From c02138cd3df913778b79675773ac17f88ae58969 Mon Sep 17 00:00:00 2001 From: george Date: Fri, 4 Dec 2009 05:11:15 +0000 Subject: [PATCH] revised back to 6/30/08 version --- r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCACM.m | 125 ++-- r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCAGST.m | 108 +-- r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCAGST1.m | 132 ++-- r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCASVC.m | 82 +-- r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDMC90.m | 389 +++++----- r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPEM.m | 332 ++++----- r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPESR2.m | 354 +++++---- r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPESR3.m | 364 ++++----- r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPESR6.m | 210 +++--- r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPESR9.m | 415 ++++++----- r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPEWL0.m | 426 ++++++----- r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPEX32.m | 190 ++--- r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPUDEP.m | 236 +++--- r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCFMOBR.m | 195 +++-- r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCMSITE.m | 132 ++-- r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCRCXM1.m | 134 ++-- r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCXVDC.m | 104 ++- r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCXVDC4.m | 164 ++--- r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCXVFTP.m | 116 +-- .../GMRACMR4.m | 149 ++-- .../GMRADSP5.m | 83 ++- .../GMRAEF2.m | 59 +- .../GMRAFDA3.m | 135 ++-- .../GMRAGUI1.m | 315 ++++---- .../GMRAPET0.m | 242 +++--- .../GMRAPFT.m | 165 +++-- r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPL.m | 219 +++--- .../GMRAPNA.m | 171 +++-- .../GMRAPST1.m | 177 +++-- .../GMRAPST2.m | 181 +++-- .../GMRAPST3.m | 161 ++-- .../GMRAPST4.m | 165 +++-- .../GMRAPST5.m | 113 ++- .../GMRAPST6.m | 191 +++-- .../GMRAPST7.m | 223 +++--- r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPU.m | 161 ++-- .../GMRAUTL1.m | 162 ++-- .../GMRAVFY.m | 65 +- r/ASISTS-OOPS/OOPSGUIR.m | 432 +++++------ r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7ADL.m | 481 ++++++------ r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7UID.m | 97 ++- r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7VIN4.m | 528 +++++++------ r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7VIN5A.m | 551 +++++++------- .../DVBCREQ1.m | 123 ++-- .../DVBCUTIL.m | 131 ++-- r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBGEN1.m | 205 +++--- r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBINP.m | 444 ++++++----- r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBPWRD.m | 400 +++++----- r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBUTL1.m | 415 ++++++----- r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBO.m | 388 +++++----- r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBO1.m | 114 +-- r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBOMH1.m | 350 ++++----- r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBPOIV.m | 290 ++++---- r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBRPC2.m | 274 +++---- r/BENEFICIARY_TRAVEL-DGBT/DGBTCE.m | 116 +-- r/BENEFICIARY_TRAVEL-DGBT/DGBTCR.m | 117 ++- r/BENEFICIARY_TRAVEL-DGBT/DGBTEE.m | 110 +-- r/BENEFICIARY_TRAVEL-DGBT/DGBTEE1.m | 128 ++-- r/BENEFICIARY_TRAVEL-DGBT/DGBTEF1.m | 122 ++- r/CLINICAL_CASE_REGISTRIES-ROR/RORHL09.m | 546 +++++++------- .../RGEVPRG.m | 416 ++++++----- .../RGEX01.m | 313 ++++---- .../RGEX06.m | 126 ++-- .../RGEX07.m | 104 +-- .../RGEXHND1.m | 347 ++++----- r/CLINICAL_PROCEDURES-MD/MDAPI.m | 439 +++++------ r/CLINICAL_PROCEDURES-MD/MDHL7A.m | 349 +++++---- r/CLINICAL_PROCEDURES-MD/MDHL7MCA.m | 132 ++-- r/CLINICAL_PROCEDURES-MD/MDHL7U3.m | 224 +----- r/CLINICAL_PROCEDURES-MD/MDHL7X.m | 68 +- r/CLINICAL_PROCEDURES-MD/MDRPCOG.m | 344 +++++---- r/CLINICAL_PROCEDURES-MD/MDRPCOP.m | 465 ++++++------ r/CLINICAL_PROCEDURES-MD/MDRPCOT.m | 451 ++++++------ r/CLINICAL_REMINDERS-PXRM/PXRM7M1.m | 33 +- r/CLINICAL_REMINDERS-PXRM/PXRM7XT.m | 507 +++++++------ r/CLINICAL_REMINDERS-PXRM/PXRMCDUE.m | 331 +++++---- r/CLINICAL_REMINDERS-PXRM/PXRMCF.m | 389 +++++----- r/CLINICAL_REMINDERS-PXRM/PXRMCOND.m | 461 ++++++------ r/CLINICAL_REMINDERS-PXRM/PXRMCOPY.m | 337 +++++---- r/CLINICAL_REMINDERS-PXRM/PXRMDATA.m | 122 +-- r/CLINICAL_REMINDERS-PXRM/PXRMDATE.m | 507 +++++++------ r/CLINICAL_REMINDERS-PXRM/PXRMDBL3.m | 316 ++++---- r/CLINICAL_REMINDERS-PXRM/PXRMDEDT.m | 605 ++++++++------- r/CLINICAL_REMINDERS-PXRM/PXRMDEV.m | 298 ++++---- r/CLINICAL_REMINDERS-PXRM/PXRMDLG4.m | 568 +++++++------- r/CLINICAL_REMINDERS-PXRM/PXRMDLG5.m | 342 +++------ r/CLINICAL_REMINDERS-PXRM/PXRMDLGZ.m | 472 ++++++------ r/CLINICAL_REMINDERS-PXRM/PXRMDLL.m | 542 +++++++------- r/CLINICAL_REMINDERS-PXRM/PXRMDLLA.m | 478 ++++++------ r/CLINICAL_REMINDERS-PXRM/PXRMDLLB.m | 324 ++++---- r/CLINICAL_REMINDERS-PXRM/PXRMDLR.m | 201 +++-- r/CLINICAL_REMINDERS-PXRM/PXRMDLR1.m | 178 ++--- r/CLINICAL_REMINDERS-PXRM/PXRMDNVA.m | 97 ++- r/CLINICAL_REMINDERS-PXRM/PXRMDRGR.m | 381 +++++----- r/CLINICAL_REMINDERS-PXRM/PXRMDRUG.m | 408 +++++----- r/CLINICAL_REMINDERS-PXRM/PXRMEDIT.m | 39 +- r/CLINICAL_REMINDERS-PXRM/PXRMENOD.m | 99 ++- r/CLINICAL_REMINDERS-PXRM/PXRMEPM.m | 354 ++++----- r/CLINICAL_REMINDERS-PXRM/PXRMETCO.m | 291 ++++---- r/CLINICAL_REMINDERS-PXRM/PXRMETH.m | 668 +++++++++-------- r/CLINICAL_REMINDERS-PXRM/PXRMETH1.m | 179 +++-- r/CLINICAL_REMINDERS-PXRM/PXRMETM.m | 389 +++++----- r/CLINICAL_REMINDERS-PXRM/PXRMETT.m | 429 +++++------ r/CLINICAL_REMINDERS-PXRM/PXRMETX.m | 551 +++++++------- r/CLINICAL_REMINDERS-PXRM/PXRMETXR.m | 499 +++++++------ r/CLINICAL_REMINDERS-PXRM/PXRMETXU.m | 122 ++- r/CLINICAL_REMINDERS-PXRM/PXRMEUT.m | 455 ++++++------ r/CLINICAL_REMINDERS-PXRM/PXRMEUT1.m | 268 +++---- r/CLINICAL_REMINDERS-PXRM/PXRMEVFI.m | 84 +-- r/CLINICAL_REMINDERS-PXRM/PXRMEXCF.m | 142 ++-- r/CLINICAL_REMINDERS-PXRM/PXRMEXCS.m | 214 ++---- r/CLINICAL_REMINDERS-PXRM/PXRMEXDG.m | 442 ++++++----- r/CLINICAL_REMINDERS-PXRM/PXRMEXFI.m | 284 ++++--- r/CLINICAL_REMINDERS-PXRM/PXRMEXID.m | 528 ++++++------- r/CLINICAL_REMINDERS-PXRM/PXRMEXIU.m | 514 ++++++------- r/CLINICAL_REMINDERS-PXRM/PXRMEXIX.m | 273 ++++--- r/CLINICAL_REMINDERS-PXRM/PXRMEXLB.m | 399 +++++----- r/CLINICAL_REMINDERS-PXRM/PXRMEXLC.m | 297 +++++--- r/CLINICAL_REMINDERS-PXRM/PXRMEXLD.m | 402 +++++++--- r/CLINICAL_REMINDERS-PXRM/PXRMEXLI.m | 324 ++++---- r/CLINICAL_REMINDERS-PXRM/PXRMEXLM.m | 490 ++++++------ r/CLINICAL_REMINDERS-PXRM/PXRMEXLR.m | 374 +++++++--- r/CLINICAL_REMINDERS-PXRM/PXRMEXPR.m | 465 ++++++------ r/CLINICAL_REMINDERS-PXRM/PXRMEXPU.m | 386 +++++----- r/CLINICAL_REMINDERS-PXRM/PXRMEXSI.m | 310 ++++---- r/CLINICAL_REMINDERS-PXRM/PXRMEXU1.m | 444 ++++++----- r/CLINICAL_REMINDERS-PXRM/PXRMEXU2.m | 391 +++++----- r/CLINICAL_REMINDERS-PXRM/PXRMEXU4.m | 461 ++++++------ r/CLINICAL_REMINDERS-PXRM/PXRMFF.m | 254 +++---- r/CLINICAL_REMINDERS-PXRM/PXRMFF0.m | 196 +++-- r/CLINICAL_REMINDERS-PXRM/PXRMFFAT.m | 108 ++- r/CLINICAL_REMINDERS-PXRM/PXRMFFDB.m | 513 +++++++------ r/CLINICAL_REMINDERS-PXRM/PXRMGECN.m | 244 +++--- r/CLINICAL_REMINDERS-PXRM/PXRMHF.m | 349 +++++---- r/CLINICAL_REMINDERS-PXRM/PXRMINDC.m | 501 +++++++------ r/CLINICAL_REMINDERS-PXRM/PXRMINDD.m | 475 ++++++------ r/CLINICAL_REMINDERS-PXRM/PXRMINDL.m | 242 +++--- r/CLINICAL_REMINDERS-PXRM/PXRMINDX.m | 334 ++++----- r/CLINICAL_REMINDERS-PXRM/PXRMISE.m | 569 +++++++------- r/CLINICAL_REMINDERS-PXRM/PXRMLCD.m | 101 ++- r/CLINICAL_REMINDERS-PXRM/PXRMLCR.m | 333 +++++---- r/CLINICAL_REMINDERS-PXRM/PXRMLIST.m | 211 +++--- r/CLINICAL_REMINDERS-PXRM/PXRMLLED.m | 186 ++--- r/CLINICAL_REMINDERS-PXRM/PXRMLOCF.m | 489 ++++++------ r/CLINICAL_REMINDERS-PXRM/PXRMLOCL.m | 308 ++++---- r/CLINICAL_REMINDERS-PXRM/PXRMLPAU.m | 360 ++++----- r/CLINICAL_REMINDERS-PXRM/PXRMLPHS.m | 167 ++--- r/CLINICAL_REMINDERS-PXRM/PXRMLPP.m | 496 ++++++------- r/CLINICAL_REMINDERS-PXRM/PXRMLPU.m | 581 ++++++++------- r/CLINICAL_REMINDERS-PXRM/PXRMLRM.m | 409 +++++----- r/CLINICAL_REMINDERS-PXRM/PXRMMH.m | 396 +++++----- r/CLINICAL_REMINDERS-PXRM/PXRMMST.m | 506 ++++++------- r/CLINICAL_REMINDERS-PXRM/PXRMOUTC.m | 278 ++++--- r/CLINICAL_REMINDERS-PXRM/PXRMOUTM.m | 262 ++++--- r/CLINICAL_REMINDERS-PXRM/PXRMPARS.m | 138 ++-- r/CLINICAL_REMINDERS-PXRM/PXRMPDR.m | 395 +++++----- r/CLINICAL_REMINDERS-PXRM/PXRMPDRP.m | 607 +++++++-------- r/CLINICAL_REMINDERS-PXRM/PXRMPDRS.m | 390 +++++----- r/CLINICAL_REMINDERS-PXRM/PXRMPLST.m | 501 ++++++------- r/CLINICAL_REMINDERS-PXRM/PXRMPTD2.m | 120 +-- r/CLINICAL_REMINDERS-PXRM/PXRMPTDF.m | 532 +++++++------ r/CLINICAL_REMINDERS-PXRM/PXRMPTTR.m | 277 ++++--- r/CLINICAL_REMINDERS-PXRM/PXRMREDF.m | 656 ++++++++--------- r/CLINICAL_REMINDERS-PXRM/PXRMREDT.m | 631 ++++++++-------- r/CLINICAL_REMINDERS-PXRM/PXRMRPCC.m | 295 ++++---- r/CLINICAL_REMINDERS-PXRM/PXRMRUL1.m | 328 +++------ r/CLINICAL_REMINDERS-PXRM/PXRMRULE.m | 519 +++++++------ r/CLINICAL_REMINDERS-PXRM/PXRMSTA1.m | 502 ++++++------- r/CLINICAL_REMINDERS-PXRM/PXRMSTA2.m | 264 ++++--- r/CLINICAL_REMINDERS-PXRM/PXRMSXRM.m | 364 +++++---- r/CLINICAL_REMINDERS-PXRM/PXRMTAX.m | 426 +++++------ r/CLINICAL_REMINDERS-PXRM/PXRMTERM.m | 420 ++++++----- r/CLINICAL_REMINDERS-PXRM/PXRMTEXT.m | 295 +++----- r/CLINICAL_REMINDERS-PXRM/PXRMTMED.m | 230 +++--- r/CLINICAL_REMINDERS-PXRM/PXRMUTIL.m | 451 +++++------- r/CLINICAL_REMINDERS-PXRM/PXRMVITL.m | 171 +++-- r/CLINICAL_REMINDERS-PXRM/PXRMVPTR.m | 87 ++- r/CLINICAL_REMINDERS-PXRM/PXRMVSIT.m | 184 +++-- r/CLINICAL_REMINDERS-PXRM/PXRMXD.m | 555 +++++++------- r/CLINICAL_REMINDERS-PXRM/PXRMXDT1.m | 372 +++++----- r/CLINICAL_REMINDERS-PXRM/PXRMXGPR.m | 466 ++++++------ r/CLINICAL_REMINDERS-PXRM/PXRMXGUT.m | 188 +++-- r/CLINICAL_REMINDERS-PXRM/PXRMXPR.m | 567 +++++++------- r/CLINICAL_REMINDERS-PXRM/PXRMXPR1.m | 232 +++--- r/CLINICAL_REMINDERS-PXRM/PXRMXQUE.m | 280 ++++--- r/CLINICAL_REMINDERS-PXRM/PXRMXSC.m | 155 ++-- r/CLINICAL_REMINDERS-PXRM/PXRMXSE1.m | 397 +++++----- r/CLINICAL_REMINDERS-PXRM/PXRMXSL1.m | 456 ++++++------ r/CLINICAL_REMINDERS-PXRM/PXRMXSL2.m | 403 +++++----- r/CLINICAL_REMINDERS-PXRM/PXRMXTB.m | 177 +++-- r/CLINICAL_REMINDERS-PXRM/PXRMXTD.m | 205 +++--- r/CLINICAL_REMINDERS-PXRM/PXRMXTE.m | 186 +++-- r/CLINICAL_REMINDERS-PXRM/PXRMXTF.m | 300 ++++---- r/CLINICAL_REMINDERS-PXRM/PXRMXTU.m | 432 +++++------ r/CMOP-PSX/PSXBLD1.m | 206 +++--- r/CMOP-PSX/PSXMISC1.m | 291 ++++---- .../GMRCP5D.m | 408 +++++----- .../GMRCSTL7.m | 454 +++++------- .../GMRCSTL8.m | 307 +++----- .../GMRCSTU.m | 447 ++++++----- r/CONTROLLED_SUBSTANCES-PSD/PSDACT1.m | 215 +++--- r/CONTROLLED_SUBSTANCES-PSD/PSDNRGS.m | 110 ++- r/CONTROLLED_SUBSTANCES-PSD/PSDNTF.m | 161 ++-- r/CONTROLLED_SUBSTANCES-PSD/PSDNTT.m | 80 +- r/CONTROLLED_SUBSTANCES-PSD/PSDSITE.m | 100 +-- r/DIETETICS-FH/FHASM1.m | 358 ++++----- r/DIETETICS-FH/FHASM3.m | 193 +++-- r/DIETETICS-FH/FHASM7.m | 312 ++++---- r/DIETETICS-FH/FHASMR2.m | 362 ++++----- r/DIETETICS-FH/FHASP1.m | 164 ++--- r/DIETETICS-FH/FHDSSAPI.m | 171 ++--- r/DIETETICS-FH/FHNO2.m | 233 +++--- r/DIETETICS-FH/FHOMPP.m | 160 ++-- r/DIETETICS-FH/FHORC5.m | 42 +- r/DIETETICS-FH/FHPRO.m | 99 ++- r/DIETETICS-FH/FHPRW.m | 146 ++-- r/DIETETICS-FH/FHREP1.m | 172 ++--- r/DIETETICS-FH/FHSELA1.m | 341 +++++---- r/DIETETICS-FH/FHSELA2.m | 618 ++++++++-------- r/DRUG_ACCOUNTABILITY-PSA/PSABRKU3.m | 209 +++--- r/DRUG_ACCOUNTABILITY-PSA/PSABRKU5.m | 75 +- r/DRUG_ACCOUNTABILITY-PSA/PSAENTO.m | 208 +++--- r/DRUG_ACCOUNTABILITY-PSA/PSAORDP1.m | 297 ++++---- r/DRUG_ACCOUNTABILITY-PSA/PSAPROC4.m | 242 +++--- r/DRUG_ACCOUNTABILITY-PSA/PSAPROC7.m | 333 ++++----- r/DRUG_ACCOUNTABILITY-PSA/PSAUDP.m | 116 ++- r/DRUG_ACCOUNTABILITY-PSA/PSAUP4.m | 353 +++++---- r/DRUG_ACCOUNTABILITY-PSA/PSAUTL1.m | 241 +++--- r/DRUG_ACCOUNTABILITY-PSA/PSAUTL4.m | 163 ++-- r/DRUG_ACCOUNTABILITY-PSA/PSAVER7.m | 189 +++-- r/DRUG_ACCOUNTABILITY-PSA/PSAVERA.m | 226 +++--- r/DRUG_ACCOUNTABILITY-PSA/PSAVERA1.m | 218 +++--- r/DSS_EXTRACTS-ECX/ECX802.m | 2 +- r/DSS_EXTRACTS-ECX/ECX8021.m | 2 +- r/DSS_EXTRACTS-ECX/ECX8022.m | 2 +- r/DSS_EXTRACTS-ECX/ECX808.m | 2 +- r/DSS_EXTRACTS-ECX/ECX8081.m | 2 +- r/DSS_EXTRACTS-ECX/ECX8082.m | 2 +- r/DSS_EXTRACTS-ECX/ECX809.m | 2 +- r/DSS_EXTRACTS-ECX/ECX8091.m | 2 +- r/DSS_EXTRACTS-ECX/ECX8092.m | 2 +- r/DSS_EXTRACTS-ECX/ECX810.m | 2 +- r/DSS_EXTRACTS-ECX/ECX8101.m | 2 +- r/DSS_EXTRACTS-ECX/ECX8102.m | 2 +- r/DSS_EXTRACTS-ECX/ECX811.m | 2 +- r/DSS_EXTRACTS-ECX/ECX8111.m | 2 +- r/DSS_EXTRACTS-ECX/ECX8112.m | 2 +- r/DSS_EXTRACTS-ECX/ECX813.m | 2 +- r/DSS_EXTRACTS-ECX/ECX8131.m | 2 +- r/DSS_EXTRACTS-ECX/ECX8132.m | 2 +- r/DSS_EXTRACTS-ECX/ECX814.m | 2 +- r/DSS_EXTRACTS-ECX/ECX8141.m | 2 +- r/DSS_EXTRACTS-ECX/ECX8142.m | 2 +- r/DSS_EXTRACTS-ECX/ECX815.m | 2 +- r/DSS_EXTRACTS-ECX/ECX8151.m | 2 +- r/DSS_EXTRACTS-ECX/ECX8152.m | 2 +- r/DSS_EXTRACTS-ECX/ECX817.m | 2 +- r/DSS_EXTRACTS-ECX/ECX8171.m | 2 +- r/DSS_EXTRACTS-ECX/ECX8172.m | 2 +- r/DSS_EXTRACTS-ECX/ECX819.m | 2 +- r/DSS_EXTRACTS-ECX/ECX8191.m | 2 +- r/DSS_EXTRACTS-ECX/ECX8192.m | 2 +- r/DSS_EXTRACTS-ECX/ECX824.m | 2 +- r/DSS_EXTRACTS-ECX/ECX8241.m | 2 +- r/DSS_EXTRACTS-ECX/ECX8242.m | 2 +- r/DSS_EXTRACTS-ECX/ECX825.m | 2 +- r/DSS_EXTRACTS-ECX/ECX8251.m | 2 +- r/DSS_EXTRACTS-ECX/ECX8252.m | 2 +- r/DSS_EXTRACTS-ECX/ECX826.m | 2 +- r/DSS_EXTRACTS-ECX/ECX8261.m | 2 +- r/DSS_EXTRACTS-ECX/ECX8262.m | 2 +- r/DSS_EXTRACTS-ECX/ECX827.m | 2 +- r/DSS_EXTRACTS-ECX/ECX8271.m | 2 +- r/DSS_EXTRACTS-ECX/ECX8272.m | 2 +- r/DSS_EXTRACTS-ECX/ECXADM.m | 392 +++++----- r/DSS_EXTRACTS-ECX/ECXAPHA2.m | 221 +++--- r/DSS_EXTRACTS-ECX/ECXATRT.m | 338 ++++----- r/DSS_EXTRACTS-ECX/ECXDIVIV.m | 172 +++-- r/DSS_EXTRACTS-ECX/ECXDRUG2.m | 192 +++-- r/DSS_EXTRACTS-ECX/ECXDVSN.m | 448 ++++++----- r/DSS_EXTRACTS-ECX/ECXDVSN1.m | 316 ++++---- r/DSS_EXTRACTS-ECX/ECXEC.m | 361 +++++---- r/DSS_EXTRACTS-ECX/ECXFELOC.m | 122 ++- r/DSS_EXTRACTS-ECX/ECXKILL.m | 75 +- r/DSS_EXTRACTS-ECX/ECXLABN.m | 303 ++++---- r/DSS_EXTRACTS-ECX/ECXLABR.m | 239 +++--- r/DSS_EXTRACTS-ECX/ECXLBB.m | 423 ++++++----- r/DSS_EXTRACTS-ECX/ECXMOV.m | 216 +++--- r/DSS_EXTRACTS-ECX/ECXMTL.m | 333 ++++----- r/DSS_EXTRACTS-ECX/ECXNUT.m | 291 ++++---- r/DSS_EXTRACTS-ECX/ECXNUT1.m | 322 +++----- r/DSS_EXTRACTS-ECX/ECXOPRX.m | 255 ++++--- r/DSS_EXTRACTS-ECX/ECXOPRX1.m | 96 ++- r/DSS_EXTRACTS-ECX/ECXPIVDN.m | 301 ++++---- r/DSS_EXTRACTS-ECX/ECXPLBB.m | 196 ++--- r/DSS_EXTRACTS-ECX/ECXPRO.m | 304 ++++---- r/DSS_EXTRACTS-ECX/ECXPRO1.m | 293 ++++---- r/DSS_EXTRACTS-ECX/ECXPURG.m | 146 ++-- r/DSS_EXTRACTS-ECX/ECXPURG1.m | 245 +++--- r/DSS_EXTRACTS-ECX/ECXQSR.m | 340 +++++---- r/DSS_EXTRACTS-ECX/ECXRAD.m | 263 ++++--- r/DSS_EXTRACTS-ECX/ECXSCLD.m | 206 +++--- r/DSS_EXTRACTS-ECX/ECXSCX1.m | 423 +++++------ r/DSS_EXTRACTS-ECX/ECXSCX2.m | 139 ++-- r/DSS_EXTRACTS-ECX/ECXSCXN.m | 317 ++++---- r/DSS_EXTRACTS-ECX/ECXSCXN1.m | 94 +-- r/DSS_EXTRACTS-ECX/ECXSURG.m | 447 +++++------ r/DSS_EXTRACTS-ECX/ECXTRAC.m | 406 +++++----- r/DSS_EXTRACTS-ECX/ECXTREX.m | 178 ++--- r/DSS_EXTRACTS-ECX/ECXTRT.m | 392 +++++----- r/DSS_EXTRACTS-ECX/ECXUD.m | 362 +++++---- r/DSS_EXTRACTS-ECX/ECXUPRO.m | 229 +++--- r/DSS_EXTRACTS-ECX/ECXUPRO1.m | 108 +-- r/DSS_EXTRACTS-ECX/ECXUSUR.m | 241 +++--- r/DSS_EXTRACTS-ECX/ECXUSUR1.m | 243 +++--- r/DSS_EXTRACTS-ECX/ECXUTL2.m | 475 ++++++------ r/DSS_EXTRACTS-ECX/ECXUTL3.m | 483 ++++++------ r/DSS_EXTRACTS-ECX/ECXUTL4.m | 560 +++++++------- r/DSS_EXTRACTS-ECX/ECXUTL5.m | 432 ++++++----- r/DSS_EXTRACTS-ECX/ECXUTL6.m | 303 ++++---- r/ENGINEERING-EN/ENEQ4.m | 129 ++-- r/ENGINEERING-EN/ENPLS2.m | 178 +++-- r/EVENT_CAPTURE-EC--ECT--ECX/ECRRPT.m | 390 +++++----- r/EVENT_CAPTURE-EC--ECT--ECX/ECUMRPC1.m | 437 ++++++----- r/EVENT_CAPTURE-EC--ECT--ECX/ECUURPC.m | 181 +++-- r/FEE_BASIS-FB/FBAA79.m | 115 ++- r/FEE_BASIS-FB/FBAA79A.m | 66 +- r/FEE_BASIS-FB/FBAAAUT.m | 94 +-- r/FEE_BASIS-FB/FBAADEM1.m | 100 ++- r/FEE_BASIS-FB/FBAAFSR.m | 454 ++++++------ r/FEE_BASIS-FB/FBCH78.m | 154 ++-- r/FEE_BASIS-FB/FBCH78A.m | 61 +- r/FEE_BASIS-FB/FBCHP78.m | 113 ++- r/FEE_BASIS-FB/FBCHREQ1.m | 61 +- r/FEE_BASIS-FB/FBCTAU.m | 4 +- r/FEE_BASIS-FB/FBCTAU1.m | 66 +- r/FEE_BASIS-FB/FBCTAU2.m | 212 +++++- r/FEE_BASIS-FB/FBCTAU3.m | 191 +---- r/FEE_BASIS-FB/FBNHEAU1.m | 37 +- r/FEE_BASIS-FB/FBNHEAUT.m | 113 ++- r/FEE_BASIS-FB/FBNHEDAT.m | 79 +- r/FEE_BASIS-FB/FBPCR.m | 343 +++++---- r/HEALTH_LEVEL_SEVEN-HL/HLCS.m | 397 +++++----- r/HEALTH_LEVEL_SEVEN-HL/HLCS2.m | 329 ++++----- r/HEALTH_LEVEL_SEVEN-HL/HLCSGTM.m | 133 ++-- r/HEALTH_LEVEL_SEVEN-HL/HLCSHDR1.m | 491 ++++++------ r/HEALTH_LEVEL_SEVEN-HL/HLCSHDR4.m | 510 +++++++------ r/HEALTH_LEVEL_SEVEN-HL/HLCSIN.m | 256 +++---- r/HEALTH_LEVEL_SEVEN-HL/HLCSLM.m | 483 ++++++------ r/HEALTH_LEVEL_SEVEN-HL/HLCSLNCH.m | 295 ++++---- r/HEALTH_LEVEL_SEVEN-HL/HLCSMON.m | 484 ++++++------ r/HEALTH_LEVEL_SEVEN-HL/HLCSMON1.m | 154 ++-- r/HEALTH_LEVEL_SEVEN-HL/HLCSREP.m | 116 ++- r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP.m | 499 ++++++------- r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP1.m | 578 +++++++-------- r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP2.m | 549 +++++++------- r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP3.m | 180 ++--- r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP4.m | 365 +++------ r/HEALTH_LEVEL_SEVEN-HL/HLCSTCPA.m | 154 ++-- r/HEALTH_LEVEL_SEVEN-HL/HLCSTERM.m | 73 +- r/HEALTH_LEVEL_SEVEN-HL/HLDIE.m | 542 +++++++------- r/HEALTH_LEVEL_SEVEN-HL/HLFNC.m | 427 ++++++----- r/HEALTH_LEVEL_SEVEN-HL/HLMA.m | 393 +++++----- r/HEALTH_LEVEL_SEVEN-HL/HLOAPI1.m | 435 +++++------ r/HEALTH_LEVEL_SEVEN-HL/HLOAPI2.m | 335 ++++----- r/HEALTH_LEVEL_SEVEN-HL/HLOAPI3.m | 390 +++++----- r/HEALTH_LEVEL_SEVEN-HL/HLOAPP.m | 214 +++--- r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT.m | 386 +++++----- r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT1.m | 308 ++++---- r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT2.m | 364 +++++---- r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT3.m | 78 +- r/HEALTH_LEVEL_SEVEN-HL/HLOCNRT.m | 162 ++-- r/HEALTH_LEVEL_SEVEN-HL/HLOF778.m | 302 ++++---- r/HEALTH_LEVEL_SEVEN-HL/HLOF778A.m | 347 +++++---- r/HEALTH_LEVEL_SEVEN-HL/HLOFILER.m | 330 ++++----- r/HEALTH_LEVEL_SEVEN-HL/HLOMSG.m | 439 ++++++----- r/HEALTH_LEVEL_SEVEN-HL/HLOPOST.m | 172 ++--- r/HEALTH_LEVEL_SEVEN-HL/HLOPURGE.m | 329 ++++----- r/HEALTH_LEVEL_SEVEN-HL/HLOQUE.m | 311 +++----- r/HEALTH_LEVEL_SEVEN-HL/HLOSRVR.m | 409 +++++----- r/HEALTH_LEVEL_SEVEN-HL/HLOSRVR1.m | 471 ++++++------ r/HEALTH_LEVEL_SEVEN-HL/HLOSRVR2.m | 143 ++-- r/HEALTH_LEVEL_SEVEN-HL/HLOTCP.m | 412 +++++------ r/HEALTH_LEVEL_SEVEN-HL/HLOUSR.m | 569 +++++++------- r/HEALTH_LEVEL_SEVEN-HL/HLOUSR1.m | 530 +++++++------ r/HEALTH_LEVEL_SEVEN-HL/HLOUSR2.m | 467 ++++++------ r/HEALTH_LEVEL_SEVEN-HL/HLTF.m | 420 ++++++----- r/HEALTH_LEVEL_SEVEN-HL/HLTF1.m | 314 ++++---- r/HEALTH_LEVEL_SEVEN-HL/HLTF2.m | 302 +++----- r/HEALTH_LEVEL_SEVEN-HL/HLTP3.m | 511 +++++++------ r/HEALTH_LEVEL_SEVEN-HL/HLTPCK2B.m | 409 +++++----- r/HEALTH_SUMMARY-GMTS/GMTSDA.m | 87 ++- r/HEALTH_SUMMARY-GMTS/GMTSPSO.m | 129 ++-- r/HEALTH_SUMMARY-GMTS/GMTSPSO7.m | 117 ++- r/HEALTH_SUMMARY-GMTS/GMTSPSZO.m | 82 +-- r/HEALTH_SUMMARY-GMTS/GMTSRAE.m | 387 +++++----- r/HEALTH_SUMMARY-GMTS/GMTSRAS.m | 318 ++++---- r/HEALTH_SUMMARY-GMTS/GMTSUP.m | 367 +++++---- r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE.m | 45 +- r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE1.m | 10 +- r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE10.m | 12 +- r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE11.m | 22 +- r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE12.m | 20 +- r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE13.m | 182 ++++- r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE14.m | 273 +++---- r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE15.m | 8 +- r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE16.m | 20 +- r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE17.m | 8 +- r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE18.m | 210 ++---- r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE19.m | 12 +- r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE2.m | 6 +- r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE20.m | 183 ++++- r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE21.m | 38 +- r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE22.m | 264 +------ r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE23.m | 199 ++++- r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE24.m | 6 +- r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE25.m | 250 +------ r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE26.m | 173 ++++- r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE27.m | 248 +------ r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE28.m | 150 +--- r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE29.m | 217 ++++-- r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE3.m | 197 ++++- r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE4.m | 266 +------ r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE5.m | 6 +- r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE6.m | 206 +++++- r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE7.m | 231 +++++- r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE8.m | 241 +----- r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE9.m | 86 +-- r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCG.m | 2 +- r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFACPS.m | 72 +- r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFALOG.m | 75 +- r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHEF.m | 50 +- r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHMA.m | 365 ++++----- r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHNPO3.m | 188 +++-- r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHNPO5.m | 269 ++++--- r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHNPO8.m | 95 ++- r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHPCAR.m | 180 +++-- r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHQ4.m | 286 +++---- r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPLO2A.m | 415 ++++++----- r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPUSEL.m | 262 +++---- r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSD122.m | 58 +- r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSP122.m | 64 +- r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSRIG1.m | 166 ++--- r/IFCAP-PRC-PRX--PRCA--PRCN/PRCVRC2.m | 447 ++++++----- r/IFCAP-PRC-PRX--PRCA--PRCN/PRCVRE1.m | 446 ++++++----- r/IFCAP-PRC-PRX--PRCA--PRCN/PRCVREA.m | 260 ++++--- r/IHS_ROUTINES-AUP/AUPNSICD.m | 71 +- r/IMAGING-MAG-ZMAG/MAGBAPIP.m | 127 ++-- r/IMAGING-MAG-ZMAG/MAGGNLKP.m | 193 ++--- r/IMAGING-MAG-ZMAG/MAGGNTI.m | 281 +++---- r/IMAGING-MAG-ZMAG/MAGGNTI1.m | 403 +++++----- r/IMAGING-MAG-ZMAG/MAGGNTI2.m | 236 +++--- r/IMAGING-MAG-ZMAG/MAGGNTI3.m | 178 ++--- r/IMAGING-MAG-ZMAG/MAGGSIA.m | 323 ++++---- r/IMAGING-MAG-ZMAG/MAGGSIA1.m | 319 ++++---- r/IMAGING-MAG-ZMAG/MAGGSIU2.m | 173 +++-- r/IMAGING-MAG-ZMAG/MAGGSIUI.m | 391 +++++----- r/IMAGING-MAG-ZMAG/MAGGSIV.m | 347 +++++---- r/IMAGING-MAG-ZMAG/MAGGSIV1.m | 243 +++--- r/IMAGING-MAG-ZMAG/MAGGTAU.m | 457 ++++++------ r/IMAGING-MAG-ZMAG/MAGGTERR.m | 119 ++- r/IMAGING-MAG-ZMAG/MAGGTIA1.m | 345 ++++----- r/IMAGING-MAG-ZMAG/MAGGTID.m | 389 +++++----- r/IMAGING-MAG-ZMAG/MAGGTII.m | 424 +++++------ r/IMAGING-MAG-ZMAG/MAGGTLB1.m | 241 +++--- r/IMAGING-MAG-ZMAG/MAGGTMC1.m | 162 ++-- r/IMAGING-MAG-ZMAG/MAGGTPT1.m | 342 ++++----- r/IMAGING-MAG-ZMAG/MAGGTRA.m | 149 ++-- r/IMAGING-MAG-ZMAG/MAGGTSR.m | 172 ++--- r/IMAGING-MAG-ZMAG/MAGGTSR1.m | 106 ++- r/IMAGING-MAG-ZMAG/MAGGTSY2.m | 80 +- r/IMAGING-MAG-ZMAG/MAGGTSYS.m | 123 ++-- r/IMAGING-MAG-ZMAG/MAGGTU1.m | 111 ++- r/IMAGING-MAG-ZMAG/MAGGTU3.m | 383 ++++++---- r/IMAGING-MAG-ZMAG/MAGGTU31.m | 221 ++---- r/IMAGING-MAG-ZMAG/MAGGTU4.m | 361 +++++---- r/IMAGING-MAG-ZMAG/MAGGTU41.m | 249 ++++--- r/IMAGING-MAG-ZMAG/MAGGTU6.m | 381 +++++----- r/IMAGING-MAG-ZMAG/MAGGTU71.m | 144 ++-- r/IMAGING-MAG-ZMAG/MAGGTU9.m | 254 +++---- r/IMAGING-MAG-ZMAG/MAGGTUP.m | 247 +++---- r/IMAGING-MAG-ZMAG/MAGJEX1B.m | 244 +++--- r/IMAGING-MAG-ZMAG/MAGJEX2.m | 337 +++++---- r/IMAGING-MAG-ZMAG/MAGJLS2.m | 435 +++++------ r/IMAGING-MAG-ZMAG/MAGJLS2B.m | 387 +++++----- r/IMAGING-MAG-ZMAG/MAGJLS4.m | 315 ++++---- r/IMAGING-MAG-ZMAG/MAGJLST1.m | 317 ++++---- r/IMAGING-MAG-ZMAG/MAGJMN1.m | 460 ++++++------ r/IMAGING-MAG-ZMAG/MAGJUPD1.m | 337 +++++---- r/IMAGING-MAG-ZMAG/MAGJUPD2.m | 403 +++++----- r/IMAGING-MAG-ZMAG/MAGJUTL1.m | 398 +++++----- r/IMAGING-MAG-ZMAG/MAGJUTL2.m | 347 +++++---- r/IMAGING-MAG-ZMAG/MAGJUTL3.m | 472 ++++++------ r/IMAGING-MAG-ZMAG/MAGJUTL4.m | 361 +++++---- r/IMAGING-MAG-ZMAG/MAGJUTL5.m | 232 +++--- r/IMAGING-MAG-ZMAG/MAGLOG.m | 98 ++- r/IMAGING-MAG-ZMAG/MAGSIXG1.m | 329 ++++----- r/IMAGING-MAG-ZMAG/MAGSIXGT.m | 466 ++++++------ r/INCOME_VERIFICATION_MATCH-IVM/IVMCM.m | 526 +++++++------ r/INCOME_VERIFICATION_MATCH-IVM/IVMLDEM9.m | 411 ++++++----- r/INCOME_VERIFICATION_MATCH-IVM/IVMZ072.m | 137 ++-- r/INCOME_VERIFICATION_MATCH-IVM/IVMZ07C.m | 363 ++++----- r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CD.m | 256 +++---- r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CE.m | 171 +++-- r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CR.m | 499 ++++++------- .../PSGOE1.m | 199 ++--- .../PSGOE6.m | 172 +++-- .../PSGOEC.m | 260 +++---- .../PSGOECS.m | 266 ++++--- .../PSGOEF.m | 290 ++++---- .../PSGOT.m | 76 +- .../PSGPLR.m | 177 +++-- .../PSGS0.m | 325 ++++---- .../PSGSICHK.m | 279 +++---- .../PSGXR3.m | 2 +- .../PSGXR31.m | 2 +- .../PSGXR310.m | 2 +- .../PSGXR311.m | 2 +- .../PSGXR312.m | 2 +- .../PSGXR32.m | 2 +- .../PSGXR33.m | 2 +- .../PSGXR34.m | 2 +- .../PSGXR35.m | 2 +- .../PSGXR36.m | 2 +- .../PSGXR37.m | 2 +- .../PSGXR38.m | 2 +- .../PSGXR39.m | 2 +- .../PSIVCAL.m | 279 ++++--- .../PSIVEDT.m | 253 ++++--- .../PSIVORA.m | 204 ++--- .../PSIVORC.m | 201 +++-- .../PSIVORC1.m | 224 +++--- .../PSIVOREN.m | 179 ++--- .../PSIVORFA.m | 160 ++-- .../PSIVORFB.m | 259 +++---- .../PSIVSP.m | 213 +++--- .../PSIVUTL1.m | 225 +++--- .../PSJHL2.m | 229 +++--- .../PSJHL3.m | 307 ++++---- .../PSJHL4.m | 398 +++++----- .../PSJHL4A.m | 281 +++---- .../PSJHL5.m | 176 +++-- .../PSJHL9.m | 279 ++++--- .../PSJHLU.m | 192 ++--- .../PSJLIACT.m | 305 ++++---- .../PSJLIVFD.m | 291 ++++---- .../PSJLIVMD.m | 423 ++++++----- .../PSJLMPRU.m | 115 ++- .../PSJLMUDE.m | 264 +++---- .../PSJLMUT1.m | 319 ++++---- .../PSJLMUT2.m | 183 +++-- .../PSJMPEND.m | 111 ++- .../PSJOERI.m | 86 ++- .../PSJOREN.m | 99 ++- .../PSJORPOE.m | 232 +++--- .../PSJORRE.m | 182 ++--- .../PSJORRE1.m | 242 +++--- .../PSJORREN.m | 172 ++--- .../PSJORUT2.m | 287 ++++---- .../PSJUTL.m | 423 ++++++----- .../IBATER.m | 90 +-- .../IBATFILE.m | 394 +++++----- .../IBATLM1B.m | 362 ++++----- .../IBATLM2A.m | 366 ++++----- .../IBATO1.m | 420 +++++------ .../IBATUTL.m | 342 +++++---- .../IBCBB.m | 321 +++----- .../IBCBB1.m | 413 ++++++----- .../IBCBB11.m | 171 ++--- .../IBCBB2.m | 258 ++++--- .../IBCBB3.m | 392 +++++----- .../IBCBB5.m | 111 ++- .../IBCBB9.m | 79 +- .../IBCC1.m | 205 ++---- .../IBCCC2.m | 400 +++++----- .../IBCCC3.m | 116 +-- .../IBCE.m | 187 +++-- .../IBCE277.m | 436 ++++++----- .../IBCE835.m | 469 ++++++------ .../IBCE837A.m | 366 +++++---- .../IBCEBUL.m | 121 +-- .../IBCECOB1.m | 407 +++++----- .../IBCECSA1.m | 341 +++++---- .../IBCECSA3.m | 289 ++++---- .../IBCECSA4.m | 445 ++++++----- .../IBCEF.m | 500 +++++++------ .../IBCEF1.m | 436 ++++++----- .../IBCEF11.m | 383 +++++----- .../IBCEF21.m | 227 ++---- .../IBCEF22.m | 258 +++---- .../IBCEF3.m | 478 ++++++------ .../IBCEF73.m | 541 +++++++------- .../IBCEF73A.m | 286 ++++--- .../IBCEF74A.m | 243 +++--- .../IBCEF75.m | 316 ++++---- .../IBCEFG1.m | 263 +++---- .../IBCEM.m | 377 +++++----- .../IBCEM4.m | 292 ++++---- .../IBCEMCA2.m | 235 +++--- .../IBCEOB.m | 513 ++++++------- .../IBCEOB00.m | 445 ++++++----- .../IBCEP0.m | 420 +++++------ .../IBCEP0A.m | 362 +++++---- .../IBCEP4.m | 256 +++---- .../IBCEP4A.m | 336 ++++----- .../IBCEP5.m | 321 ++++---- .../IBCEP6.m | 235 +++--- .../IBCEP8.m | 503 +++++++------ .../IBCEP81.m | 339 ++++----- .../IBCEP82.m | 347 ++++----- .../IBCEPA.m | 507 +++++++------ .../IBCERP3.m | 192 ++--- .../IBCEST.m | 442 ++++++----- .../IBCEST1.m | 81 +- .../IBCEU1.m | 374 +++++----- .../IBCEU3.m | 437 +++++------ .../IBCEU6.m | 155 ++-- .../IBCEXTRP.m | 280 +++---- .../IBCF331.m | 78 +- .../IBCF4.m | 210 +++--- .../IBCNADD.m | 135 ++-- .../IBCNBCD.m | 261 ++++--- .../IBCNBEE.m | 338 ++++----- .../IBCNBLE.m | 375 +++++----- .../IBCNBMI.m | 361 +++++---- .../IBCNEBF.m | 343 +++++---- .../IBCNQ.m | 250 +++---- .../IBCNRDV.m | 408 +++++----- .../IBCNS1.m | 424 ++++++----- .../IBCNSC.m | 240 +++--- .../IBCNSC0.m | 120 +-- .../IBCNSC01.m | 366 +++++---- .../IBCNSC02.m | 508 ++++++------- .../IBCNSC1.m | 437 ++++++----- .../IBCNSEH.m | 81 +- .../IBCNSM32.m | 220 +++--- .../IBCNSP.m | 295 ++++---- .../IBCNSP0.m | 250 +++---- .../IBCNSP01.m | 217 +++--- .../IBCNSP1.m | 362 +++------ .../IBCNSP2.m | 247 +++---- .../IBCNSP3.m | 328 ++++----- .../IBCNSU.m | 395 +++++----- .../IBCNSU1.m | 272 +++---- .../IBCRBC.m | 361 ++++----- .../IBCRBC1.m | 356 ++++----- .../IBCRBC2.m | 275 ++++--- .../IBCRBG.m | 343 ++++----- .../IBCRBH1.m | 384 +++++----- .../IBCRCC.m | 231 +++--- .../IBCRHBRV.m | 358 ++++----- .../IBCRHBS8.m | 379 +++++----- .../IBCSC3.m | 203 +++-- .../IBCSC5.m | 145 ++-- .../IBCSC5B.m | 271 +++---- .../IBCSC61.m | 82 +-- .../IBCSC8H.m | 241 +++--- .../IBCSCE.m | 171 +++-- .../IBCSCH.m | 284 ++++--- .../IBCSCH1.m | 173 ++--- .../IBCU4.m | 231 +++--- .../IBCU7.m | 310 ++++---- .../IBCVA0.m | 85 +-- .../IBCVA1.m | 222 +++--- .../IBJDB1.m | 226 +++--- .../IBJDB11.m | 357 +++++---- .../IBJPS.m | 132 ++-- .../IBJPS2.m | 297 ++++---- .../IBJTA1.m | 183 +++-- .../IBJTBA.m | 334 ++++----- .../IBJTCA2.m | 254 +++---- .../IBJTRA1.m | 132 ++-- .../IBJTTC.m | 201 +++-- .../IBRFN3.m | 286 +++---- .../IBRFN4.m | 284 +++---- .../IBTOBI1.m | 198 +++-- .../IBTOBI4.m | 212 +++--- .../IBTRED01.m | 162 ++-- .../IBTRKR5.m | 272 +++---- .../IBXBCR2.m | 6 +- .../IBXSC1.m | 2 +- .../IBXSC11.m | 74 +- .../IBXSC110.m | 20 +- .../IBXSC111.m | 18 +- .../IBXSC112.m | 20 +- .../IBXSC113.m | 245 +----- .../IBXSC114.m | 225 +++++- .../IBXSC12.m | 2 +- .../IBXSC13.m | 22 +- .../IBXSC14.m | 28 +- .../IBXSC15.m | 26 +- .../IBXSC16.m | 269 +------ .../IBXSC17.m | 230 +++++- .../IBXSC18.m | 20 +- .../IBXSC19.m | 20 +- .../IBXSC3.m | 2 +- .../IBXSC31.m | 2 +- .../IBXSC32.m | 2 +- .../IBXSC33.m | 6 +- .../IBXSC34.m | 2 +- .../IBXSC35.m | 2 +- .../IBXSC36.m | 14 +- .../IBXSC37.m | 14 +- .../IBXSC38.m | 10 +- .../IBXSC39.m | 2 +- .../IBXSC4.m | 4 +- .../IBXSC41.m | 2 +- .../IBXSC42.m | 6 +- .../IBXSC43.m | 2 +- .../IBXSC44.m | 25 +- .../IBXSC5.m | 4 +- .../IBXSC51.m | 2 +- .../IBXSC52.m | 6 +- .../IBXSC53.m | 2 +- .../IBXSC54.m | 25 +- .../IBXSC6.m | 2 +- .../IBXSC61.m | 2 +- .../IBXSC610.m | 2 +- .../IBXSC611.m | 2 +- .../IBXSC612.m | 2 +- .../IBXSC62.m | 2 +- .../IBXSC63.m | 2 +- .../IBXSC64.m | 2 +- .../IBXSC65.m | 2 +- .../IBXSC66.m | 2 +- .../IBXSC67.m | 2 +- .../IBXSC68.m | 2 +- .../IBXSC69.m | 2 +- .../IBXSC7.m | 42 +- .../IBXSC71.m | 2 +- .../IBXSC710.m | 2 +- .../IBXSC711.m | 2 +- .../IBXSC712.m | 2 +- .../IBXSC72.m | 2 +- .../IBXSC73.m | 14 +- .../IBXSC74.m | 251 +------ .../IBXSC75.m | 306 ++++---- .../IBXSC76.m | 14 +- .../IBXSC77.m | 6 +- .../IBXSC78.m | 128 +++- .../IBXSC79.m | 2 +- .../IBXX.m | 18 +- .../IBXX1.m | 48 +- .../IBXX10.m | 2 +- .../IBXX11.m | 2 +- .../IBXX12.m | 2 +- .../IBXX13.m | 21 +- .../IBXX14.m | 169 ++++- .../IBXX15.m | 253 +++---- .../IBXX16.m | 169 ++--- .../IBXX17.m | 72 +- .../IBXX18.m | 2 +- .../IBXX19.m | 2 +- .../IBXX2.m | 50 +- .../IBXX20.m | 2 +- .../IBXX21.m | 2 +- .../IBXX22.m | 2 +- .../IBXX23.m | 2 +- .../IBXX24.m | 2 +- .../IBXX25.m | 2 +- .../IBXX26.m | 2 +- .../IBXX27.m | 2 +- .../IBXX28.m | 25 +- .../IBXX3.m | 2 +- .../IBXX4.m | 2 +- .../IBXX5.m | 2 +- .../IBXX6.m | 2 +- .../IBXX7.m | 2 +- .../IBXX8.m | 2 +- .../IBXX9.m | 2 +- .../PRPFED2.m | 30 +- .../XGKB.m | 128 ++-- .../XPDDP.m | 374 ++++------ .../XPDIA3.m | 174 +++-- .../XPDIST.m | 182 ++--- .../XPDTA.m | 282 ++++--- .../XPDTA2.m | 100 ++- .../XQ3.m | 191 +++-- .../XQ5.m | 197 +++-- .../XQ55.m | 202 +++-- .../XQ81.m | 508 +++++++------ .../XQALDATA.m | 110 ++- .../XQALDEL.m | 350 ++++----- .../XQALERT1.m | 323 ++++---- .../XQALMAKE.m | 72 +- .../XQALSET.m | 316 ++++---- .../XQALSET1.m | 67 +- .../XQALSUR1.m | 337 ++++----- .../XQALSURO.m | 368 +++++---- .../XQARPRT2.m | 301 ++++---- .../XQCHK.m | 318 ++++++-- .../XQCHK2.m | 83 +-- .../XQOR.m | 130 ++-- .../XQOR4.m | 94 +-- .../XUP.m | 134 ++-- .../XUPROD.m | 95 ++- .../XUS.m | 353 +++++---- .../XUS2.m | 376 +++++----- .../XUSCLEAN.m | 176 +++-- .../XUSERBLK.m | 362 +++++---- .../XUSERNEW.m | 216 +++--- .../XUSNPI.m | 390 +++++----- .../XUSNPIDA.m | 688 +++++++++-------- .../XUSNPIE1.m | 263 ++++--- .../XUSNPIE2.m | 317 ++++---- .../XUSNPIED.m | 263 ++++--- .../XUSNPIX1.m | 522 +++++++------ .../XUSNPIX2.m | 599 +++++++-------- .../XUSNPIX3.m | 312 ++++---- .../XUSNPIX4.m | 509 ++++++------- .../XUSNPIX5.m | 196 ++--- .../ZIS.m | 190 +++-- .../ZIS1.m | 195 +++-- .../ZIS2.m | 184 +++-- .../ZIS3.m | 153 ++-- .../ZIS4GTM.m | 212 +++--- .../ZIS4ONT.m | 258 ++++--- .../ZIS6.m | 189 +++-- .../ZISC.m | 261 +++---- .../ZISEDIT.m | 72 +- .../ZISHONT.m | 527 +++++++------ .../ZISS1.m | 157 ++-- .../ZOSFONT.m | 231 +++--- .../ZOSVONT.m | 333 +++++---- .../ZTLOAD4.m | 117 ++- .../_ZIS.m | 190 +++-- .../_ZIS1.m | 195 +++-- .../_ZIS2.m | 184 +++-- .../_ZIS3.m | 153 ++-- .../_ZIS4.m | 212 +++--- .../_ZIS6.m | 189 +++-- .../_ZISC.m | 261 +++---- .../_ZISS1.m | 157 ++-- .../_ZTLOAD4.m | 117 ++- r/LAB_SERVICE-LR-LS/LR7OB69.m | 109 +-- r/LAB_SERVICE-LR-LS/LR7OGG.m | 293 ++++---- r/LAB_SERVICE-LR-LS/LR7OGMG.m | 152 ++-- r/LAB_SERVICE-LR-LS/LR7OGMM.m | 73 +- r/LAB_SERVICE-LR-LS/LR7OSAP2.m | 381 +++++----- r/LAB_SERVICE-LR-LS/LRAPBR1.m | 518 +++++++------ r/LAB_SERVICE-LR-LS/LRAPDA.m | 513 +++++++------ r/LAB_SERVICE-LR-LS/LRAPR.m | 591 ++++++++------- r/LAB_SERVICE-LR-LS/LRAPRES1.m | 380 +++++----- r/LAB_SERVICE-LR-LS/LRSPT.m | 166 ++--- r/LAB_SERVICE-LR-LS/LRSRVR6.m | 245 +++--- r/LAB_SERVICE-LR-LS/LRVER3A.m | 190 ++--- r/LAB_SERVICE-LR-LS/LRWLST1.m | 630 ++++++++-------- r/LAB_SERVICE-LR-LS/LRWLST11.m | 382 +++++----- r/LAB_SERVICE-LR-LS/LRWOMEN.m | 80 +- r/MENTAL_HEALTH-YS-RUCL-YI-YT/YS31ENV.m | 42 +- r/MENTAL_HEALTH-YS-RUCL-YI-YT/YS31POST.m | 20 +- r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSCLSERV.m | 277 ++++--- r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSCLSRV2.m | 193 +++-- r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSCLSRV3.m | 186 ++--- r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSCLTST2.m | 253 ++++--- r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTALUSE.m | 20 +- r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTAPI5.m | 164 ++--- r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTAUIRR.m | 147 ++-- r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTDOMR.m | 185 +++-- r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTDOMR1.m | 188 ++--- r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTKIL.m | 82 +-- r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTMMPI2B.m | 134 ++-- r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTPCL.m | 70 +- r/MY_HEALTHEVET-MHV/MHV7B0.m | 111 ++- r/MY_HEALTHEVET-MHV/MHV7B1.m | 166 +++-- r/MY_HEALTHEVET-MHV/MHV7B1B.m | 210 +++--- r/MY_HEALTHEVET-MHV/MHV7B2.m | 190 +++-- r/MY_HEALTHEVET-MHV/MHV7R1.m | 377 +++++----- r/MY_HEALTHEVET-MHV/MHV7R2.m | 345 +++++---- r/MY_HEALTHEVET-MHV/MHV7T.m | 262 ++++--- r/MY_HEALTHEVET-MHV/MHV7U.m | 653 ++++++++-------- r/MY_HEALTHEVET-MHV/MHVRQI.m | 159 ++-- r/MY_HEALTHEVET-MHV/MHVU1.m | 159 ++-- r/MY_HEALTHEVET-MHV/MHVUL2.m | 320 ++++---- r/MY_HEALTHEVET-MHV/MHVXRX.m | 228 +++--- r/MY_HEALTHEVET-MHV/MHVXRXR.m | 85 ++- r/NATIONAL_DRUG_FILE-PSN/PSNACT.m | 250 +++---- r/NATIONAL_DRUG_FILE-PSN/PSNHFRM.m | 147 ++-- .../OCXOCMP.m | 381 +++++----- .../OCXOCMP6.m | 302 ++++---- .../OCXOCMP8.m | 191 ++--- .../OCXOCMPV.m | 462 ++++++------ .../OCXOZ01.m | 396 +++++----- .../OCXOZ02.m | 286 +++---- .../OCXOZ03.m | 284 +++---- .../OCXOZ04.m | 344 ++++----- .../OCXOZ05.m | 394 +++++----- .../OCXOZ06.m | 368 ++++----- .../OCXOZ07.m | 390 +++++----- .../OCXOZ08.m | 382 +++++----- .../OCXOZ09.m | 414 +++++------ .../OCXOZ0A.m | 394 +++++----- .../OCXOZ0B.m | 434 +++++------ .../OCXOZ0C.m | 418 ++++++----- .../OCXOZ0D.m | 409 +++++----- .../OCXOZ0E.m | 391 +++++----- .../OCXOZ0F.m | 433 ++++++----- .../OCXOZ0G.m | 516 ++++++------- .../OCXOZ0H.m | 577 +++++++-------- .../OCXOZ0I.m | 521 +++++++------ .../OCXOZ0J.m | 452 ++++++------ .../OCXOZ0K.m | 488 ++++++------ .../OCXOZ0L.m | 474 ++++++------ .../OCXOZ0M.m | 526 ++++++------- .../OCXOZ0N.m | 508 ++++++------- .../OCXOZ0O.m | 510 ++++++------- .../OCXOZ0P.m | 486 ++++++------ .../OCXOZ0Q.m | 548 +++++++------- .../OCXOZ0R.m | 494 ++++++------- .../OCXOZ0S.m | 472 ++++++------ .../OCXOZ0T.m | 470 ++++++------ .../OCXOZ0U.m | 470 ++++++------ .../OCXOZ0V.m | 542 +++++++------- .../OCXOZ0W.m | 523 +++++++------ .../OCXOZ0X.m | 311 ++++---- .../OCXOZ0Y.m | 400 +++++----- .../OCXOZ0Z.m | 536 +++++++------- .../OCXOZ10.m | 478 ++++++------ .../OCXOZ11.m | 412 +++++------ .../OCXOZ12.m | 460 ++++++------ .../OCXOZ13.m | 158 ++-- .../OCXOZ14.m | 80 +- .../OCXSEND.m | 273 ++++--- .../OCXSEND3.m | 219 +++--- .../OCXSEND4.m | 240 +++--- .../OCXSEND5.m | 386 +++++----- .../OCXSEND6.m | 324 ++++---- .../OCXSEND7.m | 216 +++--- .../OCXSEND8.m | 212 +++--- .../OCXSENDA.m | 214 +++--- .../ORB3FUP1.m | 397 +++++----- .../ORB3FUP2.m | 468 ++++++------ .../ORB3LAB.m | 32 +- .../ORBCMA1.m | 202 +++-- .../ORBCMA32.m | 471 ++++++------ .../ORCACT0.m | 247 +++---- .../ORCACT01.m | 304 ++++---- .../ORCACT2.m | 353 +++++---- .../ORCB.m | 329 +++++---- .../ORCD.m | 380 +++++----- .../ORCDFH1.m | 186 +++-- .../ORCDLG1.m | 330 +++++---- .../ORCDLG2.m | 391 +++++----- .../ORCDLR.m | 350 +++++---- .../ORCDLR1.m | 373 +++++----- .../ORCDPS1.m | 417 ++++++----- .../ORCDPS2.m | 359 +++++---- .../ORCDPS3.m | 307 ++++---- .../ORCDPSH.m | 202 ++--- .../ORCDPSIV.m | 353 +++------ .../ORCFLAG.m | 212 +++--- .../ORCHANG2.m | 275 ++++--- .../ORCHANGE.m | 272 ++++--- .../ORCHECK.m | 307 ++++---- .../ORCMED.m | 286 +++---- .../ORCMEDT0.m | 147 ++-- .../ORCMEDT1.m | 245 +++--- .../ORCMEDT8.m | 558 +++++++------- .../ORCSAVE.m | 366 +++++---- .../ORCSAVE1.m | 235 +++--- .../ORCSAVE2.m | 396 +++++----- .../ORCSEND.m | 356 +++++---- .../ORCSEND1.m | 368 ++++----- .../ORCXPND1.m | 415 ++++++----- .../ORCXPND3.m | 313 ++++---- .../ORD2.m | 2 +- .../ORD21.m | 2 +- .../ORD210.m | 2 +- .../ORD211.m | 2 +- .../ORD212.m | 2 +- .../ORD213.m | 2 +- .../ORD214.m | 2 +- .../ORD215.m | 2 +- .../ORD216.m | 2 +- .../ORD22.m | 2 +- .../ORD23.m | 2 +- .../ORD24.m | 2 +- .../ORD25.m | 2 +- .../ORD26.m | 2 +- .../ORD27.m | 2 +- .../ORD28.m | 2 +- .../ORD29.m | 2 +- .../ORDV03.m | 256 +++---- .../ORDV04.m | 393 +++++----- .../ORDV04A.m | 218 ++---- .../ORDV06.m | 271 +++---- .../ORDV06A.m | 90 +-- .../ORDV08.m | 189 +++-- .../OREVNTX.m | 420 ++++++----- .../OREVNTX1.m | 608 +++++++-------- .../ORIMO.m | 82 +-- .../ORKCHK.m | 310 ++++---- .../ORKLR.m | 276 +++---- .../ORLP.m | 513 +++++++------ .../ORMBLDPS.m | 403 +++++----- .../ORMBLDRA.m | 88 +-- .../ORMEVNT.m | 377 +++++----- .../ORMFH.m | 408 +++++----- .../ORMFN.m | 266 ++++--- .../ORMGMRC.m | 316 ++++---- .../ORMLR.m | 375 +++++----- .../ORMPS.m | 464 ++++++------ .../ORMPS1.m | 343 ++++----- .../ORMPS2.m | 305 ++++---- .../ORMPS3.m | 155 ++-- .../ORMRA.m | 365 +++++---- .../ORMTIM02.m | 181 +++-- .../ORMTIME.m | 161 ++-- .../ORPRF.m | 206 +++--- .../ORPRPM.m | 246 +++---- .../ORPRS07.m | 124 ++-- .../ORQ11.m | 406 +++++----- .../ORQ12.m | 243 +++--- .../ORQ2.m | 255 ++++--- .../ORQ20.m | 258 ++++--- .../ORQ21.m | 251 +++---- .../ORQPT.m | 406 +++++----- .../ORQPTQ1.m | 418 +++++------ .../ORQQAL.m | 269 ++++--- .../ORQQPL1.m | 513 ++++++------- .../ORQQPL3.m | 490 ++++++------ .../ORQQPXRM.m | 291 ++++---- .../ORUDPA.m | 74 +- .../ORUTL1.m | 81 +- .../ORWCIRN.m | 124 ++-- .../ORWCV.m | 451 ++++++------ .../ORWD.m | 340 ++++----- .../ORWDAL32.m | 282 ++++--- .../ORWDBA1.m | 497 ++++++------- .../ORWDBA3.m | 421 ++++++----- .../ORWDBA4.m | 238 +++--- .../ORWDBA7.m | 270 +++---- .../ORWDFH.m | 348 ++++----- .../ORWDGX.m | 109 ++- .../ORWDLR.m | 284 ++++--- .../ORWDLR32.m | 437 ++++++----- .../ORWDLR33.m | 177 +++-- .../ORWDOR.m | 129 ++-- .../ORWDPS1.m | 361 ++++----- .../ORWDPS2.m | 468 ++++++------ .../ORWDPS32.m | 462 ++++++------ .../ORWDPS4.m | 259 ++++--- .../ORWDVAL.m | 71 +- .../ORWDX.m | 425 ++++++----- .../ORWDX1.m | 346 ++++----- .../ORWDXA.m | 454 ++++++------ .../ORWDXC.m | 249 ++++--- .../ORWDXM1.m | 390 +++++----- .../ORWDXM2.m | 398 +++++----- .../ORWDXM3.m | 400 ++++------ .../ORWDXR.m | 380 +++++----- .../ORWDXVB.m | 257 +++---- .../ORWDXVB1.m | 237 +++--- .../ORWDXVB2.m | 118 ++- .../ORWGAPI.m | 333 ++++----- .../ORWGAPI1.m | 428 +++++++---- .../ORWGAPI2.m | 364 ++++++--- .../ORWGAPI3.m | 329 +++++---- .../ORWGAPI4.m | 445 ++++++----- .../ORWGAPIA.m | 511 ++++++++----- .../ORWGAPIB.m | 99 ++- .../ORWGAPID.m | 504 +++++++------ .../ORWGAPIP.m | 442 +++++------ .../ORWGAPIR.m | 313 ++++---- .../ORWGAPIT.m | 407 +++++----- .../ORWGAPIU.m | 316 +++++--- .../ORWGAPIX.m | 317 ++++---- .../ORWGRPC.m | 242 +++--- .../ORWNSS.m | 100 +-- .../ORWOR.m | 304 ++++---- .../ORWORB.m | 402 +++++----- .../ORWORR.m | 411 ++++++----- .../ORWORR1.m | 93 +-- .../ORWPCE.m | 372 +++++----- .../ORWPCE1.m | 413 ++++++----- .../ORWPCE2.m | 392 +++++----- .../ORWPS.m | 403 +++++----- .../ORWPT.m | 496 +++++++------ .../ORWPT16.m | 177 ++--- .../ORWPT2.m | 414 +++++------ .../ORWPT3.m | 318 ++++---- .../ORWRP.m | 477 ++++++------ .../ORWRP1.m | 420 +++++------ .../ORWRP3.m | 100 ++- .../ORWRP4P.m | 70 +- .../ORWRP4V.m | 134 ++-- .../ORWTIU.m | 161 ++-- .../ORWTPD.m | 202 +++-- .../ORWTPL.m | 256 ++++--- .../ORWTPP.m | 436 +++++------ .../ORWTPR.m | 251 ++++--- .../ORWTPT.m | 282 ++++--- .../ORWTPUA.m | 55 +- .../ORWU.m | 436 ++++++----- .../ORY269.m | 32 +- .../ORYDLG.m | 166 ++--- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOAFIN.m | 213 +++--- .../PSOAFPT1.m | 38 +- .../PSOAFPTL.m | 446 +++++------ .../PSOAFPTS.m | 610 +++++++-------- .../PSOAFRP1.m | 216 +++--- .../PSOAFRPT.m | 224 +++--- .../PSOAFSET.m | 160 ++-- .../PSOBINGO.m | 256 ++++--- .../PSOBPSU1.m | 412 ++++++----- .../PSOBPSUT.m | 494 +++++++------ .../PSOBUILD.m | 184 ++--- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCAN2.m | 296 ++++---- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCAN3.m | 316 ++++---- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCAN4.m | 227 +++--- .../PSOCIDC2.m | 375 +++++----- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCMOP.m | 306 ++++---- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCP.m | 369 +++++----- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCP1.m | 105 ++- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCPC.m | 323 ++++---- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCPE.m | 329 +++++---- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCSTM.m | 256 ++++--- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODEA.m | 56 +- .../PSODGDGI.m | 240 +++--- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODIAG.m | 325 ++++---- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODIR.m | 227 +++--- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODIR1.m | 324 ++++---- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODIR3.m | 182 ++--- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODISP.m | 266 +++---- .../PSODISPS.m | 212 +++--- .../PSODRDUP.m | 168 ++--- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODRG.m | 308 ++++---- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHELP.m | 222 +++--- .../PSOHELP3.m | 123 ++-- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLD.m | 230 +++--- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLDA.m | 99 +-- .../PSOHLDS4.m | 167 +++-- .../PSOHLEXP.m | 109 ++- .../PSOHLNE1.m | 349 ++++----- .../PSOHLNE2.m | 292 ++++---- .../PSOHLNE3.m | 312 ++++---- .../PSOHLNE4.m | 127 ++-- .../PSOHLNEW.m | 297 ++++---- .../PSOHLPII.m | 268 +++---- .../PSOHLPIS.m | 280 +++---- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLSN.m | 328 ++++----- .../PSOHLSN1.m | 335 +++++---- .../PSOHLSN2.m | 115 ++- .../PSOHLSNC.m | 320 ++++---- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLUP.m | 139 ++-- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLBL.m | 254 +++---- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLBL1.m | 100 ++- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLBL4.m | 239 +++--- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLBLN.m | 272 +++---- .../PSOLBLN2.m | 152 ++-- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLLLI.m | 304 ++++---- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLMAO.m | 55 +- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLMPO.m | 69 +- .../PSOLMPO1.m | 51 +- .../PSOLMPO2.m | 54 +- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLMRN.m | 57 +- .../PSOLMUTL.m | 167 +++-- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLSET.m | 212 +++--- .../PSOMAUEX.m | 190 +++-- .../PSOMLLD2.m | 123 ++-- .../PSOMLLDT.m | 327 ++++---- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSON52.m | 349 ++++----- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSONEW.m | 199 ++--- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSONEW2.m | 245 +++--- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSONEWF.m | 217 +++--- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSONEWG.m | 137 ++-- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSONFI.m | 137 ++-- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORAL.m | 54 +- .../PSOORAL1.m | 245 +++--- .../PSOORED1.m | 282 +++---- .../PSOORED2.m | 295 ++++---- .../PSOORED6.m | 324 ++++---- .../PSOORED7.m | 179 ++--- .../PSOOREDT.m | 313 ++++---- .../PSOORFI1.m | 268 +++---- .../PSOORFI2.m | 310 ++++---- .../PSOORFI3.m | 264 +++---- .../PSOORFI4.m | 298 ++++---- .../PSOORFI5.m | 123 +--- .../PSOORFIN.m | 300 ++++---- .../PSOORNE1.m | 286 ++++--- .../PSOORNE2.m | 232 +++--- .../PSOORNE4.m | 251 +++---- .../PSOORNE5.m | 261 +++---- .../PSOORNEW.m | 302 ++++---- .../PSOORNW1.m | 192 ++--- .../PSOORNW2.m | 259 ++++--- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORRL.m | 265 ++++--- .../PSOORRNW.m | 168 +++-- .../PSOORUT1.m | 285 ++++--- .../PSOORUTL.m | 215 +++--- .../PSOPFSU0.m | 214 +++--- .../PSOPFSU1.m | 264 +++---- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOPMP0.m | 505 +++++++------ r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOPMP1.m | 314 ++++---- .../PSOPTPST.m | 188 +++-- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOR52.m | 264 +++---- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOREF.m | 255 ++++--- .../PSOREJP1.m | 545 +++++++------- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORENW.m | 165 ++--- .../PSORENW0.m | 402 +++++----- .../PSORENW1.m | 281 +++---- .../PSORENW4.m | 240 +++--- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORN52.m | 252 ++++--- .../PSORN52A.m | 129 ++-- .../PSORN52C.m | 194 ++--- .../PSORN52D.m | 242 +++--- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORX1.m | 318 ++++---- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXDL.m | 254 ++++--- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXED.m | 248 +++---- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXL.m | 272 +++---- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXL1.m | 193 +++-- .../PSORXPA1.m | 176 ++--- .../PSORXRP1.m | 194 ++--- .../PSORXRP2.m | 202 +++-- .../PSORXRPT.m | 224 +++--- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXVW.m | 232 +++--- .../PSORXVW1.m | 265 ++++--- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSD0.m | 190 ++--- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSD1.m | 197 +++-- .../PSOSIGMX.m | 102 +-- .../PSOSUPOE.m | 250 +++---- .../PSOTPCAN.m | 346 ++++----- .../PSOUTLA1.m | 372 +++++----- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOVER1.m | 256 +++---- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA.m | 2 +- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA1.m | 2 +- .../PSOXZA10.m | 2 +- .../PSOXZA11.m | 2 +- .../PSOXZA12.m | 2 +- .../PSOXZA13.m | 2 +- .../PSOXZA14.m | 2 +- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA2.m | 2 +- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA3.m | 2 +- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA4.m | 2 +- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA5.m | 2 +- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA6.m | 2 +- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA7.m | 2 +- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA8.m | 2 +- r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA9.m | 2 +- r/PAID-PRS/PRS8AC.m | 354 ++++----- r/PAID-PRS/PRS8CR.m | 155 ++-- r/PAID-PRS/PRS8DR.m | 145 ++-- r/PAID-PRS/PRS8EX.m | 291 ++++---- r/PAID-PRS/PRS8HD.m | 353 +++++---- r/PAID-PRS/PRS8HR.m | 400 +++++----- r/PAID-PRS/PRS8HRSV.m | 417 +++++------ r/PAID-PRS/PRS8MSC0.m | 342 ++++----- r/PAID-PRS/PRS8MT.m | 265 +++---- r/PAID-PRS/PRS8OC.m | 333 ++++----- r/PAID-PRS/PRS8PP.m | 386 +++++----- r/PAID-PRS/PRS8ST.m | 301 ++++---- r/PAID-PRS/PRS8SU.m | 216 +++--- r/PAID-PRS/PRS8VW.m | 177 +++-- r/PAID-PRS/PRS8VW1.m | 143 ++-- r/PAID-PRS/PRS8VW2.m | 287 ++++---- r/PAID-PRS/PRS8WE2.m | 221 +++--- r/PAID-PRS/PRSACED2.m | 234 +++--- r/PAID-PRS/PRSACED5.m | 95 ++- r/PAID-PRS/PRSACED6.m | 89 ++- r/PAID-PRS/PRSAENT.m | 404 +++++----- r/PAID-PRS/PRSAENX.m | 113 ++- r/PAID-PRS/PRSALVS.m | 150 ++-- r/PAID-PRS/PRSAOTT.m | 467 ++++++------ r/PAID-PRS/PRSAPPH.m | 192 ++--- r/PAID-PRS/PRSAPPO.m | 156 ++-- r/PAID-PRS/PRSASR.m | 453 ++++++------ r/PAID-PRS/PRSASR1.m | 426 +++++------ r/PAID-PRS/PRSATE.m | 696 +++++++++--------- r/PAID-PRS/PRSATE0.m | 67 +- r/PAID-PRS/PRSATP.m | 268 +++---- r/PAID-PRS/PRSATP1.m | 132 ++-- r/PAID-PRS/PRSATPE.m | 343 ++++----- r/PAID-PRS/PRSAUDP.m | 75 +- r/PAID-PRS/PRSDEU03.m | 203 +++-- r/PAID-PRS/PRSDSERV.m | 348 +++++---- r/PAID-PRS/PRSDW450.m | 74 +- r/PAID-PRS/PRSPUT3.m | 562 +++++++------- r/PATIENT_REPRESENTATIVE-QAC/QACVEMPX.m | 298 +++----- .../PXBPCPT.m | 384 +++++----- .../PXCEVFI1.m | 210 +++--- r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUCP.m | 453 ++++++------ r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUDEM1.m | 425 ++++++----- r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUDEM4.m | 402 +++++----- r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSULRHL1.m | 516 +++++++------ r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUMAP0.m | 319 ++++---- r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUOPAM.m | 153 ++-- r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUPR2.m | 563 +++++++------- r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSURT1.m | 260 +++---- r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUSUM1.m | 211 +++--- r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUVIT1.m | 381 +++++----- r/PHARMACY_DATA_MANAGEMENT-PSS/PSS51P1.m | 308 ++++---- r/PHARMACY_DATA_MANAGEMENT-PSS/PSS51P2.m | 341 +++++---- r/PHARMACY_DATA_MANAGEMENT-PSS/PSSDDUT2.m | 407 +++++----- r/PHARMACY_DATA_MANAGEMENT-PSS/PSSGSGUI.m | 220 +++--- r/PHARMACY_DATA_MANAGEMENT-PSS/PSSHLU.m | 116 +-- r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJORDF.m | 206 ++---- r/PHARMACY_DATA_MANAGEMENT-PSS/PSSMARK.m | 161 ++-- r/PHARMACY_DATA_MANAGEMENT-PSS/PSSQOC.m | 122 +-- r/PHARMACY_DATA_MANAGEMENT-PSS/PSSVX6.m | 2 +- r/PHARMACY_DATA_MANAGEMENT-PSS/PSSVX61.m | 2 +- r/PHARMACY_DATA_MANAGEMENT-PSS/PSSVX62.m | 2 +- r/PHARMACY_DATA_MANAGEMENT-PSS/PSSVX63.m | 2 +- r/PHARMACY_DATA_MANAGEMENT-PSS/PSSVX64.m | 2 +- r/PHARMACY_DATA_MANAGEMENT-PSS/PSSVX65.m | 2 +- r/PHARMACY_DATA_MANAGEMENT-PSS/PSSVX66.m | 2 +- r/POLICE_AND_SECURITY-ES/ESPQNC.m | 188 ++--- r/PROBLEM_LIST-GMPL/GMPLDISP.m | 236 +++--- r/PROBLEM_LIST-GMPL/GMPLEDIT.m | 240 +++--- r/PROBLEM_LIST-GMPL/GMPLEDT1.m | 280 ++++--- r/PROBLEM_LIST-GMPL/GMPLEDT2.m | 224 +++--- r/PROBLEM_LIST-GMPL/GMPLEDT3.m | 218 +++--- r/PROBLEM_LIST-GMPL/GMPLENFM.m | 208 +++--- r/PROBLEM_LIST-GMPL/GMPLHIST.m | 102 +-- r/PROBLEM_LIST-GMPL/GMPLHS.m | 192 +++-- r/PROBLEM_LIST-GMPL/GMPLSAVE.m | 255 ++++--- r/PROBLEM_LIST-GMPL/GMPLUTL.m | 329 ++++----- r/PROBLEM_LIST-GMPL/GMPLUTL1.m | 263 ++++--- r/PROBLEM_LIST-GMPL/GMPLUTL2.m | 401 +++++----- r/PROBLEM_LIST-GMPL/GMPLX1.m | 333 ++++----- r/PROSTHETICS-RMPR-RMPO-RMPS/RMPOBIL5.m | 162 ++-- r/PROSTHETICS-RMPR-RMPO-RMPS/RMPOPED.m | 607 ++++++++------- r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR121B.m | 171 +++-- r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR29A.m | 101 ++- r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR29BG.m | 153 ++-- r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR29CA.m | 462 ++++++------ r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR29GA.m | 127 ++-- r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR4C21.m | 139 ++-- r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR4E21.m | 324 ++++---- r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR4LOP.m | 142 ++-- r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR4OPN.m | 122 +-- r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR4P21.m | 165 +++-- r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR8PG.m | 47 +- r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR9CA.m | 427 ++++++----- r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR9DO.m | 549 +++++++------- r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR9P21.m | 200 ++--- r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRD1.m | 236 +++--- r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRDDC.m | 236 +++--- r/PROSTHETICS-RMPR-RMPO-RMPS/RMPREOS.m | 534 +++++++------- r/PROSTHETICS-RMPR-RMPO-RMPS/RMPREOU.m | 306 ++++---- r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRP21.m | 153 ++-- r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPAT2.m | 251 ++++--- r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPCEB.m | 239 +++--- r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPCED.m | 262 +++---- r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPIY7.m | 462 ++++++------ r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPIYF.m | 463 ++++++------ r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPRT1.m | 167 ++--- r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRSP7.m | 237 +++--- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RABUL3.m | 133 ++-- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE.m | 26 +- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE1.m | 2 +- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE2.m | 2 +- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE3.m | 250 +++---- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE4.m | 68 +- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE5.m | 132 +--- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTQE.m | 71 +- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTQE1.m | 2 +- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTQE2.m | 181 ++++- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTQE3.m | 180 ++++- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTQE4.m | 186 +---- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTQE5.m | 98 ++- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG.m | 2 +- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG1.m | 2 +- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG10.m | 104 ++- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG2.m | 39 +- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG3.m | 146 +++- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG4.m | 2 +- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG5.m | 184 +---- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG6.m | 196 +++-- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG7.m | 2 +- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG8.m | 2 +- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG9.m | 74 +- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RADD1.m | 271 +++---- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RADD2.m | 221 +++--- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RADD3.m | 288 ++++---- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RADD4.m | 103 ++- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RADLQ3.m | 217 +++--- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RADOSTIK.m | 197 +++-- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLO.m | 240 +++--- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLO1.m | 296 ++++---- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLO2.m | 209 +++--- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLO3.m | 222 +++--- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLO4.m | 342 +++++---- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLR.m | 278 ++++--- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLRPC.m | 180 +++-- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLRPT.m | 341 +++++---- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLRS1.m | 389 +++++----- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLTCPB.m | 359 +++++---- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAMAIN.m | 261 ++++--- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAMAIN2.m | 379 +++++----- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RANMED1.m | 132 ++-- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RANMUSE2.m | 233 +++--- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RANMUSE3.m | 141 ++-- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RANMUTL1.m | 192 +++-- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAO7PC1A.m | 308 ++++---- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAO7PC2.m | 334 +++++---- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAO7PC3.m | 326 ++++---- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAO7RO1.m | 98 ++- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAO7RON.m | 194 +++-- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAORD1.m | 330 ++++----- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAORD1A.m | 237 +++--- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAPCE.m | 312 ++++---- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAPROD.m | 298 ++++---- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAPTLU.m | 194 +++-- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAPXRM.m | 246 +++---- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RART.m | 181 +++-- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RARTE.m | 191 +++-- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RARTE1.m | 308 ++++---- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RARTE3.m | 102 ++- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RARTE4.m | 172 +++-- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RARTR.m | 343 +++++---- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RARTR0.m | 282 ++++--- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RARTR1.m | 258 ++++--- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RARTRPV.m | 183 +++-- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RARTST1.m | 170 +++-- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RARTUVR.m | 224 +++--- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RARTUVR1.m | 176 +++-- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RARTUVR3.m | 239 +++--- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RARTVER.m | 182 +++-- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RASTREQ.m | 324 ++++---- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RASTREQN.m | 317 ++++---- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAUTL1.m | 327 ++++---- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAWKLU.m | 401 +++++----- r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAWKLU2.m | 384 +++++----- r/RECORD_TRACKING-RT/RTQ2.m | 158 ++-- .../DG10.m | 332 ++++----- .../DGCV.m | 450 +++++------ .../DGDEATH.m | 301 ++++---- .../DGENA2.m | 308 ++++---- .../DGENUPLB.m | 127 ++-- .../DGLBPID.m | 232 +++--- .../DGMSTAPI.m | 614 +++++++-------- .../DGMTCOU1.m | 230 +++--- .../DGMTU.m | 410 +++++------ .../DGPFUT.m | 590 +++++++-------- .../DGPTF4.m | 174 +++-- .../DGPTFDEL.m | 145 ++-- .../DGPTFM4.m | 151 ++-- .../DGPTICD.m | 123 ++-- .../DGPTR1.m | 154 ++-- .../DGREG.m | 462 ++++++------ .../DGREGAED.m | 366 ++++----- .../DGREGAZL.m | 376 +++++----- .../DGRP1.m | 446 +++++------ .../DGRP14.m | 76 +- .../DGRP2.m | 212 +++--- .../DGRP3.m | 96 +-- .../DGRPCE.m | 314 ++++---- .../DGRPD.m | 382 +++++----- .../DGRPDB.m | 262 ++++--- .../DGRPE.m | 320 ++++---- .../DGRPECE.m | 432 +++++------ .../DGRPTX.m | 60 +- .../DGRPTX1.m | 22 +- .../DGRPTX10.m | 222 +++++- .../DGRPTX11.m | 11 +- .../DGRPTX12.m | 7 +- .../DGRPTX13.m | 215 +++++- .../DGRPTX14.m | 11 +- .../DGRPTX15.m | 11 +- .../DGRPTX16.m | 223 +++++- .../DGRPTX17.m | 325 ++++---- .../DGRPTX18.m | 15 +- .../DGRPTX19.m | 11 +- .../DGRPTX2.m | 20 +- .../DGRPTX20.m | 295 +------- .../DGRPTX21.m | 12 +- .../DGRPTX22.m | 274 +------ .../DGRPTX23.m | 19 +- .../DGRPTX24.m | 148 +++- .../DGRPTX25.m | 91 ++- .../DGRPTX26.m | 49 +- .../DGRPTX27.m | 91 ++- .../DGRPTX28.m | 17 +- .../DGRPTX29.m | 150 +--- .../DGRPTX3.m | 20 +- .../DGRPTX30.m | 99 +-- .../DGRPTX4.m | 197 ++++- .../DGRPTX5.m | 303 +------- .../DGRPTX6.m | 8 +- .../DGRPTX7.m | 22 +- .../DGRPTX8.m | 14 +- .../DGRPTX9.m | 204 ++++- .../DGRPU.m | 422 +++++------ .../DGRPV.m | 282 +++---- .../DGRPX7.m | 80 +- .../DGRPX71.m | 11 +- .../DGRPX72.m | 8 +- .../DGRPX73.m | 208 +++++- .../DGRPX74.m | 222 +----- .../DGRPX75.m | 19 +- .../DGRPX76.m | 19 +- .../DGRPX77.m | 133 +--- .../DGRPX78.m | 87 +-- .../DGRPX79.m | 68 +- .../DGRPXR.m | 24 +- .../DGRUGA01.m | 148 ++-- .../DGRUGA08.m | 121 ++- .../DGRUGA22.m | 67 +- .../DGRUGBJ.m | 223 +++--- .../DGRUUTL.m | 180 +++-- .../DPTLK.m | 466 ++++++------ .../VADATE.m | 32 +- .../VADPT1.m | 328 ++++----- .../VADPT2.m | 120 +-- .../VADPT3.m | 194 ++--- .../VADPT5.m | 206 +++--- .../VADPT61.m | 120 +-- .../VAFCPID.m | 244 +++--- .../VAFCTF.m | 154 ++-- .../VAFHLPID.m | 184 +++-- r/SCHEDULING-SD-SC/SCAPMC14.m | 177 +++-- r/SCHEDULING-SD-SC/SCAPMC29.m | 174 ++--- r/SCHEDULING-SD-SC/SCAPMC30.m | 166 ++--- r/SCHEDULING-SD-SC/SCAPMC9.m | 156 ++-- r/SCHEDULING-SD-SC/SCAPMCU2.m | 431 ++++++----- r/SCHEDULING-SD-SC/SCMCDD2.m | 98 +-- r/SCHEDULING-SD-SC/SCMCHLB1.m | 288 ++++---- r/SCHEDULING-SD-SC/SCMCHLB2.m | 204 +++-- r/SCHEDULING-SD-SC/SCMCHLR2.m | 264 +++---- r/SCHEDULING-SD-SC/SCMCHLS.m | 214 +++--- r/SCHEDULING-SD-SC/SCMCMU2.m | 486 ++++++------ r/SCHEDULING-SD-SC/SCMCQK1.m | 536 +++++++------- r/SCHEDULING-SD-SC/SCMCTSK1.m | 490 ++++++------ r/SCHEDULING-SD-SC/SCMCTSK2.m | 483 ++++++------ r/SCHEDULING-SD-SC/SCMCTSK3.m | 441 ++++++----- r/SCHEDULING-SD-SC/SCMCTSK4.m | 160 ++-- r/SCHEDULING-SD-SC/SCMCTSK9.m | 200 ++--- r/SCHEDULING-SD-SC/SCMSVUT2.m | 480 ++++++------ r/SCHEDULING-SD-SC/SCRPBK11.m | 194 ++--- r/SCHEDULING-SD-SC/SCRPEC.m | 204 ++--- r/SCHEDULING-SD-SC/SCRPEC2.m | 314 ++++---- r/SCHEDULING-SD-SC/SCRPITP.m | 293 ++++---- r/SCHEDULING-SD-SC/SCRPITP2.m | 253 +++---- r/SCHEDULING-SD-SC/SCRPPAT2.m | 308 ++++---- r/SCHEDULING-SD-SC/SCRPPAT3.m | 285 ++++--- r/SCHEDULING-SD-SC/SCRPRAC2.m | 238 +++--- r/SCHEDULING-SD-SC/SCRPSLT.m | 290 ++++---- r/SCHEDULING-SD-SC/SCRPSLT2.m | 332 ++++----- r/SCHEDULING-SD-SC/SCRPTA.m | 320 ++++---- r/SCHEDULING-SD-SC/SCRPTA2.m | 305 ++++---- r/SCHEDULING-SD-SC/SCRPTM.m | 329 ++++----- r/SCHEDULING-SD-SC/SCRPTM2.m | 265 ++++--- r/SCHEDULING-SD-SC/SCRPTP.m | 325 ++++---- r/SCHEDULING-SD-SC/SCRPTP2.m | 292 ++++---- r/SCHEDULING-SD-SC/SCRPTP3.m | 264 ++++--- r/SCHEDULING-SD-SC/SCRPU1.m | 262 +++---- r/SCHEDULING-SD-SC/SCRPU2.m | 292 ++++---- r/SCHEDULING-SD-SC/SCRPW24.m | 396 +++++----- r/SCHEDULING-SD-SC/SCRPW6.m | 210 +++--- r/SCHEDULING-SD-SC/SCRPW62.m | 256 +++---- r/SCHEDULING-SD-SC/SCRPW63.m | 483 ++++++------ r/SCHEDULING-SD-SC/SCRPW8.m | 277 ++++--- r/SCHEDULING-SD-SC/SCRPW9.m | 212 +++--- r/SCHEDULING-SD-SC/SDAL.m | 248 +++---- r/SCHEDULING-SD-SC/SDAM10.m | 110 ++- r/SCHEDULING-SD-SC/SDAMODO3.m | 204 ++--- r/SCHEDULING-SD-SC/SDAMVSC.m | 118 ++- r/SCHEDULING-SD-SC/SDC.m | 136 ++-- r/SCHEDULING-SD-SC/SDCLAS.m | 106 +-- r/SCHEDULING-SD-SC/SDCLAV0.m | 94 ++- r/SCHEDULING-SD-SC/SDCWL2.m | 62 +- r/SCHEDULING-SD-SC/SDD0.m | 82 +-- r/SCHEDULING-SD-SC/SDLT.m | 164 ++--- r/SCHEDULING-SD-SC/SDN1.m | 84 +-- r/SCHEDULING-SD-SC/SDNOS0.m | 147 ++-- r/SCHEDULING-SD-SC/SDRPA00.m | 394 +++++----- r/SCHEDULING-SD-SC/SDRPA04.m | 283 ++++--- r/SCHEDULING-SD-SC/SDRPA05.m | 209 +++--- r/SCHEDULING-SD-SC/SDRPA06.m | 428 +++++------ r/SCHEDULING-SD-SC/SDWLCU3.m | 135 ++-- r/SCHEDULING-SD-SC/SDWLCU5.m | 254 +++---- r/SCHEDULING-SD-SC/SDWLCU6.m | 101 ++- r/SCHEDULING-SD-SC/SDWLE.m | 260 +++---- r/SCHEDULING-SD-SC/SDWLI.m | 333 +++++---- r/SCHEDULING-SD-SC/SDWLPE.m | 216 +++--- r/SCHEDULING-SD-SC/SDWLQSR.m | 120 ++- r/SCHEDULING-SD-SC/SDWLREB.m | 373 +++++----- r/SCHEDULING-SD-SC/SDWLRSR.m | 193 +++-- r/SURGERY-SR/SROABCH.m | 48 +- r/SURGERY-SR/SROACAR.m | 98 ++- r/SURGERY-SR/SROACMP.m | 162 ++-- r/SURGERY-SR/SROACMP1.m | 128 ++-- r/SURGERY-SR/SROACOM.m | 112 +-- r/SURGERY-SR/SROACOP.m | 155 ++-- r/SURGERY-SR/SROACPM.m | 242 +++--- r/SURGERY-SR/SROACPM1.m | 101 ++- r/SURGERY-SR/SROACR2.m | 126 ++-- r/SURGERY-SR/SROALEC.m | 166 ++--- r/SURGERY-SR/SROALM.m | 134 ++-- r/SURGERY-SR/SROALOG.m | 116 ++- r/SURGERY-SR/SROALT.m | 77 +- r/SURGERY-SR/SROALTP.m | 78 +- r/SURGERY-SR/SROALTS.m | 99 ++- r/SURGERY-SR/SROALTSP.m | 104 ++- r/SURGERY-SR/SROAMEAS.m | 28 +- r/SURGERY-SR/SROAMIS.m | 98 ++- r/SURGERY-SR/SROAOP.m | 142 ++-- r/SURGERY-SR/SROAPAS.m | 208 +++--- r/SURGERY-SR/SROAPCA1.m | 189 +++-- r/SURGERY-SR/SROAPCA3.m | 129 ++-- r/SURGERY-SR/SROAPM.m | 257 ++++--- r/SURGERY-SR/SROAPRE.m | 110 +-- r/SURGERY-SR/SROAPRE1.m | 131 ++-- r/SURGERY-SR/SROAPRE2.m | 118 +-- r/SURGERY-SR/SROAPRT1.m | 118 +-- r/SURGERY-SR/SROAPRT2.m | 94 +-- r/SURGERY-SR/SROAPRT4.m | 48 +- r/SURGERY-SR/SROAPRT5.m | 42 +- r/SURGERY-SR/SROAPS1.m | 154 ++-- r/SURGERY-SR/SROAPS2.m | 98 +-- r/SURGERY-SR/SROASS.m | 92 +-- r/SURGERY-SR/SROASSP.m | 24 +- r/SURGERY-SR/SROATCM3.m | 51 +- r/SURGERY-SR/SROATM1.m | 81 +- r/SURGERY-SR/SROATMNO.m | 153 ++-- r/SURGERY-SR/SROAUTL.m | 214 +++--- r/SURGERY-SR/SROAUTL1.m | 126 ++-- r/SURGERY-SR/SROAUTL3.m | 103 ++- r/SURGERY-SR/SROAUTL4.m | 249 +++---- r/SURGERY-SR/SROAUTLC.m | 117 ++- r/SURGERY-SR/SROCODE.m | 64 +- r/SURGERY-SR/SROESPR1.m | 377 +++++----- r/SURGERY-SR/SROGMTS.m | 353 +++++---- r/SURGERY-SR/SROMED.m | 96 ++- r/SURGERY-SR/SROWL.m | 156 ++-- r/SURGERY-SR/SROXR4.m | 130 ++-- .../TIUDD1.m | 345 ++++----- .../TIUEDS.m | 56 +- .../TIUEDS1.m | 30 +- .../TIUEDS10.m | 178 ++++- .../TIUEDS11.m | 10 +- .../TIUEDS12.m | 6 +- .../TIUEDS13.m | 85 +-- .../TIUEDS14.m | 2 +- .../TIUEDS2.m | 28 +- .../TIUEDS3.m | 22 +- .../TIUEDS4.m | 22 +- .../TIUEDS5.m | 178 ++++- .../TIUEDS6.m | 279 +------ .../TIUEDS7.m | 78 +- .../TIUEDS8.m | 42 +- .../TIUEDS9.m | 8 +- .../TIUFLF4.m | 230 +++--- .../TIUHL7.m | 187 +++-- .../TIUHL7A.m | 96 +-- .../TIUHL7P1.m | 262 ++++--- .../TIUHL7P2.m | 147 ++-- .../TIUHL7U1.m | 291 ++++---- .../TIULA3.m | 191 +++-- .../TIULMED.m | 369 +++++----- r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIULP.m | 326 ++++---- r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIULX.m | 336 ++++----- .../TIUPREL.m | 6 +- .../TIUPRPN1.m | 360 ++++----- .../TIUPRPN8.m | 230 +++--- r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUR.m | 309 ++++---- .../TIURA3.m | 249 +++---- r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIURB.m | 341 +++++---- r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIURL.m | 193 +++-- r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIURM.m | 243 +++--- .../TIUSRVA.m | 236 +++--- .../TIUSRVP1.m | 328 ++++----- .../TIUSRVR2.m | 302 ++++---- .../TIUXRC.m | 8 +- .../TIUXRC1.m | 19 +- .../TIUXRC2.m | 69 +- .../TIUXRC3.m | 144 +--- .../TIUXRC4.m | 251 +++---- .../XDRDSHOW.m | 300 ++++---- .../XTPMKPCF.m | 149 ++-- .../XTPMSTA2.m | 158 ++-- r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIA.m | 154 ++-- r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIA1.m | 104 +-- r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIA3.m | 105 +-- r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIC3.m | 309 ++++---- r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIC5.m | 139 ++-- .../DICATT2.m | 108 ++- r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICM.m | 288 ++++---- .../DICOMP0.m | 123 ++-- .../DICOMP1.m | 158 ++-- .../DICOMPZ.m | 213 +++--- r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DID1.m | 161 ++-- r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIE.m | 215 +++--- r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIE0.m | 145 ++-- r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIE1.m | 297 ++++---- .../DIETED.m | 295 ++++---- r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIEZ.m | 194 ++--- .../DIEZ0.m | 128 ++-- .../DIEZ2.m | 393 +++++----- .../DIL11.m | 58 +- .../DINIT0F0.m | 458 ++++++------ .../DINIT0F5.m | 510 ++++++------- .../DIWE1.m | 143 ++-- r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIWP.m | 125 ++-- r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIWW.m | 118 +-- r/WOMENS_HEALTH-WV/WVLABCHK.m | 275 ++++--- r/WOMENS_HEALTH-WV/WVRALINK.m | 431 ++++++----- r/WOMENS_HEALTH-WV/WVSNOMED.m | 274 +++---- r/WORLDVISTA-VW/VWUTIL.m | 139 ++-- .../A1CKC.m | 93 +-- .../A1CKC1.m | 22 +- .../A1CKC10.m | 157 +--- .../A1CKC11.m | 178 ++++- .../A1CKC12.m | 152 +++- .../A1CKC13.m | 14 +- .../A1CKC14.m | 14 +- .../A1CKC15.m | 78 +- .../A1CKC2.m | 16 +- .../A1CKC3.m | 249 ++++++- .../A1CKC4.m | 13 +- .../A1CKC5.m | 14 +- .../A1CKC6.m | 6 +- .../A1CKC7.m | 19 +- .../A1CKC8.m | 11 +- .../A1CKC9.m | 253 +------ .../RGADTP2.m | 231 +++--- .../RGHLLOG.m | 302 ++++---- .../RGMTETOT.m | 274 +++---- .../RGPVMPI.m | 175 +++-- .../RGPVREJ.m | 157 ++-- .../RGRSBUL1.m | 303 ++++---- .../RGRSPT.m | 197 +++-- .../RGSYSTAT.m | 203 +++-- 1724 files changed, 196085 insertions(+), 204097 deletions(-) diff --git a/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCACM.m b/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCACM.m index f8b00197..90a8b86b 100644 --- a/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCACM.m +++ b/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCACM.m @@ -1,65 +1,60 @@ -PRCACM ;WASH-ISC@ALTOONA,PA/RGY-COMMENT ADJUSTMENT TRANSACTION ;6/2/95 2:41 PM - ;;4.5;Accounts Receivable;**8,67,125,169,254**;Mar 20, 1995;Build 2 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; DBIA 3820-A used for direct global read into file 399. - ; - ;This is a routine for adjustment transaction. - NEW PRCABN,PRCAEN,PRCAA1,DR,DIE,DA,D0,PRCAD,RCASK,PRCAA2,DIROUT,DIRUT,DIR,DUOUT,PRCA,PRCATY -ADJUST D BEGIN G:('$D(PRCABN))!('$D(PRCAEN)) Q - S PRCAA1=$S($D(^PRCA(433,PRCAEN,4,0)):+$P(^(0),U,4),1:0) G Q:PRCAA1'>0 S PRCAA2=$P(^(0),U,3) W ! -DIE S DR="[PRCA COMMENT]",DIE="^PRCA(433,",DA=PRCAEN D ^DIE K DIE,DR,DA - I $P($G(^PRCA(433,PRCAEN,5)),"^",2)=""!'$P(^PRCA(433,PRCAEN,1),"^") S PRCACOMM="TRANSACTION INCOMPLETE" D DELETE^PRCAWO1 K PRCACOMM G:$D(DTOUT) Q G ADJUST - W ! W:$D(IOF) @IOF S D0=PRCAEN K DXS D ^PRCATO4 K DXS - I $P($G(^PRCA(433,PRCAEN,1)),"^")>$P($G(^(5)),"^",3),$P($G(^(5)),"^",3) W !!,*7,"You entered a date of follow-up before the date of contact!" S PRCACOMM="INVALID FOLLOW-UP DATE" D DELETE^PRCAWO1 K PRCACOMM G ADJUST -ASK S %=2 W !!,"Is this correct" D YN^DICN I %=0 W !,"Answer 'Y' or 'YES' if this data is correct, answer 'N' or 'NO' if not",! G ASK - I (%<0)!(%=2) S PRCACOMM="USER CANCELED" D DELETE^PRCAWO1 K PRCACOMM G ADJUST -DONE I '$D(PRCAD("DELETE")) S RCASK=1 D TRANUP^PRCAUTL,UPPRIN^PRCADJ - I $P($G(^RCD(340,+$P(^PRCA(430,PRCABN,0),"^",9),0)),"^")[";DPT(" D - .S $P(^PRCA(433,PRCAEN,0),"^",10)=1 - .S DIR(0)="Y",DIR("A")="Should the BRIEF COMMENT print on the patient statement",DIR("B")="NO" D ^DIR K DIR - .I Y=1 S DIR(0)="Y",DIR("A")="Are you SURE this BRIEF COMMENT should appear on the patient statement",DIR("B")="NO" D ^DIR K DIR I Y=1 D - ..W !!,*7,"*** OK, This comment will appear on the patient's statement! ***",!,"(If you change your mind, use the option Remove/Add Comment From Patient Statement)",! - ..S $P(^PRCA(433,PRCAEN,0),"^",10)="" - ..Q - .Q - G ADJUST -Q Q -EN1 Q:'$D(PRCABN) - NEW X - F X=0:0 S X=$O(^PRCA(433,"C",PRCABN,X)) Q:'X I $P($G(^PRCA(433,X,1)),"^",4) I $P(^(1),"^",2)=1!($P(^(1),"^",2)=35) S PRCAQNM=$P(^(1),"^",4)+1 - Q -ASK1 ;ASK FOR STATUS - NEW DTOUT,DUOUT,DIRUT,DIR,DIROUT - S DIR("A")="Change 'BILL' status to?",DIR("B")="CANCELLED",DIR(0)="SB^1:CANCELLED;2:COLLECTED/CLOSED;" D ^DIR K DIR - I Y=2 S PRCA("STATUS")=$O(^PRCA(430.3,"AC",108,0)) - Q -RPT ; - NEW %DT,BEG,END,DIC,L,FR,TO,FLDS,PRCACM,POP,PRCADEV -ST W !! S %DT="AEX",%DT("A")="Follow-up Date(s) From: " D ^%DT G:Y<0 REPQ S BEG=Y - S %DT="AEX",%DT("A")="Follow-up Date(s) To: " D ^%DT G:Y<0 REPQ S END=Y - I BEG>END W !!,*7," (Ending date must be greater than Start date.)" G ST - S %ZIS="MQ" D ^%ZIS G:POP REPQ S PRCADEV=ION_";"_IOST_";"_IOM_";"_IOSL_";"_$G(IO("DOC")) - I $D(IO("Q")) S Y=$$TI() G:Y<0 REPQ F PRCACM=1,2 S ZTDTH=$H,ZTRTN="DQ"_PRCACM_"^PRCACM",ZTSAVE("BEG")="",ZTSAVE("PRCADEV")="",ZTSAVE("END")="",ZTDESC="Comment Follow-up List" D ^%ZTLOAD G REPQ:PRCACM=2 - D DQ1,DQ2:'$D(DTOUT) -REPQ Q -DQ1 ; - S IOP=PRCADEV,DIC="^PRCA(433,",L=0,BY="[PRCA FOLLOW-UP]",FLDS="[PRCA FOLLOW-UP]",FR=BEG,TO=END D EN1^DIP - D ^%ZISC K IOP - I $E(IOST)="C" W !,*7,"OK, first part of report complete...",!,"press return to continue: " R X:DTIME W @IOF S:X["^"!'$T DTOUT=1 - Q -DQ2 ; - S IOP=PRCADEV D ^%ZIS - I 'POP S IOP=PRCADEV,DIC="^RC(341,",L=0,BY="[RCAM COMMENT]",FLDS="[RCAM COMMENT]",FR=BEG,TO=END D EN1^DIP - D ^%ZISC K IOP - Q -TI() ; - N %DT D NOW^%DTC S %DT("A")="Request Time to Queue? ",%DT("B")="NOW" - S %DT="AERX",%DT(0)=% D ^%DT - Q Y -BEGIN K PRCATERM,PRCABN,PRCAEN,PRCA("CKSITE"),PRCAIBS D BILL^PRCAUTL Q:('$D(PRCABN)) - S PRCAIBS=$P($G(^DGCR(399,PRCABN,0)),U,13) ; IB claim status - DBIA3820-A - I PRCAIBS=1 W !!,"** You cannot add AR Comments to an Entered/Not Reviewed claim. **",!,*7 G BEGIN - I PRCAIBS=2 W !!,"** You cannot add AR Comments to an MRA Request claim. **",!,*7 G BEGIN - I '$D(^PRCA(430,PRCABN,2,0)),PRCAIBS=7 W !!,"** You cannot add AR Comments to a claim Cancelled/not passed to AR. **",!,*7 G BEGIN - I $P($G(^PRCA(430,PRCABN,0)),"^",8)=49 W !!,"** Comments CANNOT be entered on an ARCHIVED bill. **",!,*7 G BEGIN - D SETTR^PRCAUTL,PATTR^PRCAUTL S DIC="^PRCA(433," K PRCAMT,PRCAD("DELETE") Q +PRCACM ;WASH-ISC@ALTOONA,PA/RGY-COMMENT ADJUSTMENT TRANSACTION ;6/2/95 2:41 PM +V ;;4.5;Accounts Receivable;**8,67,125,169**;Mar 20, 1995 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ;This is a routine for adjustment transaction. + NEW PRCABN,PRCAEN,PRCAA1,DR,DIE,DA,D0,PRCAD,RCASK,PRCAA2,DIROUT,DIRUT,DIR,DUOUT,PRCA,PRCATY +ADJUST D BEGIN G:('$D(PRCABN))!('$D(PRCAEN)) Q + S PRCAA1=$S($D(^PRCA(433,PRCAEN,4,0)):+$P(^(0),U,4),1:0) G Q:PRCAA1'>0 S PRCAA2=$P(^(0),U,3) W ! +DIE S DR="[PRCA COMMENT]",DIE="^PRCA(433,",DA=PRCAEN D ^DIE K DIE,DR,DA + I $P($G(^PRCA(433,PRCAEN,5)),"^",2)=""!'$P(^PRCA(433,PRCAEN,1),"^") S PRCACOMM="TRANSACTION INCOMPLETE" D DELETE^PRCAWO1 K PRCACOMM G:$D(DTOUT) Q G ADJUST + W ! W:$D(IOF) @IOF S D0=PRCAEN K DXS D ^PRCATO4 K DXS + I $P($G(^PRCA(433,PRCAEN,1)),"^")>$P($G(^(5)),"^",3),$P($G(^(5)),"^",3) W !!,*7,"You entered a date of follow-up before the date of contact!" S PRCACOMM="INVALID FOLLOW-UP DATE" D DELETE^PRCAWO1 K PRCACOMM G ADJUST +ASK S %=2 W !!,"Is this correct" D YN^DICN I %=0 W !,"Answer 'Y' or 'YES' if this data is correct, answer 'N' or 'NO' if not",! G ASK + I (%<0)!(%=2) S PRCACOMM="USER CANCELED" D DELETE^PRCAWO1 K PRCACOMM G ADJUST +DONE I '$D(PRCAD("DELETE")) S RCASK=1 D TRANUP^PRCAUTL,UPPRIN^PRCADJ + I $P($G(^RCD(340,+$P(^PRCA(430,PRCABN,0),"^",9),0)),"^")[";DPT(" D + .S $P(^PRCA(433,PRCAEN,0),"^",10)=1 + .S DIR(0)="Y",DIR("A")="Should the BRIEF COMMENT print on the patient statement",DIR("B")="NO" D ^DIR K DIR + .I Y=1 S DIR(0)="Y",DIR("A")="Are you SURE this BRIEF COMMENT should appear on the patient statement",DIR("B")="NO" D ^DIR K DIR I Y=1 D + ..W !!,*7,"*** OK, This comment will appear on the patient's statement! ***",!,"(If you change your mind, use the option Remove/Add Comment From Patient Statement)",! + ..S $P(^PRCA(433,PRCAEN,0),"^",10)="" + ..Q + .Q + G ADJUST +Q Q +EN1 Q:'$D(PRCABN) + NEW X + F X=0:0 S X=$O(^PRCA(433,"C",PRCABN,X)) Q:'X I $P($G(^PRCA(433,X,1)),"^",4) I $P(^(1),"^",2)=1!($P(^(1),"^",2)=35) S PRCAQNM=$P(^(1),"^",4)+1 + Q +ASK1 ;ASK FOR STATUS + NEW DTOUT,DUOUT,DIRUT,DIR,DIROUT + S DIR("A")="Change 'BILL' status to?",DIR("B")="CANCELLED",DIR(0)="SB^1:CANCELLED;2:COLLECTED/CLOSED;" D ^DIR K DIR + I Y=2 S PRCA("STATUS")=$O(^PRCA(430.3,"AC",108,0)) + Q +RPT ; + NEW %DT,BEG,END,DIC,L,FR,TO,FLDS,PRCACM,POP,PRCADEV +ST W !! S %DT="AEX",%DT("A")="Follow-up Date(s) From: " D ^%DT G:Y<0 REPQ S BEG=Y + S %DT="AEX",%DT("A")="Follow-up Date(s) To: " D ^%DT G:Y<0 REPQ S END=Y + I BEG>END W !!,*7," (Ending date must be greater than Start date.)" G ST + S %ZIS="MQ" D ^%ZIS G:POP REPQ S PRCADEV=ION_";"_IOST_";"_IOM_";"_IOSL_";"_$G(IO("DOC")) + I $D(IO("Q")) S Y=$$TI() G:Y<0 REPQ F PRCACM=1,2 S ZTDTH=$H,ZTRTN="DQ"_PRCACM_"^PRCACM",ZTSAVE("BEG")="",ZTSAVE("PRCADEV")="",ZTSAVE("END")="",ZTDESC="Comment Follow-up List" D ^%ZTLOAD G REPQ:PRCACM=2 + D DQ1,DQ2:'$D(DTOUT) +REPQ Q +DQ1 ; + S IOP=PRCADEV,DIC="^PRCA(433,",L=0,BY="[PRCA FOLLOW-UP]",FLDS="[PRCA FOLLOW-UP]",FR=BEG,TO=END D EN1^DIP + D ^%ZISC K IOP + I $E(IOST)="C" W !,*7,"OK, first part of report complete...",!,"press return to continue: " R X:DTIME W @IOF S:X["^"!'$T DTOUT=1 + Q +DQ2 ; + S IOP=PRCADEV D ^%ZIS + I 'POP S IOP=PRCADEV,DIC="^RC(341,",L=0,BY="[RCAM COMMENT]",FLDS="[RCAM COMMENT]",FR=BEG,TO=END D EN1^DIP + D ^%ZISC K IOP + Q +TI() ; + N %DT D NOW^%DTC S %DT("A")="Request Time to Queue? ",%DT("B")="NOW" + S %DT="AERX",%DT(0)=% D ^%DT + Q Y +BEGIN K PRCATERM,PRCABN,PRCAEN,PRCA("CKSITE") D BILL^PRCAUTL Q:('$D(PRCABN)) + I '$D(^PRCA(430,PRCABN,2,0)) W !!,"** This bill was cancelled in IB before it was passed to AR. **",!,*7 G BEGIN + I $P($G(^PRCA(430,PRCABN,0)),"^",8)=49 W !!,"** Comments CANNOT be entered on an ARCHIVED bill. **",!,*7 G BEGIN + D SETTR^PRCAUTL,PATTR^PRCAUTL S DIC="^PRCA(433," K PRCAMT,PRCAD("DELETE") Q diff --git a/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCAGST.m b/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCAGST.m index 2ac61a64..0dd33d57 100644 --- a/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCAGST.m +++ b/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCAGST.m @@ -1,54 +1,54 @@ -PRCAGST ;WASH-ISC@ALTOONA,PA/CMS-Print Patient Statement ;12/12/96 9:39 AM -V ;;4.5;Accounts Receivable;**34,181,190,249**;Mar 20, 1995;Build 2 - ;;Per VHA Directive 10-93-142, this routine should not be modified. - ;ENTRY WITH DEBTOR PRINT STATEMENT -EN(DEB,TBAL,PDAT,PBAL,LDT) ; - NEW ADD,DA,LN,NAM,PAGE,SSN,X,X1,X2,Y - I '$D(SITE) D SITE^PRCAGU - S SSN=$$SSN^RCFN01(DEB),SSN=$S(SSN=-1:"XXXXXXXXX",1:SSN) - S ADD=$$SADD^RCFN01(8) I ADD="" S ADD=$$SADD^RCFN01(1) - S X=0 F Y=1:1:3 I $P(ADD,U,Y)]"" S X=X+1 S ADD(X)=$P(ADD,U,Y) - S X=X+1,ADD(X)=$P(ADD,U,4)_", "_$P(ADD,U,5)_" "_$P(ADD,U,6) - S X=X+1,ADD(X)=$P(ADD,U,7) - W @IOF - W !!,"Department of Veterans Affairs",?50,"Acct No.: ",$P($$SITE^VASITE(),U,3)_"/"_$E(SSN,6,9) - W !,$G(ADD(1)) - S Y=$$FPS^RCAMFN01($S($G(LDT)>0:$E(LDT,1,5),1:$E(DT,1,5))_$TR($J($$PST^RCAMFN01(DEB),2)," ",0),$S(+$E($G(LDT),6,7)>$$STD^RCCPCFN:2,1:1)) D DD^%DT - W !,$G(ADD(2)),?50 I TBAL>0 W "Due: UPON RECEIPT" - W !,$G(ADD(3)),?50,$S(TBAL>0:"Amount Due: $"_$J(TBAL,0,2),1:"NO AMOUNT DUE") - W !,$G(ADD(4)),?50,$S(TBAL'>0:"*THIS IS NOT A BILL*",1:"Amount Paid: _____________") - W !,$G(ADD(5)),?50,"Today's Date: " S Y=DT D DD^%DT W Y - I TBAL'>0 D MES G LB - W !!,?2,"Please Make your Check or Money Order payable to the ""Department of Veterans" - W !,?2,"Affairs"" and send payment to the above address. If you have any questions" - W !,?2,"regarding this statement, please call the number listed above.",!!! -LB K ADD S NAM=$$NAM^RCFN01(DEB) - W !,?7,NAM - S ADD=$$DADD^RCAMADD(DEB,1) ; Get debtor address, confidential if applicable - S X=0 F Y=1:1:3 I $P(ADD,U,Y)]"" S X=X+1 S ADD(X)=$P(ADD,U,Y) - S X=X+1,ADD(X)=$P(ADD,U,4)_", "_$P(ADD,U,5)_" "_$P(ADD,U,6) - F X=0:0 S X=$O(ADD(X)) Q:'X W !,?7,$E(ADD(X),1,40) I X=1 W ?50 X $G(SITE("SCAN")) - W ! - I $G(SITE("COM1"))'="" W !,?2,SITE("COM1") - I $$GMT(DEB) W !,?2,"REDUCTION OF INPATIENT COPAYMENT DUE TO GEOGRAPHIC MEANS TEST STATUS" - W !! I TBAL>0 W !,?10,"Please Detach and Return Top Portion with Payment" - S Y="",$P(Y,"=",80)="" W !,Y - W !,"IMPORTANT: Please read the Notice of Rights accompanying this statement!",! - D ^PRCAGST1 - Q -MES ;text for no amount due - W !!,?2,"This statement is being sent to you to provide you with information" - W !,?2,"concerning transactions affecting your account. If a prepayment offset" - W !,?2,"a bill or you have made one or more payments or charges were removed," - W !,?2,"from your account, you are being sent this statement to confirm these actions.",!! - Q - ; - ; Detect GMT-related status for the statement (fetch all patient's bills) - ; Input: Temporary global ^TMP("PRCAGT",$J,PRDEB) - ; Output: 1 - 'Yes', 0 - 'No' -GMT(PRDEB) N PRDAT,PRBN,PRGMT - S PRGMT=0 ; Default - I $G(PRDEB)'="" S PRDAT=0 F S PRDAT=$O(^TMP("PRCAGT",$J,PRDEB,PRDAT)) Q:'PRDAT D Q:PRGMT - . S PRBN=0 F S PRBN=$O(^TMP("PRCAGT",$J,PRDEB,PRDAT,PRBN)) Q:'PRBN D Q:PRGMT - .. I $$ISGMTBIL^IBAGMT($P($G(^PRCA(430,PRBN,0)),U,1)) S PRGMT=1 - Q PRGMT +PRCAGST ;WASH-ISC@ALTOONA,PA/CMS-Print Patient Statement ;12/12/96 9:39 AM +V ;;4.5;Accounts Receivable;**34,181,190**;Mar 20, 1995 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ;ENTRY WITH DEBTOR PRINT STATEMENT +EN(DEB,TBAL,PDAT,PBAL,LDT) ; + NEW ADD,DA,LN,NAM,PAGE,SSN,X,X1,X2,Y + I '$D(SITE) D SITE^PRCAGU + S SSN=$$SSN^RCFN01(DEB),SSN=$S(SSN=-1:"XXXXXXXXX",1:SSN) + S ADD=$$SADD^RCFN01(8) I ADD="" S ADD=$$SADD^RCFN01(1) + S X=0 F Y=1:1:3 I $P(ADD,U,Y)]"" S X=X+1 S ADD(X)=$P(ADD,U,Y) + S X=X+1,ADD(X)=$P(ADD,U,4)_", "_$P(ADD,U,5)_" "_$P(ADD,U,6) + S X=X+1,ADD(X)=$P(ADD,U,7) + W @IOF + W !!,"Department of Veterans Affairs",?50,"Acct No.: ",SSN + W !,$G(ADD(1)) + S Y=$$FPS^RCAMFN01($S($G(LDT)>0:$E(LDT,1,5),1:$E(DT,1,5))_$TR($J($$PST^RCAMFN01(DEB),2)," ",0),$S(+$E($G(LDT),6,7)>$$STD^RCCPCFN:2,1:1)) D DD^%DT + W !,$G(ADD(2)),?50 I TBAL>0 W "Due: UPON RECEIPT" + W !,$G(ADD(3)),?50,$S(TBAL>0:"Amount Due: $"_$J(TBAL,0,2),1:"NO AMOUNT DUE") + W !,$G(ADD(4)),?50,$S(TBAL'>0:"*THIS IS NOT A BILL*",1:"Amount Paid: _____________") + W !,$G(ADD(5)),?50,"Today's Date: " S Y=DT D DD^%DT W Y + I TBAL'>0 D MES G LB + W !!,?2,"Please Make your Check or Money Order payable to the ""Department of Veterans" + W !,?2,"Affairs"" and send payment to the above address. If you have any questions" + W !,?2,"regarding this statement, please call the number listed above.",!!! +LB K ADD S NAM=$$NAM^RCFN01(DEB) + W !,?7,NAM + S ADD=$$DADD^RCAMADD(DEB,1) ; Get debtor address, confidential if applicable + S X=0 F Y=1:1:3 I $P(ADD,U,Y)]"" S X=X+1 S ADD(X)=$P(ADD,U,Y) + S X=X+1,ADD(X)=$P(ADD,U,4)_", "_$P(ADD,U,5)_" "_$P(ADD,U,6) + F X=0:0 S X=$O(ADD(X)) Q:'X W !,?7,$E(ADD(X),1,40) I X=1 W ?50 X $G(SITE("SCAN")) + W ! + I $G(SITE("COM1"))'="" W !,?2,SITE("COM1") + I $$GMT(DEB) W !,?2,"REDUCTION OF INPATIENT COPAYMENT DUE TO GEOGRAPHIC MEANS TEST STATUS" + W !! I TBAL>0 W !,?10,"Please Detach and Return Top Portion with Payment" + S Y="",$P(Y,"=",80)="" W !,Y + W !,"IMPORTANT: Please read the Notice of Rights accompanying this statement!",! + D ^PRCAGST1 + Q +MES ;text for no amount due + W !!,?2,"This statement is being sent to you to provide you with information" + W !,?2,"concerning transactions affecting your account. If a prepayment offset" + W !,?2,"a bill or you have made one or more payments or charges were removed," + W !,?2,"from your account, you are being sent this statement to confirm these actions.",!! + Q + ; + ; Detect GMT-related status for the statement (fetch all patient's bills) + ; Input: Temporary global ^TMP("PRCAGT",$J,PRDEB) + ; Output: 1 - 'Yes', 0 - 'No' +GMT(PRDEB) N PRDAT,PRBN,PRGMT + S PRGMT=0 ; Default + I $G(PRDEB)'="" S PRDAT=0 F S PRDAT=$O(^TMP("PRCAGT",$J,PRDEB,PRDAT)) Q:'PRDAT D Q:PRGMT + . S PRBN=0 F S PRBN=$O(^TMP("PRCAGT",$J,PRDEB,PRDAT,PRBN)) Q:'PRBN D Q:PRGMT + .. I $$ISGMTBIL^IBAGMT($P($G(^PRCA(430,PRBN,0)),U,1)) S PRGMT=1 + Q PRGMT diff --git a/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCAGST1.m b/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCAGST1.m index cd7cd19f..121044a4 100644 --- a/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCAGST1.m +++ b/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCAGST1.m @@ -1,66 +1,66 @@ -PRCAGST1 ;WASH-ISC@ALTOONA,PA/CMS-Print Patient Statement Bottom ;10/16/96 11:13 AM -V ;;4.5;Accounts Receivable;**2,48,104,176,249**;Mar 20, 1995;Build 2 - ;;Per VHA Directive 10-93-142, this routine should not be modified. - ;ENTRY FROM PRCAGST PAGE 1 - NEW AMT,BN,DAT,DESC,I,REF,THNK,TN,TTY,X,Y,RCTOTAL - D HDR - S DESC(1)="Previous Balance",REF="" D WRL(PDAT,.DESC,PBAL,REF) - S DAT=0 - F S DAT=$O(^TMP("PRCAGT",$J,DEB,DAT)) Q:'DAT S BN=0 F S BN=$O(^TMP("PRCAGT",$J,DEB,DAT,BN)) Q:'BN D - . S REF=$P($G(^PRCA(430,BN,0)),"^") ; Get Bill Name - . I $D(^TMP("PRCAGT",$J,DEB,DAT,BN,0)) S AMT=+^(0) I AMT D Q - .. D BILLDESC(BN,.DESC) ; Compile bill description - .. D WRL(DAT,.DESC,AMT,REF) ; Print the item - . S TN=0 F S TN=$O(^TMP("PRCAGT",$J,DEB,DAT,BN,TN)) Q:'TN S AMT=^(TN) D - .. S TTY=$P(AMT,U,2) S AMT=+AMT - .. D AMOUNT(TN,TTY,.AMT,.THNK) ; Adjust Amount sign (+/-) and "Thank You" flag - .. D TRANDESC(TN,.DESC) ; Compile description - .. D WRL(DAT,.DESC,AMT,REF) ; Print the item - I ($Y+9)>(IOSL-2) D D HDR - . W !,"|" F I=12,46,9,12 S Y="",$P(Y,"_",I)="" W Y,"|" - D SUM^PRCAGST2 - Q -WRL(DAT,DESC,AMT,REF) ;Write transaction - NEW LN,I,X,Y - S LN=1,X=0 F S X=$O(DESC(X)) Q:'X S LN=$G(LN)+1 - I ($Y+LN)>(IOSL-2) D D HDR - . W !,"|" F I=12,46,9,12 S Y="",$P(Y,"_",I)="" W Y,"|" - W !,"|",$S($G(DAT):$$DAT(DAT),1:""),?12,"|",DESC(1),?58,"|",$J(AMT,8,2),?67,"|",?68,$G(REF),?79,"|" - F X=1:0 S X=$O(DESC(X)) Q:'X W !,"|",?12,"|",DESC(X),?58,"|",?67,"|",?79,"|" - Q - ; - ; Get transaction description array -TRANDESC(PRTRAN,RCDESC) N RCTOTAL - ; RCTOTAL not used in reprinted statements. - K RCDESC - D TRANDESC^RCCPCPS1(PRTRAN,45) ; returns RCDESC() array (max. length 45 characters) - Q - ; -AMOUNT(BN,TTY,AMT,THNK) ;Adjust (+/-) amount depending on Transaction Type - N BN0,CAT,TS - S BN0=$G(^PRCA(430,BN,0)),CAT=$$CATN^PRCAFN(+$P(BN0,U,2)) - I ",2,8,9,10,11,14,19,47,34,35,29,"[(","_TTY_",") I AMT'<0 S AMT=-AMT - I ",2,8,9,10,11,12,14,19,47,34,35,29,"'[(","_TTY_",") I AMT<0 S AMT=-AMT - I +CAT=33,TTY=1 I AMT<0 S AMT=-AMT - I +CAT=33,TTY=35 I AMT>0 S AMT=-AMT - S TS=$P($G(^PRCA(430.3,TTY,0)),U,3) I '$D(THNK),(TS=2!(TS=20)) S THNK=1 - Q - ; Description for bills - ; Input: PRBILL - Bill IEN - ; Output: RCDESC(1..n) - Description Array -BILLDESC(PRBILL,RCDESC) K RCDESC - D BILLDESC^RCCPCPS1(PRBILL,45) ; returns RCDESC() array (max. length 45 characters) - Q -DAT(DAT) ;slash date - I 'DAT Q "" - Q $$SLH^RCFN01(DAT,"/") -HDR ;statement transaction header - NEW I,Y - S PAGE=$G(PAGE)+1 - I PAGE>1 W @IOF I $G(^RC(342,1,5))]"" F I=1:1:18 W ! - W !,"Department of Veterans Affairs",?50,"Acct No.:",$P($$SITE^VASITE(),U,3)_"/"_$E(SSN,6,9) - W !,NAM,?50,"Page ",PAGE - S Y="",$P(Y,"_",80)="" W !,Y - W !,"|Date Posted|",?13," Description",?58,"| Amount ",?67,"| Reference |" - W !,"|" F I=12,46,9,12 S Y="",$P(Y,"_",I)="" W Y,"|" - Q +PRCAGST1 ;WASH-ISC@ALTOONA,PA/CMS-Print Patient Statement Bottom ;10/16/96 11:13 AM +V ;;4.5;Accounts Receivable;**2,48,104,176**;Mar 20, 1995 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ;ENTRY FROM PRCAGST PAGE 1 + NEW AMT,BN,DAT,DESC,I,REF,THNK,TN,TTY,X,Y,RCTOTAL + D HDR + S DESC(1)="Previous Balance",REF="" D WRL(PDAT,.DESC,PBAL,REF) + S DAT=0 + F S DAT=$O(^TMP("PRCAGT",$J,DEB,DAT)) Q:'DAT S BN=0 F S BN=$O(^TMP("PRCAGT",$J,DEB,DAT,BN)) Q:'BN D + . S REF=$P($G(^PRCA(430,BN,0)),"^") ; Get Bill Name + . I $D(^TMP("PRCAGT",$J,DEB,DAT,BN,0)) S AMT=+^(0) I AMT D Q + .. D BILLDESC(BN,.DESC) ; Compile bill description + .. D WRL(DAT,.DESC,AMT,REF) ; Print the item + . S TN=0 F S TN=$O(^TMP("PRCAGT",$J,DEB,DAT,BN,TN)) Q:'TN S AMT=^(TN) D + .. S TTY=$P(AMT,U,2) S AMT=+AMT + .. D AMOUNT(TN,TTY,.AMT,.THNK) ; Adjust Amount sign (+/-) and "Thank You" flag + .. D TRANDESC(TN,.DESC) ; Compile description + .. D WRL(DAT,.DESC,AMT,REF) ; Print the item + I ($Y+9)>(IOSL-2) D D HDR + . W !,"|" F I=12,46,9,12 S Y="",$P(Y,"_",I)="" W Y,"|" + D SUM^PRCAGST2 + Q +WRL(DAT,DESC,AMT,REF) ;Write transaction + NEW LN,I,X,Y + S LN=1,X=0 F S X=$O(DESC(X)) Q:'X S LN=$G(LN)+1 + I ($Y+LN)>(IOSL-2) D D HDR + . W !,"|" F I=12,46,9,12 S Y="",$P(Y,"_",I)="" W Y,"|" + W !,"|",$S($G(DAT):$$DAT(DAT),1:""),?12,"|",DESC(1),?58,"|",$J(AMT,8,2),?67,"|",?68,$G(REF),?79,"|" + F X=1:0 S X=$O(DESC(X)) Q:'X W !,"|",?12,"|",DESC(X),?58,"|",?67,"|",?79,"|" + Q + ; + ; Get transaction description array +TRANDESC(PRTRAN,RCDESC) N RCTOTAL + ; RCTOTAL not used in reprinted statements. + K RCDESC + D TRANDESC^RCCPCPS1(PRTRAN,45) ; returns RCDESC() array (max. length 45 characters) + Q + ; +AMOUNT(BN,TTY,AMT,THNK) ;Adjust (+/-) amount depending on Transaction Type + N BN0,CAT,TS + S BN0=$G(^PRCA(430,BN,0)),CAT=$$CATN^PRCAFN(+$P(BN0,U,2)) + I ",2,8,9,10,11,14,19,47,34,35,29,"[(","_TTY_",") I AMT'<0 S AMT=-AMT + I ",2,8,9,10,11,12,14,19,47,34,35,29,"'[(","_TTY_",") I AMT<0 S AMT=-AMT + I +CAT=33,TTY=1 I AMT<0 S AMT=-AMT + I +CAT=33,TTY=35 I AMT>0 S AMT=-AMT + S TS=$P($G(^PRCA(430.3,TTY,0)),U,3) I '$D(THNK),(TS=2!(TS=20)) S THNK=1 + Q + ; Description for bills + ; Input: PRBILL - Bill IEN + ; Output: RCDESC(1..n) - Description Array +BILLDESC(PRBILL,RCDESC) K RCDESC + D BILLDESC^RCCPCPS1(PRBILL,45) ; returns RCDESC() array (max. length 45 characters) + Q +DAT(DAT) ;slash date + I 'DAT Q "" + Q $$SLH^RCFN01(DAT,"/") +HDR ;statement transaction header + NEW I,Y + S PAGE=$G(PAGE)+1 + I PAGE>1 W @IOF I $G(^RC(342,1,5))]"" F I=1:1:18 W ! + W !,"Department of Veterans Affairs",?50,"Acct No.: ",SSN + W !,NAM,?50,"Page ",PAGE + S Y="",$P(Y,"_",80)="" W !,Y + W !,"|Date Posted|",?13," Description",?58,"| Amount ",?67,"| Reference |" + W !,"|" F I=12,46,9,12 S Y="",$P(Y,"_",I)="" W Y,"|" + Q diff --git a/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCASVC.m b/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCASVC.m index 3434f00d..7c82f24d 100644 --- a/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCASVC.m +++ b/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCASVC.m @@ -1,41 +1,41 @@ -PRCASVC ;SF-ISC/YJK-ACCEPT, AMMEND AND CANCEL AR BILL ;9/6/95 2:09 PM -V ;;4.5;Accounts Receivable;**1,21,48,90,136,138,249**;Mar 20, 1995;Build 2 - ;;Per VHA Directive 10-93-142, this routine should not be modified. -REL ;Accept bill into AR - N X,Y - D ^PRCASVC6 G:$D(PRCAERR) Q3 S PRCADEBT=$O(^RCD(340,"B",PRCASV("DEBTOR"),0)) I 'PRCADEBT K DD,DO S DIC="^RCD(340,",DIC(0)="QL",X=PRCASV("DEBTOR"),DLAYGO=340 D FILE^DICN K DIC,DLAYGO,DO Q:Y<0 S PRCADEBT=+Y - D FY S PRCAT=$P(^PRCA(430.2,PRCASV("CAT"),0),"^",6) F Y="IDNO^4","GPNO^6","GPNM^5","INPA^1" S:$D(PRCASV($P(Y,"^"))) $P(^PRCA(430,PRCASV("ARREC"),202),"^",$P(Y,"^",2))=PRCASV($P(Y,"^")) - S DIE="^PRCA(430,",DR="[PRCASV REL]",DA=PRCASV("ARREC") D ^DIE -Q3 K PRCAT,PRCAORA,PRCADEBT,DIE,DR,% - ; set the fund for the bill (set in routine rcxfmsuf) - S:'$G(DA) DA=PRCASV("ARREC") S %=$$GETFUNDB^RCXFMSUF(DA) - I "^27^28^"[("^"_PRCASV("CAT")_"^") D - .N P - .F P=6,8,10,15 S $P(^PRCA(430,DA,11),"^",P)=$S(P=6:1000,P=8:$G(PRCASV("SITE")),P=10:9,1:$P($G(PRCASV("FY")),"^")) - .S $P(^PRCA(430,DA,11),"^",18,999)="" - I PRCASV("CAT")=27 S $P(^PRCA(430,+PRCASV("ARREC"),0),"^",5)=$O(^PRCA(430.6,"B","CHMPV",0)) - I PRCASV("CAT")=29 S $P(^PRCA(430,DA,11),"^",18,999)="" - I "^30^31^32^"[("^"_PRCASV("CAT")_"^") D - .N RCCARE,P - .F P=8,9,10,15 S $P(^PRCA(430,DA,11),"^",P)=$S(P=8:$P(^PRCA(430,DA,0),"^",12),P=9:1,P=10:"02",1:$P($G(PRCASV("FY")),"^")) - .S $P(^PRCA(430,DA,11),"^",18)="" - .S RCCARE=$$TYP^IBRFN(DA),RCCARE(1)=$S(RCCARE="I":8028,RCCARE="O":8029,1:8030),$P(^PRCA(430,DA,11),"^",6)=RCCARE(1) - I $G(PRCASV("MEDCA"))!$G(PRCASV("MEDURE")) D MEDICARE - K DA - Q - ; - ; -FY K:$D(^PRCA(430,PRCASV("ARREC"),2)) ^(2) S PRCAK1=1,PRCAORA=0,^PRCA(430,PRCASV("ARREC"),2,0)="^430.01IA^^" - F J=1:1 S X=$P(PRCASV("FY"),U,PRCAK1),PRCAMT=+$P(PRCASV("FY"),U,PRCAK1+1) D FY1 S PRCAK1=PRCAK1+2 Q:$P(PRCASV("FY"),U,PRCAK1)="" -EXITFY K PRCAK1,J,PRCAMT Q -FY1 S DA(1)=PRCASV("ARREC"),DIC="^PRCA(430,"_DA(1)_",2,",DIC(0)="QL",DLAYGO=430 D ^DIC K DIC,DLAYGO Q:Y<0 S DA=+Y - S PRCAORA=PRCAORA+PRCAMT,$P(^PRCA(430,PRCASV("ARREC"),0),"^",3)=PRCAORA,$P(^(7),"^")=PRCAORA,$P(^(2,DA,0),U,2)=PRCAMT,$P(^(0),"^",8)=PRCAMT - K DA Q - ; -MEDICARE ;Setup Medicare Supplemental amounts - N DR,DIE - I $G(PRCASV("MEDCA")) S DIE="^PRCA(430,",DR="131////"_PRCASV("MEDCA") D ^DIE - I $G(PRCASV("MEDURE")) S DIE="^PRCA(430,",DR="132////"_PRCASV("MEDURE") D ^DIE - K PRCASV("MEDCA"),PRCASV("MEDURE") - Q ;MEDICARE - ; +PRCASVC ;SF-ISC/YJK-ACCEPT, AMMEND AND CANCEL AR BILL ;9/6/95 2:09 PM +V ;;4.5;Accounts Receivable;**1,21,48,90,136,138**;Mar 20, 1995 + ;;Per VHA Directive 10-93-142, this routine should not be modified. +REL ;Accept bill into AR + N X,Y + D ^PRCASVC6 G:$D(PRCAERR) Q3 S PRCADEBT=$O(^RCD(340,"B",PRCASV("DEBTOR"),0)) I 'PRCADEBT K DD,DO S DIC="^RCD(340,",DIC(0)="QL",X=PRCASV("DEBTOR"),DLAYGO=340 D FILE^DICN K DIC,DLAYGO,DO Q:Y<0 S PRCADEBT=+Y + D FY S PRCAT=$P(^PRCA(430.2,PRCASV("CAT"),0),"^",6) F Y="IDNO^4","GPNO^6","GPNM^5","INPA^1" S:$D(PRCASV($P(Y,"^"))) $P(^PRCA(430,PRCASV("ARREC"),202),"^",$P(Y,"^",2))=PRCASV($P(Y,"^")) + S DIE="^PRCA(430,",DR="[PRCASV REL]",DA=PRCASV("ARREC") D ^DIE +Q3 K PRCAT,PRCAORA,PRCADEBT,DIE,DR,% + ; set the fund for the bill (set in routine rcxfmsuf) + S %=$$GETFUNDB^RCXFMSUF(DA) + I "^27^28^"[("^"_PRCASV("CAT")_"^") D + .N P + .F P=6,8,10,15 S $P(^PRCA(430,DA,11),"^",P)=$S(P=6:1000,P=8:$G(PRCASV("SITE")),P=10:9,1:$P($G(PRCASV("FY")),"^")) + .S $P(^PRCA(430,DA,11),"^",18,999)="" + I PRCASV("CAT")=27 S $P(^PRCA(430,+PRCASV("ARREC"),0),"^",5)=$O(^PRCA(430.6,"B","CHMPV",0)) + I PRCASV("CAT")=29 S $P(^PRCA(430,DA,11),"^",18,999)="" + I "^30^31^32^"[("^"_PRCASV("CAT")_"^") D + .N RCCARE,P + .F P=8,9,10,15 S $P(^PRCA(430,DA,11),"^",P)=$S(P=8:$P(^PRCA(430,DA,0),"^",12),P=9:1,P=10:"02",1:$P($G(PRCASV("FY")),"^")) + .S $P(^PRCA(430,DA,11),"^",18)="" + .S RCCARE=$$TYP^IBRFN(DA),RCCARE(1)=$S(RCCARE="I":8028,RCCARE="O":8029,1:8030),$P(^PRCA(430,DA,11),"^",6)=RCCARE(1) + I $G(PRCASV("MEDCA"))!$G(PRCASV("MEDURE")) D MEDICARE + K DA + Q + ; + ; +FY K:$D(^PRCA(430,PRCASV("ARREC"),2)) ^(2) S PRCAK1=1,PRCAORA=0,^PRCA(430,PRCASV("ARREC"),2,0)="^430.01IA^^" + F J=1:1 S X=$P(PRCASV("FY"),U,PRCAK1),PRCAMT=+$P(PRCASV("FY"),U,PRCAK1+1) D FY1 S PRCAK1=PRCAK1+2 Q:$P(PRCASV("FY"),U,PRCAK1)="" +EXITFY K PRCAK1,J,PRCAMT Q +FY1 S DA(1)=PRCASV("ARREC"),DIC="^PRCA(430,"_DA(1)_",2,",DIC(0)="QL",DLAYGO=430 D ^DIC K DIC,DLAYGO Q:Y<0 S DA=+Y + S PRCAORA=PRCAORA+PRCAMT,$P(^PRCA(430,PRCASV("ARREC"),0),"^",3)=PRCAORA,$P(^(7),"^")=PRCAORA,$P(^(2,DA,0),U,2)=PRCAMT,$P(^(0),"^",8)=PRCAMT + K DA Q + ; +MEDICARE ;Setup Medicare Supplemental amounts + N DR,DIE + I $G(PRCASV("MEDCA")) S DIE="^PRCA(430,",DR="131////"_PRCASV("MEDCA") D ^DIE + I $G(PRCASV("MEDURE")) S DIE="^PRCA(430,",DR="132////"_PRCASV("MEDURE") D ^DIE + K PRCASV("MEDCA"),PRCASV("MEDURE") + Q ;MEDICARE + ; diff --git a/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDMC90.m b/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDMC90.m index 8a6e41b7..4a68cc26 100644 --- a/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDMC90.m +++ b/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDMC90.m @@ -1,196 +1,193 @@ -RCDMC90 ;WASH IRMFO@ALTOONA,PA/TJK-DMC 90 DAY ;7/17/97 8:13 AM -V ;;4.5;Accounts Receivable;**45,108,133,121,163,190,192,236,237,229,253**;Mar 20, 1995;Build 9 - ;;Per VHA Directive 2004-038, this routine should not be modified. -ENTER ;Entry point from nightly process - Q:'$D(RCDOC) - ;run the interest and admin for newly flagged Katrina Patients. - I DT'<$P($G(^RC(342,1,30)),"^",1)&(DT'>$P($G(^RC(342,1,30)),"^",2)) D ^RCEXINAD - N DEBTOR,BILL,DEBTOR0,B0,B6,B7,LTRDT3,P30DT,PRIN,INT,ADMIN,B4,B12 - N TPRIN,TINT,TADMIN,ESTDT,CATYP,DFN,CNTR,SITE,LN,FN,MN,STNM,DOB,SITE - N PHONE,QUIT,TOTAL,ZIPCODE,FULLNM,XN,P91DT,OFFAMT,RCNT,TLINE,REPAY,X1,X2 - N LKUP,ADDR,ADDRPHO,CHKPHONE,PSSN - K ^XTMP("RCDMC90",$J),^TMP($J,"RCDMC90") S ^XTMP("RCDMC90",0)=DT - S SITE=$$SITE^RCMSITE(),TLINE="0^0^0" - S X1=DT,X2=-91 D C^%DTC S P91DT=X - S X1=DT,X2=-30 D C^%DTC S P30DT=X - S (CNTR,DEBTOR)=0,RCNT=2 G UPDATE:$G(RCDOC)="W" - ;MASTER SHEET COMPILATION - F S DEBTOR=$O(^PRCA(430,"C",DEBTOR)) Q:DEBTOR'?1N.N D - .N X,RCDFN - .S RCDFN=$P($G(^RCD(340,DEBTOR,0)),"^",1) I $P(RCDFN,";",2)'["DPT" Q - .S X=$$EMERES^PRCAUTL(+RCDFN) I X]""&('$D(^RCD(340,"DMC",1,DEBTOR))) Q ;stop the master sheet compilation for hurricane Katrina sites - .K ^TMP($J,"RCDMC90","BILL") - .S QUIT=1,OFFAMT=+$P($G(^RCD(340,DEBTOR,3)),U,9) - .D PROC(DEBTOR,.QUIT) Q:QUIT - .;COMPILES FIELDS UNIQUE TO MASTER CODE SHEETS - .S FULLNM=$$NM(DFN),FN=$P(FULLNM,U,3),MN=$P(FULLNM,U,4) - .S LN=$P(FULLNM,U,1),XN=$P(FULLNM,U,2) - .S FULLNM=FN_" "_$S(MN'="":$P(MN,".")_" ",1:"")_LN_$S(XN'="":" "_$P(XN,"."),1:"") - .S STNM=$$LJ^XLFSTR($E(FN)_$S(MN'="":$E(MN),1:" ")_$E(LN,1,5),7," ") - .S DOB=$$DATE8(+VADM(3)) - .;SET HOLDING GLOBAL FOR MASTER SHEETS - .S CNTR=CNTR+1 - .S ^XTMP("RCDMC90",$J,CNTR)=$E($$LJ^XLFSTR($P(VADM(2),U),9),1,9)_STNM_SITE_DOB_PHONE_$$LJ^XLFSTR(FULLNM,40)_$$LJ^XLFSTR($E($P(ADDR,U,1),1,2),2) - .S CNTR=CNTR+1 - .S ^XTMP("RCDMC90",$J,CNTR)=$$LJ^XLFSTR($E($P(ADDR,U,1),3,40),38)_$$LJ^XLFSTR($E($P(ADDR,U,2),1,40),40)_$$LJ^XLFSTR($E($P(ADDR,U,3)),1) - .S CNTR=CNTR+1 - .S ^XTMP("RCDMC90",$J,CNTR)=$$LJ^XLFSTR($E($P(ADDR,U,3),2,40),39)_$$LJ^XLFSTR($E($P(ADDR,U,4),1,40),40) - .S CNTR=CNTR+1 - .S ^XTMP("RCDMC90",$J,CNTR)=$$LJ^XLFSTR($E($P(ADDR,U,5),1,40),40)_$$LJ^XLFSTR(ZIPCODE,9)_$$DATE8(ESTDT)_$$AMT(TPRIN)_$$AMT(TINT)_$E($$AMT(TADMIN),1,4) - .S CNTR=CNTR+1 - .S ^XTMP("RCDMC90",$J,CNTR)=$E($$AMT(TADMIN),5,9)_$$DATE8(DT)_CATYP_$$AMT(OFFAMT)_$$AMT($$BAL(DEBTOR))_$E("0000000000",1,10-$L(DEBTOR))_DEBTOR_"$" - .S $P(^RCD(340,DEBTOR,3),U)=1,$P(^(3),U,2)=DT,$P(^(3),U,3)=ESTDT,$P(^(3),U,5)=TOTAL,$P(^(3),U,6)=TPRIN,$P(^(3),U,7)=TINT,$P(^(3),U,8)=TADMIN,^RCD(340,"DMC",1,DEBTOR)="" - .S X=0 F S X=$O(^TMP($J,"RCDMC90","BILL",X)) Q:'X S ^PRCA(430,X,12)=^(X) - .D SETREC - .Q - D COMPILE^RCDMC90U(375,CNTR,5,TLINE),KVAR - Q -UPDATE ;WEEKLY UPDATE COMPILATION - F S DEBTOR=$O(^RCD(340,"DMC",1,DEBTOR)) Q:DEBTOR'?1N.N D - .I '$G(^RCD(340,DEBTOR,3)) K ^RCD(340,"DMC",1,DEBTOR) Q - .S QUIT=1,OFFAMT=+$P(^RCD(340,DEBTOR,3),U,9) - .D PROC(DEBTOR,.QUIT) Q:QUIT - .;SET HOLDING GLOBAL FOR WEEKLY UPDATES - .S CNTR=CNTR+1 - .S ^XTMP("RCDMC90",$J,CNTR)=$E($$LJ^XLFSTR($P(VADM(2),U),9),1,9)_$$LJ^XLFSTR($E($P(ADDR,U,1),1,40),40)_$$LJ^XLFSTR($E($P(ADDR,U,2),1,30),30) - .S CNTR=CNTR+1 - .S ^XTMP("RCDMC90",$J,CNTR)=$$LJ^XLFSTR($E($P(ADDR,U,2),31,40),10)_$$LJ^XLFSTR($E($P(ADDR,U,3),1,40),40)_$$LJ^XLFSTR($E($P(ADDR,U,4),1,29),29) - .S CNTR=CNTR+1 - .S ^XTMP("RCDMC90",$J,CNTR)=$$LJ^XLFSTR($E($P(ADDR,U,4),30,40),11)_$$LJ^XLFSTR($E($P(ADDR,U,5),1,40),40)_$$LJ^XLFSTR(ZIPCODE,9)_SITE_PHONE_$E($$AMT(TPRIN),1,6) - .S CNTR=CNTR+1 - .S ^XTMP("RCDMC90",$J,CNTR)=$E($$AMT(TPRIN),7,9)_$$AMT(TINT)_$$AMT(TADMIN)_$$DATE8(DT)_CATYP_$$AMT(OFFAMT)_$$AMT($$BAL(DEBTOR))_"$" - .S:TOTAL $P(^RCD(340,DEBTOR,3),U,5)=TOTAL,$P(^(3),U,6)=TPRIN,$P(^(3),U,7)=TINT,$P(^(3),U,8)=TADMIN - .D SETREC - .Q - D COMPILE^RCDMC90U(300,CNTR,4,TLINE),KVAR - Q -KVAR D KVAR^VADPT - K RCDOC,^XTMP("RCDMC90",$J),VA("BID"),XMDUZ - Q -PROC(DEBTOR,QUIT) ;PROCESS BILLS FOR A SPECIFIC DEBTOR - ;SETS DATA COMMON TO BOTH WEEKLY & MASTER CODESHEETS - S DEBTOR0=$G(^RCD(340,DEBTOR,0)) - Q:$P(DEBTOR0,U)'["DPT" - S DFN=+DEBTOR0 D DEM^VADPT Q:$E(VADM(2),1,5)="00000" - F X=1:1:6 S CATYP(X)="" - S (BILL,TOTAL,TPRIN,TINT,TADMIN,REPAY)=0,ESTDT=P91DT - I RCDOC="W",$P(^RCD(340,DEBTOR,3),U,10) G TOTAL - F S BILL=$O(^PRCA(430,"C",DEBTOR,BILL)) Q:BILL'?1N.N D K:PRIN=0 ^PRCA(430,BILL,12) Q:REPAY - .S (PRIN,INT,ADMIN)=0 - .I +VADM(6) Q - .S B0=$G(^PRCA(430,BILL,0)),B4=$G(^(4)),B6=$G(^(6)),B7=$G(^(7)),B12=$G(^(12)) - .Q:$P(B0,U,8)'=16 - .I B4 D Q - ..S (TOTAL,TPRIN,TINT,TADMIN)=0 - ..S X=0 F S X=$O(^PRCA(430,"C",DEBTOR,X)) Q:X'?1N.N K ^PRCA(430,X,12) - ..S REPAY=1 - ..Q - .I RCDOC="W",'$P(B12,U) Q - .S PRIN=$P(B7,U),INT=$P(B7,U,2),ADMIN=$P(B7,U,3)+$P(B7,U,4)+$P(B7,U,5) - .I PRIN'>0,INT+ADMIN>0 D Q - ..N XMSUB,XMY,XMTEXT,MSG - ..S XMSUB="Notice Of Active Bill Without Principal Balance" - ..S XMY("G.DMR")="" - ..S XMDUZ="AR PACKAGE" - ..S XMTEXT="MSG(" - ..S MSG(1)="The following bill has a 0 principal balance," - ..S MSG(2)="but has interest/admin charges remaining." - ..S MSG(3)="These charges should be exempted" - ..S MSG(4)=" " - ..S MSG(5)="BILL #: "_$P(B0,U) - ..D ^XMD - ..Q - .Q:$P(B4,U) - .S LTRDT3=$P(B6,U,3) Q:'LTRDT3 Q:LTRDT3>P30DT - .;CHECK FOR DC REFERRAL HERE - .I $P(B6,U,4),($P(B6,U,5)="DC")!($P(B6,U,5)="RC") Q - .;Q:$$INSURED^IBCNS1(DFN,$P(B0,U,10)) ;Commented out w/patch *121 - .S X=$P(B0,U,2),X=$S(X=22:1,X=23:1,(X>2)&(X<6):2,X=18:2,X=24:2,X=25:2,X=1:3,X=2:4,(X>26)&(X<30):5,X>29:6,1:"") - .Q:X="" K CATYP(X) - .;Check if bill should be deferred from being sent to DMC if Veteran is - .;SC 50% to 100% or Receiving VA Pension (Hold Debt to DMC project, sbw) - .Q:+$$HOLDCHK^RCDMCUT1(BILL,DFN)>0 - .I $P(B6,U,21),$P(B6,U,21)$P(B12,U,2) S PRIN=$P(B12,U,2) - .S ^TMP($J,"RCDMC90","BILL",BILL)=$S($P(B12,U):$P(B12,U),1:DT)_U_PRIN_U_INT_U_ADMIN - .S TPRIN=TPRIN+PRIN,TINT=TINT+INT,TADMIN=TADMIN+ADMIN - .Q -TOTAL S TOTAL=TPRIN+TINT+TADMIN - I RCDOC="M" Q:TPRIN'>0 ;PRCA*4.5*229 - I RCDOC="M",'+$$SWSTAT^IBBAPI() Q:TOTAL<25 ;PRCA*4.5*229 - ; - I RCDOC="M",$P(VADM(2),U)["P" S PSSN=$P(VADM(2),U) D PSEUDO^RCDMC90U(DFN,PSSN) Q - I RCDOC="W" Q:(TOTAL_U_TPRIN_U_TINT_U_TADMIN)=$P(^RCD(340,DEBTOR,3),U,5,8) - S DFN=+DEBTOR0 - ;SETS CATEGORY CODE 1=MEANS TEST,2=PHARMACY,3=INEL.,4=EMER./HUM. - ;5=CHAMPVA,6=TRICARE OR ANY COMBINATION THEREOF - S CATYP="" F X=1:1:6 S:'$D(CATYP(X)) CATYP=CATYP_X - S CATYP=$$LJ^XLFSTR(CATYP,6) - ; - ;Send Master/Weekly error msg if Unknown or Invalid address - ;If Master update, quit and don't refer to DMC - ;If Weekly update, send a zero balance - S LKUP=$$CHKADD(DEBTOR) - I LKUP D ERROR^RCDMC90U(RCDOC,LKUP,DFN) Q:RCDOC="M" S (TOTAL,TPRIN,TINT,TADMIN)=0 - ; - S ZIPCODE=$TR($P(ADDR,U,6),"-") - ; - ;Retrieve and format patient phone number - S ADDRPHO=$P(ADDR,U,7),PHONE="" - F I=1:1:$L(ADDRPHO) S CHKPHONE=$E(ADDRPHO,I) I CHKPHONE?1N S PHONE=PHONE_CHKPHONE - S PHONE=$S(PHONE?10N:PHONE,PHONE?7N:" "_PHONE,1:" ") - ; - I RCDOC="W",TOTAL=0 D - .K ^RCD(340,"DMC",1,DEBTOR),^RCD(340,DEBTOR,3) - .N NM,XMSUB,XMY,XMTEXT,MSG - .S XMSUB="Deletion of Debtor from DMC" - .S XMY("G.DMX")="" - .S XMDUZ="AR PACKAGE" - .S XMTEXT="MSG(" - .S MSG(1)="The following patient has a DMC balance of '0'" - .S MSG(2)="and will be deleted from the DMC system:" - .S MSG(3)=" " - .S MSG(4)=$P(^DPT(DFN,0),U)_" SSN: "_$P(^(0),U,9) - .D ^XMD - .Q - S QUIT=0 -PROCQ Q -DATE8(X) ;CHANGES FILEMAN DATE INTO 8 DIGIT DATE IN FORMAT MMDDYYYY - S X=$E(X,4,7)_($E(X,1,3)+1700) - Q X -AMT(X) ;CHANGES AMOUNT TO ZERO FILLED, RIGHT JUSTIFIED - S X=$TR($J(X,0,2),".") - S X=$E("000000000",1,9-$L(X))_X - Q X -NM(DFN) ;Returns first, middle, and last name in 3 different variables - N FN,LN,MN,NM,XN - S NM=$P($G(^DPT(DFN,0)),"^") - S LN=$TR($P(NM,",")," .'-"),MN=$P($P(NM,",",2)," ",2) - I ($E(MN,1,2)="SR")!($E(MN,1,2)="JR")!(MN?2.3"I")!(MN?0.1"I"1"V"1.3"I") S XN=MN,MN="" - I $G(XN)="" S XN=$P($P($G(NM),",",2)," ",3) - S FN=$P($P(NM,",",2)," ") -QNM Q LN_"^"_XN_"^"_FN_"^"_MN -BAL(DEBTOR) ;COMPUTES TOTAL OF ACTIVE BILLS THAT COULD BE SENT TO DMC - N BILL,BAL - S (BILL,BAL)=0 - F S BILL=$O(^PRCA(430,"C",DEBTOR,BILL)) Q:BILL'?1N.N D - .S B0=$G(^PRCA(430,BILL,0)),B7=$G(^(7)) - .Q:$P(B0,U,8)'=16 - .S X=$P(B0,U,2),X=$S((X>0)&(X<6):1,X=18:1,(X>21)&(X<26):1,(X>26)&(X<33):1,1:"") - .Q:X="" - .S BAL=BAL+$P(B7,U)+$P(B7,U,2)+$P(B7,U,3)+$P(B7,U,4)+$P(B7,U,5) - .Q -BALQ Q BAL -SETREC ;SETS TEMPORARY GLOBAL FOR MAIL MESSAGE TO USERS - S RCNT=RCNT+1 D PID^VADPT S:$L(VA("BID"))=4 VA("BID")=" "_VA("BID") - S TLINE=($P(TLINE,U)+TPRIN)_U_($P(TLINE,U,2)+TINT)_U_($P(TLINE,U,3)+TADMIN) - S ^XTMP("RCDMC90",$J,"REC",$P(^DPT(DFN,0),U)_";"_DFN)=$$LJ^XLFSTR($E($P(^DPT(DFN,0),U),1,28),29)_" "_VA("BID")_" "_$J(TPRIN,10,2)_$J(TINT,10,2)_$J(TADMIN,10,2)_$J(TOTAL,10,2) - Q - ; -CHKADD(DEBTOR) ; Checks for invalid and unknown addresses - N CHK S CHK=0,ADDR="" - I $P($G(^RCD(340,+DEBTOR,1)),"^",9)=1 S CHK=1 G CHKADDQ - S ADDR=$$DADD^RCAMADD(+DEBTOR,1) ;get address (confidential if possible) - I ADDR'?.ANP!(ADDR["$")!(ADDR["**")!(ADDR["///")!(ADDR["ZZZ") S CHK=2 -CHKADDQ Q CHK - ; +RCDMC90 ;WASH IRMFO@ALTOONA,PA/TJK-DMC 90 DAY ;7/17/97 8:13 AM +V ;;4.5;Accounts Receivable;**45,108,133,121,163,190,192,236,237,229**;Mar 20, 1995 + ;;Per VHA Directive 10-93-142, this routine should not be modified. +ENTER ;Entry point from nightly process + Q:'$D(RCDOC) + ;run the interest and admin for newly flagged Katrina Patients. + I DT'<$P($G(^RC(342,1,30)),"^",1)&(DT'>$P($G(^RC(342,1,30)),"^",2)) D ^RCEXINAD + N DEBTOR,BILL,DEBTOR0,B0,B6,B7,LTRDT3,P30DT,PRIN,INT,ADMIN,B4,B12 + N TPRIN,TINT,TADMIN,ESTDT,CATYP,DFN,CNTR,SITE,LN,FN,MN,STNM,DOB,SITE + N PHONE,QUIT,TOTAL,ZIPCODE,FULLNM,XN,P91DT,OFFAMT,RCNT,TLINE,REPAY,X1,X2 + N LKUP,ADDR,ADDRPHO,CHKPHONE,PSSN + K ^XTMP("RCDMC90",$J),^TMP($J,"RCDMC90") S ^XTMP("RCDMC90",0)=DT + S SITE=$$SITE^RCMSITE(),TLINE="0^0^0" + S X1=DT,X2=-91 D C^%DTC S P91DT=X + S X1=DT,X2=-30 D C^%DTC S P30DT=X + S (CNTR,DEBTOR)=0,RCNT=2 G UPDATE:$G(RCDOC)="W" + ;MASTER SHEET COMPILATION + F S DEBTOR=$O(^PRCA(430,"C",DEBTOR)) Q:DEBTOR'?1N.N D + .N X,RCDFN + .S RCDFN=$P($G(^RCD(340,DEBTOR,0)),"^",1) I $P(RCDFN,";",2)'["DPT" Q + .S X=$$EMERES^PRCAUTL(+RCDFN) I X]""&('$D(^RCD(340,"DMC",1,DEBTOR))) Q ;stop the master sheet compilation for hurricane Katrina sites + .K ^TMP($J,"RCDMC90","BILL") + .S QUIT=1,OFFAMT=+$P($G(^RCD(340,DEBTOR,3)),U,9) + .D PROC(DEBTOR,.QUIT) Q:QUIT + .;COMPILES FIELDS UNIQUE TO MASTER CODE SHEETS + .S FULLNM=$$NM(DFN),FN=$P(FULLNM,U,3),MN=$P(FULLNM,U,4) + .S LN=$P(FULLNM,U,1),XN=$P(FULLNM,U,2) + .S FULLNM=FN_" "_$S(MN'="":$P(MN,".")_" ",1:"")_LN_$S(XN'="":" "_$P(XN,"."),1:"") + .S STNM=$$LJ^XLFSTR($E(FN)_$S(MN'="":$E(MN),1:" ")_$E(LN,1,5),7," ") + .S DOB=$$DATE8(+VADM(3)) + .;SET HOLDING GLOBAL FOR MASTER SHEETS + .S CNTR=CNTR+1 + .S ^XTMP("RCDMC90",$J,CNTR)=$E($$LJ^XLFSTR($P(VADM(2),U),9),1,9)_STNM_SITE_DOB_PHONE_$$LJ^XLFSTR(FULLNM,40)_$$LJ^XLFSTR($E($P(ADDR,U,1),1,2),2) + .S CNTR=CNTR+1 + .S ^XTMP("RCDMC90",$J,CNTR)=$$LJ^XLFSTR($E($P(ADDR,U,1),3,40),38)_$$LJ^XLFSTR($E($P(ADDR,U,2),1,40),40)_$$LJ^XLFSTR($E($P(ADDR,U,3)),1) + .S CNTR=CNTR+1 + .S ^XTMP("RCDMC90",$J,CNTR)=$$LJ^XLFSTR($E($P(ADDR,U,3),2,40),39)_$$LJ^XLFSTR($E($P(ADDR,U,4),1,40),40) + .S CNTR=CNTR+1 + .S ^XTMP("RCDMC90",$J,CNTR)=$$LJ^XLFSTR($E($P(ADDR,U,5),1,40),40)_$$LJ^XLFSTR(ZIPCODE,9)_$$DATE8(ESTDT)_$$AMT(TPRIN)_$$AMT(TINT)_$E($$AMT(TADMIN),1,4) + .S CNTR=CNTR+1 + .S ^XTMP("RCDMC90",$J,CNTR)=$E($$AMT(TADMIN),5,9)_$$DATE8(DT)_CATYP_$$AMT(OFFAMT)_$$AMT($$BAL(DEBTOR))_$E("0000000000",1,10-$L(DEBTOR))_DEBTOR_"$" + .S $P(^RCD(340,DEBTOR,3),U)=1,$P(^(3),U,2)=DT,$P(^(3),U,3)=ESTDT,$P(^(3),U,5)=TOTAL,$P(^(3),U,6)=TPRIN,$P(^(3),U,7)=TINT,$P(^(3),U,8)=TADMIN,^RCD(340,"DMC",1,DEBTOR)="" + .S X=0 F S X=$O(^TMP($J,"RCDMC90","BILL",X)) Q:'X S ^PRCA(430,X,12)=^(X) + .D SETREC + .Q + D COMPILE^RCDMC90U(375,CNTR,5,TLINE),KVAR + Q +UPDATE ;WEEKLY UPDATE COMPILATION + F S DEBTOR=$O(^RCD(340,"DMC",1,DEBTOR)) Q:DEBTOR'?1N.N D + .I '$G(^RCD(340,DEBTOR,3)) K ^RCD(340,"DMC",1,DEBTOR) Q + .S QUIT=1,OFFAMT=+$P(^RCD(340,DEBTOR,3),U,9) + .D PROC(DEBTOR,.QUIT) Q:QUIT + .;SET HOLDING GLOBAL FOR WEEKLY UPDATES + .S CNTR=CNTR+1 + .S ^XTMP("RCDMC90",$J,CNTR)=$E($$LJ^XLFSTR($P(VADM(2),U),9),1,9)_$$LJ^XLFSTR($E($P(ADDR,U,1),1,40),40)_$$LJ^XLFSTR($E($P(ADDR,U,2),1,30),30) + .S CNTR=CNTR+1 + .S ^XTMP("RCDMC90",$J,CNTR)=$$LJ^XLFSTR($E($P(ADDR,U,2),31,40),10)_$$LJ^XLFSTR($E($P(ADDR,U,3),1,40),40)_$$LJ^XLFSTR($E($P(ADDR,U,4),1,29),29) + .S CNTR=CNTR+1 + .S ^XTMP("RCDMC90",$J,CNTR)=$$LJ^XLFSTR($E($P(ADDR,U,4),30,40),11)_$$LJ^XLFSTR($E($P(ADDR,U,5),1,40),40)_$$LJ^XLFSTR(ZIPCODE,9)_SITE_PHONE_$E($$AMT(TPRIN),1,6) + .S CNTR=CNTR+1 + .S ^XTMP("RCDMC90",$J,CNTR)=$E($$AMT(TPRIN),7,9)_$$AMT(TINT)_$$AMT(TADMIN)_$$DATE8(DT)_CATYP_$$AMT(OFFAMT)_$$AMT($$BAL(DEBTOR))_"$" + .S:TOTAL $P(^RCD(340,DEBTOR,3),U,5)=TOTAL,$P(^(3),U,6)=TPRIN,$P(^(3),U,7)=TINT,$P(^(3),U,8)=TADMIN + .D SETREC + .Q + D COMPILE^RCDMC90U(300,CNTR,4,TLINE),KVAR + Q +KVAR D KVAR^VADPT + K RCDOC,^XTMP("RCDMC90",$J),VA("BID"),XMDUZ + Q +PROC(DEBTOR,QUIT) ;PROCESS BILLS FOR A SPECIFIC DEBTOR + ;SETS DATA COMMON TO BOTH WEEKLY & MASTER CODESHEETS + S DEBTOR0=$G(^RCD(340,DEBTOR,0)) + Q:$P(DEBTOR0,U)'["DPT" + S DFN=+DEBTOR0 D DEM^VADPT Q:$E(VADM(2),1,5)="00000" + F X=1:1:6 S CATYP(X)="" + S (BILL,TOTAL,TPRIN,TINT,TADMIN,REPAY)=0,ESTDT=P91DT + I RCDOC="W",$P(^RCD(340,DEBTOR,3),U,10) G TOTAL + F S BILL=$O(^PRCA(430,"C",DEBTOR,BILL)) Q:BILL'?1N.N D K:PRIN=0 ^PRCA(430,BILL,12) Q:REPAY + .S (PRIN,INT,ADMIN)=0 + .I +VADM(6) Q + .S B0=$G(^PRCA(430,BILL,0)),B4=$G(^(4)),B6=$G(^(6)),B7=$G(^(7)),B12=$G(^(12)) + .Q:$P(B0,U,8)'=16 + .I B4 D Q + ..S (TOTAL,TPRIN,TINT,TADMIN)=0 + ..S X=0 F S X=$O(^PRCA(430,"C",DEBTOR,X)) Q:X'?1N.N K ^PRCA(430,X,12) + ..S REPAY=1 + ..Q + .I RCDOC="W",'$P(B12,U) Q + .S PRIN=$P(B7,U),INT=$P(B7,U,2),ADMIN=$P(B7,U,3)+$P(B7,U,4)+$P(B7,U,5) + .I PRIN'>0,INT+ADMIN>0 D Q + ..N XMSUB,XMY,XMTEXT,MSG + ..S XMSUB="Notice Of Active Bill Without Principal Balance" + ..S XMY("G.DMR")="" + ..S XMDUZ="AR PACKAGE" + ..S XMTEXT="MSG(" + ..S MSG(1)="The following bill has a 0 principal balance," + ..S MSG(2)="but has interest/admin charges remaining." + ..S MSG(3)="These charges should be exempted" + ..S MSG(4)=" " + ..S MSG(5)="BILL #: "_$P(B0,U) + ..D ^XMD + ..Q + .Q:$P(B4,U) + .S LTRDT3=$P(B6,U,3) Q:'LTRDT3 Q:LTRDT3>P30DT + .;CHECK FOR DC REFERRAL HERE + .I $P(B6,U,4),($P(B6,U,5)="DC")!($P(B6,U,5)="RC") Q + .;Q:$$INSURED^IBCNS1(DFN,$P(B0,U,10)) ;Commented out w/patch *121 + .S X=$P(B0,U,2),X=$S(X=22:1,X=23:1,(X>2)&(X<6):2,X=18:2,X=24:2,X=25:2,X=1:3,X=2:4,(X>26)&(X<30):5,X>29:6,1:"") + .Q:X="" K CATYP(X) + .I $P(B6,U,21),$P(B6,U,21)$P(B12,U,2) S PRIN=$P(B12,U,2) + .S ^TMP($J,"RCDMC90","BILL",BILL)=$S($P(B12,U):$P(B12,U),1:DT)_U_PRIN_U_INT_U_ADMIN + .S TPRIN=TPRIN+PRIN,TINT=TINT+INT,TADMIN=TADMIN+ADMIN + .Q +TOTAL S TOTAL=TPRIN+TINT+TADMIN + I RCDOC="M" Q:TPRIN'>0 ;PRCA*4.5*229 + I RCDOC="M",'+$$SWSTAT^IBBAPI() Q:TOTAL<25 ;PRCA*4.5*229 + ; + I RCDOC="M",$P(VADM(2),U)["P" S PSSN=$P(VADM(2),U) D PSEUDO^RCDMC90U(DFN,PSSN) Q + I RCDOC="W" Q:(TOTAL_U_TPRIN_U_TINT_U_TADMIN)=$P(^RCD(340,DEBTOR,3),U,5,8) + S DFN=+DEBTOR0 + ;SETS CATEGORY CODE 1=MEANS TEST,2=PHARMACY,3=INEL.,4=EMER./HUM. + ;5=CHAMPVA,6=TRICARE OR ANY COMBINATION THEREOF + S CATYP="" F X=1:1:6 S:'$D(CATYP(X)) CATYP=CATYP_X + S CATYP=$$LJ^XLFSTR(CATYP,6) + ; + ;Send Master/Weekly error msg if Unknown or Invalid address + ;If Master update, quit and don't refer to DMC + ;If Weekly update, send a zero balance + S LKUP=$$CHKADD(DEBTOR) + I LKUP D ERROR^RCDMC90U(RCDOC,LKUP,DFN) Q:RCDOC="M" S (TOTAL,TPRIN,TINT,TADMIN)=0 + ; + S ZIPCODE=$TR($P(ADDR,U,6),"-") + ; + ;Retrieve and format patient phone number + S ADDRPHO=$P(ADDR,U,7),PHONE="" + F I=1:1:$L(ADDRPHO) S CHKPHONE=$E(ADDRPHO,I) I CHKPHONE?1N S PHONE=PHONE_CHKPHONE + S PHONE=$S(PHONE?10N:PHONE,PHONE?7N:" "_PHONE,1:" ") + ; + I RCDOC="W",TOTAL=0 D + .K ^RCD(340,"DMC",1,DEBTOR),^RCD(340,DEBTOR,3) + .N NM,XMSUB,XMY,XMTEXT,MSG + .S XMSUB="Deletion of Debtor from DMC" + .S XMY("G.DMX")="" + .S XMDUZ="AR PACKAGE" + .S XMTEXT="MSG(" + .S MSG(1)="The following patient has a DMC balance of '0'" + .S MSG(2)="and will be deleted from the DMC system:" + .S MSG(3)=" " + .S MSG(4)=$P(^DPT(DFN,0),U)_" SSN: "_$P(^(0),U,9) + .D ^XMD + .Q + S QUIT=0 +PROCQ Q +DATE8(X) ;CHANGES FILEMAN DATE INTO 8 DIGIT DATE IN FORMAT MMDDYYYY + S X=$E(X,4,7)_($E(X,1,3)+1700) + Q X +AMT(X) ;CHANGES AMOUNT TO ZERO FILLED, RIGHT JUSTIFIED + S X=$TR($J(X,0,2),".") + S X=$E("000000000",1,9-$L(X))_X + Q X +NM(DFN) ;Returns first, middle, and last name in 3 different variables + N FN,LN,MN,NM,XN + S NM=$P($G(^DPT(DFN,0)),"^") + S LN=$TR($P(NM,",")," .'-"),MN=$P($P(NM,",",2)," ",2) + I ($E(MN,1,2)="SR")!($E(MN,1,2)="JR")!(MN?2.3"I")!(MN?0.1"I"1"V"1.3"I") S XN=MN,MN="" + I $G(XN)="" S XN=$P($P($G(NM),",",2)," ",3) + S FN=$P($P(NM,",",2)," ") +QNM Q LN_"^"_XN_"^"_FN_"^"_MN +BAL(DEBTOR) ;COMPUTES TOTAL OF ACTIVE BILLS THAT COULD BE SENT TO DMC + N BILL,BAL + S (BILL,BAL)=0 + F S BILL=$O(^PRCA(430,"C",DEBTOR,BILL)) Q:BILL'?1N.N D + .S B0=$G(^PRCA(430,BILL,0)),B7=$G(^(7)) + .Q:$P(B0,U,8)'=16 + .S X=$P(B0,U,2),X=$S((X>0)&(X<6):1,X=18:1,(X>21)&(X<26):1,(X>26)&(X<33):1,1:"") + .Q:X="" + .S BAL=BAL+$P(B7,U)+$P(B7,U,2)+$P(B7,U,3)+$P(B7,U,4)+$P(B7,U,5) + .Q +BALQ Q BAL +SETREC ;SETS TEMPORARY GLOBAL FOR MAIL MESSAGE TO USERS + S RCNT=RCNT+1 D PID^VADPT S:$L(VA("BID"))=4 VA("BID")=" "_VA("BID") + S TLINE=($P(TLINE,U)+TPRIN)_U_($P(TLINE,U,2)+TINT)_U_($P(TLINE,U,3)+TADMIN) + S ^XTMP("RCDMC90",$J,"REC",$P(^DPT(DFN,0),U)_";"_DFN)=$$LJ^XLFSTR($E($P(^DPT(DFN,0),U),1,28),29)_" "_VA("BID")_" "_$J(TPRIN,10,2)_$J(TINT,10,2)_$J(TADMIN,10,2)_$J(TOTAL,10,2) + Q + ; +CHKADD(DEBTOR) ; Checks for invalid and unknown addresses + N CHK S CHK=0,ADDR="" + I $P($G(^RCD(340,+DEBTOR,1)),"^",9)=1 S CHK=1 G CHKADDQ + S ADDR=$$DADD^RCAMADD(+DEBTOR,1) ;get address (confidential if possible) + I ADDR'?.ANP!(ADDR["$")!(ADDR["**")!(ADDR["///")!(ADDR["ZZZ") S CHK=2 +CHKADDQ Q CHK + ; diff --git a/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPEM.m b/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPEM.m index c4ae0502..9ffe9b2c 100644 --- a/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPEM.m +++ b/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPEM.m @@ -1,166 +1,166 @@ -RCDPEM ;ALB/TMK - POST EFT, ERA MATCHING TO EFT ;05-NOV-02 - ;;4.5;Accounts Receivable;**173,255**;Mar 20, 1995;Build 1 - ;;Per VHA Directive 10-93-142, this routine should not be modified. - ; IA 4050 covers call to SPL1^IBCEOBAR - Q - ; Note - keep processing in line with RCDPXPAP -EN ; Post EFT deposits, auto-match EFT's and ERA's - ; - K ^TMP($J,"RCDPETOT") - ; ^TMP($J,"RCDPETOT",344.3 or 344.31,file ien)= - ; (1) match (0/1/-1) (2) total $ (3) posted (0/1) (4) error ref - ; (5) EFT deposit ien 344.1 if added for EFT - ; - N RCZ,RCSUM,RCDEP,RECTDA,RC0,RCER,RCDUZ,Z,Z0,Z1,DA,X,Y,DIE,DR - M RCDUZ=DUZ - N DUZ S DUZ=+$O(^VA(200,"B","EDILOCKBOX,AUTOMATIC",0)),DUZ(0)="" S:'DUZ DUZ=.5 - K ^TMP($J,"RCXM"),^TMP($J,"RCTOT") - S ZTREQ="@" - L +^RCY(344.3,"ALOCK"):5 I '$T D G ENQ ; Lock record - . ; Send bulletin that job could not be run - . S ^TMP($J,"RCXM",1)="The nightly job to post EFT deposits and match EFTs to ERAs could not be run",^TMP($J,"RCXM",2)="Another match process was already running (lock on ^RCY(344.3,""ALOCK"") )" - . D SENDBULL^RCDPEM1 - ; - ; Post deposits for any unposted EFTs in file 344.3 - ; 'Unposted' EFTs have a 0 in AMOUNT POSTED field - S ^TMP($J,"RCTOT","EFT_DEP")=0 - S RCZ=0 F S RCZ=$O(^RCY(344.3,"APOST",0,RCZ)) Q:'RCZ S RC0=$G(^RCY(344.3,RCZ,0)) I RC0'="",$P(RC0,U,8),($E($P(RC0,U,6),1,3)="469")!($E($P(RC0,U,6),1,3)="569") D - . S ^TMP($J,"RCTOT","EFT_DEP")=^TMP($J,"RCTOT","EFT_DEP")+1 - . ; Verify check sums - . S RCSUM=$$CHKSUM^RCDPESR3(RCZ) - . I RCSUM'=$P(RC0,U,9) D Q - .. ; Bulletin that check sums do not match - .. ; Update record error list and checksum error field - .. S RCER(1)=$$SETERR^RCDPEM0(2) - .. S RCER(2)=" Checksum is invalid and the EFT deposit record is corrupted.",RCER(3)=" Stored Checksum = "_$P(RC0,U,9)_" Calculated Checksum: "_RCSUM,RCER(4)=" This EFT deposit cannot be sent to FMS. You must ask for it to be" - .. S RCER(5)=" retransmitted to your site." - .. D BULL^RCDPEM1(344.3,RC0,.RCER) - .. S $P(^TMP($J,"RCDPETOT",344.3,RCZ),U,4)=+$G(^TMP($J,"RCXM",0)) - .. D STORERR^RCDPEM0(RCZ,.RCER) - .. S DIE="^RCY(344.3,",DA=RCZ,DR=".1////1" D ^DIE - .. S ^TMP($J,"RCTOT","CSUM")=$G(^TMP($J,"RCTOT","CSUM"))+1 - . ; - . S RCDEP=+$P(RC0,U,3),RECTDA=+$O(^RCY(344,"AD",RCDEP,0)) - . I RCDEP D LOCKDEP(RCDEP,1) - . I 'RCDEP!'RECTDA D ; Add deposit and/or receipt to files 344.1, 344 - .. I 'RCDEP D ; Add dep record RCDEP, update field .03 with the pointer - ... S RCDEP=+$$ADDDEP^RCDPEM0($P(RC0,U,6),$P(RC0,U,7),RCZ) - ... S ^TMP($J,"RCTOT","DEPOSIT")=$G(^TMP($J,"RCTOT","DEPOSIT"))+1 - .. ; - .. I 'RECTDA,RCDEP D ; Add receipt record, post to rev source cd 8NZZ - ... S RECTDA=+$$ADDREC^RCDPEM0(RCDEP,RCZ) - .. ; - . I RCDEP D LOCKDEP(RCDEP,0) - . ; - . I 'RCDEP!'RECTDA D Q ; Could not add entry to file 344.1 or 344 - .. ; Send a bulletin, update error text - .. S RCER(1)=$$SETERR^RCDPEM0(2),RCER(2)=" "_$S('RCDEP:"Neither a deposit nor a receipt were able",1:"A receipt was not able")_" to be added - no match attempted" - .. I RCDEP,'RECTDA S RCER(3)=" Deposit Ticket # created: "_$P($G(^RCY(344.1,+$P(RC0,U,3),0)),U) - .. S RCER($O(RCER(""),-1)+1)="This EFT deposit can't be sent to FMS. You must ask Austin to retransmit" - .. D BULL^RCDPEM1(344.3,RC0,.RCER) - .. S $P(^TMP($J,"RCDPETOT",344.3,RCZ),U,4)=+$G(^TMP($J,"RCXM",0)) - .. D STORERR^RCDPEM0(RCZ,.RCER) - .. S ^TMP($J,"RCTOT","ERR")=$G(^TMP($J,"RCTOT","ERR"))+1 - . ; - . S DIE="^RCY(344.31," S Z=0 F S Z=$O(^RCY(344.31,"B",RCZ,Z)) Q:'Z S DA=Z,DR=".11////1" D ^DIE - ; - D MATCH(0,1) - L -^RCY(344.3,"ALOCK") -ENQ K ^TMP($J,"RCDPETOT") - Q - ; -MATCH(RCMAN,RCPROC) ; Try to matched unmatched EFTs - ; RCMAN = 1 if job run manually, outside of nightly processing - ; RCPROC = 1 if called from EFT-EOB automatch, 0 if from manual match - ; - N RC0,RCER,RCZ,RCHAC - I '$O(^RCY(344.31,"AMATCH",0,0)) D G MATCHQ - . ; Send bulletin - no unmatched EFTs found - . N RCT - . S RCT=+$O(^TMP($J,"RCXM"," "),-1)+1 - . S ^TMP($J,"RCXM",RCT)=$S('$G(RCMAN):"The nightly job",1:"The manual option")_" to match EFTs has found no EFTs are currently unmatched on your system" - . I $G(RCMAN) S ^TMP($J,"RCXM",RCT+1)="The action was initiated by "_$P($G(^VA(200,DUZ,0)),U) - . D SENDBULL^RCDPEM1 - ; - S RCZ=0 F S RCZ=$O(^RCY(344.31,"AMATCH",0,RCZ)) Q:'RCZ D - . K RCER - . S RC0=$G(^RCY(344.31,RCZ,0)),RCHAC=($E($P($G(^RCY(344.3,+RC0,0)),U,6),1,3)="HAC") - . Q:RC0="" ; Bad xref - . Q:$S('RCHAC:'$P(RC0,U,11),1:0) ; EFT deposit must have been recorded - . S ^TMP($J,"RCTOT","EFT")=$G(^TMP($J,"RCTOT","EFT"))+1 - . I RCHAC S ^TMP($J,"RCTOT","EFT_HAC")=$G(^TMP($J,"RCTOT","EFT_HAC"))+1 - . S ^TMP($J,"RCDPETOT",344.31,RCZ)="" - . ; - . D MATCH^RCDPEM0(RCZ,RCPROC) - ; - I '$O(^TMP($J,"RCXM",0)) K RCER S RCER(1)="",RCER(2)="NO EXCEPTIONS WHILE MATCHING EFTs-ERAs OR IN RECORDING THE DEPOSITS TO FMS" D BULL^RCDPEM1("","",.RCER) K RCER - D EN2^RCDPEM1,BULL^RCDPEM1("","",.RCER) - D SENDBULL^RCDPEM1 - ; -MATCHQ K ^TMP($J,"RCDPETOT"),^TMP($J,"RCTOT") - Q - ; -LOCKDEP(RCDEP,LOCK) ; Lock/confirm deposit ien RCDEP file 341.1 - ; If LOCK = 1 lock deposit - ; If LOCK = 0 unlock deposit - I $G(LOCK) D - . L +^RCY(344.1,RCDEP,0) - . D CONFIRM^RCDPUDEP(RCDEP) ; confirm to prevent changes - I '$G(LOCK) L -^RCY(344.1,RCDEP,0) - Q - ; -RCPTDET(RCRZ,RECTDA1,RCER) ; Adds detail to a receipt based on file 344.49 - ; RCRZ = ien of ERA entry in file 344.49 - ; RECTDA1 = ien of receipt entry in file 344 - ; RCER = error array returned if passed by reference - ; - N RCR,RCSPL,RCZ0,RCTRANDA,RCQ,DR,DA,DIE,X,Y,Q,Z0,Z1,Z - ; - S RCR=0 F S RCR=$O(^RCY(344.49,RCRZ,1,RCR)) Q:'RCR D - . S RCZ0=$G(^RCY(344.49,RCRZ,1,RCR,0)) - . I $P(RCZ0,U)'["." S RCSPL(+RCZ0)=$P(RCZ0,U,9) Q - . I $S(+$P(RCZ0,U,3)=0:$P($G(^RCY(344.49,RCRZ,0)),U,3),1:$P(RCZ0,U,3)<0) S RCSPL(RCZ0\1,+RCZ0)=RCZ0 Q - . S RCTRANDA=$$ADDTRAN^RCDPURET(RECTDA1) - . ; - . I 'RCTRANDA D Q ; Error adding receipt detail - .. S RCER(1)=$$SETERR^RCDPEM0() S RCER($O(RCER(""),-1)+1)=" NO DETAIL LINE ADDED TO RECEIPT "_$P($G(^RCY(344,RECTDA1,0)),U)_" FOR LINE #"_$P(RCZ0,U)_" IN EEOB WORKLIST SCRATCH PAD" - . ; - . ;Store receipt line detail - . D DET(RCRZ,RCR,RECTDA1,RCTRANDA) - . S RCSPL(RCZ0\1,+RCZ0)=RCZ0 - S Z=0 F S Z=$O(RCSPL(Z)) Q:'Z S RCQ=+$G(RCSPL(Z)) I RCQ D - . S Z1=$O(RCSPL(Z,"")) Q:$O(RCSPL(Z,""),-1)=Z1 ; No split occurred - . S Z1=0 F S Z1=$O(RCSPL(Z,Z1)) Q:'Z1 S Z0=$G(RCSPL(Z,Z1)) D - .. S Q=+$P($G(^RCY(344.4,RCRZ,1,RCQ,0)),U,2) ; EOB detail rec - .. Q:'Q - .. I '$P(Z0,U,7)!($P(Z0,U,2)="") D ; Suspensed - ... D SPL1^IBCEOBAR(Q,$S($P(Z0,U,2)="":"NO BILL",1:$P(Z0,U,2)),"",$P(Z0,U,6)) ; IA 4050 - .. E D - ... D SPL1^IBCEOBAR(Q,$P(Z0,U,2),$P(Z0,U,7),$P(Z0,U,6)) ; Add the split bill # ; IA 4050 - ; - Q - ; -DET(RCZ,RCR,RECTDA1,RCTRANDA) ; Store receipt detail - ; RCZ = ien of entry file 344.49 - ; RCR = ien of entry in file 344.491 - ; RCPROC = Function calling this subroutine - ; = 1 EFT match to ERA = 0 manual add receipt - ; RECTDA1 = ien of entry in file 344 - ; RCTRANDA = ien of entry in subfile 344.01 - ; - N DIE,DA,DR,X,Y,Z,RCUP,RCCOM,RCZ0,RC0 - S RC0=$G(^RCY(344.49,RCZ,0)) - S RCZ0=$G(^RCY(344.49,RCZ,1,RCR,0)) - S DR="",RCUP=+$O(^RCY(344.49,RCZ,1,"B",+RCZ0/1,0)),RCUP=$G(^RCY(344.49,RCZ,1,RCUP,0)) - I $P(RCZ0,U,7) S DR=".09////^S X="_+$P(RCZ0,U,7)_"_$C(59)_""PRCA(430,"";" - S DR=DR_".04////"_(+$P(RCZ0,U,3))_";"_$S($P(RC0,U,4)'="":".13////"_$P(RC0,U,4)_";",1:"")_".27////"_RCR_";" - I $P(RC0,U,5)'="" S DR=DR_".1////"_$P(RC0,U,5)_";" - I $P(RC0,U,6)'="" S DR=DR_".08////"_$P(RC0,U,6)_";" - S RCCOM=$P(RCZ0,U,10) - S Z=0 F S Z=$O(^RCY(344.49,RCZ,1,RCR,1,Z)) Q:'Z I $P($G(^(Z,0)),U,5)=1 S DR=DR_".28////1;" Q ; Update receipt line with dec adj flag - I $P(RCUP,U,2)["**ADJ" S DR=DR_"1.02////"_$E($S(RCCOM'="":RCCOM_"/",1:"")_$S($P($P(RCUP,U,2),"ADJ",2):"ERA adjustment - no bill referenced",1:"Total of EFT mismatched to ERA"),1,60)_";" - I $P($G(^RCY(344.49,RCZ,0)),U,4)'="" S DR=DR_".07////"_$P($G(^RCY(344.49,RCZ,0)),U,4)_";" - S DA(1)=RECTDA1,DA=RCTRANDA,DIE="^RCY(344,"_DA(1)_",1," - D ^DIE - Q - ; +RCDPEM ;ALB/TMK - POST EFT, ERA MATCHING TO EFT ;05-NOV-02 + ;;4.5;Accounts Receivable;**173**;Mar 20, 1995 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; IA 4050 covers call to SPL1^IBCEOBAR + Q + ; Note - keep processing in line with RCDPXPAP +EN ; Post EFT deposits, auto-match EFT's and ERA's + ; + K ^TMP($J,"RCDPETOT") + ; ^TMP($J,"RCDPETOT",344.3 or 344.31,file ien)= + ; (1) match (0/1/-1) (2) total $ (3) posted (0/1) (4) error ref + ; (5) EFT deposit ien 344.1 if added for EFT + ; + N RCZ,RCSUM,RCDEP,RECTDA,RC0,RCER,RCDUZ,Z,Z0,Z1,DA,X,Y,DIE,DR + M RCDUZ=DUZ + N DUZ S DUZ=+$O(^VA(200,"B","EDILOCKBOX,AUTOMATIC",0)),DUZ(0)="" S:'DUZ DUZ=.5 + K ^TMP($J,"RCXM"),^TMP($J,"RCTOT") + S ZTREQ="@" + L +^RCY(344.3,"ALOCK"):5 I '$T D G ENQ ; Lock record + . ; Send bulletin that job could not be run + . S ^TMP($J,"RCXM",1)="The nightly job to post EFT deposits and match EFTs to ERAs could not be run",^TMP($J,"RCXM",2)="Another match process was already running (lock on ^RCY(344.3,""ALOCK"") )" + . D SENDBULL^RCDPEM1 + ; + ; Post deposits for any unposted EFTs in file 344.3 + ; 'Unposted' EFTs have a 0 in AMOUNT POSTED field + S ^TMP($J,"RCTOT","EFT_DEP")=0 + S RCZ=0 F S RCZ=$O(^RCY(344.3,"APOST",0,RCZ)) Q:'RCZ S RC0=$G(^RCY(344.3,RCZ,0)) I RC0'="",$E($P(RC0,U,6),1,3)="469",$P(RC0,U,8) D + . S ^TMP($J,"RCTOT","EFT_DEP")=^TMP($J,"RCTOT","EFT_DEP")+1 + . ; Verify check sums + . S RCSUM=$$CHKSUM^RCDPESR3(RCZ) + . I RCSUM'=$P(RC0,U,9) D Q + .. ; Bulletin that check sums do not match + .. ; Update record error list and checksum error field + .. S RCER(1)=$$SETERR^RCDPEM0(2) + .. S RCER(2)=" Checksum is invalid and the EFT deposit record is corrupted.",RCER(3)=" Stored Checksum = "_$P(RC0,U,9)_" Calculated Checksum: "_RCSUM,RCER(4)=" This EFT deposit cannot be sent to FMS. You must ask for it to be" + .. S RCER(5)=" retransmitted to your site." + .. D BULL^RCDPEM1(344.3,RC0,.RCER) + .. S $P(^TMP($J,"RCDPETOT",344.3,RCZ),U,4)=+$G(^TMP($J,"RCXM",0)) + .. D STORERR^RCDPEM0(RCZ,.RCER) + .. S DIE="^RCY(344.3,",DA=RCZ,DR=".1////1" D ^DIE + .. S ^TMP($J,"RCTOT","CSUM")=$G(^TMP($J,"RCTOT","CSUM"))+1 + . ; + . S RCDEP=+$P(RC0,U,3),RECTDA=+$O(^RCY(344,"AD",RCDEP,0)) + . I RCDEP D LOCKDEP(RCDEP,1) + . I 'RCDEP!'RECTDA D ; Add deposit and/or receipt to files 344.1, 344 + .. I 'RCDEP D ; Add dep record RCDEP, update field .03 with the pointer + ... S RCDEP=+$$ADDDEP^RCDPEM0($P(RC0,U,6),$P(RC0,U,7),RCZ) + ... S ^TMP($J,"RCTOT","DEPOSIT")=$G(^TMP($J,"RCTOT","DEPOSIT"))+1 + .. ; + .. I 'RECTDA,RCDEP D ; Add receipt record, post to rev source cd 8NZZ + ... S RECTDA=+$$ADDREC^RCDPEM0(RCDEP,RCZ) + .. ; + . I RCDEP D LOCKDEP(RCDEP,0) + . ; + . I 'RCDEP!'RECTDA D Q ; Could not add entry to file 344.1 or 344 + .. ; Send a bulletin, update error text + .. S RCER(1)=$$SETERR^RCDPEM0(2),RCER(2)=" "_$S('RCDEP:"Neither a deposit nor a receipt were able",1:"A receipt was not able")_" to be added - no match attempted" + .. I RCDEP,'RECTDA S RCER(3)=" Deposit Ticket # created: "_$P($G(^RCY(344.1,+$P(RC0,U,3),0)),U) + .. S RCER($O(RCER(""),-1)+1)="This EFT deposit can't be sent to FMS. You must ask Austin to retransmit" + .. D BULL^RCDPEM1(344.3,RC0,.RCER) + .. S $P(^TMP($J,"RCDPETOT",344.3,RCZ),U,4)=+$G(^TMP($J,"RCXM",0)) + .. D STORERR^RCDPEM0(RCZ,.RCER) + .. S ^TMP($J,"RCTOT","ERR")=$G(^TMP($J,"RCTOT","ERR"))+1 + . ; + . S DIE="^RCY(344.31," S Z=0 F S Z=$O(^RCY(344.31,"B",RCZ,Z)) Q:'Z S DA=Z,DR=".11////1" D ^DIE + ; + D MATCH(0,1) + L -^RCY(344.3,"ALOCK") +ENQ K ^TMP($J,"RCDPETOT") + Q + ; +MATCH(RCMAN,RCPROC) ; Try to matched unmatched EFTs + ; RCMAN = 1 if job run manually, outside of nightly processing + ; RCPROC = 1 if called from EFT-EOB automatch, 0 if from manual match + ; + N RC0,RCER,RCZ,RCHAC + I '$O(^RCY(344.31,"AMATCH",0,0)) D G MATCHQ + . ; Send bulletin - no unmatched EFTs found + . N RCT + . S RCT=+$O(^TMP($J,"RCXM"," "),-1)+1 + . S ^TMP($J,"RCXM",RCT)=$S('$G(RCMAN):"The nightly job",1:"The manual option")_" to match EFTs has found no EFTs are currently unmatched on your system" + . I $G(RCMAN) S ^TMP($J,"RCXM",RCT+1)="The action was initiated by "_$P($G(^VA(200,DUZ,0)),U) + . D SENDBULL^RCDPEM1 + ; + S RCZ=0 F S RCZ=$O(^RCY(344.31,"AMATCH",0,RCZ)) Q:'RCZ D + . K RCER + . S RC0=$G(^RCY(344.31,RCZ,0)),RCHAC=($E($P($G(^RCY(344.3,+RC0,0)),U,6),1,3)="HAC") + . Q:RC0="" ; Bad xref + . Q:$S('RCHAC:'$P(RC0,U,11),1:0) ; EFT deposit must have been recorded + . S ^TMP($J,"RCTOT","EFT")=$G(^TMP($J,"RCTOT","EFT"))+1 + . I RCHAC S ^TMP($J,"RCTOT","EFT_HAC")=$G(^TMP($J,"RCTOT","EFT_HAC"))+1 + . S ^TMP($J,"RCDPETOT",344.31,RCZ)="" + . ; + . D MATCH^RCDPEM0(RCZ,RCPROC) + ; + I '$O(^TMP($J,"RCXM",0)) K RCER S RCER(1)="",RCER(2)="NO EXCEPTIONS WHILE MATCHING EFTs-ERAs OR IN RECORDING THE DEPOSITS TO FMS" D BULL^RCDPEM1("","",.RCER) K RCER + D EN2^RCDPEM1,BULL^RCDPEM1("","",.RCER) + D SENDBULL^RCDPEM1 + ; +MATCHQ K ^TMP($J,"RCDPETOT"),^TMP($J,"RCTOT") + Q + ; +LOCKDEP(RCDEP,LOCK) ; Lock/confirm deposit ien RCDEP file 341.1 + ; If LOCK = 1 lock deposit + ; If LOCK = 0 unlock deposit + I $G(LOCK) D + . L +^RCY(344.1,RCDEP,0) + . D CONFIRM^RCDPUDEP(RCDEP) ; confirm to prevent changes + I '$G(LOCK) L -^RCY(344.1,RCDEP,0) + Q + ; +RCPTDET(RCRZ,RECTDA1,RCER) ; Adds detail to a receipt based on file 344.49 + ; RCRZ = ien of ERA entry in file 344.49 + ; RECTDA1 = ien of receipt entry in file 344 + ; RCER = error array returned if passed by reference + ; + N RCR,RCSPL,RCZ0,RCTRANDA,RCQ,DR,DA,DIE,X,Y,Q,Z0,Z1,Z + ; + S RCR=0 F S RCR=$O(^RCY(344.49,RCRZ,1,RCR)) Q:'RCR D + . S RCZ0=$G(^RCY(344.49,RCRZ,1,RCR,0)) + . I $P(RCZ0,U)'["." S RCSPL(+RCZ0)=$P(RCZ0,U,9) Q + . I $S(+$P(RCZ0,U,3)=0:$P($G(^RCY(344.49,RCRZ,0)),U,3),1:$P(RCZ0,U,3)<0) S RCSPL(RCZ0\1,+RCZ0)=RCZ0 Q + . S RCTRANDA=$$ADDTRAN^RCDPURET(RECTDA1) + . ; + . I 'RCTRANDA D Q ; Error adding receipt detail + .. S RCER(1)=$$SETERR^RCDPEM0() S RCER($O(RCER(""),-1)+1)=" NO DETAIL LINE ADDED TO RECEIPT "_$P($G(^RCY(344,RECTDA1,0)),U)_" FOR LINE #"_$P(RCZ0,U)_" IN EEOB WORKLIST SCRATCH PAD" + . ; + . ;Store receipt line detail + . D DET(RCRZ,RCR,RECTDA1,RCTRANDA) + . S RCSPL(RCZ0\1,+RCZ0)=RCZ0 + S Z=0 F S Z=$O(RCSPL(Z)) Q:'Z S RCQ=+$G(RCSPL(Z)) I RCQ D + . S Z1=$O(RCSPL(Z,"")) Q:$O(RCSPL(Z,""),-1)=Z1 ; No split occurred + . S Z1=0 F S Z1=$O(RCSPL(Z,Z1)) Q:'Z1 S Z0=$G(RCSPL(Z,Z1)) D + .. S Q=+$P($G(^RCY(344.4,RCRZ,1,RCQ,0)),U,2) ; EOB detail rec + .. Q:'Q + .. I '$P(Z0,U,7)!($P(Z0,U,2)="") D ; Suspensed + ... D SPL1^IBCEOBAR(Q,$S($P(Z0,U,2)="":"NO BILL",1:$P(Z0,U,2)),"",$P(Z0,U,6)) ; IA 4050 + .. E D + ... D SPL1^IBCEOBAR(Q,$P(Z0,U,2),$P(Z0,U,7),$P(Z0,U,6)) ; Add the split bill # ; IA 4050 + ; + Q + ; +DET(RCZ,RCR,RECTDA1,RCTRANDA) ; Store receipt detail + ; RCZ = ien of entry file 344.49 + ; RCR = ien of entry in file 344.491 + ; RCPROC = Function calling this subroutine + ; = 1 EFT match to ERA = 0 manual add receipt + ; RECTDA1 = ien of entry in file 344 + ; RCTRANDA = ien of entry in subfile 344.01 + ; + N DIE,DA,DR,X,Y,Z,RCUP,RCCOM,RCZ0,RC0 + S RC0=$G(^RCY(344.49,RCZ,0)) + S RCZ0=$G(^RCY(344.49,RCZ,1,RCR,0)) + S DR="",RCUP=+$O(^RCY(344.49,RCZ,1,"B",+RCZ0/1,0)),RCUP=$G(^RCY(344.49,RCZ,1,RCUP,0)) + I $P(RCZ0,U,7) S DR=".09////^S X="_+$P(RCZ0,U,7)_"_$C(59)_""PRCA(430,"";" + S DR=DR_".04////"_(+$P(RCZ0,U,3))_";"_$S($P(RC0,U,4)'="":".13////"_$P(RC0,U,4)_";",1:"")_".27////"_RCR_";" + I $P(RC0,U,5)'="" S DR=DR_".1////"_$P(RC0,U,5)_";" + I $P(RC0,U,6)'="" S DR=DR_".08////"_$P(RC0,U,6)_";" + S RCCOM=$P(RCZ0,U,10) + S Z=0 F S Z=$O(^RCY(344.49,RCZ,1,RCR,1,Z)) Q:'Z I $P($G(^(Z,0)),U,5)=1 S DR=DR_".28////1;" Q ; Update receipt line with dec adj flag + I $P(RCUP,U,2)["**ADJ" S DR=DR_"1.02////"_$E($S(RCCOM'="":RCCOM_"/",1:"")_$S($P($P(RCUP,U,2),"ADJ",2):"ERA adjustment - no bill referenced",1:"Total of EFT mismatched to ERA"),1,60)_";" + I $P($G(^RCY(344.49,RCZ,0)),U,4)'="" S DR=DR_".07////"_$P($G(^RCY(344.49,RCZ,0)),U,4)_";" + S DA(1)=RECTDA1,DA=RCTRANDA,DIE="^RCY(344,"_DA(1)_",1," + D ^DIE + Q + ; diff --git a/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPESR2.m b/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPESR2.m index 2e2ee964..0ef819e0 100644 --- a/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPESR2.m +++ b/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPESR2.m @@ -1,178 +1,176 @@ -RCDPESR2 ;ALB/TMK - Server auto-upd - EDI Lockbox ;06/03/02 - ;;4.5;Accounts Receivable;**173,216,208,230,252**;Mar 20, 1995;Build 63 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; IA 4042 (IBCEOB) - ; -TASKERA(RCTDA) ; Task to upd ERA - ; RCTDA = ien 344.5 - N ZTDTH,ZTUCI,ZTSAVE,ZTIO,ZTDESC,ZTRTN,ZTSK,DIE,DR,DA - S (ZTSAVE("DT"),ZTSAVE("U"),ZTSAVE("DUZ"))="",ZTSAVE("ZTREQ")="@",ZTRTN="NEWERA^RCDPESR2("_RCTDA_",0)",ZTDTH=$H,ZTIO="" - D ^%ZTLOAD - Q - ; -NEWERA(RCTDA,RCREFILE) ;Tasked - ; Add new EOB's to IB & ERA tot rec to AR - ; RCTDA = ien 344.5 - ; RCREFILE = 1: re-filing rec via exc proc - N RCDUPERR,RCPAYER,RCRTOT,RCE,RCEC,RCERR,RCR1,RCADJ,DIE,DR,DA,Z,Q - S ZTREQ="@" - K ^TMP($J,"RCDPERA") - L +^RCY(344.5,RCTDA):5 - I $D(ZTQUEUED) S DIE="^RCY(344.5,",DA=RCTDA,DR=".05////"_ZTSK_";.04////1" D ^DIE - I $P($G(^RCY(344.5,RCTDA,0)),U,5),'$G(RCREFILE) S DIE="^RCY(344.5,",DA=RCTDA,DR=".1////4;.08///1" D ^DIE - S RCR1=$P($G(^RCY(344.5,RCTDA,0)),U,7),RCPAYER=$P($G(^RCY(344.5,RCTDA,3)),U) - S RCRTOT=$S(RCR1:RCR1,1:$$ERATOT^RCDPESR6(RCTDA,.RCERR)) ; ERA rec - S RCDUPERR=$S($G(RCERR)="DUP"!($G(RCERR(1))=-2):$G(RCERR(1)),1:0) K RCERR(1) - I RCRTOT,'RCR1 S DIE="^RCY(344.5,",DR=".07////"_RCRTOT,DA=RCTDA D ^DIE - D:RCDUPERR'=-2 UPDEOB(RCTDA,5,$S('$G(RCREFILE):RCDUPERR,1:-1)) ; Add EOB det to IB - I RCRTOT D UPDCON^RCDPESR6(RCRTOT),UPDADJ^RCDPESR6(RCRTOT),UPD3444^RCDPESR6(.RCRTOT) ; Bills added 344.41 - I RCRTOT,RCTDA S DIE="^RCY(344.5,",DR=".08////0;.1///@",DA=RCTDA D ^DIE - I 'RCRTOT D G QNEW - .I RCDUPERR Q:'RCTDA D S RCTDA="" Q - ..I RCDUPERR=-2 D BULLERA^RCDPESR0("D",RCTDA,$P($G(^RCY(344.5,RCTDA,0)),U,11),"EDI LBOX - DUPLICATE ERA NOT FILED "_$E(RCPAYER,1,20),.RCERR,0) - ..D TEMPDEL^RCDPESR1(RCTDA) - .S RCE(1)=$$FMTE^XLFDT($$NOW^XLFDT(),2)_" An error occurred while storing ERA data.",RCE(2)="No totals data was stored for this ERA record"_$S('$G(RCREFILE):" and an",1:" on this re-file attempt.") - .S RCE(3)=$S('$G(RCREFILE):"ERA transmission exception was created.",1:"") - .D WP^DIE(344.5,RCTDA_",",5,"A","RCE") - .S DIE="^RCY(344.5,",DA=RCTDA,DR=".07///@;.08////1;.1////1" D ^DIE - .K RCERR - .S RCERR(1)=$$FMTE^XLFDT($$NOW^XLFDT(),2)_" The ERA data could not be stored. The AR receipt",RCERR(2)=" for this data must be created/processed manually for the bills included" - .S RCERR(3)=" in this ERA."_$S('$G(RCREFILE):"",1:" This error occurred during a refile attempt."),RCERR(4)=" " - .D BULLERA^RCDPESR0("DF",RCTDA,$P($G(^RCY(344.5,RCTDA,0)),U,11),"EDI LBOX - TOTALS FILE EXCEPTION "_$E(RCPAYER,1,20),.RCERR,0) - .K RCERR - I $$ADJ^RCDPEU(RCRTOT,.RCADJ) D ;Bulletin adjs - .S RCEC=$$ADJERR^RCDPESR3(.RCERR) - .I RCADJ'=2 S RCEC=RCEC+1,RCERR(RCEC)=" THERE ARE ERA LEVEL ADJUSTMENT(S)",RCEC=RCEC+1,RCERR(RCEC)=" " - .I RCADJ'=1 S RCEC=RCEC+1,RCERR(RCEC)=" THE FOLLOWING BILL(S) HAVE RETRACTIONS:" D - ..S (Q,Z)=0 S Z=0 F S Z=$O(RCADJ(RCRTOT,Z)) Q:'Z S:'Q RCEC=RCEC+1,RCERR(RCEC)=" " S Q=Q+1,RCERR(RCEC)=RCERR(RCEC)_" "_RCADJ(RCRTOT,Z) S:Q=4 Q=0 - ..S RCEC=RCEC+1,RCERR(RCEC)=" " - .D BULLERA^RCDPESR0("D",RCTDA,$P($G(^RCY(344.5,RCTDA,0)),U,11),"EDI LBOX - ERA HAS ADJ/TAKEBACKS "_$E(RCPAYER,1,20),.RCERR,0) - ; -QNEW I RCTDA,'$P($G(^RCY(344.5,RCTDA,0)),U,8) D TEMPDEL^RCDPESR1(RCTDA) S RCTDA="" - I RCTDA,$P($G(^RCY(344.5,RCTDA,0)),U)'="" S DIE="^RCY(344.5,",DR=".04////0;.05///@"_$S('$G(RCR1)&$G(RCRTOT):";.07////"_RCRTOT,1:""),DA=RCTDA D ^DIE - K ^TMP($J,"RCDPERA") - I RCTDA L -^RCY(344.5,RCTDA) - Q - ; -UPDEOB(RCTDA,RCFILE,DUP) ;Upd 361.1 from ERA msg in 344.5 or .4 - ;RCTDA = ien ERA msg in 344.5 or ;subfile in 344.4 - ;RCFILE = 4 file 344.4, 5 if 344.5 - ;DUP = msg # if dup msg, but not same # or -1 if same msg # - ;Returned for each bill in ERA: - ;^TMP($J,"RCDPEOB",n)=Bill ien^AR bill#^SrvDt - ;^TMP($J,"RCDPEOB",n,"EOB")=EOB ien^amt pd^ins co ptr^rev flg^EEOB pn^amtbld^^^^BPNPI^RNPI^ETQual^LN^FN - ;^TMP($J,"RCDPEOB","ADJ",x)=adj rec ('02') - ;Also: - ;^TMP($J,"RCDPEOB","HDR")=hdr rec from txmn - ;^TMP($J,"RCDPEOB","CONTACT")=ERA contact rec ('01') - ; - N RCGBL,RC,RC0,RCCT,RCCT1,RCEOB,RCBILL,RCDPBNPI,RCMNUM,RCIFN,RCIB,RCERR,RCSTAR,RCET,RCX,RCXMG,Z,Q,DA,DR,DIE,RCPAYER,RCFILED,RCEOBD,RCNOUPD,REFORM,RCSD,RCERR1,C5 - K ^TMP($J,"RCDP-EOB"),^TMP("RCDPERR-EOB",$J) - ; - S RCPAYER="",RCFILED=1,RCNOUPD=0 - I RCFILE=5 D - .S RCGBL=$NA(^RCY(344.5,RCTDA,2)) - .S RCMNUM=+$G(^RCY(344.5,RCTDA,0)),RCXMG=$P($G(^(0)),U,11) - .I $G(DUP) S RCNOUPD=$S(DUP>0:+DUP,1:RCXMG) - .S ^TMP($J,"RCDPEOB","HDR")=$G(^RCY(344.5,RCTDA,2,1,0)) - .I $P(^TMP($J,"RCDPEOB","HDR"),U)["XFR",'$P($G(^RCY(344.5,RCTDA,0)),U,14) D - ..D SENDACK^RCDPESR5(RCTDA,1) - ..S DR=".14////1",DIE="^RCY(344.5,",DA=RCTDA D ^DIE - ; - I RCFILE=4 D - .S RCGBL=$NA(^RCY(344.4,+RCTDA,1,+$P(RCTDA,";",2),1)) - .S RCMNUM=$P($G(^RCY(344.4,+RCTDA,0)),U,12),RCXMG=$P($G(^(0)),U,12) - .S ^TMP($J,"RCDPEOB","HDR")=$G(^RCY(344.4,+RCTDA,1,+$P(RCTDA,";",2),1,1,0)) - ; - S RCPAYER=$P($G(^TMP($J,"RCDPEOB","HDR")),U,6) - S RCDPBNPI=$P($G(^TMP($J,"RCDPEOB","HDR")),U,18) - ; - ;srv dates - S RCSD=$NA(^TMP($J,"RCSRVDT")) K @RCSD - S RC=1,C5=0 - F S RC=$O(@RCGBL@(RC)) Q:'RC S RC0=$G(^(RC,0)) D - .I RC0<5 Q - .I +RC0=5 S C5=RC Q - .I +RC0=40,$P(RC0,U,2)?1.7N,C5,'$D(@RCSD@(C5)) S @RCSD@(C5)=$P(RC0,U,19) ;serv date - ; - S RC=1,(RCCT,RCCT1,RCX,REFORM)=0,RCBILL="" - S RCERR1=$NA(^TMP("RCERR1",$J)) K @RCERR1 - F S RC=$O(@RCGBL@(RC)) Q:'RC S RC0=$G(^(RC,0)) D - .I RCFILE=5,+RC0=1 D Q - ..S ^TMP($J,"RCDPEOB","CONTACT")=RC0 - .; - .I RCFILE=5,+RC0=2 D Q - ..S RCX=RCX+1,^TMP($J,"RCDPEOB","ADJ",RCX)=RC0 - .; - .I +RC0=5 S RCCT=RCCT+1,RCCT1=0 D - ..S REFORM=0 - ..S Z=$$BILL^RCDPESR1($P(RC0,U,2),$G(@RCSD@(RC)),.RCIB) - ..I Z S RCBILL=$P($G(^PRCA(430,Z,0)),U) I RCBILL'="",RCBILL'=$P(RC0,U,2) S REFORM=1,$P(RC0,U,2)=RCBILL - ..S RCBILL=$P(RC0,U,2) - ..S Z=$S(Z>0:$S($G(RCIB):Z,1:-1),1:-1) - ..S ^TMP($J,"RCDP-EOB",RCCT,0)=Z_U_RCBILL_U_$G(@RCSD@(RC)) - ..S $P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U,5)=$P(RC0,U,3)_","_$P(RC0,U,4)_" "_$P(RC0,U,5) ;Save pt nm - ..I Z>0 S Q=+$P($G(^PRCA(430,Z,0)),U,9) I $P($G(^RCD(340,Q,0)),U)["DIC(36," S $P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U,3)=+^RCD(340,Q,0) ;Save ins co - .; - .I +RC0>5,REFORM S $P(RC0,U,2)=RCBILL ; - .I +RC0=10 D ;Save amt pd/billed, rev flg - ..S $P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U,2)=$S(+$P(RC0,U,11):$J($P(RC0,U,11)/100,"",2),1:0),$P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U,6)=$J($P(RC0,U,11),"",2) - ..I $P(RC0,U,6)="Y"!($P(RC0,U,7)=22) S $P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U,4)=1 - ..S $P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U,10,14)=RCDPBNPI_U_$P(RC0,U,16,19) - .I RCBILL=$P(RC0,U,2) S RCCT1=RCCT1+1,^TMP($J,"RCDP-EOB",RCCT,RCCT1,0)=RC0 - ; - S RCSTAR=$TR($J("",15)," ","*"),RCET=RCSTAR_"ERROR/WARNING EEOB DETAIL SEQ #" - S RCCT=0 F S RCCT=$O(^TMP($J,"RCDP-EOB",RCCT)) Q:'RCCT S RCIFN=+$G(^(RCCT,0)),RCBILL=$P($G(^(0)),U,2),^TMP($J,"RCDPEOB",RCCT)=$G(^TMP($J,"RCDP-EOB",RCCT,0)) D - .S RCEOB=-1,RCEOBD="" - .I $S(RCIFN>0:$P(^PRCA(430.3,+$P($G(^PRCA(430,+RCIFN,0)),U,8),0),U,3)'=102,RCIFN'>0&($G(DUP)'>0):1,1:0) D - ..S @RCERR1@(RCCT)=" ",@RCERR1@(RCCT,1)=RCET_RCCT_RCSTAR - ..S @RCERR1@(RCCT,2)="Bill "_RCBILL_" is"_$S(RCIFN>0:" not in an ACTIVE status in your A/R",1:"n't valid/wasn't found so its detail wasn't stored in IB") - ..S:RCFILE=5 @RCERR1@(RCCT,"*")=@RCERR1@(RCCT,2) - ..S @RCERR1@(RCCT,3)=" The reported amount paid on this bill was: "_$P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U,2) - ..I RCIFN'>0 D - ...S @RCERR1@(RCCT,4)=" If the bill is not for your site, it must be transferred to the" - ...S @RCERR1@(RCCT,5)=" correct site and manually adjusted in your AR." - ...S @RCERR1@(RCCT,6)=" You can perform this transfer using EDI Lockbox ERA/EEOB exception process." - ...S @RCERR1@(RCCT,7)=" " - ..D DISP1^RCDPESR5(RCCT,1) - ..S Q=0 F S Q=$O(^TMP($J,"RCDP-EOB",RCCT,Q)) Q:'Q S ^TMP($J,"RCDPEOB",RCCT,Q)=$G(^TMP($J,"RCDP-EOB",RCCT,Q,0)) - ..S ^TMP($J,"RCDPEOB",RCCT)=^TMP($J,"RCDP-EOB",RCCT,0) M ^TMP($J,"RCDPEOB",RCCT,"ERR")=@RCERR1@(RCCT) - ..I RCFILE=5 D ;Store err if trans-in failed - ...N RCE,RC,DIE,X,Y,DA,DR - ...S RCE(1)=$$FMTE^XLFDT($$NOW^XLFDT(),2)_" "_$G(@RCERR1@(RCCT,"*")) - ...S RCE(2)=" ",RCFILED=0 - ...D WP^DIE(344.5,RCTDA_",",5,"A","RCE") - .I RCIFN>0 D - ..N RCDUPEOB,RCALLDUP - ..;Chk rec exists - ..S RCDUPEOB=0 - ..S RCEOB=$$DUP^RCDPESR3(RCMNUM,RCIFN,$P($G(^TMP($J,"RCDPEOB",RCCT,"EOB")),U,2),$P($G(^TMP($J,"RCDPEOB",RCCT,"EOB")),U,6)) ;Same msg for update? - ..I RCEOB,$P(RCEOB,U,2) S RCEOB=0 ;If chksum exists, let below check it - ..S ^TMP($J,"RCDP-EOB",RCCT,.5,0)="835ERA" ;Needed - checksum - ..S RCALLDUP=$$DUP^IBCEOB("^TMP("_$J_",""RCDP-EOB"","_RCCT_")",RCIFN) - ..I $S(RCALLDUP:1,RCEOB:$G(DUP)'>0,1:0) D - ...S RCDUPEOB=1 - ...D DUPREC^RCDPESR6(RCET,RCCT,RCSTAR,RCFILE,RCALLDUP,RCEOB,RCBILL,.RCDUPEOB) - ...S:RCALLDUP RCEOBD=RCALLDUP - ..;Add stub to 361.1 - ..I 'RCDUPEOB S RCEOB=+$$ADD3611^IBCEOB(RCMNUM,"","",RCIFN,1,"^TMP("_$J_",""RCDP-EOB"","_RCCT_")") ;IA 4042 - ..K ^TMP($J,"RCDP-EOB",RCCT,.5,0) - ..I RCEOB<0 D:$G(DUP)'>0 Q - ...S @RCERR1@(RCCT)=" ",^(RCCT,1)=RCET_RCCT_RCSTAR,RCFILED=0 - ...S @RCERR1@(RCCT,2)="Error - EEOB detail not added to IB for bill "_RCBILL,$P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U)="" - ...S:RCFILE=5 @RCERR1@(RCCT,"*")=@RCERR1@(RCCT,2) - ...D DISP1^RCDPESR5(RCCT,1) - ...S Q=0 F S Q=$O(^TMP($J,"RCDP-EOB",RCCT,Q)) Q:'Q S ^TMP($J,"RCDPEOB",RCCT,Q)=$G(^TMP($J,"RCDP-EOB",RCCT,Q,0)) - ...S ^TMP($J,"RCDPEOB",RCCT)=^TMP($J,"RCDP-EOB",RCCT,0) M ^TMP($J,"RCDPEOB",RCCT,"ERR")=@RCERR1@(RCCT) - ..;Upd 361.1, needs ^TMP($J,"RCDPEOB","HDR" and $J,"RCDP-EOB" - ..I RCDUPEOB'<0 S RCNOUPD=0 D UPD3611^IBCEOB(RCEOB,RCCT,1) - ..;errors in ^TMP("RCDPERR-EOB",$J - ..I $O(^TMP("RCDPERR-EOB",$J,0)) D ERRUPD^IBCEOB(RCEOB,"RCDPERR-EOB") - ..S $P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U)=$S('$G(RCEOBD):RCEOB,1:RCEOBD) - .K ^TMP("RCDPERR-EOB",$J) - ; - I RCNOUPD D DUPERA^RCDPESR3($G(DUP),RCNOUPD) - I $O(@RCERR1@("")) D BULLS^RCDPESR3(RCFILE,RCTDA,$S(RCNOUPD:RCNOUPD,1:$G(DUP)),$G(RCXMG)) - K ^TMP("RCDPERR-EOB",$J),^TMP($J,"RCDP-EOB"),@RCERR1,@RCSD - D CLEAN^DILF - Q +RCDPESR2 ;ALB/TMK - Server auto-upd - EDI Lockbox ;06/03/02 + ;;4.5;Accounts Receivable;**173,216,208,230**;Mar 20, 1995 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; IA 4042 (IBCEOB) + ; +TASKERA(RCTDA) ; Task to upd ERA + ; RCTDA = ien 344.5 + N ZTDTH,ZTUCI,ZTSAVE,ZTIO,ZTDESC,ZTRTN,ZTSK,DIE,DR,DA + S (ZTSAVE("DT"),ZTSAVE("U"),ZTSAVE("DUZ"))="",ZTSAVE("ZTREQ")="@",ZTRTN="NEWERA^RCDPESR2("_RCTDA_",0)",ZTDTH=$H,ZTIO="" + D ^%ZTLOAD + Q + ; +NEWERA(RCTDA,RCREFILE) ;Tasked + ; Add new EOB's to IB & ERA tot rec to AR + ; RCTDA = ien 344.5 + ; RCREFILE = 1: re-filing rec via exc proc + N RCDUPERR,RCPAYER,RCRTOT,RCE,RCEC,RCERR,RCR1,RCADJ,DIE,DR,DA,Z,Q + S ZTREQ="@" + K ^TMP($J,"RCDPERA") + L +^RCY(344.5,RCTDA):5 + I $D(ZTQUEUED) S DIE="^RCY(344.5,",DA=RCTDA,DR=".05////"_ZTSK_";.04////1" D ^DIE + I $P($G(^RCY(344.5,RCTDA,0)),U,5),'$G(RCREFILE) S DIE="^RCY(344.5,",DA=RCTDA,DR=".1////4;.08///1" D ^DIE + S RCR1=$P($G(^RCY(344.5,RCTDA,0)),U,7),RCPAYER=$P($G(^RCY(344.5,RCTDA,3)),U) + S RCRTOT=$S(RCR1:RCR1,1:$$ERATOT^RCDPESR6(RCTDA,.RCERR)) ; ERA rec + S RCDUPERR=$S($G(RCERR)="DUP"!($G(RCERR(1))=-2):$G(RCERR(1)),1:0) K RCERR(1) + I RCRTOT,'RCR1 S DIE="^RCY(344.5,",DR=".07////"_RCRTOT,DA=RCTDA D ^DIE + D:RCDUPERR'=-2 UPDEOB(RCTDA,5,$S('$G(RCREFILE):RCDUPERR,1:-1)) ; Add EOB det to IB + I RCRTOT D UPDCON^RCDPESR6(RCRTOT),UPDADJ^RCDPESR6(RCRTOT),UPD3444^RCDPESR6(.RCRTOT) ; Bills added 344.41 + I RCRTOT,RCTDA S DIE="^RCY(344.5,",DR=".08////0;.1///@",DA=RCTDA D ^DIE + I 'RCRTOT D G QNEW + .I RCDUPERR Q:'RCTDA D S RCTDA="" Q + ..I RCDUPERR=-2 D BULLERA^RCDPESR0("D",RCTDA,$P($G(^RCY(344.5,RCTDA,0)),U,11),"EDI LBOX - DUPLICATE ERA NOT FILED "_$E(RCPAYER,1,20),.RCERR,0) + ..D TEMPDEL^RCDPESR1(RCTDA) + .S RCE(1)=$$FMTE^XLFDT($$NOW^XLFDT(),2)_" An error occurred while storing ERA data.",RCE(2)="No totals data was stored for this ERA record"_$S('$G(RCREFILE):" and an",1:" on this re-file attempt.") + .S RCE(3)=$S('$G(RCREFILE):"ERA transmission exception was created.",1:"") + .D WP^DIE(344.5,RCTDA_",",5,"A","RCE") + .S DIE="^RCY(344.5,",DA=RCTDA,DR=".07///@;.08////1;.1////1" D ^DIE + .K RCERR + .S RCERR(1)=$$FMTE^XLFDT($$NOW^XLFDT(),2)_" The ERA data could not be stored. The AR receipt",RCERR(2)=" for this data must be created/processed manually for the bills included" + .S RCERR(3)=" in this ERA."_$S('$G(RCREFILE):"",1:" This error occurred during a refile attempt."),RCERR(4)=" " + .D BULLERA^RCDPESR0("DF",RCTDA,$P($G(^RCY(344.5,RCTDA,0)),U,11),"EDI LBOX - TOTALS FILE EXCEPTION "_$E(RCPAYER,1,20),.RCERR,0) + .K RCERR + I $$ADJ^RCDPEU(RCRTOT,.RCADJ) D ;Bulletin adjs + .S RCEC=$$ADJERR^RCDPESR3(.RCERR) + .I RCADJ'=2 S RCEC=RCEC+1,RCERR(RCEC)=" THERE ARE ERA LEVEL ADJUSTMENT(S)",RCEC=RCEC+1,RCERR(RCEC)=" " + .I RCADJ'=1 S RCEC=RCEC+1,RCERR(RCEC)=" THE FOLLOWING BILL(S) HAVE RETRACTIONS:" D + ..S (Q,Z)=0 S Z=0 F S Z=$O(RCADJ(RCRTOT,Z)) Q:'Z S:'Q RCEC=RCEC+1,RCERR(RCEC)=" " S Q=Q+1,RCERR(RCEC)=RCERR(RCEC)_" "_RCADJ(RCRTOT,Z) S:Q=4 Q=0 + ..S RCEC=RCEC+1,RCERR(RCEC)=" " + .D BULLERA^RCDPESR0("D",RCTDA,$P($G(^RCY(344.5,RCTDA,0)),U,11),"EDI LBOX - ERA HAS ADJ/TAKEBACKS "_$E(RCPAYER,1,20),.RCERR,0) + ; +QNEW I RCTDA,'$P($G(^RCY(344.5,RCTDA,0)),U,8) D TEMPDEL^RCDPESR1(RCTDA) S RCTDA="" + I RCTDA,$P($G(^RCY(344.5,RCTDA,0)),U)'="" S DIE="^RCY(344.5,",DR=".04////0;.05///@"_$S('$G(RCR1)&$G(RCRTOT):";.07////"_RCRTOT,1:""),DA=RCTDA D ^DIE + K ^TMP($J,"RCDPERA") + I RCTDA L -^RCY(344.5,RCTDA) + Q + ; +UPDEOB(RCTDA,RCFILE,DUP) ;Upd 361.1 from ERA msg in 344.5 or .4 + ; RCTDA = ien ERA msg in 344.5 or ;subfile in 344.4 + ; RCFILE = 4 file 344.4, 5 if 344.5 + ; DUP = msg # if dup msg, but not same # or -1 if same msg # + ;Returned for each bill in ERA: + ; ^TMP($J,"RCDPEOB",n)=Bill ien^AR bill#^Service Date + ; ^TMP($J,"RCDPEOB",n,"EOB")=EOB ien^amt pd^ins co ptr^reversal flag^pt name on EEOB^amt billed + ; ^TMP($J,"RCDPEOB","ADJ",x)=adj rec ('02') + ;Also: + ; ^TMP($J,"RCDPEOB","HDR")=hdr rec from txmn + ; ^TMP($J,"RCDPEOB","CONTACT")=ERA contact rec ('01') + ; + N RCGBL,RC,RC0,RCCT,RCCT1,RCEOB,RCBILL,RCMNUM,RCIFN,RCIB,RCERR,RCSTAR,RCET,RCX,RCXMG,Z,Q,DA,DR,DIE,RCPAYER,RCFILED,RCEOBD,RCNOUPD,REFORM,RCSD,RCERR1,C5 + K ^TMP($J,"RCDP-EOB"),^TMP("RCDPERR-EOB",$J) + ; + S RCPAYER="",RCFILED=1,RCNOUPD=0 + I RCFILE=5 D + .S RCGBL=$NA(^RCY(344.5,RCTDA,2)) + .S RCMNUM=+$G(^RCY(344.5,RCTDA,0)),RCXMG=$P($G(^(0)),U,11) + .I $G(DUP) S RCNOUPD=$S(DUP>0:+DUP,1:RCXMG) + .S ^TMP($J,"RCDPEOB","HDR")=$G(^RCY(344.5,RCTDA,2,1,0)) + .I $P(^TMP($J,"RCDPEOB","HDR"),U)["XFR",'$P($G(^RCY(344.5,RCTDA,0)),U,14) D + ..D SENDACK^RCDPESR5(RCTDA,1) + ..S DR=".14////1",DIE="^RCY(344.5,",DA=RCTDA D ^DIE + ; + I RCFILE=4 D + .S RCGBL=$NA(^RCY(344.4,+RCTDA,1,+$P(RCTDA,";",2),1)) + .S RCMNUM=$P($G(^RCY(344.4,+RCTDA,0)),U,12),RCXMG=$P($G(^(0)),U,12) + .S ^TMP($J,"RCDPEOB","HDR")=$G(^RCY(344.4,+RCTDA,1,+$P(RCTDA,";",2),1,1,0)) + ; + S RCPAYER=$P($G(^TMP($J,"RCDPEOB","HDR")),U,6) + ; + ;srv dates + S RCSD=$NA(^TMP($J,"RCSRVDT")) K @RCSD + S RC=1,C5=0 + F S RC=$O(@RCGBL@(RC)) Q:'RC S RC0=$G(^(RC,0)) D + .I RC0<5 Q + .I +RC0=5 S C5=RC Q + .I +RC0=40,$P(RC0,U,2)?1.7N,C5,'$D(@RCSD@(C5)) S @RCSD@(C5)=$P(RC0,U,19) ;serv date + ; + S RC=1,(RCCT,RCCT1,RCX,REFORM)=0,RCBILL="" + S RCERR1=$NA(^TMP("RCERR1",$J)) K @RCERR1 + F S RC=$O(@RCGBL@(RC)) Q:'RC S RC0=$G(^(RC,0)) D + .I RCFILE=5,+RC0=1 D Q + ..S ^TMP($J,"RCDPEOB","CONTACT")=RC0 + .; + .I RCFILE=5,+RC0=2 D Q + ..S RCX=RCX+1,^TMP($J,"RCDPEOB","ADJ",RCX)=RC0 + .; + .I +RC0=5 S RCCT=RCCT+1,RCCT1=0 D + ..S REFORM=0 + ..S Z=$$BILL^RCDPESR1($P(RC0,U,2),$G(@RCSD@(RC)),.RCIB) + ..I Z S RCBILL=$P($G(^PRCA(430,Z,0)),U) I RCBILL'="",RCBILL'=$P(RC0,U,2) S REFORM=1,$P(RC0,U,2)=RCBILL + ..S RCBILL=$P(RC0,U,2) + ..S Z=$S(Z>0:$S($G(RCIB):Z,1:-1),1:-1) + ..S ^TMP($J,"RCDP-EOB",RCCT,0)=Z_U_RCBILL_U_$G(@RCSD@(RC)) + ..S $P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U,5)=$P(RC0,U,3)_","_$P(RC0,U,4)_" "_$P(RC0,U,5) ;Save pt nm + ..I Z>0 S Q=+$P($G(^PRCA(430,Z,0)),U,9) I $P($G(^RCD(340,Q,0)),U)["DIC(36," S $P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U,3)=+^RCD(340,Q,0) ;Save ins co + .; + .I +RC0>5,REFORM S $P(RC0,U,2)=RCBILL ; + .I +RC0=10 D ;Save amt pd/billed, rev flg + ..S $P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U,2)=$S(+$P(RC0,U,11):$J($P(RC0,U,11)/100,"",2),1:0),$P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U,6)=$J($P(RC0,U,11),"",2) + ..I $P(RC0,U,6)="Y"!($P(RC0,U,7)=22) S $P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U,4)=1 + .I RCBILL=$P(RC0,U,2) S RCCT1=RCCT1+1,^TMP($J,"RCDP-EOB",RCCT,RCCT1,0)=RC0 + ; + S RCSTAR=$TR($J("",15)," ","*"),RCET=RCSTAR_"ERROR/WARNING EEOB DETAIL SEQ #" + S RCCT=0 F S RCCT=$O(^TMP($J,"RCDP-EOB",RCCT)) Q:'RCCT S RCIFN=+$G(^(RCCT,0)),RCBILL=$P($G(^(0)),U,2),^TMP($J,"RCDPEOB",RCCT)=$G(^TMP($J,"RCDP-EOB",RCCT,0)) D + .S RCEOB=-1,RCEOBD="" + .I $S(RCIFN>0:$P(^PRCA(430.3,+$P($G(^PRCA(430,+RCIFN,0)),U,8),0),U,3)'=102,RCIFN'>0&($G(DUP)'>0):1,1:0) D + ..S @RCERR1@(RCCT)=" ",@RCERR1@(RCCT,1)=RCET_RCCT_RCSTAR + ..S @RCERR1@(RCCT,2)="Bill "_RCBILL_" is"_$S(RCIFN>0:" not in an ACTIVE status in your A/R",1:"n't valid/wasn't found so its detail wasn't stored in IB") + ..S:RCFILE=5 @RCERR1@(RCCT,"*")=@RCERR1@(RCCT,2) + ..S @RCERR1@(RCCT,3)=" The reported amount paid on this bill was: "_$P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U,2) + ..I RCIFN'>0 D + ...S @RCERR1@(RCCT,4)=" If the bill is not for your site, it must be transferred to the" + ...S @RCERR1@(RCCT,5)=" correct site and manually adjusted in your AR." + ...S @RCERR1@(RCCT,6)=" You can perform this transfer using EDI Lockbox ERA/EEOB exception process." + ...S @RCERR1@(RCCT,7)=" " + ..D DISP1^RCDPESR5(RCCT,1) + ..S Q=0 F S Q=$O(^TMP($J,"RCDP-EOB",RCCT,Q)) Q:'Q S ^TMP($J,"RCDPEOB",RCCT,Q)=$G(^TMP($J,"RCDP-EOB",RCCT,Q,0)) + ..S ^TMP($J,"RCDPEOB",RCCT)=^TMP($J,"RCDP-EOB",RCCT,0) M ^TMP($J,"RCDPEOB",RCCT,"ERR")=@RCERR1@(RCCT) + ..I RCFILE=5 D ;Store err if trans-in failed + ...N RCE,RC,DIE,X,Y,DA,DR + ...S RCE(1)=$$FMTE^XLFDT($$NOW^XLFDT(),2)_" "_$G(@RCERR1@(RCCT,"*")) + ...S RCE(2)=" ",RCFILED=0 + ...D WP^DIE(344.5,RCTDA_",",5,"A","RCE") + .I RCIFN>0 D + ..N RCDUPEOB,RCALLDUP + ..;Chk rec exists + ..S RCDUPEOB=0 + ..S RCEOB=$$DUP^RCDPESR3(RCMNUM,RCIFN,$P($G(^TMP($J,"RCDPEOB",RCCT,"EOB")),U,2),$P($G(^TMP($J,"RCDPEOB",RCCT,"EOB")),U,6)) ;Same msg for update? + ..I RCEOB,$P(RCEOB,U,2) S RCEOB=0 ;If chksum exists, let below check it + ..S ^TMP($J,"RCDP-EOB",RCCT,.5,0)="835ERA" ;Needed - checksum + ..S RCALLDUP=$$DUP^IBCEOB("^TMP("_$J_",""RCDP-EOB"","_RCCT_")",RCIFN) + ..I $S(RCALLDUP:1,RCEOB:$G(DUP)'>0,1:0) D + ...S RCDUPEOB=1 + ...D DUPREC^RCDPESR6(RCET,RCCT,RCSTAR,RCFILE,RCALLDUP,RCEOB,RCBILL,.RCDUPEOB) + ...S:RCALLDUP RCEOBD=RCALLDUP + ..;Add stub to 361.1 + ..I 'RCDUPEOB S RCEOB=+$$ADD3611^IBCEOB(RCMNUM,"","",RCIFN,1,"^TMP("_$J_",""RCDP-EOB"","_RCCT_")") ;IA 4042 + ..K ^TMP($J,"RCDP-EOB",RCCT,.5,0) + ..I RCEOB<0 D:$G(DUP)'>0 Q + ...S @RCERR1@(RCCT)=" ",^(RCCT,1)=RCET_RCCT_RCSTAR,RCFILED=0 + ...S @RCERR1@(RCCT,2)="Error - EEOB detail not added to IB for bill "_RCBILL,$P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U)="" + ...S:RCFILE=5 @RCERR1@(RCCT,"*")=@RCERR1@(RCCT,2) + ...D DISP1^RCDPESR5(RCCT,1) + ...S Q=0 F S Q=$O(^TMP($J,"RCDP-EOB",RCCT,Q)) Q:'Q S ^TMP($J,"RCDPEOB",RCCT,Q)=$G(^TMP($J,"RCDP-EOB",RCCT,Q,0)) + ...S ^TMP($J,"RCDPEOB",RCCT)=^TMP($J,"RCDP-EOB",RCCT,0) M ^TMP($J,"RCDPEOB",RCCT,"ERR")=@RCERR1@(RCCT) + ..;Upd 361.1, needs ^TMP($J,"RCDPEOB","HDR" and $J,"RCDP-EOB" + ..I RCDUPEOB'<0 S RCNOUPD=0 D UPD3611^IBCEOB(RCEOB,RCCT,1) + ..;errors in ^TMP("RCDPERR-EOB",$J + ..I $O(^TMP("RCDPERR-EOB",$J,0)) D ERRUPD^IBCEOB(RCEOB,"RCDPERR-EOB") + ..S $P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U)=$S('$G(RCEOBD):RCEOB,1:RCEOBD) + .K ^TMP("RCDPERR-EOB",$J) + ; + I RCNOUPD D DUPERA^RCDPESR3($G(DUP),RCNOUPD) + I $O(@RCERR1@("")) D BULLS^RCDPESR3(RCFILE,RCTDA,$S(RCNOUPD:RCNOUPD,1:$G(DUP)),$G(RCXMG)) + K ^TMP("RCDPERR-EOB",$J),^TMP($J,"RCDP-EOB"),@RCERR1,@RCSD + D CLEAN^DILF + Q diff --git a/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPESR3.m b/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPESR3.m index 155b352f..57091961 100644 --- a/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPESR3.m +++ b/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPESR3.m @@ -1,182 +1,182 @@ -RCDPESR3 ;ALB/TMK - Server auto-update utilities - EDI Lockbox ;06/06/02 - ;;4.5;Accounts Receivable;**173,214,208,255**;Mar 20, 1995;Build 1 - Q - ; -EFTIN(RCTXN,RCD,XMZ,RCGBL,RCEFLG) ; Adds a new EFT record to AR file 344.3 - ; from Lockbox EFT msg - ; RCTXN = the data on the header record of the message text - ; RCD = array containing formatted mail message header data - ; XMZ = the mail message number - ; RCGBL = the name of the array or global where the message is stored - ; RCEFLG = error flag returned if passed by reference - ; - N CT,RC,RC1,RCLAST,RCEFT,RCTDA,RCERR,RCTYP1,DA,DIK,RCZ,Z,Z0,DLAYGO - ; - ; Take data out of mail message - S (RCEFLG,RCLAST)=0,CT=0,RCTYP1="835EFT" - F X XMREC Q:XMER<0 D Q:RCLAST - . I +XMRG=99,$P(XMRG,U,2)="$" S RCLAST=1 Q - . S:XMRG'="" CT=CT+1,@RCGBL@(2,"D",CT)=XMRG - ; - I 'RCLAST,'$G(RCERR) K @RCGBL S RCERR=2 ;No $ as last character of msg - ; - I $G(RCERR)>0 D G EFTQ - . D ERRUPD^RCDPESR1(RCGBL,.RCD,RCTYP1,.RCERR) - . S RCEFLG=1 - ; - ; Add top-level entry to file 344.3 - S RCEFT=$$ADDEFT(RCTXN,XMZ,RCGBL,.RCERR) - ; - I $G(RCERR) D G EFTQ ; 'BAD' EFT's - . D ERRUPD^RCDPESR1(RCGBL,.RCD,RCTYP1,.RCERR) - . S RCEFLG=1 - ; - G:'RCEFT EFTQ - ; - ; Add the detail data to file 344.31 for this EFT record - S Z=0 F S Z=$O(^RCY(344.31,"B",RCEFT,Z)) Q:'Z S DA=Z,DIK="^RCY(344.31," D ^DIK ; Delete any detail data already there - ; - S (RC,RC1,RCZ)=0 - F S RCZ=$O(@RCGBL@(2,"D",RCZ)) Q:'RCZ S Z0=$G(^(RCZ)) I Z0'="" D Q:$G(RCERR) - . I $P(Z0,U)="01" D ; Each payer's data - .. N DA,DIE,DR,X,Y,DO,DD,DIC - .. S X=RCEFT - .. S DIC("DR")=".11////0;.04////"_$P(Z0,U,2)_";.08////0"_$S($P(Z0,U,5)'="":";.02////"_$P(Z0,U,5),1:"")_$S($P(Z0,U,6)'="":";.03////"_$P(Z0,U,6),1:"")_";.07////"_$J(+$P(Z0,U,4)/100,"",2)_";.06////"_$S($P(Z0,U,8)'="":1,1:0) - .. S DIC("DR")=DIC("DR")_";.12///"_$$FDT^RCDPESR9($P(Z0,U,3))_";.13////"_DT_$S($P(Z0,U,7)'="":";.05////"_$P(Z0,U,7),1:"")_$S($P(Z0,U,9)'="":";.15////"_$P(Z0,U,9),1:"") - .. ; - .. I $P(Z0,U,8)'="" D ; tax id error - ... D TAXERR^RCDPESR1("EFT",$P(Z0,U,5)_" Payer ID: "_$P(RCTXN,U,6),$P(RCTXN,U,7),$P(RCTXN,U,8)) ; Send bad tax id bulletin - .. ; - .. S DIC(0)="L",DIC="^RCY(344.31,",DLAYGO=344.31 D FILE^DICN K DIC,DLAYGO,DO,DD - .. I Y'>0 D ; Error filing data - ... S DIK="^RCY(344.3,",DA=RCEFT D ^DIK - ... S Z=0 F S Z=$O(^RCY(344.31,"B",RCEFT,Z)) Q:'Z S DIK="^RCY(344.31,",DA=Z D ^DIK - ... S RCEFLG=1,RCERR=3 - ... D ERRUPD^RCDPESR1(RCGBL,.RCD,RCTYP1,RCERR) - ; - I '$G(RCEFLG) D - . S DIE="^RCY(344.3,",DA=RCEFT,DR=".09////"_$$CHKSUM(RCEFT) D ^DIE - ; -EFTQ ; - D CLEAN^DILF - Q - ; -ADDEFT(RCTXN,RCXMZ,RCGBL,RCERR) ; File EFT TOTAL record in file 344.3 - ; RCTXN = the data on the header record of the message text - ; RCXMZ = the mail message number - ; RCGBL = the name of the array or global where the message is stored - ; Function returns the ien of the total record found/added - ; and also returns RCERR if passed by reference - ; - N RCTDA,RCRCPT,RCDUP,RCHAC,Z,Z0 - S (RCERR,RCTDA)="" - ; - I $E($P(RCTXN,U,6),1,3)'="469",$E($P(RCTXN,U,6),1,3)'="569",$E($P(RCTXN,U,6),1,3)'="HAC" D G ADDQ ; Invalid EFT deposit number - . N RCDXM,RCCT - . S RCCT=0 - . S RCCT=RCCT+1,RCDXM(RCCT)="This EFT has an invalid deposit number for EDI Lockbox and has been rejected.",RCCT=RCCT+1,RCDXM(RCCT)=" " - . S RCCT=RCCT+1,RCDXM(RCCT)=" ",RCCT=RCCT+1,RCDXM(RCCT)="Here are the contents of this message:" - . D DISP("EDI LBOX INVALID EFT DEPOSIT #",RCCT,.RCDXM,RCXMZ) - ; - ; Make sure it's not already there or if so, it has no ptr to a deposit - ; or if a deposit exists, that the deposit does not yet have a receipt - S RCDUP=0,RCHAC=$E($P(RCTXN,U,6),1,3)="HAC" ; This is a HAC deposit - I $P(RCTXN,U,6)'="" D - . S Z=0 ; Lookup deposit by deposit # - . F S Z=$O(^RCY(344.3,"C",$P(RCTXN,U,6),Z)) Q:'Z S Z0=$G(^RCY(344.3,Z,0)) S:'$P(Z0,U,3) RCTDA=Z Q:RCTDA D Q - .. ; Deposit found - find receipt - .. I $O(^RCY(344,"AD",$P(Z0,U,3),0)) S RCDUP=Z Q - .. S RCTDA=Z - ; - I RCDUP D ; Send bulletin that duplicate EFT received - . N RCDXM,RCCT - . S RCCT=0 - . S RCCT=RCCT+1,RCDXM(RCCT)="This EFT appears to be a duplicate transaction and has been rejected.",RCCT=RCCT+1,RCDXM(RCCT)=" " - . S RCCT=RCCT+1,RCDXM(RCCT)=" ",RCCT=RCCT+1,RCDXM(RCCT)="Here are the contents of this message:" - . D DISP("EDI LBOX DUP EFT DEPOSIT RECEIVED",RCCT,.RCDXM,RCXMZ) - ; - I 'RCDUP D ; Add or update the record - . N RCX,RCDTTM,DIE,DIC,DLAYGO,DD,DA,DO,DR,X,Y,%DT,DINUM - . ; - . S X=$$FDT^RCDPESR9($P(RCTXN,U,3))_"@"_$P(RCTXN,U,4) - . S %DT="XTS" D ^%DT S:Y>0 RCDTTM=Y - . ; - . S DIC("DR")="" - . S DIC("DR")=$S(RCDTTM'="":".02////"_RCDTTM,1:"") - . S DIC("DR")=DIC("DR")_$S(DIC("DR")'="":";",1:"")_".06////"_$P(RCTXN,U,6)_";.07///"_$$FDT^RCDPESR9($P(RCTXN,U,7)) - . S DIC("DR")=DIC("DR")_";.08////"_$$ZERO^RCDPESR9($P(RCTXN,U,8),1)_";.13////"_$$NOW^XLFDT()_";.05////"_RCXMZ_";.14////0;.12////0" - . ; - . I RCTDA D ; Overwrite the data already there - .. L +^RCY(344.3,RCTDA):1 I '$T S RCTDA=-1 Q - .. S DIE="^RCY(344.3,",DA=RCTDA,DR=DIC("DR") K DIC D ^DIE - .. L -^RCY(344.3,RCTDA) - . ; - . I 'RCTDA D - .. S RCX=+$O(^RCY(344.3," "),-1) - .. F RCX=RCX+1:1 I '$D(^RCY(344.3,RCX,0)) L +^RCY(344.3,RCX,0):1 I $T S X=RCX Q - .. S DIC(0)="L",DIC="^RCY(344.3,",DLAYGO=344.3,DINUM=RCX - .. D FILE^DICN K DO,DD,DLAYGO,DIC,DINUM - .. L -^RCY(344.3,RCX,0) - .. S RCTDA=$S(Y<0:"",1:+Y) - . ; - . I 'RCTDA S RCERR=3 ; Error in add of EFT record to file 344.3 - ; -ADDQ Q $S(RCTDA>0:RCTDA,1:"") - ; -CHKSUM(RCTDA) ; Calc the checksum for EFT record stored in RCTDA in 344.3 - ; - N RCDPCSUM,RCDPDATA,X,Y,Z,Z0 - ; - S (RCDPCSUM,X)=0,Z0=$G(^RCY(344.3,RCTDA,0)) - ; Use pcs 1-8, leaving out piece 3 - S RCDPDATA=$P(Z0,U,1,8),$P(RCDPDATA,U,3)="" - S X=RCDPCSUM_RCDPDATA X $S($G(^%ZOSF("LPC"))'="":^("LPC"),1:"S Y=""""") S RCDPCSUM=Y - ; Use detail iens and pieces 3,4,7 to complete the checksum - S Z=0 F S Z=$O(^RCY(344.31,"B",RCTDA,Z)) Q:'Z S Z0=$G(^RCY(344.31,Z,0)),RCDPDATA=Z_U_$P(Z0,U,3,4)_U_$P(Z0,U,7),X=RCDPCSUM_RCDPDATA X $S($G(^%ZOSF("LPC"))'="":^("LPC"),1:"S Y=""""") S RCDPCSUM=Y - Q RCDPCSUM - ; -DISP(RCTIT,RCCT,RCDXM,RCXMZ) ; Sends bulletin with formatted data from message - ; RCTIT = title of bulletin - ; RCCT = # of lines previously populated - ; RCXDM = array containing the text of the bulletin - N RC,Z - K ^TMP("RC1",$J),^TMP("RC",$J),^TMP("RCTEMP",$J) - S RC=1,^TMP("RCTEMP",$J,RC)=$G(^TMP("RCMSGH",$J,0)) - S Z=0 F S Z=$O(^TMP("RCMSG",$J,2,"D",Z)) Q:'Z S RC=RC+1,^TMP("RCTEMP",$J,RC)=$G(^TMP("RCMSG",$J,2,"D",Z)) - D DISP^RCDPESR8("^TMP(""RCTEMP"",$J)","^TMP(""RC1"",$J)",1,"^TMP(""RC"",$J)",75) - S Z=0 F S Z=$O(^TMP("RC",$J,Z)) Q:'Z S RCCT=RCCT+1,RCDXM(RCCT)=$G(^TMP("RC",$J,Z)) - D BULLEFT^RCDPESR0("",RCXMZ,RCTIT,.RCDXM) - K ^TMP("RC1",$J),^TMP("RC",$J),^TMP("RCTEMP",$J) - Q - ; -DUP(RCM,RCIFN,RCAMT,RCAMT1) ; EOB in mail message already stored in 361.1? - ; RCM = msg # EOB was received in - ; RCIFN = bill ien - ; RCAMT = amt pd - ; RCAMT1 = amt reported billed - ; Returns 0 if none found, entry #^message checksum on file if found - N Z,DUP,DUP1 - S (DUP,DUP1,Z)=0 - F S Z=$O(^IBM(361.1,"AC",RCM,Z)) Q:'Z I +$G(^IBM(361.1,Z,0))=RCIFN D Q:DUP - . I '$P($G(^IBM(361.1,Z,100)),U,5) S DUP1=Z Q ; Partially filed before - . I +$G(^IBM(361.1,Z,1))=+RCAMT,+$P($G(^IBM(361.1,1,Z,2)),U,4)=+RCAMT1 S DUP=Z_U_+$P($G(^IBM(361.1,Z,100)),U,5) Q - I 'DUP,DUP1 S DUP=DUP1_"^0" - Q DUP - ; -DUPERA(DUP,RCNOUPD) ; Msg for duplicate ERA - ; RCNOUPD = # of message with duplicate data - ; DUP = flag = -1 if duplicate message received in same mail msg # - K ^TMP("RCERR1",$J) - S ^TMP("RCERR1",$J,1)=$S(DUP>0:"This an exact duplicate of an ERA received previously in mail msg "_RCNOUPD,1:"This ERA message was already fully processed - message was ignored") - Q - ; -BULLS(RCFILE,RCTDA,DUP,RCXMSG) ; Error bulletins for ERA - I RCFILE=5 D BULL1^RCDPESR5(RCTDA,"^TMP(""RCERR1"",$J)",$S($G(DUP)>0:$G(DUP),1:"")) - I RCFILE=4 D BULL2^RCDPESR5(RCTDA,"^TMP(""RCERR1"",$J)",RCXMSG) - Q - ; -ADJERR(RCERR) ; Set up adj error text in RCERR(n) - pass by ref - ; Function returns # of lines for error text - S RCERR(1)="At least 1 adjustment transaction has been found on this ERA. Before the",RCERR(2)=" receipt for this ERA can be processed, the appropriate adjustments",RCERR(3)=" must be made using the EEOB Worklist",RCERR(4)=" " - Q 4 - ; +RCDPESR3 ;ALB/TMK - Server auto-update utilities - EDI Lockbox ;06/06/02 + ;;4.5;Accounts Receivable;**173,214,208**;Mar 20, 1995 + Q + ; +EFTIN(RCTXN,RCD,XMZ,RCGBL,RCEFLG) ; Adds a new EFT record to AR file 344.3 + ; from Lockbox EFT msg + ; RCTXN = the data on the header record of the message text + ; RCD = array containing formatted mail message header data + ; XMZ = the mail message number + ; RCGBL = the name of the array or global where the message is stored + ; RCEFLG = error flag returned if passed by reference + ; + N CT,RC,RC1,RCLAST,RCEFT,RCTDA,RCERR,RCTYP1,DA,DIK,RCZ,Z,Z0,DLAYGO + ; + ; Take data out of mail message + S (RCEFLG,RCLAST)=0,CT=0,RCTYP1="835EFT" + F X XMREC Q:XMER<0 D Q:RCLAST + . I +XMRG=99,$P(XMRG,U,2)="$" S RCLAST=1 Q + . S:XMRG'="" CT=CT+1,@RCGBL@(2,"D",CT)=XMRG + ; + I 'RCLAST,'$G(RCERR) K @RCGBL S RCERR=2 ;No $ as last character of msg + ; + I $G(RCERR)>0 D G EFTQ + . D ERRUPD^RCDPESR1(RCGBL,.RCD,RCTYP1,.RCERR) + . S RCEFLG=1 + ; + ; Add top-level entry to file 344.3 + S RCEFT=$$ADDEFT(RCTXN,XMZ,RCGBL,.RCERR) + ; + I $G(RCERR) D G EFTQ ; 'BAD' EFT's + . D ERRUPD^RCDPESR1(RCGBL,.RCD,RCTYP1,.RCERR) + . S RCEFLG=1 + ; + G:'RCEFT EFTQ + ; + ; Add the detail data to file 344.31 for this EFT record + S Z=0 F S Z=$O(^RCY(344.31,"B",RCEFT,Z)) Q:'Z S DA=Z,DIK="^RCY(344.31," D ^DIK ; Delete any detail data already there + ; + S (RC,RC1,RCZ)=0 + F S RCZ=$O(@RCGBL@(2,"D",RCZ)) Q:'RCZ S Z0=$G(^(RCZ)) I Z0'="" D Q:$G(RCERR) + . I $P(Z0,U)="01" D ; Each payer's data + .. N DA,DIE,DR,X,Y,DO,DD,DIC + .. S X=RCEFT + .. S DIC("DR")=".11////0;.04////"_$P(Z0,U,2)_";.08////0"_$S($P(Z0,U,5)'="":";.02////"_$P(Z0,U,5),1:"")_$S($P(Z0,U,6)'="":";.03////"_$P(Z0,U,6),1:"")_";.07////"_$J(+$P(Z0,U,4)/100,"",2)_";.06////"_$S($P(Z0,U,8)'="":1,1:0) + .. S DIC("DR")=DIC("DR")_";.12///"_$$FDT^RCDPESR9($P(Z0,U,3))_";.13////"_DT_$S($P(Z0,U,7)'="":";.05////"_$P(Z0,U,7),1:"")_$S($P(Z0,U,9)'="":";.15////"_$P(Z0,U,9),1:"") + .. ; + .. I $P(Z0,U,8)'="" D ; tax id error + ... D TAXERR^RCDPESR1("EFT",$P(Z0,U,5)_" Payer ID: "_$P(RCTXN,U,6),$P(RCTXN,U,7),$P(RCTXN,U,8)) ; Send bad tax id bulletin + .. ; + .. S DIC(0)="L",DIC="^RCY(344.31,",DLAYGO=344.31 D FILE^DICN K DIC,DLAYGO,DO,DD + .. I Y'>0 D ; Error filing data + ... S DIK="^RCY(344.3,",DA=RCEFT D ^DIK + ... S Z=0 F S Z=$O(^RCY(344.31,"B",RCEFT,Z)) Q:'Z S DIK="^RCY(344.31,",DA=Z D ^DIK + ... S RCEFLG=1,RCERR=3 + ... D ERRUPD^RCDPESR1(RCGBL,.RCD,RCTYP1,RCERR) + ; + I '$G(RCEFLG) D + . S DIE="^RCY(344.3,",DA=RCEFT,DR=".09////"_$$CHKSUM(RCEFT) D ^DIE + ; +EFTQ ; + D CLEAN^DILF + Q + ; +ADDEFT(RCTXN,RCXMZ,RCGBL,RCERR) ; File EFT TOTAL record in file 344.3 + ; RCTXN = the data on the header record of the message text + ; RCXMZ = the mail message number + ; RCGBL = the name of the array or global where the message is stored + ; Function returns the ien of the total record found/added + ; and also returns RCERR if passed by reference + ; + N RCTDA,RCRCPT,RCDUP,RCHAC,Z,Z0 + S (RCERR,RCTDA)="" + ; + I $E($P(RCTXN,U,6),1,3)'="469",$E($P(RCTXN,U,6),1,3)'="HAC" D G ADDQ ; Invalid EFT deposit number + . N RCDXM,RCCT + . S RCCT=0 + . S RCCT=RCCT+1,RCDXM(RCCT)="This EFT has an invalid deposit number for EDI Lockbox and has been rejected.",RCCT=RCCT+1,RCDXM(RCCT)=" " + . S RCCT=RCCT+1,RCDXM(RCCT)=" ",RCCT=RCCT+1,RCDXM(RCCT)="Here are the contents of this message:" + . D DISP("EDI LBOX INVALID EFT DEPOSIT #",RCCT,.RCDXM,RCXMZ) + ; + ; Make sure it's not already there or if so, it has no ptr to a deposit + ; or if a deposit exists, that the deposit does not yet have a receipt + S RCDUP=0,RCHAC=$E($P(RCTXN,U,6),1,3)="HAC" ; This is a HAC deposit + I $P(RCTXN,U,6)'="" D + . S Z=0 ; Lookup deposit by deposit # + . F S Z=$O(^RCY(344.3,"C",$P(RCTXN,U,6),Z)) Q:'Z S Z0=$G(^RCY(344.3,Z,0)) S:'$P(Z0,U,3) RCTDA=Z Q:RCTDA D Q + .. ; Deposit found - find receipt + .. I $O(^RCY(344,"AD",$P(Z0,U,3),0)) S RCDUP=Z Q + .. S RCTDA=Z + ; + I RCDUP D ; Send bulletin that duplicate EFT received + . N RCDXM,RCCT + . S RCCT=0 + . S RCCT=RCCT+1,RCDXM(RCCT)="This EFT appears to be a duplicate transaction and has been rejected.",RCCT=RCCT+1,RCDXM(RCCT)=" " + . S RCCT=RCCT+1,RCDXM(RCCT)=" ",RCCT=RCCT+1,RCDXM(RCCT)="Here are the contents of this message:" + . D DISP("EDI LBOX DUP EFT DEPOSIT RECEIVED",RCCT,.RCDXM,RCXMZ) + ; + I 'RCDUP D ; Add or update the record + . N RCX,RCDTTM,DIE,DIC,DLAYGO,DD,DA,DO,DR,X,Y,%DT,DINUM + . ; + . S X=$$FDT^RCDPESR9($P(RCTXN,U,3))_"@"_$P(RCTXN,U,4) + . S %DT="XTS" D ^%DT S:Y>0 RCDTTM=Y + . ; + . S DIC("DR")="" + . S DIC("DR")=$S(RCDTTM'="":".02////"_RCDTTM,1:"") + . S DIC("DR")=DIC("DR")_$S(DIC("DR")'="":";",1:"")_".06////"_$P(RCTXN,U,6)_";.07///"_$$FDT^RCDPESR9($P(RCTXN,U,7)) + . S DIC("DR")=DIC("DR")_";.08////"_$$ZERO^RCDPESR9($P(RCTXN,U,8),1)_";.13////"_$$NOW^XLFDT()_";.05////"_RCXMZ_";.14////0;.12////0" + . ; + . I RCTDA D ; Overwrite the data already there + .. L +^RCY(344.3,RCTDA):1 I '$T S RCTDA=-1 Q + .. S DIE="^RCY(344.3,",DA=RCTDA,DR=DIC("DR") K DIC D ^DIE + .. L -^RCY(344.3,RCTDA) + . ; + . I 'RCTDA D + .. S RCX=+$O(^RCY(344.3," "),-1) + .. F RCX=RCX+1:1 I '$D(^RCY(344.3,RCX,0)) L +^RCY(344.3,RCX,0):1 I $T S X=RCX Q + .. S DIC(0)="L",DIC="^RCY(344.3,",DLAYGO=344.3,DINUM=RCX + .. D FILE^DICN K DO,DD,DLAYGO,DIC,DINUM + .. L -^RCY(344.3,RCX,0) + .. S RCTDA=$S(Y<0:"",1:+Y) + . ; + . I 'RCTDA S RCERR=3 ; Error in add of EFT record to file 344.3 + ; +ADDQ Q $S(RCTDA>0:RCTDA,1:"") + ; +CHKSUM(RCTDA) ; Calc the checksum for EFT record stored in RCTDA in 344.3 + ; + N RCDPCSUM,RCDPDATA,X,Y,Z,Z0 + ; + S (RCDPCSUM,X)=0,Z0=$G(^RCY(344.3,RCTDA,0)) + ; Use pcs 1-8, leaving out piece 3 + S RCDPDATA=$P(Z0,U,1,8),$P(RCDPDATA,U,3)="" + S X=RCDPCSUM_RCDPDATA X $S($G(^%ZOSF("LPC"))'="":^("LPC"),1:"S Y=""""") S RCDPCSUM=Y + ; Use detail iens and pieces 3,4,7 to complete the checksum + S Z=0 F S Z=$O(^RCY(344.31,"B",RCTDA,Z)) Q:'Z S Z0=$G(^RCY(344.31,Z,0)),RCDPDATA=Z_U_$P(Z0,U,3,4)_U_$P(Z0,U,7),X=RCDPCSUM_RCDPDATA X $S($G(^%ZOSF("LPC"))'="":^("LPC"),1:"S Y=""""") S RCDPCSUM=Y + Q RCDPCSUM + ; +DISP(RCTIT,RCCT,RCDXM,RCXMZ) ; Sends bulletin with formatted data from message + ; RCTIT = title of bulletin + ; RCCT = # of lines previously populated + ; RCXDM = array containing the text of the bulletin + N RC,Z + K ^TMP("RC1",$J),^TMP("RC",$J),^TMP("RCTEMP",$J) + S RC=1,^TMP("RCTEMP",$J,RC)=$G(^TMP("RCMSGH",$J,0)) + S Z=0 F S Z=$O(^TMP("RCMSG",$J,2,"D",Z)) Q:'Z S RC=RC+1,^TMP("RCTEMP",$J,RC)=$G(^TMP("RCMSG",$J,2,"D",Z)) + D DISP^RCDPESR8("^TMP(""RCTEMP"",$J)","^TMP(""RC1"",$J)",1,"^TMP(""RC"",$J)",75) + S Z=0 F S Z=$O(^TMP("RC",$J,Z)) Q:'Z S RCCT=RCCT+1,RCDXM(RCCT)=$G(^TMP("RC",$J,Z)) + D BULLEFT^RCDPESR0("",RCXMZ,RCTIT,.RCDXM) + K ^TMP("RC1",$J),^TMP("RC",$J),^TMP("RCTEMP",$J) + Q + ; +DUP(RCM,RCIFN,RCAMT,RCAMT1) ; EOB in mail message already stored in 361.1? + ; RCM = msg # EOB was received in + ; RCIFN = bill ien + ; RCAMT = amt pd + ; RCAMT1 = amt reported billed + ; Returns 0 if none found, entry #^message checksum on file if found + N Z,DUP,DUP1 + S (DUP,DUP1,Z)=0 + F S Z=$O(^IBM(361.1,"AC",RCM,Z)) Q:'Z I +$G(^IBM(361.1,Z,0))=RCIFN D Q:DUP + . I '$P($G(^IBM(361.1,Z,100)),U,5) S DUP1=Z Q ; Partially filed before + . I +$G(^IBM(361.1,Z,1))=+RCAMT,+$P($G(^IBM(361.1,1,Z,2)),U,4)=+RCAMT1 S DUP=Z_U_+$P($G(^IBM(361.1,Z,100)),U,5) Q + I 'DUP,DUP1 S DUP=DUP1_"^0" + Q DUP + ; +DUPERA(DUP,RCNOUPD) ; Msg for duplicate ERA + ; RCNOUPD = # of message with duplicate data + ; DUP = flag = -1 if duplicate message received in same mail msg # + K ^TMP("RCERR1",$J) + S ^TMP("RCERR1",$J,1)=$S(DUP>0:"This an exact duplicate of an ERA received previously in mail msg "_RCNOUPD,1:"This ERA message was already fully processed - message was ignored") + Q + ; +BULLS(RCFILE,RCTDA,DUP,RCXMSG) ; Error bulletins for ERA + I RCFILE=5 D BULL1^RCDPESR5(RCTDA,"^TMP(""RCERR1"",$J)",$S($G(DUP)>0:$G(DUP),1:"")) + I RCFILE=4 D BULL2^RCDPESR5(RCTDA,"^TMP(""RCERR1"",$J)",RCXMSG) + Q + ; +ADJERR(RCERR) ; Set up adj error text in RCERR(n) - pass by ref + ; Function returns # of lines for error text + S RCERR(1)="At least 1 adjustment transaction has been found on this ERA. Before the",RCERR(2)=" receipt for this ERA can be processed, the appropriate adjustments",RCERR(3)=" must be made using the EEOB Worklist",RCERR(4)=" " + Q 4 + ; diff --git a/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPESR6.m b/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPESR6.m index 2a0f660f..f52599ef 100644 --- a/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPESR6.m +++ b/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPESR6.m @@ -1,110 +1,100 @@ -RCDPESR6 ;ALB/TMK - Server auto-update file 344.4 - EDI Lockbox ;10/29/02 - ;;4.5;Accounts Receivable;**173,214,208,230,252**;Mar 20, 1995;Build 63 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -UPD3444(RCRTOT) ; Add EOB detail to list in 344.41 for file 344.4 entry RCRTOT - ; If passed by reference, RCRTOT is returned = "" if errors - ; - N RC,RCCOM1,RCCOM2,RCCT,RC1,RC2,RCDPNM,RCEOB,RCNPI1,RCNPI2,DA,DR,DO,DD,DLAYGO,DIC,DIK,X,Y,Z - S RC=0 F S RC=$O(^TMP($J,"RCDPEOB",RC)) Q:'RC S RC1=$G(^(RC)),RC2=$G(^(RC,"EOB")),RCEOB=+RC2 D Q:'RCRTOT - . ; Upd 344.41 with reference to this record if it doesn't already exist - . I RCEOB>0 Q:$D(^RCY(344.4,RCRTOT,1,"AC",RCEOB,RC)) - . I RCEOB'>0,$S($P(RC1,U,2)'="":$D(^RCY(344.4,RCRTOT,1,"AD",$P(RC1,U,2),RC)),1:0) Q - . ; Disregard ECME reject related EEOBs - . I RCEOB'>0,'$P(RC2,U,2),$P(RC1,U,2)?1.7N,$$REJECT^IBNCPDPU($P(RC1,U,2),$P(RC1,U,3)) Q - . S DA(1)=RCRTOT,X=RC,DIC="^RCY(344.4,"_DA(1)_",1,",DIC(0)="L",DLAYGO=344.41 - . S DIC("DR")=$S($G(RCEOB)>0:".02////"_RCEOB,1:".05////"_$P(RC1,U,2)_";.07////1") - . I $P(RC2,U,2)'="" S DIC("DR")=DIC("DR")_$S($L(DIC("DR")):";",1:"")_".03///"_$P(RC2,U,2) ; amt - . I $P(RC2,U,3)'="" S DIC("DR")=DIC("DR")_$S($L(DIC("DR")):";",1:"")_".04////"_$P(RC2,U,3) ; ins co - . I $P(RC2,U,4) S DIC("DR")=DIC("DR")_$S($L(DIC("DR")):";",1:"")_".14////1" ; reversal - . I $P(RC2,U,5)'="" S DIC("DR")=DIC("DR")_$S($L(DIC("DR")):";",1:"")_".15////^S X=$E($P(RC2,U,5),1,30)" ; Patient name - . ; Process Billing Prov NPI, Rendering/Servicing NPI & name - . S (RCCOM1,RCCOM2)="" - . S RCNPI1=$P(RC2,U,10),RCNPI2=$P(RC2,U,11) - . I RCNPI1'="",'$$CHKDGT^XUSNPI(RCNPI1) S RCCOM1="The Billing Provider NPI received on the 835 ("_$E(RCNPI1,1,10)_") is not a valid format." - . I RCNPI2'="",'$$CHKDGT^XUSNPI(RCNPI2) S RCCOM2="The "_$S($P(RC2,U,12)=1:"Rendering",1:"Servicing")_" NPI received on the 835 ("_$E(RCNPI2,1,10)_") is not a valid format." - . I RCCOM1="" S DIC("DR")=DIC("DR")_";.18////^S X=$P(RC2,U,10)" ;Billing Provider NPI - . I RCCOM2="" S DIC("DR")=DIC("DR")_";.19////^S X=$P(RC2,U,11)" ;Rendering Provider NPI - . S RCDPNM=$P(RC2,U,13) I $P(RC2,U,14)]"" S RCDPNM=RCDPNM_$S(RCDPNM]"":",",1:"")_$P(RC2,U,14) - . S DIC("DR")=DIC("DR")_";.2////^S X=$P(RC2,U,12);.21////^S X=RCDPNM" ; Entity Type Qualifier ^ Last name,First Name - . S DIC("DR")=DIC("DR")_";.22////^S X=RCCOM1;.23////^S X=RCCOM2" ;Comment on Billing provider^comment on rendering/servicing provider NPI - . D FILE^DICN K DO,DD,DLAYGO,DIC,DIK - . S RCCT=+Y - . I RCCT<0 D Q - .. S DA=RCRTOT,DIK="^RCY(344.4," D ^DIK - .. S RCRTOT=0 - . ; If there is no IB EOB record, store the raw data in 344.411 - . I RC1'>0!(RCEOB'>0) D - .. N RCDATA,RCC,RCDA - .. S RCC=2,RCDATA(1)=$G(^TMP($J,"RCDPEOB","HDR")) - .. S Z=0 F S Z=$O(^TMP($J,"RCDPEOB",RCCT,Z)) Q:'Z S RCC=RCC+1,RCDATA(RCC)=$G(^TMP($J,"RCDPEOB",RCCT,Z)) - .. S RCDA(1)=RCRTOT,RCDA=RCCT - .. D WP^DIE(344.41,$$IENS^DILF(.RCDA),1,"A","RCDATA") - Q - ; - ; -ERATOT(RCTDA,RCERR) ; File ERA TOTAL rec in 344.4 from entry RCTDA in 344.5 - ; RCTDA = ien file 344.5 - ; Returns: the ien file 344.4 - ; RCERR if passed by reference, with error text - ; RCERR(1)=duplicated message - N RCTYPE,RCDA,RCMETH,RCTRACE,RCID,RCDT,RCAMT,RCDUP,RCZ,RCX,RCPAYER,DIE,DIK,DIC,DLAYGO,DD,DO,DR,DA,X,Y,Z0,Z1 - S (RCERR,RCDA)="" - S RCZ=$G(^RCY(344.5,RCTDA,2,1,0)) - S RCTYPE=$P(RCZ,U),RCTRACE=$P(RCZ,U,8),RCID=$P(RCZ,U,7),RCPAYER=$P(RCZ,U,6),RCMETH=$P(RCZ,U,17) - ; Need header record as first entry in field - I RCTYPE'["835ERA" S RCERR="No header record found in message. An EEOB exception record was created" G ERATOTQ - ; - S RCDT=$$FMDT^RCDPESR1($P(RCZ,U,9)),RCAMT=$J(($P(RCZ,U,10)/100),0,2) - ;Elec ERA's must have a trace # and an ins co id - I RCTRACE=""!(RCID="") S RCERR="Trace # or ins ID missing on ERA transaction. An EEOB exception record was created." G ERATOTQ - ; Make sure it's not already there - S (RCDUP,Z1)=0 - F S Z1=$O(^RCY(344.4,"ATRID",RCTRACE,RCID,Z1)) Q:'Z1 S Z0=$G(^RCY(344.4,Z1,0)) I $P(Z0,U,4)=RCDT,+$P(Z0,U,5)=+RCAMT S RCDUP=1 Q - ; - I RCDUP,$P(Z0,U,8) D G ERATOTQ ; Receipt already exists - no update - . S RCERR="This is a duplicate ERA and has already been posted",RCERR(1)=-2 - I RCDUP S RCERR="DUP",RCERR(1)=$S($P(Z0,U,12)'=$P($G(^RCY(344.5,RCTDA,0)),U,11):$P(Z0,U,12),1:-1) G ERATOTQ - ; - S RCX=+$O(^RCY(344.4," "),-1) - S DIC(0)="L",DIC="^RCY(344.4,",DLAYGO=344.4 - S DIC("DR")=".02////"_RCTRACE_";.03////"_RCID_";.04////"_RCDT_";.05////"_RCAMT_";.06////"_$P(RCZ,U,6)_";.09////0;.12////"_$P($G(^RCY(344.5,RCTDA,0)),U,11)_";.07////"_$$NOW^XLFDT()_";.1////1" - I RCMETH'="" S DIC("DR")=DIC("DR")_";.15////"_RCMETH - F RCX=RCX+1:1 L +^RCY(344.4,RCX,0):1 I $T,'$D(^RCY(344.4,RCX,0)) S X=RCX Q - D FILE^DICN K DO,DLAYGO,DD,DIC - L -^RCY(344.4,RCX,0) - S RCDA=$S(Y<0:"",1:+Y) - I 'RCDA D - . S RCERR="An error was encountered that prevented the adding of an ERA totals record. An EEOB exception record was created." - ; -ERATOTQ Q RCDA - ; -UPDCON(RCRTOT) ; Add contact information to file 344.4 for an ERA - N DIE,DA,DR,Z,Q,X,Y - S Z=$G(^TMP($J,"RCDPEOB","CONTACT")) - Q:$TR($P(Z,U,3,9),U)="" - S DA=RCRTOT,DIE="^RCY(344.4,",DR="" - F Q=3:1:9 S DR=DR_$S(DR'="":";3.0",1:"3.0")_(Q-2)_"///"_$S($P(Z,U,Q)="":"@",1:"/"_$P(Z,U,Q)) - D ^DIE - Q - ; -UPDADJ(RCRTOT) ; Add ERA level adj data to file 344.4 - N Z,Z0,DA,DIC,DLAYGO,DR,X,Y,DO,DD - ; Remove any already there - S Z=0 F S Z=$O(^RCY(344.4,RCRTOT,2,Z)) Q:'Z S DA(1)=RCRTOT,DA=Z D ^DIK - ; - S Z=0 F S Z=$O(^TMP($J,"RCDPEOB","ADJ",Z)) Q:'Z S Z0=$G(^(Z)) D - . S DIC(0)="L",X=$P(Z0,U,3)_" ",DA(1)=RCRTOT,DIC="^RCY(344.4,"_DA(1)_",2,",DIC("DR")=$S($P(Z0,U,2)'="":".02////"_$P(Z0,U,2),1:"") - . S DIC("DR")=DIC("DR")_$S(DIC("DR")'="":";",1:"")_$S($P(Z0,U,4)'="":".03////"_$J(-$P(Z0,U,4)/100,"",2),1:"") - . S DIC("DR")=DIC("DR")_$S(DIC("DR")'="":";",1:"")_$S($P(Z0,U,5)'="":".04////"_$P(Z0,U,5),1:""),DLAYGO=344.42 - . S:$O(^RCY(344.4,RCRTOT,2,"B",X,0)) X=""""_X_"""" - . D FILE^DICN K DIC,DO,DD - Q - ; -DUPREC(RCET,RCCT,RCSTAR,RCFILE,RCALLDUP,RCEOB,RCBILL,RCDUPEOB) ; Overflow from RCDPESR2 - S ^TMP("RCERR1",$J,RCCT)=" ",^TMP("RCERR1",$J,RCCT,1)=RCET_RCCT_RCSTAR - S ^TMP("RCERR1",$J,RCCT,2)="(Warning): EEOB detail already filed for "_RCBILL_" - "_$S(RCALLDUP:"Duplicate not stored",1:"EEOB updated"),^TMP("RCERR1",$J,RCCT,3)=" " S:RCFILE=5 ^TMP("RCERR1",$J,RCCT,"*")=^TMP("RCERR1",$J,RCCT,2) - I RCALLDUP S RCEOB="",RCDUPEOB=-1 Q - S $P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U)=RCEOB - Q - ; +RCDPESR6 ;ALB/TMK - Server auto-update file 344.4 - EDI Lockbox ;10/29/02 + ;;4.5;Accounts Receivable;**173,214,208,230**;Mar 20, 1995 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; +UPD3444(RCRTOT) ; Add EOB detail to list in 344.41 for file 344.4 entry RCRTOT + ; If passed by reference, RCRTOT is returned = "" if errors + ; + N RC,RCCT,RC1,RC2,RCEOB,DA,DR,DO,DD,DLAYGO,DIC,DIK,X,Y,Z + S RC=0 F S RC=$O(^TMP($J,"RCDPEOB",RC)) Q:'RC S RC1=$G(^(RC)),RC2=$G(^(RC,"EOB")),RCEOB=+RC2 D Q:'RCRTOT + . ; Upd 344.41 with reference to this record if it doesn't already exist + . I RCEOB>0 Q:$D(^RCY(344.4,RCRTOT,1,"AC",RCEOB,RC)) + . I RCEOB'>0,$S($P(RC1,U,2)'="":$D(^RCY(344.4,RCRTOT,1,"AD",$P(RC1,U,2),RC)),1:0) Q + . ; Disregard ECME reject related EEOBs + . I RCEOB'>0,'$P(RC2,U,2),$P(RC1,U,2)?1.7N,$$REJECT^IBNCPDPU($P(RC1,U,2),$P(RC1,U,3)) Q + . S DA(1)=RCRTOT,X=RC,DIC="^RCY(344.4,"_DA(1)_",1,",DIC(0)="L",DLAYGO=344.41 + . S DIC("DR")=$S($G(RCEOB)>0:".02////"_RCEOB,1:".05////"_$P(RC1,U,2)_";.07////1") + . I $P(RC2,U,2)'="" S DIC("DR")=DIC("DR")_$S($L(DIC("DR")):";",1:"")_".03///"_$P(RC2,U,2) ; amt + . I $P(RC2,U,3)'="" S DIC("DR")=DIC("DR")_$S($L(DIC("DR")):";",1:"")_".04////"_$P(RC2,U,3) ; ins co + . I $P(RC2,U,4) S DIC("DR")=DIC("DR")_$S($L(DIC("DR")):";",1:"")_".14////1" ; reversal + . I $P(RC2,U,5)'="" S DIC("DR")=DIC("DR")_$S($L(DIC("DR")):";",1:"")_".15////^S X=$E($P(RC2,U,5),1,30)" ; Patient name + . D FILE^DICN K DO,DD,DLAYGO,DIC,DIK + . S RCCT=+Y + . I RCCT<0 D Q + .. S DA=RCRTOT,DIK="^RCY(344.4," D ^DIK + .. S RCRTOT=0 + . ; If there is no IB EOB record, store the raw data in 344.411 + . I RC1'>0!(RCEOB'>0) D + .. N RCDATA,RCC,RCDA + .. S RCC=2,RCDATA(1)=$G(^TMP($J,"RCDPEOB","HDR")) + .. S Z=0 F S Z=$O(^TMP($J,"RCDPEOB",RCCT,Z)) Q:'Z S RCC=RCC+1,RCDATA(RCC)=$G(^TMP($J,"RCDPEOB",RCCT,Z)) + .. S RCDA(1)=RCRTOT,RCDA=RCCT + .. D WP^DIE(344.41,$$IENS^DILF(.RCDA),1,"A","RCDATA") + Q + ; + ; +ERATOT(RCTDA,RCERR) ; File ERA TOTAL rec in 344.4 from entry RCTDA in 344.5 + ; RCTDA = ien file 344.5 + ; Returns: the ien file 344.4 + ; RCERR if passed by reference, with error text + ; RCERR(1)=duplicated message + N RCTYPE,RCDA,RCMETH,RCTRACE,RCID,RCDT,RCAMT,RCDUP,RCZ,RCX,RCPAYER,DIE,DIK,DIC,DLAYGO,DD,DO,DR,DA,X,Y,Z0,Z1 + S (RCERR,RCDA)="" + S RCZ=$G(^RCY(344.5,RCTDA,2,1,0)) + S RCTYPE=$P(RCZ,U),RCTRACE=$P(RCZ,U,8),RCID=$P(RCZ,U,7),RCPAYER=$P(RCZ,U,6),RCMETH=$P(RCZ,U,17) + ; Need header record as first entry in field + I RCTYPE'["835ERA" S RCERR="No header record found in message. An EEOB exception record was created" G ERATOTQ + ; + S RCDT=$$FMDT^RCDPESR1($P(RCZ,U,9)),RCAMT=$J(($P(RCZ,U,10)/100),0,2) + ;Elec ERA's must have a trace # and an ins co id + I RCTRACE=""!(RCID="") S RCERR="Trace # or ins ID missing on ERA transaction. An EEOB exception record was created." G ERATOTQ + ; Make sure it's not already there + S (RCDUP,Z1)=0 + F S Z1=$O(^RCY(344.4,"ATRID",RCTRACE,RCID,Z1)) Q:'Z1 S Z0=$G(^RCY(344.4,Z1,0)) I $P(Z0,U,4)=RCDT,+$P(Z0,U,5)=+RCAMT S RCDUP=1 Q + ; + I RCDUP,$P(Z0,U,8) D G ERATOTQ ; Receipt already exists - no update + . S RCERR="This is a duplicate ERA and has already been posted",RCERR(1)=-2 + I RCDUP S RCERR="DUP",RCERR(1)=$S($P(Z0,U,12)'=$P($G(^RCY(344.5,RCTDA,0)),U,11):$P(Z0,U,12),1:-1) G ERATOTQ + ; + S RCX=+$O(^RCY(344.4," "),-1) + S DIC(0)="L",DIC="^RCY(344.4,",DLAYGO=344.4 + S DIC("DR")=".02////"_RCTRACE_";.03////"_RCID_";.04////"_RCDT_";.05////"_RCAMT_";.06////"_$P(RCZ,U,6)_";.09////0;.12////"_$P($G(^RCY(344.5,RCTDA,0)),U,11)_";.07////"_$$NOW^XLFDT()_";.1////1" + I RCMETH'="" S DIC("DR")=DIC("DR")_";.15////"_RCMETH + F RCX=RCX+1:1 L +^RCY(344.4,RCX,0):1 I $T,'$D(^RCY(344.4,RCX,0)) S X=RCX Q + D FILE^DICN K DO,DLAYGO,DD,DIC + L -^RCY(344.4,RCX,0) + S RCDA=$S(Y<0:"",1:+Y) + I 'RCDA D + . S RCERR="An error was encountered that prevented the adding of an ERA totals record. An EEOB exception record was created." + ; +ERATOTQ Q RCDA + ; +UPDCON(RCRTOT) ; Add contact information to file 344.4 for an ERA + N DIE,DA,DR,Z,Q,X,Y + S Z=$G(^TMP($J,"RCDPEOB","CONTACT")) + Q:$TR($P(Z,U,3,9),U)="" + S DA=RCRTOT,DIE="^RCY(344.4,",DR="" + F Q=3:1:9 S DR=DR_$S(DR'="":";3.0",1:"3.0")_(Q-2)_"///"_$S($P(Z,U,Q)="":"@",1:"/"_$P(Z,U,Q)) + D ^DIE + Q + ; +UPDADJ(RCRTOT) ; Add ERA level adj data to file 344.4 + N Z,Z0,DA,DIC,DLAYGO,DR,X,Y,DO,DD + ; Remove any already there + S Z=0 F S Z=$O(^RCY(344.4,RCRTOT,2,Z)) Q:'Z S DA(1)=RCRTOT,DA=Z D ^DIK + ; + S Z=0 F S Z=$O(^TMP($J,"RCDPEOB","ADJ",Z)) Q:'Z S Z0=$G(^(Z)) D + . S DIC(0)="L",X=$P(Z0,U,3)_" ",DA(1)=RCRTOT,DIC="^RCY(344.4,"_DA(1)_",2,",DIC("DR")=$S($P(Z0,U,2)'="":".02////"_$P(Z0,U,2),1:"") + . S DIC("DR")=DIC("DR")_$S(DIC("DR")'="":";",1:"")_$S($P(Z0,U,4)'="":".03////"_$J(-$P(Z0,U,4)/100,"",2),1:"") + . S DIC("DR")=DIC("DR")_$S(DIC("DR")'="":";",1:"")_$S($P(Z0,U,5)'="":".04////"_$P(Z0,U,5),1:""),DLAYGO=344.42 + . S:$O(^RCY(344.4,RCRTOT,2,"B",X,0)) X=""""_X_"""" + . D FILE^DICN K DIC,DO,DD + Q + ; +DUPREC(RCET,RCCT,RCSTAR,RCFILE,RCALLDUP,RCEOB,RCBILL,RCDUPEOB) ; Overflow from RCDPESR2 + S ^TMP("RCERR1",$J,RCCT)=" ",^TMP("RCERR1",$J,RCCT,1)=RCET_RCCT_RCSTAR + S ^TMP("RCERR1",$J,RCCT,2)="(Warning): EEOB detail already filed for "_RCBILL_" - "_$S(RCALLDUP:"Duplicate not stored",1:"EEOB updated"),^TMP("RCERR1",$J,RCCT,3)=" " S:RCFILE=5 ^TMP("RCERR1",$J,RCCT,"*")=^TMP("RCERR1",$J,RCCT,2) + I RCALLDUP S RCEOB="",RCDUPEOB=-1 Q + S $P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U)=RCEOB + Q + ; diff --git a/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPESR9.m b/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPESR9.m index 846ff341..e183088d 100644 --- a/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPESR9.m +++ b/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPESR9.m @@ -1,210 +1,205 @@ -RCDPESR9 ;ALB/TMK - ERA return file field captions ;09-SEP-2003 - ;;4.5;Accounts Receivable;**173,252**;Mar 20, 1995;Build 63 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ; Note: if the 835 flat file changes, make the corresponding changes - ; in this routine. -835 ;;HEADER DATA - ;;835^^Return Message ID^S Y=X_" (ERA HEADER DATA)" - ;;835^^X12/Proprietary flag^S Y=$S(X="X":"X12",1:X) - ;;835^^File Date^S Y=$$FDT^RCDPESR9(X) - ;;835^^File Time^S Y=$E(X,1,2)-$S($E(X,1,2)>12:12,1:0)_":"_$E(X,3,4)_$S($E(X,1,2)=24:" AM",$E(X,1,2)>11:" PM",1:" AM") - ;;835^1^MRA^S Y="" - ;;835^^Payer Name - ;;835^^Payer ID - ;;835^^Trace Number - ;;835^^Date Claims Paid^S Y=$$FDT^RCDPESR9(X) - ;;835^^Total ERA Amount^S Y=$$ZERO^RCDPESR9(X,1) - ;;835^^Erroneous Provider Tax ID - ;;835^^Tax ID correction Flag^S Y=$S(X="E":"CHANGED BY EPHRA",X="C":"DETERMINED FROM CLAIM DATA",X="":"NO CHANGE MADE",1:X) - ;;835^^Sequence Control # - ;;835^^Sequence # - ;;835^^Last Sequence # - ;;835^^Contact Information - ;;835^^Payment Method Code - ;;835^^Billing Provider NPI - ; -01 ;;PAYER CONTACT INFORMATION - ;;01^^ERA Contact Name - ;;01^^ERA Contact #1 - ;;01^^ERA Contact #1 Type^S Y=$$EXTERNAL^DILFD(344.4,3.03,,X) - ;;01^^ERA Contact #2 - ;;01^^ERA Contact #2 Type^S Y=$$EXTERNAL^DILFD(344.4,3.05,,X) - ;;01^^ERA Contact #3 - ;;01^^ERA Contact #3 Type^S Y=$$EXTERNAL^DILFD(344.4,3.07,,X) - ; -02 ;;PAYER ADJUSTMENT RECORD - ;;02^^Line Type^S Y=X_" (ERA LEVEL PAYER ADJUSTMENT RECORD)" - ;;02^^X12 Adjustment Reason Code - ;;02^^Provider Adjustment Identifier - ;;02^^Adjustment Amount^S Y=$$ZERO^RCDPESR9(X,1) - ;;02^^X12 Reason Text - ; -05 ;;CLAIM PATIENT ID - ;;05^^Line Type^S Y=X_" (CLAIM LEVEL PATIENT ID DATA)" - ;;05^^Bill # - ;;05^^Patient Last Name - ;;05^^Patient First Name - ;;05^^Patient Middle Name - ;;05^^Patient ID # - ;;05^1^Record Contains Patient Name Change^S Y="" - ;;05^1^Record Contains Patient ID Change^S Y="" - ;;05^^Statement Start Date^S Y=$$FDT^RCDPESR9(X) - ;;05^^Statement End Date^S Y=$$FDT^RCDPESR9(X) - ; -10 ;;CLAIM STATUS DATA - ;;10^^Line Type^S Y=X_" (CLAIM LEVEL CLAIM STATUS DATA)" - ;;10^^Bill # - ;;10^^Claim Processed^S Y=$$YN^RCDPESR9(X) - ;;10^^Claim Denied^S Y=$$YN^RCDPESR9(X) - ;;10^^Claim Pended^S Y=$$YN^RCDPESR9(X) - ;;10^^Claim Reversal^S Y=$$YN^RCDPESR9(X) - ;;10^^Claim Status Code - ;;10^1^Crossed Over Name^S Y="" - ;;10^1^Crossed Over ID^S Y="" - ;;10^^Submitted Charge^S Y=$$ZERO^RCDPESR9(X,1) - ;;10^^Amount Paid^S Y=$$ZERO^RCDPESR9(X,1) - ;;10^^ICN - ;;10^^DRG Code Used - ;;10^^DRG Weight Used^S Y=$J($$ZERO^RCDPESR9(X,1)/100,4) - ;;10^^Discharge Fraction^S Y=$$ZERO^RCDPESR9(X,1) - ;;10^^Rendering NPI - ;;10^^Entity Type Qualifier - ;;10^^Last Name - ;;10^^First Name - ; -15 ;;CLAIM STATUS DATA - ;;15^^Line Type^S Y=X_" (CLAIM LEVEL CLAIM STATUS DATA (CONTINUED))" - ;;15^^Bill # - ;;15^^Covered Amount^S Y=$$ZERO^RCDPESR9(X,1) - ;;15^1^Discount Amount^S Y=$$ZERO^RCDPESR9(X,1,1) - ;;15^1^Day Limit Amt^S Y=$$ZERO^RCDPESR9(X,1,1) - ;;15^1^Interest Amount^S Y=$$ZERO^RCDPESR9(X,1,1) - ;;15^1^Tax Amount^S Y=$$ZERO^RCDPESR9(X,1,1) - ;;15^1^Total Before Taxes Amt^S Y=$$ZERO^RCDPESR9(X,1,1) - ;;15^^Patient Responsibility Amount^S Y=$$ZERO^RCDPESR9(X,1) - ;;15^1^Negative Reimbursement^S Y=$$ZERO^RCDPESR9(X,1,1) - ; -17 ;;CLAIM LEVEL PAYER CONTACT INFORMATION - ;;17^^Line Type^S Y=X_" (CLAIM LEVEL PAYER CONTACT INFO)" - ;;17^^Bill # - ;;17^^Contact Name - ;;17^^Contact #1 - ;;17^^Contact #1 Type^S Y=$$EXTERNAL^DILFD(361.1,25.03,,X) - ;;17^^Contact #2 - ;;17^^Contact #2 Type^S Y=$$EXTERNAL^DILFD(361.1,25.05,,X) - ;;17^^Contact #3 - ;;17^^Contact #3 Type^S Y=$$EXTERNAL^DILFD(361.1,25.07,,X) - ; -20 ;;CLAIM LEVEL ADJUSTMENT DATA - ;;20^^Line Type^S Y=X_" (CLAIM LEVEL CLAIM ADJUSTMENT DATA)" - ;;20^^Bill # - ;;20^^Adjustment Group Code - ;;20^^Adjustment Reason Code - ;;20^^Adjustment Amount^S Y=$$ZERO^RCDPESR9(X,1) - ;;20^^Quantity^S Y=$$ZERO^RCDPESR9(X) - ;;20^^Reason Code Text - ; -30 ;;CLAIM LEVEL MEDICARE INPT ADJUDICATION DATA - ;;30^^Line Type^S Y=X_" (CLAIM LEVEL MEDICARE INPATIENT ADJUDICATION DATA)" - ;;30^^Bill # - ;;30^^Covered Days/Visits^S Y=$$ZERO^RCDPESR9(X) - ;;30^1^Lifetime Reserve Days Count^S Y=$$ZERO^RCDPESR9(X,,1) - ;;30^1^Lifetime Psych Days Count^S Y=$$ZERO^RCDPESR9(X,,1) - ;;30^^Claim DRG Amt^S Y=$$ZERO^RCDPESR9(X,1) - ;;30^1^Claim Disproportionate Share Amt^S Y=$$ZERO^RCDPESR9(X,1,1) - ;;30^1^Claim MSP Pass thru Amt^S Y=$$ZERO^RCDPESR9(X,1,1) - ;;30^1^Claim PPS Capital Amt^S Y=$$ZERO^RCDPESR9(X,1,1) - ;;30^1^PPS-Capital FSP DRG Amt^S Y=$$ZERO^RCDPESR9(X,1,1) - ;;30^1^PPS-Capital HSP DRG Amt^S Y=$$ZERO^RCDPESR9(X,1,1) - ;;30^1^PPS-Capital DSH DRG Amt^S Y=$$ZERO^RCDPESR9(X,1,1) - ;;30^1^Old Capital Amt^S Y=$$ZERO^RCDPESR9(X,1,1) - ;;30^^Non-Covered Days^S Y=$$ZERO^RCDPESR9(X) - ; -35 ;;CLAIM LEVEL MEDICARE ADJUDICATION DATA - ;;35^^Line Type^S Y=X_" (CLAIM LEVEL MEDICARE ADJUDICATION DATA)" - ;;35^^Bill # - ;;35^1^PPS-Capital IME Amt^S Y=$$ZERO^RCDPESR9(X,1,1) - ;;35^1^PPS-Operating Hosp Specific DRG Amt^S Y=$$ZERO^RCDPESR9(X,1,1) - ;;35^1^Cost Report Day Count^S Y=$$ZERO^RCDPESR9(X) - ;;35^1^PPS-Operating Fed Specific DRG Amt^S Y=$$ZERO^RCDPESR9(X,1,1) - ;;35^1^Claim PPS Capital Outlier Amt^S Y=$$ZERO^RCDPESR9(X,1,1) - ;;35^1^Claim Indirect Teaching Amt^S Y=$$ZERO^RCDPESR9(X,1,1) - ;;35^1^Non-payable Professional Component Amt^S Y=$$ZERO^RCDPESR9(X,1,1) - ;;35^1^PPS-Capital Exception Amt^S Y=$$ZERO^RCDPESR9(X,1,1) - ;;35^1^Outpatient Reimbursement %^S Y=$$ZERO^RCDPESR9(X) - ;;35^1^HCPCS Payable Amount^S Y=$$ZERO^RCDPESR9(X,1,1) - ;;35^1^ESRD Paid Amount^S Y=$$ZERO^RCDPESR9(X,1,1) - ;;35^1^Non-payable Professional Component^S Y=$$ZERO^RCDPESR9(X,1,1) - ; -37 ;;CLAIM LEVEL MEDICARE ADJUDICATION DATA REMARKS - ;;37^^Line Type^S Y=X_" (CLAIM LEVEL MEDICARE ADJUDICATION DATA REMARKS)" - ;;37^^Bill # - ;;37^^Type^S Y=$S(X="O":"MOA",X="I":"MIA",1:X) - ;;37^^Claim Payment Remark Code - ;;37^^Claim Payment Remark Code Message Text - ; -40 ;;SERVICE LINE DATA - ;;40^^Line Type^S Y=X_" (CLAIM LEVEL SERVICE LINE DATA)" - ;;40^^Bill # - ;;40^^Procedure - ;;40^^Revenue Code - ;;40^^Modifier 1 - ;;40^^Modifier 2 - ;;40^^Modifier 3 - ;;40^^Modifier 4 - ;;40^^Description - ;;40^^Original Procedure - ;;40^^Original Modifier 1 - ;;40^^Original Modifier 2 - ;;40^^Original Modifier 3 - ;;40^^Original Modifier 4 - ;;40^^Original Charge^S Y=$$ZERO^RCDPESR9(X,1) - ;;40^^Original Units^S Y=$$ZERO^RCDPESR9(X,1) - ;;40^^Amount Paid^S Y=$$ZERO^RCDPESR9(X,1) - ;;40^^Covered Units^S Y=$$ZERO^RCDPESR9(X,1) - ;;40^^Service From Date^S Y=$$FDT^RCDPESR9(X) - ;;40^^Service To Date^S Y=$$FDT^RCDPESR9(X) - ;;40^^Procedure Type - ;;40^^Applies to Billing Line - ; -41 ;;SERVICE LINE DATA - ;;41^^Line Type^S Y=X_" (CLAIM LEVEL SERVICE LINE DATA (CONTINUED))" - ;;41^^Bill # - ;;41^^Allowed Amount^S Y=$$ZERO^RCDPESR9(X,1) - ;;41^1^Per Diem Amount^S Y=$$ZERO^RCDPESR9(X,1,1) - ; -42 ; SERVICE LINE DATA - ;;42^^Line Type^S Y=X_" (CLAIM LEVEL SERVICE LINE DATA (CONTINUED))" - ;;42^^Bill # - ;;42^^Line Item Remark Code - ;;42^^Line Item Remark Code Text - ; -45 ;;SERVICE LINE ADJUSTMENT DATA - ;;45^^Line Type^S Y=X_" (CLAIM LEVEL SERVICE LINE ADJUSTMENT DATA)" - ;;45^^Bill # - ;;45^^Adjustment Group Code - ;;45^^Adjustment Reason Code - ;;45^^Adjustment Amount^S Y=$$ZERO^RCDPESR9(X,1) - ;;45^^Quantity^S Y=$$ZERO^RCDPESR9(X) - ;;45^^Reason Code Text - ; -FDT(X) ; returns MM/DD/YYYY or MM/DD/YY from YYYYMMDD or YYMMDD in X - I $L(X)=8,X?8N S X=$E(X,5,6)_"/"_$E(X,7,8)_"/"_$E(X,1,4) - I $L(X)=6,X?6N S X=$E(X,3,4)_"/"_$E(X,5,6)_"/"_$E(X,1,2) - Q X - ; -ZERO(X,D,NULL) ; Returns numeric value of X without leading 0's - ; or null if no value wanted for 0 amount - ; D = 1 if dollar amt - N Z - I X["." S Z=$P(X,"."),X=+Z_"."_$P(X,".",2) - I X'["." D - . I $G(D) S X=+$E(X,1,$L(X)-2)_"."_$E(X,$L(X)-1,$L(X)) - . S X=$S('$G(D):+X,1:$J(X,"",2)) - Q $S(X:X,$G(NULL):"",1:X) - ; -YN(X) ; Returns YES for X="Y" and NO for X="N" - S X=$S(X="Y":"YES",X="N":"NO",1:X) - Q X - ; +RCDPESR9 ;ALB/TMK - ERA return file field captions ;09-SEP-2003 + ;;4.5;Accounts Receivable;**173**;Mar 20, 1995 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; + ; Note: if the 835 flat file changes, make the corresponding changes + ; in this routine. +835 ;;HEADER DATA + ;;835^^Return Message ID^S Y=X_" (ERA HEADER DATA)" + ;;835^^X12/Proprietary flag^S Y=$S(X="X":"X12",1:X) + ;;835^^File Date^S Y=$$FDT^RCDPESR9(X) + ;;835^^File Time^S Y=$E(X,1,2)-$S($E(X,1,2)>12:12,1:0)_":"_$E(X,3,4)_$S($E(X,1,2)=24:" AM",$E(X,1,2)>11:" PM",1:" AM") + ;;835^1^MRA^S Y="" + ;;835^^Payer Name + ;;835^^Payer ID + ;;835^^Trace Number + ;;835^^Date Claims Paid^S Y=$$FDT^RCDPESR9(X) + ;;835^^Total ERA Amount^S Y=$$ZERO^RCDPESR9(X,1) + ;;835^^Erroneous Provider Tax ID + ;;835^^Tax ID correction Flag^S Y=$S(X="E":"CHANGED BY EPHRA",X="C":"DETERMINED FROM CLAIM DATA",X="":"NO CHANGE MADE",1:X) + ;;835^^Sequence Control # + ;;835^^Sequence # + ;;835^^Last Sequence # + ;;835^^Contact Information + ;;835^^Payment Method Code + ; +01 ;;PAYER CONTACT INFORMATION + ;;01^^ERA Contact Name + ;;01^^ERA Contact #1 + ;;01^^ERA Contact #1 Type^S Y=$$EXTERNAL^DILFD(344.4,3.03,,X) + ;;01^^ERA Contact #2 + ;;01^^ERA Contact #2 Type^S Y=$$EXTERNAL^DILFD(344.4,3.05,,X) + ;;01^^ERA Contact #3 + ;;01^^ERA Contact #3 Type^S Y=$$EXTERNAL^DILFD(344.4,3.07,,X) + ; +02 ;;PAYER ADJUSTMENT RECORD + ;;02^^Line Type^S Y=X_" (ERA LEVEL PAYER ADJUSTMENT RECORD)" + ;;02^^X12 Adjustment Reason Code + ;;02^^Provider Adjustment Identifier + ;;02^^Adjustment Amount^S Y=$$ZERO^RCDPESR9(X,1) + ;;02^^X12 Reason Text + ; +05 ;;CLAIM PATIENT ID + ;;05^^Line Type^S Y=X_" (CLAIM LEVEL PATIENT ID DATA)" + ;;05^^Bill # + ;;05^^Patient Last Name + ;;05^^Patient First Name + ;;05^^Patient Middle Name + ;;05^^Patient ID # + ;;05^1^Record Contains Patient Name Change^S Y="" + ;;05^1^Record Contains Patient ID Change^S Y="" + ;;05^^Statement Start Date^S Y=$$FDT^RCDPESR9(X) + ;;05^^Statement End Date^S Y=$$FDT^RCDPESR9(X) + ; +10 ;;CLAIM STATUS DATA + ;;10^^Line Type^S Y=X_" (CLAIM LEVEL CLAIM STATUS DATA)" + ;;10^^Bill # + ;;10^^Claim Processed^S Y=$$YN^RCDPESR9(X) + ;;10^^Claim Denied^S Y=$$YN^RCDPESR9(X) + ;;10^^Claim Pended^S Y=$$YN^RCDPESR9(X) + ;;10^^Claim Reversal^S Y=$$YN^RCDPESR9(X) + ;;10^^Claim Status Code + ;;10^1^Crossed Over Name^S Y="" + ;;10^1^Crossed Over ID^S Y="" + ;;10^^Submitted Charge^S Y=$$ZERO^RCDPESR9(X,1) + ;;10^^Amount Paid^S Y=$$ZERO^RCDPESR9(X,1) + ;;10^^ICN + ;;10^^DRG Code Used + ;;10^^DRG Weight Used^S Y=$J($$ZERO^RCDPESR9(X,1)/100,4) + ;;10^^Discharge Fraction^S Y=$$ZERO^RCDPESR9(X,1) + ; +15 ;;CLAIM STATUS DATA + ;;15^^Line Type^S Y=X_" (CLAIM LEVEL CLAIM STATUS DATA (CONTINUED))" + ;;15^^Bill # + ;;15^^Covered Amount^S Y=$$ZERO^RCDPESR9(X,1) + ;;15^1^Discount Amount^S Y=$$ZERO^RCDPESR9(X,1,1) + ;;15^1^Day Limit Amt^S Y=$$ZERO^RCDPESR9(X,1,1) + ;;15^1^Interest Amount^S Y=$$ZERO^RCDPESR9(X,1,1) + ;;15^1^Tax Amount^S Y=$$ZERO^RCDPESR9(X,1,1) + ;;15^1^Total Before Taxes Amt^S Y=$$ZERO^RCDPESR9(X,1,1) + ;;15^^Patient Responsibility Amount^S Y=$$ZERO^RCDPESR9(X,1) + ;;15^1^Negative Reimbursement^S Y=$$ZERO^RCDPESR9(X,1,1) + ; +17 ;;CLAIM LEVEL PAYER CONTACT INFORMATION + ;;17^^Line Type^S Y=X_" (CLAIM LEVEL PAYER CONTACT INFO)" + ;;17^^Bill # + ;;17^^Contact Name + ;;17^^Contact #1 + ;;17^^Contact #1 Type^S Y=$$EXTERNAL^DILFD(361.1,25.03,,X) + ;;17^^Contact #2 + ;;17^^Contact #2 Type^S Y=$$EXTERNAL^DILFD(361.1,25.05,,X) + ;;17^^Contact #3 + ;;17^^Contact #3 Type^S Y=$$EXTERNAL^DILFD(361.1,25.07,,X) + ; +20 ;;CLAIM LEVEL ADJUSTMENT DATA + ;;20^^Line Type^S Y=X_" (CLAIM LEVEL CLAIM ADJUSTMENT DATA)" + ;;20^^Bill # + ;;20^^Adjustment Group Code + ;;20^^Adjustment Reason Code + ;;20^^Adjustment Amount^S Y=$$ZERO^RCDPESR9(X,1) + ;;20^^Quantity^S Y=$$ZERO^RCDPESR9(X) + ;;20^^Reason Code Text + ; +30 ;;CLAIM LEVEL MEDICARE INPT ADJUDICATION DATA + ;;30^^Line Type^S Y=X_" (CLAIM LEVEL MEDICARE INPATIENT ADJUDICATION DATA)" + ;;30^^Bill # + ;;30^^Covered Days/Visits^S Y=$$ZERO^RCDPESR9(X) + ;;30^1^Lifetime Reserve Days Count^S Y=$$ZERO^RCDPESR9(X,,1) + ;;30^1^Lifetime Psych Days Count^S Y=$$ZERO^RCDPESR9(X,,1) + ;;30^^Claim DRG Amt^S Y=$$ZERO^RCDPESR9(X,1) + ;;30^1^Claim Disproportionate Share Amt^S Y=$$ZERO^RCDPESR9(X,1,1) + ;;30^1^Claim MSP Pass thru Amt^S Y=$$ZERO^RCDPESR9(X,1,1) + ;;30^1^Claim PPS Capital Amt^S Y=$$ZERO^RCDPESR9(X,1,1) + ;;30^1^PPS-Capital FSP DRG Amt^S Y=$$ZERO^RCDPESR9(X,1,1) + ;;30^1^PPS-Capital HSP DRG Amt^S Y=$$ZERO^RCDPESR9(X,1,1) + ;;30^1^PPS-Capital DSH DRG Amt^S Y=$$ZERO^RCDPESR9(X,1,1) + ;;30^1^Old Capital Amt^S Y=$$ZERO^RCDPESR9(X,1,1) + ;;30^^Non-Covered Days^S Y=$$ZERO^RCDPESR9(X) + ; +35 ;;CLAIM LEVEL MEDICARE ADJUDICATION DATA + ;;35^^Line Type^S Y=X_" (CLAIM LEVEL MEDICARE ADJUDICATION DATA)" + ;;35^^Bill # + ;;35^1^PPS-Capital IME Amt^S Y=$$ZERO^RCDPESR9(X,1,1) + ;;35^1^PPS-Operating Hosp Specific DRG Amt^S Y=$$ZERO^RCDPESR9(X,1,1) + ;;35^1^Cost Report Day Count^S Y=$$ZERO^RCDPESR9(X) + ;;35^1^PPS-Operating Fed Specific DRG Amt^S Y=$$ZERO^RCDPESR9(X,1,1) + ;;35^1^Claim PPS Capital Outlier Amt^S Y=$$ZERO^RCDPESR9(X,1,1) + ;;35^1^Claim Indirect Teaching Amt^S Y=$$ZERO^RCDPESR9(X,1,1) + ;;35^1^Non-payable Professional Component Amt^S Y=$$ZERO^RCDPESR9(X,1,1) + ;;35^1^PPS-Capital Exception Amt^S Y=$$ZERO^RCDPESR9(X,1,1) + ;;35^1^Outpatient Reimbursement %^S Y=$$ZERO^RCDPESR9(X) + ;;35^1^HCPCS Payable Amount^S Y=$$ZERO^RCDPESR9(X,1,1) + ;;35^1^ESRD Paid Amount^S Y=$$ZERO^RCDPESR9(X,1,1) + ;;35^1^Non-payable Professional Component^S Y=$$ZERO^RCDPESR9(X,1,1) + ; +37 ;;CLAIM LEVEL MEDICARE ADJUDICATION DATA REMARKS + ;;37^^Line Type^S Y=X_" (CLAIM LEVEL MEDICARE ADJUDICATION DATA REMARKS)" + ;;37^^Bill # + ;;37^^Type^S Y=$S(X="O":"MOA",X="I":"MIA",1:X) + ;;37^^Claim Payment Remark Code + ;;37^^Claim Payment Remark Code Message Text + ; +40 ;;SERVICE LINE DATA + ;;40^^Line Type^S Y=X_" (CLAIM LEVEL SERVICE LINE DATA)" + ;;40^^Bill # + ;;40^^Procedure + ;;40^^Revenue Code + ;;40^^Modifier 1 + ;;40^^Modifier 2 + ;;40^^Modifier 3 + ;;40^^Modifier 4 + ;;40^^Description + ;;40^^Original Procedure + ;;40^^Original Modifier 1 + ;;40^^Original Modifier 2 + ;;40^^Original Modifier 3 + ;;40^^Original Modifier 4 + ;;40^^Original Charge^S Y=$$ZERO^RCDPESR9(X,1) + ;;40^^Original Units^S Y=$$ZERO^RCDPESR9(X,1) + ;;40^^Amount Paid^S Y=$$ZERO^RCDPESR9(X,1) + ;;40^^Covered Units^S Y=$$ZERO^RCDPESR9(X,1) + ;;40^^Service From Date^S Y=$$FDT^RCDPESR9(X) + ;;40^^Service To Date^S Y=$$FDT^RCDPESR9(X) + ;;40^^Procedure Type + ;;40^^Applies to Billing Line + ; +41 ;;SERVICE LINE DATA + ;;41^^Line Type^S Y=X_" (CLAIM LEVEL SERVICE LINE DATA (CONTINUED))" + ;;41^^Bill # + ;;41^^Allowed Amount^S Y=$$ZERO^RCDPESR9(X,1) + ;;41^1^Per Diem Amount^S Y=$$ZERO^RCDPESR9(X,1,1) + ; +42 ; SERVICE LINE DATA + ;;42^^Line Type^S Y=X_" (CLAIM LEVEL SERVICE LINE DATA (CONTINUED))" + ;;42^^Bill # + ;;42^^Line Item Remark Code + ;;42^^Line Item Remark Code Text + ; +45 ;;SERVICE LINE ADJUSTMENT DATA + ;;45^^Line Type^S Y=X_" (CLAIM LEVEL SERVICE LINE ADJUSTMENT DATA)" + ;;45^^Bill # + ;;45^^Adjustment Group Code + ;;45^^Adjustment Reason Code + ;;45^^Adjustment Amount^S Y=$$ZERO^RCDPESR9(X,1) + ;;45^^Quantity^S Y=$$ZERO^RCDPESR9(X) + ;;45^^Reason Code Text + ; +FDT(X) ; returns MM/DD/YYYY or MM/DD/YY from YYYYMMDD or YYMMDD in X + I $L(X)=8,X?8N S X=$E(X,5,6)_"/"_$E(X,7,8)_"/"_$E(X,1,4) + I $L(X)=6,X?6N S X=$E(X,3,4)_"/"_$E(X,5,6)_"/"_$E(X,1,2) + Q X + ; +ZERO(X,D,NULL) ; Returns numeric value of X without leading 0's + ; or null if no value wanted for 0 amount + ; D = 1 if dollar amt + N Z + I X["." S Z=$P(X,"."),X=+Z_"."_$P(X,".",2) + I X'["." D + . I $G(D) S X=+$E(X,1,$L(X)-2)_"."_$E(X,$L(X)-1,$L(X)) + . S X=$S('$G(D):+X,1:$J(X,"",2)) + Q $S(X:X,$G(NULL):"",1:X) + ; +YN(X) ; Returns YES for X="Y" and NO for X="N" + S X=$S(X="Y":"YES",X="N":"NO",1:X) + Q X + ; diff --git a/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPEWL0.m b/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPEWL0.m index 7ac814c9..6a0e455d 100644 --- a/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPEWL0.m +++ b/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPEWL0.m @@ -1,214 +1,212 @@ -RCDPEWL0 ;ALB/TMK - ELECTRONIC EOB WORKLIST ACTIONS ;06 Jun 2007 11:50 AM - ;;4.5;Accounts Receivable;**173,208,252**;Mar 20, 1995;Build 63 - ;;Per VHA Directive 2004-038, this routine should not be modified. - Q - ; -PARAMS ; Select params for ERA list - ; Return ^TMP("RCERA_PARAMS",$J) array - N DIR,X,Y,RCDFR,RCDTO,RCPAYR,RCQUIT,DUOUT,DTOUT - K ^TMP("RCERA_PARAMS",$J) - S RCQUIT=0 - W !!,"SELECT PARAMETERS FOR DISPLAYING THE LIST OF ERAs" - S DIR(0)="SA^U:UNPOSTED;P:POSTED;B:BOTH",DIR("B")="UNPOSTED",DIR("A")="ERA POSTING STATUS: " W ! D ^DIR K DIR - I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 G PARAMSQ - S ^TMP("RCERA_PARAMS",$J,"RCPOST")=Y - S DIR(0)="SA^N:NOT MATCHED;M:MATCHED;B:BOTH",DIR("B")="BOTH",DIR("A")="ERA-EFT MATCH STATUS: " W ! D ^DIR K DIR - I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 G PARAMSQ - S ^TMP("RCERA_PARAMS",$J,"RCMATCH")=Y - ; -DT1 S RCDTO=DT,RCDFR=0 - S RCQUIT=0,DIR(0)="YA",DIR("A")="LIMIT THE SELECTION TO A DATE RANGE WHEN THE ERA WAS RECEIVED?: ",DIR("B")="NO" W ! D ^DIR K DIR - I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 G PARAMSQ - I Y=1 S RCQUIT=0 D I RCQUIT K ^TMP("RCERA_PARAMS",$J,"RCDT") G DT1 - . S DIR(0)="DA",DIR("A")="EARLIEST DATE: " D ^DIR K DIR - . I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 Q - . S RCDFR=Y - . S DIR(0)="DA^"_RCDFR_";"_DT,DIR("A")="LATEST DATE: " D ^DIR K DIR - . I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 Q - . S RCDTO=Y - S ^TMP("RCERA_PARAMS",$J,"RCDT")=(RCDFR_U_RCDTO) - ; -PAYR S RCQUIT=0,DIR(0)="SA^A:ALL;R:RANGE",DIR("A")="(A)LL PAYERS, (R)ANGE OF PAYER NAMES: ",DIR("B")="ALL" W ! D ^DIR K DIR - I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 G PARAMSQ - S RCPAYR=Y,^TMP("RCERA_PARAMS",$J,"RCPAYR")=Y - I RCPAYR="A" G PARAMSQ - I RCPAYR="R" D I RCQUIT K ^TMP("RCERA_PARAMS",$J,"RCPAYR") G PAYR - . W !,"NAMES YOU SELECT HERE WILL BE THE PAYER NAMES FROM THE ERA, NOT THE INS FILE" - . S DIR("?")="ENTER A NAME BETWEEN 1 AND 30 CHARACTERS IN UPPERCASE" - . S DIR(0)="FA^1:30^K:X'?.U X",DIR("A")="START WITH PAYER NAME: " W ! D ^DIR K DIR - . I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 Q - . S RCPAYR("FROM")=Y,$P(^TMP("RCERA_PARAMS",$J,"RCPAYR"),U,2)=Y - . S DIR("?")="ENTER A NAME BETWEEN 1 AND 30 CHARACTERS IN UPPERCASE" - . S DIR(0)="FA^1:30^K:X'?.U X",DIR("A")="GO TO PAYER NAME: ",DIR("B")=$E(RCPAYR("FROM"),1,27)_"ZZZ" W ! D ^DIR K DIR - . I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 Q - . S $P(^TMP("RCERA_PARAMS",$J,"RCPAYR"),U,3)=Y - W ! - ; -PARAMSQ ; - D PARAMS^RCDPEWLD(.RCQUIT) - Q - ; -FILTER(Y) ; Returns 1 if record in entry Y in 344.4 passes - ; the edits for the worklist selection of ERAs - ; Parameters found in ^TMP("RCERA_PARAMS",$J) - N OK,RCPOST,RCMATCH,RCDFR,RCDTO,RCPAYFR,RCPAYTO,RCPAYR,RC0 - S OK=1,RC0=$G(^RCY(344.4,Y,0)) - ; - S RCMATCH=$G(^TMP("RCERA_PARAMS",$J,"RCMATCH")),RCPOST=$G(^TMP("RCERA_PARAMS",$J,"RCPOST")) - S RCDFR=+$P($G(^TMP("RCERA_PARAMS",$J,"RCDT")),U),RCDTO=+$P($G(^TMP("RCERA_PARAMS",$J,"RCDT")),U,2) - S RCPAYR=$P($G(^TMP("RCERA_PARAMS",$J,"RCPAYR")),U),RCPAYFR=$P($G(^TMP("RCERA_PARAMS",$J,"RCPAYR")),U,2),RCPAYTO=$P($G(^TMP("RCERA_PARAMS",$J,"RCPAYR")),U,3) - ; - ; If receipt exists, scratchpad must exist - ;I $P(RC0,U,8),'$D(^RCY(344.49,+Y,0)) S OK=0 G FQ - ; Post status - I $S(RCPOST="B":0,RCPOST="U":$P(RC0,U,14),1:'$P(RC0,U,14)) S OK=0 G FQ - ; Match status - I $S(RCMATCH="B":0,RCMATCH="N":$P(RC0,U,9),1:'$P(RC0,U,9)) S OK=0 G FQ - ; dt rec'd range - I $S(RCDFR=0:0,1:$P(RC0,U,7)\1RCDTO) S OK=0 G FQ - ; Payer name - I RCPAYR'="A" D G:'OK FQ - . N Q - . S Q=$$UPPER^RCDPEWL7($P(RC0,U,6)) - . I $S(Q=RCPAYFR:1,Q=RCPAYTO:1,Q]RCPAYFR:RCPAYTO]Q,1:0) Q - . S OK=0 -FQ Q OK - ; -SPLIT ; Split line in ERA list - N RCLINE,RCZ,RCDA,Q,Q0,Z,Z0,DIR,X,Y,CT,L,L1,RCONE,RCQUIT - D FULL^VALM1 - I $G(RCSCR("NOEDIT")) D NOEDIT^RCDPEWL G SPLITQ - W !!,"SELECT THE ENTRY THAT HAS A LINE YOU NEED TO SPLIT/EDIT",! - D SEL^RCDPEWL(.RCDA) - S Z=+$O(RCDA(0)) G:'$G(RCDA(Z)) SPLITQ - S RCLINE=+RCDA(Z),Z0=+$O(^TMP("RCDPE-EOB_WLDX",$J,Z_".999"),-1) - S RCZ=Z F S RCZ=$O(^TMP("RCDPE-EOB_WLDX",$J,RCZ)) Q:'RCZ!(RCZ\1'=Z) D - . S Q=$P($G(^TMP("RCDPE-EOB_WLDX",$J,RCZ)),U,2) - . Q:'Q - . S RCZ(RCZ)=Q - . S Q0=0 F S Q0=$O(^RCY(344.49,RCSCR,1,Q,1,Q0)) Q:'Q0 I "01"[$P($G(^(Q0,0)),U,2) K RCZ(RCZ) Q - I '$O(RCZ(0)) D G SPLITQ - . S DIR(0)="EA",DIR("A",1)="THIS ENTRY HAS NO LINES AVAILABLE TO EDIT/SPLIT",DIR("A")="PRESS RETURN TO CONTINUE " W ! D ^DIR K DIR - S RCQUIT=0 - I $P($G(^RCY(344.49,RCSCR,1,RCLINE,0)),U,13) D G:RCQUIT SPLITQ - . S DIR("A",1)="WARNING! THIS LINE HAS ALREADY BEEN VERIFIED",DIR("A")="ARE YOU SURE YOU WANT TO CONTINUE?: ",DIR(0)="YA",DIR("B")="NO" W ! D ^DIR K DIR - . I Y'=1 S RCQUIT=1 - S CT=0,CT=CT+1,DIR("?",CT)="Enter the line # that you want to split or edit:",RCONE=1 - S L=Z F S L=$O(RCZ(L)) Q:'L D - . S L1=+$G(^TMP("RCDPE-EOB_WLDX",$J,L)) - . S CT=CT+1 - . S DIR("?",CT)=$G(^TMP("RCDPE-EOB_WL",$J,L1,0)),CT=CT+1,DIR("?",CT)=$G(^TMP("RCDPE-EOB_WL",$J,L1+1,0)) S RCONE(1)=$S(RCONE:L,1:"") S RCONE=0 - S DIR("?")=" ",Y=-1 - I $G(RCONE(1)) S Y=+RCONE(1) K DIR G:'Y SPLITQ - I '$G(RCONE(1)) D K DIR I $D(DTOUT)!$D(DUOUT)!(Y\1'=Z) G SPLITQ - . F S DIR(0)="NAO^"_(Z+.001)_":"_Z0_":3",DIR("A")="WHICH LINE OF ENTRY "_Z_" DO YOU WANT TO SPLIT/EDIT?: " S:$G(RCONE(1))'="" DIR("B")=RCONE(1) D ^DIR Q:'Y!$D(DUOUT)!$D(DTOUT) D Q:Y>0 - .. I '$D(^TMP("RCDPE-EOB_WLDX",$J,Y)) W !!,"LINE "_Y_" DOES NOT EXIST - TRY AGAIN",! S Y=-1 Q - .. I '$D(RCZ(Y)) W !!,"LINE "_Y_" HAS BEEN USED IN A DISTRIBUTE ADJ ACTION AND CAN'T BE EDITED",! S Y=-1 Q - .. S Q=+$O(^RCY(344.49,RCSCR,1,"B",Y,0)) - ; - K ^TMP("RCDPE_SPLIT_REBLD",$J) - D SPLIT^RCDPEWL3(RCSCR,+Y) - I $G(^TMP("RCDPE_SPLIT_REBLD",$J)) K ^TMP("RCDPE_SPLIT_REBLD",$J) D BLD^RCDPEWL1($G(^TMP($J,"RC_SORTPARM"))) - ; -SPLITQ S VALMBCK="R" - Q - ; -PRTERA ; View/prt - N DIC,X,Y,RCSCR - S DIC="^RCY(344.4,",DIC(0)="AEMQ" D ^DIC - Q:Y'>0 - S RCSCR=+Y - D PRERA1 - Q - ; -PRERA ; RCSCR is assumed to be defined - D FULL^VALM1 ; Protocol entry -PRERA1 ; Option entry - N %ZIS,ZTRTN,ZTSAVE,ZTDESC,POP,DIR,X,Y,RCERADET - S DIR("?",1)="INCLUDING EXPANDED DETAIL WILL SIGNIFICANTLY INCREASE THE SIZE OF THIS REPORT",DIR("?",2)="IF YOU CHOOSE TO INCLUDE IT, ALL PAYMENT DETAILS FOR EACH EEOB WILL BE" - S DIR("?")="LISTED. IF YOU WANT JUST SUMMARY DATA FOR EACH EEOB, DO NOT INCLUDE IT." - S DIR(0)="YA",DIR("A")="DO YOU WANT TO INCLUDE EXPANDED EEOB DETAIL?: ",DIR("B")="NO" W ! D ^DIR K DIR - I $D(DUOUT)!$D(DTOUT) G PRERAQ - S RCERADET=+Y - S %ZIS="QM" D ^%ZIS G:POP PRERAQ - I $D(IO("Q")) D G PRERAQ - . S ZTRTN="VPERA^RCDPEWL0("_RCSCR_","_RCERADET_")",ZTDESC="AR - Print ERA From Worklist" - . D ^%ZTLOAD - . W !!,$S($D(ZTSK):"Your task # "_ZTSK_" has been queued.",1:"Unable to queue this job.") - . K ZTSK,IO("Q") D HOME^%ZIS - U IO - D VPERA(RCSCR,RCERADET) - Q - ; -VPERA(RCSCR,RCERADET) ; Queued entry - ; RCSCR = ien of entry in file 344.4 - ; RCERADET = 1 if inclusion of all EOB details from file 361.1 is - ; desired, 0 if not - N Z,Z0,RCSTOP,RCZ,RCPG,RCDOT,RCDIQ,RCDIQ1,RCDIQ2,RCXM1,RC,RCSCR1,RC3611 - K ^TMP($J,"RC_SUMRAW"),^TMP($J,"RC_SUMOUT"),^TMP($J,"RC_SUMALL") - S (RCSTOP,RCPG)=0,RCDOT="",$P(RCDOT,".",79)="" - D GETS^DIQ(344.4,RCSCR_",","*","IEN","RCDIQ") - D TXT0^RCDPEX31(RCSCR,.RCDIQ,.RCXM1,.RC) ; Get top level 0-node captioned flds - I $O(^RCY(344.4,RCSCR,2,0)) S RC=RC+1,RCXM1(RC)=" **ERA LEVEL ADJUSTMENTS**" - S RCSCR1=0 F S RCSCR1=$O(^RCY(344.4,RCSCR,2,RCSCR1)) Q:'RCSCR1 D - . K RCDIQ2 - . D GETS^DIQ(344.42,RCSCR1_","_RCSCR_",","*","IEN","RCDIQ2") - . D TXT2^RCDPEX31(RCSCR,RCSCR1,.RCDIQ2,.RCXM1,.RC) ; Get top level ERA adjs - S RCSCR1=0 F S RCSCR1=$O(^RCY(344.4,RCSCR,1,RCSCR1)) Q:'RCSCR1 D - . K RCDIQ1 - . D GETS^DIQ(344.41,RCSCR1_","_RCSCR_",","*","IEN","RCDIQ1") - . D TXT00^RCDPEX31(RCSCR,RCSCR1,.RCDIQ1,.RCXM1,.RC) - . S RC=RC+1,RCXM1(RC-1)=$E("PATIENT: "_$$PNM4^RCDPEWL1(RCSCR,RCSCR1)_$J("",41),1,41)_"CLAIM #: "_$$BILLREF^RCDPESR0(RCSCR,RCSCR1),RCXM1(RC)=" " - . D PROV^RCDPEWLD(RCSCR,RCSCR1,.RCXM1,.RC) - . S RC3611=$P($G(^RCY(344.4,RCSCR,1,RCSCR1,0)),U,2) - . I RCERADET D - .. I 'RC3611 D Q - ... D DISP^RCDPESR0("^RCY(344.4,"_RCSCR_",1,"_RCSCR1_",1)","^TMP($J,""RC_SUMRAW"")",1,"^TMP($J,""RC_SUMOUT"")",75,1) - ..; - .. E D ; Detail record is in 361.1 - ... K ^TMP("PRCA_EOB",$J) - ... D GETEOB^IBCECSA6(RC3611,2) - ... I $O(^IBM(361.1,RC3611,"ERR",0)) D GETERR^RCDPEDS(RC3611,+$O(^TMP("PRCA_EOB",$J,RC3611," "),-1)) ; get filing errors - ... S Z=0 F S Z=$O(^TMP("PRCA_EOB",$J,RC3611,Z)) Q:'Z S RC=RC+1,^TMP($J,"RC_SUMOUT",RC)=$G(^TMP("PRCA_EOB",$J,RC3611,Z)) - ... S RC=RC+2,^TMP($J,"RC_SUMOUT",RC-1)=" ",^TMP($J,"RC_SUMOUT",RC)=" " - ... K ^TMP("PRCA_EOB",$J) - . I $D(RCDIQ1(344.41,RCSCR1_","_RCSCR_",",2)) D - .. S RC=RC+1,RCXM1(RC)=" **EXCEPTION RESOLUTION LOG DATA**" - .. S Z=0 F S Z=$O(RCDIQ1(344.41,RCSCR1_","_RCSCR_",",2,Z)) Q:'Z S RC=RC+1,RCXM1(RC)=RCDIQ1(344.41,RCSCR1_","_RCSCR_",",2,Z) - . S RC=RC+1,RCXM1(RC)=" " - . S Z0=+$O(^TMP($J,"RC_SUMALL"," "),-1) - . S Z=0 F S Z=$O(RCXM1(Z)) Q:'Z S Z0=Z0+1,^TMP($J,"RC_SUMALL",Z0)=RCXM1(Z) - . K RCXM1 S RC=0 - . S Z=0 F S Z=$O(^TMP($J,"RC_SUMOUT",Z)) Q:'Z S Z0=Z0+1,^TMP($J,"RC_SUMALL",Z0)=$G(^TMP($J,"RC_SUMOUT",Z)) - S RCSTOP=0,Z="" - F S Z=$O(^TMP($J,"RC_SUMALL",Z)) Q:'Z D Q:RCSTOP - . I $D(ZTQUEUED),$$S^%ZTLOAD S (RCSTOP,ZTSTOP)=1 K ZTREQ I +$G(RCPG) W !!,"***TASK STOPPED BY USER***" Q - . I 'RCPG!(($Y+5)>IOSL) D I RCSTOP Q - .. D:RCPG ASK(.RCSTOP) I RCSTOP Q - .. D HDR(.RCPG) - . W !,$G(^TMP($J,"RC_SUMALL",Z)) - ; - I 'RCSTOP,RCPG D ASK(.RCSTOP) - ; - I $D(ZTQUEUED) S ZTREQ="@" - I '$D(ZTQUEUED) D ^%ZISC - ; -PRERAQ K ^TMP($J,"RC_SUMRAW"),^TMP($J,"RC_SUMOUT"),^TMP($J,"SUMALL") - S VALMBCK="R" - Q - ; -HDR(RCPG) ;Report hdr - ; RCPG = last page # - I RCPG!($E(IOST,1,2)="C-") W @IOF,*13 - S RCPG=$G(RCPG)+1 - W !,?5,"EDI LOCKBOX WORKLIST - ERA DETAIL",?55,$$FMTE^XLFDT(DT,2),?70,"Page: ",RCPG,!,$TR($J("",IOM)," ","=") - Q - ; -ASK(RCSTOP) ; - I $E(IOST,1,2)'["C-" Q - N DIR,DIROUT,DIRUT,DTOUT,DUOUT - S DIR(0)="E" W ! D ^DIR - I ($D(DIRUT))!($D(DUOUT)) S RCSTOP=1 Q - Q - ; +RCDPEWL0 ;ALB/TMK - ELECTRONIC EOB WORKLIST ACTIONS ;26-NOV-02 + ;;4.5;Accounts Receivable;**173,208**;Mar 20, 1995 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + Q + ; +PARAMS ; Select params for ERA list + ; Return ^TMP("RCERA_PARAMS",$J) array + N DIR,X,Y,RCDFR,RCDTO,RCPAYR,RCQUIT + K ^TMP("RCERA_PARAMS",$J) + S RCQUIT=0 + W !!,"SELECT PARAMETERS FOR DISPLAYING THE LIST OF ERAs" + S DIR(0)="SA^U:UNPOSTED;P:POSTED;B:BOTH",DIR("B")="UNPOSTED",DIR("A")="ERA POSTING STATUS: " W ! D ^DIR K DIR + I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 G PARAMSQ + S ^TMP("RCERA_PARAMS",$J,"RCPOST")=Y + S DIR(0)="SA^N:NOT MATCHED;M:MATCHED;B:BOTH",DIR("B")="BOTH",DIR("A")="ERA-EFT MATCH STATUS: " W ! D ^DIR K DIR + I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 G PARAMSQ + S ^TMP("RCERA_PARAMS",$J,"RCMATCH")=Y + ; +DT1 S RCDTO=DT,RCDFR=0 + S RCQUIT=0,DIR(0)="YA",DIR("A")="LIMIT THE SELECTION TO A DATE RANGE WHEN THE ERA WAS RECEIVED?: ",DIR("B")="NO" W ! D ^DIR K DIR + I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 G PARAMSQ + I Y=1 S RCQUIT=0 D I RCQUIT K ^TMP("RCERA_PARAMS",$J,"RCDT") G DT1 + . S DIR(0)="DA",DIR("A")="EARLIEST DATE: " D ^DIR K DIR + . I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 Q + . S RCDFR=Y + . S DIR(0)="DA^"_RCDFR_";"_DT,DIR("A")="LATEST DATE: " D ^DIR K DIR + . I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 Q + . S RCDTO=Y + S ^TMP("RCERA_PARAMS",$J,"RCDT")=(RCDFR_U_RCDTO) + ; +PAYR S RCQUIT=0,DIR(0)="SA^A:ALL;R:RANGE",DIR("A")="(A)LL PAYERS, (R)ANGE OF PAYER NAMES: ",DIR("B")="ALL" W ! D ^DIR K DIR + I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 G PARAMSQ + S RCPAYR=Y,^TMP("RCERA_PARAMS",$J,"RCPAYR")=Y + I RCPAYR="A" G PARAMSQ + I RCPAYR="R" D I RCQUIT K ^TMP("RCERA_PARAMS",$J,"RCPAYR") G PAYR + . W !,"NAMES YOU SELECT HERE WILL BE THE PAYER NAMES FROM THE ERA, NOT THE INS FILE" + . S DIR("?")="ENTER A NAME BETWEEN 1 AND 30 CHARACTERS IN UPPERCASE" + . S DIR(0)="FA^1:30^K:X'?.U X",DIR("A")="START WITH PAYER NAME: " W ! D ^DIR K DIR + . I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 Q + . S RCPAYR("FROM")=Y,$P(^TMP("RCERA_PARAMS",$J,"RCPAYR"),U,2)=Y + . S DIR("?")="ENTER A NAME BETWEEN 1 AND 30 CHARACTERS IN UPPERCASE" + . S DIR(0)="FA^1:30^K:X'?.U X",DIR("A")="GO TO PAYER NAME: ",DIR("B")=$E(RCPAYR("FROM"),1,27)_"ZZZ" W ! D ^DIR K DIR + . I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 Q + . S $P(^TMP("RCERA_PARAMS",$J,"RCPAYR"),U,3)=Y + W ! + ; +PARAMSQ I $G(RCQUIT) K ^TMP("RCERA_PARAMS",$J) + Q + ; +FILTER(Y) ; Returns 1 if record in entry Y in 344.4 passes + ; the edits for the worklist selection of ERAs + ; Parameters found in ^TMP("RCERA_PARAMS",$J) + N OK,RCPOST,RCMATCH,RCDFR,RCDTO,RCPAYFR,RCPAYTO,RCPAYR,RC0 + S OK=1,RC0=$G(^RCY(344.4,Y,0)) + ; + S RCMATCH=$G(^TMP("RCERA_PARAMS",$J,"RCMATCH")),RCPOST=$G(^TMP("RCERA_PARAMS",$J,"RCPOST")) + S RCDFR=+$P($G(^TMP("RCERA_PARAMS",$J,"RCDT")),U),RCDTO=+$P($G(^TMP("RCERA_PARAMS",$J,"RCDT")),U,2) + S RCPAYR=$P($G(^TMP("RCERA_PARAMS",$J,"RCPAYR")),U),RCPAYFR=$P($G(^TMP("RCERA_PARAMS",$J,"RCPAYR")),U,2),RCPAYTO=$P($G(^TMP("RCERA_PARAMS",$J,"RCPAYR")),U,3) + ; + ; If receipt exists, scratchpad must exist + ;I $P(RC0,U,8),'$D(^RCY(344.49,+Y,0)) S OK=0 G FQ + ; Post status + I $S(RCPOST="B":0,RCPOST="U":$P(RC0,U,14),1:'$P(RC0,U,14)) S OK=0 G FQ + ; Match status + I $S(RCMATCH="B":0,RCMATCH="N":$P(RC0,U,9),1:'$P(RC0,U,9)) S OK=0 G FQ + ; dt rec'd range + I $S(RCDFR=0:0,1:$P(RC0,U,7)\1RCDTO) S OK=0 G FQ + ; Payer name + I RCPAYR'="A" D G:'OK FQ + . N Q + . S Q=$$UPPER^RCDPEWL7($P(RC0,U,6)) + . I $S(Q=RCPAYFR:1,Q=RCPAYTO:1,Q]RCPAYFR:RCPAYTO]Q,1:0) Q + . S OK=0 +FQ Q OK + ; +SPLIT ; Split line in ERA list + N RCLINE,RCZ,RCDA,Q,Q0,Z,Z0,DIR,X,Y,CT,L,L1,RCONE,RCQUIT + D FULL^VALM1 + I $G(RCSCR("NOEDIT")) D NOEDIT^RCDPEWL G SPLITQ + W !!,"SELECT THE ENTRY THAT HAS A LINE YOU NEED TO SPLIT/EDIT",! + D SEL^RCDPEWL(.RCDA) + S Z=+$O(RCDA(0)) G:'$G(RCDA(Z)) SPLITQ + S RCLINE=+RCDA(Z),Z0=+$O(^TMP("RCDPE-EOB_WLDX",$J,Z_".999"),-1) + S RCZ=Z F S RCZ=$O(^TMP("RCDPE-EOB_WLDX",$J,RCZ)) Q:'RCZ!(RCZ\1'=Z) D + . S Q=$P($G(^TMP("RCDPE-EOB_WLDX",$J,RCZ)),U,2) + . Q:'Q + . S RCZ(RCZ)=Q + . S Q0=0 F S Q0=$O(^RCY(344.49,RCSCR,1,Q,1,Q0)) Q:'Q0 I "01"[$P($G(^(Q0,0)),U,2) K RCZ(RCZ) Q + I '$O(RCZ(0)) D G SPLITQ + . S DIR(0)="EA",DIR("A",1)="THIS ENTRY HAS NO LINES AVAILABLE TO EDIT/SPLIT",DIR("A")="PRESS RETURN TO CONTINUE " W ! D ^DIR K DIR + S RCQUIT=0 + I $P($G(^RCY(344.49,RCSCR,1,RCLINE,0)),U,13) D G:RCQUIT SPLITQ + . S DIR("A",1)="WARNING! THIS LINE HAS ALREADY BEEN VERIFIED",DIR("A")="ARE YOU SURE YOU WANT TO CONTINUE?: ",DIR(0)="YA",DIR("B")="NO" W ! D ^DIR K DIR + . I Y'=1 S RCQUIT=1 + S CT=0,CT=CT+1,DIR("?",CT)="Enter the line # that you want to split or edit:",RCONE=1 + S L=Z F S L=$O(RCZ(L)) Q:'L D + . S L1=+$G(^TMP("RCDPE-EOB_WLDX",$J,L)) + . S CT=CT+1 + . S DIR("?",CT)=$G(^TMP("RCDPE-EOB_WL",$J,L1,0)),CT=CT+1,DIR("?",CT)=$G(^TMP("RCDPE-EOB_WL",$J,L1+1,0)) S RCONE(1)=$S(RCONE:L,1:"") S RCONE=0 + S DIR("?")=" ",Y=-1 + I $G(RCONE(1)) S Y=+RCONE(1) K DIR G:'Y SPLITQ + I '$G(RCONE(1)) D K DIR I $D(DTOUT)!$D(DUOUT)!(Y\1'=Z) G SPLITQ + . F S DIR(0)="NAO^"_(Z+.001)_":"_Z0_":3",DIR("A")="WHICH LINE OF ENTRY "_Z_" DO YOU WANT TO SPLIT/EDIT?: " S:$G(RCONE(1))'="" DIR("B")=RCONE(1) D ^DIR Q:'Y!$D(DUOUT)!$D(DTOUT) D Q:Y>0 + .. I '$D(^TMP("RCDPE-EOB_WLDX",$J,Y)) W !!,"LINE "_Y_" DOES NOT EXIST - TRY AGAIN",! S Y=-1 Q + .. I '$D(RCZ(Y)) W !!,"LINE "_Y_" HAS BEEN USED IN A DISTRIBUTE ADJ ACTION AND CAN'T BE EDITED",! S Y=-1 Q + .. S Q=+$O(^RCY(344.49,RCSCR,1,"B",Y,0)) + ; + K ^TMP("RCDPE_SPLIT_REBLD",$J) + D SPLIT^RCDPEWL3(RCSCR,+Y) + I $G(^TMP("RCDPE_SPLIT_REBLD",$J)) K ^TMP("RCDPE_SPLIT_REBLD",$J) D BLD^RCDPEWL1($G(^TMP($J,"RC_SORTPARM"))) + ; +SPLITQ S VALMBCK="R" + Q + ; +PRTERA ; View/prt + N DIC,X,Y,RCSCR + S DIC="^RCY(344.4,",DIC(0)="AEMQ" D ^DIC + Q:Y'>0 + S RCSCR=+Y + D PRERA1 + Q + ; +PRERA ; RCSCR is assumed to be defined + D FULL^VALM1 ; Protocol entry +PRERA1 ; Option entry + N %ZIS,ZTRTN,ZTSAVE,ZTDESC,POP,DIR,X,Y,RCERADET + S DIR("?",1)="INCLUDING EXPANDED DETAIL WILL SIGNIFICANTLY INCREASE THE SIZE OF THIS REPORT",DIR("?",2)="IF YOU CHOOSE TO INCLUDE IT, ALL PAYMENT DETAILS FOR EACH EEOB WILL BE" + S DIR("?")="LISTED. IF YOU WANT JUST SUMMARY DATA FOR EACH EEOB, DO NOT INCLUDE IT." + S DIR(0)="YA",DIR("A")="DO YOU WANT TO INCLUDE EXPANDED EEOB DETAIL?: ",DIR("B")="NO" W ! D ^DIR K DIR + I $D(DUOUT)!$D(DTOUT) G PRERAQ + S RCERADET=+Y + S %ZIS="QM" D ^%ZIS G:POP PRERAQ + I $D(IO("Q")) D G PRERAQ + . S ZTRTN="VPERA^RCDPEWL0("_RCSCR_","_RCERADET_")",ZTDESC="AR - Print ERA From Worklist" + . D ^%ZTLOAD + . W !!,$S($D(ZTSK):"Your task # "_ZTSK_" has been queued.",1:"Unable to queue this job.") + . K ZTSK,IO("Q") D HOME^%ZIS + U IO + D VPERA(RCSCR,RCERADET) + Q + ; +VPERA(RCSCR,RCERADET) ; Queued entry + ; RCSCR = ien of entry in file 344.4 + ; RCERADET = 1 if inclusion of all EOB details from file 361.1 is + ; desired, 0 if not + N Z,Z0,RCSTOP,RCZ,RCPG,RCDOT,RCDIQ,RCDIQ1,RCDIQ2,RCXM1,RC,RCSCR1,RC3611 + K ^TMP($J,"RC_SUMRAW"),^TMP($J,"RC_SUMOUT"),^TMP($J,"RC_SUMALL") + S (RCSTOP,RCPG)=0,RCDOT="",$P(RCDOT,".",79)="" + D GETS^DIQ(344.4,RCSCR_",","*","IEN","RCDIQ") + D TXT0^RCDPEX31(RCSCR,.RCDIQ,.RCXM1,.RC) ; Get top level 0-node captioned flds + I $O(^RCY(344.4,RCSCR,2,0)) S RC=RC+1,RCXM1(RC)=" **ERA LEVEL ADJUSTMENTS**" + S RCSCR1=0 F S RCSCR1=$O(^RCY(344.4,RCSCR,2,RCSCR1)) Q:'RCSCR1 D + . K RCDIQ2 + . D GETS^DIQ(344.42,RCSCR1_","_RCSCR_",","*","IEN","RCDIQ2") + . D TXT2^RCDPEX31(RCSCR,RCSCR1,.RCDIQ2,.RCXM1,.RC) ; Get top level ERA adjs + S RCSCR1=0 F S RCSCR1=$O(^RCY(344.4,RCSCR,1,RCSCR1)) Q:'RCSCR1 D + . K RCDIQ1 + . D GETS^DIQ(344.41,RCSCR1_","_RCSCR_",","*","IEN","RCDIQ1") + . D TXT00^RCDPEX31(RCSCR,RCSCR1,.RCDIQ1,.RCXM1,.RC) + . S RC=RC+1,RCXM1(RC-1)=$E("PATIENT: "_$$PNM4^RCDPEWL1(RCSCR,RCSCR1)_$J("",41),1,41)_"CLAIM #: "_$$BILLREF^RCDPESR0(RCSCR,RCSCR1),RCXM1(RC)=" " + . S RC3611=$P($G(^RCY(344.4,RCSCR,1,RCSCR1,0)),U,2) + . I RCERADET D ; Include formatted txt from 361.1 or 344.411 + .. I 'RC3611 D Q ; Formatted raw data + ... D DISP^RCDPESR0("^RCY(344.4,"_RCSCR_",1,"_RCSCR1_",1)","^TMP($J,""RC_SUMRAW"")",1,"^TMP($J,""RC_SUMOUT"")",75,1) + ..; + .. E D ; Detail record is in 361.1 + ... K ^TMP("PRCA_EOB",$J) + ... D GETEOB^IBCECSA6(RC3611,2) + ... I $O(^IBM(361.1,RC3611,"ERR",0)) D GETERR^RCDPEDS(RC3611,+$O(^TMP("PRCA_EOB",$J,RC3611," "),-1)) ; get filing errors + ... S Z=0 F S Z=$O(^TMP("PRCA_EOB",$J,RC3611,Z)) Q:'Z S RC=RC+1,^TMP($J,"RC_SUMOUT",RC)=$G(^TMP("PRCA_EOB",$J,RC3611,Z)) + ... S RC=RC+2,^TMP($J,"RC_SUMOUT",RC-1)=" ",^TMP($J,"RC_SUMOUT",RC)=" " + ... K ^TMP("PRCA_EOB",$J) + . I $D(RCDIQ1(344.41,RCSCR1_","_RCSCR_",",2)) D + .. S RC=RC+1,RCXM1(RC)=" **EXCEPTION RESOLUTION LOG DATA**" + .. S Z=0 F S Z=$O(RCDIQ1(344.41,RCSCR1_","_RCSCR_",",2,Z)) Q:'Z S RC=RC+1,RCXM1(RC)=RCDIQ1(344.41,RCSCR1_","_RCSCR_",",2,Z) + . S RC=RC+1,RCXM1(RC)=" " + . S Z0=+$O(^TMP($J,"RC_SUMALL"," "),-1) + . S Z=0 F S Z=$O(RCXM1(Z)) Q:'Z S Z0=Z0+1,^TMP($J,"RC_SUMALL",Z0)=RCXM1(Z) + . K RCXM1 S RC=0 + . S Z=0 F S Z=$O(^TMP($J,"RC_SUMOUT",Z)) Q:'Z S Z0=Z0+1,^TMP($J,"RC_SUMALL",Z0)=$G(^TMP($J,"RC_SUMOUT",Z)) + S RCSTOP=0,Z="" + F S Z=$O(^TMP($J,"RC_SUMALL",Z)) Q:'Z D Q:RCSTOP + . I $D(ZTQUEUED),$$S^%ZTLOAD S (RCSTOP,ZTSTOP)=1 K ZTREQ I +$G(RCPG) W !!,"***TASK STOPPED BY USER***" Q + . I 'RCPG!(($Y+5)>IOSL) D I RCSTOP Q + .. D:RCPG ASK(.RCSTOP) I RCSTOP Q + .. D HDR(.RCPG) + . W !,$G(^TMP($J,"RC_SUMALL",Z)) + ; + I 'RCSTOP,RCPG D ASK(.RCSTOP) + ; + I $D(ZTQUEUED) S ZTREQ="@" + I '$D(ZTQUEUED) D ^%ZISC + ; +PRERAQ K ^TMP($J,"RC_SUMRAW"),^TMP($J,"RC_SUMOUT"),^TMP($J,"SUMALL") + S VALMBCK="R" + Q + ; +HDR(RCPG) ;Report hdr + ; RCPG = last page # + I RCPG!($E(IOST,1,2)="C-") W @IOF,*13 + S RCPG=$G(RCPG)+1 + W !,?5,"EDI LOCKBOX WORKLIST - ERA DETAIL",?55,$$FMTE^XLFDT(DT,2),?70,"Page: ",RCPG,!,$TR($J("",IOM)," ","=") + Q + ; +ASK(RCSTOP) ; + I $E(IOST,1,2)'["C-" Q + N DIR,DIROUT,DIRUT,DTOUT,DUOUT + S DIR(0)="E" W ! D ^DIR + I ($D(DIRUT))!($D(DUOUT)) S RCSTOP=1 Q + Q + ; diff --git a/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPEX32.m b/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPEX32.m index 2fc9e28c..92c37c31 100644 --- a/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPEX32.m +++ b/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPEX32.m @@ -1,95 +1,95 @@ -RCDPEX32 ;ALB/TMK - ELECTRONIC EOB EXCEPTION PROCESSING - FILE 344.4 ;10-OCT-02 - ;;4.5;Accounts Receivable;**173,249**;Mar 20, 1995;Build 2 - ;;Per VHA Directive 10-93-142, this routine should not be modified. - ; -EDITNUM ; Edit invalid claim # to valid, refile EOB - N RC,RC0,RCDA,RCXDA,RCXDA1,RCSAVE,RCEOB,RCWARN,Q,Q0,DA,DR,DIE,DIC,DIR,X,Y,RCBILL,RCCHG - D FULL^VALM1 - D SEL^RCDPEX3(.RCDA) - G:'$O(RCDA(0)) EDITNQ - ; - S RC=0 F S RC=$O(RCDA(RC)) Q:'RC D L -^RCY(344.4,RCXDA1,1,RCXDA,0) - . S RCXDA1=+RCDA(RC),RCXDA=+$P(RCDA(RC),U,2),RCSAVE="" - . I '$$LOCK^RCDPEX31(RCXDA1,RCXDA,1) D Q - .. S DIR(0)="EA",DIR("A",1)="**Selection #"_RC_" is being edited by another user - ... please try again later",DIR("A")="PRESS RETURN TO CONTINUE" D ^DIR K DIR - . S RC0=$G(^RCY(344.4,RCXDA1,1,RCXDA,0)) - . I $P(RC0,U,5)="" D Q - .. S DIR(0)="EA",DIR("A",1)="The claim for selection #"_RC_" can't be edited as the bill # is not invalid",DIR("A")="PRESS RETURN TO CONTINUE" D ^DIR K DIR - . I $P(RC0,U,9) D Q - .. S DIR(0)="EA",DIR("A",1)="The claim for selection #"_RC_" can't be edited as the claim has already",DIR("A")="been transferred to another site - PRESS RETURN TO CONTINUE" W ! D ^DIR K DIR - . ; - . I $D(^RCY(344.49,RCXDA1)) D - .. N X - .. S X=$G(^RCY(344,+$P($G(^RCY(344.49,RCXDA1,0)),U,2),0)) - .. W !!,*7,"Warning: EEOB Worklist entry #"_RCXDA1_$S($P(X,U)'="":" and receipt "_$P(X,U),1:"")_" exist for this EEOB" - .. I X="" W !,"You should refresh the worklist entry to include the new claim #",!," before creating the receipt",! - . I $P($G(^RCY(344.4,RCXDA1,0)),U,8) D - .. W !,"Since the receipt for this EEOB ("_$P($G(^RCY(344,+$P($G(^RCY(344.4,RCXDA1,0)),U,8),0)),U)_") already exists" - .. I '$P($G(^RCY(344,+$P($G(^RCY(344.4,RCXDA1,0)),U,8),0)),U,14) W !," and is closed, you will need to use link payment to apply the payment",!," to the correct account",! Q - .. W !," you should edit the receipt and change the claim # so it posts to the",!," correct account",! - . ; - . I $P(RC0,U,17)="" S RCSAVE=$P(RC0,U,5) - . W !,"Selection #: "_RC_$J("",5)_$P(RC0,U,5) - . S DIC("A")="Select A/R Bill this EEOB is actually paying on: ",DIC="^PRCA(430,",DIC(0)="AEMQ",DIC("S")="I $D(^DGCR(399,+Y,0))" W ! D ^DIC K DIC - . Q:Y'>0 - . S RCBILL=+Y,RCBILL(1)=$P($G(^PRCA(430,RCBILL,0)),U),RCWARN=0 - . I $P($G(^RCY(344.4,RCXDA1,0)),U,14) S RCWARN=RCWARN+1,DIR("A",RCWARN+1)=$J("",4)_"THE RECEIPT FOR THIS EEOB HAS ALREADY BEEN POSTED." - . I $P($G(^PRCA(430.3,+$P($G(^PRCA(430,RCBILL,0)),U,8),0)),U,3)'=102 S RCWARN=RCWARN+1,DIR("A",RCWARN+1)=$J("",4)_"THIS IS NOT AN ACTIVE ACCOUNTS RECEIVABLE." - . I RCWARN D I Y'=1 Q - .. S DIR("A",1)="** WARNING"_$S(RCWARN>1:"S",1:"")_":" - .. S DIR("A",RCWARN+1)=" " - .. S DIR(0)="YA",DIR("A")="ARE YOU SURE YOU WANT TO FILE THIS EEOB FOR CLAIM #: "_RCBILL(1)_"?: ",DIR("B")="NO" W ! D ^DIR K DIR - .. ; - . ; File EOB for new claim # - . K ^TMP($J,"RCDP-EOB"),^TMP($J,"RCDPEOB","HDR") - . S Q=0 F S Q=$O(^RCY(344.4,RCXDA1,1,RCXDA,1,Q)) Q:'Q S Q0=$G(^(Q,0)) D - .. I $P(Q0,U)["835ERA" S ^TMP($J,"RCDPEOB","HDR")=Q0 - .. I $P(Q0,U,2)=$P(RC0,U,5) S $P(Q0,U,2)=RCBILL(1) - .. S ^TMP($J,"RCDP-EOB",1,Q,0)=Q0 - . S ^TMP($J,"RCDP-EOB",1,.5,0)="835ERA" - . S RCEOB=$$DUP^IBCEOB("^TMP("_$J_",""RCDP-EOB"",1)",RCBILL) ; IA 4042 - . K ^TMP($J,"RCDP-EOB",1,.5,0) - . I RCEOB D Q - .. N RCWHY S RCWHY(1)="EEOB already found on file while trying to change claim # and filing into IB" - .. D STORACT^RCDPEX31(RCXDA1,RCXDA,.RCWHY) - .. S RCCHG=1,DA(1)=RCXDA1,DA=RCXDA D CHGED(.DA,RCEOB,RCSAVE) - .. S DIR(0)="YA",DIR("A",1)="EEOB detail is already on file for "_RCBILL(1)_" - Exception removed",DIR("A")="PRESS RETURN TO CONTINUE" D ^DIR K DIR - . ; - . ; Add stub rec to 361.1 if not there - . S RCEOB=+$$ADD3611^IBCEOB(+$P($G(^RCY(344.4,RCXDA1,0)),U,12),"","",RCBILL,1,"^TMP("_$J_",""RCDP-EOB"",1)") ; IA 4042 - . ; - . I RCEOB<0 D Q - .. N RCWHY S RCWHY(1)="Error encountered trying to change claim # and file into IB" - .. D STORACT^RCDPEX31(RCXDA1,RCXDA,.RCWHY) - .. S DIR("A")="EA",DIR("A",1)="Error - EEOB detail not added to IB for bill "_RCBILL(1),DIR("A")="PRESS RETURN TO CONTINUE" D ^DIR K DIR - . ; - . ; Update EOB in file 361.1 - . ; Call needs ^TMP arrays: $J,"RCDPEOB","HDR" and $J,"RCDP-EOB" - . D UPD3611^IBCEOB(RCEOB,1,1) ; IA 4042 - . ; errors in ^TMP("RCDPERR-EOB",$J - . I $O(^TMP("RCDPERR-EOB",$J,0)) D - .. D ERRUPD^IBCEOB(RCEOB,"RCDPERR-EOB") ; Adds error msgs to IB file 361.1 ; IA 4042 - . ; - . S RCCHG=1 - . N RCWHY S RCWHY(1)="EEOB claim # changed and filed into IB under new claim #" - . D STORACT^RCDPEX31(RCXDA1,RCXDA,.RCWHY) - . S DA(1)=RCXDA1,DA=RCXDA - . D CHGED(.DA,RCEOB,RCSAVE) - . S DIE="^RCY(344.4,"_DA(1)_",1,",DR="1///@" D ^DIE - . S DIR("A",1)="EEOB Filed. Its detail may be viewed using Third Party Joint Inquiry",DIR("A")="PRESS RETURN TO CONTINUE ",DIR(0)="EA" - . W ! D ^DIR K DIR - . S VALMBG=1 - ; -EDITNQ I $G(RCCHG) D BLD^RCDPEX2 - K ^TMP($J,"RCDP-EOB"),^TMP($J,"RCDPEOB","HDR"),^TMP("RCDPERR-EOB",$J) - S VALMBCK="R" - Q - ; -CHGED(DA,RCEOB,RCSAVE) ; Change bad bill # to good one for EOB - ; DA = DA and DA(1) to use for DIE call - ; RCEOB = the ien of the entry in file 361.1 - ; RCSAVE = the free text of the original bill # - N DIE,DR,X,Y - S DIE="^RCY(344.4,"_DA(1)_",1,",DR=".05///@;.02////"_RCEOB_";.13////1"_$S(RCSAVE'="":";.17////"_RCSAVE,1:"")_";.07///@" D ^DIE - Q - ; +RCDPEX32 ;ALB/TMK - ELECTRONIC EOB EXCEPTION PROCESSING - FILE 344.4 ;10-OCT-02 + ;;4.5;Accounts Receivable;**173**;Mar 20, 1995 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; +EDITNUM ; Edit invalid claim # to valid, refile EOB + N RC,RC0,RCDA,RCXDA,RCXDA1,RCSAVE,RCEOB,RCWARN,Q,Q0,DA,DR,DIE,DIC,DIR,X,Y,RCBILL,RCCHG + D FULL^VALM1 + D SEL^RCDPEX3(.RCDA) + G:'$O(RCDA(0)) EDITNQ + ; + S RC=0 F S RC=$O(RCDA(RC)) Q:'RC D L -^RCY(344.4,RCXDA1,1,RCXDA,0) + . S RCXDA1=+RCDA(RC),RCXDA=+$P(RCDA(RC),U,2),RCSAVE="" + . I '$$LOCK^RCDPEX31(RCXDA1,RCXDA,1) D Q + .. S DIR(0)="EA",DIR("A",1)="**Selection #"_RC_" is being edited by another user - ... please try again later",DIR("A")="PRESS RETURN TO CONTINUE" D ^DIR K DIR + . S RC0=$G(^RCY(344.4,RCXDA1,1,RCXDA,0)) + . I $P(RC0,U,5)="" D Q + .. S DIR(0)="EA",DIR("A",1)="The claim for selection #"_RC_" can't be edited as the bill # is not invalid",DIR("A")="PRESS RETURN TO CONTINUE" D ^DIR K DIR + . I $P(RC0,U,9) D Q + .. S DIR(0)="EA",DIR("A",1)="The claim for selection #"_RC_" can't be edited as the claim has already",DIR("A")="been transferred to another site - PRESS RETURN TO CONTINUE" W ! D ^DIR K DIR + . ; + . I $D(^RCY(344.49,RCXDA1)) D + .. N X + .. S X=$G(^RCY(344,+$P($G(^RCY(344.49,RCXDA1,0)),U,2),0)) + .. W !!,*7,"Warning: EEOB Worklist entry #"_RCXDA1_$S($P(X,U)'="":" and receipt "_$P(X,U),1:"")_" exist for this EEOB" + .. I X="" W !,"You should refresh the worklist entry to include the new claim #",!," before creating the receipt",! + . I $P($G(^RCY(344.4,RCXDA1,0)),U,8) D + .. W !,"Since the receipt for this EEOB ("_$P($G(^RCY(344,+$P($G(^RCY(344.4,RCXDA1,0)),U,8),0)),U)_") already exists" + .. I '$P($G(^RCY(344,+$P($G(^RCY(344.4,RCXDA1,0)),U,8),0)),U,14) W !," and is closed, you will need to use link payment to apply the payment",!," to the correct account",! Q + .. W !," you should edit the receipt and change the claim # so it posts to the",!," correct account",! + . ; + . I $P(RC0,U,17)="" S RCSAVE=$P(RC0,U,5) + . W !,"Selection #: "_RC_$J("",5)_$P(RC0,U,5) + . S DIC("A")="Select A/R Bill this EEOB is actually paying on: ",DIC="^PRCA(430,",DIC(0)="AEMQ",DIC("S")="I $D(^DGCR(399,+Y,0))" W ! D ^DIC K DIC + . Q:Y'>0 + . S RCBILL=+Y,RCBILL(1)=$P($G(^PRCA(430,RCBILL,0)),U),RCWARN=0 + . I $P($G(^RCY(344.4,RCXDA1,0)),U,14) S RCWARN=RCWARN+1,DIR("A",RCWARN+1)=$J("",4)_"THE RECEIPT FOR THIS EEOB HAS ALREADY BEEN POSTED." + . I $P($G(^PRCA(430.3,+$P($G(^PRCA(430,RCBILL,0)),U,8),0)),U,3)'=102 S RCWARN=RCWARN+1,DIR("A",RCWARN+1)=$J("",4)_"THIS IS NOT AN ACTIVE ACCOUNTS RECEIVABLE." + . I RCWARN D I Y'=1 Q + .. S DIR("A",1)="** WARNING"_$S(RCWARN>1:"S",1:"")_":" + .. S DIR("A",RCWARN+1)=" " + .. S DIR(0)="YA",DIR("A")="ARE YOU SURE YOU WANT TO FILE THIS EEOB FOR CLAIM #: "_RCBILL(1)_"?: ",DIR("B")="NO" W ! D ^DIR K DIR + .. ; + . ; File EOB for new claim # + . K ^TMP($J,"RCDP-EOB"),^TMP($J,"RCDPEOB","HDR") + . S Q=0 F S Q=$O(^RCY(344.4,RCXDA1,1,RCXDA,1,Q)) Q:'Q S Q0=$G(^(Q,0)) D + .. I $P(Q0,U)["835ERA" S ^TMP($J,"RCDPEOB","HDR")=Q0 + .. I $P(Q0,U,2)=$P(RC0,U,5) S $P(Q0,U,2)=RCBILL(1) + .. S ^TMP($J,"RCDP-EOB",1,Q,0)=Q0 + . S ^TMP($J,"RCDP-EOB",1,.5,0)="835ERA" + . S RCEOB=$$DUP^IBCEOB(RCBILL,"^TMP("_$J_",""RCDP-EOB"",1)") ; IA 4042 + . K ^TMP($J,"RCDP-EOB",1,.5,0) + . I RCEOB D Q + .. N RCWHY S RCWHY(1)="EEOB already found on file while trying to change claim # and filing into IB" + .. D STORACT^RCDPEX31(RCXDA1,RCXDA,.RCWHY) + .. S RCCHG=1,DA(1)=RCXDA1,DA=RCXDA D CHGED(.DA,RCEOB,RCSAVE) + .. S DIR(0)="YA",DIR("A",1)="EEOB detail is already on file for "_RCBILL(1)_" - Exception removed",DIR("A")="PRESS RETURN TO CONTINUE" D ^DIR K DIR + . ; + . ; Add stub rec to 361.1 if not there + . S RCEOB=+$$ADD3611^IBCEOB(+$P($G(^RCY(344.4,RCXDA1,0)),U,12),"","",RCBILL,1,"^TMP("_$J_",""RCDP-EOB"",1)") ; IA 4042 + . ; + . I RCEOB<0 D Q + .. N RCWHY S RCWHY(1)="Error encountered trying to change claim # and file into IB" + .. D STORACT^RCDPEX31(RCXDA1,RCXDA,.RCWHY) + .. S DIR("A")="EA",DIR("A",1)="Error - EEOB detail not added to IB for bill "_RCBILL(1),DIR("A")="PRESS RETURN TO CONTINUE" D ^DIR K DIR + . ; + . ; Update EOB in file 361.1 + . ; Call needs ^TMP arrays: $J,"RCDPEOB","HDR" and $J,"RCDP-EOB" + . D UPD3611^IBCEOB(RCEOB,1,1) ; IA 4042 + . ; errors in ^TMP("RCDPERR-EOB",$J + . I $O(^TMP("RCDPERR-EOB",$J,0)) D + .. D ERRUPD^IBCEOB(RCEOB,"RCDPERR-EOB") ; Adds error msgs to IB file 361.1 ; IA 4042 + . ; + . S RCCHG=1 + . N RCWHY S RCWHY(1)="EEOB claim # changed and filed into IB under new claim #" + . D STORACT^RCDPEX31(RCXDA1,RCXDA,.RCWHY) + . S DA(1)=RCXDA1,DA=RCXDA + . D CHGED(.DA,RCEOB,RCSAVE) + . S DIE="^RCY(344.4,"_DA(1)_",1,",DR="1///@" D ^DIE + . S DIR("A",1)="EEOB Filed. Its detail may be viewed using Third Party Joint Inquiry",DIR("A")="PRESS RETURN TO CONTINUE ",DIR(0)="EA" + . W ! D ^DIR K DIR + . S VALMBG=1 + ; +EDITNQ I $G(RCCHG) D BLD^RCDPEX2 + K ^TMP($J,"RCDP-EOB"),^TMP($J,"RCDPEOB","HDR"),^TMP("RCDPERR-EOB",$J) + S VALMBCK="R" + Q + ; +CHGED(DA,RCEOB,RCSAVE) ; Change bad bill # to good one for EOB + ; DA = DA and DA(1) to use for DIE call + ; RCEOB = the ien of the entry in file 361.1 + ; RCSAVE = the free text of the original bill # + N DIE,DR,X,Y + S DIE="^RCY(344.4,"_DA(1)_",1,",DR=".05///@;.02////"_RCEOB_";.13////1"_$S(RCSAVE'="":";.17////"_RCSAVE,1:"")_";.07///@" D ^DIE + Q + ; diff --git a/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPUDEP.m b/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPUDEP.m index 14ba677a..e9fdf38d 100644 --- a/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPUDEP.m +++ b/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPUDEP.m @@ -1,120 +1,116 @@ -RCDPUDEP ;WISC/RFJ-deposit utilities ;29/MAY/2008 - ;;4.5;Accounts Receivable;**114,173,257**;Mar 20, 1995;Build 3 - ;;Per VHA Directive 2004-038, this routine should not be modified. - Q - ; - ; -ADDDEPT(DEPOSIT,DEPDATE) ; if the deposit is not entered, add it - ; - ; if deposit date is missing, do not add the deposit - I 'DEPDATE Q 0 - ; - ; already in file, deposit number and deposit date match - N DA,RCDPFLAG - S DA=0 F S DA=$O(^RCY(344.1,"B",DEPOSIT,DA)) Q:'DA I $P($G(^RCY(344.1,DA,0)),"^",3)=DEPDATE S RCDPFLAG=1 Q - I $G(RCDPFLAG) Q DA - ; - ; add it - N %,%DT,D0,DA,DD,DI,DIC,DIE,DLAYGO,DO,DQ,DR,X,Y - S DIC="^RCY(344.1,",DIC(0)="L",DLAYGO=344.1 - ; .03 = deposit date .06 = opened by - ; .07 = date/time opened .12 = status (set to 1:open) - S DIC("DR")=".03////"_DEPDATE_";.06////"_DUZ_";.07///NOW;.12////1;" - S X=DEPOSIT - D FILE^DICN - I Y>0 Q +Y - Q 0 - ; - ; -SELDEPT(ADDNEW) ; select a deposit - ; if $g(addnew) allow adding a new deposit - ; returns -1 for timeout or ^, 0 for no selection, or ien of deposit - N %,%T,%Y,C,D0,DA,DIC,DIE,DLAYGO,DQ,DR,DTOUT,DUOUT,RCDEFLUP,X,Y - S DIC="^RCY(344.1,",DIC(0)="QEAM",DIC("A")="Select DEPOSIT: " - S DIC("W")="D DICW^RCDPUDEP" - ; use special lookup on input - S RCDEFLUP=1 - I $G(ADDNEW) S DIC(0)="QEALM",DLAYGO=344.1,DIC("DR")=".03///TODAY;.06////"_DUZ_";.07///NOW;.12////1;" - D ^DIC - I Y<0,'$G(DUOUT),'$G(DTOUT) S Y=0 - Q +Y - ; - ; -DICW ; write identifier code for receipt lookup - N DATA - S DATA=$G(^RCY(344.1,Y,0)) I DATA="" Q - ; opened by - W ?13,"by: ",$E($P($G(^VA(200,+$P(DATA,"^",6),0)),"^"),1,15) - ; date opened - I '$P(DATA,"^",7) S $P(DATA,"^",7)="???????" - W ?35," on: ",$E($P(DATA,"^",7),4,5),"/",$E($P(DATA,"^",7),6,7),"/",$E($P(DATA,"^",7),2,3) - ; total dollars - W ?50," amt: $",$J($P(DATA,"^",4),9,2) - ; status - W ?69," ",$P("N/A^OPEN^DEPOSITED^CONFIRMED^PROCESSED^VOID","^",+$P(DATA,"^",12)+1) - Q - ; - ; -LOOKUP ; special lookup on deposits, called from ^dd(344.1,.01,7.5) - ; if rcdeflup flag not set, do not use special lookup - I '$D(RCDEFLUP) Q - ; 1:OPEN;3:CONFIRMED - ; user entered O.? for lookup on open deposits - I X["O."!(X["o.") S DIC("S")="I $P(^(0),U,12)=1" S X="?" Q - ; user entered C.? for lookup on confirmed deposits - I X["C."!(X["c.") S DIC("S")="I $P(^(0),U,12)=3" S X="?" Q - ; deposit ticket # manually added is for electronic ticket only - I $G(DIC(0))["L",$$AUTODEP(X) D EN^DDIOL(" ** Deposit #'s starting with "_$E(X,1,3)_" can only be used by automatic deposits",,"!") S X="" Q - ; Do not allow for 7-, 8-, or 9-digit electronic ticket to be added. - I $G(DIC(0))["L",'$D(^RCY(344.1,"B",X)),$L(X)>6,$L(X)<10 D EN^DDIOL(" ** Deposit # of "_$L(X)_" digits not allowed. "_$S($L(X)=9:"9 digits limited to automatic deposits.",1:""),,"!") S X="" Q - K DIC("S") - Q - ; - ; -EDITDEP(DA,ASKDATE) ; edit the deposit - ; if $g(askdate) ask only the deposit date - N %,D,D0,DI,DIC,DIE,DQ,DR,J,X,Y - S (DIC,DIE)="^RCY(344.1,",DR="" - ; deposit date(.03), do not allow edit if closed or either lockbox - I $$CHECKDEP^RCDPDPLU(DA) S DR=".03BANK DEPOSIT DATE//TODAY;" - ; bank(.13) - S DR=DR_".13//"_$P($G(^RC(342.1,+$O(^RC(342.1,"AC",9,0)),0)),"^")_";" - ; bank trace(.05) - S DR=DR_".05;" - ; agency title(.17) - S DR=DR_".17//"_$P($G(^RC(342.1,+$O(^RC(342.1,"AC",10,0)),0)),"^")_";" - ; agency location code(.14), comments(1) - S DR=DR_".14//"_$P(^RC(342,1,0),"^",7)_";1;" - ; - ; only ask deposit date - I $G(ASKDATE) S DR=".03BANK DEPOSIT DATE//TODAY;" - D ^DIE - Q - ; - ; -CONFIRM(DA) ; confirm the deposit - N %DT,D,D0,DI,DIC,DIE,DQ,DR,X,Y - S (DIC,DIE)="^RCY(344.1," - S DR=".04///"_$$TOTAL(DA)_";.12////3;.1////"_DUZ_";.11///NOW;" - D ^DIE - Q - ; - ; -TOTAL(RCDEPTDA) ; compute total dollars for all receipts on the deposit - N RCRECTDA,RCTRANDA,TOTAL - S RCRECTDA=0 - F S RCRECTDA=$O(^RCY(344,"AD",RCDEPTDA,RCRECTDA)) Q:'RCRECTDA D - . S RCTRANDA=0 - . F S RCTRANDA=$O(^RCY(344,RCRECTDA,1,RCTRANDA)) Q:'RCTRANDA D - . . S TOTAL=$G(TOTAL)+$P($G(^RCY(344,RCRECTDA,1,RCTRANDA,0)),"^",4) - Q +$G(TOTAL) - ; -AUTODEP(X) ; Function returns 1 if the deposit ticket # in X is in the auto - ; deposit number space 269xxx, 369xxx, 469xxx, 569xxx, or 669xxx - ; and hasn't been previously entered via lockbox interface. - ; - N Y - S Y=0 - I $L(X)=6,$E(X,2,3)="69","23456"[$E(X),'$D(^RCY(344.1,"B",X)) S Y=1 - Q Y - ; +RCDPUDEP ;WISC/RFJ-deposit utilities ;1 Jun 99 + ;;4.5;Accounts Receivable;**114,173**;Mar 20, 1995 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + Q + ; + ; +ADDDEPT(DEPOSIT,DEPDATE) ; if the deposit is not entered, add it + ; + ; if deposit date is missing, do not add the deposit + I 'DEPDATE Q 0 + ; + ; already in file, deposit number and deposit date match + N DA,RCDPFLAG + S DA=0 F S DA=$O(^RCY(344.1,"B",DEPOSIT,DA)) Q:'DA I $P($G(^RCY(344.1,DA,0)),"^",3)=DEPDATE S RCDPFLAG=1 Q + I $G(RCDPFLAG) Q DA + ; + ; add it + N %,%DT,D0,DA,DD,DI,DIC,DIE,DLAYGO,DO,DQ,DR,X,Y + S DIC="^RCY(344.1,",DIC(0)="L",DLAYGO=344.1 + ; .03 = deposit date .06 = opened by + ; .07 = date/time opened .12 = status (set to 1:open) + S DIC("DR")=".03////"_DEPDATE_";.06////"_DUZ_";.07///NOW;.12////1;" + S X=DEPOSIT + D FILE^DICN + I Y>0 Q +Y + Q 0 + ; + ; +SELDEPT(ADDNEW) ; select a deposit + ; if $g(addnew) allow adding a new deposit + ; returns -1 for timeout or ^, 0 for no selection, or ien of deposit + N %,%T,%Y,C,D0,DA,DIC,DIE,DLAYGO,DQ,DR,DTOUT,DUOUT,RCDEFLUP,X,Y + S DIC="^RCY(344.1,",DIC(0)="QEAM",DIC("A")="Select DEPOSIT: " + S DIC("W")="D DICW^RCDPUDEP" + ; use special lookup on input + S RCDEFLUP=1 + I $G(ADDNEW) S DIC(0)="QEALM",DLAYGO=344.1,DIC("DR")=".03///TODAY;.06////"_DUZ_";.07///NOW;.12////1;" + D ^DIC + I Y<0,'$G(DUOUT),'$G(DTOUT) S Y=0 + Q +Y + ; + ; +DICW ; write identifier code for receipt lookup + N DATA + S DATA=$G(^RCY(344.1,Y,0)) I DATA="" Q + ; opened by + W ?13,"by: ",$E($P($G(^VA(200,+$P(DATA,"^",6),0)),"^"),1,15) + ; date opened + I '$P(DATA,"^",7) S $P(DATA,"^",7)="???????" + W ?35," on: ",$E($P(DATA,"^",7),4,5),"/",$E($P(DATA,"^",7),6,7),"/",$E($P(DATA,"^",7),2,3) + ; total dollars + W ?50," amt: $",$J($P(DATA,"^",4),9,2) + ; status + W ?69," ",$P("N/A^OPEN^DEPOSITED^CONFIRMED^PROCESSED^VOID","^",+$P(DATA,"^",12)+1) + Q + ; + ; +LOOKUP ; special lookup on deposits, called from ^dd(344.1,.01,7.5) + ; if rcdeflup flag not set, do not use special lookup + I '$D(RCDEFLUP) Q + ; 1:OPEN;3:CONFIRMED + ; user entered O.? for lookup on open deposits + I X["O."!(X["o.") S DIC("S")="I $P(^(0),U,12)=1" S X="?" Q + ; user entered C.? for lookup on confirmed deposits + I X["C."!(X["c.") S DIC("S")="I $P(^(0),U,12)=3" S X="?" Q + ; deposit ticket # manually entered is for electronic ticket only + I $G(DIC(0))["L",$$AUTODEP(X) D EN^DDIOL(" ** Deposit #'s starting with "_$E(X,1,3)_" can only be used by automatic deposits",,"!") S X="" + K DIC("S") + Q + ; + ; +EDITDEP(DA,ASKDATE) ; edit the deposit + ; if $g(askdate) ask only the deposit date + N %,D,D0,DI,DIC,DIE,DQ,DR,J,X,Y + S (DIC,DIE)="^RCY(344.1,",DR="" + ; deposit date(.03), do not allow edit if closed or either lockbox + I $$CHECKDEP^RCDPDPLU(DA) S DR=".03BANK DEPOSIT DATE//TODAY;" + ; bank(.13) + S DR=DR_".13//"_$P($G(^RC(342.1,+$O(^RC(342.1,"AC",9,0)),0)),"^")_";" + ; bank trace(.05) + S DR=DR_".05;" + ; agency title(.17) + S DR=DR_".17//"_$P($G(^RC(342.1,+$O(^RC(342.1,"AC",10,0)),0)),"^")_";" + ; agency location code(.14), comments(1) + S DR=DR_".14//"_$P(^RC(342,1,0),"^",7)_";1;" + ; + ; only ask deposit date + I $G(ASKDATE) S DR=".03BANK DEPOSIT DATE//TODAY;" + D ^DIE + Q + ; + ; +CONFIRM(DA) ; confirm the deposit + N %DT,D,D0,DI,DIC,DIE,DQ,DR,X,Y + S (DIC,DIE)="^RCY(344.1," + S DR=".04///"_$$TOTAL(DA)_";.12////3;.1////"_DUZ_";.11///NOW;" + D ^DIE + Q + ; + ; +TOTAL(RCDEPTDA) ; compute total dollars for all receipts on the deposit + N RCRECTDA,RCTRANDA,TOTAL + S RCRECTDA=0 + F S RCRECTDA=$O(^RCY(344,"AD",RCDEPTDA,RCRECTDA)) Q:'RCRECTDA D + . S RCTRANDA=0 + . F S RCTRANDA=$O(^RCY(344,RCRECTDA,1,RCTRANDA)) Q:'RCTRANDA D + . . S TOTAL=$G(TOTAL)+$P($G(^RCY(344,RCRECTDA,1,RCTRANDA,0)),"^",4) + Q +$G(TOTAL) + ; +AUTODEP(X) ; Function returns 1 if the deposit ticket # in X is in the auto + ; deposit number space 269xxx, 369xxx, 469xxx, 569xxx + N Y + S Y=0 + I $L(X)=6,$E(X,2,3)="69","2345"[$E(X),'$D(^RCY(344.1,"B",X)) S Y=1 + Q Y + ; diff --git a/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCFMOBR.m b/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCFMOBR.m index 464081c0..cfea6df6 100644 --- a/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCFMOBR.m +++ b/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCFMOBR.m @@ -1,100 +1,95 @@ -RCFMOBR ;WASH-ISC@ALTOONA,PA/RWT-BILL RECONCILIATIONS LIST ;11/20/96 2:30 PM -V ;;4.5;Accounts Receivable;**2,20,40,53,249**;Mar 20, 1995;Build 2 - ;;Per VHA Directive 10-93-142, this routine should not be modified. -EN ;Creates report from OBR data in file 423.6 - ; - ; OBR Data Structure used by this routine - ; ^TMP("OBR",$J,SITE,"NOT IN AR")=NextRec^TotalItems^TotalFMSAmt - ; ^TMP("OBR",$J,SITE,"NOT IN FMS")=NextRec^TotalItems^TotalARAmt - ; ^TMP("OBR",$J,SITE,"DISCREPANCY")=NextRec^TotalItems^TotalFMSAmt^TotalARAmt - ; ^TMP("OBR",$J,"BN",BILLNUMBER)=[423.6 rec] <-- x-ref of FMS Bills - ; ^TMP("OBR",$J,"REPORT","1")="LINE 1" - ; ^TMP("OBR",$J","REPORT,"2")="LINE 2" - ; - ; Descriptions of modules: - ; PROCFMS - loop through FMS bills (^PRCF(423.6)) updating - ; global ^TMP("OBR",$J,"BN") while also checking - ; for invalid AR bills - ; PROCAR - loop through all Active AR Bills comparing amounts - ; and looking for Detail bills not found in FMS - ; BUILDRPT - Prepares report in global ^TMP("OBR",$J,"REPORT") - ; - N X,Y,OBR,A0,ERR - K ^TMP("OBR",$J) - ; - I $G(PRCADA) D PROCESS(PRCADA) G Q1 - S OBR="OBR-",ERR=-1 - F S OBR=$O(^PRCF(423.6,"B",OBR)) Q:OBR=""!(OBR'["OBR-") D - .I $O(^PRCF(423.6,"B",OBR))'["OBR-" D Q - ..S A0=$O(^PRCF(423.6,"B",OBR,0)) - ..S ERR=0 D PROCESS(A0) - I ERR D PROCESS(ERR) -Q1 K ^TMP("OBR",$J) - Q -PROCESS(A0) N X,X1,X2,Y,SN,PARENT,XMTEXT,XMSUB,XMSENDER,XMDUZ,ERR,DATE,FMSDATE - S ERR=0 D - .I '$D(^PRCF(423.6,A0,0)) S ERR=-1 Q - .I $E(^PRCF(423.6,A0,0),1,3)'["OBR" S ERR=-1 Q - .S X=$P(^PRCF(423.6,A0,0),"-",2) - .S X=$E(X,5,6)_"-"_$E(X,7,8)_"-"_$E(X,1,4) D ^%DT ;Y is defined - .S PARENT=$P($P(^PRCF(423.6,A0,0),"-",5),U) - .; - .D PROCFMS^RCFMOBR1(A0) - .D PROCAR^RCFMOBR1(A0) - .D BUILDRPT^RCFMOBR2(PARENT) - ; - I '$D(PARENT) S PARENT=$$SITE^RCMSITE - S PARENT=$P(^DIC(4,+$O(^DIC(4,"D",PARENT,0)),0),U) - ; - I '$D(Y) S Y=DT ;Y may be defined from %DT call above - S X1=Y,X2=($E(Y,6,7)+1)*-1 D C^%DTC,YX^%DTC - S FMSDATE=$P(Y,"@"),FMSDATE=$E(FMSDATE,1,4)_$E(FMSDATE,9,12) - D NOW^%DTC S DATE=$E(X,4,5)_"-"_$E(X,6,7)_"-"_$E(X,2,3) - ; - Transmits report via e-mail to FMS mail group - S XMSUB="FMS "_FMSDATE_" RECONCILIATION ("_DATE_") " - S XMSUB=XMSUB_PARENT - I ERR D - .S ^TMP("OBR",$J,"REPORT",1)="Date of Report: "_DATE - .S ^TMP("OBR",$J,"REPORT",2)="NOTE: This report compares your current A/R records with data received from" - .S ^TMP("OBR",$J,"REPORT",3)=" FMS on the last day of the previous accounting period." - .S ^TMP("OBR",$J,"REPORT",4)="" - .S ^TMP("OBR",$J,"REPORT",5)="No FMS data exists to reconcile!" - S XMTEXT="^TMP(""OBR"",$J,""REPORT""," - S XMDUZ="Accounts Receivable Package",XMY("G.FMS")="",XMY(DUZ)="" D ^XMD - Q -EN2 ;Entry point from Regenerate Prior Month OBRs option - N DIR,PRCADA,Y - W !!,"This option will transmit the OBR report(s) to you and members" - W !,"of the G.FMS mail group." - W !!,"NOTE: Depending on the number of active AR bills in your system," - W !," this may take awhile to run.",! - S DIR(0)="YO",DIR("A")="Are you sure you want to do this",DIR("B")="NO" - D ^DIR Q:Y'=1 S ZTRTN="EN^RCFMOBR",ZTDESC="Prior Month OBRs" - S ZTIO="" D ^%ZTLOAD Q - ; -EN3 ;Deletes OBRs over 60 days old - N A0,A1,A2,DA,DIK,X,X1,X2 - S A0="OBR-" F S A0=$O(^PRCF(423.6,"B",A0)) Q:A0=""!(A0'["OBR-") S A1=$E($P(A0,"-",2),1,8),A2=0 F S A2=$O(^PRCF(423.6,"B",A0,A2)) Q:+A2=0 D - .S X1=DT,X2=$$RCDT(A1) D ^%DTC I X>60 S DIK="^PRCF(423.6,",DA=A2 D ^DIK - Q -RCDT(A1) ;Convert yyyymmdd to FM date - N X,Y - S X=A1,X=$E(X,5,6)_" "_$E(X,7,8)_", "_$E(X,1,4) - D ^%DT - Q Y -PURGE ;purge unprocessed document file - N DIR,Y,X,X1,X2,RCDT - S DIR("A")="How many days worth of DATA do you want to retain" - S DIR(0)="N",DIR("?")="This is the number of days entries will remain in the file." - D ^DIR - I +Y<0!(Y="")!($E(Y,1)="^") G POUT - S X1=DT,X2=-(+Y) D C^%DTC S RCDT=X - S ZTRTN="QPURGE^RCFMOBR",ZTSAVE("RCDT")="",ZTDESC="Purge unprocessed document list",ZTIO="" D ^%ZTLOAD -POUT K DIRUT,DIROUT,DTOUT,DUOUT Q - ; -QPURGE N DA,DIK - S DIK="^RC(347," - Q:'$D(^RC(347)) - S DA=0 F S DA=$O(^RC(347,DA)) Q:'DA I $P(^(DA,0),U,5)60 S DIK="^PRCF(423.6,",DA=A2 D ^DIK + Q +PURGE ;purge unprocessed document file + N DIR,Y,X,X1,X2,RCDT + S DIR("A")="How many days worth of DATA do you want to retain" + S DIR(0)="N",DIR("?")="This is the number of days entries will remain in the file." + D ^DIR + I +Y<0!(Y="")!($E(Y,1)="^") G POUT + S X1=DT,X2=-(+Y) D C^%DTC S RCDT=X + S ZTRTN="QPURGE^RCFMOBR",ZTSAVE("RCDT")="",ZTDESC="Purge unprocessed document list",ZTIO="" D ^%ZTLOAD +POUT K DIRUT,DIROUT,DTOUT,DUOUT Q + ; +QPURGE N DA,DIK + S DIK="^RC(347," + Q:'$D(^RC(347)) + S DA=0 F S DA=$O(^RC(347,DA)) Q:'DA I $P(^(DA,0),U,5)0 S DA=+Y,DR=.01,DIE="^RC(342," D ^DIE - Q -ALC ;Edit ALC parameter - NEW DIC,DR,DA,Y - S DIE="^RC(342,",DA=1,DR=".07;31" D ^DIE - Q -IRS ;Edit IRS OFFSET site parameters - NEW DIE,DR,DA,Y - I '$D(^RC(342,1,0)) D BEG G:'$D(^RC(342,1,0)) Q - S DA=1,DR="[RCMS IRS]",DIE="^RC(342," D ^DIE -Q Q -STAT ;Edit NOTIFICATION site parameters - NEW DIE,DR,DA,Y - I '$D(^RC(342,1,0)) D BEG G:'$D(^RC(342,1,0)) Q1 - S DA=1,DR="[RCMS NOTIFICATION]",DIE="^RC(342," D ^DIE -Q1 Q -GRP ;Edit AR Group Parameters - NEW DIE,DR,DA,Y - F W ! S DIC(0)="QEAML",DIC="^RC(342.1,",DLAYGO=342.1 D ^DIC K DIC G:Y<0 Q3 S DA=+Y,DIE="^RC(342.1,",DR=$P($G(^RC(342.2,+$P(^RC(342.1,+Y,0),"^",2),1)),"^") I DR]"" D ^DIE -Q3 Q -DEA ;Deactive an AR group - NEW DIE,DIC,DA,DR,Y,GRP - S DIC="^RC(342.1,",DIC(0)="QEAM",DIC("S")="I $P(^(0),""^"",2)'=7" D ^DIC Q:Y<0 S GRP=+Y - W ! S DIR("A")="Are you sure you want to Deactive Group '"_$P(^RC(342.1,GRP,0),"^")_"'",DIR(0)="Y",DIR("B")="NO" D ^DIR K DIR - I 'Y W !!,"*** NO ACTION TAKEN ***" Q - I Y S DIE="^RC(342.1,",DA=GRP,DR=".02////^S X=7" D ^DIE W !!,"*** Group Deactivated ***" - Q -SITE() ;Return site number - Q +$G(^DIC(4,+$P($G(^RC(342,1,0)),"^"),99)) -INT ;Print Inter/Admin/Pen effective report - NEW DIC,BY,FR,TO,FLDS,L - S DIC="^RC(342,",BY=.01,(FR,TO)="",FLDS="[RCMS INT/ADM/PEN]",L=0 D EN1^DIP - Q -UPINT ;Update Rate site parameters - NEW DIE,DR,DA,Y,IOP - S IOP=ION D INT - I '$D(^RC(342,1,0)) D BEG G:'$D(^RC(342,1,0)) Q4 - F W ! S DA=1,DR="[RCMS RATES]",DIE="^RC(342," D ^DIE Q:$D(Y) -Q4 Q - ; -EDILOCK ;Update EDI Lockbox site parameters - N DIE,DR,DA,Y - I '$D(^RC(342,1,0)) D BEG G:'$D(^RC(342,1,0)) Q5 - S DA=1,DR="[RCMS EDI LOCKBOX]",DIE="^RC(342," D ^DIE -Q5 Q - ; -EDITRDDT ;Update # OF DAYS FOR RD ELIG CHG RPT site parameter - ;This is the number of days for the Rated Disability Eligibility - ;Change Report to be used when the report is scheduled to be run - ;on a recurring basis. (Added for Hold Debt to DMC Project) - N DIE,DR,DA,Y - I '$D(^RC(342,1,0)) D BEG G:'$D(^RC(342,1,0)) Q6 - S DA=1,DR="8.01",DIE="^RC(342," D ^DIE -Q6 Q - ; -GETRDDAY() ;Return # OF DAYS FOR RD ELIG CHG RPT site parameter - Q $$GET1^DIQ(342,1_",",8.01) - ; -EDITRDAY ;Update NUMBER OF DAYS FOR DMC REPORTS site parameter. - ;This is the number of days in the past bills for episodes - ;of care will be included for the following reports when scheduled by - ;IRM to be run on a recurring basis: - ; DMC Debt Validity Report - ; DMC Debt Validity Management Report - ; Rated Disability Eligibility Change Report - ;The minimum value for this field is 365 days (1 year) and the maximum - ;value is 3650 days (10 years). If no value is added in this field the - ;report will default to 365 days. (Added for Hold Debt to DMC Project) - N DIE,DR,DA,Y - I '$D(^RC(342,1,0)) D BEG G:'$D(^RC(342,1,0)) Q7 - S DA=1,DR="8.02",DIE="^RC(342," D ^DIE -Q7 Q - ; -GETRDAY() ;Return NUMBER OF DAYS FOR DMC REPORTS site parameter - Q $$GET1^DIQ(342,1_",",8.02) - ; +RCMSITE ;ALB/RRG - EDIT SITE PARAMETERS ;03/12/02 +V ;;4.5;Accounts Receivable;**173,236**;Mar 20, 1995 + ;;Per VHA Directive 10-93-142, this routine should not be modified. +BEG ;Start editing site paramters + N DIC,DLAYGO,X,Y,DIE,DA,DR + S DIC="^RC(342,",DIC(0)="QEAML",DLAYGO=342 D ^DIC I Y>0 S DA=+Y,DR=.01,DIE="^RC(342," D ^DIE + Q +ALC ;Edit ALC parameter + NEW DIC,DR,DA,Y + S DIE="^RC(342,",DA=1,DR=".07;31" D ^DIE + Q +IRS ;Edit IRS OFFSET site parameters + NEW DIE,DR,DA,Y + I '$D(^RC(342,1,0)) D BEG G:'$D(^RC(342,1,0)) Q + S DA=1,DR="[RCMS IRS]",DIE="^RC(342," D ^DIE +Q Q +STAT ;Edit NOTIFICATION site parameters + NEW DIE,DR,DA,Y + I '$D(^RC(342,1,0)) D BEG G:'$D(^RC(342,1,0)) Q1 + S DA=1,DR="[RCMS NOTIFICATION]",DIE="^RC(342," D ^DIE +Q1 Q +GRP ;Edit AR Group Parameters + NEW DIE,DR,DA,Y + F W ! S DIC(0)="QEAML",DIC="^RC(342.1,",DLAYGO=342.1 D ^DIC K DIC G:Y<0 Q3 S DA=+Y,DIE="^RC(342.1,",DR=$P($G(^RC(342.2,+$P(^RC(342.1,+Y,0),"^",2),1)),"^") I DR]"" D ^DIE +Q3 Q +DEA ;Deactive an AR group + NEW DIE,DIC,DA,DR,Y,GRP + S DIC="^RC(342.1,",DIC(0)="QEAM",DIC("S")="I $P(^(0),""^"",2)'=7" D ^DIC Q:Y<0 S GRP=+Y + W ! S DIR("A")="Are you sure you want to Deactive Group '"_$P(^RC(342.1,GRP,0),"^")_"'",DIR(0)="Y",DIR("B")="NO" D ^DIR K DIR + I 'Y W !!,"*** NO ACTION TAKEN ***" Q + I Y S DIE="^RC(342.1,",DA=GRP,DR=".02////^S X=7" D ^DIE W !!,"*** Group Deactivated ***" + Q +SITE() ;Return site number + Q +$G(^DIC(4,+$P($G(^RC(342,1,0)),"^"),99)) +INT ;Print Inter/Admin/Pen effective report + NEW DIC,BY,FR,TO,FLDS,L + S DIC="^RC(342,",BY=.01,(FR,TO)="",FLDS="[RCMS INT/ADM/PEN]",L=0 D EN1^DIP + Q +UPINT ;Update Rate site parameters + NEW DIE,DR,DA,Y,IOP + S IOP=ION D INT + I '$D(^RC(342,1,0)) D BEG G:'$D(^RC(342,1,0)) Q4 + F W ! S DA=1,DR="[RCMS RATES]",DIE="^RC(342," D ^DIE Q:$D(Y) +Q4 Q + ; +EDILOCK ;Update EDI Lockbox site parameters + N DIE,DR,DA,Y + I '$D(^RC(342,1,0)) D BEG G:'$D(^RC(342,1,0)) Q5 + S DA=1,DR="[RCMS EDI LOCKBOX]",DIE="^RC(342," D ^DIE +Q5 Q + ; diff --git a/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCRCXM1.m b/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCRCXM1.m index a7a2b0bc..cb587360 100644 --- a/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCRCXM1.m +++ b/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCRCXM1.m @@ -1,67 +1,67 @@ -RCRCXM1 ;ALB/CMS - AR/RC ORIGINAL TRANSMISSION SET ;09/08/97 -V ;;4.5;Accounts Receivable;**63,122,189,249**;Mar 20, 1995;Build 2 - ;;Per VHA Directive 10-93-142, this routine should not be modified. - ; - Q - ; -IBS ;Set the IB Bill Information data line from RCRCVXM - ;Return: ^TMP("RCRCVL",$J,"XM") - ;S ^TMP("RCRCVL",$J,"XM",PRCABN,1,1)="BN1^BILL#^CAT.ABB^STATUS.ABB^CURRENT BALANCE^BILL TYPE^FORM TYPE^BILL DATE FROM^BILL DATE TO" - ;S ^TMP("RCRCVL",$J,"XM",PRCABN,1,2)="BN2^TOTAL BILL CHARGES^OFFSET AMT^OFFSET DESC.^DATE FIRST PRINTED^TAX ID^REFERRAL REASON CODE^REFERRAL COMMENT" - ;S ^TMP("RCRCVL",$J,"XM",PRCABN,2,1)="BINS^NAME OF INSURED^SUBSCRIBER ID#^RELATIONSHIP TO INSURED^CONDITION RELATED TO^" - ;S ^TMP("RCRCVL",$J,"XM",PRCABN,3,1)="PAT^PAT NAME^SSN^DOB^SEX^SENSITIVE RECORD Y/N^ADD1^ADD2^ADD3^CITY^STATE^ZIP" - ;S ^TMP("RCRCVL",$J,"XM",PRCABN,4,1)="INS^INSURER NAME^ADD1^ADD2^ADD3^CITY^STATE^ZIP^PHONE^PROVIDER ID#^GROUP NAME^GROUP #" - ;S ^TMP("RCRCVL",$J,"XM",PRCABN,5,1)="INSUP^DEBTNAME^DEBT ADD1^DEBT ADD2^DEBT ADD3^CITY^STATE^ZIP^PHONE - ;S ^TMP("RCRCVL",$J,"XM",PRCABN,6,1)="OPV^1^OPV DATE1" - ;S ^TMP("RCRCVL",$J,"XM",PRCABN,6,2)="OPV^2^OPV DATE2" - ;S ^TMP("RCRCVL",$J,"XM",PRCABN,7,1)="DXS^1^DIAGNOSIS CODE^DESCRIPTION" - ;S ^TMP("RCRCVL",$J,"XM",PRCABN,7,2)="DXS^2^DIAGNOSIS CODE^DESCRIPTION" - ;S ^TMP("RCRCVL",$J,"XM",PRCABN,8,1)="RVC^1^REVENUE CODE^DESCRIPTION^RATE^UNITS^TOTAL CHARGES" - ;S ^TMP("RCRCVL",$J,"XM",PRCABN,8,2)="RVC^2^REVENUE CODE^DESCRIPTION^RATE^UNITS^TOTAL CHARGES" - ;S ^TMP("RCRCVL",$J,"XM",PRCABN,9,1)="PRC^1^PROCEDURE CODE^PROCEDURE DATE^PLACE OF SERVICE CODE^PLACE OF SERVICE^TYPE OF SERVICE CODE^TYPE OF SERVICE" - ;S ^TMP("RCRCVL",$J,"XM",PRCABN,9,2)="PRC^2^PROCEDURE CODE^PROCEDURE DATE^PLACE OF SERVICE CODE^PLACE OF SERVICE^TYPE OF SERVICE CODE^TYPE OF SERVICE" - ;S ^TMP("RCRCVL",$J,"XM",PRCABN,10,1)="RXF^1^RX #^REFILL DATE^DRUG^NAME^DAYS SUPPLY^QUANTITY^NDC NUMBER" - ;S ^TMP("RCRCVL",$J,"XM",PRCABN,10,2)="RXF^2^RX #^REFILL DATE^DRUG^NAME^DAYS SUPPLY^QUANTITY^NDC NUMBER" - ;S ^TMP("RCRCVL",$J,"XM",PRCABN,11,1)="PRD^1^PROSTHETIC DEVICE NAME^DELIVERY DATE" - ;S ^TMP("RCRCVL",$J,"XM",PRCABN,11,2)="PRD^2^PROSTHETIC DEVICE NAME^DELIVERY DATE" - ; - N RCDR,RCI,RCIB,RCUNK S RCIB="" - D BILL^IBRFN3(PRCABN,.RCIB) - S RCUNK="UNK" - I RCIB=0 S RCA(PRCABN,RCY)="No IB Bill/Claim Information" G IBSQ - ; - allow sites to refer bill but not electronically - I $P($G(RCCAT(+$G(PRCA("CAT")))),U,1)'=1 S ^TMP("RCRCVL",$J,"XM",PRCABN,0)=RCY G IBSQ - ; - set XM primary bill information - S RCCNT=RCCNT+1 - S ^TMP("RCRCVL",$J,"XM",PRCABN,0)=RCY - S RCDR="BN1^"_$G(PRCA("BNAME"),RCUNK)_U_$P($G(PRCA("CAT")),U,3)_U_$P($G(PRCA("STATUS")),U,3)_U_+$P($$BILL^RCJIBFN2(PRCABN),U,3)_U_$G(RCIB("TOC"))_U_$G(RCIB("TCF"))_U_$G(RCIB("STF"))_U_$G(RCIB("STT")) - S ^TMP("RCRCVL",$J,"XM",PRCABN,1,1)=RCDR S RCDR="" - S ^TMP("RCRCVL",$J,"XM",PRCABN,1,2)="BN2^"_$G(RCIB("TCG"))_U_$G(RCIB("DFP"))_U_$G(RCIB("TAX"))_U_$G(PRCA("REF REASON")) - S ^TMP("RCRCVL",$J,"XM",PRCABN,2,1)="BINS^"_$P($G(RCIB("PIN")),U,5)_U_$P($G(RCIB("PIN")),U,6)_U_$P($G(RCIB("PIN")),U,7)_U_$S($G(RCIB("CRE"))]"":RCIB("CRE"),$G(RCIB("CRA"))]"":RCIB("CRA"),$G(RCIB("CRO"))]"":RCIB("CRO"),1:"") - S ^TMP("RCRCVL",$J,"XM",PRCABN,3,1)="PAT^"_$E($G(VADM(1),RCUNK),1,30)_U_$P($G(VADM(2)),U,1)_U_$P($G(VADM(3)),U,1)_U_$P($G(VADM(5)),U)_U_$G(RCIB("SR"))_U_$G(VAPA(1))_U_$G(VAPA(2))_U_$G(VAPA(3))_U_$G(VAPA(4))_U_$P($G(VAPA(5)),U,2)_U_+$G(VAPA(6)) - S ^TMP("RCRCVL",$J,"XM",PRCABN,4,1)="INS^"_$P($G(RCIB("PIN")),U,1)_U_$G(RCIB("PIN","MMA"))_U_$P($G(RCIB("PIN")),U,2,4) - ; - ; - set multiples if defined - I $O(RCIB("OPV",0)) S RCI=0 F S RCI=$O(RCIB("OPV",RCI)) Q:'RCI D - .S ^TMP("RCRCVL",$J,"XM",PRCABN,6,RCI)="OPV^"_RCI_U_RCIB("OPV",RCI) - I $O(RCIB("DXS",0)) S RCI=0 F S RCI=$O(RCIB("DXS",RCI)) Q:'RCI D - .S ^TMP("RCRCVL",$J,"XM",PRCABN,7,RCI)="DXS^"_RCI_U_RCIB("DXS",RCI) - I $O(RCIB("RVC",0)) S RCI=0 F S RCI=$O(RCIB("RCV",RCI)) Q:'RCI D - .S ^TMP("RCRCVL",$J,"XM",PRCABN,8,RCI)="RVC^"_RCI_U_RCIB("RCV",RCI) - I $O(RCIB("PRC",0)) S RCI=0 F S RCI=$O(RCIB("PRC",RCI)) Q:'RCI D - .S ^TMP("RCRCVL",$J,"XM",PRCABN,9,RCI)="PRC^"_RCI_U_RCIB("PRC",RCI) - I $O(RCIB("RXF",0)) S RCI=0 F S RCI=$O(RCIB("RXF",RCI)) Q:'RCI D - .S ^TMP("RCRCVL",$J,"XM",PRCABN,10,RCI)="RXF^"_RCI_U_RCIB("RXF",RCI) - I $O(RCIB("PDR",0)) S RCI=0 F S RCI=$O(RCIB("PDR",RCI)) Q:'RCI D - .S ^TMP("RCRCVL",$J,"XM",PRCABN,11,RCI)="PDR^"_RCI_U_RCIB("PDR",RCI) - ; - ; - set Current Debtor Name and Address if different - S RCI="" - I $G(PRCA("DEBTNM"))'=$P($G(RCIB("PIN")),U,1) S RCI=1 - I 'RCI,$G(PRCA("DEBTAD1"))'=$P($G(RCIB("PIN","MMA")),U,1) S RCI=1 - I 'RCI,$P($G(PRCA("DEBTADD")),U,7)'=$P($G(PRCA("PIN","MMA")),U,7) - I RCI S ^TMP("RCRCVL",$J,"XM",PRCABN,5,1)="INSUP^"_$E($G(PRCA("DEBTNM")),1,30)_U_$G(PRCA("DEBTAD1"))_U_$G(PRCA("DEBTAD2"))_U_$G(PRCA("DEBTAD3"))_U_$G(PRCA("DEBTCT"))_U_$G(PRCA("DEBTST"))_U_$G(PRCA("DEBTZIP"))_U_$P($G(PRCA("DEBTADD")),U,7) - ; -IBSQ K DFN,PRCA,RCCAT,VA,VADM,VAPA - Q - ;RCRCXM1 +RCRCXM1 ;ALB/CMS - AR/RC ORIGINAL TRANSMISSION SET ;09/08/97 +V ;;4.5;Accounts Receivable;**63,122,189**;Mar 20, 1995 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; + Q + ; +IBS ;Set the IB Bill Information data line from RCRCVXM + ;Return: ^TMP("RCRCVL",$J,"XM") + ;S ^TMP("RCRCVL",$J,"XM",PRCABN,1,1)="BN1^BILL#^CAT.ABB^STATUS.ABB^CURRENT BALANCE^BILL TYPE^FORM TYPE^BILL DATE FROM^BILL DATE TO" + ;S ^TMP("RCRCVL",$J,"XM",PRCABN,1,2)="BN2^TOTAL BILL CHARGES^OFFSET AMT^OFFSET DESC.^DATE FIRST PRINTED^TAX ID^REFERRAL REASON CODE^REFERRAL COMMENT" + ;S ^TMP("RCRCVL",$J,"XM",PRCABN,2,1)="BINS^NAME OF INSURED^SUBSCRIBER ID#^RELATIONSHIP TO INSURED^CONDITION RELATED TO^" + ;S ^TMP("RCRCVL",$J,"XM",PRCABN,3,1)="PAT^PAT NAME^SSN^DOB^SEX^SENSITIVE RECORD Y/N^ADD1^ADD2^ADD3^CITY^STATE^ZIP" + ;S ^TMP("RCRCVL",$J,"XM",PRCABN,4,1)="INS^INSURER NAME^ADD1^ADD2^ADD3^CITY^STATE^ZIP^PHONE^PROVIDER ID#^GROUP NAME^GROUP #" + ;S ^TMP("RCRCVL",$J,"XM",PRCABN,5,1)="INSUP^DEBTNAME^DEBT ADD1^DEBT ADD2^DEBT ADD3^CITY^STATE^ZIP^PHONE + ;S ^TMP("RCRCVL",$J,"XM",PRCABN,6,1)="OPV^1^OPV DATE1" + ;S ^TMP("RCRCVL",$J,"XM",PRCABN,6,2)="OPV^2^OPV DATE2" + ;S ^TMP("RCRCVL",$J,"XM",PRCABN,7,1)="DXS^1^DIAGNOSIS CODE^DESCRIPTION" + ;S ^TMP("RCRCVL",$J,"XM",PRCABN,7,2)="DXS^2^DIAGNOSIS CODE^DESCRIPTION" + ;S ^TMP("RCRCVL",$J,"XM",PRCABN,8,1)="RVC^1^REVENUE CODE^DESCRIPTION^RATE^UNITS^TOTAL CHARGES" + ;S ^TMP("RCRCVL",$J,"XM",PRCABN,8,2)="RVC^2^REVENUE CODE^DESCRIPTION^RATE^UNITS^TOTAL CHARGES" + ;S ^TMP("RCRCVL",$J,"XM",PRCABN,9,1)="PRC^1^PROCEDURE CODE^PROCEDURE DATE^PLACE OF SERVICE CODE^PLACE OF SERVICE^TYPE OF SERVICE CODE^TYPE OF SERVICE" + ;S ^TMP("RCRCVL",$J,"XM",PRCABN,9,2)="PRC^2^PROCEDURE CODE^PROCEDURE DATE^PLACE OF SERVICE CODE^PLACE OF SERVICE^TYPE OF SERVICE CODE^TYPE OF SERVICE" + ;S ^TMP("RCRCVL",$J,"XM",PRCABN,10,1)="RXF^1^RX #^REFILL DATE^DRUG^NAME^DAYS SUPPLY^QUANTITY^NDC NUMBER" + ;S ^TMP("RCRCVL",$J,"XM",PRCABN,10,2)="RXF^2^RX #^REFILL DATE^DRUG^NAME^DAYS SUPPLY^QUANTITY^NDC NUMBER" + ;S ^TMP("RCRCVL",$J,"XM",PRCABN,11,1)="PRD^1^PROSTHETIC DEVICE NAME^DELIVERY DATE" + ;S ^TMP("RCRCVL",$J,"XM",PRCABN,11,2)="PRD^2^PROSTHETIC DEVICE NAME^DELIVERY DATE" + ; + N RCDR,RCI,RCIB,RCUNK S RCIB="" + D BILL^IBRFN3(PRCABN,.RCIB) + S RCUNK="UNK" + I RCIB=0 S RCA(PRCABN,RCY)="No IB Bill/Claim Information" G IBSQ + ; - allow sites to refer bill but not electronically + I $P($G(RCCAT(+$G(PRCA("CAT")))),U,1)'=1 S ^TMP("RCRCVL",$J,"XM",PRCABN,0)=RCY G IBSQ + ; - set XM primary bill information + S RCCNT=RCCNT+1 + S ^TMP("RCRCVL",$J,"XM",PRCABN,0)=RCY + S RCDR="BN1^"_$G(PRCA("BNAME"),RCUNK)_U_$P($G(PRCA("CAT")),U,3)_U_$P($G(PRCA("STATUS")),U,3)_U_+$P($$BILL^RCJIBFN2(PRCABN),U,3)_U_$G(RCIB("TOC"))_U_$G(RCIB("TCF"))_U_$G(RCIB("STF"))_U_$G(RCIB("STT")) + S ^TMP("RCRCVL",$J,"XM",PRCABN,1,1)=RCDR S RCDR="" + S ^TMP("RCRCVL",$J,"XM",PRCABN,1,2)="BN2^"_$G(RCIB("TCG"))_U_$G(RCIB("DFP"))_U_$G(RCIB("TAX"))_U_$G(PRCA("REF REASON")) + S ^TMP("RCRCVL",$J,"XM",PRCABN,2,1)="BINS^"_$P($G(RCIB("PIN")),U,5)_U_$P($G(RCIB("PIN")),U,6)_U_$P($G(RCIB("PIN")),U,7)_U_$S($G(RCIB("CRE"))]"":RCIB("CRE"),$G(RCIB("CRA"))]"":RCIB("CRA"),$G(RCIB("CRO"))]"":RCIB("CRO"),1:"") + S ^TMP("RCRCVL",$J,"XM",PRCABN,3,1)="PAT^"_$E($G(VADM(1),RCUNK),1,30)_U_$P($G(VADM(2)),U,1)_U_$P($G(VADM(3)),U,1)_U_$P($G(VADM(5)),U)_U_$G(RCIB("SR"))_U_$G(VAPA(1))_U_$G(VAPA(2))_U_$G(VAPA(3))_U_$G(VAPA(4))_U_$P($G(VAPA(5)),U,2)_U_+$G(VAPA(6)) + S ^TMP("RCRCVL",$J,"XM",PRCABN,4,1)="INS^"_$P($G(RCIB("PIN")),U,1)_U_$G(RCIB("PIN","MMA"))_U_$P($G(RCIB("PIN")),2,4) + ; + ; - set multiples if defined + I $O(RCIB("OPV",0)) S RCI=0 F S RCI=$O(RCIB("OPV",RCI)) Q:'RCI D + .S ^TMP("RCRCVL",$J,"XM",PRCABN,6,RCI)="OPV^"_RCI_U_RCIB("OPV",RCI) + I $O(RCIB("DXS",0)) S RCI=0 F S RCI=$O(RCIB("DXS",RCI)) Q:'RCI D + .S ^TMP("RCRCVL",$J,"XM",PRCABN,7,RCI)="DXS^"_RCI_U_RCIB("DXS",RCI) + I $O(RCIB("RVC",0)) S RCI=0 F S RCI=$O(RCIB("RCV",RCI)) Q:'RCI D + .S ^TMP("RCRCVL",$J,"XM",PRCABN,8,RCI)="RVC^"_RCI_U_RCIB("RCV",RCI) + I $O(RCIB("PRC",0)) S RCI=0 F S RCI=$O(RCIB("PRC",RCI)) Q:'RCI D + .S ^TMP("RCRCVL",$J,"XM",PRCABN,9,RCI)="PRC^"_RCI_U_RCIB("PRC",RCI) + I $O(RCIB("RXF",0)) S RCI=0 F S RCI=$O(RCIB("RXF",RCI)) Q:'RCI D + .S ^TMP("RCRCVL",$J,"XM",PRCABN,10,RCI)="RXF^"_RCI_U_RCIB("RXF",RCI) + I $O(RCIB("PDR",0)) S RCI=0 F S RCI=$O(RCIB("PDR",RCI)) Q:'RCI D + .S ^TMP("RCRCVL",$J,"XM",PRCABN,11,RCI)="PDR^"_RCI_U_RCIB("PDR",RCI) + ; + ; - set Current Debtor Name and Address if different + S RCI="" + I $G(PRCA("DEBTNM"))'=$P($G(RCIB("PIN")),U,1) S RCI=1 + I 'RCI,$G(PRCA("DEBTAD1"))'=$P($G(RCIB("PIN","MMA")),U,1) S RCI=1 + I 'RCI,$P($G(PRCA("DEBTADD")),U,7)'=$P($G(PRCA("PIN","MMA")),U,7) + I RCI S ^TMP("RCRCVL",$J,"XM",PRCABN,5,1)="INSUP^"_$E($G(PRCA("DEBTNM")),1,30)_U_$G(PRCA("DEBTAD1"))_U_$G(PRCA("DEBTAD2"))_U_$G(PRCA("DEBTAD3"))_U_$G(PRCA("DEBTCT"))_U_$G(PRCA("DEBTST"))_U_$G(PRCA("DEBTZIP"))_U_$P($G(PRCA("DEBTADD")),U,7) + ; +IBSQ K DFN,PRCA,RCCAT,VA,VADM,VAPA + Q + ;RCRCXM1 diff --git a/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCXVDC.m b/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCXVDC.m index 02e71f74..8a42564d 100644 --- a/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCXVDC.m +++ b/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCXVDC.m @@ -1,53 +1,51 @@ -RCXVDC ;DAOU/ALA-AR Data Extraction Data Creation ;02-JUL-03 - ;;4.5;Accounts Receivable;**201,228,256**;Mar 20, 1995;Build 6 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - Q -EN ; Entry Point - NEW RCXVD0,RCXVEVDT,RCXVBCN - NEW RCXVI,RCXVCP,RCXVPC,RCXVPFDT,RCXVPTDT - NEW RCXVBLNA,RCXVBLNB,RCXVICN - I DFN="" S DFN=$P($G(^PRCA(430,RCXVBLN,0)),U,7) ; - K ^TMP($J) - D D430^RCXVDC1 - I DFN'="" D D2^RCXVDC2 - D D399^RCXVDC3 - D D399PC^RCXVDC4 - D D350^RCXVDC5 - D D3625^RCXVDC7 - I RCXVRT="D"!(RCXVRT="C")!(RCXVRT="E") D D433^RCXVDC6 - I RCXVRT="H" D D433B^RCXVDC6 - ; -FILE ; - W "REC:"_RCXVBLNA,! - W "430:"_$G(^TMP($J,RCXVBLN,"1-430A"))_RCXVU - W $G(^TMP($J,RCXVBLN,"1-430B"))_RCXVU - W $G(^TMP($J,RCXVBLN,"1-430C")) - W ! - I DFN'="" W "2:"_$G(^TMP($J,RCXVBLN,"2-2A"))_RCXVU_$G(^TMP($J,RCXVBLN,"2-2B")),! - I $G(^TMP($J,RCXVBLN,"3-399A"))'="" W "399:"_^TMP($J,RCXVBLN,"3-399A")_RCXVU_^TMP($J,RCXVBLN,"3-399B")_RCXVU_^TMP($J,RCXVBLN,"3-399C")_RCXVU_^TMP($J,RCXVBLN,"3-399D"),! - S RCXVPC=0 - F S RCXVPC=$O(^TMP($J,RCXVBLN,"4-399A",RCXVPC)) Q:'RCXVPC D - . I $G(^TMP($J,RCXVBLN,"4-399A",RCXVPC))'="" D - .. W "399.0304:" - .. W $G(^TMP($J,RCXVBLN,"4-399A",RCXVPC)) - .. W RCXVU - .. F RCXVCP=1:1 Q:('$D(^TMP($J,RCXVBLN,"4-399A",RCXVPC,RCXVCP))) D - ... I RCXVCP>1 W "~" - ... W $G(^TMP($J,RCXVBLN,"4-399A",RCXVPC,RCXVCP)) - ... Q - .. W ! - . I $G(^TMP($J,RCXVBLN,"4-399B",RCXVPC))'="" W "399.042:"_$G(^TMP($J,RCXVBLN,"4-399B",RCXVPC)),! - . Q - S RCXVI="" - F S RCXVI=$O(^TMP($J,RCXVBLN,"5-350A",RCXVI)) Q:RCXVI="" D - . W "350:"_^TMP($J,RCXVBLN,"5-350A",RCXVI),! - S RCXVI="" - F S RCXVI=$O(^TMP($J,RCXVBLN,"7-362.5A",RCXVI)) Q:RCXVI="" D - . W "362.5:"_^TMP($J,RCXVBLN,"7-362.5A",RCXVI),! - ; LOOP THRU ^TMP($J,RCXVBLN,"6-433A",RCXVI) - S RCXVI="" - F S RCXVI=$O(^TMP($J,RCXVBLN,"6-433A",RCXVI)) Q:RCXVI="" D - . W "433:"_$G(^TMP($J,RCXVBLN,"6-433A",RCXVI)),! - . Q - Q +RCXVDC ;DAOU/ALA-AR Data Extraction Data Creation ;02-JUL-03 + ;;4.5;Accounts Receivable;**201,228**;Mar 20, 1995 + ; + Q +EN ; Entry Point + NEW RCXVD0,RCXVEVDT,RCXVBCN + NEW RCXVI,RCXVCP,RCXVPC,RCXVPFDT,RCXVPTDT + NEW RCXVBLNA,RCXVBLNB,RCXVICN + I DFN="" S DFN=$P($G(^PRCA(430,RCXVBLN,0)),U,7) ; + K ^TMP($J) + D D430^RCXVDC1 + I DFN'="" D D2^RCXVDC2 + D D399^RCXVDC3 + D D399PC^RCXVDC4 + D D350^RCXVDC5 + D D3625^RCXVDC7 + I RCXVRT="D"!(RCXVRT="C")!(RCXVRT="E") D D433^RCXVDC6 + I RCXVRT="H" D D433B^RCXVDC6 + ; +FILE ; + W "REC:"_RCXVBLNA,! + W "430:"_$G(^TMP($J,RCXVBLN,"1-430A"))_RCXVU + W $G(^TMP($J,RCXVBLN,"1-430B"))_RCXVU + W $G(^TMP($J,RCXVBLN,"1-430C")) + W ! + I DFN'="" W "2:"_$G(^TMP($J,RCXVBLN,"2-2A"))_RCXVU_$G(^TMP($J,RCXVBLN,"2-2B")),! + I $G(^TMP($J,RCXVBLN,"3-399A"))'="" W "399:"_^TMP($J,RCXVBLN,"3-399A")_RCXVU_^TMP($J,RCXVBLN,"3-399B")_RCXVU_^TMP($J,RCXVBLN,"3-399C")_RCXVU_^TMP($J,RCXVBLN,"3-399D"),! + S RCXVPC=0 + F S RCXVPC=$O(^TMP($J,RCXVBLN,"4-399A",RCXVPC)) Q:'RCXVPC D + . W "399.0304:" + . W $G(^TMP($J,RCXVBLN,"4-399A",RCXVPC)) + . W RCXVU + . F RCXVCP=1:1 Q:('$D(^TMP($J,RCXVBLN,"4-399A",RCXVPC,RCXVCP))) D + . . I RCXVCP>1 W "~" + . . W $G(^TMP($J,RCXVBLN,"4-399A",RCXVPC,RCXVCP)) + . . Q + . W ! + . I $D(^TMP($J,RCXVBLN,"4-399B",RCXVPC)) W "399.042:"_$G(^TMP($J,RCXVBLN,"4-399B",RCXVPC)),! + . Q + S RCXVI="" + F S RCXVI=$O(^TMP($J,RCXVBLN,"5-350A",RCXVI)) Q:RCXVI="" D + . W "350:"_^TMP($J,RCXVBLN,"5-350A",RCXVI),! + S RCXVI="" + F S RCXVI=$O(^TMP($J,RCXVBLN,"7-362.5A",RCXVI)) Q:RCXVI="" D + . W "362.5:"_^TMP($J,RCXVBLN,"7-362.5A",RCXVI),! + ; LOOP THRU ^TMP($J,RCXVBLN,"6-433A",RCXVI) + S RCXVI="" + F S RCXVI=$O(^TMP($J,RCXVBLN,"6-433A",RCXVI)) Q:RCXVI="" D + . W "433:"_$G(^TMP($J,RCXVBLN,"6-433A",RCXVI)),! + . Q + Q diff --git a/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCXVDC4.m b/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCXVDC4.m index 1185c200..26be4fdf 100644 --- a/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCXVDC4.m +++ b/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCXVDC4.m @@ -1,95 +1,69 @@ -RCXVDC4 ;DAOU/ALA-AR Data Extraction Data Creation ;02-JUL-03 - ;;4.5;Accounts Receivable;**201,227,228,248,251,256**;Mar 20, 1995;Build 6 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ; Procedures - Q -D399PC ; - I RCXVD0="" Q - N RCXVD,RCXVDA,RCXVB,RCXVPC,RCXVP1,RCXVP2,RCXVP3,RCXVMULT - N RCXVDT3,RCXVCP,RCXVPCDT,RCXVPS1,RCXVPS2,RCXVPS,RCXVPSER,RCXVNPI,RCXVCNT,RCXVMH - ;RCXVPC=PROC. CODE IEN, RCXVCP=CPT CODE IEN - ; LOOP THRU PROC. - S RCXVMH="",(RCXVPC,RCXVCNT)=0 - F S RCXVPC=$O(^DGCR(399,RCXVD0,"CP",RCXVPC)) Q:'RCXVPC D D399PCA - S RCXVPC=0 - F S RCXVPC=$O(^DGCR(399,RCXVD0,"RC",RCXVPC)) Q:'RCXVPC D D39942 - Q -D399PCA ; - S RCXVD=$G(^DGCR(399,RCXVD0,"CP",RCXVPC,0)) Q:RCXVD="" - S RCXVP1=$P(RCXVD,U,1),RCXVVP="",RCXVVP1="" - I RCXVP1'="" S RCXVVP="^"_$P(RCXVP1,";",2)_$P(RCXVP1,";",1)_",0)" - I RCXVVP'="" S RCXVVP1=$P($G(@RCXVVP),U,1) I RCXVVP1="" D - . NEW CT - . S CT=$G(^TMP("RCXVBREC",$J,0))+1,^TMP("RCXVBREC",$J,0)=CT - . S ^TMP("RCXVBREC",$J,CT,0)="Bill # "_$P($G(^DGCR(399,RCXVD0,0)),"^",1)_" has a bad CPT code at IEN # "_RCXVPC_" check ^DGCR(399,"_RCXVD0_",""CP"","_RCXVPC_",0)" - S RCXVDA=RCXVBLNA_RCXVU_RCXVVP1 ; PROC. - S RCXVDT=$P(RCXVD,U,2) - S RCXVPCDT=$E($$HLDATE^HLFNC(RCXVDT),1,8) - S RCXVDA=RCXVDA_RCXVU_RCXVPCDT ; DT - S RCXVP1=$P(RCXVD,U,11),RCXVP2="" - I RCXVP1'="" S RCXVP1=$P($G(^IBA(362.3,RCXVP1,0)),U,1) - I RCXVP1'="" S RCXVP2=$P($G(^ICD9(RCXVP1,0)),U,1) - S RCXVDA=RCXVDA_RCXVU_RCXVP2 ; ASSOC DXN (1) - S RCXVP1=$P(RCXVD,U,7),RCXVP2="" - I RCXVP1'="" S RCXVP2=$P($G(^SC(RCXVP1,0)),U,1) - S RCXVDA=RCXVDA_RCXVU_RCXVP2 ; ASSC. CLNC (P) - S RCXVP1=$P(RCXVD,U,18),(RCXVP2,RCXVPS,RCXVPSER,RCXVNPI)="" - I RCXVP1'="" S RCXVP2=$$GET1^DIQ(200,RCXVP1_",",.01,"E"),RCXVNPI=$P($$NPI^XUSNPI("Individual_ID",RCXVP1),RCXVU,1) S:+RCXVNPI<1 RCXVNPI="" D - . S RCXVPS=$$GET^XUA4A72(RCXVP1,RCXVDT) - . S RCXVPS=$P(RCXVPS,U,3) - . S RCXVPSER=$$GET1^DIQ(200,RCXVP1_",",29,"E") - . Q - ;provider^provider npi^specialty^service/section - S RCXVDA=RCXVDA_RCXVU_RCXVP2_RCXVU_RCXVNPI_RCXVU_RCXVPS_RCXVU_RCXVPSER - S RCXVCNT=RCXVCNT+1,^TMP($J,RCXVBLN,"4-399A",RCXVCNT)=RCXVDA - ; LOOP THRU CPT - S RCXVCP=0,RCXVMULT=0 - F S RCXVCP=$O(^DGCR(399,RCXVD0,"CP",RCXVPC,"MOD",RCXVCP)) Q:'RCXVCP D - . Q:'($D(^DGCR(399,RCXVD0,"CP",RCXVPC,"MOD",RCXVCP,0))) - . ; ^DGCR(399,D0,CP,D1,MOD,D2,0)= (#.01) CPT MODIFIER SEQUENCE [1N] - . ; (#.02) CPT ==>MODIFIER [2P:81.3] - . S RCXVP1=$P($G(^DGCR(399,RCXVD0,"CP",RCXVPC,"MOD",RCXVCP,0)),U,2) - . Q:RCXVP1="" - . S RCXVMULT=RCXVMULT+1 - . S RCXVP2=$P($G(^DIC(81.3,RCXVP1,0)),U,1) - . S ^TMP($J,RCXVBLN,"4-399A",RCXVCNT,RCXVMULT)=RCXVP2 - . Q - ; - ; *256 - loop through 399.042 to find CPT procedure -MATCH N RCXVCPT1,RCXVFND,X - S RCXVCPT1=$P(RCXVD,";",1) ;proc - S (RCXVFND,RCXVCP)=0 - F S RCXVCP=$O(^DGCR(399,RCXVD0,"RC",RCXVCP)) Q:'RCXVCP!RCXVFND D - . Q:$F(RCXVMH,";"_RCXVCP) ;quit if CPT proc match - . S RCXVD1=$G(^DGCR(399,RCXVD0,"RC",RCXVCP,0)) - . Q:RCXVD1="" - . S X=$P(RCXVD1,U,6) ;CPT proc - . I RCXVCPT1'="",X'="",RCXVCPT1=X D - .. S RCXVFND=1 - .. S X=$P(RCXVD1,U) - .. S RCXVDB=RCXVBLNA_RCXVU_$$GET1^DIQ(399.2,X_",",.01,"E") ; Revenue Code - .. S X=$P(RCXVD1,U,6) - .. S RCXVDB=RCXVDB_RCXVU_$$GET1^DIQ(81,X_",",.01,"E") ; Procedures [P] - .. S RCXVDB=RCXVDB_RCXVU_RCXVPCDT ; PROC. DT - .. S RCXVDB=RCXVDB_RCXVU_$P(RCXVD1,U,2) ; Charges - .. S ^TMP($J,RCXVBLN,"4-399B",RCXVCNT)=RCXVDB - .. S RCXVMH=RCXVMH_";"_RCXVCP - I 'RCXVFND S ^TMP($J,RCXVBLN,"4-399B",RCXVCNT)="" - Q - ; -D39942 ; charge - N X - Q:$F(RCXVMH,";"_RCXVPC) - S RCXVD1=$G(^DGCR(399,RCXVD0,"RC",RCXVPC,0)) - Q:RCXVD1="" - S X=$P(RCXVD1,U) - S RCXVDB=RCXVBLNA_RCXVU_$$GET1^DIQ(399.2,X_",",.01,"E") ; Revenue Code - S RCXVDB=RCXVDB_RCXVU_"" ;No CPT proc - S RCXVDB=RCXVDB_RCXVU_"" ; No proc dt - S RCXVDB=RCXVDB_RCXVU_$P(RCXVD1,U,2) ; Charges - S RCXVCNT=RCXVCNT+1 - S ^TMP($J,RCXVBLN,"4-399A",RCXVCNT)="" - S ^TMP($J,RCXVBLN,"4-399B",RCXVCNT)=RCXVDB - Q - ; +RCXVDC4 ;DAOU/ALA-AR Data Extraction Data Creation ;02-JUL-03 + ;;4.5;Accounts Receivable;**201,227,228,248,251**;Mar 20, 1995;Build 21 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; + ; Procedures + Q +D399PC ; + I RCXVD0="" Q + N RCXVD,RCXVDA,RCXVB,RCXVPC,RCXVP1,RCXVP2,RCXVP3,RCXVMULT + N RCXVDT3,RCXVCP,RCXVPCDT,RCXVPS1,RCXVPS2,RCXVPS,RCXVPSER,RCXVNPI + ;RCXVPC=PROC. CODE IEN, RCXVCP=CPT CODE IEN + ; LOOP THRU PROC. + S RCXVPC=0 + F S RCXVPC=$O(^DGCR(399,RCXVD0,"CP",RCXVPC)) Q:'RCXVPC D D399PCA + Q +D399PCA ; + S RCXVD=$G(^DGCR(399,RCXVD0,"CP",RCXVPC,0)) Q:RCXVD="" + S RCXVP1=$P(RCXVD,U,1),RCXVVP="",RCXVVP1="" + I RCXVP1'="" S RCXVVP="^"_$P(RCXVP1,";",2)_$P(RCXVP1,";",1)_",0)" + I RCXVVP'="" S RCXVVP1=$P($G(@RCXVVP),U,1) I RCXVVP1="" D + . NEW CT + . S CT=$G(^TMP("RCXVBREC",$J,0))+1,^TMP("RCXVBREC",$J,0)=CT + . S ^TMP("RCXVBREC",$J,CT,0)="Bill # "_$P($G(^DGCR(399,RCXVD0,0)),"^",1)_" has a bad CPT code at IEN # "_RCXVPC_" check ^DGCR(399,"_RCXVD0_",""CP"","_RCXVPC_",0)" + S RCXVDA=RCXVBLNA_RCXVU_RCXVVP1 ; PROC. + S RCXVDT=$P(RCXVD,U,2) + S RCXVPCDT=$E($$HLDATE^HLFNC(RCXVDT),1,8) + S RCXVDA=RCXVDA_RCXVU_RCXVPCDT ; DT + S RCXVP1=$P(RCXVD,U,11),RCXVP2="" + I RCXVP1'="" S RCXVP1=$P($G(^IBA(362.3,RCXVP1,0)),U,1) + I RCXVP1'="" S RCXVP2=$P($G(^ICD9(RCXVP1,0)),U,1) + S RCXVDA=RCXVDA_RCXVU_RCXVP2 ; ASSOC DXN (1) + S RCXVP1=$P(RCXVD,U,7),RCXVP2="" + I RCXVP1'="" S RCXVP2=$P($G(^SC(RCXVP1,0)),U,1) + S RCXVDA=RCXVDA_RCXVU_RCXVP2 ; ASSC. CLNC (P) + S RCXVP1=$P(RCXVD,U,18),(RCXVP2,RCXVPS,RCXVPSER,RCXVNPI)="" + I RCXVP1'="" S RCXVP2=$$GET1^DIQ(200,RCXVP1_",",.01,"E"),RCXVNPI=$P($$NPI^XUSNPI("Individual_ID",RCXVP1),RCXVU,1) S:+RCXVNPI<1 RCXVNPI="" D + . S RCXVPS=$$GET^XUA4A72(RCXVP1,RCXVDT) + . S RCXVPS=$P(RCXVPS,U,3) + . S RCXVPSER=$$GET1^DIQ(200,RCXVP1_",",29,"E") + . Q + ;provider^provider npi^specialty^service/section + S RCXVDA=RCXVDA_RCXVU_RCXVP2_RCXVU_RCXVNPI_RCXVU_RCXVPS_RCXVU_RCXVPSER + S ^TMP($J,RCXVBLN,"4-399A",RCXVPC)=RCXVDA + ; LOOP THRU CPT + S RCXVCP=0,RCXVMULT=0 + F S RCXVCP=$O(^DGCR(399,RCXVD0,"CP",RCXVPC,"MOD",RCXVCP)) Q:'RCXVCP D + . Q:'($D(^DGCR(399,RCXVD0,"CP",RCXVPC,"MOD",RCXVCP,0))) + . ; ^DGCR(399,D0,CP,D1,MOD,D2,0)= (#.01) CPT MODIFIER SEQUENCE [1N] + . ; (#.02) CPT ==>MODIFIER [2P:81.3] + . S RCXVP1=$P($G(^DGCR(399,RCXVD0,"CP",RCXVPC,"MOD",RCXVCP,0)),U,2) + . Q:RCXVP1="" + . S RCXVMULT=RCXVMULT+1 + . S RCXVP2=$P($G(^DIC(81.3,RCXVP1,0)),U,1) + . S ^TMP($J,RCXVBLN,"4-399A",RCXVPC,RCXVMULT)=RCXVP2 + . Q +D39942 ; CHARGES FROM 399.042 + ; LOOP THRU 399.042 + N X + S RCXVD1=$G(^DGCR(399,RCXVD0,"RC",RCXVPC,0)) + I RCXVD1="" Q + S X=$P(RCXVD1,U) + S RCXVDB=RCXVBLNA_RCXVU_$$GET1^DIQ(399.2,X_",",.01,"E") ; Revenue Code + S X=$P(RCXVD1,U,6) + S RCXVDB=RCXVDB_RCXVU_$$GET1^DIQ(81,X_",",.01,"E") ; Procedures [P] + S RCXVDB=RCXVDB_RCXVU_RCXVPCDT ; PROC. DT + S RCXVDB=RCXVDB_RCXVU_$P(RCXVD1,U,2) ; Charges + S ^TMP($J,RCXVBLN,"4-399B",RCXVPC)=RCXVDB + Q + ; diff --git a/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCXVFTP.m b/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCXVFTP.m index 847758ca..d0fe48c1 100644 --- a/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCXVFTP.m +++ b/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCXVFTP.m @@ -1,58 +1,58 @@ -RCXVFTP ;DAOU/ALA-FTP AR Data Extract Batch Files ;08-SEP-03 - ;;4.5;Accounts Receivable;**201,256**;Mar 20, 1995;Build 6 - ; - ;**Program Description** - ; This code will ftp a batch file - ; -EN(FILE,DIREC) ; - ; Input Parameter - ; FILE = Filename - ; DIREC = Directory - S RCXVPTH=$S($G(DIREC)'="":DIREC,1:RCXVDIR) - ; -SYS ; Get system type - S RCXVSYS=$$VERSION^%ZOSV(1) - I RCXVSYS["DSM" S RCXVSYS="VMS",RCXVSYT="DSM" - I RCXVSYS["MSM" D - . I RCXVSYS["NT"!(RCXVSYS["PC") S RCXVSYS="MSM",RCXVSYT="MSM" Q - . E S RCXVSYS="UNIX",RCXVSYT="MSM" - I RCXVSYS["Cache" D - . I RCXVSYS["VMS" S RCXVSYS="VMS",RCXVSYT="CACHE" Q - . S RCXVSYS="CACHE",RCXVSYT="CACHE" - ; - I RCXVSYS="VMS" S RCXVNME=FILE_";1" - I RCXVSYS'="VMS" S RCXVNME=FILE - ; -ARC ; Directly FTP to the Boston Allocation Resource Center - I $$GET1^DIQ(342,"1,",20.06,"I")="P" D - . S RCXVIP="MORPHEUS.ARC.MED.VA.GOV" - . S RCXVUSR="mccf" - . S RCXVPAS="1qaz2wsx" - ; - I $$GET1^DIQ(342,"1,",20.06,"I")'="P" D - . S RCXVIP="MORPHEUS.ARC.MED.VA.GOV" - . S RCXVUSR="cbotest1" - . S RCXVPAS="1qaz2wsx" - ; - I RCXVSYS="VMS" D ^RCXVFTV - I RCXVSYS'="VMS" D ^RCXVFTC - ; - S RCXVARRY(RCXVTXT)="",RCXVARRY(RCXVBAT)="",RCXVARRY(RCXVNME)="" - S Y=$$DEL^%ZISH(RCXVPTH,$NA(RCXVARRY)) - K RCXVARRY,%ZISHF,%ZISHO,%ZISUB,DIREC,FILE,I,RCXCT,RCXI,RCXOKAY,RCXVBAT - K RCXVFTP,RCXVHNDL,RCXVIP,RCXVNME,RCXVOUT,RCXVPAS,RCXVPTH,RCXVSCR,XMY - K RCXVSYS,RCXVSYT,RCXVTXT,RCXVUSR,RCXVVMS,CNT,QER,QFL,RCXMGRP,XMSUB - K VALMSG,RCXVROOT - Q - ; -FCK ; Check that file is ready to read - S QFL=0,CNT=0,QER=0 -FQT I QFL Q - D OPEN^%ZISH(RCXVHNDL,RCXVPTH,RCXVSCR,"R") - I POP D G FQT - . HANG 5 - . S CNT=CNT+1 - . I CNT>10 S QFL=1,QER=1 D CLOSE^%ZISH(RCXVHNDL) - S QFL=1 D CLOSE^%ZISH(RCXVHNDL) - G FQT - ; +RCXVFTP ;DAOU/ALA-FTP AR Data Extract Batch Files ;08-SEP-03 + ;;4.5;Accounts Receivable;**201**;Mar 20, 1995 + ; + ;**Program Description** + ; This code will ftp a batch file + ; +EN(FILE,DIREC) ; + ; Input Parameter + ; FILE = Filename + ; DIREC = Directory + S RCXVPTH=$S($G(DIREC)'="":DIREC,1:RCXVDIR) + ; +SYS ; Get system type + S RCXVSYS=$$VERSION^%ZOSV(1) + I RCXVSYS["DSM" S RCXVSYS="VMS",RCXVSYT="DSM" + I RCXVSYS["MSM" D + . I RCXVSYS["NT"!(RCXVSYS["PC") S RCXVSYS="MSM",RCXVSYT="MSM" Q + . E S RCXVSYS="UNIX",RCXVSYT="MSM" + I RCXVSYS["Cache" D + . I RCXVSYS["VMS" S RCXVSYS="VMS",RCXVSYT="CACHE" Q + . S RCXVSYS="CACHE",RCXVSYT="CACHE" + ; + I RCXVSYS="VMS" S RCXVNME=FILE_";1" + I RCXVSYS'="VMS" S RCXVNME=FILE + ; +ARC ; Directly FTP to the Boston Allocation Resource Center + I $$GET1^DIQ(342,"1,",20.06,"I")="P" D + . S RCXVIP="MORPHEUS.ARC.MED.VA.GOV" + . S RCXVUSR="mccf" + . S RCXVPAS="1qaz2wsx" + ; + I $$GET1^DIQ(342,"1,",20.06,"I")'="P" D + . S RCXVIP="MORPHEUS.ARC.MED.VA.GOV" + . S RCXVUSR="cbotest" + . S RCXVPAS="1qaz2wsx" + ; + I RCXVSYS="VMS" D ^RCXVFTV + I RCXVSYS'="VMS" D ^RCXVFTC + ; + S RCXVARRY(RCXVTXT)="",RCXVARRY(RCXVBAT)="",RCXVARRY(RCXVNME)="" + S Y=$$DEL^%ZISH(RCXVPTH,$NA(RCXVARRY)) + K RCXVARRY,%ZISHF,%ZISHO,%ZISUB,DIREC,FILE,I,RCXCT,RCXI,RCXOKAY,RCXVBAT + K RCXVFTP,RCXVHNDL,RCXVIP,RCXVNME,RCXVOUT,RCXVPAS,RCXVPTH,RCXVSCR,XMY + K RCXVSYS,RCXVSYT,RCXVTXT,RCXVUSR,RCXVVMS,CNT,QER,QFL,RCXMGRP,XMSUB + K VALMSG,RCXVROOT + Q + ; +FCK ; Check that file is ready to read + S QFL=0,CNT=0,QER=0 +FQT I QFL Q + D OPEN^%ZISH(RCXVHNDL,RCXVPTH,RCXVSCR,"R") + I POP D G FQT + . HANG 5 + . S CNT=CNT+1 + . I CNT>10 S QFL=1,QER=1 D CLOSE^%ZISH(RCXVHNDL) + S QFL=1 D CLOSE^%ZISH(RCXVHNDL) + G FQT + ; diff --git a/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRACMR4.m b/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRACMR4.m index 8618acba..eb2c38ae 100644 --- a/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRACMR4.m +++ b/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRACMR4.m @@ -1,75 +1,74 @@ -GMRACMR4 ;HIRMFO/WAA-PATIENT NOT ASKED ABOUT ALLERGIES ;10/1/92 - ;;4.0;Adverse Reaction Tracking;**33**;Mar 29, 1996;Build 5 -EN1 ;This is the main entry point for this program - D EN1^GMRACMR G:GMRAOUT EXIT -DEV ; *** Select output device, force queuing - S GMRAZIS="" - S:GMRASEL'="1," GMRAZIS="Q" - W !! D DEV^GMRAUTL I POP S GMRAOUT=1 G EXIT - I $D(IO("Q")) D G EXIT - . K IO("Q") - . S ZTRTN="ENTSK^GMRACMR4" - . S ZTSAVE("GMRA*")="",ZTSAVE("^TMP($J,")="" - . S ZTDESC="List of patients without ID band or Chart marked" - . D ^%ZTLOAD - . W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try later...") - . Q - E D ENTSK - Q -ENTSK U IO - D EN1^GMRACMR2,EN1^GMRACMR3 - S GMRAPAGE=0,X="NOW" D ^%DT S GMRAPDT=$$DATE^GMRAUTL1(Y) - D SITE^GMRAUTL S GMRASITE=$G(^GMRD(120.84,GMRASITE,0)) - D PRINT - G EXIT -PRINT ;PRINT THE DATE - D PRE^GMRAPNA - S GMRAHLOC="" F S GMRAHLOC=$O(^TMP($J,"GMRAWC","C",GMRAHLOC)) Q:GMRAHLOC="" S GMRAX=0 Q:GMRAOUT F S GMRAX=$O(^(GMRAHLOC,GMRAX)) Q:GMRAX<1 D Q:GMRAOUT - .S GMRA=^TMP($J,"GMRAWC",GMRAX) - .D HEAD Q:GMRAOUT - .W !!,?10,$S(GMRA="W":"WARD",GMRA="M":"MODULE",GMRA="C":"CLINIC",1:"UNKNOWN"),": ",$P(^SC(GMRAX,0),U) - .S GMRACNT=0 - .S GMRADATE=0 F S GMRADATE=$O(^TMP($J,"GMRAWC",GMRAX,GMRADATE)) Q:GMRADATE="" S (GMRAFLG,GMRADFN)=0 F S GMRADFN=$O(^TMP($J,"GMRAWC",GMRAX,GMRADATE,GMRADFN)) Q:GMRADFN<1 D Q:GMRAOUT - ..Q:'$$PRDTST^GMRAUTL1(GMRADFN) ;GMRA*4*33 Exclude test patient from report if production or legacy environment. - ..S GMRAI=0 F S GMRAI=$O(^GMR(120.8,"B",GMRADFN,GMRAI)) Q:GMRAI<1 D Q:GMRAOUT - ...Q:'$D(^GMR(120.8,GMRAI,0)) Q:$P($G(^GMR(120.86,GMRADFN,0)),U,2)'=1 - ...Q:$D(^GMR(120.8,GMRAI,"ER")) - ...Q:$P(^GMR(120.8,GMRAI,0),U,2)="" - ...S (GMRA("C"),GMRA("I"),GMRA("M"))=1 - ...I '$O(^GMR(120.8,GMRAI,13,0)) S (GMRA("C"),GMRA("M"))=0 - ...I GMRA'="W",GMRA("M") Q - ...I GMRA="W",$P(GMRASITE,U,5)'=0,'$$IDMARK^GMRACMR5(GMRADFN,GMRADATE,GMRAI) S (GMRA("I"),GMRA("M"))=0 - ...I GMRA("M") Q - ...S GMRACNT=GMRACNT+1 - ...W ! I GMRAFLG'=GMRADFN W $E($P(^DPT(GMRADFN,0),U),1,30) S (DFN,GMRAFLG)=GMRADFN S GMRAPID="" D VAD^GMRAUTL1(GMRADFN,"","","","","","","",.GMRAPID) W ?30,GMRAPID K GMRAPID - ...W ?45,$E($P(^GMR(120.8,GMRAI,0),U,2),1,20) - ...I GMRA="W" W ?66,$S(('GMRA("C")&'GMRA("I")):"ID BAND/CHART",('GMRA("C")):"CHART",('GMRA("I")):"ID BAND",1:"ERROR") - ...E W ?66,$S('GMRA("C"):"CHART",1:"ERROR") - ...I $Y>(IOSL-4) D HEAD Q:GMRAOUT - ...Q - ..Q - .D NOPAT^GMRAPNA - .Q - D CLOSE^GMRAUTL - Q -HEAD ;HEADER PAGE FOR PRINTOUT - S GMRAPAGE=GMRAPAGE+1,GMRATL="" I $E(IOST,1)="C",GMRAPAGE=1 W @IOF - I $E(IOST,1)="C",GMRAPAGE'=1 D Q:GMRAOUT - .S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1 - .K Y - .Q - W:GMRAPAGE'=1 @IOF - W !,GMRAPDT,?22,"PATIENTS WITH UNMARKED ID BAND/CHART",?70,"PAGE ",GMRAPAGE - I GMRASEL["1" S GMRATL="CURRENT INPATIENTS" - I GMRASEL["2" S GMRATL=$S(GMRATL="":"OUTPATIENTS",1:GMRATL_" / OUTPATIENTS") - I GMRASEL["3" S GMRATL=$S(GMRATL="":"NEW ADMISSIONS",1:GMRATL_" / NEW ADMISSIONS") - W !,?(40-($L(GMRATL)/2)),GMRATL - I (GMRASEL["2"!(GMRASEL["3")) W !,?22,"FROM ",$$DATE^GMRAUTL1(GMRAST),?43,"TO ",$$DATE^GMRAUTL1(GMRAED) - W !!,"PATIENT",?30,"SSN",?45,"ALLERGY",?66,"UNMARKED" - W !,$$REPEAT^XLFSTR("-",79) - I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user - Q -EXIT ; - K ^TMP($J,"GMRAWC") - D KILL^XUSCLEAN - Q +GMRACMR4 ;HIRMFO/WAA-PATIENT NOT ASKED ABOUT ALLERGIES ; 10/1/92 + ;;4.0;Adverse Reaction Tracking;;Mar 29, 1996 +EN1 ;This is the main entry point for this program + D EN1^GMRACMR G:GMRAOUT EXIT +DEV ; *** Select output device, force queueing + S GMRAZIS="" + S:GMRASEL'="1," GMRAZIS="Q" + W !! D DEV^GMRAUTL I POP S GMRAOUT=1 G EXIT + I $D(IO("Q")) D G EXIT + . K IO("Q") + . S ZTRTN="ENTSK^GMRACMR4" + . S ZTSAVE("GMRA*")="",ZTSAVE("^TMP($J,")="" + . S ZTDESC="List of patients without ID band or Chart marked" + . D ^%ZTLOAD + . W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try later...") + . Q + E D ENTSK + Q +ENTSK U IO + D EN1^GMRACMR2,EN1^GMRACMR3 + S GMRAPAGE=0,X="NOW" D ^%DT S GMRAPDT=$$DATE^GMRAUTL1(Y) + D SITE^GMRAUTL S GMRASITE=$G(^GMRD(120.84,GMRASITE,0)) + D PRINT + G EXIT +PRINT ;PRINT THE DATE + D PRE^GMRAPNA + S GMRAHLOC="" F S GMRAHLOC=$O(^TMP($J,"GMRAWC","C",GMRAHLOC)) Q:GMRAHLOC="" S GMRAX=0 Q:GMRAOUT F S GMRAX=$O(^(GMRAHLOC,GMRAX)) Q:GMRAX<1 D Q:GMRAOUT + .S GMRA=^TMP($J,"GMRAWC",GMRAX) + .D HEAD Q:GMRAOUT + .W !!,?10,$S(GMRA="W":"WARD",GMRA="M":"MODULE",GMRA="C":"CLINIC",1:"UNKNOWN"),": ",$P(^SC(GMRAX,0),U) + .S GMRACNT=0 + .S GMRADATE=0 F S GMRADATE=$O(^TMP($J,"GMRAWC",GMRAX,GMRADATE)) Q:GMRADATE="" S (GMRAFLG,GMRADFN)=0 F S GMRADFN=$O(^TMP($J,"GMRAWC",GMRAX,GMRADATE,GMRADFN)) Q:GMRADFN<1 D Q:GMRAOUT + ..S GMRAI=0 F S GMRAI=$O(^GMR(120.8,"B",GMRADFN,GMRAI)) Q:GMRAI<1 D Q:GMRAOUT + ...Q:'$D(^GMR(120.8,GMRAI,0)) Q:$P($G(^GMR(120.86,GMRADFN,0)),U,2)'=1 + ...Q:$D(^GMR(120.8,GMRAI,"ER")) + ...Q:$P(^GMR(120.8,GMRAI,0),U,2)="" + ...S (GMRA("C"),GMRA("I"),GMRA("M"))=1 + ...I '$O(^GMR(120.8,GMRAI,13,0)) S (GMRA("C"),GMRA("M"))=0 + ...I GMRA'="W",GMRA("M") Q + ...I GMRA="W",$P(GMRASITE,U,5)'=0,'$$IDMARK^GMRACMR5(GMRADFN,GMRADATE,GMRAI) S (GMRA("I"),GMRA("M"))=0 + ...I GMRA("M") Q + ...S GMRACNT=GMRACNT+1 + ...W ! I GMRAFLG'=GMRADFN W $E($P(^DPT(GMRADFN,0),U),1,30) S (DFN,GMRAFLG)=GMRADFN S GMRAPID="" D VAD^GMRAUTL1(GMRADFN,"","","","","","","",.GMRAPID) W ?30,GMRAPID K GMRAPID + ...W ?45,$E($P(^GMR(120.8,GMRAI,0),U,2),1,20) + ...I GMRA="W" W ?66,$S(('GMRA("C")&'GMRA("I")):"ID BAND/CHART",('GMRA("C")):"CHART",('GMRA("I")):"ID BAND",1:"ERROR") + ...E W ?66,$S('GMRA("C"):"CHART",1:"ERROR") + ...I $Y>(IOSL-4) D HEAD Q:GMRAOUT + ...Q + ..Q + .D NOPAT^GMRAPNA + .Q + D CLOSE^GMRAUTL + Q +HEAD ;HEADER PAGE FOR PRINTOUT + S GMRAPAGE=GMRAPAGE+1,GMRATL="" I $E(IOST,1)="C",GMRAPAGE=1 W @IOF + I $E(IOST,1)="C",GMRAPAGE'=1 D Q:GMRAOUT + .S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1 + .K Y + .Q + W:GMRAPAGE'=1 @IOF + W !,GMRAPDT,?22,"PATIENTS WITH UNMARKED ID BAND/CHART",?70,"PAGE ",GMRAPAGE + I GMRASEL["1" S GMRATL="CURRENT INPATIENTS" + I GMRASEL["2" S GMRATL=$S(GMRATL="":"OUTPATIENTS",1:GMRATL_" / OUTPATIENTS") + I GMRASEL["3" S GMRATL=$S(GMRATL="":"NEW ADMISSIONS",1:GMRATL_" / NEW ADMISSIONS") + W !,?(40-($L(GMRATL)/2)),GMRATL + I (GMRASEL["2"!(GMRASEL["3")) W !,?22,"FROM ",$$DATE^GMRAUTL1(GMRAST),?43,"TO ",$$DATE^GMRAUTL1(GMRAED) + W !!,"PATIENT",?30,"SSN",?45,"ALLERGY",?66,"UNMARKED" + W !,$$REPEAT^XLFSTR("-",79) + I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user + Q +EXIT ; + K ^TMP($J,"GMRAWC") + D KILL^XUSCLEAN + Q diff --git a/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRADSP5.m b/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRADSP5.m index 4b338d99..12522d60 100644 --- a/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRADSP5.m +++ b/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRADSP5.m @@ -1,42 +1,41 @@ -GMRADSP5 ;HIRMFO/YMP,RM,WAA-LISTING OF ALLERGIES TO SIGNED OFF ALLERGIES ;8/16/92 - ;;4.0;Adverse Reaction Tracking;**33**;Mar 29, 1996;Build 5 -EN1 ; Entry to PATIENT ALLERGIES NOT SIGNED OFF option - S GMRAOUT=0 - S GMRAHEAD(1)=$J("ALLERGY/ADVERSE REACTIONS TO BE SIGNED OFF",59),GMRAHEAD(4)=$J("ORIGINATOR",10)_$J("PATIENT",21)_$J("ALLERGY",19)_$J("ORIGINATION DATE/TIME",29),(GMRAHEAD(3),GMRAHEAD(5),GMRAHEAD(6))="",$P(GMRAHEAD(5),"-",81)="" - S GMRANOW=$$NOW^XLFDT,GMRANOW=$$FMTE^XLFDT(GMRANOW,"2P") - S GMRAHEAD(1.5)=$J("Run Date/Time: "_GMRANOW,55) - K GMRAZIS D DEV^GMRAUTL I POP S GMRAOUT=1 G EXIT - I $D(IO("Q")) D TASK G EXIT -EN2 S (GMRAORG,GMRADT)="" - F GMRAREC=0:0 S GMRAREC=$O(^GMR(120.8,"ASGN",GMRAREC)) Q:GMRAREC'>0 D EN2A - G DISP - Q -EN2A S GMRATEMP=$G(^GMR(120.8,GMRAREC,0)) Q:GMRATEMP="" - I '$D(^XUSEC("GMRA-ALLERGY VERIFY",DUZ)) Q:$P(GMRATEMP,U,5)'=DUZ - Q:'$$PRDTST^GMRAUTL1($P(GMRATEMP,U)) ;GMRA*4*33 Exclude test patient if production or legacy environment. - S DFN=$P(GMRATEMP,U) D PID^VADPT6 S GMRASSN=VA("BID") D KVA^VADPT - I $P(GMRATEMP,U,5)'="" S ^TMP($J,"GMRADSP",$P(^VA(200,$P(GMRATEMP,U,5),0),U),$P(GMRATEMP,U,5),$P(GMRATEMP,U,4),$P(GMRATEMP,U),GMRAREC)=$P(GMRATEMP,U,2)_U_$E($P(^DPT($P(GMRATEMP,U),0),U),1,14)_"("_GMRASSN_")" - Q -DISP S GMRAPG=0 D HDR^GMRADSP3 W:'$D(^TMP($J,"GMRADSP")) !!!,?7,"NO DATA FOR THIS REPORT" - S GMRAORG="" F S GMRAORG=$O(^TMP($J,"GMRADSP",GMRAORG)) Q:GMRAORG=""!GMRAOUT D Q:GMRAOUT - .S GMRAIEN="" F S GMRAIEN=$O(^TMP($J,"GMRADSP",GMRAORG,GMRAIEN)) Q:GMRAIEN=""!GMRAOUT D Q:GMRAOUT - ..S GMRADT="" F S GMRADT=$O(^TMP($J,"GMRADSP",GMRAORG,GMRAIEN,GMRADT)) Q:GMRADT=""!GMRAOUT D Q:GMRAOUT - ...S GMRADFN="" F S GMRADFN=$O(^TMP($J,"GMRADSP",GMRAORG,GMRAIEN,GMRADT,GMRADFN)) Q:GMRADFN=""!GMRAOUT D EN3 - ...Q - ..Q - .Q -EXIT ;Quit and kill - D CLOSE^GMRAUTL - K ^TMP($J,"GMRADSP"),X,Y,Z - D KILL^XUSCLEAN - Q -EN3 S GMRAPAT="" F S GMRAPAT=$O(^TMP($J,"GMRADSP",GMRAORG,GMRAIEN,GMRADT,GMRADFN,GMRAPAT)) Q:GMRAPAT=""!GMRAOUT S GMRALL=$G(^(GMRAPAT)) I GMRALL'="" D Q:GMRAOUT - .S Y=GMRADT D D^DIQ W !,$E(GMRAORG,1,15),?17,$P(GMRALL,U,2),?42,$E($P(GMRALL,U),1,16),?59,Y - .D:IOSL-4<$Y EOP^GMRADSP3 Q:GMRAOUT - .Q - Q -TASK ; - S ZTDESC="Patient reactions not signed off",ZTRTN="EN2^GMRADSP5",ZTDTH="",ZTIO=ION,ZTSAVE("GMRA*")="",ZTSAVE("DFN")="" D ^%ZTLOAD - W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try later...") - K ZTRTN,ZTDH,ZTSAVE,ZTDTH,ZTSK - Q +GMRADSP5 ;HIRMFO/YMP,RM,WAA-LISTING OF ALLERGIES TO SIGNED OFF ALLERGIES ; 8/16/92 + ;;4.0;Adverse Reaction Tracking;;Mar 29, 1996 +EN1 ; Entry to PATIENT ALLERGIES NOT SIGNED OFF option + S GMRAOUT=0 + S GMRAHEAD(1)=$J("ALLERGY/ADVERSE REACTIONS TO BE SIGNED OFF",59),GMRAHEAD(4)=$J("ORIGINATOR",10)_$J("PATIENT",21)_$J("ALLERGY",19)_$J("ORIGINATION DATE/TIME",29),(GMRAHEAD(3),GMRAHEAD(5),GMRAHEAD(6))="",$P(GMRAHEAD(5),"-",81)="" + S GMRANOW=$$NOW^XLFDT,GMRANOW=$$FMTE^XLFDT(GMRANOW,"2P") + S GMRAHEAD(1.5)=$J("Run Date/Time: "_GMRANOW,55) + K GMRAZIS D DEV^GMRAUTL I POP S GMRAOUT=1 G EXIT + I $D(IO("Q")) D TASK G EXIT +EN2 S (GMRAORG,GMRADT)="" + F GMRAREC=0:0 S GMRAREC=$O(^GMR(120.8,"ASGN",GMRAREC)) Q:GMRAREC'>0 D EN2A + G DISP + Q +EN2A S GMRATEMP=$G(^GMR(120.8,GMRAREC,0)) Q:GMRATEMP="" + I '$D(^XUSEC("GMRA-ALLERGY VERIFY",DUZ)) Q:$P(GMRATEMP,U,5)'=DUZ + S DFN=$P(GMRATEMP,U) D PID^VADPT6 S GMRASSN=VA("BID") D KVA^VADPT + I $P(GMRATEMP,U,5)'="" S ^TMP($J,"GMRADSP",$P(^VA(200,$P(GMRATEMP,U,5),0),U),$P(GMRATEMP,U,5),$P(GMRATEMP,U,4),$P(GMRATEMP,U),GMRAREC)=$P(GMRATEMP,U,2)_U_$E($P(^DPT($P(GMRATEMP,U),0),U),1,14)_"("_GMRASSN_")" + Q +DISP S GMRAPG=0 D HDR^GMRADSP3 W:'$D(^TMP($J,"GMRADSP")) !!!,?7,"NO DATA FOR THIS REPORT" + S GMRAORG="" F S GMRAORG=$O(^TMP($J,"GMRADSP",GMRAORG)) Q:GMRAORG=""!GMRAOUT D Q:GMRAOUT + .S GMRAIEN="" F S GMRAIEN=$O(^TMP($J,"GMRADSP",GMRAORG,GMRAIEN)) Q:GMRAIEN=""!GMRAOUT D Q:GMRAOUT + ..S GMRADT="" F S GMRADT=$O(^TMP($J,"GMRADSP",GMRAORG,GMRAIEN,GMRADT)) Q:GMRADT=""!GMRAOUT D Q:GMRAOUT + ...S GMRADFN="" F S GMRADFN=$O(^TMP($J,"GMRADSP",GMRAORG,GMRAIEN,GMRADT,GMRADFN)) Q:GMRADFN=""!GMRAOUT D EN3 + ...Q + ..Q + .Q +EXIT ;Quit and kill + D CLOSE^GMRAUTL + K ^TMP($J,"GMRADSP"),X,Y,Z + D KILL^XUSCLEAN + Q +EN3 S GMRAPAT="" F S GMRAPAT=$O(^TMP($J,"GMRADSP",GMRAORG,GMRAIEN,GMRADT,GMRADFN,GMRAPAT)) Q:GMRAPAT=""!GMRAOUT S GMRALL=$G(^(GMRAPAT)) I GMRALL'="" D Q:GMRAOUT + .S Y=GMRADT D D^DIQ W !,$E(GMRAORG,1,15),?17,$P(GMRALL,U,2),?42,$E($P(GMRALL,U),1,16),?59,Y + .D:IOSL-4<$Y EOP^GMRADSP3 Q:GMRAOUT + .Q + Q +TASK ; + S ZTDESC="Patient reactions not signed off",ZTRTN="EN2^GMRADSP5",ZTDTH="",ZTIO=ION,ZTSAVE("GMRA*")="",ZTSAVE("DFN")="" D ^%ZTLOAD + W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try later...") + K ZTRTN,ZTDH,ZTSAVE,ZTDTH,ZTSK + Q diff --git a/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAEF2.m b/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAEF2.m index ae68e1c3..3e02a02d 100644 --- a/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAEF2.m +++ b/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAEF2.m @@ -1,30 +1,29 @@ -GMRAEF2 ;HIRMFO/WAA-FDA EXCEPTION REPORT ;11/29/95 15:01 - ;;4.0;Adverse Reaction Tracking;**33**;Mar 29, 1996;Build 5 -EN1 ; Entry to PRINT ALL FDA EXCEPTIONS WITHIN A D/T RANGE option - S GMRAOUT=0 K DIR - S DIR(0)="DO^:DT:ETX",DIR("A")="Select Start Date" - D ^DIR K DIR - I $D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT)) S GMRAOUT=1 G EXIT - S (GMRABGDT,GMRASTDT)=Y K Y - S DIR(0)="DO^"_GMRABGDT_":NOW:ETX",DIR("A")="Select End Date",DIR("B")="T" - D ^DIR K DIR - I $D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT)) S GMRAOUT=1 G EXIT - S GMRAEDT=Y,GMRAENDT=((Y+1)-.0000001) K Y -EN2 ; - S GMRABGDT=GMRABGDT-.0000001 - F S GMRABGDT=$O(^GMR(120.8,"AODT",GMRABGDT)) Q:GMRABGDT<1 Q:GMRABGDT>GMRAENDT S GMRAIEN=0 F S GMRAIEN=$O(^GMR(120.8,"AODT",GMRABGDT,GMRAIEN)) Q:GMRAIEN<1 D - .S GMRA(0)=$G(^GMR(120.8,GMRAIEN,0)) - .Q:$P(GMRA(0),U,2)="" - .Q:$D(^GMR(120.8,GMRAIEN,"ER")) - .I $P(GMRA(0),U,6)'="o"!($P(GMRA(0),U,20)'["D") Q - .I '$P(GMRA(0),U,12) Q - .I $$CMPFDA^GMRAEF1(GMRAIEN) Q - .S GMRDFN=$P(GMRA(0),U) - .Q:'$$PRDTST^GMRAUTL1(GMRDFN) ;GMRA*4*33 Exclude test patient from report if production or legacy environment. - .S ^TMP($J,"GMRAEF",GMRDFN,GMRABGDT)=GMRAIEN - .Q - D EN1^GMRAEF -EXIT ;EXIT OF ROUTINE - K GMRAY,GMRAX,GMRAIEN,GMRDFN,GMRBGDT,GMRENDT,GMRDT,GMRAOUT - K GMRA,GMRABGDT,GMRAENDT - Q +GMRAEF2 ;HIRMFO/WAA-FDA EXCEPTION REPORT ;11/29/95 15:01 + ;;4.0;Adverse Reaction Tracking;;Mar 29, 1996 +EN1 ; Entry to PRINT ALL FDA EXCEPTIONS WITHIN A D/T RANGE option + S GMRAOUT=0 K DIR + S DIR(0)="DO^:DT:ETX",DIR("A")="Select Start Date" + D ^DIR K DIR + I $D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT)) S GMRAOUT=1 G EXIT + S (GMRABGDT,GMRASTDT)=Y K Y + S DIR(0)="DO^"_GMRABGDT_":NOW:ETX",DIR("A")="Select End Date",DIR("B")="T" + D ^DIR K DIR + I $D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT)) S GMRAOUT=1 G EXIT + S GMRAEDT=Y,GMRAENDT=((Y+1)-.0000001) K Y +EN2 ; + S GMRABGDT=GMRABGDT-.0000001 + F S GMRABGDT=$O(^GMR(120.8,"AODT",GMRABGDT)) Q:GMRABGDT<1 Q:GMRABGDT>GMRAENDT S GMRAIEN=0 F S GMRAIEN=$O(^GMR(120.8,"AODT",GMRABGDT,GMRAIEN)) Q:GMRAIEN<1 D + .S GMRA(0)=$G(^GMR(120.8,GMRAIEN,0)) + .Q:$P(GMRA(0),U,2)="" + .Q:$D(^GMR(120.8,GMRAIEN,"ER")) + .I $P(GMRA(0),U,6)'="o"!($P(GMRA(0),U,20)'["D") Q + .I '$P(GMRA(0),U,12) Q + .I $$CMPFDA^GMRAEF1(GMRAIEN) Q + .S GMRDFN=$P(GMRA(0),U) + .S ^TMP($J,"GMRAEF",GMRDFN,GMRABGDT)=GMRAIEN + .Q + D EN1^GMRAEF +EXIT ;EXIT OF ROUTINE + K GMRAY,GMRAX,GMRAIEN,GMRDFN,GMRBGDT,GMRENDT,GMRDT,GMRAOUT + K GMRA,GMRABGDT,GMRAENDT + Q diff --git a/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAFDA3.m b/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAFDA3.m index 88ab5979..206fead4 100644 --- a/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAFDA3.m +++ b/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAFDA3.m @@ -1,68 +1,67 @@ -GMRAFDA3 ;HIRMFO/WAA-DISPLAY FDA REPORT OVER DT RANGE ;12/1/95 11:34 - ;;4.0;Adverse Reaction Tracking;**33**;Mar 29, 1996;Build 5 -EN1 ; Entry for PRINT ALL FDA EVENTS WITHIN D/T RANGE option - S GMRAOUT=0 K DIR - S DIR(0)="DO^:NOW:EXT",DIR("A")="Select Start Date/Time" - D ^DIR K DIR - I $D(DIRUT) G EXIT - S GMRABGDT=Y K Y - S DIR(0)="DO^"_GMRABGDT_":NOW:EXT",DIR("A")="Select End Date/Time",DIR("B")="T" - D ^DIR K DIR - I $D(DIRUT) G EXIT - S GMRAENDT=Y K Y -EN2 ; - S GMRABGDT=GMRABGDT-.0000001 - S GMRAENDT=$S($P(GMRAENDT,".",2)="":GMRAENDT_".24",1:(GMRAENDT+.000001)) -YN F S %=1 W !,"Do you want an Abbreviated report" D YN^DICN S:%=-1 %=2,GMRAOUT=1 Q:% W !,"ENTER ""Y"" FOR YES OR ""N"" FOR NO",$C(7) - G:GMRAOUT EXIT - S GMRAYN=% -PRINTER ;Select printer - S GMRAOUT=0,GMRAPG=0 - W ! K GMRAZIS S:GMRAYN=2 GMRAZIS="QM132S60" D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" G EXIT - I $D(IO("Q")) D G EXIT - .S ZTRTN="PRINT^GMRAFDA3",ZTSAVE("GMRAPG")="",ZTSAVE("GMRAOUT")="",ZTSAVE("GMRABGDT")="",ZTSAVE("GMRAENDT")="",ZTSAVE("GMRAYN")="" - .S ZTDESC="Print FDA Report by Date/Time" D ^%ZTLOAD - .W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try later...") - .Q - U IO D PRINT U IO(0) - D CLOSE^GMRAUTL - G EXIT - Q -PRINT ;Central Print - N GMRACNT S GMRACNT=0 - S GMRAFLG=0,GMRANOW=$$NOW^XLFDT,GMRANOW=$$FMTE^XLFDT(GMRANOW,"1") - I IOST?1"C".E W @IOF - I GMRAYN=1 D HDR1 - F S GMRABGDT=$O(^GMR(120.85,"B",GMRABGDT)) Q:GMRABGDT<1!(GMRABGDT>GMRAENDT)!(GMRAOUT) S GMRAPA1=0 F S GMRAPA1=$O(^GMR(120.85,"B",GMRABGDT,GMRAPA1)) Q:GMRAPA1<1 D Q:GMRAOUT - .I +$P($G(^GMR(120.8,+$P($G(^GMR(120.85,+GMRAPA1,0)),U,15),"ER")),U,1)=1 Q - .I GMRAYN=2 D PRT^GMRAFDA1 Q - .I $Y>(IOSL-3) D HEAD Q:GMRAOUT - .S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) Q:GMRAPA1(0)="" - .S GMRAPA(0)=$G(^GMR(120.8,$P(GMRAPA1(0),U,15),0)) Q:GMRAPA(0)="" - .S DFN=$P(GMRAPA(0),U) D PID^VADPT6 - .Q:'$$PRDTST^GMRAUTL1(DFN) ;GMRA*4*33 Exclude test patient from report if production or legacy environment. - .S GMRACNT=GMRACNT+1 - .W !,$E($P(^DPT(DFN,0),U),1,23)," (",VA("PID"),")" K VA,DFN - .W ?32,$E($P(GMRAPA(0),U,2),1,28) - .W ?62 S Y=$P(GMRAPA1(0),U),Y=$$DATE^GMRAUTL1(Y) W $P(Y,":",1,2) K Y - .I $P($G(^GMR(120.85,GMRAPA1,"PTC1")),U,5) D - ..W !,?5,"(SENT TO FDA: " S Y=$P(^GMR(120.85,GMRAPA1,"PTC1"),U,5),Y=$$DATE^GMRAUTL1(Y) W $P(Y,":",1,2),")" K Y - .Q - .K GMRAPA1(0),GMRAPA(0) - .Q - I 'GMRACNT W !,?30,"NO DATA FOR THIS REPORT" - Q -HEAD ;Header Print -HDR ; - I IOST?1"C".E K DIR S DIR(0)="E" D ^DIR K DIR I Y'>0 S GMRAOUT=1 Q - W @IOF -HDR1 S GMRAPG=GMRAPG+1 - W GMRANOW,?70,"Page: ",GMRAPG - W !,?30,"FDA ABBREVIATED REPORT" - W !,"PATIENT",?32,"SUSPECTED AGENT",?62,"D/T OF EVENT" - W !,$$REPEAT^XLFSTR("-",79),! - Q -EXIT ;EXIT - K ^TMP($J,"GMRAEF") - D KILL^XUSCLEAN - Q +GMRAFDA3 ;HIRMFO/WAA-DISPLAY FDA REPORT OVER DT RANGE ;12/1/95 11:34 + ;;4.0;Adverse Reaction Tracking;;Mar 29, 1996 +EN1 ; Entry for PRINT ALL FDA EVENTS WITHIN D/T RANGE option + S GMRAOUT=0 K DIR + S DIR(0)="DO^:NOW:EXT",DIR("A")="Select Start Date/Time" + D ^DIR K DIR + I $D(DIRUT) G EXIT + S GMRABGDT=Y K Y + S DIR(0)="DO^"_GMRABGDT_":NOW:EXT",DIR("A")="Select End Date/Time",DIR("B")="T" + D ^DIR K DIR + I $D(DIRUT) G EXIT + S GMRAENDT=Y K Y +EN2 ; + S GMRABGDT=GMRABGDT-.0000001 + S GMRAENDT=$S($P(GMRAENDT,".",2)="":GMRAENDT_".24",1:(GMRAENDT+.000001)) +YN F S %=1 W !,"Do you want an Abbreviated report" D YN^DICN S:%=-1 %=2,GMRAOUT=1 Q:% W !,"ENTER ""Y"" FOR YES OR ""N"" FOR NO",$C(7) + G:GMRAOUT EXIT + S GMRAYN=% +PRINTER ;Select printer + S GMRAOUT=0,GMRAPG=0 + W ! K GMRAZIS S:GMRAYN=2 GMRAZIS="QM132S60" D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" G EXIT + I $D(IO("Q")) D G EXIT + .S ZTRTN="PRINT^GMRAFDA3",ZTSAVE("GMRAPG")="",ZTSAVE("GMRAOUT")="",ZTSAVE("GMRABGDT")="",ZTSAVE("GMRAENDT")="",ZTSAVE("GMRAYN")="" + .S ZTDESC="Print FDA Report by Date/Time" D ^%ZTLOAD + .W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try later...") + .Q + U IO D PRINT U IO(0) + D CLOSE^GMRAUTL + G EXIT + Q +PRINT ;Central Print + N GMRACNT S GMRACNT=0 + S GMRAFLG=0,GMRANOW=$$NOW^XLFDT,GMRANOW=$$FMTE^XLFDT(GMRANOW,"1") + I IOST?1"C".E W @IOF + I GMRAYN=1 D HDR1 + F S GMRABGDT=$O(^GMR(120.85,"B",GMRABGDT)) Q:GMRABGDT<1!(GMRABGDT>GMRAENDT)!(GMRAOUT) S GMRAPA1=0 F S GMRAPA1=$O(^GMR(120.85,"B",GMRABGDT,GMRAPA1)) Q:GMRAPA1<1 D Q:GMRAOUT + .I +$P($G(^GMR(120.8,+$P($G(^GMR(120.85,+GMRAPA1,0)),U,15),"ER")),U,1)=1 Q + .I GMRAYN=2 D PRT^GMRAFDA1 Q + .I $Y>(IOSL-3) D HEAD Q:GMRAOUT + .S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) Q:GMRAPA1(0)="" + .S GMRAPA(0)=$G(^GMR(120.8,$P(GMRAPA1(0),U,15),0)) Q:GMRAPA(0)="" + .S DFN=$P(GMRAPA(0),U) D PID^VADPT6 + .S GMRACNT=GMRACNT+1 + .W !,$E($P(^DPT(DFN,0),U),1,23)," (",VA("PID"),")" K VA,DFN + .W ?32,$E($P(GMRAPA(0),U,2),1,28) + .W ?62 S Y=$P(GMRAPA1(0),U),Y=$$DATE^GMRAUTL1(Y) W $P(Y,":",1,2) K Y + .I $P($G(^GMR(120.85,GMRAPA1,"PTC1")),U,5) D + ..W !,?5,"(SENT TO FDA: " S Y=$P(^GMR(120.85,GMRAPA1,"PTC1"),U,5),Y=$$DATE^GMRAUTL1(Y) W $P(Y,":",1,2),")" K Y + .Q + .K GMRAPA1(0),GMRAPA(0) + .Q + I 'GMRACNT W !,?30,"NO DATA FOR THIS REPORT" + Q +HEAD ;Header Print +HDR ; + I IOST?1"C".E K DIR S DIR(0)="E" D ^DIR K DIR I Y'>0 S GMRAOUT=1 Q + W @IOF +HDR1 S GMRAPG=GMRAPG+1 + W GMRANOW,?70,"Page: ",GMRAPG + W !,?30,"FDA ABBREVIATED REPORT" + W !,"PATIENT",?32,"SUSPECTED AGENT",?62,"D/T OF EVENT" + W !,$$REPEAT^XLFSTR("-",79),! + Q +EXIT ;EXIT + K ^TMP($J,"GMRAEF") + D KILL^XUSCLEAN + Q diff --git a/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAGUI1.m b/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAGUI1.m index ab78823c..79b16bf2 100644 --- a/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAGUI1.m +++ b/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAGUI1.m @@ -1,158 +1,157 @@ -GMRAGUI1 ;SLC/DAN - CPRS GUI support ;11/17/06 09:50 - ;;4.0;Adverse Reaction Tracking;**21,25,36,38**;Mar 29, 1996;Build 2 - ; - Q -EN1 ; GETREC, cont'd -OBSV ; Get OBSERVATIONS from file 120.85 - S STRING="~OBSERVATIONS" D NEXT - S OBSIEN=0 -OBSLOOP S OBSIEN=$O(^GMR(120.85,"C",GMRAIEN,OBSIEN)) G:OBSIEN<1 EXIT - S GMRA(1)=$G(^GMR(120.85,OBSIEN,0)) Q:'$L(GMRA(1)) - S STRING="tRecord : "_OBSIEN D NEXT - S USRNAM="" - S USR=$P(GMRA(1),U,13) I USR'="" D GETUSR - S Y=$P(GMRA(1),U,1) X ^DD("DD") - S STRING="tDate/Time of Event: "_Y D NEXT - S STRING="tObserver : "_USRNAM D NEXT - S SEVCOD=$P(GMRA(1),U,14) - S SEVER=$S(SEVCOD=1:"MILD",SEVCOD=2:"MODERATE",SEVCOD=3:"SEVERE",1:"") - S STRING="tSeverity : "_SEVER D NEXT - S Y=$P(GMRA(1),U,18) X ^DD("DD") - S STRING="tDate Reported : "_Y D NEXT - S USRNAM="" - S USR=$P(GMRA(1),U,19) I USR'="" D GETUSR - S STRING="tReporting User : "_USRNAM D NEXT - S STRING="t" F I=1:1:60 S STRING=STRING_"-" - D NEXT - G OBSLOOP -EXIT Q -NEXT ;SET ARRAY NODE AND INCREMENT ARRAY COUNTER - S @GMRARRAY@(ND)=STRING,ND=ND+1,STRING="" - Q -GETUSR S USRNAM=$$GET1^DIQ(200,USR_",",".01") - Q - ; -EIE(GMRAIEN,GMRADFN,GMRARRAY) ;Mark individual entry as entered in error - N DIE,DA,DR,Y,DIK,DFN,OROLD,VAIN,X,GMRAOUT,GMRAPA - L +^XTMP("GMRAED",GMRADFN):1 I '$T D MESS Q - S GMRAPA=GMRAIEN - S DIE="^GMR(120.8,",DA=GMRAPA,DR="15///1;22///1;23///"_@GMRARRAY@("GMRAERRDT")_";24////"_$G(@GMRARRAY@("GMRAERRBY"),.5) ;36 - D ^DIE ;Entered in error on date/time by user - I $D(@GMRARRAY@("GMRAERRCMTS")) D ADCOM(GMRAPA,"E",$NA(@GMRARRAY@("GMRAERRCMTS"))) ;add comments - I $$NKASCR^GMRANKA($P(^GMR(120.8,GMRAPA,0),U)) D - .S DIK="^GMR(120.86,",DA=$P(^GMR(120.8,GMRAPA,0),U) - .D ^DIK ;If patient's last allergy marked as entered in error then delete assessment - S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) Q:GMRAPA(0)="" - S GMRAOUT=0 - D EN1^GMRAEAB ;Sends entered in error bulletin to appropriate mail groups - D EN1^GMRAPET0(GMRADFN,GMRAPA,"E",.GMRAOUT) ;21 File Progress Note - S DFN=GMRADFN - D INP^VADPT S X=$$FIND1^DIC(101,,"BX","GMRA ENTERED IN ERROR")_";ORD(101," - D:X EN^XQOR ;Process protocols hanging off of "entered in error" protocol - L -^XTMP("GMRAED",GMRADFN) - S ORY=0_$S(+$G(GMRAPN)>0:("^"_+$G(GMRAPN)),1:"") ;38 Return IEN of progress note if created - Q - ; -ADCOM(ENTRY,TYPE,GMRACOM) ;Add comments to allergies - ; - N FDA,GMRAI,X,DIWL,DIWR - K ^UTILITY($J,"W") S DIWL=1,DIWR=60 S GMRAI=0 F S GMRAI=$O(@GMRACOM@(GMRAI)) Q:'+GMRAI S X=@GMRACOM@(GMRAI) D ^DIWP - S GMRACOM="^UTILITY($J,""W"",1)" - S FDA(120.826,"+1,"_ENTRY_",",.01)=$$NOW^XLFDT - S FDA(120.826,"+1,"_ENTRY_",",1)=DUZ - S FDA(120.826,"+1,"_ENTRY_",",1.5)=TYPE - S FDA(120.826,"+1,"_ENTRY_",",2)=GMRACOM - D UPDATE^DIE("","FDA") - Q - ; -NKA ;Change patient assessment to NKA - ; - N DA,DR,DIE,NKA,DFN - S DFN=ORDFN - L +^XTMP("GMRAED",DFN):1 I '$T D MESS Q - S NKA=$$NKA^GMRANKA(DFN) - I NKA=0 Q ;Patient is already NKA - I NKA=1 S ORY="-1^Patient has active allergies - can't mark as NKA" Q - L +^GMR(120.86,0):5 I '$T S ORY="-1^Unable to update assessment - try again." Q - I '$D(^GMR(120.86,DFN,0)) D ;Add assessment entry - .S $P(^GMR(120.86,0),U,3,4)=(DFN_"^"_($P(^GMR(120.86,0),U,4)+1)) - .S ^GMR(120.86,DFN,0)=DFN_U,^GMR(120.86,"B",DFN,DFN)="" - L -^GMR(120.86,0) L +^GMR(120.86,DFN,0):5 I '$T S ORY="-1^Unable to update assessment - try again." Q - S DIE="^GMR(120.86,",DA=DFN,DR="1////0;2////"_DUZ_";3///NOW" D ^DIE - S ORY=0 - L -^XTMP("GMRAED",DFN) - Q - ; -UPDATE(GMRAIEN,DFN,GMRARRAY) ;Add/edit allergies - N NEW,NKA,FDA,NODE,IEN,SUB,FILE,DA,DIK,SIEN,GMRAS0,GMRAIEN,GMRAL,GMRAPA,GMRAAR,GMRALL,GMRADFN,GMRAOUT,GMRAROT - S NEW='$G(GMRAIEN) - I NEW,$$DUPCHK^GMRAOR0(DFN,$P(@GMRARRAY@("GMRAGNT"),U))=1 S ORY="-1^Patient already has a "_$P(@GMRARRAY@("GMRAGNT"),U)_" reaction entered. No duplicates allowed." Q - L +^XTMP("GMRAED",DFN):1 I '$T D MESS Q - D SITE^GMRAUTL S GMRASITE(0)=$G(^GMRD(120.84,+GMRASITE,0)) - S NKA='$$NKA^GMRANKA(DFN) ;is patient NKA? - I NKA,NEW D - .S FDA(120.86,"?+"_DFN_",",.01)=DFN - .S FDA(120.86,"?+"_DFN_",",1)=1 - .S FDA(120.86,"?+"_DFN_",",2)=DUZ - .S FDA(120.86,"?+"_DFN_",",3)=$G(@GMRARRAY@("GMRAORDT"),$$NOW^XLFDT) - .S IEN(DFN)=DFN - .D UPDATE^DIE("","FDA","IEN") - K FDA,IEN - S NODE=$S($G(NEW):"+1,",1:(GMRAIEN_",")) - S:$G(NEW) FDA(120.8,NODE,.01)=DFN - I $P($G(@GMRARRAY@("GMRAGNT")),U,2)["50.67" S $P(@GMRARRAY@("GMRAGNT"),U,2)=$$TGTOG^PSNAPIS($P(@GMRARRAY@("GMRAGNT"),U))_";PSNDF(50.6," - F SUB="GMRAGNT;.02","GMRATYPE;3.1","GMRANATR;17","GMRAORIG;5","GMRAORDT;4","GMRAOBHX;6" D - .S FDA(120.8,NODE,$P(SUB,";",2))=$P(@GMRARRAY@($P(SUB,";")),U) - .I (SUB["GMRAGNT"),NEW S FDA(120.8,NODE,1)=$P(@GMRARRAY@($P(SUB,";")),U,2) - D UPDATE^DIE("","FDA","IEN") - S:NEW GMRAIEN=IEN(1) - K FDA - F SUB="GMRACHT","GMRAIDBN" D - .Q:'$D(@GMRARRAY@(SUB)) ;Stop if no updates - .S FILE=$S(SUB="GMRACHT":120.813,1:120.814) - .S FDA(FILE,"+1,"_GMRAIEN_",",.01)=@GMRARRAY@(SUB,1) - .S FDA(FILE,"+1,"_GMRAIEN_",",1)=DUZ - .D UPDATE^DIE("","FDA") - I $D(@GMRARRAY@("GMRACMTS")) D ADCOM(GMRAIEN,"O",$NA(@GMRARRAY@("GMRACMTS"))) ;Add comments if included - K FDA - S SUB=0 F S SUB=$O(@GMRARRAY@("GMRASYMP",SUB)) Q:'+SUB D - .S GMRAS0=^(SUB) ;Naked from above - .Q:$P(^(SUB),U)="" ;25 No text or free text entered so don't store - .S SIEN=$O(^GMR(120.8,GMRAIEN,10,"B",$P(GMRAS0,U),0)) - .I SIEN,$P(^GMR(120.8,GMRAIEN,10,SIEN,0),U,4)=$P(GMRAS0,U,3) Q ;Exists and nothing has changed - .I SIEN,$P(GMRAS0,U,5)="@" S DIK="^GMR(120.8,"_GMRAIEN_",",DA(1)=GMRAIEN,DA=SIEN D ^DIK Q ;Sign/symptom deleted - .S:'SIEN FDA(120.81,"+1,"_GMRAIEN_",",.01)=$S($P(GMRAS0,U)="FT":$O(^GMRD(120.83,"B","OTHER REACTION",0)),1:$P(GMRAS0,U)) - .S NODE=$S(SIEN:SIEN_","_GMRAIEN,1:"+1,"_GMRAIEN_",") - .S:$P(GMRAS0,U)="FT" FDA(120.81,NODE,1)=$P(GMRAS0,U,2) - .S FDA(120.81,NODE,2)=DUZ - .S FDA(120.81,NODE,3)=$P(GMRAS0,U,3) - .D UPDATE^DIE("","FDA","","ERR") - .S GMRAROT($P(GMRAS0,U,2))="" ;21 record s/s added - I NEW D - .S GMRALL(GMRAIEN)="" D VAD^GMRAUTL1(DFN,,.GMRALOC,.GMRANAM) D EN7^GMRAMCB ;Send mark chart/ID band bulletin if needed. - .I $P(@GMRARRAY@("GMRAOBHX"),U)="o" D ;if observed reaction add data to 120.85 - ..S GMRAOUT=0 ;21 - ..S GMRAL(GMRAIEN,"O",GMRAIEN)=$G(@GMRARRAY@("GMRARDT"))_"^"_$G(@GMRARRAY@("GMRASEVR")) - ..S GMRADFN=DFN - ..S GMRAL(GMRAIEN)="^^"_$P($G(@GMRARRAY@("GMRAGNT")),U)_"^^^^"_$G(@GMRARRAY@("GMRAORIG")) - ..M GMRAL(GMRAIEN,"S")=@GMRARRAY@("GMRASYMP") - ..S SUB=0 F S SUB=$O(GMRAL(GMRAIEN,"S",SUB)) Q:'+SUB S $P(GMRAL(GMRAIEN,"S",SUB),U,2)=$P(GMRAL(GMRAIEN,"S",SUB),U,2)_"^" S:$P(GMRAL(GMRAIEN,"S",SUB),U)="FT" $P(GMRAL(GMRAIEN,"S",SUB),U)=$O(^GMRD(120.83,"B","OTHER REACTION",0)) - ..S GMRAL=GMRAIEN - ..D ADVERSE^GMRAOR7(GMRAIEN,.GMRAL) ;adds entry to 120.85 - ..S GMRAIEN(GMRAIEN)="" ;21 - ..D EN1^GMRAPET0(GMRADFN,.GMRAIEN,"S",.GMRAOUT) ;21 File progress note - ..I $G(@GMRARRAY@("GMRATYPE"))["D" S GMRAPA=GMRAIEN D EN1^GMRAPTB ;21 Send med-watch update - .S GMRAAR=$P($G(@GMRARRAY@("GMRAGNT")),U,2),GMRAPA=GMRAIEN - .D EN1^GMRAOR9 S ^TMP($J,"GMRASF",1,GMRAPA)="" D RANGE^GMRASIGN(1) ;add ingredients/classes send appropriate bulletins - S ORY=0_$S(+$G(GMRAPN)>0:("^"_+$G(GMRAPN)),1:"") ;38 If note was created send back IEN - L -^XTMP("GMRAED",DFN) - Q - ; -MESS ;Give out locked message - N GMRAXBOS,GMRAL1,GMRAL2 - S GMRAXBOS=$$BROKER^XWBLIB ;In GUI? - S GMRAL1="Another user is editing this patient's allergy information." - S GMRAL2="Please refresh/review the patient's information before proceeding." - I 'GMRAXBOS W !,GMRAL1,!,GMRAL2 D WAIT^GMRAFX3 Q - S ORY="-1^"_GMRAL1_" "_GMRAL2 - Q +GMRAGUI1 ;SLC/DAN - CPRS GUI support ;7/13/06 14:32 + ;;4.0;Adverse Reaction Tracking;**21,25,36**;Mar 29, 1996;Build 9 + ; + Q +EN1 ; GETREC, cont'd +OBSV ; Get OBSERVATIONS from file 120.85 + S STRING="~OBSERVATIONS" D NEXT + S OBSIEN=0 +OBSLOOP S OBSIEN=$O(^GMR(120.85,"C",GMRAIEN,OBSIEN)) G:OBSIEN<1 EXIT + S GMRA(1)=$G(^GMR(120.85,OBSIEN,0)) Q:'$L(GMRA(1)) + S STRING="tRecord : "_OBSIEN D NEXT + S USRNAM="" + S USR=$P(GMRA(1),U,13) I USR'="" D GETUSR + S Y=$P(GMRA(1),U,1) X ^DD("DD") + S STRING="tDate/Time of Event: "_Y D NEXT + S STRING="tObserver : "_USRNAM D NEXT + S SEVCOD=$P(GMRA(1),U,14) + S SEVER=$S(SEVCOD=1:"MILD",SEVCOD=2:"MODERATE",SEVCOD=3:"SEVERE",1:"") + S STRING="tSeverity : "_SEVER D NEXT + S Y=$P(GMRA(1),U,18) X ^DD("DD") + S STRING="tDate Reported : "_Y D NEXT + S USRNAM="" + S USR=$P(GMRA(1),U,19) I USR'="" D GETUSR + S STRING="tReporting User : "_USRNAM D NEXT + S STRING="t" F I=1:1:60 S STRING=STRING_"-" + D NEXT + G OBSLOOP +EXIT Q +NEXT ;SET ARRAY NODE AND INCREMENT ARRAY COUNTER + S @GMRARRAY@(ND)=STRING,ND=ND+1,STRING="" + Q +GETUSR S USRNAM=$$GET1^DIQ(200,USR_",",".01") + Q + ; +EIE(GMRAIEN,GMRADFN,GMRARRAY) ;Mark individual entry as entered in error + N DIE,DA,DR,Y,DIK,DFN,OROLD,VAIN,X,GMRAOUT,GMRAPA + L +^XTMP("GMRAED",GMRADFN):1 I '$T D MESS Q + S GMRAPA=GMRAIEN + S DIE="^GMR(120.8,",DA=GMRAPA,DR="15///1;22///1;23///"_@GMRARRAY@("GMRAERRDT")_";24////"_$G(@GMRARRAY@("GMRAERRBY"),.5) ;36 + D ^DIE ;Entered in error on date/time by user + I $D(@GMRARRAY@("GMRAERRCMTS")) D ADCOM(GMRAPA,"E",$NA(@GMRARRAY@("GMRAERRCMTS"))) ;add comments + I $$NKASCR^GMRANKA($P(^GMR(120.8,GMRAPA,0),U)) D + .S DIK="^GMR(120.86,",DA=$P(^GMR(120.8,GMRAPA,0),U) + .D ^DIK ;If patient's last allergy marked as entered in error then delete assessment + S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) Q:GMRAPA(0)="" + S GMRAOUT=0 + D EN1^GMRAEAB ;Sends entered in error bulletin to appropriate mail groups + D EN1^GMRAPET0(GMRADFN,GMRAPA,"E",.GMRAOUT) ;21 File Progress Note + S DFN=GMRADFN + D INP^VADPT S X=$$FIND1^DIC(101,,"BX","GMRA ENTERED IN ERROR")_";ORD(101," + D:X EN^XQOR ;Process protocols hanging off of "entered in error" protocol + L -^XTMP("GMRAED",GMRADFN) + Q + ; +ADCOM(ENTRY,TYPE,GMRACOM) ;Add comments to allergies + ; + N FDA,GMRAI,X,DIWL,DIWR + K ^UTILITY($J,"W") S DIWL=1,DIWR=60 S GMRAI=0 F S GMRAI=$O(@GMRACOM@(GMRAI)) Q:'+GMRAI S X=@GMRACOM@(GMRAI) D ^DIWP + S GMRACOM="^UTILITY($J,""W"",1)" + S FDA(120.826,"+1,"_ENTRY_",",.01)=$$NOW^XLFDT + S FDA(120.826,"+1,"_ENTRY_",",1)=DUZ + S FDA(120.826,"+1,"_ENTRY_",",1.5)=TYPE + S FDA(120.826,"+1,"_ENTRY_",",2)=GMRACOM + D UPDATE^DIE("","FDA") + Q + ; +NKA ;Change patient assessment to NKA + ; + N DA,DR,DIE,NKA,DFN + S DFN=ORDFN + L +^XTMP("GMRAED",DFN):1 I '$T D MESS Q + S NKA=$$NKA^GMRANKA(DFN) + I NKA=0 Q ;Patient is already NKA + I NKA=1 S ORY="-1^Patient has active allergies - can't mark as NKA" Q + L +^GMR(120.86,0):5 I '$T S ORY="-1^Unable to update assessment - try again." Q + I '$D(^GMR(120.86,DFN,0)) D ;Add assessment entry + .S $P(^GMR(120.86,0),U,3,4)=(DFN_"^"_($P(^GMR(120.86,0),U,4)+1)) + .S ^GMR(120.86,DFN,0)=DFN_U,^GMR(120.86,"B",DFN,DFN)="" + L -^GMR(120.86,0) L +^GMR(120.86,DFN,0):5 I '$T S ORY="-1^Unable to update assessment - try again." Q + S DIE="^GMR(120.86,",DA=DFN,DR="1////0;2////"_DUZ_";3///NOW" D ^DIE + S ORY=0 + L -^XTMP("GMRAED",DFN) + Q + ; +UPDATE(GMRAIEN,DFN,GMRARRAY) ;Add/edit allergies + N NEW,NKA,FDA,NODE,IEN,SUB,FILE,DA,DIK,SIEN,GMRAS0,GMRAIEN,GMRAL,GMRAPA,GMRAAR,GMRALL,GMRADFN,GMRAOUT,GMRAROT + S NEW='$G(GMRAIEN) + I NEW,$$DUPCHK^GMRAOR0(DFN,$P(@GMRARRAY@("GMRAGNT"),U))=1 S ORY="-1^Patient already has a "_$P(@GMRARRAY@("GMRAGNT"),U)_" reaction entered. No duplicates allowed." Q + L +^XTMP("GMRAED",DFN):1 I '$T D MESS Q + D SITE^GMRAUTL S GMRASITE(0)=$G(^GMRD(120.84,+GMRASITE,0)) + S NKA='$$NKA^GMRANKA(DFN) ;is patient NKA? + I NKA,NEW D + .S FDA(120.86,"?+"_DFN_",",.01)=DFN + .S FDA(120.86,"?+"_DFN_",",1)=1 + .S FDA(120.86,"?+"_DFN_",",2)=DUZ + .S FDA(120.86,"?+"_DFN_",",3)=$G(@GMRARRAY@("GMRAORDT"),$$NOW^XLFDT) + .S IEN(DFN)=DFN + .D UPDATE^DIE("","FDA","IEN") + K FDA,IEN + S NODE=$S($G(NEW):"+1,",1:(GMRAIEN_",")) + S:$G(NEW) FDA(120.8,NODE,.01)=DFN + I $P($G(@GMRARRAY@("GMRAGNT")),U,2)["50.67" S $P(@GMRARRAY@("GMRAGNT"),U,2)=$$TGTOG^PSNAPIS($P(@GMRARRAY@("GMRAGNT"),U))_";PSNDF(50.6," + F SUB="GMRAGNT;.02","GMRATYPE;3.1","GMRANATR;17","GMRAORIG;5","GMRAORDT;4","GMRAOBHX;6" D + .S FDA(120.8,NODE,$P(SUB,";",2))=$P(@GMRARRAY@($P(SUB,";")),U) + .I (SUB["GMRAGNT"),NEW S FDA(120.8,NODE,1)=$P(@GMRARRAY@($P(SUB,";")),U,2) + D UPDATE^DIE("","FDA","IEN") + S:NEW GMRAIEN=IEN(1) + K FDA + F SUB="GMRACHT","GMRAIDBN" D + .Q:'$D(@GMRARRAY@(SUB)) ;Stop if no updates + .S FILE=$S(SUB="GMRACHT":120.813,1:120.814) + .S FDA(FILE,"+1,"_GMRAIEN_",",.01)=@GMRARRAY@(SUB,1) + .S FDA(FILE,"+1,"_GMRAIEN_",",1)=DUZ + .D UPDATE^DIE("","FDA") + I $D(@GMRARRAY@("GMRACMTS")) D ADCOM(GMRAIEN,"O",$NA(@GMRARRAY@("GMRACMTS"))) ;Add comments if included + K FDA + S SUB=0 F S SUB=$O(@GMRARRAY@("GMRASYMP",SUB)) Q:'+SUB D + .S GMRAS0=^(SUB) ;Naked from above + .Q:$P(^(SUB),U)="" ;25 No text or free text entered so don't store + .S SIEN=$O(^GMR(120.8,GMRAIEN,10,"B",$P(GMRAS0,U),0)) + .I SIEN,$P(^GMR(120.8,GMRAIEN,10,SIEN,0),U,4)=$P(GMRAS0,U,3) Q ;Exists and nothing has changed + .I SIEN,$P(GMRAS0,U,5)="@" S DIK="^GMR(120.8,"_GMRAIEN_",",DA(1)=GMRAIEN,DA=SIEN D ^DIK Q ;Sign/symptom deleted + .S:'SIEN FDA(120.81,"+1,"_GMRAIEN_",",.01)=$S($P(GMRAS0,U)="FT":$O(^GMRD(120.83,"B","OTHER REACTION",0)),1:$P(GMRAS0,U)) + .S NODE=$S(SIEN:SIEN_","_GMRAIEN,1:"+1,"_GMRAIEN_",") + .S:$P(GMRAS0,U)="FT" FDA(120.81,NODE,1)=$P(GMRAS0,U,2) + .S FDA(120.81,NODE,2)=DUZ + .S FDA(120.81,NODE,3)=$P(GMRAS0,U,3) + .D UPDATE^DIE("","FDA","","ERR") + .S GMRAROT($P(GMRAS0,U,2))="" ;21 record s/s added + I NEW D + .S GMRALL(GMRAIEN)="" D VAD^GMRAUTL1(DFN,,.GMRALOC,.GMRANAM) D EN7^GMRAMCB ;Send mark chart/ID band bulletin if needed. + .I $P(@GMRARRAY@("GMRAOBHX"),U)="o" D ;if observed reaction add data to 120.85 + ..S GMRAOUT=0 ;21 + ..S GMRAL(GMRAIEN,"O",GMRAIEN)=$G(@GMRARRAY@("GMRARDT"))_"^"_$G(@GMRARRAY@("GMRASEVR")) + ..S GMRADFN=DFN + ..S GMRAL(GMRAIEN)="^^"_$P($G(@GMRARRAY@("GMRAGNT")),U)_"^^^^"_$G(@GMRARRAY@("GMRAORIG")) + ..M GMRAL(GMRAIEN,"S")=@GMRARRAY@("GMRASYMP") + ..S SUB=0 F S SUB=$O(GMRAL(GMRAIEN,"S",SUB)) Q:'+SUB S $P(GMRAL(GMRAIEN,"S",SUB),U,2)=$P(GMRAL(GMRAIEN,"S",SUB),U,2)_"^" S:$P(GMRAL(GMRAIEN,"S",SUB),U)="FT" $P(GMRAL(GMRAIEN,"S",SUB),U)=$O(^GMRD(120.83,"B","OTHER REACTION",0)) + ..S GMRAL=GMRAIEN + ..D ADVERSE^GMRAOR7(GMRAIEN,.GMRAL) ;adds entry to 120.85 + ..S GMRAIEN(GMRAIEN)="" ;21 + ..D EN1^GMRAPET0(GMRADFN,.GMRAIEN,"S",.GMRAOUT) ;21 File progress note + ..I $G(@GMRARRAY@("GMRATYPE"))["D" S GMRAPA=GMRAIEN D EN1^GMRAPTB ;21 Send med-watch update + .S GMRAAR=$P($G(@GMRARRAY@("GMRAGNT")),U,2),GMRAPA=GMRAIEN + .D EN1^GMRAOR9 S ^TMP($J,"GMRASF",1,GMRAPA)="" D RANGE^GMRASIGN(1) ;add ingredients/classes send appropriate bulletins + S ORY=0 + L -^XTMP("GMRAED",DFN) + Q + ; +MESS ;Give out locked message + N GMRAXBOS,GMRAL1,GMRAL2 + S GMRAXBOS=$$BROKER^XWBLIB ;In GUI? + S GMRAL1="Another user is editing this patient's allergy information." + S GMRAL2="Please refresh/review the patient's information before proceeding." + I 'GMRAXBOS W !,GMRAL1,!,GMRAL2 D WAIT^GMRAFX3 Q + S ORY="-1^"_GMRAL1_" "_GMRAL2 + Q diff --git a/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPET0.m b/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPET0.m index 22bab39d..c5fec5be 100644 --- a/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPET0.m +++ b/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPET0.m @@ -1,121 +1,121 @@ -GMRAPET0 ;HIRMFO/RM-VERIFIED ALLERGY TASKS ;11/17/06 10:27 - ;;4.0;Adverse Reaction Tracking;**6,17,21,20,38**;Mar 29, 1996;Build 2 -EN1(GMRADFN,GMRAPA,GMRACT,GMRAOUT) ; - ; ENTRY TO PERFORM ALL OF THE TASKS NECESSARY FOR - ; A PROGRESS NOTE TO BE ENTERED BY ART - ; INPUT: - ; GMRADFN = PATIENT IEN IN THE PATIENT FILE - ; GMRAPA = THE IEN IN THE PATIENT ALLERGY FILE - ; GMRACT = THE ACTION TO BE ENTERED FOR THIS REACTION - ; = "V" VERIFICATION OF A REACTION - ; = "S" SIGN OFF OF A REACTION - ; = "M" MEDWATCH FORM ENTERD - ; = "E" REACTION ENERED IN ERROR - ; OUTPUT: - ; GMRAOUT = REACTION ALL WAS PASSED - ; = 1 USER ABORT OR PN FAIL IN SOME WAY - ; = 0 PASSED - ; - ; VARABLE LIST - ; GMRACW = IS THE PROGRESS NOTE TITLE - ; GMRALOC = IS THE LOCATION OF THE PATIENT - ; GMRAHLOC = IS THE LOCATION IN FILE 44 - ; GMRADFN = IS THE PATIENT IEN - ; GMRADT = IS THE DATE THE EVENT TOOK PLACE - ; GMRADUZ = IS THE USER WHO ENTERED THE INFORMATION - ; GMRAPN = IS THE IEN OF THE PROGRESS NOTE THAT WAS ENTERED - ; - ;CHECKING FOR A VALID TITLE - K ^TMP("TIUP",$J),GMRAPN - N GMRACW,GMRALOC,GMRAHLOC,GMRAXBOS ;21 - S GMRAPN=-1,GMRAXBOS=$$BROKER^XWBLIB ;21 Got GUI? - I "VSME"'[GMRACT S GMRAOUT=1 D EXIT Q - ; The following lines of code which reference Progress Notes files and - ; routines will have to change when TIU replaces Progress Notes. - ;S GMRACW=0 F S GMRACW=$O(^GMR(121.2,"B","ADVERSE REACTION/ALLERGY",GMRACW)) Q:GMRACW<1 I $P($G(^GMR(121.1,$P($G(^GMR(121.2,GMRACW,0)),U,2),0)),U)="GENERAL NOTE" Q - ;-----ADDED BY VAUGHN 1/13/97 FOR TIU REPLACES LINE ABOVE---- - S GMRACW=+$$WHATITLE^TIUPUTU("ADVERSE REACTION/ALLERGY") - ;------END--- - ;-----CHANGED BY VAUGHN 1/13/97 FOR TIU--- - I GMRACW<1!($T(NEW^TIUPNAPI)']"")!('$$CANPICK^TIULP(GMRACW)) S GMRAOUT=1 D EXIT Q ;21 - ;I GMRACW<1!($T(PN^GMRPART)']"") S GMRAOUT=1 D EXIT Q - ;-----END---- - D @GMRACT I GMRAOUT D EXIT Q ; THIS TELL'S THE PROGRAM WHERE TO GO - S GMRALOC="" - D VAD^GMRAUTL1(GMRADFN,"",.GMRALOC,"","","") - I GMRALOC'="" S GMRAHLOC=+$G(^DIC(42,GMRALOC,44)) - ;E I '$G(GMRAXBOS) D ASK ;20 - ; Call to Progress Notes - ; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv - ;S:'GMRAOUT GMRAPN=+$$PN^GMRPART(GMRADFN,GMRADUZ,GMRADT,GMRACW,GMRAHLOC) - ;---REPLACED LINE ABOVE WITH LINE BELOW;1/13/97 VAUGHN--- - I 'GMRAOUT D - .S GMRAPN=0 D NEW^TIUPNAPI(.GMRAPN,GMRADFN,GMRADUZ,GMRADT,GMRACW,$G(GMRAHLOC),$S($G(GMRAXBOS):0,1:1)) ;17,21 Allow editing if not in GUI - ;----------END------- - I GMRAPN=-1,'$G(GMRAXBOS) S GMRAOUT=1 W !,"No Progress Note was created." ;21 - I GMRAPN=0,'$G(GMRAXBOS) W !,"Progress note has not been signed." ;21 - D EXIT - Q -EXIT ; Clean up of variables - K ^TMP("TIUP",$J),GMRALOC,GMRAHLOC,GMRADUZ ;38 Removed variable GMRAPN from list of variables to kill - Q -ASK ; Simple file manager query for a location in file 44 - N DIC - S X="" - S DIC=44,DIC(0)="AEQ",DIC("A")="Select a Hospital Location: ",DIC("S")="I ""CMW""[$P(^(0),U,3)" ;20 - W !,"A progress note is being created because you "_$S(GMRACT="V":"verified",GMRACT="E":"inactivated",GMRACT="S":"activated",1:"entered a medwatch form for"),!,$P($G(^GMR(120.8,GMRAPA,0)),U,2),"." ;20 - W !,"Enter a hospital location to be associated with this note." ;20 - D ^DIC - I $D(DTOUT)!($D(DUOUT)) S GMRAOUT=1 Q - S GMRAHLOC=+Y - Q -V ; Verified Reaction - N GMRAI ;21 - S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) - S GMRADT=$P(GMRAPA(0),U,17),GMRADUZ=$P(GMRAPA(0),U,18) - S:GMRADUZ="" GMRADUZ=DUZ ; Autoverified reaction being reverified - S ^TMP("TIUP",$J,1,0)="This patient has had an "_$S($P(GMRAPA(0),"^",14)="P":"adverse reaction reported for ",1:"allergy to ")_$P(GMRAPA(0),"^",2) - S ^TMP("TIUP",$J,2,0)="verified on "_$$FMTE^XLFDT(GMRADT,1)_"." - S GMRAI=2 D ADDCOM("V",.GMRAI) ;21 - S ^TMP("TIUP",$J,0)=U_U_GMRAI_U_GMRAI_U_GMRADT_"^^^" ;21 - Q -S ; Signed Reaction - N GMRAI,GMRAREAC ;21 - D NOW^%DTC - S GMRADT=%,GMRADUZ=DUZ - S GMRAREAC=0,GMRAI=3 F S GMRAREAC=$O(GMRAPA(GMRAREAC)) Q:GMRAREAC<1 S GMRAI=GMRAI+1,^TMP("TIUP",$J,GMRAI,0)=$P($G(^GMR(120.8,GMRAREAC,0)),U,2) S GMRAPA=GMRAREAC D ;21 - .D ADDCOM("O",.GMRAI) ;21 - .S GMRAI=GMRAI+1,^TMP("TIUP",$J,GMRAI,0)="" ;21 - S ^TMP("TIUP",$J,1,0)="This patient has had the following reaction"_$S(GMRAI=3:" ",1:"s ") - S ^TMP("TIUP",$J,2,0)="signed-off on "_$$FMTE^XLFDT(GMRADT,1)_"." - S ^TMP("TIUP",$J,3,0)="" ;21 - S ^TMP("TIUP",$J,0)=U_U_GMRAI_U_GMRAI_U_GMRADT_"^^^" - Q -M ; MedWATCH data entered - N X - S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) - D NOW^%DTC - S GMRADT=%,GMRADUZ=DUZ - S ^TMP("TIUP",$J,1,0)="This patient has had a MEDWatch report completed on "_$$FMTE^XLFDT(GMRADT,1)_" for" - S ^TMP("TIUP",$J,2,0)=$S($P(GMRAPA(0),"^",14)="P":"an adverse reaction to ",1:"allergy to ")_$P(GMRAPA(0),"^",2)_"." - S ^TMP("TIUP",$J,0)=U_U_"2"_U_"2"_U_GMRADT_"^^^" - Q -E ; Reaction Entered in Error - N GMRAER,GMRAI ;21 - S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) - S GMRAER=$G(^GMR(120.8,GMRAPA,"ER")) I GMRAER="" S GMRAOUT=1 Q - S GMRADT=$P(GMRAER,U,2),GMRADUZ=$P(GMRAER,U,3) - S ^TMP("TIUP",$J,1,0)="The "_$S($P(GMRAPA(0),"^",14)="P":"adverse reaction ",1:"allergy ")_"to "_$P(GMRAPA(0),"^",2)_" was removed on "_$$FMTE^XLFDT($P(GMRADT,"."),2)_"." ;20 - S ^TMP("TIUP",$J,2,0)="This reaction was either an erroneous entry or was found" ;20 - S ^TMP("TIUP",$J,3,0)="to no longer be a true "_$S($P(GMRAPA(0),"^",14)="P":"adverse reaction",1:"allergy")_"." ;20 - S GMRAI=3 D ADDCOM("E",.GMRAI) ;21,20 - S ^TMP("TIUP",$J,0)=U_U_GMRAI_U_GMRAI_U_GMRADT_"^^^" ;21 - Q - ; -ADDCOM(TYPE,CNT) ;Add any comments to progress note - section added in patch 21 - N SUB,ENTRY - S ENTRY=$O(^GMR(120.8,GMRAPA,26,"AVER",TYPE,0)) Q:'+ENTRY - S CNT=CNT+1,^TMP("TIUP",$J,CNT,0)="",CNT=CNT+1,^TMP("TIUP",$J,CNT,0)="Author's comments:" - S CNT=CNT+1,^TMP("TIUP",$J,CNT,0)="" - S SUB=0 F S SUB=$O(^GMR(120.8,GMRAPA,26,ENTRY,2,SUB)) Q:'+SUB S CNT=CNT+1,^TMP("TIUP",$J,CNT,0)=^GMR(120.8,GMRAPA,26,ENTRY,2,SUB,0) - Q +GMRAPET0 ;HIRMFO/RM-VERIFIED ALLERGY TASKS ;4/7/06 12:38 + ;;4.0;Adverse Reaction Tracking;**6,17,21,20**;Mar 29, 1996;Build 1 +EN1(GMRADFN,GMRAPA,GMRACT,GMRAOUT) ; + ; ENTRY TO PERFORM ALL OF THE TASKS NECESSARY FOR + ; A PROGRESS NOTE TO BE ENTERED BY ART + ; INPUT: + ; GMRADFN = PATIENT IEN IN THE PATIENT FILE + ; GMRAPA = THE IEN IN THE PATIENT ALLERGY FILE + ; GMRACT = THE ACTION TO BE ENTERED FOR THIS REACTION + ; = "V" VERIFICATION OF A REACTION + ; = "S" SIGN OFF OF A REACTION + ; = "M" MEDWATCH FORM ENTERD + ; = "E" REACTION ENERED IN ERROR + ; OUTPUT: + ; GMRAOUT = REACTION ALL WAS PASSED + ; = 1 USER ABORT OR PN FAIL IN SOME WAY + ; = 0 PASSED + ; + ; VARABLE LIST + ; GMRACW = IS THE PROGRESS NOTE TITLE + ; GMRALOC = IS THE LOCATION OF THE PATIENT + ; GMRAHLOC = IS THE LOCATION IN FILE 44 + ; GMRADFN = IS THE PATIENT IEN + ; GMRADT = IS THE DATE THE EVENT TOOK PLACE + ; GMRADUZ = IS THE USER WHO ENTERED THE INFORMATION + ; GMRAPN = IS THE IEN OF THE PROGRESS NOTE THAT WAS ENTERED + ; + ;CHECKING FOR A VALID TITLE + K ^TMP("TIUP",$J),GMRAPN + N GMRACW,GMRALOC,GMRAHLOC,GMRAXBOS ;21 + S GMRAPN=-1,GMRAXBOS=$$BROKER^XWBLIB ;21 Got GUI? + I "VSME"'[GMRACT S GMRAOUT=1 D EXIT Q + ; The following lines of code which reference Progress Notes files and + ; routines will have to change when TIU replaces Progress Notes. + ;S GMRACW=0 F S GMRACW=$O(^GMR(121.2,"B","ADVERSE REACTION/ALLERGY",GMRACW)) Q:GMRACW<1 I $P($G(^GMR(121.1,$P($G(^GMR(121.2,GMRACW,0)),U,2),0)),U)="GENERAL NOTE" Q + ;-----ADDED BY VAUGHN 1/13/97 FOR TIU REPLACES LINE ABOVE---- + S GMRACW=+$$WHATITLE^TIUPUTU("ADVERSE REACTION/ALLERGY") + ;------END--- + ;-----CHANGED BY VAUGHN 1/13/97 FOR TIU--- + I GMRACW<1!($T(NEW^TIUPNAPI)']"")!('$$CANPICK^TIULP(GMRACW)) S GMRAOUT=1 D EXIT Q ;21 + ;I GMRACW<1!($T(PN^GMRPART)']"") S GMRAOUT=1 D EXIT Q + ;-----END---- + D @GMRACT I GMRAOUT D EXIT Q ; THIS TELL'S THE PROGRAM WHERE TO GO + S GMRALOC="" + D VAD^GMRAUTL1(GMRADFN,"",.GMRALOC,"","","") + I GMRALOC'="" S GMRAHLOC=+$G(^DIC(42,GMRALOC,44)) + ;E I '$G(GMRAXBOS) D ASK ;20 + ; Call to Progress Notes + ; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv + ;S:'GMRAOUT GMRAPN=+$$PN^GMRPART(GMRADFN,GMRADUZ,GMRADT,GMRACW,GMRAHLOC) + ;---REPLACED LINE ABOVE WITH LINE BELOW;1/13/97 VAUGHN--- + I 'GMRAOUT D + .S GMRAPN=0 D NEW^TIUPNAPI(.GMRAPN,GMRADFN,GMRADUZ,GMRADT,GMRACW,$G(GMRAHLOC),$S($G(GMRAXBOS):0,1:1)) ;17,21 Allow editing if not in GUI + ;----------END------- + I GMRAPN=-1,'$G(GMRAXBOS) S GMRAOUT=1 W !,"No Progress Note was created." ;21 + I GMRAPN=0,'$G(GMRAXBOS) W !,"Progress note has not been signed." ;21 + D EXIT + Q +EXIT ; Clean up of variables + K ^TMP("TIUP",$J),GMRAPN,GMRALOC,GMRAHLOC,GMRADUZ + Q +ASK ; Simple file manager query for a location in file 44 + N DIC + S X="" + S DIC=44,DIC(0)="AEQ",DIC("A")="Select a Hospital Location: ",DIC("S")="I ""CMW""[$P(^(0),U,3)" ;20 + W !,"A progress note is being created because you "_$S(GMRACT="V":"verified",GMRACT="E":"inactivated",GMRACT="S":"activated",1:"entered a medwatch form for"),!,$P($G(^GMR(120.8,GMRAPA,0)),U,2),"." ;20 + W !,"Enter a hospital location to be associated with this note." ;20 + D ^DIC + I $D(DTOUT)!($D(DUOUT)) S GMRAOUT=1 Q + S GMRAHLOC=+Y + Q +V ; Verified Reaction + N GMRAI ;21 + S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) + S GMRADT=$P(GMRAPA(0),U,17),GMRADUZ=$P(GMRAPA(0),U,18) + S:GMRADUZ="" GMRADUZ=DUZ ; Autoverified reaction being reverified + S ^TMP("TIUP",$J,1,0)="This patient has had an "_$S($P(GMRAPA(0),"^",14)="P":"adverse reaction reported for ",1:"allergy to ")_$P(GMRAPA(0),"^",2) + S ^TMP("TIUP",$J,2,0)="verified on "_$$FMTE^XLFDT(GMRADT,1)_"." + S GMRAI=2 D ADDCOM("V",.GMRAI) ;21 + S ^TMP("TIUP",$J,0)=U_U_GMRAI_U_GMRAI_U_GMRADT_"^^^" ;21 + Q +S ; Signed Reaction + N GMRAI,GMRAREAC ;21 + D NOW^%DTC + S GMRADT=%,GMRADUZ=DUZ + S GMRAREAC=0,GMRAI=3 F S GMRAREAC=$O(GMRAPA(GMRAREAC)) Q:GMRAREAC<1 S GMRAI=GMRAI+1,^TMP("TIUP",$J,GMRAI,0)=$P($G(^GMR(120.8,GMRAREAC,0)),U,2) S GMRAPA=GMRAREAC D ;21 + .D ADDCOM("O",.GMRAI) ;21 + .S GMRAI=GMRAI+1,^TMP("TIUP",$J,GMRAI,0)="" ;21 + S ^TMP("TIUP",$J,1,0)="This patient has had the following reaction"_$S(GMRAI=3:" ",1:"s ") + S ^TMP("TIUP",$J,2,0)="signed-off on "_$$FMTE^XLFDT(GMRADT,1)_"." + S ^TMP("TIUP",$J,3,0)="" ;21 + S ^TMP("TIUP",$J,0)=U_U_GMRAI_U_GMRAI_U_GMRADT_"^^^" + Q +M ; MedWATCH data entered + N X + S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) + D NOW^%DTC + S GMRADT=%,GMRADUZ=DUZ + S ^TMP("TIUP",$J,1,0)="This patient has had a MEDWatch report completed on "_$$FMTE^XLFDT(GMRADT,1)_" for" + S ^TMP("TIUP",$J,2,0)=$S($P(GMRAPA(0),"^",14)="P":"an adverse reaction to ",1:"allergy to ")_$P(GMRAPA(0),"^",2)_"." + S ^TMP("TIUP",$J,0)=U_U_"2"_U_"2"_U_GMRADT_"^^^" + Q +E ; Reaction Entered in Error + N GMRAER,GMRAI ;21 + S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) + S GMRAER=$G(^GMR(120.8,GMRAPA,"ER")) I GMRAER="" S GMRAOUT=1 Q + S GMRADT=$P(GMRAER,U,2),GMRADUZ=$P(GMRAER,U,3) + S ^TMP("TIUP",$J,1,0)="The "_$S($P(GMRAPA(0),"^",14)="P":"adverse reaction ",1:"allergy ")_"to "_$P(GMRAPA(0),"^",2)_" was removed on "_$$FMTE^XLFDT($P(GMRADT,"."),2)_"." ;20 + S ^TMP("TIUP",$J,2,0)="This reaction was either an erroneous entry or was found" ;20 + S ^TMP("TIUP",$J,3,0)="to no longer be a true "_$S($P(GMRAPA(0),"^",14)="P":"adverse reaction",1:"allergy")_"." ;20 + S GMRAI=3 D ADDCOM("E",.GMRAI) ;21,20 + S ^TMP("TIUP",$J,0)=U_U_GMRAI_U_GMRAI_U_GMRADT_"^^^" ;21 + Q + ; +ADDCOM(TYPE,CNT) ;Add any comments to progress note - section added in patch 21 + N SUB,ENTRY + S ENTRY=$O(^GMR(120.8,GMRAPA,26,"AVER",TYPE,0)) Q:'+ENTRY + S CNT=CNT+1,^TMP("TIUP",$J,CNT,0)="",CNT=CNT+1,^TMP("TIUP",$J,CNT,0)="Author's comments:" + S CNT=CNT+1,^TMP("TIUP",$J,CNT,0)="" + S SUB=0 F S SUB=$O(^GMR(120.8,GMRAPA,26,ENTRY,2,SUB)) Q:'+SUB S CNT=CNT+1,^TMP("TIUP",$J,CNT,0)=^GMR(120.8,GMRAPA,26,ENTRY,2,SUB,0) + Q diff --git a/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPFT.m b/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPFT.m index 7c8b27df..6b9c150a 100644 --- a/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPFT.m +++ b/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPFT.m @@ -1,83 +1,82 @@ -GMRAPFT ;HIRMFO/WAA- PRINT FDA REACTION BY DATE ENTERED/TRACKED ;4/10/97 09:30 - ;;4.0;Adverse Reaction Tracking;**7,33**;Mar 29, 1996;Build 5 -EN1 ; This routine will loop through the ADT entry point to get all - ; the entries in that date range. - S GMRAOUT=0 - W !,"Select a Tracking date range for this report." - D DT^GMRAPL G:GMRAOUT EXIT - D PRINTER -EXIT ; Exit of program kill cleanup - D KILL^XUSCLEAN - Q -PRINTER ;Select printer - W ! K GMRAZIS D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q - I $D(IO("Q")) D Q - . S ZTRTN="PRINT^GMRAPFT",(ZTSAVE("GMRAOUT"),ZTSAVE("GMAST"),ZTSAVE("GMAEN"))="" - . S ZTDESC="List of FDA Reactions over a Date range by Tracking date" D ^%ZTLOAD - . W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.") - . Q - U IO D PRINT U IO(0) - D EXIT - Q -PRINT ;Queue point for report - D NOW^%DTC S GMRADPDT=X - S GMRADATE=GMAST-.0001,GMRAPG=1 - F S GMRADATE=$O(^GMR(120.85,"ARDT",GMRADATE)) Q:GMRADATE<1 Q:GMRADATE>GMAEN D Q:GMRAOUT - .S GMRAPA1=0 - .F S GMRAPA1=$O(^GMR(120.85,"ARDT",GMRADATE,GMRAPA1)) Q:GMRAPA1<1 D Q:GMRAOUT - ..S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) Q:GMRAPA1(0)="" - ..Q:+$G(^GMR(120.8,$P(GMRAPA1(0),U,15),"ER")) ;data entered in error - ..D HEAD Q:GMRAOUT - ..S (GMRAPID,GMRANAME,GMRALOC)="" - ..S GMRADFN=$P(GMRAPA1(0),U,2),GMRADDT=$P(GMRAPA1(0),U) - ..Q:'$$PRDTST^GMRAUTL1(GMRADFN) ;GMRA*4*33 Exclude test patient from report if production or legacy system. - ..D VAD^GMRAUTL1(GMRADFN,GMRADDT,.GMRALOC,.GMRANAME,"",.GMRAPID) - ..I GMRALOC="" S GMRALOC="OUT PATIENT" - ..E S GMRALOC=$P($G(^DIC(42,GMRALOC,0)),U) - ..W !,$E(GMRANAME,1,30) ; Patient Name - ..K GMRARAC - ..S GMRARAC=0,GMRACNT=1 F S GMRARAC=$O(^GMR(120.85,GMRAPA1,3,GMRARAC)) Q:GMRARAC<1 D - ...S GMRARAC(GMRACNT)=$P($G(^GMR(120.85,GMRAPA1,3,GMRARAC,0)),U) Q:GMRARAC(GMRACNT)="" - ...S GMRACNT=GMRACNT+1 - ...Q - ..W ?32,"Obs DT: ",$$FMTE^XLFDT($P(GMRAPA1(0),U),"2D") ; Observed Date - ..W ?49,$E($G(GMRARAC(1)),1,30) ; The 1st reaction that is listed first - ..W !,"(",GMRAPID,")" - ..W ?32,"Trk DT: ",$$FMTE^XLFDT($P(GMRAPA1(0),U,18),"2D") ; Tracking Date - ..W ?49,$E($G(GMRARAC(2)),1,30) ; The 2nd reaction that is listed - ..W !,"Loc: ",GMRALOC - ..W ?32,"-------------" ; Separator - ..W ?49,$E($G(GMRARAC(3)),1,30) ; The 3rd reaction that is listed - ..W !,"Obs: ",$P($G(^VA(200,$P(GMRAPA1(0),U,19),0)),U) ; User entered - ..D - ...N X1,X2,X,Y - ...S X2=$P(GMRAPA1(0),U),X1=$P(GMRAPA1(0),U,18) - ...D ^%DTC - ...W ?32,X," Days Difference" ;Difference - ...Q - ..W ?50,$E($G(GMRARAC(4)),1,30) ; The 4th reaction that is listed - ..S GMRACNT=4 F S GMRACNT=$O(GMRARAC(GMRACNT)) Q:GMRACNT<1 W !,?50,$E($G(GMRARAC(GMRACNT)),1,30) ; The Nth reaction that is listed - ..W ! ; Put a blank line between the ADRs - ..Q - .Q - D CLOSE^GMRAUTL - Q -HEAD ; Print header information - I GMRAPG'=1 Q:$Y<(IOSL-4) - I $E(IOST,1)="C" D Q:GMRAOUT - .I GMRAPG=1 W @IOF Q - .I GMRAPG'=1 D Q:GMRAOUT - ..N DIR S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1 - ..K Y - ..Q - .Q - Q:GMRAOUT - I GMRAPG'=1 W @IOF - W "Report Date: ",$P($$FMTE^XLFDT(GMRADPDT),"@"),?70,"Page: ",GMRAPG - W !,?22,"Adverse Reaction Tracking Report" - W !,?25,"From: ",$$FMTE^XLFDT(GMAST,"2D")," To: ",$$FMTE^XLFDT(GMAEN,"2D") - W !,"Patient",?40,"Dates",?49,"Related Reaction" - W !,$$REPEAT^XLFSTR("-",78) - S GMRAPG=GMRAPG+1 - I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user - Q +GMRAPFT ;HIRMFO/WAA- PRINT FDA REACTION BY DATE ENTERED/TRACKED ;4/10/97 09:30 + ;;4.0;Adverse Reaction Tracking;**7**;Mar 29, 1996 +EN1 ; This routine will loop through the ADT entry point to get all + ; the entries in that date range. + S GMRAOUT=0 + W !,"Select a Tracking date range for this report." + D DT^GMRAPL G:GMRAOUT EXIT + D PRINTER +EXIT ; Exit of program kill cleanup + D KILL^XUSCLEAN + Q +PRINTER ;Select printer + W ! K GMRAZIS D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q + I $D(IO("Q")) D Q + . S ZTRTN="PRINT^GMRAPFT",(ZTSAVE("GMRAOUT"),ZTSAVE("GMAST"),ZTSAVE("GMAEN"))="" + . S ZTDESC="List of FDA Reactions over a Date range by Tracking date" D ^%ZTLOAD + . W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.") + . Q + U IO D PRINT U IO(0) + D EXIT + Q +PRINT ;Queue point for report + D NOW^%DTC S GMRADPDT=X + S GMRADATE=GMAST-.0001,GMRAPG=1 + F S GMRADATE=$O(^GMR(120.85,"ARDT",GMRADATE)) Q:GMRADATE<1 Q:GMRADATE>GMAEN D Q:GMRAOUT + .S GMRAPA1=0 + .F S GMRAPA1=$O(^GMR(120.85,"ARDT",GMRADATE,GMRAPA1)) Q:GMRAPA1<1 D Q:GMRAOUT + ..S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) Q:GMRAPA1(0)="" + ..Q:+$G(^GMR(120.8,$P(GMRAPA1(0),U,15),"ER")) ;data entered in error + ..D HEAD Q:GMRAOUT + ..S (GMRAPID,GMRANAME,GMRALOC)="" + ..S GMRADFN=$P(GMRAPA1(0),U,2),GMRADDT=$P(GMRAPA1(0),U) + ..D VAD^GMRAUTL1(GMRADFN,GMRADDT,.GMRALOC,.GMRANAME,"",.GMRAPID) + ..I GMRALOC="" S GMRALOC="OUT PATIENT" + ..E S GMRALOC=$P($G(^DIC(42,GMRALOC,0)),U) + ..W !,$E(GMRANAME,1,30) ; Patient Name + ..K GMRARAC + ..S GMRARAC=0,GMRACNT=1 F S GMRARAC=$O(^GMR(120.85,GMRAPA1,3,GMRARAC)) Q:GMRARAC<1 D + ...S GMRARAC(GMRACNT)=$P($G(^GMR(120.85,GMRAPA1,3,GMRARAC,0)),U) Q:GMRARAC(GMRACNT)="" + ...S GMRACNT=GMRACNT+1 + ...Q + ..W ?32,"Obs DT: ",$$FMTE^XLFDT($P(GMRAPA1(0),U),"2D") ; Observed Date + ..W ?49,$E($G(GMRARAC(1)),1,30) ; The 1st reaction that is listed first + ..W !,"(",GMRAPID,")" + ..W ?32,"Trk DT: ",$$FMTE^XLFDT($P(GMRAPA1(0),U,18),"2D") ; Tracking Date + ..W ?49,$E($G(GMRARAC(2)),1,30) ; The 2nd reaction that is listed + ..W !,"Loc: ",GMRALOC + ..W ?32,"-------------" ; Seperator + ..W ?49,$E($G(GMRARAC(3)),1,30) ; The 3rd reaction that is listed + ..W !,"Obs: ",$P($G(^VA(200,$P(GMRAPA1(0),U,19),0)),U) ; User entered + ..D + ...N X1,X2,X,Y + ...S X2=$P(GMRAPA1(0),U),X1=$P(GMRAPA1(0),U,18) + ...D ^%DTC + ...W ?32,X," Days Difference" ;Difference + ...Q + ..W ?50,$E($G(GMRARAC(4)),1,30) ; The 4th reaction that is listed + ..S GMRACNT=4 F S GMRACNT=$O(GMRARAC(GMRACNT)) Q:GMRACNT<1 W !,?50,$E($G(GMRARAC(GMRACNT)),1,30) ; The Nth reaction that is listed + ..W ! ; Put a blank line between the ADRs + ..Q + .Q + D CLOSE^GMRAUTL + Q +HEAD ; Print header information + I GMRAPG'=1 Q:$Y<(IOSL-4) + I $E(IOST,1)="C" D Q:GMRAOUT + .I GMRAPG=1 W @IOF Q + .I GMRAPG'=1 D Q:GMRAOUT + ..N DIR S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1 + ..K Y + ..Q + .Q + Q:GMRAOUT + I GMRAPG'=1 W @IOF + W "Report Date: ",$P($$FMTE^XLFDT(GMRADPDT),"@"),?70,"Page: ",GMRAPG + W !,?22,"Adverse Reaction Tracking Report" + W !,?25,"From: ",$$FMTE^XLFDT(GMAST,"2D")," To: ",$$FMTE^XLFDT(GMAEN,"2D") + W !,"Patient",?40,"Dates",?49,"Related Reaction" + W !,$$REPEAT^XLFSTR("-",78) + S GMRAPG=GMRAPG+1 + I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user + Q diff --git a/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPL.m b/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPL.m index 30a6e002..ba4db300 100644 --- a/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPL.m +++ b/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPL.m @@ -1,110 +1,109 @@ -GMRAPL ;HIRMFO/WAA- PRINT ALLERGY LIST BY LOCATION ;5/2/97 14:13 - ;;4.0;Adverse Reaction Tracking;**7,33**;Mar 29, 1996;Build 5 -EN1 ; This routine will loop through the GMRA patient allergy file - ; to find all patient within the date range that meet the criteria - ; and then display all the data for those patients first by location - ; then by date/time range of the reaction. - ; First select a starting date. - ; then select an end date. - ; then select a print device. - ; GMAST = START DATE - ; GMAEN = END DATE - ; - S GMRAOUT=0 - D DT G:GMRAOUT EXIT - S GMAPG=1 - D DEVICE - D EXIT - Q -GET ; This sub routine is to find all the reaction with in this observed - ; date range. - K ^TMP($J,"GMRAPL") - N GMADT S GMADT=GMAST-.0001 - F S GMADT=$O(^GMR(120.8,"AODT",GMADT)) Q:GMADT<1 Q:GMADT>GMAEN D - .N GMRAPA S GMRAPA=0 - .F S GMRAPA=$O(^GMR(120.8,"AODT",GMADT,GMRAPA)) Q:GMRAPA<1 D - ..S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) - ..; Stop if it is not Signed or if is E/E - ..Q:GMRAPA(0)="" ; Bad Zero node - ..Q:'$P(GMRAPA(0),U,12) ; Not signed off - ..Q:$P($G(^GMR(120.8,GMRAPA,"ER")),U) ; Entered in error - ..; Get patient name and location. - ..S GMRATYP=$P(GMRAPA(0),U,20) ; Get the reaction types FDO - ..S (GMRANAM,GMRALOC,GMRAVIP)="" - ..Q:'$$PRDTST^GMRAUTL1($P($G(GMRAPA(0)),U)) ;GMRA*4*33 Exclude test patient from report if production or legacy environment - ..D VAD^GMRAUTL1($P(GMRAPA(0),U),$P(GMRAPA(0),U,4),.GMRALOC,.GMRANAM,"","","","",.GMRAVIP) - ..I GMRALOC'="",+$G(^DIC(42,GMRALOC,44)) S GMRALOC=$P($G(^SC(+$G(^DIC(42,GMRALOC,44)),0)),U) - ..I GMRALOC="" S GMRALOC="Out Patients" - ..;Data format is as follows.... - ..;^TMP($J,"GMRAPL",Ward location,Patient,PID,Reaction Type(FDO),Reaction) - ..S ^TMP($J,"GMRAPL",$E(GMRALOC,1,30),$E(GMRANAM,1,30),GMRAVIP,GMRATYP,GMRAPA)="" - ..Q - .Q - Q -PRINT ; Print data in the reaction global - I $E(IOST,1)="C" W !,"One moment please...",! - D GET - S GMRALOC="" F S GMRALOC=$O(^TMP($J,"GMRAPL",GMRALOC)) Q:GMRALOC="" D Q:GMRAOUT - .D HEAD Q:GMRAOUT - .S GMRANAM="" F S GMRANAM=$O(^TMP($J,"GMRAPL",GMRALOC,GMRANAM)) Q:GMRANAM="" D Q:GMRAOUT - ..S GMRAVIP="" F S GMRAVIP=$O(^TMP($J,"GMRAPL",GMRALOC,GMRANAM,GMRAVIP)) Q:GMRAVIP="" D Q:GMRAOUT - ...I $Y>(IOSL-4) D HEAD Q:GMRAOUT - ...W !,?10,"Patient: ",GMRANAM," (",GMRAVIP,")" - ...S GMRATYP="" F S GMRATYP=$O(^TMP($J,"GMRAPL",GMRALOC,GMRANAM,GMRAVIP,GMRATYP)) W:GMRATYP="" ! Q:GMRATYP="" D Q:GMRAOUT - ....S GMRAPA=0 F S GMRAPA=$O(^TMP($J,"GMRAPL",GMRALOC,GMRANAM,GMRAVIP,GMRATYP,GMRAPA)) Q:GMRAPA<1 D Q:GMRAOUT - .....S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) Q:GMRAPA(0)="" - .....W !,$$FMTE^XLFDT($P(GMRAPA(0),U,4),"1") ;When It was entered - .....W ?20,$S($P(GMRAPA(0),U,5)'="":$E($P(^VA(200,$P(GMRAPA(0),U,5),0),U),1,25),1:"") ;Who Entered it - .....W ?46,GMRATYP ;Type of reaction - .....W ?50,$E($P(GMRAPA(0),U,2),1,30) ;Reaction - .....I $Y>(IOSL-4) D HEAD - .....Q - ....Q - ...Q - ..Q - .Q - Q -HEAD ; Header - I $E(IOST,1)="C" D Q:GMRAOUT - .I GMAPG=1 W @IOF Q - .I GMAPG'=1 D Q:GMRAOUT - ..N DIR S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1 - ..K Y - ..Q - .Q - I GMAPG'=1 W @IOF - W $$FMTE^XLFDT(GMRAPDT,"1"),?70,"Page: ",GMAPG S GMAPG=GMAPG+1 - W !,?11,"List all Signed Patient Reactions for",$S(GMRALOC'="Out Patients":" Ward Location ",1:" "),GMRALOC - W !,?15,"From ",$$FMTE^XLFDT(GMAST,"1")," to ",$$FMTE^XLFDT(GMAEN,"1") - W !,"Date",?20,"Originator",?45,"Type",?50,"Causative Agent" - W !,$$REPEAT^XLFSTR("-",79) - Q -DEVICE ; Select a device to print on - D NOW^%DTC S GMRAPDT=X - W ! K GMRAZIS D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q - I $D(IO("Q")) D Q - . S ZTRTN="PRINT^GMRAPL",(ZTSAVE("GMAST"),ZTSAVE("GMAEN"),ZTSAVE("GMRAOUT"),ZTSAVE("GMRAPDT"),ZTSAVE("GMAPG"))="" - . S ZTDESC="List of Reactions by Ward Location within a date range." D ^%ZTLOAD - . W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.") - . Q - U IO D PRINT U IO(0) - D CLOSE^GMRAUTL - D EXIT - Q -DT ; Get dates - S GMAST=$$DATE("Enter Start Date: ") I GMAST<1 S GMRAOUT=1 Q - S GMAEN=$$DATE("Enter Ending Date: ",GMAST) I GMAEN<1 S GMRAOUT=1 Q - S GMAEN=GMAEN_".24" ;Gives results through entire day when 'T' is selected - Q -DATE(PROMPT,GMADATE) ; Date sub routine - S GMADATE=$G(GMADATE) - S DATE="" - N DIR - S DIR(0)="DAO^"_GMADATE_"::AEP",DIR("A")=PROMPT - D ^DIR I $D(DIRUT) S DATE="" Q DATE - S DATE=Y - Q DATE -EXIT ;EXIT ROUTINE DATA - K ^TMP($J,"GMRAPL") - D KILL^XUSCLEAN - Q +GMRAPL ;HIRMFO/WAA- PRINT ALLERGY LIST BY LOCATION ;5/2/97 14:13 + ;;4.0;Adverse Reaction Tracking;**7**;Mar 29, 1996 +EN1 ; This routine will loop thourgh the GMRA patient allergy file + ; to find all patient within the date range that meet the critera + ; and then display all the data for those patients first by location + ; then by date/time range of the reaction. + ; First select a starting date. + ; then select an end date. + ; then select a print device. + ; GMAST = START DATE + ; GMAEN = END DATE + ; + S GMRAOUT=0 + D DT G:GMRAOUT EXIT + S GMAPG=1 + D DEVICE + D EXIT + Q +GET ; This sub routine is to find all the reaction with in this observed + ; date range. + K ^TMP($J,"GMRAPL") + N GMADT S GMADT=GMAST-.0001 + F S GMADT=$O(^GMR(120.8,"AODT",GMADT)) Q:GMADT<1 Q:GMADT>GMAEN D + .N GMRAPA S GMRAPA=0 + .F S GMRAPA=$O(^GMR(120.8,"AODT",GMADT,GMRAPA)) Q:GMRAPA<1 D + ..S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) + ..; Stop if it is not Signed or if is E/E + ..Q:GMRAPA(0)="" ; Bad Zero node + ..Q:'$P(GMRAPA(0),U,12) ; Not signed off + ..Q:$P($G(^GMR(120.8,GMRAPA,"ER")),U) ; Entered in error + ..; Get patient name and location. + ..S GMRATYP=$P(GMRAPA(0),U,20) ; Get the reaction types FDO + ..S (GMRANAM,GMRALOC,GMRAVIP)="" + ..D VAD^GMRAUTL1($P(GMRAPA(0),U),$P(GMRAPA(0),U,4),.GMRALOC,.GMRANAM,"","","","",.GMRAVIP) + ..I GMRALOC'="",+$G(^DIC(42,GMRALOC,44)) S GMRALOC=$P($G(^SC(+$G(^DIC(42,GMRALOC,44)),0)),U) + ..I GMRALOC="" S GMRALOC="Out Patients" + ..;Data format is as follows.... + ..;^TMP($J,"GMRAPL",Ward location,Patient,PID,Reaction Type(FDO),Reaction) + ..S ^TMP($J,"GMRAPL",$E(GMRALOC,1,30),$E(GMRANAM,1,30),GMRAVIP,GMRATYP,GMRAPA)="" + ..Q + .Q + Q +PRINT ; Print data in the reaction global + I $E(IOST,1)="C" W !,"One moment please...",! + D GET + S GMRALOC="" F S GMRALOC=$O(^TMP($J,"GMRAPL",GMRALOC)) Q:GMRALOC="" D Q:GMRAOUT + .D HEAD Q:GMRAOUT + .S GMRANAM="" F S GMRANAM=$O(^TMP($J,"GMRAPL",GMRALOC,GMRANAM)) Q:GMRANAM="" D Q:GMRAOUT + ..S GMRAVIP="" F S GMRAVIP=$O(^TMP($J,"GMRAPL",GMRALOC,GMRANAM,GMRAVIP)) Q:GMRAVIP="" D Q:GMRAOUT + ...I $Y>(IOSL-4) D HEAD Q:GMRAOUT + ...W !,?10,"Patient: ",GMRANAM," (",GMRAVIP,")" + ...S GMRATYP="" F S GMRATYP=$O(^TMP($J,"GMRAPL",GMRALOC,GMRANAM,GMRAVIP,GMRATYP)) W:GMRATYP="" ! Q:GMRATYP="" D Q:GMRAOUT + ....S GMRAPA=0 F S GMRAPA=$O(^TMP($J,"GMRAPL",GMRALOC,GMRANAM,GMRAVIP,GMRATYP,GMRAPA)) Q:GMRAPA<1 D Q:GMRAOUT + .....S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) Q:GMRAPA(0)="" + .....W !,$$FMTE^XLFDT($P(GMRAPA(0),U,4),"1") ;When It was entered + .....W ?20,$S($P(GMRAPA(0),U,5)'="":$E($P(^VA(200,$P(GMRAPA(0),U,5),0),U),1,25),1:"") ;Who Entered it + .....W ?46,GMRATYP ;Type of reaction + .....W ?50,$E($P(GMRAPA(0),U,2),1,30) ;Reaction + .....I $Y>(IOSL-4) D HEAD + .....Q + ....Q + ...Q + ..Q + .Q + Q +HEAD ; Header + I $E(IOST,1)="C" D Q:GMRAOUT + .I GMAPG=1 W @IOF Q + .I GMAPG'=1 D Q:GMRAOUT + ..N DIR S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1 + ..K Y + ..Q + .Q + I GMAPG'=1 W @IOF + W $$FMTE^XLFDT(GMRAPDT,"1"),?70,"Page: ",GMAPG S GMAPG=GMAPG+1 + W !,?11,"List all Signed Patient Reactions for",$S(GMRALOC'="Out Patients":" Ward Location ",1:" "),GMRALOC + W !,?15,"From ",$$FMTE^XLFDT(GMAST,"1")," to ",$$FMTE^XLFDT(GMAEN,"1") + W !,"Date",?20,"Originator",?45,"Type",?50,"Causative Agent" + W !,$$REPEAT^XLFSTR("-",79) + Q +DEVICE ; Select a device to print on + D NOW^%DTC S GMRAPDT=X + W ! K GMRAZIS D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q + I $D(IO("Q")) D Q + . S ZTRTN="PRINT^GMRAPL",(ZTSAVE("GMAST"),ZTSAVE("GMAEN"),ZTSAVE("GMRAOUT"),ZTSAVE("GMRAPDT"),ZTSAVE("GMAPG"))="" + . S ZTDESC="List of Reactions by Ward Location within a date range." D ^%ZTLOAD + . W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.") + . Q + U IO D PRINT U IO(0) + D CLOSE^GMRAUTL + D EXIT + Q +DT ; Get dates + S GMAST=$$DATE("Enter Start Date: ") I GMAST<1 S GMRAOUT=1 Q + S GMAEN=$$DATE("Enter Ending Date: ",GMAST) I GMAEN<1 S GMRAOUT=1 Q + S GMAEN=GMAEN_".24" ;Gives results through entire day when 'T' is selected + Q +DATE(PROMPT,GMADATE) ; Date sub routine + S GMADATE=$G(GMADATE) + S DATE="" + N DIR + S DIR(0)="DAO^"_GMADATE_"::AEP",DIR("A")=PROMPT + D ^DIR I $D(DIRUT) S DATE="" Q DATE + S DATE=Y + Q DATE +EXIT ;EXIT ROUTINE DATA + K ^TMP($J,"GMRAPL") + D KILL^XUSCLEAN + Q diff --git a/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPNA.m b/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPNA.m index 04fba99a..ded06e78 100644 --- a/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPNA.m +++ b/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPNA.m @@ -1,86 +1,85 @@ -GMRAPNA ;HIRMFO/WAA-PATIENT NOT ASKED ABOUT ALLERGIES ;12/1/95 14:15 - ;;4.0;Adverse Reaction Tracking;**30,33**;Mar 29, 1996;Build 5 -EN1 ; Entry for LIST BY LOCATION OF UNDOCUMENTED ALLERGIES option - D EN1^GMRACMR G:GMRAOUT EXIT - D DEV - D EXIT - Q -DEV ; *** Select output device, force queuing - ;***** NOTE: CHECKS TO SEE IF VALID DEVICE IS SELECTED THEN ALL I HAVE TO DO IS RUN TASK MAN. - S GMRAZIS="" S:GMRASEL'="1," GMRAZIS="Q" - W !! D DEV^GMRAUTL I POP G EXIT - I $D(IO("Q")) D G EXIT - . K IO("Q") - . S ZTRTN="ENTSK^GMRAPNA" - . S ZTSAVE("GMRA*")="",ZTSAVE("^TMP($J,")="" - . S ZTDESC="List of patients who have not been asked of allergies" - . D ^%ZTLOAD - . W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try later...") - . Q - E D ENTSK - Q -ENTSK U IO - D EN1^GMRACMR2,EN1^GMRACMR3 - S GMRAPAGE=0,X="NOW" D ^%DT S GMRAPDT=$$DATE^GMRAUTL1(Y) - D PRINT - G EXIT -PRINT ;PRINT THE DATE - D PRE - S GMRAHLOC="" F S GMRAHLOC=$O(^TMP($J,"GMRAWC","C",GMRAHLOC)) Q:GMRAHLOC=""!(GMRAOUT) S GMRAX=0 F S GMRAX=$O(^(GMRAHLOC,GMRAX)) Q:GMRAX<1 D Q:GMRAOUT - .S GMRA=$G(^TMP($J,"GMRAWC",GMRAX)),GMRACNT=0 - .I GMRA="" Q - .D HEAD Q:GMRAOUT - .W !!,?10,$S(GMRA="W":"WARD",GMRA="M":"MODULE",GMRA="C":"CLINIC",1:"UNKNOWN"),": ",$P(^SC(GMRAX,0),U) - .S GMRADATE=0 F S GMRADATE=$O(^TMP($J,"GMRAWC",GMRAX,GMRADATE)) Q:GMRADATE="" S GMRADFN=0 Q:GMRAOUT F S GMRADFN=$O(^TMP($J,"GMRAWC",GMRAX,GMRADATE,GMRADFN)) Q:GMRADFN<1 D Q:GMRAOUT - ..I '$D(^GMR(120.86,GMRADFN,0)) - ..E I +$P(^GMR(120.86,GMRADFN,0),U,4)<$G(GMRAED,9999999) Q - ..Q:'$D(^DPT(GMRADFN,0)) - ..Q:$$DECEASED^GMRAFX(GMRADFN) ;GMRA*4*30 Prevent deceased patients from appearing on this report. - ..Q:'$$PRDTST^GMRAUTL1(GMRADFN) ;GMRA*4*33 Exclude test patient from report if production or legacy environment. - ..S GMRACNT=GMRACNT+1 - ..W !,$P(^DPT(GMRADFN,0),U) S DFN=GMRADFN,VAINDT=$S(GMRADATE="CURRENT":DT,1:GMRADATE) D 1^VADPT W ?30,VA("PID") W:GMRA'="C" ?45,$P(VAIN(2),U,2) - ..I VAIN(5)'="" W !,?5,"Room/Bed: ",VAIN(5) - ..D KVAR^VADPT K VA,DFN - ..I $Y>(IOSL-4) D HEAD Q:GMRAOUT - ..Q - .D NOPAT - .Q - D CLOSE^GMRAUTL - Q -NOPAT ; If there are no patients print informational message - Q:GMRACNT - W !,?24,"* No Patients for this ",$S(GMRA="W":"Ward",GMRA="M":"Module",GMRA="C":"Clinic",1:"UNKNOWN")," *" - W ! - Q -HEAD ;HEADER PAGE FOR PRINTOUT - S GMRAPAGE=GMRAPAGE+1,GMRATL="" I $E(IOST,1)="C",GMRAPAGE=1 W @IOF - I $E(IOST,1)="C",GMRAPAGE'=1 D Q:GMRAOUT - .S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1 - .K Y - .Q - I GMRAPAGE'=1 W @IOF - W !,GMRAPDT,?23,"PATIENTS NOT ASKED ABOUT ALLERGIES",?70,"PAGE ",GMRAPAGE - I GMRASEL["1" S GMRATL="CURRENT INPATIENTS" - I GMRASEL["2" S GMRATL=$S(GMRATL="":"OUTPATIENTS",1:GMRATL_" / OUTPATIENTS") - I GMRASEL["3" S GMRATL=$S(GMRATL="":"NEW ADMISSIONS",1:GMRATL_" / NEW ADMISSIONS") - W !,?(40-($L(GMRATL)/2)),GMRATL - I (GMRASEL["2"!(GMRASEL["3")) W !,?23,"FROM ",$$DATE^GMRAUTL1(GMRAST),?42,"TO ",$$DATE^GMRAUTL1(GMRAED) - W !!,"PATIENT",?30,"SSN" W:GMRA'="C" ?45,"PROVIDER" - W !,$$REPEAT^XLFSTR("-",78) - I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user - Q -PRE ; This will validate the TMP global and fire off Xref - N GMRAX,GMRAY,GMRAT1,GMRAT2,GMRAT3 - Q:'$D(^TMP($J,"GMRAWC")) - S GMRAX=0 F S GMRAX=$O(^TMP($J,"GMRAWC",GMRAX)) Q:GMRAX<1 D - .S GMRAY=^TMP($J,"GMRAWC",GMRAX) - .S GMRAT1=$P($G(^SC(GMRAX,0)),U,2) - .S GMRAT2=$P($G(^SC(GMRAX,0)),U) - .S GMRAT3=$S(GMRAT1'="":GMRAT1,1:GMRAT2) - .S ^TMP($J,"GMRAWC","C",GMRAT3,GMRAX)="" - .Q - Q -EXIT ; - K ^TMP($J,"GMRAWC") - D KILL^XUSCLEAN - Q +GMRAPNA ;HIRMFO/WAA-PATIENT NOT ASKED ABOUT ALLERGIES ;12/1/95 14:15 + ;;4.0;Adverse Reaction Tracking;**30**;Mar 29, 1996 +EN1 ; Entry for LIST BY LOCATION OF UNDOCUMENTED ALLERGIES option + D EN1^GMRACMR G:GMRAOUT EXIT + D DEV + D EXIT + Q +DEV ; *** Select output device, force queueing + ;***** NOTE: CHECKS TO SEE IF VALID DEVICE IS SELECTED THEN ALL I HAVE TO DO IS RUN TASK MAN. + S GMRAZIS="" S:GMRASEL'="1," GMRAZIS="Q" + W !! D DEV^GMRAUTL I POP G EXIT + I $D(IO("Q")) D G EXIT + . K IO("Q") + . S ZTRTN="ENTSK^GMRAPNA" + . S ZTSAVE("GMRA*")="",ZTSAVE("^TMP($J,")="" + . S ZTDESC="List of patients who have not been asked of allergies" + . D ^%ZTLOAD + . W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try later...") + . Q + E D ENTSK + Q +ENTSK U IO + D EN1^GMRACMR2,EN1^GMRACMR3 + S GMRAPAGE=0,X="NOW" D ^%DT S GMRAPDT=$$DATE^GMRAUTL1(Y) + D PRINT + G EXIT +PRINT ;PRINT THE DATE + D PRE + S GMRAHLOC="" F S GMRAHLOC=$O(^TMP($J,"GMRAWC","C",GMRAHLOC)) Q:GMRAHLOC=""!(GMRAOUT) S GMRAX=0 F S GMRAX=$O(^(GMRAHLOC,GMRAX)) Q:GMRAX<1 D Q:GMRAOUT + .S GMRA=$G(^TMP($J,"GMRAWC",GMRAX)),GMRACNT=0 + .I GMRA="" Q + .D HEAD Q:GMRAOUT + .W !!,?10,$S(GMRA="W":"WARD",GMRA="M":"MODULE",GMRA="C":"CLINIC",1:"UNKNOWN"),": ",$P(^SC(GMRAX,0),U) + .S GMRADATE=0 F S GMRADATE=$O(^TMP($J,"GMRAWC",GMRAX,GMRADATE)) Q:GMRADATE="" S GMRADFN=0 Q:GMRAOUT F S GMRADFN=$O(^TMP($J,"GMRAWC",GMRAX,GMRADATE,GMRADFN)) Q:GMRADFN<1 D Q:GMRAOUT + ..I '$D(^GMR(120.86,GMRADFN,0)) + ..E I +$P(^GMR(120.86,GMRADFN,0),U,4)<$G(GMRAED,9999999) Q + ..Q:'$D(^DPT(GMRADFN,0)) + ..Q:$$DECEASED^GMRAFX(GMRADFN) ;GMRA*4*30 Prevent deceased patients from appearing on this report. + ..S GMRACNT=GMRACNT+1 + ..W !,$P(^DPT(GMRADFN,0),U) S DFN=GMRADFN,VAINDT=$S(GMRADATE="CURRENT":DT,1:GMRADATE) D 1^VADPT W ?30,VA("PID") W:GMRA'="C" ?45,$P(VAIN(2),U,2) + ..I VAIN(5)'="" W !,?5,"Room/Bed: ",VAIN(5) + ..D KVAR^VADPT K VA,DFN + ..I $Y>(IOSL-4) D HEAD Q:GMRAOUT + ..Q + .D NOPAT + .Q + D CLOSE^GMRAUTL + Q +NOPAT ; If there are no patients print informational message + Q:GMRACNT + W !,?24,"* No Patients for this ",$S(GMRA="W":"Ward",GMRA="M":"Module",GMRA="C":"Clinic",1:"UNKNOWN")," *" + W ! + Q +HEAD ;HEADER PAGE FOR PRINTOUT + S GMRAPAGE=GMRAPAGE+1,GMRATL="" I $E(IOST,1)="C",GMRAPAGE=1 W @IOF + I $E(IOST,1)="C",GMRAPAGE'=1 D Q:GMRAOUT + .S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1 + .K Y + .Q + I GMRAPAGE'=1 W @IOF + W !,GMRAPDT,?23,"PATIENTS NOT ASKED ABOUT ALLERGIES",?70,"PAGE ",GMRAPAGE + I GMRASEL["1" S GMRATL="CURRENT INPATIENTS" + I GMRASEL["2" S GMRATL=$S(GMRATL="":"OUTPATIENTS",1:GMRATL_" / OUTPATIENTS") + I GMRASEL["3" S GMRATL=$S(GMRATL="":"NEW ADMISSIONS",1:GMRATL_" / NEW ADMISSIONS") + W !,?(40-($L(GMRATL)/2)),GMRATL + I (GMRASEL["2"!(GMRASEL["3")) W !,?23,"FROM ",$$DATE^GMRAUTL1(GMRAST),?42,"TO ",$$DATE^GMRAUTL1(GMRAED) + W !!,"PATIENT",?30,"SSN" W:GMRA'="C" ?45,"PROVIDER" + W !,$$REPEAT^XLFSTR("-",78) + I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user + Q +PRE ; This will validate the TMP global and fire off Xref + N GMRAX,GMRAY,GMRAT1,GMRAT2,GMRAT3 + Q:'$D(^TMP($J,"GMRAWC")) + S GMRAX=0 F S GMRAX=$O(^TMP($J,"GMRAWC",GMRAX)) Q:GMRAX<1 D + .S GMRAY=^TMP($J,"GMRAWC",GMRAX) + .S GMRAT1=$P($G(^SC(GMRAX,0)),U,2) + .S GMRAT2=$P($G(^SC(GMRAX,0)),U) + .S GMRAT3=$S(GMRAT1'="":GMRAT1,1:GMRAT2) + .S ^TMP($J,"GMRAWC","C",GMRAT3,GMRAX)="" + .Q + Q +EXIT ; + K ^TMP($J,"GMRAWC") + D KILL^XUSCLEAN + Q diff --git a/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST1.m b/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST1.m index f092ac39..2ffde3d3 100644 --- a/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST1.m +++ b/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST1.m @@ -1,89 +1,88 @@ -GMRAPST1 ;HIRMFO/WAA- PRINT LISTING OF FATAL REACTIONS ;3/5/97 14:45 - ;;4.0;Adverse Reaction Tracking;**7,33**;Mar 29, 1996;Build 5 -EN1 ; This routine will loop through the ADT entry point to get all - ; the entries where the patient has died. - S GMRAOUT=0 - W !,"Select an Observed date range for this report." - D DT^GMRAPL G:GMRAOUT EXIT - D PRINTER -EXIT ; Exit of program kill cleanup - D KILL^XUSCLEAN - K ^TMP($J,"GMRAPST1") - Q -PRINTER ;Select printer - W ! K GMRAZIS D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q - I $D(IO("Q")) D Q - . S ZTRTN="PRINT^GMRAPST1",(ZTSAVE("GMRAOUT"),ZTSAVE("GMAST"),ZTSAVE("GMAEN"))="" - . S ZTDESC="List of Fatal Reaction over a date range" D ^%ZTLOAD - . W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.") - . Q - U IO D PRINT U IO(0) - Q -PRINT ;Queue point for report - ;Loop through the 120.85 file. - K ^TMP($J,"GMRAPST1") - D NOW^%DTC S GMRADPDT=X - S GMRADATE=GMAST-.0001,GMRAPG=1 - F S GMRADATE=$O(^GMR(120.85,"B",GMRADATE)) Q:GMRADATE<1 Q:GMRADATE>GMAEN D - .S GMRAPA1=0 F S GMRAPA1=$O(^GMR(120.85,"B",GMRADATE,GMRAPA1)) Q:GMRAPA1<1 D - ..S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) Q:GMRAPA1(0)="" ;Bad Node - ..Q:+$G(^GMR(120.8,$P(GMRAPA1(0),U,15),"ER")) ;data entered in error - ..Q:$P(GMRAPA1(0),U,3)'="y" ; If patient did not die of the reaction - ..S GMRADFN=$P(GMRAPA1(0),U,2),GMRADDT=$P(GMRAPA1(0),U) ; reaction date - ..Q:'$$PRDTST^GMRAUTL1(GMRADFN) ;GMRA*4*33 Exclude test patient from report in production or legacy environments. - ..S (GMRAPID,GMRANAME)="" - ..D VAD^GMRAUTL1(GMRADFN,GMRADDT,"",.GMRANAME,"",.GMRAPID) - ..S GMRADIED=$P($G(^DPT(GMRADFN,.35)),U) ; Date patient died - ..S ^TMP($J,"GMRAPST1",$E(GMRANAME,1,30),GMRAPID,GMRADDT,GMRAPA1)=GMRADIED - ..Q - .Q - Q:GMRAOUT - I '$D(^TMP($J,"GMRAPST1")) D HEAD W !,"NO DATA FOR THIS REPORT..." Q - S GMRANAME="" - F S GMRANAME=$O(^TMP($J,"GMRAPST1",GMRANAME)) Q:GMRANAME="" D Q:GMRAOUT - .S GMRAPID="" - .F S GMRAPID=$O(^TMP($J,"GMRAPST1",GMRANAME,GMRAPID)) Q:GMRAPID="" D Q:GMRAOUT - ..D HEAD Q:GMRAOUT - ..W !,$E(GMRANAME,1,22)," (",$E(GMRANAME,1),$P(GMRAPID,"-",3),")" - ..S GMRADDT=0 - ..F S GMRADDT=$O(^TMP($J,"GMRAPST1",GMRANAME,GMRAPID,GMRADDT)) Q:GMRADDT<1 D Q:GMRAOUT - ...S GMRAPA1=0 - ...F S GMRAPA1=$O(^TMP($J,"GMRAPST1",GMRANAME,GMRAPID,GMRADDT,GMRAPA1)) Q:GMRAPA1<1 D Q:GMRAOUT W ! - ....S GMRADIED=^TMP($J,"GMRAPST1",GMRANAME,GMRAPID,GMRADDT,GMRAPA1) - ....W ?31,$$FMTE^XLFDT($P(^GMR(120.85,GMRAPA1,0),U),"2D") - ....S GMRAX="",GMRACNT=1 K GMRARX - ....F S GMRAX=$O(^GMR(120.85,GMRAPA1,3,"B",GMRAX)) Q:GMRAX="" D - .....S GMRARX(GMRACNT)=GMRAX,GMRACNT=GMRACNT+1 - .....Q - ....W ?40,GMRARX(1),?70,$$FMTE^XLFDT(GMRADIED,"2D") - ....D HEAD Q:GMRAOUT - ....S GMRACNT=1 F S GMRACNT=$O(GMRARX(GMRACNT)) Q:GMRACNT<1 D Q:GMRAOUT - .....W !,?40,GMRARX(GMRACNT) D HEAD Q:GMRAOUT - .....Q - ....Q - ...Q - ..W ! D HEAD Q:GMRAOUT - ..Q - .Q - D CLOSE^GMRAUTL - Q - ;has the patient died within the date -HEAD ; Print header information - I GMRAPG'=1 Q:$Y<(IOSL-4) - I $E(IOST,1)="C" D Q:GMRAOUT - .I GMRAPG=1 W @IOF Q - .I GMRAPG'=1 D Q:GMRAOUT - ..N DIR S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1 - ..K Y - ..Q - .Q - Q:GMRAOUT - I GMRAPG'=1 W @IOF - W "Report Date: ",$P($$FMTE^XLFDT(GMRADPDT),"@"),?70,"Page: ",GMRAPG - W !,?22,"List of Fatal Reaction over a date range" - W !,?25,"From: ",$$FMTE^XLFDT(GMAST,"2D")," To: ",$$FMTE^XLFDT(GMAEN,"2D") - W !,"Patient",?31,"Dates",?40,"Related Reaction",?70,"Date Died" - W !,$$REPEAT^XLFSTR("-",79) - S GMRAPG=GMRAPG+1 - I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user - Q +GMRAPST1 ;HIRMFO/WAA- PRINT LISTING OF FATAL REACTIONS ;3/5/97 14:45 + ;;4.0;Adverse Reaction Tracking;**7**;Mar 29, 1996 +EN1 ; This routine will loop through the ADT entry point to get all + ; the entries where the patient has died. + S GMRAOUT=0 + W !,"Select an Observed date range for this report." + D DT^GMRAPL G:GMRAOUT EXIT + D PRINTER +EXIT ; Exit of program kill cleanup + D KILL^XUSCLEAN + K ^TMP($J,"GMRAPST1") + Q +PRINTER ;Select printer + W ! K GMRAZIS D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q + I $D(IO("Q")) D Q + . S ZTRTN="PRINT^GMRAPST1",(ZTSAVE("GMRAOUT"),ZTSAVE("GMAST"),ZTSAVE("GMAEN"))="" + . S ZTDESC="List of Fatal Reaction over a date range" D ^%ZTLOAD + . W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.") + . Q + U IO D PRINT U IO(0) + Q +PRINT ;Queue point for report + ;Loop through the 120.85 file. + K ^TMP($J,"GMRAPST1") + D NOW^%DTC S GMRADPDT=X + S GMRADATE=GMAST-.0001,GMRAPG=1 + F S GMRADATE=$O(^GMR(120.85,"B",GMRADATE)) Q:GMRADATE<1 Q:GMRADATE>GMAEN D + .S GMRAPA1=0 F S GMRAPA1=$O(^GMR(120.85,"B",GMRADATE,GMRAPA1)) Q:GMRAPA1<1 D + ..S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) Q:GMRAPA1(0)="" ;Bad Node + ..Q:+$G(^GMR(120.8,$P(GMRAPA1(0),U,15),"ER")) ;data entered in error + ..Q:$P(GMRAPA1(0),U,3)'="y" ; If patient did not die of the reaction + ..S GMRADFN=$P(GMRAPA1(0),U,2),GMRADDT=$P(GMRAPA1(0),U) ; reaction date + ..S (GMRAPID,GMRANAME)="" + ..D VAD^GMRAUTL1(GMRADFN,GMRADDT,"",.GMRANAME,"",.GMRAPID) + ..S GMRADIED=$P($G(^DPT(GMRADFN,.35)),U) ; Date patient died + ..S ^TMP($J,"GMRAPST1",$E(GMRANAME,1,30),GMRAPID,GMRADDT,GMRAPA1)=GMRADIED + ..Q + .Q + Q:GMRAOUT + I '$D(^TMP($J,"GMRAPST1")) D HEAD W !,"NO DATA FOR THIS REPORT..." Q + S GMRANAME="" + F S GMRANAME=$O(^TMP($J,"GMRAPST1",GMRANAME)) Q:GMRANAME="" D Q:GMRAOUT + .S GMRAPID="" + .F S GMRAPID=$O(^TMP($J,"GMRAPST1",GMRANAME,GMRAPID)) Q:GMRAPID="" D Q:GMRAOUT + ..D HEAD Q:GMRAOUT + ..W !,$E(GMRANAME,1,22)," (",$E(GMRANAME,1),$P(GMRAPID,"-",3),")" + ..S GMRADDT=0 + ..F S GMRADDT=$O(^TMP($J,"GMRAPST1",GMRANAME,GMRAPID,GMRADDT)) Q:GMRADDT<1 D Q:GMRAOUT + ...S GMRAPA1=0 + ...F S GMRAPA1=$O(^TMP($J,"GMRAPST1",GMRANAME,GMRAPID,GMRADDT,GMRAPA1)) Q:GMRAPA1<1 D Q:GMRAOUT W ! + ....S GMRADIED=^TMP($J,"GMRAPST1",GMRANAME,GMRAPID,GMRADDT,GMRAPA1) + ....W ?31,$$FMTE^XLFDT($P(^GMR(120.85,GMRAPA1,0),U),"2D") + ....S GMRAX="",GMRACNT=1 K GMRARX + ....F S GMRAX=$O(^GMR(120.85,GMRAPA1,3,"B",GMRAX)) Q:GMRAX="" D + .....S GMRARX(GMRACNT)=GMRAX,GMRACNT=GMRACNT+1 + .....Q + ....W ?40,GMRARX(1),?70,$$FMTE^XLFDT(GMRADIED,"2D") + ....D HEAD Q:GMRAOUT + ....S GMRACNT=1 F S GMRACNT=$O(GMRARX(GMRACNT)) Q:GMRACNT<1 D Q:GMRAOUT + .....W !,?40,GMRARX(GMRACNT) D HEAD Q:GMRAOUT + .....Q + ....Q + ...Q + ..W ! D HEAD Q:GMRAOUT + ..Q + .Q + D CLOSE^GMRAUTL + Q + ;has the patient died with inthe dat +HEAD ; Print header information + I GMRAPG'=1 Q:$Y<(IOSL-4) + I $E(IOST,1)="C" D Q:GMRAOUT + .I GMRAPG=1 W @IOF Q + .I GMRAPG'=1 D Q:GMRAOUT + ..N DIR S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1 + ..K Y + ..Q + .Q + Q:GMRAOUT + I GMRAPG'=1 W @IOF + W "Report Date: ",$P($$FMTE^XLFDT(GMRADPDT),"@"),?70,"Page: ",GMRAPG + W !,?22,"List of Fatal Reaction over a date range" + W !,?25,"From: ",$$FMTE^XLFDT(GMAST,"2D")," To: ",$$FMTE^XLFDT(GMAEN,"2D") + W !,"Patient",?31,"Dates",?40,"Related Reaction",?70,"Date Died" + W !,$$REPEAT^XLFSTR("-",79) + S GMRAPG=GMRAPG+1 + I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user + Q diff --git a/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST2.m b/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST2.m index b5092652..dac4efd5 100644 --- a/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST2.m +++ b/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST2.m @@ -1,91 +1,90 @@ -GMRAPST2 ;HIRMFO/WAA- PRINT SUM LISTING OF OUT COMES ;3/5/97 14:50 - ;;4.0;Adverse Reaction Tracking;**7,33**;Mar 29, 1996;Build 5 -EN1 ; This routine will loop through the ADT entry point to get all - ; the entries in that date range. - S GMRAOUT=0 - W !,"Select an Observed date range for this report." - D DT^GMRAPL G:GMRAOUT EXIT - D PRINTER -EXIT ; Exit of program kill cleanup - D KILL^XUSCLEAN - Q -PRINTER ;Select printer - W ! K GMRAZIS D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q - I $D(IO("Q")) D Q - . S ZTRTN="PRINT^GMRAPST2",(ZTSAVE("GMRAOUT"),ZTSAVE("GMAST"),ZTSAVE("GMAEN"))="" - . S ZTDESC="Summary of Outcomes" D ^%ZTLOAD - . W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.") - . Q - U IO D PRINT U IO(0) - Q -PRINT ;Queue point for report - ;loop through the 120.85 file and look for the field that - D NOW^%DTC S GMRADPDT=X - S GMRADATE=GMAST-.0001,GMRAPG=1 - S (GMRARRAY("YES"),GMRARRAY("NO"),GMRARRAY("NULL"))="",GMRATOT=0 - F S GMRADATE=$O(^GMR(120.85,"B",GMRADATE)) Q:GMRADATE<1 Q:GMRADATE>GMAEN D - .S GMRAPA1=0 F S GMRAPA1=$O(^GMR(120.85,"B",GMRADATE,GMRAPA1)) Q:GMRAPA1<1 D - ..S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) Q:GMRAPA1(0)="" ;Bad Node - ..Q:+$G(^GMR(120.8,$P(GMRAPA1(0),U,15),"ER")) ;Entered in Error data - ..Q:'$$PRDTST^GMRAUTL1($P(GMRAPA1(0),U,2)) ;GMRA*4*33 Exclude test patient from report if production or legacy environment. - ..S GMRATOT=GMRATOT+1 - ..F GMRALAB=1:1 S GMRALINE=$T(TEXT+GMRALAB) Q:$P(GMRALINE,";",3)="" D - ...S GMRAP=$P(GMRALINE,";",4) - ...I $P(GMRAPA1(0),U,GMRAP)="y" S $P(GMRARRAY("YES"),U,GMRAP)=$P(GMRARRAY("YES"),U,GMRAP)+1 - ...I $P(GMRAPA1(0),U,GMRAP)="n" S $P(GMRARRAY("NO"),U,GMRAP)=$P(GMRARRAY("NO"),U,GMRAP)+1 - ...I $P(GMRAPA1(0),U,GMRAP)="" S $P(GMRARRAY("NULL"),U,GMRAP)=$P(GMRARRAY("NULL"),U,GMRAP)+1 - ...Q - ..Q - .Q - Q:GMRAOUT - D HEAD - S (GMRAY,GMRAN,GMRANU)=0 - F GMRALAB=1:1 S GMRALINE=$T(TEXT+GMRALAB) Q:$P(GMRALINE,";",3)="" D - .N GMRAP,GMRATAB - .S GMRAP=$P(GMRALINE,";",4) - .S GMRATAB=40-$L($P(GMRALINE,";",3)) - .W !,?GMRATAB,$P(GMRALINE,";",3) - .W ?42,$P(GMRARRAY("YES"),U,GMRAP) - .S GMRAY=GMRAY+$P(GMRARRAY("YES"),U,GMRAP) - .W ?53,"| ",$P(GMRARRAY("NO"),U,GMRAP) - .S GMRAN=GMRAN+$P(GMRARRAY("NO"),U,GMRAP) - .W ?63,"| ",$P(GMRARRAY("NULL"),U,GMRAP) - .S GMRANU=GMRANU+$P(GMRARRAY("NULL"),U,GMRAP) - .Q - W !,?30," ---------------------------------------" - W !,?32,"Totals: ",?42,GMRAY,?53,"| ",GMRAN,?63,"| ",GMRANU - W !!,?22,"Total number of records processed ",GMRATOT - D CLOSE^GMRAUTL - Q - ;has the patient died within the date -HEAD ; Print header information - I GMRAPG'=1 Q:$Y<(IOSL-4) - I $E(IOST,1)="C" D Q:GMRAOUT - .I GMRAPG=1 W @IOF Q - .I GMRAPG'=1 D Q:GMRAOUT - ..N DIR S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1 - ..K Y - ..Q - .Q - Q:GMRAOUT - I GMRAPG'=1 W @IOF - W "Report Date: ",$P($$FMTE^XLFDT(GMRADPDT),"@"),?70,"Page: ",GMRAPG - W !,?30,"Summary of Outcomes" - W !,?25,"From: ",$$FMTE^XLFDT(GMAST,"2D")," To: ",$$FMTE^XLFDT(GMAEN,"2D") - W !,?42,"Yes",?55,"No",?65,"No Response" - W !,$$REPEAT^XLFSTR("-",79) - S GMRAPG=GMRAPG+1 - I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user - Q -TEXT ;;these are the labels that will denote the field data - ;;Patients that Died: ;3 - ;;Reactions treated with RX drugs: ;4 - ;;Life Threatening illness: ;5 - ;;Required ER/MD visit: ;6 - ;;Required hospitalization: ;7 - ;;Prolonged Hospitalization: ;9 - ;;Resulted in permanent disability: ;10 - ;;Patient recovered: ;11 - ;;Congenital Anomaly: ;16 - ;;Required intervention: ;17 - ;; +GMRAPST2 ;HIRMFO/WAA- PRINT SUM LISTING OF OUT COMES ;3/5/97 14:50 + ;;4.0;Adverse Reaction Tracking;**7**;Mar 29, 1996 +EN1 ; This routine will loop through the ADT entry point to get all + ; the entries in that date range. + S GMRAOUT=0 + W !,"Select an Observed date range for this report." + D DT^GMRAPL G:GMRAOUT EXIT + D PRINTER +EXIT ; Exit of program kill cleanup + D KILL^XUSCLEAN + Q +PRINTER ;Select printer + W ! K GMRAZIS D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q + I $D(IO("Q")) D Q + . S ZTRTN="PRINT^GMRAPST2",(ZTSAVE("GMRAOUT"),ZTSAVE("GMAST"),ZTSAVE("GMAEN"))="" + . S ZTDESC="Summary of Outcomes" D ^%ZTLOAD + . W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.") + . Q + U IO D PRINT U IO(0) + Q +PRINT ;Queue point for report + ;loop through the 120.85 file and look for the field that + D NOW^%DTC S GMRADPDT=X + S GMRADATE=GMAST-.0001,GMRAPG=1 + S (GMRARRAY("YES"),GMRARRAY("NO"),GMRARRAY("NULL"))="",GMRATOT=0 + F S GMRADATE=$O(^GMR(120.85,"B",GMRADATE)) Q:GMRADATE<1 Q:GMRADATE>GMAEN D + .S GMRAPA1=0 F S GMRAPA1=$O(^GMR(120.85,"B",GMRADATE,GMRAPA1)) Q:GMRAPA1<1 D + ..S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) Q:GMRAPA1(0)="" ;Bad Node + ..Q:+$G(^GMR(120.8,$P(GMRAPA1(0),U,15),"ER")) ;Entered in Error data + ..S GMRATOT=GMRATOT+1 + ..F GMRALAB=1:1 S GMRALINE=$T(TEXT+GMRALAB) Q:$P(GMRALINE,";",3)="" D + ...S GMRAP=$P(GMRALINE,";",4) + ...I $P(GMRAPA1(0),U,GMRAP)="y" S $P(GMRARRAY("YES"),U,GMRAP)=$P(GMRARRAY("YES"),U,GMRAP)+1 + ...I $P(GMRAPA1(0),U,GMRAP)="n" S $P(GMRARRAY("NO"),U,GMRAP)=$P(GMRARRAY("NO"),U,GMRAP)+1 + ...I $P(GMRAPA1(0),U,GMRAP)="" S $P(GMRARRAY("NULL"),U,GMRAP)=$P(GMRARRAY("NULL"),U,GMRAP)+1 + ...Q + ..Q + .Q + Q:GMRAOUT + D HEAD + S (GMRAY,GMRAN,GMRANU)=0 + F GMRALAB=1:1 S GMRALINE=$T(TEXT+GMRALAB) Q:$P(GMRALINE,";",3)="" D + .N GMRAP,GMRATAB + .S GMRAP=$P(GMRALINE,";",4) + .S GMRATAB=40-$L($P(GMRALINE,";",3)) + .W !,?GMRATAB,$P(GMRALINE,";",3) + .W ?42,$P(GMRARRAY("YES"),U,GMRAP) + .S GMRAY=GMRAY+$P(GMRARRAY("YES"),U,GMRAP) + .W ?53,"| ",$P(GMRARRAY("NO"),U,GMRAP) + .S GMRAN=GMRAN+$P(GMRARRAY("NO"),U,GMRAP) + .W ?63,"| ",$P(GMRARRAY("NULL"),U,GMRAP) + .S GMRANU=GMRANU+$P(GMRARRAY("NULL"),U,GMRAP) + .Q + W !,?30," ---------------------------------------" + W !,?32,"Totals: ",?42,GMRAY,?53,"| ",GMRAN,?63,"| ",GMRANU + W !!,?22,"Total number of records processed ",GMRATOT + D CLOSE^GMRAUTL + Q + ;has the patient died with inthe dat +HEAD ; Print header information + I GMRAPG'=1 Q:$Y<(IOSL-4) + I $E(IOST,1)="C" D Q:GMRAOUT + .I GMRAPG=1 W @IOF Q + .I GMRAPG'=1 D Q:GMRAOUT + ..N DIR S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1 + ..K Y + ..Q + .Q + Q:GMRAOUT + I GMRAPG'=1 W @IOF + W "Report Date: ",$P($$FMTE^XLFDT(GMRADPDT),"@"),?70,"Page: ",GMRAPG + W !,?30,"Summary of Outcomes" + W !,?25,"From: ",$$FMTE^XLFDT(GMAST,"2D")," To: ",$$FMTE^XLFDT(GMAEN,"2D") + W !,?42,"Yes",?55,"No",?65,"No Response" + W !,$$REPEAT^XLFSTR("-",79) + S GMRAPG=GMRAPG+1 + I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user + Q +TEXT ;;these are the labeles that will denote the field data + ;;Patients that Died: ;3 + ;;Reactions treated with RX drugs: ;4 + ;;Life Threatening illness: ;5 + ;;Required ER/MD visit: ;6 + ;;Required hospitalization: ;7 + ;;Prolonged Hospitalization: ;9 + ;;Resulted in permanent disability: ;10 + ;;Patient recovered: ;11 + ;;Congenital Anomaly: ;16 + ;;Required intervention: ;17 + ;; diff --git a/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST3.m b/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST3.m index 169e45fa..78fe8cff 100644 --- a/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST3.m +++ b/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST3.m @@ -1,81 +1,80 @@ -GMRAPST3 ;HIRMFO/WAA- PRINT FREQUENCY OF DIST OVR DT BY REACT ;3/5/97 15:14 - ;;4.0;Adverse Reaction Tracking;**7,33**;Mar 29, 1996;Build 5 -EN1 ; This routine will loop through the ADT entry point to get all - ; the entries in that date range. - S GMRAOUT=0 - W !,"Select an Observed date range for this report." - D DT^GMRAPL G:GMRAOUT EXIT - D PRINTER -EXIT ; Exit of program kill cleanup - D KILL^XUSCLEAN - K ^TMP($J,"GMRAPST3B") - K ^TMP($J,"GMRAPST3A") - Q -PRINTER ;Select printer - W ! K GMRAZIS D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q - I $D(IO("Q")) D Q - . S ZTRTN="PRINT^GMRAPST3",(ZTSAVE("GMRAOUT"),ZTSAVE("GMAST"),ZTSAVE("GMAEN"))="" - . S ZTDESC="Frequency Distribution of Causative Agents" D ^%ZTLOAD - . W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.") - . Q - U IO D PRINT U IO(0) - Q -PRINT ;Queue point for report - ;loop through the 120.85 file and look for the field that - D NOW^%DTC S GMRADPDT=X - S GMRADATE=GMAST-.0001,GMRAPG=1 - K ^TMP($J,"GMRAPST3A") - S GMRATOT=0 - F S GMRADATE=$O(^GMR(120.85,"B",GMRADATE)) Q:GMRADATE<1 Q:GMRADATE>GMAEN D - .S GMRAPA1=0 F S GMRAPA1=$O(^GMR(120.85,"B",GMRADATE,GMRAPA1)) Q:GMRAPA1<1 D - ..S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) Q:GMRAPA1(0)="" ;Bad Node - ..Q:+$G(^GMR(120.8,$P(GMRAPA1(0),U,15),"ER")) ;Entered in error data - ..Q:'$$PRDTST^GMRAUTL1($P(GMRAPA1(0),U,2)) ;GMRA*4*33 Exclude test patient from report if production or legacy environment. - ..S GMRATOT=GMRATOT+1 - ..S GMRAPA=$P(GMRAPA1(0),U,15) Q:'GMRAPA - ..S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) Q:GMRAPA(0)="" - ..S GMRAREC=$P(GMRAPA(0),U,2) - ..S ^TMP($J,"GMRAPST3A",GMRAREC)=$G(^TMP($J,"GMRAPST3A",GMRAREC))+1 - ..Q - .Q - Q:GMRAOUT - Q:'$D(^TMP($J,"GMRAPST3A")) - K ^TMP($J,"GMRAPST3B") - S GMRAREC="" - F S GMRAREC=$O(^TMP($J,"GMRAPST3A",GMRAREC)) Q:GMRAREC="" D - .S GMRARECN=$G(^TMP($J,"GMRAPST3A",GMRAREC)) Q:GMRARECN="" - .S ^TMP($J,"GMRAPST3B",GMRARECN,GMRAREC)="" - .Q - D HEAD - S GMRARECN="" - F S GMRARECN=$O(^TMP($J,"GMRAPST3B",GMRARECN),-1) Q:GMRARECN<1 D Q:GMRAOUT - .S GMRAREC="" - .F S GMRAREC=$O(^TMP($J,"GMRAPST3B",GMRARECN,GMRAREC)) Q:GMRAREC="" D Q:GMRAOUT - ..S GMRATAB=30-$L($E(GMRAREC,1,30)) - ..W !,?GMRATAB,$E(GMRAREC,1,30)," :",$J(GMRARECN,5) - ..D HEAD Q:GMRAOUT - ..Q - .Q - W !!,?22,"Total number of records processed ",GMRATOT - D CLOSE^GMRAUTL - Q - ;has the patient died within the date -HEAD ; Print header information - I GMRAPG'=1 Q:$Y<(IOSL-4) - I $E(IOST,1)="C" D Q:GMRAOUT - .I GMRAPG=1 W @IOF Q - .I GMRAPG'=1 D Q:GMRAOUT - ..N DIR S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1 - ..K Y - ..Q - .Q - Q:GMRAOUT - I GMRAPG'=1 W @IOF - W "Report Date: ",$P($$FMTE^XLFDT(GMRADPDT),"@"),?70,"Page: ",GMRAPG - W !,?20,"Frequency Distribution of Causative Agents" - W !,?25,"From: ",$$FMTE^XLFDT(GMAST,"2D")," To: ",$$FMTE^XLFDT(GMAEN,"2D") - W !,"Causative Agents",?34,"Number" - W !,$$REPEAT^XLFSTR("-",79) - S GMRAPG=GMRAPG+1 - I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user - Q +GMRAPST3 ;HIRMFO/WAA- PRINT FREQUENCY OF DIST OVR DT BY REACT ;3/5/97 15:14 + ;;4.0;Adverse Reaction Tracking;**7**;Mar 29, 1996 +EN1 ; This routine will loop through the ADT entry point to get all + ; the entries in that date range. + S GMRAOUT=0 + W !,"Select an Observed date range for this report." + D DT^GMRAPL G:GMRAOUT EXIT + D PRINTER +EXIT ; Exit of program kill cleanup + D KILL^XUSCLEAN + K ^TMP($J,"GMRAPST3B") + K ^TMP($J,"GMRAPST3A") + Q +PRINTER ;Select printer + W ! K GMRAZIS D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q + I $D(IO("Q")) D Q + . S ZTRTN="PRINT^GMRAPST3",(ZTSAVE("GMRAOUT"),ZTSAVE("GMAST"),ZTSAVE("GMAEN"))="" + . S ZTDESC="Frequency Distribution of Causative Agents" D ^%ZTLOAD + . W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.") + . Q + U IO D PRINT U IO(0) + Q +PRINT ;Queue point for report + ;loop through the 120.85 file and look for the field that + D NOW^%DTC S GMRADPDT=X + S GMRADATE=GMAST-.0001,GMRAPG=1 + K ^TMP($J,"GMRAPST3A") + S GMRATOT=0 + F S GMRADATE=$O(^GMR(120.85,"B",GMRADATE)) Q:GMRADATE<1 Q:GMRADATE>GMAEN D + .S GMRAPA1=0 F S GMRAPA1=$O(^GMR(120.85,"B",GMRADATE,GMRAPA1)) Q:GMRAPA1<1 D + ..S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) Q:GMRAPA1(0)="" ;Bad Node + ..Q:+$G(^GMR(120.8,$P(GMRAPA1(0),U,15),"ER")) ;Entered in error data + ..S GMRATOT=GMRATOT+1 + ..S GMRAPA=$P(GMRAPA1(0),U,15) Q:'GMRAPA + ..S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) Q:GMRAPA(0)="" + ..S GMRAREC=$P(GMRAPA(0),U,2) + ..S ^TMP($J,"GMRAPST3A",GMRAREC)=$G(^TMP($J,"GMRAPST3A",GMRAREC))+1 + ..Q + .Q + Q:GMRAOUT + Q:'$D(^TMP($J,"GMRAPST3A")) + K ^TMP($J,"GMRAPST3B") + S GMRAREC="" + F S GMRAREC=$O(^TMP($J,"GMRAPST3A",GMRAREC)) Q:GMRAREC="" D + .S GMRARECN=$G(^TMP($J,"GMRAPST3A",GMRAREC)) Q:GMRARECN="" + .S ^TMP($J,"GMRAPST3B",GMRARECN,GMRAREC)="" + .Q + D HEAD + S GMRARECN="" + F S GMRARECN=$O(^TMP($J,"GMRAPST3B",GMRARECN),-1) Q:GMRARECN<1 D Q:GMRAOUT + .S GMRAREC="" + .F S GMRAREC=$O(^TMP($J,"GMRAPST3B",GMRARECN,GMRAREC)) Q:GMRAREC="" D Q:GMRAOUT + ..S GMRATAB=30-$L($E(GMRAREC,1,30)) + ..W !,?GMRATAB,$E(GMRAREC,1,30)," :",$J(GMRARECN,5) + ..D HEAD Q:GMRAOUT + ..Q + .Q + W !!,?22,"Total number of records processed ",GMRATOT + D CLOSE^GMRAUTL + Q + ;has the patient died with inthe dat +HEAD ; Print header information + I GMRAPG'=1 Q:$Y<(IOSL-4) + I $E(IOST,1)="C" D Q:GMRAOUT + .I GMRAPG=1 W @IOF Q + .I GMRAPG'=1 D Q:GMRAOUT + ..N DIR S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1 + ..K Y + ..Q + .Q + Q:GMRAOUT + I GMRAPG'=1 W @IOF + W "Report Date: ",$P($$FMTE^XLFDT(GMRADPDT),"@"),?70,"Page: ",GMRAPG + W !,?20,"Frequency Distribution of Causative Agents" + W !,?25,"From: ",$$FMTE^XLFDT(GMAST,"2D")," To: ",$$FMTE^XLFDT(GMAEN,"2D") + W !,"Causative Agents",?34,"Number" + W !,$$REPEAT^XLFSTR("-",79) + S GMRAPG=GMRAPG+1 + I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user + Q diff --git a/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST4.m b/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST4.m index 88b70f9f..a7190aa1 100644 --- a/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST4.m +++ b/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST4.m @@ -1,83 +1,82 @@ -GMRAPST4 ;HIRMFO/WAA- PRINT FREQUENCY OF DIST OVR DT BY DC ;3/5/97 15:15 - ;;4.0;Adverse Reaction Tracking;**7,33**;Mar 29, 1996;Build 5 -EN1 ; This routine will loop through the ADT entry point to get all - ; the entries in that date range. - S GMRAOUT=0 - W !,"Select an Observed date range for this report." - D DT^GMRAPL G:GMRAOUT EXIT - D PRINTER -EXIT ; Exit of program kill cleanup - K ^TMP($J,"GMRAPST4") - D KILL^XUSCLEAN - Q -PRINTER ;Select printer - W ! K GMRAZIS D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q - I $D(IO("Q")) D Q - . S ZTRTN="PRINT^GMRAPST4",(ZTSAVE("GMRAOUT"),ZTSAVE("GMAST"),ZTSAVE("GMAEN"))="" - . S ZTDESC="Frequency Distribution of Drug Classes" D ^%ZTLOAD - . W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.") - . Q - U IO D PRINT U IO(0) - Q -PRINT ;Queue point for report - ;loop through the 120.85 file and look for the field that - D NOW^%DTC S GMRADPDT=X - S GMRADATE=GMAST-.0001,GMRAPG=1 - K ^TMP($J,"GMRAPST4") - S GMRATOT=0 - F S GMRADATE=$O(^GMR(120.85,"B",GMRADATE)) Q:GMRADATE<1 Q:GMRADATE>GMAEN D - .S GMRAPA1=0 F S GMRAPA1=$O(^GMR(120.85,"B",GMRADATE,GMRAPA1)) Q:GMRAPA1<1 D - ..S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) Q:GMRAPA1(0)="" ;Bad Node - ..Q:+$G(^GMR(120.8,$P(GMRAPA1(0),U,15),"ER")) ;Entered in error data - ..Q:'$$PRDTST^GMRAUTL1($P(GMRAPA1(0),U,2)) ;GMRA*4*33 Exclude test patient from report if production or legacy environment. - ..S GMRATOT=GMRATOT+1 - ..S GMRAPA=$P(GMRAPA1(0),U,15) Q:'GMRAPA - ..S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) Q:GMRAPA(0)="" - ..S GMRADC=0 - ..F S GMRADC=$O(^GMR(120.8,GMRAPA,3,GMRADC)) Q:GMRADC<1 D - ...S GMRADCN=$P($G(^GMR(120.8,GMRAPA,3,GMRADC,0)),U) Q:GMRADCN="" - ...S ^TMP($J,"GMRAPST4",GMRADCN)=$G(^TMP($J,"GMRAPST4",GMRADCN))+1 - ...Q - ..Q - .Q - Q:GMRAOUT - Q:'$D(^TMP($J,"GMRAPST4")) - S GMRADCN=0 - ;Sort in value order. - F S GMRADCN=$O(^TMP($J,"GMRAPST4",GMRADCN)) Q:GMRADCN<1 D - .S GMRADC=$G(^TMP($J,"GMRAPST4",GMRADCN)) Q:GMRADC<1 - .S ^TMP($J,"GMRAPST4","B",GMRADC,GMRADCN)="" - .Q - D HEAD - S GMRADC="" - F S GMRADC=$O(^TMP($J,"GMRAPST4","B",GMRADC),-1) Q:GMRADC<1 D Q:GMRAOUT - .S GMRADCN=0 - .F S GMRADCN=$O(^TMP($J,"GMRAPST4","B",GMRADC,GMRADCN)) Q:GMRADCN<1 D Q:GMRAOUT - ..S GMRADC0=$G(^PS(50.605,GMRADCN,0)) Q:GMRADC0="" - ..S GMRATAB=30-$L($E($P(GMRADC0,U,2),1,30)) - ..W !,?GMRATAB,$E($P(GMRADC0,U,2),1,30)," (",$P(GMRADC0,U),") :",$J(GMRADC,5) - ..D HEAD Q:GMRAOUT - ..Q - .Q - W !!,?22,"Total number of records processed ",GMRATOT - D CLOSE^GMRAUTL - Q -HEAD ; Print header information - I GMRAPG'=1 Q:$Y<(IOSL-4) - I $E(IOST,1)="C" D Q:GMRAOUT - .I GMRAPG=1 W @IOF Q - .I GMRAPG'=1 D Q:GMRAOUT - ..N DIR S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1 - ..K Y - ..Q - .Q - Q:GMRAOUT - I GMRAPG'=1 W @IOF - W "Report Date: ",$P($$FMTE^XLFDT(GMRADPDT),"@"),?70,"Page: ",GMRAPG - W !,?20,"Frequency Distribution of Drug Classes" - W !,?25,"From: ",$$FMTE^XLFDT(GMAST,"2D")," To: ",$$FMTE^XLFDT(GMAEN,"2D") - W !,"Drug Class",?39,"Number" - W !,$$REPEAT^XLFSTR("-",79) - S GMRAPG=GMRAPG+1 - I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user - Q +GMRAPST4 ;HIRMFO/WAA- PRINT FREQUENCY OF DIST OVR DT BY DC ;3/5/97 15:15 + ;;4.0;Adverse Reaction Tracking;**7**;Mar 29, 1996 +EN1 ; This routine will loop through the ADT entry point to get all + ; the entries in that date range. + S GMRAOUT=0 + W !,"Select an Observed date range for this report." + D DT^GMRAPL G:GMRAOUT EXIT + D PRINTER +EXIT ; Exit of program kill cleanup + K ^TMP($J,"GMRAPST4") + D KILL^XUSCLEAN + Q +PRINTER ;Select printer + W ! K GMRAZIS D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q + I $D(IO("Q")) D Q + . S ZTRTN="PRINT^GMRAPST4",(ZTSAVE("GMRAOUT"),ZTSAVE("GMAST"),ZTSAVE("GMAEN"))="" + . S ZTDESC="Frequency Distribution of Drug Classes" D ^%ZTLOAD + . W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.") + . Q + U IO D PRINT U IO(0) + Q +PRINT ;Queue point for report + ;loop through the 120.85 file and look for the field that + D NOW^%DTC S GMRADPDT=X + S GMRADATE=GMAST-.0001,GMRAPG=1 + K ^TMP($J,"GMRAPST4") + S GMRATOT=0 + F S GMRADATE=$O(^GMR(120.85,"B",GMRADATE)) Q:GMRADATE<1 Q:GMRADATE>GMAEN D + .S GMRAPA1=0 F S GMRAPA1=$O(^GMR(120.85,"B",GMRADATE,GMRAPA1)) Q:GMRAPA1<1 D + ..S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) Q:GMRAPA1(0)="" ;Bad Node + ..Q:+$G(^GMR(120.8,$P(GMRAPA1(0),U,15),"ER")) ;Entered in error data + ..S GMRATOT=GMRATOT+1 + ..S GMRAPA=$P(GMRAPA1(0),U,15) Q:'GMRAPA + ..S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) Q:GMRAPA(0)="" + ..S GMRADC=0 + ..F S GMRADC=$O(^GMR(120.8,GMRAPA,3,GMRADC)) Q:GMRADC<1 D + ...S GMRADCN=$P($G(^GMR(120.8,GMRAPA,3,GMRADC,0)),U) Q:GMRADCN="" + ...S ^TMP($J,"GMRAPST4",GMRADCN)=$G(^TMP($J,"GMRAPST4",GMRADCN))+1 + ...Q + ..Q + .Q + Q:GMRAOUT + Q:'$D(^TMP($J,"GMRAPST4")) + S GMRADCN=0 + ;Sort in value order. + F S GMRADCN=$O(^TMP($J,"GMRAPST4",GMRADCN)) Q:GMRADCN<1 D + .S GMRADC=$G(^TMP($J,"GMRAPST4",GMRADCN)) Q:GMRADC<1 + .S ^TMP($J,"GMRAPST4","B",GMRADC,GMRADCN)="" + .Q + D HEAD + S GMRADC="" + F S GMRADC=$O(^TMP($J,"GMRAPST4","B",GMRADC),-1) Q:GMRADC<1 D Q:GMRAOUT + .S GMRADCN=0 + .F S GMRADCN=$O(^TMP($J,"GMRAPST4","B",GMRADC,GMRADCN)) Q:GMRADCN<1 D Q:GMRAOUT + ..S GMRADC0=$G(^PS(50.605,GMRADCN,0)) Q:GMRADC0="" + ..S GMRATAB=30-$L($E($P(GMRADC0,U,2),1,30)) + ..W !,?GMRATAB,$E($P(GMRADC0,U,2),1,30)," (",$P(GMRADC0,U),") :",$J(GMRADC,5) + ..D HEAD Q:GMRAOUT + ..Q + .Q + W !!,?22,"Total number of records processed ",GMRATOT + D CLOSE^GMRAUTL + Q +HEAD ; Print header information + I GMRAPG'=1 Q:$Y<(IOSL-4) + I $E(IOST,1)="C" D Q:GMRAOUT + .I GMRAPG=1 W @IOF Q + .I GMRAPG'=1 D Q:GMRAOUT + ..N DIR S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1 + ..K Y + ..Q + .Q + Q:GMRAOUT + I GMRAPG'=1 W @IOF + W "Report Date: ",$P($$FMTE^XLFDT(GMRADPDT),"@"),?70,"Page: ",GMRAPG + W !,?20,"Frequency Distribution of Drug Classes" + W !,?25,"From: ",$$FMTE^XLFDT(GMAST,"2D")," To: ",$$FMTE^XLFDT(GMAEN,"2D") + W !,"Drug Class",?39,"Number" + W !,$$REPEAT^XLFSTR("-",79) + S GMRAPG=GMRAPG+1 + I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user + Q diff --git a/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST5.m b/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST5.m index 596dba1e..c37b9a86 100644 --- a/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST5.m +++ b/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST5.m @@ -1,57 +1,56 @@ -GMRAPST5 ;HIRMFO/WAA- PRINT TOTAL NUMBER OF REPORTED REACTION ;3/5/97 15:16 - ;;4.0;Adverse Reaction Tracking;**7,33**;Mar 29, 1996;Build 5 -EN1 ; This routine will loop through the ADT entry point to get all - ; the entries in that date range. - S GMRAOUT=0 - W !,"Select an Observed date range for this report." - D DT^GMRAPL G:GMRAOUT EXIT - D PRINTER -EXIT ; Exit of program kill cleanup - D KILL^XUSCLEAN - Q -PRINTER ;Select printer - W ! K GMRAZIS D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q - I $D(IO("Q")) D Q - . S ZTRTN="PRINT^GMRAPST5",(ZTSAVE("GMRAOUT"),ZTSAVE("GMAST"),ZTSAVE("GMAEN"))="" - . S ZTDESC="Reported Reaction over a date range." D ^%ZTLOAD - . W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.") - . Q - U IO D PRINT U IO(0) - Q -PRINT ;Queue point for report - ;loop through the 120.85 file and look for the field that - D NOW^%DTC S GMRADPDT=X - S GMRADATE=GMAST-.0001,GMRAPG=1 - S GMRATOT=0 - F S GMRADATE=$O(^GMR(120.85,"B",GMRADATE)) Q:GMRADATE<1 Q:GMRADATE>GMAEN D - .S GMRAPA1=0 F S GMRAPA1=$O(^GMR(120.85,"B",GMRADATE,GMRAPA1)) Q:GMRAPA1<1 D - ..S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) Q:GMRAPA1(0)="" ;Bad Node - ..Q:+$G(^GMR(120.8,$P(GMRAPA1(0),U,15),"ER")) ;Entered in Error Data - ..Q:'$$PRDTST^GMRAUTL1($P(GMRAPA1(0),U,2)) ;GMRA*4*33 Exclude test patient from report if production or legacy environment. - ..S GMRATOT=GMRATOT+1 - ..Q - .Q - Q:GMRAOUT - D HEAD - W !,?19,"Total Number of Reported Reactions: ",GMRATOT - W !,?27,"From: ",$$FMTE^XLFDT(GMAST,"2D"),?42,"To: ",$$FMTE^XLFDT(GMAEN,"2D") - D CLOSE^GMRAUTL - Q - ;has the patient died within the date -HEAD ; Print header information - I GMRAPG'=1 Q:$Y<(IOSL-4) - I $E(IOST,1)="C" D Q:GMRAOUT - .I GMRAPG=1 W @IOF Q - .I GMRAPG'=1 D Q:GMRAOUT - ..N DIR S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1 - ..K Y - ..Q - .Q - Q:GMRAOUT - I GMRAPG'=1 W @IOF - W "Report Date: ",$P($$FMTE^XLFDT(GMRADPDT),"@"),?70,"Page: ",GMRAPG - W !,?33,"Reported Reactions" - W !,$$REPEAT^XLFSTR("-",79) - S GMRAPG=GMRAPG+1 - I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user - Q +GMRAPST5 ;HIRMFO/WAA- PRINT TOTAL NUMBER OF REPORTED REACTION ;3/5/97 15:16 + ;;4.0;Adverse Reaction Tracking;**7**;Mar 29, 1996 +EN1 ; This routine will loop through the ADT entry point to get all + ; the entries in that date range. + S GMRAOUT=0 + W !,"Select an Observed date range for this report." + D DT^GMRAPL G:GMRAOUT EXIT + D PRINTER +EXIT ; Exit of program kill cleanup + D KILL^XUSCLEAN + Q +PRINTER ;Select printer + W ! K GMRAZIS D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q + I $D(IO("Q")) D Q + . S ZTRTN="PRINT^GMRAPST5",(ZTSAVE("GMRAOUT"),ZTSAVE("GMAST"),ZTSAVE("GMAEN"))="" + . S ZTDESC="Reported Reaction over a date range." D ^%ZTLOAD + . W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.") + . Q + U IO D PRINT U IO(0) + Q +PRINT ;Queue point for report + ;loop through the 120.85 file and look for the field that + D NOW^%DTC S GMRADPDT=X + S GMRADATE=GMAST-.0001,GMRAPG=1 + S GMRATOT=0 + F S GMRADATE=$O(^GMR(120.85,"B",GMRADATE)) Q:GMRADATE<1 Q:GMRADATE>GMAEN D + .S GMRAPA1=0 F S GMRAPA1=$O(^GMR(120.85,"B",GMRADATE,GMRAPA1)) Q:GMRAPA1<1 D + ..S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) Q:GMRAPA1(0)="" ;Bad Node + ..Q:+$G(^GMR(120.8,$P(GMRAPA1(0),U,15),"ER")) ;Entered in Error Data + ..S GMRATOT=GMRATOT+1 + ..Q + .Q + Q:GMRAOUT + D HEAD + W !,?19,"Total Number of Reported Reactions: ",GMRATOT + W !,?27,"From: ",$$FMTE^XLFDT(GMAST,"2D"),?42,"To: ",$$FMTE^XLFDT(GMAEN,"2D") + D CLOSE^GMRAUTL + Q + ;has the patient died with inthe dat +HEAD ; Print header information + I GMRAPG'=1 Q:$Y<(IOSL-4) + I $E(IOST,1)="C" D Q:GMRAOUT + .I GMRAPG=1 W @IOF Q + .I GMRAPG'=1 D Q:GMRAOUT + ..N DIR S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1 + ..K Y + ..Q + .Q + Q:GMRAOUT + I GMRAPG'=1 W @IOF + W "Report Date: ",$P($$FMTE^XLFDT(GMRADPDT),"@"),?70,"Page: ",GMRAPG + W !,?33,"Reported Reactions" + W !,$$REPEAT^XLFSTR("-",79) + S GMRAPG=GMRAPG+1 + I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user + Q diff --git a/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST6.m b/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST6.m index 07191e2c..5e6b6fcd 100644 --- a/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST6.m +++ b/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST6.m @@ -1,96 +1,95 @@ -GMRAPST6 ;HIRMFO/WAA- ADR OUTCOME REPORT ;3/5/97 15:16 - ;;4.0;Adverse Reaction Tracking;**7,33**;Mar 29, 1996;Build 5 -EN1 ; This routine will loop through the ADT entry point to get all - ; the entries in that date range. - S GMRAOUT=0 - W !,"Select an Observed date range for this report." - D DT^GMRAPL G:GMRAOUT EXIT - D PRINTER -EXIT ; Exit of program kill cleanup - D KILL^XUSCLEAN - K ^TMP($J,"GMRAPST6") - Q -PRINTER ;Select printer - W ! K GMRAZIS D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q - I $D(IO("Q")) D Q - . S ZTRTN="PRINT^GMRAPST6",(ZTSAVE("GMRAOUT"),ZTSAVE("GMAST"),ZTSAVE("GMAEN"))="" - . S ZTDESC="P&T Committee ADR Outcome Report" D ^%ZTLOAD - . W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.") - . Q - U IO D PRINT U IO(0) - Q -PRINT ;Queue point for report - ;loop through the 120.85 file and look for the field that - K ^TMP($J,"GMRAPST6") - D NOW^%DTC S GMRADPDT=X - S GMRADATE=GMAST-.0001,GMRAPG=1 - F S GMRADATE=$O(^GMR(120.85,"B",GMRADATE)) Q:GMRADATE<1 Q:GMRADATE>GMAEN D - .S GMRAPA1=0 F S GMRAPA1=$O(^GMR(120.85,"B",GMRADATE,GMRAPA1)) Q:GMRAPA1<1 D - ..S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) Q:GMRAPA1(0)="" ;Bad Node - ..S GMRADDT=$P(GMRAPA1(0),U) ; reaction date - ..S GMRAPA=$P(GMRAPA1(0),U,15) ; Get the 120.8 entry for this reaction in 120.85 - ..S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) Q:GMRAPA(0)="" ; Bad node - ..Q:+$G(^GMR(120.8,GMRAPA,"ER")) ;entered in error data - ..S GMRACA=$P(GMRAPA(0),U,2) ; Causative Agent - ..S DFN=$P(GMRAPA(0),U),GMRACA=$E(GMRACA,1,22)_"-"_$E($P(^DPT(DFN,0),U),1)_$E($P(^(0),U,9),6,9) - ..Q:'$$PRDTST^GMRAUTL1(DFN) ;GMRA*4*33 Exclude test patients if production or legacy environment. - ..S ^TMP($J,"GMRAPST6",GMRADDT,GMRACA,GMRAPA1)="" - ..Q - .Q - Q:GMRAOUT - I '$D(^TMP($J,"GMRAPST6")) D HEAD W !,"NO DATA FOR THIS REPORT..." Q - S GMRAOTH=$G(GMRAOTH,$O(^GMRD(120.83,"B","OTHER REACTION",0))) - S GMRADDT=0 - F S GMRADDT=$O(^TMP($J,"GMRAPST6",GMRADDT)) Q:GMRADDT<1 D Q:GMRAOUT - .S GMRACA="" - .F S GMRACA=$O(^TMP($J,"GMRAPST6",GMRADDT,GMRACA)) Q:GMRACA="" D Q:GMRAOUT - ..S GMRAPA1=0 - ..F S GMRAPA1=$O(^TMP($J,"GMRAPST6",GMRADDT,GMRACA,GMRAPA1)) Q:GMRAPA1<1 D Q:GMRAOUT - ...S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) - ...Q:GMRAPA(0)="" - ...D HEAD Q:GMRAOUT - ...W !,$J($$FMTE^XLFDT(GMRADDT,"2D"),8) ; Obs Date - ...W ?8,"|",GMRACA ; Causative Agent - ...W ?38,"|" - ...S GMRAREC=0 - ...S GMRAREC=$O(^GMR(120.85,GMRAPA1,2,0)) D:GMRAREC>0 SIGN("0",GMRAREC) - ...W ?58,"|" W:$P(GMRAPA1(0),U,4)="y" " Y" ; Req Tx with Rx - ...W ?63,"|" W:$P(GMRAPA1(0),U,7)="y" " Y" ; Req Hosp. - ...W ?68,"|" W:$P(GMRAPA1(0),U,10)="y" " Y" ; Disability - ...W ?73,"|" W:$P(GMRAPA1(0),U,3)="y" " Y" ; Death - ...F S GMRAREC=$O(^GMR(120.85,GMRAPA1,2,GMRAREC)) Q:GMRAREC<1 D SIGN("1",GMRAREC) Q:GMRAOUT - ...Q:GMRAOUT - ...D HEAD Q:GMRAOUT W !,?8,"|",?38,"|",?58,"|",?63,"|",?68,"|",?73,"|" - ...Q - ..Q - .Q - D CLOSE^GMRAUTL - Q -SIGN(CNT,GMRAREC) ; Print Sign/Symptoms - N NAM,Y - S Y=$G(^GMR(120.85,GMRAPA1,2,GMRAREC,0)) - S NAM=$S(+Y=GMRAOTH:$P(Y,U,2),$D(^GMRD(120.83,+Y,0)):$P(^GMRD(120.83,+Y,0),U),1:"") - I 'CNT W $E(NAM,1,19) - E D HEAD Q:GMRAOUT W !,?8,"|",?38,"|",$E(NAM,1,19),?58,"|",?63,"|",?68,"|",?73,"|" - Q -HEAD ; Print header information - I GMRAPG'=1 Q:$Y<(IOSL-4) - I $E(IOST,1)="C" D Q:GMRAOUT - .I GMRAPG=1 W @IOF Q - .I GMRAPG'=1 D Q:GMRAOUT - ..N DIR S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1 - ..K Y - ..Q - .Q - Q:GMRAOUT - I GMRAPG'=1 W @IOF - W "Report Date: ",$P($$FMTE^XLFDT(GMRADPDT),"@"),?70,"Page: ",GMRAPG - W !,?22,"P&T Committee ADR Outcome Report" - W !,?25,"From: ",$$FMTE^XLFDT(GMAST,"2D")," To: ",$$FMTE^XLFDT(GMAEN,"2D") - W !,$$REPEAT^XLFSTR("-",79) - W !,"Obsv.",?8,"|",?38,"|",?58,"|Req.",?63,"|Req.",?68,"|",?73,"|" - W !,"Date",?8,"|Causative agent-Pat. ID",?38,"|Sign/Symptoms",?58,"|Tx",?63,"|Hosp",?68,"|Dis.",?73,"|Death" - W !,$$REPEAT^XLFSTR("-",79) - S GMRAPG=GMRAPG+1 - I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user - Q +GMRAPST6 ;HIRMFO/WAA- ADR OUTCOME REPORT ;3/5/97 15:16 + ;;4.0;Adverse Reaction Tracking;**7**;Mar 29, 1996 +EN1 ; This routine will loop through the ADT entry point to get all + ; the entries in that date range. + S GMRAOUT=0 + W !,"Select an Observed date range for this report." + D DT^GMRAPL G:GMRAOUT EXIT + D PRINTER +EXIT ; Exit of program kill cleanup + D KILL^XUSCLEAN + K ^TMP($J,"GMRAPST6") + Q +PRINTER ;Select printer + W ! K GMRAZIS D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q + I $D(IO("Q")) D Q + . S ZTRTN="PRINT^GMRAPST6",(ZTSAVE("GMRAOUT"),ZTSAVE("GMAST"),ZTSAVE("GMAEN"))="" + . S ZTDESC="P&T Committee ADR Outcome Report" D ^%ZTLOAD + . W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.") + . Q + U IO D PRINT U IO(0) + Q +PRINT ;Queue point for report + ;loop through the 120.85 file and look for the field that + K ^TMP($J,"GMRAPST6") + D NOW^%DTC S GMRADPDT=X + S GMRADATE=GMAST-.0001,GMRAPG=1 + F S GMRADATE=$O(^GMR(120.85,"B",GMRADATE)) Q:GMRADATE<1 Q:GMRADATE>GMAEN D + .S GMRAPA1=0 F S GMRAPA1=$O(^GMR(120.85,"B",GMRADATE,GMRAPA1)) Q:GMRAPA1<1 D + ..S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) Q:GMRAPA1(0)="" ;Bad Node + ..S GMRADDT=$P(GMRAPA1(0),U) ; reaction date + ..S GMRAPA=$P(GMRAPA1(0),U,15) ; Get the 120.8 entry for this reaction in 120.85 + ..S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) Q:GMRAPA(0)="" ; Bad node + ..Q:+$G(^GMR(120.8,GMRAPA,"ER")) ;entered in error data + ..S GMRACA=$P(GMRAPA(0),U,2) ; Causative Agent + ..S DFN=$P(GMRAPA(0),U),GMRACA=$E(GMRACA,1,22)_"-"_$E($P(^DPT(DFN,0),U),1)_$E($P(^(0),U,9),6,9) + ..S ^TMP($J,"GMRAPST6",GMRADDT,GMRACA,GMRAPA1)="" + ..Q + .Q + Q:GMRAOUT + I '$D(^TMP($J,"GMRAPST6")) D HEAD W !,"NO DATA FOR THIS REPORT..." Q + S GMRAOTH=$G(GMRAOTH,$O(^GMRD(120.83,"B","OTHER REACTION",0))) + S GMRADDT=0 + F S GMRADDT=$O(^TMP($J,"GMRAPST6",GMRADDT)) Q:GMRADDT<1 D Q:GMRAOUT + .S GMRACA="" + .F S GMRACA=$O(^TMP($J,"GMRAPST6",GMRADDT,GMRACA)) Q:GMRACA="" D Q:GMRAOUT + ..S GMRAPA1=0 + ..F S GMRAPA1=$O(^TMP($J,"GMRAPST6",GMRADDT,GMRACA,GMRAPA1)) Q:GMRAPA1<1 D Q:GMRAOUT + ...S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) + ...Q:GMRAPA(0)="" + ...D HEAD Q:GMRAOUT + ...W !,$J($$FMTE^XLFDT(GMRADDT,"2D"),8) ; Obs Date + ...W ?8,"|",GMRACA ; Causative Agent + ...W ?38,"|" + ...S GMRAREC=0 + ...S GMRAREC=$O(^GMR(120.85,GMRAPA1,2,0)) D:GMRAREC>0 SIGN("0",GMRAREC) + ...W ?58,"|" W:$P(GMRAPA1(0),U,4)="y" " Y" ; Req Tx with Rx + ...W ?63,"|" W:$P(GMRAPA1(0),U,7)="y" " Y" ; Req Hosp. + ...W ?68,"|" W:$P(GMRAPA1(0),U,10)="y" " Y" ; Disability + ...W ?73,"|" W:$P(GMRAPA1(0),U,3)="y" " Y" ; Death + ...F S GMRAREC=$O(^GMR(120.85,GMRAPA1,2,GMRAREC)) Q:GMRAREC<1 D SIGN("1",GMRAREC) Q:GMRAOUT + ...Q:GMRAOUT + ...D HEAD Q:GMRAOUT W !,?8,"|",?38,"|",?58,"|",?63,"|",?68,"|",?73,"|" + ...Q + ..Q + .Q + D CLOSE^GMRAUTL + Q +SIGN(CNT,GMRAREC) ; Print Sign/Symptoms + N NAM,Y + S Y=$G(^GMR(120.85,GMRAPA1,2,GMRAREC,0)) + S NAM=$S(+Y=GMRAOTH:$P(Y,U,2),$D(^GMRD(120.83,+Y,0)):$P(^GMRD(120.83,+Y,0),U),1:"") + I 'CNT W $E(NAM,1,19) + E D HEAD Q:GMRAOUT W !,?8,"|",?38,"|",$E(NAM,1,19),?58,"|",?63,"|",?68,"|",?73,"|" + Q +HEAD ; Print header information + I GMRAPG'=1 Q:$Y<(IOSL-4) + I $E(IOST,1)="C" D Q:GMRAOUT + .I GMRAPG=1 W @IOF Q + .I GMRAPG'=1 D Q:GMRAOUT + ..N DIR S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1 + ..K Y + ..Q + .Q + Q:GMRAOUT + I GMRAPG'=1 W @IOF + W "Report Date: ",$P($$FMTE^XLFDT(GMRADPDT),"@"),?70,"Page: ",GMRAPG + W !,?22,"P&T Committee ADR Outcome Report" + W !,?25,"From: ",$$FMTE^XLFDT(GMAST,"2D")," To: ",$$FMTE^XLFDT(GMAEN,"2D") + W !,$$REPEAT^XLFSTR("-",79) + W !,"Obsv.",?8,"|",?38,"|",?58,"|Req.",?63,"|Req.",?68,"|",?73,"|" + W !,"Date",?8,"|Causative agent-Pat. ID",?38,"|Sign/Symptoms",?58,"|Tx",?63,"|Hosp",?68,"|Dis.",?73,"|Death" + W !,$$REPEAT^XLFSTR("-",79) + S GMRAPG=GMRAPG+1 + I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user + Q diff --git a/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST7.m b/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST7.m index 57f2f25c..afb31f72 100644 --- a/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST7.m +++ b/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST7.m @@ -1,112 +1,111 @@ -GMRAPST7 ;HIRMFO/WAA- ADVERSE DRUG REACTION REPORT ;3/5/97 15:17 - ;;4.0;Adverse Reaction Tracking;**7,33**;Mar 29, 1996;Build 5 -EN1 ; This routine will loop through the ADT entry point to get all - ; the entries in that date range. - S GMRAOUT=0 - W !,"Select an Observed date range for this report." - D DT^GMRAPL G:GMRAOUT EXIT - D PRINTER -EXIT ; Exit of program kill cleanup - D KILL^XUSCLEAN - K ^TMP($J,"GMRAPST7") - Q -PRINTER ;Select printer - W !!,"This report required a 132 column printer." - K GMRAZIS S GMRAZIS="M132" D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q - I $D(IO("Q")) D Q - . S ZTRTN="PRINT^GMRAPST7",(ZTSAVE("GMRAOUT"),ZTSAVE("GMAST"),ZTSAVE("GMAEN"))="" - . S ZTDESC="P&T Committee ADR Report" D ^%ZTLOAD - . W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.") - . Q - U IO D PRINT U IO(0) - Q -PRINT ;Queue point for report - ;loop through the 120.85 file and look for the field that - K ^TMP($J,"GMRAPST7") - D NOW^%DTC S GMRADPDT=X - S GMRADATE=GMAST-.0001,GMRAPG=1 - F S GMRADATE=$O(^GMR(120.85,"B",GMRADATE)) Q:GMRADATE<1 Q:GMRADATE>GMAEN D - .S GMRAPA1=0 F S GMRAPA1=$O(^GMR(120.85,"B",GMRADATE,GMRAPA1)) Q:GMRAPA1<1 D - ..S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) Q:GMRAPA1(0)="" ;Bad Node - ..S GMRADDT=$P(GMRAPA1(0),U) ; reaction date - ..S GMRAPA=$P(GMRAPA1(0),U,15) ; Get the 120.8 entry for this reaction in 120.85 - ..S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) Q:GMRAPA(0)="" ; Bad node - ..Q:+$G(^GMR(120.8,GMRAPA,"ER")) ;Entered in error data - ..S GMRACA=$P(GMRAPA(0),U,2) ; Causative Agent - ..S DFN=$P(GMRAPA(0),U),GMRACA=$E(GMRACA,1,22)_"-"_$E($P(^DPT(DFN,0),U),1)_$E($P(^(0),U,9),6,9) - ..Q:'$$PRDTST^GMRAUTL1(DFN) ;GMRA*4*33 Exclude test patients from report if production or legacy environment. - ..S ^TMP($J,"GMRAPST7",GMRADDT,GMRACA,GMRAPA1)=GMRAPA - ..Q - .Q - Q:GMRAOUT - I '$D(^TMP($J,"GMRAPST7")) D HEAD W !,"NO DATA FOR THIS REPORT..." Q - S GMRAOTH=$G(GMRAOTH,$O(^GMRD(120.83,"B","OTHER REACTION",0))) - S GMRADDT=0 - F S GMRADDT=$O(^TMP($J,"GMRAPST7",GMRADDT)) Q:GMRADDT<1 D Q:GMRAOUT - .S GMRACA="" - .F S GMRACA=$O(^TMP($J,"GMRAPST7",GMRADDT,GMRACA)) Q:GMRACA="" D Q:GMRAOUT - ..S GMRAPA1=0 - ..F S GMRAPA1=$O(^TMP($J,"GMRAPST7",GMRADDT,GMRACA,GMRAPA1)) Q:GMRAPA1<1 D Q:GMRAOUT - ...S GMRAPA=$G(^TMP($J,"GMRAPST7",GMRADDT,GMRACA,GMRAPA1)) - ...Q:GMRAPA="" - ...S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) - ...Q:GMRAPA1(0)="" - ...S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) - ...Q:GMRAPA(0)="" - ...D HEAD Q:GMRAOUT - ...W !,$J($$FMTE^XLFDT(GMRADDT,"2D"),8) ; Obs Date - ...W ?8,"|",GMRACA ; Causative Agent - ...W ?38,"|" - ...S GMRAREC=0 - ...S GMRAREC=$O(^GMR(120.85,GMRAPA1,2,0)) D:GMRAREC>0 SIGN("0",GMRAREC) - ...W ?58,"| " W $P(GMRAPA(0),U,14) ; Mechanism - ...W ?63,"|" W $S($P(GMRAPA1(0),U,14)=1:"MILD",$P(GMRAPA1(0),U,14)=2:"MOD.",$P(GMRAPA1(0),U,14)=3:"SVR.",1:"") ; Severity - ...W ?68,"|" - ...K ^TMP($J,"GMRAWORD") D WORD^GMRAWORD(GMRAPA,"OVE",60) - ...S GMRACNT=1 W $G(^TMP($J,"GMRAWORD",GMRACNT)) - ...F S GMRAREC=$O(^GMR(120.85,GMRAPA1,2,GMRAREC)) Q:GMRAREC<1 D SIGN("1",GMRAREC) Q:GMRAOUT - ...F S GMRACNT=$O(^TMP($J,"GMRAWORD",GMRACNT)) Q:GMRACNT<1 D Q:GMRAOUT - ....D HEAD Q:GMRAOUT W !,?8,"|",?38,"|",?58,"|",?63,"|",?68,"|" - ....Q:GMRAOUT - ....W $G(^TMP($J,"GMRAWORD",GMRACNT)) - ....Q - ...K ^TMP($J,"GMRAWORD") - ...Q:GMRAOUT - ...D HEAD Q:GMRAOUT W !,?8,"|",?38,"|",?58,"|",?63,"|",?68,"|" - ...Q - ..Q - .Q - D CLOSE^GMRAUTL - Q -SIGN(CNT,GMRAREC) ; Print Sign/Symptoms - N NAM,Y - S Y=$G(^GMR(120.85,GMRAPA1,2,GMRAREC,0)) - S NAM=$S(+Y=GMRAOTH:$P(Y,U,2),$D(^GMRD(120.83,+Y,0)):$P(^GMRD(120.83,+Y,0),U),1:"") - I 'CNT W $E(NAM,1,19) - E D - .D HEAD Q:GMRAOUT W !,?8,"|",?38,"|",$E(NAM,1,19),?58,"|",?63,"|",?68,"|" - .I $D(^TMP($J,"GMRAWORD",(GMRACNT+1))) S GMRACNT=GMRACNT+1 W $G(^TMP($J,"GMRAWORD",GMRACNT)) - .Q - Q -HEAD ; Print header information - I GMRAPG'=1 Q:$Y<(IOSL-4) - I $E(IOST,1)="C" D Q:GMRAOUT - .I GMRAPG=1 W @IOF Q - .I GMRAPG'=1 D Q:GMRAOUT - ..N DIR S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1 - ..K Y - ..Q - .Q - Q:GMRAOUT - I GMRAPG'=1 W @IOF - N Z - W "Report Date: ",$P($$FMTE^XLFDT(GMRADPDT),"@"),?125,"Page: ",GMRAPG - W !,?48,"P&T Committee ADR Report" - W !,?51,"From: ",$$FMTE^XLFDT(GMAST,"2D")," To: ",$$FMTE^XLFDT(GMAEN,"2D") - W !,$$REPEAT^XLFSTR("-",130) - W !,"Obsv.",?8,"|",?38,"|",?58,"|ADR",?63,"|ADR",?68,"|" - W !,"Date",?8,"|Causative agent-Pat. ID",?38,"|Sign/Symptoms",?58,"|Mech",?63,"|Svr.",?68,"|Comments" - W !,$$REPEAT^XLFSTR("-",130) - S GMRAPG=GMRAPG+1 - I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user - Q +GMRAPST7 ;HIRMFO/WAA- ADVERSE DRUG REACTION REPORT ;3/5/97 15:17 + ;;4.0;Adverse Reaction Tracking;**7**;Mar 29, 1996 +EN1 ; This routine will loop through the ADT entry point to get all + ; the entries in that date range. + S GMRAOUT=0 + W !,"Select an Observed date range for this report." + D DT^GMRAPL G:GMRAOUT EXIT + D PRINTER +EXIT ; Exit of program kill cleanup + D KILL^XUSCLEAN + K ^TMP($J,"GMRAPST7") + Q +PRINTER ;Select printer + W !!,"This report required a 132 column printer." + K GMRAZIS S GMRAZIS="M132" D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q + I $D(IO("Q")) D Q + . S ZTRTN="PRINT^GMRAPST7",(ZTSAVE("GMRAOUT"),ZTSAVE("GMAST"),ZTSAVE("GMAEN"))="" + . S ZTDESC="P&T Committee ADR Report" D ^%ZTLOAD + . W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.") + . Q + U IO D PRINT U IO(0) + Q +PRINT ;Queue point for report + ;loop through the 120.85 file and look for the field that + K ^TMP($J,"GMRAPST7") + D NOW^%DTC S GMRADPDT=X + S GMRADATE=GMAST-.0001,GMRAPG=1 + F S GMRADATE=$O(^GMR(120.85,"B",GMRADATE)) Q:GMRADATE<1 Q:GMRADATE>GMAEN D + .S GMRAPA1=0 F S GMRAPA1=$O(^GMR(120.85,"B",GMRADATE,GMRAPA1)) Q:GMRAPA1<1 D + ..S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) Q:GMRAPA1(0)="" ;Bad Node + ..S GMRADDT=$P(GMRAPA1(0),U) ; reaction date + ..S GMRAPA=$P(GMRAPA1(0),U,15) ; Get the 120.8 entry for this reaction in 120.85 + ..S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) Q:GMRAPA(0)="" ; Bad node + ..Q:+$G(^GMR(120.8,GMRAPA,"ER")) ;Entered in error data + ..S GMRACA=$P(GMRAPA(0),U,2) ; Causative Agent + ..S DFN=$P(GMRAPA(0),U),GMRACA=$E(GMRACA,1,22)_"-"_$E($P(^DPT(DFN,0),U),1)_$E($P(^(0),U,9),6,9) + ..S ^TMP($J,"GMRAPST7",GMRADDT,GMRACA,GMRAPA1)=GMRAPA + ..Q + .Q + Q:GMRAOUT + I '$D(^TMP($J,"GMRAPST7")) D HEAD W !,"NO DATA FOR THIS REPORT..." Q + S GMRAOTH=$G(GMRAOTH,$O(^GMRD(120.83,"B","OTHER REACTION",0))) + S GMRADDT=0 + F S GMRADDT=$O(^TMP($J,"GMRAPST7",GMRADDT)) Q:GMRADDT<1 D Q:GMRAOUT + .S GMRACA="" + .F S GMRACA=$O(^TMP($J,"GMRAPST7",GMRADDT,GMRACA)) Q:GMRACA="" D Q:GMRAOUT + ..S GMRAPA1=0 + ..F S GMRAPA1=$O(^TMP($J,"GMRAPST7",GMRADDT,GMRACA,GMRAPA1)) Q:GMRAPA1<1 D Q:GMRAOUT + ...S GMRAPA=$G(^TMP($J,"GMRAPST7",GMRADDT,GMRACA,GMRAPA1)) + ...Q:GMRAPA="" + ...S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) + ...Q:GMRAPA1(0)="" + ...S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) + ...Q:GMRAPA(0)="" + ...D HEAD Q:GMRAOUT + ...W !,$J($$FMTE^XLFDT(GMRADDT,"2D"),8) ; Obs Date + ...W ?8,"|",GMRACA ; Causative Agent + ...W ?38,"|" + ...S GMRAREC=0 + ...S GMRAREC=$O(^GMR(120.85,GMRAPA1,2,0)) D:GMRAREC>0 SIGN("0",GMRAREC) + ...W ?58,"| " W $P(GMRAPA(0),U,14) ; Mechanism + ...W ?63,"|" W $S($P(GMRAPA1(0),U,14)=1:"MILD",$P(GMRAPA1(0),U,14)=2:"MOD.",$P(GMRAPA1(0),U,14)=3:"SVR.",1:"") ; Severity + ...W ?68,"|" + ...K ^TMP($J,"GMRAWORD") D WORD^GMRAWORD(GMRAPA,"OVE",60) + ...S GMRACNT=1 W $G(^TMP($J,"GMRAWORD",GMRACNT)) + ...F S GMRAREC=$O(^GMR(120.85,GMRAPA1,2,GMRAREC)) Q:GMRAREC<1 D SIGN("1",GMRAREC) Q:GMRAOUT + ...F S GMRACNT=$O(^TMP($J,"GMRAWORD",GMRACNT)) Q:GMRACNT<1 D Q:GMRAOUT + ....D HEAD Q:GMRAOUT W !,?8,"|",?38,"|",?58,"|",?63,"|",?68,"|" + ....Q:GMRAOUT + ....W $G(^TMP($J,"GMRAWORD",GMRACNT)) + ....Q + ...K ^TMP($J,"GMRAWORD") + ...Q:GMRAOUT + ...D HEAD Q:GMRAOUT W !,?8,"|",?38,"|",?58,"|",?63,"|",?68,"|" + ...Q + ..Q + .Q + D CLOSE^GMRAUTL + Q +SIGN(CNT,GMRAREC) ; Print Sign/Symptoms + N NAM,Y + S Y=$G(^GMR(120.85,GMRAPA1,2,GMRAREC,0)) + S NAM=$S(+Y=GMRAOTH:$P(Y,U,2),$D(^GMRD(120.83,+Y,0)):$P(^GMRD(120.83,+Y,0),U),1:"") + I 'CNT W $E(NAM,1,19) + E D + .D HEAD Q:GMRAOUT W !,?8,"|",?38,"|",$E(NAM,1,19),?58,"|",?63,"|",?68,"|" + .I $D(^TMP($J,"GMRAWORD",(GMRACNT+1))) S GMRACNT=GMRACNT+1 W $G(^TMP($J,"GMRAWORD",GMRACNT)) + .Q + Q +HEAD ; Print header information + I GMRAPG'=1 Q:$Y<(IOSL-4) + I $E(IOST,1)="C" D Q:GMRAOUT + .I GMRAPG=1 W @IOF Q + .I GMRAPG'=1 D Q:GMRAOUT + ..N DIR S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1 + ..K Y + ..Q + .Q + Q:GMRAOUT + I GMRAPG'=1 W @IOF + N Z + W "Report Date: ",$P($$FMTE^XLFDT(GMRADPDT),"@"),?125,"Page: ",GMRAPG + W !,?48,"P&T Committee ADR Report" + W !,?51,"From: ",$$FMTE^XLFDT(GMAST,"2D")," To: ",$$FMTE^XLFDT(GMAEN,"2D") + W !,$$REPEAT^XLFSTR("-",130) + W !,"Obsv.",?8,"|",?38,"|",?58,"|ADR",?63,"|ADR",?68,"|" + W !,"Date",?8,"|Causative agent-Pat. ID",?38,"|Sign/Symptoms",?58,"|Mech",?63,"|Svr.",?68,"|Comments" + W !,$$REPEAT^XLFSTR("-",130) + S GMRAPG=GMRAPG+1 + I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user + Q diff --git a/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPU.m b/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPU.m index 58998e29..4a4f969d 100644 --- a/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPU.m +++ b/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPU.m @@ -1,81 +1,80 @@ -GMRAPU ;HIRMFO/WAA- PRINT ALLERGY LIST BY LOCATION UNVERIFIED ;8/27/93 - ;;4.0;Adverse Reaction Tracking;**33**;Mar 29, 1996;Build 5 -EN1 ; This routine will loop through the GMRA patient allergy file (120.8) - ; to find all patients with unverified reactions - ; - S GMRAOUT=0 D PRINTER -EXIT ; Exit of program kill cleanup - D KILL^XUSCLEAN - K ^TMP($J,"GMRAPU") - Q -PRINTER ;Select printer - W ! K GMRAZIS D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q - I $D(IO("Q")) D Q - . S ZTRTN="PRINT^GMRAPU",ZTSAVE("GMRAOUT")="" - . S ZTDESC="List of Unverified Reactions by Ward Location" D ^%ZTLOAD - . W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.") - . Q - U IO D PRINT U IO(0) - Q -PRINT ;Queue point for report - K ^TMP($J,"GMRAPU") D FIND -REPORT ; Print out the report - S GMRAOUT=$G(GMRAOUT) - S GMALOC="",GMRAPG=1,GMRADATE=$$NOW^XLFDT - I '$D(^TMP($J,"GMRAPU")) D HEAD W !,?20,"NO DATA FOR THIS REPORT" - F S GMALOC=$O(^TMP($J,"GMRAPU",GMALOC)) Q:GMALOC="" D HEAD Q:GMRAOUT D Q:GMRAOUT - .S GMRANAM="" F S GMRANAM=$O(^TMP($J,"GMRAPU",GMALOC,GMRANAM)) Q:GMRANAM="" D Q:GMRAOUT - ..S GMADFN=0 F S GMADFN=$O(^TMP($J,"GMRAPU",GMALOC,GMRANAM,GMADFN)) Q:GMADFN<1 D Q:GMRAOUT - ...S GMRASSN="",GMRARB="" - ...D VAD^GMRAUTL1(GMADFN,"","","","",.GMRASSN,.GMRARB) - ...W !,GMRARB,$S(GMRARB'="":" ",1:""),GMRANAM," (",GMRASSN,")" - ...S GMADT=0 F S GMADT=$O(^TMP($J,"GMRAPU",GMALOC,GMRANAM,GMADFN,GMADT)) Q:GMADT<1 S GMRAPA=0 F S GMRAPA=$O(^TMP($J,"GMRAPU",GMALOC,GMRANAM,GMADFN,GMADT,GMRAPA)) Q:GMRAPA<1 D Q:GMRAOUT - ....S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) - ....Q:GMRAPA(0)="" - ....W !,?3,$$FMTE^XLFDT(GMADT,"1") - ....W ?30,$S($P(GMRAPA(0),U,5)'="":$E($P($G(^VA(200,$P(GMRAPA(0),U,5),0)),U),1,24),1:"") - ....W ?55,$E($P(GMRAPA(0),U,2),1,24) - ....I $Y>(IOSL-4) D HEAD - ....Q - ...Q - ..Q - .Q - D CLOSE^GMRAUTL - Q -HEAD ; Print header information - I $E(IOST,1)="C" D Q:GMRAOUT - .I GMRAPG=1 W @IOF Q - .I GMRAPG'=1 D Q:GMRAOUT - ..N DIR S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1 - ..K Y - ..Q - .Q - Q:GMRAOUT - I GMRAPG'=1 W @IOF - W "Report Date: ",$P($$FMTE^XLFDT(GMRADATE),"@"),?70,"Page: ",GMRAPG - W !,?19,"List of Unverified Reactions by Ward Location" - W !,?30,"Ward Location: ",GMALOC - W !,?3,"Origination Date/Time",?30,"Originator",?55,"Reaction" - W !,$$REPEAT^XLFSTR("-",78) - S GMRAPG=GMRAPG+1 - I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user - Q -FIND ; This subroutines will build the data for the report. - N GMADFN - S GMADFN=0 - F S GMADFN=$O(^GMR(120.8,"AVER",GMADFN)) Q:GMADFN<1 D - .N GMRALOC,GMRANAM,GMALOC,GMRAPA - .S GMRANAM="",GMRALOC="" - .Q:'$$PRDTST^GMRAUTL1(GMADFN) ;GMRA*4*33 Exclude test patients if production or legacy environment. - .D VAD^GMRAUTL1(GMADFN,"",.GMRALOC,.GMRANAM,"","","") I GMRALOC="" S GMALOC="OUTPATIENT" - .E S GMALOC=$P($G(^DIC(42,GMRALOC,0)),U) - .Q:GMALOC="" - .S GMRAPA=0 - .F S GMRAPA=$O(^GMR(120.8,"AVER",GMADFN,GMRAPA)) Q:GMRAPA<1 D - ..N GMADT - ..S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) Q:GMRAPA(0)="" - ..S GMADT=$P(GMRAPA(0),U,4) - ..S ^TMP($J,"GMRAPU",GMALOC,GMRANAM,GMADFN,GMADT,GMRAPA)="" - ..Q - .Q - Q +GMRAPU ;HIRMFO/WAA- PRINT ALLERGY LIST BY LOCATION UNVERIFIED ; 8/27/93 + ;;4.0;Adverse Reaction Tracking;;Mar 29, 1996 +EN1 ; This routine will loop through the GMRA patient allergy file (120.8) + ; to find all patients with unverified reactions + ; + S GMRAOUT=0 D PRINTER +EXIT ; Exit of program kill cleanup + D KILL^XUSCLEAN + K ^TMP($J,"GMRAPU") + Q +PRINTER ;Select printer + W ! K GMRAZIS D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q + I $D(IO("Q")) D Q + . S ZTRTN="PRINT^GMRAPU",ZTSAVE("GMRAOUT")="" + . S ZTDESC="List of Unverified Reactions by Ward Location" D ^%ZTLOAD + . W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.") + . Q + U IO D PRINT U IO(0) + Q +PRINT ;Queue point for report + K ^TMP($J,"GMRAPU") D FIND +REPORT ; Print out the report + S GMRAOUT=$G(GMRAOUT) + S GMALOC="",GMRAPG=1,GMRADATE=$$NOW^XLFDT + I '$D(^TMP($J,"GMRAPU")) D HEAD W !,?20,"NO DATA FOR THIS REPORT" + F S GMALOC=$O(^TMP($J,"GMRAPU",GMALOC)) Q:GMALOC="" D HEAD Q:GMRAOUT D Q:GMRAOUT + .S GMRANAM="" F S GMRANAM=$O(^TMP($J,"GMRAPU",GMALOC,GMRANAM)) Q:GMRANAM="" D Q:GMRAOUT + ..S GMADFN=0 F S GMADFN=$O(^TMP($J,"GMRAPU",GMALOC,GMRANAM,GMADFN)) Q:GMADFN<1 D Q:GMRAOUT + ...S GMRASSN="",GMRARB="" + ...D VAD^GMRAUTL1(GMADFN,"","","","",.GMRASSN,.GMRARB) + ...W !,GMRARB,$S(GMRARB'="":" ",1:""),GMRANAM," (",GMRASSN,")" + ...S GMADT=0 F S GMADT=$O(^TMP($J,"GMRAPU",GMALOC,GMRANAM,GMADFN,GMADT)) Q:GMADT<1 S GMRAPA=0 F S GMRAPA=$O(^TMP($J,"GMRAPU",GMALOC,GMRANAM,GMADFN,GMADT,GMRAPA)) Q:GMRAPA<1 D Q:GMRAOUT + ....S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) + ....Q:GMRAPA(0)="" + ....W !,?3,$$FMTE^XLFDT(GMADT,"1") + ....W ?30,$S($P(GMRAPA(0),U,5)'="":$E($P($G(^VA(200,$P(GMRAPA(0),U,5),0)),U),1,24),1:"") + ....W ?55,$E($P(GMRAPA(0),U,2),1,24) + ....I $Y>(IOSL-4) D HEAD + ....Q + ...Q + ..Q + .Q + D CLOSE^GMRAUTL + Q +HEAD ; Print header information + I $E(IOST,1)="C" D Q:GMRAOUT + .I GMRAPG=1 W @IOF Q + .I GMRAPG'=1 D Q:GMRAOUT + ..N DIR S DIR(0)="E" D ^DIR I 'Y S GMRAOUT=1 + ..K Y + ..Q + .Q + Q:GMRAOUT + I GMRAPG'=1 W @IOF + W "Report Date: ",$P($$FMTE^XLFDT(GMRADATE),"@"),?70,"Page: ",GMRAPG + W !,?19,"List of Unverified Reactions by Ward Location" + W !,?30,"Ward Location: ",GMALOC + W !,?3,"Origination Date/Time",?30,"Originator",?55,"Reaction" + W !,$$REPEAT^XLFSTR("-",78) + S GMRAPG=GMRAPG+1 + I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user + Q +FIND ; This subroutines will build the data for the report. + N GMADFN + S GMADFN=0 + F S GMADFN=$O(^GMR(120.8,"AVER",GMADFN)) Q:GMADFN<1 D + .N GMRALOC,GMRANAM,GMALOC,GMRAPA + .S GMRANAM="",GMRALOC="" + .D VAD^GMRAUTL1(GMADFN,"",.GMRALOC,.GMRANAM,"","","") I GMRALOC="" S GMALOC="OUTPATIENT" + .E S GMALOC=$P($G(^DIC(42,GMRALOC,0)),U) + .Q:GMALOC="" + .S GMRAPA=0 + .F S GMRAPA=$O(^GMR(120.8,"AVER",GMADFN,GMRAPA)) Q:GMRAPA<1 D + ..N GMADT + ..S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) Q:GMRAPA(0)="" + ..S GMADT=$P(GMRAPA(0),U,4) + ..S ^TMP($J,"GMRAPU",GMALOC,GMRANAM,GMADFN,GMADT,GMRAPA)="" + ..Q + .Q + Q diff --git a/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAUTL1.m b/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAUTL1.m index fe73704f..5b1a73eb 100644 --- a/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAUTL1.m +++ b/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAUTL1.m @@ -1,88 +1,74 @@ -GMRAUTL1 ;HIRMFO/WAA-ALLERGY UTILITIES ;12/04/92 - ;;4.0;Adverse Reaction Tracking;**33**;Mar 29, 1996;Build 5 - ; - ; Reference to $$PROD^XUPROD supported by DBIA 4440 - ; Reference to $$TESTPAT^VADPT supported by DBIA 3744 - ; - Q -STPCK() ; This is to check to see if the user wanted to stop the print - S ZTSTOP=0 - I $$S^%ZTLOAD D - .S ZTSTOP=1 K ZTREG W !?10,"*** OUTPUT STOPPED AT USER'S REQUEST ***" - .Q - Q ZTSTOP -BR ; This is a online reference card entry point - I '$$TEST^DDBRT D Q - .W $C(7) - .W !,?20,"Your Terminal cannot display this Reference Card." - .W !,?20,"Please contact IRM Service to correct this problem." - .Q - N X - S X=$O(^GMRD(120.87,"B","REFERENCE CARD",0)) Q:X<1 - D WP^DDBR(120.87,X,1) - Q -PR ; This is a print utility for the reference card for IRM - W ! K GMRAZIS D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q - I $D(IO("Q")) D Q - . S ZTRTN="PR1^GMRAUTL1",(ZTSAVE("GMRAOUT"),ZTSAVE("GMAST"),ZTSAVE("GMAEN"))="" - . S ZTDESC="Print reference card" D ^%ZTLOAD - . W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.") - . Q - U IO D PR1 U IO(0) - Q -PR1 ; Print out the card - N GMRAOUT,GMRACD,GMRALN,X - I $E(IOST,1)="C" W @IOF - S GMRACD=$O(^GMRD(120.87,"B","REFERENCE CARD",0)) - S (GMRAOUT,GMRALN)=0 -LP1 ; Main loop - F S GMRALN=$O(^GMRD(120.87,GMRACD,1,GMRALN)) Q:GMRALN<1 D Q:GMRAOUT - .S X=$G(^GMRD(120.87,GMRACD,1,GMRALN,0)) - .W !,X - .I $Y>(IOSL-4) D - ..I $E(IOST,1)="C" N DIR,DIRUT,DIROUT,DTOUT,DUOUT S DIR(0)="E" D ^DIR S:$D(DIRUT) GMRAOUT=1 W:'GMRAOUT @IOF Q - ..W @IOF - ..Q - .Q - D CLOSE^GMRAUTL - Q -PRDTST(GMRADFN) ; GMRA*4*33 - Remove Test Patients from Live Reports - ; This function will return 0 if the patient should not print on the report, and 1 if the patient - ; should appear on the report. This function will allow all patients to print on the report if the - ; report is run in a test environment. - ; - I GMRADFN="" Q 0 ;DFN not defined. Should never be the case. - I '$$PROD^XUPROD() Q 1 ;Not a production or legacy environment. Print all patients on report. - I $$TESTPAT^VADPT(GMRADFN) Q 0 ;Production or legacy environment. Test patient. Do not print on report. - Q 1 ;Production or legacy environment. Not a test patient. Print on report. - ; -VAD(DFN,DAT,LOC,NAM,SEX,SSN,RB,PRO,PID) ; Call to VADPT - ; This call is a generic call to 1^VADPT - ; Input: - ; 1 DFN = Patient Internal entry number in the Patient File - ; 2 DAT = Date for lookup - ; - ; Output: - ; 3 LOC = Hospital Location - ; 4 NAM = Full Patient name - ; 5 SEX = Patient SEX - ; 6 SSN = Patient SSN - ; 7 RB = Patient Room Bed - ; 8 PRO = Patient Provider - ; 9 PID = Patient ID - ; - S DFN=$G(DFN) Q:DFN="" - S VAINDT=$G(DAT) I VAINDT="" K VAINDT - D 1^VADPT - S LOC=$P(VAIN(4),U),NAM=VADM(1),SEX=VADM(5) - S SSN=$P(VADM(2),U,2),RB=VAIN(5),PID=VA("PID") - S PRO=$P(VAIN(2),U,2) - D KVAR^VADPT K VA,VAROOT - Q -DATE(DATE) ; This Ex-Function will date the date from the DATE - ; and convert it to the old DD("DD") style format - ; it returns the answer in DATE - N Y - S Y=$$FMTE^XLFDT(DATE,1) - S DATE=$P(Y," ")_" "_(+$P($P(Y,",")," ",2))_","_$P(Y," ",3) - Q DATE +GMRAUTL1 ;HIRMFO/WAA-ALLERGY UTILITIES ; 12/04/92 + ;;4.0;Adverse Reaction Tracking;;Mar 29, 1996 + Q +STPCK() ; This is to check to see if the user wanted to stop the print + S ZTSTOP=0 + I $$S^%ZTLOAD D + .S ZTSTOP=1 K ZTREG W !?10,"*** OUTPUT STOPPED AT USER'S REQUEST ***" + .Q + Q ZTSTOP +BR ; This is a online reference card entry point + I '$$TEST^DDBRT D Q + .W $C(7) + .W !,?20,"Your Terminal cannot display this Reference Card." + .W !,?20,"Please contact IRM Service to correct this problem." + .Q + N X + S X=$O(^GMRD(120.87,"B","REFERENCE CARD",0)) Q:X<1 + D WP^DDBR(120.87,X,1) + Q +PR ; This is a print utility for the reference card for IRM + W ! K GMRAZIS D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q + I $D(IO("Q")) D Q + . S ZTRTN="PR1^GMRAUTL1",(ZTSAVE("GMRAOUT"),ZTSAVE("GMAST"),ZTSAVE("GMAEN"))="" + . S ZTDESC="Print reference card" D ^%ZTLOAD + . W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.") + . Q + U IO D PR1 U IO(0) + Q +PR1 ; Print out the card + N GMRAOUT,GMRACD,GMRALN,X + I $E(IOST,1)="C" W @IOF + S GMRACD=$O(^GMRD(120.87,"B","REFERENCE CARD",0)) + S (GMRAOUT,GMRALN)=0 +LP1 ; Main loop + F S GMRALN=$O(^GMRD(120.87,GMRACD,1,GMRALN)) Q:GMRALN<1 D Q:GMRAOUT + .S X=$G(^GMRD(120.87,GMRACD,1,GMRALN,0)) + .W !,X + .I $Y>(IOSL-4) D + ..I $E(IOST,1)="C" N DIR,DIRUT,DIROUT,DTOUT,DUOUT S DIR(0)="E" D ^DIR S:$D(DIRUT) GMRAOUT=1 W:'GMRAOUT @IOF Q + ..W @IOF + ..Q + .Q + D CLOSE^GMRAUTL + Q +VAD(DFN,DAT,LOC,NAM,SEX,SSN,RB,PRO,PID) ; Call to VADPT + ; This call is a generic call to 1^VADPT + ; Input: + ; 1 DFN = Patient Internal entry number in the Patient File + ; 2 DAT = Date for lookup + ; + ; Output: + ; 3 LOC = Hospital Location + ; 4 NAM = Full Patient name + ; 5 SEX = Patient SEX + ; 6 SSN = Patient SSN + ; 7 RB = Patient Room Bed + ; 8 PRO = Patient Provider + ; 9 PID = Patient ID + ; + S DFN=$G(DFN) Q:DFN="" + S VAINDT=$G(DAT) I VAINDT="" K VAINDT + D 1^VADPT + S LOC=$P(VAIN(4),U),NAM=VADM(1),SEX=VADM(5) + S SSN=$P(VADM(2),U,2),RB=VAIN(5),PID=VA("PID") + S PRO=$P(VAIN(2),U,2) + D KVAR^VADPT K VA,VAROOT + Q +DATE(DATE) ; This Ex-Function will date the date from the DATE + ; and convert it to the old DD("DD") style format + ; it returns the answer in DATE + N Y + S Y=$$FMTE^XLFDT(DATE,1) + S DATE=$P(Y," ")_" "_(+$P($P(Y,",")," ",2))_","_$P(Y," ",3) + Q DATE diff --git a/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAVFY.m b/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAVFY.m index f60c7195..96d55a32 100644 --- a/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAVFY.m +++ b/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAVFY.m @@ -1,33 +1,32 @@ -GMRAVFY ;HIRMFO/WAA,PWC-VERIFY AND SIGN OFF AN AGENT ; 5/23/07 10:32am - ;;4.0;Adverse Reaction Tracking;**2,33**;Mar 29, 1996;Build 5 -EN1 ;This is the main entry point for the verifier option. - S GMRAVER=0,GMRADRUG=0 - I $P(GMRAPA(0),U,20)'["D" S GMRAFLAG=0 G VERIFY - S GMRAFLAG=1,GMRADRUG=1 - I $P(GMRAPA(0),U,6)'="o" G VERIFY - I '$D(GMRASITE) D SITE^GMRAUTL S GMRASITE(0)=$G(^GMRD(120.84,GMRASITE,0)) - I $P(^GMRD(120.84,+GMRASITE,0),U,7)'="y" G VERIFY - I $D(^GMR(120.85,"C",GMRAPA)) G VERIFY - W !,"Since this Causative Agent is an observed drug reaction and" - W !,"FDA Data is required you must enter the Observer information" - W !,"prior to verification." - G EXIT -VERIFY ;Verify an agent - W !!,"Currently you have verifier access." - F W !,"Would you like to verify this Causative Agent now" S %=1 D YN^DICN Q:%'=0 W !?4,"ANSWER YES IF YOU WOULD LIKE TO VERIFY THIS DATA, ELSE ANSWER NO." - S:%=-1 GMRAOUT=1 G EXIT:%'=1 S GMRAVFY=1 W @IOF,! D SITE^GMRAUTL,EN2^GMRAPEV0 K GMRAVFY G:GMRAOUT EXIT - I GMRAVER S GMRANAME=$P($G(^DPT(+GMRAPA(0),0)),U),GMRALLER=$P(GMRAPA(0),U,2) K:GMRANAME]""&(GMRALLER]"") ^TMP($J,"GMRADSP",GMRANAME,GMRALLER,GMRAPA) K ^TMP("GMRA",$J) - I 'GMRAVER!GMRAOUT G EXIT - S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) Q:GMRAPA(0)="" - I '$P(GMRAPA(0),U,12) S DA=GMRAPA,DIE="^GMR(120.8,",DR="15////1" D ^DIE D ; Execute the event point for this reaction - .Q:'$D(GMRAPA) S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) Q:GMRAPA(0)="" - .N OROLD,DFN,GMRACNT S DFN=$P(GMRAPA(0),U) - .D INP^VADPT S X=$O(^ORD(101,"B","GMRA SIGN-OFF ON DATA",0))_";ORD(101," D EN^XQOR:X K VAIN,X - .Q - S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)),GMRATYPE=$P(GMRAPA(0),U,20) - S DA=GMRAPA,DIE="^GMR(120.8,",DR="19////1;20///N;21////"_DUZ D ^DIE D:'GMRAVER EN1^GMRAVAB S GMRAPA(0)=$S($D(^GMR(120.8,GMRAPA,0)):^(0),1:"") - I $G(GMRANEW) D ;send NOTIFICATION bulletin if this is new -- GMRA*4*33 - . I $P(GMRAPA(0),U,6)="o",GMRATYPE["D" D PTBUL^GMRAROBS - I GMRAVER D EN1^GMRAPET0($P(GMRAPA(0),U),GMRAPA,"V",.GMRAOUT) I GMRAOUT S GMRAOUT=0 -Q1 D UNLOCK^GMRAUTL(120.8,GMRAPA) -EXIT K GMRAFLAG,DA,DIE,DR,GMRADRUG Q +GMRAVFY ;HIRMFO/WAA-VERIFY AND SIGN OFF AN AGENT ;12/1/95 16:06 + ;;4.0;Adverse Reaction Tracking;**2**;Mar 29, 1996 +EN1 ;This is the main entry point for the verifier option. + S GMRAVER=0,GMRADRUG=0 + I $P(GMRAPA(0),U,20)'["D" S GMRAFLAG=0 G VERIFY + S GMRAFLAG=1,GMRADRUG=1 + I $P(GMRAPA(0),U,6)'="o" G VERIFY + I '$D(GMRASITE) D SITE^GMRAUTL S GMRASITE(0)=$G(^GMRD(120.84,GMRASITE,0)) + I $P(^GMRD(120.84,+GMRASITE,0),U,7)'="y" G VERIFY + I $D(^GMR(120.85,"C",GMRAPA)) G VERIFY + W !,"Since this Causative Agent is an observed drug reaction and" + W !,"FDA Data is required you must enter the Observer information" + W !,"prior to verification." + G EXIT +VERIFY ;Verify an agent + W !!,"Currently you have verifier access." + F W !,"Would you like to verify this Causative Agent now" S %=1 D YN^DICN Q:%'=0 W !?4,"ANSWER YES IF YOU WOULD LIKE TO VERIFY THIS DATA, ELSE ANSWER NO." + S:%=-1 GMRAOUT=1 G EXIT:%'=1 S GMRAVFY=1 W @IOF,! D SITE^GMRAUTL,EN2^GMRAPEV0 K GMRAVFY G:GMRAOUT EXIT + I GMRAVER S GMRANAME=$P($G(^DPT(+GMRAPA(0),0)),U),GMRALLER=$P(GMRAPA(0),U,2) K:GMRANAME]""&(GMRALLER]"") ^TMP($J,"GMRADSP",GMRANAME,GMRALLER,GMRAPA) K ^TMP("GMRA",$J) + I 'GMRAVER!GMRAOUT G EXIT + S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) Q:GMRAPA(0)="" + I '$P(GMRAPA(0),U,12) S DA=GMRAPA,DIE="^GMR(120.8,",DR="15////1" D ^DIE D ; Execute the event point for this reaction + .Q:'$D(GMRAPA) S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) Q:GMRAPA(0)="" + .N OROLD,DFN,GMRACNT S DFN=$P(GMRAPA(0),U) + .D INP^VADPT S X=$O(^ORD(101,"B","GMRA SIGN-OFF ON DATA",0))_";ORD(101," D EN^XQOR:X K VAIN,X + .Q + S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)),GMRATYPE=$P(GMRAPA(0),U,20) + S DA=GMRAPA,DIE="^GMR(120.8,",DR="19////1;20///N;21////"_DUZ D ^DIE D:'GMRAVER EN1^GMRAVAB S GMRAPA(0)=$S($D(^GMR(120.8,GMRAPA,0)):^(0),1:"") + I $P(GMRAPA(0),U,6)="o",GMRATYPE["D" D PTBUL^GMRAROBS + I GMRAVER D EN1^GMRAPET0($P(GMRAPA(0),U),GMRAPA,"V",.GMRAOUT) I GMRAOUT S GMRAOUT=0 +Q1 D UNLOCK^GMRAUTL(120.8,GMRAPA) +EXIT K GMRAFLAG,DA,DIE,DR,GMRADRUG Q diff --git a/r/ASISTS-OOPS/OOPSGUIR.m b/r/ASISTS-OOPS/OOPSGUIR.m index 4570d23d..dae78102 100644 --- a/r/ASISTS-OOPS/OOPSGUIR.m +++ b/r/ASISTS-OOPS/OOPSGUIR.m @@ -1,216 +1,216 @@ -OOPSGUIR ;WIOFO/LLH-RPC routine for misc reports ;03/16/04 - ;;2.0;ASISTS;**8,7,11,14**;Jun 03, 2002;Build 1 - ; -ENT(RESULTS,INPUT,CALL) ; get the data for the report - ; Input: INPUT - contains 3 values, the START AND END DATE, - ; STATION. The Date of Occ (fld #4) is used to - ; in/exclude claims from the report. If Station='ALL' - ; then all claims are included, if not 'All', then - ; only 1 station is included. - ; CALL - contains the report call which will invoke - ; the appropriate M call - ; Output: RESULTS - the results array passes data back to the client. - N CAX,FI,LP,MENU,SDATE,STDT,STA,STATION,ENDDT,EDATE,TAG,X,Y,%DT - S RESULTS(0)="Processing..." - S STDT=$P($G(INPUT),U),ENDDT=$P($G(INPUT),U,2) - S STA=$P($G(INPUT),U,3),TAG=CALL - I (STDT="")!(ENDDT="")!(STA="")!(TAG="") D Q - . S RESULTS(0)="Input parameters missing, cannot run report." Q - K ^TMP($J,TAG) - S (SDATE,EDATE,MENU)="" - S X=STDT D ^%DT S SDATE=Y - S X=ENDDT D ^%DT S EDATE=Y - ; SDATE made last time in day prior so start date correct - I TAG="LOG300U" S TAG="LOG300",MENU="U" - S SDATE=(SDATE-1)+.9999,EDATE=EDATE_".9999" - D @TAG - Q -SERVICE ; Service/Detail Location report - patch 11 -DSPUTE ; Reason for Dispute report. Patch 11 -FLD174 ; Report compiles filing instruction result counts -FLD332 ; Use this tag for Reason for Controvert report. Patch 11 - N ARR,CODE,CN,LP,IEN,I,GOON,P2,TX - S LP="",IEN="",CN=0 - I TAG="FLD174" D - .S CODE=$P($G(^DD(2260,174,0)),U,3) - .F I=1:1 S LP=$P(CODE,";",I) Q:$G(LP)="" I $P(LP,":",2)'="" S ARR(LP)=0 - .S ARR(I_":No Data Entered")=0 - I TAG="FLD332" D - .F I=1:1 Q:'$D(^OOPS(2262.4,I)) S ARR(I_":"_$P(^OOPS(2262.4,I,0),U))=0 - .S ARR(98_":Blk 36 also has text entered")=0 - .S ARR(99_":Controvert question checked Yes, but no Controvert Code entered")=0 - F LP=SDATE:0 S LP=$O(^OOPS(2260,"AD",LP)) Q:(LP'>0)!(LP>EDATE) D - .F S IEN=$O(^OOPS(2260,"AD",LP,IEN)) Q:IEN'>0 D - ..I $$GET1^DIQ(2260,IEN,51,"I")>1 Q ;only allow open/closed cases - ..S CAX=$$GET1^DIQ(2260,IEN,52,"I") - ..I TAG'="SERVICE"&(CAX=2) Q ;only allow CA1's - ..S STATION=$P(^OOPS(2260,IEN,"2162A"),U,9) - ..I ($G(STA)'="A"),(STATION'=STA) Q ;get correct station - ..;patch 11 - sent to OOPSGUIF due to size this routine - ..I TAG="DSPUTE" D DSPUTE^OOPSGUIF - ..I TAG="SERVICE" D SERVICE^OOPSGUIU - ..; Filing instructions report - ..I TAG="FLD174" D - ...S FI=$$GET1^DIQ(2260,IEN,174,"I")_":"_$$GET1^DIQ(2260,IEN,174) - ...I $$GET1^DIQ(2260,IEN,174)="" S FI=I_":No Data Entered" - ...S ARR(FI)=ARR(FI)+1 - ...;patch 11 - Reason for controvert report - ..I TAG="FLD332" D - ...;first Agency Controvert must = "Y" to be counted - ...S GOON=$$GET1^DIQ(2260,IEN,165.1,"I") I $G(GOON)'="Y" D Q - ....S:'$D(ARR("999:Case not controverted, no controvert code expected")) ARR("999:Case not controverted, no controvert code expected")=0 - ....S ARR("999:Case not controverted, no controvert code expected")=ARR("999:Case not controverted, no controvert code expected")+1 - ...S FI=$$GET1^DIQ(2260,IEN,332,"I")_":"_$$GET1^DIQ(2260,IEN,332) - ...I $$GET1^DIQ(2260,IEN,332)="" S FI=99_":Controvert question checked Yes, but no Controvert Code entered" - ...S ARR(FI)=ARR(FI)+1 - ...I $G(^OOPS(2260,IEN,"CA1K",1,0))'="" D - ....;if case is diputed, don't count in Controvert rpt - quit - ....S GOON=$$GET1^DIQ(2260,IEN,165.2,"I") I $G(GOON)="Y" Q - ....S ARR(98_":Blk 36 also has text entered")=ARR(98_":Blk 36 also has text entered")+1 - I TAG'="DSPUTE",(TAG'="SERVICE") D - .S CN=0,FI="",P2="" - .F S FI=$O(ARR(FI)) Q:FI="" D - ..S CN=$P(FI,":"),P2=$P(FI,":",2),CODE=0 - ..I TAG="FLD332" S TX=$O(^OOPS(2262.4,"B",P2,"")) I $G(TX) S CODE=$P(^OOPS(2262.4,TX,0),U,2) - ..S ^TMP($J,TAG,CN)=P2_U_CODE_U_ARR(FI) - ..; rearrange 'bogus' Controvert Codes for report formating - ..I TAG="FLD332",(CN>97) S ^TMP($J,TAG,CN)=U_P2_U_ARR(FI) - I TAG="SERVICE" D CMPLSRV^OOPSGUIU - I TAG="DSPUTE" D DSPUTE^OOPSGUIU - S RESULTS=$NA(^TMP($J,TAG)) - Q -SUM300A ; Summary of Work-related injuries and illness report - N CN,EMP,FAC,HRS,STATE,STR - N COLG,COLH,COLI,COLJ,COLK,COLL,COLM - S (COLG,COLH,COLI,COLJ,COLK,COLL)=0 - S (COLM(1),COLM(2),COLM(3),COLM(4),COLM(5),COLM(6))=0 - S ^TMP($J,TAG,0)="No worksheet data for this station." - S FAC=$$GET1^DIQ(4,STA,.01,"E") - K ARR D STATINFO^OOPSGUI3(.ARR,STA) I $D(ARR) D - .S STATE=$P($G(ARR(0)),U,3) - .I $G(STATE)'="" D - ..S STATE=$O(^DIC(5,"B",STATE,"")) - ..S $P(ARR(0),U,3)=$P(^DIC(5,STATE,0),U,2) - .S ^TMP($J,TAG,0)=FAC_U_ARR(0) - K ARR D SITEPGET^OOPSGUI6(.ARR,"OSHA300") I $D(ARR) D - .S CN=0 F S CN=$O(ARR(CN)) Q:CN="" D - ..I $P(ARR(CN),U,11)'=STA Q - ..S STR=$P($P(ARR(CN),U,1)," = ",2) - ..S STR=$P(ARR(CN),U,3)_U_$P(ARR(CN),U,4)_U_$P(ARR(CN),U,6)_U - ..S STR=STR_$P(ARR(CN),U,7)_U_$P(ARR(CN),U,8) - ..S ^TMP($J,TAG,0)=^TMP($J,TAG,0)_U_STR - K ARR,DATA S DATA="" - D EMPHRS,DETAIL - Q -IRWSHT ; Incidence Rates Worksheet Report - N COLHI,EMP,HRS - S ^TMP($J,TAG,1)="No Worksheet Data for this Station" - S COLHI=0 - K ARR,DATA S DATA="" - D EMPHRS,DETAIL - Q -DETAIL ; now get employee information -LOG300 ; entry point for the OSHA 300 LOG - N CN,CASES,DOI,FLD,IEN,INC,STATION,TYPE - S DOI=SDATE,CASES=0,CN=1 - F S DOI=$O(^OOPS(2260,"AF",DOI)) Q:(DOI>EDATE)!(DOI="") S IEN=0 D - .F S IEN=$O(^OOPS(2260,"AF",DOI,"Y",IEN)) Q:IEN="" D - ..S STATION=$P(^OOPS(2260,IEN,"2162A"),U,9) I $G(STATION)'=STA Q - ..I $P(^OOPS(2260,IEN,0),U,6)>1 Q - ..S CASES=CASES+1 - ..I TAG="IRWSHT" D - ...I $D(^OOPS(2260,IEN,"OUTC","AC","A","J"))!$D(^OOPS(2260,IEN,"OUTC","AC","A","A")) S COLHI=COLHI+1 - ..I TAG="SUM300A" D FLD95 - ..I TAG="LOG300" D FLD95 D - ...S ARR(1)=$$GET1^DIQ(2260,IEN,.01),ARR(2)=$$GET1^DIQ(2260,IEN,1) - ...I $$GET1^DIQ(2260,IEN,337,"I")="Y" S ARR(2)="Privacy Case" - ...S TYPE=$$GET1^DIQ(2260,IEN,3,"I") - ...I TYPE>10&(TYPE<15) S ARR(2)="Privacy Case" - ...I MENU="U" S ARR(2)="" - ...S INC=$$GET1^DIQ(2260,IEN,52,"I"),FLD=$S(INC=1:111,INC=2:208,1:"") - ...S ARR(3)=$$GET1^DIQ(2260,IEN,FLD) - ...S ARR(4)=$P($$FMTE^XLFDT(($$GET1^DIQ(2260,IEN,4,"I")),2),"@") - ...S ARR(5)=$$GET1^DIQ(2260,IEN,27,"E") - ...S ARR(6)=$$GET1^DIQ(2260,IEN,3)_";"_$$GET1^DIQ(2260,IEN,30) - ...S DATA=ARR(1)_U_ARR(2)_U_ARR(3)_U_ARR(4)_U_ARR(5)_U_ARR(6)_U_ARR(7)_U - ...S DATA=DATA_ARR(8)_U_ARR(9)_U_ARR(10) - ...S ^TMP($J,TAG,CN)=DATA,CN=CN+1 - I TAG="IRWSHT" S ^TMP($J,TAG,1)=CASES_U_COLHI_U_HRS - I TAG="SUM300A" D - .S DATA=CASES_U_EMP_U_HRS_U_COLG_U_COLH_U_COLI_U_COLJ_U_COLK_U_COLL_U - .S DATA=DATA_COLM(1)_U_COLM(2)_U_COLM(3)_U_COLM(4)_U_COLM(5)_U_COLM(6) - .S ^TMP($J,TAG,1)=DATA - S RESULTS=$NA(^TMP($J,TAG)) - K ARR,DATA - Q -FLD95 ; use OUTC subrecord to retrieve data - N AVAIL,ED,SD,S0,INC,ILL,DAYA,DAYJ,DAYS,IEN95,OC,OUTC,S95,TDAY - S S0=$G(^OOPS(2260,IEN,0)),INC=$P(S0,U,7) - S ILL=$P($G(^OOPS(2260,IEN,"2162B")),U,15) - S TDAY=$$HTFM^XLFDT(+$H) - ; add days away & job transfer up only to 180 for log, 4 300A get all - S (DAYA,DAYJ,TAWAY)=0,IEN95=0 - F S IEN95=$O(^OOPS(2260,IEN,"OUTC",IEN95)) Q:IEN95'>0 D - .S S95=$G(^OOPS(2260,IEN,"OUTC",IEN95,0)) - .S SD=$P(S95,U,1),ED=$P(S95,U,2),OC=$P(S95,U,3),DAYS=0 - .I $P(S95,U,11)="D" Q ; entry is deleted - .;patch 11 - added logic that if TAG=LOG300 include all incident days - .; up to 180, else 300A, only include date range incidents - .I (TAG="SUM300A"),(EDATEEDATE) S DAYS=$$FMDIFF^XLFDT(EDATE,SD,1)+1 - .I TAG="LOG300",($G(ED)="") S DAYS=$$FMDIFF^XLFDT(TDAY,SD,1)+1 - .I '$G(DAYS) S DAYS=$S(OC="A":$P(S95,U,4),OC="J":$P(S95,U,5),1:0) - .I DAYA+DAYJ>179 Q - .S AVAIL=0 - .I DAYS>179 S AVAIL=(180-(DAYA+DAYJ)) - .I (DAYS<180) D - ..I (DAYS+DAYA+DAYJ)<180 S AVAIL=DAYS - ..I (DAYS+DAYA+DAYJ)>180 S AVAIL=(180-(DAYA+DAYJ)) - .I $G(OC)="A" S DAYA=DAYA+AVAIL - .I $G(OC)="J" S DAYJ=DAYJ+AVAIL - I TAG="SUM300A" D - .S:$G(INC)=1 COLM(1)=COLM(1)+1 - .I INC=2 D - ..I $G(ILL) S COLM(ILL)=COLM(ILL)+1 - ..I '$G(ILL) S COLM(6)=COLM(6)+1 - .S COLK=COLK+DAYA,COLL=COLL+DAYJ - .I $D(OUTC("D")) S COLG=COLG+1 Q - .I $D(OUTC("A")) S COLH=COLH+1 Q - .I $D(OUTC("J")) S COLI=COLI+1 Q - .I $D(OUTC("O")) S COLJ=COLJ+1 Q - I TAG="LOG300" D - .S ARR(7)="",ARR(10)="",(ARR(8),ARR(9))=0 - .I INC=1 S ARR(10)=1 - .I INC=2 S:$G(ILL) ARR(10)=ILL S:'$G(ILL) ARR(10)=6 - .S ARR(8)=DAYA,ARR(9)=DAYJ - .I $D(OUTC("D")) S ARR(7)="D" S (ARR(8),ARR(9))=0 Q - .I $D(OUTC("A")) S ARR(7)="A" Q - .I $D(OUTC("J")) S ARR(7)="J" Q - .I $D(OUTC("O")) S ARR(7)="O" Q - Q -EMPHRS ; get Total Num Employees and Hours worked - N CASES,ED,LV1,LV2,MON,OK,PAR,SD,SIEN,STR,WS,X,X1,X2 - S (EMP,HRS,WS)=0 - S PAR="^OOPS(2262,0)",PAR=$Q(@PAR),PAR=$Q(@PAR) - S LV1=$P(PAR,",",2),LV2=$P(PAR,",",3) - S SIEN=$O(^OOPS(2262,LV1,LV2,"B",STA,-1)) Q:SIEN="" - ; get month range to make sure all emp numbers and hours are entered - S SDATE=SDATE\1 - S SD=$E(SDATE,1,5)_"00"_$E(SDATE,8,$L(SDATE)) - S ED=$E(EDATE,1,5)_"00"_$E(EDATE,8,$L(EDATE)) - S X1=$E(ED,1,3),X2=$E(SD,1,3) - I X1>X2 D - .S OK=0,X=(X1-X2) S:X>1 OK=(X-1)*12 - .S OK=OK+((12-$E(SD,4,5))+1)+$E(ED,4,5) - I X1=X2 S OK=($E(ED,4,5)-$E(SD,4,5))+1 - S MON=OK - F S WS=$O(^OOPS(2262,LV1,LV2,SIEN,2,WS)) Q:(WS'>0) D - .S STR=^OOPS(2262,LV1,LV2,SIEN,2,WS,0) - .I ($P(STR,U)'ED) D - ..I ($P(STR,U,2)="")!($P(STR,U,3)="") Q - ..S EMP=EMP+$P(STR,U,2),HRS=HRS+$P(STR,U,3),OK=OK-1 - I '$G(OK) S EMP=EMP/MON - I $G(OK) S (EMP,HRS)="INCOMPLETE DATA" - Q +OOPSGUIR ;WIOFO/LLH-RPC routine for misc reports ;03/16/04 + ;;2.0;ASISTS;**8,7,11**;Jun 03, 2002 + ; +ENT(RESULTS,INPUT,CALL) ; get the data for the report + ; Input: INPUT - contains 3 values, the START AND END DATE, + ; STATION. The Date of Occ (fld #4) is used to + ; in/exclude claims from the report. If Station='ALL' + ; then all claims are included, if not 'All', then + ; only 1 station is included. + ; CALL - contains the report call which will invoke + ; the appropriate M call + ; Output: RESULTS - the results array passes data back to the client. + N CAX,FI,LP,MENU,SDATE,STDT,STA,STATION,ENDDT,EDATE,TAG,X,Y,%DT + S RESULTS(0)="Processing..." + S STDT=$P($G(INPUT),U),ENDDT=$P($G(INPUT),U,2) + S STA=$P($G(INPUT),U,3),TAG=CALL + I (STDT="")!(ENDDT="")!(STA="")!(TAG="") D Q + . S RESULTS(0)="Input parameters missing, cannot run report." Q + K ^TMP($J,TAG) + S (SDATE,EDATE,MENU)="" + S X=STDT D ^%DT S SDATE=Y + S X=ENDDT D ^%DT S EDATE=Y + ; SDATE made last time in day prior so start date correct + I TAG="LOG300U" S TAG="LOG300",MENU="U" + S SDATE=(SDATE-1)+.9999,EDATE=EDATE_".9999" + D @TAG + Q +SERVICE ; Service/Detail Location report - patch 11 +DSPUTE ; Reason for Dispute report. Patch 11 +FLD174 ; Report compiles filing instruction result counts +FLD332 ; Use this tag for Reason for Controvert report. Patch 11 + N ARR,CODE,CN,LP,IEN,I,GOON,P2,TX + S LP="",IEN="",CN=0 + I TAG="FLD174" D + .S CODE=$P($G(^DD(2260,174,0)),U,3) + .F I=1:1 S LP=$P(CODE,";",I) Q:$G(LP)="" I $P(LP,":",2)'="" S ARR(LP)=0 + .S ARR(I_":No Data Entered")=0 + I TAG="FLD332" D + .F I=1:1 Q:'$D(^OOPS(2262.4,I)) S ARR(I_":"_$P(^OOPS(2262.4,I,0),U))=0 + .S ARR(98_":Blk 36 also has text entered")=0 + .S ARR(99_":Controvert question checked Yes, but no Controvert Code entered")=0 + F LP=SDATE:0 S LP=$O(^OOPS(2260,"AD",LP)) Q:(LP'>0)!(LP>EDATE) D + .F S IEN=$O(^OOPS(2260,"AD",LP,IEN)) Q:IEN'>0 D + ..I $$GET1^DIQ(2260,IEN,51,"I")>1 Q ;only allow open/closed cases + ..S CAX=$$GET1^DIQ(2260,IEN,52,"I") + ..I TAG'="SERVICE"&(CAX=2) Q ;only allow CA1's + ..S STATION=$P(^OOPS(2260,IEN,"2162A"),U,9) + ..I ($G(STA)'="A"),(STATION'=STA) Q ;get correct station + ..;patch 11 - sent to OOPSGUIF due to size this routine + ..I TAG="DSPUTE" D DSPUTE^OOPSGUIF + ..I TAG="SERVICE" D SERVICE^OOPSGUIU + ..; Filing instructions report + ..I TAG="FLD174" D + ...S FI=$$GET1^DIQ(2260,IEN,174,"I")_":"_$$GET1^DIQ(2260,IEN,174) + ...I $$GET1^DIQ(2260,IEN,174)="" S FI=I_":No Data Entered" + ...S ARR(FI)=ARR(FI)+1 + ...;patch 11 - Reason for controvert report + ..I TAG="FLD332" D + ...;first Agency Controvert must = "Y" to be counted + ...S GOON=$$GET1^DIQ(2260,IEN,165.1,"I") I $G(GOON)'="Y" D Q + ....S:'$D(ARR("999:Case not controverted, no controvert code expected")) ARR("999:Case not controverted, no controvert code expected")=0 + ....S ARR("999:Case not controverted, no controvert code expected")=ARR("999:Case not controverted, no controvert code expected")+1 + ...S FI=$$GET1^DIQ(2260,IEN,332,"I")_":"_$$GET1^DIQ(2260,IEN,332) + ...I $$GET1^DIQ(2260,IEN,332)="" S FI=99_":Controvert question checked Yes, but no Controvert Code entered" + ...S ARR(FI)=ARR(FI)+1 + ...I $G(^OOPS(2260,IEN,"CA1K",1,0))'="" D + ....;if case is diputed, don't count in Controvert rpt - quit + ....S GOON=$$GET1^DIQ(2260,IEN,165.2,"I") I $G(GOON)="Y" Q + ....S ARR(98_":Blk 36 also has text entered")=ARR(98_":Blk 36 also has text entered")+1 + I TAG'="DSPUTE",(TAG'="SERVICE") D + .S CN=0,FI="",P2="" + .F S FI=$O(ARR(FI)) Q:FI="" D + ..S CN=$P(FI,":"),P2=$P(FI,":",2),CODE=0 + ..I TAG="FLD332" S TX=$O(^OOPS(2262.4,"B",P2,"")) I $G(TX) S CODE=$P(^OOPS(2262.4,TX,0),U,2) + ..S ^TMP($J,TAG,CN)=P2_U_CODE_U_ARR(FI) + ..; rearrange 'bogus' Controvert Codes for report formating + ..I TAG="FLD332",(CN>97) S ^TMP($J,TAG,CN)=U_P2_U_ARR(FI) + I TAG="SERVICE" D CMPLSRV^OOPSGUIU + I TAG="DSPUTE" D DSPUTE^OOPSGUIU + S RESULTS=$NA(^TMP($J,TAG)) + Q +SUM300A ; Summary of Work-related injuries and illness report + N CN,EMP,FAC,HRS,STATE,STR + N COLG,COLH,COLI,COLJ,COLK,COLL,COLM + S (COLG,COLH,COLI,COLJ,COLK,COLL)=0 + S (COLM(1),COLM(2),COLM(3),COLM(4),COLM(5),COLM(6))=0 + S ^TMP($J,TAG,0)="No worksheet data for this station." + S FAC=$$GET1^DIQ(4,STA,.01,"E") + K ARR D STATINFO^OOPSGUI3(.ARR,STA) I $D(ARR) D + .S STATE=$P($G(ARR(0)),U,3) + .I $G(STATE)'="" D + ..S STATE=$O(^DIC(5,"B",STATE,"")) + ..S $P(ARR(0),U,3)=$P(^DIC(5,STATE,0),U,2) + .S ^TMP($J,TAG,0)=FAC_U_ARR(0) + K ARR D SITEPGET^OOPSGUI6(.ARR,"OSHA300") I $D(ARR) D + .S CN=0 F S CN=$O(ARR(CN)) Q:CN="" D + ..I $P(ARR(CN),U,11)'=STA Q + ..S STR=$P($P(ARR(CN),U,1)," = ",2) + ..S STR=$P(ARR(CN),U,3)_U_$P(ARR(CN),U,4)_U_$P(ARR(CN),U,6)_U + ..S STR=STR_$P(ARR(CN),U,7)_U_$P(ARR(CN),U,8) + ..S ^TMP($J,TAG,0)=^TMP($J,TAG,0)_U_STR + K ARR,DATA S DATA="" + D EMPHRS,DETAIL + Q +IRWSHT ; Incidence Rates Worksheet Report + N COLHI,EMP,HRS + S ^TMP($J,TAG,1)="No Worksheet Data for this Station" + S COLHI=0 + K ARR,DATA S DATA="" + D EMPHRS,DETAIL + Q +DETAIL ; now get employee information +LOG300 ; entry point for the OSHA 300 LOG + N CN,CASES,DOI,FLD,IEN,INC,STATION,TYPE + S DOI=SDATE,CASES=0,CN=1 + F S DOI=$O(^OOPS(2260,"AF",DOI)) Q:(DOI>EDATE)!(DOI="") S IEN=0 D + .F S IEN=$O(^OOPS(2260,"AF",DOI,"Y",IEN)) Q:IEN="" D + ..S STATION=$P(^OOPS(2260,IEN,"2162A"),U,9) I $G(STATION)'=STA Q + ..I $P(^OOPS(2260,IEN,0),U,6)>1 Q + ..S CASES=CASES+1 + ..I TAG="IRWSHT" D + ...I $D(^OOPS(2260,IEN,"OUTC","AC","A","J"))!$D(^OOPS(2260,IEN,"OUTC","AC","A","A")) S COLHI=COLHI+1 + ..I TAG="SUM300A" D FLD95 + ..I TAG="LOG300" D FLD95 D + ...S ARR(1)=$$GET1^DIQ(2260,IEN,.01),ARR(2)=$$GET1^DIQ(2260,IEN,1) + ...I $$GET1^DIQ(2260,IEN,337,"I")="Y" S ARR(2)="Privacy Case" + ...S TYPE=$$GET1^DIQ(2260,IEN,3,"I") + ...I TYPE>10&(TYPE<15) S ARR(2)="Privacy Case" + ...I MENU="U" S ARR(2)="" + ...S INC=$$GET1^DIQ(2260,IEN,52,"I"),FLD=$S(INC=1:111,INC=2:208,1:"") + ...S ARR(3)=$$GET1^DIQ(2260,IEN,FLD) + ...S ARR(4)=$P($$FMTE^XLFDT(($$GET1^DIQ(2260,IEN,4,"I")),2),"@") + ...S ARR(5)=$$GET1^DIQ(2260,IEN,27,"E") + ...S ARR(6)=$$GET1^DIQ(2260,IEN,3)_";"_$$GET1^DIQ(2260,IEN,30) + ...S DATA=ARR(1)_U_ARR(2)_U_ARR(3)_U_ARR(4)_U_ARR(5)_U_ARR(6)_U_ARR(7)_U + ...S DATA=DATA_ARR(8)_U_ARR(9)_U_ARR(10) + ...S ^TMP($J,TAG,CN)=DATA,CN=CN+1 + I TAG="IRWSHT" S ^TMP($J,TAG,1)=CASES_U_COLHI_U_HRS + I TAG="SUM300A" D + .S DATA=CASES_U_EMP_U_HRS_U_COLG_U_COLH_U_COLI_U_COLJ_U_COLK_U_COLL_U + .S DATA=DATA_COLM(1)_U_COLM(2)_U_COLM(3)_U_COLM(4)_U_COLM(5)_U_COLM(6) + .S ^TMP($J,TAG,1)=DATA + S RESULTS=$NA(^TMP($J,TAG)) + K ARR,DATA + Q +FLD95 ; use OUTC subrecord to retrieve data + N AVAIL,ED,SD,S0,INC,ILL,DAYA,DAYJ,DAYS,IEN95,OC,OUTC,S95,TDAY + S S0=$G(^OOPS(2260,IEN,0)),INC=$P(S0,U,7) + S ILL=$P($G(^OOPS(2260,IEN,"2162B")),U,15) + S TDAY=$$HTFM^XLFDT(+$H) + ; add days away & job transfer up only to 180 for log, 4 300A get all + S (DAYA,DAYJ,TAWAY)=0,IEN95=0 + F S IEN95=$O(^OOPS(2260,IEN,"OUTC",IEN95)) Q:IEN95'>0 D + .S S95=$G(^OOPS(2260,IEN,"OUTC",IEN95,0)) + .S SD=$P(S95,U,1),ED=$P(S95,U,2),OC=$P(S95,U,3),DAYS=0 + .I $P(S95,U,11)="D" Q ; entry is deleted + .;patch 11 - added logic that if TAG=LOG300 include all incident days + .; up to 180, else 300A, only include date range incidents + .I (TAG="SUM300A"),(EDATEEDATE) S DAYS=$$FMDIFF^XLFDT(EDATE,SD,1)+1 + .I TAG="LOG300",($G(ED)="") S DAYS=$$FMDIFF^XLFDT(TDAY,SD,1)+1 + .I '$G(DAYS) S DAYS=$S(OC="A":$P(S95,U,4),OC="J":$P(S95,U,5),1:0) + .I DAYA+DAYJ>180 Q + .S AVAIL=0 + .I DAYS>180 S AVAIL=180 + .I (DAYS<180) D + ..I (DAYS+DAYA+DAYJ)<180 S AVAIL=DAYS + ..I (DAYS+DAYA+DAYJ)>180 S AVAIL=(180-(DAYA+DAYJ)) + .I $G(OC)="A" S DAYA=DAYA+AVAIL + .I $G(OC)="J" S DAYJ=DAYJ+AVAIL + I TAG="SUM300A" D + .S:$G(INC)=1 COLM(1)=COLM(1)+1 + .I INC=2 D + ..I $G(ILL) S COLM(ILL)=COLM(ILL)+1 + ..I '$G(ILL) S COLM(6)=COLM(6)+1 + .S COLK=COLK+DAYA,COLL=COLL+DAYJ + .I $D(OUTC("D")) S COLG=COLG+1 Q + .I $D(OUTC("A")) S COLH=COLH+1 Q + .I $D(OUTC("J")) S COLI=COLI+1 Q + .I $D(OUTC("O")) S COLJ=COLJ+1 Q + I TAG="LOG300" D + .S ARR(7)="",ARR(10)="",(ARR(8),ARR(9))=0 + .I INC=1 S ARR(10)=1 + .I INC=2 S:$G(ILL) ARR(10)=ILL S:'$G(ILL) ARR(10)=6 + .S ARR(8)=DAYA,ARR(9)=DAYJ + .I $D(OUTC("D")) S ARR(7)="D" S (ARR(8),ARR(9))=0 Q + .I $D(OUTC("A")) S ARR(7)="A" Q + .I $D(OUTC("J")) S ARR(7)="J" Q + .I $D(OUTC("O")) S ARR(7)="O" Q + Q +EMPHRS ; get Total Num Employees and Hours worked + N CASES,ED,LV1,LV2,MON,OK,PAR,SD,SIEN,STR,WS,X,X1,X2 + S (EMP,HRS,WS)=0 + S PAR="^OOPS(2262,0)",PAR=$Q(@PAR),PAR=$Q(@PAR) + S LV1=$P(PAR,",",2),LV2=$P(PAR,",",3) + S SIEN=$O(^OOPS(2262,LV1,LV2,"B",STA,-1)) Q:SIEN="" + ; get month range to make sure all emp numbers and hours are entered + S SDATE=SDATE\1 + S SD=$E(SDATE,1,5)_"00"_$E(SDATE,8,$L(SDATE)) + S ED=$E(EDATE,1,5)_"00"_$E(EDATE,8,$L(EDATE)) + S X1=$E(ED,1,3),X2=$E(SD,1,3) + I X1>X2 D + .S OK=0,X=(X1-X2) S:X>1 OK=(X-1)*12 + .S OK=OK+(($E(ED,4,5)-$E(SD,4,5))+1)+$E(SD,4,5) + I X1=X2 S OK=($E(ED,4,5)-$E(SD,4,5))+1 + S MON=OK + F S WS=$O(^OOPS(2262,LV1,LV2,SIEN,2,WS)) Q:(WS'>0) D + .S STR=^OOPS(2262,LV1,LV2,SIEN,2,WS,0) + .I ($P(STR,U)'ED) D + ..I ($P(STR,U,2)="")!($P(STR,U,3)="") Q + ..S EMP=EMP+$P(STR,U,2),HRS=HRS+$P(STR,U,3),OK=OK-1 + I '$G(OK) S EMP=EMP/MON + I $G(OK) S (EMP,HRS)="INCOMPLETE DATA" + Q diff --git a/r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7ADL.m b/r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7ADL.m index 4fef33a9..13059747 100644 --- a/r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7ADL.m +++ b/r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7ADL.m @@ -1,249 +1,232 @@ -LA7ADL ;DALOI/JMC - Automatic Download of Test Orders;May 30, 2008 - ;;5.2;AUTOMATED LAB INSTRUMENTS;**17,25,23,57,66**;Sep 27, 1994;Build 30 - ; - ; This routine will monitor the ^LA("ADL") node to check for accessions which are to have test orders automatically - ; downloaded to another computer system. All entries in the auto instrument file which are flagged for automatic downloading - ; will be checked to see if they contain any tests on the accession. If tests are found then the appropiate download message - ; is constructed and sent. - ; - ; -EN(LA7UID) ; Set flag to check accession for downloading, start background job if needed. - ; Called by LR7OMERG, LRCONJAM, LRTSTSET, LRWLST1. - ; - ; No UID passed to routine. - I $G(LA7UID)="" Q - ; - ; No instrument flagged for auto downloading. - I '$D(^LAB(62.4,"AE")) Q - ; - ; Quit if "Don't Start/Collect" flag set. - I +$G(^LA("ADL","STOP"),0)=3 Q - ; - ; Lock node in case already downloading this accession, wait until downloading finished. - L +^LA("ADL","Q",LA7UID):60 - ; - ; Set flag to check this accession for auto downloading. - S ^LA("ADL","Q",LA7UID)="" - ; - ; Release lock. - L -^LA("ADL","Q",LA7UID) - ; - ; Quit if "Don't Start" flag set. - I +$G(^LA("ADL","STOP"),0)=2 Q - ; - ; Task background job to run. - D CHKTSK - ; - ; Unlock node. - L -^LA("ADL",0) - ; - Q - ; - ; -DQ ; Entry point from Taskman. - ; - ; Wait for a little while in case another job checking for background job has lock. - L +^LA("ADL",0):10 - ; Another process has lock, only want one at a time. - I '$T S:$D(ZTQUEUED) ZTREQ="@" Q - ; - ; No instrument flagged for auto downloading. - I '$D(^LAB(62.4,"AE")) D EXIT Q - ; - ; Quit if "Don't Start/Collect" flags set. - I +$G(^LA("ADL","STOP"),0)>1 Q - ; - ; Update XTMP entry to let auto download know we're running for this process - ; and build table of tests to check for downloading} - D XTMP,BUILD - ; - F D UID Q:TOUT>60 - D EXIT - Q - ; - ; -UID ; Start loop to monitor for accessions to download. - ; - S LA7UID="",(TOUT,ZTSTOP)=0 - ; - ; Flag set to "Rebuild". - I +$G(^LA("ADL","STOP"))=1,'ZTSTOP D BUILD - ; - F S LA7UID=$O(^LA("ADL","Q",LA7UID)) Q:LA7UID=""!(ZTSTOP)!(TOUT) D - . I +$G(^LA("ADL","STOP"))>0 S TOUT=61 Q - . I $$S^%ZTLOAD("Processing Lab UID "_LA7UID) S ZTSTOP=1,TOUT=61 Q - . ; Lock this UID, synch setting/deleting when another job is attempting to set node. - . D LOCK^DILF("^LA(""ADL"",""Q"",LA7UID)") - . ; Unable to get lock, go on to next UID, check again on next go around. - . I '$T Q - . ; Get accession info from ^LRO(68,"C"). - . S X=$Q(^LRO(68,"C",LA7UID)) - . ; Quit - UID does not match. - . I $QS(X,3)'=LA7UID D CLEANUP Q - . ; Setup accession variables for auto downloading. - . S LRAA=+$QS(X,4),LRAD=+$QS(X,5),LRAN=+$QS(X,6) - . D BLDTST - . S LA7INST=0 - . F S LA7INST=$O(LA7AUTO(LA7INST)) Q:'LA7INST D - . . D CHKTEST - . . ; No tests on instrument list for this accession. - . . I '$D(LA7ACC) Q - . . S LRINST=LA7INST,LRAUTO=LA7AUTO(LA7INST) - . . N LA7UID - . . ; File build (entry^routine) from fields #93 and #94 in file #62.4. - . . D @$P(LA7AUTO(LA7INST,9),"^",3,4) - . D CLEANUP,XTMP - ; - F D Q:$O(^LA("ADL","Q",""))'="" Q:TOUT>60 - . I $G(^LA("ADL","STOP"))>1 S TOUT=61 Q - . ; Task has been requested to stop. - . I $$S^%ZTLOAD("Idle - waiting for new accessions to process") S TOUT=61,ZTSTOP=1 Q - . S TOUT=TOUT+1 H 5 D XTMP - ; - Q - ; - ; -BLDTST ; Build array of tests on accession to check for downloading - ; - N X,LA760,LA7PCNT - ; - K LA7TREE - S LA760=0 - F S LA760=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LA760)) Q:'LA760 D - . ; Quit if test has been removed from accession. - . S X=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LA760,0),0) Q:'X - . ; If test completed (#4, COMPLETE DATE entered), don't download. - . I $P(X,"^",5) Q - . ; Build array of atomic tests on accession with urgency. - . S LA7PCNT=0 - . D UNWIND^LA7ADL1(LA760,$P(X,"^",2),0) - ; - Q - ; - ; -CHKTEST ; Check tests to determine if they should build in message. - ; Array LA7ACC returned with tests to send in message - ; - N LA760,LA761,LA76205,LA768,LA7I,LRDPF,X - ; - K LA7ACC - ; - ; Quit - specimen uncollected & don't download uncollected flag set. - ; controls exempted. - S LRDPF=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",2) - S X=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)) - I LRDPF'=62.3,'$P(X,"^",3),'$P(^TMP("LA7-INST",$J,LA7INST),"^") Q - ; - S X=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,5,0)) - S LA761=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,5,X,0),"^") - S LA760=0 - F S LA760=$O(LA7TREE(LA760)) Q:'LA760 D - . I '$D(^TMP("LA7-INST",$J,LA7INST,LA760)) Q - . S LA7I=0 - . F S LA7I=$O(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I)) Q:'LA7I D - . . S LA76205=+$P(LA7TREE(LA760),"^") - . . D CHKMASK - ; - Q - ; -CHKMASK ; Check pattern mask for tests that match download pattern mask - ; - ; Any accession area, specimen, urgency - I $D(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I,0,0,0)) D ADD Q - ; - ; Specific accession area, any specimen/urgency - I $D(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I,LRAA,0,0)) D ADD Q - ; - ; Specific specimen, any accession area/urgency - I $D(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I,0,LA761,0)) D ADD Q - ; - ; Specific urgency, any accession area/specimen - I $D(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I,0,0,LA76205)) D ADD Q - ; - ; Specific accession/specimen, any urgency - I $D(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I,LRAA,LA761,0)) D ADD Q - ; - ; Specific specimen/urgency, any accession area - I $D(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I,0,LA761,LA76205)) D ADD Q - ; - ; Specific accession/specimen/urgency - I $D(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I,LRAA,LA761,LA76205)) D ADD Q - ; - Q - ; -ADD ; Add to list of tests to download - ; - S LA7ACC(LA7I)=LA760_"^"_LA7TREE(LA760) - Q - ; - ; -CLEANUP ; Delete flag after accession has been checked. - ; NOTE: Lock previously set above. - ; - K ^LA("ADL","Q",LA7UID) - ; - ; Release lock on this UID. - L -^LA("ADL","Q",LA7UID) - ; - Q - ; - ; -CHKTSK ; Check if we shoud task the auto download processing routine. - ; Check if we recently tasked the processing routine for this process by compaing values in the XTMP global. - ; Done to avoid repetitive locking attempts on each new accessione since the FileMan locking API uses a site-defined timeout which is usually 3 seconds - ; but can be more. Slows down the interface if on each accession we are waiting 3 or more seconds for the lock to find out if the processing routine - ; is already running. - ; - N LA7X,LA7Y - S LA7X=$H,LA7Y=$G(^XTMP("LA7ADL",1)) - I $P(LA7X,",")=$P(LA7Y,","),($P(LA7X,",",2)-$P(LA7Y,",",2))<240 Q - ; - ; Lock zeroth node. - ; Quit if another process has lock - either another job setting node or the background job. - D LOCK^DILF("^LA(""ADL"",0)") - I '$T Q - ; -ZTSK ; Task background job to run. - ; - ; Call here to queue this processing routine to run in the background. - ; - ; Task background job if not running. - N ZTDESC,ZTSAVE,ZTDTH,ZTIO,ZTRTN - S ZTRTN="DQ^LA7ADL",ZTDESC="Lab Auto Download",ZTIO="",ZTDTH=$H - D ^%ZTLOAD - ; - Q - ; - ; -BUILD ; Build TMP global with list of tests for instruments flagged for auto download. - ; - D BUILD^LA7ADL1 - ; - ; Set flag to "Running". - D SETSTOP^LA7ADL1(0,$G(DUZ)) - ; - Q - ; - ; -XTMP ; Set/update XTMP with current run time of this processing routine - ; - S DT=$$DT^XLFDT - S ^XTMP("LA7ADL",0)=DT_"^"_DT_"^LAB AUTO DOWNLOAD PROCESS TASKING" - S ^XTMP("LA7ADL",1)=$H - Q - ; - ; -EXIT ; Exit and cleanup. - ; - ; Release lock on LA("ADL") global. - L -^LA("ADL",0) - ; - K ^TMP("LA7",$J),^TMP($J),^XTMP("LA7ADL",1) - K LA7ADL,LA7AUTO,LA7NVAF,LRAA,LRAD,LRAN,TOUT - ; - ; Clear flag if normal shutdown, no new accessions. - I +$G(^LA("ADL","STOP"))<2 K ^LA("ADL","STOP") - ; - ; Set flag for taskman to cleanup task. - I $D(ZTQUEUED) S ZTREQ="@" - Q +LA7ADL ;DALOI/JMC - Automatic Download of Test Orders; 1/30/95 09:00 + ;;5.2;AUTOMATED LAB INSTRUMENTS;**17,25,23,57**;Sep 27, 1994 + ; + ; This routine will monitor the ^LA("ADL") node to check for accessions which are to have test orders automatically + ; downloaded to another computer system. All entries in the auto instrument file which are flagged for automatic downloading + ; will be checked to see if they contain any tests on the accession. If tests are found then the appropiate download message + ; is constructed and sent. + ; + ; +EN(LA7UID) ; Set flag to check accession for downloading, start background job if needed. + ; Called by LR7OMERG, LRCONJAM, LRTSTSET, LRWLST1. + ; + ; No UID passed to routine. + I $G(LA7UID)="" Q + ; + ; No instrument flagged for auto downloading. + I '$D(^LAB(62.4,"AE")) Q + ; + ; Quit if "Don't Start/Collect" flag set. + I +$G(^LA("ADL","STOP"),0)=3 Q + ; + ; Lock node in case already downloading this accession, wait until downloading finished. + L +^LA("ADL","Q",LA7UID):60 + ; + ; Set flag to check this accession for auto downloading. + S ^LA("ADL","Q",LA7UID)="" + ; + ; Release lock. + L -^LA("ADL","Q",LA7UID) + ; + ; Quit if "Don't Start" flag set. + I +$G(^LA("ADL","STOP"),0)=2 Q + ; + ; Lock zeroth node. + ; Quit if another process has lock + ; - either another job setting node or the background job. + L +^LA("ADL",0):1 + I '$T Q + ; + ; Task background job to run. + N ZTSK + D ZTSK + ; + ; Unlock node. + L -^LA("ADL",0) + ; + Q + ; + ; +DQ ; Entry point from Taskman. + ; + ; Set flag for taskman to cleanup task. + I $D(ZTQUEUED) S ZTREQ="@" + ; + ; Wait for a little while in case another job checking for background job has lock. + L +^LA("ADL",0):10 + ; Another process has lock, only want one at a time. + I '$T Q + ; + ; No instrument flagged for auto downloading. + I '$D(^LAB(62.4,"AE")) D EXIT Q + ; + ; Quit if "Don't Start/Collect" flags set. + I +$G(^LA("ADL","STOP"),0)>1 Q + ; + D BUILD + ; + F D UID Q:TOUT>60 + D EXIT + Q + ; + ; +UID ; Start loop to monitor for accessions to download. + ; + S LA7UID="",(TOUT,ZTSTOP)=0 + ; + ; Flag set to "Rebuild". + I +$G(^LA("ADL","STOP"))=1,'ZTSTOP D BUILD + ; + F S LA7UID=$O(^LA("ADL","Q",LA7UID)) Q:LA7UID=""!(ZTSTOP)!(TOUT) D + . I +$G(^LA("ADL","STOP"))>0 S TOUT=61 Q + . I $$S^%ZTLOAD S ZTSTOP=1,TOUT=61 Q + . ; Lock this UID, synch setting/deleting when another job is attempting to set node. + . L +^LA("ADL","Q",LA7UID):1 + . ; Unable to get lock, go on to next UID, check again on next go around. + . I '$T Q + . ; Get accession info from ^LRO(68,"C"). + . S X=$Q(^LRO(68,"C",LA7UID)) + . ; Quit - UID does not match. + . I $QS(X,3)'=LA7UID D CLEANUP Q + . ; Setup accession variables for auto downloading. + . S LRAA=+$QS(X,4),LRAD=+$QS(X,5),LRAN=+$QS(X,6) + . D BLDTST + . S LA7INST=0 + . F S LA7INST=$O(LA7AUTO(LA7INST)) Q:'LA7INST D + . . D CHKTEST + . . ; No tests on instrument list for this accession. + . . I '$D(LA7ACC) Q + . . S LRINST=LA7INST,LRAUTO=LA7AUTO(LA7INST) + . . N LA7UID + . . ; File build (entry^routine) from fields #93 and #94 in file #62.4. + . . D @$P(LA7AUTO(LA7INST,9),"^",3,4) + . D CLEANUP + ; + F D Q:$O(^LA("ADL","Q",""))'="" Q:TOUT>60 + . I $G(^LA("ADL","STOP"))>1 S TOUT=61 Q + . ; Task has been requested to stop. + . I $$S^%ZTLOAD S TOUT=61,ZTSTOP=1 Q + . S TOUT=TOUT+1 H 5 + ; + Q + ; + ; +BLDTST ; Build array of tests on accession to check for downloading + ; + N X,LA760,LA7PCNT + ; + K LA7TREE + S LA760=0 + F S LA760=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LA760)) Q:'LA760 D + . ; Quit if test has been removed from accession. + . S X=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LA760,0),0) Q:'X + . ; If test completed (#4, COMPLETE DATE entered), don't download. + . I $P(X,"^",5) Q + . ; Build array of atomic tests on accession with urgency. + . S LA7PCNT=0 + . D UNWIND^LA7ADL1(LA760,$P(X,"^",2),0) + ; + Q + ; + ; +CHKTEST ; Check tests to determine if they should build in message. + ; Array LA7ACC returned with tests to send in message + ; + N LA760,LA761,LA76205,LA768,LA7I,LRDPF,X + ; + K LA7ACC + ; + ; Quit - specimen uncollected & don't download uncollected flag set. + ; controls exempted. + S LRDPF=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",2) + S X=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)) + I LRDPF'=62.3,'$P(X,"^",3),'$P(^TMP("LA7-INST",$J,LA7INST),"^") Q + ; + S X=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,5,0)) + S LA761=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,5,X,0),"^") + S LA760=0 + F S LA760=$O(LA7TREE(LA760)) Q:'LA760 D + . I '$D(^TMP("LA7-INST",$J,LA7INST,LA760)) Q + . S LA7I=0 + . F S LA7I=$O(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I)) Q:'LA7I D + . . S LA76205=+$P(LA7TREE(LA760),"^") + . . D CHKMASK + ; + Q + ; +CHKMASK ; Check pattern mask for tests that match download pattern mask + ; + ; Any accession area, specimen, urgency + I $D(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I,0,0,0)) D ADD Q + ; + ; Specific accession area, any specimen/urgency + I $D(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I,LRAA,0,0)) D ADD Q + ; + ; Specific specimen, any accession area/urgency + I $D(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I,0,LA761,0)) D ADD Q + ; + ; Specific urgency, any accession area/specimen + I $D(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I,0,0,LA76205)) D ADD Q + ; + ; Specific accession/specimen, any urgency + I $D(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I,LRAA,LA761,0)) D ADD Q + ; + ; Specific specimen/urgency, any accession area + I $D(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I,0,LA761,LA76205)) D ADD Q + ; + ; Specific accession/specimen/urgency + I $D(^TMP("LA7-INST",$J,LA7INST,LA760,LA7I,LRAA,LA761,LA76205)) D ADD Q + ; + Q + ; +ADD ; Add to list of tests to download + ; + S LA7ACC(LA7I)=LA760_"^"_LA7TREE(LA760) + Q + ; + ; +CLEANUP ; Delete flag after accession has been checked. + ; NOTE: Lock previously set above. + ; + K ^LA("ADL","Q",LA7UID) + ; + ; Release lock on this UID. + L -^LA("ADL","Q",LA7UID) + ; + Q + ; + ; +ZTSK ; Task background job to run. + ; + N ZTDESC,ZTSAVE,ZTDTH,ZTIO,ZTRTN + ; + ; Task background job if not running. + S ZTRTN="DQ^LA7ADL",ZTDESC="Lab Auto Download",ZTIO="",ZTDTH=$H + D ^%ZTLOAD + ; + Q + ; + ; +BUILD ; Build TMP global with list of tests for instruments flagged for auto download. + D BUILD^LA7ADL1 + ; + ; Set flag to "Running". + D SETSTOP^LA7ADL1(0,$G(DUZ)) + ; + Q + ; + ; +EXIT ; Exit and cleanup. + ; + ; Release lock on LA("ADL") global. + L -^LA("ADL",0) + ; + K ^TMP("LA7",$J),^TMP($J) + K LA7ADL + K LRAA,LRAD,LRAN + K TOUT + ; + ; Clear flag if normal shutdown, no new accessions. + I +$G(^LA("ADL","STOP"))<2 K ^LA("ADL","STOP") + ; + Q diff --git a/r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7UID.m b/r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7UID.m index 67f49dc6..68b6b9cc 100644 --- a/r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7UID.m +++ b/r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7UID.m @@ -1,49 +1,48 @@ -LA7UID ;DALIO/JRR - BUILD HL7 DOWNLOAD TO UI ;May 20, 2008 - ;;5.2;AUTOMATED LAB INSTRUMENTS;**17,57,66**;Sep 27, 1994;Build 30 - ; - Q - ; -EN ; This line tag is called from ^LADOWN when downloading - ; a load work list to the Auto Instrument. LADOWN1 should - ; have already built ^TMP($J with all of the atomic and - ; cosmic tests, ^TMP("LA7",$J holds all of the Instrument defined - ; tests from 62.4. - ; LRLL= IEN in 68.2 Load Worklist file, from field in 62.4 - ; LRINST= IEN IN 62.4 Auto Inst file - ; LRAUTO= zero node of 62.4 entry - ; - N LA7MODE - S LA7INST=LRINST - I '$G(LA7ADL) D BLDINST^LA7ADL1(LA7INST,LRLL) - S LA76248=$P($G(^LAB(62.4,+$G(LRINST),0)),"^",8) - I 'LA76248 D Q - . S XQAMSG="MESSAGE CONFIGURATION not defined in AUTO INSTRUMENT file for "_$P(LRAUTO,"^") - . D ERROR,EXIT - . I '$D(ZTQUEUED) D ; - . . W $C(7),!!,"You must have a MESSAGE CONFIGURATION defined in field 8 of" - . . W !,"the AUTO INSTRUMENT file before downloading to this instrument!" - . ; - ; - I '$P(^LAHM(62.48,LA76248,0),"^",3) D Q - . S XQAMSG="STATUS field in the LA7 MESSAGE PARAMETER file not turned on for "_$P(LRAUTO,"^") - . D ERROR,EXIT - . I '$D(ZTQUEUED) D ; - . . W $C(7),!!,"The STATUS field in the LA7 MESSAGE PARAMETER file must be " - . . W !,"turned on before downloading to this instrument!" - . ; - ; - S LA7MODE=$P(^LAHM(62.48,LA76248,0),"^",4) - ; - ; Call the routine specified in the PROCESS DOWNLOAD field in file 62.48 - ; Download for one whole load list is done - X $G(^LAHM(62.48,LA76248,2)) - ; -EXIT I '$G(LA7ADL) K ^TMP("LA7",$J),LA76248 - Q - ; - ; -ERROR ; Send warning of error in Auto Instrument file configuration. - S XQA("G.LAB MESSAGING")="" - D SETUP^XQALERT - K XQA,XQAMSG - Q +LA7UID ;DALOI/JMC - BUILD HL7 DOWNLOAD TO UI; 12/3/1997 + ;;5.2;AUTOMATED LAB INSTRUMENTS;**17,57**;Sep 27, 1994 + Q + ; +EN ;; This line tag is called from ^LADOWN when downloading + ; a load work list to the Auto Instrument. + ; + ; LRLL= IEN in 68.2 Load Worklist file, from field in 62.4 + ; LRINST= IEN IN 62.4 Auto Inst file + ; LRAUTO= zero node of 62.4 entry + ; + S LA7INST=LRINST + I '$G(LA7ADL) D BLDINST^LA7ADL1(LA7INST,LRLL) + S LA76248=$P(^LAB(62.4,LA7INST,0),"^",8) + I 'LA76248 D Q + . I '$D(ZTQUEUED) D + . . W $C(7),!!,"You must have a MESSAGE CONFIGURATION defined in field 8 of" + . . W !,"the AUTO INSTRUMENT file before downloading to this instrument!" + . S XQAMSG="MESSAGE CONFIGURATION not defined in AUTO INSTRUMENT file for "_$P(LRAUTO,"^") + . D ERROR + . D EXIT + ; + I '$P(^LAHM(62.48,LA76248,0),"^",3) D Q + . I '$D(ZTQUEUED) D + . . W $C(7),!!,"The STATUS field in the MESSAGE PARAMETER file must be " + . . W !,"turned on before downloading to this instrument!" + . S XQAMSG="STATUS field in the MESSAGE PARAMETER file not turned on for "_$P(LRAUTO,"^") + . D ERROR + . D EXIT + ; + S LA7MODE=$P(^LAHM(62.48,LA76248,0),"^",4) + ; + ; +CALL ; Call the routine specified in the PROCESS DOWNLOAD field + ; in file 62.48 + X $G(^LAHM(62.48,LA76248,2)) + ; + ; +EXIT ; Download for one whole load list is done + I '$G(LA7ADL) K ^TMP("LA7-INST",$J),LA76248,LA7MODE + Q + ; + ; +ERROR ; Send warning of error in Auto Instrument file configuration. + ; + S XQA("G.LAB MESSAGING")="" + D SETUP^XQALERT + Q diff --git a/r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7VIN4.m b/r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7VIN4.m index 2bf0fdbf..8ff0f2ba 100644 --- a/r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7VIN4.m +++ b/r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7VIN4.m @@ -1,265 +1,263 @@ -LA7VIN4 ;DALOI/JMC - Process Incoming UI Msgs, continued ; 7/27/07 11:24am - ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64,67,66**;Sep 27, 1994;Build 30 - ;This routine is a continuation of LA7VIN1 and is only called from there. - Q - ; -OBR ; Process OBR segments - N I,LA7CUP,LA7ENTRY,LA7IDE,LA7INST,LA7PDUZ,LA7TRAY,LA7X,LA7Y - ; - ; OBR Set ID - S LA7SOBR=$$P^LA7VHLU(.LA7SEG,2,LA7FS) - ; - S LA7X=$$P^LA7VHLU(.LA7SEG,19,LA7FS) - S LA7X=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH) - S LA7624=0,LA7INST=$P(LA7X,"^") ; extracting 1st piece - ; Look up #62.4 entry from instrument name. - I LA7INST'="" S LA7624=+$O(^LAB(62.4,"B",LA7INST,0)) - ; - ; If none then use sending application name to look up #62.4 entry. - I 'LA7624 S LA7624=+$O(^LAB(62.4,"B",LA7SAP,0)) - ; - ; Instrument name not found in xref - I 'LA7624 D Q - . I LA7INST="" D Q - . . S LA7ERR=10,LA7QUIT=2 - . . D CREATE^LA7LOG(LA7ERR) - . S LA7ERR=11,LA7QUIT=2 - . D CREATE^LA7LOG(LA7ERR) - S LA7624(0)=$G(^LAB(62.4,LA7624,0)) - S LA7ID=$P(LA7624(0),"^")_"-I-" - ; - S LA7LWL=+$P(LA7624(0),"^",4) ; Load/Work List - S LA7ENTRY=$P(LA7624(0),"^",6) ;LOG,LLIST,IDENT or SEQN - S:LA7ENTRY="" LA7ENTRY="LOG" - ; - ; Placer(sender)/filler order numbers - S LA7X=$$P^LA7VHLU(.LA7SEG,3,LA7FS) - S LA7SID=$P(LA7X,$E(LA7ECH)) F I=2:1:4 S LA7SID(I)=$P(LA7X,$E(LA7ECH),I) - S LA7X=$$P^LA7VHLU(.LA7SEG,4,LA7FS) - S LA7FID=$P(LA7X,$E(LA7ECH)) F I=2:1:4 S LA7FID(I)=$P(LA7X,$E(LA7ECH),I) - ; - ; Test order code - find order NLT code - ; If POC interface then see if NLT is used for ordering code - S LA7X=$$P^LA7VHLU(.LA7SEG,5,LA7FS),LA7ONLT="" - F I=1,4 D Q:LA7ONLT'="" - . I $P(LA7X,LA7CS,I)'?5N1"."4N Q - . I $P(LA7X,LA7CS,I+2)="99VA64" S LA7ONLT=$P(LA7X,LA7CS,I),LA7ONLT(0)=$P(LA7X,LA7CS,I+1) Q - . I LA7INTYP>19,LA7INTYP<30,$P(LA7X,LA7CS,I+2)="" S LA7ONLT=$P(LA7X,LA7CS,I),LA7ONLT(0)=$P(LA7X,LA7CS,I+1) Q - ; - ; Specimen collection date/time - S LA7CDT=$$HL7TFM^XLFDT($P($$P^LA7VHLU(.LA7SEG,8,LA7FS),LA7CS),"L") - ; - ; Pull info from placer field #2 (OBR-19) - S LA7X=$$P^LA7VHLU(.LA7SEG,20,LA7FS) - S LA7X=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH) - S LA7TRAY=+$P(LA7X,"^",1) ;Tray - S LA7CUP=+$P(LA7X,"^",2) ; Cup - ; If POC interface set cup to file #62.49 ien - I LA7INTYP>19,LA7INTYP<30 S LA7CUP=LA76249 - S LA7AA=$P(LA7X,"^",3) ; Accession Area - S LA7AD=$P(LA7X,"^",4) ; Accession Date - S LA7AN=$P(LA7X,"^",5) ; Accession Entry - S LA7ACC=$P(LA7X,"^",6) ; Accession - S LA7UID=$P(LA7X,"^",7) ; Unique ID - I LA7UID'?1(10UN,15UN) S LA7UID="" - ; - ; Sequence Number - ; If point of care interface (20-29) then use file #62.49 ien as IDE - S LA7IDE=$P(LA7X,LA7CS,8) - I LA7INTYP>19,LA7INTYP<30 S LA7IDE=LA76249 - ; - ; UID might come as Sample ID - I LA7UID="",LA7SID?1(10UN,15UN) S LA7UID=LA7SID - ; - ; Try to figure out LA7AA LA7AD LA7AN by using the unique ID (UID) - ; accession may have rolled over, use UID to get current accession info. - I LA7UID]"" D - . N X - . S X=$Q(^LRO(68,"C",LA7UID)) - . I $QS(X,3)'=LA7UID S LA7UID="" Q ; UID not on file. - . S LA7AA=+$QS(X,4),LA7AD=+$QS(X,5),LA7AN=+$QS(X,6) - . D SETID^LA7VHLU1(LA76249,LA7ID,LA7UID) - ; - ; If still not known, compute from default accession date and area. - ; Calculate accession date based on accession transform. - I LA7AA<1!(LA7AD<1)!(LA7AN<1) D - . N X - . S LA7AA=+$P(LA7624(0),"^",11) - . S X=$P($G(^LRO(68,LA7AA,0)),U,3) - . S LA7AD=$S(X="D":DT,X="M":$E(DT,1,5)_"00",X="Y":$E(DT,1,3)_"0000",X="Q":$E(DT,1,3)_"0000"+(($E(DT,4,5)-1)\3*300+100),1:DT) - . S LA7AN=+LA7SID - . I LA7AN>0 D SETID^LA7VHLU1(LA76249,LA7ID,LA7AN) Q - . D SETID^LA7VHLU1(LA76249,LA7ID,$S($G(LA7PNM)]"":LA7PNM,$G(LA7SSN)]"":LA7SSN,1:"NO ID")) - ; - ; Zeroth node of accession area. - S LA7AA(0)=$G(^LRO(68,+LA7AA,0)) - ; Accession's subscript - S LA7SS=$P(LA7AA(0),"^",2) - ; - ; Specimen action code - S LA7SAC=$$P^LA7VHLU(.LA7SEG,12,LA7FS) - ; - ; Specimen(topography), collection sample, HL7 specimen source - S (LA761,LA762,LA70070,LA7SPEC)="" - S LA7SPTY=$$P^LA7VHLU(.LA7SEG,16,LA7FS) - ; - ; Check if using HL7 table 0070 - S LA7X=$P($P(LA7SPTY,LA7CS),$E(LA7ECH,4),3) - I LA7X=""!(LA7X="HL70070") S LA7SPEC=$P($P(LA7SPTY,LA7CS),$E(LA7ECH,4)) - ; - I $O(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,0)) D - . N X - . S X=$O(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,0)) - . ; specimen^collection sample - . S X(0)=$G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,X,0)) - . S LA761=$P(X(0),"^") ; specimen - . S LA762=$P(X(0),"^",2) ; collection sample - . ; HL7 code - . I LA761 S LA70070=$$GET1^DIQ(61,LA761_",","LEDI HL7:HL7 ABBR") - ; - ; Log error when specimen source does not match accession's specimen - I LA70070'="",LA7SPEC'="",LA70070'=LA7SPEC D - . ; Ignore if specimen related to lab control file #62.3 - . I $P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0)),"^",2)=62.3 Q - . N LA7OBR - . S LA7OBR(15)=LA7SPEC ; backward compatible with old code - . S LA7ERR=22,LA7QUIT=2 - . D CREATE^LA7LOG(LA7ERR) - ; - ; Don't continue if flag set to skip this segment - I LA7QUIT Q - ; - ; Placer's ordering provider (id^duz^last name, first name, mi [id]) - I $G(LA7POP)="" D - . S LA7POP="",LA7X=$$P^LA7VHLU(.LA7SEG,17,LA7FS) - . I LA7X="" Q - . S LA7POP=$$XCNTFM^LA7VHLU4(LA7X,LA7ECH) - . I LA7POP="^^" S LA7POP="" - ; - ; Create entry in LAH for supported subscripts. - I LA7MTYP="ORR",$G(LA7OTYPE)'="OK","CHMI"[LA7SS D - . D LAGEN - . I $G(LA7ISQN)="" D CREATE^LA7LOG(14) Q - . S LA7I=$O(^TMP("LA7 ORDER STATUS",$J,""),-1),LA7I=LA7I+1 - . I LA7ONLT="" S X=$$P^LA7VHLU(.LA7SEG,5,LA7FS),LA7X=$P(X,LA7CS),LA7X(0)=$P(X,LA7CS,2) - . E S LA7X=LA7ONLT,LA7X(0)=LA7ONLT(0) - . S X=LA7LWL_"^"_LA7ISQN_"^"_LA7X_"^"_LA7X(0)_"^"_LA76248_"^"_LA76249_"^"_LA7OTYPE_"^^"_$P($G(LA7SM),"^",2) - . S ^TMP("LA7 ORDER STATUS",$J,LA7I)=X - . I $G(LA7OCR)'="" S ^TMP("LA7 ORDER STATUS",$J,LA7I,"OCR")=$TR(LA7OCR,LA7CS,"^") - . I $G(LA7MSATM)'="" S ^TMP("LA7 ORDER STATUS",$J,LA7I,"MSA")=LA7MSATM - ; - I LA7MTYP="ORU","CHMI"[LA7SS D - . D LAGEN - . I $G(LA7ISQN)<1 D CREATE^LA7LOG(14) Q - . I LA7INTYP=10,LA7SAC?1(1"A",1"G") D - . . S LA7I=$O(^TMP("LA7 ORDER STATUS",$J,""),-1),LA7I=LA7I+1,LA7SAC(0)=LA7I - . . I LA7ONLT="" S X=$$P^LA7VHLU(.LA7SEG,5,LA7FS),LA7X=$P(X,LA7CS),LA7X(0)=$P(X,LA7CS,2) - . . E S LA7X=LA7ONLT,LA7X(0)=LA7ONLT(0) - . . S X=LA7LWL_"^"_LA7ISQN_"^"_LA7X_"^"_LA7X(0)_"^"_LA76248_"^"_LA76249_"^"_$G(LA7OTYPE)_"^"_LA7SAC_"^"_$P($G(LA7SM),"^",2) - . . S ^TMP("LA7 ORDER STATUS",$J,LA7I)=X - ; - I LA7INTYP=10,$G(LA7SM)'="",$G(LA7UID)'="" D SMUPDT - Q - ; - ; -LAGEN ; Sets up variables for call to ^LAGEN, build entry in LAH - ; requires LA7INST,LA7TRAY,LA7CUP,LA7AA,LA7AD,LA7AN,LA7LWL - ; returns LA7ISQN=subscript to store results in ^LAH global - ; - I LA7ENTRY="LOG" D - . I LA7INTYP>19,LA7INTYP<30 Q - . I '$D(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0)) D CREATE^LA7LOG(13) - I LA7ENTRY="LLIST" S:'LA7CUP LA7CUP=LA7IDE ;cup=sequence number - ; - K LA7ISQN,LADT,LAGEN - K TRAY,CUP,LWL,WL,LROVER,METH,LOG,IDENT,ISQN - ; - S LA7ISQN="" - S TRAY=+$G(LA7TRAY) S:'TRAY TRAY=1 - S CUP=+$G(LA7CUP) S:'CUP CUP=1 - ; - S LWL=LA7LWL - I '$D(^LRO(68.2,+LWL,0)) D Q - . D CREATE^LA7LOG(19) - ; - ; Set accession area to area of specimen, allow multiple areas on same instrument. - S WL=LA7AA - I '$D(^LRO(68,+WL,0)) D Q - . D CREATE^LA7LOG(20) - S LROVER=$P(LA7624(0),"^",12) - S METH=$P(LA7624(0),"^",10) - S LOG=LA7AN - S IDENT=$P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0)),"^",6) ;identity field - S IDE=+LA7IDE - S LADT=LA7AD - ; - ; If POC interface call special entry point - D - . N LRDFN ; Protect LRDFN - call into LAGEN can set to 0 - . I LA7INTYP>19,LA7INTYP<30 S IDE=LA76249 D POC^LAGEN Q - . D @(LA7ENTRY_"^LAGEN") ;this disregards the CROSS LINK field in 62.4 - S LA7ISQN=$G(ISQN) - ; - I LA7ISQN<1 Q - ; - ; Build/store patient demographics array - N I,J,LA7OBRA,LA7PIDA,X,Y - S J="DFN^DOB^ICN^LOC^LRDFN^LRTDFN^PNM^SEX^SSN" - S J(0)="DFN^LA7DOB^LA7ICN^LA7LOC^LRDFN^LRTDFN^LA7PNM^LA7SEX^LA7SSN" - F I=1:1 S X=$P(J,"^",I) Q:X="" D - . S Y=$P(J(0),"^",I) - . I $G(@Y)'="" S LA7PIDA(X)=@Y - I $D(LA7PIDA) D POI^LAGEN(LA7LWL,LA7ISQN,"PID",.LA7PIDA) - ; - ; Build/store order info array - N LA7ONLTS - I LA7POP'="" S LA7POP=$P(LA7POP," [") - S X=$G(^LAH(LA7LWL,1,LA7ISQN,.1,"OBR","ORDNLT")) - I X'="",LA7ONLT'="",X'[LA7ONLT S LA7ONLTS=X_"^"_LA7ONLT - E S LA7ONLTS=LA7ONLT - S J="EOL^FID^ORCDT^ORDNLT^ORDP^ORDSPEC^PON^SID^PEB^PVB" - S J(0)="LA7EOL^LA7FID^LA7CDT^LA7ONLTS^LA7POP^LA7SPEC^LA7PON^LA7SID^LA7PEB^LA7PVB" - F I=1:1 S X=$P(J,"^",I) Q:X="" D - . S Y=$P(J(0),"^",I) - . I $G(@Y)'="" S LA7OBRA(X)=@Y - I $D(LA7OBRA) D POI^LAGEN(LA7LWL,LA7ISQN,"OBR",.LA7OBRA) - ; - ; Store interface type with results - D LATYP^LAGEN(LA7LWL,LA7ISQN,LA7INTYP) - ; - ; Store #62.49 ien with results - D LAMSGID^LAGEN(LA7LWL,LA7ISQN,LA76249) - ; - ; Store method name with LAH entry - D METH^LAGEN(LA7LWL,LA7ISQN,METH) - ; - ; Set flag if POC interface to start POC processing routine when - ; finished - tasked by LA7VIN before shutdown - I LA7INTYP>19,LA7INTYP<30 S LA7INTYP("LWL",LA7LWL)="" - ; - Q - ; - ; -SMUPDT ; Update shipping manifest in shipping event file #62.85 - N LA7DATA,LA7NCS,LA7TST,LA7USID - ; - S LA7USID=$$P^LA7VHLU(.LA7SEG,5,LA7FS) ; Universal Service ID (OBR-4) - S LA7TST=$P(LA7USID,LA7CS,1) ; Test code - S LA7NCS=$P(LA7USID,LA7CS,3) ; Name of coding system - S LA7TST(2)=$P(LA7USID,LA7CS,4) ; Alternate test code - S LA7NCS(2)=$P(LA7USID,LA7CS,6) ; Alternate coding system - ; - ; Determine ordered test, check primary and alternate - S LA7OTST=$$DOT^LA7SMU1(LA7TST,LA7NCS,LA7UID,$P(LA7SM,"^")) - I 'LA7OTST,LA7TST(2)'="" S LA7OTST=$$DOT^LA7SMU1(LA7TST(2),LA7NCS(2),LA7UID,$P(LA7SM,"^")) - ; - ; Flag the Results Received Event in #62.85 - I LA7MTYP="ORU" D - . S LA7DATA="SM70"_"^"_LA7MEDT_"^"_$G(LA7OTST)_"^"_$P(LA7SM,"^",2) - . D SEUP^LA7SMU(LA7UID,"2",LA7DATA) - ; - ; Flag the Test Received Event in #62.85 - I LA7MTYP="ORR" D - . S LA7DATA="SM55"_"^"_LA7MEDT_"^"_$G(LA7OTST)_"^"_$P(LA7SM,"^",2) - . D SEUP^LA7SMU(LA7UID,"2",LA7DATA) - Q +LA7VIN4 ;DALOI/JMC - Process Incoming UI Msgs, continued ; Jan 12, 2004 + ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64,67**;Sep 27, 1994 + ;This routine is a continuation of LA7VIN1 and is only called from there. + Q + ; +OBR ; Process OBR segments + N I,LA7CUP,LA7ENTRY,LA7IDE,LA7INST,LA7PDUZ,LA7TRAY,LA7X,LA7Y + ; + ; OBR Set ID + S LA7SOBR=$$P^LA7VHLU(.LA7SEG,2,LA7FS) + ; + S LA7X=$$P^LA7VHLU(.LA7SEG,19,LA7FS) + S LA7X=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH) + S LA7624=0,LA7INST=$P(LA7X,"^") ; extracting 1st piece + ; Look up #62.4 entry from instrument name. + I LA7INST'="" S LA7624=+$O(^LAB(62.4,"B",LA7INST,0)) + ; + ; If none then use sending application name to look up #62.4 entry. + I 'LA7624 S LA7624=+$O(^LAB(62.4,"B",LA7SAP,0)) + ; + ; Instrument name not found in xref + I 'LA7624 D Q + . I LA7INST="" D Q + . . S LA7ERR=10,LA7QUIT=2 + . . D CREATE^LA7LOG(LA7ERR) + . S LA7ERR=11,LA7QUIT=2 + . D CREATE^LA7LOG(LA7ERR) + S LA7624(0)=$G(^LAB(62.4,LA7624,0)) + S LA7ID=$P(LA7624(0),"^")_"-I-" + ; + S LA7LWL=+$P(LA7624(0),"^",4) ; Load/Work List + S LA7ENTRY=$P(LA7624(0),"^",6) ;LOG,LLIST,IDENT or SEQN + S:LA7ENTRY="" LA7ENTRY="LOG" + ; + ; Placer(sender)/filler order numbers + S LA7X=$$P^LA7VHLU(.LA7SEG,3,LA7FS) + S LA7SID=$P(LA7X,$E(LA7ECH)) F I=2:1:4 S LA7SID(I)=$P(LA7X,$E(LA7ECH),I) + S LA7X=$$P^LA7VHLU(.LA7SEG,4,LA7FS) + S LA7FID=$P(LA7X,$E(LA7ECH)) F I=2:1:4 S LA7FID(I)=$P(LA7X,$E(LA7ECH),I) + ; + ; Test order code - find order NLT code + ; If POC interface then see if NLT is used for ordering code + S LA7X=$$P^LA7VHLU(.LA7SEG,5,LA7FS),LA7ONLT="" + F I=1,4 D Q:LA7ONLT'="" + . I $P(LA7X,LA7CS,I)'?5N1"."4N Q + . I $P(LA7X,LA7CS,I+2)="99VA64" S LA7ONLT=$P(LA7X,LA7CS,I),LA7ONLT(0)=$P(LA7X,LA7CS,I+1) Q + . I LA7INTYP>19,LA7INTYP<30,$P(LA7X,LA7CS,I+2)="" S LA7ONLT=$P(LA7X,LA7CS,I),LA7ONLT(0)=$P(LA7X,LA7CS,I+1) Q + ; + ; Specimen collection date/time + S LA7CDT=$$HL7TFM^XLFDT($P($$P^LA7VHLU(.LA7SEG,8,LA7FS),LA7CS),"L") + ; + ; Pull info from placer field #2 (OBR-19) + S LA7X=$$P^LA7VHLU(.LA7SEG,20,LA7FS) + S LA7X=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH) + S LA7TRAY=+$P(LA7X,"^",1) ;Tray + S LA7CUP=+$P(LA7X,"^",2) ; Cup + ; If POC interface set cup to file #62.49 ien + I LA7INTYP>19,LA7INTYP<30 S LA7CUP=LA76249 + S LA7AA=$P(LA7X,"^",3) ; Accession Area + S LA7AD=$P(LA7X,"^",4) ; Accession Date + S LA7AN=$P(LA7X,"^",5) ; Accession Entry + S LA7ACC=$P(LA7X,"^",6) ; Accession + S LA7UID=$P(LA7X,"^",7) ; Unique ID + I LA7UID'?1(10UN,15UN) S LA7UID="" + ; + ; Sequence Number + ; If point of care interface (20-29) then use file #62.49 ien as IDE + S LA7IDE=$P(LA7X,LA7CS,8) + I LA7INTYP>19,LA7INTYP<30 S LA7IDE=LA76249 + ; + ; UID might come as Sample ID + I LA7UID="",LA7SID?1(10UN,15UN) S LA7UID=LA7SID + ; + ; Try to figure out LA7AA LA7AD LA7AN by using the unique ID (UID) + ; accession may have rolled over, use UID to get current accession info. + I LA7UID]"" D + . N X + . S X=$Q(^LRO(68,"C",LA7UID)) + . I $QS(X,3)'=LA7UID S LA7UID="" Q ; UID not on file. + . S LA7AA=+$QS(X,4),LA7AD=+$QS(X,5),LA7AN=+$QS(X,6) + . D SETID^LA7VHLU1(LA76249,LA7ID,LA7UID) + ; + ; If still not known, compute from default accession date and area. + ; Calculate accession date based on accession transform. + I LA7AA<1!(LA7AD<1)!(LA7AN<1) D + . N X + . S LA7AA=+$P(LA7624(0),"^",11) + . S X=$P($G(^LRO(68,LA7AA,0)),U,3) + . S LA7AD=$S(X="D":DT,X="M":$E(DT,1,5)_"00",X="Y":$E(DT,1,3)_"0000",X="Q":$E(DT,1,3)_"0000"+(($E(DT,4,5)-1)\3*300+100),1:DT) + . S LA7AN=+LA7SID + . I LA7AN>0 D SETID^LA7VHLU1(LA76249,LA7ID,LA7AN) + . E D SETID^LA7VHLU1(LA76249,LA7ID,$S(LA7PNM]"":LA7PNM,LA7SSN]"":LA7SSN,1:"NO ID")) + ; + ; Zeroth node of acession area. + S LA7AA(0)=$G(^LRO(68,+LA7AA,0)) + ; Accession's subscript + S LA7SS=$P(LA7AA(0),"^",2) + ; + ; Specimen action code + S LA7SAC=$$P^LA7VHLU(.LA7SEG,12,LA7FS) + ; + ; Specimen(topography), collection sample, HL7 specimen source + S (LA761,LA762,LA70070,LA7SPEC)="" + S LA7SPTY=$$P^LA7VHLU(.LA7SEG,16,LA7FS) + ; + ; Check if using HL7 table 0070 + S LA7X=$P($P(LA7SPTY,LA7CS),$E(LA7ECH,4),3) + I LA7X=""!(LA7X="HL70070") S LA7SPEC=$P($P(LA7SPTY,LA7CS),$E(LA7ECH,4)) + ; + I $O(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,0)) D + . N X + . S X=$O(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,0)) + . ; specimen^collection sample + . S X(0)=$G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,X,0)) + . S LA761=$P(X(0),"^") ; specimen + . S LA762=$P(X(0),"^",2) ; collection sample + . ; HL7 code + . I LA761 S LA70070=$$GET1^DIQ(61,LA761_",","LEDI HL7:HL7 ABBR") + ; + ; Log error when specimen source does not match accession's specimen + I LA70070'="",LA7SPEC'="",LA70070'=LA7SPEC D + . N LA7OBR + . S LA7OBR(15)=LA7SPEC ; backward compatible with old code + . S LA7ERR=22,LA7QUIT=2 + . D CREATE^LA7LOG(LA7ERR) + ; + ; Don't continue if flag set to skip this segment + I LA7QUIT Q + ; + ; Placer's ordering provider (id^duz^last name, first name, mi [id]) + I $G(LA7POP)="" D + . S LA7POP="",LA7X=$$P^LA7VHLU(.LA7SEG,17,LA7FS) + . I LA7X="" Q + . S LA7POP=$$XCNTFM^LA7VHLU4(LA7X,LA7ECH) + . I LA7POP="^^" S LA7POP="" + ; + ; Create entry in LAH for supported subscripts. + I LA7MTYP="ORR",$G(LA7OTYPE)'="OK","CHMI"[LA7SS D + . D LAGEN + . I $G(LA7ISQN)="" D CREATE^LA7LOG(14) Q + . S LA7I=$O(^TMP("LA7 ORDER STATUS",$J,""),-1),LA7I=LA7I+1 + . I LA7ONLT="" S X=$$P^LA7VHLU(.LA7SEG,5,LA7FS),LA7X=$P(X,LA7CS),LA7X(0)=$P(X,LA7CS,2) + . E S LA7X=LA7ONLT,LA7X(0)=LA7ONLT(0) + . S X=LA7LWL_"^"_LA7ISQN_"^"_LA7X_"^"_LA7X(0)_"^"_LA76248_"^"_LA76249_"^"_LA7OTYPE_"^^"_$P($G(LA7SM),"^",2) + . S ^TMP("LA7 ORDER STATUS",$J,LA7I)=X + . I $G(LA7OCR)'="" S ^TMP("LA7 ORDER STATUS",$J,LA7I,"OCR")=$TR(LA7OCR,LA7CS,"^") + . I $G(LA7MSATM)'="" S ^TMP("LA7 ORDER STATUS",$J,LA7I,"MSA")=LA7MSATM + ; + I LA7MTYP="ORU","CHMI"[LA7SS D + . D LAGEN + . I $G(LA7ISQN)<1 D CREATE^LA7LOG(14) Q + . I LA7INTYP=10,LA7SAC?1(1"A",1"G") D + . . S LA7I=$O(^TMP("LA7 ORDER STATUS",$J,""),-1),LA7I=LA7I+1,LA7SAC(0)=LA7I + . . I LA7ONLT="" S X=$$P^LA7VHLU(.LA7SEG,5,LA7FS),LA7X=$P(X,LA7CS),LA7X(0)=$P(X,LA7CS,2) + . . E S LA7X=LA7ONLT,LA7X(0)=LA7ONLT(0) + . . S X=LA7LWL_"^"_LA7ISQN_"^"_LA7X_"^"_LA7X(0)_"^"_LA76248_"^"_LA76249_"^"_$G(LA7OTYPE)_"^"_LA7SAC_"^"_$P($G(LA7SM),"^",2) + . . S ^TMP("LA7 ORDER STATUS",$J,LA7I)=X + ; + I LA7INTYP=10,$G(LA7SM)'="",$G(LA7UID)'="" D SMUPDT + Q + ; + ; +LAGEN ; Sets up variables for call to ^LAGEN, build entry in LAH + ; requires LA7INST,LA7TRAY,LA7CUP,LA7AA,LA7AD,LA7AN,LA7LWL + ; returns LA7ISQN=subscript to store results in ^LAH global + ; + I LA7ENTRY="LOG" D + . I LA7INTYP>19,LA7INTYP<30 Q + . I '$D(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0)) D CREATE^LA7LOG(13) + I LA7ENTRY="LLIST" S:'LA7CUP LA7CUP=LA7IDE ;cup=sequence number + ; + K LA7ISQN,LADT,LAGEN + K TRAY,CUP,LWL,WL,LROVER,METH,LOG,IDENT,ISQN + ; + S LA7ISQN="" + S TRAY=+$G(LA7TRAY) S:'TRAY TRAY=1 + S CUP=+$G(LA7CUP) S:'CUP CUP=1 + ; + S LWL=LA7LWL + I '$D(^LRO(68.2,+LWL,0)) D Q + . D CREATE^LA7LOG(19) + ; + ; Set accession area to area of specimen, allow multiple areas on same instrument. + S WL=LA7AA + I '$D(^LRO(68,+WL,0)) D Q + . D CREATE^LA7LOG(20) + S LROVER=$P(LA7624(0),"^",12) + S METH=$P(LA7624(0),"^",10) + S LOG=LA7AN + S IDENT=$P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0)),"^",6) ;identity field + S IDE=+LA7IDE + S LADT=LA7AD + ; + ; If POC interface call special entry point + D + . N LRDFN ; Protect LRDFN - call into LAGEN can set to 0 + . I LA7INTYP>19,LA7INTYP<30 S IDE=LA76249 D POC^LAGEN Q + . D @(LA7ENTRY_"^LAGEN") ;this disregards the CROSS LINK field in 62.4 + S LA7ISQN=$G(ISQN) + ; + I LA7ISQN<1 Q + ; + ; Build/store patient demographics array + N I,J,LA7OBRA,LA7PIDA,X,Y + S J="DFN^DOB^ICN^LOC^LRDFN^LRTDFN^PNM^SEX^SSN" + S J(0)="DFN^LA7DOB^LA7ICN^LA7LOC^LRDFN^LRTDFN^LA7PNM^LA7SEX^LA7SSN" + F I=1:1 S X=$P(J,"^",I) Q:X="" D + . S Y=$P(J(0),"^",I) + . I $G(@Y)'="" S LA7PIDA(X)=@Y + I $D(LA7PIDA) D POI^LAGEN(LA7LWL,LA7ISQN,"PID",.LA7PIDA) + ; + ; Build/store order info array + N LA7ONLTS + I LA7POP'="" S LA7POP=$P(LA7POP," [") + S X=$G(^LAH(LA7LWL,1,LA7ISQN,.1,"OBR","ORDNLT")) + I X'="",LA7ONLT'="",X'[LA7ONLT S LA7ONLTS=X_"^"_LA7ONLT + E S LA7ONLTS=LA7ONLT + S J="EOL^FID^ORCDT^ORDNLT^ORDP^ORDSPEC^PON^SID^PEB^PVB" + S J(0)="LA7EOL^LA7FID^LA7CDT^LA7ONLTS^LA7POP^LA7SPEC^LA7PON^LA7SID^LA7PEB^LA7PVB" + F I=1:1 S X=$P(J,"^",I) Q:X="" D + . S Y=$P(J(0),"^",I) + . I $G(@Y)'="" S LA7OBRA(X)=@Y + I $D(LA7OBRA) D POI^LAGEN(LA7LWL,LA7ISQN,"OBR",.LA7OBRA) + ; + ; Store interface type with results + D LATYP^LAGEN(LA7LWL,LA7ISQN,LA7INTYP) + ; + ; Store #62.49 ien with results + D LAMSGID^LAGEN(LA7LWL,LA7ISQN,LA76249) + ; + ; Store method name with LAH entry + D METH^LAGEN(LA7LWL,LA7ISQN,METH) + ; + ; Set flag if POC interface to start POC processing routine when + ; finished - tasked by LA7VIN before shutdown + I LA7INTYP>19,LA7INTYP<30 S LA7INTYP("LWL",LA7LWL)="" + ; + Q + ; + ; +SMUPDT ; Update shipping manifest in shipping event file #62.85 + N LA7DATA,LA7NCS,LA7TST,LA7USID + ; + S LA7USID=$$P^LA7VHLU(.LA7SEG,5,LA7FS) ; Universal Service ID (OBR-4) + S LA7TST=$P(LA7USID,LA7CS,1) ; Test code + S LA7NCS=$P(LA7USID,LA7CS,3) ; Name of coding system + S LA7TST(2)=$P(LA7USID,LA7CS,4) ; Alternate test code + S LA7NCS(2)=$P(LA7USID,LA7CS,6) ; Alternate coding system + ; + ; Determine ordered test, check primary and alternate + S LA7OTST=$$DOT^LA7SMU1(LA7TST,LA7NCS,LA7UID,$P(LA7SM,"^")) + I 'LA7OTST,LA7TST(2)'="" S LA7OTST=$$DOT^LA7SMU1(LA7TST(2),LA7NCS(2),LA7UID,$P(LA7SM,"^")) + ; + ; Flag the Results Received Event in #62.85 + I LA7MTYP="ORU" D + . S LA7DATA="SM70"_"^"_LA7MEDT_"^"_$G(LA7OTST)_"^"_$P(LA7SM,"^",2) + . D SEUP^LA7SMU(LA7UID,"2",LA7DATA) + ; + ; Flag the Test Received Event in #62.85 + I LA7MTYP="ORR" D + . S LA7DATA="SM55"_"^"_LA7MEDT_"^"_$G(LA7OTST)_"^"_$P(LA7SM,"^",2) + . D SEUP^LA7SMU(LA7UID,"2",LA7DATA) + Q diff --git a/r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7VIN5A.m b/r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7VIN5A.m index 0f4443c4..a7cfcb8b 100644 --- a/r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7VIN5A.m +++ b/r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7VIN5A.m @@ -1,279 +1,272 @@ -LA7VIN5A ;DALOI/JMC - Process Incoming UI Msgs, continued ;May 29, 2008 - ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64,67,72,66**;Sep 27, 1994;Build 30 - ; This routine is a continuation of LA7VIN5. - ; It is performs processing of fields in OBX segments. - Q - ; -XFORM ; Transform the result based on fields 12,13,14,16,17 in the Chem Test - ; multiple in the Auto Instrument file (62.4), or set on the fly - ; from PARAM 1 - N LA7I - S LA7XFORM=LA76241(2) - ; - ; get PARAM 1 overrides - I $D(LA7XFORM(1)),LA7XFORM(1)?1.N S $P(LA7XFORM,"^")=LA7XFORM(1) - F LA7I=2,3,5,6 I $D(LA7XFORM(LA7I)) S $P(LA7XFORM,"^",LA7I)=LA7XFORM(LA7I) - ; set up defaults if field was not answered - ; accept results,yes - I $P(LA7XFORM,"^",3)="" S $P(LA7XFORM,"^",3)=1 - ; strip spaces,no - I $P(LA7XFORM,"^",6)="" S $P(LA7XFORM,"^",6)=0 - ; now transform - ; - ; Don't accept results - I '$P(LA7XFORM,"^",3) S LA7VAL="" Q - ; - ; Only accept "FINAL" type results - I $P(LA7XFORM,"^",3)=2,"CFUX"'[LA7ORS S LA7VAL="" Q - ; - ; Accept ordered tests only - ; If LEDI interface (10) and message indicates a reflex ("G") or add-on - ; test ("A") then process anyway in case it has not been added to - ; accession. - I $P(LA7XFORM,"^",5) D - . I LA7INTYP=10,LA7SAC?1(1"A",1"G") Q - . S LA7LIMIT=1 - ; - ; Decimal places if number of places defined - I $P(LA7XFORM,"^")?1.N D JUSTDEC - ; - ; Strip spaces - I $P(LA7XFORM,"^",6) S LA7VAL=$TR(LA7VAL," ","") - ; - ; Make result a comment - ; Set value to null after making into remark, don't store twice. - I $P(LA7XFORM,"^",2) D - . N LA7Y - . ; Store comment in ^LAH global - . S LA7Y=$P(LA7RMK(0,+LA76241(0)),"^",2) - . D RMKSET^LASET(LA7LWL,LA7ISQN,LA7VAL,LA7Y) - . S LA7VAL="" - Q - ; - ; -CHKDIE ; Check if value to be stored passes input transform of field in DD - N LA7ERR,LA7Y - ; - ; If result is on a LEDI interface (type=10) then don't check result - ; against FileMan input transform. - ; VistA sends "canc" as test result when test is cancelled. - ; DoD sends "PL Canceled" --> change to "canc" for VistA storage. - I LA7INTYP=10 D Q - . I LA7VAL="PL Cancelled" S LA7VAL="canc" - . I LA7VAL="PL Canceled" S LA7VAL="canc" - . I LA7VAL="PLCanceled" S LA7VAL="canc" - ; - ; If value fails data checker then log error and suppress result. - D CHK^DIE(LA7SUBFL,LA76304,"H",LA7VAL,.LA7Y,"LA7ERR") - I LA7Y="^" D - . N LA7X - . S LA7X=$G(LA7ERR("DIERR",1,"TEXT",1)) - . D CREATE^LA7LOG(37) - . S LA7VAL="" - Q - ; - ; -JUSTDEC ; Justify to number of places specified - ; - N LA7DDTYP,LA7FMT,LA7I,LA7PRFIX,LA7X - ; - ; If LEDI interface (type=10) then skip decimal adjustment - I LA7INTYP=10 Q - ; - ; Get data name field type from DD - ; Only justify if Vista field is numeric or free text. - S LA7DDTYP=$$GET1^DID(LA7SUBFL,LA76304,"","TYPE") - I "NUMERIC^FREE TEXT"'[LA7DDTYP D Q - . N LA7FLDNM - . S LA7FLDNM=$$GET1^DID(63.04,LA76304,"","LABEL") - . D CREATE^LA7LOG(38) - ; - S LA7X=LA7VAL,(LA7FMT,LA7PRFIX)="" - ; - ; If comma formatted, strip comma and set flag to add back in. - S LA7X=$TR(LA7X,",","") - I LA7X'=LA7VAL S LA7FMT="P" - ; - ; If "<>=" formatted, strip and save to add back in. - F LA7I=1:1:$L(LA7X) Q:$E(LA7X,LA7I)'?1(1"<",1">",1"=") - I LA7I>1 D - . S LA7PRFIX=$E(LA7X,1,LA7I-1) - . S LA7X=$E(LA7X,LA7I,$L(LA7X)) - ; - ; Format if starts with number or decimal point, skip other results. - I LA7X?1(1.N,.N1"."1.N) D - . S LA7X=$FN(LA7X,LA7FMT,+LA7XFORM) - . S LA7VAL=LA7PRFIX_LA7X - Q - ; - ; -PRDID(LA7PRDID,LA7SFAC,LA7CS) ; Process/Store Producer's ID - ; Store where test was performed. - ; Call with LA7PRDID = Producer's ID field - ; LA7SFAC = sending facility - ; LA7CS = component encoding character - ; - ; Remove units/reference ranges when Lab UI interface - ; so file #60 settings always used - I $G(LA7INTYP)=1 S $P(^LAH(LA7LWL,1,LA7ISQN,LA76304),"^",5)="" Q - ; - N LA74,LA7I,LA7X,LA7Y - ; - S LA7X=$P(LA7PRDID,LA7CS,2),LA74="" - ; - F LA7I=1,4 D Q:LA74 - . I $P(LA7PRDID,LA7CS,LA7I+2)="99VA4" S LA74=$$LKUP^XUAF4($P(LA7PRDID,LA7CS,LA7I)) - . I 'LA74,$P(LA7PRDID,LA7CS,LA7I+2)?1(1"L-CL",1"CLIA",1"99VACLIA") S LA74=$$IDX^XUAF4("CLIA",$P(LA7PRDID,LA7CS,LA7I)) - . I 'LA74 S LA74=$$LKUP^XUAF4($P(LA7PRDID,LA7CS,LA7I+1)) - . I 'LA74 S LA74=$$FINDSITE^LA7VHLU2($P(LA7PRDID,LA7CS),1,1) - . I 'LA74 S LA74=$$FINDSITE^LA7VHLU2($P(LA7SFAC,LA7CS),1,1) - ; - ; Store producer's id in LAH global with results. - I LA74 S $P(^LAH(LA7LWL,1,LA7ISQN,LA76304),"^",9)=LA74 Q - ; - ; Don't store producer's id as comment. - I '$P(LA76241(2),"^",9) Q - ; If unable to identify producer in file #4 - ; then store as comment if field STORE PRODUCER'S ID (#20) enabled. - I LA7X="" Q - S LA7Y=$P(LA7RMK(0,+LA76241(0)),"^",2) - S LA7X=$S(LA7Y="":"P",1:"p")_"erformed by "_LA7X - D RMKSET^LASET(LA7LWL,LA7ISQN,LA7X,LA7Y) - ; - Q - ; - ; -REFRNG(LA7X) ; Process/Store References Range. - ; Call with LA7X = reference range to store. - ; - Q:$G(LA7INTYP)=1 - N LA7Y,X,Y - ; - ; Check if site does not want to store reference ranges on POC test. - I LA7INTYP>19,LA7INTYP<30,+$P(LA76241(2),"^",10)=0 Q - ; - ; Remove leading and trailing quotes from reference range. - S LA7X=$$TRIM^XLFSTR($G(LA7X),"RL","""") - I LA7X="" Q - ; - S X=$P($G(^LAH(LA7LWL,1,LA7ISQN,LA76304)),"^",5) - ; - ; >lower limit (no upper limit e.g. >10) - store as low value - I LA7X?1">".N.1".".N S $P(X,"!",2)=$TR(LA7X,">",""),LA7X="" - ; - ; 19,LA7INTYP<30,LA7Y="",LA7X'="" D - . S X=" L^ H^LL^HH^ <^ >^ N^ A^AA^ U^ D^ B^ W^ S^ R^ I^MS^VS" - . S I=$F(X,LA7X)\3 - . S LA7Y="normalcy status - "_$P($T(ABFLAGS+I^LA7VHLU1),";;",2) - . D RMKSET^LASET(LA7LWL,LA7ISQN,LA7Y,$P(LA7RMK(0,+LA76241(0)),"^",2)) - ; - Q - ; - ; -EII ; Store equipment instance identifier in LAH global with results. - ; - N I,LA7X,X - ; - S LA7X="" - F I=1:1:4 D - . S X=$P(LA7EII,LA7CS,I) - . I X="" Q - . S $P(LA7X,"!",I)=$TR(X,"!","~") - I LA7X'="" S $P(^LAH(LA7LWL,1,LA7ISQN,LA76304),"^",11)=LA7X - Q - ; - ; -ORESULTS ; Process results that accompany order (ORM) messages - ; - N I,LA764,LA7DIE,LA7ERR,LA7I,LA7WP,LA7X,LA7Y,X - S LA7WP(1,0)=" ",LA7I=2,X="" - I LA7RLNC S X="[LOINC "_$$GET1^DIQ(95.3,LA7RLNC_",",.01)_"] "_$$GET1^DIQ(95.3,LA7RLNC_",",80) - I 'LA7RLNC,LA7RNLT D - . S LA764=$$FIND1^DIC(64,"","X",LA7RNLT,"E","","LA7ERR") - . I 'LA764 S LA7RNLT="" Q - . S X="[NLT "_$$GET1^DIQ(64,LA764_",",1)_"] "_$$GET1^DIQ(64,LA764_",",.01,"I") - I 'LA7RLNC,'LA7RNLT D - . I LA7TEST(0)]""!(LA7TEST]"") S X="["_LA7TEST(0,1)_" "_LA7TEST_"] "_LA7TEST(0) Q - . S X="["_LA7TEST(2,1)_" "_LA7TEST(2)_"] "_LA7TEST(2,0) - S LA7WP(LA7I,0)="Test result: "_X - ; Date value - I LA7VTYP="DT" D - . S LA7X=$$P^LA7VHLU(.LA7SEG,6,LA7FS) - . S LA7X=$$HL7TFM^XLFDT(LA7X,"L") - . S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test value: "_LA7X - ; Coded entry - I "CECM"[LA7VTYP D - . S LA7X=$P($$P^LA7VHLU(.LA7SEG,6,LA7FS),LA7CS,2) - . S LA7X=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH) - . S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test value: "_LA7X_$S(LA7UNITS]"":" "_LA7UNITS,1:"") - ; Numeric/ Structured Numeric value - I "NMSN"[LA7VTYP D - . S LA7X=$$P^LA7VHLU(.LA7SEG,6,LA7FS) - . S LA7X=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH) - . S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test value: "_LA7X_$S(LA7UNITS]"":" "_LA7UNITS,1:"") - ; String Data/ Formatted Text/ Text Data - I "FTSTX"[LA7VTYP D - . D PA^LA7VHLU(.LA7SEG,6,LA7FS,.LA7X) - . D UNESCFT^LA7VHLU3(.LA7X,LA7FS_LA7ECH,.LA7Y) - . I LA7Y=1,(($L(LA7Y(1,0))+$L(LA7UNITS))<225) S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test value: "_LA7Y(1,0)_$S(LA7UNITS]"":" "_LA7UNITS,1:"") Q - . S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test value:" - . F I=1:1:LA7Y S LA7I=LA7I+1,LA7WP(LA7I,0)=LA7Y(I,0) - . I LA7UNITS'="" S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test units: "_LA7UNITS - ; Normals/ Reference range - S LA7X=$$P^LA7VHLU(.LA7SEG,8,LA7FS) - I LA7X'="" S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test normals: "_LA7X - ; Normalcy status - S LA7X=$$P^LA7VHLU(.LA7SEG,9,LA7FS) - I LA7X'="" D - . S X=" L^ H^LL^HH^ <^ >^ N^ A^AA^ U^ D^ B^ W^ S^ R^ I^MS^VS" - . S I=$F(X,LA7X)\3,LA7X=$P($T(ABFLAGS+I^LA7VHLU1),";;",2) - . I LA7X'="" S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test normalcy status: "_LA7X - I $D(LA7WP) D WP^DIE(69.6,LA7696_",",99,"A","LA7WP","LA7DIE(99)") - Q +LA7VIN5A ;DALOI/JMC - Process Incoming UI Msgs, continued ; Jan 12, 2004 + ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64,67,72**;Sep 27, 1994 + ; This routine is a continuation of LA7VIN5. + ; It is performs processing of fields in OBX segments. + Q + ; +XFORM ; Transform the result based on fields 12,13,14,16,17 in the Chem Test + ; multiple in the Auto Instrument file (62.4), or set on the fly + ; from PARAM 1 + N LA7I + S LA7XFORM=LA76241(2) + ; + ; get PARAM 1 overides + I $D(LA7XFORM(1)),LA7XFORM(1)?1.N S $P(LA7XFORM,"^")=LA7XFORM(1) + F LA7I=2,3,5,6 I $D(LA7XFORM(LA7I)) S $P(LA7XFORM,"^",LA7I)=LA7XFORM(LA7I) + ; set up defaults if field was not answered + ; accept results,yes + I $P(LA7XFORM,"^",3)="" S $P(LA7XFORM,"^",3)=1 + ; strip spaces,no + I $P(LA7XFORM,"^",6)="" S $P(LA7XFORM,"^",6)=0 + ; now transform + ; + ; Don't accept results + I '$P(LA7XFORM,"^",3) S LA7VAL="" Q + ; + ; Only accept "FINAL" type results + I $P(LA7XFORM,"^",3)=2,"CFUX"'[LA7ORS S LA7VAL="" Q + ; + ; Accept ordered tests only + ; If LEDI interface (10) and message indicates a reflex ("G") or add-on + ; test ("A") then process anyway in case it has not been added to + ; accession. + I $P(LA7XFORM,"^",5) D + . I LA7INTYP=10,LA7SAC?1(1"A",1"G") Q + . S LA7LIMIT=1 + ; + ; Decimal places if number of places defined + I $P(LA7XFORM,"^")?1.N D JUSTDEC + ; + ; Strip spaces + I $P(LA7XFORM,"^",6) S LA7VAL=$TR(LA7VAL," ","") + ; + ; Make result a comment + ; Set value to null after making into remark, don't store twice. + I $P(LA7XFORM,"^",2) D + . N LA7Y + . ; Store comment in ^LAH global + . S LA7Y=$P(LA7RMK(0,+LA76241(0)),"^",2) + . D RMKSET^LASET(LA7LWL,LA7ISQN,LA7VAL,LA7Y) + . S LA7VAL="" + Q + ; + ; +CHKDIE ; Check if value to be stored passes input transform of field in DD + N LA7ERR,LA7Y + ; + ; If result is on a LEDI interface (type=10) then don't check result + ; against FileMan input tranform. + ; VistA sends "canc" as test result when test is cancelled. + ; DoD sends "PL Canceled" --> change to "canc" for VistA storage. + I LA7INTYP=10 D Q + . I LA7VAL="PL Cancelled" S LA7VAL="canc" + . I LA7VAL="PL Canceled" S LA7VAL="canc" + . I LA7VAL="PLCanceled" S LA7VAL="canc" + ; + ; If value fails data checker then log error and suppress result. + D CHK^DIE(LA7SUBFL,LA76304,"H",LA7VAL,.LA7Y,"LA7ERR") + I LA7Y="^" D + . N LA7X + . S LA7X=$G(LA7ERR("DIERR",1,"TEXT",1)) + . D CREATE^LA7LOG(37) + . S LA7VAL="" + Q + ; + ; +JUSTDEC ; Justify to number of places specified + ; + N LA7DDTYP,LA7FMT,LA7I,LA7PRFIX,LA7X + ; + ; If LEDI interface (type=10) then skip decimal adjustment + I LA7INTYP=10 Q + ; + ; Get data name field type from DD + ; Only justify if Vista field is numeric or free text. + S LA7DDTYP=$$GET1^DID(LA7SUBFL,LA76304,"","TYPE") + I "NUMERIC^FREE TEXT"'[LA7DDTYP D Q + . N LA7FLDNM + . S LA7FLDNM=$$GET1^DID(63.04,LA76304,"","LABEL") + . D CREATE^LA7LOG(38) + ; + S LA7X=LA7VAL,(LA7FMT,LA7PRFIX)="" + ; + ; If comma formatted, strip comma and set flag to add back in. + S LA7X=$TR(LA7X,",","") + I LA7X'=LA7VAL S LA7FMT="P" + ; + ; If "<>=" formatted, strip and save to add back in. + F LA7I=1:1:$L(LA7X) Q:$E(LA7X,LA7I)'?1(1"<",1">",1"=") + I LA7I>1 D + . S LA7PRFIX=$E(LA7X,1,LA7I-1) + . S LA7X=$E(LA7X,LA7I,$L(LA7X)) + ; + ; Format if starts with number or decimal point, skip other results. + I LA7X?1(1.N,.N1"."1.N) D + . S LA7X=$FN(LA7X,LA7FMT,+LA7XFORM) + . S LA7VAL=LA7PRFIX_LA7X + Q + ; + ; +PRDID(LA7PRDID,LA7SFAC,LA7CS) ; Process/Store Producer's ID + ; Store where test was performed. + ; Call with LA7PRDID = Producer's ID field + ; LA7SFAC = sending facility + ; LA7CS = component encoding character + ; + N LA74,LA7I,LA7X,LA7Y + ; + S LA7X=$P(LA7PRDID,LA7CS,2),LA74="" + ; + F LA7I=1,4 D Q:LA74 + . I $P(LA7PRDID,LA7CS,LA7I+2)="99VA4" S LA74=$$LKUP^XUAF4($P(LA7PRDID,LA7CS,LA7I)) + . I 'LA74 S LA74=$$LKUP^XUAF4($P(LA7PRDID,LA7CS,LA7I+1)) + . I 'LA74 S LA74=$$FINDSITE^LA7VHLU2($P(LA7PRDID,LA7CS),1,1) + . I 'LA74 S LA74=$$FINDSITE^LA7VHLU2($P(LA7SFAC,LA7CS),1,1) + ; + ; Store producer's id in LAH global with results. + I LA74 S $P(^LAH(LA7LWL,1,LA7ISQN,LA76304),"^",9)=LA74 Q + ; + ; Don't store producer's id as comment. + I '$P(LA76241(2),"^",9) Q + ; If unable to identify producer in file #4 + ; then store as comment if field STORE PRODUCER'S ID (#20) enabled. + I LA7X="" Q + S LA7Y=$P(LA7RMK(0,+LA76241(0)),"^",2) + S LA7X=$S(LA7Y="":"P",1:"p")_"erformed by "_LA7X + D RMKSET^LASET(LA7LWL,LA7ISQN,LA7X,LA7Y) + ; + Q + ; + ; +REFRNG(LA7X) ; Process/Store References Range. + ; Call with LA7X = reference range to store. + ; + N LA7Y,X,Y + ; + ; Check if site does not want to store reference ranges on POC test. + I LA7INTYP>19,LA7INTYP<30,+$P(LA76241(2),"^",10)=0 Q + ; + ; Remove leading and trailing quotes from reference range. + S LA7X=$$TRIM^XLFSTR($G(LA7X),"RL","""") + I LA7X="" Q + ; + S X=$P($G(^LAH(LA7LWL,1,LA7ISQN,LA76304)),"^",5) + ; + ; >lower limit (no upper limit e.g. >10) - store as low value + I LA7X?1">".N.1".".N S $P(X,"!",2)=$TR(LA7X,">",""),LA7X="" + ; + ; 19,LA7INTYP<30,LA7Y="",LA7X'="" D + . S X=" L^ H^LL^HH^ <^ >^ N^ A^AA^ U^ D^ B^ W^ S^ R^ I^MS^VS" + . S I=$F(X,LA7X)\3 + . S LA7Y="normalcy status - "_$P($T(ABFLAGS+I^LA7VHLU1),";;",2) + . D RMKSET^LASET(LA7LWL,LA7ISQN,LA7Y,$P(LA7RMK(0,+LA76241(0)),"^",2)) + ; + Q + ; + ; +EII ; Store equipment instance identifier in LAH global with results. + ; + N I,LA7X,X + ; + S LA7X="" + F I=1:1:4 D + . S X=$P(LA7EII,LA7CS,I) + . I X="" Q + . S $P(LA7X,"!",I)=$TR(X,"!","~") + I LA7X'="" S $P(^LAH(LA7LWL,1,LA7ISQN,LA76304),"^",11)=LA7X + Q + ; + ; +ORESULTS ; Process results that accompany order (ORM) messages + ; + N I,LA764,LA7DIE,LA7ERR,LA7I,LA7WP,LA7X,LA7Y,X + S LA7WP(1,0)=" ",LA7I=2,X="" + I LA7RLNC S X="[LOINC "_$$GET1^DIQ(95.3,LA7RLNC_",",.01)_"] "_$$GET1^DIQ(95.3,LA7RLNC_",",80) + I 'LA7RLNC,LA7RNLT D + . S LA764=$$FIND1^DIC(64,"","X",LA7RNLT,"E","","LA7ERR") + . I 'LA764 S LA7RNLT="" Q + . S X="[NLT "_$$GET1^DIQ(64,LA764_",",1)_"] "_$$GET1^DIQ(64,LA764_",",.01,"I") + I 'LA7RLNC,'LA7RNLT D + . I LA7TEST(0)]""!(LA7TEST]"") S X="["_LA7TEST(0,1)_" "_LA7TEST_"] "_LA7TEST(0) Q + . S X="["_LA7TEST(2,1)_" "_LA7TEST(2)_"] "_LA7TEST(2,0) + S LA7WP(LA7I,0)="Test result: "_X + ; Date value + I LA7VTYP="DT" D + . S LA7X=$$P^LA7VHLU(.LA7SEG,6,LA7FS) + . S LA7X=$$HL7TFM^XLFDT(LA7X,"L") + . S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test value: "_LA7X + ; Coded entry + I "CECM"[LA7VTYP D + . S LA7X=$P($$P^LA7VHLU(.LA7SEG,6,LA7FS),LA7CS,2) + . S LA7X=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH) + . S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test value: "_LA7X_$S(LA7UNITS]"":" "_LA7UNITS,1:"") + ; Numeric/ Structured Numeric value + I "NMSN"[LA7VTYP D + . S LA7X=$$P^LA7VHLU(.LA7SEG,6,LA7FS) + . S LA7X=$$UNESC^LA7VHLU3(LA7X,LA7FS_LA7ECH) + . S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test value: "_LA7X_$S(LA7UNITS]"":" "_LA7UNITS,1:"") + ; String Data/ Formatted Text/ Text Data + I "FTSTX"[LA7VTYP D + . D PA^LA7VHLU(.LA7SEG,6,LA7FS,.LA7X) + . D UNESCFT^LA7VHLU3(.LA7X,LA7FS_LA7ECH,.LA7Y) + . I LA7Y=1,(($L(LA7Y(1,0))+$L(LA7UNITS))<225) S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test value: "_LA7Y(1,0)_$S(LA7UNITS]"":" "_LA7UNITS,1:"") Q + . S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test value:" + . F I=1:1:LA7Y S LA7I=LA7I+1,LA7WP(LA7I,0)=LA7Y(I,0) + . I LA7UNITS'="" S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test units: "_LA7UNITS + ; Normals/ Reference range + S LA7X=$$P^LA7VHLU(.LA7SEG,8,LA7FS) + I LA7X'="" S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test normals: "_LA7X + ; Normalcy status + S LA7X=$$P^LA7VHLU(.LA7SEG,9,LA7FS) + I LA7X'="" D + . S X=" L^ H^LL^HH^ <^ >^ N^ A^AA^ U^ D^ B^ W^ S^ R^ I^MS^VS" + . S I=$F(X,LA7X)\3,LA7X=$P($T(ABFLAGS+I^LA7VHLU1),";;",2) + . I LA7X'="" S LA7I=LA7I+1,LA7WP(LA7I,0)=" Test normalcy status: "_LA7X + I $D(LA7WP) D WP^DIE(69.6,LA7696_",",99,"A","LA7WP","LA7DIE(99)") + Q diff --git a/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCREQ1.m b/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCREQ1.m index 19bc96a5..d0704467 100644 --- a/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCREQ1.m +++ b/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCREQ1.m @@ -1,65 +1,58 @@ -DVBCREQ1 ;ALB/GTS-557/THM-NEW 2507 REQUEST PRINTING ; 5/25/91 11:36 AM - ;;2.7;AMIE;**19,29,126**;Apr 10, 1995;Build 8 - ; -START S PGHD="COMPENSATION AND PENSION EXAM REQUEST",ROHD="Requested by "_RONAME,PG=0 - D HDR - D SSNOUT^DVBCUTIL ;** Set the value of DVBCSSNO - W !?2,"Name: ",PNAM,?56,"SSN: ",DVBCSSNO,!?51,"C-Number: ",CNUM,!?56,"DOB: " S Y=DOB X ^DD("DD") W Y,!?2,"Address: ",ADR1,! W:ADR2]"" ?11,ADR2,! W:ADR3]"" ?11,ADR3,!! - W ?2,"City,State,Zip+4: ",?48,"Res Phone: ",HOMPHON,!?5,CITY," ",STATE," ",ZIP,?48,"Bus Phone: ",BUSPHON,! ;I IOST?1"C-".E D CRTBOT G:$D(GETOUT) EXIT ;DVBA/126 comment off this code - I $D(^DPT(DFN,.121)) I $D(DTT) D ;DVBA/126 - .Q:$P(DTT,U,9)=""!($P(DTT,U,9)="N") - .I $P(DTT,U,7)'="" Q:$P(DTT,U,7)>DT - .I $P(DTT,U,8)'="" Q:$P(DTT,U,8)
0) DO - .I $D(DVBAINSF),($D(^DVB(396.3,$P(^DVB(396.3,DA(1),5),U,1),0))) DO - ..S Y=$P(^DVB(396.3,$P(^DVB(396.3,DA(1),5),U,1),0),U,5) X ^DD("DD") - ..S TVAR(1,0)="0,0,0,0,0^Date original 2507 Reported to MAS: "_Y K Y - ..D WR^DVBAUTL4("TVAR") - ..K TVAR - S TVAR(1,0)="0,0,0,3:2,0^Selected exams: " - D WR^DVBAUTL4("TVAR") - K TVAR - D TST^DVBCUTL3 G:($D(GETOUT)) EXIT - W !!!!! I IOST?1"C-".E D CRTBOT G:$D(GETOUT) EXIT - W "Current Rated disabilities:",!! D DDIS^DVBCUTL3 G:($D(GETOUT)) EXIT - W "Other Disabilities:",!!?2,OTHDIS,!?2,OTHDIS1,!?2,OTHDIS2,!!,"General remarks:",!! - K ^UTILITY($J,"W") - I IOST?1"C-".E D CRTBOT G:$D(GETOUT) EXIT - F LINE=0:0 S LINE=$O(^DVB(396.3,DA(1),2,LINE)) Q:(LINE="")!($D(GETOUT)) S X=^(LINE,0),DIWL=1,DIWF="NW" D ^DIWP I $Y>(IOSL-7),$O(^DVB(396.3,DA(1),2,LINE))]"" D BOT D:'$D(GETOUT) HDR,RMRK - D:('$D(GETOUT)) ^DIWW - ; ** Exit TAG ** -EXIT D:('$D(GETOUT)) BOT K GETOUT,LPCNT,DVBCDX,DVBCSC,DVBCSSNO,DTT,TAD1,TAD2,TAD3,TCITY,TST,TZIP,TPHONE Q - ; -HDR S PG=PG+1 I '$D(ONE)!(($D(ONE))&(PG>1))!(IOST?1"C-".E) W @IOF - W !,"Date: ",DVBCDT(0),?(80-$L(PGHD)\2),PGHD,?71,"Page: ",PG,! S PRTDIV=$S($D(^DG(40.8,XDIV,0)):$P(^(0),U,1),1:"Unknown division") S PRTDIV="For "_PRTDIV_" Medical Center Division at "_$$SITE^DVBCUTL4 - W ?(80-$L(PRTDIV)\2),PRTDIV - W !! S Y=$P(^DVB(396.3,DA(1),0),U,22) I Y]"" S Z="*** Transferred from ",Z=Z_$S($D(^DIC(4.2,+Y,0)):$P(^(0),U,1),1:"unknown site")_" ***" W ?(80-$L(Z)\2),Z,! - W ?(80-$L(ROHD)\2),ROHD,! S RQ="Date Requested: ",Y=DTRQ X ^DD("DD") S RQ=RQ_Y W ?(80-$L(RQ)\2),RQ,! F XLN=1:1:80 W "=" - K XLN Q - ; -CRTBOT ; ** Write form number at bottom of CRT ** - I $P(^DVB(396.3,DA(1),0),U,23)="Y" W !?20,"** Claim folder review will be required **",! - F LPCNT=$Y:1:(IOSL-7) W ! - W !,"VA Form 21-2507" - D TERM^DVBCUTL3 - Q - ; -BOT I $P(^DVB(396.3,DA(1),0),U,23)="Y" W !?20,"** Claim folder review will be required **",! - I IOST?1"C-".E F LPCNT=$Y:1:(IOSL-6) W ! - I IOST'?1"C-".E F LPCNT=$Y:1:(IOSL-4) W ! - W !,"VA Form 21-2507" - I IOST?1"C-".E D TERM^DVBCUTL3 - Q - ; -RMRK W !?2,"Name: ",PNAM,?56,"SSN: ",DVBCSSNO - W ! F XLN=1:1:80 W "=" - W !!,"General remarks (continued):",!! - Q +DVBCREQ1 ;ALB/GTS-557/THM-NEW 2507 REQUEST PRINTING ; 5/25/91 11:36 AM + ;;2.7;AMIE;**19,29**;Apr 10, 1995 + ; +START S PGHD="COMPENSATION AND PENSION EXAM REQUEST",ROHD="Requested by "_RONAME,PG=0 + D HDR + D SSNOUT^DVBCUTIL ;** Set the value of DVBCSSNO + W !?2,"Name: ",PNAM,?56,"SSN: ",DVBCSSNO,!?51,"C-Number: ",CNUM,!?56,"DOB: " S Y=DOB X ^DD("DD") W Y,!?2,"Address: ",ADR1,! W:ADR2]"" ?11,ADR2,! W:ADR3]"" ?11,ADR3,!! + W !?2,"City,State,Zip+4: ",?48,"Res Phone: ",HOMPHON,!?5,CITY," ",STATE," ",ZIP,?48,"Bus Phone: ",BUSPHON,! I IOST?1"C-".E D CRTBOT G:$D(GETOUT) EXIT + W !,"Entered active service: " S Y=EOD X ^DD("DD") S:Y="" Y="Not specified" W Y,?40,"Last rating exam date: ",LREXMDT,! S Y=RAD X ^DD("DD") S:Y="" Y="Not specified" W "Released active service: " W Y,! + F LINE=1:1:80 W "=" + S TVAR(1,0)="0,0,0,2:1,0^** Priority of exam: "_PRIO + D WR^DVBAUTL4("TVAR") + K TVAR + I $D(^DVB(396.3,DA(1),5)),(+$P(^DVB(396.3,DA(1),5),U,1)>0) DO + .I $D(DVBAINSF),($D(^DVB(396.3,$P(^DVB(396.3,DA(1),5),U,1),0))) DO + ..S Y=$P(^DVB(396.3,$P(^DVB(396.3,DA(1),5),U,1),0),U,5) X ^DD("DD") + ..S TVAR(1,0)="0,0,0,0,0^Date original 2507 Reported to MAS: "_Y K Y + ..D WR^DVBAUTL4("TVAR") + ..K TVAR + S TVAR(1,0)="0,0,0,3:2,0^Selected exams: " + D WR^DVBAUTL4("TVAR") + K TVAR + D TST^DVBCUTL3 G:($D(GETOUT)) EXIT + W !!!!! I IOST?1"C-".E D CRTBOT G:$D(GETOUT) EXIT + W "Current Rated disabilities:",!! D DDIS^DVBCUTL3 G:($D(GETOUT)) EXIT + W "Other Disabilities:",!!?2,OTHDIS,!?2,OTHDIS1,!?2,OTHDIS2,!!,"General remarks:",!! + K ^UTILITY($J,"W") + I IOST?1"C-".E D CRTBOT G:$D(GETOUT) EXIT + F LINE=0:0 S LINE=$O(^DVB(396.3,DA(1),2,LINE)) Q:(LINE="")!($D(GETOUT)) S X=^(LINE,0),DIWL=1,DIWF="NW" D ^DIWP I $Y>(IOSL-7),$O(^DVB(396.3,DA(1),2,LINE))]"" D BOT D:'$D(GETOUT) HDR,RMRK + D:('$D(GETOUT)) ^DIWW + ; ** Exit TAG ** +EXIT D:('$D(GETOUT)) BOT K GETOUT,LPCNT,DVBCDX,DVBCSC,DVBCSSNO Q + ; +HDR S PG=PG+1 I '$D(ONE)!(($D(ONE))&(PG>1))!(IOST?1"C-".E) W @IOF + W !,"Date: ",DVBCDT(0),?(80-$L(PGHD)\2),PGHD,?71,"Page: ",PG,! S PRTDIV=$S($D(^DG(40.8,XDIV,0)):$P(^(0),U,1),1:"Unknown division") S PRTDIV="For "_PRTDIV_" Medical Center Division at "_$$SITE^DVBCUTL4 + W ?(80-$L(PRTDIV)\2),PRTDIV + W !! S Y=$P(^DVB(396.3,DA(1),0),U,22) I Y]"" S Z="*** Transferred from ",Z=Z_$S($D(^DIC(4.2,+Y,0)):$P(^(0),U,1),1:"unknown site")_" ***" W ?(80-$L(Z)\2),Z,! + W ?(80-$L(ROHD)\2),ROHD,! S RQ="Date Requested: ",Y=DTRQ X ^DD("DD") S RQ=RQ_Y W ?(80-$L(RQ)\2),RQ,! F XLN=1:1:80 W "=" + K XLN Q + ; +CRTBOT ; ** Write form number at bottom of CRT ** + I $P(^DVB(396.3,DA(1),0),U,23)="Y" W !?20,"** Claim folder review will be required **",! + F LPCNT=$Y:1:(IOSL-7) W ! + W !,"VA Form 21-2507" + D TERM^DVBCUTL3 + Q + ; +BOT I $P(^DVB(396.3,DA(1),0),U,23)="Y" W !?20,"** Claim folder review will be required **",! + I IOST?1"C-".E F LPCNT=$Y:1:(IOSL-6) W ! + I IOST'?1"C-".E F LPCNT=$Y:1:(IOSL-4) W ! + W !,"VA Form 21-2507" + I IOST?1"C-".E D TERM^DVBCUTL3 + Q + ; +RMRK W !?2,"Name: ",PNAM,?56,"SSN: ",DVBCSSNO + W ! F XLN=1:1:80 W "=" + W !!,"General remarks (continued):",!! + Q diff --git a/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCUTIL.m b/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCUTIL.m index 8f3a69bc..9566aedb 100644 --- a/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCUTIL.m +++ b/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCUTIL.m @@ -1,69 +1,62 @@ -DVBCUTIL ;ALB/GTS-557/THM;C&P UTILITY ROUTINE ; 4/26/91 11:16 AM - ;;2.7;AMIE;**17,126**;Apr 10, 1995;Build 8 -KILL ;common exit - D ^%ZISC I $D(FF),'$D(ZTQUEUED) W @FF,!! - K %DT,ADR1,ADR2,ADR3,BDTRQ,BUSPHON,CITY,CNDCT,CNUM,DFN,DIW,DIWF,DIWL,DIWR,DIWT,DN,DOB,DTA,DTRQ,DX,DXCOD,DXNUM,EDTRQ,HOMPHON,I,LINE,MDTRM,NAME,OTHDIS,PCT,PG,PGHD,POP,PRINT,REQN,RO,ROHD,RONAME,RQ,SC,D,DIE,ONE,DVBCNEW,LN,FEXM,PRIO,DTB - K SEX,SSN,STATE,TST,X,Y,Z,JI,JII,ZIP,JJ,KJX,D0,D1,DA,DI,DIC,DIPGM,DLAYGO,DQ,DWLW,HD,HD1,HD2,J,ONFILE,CTIM,JJ,C,DIZ,DPTSZ,STAT,JDT,JY,TSTDT,DIYS,EXAM,DR,REQDT,ELIG,INCMP,PRDSV,WARD,ADD1,ADD2,CNTY,PG,OLDDA,DIRUT,DUOUT - K DVBCCNT,TNAM,DIR,TEMP,SWITCH,EDTA,RAD,EOD,%T,STATUS,XX,XDD,OLDA,OLDA1 - K DTTRNSC,ZIP4,DVBAINSF,DTT,TAD1,TAD2,TAD3,TCITY,TST,TZIP,TPHONE - G KILL^DVBCUTL2 - ; -DICW ;used on ^DIC lookups only - W ! S TSTDT=$P(^(0),U,2),RO=$P(^(0),U,3),STAT=$P(^(0),U,18),RONAME=$S($D(^DIC(4,+RO,0)):$P(^(0),U,1),1:"Unknown RO") D DICW1 - W ! Q - ; -DICW1 F JY=0:0 S JY=$O(^DVB(396.4,"C",+Y,JY)) Q:JY="" S EXAM=$P(^DVB(396.4,+JY,0),U,3),EXAM=$S($D(^DVB(396.6,EXAM,0)):$P(^(0),U,1),1:"Unknown exam") D DICW2 - Q - ; -DICW2 W ?3,EXAM," (",$$FMTE^XLFDT(TSTDT,"5DZ")," by ",RONAME,")",! - Q - ; -VARS S DTA=^DVB(396.3,DA,0),DFN=$P(DTA,U,1),(NAME,PNAM)=$P(^DPT(DFN,0),U,1),DOB=$P(^(0),U,3),SEX=$P(^(0),U,2),SSN=$P(^(0),U,9),CNUM=$S($D(^DPT(DFN,.31)):$P(^(.31),U,3),1:"Unknown"),DTRQ=$P(DTA,U,2) - S RO=$P(DTA,U,3),FEXM=$P(DTA,U,9) S:RO="" RO=0 S RONAME=$S($D(^DIC(4,RO,0)):$P(^(0),U,1),1:"Unknown") - S REQN=$P(DTA,U,4),REQN=$S($D(^VA(200,+REQN,0)):$P(^(0),U,1),1:"Unknown"),OTHDIS=$P(DTA,U,11) I $D(^DVB(396.3,DA,1)) S OTHDIS1=$P(^(1),U,9),OTHDIS2=$P(^(1),U,10) - S ZPR=$P(DTA,U,10),PRIO=$S(ZPR="T":"Terminal",ZPR="P":"Prisoner of war",ZPR="OS":"Original SC",ZPR="ON":"Original NSC",ZPR="I":"Increase",ZPR="R":"Review",ZPR="OTR":"Other",ZPR="E":"Inadequate exam",1:"Unknown") - K DVBAINSF S:ZPR="E" DVBAINSF="" - S (ADR1,ADR2,ADR3,CITY,STATE,ZIP)="" - I $D(^DPT(DFN,.11)) S DTA=^DPT(DFN,.11),ADR1=$P(DTA,U,1),ADR2=$P(DTA,U,2),ADR3=$P(DTA,U,3),CITY=$P(DTA,U,4),ZIP=$P(DTA,U,12) S:ZIP'="" ZIP=$S($L(ZIP)>5:$E(ZIP,1,5)_"-"_$E(ZIP,6,9),1:ZIP) I ZIP="" S ZIP="No Zip" - S CITY=$S(CITY]"":CITY,1:"Unknown") S STATE=$P(DTA,U,5) I STATE]"" S STATE=$S($D(^DIC(5,STATE,0)):$P(^(0),U,1),1:"Unknown") - S (HOMPHON,BUSPHON)="Unknown" I $D(^DPT(DFN,.13)) S HOMPHON=$P(^(.13),U,1),BUSPHON=$P(^(.13),U,2) - I $D(^DPT(DFN,.121)) D ;DVBA/126 added - .S (DTT,TAD1,TAD2,TAD3,TCITY,TST,TZIP,TPHONE)="" - .S DTT=^DPT(DFN,.121) - .S TAD1=$P(DTT,U,1),TAD2=$P(DTT,U,2),TAD3=$P(DTT,U,3),TCITY=$P(DTT,U,4) - .S TZIP=$P(DTT,U,12) S:TZIP'="" TZIP=$S($L(TZIP)>5:$E(TZIP,1,5)_"-"_$E(TZIP,6,9),1:TZIP) I TZIP="" S TZIP="No Zip" - .S TCITY=$S(TCITY]"":TCITY,1:"Unknown") S TST=$P(DTT,U,5) I TST]"" S TST=$S($D(^DIC(5,TST,0)):$P(^(0),U,1),1:"Unknown") - .S TPHONE=$P(DTT,U,10) S:TPHONE="" TPHONE="Unknown" - S EDTA=$S($D(^DPT(DFN,.32)):^(.32),1:""),EOD=$P(EDTA,U,6),RAD=$P(EDTA,U,7),Y=$S($D(^DVB(396.3,DA,1)):$P(^(1),U,7),1:"") X ^DD("DD") S LREXMDT=Y - Q - ; -HDR W @FF,?(IOM-$L(HD2)\2),HD2,!!!?5,"Veteran name: ",PNAM,?45,"SSN: ",SSN,!?40,"C-NUMBER: ",CNUM,!!,"Exams on this request:",!! - S JII="" - F JIJ=0:0 S JII=$O(^TMP($J,JII)) Q:JII="" S XST=$P(^TMP($J,JII),U,1) W JII,", ",$S(XST="C":"Completed",XST="RX":"Cancelled by RO",XST="X":"Cancelled by MAS",XST="T":"Transferred",1:"Open"),", " I $X>30 W ! - Q - ; -ADDR S (ADD1,ADD2,CITY,CNTY,STATE,ZIP)="" - I $D(^DPT(DFN,.11)) S DTA=^(.11),ADD1=$P(DTA,U,1),ADD2=$P(DTA,U,2),CITY=$P(DTA,U,4),STATE=$P(DTA,U,5),ZIP=$P(DTA,U,12),CNTY=$P(DTA,U,7) - S:ZIP'="" ZIP=$S($L(ZIP)>5:$E(ZIP,1,5)_"-"_$E(ZIP,6,9),1:ZIP) - S CNTY=$S($D(^DIC(5,+STATE,1,+CNTY,0)):$P(^(0),U,1),1:"Unknown") - S STATE=$S($D(^DIC(5,+STATE,0)):$P(^(0),U,1),1:"Unknown") - W !!?0,"Address: ",?9,ADD1,! W:ADD2]"" ?9,ADD2,! W ?0,"City:",?9,CITY," ",STATE," ",ZIP,!?0,"County:",?9,CNTY,!! - S PRDSV=$S($D(^DPT(DFN,.32)):$P(^(.32),U,3),1:"") I PRDSV]"" S PRDSV=$P(^DIC(21,PRDSV,0),U,1) - W "Period of service: ",PRDSV,! - S ELIG="",INCMP=0 - W ?0,"Eligibility data:" I $D(^DPT(DFN,.36)),$P(^(.36),U,1)]"" S ELIG=$S($D(^DIC(8,+^(.36),0)):$P(^(0),U,6),1:"") - I ELIG]"",$D(^DPT(DFN,.361)),^(.361)]"" S ELIG=ELIG_" ("_$S($P(^(.361),U,1)="P":"Pend ver",$P(^(.361),U,1)="R":"Pend re-verif",$P(^(.361),U,1)="V":"Verified",1:"Not verified")_")" - I $D(^DPT(DFN,.29)),$P(^(.29),U,1)]"" S INCMP=1 - I $D(^DPT(DA,.293)),$P(^(.293),U,1)=1 S INCMP=1 - W ?19,ELIG_$S(ELIG]"":", ",1:"")_$S(INCMP=1:"Incompetent",1:""),! - Q - ; -SSNSHRT ; ** Set SSN in the Format '123 45 6789' ** - K DVBCSSNO - S DVBCSSNO=$E(SSN,1,3)_" "_$E(SSN,4,5)_" "_$E(SSN,6,9) - Q - ; -SSNOUT ; ** Set SSN in the Format '123 45 6789 (Z6789) ** - D SSNSHRT - S DVBCSSNO=DVBCSSNO_" ("_$E(PNAM)_$E(SSN,6,9)_")" - Q +DVBCUTIL ;ALB/GTS-557/THM;C&P UTILITY ROUTINE ; 4/26/91 11:16 AM + ;;2.7;AMIE;**17**;Apr 10, 1995 +KILL ;common exit + D ^%ZISC I $D(FF),'$D(ZTQUEUED) W @FF,!! + K %DT,ADR1,ADR2,ADR3,BDTRQ,BUSPHON,CITY,CNDCT,CNUM,DFN,DIW,DIWF,DIWL,DIWR,DIWT,DN,DOB,DTA,DTRQ,DX,DXCOD,DXNUM,EDTRQ,HOMPHON,I,LINE,MDTRM,NAME,OTHDIS,PCT,PG,PGHD,POP,PRINT,REQN,RO,ROHD,RONAME,RQ,SC,D,DIE,ONE,DVBCNEW,LN,FEXM,PRIO,DTB + K SEX,SSN,STATE,TST,X,Y,Z,JI,JII,ZIP,JJ,KJX,D0,D1,DA,DI,DIC,DIPGM,DLAYGO,DQ,DWLW,HD,HD1,HD2,J,ONFILE,CTIM,JJ,C,DIZ,DPTSZ,STAT,JDT,JY,TSTDT,DIYS,EXAM,DR,REQDT,ELIG,INCMP,PRDSV,WARD,ADD1,ADD2,CNTY,PG,OLDDA,DIRUT,DUOUT + K DVBCCNT,TNAM,DIR,TEMP,SWITCH,EDTA,RAD,EOD,%T,STATUS,XX,XDD,OLDA,OLDA1 + K DTTRNSC,ZIP4,DVBAINSF + G KILL^DVBCUTL2 + ; +DICW ;used on ^DIC lookups only + W ! S TSTDT=$P(^(0),U,2),RO=$P(^(0),U,3),STAT=$P(^(0),U,18),RONAME=$S($D(^DIC(4,+RO,0)):$P(^(0),U,1),1:"Unknown RO") D DICW1 + W ! Q + ; +DICW1 F JY=0:0 S JY=$O(^DVB(396.4,"C",+Y,JY)) Q:JY="" S EXAM=$P(^DVB(396.4,+JY,0),U,3),EXAM=$S($D(^DVB(396.6,EXAM,0)):$P(^(0),U,1),1:"Unknown exam") D DICW2 + Q + ; +DICW2 W ?3,EXAM," (",$$FMTE^XLFDT(TSTDT,"5DZ")," by ",RONAME,")",! + Q + ; +VARS S DTA=^DVB(396.3,DA,0),DFN=$P(DTA,U,1),(NAME,PNAM)=$P(^DPT(DFN,0),U,1),DOB=$P(^(0),U,3),SEX=$P(^(0),U,2),SSN=$P(^(0),U,9),CNUM=$S($D(^DPT(DFN,.31)):$P(^(.31),U,3),1:"Unknown"),DTRQ=$P(DTA,U,2) + S RO=$P(DTA,U,3),FEXM=$P(DTA,U,9) S:RO="" RO=0 S RONAME=$S($D(^DIC(4,RO,0)):$P(^(0),U,1),1:"Unknown") + S REQN=$P(DTA,U,4),REQN=$S($D(^VA(200,+REQN,0)):$P(^(0),U,1),1:"Unknown"),OTHDIS=$P(DTA,U,11) I $D(^DVB(396.3,DA,1)) S OTHDIS1=$P(^(1),U,9),OTHDIS2=$P(^(1),U,10) + S ZPR=$P(DTA,U,10),PRIO=$S(ZPR="T":"Terminal",ZPR="P":"Prisoner of war",ZPR="OS":"Original SC",ZPR="ON":"Original NSC",ZPR="I":"Increase",ZPR="R":"Review",ZPR="OTR":"Other",ZPR="E":"Inadequate exam",1:"Unknown") + K DVBAINSF S:ZPR="E" DVBAINSF="" + S (ADR1,ADR2,ADR3,CITY,STATE,ZIP)="" + I $D(^DPT(DFN,.11)) S DTA=^DPT(DFN,.11),ADR1=$P(DTA,U,1),ADR2=$P(DTA,U,2),ADR3=$P(DTA,U,3),CITY=$P(DTA,U,4),ZIP=$P(DTA,U,12) S:ZIP'="" ZIP=$S($L(ZIP)>5:$E(ZIP,1,5)_"-"_$E(ZIP,6,9),1:ZIP) I ZIP="" S ZIP="No Zip" + S CITY=$S(CITY]"":CITY,1:"Unknown") S STATE=$P(DTA,U,5) I STATE]"" S STATE=$S($D(^DIC(5,STATE,0)):$P(^(0),U,1),1:"Unknown") + S (HOMPHON,BUSPHON)="Unknown" I $D(^DPT(DFN,.13)) S HOMPHON=$P(^(.13),U,1),BUSPHON=$P(^(.13),U,2) + S EDTA=$S($D(^DPT(DFN,.32)):^(.32),1:""),EOD=$P(EDTA,U,6),RAD=$P(EDTA,U,7),Y=$S($D(^DVB(396.3,DA,1)):$P(^(1),U,7),1:"") X ^DD("DD") S LREXMDT=Y + Q + ; +HDR W @FF,?(IOM-$L(HD2)\2),HD2,!!!?5,"Veteran name: ",PNAM,?45,"SSN: ",SSN,!?40,"C-NUMBER: ",CNUM,!!,"Exams on this request:",!! + S JII="" + F JIJ=0:0 S JII=$O(^TMP($J,JII)) Q:JII="" S XST=$P(^TMP($J,JII),U,1) W JII,", ",$S(XST="C":"Completed",XST="RX":"Cancelled by RO",XST="X":"Cancelled by MAS",XST="T":"Transferred",1:"Open"),", " I $X>30 W ! + Q + ; +ADDR S (ADD1,ADD2,CITY,CNTY,STATE,ZIP)="" + I $D(^DPT(DFN,.11)) S DTA=^(.11),ADD1=$P(DTA,U,1),ADD2=$P(DTA,U,2),CITY=$P(DTA,U,4),STATE=$P(DTA,U,5),ZIP=$P(DTA,U,12),CNTY=$P(DTA,U,7) + S:ZIP'="" ZIP=$S($L(ZIP)>5:$E(ZIP,1,5)_"-"_$E(ZIP,6,9),1:ZIP) + S CNTY=$S($D(^DIC(5,+STATE,1,+CNTY,0)):$P(^(0),U,1),1:"Unknown") + S STATE=$S($D(^DIC(5,+STATE,0)):$P(^(0),U,1),1:"Unknown") + W !!?0,"Address: ",?9,ADD1,! W:ADD2]"" ?9,ADD2,! W ?0,"City:",?9,CITY," ",STATE," ",ZIP,!?0,"County:",?9,CNTY,!! + S PRDSV=$S($D(^DPT(DFN,.32)):$P(^(.32),U,3),1:"") I PRDSV]"" S PRDSV=$P(^DIC(21,PRDSV,0),U,1) + W "Period of service: ",PRDSV,! + S ELIG="",INCMP=0 + W ?0,"Eligibility data:" I $D(^DPT(DFN,.36)),$P(^(.36),U,1)]"" S ELIG=$S($D(^DIC(8,+^(.36),0)):$P(^(0),U,6),1:"") + I ELIG]"",$D(^DPT(DFN,.361)),^(.361)]"" S ELIG=ELIG_" ("_$S($P(^(.361),U,1)="P":"Pend ver",$P(^(.361),U,1)="R":"Pend re-verif",$P(^(.361),U,1)="V":"Verified",1:"Not verified")_")" + I $D(^DPT(DFN,.29)),$P(^(.29),U,1)]"" S INCMP=1 + I $D(^DPT(DA,.293)),$P(^(.293),U,1)=1 S INCMP=1 + W ?19,ELIG_$S(ELIG]"":", ",1:"")_$S(INCMP=1:"Incompetent",1:""),! + Q + ; +SSNSHRT ; ** Set SSN in the Format '123 45 6789' ** + K DVBCSSNO + S DVBCSSNO=$E(SSN,1,3)_" "_$E(SSN,4,5)_" "_$E(SSN,6,9) + Q + ; +SSNOUT ; ** Set SSN in the Format '123 45 6789 (Z6789) ** + D SSNSHRT + S DVBCSSNO=DVBCSSNO_" ("_$E(PNAM)_$E(SSN,6,9)_")" + Q diff --git a/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBGEN1.m b/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBGEN1.m index 4f4abc4d..1fb64831 100644 --- a/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBGEN1.m +++ b/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBGEN1.m @@ -1,103 +1,102 @@ -ALPBGEN1 ;SFVAMC/JC - Parse and File HL7 PMU messages ;05/10/07 - ;;3.0;BAR CODE MED ADMIN;**8,37**;Mar 2004;Build 10 - ;;Per VHA Directive 2004-038, this routine should not be modified. - Q - ; -PARSIT ;PARSE MESSAGE ON RECEIVING SIDE - N FS,EC,CS,RS,ESC,SS,EEC,EFS,ECS,ERS,ESS,ALPBID,ALPBKY,ALPBMENU,ALPBMT,ALPBVC,DATE,DIK,DLAYGO,STF - S FS=$G(HL("FS")) I FS="" W !,"NO SEPARATOR" Q:FS="" ;Field separator - S EC=$G(HL("ECH")) Q:EC="" ;Encoding Charaters - S CS=$E(EC) ;Component separator - S RS=$E(EC,2) ;Repitition separator - S ESC=$E(EC,3) ;Escape character - S SS=$E(EC,4) ;Subcomponent separator - S EEC=ESC_"E"_ESC ;escaped escape character - S EFS=ESC_"F"_ESC ;escaped field sep - S ECS=ESC_"S"_ESC ;escaped component sep - S ERS=ESC_"R"_ESC ; escaped repitition sep - S ESS=ESC_"T"_ESC ;escaped subcomponent separator - N ALPBI,ALBPJ,ALPBX,ALPBAC,ACLPVC,ALPBSSN,ALPBERR,ALPBNAM,ALPBTRM - F X HLNEXT Q:$G(HLQUIT)'>0 D - . I $E(HLNODE,1,3)="EVN" S ALPBMT=$P(HLNODE,2) - . I $E(HLNODE,1,3)="STF" S STF=$E(HLNODE,5,9999) D PSTF - Q -PSTF ;Process STF segment - S ALPBKY=$P(STF,FS,1) Q:ALPBKY'[200_CS_"VISTA" - S ALPBID=$P(STF,FS,2) S ALPBSSN=$E(ALPBID,1,9),ALPBAC=$P(ALPBID,RS,2),ALPBVC=$P(ALPBID,RS,3) D - . S ALPBSSN=$TR(ALPBSSN,"-","") - . I ALPBAC']"" S ALERR("ACCESS")="MISSING ACCESS CODE" - . I ALPBVC']"" S ALERR("VERIFY")="MISSING VERIFY CODE" - . ;Unescape Access Code - . S ALPBAC=$$UNESC(ALPBAC) - . ;Unescape Verify Code - . S ALPBVC=$$UNESC(ALPBVC) - S ALPBNAM=$P(STF,FS,3),ALPBNAM=$P(ALPBNAM,CS,1)_","_$P(ALPBNAM,CS,2)_" "_$P(ALPBNAM,CS,3)_" "_$P(ALPBNAM,CS,4) I ALPBNAM[" " S ALPBNAM=$TR(ALPBNAM," ","") I ALPBNAM']"" S ALERR("NAME")="MISSING NAME" - I $D(ALERR) G PERR - S ALPBDIS=$S($P(STF,FS,7)="I":1,1:0) - I $P(STF,FS,13)]"" S ALPBTRM=$$HL7TFM^XLFDT($P(STF,FS,13),"L") -FILE ;Store File 200 data on backup system - N Y,DIC,DIE,DA,DR - Q:'$D(ALPBNAM) - Q:$L(ALPBSSN)'=9 - ;Try exact SSn lookup first - K Y S DIC="^VA(200,",DIC(0)="X",X=ALPBSSN,D="SSN" D IX^DIC - ;S DLAYGO=200,DIC="^VA(200,",DIC(0)="LM",X=ALPBNAM D ^DIC K DIC,DA,DR - ;If SSN lookup fails, try name lookup and add - I +Y<1 S DLAYGO=200,DIC="^VA(200,",DIC(0)="LM",X=ALPBNAM D ^DIC K DIC,DA,DR - I +Y>0 S (ALPBDA,DA,DUZ)=+Y S ALPBMENU=$O(^DIC(19,"B","PSB BCBU WRKSTN MAIN",0)) D - . S DIE="^VA(200,",DR="2////^S X=ALPBAC" - . ;Update name too - . S DR=DR_";.01////^S X=ALPBNAM" - . I ALPBDIS]"" S DR=DR_";7////^S X=ALPBDIS" - . I ALPBSSN]"",$L(ALPBSSN)=9 S DR=DR_";9////^S X=ALPBSSN" - . I ALPBVC]"" S DR=DR_";11////^S X=ALPBVC" - . I +ALPBMENU S DR=DR_";201////^S X=ALPBMENU" - . I $G(ALPBTRM)]"" S DR=DR_";9.2////^S X=ALPBTRM" - . I $G(DR)]"" D ^DIE K DIC,DA,DR S DIK=DIE,DA=ALPBDA D IX1^DIK - K ALPBDA,HL,ALPBDIS,ALPBI,ALBPJ,ALPBX,ALPBAC,ACLPVC,ALPBSSN,ALERR,ALPBNAM,ALPBTRM - Q -UNESC(ST,PR) ;Unescape string from message - ;ST=String to translate - ;PR=Event Protocol to set up HL array variables (optional) - ;First, do the escape character - I $G(ST)="" Q "" - S PR=$G(PR) I PR]"" D INIT^HLFNC2(PR,.HL) - I '$D(HL) D - . S HL("FS")="^" - . S HL("ECH")="~|\&" - S FS=$G(HL("FS")) I FS="" Q "" ;Field separator - S EC=$G(HL("ECH")) I EC="" Q "" ;Encoding Charaters - S CS=$E(EC) ;Component separator - S RS=$E(EC,2) ;Repitition separator - S ESC=$E(EC,3) ;Escape character - S SS=$E(EC,4) ;Subcomponent separator - S EEC=ESC_"E"_ESC ;escaped escape character - S EFS=ESC_"F"_ESC ;escaped field sep - S ECS=ESC_"S"_ESC ;escaped component sep - S ERS=ESC_"R"_ESC ; escaped repitition sep - S ESS=ESC_"T"_ESC ;escaped subcomponent separator - K I,J,K,L,X F S X=$F(ST,EEC) S:X I=$G(I)+1,K(I)=$E(ST,1,X-1),ST=$E(ST,X,999) S:'X K($G(I)+1)=ST Q:'X - S I=0 F S I=$O(K(I)) Q:I<1 S:K(I)[EEC K(I)=$P(K(I),EEC)_ESC S L=$G(L)_K(I) - I $G(L)]"" S ST=L - ; - K I,J,K,L,X F S X=$F(ST,EFS) S:X I=$G(I)+1,K(I)=$E(ST,1,X-1),ST=$E(ST,X,999) S:'X K($G(I)+1)=ST Q:'X - S I=0 F S I=$O(K(I)) Q:I<1 S:K(I)[EFS K(I)=$P(K(I),EFS)_FS S L=$G(L)_K(I) - I $G(L)]"" S ST=L - ; - K I,J,K,L,X S I=0 F S X=$F(ST,ECS) S:X I=$G(I)+1,K(I)=$E(ST,1,X-1),ST=$E(ST,X,999) S:'X K(I+1)=ST Q:'X - S I=0 F S I=$O(K(I)) Q:I<1 S:K(I)[ECS K(I)=$P(K(I),ECS)_CS S L=$G(L)_K(I) - I $G(L)]"" S ST=L - ; - K I,J,K,L,X S I=0 F S X=$F(ST,ERS) S:X I=$G(I)+1,K(I)=$E(ST,1,X-1),ST=$E(ST,X,999) S:'X K(I+1)=ST Q:'X - S I=0 F S I=$O(K(I)) Q:I<1 S:K(I)[ERS K(I)=$P(K(I),ERS)_RS S L=$G(L)_K(I) - I $G(L)]"" S ST=L - ; - K I,J,K,L,X S I=0 F S X=$F(ST,ESS) S:X I=$G(I)+1,K(I)=$E(ST,1,X-1),ST=$E(ST,X,999) S:'X K(I+1)=ST Q:'X - S I=0 F S I=$O(K(I)) Q:I<1 S:K(I)[ESS K(I)=$P(K(I),ESS)_SS S L=$G(L)_K(I) - I $G(L)]"" S ST=L - K I,J,K,L,X - Q ST -PERR ;PROCESSING ERRORS - H 1 S DATE=$$NOW^XLFDT M ^TMP("BCBU",$J,$S($G(ALPBSSN)'="":ALPBSSN,1:0),DATE)=ALERR - K ALERR - Q +ALPBGEN1 ;SFVAMC/JC - Parse and File HL7 PMU messages ;04/30/2003 07:59 + ;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004 + Q + ; +PARSIT ;PARSE MESSAGE ON RECEIVING SIDE + N FS,EC,CS,RS,ESC,SS,EEC,EFS,ECS,ERS,ESS,ALPBID,ALPBKY,ALPBMENU,ALPBMT,ALPBVC,DATE,DIK,DLAYGO,STF + S FS=$G(HL("FS")) I FS="" W !,"NO SEPARATOR" Q:FS="" ;Field separator + S EC=$G(HL("ECH")) Q:EC="" ;Encoding Charaters + S CS=$E(EC) ;Component separator + S RS=$E(EC,2) ;Repitition separator + S ESC=$E(EC,3) ;Escape character + S SS=$E(EC,4) ;Subcomponent separator + S EEC=ESC_"E"_ESC ;escaped escape character + S EFS=ESC_"F"_ESC ;escaped field sep + S ECS=ESC_"S"_ESC ;escaped component sep + S ERS=ESC_"R"_ESC ; escaped repitition sep + S ESS=ESC_"T"_ESC ;escaped subcomponent separator + N ALPBI,ALBPJ,ALPBX,ALPBAC,ACLPVC,ALPBSSN,ALPBERR,ALPBNAM,ALPBTRM + F X HLNEXT Q:$G(HLQUIT)'>0 D + . I $E(HLNODE,1,3)="EVN" S ALPBMT=$P(HLNODE,2) + . I $E(HLNODE,1,3)="STF" S STF=$E(HLNODE,5,9999) D PSTF + Q +PSTF ;Process STF segment + S ALPBKY=$P(STF,FS,1) Q:ALPBKY'[200_CS_"VISTA" + S ALPBID=$P(STF,FS,2) S ALPBSSN=$E(ALPBID,1,9),ALPBAC=$P(ALPBID,RS,2),ALPBVC=$P(ALPBID,RS,3) D + . S ALPBSSN=$TR(ALPBSSN,"-","") + . I ALPBAC']"" S ALERR("ACCESS")="MISSING ACCESS CODE" + . I ALPBVC']"" S ALERR("VERIFY")="MISSING VERIFY CODE" + . ;Unescape Access Code + . S ALPBAC=$$UNESC(ALPBAC) + . ;Unescape Verify Code + . S ALPBVC=$$UNESC(ALPBVC) + S ALPBNAM=$P(STF,FS,3),ALPBNAM=$P(ALPBNAM,CS,1)_","_$P(ALPBNAM,CS,2)_" "_$P(ALPBNAM,CS,3)_" "_$P(ALPBNAM,CS,4) I ALPBNAM[" " S ALPBNAM=$TR(ALPBNAM," ","") I ALPBNAM']"" S ALERR("NAME")="MISSING NAME" + I $D(ALERR) G PERR + S ALPBDIS=$S($P(STF,FS,7)="I":1,1:0) + I $P(STF,FS,13)]"" S ALPBTRM=$$HL7TFM^XLFDT($P(STF,FS,13),"L") +FILE ;Store File 200 data on backup system + N Y,DIC,DIE,DA,DR + Q:'$D(ALPBNAM) + Q:$L(ALPBSSN)'=9 + ;Try exact SSn lookup first + K Y S DIC="^VA(200,",DIC(0)="X",X=ALPBSSN,D="SSN" D IX^DIC + ;S DLAYGO=200,DIC="^VA(200,",DIC(0)="LM",X=ALPBNAM D ^DIC K DIC,DA,DR + ;If SSN lookup fails, try name lookup and add + I +Y<1 S DLAYGO=200,DIC="^VA(200,",DIC(0)="LM",X=ALPBNAM D ^DIC K DIC,DA,DR + I +Y>0 S (ALPBDA,DA)=+Y S ALPBMENU=$O(^DIC(19,"B","PSB BCBU WRKSTN MAIN",0)) D + . S DIE="^VA(200,",DR="2////^S X=ALPBAC" + . ;Update name too + . S DR=DR_";.01////^S X=ALPBNAM" + . I ALPBDIS]"" S DR=DR_";7////^S X=ALPBDIS" + . I ALPBSSN]"",$L(ALPBSSN)=9 S DR=DR_";9////^S X=ALPBSSN" + . I ALPBVC]"" S DR=DR_";11////^S X=ALPBVC" + . I +ALPBMENU S DR=DR_";201////^S X=ALPBMENU" + . I $G(ALPBTRM)]"" S DR=DR_";9.2////^S X=ALPBTRM" + . I $G(DR)]"" D ^DIE K DIC,DA,DR S DIK=DIE,DA=ALPBDA D IX1^DIK + K ALPBDA,HL,ALPBDIS,ALPBI,ALBPJ,ALPBX,ALPBAC,ACLPVC,ALPBSSN,ALERR,ALPBNAM,ALPBTRM + Q +UNESC(ST,PR) ;Unescape string from message + ;ST=String to translate + ;PR=Event Protocol to set up HL array variables (optional) + ;First, do the escape character + I $G(ST)="" Q "" + S PR=$G(PR) I PR]"" D INIT^HLFNC2(PR,.HL) + I '$D(HL) D + . S HL("FS")="^" + . S HL("ECH")="~|\&" + S FS=$G(HL("FS")) I FS="" Q "" ;Field separator + S EC=$G(HL("ECH")) I EC="" Q "" ;Encoding Charaters + S CS=$E(EC) ;Component separator + S RS=$E(EC,2) ;Repitition separator + S ESC=$E(EC,3) ;Escape character + S SS=$E(EC,4) ;Subcomponent separator + S EEC=ESC_"E"_ESC ;escaped escape character + S EFS=ESC_"F"_ESC ;escaped field sep + S ECS=ESC_"S"_ESC ;escaped component sep + S ERS=ESC_"R"_ESC ; escaped repitition sep + S ESS=ESC_"T"_ESC ;escaped subcomponent separator + K I,J,K,L,X F S X=$F(ST,EEC) S:X I=$G(I)+1,K(I)=$E(ST,1,X-1),ST=$E(ST,X,999) S:'X K($G(I)+1)=ST Q:'X + S I=0 F S I=$O(K(I)) Q:I<1 S:K(I)[EEC K(I)=$P(K(I),EEC)_ESC S L=$G(L)_K(I) + I $G(L)]"" S ST=L + ; + K I,J,K,L,X F S X=$F(ST,EFS) S:X I=$G(I)+1,K(I)=$E(ST,1,X-1),ST=$E(ST,X,999) S:'X K($G(I)+1)=ST Q:'X + S I=0 F S I=$O(K(I)) Q:I<1 S:K(I)[EFS K(I)=$P(K(I),EFS)_FS S L=$G(L)_K(I) + I $G(L)]"" S ST=L + ; + K I,J,K,L,X S I=0 F S X=$F(ST,ECS) S:X I=$G(I)+1,K(I)=$E(ST,1,X-1),ST=$E(ST,X,999) S:'X K(I+1)=ST Q:'X + S I=0 F S I=$O(K(I)) Q:I<1 S:K(I)[ECS K(I)=$P(K(I),ECS)_CS S L=$G(L)_K(I) + I $G(L)]"" S ST=L + ; + K I,J,K,L,X S I=0 F S X=$F(ST,ERS) S:X I=$G(I)+1,K(I)=$E(ST,1,X-1),ST=$E(ST,X,999) S:'X K(I+1)=ST Q:'X + S I=0 F S I=$O(K(I)) Q:I<1 S:K(I)[ERS K(I)=$P(K(I),ERS)_RS S L=$G(L)_K(I) + I $G(L)]"" S ST=L + ; + K I,J,K,L,X S I=0 F S X=$F(ST,ESS) S:X I=$G(I)+1,K(I)=$E(ST,1,X-1),ST=$E(ST,X,999) S:'X K(I+1)=ST Q:'X + S I=0 F S I=$O(K(I)) Q:I<1 S:K(I)[ESS K(I)=$P(K(I),ESS)_SS S L=$G(L)_K(I) + I $G(L)]"" S ST=L + K I,J,K,L,X + Q ST +PERR ;PROCESSING ERRORS + H 1 S DATE=$$NOW^XLFDT M ^TMP("BCBU",$J,$S($G(ALPBSSN)'="":ALPBSSN,1:0),DATE)=ALERR + K ALERR + Q diff --git a/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBINP.m b/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBINP.m index ad84b8d4..671591b9 100644 --- a/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBINP.m +++ b/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBINP.m @@ -1,223 +1,221 @@ -ALPBINP ;OIFO-DALLAS/SED/KC/MW BCMA - BCBU INPT TO HL7 ;5/2/2002 - ;;3.0;BAR CODE MED ADMIN;**8,37**;May 2007;Build 10 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;This routine will intercept the HL7 message that it sent from Pharmacy - ;to CPRS to update order information. The message is then parsed and - ;repackage so it can be sent to the BCBU workstation. - ; - ; Reference/IA - ; EN^PSJBCBU/3876 - ; $$EN^VAFHLPID/263 - ; $$EN^VAFHAPV1/4512 - ; EN1^GMRADPT/10099 - ; EN^PSJBCMA1/2829 - ; -IPH(MSG) ;CAPTURE MESSAGE ARRAY FROM PHARMACY - N VAIN,ALPMSG - S ALPMSG=$S($L($G(MSG)):MSG,1:"MSG") - I '$O(@ALPMSG@(0)) Q "0^MSG^Missing Message Array" - S MSH=0 - F S MSH=$O(@ALPMSG@(MSH)) Q:MSH'>0 Q:$E(@ALPMSG@(MSH),1,3)="MSH" - I +MSH'>0 Q "0^MSG^Missing MSH Segment Bad Message" - S MSFS=$E(@ALPMSG@(MSH),4,4) - S MSCS=$E(@ALPMSG@(MSH),5,5) - S MSCH=$E(@ALPMSG@(MSH),6,6) - S MSCTR=$E(@ALPMSG@(MSH),4,8) - ;The message is confirmed to be a Pharmacy message - I $P(@ALPMSG@(MSH),MSFS,3)'="PHARMACY" Q "1^^Not a Pharmacy Message" - ;A PID and PV1 segment is required for this message - S PID=0 - F S PID=$O(@ALPMSG@(PID)) Q:PID'>0 Q:$E(@ALPMSG@(PID),1,3)="PID" - I +PID'>0 Q "0^MSG^Missing PID Segment Bad Message" - ;Also the patient must have an inpatient status - S PV1=0 - F S PV1=$O(@ALPMSG@(PV1)) Q:PV1'>0 Q:$E(@ALPMSG@(PV1),1,3)="PV1" - I +PV1'>0 Q "0^MSG^Missing PV1 Segment Bad Message" - I $P(@ALPMSG@(PV1),MSFS,3)'="I" Q "1^^Not an Inpatient Pharmacy Message" - S ORC=0 - F S ORC=$O(@ALPMSG@(ORC)) Q:ORC'>0 Q:$E(@ALPMSG@(ORC),1,3)="ORC" - I +ORC'>0 Q "0^MSG^Missing ORC Segment Bad Message" - ;RE-BUILDING THE MESSAGE FOR BCBU - S ALPDFN=$P(@ALPMSG@(PID),MSFS,4) - I +ALPDFN'>0 Q "0^MSG^Invalid or Missing Patient - PID" - S ALPORD=$P($P(@ALPMSG@(ORC),MSFS,4),MSCS,1) - I ALPORD="" Q "0^MSG^Invalid or Missing Order Number - ORC" - K ALPB - D EN^PSJBCBU(ALPDFN,ALPORD,.ALPB) -SEED ;Entry point for ^ALPBIND - N VAIN - D INIT - S SUB=0 F S SUB=$O(ALPB(SUB)) Q:'SUB D - . ;convert and move the message to the HLA array for transport - . S HLA("HLS",SUB)=$$CNV^ALPBUTL1(MSCTR,HLCTR,ALPB(SUB)) - . ;Now check for continuations - . S SUB1=0 - . F S SUB1=$O(ALPB(SUB,SUB1)) Q:'SUB1 D - . . S HLA("HLS",SUB,SUB1)=$$CNV^ALPBUTL1(MSCTR,HLCTR,ALPB(SUB,SUB1)) - . I $E(HLA("HLS",SUB),1,3)="RXE" S RXE=SUB - . I $E(HLA("HLS",SUB),1,3)="PID" S PID=SUB - . I $E(HLA("HLS",SUB),1,3)="PV1" S PV1=SUB - K HLA("HLS",MSH) - I '$D(HLA("HLS",PID)) Q "0^MSG^Missing PID Segment Bad Message" - S ALPDFN=$P($P(HLA("HLS",PID),HLFS,4),HLCS,1) - I +ALPDFN'>0 Q "0^MSG^Invalid or Missing Patient - PID" - S HLA("HLS",PID)=$$EN^VAFHLPID(ALPDFN,"2,7,8,19") - ;Fix RXE segement for Administration Type - D RXE - ;Get the Division that the patient is associated with - D PDIV - I ALPDIV="DOM",+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0 Q "0^^Screen of DOMICILIARY" - I '$D(HLL("LINKS")) Q "0^HL7^Missing HLL Links Array Division # "_ALPDIV - ;SET NEW PV1 - D NOW^%DTC - S STRING=$$EN^VAFHAPV1(ALPDFN,%,"2,3,7,18") - S HLA("HLS",PV1)=STRING - I +ORC>0 D - . S ALPST=$$STAT^ALPBUTL1($P(HLA("HLS",ORC),HLFS,6)) - . Q:ALPST="" - . S $P(HLA("HLS",ORC),HLFS,6)=$P(HLA("HLS",ORC),HLFS,6)_HLCS_ALPST - D AL1 - ;Capture message to review for testing before sending - D SEND -EXIT ;EXIT and kill - K HLA,SUB,SUB1,STRING,ALPLOC,HLCS,HLCTR,HLFS,MSCH,MSCS,MSCTR - K MSH,ORC,PID,PV1,RXE,RXR,ALPB,ALPBY,ALPBYN,ALPC,ALPDATA,ALPDFN - K ALPDT,ALPI,ALPII,ALPIV,ALPOPTS,ALPOR,ALPORD,ALPST - K ALPSTN,ALPSYM,EVENT,GMRA,GMRAL - Q ALPRSLT -INI() ;INTIAL SET UP ENTRY - G SEED -INIT ;CALL HL7 TO INITIALIZE MESSAGE VARIABLES - ;SET UP ENVIRONMENT FOR MESSAGE - K HL,HLA,HLECH,HLQ,ALPRSLT,ALPOPTS - S EVENT="PSB BCBU ORM SEND" - D INIT^HLFNC2(EVENT,.HL,1) - S HLCS=$E(HL("ECH")),HLCTR=HLFS_HL("ECH") - Q -SEND ;CALL HL7 TO TRANSMIT SINGLE MESSAGE - K ALPRSLT,ALPOPTS - D GENERATE^HLMA(EVENT,"LM",1,.ALPRSLT,"",.ALPOPTS) - Q -AL1 ;ALLERGY SEGMENT BUILD - ;The will build the ALP segment with the curent allergies - ;for the patient to be added to the message - N DFN - Q:+ALPDFN'>0 - K GMRAL - S DFN=ALPDFN - S GMRA="0^0^111" ;DEFINES WHAT ALLERGIES TO RETURN - D EN1^GMRADPT - Q:'$D(GMRAL) - S ALPI=0,ALPC=1,ALPSYM="" - F S ALPI=$O(GMRAL(ALPI)) Q:+ALPI'>0 D - . S ALPADR="" - . I $P($P(GMRAL(ALPI),U,8),";",2)="P" S ALPADR="**ADR** " - . S ALPDATA="AL1"_HLFS_ALPC_HLFS_$P(GMRAL(ALPI),U,7) - . S ALPDATA=ALPDATA_HLFS_ALPI_HLCS_ALPADR_$E($P(GMRAL(ALPI),U,2),1,25)_HLCS_"VA120.8" - . ;S ALPII=0 F S ALPII=$O(GMRAL(ALPI,"S",ALPII)) Q:+ALPII'>0 D - . ;. S ALPSYM=ALPSYM_$P(GMRAL(ALPI,"S",ALPII),";",1)_HLCS - . ;S $P(ALPDATA,HLFS,6)=ALPSYM - . S HLA("HLS",$O(HLA("HLS",9999999),-1)+1)=ALPDATA - . S ALPC=ALPC+1 - K GMRAL - Q -RXE ; - Q:+$G(RXE)'>0 - K ^TMP("PSJ1",$J) - Q:'$D(HLA("HLS",RXE)) - S DATA=HLA("HLS",RXE) - D EN^PSJBCMA1(ALPDFN,ALPORD,1) - S TYP=$P($G(^TMP("PSJ1",$J,4)),U,2) - Q:TYP="CONTINUOUS" - Q:TYP="FILL ON REQUEST" - S ALP1=$P(DATA,HLFS,2),ALP2=$P(ALP1,HLCS,2) - I ALP1[TYP Q - I ALP2[TYP Q - S $P(ALP2,"&",1)=$P(ALP2,"&",1)_" "_TYP - S $P(ALP1,HLCS,2)=ALP2,$P(DATA,HLFS,2)=ALP1 - S HLA("HLS",RXE)=DATA - K TYP,ALP1,ALP2,^TMP("PSJ1",$J) - Q -PDIV ;PATIENT DIVISION - ;Check ALPBMDT Variable - S:+$G(ALPBMDT)'>0 ALPBMDT=0 - S ALPDIV=$$DIV^ALPBUTL1(ALPDFN,ALPBMDT) - ;Screen Dom - I ALPDIV="DOM",+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0 Q - ;Now do I send the Message or not Based of Division - I $D(ALPHLL("LINKS")) M HLL("LINKS")=ALPHLL("LINKS") - I '$D(HLL("LINKS")) D GET^ALPBPARM(.HLL,ALPDIV) - Q -MEDL(ALPML) ;Use this entry to send MedLog messages - N VAIN - ;ALPML is the IEN of the MedLog for file #53.79 - I '$D(ALPML) Q "0^ALPML^No Med-Log Number" - I '$D(^PSB(53.79,ALPML,0)) Q "0^"_ALPML_"^Med - Log Number Invalid" - ;First get the required HL7 Variables - D INIT - ;Need to build the PID, PV1 and ORC segments - S ALPDFN=+$P($G(^PSB(53.79,ALPML,0)),U,1) - I +ALPDFN'>0 Q "0^"_ALPML_"^Invalid or Missing Patient - Med-Log" - ;Get the Division that the patient is associated with - D PDIV - I ALPDIV="DOM",+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0 Q "0^^Screen of DOMICILIARY" - I '$D(HLL("LINKS")) Q "0^"_ALPML_"^Missing HLL Links Array Med-Log" - S ALPST=$P($G(^PSB(53.79,ALPML,0)),U,9) - S ALPBY=$P($G(^PSB(53.79,ALPML,0)),U,7) - S ALPDT=$P($G(^PSB(53.79,ALPML,0)),U,6) - S ALPOR=$P($G(^PSB(53.79,ALPML,.1)),U,1) - S ALPBYN=$P($G(^VA(200,ALPBY,0)),U,1) - S ALPSTN=$S($D(ALPST):$$EXTERNAL^DILFD(53.79,".09",,ALPST),1:"Non") - I '$D(ALPOR) Q "0^"_ALPML_"^Invalid or Missing Pharmacy Order Number Med-Log" - S PID=$$EN^VAFHLPID(ALPDFN,"2,7,8,19") - I '$D(PID) Q "0^"_ALPML_"^Invalid or Missing Patient - PID Med-Log" - S PV1=$$EN^VAFHAPV1(ALPDFN,DT,"2,3,7,18") - I '$D(PV1) Q "0^"_ALPML_"^Invalid or Missing Patient Location - PV1 Med-Log" - S HLA("HLS",1)=PID - S HLA("HLS",2)=PV1 - ;BUILD ORC SEGMENT - S ORC="ORC"_HLFS_"ML"_HLFS_ALPML_HLCS_"ML"_HLFS_ALPOR_HLCS_"PS"_HLFS - S ORC=ORC_HLFS_ALPST_HLCS_ALPSTN_HLFS_HLFS_HLFS_HLFS - S ORC=ORC_$$HLDATE^HLFNC(ALPDT,"TS")_HLFS_ALPBY_HLCS_ALPBYN - S HLA("HLS",3)=ORC - ;The Message is ready to send - D SEND - Q ALPRSLT - ; -ADMQ ;Need to que a single patient init for admissions - S ALDFN=ALPDFN - S ZTDTH=$$NOW^XLFDT - S ZTRTN="PAT^ALPBIND" - S ZTDESC="PSB - Initialize Single Patient on Admission Contingency Workstation" - S ZTIO="",ZTSAVE("ALDFN")="" - D ^%ZTLOAD - K ZTIO,ZTDESC,ZTRTN,ZTSK - Q -PMOV(ALPDFN,ALPTYP,ALPTT,ALPBMDT) ;Entry Point to send patient movement - N VAIN - I +$G(ALPDFN)'>0 Q "0^^Missing Patient ID" - D INIT - ;Check Movement type. If not a discharge then don't pass date and time - S:$G(ALPTT)'="DISCHARGE" ALPBMDT=0 - ;Get the Division that the patient is associated with - D PDIV - I ALPDIV="DOM",+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0 Q "0^^Screen of DOMICILIARY" - I '$D(HLL("LINKS")) Q "0^"_ALPDFN_"^Missing HLL Links Array Pat-Move" - S HLA("HLS",1)=$$EN^VAFHLPID(ALPDFN,"2,7,8,19") - S HLA("HLS",2)=$$EN^VAFHAPV1(ALPDFN,DT,"2,3,7,18") - S:$G(ALPTT)="DISCHARGE" $P(HLA("HLS",2),HLFS,37)=$G(ALPTYP) - D SEND - I ALPTYP=14!(ALPTYP=41) S ALPTT="ADMISSION" ;FOR RETURN FROM ASIH - I $G(ALPTT)="ADMISSION" D ADMQ - ;SEND A DISCHARGE TO DIV SENDING ASIH - I $G(ALPTYP)[13!($G(ALPTYP)[40) D - .D INIT - .S ALPWRD=$P($G(DGPMVI(5)),U,1) ;LAST WARD - .I +ALPWRD'>0 S ALPRSLT="0^^Screen - No Ward" Q ;NO WARD - .S ALPBDIV=$P($G(^DIC(42,ALPWRD,0)),U,11) - .D GET^ALPBPARM(.HLL,ALPBDIV) - .S HLA("HLS",1)=$$EN^VAFHLPID(ALPDFN,"2,7,8,19") - .S HLA("HLS",2)=$$EN^VAFHAPV1(ALPDFN,DT,"2,3,7,18") - .S $P(HLA("HLS",2),HLFS,37)="ASIH" - .D SEND - Q ALPRSLT +ALPBINP ;OIFO-DALLAS/SED/KC/MW BCMA - BCBU INPT TO HL7 ;5/2/2002 + ;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004 + ;This routine will intercept the HL7 message that it sent from Pharmacy + ;to CPRS to update order information. The message is then parsed and + ;repackage so it can be sent to the BCBU workstation. + ; + ; Reference/IA + ; EN^PSJBCBU/3876 + ; $$EN^VAFHLPID/263 + ; $$EN^VAFHAPV1/4512 + ; EN1^GMRADPT/10099 + ; EN^PSJBCMA1/2829 + ; +IPH(MSG) ;CAPTURE MESSAGE ARRAY FROM PHARMACY + N VAIN,ALPMSG + S ALPMSG=$S($L($G(MSG)):MSG,1:"MSG") + I '$O(@ALPMSG@(0)) Q "0^MSG^Missing Message Array" + S MSH=0 + F S MSH=$O(@ALPMSG@(MSH)) Q:MSH'>0 Q:$E(@ALPMSG@(MSH),1,3)="MSH" + I +MSH'>0 Q "0^MSG^Missing MSH Segment Bad Message" + S MSFS=$E(@ALPMSG@(MSH),4,4) + S MSCS=$E(@ALPMSG@(MSH),5,5) + S MSCH=$E(@ALPMSG@(MSH),6,6) + S MSCTR=$E(@ALPMSG@(MSH),4,8) + ;The message is confirmed to be a Pharmacy message + I $P(@ALPMSG@(MSH),MSFS,3)'="PHARMACY" Q "1^^Not a Pharmacy Message" + ;A PID and PV1 segment is required for this message + S PID=0 + F S PID=$O(@ALPMSG@(PID)) Q:PID'>0 Q:$E(@ALPMSG@(PID),1,3)="PID" + I +PID'>0 Q "0^MSG^Missing PID Segment Bad Message" + ;Also the patient must have an inpatient status + S PV1=0 + F S PV1=$O(@ALPMSG@(PV1)) Q:PV1'>0 Q:$E(@ALPMSG@(PV1),1,3)="PV1" + I +PV1'>0 Q "0^MSG^Missing PV1 Segment Bad Message" + I $P(@ALPMSG@(PV1),MSFS,3)'="I" Q "1^^Not an Inpatient Pharmacy Message" + S ORC=0 + F S ORC=$O(@ALPMSG@(ORC)) Q:ORC'>0 Q:$E(@ALPMSG@(ORC),1,3)="ORC" + I +ORC'>0 Q "0^MSG^Missing ORC Segment Bad Message" + ;RE-BUILDING THE MESSAGE FOR BCBU + S ALPDFN=$P(@ALPMSG@(PID),MSFS,4) + I +ALPDFN'>0 Q "0^MSG^Invalid or Missing Patient - PID" + S ALPORD=$P($P(@ALPMSG@(ORC),MSFS,4),MSCS,1) + I ALPORD="" Q "0^MSG^Invalid or Missing Order Number - ORC" + K ALPB + D EN^PSJBCBU(ALPDFN,ALPORD,.ALPB) +SEED ;Entry point for ^ALPBIND + D INIT + S SUB=0 F S SUB=$O(ALPB(SUB)) Q:'SUB D + . ;convert and move the message to the HLA array for transport + . S HLA("HLS",SUB)=$$CNV^ALPBUTL1(MSCTR,HLCTR,ALPB(SUB)) + . ;Now check for continuations + . S SUB1=0 + . F S SUB1=$O(ALPB(SUB,SUB1)) Q:'SUB1 D + . . S HLA("HLS",SUB,SUB1)=$$CNV^ALPBUTL1(MSCTR,HLCTR,ALPB(SUB,SUB1)) + . I $E(HLA("HLS",SUB),1,3)="RXE" S RXE=SUB + . I $E(HLA("HLS",SUB),1,3)="PID" S PID=SUB + . I $E(HLA("HLS",SUB),1,3)="PV1" S PV1=SUB + K HLA("HLS",MSH) + I '$D(HLA("HLS",PID)) Q "0^MSG^Missing PID Segment Bad Message" + S ALPDFN=$P($P(HLA("HLS",PID),HLFS,4),HLCS,1) + I +ALPDFN'>0 Q "0^MSG^Invalid or Missing Patient - PID" + S HLA("HLS",PID)=$$EN^VAFHLPID(ALPDFN,"2,7,8,19") + ;Fix RXE segement for Administration Type + D RXE + ;Get the Division that the patient is associated with + D PDIV + I ALPDIV="DOM" Q "0^^Screen of DOMICILIARY" + I '$D(HLL("LINKS")) Q "0^HL7^Missing HLL Links Array Division # "_ALPDIV + ;SET NEW PV1 + D NOW^%DTC + S STRING=$$EN^VAFHAPV1(ALPDFN,%,"2,3,7,18") + S HLA("HLS",PV1)=STRING + I +ORC>0 D + . S ALPST=$$STAT^ALPBUTL1($P(HLA("HLS",ORC),HLFS,6)) + . Q:ALPST="" + . S $P(HLA("HLS",ORC),HLFS,6)=$P(HLA("HLS",ORC),HLFS,6)_HLCS_ALPST + D AL1 + ;Capture message to review for testing before sending + D SEND +EXIT ;EXIT and kill + K HLA,SUB,SUB1,STRING,ALPLOC,HLCS,HLCTR,HLFS,MSCH,MSCS,MSCTR + K MSH,ORC,PID,PV1,RXE,RXR,ALPB,ALPBY,ALPBYN,ALPC,ALPDATA,ALPDFN + K ALPDT,ALPI,ALPII,ALPIV,ALPOPTS,ALPOR,ALPORD,ALPST + K ALPSTN,ALPSYM,EVENT,GMRA,GMRAL + Q ALPRSLT +INI() ;INTIAL SET UP ENTRY + G SEED +INIT ;CALL HL7 TO INITIALIZE MESSAGE VARIABLES + ;SET UP ENVIRONMENT FOR MESSAGE + K HL,HLA,HLECH,HLQ,ALPRSLT,ALPOPTS + S EVENT="PSB BCBU ORM SEND" + D INIT^HLFNC2(EVENT,.HL,1) + S HLCS=$E(HL("ECH")),HLCTR=HLFS_HL("ECH") + Q +SEND ;CALL HL7 TO TRANSMIT SINGLE MESSAGE + K ALPRSLT,ALPOPTS + D GENERATE^HLMA(EVENT,"LM",1,.ALPRSLT,"",.ALPOPTS) + Q +AL1 ;ALLERGY SEGMENT BUILD + ;The will build the ALP segment with the curent allergies + ;for the patient to be added to the message + N DFN + Q:+ALPDFN'>0 + K GMRAL + S DFN=ALPDFN + S GMRA="0^0^111" ;DEFINES WHAT ALLERGIES TO RETURN + D EN1^GMRADPT + Q:'$D(GMRAL) + S ALPI=0,ALPC=1,ALPSYM="" + F S ALPI=$O(GMRAL(ALPI)) Q:+ALPI'>0 D + . S ALPADR="" + . I $P($P(GMRAL(ALPI),U,8),";",2)="P" S ALPADR="**ADR** " + . S ALPDATA="AL1"_HLFS_ALPC_HLFS_$P(GMRAL(ALPI),U,7) + . S ALPDATA=ALPDATA_HLFS_ALPI_HLCS_ALPADR_$E($P(GMRAL(ALPI),U,2),1,25)_HLCS_"VA120.8" + . ;S ALPII=0 F S ALPII=$O(GMRAL(ALPI,"S",ALPII)) Q:+ALPII'>0 D + . ;. S ALPSYM=ALPSYM_$P(GMRAL(ALPI,"S",ALPII),";",1)_HLCS + . ;S $P(ALPDATA,HLFS,6)=ALPSYM + . S HLA("HLS",$O(HLA("HLS",9999999),-1)+1)=ALPDATA + . S ALPC=ALPC+1 + K GMRAL + Q +RXE ; + Q:+$G(RXE)'>0 + K ^TMP("PSJ1",$J) + Q:'$D(HLA("HLS",RXE)) + S DATA=HLA("HLS",RXE) + D EN^PSJBCMA1(ALPDFN,ALPORD,1) + S TYP=$P($G(^TMP("PSJ1",$J,4)),U,2) + Q:TYP="CONTINUOUS" + Q:TYP="FILL ON REQUEST" + S ALP1=$P(DATA,HLFS,2),ALP2=$P(ALP1,HLCS,2) + I ALP1[TYP Q + I ALP2[TYP Q + S $P(ALP2,"&",1)=$P(ALP2,"&",1)_" "_TYP + S $P(ALP1,HLCS,2)=ALP2,$P(DATA,HLFS,2)=ALP1 + S HLA("HLS",RXE)=DATA + K TYP,ALP1,ALP2,^TMP("PSJ1",$J) + Q +PDIV ;PATIENT DIVISION + ;Check ALPBMDT Variable + S:+$G(ALPBMDT)'>0 ALPBMDT=0 + S ALPDIV=$$DIV^ALPBUTL1(ALPDFN,ALPBMDT) + ;Screen Dom + Q:ALPDIV="DOM" + ;Now do I send the Message or not Based of Division + I $D(ALPHLL("LINKS")) M HLL("LINKS")=ALPHLL("LINKS") + I '$D(HLL("LINKS")) D GET^ALPBPARM(.HLL,ALPDIV) + Q +MEDL(ALPML) ;Use this entry to send MedLog messages + N VAIN + ;ALPML is the IEN of the MedLog for file #53.79 + I '$D(ALPML) Q "0^ALPML^No Med-Log Number" + I '$D(^PSB(53.79,ALPML,0)) Q "0^"_ALPML_"^Med - Log Number Invalid" + ;First get the required HL7 Variables + D INIT + ;Need to build the PID, PV1 and ORC segments + S ALPDFN=+$P($G(^PSB(53.79,ALPML,0)),U,1) + I +ALPDFN'>0 Q "0^"_ALPML_"^Invalid or Missing Patient - Med-Log" + ;Get the Division that the patient is associated with + D PDIV + I ALPDIV="DOM" Q "0^^Screen of DOMICILIARY" + I '$D(HLL("LINKS")) Q "0^"_ALPML_"^Missing HLL Links Array Med-Log" + S ALPST=$P($G(^PSB(53.79,ALPML,0)),U,9) + S ALPBY=$P($G(^PSB(53.79,ALPML,0)),U,7) + S ALPDT=$P($G(^PSB(53.79,ALPML,0)),U,6) + S ALPOR=$P($G(^PSB(53.79,ALPML,.1)),U,1) + S ALPBYN=$P($G(^VA(200,ALPBY,0)),U,1) + S ALPSTN=$S($D(ALPST):$$EXTERNAL^DILFD(53.79,".09",,ALPST),1:"Non") + I '$D(ALPOR) Q "0^"_ALPML_"^Invalid or Missing Pharmacy Order Number Med-Log" + S PID=$$EN^VAFHLPID(ALPDFN,"2,7,8,19") + I '$D(PID) Q "0^"_ALPML_"^Invalid or Missing Patient - PID Med-Log" + S PV1=$$EN^VAFHAPV1(ALPDFN,DT,"2,3,7,18") + I '$D(PV1) Q "0^"_ALPML_"^Invalid or Missing Patient Location - PV1 Med-Log" + S HLA("HLS",1)=PID + S HLA("HLS",2)=PV1 + ;BUILD ORC SEGMENT + S ORC="ORC"_HLFS_"ML"_HLFS_ALPML_HLCS_"ML"_HLFS_ALPOR_HLCS_"PS"_HLFS + S ORC=ORC_HLFS_ALPST_HLCS_ALPSTN_HLFS_HLFS_HLFS_HLFS + S ORC=ORC_$$HLDATE^HLFNC(ALPDT,"TS")_HLFS_ALPBY_HLCS_ALPBYN + S HLA("HLS",3)=ORC + ;The Message is ready to send + D SEND + Q ALPRSLT + ; +ADMQ ;Need to que a single patient init for admissions + S ALDFN=ALPDFN + S ZTDTH=$$NOW^XLFDT + S ZTRTN="PAT^ALPBIND" + S ZTDESC="PSB - Initialize Single Patient on Admission Contingency Workstation" + S ZTIO="",ZTSAVE("ALDFN")="" + D ^%ZTLOAD + K ZTIO,ZTDESC,ZTRTN,ZTSK + Q +PMOV(ALPDFN,ALPTYP,ALPTT,ALPBMDT) ;Entry Point to send patient movement + N VAIN + I +$G(ALPDFN)'>0 Q "0^^Missing Patient ID" + D INIT + ;Check Movement type. If not a discharge then don't pass date and time + S:$G(ALPTT)'="DISCHARGE" ALPBMDT=0 + ;Get the Division that the patient is associated with + D PDIV + I ALPDIV="DOM" Q "0^^Screen of DOMICILIARY" + I '$D(HLL("LINKS")) Q "0^"_ALPDFN_"^Missing HLL Links Array Pat-Move" + S HLA("HLS",1)=$$EN^VAFHLPID(ALPDFN,"2,7,8,19") + S HLA("HLS",2)=$$EN^VAFHAPV1(ALPDFN,DT,"2,3,7,18") + S:$G(ALPTT)="DISCHARGE" $P(HLA("HLS",2),HLFS,37)=$G(ALPTYP) + D SEND + I ALPTYP=14!(ALPTYP=41) S ALPTT="ADMISSION" ;FOR RETURN FROM ASIH + I $G(ALPTT)="ADMISSION" D ADMQ + ;SEND A DISCHARGE TO DIV SENDING ASIH + I $G(ALPTYP)[13!($G(ALPTYP)[40) D + .D INIT + .S ALPWRD=$P($G(DGPMVI(5)),U,1) ;LAST WARD + .I +ALPWRD'>0 S ALPRSLT="0^^Screen - No Ward" Q ;NO WARD + .S ALPBDIV=$P($G(^DIC(42,ALPWRD,0)),U,11) + .D GET^ALPBPARM(.HLL,ALPBDIV) + .S HLA("HLS",1)=$$EN^VAFHLPID(ALPDFN,"2,7,8,19") + .S HLA("HLS",2)=$$EN^VAFHAPV1(ALPDFN,DT,"2,3,7,18") + .S $P(HLA("HLS",2),HLFS,37)="ASIH" + .D SEND + Q ALPRSLT diff --git a/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBPWRD.m b/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBPWRD.m index 749358c2..fc8a3594 100644 --- a/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBPWRD.m +++ b/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBPWRD.m @@ -1,201 +1,199 @@ -ALPBPWRD ;OIFO-DALLAS MW,SED,KC-PRINT 3-DAY MAR BCMA BCBU REPORT FOR A SELECTED WARD ;01/01/03 - ;;3.0;BAR CODE MED ADMIN;**8,37**;Mar 2004;Build 10 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ; NOTE: this routine is designed for hard-copy output. - ; Output is formatted for 132-column printing. - ; - F D Q:$D(DIRUT) - .W !,"Inpatient Pharmacy Orders for a selected ward" - .S DIR(0)="FAO^2:10" - .S DIR("A")="Select WARD: " - .S DIR("?")="^D WARDLIST^ALPBUTL(""C"")" - .D ^DIR K DIR - .I $D(DIRUT) Q - .D WARDSEL^ALPBUTL(Y,.ALPBSEL) - .I +$G(ALPBSEL(0))=0 D Q - ..W $C(7) - ..W " ??" - ..D WARDLIST^ALPBUTL("C") - ..K ALPBSEL - .I +$G(ALPBSEL(0))=1 D - ..S ALPBWARD=ALPBSEL(1) - ..W " ",ALPBWARD - ..K ALPBSEL - .I +$G(ALPBSEL(0))>1 D I $D(DIRUT) K DIRUT,DTOUT,X,Y Q - ..S ALPBX=0 - ..F S ALPBX=$O(ALPBSEL(ALPBX)) Q:'ALPBX W !?2,$J(ALPBX,2)," ",ALPBSEL(ALPBX) - ..K ALPBX - ..S DIR(0)="NA^1:"_ALPBSEL(0) - ..S DIR("A")="Select Ward from the list (1-"_ALPBSEL(0)_"): " - ..W ! D ^DIR K DIR - ..I $D(DIRUT) K ALPBSEL Q - ..S ALPBWARD=ALPBSEL(+Y) - ..K ALPBSEL - .; - .; get all or just current orders?... - .S DIR(0)="SA^A:ALL;C:CURRENT" - .S DIR("A")="Report [A]LL or [C]URRENT orders? " - .S DIR("B")="CURRENT" - .S DIR("?")="[A]LL=all orders in the file, [C]URRENT=orders not yet expired." - .W ! D ^DIR K DIR - .I $D(DIRUT) K ALPBWARD,DIRUT,DTOUT,X,Y Q - .S ALPBOTYP=Y - .; - .;SORT BY NAME OR ROOM/BED added 6/23/05 - .S DIR(0)="SA^N:Name;R:Room/Bed" - .S DIR("A")="Sort Patients by [N]ame or [R]oom/Bed? " - .S DIR("B")="Room/bed" - .S DIR("?")="Sort by [N]ame or [R]oom Bed" - .W ! D ^DIR K DIR - .I $D(DIRUT) K ALPBWARD,DIRUT,DTOUT,X,Y Q - .S ALPBSORT=Y - .; - .; print how many days MAR?... - .S DIR(0)="NA^1:7" - .S DIR("A")="Print how many days MAR? " - .S DIR("B")=$$DEFDAYS^ALPBUTL() - .S DIR("?")="The default is shown; you may enter 3 or 7." - .W ! D ^DIR K DIR - .I $D(DIRUT) K ALPBOTYP,DIRUT,DTOUT,X,Y Q - .S ALPBDAYS=+Y - .; - .; BCMA Med Log info for how many ?... - .S DIR(0)="NA^1:99" - .S DIR("B")=$$DEFML^ALPBUTL3() - .S DIR("A")="Select how many BCMA Medication Log history: " - .S DIR("A",1)=" " - .S DIR("?",1)="Select a number of BCMA Medication log entries" - .S DIR("?",2)="for each of the patient's orders" - .S DIR("?")="They are listed by the most current entry first" - .D ^DIR K DIR - .I $D(DIRUT) K ALPBOTYP,ALPBWARD,DIRUT,DTOUT,X,Y Q - .S ALPBMLOG=Y - .; - .S %ZIS="Q" - .S %ZIS("B")=$$DEFPRT^ALPBUTL() - .I %ZIS("B")="" K %ZIS("B") - .W ! D ^%ZIS K %ZIS - .I POP D Q - ..W $C(7) - ..K ALPBMLOG,ALPBOTYP,ALPBWARD,POP - .; - .; output not queued... - .I '$D(IO("Q")) D - ..U IO - ..D DQ - ..I IO'=IO(0) D ^%ZISC - .; - .; set up the Task... - .I $D(IO("Q")) D - ..S ZTRTN="DQ^ALPBPWRD" - ..S ZTDESC="PSB INPT PHARM ORDERS FOR WARD "_ALPBWARD - ..S ZTSAVE("ALPBDAYS")="" - ..S ZTSAVE("ALPBWARD")="" - ..S ZTSAVE("ALPBMLOG")="" - ..S ZTSAVE("ALPBOTYP")="" - ..S ZTSAVE("ALPBSORT")="" - ..S ZTIO=ION - ..D ^%ZTLOAD - ..D HOME^%ZIS - ..W !,$S($G(ZTSK):"Task number "_ZTSK_" queued.",1:"ERROR -- NOT QUEUED!") - ..K IO("Q"),ZTSK - .K ALPBDAYS,ALPBMLOG,ALPBOTYP,ALPBWARD - K DIRUT,DTOUT,X,Y - Q - ; -DQ ; output entry point... - K ^TMP($J) - ; - ; set report date... SED 11/4/03 - S ALPBRDAT=$S(ALPBOTYP="C":$$NOW^XLFDT(),1:"") - ; - ; loop through ward cross reference in 53.7... - S ALPBPTN="" - F S ALPBPTN=$O(^ALPB(53.7,"AW",ALPBWARD,ALPBPTN)) Q:ALPBPTN="" D - .S ALPBIEN=0 - .F S ALPBIEN=$O(^ALPB(53.7,"AW",ALPBWARD,ALPBPTN,ALPBIEN)) Q:'ALPBIEN D - ..D ORDS^ALPBUTL(ALPBIEN,ALPBRDAT,.ALPBORDS) - ..I +ALPBORDS(0)'>0 K ALPBORDS Q - ..I $G(ALPBPDAT(0))="" S ALPBPDAT(0)=$G(^ALPB(53.7,ALPBIEN,0)) - ..S ALPBOIEN=0 - ..F S ALPBOIEN=$O(ALPBORDS(ALPBOIEN)) Q:'ALPBOIEN D - ...S ALPBDATA=$G(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,1)) - ...S ALPBOCT=$P($G(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,3)),U,1) - ...S:$P($G(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,4)),U,3)["PRN" ALPBOCT=ALPBOCT_"P" - ...; if report is for "C"urrent, check stop date and quit if - ...; stop date is less than report date... - ...I ALPBOTYP="C"&($P(ALPBDATA,U,2)IOSL) D PAGE - ...F ALPBX=1:1:ALPBFORM(0) W !,ALPBFORM(ALPBX) - ...K ALPBDATA,ALPBFORM,ALPBOIEN,ALPBX - ..K ALPBORDN - .K ALPBOST - K ALPBOCT - ; print footer at end of this patient's record... - I $Y+10>IOSL D PAGE - W !! - D FOOT^ALPBFRMU - ;Print a blank page between patient - W @IOF - S ALPBPG=0 - K ALPBPDAT - Q - ;K ALPBIEN,ALPBPDAT KILLING ALPBIEN WILL BREAK SORT BY ROOM/BED - ; -DONE ; - K ALPBDAYS,ALPBMLOG,ALPBOTYP,ALPBPG,ALPBPTN,ALPBRDAT,ALPBWARD,^TMP($J),ALPRM,ALPRM1,ALPBD,ALPBIEN,ALPBSORT - I $D(ZTQUEUED) S ZTREQ="@" - Q - ; -PAGE ; print page header for patient... - W @IOF - S ALPBPG=ALPBPG+1 - D HDR^ALPBFRMU(.ALPBPDAT,ALPBPG,.ALPBHDR) - F ALPBX=1:1:ALPBHDR(0) W !,ALPBHDR(ALPBX) - K ALPBHDR,ALPBX - Q +ALPBPWRD ;OIFO-DALLAS MW,SED,KC-PRINT 3-DAY MAR BCMA BCBU REPORT FOR A SELECTED WARD ;01/01/03 + ;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004 + ; + ; NOTE: this routine is designed for hard-copy output. + ; Output is formatted for 132-column printing. + ; + F D Q:$D(DIRUT) + .W !,"Inpatient Pharmacy Orders for a selected ward" + .S DIR(0)="FAO^2:10" + .S DIR("A")="Select WARD: " + .S DIR("?")="^D WARDLIST^ALPBUTL(""C"")" + .D ^DIR K DIR + .I $D(DIRUT) Q + .D WARDSEL^ALPBUTL(Y,.ALPBSEL) + .I +$G(ALPBSEL(0))=0 D Q + ..W $C(7) + ..W " ??" + ..D WARDLIST^ALPBUTL("C") + ..K ALPBSEL + .I +$G(ALPBSEL(0))=1 D + ..S ALPBWARD=ALPBSEL(1) + ..W " ",ALPBWARD + ..K ALPBSEL + .I +$G(ALPBSEL(0))>1 D I $D(DIRUT) K DIRUT,DTOUT,X,Y Q + ..S ALPBX=0 + ..F S ALPBX=$O(ALPBSEL(ALPBX)) Q:'ALPBX W !?2,$J(ALPBX,2)," ",ALPBSEL(ALPBX) + ..K ALPBX + ..S DIR(0)="NA^1:"_ALPBSEL(0) + ..S DIR("A")="Select Ward from the list (1-"_ALPBSEL(0)_"): " + ..W ! D ^DIR K DIR + ..I $D(DIRUT) K ALPBSEL Q + ..S ALPBWARD=ALPBSEL(+Y) + ..K ALPBSEL + .; + .; get all or just current orders?... + .S DIR(0)="SA^A:ALL;C:CURRENT" + .S DIR("A")="Report [A]LL or [C]URRENT orders? " + .S DIR("B")="CURRENT" + .S DIR("?")="[A]LL=all orders in the file, [C]URRENT=orders not yet expired." + .W ! D ^DIR K DIR + .I $D(DIRUT) K ALPBWARD,DIRUT,DTOUT,X,Y Q + .S ALPBOTYP=Y + .; + .;SORT BY NAME OR ROOM/BED added 6/23/05 + .S DIR(0)="SA^N:Name;R:Room/Bed" + .S DIR("A")="Sort Patients by [N]ame or [R]oom/Bed? " + .S DIR("B")="Room/bed" + .S DIR("?")="Sort by [N]ame or [R]oom Bed" + .W ! D ^DIR K DIR + .I $D(DIRUT) K ALPBWARD,DIRUT,DTOUT,X,Y Q + .S ALPBSORT=Y + .; + .; print how many days MAR?... + .S DIR(0)="NA^1:7" + .S DIR("A")="Print how many days MAR? " + .S DIR("B")=$$DEFDAYS^ALPBUTL() + .S DIR("?")="The default is shown; you may enter 3 or 7." + .W ! D ^DIR K DIR + .I $D(DIRUT) K ALPBOTYP,DIRUT,DTOUT,X,Y Q + .S ALPBDAYS=+Y + .; + .; BCMA Med Log info for how many ?... + .S DIR(0)="NA^1:99" + .S DIR("B")=$$DEFML^ALPBUTL3() + .S DIR("A")="Select how many BCMA Medication Log history: " + .S DIR("A",1)=" " + .S DIR("?",1)="Select a number of BCMA Medication log entries" + .S DIR("?",2)="for each of the patient's orders" + .S DIR("?")="They are listed by the most current entry first" + .D ^DIR K DIR + .I $D(DIRUT) K ALPBOTYP,ALPBWARD,DIRUT,DTOUT,X,Y Q + .S ALPBMLOG=Y + .; + .S %ZIS="Q" + .S %ZIS("B")=$$DEFPRT^ALPBUTL() + .I %ZIS("B")="" K %ZIS("B") + .W ! D ^%ZIS K %ZIS + .I POP D Q + ..W $C(7) + ..K ALPBMLOG,ALPBOTYP,ALPBWARD,POP + .; + .; output not queued... + .I '$D(IO("Q")) D + ..U IO + ..D DQ + ..I IO'=IO(0) D ^%ZISC + .; + .; set up the Task... + .I $D(IO("Q")) D + ..S ZTRTN="DQ^ALPBPWRD" + ..S ZTDESC="PSB INPT PHARM ORDERS FOR WARD "_ALPBWARD + ..S ZTSAVE("ALPBDAYS")="" + ..S ZTSAVE("ALPBWARD")="" + ..S ZTSAVE("ALPBMLOG")="" + ..S ZTSAVE("ALPBOTYP")="" + ..S ZTSAVE("ALPBSORT")="" + ..S ZTIO=ION + ..D ^%ZTLOAD + ..D HOME^%ZIS + ..W !,$S($G(ZTSK):"Task number "_ZTSK_" queued.",1:"ERROR -- NOT QUEUED!") + ..K IO("Q"),ZTSK + .K ALPBDAYS,ALPBMLOG,ALPBOTYP,ALPBWARD + K DIRUT,DTOUT,X,Y + Q + ; +DQ ; output entry point... + K ^TMP($J) + ; + ; set report date... SED 11/4/03 + S ALPBRDAT=$S(ALPBOTYP="C":$$NOW^XLFDT(),1:"") + ; + ; loop through ward cross reference in 53.7... + S ALPBPTN="" + F S ALPBPTN=$O(^ALPB(53.7,"AW",ALPBWARD,ALPBPTN)) Q:ALPBPTN="" D + .S ALPBIEN=0 + .F S ALPBIEN=$O(^ALPB(53.7,"AW",ALPBWARD,ALPBPTN,ALPBIEN)) Q:'ALPBIEN D + ..D ORDS^ALPBUTL(ALPBIEN,ALPBRDAT,.ALPBORDS) + ..I +ALPBORDS(0)'>0 K ALPBORDS Q + ..I $G(ALPBPDAT(0))="" S ALPBPDAT(0)=$G(^ALPB(53.7,ALPBIEN,0)) + ..S ALPBOIEN=0 + ..F S ALPBOIEN=$O(ALPBORDS(ALPBOIEN)) Q:'ALPBOIEN D + ...S ALPBDATA=$G(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,1)) + ...S ALPBOCT=$P($G(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,3)),U,1) + ...S:$P($G(^ALPB(53.7,ALPBIEN,2,ALPBOIEN,4)),U,3)["PRN" ALPBOCT=ALPBOCT_"P" + ...; if report is for "C"urrent, check stop date and quit if + ...; stop date is less than report date... + ...I ALPBOTYP="C"&($P(ALPBDATA,U,2)IOSL) D PAGE + ...F ALPBX=1:1:ALPBFORM(0) W !,ALPBFORM(ALPBX) + ...K ALPBDATA,ALPBFORM,ALPBOIEN,ALPBX + ..K ALPBORDN + .K ALPBOST + K ALPBOCT + ; print footer at end of this patient's record... + I $Y+10>IOSL D PAGE + W !! + D FOOT^ALPBFRMU + ;Print a blank page between patient + W @IOF + S ALPBPG=0 + K ALPBPDAT + Q + ;K ALPBIEN,ALPBPDAT KILLING ALPBIEN WILL BREAK SORT BY ROOM/BED + ; +DONE ; + K ALPBDAYS,ALPBMLOG,ALPBOTYP,ALPBPG,ALPBPTN,ALPBRDAT,ALPBWARD,^TMP($J),ALPRM,ALPRM1,ALPBD,ALPBIEN,ALPBSORT + I $D(ZTQUEUED) S ZTREQ="@" + Q + ; +PAGE ; print page header for patient... + W @IOF + S ALPBPG=ALPBPG+1 + D HDR^ALPBFRMU(.ALPBPDAT,ALPBPG,.ALPBHDR) + F ALPBX=1:1:ALPBHDR(0) W !,ALPBHDR(ALPBX) + K ALPBHDR,ALPBX + Q diff --git a/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBUTL1.m b/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBUTL1.m index 0ac2b971..b3dbe632 100644 --- a/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBUTL1.m +++ b/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBUTL1.m @@ -1,208 +1,207 @@ -ALPBUTL1 ;OIFO-DALLAS MW,SED,KC-BCBU BACKUP REPORT FUNCTIONS AND UTILITIES ;01/01/03 - ;;3.0;BAR CODE MED ADMIN;**8,37**;Mar 2004;Build 10 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ; Reference/IA - ; INP^VADPT/10061 - ; DIC(42/10039 - ; DIC(42/2440 - ; -ERRBLD(SEG,MSG,ERR) ; build an error array for non-FileMan-related errors... - ; SEG = HL7 segment name - ; MSG = a message that will be used in the error text portion of the array (optional -- if not passed, the - ; default will be used) - ; ERR = array passed by reference in which error will be returned - ; note: code 999 is a code indicating a non-FileMan error for filing the error message in file 53.71 - S ERR("DIERR")=1 - S ERR("DIERR",1)=999 - S ERR("DIERR",1,"TEXT",1)=$S($G(MSG)'="":MSG,1:"Invalid parameter passed to "_SEG_" module in routine ALPBHL1U") - Q - ; -ERRLOG(IEN,OIEN,MSGREC,SEGNAME,SEGDATA,ERRTEXT) ; log filing errors... - ; this module logs error data in the BCMA BACKUP PARAMETERS file (53.71). These - ; errors usually occur as the result of missing or bad data passed to one of the - ; File Manager DBS calls used by this package. - ; - ; IEN = the patient's record number in file 53.7 - ; OIEN = the order number's sub-file record number in file 53.7 - ; MSGREC = the HL7 message's record number in file 772 - ; SEGNAME = the HL7 segment associated with the error (optional) - ; SEGDATA = the HL7 segment's data (optional) - ; ERRTEXT = an array passed by reference which contains the error - ; code (numeric) and the error text to be filed. It is - ; expected that this is usually the error array returned - ; from a FileMan DBS call, so the format is specific: - ; - ; ERRTEXT("DIERR",n)=error code (numeric) - ; ERRTEXT("DIERR",n,"TEXT",1)=first line of error text - ; ERRTEXT("DIERR",n,"TEXT",2)=second line of error text - ; ERRTEXT("DIERR",n,"TEXT",n)=last line of error text - ; - ; However, any error message can be passed to this module - ; as long as the above format is used. - N ALPBCODE,ALPBFERR,ALPBFILE,ALPBLOGD,ALPBN1,ALPBN2,ALPBPIEN,ALPBTEXT,ALPBX - S ALPBLOGD=$$NOW^XLFDT() - S ALPBPIEN=+$O(^ALPB(53.71,0)) - I ALPBPIEN=0 D - .S X="ONE" - .S DIC="^ALPB(53.71," - .S DIC(0)="LZ" - .S DIC("DR")="1///^S X=3" - .S DINUM=1 - .S DLAYGO=53.71 - .D FILE^DICN K DIC - .S ALPBPIEN=+Y - I ALPBPIEN'>0 Q - S ALPBN1=+$O(^ALPB(53.71,ALPBPIEN,1," "),-1)+1 - S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",.01)=ALPBLOGD - S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",1)=+$G(IEN) - S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",2)=+$G(OIEN) - S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",3)=+$G(MSGREC) - S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",3.1)=$G(SEGNAME) - S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",3.2)=$G(SEGDATA) - D UPDATE^DIE("","ALPBFILE","ALPBN1","ALPBFERR") - K ALPBFERR,ALPBFILE - S ALPBX=0 - F S ALPBX=$O(ERRTEXT("DIERR",ALPBX)) Q:'ALPBX D - .S ALPBCODE=ERRTEXT("DIERR",ALPBX) - .; file the error code... - .S ALPBN2=+$O(^ALPB(53.71,ALPBPIEN,1,ALPBN1,2," "),-1)+1 - .S ALPBFILE(53.7135,"+"_ALPBN2_","_ALPBN1_","_ALPBPIEN_",",.01)=ALPBCODE - .D UPDATE^DIE("","ALPBFILE","ALPBN2","ALPBFERR") - .K ALPBFERR,ALPBFILE - .; file the error text... - .M ALPBTEXT=ERRTEXT("DIERR",ALPBX,"TEXT") - .D WP^DIE(53.7135,ALPBN2_","_ALPBN1_","_ALPBPIEN_",",1,"","ALPBTEXT","ALPBFERR") - .;S ALPBFILE(53.7135,"+"_ALPBN2_","_ALPBN1_","_ALPBPIEN_",",1)=ALPBTEXT - .;D UPDATE^DIE("","ALPBFILE","ALPBN2","ALPBFERR") - .K ALPBCODE,ALPBFERR,ALPBFILE,ALPBN2,ALPBTEXT - Q - ; -CLEAN(IEN) ; check error log records to see if the patients' whose records - ; are noted still exist in file 53.7. if not, delete the error log - ; record(s) in file 53.71... - ; IEN = patient record number in file 53.7 - ; Note: this function is also called from DELPT^ALPBUTL when a patient's - ; record is deleted (as a result of a discharge action) from 53.7. - ; - N ALPBX,ALPBY,DA,DIK,X,Y - ; patient still has record in 53.7? if so, quit... - I $G(^ALPB(53.7,IEN,0))'="" Q - S ALPBX=0 - F S ALPBX=$O(^ALPB(53.71,"C",IEN,ALPBX)) Q:'ALPBX D - .S ALPBY=0 - .F S ALPBY=$O(^ALPB(53.71,"C",IEN,ALPBX,ALPBY)) Q:'ALPBY D - ..S DA=ALPBY - ..S DA(1)=ALPBX - ..S DIK="^ALPB(53.71,"_DA(1)_",1," - ..D ^DIK - ..K DA,DIK - .K ALPBY - K ALPBX - Q - ; -DELERR(ERRIEN) ; delete an error log entry from file 53.71... - ; ERRIEN = error log entry's internal record number - N ALPBPARM,DA,DIK,X,Y - S ALPBPARM=+$O(^ALPB(53.71,0)) - I ALPBPARM'>0 Q - S DA=ERRIEN - S DA(1)=ALPBPARM - S DIK="^ALPB(53.71,"_DA(1)_",1," - D ^DIK - Q - ; -PTLIST(LTYPE,RESULTS) ; get list of patients in file 53.7... - ; LTYPE = passed = "ALL" to list all patients or - ; = to list patients on a selected ward - ; RESULTS = an array passed by reference in which data will be returned - N ALPBDATA,ALPBIEN,ALPBPTN,ALPBX - I $G(LTYPE)="" S LTYPE="ALL" - S ALPBX=0 - I LTYPE="ALL" D - .S ALPBPTN="" - .F S ALPBPTN=$O(^ALPB(53.7,"B",ALPBPTN)) Q:ALPBPTN="" D - ..S ALPBIEN=0 - ..F S ALPBIEN=$O(^ALPB(53.7,"B",ALPBPTN,ALPBIEN)) Q:'ALPBIEN D - ...S ALPBDATA=$G(^ALPB(53.7,ALPBIEN,0)) - ...I ALPBDATA="" K ALPBDATA Q - ...S ALPBX=ALPBX+1 - ...S RESULTS(ALPBX)=ALPBPTN_"^"_$P(ALPBDATA,"^",2)_"^"_$P(ALPBDATA,"^",5)_"^"_$P(ALPBDATA,"^",6)_"^"_$P(ALPBDATA,"^",7) - ...K ALPBDATA - ..K ALPBIEN - .K ALPBPTN - I LTYPE'="ALL" D - .S ALPBPTN="" - .F S ALPBPTN=$O(^ALPB(53.7,"AW",LTYPE,ALPBPTN)) Q:ALPBPTN="" D - ..S ALPBIEN=0 - ..F S ALPBIEN=$O(^ALPB(53.7,"AW",LTYPE,ALPBPTN,ALPBIEN)) Q:'ALPBIEN D - ...S ALPBDATA=$G(^ALPB(53.7,ALPBIEN,0)) - ...I ALPBDATA="" K ALPBDATA Q - ...S ALPBX=ALPBX+1 - ...S RESULTS(ALPBX)=ALPBPTN_"^"_$P(ALPBDATA,"^",2)_"^"_$P(ALPBDATA,"^",5)_"^"_$P(ALPBDATA,"^",6)_"^"_$P(ALPBDATA,"^",7) - ...K ALPBDATA - ..K ALPBIEN - .K ALPBPTN - Q - ; -STAT(ST) ;This will return the value of a status code for pharmacy - I $G(ST)="" Q "" - I $L($T(@ST)) G @ST - Q "" -IP Q "pending" -CM Q "finished/verified by pharmacist(active)" -DC Q "discontinued" -RP Q "replaced" -HD Q "on hold" -ZE Q "expired" -ZS Q "suspended(active)" -ZU Q "un-suspended(active)" -ZX Q "unreleased" -ZZ Q "renewed" - ; -STAT2(CODE) ; convert order status code for output... - ; this function is used primarily by the workstation software - ; CODE = an order status code - ; returns printable status code - I $G(CODE)="" Q "Unknown" - I CODE="IP"!(CODE="ZX") Q "Pending" - I CODE="CM"!(CODE="ZU")!(CODE="ZZ") Q "Active" - I CODE="HD"!(CODE="ZS") Q "Hold" - I CODE="DC"!(CODE="RP")!(CODE="ZE") Q "Expired" - Q "Unknown" - ; -DIV(DFN,ALPBMDT) ;get the Division for a patient - I +$G(DFN)'>0 Q "" - N ALPBDIV,ALPWRD,VAIN,VAINDT - S:+$G(ALPBMDT)>0 VAINDT=$P(ALPBMDT,".",1) - K ALPBMDT - D INP^VADPT - S ALPWRD=$P($G(VAIN(4)),U,1) - Q:+ALPWRD'>0 "" - ;Check to see if ward is a DOMICILIARY - I $P($G(^DIC(42,ALPWRD,0)),U,3)="D",+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0 Q "DOM" - S ALPBDIV=$P($G(^DIC(42,ALPWRD,0)),U,11) - Q:+ALPBDIV'>0 "" - Q ALPBDIV - ; -CNV(A,B,X) ;CONVERT A STRING - ;This API will take a HL7 segment and convert characters - ;defined in the input - ;Example: - ;Single encoding characters can be converted such as ^ to ~ - ;or multiple encoding characters can be converted such as - ; |~^@/ to ^~|/@ - ;A is the string of HL7 encoding characters to be converted - ;B is the string of HL7 encoding characters to be converted to - ;X is te message string to be converted - I A=""!B=""!X="" Q "" - F I=1:1:$L(A) S A(I)=$E(A,I,I),A(I,1)="" - F I=1:1:$L(B) S B(I)=$E(B,I,I) - S J=0 - F S J=$O(A(J)) Q:+J'>0 D - . F I=1:1:$L(X) S:$E(X,I,I)=A(J) A(J,1)=A(J,1)_I_U - S J=0 - F S J=$O(A(J)) Q:+J'>0 D - . Q:'$D(A(J,1))!'$D(B(J)) - . F I=1:1:$L(A(J,1),U) S C=$P(A(J,1),U,I) S:+C>0 $E(X,C,C)=B(J) - Q X +ALPBUTL1 ;OIFO-DALLAS MW,SED,KC-BCBU BACKUP REPORT FUNCTIONS AND UTILITIES ;01/01/03 + ;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004 + ; + ; Reference/IA + ; INP^VADPT/10061 + ; DIC(42/10039 + ; DIC(42/2440 + ; +ERRBLD(SEG,MSG,ERR) ; build an error array for non-FileMan-related errors... + ; SEG = HL7 segment name + ; MSG = a message that will be used in the error text portion of the array (optional -- if not passed, the + ; default will be used) + ; ERR = array passed by reference in which error will be returned + ; note: code 999 is a code indicating a non-FileMan error for filing the error message in file 53.71 + S ERR("DIERR")=1 + S ERR("DIERR",1)=999 + S ERR("DIERR",1,"TEXT",1)=$S($G(MSG)'="":MSG,1:"Invalid parameter passed to "_SEG_" module in routine ALPBHL1U") + Q + ; +ERRLOG(IEN,OIEN,MSGREC,SEGNAME,SEGDATA,ERRTEXT) ; log filing errors... + ; this module logs error data in the BCMA BACKUP PARAMETERS file (53.71). These + ; errors usually occur as the result of missing or bad data passed to one of the + ; File Manager DBS calls used by this package. + ; + ; IEN = the patient's record number in file 53.7 + ; OIEN = the order number's sub-file record number in file 53.7 + ; MSGREC = the HL7 message's record number in file 772 + ; SEGNAME = the HL7 segment associated with the error (optional) + ; SEGDATA = the HL7 segment's data (optional) + ; ERRTEXT = an array passed by reference which contains the error + ; code (numeric) and the error text to be filed. It is + ; expected that this is usually the error array returned + ; from a FileMan DBS call, so the format is specific: + ; + ; ERRTEXT("DIERR",n)=error code (numeric) + ; ERRTEXT("DIERR",n,"TEXT",1)=first line of error text + ; ERRTEXT("DIERR",n,"TEXT",2)=second line of error text + ; ERRTEXT("DIERR",n,"TEXT",n)=last line of error text + ; + ; However, any error message can be passed to this module + ; as long as the above format is used. + N ALPBCODE,ALPBFERR,ALPBFILE,ALPBLOGD,ALPBN1,ALPBN2,ALPBPIEN,ALPBTEXT,ALPBX + S ALPBLOGD=$$NOW^XLFDT() + S ALPBPIEN=+$O(^ALPB(53.71,0)) + I ALPBPIEN=0 D + .S X="ONE" + .S DIC="^ALPB(53.71," + .S DIC(0)="LZ" + .S DIC("DR")="1///^S X=3" + .S DINUM=1 + .S DLAYGO=53.71 + .D FILE^DICN K DIC + .S ALPBPIEN=+Y + I ALPBPIEN'>0 Q + S ALPBN1=+$O(^ALPB(53.71,ALPBPIEN,1," "),-1)+1 + S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",.01)=ALPBLOGD + S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",1)=+$G(IEN) + S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",2)=+$G(OIEN) + S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",3)=+$G(MSGREC) + S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",3.1)=$G(SEGNAME) + S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",3.2)=$G(SEGDATA) + D UPDATE^DIE("","ALPBFILE","ALPBN1","ALPBFERR") + K ALPBFERR,ALPBFILE + S ALPBX=0 + F S ALPBX=$O(ERRTEXT("DIERR",ALPBX)) Q:'ALPBX D + .S ALPBCODE=ERRTEXT("DIERR",ALPBX) + .; file the error code... + .S ALPBN2=+$O(^ALPB(53.71,ALPBPIEN,1,ALPBN1,2," "),-1)+1 + .S ALPBFILE(53.7135,"+"_ALPBN2_","_ALPBN1_","_ALPBPIEN_",",.01)=ALPBCODE + .D UPDATE^DIE("","ALPBFILE","ALPBN2","ALPBFERR") + .K ALPBFERR,ALPBFILE + .; file the error text... + .M ALPBTEXT=ERRTEXT("DIERR",ALPBX,"TEXT") + .D WP^DIE(53.7135,ALPBN2_","_ALPBN1_","_ALPBPIEN_",",1,"","ALPBTEXT","ALPBFERR") + .;S ALPBFILE(53.7135,"+"_ALPBN2_","_ALPBN1_","_ALPBPIEN_",",1)=ALPBTEXT + .;D UPDATE^DIE("","ALPBFILE","ALPBN2","ALPBFERR") + .K ALPBCODE,ALPBFERR,ALPBFILE,ALPBN2,ALPBTEXT + Q + ; +CLEAN(IEN) ; check error log records to see if the patients' whose records + ; are noted still exist in file 53.7. if not, delete the error log + ; record(s) in file 53.71... + ; IEN = patient record number in file 53.7 + ; Note: this function is also called from DELPT^ALPBUTL when a patient's + ; record is deleted (as a result of a discharge action) from 53.7. + ; + N ALPBX,ALPBY,DA,DIK,X,Y + ; patient still has record in 53.7? if so, quit... + I $G(^ALPB(53.7,IEN,0))'="" Q + S ALPBX=0 + F S ALPBX=$O(^ALPB(53.71,"C",IEN,ALPBX)) Q:'ALPBX D + .S ALPBY=0 + .F S ALPBY=$O(^ALPB(53.71,"C",IEN,ALPBX,ALPBY)) Q:'ALPBY D + ..S DA=ALPBY + ..S DA(1)=ALPBX + ..S DIK="^ALPB(53.71,"_DA(1)_",1," + ..D ^DIK + ..K DA,DIK + .K ALPBY + K ALPBX + Q + ; +DELERR(ERRIEN) ; delete an error log entry from file 53.71... + ; ERRIEN = error log entry's internal record number + N ALPBPARM,DA,DIK,X,Y + S ALPBPARM=+$O(^ALPB(53.71,0)) + I ALPBPARM'>0 Q + S DA=ERRIEN + S DA(1)=ALPBPARM + S DIK="^ALPB(53.71,"_DA(1)_",1," + D ^DIK + Q + ; +PTLIST(LTYPE,RESULTS) ; get list of patients in file 53.7... + ; LTYPE = passed = "ALL" to list all patients or + ; = to list patients on a selected ward + ; RESULTS = an array passed by reference in which data will be returned + N ALPBDATA,ALPBIEN,ALPBPTN,ALPBX + I $G(LTYPE)="" S LTYPE="ALL" + S ALPBX=0 + I LTYPE="ALL" D + .S ALPBPTN="" + .F S ALPBPTN=$O(^ALPB(53.7,"B",ALPBPTN)) Q:ALPBPTN="" D + ..S ALPBIEN=0 + ..F S ALPBIEN=$O(^ALPB(53.7,"B",ALPBPTN,ALPBIEN)) Q:'ALPBIEN D + ...S ALPBDATA=$G(^ALPB(53.7,ALPBIEN,0)) + ...I ALPBDATA="" K ALPBDATA Q + ...S ALPBX=ALPBX+1 + ...S RESULTS(ALPBX)=ALPBPTN_"^"_$P(ALPBDATA,"^",2)_"^"_$P(ALPBDATA,"^",5)_"^"_$P(ALPBDATA,"^",6)_"^"_$P(ALPBDATA,"^",7) + ...K ALPBDATA + ..K ALPBIEN + .K ALPBPTN + I LTYPE'="ALL" D + .S ALPBPTN="" + .F S ALPBPTN=$O(^ALPB(53.7,"AW",LTYPE,ALPBPTN)) Q:ALPBPTN="" D + ..S ALPBIEN=0 + ..F S ALPBIEN=$O(^ALPB(53.7,"AW",LTYPE,ALPBPTN,ALPBIEN)) Q:'ALPBIEN D + ...S ALPBDATA=$G(^ALPB(53.7,ALPBIEN,0)) + ...I ALPBDATA="" K ALPBDATA Q + ...S ALPBX=ALPBX+1 + ...S RESULTS(ALPBX)=ALPBPTN_"^"_$P(ALPBDATA,"^",2)_"^"_$P(ALPBDATA,"^",5)_"^"_$P(ALPBDATA,"^",6)_"^"_$P(ALPBDATA,"^",7) + ...K ALPBDATA + ..K ALPBIEN + .K ALPBPTN + Q + ; +STAT(ST) ;This will return the value of a status code for pharmacy + I $G(ST)="" Q "" + I $L($T(@ST)) G @ST + Q "" +IP Q "pending" +CM Q "finished/verified by pharmacist(active)" +DC Q "discontinued" +RP Q "replaced" +HD Q "on hold" +ZE Q "expired" +ZS Q "suspended(active)" +ZU Q "un-suspended(active)" +ZX Q "unreleased" +ZZ Q "renewed" + ; +STAT2(CODE) ; convert order status code for output... + ; this function is used primarily by the workstation software + ; CODE = an order status code + ; returns printable status code + I $G(CODE)="" Q "Unknown" + I CODE="IP"!(CODE="ZX") Q "Pending" + I CODE="CM"!(CODE="ZU")!(CODE="ZZ") Q "Active" + I CODE="HD"!(CODE="ZS") Q "Hold" + I CODE="DC"!(CODE="RP")!(CODE="ZE") Q "Expired" + Q "Unknown" + ; +DIV(DFN,ALPBMDT) ;get the Division for a patient + I +$G(DFN)'>0 Q "" + N ALPBDIV,ALPWRD,VAIN,VAINDT + S:+$G(ALPBMDT)>0 VAINDT=$P(ALPBMDT,".",1) + K ALPBMDT + D INP^VADPT + S ALPWRD=$P($G(VAIN(4)),U,1) + Q:+ALPWRD'>0 "" + ;Check to see if ward is a DOMICILIARY + I $P($G(^DIC(42,ALPWRD,0)),U,3)="D" Q "DOM" + S ALPBDIV=$P($G(^DIC(42,ALPWRD,0)),U,11) + Q:+ALPBDIV'>0 "" + Q ALPBDIV + ; +CNV(A,B,X) ;CONVERT A STRING + ;This API will take a HL7 segment and convert characters + ;defined in the input + ;Example: + ;Single encoding characters can be converted such as ^ to ~ + ;or multiple encoding characters can be converted such as + ; |~^@/ to ^~|/@ + ;A is the string of HL7 encoding characters to be converted + ;B is the string of HL7 encoding characters to be converted to + ;X is te message string to be converted + I A=""!B=""!X="" Q "" + F I=1:1:$L(A) S A(I)=$E(A,I,I),A(I,1)="" + F I=1:1:$L(B) S B(I)=$E(B,I,I) + S J=0 + F S J=$O(A(J)) Q:+J'>0 D + . F I=1:1:$L(X) S:$E(X,I,I)=A(J) A(J,1)=A(J,1)_I_U + S J=0 + F S J=$O(A(J)) Q:+J'>0 D + . Q:'$D(A(J,1))!'$D(B(J)) + . F I=1:1:$L(A(J,1),U) S C=$P(A(J,1),U,I) S:+C>0 $E(X,C,C)=B(J) + Q X diff --git a/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBO.m b/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBO.m index ab14c96b..b7875bb6 100644 --- a/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBO.m +++ b/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBO.m @@ -1,194 +1,194 @@ -PSBO ;BIRMINGHAM/EFC-BCMA OUTPUTS ;Mar 2004 - ;;3.0;BAR CODE MED ADMIN;**13,32,2**;Mar 2004;Build 22 - ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified. - ; Reference/IA - ; ^DPT(/10035 - ; WARD^NURSUT5/3052 - ; EN^PSJBCMA/2828 - ; ^ORD(101.24/3429 - ; ^PSDRUG(/221 -RPC(RESULTS,PSBTYPE,PSBDFN,PSBSTRT,PSBSTOP,PSBINCL,PSBDEV,PSBSORT,PSBOI,PSBWLOC,PSBWSORT,PSBFUTR,PSBORDNM,PSBRCRI,PSBLIST) ; - ; - ; RPC: PSB REPORT - ; - ; Description: - ; Used by the client to create individual patient extracts of - ; CHUI report options to display on the client. - ; - S RESULTS=$NAME(^TMP("PSBO",$J)) - N PSBIENS,PSBRPT,PSBFDA,DIC,PSBANS - K ^TMP("PSBO",$J) S ^TMP("PSBO",$J,1)="-1^" - S DFN=PSBDFN - D NEW^PSBO1(.PSBRPT,PSBTYPE) - I +PSBRPT(0)<1 S ^TMP("PSBO",$J,1)="-1^Error: "_$P(PSBRPT(0),U,2) Q - S PSBIENS=+PSBRPT(0)_"," - S PSBSTRT(0)=$E($P(PSBSTRT,".",2)_"0000",1,4),PSBSTRT=PSBSTRT\1 - S PSBSTOP(0)=$E($P(PSBSTOP,".",2)_"0000",1,4),PSBSTOP=PSBSTOP\1 - D:$G(PSBDEV)]"" - .D NOW^%DTC - .I $P(PSBDEV,U,2)="" D VAL^DIE(53.69,PSBIENS,.06,"F",PSBDEV,"PSBRET","PSBFDA") - .I $P(PSBDEV,U,2)'="" D VAL^DIE(53.69,PSBIENS,.06,"F","`"_$P(PSBDEV,U,2),"PSBRET","PSBFDA") - .D VAL^DIE(53.69,PSBIENS,.07,"F",$S($P(PSBRCRI,U)="QD":$P(PSBRCRI,U,2),1:%),"PSBRET","PSBFDA") - D:$G(PSBOI)]"" VAL^DIE(53.69,PSBIENS,.09,"F",PSBOI,"PSBRET","PSBFDA") - S:($G(PSBSORT)']"")&(PSBTYPE'="XA") PSBSORT="P" D VAL^DIE(53.69,PSBIENS,.11,"F",PSBSORT,"PSBRET","PSBFDA") - D VAL^DIE(53.69,PSBIENS,.12,"F","`"_PSBDFN,"PSBRET","PSBFDA") - I $G(PSBWLOC)]"" S PSBFDA(53.69,PSBIENS,.13)=PSBWLOC - D:$G(PSBWSORT)]"" VAL^DIE(53.69,PSBIENS,.15,"F",PSBWSORT,"PSBRET","PSBFDA") - D VAL^DIE(53.69,PSBIENS,.16,"F",PSBSTRT,"PSBRET","PSBFDA") - D VAL^DIE(53.69,PSBIENS,.17,"F",PSBSTRT(0),"PSBRET","PSBFDA") - D VAL^DIE(53.69,PSBIENS,.18,"F",PSBSTOP,"PSBRET","PSBFDA") - D VAL^DIE(53.69,PSBIENS,.19,"F",PSBSTOP(0),"PSBRET","PSBFDA") - D:$G(PSBINCL)]"" - .D VAL^DIE(53.69,PSBIENS,.21,"F",+$P(PSBINCL,"^",1),"PSBRET","PSBFDA") - .D VAL^DIE(53.69,PSBIENS,.22,"F",+$P(PSBINCL,"^",2),"PSBRET","PSBFDA") - .D VAL^DIE(53.69,PSBIENS,.23,"F",+$P(PSBINCL,"^",3),"PSBRET","PSBFDA") - .D VAL^DIE(53.69,PSBIENS,.24,"F",+$P(PSBINCL,"^",4),"PSBRET","PSBFDA") - .D VAL^DIE(53.69,PSBIENS,.28,"F",+$P(PSBINCL,"^",5),"PSBRET","PSBFDA") - .D VAL^DIE(53.69,PSBIENS,.29,"F",+$P(PSBINCL,"^",6),"PSBRET","PSBFDA") - D:$G(PSBFUTR)]"" - .D VAL^DIE(53.69,PSBIENS,.25,"F",+$P(PSBFUTR,"^",1),"PSBRET","PSBFDA") - .D VAL^DIE(53.69,PSBIENS,.26,"F",+$P(PSBFUTR,"^",2),"PSBRET","PSBFDA") - .D VAL^DIE(53.69,PSBIENS,.27,"F",+$P(PSBFUTR,"^",3),"PSBRET","PSBFDA") - .D VAL^DIE(53.69,PSBIENS,.41,"F",+$P(PSBFUTR,"^",4),"PSBRET","PSBFDA") - .D VAL^DIE(53.69,PSBIENS,.61,"F",$TR(PSBFUTR,"^ ","~"),"PSBRET","PSBFDA") - D FILE^DIE("","PSBFDA") - I $G(PSBLIST(0),"")]"" D LIST^PSBO1(.PSBLIST) - I $G(PSBDEV)]"" D PRINT^PSBO1 S RESULTS=$NAME(^TMP("PSBO",$J)) Q - D HFSOPEN^PSBUTL("RPC") I POP S ^TMP("PSBO",$J,1)="ERROR: UNABLE TO ACCESS HFS DIRECTORY "_$$GET^XPAR("DIV","PSB HFS SCRATCH"),^TMP("PSBO",$J,2)="PLEASE CHECK DIRECTORY WRITE PRIVILEDGES." Q - U IO D DQ(+PSBIENS) - D HFSCLOSE^PSBUTL("RPC") - S RESULTS=$NAME(^TMP("PSBO",$J)) - D:$G(PSBDEV)]"" PRINT^PSBO1 - Q - ; -XQ(PSBTYPE) ; Called via Kernel Menus - N PSBANS,PSBANS1,PSBRPT,PSBSAVE,DA,DIK,DR,DDSFILE - D NEW^PSBO1(.PSBRPT,PSBTYPE) - I +PSBRPT(0)<1 W !,"Error: ",$P(PSBRPT(0),U,2) S DIR(0)="E" D ^DIR Q - S DA=+PSBRPT(0),DR="[PSBO "_PSBTYPE_"]",DDSFILE=53.69 D ^DDS - W @IOF - I 'PSBSAVE W !,"Cancelling Request..." S DIK="^PSB(53.69," D ^DIK W "Cancelled!" - D:PSBSAVE - .;Check Drug to Patient Relationship. - .I (PSBTYPE="BL")!(PSBTYPE="BZ") S PSBANS="" D CHECK I PSBANS=0!($D(DIRUT)) W !,"Cancelling Request..." S DIK="^PSB(53.69," D ^DIK W "Cancelled!" Q - .; - .;Allow "'BROWSER" Device - .S IOP=$$GET1^DIQ(53.69,DA_",",.06,"I"),PSBSIO=0 I IOP]"" D - ..S IOP="`"_IOP,%ZIS="N" - ..D ^%ZIS - ..I IO=IO(0) S PSBSIO=1 - ..D HOME^%ZIS K IOP - .I $$GET1^DIQ(53.69,DA_",",.06)["BROWSER"!(PSBSIO=1) S IOP=$$GET1^DIQ(53.69,DA_",",.06)_";132" D ^%ZIS U IO D DQ(DA) D ^%ZISC K IOP Q - .W @IOF,"Submitting Your Report Request to Taskman..." - .S ZTIO=$$GET1^DIQ(53.69,DA_",",.06) - .S ZTDTH=$P(^PSB(53.69,DA,0),U,7) - .S ZTDESC="BCMA - "_$$GET1^DIQ(53.69,DA_",",.05) - .S ZTRTN="DQ^PSBO("_DA_")" - .D ^%ZTLOAD - .W "Submitted!",!,"Your Task Number Is: ",$G(ZTSK),! - K ^TMP("PSBO",$J) - Q - ; -DQ(PSBRPT) ; Dequeue report from Taskman - N PSBWRD,PSBDFN - Q:'$D(^PSB(53.69,PSBRPT,0)) ; No Such Report - S $P(^PSB(53.69,PSBRPT,0),U,8)=$G(ZTSK,"RPC") - D:$$SETUP @("EN^PSBO"_$P(PSBRPT(0),U,5)) - K ^TMP("PSBO",$J) - S ZTREQ="@" - Q - ; -IOM() ; Returns good margin or not - Q:IOM'<132 1 - W !,"**************************************************************" - W !,"* SORRY, Your selected DEVICE does not print 132 columns. *" - W !,"**************************************************************" - W ! - Q 0 - ; -VAL(PSBFLDS) ; Validate that fields in PSBFLDS are filled in - N PSB,PSBFLD,PSBMSG,PSBSTOP,PSBST,PSBDAYS S PSBSTRT="" - F PSB=1:1 Q:$P(PSBFLDS,";",PSB)="" S PSBFLD=$P(PSBFLDS,";",PSB),PSBFLD(PSBFLD)=$$GET^DDSVAL(53.69,DA,PSBFLD) - I $D(PSBFLD(.11)) K:$E(PSBFLD(.11))="P" PSBFLD(.13),PSBFLD(.15) K:$E(PSBFLD(.11))="W" PSBFLD(.12) - S PSB="" F S PSB=$O(PSBFLD(PSB)) Q:PSB="" D:PSBFLD(PSB)="" - .I '$D(PSBMSG) S PSBMSG(0)="UNABLE TO FILE REQUEST",PSBMSG(1)=" ",PSBMSG(2)="ERROR: MISSING DATA - ALL FIELDS ARE REQUIRED",PSBMSG(3)=" " - .D FIELD^DID(53.69,PSB,"","TITLE;LABEL","PSB") - .S Z=" Missing Field: "_$S(PSB("TITLE")]"":PSB("TITLE"),1:PSB("LABEL")) - .S PSBMSG($O(PSBMSG(""),-1)+1)=Z - ; Check Times - D:$G(PSBFLD(.16)) - .S PSBSTRT=PSBFLD(.16)+$G(PSBFLD(.17)) - .D:$P($$GET1^DIQ(53.69,DA_",",.01),U)["MH" - ..S PSBDAYS=$$GET1^DIQ(101.24,$$FIND1^DIC(101.24,"","X","ORRP BCMA MAH","B")_",",.42) ;check maxdays - ..S:PSBDAYS="" PSBDAYS=7 - ..S X=PSBSTRT\1 D H^%DTC S PSBST=%H+PSBDAYS ;Determine stop date - .S PSBSTOP=$S($G(PSBFLD(.18)):PSBFLD(.18),1:PSBFLD(.16))+$G(PSBFLD(.19)) - .I PSBSTOPPSBST S Y=$O(PSBMSG(""),-1)+1,PSBMSG(Y)=" The date range cannot exceed "_PSBDAYS_" day(s) as defined in the CPRS 'MAXIMUM DAYS BACK' parameter" - Q:'$D(PSBMSG) ; All is well - D MSG^DDSUTL(.PSBMSG) - S DDSERROR=1 - Q - ; -SETUP() ; Setup parameters for the report in PSBRPT - N PSBWRDL,PSBINDX,PSBWRDA - K ^TMP("PSBO",$J) - F X=0,.1,.2,.3,.4,1 S PSBRPT(X)=$G(^PSB(53.69,PSBRPT,X)) - I $D(^PSB(53.69,PSBRPT,2)) M PSBRPT(2)=^PSB(53.69,PSBRPT,2) - I $P(PSBRPT(.1),U,1)="P" S PSBDFN=+$P(PSBRPT(.1),U,2) Q:'PSBDFN S ^TMP("PSBO",$J,PSBDFN,0)=$P(^DPT(PSBDFN,0),U)_U_$P(^DPT(PSBDFN,0),U,9),^TMP("PSBO",$J,"B",$P(^DPT(PSBDFN,0),U),PSBDFN)="" - D:$P(PSBRPT(.1),U,1)="W" - .S PSBWRD=$P(PSBRPT(.1),U,3) Q:'PSBWRD D WARD^NURSUT5("L^"_PSBWRD,.PSBWRDA) - .S X="" F S X=$O(PSBWRDA(PSBWRD,2,X)) Q:X="" S PSBWRDL=$P(PSBWRDA(PSBWRD,2,X,.01),U,2) D - ..F PSBDFN=0:0 S PSBDFN=$O(^DPT("CN",PSBWRDL,PSBDFN)) Q:'PSBDFN D - ...S ^TMP("PSBO",$J,PSBDFN,0)=$P(^DPT(PSBDFN,0),U)_U_$P(^DPT(PSBDFN,0),U,9) - ...; Determine Sort or default to Pt Name... - ...S:$P(PSBRPT(.1),U,5)="P" PSBINDX=$P(^DPT(PSBDFN,0),U) - ...I $P(PSBRPT(.1),U,5)="B" S PSBINDX=$P($G(^DPT(PSBDFN,.101)),U) S:PSBINDX="" PSBINDX="** NO ROOM BED **" - ...S:$P(PSBRPT(.1),U,5)="" PSBINDX=$P(^DPT(PSBDFN,0),U) - ...S:$G(PSBINDX)="" PSBINDX=$P(^DPT(PSBDFN,0),U) - ...S ^TMP("PSBO",$J,"B",PSBINDX,PSBDFN)="" - Q 1 - ; -WRAP(X,Y,Z) ; Quick text wrap - ; - ; Input Parameters Description: - ; X: Left Column of display [Optional] - ; Y: Cols to wrap in [Optional] - ; Z: Text to wrap [Optional] - ; - N PSB - F Q:'$L(Z) D - .W:$X>X ! - .W:$XPSBST S Y=$O(PSBMSG(""),-1)+1,PSBMSG(Y)=" The date range cannot exceed "_PSBDAYS_" day(s) as defined in the CPRS 'MAXIMUM DAYS BACK' parameter" + Q:'$D(PSBMSG) ; All is well + D MSG^DDSUTL(.PSBMSG) + S DDSERROR=1 + Q + ; +SETUP() ; Setup parameters for the report in PSBRPT + N PSBWRDL,PSBINDX,PSBWRDA + K ^TMP("PSBO",$J) + F X=0,.1,.2,.3,.4,1 S PSBRPT(X)=$G(^PSB(53.69,PSBRPT,X)) + I $D(^PSB(53.69,PSBRPT,2)) M PSBRPT(2)=^PSB(53.69,PSBRPT,2) + I $P(PSBRPT(.1),U,1)="P" S PSBDFN=+$P(PSBRPT(.1),U,2) Q:'PSBDFN S ^TMP("PSBO",$J,PSBDFN,0)=$P(^DPT(PSBDFN,0),U)_U_$P(^DPT(PSBDFN,0),U,9),^TMP("PSBO",$J,"B",$P(^DPT(PSBDFN,0),U),PSBDFN)="" + D:$P(PSBRPT(.1),U,1)="W" + .S PSBWRD=$P(PSBRPT(.1),U,3) Q:'PSBWRD D WARD^NURSUT5("L^"_PSBWRD,.PSBWRDA) + .S X="" F S X=$O(PSBWRDA(PSBWRD,2,X)) Q:X="" S PSBWRDL=$P(PSBWRDA(PSBWRD,2,X,.01),U,2) D + ..F PSBDFN=0:0 S PSBDFN=$O(^DPT("CN",PSBWRDL,PSBDFN)) Q:'PSBDFN D + ...S ^TMP("PSBO",$J,PSBDFN,0)=$P(^DPT(PSBDFN,0),U)_U_$P(^DPT(PSBDFN,0),U,9) + ...; Determine Sort or default to Pt Name... + ...S:$P(PSBRPT(.1),U,5)="P" PSBINDX=$P(^DPT(PSBDFN,0),U) + ...I $P(PSBRPT(.1),U,5)="B" S PSBINDX=$P($G(^DPT(PSBDFN,.101)),U) S:PSBINDX="" PSBINDX="** NO ROOM BED **" + ...S:$P(PSBRPT(.1),U,5)="" PSBINDX=$P(^DPT(PSBDFN,0),U) + ...S:$G(PSBINDX)="" PSBINDX=$P(^DPT(PSBDFN,0),U) + ...S ^TMP("PSBO",$J,"B",PSBINDX,PSBDFN)="" + Q 1 + ; +WRAP(X,Y,Z) ; Quick text wrap + ; + ; Input Parameters Description: + ; X: Left Column of display [Optional] + ; Y: Cols to wrap in [Optional] + ; Z: Text to wrap [Optional] + ; + N PSB + F Q:'$L(Z) D + .W:$X>X ! + .W:$X30:DILOCKTM,1:30) - E S RESULTS(0)="-1^Request Log Locked" Q - ; Generate Unique Entry and Create - F D NOW^%DTC S X=$E(%_"000000",1,14) S X=(1700+$E(X,1,3))_$E(X,4,14),X=PSBRTYP_"-"_$TR(X,".","-") Q:'$D(^PSB(53.69,"B",X)) - S DIC="^PSB(53.69,",DIC(0)="L" - S DIC("DR")=".02///N;.03////^S X=DUZ;.04////^S X=DUZ(2);.05///^S X=PSBRTYP" - K DD,DO D FILE^DICN - L -(^PSB(53.69,0)) - ; Okay, setup return and Boogie - I +Y<1 S RESULTS(0)="-1^Error Creating Request" - E S RESULTS(0)=Y - Q - ; -PRINT ; - N ZTDTH,ZTRTN,ZTSK,ZTDESC,ZTSAVE,DA - S DA=+PSBRPT(0) - S IOP=$$GET1^DIQ(53.69,DA_",",.06,"I"),PSBSIO=0 I IOP]"" D - .S IOP="`"_IOP,%ZIS="N" - .D ^%ZIS - .I IO=IO(0) S PSBSIO=1 - .D HOME^%ZIS K IOP - I $$GET1^DIQ(53.69,DA_",",.06)["BROWSER"!(PSBSIO=1) S IOP=$$GET1^DIQ(53.69,DA_",",.06)_";132" D ^%ZIS U IO D DQ^PSBO(DA) D ^%ZISC K IOP Q - W @IOF,"Submitting Your Report Request to Taskman..." - S ZTIO=$$GET1^DIQ(53.69,DA_",",.06)_";132" - S ZTDTH=$S($$GET1^DIQ(53.69,DA_",",.07,"I")]"":$$GET1^DIQ(53.69,DA_",",.07,"I"),1:$H) - S ZTDESC="BCMA - "_$$GET1^DIQ(53.69,DA_",",.05) - S ZTRTN="DQ^PSBO("_DA_")" - F I="PSBDFN","PSBTYPE" S ZTSAVE(I)="" - I $G(PSBORDNM)]"" S ZTSAVE("PSBORDNM")="" - D ^%ZTLOAD - I $D(ZTSK) S ^TMP("PSBO",$J,1)="0^Report queued. (Task #"_ZTSK_")" - E S ^TMP("PSBO",$J,1)="-1^Task Rejected." - Q - ; -LIST(XLIST) ; Place List Criteria into subfile #53.692 (multiple) - F XL1=$O(XLIST("")):1:$O(XLIST("B"),-1) Q:+XL1="" D - .I $P(XLIST(XL1),U)=PSBTYPE D - ..K PSBFDA,PSBRET,PSBIENX D CLEAN^DILF - ..S PSBIENX="+"_(XL1+1)_","_PSBIENS - ..D VAL^DIE(53.692,"+"_(XL1+1)_","_PSBIENS,.01,"F",$TR(XLIST(XL1),"^","~"),"PSBRET","PSBFDA") - ..D UPDATE^DIE("","PSBFDA","PSBIENX","PSBRET") - Q - ; +PSBO1 ;BIRMINGHAM/EFC-BCMA OUTPUTS ;Mar 2004 + ;;3.0;BAR CODE MED ADMIN;**4,13,32**;Mar 2004;Build 32 + ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified. + ; Reference/IA + ; FILE^DICN/10009 + ; +NEW(RESULTS,PSBRTYP) ; Create a new report request + ; Called interactively and via RPCBroker + K RESULTS + ; Check Type + I '$F("DL^MD^MH^ML^MM^MV^MT^PE^PM^WA^BL^PI^AL^DO^VT^PF^XA^IV^CM^CP^CE^CI^",PSBRTYP) S RESULTS(0)="-1^Invalid Report Type" Q + I '+$G(DUZ) S RESULTS(0)="-1^Undefined User" Q + I '$G(DUZ(2)) S RESULTS(0)="-1^Undefined Division" Q + ; Lock Log + L +(^PSB(53.69,0)):0 + E S RESULTS(0)="-1^Request Log Locked" Q + ; Generate Unique Entry and Create + F D NOW^%DTC S X=$E(%_"000000",1,14) S X=(1700+$E(X,1,3))_$E(X,4,14),X=PSBRTYP_"-"_$TR(X,".","-") Q:'$D(^PSB(53.69,"B",X)) + S DIC="^PSB(53.69,",DIC(0)="L" + S DIC("DR")=".02///N;.03////^S X=DUZ;.04////^S X=DUZ(2);.05///^S X=PSBRTYP" + K DD,DO D FILE^DICN + L -(^PSB(53.69,0)) + ; Okay, setup return and Boogie + I +Y<1 S RESULTS(0)="-1^Error Creating Request" + E S RESULTS(0)=Y + Q + ; +PRINT ; + N ZTDTH,ZTRTN,ZTSK,ZTDESC,ZTSAVE,DA + S DA=+PSBRPT(0) + S IOP=$$GET1^DIQ(53.69,DA_",",.06,"I"),PSBSIO=0 I IOP]"" D + .S IOP="`"_IOP,%ZIS="N" + .D ^%ZIS + .I IO=IO(0) S PSBSIO=1 + .D HOME^%ZIS K IOP + I $$GET1^DIQ(53.69,DA_",",.06)["BROWSER"!(PSBSIO=1) S IOP=$$GET1^DIQ(53.69,DA_",",.06)_";132" D ^%ZIS U IO D DQ^PSBO(DA) D ^%ZISC K IOP Q + W @IOF,"Submitting Your Report Request to Taskman..." + S ZTIO=$$GET1^DIQ(53.69,DA_",",.06)_";132" + S ZTDTH=$S($$GET1^DIQ(53.69,DA_",",.07,"I")]"":$$GET1^DIQ(53.69,DA_",",.07,"I"),1:$H) + S ZTDESC="BCMA - "_$$GET1^DIQ(53.69,DA_",",.05) + S ZTRTN="DQ^PSBO("_DA_")" + F I="PSBDFN","PSBTYPE" S ZTSAVE(I)="" + I $G(PSBORDNM)]"" S ZTSAVE("PSBORDNM")="" + D ^%ZTLOAD + I $D(ZTSK) S ^TMP("PSBO",$J,1)="0^Report queued. (Task #"_ZTSK_")" + E S ^TMP("PSBO",$J,1)="-1^Task Rejected." + Q + ; +LIST(XLIST) ; Place List Criteria into subfile #53.692 (multiple) + F XL1=$O(XLIST("")):1:$O(XLIST("B"),-1) Q:+XL1="" D + .I $P(XLIST(XL1),U)=PSBTYPE D + ..K PSBFDA,PSBRET,PSBIENX D CLEAN^DILF + ..S PSBIENX="+"_(XL1+1)_","_PSBIENS + ..D VAL^DIE(53.692,"+"_(XL1+1)_","_PSBIENS,.01,"F",$TR(XLIST(XL1),"^","~"),"PSBRET","PSBFDA") + ..D UPDATE^DIE("","PSBFDA","PSBIENX","PSBRET") + Q + ; diff --git a/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBOMH1.m b/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBOMH1.m index a00cb04b..b6876df0 100644 --- a/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBOMH1.m +++ b/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBOMH1.m @@ -1,175 +1,175 @@ -PSBOMH1 ;BIRMINGHAM/EFC-MAH ;7:40 PM 30 Jan 2008 - ;;3.0;BAR CODE MED ADMIN;**6,3,9,11,26,38,VWEHR1**;WorldVistA 30-Jan-08;Build 4 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; - ;Modified from FOIA VISTA, - ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;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 Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - ; Reference/IA - ; ^DILF/2054 - ; File 200/10060 - ; -EN ; - ; Load administrations - S (PSBORD,PSBIEN,PSBR1,PSBADIEN,PSBABR)="",PSBDT=PSBSTRT - K PSBTSA - F S PSBDT=$O(^PSB(53.79,"AADT",DFN,PSBDT)) Q:'PSBDT!(PSBDT>PSBSTOP) D - .F S PSBIEN=$O(^PSB(53.79,"AADT",DFN,PSBDT,PSBIEN)) Q:'PSBIEN Q:'$D(^PSB(53.79,PSBIEN)) L +^PSB(53.79,PSBIEN):3 I $P(^PSB(53.79,PSBIEN,0),U,9)]"" D L -^PSB(53.79,PSBIEN) - ..Q:'$P($G(^PSB(53.79,PSBIEN,0)),U,6) ; Bad IEN -no evnt dt - ..Q:$P(^PSB(53.79,PSBIEN,0),U,9)="N" ;NGiven - ..S PSBORD=$P($G(^PSB(53.79,PSBIEN,.1)),U,1) - ..; Continuous - ..D:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)="C" - ...S X=PSBDT D H^%DTC S PSBWEEK=PSBAR(%H) D CLEAN^PSBVT,PSJ1^PSBVT($P(^PSB(53.79,PSBIEN,0),U,1),$P(^PSB(53.79,PSBIEN,.1),U,1)) - ...I $P(^PSB(53.79,PSBIEN,0),U,6)'=PSBDT,'$$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,PSBIVPSH) D D CLEAN^PSBVT Q ;chck IV audit - ....S PSBSIEN=PSBIEN - ....I $P(^PSB(53.79,PSBIEN,0),"^",10)]"" D BAGDTL^PSBRPC2(.PSBAUD,$P(^PSB(53.79,PSBIEN,0),U,10),$P(^PSB(53.79,PSBIEN,.1),U,1)) - ....S PSBIEN=PSBSIEN K PSBSIEN - ....S X=0 F S X=$O(PSBAUD(X)) Q:X="" I $P(PSBAUD(X),U,3)="" K PSBAUD(X) - ....S X=0 F S X=$O(PSBAUD(X)) Q:X="" Q:$P(PSBAUD(X),U,1)=PSBDT - ....I X="" K PSBAUD Q - ....I '$D(PSBAUD(X)) K PSBAUD Q - ....S PSBS=$P(PSBAUD(X),U,3) - ....I PSBS="GIVEN",$P($G(PSBAUD(X-1)),U,3)="NOT GIVEN" Q - ....I PSBS="NOT GIVEN" Q - ....S PSBS=$S(PSBS="INFUSING":"I",PSBS="GIVEN":"G",PSBS="COMPLETED":"C",PSBS="HELD":"H",PSBS="REFUSED":"R",PSBS="REMOVED":"RM",PSBS="STOPPED":"S",PSBS["MISSING":"M",1:"NOACTION") - ....D PSBSTIV^PSBOMH2 - ....S X=PSBDT_U_$P(PSBAUD(X),U,2)_U_PSBS_U_PSBIEN - ....S Y=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,""),-1)+1 - ....S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,Y)=X - ....S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,0)=Y - ....D PSBOUT($P((X),"^",1),$P((X),"^",2)) - ....K PSBAUD - ...S PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:INITIAL") - ...S PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:NAME") - ...I PSBINIT="" S PSBINIT=99 - ...;get instrc info - audt log - ...I $D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D - ....D INSTR^PSBOMH - ....S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)="" - ...I PSBINIT[99 S PSBINIT="" - ...I $P(^PSB(53.79,PSBIEN,0),U,9)="G",PSBDT=$P(^PSB(53.79,PSBIEN,0),U,6) D PSBCK1^PSBOMH2("A") - ...I $P(^PSB(53.79,PSBIEN,0),U,9)'="G",PSBDT=$P(^PSB(53.79,PSBIEN,0),U,6) D PSBCK1^PSBOMH2("B") - ...I PSBDT'=$P(^PSB(53.79,PSBIEN,0),U,6),$P(^PSB(53.79,PSBIEN,0),U,9)="RM" D - ....D DDAUD - ....S I="" F S I=$O(PSBTAR(I),-1) Q:I="" I $P(PSBTAR(I),U,1)=PSBDT D - .....S PSBS=$P(PSBTAR(I),U,3) - .....I PSBS="GIVEN",$P($G(PSBTAR(I-1)),U,3)="NOT GIVEN" Q ; canceled - not given - .....I PSBS="NOT GIVEN" Q - .....S PSBS=$S(PSBS="INFUSING":"I",PSBS="GIVEN":"G",PSBS="COMPLETED":"C",PSBS="HELD":"H",PSBS="REFUSED":"R",PSBS="REMOVED":"RM",PSBS="STOPPED":"S",PSBS["MISSING":"M",1:"NO ACTION") - .....D PSBCTAR^PSBOMH2 - .....S X=$P(PSBTAR(I),U,1,2)_U_PSBS_U_PSBIEN - ...S Y=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,""),-1)+1 - ...S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,Y)=X - ...S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,0)=Y - ...D PSBOUT($P((X),"^",1),$P((X),"^",2)) - ...Q - ..; 1-Time On Call or PRN - ..D:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)'="C" - ...I PSBDT'=$$GET1^DIQ(53.79,PSBIEN_",",.06,"I") Q - ...S PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:INITIAL") - ...S PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:NAME") - ...I PSBINIT="" S PSBINIT=99 - ...S (PSBXA,PSBM)=1,(PSBZ,PSBT,PSBFLG)="" - ...I $$GET1^DIQ(53.79,PSBIEN_",",.09)="REMOVED" D - ....F I=1:1 S PSBXA=$O(^PSB(53.79,PSBIEN,.9,PSBXA)) Q:PSBXA="" I PSBXA?1.3N S PSBZ=PSBZ+1,PSBT(PSBZ)=^PSB(53.79,PSBIEN,.9,PSBXA,0) - ....F S=1:1 Q:PSBM<1 S PSBM=PSBZ-S I (PSBM>0) I (PSBT(PSBM)["GIVEN") S PSBFLG="1" S PRELINE1=$P(PSBT(PSBM),"'",2)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.04)_" "_$E($P(PSBT(PSBM),"'",4),1,3) Q - ...I $D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D - ....D INSTR^PSBOMH - ....S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)="" - ...I '$D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D PSBOUT(PSBDT,PSBINIT) - ...S PSBLINE1=$$GET1^DIQ(53.79,PSBIEN_",",.09)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.06)_" "_PSBINIT_" "_$$GET1^DIQ(53.79,PSBIEN_",",.21),PSBLINE2="" - ...I PSBINIT[99 S PSBINIT="" - ...D:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)="P" - ....I $P($G(^PSB(53.79,PSBIEN,.2)),U,2)="" S PSBLINE2=" Results: " - ....E D - .....S PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","PRN EFFECTIVENESS ENTERED BY:INITIAL") - .....S PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","PRN EFFECTIVENESS ENTERED BY:NAME") - .....I PSBINIT="" S PSBINIT=99 - .....I $D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D - ......S PSBINIT=PSBINIT_"*",PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."),0),U,3)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.24) - ......S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)="" - .....I '$D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D - ......D:$D(^PSB(53.79,PSBIEN,.9,0)) - .......S (PSBXA2,PSBFG)=0,PSBEFFDT=$P(^PSB(53.79,PSBIEN,.2),U,4) F S PSBXA2=$O(^PSB(53.79,PSBIEN,.9,PSBXA2)) Q:+PSBXA2'>0 D Q:PSBFG=1 - ........D:($P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U)=PSBEFFDT)&($P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U,3)["Instruct")&($P(^PSB(53.79,PSBIEN,.2),U,3)=$P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U,2)) - .........S PSBINIT=PSBINIT_"*",PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U,3)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.24) - .........S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)="",PSBFG=1 - .....S PSBLINE2=" Results: "_$$GET1^DIQ(53.79,PSBIEN_",",.22) - .....S PSBRTXTW=" Entered By "_PSBINIT_" on "_$$GET1^DIQ(53.79,PSBIEN_",",.24) - .....I PSBINIT[99 S PSBINIT="" - ...S X=PSBDT D H^%DTC F PSBWEEK=PSBAR(%H):-7 Q:$D(^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",0))!('$D(PSBAR(PSBWEEK))) - ...S X=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",""),-1)+1 - ...I PSBFLG="1" S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X)=PRELINE1 - ...S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+1)=PSBLINE1 - ...I $G(PSBLINE2)]"" D - ....I $L(PSBLINE2)<90 S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+2)=PSBLINE2 S:$$GET1^DIQ(53.79,PSBIEN_",",.24)'="" ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+3)=" "_PSBRTXTW - ....I $L(PSBLINE2)>90 D - .....S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+2)=$E(PSBLINE2,1,90) - .....S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+3)=" "_$E(PSBLINE2,91,161) - .....I $L(PSBLINE2)'>161 S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+4)=" "_PSBRTXTW - .....I $L(PSBLINE2)>161 S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+4)=" "_$E(PSBLINE2,162,200),^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+5)=" "_PSBRTXTW - Q - ; -DDAUD ; audits for dispen drugs - ; - M PSBMLA=^PSB(53.79,PSBIEN) - S PSBGA="" I $D(PSBMLA(.9,0)) D - .F PSBX=1:1 Q:'$D(PSBMLA(.9,PSBX)) I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D Q - ..I $D(PSBMLA(.9,PSBX-2,0)) D DT^DILF("ENPST",$P(PSBMLA(.9,PSBX-2,0),"'",2),.PSBDATE) - ..I '$D(PSBMLA(.9,PSBX-2,0)) S PSBDATE=$P(^PSB(53.79,PSBIEN,0),U,6) - ..S PSBTMP(10000000-PSBDATE,"B")=PSBDATE_U_$$INITIAL^PSBRPC2($P(PSBMLA(0),U,5))_U_$P(PSBMLA(.9,PSBX,0),"'",2) - ..S PSBGA=1 - .F PSBX=1:1 Q:'$D(PSBMLA(.9,PSBX)) I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D - ..S PSBTMP(10000000-$P(PSBMLA(.9,PSBX,0),U,1),"B")=$P(PSBMLA(.9,PSBX,0),U,1)_U_$$INITIAL^PSBRPC2($P(PSBMLA(.9,PSBX,0),U,2))_U_$P($P(PSBMLA(.9,PSBX,0),U,3),"'",2) - ..S PSBGA=1 - I PSBGA'=1 S PSBTMP(10000000-$P(PSBMLA(0),U,6),"A")=$P(PSBMLA(0),U,6)_U_$$INITIAL^PSBRPC2($P(PSBMLA(0),U,7)) - S PSBQRY="PSBTMP",PSBCNT=1 F S PSBQRY=$Q(@PSBQRY) Q:PSBQRY="" D ; does comment go with action - .; - .;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1 - .; - .;S PSBPQRY=$Q(@PSBQRY,-1) - .S PSBPQRY=$$Q^VWUTIL($NA(@PSBQRY),-1) - .; - .;END CHANGE - .; - .I PSBPQRY="" S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q ; no prev action - .I $QS(PSBPQRY,2)="C" S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q ; prev line = comment - .I $QS(PSBQRY,2)="C",$E($P(@$Q(@PSBQRY,-1),U,1),1,12)=$E($P(@PSBQRY,U,1),1,12),$P(@$Q(@PSBQRY,-1),U,2)=$P(@PSBQRY,U,2) D Q - ..S X=$P(@PSBQRY,U,4) S:X[":" X=$P(X,":",2) S $P(PSBTAR(PSBCNT-1),U,4)=X Q - .S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 - Q - ; -PSBOUT(PSBTET,PSBOT1) ; - I '$D(^PSB(53.79,PSBIEN,.9,0)) D PSBENT^PSBOMH2(PSBOT1) - S PSBIDA="" I $P(^PSB(53.79,PSBIEN,0),U,6)=PSBTET S PSBIDA=$P(^PSB(53.79,PSBIEN,0),U,7),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1) - S PSBXA1=0 - F S PSBXA1=$O(^PSB(53.79,PSBIEN,.9,PSBXA1)) Q:+PSBXA1'>0 I PSBXA1'=0 D Q:$G(PSBOT1)["*" - .I $L(PSBXA1)<4 D - ..I $P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",1)=PSBTET D - ...S:$G(PSBIDA)="" PSBIDA=$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",2),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1) - ...I (PSBIDA=$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",2)),$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",3)["Instruct" D - ....S INSDD=$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",1),Y=INSDD D DD^%DT S INSDD=Y - ....S PSBOT1=PSBOT1_"*",PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),U,3)_" "_INSDD - I $G(PSBIDA)="",$P(^PSB(53.79,PSBIEN,0),U,4)=PSBTET D - .S PSBIDA=$P(^PSB(53.79,PSBIEN,0),U,5),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1) - I $G(PSBNAME)="" D - . S PSBIDA=$P(^PSB(53.79,PSBIEN,0),U,5),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1) - S ^TMP("PSB",$J,"LEGEND",$S($G(PSBOT1)="":99,1:PSBOT1),PSBNAME)="" - Q - ; +PSBOMH1 ;BIRMINGHAM/EFC-MAH ;7:40 PM 30 Jan 2008 + ;;3.0;BAR CODE MED ADMIN;**6,3,9,11,26,38,VWEHR1**;WorldVistA 30-Jan-08 + ;Per VHA Directive 2004-038, this routine should not be modified. + ; + ;Modified from FOIA VISTA, + ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;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 Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + ; Reference/IA + ; ^DILF/2054 + ; File 200/10060 + ; +EN ; + ; Load administrations + S (PSBORD,PSBIEN,PSBR1,PSBADIEN,PSBABR)="",PSBDT=PSBSTRT + K PSBTSA + F S PSBDT=$O(^PSB(53.79,"AADT",DFN,PSBDT)) Q:'PSBDT!(PSBDT>PSBSTOP) D + .F S PSBIEN=$O(^PSB(53.79,"AADT",DFN,PSBDT,PSBIEN)) Q:'PSBIEN Q:'$D(^PSB(53.79,PSBIEN)) L +^PSB(53.79,PSBIEN):3 I $P(^PSB(53.79,PSBIEN,0),U,9)]"" D L -^PSB(53.79,PSBIEN) + ..Q:'$P($G(^PSB(53.79,PSBIEN,0)),U,6) ; Bad IEN -no evnt dt + ..Q:$P(^PSB(53.79,PSBIEN,0),U,9)="N" ;NGiven + ..S PSBORD=$P($G(^PSB(53.79,PSBIEN,.1)),U,1) + ..; Continuous + ..D:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)="C" + ...S X=PSBDT D H^%DTC S PSBWEEK=PSBAR(%H) D CLEAN^PSBVT,PSJ1^PSBVT($P(^PSB(53.79,PSBIEN,0),U,1),$P(^PSB(53.79,PSBIEN,.1),U,1)) + ...I $P(^PSB(53.79,PSBIEN,0),U,6)'=PSBDT,'$$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,PSBIVPSH) D D CLEAN^PSBVT Q ;chck IV audit + ....S PSBSIEN=PSBIEN + ....I $P(^PSB(53.79,PSBIEN,0),"^",10)]"" D BAGDTL^PSBRPC2(.PSBAUD,$P(^PSB(53.79,PSBIEN,0),U,10),$P(^PSB(53.79,PSBIEN,.1),U,1)) + ....S PSBIEN=PSBSIEN K PSBSIEN + ....S X=0 F S X=$O(PSBAUD(X)) Q:X="" I $P(PSBAUD(X),U,3)="" K PSBAUD(X) + ....S X=0 F S X=$O(PSBAUD(X)) Q:X="" Q:$P(PSBAUD(X),U,1)=PSBDT + ....I X="" K PSBAUD Q + ....I '$D(PSBAUD(X)) K PSBAUD Q + ....S PSBS=$P(PSBAUD(X),U,3) + ....I PSBS="GIVEN",$P($G(PSBAUD(X-1)),U,3)="NOT GIVEN" Q + ....I PSBS="NOT GIVEN" Q + ....S PSBS=$S(PSBS="INFUSING":"I",PSBS="GIVEN":"G",PSBS="COMPLETED":"C",PSBS="HELD":"H",PSBS="REFUSED":"R",PSBS="REMOVED":"RM",PSBS="STOPPED":"S",PSBS["MISSING":"M",1:"NOACTION") + ....D PSBSTIV^PSBOMH2 + ....S X=PSBDT_U_$P(PSBAUD(X),U,2)_U_PSBS_U_PSBIEN + ....S Y=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,""),-1)+1 + ....S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,Y)=X + ....S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,0)=Y + ....D PSBOUT($P((X),"^",1),$P((X),"^",2)) + ....K PSBAUD + ...S PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:INITIAL") + ...S PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:NAME") + ...I PSBINIT="" S PSBINIT=99 + ...;get instrc info - audt log + ...I $D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D + ....D INSTR^PSBOMH + ....S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)="" + ...I PSBINIT[99 S PSBINIT="" + ...I $P(^PSB(53.79,PSBIEN,0),U,9)="G",PSBDT=$P(^PSB(53.79,PSBIEN,0),U,6) D PSBCK1^PSBOMH2("A") + ...I $P(^PSB(53.79,PSBIEN,0),U,9)'="G",PSBDT=$P(^PSB(53.79,PSBIEN,0),U,6) D PSBCK1^PSBOMH2("B") + ...I PSBDT'=$P(^PSB(53.79,PSBIEN,0),U,6),$P(^PSB(53.79,PSBIEN,0),U,9)="RM" D + ....D DDAUD + ....S I="" F S I=$O(PSBTAR(I),-1) Q:I="" I $P(PSBTAR(I),U,1)=PSBDT D + .....S PSBS=$P(PSBTAR(I),U,3) + .....I PSBS="GIVEN",$P($G(PSBTAR(I-1)),U,3)="NOT GIVEN" Q ; canceled - not given + .....I PSBS="NOT GIVEN" Q + .....S PSBS=$S(PSBS="INFUSING":"I",PSBS="GIVEN":"G",PSBS="COMPLETED":"C",PSBS="HELD":"H",PSBS="REFUSED":"R",PSBS="REMOVED":"RM",PSBS="STOPPED":"S",PSBS["MISSING":"M",1:"NO ACTION") + .....D PSBCTAR^PSBOMH2 + .....S X=$P(PSBTAR(I),U,1,2)_U_PSBS_U_PSBIEN + ...S Y=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,""),-1)+1 + ...S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,Y)=X + ...S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,0)=Y + ...D PSBOUT($P((X),"^",1),$P((X),"^",2)) + ...Q + ..; 1-Time On Call or PRN + ..D:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)'="C" + ...I PSBDT'=$$GET1^DIQ(53.79,PSBIEN_",",.06,"I") Q + ...S PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:INITIAL") + ...S PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:NAME") + ...I PSBINIT="" S PSBINIT=99 + ...S (PSBXA,PSBM)=1,(PSBZ,PSBT,PSBFLG)="" + ...I $$GET1^DIQ(53.79,PSBIEN_",",.09)="REMOVED" D + ....F I=1:1 S PSBXA=$O(^PSB(53.79,PSBIEN,.9,PSBXA)) Q:PSBXA="" I PSBXA?1.3N S PSBZ=PSBZ+1,PSBT(PSBZ)=^PSB(53.79,PSBIEN,.9,PSBXA,0) + ....F S=1:1 Q:PSBM<1 S PSBM=PSBZ-S I (PSBM>0) I (PSBT(PSBM)["GIVEN") S PSBFLG="1" S PRELINE1=$P(PSBT(PSBM),"'",2)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.04)_" "_$E($P(PSBT(PSBM),"'",4),1,3) Q + ...I $D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D + ....D INSTR^PSBOMH + ....S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)="" + ...I '$D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D PSBOUT(PSBDT,PSBINIT) + ...S PSBLINE1=$$GET1^DIQ(53.79,PSBIEN_",",.09)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.06)_" "_PSBINIT_" "_$$GET1^DIQ(53.79,PSBIEN_",",.21),PSBLINE2="" + ...I PSBINIT[99 S PSBINIT="" + ...D:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)="P" + ....I $P($G(^PSB(53.79,PSBIEN,.2)),U,2)="" S PSBLINE2=" Results: " + ....E D + .....S PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","PRN EFFECTIVENESS ENTERED BY:INITIAL") + .....S PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","PRN EFFECTIVENESS ENTERED BY:NAME") + .....I PSBINIT="" S PSBINIT=99 + .....I $D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D + ......S PSBINIT=PSBINIT_"*",PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."),0),U,3)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.24) + ......S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)="" + .....I '$D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D + ......D:$D(^PSB(53.79,PSBIEN,.9,0)) + .......S (PSBXA2,PSBFG)=0,PSBEFFDT=$P(^PSB(53.79,PSBIEN,.2),U,4) F S PSBXA2=$O(^PSB(53.79,PSBIEN,.9,PSBXA2)) Q:+PSBXA2'>0 D Q:PSBFG=1 + ........D:($P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U)=PSBEFFDT)&($P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U,3)["Instruct")&($P(^PSB(53.79,PSBIEN,.2),U,3)=$P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U,2)) + .........S PSBINIT=PSBINIT_"*",PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U,3)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.24) + .........S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)="",PSBFG=1 + .....S PSBLINE2=" Results: "_$$GET1^DIQ(53.79,PSBIEN_",",.22) + .....S PSBRTXTW=" Entered By "_PSBINIT_" on "_$$GET1^DIQ(53.79,PSBIEN_",",.24) + .....I PSBINIT[99 S PSBINIT="" + ...S X=PSBDT D H^%DTC F PSBWEEK=PSBAR(%H):-7 Q:$D(^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",0))!('$D(PSBAR(PSBWEEK))) + ...S X=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",""),-1)+1 + ...I PSBFLG="1" S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X)=PRELINE1 + ...S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+1)=PSBLINE1 + ...I $G(PSBLINE2)]"" D + ....I $L(PSBLINE2)<90 S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+2)=PSBLINE2 S:$$GET1^DIQ(53.79,PSBIEN_",",.24)'="" ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+3)=" "_PSBRTXTW + ....I $L(PSBLINE2)>90 D + .....S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+2)=$E(PSBLINE2,1,90) + .....S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+3)=" "_$E(PSBLINE2,91,161) + .....I $L(PSBLINE2)'>161 S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+4)=" "_PSBRTXTW + .....I $L(PSBLINE2)>161 S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+4)=" "_$E(PSBLINE2,162,200),^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+5)=" "_PSBRTXTW + Q + ; +DDAUD ; audits for dispen drugs + ; + M PSBMLA=^PSB(53.79,PSBIEN) + S PSBGA="" I $D(PSBMLA(.9,0)) D + .F PSBX=1:1 Q:'$D(PSBMLA(.9,PSBX)) I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D Q + ..I $D(PSBMLA(.9,PSBX-2,0)) D DT^DILF("ENPST",$P(PSBMLA(.9,PSBX-2,0),"'",2),.PSBDATE) + ..I '$D(PSBMLA(.9,PSBX-2,0)) S PSBDATE=$P(^PSB(53.79,PSBIEN,0),U,6) + ..S PSBTMP(10000000-PSBDATE,"B")=PSBDATE_U_$$INITIAL^PSBRPC2($P(PSBMLA(0),U,5))_U_$P(PSBMLA(.9,PSBX,0),"'",2) + ..S PSBGA=1 + .F PSBX=1:1 Q:'$D(PSBMLA(.9,PSBX)) I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D + ..S PSBTMP(10000000-$P(PSBMLA(.9,PSBX,0),U,1),"B")=$P(PSBMLA(.9,PSBX,0),U,1)_U_$$INITIAL^PSBRPC2($P(PSBMLA(.9,PSBX,0),U,2))_U_$P($P(PSBMLA(.9,PSBX,0),U,3),"'",2) + ..S PSBGA=1 + I PSBGA'=1 S PSBTMP(10000000-$P(PSBMLA(0),U,6),"A")=$P(PSBMLA(0),U,6)_U_$$INITIAL^PSBRPC2($P(PSBMLA(0),U,7)) + S PSBQRY="PSBTMP",PSBCNT=1 F S PSBQRY=$Q(@PSBQRY) Q:PSBQRY="" D ; does comment go with action + .; + .;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1 + .; + .;S PSBPQRY=$Q(@PSBQRY,-1) + .S PSBPQRY=$$Q^VWUTIL($NA(@PSBQRY),-1) + .; + .;END CHANGE + .; + .I PSBPQRY="" S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q ; no prev action + .I $QS(PSBPQRY,2)="C" S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q ; prev line = comment + .I $QS(PSBQRY,2)="C",$E($P(@$Q(@PSBQRY,-1),U,1),1,12)=$E($P(@PSBQRY,U,1),1,12),$P(@$Q(@PSBQRY,-1),U,2)=$P(@PSBQRY,U,2) D Q + ..S X=$P(@PSBQRY,U,4) S:X[":" X=$P(X,":",2) S $P(PSBTAR(PSBCNT-1),U,4)=X Q + .S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 + Q + ; +PSBOUT(PSBTET,PSBOT1) ; + I '$D(^PSB(53.79,PSBIEN,.9,0)) D PSBENT^PSBOMH2(PSBOT1) + S PSBIDA="" I $P(^PSB(53.79,PSBIEN,0),U,6)=PSBTET S PSBIDA=$P(^PSB(53.79,PSBIEN,0),U,7),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1) + S PSBXA1=0 + F S PSBXA1=$O(^PSB(53.79,PSBIEN,.9,PSBXA1)) Q:+PSBXA1'>0 I PSBXA1'=0 D Q:$G(PSBOT1)["*" + .I $L(PSBXA1)<4 D + ..I $P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",1)=PSBTET D + ...S:$G(PSBIDA)="" PSBIDA=$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",2),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1) + ...I (PSBIDA=$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",2)),$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",3)["Instruct" D + ....S INSDD=$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",1),Y=INSDD D DD^%DT S INSDD=Y + ....S PSBOT1=PSBOT1_"*",PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),U,3)_" "_INSDD + I $G(PSBIDA)="",$P(^PSB(53.79,PSBIEN,0),U,4)=PSBTET D + .S PSBIDA=$P(^PSB(53.79,PSBIEN,0),U,5),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1) + I $G(PSBNAME)="" D + . S PSBIDA=$P(^PSB(53.79,PSBIEN,0),U,5),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1) + S ^TMP("PSB",$J,"LEGEND",$S($G(PSBOT1)="":99,1:PSBOT1),PSBNAME)="" + Q + ; diff --git a/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBPOIV.m b/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBPOIV.m index 00633877..4881c54f 100644 --- a/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBPOIV.m +++ b/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBPOIV.m @@ -1,145 +1,145 @@ -PSBPOIV ;BIRMINGHAM/EFC-IV PARAMETER VALIDATION ;Mar 2004 - ;;3.0;BAR CODE MED ADMIN;**2**;Mar 2004;Build 22 - ;;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified. - ; - ; Reference/IA - ; ^DIC(42/2440 - ; EN^PSJBCMA2/2830 - ; VADPT/10061 - ; - ; -EN(PSBDFN,PSBORD) ; - ; - S DFN=PSBDFN,(PSBMI,PSBMW,PSBMWC,PSBMAUD)=0,(PSBMIDT,PSBMIM)="",PSBONXS=PSBORD_"^" - K ^TMP("PSBAR",$J) S ^TMP("PSBAR",$J,"W",0)=0 - D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBORD) - ; get IV parameters for the current ward - S PSBCSTR="^ADDITIVE^STRENGTH^BOTTLE^SOLUTION^VOLUME^INFUSION RATE^MED ROUTE^SCHEDULE^ADMIN TIME^REMARKS^OTHER PRINT INFO^PROVIDER^START DATE/TIME^STOP DATE/TIME^PROVIDER COMMENTS" - D INP^VADPT S PSBWARD=$P(VAIN(4),"^"),PSBWDIV=PSBWARD D KVAR^VADPT - I $G(PSBWARD)'="",$D(^PSB(53.66,"B",PSBWARD)) D ; if IV paramaters defined for ward use them - .S PSBWARD=$O(^PSB(53.66,"B",PSBWARD,"")) - .S:$D(^PSB(53.66,PSBWARD,1,"B",PSBIVT)) PSBIVPAR=^PSB(53.66,PSBWARD,1,$O(^PSB(53.66,PSBWARD,1,"B",PSBIVT,""),-1),0) - I '$D(PSBIVPAR) S PSBIVPAR=PSBIVT D ; if IV parameters not defined for ward get defaults for division - .D:$D(PSBWDIV) ; Get the appropriate DIV for ward and DIVISIONAL IV PARAMETERS - ..S PSBWDIV=$$GET1^DIQ(42,PSBWDIV_",",.015,"I") - ..I $G(PSBWDIV)']"" S PSBWDIV="DIV" - ..E S PSBWDIV=$P($$SITE^VASITE(DT,PSBWDIV),U,1),PSBWDIV="DIV.`"_PSBWDIV - ..F X=2:1 Q:$P(PSBCSTR,U,X)="" S PSBIVPAR=PSBIVPAR_U_$P($P($$GET^XPAR(PSBWDIV,"PSBIV "_$P(PSBCSTR,U,X),PSBIVT,"B"),U,2),"-",1) - ..K PSBWDIV ; Kill temp variable. - F PSBC1=1:1 Q:$P(PSBONXS,U,PSBC1)="" D ; process all orders - .D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBONXS,U,PSBC1)) - .K PSBPONX2 I $G(PSBPONX)]"",$G(PSBPONX)["P" S PSBPONX2=PSBPONX D ; Must compare "active" orders for changes made - look beyond "pendings" - ..F D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBPONX2) S PSBPONX2=PSBPONX Q:(PSBPONX2="")!(PSBPONX2'["P") ; - ..D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBONXS,U,PSBC1)) ; Refresh data - ..S:$D(PSBPONX2) PSBPONX=PSBPONX2 K PSBPONX2 - .Q:($L(U_PSBONXS,U_PSBPONX_U)-1)>0 - .I $G(PSBPONX)]"" S PSBONXS=PSBONXS_PSBPONX_U - .K ^TMP("PSJ2",$J) S PSBMAUD=0 D EN^PSJBCMA2(PSBDFN,PSBONX,1) ; check IV parameters against activity log for this order when no "I"nvalid message - .I PSBMI=0 F X=1:1 Q:'$D(^TMP("PSJ2",$J,X)) S PSBCHKV=U_$P(^TMP("PSJ2",$J,X,1),U,3)_U I PSBCSTR[PSBCHKV D MSG(PSBCHKV,$P(^TMP("PSJ2",$J,X,1),U,1)) S PSBMAUD=1 - .K ^TMP("PSJ2",$J) - .I PSBMI=0,$G(PSBPONX)]"" D SAVEPAR,CHKORD ; check IV parameters against previous order when no "I"nvalid message - .D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBONXS,U,PSBC1)) ; restore variable for this order - .; okay - we have invalids and warnings through this order so process bags for this order - .I '$D(PSBUIDA) Q ; got errors and warning but no bags printed for this order - go to the next - .S PSBUID="" F S PSBUID=$O(PSBUIDA(PSBUID),-1) Q:PSBUID="" D - ..F PSBC2=1:1 S PSBMONX=$P(PSBONXS,U,PSBC2) Q:PSBMONX="" D ; check if bag is in 53.79 - ...I $D(^PSB(53.79,"AUID",PSBDFN,PSBMONX,PSBUID)) D - ....S PSBIEN=$O(^PSB(53.79,"AUID",PSBDFN,PSBMONX,PSBUID,"")) - ....S PSBPDT=$P(PSBLBLA(PSBUID),U,1),PSBLSTS=$P(PSBLBLA(PSBUID),3) - ....S $P(X,U,2)=$P(^PSB(53.79,PSBIEN,0),U,9) ; add action status - ....S $P(X,U,3)=$P(^PSB(53.79,PSBIEN,0),U,6) ; add action date/time - ....S $P(X,U,4)=$P(^PSB(53.79,PSBIEN,.1),U,1) ; add order ID was administered for - ..S $P(X,U,5)=PSBONX ; add order ID was printed for - ..S $P(X,U,6)=PSBOSTS ; add order status - ..S $P(X,U,7)=$P(PSBLBLA(PSBUID),U,1) ; add date/time ID was printed - ..S $P(X,U,8)=$P(PSBLBLA(PSBUID),U,3) ; add lable status from pharmacy - ..S $P(X,U,9)="" ; 9 open for later development - ..S $P(X,U,10)=PSBUIDA(PSBUID) ; add return from PSJ1 - ..D BWAR - ..I PSBMW=1 S PSBMWS="W;" F I=1:1:^TMP("PSBAR",$J,"W",0) D S $P(X,U,1)=$P(PSBMWS,";",1,$L(PSBMWS,";")-1) - ...I $P(PSBLBLA(PSBUID),U,1)'>$P(^TMP("PSBAR",$J,"W",I),U,2) D - ....S:(PSBONX=$P(PSBONXS,U,1))&(PSBMAUD=1) PSBMWS=PSBMWS_I_";" - ....S:PSBONX'=$P(PSBONXS,U,1) PSBMWS=PSBMWS_I_";" - ..I PSBMIDT'="",$P(PSBLBLA(PSBUID),U,1)$O(PSBOTMP("ADD",""),-1) D MSG("ADDITIVE",PSBOSP) Q ;previous order has addtives not in current order - I $O(PSBADA(""),-1)<$O(PSBOTMP("ADD",""),-1) D MSG("ADDITIVE",PSBOSP) Q ;previous order missing additives in current order - S X="" F S X=$O(PSBADA(X)) Q:X="" D Q ; check that additives, strength, and bottle are the same - .I PSBADA(X)=PSBOTMP("ADD",X) Q ; everything the same - .I $P(PSBADA(X),U,2)'=$P(PSBOTMP("ADD",X),U,2) D MSG("ADDITIVE",PSBOSP) Q - .I $P(PSBADA(X),U,4)'=$P(PSBOTMP("ADD",X),U,4) D MSG("STRENGTH",PSBOSP) Q - Q - ; -CHKSOL ; - N X,Y - I '$D(PSBSOLA),'$D(PSBOTMP("SOL")) Q ; no solutions - I $O(PSBSOLA(""),-1)>$O(PSBOTMP("SOL",""),-1) D MSG("SOLUTION",PSBOSP) Q ;previous order has solutions not in current order - I $O(PSBSOLA(""),-1)<$O(PSBOTMP("SOL",""),-1) D MSG("SOLUTION",PSBOSP) Q ;previous order missing solutions in current order - S X="" F S X=$O(PSBSOLA(X)) Q:X="" D Q ; check that solutions volume are the same - .I PSBSOLA(X)=PSBOTMP("SOL",X) Q ; everything the same - .I $P(PSBSOLA(X),U,2)'=$P(PSBOTMP("SOL",X),U,2) D MSG("SOLUTION",PSBOSP) Q - .I $P(PSBSOLA(X),U,4)'=$P(PSBOTMP("SOL",X),U,4) D MSG("VOLUME",PSBOSP) Q - Q - ; -BWAR ; - N X,Y,Z,PSBONX - S X=^TMP("PSBAR",$J,"W",0)+1 - S Z="" F Z=1:1 S PSBONX=$P(PSBONXS,U,Z) Q:$G(PSBONX)="" D ; Display "Warning"s for changes - .I '$D(PSBMWAR(PSBONX)) Q - .S Y="" F S Y=$O(PSBMWAR(PSBONX,Y)) Q:Y'?.N1".".N D - ..S Z="",PSBYS="" F S Z=$O(PSBMWAR(PSBONX,Y,Z)) Q:Z="" S PSBYS=PSBYS_Z_";" - ..S PSBYS=$P(PSBYS,";",1,$L(PSBYS,";")-1) - ..S ^TMP("PSBAR",$J,"W",X)=PSBONX_U_Y_U_"2^The "_PSBYS_" was changed on",^TMP("PSBAR",$J,"W",0)=X,X=X+1 - .K PSBMWAR(PSBONX) - Q - ; -MSG(PSBMVAR,PSBDATE) ; - I PSBMI=1 Q ;already have an invalid don't need anymore - F Y=1:1 S PSBSPAR=$P(PSBCSTR,U,Y) I PSBSPAR=$TR(PSBMVAR,"^") D Q - .I $P(PSBIVPAR,U,Y)="W" D - ..S PSBMVAR=$TR(PSBMVAR,"^") - ..I PSBMW=0 S PSBMW=1 - ..S PSBMWC=PSBMWC+1,PSBMWM="2^The "_PSBSPAR_" has been changed." - ..I $D(PSBMWAR(PSBONX,PSBMVAR)) S PSBOLDT=$O(PSBMWAR(PSBONX,PSBMVAR,"")) I PSBOLDT<$E(PSBDATE,1,12) K PSBMWAR(PSBONX,PSBMVAR,PSBOLDT) - ..S PSBMWAR(PSBONX,PSBMVAR,$E(PSBDATE,1,12))="" - ..S PSBMWAR(PSBONX,$E(PSBDATE,1,12),PSBMVAR)="" - .I $P(PSBIVPAR,U,Y)="I" S PSBMI=1,PSBMIDT=PSBDATE,PSBMIM="-1^IV invalid "_PSBSPAR_".",^TMP("PSBAR",$J,"I")=PSBONX_U_PSBMIDT_U_PSBMIM - Q +PSBPOIV ;BIRMINGHAM/EFC-IV PARAMETER VALIDATION ;Mar 2004 + ;;3.0;BAR CODE MED ADMIN;;Mar 2004 + ; + ; Reference/IA + ; ^DIC(42/1377 + ; ^DIC(42/2440 + ; EN^PSJCBMA1/2829 + ; EN^PSJBCMA2/2830 + ; DIQ(2/10035 + ; +EN(PSBDFN,PSBORD) ; + ; + S DFN=PSBDFN,(PSBMI,PSBMW,PSBMWC,PSBMAUD)=0,(PSBMIDT,PSBMIM)="",PSBONXS=PSBORD_"^" + K ^TMP("PSBAR",$J) S ^TMP("PSBAR",$J,"W",0)=0 + D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBORD) + ; get IV parameters for the current ward + S PSBCSTR="^ADDITIVE^STRENGTH^BOTTLE^SOLUTION^VOLUME^INFUSION RATE^MED ROUTE^SCHEDULE^ADMIN TIME^REMARKS^OTHER PRINT INFO^PROVIDER^START DATE/TIME^STOP DATE/TIME^PROVIDER COMMENTS" + S PSBWARD=$$GET1^DIQ(2,PSBDFN_",",.1),PSBWARD=$$FIND1^DIC(42,"","X",PSBWARD),PSBWDIV=PSBWARD + I $G(PSBWARD)'="",$D(^PSB(53.66,"B",PSBWARD)) D ; if IV paramaters defined for ward use them + .S PSBWARD=$O(^PSB(53.66,"B",PSBWARD,"")) + .S:$D(^PSB(53.66,PSBWARD,1,"B",PSBIVT)) PSBIVPAR=^PSB(53.66,PSBWARD,1,$O(^PSB(53.66,PSBWARD,1,"B",PSBIVT,""),-1),0) + I '$D(PSBIVPAR) S PSBIVPAR=PSBIVT D ; if IV parameters not defined for ward get defaults for division + .D:$D(PSBWDIV) ; Get the appropriate DIV for ward and DIVISIONAL IV PARAMETERS + ..S PSBWDIV=$$GET1^DIQ(42,PSBWDIV_",",.015,"I"),PSBWDIV=$P($$SITE^VASITE(DT,PSBWDIV),U,1) + ..I $G(PSBWDIV)']"" S PSBWDIV="DIV" + ..E S PSBWDIV="DIV.`"_PSBWDIV + ..F X=2:1 Q:$P(PSBCSTR,U,X)="" S PSBIVPAR=PSBIVPAR_U_$P($P($$GET^XPAR(PSBWDIV,"PSBIV "_$P(PSBCSTR,U,X),PSBIVT,"B"),U,2),"-",1) + ..K PSBWDIV ; Kill temp variable. + F PSBC1=1:1 Q:$P(PSBONXS,U,PSBC1)="" D ; process all orders + .D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBONXS,U,PSBC1)) + .K PSBPONX2 I $G(PSBPONX)]"",$G(PSBPONX)["P" S PSBPONX2=PSBPONX D ; Must compare "active" orders for changes made - look beyond "pendings" + ..F D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBPONX2) S PSBPONX2=PSBPONX Q:(PSBPONX2="")!(PSBPONX2'["P") ; + ..D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBONXS,U,PSBC1)) ; Refresh data + ..S:$D(PSBPONX2) PSBPONX=PSBPONX2 K PSBPONX2 + .Q:($L(U_PSBONXS,U_PSBPONX_U)-1)>0 + .I $G(PSBPONX)]"" S PSBONXS=PSBONXS_PSBPONX_U + .K ^TMP("PSJ2",$J) S PSBMAUD=0 D EN^PSJBCMA2(PSBDFN,PSBONX,1) ; check IV parameters against activity log for this order when no "I"nvalid message + .I PSBMI=0 F X=1:1 Q:'$D(^TMP("PSJ2",$J,X)) S PSBCHKV=U_$P(^TMP("PSJ2",$J,X,1),U,3)_U I PSBCSTR[PSBCHKV D MSG(PSBCHKV,$P(^TMP("PSJ2",$J,X,1),U,1)) S PSBMAUD=1 + .K ^TMP("PSJ2",$J) + .I PSBMI=0,$G(PSBPONX)]"" D SAVEPAR,CHKORD ; check IV parameters against previous order when no "I"nvalid message + .D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBONXS,U,PSBC1)) ; restore variable for this order + .; okay - we have invalids and warnings through this order so process bags for this order + .I '$D(PSBUIDA) Q ; got errors and warning but no bags printed for this order - go to the next + .S PSBUID="" F S PSBUID=$O(PSBUIDA(PSBUID),-1) Q:PSBUID="" D + ..F PSBC2=1:1 S PSBMONX=$P(PSBONXS,U,PSBC2) Q:PSBMONX="" D ; check if bag is in 53.79 + ...I $D(^PSB(53.79,"AUID",PSBDFN,PSBMONX,PSBUID)) D + ....S PSBIEN=$O(^PSB(53.79,"AUID",PSBDFN,PSBMONX,PSBUID,"")) + ....S PSBPDT=$P(PSBLBLA(PSBUID),U,1),PSBLSTS=$P(PSBLBLA(PSBUID),3) + ....S $P(X,U,2)=$P(^PSB(53.79,PSBIEN,0),U,9) ; add action status + ....S $P(X,U,3)=$P(^PSB(53.79,PSBIEN,0),U,6) ; add action date/time + ....S $P(X,U,4)=$P(^PSB(53.79,PSBIEN,.1),U,1) ; add order ID was administered for + ..S $P(X,U,5)=PSBONX ; add order ID was printed for + ..S $P(X,U,6)=PSBOSTS ; add order status + ..S $P(X,U,7)=$P(PSBLBLA(PSBUID),U,1) ; add date/time ID was printed + ..S $P(X,U,8)=$P(PSBLBLA(PSBUID),U,3) ; add lable status from pharmacy + ..S $P(X,U,9)="" ; 9 open for later development + ..S $P(X,U,10)=PSBUIDA(PSBUID) ; add return from PSJ1 + ..D BWAR + ..I PSBMW=1 S PSBMWS="W;" F I=1:1:^TMP("PSBAR",$J,"W",0) D S $P(X,U,1)=$P(PSBMWS,";",1,$L(PSBMWS,";")-1) + ...I $P(PSBLBLA(PSBUID),U,1)'>$P(^TMP("PSBAR",$J,"W",I),U,2) D + ....S:(PSBONX=$P(PSBONXS,U,1))&(PSBMAUD=1) PSBMWS=PSBMWS_I_";" + ....S:PSBONX'=$P(PSBONXS,U,1) PSBMWS=PSBMWS_I_";" + ..I PSBMIDT'="",$P(PSBLBLA(PSBUID),U,1)$O(PSBOTMP("ADD",""),-1) D MSG("ADDITIVE",PSBOSP) Q ;previous order has addtives not in current order + I $O(PSBADA(""),-1)<$O(PSBOTMP("ADD",""),-1) D MSG("ADDITIVE",PSBOSP) Q ;previous order missing additives in current order + S X="" F S X=$O(PSBADA(X)) Q:X="" D Q ; check that additives, strength, and bottle are the same + .I PSBADA(X)=PSBOTMP("ADD",X) Q ; everything the same + .I $P(PSBADA(X),U,2)'=$P(PSBOTMP("ADD",X),U,2) D MSG("ADDITIVE",PSBOSP) Q + .I $P(PSBADA(X),U,4)'=$P(PSBOTMP("ADD",X),U,4) D MSG("STRENGTH",PSBOSP) Q + Q + ; +CHKSOL ; + N X,Y + I '$D(PSBSOLA),'$D(PSBOTMP("SOL")) Q ; no solutions + I $O(PSBSOLA(""),-1)>$O(PSBOTMP("SOL",""),-1) D MSG("SOLUTION",PSBOSP) Q ;previous order has solutions not in current order + I $O(PSBSOLA(""),-1)<$O(PSBOTMP("SOL",""),-1) D MSG("SOLUTION",PSBOSP) Q ;previous order missing solutions in current order + S X="" F S X=$O(PSBSOLA(X)) Q:X="" D Q ; check that solutions volume are the same + .I PSBSOLA(X)=PSBOTMP("SOL",X) Q ; everything the same + .I $P(PSBSOLA(X),U,2)'=$P(PSBOTMP("SOL",X),U,2) D MSG("SOLUTION",PSBOSP) Q + .I $P(PSBSOLA(X),U,4)'=$P(PSBOTMP("SOL",X),U,4) D MSG("VOLUME",PSBOSP) Q + Q + ; +BWAR ; + N X,Y,Z,PSBONX + S X=^TMP("PSBAR",$J,"W",0)+1 + S Z="" F Z=1:1 S PSBONX=$P(PSBONXS,U,Z) Q:$G(PSBONX)="" D ; Display "Warning"s for changes + .I '$D(PSBMWAR(PSBONX)) Q + .S Y="" F S Y=$O(PSBMWAR(PSBONX,Y)) Q:Y'?.N1".".N D + ..S Z="",PSBYS="" F S Z=$O(PSBMWAR(PSBONX,Y,Z)) Q:Z="" S PSBYS=PSBYS_Z_";" + ..S PSBYS=$P(PSBYS,";",1,$L(PSBYS,";")-1) + ..S ^TMP("PSBAR",$J,"W",X)=PSBONX_U_Y_U_"2^The "_PSBYS_" was changed on",^TMP("PSBAR",$J,"W",0)=X,X=X+1 + .K PSBMWAR(PSBONX) + Q + ; +MSG(PSBMVAR,PSBDATE) ; + I PSBMI=1 Q ;already have an invalid don't need anymore + F Y=1:1 S PSBSPAR=$P(PSBCSTR,U,Y) I PSBSPAR=$TR(PSBMVAR,"^") D Q + .I $P(PSBIVPAR,U,Y)="W" D + ..S PSBMVAR=$TR(PSBMVAR,"^") + ..I PSBMW=0 S PSBMW=1 + ..S PSBMWC=PSBMWC+1,PSBMWM="2^The "_PSBSPAR_" has been changed." + ..I $D(PSBMWAR(PSBONX,PSBMVAR)) S PSBOLDT=$O(PSBMWAR(PSBONX,PSBMVAR,"")) I PSBOLDT<$E(PSBDATE,1,12) K PSBMWAR(PSBONX,PSBMVAR,PSBOLDT) + ..S PSBMWAR(PSBONX,PSBMVAR,$E(PSBDATE,1,12))="" + ..S PSBMWAR(PSBONX,$E(PSBDATE,1,12),PSBMVAR)="" + .I $P(PSBIVPAR,U,Y)="I" S PSBMI=1,PSBMIDT=PSBDATE,PSBMIM="-1^IV invalid "_PSBSPAR_".",^TMP("PSBAR",$J,"I")=PSBONX_U_PSBMIDT_U_PSBMIM + Q diff --git a/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBRPC2.m b/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBRPC2.m index 3a3bb2bc..938f8b07 100644 --- a/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBRPC2.m +++ b/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBRPC2.m @@ -1,137 +1,137 @@ -PSBRPC2 ;BIRMINGHAM/EFC-BCMA RPC BROKER CALLS ;7:42 PM 30 Jan 2008 - ;;3.0;BAR CODE MED ADMIN;**6,3,16,32,WVEHR1**;WorldVistA 30-Jan-08;Build 4 - ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified. - ; - ;Modified from FOIA VISTA, - ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;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 Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - ; Reference/IA - ; File 50/221 - ; File 52.6/436 - ; File 52.7/437 - ; File 200/10060 -GETOHIST(RESULTS,DFN,PSBORD) ; - S RESULTS=$NAME(^TMP("PSB",$J)),PSB=0 K ^TMP("PSB",$J) - S ^TMP("PSB",$J,0)=1,^TMP("PSB",$J,1)="-1^No History On File" - D NOW^%DTC S PSBNOW=$P(%,".",1),PSBNOWZ=% - D EN^PSBPOIV(DFN,PSBORD) - S PSBUID=DFN_"V"_99999 F S PSBUID=$O(^TMP("PSBAR",$J,PSBUID),-1) Q:PSBUID="" D - .S PSBUIDS=^TMP("PSBAR",$J,PSBUID) - .I ((PSBOSTS="D")!(PSBOSTS="E")),$P(PSBUIDS,U,2)'="I",$P(PSBUIDS,U,2)'="S" Q ; only want the infusing bag on a dc'ed order - .I (PSBOSTS="A"),(PSBOSP0 S RESULTS(0)=1,RESULTS(1)="-1^No History On File" Q - M PSBMLA=^PSB(53.79,PSBIEN) - S X=$P(^PSB(53.79,PSBIEN,0),U,9) - S PSBLAC=$S(X="I":"INFUSING",X="G":"GIVEN",X="C":"COMPLETE",X="H":"HELD",X="R":"REFUSED",X="RM":"REMOVED",X="S":"STOPPED",X="M":"MISSING",1:"NO ACTION") - ; comments - S PSBX="0" F S PSBX=$O(PSBMLA(.3,PSBX)) Q:PSBX="" S PSBTMP(10000000-$P(PSBMLA(.3,PSBX,0),U,3),"C")=$P(PSBMLA(.3,PSBX,0),U,3)_U_$$INITIAL($P(PSBMLA(.3,PSBX,0),U,2))_U_U_$P(PSBMLA(.3,PSBX,0),U,1) - ; audit - S PSBGA="" I $D(PSBMLA(.9,0)) D - .S PSBX="0" F S PSBX=$O(PSBMLA(.9,PSBX)) Q:PSBX="" I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D Q - ..S PSBDATE=$P(PSBMLA(0),U,4) I (PSBX-2)>0 D DT^DILF("ENPST",$P(PSBMLA(.9,PSBX-2,0),"'",2),.PSBDATE) - ..S PSBTMP(10000000-PSBDATE,"B")=PSBDATE_U_$$INITIAL($P(PSBMLA(0),U,5))_U_$P(PSBMLA(.9,PSBX,0),"'",2) - ..S PSBGA=1 - .S PSBX="0" F S PSBX=$O(PSBMLA(.9,PSBX)) Q:PSBX="" I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D - ..S PSBTMP(10000000-$P(PSBMLA(.9,PSBX,0),U,1),"B")=$P(PSBMLA(.9,PSBX,0),U,1)_U_$$INITIAL($P(PSBMLA(.9,PSBX,0),U,2))_U_$P($P(PSBMLA(.9,PSBX,0),U,3),"'",2) - ..S PSBGA=1 - I PSBGA'=1 S PSBTMP(10000000-$P(PSBMLA(0),U,6),"A")=$P(PSBMLA(0),U,6)_U_$$INITIAL($P(PSBMLA(0),U,7))_U_PSBLAC - S PSBQRY="PSBTMP",PSBCNT=1 F S PSBQRY=$Q(@PSBQRY) Q:PSBQRY="" D ; does comment go with action - .S PSBPQRY=$Q(@PSBQRY,-1) - .I PSBPQRY="" S RESULTS(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q ; no previous action - .I $QS(PSBPQRY,2)="C" S RESULTS(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q ; previous line is a comment - .I $QS(PSBQRY,2)="C",$E($P(@$Q(@PSBQRY,-1),U,1),1,12)=$E($P(@PSBQRY,U,1),1,12),$P(@$Q(@PSBQRY,-1),U,2)=$P(@PSBQRY,U,2) S X=$P(@PSBQRY,U,4),$P(RESULTS(PSBCNT-1),U,4)=X Q - .S RESULTS(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 - S RESULTS(0)=PSBCNT-1 - K PSBMLA,PSBIEN,PSBTMP,PSBQRY - Q - ; -INITIAL(PSBDUZ) ; - Q $$GET1^DIQ(200,PSBDUZ,"INITIAL") -SCANMED(RESULTS,PSBDIEN,PSBTAB) ; Lookup Medication - ; - ; RPC: PSB SCANMED - ; - ; Description: - ; Does a lookup on file 50 returns -1 on invalid lookup or - ; IEN^DrugName on success - ; - D NOW^%DTC S PSBDT=% - S PSBCNT=0 - I $L(PSBDIEN)>40 S PSBDIEN=$E(PSBDIEN,1,40) - S RESULTS(PSBCNT)=1 - S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)="-1^Invalid Medication Lookup" - I $$GET^XPAR("DIV","PSB ROBOT RX"),PSBDIEN?1"3"15N!(PSBDIEN?1"3"17N),123[$E(PSBDIEN,12) S PSBDIEN=$E(PSBDIEN,2,11) - I PSBTAB="UDTAB" D Q - .S X=$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C") - .I X<1 Q - .E S RESULTS(PSBCNT)="DD"_U_X_U_$$GET1^DIQ(50,X_",",.01) - ; - ; IV/IVPB ward stock scan - ; - S PSBDIEN=$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C") I PSBDIEN<1 Q - S PSBOIT=$$GET1^DIQ(50,PSBDIEN,"PHARMACY ORDERABLE ITEM","I") - I $D(^PSDRUG("A527",PSBDIEN)) S X="" F S X=$O(^PSDRUG("A527",PSBDIEN,X)) Q:X="" D - .S PSBINACT=$$GET1^DIQ(52.7,X,8,"I") I PSBINACT]"",PSBINACT'>PSBDT Q - .S RESULTS(PSBCNT)="SOL"_U_X_U_$$GET1^DIQ(50,PSBDIEN_",",.01),PSBCNT=PSBCNT+1,RESULTS(0)=PSBCNT-1 - I $D(^PSDRUG("A526",PSBDIEN)) S X="" F S X=$O(^PSDRUG("A526",PSBDIEN,X)) Q:X="" D - .S PSBINACT=$$GET1^DIQ(52.6,X,12,"I") I PSBINACT]"",PSBINACT'>PSBDT Q - .S RESULTS(PSBCNT)="ADD"_U_X_U_$$GET1^DIQ(50,PSBDIEN_",",.01),PSBCNT=PSBCNT+1,RESULTS(0)=PSBCNT-1 - ; - I PSBTAB="PBTAB",$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C")'<1 S X=$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C"),RESULTS(PSBCNT)="DD"_U_X_U_$$GET1^DIQ(50,X_",",.01),PSBCNT=PSBCNT+1,RESULTS(0)=PSBCNT-1 - Q - ; +PSBRPC2 ;BIRMINGHAM/EFC-BCMA RPC BROKER CALLS ;7:42 PM 30 Jan 2008 + ;;3.0;BAR CODE MED ADMIN;**6,3,16,32,WVEHR1**;WorldVistA 30-Jan-08 + ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified. + ; + ;Modified from FOIA VISTA, + ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;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 Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + ; Reference/IA + ; File 50/221 + ; File 52.6/436 + ; File 52.7/437 + ; File 200/10060 +GETOHIST(RESULTS,DFN,PSBORD) ; + S RESULTS=$NAME(^TMP("PSB",$J)),PSB=0 K ^TMP("PSB",$J) + S ^TMP("PSB",$J,0)=1,^TMP("PSB",$J,1)="-1^No History On File" + D NOW^%DTC S PSBNOW=$P(%,".",1),PSBNOWZ=% + D EN^PSBPOIV(DFN,PSBORD) + S PSBUID=DFN_"V"_99999 F S PSBUID=$O(^TMP("PSBAR",$J,PSBUID),-1) Q:PSBUID="" D + .S PSBUIDS=^TMP("PSBAR",$J,PSBUID) + .I ((PSBOSTS="D")!(PSBOSTS="E")),$P(PSBUIDS,U,2)'="I",$P(PSBUIDS,U,2)'="S" Q ; only want the infusing bag on a dc'ed order + .I (PSBOSTS="A"),(PSBOSP0 S RESULTS(0)=1,RESULTS(1)="-1^No History On File" Q + M PSBMLA=^PSB(53.79,PSBIEN) + S X=$P(^PSB(53.79,PSBIEN,0),U,9) + S PSBLAC=$S(X="I":"INFUSING",X="G":"GIVEN",X="C":"COMPLETE",X="H":"HELD",X="R":"REFUSED",X="RM":"REMOVED",X="S":"STOPPED",X="M":"MISSING",1:"NO ACTION") + ; comments + S PSBX="0" F S PSBX=$O(PSBMLA(.3,PSBX)) Q:PSBX="" S PSBTMP(10000000-$P(PSBMLA(.3,PSBX,0),U,3),"C")=$P(PSBMLA(.3,PSBX,0),U,3)_U_$$INITIAL($P(PSBMLA(.3,PSBX,0),U,2))_U_U_$P(PSBMLA(.3,PSBX,0),U,1) + ; audit + S PSBGA="" I $D(PSBMLA(.9,0)) D + .S PSBX="0" F S PSBX=$O(PSBMLA(.9,PSBX)) Q:PSBX="" I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D Q + ..S PSBDATE=$P(PSBMLA(0),U,4) I (PSBX-2)>0 D DT^DILF("ENPST",$P(PSBMLA(.9,PSBX-2,0),"'",2),.PSBDATE) + ..S PSBTMP(10000000-PSBDATE,"B")=PSBDATE_U_$$INITIAL($P(PSBMLA(0),U,5))_U_$P(PSBMLA(.9,PSBX,0),"'",2) + ..S PSBGA=1 + .S PSBX="0" F S PSBX=$O(PSBMLA(.9,PSBX)) Q:PSBX="" I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D + ..S PSBTMP(10000000-$P(PSBMLA(.9,PSBX,0),U,1),"B")=$P(PSBMLA(.9,PSBX,0),U,1)_U_$$INITIAL($P(PSBMLA(.9,PSBX,0),U,2))_U_$P($P(PSBMLA(.9,PSBX,0),U,3),"'",2) + ..S PSBGA=1 + I PSBGA'=1 S PSBTMP(10000000-$P(PSBMLA(0),U,6),"A")=$P(PSBMLA(0),U,6)_U_$$INITIAL($P(PSBMLA(0),U,7))_U_PSBLAC + S PSBQRY="PSBTMP",PSBCNT=1 F S PSBQRY=$Q(@PSBQRY) Q:PSBQRY="" D ; does comment go with action + .S PSBPQRY=$Q(@PSBQRY,-1) + .I PSBPQRY="" S RESULTS(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q ; no previous action + .I $QS(PSBPQRY,2)="C" S RESULTS(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q ; previous line is a comment + .I $QS(PSBQRY,2)="C",$E($P(@$Q(@PSBQRY,-1),U,1),1,12)=$E($P(@PSBQRY,U,1),1,12),$P(@$Q(@PSBQRY,-1),U,2)=$P(@PSBQRY,U,2) S X=$P(@PSBQRY,U,4),$P(RESULTS(PSBCNT-1),U,4)=X Q + .S RESULTS(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 + S RESULTS(0)=PSBCNT-1 + K PSBMLA,PSBIEN,PSBTMP,PSBQRY + Q + ; +INITIAL(PSBDUZ) ; + Q $$GET1^DIQ(200,PSBDUZ,"INITIAL") +SCANMED(RESULTS,PSBDIEN,PSBTAB) ; Lookup Medication + ; + ; RPC: PSB SCANMED + ; + ; Description: + ; Does a lookup on file 50 returns -1 on invalid lookup or + ; IEN^DrugName on success + ; + D NOW^%DTC S PSBDT=% + S PSBCNT=0 + I $L(PSBDIEN)>40 S PSBDIEN=$E(PSBDIEN,1,40) + S RESULTS(PSBCNT)=1 + S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)="-1^Invalid Medication Lookup" + I $$GET^XPAR("DIV","PSB ROBOT RX"),PSBDIEN?1"3"15N!(PSBDIEN?1"3"17N),123[$E(PSBDIEN,12) S PSBDIEN=$E(PSBDIEN,2,11) + I PSBTAB="UDTAB" D Q + .S X=$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C") + .I X<1 Q + .E S RESULTS(PSBCNT)="DD"_U_X_U_$$GET1^DIQ(50,X_",",.01) + ; + ; IV/IVPB ward stock scan + ; + S PSBDIEN=$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C") I PSBDIEN<1 Q + S PSBOIT=$$GET1^DIQ(50,PSBDIEN,"PHARMACY ORDERABLE ITEM","I") + I $D(^PSDRUG("A527",PSBDIEN)) S X="" F S X=$O(^PSDRUG("A527",PSBDIEN,X)) Q:X="" D + .S PSBINACT=$$GET1^DIQ(52.7,X,8,"I") I PSBINACT]"",PSBINACT'>PSBDT Q + .S RESULTS(PSBCNT)="SOL"_U_X_U_$$GET1^DIQ(50,PSBDIEN_",",.01),PSBCNT=PSBCNT+1,RESULTS(0)=PSBCNT-1 + I $D(^PSDRUG("A526",PSBDIEN)) S X="" F S X=$O(^PSDRUG("A526",PSBDIEN,X)) Q:X="" D + .S PSBINACT=$$GET1^DIQ(52.6,X,12,"I") I PSBINACT]"",PSBINACT'>PSBDT Q + .S RESULTS(PSBCNT)="ADD"_U_X_U_$$GET1^DIQ(50,PSBDIEN_",",.01),PSBCNT=PSBCNT+1,RESULTS(0)=PSBCNT-1 + ; + I PSBTAB="PBTAB",$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C")'<1 S X=$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C"),RESULTS(PSBCNT)="DD"_U_X_U_$$GET1^DIQ(50,X_",",.01),PSBCNT=PSBCNT+1,RESULTS(0)=PSBCNT-1 + Q + ; diff --git a/r/BENEFICIARY_TRAVEL-DGBT/DGBTCE.m b/r/BENEFICIARY_TRAVEL-DGBT/DGBTCE.m index 509098ac..6e311aed 100644 --- a/r/BENEFICIARY_TRAVEL-DGBT/DGBTCE.m +++ b/r/BENEFICIARY_TRAVEL-DGBT/DGBTCE.m @@ -1,58 +1,58 @@ -DGBTCE ;ALB/SCK - BENEFICIARY TRAVEL CLAIM RE-ENTER/EDIT; 12/15/92 06/04/93 - ;;1.0;Beneficiary Travel;**2,14**;September 25, 2001;Build 7 - Q -SCREEN ; - D QUIT^DGBTCE1 - D SCREEN^DGBTEE1 Q:'$D(^DGBT(392,DGBTDT,0)) I DGBTTOUT=-1 S DGBTTOUT=1 Q - I $D(DGBTOACT) I DGBTOACT'=DGBTACCT S DGBTVAR(0)=^DGBT(392,DGBTDT,0) D FILE - S (DGBTMAL,DGBTFAB,DGBTME,DGBTCP,DGBTFLAG,DGBTDE,DGBTDCV,DGBTDCM,DGBTDPV,DGBTDPM)=0 - S:$G(DGBTACCT)'>0 DGBTACCT=$P($G(DGBTVAR(0)),U,6) - S DGBTAP=VADM(1),DIE="^DGBT(392,",DA=DGBTDT,DR=$S(DGBTACCT=4:"42//"_DGBTAP,DGBTACCT=5:"43;S DGBTCP=X;42//"_DGBTAP,1:"44") - D ^DIE K DIE,DQ,DR I $D(DTOUT)!($D(Y)) S DGBTTOUT=1 Q - I DGBTACCT=4!(DGBTACCT=5) S:$D(^DGBT(392,DGBTDT,"M")) DGBTWAY=$P(^("M"),"^"),DGBTMILE=$P(^("M"),"^",2) S:$D(^DGBT(392,DGBTDT,"D")) DGBTCITY=$P(^("D"),"^",4),DGBTSTAT=$P(^("D"),"^",5) - S DGBTDIV=$P($G(^DGBT(392,DA,0)),U,11),DGBTRMK=$S($D(DGBTREC):$$DICLKUP^DGBTUTL(DGBTREC,DGBTDIV,4),1:"") - S DIE="^DGBT(392,",DA=DGBTDT - S DR="3////"_DGBTELIG_";6////"_DGBTACTN_";21;I X="""" S Y=24;22;I X="""" S Y=24;23;24;24.1;24.2;25;I X="""" S Y=28;26;I X="""" S Y=28;27;28;28.1;28.2" - D ^DIE K DIE I $D(DTOUT)!($D(Y)) S DGBTTOUT=1 Q - W:DGBTRMK]"" !!,*7,"MILEAGE REMARKS: ",DGBTRMK,! - I DGBTACCT=4!(DGBTACCT=5) D Q:$G(DGBTTOUT) - . S DR="31//;S DGBTOWRT=X;32//;S DGBTML=X" - . I DGBTACCT=5&(DGBTCP=1) S DGBTMR=DGBTMR1 - . S DIE="^DGBT(392,",DA=DGBTDT - . D ^DIE K DIE,DQ,DR I $D(DTOUT)!($D(Y)) S DGBTTOUT=1 -DIE1 ; - S DGBTMLT=$S($D(DGBTVAR("M"))&((DGBTACCT=4)!(DGBTACCT=5)):$J((DGBTOWRT*DGBTML*DGBTMR),0,2),1:""),$P(^DGBT(392,DGBTDT,"M"),"^",3)=DGBTMLT,$P(DGBTVAR("M"),"^",3)=DGBTMLT - ; - S DIE="^DGBT(392,",DA=DGBTDT - I 'DGBTCORE D - . S DR="I DGBTACCT=4!(DGBTACCT=5) S Y=""@1"";41;7;@1;I DGBTMLFB=0 S Y=""@2"";34//;S DGBTMAL=X;35//;S DGBTFAB=X;@2;8//;S DGBTME=X" - I DGBTCORE S DR="" D - . S DR(1,392,1)="I DGBTACCT=4!(DGBTACCT=5) S Y=""@1"";41;@3;14;S DGBTCSL=$$AFTER^DGBTCSL(392,D0,X,$G(DGBTPRV)) S:DGBTCSL<1 Y=""@3"" W:DGBTCSL<1 "" Required"" K DGBTPRV,DGBTCSL;" - . S DR(1,392,2)="@1;I DGBTMLFB=0 S Y=""@2"";34//;S DGBTMAL=X;35//;S DGBTFAB=X;@2;8//;S DGBTME=X" -DIE3 ; - D ^DIE K DIE,DQ,DR I $D(DTOUT)!($D(Y)) S DGBTTOUT=1 Q - ; -TCOST ;CALCULATE TOTAL COST AND MONTHLY CUM. DEDUCTIBLE -MLFB ; - S DGBTMAF=$S(DGBTMLFB:DGBTMAL+DGBTFAB,1:0),DGBTMETC=DGBTME+$S($D(DGBTMAL):DGBTMAL,1:0) - I DGBTACCT'=4&(DGBTACCT'=5) S DGBTPA=DGBTMAF+DGBTME G CONT - I $D(DGBTMLT) S DGBTTC=$S(DGBTMLT+DGBTMAF'>DGBTMETC:DGBTMLT+DGBTMAF,DGBTMLT+DGBTMAF>DGBTMETC&(DGBTME>0):DGBTMETC,DGBTME'>0:DGBTMLT+DGBTMAF,1:DGBTMETC) - I DGBTACCT=5 S DGBTDE=0 S DGBTPA=$S((DGBTMLT+DGBTMAF)'=0:DGBTTC,1:DGBTMETC) G CONT -DED ; - F I=$E(DGBTDT,1,5)_"00.2399":0 S I=$O(^DGBT(392,"C",DFN,I)) Q:'I!($E(I,1,5)>$E(DGBTDT,1,5)) I I'=DGBTDT S DGBTDCM=DGBTDCM+($P(^DGBT(392,I,0),"^",9)) - I $D(^DG(43.1,$O(^DG(43.1,(9999999.99999-DGBTDT))),"BT")) S DGBTRATE=^("BT"),DGBTDPV=$P(DGBTRATE,"^"),DGBTDPM=$P(DGBTRATE,"^",2),DGBTMR=$P(DGBTRATE,"^",3) - I $D(^DGBT(392,DGBTDT,"M")) S:$P(^("M"),"^")=1 DGBTDPV=DGBTDPV/2 I DGBTWAY'=$P(^("M"),"^")!(DGBTMILE'=$P(^("M"),"^",2)) I $D(^DGBT(392,DGBTDT,0)) S $P(^(0),"^",9)="" K ^DGBT(392,"AD",$P(^(0),"^",2),$E(DGBTDT,2,5),DGBTDT) - S DGBTDRM=DGBTDPM-DGBTDCM - S DGBTDCV=$S(DGBTDCM'DGBTDPV):DGBTTC,DGBTDRM'>DGBTDPV&(DGBTTC'>DGBTDRM):DGBTTC,DGBTDRM'>DGBTDPV&(DGBTTC'DGBTTC DGBTDE=DGBTTC,DGBTFLAG=2 S:DGBTDE>DGBTDRM DGBTDE=DGBTDRM,DGBTFLAG=1" -DIE4 ; - S DIE="^DGBT(392,",DA=DGBTDT D ^DIE K DIE,DQ,DR I $D(DTOUT)!($D(Y)) S DGBTTOUT=1 Q -CONT ; - D CONT^DGBTCE1 - Q -FILE ; Reset values if account changes - S DGBTVAR(0)=$P(DGBTVAR(0),"^",1,6)_"^^0^^"_$S($L(DGBTVAR(0),"^")>10:$P(DGBTVAR(0),"^",10,$L(DGBTVAR(0),"^")),1:""),DGBTVAR("A")="^"_$P(DGBTVAR("A"),"^",2)_"^^^"_$S($L(DGBTVAR("A"),"^")>4:$P(DGBTVAR("A"),"^",5,$L(DGBTVAR("A"),"^")),1:"") - I DGBTACCT<4 S DGBTVAR("M")="^^^"_$S($L(DGBTVAR("M"),"^")>3:$P(DGBTVAR("M"),"^",4,$L(DGBTVAR("M"),"^")),1:"") - S ^DGBT(392,DGBTDT,0)=DGBTVAR(0),^("A")=DGBTVAR("A") S:DGBTACCT<4 ^("M")=DGBTVAR("M") S DA=DGBTDT,DIK="^DGBT(392," D IX^DIK - Q +DGBTCE ;ALB/SCK - BENEFICIARY TRAVEL CLAIM RE-ENTER/EDIT; 12/15/92 06/04/93 + ;;1.0;Beneficiary Travel;**2**;September 25, 2001 + Q +SCREEN ; + D QUIT^DGBTCE1 + D SCREEN^DGBTEE1 Q:'$D(^DGBT(392,DGBTDT,0)) I DGBTTOUT=-1 S DGBTTOUT=1 Q + I $D(DGBTOACT) I DGBTOACT'=DGBTACCT S DGBTVAR(0)=^DGBT(392,DGBTDT,0) D FILE + S (DGBTMAL,DGBTFAB,DGBTME,DGBTCP,DGBTFLAG,DGBTDE,DGBTDCV,DGBTDCM,DGBTDPV,DGBTDPM)=0 + S:$G(DGBTACCT)'>0 DGBTACCT=$P($G(DGBTVAR(0)),U,6) + S DGBTAP=VADM(1),DIE="^DGBT(392,",DA=DGBTDT,DR=$S(DGBTACCT=4:"42//"_DGBTAP,DGBTACCT=5:"43;S DGBTCP=X;42//"_DGBTAP,1:"44") + D ^DIE K DIE,DQ,DR I $D(DTOUT)!($D(Y)) S DGBTTOUT=1 Q + I DGBTACCT=4!(DGBTACCT=5) S:$D(^DGBT(392,DGBTDT,"M")) DGBTWAY=$P(^("M"),"^"),DGBTMILE=$P(^("M"),"^",2) S:$D(^DGBT(392,DGBTDT,"D")) DGBTCITY=$P(^("D"),"^",4),DGBTSTAT=$P(^("D"),"^",5) + S DGBTDIV=$P($G(^DGBT(392,DA,0)),U,11),DGBTRMK=$S($D(DGBTREC):$$DICLKUP^DGBTUTL(DGBTREC,DGBTDIV,4),1:"") + S DIE="^DGBT(392,",DA=DGBTDT + S DR="3////"_DGBTELIG_";6////"_DGBTACTN_";21;I X="""" S Y=24;22;I X="""" S Y=24;23;24;24.1;24.2;25;I X="""" S Y=28;26;I X="""" S Y=28;27;28;28.1;28.2" + D ^DIE K DIE I $D(DTOUT)!($D(Y)) S DGBTTOUT=1 Q + W:DGBTRMK]"" !!,*7,"MILEAGE REMARKS: ",DGBTRMK,! + I DGBTACCT=4!(DGBTACCT=5) D Q:$G(DGBTTOUT) + . S DR="31//;S DGBTOWRT=X;32//;S DGBTML=X" + . I DGBTACCT=5&(DGBTCP=1) S DGBTMR=DGBTMR1 + . S DIE="^DGBT(392,",DA=DGBTDT + . D ^DIE K DIE,DQ,DR I $D(DTOUT)!($D(Y)) S DGBTTOUT=1 +DIE1 ; + S DGBTMLT=$S($D(DGBTVAR("M"))&((DGBTACCT=4)!(DGBTACCT=5)):DGBTOWRT*DGBTML*DGBTMR,1:""),$P(^DGBT(392,DGBTDT,"M"),"^",3)=DGBTMLT,$P(DGBTVAR("M"),"^",3)=DGBTMLT + ; + S DIE="^DGBT(392,",DA=DGBTDT + I 'DGBTCORE D + . S DR="I DGBTACCT=4!(DGBTACCT=5) S Y=""@1"";41;7;@1;I DGBTMLFB=0 S Y=""@2"";34//;S DGBTMAL=X;35//;S DGBTFAB=X;@2;8//;S DGBTME=X" + I DGBTCORE S DR="" D + . S DR(1,392,1)="I DGBTACCT=4!(DGBTACCT=5) S Y=""@1"";41;@3;14;S DGBTCSL=$$AFTER^DGBTCSL(392,D0,X,$G(DGBTPRV)) S:DGBTCSL<1 Y=""@3"" W:DGBTCSL<1 "" Required"" K DGBTPRV,DGBTCSL;" + . S DR(1,392,2)="@1;I DGBTMLFB=0 S Y=""@2"";34//;S DGBTMAL=X;35//;S DGBTFAB=X;@2;8//;S DGBTME=X" +DIE3 ; + D ^DIE K DIE,DQ,DR I $D(DTOUT)!($D(Y)) S DGBTTOUT=1 Q + ; +TCOST ;CALCULATE TOTAL COST AND MONTHLY CUM. DEDUCTIBLE +MLFB ; + S DGBTMAF=$S(DGBTMLFB:DGBTMAL+DGBTFAB,1:0),DGBTMETC=DGBTME+$S($D(DGBTMAL):DGBTMAL,1:0) + I DGBTACCT'=4&(DGBTACCT'=5) S DGBTPA=DGBTMAF+DGBTME G CONT + I $D(DGBTMLT) S DGBTTC=$S(DGBTMLT+DGBTMAF'>DGBTMETC:DGBTMLT+DGBTMAF,DGBTMLT+DGBTMAF>DGBTMETC&(DGBTME>0):DGBTMETC,DGBTME'>0:DGBTMLT+DGBTMAF,1:DGBTMETC) + I DGBTACCT=5 S DGBTDE=0 S DGBTPA=$S((DGBTMLT+DGBTMAF)'=0:DGBTTC,1:DGBTMETC) G CONT +DED ; + F I=$E(DGBTDT,1,5)_"00.2399":0 S I=$O(^DGBT(392,"C",DFN,I)) Q:'I!($E(I,1,5)>$E(DGBTDT,1,5)) I I'=DGBTDT S DGBTDCM=DGBTDCM+($P(^DGBT(392,I,0),"^",9)) + I $D(^DG(43.1,$O(^DG(43.1,(9999999.99999-DGBTDT))),"BT")) S DGBTRATE=^("BT"),DGBTDPV=$P(DGBTRATE,"^"),DGBTDPM=$P(DGBTRATE,"^",2),DGBTMR=$P(DGBTRATE,"^",3) + I $D(^DGBT(392,DGBTDT,"M")) S:$P(^("M"),"^")=1 DGBTDPV=DGBTDPV/2 I DGBTWAY'=$P(^("M"),"^")!(DGBTMILE'=$P(^("M"),"^",2)) I $D(^DGBT(392,DGBTDT,0)) S $P(^(0),"^",9)="" K ^DGBT(392,"AD",$P(^(0),"^",2),$E(DGBTDT,2,5),DGBTDT) + S DGBTDRM=DGBTDPM-DGBTDCM + S DGBTDCV=$S(DGBTDCM'DGBTDPV):DGBTTC,DGBTDRM'>DGBTDPV&(DGBTTC'>DGBTDRM):DGBTTC,DGBTDRM'>DGBTDPV&(DGBTTC'DGBTTC DGBTDE=DGBTTC,DGBTFLAG=2 S:DGBTDE>DGBTDRM DGBTDE=DGBTDRM,DGBTFLAG=1" +DIE4 ; + S DIE="^DGBT(392,",DA=DGBTDT D ^DIE K DIE,DQ,DR I $D(DTOUT)!($D(Y)) S DGBTTOUT=1 Q +CONT ; + D CONT^DGBTCE1 + Q +FILE ; Reset values if account changes + S DGBTVAR(0)=$P(DGBTVAR(0),"^",1,6)_"^^0^^"_$S($L(DGBTVAR(0),"^")>10:$P(DGBTVAR(0),"^",10,$L(DGBTVAR(0),"^")),1:""),DGBTVAR("A")="^"_$P(DGBTVAR("A"),"^",2)_"^^^"_$S($L(DGBTVAR("A"),"^")>4:$P(DGBTVAR("A"),"^",5,$L(DGBTVAR("A"),"^")),1:"") + I DGBTACCT<4 S DGBTVAR("M")="^^^"_$S($L(DGBTVAR("M"),"^")>3:$P(DGBTVAR("M"),"^",4,$L(DGBTVAR("M"),"^")),1:"") + S ^DGBT(392,DGBTDT,0)=DGBTVAR(0),^("A")=DGBTVAR("A") S:DGBTACCT<4 ^("M")=DGBTVAR("M") S DA=DGBTDT,DIK="^DGBT(392," D IX^DIK + Q diff --git a/r/BENEFICIARY_TRAVEL-DGBT/DGBTCR.m b/r/BENEFICIARY_TRAVEL-DGBT/DGBTCR.m index 9df48c3e..c754a926 100644 --- a/r/BENEFICIARY_TRAVEL-DGBT/DGBTCR.m +++ b/r/BENEFICIARY_TRAVEL-DGBT/DGBTCR.m @@ -1,59 +1,58 @@ -DGBTCR ;ALB/SCK - BENEFICIARY TRAVEL FORM 70-3542d VARIABLES; 2/7/88@08:00 ;6/11/93@09:30 - ;;1.0;Beneficiary Travel;**7,14**;September 25, 2001;Build 7 - ;Modification of AIVBTPRT / pmg / GRAND ISLAND ; 07 Jul 88 12:02 PM -START Q:'$D(DGBTDT) - S DGBTVAR(0)=$G(^DGBT(392,+DGBTDT,0)),DGBTACCT=$P($G(^DGBT(392.3,+$P(DGBTVAR(0),"^",6),0)),"^",5) - Q:DGBTACCT'>3 - W !!,*7,"This needs to be printed at 132 columns" - S DGPGM="PRINT^DGBTCR",DGVAR="DGBTDT" - S %ZIS="PMQ" D ^%ZIS G QUIT:POP - I $D(IO("Q")) D QUE G QUIT - D PRINT -QUIT ; - D:'$D(ZTQUEUED) ^%ZISC - K DGPGM,DGVAR,VADAT,VADATE,I,X,X2,DGBTVAR,DGBTCC,DGBTDIV,DGBTDOB,DGBTINS,DGBTINS1,DGBTINS2,DGBTCNA,DGBTCSZ,DGBTCNU,DGBTTCTY,DGBTFCTY,DGBTDT,DGBTACCT,DFN,Y - K DGBTM6,DGBTM7,DGBTM8,DGBTM9,DGBTM10,DGBTM11,DGBTM12,DGBTM13,DGBTM14,DGBTM15,DGBTM16,DGBTM17,DGBTRATE,DGBTSCP,DGBTSSN,DGBTST - Q -PRINT ; - U IO D SET,PRINT^DGBTCR1,PRINT^DGBTCR2,KVAR^VADPT - Q -SET S DFN=$P(^DGBT(392,DGBTDT,0),"^",2) D 6^VADPT S (DGBTFCTY,DGBTTCTY)="" -NODES F I=0,"A","D","M","R","T" S DGBTVAR(I)=$S($D(^DGBT(392,DGBTDT,I)):^(I),1:"") - I $D(^DG(43.1,$O(^DG(43.1,(9999999.99999-DGBTDT))),"BT")) S DGBTRATE=^("BT"),DGBTM7=$S($P(DGBTVAR("A"),"^",3)=1:$P(DGBTRATE,"^",5),1:$P(DGBTRATE,"^",3)) - I $P(DGBTVAR("D"),"^",4)]"" S DGBTCNA=$P(DGBTVAR("D"),"^",4) D CITY I DGBTCSZ[DGBTCNA D - . S DGBTCSZ=DGBTCNA_", "_$S(+$P(DGBTVAR("D"),"^",5)>0:$P(^DIC(5,$P(DGBTVAR("D"),"^",5),0),U,2),1:"")_" " - . S Y=$P(DGBTVAR("D"),U,6),Y=$E(Y,1,5)_$S($E(Y,6,9)]"":"-"_$E(Y,6,9),1:""),DGBTCSZ=DGBTCSZ_Y,DGBTFCTY=DGBTCSZ - I $P(DGBTVAR("T"),"^",4)]"" S DGBTCNA=$P(DGBTVAR("T"),U,4) D CITY^DGBTCR S:DGBTCSZ[DGBTCNA DGBTCSZ=DGBTCNA_", "_$S(+$P(DGBTVAR("T"),"^",5)>0:$P(^DIC(5,$P(DGBTVAR("T"),"^",5),0),U,2),1:"")_" "_$P(DGBTVAR("T"),U,6) S DGBTTCTY=DGBTCSZ -DIV S DGBTDIV=$P(DGBTVAR(0),"^",11) I +DGBTDIV S DGBTDIV=$P(^DG(40.8,DGBTDIV,0),"^",7) S (DGBTCC,DGBTST)="" - I $D(^DIC(4,+DGBTDIV,0)) S DGBTINS=^(0),DGBTINS1=$S($D(^DIC(4,DGBTDIV,1)):^(1),1:""),DGBTINS2=$S(DGBTINS1]"":$P(DGBTINS1,"^",3)_",",1:"UNSPECIFIED")_" "_$S($D(^DIC(5,+$P(DGBTINS,U,2),0)):$P(^(0),U,2),1:"")_" "_$P(DGBTINS1,"^",4) - I VAPA(5)&(VAPA(7)) S DGBTCC=$S($D(^DIC(5,+VAPA(5),1,+VAPA(7),0)):$P(^(0),"^",3),1:""),DGBTST=$P(^DIC(5,+VAPA(5),0),"^",2) - ;S DGBTSSN=$P($P(VADM(2),"^",2),"-")_" "_$P($P(VADM(2),"^",2),"-",2)_" "_$P($P(VADM(2),"^",2),"-",3),DGBTDOB=$E(VADM(3),4,7)_$E(VADM(3),2,3) - D PID^VADPT6 S DGBTSSN=VA("PID"),DGBTDOB=$E(VADM(3),4,7)_($E(VADM(3),1,3)+1700) - S DGBTSCP=$S($L($P(VAEL(3),"^",2)<3):"0",1:"")_$P(VAEL(3),"^",2) -MILES S DGBTM6=$P(DGBTVAR("M"),"^")*$P(DGBTVAR("M"),"^",2) - N X3 - S X2="2$",X=DGBTM6*DGBTM7 D COMMA^%DTC S DGBTM8=X - S X=$P(DGBTVAR("M"),"^",4) D COMMA^%DTC S DGBTM9=X - S X=$P(DGBTVAR("M"),"^",5) D COMMA^%DTC S DGBTM10=X - S X=DGBTM6*DGBTM7+$P(DGBTVAR("M"),"^",4)+$P(DGBTVAR("M"),"^",5) D COMMA^%DTC S DGBTM11=X - S X2="3$",X=DGBTM7 D COMMA^%DTC S DGBTM7=X - S X2="2$" ;Reset edit mask to 2 decimal positions for rest of report - S X=$P(DGBTVAR(0),"^",8) D COMMA^%DTC S DGBTM12=X - S X=$P(DGBTVAR("M"),"^",4)+$P(DGBTVAR(0),"^",8) D COMMA^%DTC S DGBTM13=X - S X=$P(DGBTVAR(0),"^",10) D COMMA^%DTC S DGBTM14=X - S X=$P(DGBTVAR(0),"^",9) D COMMA^%DTC S $P(DGBTM14,"^",2)=X -CERT S VADAT("W")=DGBTDT D ^VADATE S DGBTM15=VADATE("E") - S X=$S($P(^DG(43,1,"BT"),"^")'="":$P(^DG(43,1,"BT"),"^"),1:DUZ),DGBTM16=$P($P(^VA(200,X,0),",",2),"^")_" "_$P(^VA(200,X,0),",")_$S($P(^DG(43,1,"BT"),"^")'="":"",1:", DESIGNEE OF CERTIFYING OFFICIAL") K X - S DGBTM17=$P($P(DGBTVAR("A"),"^",2),",",2)_" "_$P($P(DGBTVAR("A"),"^",2),",") - Q -CITY S DGBTCSZ=DGBTCNA - S:VAPA(5)'="" DGBTCNU=$O(^DGBT(392.1,"ACS",DGBTCNA,+VAPA(5),0)) - I $D(DGBTCNU),(DGBTCNU'="") S DGBTCSZ=$P(^DGBT(392.1,DGBTCNU,0),"^")_", "_($P(^DIC(5,+VAPA(5),0),"^",2))_" "_($P(^DGBT(392.1,DGBTCNU,0),"^",4)) - Q -QUE ; - N I - S ZTRTN="PRINT^DGBTCR",ZTDESC="VA FORM 70-3542d" - F I="DFN","DGBTDT","DGBTFCTY","DGBTTCTY" S ZTSAVE(I)="" - D ^%ZTLOAD W:$D(ZTSK) !,"TASK #",ZTSK - D HOME^%ZIS K IO("Q") - Q +DGBTCR ;ALB/SCK - BENEFICIARY TRAVEL FORM 70-3542d VARIABLES; 2/7/88@08:00 ;6/11/93@09:30 + ;;1.0;Beneficiary Travel;**7**;September 25, 2001 + ;Modification of AIVBTPRT / pmg / GRAND ISLAND ; 07 Jul 88 12:02 PM +START Q:'$D(DGBTDT) + S DGBTVAR(0)=$G(^DGBT(392,+DGBTDT,0)),DGBTACCT=$P($G(^DGBT(392.3,+$P(DGBTVAR(0),"^",6),0)),"^",5) + Q:DGBTACCT'>3 + W !!,*7,"This needs to be printed at 132 columns" + S DGPGM="PRINT^DGBTCR",DGVAR="DGBTDT" + S %ZIS="PMQ" D ^%ZIS G QUIT:POP + I $D(IO("Q")) D QUE G QUIT + D PRINT +QUIT ; + D:'$D(ZTQUEUED) ^%ZISC + K DGPGM,DGVAR,VADAT,VADATE,I,X,X2,DGBTVAR,DGBTCC,DGBTDIV,DGBTDOB,DGBTINS,DGBTINS1,DGBTINS2,DGBTCNA,DGBTCSZ,DGBTCNU,DGBTTCTY,DGBTFCTY,DGBTDT,DGBTACCT,DFN,Y + K DGBTM6,DGBTM7,DGBTM8,DGBTM9,DGBTM10,DGBTM11,DGBTM12,DGBTM13,DGBTM14,DGBTM15,DGBTM16,DGBTM17,DGBTRATE,DGBTSCP,DGBTSSN,DGBTST + Q +PRINT ; + U IO D SET,PRINT^DGBTCR1,PRINT^DGBTCR2,KVAR^VADPT + Q +SET S DFN=$P(^DGBT(392,DGBTDT,0),"^",2) D 6^VADPT S (DGBTFCTY,DGBTTCTY)="" +NODES F I=0,"A","D","M","R","T" S DGBTVAR(I)=$S($D(^DGBT(392,DGBTDT,I)):^(I),1:"") + I $D(^DG(43.1,$O(^DG(43.1,(9999999.99999-DGBTDT))),"BT")) S DGBTRATE=^("BT"),DGBTM7=$S($P(DGBTVAR("A"),"^",3)=1:$P(DGBTRATE,"^",5),1:$P(DGBTRATE,"^",3)) + I $P(DGBTVAR("D"),"^",4)]"" S DGBTCNA=$P(DGBTVAR("D"),"^",4) D CITY I DGBTCSZ[DGBTCNA D + . S DGBTCSZ=DGBTCNA_", "_$S(+$P(DGBTVAR("D"),"^",5)>0:$P(^DIC(5,$P(DGBTVAR("D"),"^",5),0),U,2),1:"")_" " + . S Y=$P(DGBTVAR("D"),U,6),Y=$E(Y,1,5)_$S($E(Y,6,9)]"":"-"_$E(Y,6,9),1:""),DGBTCSZ=DGBTCSZ_Y,DGBTFCTY=DGBTCSZ + I $P(DGBTVAR("T"),"^",4)]"" S DGBTCNA=$P(DGBTVAR("T"),U,4) D CITY^DGBTCR S:DGBTCSZ[DGBTCNA DGBTCSZ=DGBTCNA_", "_$S(+$P(DGBTVAR("T"),"^",5)>0:$P(^DIC(5,$P(DGBTVAR("T"),"^",5),0),U,2),1:"")_" "_$P(DGBTVAR("T"),U,6) S DGBTTCTY=DGBTCSZ +DIV S DGBTDIV=$P(DGBTVAR(0),"^",11) I +DGBTDIV S DGBTDIV=$P(^DG(40.8,DGBTDIV,0),"^",7) S (DGBTCC,DGBTST)="" + I $D(^DIC(4,+DGBTDIV,0)) S DGBTINS=^(0),DGBTINS1=$S($D(^DIC(4,DGBTDIV,1)):^(1),1:""),DGBTINS2=$S(DGBTINS1]"":$P(DGBTINS1,"^",3)_",",1:"UNSPECIFIED")_" "_$S($D(^DIC(5,+$P(DGBTINS,U,2),0)):$P(^(0),U,2),1:"")_" "_$P(DGBTINS1,"^",4) + I VAPA(5)&(VAPA(7)) S DGBTCC=$S($D(^DIC(5,+VAPA(5),1,+VAPA(7),0)):$P(^(0),"^",3),1:""),DGBTST=$P(^DIC(5,+VAPA(5),0),"^",2) + ;S DGBTSSN=$P($P(VADM(2),"^",2),"-")_" "_$P($P(VADM(2),"^",2),"-",2)_" "_$P($P(VADM(2),"^",2),"-",3),DGBTDOB=$E(VADM(3),4,7)_$E(VADM(3),2,3) + D PID^VADPT6 S DGBTSSN=VA("PID"),DGBTDOB=$E(VADM(3),4,7)_($E(VADM(3),1,3)+1700) + S DGBTSCP=$S($L($P(VAEL(3),"^",2)<3):"0",1:"")_$P(VAEL(3),"^",2) +MILES S DGBTM6=$P(DGBTVAR("M"),"^")*$P(DGBTVAR("M"),"^",2) + N X3 + S X2="2$",X=DGBTM6*DGBTM7 D COMMA^%DTC S DGBTM8=X + S X=$P(DGBTVAR("M"),"^",4) D COMMA^%DTC S DGBTM9=X + S X=$P(DGBTVAR("M"),"^",5) D COMMA^%DTC S DGBTM10=X + S X=DGBTM6*DGBTM7+$P(DGBTVAR("M"),"^",4)+$P(DGBTVAR("M"),"^",5) D COMMA^%DTC S DGBTM11=X + S X=DGBTM7 D COMMA^%DTC S DGBTM7=X + S X=$P(DGBTVAR(0),"^",8) D COMMA^%DTC S DGBTM12=X + S X=$P(DGBTVAR("M"),"^",4)+$P(DGBTVAR(0),"^",8) D COMMA^%DTC S DGBTM13=X + S X=$P(DGBTVAR(0),"^",10) D COMMA^%DTC S DGBTM14=X + S X=$P(DGBTVAR(0),"^",9) D COMMA^%DTC S $P(DGBTM14,"^",2)=X +CERT S VADAT("W")=DGBTDT D ^VADATE S DGBTM15=VADATE("E") + S X=$S($P(^DG(43,1,"BT"),"^")'="":$P(^DG(43,1,"BT"),"^"),1:DUZ),DGBTM16=$P($P(^VA(200,X,0),",",2),"^")_" "_$P(^VA(200,X,0),",")_$S($P(^DG(43,1,"BT"),"^")'="":"",1:", DESIGNEE OF CERTIFYING OFFICIAL") K X + S DGBTM17=$P($P(DGBTVAR("A"),"^",2),",",2)_" "_$P($P(DGBTVAR("A"),"^",2),",") + Q +CITY S DGBTCSZ=DGBTCNA + S:VAPA(5)'="" DGBTCNU=$O(^DGBT(392.1,"ACS",DGBTCNA,+VAPA(5),0)) + I $D(DGBTCNU),(DGBTCNU'="") S DGBTCSZ=$P(^DGBT(392.1,DGBTCNU,0),"^")_", "_($P(^DIC(5,+VAPA(5),0),"^",2))_" "_($P(^DGBT(392.1,DGBTCNU,0),"^",4)) + Q +QUE ; + N I + S ZTRTN="PRINT^DGBTCR",ZTDESC="VA FORM 70-3542d" + F I="DFN","DGBTDT","DGBTFCTY","DGBTTCTY" S ZTSAVE(I)="" + D ^%ZTLOAD W:$D(ZTSK) !,"TASK #",ZTSK + D HOME^%ZIS K IO("Q") + Q diff --git a/r/BENEFICIARY_TRAVEL-DGBT/DGBTEE.m b/r/BENEFICIARY_TRAVEL-DGBT/DGBTEE.m index b57c522a..8d4082e9 100644 --- a/r/BENEFICIARY_TRAVEL-DGBT/DGBTEE.m +++ b/r/BENEFICIARY_TRAVEL-DGBT/DGBTEE.m @@ -1,55 +1,55 @@ -DGBTEE ;ALB/SCK - BENEFICIARY TRAVEL ENTER/EDIT; 12/3/92@1600 - ;;1.0;Beneficiary Travel;**2,14**;September 25, 2001;Build 7 - Q -SCREEN ; - D SCREEN^DGBTEE1 Q:DGBTTOUT=-1!(DGBTTOUT=1) Q:'$D(^DGBT(392,DGBTDT,0)) - ; The following section of code moved to DGBTEE2 for space problems - D STUFF^DGBTEE2 -MILES ; get miles between dep. and dest. using function call to DGBTUTL - K X,DGBTREC S (DGBTOWRT,DGBTML,DGBTMLT)="" - I DGBTFR4]""&((DGBTACCT=4)!(DGBTACCT=5)) I $D(^DGBT(392.1,"ACS",DGBTFR4,+VAPA(5))) D - . S X=$O(^(+VAPA(5),0)) ; naked ref. refers to file #392.1, "ACS", city. Full reference on line MILES+2^DGBTEE, ^DGBTE(392.1,"ACS",DGBTFR4,+VAPA(5) - . ; function $$miles passes city's record# and div name to function, mileage value is returned - . I X'="" S DGBTREC=X,DGBTML=$$MILES^DGBTUTL(DGBTREC,DGBTDV1),DGBTOWRT="ROUND TRIP" K X - S (DGBTMAL,DGBTFAB,DGBTME,DGBTCP,DGBTFLAG,DGBTDCV,DGBTDE,DGBTDCM,DGBTDPV,DGBTDPM)=0 -DIE1 ; stuff from,to address, meals, ferry's/bridges - Q:'$D(^DGBT(392,DGBTDT,0)) - S DIE="^DGBT(392,",DA=DGBTDT,DR=$S(DGBTACCT=4:"42//"_DGBTAP,DGBTACCT=5:"43;S DGBTCP=X;42//"_DGBTAP,1:"44") - D ^DIE I X=""!(X="^") S DGBTTOUT=-1 Q - S DR="21////^S X=DGBTFR1;22////^S X=DGBTFR2;23////^S X=DGBTFR3;24////^S X=DGBTFR4;25////^S X=DGBTTO1;26////^S X=DGBTTO2;27////^S X=DGBTTO3;28////^S X=DGBTTO4;34////^S X=DGBTMAL;35////^S X=DGBTFAB" - D ^DIE I X=""!(X="^") S DGBTTOUT=-1 Q - ; function $$diclkup passes the city's record #, div name, and a flag for remarks (4), remarks or a null are returned - I DGBTACCT=4!(DGBTACCT=5) D - . W !!,"Please wait, Checking Mileage ..." - . S DGBTRMK=$S($D(DGBTREC):$$DICLKUP^DGBTUTL(DGBTREC,DGBTDV1,4),1:"") I $D(DGBTDEF),DGBTDEF S DGBTRMK="DEFAULT MILEAGE USED" - . I DGBTRMK]"" W !,*7,"MILEAGE REMARKS: ",DGBTRMK,! -EDIT ; display trip type, mileage - I DGBTACCT=4!(DGBTACCT=5) S DR="32//"_DGBTML_";S DGBTML=X;31//"_DGBTOWRT_";S DGBTOWRT=X;" D ^DIE I X=""!(X="^") S DGBTTOUT=-1 Q - S:DGBTACCT=5&(DGBTCP=1) DGBTMR=DGBTMR1 S DGBTMLT=DGBTOWRT*DGBTML*DGBTMR,DGBTMLT=$J(DGBTMLT,0,2),DR="33///"_DGBTMLT - D ^DIE I X=""!(X="^") S DGBTTOUT=-1 Q -DIE2 ; stuff eligibility data, SC%, acct. type - S DIE("NO^")="12345" S:'$D(DGBTCD) DGBTCD="" - I 'DGBTCORE D - . S DR="3////"_DGBTELIG_";4////"_DGBTSCP_";5///"_DGBTCD_";6////"_DGBTACTN_";I DGBTACCT=4!(DGBTACCT=5) S Y=""@1"";41;7;@1;I DGBTMLFB=0 S Y=""@2"";34;S DGBTMAL=X;35;S DGBTFAB=X;@2" - I DGBTCORE D - . S DR(1,392,1)="3////"_DGBTELIG_";4////"_DGBTSCP_";5///"_DGBTCD_";6////"_DGBTACTN_";I DGBTACCT=4!(DGBTACCT=5) S Y=""@1"";41;" - . S DR(1,392,2)="@3;14;S DGBTCSL=$$AFTER^DGBTCSL(392,D0,X,$G(DGBTPRV)) S:DGBTCSL<1 Y=""@3"" W:DGBTCSL<1 "" Required"" K DGBTPRV,DGBTCSL;@1;I DGBTMLFB=0 S Y=""@2"";34;S DGBTMAL=X;35;S DGBTFAB=X;@2" -DIE3 ; get most econ. cost - D ^DIE K DR I X=""!(X="^") S DGBTTOUT=-1 Q - ; function $$diclkup passes the city's record #, division name, and flag for MEC (3), the MEC is returned - S:$D(DGBTREC) DGBTME=$$DICLKUP^DGBTUTL(DGBTREC,DGBTDV1,3) S:DGBTME="" DGBTME=0 S DR="8//"_DGBTME_";S DGBTME=X" - D ^DIE I X=""!(X="^") S DGBTTOUT=-1 G EXIT -TCOST ; calculate total cost and monthly cum. deductable -MLFB ; - S DGBTMAF=$S(DGBTMLFB:DGBTMAL+DGBTFAB,1:0),DGBTMETC=DGBTME+$S($D(DGBTMAL):DGBTMAL,1:0) - I DGBTACCT'=4&(DGBTACCT'=5) S DGBTPA=DGBTMAF+DGBTME G CONT - I $D(DGBTMLT) S DGBTTC=$S(DGBTMLT+DGBTMAF'>DGBTMETC:DGBTMLT+DGBTMAF,DGBTMLT+DGBTMAF>DGBTMETC&(DGBTME>0):DGBTMETC,DGBTME'>0:DGBTMLT+DGBTMAF,1:DGBTMETC) - I DGBTACCT=5 S DGBTDE=0 S DGBTPA=$S((DGBTMLT+DGBTMAF)'=0:DGBTTC,1:DGBTMETC) G CONT - ; the following section of code moved to DGBTEE2 for space reasons - D DED^DGBTEE2 -DIE4 ; display deductable amount - D ^DIE I X=""!(X="^") S DGBTTOUT=-1 Q -CONT ; - D CONT^DGBTCE1 Q -EXIT ; - K DGBTDV1,DGBTRMK Q +DGBTEE ;ALB/SCK - BENEFICIARY TRAVEL ENTER/EDIT; 12/3/92@1600 + ;;1.0;Beneficiary Travel;**2**;September 25, 2001 + Q +SCREEN ; + D SCREEN^DGBTEE1 Q:DGBTTOUT=-1!(DGBTTOUT=1) Q:'$D(^DGBT(392,DGBTDT,0)) + ; The following section of code moved to DGBTEE2 for space problems + D STUFF^DGBTEE2 +MILES ; get miles between dep. and dest. using function call to DGBTUTL + K X,DGBTREC S (DGBTOWRT,DGBTML,DGBTMLT)="" + I DGBTFR4]""&((DGBTACCT=4)!(DGBTACCT=5)) I $D(^DGBT(392.1,"ACS",DGBTFR4,+VAPA(5))) D + . S X=$O(^(+VAPA(5),0)) ; naked ref. refers to file #392.1, "ACS", city. Full reference on line MILES+2^DGBTEE, ^DGBTE(392.1,"ACS",DGBTFR4,+VAPA(5) + . ; function $$miles passes city's record# and div name to function, mileage value is returned + . I X'="" S DGBTREC=X,DGBTML=$$MILES^DGBTUTL(DGBTREC,DGBTDV1),DGBTOWRT="ROUND TRIP" K X + S (DGBTMAL,DGBTFAB,DGBTME,DGBTCP,DGBTFLAG,DGBTDCV,DGBTDE,DGBTDCM,DGBTDPV,DGBTDPM)=0 +DIE1 ; stuff from,to address, meals, ferry's/bridges + Q:'$D(^DGBT(392,DGBTDT,0)) + S DIE="^DGBT(392,",DA=DGBTDT,DR=$S(DGBTACCT=4:"42//"_DGBTAP,DGBTACCT=5:"43;S DGBTCP=X;42//"_DGBTAP,1:"44") + D ^DIE I X=""!(X="^") S DGBTTOUT=-1 Q + S DR="21////^S X=DGBTFR1;22////^S X=DGBTFR2;23////^S X=DGBTFR3;24////^S X=DGBTFR4;25////^S X=DGBTTO1;26////^S X=DGBTTO2;27////^S X=DGBTTO3;28////^S X=DGBTTO4;34////^S X=DGBTMAL;35////^S X=DGBTFAB" + D ^DIE I X=""!(X="^") S DGBTTOUT=-1 Q + ; function $$diclkup passes the city's record #, div name, and a flag for remarks (4), remarks or a null are returned + I DGBTACCT=4!(DGBTACCT=5) D + . W !!,"Please wait, Checking Mileage ..." + . S DGBTRMK=$S($D(DGBTREC):$$DICLKUP^DGBTUTL(DGBTREC,DGBTDV1,4),1:"") I $D(DGBTDEF),DGBTDEF S DGBTRMK="DEFAULT MILEAGE USED" + . I DGBTRMK]"" W !,*7,"MILEAGE REMARKS: ",DGBTRMK,! +EDIT ; display trip type, mileage + I DGBTACCT=4!(DGBTACCT=5) S DR="32//"_DGBTML_";S DGBTML=X;31//"_DGBTOWRT_";S DGBTOWRT=X;" D ^DIE I X=""!(X="^") S DGBTTOUT=-1 Q + S:DGBTACCT=5&(DGBTCP=1) DGBTMR=DGBTMR1 S DGBTMLT=DGBTOWRT*DGBTML*DGBTMR,DR="33///"_DGBTMLT + D ^DIE I X=""!(X="^") S DGBTTOUT=-1 Q +DIE2 ; stuff eligibility data, SC%, acct. type + S DIE("NO^")="12345" S:'$D(DGBTCD) DGBTCD="" + I 'DGBTCORE D + . S DR="3////"_DGBTELIG_";4////"_DGBTSCP_";5///"_DGBTCD_";6////"_DGBTACTN_";I DGBTACCT=4!(DGBTACCT=5) S Y=""@1"";41;7;@1;I DGBTMLFB=0 S Y=""@2"";34;S DGBTMAL=X;35;S DGBTFAB=X;@2" + I DGBTCORE D + . S DR(1,392,1)="3////"_DGBTELIG_";4////"_DGBTSCP_";5///"_DGBTCD_";6////"_DGBTACTN_";I DGBTACCT=4!(DGBTACCT=5) S Y=""@1"";41;" + . S DR(1,392,2)="@3;14;S DGBTCSL=$$AFTER^DGBTCSL(392,D0,X,$G(DGBTPRV)) S:DGBTCSL<1 Y=""@3"" W:DGBTCSL<1 "" Required"" K DGBTPRV,DGBTCSL;@1;I DGBTMLFB=0 S Y=""@2"";34;S DGBTMAL=X;35;S DGBTFAB=X;@2" +DIE3 ; get most econ. cost + D ^DIE K DR I X=""!(X="^") S DGBTTOUT=-1 Q + ; function $$diclkup passes the city's record #, division name, and flag for MEC (3), the MEC is returned + S:$D(DGBTREC) DGBTME=$$DICLKUP^DGBTUTL(DGBTREC,DGBTDV1,3) S:DGBTME="" DGBTME=0 S DR="8//"_DGBTME_";S DGBTME=X" + D ^DIE I X=""!(X="^") S DGBTTOUT=-1 G EXIT +TCOST ; calculate total cost and monthly cum. deductable +MLFB ; + S DGBTMAF=$S(DGBTMLFB:DGBTMAL+DGBTFAB,1:0),DGBTMETC=DGBTME+$S($D(DGBTMAL):DGBTMAL,1:0) + I DGBTACCT'=4&(DGBTACCT'=5) S DGBTPA=DGBTMAF+DGBTME G CONT + I $D(DGBTMLT) S DGBTTC=$S(DGBTMLT+DGBTMAF'>DGBTMETC:DGBTMLT+DGBTMAF,DGBTMLT+DGBTMAF>DGBTMETC&(DGBTME>0):DGBTMETC,DGBTME'>0:DGBTMLT+DGBTMAF,1:DGBTMETC) + I DGBTACCT=5 S DGBTDE=0 S DGBTPA=$S((DGBTMLT+DGBTMAF)'=0:DGBTTC,1:DGBTMETC) G CONT + ; the following section of code moved to DGBTEE2 for space reasons + D DED^DGBTEE2 +DIE4 ; display deductable amount + D ^DIE I X=""!(X="^") S DGBTTOUT=-1 Q +CONT ; + D CONT^DGBTCE1 Q +EXIT ; + K DGBTDV1,DGBTRMK Q diff --git a/r/BENEFICIARY_TRAVEL-DGBT/DGBTEE1.m b/r/BENEFICIARY_TRAVEL-DGBT/DGBTEE1.m index 183e1cd6..37508224 100644 --- a/r/BENEFICIARY_TRAVEL-DGBT/DGBTEE1.m +++ b/r/BENEFICIARY_TRAVEL-DGBT/DGBTEE1.m @@ -1,64 +1,64 @@ -DGBTEE1 ;ALB/SCK - BENEFICIARY TRAVEL ENTER/EDIT CHECK; 12/7/92 3/19/93 - ;;1.0;Beneficiary Travel;**14**;September 25, 2001;Build 7 - Q -SCREEN ; called by dgbtee,dgbtce - Q:'$D(^DGBT(392,DGBTDT,0)) - K DGBTVAR F I=0,"A","D","M","R","T" S DGBTVAR(I)=$S($D(^DGBT(392,DGBTDT,I)):^(I),1:"") ; ref file #392, claims - W @IOF S DGBTFLAG=0 - I '$D(^DG(43,1,"BT"))!('$D(^DG(43.1,$O(^DG(43.1,(9999999.99999-DGBTDT))),"BT"))) W !!,"Module has not been properly initialized - to continue you should first complete",!,"the parameters" Q - W !?16,"Beneficiary Travel Claim Information " - D PID^VADPT6 - W !!?8,"Name: ",VADM(1),?40,"PT ID: ",VA("PID"),?64,"DOB: ",$P(VADM(3),"^",2),! -START ; ask date/time, and division - K DIC,^TMP("DGBT",$J),X - S DIE="^DGBT(392,",DIE("NO^")="OUTOK" - S DR=".01;S (DGBTDT,VADAT(""W""))=X D ^VADATE S DGBTDTI=VADATE(""I""),DGBTDTE=VADATE(""E"") K VADAT,VADATE I '$D(DGBTMD) S Y=""@1"";11;@1" - S DIDEL=392 ; allows users to delete BT claims - D ^DIE K DIE,DIDEL,DQ,DR I $D(DTOUT)!($D(Y)) S DGBTTOUT=-1 Q - K X - I '$D(^DGBT(392,DGBTDT,0)) Q - I $D(^DGBT(392,DGBTDT,0)) L ^DGBT(392,DGBTDT):2 I '$T W !?5,"Another user is editing this entry.",*7 S DGBTTOUT=1 G QUIT - ; set rates and build eligibilities in DGBTEE2 - D RATES^DGBTEE2 -ELIG1 ; select eligibility from those available in TMP list - I '$O(VAEL(1,0)) S DGBTELIG=+VAEL(1) G ESET1 - S DIR("A")="Select ELIGIBILITY",DIR("B")=$S($P(^DGBT(392,DGBTDT,0),"^",3):$P(^DIC(8,$P(^DGBT(392,DGBTDT,0),"^",3),0),"^"),VAEL(1):$P(VAEL(1),"^",2),1:"") - S DIR(0)="F",DIR("?")="^D ELIST^DGBTEE2" - D ^DIR K DIR I $D(DUOUT) W !?3,"SORRY, '^' NOT ALLOWED!!" G ELIG1 - I $D(DTOUT) S DGBTTOUT=-1 Q - S:Y="" DGBTELIG=$S($P(^DGBT(392,DGBTDT,0),"^",3):$P(^(0),"^",3),1:+VAEL(1)) ; ref file #392, claims - I X["@" W !,"ELIGIBILITY REQUIRED." G ELIG1 - I Y?1A.E F I=0:0 S I=$O(^TMP("DGBT",$J,I)) Q:'I I $E($P(^(I),"^",2),1,$L(X))=X S XX=Y,Y=I G ESET ; ref ^TMP file for eligibility - I +Y?1N.N S Y=+Y F I=0:0 S I=$O(^TMP("DGBT",$J,I)) Q:'I I +$P(^(I),"^")=Y S XX=Y,Y=I G ESET ; ref ^TMP file for eligibility -ECHOZ ; - W !!,"Choose by NUMBER the primary eligibility or other entitled eligibilities",! - I DGBTCT>1 F I=0:0 S I=$O(^TMP("DGBT",$J,I)) Q:'I W !?5,I,?10,$P(^TMP("DGBT",$J,I),"^",2) - K DIR,X S DIR("A")="Choose 1-"_DGBTCT,DIR(0)="NO^1:"_DGBTCT,DIR("?")="Enter choice from those displayed" - D ^DIR K DIR G:$D(DIRUT) ELIG1 S XX=Y - I '$D(^TMP("DGBT",$J,Y)) W " ?? ",!,"Select ELIGIBILITY: " G ECHOZ -ESET ; - S:$D(Y) DGBTELIG=$S($D(^TMP("DGBT",$J,Y)):+^TMP("DGBT",$J,Y),'$D(XX):Y,1:+VAEL(1)) - W:Y]"" ?30,$E($P(^DIC(8,+DGBTELIG,0),"^"),$S($D(XX):($L(XX)+1),1:1),99) -ESET1 ; - S DGBTSCP=$S($P(^DIC(8,DGBTELIG,0),"^",9)=1&(+VAEL(3)):$P(VAEL(3),"^",2),$P(^DIC(8,DGBTELIG,0),"^",9)=3&(+VAEL(3)):$P(VAEL(3),"^",2),1:"") -CERT ; stuff of certification date if appropriate - ; naked global ref file #392.2, certification file. - I $P(VAEL(3),"^") S DGBTCD="" I VAEL(3)&($P(VAEL(3),"^",2)'>29) S DGBTIDT=9999999.99999-DGBTDT F I=0:0 S I=$O(^DGBT(392.2,"C",DFN,I)) Q:'I I I'>DGBTIDT&($P(^DGBT(392.2,I,0),"^",3)) S DGBTCD=$P(^(0),"^") -ACCT ; allowed to select only valid active accounts - S DGBTOACT=$S('$D(^DGBT(392.3,+$P(DGBTVAR(0),"^",6),0)):0,1:+$P(^DGBT(392.3,$P(DGBTVAR(0),"^",6),0),"^",5)) - K X S (DIC("B"),X)=$S(+$P(DGBTVAR(0),"^",6):$P(^DGBT(392.3,$P(DGBTVAR(0),"^",6),0),"^"),1:$$DEFLT1) S DIC("A")="Select ACCOUNT: " - S DIC="^DGBT(392.3,",DIC(0)="AEQMZ",DIC("S")="I $P(^(0),U,3)'>DGBTDT&('$P(^(0),U,4)!($P(^(0),U,4)'0 W !,"ACCOUNT IS REQUIRED!!" G ACCT - S DGBTACTN=$P(Y,"^"),DGBTACCT=$P(Y(0),"^",5) - ; if account is ALL OTHER - stuff in mileage info - I $D(DGBTVAR("M")) S DGBTML=$P(DGBTVAR("M"),"^",2),DGBTOWRT=$P(DGBTVAR("M"),"^"),DGBTMLT=$J((DGBTML*DGBTOWRT*DGBTMR),0,2) -QUIT ; - K A,C,I,IA,J,X,XX,^TMP("DGBT",$J),DGBTDIV,DGBTIDT,DGBTCT - Q - ; -DEFLT1() ; - N REC,Y - S REC="0" F S REC=$O(^DGBT(392.3,REC)) Q:'REC D Q:$D(Y) - . S:$P(^DGBT(392.3,REC,0),U,5)=4&($P(^(0),U,3)'>DGBTDT&('$P(^(0),U,4)!($P(^(0),U,4)'" + D PID^VADPT6 + W !!?8,"Name: ",VADM(1),?40,"PT ID: ",VA("PID"),?64,"DOB: ",$P(VADM(3),"^",2),! +START ; ask date/time, and division + K DIC,^TMP("DGBT",$J),X + S DIE="^DGBT(392,",DIE("NO^")="OUTOK" + S DR=".01;S (DGBTDT,VADAT(""W""))=X D ^VADATE S DGBTDTI=VADATE(""I""),DGBTDTE=VADATE(""E"") K VADAT,VADATE I '$D(DGBTMD) S Y=""@1"";11;@1" + S DIDEL=392 ; allows users to delete BT claims + D ^DIE K DIE,DIDEL,DQ,DR I $D(DTOUT)!($D(Y)) S DGBTTOUT=-1 Q + K X + I '$D(^DGBT(392,DGBTDT,0)) Q + I $D(^DGBT(392,DGBTDT,0)) L ^DGBT(392,DGBTDT):2 I '$T W !?5,"Another user is editing this entry.",*7 S DGBTTOUT=1 G QUIT + ; set rates and build eligibilities in DGBTEE2 + D RATES^DGBTEE2 +ELIG1 ; select eligibility from those available in TMP list + I '$O(VAEL(1,0)) S DGBTELIG=+VAEL(1) G ESET1 + S DIR("A")="Select ELIGIBILITY",DIR("B")=$S($P(^DGBT(392,DGBTDT,0),"^",3):$P(^DIC(8,$P(^DGBT(392,DGBTDT,0),"^",3),0),"^"),VAEL(1):$P(VAEL(1),"^",2),1:"") + S DIR(0)="F",DIR("?")="^D ELIST^DGBTEE2" + D ^DIR K DIR I $D(DUOUT) W !?3,"SORRY, '^' NOT ALLOWED!!" G ELIG1 + I $D(DTOUT) S DGBTTOUT=-1 Q + S:Y="" DGBTELIG=$S($P(^DGBT(392,DGBTDT,0),"^",3):$P(^(0),"^",3),1:+VAEL(1)) ; ref file #392, claims + I X["@" W !,"ELIGIBILITY REQUIRED." G ELIG1 + I Y?1A.E F I=0:0 S I=$O(^TMP("DGBT",$J,I)) Q:'I I $E($P(^(I),"^",2),1,$L(X))=X S XX=Y,Y=I G ESET ; ref ^TMP file for eligibility + I +Y?1N.N S Y=+Y F I=0:0 S I=$O(^TMP("DGBT",$J,I)) Q:'I I +$P(^(I),"^")=Y S XX=Y,Y=I G ESET ; ref ^TMP file for eligibility +ECHOZ ; + W !!,"Choose by NUMBER the primary eligibility or other entitled eligibilities",! + I DGBTCT>1 F I=0:0 S I=$O(^TMP("DGBT",$J,I)) Q:'I W !?5,I,?10,$P(^TMP("DGBT",$J,I),"^",2) + K DIR,X S DIR("A")="Choose 1-"_DGBTCT,DIR(0)="NO^1:"_DGBTCT,DIR("?")="Enter choice from those displayed" + D ^DIR K DIR G:$D(DIRUT) ELIG1 S XX=Y + I '$D(^TMP("DGBT",$J,Y)) W " ?? ",!,"Select ELIGIBILITY: " G ECHOZ +ESET ; + S:$D(Y) DGBTELIG=$S($D(^TMP("DGBT",$J,Y)):+^TMP("DGBT",$J,Y),'$D(XX):Y,1:+VAEL(1)) + W:Y]"" ?30,$E($P(^DIC(8,+DGBTELIG,0),"^"),$S($D(XX):($L(XX)+1),1:1),99) +ESET1 ; + S DGBTSCP=$S($P(^DIC(8,DGBTELIG,0),"^",9)=1&(+VAEL(3)):$P(VAEL(3),"^",2),$P(^DIC(8,DGBTELIG,0),"^",9)=3&(+VAEL(3)):$P(VAEL(3),"^",2),1:"") +CERT ; stuff of certification date if appropriate + ; naked global ref file #392.2, certification file. + I $P(VAEL(3),"^") S DGBTCD="" I VAEL(3)&($P(VAEL(3),"^",2)'>29) S DGBTIDT=9999999.99999-DGBTDT F I=0:0 S I=$O(^DGBT(392.2,"C",DFN,I)) Q:'I I I'>DGBTIDT&($P(^DGBT(392.2,I,0),"^",3)) S DGBTCD=$P(^(0),"^") +ACCT ; allowed to select only valid active accounts + S DGBTOACT=$S('$D(^DGBT(392.3,+$P(DGBTVAR(0),"^",6),0)):0,1:+$P(^DGBT(392.3,$P(DGBTVAR(0),"^",6),0),"^",5)) + K X S (DIC("B"),X)=$S(+$P(DGBTVAR(0),"^",6):$P(^DGBT(392.3,$P(DGBTVAR(0),"^",6),0),"^"),1:$$DEFLT1) S DIC("A")="Select ACCOUNT: " + S DIC="^DGBT(392.3,",DIC(0)="AEQMZ",DIC("S")="I $P(^(0),U,3)'>DGBTDT&('$P(^(0),U,4)!($P(^(0),U,4)'0 W !,"ACCOUNT IS REQUIRED!!" G ACCT + S DGBTACTN=$P(Y,"^"),DGBTACCT=$P(Y(0),"^",5) + ; if account is ALL OTHER - stuff in mileage info + I $D(DGBTVAR("M")) S DGBTML=$P(DGBTVAR("M"),"^",2),DGBTOWRT=$P(DGBTVAR("M"),"^"),DGBTMLT=DGBTML*DGBTOWRT*DGBTMR +QUIT ; + K A,C,I,IA,J,X,XX,^TMP("DGBT",$J),DGBTDIV,DGBTIDT,DGBTCT + Q + ; +DEFLT1() ; + N REC,Y + S REC="0" F S REC=$O(^DGBT(392.3,REC)) Q:'REC D Q:$D(Y) + . S:$P(^DGBT(392.3,REC,0),U,5)=4&($P(^(0),U,3)'>DGBTDT&('$P(^(0),U,4)!($P(^(0),U,4)'0 S DA=+Y - S DGBTN=$S('$D(^DG(43.1,DA,"BT")):"",1:^DG(43.1,DA,"BT")) - S:$D(DGBTN)&($P(DGBTN,"^")]"") DIR("B")=$P(DGBTN,"^") - S DGBTDEDV=$$DEDUCT(6,"VISIT") G:DGBTDEDV<0 QUIT1 - S DIE="^DG(43.1,",DR="30.01///^S X=DGBTDEDV" - D ^DIE - S:$D(DGBTN)&($P(DGBTN,"^",2)]"") DIR("B")=$P(DGBTN,"^",2) - S DGBTDEDM=$$DEDUCT(18,"MONTH") G:DGBTDEDM<0 QUIT1 - S DIE="^DG(43.1,",DR="30.02///^S X=DGBTDEDM" - D ^DIE - S DR="30.03;30.05;30.04",DIE="^DG(43.1," - D ^DIE G QUIT1 -ACCT ; change activation/inactivation dates for accounts - W !!,"ACCOUNT TYPES are determined by Fiscal Service and have a direct impact",!,"on the type of questions asked in the Beneficiary Travel CLAIM ENTER/EDIT",!,"option." - W !,"DO NOT add to this file unless so instructed by Fiscal Service.",! -TYPE ; select account to edit - S DIR("A")="Select ACCOUNT",DIR("?")="^D HELP2^DGBTEF1",DIR(0)="FO" - D ^DIR K DIR G QUIT:$D(DIRUT) S X=Y - S DIC="^DGBT(392.3,",DIC(0)="ELQMZ" - D ^DIC G TYPE:Y'>0 - S DA=+Y,DR="2:4",DIE="^DGBT(392.3," D ^DIE G TYPE -NWACT ;enter/edit account file (392.3);option DGBT BENE TRAVEL ACCOUNT - W !!?3,"You are about to enter/edit Bene Travel account types. Although",!?3,"this process is now decentralized, changes and additions should be",!?3,"made with extreme care.",! - S DIR(0)="Y",DIR("A")="Are you sure you wish to continue",DIR("B")="No" D ^DIR K DIR I $D(DTOUT)!($D(DUOUT))!('Y) G QUIT1 -ED ; edit data for new account - W ! K X,DA - S (DIE,DIC)="^DGBT(392.3,",DIC(0)="AEQLMZ",DLAYGO=392.3,DIC("DR")="" - D ^DIC K DIC G:$D(DTOUT)!$D(DUOUT)!(X="") QUIT1 G:Y'>0 ED - S DR="2///"_$P(Y(0)," ",1)_";3;4;5" ; account number now stuffed, not asked - S DA=+Y L ^DGBT(392.3,DA):2 E W !?5,"Another user is editing this entry.",*7 G ED - S DIE("NO^")=1 - D ^DIE L K DR,DIE,DIE("NO^") - W ! S DIR(0)="Y",DIR("A")="Would you like to Enter/Edit another ACCOUNT",DIR("B")="Yes" - D ^DIR K DIR G:$D(DTOUT)!($D(DUOUT))!(Y=0) QUIT1 G ED -QUIT1 ; - K DIR,DTOUT,DI,D0,DUOUT,DIRUT,DGBTN,DGBTDEDV,DGBTDEDM -QUIT ; - K %DT,DA,DIC,DIE,DIE("NO^"),DR,X,Y Q -DEDUCT(LIMIT,TYPE) ; enter new deductble value -DEDCT1 S DIR(0)="FAO",DIR("A")="ENTER DEDUCTIBLE AMOUNT/"_TYPE_": " - S DIR("?")="Type a dollar amount between 0 and "_LIMIT_" with up to 2 decimal places." - D ^DIR K DIR I $D(DUOUT)!($D(DTOUT))!(Y']"") S Y=-1 G DEDUCTQ - S:Y["$" Y=$P(Y,"$",2) - I Y'?.N,Y'?.N1".".N K X,Y,DIR G DEDCT1 - I Y>(LIMIT+.001) W " -- Deductible exceeds limit." K X,Y,DIR G DEDCT1 -DEDUCTQ Q (+Y) - ; -HELP W !!,"The effective date must start on the fiscal year, Oct 1.",! G DATE -HELP1 S DIC="^DG(43.1,",DIC(0)="QMZ",X="?" D ^DIC K DIC Q -HELP2 S DIC="^DGBT(392.3,",DIC(0)="QMZ",X="?" D ^DIC K DIC Q +DGBTEF1 ;ALB/SCK - BENEFICIARY TRAVEL UPDATE PARAMETERS INTO FILES ;12/14/92 3/12/93 + ;;1.0;Beneficiary Travel;**2**;September 25, 2001 +RATES ;enter/edit bene travel parameters;option DGBT BENE TRAVEL RATES + S DA=1,DR="720;723;721",DIE="^DG(43," D ^DIE G QUIT:X="^"!($D(DTOUT))!($D(Y)) K DA,DE,DQ,DR,DIE + W !!,"New travel rates are determined each fiscal year. The rates should be",!,"entered each year with the effective date of Oct 1.",! + W !,"Changing values for the current or past fiscal years could result in changes",!,"to the claims already entered.",! +DATE ; change deductible rates for FY + S DIR("A")="Select EFFECTIVE DATE",DIR(0)="DO^^E",DIR("?")="^D HELP1^DGBTEF1" + D ^DIR K DIR G QUIT:$D(DIRUT) G HELP:$E(Y,4,7)'="1001" S X=+Y + S DIC="^DG(43.1,",DIC(0)="ELQMZ" + D ^DIC G QUIT:Y'>0 S DA=+Y + S DGBTN=$S('$D(^DG(43.1,DA,"BT")):"",1:^DG(43.1,DA,"BT")) + S:$D(DGBTN)&($P(DGBTN,"^")]"") DIR("B")=$P(DGBTN,"^") + S DGBTDEDV=$$DEDUCT(6,"VISIT") G:DGBTDEDV<0 QUIT1 + S DIE="^DG(43.1,",DR="30.01///^S X=DGBTDEDV" + D ^DIE + S:$D(DGBTN)&($P(DGBTN,"^",2)]"") DIR("B")=$P(DGBTN,"^",2) + S DGBTDEDM=$$DEDUCT(18,"MONTH") G:DGBTDEDM<0 QUIT1 + S DIE="^DG(43.1,",DR="30.02///^S X=DGBTDEDM" + D ^DIE + S DR="30.03;30.05;30.04",DIE="^DG(43.1," + D ^DIE G QUIT1 +ACCT ; change activation/inactivation dates for accounts + W !!,"ACCOUNT TYPES are determined by Fiscal Service and have a direct impact",!,"on the type of questions asked in the Beneficiary Travel CLAIM ENTER/EDIT",!,"option." + W !,"DO NOT add to this file unless so instructed by Fiscal Service.",! +TYPE ; select account to edit + S DIR("A")="Select ACCOUNT",DIR("?")="^D HELP2^DGBTEF1",DIR(0)="FO" + D ^DIR K DIR G QUIT:$D(DIRUT) S X=Y + S DIC="^DGBT(392.3,",DIC(0)="ELQMZ" + D ^DIC G TYPE:Y'>0 + S DA=+Y,DR="2:4",DIE="^DGBT(392.3," D ^DIE G TYPE +NWACT ;enter/edit account file (392.3);option DGBT BENE TRAVEL ACCOUNT + W !!?3,"You are about to enter/edit Bene Travel account types. Although",!?3,"this process is now decentralized, changes and additions should be",!?3,"made with extreme care.",! + S DIR(0)="Y",DIR("A")="Are you sure you wish to continue",DIR("B")="No" D ^DIR K DIR I $D(DTOUT)!($D(DUOUT))!('Y) G QUIT1 +ED ; edit data for new account + W ! K X,DA + S (DIE,DIC)="^DGBT(392.3,",DIC(0)="AEQLMZ",DLAYGO=392.3,DIC("DR")="" + D ^DIC K DIC G:$D(DTOUT)!$D(DUOUT)!(X="") QUIT1 G:Y'>0 ED + S DR="2///"_$P(Y(0)," ",1)_";3;4;5" ; account number now stuffed, not asked + S DA=+Y L ^DGBT(392.3,DA):2 E W !?5,"Another user is editing this entry.",*7 G ED + S DIE("NO^")=1 + D ^DIE L K DR,DIE,DIE("NO^") + W ! S DIR(0)="Y",DIR("A")="Would you like to Enter/Edit another ACCOUNT",DIR("B")="Yes" + D ^DIR K DIR G:$D(DTOUT)!($D(DUOUT))!(Y=0) QUIT1 G ED +QUIT1 ; + K DIR,DTOUT,DI,D0,DUOUT,DIRUT,DGBTN,DGBTDEDV,DGBTDEDM +QUIT ; + K %DT,DA,DIC,DIE,DIE("NO^"),DR,X,Y Q +DEDUCT(LIMIT,TYPE) ; enter new deductble value +DEDCT1 S DIR(0)="FAO",DIR("A")="ENTER DEDUCTIBLE AMOUNT/"_TYPE_": " + S DIR("?")="Type a dollar amount between 0 and "_LIMIT_" with up to 2 decimal places." + D ^DIR K DIR I $D(DUOUT)!($D(DTOUT))!(Y']"") S Y=-1 G DEDUCTQ + S:Y["$" Y=$P(Y,"$",2) + I Y'?.N,Y'?.N1".".N K X,Y,DIR G DEDCT1 + I Y>(LIMIT+.001) W " -- Deductible exceeds limit." K X,Y,DIR G DEDCT1 +DEDUCTQ Q (+Y) + ; +HELP W !!,"The effective date must start on the fiscal year, Oct 1.",! G DATE +HELP1 S DIC="^DG(43.1,",DIC(0)="QMZ",X="?" D ^DIC K DIC Q +HELP2 S DIC="^DGBT(392.3,",DIC(0)="QMZ",X="?" D ^DIC K DIC Q diff --git a/r/CLINICAL_CASE_REGISTRIES-ROR/RORHL09.m b/r/CLINICAL_CASE_REGISTRIES-ROR/RORHL09.m index d4f1945e..72907f99 100644 --- a/r/CLINICAL_CASE_REGISTRIES-ROR/RORHL09.m +++ b/r/CLINICAL_CASE_REGISTRIES-ROR/RORHL09.m @@ -1,276 +1,270 @@ -RORHL09 ;HOIFO/BH - HL7 OUTPATIENT DATA: PV1,OBR,OBX ; 3/13/06 9:24am - ;;1.5;CLINICAL CASE REGISTRIES;**1,5**;Feb 17, 2006;Build 10 - ; - ; 11/29/2007 BAY/KAM ROR*1.5*5 Rem Call 218601 Correct Outpatient - ; CPTs not transmitting to the AAC - ; - ; This routine uses the following IAs: - ; - ; #93 Get stop code from the file #44 (controlled) - ; #1889 Use of the ENCEVENT^PXKENC API - ; #1995 $$CODEC^ICPTCOD (supported) - ; #2309 Read access to the 'AA' x-ref in VISIT file (#9000010) - ; #3990 $$CODEC^ICDCODE (supported) - ; #10060 Read access to the file #200 (supported) - ; #2438 Access to the file #40.8 (field #1) (controlled) - ; - Q - ; - ;***** PROCESSES DIAGNOSIS CODES -DIAGS() ; - N DIAG,IEN,K5,OID,REC,TMP - S OID="OICD9"_RORCS_"Diagnosis"_RORCS_"VA080" - S K5="" - F S K5=$O(^TMP("PXKENC",$J,RORIEN,"POV",K5)) Q:K5="" D - . S REC=^TMP("PXKENC",$J,RORIEN,"POV",K5,0) - . S IEN=+$P(REC,U) Q:IEN'>0 - . ;--- - . S DIAG=$$CODEC^ICDCODE(IEN) - . D:DIAG'<0 SETOBX(OID,DIAG) - Q 0 - ; - ;***** OUTPATIENT DATA SEGMENT BUILDER - ; - ; RORDFN DFN of Patient Record in File #2 - ; - ; .DXDTS Reference to a local variable where the - ; data extraction time frames are stored. - ; - ; RORTY Set to either "PV1" or "OBR" - ; - ; The ^TMP("PXKENC",$J) and ^TMP("RORHL08",$J) global nodes are - ; used by this function. - ; - ; Return Values: - ; <0 Error Code - ; 0 Ok - ; >0 Non-fatal error(s) - ; -EN1(RORDFN,DXDTS,RORTY) ; - N ERRCNT,PIEN,PV1CNT,RC - S (ERRCNT,RC)=0 - ; - ;--- PV1 Segments - I RORTY="PV1" K ^TMP("PXKENC",$J),^TMP("RORHL09",$J) D - . N IDX,INVDT,ROREND - . S (IDX,PV1CNT)=0 - . F S IDX=$O(DXDTS(2,IDX)) Q:IDX'>0 D Q:RC<0 - . . S INVDT=9999999-$$FMADD^XLFDT($P(DXDTS(2,IDX),U)\1,-1) - . . S ROREND=9999999-$P(DXDTS(2,IDX),U,2) - . . F S INVDT=$O(^AUPNVSIT("AA",RORDFN,INVDT),-1) Q:'INVDT!(INVDT'>ROREND) D - . . . S PIEN="" - . . . F S PIEN=$O(^AUPNVSIT("AA",RORDFN,INVDT,PIEN),-1) Q:'PIEN D - . . . . S TMP=$$PV1(PIEN,RORDFN) - . . . . I TMP Q:TMP<0 S ERRCNT=ERRCNT+TMP - . . . . ;--- Reference for the corresponding OBR segment - . . . . S:TMP'="S" PV1CNT=PV1CNT+1,^TMP("RORHL09",$J,PV1CNT)=PIEN - ; - ;--- OBR and OBX Segments - I RORTY="OBR" D K ^TMP("PXKENC",$J),^TMP("RORHL09",$J) - . S PV1CNT=0 - . F S PV1CNT=$O(^TMP("RORHL09",$J,PV1CNT)) Q:PV1CNT'>0 D - . . S PIEN=+$G(^TMP("RORHL09",$J,PV1CNT)) Q:PIEN'>0 - . . ;--- - . . S TMP=$$OBR(PIEN,RORDFN) - . . I TMP Q:TMP<0 S ERRCNT=ERRCNT+TMP - . . ;--- - . . S TMP=$$OBX(PIEN,RORDFN) - . . I TMP Q:TMP<0 S ERRCNT=ERRCNT+TMP - ; - ;--- Check for errors - Q $S(RC<0:RC,1:ERRCNT) - ; - ;***** OBR SEGMENT BUILDER (OUTPATIENT) - ; - ; RORIEN IEN of file #9000010 - ; RORDFN DFN of Patient Record in File #2 - ; - ; Return Values: - ; <0 Error Code - ; 0 Ok - ; >0 Non-fatal error(s) - ; -OBR(RORIEN,RORDFN) ; - N CS,ERRCNT,RC,RORSEG,STN,TMP,VST0 - S (ERRCNT,RC)=0 - D ECH^RORHL7(.CS) - ; - S VST0=$G(^TMP("PXKENC",$J,RORIEN,"VST",RORIEN,0)) - ; - ;--- Initialize the segment - S RORSEG(0)="OBR" - ; - ;--- OBR-3 - Order Number (IEN in the VISIT file #9000010) - S RORSEG(3)=RORIEN - ; - ;--- OBR-4 - Universal Service ID - S RORSEG(4)="OP"_CS_"Outpatient"_CS_"C4" - ; - ;--- OBR-7 - Observation Date/Time (Visit Date/Time) *KEY* - S TMP=$$FMTHL7^XLFDT($P(VST0,U)) - Q:TMP'>0 $$ERROR^RORERR(-100,,,,"No visit date","ENCEVENT^PXKENC") - S RORSEG(7)=TMP - ; - ;--- OBR-24 - Diagnostic Service ID - S RORSEG(24)="PHY" - ; - ;--- OBR-44 - Division - S RORSEG(44)=$$SITE^RORUTL03(CS) - S TMP=+$P(VST0,U,6) ; LOC. OF ENCOUNTER (.06) - I TMP>0 D - . S TMP=$$NS^XUAF4(TMP),STN=$P(TMP,U,2) - . S:STN'="" RORSEG(44)=STN_CS_$P(TMP,U)_CS_"99VA4" - ; - ;--- Store the segment - D ADDSEG^RORHL7(.RORSEG) - Q ERRCNT - ; - ;***** OBX SEGMENT BUILDER (OUTPATIENT) - ; - ; RORIEN IEN of file #9000010 - ; RORDFN DFN of Patient Record in File #2 - ; - ; Return Values: - ; <0 Error Code - ; 0 Ok - ; >0 Non-fatal error(s) - ; -OBX(RORIEN,RORDFN) ; - N ERRCNT,RC,RORCS,RORLST,RORMSG,RORSEG,TMP - S (ERRCNT,RC)=0 - D ECH^RORHL7(.RORCS) - ; - ;--- Procedures - I $D(^TMP("PXKENC",$J,RORIEN,"CPT"))>1 D Q:RC<0 RC - . S RC=$$PROCS() S:RC ERRCNT=ERRCNT+1 - ;--- Diagnosis codes - I $D(^TMP("PXKENC",$J,RORIEN,"POV"))>1 D Q:RC<0 RC - . S RC=$$DIAGS() S:RC ERRCNT=ERRCNT+1 - ; - Q ERRCNT - ; - ;***** PROCESSES PROCEDURES -PROCS() ; - N CLASS,ERRCNT,IEN,K5,OID,PROC,PRV,REC,RORMSG,TMP - S ERRCNT=0 - S OID="OCPT"_RORCS_"Procedures"_RORCS_"VA080" - S K5="" - F S K5=$O(^TMP("PXKENC",$J,RORIEN,"CPT",K5)) Q:K5="" D - . S REC=$G(^TMP("PXKENC",$J,RORIEN,"CPT",K5,0)) - . S IEN=+$P(REC,U) Q:IEN'>0 - . ;--- - . S PROC=$$CODEC^ICPTCOD(IEN) - . Q:PROC<0 - . ;--- - . S PRV=+$P($G(^TMP("PXKENC",$J,RORIEN,"CPT",K5,12)),U,4) - . ;12/06/2007 BAY/KAM REM CALL 218601 Modified next 8 lines - . ;--- - . I PRV>0 D - .. S $P(PRV,RORCS,13)=$$GET1^DIQ(200,PRV_",",53.5,"E",,"RORMSG") - .. I $G(DIERR) D S ERRCNT=ERRCNT+1 - ... D DBS^RORERR("RORMSG",-99,,RORDFN,200,+PRV_",") - . E S PRV="" - . ;----------> End of changes for 218601 - . ;--- - . D SETOBX(OID,PROC,PRV) - Q ERRCNT - ; - ;***** PV1 SEGMENT BUILDER (OUTPATIENT) - ; - ; RORIEN IEN in the file #9000010 - ; RORDFN DFN of Patient Record in File #2 - ; - ; Return Values: - ; <0 Error Code - ; 0 Ok - ; "S" No visit data - ; >0 Non-fatal error(s) - ; -PV1(RORIEN,RORDFN) ; - N BUF,CLASS,CS,ERRCNT,IENS,KK4,RC,REC,REP,RORCLIN,RORMSG,PRV,TMP,TMP1,VST0 - S (ERRCNT,RC)=0 - D ECH^RORHL7(.CS,,.REP) - ; - ;--- Get Visit Data - D ENCEVENT^PXKENC(RORIEN,1) - Q:$D(^TMP("PXKENC",$J,RORIEN))<10 "S" - S VST0=$G(^TMP("PXKENC",$J,RORIEN,"VST",RORIEN,0)) - ; - ;--- Do not send visits with the following service categories: Daily - ;--- Hospitalization (D), Ancillary (X), Chart (C), Not Found (N), - ; (E), Event Historical, Hospitalization (H). - Q:"HEDXNC"[$P(VST0,U,7) "S" - ; - ;--- Initialize the segment - S RORSEG(0)="PV1" - ; - ;--- PV1-2 - Patient Class - S RORSEG(2)="O" ; O - Outpatient - ; - ;--- PV1-3 - Assigned Patient Location (Station Number and Stop Code) - S RORCLIN=+$P(VST0,U,22),BUF="" - I RORCLIN>0 D - . S IENS=RORCLIN_"," - . S TMP=$$GET1^DIQ(44,IENS,3.5,"I") Q:TMP'>0 - . S BUF=$$GET1^DIQ(40.8,TMP,1) Q:BUF="" ; Station Number - . S TMP=$$STOPCODE^RORUTL18(+RORCLIN) - . S $P(BUF,CS,6)=$S(TMP>0:TMP,1:"") ; Stop Code - Q:$P(BUF,CS,6)="" "S" ; Stop Code is required - S RORSEG(3)=BUF - ; - ; PV1-4 - Admission Type - S TMP=$P($G(^TMP("PXKENC",$J,RORIEN,"VST",RORIEN,150)),U,3) - S RORSEG(4)=TMP - ; - ;--- PV1-7 - Attending Physician (User IEN and Provider Class Name) - S (KK4,BUF)="" - F S KK4=$O(^TMP("PXKENC",$J,RORIEN,"PRV",KK4)) Q:KK4="" D - . S REC=$G(^TMP("PXKENC",$J,RORIEN,"PRV",KK4,0)) - . S PRV=+$P(REC,U) Q:(PRV'>0)!($P(REC,U,4)'="P") - . S $P(PRV,CS,13)=$$GET1^DIQ(200,PRV_",",53.5,"E",,"RORMSG") - . I $G(DIERR) D S ERRCNT=ERRCNT+1 - . . D DBS^RORERR("RORMSG",-99,,RORDFN,200,PRV_",") - . S BUF=BUF_REP_PRV - S RORSEG(7)=$P(BUF,REP,2,999) - ; - ;--- PV1-19 - Visit Number (IEN in the VISIT file #9000010) *KEY* - S RORSEG(19)=RORIEN - ; - ;--- PV1-44 - Admit Date/Time (Visit Date/Time) *KEY* - S TMP=$$FMTHL7^XLFDT($P(VST0,U)) - I TMP'>0 D Q RC - . S RC=$$ERROR^RORERR(-100,,,,"No admission date","ENCEVENT^PXKENC") - S RORSEG(44)=TMP - ; - ;--- PV1-51 - Visit Indicator (Deleted Visit Indicator) - S TMP=$P(VST0,U,11) - S RORSEG(51)=$S(TMP'="":TMP,1:0) - ; - ;--- Store the segment - D ADDSEG^RORHL7(.RORSEG) - Q ERRCNT - ; - ;***** LOW-LEVEL SEGMENT BUILDER - ; - ; OBX3 Observation Identifier - ; - ; OBX5 Observation Value - ; - ; [OBX16] Procedure Provider and Provider Class Name - ; -SETOBX(OBX3,OBX5,OBX16) ; - N RORSEG - S RORSEG(0)="OBX" - ;--- OBX-2 Value Type - S RORSEG(2)="FT" - ;--- OBX-3 Observation Identifier - S RORSEG(3)=OBX3 - ;--- OBX-5 Observation Value - S RORSEG(5)=OBX5 - ;--- OBX-11 Observation Result Status - S RORSEG(11)="F" - ;--- OBX-16 Responsible Observer (Procedure Provider) - S:$G(OBX16)'="" RORSEG(16)=OBX16 - ;--- Store the segment - D ADDSEG^RORHL7(.RORSEG) - Q +RORHL09 ;HOIFO/BH - HL7 OUTPATIENT DATA: PV1,OBR,OBX ; 3/13/06 9:24am + ;;1.5;CLINICAL CASE REGISTRIES;**1**;Feb 17, 2006;Build 24 + ; + ; This routine uses the following IAs: + ; + ; #93 Get stop code from the file #44 (controlled) + ; #1889 Use of the ENCEVENT^PXKENC API + ; #1995 $$CODEC^ICPTCOD (supported) + ; #2309 Read access to the 'AA' x-ref in VISIT file (#9000010) + ; #3990 $$CODEC^ICDCODE (supported) + ; #10060 Read access to the file #200 (supported) + ; #2438 Access to the file #40.8 (field #1) (controlled) + ; + Q + ; + ;***** PROCESSES DIAGNOSIS CODES +DIAGS() ; + N DIAG,IEN,K5,OID,REC,TMP + S OID="OICD9"_RORCS_"Diagnosis"_RORCS_"VA080" + S K5="" + F S K5=$O(^TMP("PXKENC",$J,RORIEN,"POV",K5)) Q:K5="" D + . S REC=^TMP("PXKENC",$J,RORIEN,"POV",K5,0) + . S IEN=+$P(REC,U) Q:IEN'>0 + . ;--- + . S DIAG=$$CODEC^ICDCODE(IEN) + . D:DIAG'<0 SETOBX(OID,DIAG) + Q 0 + ; + ;***** OUTPATIENT DATA SEGMENT BUILDER + ; + ; RORDFN DFN of Patient Record in File #2 + ; + ; .DXDTS Reference to a local variable where the + ; data extraction time frames are stored. + ; + ; RORTY Set to either "PV1" or "OBR" + ; + ; The ^TMP("PXKENC",$J) and ^TMP("RORHL08",$J) global nodes are + ; used by this function. + ; + ; Return Values: + ; <0 Error Code + ; 0 Ok + ; >0 Non-fatal error(s) + ; +EN1(RORDFN,DXDTS,RORTY) ; + N ERRCNT,PIEN,PV1CNT,RC + S (ERRCNT,RC)=0 + ; + ;--- PV1 Segments + I RORTY="PV1" K ^TMP("PXKENC",$J),^TMP("RORHL09",$J) D + . N IDX,INVDT,ROREND + . S (IDX,PV1CNT)=0 + . F S IDX=$O(DXDTS(2,IDX)) Q:IDX'>0 D Q:RC<0 + . . S INVDT=9999999-$$FMADD^XLFDT($P(DXDTS(2,IDX),U)\1,-1) + . . S ROREND=9999999-$P(DXDTS(2,IDX),U,2) + . . F S INVDT=$O(^AUPNVSIT("AA",RORDFN,INVDT),-1) Q:'INVDT!(INVDT'>ROREND) D + . . . S PIEN="" + . . . F S PIEN=$O(^AUPNVSIT("AA",RORDFN,INVDT,PIEN),-1) Q:'PIEN D + . . . . S TMP=$$PV1(PIEN,RORDFN) + . . . . I TMP Q:TMP<0 S ERRCNT=ERRCNT+TMP + . . . . ;--- Reference for the corresponding OBR segment + . . . . S:TMP'="S" PV1CNT=PV1CNT+1,^TMP("RORHL09",$J,PV1CNT)=PIEN + ; + ;--- OBR and OBX Segments + I RORTY="OBR" D K ^TMP("PXKENC",$J),^TMP("RORHL09",$J) + . S PV1CNT=0 + . F S PV1CNT=$O(^TMP("RORHL09",$J,PV1CNT)) Q:PV1CNT'>0 D + . . S PIEN=+$G(^TMP("RORHL09",$J,PV1CNT)) Q:PIEN'>0 + . . ;--- + . . S TMP=$$OBR(PIEN,RORDFN) + . . I TMP Q:TMP<0 S ERRCNT=ERRCNT+TMP + . . ;--- + . . S TMP=$$OBX(PIEN,RORDFN) + . . I TMP Q:TMP<0 S ERRCNT=ERRCNT+TMP + ; + ;--- Check for errors + Q $S(RC<0:RC,1:ERRCNT) + ; + ;***** OBR SEGMENT BUILDER (OUTPATIENT) + ; + ; RORIEN IEN of file #9000010 + ; RORDFN DFN of Patient Record in File #2 + ; + ; Return Values: + ; <0 Error Code + ; 0 Ok + ; >0 Non-fatal error(s) + ; +OBR(RORIEN,RORDFN) ; + N CS,ERRCNT,RC,RORSEG,STN,TMP,VST0 + S (ERRCNT,RC)=0 + D ECH^RORHL7(.CS) + ; + S VST0=$G(^TMP("PXKENC",$J,RORIEN,"VST",RORIEN,0)) + ; + ;--- Initialize the segment + S RORSEG(0)="OBR" + ; + ;--- OBR-3 - Order Number (IEN in the VISIT file #9000010) + S RORSEG(3)=RORIEN + ; + ;--- OBR-4 - Universal Service ID + S RORSEG(4)="OP"_CS_"Outpatient"_CS_"C4" + ; + ;--- OBR-7 - Observation Date/Time (Visit Date/Time) *KEY* + S TMP=$$FMTHL7^XLFDT($P(VST0,U)) + Q:TMP'>0 $$ERROR^RORERR(-100,,,,"No visit date","ENCEVENT^PXKENC") + S RORSEG(7)=TMP + ; + ;--- OBR-24 - Diagnostic Service ID + S RORSEG(24)="PHY" + ; + ;--- OBR-44 - Division + S RORSEG(44)=$$SITE^RORUTL03(CS) + S TMP=+$P(VST0,U,6) ; LOC. OF ENCOUNTER (.06) + I TMP>0 D + . S TMP=$$NS^XUAF4(TMP),STN=$P(TMP,U,2) + . S:STN'="" RORSEG(44)=STN_CS_$P(TMP,U)_CS_"99VA4" + ; + ;--- Store the segment + D ADDSEG^RORHL7(.RORSEG) + Q ERRCNT + ; + ;***** OBX SEGMENT BUILDER (OUTPATIENT) + ; + ; RORIEN IEN of file #9000010 + ; RORDFN DFN of Patient Record in File #2 + ; + ; Return Values: + ; <0 Error Code + ; 0 Ok + ; >0 Non-fatal error(s) + ; +OBX(RORIEN,RORDFN) ; + N ERRCNT,RC,RORCS,RORLST,RORMSG,RORSEG,TMP + S (ERRCNT,RC)=0 + D ECH^RORHL7(.RORCS) + ; + ;--- Procedures + I $D(^TMP("PXKENC",$J,RORIEN,"CPT"))>1 D Q:RC<0 RC + . S RC=$$PROCS() S:RC ERRCNT=ERRCNT+1 + ;--- Diagnosis codes + I $D(^TMP("PXKENC",$J,RORIEN,"POV"))>1 D Q:RC<0 RC + . S RC=$$DIAGS() S:RC ERRCNT=ERRCNT+1 + ; + Q ERRCNT + ; + ;***** PROCESSES PROCEDURES +PROCS() ; + N CLASS,ERRCNT,IEN,K5,OID,PROC,PRV,REC,RORMSG,TMP + S ERRCNT=0 + S OID="OCPT"_RORCS_"Procedures"_RORCS_"VA080" + S K5="" + F S K5=$O(^TMP("PXKENC",$J,RORIEN,"CPT",K5)) Q:K5="" D + . S REC=$G(^TMP("PXKENC",$J,RORIEN,"CPT",K5,0)) + . S IEN=+$P(REC,U) Q:IEN'>0 + . ;--- + . S PROC=$$CODEC^ICPTCOD(IEN) + . Q:PROC<0 + . ;--- + . S PRV=+$P($G(^TMP("PXKENC",$J,RORIEN,"CPT",K5,12)),U,4) + . Q:PRV'>0 + . ;--- + . S $P(PRV,RORCS,13)=$$GET1^DIQ(200,PRV_",",53.5,"E",,"RORMSG") + . I $G(DIERR) D S ERRCNT=ERRCNT+1 + . . D DBS^RORERR("RORMSG",-99,,RORDFN,200,+PRV_",") + . ;--- + . D SETOBX(OID,PROC,PRV) + Q ERRCNT + ; + ;***** PV1 SEGMENT BUILDER (OUTPATIENT) + ; + ; RORIEN IEN in the file #9000010 + ; RORDFN DFN of Patient Record in File #2 + ; + ; Return Values: + ; <0 Error Code + ; 0 Ok + ; "S" No visit data + ; >0 Non-fatal error(s) + ; +PV1(RORIEN,RORDFN) ; + N BUF,CLASS,CS,ERRCNT,IENS,KK4,RC,REC,REP,RORCLIN,RORMSG,PRV,TMP,TMP1,VST0 + S (ERRCNT,RC)=0 + D ECH^RORHL7(.CS,,.REP) + ; + ;--- Get Visit Data + D ENCEVENT^PXKENC(RORIEN,1) + Q:$D(^TMP("PXKENC",$J,RORIEN))<10 "S" + S VST0=$G(^TMP("PXKENC",$J,RORIEN,"VST",RORIEN,0)) + ; + ;--- Do not send visits with the following service categories: Daily + ;--- Hospitalization (D), Ancillary (X), Chart (C), Not Found (N), + ; (E), Event Historical, Hospitalization (H). + Q:"HEDXNC"[$P(VST0,U,7) "S" + ; + ;--- Initialize the segment + S RORSEG(0)="PV1" + ; + ;--- PV1-2 - Patient Class + S RORSEG(2)="O" ; O - Outpatient + ; + ;--- PV1-3 - Assigned Patient Location (Station Number and Stop Code) + S RORCLIN=+$P(VST0,U,22),BUF="" + I RORCLIN>0 D + . S IENS=RORCLIN_"," + . S TMP=$$GET1^DIQ(44,IENS,3.5,"I") Q:TMP'>0 + . S BUF=$$GET1^DIQ(40.8,TMP,1) Q:BUF="" ; Station Number + . S TMP=$$STOPCODE^RORUTL18(+RORCLIN) + . S $P(BUF,CS,6)=$S(TMP>0:TMP,1:"") ; Stop Code + Q:$P(BUF,CS,6)="" "S" ; Stop Code is required + S RORSEG(3)=BUF + ; + ; PV1-4 - Admission Type + S TMP=$P($G(^TMP("PXKENC",$J,RORIEN,"VST",RORIEN,150)),U,3) + S RORSEG(4)=TMP + ; + ;--- PV1-7 - Attending Physician (User IEN and Provider Class Name) + S (KK4,BUF)="" + F S KK4=$O(^TMP("PXKENC",$J,RORIEN,"PRV",KK4)) Q:KK4="" D + . S REC=$G(^TMP("PXKENC",$J,RORIEN,"PRV",KK4,0)) + . S PRV=+$P(REC,U) Q:(PRV'>0)!($P(REC,U,4)'="P") + . S $P(PRV,CS,13)=$$GET1^DIQ(200,PRV_",",53.5,"E",,"RORMSG") + . I $G(DIERR) D S ERRCNT=ERRCNT+1 + . . D DBS^RORERR("RORMSG",-99,,RORDFN,200,PRV_",") + . S BUF=BUF_REP_PRV + S RORSEG(7)=$P(BUF,REP,2,999) + ; + ;--- PV1-19 - Visit Number (IEN in the VISIT file #9000010) *KEY* + S RORSEG(19)=RORIEN + ; + ;--- PV1-44 - Admit Date/Time (Visit Date/Time) *KEY* + S TMP=$$FMTHL7^XLFDT($P(VST0,U)) + I TMP'>0 D Q RC + . S RC=$$ERROR^RORERR(-100,,,,"No admission date","ENCEVENT^PXKENC") + S RORSEG(44)=TMP + ; + ;--- PV1-51 - Visit Indicator (Deleted Visit Indicator) + S TMP=$P(VST0,U,11) + S RORSEG(51)=$S(TMP'="":TMP,1:0) + ; + ;--- Store the segment + D ADDSEG^RORHL7(.RORSEG) + Q ERRCNT + ; + ;***** LOW-LEVEL SEGMENT BUILDER + ; + ; OBX3 Observation Identifier + ; + ; OBX5 Observation Value + ; + ; [OBX16] Procedure Provider and Provider Class Name + ; +SETOBX(OBX3,OBX5,OBX16) ; + N RORSEG + S RORSEG(0)="OBX" + ;--- OBX-2 Value Type + S RORSEG(2)="FT" + ;--- OBX-3 Observation Identifier + S RORSEG(3)=OBX3 + ;--- OBX-5 Observation Value + S RORSEG(5)=OBX5 + ;--- OBX-11 Observation Result Status + S RORSEG(11)="F" + ;--- OBX-16 Responsible Observer (Procedure Provider) + S:$G(OBX16)'="" RORSEG(16)=OBX16 + ;--- Store the segment + D ADDSEG^RORHL7(.RORSEG) + Q diff --git a/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEVPRG.m b/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEVPRG.m index fa141252..a7b273ae 100644 --- a/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEVPRG.m +++ b/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEVPRG.m @@ -1,188 +1,228 @@ -RGEVPRG ;BAY/ALS-OPTIONS TO PURGE MPI/PD EXCEPTIONS ;08/23/99 - ;;1.0;CLINICAL INFO RESOURCE NETWORK;**3,12,19,32,35,43,44,50,52**;30 Apr 99;Build 2 - ; -MAIN ; - ;Q:($D(^TMP("RGEXC")))!($D(^TMP("RGEXC2"))) - L +^RGHL7(991.1):0 I '$T Q - L -^RGHL7(991.1) - L +^RGHL7(991.1,"RG PURGE EXCEPTION"):5 E Q - I $D(ZTQUEUED) S ZTREQ="@" - S $P(^RGSITE(991.8,1,"EXCPRG"),"^",1)=$$NOW^XLFDT - S $P(^RGSITE(991.8,1,"EXCPRG"),"^",3)="R" - ;D PROC ;**52 Module is obsolete - D PRGDUP - D PRG30 - D PRGZZ - S $P(^RGSITE(991.8,1,"EXCPRG"),"^",2)=$$NOW^XLFDT - S $P(^RGSITE(991.8,1,"EXCPRG"),"^",3)="C" - L -^RGHL7(991.1,"RG PURGE EXCEPTION") - Q -PRGPAT ;Purge by Patient - W ! - S DIC="^DPT(",DIC(0)="QEAM",DIC("A")="Select PATIENT: " - D ^DIC K DIC G:Y<0 QUIT S RGDFN=+Y - S EXCT="",FLAG=0 - F S EXCT=$O(^RGHL7(991.1,"ADFN",EXCT)) Q:EXCT="" D - . I $D(^RGHL7(991.1,"ADFN",EXCT,RGDFN)) S FLAG=1 Q - I FLAG=0 W !,"There are no exceptions on file for this patient." G PRGPAT - I $$IFLOCAL^MPIF001(RGDFN) W !,"This patient does not have a national ICN assigned, do not purge." Q - S DFN=RGDFN D DEM^VADPT - S DIR(0)="YA",DIR("B")="YES" - S DIR("A")="Are you sure you want to purge all exceptions on file for "_VADM(1)_"? YES// " - D ^DIR Q:$D(DIRUT) I Y>0 D - . S EXCT="",CNT=0 - . F S EXCT=$O(^RGHL7(991.1,"ADFN",EXCT)) Q:'EXCT D - .. S IEN=0 - .. F S IEN=$O(^RGHL7(991.1,"ADFN",EXCT,RGDFN,IEN)) Q:'IEN D - ... S IEN2=0 - ... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCT,RGDFN,IEN,IEN2)) Q:'IEN2 D - .... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4) - .... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA S CNT=CNT+1 - .... E I NUM>1 D DEL - . W !,"All exceptions purged for "_VADM(1)_" DFN: "_RGDFN - K EXCT,DFN,FLAG,VADM,CNT,IEN,IEN2,NUM,RGDFN,Y -QUIT Q - ; -PRGDT ; Purge by Date - W !!,"Enter a date for the purge. All exceptions on file, on or before that date, will be deleted." - K DIR,DIRUT,DTOUT,DUOUT - S DIR(0)="DA^:DT:EPX",DIR("A")="Enter Date for Purge: " - D ^DIR K DIR Q:$D(DIRUT) - S PURDT=Y - S PDATE=$$FMTE^XLFDT(PURDT) - S DIR(0)="YA",DIR("B")="YES" - S DIR("A")="Are you sure you want to purge all exceptions on file dated on or before "_PDATE_"? YES// " - D ^DIR Q:$D(DIRUT) I Y>0 D - . S EXCDT="",CNT=0 - . F S EXCDT=$O(^RGHL7(991.1,"AD",EXCDT)) Q:'EXCDT D - .. I ($P(EXCDT,".",1)=PURDT)!($P(EXCDT,".",1)0 W !,CNT_" exceptions, dated on or before "_PDATE_" have been purged!" - K PDATE,PURDT,EXCDT,CNT,IEN,NUM,Y - Q -PRG30 ; Purge Exceptions over 30 days old - S TODAY="" - S TODAY=$$NOW^XLFDT D - . S EXCDT="",CNT=0,DIFF="" - . F S EXCDT=$O(^RGHL7(991.1,"AD",EXCDT)) Q:'EXCDT D - .. S DIFF=$$FMDIFF^XLFDT(TODAY,EXCDT) - .. I DIFF>30 D - ... S IEN=0 - ... F S IEN=$O(^RGHL7(991.1,"AD",EXCDT,IEN)) Q:'IEN D - .... S NUM="" S NUM=$P($G(^RGHL7(991.1,IEN,1,0)),"^",4) Q:'NUM - .... S IEN2=0 - .... F S IEN2=$O(^RGHL7(991.1,IEN,1,IEN2)) Q:'IEN2 D - ..... S STAT="" - ..... S STAT=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",5) - ..... ; Only delete PROCESSED exceptions - ..... I (STAT>0)!(STAT="") D - ...... I NUM>1 D DEL - ...... E I NUM=1 D - ....... S CNT=CNT+NUM - ....... S DIK="^RGHL7(991.1,",DA=IEN - ....... D ^DIK K DIK,DA - K DIFF,TODAY,EXCDT,CNT,IEN,IEN2,NUM,STAT - Q -PRGEXC ; Purge by Exception Type - ;**52 This module was obsolete before 52; just adding comment - ;S DIC="^RGHL7(991.11,",DIC(0)="QEAM" - ;S DIC("A")="Enter an exception type to purge: " - ;D ^DIC K DIC G:Y<200 QUIT S EXCTYP=+Y,ETYPE=X - ;S DIR(0)="YA",DIR("B")="YES" - ;S DIR("A")="*WARNING* This will permanently delete all "_ETYPE_" exceptions. Are you sure you want to do this? YES// " - ;D ^DIR Q:$D(DIRUT) I Y>0 D - ;. S CNT=0,IEN="" - ;. F S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN D - ;.. S IEN2=0 - ;.. F S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2 D - ;... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4) - ;... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA S CNT=CNT+1 - ;... E I NUM>1 D DEL - ;I CNT=0 W !,"There are no "_ETYPE_" exceptions on file." - ;E I CNT>0 W !,CNT_" "_ETYPE_" Exceptions purged!" - ;K ETYPE,CNT,IEN,IEN2,NUM,X,Y - Q ;**52;if module accidentally called, should quit instead of falling into next module. -PRGDUP ;Purge Duplicate Entries; retain most recent for all except types. - ;**50 through remainder of module. - S EXCTYP="",CNT=0 - K ^TMP("RGEVDUP",$J) - F S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP D - . S RGDFN="" - . F S RGDFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN)) Q:'RGDFN D - .. S IEN=0 - .. F S IEN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN)) Q:'IEN D - ... S IEN2=0 - ... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2)) Q:'IEN2 D - .... I $P($G(^RGHL7(991.1,IEN,1,IEN2,0)),"^",5)=1 K ^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2) Q ;exception processed - .... S EXCDT=$P($G(^RGHL7(991.1,IEN,0)),"^",3) ;incoming date - .... I '$D(^TMP("RGEVDUP",$J,RGDFN,EXCTYP)) D Q - ..... S ^TMP("RGEVDUP",$J,RGDFN,EXCTYP)=EXCDT_"^"_IEN_"^"_IEN2 - .... I $D(^TMP("RGEVDUP",$J,RGDFN,EXCTYP)) D ;duplicate exists; compare incoming to previous. - ..... S OLDNODE=^TMP("RGEVDUP",$J,RGDFN,EXCTYP) - ..... S OLDDT=$P(OLDNODE,"^"),OLDIEN=$P(OLDNODE,"^",2),OLDIEN2=$P(OLDNODE,"^",3) - ..... I EXCDT>OLDDT D Q ;incoming date greater than previous? purge old, keep new. - ...... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4) - ...... I NUM=1 S DIK="^RGHL7(991.1,",DA=OLDIEN D ^DIK K DIK,DA - ...... I NUM>1 D - ....... S DA(1)=OLDIEN,DA=OLDIEN2 - ....... S DIK="^RGHL7(991.1,"_DA(1)_",1," D ^DIK K DIK,DA - ...... S ^TMP("RGEVDUP",$J,RGDFN,EXCTYP)=EXCDT_"^"_IEN_"^"_IEN2 - ..... ; - ..... I OLDDT>EXCDT!(OLDDT=EXCDT) D ;previous date greater or equal incoming? purge new, keep old. - ...... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4) - ...... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA - ...... I NUM>1 D DEL - ...... ; - K CNT,EXCDT,EXCTYP,IEN,IEN2,NUM,OLDDT,OLDIEN,OLDIEN2,OLDNODE,RGDFN,RGDT,^TMP("RGEVDUP") - Q - ; -PRGZZ ;Purge if name field is null (incomplete record) - ;Purge if -9 node exists, this indicates the record has been merged. - S EXCTYP="",CNT="" - F S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP D - . S RGDFN="" - . F S RGDFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN)) Q:'RGDFN D - .. S IEN=0 - .. F S IEN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN)) Q:'IEN D - ... S IEN2=0 - ... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2)) Q:'IEN2 D - .... S DFN=RGDFN D DEM^VADPT - .... I VADM(1)=""!($D(^DPT(RGDFN,-9))) D - ..... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4) - ..... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA - ..... E I NUM>1 D DEL - K EXCTYP,RGDFN,DFN,IEN,IEN2,NUM,VADM - Q -DEL ; - S CNT=CNT+1 - S DA(1)=IEN,DA=IEN2 - S DIK="^RGHL7(991.1,"_DA(1)_",1," - D ^DIK K DIK,DA - Q -PROC ;Set these exception types to PROCESSED if they have a national ICN - ;**52 The PROC module is obsolete and is no longer being called. - ;209 - Required field(s) missing for patient sent to MPI, - ;227 - Multiple ICNs, 213 - SSN Match Failed, 214 - Name Doesn't Match - ;S EXCTYP="" - ;S HOME=$$SITE^VASITE() - ;F S EXCTYP=$O(^RGHL7(991.1,"AC",EXCTYP)) Q:'EXCTYP D - ;. I (EXCTYP=209)!(EXCTYP=227)!(EXCTYP=213)!(EXCTYP=214) D ;**43 - ;.. S IEN=0 - ;.. F S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN D - ;... S IEN2=0,ICN="",RGDFN="" - ;... F S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2 D - ;.... S RGDFN=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",4) Q:'RGDFN - ;.... S ICN=+$$GETICN^MPIF001(RGDFN) - ;.... I $E(ICN,1,3)'=$E($P(HOME,"^",3),1,3)&(ICN>0) D - ;..... L +^RGHL7(991.1,IEN):10 - ;..... S DA(1)=IEN,DA=IEN2,DR="6///"_1,DIE="^RGHL7(991.1,"_DA(1)_",1," - ;..... D ^DIE K DIE,DA,DR - ;..... L -^RGHL7(991.1,IEN) - ;K EXCTYP,HOME,ICN,IEN,IEN2,RGDFN - Q +RGEVPRG ;BAY/ALS-OPTIONS TO PURGE MPI/PD EXCEPTIONS ;08/23/99 + ;;1.0;CLINICAL INFO RESOURCE NETWORK;**3,12,19,32,35,43,44**;30 Apr 99;Build 8 + ; +MAIN ; + ;Q:($D(^TMP("RGEXC")))!($D(^TMP("RGEXC2"))) + L +^RGHL7(991.1):0 I '$T Q + L -^RGHL7(991.1) + L +^RGHL7(991.1,"RG PURGE EXCEPTION"):5 E Q + I $D(ZTQUEUED) S ZTREQ="@" + S $P(^RGSITE(991.8,1,"EXCPRG"),"^",1)=$$NOW^XLFDT + S $P(^RGSITE(991.8,1,"EXCPRG"),"^",3)="R" + D PROC + D PRGDUP + D PRG30 + D PRGZZ + S $P(^RGSITE(991.8,1,"EXCPRG"),"^",2)=$$NOW^XLFDT + S $P(^RGSITE(991.8,1,"EXCPRG"),"^",3)="C" + L -^RGHL7(991.1,"RG PURGE EXCEPTION") + Q +PRGPAT ;Purge by Patient + W ! + S DIC="^DPT(",DIC(0)="QEAM",DIC("A")="Select PATIENT: " + D ^DIC K DIC G:Y<0 QUIT S RGDFN=+Y + S EXCT="",FLAG=0 + F S EXCT=$O(^RGHL7(991.1,"ADFN",EXCT)) Q:EXCT="" D + . I $D(^RGHL7(991.1,"ADFN",EXCT,RGDFN)) S FLAG=1 Q + I FLAG=0 W !,"There are no exceptions on file for this patient." G PRGPAT + I $$IFLOCAL^MPIF001(RGDFN) W !,"This patient does not have a national ICN assigned, do not purge." Q + S DFN=RGDFN D DEM^VADPT + S DIR(0)="YA",DIR("B")="YES" + S DIR("A")="Are you sure you want to purge all exceptions on file for "_VADM(1)_"? YES// " + D ^DIR Q:$D(DIRUT) I Y>0 D + . S EXCT="",CNT=0 + . F S EXCT=$O(^RGHL7(991.1,"ADFN",EXCT)) Q:'EXCT D + .. S IEN=0 + .. F S IEN=$O(^RGHL7(991.1,"ADFN",EXCT,RGDFN,IEN)) Q:'IEN D + ... S IEN2=0 + ... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCT,RGDFN,IEN,IEN2)) Q:'IEN2 D + .... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4) + .... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA S CNT=CNT+1 + .... E I NUM>1 D DEL + . W !,"All exceptions purged for "_VADM(1)_" DFN: "_RGDFN + K EXCT,DFN,FLAG,VADM,CNT,IEN,IEN2,NUM,RGDFN,Y +QUIT Q + ; +PRGDT ; Purge by Date + W !!,"Enter a date for the purge. All exceptions on file, on or before that date, will be deleted." + K DIR,DIRUT,DTOUT,DUOUT + S DIR(0)="DA^:DT:EPX",DIR("A")="Enter Date for Purge: " + D ^DIR K DIR Q:$D(DIRUT) + S PURDT=Y + S PDATE=$$FMTE^XLFDT(PURDT) + S DIR(0)="YA",DIR("B")="YES" + S DIR("A")="Are you sure you want to purge all exceptions on file dated on or before "_PDATE_"? YES// " + D ^DIR Q:$D(DIRUT) I Y>0 D + . S EXCDT="",CNT=0 + . F S EXCDT=$O(^RGHL7(991.1,"AD",EXCDT)) Q:'EXCDT D + .. I ($P(EXCDT,".",1)=PURDT)!($P(EXCDT,".",1)0 W !,CNT_" exceptions, dated on or before "_PDATE_" have been purged!" + K PDATE,PURDT,EXCDT,CNT,IEN,NUM,Y + Q +PRG30 ; Purge Exceptions over 30 days old + S TODAY="" + S TODAY=$$NOW^XLFDT D + . S EXCDT="",CNT=0,DIFF="" + . F S EXCDT=$O(^RGHL7(991.1,"AD",EXCDT)) Q:'EXCDT D + .. S DIFF=$$FMDIFF^XLFDT(TODAY,EXCDT) + .. I DIFF>30 D + ... S IEN=0 + ... F S IEN=$O(^RGHL7(991.1,"AD",EXCDT,IEN)) Q:'IEN D + .... S NUM="" S NUM=$P($G(^RGHL7(991.1,IEN,1,0)),"^",4) Q:'NUM + .... S IEN2=0 + .... F S IEN2=$O(^RGHL7(991.1,IEN,1,IEN2)) Q:'IEN2 D + ..... S STAT="" + ..... S STAT=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",5) + ..... ; Only delete PROCESSED exceptions + ..... I (STAT>0)!(STAT="") D + ...... I NUM>1 D DEL + ...... E I NUM=1 D + ....... S CNT=CNT+NUM + ....... S DIK="^RGHL7(991.1,",DA=IEN + ....... D ^DIK K DIK,DA + K DIFF,TODAY,EXCDT,CNT,IEN,IEN2,NUM,STAT + Q +PRGEXC ; Purge by Exception Type + ;S DIC="^RGHL7(991.11,",DIC(0)="QEAM" + ;S DIC("A")="Enter an exception type to purge: " + ;D ^DIC K DIC G:Y<200 QUIT S EXCTYP=+Y,ETYPE=X + ;S DIR(0)="YA",DIR("B")="YES" + ;S DIR("A")="*WARNING* This will permanently delete all "_ETYPE_" exceptions. Are you sure you want to do this? YES// " + ;D ^DIR Q:$D(DIRUT) I Y>0 D + ;. S CNT=0,IEN="" + ;. F S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN D + ;.. S IEN2=0 + ;.. F S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2 D + ;... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4) + ;... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA S CNT=CNT+1 + ;... E I NUM>1 D DEL + ;I CNT=0 W !,"There are no "_ETYPE_" exceptions on file." + ;E I CNT>0 W !,CNT_" "_ETYPE_" Exceptions purged!" + ;K ETYPE,CNT,IEN,IEN2,NUM,X,Y + ;Q +PRGDUP ; Purge Duplicate Entries; retain most recent for all types except 234. + S EXCTYP="",CNT=0 + K ^TMP("RGEVDUP",$J) + F S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP D + . I EXCTYP=234 Q ;**44 process 234s separately below + . S RGDFN="" + . F S RGDFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN)) Q:'RGDFN D + .. S IEN=0 + .. F S IEN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN)) Q:'IEN D + ... S IEN2=0 + ... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2)) Q:'IEN2 D + .... S EXCDT=$P(^RGHL7(991.1,IEN,0),"^",3) + .... I '$D(^TMP("RGEVDUP",$J,RGDFN,EXCTYP)) D Q + ..... S ^TMP("RGEVDUP",$J,RGDFN,EXCTYP)=EXCDT_"^"_IEN_"^"_IEN2 + .... I $D(^TMP("RGEVDUP",$J,RGDFN,EXCTYP)) D + ..... S OLDNODE=^TMP("RGEVDUP",$J,RGDFN,EXCTYP) + ..... S OLDDT=$P(OLDNODE,"^") + ..... I EXCDT>OLDDT D Q + ...... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4) + ...... I NUM=1 S DIK="^RGHL7(991.1,",DA=$P(OLDNODE,"^",2) D ^DIK K DIK,DA + ...... E I NUM>1 D + ....... S DA(1)=$P(OLDNODE,"^",2),DA=$P(OLDNODE,"^",3) + ....... S DIK="^RGHL7(991.1,"_DA(1)_",1," D ^DIK K DIK,DA + ...... S CNT=CNT+1 + ...... S ^TMP("RGEVDUP",$J,RGDFN,EXCTYP)=EXCDT_"^"_IEN_"^"_IEN2 + ..... I OLDDT>EXCDT!(OLDDT=EXCDT) D + ...... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4) + ...... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA S CNT=CNT+1 + ...... E I NUM>1 D DEL + ; W !,CNT_" Duplicate entries" + ;Process PRIMARY VIEW REJECT (234) duplicates; purge if for SAME day. + ;**44 through remainder of module. + K ^TMP("RGDFNDT",$J) S RGDFN="" + F S RGDFN=$O(^RGHL7(991.1,"ADFN",234,RGDFN)) Q:'RGDFN D + .S IEN=0 + .F S IEN=$O(^RGHL7(991.1,"ADFN",234,RGDFN,IEN)) Q:'IEN D + ..S IEN2=0 + ..F S IEN2=$O(^RGHL7(991.1,"ADFN",234,RGDFN,IEN,IEN2)) Q:'IEN2 D + ...S EXCDT=$P(^RGHL7(991.1,IEN,0),"^",3) + ...;How many for each DFN? Store in ^TMP("RGDFNDT") + ...I '$D(^TMP("RGDFNDT",$J,RGDFN)) S ^TMP("RGDFNDT",$J,RGDFN)=0 + ...I $D(^TMP("RGDFNDT",$J,RGDFN)) D + ....S ^TMP("RGDFNDT",$J,RGDFN)=^TMP("RGDFNDT",$J,RGDFN)+1 + ....S ^TMP("RGDFNDT",$J,RGDFN,IEN,IEN2)=$P(EXCDT,".") ;date only/no time + ;If RGDFN has more than 1 exception, see if any are for same DAY. + ;Process the ^TMP("RGDFNDT",$J global to build LOC array. + I $D(^TMP("RGDFNDT",$J)) D + .S RGDFN="" + .F S RGDFN=$O(^TMP("RGDFNDT",$J,RGDFN)) Q:'RGDFN D + ..;If only one 234 exception for DFN ignore it. + ..I ^TMP("RGDFNDT",$J,RGDFN)=1 Q + ..;More than one for this DFN? How many for same day? + ..S IEN=0 K LOC + ..F S IEN=$O(^TMP("RGDFNDT",$J,RGDFN,IEN)) Q:'IEN D + ...S (IEN2,VAL)=0 + ...F S IEN2=$O(^TMP("RGDFNDT",$J,RGDFN,IEN,IEN2)) Q:'IEN2 D + ....S VAL=$P(^TMP("RGDFNDT",$J,RGDFN,IEN,IEN2),"^") + ....I '$D(LOC(VAL)) S LOC(VAL)=0 + ....I $D(LOC(VAL)) D + .....S LOC(VAL)=LOC(VAL)+1 + .....S LOC(VAL,IEN,IEN2)="" + ..;Process the LOC array; contains numbers / day / DFN. + ..;If only 1 exception / day, keep it. + ..S RGDT=0 K CTR,TOT + ..F S RGDT=$O(LOC(RGDT)) Q:'RGDT D + ...S TOT=LOC(RGDT) + ...I TOT=1 K TOT Q ;only 1. + ...;More than 1, delete all except 1. + ...S TOT=TOT-1 ;leave 1; doesn't matter which - all are same day. + ...S IEN=0,CTR=0 + ...F S IEN=$O(LOC(RGDT,IEN)) Q:'IEN D + ....I CTR=TOT Q + ....S CTR=CTR+1,IEN2=0 + ....F S IEN2=$O(LOC(RGDT,IEN,IEN2)) Q:'IEN2 D DEL ;delete entry + K CNT,CTR,EXCDT,IEN,IEN2,LOC,NUM,OLDDT,OLDNODE,RGDFN,RGDT,TOT,VAL,^TMP("RGDFNDT") + Q +PRGZZ ;Purge if name field is null (incomplete record) + ;Purge if -9 node exists, this indicates the record has been merged. + S EXCTYP="",CNT="" + F S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP D + . S RGDFN="" + . F S RGDFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN)) Q:'RGDFN D + .. S IEN=0 + .. F S IEN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN)) Q:'IEN D + ... S IEN2=0 + ... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2)) Q:'IEN2 D + .... S DFN=RGDFN D DEM^VADPT + .... I VADM(1)=""!($D(^DPT(RGDFN,-9))) D + ..... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4) + ..... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA + ..... E I NUM>1 D DEL + K EXCTYP,RGDFN,DFN,IEN,IEN2,NUM,VADM + Q +DEL ; + S CNT=CNT+1 + S DA(1)=IEN,DA=IEN2 + S DIK="^RGHL7(991.1,"_DA(1)_",1," + D ^DIK K DIK,DA + Q +PROC ;Set these exception types to PROCESSED if they have a national ICN + ;209 - Required field(s) missing for patient sent to MPI, + ;227 - Multiple ICNs, 213 - SSN Match Failed, 214 - Name Doesn't Match + S EXCTYP="" + S HOME=$$SITE^VASITE() + F S EXCTYP=$O(^RGHL7(991.1,"AC",EXCTYP)) Q:'EXCTYP D + . I (EXCTYP=209)!(EXCTYP=227)!(EXCTYP=213)!(EXCTYP=214) D ;**43 + .. S IEN=0 + .. F S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN D + ... S IEN2=0,ICN="",RGDFN="" + ... F S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2 D + .... S RGDFN=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",4) Q:'RGDFN + .... S ICN=+$$GETICN^MPIF001(RGDFN) + .... I $E(ICN,1,3)'=$E($P(HOME,"^",3),1,3)&(ICN>0) D + ..... L +^RGHL7(991.1,IEN):10 + ..... S DA(1)=IEN,DA=IEN2,DR="6///"_1,DIE="^RGHL7(991.1,"_DA(1)_",1," + ..... D ^DIE K DIE,DA,DR + ..... L -^RGHL7(991.1,IEN) + K EXCTYP,HOME,ICN,IEN,IEN2,RGDFN + Q diff --git a/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEX01.m b/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEX01.m index 5e6e401e..aed24938 100644 --- a/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEX01.m +++ b/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEX01.m @@ -1,157 +1,156 @@ -RGEX01 ;BAY/ALS-LIST MANAGER FOR MPI/PD EXCEPTIONS ;10/07/99 - ;;1.0;CLINICAL INFO RESOURCE NETWORK;**3,12,19,23,43,45,47,48,52**;30 Apr 99;Build 2 - ; - ;Reference to MAIN^VAFCPDAT supported by IA #3299 -EN ; -- main entry point for RG EXCPT SUMMARY - N STDT,ENDDT,PRGSTAT,XFLAG,NOW,%,X,%H,%I,INDT,RUN,INDTT - S XFLAG=0 D NOW^%DTC S NOW=% - S STDT=$P($G(^RGSITE(991.8,1,"EXCPRG")),"^",1),INDT=STDT - I $D(STDT) S STDT=$$FMTE^XLFDT(STDT,1) - S PRGSTAT=$P($G(^RGSITE(991.8,1,"EXCPRG")),"^",3) - ;status shows 'running' but lock shows 'not running';**47 - I PRGSTAT="R" D - .L +^RGHL7(991.1,"RG PURGE EXCEPTION"):0 I $T D ;can get lock - ..L +^RGSITE(991.8):10 - ..S DIE="^RGSITE(991.8,",DA=1,DR="42///@" - ..D ^DIE K DA,DIE,DR ;delete old status - ..L -^RGSITE(991.8) - ..S PRGSTAT="" - .L -^RGHL7(991.1,"RG PURGE EXCEPTION") - I PRGSTAT="" D - . W $C(7) - . W !!,"The MPI/PD Exception Purge process has not been run." - . ;**48 NO LONGER A CHOICE - . W !!,"The MPI/PD Exception Purge process will now run." - . W !,"Please come back to this option in five minutes." - . W !!,"Please contact IRM to schedule the MPI/PD EXCEPTION PURGE" - . W !,"[RG EXCEPTION PURGE] option via TaskMan with a frequency of once an hour." - . S XFLAG=1 D QUEPRG - L +^RGHL7(991.1,"RG PURGE EXCEPTION"):0 I '$T W $C(7),!!,"The MPI/PD Exception Purge process is currently running.",!,"Please try this option again in five minutes." S XFLAG=1 G EXIT - L -^RGHL7(991.1,"RG PURGE EXCEPTION") - S RUN=0 - I $G(PRGSTAT)="C" D - . I $P(INDT,".")<$P(NOW,".") S RUN=1 ;RAN A PREVIOUS DAY - . I $P(INDT,".")=$P(NOW,".") D - .. S INDTT=$E($P(INDT,".",2),1,4),INDTT=INDTT+101 - .. I INDTT<$E($P(NOW,".",2),1,4) S RUN=1 - . Q:RUN=0 - . ;** if job ran more than 1 hour ago, run it now. - . W !!,"The MPI/PD Exception Purge process last ran "_STDT_"." - . W !!,"The MPI/PD Exception Purge process will now run." - . W !,"Please come back to this option in five minutes." - . W !!,"Please contact IRM to verify that the MPI/PD EXCEPTION PURGE " - . W !,"[RG EXCEPTION PURGE] option is scheduled to run via TaskMan" - . W !,"with a frequency of once an hour." - . S XFLAG=1 D QUEPRG - I XFLAG=1 G EXIT - K RGANS - D WAIT^DICD - D EN^VALM("RG EXCPT SUMMARY") - Q - ; -HDR ; -- header code - S VALMHDR(1)="MPI/PD Exception Handling" - S VALMHDR(2)="" - Q - ; -INIT ; -- init variables and list array - I '$D(RGSORT) S RGSORT="SD" - K @VALMAR - I RGSORT="SD" D DTLIST^RGEXHND1 - E I RGSORT="ST" D EXCLST^RGEXHND1 - E I RGSORT="SN" D PATLST^RGEXHND1 - E I RGSORT="VT" D SELTYP^RGEXHND1 - Q - ; -SORT ; - D INIT - S VALMBCK="R" - Q -HELP ; -- help code - S X="?" D DISP^XQORM1 W !! - Q -HLPPRG ; - W !,"Enter Y(YES) to run the MPI/PD Exception Purge process now." - W !!,"Enter N(NO) to go directly into the MPI/PD Exception Handling option." - Q - ; -EXIT ; -- exit code - K VADM,RGDFN,RGNM,RGSORT,RGSSN,STAT,STRING,NDX,NM,IEN,IEN2,X,DATA,CNT,EXCTYPE,ETYPE,^TMP("RGEXC",$J),^TMP("RGEX01",$J) - Q -QUEPRG S ZTRTN="MAIN^RGEVPRG",ZTDESC="PURGE ZZ*, OVER 30 DAY AND DUPLICATE RECORDS FROM THE CIRN HL7 EXCEPTION LOG FILE" - D NOW^%DTC - S ZTIO="",ZTDTH=% - I $D(DUZ) S ZTSAVE("DUZ")=DUZ - D ^%ZTLOAD - D HOME^%ZIS K IO("Q") - K ZTDESC,ZTDTH,ZTIO,ZTQUEUED,ZTREQ,ZTRTN,ZTSAVE,ZTSK,% - Q - ; -EXPND ; -- expand code - Q - ; -CUREX() ;Are there any patients in the CIRN HL7 EXCEPTION LOG file (#991.1) - ;that are NOT PROCESSED for specific exception types? - ; Return RGEX: - ;If RGEX=3 both unprocessed and Primary View Reject exceptions exist - ;If RGEX=2 only Primary View Reject exceptions exist - ;If RGEX=1 only unprocessed exceptions exist - ;If RGEX=0 no unprocessed exceptions exist - ; - N EXCTYP,RG1,RG2,RGEX - S EXCTYP="",(RG1,RG2,RGEX)=0 - F S EXCTYP=$O(^RGHL7(991.1,"ASTAT","0",EXCTYP)) Q:'EXCTYP D - .I (EXCTYP=234)!(EXCTYP=218) S RG1=1 ;MPIC_772; **52 remove 215, 216, and 217 - .I (EXCTYP=234) S RG2=1 ;Primary View Reject - I (RG1=1),(RG2=1) S RGEX=3 ;Send both messages - I (RG1=1),(RG2=0) S RGEX=1 ;Only unresolved exceptions exist - I (RG1=0),(RG2=1) S RGEX=2 ;Only Primary View Reject exceptions exist - Q RGEX - ; -PROC ; For a given patient, set exceptions STATUS to PROCESSED. - ;**52 The PROC module is obsolete and is no longer being called. - ; DFN must be defined - ;Q:'$D(DFN) - ;S EXCTYP="" - ;S HOME=$$SITE^VASITE() - ;F S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP D - ;. S RGDFN="",ICN="" - ;. F S RGDFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN)) Q:'RGDFN D - ;.. I DFN=RGDFN D - ;... S ICN=+$$GETICN^MPIF001(DFN) - ;... ;Only set to PROCESSED if patient has national ICN. - ;... I $E(ICN,1,3)'=$E($P(HOME,"^",3),1,3)&(ICN>0) D - ;.... ;Exclude Death exceptions (215-217); they must be processed manually. - ;.... ;Exclude 218 Potential Matches Returned exception **43 - ;.... I (EXCTYP>218)!(EXCTYP<215) D - ;..... S IEN=0 - ;..... F S IEN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN)) Q:'IEN D - ;...... S IEN2=0 - ;...... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2)) Q:'IEN2 D - ;....... L +^RGHL7(991.1,IEN):10 - ;....... S DA(1)=IEN,DA=IEN2,DR="6///"_1,DIE="^RGHL7(991.1,"_DA(1)_",1," - ;....... D ^DIE K DIE,DA,DR - ;....... L -^RGHL7(991.1,IEN) - ;K IEN,IEN2,RGDFN,EXCTYP,ICN - Q -PDAT ; - K DIRUT - W !,"This report prints MPI/PD Data for a selected patient. The" - W !,"information displayed includes the Integration Control Number" - W !,"(ICN), patient identity information, and Treating Facility list." - W !!,"The information is pulled from the Patient (#2) file and the" - W !,"Treating Facility List (#391.91) file." - ; -ASK ;Ask for PATIENT - I $D(DIRUT) G QUIT - W !!,"Patient lookup can be done by Patient Name/SSN or by ICN.",! - N DFN,ICN - S DIC="^DPT(",DIC(0)="QEAM",DIC("A")="Select PATIENT: ",D="SSN^AICN^B^BS^BS5" - D MIX^DIC1 K DIC - G:Y<0 QUIT - S DFN=+Y - D MAIN^VAFCPDAT - G ASK - Q -QUIT ; - K DFN,ICN,D,Y,HOME +RGEX01 ;BAY/ALS-LIST MANAGER FOR MPI/PD EXCEPTIONS ;10/07/99 + ;;1.0;CLINICAL INFO RESOURCE NETWORK;**3,12,19,23,43,45,47,48**;30 Apr 99;Build 3 + ; + ;Reference to MAIN^VAFCPDAT supported by IA #3299 +EN ; -- main entry point for RG EXCPT SUMMARY + N STDT,ENDDT,PRGSTAT,XFLAG,NOW,%,X,%H,%I,INDT,RUN,INDTT + S XFLAG=0 D NOW^%DTC S NOW=% + S STDT=$P($G(^RGSITE(991.8,1,"EXCPRG")),"^",1),INDT=STDT + I $D(STDT) S STDT=$$FMTE^XLFDT(STDT,1) + S PRGSTAT=$P($G(^RGSITE(991.8,1,"EXCPRG")),"^",3) + ;status shows 'running' but lock shows 'not running';**47 + I PRGSTAT="R" D + .L +^RGHL7(991.1,"RG PURGE EXCEPTION"):0 I $T D ;can get lock + ..L +^RGSITE(991.8):10 + ..S DIE="^RGSITE(991.8,",DA=1,DR="42///@" + ..D ^DIE K DA,DIE,DR ;delete old status + ..L -^RGSITE(991.8) + ..S PRGSTAT="" + .L -^RGHL7(991.1,"RG PURGE EXCEPTION") + I PRGSTAT="" D + . W $C(7) + . W !!,"The MPI/PD Exception Purge process has not been run." + . ;**48 NO LONGER A CHOICE + . W !!,"The MPI/PD Exception Purge process will now run." + . W !,"Please come back to this option in five minutes." + . W !!,"Please contact IRM to schedule the MPI/PD EXCEPTION PURGE" + . W !,"[RG EXCEPTION PURGE] option via TaskMan with a frequency of once an hour." + . S XFLAG=1 D QUEPRG + L +^RGHL7(991.1,"RG PURGE EXCEPTION"):0 I '$T W $C(7),!!,"The MPI/PD Exception Purge process is currently running.",!,"Please try this option again in five minutes." S XFLAG=1 G EXIT + L -^RGHL7(991.1,"RG PURGE EXCEPTION") + S RUN=0 + I $G(PRGSTAT)="C" D + . I $P(INDT,".")<$P(NOW,".") S RUN=1 ;RAN A PREVIOUS DAY + . I $P(INDT,".")=$P(NOW,".") D + .. S INDTT=$E($P(INDT,".",2),1,4),INDTT=INDTT+101 + .. I INDTT<$E($P(NOW,".",2),1,4) S RUN=1 + . Q:RUN=0 + . ;** if job ran more than 1 hour ago, run it now. + . W !!,"The MPI/PD Exception Purge process last ran "_STDT_"." + . W !!,"The MPI/PD Exception Purge process will now run." + . W !,"Please come back to this option in five minutes." + . W !!,"Please contact IRM to verify that the MPI/PD EXCEPTION PURGE " + . W !,"[RG EXCEPTION PURGE] option is scheduled to run via TaskMan" + . W !,"with a frequency of once an hour." + . S XFLAG=1 D QUEPRG + I XFLAG=1 G EXIT + K RGANS + D WAIT^DICD + D EN^VALM("RG EXCPT SUMMARY") + Q + ; +HDR ; -- header code + S VALMHDR(1)="MPI/PD Exception Handling" + S VALMHDR(2)="" + Q + ; +INIT ; -- init variables and list array + I '$D(RGSORT) S RGSORT="SD" + K @VALMAR + I RGSORT="SD" D DTLIST^RGEXHND1 + E I RGSORT="ST" D EXCLST^RGEXHND1 + E I RGSORT="SN" D PATLST^RGEXHND1 + E I RGSORT="VT" D SELTYP^RGEXHND1 + Q + ; +SORT ; + D INIT + S VALMBCK="R" + Q +HELP ; -- help code + S X="?" D DISP^XQORM1 W !! + Q +HLPPRG ; + W !,"Enter Y(YES) to run the MPI/PD Exception Purge process now." + W !!,"Enter N(NO) to go directly into the MPI/PD Exception Handling option." + Q + ; +EXIT ; -- exit code + K VADM,RGDFN,RGNM,RGSORT,RGSSN,STAT,STRING,NDX,NM,IEN,IEN2,X,DATA,CNT,EXCTYPE,ETYPE,^TMP("RGEXC",$J),^TMP("RGEX01",$J) + Q +QUEPRG S ZTRTN="MAIN^RGEVPRG",ZTDESC="PURGE ZZ*, OVER 30 DAY AND DUPLICATE RECORDS FROM THE CIRN HL7 EXCEPTION LOG FILE" + D NOW^%DTC + S ZTIO="",ZTDTH=% + I $D(DUZ) S ZTSAVE("DUZ")=DUZ + D ^%ZTLOAD + D HOME^%ZIS K IO("Q") + K ZTDESC,ZTDTH,ZTIO,ZTQUEUED,ZTREQ,ZTRTN,ZTSAVE,ZTSK,% + Q + ; +EXPND ; -- expand code + Q + ; +CUREX() ;Are there any patients in the CIRN HL7 EXCEPTION LOG file (#991.1) + ;that are NOT PROCESSED for specific exception types? + ; Return RGEX: + ;If RGEX=3 both unprocessed and Primary View Reject exceptions exist + ;If RGEX=2 only Primary View Reject exceptions exist + ;If RGEX=1 only unprocessed exceptions exist + ;If RGEX=0 no unprocessed exceptions exist + ; + N EXCTYP,RG1,RG2,RGEX + S EXCTYP="",(RG1,RG2,RGEX)=0 + F S EXCTYP=$O(^RGHL7(991.1,"ASTAT","0",EXCTYP)) Q:'EXCTYP D + .I ((EXCTYP=234)!((EXCTYP>214)&(EXCTYP<219))) S RG1=1 + .I (EXCTYP=234) S RG2=1 ;Primary View Reject + I (RG1=1),(RG2=1) S RGEX=3 ;Send both messages + I (RG1=1),(RG2=0) S RGEX=1 ;Only unresolved exceptions exist + I (RG1=0),(RG2=1) S RGEX=2 ;Only Primary View Reject exceptions exist + Q RGEX + ; +PROC ; For a given patient, set exceptions STATUS to PROCESSED. + ; DFN must be defined + Q:'$D(DFN) + S EXCTYP="" + S HOME=$$SITE^VASITE() + F S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP D + . S RGDFN="",ICN="" + . F S RGDFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN)) Q:'RGDFN D + .. I DFN=RGDFN D + ... S ICN=+$$GETICN^MPIF001(DFN) + ... ;Only set to PROCESSED if patient has national ICN. + ... I $E(ICN,1,3)'=$E($P(HOME,"^",3),1,3)&(ICN>0) D + .... ;Exclude Death exceptions (215-217); they must be processed manually. + .... ;Exclude 218 Potential Matches Returned exception **43 + .... I (EXCTYP>218)!(EXCTYP<215) D + ..... S IEN=0 + ..... F S IEN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN)) Q:'IEN D + ...... S IEN2=0 + ...... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2)) Q:'IEN2 D + ....... L +^RGHL7(991.1,IEN):10 + ....... S DA(1)=IEN,DA=IEN2,DR="6///"_1,DIE="^RGHL7(991.1,"_DA(1)_",1," + ....... D ^DIE K DIE,DA,DR + ....... L -^RGHL7(991.1,IEN) + K IEN,IEN2,RGDFN,EXCTYP,ICN + Q +PDAT ; + K DIRUT + W !,"This report prints MPI/PD Data for a selected patient. The" + W !,"information displayed includes the Integration Control Number" + W !,"(ICN), patient identity information, and Treating Facility list." + W !!,"The information is pulled from the Patient (#2) file and the" + W !,"Treating Facility List (#391.91) file." + ; +ASK ;Ask for PATIENT + I $D(DIRUT) G QUIT + W !!,"Patient lookup can be done by Patient Name/SSN or by ICN.",! + N DFN,ICN + S DIC="^DPT(",DIC(0)="QEAM",DIC("A")="Select PATIENT: ",D="SSN^AICN^B^BS^BS5" + D MIX^DIC1 K DIC + G:Y<0 QUIT + S DFN=+Y + D MAIN^VAFCPDAT + G ASK + Q +QUIT ; + K DFN,ICN,D,Y,HOME diff --git a/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEX06.m b/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEX06.m index 0330a352..edddb917 100644 --- a/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEX06.m +++ b/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEX06.m @@ -1,63 +1,63 @@ -RGEX06 ;BIR/PTD-LIST MANAGER ROUTINE FOR REMOTE MPI PRIMARY VIEW PDAT ;5/17/07 - ;;1.0;CLINICAL INFO RESOURCE NETWORK;**48,53**;30 Apr 99;Build 2 - ; - ;Reference to ^XWB2HL7 supported by IA #3144 - ;Reference to ^XWBDRPC supported by IA #3149 - ; -EN(ICN) ;Entry point calling List Template for primary view PDAT display - D EN^VALM("RG EXCPT PV MPI PDAT") - Q - ; -HDR ; -- header code - S VALMHDR(1)="MPI PRIMARY VIEW PATIENT DATA DISPLAY" - Q - ; -INIT ;Display the MPI Primary View Patient Data (PDAT) - K ^TMP("RGEXC6",$J) - K @VALMAR - I '$D(ICN) G EXIT - S LIN=1,X=0,STR="",TXT="" - I '$D(^XTMP("RGPVMPI"_ICN,"DATA")) S TXT=" - No MPI Primary View data exists for this patient." D ADDTMP - N STATUS,R,RETURN,RESULT,RET - I $D(^XTMP("RGPVMPI"_ICN,"DATA")) S RETURN(0)=$P(^XTMP("RGPVMPI"_ICN,"DATA"),"^") D - .D RPCCHK^XWB2HL7(.RESULT,RETURN(0)) I +RESULT(0)=1 D - ..;Retrieve the data - ..D RTNDATA^XWBDRPC(.RET,RETURN(0)) D - ...I $G(RET(0))<0 S TXT="No Data Returned Due To: "_$P(RET(0),"^",2,99) S STR=$$SETSTR^VALM1(TXT,STR,1,80) D ADDTMP Q - ...I $G(RET)'="",$D(@RET) S GLO=RET F S GLO=$Q(@GLO) Q:$QS(GLO,1)'=$J S TXT=@GLO S STR=$$SETSTR^VALM1(TXT,STR,1,80) D ADDTMP - ...S R="" F S R=$O(RET(R)) Q:R="" S TXT=RET(R) S STR=$$SETSTR^VALM1(TXT,STR,1,80) D ADDTMP - K GLO,L,R,SL - S VALMCNT=LIN-1 - Q - ; -ADDTMP ;Set string into the array. - S ^TMP("RGEXC6",$J,LIN,0)=STR - S ^TMP("RGEXC6",$J,"IDX",LIN,LIN)="" - S LIN=LIN+1,STR="" - Q - ; -HELP ; -- help code - S X="?" D DISP^XQORM1 W !! - Q - ; -EXIT ; -- exit code - S VALMBCK="" - K ^TMP("RGEXC6",$J),GLO,L,LIN,R,RESULT,RET,RETURN,SL,STATUS,STR,TXT,X - S VALMBCK="R" - Q - ; -EXPND ; -- expand code - Q - ; -SAPV(ICN) ;Print stand alone Primary View display - I '$D(^XTMP("RGPVMPI"_ICN,"DATA")) W !," - No MPI Primary View data exists for this patient." Q - N STATUS,R,RETURN,RESULT,RET - I $D(^XTMP("RGPVMPI"_ICN,"DATA")) S RETURN(0)=$P(^XTMP("RGPVMPI"_ICN,"DATA"),"^") D - .D RPCCHK^XWB2HL7(.RESULT,RETURN(0)) I +RESULT(0)=1 D - ..;Retrieve the data - ..D RTNDATA^XWBDRPC(.RET,RETURN(0)) D - ...I $D(RET(0)) I RET(0)<0 W !!,"No data returned due to: "_$P(RET(0),"^",2) Q - ...I $G(RET)'="",$D(@RET) S GLO=RET F S GLO=$Q(@GLO) Q:$QS(GLO,1)'=$J S TXT=@GLO W !,TXT I $Y>22 S DIR(0)="E" D ^DIR K DIR W @IOF S $Y=1 - ...S R="" F S R=$O(RET(R)) Q:R="" W !,RET(R) I $Y>22 S DIR(0)="E" D ^DIR K DIR Q:'Y W @IOF S $Y=1 - Q - ; +RGEX06 ;BIR/PTD-LIST MANAGER ROUTINE FOR REMOTE MPI PRIMARY VIEW PDAT ;5/17/07 + ;;1.0;CLINICAL INFO RESOURCE NETWORK;**48**;30 Apr 99;Build 3 + ; + ;Reference to ^XWB2HL7 supported by IA #3144 + ;Reference to ^XWBDRPC supported by IA #3149 + ; +EN(ICN) ;Entry point calling List Template for primary view PDAT display + D EN^VALM("RG EXCPT PV MPI PDAT") + Q + ; +HDR ; -- header code + S VALMHDR(1)="MPI PRIMARY VIEW PATIENT DATA DISPLAY" + Q + ; +INIT ;Display the MPI Primary View Patient Data (PDAT) + K ^TMP("RGEXC6",$J) + K @VALMAR + I '$D(ICN) G EXIT + S LIN=1,X=0,STR="",TXT="" + I '$D(^XTMP("RGPVMPI",ICN)) S TXT=" - No MPI Primary View data exists for this patient." D ADDTMP + N STATUS,R,RETURN,RESULT,RET + I $D(^XTMP("RGPVMPI",ICN)) S RETURN(0)=$P(^XTMP("RGPVMPI",ICN),"^") D + .D RPCCHK^XWB2HL7(.RESULT,RETURN(0)) I +RESULT(0)=1 D + ..;Retrieve the data + ..D RTNDATA^XWBDRPC(.RET,RETURN(0)) D + ...I $G(RET(0))<0 S TXT="No Data Returned Due To: "_$P(RET(0),"^",2,99) S STR=$$SETSTR^VALM1(TXT,STR,1,80) D ADDTMP Q + ...I $G(RET)'="",$D(@RET) S GLO=RET F S GLO=$Q(@GLO) Q:$QS(GLO,1)'=$J S TXT=@GLO S STR=$$SETSTR^VALM1(TXT,STR,1,80) D ADDTMP + ...S R="" F S R=$O(RET(R)) Q:R="" S TXT=RET(R) S STR=$$SETSTR^VALM1(TXT,STR,1,80) D ADDTMP + K GLO,L,R,SL + S VALMCNT=LIN-1 + Q + ; +ADDTMP ;Set string into the array. + S ^TMP("RGEXC6",$J,LIN,0)=STR + S ^TMP("RGEXC6",$J,"IDX",LIN,LIN)="" + S LIN=LIN+1,STR="" + Q + ; +HELP ; -- help code + S X="?" D DISP^XQORM1 W !! + Q + ; +EXIT ; -- exit code + S VALMBCK="" + K ^TMP("RGEXC6",$J),GLO,L,LIN,R,RESULT,RET,RETURN,SL,STATUS,STR,TXT,X + S VALMBCK="R" + Q + ; +EXPND ; -- expand code + Q + ; +SAPV(ICN) ;Print stand alone Primary View display + I '$D(^XTMP("RGPVMPI",ICN)) W !," - No MPI Primary View data exists for this patient." Q + N STATUS,R,RETURN,RESULT,RET + I $D(^XTMP("RGPVMPI",ICN)) S RETURN(0)=$P(^XTMP("RGPVMPI",ICN),"^") D + .D RPCCHK^XWB2HL7(.RESULT,RETURN(0)) I +RESULT(0)=1 D + ..;Retrieve the data + ..D RTNDATA^XWBDRPC(.RET,RETURN(0)) D + ...I $D(RET(0)) I RET(0)<0 W !!,"No data returned due to: "_$P(RET(0),"^",2) Q + ...I $G(RET)'="",$D(@RET) S GLO=RET F S GLO=$Q(@GLO) Q:$QS(GLO,1)'=$J S TXT=@GLO W !,TXT I $Y>22 S DIR(0)="E" D ^DIR K DIR W @IOF S $Y=1 + ...S R="" F S R=$O(RET(R)) Q:R="" W !,RET(R) I $Y>22 S DIR(0)="E" D ^DIR K DIR Q:'Y W @IOF S $Y=1 + Q + ; diff --git a/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEX07.m b/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEX07.m index b73e62c9..528554e6 100644 --- a/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEX07.m +++ b/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEX07.m @@ -1,52 +1,52 @@ -RGEX07 ;BIR/PTD-LIST MANAGER ROUTINE FOR REMOTE PRIMARY VIEW DISPLAY ;10/17/06 - ;;1.0;CLINICAL INFO RESOURCE NETWORK;**44,53**;30 Apr 99;Build 2 - ; - ;Reference to ^XWB2HL7 supported by IA #3144 - ;Reference to ^XWBDRPC supported by IA #3149 - ; -EN(ICN,EXCDT) ;Entry point calling List Template for primary view reject display - D EN^VALM("RG EXCPT PV REJECT RDISPLAY") - Q - ; -HDR ; -- header code - S VALMHDR(1)="MPI PRIMARY VIEW REJECT DISPLAY" - Q - ; -INIT ;Display the MPI Primary View Rejected Data Report - K ^TMP("RGEXC7",$J) - K @VALMAR - I '$D(ICN) G EXIT - I '$D(EXCDT) G EXIT - S LIN=1,X=0,STR="",TXT="" - I '$D(^XTMP("RGPVREJ"_ICN,EXCDT)) S TXT=" - No Primary View Reject data exists for this patient/exception date." D ADDTMP - N STATUS,R,RETURN,RESULT,RET - I $D(^XTMP("RGPVREJ"_ICN,EXCDT)) S RETURN(0)=$P(^XTMP("RGPVREJ"_ICN,EXCDT),"^") D - .D RPCCHK^XWB2HL7(.RESULT,RETURN(0)) I +RESULT(0)=1 D - ..;Retrieve the data - ..D RTNDATA^XWBDRPC(.RET,RETURN(0)) D - ...I $G(RET(0))<0 S TXT="No Data Returned Due To: "_$P(RET(0),"^",2,99) S STR=$$SETSTR^VALM1(TXT,STR,2,78) D ADDTMP Q - ...I $G(RET)'="",$D(@RET) S GLO=RET F S GLO=$Q(@GLO) Q:$QS(GLO,1)'=$J S TXT=@GLO S STR=$$SETSTR^VALM1(TXT,STR,2,78) D ADDTMP - ...S R="" F S R=$O(RET(R)) Q:R="" S TXT=RET(R) S STR=$$SETSTR^VALM1(TXT,STR,2,78) D ADDTMP - K GLO,L,R,SL - S VALMCNT=LIN-1 - Q - ; -ADDTMP ;Set string into the array. - S ^TMP("RGEXC7",$J,LIN,0)=STR - S ^TMP("RGEXC7",$J,"IDX",LIN,LIN)="" - S LIN=LIN+1,STR="" - Q - ; -HELP ; -- help code - S X="?" D DISP^XQORM1 W !! - Q - ; -EXIT ; -- exit code - S VALMBCK="" - K ^TMP("RGEXC7",$J),GLO,L,LIN,R,RESULT,RET,RETURN,SL,STATUS,STR,TXT,X - S VALMBCK="R" - Q - ; -EXPND ; -- expand code - Q - ; +RGEX07 ;BIR/PTD-LIST MANAGER ROUTINE FOR REMOTE PRIMARY VIEW DISPLAY ;10/17/06 + ;;1.0;CLINICAL INFO RESOURCE NETWORK;**44**;30 Apr 99;Build 8 + ; + ;Reference to ^XWB2HL7 supported by IA #3144 + ;Reference to ^XWBDRPC supported by IA #3149 + ; +EN(ICN,EXCDT) ;Entry point calling List Template for primary view reject display + D EN^VALM("RG EXCPT PV REJECT RDISPLAY") + Q + ; +HDR ; -- header code + S VALMHDR(1)="MPI PRIMARY VIEW REJECT DISPLAY" + Q + ; +INIT ;Display the MPI Primary View Rejected Data Report + K ^TMP("RGEXC7",$J) + K @VALMAR + I '$D(ICN) G EXIT + I '$D(EXCDT) G EXIT + S LIN=1,X=0,STR="",TXT="" + I '$D(^XTMP("RGPVREJ",ICN,EXCDT)) S TXT=" - No Primary View Reject data exists for this patient/exception date." D ADDTMP + N STATUS,R,RETURN,RESULT,RET + I $D(^XTMP("RGPVREJ",ICN,EXCDT)) S RETURN(0)=$P(^XTMP("RGPVREJ",ICN,EXCDT),"^") D + .D RPCCHK^XWB2HL7(.RESULT,RETURN(0)) I +RESULT(0)=1 D + ..;Retrieve the data + ..D RTNDATA^XWBDRPC(.RET,RETURN(0)) D + ...I $G(RET(0))<0 S TXT="No Data Returned Due To: "_$P(RET(0),"^",2,99) S STR=$$SETSTR^VALM1(TXT,STR,2,78) D ADDTMP Q + ...I $G(RET)'="",$D(@RET) S GLO=RET F S GLO=$Q(@GLO) Q:$QS(GLO,1)'=$J S TXT=@GLO S STR=$$SETSTR^VALM1(TXT,STR,2,78) D ADDTMP + ...S R="" F S R=$O(RET(R)) Q:R="" S TXT=RET(R) S STR=$$SETSTR^VALM1(TXT,STR,2,78) D ADDTMP + K GLO,L,R,SL + S VALMCNT=LIN-1 + Q + ; +ADDTMP ;Set string into the array. + S ^TMP("RGEXC7",$J,LIN,0)=STR + S ^TMP("RGEXC7",$J,"IDX",LIN,LIN)="" + S LIN=LIN+1,STR="" + Q + ; +HELP ; -- help code + S X="?" D DISP^XQORM1 W !! + Q + ; +EXIT ; -- exit code + S VALMBCK="" + K ^TMP("RGEXC7",$J),GLO,L,LIN,R,RESULT,RET,RETURN,SL,STATUS,STR,TXT,X + S VALMBCK="R" + Q + ; +EXPND ; -- expand code + Q + ; diff --git a/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEXHND1.m b/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEXHND1.m index 70bf31ed..4aa04472 100644 --- a/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEXHND1.m +++ b/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEXHND1.m @@ -1,172 +1,175 @@ -RGEXHND1 ;BAY/ALS-MPI/PD EXCEPTION HANDLING UTILITY ;10/08/99 - ;;1.0;CLINICAL INFO RESOURCE NETWORK;**3,12,19,23,43,45,52**;30 Apr 99;Build 2 -DTLIST ;List exceptions by date - K ^TMP("RGEXC",$J) - I '$D(RGBG) S VALMBG=1 - ;**45 list exception 234 first regardless of date - Primary View Reject - S EXCDT="",EXCTYP=234,(CNT,IEN)=0 - F S IEN=$O(^RGHL7(991.1,"ASTAT","0",EXCTYP,IEN)) Q:'IEN D - .S IEN2=0 - .F S IEN2=$O(^RGHL7(991.1,"ASTAT","0",EXCTYP,IEN,IEN2)) Q:'IEN2 D - ..S EXCDT=$P(^RGHL7(991.1,IEN,0),"^",3) - ..D ADDREC - S EXCDT="",EXCTYP="" - F S EXCDT=$O(^RGHL7(991.1,"AD",EXCDT)) Q:'EXCDT D - . S IEN=0 - . F S IEN=$O(^RGHL7(991.1,"AD",EXCDT,IEN)) Q:'IEN D - .. S NUM="" S NUM=$P($G(^RGHL7(991.1,IEN,1,0)),"^",4) Q:NUM<1 D - ... S IEN2=0 - ... F S IEN2=$O(^RGHL7(991.1,IEN,1,IEN2)) Q:'IEN2 D - .... S EXCTYP=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",3) - ....;don't include 234 below; those were done first (above). - .... I EXCTYP=218 D ADDREC ;**45;MPIC_772; **52 remove 215, 216, and 217 - K I,NUM,EXCDT,EXCTYP,RGBG - IF CNT<1 D NDATA - Q - ; -NDATA ; There is no data matching the criteria - S CNT=CNT+1,STRING="" - S STRING=$$SETSTR^VALM1("There were no exceptions found.",STRING,5,35) - S ^TMP("RGEXC",$J,CNT,0)=STRING - S ^TMP("RGEXC",$J,"IDX",CNT,CNT)="" - S VALMCNT=CNT - Q -EXCLST ;List exceptions by type - K ^TMP("RGEXC",$J) - S CNT=0,EXCDT="",EXCTYP="" - I '$D(RGBG) S VALMBG=1 - F S EXCTYP=$O(^RGHL7(991.1,"AC",EXCTYP)) Q:'EXCTYP D - . I (EXCTYP=234)!(EXCTYP=218) D ;**45;MPIC_772; **52 remove 215, 216, and 217 - .. S IEN=0 - .. F S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN D - ... S NUM="" S NUM=$P($G(^RGHL7(991.1,IEN,1,0)),"^",4) Q:NUM<1 D - .... S IEN2=0 - .... F S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2 D - ..... S EXCDT=$P($G(^RGHL7(991.1,IEN,0)),"^",3) Q:'EXCDT - ..... D ADDREC - IF CNT<1 D NDATA - K RGBG - Q -PATLST ;List exceptions by patient - K ^TMP("RGEXC",$J),^TMP("RGEX01",$J) - S CNT=0,EXCDT="",EXCTYP="",NDX=0,NAME="" - I '$D(RGBG) S VALMBG=1 - F S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP D - . I (EXCTYP=234)!(EXCTYP=218) D ;**45;MPIC_772; **52 remove 215, 216, and 217 - .. S DFN="" - .. F S DFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,DFN)) Q:'DFN D - ... S IEN=0 - ... F S IEN=$O(^RGHL7(991.1,"ADFN",EXCTYP,DFN,IEN)) Q:'IEN D - .... S IEN2=0 - .... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCTYP,DFN,IEN,IEN2)) Q:'IEN2 D - ..... S EXCDT=$P($G(^RGHL7(991.1,IEN,0)),"^",3) Q:'EXCDT - ..... D DEM^VADPT S NAME=VADM(1) Q:NAME="" - ..... S NDX=NDX+1 - ..... S ^TMP("RGEX01",$J,NAME,NDX)=$G(VADM(1))_"^"_IEN_"^"_IEN2_"^"_EXCTYP_"^"_EXCDT - D PATTMP - IF CNT<1 D NDATA - K DFN,RGBG - Q -PATTMP ; - S NM="" - F S NM=$O(^TMP("RGEX01",$J,NM)) Q:NM="" D - . S NDX=0 - . F S NDX=$O(^TMP("RGEX01",$J,NM,NDX)) Q:'NDX D - .. S IEN=$P(^TMP("RGEX01",$J,NM,NDX),"^",2) - .. S IEN2=$P(^TMP("RGEX01",$J,NM,NDX),"^",3) - .. S EXCTYP=$P(^TMP("RGEX01",$J,NM,NDX),"^",4) - .. S EXCDT=$P(^TMP("RGEX01",$J,NM,NDX),"^",5) - .. D ADDREC - K NDX,NM,NAME - Q -SELTYP ; List all exceptions of type selected by user - S EXCTYPE="",FLAG=0,ETYPE="" - I '$D(RGBG) S VALMBG=1 - K DIR,Y,DIC - S DIR("A")="Enter an exception type to view: " - S DIR(0)="SAM^218:Potential Matches Returned;234:Primary View Reject" ;**43;**45;MPIC_772; **52 remove 215, 216, and 217 - S DIR("?")="^D HLPSEL^RGEXHND1" - D ^DIR - I Y<1 S RGSORT="SD" D SORT^RGEX01 Q - Q:$D(DUOUT)!$D(DTOUT) - S EXCTYPE=+Y,ETYPE=$P(^RGHL7(991.11,EXCTYPE,10),"^",1) - I (EXCTYPE=234)!(EXCTYPE=218) S FLAG=1 ;**43;**45;MPIC_772; **52 remove 215, 216, and 217 - I FLAG=1 D ADDSEL - E I FLAG=0 D - . W !,"Not a valid selection." - . D SELTYP - K FLAG,Y,DIR,DIC,DTOUT,DUOUT,RGBG - Q -ADDSEL ;called by SELTYP - K ^TMP("RGEXC",$J) - S CNT=0,EXCDT="",EXCTYP="" - F S EXCTYP=$O(^RGHL7(991.1,"AC",EXCTYP)) Q:'EXCTYP D - . I EXCTYP=EXCTYPE D - .. S IEN=0 - .. F S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN D - ... S IEN2=0 - ... F S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2 D - .... S EXCDT=$P($G(^RGHL7(991.1,IEN,0)),"^",3) Q:'EXCDT ;**43 - .... D ADDREC - I CNT<1 D - . W !,"There are no "_ETYPE - . W !,"exceptions that need processing." - . D SELTYP - Q -HLPSEL ; - D FULL^VALM1 - ;W !,"The following exception types are handled by this option:" - ;W !,"Potential Matches Returned",?50,"(218)" - ;W !,"Primary View Reject",?50,"(234)" - S VALMBCK="R" - Q -ADDREC ; - S ETEXT="",RGDFN="",ICN="",RGNM="",STAT="",DOD="" - S ETEXT=$P($G(^RGHL7(991.11,EXCTYP,10)),"^",1) - S RGDFN=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",4) Q:'RGDFN - S STAT=$P($G(^RGHL7(991.1,IEN,1,IEN2,0)),"^",5) - S ICN=+$$GETICN^MPIF001(RGDFN) - S HOME=$$SITE^VASITE() - I (STAT<1)!(STAT="") D - .;Only list exceptions that are Not Processed - .; only list patients with local ICN, or for exceptions 234 or 218;MPIC_772; **52 remove 215, 216, and 217 - . I $E(ICN,1,3)=$E($P(HOME,"^",3),1,3)!(ICN<0)!(EXCTYP=234)!(EXCTYP=218) D ;**43,**45,**52 - .. S DFN=RGDFN D DEM^VADPT - .. S RGNM=VADM(1) - .. S RGSSN=$P($G(VADM(2)),"^",1) - .. S DOB=$G(VADM(3)) I DOB="" S DOB="^" - .. S DOD=$P($P($G(VADM(6)),"^",2),"@",1) - .. S EXDATE=$P($$FMTE^XLFDT(EXCDT,2),"@",1) - .. S CNT=CNT+1 - .. S STRING="" - .. I ICN<0 S ICN="" - .. S STRING=$$SETSTR^VALM1(CNT,STRING,1,4) - .. S STRING=$$SETSTR^VALM1($E(RGNM,1,22),STRING,6,21) - .. S STRING=$$SETSTR^VALM1(RGSSN,STRING,28,10) - .. S STRING=$$SETSTR^VALM1(EXDATE,STRING,39,8) - .. S STRING=$$SETSTR^VALM1(ETEXT,STRING,49,32) - .. S ^TMP("RGEXC",$J,CNT,0)=STRING - .. S ^TMP("RGEXC",$J,"IDX",CNT,CNT)="" - .. S ^TMP("RGEXC",$J,CNT,"DATA")=RGNM_"^"_RGSSN_"^"_$P($$FMTE^XLFDT(EXCDT),"@",1)_"^"_ETEXT_"^"_DFN_"^"_ICN_"^"_DOB_"^"_STAT_"^"_IEN_"^"_IEN2_"^"_CNT_"^"_DOD - S VALMCNT=CNT - K RGDFN,RGNM,RGSSN,EXDATE,ETEXT,ICN,DOB,STAT,VADM,HOME,STRING,DOD - Q -SELECT ; - I $G(STRING)["no exceptions found" D SORT^RGEX01 Q - N VALMY - D EN^VALM2(XQORNOD(0),"OS") - I '$D(VALMY) Q - S VALMCNT=CNT - S DATA="",CNT="" - S CNT=$O(VALMY(0)) - S DATA=$G(^TMP("RGEXC",$J,CNT,"DATA")) - I '$D(DATA) S CNT=0 Q - D CLEAN^VALM10 - D EN^RGEX03(DATA) - I RGSORT="VT" D - . K @VALMAR - . D ADDSEL - E I RGSORT'="VT" D SORT^RGEX01 - ; - Q -QUIT ; +RGEXHND1 ;BAY/ALS-MPI/PD EXCEPTION HANDLING UTILITY ;10/08/99 + ;;1.0;CLINICAL INFO RESOURCE NETWORK;**3,12,19,23,43,45**;30 Apr 99;Build 9 +DTLIST ;List exceptions by date + K ^TMP("RGEXC",$J) + I '$D(RGBG) S VALMBG=1 + ;**45 list exception 234 first regardless of date - Primary View Reject + S EXCDT="",EXCTYP=234,(CNT,IEN)=0 + F S IEN=$O(^RGHL7(991.1,"ASTAT","0",EXCTYP,IEN)) Q:'IEN D + .S IEN2=0 + .F S IEN2=$O(^RGHL7(991.1,"ASTAT","0",EXCTYP,IEN,IEN2)) Q:'IEN2 D + ..S EXCDT=$P(^RGHL7(991.1,IEN,0),"^",3) + ..D ADDREC + S EXCDT="",EXCTYP="" + F S EXCDT=$O(^RGHL7(991.1,"AD",EXCDT)) Q:'EXCDT D + . S IEN=0 + . F S IEN=$O(^RGHL7(991.1,"AD",EXCDT,IEN)) Q:'IEN D + .. S NUM="" S NUM=$P($G(^RGHL7(991.1,IEN,1,0)),"^",4) Q:NUM<1 D + ... S IEN2=0 + ... F S IEN2=$O(^RGHL7(991.1,IEN,1,IEN2)) Q:'IEN2 D + .... S EXCTYP=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",3) + ....;don't include 234 below; those were done first (above). + .... I ((EXCTYP>214)&(EXCTYP<219)) D ADDREC ;**45 + K I,NUM,EXCDT,EXCTYP,RGBG + IF CNT<1 D NDATA + Q + ; +NDATA ; There is no data matching the criteria + S CNT=CNT+1,STRING="" + S STRING=$$SETSTR^VALM1("There were no exceptions found.",STRING,5,35) + S ^TMP("RGEXC",$J,CNT,0)=STRING + S ^TMP("RGEXC",$J,"IDX",CNT,CNT)="" + S VALMCNT=CNT + Q +EXCLST ;List exceptions by type + K ^TMP("RGEXC",$J) + S CNT=0,EXCDT="",EXCTYP="" + I '$D(RGBG) S VALMBG=1 + F S EXCTYP=$O(^RGHL7(991.1,"AC",EXCTYP)) Q:'EXCTYP D + . I (EXCTYP=234)!((EXCTYP>214)&(EXCTYP<219)) D ;**45 + .. S IEN=0 + .. F S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN D + ... S NUM="" S NUM=$P($G(^RGHL7(991.1,IEN,1,0)),"^",4) Q:NUM<1 D + .... S IEN2=0 + .... F S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2 D + ..... S EXCDT=$P($G(^RGHL7(991.1,IEN,0)),"^",3) Q:'EXCDT + ..... D ADDREC + IF CNT<1 D NDATA + K RGBG + Q +PATLST ;List exceptions by patient + K ^TMP("RGEXC",$J),^TMP("RGEX01",$J) + S CNT=0,EXCDT="",EXCTYP="",NDX=0,NAME="" + I '$D(RGBG) S VALMBG=1 + F S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP D + . I (EXCTYP=234)!((EXCTYP>214)&(EXCTYP<219)) D ;**45 + .. S DFN="" + .. F S DFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,DFN)) Q:'DFN D + ... S IEN=0 + ... F S IEN=$O(^RGHL7(991.1,"ADFN",EXCTYP,DFN,IEN)) Q:'IEN D + .... S IEN2=0 + .... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCTYP,DFN,IEN,IEN2)) Q:'IEN2 D + ..... S EXCDT=$P($G(^RGHL7(991.1,IEN,0)),"^",3) Q:'EXCDT + ..... D DEM^VADPT S NAME=VADM(1) Q:NAME="" + ..... S NDX=NDX+1 + ..... S ^TMP("RGEX01",$J,NAME,NDX)=$G(VADM(1))_"^"_IEN_"^"_IEN2_"^"_EXCTYP_"^"_EXCDT + D PATTMP + IF CNT<1 D NDATA + K DFN,RGBG + Q +PATTMP ; + S NM="" + F S NM=$O(^TMP("RGEX01",$J,NM)) Q:NM="" D + . S NDX=0 + . F S NDX=$O(^TMP("RGEX01",$J,NM,NDX)) Q:'NDX D + .. S IEN=$P(^TMP("RGEX01",$J,NM,NDX),"^",2) + .. S IEN2=$P(^TMP("RGEX01",$J,NM,NDX),"^",3) + .. S EXCTYP=$P(^TMP("RGEX01",$J,NM,NDX),"^",4) + .. S EXCDT=$P(^TMP("RGEX01",$J,NM,NDX),"^",5) + .. D ADDREC + K NDX,NM,NAME + Q +SELTYP ; List all exceptions of type selected by user + S EXCTYPE="",FLAG=0,ETYPE="" + I '$D(RGBG) S VALMBG=1 + K DIR,Y,DIC + S DIR("A")="Enter an exception type to view: " + S DIR(0)="SAM^215:Death Entry on MPI not VISTA;216:Death Entry on Vista not MPI;217:Death Entries on MPI and Vista DON'T MATCH;218:Potential Matches Returned;234:Primary View Reject" ;**43,45 + S DIR("?")="^D HLPSEL^RGEXHND1" + D ^DIR + I Y<1 S RGSORT="SD" D SORT^RGEX01 Q + Q:$D(DUOUT)!$D(DTOUT) + S EXCTYPE=+Y,ETYPE=$P(^RGHL7(991.11,EXCTYPE,10),"^",1) + I (EXCTYPE=234)!((EXCTYPE>214)&(EXCTYPE<219)) S FLAG=1 ;**43,45 + I FLAG=1 D ADDSEL + E I FLAG=0 D + . W !,"Not a valid selection." + . D SELTYP + K FLAG,Y,DIR,DIC,DTOUT,DUOUT,RGBG + Q +ADDSEL ;called by SELTYP + K ^TMP("RGEXC",$J) + S CNT=0,EXCDT="",EXCTYP="" + F S EXCTYP=$O(^RGHL7(991.1,"AC",EXCTYP)) Q:'EXCTYP D + . I EXCTYP=EXCTYPE D + .. S IEN=0 + .. F S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN D + ... S IEN2=0 + ... F S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2 D + .... S EXCDT=$P($G(^RGHL7(991.1,IEN,0)),"^",3) Q:'EXCDT ;**43 + .... D ADDREC + I CNT<1 D + . W !,"There are no "_ETYPE + . W !,"exceptions that need processing." + . D SELTYP + Q +HLPSEL ; + D FULL^VALM1 + ;W !,"The following exception types are handled by this option:" + ;W !!,"Death Entry on MPI not in VISTA",?50,"(215)" + ;W !,"Death Entry on Vista not in MPI",?50,"(216)" + ;W !,"Death Entries on MPI and Vista DO NOT MATCH",?50,"(217)" + ;W !,"Potential Matches Returned",?50,"(218)" + ;W !,"Primary View Reject",?50,"(234)" + S VALMBCK="R" + Q +ADDREC ; + S ETEXT="",RGDFN="",ICN="",RGNM="",STAT="",DOD="" + S ETEXT=$P($G(^RGHL7(991.11,EXCTYP,10)),"^",1) + S RGDFN=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",4) Q:'RGDFN + S STAT=$P($G(^RGHL7(991.1,IEN,1,IEN2,0)),"^",5) + S ICN=+$$GETICN^MPIF001(RGDFN) + S HOME=$$SITE^VASITE() + I (STAT<1)!(STAT="") D + .;Only list exceptions that are Not Processed + .; only list patients with local ICN, or for exceptions 234, 215 - 218 + . I $E(ICN,1,3)=$E($P(HOME,"^",3),1,3)!(ICN<0)!(EXCTYP=234)!((EXCTYP>214)&(EXCTYP<219)) D ;**43,45 + .. S DFN=RGDFN D DEM^VADPT + .. S RGNM=VADM(1) + .. S RGSSN=$P($G(VADM(2)),"^",1) + .. S DOB=$G(VADM(3)) I DOB="" S DOB="^" + .. S DOD=$P($P($G(VADM(6)),"^",2),"@",1) + .. S EXDATE=$P($$FMTE^XLFDT(EXCDT,2),"@",1) + .. S CNT=CNT+1 + .. S STRING="" + .. I ICN<0 S ICN="" + .. S STRING=$$SETSTR^VALM1(CNT,STRING,1,4) + .. S STRING=$$SETSTR^VALM1($E(RGNM,1,22),STRING,6,21) + .. S STRING=$$SETSTR^VALM1(RGSSN,STRING,28,10) + .. S STRING=$$SETSTR^VALM1(EXDATE,STRING,39,8) + .. S STRING=$$SETSTR^VALM1(ETEXT,STRING,49,32) + .. S ^TMP("RGEXC",$J,CNT,0)=STRING + .. S ^TMP("RGEXC",$J,"IDX",CNT,CNT)="" + .. S ^TMP("RGEXC",$J,CNT,"DATA")=RGNM_"^"_RGSSN_"^"_$P($$FMTE^XLFDT(EXCDT),"@",1)_"^"_ETEXT_"^"_DFN_"^"_ICN_"^"_DOB_"^"_STAT_"^"_IEN_"^"_IEN2_"^"_CNT_"^"_DOD + S VALMCNT=CNT + K RGDFN,RGNM,RGSSN,EXDATE,ETEXT,ICN,DOB,STAT,VADM,HOME,STRING,DOD + Q +SELECT ; + I $G(STRING)["no exceptions found" D SORT^RGEX01 Q + N VALMY + D EN^VALM2(XQORNOD(0),"OS") + I '$D(VALMY) Q + S VALMCNT=CNT + S DATA="",CNT="" + S CNT=$O(VALMY(0)) + S DATA=$G(^TMP("RGEXC",$J,CNT,"DATA")) + I '$D(DATA) S CNT=0 Q + D CLEAN^VALM10 + D EN^RGEX03(DATA) + I RGSORT="VT" D + . K @VALMAR + . D ADDSEL + E I RGSORT'="VT" D SORT^RGEX01 + ; + Q +QUIT ; diff --git a/r/CLINICAL_PROCEDURES-MD/MDAPI.m b/r/CLINICAL_PROCEDURES-MD/MDAPI.m index dc6d2588..e2c900d8 100644 --- a/r/CLINICAL_PROCEDURES-MD/MDAPI.m +++ b/r/CLINICAL_PROCEDURES-MD/MDAPI.m @@ -1,239 +1,200 @@ -MDAPI ; HOIFO/DP/NCA - CP API Calls ; [05-05-2003 10:28] - ;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102 - ; Description: - ; These API's are for use by external packages communicating with CP. - ; - ; Integration Agreements: - ; IA# 3378 [Subscription] Documents the APIs that external packages use to communicate with CP. - ; IA# 3468 [Subscription] Use GMRCCP APIs. - ; -EXTDATA(MDPROC) ; [Procedure] - ; Returns 0/1 for external data needed - ; Called by Consults to determine status of consult ordered - ; - ; Input parameters - ; 1. MDPROC [Literal/Required] CP Definition IEN - ; - Q:'$D(^MDS(702.01,+$G(MDPROC),0)) 0 - I +$P(^MDS(702.01,+$G(MDPROC),0),U,3)!($O(^(.1,0))) Q 1 - E Q 0 - ; -ISTAT(MDARR) ; [Procedure] Called by Imaging to update status - ; Input parameters - ; 1. MDARR [Literal/Required] Array from Imaging - ; - ; Input: MDARR(0)="0^error message" or "1^success message" - ; MDARR(1)=TrackID (CP;Transaction IEN) - ; MDARR(2)=Queue Number - ; MDARR(3..N)=Warnings - N MDCON,MDCR,MDIEN,MDIENS,MDLP,MDSTAT,MDSTR,MDTIU,RESULTS - Q:$G(MDARR(0))="" - Q:$G(MDARR(1))="" - Q:$P(MDARR(1),";")'="CP" - Q:'(+$P(MDARR(1),";",2)) - S MDIEN=+$P(MDARR(1),";",2),MDIENS=MDIEN_"," - S MDSTAT=+$P(MDARR(0),"^") - S DATA("TRANSACTION")=MDIEN - ; Is it in error? - I 'MDSTAT D Q - .D STATUS^MDRPCOT(MDIENS,2,$P(MDARR(0),"^",2)) - .S DATA("PKG")="IMAGING" - .S DATA("MESSAGE")=$P(MDARR(0),"^",2) D RPC^MDRPCOT(.RESULTS,"ADDMSG",.DATA) - .F MDLP=2:0 S MDLP=$O(MDARR(MDLP)) Q:'MDLP I $G(MDARR(MDLP))'="" D - ..S DATA("MESSAGE")=$$TRANS(MDARR(MDLP)) D RPC^MDRPCOT(.RESULTS,"ADDMSG",.DATA) - .D IMGSTAT^MDRPCOT1(+MDIENS,2) Q - ; Call Consults that Partial Result ready - S MDCON=+$P(^MDD(702,MDIEN,0),"^",5),MDTIU=+$P(^(0),"^",6) - S MDCR=$$UPDCONS^MDRPCOT1(MDCON,MDTIU) - I +MDCR<0 D Q - .D STATUS^MDRPCOT(MDIENS,2,$P(MDCR,"^",2)) - .S DATA("PKG")="CONSULTS",DATA("MESSAGE")=$P(MDCR,"^",2) - .D RPC^MDRPCOT(.RESULTS,"ADDMSG",.DATA) - .Q - ; Closeout the record - D STATUS^MDRPCOT(MDIENS,3,"") - ; Update Images Status - D IMGSTAT^MDRPCOT1(+MDIENS,3) - Q - ; -ITIU(RESULTS,DFN,CONSULT,VSTRING) ; [Procedure] API for Vista Imaging - ; This API enables VistA Imaging to retrieve/create a TIU note for - ; a consult for attaching images to. - ; - ; RESULTS(0) will equal one of the following - ; IEN of the TIU note if successful - ; or on failure one of the following status messages - ; -1^No patient DFN - ; -1^No Consult IEN - ; -1^No VString - ; -1^Error in CP transaction - ; -1^Unable to create CP transaction - ; -1^Unable to create the TIU document - ; -1^No such consult for this patient. - ; - ; Input parameters - ; 1. RESULTS [Reference/Required] Return array - ; 2. DFN [Literal/Required] Patient IEN - ; 3. CONSULT [Literal/Required] Consult IEN - ; 4. VSTRING [Literal/Optional] VString data for TIU Note (Required to create new TIU note) - ; - ; Variables: - ; MDIEN: [Private] Returns IEN from UPDATE~DIE call - ; MDIENS: [Private] Scratch - ; MDNOTE: [Private] Scratch - ; MDTRANS: [Private] Contains IEN of CP transaction - ; - ; New private variables - NEW MDIEN,MDIENS,MDNOTE,MDTRANS - K ^TMP($J),^TMP("MDTIUST",$J) - N MDD,MDN,MDTIUER,MDTST,MDNEWV,MDTIUD S (MDTIUD,MDTIUER,MDTST)="" - I '$G(DFN) S RESULTS(0)="-1^No patient DFN" Q - I '$G(CONSULT) S RESULTS(0)="-1^No Consult IEN" Q - ; Look for existing transaction - S MDTIUD=$$PREV^MDRPCOT(+CONSULT,"") - I +MDTIUD S RESULTS(0)=+MDTIUD Q - ; No transaction, must create one for this consult - I $G(VSTRING)="" S RESULTS(0)="-1^No VString" Q - D CPLIST^GMRCCP(DFN,,$NA(^TMP($J))) - S MDX="" F S MDX=$O(^TMP($J,MDX)) Q:'MDX I $P(^(MDX),U,5)=CONSULT D Q - .D NOW^%DTC S MDD=% - .S:$L(VSTRING,";")=1 VSTRING=";"_VSTRING - .S MDNEWV=$$GETVSTR^MDRPCOT1(DFN,VSTRING,$P(^TMP($J,MDX),U,6),MDD) - .S MDFDA(702,"+1,",.01)=DFN - .S MDFDA(702,"+1,",.02)=MDD - .S MDFDA(702,"+1,",.03)=DUZ - .S MDFDA(702,"+1,",.04)=$P(^TMP($J,MDX),U,6) - .S MDFDA(702,"+1,",.05)=CONSULT - .S MDFDA(702,"+1,",.07)=$P(MDNEWV,";",3)_";"_$P(MDNEWV,";",2)_";"_$P(MDNEWV,";") - .S MDFDA(702,"+1,",.09)=0 - .;Create the new transaction - .D UPDATE^DIE("","MDFDA","MDIEN") I '$G(MDIEN(1)) D Q - ..S RESULTS(0)="-1^Unable to create CP transaction" - . - .;Create the new TIU Note - .S MDIENS=MDIEN(1)_"," - .S MDN=$$NEWTIUN^MDRPCOT(+MDIENS) - .S MDNOTE=$S(MDN:$$GET1^DIQ(702,+MDIENS,.06,"I"),1:0) - .I 'MDNOTE D Q - ..N DA,DIK - ..S RESULTS(0)="-1^Unable to create the TIU document" - ..S DA=+MDIENS,DIK="^MDD(702," D ^DIK - .S RESULTS(0)=MDNOTE - Q - ; -TIUCOMP(MDNOTE) ; [Procedure] Post Signature action to complete transaction - ; Input parameters - ; 1. MDNOTE [Literal/Required] TIU IEN - ; - N MDFDA,MDRES - S MDRES=$O(^MDD(702,"ATIU",MDNOTE,0)) - I $G(^MDD(702,+MDRES,0))="" Q 0 - I $P($G(^MDD(702,+MDRES,0)),"^",9)=3 Q 1 - S MDFDA(702,MDRES_",",.09)=3 - D FILE^DIE("","MDFDA") - Q 1 - ; -TIUDEL(MDNOTE) ; [Procedure] TIU Note deletion Update - ; Input parameters - ; 1. MDNOTE [Literal/Required] TIU IEN - ; - N MDGBL,MDRES,MDFDA,MDTRAN,RESULTS - S MDRES="" F S MDRES=$O(^MDD(702,"ATIU",MDNOTE,MDRES)) Q:'MDRES D - .Q:$G(^MDD(702,+MDRES,0))="" - .;S MDFDA(702,MDRES_",",.05)="" - .S MDFDA(702,MDRES_",",.06)="" - .D FILE^DIE("","MDFDA") - .S MDTRAN=$O(^MDD(702.001,"ASTUDY",MDRES,MDNOTE,0)) I +MDTRAN N DA,DIK S DA=+MDTRAN,DIK="^MDD(702.001," D ^DIK - .D STATUS^MDRPCOT(MDRES_",",2,"TIU note deleted.") - .S DATA("TRANSACTION")=MDRES,DATA("PKG")="TIU" - .S DATA("MESSAGE")="TIU note deleted." D RPC^MDRPCOT(.RESULTS,"ADDMSG",.DATA) - S MDGBL=$NA(^MDD(702.001,"PK",MDNOTE)) F S MDGBL=$Q(@MDGBL) Q:MDGBL="" Q:$QS(MDGBL,2)'="PK"!($QS(MDGBL,3)'=MDNOTE) S MDTRAN=$QS(MDGBL,6) N DA,DIK S DA=+MDTRAN,DIK="^MDD(702.001," D ^DIK - Q 1 - ; -TIUREAS(MDFN,MDOLDC,MDANOTE,MDNDFN,MDNEWC,MDNEWV,MDNTIU) ; [Function] This is an API to clean up and update TIU note re-assignment. - ; Input parameters - ; 1. MDFN [Literal/Required] The Patient DFN whose TIU document is being re-assigned. - ; 2. MDOLDC [Literal/Required] The Consult that the note is being re-assigned from. - ; 3. MDANOTE [Literal/Required] The TIU Document IEN that is being re-assigned. - ; 4. MDNDFN [Literal/Required] The Patient DFN who will be re-assigned the TIU document. - ; 5. MDNEWC [Literal/Required] The consult number that will be assignment the TIU document. - ; 6. MDNEWV [Literal/Required] The new visit for the TIU document assignment. - ; 7. MDNTIU [Literal/Required] The new reassigned TIU document IEN. - ; - N MDD,MDGBL,MDTRAN,MDCHK,MDLP,MDMULN,MDN,MDPPR,MDREAS,MDTRANI,MDX - I '$G(MDFN) Q "0^No DFN for the TIU note re-assignment." - I '$G(MDOLDC) Q "0^No Old Consult # for the note re-assignment." - I '$G(MDANOTE) Q "0^No TIU Note IEN." - I '$G(MDNDFN) Q "0^No New DFN for the note assignment." - I '$G(MDNEWC) Q "0^No New Consult # for the note assignment." - I '$G(MDNTIU) Q "0^No New Reassigned TIU IEN." - S (MDD,MDCHK,MDREAS,MDTRAN)="",MDPPR=0 K ^TMP("MDTMP",$J) - S MDTRAN=$O(^MDD(702,"ATIU",MDANOTE,0)) I +MDTRAN S MDCHK=$G(^MDD(702,MDTRAN,0)),MDTRANI=MDTRAN_"," D - .I $P(MDCHK,U,5)=MDOLDC&($P(MDCHK,U,6)=MDANOTE) D - ..S MDFDA(702,+MDTRAN_",",.06)="" - ..D FILE^DIE("","MDFDA") K MDFDA - S MDGBL=$NA(^MDD(702.001,"PK",MDANOTE)) - F S MDGBL=$Q(@MDGBL) Q:MDGBL="" Q:$QS(MDGBL,2)'="PK"!($QS(MDGBL,3)'=MDANOTE) S MDN=$QS(MDGBL,6) N DA,DIK S DA=+MDN,DIK="^MDD(702.001," D ^DIK - S MDMULN=+$O(^MDD(702.001,"ASTUDY",+MDTRAN,0)) - I '+MDMULN I +MDTRAN N DA,DIK S DA=+MDTRAN,DIK="^MDD(702," D ^DIK - D NOW^%DTC S MDD=% S MDTRANI=$O(^MDD(702,"ACON",MDNEWC,0)) - S MDREAS=$P(MDNEWV,";",3)_";"_$P(MDNEWV,";",2)_";"_$P(MDNEWV,";") - I +MDTRANI&(MDNDFN=+$G(^MDD(702,+MDTRANI,0))) D - .S MDPPR=$P($G(^MDD(702,+MDTRANI,0)),"^",4) Q:'MDPPR - .S MDNEWV=$$GETVSTR^MDRPCOT1(MDNDFN,MDREAS,MDPPR,MDD) - .S MDFDA(702,+MDTRANI_",",.06)=MDNTIU - .S MDFDA(702,"+1,",.07)=$P(MDNEWV,";",3)_";"_$P(MDNEWV,";",2)_";"_$P(MDNEWV,";") - .D FILE^DIE("","MDFDA") K MDFDA - I 'MDPPR D - .D CPLIST^GMRCCP(MDNDFN,,$NA(^TMP("MDTMP",$J))) - .S MDX="" - .F S MDX=$O(^TMP("MDTMP",$J,MDX)) Q:'MDX S:$P(^(MDX),U,5)=MDNEWC MDPPR=$P(^(MDX),U,6) - K ^TMP("MDTMP",$J) - I +MDPPR Q 1 - S MDNEWV=$$GETVSTR^MDRPCOT1(MDNDFN,MDREAS,MDPPR,MDD) - S MDFDA(702,"+1,",.01)=MDNDFN - S MDFDA(702,"+1,",.02)=MDD - S MDFDA(702,"+1,",.03)=DUZ - S MDFDA(702,"+1,",.04)=MDPPR - S MDFDA(702,"+1,",.05)=MDNEWC - S MDFDA(702,"+1,",.06)=MDNTIU - S MDFDA(702,"+1,",.07)=$P(MDNEWV,";",3)_";"_$P(MDNEWV,";",2)_";"_$P(MDNEWV,";") - S MDFDA(702,"+1,",.09)=0 - D UPDATE^DIE("","MDFDA") - Q 1 - ; -TRANS(STR) ; [Function] Translate the upper arrows to blanks - ; Input parameters - ; 1. STR [Literal/Required] Input: Text with upper arrows that needs to be removed - ; - I STR["^" Q $TR(STR,"^"," ") - Q STR - ; -GETCP(RESULTS,MDCSLT) ; API to return CP Study data - ; Input Parameters: - ; 1. RESULTS [Literal/Required] Return Array - ; 2. MDCSLT [Literal/Required] Consult number - ; - ; Output: - ; RESULTS(0)=-1^Error Message or 1 for success - ; (N,1)=CP Study Number - ; (N,2)=Patient DFN - ; (N,3)=Created Date/Time - ; (N,4)=Created By - ; (N,5)=CP Definition (External Name) - ; (N,6)=Consult Number - ; (N,7)=TIU Note IEN - ; (N,8)=VSTR - ; (N,9)=Transaction Status - ; - ; Where N = 1..n entries - ; - N MDCT,MDX,MDY - I '$G(MDCSLT) S @RESULTS@(0)="-1^No Consult Number passed" Q - S MDX=$O(^MDD(702,"ACON",MDCSLT,0)) I 'MDX S @RESULTS@(0)="-1^No CP Study Entry." Q - S @RESULTS@(0)=1 - S MDCT=0,MDX="" F S MDX=$O(^MDD(702,"ACON",MDCSLT,MDX)) Q:MDX<1 D - .S MDCT=MDCT+1,@RESULTS@(MDCT,1)=MDX - .S MDY=$G(^MDD(702,+MDX,0)),@RESULTS@(MDCT,2)=$P(MDY,U),@RESULTS@(MDCT,3)=$P(MDY,U,2),@RESULTS@(MDCT,4)=$P(MDY,U,3),@RESULTS@(MDCT,5)=$$GET1^DIQ(702,+MDX,.04,"E") - .S @RESULTS@(MDCT,6)=$P(MDY,U,5),@RESULTS@(MDCT,7)=$P(MDY,U,6),@RESULTS@(MDCT,8)=$P(MDY,U,7),@RESULTS@(MDCT,9)=$$GET1^DIQ(702,+MDX,.09,"E") - Q +MDAPI ; HOIFO/DP/NCA - CP API Calls ; [05-05-2003 10:28] + ;;1.0;CLINICAL PROCEDURES;;Apr 01, 2004 + ; Description: + ; These API's are for use by external packages communicating with CP. + ; + ; Integration Agreements: + ; IA# 3378 [Restricted] Documents the APIs that external packages use to communicate with CP. + ; IA# 3468 [Subscription] Use GMRCCP APIs. + ; +EXTDATA(MDPROC) ; [Procedure] + ; Returns 0/1 for external data needed + ; Called by Consults to determine status of consult ordered + ; + ; Input parameters + ; 1. MDPROC [Literal/Required] CP Definition IEN + ; + Q:'$D(^MDS(702.01,+$G(MDPROC),0)) 0 + I +$P(^MDS(702.01,+$G(MDPROC),0),U,3)!($O(^(.1,0))) Q 1 + E Q 0 + ; +ISTAT(MDARR) ; [Procedure] Called by Imaging to update status + ; Input parameters + ; 1. MDARR [Literal/Required] Array from Imaging + ; + ; Input: MDARR(0)="0^error message" or "1^success message" + ; MDARR(1)=TrackID (CP;Transaction IEN) + ; MDARR(2)=Queue Number + ; MDARR(3..N)=Warnings + N MDCON,MDCR,MDIEN,MDIENS,MDLP,MDSTAT,MDSTR,MDTIU,RESULTS + Q:$G(MDARR(0))="" + Q:$G(MDARR(1))="" + Q:$P(MDARR(1),";")'="CP" + Q:'(+$P(MDARR(1),";",2)) + S MDIEN=+$P(MDARR(1),";",2),MDIENS=MDIEN_"," + S MDSTAT=+$P(MDARR(0),"^") + S DATA("TRANSACTION")=MDIEN + ; Is it in error? + I 'MDSTAT D Q + .D STATUS^MDRPCOT(MDIENS,2,$P(MDARR(0),"^",2)) + .S DATA("PKG")="IMAGING" + .S DATA("MESSAGE")=$P(MDARR(0),"^",2) D RPC^MDRPCOT(.RESULTS,"ADDMSG",.DATA) + .F MDLP=2:0 S MDLP=$O(MDARR(MDLP)) Q:'MDLP I $G(MDARR(MDLP))'="" D + ..S DATA("MESSAGE")=$$TRANS(MDARR(MDLP)) D RPC^MDRPCOT(.RESULTS,"ADDMSG",.DATA) + .D IMGSTAT^MDRPCOT1(+MDIENS,2) Q + ; Call Consults that Partial Result ready + S MDCON=+$P(^MDD(702,MDIEN,0),"^",5),MDTIU=+$P(^(0),"^",6) + S MDCR=$$UPDCONS^MDRPCOT1(MDCON,MDTIU) + I +MDCR<0 D Q + .D STATUS^MDRPCOT(MDIENS,2,$P(MDCR,"^",2)) + .S DATA("PKG")="CONSULTS",DATA("MESSAGE")=$P(MDCR,"^",2) + .D RPC^MDRPCOT(.RESULTS,"ADDMSG",.DATA) + .Q + ; Closeout the record + D STATUS^MDRPCOT(MDIENS,3,"") + ; Update Images Status + D IMGSTAT^MDRPCOT1(+MDIENS,3) + Q + ; +ITIU(RESULTS,DFN,CONSULT,VSTRING) ; [Procedure] API for Vista Imaging + ; This API enables VistA Imaging to retrieve/create a TIU note for + ; a consult for attaching images to. + ; + ; RESULTS(0) will equal one of the following + ; IEN of the TIU note if successful + ; or on failure one of the following status messages + ; -1^No patient DFN + ; -1^No Consult IEN + ; -1^No VString + ; -1^Error in CP transaction + ; -1^Unable to create CP transaction + ; -1^Unable to create the TIU document + ; -1^No such consult for this patient. + ; + ; Input parameters + ; 1. RESULTS [Reference/Required] Return array + ; 2. DFN [Literal/Required] Patient IEN + ; 3. CONSULT [Literal/Required] Consult IEN + ; 4. VSTRING [Literal/Optional] VString data for TIU Note (Required to create new TIU note) + ; + ; Variables: + ; MDIEN: [Private] Returns IEN from UPDATE~DIE call + ; MDIENS: [Private] Scratch + ; MDNOTE: [Private] Scratch + ; MDTRANS: [Private] Contains IEN of CP transaction + ; + ; New private variables + NEW MDIEN,MDIENS,MDNOTE,MDTRANS + K ^TMP($J),^TMP("MDTIUST",$J) + N MDD,MDN,MDTIUER,MDTST,MDNEWV,MDTIUD S (MDTIUD,MDTIUER,MDTST)="" + I '$G(DFN) S RESULTS(0)="-1^No patient DFN" Q + I '$G(CONSULT) S RESULTS(0)="-1^No Consult IEN" Q + ; Look for existing transaction + S MDTIUD=$$PREV^MDRPCOT(+CONSULT,"") + I +MDTIUD S RESULTS(0)=+MDTIUD Q + ; No transaction, must create one for this consult + I $G(VSTRING)="" S RESULTS(0)="-1^No VString" Q + D CPLIST^GMRCCP(DFN,,$NA(^TMP($J))) + S MDX="" F S MDX=$O(^TMP($J,MDX)) Q:'MDX I $P(^(MDX),U,5)=CONSULT D Q + .D NOW^%DTC S MDD=% + .S:$L(VSTRING,";")=1 VSTRING=";"_VSTRING + .S MDNEWV=$$GETVSTR^MDRPCOT1(DFN,VSTRING,$P(^TMP($J,MDX),U,6),MDD) + .S MDFDA(702,"+1,",.01)=DFN + .S MDFDA(702,"+1,",.02)=MDD + .S MDFDA(702,"+1,",.03)=DUZ + .S MDFDA(702,"+1,",.04)=$P(^TMP($J,MDX),U,6) + .S MDFDA(702,"+1,",.05)=CONSULT + .S MDFDA(702,"+1,",.07)=$P(MDNEWV,";",3)_";"_$P(MDNEWV,";",2)_";"_$P(MDNEWV,";") + .S MDFDA(702,"+1,",.09)=0 + .;Create the new transaction + .D UPDATE^DIE("","MDFDA","MDIEN") I '$G(MDIEN(1)) D Q + ..S RESULTS(0)="-1^Unable to create CP transaction" + . + .;Create the new TIU Note + .S MDIENS=MDIEN(1)_"," + .S MDN=$$NEWTIUN^MDRPCOT(+MDIENS) + .S MDNOTE=$S(MDN:$$GET1^DIQ(702,+MDIENS,.06,"I"),1:0) + .I 'MDNOTE D Q + ..N DA,DIK + ..S RESULTS(0)="-1^Unable to create the TIU document" + ..S DA=+MDIENS,DIK="^MDD(702," D ^DIK + .S RESULTS(0)=MDNOTE + Q + ; +TIUCOMP(MDNOTE) ; [Procedure] Post Signature action to complete transaction + ; Input parameters + ; 1. MDNOTE [Literal/Required] TIU IEN + ; + N MDFDA,MDRES + S MDRES=$O(^MDD(702,"ATIU",MDNOTE,0)) + I $G(^MDD(702,+MDRES,0))="" Q 0 + I $P($G(^MDD(702,+MDRES,0)),"^",9)=3 Q 1 + S MDFDA(702,MDRES_",",.09)=3 + D FILE^DIE("","MDFDA") + Q 1 + ; +TIUDEL(MDNOTE) ; [Procedure] TIU Note deletion Update + ; Input parameters + ; 1. MDNOTE [Literal/Required] TIU IEN + ; + N MDRES,MDFDA,RESULTS + S MDRES="" F S MDRES=$O(^MDD(702,"ATIU",MDNOTE,MDRES)) Q:'MDRES D + .Q:$G(^MDD(702,+MDRES,0))="" + .S MDFDA(702,MDRES_",",.05)="" + .S MDFDA(702,MDRES_",",.06)="" + .D FILE^DIE("","MDFDA") + .D STATUS^MDRPCOT(MDRES_",",2,"TIU note deleted.") + .S DATA("TRANSACTION")=MDRES,DATA("PKG")="TIU" + .S DATA("MESSAGE")="TIU note deleted." D RPC^MDRPCOT(.RESULTS,"ADDMSG",.DATA) + Q 1 + ; +TIUREAS(MDFN,MDOLDC,MDANOTE,MDNDFN,MDNEWC,MDNEWV,MDNTIU) ; [Function] This is an API to clean up and update TIU note re-assignment. + ; Input parameters + ; 1. MDFN [Literal/Required] The Patient DFN whose TIU document is being re-assigned. + ; 2. MDOLDC [Literal/Required] The Consult that the note is being re-assigned from. + ; 3. MDANOTE [Literal/Required] The TIU Document IEN that is being re-assigned. + ; 4. MDNDFN [Literal/Required] The Patient DFN who will be re-assigned the TIU document. + ; 5. MDNEWC [Literal/Required] The consult number that will be assignment the TIU document. + ; 6. MDNEWV [Literal/Required] The new visit for the TIU document assignment. + ; 7. MDNTIU [Literal/Required] The new reassigned TIU document IEN. + ; + N MDD,MDTRAN,MDCHK,MDLP,MDPPR,MDREAS,MDTRANI,MDX + I '$G(MDFN) Q "0^No DFN for the TIU note re-assignment." + I '$G(MDOLDC) Q "0^No Old Consult # for the note re-assignment." + I '$G(MDANOTE) Q "0^No TIU Note IEN." + I '$G(MDNDFN) Q "0^No New DFN for the note assignment." + I '$G(MDNEWC) Q "0^No New Consult # for the note assignment." + I '$G(MDNTIU) Q "0^No New Reassigned TIU IEN." + S (MDD,MDCHK,MDREAS,MDTRAN)="",MDPPR=0 K ^TMP("MDTMP",$J) + F S MDTRAN=$O(^MDD(702,"ACON",MDOLDC,MDTRAN)) Q:'MDTRAN D + .S MDCHK=$G(^MDD(702,MDTRAN,0)),MDTRANI=MDTRAN_"," + .I $P(MDCHK,U,5)=MDOLDC&($P(MDCHK,U,6)=MDANOTE) D + ..S:'MDPPR MDPPR=$P(MDCHK,U,4) + ..N DA,DIK S DA=+MDTRAN,DIK="^MDD(702," D ^DIK + I 'MDPPR D + .D CPLIST^GMRCCP(MDNDFN,,$NA(^TMP("MDTMP",$J))) + .S MDX="" + .F S MDX=$O(^TMP("MDTMP",$J,MDX)) Q:'MDX S:$P(^(MDX),U,5)=MDNEWC MDPPR=$P(^(MDX),U,6) + K ^TMP("MDTMP",$J) + I 'MDPPR Q 1 + D NOW^%DTC S MDD=% + S MDREAS=$P(MDNEWV,";",3)_";"_$P(MDNEWV,";",2)_";"_$P(MDNEWV,";") + S MDNEWV=$$GETVSTR^MDRPCOT1(MDNDFN,MDREAS,MDPPR,MDD) + S MDFDA(702,"+1,",.01)=MDNDFN + S MDFDA(702,"+1,",.02)=MDD + S MDFDA(702,"+1,",.03)=DUZ + S MDFDA(702,"+1,",.04)=MDPPR + S MDFDA(702,"+1,",.05)=MDNEWC + S MDFDA(702,"+1,",.06)=MDNTIU + S MDFDA(702,"+1,",.07)=$P(MDNEWV,";",3)_";"_$P(MDNEWV,";",2)_";"_$P(MDNEWV,";") + S MDFDA(702,"+1,",.09)=0 + D UPDATE^DIE("","MDFDA","MDTRANI") Q:'$G(MDTRANI(1)) 1 + Q 1 + ; +TRANS(STR) ; [Function] Translate the upper arrows to blanks + ; Input parameters + ; 1. STR [Literal/Required] Input: Text with upper arrows that needs to be removed + ; + I STR["^" Q $TR(STR,"^"," ") + Q STR + ; diff --git a/r/CLINICAL_PROCEDURES-MD/MDHL7A.m b/r/CLINICAL_PROCEDURES-MD/MDHL7A.m index 8895a19a..8b51cdb4 100644 --- a/r/CLINICAL_PROCEDURES-MD/MDHL7A.m +++ b/r/CLINICAL_PROCEDURES-MD/MDHL7A.m @@ -1,182 +1,167 @@ -MDHL7A ; HOIFO/WAA - Routine to Decode HL7 for CP ;9/17/07 08:17 - ;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102 - ; Reference DBIA #10035 [Supported] for DPT calls. - ; Reference DBIA #10106 [Supported] for HLFNC calls. - ; Reference DBIA #10062 [Supported] for VADPT6 calls. - ; Reference DBIA #2701 [Supported] for MPIF001 calls - ; Reference DBIA #10096 [Supported] for ^%ZOSF calls -EN ; [Procedure] Entry Point for Message Array in MSG - N %,BID,CODE,CPT,DA,DATE,DFN,DIK,DLCO,DTO,DZ,ERRTX,EXAM,EXE,MDFLAG,FIL - N I,ICNT,ID,IMP,J,K,LBL,LINO,LINE,LN,MDAPP,MDRTN,MG,MSG,N,NAM,NEXT,NUM - N ORIFN,P,PID,PIEN,S,SEG,SET,SEP,MDSSN,STR,STYP,SUB,TCNT,TXT,UNIQ,SEC - N UNITS,VA,VAL,X,XMBODY,XMDUZ,XMSUBJ,XMTO,Z,ZZ,Z1,Z2,MDERROR - N ECODE,MDIEN,MDOBX,NUMZ,PNAM,ZCODE,MDDEV,MDD702,DEVNAME,DEVIEN,MDQFLG - N MDIORD - K ^TMP($J,"MDHL7A"),^TMP($J,"MDHL7"),^TMP($J,"MDHL7A1") - S MDFLAG=0,MDERROR=0,MDQFLG=0 - Q:$G(HLMTIENS)="" - S ^TMP($J,"MDHL7A1")="" - S HLREST="^TMP($J,""MDHL7A1"")" - S X=$$MSGIEN^MDHL7U3(HLMTIENS,HLREST) ; This code is to convert the HL7 Message **6** - I $P(X,U)=0 D Q - . S DEVIEN=0,ECODE=0 - . S ERRTX=$P(X,U,2) - . D ^MDHL7X - . Q - I $P(X,U)=1 D XVERT^MDHL7U3("MDHL7A1","MDHL7A") - K HLNODE,^TMP($J,"MDHL7A1") - ; -EN2 ; [Procedure] No Description - S (DEVIEN,DEVNAME)="",I=0 - F I=1:1 S X=$G(^TMP($J,"MDHL7A",I)) Q:X="" Q:$E(X,1,3)="OBX" D - . S:$E(X,1,3)="MSH" DEVNAME=$P(X,"|",4) - . I DEVNAME="",HLREC("SFN")'="" S DEVNAME=HLREC("SFN") - . I $E(X,1,3)="MSH",DEVNAME'="Instrument Manager" S DEVIEN=$O(^MDS(702.09,"B",DEVNAME,0)) - . I $E(X,1,3)="OBR" D - .. I DEVNAME="Instrument Manager" D - ... S DEVNAME=$P(X,"|",25) - ... Q - .. S MDIORD=$P(X,"|",4) - .. S MDD702=$S(+MDIORD<1:"",1:$$GETSTDY^MDRPCOT1(MDIORD)) - .. I MDD702<1 S MDD702="" Q - .. I MDD702>0 D ;Validate the entry from 702 is good. - ... I $G(^MDD(702,MDD702,0))="" S MDD702="" Q - ... S DEVIEN=$$GET1^DIQ(702,MDD702,.11,"I") - ... I DEVIEN<1 S DEVIEN="" ; No device defined - ... Q - .. Q - . Q - I DEVIEN="",DEVNAME'="" S DEVIEN=$O(^MDS(702.09,"B",DEVNAME,0)) - I DEVNAME="" S ERRTX="Invalid device Code" D ^MDHL7X Q - I DEVIEN="" S ERRTX="Invalid device entry" D ^MDHL7X Q - S ZCODE=$P($G(^MDS(702.09,DEVIEN,.1)),"^",2) - S ECODE=0,INST=DEVIEN,MDAPP=DEVNAME - I 'INST S ERRTX="Invalid Application Code" D ^MDHL7X Q - D INST^MDHL7U2(DEVIEN,.ECODE) I 'ECODE D Q - . S ERRTX="Device Error" D ^MDHL7X - . Q - I (ZCODE="M")!(ZCODE="B") D Q:MDERROR Q:ZCODE="M" ; - . S MDFLAG=1,MDERROR=0 ; Tell Medicine that CP is talking to HL7 - . D ^MDHL7MCA ; Run the Medicine routines - . Q:MDERROR ; Medicine found an error and sent an error back - . Q - S NUMZ=$O(^TMP($J,"MDHL7A",""),-1) - S NUM=0,MDOBX=0 - F NUM=1:1:NUMZ D Q:$G(ERRTX)'="" - . S LINO=^TMP($J,"MDHL7A",NUM) - . S SEC=$P(LINO,"|") - . I SEC="MSH" D MSH Q - . I SEC="PID" D PID Q - . I SEC="OBR" D OBR Q - . I SEC="PV1" Q - . I SEC="ORC" Q - . I SEC="OBX" S MDOBX=1 Q - . Q - Q:$G(ERRTX)'="" - I 'MDOBX S ERRTX="OBX not found when expected" D ^MDHL7X Q - D OBX - D STATUS(MDIEN,"P") - K ^TMP($J,"MDHL7A"),^TMP($J,"MDHL7") - Q -STATUS(DA,STAT) ; Update the status of the report in 703.1 - Q:$G(ERRTX)'="" - S $P(^MDD(703.1,DA,0),U,9)=STAT - S DIK="^MDD(703.1," D IX1^DIK - Q -IM ;Instrument Manager Interface - Q:DEVNAME'="Instrument Manager" - I $E(X,1,3)'="OBR" Q - S DEVNAME=$P(X,"|",25) - S DEVIEN=$O(^MDS(702.09,"B",DEVNAME,0)) - Q - ; -MSH ; [Procedure] Decode MSH - N SEG - I '$D(^TMP($J,"MDHL7A",NUM)) Q - S X=$G(^TMP($J,"MDHL7A",NUM)),SEG("MSH")=X - I $E(X,1,3)'="MSH" S ERRTX="MSH not first record" D ^MDHL7X Q - Q - ; -OBR ; [Procedure] Check OBR - N MDGMRC - S X=$G(^TMP($J,"MDHL7A",NUM)) I $E(X,1,3)'="OBR" S ERRTX="OBR not found when expected" D ^MDHL7X Q - S SEG("OBR")=X - S MDIORD=$P(X,"|",4) - S MDD702=$S(+MDIORD<1:"",1:$$GETSTDY^MDRPCOT1(MDIORD)) - ;I MDD702'="" S MDD702=$$CHK^MDNCHK(MDD702) ; PATCH 11 - S ORIFN=$P(X,"|",3),(EXAM,%)=$P(X,"|",5) I EXAM'="" S EXAM=$P(%,"^",2) I EXAM="" S EXAM=$P(%,"^",1) - S CPT=$P(X,"|",5) I $P(CPT,"^",3)["CPT" S CPT=$P(CPT,"^",1) - S DTO="",DATE=$P(X,"|",8) I DATE'="" S:$L(DATE)>14 DATE=$E(DATE,1,14) S DTO=$$FMDATE^HLFNC(DATE) - ; vvv== Added to address the issues of mismatch - I $G(MDD702)>0 I DFN'=$$GET1^DIQ(702,MDD702,.01,"I") S ERRTX="Patient name Mismatch. Name in PID doesn't match the name in the CP Order #"_MDD702_"." D ^MDHL7X Q - I $G(MDD702)>0 I MDDOB'=$$GET1^DIQ(2,DFN,.03,"I") S ERRTX="Patient DOB Mismatch. DOB in PID doesn't match the DOB in the CP Order #"_MDD702_"." D ^MDHL7X Q - I DTO="" S ERRTX="Missing required Date/Time of Procedure in OBR" D ^MDHL7X Q - ;;S UNIQ=$TR($H,",","-") - S UNIQ=$$NEWID(DFN,DATE,INST,$G(MDD702),HLMTIEN) - I +UNIQ="-1" S ERRTX="Unable to Create or Lock 703.1" D ^MDHL7X Q - S MDIEN=$P(UNIQ,"^",1) ; Got the IEN for 703.1 - N SET S SET=DTO_"^"_$P(UNIQ,U,2),ICNT=0 N IMP - S MDRTN=$P($G(^MDS(702.09,INST,.1)),"^",1) S:MDRTN'["^" MDRTN="^"_MDRTN - S X=MDRTN S:X["^" X=$P(X,"^",2) X ^%ZOSF("TEST") I '$T S ERRTX="Processing routine not found" D ^MDHL7X Q ; IA %10096 - D CPTICD^MDHL7U3(X,MDIEN) ; Update CPT and ICD9 - D PHY^MDHL7U3(X,MDIEN) ; Get Doc who did the procedure. - Q - ; -PID ; [Procedure] Check PID - S X=$G(^TMP($J,"MDHL7A",NUM)) I $E(X,1,3)'="PID" S ERRTX="PID not second record" D ^MDHL7X Q - S SEG("PID")=X - S MDDOB=$P(X,"|",8) I MDDOB'="" S MDDOB=($E(MDDOB,1,4)-1700)_$E(MDDOB,5,8) - I $L($P(X,"|",4))'<16 D I +DFN=-1 Q - . N ICN - . S ICN=$P(X,"|",4) - . S DFN=$$GETDFN^MPIF001(ICN) - . I +DFN=-1 S ERRTX=$P(DFN,U,2) - . D MDSSN I DFN<1 S ERRTX="SSN not found" D ^MDHL7X Q - . I DFN>0 K ERRTX - . S MDSSN=$$GET1^DIQ(2,DFN,.09,"I") I MDSSN="" S MDSSN=" ",DFN=0 - . Q - E D MDSSN - I 'DFN S ERRTX="SSN not found" D ^MDHL7X Q - S Z1=$P($G(^DPT(DFN,0)),",",1),Z2=$P(NAM,"^",1) - S Z1=$TR(Z1,"abcdefghijklmnopqrstuvwxyz- '","ABCDEFGHIJKLMNOPQRSTUVWXYZ") - S Z2=$TR(Z2,"abcdefghijklmnopqrstuvwxyz- '","ABCDEFGHIJKLMNOPQRSTUVWXYZ") - I $E(Z1,1,3)'=$E(Z2,1,3) S ERRTX="Last Name MisMatch" D ^MDHL7X Q - S PNAM=$TR(NAM,"^",",") - D PID^VADPT6 S PID=$G(VA("PID")),BID=$G(VA("BID")) N VA - Q -MDSSN ; This subroutine is to match up the SSN for a patient. - S NAM=$P(X,"|",6),MDSSN=$P(X,"|",20) I $L(MDSSN)<9 S MDSSN=$P(X,"|",4) - S MDSSN=$P(MDSSN,"^",1) I MDSSN'?9N S MDSSN=$TR(MDSSN,"- ","") - I $E(MDSSN,$L(MDSSN))="P" S MDSSN=$E(MDSSN,1,9) - S:MDSSN'?9N MDSSN=" " S DFN=$O(^DPT("SSN",MDSSN,0)) - I 'DFN S DFN=$O(^DPT("SSN",MDSSN_"P",0)) - Q - ; -OBX ; [Observation] - D @MDRTN - Q -NEWID(DFN,DATE,INST,MDD702,HLMTIEN) ; Generate a new entry and ID of 703.1 - N NEWID,MDFDA,MDIEN,MDNO - S NEWID=$TR($H,",","-") ; Create inital ID - L +(^MDD(703.1,"B")):60 E Q "-1" - ;^^--- Unable to get a lock in the file - F Q:'$D(^MDD(703.1,"B",NEWID)) H 1 S NEWID=$TR($H,",","-") - ;^^--- Search to create a new ID if current ID is in use - S MDFDA(703.1,"+1,",.01)=NEWID - S MDFDA(703.1,"+1,",.02)=DFN - S MDFDA(703.1,"+1,",.03)=$$HL7TFM^MDHL7U(DATE) - S MDFDA(703.1,"+1,",.04)=INST - S MDFDA(703.1,"+1,",.05)=MDD702 - S MDFDA(703.1,"+1,",.06)=HLMTIEN - D UPDATE^DIE("","MDFDA","MDIEN") - L -(^MDD(703.1,"B")) - I $G(MDIEN(1))>0 D Q MDIEN(1)_U_NEWID - . S ^MDD(703.1,MDIEN(1),.1,0)="^703.11S^0^0" - . S MDNO=$$NTIU^MDRPCW1(+MDD702) - . Q - ; ^^--- Create Subfile and quit - Q "-1" ; Unable to create file - ; -PROC ; [Procedure] Create report entry in file (703.1) - D PROC^MDHL7U - Q +MDHL7A ; HOIFO/WAA - Routine to Decode HL7 for CP ; [05-07-2001 10:38] + ;;1.0;CLINICAL PROCEDURES;;Apr 01, 2004 + ; Reference DBIA #10035 [Supported] for DPT calls. + ; Reference DBIA #10106 [Supported] for HLFNC calls. + ; Reference DBIA #10062 [Supported] for VADPT6 calls. + ; Reference DBIA #2701 [Supported] for MPIF001 Calls +EN ; [Procedure] Entry Point for Message Array in MSG + N %,BID,CODE,CPT,DA,DATE,DFN,DIK,DLCO,DTO,DZ,ERRTX,EXAM,EXE,MDFLAG,FIL + N I,ICNT,ID,IMP,J,K,LBL,LINO,LINE,LN,MDAPP,MDRTN,MG,MSG,N,NAM,NEXT,NUM + N ORIFN,P,PID,PIEN,S,SEG,SET,SEP,MDSSN,STR,STYP,SUB,TCNT,TXT,UNIQ,SEC + N UNITS,VA,VAL,X,XMBODY,XMDUZ,XMSUBJ,XMTO,Z,ZZ,Z1,Z2,MDERROR + N ECODE,MDIEN,MDOBX,NUMZ,PNAM,ZCODE,MDDEV,MDD702,DEVNAME,DEVIEN,MDQFLG + N MDIORD + K ^TMP($J,"MDHL7A"),^TMP($J,"MDHL7") + S MDFLAG=0,MDERROR=0,MDQFLG=0 + F I=1:1 X HLNEXT Q:MDQFLG S ^TMP($J,"MDHL7A",I)=$TR(HLNODE,$C(10),""),J=0 S:HLQUIT<1 MDQFLG=1 F S J=$O(HLNODE(J)) Q:J<1 S ^TMP($J,"MDHL7A",I,J)=$TR(HLNODE(J),$C(10),"") + K HLNODE + ; +EN2 ; [Procedure] No Description + S (DEVIEN,DEVNAME)="" + F I=1:1 S X=$G(^TMP($J,"MDHL7A",I)) Q:X="" Q:$E(X,1,3)="OBX" D + . S:$E(X,1,3)="MSH" DEVNAME=$P(X,"|",4) + . I $E(X,1,3)="MSH",DEVNAME'="Instrument Manager" S DEVIEN=$O(^MDS(702.09,"B",DEVNAME,0)) + . I $E(X,1,3)="OBR" D + .. I DEVNAME="Instrument Manager" D + ... S DEVNAME=$P(X,"|",25) + ... Q + .. S MDIORD=$P(X,"|",4) + .. S MDD702=$S(+MDIORD<1:"",1:$$GETSTDY^MDRPCOT1(MDIORD)) + .. I MDD702<1 S MDD702="" Q + .. I MDD702>0 D ;Validate the entry from 702 is good. + ... I $G(^MDD(702,MDD702,0))="" S MDD702="" Q + ... S DEVIEN=$$GET1^DIQ(702,MDD702,.11,"I") + ... I DEVIEN<1 S DEVIEN="" ; No device defined + ... Q + .. Q + . Q + I DEVIEN="",DEVNAME'="" S DEVIEN=$O(^MDS(702.09,"B",DEVNAME,0)) + I DEVNAME="" S ERRTX="Invalid device Code" D ^MDHL7X Q + I DEVIEN="" S ERRTX="Invalid device entry" D ^MDHL7X Q + S ZCODE=$P($G(^MDS(702.09,DEVIEN,.1)),"^",2) + S ECODE=0,INST=DEVIEN,MDAPP=DEVNAME + I 'INST S ERRTX="Invalid Application Code" D ^MDHL7X Q + D INST^MDHL7U2(DEVIEN,.ECODE) I 'ECODE D Q + . S ERRTX="Device Error" D ^MDHL7X + . Q + I (ZCODE="M")!(ZCODE="B") D Q:MDERROR Q:ZCODE="M" ; + . S MDFLAG=1,MDERROR=0 ; Tell Medicine that CP is talking to HL7 + . ;S MSG(1)=^TMP($J,"MDHL7A",1) + . ;S MSG(2)=^TMP($J,"MDHL7A",2) + . D ^MDHL7MCA ; Run the Medicine routines + . Q:MDERROR ; Medicine found an error and sent an error back + . ;;I ZCODE="M" D GENACK^MDHL7X + . Q + S NUMZ=$O(^TMP($J,"MDHL7A",""),-1) + S NUM=0,MDOBX=0 + F NUM=1:1:NUMZ D Q:$G(ERRTX)'="" + . S LINO=^TMP($J,"MDHL7A",NUM) + . S SEC=$P(LINO,"|") + . I SEC="MSH" D MSH Q + . I SEC="PID" D PID Q + . I SEC="OBR" D OBR Q + . I SEC="PV1" Q + . I SEC="ORC" Q + . I SEC="OBX" S MDOBX=1 Q + . Q + Q:$G(ERRTX)'="" + I 'MDOBX S ERRTX="OBX not found when expected" D ^MDHL7X Q + D OBX + D STATUS(MDIEN,"P") + K ^TMP($J,"MDHL7A"),^TMP($J,"MDHL7") + Q +STATUS(DA,STAT) ; Update the status of the report in 703.1 + Q:$G(ERRTX)'="" + S $P(^MDD(703.1,DA,0),U,9)=STAT + S DIK="^MDD(703.1," D IX1^DIK + Q +IM ;Instrument Manager Interface + Q:DEVNAME'="Instrument Manager" + I $E(X,1,3)'="OBR" Q + S DEVNAME=$P(X,"|",25) + S DEVIEN=$O(^MDS(702.09,"B",DEVNAME,0)) + Q + ; +MSH ; [Procedure] Decode MSH + N SEG + I '$D(^TMP($J,"MDHL7A",NUM)) Q + S X=$G(^TMP($J,"MDHL7A",NUM)),SEG("MSH")=X + I $E(X,1,3)'="MSH" S ERRTX="MSH not first record" D ^MDHL7X Q + Q + ; +OBR ; [Procedure] Check OBR + N MDGMRC + S X=$G(^TMP($J,"MDHL7A",NUM)) I $E(X,1,3)'="OBR" S ERRTX="OBR not found when expected" D ^MDHL7X Q + S SEG("OBR")=X + S MDIORD=$P(X,"|",4) + S MDD702=$S(+MDIORD<1:"",1:$$GETSTDY^MDRPCOT1(MDIORD)) + S ORIFN=$P(X,"|",3),(EXAM,%)=$P(X,"|",5) I EXAM'="" S EXAM=$P(%,"^",2) I EXAM="" S EXAM=$P(%,"^",1) + S CPT=$P(X,"|",5) I $P(CPT,"^",3)["CPT" S CPT=$P(CPT,"^",1) + S DTO="",DATE=$P(X,"|",8) I DATE'="" S:$L(DATE)>14 DATE=$E(DATE,1,14) S DTO=$$FMDATE^HLFNC(DATE) + ; vvv== Added to address the issues of mismatch + I $G(MDD702)>0 I DFN'=$$GET1^DIQ(702,MDD702,.01,"I") S ERRTX="Patient name Mismatch. Name in PID doesn't match the name in the CP Order #"_MDD702_"." D ^MDHL7X Q + I DTO="" S ERRTX="Missing required Date/Time of Procedure in OBR" D ^MDHL7X Q + ;;S UNIQ=$TR($H,",","-") + S UNIQ=$$NEWID(DFN,DATE,INST,$G(MDD702),HLMTIEN) + I +UNIQ="-1" S ERRTX="Unable to Create or Lock 703.1" D ^MDHL7X Q + S MDIEN=$P(UNIQ,"^",1) ; Got the IEN for 703.1 + N SET S SET=DTO_"^"_$P(UNIQ,U,2),ICNT=0 N IMP + S MDRTN=$P($G(^MDS(702.09,INST,.1)),"^",1) S:MDRTN'["^" MDRTN="^"_MDRTN + S X=MDRTN S:X["^" X=$P(X,"^",2) X ^%ZOSF("TEST") I '$T S ERRTX="Processing routine not found" D ^MDHL7X Q ; IA %10096 + Q + ; +PID ; [Procedure] Check PID + S X=$G(^TMP($J,"MDHL7A",NUM)) I $E(X,1,3)'="PID" S ERRTX="PID not second record" D ^MDHL7X Q + S SEG("PID")=X + I $L($P(X,"|",4))'<16 D I +DFN=-1 Q + . N ICN + . S ICN=$P(X,"|",4) + . S DFN=$$GETDFN^MPIF001(ICN) + . I +DFN=-1 S ERRTX=$P(DFN,U,2) + . D MDSSN I DFN<1 S ERRTX="SSN not found" D ^MDHL7X Q + . I DFN>0 K ERRTX + . S MDSSN=$$GET1^DIQ(2,DFN,.09,"I") I MDSSN="" S MDSSN=" ",DFN=0 + . Q + E D MDSSN + I 'DFN S ERRTX="SSN not found" D ^MDHL7X Q + S Z1=$P($G(^DPT(DFN,0)),",",1),Z2=$P(NAM,"^",1) + S Z1=$TR(Z1,"abcdefghijklmnopqrstuvwxyz- '","ABCDEFGHIJKLMNOPQRSTUVWXYZ") + S Z2=$TR(Z2,"abcdefghijklmnopqrstuvwxyz- '","ABCDEFGHIJKLMNOPQRSTUVWXYZ") + I $E(Z1,1,3)'=$E(Z2,1,3) S ERRTX="Last Name MisMatch" D ^MDHL7X Q + S PNAM=$TR(NAM,"^",",") + D PID^VADPT6 S PID=$G(VA("PID")),BID=$G(VA("BID")) N VA + Q +MDSSN ; This subroutine is to match up the SSN for a patient. + S NAM=$P(X,"|",6),MDSSN=$P(X,"|",20) I $L(MDSSN)<9 S MDSSN=$P(X,"|",4) + S MDSSN=$P(MDSSN,"^",1) I MDSSN'?9N S MDSSN=$TR(MDSSN,"- ","") + I $E(MDSSN,$L(MDSSN))="P" S MDSSN=$E(MDSSN,1,9) + S:MDSSN'?9N MDSSN=" " S DFN=$O(^DPT("SSN",MDSSN,0)) + I 'DFN S DFN=$O(^DPT("SSN",MDSSN_"P",0)) + Q + ; +OBX ; [Observation] + ;Q:$P(^TMP($J,"MDHL7A",NUM),"|")'="OBX" + D @MDRTN + Q +NEWID(DFN,DATE,INST,MDD702,HLMTIEN) ; Generate a new entry and ID of 703.1 + N NEWID,MDFDA,MDIEN + S NEWID=$TR($H,",","-") ; Create inital ID + L +(^MDD(703.1,"B")):60 E Q "-1" + ;^^--- Unable to get an lock in the file + F Q:'$D(^MDD(703.1,"B",NEWID)) H 1 S NEWID=$TR($H,",","-") + ;^^--- Search to create an new ID in current ID is in use + S MDFDA(703.1,"+1,",.01)=NEWID + S MDFDA(703.1,"+1,",.02)=DFN + S MDFDA(703.1,"+1,",.03)=$$HL7TFM^MDHL7U(DATE) + S MDFDA(703.1,"+1,",.04)=INST + S MDFDA(703.1,"+1,",.05)=MDD702 + S MDFDA(703.1,"+1,",.06)=HLMTIEN + D UPDATE^DIE("","MDFDA","MDIEN") + L -(^MDD(703.1,"B")) + I $G(MDIEN(1))>0 S ^MDD(703.1,MDIEN(1),.1,0)="^703.11S^0^0" Q MDIEN(1)_U_NEWID + ; ^^--- Create Subfile and quit + Q "-1" ; Unable to create file + ; +PROC ; [Procedure] Create report entry in file (703.1) + D PROC^MDHL7U + Q diff --git a/r/CLINICAL_PROCEDURES-MD/MDHL7MCA.m b/r/CLINICAL_PROCEDURES-MD/MDHL7MCA.m index 9de71e33..c1c7931b 100644 --- a/r/CLINICAL_PROCEDURES-MD/MDHL7MCA.m +++ b/r/CLINICAL_PROCEDURES-MD/MDHL7MCA.m @@ -1,66 +1,66 @@ -MDHL7MCA ; HOIFO/REL-Routine to Decode HL7 for MEDICINE ; [05-07-2001 10:38] - ;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102 - ; Reference DBIA #10035 for DPT calls. - ; Reference DBIA #10062 for VADPT calls. - ; Reference DBIA #10106 for HL7 calls. - ; Reference DBIA #10096 for ^%ZOSF calls. -EN ; Entry Point for Message Array in MSG - N MSG - K ERRTX - S MDERROR=0 - ;F I=3:1 X HLNEXT Q:HLQUIT'>0 S MSG(I)=HLNODE,J=0 F S J=$O(HLNODE(J)) Q:'J S MSG(I,J)=HLNODE(J) - M MSG=^TMP($J,"MDHL7A") - S NUM=1 -MSH ; Decode MSH - K SEG - I '$D(MSG(NUM)) G KIL - S X=$G(MSG(NUM)),SEG("MSH")=X,MCAPP="" - I $E(X,1,3)'="MSH" S ERRTX="MSH not first record" D ^MDHL7MCX G KIL - S MCAPP=$P(MSG(NUM),"|",4) I MCAPP="" G KIL - S NUM=NUM+1 -PID ; Check PID - S X=$G(MSG(NUM)) I $E(X,1,3)'="PID" S ERRTX="PID not second record" D ^MDHL7MCX G KIL - S SEG("PID")=X - S NAM=$P(X,"|",6),MDSSN=$P(X,"|",20) I $L(MDSSN)<9 S MDSSN=$P(X,"|",4) - S MDSSN=$P(MDSSN,"^",1) I MDSSN'?9N S MDSSN=$TR(MDSSN,"- ","") - S:MDSSN'?9N MDSSN=" " S DFN=$O(^DPT("SSN",MDSSN,0)) - I 'DFN S ERRTX="SSN not found" D ^MDHL7MCX G KIL - S Z1=$P($G(^DPT(DFN,0)),",",1),Z2=$P(NAM,"^",1) - S Z1=$TR(Z1,"abcdefghijklmnopqrstuvwxyz- '","ABCDEFGHIJKLMNOPQRSTUVWXYZ") - S Z2=$TR(Z2,"abcdefghijklmnopqrstuvwxyz- '","ABCDEFGHIJKLMNOPQRSTUVWXYZ") - I $E(Z1,1,3)'=$E(Z2,1,3) S ERRTX="Last Name MisMatch" D ^MDHL7MCX G KIL - D PID^VADPT6 S PID=$G(VA("PID")),BID=$G(VA("BID")) K VA - ; If DFN not a medical patient, add DFN to medical patient file - I '$D(^MCAR(690,DFN)) S ^MCAR(690,DFN,0)=DFN,^MCAR(690,"B",DFN,DFN)="",$P(^MCAR(690,0),U,4)=$P(^MCAR(690,0),U,4)+1 S:$P(^MCAR(690,0),U,3)14 DATE=$E(DATE,1,14) S DTO=$$FMDATE^HLFNC(DATE) - I DTO="" S ERRTX="Missing required Date/Time of Procedure in OBR" D ^MDHL7MCX G KIL - K SET S SET=DTO_"^"_DFN,NUM=NUM+1,ICNT=0 K IMP - ; Go to Application - S INST=$O(^MCAR(690.7,"B",MCAPP,0)) I 'INST S X=MCAPP,ERRTX="Invalid Application Code" D ^MDHL7MCX G KIL - S MCRTN=$G(^MCAR(690.7,INST,1)) S:MCRTN'["^" MCRTN="^"_MCRTN - ; test for existence - S X=MCRTN S:X["^" X=$P(X,"^",2) X ^%ZOSF("TEST") I '$T S ERRTX="Processing routine not found" D ^MDHL7MCX G KIL - D @MCRTN G KIL -PROC ; Create Procedure entry in appropriate file (FIL) - I $P(SET,"^",1)=""!($P(SET,"^",2)="") Q - S DA=0 F S DA=$O(^MCAR(FIL,"B",$P(SET,"^",1),DA)) Q:'DA I $P($G(^MCAR(FIL,DA,0)),"^",1,2)=SET Q - Q:DA -P1 L +^MCAR(FIL,0):3 G:'$T P1 S DA=$P(^MCAR(FIL,0),"^",3)+1,$P(^MCAR(FIL,0),"^",3,4)=DA_"^"_DA L -^MCAR(FIL,0) - I $D(^MCAR(FIL,DA)) G P1 - S ^MCAR(FIL,DA,0)=SET S DIK="^MCAR("_FIL_"," D IX1^DIK Q -KIL ; Kill Variables - K %,BID,CODE,CPT,DA,DATE,DFN,DIK,DLCO,DTO,ERRTX,EXAM,EXAM2,EXE,FIL - K I,ICNT,ID,IMP,J,K,LBL,LINE,LN,MCAPP,MCRTN,MG,MSG,N,NAM,NEXT,NUM - K ORIFN,P,PID,PIEN,S,SEG,SEP,SET,MDSSN,STR,STYP,SUB,TCNT,TXT - K UNITS,VA,VAL,X,XMBODY,XMDUZ,XMSUBJ,XMTO,Z1,Z2 - Q +MDHL7MCA ; HIRMFO/REL-Routine to Decode HL7 for MEDICINE ; [05-07-2001 10:38] + ;;1.0;CLINICAL PROCEDURES;;Apr 01, 2004 + ; Reference DBIA #10035 for DPT calls. + ; Reference DBIA #10062 for VADPT calls. + ; Reference DBIA #10106 for HL7 calls. +EN ; Entry Point for Message Array in MSG + N MSG + K ERRTX + S MDERROR=0 + ;F I=3:1 X HLNEXT Q:HLQUIT'>0 S MSG(I)=HLNODE,J=0 F S J=$O(HLNODE(J)) Q:'J S MSG(I,J)=HLNODE(J) + M MSG=^TMP($J,"MDHL7A") + S NUM=1 +MSH ; Decode MSH + K SEG + I '$D(MSG(NUM)) G KIL + S X=$G(MSG(NUM)),SEG("MSH")=X,MCAPP="" + I $E(X,1,3)'="MSH" S ERRTX="MSH not first record" D ^MDHL7MCX G KIL + S MCAPP=$P(MSG(NUM),"|",4) I MCAPP="" G KIL + S NUM=NUM+1 +PID ; Check PID + S X=$G(MSG(NUM)) I $E(X,1,3)'="PID" S ERRTX="PID not second record" D ^MDHL7MCX G KIL + S SEG("PID")=X + S NAM=$P(X,"|",6),MDSSN=$P(X,"|",20) I $L(MDSSN)<9 S MDSSN=$P(X,"|",4) + S MDSSN=$P(MDSSN,"^",1) I MDSSN'?9N S MDSSN=$TR(MDSSN,"- ","") + S:MDSSN'?9N MDSSN=" " S DFN=$O(^DPT("SSN",MDSSN,0)) + I 'DFN S ERRTX="SSN not found" D ^MDHL7MCX G KIL + S Z1=$P($G(^DPT(DFN,0)),",",1),Z2=$P(NAM,"^",1) + S Z1=$TR(Z1,"abcdefghijklmnopqrstuvwxyz- '","ABCDEFGHIJKLMNOPQRSTUVWXYZ") + S Z2=$TR(Z2,"abcdefghijklmnopqrstuvwxyz- '","ABCDEFGHIJKLMNOPQRSTUVWXYZ") + I $E(Z1,1,3)'=$E(Z2,1,3) S ERRTX="Last Name MisMatch" D ^MDHL7MCX G KIL + D PID^VADPT6 S PID=$G(VA("PID")),BID=$G(VA("BID")) K VA + ; If DFN not a medical patient, add DFN to medical patient file + I '$D(^MCAR(690,DFN)) S ^MCAR(690,DFN,0)=DFN,^MCAR(690,"B",DFN,DFN)="",$P(^MCAR(690,0),U,4)=$P(^MCAR(690,0),U,4)+1 S:$P(^MCAR(690,0),U,3)14 DATE=$E(DATE,1,14) S DTO=$$FMDATE^HLFNC(DATE) + I DTO="" S ERRTX="Missing required Date/Time of Procedure in OBR" D ^MDHL7MCX G KIL + K SET S SET=DTO_"^"_DFN,NUM=NUM+1,ICNT=0 K IMP + ; Go to Application + S INST=$O(^MCAR(690.7,"B",MCAPP,0)) I 'INST S X=MCAPP,ERRTX="Invalid Application Code" D ^MDHL7MCX G KIL + S MCRTN=$G(^MCAR(690.7,INST,1)) S:MCRTN'["^" MCRTN="^"_MCRTN + ; test for existence + S X=MCRTN S:X["^" X=$P(X,"^",2) X ^%ZOSF("TEST") I '$T S ERRTX="Processing routine not found" D ^MDHL7MCX G KIL + D @MCRTN G KIL +PROC ; Create Procedure entry in appropriate file (FIL) + I $P(SET,"^",1)=""!($P(SET,"^",2)="") Q + S DA=0 F S DA=$O(^MCAR(FIL,"B",$P(SET,"^",1),DA)) Q:'DA I $P($G(^MCAR(FIL,DA,0)),"^",1,2)=SET Q + Q:DA +P1 L +^MCAR(FIL,0):3 G:'$T P1 S DA=$P(^MCAR(FIL,0),"^",3)+1,$P(^MCAR(FIL,0),"^",3,4)=DA_"^"_DA L -^MCAR(FIL,0) + I $D(^MCAR(FIL,DA)) G P1 + S ^MCAR(FIL,DA,0)=SET S DIK="^MCAR("_FIL_"," D IX1^DIK Q +KIL ; Kill Variables + K %,BID,CODE,CPT,DA,DATE,DFN,DIK,DLCO,DTO,ERRTX,EXAM,EXAM2,EXE,FIL + K I,ICNT,ID,IMP,J,K,LBL,LINE,LN,MCAPP,MCRTN,MG,MSG,N,NAM,NEXT,NUM + K ORIFN,P,PID,PIEN,S,SEG,SEP,SET,MDSSN,STR,STYP,SUB,TCNT,TXT + K UNITS,VA,VAL,X,XMBODY,XMDUZ,XMSUBJ,XMTO,Z1,Z2 + Q diff --git a/r/CLINICAL_PROCEDURES-MD/MDHL7U3.m b/r/CLINICAL_PROCEDURES-MD/MDHL7U3.m index 816bca5f..dca2650d 100644 --- a/r/CLINICAL_PROCEDURES-MD/MDHL7U3.m +++ b/r/CLINICAL_PROCEDURES-MD/MDHL7U3.m @@ -1,212 +1,12 @@ -MDHL7U3 ; HOIFO/WAA -Utilities for CP to process HL7 messages ; 7/26/00 - ;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102 - ; Reference DBIA #2729 [Supported] for XMXPAI - ; Reference DBIA #4262 [Supported] for HL7 call. - ; Reference DBIA #3273 [Subscription] for HL7 call. - ; Reference DBIA #10138 [Supported] for HL7 call. - ; Reference DBIA #3990 [Supported] for ICDCODE call - ; Reference DBIA #1131 [Supported] for XMB("NETNAME") reference - ; Reference DBIA #1995 [Supported] for ICPTCOD to handle CPT Codes call - ; Reference DBIA #10082 [Supported] for ^ICD9 reference - ; Reference DBIA #10111 [Supported] for FILE 3.8 call - ; Reference DBIA #10103 [Supported] for XLFDT call - ; -HL7CHK(MDD702) ; Check to see of there is an entry in 703.1 for a patient. - N X - S X="1^" - D - . N Y - . I $G(^MDD(702,MDD702,0))="" S X="-1^No Entry in 702." Q - . I $D(^MDD(703.1,"ASTUDYID",MDD702))=0 Q - . S Y=0 - . S Y=$O(^MDD(703.1,"ASTUDYID",MDD702,Y)) I Y>0 S X="-1^This Study has Data on file." - . Q - Q X -XVERT(MDA,MDB) ; Strip out blank Lines - Q:MDA="" - Q:MDB="" - Q:$G(^TMP($J,MDA,1)) - N I,CNT,CNT2,NODE,FLG - S (CNT,I,FLG)=0 - F S I=$O(^TMP($J,MDA,I)) Q:I<1 D - . S NODE=$TR(^TMP($J,MDA,I),$C(10),"") - . I NODE="" S FLG=0 Q - . I FLG D Q - . . S CNT2=CNT2+1 - . . S ^TMP($J,MDB,CNT,CNT2)=NODE - . . Q - . I 'FLG D Q - . . S CNT=CNT+1 - . . S ^TMP($J,MDB,CNT)=NODE - . . S FLG=1,CNT2=0 - . . Q - . Q - Q - ; -PURGE(MDD7031) ; - ; This sub-routine will delete HL7 772 Message text after a message - ; been processed by Imaging. - Q:'$D(^MDD(703.1,MDD7031,0)) ; No entry found - S MDD772=$P(^MDD(703.1,MDD7031,0),U,6) Q:MDD772="" - D DELBODY^HLUOPT2(MDD772,"CLINICAL PROCEDURES message purge","^TMP($J,""IN"")") - S $P(^MDD(703.1,MDD7031,0),U,6)="" - Q - ; -PHY(X,MDIEN) ; Add the doc who did the exam to the report - Q - ; This will be implemented with the Doctor Lookup when it comes out. - N LINE1,LINE - S LINE1=$P(X,"|",17) - S LINE=$P(LINE1,"^",2) ; Last - S LINE=LINE_$S($P(LINE1,"^",3)'="":", "_$P(LINE1,"^",3),1:"") ; First - S LINE=LINE_$S($P(LINE1,"^",4)'="":" "_$P(LINE1,"^",4),1:"") ; MI - D ADD(MDIEN,"9",LINE) - Q - ; -CPTICD(X,MDIEN) ; Break out CPT and ICD9 codes - N ICD,CPT - Q:MDIEN<1 - S CPT=$P(X,"|",45) I CPT'="" D FILECD(MDIEN,CPT,"7") - S ICD=$P(X,"|",14) I ICD'="" D FILECD(MDIEN,ICD,"8") - Q -FILECD(MDIEN,CODE,TYPE) ; fILE THE DATA - N LINE,Y,I,CNT,RESULT - S CNT=$L(CODE,"~") - S LINE="" - F I=1:1:CNT S Y=$P(CODE,"~",I),RESULT=$P(Y,"^",1),LINE(.2,I,0)=RESULT - S LINE(.2,0)="^^"_CNT_"^"_CNT_"^"_$P(%,".") - Q:CNT<1 ; file the results if there is any - D ADD(MDIEN,TYPE,.LINE,CNT) - Q - ; -ADD(MDIEN,TYPE,LINE,CNT) ; - ; Create an entry in the .1 node - N NODE,X - S NODE=$G(^MDD(703.1,MDIEN,.1,0)) Q:NODE="" - S NODE=$P(NODE,"^",3) - S NODE=NODE+1 - S $P(^MDD(703.1,MDIEN,.1,0),"^",3,4)=NODE_"^"_NODE - S $P(^MDD(703.1,MDIEN,.1,NODE,0),"^")=TYPE - D NOW^%DTC - M ^MDD(703.1,MDIEN,.1,NODE)=LINE - Q - ; -MSGIEN(MDHLIENS,MDHLREST) ; Return the message as definded in MDHLIENS to the array in MDHLREST - ; Only TCP type messages - ; input: MDHLIENS= the intern entry number of the message in ^HLMA - ; MDHLREST = the return array that will contain the whole HL7 message - ; output: return "1^Message complete" if message was successful, "0^reason" if failed. - ; - N MDHLIEN,MDHLI,MDHLCNT,MDHLZ,RET - S (MDHLCNT,MDHLI,RET)=0 - I $G(MDHLIENS)="" S RET=RET_"^No IEN defined" Q RET ; Exit because no IEN for ^HLMA was provided - I $G(MDHLREST)="" S RET=RET_"^No Return ARRAY provided" Q RET ; Exit because no return array was provided - I $G(^HLMA(MDHLIENS,0))="" S RET=RET_"^HLMA entry does not exist" Q RET ; Exit because invalid OR non-EXISTING HLMA ENTRY - S MDHLIEN=$P(^HLMA(MDHLIENS,0),U) - I MDHLIEN="" S RET=RET_"^No pointer value to file 772" Q RET ; No Pointer to 772 - I $G(^HL(772,MDHLIEN,0))="" S RET=RET_"^772 Entry does not exist" Q RET ; No 772 entry exist - ;get header - S MDHLZ=$G(^HLMA(MDHLIENS,"MSH",1,0)) - I MDHLZ="" S RET=RET_"^No MSH segment found" Q RET ; No MSH was found - S MDHLCNT=MDHLCNT+1,@MDHLREST@(MDHLCNT)=MDHLZ - S MDHLCNT=MDHLCNT+1,@MDHLREST@(MDHLCNT)="" - ;get body - S MDHLI=0 - F S MDHLI=$O(^HL(772,MDHLIEN,"IN",MDHLI)) Q:'MDHLI D - . S MDHLCNT=MDHLCNT+1 - . S @MDHLREST@(MDHLCNT)=$G(^HL(772,MDHLIEN,"IN",MDHLI,0)) - . Q - I MDHLCNT'>2 S RET=RET_"^No message body found" Q RET ; There was no body - S RET="1^Message complete" - Q RET - ; -CICNV(MDIEN,RETURN) ; This subroutine will read the data in 703.1 and return the results - ;in the indicated global - N NODE,FLG - S FLG=1 - Q:MDIEN="" ; The ien was null - Q:RETURN="" ; the array was null - S ARRAY(0)="0^0" - I $G(^MDD(703.1,MDIEN,.1,0))="" S FLG=0 Q ; There is not data. - ; Start the processing of ICD/POV codes Value is 8 - S NODE=0 - I FLG I $G(^MDD(703.1,MDIEN,.1,0))'="" D - . F S NODE=$O(^MDD(703.1,MDIEN,.1,NODE)) Q:NODE<1 D - . . S TYPE=$P($G(^MDD(703.1,MDIEN,.1,NODE,0),0),"^",1) - . . I TYPE=8 D PROCESS(MDIEN,NODE,TYPE,.ARRAY) - . . I TYPE=7 D PROCESS(MDIEN,NODE,TYPE,.ARRAY) - . . Q - . Q - M @RETURN=ARRAY - Q -PROCESS(MDIEN,NODE,TYPE,ARRAY) ; This will process the data for each - N CNT,X,CONT,CODE,AR,TP,LOC - S CNT=0,CONT=0 - F S CNT=$O(^MDD(703.1,MDIEN,.1,NODE,.2,CNT)) Q:CNT<1 D - . S CODE=$G(^MDD(703.1,MDIEN,.1,NODE,.2,CNT,0),"") ; Grabbing the ICD9 AND CPT codes - . I CODE="" Q - . I TYPE=8 S AR=1,TP="POV",X=$$ICDDX^ICDCODE(CODE) Q:X="" ; Reference DBIA #3990 [Supported] for ICDCODE call - . I TYPE=7 S AR=2,TP="CPT",X=$$CPT^ICPTCOD(CODE) Q:X="" ; Reference DBIA #1995 [Supported] for ICPTCOD to handle CPT Codes call - . S CONT=CONT+1 - . S ARRAY(AR)=CONT_"^"_CONT - . I AR=1 D - . . N DESC,IN,LN - . . S IN=$P(X,"^",1) Q:IN<1 - . . S LN=$G(^ICD9(IN,0),0) Q:LN="" - . . S DESC=$P(LN,"^",3) Q:DESC="" - . . S I=CONT - . . S $P(ARRAY(AR,I),"^",1)=TP - . . S $P(ARRAY(AR,I),"^",2)=$P(X,"^",1) - . . S $P(ARRAY(AR,I),"^",3)=$P(X,"^",2) - . . S $P(ARRAY(AR,I),"^",5)=DESC - . . S $P(ARRAY(AR,I),"^",6)=$S(I=1:1,1:0) - . . Q - . I AR=2 D - . . N DESC,IN,LN - . . S IN=$P(X,"^",1) Q:IN<1 - . . ; S LN=$G(^ICPT(IN,0),0) Q:LN="" - . . S DESC=$P(X,"^",3) Q:DESC="" ; DBIA1995 $$CPT^ICPTCOD(CODE) returns X and the second piece of X is the DESC - . . S I=CNT - . . S $P(ARRAY(AR,I),"^",1)=TP - . . S $P(ARRAY(AR,I),"^",2)=$P(X,"^",1) - . . S $P(ARRAY(AR,I),"^",3)=$P(X,"^",2) - . . S $P(ARRAY(AR,I),"^",5)=DESC - . . S $P(ARRAY(AR,I),"^",7)=$S(I=1:1,1:0) - . . Q - . Q - I $D(ARRAY(1))!$D(ARRAY(2)) S ARRAY(0)="1^1" - Q - ; -NOTICE(SUBJECT,TXT,DEVIEN,DUZ) ; This will fire off a mail message to the Indicated mail group saying that a study was deleted - ; - N INST,MG,XMTO,XMDUZ,XMSUBJ,XMBODY,N,X - S MG=0 - S INST=DEVIEN - I INST>1 S MG=$P($G(^MDS(702.09,INST,0)),"^",2) - I 'MG!('$$MG^MDHL7U2(MG)) S MG=$$FIND1^DIC(3.8,"","BX","MD DEVICE ERRORS") Q:'MG - S MG=$$GET1^DIQ(3.8,+MG_",",.01) - S XMTO="G."_MG_"@"_^XMB("NETNAME"),XMINSTR("FROM")=.5 - S XMBODY="TXT" - S XMSUBJ=SUBJECT - D SENDMSG^XMXAPI(DUZ,XMSUBJ,XMBODY,XMTO,.XMINSTR) - Q - ; -ALERT(MDSIEN) ; This is to send an e-mail to the main device mail group that a study has been deleted - D NOW^%DTC - S SUBJECT="Study "_MDSIEN_" for Patient "_$$GET1^DIQ(702,MDSIEN,.01,"E")_" has been DELETED!" - S BODY(1)="The following study has been deleted." - S BODY(2)=" By the USER: "_$$GET1^DIQ(200,DUZ,.01,"E") - S BODY(3)=" On Date: "_$$FMTE^XLFDT(%,1) - S BODY(4)=" " - S BODY(5)=" CP Study Information" - S BODY(6)="------------------------------------------------------------------------------ " - S BODY(7)="CP Study ID: "_MDSIEN - S BODY(8)="CP Study Def: "_$$GET1^DIQ(702,MDSIEN,.04,"E") - S BODY(9)="Created on: "_$$FMTE^XLFDT($$GET1^DIQ(702,MDSIEN,.02,"I"),1) - S BODY(10)="Created by: "_$$GET1^DIQ(702,MDSIEN,.03,"E") - S BODY(11)="On Instrument: "_$$GET1^DIQ(702,MDSIEN,.11,"E") - S BODY(12)="For Patient: "_$$GET1^DIQ(702,MDSIEN,.01,"E") - S BODY(13)=" SSN: "_$E($$GET1^DIQ(702,MDSIEN,.011,"E"),6,9) - S BODY(14)=" DOB: "_$$FMTE^XLFDT($$GET1^DIQ(702,MDSIEN,.012,"I"),1) - S DEVIEN=$$GET1^DIQ(702,MDSIEN,.11,"I") - Q +MDHL7U3 ; HOIFO/WAA -Utilities for CP to process HL7 messages ; 7/26/00 + ;;1.0;CLINICAL PROCEDURES;;Apr 01, 2004 + ; Reference DBIA #4262 [Supported] for HL7 call. + ; +PURGE(MDD7031) ; + ; This sub-routine will delete HL7 772 Message text after a message + ; been processed by Imaging. + Q:'$D(^MDD(703.1,MDD7031,0)) ; No entry found + S MDD772=$P(^MDD(703.1,MDD7031,0),U,6) Q:MDD772="" + D DELBODY^HLUOPT2(MDD772,"CLINICAL PROCEDURES message purge","^TMP($J,""IN"")") + S $P(^MDD(703.1,MDD7031,0),U,6)="" + Q diff --git a/r/CLINICAL_PROCEDURES-MD/MDHL7X.m b/r/CLINICAL_PROCEDURES-MD/MDHL7X.m index 2b56aba1..f4015e70 100644 --- a/r/CLINICAL_PROCEDURES-MD/MDHL7X.m +++ b/r/CLINICAL_PROCEDURES-MD/MDHL7X.m @@ -1,34 +1,34 @@ -MDHL7X ; HOIFO/WAA -Generate HL7 Error Message ; 06/08/00 - ;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102 - ; Reference IA #1131 for ^XMB("NETNAME") access. - ; Reference IA #2165 for HLMA1 calls. - ; Reference IA #2729 for XMXAPI calls. - D GENERR,GENACK Q -GENERR ; Generate error message - N TXT,INST,MG,XMTO,XMDUZ,XMSUBJ,XMBODY,N,X S MG=0 - S INST=DEVIEN - I INST>1 S MG=$P($G(^MDS(702.09,INST,0)),"^",2) - I 'MG!('$$MG^MDHL7U2(MG)) S MG=$$FIND1^DIC(3.8,"","BX","MD DEVICE ERRORS") Q:'MG - S MG=$$GET1^DIQ(3.8,+MG_",",.01) - S XMTO="G."_MG_"@"_^XMB("NETNAME"),XMINSTR("FROM")=.5 - I '$D(X) S X=$G(ECODE(0)) - S TXT(1)=ERRTX,TXT(2)=X,TXT(3)=" " - S N=3 - I '$G(ECODE,1) D ; This is to process Device errors - . N X - . S X=0 - . F S X=$O(ECODE(X)) Q:X<1 S N=N+1,TXT(N)=ECODE(X) - . S N=N+1,TXT(N)=" " - . Q - F X="MSH","PID","OBR","OBX" I $D(SEG(X)) S N=N+1,TXT(N)=SEG(X) - S XMSUBJ="A Clinical Instrument HL7 Error has occurred." - S XMBODY="TXT" - D SENDMSG^XMXAPI(DUZ,XMSUBJ,XMBODY,XMTO,.XMINSTR) - Q -GENACK ; Generate an HL7 ACK message - ; Reference IA #2165 for GENACK^HLMA1 call - N HLA,HLEID,HLEIDS,HLARYTYP,HLFORMAT,HLRESLTA - S HLA("HLA",1)="MSA"_HL("FS")_$S($D(ERRTX):"AR",1:"AA")_HL("FS")_HL("MID")_$S($D(ERRTX):HL("FS")_ERRTX,1:"") - S HLEID=HL("EID"),HLEIDS=HL("EIDS"),HLARYTYP="LM",HLFORMAT=1,HLRESLTA=HL("MID") - D GENACK^HLMA1(HLEID,HLMTIENS,HLEIDS,HLARYTYP,HLFORMAT,.HLRESTLA) - N ERRTX Q +MDHL7X ; HOIFO/WAA -Generate HL7 Error Message ; 06/08/00 + ;;1.0;CLINICAL PROCEDURES;;Apr 01, 2004 + ; Reference IA #1131 for ^XMB("NETNAME") access. + ; Reference IA #2165 for HLMA1 calls. + ; Reference IA #2729 for XMXAPI calls. + D GENERR,GENACK Q +GENERR ; Generate error message + N TXT,INST,MG,XMTO,XMDUZ,XMSUBJ,XMBODY,N,X S MG=0 + S INST=DEVIEN + I INST>1 S MG=$P($G(^MDS(702.09,INST,0)),"^",2) + I 'MG!('$$MG^MDHL7U2(MG)) S MG=$$FIND1^DIC(3.8,"","BX","MD DEVICE ERRORS") Q:'MG + S MG=$$GET1^DIQ(3.8,+MG_",",.01) + S XMTO="G."_MG_"@"_^XMB("NETNAME"),XMINSTR("FROM")=.5 + I '$D(X) S X=ECODE(0) + S TXT(1)=ERRTX,TXT(2)=X,TXT(3)=" " + S N=3 + I 'ECODE D ; This is to process Device errors + . N X + . S X=0 + . F S X=$O(ECODE(X)) Q:X<1 S N=N+1,TXT(N)=ECODE(X) + . S N=N+1,TXT(N)=" " + . Q + F X="MSH","PID","OBR","OBX" I $D(SEG(X)) S N=N+1,TXT(N)=SEG(X) + S XMSUBJ="A Clinical Instrument HL7 Error has occurred." + S XMBODY="TXT" + D SENDMSG^XMXAPI(DUZ,XMSUBJ,XMBODY,XMTO,.XMINSTR) + Q +GENACK ; Generate an HL7 ACK message + ; Reference IA #2165 for GENACK^HLMA1 call + N HLA,HLEID,HLEIDS,HLARYTYP,HLFORMAT,HLRESLTA + S HLA("HLA",1)="MSA"_HL("FS")_$S($D(ERRTX):"AR",1:"AA")_HL("FS")_HL("MID")_$S($D(ERRTX):HL("FS")_ERRTX,1:"") + S HLEID=HL("EID"),HLEIDS=HL("EIDS"),HLARYTYP="LM",HLFORMAT=1,HLRESLTA=HL("MID") + D GENACK^HLMA1(HLEID,HLMTIENS,HLEIDS,HLARYTYP,HLFORMAT,.HLRESTLA) + N ERRTX Q diff --git a/r/CLINICAL_PROCEDURES-MD/MDRPCOG.m b/r/CLINICAL_PROCEDURES-MD/MDRPCOG.m index 65921e15..f19a9627 100644 --- a/r/CLINICAL_PROCEDURES-MD/MDRPCOG.m +++ b/r/CLINICAL_PROCEDURES-MD/MDRPCOG.m @@ -1,175 +1,169 @@ -MDRPCOG ; HOIFO/DP - CP Gateway ; [01-09-2003 15:20] - ;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102 - ; Description: - ; This is the main routine that manages the CLINICAL PROCEDURES Gateway functions. - ; Access to these functions is controlled via the MD GATEWAY RPC. - ; - ; Integration Agreements: - ; IA# 10097 [Supported] %ZOSV calls - ; IA# 10103 [Supported] Calls to XLFDT - ; IA# 2263 [Supported] Calls to XPAR - ; -CLEANUP ; [Procedure] Cleanup a past results report - F X=0:0 S X=$O(^MDD(703.1,DATA,.1,X)) Q:'X D - .S:$G(^MDD(703.1,DATA,.1,X,.1))]"" MDFDA(703.11,X_","_DATA_",",.1)="@" - .S:$O(^MDD(703.1,DATA,.1,X,.2,0)) MDFDA(703.11,X_","_DATA_",",.2)="@" - D:$D(MDFDA) FILE^DIE("K","MDFDA","MDERR") - I $D(MDERR) D ERROR^MDRPCU(RESULTS,.MDERR) Q - ; Manual cleanup of the empty UNC nodes and WP root - F X=0:0 S X=$O(^MDD(703.1,DATA,.1,X)) Q:'X D - .K ^MDD(703.1,DATA,.1,X,.1) - .K ^MDD(703.1,DATA,.1,X,.2) - S @RESULTS@(0)="1^Item purged" - Q - ; -DONE ; [Procedure] Done processing, Mark study status - S MDFDA(703.1,+DATA_",",.09)=$G(P1,"U") - D FILE^DIE("","MDFDA") - Q - ; -GETATT ; [Procedure] Get attachments for study - F X=0:0 S X=$O(^MDD(703.1,+DATA,.1,X)) Q:'X D - .S Y=+$O(@RESULTS@(""),-1)+1 - .S @RESULTS@(Y)="703.11;"_X_U_^MDD(703.1,+DATA,.1,X,0) - S @RESULTS@(0)=+$O(@RESULTS@(""),-1) - Q - ; -GETOLD ; [Procedure] Returns old results by date - ; Variables: - ; LOGDATE: [Private] Loop variable - ; STOPDATE: [Private] Date to stop retrieving entries - ; - ; New private variables - NEW LOGDATE,STOPDATE,MDX - S LOGDATE=+DATA,STOPDATE=+$P(DATA,U,2)+.2359 - F S LOGDATE=$O(^MDD(703.1,"ADTP",LOGDATE)) W !,"-->",LOGDATE Q:'LOGDATE!(LOGDATE>STOPDATE) D Q:Y>50 - .F MDX=0:0 S MDX=$O(^MDD(703.1,"ADTP",LOGDATE,MDX)) Q:'MDX D - ..I '$$CHECK(MDX) Q - ..S Y=$O(@RESULTS@(""),-1)+1 - ..S @RESULTS@(Y)="703.1;"_MDX_U_$G(^MDD(703.1,MDX,0)) - S:'LOGDATE!(LOGDATE>STOPDATE) LOGDATE=STOPDATE - S @RESULTS@(0)=+$O(@RESULTS@(""),-1)_U_LOGDATE_U_$$FMTE^XLFDT(LOGDATE) - Q - ; -GETPAR ; [Procedure] Get a parameter value for an RPC Call - S @RESULTS@(0)=$$PARVAL(DATA) - Q - ; -GETTXT ; [Procedure] Get attachment text for processing - N X,STUDY,ATT - S X=0,STUDY=$P(DATA,",",2),ATT=+DATA - I '$O(^MDD(703.1,STUDY,.1,ATT,.2,0)) S @RESULTS@(0)="-1^No Data" Q - F S X=$O(^MDD(703.1,STUDY,.1,ATT,.2,X)) Q:'X S @RESULTS@(X)=^(X,0) - S @RESULTS@(0)=+$O(@RESULTS@(""),-1) - Q - ; -NEXT ; [Procedure] Get the next study to process - S Y=+$O(^MDD(703.1,"ASTATUS","P",$G(DATA))) - S @RESULTS@(0)=$S($D(^MDD(703.1,Y,0)):"703.1;"_Y_U_^MDD(703.1,Y,0),1:0) - Q - ; -PARVAL(INSTANCE) ; [Procedure] Extrinsic get of parameter values - ; Input parameters - ; 1. INSTANCE [Literal/Required] XPAR instance - ; - Q $$GET^XPAR("SYS","MD GATEWAY",INSTANCE) - ; -POLL ; [Procedure] Returns server time and flag for studies to process - I $$PARVAL("Shutdown Flag")]"" D Q - .S @RESULTS@(0)="-1^SHUTDOWN" - .D SETPAR("Shutdown Flag","") - S @RESULTS@(0)=$$FMTE^XLFDT($$NOW^XLFDT) - S @RESULTS@(1)=$D(^MDD(703.1,"ASTATUS","P")) - Q - ; -POLLER(RESULTS) ; [Procedure] Non-Disk activity poller - ; With the exception of a shutdown request pending, this stand alone RPC will operate - ; without creating any disk activity and not crash during backup operations on the main - ; VistA server. - ; - ; Input parameters - ; 1. RESULTS [Reference/Required] - ; - I $$PARVAL("Shutdown Flag")]"" D Q - .S RESULTS(0)="-1^SHUTDOWN" - .D SETPAR("Shutdown Flag","") - S RESULTS(0)=$$FMTE^XLFDT($$NOW^XLFDT) - S RESULTS(1)=$D(^MDD(703.1,"ASTATUS","P")) - Q - ; -RPC(RESULTS,OPTION,DATA,P1) ; [Procedure] - ; Input parameters - ; 1. RESULTS [Literal/Required] RPC Return Array - ; 2. OPTION [Literal/Required] Gateway Option to execute - ; 3. DATA [Literal/Required] Other information - ; 4. P1 [Literal/Required] Overflow variable - ; - ; Variables: - ; MDENV: [Private] Server environment variable - ; MDERR: [Private] Fileman return array - ; MDFDA: [Private] Fileman FDA - ; - ; New private variables - NEW MDENV,MDERR,MDFDA - S RESULTS=$NA(^TMP("MDRPCOB",$J)) K @RESULTS - D @OPTION - Q - ; -RUNNING ; [Procedure] Returns 0/1 and message on running status - ; Note: If lock CAN be obtained, then gateway is NOT running - L +^MDD("CPGATEWAY"):1 E S @RESULTS@(0)="1^RUNNING" Q - L -(^MDD("CPGATEWAY")) S @RESULTS@(0)="0^NOT RUNNING" - Q - ; -SETFILE ; [Procedure] Set filename of new attachment - S MDFDA(703.11,$P(DATA,U,1),.02)=$P(DATA,U,2) - D FILE^DIE("","MDFDA") - Q - ; -SETPAR(INSTANCE,VALUE) ; [Procedure] Set value into XPAR parameter - ; Input parameters - ; 1. INSTANCE [Literal/Required] Parameter Instance - ; 2. VALUE [Literal/Required] Parameter Value - ; - D EN^XPAR("SYS","MD GATEWAY",INSTANCE,VALUE) - Q - ; -START ; [Procedure] Can we begin? - ; Ensure only one Gateway per system by locking the phantom global node - L +^MDD("CPGATEWAY"):1 - I '$T D STATUS S @RESULTS@(0)="-1^FAIL" Q - ; Clear all process settings - D NDEL^XPAR("SYS","MD GATEWAY") - S DATA=$G(DATA,"30^1000") ; Default poll interval and log entries - D SETPAR("Polling Interval",+$P(DATA,U,1)) - D SETPAR("Maximum Log Entries",+$P(DATA,U,2)) - D SETPAR("Job ID",$J) - D SETPAR("Started At",$$FMTE^XLFDT($$NOW^XLFDT)) - D SETPAR("Started By",$$GET1^DIQ(200,DUZ_",",.01)) - D GETENV^%ZOSV S MDENV=Y - D SETPAR("UCI",$P(MDENV,U,1)) - D SETPAR("Volume",$P(MDENV,U,2)) - D SETPAR("Node",$P(MDENV,U,3)) - D SETNM^%ZOSV("CP Gateway") - S @RESULTS@(0)="1^OK" - Q - ; -STATUS ; [Procedure] Return status of BP - D GETLST^XPAR(.MDRET,"SYS","MD GATEWAY","Q") - F X=0:0 S X=$O(MDRET(X)) Q:'X S @RESULTS@(X)=MDRET(X) - Q - ; -STOP ; [Procedure] Flag client to stop via cal to POLL - D SETPAR("Shutdown Flag","Yes") - Q - ; -XFERDIR ; [Procedure] Return Imaging xfer directory - S @RESULTS@(0)=$$GET^XPAR("SYS","MD IMAGING XFER") - Q - ; -CHECK(MDRI) ; Check if Upload Value and Upload Text has already been purged. - N MDFLG S MDFLG=0 - F X=0:0 S X=$O(^MDD(703.1,MDRI,.1,X)) Q:'X D Q:MDFLG - .S:$G(^MDD(703.1,MDRI,.1,X,.1))]"" MDFLG=1 - .S:$O(^MDD(703.1,MDRI,.1,X,.2,0)) MDFLG=1 - Q MDFLG +MDRPCOG ; HOIFO/DP - CP Gateway ; [01-09-2003 15:20] + ;;1.0;CLINICAL PROCEDURES;;Apr 01, 2004 + ; Description: + ; This is the main routine that manages the CLINICAL PROCEDURES Gateway functions. + ; Access to these functions is controlled via the MD GATEWAY RPC. + ; + ; Integration Agreements: + ; IA# 10097 [Supported] %ZOSV calls + ; IA# 10103 [Supported] Calls to XLFDT + ; IA# 2263 [Supported] Calls to XPAR + ; +CLEANUP ; [Procedure] Cleanup a past results report + F X=0:0 S X=$O(^MDD(703.1,DATA,.1,X)) Q:'X D + .S:$G(^MDD(703.1,DATA,.1,X,.1))]"" MDFDA(703.11,X_","_DATA_",",.1)="@" + .S:$O(^MDD(703.1,DATA,.1,X,.2,0)) MDFDA(703.11,X_","_DATA_",",.2)="@" + D:$D(MDFDA) FILE^DIE("K","MDFDA","MDERR") + I $D(MDERR) D ERROR^MDRPCU(RESULTS,.MDERR) Q + ; Manual cleanup of the empty UNC nodes and WP root + F X=0:0 S X=$O(^MDD(703.1,DATA,.1,X)) Q:'X D + .K ^MDD(703.1,DATA,.1,X,.1) + .K ^MDD(703.1,DATA,.1,X,.2) + S @RESULTS@(0)="1^Item purged" + Q + ; +DONE ; [Procedure] Done processing, Mark study status + S MDFDA(703.1,+DATA_",",.09)=$G(P1,"U") + D FILE^DIE("","MDFDA") + Q + ; +GETATT ; [Procedure] Get attachments for study + F X=0:0 S X=$O(^MDD(703.1,+DATA,.1,X)) Q:'X D + .S Y=+$O(@RESULTS@(""),-1)+1 + .S @RESULTS@(Y)="703.11;"_X_U_^MDD(703.1,+DATA,.1,X,0) + S @RESULTS@(0)=+$O(@RESULTS@(""),-1) + Q + ; +GETOLD ; [Procedure] Returns old results by date + ; Variables: + ; LOGDATE: [Private] Loop variable + ; STOPDATE: [Private] Date to stop retrieving entries + ; + ; New private variables + NEW LOGDATE,STOPDATE,MDX + S LOGDATE=+DATA,STOPDATE=+$P(DATA,U,2)+.2359 + F S LOGDATE=$O(^MDD(703.1,"ADTP",LOGDATE)) W !,"-->",LOGDATE Q:'LOGDATE!(LOGDATE>STOPDATE) D Q:Y>50 + .F MDX=0:0 S MDX=$O(^MDD(703.1,"ADTP",LOGDATE,MDX)) Q:'MDX D + ..I '$$CHECK(MDX) Q + ..S Y=$O(@RESULTS@(""),-1)+1 + ..S @RESULTS@(Y)="703.1;"_MDX_U_$G(^MDD(703.1,MDX,0)) + S:'LOGDATE!(LOGDATE>STOPDATE) LOGDATE=STOPDATE + S @RESULTS@(0)=+$O(@RESULTS@(""),-1)_U_LOGDATE_U_$$FMTE^XLFDT(LOGDATE) + Q + ; +GETPAR ; [Procedure] Get a parameter value for an RPC Call + S @RESULTS@(0)=$$PARVAL(DATA) + Q + ; +GETTXT ; [Procedure] Get attachment text for processing + N X,STUDY,ATT + S X=0,STUDY=$P(DATA,",",2),ATT=+DATA + I '$O(^MDD(703.1,STUDY,.1,ATT,.2,0)) S @RESULTS@(0)="-1^No Data" Q + F S X=$O(^MDD(703.1,STUDY,.1,ATT,.2,X)) Q:'X S @RESULTS@(X)=^(X,0) + S @RESULTS@(0)=+$O(@RESULTS@(""),-1) + Q + ; +NEXT ; [Procedure] Get the next study to process + S Y=+$O(^MDD(703.1,"ASTATUS","P",$G(DATA))) + S @RESULTS@(0)=$S($D(^MDD(703.1,Y,0)):"703.1;"_Y_U_^MDD(703.1,Y,0),1:0) + Q + ; +PARVAL(INSTANCE) ; [Procedure] Extrinsic get of parameter values + ; Input parameters + ; 1. INSTANCE [Literal/Required] XPAR instance + ; + Q $$GET^XPAR("SYS","MD GATEWAY",INSTANCE) + ; +POLL ; [Procedure] Returns server time and flag for studies to process + I $$PARVAL("Shutdown Flag")]"" D Q + .S @RESULTS@(0)="-1^SHUTDOWN" + .D SETPAR("Shutdown Flag","") + S @RESULTS@(0)=$$FMTE^XLFDT($$NOW^XLFDT) + S @RESULTS@(1)=$D(^MDD(703.1,"ASTATUS","P")) + Q + ; +POLLER(RESULTS) ; [Procedure] Non-Disk activity poller + ; With the exception of a shutdown request pending, this stand alone RPC will operate + ; without creating any disk activity and not crash during backup operations on the main + ; VistA server. + ; + ; Input parameters + ; 1. RESULTS [Reference/Required] + ; + I $$PARVAL("Shutdown Flag")]"" D Q + .S RESULTS(0)="-1^SHUTDOWN" + .D SETPAR("Shutdown Flag","") + S RESULTS(0)=$$FMTE^XLFDT($$NOW^XLFDT) + S RESULTS(1)=$D(^MDD(703.1,"ASTATUS","P")) + Q + ; +RPC(RESULTS,OPTION,DATA,P1) ; [Procedure] + ; Input parameters + ; 1. RESULTS [Literal/Required] RPC Return Array + ; 2. OPTION [Literal/Required] Gateway Option to execute + ; 3. DATA [Literal/Required] Other information + ; 4. P1 [Literal/Required] Overflow variable + ; + ; Variables: + ; MDENV: [Private] Server environment variable + ; MDERR: [Private] Fileman return array + ; MDFDA: [Private] Fileman FDA + ; + ; New private variables + NEW MDENV,MDERR,MDFDA + S RESULTS=$NA(^TMP("MDRPCOB",$J)) K @RESULTS + D @OPTION + Q + ; +SETFILE ; [Procedure] Set filename of new attachment + S MDFDA(703.11,$P(DATA,U,1),.02)=$P(DATA,U,2) + D FILE^DIE("","MDFDA") + Q + ; +SETPAR(INSTANCE,VALUE) ; [Procedure] Set value into XPAR parameter + ; Input parameters + ; 1. INSTANCE [Literal/Required] Parameter Instance + ; 2. VALUE [Literal/Required] Parameter Value + ; + D EN^XPAR("SYS","MD GATEWAY",INSTANCE,VALUE) + Q + ; +START ; [Procedure] Can we begin? + ; Ensure only one Gateway per system by locking the phantom global node + L +^MDD("CPGATEWAY"):1 + I '$T D STATUS S @RESULTS@(0)="-1^FAIL" Q + ; Clear all process settings + D NDEL^XPAR("SYS","MD GATEWAY") + S DATA=$G(DATA,"30^1000") ; Default poll interval and log entries + D SETPAR("Polling Interval",+$P(DATA,U,1)) + D SETPAR("Maximum Log Entries",+$P(DATA,U,2)) + D SETPAR("Job ID",$J) + D SETPAR("Started At",$$FMTE^XLFDT($$NOW^XLFDT)) + D SETPAR("Started By",$$GET1^DIQ(200,DUZ_",",.01)) + D GETENV^%ZOSV S MDENV=Y + D SETPAR("UCI",$P(MDENV,U,1)) + D SETPAR("Volume",$P(MDENV,U,2)) + D SETPAR("Node",$P(MDENV,U,3)) + D SETNM^%ZOSV("CP Gateway") + S @RESULTS@(0)="1^OK" + Q + ; +STATUS ; [Procedure] Return status of BP + D GETLST^XPAR(.MDRET,"SYS","MD GATEWAY","Q") + F X=0:0 S X=$O(MDRET(X)) Q:'X S @RESULTS@(X)=MDRET(X) + Q + ; +STOP ; [Procedure] Flag client to stop via cal to POLL + D SETPAR("Shutdown Flag","Yes") + Q + ; +XFERDIR ; [Procedure] Return Imaging xfer directory + S @RESULTS@(0)=$$GET^XPAR("SYS","MD IMAGING XFER") + Q + ; +CHECK(MDRI) ; Check if Upload Value and Upload Text has already been purged. + N MDFLG S MDFLG=0 + F X=0:0 S X=$O(^MDD(703.1,MDRI,.1,X)) Q:'X D Q:MDFLG + .S:$G(^MDD(703.1,MDRI,.1,X,.1))]"" MDFLG=1 + .S:$O(^MDD(703.1,MDRI,.1,X,.2,0)) MDFLG=1 + Q MDFLG diff --git a/r/CLINICAL_PROCEDURES-MD/MDRPCOP.m b/r/CLINICAL_PROCEDURES-MD/MDRPCOP.m index 5c4e372f..451fe3a2 100644 --- a/r/CLINICAL_PROCEDURES-MD/MDRPCOP.m +++ b/r/CLINICAL_PROCEDURES-MD/MDRPCOP.m @@ -1,225 +1,240 @@ -MDRPCOP ; HOIFO/DP - Object RPCs (TMDPatient) ;3/12/08 09:16 - ;;1.0;CLINICAL PROCEDURES;**4,6**;Apr 01, 2004;Build 102 - ; Integration Agreements: - ; IA# 2263 [Supported] XPAR calls - ; IA# 3027 [Supported] Calls to DGSEC4 - ; IA# 2981 [Subscription] Calls to GUI~GMRCP5 - ; IA# 2548 [Supported] ACRP Interface Toolkit APIs. - ; IA# 2552 [Supported] AIT API to provide outpatient encounter data. - ; IA# 10061 [Supported] VADPT calls. - ; IA# 3468 [Subscription] Use GMRCCP APIs. - ; IA# 10103 [Supported] Call to XLFDT - ; IA# 10039 [Supported] Ward Location File (#42) Access. - ; IA# 10035 [Supported] DPT references - ; IA# 3613 [Private] GETVST^MDRPCOP API call - ; IA# 10099 [Supported] GMRADPT call - ; IA# 1096 [Controlled Subscription] ^DGPM("ATID1" x-ref loop - ; IA# 358 [Controlled Subscription] FILE 405 references - ; -ADD(X) ; [Procedure] Add line to @RESULTS@(... - S @RESULTS@(+$O(@RESULTS@(""),-1)+1)=X - Q - ; -ALLERGY ; [Procedure] Return Allergies - D EN1^GMRADPT I '$O(GMRAL(0)) D Q - .I $G(GMRAL)="" S @RESULTS@(0)="No Allergy Assessment" - .I $G(GMRAL)=0 S @RESULTS@(0)="No Known Allergies" - S @RESULTS@(0)="This patient has the following allergy(ies): " - F X=0:0 S X=$O(GMRAL(X)) Q:'X D - .S @RESULTS@(X)=$P($G(GMRAL(X)),U,2) - Q - ; -CHKIN ; [Procedure] Check In Study - F X=2:1:5 D - .I $P(DATA,U,X)]"" S MDFDA(702,$P(DATA,U,1),$P("^.04^.05^.11^.07",U,X))=$P(DATA,U,X) - S MDFDA(702,$P(DATA,U,1),.09)=4 ; Status = Checked-In - I $P(DATA,U,1)="+1," D - .S MDFDA(702,"+1,",.01)=DFN - .S MDFDA(702,"+1,",.02)=$$NOW^XLFDT() - .S MDFDA(702,"+1,",.03)=DUZ - .D UPDATE^DIE("","MDFDA","MDIEN","MDERR") Q:$D(MDERR) - .S MDIENS=MDIEN(1)_",",MDHL7=$$SUB^MDHL7B(MDIEN(1)) - .I +MDHL7=-1 S MDFDA(702,MDIENS,.09)=2,MDFDA(702,MDIENS,.08)=$P(MDHL7,U,2) - .I +MDHL7=1 S MDFDA(702,MDIENS,.09)=5,MDFDA(702,MDIENS,.08)="" - .D:$D(MDFDA) FILE^DIE("","MDFDA","MDERR") - I $P(DATA,U,1)'="+1," D - .D FILE^DIE("","MDFDA","MDERR") Q:$D(MDERR) - .S MDIENS=+DATA_"," - .S MDHL7=$$SUB^MDHL7B(+MDIENS) - .I +MDHL7=-1 S MDFDA(702,MDIENS,.09)=2,MDFDA(702,MDIENS,.08)=$P(MDHL7,U,2) - .I +MDHL7=1 S MDFDA(702,MDIENS,.09)=5,MDFDA(702,MDIENS,.08)="" - .D:$D(MDFDA) FILE^DIE("","MDFDA","MDERR") - ; Patch 6 - Renal Check-In - D:+$G(MDIENS) - .S X=+$P(^MDD(702,+MDIENS,0),U,4) Q:'X - .I $P(^MDS(702.01,X,0),U,6)=2 D Q ; Renal Check-In - ..D CP^MDKUTLR(+MDIENS) - ..S MDFDA(702,+MDIENS_",",.09)=5 - ..D FILE^DIE("","MDFDA","MDERR") - ; Patch 6 - Renal Check-In - I '$D(MDERR) S @RESULTS@(0)="1^OK" Q - D ERROR^MDRPCU(RESULTS,.MDERR) - Q - ; -DISPCON ; [Procedure] Display a consult - K ^TMP("GMRC",$J) - D GUI^GMRCP5(.RESULTS,DATA) - Q - ; -GETCONS ; [Procedure] Get available consults for patient - K ^TMP("MDTMP",$J) N MDCDT,MDDY,X1,X2,X - S MDDY=$$GET^XPAR("SYS","MD COMPL PROC DISPLAY DAYS",1) - S X1=DT,X2=-$S(MDDY>0:+MDDY,1:365) D C^%DTC S MDCDT=X - D CPLIST^GMRCCP(DFN,,$NA(^TMP("MDTMP",$J))) - S MDX=0 - F S MDX=$O(^TMP("MDTMP",$J,MDX)) Q:'MDX D:"saprc"[$P(^(MDX),U,4) - .S Y="123;"_$P(^TMP("MDTMP",$J,MDX),U,5) - .I $P($G(^TMP("MDTMP",$J,MDX)),U,4)="c" Q:$P($G(^TMP("MDTMP",$J,MDX)),U,1)0 S X1=DT,X2=-MDNUM D C^%DTC S MDCOM=X - D CPLIST^GMRCCP(DFN,,$NA(^TMP("MDTMP",$J))) - S X1=DT,X2=-365 D C^%DTC S MDCDT=X - S MDX=0 F S MDX=$O(^TMP("MDTMP",$J,MDX)) Q:'MDX D:"saprc"[$P(^(MDX),U,4) - .I $P($G(^TMP("MDTMP",$J,MDX)),U,4)="c" Q:$P($G(^TMP("MDTMP",$J,MDX)),U,1)NOW D ; get future encounters, past cancels/no-shows from VADPT - .S VASD("F")=BEG - .S VASD("T")=END - .S VASD("W")="123456789" - .D SDA^VADPT - .S I=0 F S I=$O(^UTILITY("VASD",$J,I)) Q:'I D - ..S XI=^UTILITY("VASD",$J,I,"I"),XE=^("E") - ..S DTM=$P(XI,U),IEN=$P(XI,U,2),STI=$P(XI,U,3) - ..S LOC=$P(XE,U,2),STS=$P(XE,U,3) - ..I DTMNOW D ;past encounters from ACRP Toolkit - set in CALLBACK - .S BDT=BEG - .S EDT=$S(END0 D Q:DONE - .S MOV=0 F S MOV=$O(^DGPM("ATID1",DFN,TIM,MOV)) Q:MOV'>0 D Q:DONE - ..D GETS^DIQ(405,+MOV_",","*","IE","MDX0") S MTIM=$G(MDX0(405,MOV_",",".01","I")) - ..S XTYP=$G(MDX0(405,+MOV_",",".04","E")) - ..S XLOC=$G(MDX0(405,+MOV_",",".06","E")) - ..S XLOCI=+$G(MDX0(405,+MOV_",",".06","I")),HLOC=+$G(^DIC(42,+XLOCI,44)) - ..S MDLST(MTIM,"I",1)="I;"_MTIM_";"_HLOC_U_MTIM_U_"Inpatient Stay"_U_XLOC_U_XTYP - ..S DONE=1 ; Not sure if I should include all stays - S I=0 F S I=$O(MDLST(I)) Q:'I D - .S J="" F S J=$O(MDLST(I,J)) Q:J="" D - ..S K=0 F S K=$O(MDLST(I,J,K)) Q:'K D - ...S @RESULTS@($O(@RESULTS@(""),-1)+1)=MDLST(I,J,K) - S:$G(DFN)="" DFN=MDTDF S @RESULTS@(0)=+$O(@RESULTS@(""),-1)_U_($$GET1^DIQ(2,DFN_",",.1)]"") - Q - ; -GETBEG() ; Get Beginning Date Range - I $$GET^XPAR("SYS","MD APPOINT START DATE",1)>1 Q "T-"_$$GET^XPAR("SYS","MD APPOINT START DATE",1) - Q "T-200" -GETEND() ; Get Ending Date Range - I $$GET^XPAR("SYS","MD APPOINT END DATE",1)>1 Q "T+"_$$GET^XPAR("SYS","MD APPOINT END DATE",1) - Q "T" -LOGSEC ; [Procedure] Log Security - N RES - D NOTICE^DGSEC4(.RES,DFN,DATA,1) - S @RESULTS@(0)=$S(+RES:"1^Logged",1:"-1^Unable to log") - Q - ; -RPC(RESULTS,OPTION,DFN,DATA) ; [Procedure] Main RPC call tag - NEW DFNIENS,GMRAL,GMVALG,GN,IENS,MDDFN,MDERR,MDFDA,MDFLD,MDHL7,MDID,MDIDS,MDIEN,MDIENS,MDRET,MDX,MDY,VA,VADM,VAERR,VAIN,Z - S RESULTS=$NA(^TMP($J)) K @RESULTS - D:$T(@OPTION)]"" @OPTION - D:'$D(@RESULTS) BADRPC^MDRPCU("MD TMDPATIENT","MDRPCOP",OPTION) - D CLEAN^DILF - Q - ; -SELECT ; [Procedure] Select patient - ; Moved to continuation routine at MD*1.0*6 due to routine size - D SELECT^MDRPCOP1 - Q - ; -X2FM(X) ; [Function] return FM date given relative date - N %DT S %DT="TS" D ^%DT - Q Y - ; +MDRPCOP ; HOIFO/DP - Object RPCs (TMDPatient) ; [01-09-2003 15:21] + ;;1.0;CLINICAL PROCEDURES;**4**;Apr 01, 2004;Build 3 + ; Integration Agreements: + ; IA# 3027 [Supported] Calls to DGSEC4 + ; IA# 2981 [Subscription] Calls to GUI~GMRCP5 + ; IA# 2548 [Supported] ACRP Interface Toolkit APIs. + ; IA# 2552 [Supported] AIT API to provide outpatient encounter data. + ; IA# 10061 [Supported] VADPT calls. + ; IA# 3468 [Subscription] Use GMRCCP APIs. + ; IA# 3266 [Subscription] Call to DPTLK1 + ; IA# 10103 [Supported] Call to XLFDT + ; IA# 10039 [Supported] Ward Location File (#42) Access. + ; IA# 10035 [Supported] DPT references + ; IA# 3267 [Subscription] Call to DPTLK1 + ; IA# 3593 [Supported] Access to routine DPTLK6 utilities for lookup + ; IA# 3613 [Private] GETVST^MDRPCOP API call + ; IA# 10099 [Supported] GMRADPT call + ; IA# 1096 [Controlled Subscription] ^DGPM("ATID1" x-ref loop + ; +ADD(X) ; [Procedure] Add line to @RESULTS@(... + S @RESULTS@(+$O(@RESULTS@(""),-1)+1)=X + Q + ; +ALLERGY ; [Procedure] Return Allergies + D EN1^GMRADPT I '$O(GMRAL(0)) D Q + .I $G(GMRAL)="" S @RESULTS@(0)="No Allergy Assessment" + .I $G(GMRAL)=0 S @RESULTS@(0)="No Known Allergies" + S @RESULTS@(0)="This patient has the following allergy(ies): " + F X=0:0 S X=$O(GMRAL(X)) Q:'X D + .S @RESULTS@(X)=$P($G(GMRAL(X)),U,2) + Q + ; +CHKIN ; [Procedure] Check In Study + F X=2:1:5 D + .I $P(DATA,U,X)]"" S MDFDA(702,$P(DATA,U,1),$P("^.04^.05^.11^.07",U,X))=$P(DATA,U,X) + S MDFDA(702,$P(DATA,U,1),.09)=4 ; Status = Checked-In + I $P(DATA,U,1)="+1," D + .S MDFDA(702,"+1,",.01)=DFN + .S MDFDA(702,"+1,",.02)=$$NOW^XLFDT() + .S MDFDA(702,"+1,",.03)=DUZ + .D UPDATE^DIE("","MDFDA","MDIEN","MDERR") Q:$D(MDERR) + .S MDIENS=MDIEN(1)_",",MDHL7=$$SUB^MDHL7B(MDIEN(1)) + .I +MDHL7=-1 S MDFDA(702,MDIENS,.09)=2,MDFDA(702,MDIENS,.08)=$P(MDHL7,U,2) + .I +MDHL7=1 S MDFDA(702,MDIENS,.09)=5,MDFDA(702,MDIENS,.08)="" + .D:$D(MDFDA) FILE^DIE("","MDFDA","MDERR") + I $P(DATA,U,1)'="+1," D + .D FILE^DIE("","MDFDA","MDERR") Q:$D(MDERR) + .S MDIENS=+DATA_"," + .S MDHL7=$$SUB^MDHL7B(+MDIENS) + .I +MDHL7=-1 S MDFDA(702,MDIENS,.09)=2,MDFDA(702,MDIENS,.08)=$P(MDHL7,U,2) + .I +MDHL7=1 S MDFDA(702,MDIENS,.09)=5,MDFDA(702,MDIENS,.08)="" + .D:$D(MDFDA) FILE^DIE("","MDFDA","MDERR") + I '$D(MDERR) S @RESULTS@(0)="1^OK" Q + D ERROR^MDRPCU(RESULTS,.MDERR) + Q + ; +DISPCON ; [Procedure] Display a consult + K ^TMP("GMRC",$J) + D GUI^GMRCP5(.RESULTS,DATA) + Q + ; +GETCONS ; [Procedure] Get available consults for patient + K ^TMP("MDTMP",$J) + D CPLIST^GMRCCP(DFN,,$NA(^TMP("MDTMP",$J))) + S MDX=0 + F S MDX=$O(^TMP("MDTMP",$J,MDX)) Q:'MDX D:"saprc"[$P(^(MDX),U,4) + .S Y="123;"_$P(^TMP("MDTMP",$J,MDX),U,5) + .F X=2,3,4,1,6,5 S Y=Y_U_$P(^TMP("MDTMP",$J,MDX),U,X) + .S Y=Y_U_+$O(^MDD(702,"ACON",+$P(^TMP("MDTMP",$J,MDX),U,5))) + .; + .; Patch MD*1.0*4 - Return number of times checked in at piece 9 + .; + .S (X,Z)=0,MDY=+$P(^TMP("MDTMP",$J,MDX),U,5) + .F S X=$O(^MDD(702,"ACON",MDY,X)) Q:'X S Z=Z+1 + .S $P(Y,U,9)=Z + .; + .; End Patch MD*1.0*4 + .; + .D ADD(Y) + S @RESULTS@(0)=+$O(@RESULTS@(""),-1) + K ^TMP("MDTMP",$J) + Q + ; +GETHDR ; [Procedure] Get Pt Header + S DFNIENS=DFN_"," + S @RESULTS@(0)=$$GET1^DIQ(2,DFNIENS,.01)_" "_$$GET1^DIQ(2,DFNIENS,.1)_" "_$$GET1^DIQ(2,DFNIENS,.101) + S @RESULTS@(1)=$$GET1^DIQ(2,DFNIENS,.09)_" "_$$GET1^DIQ(2,DFNIENS,.02)_" "_$$GET1^DIQ(2,DFNIENS,.03)_" ("_$$GET1^DIQ(2,DFNIENS,.033)_")" + Q + ; +GETOBJ ; [Procedure] Get information for TMDPATIENT object + D DEM^VADPT,INP^VADPT + S @RESULTS@(0)=DFN + S @RESULTS@(1)=VADM(1) + S @RESULTS@(2)=$P(VADM(2),U,2) + S @RESULTS@(3)=$P(VADM(3),U,2) + S @RESULTS@(4)=VADM(4) + S @RESULTS@(5)=$P(VADM(5),U,2) + I VAIN(4)]"" S @RESULTS@(6)="Ward: "_$P(VAIN(4),U,2)_" Rm: "_VAIN(5) + E S @RESULTS@(6)="" + Q + ; +GETRES ; [Procedure] Get results report + F MDX=0:0 S MDX=$O(^MDD(703.1,"ADFN",DFN,MDX)) Q:'MDX D + .S MDINST=+$P($G(^MDD(703.1,MDX,0)),U,4) + .I $G(DATA) Q:'$D(^MDS(702.01,DATA,.1,"B",MDINST)) + .S MDY=$O(@RESULTS@(""),-1)+1 + .S @RESULTS@(MDY)="703.1;"_MDX_U_^MDD(703.1,MDX,0) + .S Y=$P(^MDD(703.1,MDX,0),U,3) D D^DIQ + .S $P(@RESULTS@(MDY),U,11)=Y + .S Y=$P($G(^MDS(702.09,+$P(^MDD(703.1,MDX,0),U,4),0)),U) + .S $P(@RESULTS@(MDY),U,12)=Y + S @RESULTS@(0)=+$O(@RESULTS@(""),-1) + Q + ; +GETTRAN ; [Procedure] Get a patients transactions + F MDX=0:0 S MDX=$O(^MDD(702,"B",DFN,+MDX))_"," Q:'MDX D + .S Z=$$GET1^DIQ(702,MDX,".04:.02","I")_U_$$GET1^DIQ(702,MDX,.04)_U_$$GET1^DIQ(702,MDX,.02,"I")_U_$$GET1^DIQ(702,MDX,.09)_U_$$GET1^DIQ(702,MDX,.11)_U_$$GET1^DIQ(702,MDX,.991) + .S Y=$O(@RESULTS@(""),-1)+1 + .S @RESULTS@(Y)="702;"_+MDX_U_Z + S @RESULTS@(0)=+$O(@RESULTS@(""),-1) + Q + ; +GETVST ; [Procedure] Return list of visits + N BEG,END,VAERR,VASD,BDT,DTM,EDT,LOC,NOW,MDQUERY,MDLST,STI,STS,TODAY,I,J,K,XI,XE,X + S NOW=$$NOW^XLFDT(),TODAY=$P(NOW,".",1) + S BEG=$$X2FM("T-200"),END=$$X2FM("T")+0.2359 + S MDLST="",MDSTOP="" + I END>NOW D ; get future encounters, past cancels/no-shows from VADPT + .S VASD("F")=BEG + .S VASD("T")=END + .S VASD("W")="123456789" + .D SDA^VADPT + .S I=0 F S I=$O(^UTILITY("VASD",$J,I)) Q:'I D + ..S XI=^UTILITY("VASD",$J,I,"I"),XE=^("E") + ..S DTM=$P(XI,U),IEN=$P(XI,U,2),STI=$P(XI,U,3) + ..S LOC=$P(XE,U,2),STS=$P(XE,U,3) + ..I DTMNOW D ;past encounters from ACRP Toolkit - set in CALLBACK + .S BDT=BEG + .S EDT=$S(END0 D Q:DONE + .S MOV=0 F S MOV=$O(^DGPM("ATID1",DFN,TIM,MOV)) Q:MOV'>0 D Q:DONE + ..D GETS^DIQ(405,+MOV_",","*","IE","MDX0") S MTIM=$G(MDX0(405,MOV_",",".01","I")) + ..S XTYP=$G(MDX0(405,+MOV_",",".04","E")) + ..S XLOC=$G(MDX0(405,+MOV_",",".06","E")) + ..S XLOCI=+$G(MDX0(405,+MOV_",",".06","I")),HLOC=+$G(^DIC(42,+XLOCI,44)) + ..S MDLST(MTIM,"I",1)="I;"_MTIM_";"_HLOC_U_MTIM_U_"Inpatient Stay"_U_XLOC_U_XTYP + ..S DONE=1 ; Not sure if I should include all stays + S I=0 F S I=$O(MDLST(I)) Q:'I D + .S J="" F S J=$O(MDLST(I,J)) Q:J="" D + ..S K=0 F S K=$O(MDLST(I,J,K)) Q:'K D + ...S @RESULTS@($O(@RESULTS@(""),-1)+1)=MDLST(I,J,K) + S @RESULTS@(0)=+$O(@RESULTS@(""),-1)_U_($$GET1^DIQ(2,DFN_",",.1)]"") + Q + ; +LOGSEC ; [Procedure] Log Security + D NOTICE^DGSEC4(.RESULTS,DFN,DATA,1) + S @RESULTS@(0)=$S(RESULTS:"1^Logged",1:"-1^Unable to log") + Q + ; +RPC(RESULTS,OPTION,DFN,DATA) ; [Procedure] Main RPC call tag + NEW DFNIENS,GMRAL,GMVALG,GN,IENS,MDDFN,MDERR,MDFDA,MDFLD,MDHL7,MDID,MDIDS,MDIEN,MDIENS,MDRET,MDX,MDY,VA,VADM,VAERR,VAIN,Z + S RESULTS=$NA(^TMP($J)) K @RESULTS + D:$T(@OPTION)]"" @OPTION + D:'$D(@RESULTS) BADRPC^MDRPCU("MD TMDPATIENT","MDRPCOP",OPTION) + D CLEAN^DILF + Q + ; +SELECT ; [Procedure] Select patient + I '$D(^DPT(+$G(DFN),0))#2 S @RESULTS@(0)="-1^No such patient" Q + S @RESULTS@(0)="1^Required Identifiers & messages" + S IENS=DFN_"," + D FILE^DID(2,,"REQUIRED IDENTIFIERS","MDIDS") + F MDX=0:0 S MDX=$O(MDIDS("REQUIRED IDENTIFIERS",MDX)) Q:'MDX D + .S MDFLD=MDIDS("REQUIRED IDENTIFIERS",MDX,"FIELD") + .S MDID="$$PTID^"_$$GET1^DID(2,MDFLD,"","LABEL") + .S MDID=MDID_U_$$GET1^DIQ(2,IENS,MDFLD) + .D:MDFLD=.03 + ..S MDID=MDID_" ("_$$GET1^DIQ(2,IENS,.033)_")" + ..S MDID=MDID_U_$$DOB^DPTLK1(+IENS) + .D:MDFLD=.09 + ..S X=$P(MDID,U,3),X=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,10) + ..S $P(MDID,U,3)=X,$P(MDID,U,4)=$$SSN^DPTLK1(+IENS) + .S @RESULTS@($O(@RESULTS@(""),-1)+1)=MDID + S MDID="$$PTID^"_$$GET1^DID(2,.1,"","LABEL") + S MDID=MDID_U_$$GET1^DIQ(2,IENS,.1) + S @RESULTS@($O(@RESULTS@(""),-1)+1)=MDID + S MDID="$$PTID^"_$$GET1^DID(2,.101,"","LABEL") + S MDID=MDID_U_$$GET1^DIQ(2,IENS,.101) + S @RESULTS@($O(@RESULTS@(""),-1)+1)=MDID + K MDRET + D GUIBS5A^DPTLK6(.MDRET,DFN) D:MDRET(1)=1 + .D ADD("$$MSGHDR^2^SAME LAST NAME AND LAST 4") + .S MDX=1 + .F S MDX=$O(MDRET(MDX)) Q:'MDX!(+$G(MDRET(MDX))) D + ..D ADD($P(MDRET(MDX),U,2)) + .D ADD(" ") + .S MDX=1 + .F S MDX=$O(MDRET(MDX)) Q:'MDX D:+MDRET(MDX) + ..S MDDFN=+$P(MDRET(MDX),U,2) + ..D ADD($$GET1^DIQ(2,MDDFN_",",.01)_" "_$$DOB^DPTLK1(MDDFN)_" "_$$SSN^DPTLK1(MDDFN)) + .D ADD(" ") + .D ADD("Please review carefully before continuing") + .D ADD("$$MSGEND") + K MDRET + D PTSEC^DGSEC4(.MDRET,DFN) D:MDRET(1)'=0 + .D:MDRET(1)=3 + ..D ADD("$$MSGHDR^0^CAN'T ACCESS YOUR OWN RECORD!!") + .D:MDRET(1)=-1 + ..D ADD("$$MSGHDR^0^INCOMPLETE INFORMATION - CAN'T PROCEED") + .D:MDRET(1)=1 + ..D ADD("$$MSGHDR^1^SENSITIVE RECORD ACCESS") + .D:MDRET(1)'=-1&(MDRET(1)'=3)&(MDRET(1)'=1) + ..D ADD("$$MSGHDR^3^SENSITIVE RECORD ACCESS") + .S MDX=1 + .F S MDX=$O(MDRET(MDX)) Q:'MDX D ADD($TR(MDRET(MDX),"*"," ")) + .D ADD("$$MSGEND") + D GUIMTD^DPTLK6(.MDRET,DFN) D:MDRET(1)=1 + .D ADD("$$MSGHDR^1^NOTICE") + .F MDX=1:0 S MDX=$O(MDRET(MDX)) Q:'MDX D ADD(MDRET(MDX)) + .D ADD("$$MSGEND") + Q + ; +X2FM(X) ; [Function] return FM date given relative date + N %DT S %DT="TS" D ^%DT + Q Y + ; diff --git a/r/CLINICAL_PROCEDURES-MD/MDRPCOT.m b/r/CLINICAL_PROCEDURES-MD/MDRPCOT.m index e9d3bef3..2410ba26 100644 --- a/r/CLINICAL_PROCEDURES-MD/MDRPCOT.m +++ b/r/CLINICAL_PROCEDURES-MD/MDRPCOT.m @@ -1,232 +1,219 @@ -MDRPCOT ; HOIFO/DP/NCA - Object RPCs (TMDTransaction) ;3/12/08 09:18 - ;;1.0;CLINICAL PROCEDURES;**5,6**;Apr 01, 2004;Build 102 - ; Integration Agreements: - ; IA# 2693 [Subscription] TIU Extractions. - ; IA# 2944 [Subscription] Calls to TIUSRVR1. - ; IA# 3535 [Subscription] Calls to TIUSRVP. - ; IA# 10104 [Supported] Routine XLFSTR calls -ADDMSG ; [Procedure] Add message to transaction - N MDIEN,MDIENS,MDRET - Q:'$G(DATA("TRANSACTION")) - Q:$G(DATA("MESSAGE"))="" - S MDIEN=+DATA("TRANSACTION"),MDIENS="+1,"_MDIEN_"," - D NOW^%DTC S DATA("DATE")=% K % - S MDFDA(702.091,MDIENS,.01)=+$O(^MDD(702,+MDIEN,.091,"A"),-1)+1 - S MDFDA(702.091,MDIENS,.02)=DATA("DATE") - S MDFDA(702.091,MDIENS,.03)=$G(DATA("PKG"),"UNKNOWN") - S MDFDA(702.091,MDIENS,.09)=DATA("MESSAGE") - D UPDATE^DIE("","MDFDA","MDRET") - Q - ; -DELETE ; [Procedure] Delete Study - ; Sets @RESULTS@(0)="-1^Reason for not deleting" or "1^Study Deleted" - ; - N MDAST,MDHOLD,MDNOTE,MDRES,MDSIEN,BODY,SUBJECT,DEVIEN - S (MDHOLD,MDSIEN)=+DATA,MDRES=0,MDNOTE="" - D ALERT^MDHL7U3(MDSIEN) ; Builds the body of the mail message - I $G(^MDD(702,+MDSIEN,0))="" S @RESULTS@(0)="1^Study Deleted." D NOTICE^MDHL7U3(SUBJECT,.BODY,DEVIEN,DUZ) Q ;deleting message - S:+$P(^MDD(702,MDSIEN,0),U,6) MDNOTE=$P(^MDD(702,MDSIEN,0),U,6) - I "13"[$P(^MDD(702,MDSIEN,0),U,9) S @RESULTS@(0)="-1^Can't Delete TIU Note from a "_$$GET1^DIQ(702,MDSIEN,.09,"E")_" Study." Q - I "5"[$P(^MDD(702,MDSIEN,0),U,9) S MDCANR=$$CANCEL^MDHL7B(MDHOLD) I MDCANR<1 S @RESULTS@(0)="-1^"_$P(MDCANR,"^",2) Q - I +MDNOTE S MDRES="" D DELETE^TIUSRVP(.MDRES,MDNOTE) - I MDRES D Q - .D STATUS(MDSIEN_",",2,$P(MDRES,"^",2)) - .S DATA("TRANSACTION")=MDSIEN,DATA("PKG")="TIU" - .S DATA("MESSAGE")=$P(MDRES,"^",2) D ADDMSG - .S @RESULTS@(0)="-1^"_$P(MDRES,"^",2) - .Q - E D - .I $D(^MDD(702.001,"ASTUDY",MDSIEN)) S @RESULTS@(0)="-1^Note associated with study, can not delete." Q - .S MDAST=$$HL7CHK^MDHL7U3(+MDSIEN) I +MDAST<1 S @RESULTS@(0)=MDAST Q - .D NOTICE^MDHL7U3(SUBJECT,.BODY,DEVIEN,DUZ) ; delete message - .S MDFDA(702,DATA_",",.01)="" - .; Check for renal study to delete as well - .S:$D(^MDK(704.202,DATA)) MDFDA(704.202,DATA_",",.01)="" - .D FILE^DIE("","MDFDA") - .N DA,DIK S DA=+MDSIEN,DIK="^MDD(702," D ^DIK - .S @RESULTS@(0)="1^Study Deleted." - .Q - Q - ; -FILEMSG(STUDY,MDPKG,MDSTAT,MDMSG) ; [Procedure] File Study Status and Message. - S DATA("TRANSACTION")=STUDY,DATA("PKG")=MDPKG - S DATA("MESSAGE")=$P(MDMSG,"^",2) - D STATUS(STUDY_",",MDSTAT,$P(MDMSG,"^",2)),ADDMSG - Q - ; -FILES ; [Procedure] Add/remove an attachment to this transaction - NEW MDFDA,MDIEN,MDIENS,MDRET,P1,P2,P3,P4 - S P1=$P(DATA,U,1),P2=$P(DATA,U,2),P3=$P(DATA,U,3),P4=$P(DATA,U,4) - S MDIEN=0 I $G(^MDD(702,+P1,0))="" Q - ; Look for file (All comparisons done on lower case values) - F S MDIEN=$O(^MDD(702,P1,.1,MDIEN)) Q:'MDIEN D Q:X=P3 - .S X=$$LOW^XLFSTR($G(^MDD(702,P1,.1,MDIEN,.1))) - I MDIEN&P4 S @RESULTS@(0)="1^File already assigned" Q - I 'MDIEN&'P4 S @RESULTS@(0)="1^File not assigned" Q - I P4 D Q ; Add a file - .S MDIENS="+1,"_P1_"," - .S MDFDA(702.1,MDIENS,.01)=$O(^MDD(702,P1,.1,"B",""),-1)+1 - .S MDFDA(702.1,MDIENS,.02)=$S(P2:"I",1:"U") - .I P2 S MDFDA(702.1,MDIENS,.03)=P2 - .S MDFDA(702.1,MDIENS,.1)=P3 - .D UPDATE^DIE("","MDFDA","MDIEN") - .S @RESULTS@(0)=+$G(MDIEN(1),-1) - I 'P4 D Q ; Remove the file - .S MDFDA(702.1,MDIEN_","_P1_",",.01)="@" - .D FILE^DIE("","MDFDA","MDRET") - .S @RESULTS@(0)=$S($D(MDRET):-1,1:1) - Q - ; -GETATT ; [Procedure] Get Attachments - F X=0:0 S X=$O(^MDD(702,DATA,.1,X)) Q:'X D - .S Y=$O(@RESULTS@(""),-1)+1 - .S @RESULTS@(Y)=$P(^MDD(702,DATA,.1,X,0),U,1,3) - .S $P(@RESULTS@(Y),U,4)=$G(^MDD(702,DATA,.1,X,.1)) - S @RESULTS@(0)=+$O(@RESULTS@(""),-1) - Q - ; -GETERR ; [Procedure] Return list of Imaging Errors - ; DATA = Transaction IEN - F MDX=0:0 S MDX=$O(^MDD(702,DATA,.091,MDX)) Q:'MDX D - .S MDY=+^MDD(702,DATA,.091,MDX,0)_U,Y=$P(^(0),U,2) - .D D^DIQ S MDY=MDY_Y_U - .S MDY=MDY_$P(^MDD(702,DATA,.091,MDX,0),U,3)_U_$P(^(0),U,9) - .S ^TMP($J,$O(^TMP($J,""),-1)+1)=MDY - S ^TMP($J,0)=+$O(^TMP($J,""),-1) - Q - ; -NEWSTAT ; [Procedure] RPC Call to set status - S MDFDA(702,DATA,.09)=TYPE - D FILE^DIE("","MDFDA") - I TYPE=3&($G(^MDK(704.202,+DATA,0))'="") K MDFDA S MDFDA(704.202,DATA,.09)=0 D FILE^DIE("","MDFDA") K MDFDA - Q - ; -RPC(RESULTS,OPTION,DATA,TYPE,FILE,RESREP) ; [Procedure] Main RPC call - N MDCANR,MDCON,MDDOC,MDFDA,MDFN,MDGST,MDHOLD,MDIEN,MDIENS,MDL,MDLOC,MDMSG,MDNEWV,MDNOTE,MDNVST,MDPDT,MDPKG,MDPROC,MDRES,MDRESU,MDRESUL,MDRET,MDS,MDSIEN,MDSTAT,MDSTUDY,MDTITL,MDTIUER,MDTRAN,MDTST,MDTSTR,MDVST,MDVSTR,MDWP,MDX,MDY - S RESULTS=$NA(^TMP($J)) K @RESULTS - D:$T(@OPTION)]"" @OPTION - D:'$D(@RESULTS) BADRPC^MDRPCU("MD TMDTRANSACTION","MDRPCOT",OPTION) - D CLEAN^DILF - Q - ; -STATUS(MDIENS,MDSTAT,MDMSG) ; [Procedure] Update transaction status - S MDFDA(702,MDIENS,.08)=$G(MDMSG) - S MDFDA(702,MDIENS,.09)=MDSTAT - D FILE^DIE("","MDFDA") - Q - ; -SUBMIT ; [Procedure] Process the Image(s) Submission. - ; Output: -1^Error Message or - ; 1^Successful Message - N MDRESUL,MDSTUDY - S MDSTUDY=+DATA,MDRESUL="" - ; Create New TIU Document - S MDRESUL=$$NEWTIUN(MDSTUDY) - ; File TIU Error messages - I +MDRESUL<0 D Q - .D FILEMSG(MDSTUDY,"TIU",2,MDRESUL) - .S @RESULTS@(0)=MDRESUL - ; Submit and export the images - S MDRESUL=$$SUBMIT^MDRPCOT1(MDSTUDY) - ; File message - D FILEMSG(MDSTUDY,"IMAGING",$S(+MDRESUL>0:+MDRESUL,1:2),MDRESUL) - S @RESULTS@(0)=MDRESUL - Q - ; -VIEWTIU ; [Procedure] VIew the associated tiu document - I '$P(^MDD(702,+DATA,0),U,6) D Q - .S @RESULTS@(0)="NO TIU NOTE FOR THIS STUDY" - D TGET^TIUSRVR1(.RESULTS,+$P(^MDD(702,+DATA,0),U,6)) - Q - ; -GETDATA(STUDY) ; [Function] Return the Necessary data for creating a TIU note. - ; Return: Patient DFN_"^"_TIU title_"^"_Hospital Location_"^"_TIU Note - ; IEN_"^"_Consult #_"^"_CP Definition IEN_"^"_Visit String_"^" - ; New Visit Flag - ; or - ; -1^Error Message - N DFN,MDCON,MDFN,MDIEN,MDIENS,MDLOC,MDNEWV,MDNOTE,MDNVST,MDPROC,MDVSTR,MDTITL,MDX,MDTST - S MDIEN=+STUDY,MDIENS=MDIEN_",",MDNVST=0 - I $$GET1^DIQ(702,MDIENS,.01)="" Q "-1^No such study entry." - ; Get DFN - S DFN=$$GET1^DIQ(702,MDIEN,.01,"I") - I 'DFN Q "-1^No DFN." - ; Get CP Def - S MDPROC=$$GET1^DIQ(702,MDIEN,.04,"I") - I 'MDPROC Q "-1^No CP Def." - ; Get Consult - S MDCON=$$GET1^DIQ(702,MDIEN,.05,"I") - I 'MDCON Q "-1^No Consult #." - ; Get TIU Note Title - S MDTITL=$$GET1^DIQ(702.01,+MDPROC_",",.04,"I") - I 'MDTITL Q "-1^No TIU Note Title." - S MDVSTR=$$GET1^DIQ(702,MDIEN,.07) - I MDVSTR="" Q "-1^No Visit String." - I $L(MDVSTR,";")=1 S MDNVST=1,MDVSTR=";"_MDVSTR ; If new visit is selected - ; MDLOC is Hospital Location - I MDVSTR'="" D - .S MDVSTR=$$GETVSTR^MDRPCOT1(DFN,MDVSTR,MDPROC,$$GET1^DIQ(702,MDIEN,.02,"I")) - .S MDLOC=$P(MDVSTR,";",1) - I $$GET1^DIQ(702.01,+MDPROC_",",.12,"I")=1 Q DFN_"^"_MDTITL_"^"_MDLOC_"^^"_MDCON_"^"_MDPROC_"^"_MDVSTR_"^"_MDNVST - ; Does TIU doc already exist? - I $$GET1^DIQ(702,MDIEN,.06,"I") Q DFN_"^"_MDTITL_"^"_MDLOC_"^"_+$$GET1^DIQ(702,MDIEN,.06,"I")_"^"_MDCON_"^"_MDPROC_"^"_MDVSTR_"^"_MDNVST - ; Does TIU doc exist for previous transaction of this consult? - I MDCON S MDNOTE=$$PREV(MDCON,MDIEN) - Q DFN_"^"_MDTITL_"^"_MDLOC_"^"_+MDNOTE_"^"_MDCON_"^"_MDPROC_"^"_MDVSTR_"^"_MDNVST - ; -NEWTIUN(STUDY) ; [Function] Create a new TIU for transaction - ; Input: STUDY - IENS of CP study entry - ; Return: TIU Document IEN - N CTR,DFN,MDCON,MDFDA,MDGST,MDL,MDLOC,MDNOTE,MDPDT,MDPROC,MDRESU,MDTITL,MDTSTR,MDVST,MDVSTR,MDWP,MDPT S CTR=0,MDGST=+STUDY,MDRESU="" - ; Get data for TIU Note Creation - S (MDTSTR,MDRESU)=$$GETDATA(MDGST) - ; File Error message - I +MDRESU<0 D FILEMSG(MDGST,"CP",2,MDRESU) Q MDRESU - I $G(MDTSTR)="" Q "-1^No Data to Create TIU Document" - F MDL="DFN","MDTITL","MDLOC","MDNOTE","MDCON","MDPROC","MDVSTR","MDNVST" D - .S CTR=CTR+1,@MDL=$P(MDTSTR,"^",CTR) - S MDVST="" - ; If previous TIU document exists, quit - I MDNOTE Q MDNOTE - I 'MDLOC Q "-1^No Hospital Location." - ; Create new visit, if no vstring - S MDPDT=$$PDT^MDRPCOT1(MDGST) - I 'MDPDT S MDPT=$O(^MDD(703.1,"ASTUDYID",+MDGST,0)),MDPDT=$P($G(^MDD(703.1,+MDPT,0)),U,3) - S:'MDPDT MDPDT=$P(MDVSTR,";",2) ; If No D/T Performed grab visit D/T - I $P(MDVSTR,";",3)="V" S $P(MDVSTR,";",3)="A" - ; Build variables for TIU Call - S MDWP(.05)=1 ; Undicated Status - S MDWP(1405)=+MDCON_";GMR(123," ; Package Reference - S MDWP(70201)=5 ; Default Procedure Summary Code "Machine Resulted" - I MDPDT S MDWP(70202)=MDPDT ; Date/Time Performed - ; File PCE Error message - I MDNVST S MDRESU=$$EN1^MDPCE(MDGST,$P(MDVSTR,";",2),MDPROC,$P(MDVSTR,";",3),"P") I +MDRESU S MDVST=+MDRESU,MDVSTR=$P(MDRESU,"^",2) - I MDNVST&(+MDRESU<0) D FILEMSG(MDGST,"PCE",2,$P(MDRESU,"^",2)) Q MDRESU - ; Create the TIU note stub - S MDNOTE="" D MAKE^TIUSRVP(.MDNOTE,DFN,MDTITL,$P(MDVSTR,";",2),MDLOC,$S(MDVST:MDVST,1:""),.MDWP,MDVSTR,1,1) - I '(+MDNOTE) S $P(MDNOTE,"^")=-1 Q MDNOTE - ; Finalize the transaction - S MDFDA(702,STUDY_",",.06)=+MDNOTE - S MDFDA(702,STUDY_",",.08)="" - S:MDVST>0 MDFDA(702,STUDY_",",.13)=MDVST - D FILE^DIE("","MDFDA") - D UPD^MDKUTLR(STUDY,+MDNOTE) - Q 1 - ; -PREV(MDC,MDS) ; [Function] Return the Previous TIU document. - N MDNEWV,MDDOC,MDTRAN,MDTIUER,MDTST - S (MDDOC,MDNEWV,MDTRAN,MDTIUER,MDTST)="" K ^TMP("MDTIUST",$J) - F S MDTRAN=$O(^MDD(702,"ACON",MDC,MDTRAN)) Q:'MDTRAN D Q:'MDTRAN - .I $P(^MDD(702,MDTRAN,0),U,6) D - ..D EXTRACT^TIULQ($P(^MDD(702,MDTRAN,0),U,6),"^TMP(""MDTIUST"",$J)",MDTIUER,".01;.05;1406") Q:+MDTIUER - ..S MDTST=$G(^TMP("MDTIUST",$J,$P(^MDD(702,MDTRAN,0),U,6),.05,"E")) - ..I MDTST'="UNDICTATED"&(MDTST'="UNSIGNED") K ^TMP("MDTIUST",$J) Q - ..I MDTST="UNSIGNED"&'($G(^TMP("MDTIUST",$J,$P(^MDD(702,MDTRAN,0),U,6),1406,"I"))) K ^TMP("MDTIUST",$J) Q - ..S MDDOC=$P(^MDD(702,MDTRAN,0),U,6),MDNEWV=$P(^MDD(702,MDTRAN,0),U,7) - ..Q:'MDS - ..S MDFDA(702,MDS_",",.06)=MDDOC - ..S MDFDA(702,MDS_",",.07)=MDNEWV - ..D FILE^DIE("","MDFDA") - ..S MDTRAN="" - Q MDDOC - ; +MDRPCOT ; HOIFO/DP/NCA - Object RPCs (TMDTransaction) ;12/5/02 15:33 + ;;1.0;CLINICAL PROCEDURES;**5**;Apr 01, 2004;Build 1 + ; Integration Agreements: + ; IA# 2693 [Subscription] TIU Extractions. + ; IA# 2944 [Subscription] Calls to TIUSRVR1. + ; IA# 3535 [Subscription] Calls to TIUSRVP. + ; IA# 10104 [Supported] Routine XLFSTR calls +ADDMSG ; [Procedure] Add message to transaction + N MDIEN,MDIENS,MDRET + Q:'$G(DATA("TRANSACTION")) + Q:$G(DATA("MESSAGE"))="" + S MDIEN=+DATA("TRANSACTION"),MDIENS="+1,"_MDIEN_"," + D NOW^%DTC S DATA("DATE")=% K % + S MDFDA(702.091,MDIENS,.01)=+$O(^MDD(702,+MDIEN,.091,"A"),-1)+1 + S MDFDA(702.091,MDIENS,.02)=DATA("DATE") + S MDFDA(702.091,MDIENS,.03)=$G(DATA("PKG"),"UNKNOWN") + S MDFDA(702.091,MDIENS,.09)=DATA("MESSAGE") + D UPDATE^DIE("","MDFDA","MDRET") + Q + ; +DELETE ; [Procedure] Delete Study + ; Sets @RESULTS@(0)="-1^Reason for not deleting" or "1^Study Deleted" + ; + N MDHOLD,MDNOTE,MDRES,MDSIEN + S (MDHOLD,MDSIEN)=+DATA,MDRES=0,MDNOTE="" + S:+$P(^MDD(702,MDSIEN,0),U,6) MDNOTE=$P(^MDD(702,MDSIEN,0),U,6) + I "13"[$P(^MDD(702,MDSIEN,0),U,9) S @RESULTS@(0)="-1^Can't Delete TIU Note from a "_$$GET1^DIQ(702,MDSIEN,.09,"E")_" Study." Q + I "5"[$P(^MDD(702,MDSIEN,0),U,9) S MDCANR=$$CANCEL^MDHL7B(MDHOLD) I MDCANR<1 S @RESULTS@(0)="-1^"_$P(MDCANR,"^",2) Q + I +MDNOTE S MDRES="" D DELETE^TIUSRVP(.MDRES,MDNOTE) + I MDRES D Q + .D STATUS(MDSIEN_",",2,$P(MDRES,"^",2)) + .S DATA("TRANSACTION")=MDSIEN,DATA("PKG")="TIU" + .S DATA("MESSAGE")=$P(MDRES,"^",2) D ADDMSG + .S @RESULTS@(0)="-1^"_$P(MDRES,"^",2) + .Q + E D + .S MDFDA(702,DATA_",",.01)="" + .D FILE^DIE("","MDFDA") + .N DA,DIK S DA=+MDSIEN,DIK="^MDD(702," D ^DIK + .S @RESULTS@(0)="1^Study Deleted." + .Q + Q + ; +FILEMSG(STUDY,MDPKG,MDSTAT,MDMSG) ; [Procedure] File Study Status and Message. + S DATA("TRANSACTION")=STUDY,DATA("PKG")=MDPKG + S DATA("MESSAGE")=$P(MDMSG,"^",2) + D STATUS(STUDY_",",MDSTAT,$P(MDMSG,"^",2)),ADDMSG + Q + ; +FILES ; [Procedure] Add/remove an attachment to this transaction + NEW MDFDA,MDIEN,MDIENS,MDRET,P1,P2,P3,P4 + S P1=$P(DATA,U,1),P2=$P(DATA,U,2),P3=$P(DATA,U,3),P4=$P(DATA,U,4) + S MDIEN=0 + ; Look for file (All comparisons done on lower case values) + F S MDIEN=$O(^MDD(702,P1,.1,MDIEN)) Q:'MDIEN D Q:X=P3 + .S X=$$LOW^XLFSTR($G(^MDD(702,P1,.1,MDIEN,.1))) + I MDIEN&P4 S @RESULTS@(0)="1^File already assigned" Q + I 'MDIEN&'P4 S @RESULTS@(0)="1^File not assigned" Q + I P4 D Q ; Add a file + .S MDIENS="+1,"_P1_"," + .S MDFDA(702.1,MDIENS,.01)=$O(^MDD(702,P1,.1,"B",""),-1)+1 + .S MDFDA(702.1,MDIENS,.02)=$S(P2:"I",1:"U") + .I P2 S MDFDA(702.1,MDIENS,.03)=P2 + .S MDFDA(702.1,MDIENS,.1)=P3 + .D UPDATE^DIE("","MDFDA","MDIEN") + .S @RESULTS@(0)=+$G(MDIEN(1),-1) + I 'P4 D Q ; Remove the file + .S MDFDA(702.1,MDIEN_","_P1_",",.01)="@" + .D FILE^DIE("","MDFDA","MDRET") + .S @RESULTS@(0)=$S($D(MDRET):-1,1:1) + Q + ; +GETATT ; [Procedure] Get Attachments + F X=0:0 S X=$O(^MDD(702,DATA,.1,X)) Q:'X D + .S Y=$O(@RESULTS@(""),-1)+1 + .S @RESULTS@(Y)=$P(^MDD(702,DATA,.1,X,0),U,1,3) + .S $P(@RESULTS@(Y),U,4)=$G(^MDD(702,DATA,.1,X,.1)) + S @RESULTS@(0)=+$O(@RESULTS@(""),-1) + Q + ; +GETERR ; [Procedure] Return list of Imaging Errors + ; DATA = Transaction IEN + F MDX=0:0 S MDX=$O(^MDD(702,DATA,.091,MDX)) Q:'MDX D + .S MDY=+^MDD(702,DATA,.091,MDX,0)_U,Y=$P(^(0),U,2) + .D D^DIQ S MDY=MDY_Y_U + .S MDY=MDY_$P(^MDD(702,DATA,.091,MDX,0),U,3)_U_$P(^(0),U,9) + .S ^TMP($J,$O(^TMP($J,""),-1)+1)=MDY + S ^TMP($J,0)=+$O(^TMP($J,""),-1) + Q + ; +NEWSTAT ; [Procedure] RPC Call to set status + S MDFDA(702,DATA,.09)=TYPE + D FILE^DIE("","MDFDA") + Q + ; +RPC(RESULTS,OPTION,DATA,TYPE,FILE,RESREP) ; [Procedure] Main RPC call + N MDCANR,MDCON,MDDOC,MDFDA,MDFN,MDGST,MDHOLD,MDIEN,MDIENS,MDL,MDLOC,MDMSG,MDNEWV,MDNOTE,MDNVST,MDPDT,MDPKG,MDPROC,MDRES,MDRESU,MDRESUL,MDRET,MDS,MDSIEN,MDSTAT,MDSTUDY,MDTITL,MDTIUER,MDTRAN,MDTST,MDTSTR,MDVST,MDVSTR,MDWP,MDX,MDY + S RESULTS=$NA(^TMP($J)) K @RESULTS + D:$T(@OPTION)]"" @OPTION + D:'$D(@RESULTS) BADRPC^MDRPCU("MD TMDTRANSACTION","MDRPCOT",OPTION) + D CLEAN^DILF + Q + ; +STATUS(MDIENS,MDSTAT,MDMSG) ; [Procedure] Update transaction status + S MDFDA(702,MDIENS,.08)=$G(MDMSG) + S MDFDA(702,MDIENS,.09)=MDSTAT + D FILE^DIE("","MDFDA") + Q + ; +SUBMIT ; [Procedure] Process the Image(s) Submission. + ; Output: -1^Error Message or + ; 1^Successful Message + N MDRESUL,MDSTUDY + S MDSTUDY=+DATA,MDRESUL="" + ; Create New TIU Document + S MDRESUL=$$NEWTIUN(MDSTUDY) + ; File TIU Error messages + ;I +MDRESUL<0 D FILEMSG(MDSTUDY,"TIU",2,MDRESUL) Q MDRESUL + I +MDRESUL<0 D Q + .D FILEMSG(MDSTUDY,"TIU",2,MDRESUL) + .S @RESULTS@(0)=MDRESUL + ; Submit and export the images + S MDRESUL=$$SUBMIT^MDRPCOT1(MDSTUDY) + ; File message + D FILEMSG(MDSTUDY,"IMAGING",$S(+MDRESUL>0:+MDRESUL,1:2),MDRESUL) + S @RESULTS@(0)=MDRESUL + Q + ; +VIEWTIU ; [Procedure] VIew the associated tiu document + I '$P(^MDD(702,+DATA,0),U,6) D Q + .S @RESULTS@(0)="NO TIU NOTE FOR THIS STUDY" + D TGET^TIUSRVR1(.RESULTS,+$P(^MDD(702,+DATA,0),U,6)) + Q + ; +GETDATA(STUDY) ; [Function] Return the Necessary data for creating a TIU note. + ; Return: Patient DFN_"^"_TIU title_"^"_Hospital Location_"^"_TIU Note + ; IEN_"^"_Consult #_"^"_CP Definition IEN_"^"_Visit String_"^" + ; New Visit Flag + ; or + ; -1^Error Message + N DFN,MDCON,MDFN,MDIEN,MDIENS,MDLOC,MDNEWV,MDNOTE,MDNVST,MDPROC,MDVSTR,MDTITL,MDX,MDTST + S MDIEN=+STUDY,MDIENS=MDIEN_",",MDNVST=0 + I $$GET1^DIQ(702,MDIENS,.01)="" Q "-1^No such study entry." + ; Get DFN + S DFN=$$GET1^DIQ(702,MDIEN,.01,"I") + I 'DFN Q "-1^No DFN." + ; Get CP Def + S MDPROC=$$GET1^DIQ(702,MDIEN,.04,"I") + I 'MDPROC Q "-1^No CP Def." + ; Get Consult + S MDCON=$$GET1^DIQ(702,MDIEN,.05,"I") + I 'MDCON Q "-1^No Consult #." + ; Get TIU Note Title + S MDTITL=$$GET1^DIQ(702.01,+MDPROC_",",.04,"I") + I 'MDTITL Q "-1^No TIU Note Title." + S MDVSTR=$$GET1^DIQ(702,MDIEN,.07) + I MDVSTR="" Q "-1^No Visit String." + I $L(MDVSTR,";")=1 S MDNVST=1,MDVSTR=";"_MDVSTR ; If new visit is selected + ; MDLOC is Hospital Location + I MDVSTR'="" D + .S MDVSTR=$$GETVSTR^MDRPCOT1(DFN,MDVSTR,MDPROC,$$GET1^DIQ(702,MDIEN,.02,"I")) + .S MDLOC=$P(MDVSTR,";",1) + ; Does TIU doc already exist? + I $$GET1^DIQ(702,MDIEN,.06,"I") Q DFN_"^"_MDTITL_"^"_MDLOC_"^"_+$$GET1^DIQ(702,MDIEN,.06,"I")_"^"_MDCON_"^"_MDPROC_"^"_MDVSTR_"^"_MDNVST + ; Does TIU doc exist for previous transaction of this consult? + I MDCON S MDNOTE=$$PREV(MDCON,MDIEN) + Q DFN_"^"_MDTITL_"^"_MDLOC_"^"_+MDNOTE_"^"_MDCON_"^"_MDPROC_"^"_MDVSTR_"^"_MDNVST + ; +NEWTIUN(STUDY) ; [Function] Create a new TIU for transaction + ; Input: STUDY - IENS of CP study entry + ; Return: TIU Document IEN + N CTR,DFN,MDCON,MDFDA,MDGST,MDL,MDLOC,MDNOTE,MDPDT,MDPROC,MDRESU,MDTITL,MDTSTR,MDVST,MDVSTR,MDWP S CTR=0,MDGST=+STUDY,MDRESU="" + ; Get data for TIU Note Creation + S (MDTSTR,MDRESU)=$$GETDATA(MDGST) + ; File Error message + I +MDRESU<0 D FILEMSG(MDGST,"CP",2,MDRESU) Q MDRESU + I $G(MDTSTR)="" Q "-1^No Data to Create TIU Document" + F MDL="DFN","MDTITL","MDLOC","MDNOTE","MDCON","MDPROC","MDVSTR","MDNVST" D + .S CTR=CTR+1,@MDL=$P(MDTSTR,"^",CTR) + S MDVST="" + ; If previous TIU document exists, quit + I MDNOTE Q MDNOTE + I 'MDLOC Q "-1^No Hospital Location." + ; Create new visit, if no vstring + S MDPDT=$$PDT^MDRPCOT1(MDGST) + S:'MDPDT MDPDT=$P(MDVSTR,";",2) ; If No D/T Performed grab visit D/T + ; Build variables for TIU Call + S MDWP(.05)=1 ; Undicated Status + S MDWP(1405)=+MDCON_";GMR(123," ; Package Reference + I MDPDT S MDWP(70202)=MDPDT ; Date/Time Performed + ; File PCE Error message + I MDNVST S MDRESU=$$EN1^MDPCE(MDGST,MDPDT,MDPROC,$P(MDVSTR,";",3),"P") I +MDRESU S MDVST=+MDRESU,MDVSTR=$P(MDRESU,"^",2) + I MDNVST&(+MDRESU<0) D FILEMSG(MDGST,"PCE",2,$P(MDRESU,"^",2)) Q MDRESU + ; Create the TIU note stub + S MDNOTE="" D MAKE^TIUSRVP(.MDNOTE,DFN,MDTITL,$P(MDVSTR,";",2),MDLOC,$S(MDVST:MDVST,1:""),.MDWP,MDVSTR,1,1) + I '(+MDNOTE) S $P(MDNOTE,"^")=-1 Q MDNOTE + ; Finalize the transaction + S MDFDA(702,STUDY_",",.06)=+MDNOTE + S MDFDA(702,STUDY_",",.08)="" + D FILE^DIE("","MDFDA") + Q 1 + ; +PREV(MDC,MDS) ; [Function] Return the Previous TIU document. + N MDNEWV,MDDOC,MDTRAN,MDTIUER,MDTST + S (MDDOC,MDNEWV,MDTRAN,MDTIUER,MDTST)="" K ^TMP("MDTIUST",$J) + F S MDTRAN=$O(^MDD(702,"ACON",MDC,MDTRAN)) Q:'MDTRAN D Q:'MDTRAN + .I $P(^MDD(702,MDTRAN,0),U,6) D + ..D EXTRACT^TIULQ($P(^MDD(702,MDTRAN,0),U,6),"^TMP(""MDTIUST"",$J)",MDTIUER,".01;.05;1406") Q:+MDTIUER + ..S MDTST=$G(^TMP("MDTIUST",$J,$P(^MDD(702,MDTRAN,0),U,6),.05,"E")) + ..I MDTST'="UNDICTATED"&(MDTST'="UNSIGNED") K ^TMP("MDTIUST",$J) Q + ..I MDTST="UNSIGNED"&'($G(^TMP("MDTIUST",$J,$P(^MDD(702,MDTRAN,0),U,6),1406,"I"))) K ^TMP("MDTIUST",$J) Q + ..S MDDOC=$P(^MDD(702,MDTRAN,0),U,6),MDNEWV=$P(^MDD(702,MDTRAN,0),U,7) + ..Q:'MDS + ..S MDFDA(702,MDS_",",.06)=MDDOC + ..S MDFDA(702,MDS_",",.07)=MDNEWV + ..D FILE^DIE("","MDFDA") + ..S MDTRAN="" + Q MDDOC + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRM7M1.m b/r/CLINICAL_REMINDERS-PXRM/PXRM7M1.m index 119f10b2..05c71611 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRM7M1.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRM7M1.m @@ -1,17 +1,16 @@ -PXRM7M1 ;SLC/JVS HL7 PUT MESSAGE IN 772 FILE; 06/01/2007 15:26 - ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123 - ;This routine will use the HL7 Package commands to gather the message - ;into the file 772 - Q -EN(ID) ;Entry Point - ; - S (PROTIEN,PXRM7,PXRM7R,PXRM77,PXRM7ID)="" - S PROTIEN=$O(^ORD(101,"B","PXRM7 RECO SERVER",PROTIEN)) - S HL("EID")=PROTIEN - D INIT^HLFNC2(PROTIEN,.PXRM7) - S PXRM7("PID")="HI^D" - S HLA("HLS",1)=PXRM77 - D GENERATE^HLMA(HL("EID"),"GM",1,.PXRM7R,.PXRM7ID,) - D STORE^PXRM7API - S ID=ZMID - Q +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 + Q +EN(ID) ;Entry Point + ; + S (PROTIEN,PXRM7,PXRM7R,PXRM77,PXRM7ID)="" + S PROTIEN=$O(^ORD(101,"B","PXRM7 RECO SERVER",PROTIEN)) + S HL("EID")=PROTIEN + D INIT^HLFNC2(PROTIEN,.PXRM7) + S PXRM7("PID")="HI^D" + S HLA("HLS",1)=PXRM77 + D GENERATE^HLMA(HL("EID"),"GM",1,.PXRM7R,.PXRM7ID,) + S ID=ZMID + Q diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRM7XT.m b/r/CLINICAL_REMINDERS-PXRM/PXRM7XT.m index e74f5113..ed15cf5f 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRM7XT.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRM7XT.m @@ -1,254 +1,253 @@ -PXRM7XT ;SLC/JVS HL7 EXTRACT FROM FILE; 06/01/2007 - ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123 - ;This is the beginning of the extraction from the extract file - ; - ;VARIABLE LIST - ;IEN = IEN OF ENTRY IN EXTRACT FILE 810.3 - Q -SPLIT ;SPLIT MESSAGES - ; - N ORC2 - I LINE>100 D - .S ORCCNT=ORCCNT+1 - .D EN^PXRM7M1(.ID) - .K ^TMP("HLS",$J) - .S ORC2=$G(^TMP("PXRM7HLORC",$J)) - .S $P(ORC2,"|",3)="P"_ORCCNT,ORC=ORC2 - .S LINE=2 - .I $D(SEE) W !,ORC - .S ^TMP("HLS",$J,1)=ORC - Q - ; -EXTRACT(IEN,SEE,ID,MODE) ; - N ORCCNT - K ERROR,LINE - S ORCCNT=1 ;Count of ORC segments or number of messages created - S LINE=1 ;Line count for the ^TMP("HL7",$J,LINE) global variable - ;-Verify Values - I '$D(^PXRMXT(810.3,IEN)) S ERROR(1)="No Such IEN in file 810.3 "_IEN - I $D(ERROR) D Q - .I $D(SEE)=1 - ;-Extracting Value of Nodes in file - I $D(ERROR) Q - D GETS^DIQ(810.3,IEN,"**","EI","^TMP(""PXRM7"",$J)") - D ORCSEG - ;******Add NTE segment to end of message ******* - ;******change 3rd piece of ORC segement to L (last)**** - S NTE="NTE||"_LAST_"||" - S ^TMP("HLS",$J,LINE)=NTE,LINE=LINE+1 - I SEE=1 W !,NTE - K NTE,LAST - S ORC=$G(^TMP("HLS",$J,1)),$P(ORC,"|",3)="F"_ORCCNT,^TMP("HLS",$J,1)=ORC - ;*********************************************** - ;*******TURN ON BELOW TO TRANSMIT TO AUSTIN ***** - D EN^PXRM7M1(.ID) - ;*********************************************** - K ^TMP("PXRM7",$J) - K ^TMP("HLS",$J) - K ^TMP("PXRM7HLORC",$J) - ;********KILL LEFT OVER ARRAYS AND VARIABLES***** - K HL("EID"),HLA("HLS"),PROTIEN,PXRM7,PXRM77,PXRM7ID,PXRM7R,ZMID - K DA,DISYS,DISYS,EO,HL("EIDS"),HLECH,HLFS,HLN,HLQ,HLSAN,HLX - K IENIEN,IENOBR,IENX,IENY,IENZ,L,LINE,NEXT,QTI,RFS,SEQ - K STATION,USI - ;************************************************** - Q -ORCSEG ;CREATE ORC SEGMENTS - ;ORDERED IN ORDER OF APPEARANCE IN SEGMENT - ;QTI=QUANTITY AND TIMING - ;EO=ENTERING ORGANIZATION - ;--Below adds extra line feed in front of the message. -- - ;--------------------------------------------------- - S IENY=IEN_"," - ;--------------------------------------------- - ;0 PLACER ORDER NUMBER ORC.2.1 - S $P(ORC,"|",3)="P1" - ;--------------------------------------------- - ;1 REPORTING PERIOD ORC.7.1.1 - S QTI(1)=$G(^TMP("PXRM7",$J,810.3,IENY,3,"E")) - S $P(QTI,"~",1)=QTI(1) - ;--------------------------------------------- - ;2 QUARTER ORC.7.3 - S QTI(3)=$G(^TMP("PXRM7",$J,810.3,IENY,7,"E")) - S $P(QTI,"~",3)=QTI(3) - ;--------------------------------------------- - ;3 BEGINNING DATE ORC.7.4.1 - S QTI(4)=$$HLDATE^HLFNC($G(^TMP("PXRM7",$J,810.3,IENY,.02,"I")),"DT") - S $P(QTI,"~",4)=QTI(4) - ;--------------------------------------------- - ;4 ENDING DATE ORC.7.5.1 - S QTI(5)=$$HLDATE^HLFNC($G(^TMP("PXRM7",$J,810.3,IENY,.03,"I")),"DT") - S $P(QTI,"~",5)=QTI(5) - ;--------------------------------------------- - ;5 REPORTING YEAR ORC.7.11.2 - S QTI(11)="&"_$G(^TMP("PXRM7",$J,810.3,IENY,4,"E")) - S $P(QTI,"~",11)=QTI(11) - ;--------------------------------------------- - ;6 EXTRACT DATE ORC.9.1 - S $P(ORC,"|",10)=$$HLDATE^HLFNC($G(^TMP("PXRM7",$J,810.3,IENY,.06,"I")),"DT") - ;--------------------------------------------- - ;7 NAME ORC.17.2 - S EO(2)=$G(^TMP("PXRM7",$J,810.3,IENY,.01,"E")) - S $P(EO,"~",2)=EO(2) - ;--------------------------------------------- - ;8 REPORT EXTRACT PARAMETER ORC.17.5 - S EO(5)=$G(^TMP("PXRM7",$J,810.3,IENY,1,"E")) - S $P(EO,"~",5)=EO(5) - ;--------------------------------------------- - ;9 REPORT EXTRACT TYPE ORC.18.2 - S $P(ORC,"|",19)="~"_$G(^TMP("PXRM7",$J,810.3,IENY,2,"E")) - ;--------------------------------------------- - ;FINISH POPULATING ORC SEGMENT - S $P(ORC,"|",8)=QTI - S $P(ORC,"|",18)=EO - S $P(ORC,"|",1)="ORC" - ;--------------------------------------------- - ;SET HL7 TMP ARRAY AND SHOW SEGMENT - S ^TMP("HLS",$J,LINE)=ORC,LINE=LINE+1 - I SEE=1 W !,ORC - S ^TMP("PXRM7HLORC",$J)=ORC - K ORC -OBRSEG ;CREATE OBR SEGMENTS - ;N IENOBR,SEQ,USI,QTI,NEXT,STATION - ;USI=UNIVERSAL SERVICE ID - ;RFS=REASON FOR STUDY - ; - S NEXT=1,LAST=0 - S IENOBR=0 F S IENOBR=$O(^PXRMXT(810.3,IEN,3,IENOBR)) Q:IENOBR<1 D - .S IENIEN=-1 F S IENIEN=$O(^PXRMXT(810.3,IEN,3,IENOBR,1,IENIEN)) Q:IENIEN="B" D Q:IENIEN="" - ..S L=$S(IENIEN=0:1,IENIEN>0:2,IENIEN="":1,1:"") - ..;###---Set Sequence Number - ..S IENX=IENOBR_","_IEN_"," - ..S IENZ=IENIEN_","_IENOBR_","_IEN_"," - ..S SEQ=$G(^TMP("PXRM7",$J,810.33,IENX,.01,"E")) - ..S OBR(+SEQ_L)="OBR|1|||||||||||||||||||||||||||||||" - ..S $P(OBR(+SEQ_L),"|",2)=NEXT,LAST=NEXT,NEXT=NEXT+1 - ..;-------------------------------------------------- - ..;10 COUNT TYPE OBR.4.2 - ..;R=REMINDER COUNTS F=FINDING COUNTS - ..S USI(2)=$S(L=1:"R",L=2:"F",1:"") - ..S $P(USI,"~",2)=USI(2) - ..;-------------------------------------------------- - ..;11 REMINDER OBR.4.5 - ..S USI(5)=$G(^TMP("PXRM7",$J,810.33,IENX,.02,"E")) - ..S $P(USI,"~",5)=USI(5) - ..;-------------------------------------------------- - ..;12 STATION OBR.3.1 - ..S STATION=$G(^TMP("PXRM7",$J,810.33,IENX,.03,"I"))_"," - ..D GETS^DIQ(4,STATION,"**","E","^TMP(""PXRM7"",$J)") - ..S $P(OBR(+SEQ_L),"|",4)=$G(^TMP("PXRM7",$J,4,STATION,99,"E")) - ..;-------------------------------------------------- - ..;13 PATIENT LIST OBR.31.2 - ..S RFS(2)=$G(^TMP("PXRM7",$J,810.33,IENX,.04,"E")) - ..S $P(RFS,"~",2)=RFS(2) - ..;-------------------------------------------------- - ..;19 REMINDER TERM OBR.31.1 - ..S RFS(1)=$S(L=2:$G(^TMP("PXRM7",$J,810.331,IENZ,.02,"E")),1:"") - ..S $P(RFS,"~",1)=RFS(1) - ..;-------------------------------------------------- - ..;20 FINDING TOTAL TYPE OBR.31.4 - ..S RFS(4)=$S(L=2:$G(^TMP("PXRM7",$J,810.331,IENZ,.03,"E")),1:"") - ..S $P(RFS,"~",4)=RFS(4) - ..;-------------------------------------------------- - ..;21 GROUP NAME OBR.31.5 - ..S RFS(5)=$S(L=2:$G(^TMP("PXRM7",$J,810.331,IENZ,.04,"E")),1:"") - ..S $P(RFS,"~",5)=RFS(5) - ..;-------------------------------------------------- - ..;22 REMINDER STATUS OBR.4.4 - ..S USI(4)=$S(L=2:$G(^TMP("PXRM7",$J,810.331,IENZ,.05,"I")),1:"") - ..S $P(USI,"~",4)=USI(4) - ..;------------------------------------------------- - ..;FINISH POPULATING OBR SEGMENT - ..S $P(OBR(+SEQ_L),"|",5)=USI - ..S $P(OBR(+SEQ_L),"|",32)=RFS - ..;------------------------------------------------- - ..;---Set message in HL7 array - ..;I $L($G(OBR(+SEQ_L)))=255 S OBR(+SEQ_L)=OBR(+SEQ_L)_"|||" - ..S ^TMP("HLS",$J,LINE)=$G(OBR(+SEQ_L)),LINE=LINE+1 - ..; - ..I SEE=1 W !," ",OBR(+SEQ_L) - ..K OBR - ..D OBXSEG - ..D SPLIT - ..I (L=1)&(IENIEN="") Q - Q -OBXSEG ;CREATE THE OBX SEGMENTS - N TERM - ;OV=OBSERVATION VALUE - S $P(OBX(+SEQ_L),"|",3)="MO" - S $P(OBX(+SEQ_L),"|",1)="OBX" - ;--------------------------------------------------- - ;###---SET SEQUENCE NUMBER - S $P(OBX(+SEQ_L),"|",2)=1 - ;--------------------------------------------------- - ;14 TOTAL PATIENTS EVALUATED - REMINDER OBX.5.1 - I L=1 D - .S TERM="TOTAL PATIENTS EVALUATED" - .S OV(1)=$G(^TMP("PXRM7",$J,810.33,IENX,2,"E"))_"~"_TERM - .S $P(OV,"^",1)=OV(1) - ;--------------------------------------------------- - ;15 TOTAL PATIENTS APPLICABLE - REMINDER OBX.5.2 - I L=1 D - .S TERM="TOTAL PATIENTS APPLICABLE" - .S OV(2)=$G(^TMP("PXRM7",$J,810.33,IENX,3,"E"))_"~"_TERM - .S $P(OV,"^",2)=OV(2) - ;--------------------------------------------------- - ;16 TOTAL PATIENTS NOT APPLICABLE - REMINDER OBX.5.3 - I L=1 D - .S TERM="TOTAL PATIENTS NOT APPLICABLE" - .S OV(3)=$G(^TMP("PXRM7",$J,810.33,IENX,4,"E"))_"~"_TERM - .S $P(OV,"^",3)=OV(3) - ;--------------------------------------------------- - ;17 TOTAL PATIENTS DUE - REMINDER OBX.5.4 - I L=1 D - .S TERM="TOTAL PATIENTS DUE" - .S OV(4)=$G(^TMP("PXRM7",$J,810.33,IENX,5,"E"))_"~"_TERM - .S $P(OV,"^",4)=OV(4) - ;--------------------------------------------------- - ;18 TOTAL PATIENTS NOT DUE - REMINDER OBX.5.5 - I L=1 D - .S TERM="TOTAL PATIENTS NOT DUE" - .S OV(5)=$G(^TMP("PXRM7",$J,810.33,IENX,6,"E"))_"~"_TERM - .S $P(OV,"^",5)=OV(5) - ;--------------------------------------------------- - ;23 TOTAL COUNT - FINDING OBX.5.1 - I L=2 D - .S TERM="TOTAL COUNT" - .S OV(1)=$G(^TMP("PXRM7",$J,810.331,IENZ,1,"E"))_"~"_TERM - .S $P(OV,"^",1)=OV(1) - ;--------------------------------------------------- - ;24 APPLICABLE COUNT - FINDING OBX.5.2 - I L=2 D - .S TERM="APPLICABLE COUNT" - .S OV(2)=$G(^TMP("PXRM7",$J,810.331,IENZ,2,"E"))_"~"_TERM - .S $P(OV,"^",2)=OV(2) - ;--------------------------------------------------- - ;25 NOT APPLICABLE COUNT- FINDING OBX.5.3 - I L=2 D - .S TERM="NOT APPLICABLE COUNT" - .S OV(3)=$G(^TMP("PXRM7",$J,810.331,IENZ,3,"E"))_"~"_TERM - .S $P(OV,"^",3)=OV(3) - ;--------------------------------------------------- - ;26 DUE COUNT - FINDING OBX.5.4 - I L=2 D - .S TERM="DUE COUNT" - .S OV(4)=$G(^TMP("PXRM7",$J,810.331,IENZ,4,"E"))_"~"_TERM - .S $P(OV,"^",4)=OV(4) - ;--------------------------------------------------- - ;27 NOT DUE COUNT - FINDING OBX.5.5 - I L=2 D - .S TERM="NOT DUE COUNT" - .S OV(5)=$G(^TMP("PXRM7",$J,810.331,IENZ,5,"E"))_"~"_TERM - .S $P(OV,"^",5)=OV(5) - ;--------------------------------------------------- - ;FINISH POPULATING OBX SEGMENT - S $P(OBX(+SEQ_L),"|",6)=OV - K OV - ;--------------------------------------------------- - ;###---Set message in HL7 array - S ^TMP("HLS",$J,LINE)=$G(OBX(+SEQ_L)),LINE=LINE+1 - ; - I SEE=1 W !," ",OBX(+SEQ_L) - K OBX - ;--------------------------------------------------- - Q +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 + ; + ;VARIABLE LIST + ;IEN = IEN OF ENTRY IN EXTRACT FILE 810.3 + Q +SPLIT ;SPLIT MESSAGES + N ORC2 + I LINE>100 D + .S ORCCNT=ORCCNT+1 + .D EN^PXRM7M1(.ID) + .K ^TMP("HLS",$J) + .S ORC2=$G(^TMP("PXRM7HLORC",$J)) + .S $P(ORC2,"|",3)="P"_ORCCNT,ORC=ORC2 + .S LINE=2 + .I $D(SEE) W !,ORC + .S ^TMP("HLS",$J,1)=ORC + Q + ; +EXTRACT(IEN,SEE,ID,MODE) ; + N ORCCNT + K ERROR,LINE + S ORCCNT=1 ;Count of ORC segments or number of messages created + S LINE=1 ;Line count for the ^TMP("HL7",$J,LINE) global variable + ;-Verify Values + I '$D(^PXRMXT(810.3,IEN)) S ERROR(1)="No Such IEN in file 810.3 "_IEN + I $D(ERROR) D Q + .I $D(SEE)=1 + ;-Extracting Value of Nodes in file + I $D(ERROR) Q + D GETS^DIQ(810.3,IEN,"**","EI","^TMP(""PXRM7"",$J)") + D ORCSEG + ;******Add NTE segment to end of message ******* + ;******change 3rd piece of ORC segement to L (last)**** + S NTE="NTE||"_LAST_"||" + S ^TMP("HLS",$J,LINE)=NTE,LINE=LINE+1 + I SEE=1 W !,NTE + K NTE,LAST + S ORC=$G(^TMP("HLS",$J,1)),$P(ORC,"|",3)="F"_ORCCNT,^TMP("HLS",$J,1)=ORC + ;*********************************************** + ;*******TURN ON BELOW TO TRANSMIT TO AUSTIN ***** + D EN^PXRM7M1(.ID) + ;*********************************************** + K ^TMP("PXRM7",$J) + K ^TMP("HLS",$J) + K ^TMP("PXRM7HLORC",$J) + ;********KILL LEFT OVER ARRAYS AND VARIABLES***** + K HL("EID"),HLA("HLS"),PROTIEN,PXRM7,PXRM77,PXRM7ID,PXRM7R,ZMID + K DA,DISYS,DISYS,EO,HL("EIDS"),HLECH,HLFS,HLN,HLQ,HLSAN,HLX + K IENIEN,IENOBR,IENX,IENY,IENZ,L,LINE,NEXT,QTI,RFS,SEQ + K STATION,USI + ;************************************************** + Q +ORCSEG ;CREATE ORC SEGMENTS + ;ORDERED IN ORDER OF APPEARANCE IN SEGMENT + ;QTI=QUANTITY AND TIMING + ;EO=ENTERING ORGANIZATION + ;--Below adds extra line feed in front of the message. -- + ;--------------------------------------------------- + S IENY=IEN_"," + ;--------------------------------------------- + ;0 PLACER ORDER NUMBER ORC.2.1 + S $P(ORC,"|",3)="P1" + ;--------------------------------------------- + ;1 REPORTING PERIOD ORC.7.1.1 + S QTI(1)=$G(^TMP("PXRM7",$J,810.3,IENY,3,"E")) + S $P(QTI,"~",1)=QTI(1) + ;--------------------------------------------- + ;2 QUARTER ORC.7.3 + S QTI(3)=$G(^TMP("PXRM7",$J,810.3,IENY,7,"E")) + S $P(QTI,"~",3)=QTI(3) + ;--------------------------------------------- + ;3 BEGINNING DATE ORC.7.4.1 + S QTI(4)=$$HLDATE^HLFNC($G(^TMP("PXRM7",$J,810.3,IENY,.02,"I")),"DT") + S $P(QTI,"~",4)=QTI(4) + ;--------------------------------------------- + ;4 ENDING DATE ORC.7.5.1 + S QTI(5)=$$HLDATE^HLFNC($G(^TMP("PXRM7",$J,810.3,IENY,.03,"I")),"DT") + S $P(QTI,"~",5)=QTI(5) + ;--------------------------------------------- + ;5 REPORTING YEAR ORC.7.11.2 + S QTI(11)="&"_$G(^TMP("PXRM7",$J,810.3,IENY,4,"E")) + S $P(QTI,"~",11)=QTI(11) + ;--------------------------------------------- + ;6 EXTRACT DATE ORC.9.1 + S $P(ORC,"|",10)=$$HLDATE^HLFNC($G(^TMP("PXRM7",$J,810.3,IENY,.06,"I")),"DT") + ;--------------------------------------------- + ;7 NAME ORC.17.2 + S EO(2)=$G(^TMP("PXRM7",$J,810.3,IENY,.01,"E")) + S $P(EO,"~",2)=EO(2) + ;--------------------------------------------- + ;8 REPORT EXTRACT PARAMETER ORC.17.5 + S EO(5)=$G(^TMP("PXRM7",$J,810.3,IENY,1,"E")) + S $P(EO,"~",5)=EO(5) + ;--------------------------------------------- + ;9 REPORT EXTRACT TYPE ORC.18.2 + S $P(ORC,"|",19)="~"_$G(^TMP("PXRM7",$J,810.3,IENY,2,"E")) + ;--------------------------------------------- + ;FINISH POPULATING ORC SEGMENT + S $P(ORC,"|",8)=QTI + S $P(ORC,"|",18)=EO + S $P(ORC,"|",1)="ORC" + ;--------------------------------------------- + ;SET HL7 TMP ARRAY AND SHOW SEGMENT + S ^TMP("HLS",$J,LINE)=ORC,LINE=LINE+1 + I SEE=1 W !,ORC + S ^TMP("PXRM7HLORC",$J)=ORC + K ORC +OBRSEG ;CREATE OBR SEGMENTS + ;N IENOBR,SEQ,USI,QTI,NEXT,STATION + ;USI=UNIVERSAL SERVICE ID + ;RFS=REASON FOR STUDY + ; + S NEXT=1,LAST=0 + S IENOBR=0 F S IENOBR=$O(^PXRMXT(810.3,IEN,3,IENOBR)) Q:IENOBR<1 D + .S IENIEN=-1 F S IENIEN=$O(^PXRMXT(810.3,IEN,3,IENOBR,1,IENIEN)) Q:IENIEN="B" D Q:IENIEN="" + ..S L=$S(IENIEN=0:1,IENIEN>0:2,IENIEN="":1,1:"") + ..;###---Set Sequence Number + ..S IENX=IENOBR_","_IEN_"," + ..S IENZ=IENIEN_","_IENOBR_","_IEN_"," + ..S SEQ=$G(^TMP("PXRM7",$J,810.33,IENX,.01,"E")) + ..S OBR(+SEQ_L)="OBR|1|||||||||||||||||||||||||||||||" + ..S $P(OBR(+SEQ_L),"|",2)=NEXT,LAST=NEXT,NEXT=NEXT+1 + ..;-------------------------------------------------- + ..;10 COUNT TYPE OBR.4.2 + ..;R=REMINDER COUNTS F=FINDING COUNTS + ..S USI(2)=$S(L=1:"R",L=2:"F",1:"") + ..S $P(USI,"~",2)=USI(2) + ..;-------------------------------------------------- + ..;11 REMINDER OBR.4.5 + ..S USI(5)=$G(^TMP("PXRM7",$J,810.33,IENX,.02,"E")) + ..S $P(USI,"~",5)=USI(5) + ..;-------------------------------------------------- + ..;12 STATION OBR.3.1 + ..S STATION=$G(^TMP("PXRM7",$J,810.33,IENX,.03,"I"))_"," + ..D GETS^DIQ(4,STATION,"**","E","^TMP(""PXRM7"",$J)") + ..S $P(OBR(+SEQ_L),"|",4)=$G(^TMP("PXRM7",$J,4,STATION,99,"E")) + ..;-------------------------------------------------- + ..;13 PATIENT LIST OBR.31.2 + ..S RFS(2)=$G(^TMP("PXRM7",$J,810.33,IENX,.04,"E")) + ..S $P(RFS,"~",2)=RFS(2) + ..;-------------------------------------------------- + ..;19 REMINDER TERM OBR.31.1 + ..S RFS(1)=$S(L=2:$G(^TMP("PXRM7",$J,810.331,IENZ,.02,"E")),1:"") + ..S $P(RFS,"~",1)=RFS(1) + ..;-------------------------------------------------- + ..;20 FINDING TOTAL TYPE OBR.31.4 + ..S RFS(4)=$S(L=2:$G(^TMP("PXRM7",$J,810.331,IENZ,.03,"E")),1:"") + ..S $P(RFS,"~",4)=RFS(4) + ..;-------------------------------------------------- + ..;21 GROUP NAME OBR.31.5 + ..S RFS(5)=$S(L=2:$G(^TMP("PXRM7",$J,810.331,IENZ,.04,"E")),1:"") + ..S $P(RFS,"~",5)=RFS(5) + ..;-------------------------------------------------- + ..;22 REMINDER STATUS OBR.4.4 + ..S USI(4)=$S(L=2:$G(^TMP("PXRM7",$J,810.331,IENZ,.05,"I")),1:"") + ..S $P(USI,"~",4)=USI(4) + ..;------------------------------------------------- + ..;FINISH POPULATING OBR SEGMENT + ..S $P(OBR(+SEQ_L),"|",5)=USI + ..S $P(OBR(+SEQ_L),"|",32)=RFS + ..;------------------------------------------------- + ..;---Set message in HL7 array + ..;I $L($G(OBR(+SEQ_L)))=255 S OBR(+SEQ_L)=OBR(+SEQ_L)_"|||" + ..S ^TMP("HLS",$J,LINE)=$G(OBR(+SEQ_L)),LINE=LINE+1 + ..; + ..I SEE=1 W !," ",OBR(+SEQ_L) + ..K OBR + ..D OBXSEG + ..D SPLIT + ..I (L=1)&(IENIEN="") Q + Q +OBXSEG ;CREATE THE OBX SEGMENTS + N TERM + ;OV=OBSERVATION VALUE + S $P(OBX(+SEQ_L),"|",3)="MO" + S $P(OBX(+SEQ_L),"|",1)="OBX" + ;--------------------------------------------------- + ;###---SET SEQUENCE NUMBER + S $P(OBX(+SEQ_L),"|",2)=1 + ;--------------------------------------------------- + ;14 TOTAL PATIENTS EVALUATED - REMINDER OBX.5.1 + I L=1 D + .S TERM="TOTAL PATIENTS EVALUATED" + .S OV(1)=$G(^TMP("PXRM7",$J,810.33,IENX,2,"E"))_"~"_TERM + .S $P(OV,"^",1)=OV(1) + ;--------------------------------------------------- + ;15 TOTAL PATIENTS APPLICABLE - REMINDER OBX.5.2 + I L=1 D + .S TERM="TOTAL PATIENTS APPLICABLE" + .S OV(2)=$G(^TMP("PXRM7",$J,810.33,IENX,3,"E"))_"~"_TERM + .S $P(OV,"^",2)=OV(2) + ;--------------------------------------------------- + ;16 TOTAL PATIENTS NOT APPLICABLE - REMINDER OBX.5.3 + I L=1 D + .S TERM="TOTAL PATIENTS NOT APPLICABLE" + .S OV(3)=$G(^TMP("PXRM7",$J,810.33,IENX,4,"E"))_"~"_TERM + .S $P(OV,"^",3)=OV(3) + ;--------------------------------------------------- + ;17 TOTAL PATIENTS DUE - REMINDER OBX.5.4 + I L=1 D + .S TERM="TOTAL PATIENTS DUE" + .S OV(4)=$G(^TMP("PXRM7",$J,810.33,IENX,5,"E"))_"~"_TERM + .S $P(OV,"^",4)=OV(4) + ;--------------------------------------------------- + ;18 TOTAL PATIENTS NOT DUE - REMINDER OBX.5.5 + I L=1 D + .S TERM="TOTAL PATIENTS NOT DUE" + .S OV(5)=$G(^TMP("PXRM7",$J,810.33,IENX,6,"E"))_"~"_TERM + .S $P(OV,"^",5)=OV(5) + ;--------------------------------------------------- + ;23 TOTAL COUNT - FINDING OBX.5.1 + I L=2 D + .S TERM="TOTAL COUNT" + .S OV(1)=$G(^TMP("PXRM7",$J,810.331,IENZ,1,"E"))_"~"_TERM + .S $P(OV,"^",1)=OV(1) + ;--------------------------------------------------- + ;24 APPLICABLE COUNT - FINDING OBX.5.2 + I L=2 D + .S TERM="APPLICABLE COUNT" + .S OV(2)=$G(^TMP("PXRM7",$J,810.331,IENZ,2,"E"))_"~"_TERM + .S $P(OV,"^",2)=OV(2) + ;--------------------------------------------------- + ;25 NOT APPLICABLE COUNT- FINDING OBX.5.3 + I L=2 D + .S TERM="NOT APPLICABLE COUNT" + .S OV(3)=$G(^TMP("PXRM7",$J,810.331,IENZ,3,"E"))_"~"_TERM + .S $P(OV,"^",3)=OV(3) + ;--------------------------------------------------- + ;26 DUE COUNT - FINDING OBX.5.4 + I L=2 D + .S TERM="DUE COUNT" + .S OV(4)=$G(^TMP("PXRM7",$J,810.331,IENZ,4,"E"))_"~"_TERM + .S $P(OV,"^",4)=OV(4) + ;--------------------------------------------------- + ;27 NOT DUE COUNT - FINDING OBX.5.5 + I L=2 D + .S TERM="NOT DUE COUNT" + .S OV(5)=$G(^TMP("PXRM7",$J,810.331,IENZ,5,"E"))_"~"_TERM + .S $P(OV,"^",5)=OV(5) + ;--------------------------------------------------- + ;FINISH POPULATING OBX SEGMENT + S $P(OBX(+SEQ_L),"|",6)=OV + K OV + ;--------------------------------------------------- + ;###---Set message in HL7 array + S ^TMP("HLS",$J,LINE)=$G(OBX(+SEQ_L)),LINE=LINE+1 + ; + I SEE=1 W !," ",OBX(+SEQ_L) + K OBX + ;--------------------------------------------------- + Q diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMCDUE.m b/r/CLINICAL_REMINDERS-PXRM/PXRMCDUE.m index f7593c58..385db3b4 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMCDUE.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMCDUE.m @@ -1,166 +1,165 @@ -PXRMCDUE ;SLC/PKR - Custom date due calculation routines. ;09/05/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ;======================================================== -CDBUILD(STRING,DA) ;Given a custom date due string build the data - ;structure. This is called by a new-style cross-reference after - ;the date due string has passed the input transform so we don't need - ;to validate the elements. - ;Do not execute as part of a verify fields. - I $G(DIUTIL)="VERIFY FIELDS" Q - ;Do not execute as part of exchange. - I $G(PXRMEXCH) Q - N FDA,FILIST,FREQLIST,FUNCTION,IENB,IENS,IND,MSG,NARGS,PFSTACK - S STRING=$$UP^XLFSTR(STRING) - D PARSE(STRING,.FUNCTION,.NARGS,.FILIST,.FREQLIST) - S IENS=DA_"," - S FDA(811.9,IENS,46)=FUNCTION,FDA(811.9,IENS,47)=NARGS - S IENB=DA - F IND=1:1:NARGS D - . S IENB=IENB+1 - . S IENS="+"_IENB_","_DA_"," - . S FDA(811.948,IENS,.01)=FILIST(IND) - . S FDA(811.948,IENS,.02)=FREQLIST(IND) - D UPDATE^DIE("","FDA","","MSG") - I $D(MSG) D - . W !,"The update failed, UPDATE^DIE returned the following error message:" - . D AWRITE^PXRMUTIL("MSG") - Q - ; - ;======================================================== -CDUEDATE(DEFARR,FIEVAL) ;Do the custom date due calculation and return - ;the due date. - N DATE,DDUE,DLIST,FI,FREQ,FUNCTION,IND,NARGS,TEMP - S FUNCTION=$P(DEFARR(46),U,1) - S NARGS=$P(DEFARR(46),U,2) - F IND=1:1:NARGS D - . S TEMP=DEFARR(47,IND,0) - . 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 DLIST(IND)=$$NEWDATE^PXRMDATE(DATE,FREQ) - S TEMP=$S(FUNCTION="MAX_DATE":$$MAXDATE(NARGS,.DLIST),FUNCTION="MIN_DATE":$$MINDATE(NARGS,.DLIST),1:0) - S DDUE=$P(TEMP,U,1) - I DDUE=0 Q -1 - S IND=$P(TEMP,U,2) - S TEMP=DEFARR(47,IND,0) - S FI=$P(TEMP,U,1) - S FREQ=$P(TEMP,U,2) - S DATE=+$G(FIEVAL(FI,"DATE")) - S ^TMP(PXRMPID,$J,PXRMITEM,"zCDUE")=FI_U_FREQ_U_DATE - Q DDUE - ; - ;======================================================== -CDKILL(X,DA) ; - ;Do not execute as part of a verify fields. - I $G(DIUTIL)="VERIFY FIELDS" Q - ;Do not execute as part of exchange. - I $G(PXRMEXCH) Q - K ^PXD(811.9,DA,46),^PXD(811.9,DA,47) - Q - ; - ;======================================================== -MAXDATE(NARGS,DLIST) ;Return the maximum date from a list of dates in DLIST. - N IND,INDS,MAXDATE - S (INDS,MAXDATE)=0 - F IND=1:1:NARGS I DLIST(IND)>MAXDATE S MAXDATE=DLIST(IND),INDS=IND - Q MAXDATE_U_INDS - ; - ;======================================================== -MINDATE(NARGS,DLIST) ;Return the minimum date from a list of dates in DLIST. - ;Only return 0 if there is no "real" date in the list. - N DATE,IND,INDS,MINDATE - S INDS=0 - S MINDATE=9991231 - F IND=1:1:NARGS S DATE=DLIST(IND) I DATE245 Q 0 - N FILIST,FREQLIST,FUNCTION,IND,NARGS,TEXT,VALID - D PARSE(STRING,.FUNCTION,.NARGS,.FILIST,.FREQLIST) - S VALID=1 - I FUNCTION'="MIN_DATE",FUNCTION'="MAX_DATE" D - . S TEXT=FUNCTION_" is not a valid custom date due function" - . D EN^DDIOL(TEXT) - . S VALID=0 - F IND=1:1:NARGS D - . I '$D(^PXD(811.9,DA,20,FILIST(IND),0)) D - .. S TEXT="Finding number "_FILIST(IND)_" is not a valid reminder finding" - .. D EN^DDIOL(TEXT) - .. S VALID=0 - . I '$$VFREQ(FREQLIST(IND)) D - .. S TEXT=FREQLIST(IND)_" is not a valid frequency" - .. D EN^DDIOL(TEXT) - .. S VALID=0 - Q VALID - ; - ;======================================================== -XHELP ;Executable help for custom date due. - N DONE,IND,TEXT - S DONE=0 - F IND=1:1 Q:DONE D - . S TEXT=$P($T(TEXT+IND),";",3) - . I TEXT="**End Text**" S DONE=1 Q - . W !,TEXT - Q - ; - ;======================================================== -TEXT ;Custom Date Due help text. - ;;The general form for a Custom Date Due string is: - ;; FUNCTION(ARG1,ARG2,...,ARGN) - ;;where FUNCTION is MAX_DATE or MIN_DATE and the arguments have the form - ;;M+FREQ where M is a finding number and FREQ is a number followed by - ;;D for days, M for months, or Y for years. - ;;Here is an example: - ;; MAX_DATE(1+6M,3+1Y) - ;;This will take the date of finding 1 and add 6 months, the date of finding 3 - ;;and add 1 year and set the date due to the maximum of those two dates. - ;; - ;;**End Text** - Q - ; +PXRMCDUE ;SLC/PKR - Custom date due calculation routines. ;06/30/2006 + ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21 + ; + ;======================================================== +CDBUILD(STRING,DA) ;Given a custom date due string build the data + ;structure. This is called by a new-style cross-reference after + ;the date due string has passed the input transform so we don't need + ;to validate the elements. + ;Do not execute as part of a verify fields. + I $G(DIUTIL)="VERIFY FIELDS" Q + ;Do not execute as part of exchange. + I $G(PXRMEXCH) Q + N FDA,FILIST,FREQLIST,FUNCTION,IENB,IENS,IND,MSG,NARGS,PFSTACK + S STRING=$$UP^XLFSTR(STRING) + D PARSE(STRING,.FUNCTION,.NARGS,.FILIST,.FREQLIST) + S IENS=DA_"," + S FDA(811.9,IENS,46)=FUNCTION,FDA(811.9,IENS,47)=NARGS + S IENB=DA + F IND=1:1:NARGS D + . S IENB=IENB+1 + . S IENS="+"_IENB_","_DA_"," + . S FDA(811.948,IENS,.01)=FILIST(IND) + . S FDA(811.948,IENS,.02)=FREQLIST(IND) + D UPDATE^DIE("","FDA","","MSG") + I $D(MSG) D + . W !,"The update failed, UPDATE^DIE returned the following error message:" + . D AWRITE^PXRMUTIL("MSG") + Q + ; + ;======================================================== +CDUEDATE(DEFARR,FIEVAL) ;Do the custom date due calculation and return + ;the due date. + N DATE,DDUE,DLIST,FI,FREQ,FUNCTION,IND,NARGS,TEMP + S FUNCTION=$P(DEFARR(46),U,1) + S NARGS=$P(DEFARR(46),U,2) + F IND=1:1:NARGS D + . S TEMP=DEFARR(47,IND,0) + . S FI=$P(TEMP,U,1) + . S FREQ=$P(TEMP,U,2) + . 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)) + S DDUE=$P(TEMP,U,1) + I DDUE=0 Q -1 + S IND=$P(TEMP,U,2) + S TEMP=DEFARR(47,IND,0) + S FI=$P(TEMP,U,1) + S FREQ=$P(TEMP,U,2) + S DATE=+$G(FIEVAL(FI,"DATE")) + S ^TMP(PXRMPID,$J,PXRMITEM,"zCDUE")=FI_U_FREQ_U_DATE + Q DDUE + ; + ;======================================================== +CDKILL(X,DA) ; + ;Do not execute as part of a verify fields. + I $G(DIUTIL)="VERIFY FIELDS" Q + ;Do not execute as part of exchange. + I $G(PXRMEXCH) Q + K ^PXD(811.9,DA,46),^PXD(811.9,DA,47) + Q + ; + ;======================================================== +MAXDATE(NARGS,DLIST) ;Return the maximum date from a list of dates in DLIST. + N IND,INDS,MAXDATE + S (INDS,MAXDATE)=0 + F IND=1:1:NARGS I DLIST(IND)>MAXDATE S MAXDATE=DLIST(IND),INDS=IND + Q MAXDATE_U_INDS + ; + ;======================================================== +MINDATE(NARGS,DLIST) ;Return the minimum date from a list of dates in DLIST. + ;Only return 0 if there is no "real" date in the list. + N DATE,IND,INDS,MINDATE + S INDS=0 + S MINDATE=9991231 + F IND=1:1:NARGS S DATE=DLIST(IND) I DATE245 Q 0 + N FILIST,FREQLIST,FUNCTION,IND,NARGS,TEXT,VALID + D PARSE(STRING,.FUNCTION,.NARGS,.FILIST,.FREQLIST) + S VALID=1 + I FUNCTION'="MIN_DATE",FUNCTION'="MAX_DATE" D + . S TEXT=FUNCTION_" is not a valid custom date due function" + . D EN^DDIOL(TEXT) + . S VALID=0 + F IND=1:1:NARGS D + . I '$D(^PXD(811.9,DA,20,FILIST(IND),0)) D + .. S TEXT="Finding number "_FILIST(IND)_" is not a valid reminder finding" + .. D EN^DDIOL(TEXT) + .. S VALID=0 + . I '$$VFREQ(FREQLIST(IND)) D + .. S TEXT=FREQLIST(IND)_" is not a valid frequency" + .. D EN^DDIOL(TEXT) + .. S VALID=0 + Q VALID + ; + ;======================================================== +XHELP ;Executable help for custom date due. + N DONE,IND,TEXT + S DONE=0 + F IND=1:1 Q:DONE D + . S TEXT=$P($T(TEXT+IND),";",3) + . I TEXT="**End Text**" S DONE=1 Q + . W !,TEXT + Q + ; + ;======================================================== +TEXT ;Custom Date Due help text. + ;;The general form for a Custom Date Due string is: + ;; FUNCTION(ARG1,ARG2,...,ARGN) + ;;where FUNCTION is MAX_DATE or MIN_DATE and the arguments have the form + ;;M+FREQ where M is a finding number and FREQ is a number followed by + ;;D for days, M for months, or Y for years. + ;;Here is an example: + ;; MAX_DATE(1+6M,3+1Y) + ;;This will take the date of finding 1 and add 6 months, the date of finding 3 + ;;and add 1 year and set the date due to the maximum of those two dates. + ;; + ;;**End Text** + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMCF.m b/r/CLINICAL_REMINDERS-PXRM/PXRMCF.m index 83f24998..c589e560 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMCF.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMCF.m @@ -1,195 +1,194 @@ -PXRMCF ; SLC/PKR - Handle computed findings. ;07/25/2007 - ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123 - ; - ;======================================================= -EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate computed findings. - N FIEVT,FILENUM,FINDING,FINDPA,ITEM - S FILENUM=$$GETFNUM^PXRMDATA(ENODE) - S ITEM="" - F S ITEM=$O(DEFARR("E",ENODE,ITEM)) Q:+ITEM=0 D - . S FINDING="" - . F S FINDING=$O(DEFARR("E",ENODE,ITEM,FINDING)) Q:+FINDING=0 D - .. K FINDPA - .. M FINDPA=DEFARR(20,FINDING) - .. K FIEVT - .. D FIEVAL(FILENUM,DFN,ITEM,.FINDPA,.FIEVT) - .. M FIEVAL(FINDING)=FIEVT - .. S FIEVAL(FINDING,"FINDING")=$P(FINDPA(0),U,1) - Q - ; - ;======================================================= -EVALPL(FINDPA,ENODE,TERMARR,PLIST) ;Patient list evaluator. - ;Return the list in ^TMP($J,PLIST) - N ITEM,FILENUM,PFINDPA - N TEMP,TFINDING,TFINDPA - S FILENUM=$$GETFNUM^PXRMDATA(ENODE) - S ITEM="" - F S ITEM=$O(TERMARR("E",ENODE,ITEM)) Q:+ITEM=0 D - . S TFINDING="" - . F S TFINDING=$O(TERMARR("E",ENODE,ITEM,TFINDING)) Q:+TFINDING=0 D - .. K PFINDPA,TFINDPA - .. M TFINDPA=TERMARR(20,TFINDING) - ..;Set the finding parameters. - .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA) - .. D GPLIST(FILENUM,ITEM,.PFINDPA,PLIST) - Q - ; - ;======================================================= -EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;General term - ;evaluator. - N FIEVT,FILENUM,ITEM,PFINDPA - N TEMP,TFINDING,TFINDPA - S FILENUM=$$GETFNUM^PXRMDATA(ENODE) - S ITEM="" - F S ITEM=$O(TERMARR("E",ENODE,ITEM)) Q:+ITEM=0 D - . S TFINDING="" - . F S TFINDING=$O(TERMARR("E",ENODE,ITEM,TFINDING)) Q:+TFINDING=0 D - .. K FIEVT,PFINDPA,TFINDPA - .. M TFINDPA=TERMARR(20,TFINDING) - ..;Set the finding parameters. - .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA) - .. D FIEVAL(FILENUM,DFN,ITEM,.PFINDPA,.FIEVT) - .. M TFIEVAL(TFINDING)=FIEVT - .. S TFIEVAL(TFINDING,"FINDING")=$P(TFINDPA(0),U,1) - Q - ; - ;======================================================= -FIEVAL(FILENUM,DFN,ITEM,PFINDPA,FIEVAL) ; - ;Evaluate regular patient findings. - N BDT,CASESEN,COND,CONVAL,DAS,DATA,DATE,EDT,FLIST,ICOND,IND - N NFOUND,NGET,NOCC,NP,PDATA,ROUTINE - N SAVE,SDIR,STATUSA,TEMP,TEST,TEXT,TYPE,UCIFS,VALUE,VSLIST - ;Set the finding search parameters. - D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT) - S SDIR=$S(NOCC<0:+1,1:-1) - 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 TEMP=^PXRMD(811.4,ITEM,0) - S TYPE=$P(TEMP,U,5) - I TYPE="" S TYPE="S" - I TYPE="S" D - . S ROUTINE=$P(TEMP,U,3)_"^"_$P(TEMP,U,2)_"(DFN,.TEST,.DATE,.VALUE,.TEXT)" - . D @ROUTINE - .;Make sure that the date is in range. - . I TEST,DATE'EDT S NFOUND=1 - . E S NFOUND=0 - . I NFOUND D - .. S TEST(1)=TEST,DATE(1)=DATE,TEXT(1)=$G(TEXT) - .. S DATA(1,"VALUE")=$G(VALUE) - .. I $D(VALUE)=11 S IND="" F S IND=$O(VALUE(IND)) Q:IND="" S DATA(1,IND)=VALUE(IND) - I TYPE="M" D - . S ROUTINE=$P(TEMP,U,3)_"^"_$P(TEMP,U,2)_"(DFN,NGET,BDT,EDT,.NFOUND,.TEST,.DATE,.DATA,.TEXT)" - . D @ROUTINE - I TYPE'="S",TYPE'="M" D - . S NFOUND=0 - . S ^TMP(PXRMPID,$J,PXRMITEM,"WARNING","COMPUTED FINDING","WRONG TYPE")=TYPE_" IS NOT SUITABLE FOR REMINDER EVALUATION" - I NFOUND=0 S FIEVAL=0 Q - S NP=0 - F IND=1:1:NFOUND Q:NP=NOCC D - . I TEST(IND),COND'="" D - .. K PDATA M PDATA=DATA(IND) - .. S CONVAL=$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.PDATA) - . E S CONVAL=TEST(IND) - . S SAVE=$S('UCIFS:1,(UCIFS&CONVAL):1,1:0) - . I SAVE D - .. S NP=NP+1 - .. S FIEVAL(NP)=CONVAL - .. I COND'="" S FIEVAL(NP,"CONDITION")=CONVAL - .. S FIEVAL(NP,"DATE")=DATE(IND) - .. S FIEVAL(NP,"TEXT")=$G(TEXT(IND)) - .. M FIEVAL(NP)=DATA(IND) - .. I $G(PXRMDEBG) M FIEVAL(NP,"CSUB")=DATA(IND) - ; - ;Save the finding result. - D SFRES^PXRMUTIL(SDIR,NP,.FIEVAL) - S FIEVAL("FILE NUMBER")=FILENUM - Q - ; - ;======================================================= -GPLIST(FILENUM,CFIEN,PFINDPA,PLIST) ;Add to the patient list - ;for a regular file. - N BDT,CASESEN,COND,CONVAL,DAS,DATE,EDT,DATA,DFN,FLIST - N ICOND,IND,IPLIST - N NOCC,NOCCABS,NFOUND,NGET,NP,PARAM,ROUTINE - N SAVE,SOURCE,STATUSA,TEMP,TEXT,TGLIST,TPLIST,TYPE - N UCIFS,VALUE,VSLIST - S TEMP=^PXRMD(811.4,CFIEN,0) - S TYPE=$P(TEMP,U,5) - I TYPE'="L" Q - S TGLIST="GPLIST_PXRMCF" - S PARAM=PFINDPA(15) - S SOURCE=FILENUM_";"_CFIEN - ;Set the finding search parameters. - D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT) - S NOCCABS=$$ABS^XLFMTH(NOCC) - D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST) - S NGET=$S(UCIFS:50,$D(STATUSA):50,1:NOCCABS) - K ^TMP($J,TGLIST) - S ROUTINE=$P(TEMP,U,3)_"^"_$P(TEMP,U,2)_"(NGET,BDT,EDT,TGLIST,PARAM)" - D @ROUTINE - ;Routine should return: - ;^TMP($J,TGLIST,DFN,N)=DAS_U_DATE_U_FILENUM_U_ITEM_U_VALUE - ;Data values for condition are returned in - ;^TMP($J,TGLIST,DFN,N,SUB)=DATA(SUB) - S DFN="" - F S DFN=$O(^TMP($J,TGLIST,DFN)) Q:DFN="" D - . K TPLIST - . M TPLIST=^TMP($J,TGLIST,DFN) - . S (IND,NFOUND)=0 - . K IPLIST - . F S IND=$O(TPLIST(IND)) Q:(IND="")!(NFOUND=NOCCABS) D - .. S TEMP=TPLIST(IND) - .. K DATA M DATA=TPLIST(IND) - .. S CONVAL=$S(COND'="":$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.DATA),1:1) - .. S SAVE=$S('UCIFS:1,(UCIFS&CONVAL):1,1:0) - .. I SAVE D - ... S NFOUND=NFOUND+1 - ... S IPLIST(CONVAL,DFN,NFOUND,SOURCE)=TEMP - . M ^TMP($J,PLIST)=IPLIST - K ^TMP($J,TGLIST) - Q - ; - ;======================================================= -MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output. - N DATA,DATE,FIEN,IND,JND,NAME,NOUT,PNAME,TEMP,TEXTOUT,VALUE - S FIEN=$P(IFIEVAL("FINDING"),";",1) - S TEMP=^PXRMD(811.4,FIEN,0) - S PNAME=$P(TEMP,U,4) - I PNAME="" S PNAME=$P(TEMP,U,1) - S NAME="Computed Finding: "_PNAME_" = " - S IND=0 - F S IND=+$O(IFIEVAL(IND)) Q:IND=0 D - . S VALUE=$G(IFIEVAL(IND,"VALUE")) - . S DATE=IFIEVAL(IND,"DATE") - . S TEMP=NAME_VALUE_" ("_$$EDATE^PXRMDATE(DATE)_")" - . D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT) - . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND) - S NLINES=NLINES+1,TEXT(NLINES)="" - Q - ; - ;======================================================= -OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical - ;maintenance output. - N DATA,DATE,FIEN,IND,JND,NOUT,PNAME,TEMP,TEXTOUT,VALUE - S FIEN=$P(IFIEVAL("FINDING"),";",1) - S TEMP=^PXRMD(811.4,FIEN,0) - S PNAME=$P(TEMP,U,4) - I PNAME="" S PNAME=$P(TEMP,U,1) - S NLINES=NLINES+1 - S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Computed Finding: "_PNAME - S IND=0 - F S IND=+$O(IFIEVAL(IND)) Q:IND=0 D - . S DATE=IFIEVAL(IND,"DATE") - . S TEMP=$$EDATE^PXRMDATE(DATE) - . S VALUE=$G(IFIEVAL(IND,"VALUE")) - . I VALUE'="" S TEMP=TEMP_" value - "_VALUE - .;If there is text append it. - . I $G(IFIEVAL(IND,"TEXT"))'="" S TEMP=TEMP_"; "_IFIEVAL(IND,"TEXT") - . D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT) - . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND) - S NLINES=NLINES+1,TEXT(NLINES)="" - Q - ; +PXRMCF ; SLC/PKR - Handle computed findings. ;12/15/2004 + ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005 + ; + ;======================================================= +EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate computed findings. + N FIEVT,FILENUM,FINDING,FINDPA,ITEM + S FILENUM=$$GETFNUM^PXRMDATA(ENODE) + S ITEM="" + F S ITEM=$O(DEFARR("E",ENODE,ITEM)) Q:+ITEM=0 D + . S FINDING="" + . F S FINDING=$O(DEFARR("E",ENODE,ITEM,FINDING)) Q:+FINDING=0 D + .. K FINDPA + .. M FINDPA=DEFARR(20,FINDING) + .. K FIEVT + .. D FIEVAL(FILENUM,DFN,ITEM,.FINDPA,.FIEVT) + .. M FIEVAL(FINDING)=FIEVT + .. S FIEVAL(FINDING,"FINDING")=$P(FINDPA(0),U,1) + Q + ; + ;======================================================= +EVALPL(FINDPA,ENODE,TERMARR,PLIST) ;Patient list evaluator. + ;Return the list in ^TMP($J,PLIST) + N ITEM,FILENUM,PFINDPA + N TEMP,TFINDING,TFINDPA + S FILENUM=$$GETFNUM^PXRMDATA(ENODE) + S ITEM="" + F S ITEM=$O(TERMARR("E",ENODE,ITEM)) Q:+ITEM=0 D + . S TFINDING="" + . F S TFINDING=$O(TERMARR("E",ENODE,ITEM,TFINDING)) Q:+TFINDING=0 D + .. K PFINDPA,TFINDPA + .. M TFINDPA=TERMARR(20,TFINDING) + ..;Set the finding parameters. + .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA) + .. D GPLIST(FILENUM,ITEM,.PFINDPA,PLIST) + Q + ; + ;======================================================= +EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;General term + ;evaluator. + N FIEVT,FILENUM,ITEM,PFINDPA + N TEMP,TFINDING,TFINDPA + S FILENUM=$$GETFNUM^PXRMDATA(ENODE) + S ITEM="" + F S ITEM=$O(TERMARR("E",ENODE,ITEM)) Q:+ITEM=0 D + . S TFINDING="" + . F S TFINDING=$O(TERMARR("E",ENODE,ITEM,TFINDING)) Q:+TFINDING=0 D + .. K FIEVT,PFINDPA,TFINDPA + .. M TFINDPA=TERMARR(20,TFINDING) + ..;Set the finding parameters. + .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA) + .. D FIEVAL(FILENUM,DFN,ITEM,.PFINDPA,.FIEVT) + .. M TFIEVAL(TFINDING)=FIEVT + .. S TFIEVAL(TFINDING,"FINDING")=$P(TFINDPA(0),U,1) + Q + ; + ;======================================================= +FIEVAL(FILENUM,DFN,ITEM,PFINDPA,FIEVAL) ; + ;Evaluate regular patient findings. + N BDT,CASESEN,COND,CONVAL,DAS,DATA,DATE,EDT,FLIST,ICOND,IND + N NFOUND,NGET,NOCC,NP,PDATA,ROUTINE + N SAVE,SDIR,STATUSA,TEMP,TEST,TEXT,TYPE,UCIFS,VALUE,VSLIST + ;Set the finding search parameters. + 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:"*",$D(STATUSA):"*",1:NOCC) + S TEMP=^PXRMD(811.4,ITEM,0) + S TYPE=$P(TEMP,U,5) + I TYPE="" S TYPE="S" + I TYPE="S" D + . S ROUTINE=$P(TEMP,U,3)_"^"_$P(TEMP,U,2)_"(DFN,.TEST,.DATE,.VALUE,.TEXT)" + . D @ROUTINE + .;Make sure that the date is in range. + . I TEST,DATE'EDT S NFOUND=1 + . E S NFOUND=0 + . I NFOUND D + .. S TEST(1)=TEST,DATE(1)=DATE,TEXT(1)=$G(TEXT) + .. S DATA(1,"VALUE")=$G(VALUE) + .. I $D(VALUE)=11 S IND="" F S IND=$O(VALUE(IND)) Q:IND="" S DATA(1,IND)=VALUE(IND) + I TYPE="M" D + . S ROUTINE=$P(TEMP,U,3)_"^"_$P(TEMP,U,2)_"(DFN,NGET,BDT,EDT,.NFOUND,.TEST,.DATE,.DATA,.TEXT)" + . D @ROUTINE + I TYPE'="S",TYPE'="M" D + . S NFOUND=0 + . S ^TMP(PXRMPID,$J,PXRMITEM,"WARNING","COMPUTED FINDING","WRONG TYPE")=TYPE_" IS NOT SUITABLE FOR REMINDER EVALUATION" + I NFOUND=0 S FIEVAL=0 Q + S NP=0 + F IND=1:1:NFOUND Q:NP=NOCC D + . I TEST(IND),COND'="" D + .. K PDATA M PDATA=DATA(IND) + .. S CONVAL=$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.PDATA) + . E S CONVAL=TEST(IND) + . S SAVE=$S('UCIFS:1,(UCIFS&CONVAL):1,1:0) + . I SAVE D + .. S NP=NP+1 + .. S FIEVAL(NP)=CONVAL + .. I COND'="" S FIEVAL(NP,"CONDITION")=CONVAL + .. S FIEVAL(NP,"DATE")=DATE(IND) + .. S FIEVAL(NP,"TEXT")=$G(TEXT(IND)) + .. M FIEVAL(NP)=DATA(IND) + .. I $G(PXRMDEBG) M FIEVAL(NP,"CSUB")=DATA(IND) + ; + ;Save the finding result. + D SFRES^PXRMUTIL(SDIR,NP,.FIEVAL) + S FIEVAL("FILE NUMBER")=FILENUM + Q + ; + ;======================================================= +GPLIST(FILENUM,CFIEN,PFINDPA,PLIST) ;Add to the patient list + ;for a regular file. + N BDT,CASESEN,COND,CONVAL,DAS,DATE,EDT,DATA,DFN,FLIST + N ICOND,IND,IPLIST + N NOCC,NOCCABS,NFOUND,NGET,NP,PARAM,ROUTINE + N SAVE,SOURCE,STATUSA,TEMP,TEXT,TGLIST,TPLIST,TYPE + N UCIFS,VALUE,VSLIST + S TEMP=^PXRMD(811.4,CFIEN,0) + S TYPE=$P(TEMP,U,5) + I TYPE'="L" Q + S TGLIST="GPLIST_PXRMCF" + S PARAM=PFINDPA(15) + S SOURCE=FILENUM_";"_CFIEN + ;Set the finding search parameters. + D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT) + S NOCCABS=$$ABS^XLFMTH(NOCC) + D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST) + 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)" + D @ROUTINE + ;Routine should return: + ;^TMP($J,TGLIST,DFN,N)=DAS_U_DATE_U_FILENUM_U_ITEM_U_VALUE + ;Data values for condition are returned in + ;^TMP($J,TGLIST,DFN,N,SUB)=DATA(SUB) + S DFN="" + F S DFN=$O(^TMP($J,TGLIST,DFN)) Q:DFN="" D + . K TPLIST + . M TPLIST=^TMP($J,TGLIST,DFN) + . S (IND,NFOUND)=0 + . K IPLIST + . F S IND=$O(TPLIST(IND)) Q:(IND="")!(NFOUND=NOCCABS) D + .. S TEMP=TPLIST(IND) + .. K DATA M DATA=TPLIST(IND) + .. S CONVAL=$S(COND'="":$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.DATA),1:1) + .. S SAVE=$S('UCIFS:1,(UCIFS&CONVAL):1,1:0) + .. I SAVE D + ... S NFOUND=NFOUND+1 + ... S IPLIST(CONVAL,DFN,NFOUND,SOURCE)=TEMP + . M ^TMP($J,PLIST)=IPLIST + K ^TMP($J,TGLIST) + Q + ; + ;======================================================= +MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output. + N DATA,DATE,FIEN,IND,JND,NAME,NOUT,PNAME,TEMP,TEXTOUT,VALUE + S FIEN=$P(IFIEVAL("FINDING"),";",1) + S TEMP=^PXRMD(811.4,FIEN,0) + S PNAME=$P(TEMP,U,4) + I PNAME="" S PNAME=$P(TEMP,U,1) + S NAME="Computed Finding: "_PNAME_" = " + S IND=0 + F S IND=+$O(IFIEVAL(IND)) Q:IND=0 D + . S VALUE=$G(IFIEVAL(IND,"VALUE")) + . S DATE=IFIEVAL(IND,"DATE") + . S TEMP=NAME_VALUE_" ("_$$EDATE^PXRMDATE(DATE)_")" + . D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT) + . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND) + S NLINES=NLINES+1,TEXT(NLINES)="" + Q + ; + ;======================================================= +OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical + ;maintenance output. + N DATA,DATE,FIEN,IND,JND,NOUT,PNAME,TEMP,TEXTOUT,VALUE + S FIEN=$P(IFIEVAL("FINDING"),";",1) + S TEMP=^PXRMD(811.4,FIEN,0) + S PNAME=$P(TEMP,U,4) + I PNAME="" S PNAME=$P(TEMP,U,1) + S NLINES=NLINES+1 + S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Computed Finding: "_PNAME + S IND=0 + F S IND=+$O(IFIEVAL(IND)) Q:IND=0 D + . S DATE=IFIEVAL(IND,"DATE") + . S TEMP=$$EDATE^PXRMDATE(DATE) + . S VALUE=$G(IFIEVAL(IND,"VALUE")) + . I VALUE'="" S TEMP=TEMP_" value - "_VALUE + .;If there is text append it. + . I $G(IFIEVAL(IND,"TEXT"))'="" S TEMP=TEMP_"; "_IFIEVAL(IND,"TEXT") + . D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT) + . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND) + S NLINES=NLINES+1,TEXT(NLINES)="" + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMCOND.m b/r/CLINICAL_REMINDERS-PXRM/PXRMCOND.m index eb5a1df6..41b4acf5 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMCOND.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMCOND.m @@ -1,231 +1,230 @@ -PXRMCOND ; SLC/PKR - Routines for evaluating conditions. ;06/01/2007 - ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123 - ; - ;============================================================ -CASESEN(X,DA,FILENUM) ; - ;Called by xref on condition case sensitive field in 811.5 and 811.9. - N COND,GBL - S GBL=$$GET1^DID(FILENUM,"","","GLOBAL NAME") - S GBL=GBL_DA(1)_",20,"_DA_",3)" - S COND=$P(@GBL,U,1) - D SICOND(COND,.DA,FILENUM) - Q - ; - ;============================================================ -COND(CASESEN,ICOND,VSLIST,VA) ;Evaluate the condition. - N CONVAL,IND,JND,NSTAR,SUB,TEMP,V,VSTAR - S CONVAL="" - ;If there is no condition return true. - I $L($G(ICOND))=0 Q 1 - S NSTAR=0 - F IND=1:1 S SUB=$P(VSLIST,";",IND) Q:SUB="" D - . I SUB["*" S NSTAR=NSTAR+1,VSTAR(NSTAR)=$L(SUB,",")_U_SUB - S V=$G(VA("VALUE")) - I 'CASESEN S V=$$UP^XLFSTR(V) - ;Move all non "*" elements of VA into V. - I VSLIST'="" D MV(VSLIST,CASESEN,.V,.VA) - I NSTAR=0 X ICOND S CONVAL=$T - I NSTAR>0 S CONVAL=$$STARCOND(CASESEN,ICOND,.V,.VA,NSTAR,.VSTAR) - Q CONVAL - ; - ;============================================================ -KICOND(X,DA,FILENUM) ; - ;Do not execute as part of a verify fields. - I $G(DIUTIL)="VERIFY FIELDS" Q - ;Do not execute as part of exchange. - I $G(PXRMEXCH) Q - S FILENUM=$G(FILENUM) - I FILENUM=811.5 K ^PXRMD(811.5,DA(1),20,DA,10),^PXRMD(811.5,DA(1),20,DA,11) - I FILENUM=811.9 K ^PXD(811.9,DA(1),20,DA,10),^PXD(811.9,DA(1),20,DA,11) - Q - ; - ;============================================================ -MV(VSLIST,CASESEN,V,VA) ;Move the elements of VA included in VSLIST - ;into V and uppercase if necessary. - N IND,NE,RV,RVA,SUB - S NE=$L(VSLIST,";")-1 - F IND=1:1:NE D - . S SUB=$P(VSLIST,";",IND) - . I SUB["*" Q - . S RV="V("_SUB_")",RVA="VA("_SUB_")" - .;If VA(SUB) does not exist skip it. - . I '$D(@RVA) Q - . S @RV=$S('CASESEN:$$UP^XLFSTR(@RVA),1:@RVA) - Q - ; - ;============================================================ -RECSUB(IND,V,VA,NSTAR,VSTAR,NM,VM,CASESEN,ICOND,CONVAL) ;Called recursively, - ;first substitutes V array elements with "*" in subscript with a - ;replacement value. Once all have been replaced test condition and - ;quit if true. If not true continue until all combinations have been - ;tested. - N JND,RV,RVA,VSUB,VASUB - F JND=1:1:NM(IND) Q:CONVAL D - . S VASUB=VM(IND,JND) - . S RVA="VA("_VASUB_")" - . S SUB=$P(VSTAR(IND),U,2) - . S RV="V("_SUB_")" - . S @RV=$S('CASESEN:$$UP^XLFSTR(@RVA),1:@RVA) - . I IND$P(QP(JND),U,1),SPACE<$P(QP(JND),U,2) S IQ=1,JND=NQP Q - . S NIQ=$S(IQ:0,1:1) - . I NIQ S IND=NSP Q - I NIQ D - . D EN^DDIOL("No spaces are allowed except in quoted strings!") - . S VALID=0 - Q VALID - ; - ;============================================================ -VSUB(COND) ;Make sure all V subscripts are quoted strings, numbers - ;or quoted * strings. - N IND,RP,SS,SUB,SUBL,VALID - S (SS,VALID)=1 - F S SS=$F(COND,"V(",SS) Q:('VALID)!(SS=0) D - . S RP=$F(COND,")",SS)-2 - . I RP=-2 D Q - .. N TEXT - .. S TEXT=$E(COND,SS-2,$L(COND))_" is missing a "")""" - .. D EN^DDIOL(TEXT) - .. S VALID=0 - . S SUBL=$E(COND,SS,RP) - . F IND=1:1:$L(SUBL,",") D - .. S SUB=$P(SUBL,",",IND) - ..;Check for a number. - .. I SUB=+SUB Q - ..;Check for a wildcard, must be in quotes any number of * allowed. - .. I SUB?1"""1"*"."*"""" Q - .. ;Check for first and last character = to a ". - .. I ($E(SUB,1)'="""")!($E(SUB,$L(SUB))'="""") S VALID=0 - I 'VALID D EN^DDIOL("All V subscripts must be quoted strings, numbers or *!") - Q VALID - ; +PXRMCOND ; SLC/PKR - Routines for evaluating conditions. ;11/01/2004 + ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005 + ; + ;============================================================ +CASESEN(X,DA,FILENUM) ; + ;Called by xref on condition case sensitive field in 811.5 and 811.9. + N COND,GBL + S GBL=$$GET1^DID(FILENUM,"","","GLOBAL NAME") + S GBL=GBL_DA(1)_",20,"_DA_",3)" + S COND=$P(@GBL,U,1) + D SICOND(COND,.DA,FILENUM) + Q + ; + ;============================================================ +COND(CASESEN,ICOND,VSLIST,VA) ;Evaluate the condition. + N CONVAL,IND,JND,NSTAR,SUB,TEMP,V,VSTAR + S CONVAL="" + ;If there is no condition return true. + I $L($G(ICOND))=0 Q 1 + S NSTAR=0 + F IND=1:1 S SUB=$P(VSLIST,";",IND) Q:SUB="" D + . I SUB["*" S NSTAR=NSTAR+1,VSTAR(NSTAR)=$L(SUB,",")_U_SUB + S V=$G(VA("VALUE")) + I 'CASESEN S V=$$UP^XLFSTR(V) + ;Move all non "*" elements of VA into V. + I VSLIST'="" D MV(VSLIST,CASESEN,.V,.VA) + I NSTAR=0 X ICOND S CONVAL=$T + I NSTAR>0 S CONVAL=$$STARCOND(CASESEN,ICOND,.V,.VA,NSTAR,.VSTAR) + Q CONVAL + ; + ;============================================================ +KICOND(X,DA,FILENUM) ; + ;Do not execute as part of a verify fields. + I $G(DIUTIL)="VERIFY FIELDS" Q + ;Do not execute as part of exchange. + I $G(PXRMEXCH) Q + S FILENUM=$G(FILENUM) + I FILENUM=811.5 K ^PXRMD(811.5,DA(1),20,DA,10),^PXRMD(811.5,DA(1),20,DA,11) + I FILENUM=811.9 K ^PXD(811.9,DA(1),20,DA,10),^PXD(811.9,DA(1),20,DA,11) + Q + ; + ;============================================================ +MV(VSLIST,CASESEN,V,VA) ;Move the elements of VA included in VSLIST + ;into V and uppercase if necessary. + N IND,NE,RV,RVA,SUB + S NE=$L(VSLIST,";")-1 + F IND=1:1:NE D + . S SUB=$P(VSLIST,";",IND) + . I SUB["*" Q + . S RV="V("_SUB_")",RVA="VA("_SUB_")" + .;If VA(SUB) does not exist skip it. + . I '$D(@RVA) Q + . S @RV=$S('CASESEN:$$UP^XLFSTR(@RVA),1:@RVA) + Q + ; + ;============================================================ +RECSUB(IND,V,VA,NSTAR,VSTAR,NM,VM,CASESEN,ICOND,CONVAL) ;Called recursively, + ;first substitutes V array elements with "*" in subscript with a + ;replacement value. Once all have been replaced test condition and + ;quit if true. If not true continue until all combinations have been + ;tested. + N JND,RV,RVA,VSUB,VASUB + F JND=1:1:NM(IND) Q:CONVAL D + . S VASUB=VM(IND,JND) + . S RVA="VA("_VASUB_")" + . S SUB=$P(VSTAR(IND),U,2) + . S RV="V("_SUB_")" + . S @RV=$S('CASESEN:$$UP^XLFSTR(@RVA),1:@RVA) + . I IND$P(QP(JND),U,1),SPACE<$P(QP(JND),U,2) S IQ=1,JND=NQP Q + . S NIQ=$S(IQ:0,1:1) + . I NIQ S IND=NSP Q + I NIQ D + . D EN^DDIOL("No spaces are allowed except in quoted strings!") + . S VALID=0 + Q VALID + ; + ;============================================================ +VSUB(COND) ;Make sure all V subscripts are quoted strings, numbers + ;or quoted * strings. + N IND,RP,SS,SUB,SUBL,VALID + S (SS,VALID)=1 + F S SS=$F(COND,"V(",SS) Q:('VALID)!(SS=0) D + . S RP=$F(COND,")",SS)-2 + . I RP=-2 D Q + .. N TEXT + .. S TEXT=$E(COND,SS-2,$L(COND))_" is missing a "")""" + .. D EN^DDIOL(TEXT) + .. S VALID=0 + . S SUBL=$E(COND,SS,RP) + . F IND=1:1:$L(SUBL,",") D + .. S SUB=$P(SUBL,",",IND) + ..;Check for a number. + .. I SUB=+SUB Q + ..;Check for a wildcard, must be in quotes any number of * allowed. + .. I SUB?1"""1"*"."*"""" Q + .. ;Check for first and last character = to a ". + .. I ($E(SUB,1)'="""")!($E(SUB,$L(SUB))'="""") S VALID=0 + I 'VALID D EN^DDIOL("All V subscripts must be quoted strings, numbers or *!") + Q VALID + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMCOPY.m b/r/CLINICAL_REMINDERS-PXRM/PXRMCOPY.m index 04353c7f..8e8ee5ab 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMCOPY.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMCOPY.m @@ -1,173 +1,164 @@ -PXRMCOPY ; SLC/PKR,PJH - Copy various reminder files. ;09/13/2007 - ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123 - ; - ;===================================================== -COPY(PROMPT,ROOT,WHAT) ;Copy an entry of ROOT into a new entry. - N DIROUT,DTOUT,DUOUT - F D GETORGR Q:$D(DIROUT) Q:$D(DTOUT) - Q - ; - ;===================================================== -GETORGR ;Look-up logic to get and copy source entry to destination. - 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 - W ! - D ^DIC - I $D(DUOUT)!$D(DTOUT) S DIROUT="" Q - S IENO=$P(Y,U,1) - I IENO=-1 S DIROUT="" Q - ; - ;Set the starting place for additions. - D SETSTART^PXRMCOPY(DIC) - S IENN=$$GETFOIEN(ROOT) - D MERGE(IENN,IENO,ROOT) - ; - ;Get the new name. - S ORGNAME=$P(@(ROOT_IENO_",0)"),U,1) - S FILE=$$FNFR^PXRMUTIL(ROOT) - S FIELDLEN=$$GET1^DID(FILE,.01,"","FIELD LENGTH") - S DIR(0)="F"_U_"3:"_FIELDLEN_U_"K:(X?.N)!'(X'?1P.E) X" - S DIR("A")="PLEASE ENTER A UNIQUE NAME" -GETNAM D ^DIR - I $D(DIRUT) D DELETE(ROOT,IENN) Q - S NAME=Y - ; - ;Make sure the new name is valid. - I '$$VNAME^PXRMINTR(NAME,FILE) G GETNAM - ; - ;Change to the new name. - S IENS=IENN_"," - S FDA(FILE,IENS,.01)=NAME - K MSG - D FILE^DIE("","FDA","MSG") - ;Check to make sure the name was not a duplicate. - I $G(MSG("DIERR",1))=740 D G GETNAM - . W !,NAME," is not a unique name!" - ;Change the class to local and delete the sponsor. - D SCAS(FILE,IENN,"L","") - ;Initialize the edit history. - D INIEH(FILE,ROOT,IENN,IENO) - ; - ;Reindex the cross-references. - S DIK=ROOT,DA=IENN - D IX^DIK - W ! - ; - ;Tell the user what has happened and allow for editing of the new item. - S DIR(0)="Y" - S DIR("A")="Do you want to edit it now" - S DIR("A",1)="The original "_WHAT_" "_ORGNAME_" has been copied into "_NAME_"." - D ^DIR Q:$D(DIRUT) - I Y D EDIT^PXRMEDIT(ROOT,IENN) - Q - ; - ;===================================================== -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: " - D COPY(PROMPT,ROOT,WHAT) - Q - ; - ;===================================================== -COPYTAX ;Copy a taxonomy. - N PROMPT,ROOT,WHAT - S WHAT="taxonomy" - S ROOT="^PXD(811.2," - S PROMPT="Select the reminder taxonomy to copy: " - D COPY(PROMPT,ROOT,WHAT) - Q - ; - ;===================================================== -COPYTERM ;Copy a reminder term. - N PROMPT,ROOT,WHAT - S WHAT="reminder term" - S ROOT="^PXRMD(811.5," - S PROMPT="Select the reminder term to copy: " - D COPY(PROMPT,ROOT,WHAT) - Q - ; - ;===================================================== -DELETE(DIK,DA) ;Delete the entry just added. - D ^DIK - W !!,"New entry not created due to invalid name!",! - Q - ; - ;===================================================== -GETFOIEN(ROOT) ;Return the first open IEN in ROOT. This should be called - ;after a call to SETSTART. - N ENTRY,NIEN,OIEN - S ENTRY=ROOT_0_")" - S OIEN=$P(@ENTRY,U,3) - S ENTRY=ROOT_OIEN_")" - F S NIEN=$O(@ENTRY) Q:+(NIEN-OIEN)>1 Q:+NIEN'>0 S OIEN=NIEN,ENTRY=ROOT_NIEN_")" - Q OIEN+1 - ; - ;===================================================== -INIEH(FILENUM,ROOT,IENN,IENO) ;Initialize the edit history after a copy. - ;First delete any existing history entries. - N ENTRY,IND,IENS,FDA,FDAIEN,MSG,SFN,TARGET,WP - D FIELD^DID(FILENUM,"EDIT HISTORY","","SPECIFIER","TARGET") - S SFN=+$G(TARGET("SPECIFIER")) - I SFN=0 Q - S ENTRY=ROOT_IENN_",110)" - S IND=0 - F S IND=$O(@ENTRY@(IND)) Q:+IND=0 D - . S IENS=IND_","_IENN_"," - . S FDA(SFN,IENS,.01)="@" - I $D(FDA(SFN)) D FILE^DIE("K","FDA","MSG") - I $D(MSG) D AWRITE^PXRMUTIL("MSG") - ;Establish an initial entry in the edit history. - K FDA,MSG - S IENS="+1,"_IENN_"," - S FDAIEN(IENN)=IENN - S FDA(SFN,IENS,.01)=$$FMTE^XLFDT($$NOW^XLFDT,"5Z") - S FDA(SFN,IENS,1)=$$GET1^DIQ(200,DUZ,.01) - S FDA(SFN,IENS,2)="WP(1,1)" - S WP(1,1,1)="Copied from "_$$GET1^DIQ(FILENUM,IENO,.01) - D UPDATE^DIE("E","FDA","FDAIEN","MSG") - I $D(MSG) D AWRITE^PXRMUTIL("MSG") - Q - ; - ;===================================================== -MERGE(IENN,IENO,ROOT) ;Use MERGE to copy ROOT(IENO into ROOT(IENN. - N DEST,SOURCE - S DEST=ROOT_IENN_")" - ;Lock the file before merging. - L +@DEST:10 - S SOURCE=ROOT_IENO_")" - M @DEST=@SOURCE - ;Unlock the file - L -@DEST - Q - ; - ;===================================================== -SCAS(FILENUM,IEN,CLASS,SPONSOR) ;Set the class field to CLASS and the sponsor - ;field to SPONSOR. - N IENS,FDA,MSG - S IENS=IEN_"," - S FDA(FILENUM,IENS,100)=CLASS - S FDA(FILENUM,IENS,101)=SPONSOR - D FILE^DIE("K","FDA","MSG") - I $D(MSG) D AWRITE^PXRMUTIL("MSG") - Q - ; - ;===================================================== -SETSTART(ROOT) ;Set the starting value to add new entries. Start - ;at the begining so empty spaces are filled in. - N CUR,ENTRY - S ENTRY=ROOT_"0)" - S $P(@ENTRY,U,3)=1 - Q - ; +PXRMCOPY ; SLC/PKR,PJH - Copy various reminder files. ;05/11/2001 + ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005 + ; + ;===================================================== +COPY(PROMPT,ROOT,WHAT) ;Copy an entry of ROOT into a new entry. + N DIROUT,DTOUT,DUOUT + F D GETORGR Q:$D(DIROUT) Q:$D(DTOUT) + Q + ; + ;===================================================== +GETORGR ;Look-up logic to get and copy source entry to destination. + N DA,DIE,DIC,DIK,DIR,DIRUT,FDA,FIELDLEN,FILE + N IENN,IENO,IENS,MSG,NAME,ORGNAME,X,Y + S DIC=ROOT,DIC(0)="AEQ",DIC("A")=PROMPT + W ! + D ^DIC + I $D(DUOUT)!$D(DTOUT) S DIROUT="" Q + S IENO=$P(Y,U,1) + I IENO=-1 S DIROUT="" Q + ; + ;Set the starting place for additions. + D SETSTART^PXRMCOPY(DIC) + S IENN=$$GETFOIEN(ROOT) + D MERGE(IENN,IENO,ROOT) + ; + ;Get the new name. + S ORGNAME=$P(@(ROOT_IENO_",0)"),U,1) + S FILE=$$FNFR^PXRMUTIL(ROOT) + S FIELDLEN=$$GET1^DID(FILE,.01,"","FIELD LENGTH") + S DIR(0)="F"_U_"3:"_FIELDLEN_U_"K:(X?.N)!'(X'?1P.E) X" + S DIR("A")="PLEASE ENTER A UNIQUE NAME" +GETNAM D ^DIR + I $D(DIRUT) D DELETE(ROOT,IENN) Q + S NAME=Y + ; + ;Make sure the new name is valid. + I '$$VNAME^PXRMINTR(NAME,FILE) G GETNAM + ; + ;Change to the new name. + S IENS=IENN_"," + S FDA(FILE,IENS,.01)=NAME + K MSG + D FILE^DIE("","FDA","MSG") + ;Check to make sure the name was not a duplicate. + I $G(MSG("DIERR",1))=740 D G GETNAM + . W !,NAME," is not a unique name!" + ;Change the class to local and delete the sponsor. + D SCAS(FILE,IENN,"L","") + ;Initialize the edit history. + D INIEH(FILE,ROOT,IENN,IENO) + ; + ;Reindex the cross-references. + S DIK=ROOT,DA=IENN + D IX^DIK + W ! + ; + ;Tell the user what has happened and allow for editing of the new item. + S DIR(0)="Y" + S DIR("A")="Do you want to edit it now" + S DIR("A",1)="The original "_WHAT_" "_ORGNAME_" has been copied into "_NAME_"." + D ^DIR Q:$D(DIRUT) + I Y D EDIT^PXRMEDIT(ROOT,IENN) + Q + ; + ;===================================================== +COPYREM ;Copy a reminder definition. + N PROMPT,ROOT,WHAT + S WHAT="reminder" + S ROOT="^PXD(811.9," + S PROMPT="Select the reminder item to copy: " + D COPY(PROMPT,ROOT,WHAT) + Q + ; + ;===================================================== +COPYTAX ;Copy a taxonomy. + N PROMPT,ROOT,WHAT + S WHAT="taxonomy" + S ROOT="^PXD(811.2," + S PROMPT="Select the taxonomy item to copy: " + D COPY(PROMPT,ROOT,WHAT) + Q + ; + ;===================================================== +COPYTERM ;Copy a reminder term. + N PROMPT,ROOT,WHAT + S WHAT="reminder term" + S ROOT="^PXRMD(811.5," + S PROMPT="Select the reminder term to copy: " + D COPY(PROMPT,ROOT,WHAT) + Q + ; + ;===================================================== +DELETE(DIK,DA) ;Delete the entry just added. + D ^DIK + W !!,"New entry not created due to invalid name!",! + Q + ; + ;===================================================== +GETFOIEN(ROOT) ;Return the first open IEN in ROOT. This should be called + ;after a call to SETSTART. + N ENTRY,NIEN,OIEN + S ENTRY=ROOT_0_")" + S OIEN=$P(@ENTRY,U,3) + S ENTRY=ROOT_OIEN_")" + F S NIEN=$O(@ENTRY) Q:+(NIEN-OIEN)>1 Q:+NIEN'>0 S OIEN=NIEN,ENTRY=ROOT_NIEN_")" + Q OIEN+1 + ; + ;===================================================== +INIEH(FILENUM,ROOT,IENN,IENO) ;Initialize the edit history after a copy. + ;First delete any existing history entries. + N ENTRY,IND,IENS,FDA,FDAIEN,MSG,SFN,TARGET,WP + D FIELD^DID(FILENUM,"EDIT HISTORY","","SPECIFIER","TARGET") + S SFN=+$G(TARGET("SPECIFIER")) + I SFN=0 Q + S ENTRY=ROOT_IENN_",110)" + S IND=0 + F S IND=$O(@ENTRY@(IND)) Q:+IND=0 D + . S IENS=IND_","_IENN_"," + . S FDA(SFN,IENS,.01)="@" + I $D(FDA(SFN)) D FILE^DIE("K","FDA","MSG") + I $D(MSG) D AWRITE^PXRMUTIL("MSG") + ;Establish an initial entry in the edit history. + K FDA,MSG + S IENS="+1,"_IENN_"," + S FDAIEN(IENN)=IENN + S FDA(SFN,IENS,.01)=$$FMTE^XLFDT($$NOW^XLFDT,"5Z") + S FDA(SFN,IENS,1)=$$GET1^DIQ(200,DUZ,.01) + S FDA(SFN,IENS,2)="WP(1,1)" + S WP(1,1,1)="Copied from "_$$GET1^DIQ(FILENUM,IENO,.01) + D UPDATE^DIE("E","FDA","FDAIEN","MSG") + I $D(MSG) D AWRITE^PXRMUTIL("MSG") + Q + ; + ;===================================================== +MERGE(IENN,IENO,ROOT) ;Use MERGE to copy ROOT(IENO into ROOT(IENN. + N DEST,SOURCE + S DEST=ROOT_IENN_")" + ;Lock the file before merging. + L +@DEST:10 + S SOURCE=ROOT_IENO_")" + M @DEST=@SOURCE + ;Unlock the file + L -@DEST + Q + ; + ;===================================================== +SCAS(FILENUM,IEN,CLASS,SPONSOR) ;Set the class field to CLASS and the sponsor + ;field to SPONSOR. + N IENS,FDA,MSG + S IENS=IEN_"," + S FDA(FILENUM,IENS,100)=CLASS + S FDA(FILENUM,IENS,101)=SPONSOR + D FILE^DIE("K","FDA","MSG") + I $D(MSG) D AWRITE^PXRMUTIL("MSG") + Q + ; + ;===================================================== +SETSTART(ROOT) ;Set the starting value to add new entries. Start + ;at the begining so empty spaces are filled in. + N CUR,ENTRY + S ENTRY=ROOT_"0)" + S $P(@ENTRY,U,3)=1 + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMDATA.m b/r/CLINICAL_REMINDERS-PXRM/PXRMDATA.m index ebd0e9d8..9cec4bab 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMDATA.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMDATA.m @@ -1,61 +1,61 @@ -PXRMDATA ; SLC/PKR - Routines for getting data. ;04/02/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ;=============================================== -GETDATA(FILENUM,DAS,FIEVT) ;Return data for a finding. - K FIEVT - I FILENUM=45 D GETDATA^PXRMDGPT(DAS,.FIEVT) Q - I FILENUM=52 D GETDATA^PXRMDOUT(DAS,.FIEVT) Q - I FILENUM=55 D GETDATA^PXRMDIN(DAS,.FIEVT) Q - I FILENUM="55NVA" D GETDATA^PXRMDNVA(DAS,.FIEVT) Q - I FILENUM=63 D GETDATA^PXRMLAB(DAS,.FIEVT) Q - I FILENUM=70 D GETDATA^PXRMRAD(DAS,.FIEVT) Q - 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=9000010 D GETDATA^PXRMVSIT(DAS,.FIEVT,1) Q - I FILENUM=9000010.07 D GETDATA^PXRMVPOV(DAS,.FIEVT) Q - I FILENUM=9000010.11 D GETDATA^PXRMIMM(DAS,.FIEVT) Q - I FILENUM=9000010.12 D GETDATA^PXRMSKIN(DAS,.FIEVT) Q - I FILENUM=9000010.13 D GETDATA^PXRMEXAM(DAS,.FIEVT) Q - I FILENUM=9000010.16 D GETDATA^PXRMEDU(DAS,.FIEVT) Q - I FILENUM=9000010.18 D GETDATA^PXRMVCPT(DAS,.FIEVT) Q - I FILENUM=9000010.23 D GETDATA^PXRMHF(DAS,.FIEVT) Q - I FILENUM=9000011 D GETDATA^PXRMPROB(DAS,.FIEVT) Q - Q - ; - ;=============================================== -GETFNAME(FINDING) ;Given a finding of the form IEN;GLOBAL return its name. - N DIC,DO,IEN,FNUM,GLOBAL - S IEN=$P(FINDING,";",1) - S GLOBAL=$P(FINDING,";",2) - S GLOBAL=$S(GLOBAL="PS(55NVA,":"PS(50.7,",GLOBAL="PS(55,":"PSDRUG(",1:GLOBAL) - S DIC="^"_GLOBAL - D DO^DIC1 - S FNUM=+$P(DO,U,2) - Q $$GET1^DIQ(FNUM,IEN,.01) - ; - ;=============================================== -GETFNUM(ENODE) ;Given an ENODE return the file number for the data source. - I ENODE="AUTTEDT(" Q 9000010.16 - I ENODE="AUTTEXAM(" Q 9000010.13 - I ENODE="AUTTHF(" Q 9000010.23 - I ENODE="AUTTIMM(" Q 9000010.11 - I ENODE="AUTTSK(" Q 9000010.12 - I ENODE="GMRD(120.51," Q 120.5 - I ENODE="LAB(60," Q 63 - I ENODE="ORD(101.43," Q 100 - I ENODE="PXD(811.2," Q 811.2 - I ENODE="PXRMD(810.9," Q 9000010 - I ENODE="PXRMD(811.4," Q 811.4 - I ENODE="PXRMD(811.5," Q 811.5 - I ENODE="PS(50.605," Q 52_U_55_U_"55NVA" - I ENODE="PS(55," Q 55 - I ENODE="PS(55NVA," Q "55NVA" - I ENODE="PSDRUG(" Q 52_U_55_U_"55NVA" - I ENODE="PSNDF(50.6," Q 52_U_55_U_"55NVA" - I ENODE="PSRX(" Q 52 - I ENODE="RAMIS(71," Q 70 - I ENODE="YTT(601.71," Q 601.84 - Q 0 - ; +PXRMDATA ; SLC/PKR - Routines for getting data. ;07/17/2006 + ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21 + ; + ;=============================================== +GETDATA(FILENUM,DAS,FIEVT) ;Return data for a finding. + K FIEVT + I FILENUM=45 D GETDATA^PXRMDGPT(DAS,.FIEVT) Q + I FILENUM=52 D GETDATA^PXRMDOUT(DAS,.FIEVT) Q + I FILENUM=55 D GETDATA^PXRMDIN(DAS,.FIEVT) Q + I FILENUM="55NVA" D GETDATA^PXRMDNVA(DAS,.FIEVT) Q + I FILENUM=63 D GETDATA^PXRMLAB(DAS,.FIEVT) Q + I FILENUM=70 D GETDATA^PXRMRAD(DAS,.FIEVT) Q + I FILENUM=100 D GETDATA^PXRMORDR(DAS,.FIEVT) Q + I FILENUM=120.5 D GETDATA^PXRMVITL(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 FILENUM=9000010.11 D GETDATA^PXRMIMM(DAS,.FIEVT) Q + I FILENUM=9000010.12 D GETDATA^PXRMSKIN(DAS,.FIEVT) Q + I FILENUM=9000010.13 D GETDATA^PXRMEXAM(DAS,.FIEVT) Q + I FILENUM=9000010.16 D GETDATA^PXRMEDU(DAS,.FIEVT) Q + I FILENUM=9000010.18 D GETDATA^PXRMVCPT(DAS,.FIEVT) Q + I FILENUM=9000010.23 D GETDATA^PXRMHF(DAS,.FIEVT) Q + I FILENUM=9000011 D GETDATA^PXRMPROB(DAS,.FIEVT) Q + Q + ; + ;=============================================== +GETFNAME(FINDING) ;Given a finding of the form IEN;GLOBAL return its name. + N DIC,DO,IEN,FNUM,GLOBAL + S IEN=$P(FINDING,";",1) + S GLOBAL=$P(FINDING,";",2) + S GLOBAL=$S(GLOBAL="PS(55NVA,":"PS(50.7,",GLOBAL="PS(55,":"PSDRUG(",1:GLOBAL) + S DIC="^"_GLOBAL + D DO^DIC1 + S FNUM=+$P(DO,U,2) + Q $$GET1^DIQ(FNUM,IEN,.01) + ; + ;=============================================== +GETFNUM(ENODE) ;Given an ENODE return the file number for the data source. + I ENODE="AUTTEDT(" Q 9000010.16 + I ENODE="AUTTEXAM(" Q 9000010.13 + I ENODE="AUTTHF(" Q 9000010.23 + I ENODE="AUTTIMM(" Q 9000010.11 + I ENODE="AUTTSK(" Q 9000010.12 + I ENODE="GMRD(120.51," Q 120.5 + I ENODE="LAB(60," Q 63 + I ENODE="ORD(101.43," Q 100 + I ENODE="PXD(811.2," Q 811.2 + I ENODE="PXRMD(810.9," Q 9000010 + I ENODE="PXRMD(811.4," Q 811.4 + I ENODE="PXRMD(811.5," Q 811.5 + I ENODE="PS(50.605," Q 52_U_55_U_"55NVA" + I ENODE="PS(55," Q 55 + I ENODE="PS(55NVA," Q "55NVA" + I ENODE="PSDRUG(" Q 52_U_55_U_"55NVA" + I ENODE="PSNDF(50.6," Q 52_U_55_U_"55NVA" + I ENODE="PSRX(" Q 52 + I ENODE="RAMIS(71," Q 70 + I ENODE="YTT(601," Q 601.2 + Q 0 + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMDATE.m b/r/CLINICAL_REMINDERS-PXRM/PXRMDATE.m index 15e5e306..02a0dfd8 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMDATE.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMDATE.m @@ -1,255 +1,252 @@ -PXRMDATE ; SLC/PKR - Clinical Reminders date utilities. ;01/24/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ;================================================== -CEFD(FDA) ;Called by the Exchange Utility only if the input packed - ;reminder was packed under v1.5 Move Effective Date to Beginning Date. - N IND - S IND="" - F S IND=$O(FDA(811.902,IND)) Q:IND="" D - . I '$D(FDA(811.902,IND,12)) Q - .;If the EFFECTIVE PERIOD exists don't do anything. - . I $D(FDA(811.902,IND,9)) Q - . S FDA(811.902,IND,9)=FDA(811.902,IND,12) - . K FDA(811.902,IND,12) - Q - ; - ;================================================== -COMPARE(X) ;Compare beginning and ending dates, give a warning if - ;Ending Date comes before Beginning Date. Called by ADATE xref in - ;definitions and terms. - ;Do not execute as part of exchange. - I $G(PXRMEXCH) Q - N BDT,EDT - S BDT=$S(X(1)'="":$$CTFMD^PXRMDATE(X(1)),1:0) - S EDT=X(2) - I EDT="" S EDT="T" - S EDT=$$CTFMD^PXRMDATE(EDT) - ;If EDT does not contain a time set it to the end of the day. - I EDT'["." S EDT=EDT_".235959" - I EDT9991231) Q DATE - ;Check for a date FileMan understands. - S X=DATE,%DT="ST" - D ^%DT - ;If it is not a FileMan date check for a symbolic date. - I Y=-1 S Y=$$SYMDATE(DATE) - ;If it is not a date that is understood by SYMDATE return -1 - I Y=-1 Q -1 - I $G(PXRMDATE)'="",$$ISVSYMD(DATE) D - . N DIFFS - . S DIFFS=-$$FMDIFF^XLFDT(DT,PXRMDATE,2) - . S Y=$$FMADD^XLFDT(Y,0,0,0,DIFFS) - I DATE["LAD" D - . I $G(PXRMLAD)="" S Y=0 - . E D - .. N DIFFS - .. S DIFFS=-$$FMDIFF^XLFDT(DT,$G(PXRMLAD),2) - .. S Y=$$FMADD^XLFDT(Y,0,0,0,DIFFS) - Q Y - ; - ;================================================= -DCHECK(DATE) ;Trap for special characters before calling CTFMD^PXRMDATE. - ;Used in DIR("PRE") for date inputs. - I $D(DTOUT) Q DATE - I DATE="" Q DATE - I DATE["^" Q DATE - I DATE["?" Q DATE - Q $$CTFMD^PXRMDATE(DATE) - ; - ;================================================== -DUE(DEFARR,RESDATE,FREQ,DUE,DUEDATE,FIEVAL) ;Compute the due date. - ;This is the date of the resolution finding + the reminder frequency. - ;Subtract the due in advance time to see if the reminder should be - ;marked as due soon. - ; - N DATE,DIAT,DIATOK,LDATE,PXRMITEM,TDDUE,TODAY - S PXRMITEM=DEFARR("IEN") - ;If the final frequency is 0Y then the reminder is not due. - I FREQ="0Y" S DUE=0,DUEDATE="" Q - ; - S DUEDATE="" - ;Check for custom date due. - I DEFARR(45)'="" S DUEDATE=$$CDUEDATE^PXRMCDUE(.DEFARR,.FIEVAL) - I DUEDATE'="",DUEDATE'=-1 G SETDUE - ; - ;No custom date due, do regular date calculation. - I (FREQ="")!(FREQ=-1) D Q - . S ^TMP(PXRMPID,$J,PXRMITEM,"WARNING","NOFREQ")="No reminder frequency - cannot compute due date!" - . S (DUE,DUEDATE)="CNBD" - ; - S LDATE=$S(RESDATE["X":0,1:+RESDATE) - I LDATE=0 S (DUE,DUEDATE)="DUE NOW" Q - S DATE=$$FULLDATE(LDATE),DUEDATE=$$NEWDATE(DATE,FREQ) - ; -SETDUE ;If the due date is less than or equal to today's date the reminder - ;is due. - S TODAY=$$NOW^PXRMDATE - I +DUEDATE'>TODAY S DUE="DUE NOW" Q - ; - S DIAT="-"_$P(DEFARR(0),U,4) - I DIAT="-" D - . S DIATOK=0 - . S ^TMP(PXRMPID,$J,PXRMITEM,"WARNING","DIAT")="Warning no do in advance time" - E S DIATOK=1 - ; - S TDDUE=$S(DIATOK=1:$$NEWDATE(DUEDATE,DIAT),1:DUEDATE) - S DUE=$S(TDDUE'>TODAY:"DUE SOON",1:"RESOLVED") - Q - ; - ;================================================== -DURATION(START,STOP) ;Return the number days between the Start Date and - ;Stop Date. - I +START=0 Q 0 - N PXRMNOW - S PXRMNOW=$$NOW^PXRMDATE - I START>PXRMNOW Q 0 - I (STOP="")!(STOP>PXRMNOW) S STOP=PXRMNOW - Q $$FMDIFF^XLFDT(STOP,START) - ; - ;================================================== -EDATE(DATE) ;Check for an historical (event) date, format as appropriate. - Q $$FMTE^XLFDT(DATE,"5DZ") - ; - ;================================================== -FULLDATE(DATE) ;See if DATE is a full date, i.e., it has a month and - ;a day along with a year. If the month is missing assume Jan. If the - ;day is missing assume the first. Issue a warning so the user knows - ;what happened. DATE should be in Fileman format. - N DAY,MISSING,MONTH,TDATE,YEAR - S TDATE=DATE - S MISSING=0 - S DAY=$E(DATE,6,7) - S MONTH=$E(DATE,4,5) - S YEAR=$E(DATE,1,3) - I +DAY=0 D - . S DAY=1 - . S MISSING=1 - . S ^TMP(PXRMPID,$J,PXRMITEM,"INFO","NO DAY")="Encounter date missing the day, using the first for the date due calculation." - I +MONTH=0 D - . S MONTH=1 - . S MISSING=1 - . S ^TMP(PXRMPID,$J,PXRMITEM,"INFO","NO MONTH")="Encounter date missing the month, using January for the date due calculation." - I MISSING D - . S TDATE=(YEAR*1E4)+(MONTH*1E2)+DAY - . I DATE["E" S TDATE=TDATE_"E" - Q TDATE - ; - ;================================================== -FRQINDAY(FREQ) ;Given a frequency in the form ND, NM, or NY where N is a - ;number and D stands for days, M for months, and Y for years return - ;the value in days. - I FREQ="" Q "" - N CODE,LEN,MULT,NUM - S LEN=$L(FREQ) - S NUM=$E(FREQ,1,LEN-1) - S CODE=$E(FREQ,LEN,LEN) - S MULT=1.0 - I CODE="M" S MULT=30.42 - I CODE="Y" S MULT=365.25 - Q +(MULT*NUM) - ; - ;================================================== -ISVSYMD(DATE) ;Return true if DATE is a valid symbolic date. - N P1,P1OK,P2,P2OK,OP,PAT - S DATE=$P(DATE,"@",1) - S OP=$S(DATE["+":"+",1:"-") - S P1=$P(DATE,OP,1),P1OK=0 - F PAT="T","TODAY","N","NOW" I P1=PAT S P1OK=1 Q:P1OK - I PAT=DATE Q 1 - S P2=$P(DATE,OP,2),P2OK=0 - F PAT="1N.N","1N.N1""D""","1N.N1""M""","1N.N1""Y""" I P2?@PAT S P2OK=1 Q:P2OK - Q P1OK&P2OK - ; - ;================================================== -NEWDATE(FMDATE,OFFSET) ;Given a date in VA Fileman format (FMDATE) and an - ;offset of the form NY, NM, ND where N is a number and Y stands for - ;years, M for months, and D for days return the new date in VA Fileman - ;format. - I FMDATE=0 Q 0 - N LEN,NEWDATE,NUM,UNIT - S LEN=$L(OFFSET) - S NUM=+$E(OFFSET,1,LEN-1) - S UNIT=$E(OFFSET,LEN) - I UNIT="D" G DAY - I UNIT="M" G MONTH - I UNIT="Y" G YEAR - ;Unknown unit just return the original date - Q FMDATE -DAY ; - S NEWDATE=+$$FMADD^XLFDT(FMDATE,NUM) - Q NEWDATE -MONTH ; - ;Convert the months to days and then add the days using the DAY code. - ;Multiply the number of months by the average number of days in a month. - N INT,FRAC - S NUM=30.42*NUM - ;Round the number of days, FMADD^XLFDT has problems with non-integer - ;days. - S INT=+$P(NUM,".",1) - S FRAC=NUM-INT - I FRAC<0.5 S NUM=INT - E S NUM=INT+1 - G DAY - Q -YEAR ; - Q FMDATE+(10000*NUM) - ; - ;================================================== -NOW() ;If the reminder global PXRMDATE is defined return it, otherwise - ;return the current date and time. - Q $S(+$G(PXRMDATE)>0:PXRMDATE,1:$$NOW^XLFDT) - ; - ;================================================== -SYMDATE(DATE) ;Convert a symbolic date into a FileMan date. - N %DT,OPER,PFSTACK,SYM,TIME,X,Y - S TIME=$P(DATE,"@",2),DATE=$P(DATE,"@",1) - S X=$S(DATE="LAD":$G(PXRMLAD),1:"") - I X="" D - . S OPER="+-" - . D POSTFIX^PXRMSTAC(DATE,OPER,.PFSTACK) - I PFSTACK(0)=3 D - . S SYM=PFSTACK(1) - . S SYM=$S(SYM="LAD":"T",SYM="N":"N",SYM="NOW":"N",SYM="T":"T",SYM="TODAY":"T",1:"") - . I SYM="" S Y=-1 Q - .;FileMan only handles D, W, or M so convert Y to months. - . I PFSTACK(2)["Y" S PFSTACK(2)=+PFSTACK(2)*12_"M" - . S X=SYM_PFSTACK(3)_PFSTACK(2) - I PFSTACK(0)=1 S X=PFSTACK(1) - I TIME'="" S X=X_"@"_TIME - S %DT="ST" - D ^%DT - Q Y - ; - ;================================================== -VDATE(VIEN) ;Given a visit ien return the visit date. - N DATE - I +VIEN>0 S DATE=$P($G(^AUPNVSIT(VIEN,0)),U,1) - E S DATE=0 - I $L(DATE)=0 S DATE=0 - ;Check for historical encounter. - I $$ISHIST^PXRMVSIT(VIEN) S DATE=DATE_"E" - Q DATE - ; +PXRMDATE ; SLC/PKR - Clinical Reminders date utilities. ;06/20/2006 + ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21 + ; + ;================================================== +CEFD(FDA) ;Called by the Exchange Utility only if the input packed + ;reminder was packed under v1.5 Move Effective Date to Beginning Date. + N IND + S IND="" + F S IND=$O(FDA(811.902,IND)) Q:IND="" D + . I '$D(FDA(811.902,IND,12)) Q + .;If the EFFECTIVE PERIOD exists don't do anything. + . I $D(FDA(811.902,IND,9)) Q + . S FDA(811.902,IND,9)=FDA(811.902,IND,12) + . K FDA(811.902,IND,12) + Q + ; + ;================================================== +COMPARE(X) ;Compare beginning and ending dates, give a warning if + ;Ending Date comes before Beginning Date. Called by ADATE xref in + ;definitions and terms. + ;Do not execute as part of exchange. + I $G(PXRMEXCH) Q + N BDT,EDT + S BDT=$S(X(1)'="":$$CTFMD^PXRMDATE(X(1)),1:0) + S EDT=X(2) + I EDT="" S EDT="T" + S EDT=$$CTFMD^PXRMDATE(EDT) + ;If EDT does not contain a time set it to the end of the day. + I EDT'["." S EDT=EDT_".235959" + I EDTTODAY S DUE="DUE NOW" Q + ; + S DIAT="-"_$P(DEFARR(0),U,4) + I DIAT="-" D + . S DIATOK=0 + . S ^TMP(PXRMPID,$J,PXRMITEM,"WARNING","DIAT")="Warning no do in advance time" + E S DIATOK=1 + ; + S TDDUE=$S(DIATOK=1:$$NEWDATE(DUEDATE,DIAT),1:DUEDATE) + S DUE=$S(TDDUE'>TODAY:"DUE SOON",1:"RESOLVED") + Q + ; + ;================================================== +DURATION(START,STOP) ;Return the number days between the Start Date and + ;Stop Date. + I +START=0 Q 0 + N PXRMNOW + S PXRMNOW=$$NOW^PXRMDATE + I START>PXRMNOW Q 0 + I (STOP="")!(STOP>PXRMNOW) S STOP=PXRMNOW + Q $$FMDIFF^XLFDT(STOP,START) + ; + ;================================================== +EDATE(DATE) ;Check for an historical (event) date, format as appropriate. + Q $$FMTE^XLFDT(DATE,"5DZ") + ; + ;================================================== +FULLDATE(DATE) ;See if DATE is a full date, i.e., it has a month and + ;a day along with a year. If the month is missing assume Jan. If the + ;day is missing assume the first. Issue a warning so the user knows + ;what happened. DATE should be in Fileman format. + N DAY,MISSING,MONTH,TDATE,YEAR + S TDATE=DATE + S MISSING=0 + S DAY=$E(DATE,6,7) + S MONTH=$E(DATE,4,5) + S YEAR=$E(DATE,1,3) + I +DAY=0 D + . S DAY=1 + . S MISSING=1 + . S ^TMP(PXRMPID,$J,PXRMITEM,"INFO","NO DAY")="Encounter date missing the day, using the first for the date due calculation." + I +MONTH=0 D + . S MONTH=1 + . S MISSING=1 + . S ^TMP(PXRMPID,$J,PXRMITEM,"INFO","NO MONTH")="Encounter date missing the month, using January for the date due calculation." + I MISSING D + . S TDATE=(YEAR*1E4)+(MONTH*1E2)+DAY + . I DATE["E" S TDATE=TDATE_"E" + Q TDATE + ; + ;================================================== +FRQINDAY(FREQ) ;Given a frequency in the form ND, NM, or NY where N is a + ;number and D stands for days, M for months, and Y for years return + ;the value in days. + I FREQ="" Q "" + N CODE,LEN,MULT,NUM + S LEN=$L(FREQ) + S NUM=$E(FREQ,1,LEN-1) + S CODE=$E(FREQ,LEN,LEN) + S MULT=1.0 + I CODE="M" S MULT=30.42 + I CODE="Y" S MULT=365.25 + Q +(MULT*NUM) + ; + ;================================================== +ISVSYMD(DATE) ;Return true if DATE is a valid symbolic date. + N P1,P1OK,P2,P2OK,OP,PAT + S DATE=$P(DATE,"@",1) + S OP=$S(DATE["+":"+",1:"-") + S P1=$P(DATE,OP,1),P1OK=0 + F PAT="T","TODAY","N","NOW" I P1=PAT S P1OK=1 Q:P1OK + I PAT=DATE Q 1 + S P2=$P(DATE,OP,2),P2OK=0 + F PAT="1N.N","1N.N1""D""","1N.N1""M""","1N.N1""Y""" I P2?@PAT S P2OK=1 Q:P2OK + Q P1OK&P2OK + ; + ;================================================== +NEWDATE(FMDATE,OFFSET) ;Given a date in VA Fileman format (FMDATE) and an + ;offset of the form NY, NM, ND where N is a number and Y stands for + ;years, M for months, and D for days return the new date in VA Fileman + ;format. + I FMDATE=0 Q 0 + N LEN,NEWDATE,NUM,UNIT + S LEN=$L(OFFSET) + S NUM=+$E(OFFSET,1,LEN-1) + S UNIT=$E(OFFSET,LEN) + I UNIT="D" G DAY + I UNIT="M" G MONTH + I UNIT="Y" G YEAR + ;Unknown unit just return the original date + Q FMDATE +DAY ; + S NEWDATE=+$$FMADD^XLFDT(FMDATE,NUM) + Q NEWDATE +MONTH ; + ;Convert the months to days and then add the days using the DAY code. + ;Multiply the number of months by the average number of days in a month. + N INT,FRAC + S NUM=30.42*NUM + ;Round the number of days, FMADD^XLFDT has problems with non-integer + ;days. + S INT=+$P(NUM,".",1) + S FRAC=NUM-INT + I FRAC<0.5 S NUM=INT + E S NUM=INT+1 + G DAY + Q +YEAR ; + Q FMDATE+(10000*NUM) + ; + ;================================================== +NOW() ;If the reminder global PXRMDATE is defined return it, otherwise + ;return the current date and time. + Q $S(+$G(PXRMDATE)>0:PXRMDATE,1:$$NOW^XLFDT) + ; + ;================================================== +SYMDATE(DATE) ;Convert a symbolic date into a FileMan date. + N %DT,OPER,PFSTACK,SYM,TIME,X,Y + S TIME=$P(DATE,"@",2),DATE=$P(DATE,"@",1) + S X=$S(DATE="LAD":$G(PXRMLAD),1:"") + I X="" D + . S OPER="+-" + . D POSTFIX^PXRMSTAC(DATE,OPER,.PFSTACK) + I PFSTACK(0)=3 D + . S SYM=PFSTACK(1) + . S SYM=$S(SYM="LAD":"T",SYM="N":"N",SYM="NOW":"N",SYM="T":"T",SYM="TODAY":"T",1:"") + . I SYM="" S Y=-1 Q + .;FileMan only handles D, W, or M so convert Y to months. + . I PFSTACK(2)["Y" S PFSTACK(2)=+PFSTACK(2)*12_"M" + . S X=SYM_PFSTACK(3)_PFSTACK(2) + I PFSTACK(0)=1 S X=PFSTACK(1) + I TIME'="" S X=X_"@"_TIME + S %DT="ST" + D ^%DT + Q Y + ; + ;================================================== +VDATE(VIEN) ;Given a visit ien return the visit date. + N DATE + I +VIEN>0 S DATE=$P($G(^AUPNVSIT(VIEN,0)),U,1) + E S DATE=0 + I $L(DATE)=0 S DATE=0 + ;Check for historical encounter. + I $$ISHIST^PXRMVSIT(VIEN) S DATE=DATE_"E" + Q DATE + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMDBL3.m b/r/CLINICAL_REMINDERS-PXRM/PXRMDBL3.m index 3f97acc1..595f6f1e 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMDBL3.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMDBL3.m @@ -1,158 +1,158 @@ -PXRMDBL3 ; SLC/PJH - Reminder Dialog Generation. (overflow) ;11/08/2007 - ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123 - ; - ; Called from PXRMDBL1 - ; - ;Set number range for site -START ; - D SETSTART^PXRMCOPY("^PXRMD(801.41,") - ;Update dialog file for individual dialog items - D UPDATE(.ARRAY,.WPTXT,"E") - ;Create reminder dialog - D UPDATE(.DSET,"","R") - ; - W !!,"Dialog build complete" H 3 -END Q - ; - ;Error Handler - ;------------- -ERR(DESC) ; - N ERROR,IC,REF - S ERROR(1)="Unable to update dialog file : "_DESC - S ERROR(2)="Error in UPDATE^DIE, needs further investigation" - ;Move MSG into ERROR - S REF="MSG" - F IC=3:1 S REF=$Q(@REF) Q:REF="" S ERROR(IC)=REF_"="_@REF - ;Screen message - D BMES^XPDUTL(.ERROR) - Q - ; - ;Check if dialog element already exists - ;-------------------------------------- -EXISTS(NAME) ; - N IEN S IEN=$O(^PXRMD(801.41,"B",NAME,"")) - I IEN S DSET(1,CNT*5)=IEN Q 1 - Q 0 - ; - ;Update edit history - ;------------------- -HIS(IENN) ; - ;First delete any existing history entries. - N ENTRY,IND,IENS,FDA,FDAIEN,MSG,WP - S ENTRY="^PXRMD(801.41,"_IENN_",110)" - S IND=0 - F S IND=$O(@ENTRY@(IND)) Q:+IND=0 D - . S IENS=IND_","_IENN_"," - . S FDA(801.44,IENS,.01)="@" - I $D(FDA(801.44)) D - .D FILE^DIE("K","FDA","MSG") I $D(MSG) D AWRITE^PXRMUTIL("MSG") - ;Establish an initial entry in the edit history. - K FDA,MSG - S IENS="+1,"_IENN_"," - S FDAIEN(IENN)=IENN - S FDA(801.44,IENS,.01)=$$FMTE^XLFDT($$NOW^XLFDT,"5Z") - S FDA(801.44,IENS,1)=$$GET1^DIQ(200,DUZ,.01) - S FDA(801.44,IENS,2)="WP(1,1)" - S WP(1,1,1)="Autogenerated" - D UPDATE^DIE("E","FDA","FDAIEN","MSG") - I $D(MSG) D AWRITE^PXRMUTIL("MSG") - Q - ; - ;Mental Health - ;------------- -MHOK(IEN) ; - N RNAME,TEST,YT S YT="" - ;Convert ien to name - ;DBIA #5044 - S YT("CODE")=$P($G(^YTT(601.71,IEN,0)),U) - ;Quit if no code found - I YT("CODE")="" Q 0 - I '$$OK^PXRMDLL(IEN) Q 0 - ;Check if valid - ;I TEST(1)["[ERROR]" Q 0 - ; - S DNAME=FTYP_" "_YT("CODE") - ;Create arrays - S CNT=CNT+1 - ;Convert dialog item name to UC - S DNAME=$TR(DNAME,LOWER,UPPER) - ;Truncate the item name - without finesse - S DSHORT=DNAME - I $L(DSHORT)>40 S DSHORT=$E(DNAME,1,40) - ;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" - ;Result pointer - ;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 - ;Prompt text - S WPTXT(CNT,1)=YT("CODE")_" (Mental Health Instrument)" - ;test - W !!,CNT,?5,WPTXT(CNT,1) - Q 1 - ; - ;Sub-routine to update dialog file #801.41 - ;----------------------------------------- -UPDATE(INP,WPTXT,DTYPE) ; - N CNT,DATA,DESC,IEN,STRING,SUB,TEXT - N FDA,FDAIEN,MSG - ;Get each dialog line in turn - S STRING="Updating "_$S(DTYPE="E":"Dialog Elements",1:"Reminder Dialog") - D BMES^XPDUTL(STRING) - ; - ;Create FDA for each entry in array - S CNT="" - F S CNT=$O(INP(CNT)) Q:CNT="" D Q:$D(MSG) - .;If finding is a finding item parameter no need to build an element - .I DTYPE="E",$P(INP(CNT),U)=801.43 D Q - ..S DSET(1,CNT)=$P(INP(CNT),U,2) - .;Build FDA array - .K FDAIEN,FDA - .;If existing element and not in replace mode don't update FDA - .I DTYPE="E",'PXRMREPL Q:$$EXISTS($P(INP(CNT),U)) - .;Name - .S FDA(801.41,"?+1,",.01)=$P(INP(CNT),U) - .;Dialog type - .S FDA(801.41,"?+1,",4)=DTYPE - .;Class - .S FDA(801.41,"?+1,",100)="L" - .;Sponsor - .S FDA(801.41,"?+1,",101)="" - .;Prompt text/finding entries - .I DTYPE="E" D - ..S FDA(801.41,"?+1,",13)=$P(INP(CNT),U,2) - ..S FDA(801.41,"?+1,",15)=$P(INP(CNT),U,3) - ..S FDA(801.41,"?+1,",17)=$P(INP(CNT),U,4) - ..S FDA(801.41,"?+1,",25)="WPTXT("_CNT_")" - ..;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) - .;Reminder dialog associated reminder/DISABLE - .I DTYPE="R" D - ..S FDA(801.41,"?+1,",2)=REM - ..I PXRMENAB'="Y" S FDA(801.41,"?+1,",3)="DISABLED AT AUTO GENERATE" - .;Dialog items point to prompts and actions, Sets point to dialog items - .N ACNT,SUB - .;S ACNT=0,SUB=2 - .S ACNT=0,SUB=1 - .F S ACNT=$O(INP(CNT,ACNT)) Q:ACNT="" D - ..S SUB=SUB+1,FDA(801.412,"?+"_SUB_",?+1,",.01)=ACNT - ..S FDA(801.412,"?+"_SUB_",?+1,",2)=$P(INP(CNT,ACNT),U) - ..S FDA(801.412,"?+"_SUB_",?+1,",6)=$P(INP(CNT,ACNT),U,2) - ..S FDA(801.412,"?+"_SUB_",?+1,",7)=$P(INP(CNT,ACNT),U,3) - ..S FDA(801.412,"?+"_SUB_",?+1,",8)=$P(INP(CNT,ACNT),U,4) - ..S FDA(801.412,"?+"_SUB_",?+1,",9)=$P(INP(CNT,ACNT),U,5) - .;Update #801.41 - .D UPDATE^DIE("","FDA","FDAIEN","MSG") - .I $D(MSG) D ERR($G(INP(CNT))) Q - .;Save IEN of dialog created/used for later use in building dialog set - .I DTYPE="E" S DSET(1,CNT*5)=FDAIEN(1) - .;Insert link to reminder - .I DTYPE="R",PXRMLINK="Y" D - ..S $P(^PXD(811.9,REM,51),U)=FDAIEN(1),^PXD(811.9,"AG",FDAIEN(1),REM)="" - .;Update Edit History - .D HIS(FDAIEN(1)) - Q +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,") + ;Update dialog file for individual dialog items + D UPDATE(.ARRAY,.WPTXT,"E") + ;Create reminder dialog + D UPDATE(.DSET,"","R") + ; + W !!,"Dialog build complete" H 3 +END Q + ; + ;Error Handler + ;------------- +ERR(DESC) ; + N ERROR,IC,REF + S ERROR(1)="Unable to update dialog file : "_DESC + S ERROR(2)="Error in UPDATE^DIE, needs further investigation" + ;Move MSG into ERROR + S REF="MSG" + F IC=3:1 S REF=$Q(@REF) Q:REF="" S ERROR(IC)=REF_"="_@REF + ;Screen message + D BMES^XPDUTL(.ERROR) + Q + ; + ;Check if dialog element already exists + ;-------------------------------------- +EXISTS(NAME) ; + N IEN S IEN=$O(^PXRMD(801.41,"B",NAME,"")) + I IEN S DSET(1,CNT*5)=IEN Q 1 + Q 0 + ; + ;Update edit history + ;------------------- +HIS(IENN) ; + ;First delete any existing history entries. + N ENTRY,IND,IENS,FDA,FDAIEN,MSG,WP + S ENTRY="^PXRMD(801.41,"_IENN_",110)" + S IND=0 + F S IND=$O(@ENTRY@(IND)) Q:+IND=0 D + . S IENS=IND_","_IENN_"," + . S FDA(801.44,IENS,.01)="@" + I $D(FDA(801.44)) D + .D FILE^DIE("K","FDA","MSG") I $D(MSG) D AWRITE^PXRMUTIL("MSG") + ;Establish an initial entry in the edit history. + K FDA,MSG + S IENS="+1,"_IENN_"," + S FDAIEN(IENN)=IENN + S FDA(801.44,IENS,.01)=$$FMTE^XLFDT($$NOW^XLFDT,"5Z") + S FDA(801.44,IENS,1)=$$GET1^DIQ(200,DUZ,.01) + S FDA(801.44,IENS,2)="WP(1,1)" + S WP(1,1,1)="Autogenerated" + D UPDATE^DIE("E","FDA","FDAIEN","MSG") + I $D(MSG) D AWRITE^PXRMUTIL("MSG") + Q + ; + ;Mental Health + ;------------- +MHOK(IEN) ; + N RNAME,TEST,YT S YT="" + ;Convert ien to name + S YT("CODE")=$P($G(^YTT(601,IEN,0)),U) + ;Quit if no code found + I YT("CODE")="" 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 + ; + S DNAME=FTYP_" "_YT("CODE") + ;Create arrays + S CNT=CNT+1 + ;Convert dialog item name to UC + S DNAME=$TR(DNAME,LOWER,UPPER) + ;Truncate the item name - without finesse + S DSHORT=DNAME + I $L(DSHORT)>40 S DSHORT=$E(DNAME,1,40) + ;Dialog item name, finding item and result + S ARRAY(CNT)=DSHORT_U_U_RESN_U + ;Result group name + S RNAME="PXRM "_YT("CODE")_" RESULT GROUP" + ;Result pointer + 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 + ;Prompt text + S WPTXT(CNT,1)=YT("CODE")_" (Mental Health Instrument)" + ;test + W !!,CNT,?5,WPTXT(CNT,1) + Q 1 + ; + ;Sub-routine to update dialog file #801.41 + ;----------------------------------------- +UPDATE(INP,WPTXT,DTYPE) ; + N CNT,DATA,DESC,IEN,STRING,SUB,TEXT + N FDA,FDAIEN,MSG + ;Get each dialog line in turn + S STRING="Updating "_$S(DTYPE="E":"Dialog Elements",1:"Reminder Dialog") + D BMES^XPDUTL(STRING) + ; + ;Create FDA for each entry in array + S CNT="" + F S CNT=$O(INP(CNT)) Q:CNT="" D Q:$D(MSG) + .;If finding is a finding item parameter no need to build an element + .I DTYPE="E",$P(INP(CNT),U)=801.43 D Q + ..S DSET(1,CNT)=$P(INP(CNT),U,2) + .;Build FDA array + .K FDAIEN,FDA + .;If existing element and not in replace mode don't update FDA + .I DTYPE="E",'PXRMREPL Q:$$EXISTS($P(INP(CNT),U)) + .;Name + .S FDA(801.41,"?+1,",.01)=$P(INP(CNT),U) + .;Dialog type + .S FDA(801.41,"?+1,",4)=DTYPE + .;Class + .S FDA(801.41,"?+1,",100)="L" + .;Sponsor + .S FDA(801.41,"?+1,",101)="" + .;Prompt text/finding entries + .I DTYPE="E" D + ..S FDA(801.41,"?+1,",13)=$P(INP(CNT),U,2) + ..S FDA(801.41,"?+1,",15)=$P(INP(CNT),U,3) + ..S FDA(801.41,"?+1,",17)=$P(INP(CNT),U,4) + ..S FDA(801.41,"?+1,",25)="WPTXT("_CNT_")" + ..;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) + .;Reminder dialog associated reminder/DISABLE + .I DTYPE="R" D + ..S FDA(801.41,"?+1,",2)=REM + ..I PXRMENAB'="Y" S FDA(801.41,"?+1,",3)="DISABLED AT AUTO GENERATE" + .;Dialog items point to prompts and actions, Sets point to dialog items + .N ACNT,SUB + .;S ACNT=0,SUB=2 + .S ACNT=0,SUB=1 + .F S ACNT=$O(INP(CNT,ACNT)) Q:ACNT="" D + ..S SUB=SUB+1,FDA(801.412,"?+"_SUB_",?+1,",.01)=ACNT + ..S FDA(801.412,"?+"_SUB_",?+1,",2)=$P(INP(CNT,ACNT),U) + ..S FDA(801.412,"?+"_SUB_",?+1,",6)=$P(INP(CNT,ACNT),U,2) + ..S FDA(801.412,"?+"_SUB_",?+1,",7)=$P(INP(CNT,ACNT),U,3) + ..S FDA(801.412,"?+"_SUB_",?+1,",8)=$P(INP(CNT,ACNT),U,4) + ..S FDA(801.412,"?+"_SUB_",?+1,",9)=$P(INP(CNT,ACNT),U,5) + .;Update #801.41 + .D UPDATE^DIE("","FDA","FDAIEN","MSG") + .I $D(MSG) D ERR($G(INP(CNT))) Q + .;Save IEN of dialog created/used for later use in building dialog set + .I DTYPE="E" S DSET(1,CNT*5)=FDAIEN(1) + .;Insert link to reminder + .I DTYPE="R",PXRMLINK="Y" D + ..S $P(^PXD(811.9,REM,51),U)=FDAIEN(1),^PXD(811.9,"AG",FDAIEN(1),REM)="" + .;Update Edit History + .D HIS(FDAIEN(1)) + Q diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMDEDT.m b/r/CLINICAL_REMINDERS-PXRM/PXRMDEDT.m index d4ea5259..08689797 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMDEDT.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMDEDT.m @@ -1,304 +1,301 @@ -PXRMDEDT ; SLC/PJH - Edit PXRM reminder dialog. ;10/18/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ;Used by protocol PXRM SELECTION ADD/PXRM GENERAL ADD - ; - ;Add Dialog - ;---------- -ADD N DA,DIC,Y,DTOUT,DUOUT,DTYP,DLAYGO,HED - S HED="ADD DIALOG" - W IORESET - F D Q:$D(DTOUT) - .S DIC="^PXRMD(801.41," - .;Set the starting place for additions. - .D SETSTART^PXRMCOPY(DIC) - .S DIC(0)="AELMQ",DLAYGO=801.41 - .S DIC("A")="Select DIALOG to add: " - .S DIC("DR")="4///"_$G(PXRMDTYP) - .D ^DIC - .I $D(DUOUT) S DTOUT=1 - .I ($D(DTOUT))!($D(DUOUT)) Q - .I Y=-1 K DIC S DTOUT=1 Q - .I $P(Y,U,3)'=1 W !,"This dialog name already exists" Q - .S DA=$P(Y,U,1) - .;Determine dialog type - .S DTYP=$P($G(^PXRMD(801.41,DA,0)),U,4) - .;Enter dialog type if a new entry - .I DTYP="" D Q:$D(Y) - ..N DIE,DR - ..S DIE=801.41,DR=4 - ..D ^DIE - .; - .;Edit Dialog - .D EDIT(DTYP,DA,0) - Q - ; - ;called by protocol PXRM DIALOG EDIT - ;----------------------------------- -EDIT(TYP,DA,OIEN) ; - Q:'$$LOCK(DA) - W IORESET - N CS1,CS2,D1,DIC,DIDEL,DIE,DR,DTOUT,DUOUT,DINUSE,TYP,ODA,Y - ;Save checksum - S VALMBCK="" - S CS1=$$FILE^PXRMEXCS(801.41,DA) - ; - ;Check dialog type - S TYP=$P($G(^PXRMD(801.41,DA,0)),U,4) - S DIE="^PXRMD(801.41,",DIDEL=801.41,DINUSE=0,ODA=DA - ;Reminder Dialog - I TYP="R" S DR="[PXRM EDIT REMINDER DIALOG]" - ;Dialog Element - I TYP="E" S DR="[PXRM EDIT ELEMENT]" - ;Additional Prompt - ;I TYP="P" S DR="[PXRM EDIT PROMPT]" - ;Forced Value - I TYP="F" S DR="[PXRM EDIT FORCED VALUE]" - ;Dialog Group (Finding item dialog) - I TYP="G" S DR="[PXRM EDIT GROUP]" ;S VALMBCK="R" - ;Result Group - I TYP="S" S DR="[PXRM RESULT GROUP]" - ;Result Element - I TYP="T" S DR="[PXRM RESULT ELEMENT]" - ;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 - ; - I "GEPF"[TYP D - .I '$D(^PXRMD(801.41,"AD",DA)) W !,"Not used by any other dialog",! Q - .I PXRMGTYP'="DLG" S DINUSE=1 Q - .I PXRMGTYP="DLG" D Q - ..N SUB - ..S SUB=0 - ..F S SUB=$O(^PXRMD(801.41,"AD",DA,SUB)) Q:'SUB Q:DINUSE D - ...I SUB'=PXRMDIEN S DINUSE=1 - I DINUSE D - .W !,"Current dialog element/group name: "_$P($G(^PXRMD(801.41,DA,0)),U) - .I TYP="S" Q - .I PXRMGTYP="DLGE" D - ..W !,"Used by:" D USE^PXRMDLST(DA,10,"") - ..I $D(^PXRMD(801.41,"R",DA))'>0 Q - ..W !,"Used as a Replacement Element/Group for: " D REPLACE^PXRMDLST(DA,10,"") - .I PXRMGTYP'="DLGE" D - ..W !,"Used by:" D USE^PXRMDLST(DA,10,PXRMDIEN) - ..I $D(^PXRMD(801.41,"R",DA))'>0 Q - ..W !,"Used as a Replacement Element/Group for: " D REPLACE^PXRMDLST(DA,10,PXRMDIEN) - ; - ;Save list of components - N COMP D COMP^PXRMDEDX(DA,.COMP) - ;Edit dialog then unlock - I TYP'="P" D ^DIE D UNLOCK(ODA) I $G(DA)="",$G(OIEN)>0 D - .S DA=OIEN,DR="118////@" D ^DIE K DA - I TYP="P" D PROMPT(DA) D UNLOCK(ODA) - I '$D(DUOUT)&($G(D1)'="") D Q - . I $P($G(^PXRMD(801.41,DA,10,D1,0)),U,2)="" D Q - . . S DA(1)=DA,DA=D1 Q:'DA - . . S DIK="^PXRMD(801.41,"_DA(1)_",10," - . . D ^DIK - . . S VALMBG=1 - I '$D(DA) D Q - .;Clear any pointers from #811.9 - .I $D(PXRMDIEN) D PURGE(PXRMDIEN) - .;Option to delete components - .I $D(COMP) D DELETE^PXRMDEDX(.COMP) - .S VALMBCK="R" - ; - ;Update edit history - I (TYP'="R") D - .S CS2=$$FILE^PXRMEXCS(801.41,DA) Q:CS2=CS1 Q:+CS2=0 - .S DIC="^PXRMD(801.41," - .D SEHIST^PXRMUTIL(801.41,DIC,DA) - ; - ;Redisplay changes (reminder dialog option only) - I PXRMGTYP="DLG",TYP="R" D - .;Get name of reminder dialog again - .S Y=$P($G(^PXRMD(801.41,DA,0)),U) - .;Format headings to include dialog name - .S PXRMHD="REMINDER DIALOG NAME: "_$P(Y,U) - .;Check if the set is disable and add to header if disabled - .I $P(^PXRMD(801.41,DA,0),U,3)]"" S PXRMHD=PXRMHD_" (DISABLED)" - .;Reset header in case name has changed - .S VALMHDR(1)=PXRMHD - Q - ; - ;Add SINGLE dialog element (protocol PXRM DIALOG SELECTION ITEM) - ;------------------------- -ESEL(PXRMDIEN,SEL) ; - N DA,DIC,DLAYGO,DNEW,DTOUT,DUOUT,DTYP,Y - ; - S DIC="^PXRMD(801.41," - S DLAYGO="801.41" - ;Set the starting place for additions. - D SETSTART^PXRMCOPY(DIC) - S DIC(0)="AEMQL" - S DIC("A")="Select new DIALOG ELEMENT: " - S DIC("S")="I ""EG""[$P(^PXRMD(801.41,Y,0),U,4)" - S DIC("DR")="4///E" - W ! - D ^DIC - I $D(DUOUT) S DTOUT=1 - I ($D(DTOUT))!($D(DUOUT)) Q - I Y=-1 K DIC S DTOUT=1 Q - S DA=$P(Y,U,1) Q:'DA - S DNEW=$P(Y,U,3) - ;Group points to itself - I 'DNEW,$$VGROUP(DA,PXRMDIEN) Q - ;Add to dialog - D EADD(SEL,DA,PXRMDIEN) - ;Determine dialog type - S DTYP=$P($G(^PXRMD(801.41,DA,0)),U,4) - ; - ;Edit Dialog - I DNEW D EDIT(DTYP,DA) - Q - ; - ;Update dialog component multiple - ;-------------------------------- -EADD(SEL,NSUB,PXRMDIEN) ; - N DA,DATA,NEXT - S DATA=$G(^PXRMD(801.41,PXRMDIEN,10,0)),NEXT=$P(DATA,U,3)+1 - I DATA="" S DATA="^801.412IA" - S DA=NSUB,DA(1)=PXRMDIEN - S ^PXRMD(801.41,PXRMDIEN,10,NEXT,0)=SEL_U_DA_"^^^^^^^" - ;Update next slot - S $P(DATA,U,4)=$P(DATA,U,4)+1,$P(DATA,U,3)=NEXT - S ^PXRMD(801.41,PXRMDIEN,10,0)=DATA - ;Re-index - N DIK,DA S DIK="^PXRMD(801.41,",DA=PXRMDIEN - D IX^DIK - Q - ; - ;Change Dialog Element Type - ;-------------------------- -NTYP(TYP) ; - N X,Y,DIR K DIROUT,DIRUT,DTOUT,DUOUT - S DIR(0)="SA"_U_"E:Element;" - S DIR(0)=DIR(0)_"G:Group;" - S DIR("A")="Dialog Element Type: " - S DIR("B")="E" - S DIR("?")="Select from the codes displayed. For detailed help type ??" - S DIR("??")=U_"D HELP^PXRMDEDT(3)" - D ^DIR K DIR - I $D(DIROUT) S DTOUT=1 - I $D(DTOUT)!($D(DUOUT)) Q - S TYP=Y - Q - ; - ;Clear pointers from the reminder file and process ID file - ;--------------------------------------------------------- -PURGE(DIEN) ; - ;Purge pointers to this dialog from reminder file - N RIEN - S RIEN=0 - F S RIEN=$O(^PXD(811.9,"AG",DIEN,RIEN)) Q:'RIEN D - .K ^PXD(811.9,RIEN,51),^PXD(811.9,"AG",DIEN,RIEN) - ; - Q - ; -VGROUP(DA,IEN) ;Check dialog index to see if group will point to itself - N FOUND - S FOUND=0 - ; - ;Only do check if dialog is a group - I $P($G(^PXRMD(801.41,DA,0)),U,4)'="G" Q FOUND - ; - ;Group cannot be added to itself - I DA=IEN D Q FOUND - .S FOUND=1 - .W !,"A group cannot be added to itself" H 2 - ; - ;IEN is the dialog group being added to - D VGROUP1(DA,IEN) - Q FOUND - ; -VGROUP1(DA,DIEN) ;Examine all parent dialogs - ; - ;End search if already found - Q:FOUND - ; - ;Check if dialog being added is a parent at this level - I $D(^PXRMD(801.41,"AD",DIEN,DA)) D Q - .S FOUND=1 - .W !,"A group cannot be added as it's own descendant" H 2 - ; - ;If not look at other parents - N SUB - S SUB=0 - F S SUB=$O(^PXRMD(801.41,"AD",DIEN,SUB)) Q:'SUB D Q:FOUND - .;Ignore reminder dialogs - .I $P($G(^PXRMD(801.41,SUB,0)),U,4)'="G" Q - .;Repeat check on other parents - .D VGROUP1(DA,SUB) - Q - ; -HELP(CALL) ;General help text routine - N HTEXT - N DIWF,DIWL,DIWR,IC - S DIWF="C70",DIWL=0,DIWR=70 - ; - I CALL=1 D - .S HTEXT(1)="Select E to edit dialog element. If you wish to create" - .S HTEXT(2)="a new dialog element just for this reminder dialog select" - .S HTEXT(3)="C to copy and replace the current element. Select D to" - .S HTEXT(4)="delete the sequence number/element from the dialog." - I CALL=2 D - .S HTEXT(1)="Enter Y to copy the current dialog element to a new name" - .S HTEXT(2)="and then use this new element in the reminder dialog." - I CALL=3 D - .S HTEXT(1)="Enter G to change the current dialog element into a dialog" - .S HTEXT(2)="group so that additional elements can be added. Enter E to" - .S HTEXT(3)="leave the type of the dialog element unchanged." - I CALL=4 D - .S HTEXT(1)="Enter Y to change the dialog prompt created into a forced" - .S HTEXT(2)="value. To edit the new forced value switch to the forced" - .S HTEXT(3)="value screen using CV. This option only applies to prompts" - .S HTEXT(4)="which update PCE or vitals." - .S HTEXT(5)="Enter N to leave the dialog prompt unchanged." - 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 - ; -LOCK(DA) ;Lock the record - N OK - S OK=1 - I '$$VEDIT^PXRMUTIL("^PXRMD(801.41,",DA) D - .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 - .I DTYP="G",$G(PXRMGTYP)="DLGE" Q - .;Allow edit of element findings - .I DTYP="E" Q - .S OK=0 - .W !!,?5,"VA- and national class reminder dialogs may not be edited" H 2 - I 'OK Q 0 - ; - L +^PXRMD(801.41,DA):0 I Q 1 - E W !!,?5,"Another user is editing this file, try later" H 2 Q 0 - ; -PROMPT(IEN) ; - N DIE,DR - S DIE="^PXRMD(801.41,",DA=IEN - S DR=".01;3;100;101;102;24;23;21" - S IEN=$G(^PXRMD(801.41,IEN,46)) I $G(IEN)="" G EX - I $P($G(^PXRMD(801.42,IEN,0)),U)="COM" S DR=DR_";45" -EX ; - D ^DIE - Q - ; -UNLOCK(DA) ;Unlock the record - L -^PXRMD(801.41,DA) - Q +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 + ; + ;Add Dialog + ;---------- +ADD N DA,DIC,Y,DTOUT,DUOUT,DTYP,DLAYGO,HED + S HED="ADD DIALOG" + W IORESET + F D Q:$D(DTOUT) + .S DIC="^PXRMD(801.41," + .;Set the starting place for additions. + .D SETSTART^PXRMCOPY(DIC) + .S DIC(0)="AELMQ",DLAYGO=801.41 + .S DIC("A")="Select DIALOG to add: " + .S DIC("DR")="4///"_$G(PXRMDTYP) + .D ^DIC + .I $D(DUOUT) S DTOUT=1 + .I ($D(DTOUT))!($D(DUOUT)) Q + .I Y=-1 K DIC S DTOUT=1 Q + .I $P(Y,U,3)'=1 W !,"This dialog name already exists" Q + .S DA=$P(Y,U,1) + .;Determine dialog type + .S DTYP=$P($G(^PXRMD(801.41,DA,0)),U,4) + .;Enter dialog type if a new entry + .I DTYP="" D Q:$D(Y) + ..N DIE,DR + ..S DIE=801.41,DR=4 + ..D ^DIE + .; + .;Edit Dialog + .D EDIT(DTYP,DA,0) + Q + ; + ;called by protocol PXRM DIALOG EDIT + ;----------------------------------- +EDIT(TYP,DA,OIEN) ; + Q:'$$LOCK(DA) + W IORESET + N CS1,CS2,D1,DIC,DIDEL,DIE,DR,DTOUT,DUOUT,DINUSE,TYP,ODA,Y + ;Save checksum + S VALMBCK="" + S CS1=$$FILE^PXRMEXCS(801.41,DA) + ; + ;Check dialog type + S TYP=$P($G(^PXRMD(801.41,DA,0)),U,4) + S DIE="^PXRMD(801.41,",DIDEL=801.41,DINUSE=0,ODA=DA + ;Reminder Dialog + I TYP="R" S DR="[PXRM EDIT REMINDER DIALOG]" + ;Dialog Element + I TYP="E" S DR="[PXRM EDIT ELEMENT]" + ;Additional Prompt + ;I TYP="P" S DR="[PXRM EDIT PROMPT]" + ;Forced Value + I TYP="F" S DR="[PXRM EDIT FORCED VALUE]" + ;Dialog Group (Finding item dialog) + I TYP="G" S DR="[PXRM EDIT GROUP]" ;S VALMBCK="R" + ;Result Group + I TYP="S" S DR="[PXRM RESULT GROUP]" + ;Result Element + I TYP="T" S DR="[PXRM RESULT ELEMENT]" + ;Allows limited edit of national dialogs + I $P($G(^PXRMD(801.41,DA,100)),U)="N" D + .I $G(PXRMINST)=1,DUZ(0)="@" Q + .S DR="[PXRM EDIT NATIONAL DIALOG]",DINUSE=1 + ; + I "GEPF"[TYP D + .I '$D(^PXRMD(801.41,"AD",DA)) W !,"Not used by any other dialog",! Q + .I PXRMGTYP'="DLG" S DINUSE=1 Q + .I PXRMGTYP="DLG" D Q + ..N SUB + ..S SUB=0 + ..F S SUB=$O(^PXRMD(801.41,"AD",DA,SUB)) Q:'SUB Q:DINUSE D + ...I SUB'=PXRMDIEN S DINUSE=1 + I DINUSE D + .W !,"Current dialog element/group name: "_$P($G(^PXRMD(801.41,DA,0)),U) + .I TYP="S" Q + .I PXRMGTYP="DLGE" D + ..W !,"Used by:" D USE^PXRMDLST(DA,10,"") + ..I $D(^PXRMD(801.41,"R",DA))'>0 Q + ..W !,"Used as a Replacement Element/Group for: " D REPLACE^PXRMDLST(DA,10,"") + .I PXRMGTYP'="DLGE" D + ..W !,"Used by:" D USE^PXRMDLST(DA,10,PXRMDIEN) + ..I $D(^PXRMD(801.41,"R",DA))'>0 Q + ..W !,"Used as a Replacement Element/Group for: " D REPLACE^PXRMDLST(DA,10,PXRMDIEN) + ; + ;Save list of components + N COMP D COMP^PXRMDEDX(DA,.COMP) + ;Edit dialog then unlock + I TYP'="P" D ^DIE D UNLOCK(ODA) I $G(DA)="",$G(OIEN)>0 D + .S DA=OIEN,DR="118////@" D ^DIE K DA + I TYP="P" D PROMPT(DA) D UNLOCK(ODA) + I '$D(DUOUT)&($G(D1)'="") D Q + . I $P($G(^PXRMD(801.41,DA,10,D1,0)),U,2)="" D Q + . . S DA(1)=DA,DA=D1 Q:'DA + . . S DIK="^PXRMD(801.41,"_DA(1)_",10," + . . D ^DIK + . . S VALMBG=1 + I '$D(DA) D Q + .;Clear any pointers from #811.9 + .I $D(PXRMDIEN) D PURGE(PXRMDIEN) + .;Option to delete components + .I $D(COMP) D DELETE^PXRMDEDX(.COMP) + .S VALMBCK="R" + ; + ;Update edit history + I (TYP'="R") D + .S CS2=$$FILE^PXRMEXCS(801.41,DA) Q:CS2=CS1 Q:+CS2=0 + .S DIC="^PXRMD(801.41," + .D SEHIST^PXRMUTIL(801.41,DIC,DA) + ; + ;Redisplay changes (reminder dialog option only) + I PXRMGTYP="DLG",TYP="R" D + .;Get name of reminder dialog again + .S Y=$P($G(^PXRMD(801.41,DA,0)),U) + .;Format headings to include dialog name + .S PXRMHD="REMINDER DIALOG NAME: "_$P(Y,U) + .;Check if the set is disable and add to header if disabled + .I $P(^PXRMD(801.41,DA,0),U,3)]"" S PXRMHD=PXRMHD_" (DISABLED)" + .;Reset header in case name has changed + .S VALMHDR(1)=PXRMHD + Q + ; + ;Add SINGLE dialog element (protocol PXRM DIALOG SELECTION ITEM) + ;------------------------- +ESEL(PXRMDIEN,SEL) ; + N DA,DIC,DLAYGO,DNEW,DTOUT,DUOUT,DTYP,Y + ; + S DIC="^PXRMD(801.41," + S DLAYGO="801.41" + ;Set the starting place for additions. + D SETSTART^PXRMCOPY(DIC) + S DIC(0)="AEMQL" + S DIC("A")="Select new DIALOG ELEMENT: " + S DIC("S")="I ""EG""[$P(^PXRMD(801.41,Y,0),U,4)" + S DIC("DR")="4///E" + W ! + D ^DIC + I $D(DUOUT) S DTOUT=1 + I ($D(DTOUT))!($D(DUOUT)) Q + I Y=-1 K DIC S DTOUT=1 Q + S DA=$P(Y,U,1) Q:'DA + S DNEW=$P(Y,U,3) + ;Group points to itself + I 'DNEW,$$VGROUP(DA,PXRMDIEN) Q + ;Add to dialog + D EADD(SEL,DA,PXRMDIEN) + ;Determine dialog type + S DTYP=$P($G(^PXRMD(801.41,DA,0)),U,4) + ; + ;Edit Dialog + I DNEW D EDIT(DTYP,DA) + Q + ; + ;Update dialog component multiple + ;-------------------------------- +EADD(SEL,NSUB,PXRMDIEN) ; + N DA,DATA,NEXT + S DATA=$G(^PXRMD(801.41,PXRMDIEN,10,0)),NEXT=$P(DATA,U,3)+1 + I DATA="" S DATA="^801.412IA" + S DA=NSUB,DA(1)=PXRMDIEN + S ^PXRMD(801.41,PXRMDIEN,10,NEXT,0)=SEL_U_DA_"^^^^^^^" + ;Update next slot + S $P(DATA,U,4)=$P(DATA,U,4)+1,$P(DATA,U,3)=NEXT + S ^PXRMD(801.41,PXRMDIEN,10,0)=DATA + ;Re-index + N DIK,DA S DIK="^PXRMD(801.41,",DA=PXRMDIEN + D IX^DIK + Q + ; + ;Change Dialog Element Type + ;-------------------------- +NTYP(TYP) ; + N X,Y,DIR K DIROUT,DIRUT,DTOUT,DUOUT + S DIR(0)="SA"_U_"E:Element;" + S DIR(0)=DIR(0)_"G:Group;" + S DIR("A")="Dialog Element Type: " + S DIR("B")="E" + S DIR("?")="Select from the codes displayed. For detailed help type ??" + S DIR("??")=U_"D HELP^PXRMDEDT(3)" + D ^DIR K DIR + I $D(DIROUT) S DTOUT=1 + I $D(DTOUT)!($D(DUOUT)) Q + S TYP=Y + Q + ; + ;Clear pointers from the reminder file and process ID file + ;--------------------------------------------------------- +PURGE(DIEN) ; + ;Purge pointers to this dialog from reminder file + N RIEN + S RIEN=0 + F S RIEN=$O(^PXD(811.9,"AG",DIEN,RIEN)) Q:'RIEN D + .K ^PXD(811.9,RIEN,51),^PXD(811.9,"AG",DIEN,RIEN) + ; + Q + ; +VGROUP(DA,IEN) ;Check dialog index to see if group will point to itself + N FOUND + S FOUND=0 + ; + ;Only do check if dialog is a group + I $P($G(^PXRMD(801.41,DA,0)),U,4)'="G" Q FOUND + ; + ;Group cannot be added to itself + I DA=IEN D Q FOUND + .S FOUND=1 + .W !,"A group cannot be added to itself" H 2 + ; + ;IEN is the dialog group being added to + D VGROUP1(DA,IEN) + Q FOUND + ; +VGROUP1(DA,DIEN) ;Examine all parent dialogs + ; + ;End search if already found + Q:FOUND + ; + ;Check if dialog being added is a parent at this level + I $D(^PXRMD(801.41,"AD",DIEN,DA)) D Q + .S FOUND=1 + .W !,"A group cannot be added as it's own descendant" H 2 + ; + ;If not look at other parents + N SUB + S SUB=0 + F S SUB=$O(^PXRMD(801.41,"AD",DIEN,SUB)) Q:'SUB D Q:FOUND + .;Ignore reminder dialogs + .I $P($G(^PXRMD(801.41,SUB,0)),U,4)'="G" Q + .;Repeat check on other parents + .D VGROUP1(DA,SUB) + Q + ; +HELP(CALL) ;General help text routine + N HTEXT + N DIWF,DIWL,DIWR,IC + S DIWF="C70",DIWL=0,DIWR=70 + ; + I CALL=1 D + .S HTEXT(1)="Select E to edit dialog element. If you wish to create" + .S HTEXT(2)="a new dialog element just for this reminder dialog select" + .S HTEXT(3)="C to copy and replace the current element. Select D to" + .S HTEXT(4)="delete the sequence number/element from the dialog." + I CALL=2 D + .S HTEXT(1)="Enter Y to copy the current dialog element to a new name" + .S HTEXT(2)="and then use this new element in the reminder dialog." + I CALL=3 D + .S HTEXT(1)="Enter G to change the current dialog element into a dialog" + .S HTEXT(2)="group so that additional elements can be added. Enter E to" + .S HTEXT(3)="leave the type of the dialog element unchanged." + I CALL=4 D + .S HTEXT(1)="Enter Y to change the dialog prompt created into a forced" + .S HTEXT(2)="value. To edit the new forced value switch to the forced" + .S HTEXT(3)="value screen using CV. This option only applies to prompts" + .S HTEXT(4)="which update PCE or vitals." + .S HTEXT(5)="Enter N to leave the dialog prompt unchanged." + 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 + ; +LOCK(DA) ;Lock the record + N OK + S OK=1 + I '$$VEDIT^PXRMUTIL("^PXRMD(801.41,",DA) D + .N DTYP + .S DTYP=$P($G(^PXRMD(801.41,DA,0)),U,4) + .;Allow edit of findings but not component multiple on groups + .I DTYP="G",$G(PXRMDIEN),DA'=PXRMDIEN Q + .I DTYP="G",$G(PXRMGTYP)="DLGE" Q + .;Allow edit of element findings + .I DTYP="E" Q + .S OK=0 + .W !!,?5,"VA- and national class reminder dialogs may not be edited" H 2 + I 'OK Q 0 + ; + L +^PXRMD(801.41,DA):0 I Q 1 + E W !!,?5,"Another user is editing this file, try later" H 2 Q 0 + ; +PROMPT(IEN) ; + N DIE,DR + S DIE="^PXRMD(801.41,",DA=IEN + S DR=".01;3;100;101;102;24;23;21" + S IEN=$G(^PXRMD(801.41,IEN,46)) I $G(IEN)="" G EX + I $P($G(^PXRMD(801.42,IEN,0)),U)="COM" S DR=DR_";45" +EX ; + D ^DIE + Q + ; +UNLOCK(DA) ;Unlock the record + L -^PXRMD(801.41,DA) + Q diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMDEV.m b/r/CLINICAL_REMINDERS-PXRM/PXRMDEV.m index 3e8c4582..0264668b 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMDEV.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMDEV.m @@ -1,148 +1,150 @@ -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 - ; - ;================================================== -CMOUT ;Do formatted Clinical Maintenance output. - N DUE,DUECOL,HIST,LAST,LASTCOL,LNUM,RIEN,RNAME,STATUS,STATCOL,TEMP,TYPE - W !!,"Formatted Output:" - S RIEN=$O(^TMP("PXRHM",$J,"")) - S RNAME=$O(^TMP("PXRHM",$J,RIEN,"")) - S TEMP=$G(^TMP("PXRHM",$J,RIEN,RNAME)) - S STATUS=$P(TEMP,U,1) - S DUE=$$EDATE^PXRMDATE($P(TEMP,U,2)) - S LAST=$$EDATE^PXRMDATE($P(TEMP,U,3)) - S STATCOL=41-($L(STATUS)/2) - S DUECOL=53-($L(DUE)/2) - S LASTCOL=67-($L(LAST)/2) - W !!,?36,"--STATUS--",?47,"--DUE DATE--",?61,"--LAST DONE--",! - W !,RNAME,?STATCOL,STATUS,?DUECOL,DUE,?LASTCOL,LAST,! - S LNUM=0 - F S LNUM=$O(^TMP("PXRHM",$J,RIEN,RNAME,"TXT",LNUM)) Q:LNUM="" D - . W !,^TMP("PXRHM",$J,RIEN,RNAME,"TXT",LNUM) - Q - ; - ;================================================== -DEB ;Prompt for patient and reminder by name input component. - N DATE,DFN,DIC,DIR,DIROUT,DTOUT,DUOUT,PXRMITEM,PXRHM,PXRMTDEB,X,Y - S DIC=2,DIC("A")="Select Patient: " - S DIC(0)="AEQMZ" - D ^DIC - I $D(DTOUT)!$D(DUOUT) Q - S DFN=+$P(Y,U,1) - I DFN=-1 W !,"No patient selected!" Q - S DIC=811.9,DIC("A")="Select Reminder: " - D ^DIC - I $D(DIROUT)!$D(DIRUT) Q - I $D(DTOUT)!$D(DUOUT) Q - S PXRMITEM=+$P(Y,U,1) - I PXRMITEM=-1 W !,"No reminder selected!" Q - S DIR(0)="LA"_U_"0" - S DIR("A")="Enter component number 0, 1, 5, 10, 11, 12: " - D ^DIR - I $D(DIROUT)!$D(DIRUT) Q - I $D(DTOUT)!$D(DUOUT) Q - I X="" S X=5 - S PXRHM=X - S DIR(0)="DA^"_0_"::ETX" - S DIR("A")="Enter date for reminder evaluation: " - S DIR("B")=$$FMTE^XLFDT($$DT^XLFDT,"D") - S DIR("PRE")="S X=$$DCHECK^PXRMDATE(X) K:X=-1 X" - W ! - D ^DIR K DIR - I $D(DIROUT)!$D(DIRUT) Q - I $D(DTOUT)!$D(DUOUT) Q - S DATE=Y - I $D(^PXD(811.9,PXRMITEM,20,"E","PXRMD(811.5,")) S PXRMTDEB=$$ASKYN^PXRMEUT("N","Display all term findings","","") - D DOREM(DFN,PXRMITEM,PXRHM,DATE) - Q - ; - ;================================================== -DEV ;Prompt for patient and reminder by name and evaluation date. - N DATE,DFN,DIC,DIROUT,DIRUT,DTOUT,DUOUT,PXRMITEM,PXRHM,PXRMTDEB,REF,X,Y - S DIC=2,DIC("A")="Select Patient: " - S DIC(0)="AEQMZ" - D ^DIC - I $D(DIROUT)!$D(DIRUT) Q - I $D(DTOUT)!$D(DUOUT) Q - S DFN=+$P(Y,U,1) - S DIC=811.9,DIC("A")="Select Reminder: " - D ^DIC - I $D(DIROUT)!$D(DIRUT) Q - I $D(DTOUT)!$D(DUOUT) Q - S PXRMITEM=+$P(Y,U,1) - S PXRHM=5 - S DIR(0)="DA^"_0_"::ETX" - S DIR("A")="Enter date for reminder evaluation: " - S DIR("B")=$$FMTE^XLFDT($$DT^XLFDT,"D") - S DIR("PRE")="S X=$$DCHECK^PXRMDATE(X) K:X=-1 X" - W ! - D ^DIR K DIR - I $D(DIROUT)!$D(DIRUT) Q - I $D(DTOUT)!$D(DUOUT) Q - S DATE=Y - I $D(^PXD(811.9,PXRMITEM,20,"E","PXRMD(811.5,")) S PXRMTDEB=$$ASKYN^PXRMEUT("N","Display all term findings","","") - D DOREM(DFN,PXRMITEM,PXRHM,DATE) - Q - ; - ;================================================== -DOREM(DFN,PXRMITEM,PXRMHM,DATE) ;Do the reminder - N DEFARR,FIEVAL,FINDING,PXRMDEBG,PXRMID,REF,TFIEVAL - ;This is a debugging run so set PXRMDEBG. - S PXRMDEBG=1 - D DEF^PXRMLDR(PXRMITEM,.DEFARR) - I +$G(DATE)=0 D EVAL^PXRM(DFN,.DEFARR,PXRHM,1,.FIEVAL) - I +$G(DATE)>0 D EVAL^PXRM(DFN,.DEFARR,PXRHM,1,.FIEVAL,DATE) - ; - W !!,"The elements of the FIEVAL array are:" - S REF="FIEVAL" - D AWRITE^PXRMUTIL(REF) - ; - I $G(PXRMTDEB) D - . W !!,"Term findings:" - . S REF="TFIEVAL" - . S FINDING=0 - . F S FINDING=$O(^TMP("PXRMTDEB",$J,FINDING)) Q:FINDING="" D - .. K TFIEVAL M TFIEVAL(FINDING)=^TMP("PXRMTDEB",$J,FINDING) - .. W !,"Finding ",FINDING,":" - .. D AWRITE^PXRMUTIL(REF) - . K ^TMP("PXRMTDEB",$J) - ; - W !!,"The elements of the ^TMP(PXRMID,$J) array are:" - I $D(PXRMID) S REF="^TMP(PXRMID,$J)" D AWRITE^PXRMUTIL(REF) K ^TMP(PXRMID,$J) - ; - W !!,"The elements of the ^TMP(""PXRHM"",$J) array are:" - S REF="^TMP(""PXRHM"",$J)" - D AWRITE^PXRMUTIL(REF) - ; - I $D(^TMP("PXRHM",$J)) D CMOUT - I PXRHM=12 D MHVCOUT - K ^TMP("PXRM",$J),^TMP("PXRHM",$J),^TMP("PXRMMHVC",$J) - Q - ;================================================== -MHVCOUT ;Do formatted MHV combined output. - N DUE,DUECOL,HIST,LAST,LASTCOL,LNUM,RIEN,RNAME,STATUS,STATCOL,TEMP,TYPE - W !!,"Formatted Output:" - S RIEN=$O(^TMP("PXRMMHVC",$J,"")) - S TEMP=^TMP("PXRMMHVC",$J,RIEN,"STATUS") - S STATUS=$P(TEMP,U,1) - S DUE=$$EDATE^PXRMDATE($P(TEMP,U,2)) - S LAST=$$EDATE^PXRMDATE($P(TEMP,U,3)) - S DUE=$$EDATE^PXRMDATE($P(TEMP,U,2)) - S LAST=$$EDATE^PXRMDATE($P(TEMP,U,3)) - S STATCOL=41-($L(STATUS)/2) - S DUECOL=53-($L(DUE)/2) - S LASTCOL=67-($L(LAST)/2) - S RNAME=$P(^PXD(811.9,RIEN,0),U,3) - I RNAME="" S RNAME=$P(^PXD(811.9,RIEN,0),U,1) - W !!,?36,"--STATUS--",?47,"--DUE DATE--",?61,"--LAST DONE--",! - W !,RNAME,?STATCOL,STATUS,?DUECOL,DUE,?LASTCOL,LAST,! - W !!,"---------- Detailed Output ----------" - S LNUM=0 - F S LNUM=$O(^TMP("PXRMMHVC",$J,RIEN,"DETAIL",LNUM)) Q:LNUM="" D - . W !,^TMP("PXRMMHVC",$J,RIEN,"DETAIL",LNUM) - W !!,"---------- Summary Output ----------" - S LNUM=0 - F S LNUM=$O(^TMP("PXRMMHVC",$J,RIEN,"SUMMARY",LNUM)) Q:LNUM="" D - . W !,^TMP("PXRMMHVC",$J,RIEN,"SUMMARY",LNUM) - Q - ; +PXRMDEV ; SLC/PKR - This is a driver for testing Clinical Reminders.;05/04/2006 + ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21 + ; + ;================================================== +CMOUT ;Do formatted Clinical Maintenance output. + N DUE,DUECOL,HIST,LAST,LASTCOL,LNUM,RIEN,RNAME,STATUS,STATCOL,TEMP,TYPE + W !!,"Formatted Output:" + S RIEN=$O(^TMP("PXRHM",$J,"")) + S RNAME=$O(^TMP("PXRHM",$J,RIEN,"")) + S TEMP=$G(^TMP("PXRHM",$J,RIEN,RNAME)) + S STATUS=$P(TEMP,U,1) + S DUE=$$EDATE^PXRMDATE($P(TEMP,U,2)) + S LAST=$$EDATE^PXRMDATE($P(TEMP,U,3)) + S STATCOL=41-($L(STATUS)/2) + S DUECOL=53-($L(DUE)/2) + S LASTCOL=67-($L(LAST)/2) + W !!,?36,"--STATUS--",?47,"--DUE DATE--",?61,"--LAST DONE--",! + W !,RNAME,?STATCOL,STATUS,?DUECOL,DUE,?LASTCOL,LAST,! + S LNUM=0 + F S LNUM=$O(^TMP("PXRHM",$J,RIEN,RNAME,"TXT",LNUM)) Q:LNUM="" D + . W !,^TMP("PXRHM",$J,RIEN,RNAME,"TXT",LNUM) + Q + ; + ;================================================== +DEB ;Prompt for patient and reminder by name input component. + N DATE,DFN,DIC,DIR,DIROUT,DTOUT,DUOUT,PXRMITEM,PXRHM,PXRMTDEB,X,Y + S DIC=2,DIC("A")="Select Patient: " + S DIC(0)="AEQMZ" + D ^DIC + I $D(DTOUT)!$D(DUOUT) Q + S DFN=+$P(Y,U,1) + 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 + I $D(DTOUT)!$D(DUOUT) Q + S PXRMITEM=+$P(Y,U,1) + I PXRMITEM=-1 W !,"No reminder selected!" Q + S DIR(0)="LA"_U_"0" + S DIR("A")="Enter component number 0, 1, 5, 10, 11, 12: " + D ^DIR + I $D(DIROUT)!$D(DIRUT) Q + I $D(DTOUT)!$D(DUOUT) Q + I X="" S X=5 + S PXRHM=X + S DIR(0)="DA^"_0_"::ETX" + S DIR("A")="Enter date for reminder evaluation: " + S DIR("B")=$$FMTE^XLFDT($$DT^XLFDT,"D") + S DIR("PRE")="S X=$$DCHECK^PXRMDATE(X) K:X=-1 X" + W ! + D ^DIR K DIR + I $D(DIROUT)!$D(DIRUT) Q + I $D(DTOUT)!$D(DUOUT) Q + S DATE=Y + I $D(^PXD(811.9,PXRMITEM,20,"E","PXRMD(811.5,")) S PXRMTDEB=$$ASKYN^PXRMEUT("N","Display all term findings","","") + D DOREM(DFN,PXRMITEM,PXRHM,DATE) + Q + ; + ;================================================== +DEV ;Prompt for patient and reminder by name and evaluation date. + N DATE,DFN,DIC,DIROUT,DIRUT,DTOUT,DUOUT,PXRMITEM,PXRHM,PXRMTDEB,REF,X,Y + S DIC=2,DIC("A")="Select Patient: " + S DIC(0)="AEQMZ" + D ^DIC + I $D(DIROUT)!$D(DIRUT) Q + I $D(DTOUT)!$D(DUOUT) 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 + I $D(DTOUT)!$D(DUOUT) Q + S PXRMITEM=+$P(Y,U,1) + S PXRHM=5 + S DIR(0)="DA^"_0_"::ETX" + S DIR("A")="Enter date for reminder evaluation: " + S DIR("B")=$$FMTE^XLFDT($$DT^XLFDT,"D") + S DIR("PRE")="S X=$$DCHECK^PXRMDATE(X) K:X=-1 X" + W ! + D ^DIR K DIR + I $D(DIROUT)!$D(DIRUT) Q + I $D(DTOUT)!$D(DUOUT) Q + S DATE=Y + I $D(^PXD(811.9,PXRMITEM,20,"E","PXRMD(811.5,")) S PXRMTDEB=$$ASKYN^PXRMEUT("N","Display all term findings","","") + D DOREM(DFN,PXRMITEM,PXRHM,DATE) + Q + ; + ;================================================== +DOREM(DFN,PXRMITEM,PXRMHM,DATE) ;Do the reminder + N DEFARR,FIEVAL,FINDING,PXRMDEBG,PXRMID,REF,TFIEVAL + ;This is a debugging run so set PXRMDEBG. + S PXRMDEBG=1 + D DEF^PXRMLDR(PXRMITEM,.DEFARR) + I +$G(DATE)=0 D EVAL^PXRM(DFN,.DEFARR,PXRHM,1,.FIEVAL) + I +$G(DATE)>0 D EVAL^PXRM(DFN,.DEFARR,PXRHM,1,.FIEVAL,DATE) + ; + W !!,"The elements of the FIEVAL array are:" + S REF="FIEVAL" + D AWRITE^PXRMUTIL(REF) + ; + I $G(PXRMTDEB) D + . W !!,"Term findings:" + . S REF="TFIEVAL" + . S FINDING=0 + . F S FINDING=$O(^TMP("PXRMTDEB",$J,FINDING)) Q:FINDING="" D + .. K TFIEVAL M TFIEVAL(FINDING)=^TMP("PXRMTDEB",$J,FINDING) + .. W !,"Finding ",FINDING,":" + .. D AWRITE^PXRMUTIL(REF) + . K ^TMP("PXRMTDEB",$J) + ; + W !!,"The elements of the ^TMP(PXRMID,$J) array are:" + I $D(PXRMID) S REF="^TMP(PXRMID,$J)" D AWRITE^PXRMUTIL(REF) K ^TMP(PXRMID,$J) + ; + W !!,"The elements of the ^TMP(""PXRHM"",$J) array are:" + S REF="^TMP(""PXRHM"",$J)" + D AWRITE^PXRMUTIL(REF) + ; + I $D(^TMP("PXRHM",$J)) D CMOUT + I PXRHM=12 D MHVCOUT + K ^TMP("PXRM",$J),^TMP("PXRHM",$J),^TMP("PXRMMHVC",$J) + Q + ;================================================== +MHVCOUT ;Do formatted MHV combined output. + N DUE,DUECOL,HIST,LAST,LASTCOL,LNUM,RIEN,RNAME,STATUS,STATCOL,TEMP,TYPE + W !!,"Formatted Output:" + S RIEN=$O(^TMP("PXRMMHVC",$J,"")) + S TEMP=^TMP("PXRMMHVC",$J,RIEN,"STATUS") + S STATUS=$P(TEMP,U,1) + S DUE=$$EDATE^PXRMDATE($P(TEMP,U,2)) + S LAST=$$EDATE^PXRMDATE($P(TEMP,U,3)) + S DUE=$$EDATE^PXRMDATE($P(TEMP,U,2)) + S LAST=$$EDATE^PXRMDATE($P(TEMP,U,3)) + S STATCOL=41-($L(STATUS)/2) + S DUECOL=53-($L(DUE)/2) + S LASTCOL=67-($L(LAST)/2) + S RNAME=$P(^PXD(811.9,RIEN,0),U,3) + I RNAME="" S RNAME=$P(^PXD(811.9,RIEN,0),U,1) + W !!,?36,"--STATUS--",?47,"--DUE DATE--",?61,"--LAST DONE--",! + W !,RNAME,?STATCOL,STATUS,?DUECOL,DUE,?LASTCOL,LAST,! + W !!,"---------- Detailed Output ----------" + S LNUM=0 + F S LNUM=$O(^TMP("PXRMMHVC",$J,RIEN,"DETAIL",LNUM)) Q:LNUM="" D + . W !,^TMP("PXRMMHVC",$J,RIEN,"DETAIL",LNUM) + W !!,"---------- Summary Output ----------" + S LNUM=0 + F S LNUM=$O(^TMP("PXRMMHVC",$J,RIEN,"SUMMARY",LNUM)) Q:LNUM="" D + . W !,^TMP("PXRMMHVC",$J,RIEN,"SUMMARY",LNUM) + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMDLG4.m b/r/CLINICAL_REMINDERS-PXRM/PXRMDLG4.m index 88d050ae..b42aaa1b 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMDLG4.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMDLG4.m @@ -1,284 +1,284 @@ -PXRMDLG4 ; SLC/PJH - Reminder Dialog Edit/Inquiry ;06/05/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; -WP(SUB,SUB1,WIDTH,SEQ,VALMCNT) ;Format WP text - N DIWF,DIWL,DIWR,IC,TEXT,X,TXTCNT,DTXT,CNT,SUB2 - S (CNT,SUB2,TXTCNT)=0 - F S SUB2=$O(^PXRMD(801.41,SUB,SUB1,SUB2)) Q:'SUB2 D - .S TXTCNT=TXTCNT+1,DTXT(TXTCNT)=$G(^PXRMD(801.41,SUB,SUB1,SUB2,0)) - .S DTXT(TXTCNT)=$$STRREP^PXRMUTIL($G(DTXT(TXTCNT)),"
","\\") - I TXTCNT>0 D - .N OUTPUT,NLINES - .S NLINES=0 D FORMAT^PXRMTEXT(1,WIDTH,TXTCNT,.DTXT,.NLINES,.OUTPUT) - .I NLINES>0 K DTXT M DTXT=OUTPUT - S CNT=0 - F S CNT=$O(DTXT(CNT)) Q:CNT="" D - .S TEXT=$G(DTXT(CNT)),VALMCNT=VALMCNT+1 - .S ^TMP(NODE,$J,VALMCNT,0)=SEQ_TEXT,SEQ=$J("",$L(SEQ)) - Q - ; -ADD ;PXRM DIALOG ADD ELEMENT validation - N ANS,DTOUT,DUOUT,LIT,LOCK,Y,PIEN,ERR,IEN,NATIONAL,SEQ - W IORESET - S VALMBCK="R",NATIONAL=0 - I $P($G(^PXRMD(801.41,PXRMDIEN,100)),U)="N" S NATIONAL=1 - S LOCK=$P($G(^PXRMD(801.41,PXRMDIEN,100)),U,4) - I NATIONAL,'($G(PXRMINST)=1)&(DUZ(0)="@"),$G(LOCK)'=1 D Q - .W !,"Elements may not be added to national reminder dialogs" H 2 - ; - F D SEQ(.SEQ,.PIEN) Q:$D(DUOUT)!$D(DTOUT) Q:SEQ - Q:$D(DUOUT)!$D(DTOUT) - ; - ;Check if sequence number is OK - I $G(PIEN)="" Q - S ANS="N" D ASK^PXRMDLG5(.ANS,PIEN) Q:$D(DUOUT)!$D(DTOUT)!($G(ANS)="N") - ; - ;Select a dialog element to add to parent dialog (PIEN) - ;PIEN may be dialog or a group within the dialog - D ESEL^PXRMDEDT(PIEN,SEQ) - ;Rebuild workfile - D BUILD^PXRMDLG(VIEW) - Q - ; -FADD(DIEN,FTAB) ;Additional Findings - N FIND,FSUB,FTYP,FNAME,FNUM - S FSUB=0 - F S FSUB=$O(^PXRMD(801.41,DIEN,3,FSUB)) Q:'FSUB D - .S FIND=$P($G(^PXRMD(801.41,DIEN,3,FSUB,0)),U) Q:FIND="" - .S FNAME="" D FDESC(FIND) Q:FNAME="" - .;Save additional finding name - .S FOUND=1 D FSAVE(2,FNAME,FTYP,FTAB,FIND) - Q - ; -DETAIL(DIEN,LEV,VIEW,NODE) ;;Build listman global for all components - N DDATA,DDLG,DEND,DCIEN,DNAM,DSEQ,DSTRT,IND,JND,DSUB - S DSEQ=0 - ; - ;Get each sequence number - F S DSEQ=$O(^PXRMD(801.41,DIEN,10,"B",DSEQ)) Q:'DSEQ D - .;Determine subscript - .S DSUB=$O(^PXRMD(801.41,DIEN,10,"B",DSEQ,"")) Q:'DSUB - .;Get ien of prompt/component - .S DCIEN=$P($G(^PXRMD(801.41,DIEN,10,DSUB,0)),U,2) Q:'DCIEN - .I "PF"[$P($G(^PXRMD(801.41,DCIEN,0)),U,4) Q - .;Save line in workfile - .D DLINE(DCIEN,LEV,DSEQ,NODE) - .;Build pointers back to parent - .I VIEW'=4 D - ..S ^TMP("PXRMDLG4",$J,"IEN",NSEL)=DIEN_U_DSEQ - ..S ^TMP("PXRMDLG4",$J,"SEQ",LEV_DSEQ)=DCIEN - .;Process any sub-components - .I VIEW<5 D DETAIL(DCIEN,LEV_DSEQ_".",VIEW,NODE) - Q - ; -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 - ;Dialog name - S DDATA=$G(^PXRMD(801.41,DIEN,0)),DNAM=$P(DDATA,U) Q:DNAM="" - ;Check if standard PXRM prompt - I $$PXRM^PXRMEXID(DNAM) Q - ;Dialog Type and Disabled - S DDIS=$P(DDATA,U,3),DTYP=$P(DDATA,U,4) - S DTYP=$S(DTYP="G":"Group",1:"Element"),DNAM=DTYP_": "_DNAM - I VIEW=5 S DNAM=DNAM - ;Resolution type and name - S RNAME="",RIEN=$P($G(^PXRMD(801.41,DIEN,1)),U,3) - I RIEN S RNAME=$P($G(^PXRMD(801.9,RIEN,0)),U) - ; - ;Group fields - I DTYP="Group" D - .S DGRP=1,DTXT=$P(DDATA,U,5),DCAP=" [group caption]" - .I DTXT="" S DCAP="" - .I DTXT]"" S DCAP=DTXT_" "_DCAP - .S DBOX=$S($P(DDATA,U,6)="Y":"BOX",1:"NO BOX") - .S DSUPP=$S($P(DDATA,U,11):"SUPPRESS",1:"NO SUPPRESS") - .S DSHOW=$S($P(DDATA,U,10):"HIDE",1:"SHOW") - .S DMULT=$P(DDATA,U,9) - .S DMULT=$S(DMULT=1:"ONE ONLY",DMULT=2:"ONE OR MORE",DMULT=3:"NONE OR ONE",1:"NO SELECTION") - ; - N DPTX,DTXT,EXIST,ITEM,TEMP,SEP,SEQ,TAB,ALTLEN - S NSEL=NSEL+1,NLINE=NLINE+1,ITEM=NSEL,SEP=$E(LEV,$L(LEV)),SEQ=LEV_DSEQ - ;Suppress Item numbers for INQ options - I VIEW=4 S ITEM="" - ;Otherwise display Item, Sequence and Dialog Name - S TEMP=$J(ITEM,4)_$J("",3)_SEQ,TAB=$L(TEMP)+2 - S CNT=0 F IC=1:1 Q:'$P(SEQ,".",IC) S:$P(SEQ,".",IC)<10 CNT=CNT+1 - S TAB=TAB+CNT - ; - S ALTLEN=$L(TEMP) - ;Display dialog name - S TEMP=TEMP_$J("",2+CNT)_DNAM - ;Add disabled if present - I DDIS]"" S TEMP=TEMP_" (Disabled)" - ; - S ^TMP(NODE,$J,NLINE,0)=TEMP - ;check for alternate dialog element/group - I VIEW<2!(VIEW>4) D - .I $D(^PXRMD(801.41,DIEN,49))>0 D ALT^PXRMDLG5(DIEN,LEV,DSEQ,NODE,VIEW,.NLINE,CNT,ALTLEN) - ; - ;Dialog Text or P/N Text - I (VIEW=2)!(VIEW=3)!(VIEW=4) D - .N DGBEG,DGSUB,TSUB - .S DGSUB=0,TSUB=$$TSUB^PXRMDLG1(DIEN,VIEW) - .I VIEW=4 S DGBEG=$J("",TAB)_"Text: " - .I VIEW'=4 S DGBEG=$J("",5+$L(SEQ)+CNT+$L(DTYP))_"Text: " - .D WP(DIEN,TSUB,65,.DGBEG,.NLINE) - .I DTYP="Group" D - ..S TEMP=DGBEG_"["_DBOX_", "_DSUPP_", "_DSHOW_", "_DMULT_"]" - ..S NLINE=NLINE+1,^TMP(NODE,$J,NLINE,0)=TEMP - ; - ;Set up selection index - S ^TMP(NODE,$J,"IDX",NSEL,DIEN)="" - ;Insert finding items - I (VIEW=1)!(VIEW=4),("Element;Group"[DTYP) D - .N DSUB,FDATA,FILENUM,FLIT,FLONG,FNAME,FOUND,FREP,FTYP,TEMP - .;Findings - .S FNAME="",FOUND=0 - .D FDESC($P($G(^PXRMD(801.41,DIEN,1)),U,5)) - .I FNAME'="" S FOUND=1 D FSAVE(1,FNAME,FTYP,TAB) - .;Resolution - .I RNAME]"" D - ..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) - ;Get additional prompts - I VIEW=2 D - .S FIEN=$P($G(^PXRMD(801.41,DIEN,1)),U,5) - .I $G(FIEN)["PXD(811.2," D TAX^PXRMDLG1(FIEN,DSEQ,DIEN,.NLINE,NODE) - .I $G(FIEN)["ICPT"!($G(FIEN)["ICD9") D FIND^PXRMDLG1(FIEN,DSEQ,DIEN,.NLINE,NODE) - .D FADD(DIEN,TAB) - I VIEW,VIEW<5,"Element;Group"[DTYP D PROMPT(DIEN,TAB,"Prompts: ",VIEW) - ; - I VIEW=4,$D(^PXRMD(801.41,DIEN,49))>0 D ALT^PXRMDLG5(DIEN,LEV,DSEQ,NODE,VIEW,.NLINE,CNT,ALTLEN) - S NLINE=NLINE+1 - S ^TMP(NODE,$J,NLINE,0)=$J("",79) - Q - ; -FDESC(FIEN) ;Finding description - N FGLOB,FITEM,FNUM - S FGLOB=$P(FIEN,";",2) Q:FGLOB="" - S FITEM=$P(FIEN,";") Q:FITEM="" - S FNUM=" ["_FITEM_"]" - I FGLOB["ICD9" D Q - .S FTYP="DIAGNOSIS",FGLOB=U_FGLOB_FITEM_",0)" - .S FNAME=$P($G(@FGLOB),U,3)_FNUM - I FGLOB["WV" D Q - .S FTYP="WH NOTIFICATION PURPOSE",FGLOB=U_FGLOB_FITEM_",0)" - .S FNAME=$P($G(@FGLOB),U)_FNUM - I FGLOB["ICPT" D Q - .S FTYP="PROCEDURE",FGLOB=U_FGLOB_FITEM_",0)" - .S FNAME=$P($G(@FGLOB),U,2)_FNUM - I FGLOB["ORD(101.41" D Q - .S FTYP="QUICK ORDER",FGLOB=U_FGLOB_FITEM_",0)" - .S FNAME=$P($G(@FGLOB),U,2)_FNUM - ;Short name for finding type - S FTYP=$G(DEF1(FGLOB)) Q:FTYP="" - ;Long name - S FTYP=$G(DEF2(FTYP)) - S FGLOB=U_FGLOB_FITEM_",0)" - S FNAME=$P($G(@FGLOB),U,1)_FNUM - I FNAME="" S FNAME=$P($G(@FGLOB),U)_FNUM - I FNAME="" S FNAME=FITEM - Q - ; -FSAVE(DSUB,FNAME,FTYP,FTAB,FIEN) ;Save finding details - N TEMP - I DSUB=1 S FLIT="Finding: " - I DSUB>1 S FLIT="Add. Finding: " - S FLONG=0 - ;change code to use IOM instead of default length of 60 - I $L(FLIT_FNAME_" ("_FTYP_")")>(IOM-20) S FLONG=1 - I 'FLONG S FNAME=FLIT_FNAME_" ("_FTYP_")" - I FLONG S FNAME=FLIT_FNAME - S TEMP=$J("",FTAB)_$E(FNAME,1,(IOM-20))_$J("",60-$L(FNAME)) - S NLINE=NLINE+1 - S ^TMP(NODE,$J,NLINE,0)=TEMP - I FLONG S NLINE=NLINE+1,^TMP(NODE,$J,NLINE,0)=$J("",FTAB)_"("_FTYP_")" - I VIEW=2 D - .I $G(FIEN)["ICPT"!($G(FIEN)["ICD9") D FIND^PXRMDLG1(FIEN,DSEQ,DIEN,.NLINE,NODE) - Q - ; -PROMPT(IEN,TAB,TEXT,VIEW) ;additional prompts in the dialog file - N DATA,DDIS,DGSEQ,DSUB,DTITLE,DTXT,DTYP,SEQ,SUB - S SEQ=0 - F S SEQ=$O(^PXRMD(801.41,IEN,10,"B",SEQ)) Q:'SEQ D - .S SUB=$O(^PXRMD(801.41,IEN,10,"B",SEQ,"")) Q:'SUB - .S DSUB=$P($G(^PXRMD(801.41,IEN,10,SUB,0)),U,2) Q:'DSUB - .S DATA=$G(^PXRMD(801.41,DSUB,0)) Q:DATA="" - .S DNAME=$P(DATA,U),DDIS=$P(DATA,U,3),DTYP=$P(DATA,U,4) - .I "PF"'[DTYP Q - .I DTYP="F" S DNAME=DNAME_" (forced value)" - .I DTYP="P",(VIEW=2)!(VIEW=3) D - ..;Override prompt caption - ..S DTITLE=$P($G(^PXRMD(801.41,IEN,10,SUB,0)),U,6) - ..I DTITLE="" S DTITLE=$P($G(^PXRMD(801.41,DSUB,2)),U,4) - ..S DNAME=DTITLE - .S DNAME=$J("",TAB)_TEXT_DNAME - .S:DDIS]"" DNAME=DNAME_" (Disabled)" - .S NLINE=NLINE+1 - .S ^TMP(NODE,$J,NLINE,0)=DNAME - .S TEXT=$J("",$L(TEXT)) - Q - ; -SEQ(SEQ,PIEN) ;Select sequence number to add - N X,Y,TEXT,DIR - K DIROUT,DIRUT,DTOUT,DUOUT - S SEQ=0 - S DIR(0)="FA0;1;30" - S DIR("A")="Enter a new SEQUENCE NUMBER: " - S DIR("?")="Enter new sequence number. For detailed help type ??" - S DIR("??")=U_"D HELP^PXRMDLG4(1)" - D ^DIR K DIR - I $D(DIROUT) S DTOUT=1 - I $D(DTOUT)!($D(DUOUT)) Q - ; - ;Check that sequence number is new - I $D(^TMP("PXRMDLG4",$J,"SEQ",X)) D Q - .W !,"Sequence number "_X_" already in use." - ; - ;Then check that the parent is a group or reminder dialog - I X["." D Q:X="" - .N CLASS,SUB - .;Sequence number of parent - .S SUB=$P(X,".",1,$L(X,".")-1) - .I $G(SUB)=""!($G(SUB)=0) W !,"Invalid sequence number. A sequence number cannot be less then 1" H 2 Q - .;Get IEN of parent dialog or group - .S PIEN=$G(^TMP("PXRMDLG4",$J,"SEQ",SUB)) - .;Validate sequence number - .I 'PIEN W !,"Sequence number is not part of an existing group." S X="" Q - .;Validate that the parent is a group or reminder dialog - .I "RG"'[$P($G(^PXRMD(801.41,PIEN,0)),U,4) D S X="" Q - ..W !,"New sequences can only be added to groups or reminder dialogs" - .;Disallow adding elements to national dialogs or groups - .I $P($G(^PXMRD(801.41,PIEN,100)),U)="N" D Q:X="" - ..Q:(DUZ(0)="@")&($G(PXRMINST)=1) - ..W !,"Elements cannot be added to a national group" S X="" - ; - ;If adding to top level parent ien is reminder dialog - I X?.N S PIEN=PXRMDIEN - ; - S SEQ=$P(X,".",$L(X,".")) - Q - ; - ; -HELP(CALL) ;General help text routine. - N HTEXT - N DIWF,DIWL,DIWR,IC - S DIWF="C75",DIWL=0,DIWR=75 - ; - I CALL=1 D - .S HTEXT(1)="Sequence numbers can be added at any level. Specify the full" - .S HTEXT(2)="number for the level required (e.g. 15.10.20)." - ; - D HELP^PXRMEUT(.HTEXT) - Q - ; +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 + N DIWF,DIWL,DIWR,IC,TEXT,X,TXTCNT,DTXT,CNT,SUB2 + S (CNT,SUB2,TXTCNT)=0 + F S SUB2=$O(^PXRMD(801.41,SUB,SUB1,SUB2)) Q:'SUB2 D + .S TXTCNT=TXTCNT+1,DTXT(TXTCNT)=$G(^PXRMD(801.41,SUB,SUB1,SUB2,0)) + .S DTXT(TXTCNT)=$$STRREP^PXRMUTIL($G(DTXT(TXTCNT)),"
","\\") + I TXTCNT>0 D + .N OUTPUT,NLINES + .S NLINES=0 D FORMAT^PXRMTEXT(1,WIDTH,TXTCNT,.DTXT,.NLINES,.OUTPUT) + .I NLINES>0 K DTXT M DTXT=OUTPUT + S CNT=0 + F S CNT=$O(DTXT(CNT)) Q:CNT="" D + .S TEXT=$G(DTXT(CNT)),VALMCNT=VALMCNT+1 + .S ^TMP(NODE,$J,VALMCNT,0)=SEQ_TEXT,SEQ=$J("",$L(SEQ)) + Q + ; +ADD ;PXRM DIALOG ADD ELEMENT validation + N ANS,DTOUT,DUOUT,LIT,LOCK,Y,PIEN,ERR,IEN,NATIONAL,SEQ + 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 + ; + F D SEQ(.SEQ,.PIEN) Q:$D(DUOUT)!$D(DTOUT) Q:SEQ + Q:$D(DUOUT)!$D(DTOUT) + ; + ;Check if sequence number is OK + I $G(PIEN)="" Q + S ANS="N" D ASK^PXRMDLG5(.ANS,PIEN) Q:$D(DUOUT)!$D(DTOUT)!($G(ANS)="N") + ; + ;Select a dialog element to add to parent dialog (PIEN) + ;PIEN may be dialog or a group within the dialog + D ESEL^PXRMDEDT(PIEN,SEQ) + ;Rebuild workfile + D BUILD^PXRMDLG(VIEW) + Q + ; +FADD(DIEN,FTAB) ;Additional Findings + N FIND,FSUB,FTYP,FNAME,FNUM + S FSUB=0 + F S FSUB=$O(^PXRMD(801.41,DIEN,3,FSUB)) Q:'FSUB D + .S FIND=$P($G(^PXRMD(801.41,DIEN,3,FSUB,0)),U) Q:FIND="" + .S FNAME="" D FDESC(FIND) Q:FNAME="" + .;Save additional finding name + .S FOUND=1 D FSAVE(2,FNAME,FTYP,FTAB,FIND) + Q + ; +DETAIL(DIEN,LEV,VIEW,NODE) ;;Build listman global for all components + N DDATA,DDLG,DEND,DCIEN,DNAM,DSEQ,DSTRT,IND,JND,DSUB + S DSEQ=0 + ; + ;Get each sequence number + F S DSEQ=$O(^PXRMD(801.41,DIEN,10,"B",DSEQ)) Q:'DSEQ D + .;Determine subscript + .S DSUB=$O(^PXRMD(801.41,DIEN,10,"B",DSEQ,"")) Q:'DSUB + .;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 + .D DLINE(DCIEN,LEV,DSEQ,NODE) + .;Build pointers back to parent + .I VIEW'=4 D + ..S ^TMP("PXRMDLG4",$J,"IEN",NSEL)=DIEN_U_DSEQ + ..S ^TMP("PXRMDLG4",$J,"SEQ",LEV_DSEQ)=DCIEN + .;Process any sub-components + .I VIEW<5 D DETAIL(DCIEN,LEV_DSEQ_".",VIEW,NODE) + Q + ; +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 + ;Dialog name + S DDATA=$G(^PXRMD(801.41,DIEN,0)),DNAM=$P(DDATA,U) Q:DNAM="" + ;Check if standard PXRM prompt + I $$PXRM^PXRMEXID(DNAM) Q + ;Dialog Type and Disabled + S DDIS=$P(DDATA,U,3),DTYP=$P(DDATA,U,4) + S DTYP=$S(DTYP="G":"Group",1:"Element"),DNAM=DTYP_": "_DNAM + I VIEW=5 S DNAM=DNAM + ;Resolution type and name + 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 + I DTYP="Group" D + .S DGRP=1,DTXT=$P(DDATA,U,5),DCAP=" [group caption]" + .I DTXT="" S DCAP="" + .I DTXT]"" S DCAP=DTXT_" "_DCAP + .S DBOX=$S($P(DDATA,U,6)="Y":"BOX",1:"NO BOX") + .S DSUPP=$S($P(DDATA,U,11):"SUPPRESS",1:"NO SUPPRESS") + .S DSHOW=$S($P(DDATA,U,10):"HIDE",1:"SHOW") + .S DMULT=$P(DDATA,U,9) + .S DMULT=$S(DMULT=1:"ONE ONLY",DMULT=2:"ONE OR MORE",DMULT=3:"NONE OR ONE",1:"NO SELECTION") + ; + N DPTX,DTXT,EXIST,ITEM,TEMP,SEP,SEQ,TAB,ALTLEN + S NSEL=NSEL+1,NLINE=NLINE+1,ITEM=NSEL,SEP=$E(LEV,$L(LEV)),SEQ=LEV_DSEQ + ;Suppress Item numbers for INQ options + I VIEW=4 S ITEM="" + ;Otherwise display Item, Sequence and Dialog Name + S TEMP=$J(ITEM,4)_$J("",3)_SEQ,TAB=$L(TEMP)+2 + S CNT=0 F IC=1:1 Q:'$P(SEQ,".",IC) S:$P(SEQ,".",IC)<10 CNT=CNT+1 + S TAB=TAB+CNT + ; + S ALTLEN=$L(TEMP) + ;Display dialog name + S TEMP=TEMP_$J("",2+CNT)_DNAM + ;Add disabled if present + I DDIS]"" S TEMP=TEMP_" (Disabled)" + ; + S ^TMP(NODE,$J,NLINE,0)=TEMP + ;check for alternate dialog element/group + I VIEW<2!(VIEW>4) D + .I $D(^PXRMD(801.41,DIEN,49))>0 D ALT^PXRMDLG5(DIEN,LEV,DSEQ,NODE,VIEW,.NLINE,CNT,ALTLEN) + ; + ;Dialog Text or P/N Text + I (VIEW=2)!(VIEW=3)!(VIEW=4) D + .N DGBEG,DGSUB,TSUB + .S DGSUB=0,TSUB=$$TSUB^PXRMDLG1(DIEN,VIEW) + .I VIEW=4 S DGBEG=$J("",TAB)_"Text: " + .I VIEW'=4 S DGBEG=$J("",5+$L(SEQ)+CNT+$L(DTYP))_"Text: " + .D WP(DIEN,TSUB,65,.DGBEG,.NLINE) + .I DTYP="Group" D + ..S TEMP=DGBEG_"["_DBOX_", "_DSUPP_", "_DSHOW_", "_DMULT_"]" + ..S NLINE=NLINE+1,^TMP(NODE,$J,NLINE,0)=TEMP + ; + ;Set up selection index + S ^TMP(NODE,$J,"IDX",NSEL,DIEN)="" + ;Insert finding items + I (VIEW=1)!(VIEW=4),("Element;Group"[DTYP) D + .N DSUB,FDATA,FILENUM,FLIT,FLONG,FNAME,FOUND,FREP,FTYP,TEMP + .;Findings + .S FNAME="",FOUND=0 + .D FDESC($P($G(^PXRMD(801.41,DIEN,1)),U,5)) + .I FNAME'="" S FOUND=1 D FSAVE(1,FNAME,FTYP,TAB) + .;Resolution + .I RNAME]"" D + ..S TEMP=$J("",TAB)_"Resolution: "_RNAME + ..S NLINE=NLINE+1,^TMP(NODE,$J,NLINE,0)=TEMP + .;Additional findings + .D FADD(DIEN,TAB) + ;Get additional prompts + I VIEW=2 D + .S FIEN=$P($G(^PXRMD(801.41,DIEN,1)),U,5) + .I $G(FIEN)["PXD(811.2," D TAX^PXRMDLG1(FIEN,DSEQ,DIEN,.NLINE,NODE) + .I $G(FIEN)["ICPT"!($G(FIEN)["ICD9") D FIND^PXRMDLG1(FIEN,DSEQ,DIEN,.NLINE,NODE) + .D FADD(DIEN,TAB) + I VIEW,VIEW<5,"Element;Group"[DTYP D PROMPT(DIEN,TAB,"Prompts: ",VIEW) + ; + I VIEW=4,$D(^PXRMD(801.41,DIEN,49))>0 D ALT^PXRMDLG5(DIEN,LEV,DSEQ,NODE,VIEW,.NLINE,CNT,ALTLEN) + S NLINE=NLINE+1 + S ^TMP(NODE,$J,NLINE,0)=$J("",79) + Q + ; +FDESC(FIEN) ;Finding description + N FGLOB,FITEM,FNUM + ;Determine finding type + S FGLOB=$P(FIEN,";",2) Q:FGLOB="" + S FITEM=$P(FIEN,";") Q:FITEM="" + S FNUM=" ["_FITEM_"]" + I FGLOB["ICD9" D Q + .S FTYP="DIAGNOSIS",FGLOB=U_FGLOB_FITEM_",0)" + .S FNAME=$P($G(@FGLOB),U,3)_FNUM + I FGLOB["WV" D Q + .S FTYP="WH NOTIFICATION PURPOSE",FGLOB=U_FGLOB_FITEM_",0)" + .S FNAME=$P($G(@FGLOB),U)_FNUM + I FGLOB["ICPT" D Q + .S FTYP="PROCEDURE",FGLOB=U_FGLOB_FITEM_",0)" + .S FNAME=$P($G(@FGLOB),U,2)_FNUM + I FGLOB["ORD(101.41" D Q + .S FTYP="QUICK ORDER",FGLOB=U_FGLOB_FITEM_",0)" + .S FNAME=$P($G(@FGLOB),U,2)_FNUM + ;Short name for finding type + S FTYP=$G(DEF1(FGLOB)) Q:FTYP="" + ;Long name + S FTYP=$G(DEF2(FTYP)) + S FGLOB=U_FGLOB_FITEM_",0)" + S FNAME=$P($G(@FGLOB),U,1)_FNUM + I FNAME="" S FNAME=$P($G(@FGLOB),U)_FNUM + I FNAME="" S FNAME=FITEM + Q + ; +FSAVE(DSUB,FNAME,FTYP,FTAB,FIEN) ;Save finding details + N TEMP + I DSUB=1 S FLIT="Finding: " + I DSUB>1 S FLIT="Add. Finding: " + S FLONG=0 + ;change code to use IOM instead of default length of 60 + I $L(FLIT_FNAME_" ("_FTYP_")")>(IOM-20) S FLONG=1 + I 'FLONG S FNAME=FLIT_FNAME_" ("_FTYP_")" + I FLONG S FNAME=FLIT_FNAME + S TEMP=$J("",FTAB)_$E(FNAME,1,(IOM-20))_$J("",60-$L(FNAME)) + S NLINE=NLINE+1 + S ^TMP(NODE,$J,NLINE,0)=TEMP + I FLONG S NLINE=NLINE+1,^TMP(NODE,$J,NLINE,0)=$J("",FTAB)_"("_FTYP_")" + I VIEW=2 D + .I $G(FIEN)["ICPT"!($G(FIEN)["ICD9") D FIND^PXRMDLG1(FIEN,DSEQ,DIEN,.NLINE,NODE) + Q + ; +PROMPT(IEN,TAB,TEXT,VIEW) ;additional prompts in the dialog file + N DATA,DDIS,DGSEQ,DSUB,DTITLE,DTXT,DTYP,SEQ,SUB + S SEQ=0 + F S SEQ=$O(^PXRMD(801.41,IEN,10,"B",SEQ)) Q:'SEQ D + .S SUB=$O(^PXRMD(801.41,IEN,10,"B",SEQ,"")) Q:'SUB + .S DSUB=$P($G(^PXRMD(801.41,IEN,10,SUB,0)),U,2) Q:'DSUB + .S DATA=$G(^PXRMD(801.41,DSUB,0)) Q:DATA="" + .S DNAME=$P(DATA,U),DDIS=$P(DATA,U,3),DTYP=$P(DATA,U,4) + .I "PF"'[DTYP Q + .I DTYP="F" S DNAME=DNAME_" (forced value)" + .I DTYP="P",(VIEW=2)!(VIEW=3) D + ..;Override prompt caption + ..S DTITLE=$P($G(^PXRMD(801.41,IEN,10,SUB,0)),U,6) + ..I DTITLE="" S DTITLE=$P($G(^PXRMD(801.41,DSUB,2)),U,4) + ..S DNAME=DTITLE + .S DNAME=$J("",TAB)_TEXT_DNAME + .S:DDIS]"" DNAME=DNAME_" (Disabled)" + .S NLINE=NLINE+1 + .S ^TMP(NODE,$J,NLINE,0)=DNAME + .S TEXT=$J("",$L(TEXT)) + Q + ; +SEQ(SEQ,PIEN) ;Select sequence number to add + N X,Y,TEXT,DIR + K DIROUT,DIRUT,DTOUT,DUOUT + S SEQ=0 + S DIR(0)="FA0;1;30" + S DIR("A")="Enter a new SEQUENCE NUMBER: " + S DIR("?")="Enter new sequence number. For detailed help type ??" + S DIR("??")=U_"D HELP^PXRMDLG4(1)" + D ^DIR K DIR + I $D(DIROUT) S DTOUT=1 + I $D(DTOUT)!($D(DUOUT)) Q + ; + ;Check that sequence number is new + I $D(^TMP("PXRMDLG4",$J,"SEQ",X)) D Q + .W !,"Sequence number "_X_" already in use." + ; + ;Then check that the parent is a group or reminder dialog + I X["." D Q:X="" + .N CLASS,SUB + .;Sequence number of parent + .S SUB=$P(X,".",1,$L(X,".")-1) + .I $G(SUB)=""!($G(SUB)=0) W !,"Invalid sequence number. A sequence number cannot be less then 1" H 2 Q + .;Get IEN of parent dialog or group + .S PIEN=$G(^TMP("PXRMDLG4",$J,"SEQ",SUB)) + .;Validate sequence number + .I 'PIEN W !,"Sequence number is not part of an existing group." S X="" Q + .;Validate that the parent is a group or reminder dialog + .I "RG"'[$P($G(^PXRMD(801.41,PIEN,0)),U,4) D S X="" Q + ..W !,"New sequences can only be added to groups or reminder dialogs" + .;Disallow adding elements to national dialogs or groups + .I $P($G(^PXMRD(801.41,PIEN,100)),U)="N" D Q:X="" + ..Q:(DUZ(0)="@")&($G(PXRMINST)=1) + ..W !,"Elements cannot be added to a national group" S X="" + ; + ;If adding to top level parent ien is reminder dialog + I X?.N S PIEN=PXRMDIEN + ; + S SEQ=$P(X,".",$L(X,".")) + Q + ; + ; +HELP(CALL) ;General help text routine. + N HTEXT + N DIWF,DIWL,DIWR,IC + S DIWF="C75",DIWL=0,DIWR=75 + ; + I CALL=1 D + .S HTEXT(1)="Sequence numbers can be added at any level. Specify the full" + .S HTEXT(2)="number for the level required (e.g. 15.10.20)." + ; + D HELP^PXRMEUT(.HTEXT) + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMDLG5.m b/r/CLINICAL_REMINDERS-PXRM/PXRMDLG5.m index 1d5de392..02532de6 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMDLG5.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMDLG5.m @@ -1,222 +1,120 @@ -PXRMDLG5 ; SLC/PJH - Reminder Dialog Edit/Inquiry ;11/08/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; -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 - K DIR,DIROUT,DIRUT,DNAME,DTOUT,DTYP,DUOUT,TEXT,X,Y - N DDATA,DNAME,DTYP - S DDATA=$G(^PXRMD(801.41,PIEN,0)) - ;Parent name and type - S DNAME=$P(DDATA,U),DTYP=$P(DDATA,U,4) - ; - S DIR(0)="YA0" - S DIR("A")="Add sequence "_SEQ_" to " - I DTYP="G" S DIR("A")=DIR("A")_"group "_DNAME_": " - E S DIR("A")=DIR("A")_"reminder dialog ?: " - S DIR("B")="N",DIR("?")="Enter Y or N. For detailed help type ??" - S DIR("??")=U_"D XHLP^PXRMDLG(1)" - D ^DIR K DIR - I $D(DIROUT) S DTOUT=1 - I $D(DTOUT)!($D(DUOUT)) Q - S YESNO=$E(Y(0)) I YESNO'="Y" S DUOUT=1 - S VALMBCK="R" - Q - ; -BHELP(VALUE) ; - N HTEXT - D FULL^VALM1 - ;Help text for Reminder Dialog Branching logic - I VALUE=1 D - .;Reminder Term field - .S HTEXT(1)="Enter a reminder term that will be used to determine if the reminder" - .S HTEXT(2)="element/group should be replaced or suppressed if the reminder term evaluation" - .S HTEXT(3)="matches the value in the Reminder Term Status field." - I VALUE=2 D - .;Reminder Term Status field - .S HTEXT(1)="Enter either 1 for true or 0 for false. This value will be used with the" - .S HTEXT(2)="reminder term field to determine if this item should be replaced with a" - .S HTEXT(3)="different element/group defined in the Replacement Element/Group field, or if" - .S HTEXT(4)="this item should be suppressed." - I VALUE=3 D - .;Replacement Element/Group field - .S HTEXT(1)="Enter an element/group that will be used as a replacement to thisitem, or" - .S HTEXT(2)="leave this field blank to suppress this item if the term evaluation" - .S HTEXT(3)="matches the value defined in the term status field. " - 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(2)="if item in this dialog will be using reminder term to either replace an item" - .S HTEXT(3)="or to suppress an item." - D HELP^PXRMEUT(.HTEXT) - Q - ; -INQ(DIEN) ;INQ Inquiry/Print option - ; Used by 801.41 print templates - ; [PXRM REMINDER DIALOG] - ; [PXRM DIALOG GROUP] - ; - N DEF,DEF1,DEF2 D DEF^PXRMRUTL("811.902",.DEF,.DEF1,.DEF2) - N NLINE,NODE,NSEL,SUB - S NLINE=0,NODE="PXRMDLG4",NSEL=0 - K ^TMP(NODE,$J) - ; - ;Components - W !!," Seq. Dialog",! - D DETAIL^PXRMDLG4(DIEN,"",4,NODE) - ; - ;Print lines from workfile - S SUB="" - F S SUB=$O(^TMP(NODE,$J,SUB)) Q:'SUB W !,^TMP(NODE,$J,SUB,0) - 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 - ; +PXRMDLG5 ; SLC/PJH - Reminder Dialog Edit/Inquiry ;05/17/2006 + ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21 + ; + ; +ASK(YESNO,PIEN) ;Confirm + K DIR,DIROUT,DIRUT,DNAME,DTOUT,DTYP,DUOUT,TEXT,X,Y + N DDATA,DNAME,DTYP + S DDATA=$G(^PXRMD(801.41,PIEN,0)) + ;Parent name and type + S DNAME=$P(DDATA,U),DTYP=$P(DDATA,U,4) + ; + S DIR(0)="YA0" + S DIR("A")="Add sequence "_SEQ_" to " + I DTYP="G" S DIR("A")=DIR("A")_"group "_DNAME_": " + E S DIR("A")=DIR("A")_"reminder dialog ?: " + S DIR("B")="N",DIR("?")="Enter Y or N. For detailed help type ??" + S DIR("??")=U_"D XHLP^PXRMDLG(1)" + D ^DIR K DIR + I $D(DIROUT) S DTOUT=1 + I $D(DTOUT)!($D(DUOUT)) Q + S YESNO=$E(Y(0)) I YESNO'="Y" S DUOUT=1 + 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) ; + N HTEXT + D FULL^VALM1 + ;Help text for Reminder Dialog Branching logic + I VALUE=1 D + .;Reminder Term field + .S HTEXT(1)="Enter a reminder term that will be used to determine if the reminder" + .S HTEXT(2)="element/group should be replaced or suppressed if the reminder term evaluation" + .S HTEXT(3)="matches the value in the Reminder Term Status field." + I VALUE=2 D + .;Reminder Term Status field + .S HTEXT(1)="Enter either 1 for true or 0 for false. This value will be used with the" + .S HTEXT(2)="reminder term field to determine if this item should be replaced with a" + .S HTEXT(3)="different element/group defined in the Replacement Element/Group field, or if" + .S HTEXT(4)="this item should be suppressed." + I VALUE=3 D + .;Replacement Element/Group field + .S HTEXT(1)="Enter an element/group that will be used as a replacement to thisitem, or" + .S HTEXT(2)="leave this field blank to suppress this item if the term evaluation" + .S HTEXT(3)="matches the value defined in the term status field. " + I VALUE=4 D + .;Patient Specific field + .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." + D HELP^PXRMEUT(.HTEXT) + 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] + ; [PXRM DIALOG GROUP] + ; + N DEF,DEF1,DEF2 D DEF^PXRMRUTL("811.902",.DEF,.DEF1,.DEF2) + N NLINE,NODE,NSEL,SUB + S NLINE=0,NODE="PXRMDLG4",NSEL=0 + K ^TMP(NODE,$J) + ; + ;Components + W !!," Seq. Dialog",! + D DETAIL^PXRMDLG4(DIEN,"",4,NODE) + ; + ;Print lines from workfile + S SUB="" + F S SUB=$O(^TMP(NODE,$J,SUB)) Q:'SUB W !,^TMP(NODE,$J,SUB,0) + K ^TMP(NODE,$J) + Q diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMDLGZ.m b/r/CLINICAL_REMINDERS-PXRM/PXRMDLGZ.m index 88a98aa7..d023cec0 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMDLGZ.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMDLGZ.m @@ -1,234 +1,238 @@ -PXRMDLGZ ; SLC/PJH - Link reminder to dialog. ;01/11/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ;Called by option PXRM DIALOG/COMPONENT EDIT - ; -START N BY,DATA,DDES,DHD,DIC,DNAM,DTYP,FLDS,FR,L,LOGIC,NOW,PNAM,TO,Y - N PXRMBG,PXRMHD,PXRMDIEN,PXRMGTYP,PXRMDTYP,PXRMITEM,PXRMMODE,PXRMNAME - N PXRMTEMP,PXRMTITL,PXRMVIEW - ;Refresh on return - S VALMBCK="R" - S VALMSG="+ Next Screen - Prev Screen ?? More Actions" - ;Default is display dialog elements - S PXRMDTYP="R",PXRMGTYP="DLGR",PXRMVIEW="AN" - ;Select dialog for display - F D Q:'PXRMTEMP - .S PXRMTEMP="" - .D START^PXRMSEL(.PXRMHD,.PXRMGTYP,"PXRMTEMP") Q:'PXRMTEMP - .N X S X="IORESET" - .D ENDR^%ZISS,@(PXRMGTYP_"("_PXRMTEMP_")") -END Q - ; - ;Reminder View - ;------------- -DLGR(PXRMITEM) ; - N PXRMDIEN,PXRMCS1,PXRMCS2 - ;Format headings to include reminder and name - S DATA=$G(^PXD(811.9,PXRMITEM,0)),RNAM=$P(DATA,U),PNAM=$P(DATA,U,3) - S PXRMHD="REMINDER NAME: "_RNAM - ; - ;Dialog History - F D Q:'PXRMDIEN - .D START^PXRMDLGH(PXRMITEM,.PXRMDIEN,"PXRMDIEN") Q:'PXRMDIEN - .N PXRMHD,VALMBCK,VALMBG,VALMSG,VIEW,X,XMZ - .S DNAM=$P($G(^PXRMD(801.41,PXRMDIEN,0)),U) - .I $P($G(^PXRMD(801.41,PXRMDIEN,0)),U,3)]"" S DNAM=DNAM_" (DISABLED)" - .S PXRMHD="REMINDER DIALOG NAME: "_DNAM - .S PXRMCS1=$$FILE^PXRMEXCS(801.41,PXRMDIEN) - .S X="IORESET" - .D ENDR^%ZISS,EN^VALM("PXRM DIALOG LIST") - .I PXRMDIEN,$D(^PXRMD(801.41,PXRMDIEN,0)) D - ..S PXRMCS2=$$FILE^PXRMEXCS(801.41,PXRMDIEN) Q:+PXRMCS2=0 - ..Q:PXRMCS1=PXRMCS2 - ..D SEHIST^PXRMUTIL(801.41,"^PXRMD(801,41,",PXRMDIEN) - .W IORESET - .D KILL^%ZISS - Q - ; - ;Edit element/prompt/group - ;------------------------- -DLGE(PXRMDIEN) ; - N LOCK,LFIND - ;Check for Uneditable flag - S LOCK=$P($G(^PXRMD(801.41,PXRMTEMP,100)),U,4) - S LFIND=$P($G(^PXRMD(801.41,PXRMTEMP,1)),U,5) - I LOCK=1,$G(LFIND)'="",$G(LFIND)'["ORD",'$G(PXRMINST) D Q - .W !,"This item can not be edited" H 2 - ; - S PXRMHD="Dialog Name: ",PXRMDIEN=PXRMTEMP - ;Format headings to include dialog name - S DATA=$G(^PXRMD(801.41,PXRMDIEN,0)),DDES=$P(DATA,U),DTYP=$P(DATA,U,4) - ;Test - I DTYP="G" D DLG(PXRMDIEN) Q - ; - S PXRMHD=PXRMHD_" "_DDES W PXRMHD,! - ;Edit selected dialog - D EDIT^PXRMDEDT(DTYP,PXRMDIEN,0) - Q - ; - ;Reminder dialog view - ;-------------------- -DLG(PXRMDIEN) ; - S PXRMDIEN=PXRMTEMP - S PXRMNAME=$P($G(^PXRMD(801.41,PXRMDIEN,0)),U) - S PXRMITEM=$P($G(^PXRMD(801.41,PXRMDIEN,0)),U,2) - ;Format headings to include dialog name - S PXRMHD=PXRMHD_PXRMNAME - ;Check if the set is disable and add to header if disabled - I $P(^PXRMD(801.41,PXRMDIEN,0),U,3)]"" S PXRMHD=PXRMHD_" (DISABLED)" - ;Listman option - D EN^VALM("PXRM DIALOG LIST") - W IORESET - D KILL^%ZISS - Q - ; - ;Other subroutines - ; - ;Ask update or no - ;---------------- -ASK(YESNO) ; - N X,Y,TEXT,DIR - K DIROUT,DIRUT,DTOUT,DUOUT - S DIR(0)="YA0" - S DIR("A")="LINK THIS REMINDER TO DIALOG - "_$P(PXRMHD,": ",2)_": " - S DIR("B")="Y" - S DIR("?")="Enter Y or N. For detailed help type ??" - S DIR("??")=U_"D HLP^PXRMDLGY(1)" - D ^DIR K DIR - I $D(DIROUT) S DTOUT=1 - I $D(DTOUT)!($D(DUOUT)) Q - S YESNO=$E(Y(0)) - Q - ; - ;Display dialogs autogenerated from this reminder - ;------------------------------------------------ -DISP(RIEN) ; - N ARRAY,DSUB,FIRST - ;Get OTHER dialogs - S FIRST=1,DSUB="" - F S DSUB=$O(^PXRMD(801.41,"AG",RIEN,DSUB)) Q:'DSUB D - .W ! - .D:FIRST - ..W "DIALOGS ALREADY GENERATED FROM THIS REMINDER:",!! S FIRST=0 - .W ?20,$P($G(^PXRMD(801.41,DSUB,0)),U) - ; - I 'FIRST W ! - ; - Q - ; - ;Display linked reminders - ;------------------------ -DISPL(DIEN) ; - N ARRAY,DLG,RSUB,FIRST,RNAM - S RSUB=$P($G(^PXRMD(801.41,DIEN,0)),U,2) - I RSUB W !!,"SOURCE REMINDER: "_$P($G(^PXD(811.9,RSUB,0)),U) - ;Linked reminders - S FIRST=1,RNAM="" - F S RNAM=$O(^PXD(811.9,"B",RNAM)) Q:RNAM="" D - .S RSUB=$O(^PXD(811.9,"B",RNAM,"")) Q:'RSUB - .S DLG=$P($G(^PXD(811.9,RSUB,51)),U) Q:DLG'=DIEN - .W ! I FIRST W !,"REMINDERS ALREADY LINKED TO THIS DIALOG:",!! S FIRST=0 - .W ?18,$P($G(^PXD(811.9,RSUB,0)),U) - Q - ; - ;Link a dialog (called by protocol PXRM DIALOG/REMINDER LINK) - ;------------- -LINK(DIEN) ; - F D Q:$D(DTOUT)!$D(DUOUT) - .W IORESET - .S VALMBCK="R" - .;Display linked reminders - .D DISPL(DIEN) - .; - .N ANS,DIC,DIR,DLG,LIT1,PNAME,PXRMREM,REM - .S DIC("A")="SELECT A REMINDER TO LINK OR CHANGE: " - .S LIT1="You must select a reminder!" - .D SEL(811.9,"AEQMZ",.PXRMREM) - .Q:$D(DTOUT)!$D(DUOUT) - .S REM=$P(PXRMREM(1),U),PNAME=$P(PXRMREM(1),U,3) - .I PNAME]"" W !!,"REMINDER PRINT NAME: "_PNAME,! - .;Display related dialogs - .D DISP(REM) - .;Check if already linked - .S DLG=$P($G(^PXD(811.9,REM,51)),U) - .;Reconfirm to link reminder - .I 'DLG S ANS="" D ASK(.ANS) Q:ANS'="Y" - .; - .N DA,DR,DIE - .;Edit selected reminder - .S DA=REM - .;Settup local variables - .S DIE="^PXD(811.9,",DR=51 - .;If no link force entry - .I 'DLG S DR=DR_"///"_PXRMNAME - .D ^DIE - Q - ; - ;Link a Reminder (called by protocol PXRM DIALOG LINK) - ;--------------- -RLINK(REM) ; - N DLG - ;Re-display reminder name - W IORESET - W !,PXRMHD - ; - N DA,DR,DIE - ;Edit selected reminder - S DA=REM - ;Settup local variables - S DIE="^PXD(811.9,",DR=51 - ;If no link force entry - D ^DIE - Q - ; - ;General help text routine. - ;-------------------------- -HLP(CALL) ; - N HTEXT - N DIWF,DIWL,DIWR,IC - S DIWF="C75",DIWL=0,DIWR=75 - ; - I CALL=1 D - .S HTEXT(1)="Enter Yes to link reminder to this dialog." - I CALL=2 D - .S HTEXT(1)="Enter Yes to link reminder to this dialog." - 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 - ; - ;Reminder selection - ;------------------ -SEL(FILE,MODE,ARRAY) ; - N X,Y,CNT - K DIROUT,DIRUT,DTOUT,DUOUT - S CNT=0 - W ! - F D Q:$D(DTOUT) Q:$D(DUOUT) Q:CNT>0 Q:(Y=-1)&(CNT>0) - .S DIC=FILE,DIC(0)=MODE - .D ^DIC - .I X=(U_U) S DTOUT=1 - .I '$D(DTOUT),('$D(DUOUT)) D - ..I +Y'=-1 D Q - ...S CNT=CNT+1,ARRAY(CNT)=Y_U_Y(0,0)_U_$P(Y(0),U,3) - ..W:CNT=0 !,LIT1 - .K DIC - Q - ; - ;Input transform for FINDING ITEM in 801.41 -XINP(X) ;Taxonomy findings are not allowed for dialog groups - I $P(X,";",2)="PXD(811.2,",$P($G(^PXRMD(801.41,DA,0)),U,4)="G" D Q 0 - .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 - W *7,!,"This test is not appropriate for the GUI",! - Q 0 +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 + ; +START N BY,DATA,DDES,DHD,DIC,DNAM,DTYP,FLDS,FR,L,LOGIC,NOW,PNAM,TO,Y + N PXRMBG,PXRMHD,PXRMDIEN,PXRMGTYP,PXRMDTYP,PXRMITEM,PXRMMODE,PXRMNAME + N PXRMTEMP,PXRMTITL,PXRMVIEW + ;Refresh on return + S VALMBCK="R" + S VALMSG="+ Next Screen - Prev Screen ?? More Actions" + ;Default is display dialog elements + S PXRMDTYP="R",PXRMGTYP="DLGR",PXRMVIEW="AN" + ;Select dialog for display + F D Q:'PXRMTEMP + .S PXRMTEMP="" + .D START^PXRMSEL(.PXRMHD,.PXRMGTYP,"PXRMTEMP") Q:'PXRMTEMP + .N X S X="IORESET" + .D ENDR^%ZISS,@(PXRMGTYP_"("_PXRMTEMP_")") +END Q + ; + ;Reminder View + ;------------- +DLGR(PXRMITEM) ; + N PXRMDIEN,PXRMCS1,PXRMCS2 + ;Format headings to include reminder and name + S DATA=$G(^PXD(811.9,PXRMITEM,0)),RNAM=$P(DATA,U),PNAM=$P(DATA,U,3) + S PXRMHD="REMINDER NAME: "_RNAM + ; + ;Dialog History + F D Q:'PXRMDIEN + .D START^PXRMDLGH(PXRMITEM,.PXRMDIEN,"PXRMDIEN") Q:'PXRMDIEN + .N PXRMHD,VALMBCK,VALMBG,VALMSG,VIEW,X,XMZ + .S DNAM=$P($G(^PXRMD(801.41,PXRMDIEN,0)),U) + .I $P($G(^PXRMD(801.41,PXRMDIEN,0)),U,3)]"" S DNAM=DNAM_" (DISABLED)" + .S PXRMHD="REMINDER DIALOG NAME: "_DNAM + .S PXRMCS1=$$FILE^PXRMEXCS(801.41,PXRMDIEN) + .S X="IORESET" + .D ENDR^%ZISS,EN^VALM("PXRM DIALOG LIST") + .I PXRMDIEN,$D(^PXRMD(801.41,PXRMDIEN,0)) D + ..S PXRMCS2=$$FILE^PXRMEXCS(801.41,PXRMDIEN) Q:+PXRMCS2=0 + ..Q:PXRMCS1=PXRMCS2 + ..D SEHIST^PXRMUTIL(801.41,"^PXRMD(801,41,",PXRMDIEN) + .W IORESET + .D KILL^%ZISS + Q + ; + ;Edit element/prompt/group + ;------------------------- +DLGE(PXRMDIEN) ; + N LOCK,LFIND + ;Check for Uneditable flag + S LOCK=$P($G(^PXRMD(801.41,PXRMTEMP,100)),U,4) + S LFIND=$P($G(^PXRMD(801.41,PXRMTEMP,1)),U,5) + I LOCK=1,$G(LFIND)'="",$G(LFIND)'["ORD",'$G(PXRMINST) D Q + .W !,"This item can not be edited" H 2 + ; + S PXRMHD="Dialog Name: ",PXRMDIEN=PXRMTEMP + ;Format headings to include dialog name + S DATA=$G(^PXRMD(801.41,PXRMDIEN,0)),DDES=$P(DATA,U),DTYP=$P(DATA,U,4) + ;Test + I DTYP="G" D DLG(PXRMDIEN) Q + ; + S PXRMHD=PXRMHD_" "_DDES W PXRMHD,! + ;Edit selected dialog + D EDIT^PXRMDEDT(DTYP,PXRMDIEN,0) + Q + ; + ;Reminder dialog view + ;-------------------- +DLG(PXRMDIEN) ; + S PXRMDIEN=PXRMTEMP + S PXRMNAME=$P($G(^PXRMD(801.41,PXRMDIEN,0)),U) + S PXRMITEM=$P($G(^PXRMD(801.41,PXRMDIEN,0)),U,2) + ;Format headings to include dialog name + S PXRMHD=PXRMHD_PXRMNAME + ;Check if the set is disable and add to header if disabled + I $P(^PXRMD(801.41,PXRMDIEN,0),U,3)]"" S PXRMHD=PXRMHD_" (DISABLED)" + ;Listman option + D EN^VALM("PXRM DIALOG LIST") + W IORESET + D KILL^%ZISS + Q + ; + ;Other subroutines + ; + ;Ask update or no + ;---------------- +ASK(YESNO) ; + N X,Y,TEXT,DIR + K DIROUT,DIRUT,DTOUT,DUOUT + S DIR(0)="YA0" + S DIR("A")="LINK THIS REMINDER TO DIALOG - "_$P(PXRMHD,": ",2)_": " + S DIR("B")="Y" + S DIR("?")="Enter Y or N. For detailed help type ??" + S DIR("??")=U_"D HLP^PXRMDLGY(1)" + D ^DIR K DIR + I $D(DIROUT) S DTOUT=1 + I $D(DTOUT)!($D(DUOUT)) Q + S YESNO=$E(Y(0)) + Q + ; + ;Display dialogs autogenerated from this reminder + ;------------------------------------------------ +DISP(RIEN) ; + N ARRAY,DSUB,FIRST + ;Get OTHER dialogs + S FIRST=1,DSUB="" + F S DSUB=$O(^PXRMD(801.41,"AG",RIEN,DSUB)) Q:'DSUB D + .W ! + .D:FIRST + ..W "DIALOGS ALREADY GENERATED FROM THIS REMINDER:",!! S FIRST=0 + .W ?20,$P($G(^PXRMD(801.41,DSUB,0)),U) + ; + I 'FIRST W ! + ; + Q + ; + ;Display linked reminders + ;------------------------ +DISPL(DIEN) ; + N ARRAY,DLG,RSUB,FIRST,RNAM + S RSUB=$P($G(^PXRMD(801.41,DIEN,0)),U,2) + I RSUB W !!,"SOURCE REMINDER: "_$P($G(^PXD(811.9,RSUB,0)),U) + ;Linked reminders + S FIRST=1,RNAM="" + F S RNAM=$O(^PXD(811.9,"B",RNAM)) Q:RNAM="" D + .S RSUB=$O(^PXD(811.9,"B",RNAM,"")) Q:'RSUB + .S DLG=$P($G(^PXD(811.9,RSUB,51)),U) Q:DLG'=DIEN + .W ! I FIRST W !,"REMINDERS ALREADY LINKED TO THIS DIALOG:",!! S FIRST=0 + .W ?18,$P($G(^PXD(811.9,RSUB,0)),U) + Q + ; + ;Link a dialog (called by protocol PXRM DIALOG/REMINDER LINK) + ;------------- +LINK(DIEN) ; + F D Q:$D(DTOUT)!$D(DUOUT) + .W IORESET + .S VALMBCK="R" + .;Display linked reminders + .D DISPL(DIEN) + .; + .N ANS,DIC,DIR,DLG,LIT1,PNAME,PXRMREM,REM + .S DIC("A")="SELECT A REMINDER TO LINK OR CHANGE: " + .S LIT1="You must select a reminder!" + .D SEL(811.9,"AEQMZ",.PXRMREM) + .Q:$D(DTOUT)!$D(DUOUT) + .S REM=$P(PXRMREM(1),U),PNAME=$P(PXRMREM(1),U,3) + .I PNAME]"" W !!,"REMINDER PRINT NAME: "_PNAME,! + .;Display related dialogs + .D DISP(REM) + .;Check if already linked + .S DLG=$P($G(^PXD(811.9,REM,51)),U) + .;Reconfirm to link reminder + .I 'DLG S ANS="" D ASK(.ANS) Q:ANS'="Y" + .; + .N DA,DR,DIE + .;Edit selected reminder + .S DA=REM + .;Settup local variables + .S DIE="^PXD(811.9,",DR=51 + .;If no link force entry + .I 'DLG S DR=DR_"///"_PXRMNAME + .D ^DIE + Q + ; + ;Link a Reminder (called by protocol PXRM DIALOG LINK) + ;--------------- +RLINK(REM) ; + N DLG + ;Re-display reminder name + W IORESET + W !,PXRMHD + ; + N DA,DR,DIE + ;Edit selected reminder + S DA=REM + ;Settup local variables + S DIE="^PXD(811.9,",DR=51 + ;If no link force entry + D ^DIE + Q + ; + ;General help text routine. + ;-------------------------- +HLP(CALL) ; + N HTEXT + N DIWF,DIWL,DIWR,IC + S DIWF="C75",DIWL=0,DIWR=75 + ; + I CALL=1 D + .S HTEXT(1)="Enter Yes to link reminder to this dialog." + I CALL=2 D + .S HTEXT(1)="Enter Yes to link reminder to this dialog." + 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 + ; + ;Reminder selection + ;------------------ +SEL(FILE,MODE,ARRAY) ; + N X,Y,CNT + K DIROUT,DIRUT,DTOUT,DUOUT + S CNT=0 + W ! + F D Q:$D(DTOUT) Q:$D(DUOUT) Q:CNT>0 Q:(Y=-1)&(CNT>0) + .S DIC=FILE,DIC(0)=MODE + .D ^DIC + .I X=(U_U) S DTOUT=1 + .I '$D(DTOUT),('$D(DUOUT)) D + ..I +Y'=-1 D Q + ...S CNT=CNT+1,ARRAY(CNT)=Y_U_Y(0,0)_U_$P(Y(0),U,3) + ..W:CNT=0 !,LIT1 + .K DIC + Q + ; + ;Input transform for FINDING ITEM in 801.41 +XINP(X) ;Taxonomy findings are not allowed for dialog groups + I $P(X,";",2)="PXD(811.2,",$P($G(^PXRMD(801.41,DA,0)),U,4)="G" D Q 0 + .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," 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 diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMDLL.m b/r/CLINICAL_REMINDERS-PXRM/PXRMDLL.m index b8aec21b..cf50c2dd 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMDLL.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMDLL.m @@ -1,272 +1,270 @@ -PXRMDLL ;SLC/PJH - REMINDER DIALOG LOADER ;09/26/2007 - ;;2.0;CLINICAL REMINDERS;**10,6**;Feb 04, 2005;Build 123 - ; -OK(DIEN) ;Check if mental health test is for GUI - I 'DIEN Q 0 - Q $$MH^PXRMDLG5(DIEN) - ; -TXT ;Format text - N NULL - S TEXT=DTXT(SUB),NULL=0 - I ($E(TEXT)=" ")!(TEXT="") S NULL=1 - I LAST,'NULL S TEXT="
"_TEXT - S TEXT=$$STRREP^PXRMUTIL(TEXT,"\\","
") - S LAST=0 I NULL S TEXT="
"_TEXT,LAST=1 - Q - ; -EXP(TIEN,DITEM,DSUB) ;Expand taxonomy codes - N ACNT,AHIS,ATYP,ARRAY,CODES,CNT,DPCE,DTAX - ;Get taxonomy file details - D TAX(TIEN,.ARRAY) - ; - ;Build dialog from the returned array - ; - ;Main Taxonomy prompt - S DTXT=ARRAY - S OCNT=OCNT+1 - S ORY(OCNT)=1_U_DITEM_U_DSUB_U_"S"_U_DEXC - ;Default group indents and selection entry - S $P(ORY(OCNT),U,16)=2,$P(ORY(OCNT),U,18)=2 - S OCNT=OCNT+1 - S ORY(OCNT)=2_U_DITEM_U_DSUB_U_DTXT - ; - ;Taxonomy CPT/POV resolution prompts - S ACNT="" - F S ACNT=$O(ARRAY(ACNT)) Q:ACNT="" D - .;Prompt text - .S DTXT=$P(ARRAY(ACNT),U),DPCE=$P(ARRAY(ACNT),U,4) - .;Historical/Current flag - .S AHIS=0 I $P(ARRAY(ACNT),U,3)=2 S AHIS=1 - .;CPT/POV - .S ATYP="POV" I $P(ARRAY(ACNT),U,2)=81 S ATYP="CPT" - .;Initial display - .S DHIDE=0,DCHECK=0,DDIS=0 - .;Construct ien for this level - .S DTAX=DSUB_"."_ACNT - .S OCNT=OCNT+1 - .S ORY(OCNT)=1_U_DITEM_U_DTAX_U_"T"_U_DEXC_U_U_ATYP_U_AHIS - .S OCNT=OCNT+1 - .S ORY(OCNT)=2_U_DITEM_U_DTAX_U_DTXT - Q - ; -GROUP(DIEN,DSUB) ;Dialog group - N DATA,DBOX,DCAP,DCHK,DENTRY,DEXC,DGIEN,DGRP,DGSEQ,DGSUB,DHIDE,DIND - N DINDPN,DMHEX,DRESL,DSHARE,SUB,DCOUNT - ;Group caption text - S DATA=$G(^PXRMD(801.41,DIEN,0)) - S DCAP=$P(DATA,U,5),DBOX=$P(DATA,U,6),DIND=$P(DATA,U,7) - S DSHARE=$P(DATA,U,8),DENTRY=$P(DATA,U,9),DHIDE=$P(DATA,U,10) - S DINDPN=$P(DATA,U,12) S:DINDPN="" DINDPN=0 - S DBOX=$S(DBOX="Y":1,1:"") - ;group header is display only if SUPPRESS CHECKBOX - S DCHK="S" I ('DHIDE)&(DSUPP) S DCHK="D",DHIDE=0 - ;Default group setting to hide - I DHIDE="" S DHIDE=1 - ; - S DEXC=$P($G(^PXRMD(801.41,DIEN,2)),U,3) - ; - S OCNT=OCNT+1,ORY(OCNT)=1_U_DIEN_U_DSUB_U_DCHK_U_DEXC - S $P(ORY(OCNT),U,8)=$$AHIS(DIEN) - S $P(ORY(OCNT),U,15)=DHIDE,$P(ORY(OCNT),U,16)=DIND - S $P(ORY(OCNT),U,17)=DSHARE,$P(ORY(OCNT),U,18)=DENTRY - S $P(ORY(OCNT),U,19)=DBOX,$P(ORY(OCNT),U,20)=DCAP - S $P(ORY(OCNT),U,21)=DINDPN - ;Create type 2 records if if here is additional group text - N LAST,TEXT - S SUB=0,LAST=0 F S SUB=$O(DTXT(SUB)) Q:'SUB D - .D TXT - .S OCNT=OCNT+1,ORY(OCNT)=2_U_DIEN_U_DSUB_U_TEXT - ;Get dialog group sub-elements - N DTYP,DSUPP,DDIS,IDENT S DGSEQ=0 - F S DGSEQ=$O(^PXRMD(801.41,DIEN,10,"B",DGSEQ)) Q:'DGSEQ D - .S DGSUB=$O(^PXRMD(801.41,DIEN,10,"B",DGSEQ,"")) Q:'DGSUB - .S DATA=$G(^PXRMD(801.41,DIEN,10,DGSUB,0)) - .S DGIEN=$P(DATA,U,2) Q:'DGIEN - .;Branching logic call to determine if element should be suppress, - .;replace or left as is - .N TERMNODE,TERMSTAT - .S TERMNODE=$G(^PXRMD(801.41,DGIEN,49)) - .I $G(TERMNODE)'="" D Q:TERMSTAT=0 - ..S TERMSTAT=1 - ..D REPLACE^PXRMDLLB(DFN,TERMNODE,.DGIEN,.DATA,.TERMSTAT) - .;Exclude from P/N - .S DEXC=$P(DATA,U,8) - .I $P($G(^PXRMD(801.41,DGIEN,0)),U,16)'["WHR" D - ..K DTXT S SUB=0 F S SUB=$O(^PXRMD(801.41,DGIEN,25,SUB)) Q:'SUB D - ...S DTXT(SUB)=$G(^PXRMD(801.41,DGIEN,25,SUB,0)) - .;Check if element is disabled/invalid - .S DATA=$G(^PXRMD(801.41,DGIEN,0)) Q:DATA="" Q:$P(DATA,U,3)]"" - .;If the actual element is exclude from P/N override - .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 DRES=$P($G(^PXRMD(801.41,DGIEN,1)),U,3) - .;Done Elsewhere (historical) - .S DHIS=$$AHIS(DGIEN) - .S DFIND=$P($G(^PXRMD(801.41,DGIEN,1)),U,5) - .S DFIEN=$P(DFIND,";"),DFTYP=$P(DFIND,";",2) - .S DPCE="" I DFTYP'="" S DPCE=$G(DARRAY(DFTYP)) - .;If mental Health ignore if not GUI - .I DPCE="MH" Q:'$$OK(DFIEN) - .S DGRP=DSUB_"."_DGSUB - .;Taxonomy codes need expanding - .I DPCE="T" D EXP(DFIEN,DGIEN,DGRP) Q - .;Translate vitals ien to PCE code - This will need a DBIA - .I DPCE="VIT" S DFIEN=$$GET1^DIQ(120.51,DFIEN,7,"E") - .;Embedded Dialog Group - .I DTYP="G" D GROUP(DGIEN,DGRP) Q - .S DDIS="S" I DSUPP=1 S DDIS="D" - .S DGRP=DSUB_"."_DGSUB,OCNT=OCNT+1 - .S ORY(OCNT)=1_U_DGIEN_U_DGRP_U_DDIS_U_DEXC_U_U_U_DHIS_U_DMHEX_U_DRESL_U_$G(DCOUNT) - .; - .N LAST,TEXT - .S SUB=0,LAST=0 F S SUB=$O(DTXT(SUB)) Q:'SUB D - ..D TXT - ..S OCNT=OCNT+1,ORY(OCNT)=2_U_DGIEN_U_DGRP_U_TEXT - Q - ; -LOAD(DIEN,DFN) ;Load dialog questions into array - N DARRAY,DATA,DITEM,DFIND,DFIEN,DFTYP,DPCE,DRES,DSEQ,DSUB,DTXT,DTYP,OCNT - N DDIS,DEXC,DHIDE,DCHECK,DDIS,DHIS,DMHEX,DRESL,DSUPP,SUB,IDENT,TXTCNT - ;Check Status of dialog - S DATA=$G(^PXRMD(801.41,DIEN,0)) Q:DATA="" - ;If disabled ignore - I $P(DATA,U,3)]"" Q - ;Ignore if not a reminder dialog - I $P(DATA,U,4)'="R" Q - ; - ;List of PCE codes - S DARRAY("AUTTEDT(")="PED" - S DARRAY("AUTTEXAM(")="XAM" - S DARRAY("AUTTHF(")="HF" - S DARRAY("AUTTIMM(")="IMM" - S DARRAY("AUTTSK(")="SK" - S DARRAY("GMRD(120.51,")="VIT" - S DARRAY("ORD(101.41,")="Q" - S DARRAY("YTT(601.71,")="MH" - S DARRAY("ICD9(")="POV" - S DARRAY("ICPT(")="CPT" - S DARRAY("PXD(811.2,")="T" - S DARRAY("WV(790.1,")="WHR" - ; - ;Get elements for the dialog - S DSEQ=0,OCNT=0 - F S DSEQ=$O(^PXRMD(801.41,DIEN,10,"B",DSEQ)) Q:'DSEQ D - .S DSUB=$O(^PXRMD(801.41,DIEN,10,"B",DSEQ,"")) Q:'DSUB - .S DATA=$G(^PXRMD(801.41,DIEN,10,DSUB,0)) - .S DITEM=$P(DATA,U,2) Q:DITEM="" - .;Ignore disabled elements - .S DATA=$G(^PXRMD(801.41,DITEM,0)) Q:DATA="" Q:$P(DATA,U,3)]"" - .;Branching logic call to determine if element should be suppress, - .;replace or left as is - .S TERMNODE=$G(^PXRMD(801.41,DITEM,49)) - .N TERMSTAT - .I $G(TERMNODE)'="" D Q:TERMSTAT=0 - ..S TERMSTAT=1 - ..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) - .K DTXT S SUB=0 - .F S SUB=$O(^PXRMD(801.41,DITEM,25,SUB)) Q:'SUB D - ..S DTXT(SUB)=$G(^PXRMD(801.41,DITEM,25,SUB,0)) - .S DRES=$P($G(^PXRMD(801.41,DITEM,1)),U,3) - .S DFIND=$P($G(^PXRMD(801.41,DITEM,1)),U,5) - .S DFIEN=$P(DFIND,";"),DFTYP=$P(DFIND,";",2) - .S DPCE="" I DFTYP'="" S DPCE=$G(DARRAY(DFTYP)) - .;If mental Health ignore if not GUI - .I DPCE="MH" Q:'$$OK(DFIEN) - .;Exclude from PN - .S DEXC=$P($G(^PXRMD(801.41,DITEM,2)),U,3) - .;Taxonomy codes need expanding - .I DPCE="T" D EXP(DFIEN,DITEM,DSUB) Q - .;Translate vitals ien to PCE code - This will need a DBIA - .I DPCE="VIT" S DFIEN=$P($G(^GMRD(120.51,DFIEN,0)),U,7) - .;Done Elsewhere (historical) - .S DHIS=$$AHIS(DITEM) - .;Dialog Group - .I DTYP="G" D GROUP(DITEM,DSUB) Q - .;Dialog type/text and resolution - .S OCNT=OCNT+1,DDIS="S" - .I DSUPP=1 S DDIS="D" - .S ORY(OCNT)=1_U_DITEM_U_DSUB_U_DDIS_U_DEXC_U_U_U_DHIS_U_DMHEX_U_DRESL - .N LAST,TEXT - .S SUB=0,LAST=0 F S SUB=$O(DTXT(SUB)) Q:'SUB D - ..D TXT - ..S OCNT=OCNT+1,ORY(OCNT)=2_U_DITEM_U_DSUB_U_TEXT - Q - ; -TAX(TXIEN,ARRAY) ;Return list of resolutions/codes for taxonomy - N CNT,DTXT,FNODE,RSUB,TDX,TNAME,TPAR,TPR,TYP - N TCUR,TDTXT,TDHTXT,THIS,TPTXT,TPHTXT - ; - ;Get taxonomy name - S TNAME=$P($G(^PXD(811.2,TXIEN,0)),U,1) - ; - ;Check what type of taxonomy codes exist - S TDX=$$TOK^PXRMDLLA(TXIEN,"SDX") - S TPR=$$TOK^PXRMDLLA(TXIEN,"SPR") - ; - ;Taxonomy dialog text - S DTXT=$P($G(^PXD(811.2,TXIEN,0)),U,3) - ;default to taxonomy description if null - I DTXT="" S DTXT=$P($G(^PXD(811.2,TXIEN,0)),U,2) - ;default to taxonomy name if null - I DTXT="" S DTXT=$P($G(^PXD(811.2,TXIEN,0)),U,1) - ; - S CNT=0,ARRAY=DTXT - ; - ;Diagnoses - I TDX D - .;Diagnosis texts - .S TPAR=$G(^PXD(811.2,TXIEN,"SDZ")) - .;Get parameter file node for this finding type - .S FNODE=$O(^PXRMD(801.45,"B","POV","")) Q:FNODE="" - .;check if finding parameters are disabled - .S TCUR=$P($G(^PXRMD(801.45,FNODE,1,1,0)),U,2) - .S THIS=$P($G(^PXRMD(801.45,FNODE,1,2,0)),U,2) - .;get category text (diagnoses) - .I 'TCUR D ; Current - ..S TDTXT=$P(TPAR,U,2) S:TDTXT="" TDTXT=TNAME - ..S CNT=CNT+1,ARRAY(CNT)=TDTXT_U_80_U_1_U_"POV" - .I 'THIS D ; Historical - ..S TDHTXT=$P(TPAR,U,3) S:TDHTXT="" TDHTXT=TNAME_" (HISTORICAL)" - ..S CNT=CNT+1,ARRAY(CNT)=TDHTXT_U_80_U_2_U_"POV" - ;Procedures - I TPR D - .;Procedure texts - .S TPAR=$G(^PXD(811.2,TXIEN,"SPZ")) - .;Get parameter file node for this finding type - .S FNODE=$O(^PXRMD(801.45,"B","CPT","")) Q:FNODE="" - .;check if finding parameters are disabled - .S TCUR=$P($G(^PXRMD(801.45,FNODE,1,1,0)),U,2) - .S THIS=$P($G(^PXRMD(801.45,FNODE,1,2,0)),U,2) - .;get category text (procedures) - .I 'TCUR D ; Current - ..S TPTXT=$P(TPAR,U,2) S:TPTXT="" TPTXT=TNAME - ..S CNT=CNT+1,ARRAY(CNT)=TPTXT_U_81_U_1_U_"CPT" - .I 'THIS D ; Historical - ..S TPHTXT=$P(TPAR,U,3) S:TPHTXT="" TPHTXT=TNAME_" (HISTORICAL)" - ..S CNT=CNT+1,ARRAY(CNT)=TPHTXT_U_81_U_2_U_"CPT" - ; - Q - ; -AHIS(DITEM) ; - N RSIEN,RSNAM - S RSIEN=$P($G(^PXRMD(801.41,DITEM,1)),U,3) - I RSIEN="" Q 0 - S RSNAM=$P($G(^PXRMD(801.9,RSIEN,0)),U) - I RSNAM["DONE ELSEWHERE" Q 1 - N GUI,PIEN,PFOUND - S PIEN=0,PFOUND=0 - F S PIEN=$O(^PXRMD(801.41,DITEM,10,"D",PIEN)) Q:'PIEN D Q:PFOUND - .;Ignore elements and groups - .I "EG"[$P($G(^PXRMD(801.41,PIEN,0)),U,4) Q - .;GUI Process - .S GUI=$P($G(^PXRMD(801.41,PIEN,46)),U) Q:'GUI - .;Check if this is PXRM VISIT DATE (or a copy of it) - .I $P($G(^PXRMD(801.42,GUI,0)),U)="VST_DATE" S PFOUND=1 - Q PFOUND +PXRMDLL ;SLC/PJH - REMINDER DIALOG LOADER ;09/26/2007 + ;;2.0;CLINICAL REMINDERS;**10**;Feb 04, 2005;Build 25 + ; +OK(DIEN) ;Check if mental health test is for GUI + 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 + N NULL + S TEXT=DTXT(SUB),NULL=0 + I ($E(TEXT)=" ")!(TEXT="") S NULL=1 + I LAST,'NULL S TEXT="
"_TEXT + S TEXT=$$STRREP^PXRMUTIL(TEXT,"\\","
") + S LAST=0 I NULL S TEXT="
"_TEXT,LAST=1 + Q + ; +EXP(TIEN,DITEM,DSUB) ;Expand taxonomy codes + N ACNT,AHIS,ATYP,ARRAY,CODES,CNT,DPCE,DTAX + ;Get taxonomy file details + D TAX(TIEN,.ARRAY) + ; + ;Build dialog from the returned array + ; + ;Main Taxonomy prompt + S DTXT=ARRAY + S OCNT=OCNT+1 + S ORY(OCNT)=1_U_DITEM_U_DSUB_U_"S"_U_DEXC + ;Default group indents and selection entry + S $P(ORY(OCNT),U,16)=2,$P(ORY(OCNT),U,18)=2 + S OCNT=OCNT+1 + S ORY(OCNT)=2_U_DITEM_U_DSUB_U_DTXT + ; + ;Taxonomy CPT/POV resolution prompts + S ACNT="" + F S ACNT=$O(ARRAY(ACNT)) Q:ACNT="" D + .;Prompt text + .S DTXT=$P(ARRAY(ACNT),U),DPCE=$P(ARRAY(ACNT),U,4) + .;Historical/Current flag + .S AHIS=0 I $P(ARRAY(ACNT),U,3)=2 S AHIS=1 + .;CPT/POV + .S ATYP="POV" I $P(ARRAY(ACNT),U,2)=81 S ATYP="CPT" + .;Initial display + .S DHIDE=0,DCHECK=0,DDIS=0 + .;Construct ien for this level + .S DTAX=DSUB_"."_ACNT + .S OCNT=OCNT+1 + .S ORY(OCNT)=1_U_DITEM_U_DTAX_U_"T"_U_DEXC_U_U_ATYP_U_AHIS + .S OCNT=OCNT+1 + .S ORY(OCNT)=2_U_DITEM_U_DTAX_U_DTXT + Q + ; +GROUP(DIEN,DSUB) ;Dialog group + N DATA,DBOX,DCAP,DCHK,DENTRY,DEXC,DGIEN,DGRP,DGSEQ,DGSUB,DHIDE,DIND + N DINDPN,DMHEX,DRESL,DSHARE,SUB,DCOUNT + ;Group caption text + S DATA=$G(^PXRMD(801.41,DIEN,0)) + S DCAP=$P(DATA,U,5),DBOX=$P(DATA,U,6),DIND=$P(DATA,U,7) + S DSHARE=$P(DATA,U,8),DENTRY=$P(DATA,U,9),DHIDE=$P(DATA,U,10) + S DINDPN=$P(DATA,U,12) S:DINDPN="" DINDPN=0 + S DBOX=$S(DBOX="Y":1,1:"") + ;group header is display only if SUPPRESS CHECKBOX + S DCHK="S" I ('DHIDE)&(DSUPP) S DCHK="D",DHIDE=0 + ;Default group setting to hide + I DHIDE="" S DHIDE=1 + ; + S DEXC=$P($G(^PXRMD(801.41,DIEN,2)),U,3) + ; + S OCNT=OCNT+1,ORY(OCNT)=1_U_DIEN_U_DSUB_U_DCHK_U_DEXC + S $P(ORY(OCNT),U,8)=$$AHIS(DIEN) + S $P(ORY(OCNT),U,15)=DHIDE,$P(ORY(OCNT),U,16)=DIND + S $P(ORY(OCNT),U,17)=DSHARE,$P(ORY(OCNT),U,18)=DENTRY + S $P(ORY(OCNT),U,19)=DBOX,$P(ORY(OCNT),U,20)=DCAP + S $P(ORY(OCNT),U,21)=DINDPN + ;Create type 2 records if if here is additional group text + N LAST,TEXT + S SUB=0,LAST=0 F S SUB=$O(DTXT(SUB)) Q:'SUB D + .D TXT + .S OCNT=OCNT+1,ORY(OCNT)=2_U_DIEN_U_DSUB_U_TEXT + ;Get dialog group sub-elements + N DTYP,DSUPP,DDIS,IDENT S DGSEQ=0 + F S DGSEQ=$O(^PXRMD(801.41,DIEN,10,"B",DGSEQ)) Q:'DGSEQ D + .S DGSUB=$O(^PXRMD(801.41,DIEN,10,"B",DGSEQ,"")) Q:'DGSUB + .S DATA=$G(^PXRMD(801.41,DIEN,10,DGSUB,0)) + .S DGIEN=$P(DATA,U,2) Q:'DGIEN + .;Branching logic call to determine if element should be suppress, + .;replace or left as is + .N TERMNODE,TERMSTAT + .S TERMNODE=$G(^PXRMD(801.41,DGIEN,49)) + .I $G(TERMNODE)'="" D Q:TERMSTAT=0 + ..S TERMSTAT=1 + ..D REPLACE^PXRMDLLB(DFN,TERMNODE,.DGIEN,.DATA,.TERMSTAT) + .;Exclude from P/N + .S DEXC=$P(DATA,U,8) + .I $P($G(^PXRMD(801.41,DGIEN,0)),U,16)'["WHR" D + ..K DTXT S SUB=0 F S SUB=$O(^PXRMD(801.41,DGIEN,25,SUB)) Q:'SUB D + ...S DTXT(SUB)=$G(^PXRMD(801.41,DGIEN,25,SUB,0)) + .;Check if element is disabled/invalid + .S DATA=$G(^PXRMD(801.41,DGIEN,0)) Q:DATA="" Q:$P(DATA,U,3)]"" + .;If the actual element is exclude from P/N override + .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),DRESL=$P(DATA,U,15) + .S DRES=$P($G(^PXRMD(801.41,DGIEN,1)),U,3) + .;Done Elsewhere (historical) + .S DHIS=$$AHIS(DGIEN) + .S DFIND=$P($G(^PXRMD(801.41,DGIEN,1)),U,5) + .S DFIEN=$P(DFIND,";"),DFTYP=$P(DFIND,";",2) + .S DPCE="" I DFTYP'="" S DPCE=$G(DARRAY(DFTYP)) + .;If mental Health ignore if not GUI + .I DPCE="MH" Q:'$$OK(DFIEN) + .S DGRP=DSUB_"."_DGSUB + .;Taxonomy codes need expanding + .I DPCE="T" D EXP(DFIEN,DGIEN,DGRP) Q + .;Translate vitals ien to PCE code - This will need a DBIA + .I DPCE="VIT" S DFIEN=$$GET1^DIQ(120.51,DFIEN,7,"E") + .;Embedded Dialog Group + .I DTYP="G" D GROUP(DGIEN,DGRP) Q + .S DDIS="S" I DSUPP=1 S DDIS="D" + .S DGRP=DSUB_"."_DGSUB,OCNT=OCNT+1 + .S ORY(OCNT)=1_U_DGIEN_U_DGRP_U_DDIS_U_DEXC_U_U_U_DHIS_U_DMHEX_U_DRESL_U_$G(DCOUNT) + .; + .N LAST,TEXT + .S SUB=0,LAST=0 F S SUB=$O(DTXT(SUB)) Q:'SUB D + ..D TXT + ..S OCNT=OCNT+1,ORY(OCNT)=2_U_DGIEN_U_DGRP_U_TEXT + Q + ; +LOAD(DIEN,DFN) ;Load dialog questions into array + N DARRAY,DATA,DITEM,DFIND,DFIEN,DFTYP,DPCE,DRES,DSEQ,DSUB,DTXT,DTYP,OCNT + N DDIS,DEXC,DHIDE,DCHECK,DDIS,DHIS,DMHEX,DRESL,DSUPP,SUB,IDENT,TXTCNT + ;Check Status of dialog + S DATA=$G(^PXRMD(801.41,DIEN,0)) Q:DATA="" + ;If disabled ignore + I $P(DATA,U,3)]"" Q + ;Ignore if not a reminder dialog + I $P(DATA,U,4)'="R" Q + ; + ;List of PCE codes + S DARRAY("AUTTEDT(")="PED" + S DARRAY("AUTTEXAM(")="XAM" + S DARRAY("AUTTHF(")="HF" + S DARRAY("AUTTIMM(")="IMM" + S DARRAY("AUTTSK(")="SK" + S DARRAY("GMRD(120.51,")="VIT" + S DARRAY("ORD(101.41,")="Q" + S DARRAY("YTT(601,")="MH" + S DARRAY("ICD9(")="POV" + S DARRAY("ICPT(")="CPT" + S DARRAY("PXD(811.2,")="T" + S DARRAY("WV(790.1,")="WHR" + ; + ;Get elements for the dialog + S DSEQ=0,OCNT=0 + F S DSEQ=$O(^PXRMD(801.41,DIEN,10,"B",DSEQ)) Q:'DSEQ D + .S DSUB=$O(^PXRMD(801.41,DIEN,10,"B",DSEQ,"")) Q:'DSUB + .S DATA=$G(^PXRMD(801.41,DIEN,10,DSUB,0)) + .S DITEM=$P(DATA,U,2) Q:DITEM="" + .;Ignore disabled elements + .S DATA=$G(^PXRMD(801.41,DITEM,0)) Q:DATA="" Q:$P(DATA,U,3)]"" + .;Branching logic call to determine if element should be suppress, + .;replace or left as is + .S TERMNODE=$G(^PXRMD(801.41,DITEM,49)) + .N TERMSTAT + .I $G(TERMNODE)'="" D Q:TERMSTAT=0 + ..S TERMSTAT=1 + ..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),DRESL=$P(DATA,U,15) + .K DTXT S SUB=0 + .F S SUB=$O(^PXRMD(801.41,DITEM,25,SUB)) Q:'SUB D + ..S DTXT(SUB)=$G(^PXRMD(801.41,DITEM,25,SUB,0)) + .S DRES=$P($G(^PXRMD(801.41,DITEM,1)),U,3) + .S DFIND=$P($G(^PXRMD(801.41,DITEM,1)),U,5) + .S DFIEN=$P(DFIND,";"),DFTYP=$P(DFIND,";",2) + .S DPCE="" I DFTYP'="" S DPCE=$G(DARRAY(DFTYP)) + .;If mental Health ignore if not GUI + .I DPCE="MH" Q:'$$OK(DFIEN) + .;Exclude from PN + .S DEXC=$P($G(^PXRMD(801.41,DITEM,2)),U,3) + .;Taxonomy codes need expanding + .I DPCE="T" D EXP(DFIEN,DITEM,DSUB) Q + .;Translate vitals ien to PCE code - This will need a DBIA + .I DPCE="VIT" S DFIEN=$P($G(^GMRD(120.51,DFIEN,0)),U,7) + .;Done Elsewhere (historical) + .S DHIS=$$AHIS(DITEM) + .;Dialog Group + .I DTYP="G" D GROUP(DITEM,DSUB) Q + .;Dialog type/text and resolution + .S OCNT=OCNT+1,DDIS="S" + .I DSUPP=1 S DDIS="D" + .S ORY(OCNT)=1_U_DITEM_U_DSUB_U_DDIS_U_DEXC_U_U_U_DHIS_U_DMHEX_U_DRESL + .N LAST,TEXT + .S SUB=0,LAST=0 F S SUB=$O(DTXT(SUB)) Q:'SUB D + ..D TXT + ..S OCNT=OCNT+1,ORY(OCNT)=2_U_DITEM_U_DSUB_U_TEXT + Q + ; +TAX(TXIEN,ARRAY) ;Return list of resolutions/codes for taxonomy + N CNT,DTXT,FNODE,RSUB,TDX,TNAME,TPAR,TPR,TYP + N TCUR,TDTXT,TDHTXT,THIS,TPTXT,TPHTXT + ; + ;Get taxonomy name + S TNAME=$P($G(^PXD(811.2,TXIEN,0)),U,1) + ; + ;Check what type of taxonomy codes exist + S TDX=$$TOK^PXRMDLLA(TXIEN,"SDX") + S TPR=$$TOK^PXRMDLLA(TXIEN,"SPR") + ; + ;Taxonomy dialog text + S DTXT=$P($G(^PXD(811.2,TXIEN,0)),U,3) + ;default to taxonomy description if null + I DTXT="" S DTXT=$P($G(^PXD(811.2,TXIEN,0)),U,2) + ;default to taxonomy name if null + I DTXT="" S DTXT=$P($G(^PXD(811.2,TXIEN,0)),U,1) + ; + S CNT=0,ARRAY=DTXT + ; + ;Diagnoses + I TDX D + .;Diagnosis texts + .S TPAR=$G(^PXD(811.2,TXIEN,"SDZ")) + .;Get parameter file node for this finding type + .S FNODE=$O(^PXRMD(801.45,"B","POV","")) Q:FNODE="" + .;check if finding parameters are disabled + .S TCUR=$P($G(^PXRMD(801.45,FNODE,1,1,0)),U,2) + .S THIS=$P($G(^PXRMD(801.45,FNODE,1,2,0)),U,2) + .;get category text (diagnoses) + .I 'TCUR D ; Current + ..S TDTXT=$P(TPAR,U,2) S:TDTXT="" TDTXT=TNAME + ..S CNT=CNT+1,ARRAY(CNT)=TDTXT_U_80_U_1_U_"POV" + .I 'THIS D ; Historical + ..S TDHTXT=$P(TPAR,U,3) S:TDHTXT="" TDHTXT=TNAME_" (HISTORICAL)" + ..S CNT=CNT+1,ARRAY(CNT)=TDHTXT_U_80_U_2_U_"POV" + ;Procedures + I TPR D + .;Procedure texts + .S TPAR=$G(^PXD(811.2,TXIEN,"SPZ")) + .;Get parameter file node for this finding type + .S FNODE=$O(^PXRMD(801.45,"B","CPT","")) Q:FNODE="" + .;check if finding parameters are disabled + .S TCUR=$P($G(^PXRMD(801.45,FNODE,1,1,0)),U,2) + .S THIS=$P($G(^PXRMD(801.45,FNODE,1,2,0)),U,2) + .;get category text (procedures) + .I 'TCUR D ; Current + ..S TPTXT=$P(TPAR,U,2) S:TPTXT="" TPTXT=TNAME + ..S CNT=CNT+1,ARRAY(CNT)=TPTXT_U_81_U_1_U_"CPT" + .I 'THIS D ; Historical + ..S TPHTXT=$P(TPAR,U,3) S:TPHTXT="" TPHTXT=TNAME_" (HISTORICAL)" + ..S CNT=CNT+1,ARRAY(CNT)=TPHTXT_U_81_U_2_U_"CPT" + ; + Q + ; +AHIS(DITEM) ; + N RSIEN,RSNAM + S RSIEN=$P($G(^PXRMD(801.41,DITEM,1)),U,3) + I RSIEN="" Q 0 + S RSNAM=$P($G(^PXRMD(801.9,RSIEN,0)),U) + I RSNAM["DONE ELSEWHERE" Q 1 + N GUI,PIEN,PFOUND + S PIEN=0,PFOUND=0 + F S PIEN=$O(^PXRMD(801.41,DITEM,10,"D",PIEN)) Q:'PIEN D Q:PFOUND + .;Ignore elements and groups + .I "EG"[$P($G(^PXRMD(801.41,PIEN,0)),U,4) Q + .;GUI Process + .S GUI=$P($G(^PXRMD(801.41,PIEN,46)),U) Q:'GUI + .;Check if this is PXRM VISIT DATE (or a copy of it) + .I $P($G(^PXRMD(801.42,GUI,0)),U)="VST_DATE" S PFOUND=1 + Q PFOUND diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMDLLA.m b/r/CLINICAL_REMINDERS-PXRM/PXRMDLLA.m index 162ff613..9a5c7cd4 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMDLLA.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMDLLA.m @@ -1,240 +1,238 @@ -PXRMDLLA ;SLC/PJH - REMINDER DIALOG LOADER ;11/08/2007 - ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123 - ; -FREC(DFIEN,DFTYP) ;Build type 3 record - N CSARRAY,CSCNT - ;Dialog type/text and resolution - S DNAM=$$NAME(DFIEN,DFTYP) - D CODE^PXRMDLLB(DFIEN,DFTYP,.CSARRAY) - I $D(CSARRAY)>0 D Q - . S CSCNT="" F S CSCNT=$O(CSARRAY(CSCNT)) Q:CSCNT="" D - . . S OCNT=OCNT+1 - . . S ORY(OCNT)=3_U_DITEM_U_U_DPCE_U_DEXC_U_DFIEN_U_$G(CSARRAY(CSCNT))_U_DNAM_U_U_DVIT - ;Translate vitals ien to PCE code - This will need a DBIA - S DCOD="" - I DPCE="VIT" D - .S DFIEN=$$GET1^DIQ(120.51,DFIEN,7,"E") - .;Vitals Caption - .S DVIT=$P($G(^PXRMD(801.41,DITEM,2)),U,4) - I DFTYP]"" D - .S OCNT=OCNT+1 - .S ORY(OCNT)=3_U_DITEM_U_U_DPCE_U_DEXC_U_DFIEN_U_$G(DCOD)_U_DNAM_U_U_DVIT - .;Get order type for orderable items - .;DBIA #3110 - .S:DPCE="Q" $P(ORY(OCNT),U,11)=$P($G(^ORD(101.41,DFIEN,0)),U,4) - .;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 - ..;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 - Q - ; -GUI(IEN) ;Work out prompt type for PCE - Q:IEN="" "" - N SUB S SUB=$P($G(^PXRMD(801.41,IEN,46)),U) - Q:'SUB "" - Q $P($G(^PXRMD(801.42,SUB,0)),U) - ; -LOAD(DITEM,DCUR,DTTYP) ;Load dialog questions into array - N DARRAY,DCOD,DEXC,DFIND,DFIEN,DFTYP,DNAM,DPCE,DRES,DSEQ,DSUB,DTYP,OCNT - N DVIT,NODE,CNT,IDENT - ;DBIA #3110 OR(101.41 - ; - ;Build list of PCE codes - S DARRAY("AUTTEDT(")="PED" - S DARRAY("AUTTEXAM(")="XAM" - S DARRAY("AUTTHF(")="HF" - S DARRAY("AUTTIMM(")="IMM" - S DARRAY("AUTTSK(")="SK" - ; - S DARRAY("GMRD(120.51,")="VIT" - S DARRAY("ORD(101.41,")="Q" - S DARRAY("YTT(601.71,")="MH" - ; - S DARRAY("ICD9(")="POV" - S DARRAY("ICPT(")="CPT" - S DARRAY("WV(790.404,")="WH" - S DARRAY("WV(790.1,")="WHR" - ; - S DARRAY("PXD(811.2,")="T" - ; - ;Get the dialog element - S OCNT=0 - N TERMNODE,TERMSTAT,TERMOUT - S DTYP=$P($G(^PXRMD(801.41,DITEM,0)),U,4) - ;Finding detail - S DRES=$P($G(^PXRMD(801.41,DITEM,1)),U,3) - S DFIND=$P($G(^PXRMD(801.41,DITEM,1)),U,5) - ;check for WH finding - I $P($G(^PXRMD(801.41,DITEM,0)),U,16)["WHR" S DFIND=$G(WHFIND) - ; - S DFIEN=$P(DFIND,";"),DFTYP=$P(DFIND,";",2) - S DPCE="",DVIT="" I DFTYP'="" S DPCE=$G(DARRAY(DFTYP)) - ;Exclude from P/N - S DEXC=$P($G(^PXRMD(801.41,DITEM,2)),U,3) - ; - ;Non taxonomy codes (3 - finding record) - I DPCE'="T" D FREC(DFIEN,DFTYP) - ; - ;Taxonomy codes need expanding (3 - finding record) - I DPCE="T" D EXP^PXRMDLLB(DFIEN,DCUR,DTTYP) - ; - ;Prompt details (4 - prompt records) - N ARRAY,DTITLE,DREQ,DSEQ,DSSEQ,DSUB,DTYP - ;If not a taxonomy get prompts from dialog file - I DPCE'="T" D PROTH(DITEM) - ;Check for MST findings - I (DPCE'="T"),(DFTYP]"") D MST^PXRMDLLB(DFTYP,DFIEN) - ;If taxonomy use finding parameters (CPT/POV) - I DPCE="T" D - .;Quit if finding type not passed - .Q:DTTYP="" - .N RSUB,FNODE - .;Get parameter file node for this finding type - .S FNODE=$O(^PXRMD(801.45,"B",DTTYP,"")) Q:FNODE="" - .;Derive resolution from line ien 1=done 2=done elsewhere - .S RSUB=DCUR+1 I (RSUB<1)!(RSUB>2) Q - .;Get details from 811.5 - .D PRTAX(FNODE,RSUB) - ;Return array of type 4 records - S DSEQ="" - F S DSEQ=$O(ARRAY(DSEQ)) Q:'DSEQ D - .S OCNT=OCNT+1 - .S ORY(OCNT)=4_U_DITEM_U_DSEQ_U_ARRAY(DSEQ) - .S DSSEQ="" - .F S DSSEQ=$O(ARRAY(DSEQ,DSSEQ)) Q:'DSSEQ D - ..S OCNT=OCNT+1 - ..S ORY(OCNT)=4_U_DITEM_U_DSEQ_"."_DSSEQ_U_ARRAY(DSEQ,DSSEQ) - ; - ;Get progress note text if defined - I DPCE'="T" D:'DEXC PTXT(DITEM) - ;Additional findings - N FASUB - S FASUB=0 - F S FASUB=$O(^PXRMD(801.41,DITEM,3,FASUB)) Q:'FASUB D - .S DFIND=$P($G(^PXRMD(801.41,DITEM,3,FASUB,0)),U) - .S DFIEN=$P(DFIND,";"),DFTYP=$P(DFIND,";",2) Q:DFTYP="" Q:DFIEN="" - .S DVIT="",DPCE=$G(DARRAY(DFTYP)) - .I DPCE'="" D FREC(DFIEN,DFTYP) - Q - ; - ; - ;Returns item name -NAME(DFIEN,DFTYP) ; - Q:DFTYP="" "" - Q:DFIEN="" "" - N NAME,FGLOB,POSN - ;DBIA #4108 - I DFTYP="WV(790.404," S NAME=$P($G(^WV(790.404,DFIEN,0)),U) Q:NAME]"" NAME - I DFTYP="WV(790.1," S NAME=$G(WHNAME) K WHNAME Q:NAME]"" NAME - S POSN=2 - S:DFTYP["AUTT" POSN=1 S:DFTYP["AUTTEDT" POSN=4 S:DFTYP["ICD" POSN=3 - S FGLOB=U_DFTYP_DFIEN_",0)",NAME=$P($G(@FGLOB),U,POSN) - I (POSN>1),NAME="" S NAME=$P($G(@FGLOB),U) - I NAME="" S NAME=DFIEN - Q NAME - ; -PROTH(IEN) ; Additional prompts defined in 801.41 - N DDATA,DDEF,DIEN,DEXC,DGUI,DNAME,DOVR,DREQ,DSEQ,DSNL,DSUB,DFTEXT - N DTXT,DTYP,PRINT - S DSEQ=0 - F S DSEQ=$O(^PXRMD(801.41,IEN,10,"B",DSEQ)) Q:'DSEQ D - .;Get prompts in sequence - .S DSUB=$O(^PXRMD(801.41,IEN,10,"B",DSEQ,"")) Q:'DSUB - .;Prompt ien - .S DIEN=$P($G(^PXRMD(801.41,IEN,10,DSUB,0)),U,2) Q:'DIEN - .;Ignore disabled components, and those that are not prompts - .Q:($P($G(^PXRMD(801.41,DIEN,0)),U,3)]"")!("PF"'[$P($G(^(0)),U,4)) - .;Set defaults to null - .S DDEF="",DEXC="",DREQ="",DSNL="" - .;Prompt name and GUI process (quit if null) - .S DNAME=$P($G(^PXRMD(801.41,DIEN,0)),U),DGUI=$$GUI(DIEN) - .I $G(DGUI)="WH_NOT_PURP" D - ..S PRINT=$$GET^XPAR($G(DUZ)_";VA(200,^SRV.`"_+$G(SRV)_"^DIV^SYS","PXRM WH PRINT NOW",1,"I") - .;Type Prompt or Forced - .S DTYP=$P($G(^PXRMD(801.41,DIEN,0)),U,4) - .I "PF"[DTYP D - ..;Required/Prompt caption - ..S DDATA=$G(^PXRMD(801.41,DIEN,2)),DTXT=$P(DDATA,U,4) - ..;Default value or forced value - ..S:DTYP="P" DDEF=$P(DDATA,U) S:DTYP="F" DDEF=$P(DDATA,U,2) - ..;Override caption/start new line/exclude PN from dialog file - ..S DDATA=$G(^PXRMD(801.41,IEN,10,DSUB,0)),DREQ=$P(DDATA,U,9) - ..S DOVR=$P(DDATA,U,6),DSNL=$P(DDATA,U,7),DEXC=$P(DDATA,U,8) - ..S DNAME=DTXT I DOVR]"" S DNAME=DOVR - ..;Convert date to fileman format - ..I DGUI="VST_DATE",DDEF["T" S DDEF=$$DT^XLFDT() - .S ARRAY(DSEQ)=DGUI_U_DEXC_U_DDEF_U_DTYP_U_DNAME_U_DSNL_U_DREQ_U_$G(DFTEXT)_U_$G(PRINT) - .;the following section add a comment prompt to the WH review of result - .;section of the reminder dialog - .I DGUI="WH_PAP_RESULT",DFTYP="WV(790.1,",DTYP="P" D - ..N WHCNT,WHFLAG,WHNUM,WHLOOP - ..S WHNUM=DSEQ+1,WHLOOP=0 - ..F WHLOOP=0 D - ...S (WHCNT,WHFLAG)=0 - ...F S WHCNT=$O(^PXRMD(801.41,IEN,10,"B",WHCNT)) Q:'WHCNT!(WHFLAG=1) D - ....I WHCNT=WHNUM S WHFLAG=1,WHNUM=WHNUM+1 - ...I WHFLAG=0 S WHLOOP=1 - ..S ARRAY(WHNUM)="COM"_U_U_U_"P"_U_"Comment:"_U_U_U - .;Additional checkboxes - .I DGUI="COM",DIEN>1 D - ..N DSSEQ,DSUB,DTEXT - ..S DSSEQ=0 - ..F S DSSEQ=$O(^PXRMD(801.41,DIEN,45,"B",DSSEQ)) Q:'DSSEQ D - ...S DSUB=$O(^PXRMD(801.41,DIEN,45,"B",DSSEQ,"")) Q:'DSUB - ...S DTEXT=$P($G(^PXRMD(801.41,DIEN,45,DSUB,0)),U,2) Q:DTEXT="" - ...S ARRAY(DSEQ,DSSEQ)=U_DEXC_U_DDEF_U_DTYP_U_DTEXT_U_DSNL_U_DREQ - Q - ; -PRTAX(FNODE,RSUB) ;Get all additional fields for this resolution type - N ACNT,ASUB - N DDATA,DDEF,DEXC,DGUI,DNAME,DREQ,DSEQ,DSUB,DTYP,PRINT - S ASUB=0,DSEQ=0 - F S ASUB=$O(^PXRMD(801.45,FNODE,1,RSUB,5,ASUB)) Q:'ASUB D - .S DDATA=$G(^PXRMD(801.45,FNODE,1,RSUB,5,ASUB,0)) Q:DDATA="" - .;Ignore if disabled - .I $P(DDATA,U,3)=1 Q - .S DSUB=$P(DDATA,U) Q:DDATA="" - .S DSEQ=DSEQ+1 - .;Set defaults to null - .S DDEF="",DEXC="",DREQ="",DSNL="" - .;Prompt name and GUI process (quit if null) - .S DNAME=$P($G(^PXRMD(801.41,DSUB,0)),U),DGUI=$$GUI(DSUB) - .I $G(DGUI)="WH_NOT_PURP" D - ..S PRINT=$$GET^XPAR($G(DUZ)_";VA(200,^SRV.`"_+$G(SRV)_"^DIV^SYS","PXRM WH PRINT NOW",1,"I") - .;Type Prompt or Forced - .S DTYP=$P($G(^PXRMD(801.41,DSUB,0)),U,4) - .I DTYP="P" D - ..S DREQ=$P(DDATA,U,2),DTXT=$P($G(^PXRMD(801.41,DSUB,2)),U,4) - ..;Override caption/start new line/exclude from PN from finding type - ..S DOVR=$P(DDATA,U,5),DSNL=$P(DDATA,U,6),DEXC=$P(DDATA,U,7) - ..S DNAME=DTXT I DOVR]"" S DNAME=DOVR - ..;Required/Prompt caption - ..S DDATA=$G(^PXRMD(801.41,DSUB,2)) - .S ARRAY(DSEQ)=DGUI_U_DEXC_U_DDEF_U_DTYP_U_DNAME_U_DSNL_U_DREQ_U_U_$G(PRINT) - Q - ; -PTXT(ITEM) ;Get progress note (WP) text for type 6 records - N ARRAY,LAST,NULL,SUB,TEXT,TXTCNT - S SUB=0 - F S SUB=$O(^PXRMD(801.41,ITEM,35,SUB)) Q:'SUB D - .S ARRAY(SUB)=$G(^PXRMD(801.41,ITEM,35,SUB,0)) - S SUB=0,LAST=0 F S SUB=$O(ARRAY(SUB)) Q:'SUB D - .S TEXT=$G(ARRAY(SUB)) - .S NULL=0 I (TEXT="")!($E(TEXT)=" ") S NULL=1 - .I LAST,'NULL S TEXT="
"_TEXT - .S TEXT=$$STRREP^PXRMUTIL(TEXT,"\\","
") - .S LAST=0 I NULL S TEXT="
"_TEXT,LAST=1 - .S OCNT=OCNT+1,ORY(OCNT)=6_U_ITEM_U_U_TEXT - Q - ; -TOK(TIEN,TYPE) ;Check if selectable codes exist - N DATA,FOUND,SUB - S FOUND=0,SUB=0 - F S SUB=$O(^PXD(811.2,TIEN,TYPE,SUB)) Q:'SUB D Q:FOUND - .S DATA=$G(^PXD(811.2,TIEN,TYPE,SUB,0)) Q:DATA="" - .;Ignore disabled codes - .I '$P(DATA,U,3) S FOUND=1 - Q FOUND +PXRMDLLA ;SLC/PJH - REMINDER DIALOG LOADER ;07/29/2004 + ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005 + ; +FREC(DFIEN,DFTYP) ;Build type 3 record + N CSARRAY,CSCNT + ;Dialog type/text and resolution + S DNAM=$$NAME(DFIEN,DFTYP) + D CODE^PXRMDLLB(DFIEN,DFTYP,.CSARRAY) + I $D(CSARRAY)>0 D Q + . S CSCNT="" F S CSCNT=$O(CSARRAY(CSCNT)) Q:CSCNT="" D + . . S OCNT=OCNT+1 + . . S ORY(OCNT)=3_U_DITEM_U_U_DPCE_U_DEXC_U_DFIEN_U_$G(CSARRAY(CSCNT))_U_DNAM_U_U_DVIT + ;Translate vitals ien to PCE code - This will need a DBIA + S DCOD="" + I DPCE="VIT" D + .S DFIEN=$$GET1^DIQ(120.51,DFIEN,7,"E") + .;Vitals Caption + .S DVIT=$P($G(^PXRMD(801.41,DITEM,2)),U,4) + I DFTYP]"" D + .S OCNT=OCNT+1 + .S ORY(OCNT)=3_U_DITEM_U_U_DPCE_U_DEXC_U_DFIEN_U_$G(DCOD)_U_DNAM_U_U_DVIT + .;Get order type for orderable items + .;DBIA #3110 + .S:DPCE="Q" $P(ORY(OCNT),U,11)=$P($G(^ORD(101.41,DFIEN,0)),U,4) + .;If mental health check if a GAF score and if MH test is required + .I DPCE="MH",DFIEN D + ..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)=$S($P($G(^PXRMD(801.41,DITEM,0)),U,18)=1:1,1:0) + Q + ; +GUI(IEN) ;Work out prompt type for PCE + Q:IEN="" "" + N SUB S SUB=$P($G(^PXRMD(801.41,IEN,46)),U) + Q:'SUB "" + Q $P($G(^PXRMD(801.42,SUB,0)),U) + ; +LOAD(DITEM,DCUR,DTTYP) ;Load dialog questions into array + N DARRAY,DCOD,DEXC,DFIND,DFIEN,DFTYP,DNAM,DPCE,DRES,DSEQ,DSUB,DTYP,OCNT + N DVIT,NODE,CNT,IDENT + ;DBIA #3110 OR(101.41 + ; + ;Build list of PCE codes + S DARRAY("AUTTEDT(")="PED" + S DARRAY("AUTTEXAM(")="XAM" + S DARRAY("AUTTHF(")="HF" + S DARRAY("AUTTIMM(")="IMM" + S DARRAY("AUTTSK(")="SK" + ; + S DARRAY("GMRD(120.51,")="VIT" + S DARRAY("ORD(101.41,")="Q" + S DARRAY("YTT(601,")="MH" + ; + S DARRAY("ICD9(")="POV" + S DARRAY("ICPT(")="CPT" + S DARRAY("WV(790.404,")="WH" + S DARRAY("WV(790.1,")="WHR" + ; + S DARRAY("PXD(811.2,")="T" + ; + ;Get the dialog element + S OCNT=0 + N TERMNODE,TERMSTAT,TERMOUT + S DTYP=$P($G(^PXRMD(801.41,DITEM,0)),U,4) + ;Finding detail + S DRES=$P($G(^PXRMD(801.41,DITEM,1)),U,3) + S DFIND=$P($G(^PXRMD(801.41,DITEM,1)),U,5) + ;check for WH finding + I $P($G(^PXRMD(801.41,DITEM,0)),U,16)["WHR" S DFIND=$G(WHFIND) + ; + S DFIEN=$P(DFIND,";"),DFTYP=$P(DFIND,";",2) + S DPCE="",DVIT="" I DFTYP'="" S DPCE=$G(DARRAY(DFTYP)) + ;Exclude from P/N + S DEXC=$P($G(^PXRMD(801.41,DITEM,2)),U,3) + ; + ;Non taxonomy codes (3 - finding record) + I DPCE'="T" D FREC(DFIEN,DFTYP) + ; + ;Taxonomy codes need expanding (3 - finding record) + I DPCE="T" D EXP^PXRMDLLB(DFIEN,DCUR,DTTYP) + ; + ;Prompt details (4 - prompt records) + N ARRAY,DTITLE,DREQ,DSEQ,DSSEQ,DSUB,DTYP + ;If not a taxonomy get prompts from dialog file + I DPCE'="T" D PROTH(DITEM) + ;Check for MST findings + I (DPCE'="T"),(DFTYP]"") D MST^PXRMDLLB(DFTYP,DFIEN) + ;If taxonomy use finding parameters (CPT/POV) + I DPCE="T" D + .;Quit if finding type not passed + .Q:DTTYP="" + .N RSUB,FNODE + .;Get parameter file node for this finding type + .S FNODE=$O(^PXRMD(801.45,"B",DTTYP,"")) Q:FNODE="" + .;Derive resolution from line ien 1=done 2=done elsewhere + .S RSUB=DCUR+1 I (RSUB<1)!(RSUB>2) Q + .;Get details from 811.5 + .D PRTAX(FNODE,RSUB) + ;Return array of type 4 records + S DSEQ="" + F S DSEQ=$O(ARRAY(DSEQ)) Q:'DSEQ D + .S OCNT=OCNT+1 + .S ORY(OCNT)=4_U_DITEM_U_DSEQ_U_ARRAY(DSEQ) + .S DSSEQ="" + .F S DSSEQ=$O(ARRAY(DSEQ,DSSEQ)) Q:'DSSEQ D + ..S OCNT=OCNT+1 + ..S ORY(OCNT)=4_U_DITEM_U_DSEQ_"."_DSSEQ_U_ARRAY(DSEQ,DSSEQ) + ; + ;Get progress note text if defined + I DPCE'="T" D:'DEXC PTXT(DITEM) + ;Additional findings + N FASUB + S FASUB=0 + F S FASUB=$O(^PXRMD(801.41,DITEM,3,FASUB)) Q:'FASUB D + .S DFIND=$P($G(^PXRMD(801.41,DITEM,3,FASUB,0)),U) + .S DFIEN=$P(DFIND,";"),DFTYP=$P(DFIND,";",2) Q:DFTYP="" Q:DFIEN="" + .S DVIT="",DPCE=$G(DARRAY(DFTYP)) + .I DPCE'="" D FREC(DFIEN,DFTYP) + Q + ; + ; + ;Returns item name +NAME(DFIEN,DFTYP) ; + Q:DFTYP="" "" + Q:DFIEN="" "" + N NAME,FGLOB,POSN + ;DBIA #4108 + I DFTYP="WV(790.404," S NAME=$P($G(^WV(790.404,DFIEN,0)),U) Q:NAME]"" NAME + I DFTYP="WV(790.1," S NAME=$G(WHNAME) K WHNAME Q:NAME]"" NAME + S POSN=2 + S:DFTYP["AUTT" POSN=1 S:DFTYP["AUTTEDT" POSN=4 S:DFTYP["ICD" POSN=3 + S FGLOB=U_DFTYP_DFIEN_",0)",NAME=$P($G(@FGLOB),U,POSN) + I (POSN>1),NAME="" S NAME=$P($G(@FGLOB),U) + I NAME="" S NAME=DFIEN + Q NAME + ; +PROTH(IEN) ; Additional prompts defined in 801.41 + N DDATA,DDEF,DIEN,DEXC,DGUI,DNAME,DOVR,DREQ,DSEQ,DSNL,DSUB,DFTEXT + N DTXT,DTYP,PRINT + S DSEQ=0 + F S DSEQ=$O(^PXRMD(801.41,IEN,10,"B",DSEQ)) Q:'DSEQ D + .;Get prompts in sequence + .S DSUB=$O(^PXRMD(801.41,IEN,10,"B",DSEQ,"")) Q:'DSUB + .;Prompt ien + .S DIEN=$P($G(^PXRMD(801.41,IEN,10,DSUB,0)),U,2) Q:'DIEN + .;Ignore disabled components, and those that are not prompts + .Q:($P($G(^PXRMD(801.41,DIEN,0)),U,3)]"")!("PF"'[$P($G(^(0)),U,4)) + .;Set defaults to null + .S DDEF="",DEXC="",DREQ="",DSNL="" + .;Prompt name and GUI process (quit if null) + .S DNAME=$P($G(^PXRMD(801.41,DIEN,0)),U),DGUI=$$GUI(DIEN) + .I $G(DGUI)="WH_NOT_PURP" D + ..S PRINT=$$GET^XPAR($G(DUZ)_";VA(200,^SRV.`"_+$G(SRV)_"^DIV^SYS","PXRM WH PRINT NOW",1,"I") + .;Type Prompt or Forced + .S DTYP=$P($G(^PXRMD(801.41,DIEN,0)),U,4) + .I "PF"[DTYP D + ..;Required/Prompt caption + ..S DDATA=$G(^PXRMD(801.41,DIEN,2)),DTXT=$P(DDATA,U,4) + ..;Default value or forced value + ..S:DTYP="P" DDEF=$P(DDATA,U) S:DTYP="F" DDEF=$P(DDATA,U,2) + ..;Override caption/start new line/exclude PN from dialog file + ..S DDATA=$G(^PXRMD(801.41,IEN,10,DSUB,0)),DREQ=$P(DDATA,U,9) + ..S DOVR=$P(DDATA,U,6),DSNL=$P(DDATA,U,7),DEXC=$P(DDATA,U,8) + ..S DNAME=DTXT I DOVR]"" S DNAME=DOVR + ..;Convert date to fileman format + ..I DGUI="VST_DATE",DDEF["T" S DDEF=$$DT^XLFDT() + .S ARRAY(DSEQ)=DGUI_U_DEXC_U_DDEF_U_DTYP_U_DNAME_U_DSNL_U_DREQ_U_$G(DFTEXT)_U_$G(PRINT) + .;the following section add a comment prompt to the WH review of result + .;section of the reminder dialog + .I DGUI="WH_PAP_RESULT",DFTYP="WV(790.1,",DTYP="P" D + ..N WHCNT,WHFLAG,WHNUM,WHLOOP + ..S WHNUM=DSEQ+1,WHLOOP=0 + ..F WHLOOP=0 D + ...S (WHCNT,WHFLAG)=0 + ...F S WHCNT=$O(^PXRMD(801.41,IEN,10,"B",WHCNT)) Q:'WHCNT!(WHFLAG=1) D + ....I WHCNT=WHNUM S WHFLAG=1,WHNUM=WHNUM+1 + ...I WHFLAG=0 S WHLOOP=1 + ..S ARRAY(WHNUM)="COM"_U_U_U_"P"_U_"Comment:"_U_U_U + .;Additional checkboxes + .I DGUI="COM",DIEN>1 D + ..N DSSEQ,DSUB,DTEXT + ..S DSSEQ=0 + ..F S DSSEQ=$O(^PXRMD(801.41,DIEN,45,"B",DSSEQ)) Q:'DSSEQ D + ...S DSUB=$O(^PXRMD(801.41,DIEN,45,"B",DSSEQ,"")) Q:'DSUB + ...S DTEXT=$P($G(^PXRMD(801.41,DIEN,45,DSUB,0)),U,2) Q:DTEXT="" + ...S ARRAY(DSEQ,DSSEQ)=U_DEXC_U_DDEF_U_DTYP_U_DTEXT_U_DSNL_U_DREQ + Q + ; +PRTAX(FNODE,RSUB) ;Get all additional fields for this resolution type + N ACNT,ASUB + N DDATA,DDEF,DEXC,DGUI,DNAME,DREQ,DSEQ,DSUB,DTYP,PRINT + S ASUB=0,DSEQ=0 + F S ASUB=$O(^PXRMD(801.45,FNODE,1,RSUB,5,ASUB)) Q:'ASUB D + .S DDATA=$G(^PXRMD(801.45,FNODE,1,RSUB,5,ASUB,0)) Q:DDATA="" + .;Ignore if disabled + .I $P(DDATA,U,3)=1 Q + .S DSUB=$P(DDATA,U) Q:DDATA="" + .S DSEQ=DSEQ+1 + .;Set defaults to null + .S DDEF="",DEXC="",DREQ="",DSNL="" + .;Prompt name and GUI process (quit if null) + .S DNAME=$P($G(^PXRMD(801.41,DSUB,0)),U),DGUI=$$GUI(DSUB) + .I $G(DGUI)="WH_NOT_PURP" D + ..S PRINT=$$GET^XPAR($G(DUZ)_";VA(200,^SRV.`"_+$G(SRV)_"^DIV^SYS","PXRM WH PRINT NOW",1,"I") + .;Type Prompt or Forced + .S DTYP=$P($G(^PXRMD(801.41,DSUB,0)),U,4) + .I DTYP="P" D + ..S DREQ=$P(DDATA,U,2),DTXT=$P($G(^PXRMD(801.41,DSUB,2)),U,4) + ..;Override caption/start new line/exclude from PN from finding type + ..S DOVR=$P(DDATA,U,5),DSNL=$P(DDATA,U,6),DEXC=$P(DDATA,U,7) + ..S DNAME=DTXT I DOVR]"" S DNAME=DOVR + ..;Required/Prompt caption + ..S DDATA=$G(^PXRMD(801.41,DSUB,2)) + .S ARRAY(DSEQ)=DGUI_U_DEXC_U_DDEF_U_DTYP_U_DNAME_U_DSNL_U_DREQ_U_U_$G(PRINT) + Q + ; +PTXT(ITEM) ;Get progress note (WP) text for type 6 records + N ARRAY,LAST,NULL,SUB,TEXT,TXTCNT + S SUB=0 + F S SUB=$O(^PXRMD(801.41,ITEM,35,SUB)) Q:'SUB D + .S ARRAY(SUB)=$G(^PXRMD(801.41,ITEM,35,SUB,0)) + S SUB=0,LAST=0 F S SUB=$O(ARRAY(SUB)) Q:'SUB D + .S TEXT=$G(ARRAY(SUB)) + .S NULL=0 I (TEXT="")!($E(TEXT)=" ") S NULL=1 + .I LAST,'NULL S TEXT="
"_TEXT + .S TEXT=$$STRREP^PXRMUTIL(TEXT,"\\","
") + .S LAST=0 I NULL S TEXT="
"_TEXT,LAST=1 + .S OCNT=OCNT+1,ORY(OCNT)=6_U_ITEM_U_U_TEXT + Q + ; +TOK(TIEN,TYPE) ;Check if selectable codes exist + N DATA,FOUND,SUB + S FOUND=0,SUB=0 + F S SUB=$O(^PXD(811.2,TIEN,TYPE,SUB)) Q:'SUB D Q:FOUND + .S DATA=$G(^PXD(811.2,TIEN,TYPE,SUB,0)) Q:DATA="" + .;Ignore disabled codes + .I '$P(DATA,U,3) S FOUND=1 + Q FOUND diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMDLLB.m b/r/CLINICAL_REMINDERS-PXRM/PXRMDLLB.m index f2df2681..65df1e5a 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMDLLB.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMDLLB.m @@ -1,168 +1,156 @@ -PXRMDLLB ;SLC/PJH - REMINDER DIALOG LOADER ;05/01/2007 - ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123 - ; -CODE(DFIEN,DFTYP,ARRAY) ; - N ARY,CNT,CNT1 - I DFTYP["ICD9" S CODE=$P($G(^ICD9(DFIEN,0)),U) D PERIOD^ICDAPIU(CODE,.ARY) - I DFTYP["ICPT" S CODE=$P($$CPT^ICPTCOD(DFIEN),U,2) D PERIOD^ICPTAPIU(CODE,.ARY) - I $D(ARY)'>0 Q - I $P($G(ARY(0)),U,2)'>0 Q - S (CNT,CNT1)=0 - F S CNT=$O(ARY(CNT)) Q:CNT="" D - . S ARRAY(CNT1)=CODE_":"_CNT_":"_$P($G(ARY(CNT)),U) - . S CNT1=CNT1+1 - Q - ; -CODES(FILE,TXIEN,ARRAY) ;Return selectable codes from taxonomy file - N CNT,CODE,CSCNT,DATA,DATES,DISPLAY,IEN,INSTALL,TEMP,TEXT,NODE,SUB - S SUB=0,CNT=0,NODE=$S(FILE=80:"SDX",FILE=81:"SPR") - F S SUB=$O(^PXD(811.2,TXIEN,NODE,SUB)) Q:'SUB D - .S DATA=$G(^PXD(811.2,TXIEN,NODE,SUB,0)) Q:DATA="" - .;Ignore if disabled - .S DISPLAY="" - .I $P(DATA,U,3)=1 Q - .;Get ien of code - .S IEN=$P(DATA,U) Q:IEN="" - .;get date ranges and text from period api - .K ARY - .I FILE=80 S CODE=$P($G(^ICD9(IEN,0)),U) - .I FILE=81 S CODE=$P($$CPT^ICPTCOD(IEN),U,2) - .S DISPLAY=$P($G(DATA),U,2) - .S TEMP=$$CODE^PXRMVAL(CODE,FILE) Q:'$P(TEMP,U) Q:$P(TEMP,U,9)=1 - .;Set display text from taxonomy selectable code text - .S TEXT=$P(DATA,U,2) - .;otherwise use icd9/cpt description - .I TEXT="",FILE=80 S TEXT=$P($$ICDDX^ICDCODE(IEN),U,3) - .I TEXT="",FILE=81 S TEXT=$P($$CPT^ICPTCOD(IEN),U,3) - .I FILE=80 D PERIOD^ICDAPIU(CODE,.ARY) - .I FILE=81 D PERIOD^ICPTAPIU(CODE,.ARY) - .I $D(ARY)'>0 Q - .I $P($G(ARY(0)),U,2)'>0 Q - .S CSCNT=0 F S CSCNT=$O(ARY(CSCNT)) Q:CSCNT="" D - ..S DATES=":"_CSCNT_":"_$P($G(ARY(CSCNT)),U) - ..S TEXT=$P($G(ARY(CSCNT)),U,2) I $G(DISPLAY)'="" S TEXT=DISPLAY - ..S CNT=CNT+1,ARRAY(CNT)=IEN_U_$G(CODE)_$G(DATES)_U_$G(TEXT) - Q - ; -EXP(TIEN,DCUR,DTTYP) ;Expand taxonomy codes - N CODES,CNT,FILE,LIT,CAT - S FILE=$S(DTTYP="POV":80,DTTYP="CPT":81,1:"") Q:'FILE - S LIT="Selectable "_$S(FILE=80:"Diagnoses:",1:"Procedures:") - S CAT=$P($G(^PXD(811.2,TIEN,0)),U) - ; - S OCNT=OCNT+1 - S ORY(OCNT)=3_U_DITEM_U_U_DTTYP_U_U_U_U_U_CAT_U_LIT - ;Get selectable codes - D CODES(FILE,TIEN,.CODES) - S CNT=0 - ;Save selectable codes as type 5 records - F S CNT=$O(CODES(CNT)) Q:'CNT D - .S OCNT=OCNT+1,ORY(OCNT)=5_U_DITEM_U_U_DTTYP_U_U_CODES(CNT) - Q - ; - ;Pass MST code as a forced value -MST(DFTYP,DFIEN) ; - ;Validate finding ien - Q:DFIEN="" - ;For each MST term check if finding is mapped - N FOUND,TCOND,TIEN,TNAM,TSUB - S FOUND=0 - F TNAM="POSITIVE","NEGATIVE","DECLINES" D Q:FOUND - .;Get term IEN - .S TIEN=$O(^PXRMD(811.5,"B","MST "_TNAM_" REPORT","")) Q:'TIEN - .;Check if finding is mapped to term - .Q:'$D(^PXRMD(811.5,TIEN,20,"E",DFTYP,DFIEN)) - .;If exam and term condition logic is null ignore - .I DFTYP="AUTTEXAM(" D Q:TCOND="" - ..S TCOND="",TSUB=$O(^PXRMD(811.5,TIEN,20,"E",DFTYP,DFIEN,"")) Q:'TSUB - ..S TCOND=$P($G(^PXRMD(811.5,TIEN,20,TSUB,3)),U) - .;If it is then create additional prompt for MST - .N DSEQ,DEXC,DDEF,DGUI,DTYP,DTEXT,DSNL,DREQ - .;Add to end of array - .S DSEQ=$O(ARRAY(""),-1)+1 - .;Null fields - .S DDEF="",DEXC="",DTEXT="",DSNL="",DREQ="" - .;MST status (exept for exams) - .I DFTYP'="AUTTEXAM(" S DDEF=$$STCODE^PXRMMST("MST "_TNAM_" REPORT") - .;GUI process and forced value - .S DGUI="MST",DTYP="F" - .;Save in array - .S ARRAY(DSEQ)=DGUI_U_DEXC_U_DDEF_U_DTYP_U_DTEXT_U_DSNL_U_DREQ - .;Quit after the first term is found - .S FOUND=1 - Q - ; -REPLACE(DFN,TERMNODE,DITEM,DATA,TERMSTAT) ; - ;this section is use to compare the term evalution result against - ;the value store in the Reminder Term Status field. - ;If the value match and the replacement item is active then the orginal - ;item will be replace with the new item. - N TERMOUT - S TERMSTAT=1 I +$P(TERMNODE,U),$P($G(TERMNODE),U,2)'="" D Q:+TERMSTAT=0 - .N DITEMO - .S TERMOUT=$$TERM($P(TERMNODE,U),DFN,$G(DITEM)) - .I TERMOUT'=$P(TERMNODE,U,2) Q - .I +$P(TERMNODE,U,3)'>0 S TERMSTAT=0 Q - .S DITEMO=DITEM,DITEM=$P(TERMNODE,U,3),DATA=$G(^PXRMD(801.41,DITEM,0)) - .I $G(DATA)=""!($P(DATA,U,3)]"") S DITEM=DITEMO Q - 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 - N ARRAY,CNT,NODE,RESULT,TERMARR - N DATEORDR,ESUB,FINDPA,FIEVAL,TFIEVAL,NOCC,BDT,EDT,SDIR,SUB,WVIEN - S (TERMARR,TFIEVAL,DATEORDR,FIEVAL)="" - ;build term array - D TERM^PXRMLDR(TERMIEN,.TERMARR) - ;term evaulation - D IEVALTER^PXRMTERM(DFN,.TERMARR,.TERMARR,1,.FIEVAL) - S RESULT=$G(FIEVAL(1)) - ;if the item is one of the WH review reminders build finding item and - ;text from the the WVALERTS API in PXRMCWH - I RESULT=1,$P($G(^PXRMD(801.41,IEN,0)),U,16)["WHR" D - .N IDENT - .S IDENT=$P($G(^PXRMD(801.41,IEN,0)),U,16) - .I $G(FIEVAL(1,"LINK"))=1,$G(FIEVAL(1,"STATUS"))="OPEN",$G(FIEVAL(1,"VALUE"))="Pending" D - ..S WVIEN=$G(FIEVAL(1,"WVIEN")) - ..;DBIA #4102 - ..D RESULTS^WVALERTS(.ARRAY,WVIEN) D - ...K WHFIND,WHNAME - ...S NODE=$G(ARRAY(0)) I +$P(NODE,U)'>0 Q - ...S WHFIND=WVIEN_";WV(790.1,",WHNAME=$P($G(NODE),U,3) - ...S (ESUB,SUB)=0 F S SUB=$O(DTXT(SUB)) Q:SUB'>0 S ESUB=SUB - ...S ESUB=ESUB+1 - ...I IDENT="WHRP" D - ....N MOD - ....S DATE="" - ....S DTXT(ESUB)=$P($G(NODE),U,3),ESUB=ESUB+1 - ....S DATE=$P($G(NODE),U,4),STR=$$RJ^XLFSTR("Collected: ",20) - ....S STR=STR_$P($G(NODE),U,8) - ....S DTXT(ESUB)=STR,ESUB=ESUB+1 - ....S STR=$$RJ^XLFSTR("Lab Accession #: ",20),STR=STR_$P($G(NODE),U,9) - ....S DTXT(ESUB)=STR,ESUB=ESUB+1 - ....S STR=$$RJ^XLFSTR("Specimen: ",20),STR=STR_$P($G(NODE),U,10) - ....S DTXT(ESUB)=STR - ...I IDENT="WHRM" D - ....S STR=$$RJ^XLFSTR("Procedure: ",20),STR=STR_$P($G(NODE),U,5) - ....S DTXT(ESUB)=STR,ESUB=ESUB+1 - ....S STR=$$RJ^XLFSTR("Primary Diagnosis: ",20),STR=STR_$P($G(NODE),U,6) - ....S DTXT(ESUB)=STR,ESUB=ESUB+1 - ....S STR=$$RJ^XLFSTR("Modifiers: ",20),MOD=$P($G(NODE),U,7) - ....I $G(MOD)="" S STR=STR_"" - ....E S STR=STR_$P($G(MOD),"~",1) - ....S DTXT(ESUB)=STR,ESUB=ESUB+1 - ....I $P($G(MOD),"~",2)'="" S DTXT(ESUB)=$$LJ^XLFSTR($P(MOD,"~",2),23) - Q +RESULT - ; +PXRMDLLB ;SLC/PJH - REMINDER DIALOG LOADER ;07/29/2004 + ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005 + ; +CODE(DFIEN,DFTYP,ARRAY) ; + N ARY,CNT,CNT1 + I DFTYP["ICD9" S CODE=$P($G(^ICD9(DFIEN,0)),U) D PERIOD^ICDAPIU(CODE,.ARY) + I DFTYP["ICPT" S CODE=$P($$CPT^ICPTCOD(DFIEN),U,2) D PERIOD^ICPTAPIU(CODE,.ARY) + I $D(ARY)'>0 Q + I $P($G(ARY(0)),U,2)'>0 Q + S (CNT,CNT1)=0 + F S CNT=$O(ARY(CNT)) Q:CNT="" D + . S ARRAY(CNT1)=CODE_":"_CNT_":"_$P($G(ARY(CNT)),U) + . S CNT1=CNT1+1 + Q + ; +CODES(FILE,TXIEN,ARRAY) ;Return selectable codes from taxonomy file + N CNT,CODE,CSCNT,DATA,DATES,DISPLAY,IEN,INSTALL,TEMP,TEXT,NODE,SUB + S SUB=0,CNT=0,NODE=$S(FILE=80:"SDX",FILE=81:"SPR") + F S SUB=$O(^PXD(811.2,TXIEN,NODE,SUB)) Q:'SUB D + .S DATA=$G(^PXD(811.2,TXIEN,NODE,SUB,0)) Q:DATA="" + .;Ignore if disabled + .S DISPLAY="" + .I $P(DATA,U,3)=1 Q + .;Get ien of code + .S IEN=$P(DATA,U) Q:IEN="" + .;get date ranges and text from period api + .K ARY + .I FILE=80 S CODE=$P($G(^ICD9(IEN,0)),U) + .I FILE=81 S CODE=$P($$CPT^ICPTCOD(IEN),U,2) + .S DISPLAY=$P($G(DATA),U,2) + .S TEMP=$$CODE^PXRMVAL(CODE,FILE) Q:'$P(TEMP,U) Q:$P(TEMP,U,9)=1 + .;Set display text from taxonomy selectable code text + .S TEXT=$P(DATA,U,2) + .;otherwise use icd9/cpt description + .I TEXT="",FILE=80 S TEXT=$P($$ICDDX^ICDCODE(IEN),U,3) + .I TEXT="",FILE=81 S TEXT=$P($$CPT^ICPTCOD(IEN),U,3) + .I FILE=80 D PERIOD^ICDAPIU(CODE,.ARY) + .I FILE=81 D PERIOD^ICPTAPIU(CODE,.ARY) + .I $D(ARY)'>0 Q + .I $P($G(ARY(0)),U,2)'>0 Q + .S CSCNT=0 F S CSCNT=$O(ARY(CSCNT)) Q:CSCNT="" D + ..S DATES=":"_CSCNT_":"_$P($G(ARY(CSCNT)),U) + ..S TEXT=$P($G(ARY(CSCNT)),U,2) I $G(DISPLAY)'="" S TEXT=DISPLAY + ..S CNT=CNT+1,ARRAY(CNT)=IEN_U_$G(CODE)_$G(DATES)_U_$G(TEXT) + Q + ; +EXP(TIEN,DCUR,DTTYP) ;Expand taxonomy codes + N CODES,CNT,FILE,LIT,CAT + S FILE=$S(DTTYP="POV":80,DTTYP="CPT":81,1:"") Q:'FILE + S LIT="Selectable "_$S(FILE=80:"Diagnoses:",1:"Procedures:") + S CAT=$P($G(^PXD(811.2,TIEN,0)),U) + ; + S OCNT=OCNT+1 + S ORY(OCNT)=3_U_DITEM_U_U_DTTYP_U_U_U_U_U_CAT_U_LIT + ;Get selectable codes + D CODES(FILE,TIEN,.CODES) + S CNT=0 + ;Save selectable codes as type 5 records + F S CNT=$O(CODES(CNT)) Q:'CNT D + .S OCNT=OCNT+1,ORY(OCNT)=5_U_DITEM_U_U_DTTYP_U_U_CODES(CNT) + Q + ; + ;Pass MST code as a forced value +MST(DFTYP,DFIEN) ; + ;Validate finding ien + Q:DFIEN="" + ;For each MST term check if finding is mapped + N FOUND,TCOND,TIEN,TNAM,TSUB + S FOUND=0 + F TNAM="POSITIVE","NEGATIVE","DECLINES" D Q:FOUND + .;Get term IEN + .S TIEN=$O(^PXRMD(811.5,"B","MST "_TNAM_" REPORT","")) Q:'TIEN + .;Check if finding is mapped to term + .Q:'$D(^PXRMD(811.5,TIEN,20,"E",DFTYP,DFIEN)) + .;If exam and term condition logic is null ignore + .I DFTYP="AUTTEXAM(" D Q:TCOND="" + ..S TCOND="",TSUB=$O(^PXRMD(811.5,TIEN,20,"E",DFTYP,DFIEN,"")) Q:'TSUB + ..S TCOND=$P($G(^PXRMD(811.5,TIEN,20,TSUB,3)),U) + .;If it is then create additional prompt for MST + .N DSEQ,DEXC,DDEF,DGUI,DTYP,DTEXT,DSNL,DREQ + .;Add to end of array + .S DSEQ=$O(ARRAY(""),-1)+1 + .;Null fields + .S DDEF="",DEXC="",DTEXT="",DSNL="",DREQ="" + .;MST status (exept for exams) + .I DFTYP'="AUTTEXAM(" S DDEF=$$STCODE^PXRMMST("MST "_TNAM_" REPORT") + .;GUI process and forced value + .S DGUI="MST",DTYP="F" + .;Save in array + .S ARRAY(DSEQ)=DGUI_U_DEXC_U_DDEF_U_DTYP_U_DTEXT_U_DSNL_U_DREQ + .;Quit after the first term is found + .S FOUND=1 + Q + ; +REPLACE(DFN,TERMNODE,DITEM,DATA,TERMSTAT) ; + ;this section is use to compare the term evalution result against + ;the value store in the Reminder Term Status field. + ;If the value match and the replacement item is active then the orginal + ;item will be replace with the new item. + N TERMOUT + S TERMSTAT=1 I +$P(TERMNODE,U),$P($G(TERMNODE),U,2)'="" D Q:+TERMSTAT=0 + .N DITEMO + .S TERMOUT=$$TERM($P(TERMNODE,U),DFN,$G(DITEM)) + .I TERMOUT'=$P(TERMNODE,U,2) Q + .I +$P(TERMNODE,U,3)'>0 S TERMSTAT=0 Q + .S DITEMO=DITEM,DITEM=$P(TERMNODE,U,3),DATA=$G(^PXRMD(801.41,DITEM,0)) + .I $G(DATA)=""!($P(DATA,U,3)]"") S DITEM=DITEMO Q + Q + ; +TERM(TERMIEN,DFN,IEN) ; + ;this section is use to for the term evaluation + N ARRAY,CNT,NODE,RESULT,TERMARR + N DATEORDR,ESUB,FINDPA,FIEVAL,TFIEVAL,NOCC,BDT,EDT,SDIR,SUB,WVIEN + S (TERMARR,TFIEVAL,DATEORDR,FIEVAL)="" + ;build term array + D TERM^PXRMLDR(TERMIEN,.TERMARR) + ;term evaulation + D IEVALTER^PXRMTERM(DFN,.TERMARR,.TERMARR,1,.FIEVAL) + S RESULT=$G(FIEVAL(1)) + ;if the item is one of the WH review reminders build finding item and + ;text from the the WVALERTS API in PXRMCWH + I RESULT=1,$P($G(^PXRMD(801.41,IEN,0)),U,16)["WHR" D + .N IDENT + .S IDENT=$P($G(^PXRMD(801.41,IEN,0)),U,16) + .I $G(FIEVAL(1,"LINK"))=1,$G(FIEVAL(1,"STATUS"))="OPEN",$G(FIEVAL(1,"VALUE"))="Pending" D + ..S WVIEN=$G(FIEVAL(1,"WVIEN")) + ..;DBIA #4102 + ..D RESULTS^WVALERTS(.ARRAY,WVIEN) D + ...K WHFIND,WHNAME + ...S NODE=$G(ARRAY(0)) I +$P(NODE,U)'>0 Q + ...S WHFIND=WVIEN_";WV(790.1,",WHNAME=$P($G(NODE),U,3) + ...S (ESUB,SUB)=0 F S SUB=$O(DTXT(SUB)) Q:SUB'>0 S ESUB=SUB + ...S ESUB=ESUB+1 + ...I IDENT="WHRP" D + ....N MOD + ....S DATE="" + ....S DTXT(ESUB)=$P($G(NODE),U,3),ESUB=ESUB+1 + ....S DATE=$P($G(NODE),U,4),STR=$$RJ^XLFSTR("Collected: ",20) + ....S STR=STR_$P($G(NODE),U,8) + ....S DTXT(ESUB)=STR,ESUB=ESUB+1 + ....S STR=$$RJ^XLFSTR("Lab Accession #: ",20),STR=STR_$P($G(NODE),U,9) + ....S DTXT(ESUB)=STR,ESUB=ESUB+1 + ....S STR=$$RJ^XLFSTR("Specimen: ",20),STR=STR_$P($G(NODE),U,10) + ....S DTXT(ESUB)=STR + ...I IDENT="WHRM" D + ....S STR=$$RJ^XLFSTR("Procedure: ",20),STR=STR_$P($G(NODE),U,5) + ....S DTXT(ESUB)=STR,ESUB=ESUB+1 + ....S STR=$$RJ^XLFSTR("Primary Diagnosis: ",20),STR=STR_$P($G(NODE),U,6) + ....S DTXT(ESUB)=STR,ESUB=ESUB+1 + ....S STR=$$RJ^XLFSTR("Modifiers: ",20),MOD=$P($G(NODE),U,7) + ....I $G(MOD)="" S STR=STR_"" + ....E S STR=STR_$P($G(MOD),"~",1) + ....S DTXT(ESUB)=STR,ESUB=ESUB+1 + ....I $P($G(MOD),"~",2)'="" S DTXT(ESUB)=$$LJ^XLFSTR($P(MOD,"~",2),23) + Q +RESULT + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMDLR.m b/r/CLINICAL_REMINDERS-PXRM/PXRMDLR.m index 62702510..7871d4b6 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMDLR.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMDLR.m @@ -1,108 +1,93 @@ -PXRMDLR ;SLC/PJH - DIALOG RESULTS LOADER ;05/15/2007 - ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123 - ; - ;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 - ; - I RESULT["~" S RESULT=$P(RESULT,"~") - S ERROR=0 - ; - ;Get score using API - K ^TMP($J,"YSCOR") - 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 - .I 'OK S ORY(1)="-1^[ERROR] no score returned",ERROR=1 Q - ; - ;Except for DOM80 - I ORES("CODE")="DOM80" D - .I $E(ORES("R1"))="Y" S SCORE=1 Q - .I $E(ORES("R1"),2,3)="YY",($E(ORES("R1"),4)>1) S SCORE=1 Q - .S SCORE=0 - ; - S DFN=$G(ORES("DFN")) - S INSERT("SCORE")=SCORE - ; - ;For AIMS special formatting is required - I ORES("CODE")="AIMS" D - .N CNT,LITS,RESP,SUM - .S LITS(0)="none",LITS(1)="minimal",LITS(2)="mild",LITS(3)="moderate" - .S LITS(4)="severe",SUM(2)=0,SUM(3)=0,SUM(4)=0 - .F CNT=1:1 S RESP=$E(ORES("R1"),CNT) Q:RESP="" D - ..S INSERT("R"_CNT)=$G(LITS(RESP)) - ..I (CNT<8),(234[RESP) S SUM(RESP)=SUM(RESP)+1 - .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 - ;Get the result elements - S DSEQ=0,OCNT=0 - F S DSEQ=$O(^PXRMD(801.41,RESULT,10,"B",DSEQ)) Q:'DSEQ D - .S DSUB=$O(^PXRMD(801.41,RESULT,10,"B",DSEQ,"")) Q:'DSUB - .S DITEM=$P($G(^PXRMD(801.41,RESULT,10,DSUB,0)),U,2) Q:'DITEM - .;Get the result element - .S DTYP=$P($G(^PXRMD(801.41,DITEM,0)),U,4) Q:DTYP'="T" - .;Get the result element condition - .S DCON=$P($G(^PXRMD(801.41,DITEM,0)),U,13) - .;Skip if condition not satisfied - .I DCON'="" S DCON=$TR(DCON,"~"," ") Q:'$$TRUE(SCORE,DCON,DFN) - .;Get progress note text if defined - .N LAST,NULL,SUB,TEXT S SUB=0,LAST=0 - .F S SUB=$O(^PXRMD(801.41,DITEM,35,SUB)) Q:'SUB D - ..;Insert score into text (if neccessary) - ..S TEXT=$G(^PXRMD(801.41,DITEM,35,SUB,0)) - ..S NULL=0 I ($E(TEXT)=" ")!(TEXT="") S NULL=1 - ..;Add line breaks if is or preceded by blank line or starts with space - ..I ('NULL),LAST S TEXT="
"_TEXT - ..S TEXT=$$STRREP^PXRMUTIL(TEXT,"\\","
") - ..S LAST=0 I NULL S TEXT="
"_TEXT,LAST=1 - ..;Check for inserts - note there may be embedded TIU markers too - ..N INS - ..S INS="" - ..F S INS=$O(INSERT(INS)) Q:INS="" D - ...S SEP="|"_INS_"|" I '$F(TEXT,SEP) Q - ...S TEXT=$P(TEXT,SEP)_$G(INSERT(INS))_$P(TEXT,SEP,2,99) - ..S OCNT=OCNT+1,ORY(OCNT)=7_U_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 - W $P($G(^PXRMD(801.41,DITEM,0)),U) - W !,$J("Element Condition: ",19) - W $TR($P($G(^PXRMD(801.41,DITEM,0)),U,13),"~"," ") - W !,$J("Element text:",17) - ;Get progress note text if defined - N SUB,TEXT S SUB=0 - F S SUB=$O(^PXRMD(801.41,DITEM,35,SUB)) Q:'SUB D - .S TEXT=$G(^PXRMD(801.41,DITEM,35,SUB,0)) W !,?5,TEXT - Q - ; -TRUE(V,COND,DFN) ; Check if value meets element condition - N RESULT,SEX - I COND["SEX" D Q RESULT - . S RESULT=0 - . S SEX=$P($G(^DPT(DFN,0)),U,2) - . X COND I S RESULT=1 - X COND I Q 1 - Q 0 +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 + I '$G(RESULT) S ORY(1)="-1^no results for this test" Q + ; + N ARRAY,ERROR,INSERT,OK,SCORE,SUB,YT + ; + S ERROR=0 + ; + ;Get score using API + S DFN=$G(ORES("DFN")) + I ORES("CODE")'="DOM80" D Q:ERROR + .M YT=ORES + .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 + ; + ;Except for DOM80 + I ORES("CODE")="DOM80" D + .I $E(ORES("R1"))="Y" S SCORE=1 Q + .I $E(ORES("R1"),2,3)="YY",($E(ORES("R1"),4)>1) S SCORE=1 Q + .S SCORE=0 + ; + S INSERT("SCORE")=SCORE + ; + ;For AIMS special formatting is required + I ORES("CODE")="AIMS" D + .N CNT,LITS,RESP,SUM + .S LITS(0)="none",LITS(1)="minimal",LITS(2)="mild",LITS(3)="moderate" + .S LITS(4)="severe",SUM(2)=0,SUM(3)=0,SUM(4)=0 + .F CNT=1:1 S RESP=$E(ORES("R1"),CNT) Q:RESP="" D + ..S INSERT("R"_CNT)=$G(LITS(RESP)) + ..I (CNT<8),(234[RESP) S SUM(RESP)=SUM(RESP)+1 + .F CNT=2,3,4 S INSERT("SUM"_CNT)=SUM(CNT) + ; + ;Load dialog results into ORY array + N DATA,DCON,DITEM,DSEQ,DSUB,DTYP,INS,SEP,TEXT + ;Get the result elements + S DSEQ=0,OCNT=0 + F S DSEQ=$O(^PXRMD(801.41,RESULT,10,"B",DSEQ)) Q:'DSEQ D + .S DSUB=$O(^PXRMD(801.41,RESULT,10,"B",DSEQ,"")) Q:'DSUB + .S DITEM=$P($G(^PXRMD(801.41,RESULT,10,DSUB,0)),U,2) Q:'DITEM + .;Get the result element + .S DTYP=$P($G(^PXRMD(801.41,DITEM,0)),U,4) Q:DTYP'="T" + .;Get the result element condition + .S DCON=$P($G(^PXRMD(801.41,DITEM,0)),U,13) + .;Skip if condition not satisfied + .I DCON'="" S DCON=$TR(DCON,"~"," ") Q:'$$TRUE(SCORE,DCON,DFN) + .;Get progress note text if defined + .N LAST,NULL,SUB,TEXT S SUB=0,LAST=0 + .F S SUB=$O(^PXRMD(801.41,DITEM,35,SUB)) Q:'SUB D + ..;Insert score into text (if neccessary) + ..S TEXT=$G(^PXRMD(801.41,DITEM,35,SUB,0)) + ..S NULL=0 I ($E(TEXT)=" ")!(TEXT="") S NULL=1 + ..;Add line breaks if is or preceded by blank line or starts with space + ..I ('NULL),LAST S TEXT="
"_TEXT + ..S TEXT=$$STRREP^PXRMUTIL(TEXT,"\\","
") + ..S LAST=0 I NULL S TEXT="
"_TEXT,LAST=1 + ..;Check for inserts - note there may be embedded TIU markers too + ..N INS + ..S INS="" + ..F S INS=$O(INSERT(INS)) Q:INS="" D + ...S SEP="|"_INS_"|" I '$F(TEXT,SEP) Q + ...S TEXT=$P(TEXT,SEP)_$G(INSERT(INS))_$P(TEXT,SEP,2,99) + ..S OCNT=OCNT+1,ORY(OCNT)=7_U_TEXT + Q + ; +OUT(DATA) ;Display element details + N DITEM S DITEM=$P(DATA,U,2) Q:'DITEM + W $P($G(^PXRMD(801.41,DITEM,0)),U) + W !,$J("Element Condition: ",19) + W $TR($P($G(^PXRMD(801.41,DITEM,0)),U,13),"~"," ") + W !,$J("Element text:",17) + ;Get progress note text if defined + N SUB,TEXT S SUB=0 + F S SUB=$O(^PXRMD(801.41,DITEM,35,SUB)) Q:'SUB D + .S TEXT=$G(^PXRMD(801.41,DITEM,35,SUB,0)) W !,?5,TEXT + Q + ; +TRUE(V,COND,DFN) ; Check if value meets element condition + N RESULT,SEX + I COND["SEX" D Q RESULT + . S RESULT=0 + . S SEX=$P($G(^DPT(DFN,0)),U,2) + . X COND I S RESULT=1 + X COND I Q 1 + Q 0 diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMDLR1.m b/r/CLINICAL_REMINDERS-PXRM/PXRMDLR1.m index 66da30fb..1fabb485 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMDLR1.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMDLR1.m @@ -1,89 +1,89 @@ -PXRMDLR1 ; SLC/AGP - DIALOG ORPHAN REPORT. ; 11/16/2007 - ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123 - ; - ;======================================================================= -START(NUM) ; - N DIR,POP,ZTDESC,ZTRTN,ZTSAVE - S %ZIS="M" - I NUM=1 S ZTDESC="Dialog Orphan Report" S ZTRTN="EN^PXRMDLR1" - I NUM=2 S ZTDESC="Empty Reminder Dialogs Report" S ZTRTN="EN1^PXRMDLR1" - S ZTSAVE("*")="" - D EN^XUTMDEVQ(ZTRTN,ZTDESC,.ZTSAVE,.%ZIS) - Q - ; -EN ; - N NAME,IEN,TYPE - K ^TMP("PXRMDLR1",$J) - S IEN=0 - S NAME="" F S NAME=$O(^PXRMD(801.41,"B",NAME)) Q:NAME="" D - . S IEN=$O(^PXRMD(801.41,"B",NAME,"")) Q:IEN'>0 - . S TYPE=$P($G(^PXRMD(801.41,IEN,0)),U,4) - . I $G(TYPE)=""!($G(TYPE)="R") Q - . I $D(^PXRMD(801.41,"AD",IEN)) Q - . S TYPE=$S(TYPE="P":"VPROMPT",TYPE="E":"ELEMENT",TYPE="F":"VVALUE",TYPE="G":"GROUP",TYPE="S":"RGROUP",TYPE="T":"RELEMENT") - . S ^TMP("PXRMDLR1",$J,TYPE,NAME)=IEN - I $D(^TMP("PXRMDLR1",$J))>0 D OUTPUT - Q - ; -EN1 ; - N DONE,FOUND,NAME,IEN,TITLE,TYPE - W @IOF - S PCNT=0,PAGE=1,DONE=0,FOUND=0 - S TITLE="Empty Reminder Dialogs Report" - D HEADER(.PCNT,PAGE,TITLE) - S IEN=0 - S NAME="" F S NAME=$O(^PXRMD(801.41,"B",NAME)) Q:NAME=""!(DONE=1) D - . S IEN=$O(^PXRMD(801.41,"B",NAME,"")) Q:IEN'>0 - . S TYPE=$P($G(^PXRMD(801.41,IEN,0)),U,4) - . I ($G(TYPE)'="R") Q - . I $D(^PXRMD(801.41,IEN,10))'=0 Q - . S FOUND=1 - . I (PCNT+1)'0 Q - . S TYPE=$S(CAT="VPROMPT":"Additional Prompts",CAT="ELEMENT":"Dialog Elements",CAT="VVALUE":"Force Values",CAT="GROUP":"Dialog Groups",CAT="RGROUP":"Result Groups",CAT="RELEMENT":"Result Elements") - . I (PCNT+4)'0 + . S TYPE=$P($G(^PXRMD(801.41,IEN,0)),U,4) + . I $G(TYPE)=""!($G(TYPE)="R") Q + . I $D(^PXRMD(801.41,"AD",IEN)) Q + . S TYPE=$S(TYPE="P":"VPROMPT",TYPE="E":"ELEMENT",TYPE="F":"VVALUE",TYPE="G":"GROUP",TYPE="S":"RGROUP",TYPE="T":"RELEMENT") + . S ^TMP("PXRMDLR1",$J,TYPE,NAME)=IEN + I $D(^TMP("PXRMDLR1",$J))>0 D OUTPUT + Q + ; +EN1 ; + N DONE,FOUND,NAME,IEN,TITLE,TYPE + W @IOF + S PCNT=0,PAGE=1,DONE=0,FOUND=0 + S TITLE="Empty Reminder Dialogs Report" + D HEADER(.PCNT,PAGE,TITLE) + S IEN=0 + S NAME="" F S NAME=$O(^PXRMD(801.41,"B",NAME)) Q:NAME=""!(DONE=1) D + . S IEN=$O(^PXRMD(801.41,"B",NAME,"")) Q:IEN'>0 + . S TYPE=$P($G(^PXRMD(801.41,IEN,0)),U,4) + . I ($G(TYPE)'="R") Q + . I $D(^PXRMD(801.41,IEN,10))'=0 Q + . S FOUND=1 + . I (PCNT+1)'0 Q + . S TYPE=$S(CAT="VPROMPT":"Additional Prompts",CAT="ELEMENT":"Dialog Elements",CAT="VVALUE":"Force Values",CAT="GROUP":"Dialog Groups",CAT="RGROUP":"Result Groups",CAT="RELEMENT":"Result Elements") + . I (PCNT+4)'DREND S DRUG=DRUGIEN - . E S DRUG=0 - .;DBIA #221 - . S POIIEN=$P($G(^PSDRUG(DRUGIEN,2)),U,1) - . I POIIEN'POIEND S POI=POIIEN - . E S POI=0 - . K FIEVT - . D DEVAL^PXRMDRUG(DFN,.FINDPA,.DEFARR,FINDING,.RXTYL,DRUG,POI,.FIEVT) - . I FIEVT D - .. 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) - ... S DATEORDR(FIEVT(IND,"DATE"),NFOUND)=FIEVT(IND,"FINDING") - ...;Don't keep more than NOCC occurrences on the list. - ... I NFOUND>NOCC D - .... S TDATE=$O(DATEORDR(""),-SDIR),TIND=$O(DATEORDR(TDATE,"")) - .... K FIEVTL(TIND),DATEORDR(TDATE,TIND) - I NFOUND=0 S FIEVAL=0 Q - ;Order by date. - S DATE="",NFOUND=0 - F S DATE=$O(DATEORDR(DATE),SDIR) Q:(DATE="")!(NFOUND=NOCC) D - . S IND=0 - . F S IND=$O(DATEORDR(DATE,IND)) Q:(IND="")!(NFOUND=NOCC) D - .. S NFOUND=NFOUND+1 - .. M FIEVAL(NFOUND)=FIEVTL(IND) - ;Save the finding result. - D SFRES^PXRMUTIL(SDIR,NFOUND,.FIEVAL) - Q - ; - ;================================================== -GETPDR(DFN,RXTYL,DRBEG,DREND,POIBEG,POIEND) ;Return the beginning drug and - ;ending drug for a patient. - N IBEG,IEND,OBEG,OEND - I $D(RXTYL("I")) D - . S IBEG=+$O(^PXRMINDX(55,"PI",DFN,0)) - . S IEND=+$O(^PXRMINDX(55,"PI",DFN,""),-1) - E S (IBEG,IEND)=0 - I $D(RXTYL("O")) D - . S OBEG=+$O(^PXRMINDX(52,"PI",DFN,0)) - . S OEND=+$O(^PXRMINDX(52,"PI",DFN,""),-1) - E S (OBEG,OEND)=0 - S DRBEG=$S(IBEGOEND:IEND,1:OEND) - I $D(RXTYL("N")) D - . S POIBEG=+$O(^PXRMINDX("55NVA","PI",DFN,0)) - . S POIEND=+$O(^PXRMINDX("55NVA","PI",DFN,""),-1) - E S (POIBEG,POIEND)=0 - Q - ; - ;================================================== -GPLIST(DRGRIEN,PFINDPA,XREF,PLIST) ; - N DATE,DFN,DRUGIEN,FILENUM,IND,ITEM,NFOUND,NOCC,POI,RXTYL - N TF,TEMP,TGLIST,TLIST - S TGLIST="GPLIST_PXRMDRGR" - K ^TMP($J,TGLIST) - ;Determine where we search. - D SRXTYL^PXRMRXTY(PFINDPA(0),.RXTYL) - S DRUGIEN=0 - F S DRUGIEN=$O(^PSDRUG(XREF,DRGRIEN,DRUGIEN)) Q:+DRUGIEN=0 D - . ;DBIA #221 - . S POI=$P($G(^PSDRUG(DRUGIEN,2)),U,1) - . I $D(RXTYL("I")) D GPLIST^PXRMINDL(55,"IP",DRUGIEN,.PFINDPA,TGLIST) - . I $D(RXTYL("N")),POI'="" D GPLIST^PXRMINDL("55NVA","IP",POI,.PFINDPA,TGLIST) - . I $D(RXTYL("O")) D GPLIST^PXRMINDL(52,"IP",DRUGIEN,.PFINDPA,TGLIST) - ;Return the NOCC most recent results for each DFN. - S NOCC=$P(FINDPA(0),U,14) - S NOCC=$S(NOCC<0:-NOCC,NOCC="":1,1:NOCC) - F TF=0,1 D - . S DFN=0 - . F S DFN=$O(^TMP($J,TGLIST,TF,DFN)) Q:DFN="" D - .. K TLIST - .. S ITEM="" - .. F S ITEM=$O(^TMP($J,TGLIST,TF,DFN,ITEM)) Q:ITEM="" D - ... S NFOUND="" - ... F S NFOUND=$O(^TMP($J,TGLIST,TF,DFN,ITEM,NFOUND)) Q:NFOUND="" D - .... S FILENUM="" - .... F S FILENUM=$O(^TMP($J,TGLIST,TF,DFN,ITEM,NFOUND,FILENUM)) Q:FILENUM="" D - ..... S TEMP=^TMP($J,TGLIST,TF,DFN,ITEM,NFOUND,FILENUM) - ..... S DATE=+$P(TEMP,U,3) - ..... S TLIST(TF,DATE,ITEM,NFOUND,FILENUM)="" - .. S DATE="",NFOUND=0 - .. F S DATE=$O(TLIST(TF,DATE),-1) Q:(DATE="")!(NFOUND=NOCC) D - ... S ITEM="" - ... F S ITEM=$O(TLIST(TF,DATE,ITEM)) Q:(ITEM="")!(NFOUND=NOCC) D - .... S IND="" - .... F S IND=$O(TLIST(TF,DATE,ITEM,IND)) Q:(IND="")!(NFOUND=NOCC) D - ..... S FILENUM="" - ..... F S FILENUM=$O(TLIST(TF,DATE,ITEM,IND,FILENUM)) Q:(FILENUM="")!(NFOUND=NOCC) D - ...... S NFOUND=NFOUND+1 - ...... S ^TMP($J,PLIST,TF,DFN,ITEM,NFOUND,FILENUM)=^TMP($J,TGLIST,TF,DFN,ITEM,IND,FILENUM) - K ^TMP($J,TGLIST) - 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 - ; +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. + ;================================================== +EVALFI(DFN,DEFARR,ENODE,XREF,FIEVAL) ;Evaluate drug group findings. + N DRGRIEN,FIEVT,FINDPA,FINDING,NOINDEX + S NOINDEX=0 + I $G(^PXRMINDX(52,"DATE BUILT"))="" D + . D NOINDEX^PXRMERRH("D",PXRMITEM,52) + . S NOINDEX=1 + I $G(^PXRMINDX(55,"DATE BUILT"))="" D + . D NOINDEX^PXRMERRH("D",PXRMITEM,55) + . S NOINDEX=1 + S DRGRIEN="" + F S DRGRIEN=$O(DEFARR("E",ENODE,DRGRIEN)) Q:+DRGRIEN=0 D + . S FINDING="" + . F S FINDING=$O(DEFARR("E",ENODE,DRGRIEN,FINDING)) Q:+FINDING=0 D + .. I NOINDEX S FIEVAL(FINDING)=0 Q + .. K FIEVT,FINDPA + .. M FINDPA=DEFARR(20,FINDING) + .. D FIEVAL(DFN,DRGRIEN,.FINDPA,.DEFARR,FINDING,XREF,.FIEVT) + .. M FIEVAL(FINDING)=FIEVT + .. S FIEVAL(FINDING,"FINDING")=$P(FINDPA(0),U,1) + Q + ; + ;================================================== +EVALPL(FINDPA,ENODE,XREF,TERMARR,PLIST) ;Evaluate drug group + ;terms for building patient lists. + N DRGRIEN,NOINDEX,PFINDPA + N TEMP,TFINDPA,TFINDING + S NOINDEX=0 + I $G(^PXRMINDX(52,"DATE BUILT"))="" D + . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),52) + . S NOINDEX=1 + I $G(^PXRMINDX(55,"DATE BUILT"))="" D + . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),55) + . S NOINDEX=1 + I NOINDEX Q + S DRGRIEN="" + F S DRGRIEN=$O(TERMARR("E",ENODE,DRGRIEN)) Q:+DRGRIEN=0 D + . S TFINDING="" + . F S TFINDING=$O(TERMARR("E",ENODE,DRGRIEN,TFINDING)) Q:+TFINDING=0 D + .. K PFINDPA,TFINDPA + .. M TFINDPA=TERMARR(20,TFINDING) + ..;Set the finding parameters. + .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA) + .. D GPLIST(DRGRIEN,.PFINDPA,XREF,.PLIST) + Q + ; + ;================================================== +EVALTERM(DFN,FINDPA,ENODE,XREF,TERMARR,TFIEVAL) ;Evaluate drug + ;group terms. + N DRGRIEN,FIEVT,NOINDEX,PFINDPA + N TEMP,TFINDPA,TFINDING + S NOINDEX=0 + I $G(^PXRMINDX(52,"DATE BUILT"))="" D + . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),52) + . S NOINDEX=1 + I $G(^PXRMINDX(55,"DATE BUILT"))="" D + . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),55) + . S NOINDEX=1 + S DRGRIEN="" + F S DRGRIEN=$O(TERMARR("E",ENODE,DRGRIEN)) Q:+DRGRIEN=0 D + . S TFINDING="" + . F S TFINDING=$O(TERMARR("E",ENODE,DRGRIEN,TFINDING)) Q:+TFINDING=0 D + .. I NOINDEX S TFIEVAL(TFINDING)=0 Q + .. K FIEVT,PFINDPA,TFINDPA + .. M TFINDPA=TERMARR(20,TFINDING) + ..;Set the finding parameters. + .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA) + .. D FIEVAL(DFN,DRGRIEN,.PFINDPA,.TERMARR,TFINDING,XREF,.FIEVT) + .. M TFIEVAL(TFINDING)=FIEVT + .. S TFIEVAL(TFINDING,"FINDING")=$P(TFINDPA(0),U,1) + Q + ; + ;================================================== +FIEVAL(DFN,DRGRIEN,FINDPA,DEFARR,FINDING,XREF,FIEVAL) ; + N DATE,DATEORDR,DRBEG,DREND,DRUG,DRUGIEN,IND,FIEVT,FIEVTL + N NOCC,NFOUND,POI,POIBEG,POIEND,POIIEN,RXTYL + N SDIR,TDATE,TIND + S NOCC=$P(FINDPA(0),U,14) + I NOCC="" S NOCC=1 + S SDIR=$S(NOCC<0:+1,1:-1) + S NOCC=$S(NOCC<0:-NOCC,1:NOCC) + ;Determine where we search. + D SRXTYL^PXRMRXTY(FINDPA(0),.RXTYL) + D GETPDR(DFN,.RXTYL,.DRBEG,.DREND,.POIBEG,.POIEND) + I DREND=0,POIEND=0 S FIEVAL=0 Q + S (DRUGIEN,NFOUND)=0 + F S DRUGIEN=+$O(^PSDRUG(XREF,DRGRIEN,DRUGIEN)) Q:DRUGIEN=0 D + . I DRUGIEN'DREND S DRUG=DRUGIEN + . E S DRUG=0 + .;DBIA #221 + . S POIIEN=$P($G(^PSDRUG(DRUGIEN,2)),U,1) + . I POIIEN'POIEND S POI=POIIEN + . E S POI=0 + . K FIEVT + . D DEVAL^PXRMDRUG(DFN,.FINDPA,.DEFARR,FINDING,.RXTYL,DRUG,POI,.FIEVT) + . I FIEVT D + .. S IND=0 + .. F S IND=+$O(FIEVT(IND)) Q:IND=0 D + ... S NFOUND=NFOUND+1,FIEVTL(NFOUND,"DISPENSE DRUG")=DRUGIEN + ... M FIEVTL(NFOUND)=FIEVT(IND) + ... S DATEORDR(FIEVT(IND,"DATE"),NFOUND)=FIEVT(IND,"FINDING") + ...;Don't keep more than NOCC occurrences on the list. + ... I NFOUND>NOCC D + .... S TDATE=$O(DATEORDR(""),-SDIR),TIND=$O(DATEORDR(TDATE,"")) + .... K FIEVTL(TIND),DATEORDR(TDATE,TIND) + I NFOUND=0 S FIEVAL=0 Q + ;Order by date. + S DATE="",NFOUND=0 + F S DATE=$O(DATEORDR(DATE),SDIR) Q:(DATE="")!(NFOUND=NOCC) D + . S IND=0 + . F S IND=$O(DATEORDR(DATE,IND)) Q:(IND="")!(NFOUND=NOCC) D + .. S NFOUND=NFOUND+1 + .. M FIEVAL(NFOUND)=FIEVTL(IND) + ;Save the finding result. + D SFRES^PXRMUTIL(SDIR,NFOUND,.FIEVAL) + Q + ; + ;================================================== +GETPDR(DFN,RXTYL,DRBEG,DREND,POIBEG,POIEND) ;Return the beginning drug and + ;ending drug for a patient. + N IBEG,IEND,OBEG,OEND + I $D(RXTYL("I")) D + . S IBEG=+$O(^PXRMINDX(55,"PI",DFN,0)) + . S IEND=+$O(^PXRMINDX(55,"PI",DFN,""),-1) + E S (IBEG,IEND)=0 + I $D(RXTYL("O")) D + . S OBEG=+$O(^PXRMINDX(52,"PI",DFN,0)) + . S OEND=+$O(^PXRMINDX(52,"PI",DFN,""),-1) + E S (OBEG,OEND)=0 + S DRBEG=$S(IBEGOEND:IEND,1:OEND) + I $D(RXTYL("N")) D + . S POIBEG=+$O(^PXRMINDX("55NVA","PI",DFN,0)) + . S POIEND=+$O(^PXRMINDX("55NVA","PI",DFN,""),-1) + E S (POIBEG,POIEND)=0 + Q + ; + ;================================================== +GPLIST(DRGRIEN,PFINDPA,XREF,PLIST) ; + N DATE,DFN,DRUGIEN,FILENUM,IND,ITEM,NFOUND,NOCC,POI,RXTYL + N TF,TEMP,TGLIST,TLIST + S TGLIST="GPLIST_PXRMDRGR" + K ^TMP($J,TGLIST) + ;Determine where we search. + D SRXTYL^PXRMRXTY(PFINDPA(0),.RXTYL) + S DRUGIEN=0 + F S DRUGIEN=$O(^PSDRUG(XREF,DRGRIEN,DRUGIEN)) Q:+DRUGIEN=0 D + . ;DBIA #221 + . S POI=$P($G(^PSDRUG(DRUGIEN,2)),U,1) + . I $D(RXTYL("I")) D GPLIST^PXRMINDL(55,"IP",DRUGIEN,.PFINDPA,TGLIST) + . I $D(RXTYL("N")),POI'="" D GPLIST^PXRMINDL("55NVA","IP",POI,.PFINDPA,TGLIST) + . I $D(RXTYL("O")) D GPLIST^PXRMINDL(52,"IP",DRUGIEN,.PFINDPA,TGLIST) + ;Return the NOCC most recent results for each DFN. + S NOCC=$P(FINDPA(0),U,14) + S NOCC=$S(NOCC<0:-NOCC,NOCC="":1,1:NOCC) + F TF=0,1 D + . S DFN=0 + . F S DFN=$O(^TMP($J,TGLIST,TF,DFN)) Q:DFN="" D + .. K TLIST + .. S ITEM="" + .. F S ITEM=$O(^TMP($J,TGLIST,TF,DFN,ITEM)) Q:ITEM="" D + ... S NFOUND="" + ... F S NFOUND=$O(^TMP($J,TGLIST,TF,DFN,ITEM,NFOUND)) Q:NFOUND="" D + .... S FILENUM="" + .... F S FILENUM=$O(^TMP($J,TGLIST,TF,DFN,ITEM,NFOUND,FILENUM)) Q:FILENUM="" D + ..... S TEMP=^TMP($J,TGLIST,TF,DFN,ITEM,NFOUND,FILENUM) + ..... S DATE=+$P(TEMP,U,3) + ..... S TLIST(TF,DATE,ITEM,NFOUND,FILENUM)="" + .. S DATE="",NFOUND=0 + .. F S DATE=$O(TLIST(TF,DATE),-1) Q:(DATE="")!(NFOUND=NOCC) D + ... S ITEM="" + ... F S ITEM=$O(TLIST(TF,DATE,ITEM)) Q:(ITEM="")!(NFOUND=NOCC) D + .... S IND="" + .... F S IND=$O(TLIST(TF,DATE,ITEM,IND)) Q:(IND="")!(NFOUND=NOCC) D + ..... S FILENUM="" + ..... F S FILENUM=$O(TLIST(TF,DATE,ITEM,IND,FILENUM)) Q:(FILENUM="")!(NFOUND=NOCC) D + ...... S NFOUND=NFOUND+1 + ...... S ^TMP($J,PLIST,TF,DFN,ITEM,NFOUND,FILENUM)=^TMP($J,TGLIST,TF,DFN,ITEM,IND,FILENUM) + K ^TMP($J,TGLIST) + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMDRUG.m b/r/CLINICAL_REMINDERS-PXRM/PXRMDRUG.m index 09e0eea0..3b8fb057 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMDRUG.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMDRUG.m @@ -1,205 +1,203 @@ -PXRMDRUG ; SLC/PKR - Handle drug findings. ;04/23/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ;=============================================== -DEVAL(DFN,FINDPA,DEFARR,FINDING,RXTYL,DRUG,POI,FIEVAL) ;Evaluate a drug - ;finding. - I DRUG=0,POI=0 S FIEVAL=0 Q - N DTERM,FIEVT - ;Create the pseudo term. - S DTERM(0)="DTERM",DTERM("IEN")=0 - I $D(RXTYL("I")),DRUG>0 D - . M DTERM(20,1)=DEFARR(20,FINDING) - . S $P(DTERM(20,1,0),U,1)=DRUG_";PS(55," - . S DTERM("E","PS(55,",DRUG,1)="" - I $D(RXTYL("O")),DRUG>0 D - . M DTERM(20,3)=DEFARR(20,FINDING) - . S $P(DTERM(20,3,0),U,1)=DRUG_";PSRX(" - . S DTERM("E","PSRX(",DRUG,3)="" - I $D(RXTYL("N")),POI>0 D - . M DTERM(20,2)=DEFARR(20,FINDING) - . S $P(DTERM(20,2,0),U,1)=POI_";PS(55NVA," - . S DTERM("E","PS(55NVA,",POI,2)="" - K FIEVT - D IEVALTER^PXRMTERM(DFN,.FINDPA,.DTERM,1,.FIEVT) - M FIEVAL=FIEVT(1) - I FIEVAL S FIEVAL("FINDING")=DRUG_";PSDRUG(",FIEVAL("DISPENSE DRUG")=DRUG - Q - ; - ;=============================================== -EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate drug findings. - N DRUGIEN,DTERM,FIEVT,FINDPA,FINDING - N NOINDEX,POI,RXTYL - S NOINDEX=0 - I $G(^PXRMINDX(52,"DATE BUILT"))="" D - . D NOINDEX^PXRMERRH("D",PXRMITEM,52) - . S NOINDEX=1 - I $G(^PXRMINDX(55,"DATE BUILT"))="" D - . D NOINDEX^PXRMERRH("D",PXRMITEM,55) - . S NOINDEX=1 - S DRUGIEN="" - F S DRUGIEN=$O(DEFARR("E",ENODE,DRUGIEN)) Q:+DRUGIEN=0 D - . ;DBIA #221 - . S POI=$P($G(^PSDRUG(DRUGIEN,2)),U,1) - . S FINDING="" - . F S FINDING=$O(DEFARR("E",ENODE,DRUGIEN,FINDING)) Q:+FINDING=0 D - .. I NOINDEX S FIEVAL(FINDING)=0 Q - .. M FINDPA=DEFARR(20,FINDING) - .. K FIEVT,RXTYL - ..;Determine where we search. - .. D SRXTYL^PXRMRXTY(FINDPA(0),.RXTYL) - .. D DEVAL(DFN,.FINDPA,.DEFARR,FINDING,.RXTYL,DRUGIEN,POI,.FIEVT) - .. M FIEVAL(FINDING)=FIEVT - Q - ; - ;=============================================== -EVALPL(FINDPA,ENODE,TERMARR,PLIST) ;Evaluate drug terms for - ;building patient lists. - N BDT,EDT,DATE,DFN,DRUGIEN,ITEM,FILENUM,IND,LIST,NFOUND,NOCC,NOINDEX - N PFINDPA,POI,RXTYL,TEMP,TF,TFINDPA,TFINDING,TGLIST,TLIST - S NOINDEX=0 - I $G(^PXRMINDX(52,"DATE BUILT"))="" D - . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),52) - . S NOINDEX=1 - I $G(^PXRMINDX(55,"DATE BUILT"))="" D - . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),55) - . S NOINDEX=1 - I NOINDEX Q - S TGLIST="EVALPL_PXRMDRUG" - K ^TMP($J,TGLIST) - S DRUGIEN="" - F S DRUGIEN=$O(TERMARR("E",ENODE,DRUGIEN)) Q:+DRUGIEN=0 D - . ;DBIA #221 - . S POI=$P($G(^PSDRUG(DRUGIEN,2)),U,1) - . S TFINDING="" - . F S TFINDING=$O(TERMARR("E",ENODE,DRUGIEN,TFINDING)) Q:+TFINDING=0 D - .. K PFINDPA,TFINDPA - .. M TFINDPA=TERMARR(20,TFINDING) - ..;Set the finding parameters. - .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA) - ..;Determine where we search. - .. D SRXTYL^PXRMRXTY(PFINDPA(0),.RXTYL) - .. I $D(RXTYL("I")) D GPLIST^PXRMINDL(55,"IP",DRUGIEN,.PFINDPA,TGLIST) - .. I $D(RXTYL("N")),POI'="" D GPLIST^PXRMINDL("55NVA","IP",POI,.PFINDPA,TGLIST) - .. I $D(RXTYL("O")) D GPLIST^PXRMINDL(52,"IP",DRUGIEN,.PFINDPA,TGLIST) - ;Return the NOCC most recent results for each DFN. - S NOCC=$P(FINDPA(0),U,14) - S NOCC=$S(NOCC<0:-NOCC,NOCC="":1,1:NOCC) - F TF=0,1 D - . S DFN=0 - . F S DFN=$O(^TMP($J,TGLIST,TF,DFN)) Q:DFN="" D - .. K TLIST - .. S ITEM="" - .. F S ITEM=$O(^TMP($J,TGLIST,TF,DFN,ITEM)) Q:ITEM="" D - ... S NFOUND="" - ... F S NFOUND=$O(^TMP($J,TGLIST,TF,DFN,ITEM,NFOUND)) Q:NFOUND="" D - .... S FILENUM="" - .... F S FILENUM=$O(^TMP($J,TGLIST,TF,DFN,ITEM,NFOUND,FILENUM)) Q:FILENUM="" D - ..... S TEMP=^TMP($J,TGLIST,TF,DFN,ITEM,NFOUND,FILENUM) - ..... S DATE=+$P(TEMP,U,3) - ..... S TLIST(TF,DATE,ITEM,NFOUND,FILENUM)="" - .. S DATE="",NFOUND=0 - .. F S DATE=$O(TLIST(TF,DATE),-1) Q:(DATE="")!(NFOUND=NOCC) D - ... S ITEM="" - ... F S ITEM=$O(TLIST(TF,DATE,ITEM)) Q:(ITEM="")!(NFOUND=NOCC) D - .... S IND="" - .... F S IND=$O(TLIST(TF,DATE,ITEM,IND)) Q:(IND="")!(NFOUND=NOCC) D - ..... S FILENUM="" - ..... F S FILENUM=$O(TLIST(TF,DATE,ITEM,IND,FILENUM)) Q:(FILENUM="")!(NFOUND=NOCC) D - ...... S NFOUND=NFOUND+1 - ...... S ^TMP($J,PLIST,TF,DFN,ITEM,NFOUND,FILENUM)=^TMP($J,TGLIST,TF,DFN,ITEM,IND,FILENUM) - K ^TMP($J,TGLIST) - Q - ; - ;=============================================== -EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;Evaluate drug terms. - N DATEORDR,DRUGIEN,DTERM,DTFIEVAL,IND,JND,NOINDEX,PFINDPA,POI - N RXTYL,TEMP,TFINDING,TFINDPA - N DATEORDR,NOCC,SDIR - S NOINDEX=0 - I $G(^PXRMINDX(52,"DATE BUILT"))="" D - . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),52) - . S NOINDEX=1 - I $G(^PXRMINDX(55,"DATE BUILT"))="" D - . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),55) - . S NOINDEX=1 - ;Set NOCC and SDIR. - S NOCC=$P(FINDPA(0),U,14) - I NOCC="" S NOCC=1 - S SDIR=$S(NOCC<0:+1,1:-1) - S NOCC=$S(NOCC<0:-NOCC,1:NOCC) - S DRUGIEN="" - F S DRUGIEN=$O(TERMARR("E",ENODE,DRUGIEN)) Q:+DRUGIEN=0 D - . ;DBIA #221 - . S POI=$P($G(^PSDRUG(DRUGIEN,2)),U,1) - . S TFINDING="" - . F S TFINDING=$O(TERMARR("E",ENODE,DRUGIEN,TFINDING)) Q:+TFINDING=0 D - .. S TFIEVAL(TFINDING)=0 - .. I NOINDEX Q - .. K DTERM,DTFIEVAL,PFINDPA,TFINDPA - .. S DTERM(0)="DTERM",DTERM("IEN")=0 - .. M TFINDPA=TERMARR(20,TFINDING) - ..;Set the finding parameters. - .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA) - ..;Determine where we search. - .. D SRXTYL^PXRMRXTY(PFINDPA(0),.RXTYL) - .. I $D(RXTYL("I")) D - ... M DTERM(20,1)=TERMARR(20,TFINDING) - ... S $P(DTERM(20,1,0),U,1)=DRUGIEN_";PS(55," - ... S DTERM("E","PS(55,",DRUGIEN,1)="" - .. I $D(RXTYL("N")),POI'="" D - ... M DTERM(20,2)=TERMARR(20,TFINDING) - ... S $P(DTERM(20,2,0),U,1)=POI_";PS(55NVA," - ... S DTERM("E","PS(55NVA,",POI,2)="" - .. I $D(RXTYL("O")) D - ... M DTERM(20,3)=TERMARR(20,TFINDING) - ... S $P(DTERM(20,3,0),U,1)=DRUGIEN_";PSRX(" - ... S DTERM("E","PSRX(",DRUGIEN,3)="" - .. D IEVALTER^PXRMTERM(DFN,.PFINDPA,.DTERM,TFINDING,.DTFIEVAL) - .. 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 - Q - ; - ;=============================================== -MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output. - N DRUG,DRUGIEN,IND,FTYPE,NAME,PFIEVAL,TEMP - S DRUGIEN=IFIEVAL("DISPENSE DRUG") - ;DBIA #10043 - S DRUG=$P(^PSDRUG(DRUGIEN,0),U,1) - S NAME="Drug: "_DRUG_" = " - S NLINES=NLINES+1 - S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Drug: "_DRUG - S IND=0 - F S IND=+$O(IFIEVAL(IND)) Q:IND=0 D - . S TEMP=IFIEVAL(IND,"FINDING") - . S FTYPE=$P(TEMP,";",2) - . K PFIEVAL M PFIEVAL=IFIEVAL(IND) - . S PFIEVAL("DISPENSE DRUG")=DRUG - . I FTYPE="PS(55," D MHVOUT^PXRMDIN(INDENT+1,.PFIEVAL,.NLINES,.TEXT) Q - . I FTYPE="PS(55NVA," D MHVOUT^PXRMDNVA(INDENT+1,.PFIEVAL,.NLINES,.TEXT) Q - . I FTYPE="PSRX(" D MHVOUT^PXRMDOUT(INDENT+1,.PFIEVAL,.NLINES,.TEXT) Q - S NLINES=NLINES+1,TEXT(NLINES)="" - Q - ; - ;=============================================== -OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical - ;maintenance output. - N DRUG,FTYPE,IND,PFIEVAL,TEMP,TEXTOUT - ;DBIA #10043 - S DRUG=$P(^PSDRUG(IFIEVAL("DISPENSE DRUG"),0),U,1) - S NLINES=NLINES+1 - S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Drug: "_DRUG - S IND=0 - F S IND=+$O(IFIEVAL(IND)) Q:IND=0 D - . S TEMP=IFIEVAL(IND,"FINDING") - . S FTYPE=$P(TEMP,";",2) - . K PFIEVAL M PFIEVAL=IFIEVAL(IND) - . S PFIEVAL("DISPENSE DRUG")=DRUG - . I FTYPE="PS(55," D OUTPUT^PXRMDIN(INDENT+1,.PFIEVAL,.NLINES,.TEXT) Q - . I FTYPE="PS(55NVA," D OUTPUT^PXRMDNVA(INDENT+1,.PFIEVAL,.NLINES,.TEXT) Q - . I FTYPE="PSRX(" D OUTPUT^PXRMDOUT(INDENT+1,.PFIEVAL,.NLINES,.TEXT) Q - Q - ; +PXRMDRUG ; SLC/PKR - Handle drug findings. ;06/08/2006 + ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21 + ; + ;=============================================== +DEVAL(DFN,FINDPA,DEFARR,FINDING,RXTYL,DRUG,POI,FIEVAL) ;Evaluate a drug + ;finding. + I DRUG=0,POI=0 S FIEVAL=0 Q + N DTERM,FIEVT + ;Create the pseudo term. + S DTERM(0)="DTERM",DTERM("IEN")=0 + I $D(RXTYL("I")),DRUG>0 D + . M DTERM(20,1)=DEFARR(20,FINDING) + . S $P(DTERM(20,1,0),U,1)=DRUG_";PS(55," + . S DTERM("E","PS(55,",DRUG,1)="" + I $D(RXTYL("O")),DRUG>0 D + . M DTERM(20,3)=DEFARR(20,FINDING) + . S $P(DTERM(20,3,0),U,1)=DRUG_";PSRX(" + . S DTERM("E","PSRX(",DRUG,3)="" + I $D(RXTYL("N")),POI>0 D + . M DTERM(20,2)=DEFARR(20,FINDING) + . S $P(DTERM(20,2,0),U,1)=POI_";PS(55NVA," + . S DTERM("E","PS(55NVA,",POI,2)="" + K FIEVT + D IEVALTER^PXRMTERM(DFN,.FINDPA,.DTERM,1,.FIEVT) + M FIEVAL=FIEVT(1) + I FIEVAL S FIEVAL("FINDING")=DRUG_";PSDRUG(",FIEVAL("DISPENSE DRUG")=DRUG + Q + ; + ;=============================================== +EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate drug findings. + N DRUGIEN,DTERM,FIEVT,FINDPA,FINDING + N NOINDEX,POI,RXTYL + S NOINDEX=0 + I $G(^PXRMINDX(52,"DATE BUILT"))="" D + . D NOINDEX^PXRMERRH("D",PXRMITEM,52) + . S NOINDEX=1 + I $G(^PXRMINDX(55,"DATE BUILT"))="" D + . D NOINDEX^PXRMERRH("D",PXRMITEM,55) + . S NOINDEX=1 + S DRUGIEN="" + F S DRUGIEN=$O(DEFARR("E",ENODE,DRUGIEN)) Q:+DRUGIEN=0 D + . ;DBIA #221 + . S POI=$P($G(^PSDRUG(DRUGIEN,2)),U,1) + . S FINDING="" + . F S FINDING=$O(DEFARR("E",ENODE,DRUGIEN,FINDING)) Q:+FINDING=0 D + .. I NOINDEX S FIEVAL(FINDING)=0 Q + .. M FINDPA=DEFARR(20,FINDING) + .. K FIEVT,RXTYL + ..;Determine where we search. + .. D SRXTYL^PXRMRXTY(FINDPA(0),.RXTYL) + .. D DEVAL(DFN,.FINDPA,.DEFARR,FINDING,.RXTYL,DRUGIEN,POI,.FIEVT) + .. M FIEVAL(FINDING)=FIEVT + Q + ; + ;=============================================== +EVALPL(FINDPA,ENODE,TERMARR,PLIST) ;Evaluate drug terms for + ;building patient lists. + N BDT,EDT,DATE,DFN,DRUGIEN,ITEM,FILENUM,IND,LIST,NFOUND,NOCC,NOINDEX + N PFINDPA,POI,RXTYL,TEMP,TF,TFINDPA,TFINDING,TGLIST,TLIST + S NOINDEX=0 + I $G(^PXRMINDX(52,"DATE BUILT"))="" D + . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),52) + . S NOINDEX=1 + I $G(^PXRMINDX(55,"DATE BUILT"))="" D + . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),55) + . S NOINDEX=1 + I NOINDEX Q + S TGLIST="EVALPL_PXRMDRUG" + K ^TMP($J,TGLIST) + S DRUGIEN="" + F S DRUGIEN=$O(TERMARR("E",ENODE,DRUGIEN)) Q:+DRUGIEN=0 D + . ;DBIA #221 + . S POI=$P($G(^PSDRUG(DRUGIEN,2)),U,1) + . S TFINDING="" + . F S TFINDING=$O(TERMARR("E",ENODE,DRUGIEN,TFINDING)) Q:+TFINDING=0 D + .. K PFINDPA,TFINDPA + .. M TFINDPA=TERMARR(20,TFINDING) + ..;Set the finding parameters. + .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA) + ..;Determine where we search. + .. D SRXTYL^PXRMRXTY(PFINDPA(0),.RXTYL) + .. I $D(RXTYL("I")) D GPLIST^PXRMINDL(55,"IP",DRUGIEN,.PFINDPA,TGLIST) + .. I $D(RXTYL("N")),POI'="" D GPLIST^PXRMINDL("55NVA","IP",POI,.PFINDPA,TGLIST) + .. I $D(RXTYL("O")) D GPLIST^PXRMINDL(52,"IP",DRUGIEN,.PFINDPA,TGLIST) + ;Return the NOCC most recent results for each DFN. + S NOCC=$P(FINDPA(0),U,14) + S NOCC=$S(NOCC<0:-NOCC,NOCC="":1,1:NOCC) + F TF=0,1 D + . S DFN=0 + . F S DFN=$O(^TMP($J,TGLIST,TF,DFN)) Q:DFN="" D + .. K TLIST + .. S ITEM="" + .. F S ITEM=$O(^TMP($J,TGLIST,TF,DFN,ITEM)) Q:ITEM="" D + ... S NFOUND="" + ... F S NFOUND=$O(^TMP($J,TGLIST,TF,DFN,ITEM,NFOUND)) Q:NFOUND="" D + .... S FILENUM="" + .... F S FILENUM=$O(^TMP($J,TGLIST,TF,DFN,ITEM,NFOUND,FILENUM)) Q:FILENUM="" D + ..... S TEMP=^TMP($J,TGLIST,TF,DFN,ITEM,NFOUND,FILENUM) + ..... S DATE=+$P(TEMP,U,3) + ..... S TLIST(TF,DATE,ITEM,NFOUND,FILENUM)="" + .. S DATE="",NFOUND=0 + .. F S DATE=$O(TLIST(TF,DATE),-1) Q:(DATE="")!(NFOUND=NOCC) D + ... S ITEM="" + ... F S ITEM=$O(TLIST(TF,DATE,ITEM)) Q:(ITEM="")!(NFOUND=NOCC) D + .... S IND="" + .... F S IND=$O(TLIST(TF,DATE,ITEM,IND)) Q:(IND="")!(NFOUND=NOCC) D + ..... S FILENUM="" + ..... F S FILENUM=$O(TLIST(TF,DATE,ITEM,IND,FILENUM)) Q:(FILENUM="")!(NFOUND=NOCC) D + ...... S NFOUND=NFOUND+1 + ...... S ^TMP($J,PLIST,TF,DFN,ITEM,NFOUND,FILENUM)=^TMP($J,TGLIST,TF,DFN,ITEM,IND,FILENUM) + K ^TMP($J,TGLIST) + Q + ; + ;=============================================== +EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;Evaluate drug terms. + N DATEORDR,DRUGIEN,DTERM,DTFIEVAL,IND,NOINDEX,PFINDPA,POI + N RXTYL,TEMP,TFINDING,TFINDPA + N DATEORDR,NOCC,SDIR + S NOINDEX=0 + I $G(^PXRMINDX(52,"DATE BUILT"))="" D + . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),52) + . S NOINDEX=1 + I $G(^PXRMINDX(55,"DATE BUILT"))="" D + . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),55) + . S NOINDEX=1 + ;Set NOCC and SDIR. + S NOCC=$P(FINDPA(0),U,14) + I NOCC="" S NOCC=1 + S SDIR=$S(NOCC<0:+1,1:-1) + S NOCC=$S(NOCC<0:-NOCC,1:NOCC) + S DRUGIEN="" + F S DRUGIEN=$O(TERMARR("E",ENODE,DRUGIEN)) Q:+DRUGIEN=0 D + . ;DBIA #221 + . S POI=$P($G(^PSDRUG(DRUGIEN,2)),U,1) + . S TFINDING="" + . F S TFINDING=$O(TERMARR("E",ENODE,DRUGIEN,TFINDING)) Q:+TFINDING=0 D + .. S TFIEVAL(TFINDING)=0 + .. I NOINDEX Q + .. K DTERM,DTFIEVAL,PFINDPA,TFINDPA + .. S DTERM(0)="DTERM",DTERM("IEN")=0 + .. M TFINDPA=TERMARR(20,TFINDING) + ..;Set the finding parameters. + .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA) + ..;Determine where we search. + .. D SRXTYL^PXRMRXTY(PFINDPA(0),.RXTYL) + .. I $D(RXTYL("I")) D + ... M DTERM(20,1)=TERMARR(20,TFINDING) + ... S $P(DTERM(20,1,0),U,1)=DRUGIEN_";PS(55," + ... S DTERM("E","PS(55,",DRUGIEN,1)="" + .. I $D(RXTYL("N")),POI'="" D + ... M DTERM(20,2)=TERMARR(20,TFINDING) + ... S $P(DTERM(20,2,0),U,1)=POI_";PS(55NVA," + ... S DTERM("E","PS(55NVA,",POI,2)="" + .. I $D(RXTYL("O")) D + ... M DTERM(20,3)=TERMARR(20,TFINDING) + ... S $P(DTERM(20,3,0),U,1)=DRUGIEN_";PSRX(" + ... S DTERM("E","PSRX(",DRUGIEN,3)="" + .. D IEVALTER^PXRMTERM(DFN,.PFINDPA,.DTERM,TFINDING,.DTFIEVAL) + .. D DORDER^PXRMTERM(.DTFIEVAL,.DATEORDR) + .. D COPY^PXRMTERM(NOCC,SDIR,.DTFIEVAL,.DATEORDR,TFINDING,.TFIEVAL) + .. I TFIEVAL(TFINDING) S TFIEVAL(TFINDING,"DISPENSE DRUG")=DRUGIEN + Q + ; + ;=============================================== +MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output. + N DRUG,DRUGIEN,IND,FTYPE,NAME,PFIEVAL,TEMP + S DRUGIEN=IFIEVAL("DISPENSE DRUG") + ;DBIA #10043 + S DRUG=$P(^PSDRUG(DRUGIEN,0),U,1) + S NAME="Drug: "_DRUG_" = " + S NLINES=NLINES+1 + S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Drug: "_DRUG + S IND=0 + F S IND=+$O(IFIEVAL(IND)) Q:IND=0 D + . S TEMP=IFIEVAL(IND,"FINDING") + . S FTYPE=$P(TEMP,";",2) + . K PFIEVAL M PFIEVAL=IFIEVAL(IND) + . S PFIEVAL("DISPENSE DRUG")=DRUG + . I FTYPE="PS(55," D MHVOUT^PXRMDIN(INDENT+1,.PFIEVAL,.NLINES,.TEXT) Q + . I FTYPE="PS(55NVA," D MHVOUT^PXRMDNVA(INDENT+1,.PFIEVAL,.NLINES,.TEXT) Q + . I FTYPE="PSRX(" D MHVOUT^PXRMDOUT(INDENT+1,.PFIEVAL,.NLINES,.TEXT) Q + S NLINES=NLINES+1,TEXT(NLINES)="" + Q + ; + ;=============================================== +OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical + ;maintenance output. + N DRUG,FTYPE,IND,PFIEVAL,TEMP,TEXTOUT + ;DBIA #10043 + S DRUG=$P(^PSDRUG(IFIEVAL("DISPENSE DRUG"),0),U,1) + S NLINES=NLINES+1 + S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Drug: "_DRUG + S IND=0 + F S IND=+$O(IFIEVAL(IND)) Q:IND=0 D + . S TEMP=IFIEVAL(IND,"FINDING") + . S FTYPE=$P(TEMP,";",2) + . K PFIEVAL M PFIEVAL=IFIEVAL(IND) + . S PFIEVAL("DISPENSE DRUG")=DRUG + . I FTYPE="PS(55," D OUTPUT^PXRMDIN(INDENT+1,.PFIEVAL,.NLINES,.TEXT) Q + . I FTYPE="PS(55NVA," D OUTPUT^PXRMDNVA(INDENT+1,.PFIEVAL,.NLINES,.TEXT) Q + . I FTYPE="PSRX(" D OUTPUT^PXRMDOUT(INDENT+1,.PFIEVAL,.NLINES,.TEXT) Q + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMEDIT.m b/r/CLINICAL_REMINDERS-PXRM/PXRMEDIT.m index 0ed8ab6a..4a72676f 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMEDIT.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMEDIT.m @@ -1,21 +1,18 @@ -PXRMEDIT ; SLC/PKR - Clinical Reminder edit driver. ;06/04/2007 - ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123 - ; -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 - ; - ;Reminder term - I ROOT="^PXRMD(811.5," D EDIT^PXRMTMED(ROOT,IENN) Q - ; - ;Reminder definition - I ROOT="^PXD(811.9," D - .;Build list of finding types for finding edit - . N DEF,DEF1,DEF2 D DEF^PXRMRUTL("811.902",.DEF,.DEF1,.DEF2) - .;Edit reminder - . D ALL^PXRMREDT(ROOT,IENN) Q - Q - ; +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. + ;Taxonomy + I ROOT="^PXD(811.2," D EDIT^PXRMTEDT(ROOT,IENN) Q + ; + ;Reminder term + I ROOT="^PXRMD(811.5," D EDIT^PXRMTMED(ROOT,IENN) Q + ; + ;Reminder + I ROOT="^PXD(811.9," D + .;Build list of finding types for finding edit + . N DEF,DEF1,DEF2 D DEF^PXRMRUTL("811.902",.DEF,.DEF1,.DEF2) + .;Edit reminder + . D ALL^PXRMREDT(ROOT,IENN) Q + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMENOD.m b/r/CLINICAL_REMINDERS-PXRM/PXRMENOD.m index 09892610..109d601a 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMENOD.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMENOD.m @@ -1,50 +1,49 @@ -PXRMENOD ; SLC/PKR - Clinical Reminders "E" node routines. ;12/13/2006 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ;======================================================== -KENODE(X,DA,FILENUM) ;Kill the enode in the finding multiple for definitions - ;and terms. - ;Do not execute as part of a verify fields. - I $G(DIUTIL)="VERIFY FIELDS" Q - N DAS,GLOBAL,IEN - S IEN=$P(X,";",1) - S GLOBAL=$P(X,";",2) - I GLOBAL="LAB(60," D - . N SUB - .;DBIA #91-A - . S SUB=$P(^LAB(60,IEN,0),U,4) - . I SUB="CH" Q - . I (SUB="BB")!(SUB="WK") S IEN="" Q - . I SUB="MI" S IEN="M;T;"_IEN Q - .;All other SUB values: AU, CY, EM, SP - . S IEN="A;T;"_IEN - S DAS=IEN - I DAS="" Q - I FILENUM=811.5 K ^PXRMD(811.5,DA(1),20,"E",GLOBAL,DAS,DA) - I FILENUM=811.9 K ^PXD(811.9,DA(1),20,"E",GLOBAL,DAS,DA) - Q - ; - ;======================================================== -SENODE(X,DA,FILENUM) ;Set the enode in the finding multiple for definitions - ;and terms. - ;Do not execute as part of a verify fields. - I $G(DIUTIL)="VERIFY FIELDS" Q - N DAS,GLOBAL,IEN,NAME - S IEN=$P(X,";",1) - S GLOBAL=$P(X,";",2) - I GLOBAL="LAB(60," D - . N SUB - .;DBIA #91-A - . S SUB=$P(^LAB(60,IEN,0),U,4) - . I SUB="CH" Q - . I (SUB="BB")!(SUB="WK") S IEN="" Q - . I SUB="MI" S IEN="M;T;"_IEN Q - .;All other SUB values: AU, CY, EM, SP - . S IEN="A;T;"_IEN - 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 - Q - ; +PXRMENOD ; SLC/PKR - Clinical Reminders "E" node routines. ;04/17/2006 + ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21 + ; + ;======================================================== +KENODE(X,DA,FILENUM) ;Kill the enode in the finding multiple for definitions + ;and terms. + ;Do not execute as part of a verify fields. + I $G(DIUTIL)="VERIFY FIELDS" Q + N DAS,GLOBAL,IEN + S IEN=$P(X,";",1) + S GLOBAL=$P(X,";",2) + I GLOBAL="LAB(60," D + . N SUB + .;DBIA #91-A + . S SUB=$P(^LAB(60,IEN,0),U,4) + . I SUB="CH" Q + . I (SUB="BB")!(SUB="WK") S IEN="" Q + . I SUB="MI" S IEN="M;T;"_IEN Q + .;All other SUB values: AU, CY, EM, SP + . S IEN="A;T;"_IEN + S DAS=IEN + I DAS="" Q + I FILENUM=811.5 K ^PXRMD(811.5,DA(1),20,"E",GLOBAL,DAS,DA) + I FILENUM=811.9 K ^PXD(811.9,DA(1),20,"E",GLOBAL,DAS,DA) + Q + ; + ;======================================================== +SENODE(X,DA,FILENUM) ;Set the enode in the finding multiple for definitions + ;and terms. + ;Do not execute as part of a verify fields. + I $G(DIUTIL)="VERIFY FIELDS" Q + N DAS,GLOBAL,IEN + S IEN=$P(X,";",1) + S GLOBAL=$P(X,";",2) + I GLOBAL="LAB(60," D + . N SUB + .;DBIA #91-A + . S SUB=$P(^LAB(60,IEN,0),U,4) + . I SUB="CH" Q + . I (SUB="BB")!(SUB="WK") S IEN="" Q + . I SUB="MI" S IEN="M;T;"_IEN Q + .;All other SUB values: AU, CY, EM, SP + . S IEN="A;T;"_IEN + S DAS=IEN + I DAS="" Q + 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 + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMEPM.m b/r/CLINICAL_REMINDERS-PXRM/PXRMEPM.m index 2c46238e..ed72eb2d 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMEPM.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMEPM.m @@ -1,174 +1,180 @@ -PXRMEPM ; SLC/PKR/PJH - Extract Definition Management ;07/17/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ;Main entry point for PXRM EXTRACT DEFINITIONS -START N PXRMDONE,VALMBCK,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD - S X="IORESET" - D ENDR^%ZISS - S VALMCNT=0 - D EN^VALM("PXRM EXTRACT DEFINITIONS") - Q - ; -BLDLIST ;Build workfile - K ^TMP("PXRMEPM",$J) - N IEN,IND,PLIST - D LIST^PXRMETM("PXRMEPM",.VALMCNT) - Q - ; -ENTRY ;Entry code - D BLDLIST,XQORM - Q - ; -EXIT ;Exit code - K ^TMP("PXRMEPM",$J) - K ^TMP("PXRMEPMH",$J) - D CLEAN^VALM10 - D FULL^VALM1 - S VALMBCK="Q" - Q - ; -HDR ; Header code - S VALMSG="+ Next Screen - Prev Screen ?? More Actions" - Q - ; -HLP ;Help code - N ORU,ORUPRMT,SUB,XQORM - S SUB="PXRMEPMH" - 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" - ;Reset after page up/down etc - D XQORM - Q - ; -XQORM S XQORM("#")=$O(^ORD(101,"B","PXRM EXTRACT DEFINITION SELECT ENTRY",0))_U_"1:"_VALMCNT - S XQORM("A")="Select Item: " - Q - ; -XSEL ;PXRM EXTRACT DEFINITION SELECT ENTRY validation - N SEL,IEN - 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 IEN=^TMP("PXRMEPM",$J,"SEL",SEL) - ;Display/Edit Extract Definition - D START^PXRMEPED(IEN) - D BLDLIST - S VALMBCK="R" - Q - ; -HELP(CALL) ;General help text routine - N HTEXT - I CALL=1 D - .S HTEXT(1)="Select DE to display or edit a definition." - .S HTEXT(2)="Select ED to edit a definition" - D HELP^PXRMEUT(.HTEXT) - Q - ; -EPADD ;Add Rule Option - ;Reset Screen Mode - W IORESET - ; - ;Add Rule - D ADD^PXRMEPED - ; - ;Rebuild Workfile - D BLDLIST - S VALMBCK="R" - Q - ; -EPINQ ;Definition Inquiry - PXRM EXTRACT DEFINITION DISPLAY/EDIT entry - N IND,LRIEN,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 LRIEN=^TMP("PXRMEPM",$J,"SEL",IND) - .D START^PXRMEPED(LRIEN) - D BLDLIST - S VALMBCK="R" - Q - ; -PPLR ;Display rule set components - ;used by [PXRM EXTRACT DEFINITION] template) - N ACT,DATA,FIRST,IEN,LRDATA,LRIEN,SEQ,SUB - S IEN=$P(X,U,2) Q:'IEN - W !," Description: ",$P($G(^PXRM(810.4,IEN,0)),U,2) - S SEQ="",FIRST=1 - F S SEQ=$O(^PXRM(810.4,IEN,30,"B",SEQ)) Q:'SEQ D - .S SUB=$O(^PXRM(810.4,IEN,30,"B",SEQ,"")) Q:'SUB - .S DATA=$G(^PXRM(810.4,IEN,30,SUB,0)) Q:DATA="" - .S LRIEN=$P(DATA,U,2) Q:LRIEN="" - .S ACT=$P(DATA,U,3),LRDATA=$G(^PXRM(810.4,LRIEN,0)) - .I FIRST W !!,?2,"List Rules:" S FIRST=0 - .W !,?2,SEQ,?7,$P(LRDATA,U),?66 - .W $S(ACT="A":"ADD PATIENT",ACT="R":"REMOVE PATIENT",ACT="F":"INSERT FINDING",1:"SELECT PATIENT") - .;Display List Rule fields - .D LROUT^PXRMLRED(LRIEN,23) - .W ! - Q - ; -PPFR ;Display counting rules and count type - ;used by [PXRM EXTRACT DEFINITION] template) - W ! - N DATA,GIEN,GSTATUS,IEN,SEQ,SUB - S IEN=$P(X,U,3) Q:'IEN - S SEQ="" - F S SEQ=$O(^PXRM(810.7,IEN,10,"B",SEQ)) Q:SEQ="" D - .S SUB=$O(^PXRM(810.7,IEN,10,"B",SEQ,"")) Q:'SUB - .S DATA=$G(^PXRM(810.7,IEN,10,SUB,0)) Q:DATA="" - .S GIEN=$P(DATA,U,2) Q:GIEN="" - .S GSTATUS=$P(DATA,U,3) - .;Get counting groups - .N CTYP,CTXT,DATA,EXCL,FIRST,GNAME,PNAME,TIEN,TNAME,GSEQ,GSUB - .S DATA=$G(^PXRM(810.8,GIEN,0)),GNAME=$P(DATA,U) - .S CTYP=$P(DATA,U,3),PNAME=$P(DATA,U,2),GSEQ="",FIRST=1 - .S CTXT=$$TXT(CTYP,GSTATUS) - .F S GSEQ=$O(^PXRM(810.8,GIEN,10,"B",GSEQ)) Q:GSEQ="" D - ..S GSUB=$O(^PXRM(810.8,GIEN,10,"B",GSEQ,"")) Q:'GSUB - ..S DATA=$G(^PXRM(810.8,GIEN,10,GSUB,0)) Q:DATA="" - ..S TIEN=$P(DATA,U,2) Q:TIEN="" - ..S EXCL=$P(DATA,U,3) Q:EXCL="E" - ..S TNAME=$P($G(^PXRMD(811.5,TIEN,0)),U) - ..I FIRST D - ...W !,?14,SEQ - ...W ?18,"Counting Group: ",GNAME - ...W !,?18,$$TXT(CTYP,GSTATUS) - ...W !,?23,"Terms:" S FIRST=0 - ..W ?30,TNAME,! - Q - ; -SCREEN ;Screen for 810.210 field .02 - S DIC("S")="I $P(^(0),U,3)=3" - Q - ; -TXT(COUNT,COHORT) ;Text to describe group - N TXT - ;Determine count type - I COUNT="MRFP" S TXT="Most recent finding patient counts for " - I COUNT="MRF" S TXT="Most recent finding counts for " - I COUNT="UR" S TXT="Utilization in period finding counts for " - ;Error - I $G(TXT)="" Q "Unknown count type - error" - ;Determine cohort - S TXT=TXT_$S(COHORT="A":"APPLICABLE",1:"TOTAL")_" patients" - Q TXT +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 +START N PXRMDONE,VALMBCK,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD + S X="IORESET" + D ENDR^%ZISS + S VALMCNT=0 + D EN^VALM("PXRM EXTRACT DEFINITIONS") + Q + ; +BLDLIST ;Build workfile + K ^TMP("PXRMEPM",$J) + N IEN,IND,PLIST + 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 + ; +ENTRY ;Entry code + D BLDLIST,XQORM + Q + ; +EXIT ;Exit code + K ^TMP("PXRMEPM",$J) + K ^TMP("PXRMEPMH",$J) + D CLEAN^VALM10 + D FULL^VALM1 + S VALMBCK="Q" + Q + ; +HDR ; Header code + S VALMSG="+ Next Screen - Prev Screen ?? More Actions" + Q + ; +HLP ;Help code + N ORU,ORUPRMT,SUB,XQORM + S SUB="PXRMEPMH" + 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" + ;Reset after page up/down etc + D XQORM + Q + ; +XQORM S XQORM("#")=$O(^ORD(101,"B","PXRM EXTRACT DEFINITION SELECT ENTRY",0))_U_"1:"_VALMCNT + S XQORM("A")="Select Item: " + Q + ; +XSEL ;PXRM EXTRACT DEFINITION SELECT ENTRY validation + N SEL,IEN + 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 IEN=^TMP("PXRMEPM",$J,"IDX",SEL,SEL) + ;Display/Edit Extract Definition + D START^PXRMEPED(IEN) + D BLDLIST + S VALMBCK="R" + Q + ; +HELP(CALL) ;General help text routine + N HTEXT + I CALL=1 D + .S HTEXT(1)="Select DE to display or edit a definition." + .S HTEXT(2)="Select ED to edit a definition" + D HELP^PXRMEUT(.HTEXT) + Q + ; +EPADD ;Add Rule Option + ; + ;Reset Screen Mode + W IORESET + ; + ;Add Rule + D ADD^PXRMEPED + ; + ;Rebuild Workfile + D BLDLIST + ; + S VALMBCK="R" + Q + ; +EPINQ ;Definition Inquiry - PXRM EXTRACT DEFINITION DISPLAY/EDIT entry + N IND,LRIEN,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 LRIEN=^TMP("PXRMEPM",$J,"IDX",IND,IND) + .D START^PXRMEPED(LRIEN) + D BLDLIST + S VALMBCK="R" + Q + ; +PPLR ;Display rule set components + ;used by [PXRM EXTRACT DEFINITION] template) + N ACT,DATA,FIRST,IEN,LRDATA,LRIEN,SEQ,SUB + S IEN=$P(X,U,2) Q:'IEN + W !," Description: ",$P($G(^PXRM(810.4,IEN,0)),U,2) + S SEQ="",FIRST=1 + F S SEQ=$O(^PXRM(810.4,IEN,30,"B",SEQ)) Q:'SEQ D + .S SUB=$O(^PXRM(810.4,IEN,30,"B",SEQ,"")) Q:'SUB + .S DATA=$G(^PXRM(810.4,IEN,30,SUB,0)) Q:DATA="" + .S LRIEN=$P(DATA,U,2) Q:LRIEN="" + .S ACT=$P(DATA,U,3),LRDATA=$G(^PXRM(810.4,LRIEN,0)) + .I FIRST W !!,?2,"List Rules:" S FIRST=0 + .W !,?2,SEQ,?7,$P(LRDATA,U),?66 + .W $S(ACT="A":"ADD PATIENT",ACT="R":"REMOVE PATIENT",ACT="F":"INSERT FINDING",1:"SELECT PATIENT") + .;Display List Rule fields + .D LROUT^PXRMLRED(LRIEN,23) + .W ! + Q + ; +PPFR ;Display counting rules and count type + ;used by [PXRM EXTRACT DEFINITION] template) + W ! + N DATA,GIEN,GSTATUS,IEN,SEQ,SUB + S IEN=$P(X,U,3) Q:'IEN + S SEQ="" + F S SEQ=$O(^PXRM(810.7,IEN,10,"B",SEQ)) Q:SEQ="" D + .S SUB=$O(^PXRM(810.7,IEN,10,"B",SEQ,"")) Q:'SUB + .S DATA=$G(^PXRM(810.7,IEN,10,SUB,0)) Q:DATA="" + .S GIEN=$P(DATA,U,2) Q:GIEN="" + .S GSTATUS=$P(DATA,U,3) + .;Get counting groups + .N CTYP,CTXT,DATA,EXCL,FIRST,GNAME,PNAME,TIEN,TNAME,GSEQ,GSUB + .S DATA=$G(^PXRM(810.8,GIEN,0)),GNAME=$P(DATA,U) + .S CTYP=$P(DATA,U,3),PNAME=$P(DATA,U,2),GSEQ="",FIRST=1 + .S CTXT=$$TXT(CTYP,GSTATUS) + .F S GSEQ=$O(^PXRM(810.8,GIEN,10,"B",GSEQ)) Q:GSEQ="" D + ..S GSUB=$O(^PXRM(810.8,GIEN,10,"B",GSEQ,"")) Q:'GSUB + ..S DATA=$G(^PXRM(810.8,GIEN,10,GSUB,0)) Q:DATA="" + ..S TIEN=$P(DATA,U,2) Q:TIEN="" + ..S EXCL=$P(DATA,U,3) Q:EXCL="E" + ..S TNAME=$P($G(^PXRMD(811.5,TIEN,0)),U) + ..I FIRST D + ...W !,?14,SEQ + ...W ?18,"Counting Group: ",GNAME + ...W !,?18,$$TXT(CTYP,GSTATUS) + ...W !,?23,"Terms:" S FIRST=0 + ..W ?30,TNAME,! + Q + ; +SCREEN ;Screen for 810.210 field .02 + S DIC("S")="I $P(^(0),U,3)=3" + Q + ; +TXT(COUNT,COHORT) ;Text to describe group + N TXT + ;Determine count type + I COUNT="MRFP" S TXT="Most recent finding patient counts for " + I COUNT="MRF" S TXT="Most recent finding counts for " + I COUNT="UR" S TXT="Utilization in period finding counts for " + ;Error + I $G(TXT)="" Q "Unknown count type - error" + ;Determine cohort + S TXT=TXT_$S(COHORT="A":"APPLICABLE",1:"TOTAL")_" patients" + Q TXT diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMETCO.m b/r/CLINICAL_REMINDERS-PXRM/PXRMETCO.m index f1ac08d2..ef92a4ae 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMETCO.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMETCO.m @@ -1,147 +1,144 @@ -PXRMETCO ; SLC/PJH - QUERI Extract Compliance Report ;03/27/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ; -ADHOC(IEN,PXRMSTRT,PXRMSTOP) ;Ad Hoc Conformance Report - D DUMMY1^PXRMRUTL - Q - ; - D JOB - Q - ; - ;BOOKMARK - cloned from PXRMETX, needs modifying to avoid patient list - ;update. Build ^TMP("PXRMETX",$J) for report - ; -REPORT ;Initialise - K ^TMP("PXRMETX",$J) - ;Workfile node for ^TMP - S PXRMNODE="PXRMRULE" - ;Get details from parameter file - N DATA,DATES,LIST,NAME,PARTYPE,TEXT - ;N PERIOD,TEXT,YEAR - S DATA=$G(^PXRM(810.2,IEN,0)) - ; - ;Determine Extract Name and period - S NAME=$P(DATA,U),PARTYPE=$P(DATA,U,2) - ;S YEAR=$P(NEXT,"/",2),PERIOD=$P(NEXT,"/") - ;Calculate report period start and end dates - ;D CALC^PXRMEUT(NEXT,.PXRMSTRT,.PXRMSTOP) - ;Determine output name for patient list and extract summary - S DATES=$$FMTE^XLFDT(PXRMSTRT)_" - "_$$FMTE^XLFDT(PXRMSTOP) - ; - ;Bookmark - Needs inventive patient list names - S LIST=NAME_" REPORT "_DATES - ;Process (single) Denominator rule into patient list - N INDP,INTP,SEQ,SUB,SUFFIX - S SEQ="" - F S SEQ=$O(^PXRM(810.2,IEN,10,"B",SEQ)) Q:'SEQ D - .S SUB=$O(^PXRM(810.2,IEN,10,"B",SEQ,"")) Q:'SUB - .S DATA=$G(^PXRM(810.2,IEN,10,SUB,0)) Q:DATA="" - .S PXRMRULE=$P(DATA,U,2) Q:'PXRMRULE - .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) - .;Clear ^TMP lists created for rule - .D CLEAR^PXRMRULE(PXRMRULE,PXRMNODE) - .;Process reminders - .D REM^PXRMETXR(SUB,PXRMLIST) - ; - ;Bookmark - Report stuff goes here - ;Update totals section - N APPL,DUE,DATA,ETYP,EVAL - N FAPPL,FCNT,FDATA,FDUE,FEVAL,FGNAM,FIND,FNAPPL,FNDUE,FSEQ - N NAPPL,NDUE,PXRMLIST,RCNT,RIEN,RSEQ,SEQ - S SEQ=0,CNT=1 - F S SEQ=$O(^TMP("PXRMETX",$J,SEQ)) Q:'SEQ D - .S RCNT=0,RSEQ=0 - .F S RCNT=$O(^TMP("PXRMETX",$J,SEQ,RCNT)) Q:'RCNT D - ..S DATA=$G(^TMP("PXRMETX",$J,SEQ,RCNT)) Q:'DATA - ..S RIEN=$P(DATA,U),PXRMLIST=$P(DATA,U,5) - ..S EVAL=$P(DATA,U,2),APPL=$P(DATA,U,3),DUE=$P(DATA,U,4) - ..S NAPPL=EVAL-APPL,NDUE=APPL-DUE - ..S CNT=CNT+1,RSEQ=RSEQ+1 - ..;bookmark - write patient line - ..;For each count type - ..S ETYP="",FCNT=CNT - ..F S ETYP=$O(^TMP("PXRMETX",$J,SEQ,RCNT,ETYP)) Q:ETYP="" D - ...;For each term - ...S FIND=0,FSEQ=0 - ...F S FIND=$O(^TMP("PXRMETX",$J,SEQ,RCNT,ETYP,FIND)) Q:FIND="" D - ....;Update finding totals - ....S FDATA=$G(^TMP("PXRMETX",$J,SEQ,RCNT,ETYP,FIND)),FCNT=FCNT+1 - ....S FEVAL=$P(FDATA,U,2),FAPPL=$P(FDATA,U,3),FDUE=$P(FDATA,U,4) - ....S FNAPPL=FEVAL-FAPPL,FNDUE=FAPPL-FDUE - ....S FSEQ=FSEQ+1,FGNAM=$P(DATA,U,9) - ....;Bookmark - write finding line - ..;Update CNT - ..S CNT=FCNT - Q - ; - ;Determine whether the report should be queued. -JOB ; - N %ZIS,ZTDESC,ZTSAVE,ZTRTN,ZTSK - S DBDUZ=DUZ - D SAVE^PXRMXQUE - S %ZIS="Q" - S ZTDESC="QUERI Compliance Report - print" - S ZTRTN="REPORT^PXRMETCO" - S ZTSK=1 - S PXRMQUE=0 - S PXRMQUE=$$DEVICE^PXRMXQUE(ZTRTN,ZTDESC,.ZTSAVE,.%ZIS,.ZTSK) - I PXRMQUE=1 G EXIT - I PXRMQUE>0 S ^XTMP(PXRMXTMP,"PRZTSK")=PXRMQUE - Q - ; -EXIT ;Clean things up. - D ^%ZISC - D HOME^%ZIS - K IO("Q") - K DIRUT,DTOUT,DUOUT,POP,ZTREQ - I $D(ZTSK) D KILL^%ZTLOAD - K ZTSK,ZTQUEUED - K ^TMP("PXRMXTR",$J) - Q - ; -SAVE ;Save the variables for queing. - S ZTSAVE("IEN")="" - S ZTSAVE("PXRMSTRT")="" - S ZTSAVE("PXRMSTOP")="" - Q - ; - ; -QUE ;BOOKMARK - NOT USED - ;Queue the MST synchronization job. - N DIR,DTOUT,DUOUT,MINDT,SDTIME,STIME,X,Y - S MINDT=$$NOW^XLFDT - 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(0)="DAU"_U_MINDT_"::RSX" - D ^DIR - I $D(DTOUT)!$D(DUOUT) Q - S SDTIME=Y - K DIR - S DIR(0)="YA" - S DIR("A")="Do you want to run the MST synchronization at the same time every day? " - S DIR("B")="Y" - D ^DIR - I $D(DTOUT)!$D(DUOUT) Q - I Y S STIME="1."_$P(SDTIME,".",2) - E S STIME=-1 - ; - ;Put the task into the queue. - K ZTSAVE - ;S ZTSAVE("START")=SDTIME - S ZTSAVE("STIME")=STIME - S ZTRTN="SYNCH^PXRMMST" - S ZTDESC="Clinical Reminders MST synchronization job" - S ZTDTH=SDTIME - S ZTIO="" - D ^%ZTLOAD - W !,"Task number ",ZTSK," queued." - Q +PXRMETCO ; SLC/PJH - QUERI Extract Compliance Report ;01/19/2005 + ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005 + ; + ; +ADHOC(IEN,PXRMSTRT,PXRMSTOP) ;Ad Hoc Conformance Report + D DUMMY1^PXRMRUTL + Q + ; + D JOB + Q + ; + ;BOOKMARK - cloned from PXRMETX, needs modifying to avoid patient list + ;update. Build ^TMP("PXRMETX",$J) for report + ; +REPORT ;Initialise + K ^TMP("PXRMETX",$J) + ;Workfile node for ^TMP + S PXRMNODE="PXRMRULE" + ;Get details from parameter file + N DATA,DATES,LIST,NAME,PARTYPE,TEXT + ;N PERIOD,TEXT,YEAR + S DATA=$G(^PXRM(810.2,IEN,0)) + ; + ;Determine Extract Name and period + S NAME=$P(DATA,U),PARTYPE=$P(DATA,U,2) + ;S YEAR=$P(NEXT,"/",2),PERIOD=$P(NEXT,"/") + ;Calculate report period start and end dates + ;D CALC^PXRMEUT(NEXT,.PXRMSTRT,.PXRMSTOP) + ;Determine output name for patient list and extract summary + S DATES=$$FMTE^XLFDT(PXRMSTRT)_" - "_$$FMTE^XLFDT(PXRMSTOP) + ; + ;Bookmark - Needs inventive patient list names + S LIST=NAME_" REPORT "_DATES + ;Process (single) Denominator rule into patient list + N SEQ,SUB,SUFFIX + S SEQ="" + F S SEQ=$O(^PXRM(810.2,IEN,10,"B",SEQ)) Q:'SEQ D + .S SUB=$O(^PXRM(810.2,IEN,10,"B",SEQ,"")) Q:'SUB + .S DATA=$G(^PXRM(810.2,IEN,10,SUB,0)) Q:DATA="" + .S PXRMRULE=$P(DATA,U,2) Q:'PXRMRULE + .S SUFFIX=$P(DATA,U,3) + .I SUFFIX="" S SUFFIX="DENOMINATOR "_SEQ + .;Create new patient list + .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) + .;Process reminders + .D REM^PXRMETXR(SUB,PXRMLIST) + ; + ;Bookmark - Report stuff goes here + ;Update totals section + N APPL,DUE,DATA,ETYP,EVAL + N FAPPL,FCNT,FDATA,FDUE,FEVAL,FGNAM,FIND,FNAPPL,FNDUE,FSEQ + N NAPPL,NDUE,PXRMLIST,RCNT,RIEN,RSEQ,SEQ + S SEQ=0,CNT=1 + F S SEQ=$O(^TMP("PXRMETX",$J,SEQ)) Q:'SEQ D + .S RCNT=0,RSEQ=0 + .F S RCNT=$O(^TMP("PXRMETX",$J,SEQ,RCNT)) Q:'RCNT D + ..S DATA=$G(^TMP("PXRMETX",$J,SEQ,RCNT)) Q:'DATA + ..S RIEN=$P(DATA,U),PXRMLIST=$P(DATA,U,5) + ..S EVAL=$P(DATA,U,2),APPL=$P(DATA,U,3),DUE=$P(DATA,U,4) + ..S NAPPL=EVAL-APPL,NDUE=APPL-DUE + ..S CNT=CNT+1,RSEQ=RSEQ+1 + ..;bookmark - write patient line + ..;For each count type + ..S ETYP="",FCNT=CNT + ..F S ETYP=$O(^TMP("PXRMETX",$J,SEQ,RCNT,ETYP)) Q:ETYP="" D + ...;For each term + ...S FIND=0,FSEQ=0 + ...F S FIND=$O(^TMP("PXRMETX",$J,SEQ,RCNT,ETYP,FIND)) Q:FIND="" D + ....;Update finding totals + ....S FDATA=$G(^TMP("PXRMETX",$J,SEQ,RCNT,ETYP,FIND)),FCNT=FCNT+1 + ....S FEVAL=$P(FDATA,U,2),FAPPL=$P(FDATA,U,3),FDUE=$P(FDATA,U,4) + ....S FNAPPL=FEVAL-FAPPL,FNDUE=FAPPL-FDUE + ....S FSEQ=FSEQ+1,FGNAM=$P(DATA,U,9) + ....;Bookmark - write finding line + ..;Update CNT + ..S CNT=FCNT + Q + ; + ;Determine whether the report should be queued. +JOB ; + N %ZIS,ZTDESC,ZTSAVE,ZTRTN,ZTSK + S DBDUZ=DUZ + D SAVE^PXRMXQUE + S %ZIS="Q" + S ZTDESC="QUERI Compliance Report - print" + S ZTRTN="REPORT^PXRMETCO" + S ZTSK=1 + S PXRMQUE=0 + S PXRMQUE=$$DEVICE^PXRMXQUE(ZTRTN,ZTDESC,.ZTSAVE,.%ZIS,.ZTSK) + I PXRMQUE=1 G EXIT + I PXRMQUE>0 S ^XTMP(PXRMXTMP,"PRZTSK")=PXRMQUE + Q + ; +EXIT ;Clean things up. + D ^%ZISC + D HOME^%ZIS + K IO("Q") + K DIRUT,DTOUT,DUOUT,POP,ZTREQ + I $D(ZTSK) D KILL^%ZTLOAD + K ZTSK,ZTQUEUED + K ^TMP("PXRMXTR",$J) + Q + ; +SAVE ;Save the variables for queing. + S ZTSAVE("IEN")="" + S ZTSAVE("PXRMSTRT")="" + S ZTSAVE("PXRMSTOP")="" + Q + ; + ; +QUE ;BOOKMARK - NOT USED + ;Queue the MST synchronization job. + N DIR,DTOUT,DUOUT,MINDT,SDTIME,STIME,X,Y + S MINDT=$$NOW^XLFDT + 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")="It must be after "_$$FMTE^XLFDT(MINDT,"5Z")_" " + S DIR(0)="DAU"_U_MINDT_"::RSX" + D ^DIR + I $D(DTOUT)!$D(DUOUT) Q + S SDTIME=Y + K DIR + S DIR(0)="YA" + S DIR("A")="Do you want to run the MST synchronization at the same time every day? " + S DIR("B")="Y" + D ^DIR + I $D(DTOUT)!$D(DUOUT) Q + I Y S STIME="1."_$P(SDTIME,".",2) + E S STIME=-1 + ; + ;Put the task into the queue. + K ZTSAVE + ;S ZTSAVE("START")=SDTIME + S ZTSAVE("STIME")=STIME + S ZTRTN="SYNCH^PXRMMST" + S ZTDESC="Clinical Reminders MST synchronization job" + S ZTDTH=SDTIME + S ZTIO="" + D ^%ZTLOAD + W !,"Task number ",ZTSK," queued." + Q diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMETH.m b/r/CLINICAL_REMINDERS-PXRM/PXRMETH.m index 731b27b8..3988cdf4 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMETH.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMETH.m @@ -1,339 +1,329 @@ -PXRMETH ; SLC/PJH - Reminder Extract History ;10/11/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ;Main entry point for PXRM EXTRACT HISTORY -START(EDIEN) ; - ;EDIEN is the extract definition 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 NPERIOD=$P(DATA,U,6),NSDATE=$P(DATA,U,7) - ;Default view is in date created order - S PXRMVIEW="D" - S X="IORESET" - D ENDR^%ZISS - S VALMCNT=0 - D EN^VALM("PXRM EXTRACT HISTORY") - 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 - Q - ; -EXIT ;Exit code - K ^TMP("PXRMETH",$J) - K ^TMP("PXRMETHH",$J) - D CLEAN^VALM10 - D FULL^VALM1 - S VALMBCK="Q" - Q - ; -EXTRACT(EDIEN) ;Run Extract/Transmission - ;Reset screen mode - W IORESET - ;Refresh on exit - S VALMBCK="R" - ; - ;Get details from parameter file - 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) - ;Determine Extract Name and Frequency - S NAME=$P(DATA,U),FREQ=$P(DATA,U,3),NEXT=$P(DATA,U,6),RTN="PXRMETX" - ;Save next scheduled extract - S SNEXT=NEXT - ;Select extract period -EXSEL D SELECT(FREQ,.NEXT) Q:$D(DUOUT)!$D(DTOUT) - ;Warn if period is still open - D WARN(NEXT,.STATUS) - ;Option to continue - S TEXT="Are you sure you want to run a "_NAME_" extract for "_$TR(NEXT,"/"," ") -SURE ; - S ANS=$$ASKYN^PXRMEUT("N",TEXT,RTN,1) Q:$D(DUOUT)!$D(DTOUT) Q:'ANS - ;Purge options -PLIST ; - S PLISTPUG="N" D ASK^PXRMXD(.PLISTPUG,"Purge Patient List after 5 years?: ",5) - G:$D(DUOUT) SURE Q:$D(DTOUT) - S EXSUMPUG="N" D ASK^PXRMXD(.EXSUMPUG,"Purge Extract Summary after 5 years?: ",5) - G:$D(DUOUT) PLIST Q:$D(DTOUT) - ;Option to transmit - S TEXT="Transmit extract results to AAC" - I NAT="N" S XMIT=$$ASKYN^PXRMEUT("N",TEXT,RTN,3) Q:$D(DUOUT)!$D(DTOUT) - E S XMIT=0 - ;Option to replace scheduled run - S REPL=0 - I XMIT,SNEXT=NEXT,STATUS="COMPLETE" D Q:$D(DUOUT)!$D(DTOUT) - .S TEXT="Does this extract replace the scheduled extract" - .S REPL=$$ASKYN^PXRMEUT("N",TEXT,RTN,4) Q:$D(DUOUT)!$D(DTOUT) - ; - ;Note that the manual extract does not update 810.2 - ;exept if the selected period is the same as the scheduled - ;period AND this period is complete - ; - ;Default is to extract and transmit and not update 810.2 - S MODE=2 I 'XMIT S MODE=3 - ;Update 810.2 if this extract is for current completed period - I REPL S MODE=0 I 'XMIT S MODE=1 - ; - ;Extract/transmission run - N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE - S ZTDESC="Reminder Extract "_NAME - S ZTRTN="RUN^PXRMETX(EDIEN,NEXT,MODE,EXSUMPUG)" - S ZTSAVE("EDIEN")="" - S ZTSAVE("MODE")="" - S ZTSAVE("NEXT")="" - S ZTSAVE("PLISTPUG")="" - S ZTSAVE("EXSUMPUG")="" - S ZTIO="" - ; - ;Select and verify start date/time for task - N DIR,DTOUT,DUOUT,MINDT,SDTIME,STIME,X,Y - S MINDT=$$NOW^XLFDT - W !,"Queue a "_ZTDESC_" for "_NEXT - 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(0)="DAU"_U_MINDT_"::RSX" - D ^DIR - I $D(DTOUT)!$D(DUOUT) Q - S SDTIME=Y - ; - ;Put the task into the queue. - S ZTDTH=SDTIME - 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. - F D Q:$D(DTOUT)!$D(DUOUT) Q:SEL]"" - .S DIR("A")="Select EXTRACT PERIOD " - .I FREQ="M" D - ..S DIR("A")=DIR("A")_"(Mnn/yyyy)" - ..S DIR(0)="F"_U_"7:8"_U_"K:'$$VALID^PXRMETH(FREQ,X) X" - .I FREQ="Q" D - ..S DIR("A")=DIR("A")_"(Qnn/yyyy)" - ..S DIR(0)="F"_U_"7:7"_U_"K:'$$VALID^PXRMETH(FREQ,X) X" - .I FREQ="Y" D - ..S DIR("A")=DIR("A")_"(yyyy)" - ..S DIR(0)="N"_U_"2000:2050"_U_"K:(X'?4N) X" - .;Default is next period - .S DIR("B")=NEXT - .W ! D ^DIR Q:$D(DTOUT)!$D(DUOUT) - .;Calculate beginning and end dates for period - .S Y=$$UP^XLFSTR(Y) D CALC^PXRMEUT(Y,.BDATE,.EDATE) - .;Abort if period has not started - .I $$FMDIFF^XLFDT(BDATE,$$NOW^XLFDT)>0 D Q - ..S FDATE=$$FMTE^XLFDT(BDATE,5) - ..W !,"ERROR -This period does not start until "_FDATE,*7 - .S SEL=Y - 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" - 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 - .;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) - ; - ;Rebuild workfile - D BLDLIST^PXRMETH1(EDIEN) - ;Refresh - S VALMBCK="R" - Q - ; -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) - S VALMBCK="R" - Q - ; -VALID(FREQ,INP) ;Validate Period input - W ! - N PERIOD,YEAR - ;Convert to upper case - S INP=$$UP^XLFSTR(INP) - ;General format - I $E(INP)'=FREQ D EN^DDIOL("Format should be "_FREQ_"nn/yyyy") Q 0 - S PERIOD=$P(INP,"/"),YEAR=$P(INP,"/",2) - S PERIOD=$P(PERIOD,FREQ,2) - ;All runs - I (YEAR<2000)!(YEAR>2050) D EN^DDIOL("Year should be in range 2000-2050") Q 0 - ;Quarterly run - I FREQ="Q",(PERIOD>4)!(PERIOD<1) D EN^DDIOL("Quarter should be in range 1-4") Q 0 - ;Monthly run - I FREQ="M",(PERIOD>12)!(PERIOD<1) D EN^DDIOL("Month should be in range 1-12") Q 0 - ;Otherwise - Q 1 - ; -VIEW ;Select view - W IORESET - S VALMBCK="R" - N X,Y,CODE,DIR - K DIROUT,DIRUT,DTOUT,DUOUT - S DIR(0)="S"_U_"D:Sort by Creation Date;" - S DIR(0)=DIR(0)_"P:Sort by Extract Period;" - S DIR("A")="TYPE OF VIEW" - S DIR("B")=$S(PXRMVIEW="P":"D",1:"P") - S DIR("?")="Select from the codes displayed. For detailed help type ??" - ;BOOKMARK - HELP NEEDS MOVING - S DIR("??")=U_"D HELP^PXRMSEL2(3)" - D ^DIR K DIR - I $D(DIROUT) S DTOUT=1 - I $D(DTOUT)!($D(DUOUT)) Q - ;Change display type - S PXRMVIEW=Y - ; - ;Rebuild Workfile - D BLDLIST^PXRMETH1(EDIEN),HDR - Q - ; -WARN(NEXT,STATUS) ;Warn if period is not completed - N BDATE,EDATE,FDATE - ;Calculate beginning and end dates for period - D CALC^PXRMEUT(NEXT,.BDATE,.EDATE) - ;No warning if period end date is a prior date - I $$FMDIFF^XLFDT($$NOW^XLFDT,EDATE)>0 S STATUS="COMPLETE" Q - ;Else Format date - S FDATE=$$FMTE^XLFDT(EDATE,5),STATUS="INCOMPLETE" - ;And Warn that period end date is a future date - 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 - ; +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(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,IEN,0)) + S NPERIOD=$P(DATA,U,6),NSDATE=$P(DATA,U,7) + ;Default view is in date created order + S PXRMVIEW="D" + S X="IORESET" + D ENDR^%ZISS + S VALMCNT=0 + D EN^VALM("PXRM EXTRACT HISTORY") + Q + ; +ENTRY ;Entry code + D BLDLIST^PXRMETH1(IEN),XQORM + Q + ; +EXIT ;Exit code + K ^TMP("PXRMETH",$J) + K ^TMP("PXRMETHH",$J) + D CLEAN^VALM10 + D FULL^VALM1 + 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,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 + ;Refresh on exit + S VALMBCK="R" + ; + ;Get details from parameter file + 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,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" + ;Save next scheduled extract + S SNEXT=NEXT + ;Select extract period +EXSEL D SELECT(FREQ,.NEXT) Q:$D(DUOUT)!$D(DTOUT) + ;Warn if period is still open + D WARN(NEXT,.STATUS) + ;Option to continue + S TEXT="Are you sure you want to run a "_NAME_" extract for "_$TR(NEXT,"/"," ") +SURE ; + S ANS=$$ASKYN^PXRMEUT("N",TEXT,RTN,1) Q:$D(DUOUT)!$D(DTOUT) Q:'ANS + ;Purge options +PLIST ; + S PLISTPUG="N" D ASK^PXRMXD(.PLISTPUG,"Purge Patient List after 5 years?: ",5) + G:$D(DUOUT) SURE Q:$D(DTOUT) + S EXSUMPUG="N" D ASK^PXRMXD(.EXSUMPUG,"Purge Extract Summary after 5 years?: ",5) + G:$D(DUOUT) PLIST Q:$D(DTOUT) + ;Option to transmit + S TEXT="Transmit extract results to AAC" + I NAT="N" S XMIT=$$ASKYN^PXRMEUT("N",TEXT,RTN,3) Q:$D(DUOUT)!$D(DTOUT) + E S XMIT=0 + ;Option to replace scheduled run + S REPL=0 + I XMIT,SNEXT=NEXT,STATUS="COMPLETE" D Q:$D(DUOUT)!$D(DTOUT) + .S TEXT="Does this extract replace the scheduled extract" + .S REPL=$$ASKYN^PXRMEUT("N",TEXT,RTN,4) Q:$D(DUOUT)!$D(DTOUT) + ; + ;Note that the manual extract does not update 810.2 + ;exept if the selected period is the same as the scheduled + ;period AND this period is complete + ; + ;Default is to extract and transmit and not update 810.2 + S MODE=2 I 'XMIT S MODE=3 + ;Update 810.2 if this extract is for current completed period + I REPL S MODE=0 I 'XMIT S MODE=1 + ; + ;Extract/transmission run + N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE + S ZTDESC="Reminder Extract "_NAME + S ZTRTN="RUN^PXRMETX(IEN,NEXT,MODE,EXSUMPUG)" + S ZTSAVE("IEN")="" + S ZTSAVE("MODE")="" + S ZTSAVE("NEXT")="" + S ZTSAVE("PLISTPUG")="" + S ZTSAVE("EXSUMPUG")="" + S ZTIO="" + ; + ;Select and verify start date/time for task + N DIR,DTOUT,DUOUT,MINDT,SDTIME,STIME,X,Y + S MINDT=$$NOW^XLFDT + W !,"Queue a "_ZTDESC_" for "_NEXT + 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(0)="DAU"_U_MINDT_"::RSX" + D ^DIR + I $D(DTOUT)!$D(DUOUT) Q + S SDTIME=Y + ; + ;Put the task into the queue. + S ZTDTH=SDTIME + D ^%ZTLOAD + W !,"Task number ",ZTSK," queued." H 2 + ; + S VALMBCK="Q" + Q + ; +SELECT(FREQ,SEL) ;Select extract period + ; + N BDATE,EDATE,DA,DIE,DIK,DIR,DR,FDATE,VALID,X + ;Get the new name. + F D Q:$D(DTOUT)!$D(DUOUT) Q:SEL]"" + .S DIR("A")="Select EXTRACT PERIOD " + .I FREQ="M" D + ..S DIR("A")=DIR("A")_"(Mnn/yyyy)" + ..S DIR(0)="F"_U_"7:8"_U_"K:'$$VALID^PXRMETH(FREQ,X) X" + .I FREQ="Q" D + ..S DIR("A")=DIR("A")_"(Qnn/yyyy)" + ..S DIR(0)="F"_U_"7:7"_U_"K:'$$VALID^PXRMETH(FREQ,X) X" + .I FREQ="Y" D + ..S DIR("A")=DIR("A")_"(yyyy)" + ..S DIR(0)="N"_U_"2000:2050"_U_"K:(X'?4N) X" + .;Default is next period + .S DIR("B")=NEXT + .W ! D ^DIR Q:$D(DTOUT)!$D(DUOUT) + .;Calculate beginning and end dates for period + .S Y=$$UP^XLFSTR(Y) D CALC^PXRMEUT(Y,.BDATE,.EDATE) + .;Abort if period has not started + .I $$FMDIFF^XLFDT(BDATE,$$NOW^XLFDT)>0 D Q + ..S FDATE=$$FMTE^XLFDT(BDATE,5) + ..W !,"ERROR -This period does not start until "_FDATE,*7 + .S SEL=Y + Q + ; +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 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(PXRMXIEN) + ; + ;Rebuild workfile + D BLDLIST^PXRMETH1(IEN) + ;Refresh + S VALMBCK="R" + Q + ; +TRHIST ;Transmission History + 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 + ; +VALID(FREQ,INP) ;Validate Period input + W ! + N PERIOD,YEAR + ;Convert to upper case + S INP=$$UP^XLFSTR(INP) + ;General format + I $E(INP)'=FREQ D EN^DDIOL("Format should be "_FREQ_"nn/yyyy") Q 0 + S PERIOD=$P(INP,"/"),YEAR=$P(INP,"/",2) + S PERIOD=$P(PERIOD,FREQ,2) + ;All runs + I (YEAR<2000)!(YEAR>2050) D EN^DDIOL("Year should be in range 2000-2050") Q 0 + ;Quarterly run + I FREQ="Q",(PERIOD>4)!(PERIOD<1) D EN^DDIOL("Quarter should be in range 1-4") Q 0 + ;Monthly run + I FREQ="M",(PERIOD>12)!(PERIOD<1) D EN^DDIOL("Month should be in range 1-12") Q 0 + ;Otherwise + Q 1 + ; +VIEW ;Select view + ; + W IORESET + ; + S VALMBCK="R" + ; + N X,Y,CODE,DIR + K DIROUT,DIRUT,DTOUT,DUOUT + S DIR(0)="S"_U_"D:Sort by Creation Date;" + S DIR(0)=DIR(0)_"P:Sort by Extract Period;" + S DIR("A")="TYPE OF VIEW" + S DIR("B")=$S(PXRMVIEW="P":"D",1:"P") + S DIR("?")="Select from the codes displayed. For detailed help type ??" + ;BOOKMARK - HELP NEEDS MOVING + S DIR("??")=U_"D HELP^PXRMSEL2(3)" + D ^DIR K DIR + I $D(DIROUT) S DTOUT=1 + I $D(DTOUT)!($D(DUOUT)) Q + ;Change display type + S PXRMVIEW=Y + ; + ;Rebuild Workfile + D BLDLIST^PXRMETH1(IEN),HDR + Q + ; +WARN(NEXT,STATUS) ;Warn if period is not completed + N BDATE,EDATE,FDATE + ;Calculate beginning and end dates for period + D CALC^PXRMEUT(NEXT,.BDATE,.EDATE) + ;No warning if period end date is a prior date + I $$FMDIFF^XLFDT($$NOW^XLFDT,EDATE)>0 S STATUS="COMPLETE" Q + ;Else Format date + S FDATE=$$FMTE^XLFDT(EDATE,5),STATUS="INCOMPLETE" + ;And Warn that period end date is a future date + W !!,"WARNING -This period is not complete until "_FDATE + Q diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMETH1.m b/r/CLINICAL_REMINDERS-PXRM/PXRMETH1.m index 987aa45d..a53f5a4c 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMETH1.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMETH1.m @@ -1,91 +1,88 @@ -PXRMETH1 ; SLC/PJH - Reminder Extract History ;09/07/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; -BLDLIST(EDIEN) ;Build workfile - ;EDIEN is the extract definition IEN. - N IND,FMTSTR,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) - ;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) - Q - ; -HELP(CALL) ;General help text routine. - 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." - ; - I CALL=3 D - .S HTEXT(1)="Select Y to send the results of the Extract to the National Austin database." - ; - I CALL=4 D - .S HTEXT(4)="Select Y to overwrite the previous Extract stored in the National Austin Database." - D HELP^PXRMEUT(.HTEXT) - 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 - ;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 PERIOD="99" - .F S PERIOD=$O(^PXRMXT(810.3,"D",EDIEN,YEAR,PERIOD),-1) Q:PERIOD="" D - ..S IND="" - ..F S IND=$O(^PXRMXT(810.3,"D",EDIEN,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) - ...S AUTO=$P($G(^PXRMXT(810.3,IND,4)),U,5) - ...S AUTO=$S(AUTO="A":"Y",1:"N") - ...S HL7ID=$O(^PXRMXT(810.3,IND,5,"B",""),-1),XDATE="",HL7SUB="" - ...I HL7ID S HL7SUB=$O(^PXRMXT(810.3,IND,5,"B",HL7ID,"")) - ...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 - 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 - ;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 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) - ..S AUTO=$P($G(^PXRMXT(810.3,IND,4)),U,5) - ..S AUTO=$S(AUTO="A":"Y",1:"N") - ..S HL7ID=$O(^PXRMXT(810.3,IND,5,"B",""),-1),XDATE="",HL7SUB="" - ..I HL7ID S HL7SUB=$O(^PXRMXT(810.3,IND,5,"B",HL7ID,"")) - ..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 - Q - ; +PXRMETH1 ; SLC/PJH - Reminder Extract History ;07/24/2006 + ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21 + ; +BLDLIST(IEN) ;Build workfile + N IND,PLIST + K ^TMP("PXRMETH",$J) + ;Build list of extract summaries in period order + I PXRMVIEW="P" D LIST1(.PLIST,.IEN) + ;Build list of extract summaries in date order + 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 + ; +HELP(CALL) ;General help text routine. + N HTEXT + I CALL=1 D + .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 + .S HTEXT(1)="Select Y to send the results of the Extract to the National Austin database." + ; + I CALL=4 D + .S HTEXT(4)="Select Y to overwrite the previous Extract stored in the National Austin Database." + D HELP^PXRMEUT(.HTEXT) + Q + ; +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",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",IEN,YEAR,PERIOD),-1) Q:PERIOD="" D + ..S IND="" + ..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) + ...S AUTO=$P($G(^PXRMXT(810.3,IND,4)),U,5) + ...S AUTO=$S(AUTO="A":"Y",1:"N") + ...S HL7ID=$O(^PXRMXT(810.3,IND,5,"B",""),-1),XDATE="",HL7SUB="" + ...I HL7ID S HL7SUB=$O(^PXRMXT(810.3,IND,5,"B",HL7ID,"")) + ...I HL7SUB S XDATE=$P($G(^PXRMXT(810.3,IND,5,HL7SUB,0)),U,2) + ...I 'XDATE S XDATE="Not Transmitted" + ...S VALMCNT=VALMCNT+1 + ...S LIST(VALMCNT,0)=$$FRE(VALMCNT,NAME,EDATE,XDATE,AUTO) + ...S IEN(VALMCNT)=IND + S LIST("VALMCNT")=VALMCNT + Q + ; +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="",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",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") + ..S HL7ID=$O(^PXRMXT(810.3,IND,5,"B",""),-1),XDATE="",HL7SUB="" + ..I HL7ID S HL7SUB=$O(^PXRMXT(810.3,IND,5,"B",HL7ID,"")) + ..I HL7SUB S XDATE=$P($G(^PXRMXT(810.3,IND,5,HL7SUB,0)),U,2) + ..I 'XDATE S XDATE="Not Transmitted" + ..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 diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMETM.m b/r/CLINICAL_REMINDERS-PXRM/PXRMETM.m index 74750340..69724c3b 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMETM.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMETM.m @@ -1,190 +1,199 @@ -PXRMETM ; SLC/PKR/PJH - Extract/Transmission Management ;09/06/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ;Main entry point for PXRM EXTRACT MANAGEMENT -START N PXRMDONE,VALMBCK,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD - S X="IORESET" - D ENDR^%ZISS - S VALMCNT=0 - D EN^VALM("PXRM EXTRACT MANAGEMENT") - W IORESET - D KILL^%ZISS - Q - ; -BLDLIST ;Build workfile - K ^TMP("PXRMETM",$J) - N IEN,IND,PLIST - D LIST("PXRMETM",.VALMCNT) - Q - ; -ENTRY ;Entry code - D BLDLIST,XQORM - Q - ; -EXIT ;Exit code - K ^TMP("PXRMETM",$J) - K ^TMP("PXRMETMH",$J) - D CLEAN^VALM10 - D FULL^VALM1 - S VALMBCK="Q" - 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 - ; -HLP ;Help code - N ORU,ORUPRMT,SUB,XQORM - S SUB="PXRMETMH" - D EN^VALM("PXRM EXTRACT HELP") - Q - ; -INIT ;Init - S VALMCNT=0 - 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 - ; -XQORM S XQORM("#")=$O(^ORD(101,"B","PXRM EXTRACT MANAGEMENT SELECT ENTRY",0))_U_"1:"_VALMCNT - S XQORM("A")="Select Item: " - Q - ; -XSEL ;PXRM EXTRACT MANAGEMENT SELECT ENTRY validation - N EDIEN,SEL - 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 EDIEN=^TMP("PXRMETM",$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_"EDM:Extract Definition Management;" - S DIR(0)=DIR(0)_"VSE:Examine/Schedule Extract;" - S DIR("A")="Select Action" - S DIR("B")="VSE" - S DIR("?")="Select from the codes displayed. For detailed help type ??" - S DIR("??")=U_"D HELP^PXRMETM(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 Definitions - I OPTION="EDM" D START^PXRMEPED(EDIEN) - ; - ;Examine/Run Extract - I OPTION="VSE" D START^PXRMETH(EDIEN) - ; - ;Examine/Run Extract - I OPTION="ERE" D GENSEL(EDIEN) - ; - S VALMBCK="R" - Q - ; +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 +START N PXRMDONE,VALMBCK,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD + S X="IORESET" + D ENDR^%ZISS + S VALMCNT=0 + D EN^VALM("PXRM EXTRACT MANAGEMENT") + W IORESET + D KILL^%ZISS + Q + ; +BLDLIST ;Build workfile + K ^TMP("PXRMETM",$J) + N IEN,IND,PLIST + 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 + D BLDLIST,XQORM + Q + ; +EXIT ;Exit code + K ^TMP("PXRMETM",$J) + K ^TMP("PXRMETMH",$J) + D CLEAN^VALM10 + D FULL^VALM1 + S VALMBCK="Q" + Q + ; +HDR ; Header code + S VALMHDR(1)="Available Extract Definitions:" + S VALMSG="+ Next Screen - Prev Screen ?? More Actions" + Q + ; +HLP ;Help code + N ORU,ORUPRMT,SUB,XQORM + S SUB="PXRMETMH" + D EN^VALM("PXRM EXTRACT HELP") + Q + ; +INIT ;Init + S VALMCNT=0 + Q + ; +PEXIT ;Protocol exit code + S VALMSG="+ Next Screen - Prev Screen ?? More Actions" + ;Reset after page up/down etc + D XQORM + Q + ; +XQORM S XQORM("#")=$O(^ORD(101,"B","PXRM EXTRACT MANAGEMENT SELECT ENTRY",0))_U_"1:"_VALMCNT + S XQORM("A")="Select Item: " + Q + ; +XSEL ;PXRM EXTRACT MANAGEMENT SELECT ENTRY validation + N SEL,IEN + 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 IEN=^TMP("PXRMETM",$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_"EDM:Extract Definition Management;" + S DIR(0)=DIR(0)_"VSE:Examine/Schedule Extract;" + S DIR("A")="Select Action" + S DIR("B")="VSE" + S DIR("?")="Select from the codes displayed. For detailed help type ??" + S DIR("??")=U_"D HELP^PXRMETM(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 Definitions + I OPTION="EDM" D + .D START^PXRMEPED(IEN) + ; + ;Examine/Run Extract + I OPTION="VSE" D + .D START^PXRMETH(IEN) + ; + ;Examine/Run Extract + 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 diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMETT.m b/r/CLINICAL_REMINDERS-PXRM/PXRMETT.m index eef48d60..d940faa2 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMETT.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMETT.m @@ -1,212 +1,217 @@ -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 -START(IEN) N TOGGLE,TOGGLE1,VALMBCK,VALMBG,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD - S X="IORESET" - D ENDR^%ZISS - S VALMCNT=0,TOGGLE=0,TOGGLE1=0 - D EN^VALM("PXRM EXTRACT SUMMARY") - Q - ; -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 - ;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 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 STATION=$P(DATA,U,3),SARRAY="" - .D GETS^DIQ(4,STATION,99,"E","SARRAY") - .S SNAME=$G(SARRAY(4,STATION_",",99,"E")) - .I SNAME="" S SNAME=STATION - .S TOT=+$P(DATA,U,5),APPL=+$P(DATA,U,6),NAPPL=+$P(DATA,U,7) - .S DUE=+$P(DATA,U,8),NDUE=+$P(DATA,U,9) - .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,"IDX",VALMCNT,PLCNT)="" - ..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)=$$FRE(VALMCNT,RNAME,SNAME,TOT,APPL,NAPPL,DUE,NDUE) - .S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)="" - .;Finding totals - .I +FINDINGS>0 D FBLD(PATIENT) - ; - 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" - Q - ; -FBLD(PATIENT) ;Build finding list - N APPL,DATA,DUE,ETYP,EVAL,GNAM,GTYP - N NAPPL,NDUE,OGNAM,SEQ,SUB,TIEN,TNAME,TOTAL - S SUB=0,OGNAM="" - F S SUB=$O(^PXRMXT(810.3,IEN,3,IND,1,SUB)) Q:'SUB D - .S DATA=$G(^PXRMXT(810.3,IEN,3,IND,1,SUB,0)) Q:DATA="" - .S TIEN=$P(DATA,U,2) Q:'TIEN - .S TNAME=$P($G(^PXRMD(811.5,TIEN,0)),U) - .S SEQ=$P(DATA,U),ETYP=$P(DATA,U,3),GNAM=$P(DATA,U,9),GTYP=$P(DATA,U,10) - .S TOT=+$P(DATA,U,4),APPL=+$P(DATA,U,5),NAPPL=+$P(DATA,U,6) - .S DUE=+$P(DATA,U,7),NDUE=+$P(DATA,U,8) - .I OGNAM'=GNAM D - ..I OGNAM'="" D - ...S VALMCNT=VALMCNT+1 - ...S ^TMP("PXRMETT",$J,VALMCNT,0)="" - ...S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)="" - ..S OGNAM=GNAM,VALMCNT=VALMCNT+1 - ..S ^TMP("PXRMETT",$J,VALMCNT,0)=$$RJ^XLFSTR("Counting Group: ",21)_GNAM - ..S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)="",VALMCNT=VALMCNT+1 - ..S ^TMP("PXRMETT",$J,VALMCNT,0)=$J("",6)_$$LJ^XLFSTR($$TXT^PXRMEPM(ETYP,GTYP),49) - ..S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)="" - .S VALMCNT=VALMCNT+1 - .S ^TMP("PXRMETT",$J,VALMCNT,0)=$$FREF(VALMCNT,TNAME,SEQ,TOT,APPL,NAPPL,DUE,NDUE,ETYP) - .S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)="" - .I +PATIENT>0 D PBLD(IEN,IND,SUB) - 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 - ; -FRE(NUMBER,NAME,SNAME,TOT,APPL,NAPPL,DUE,NDUE) ;Format reminder entry - N TEMP,TNAME,TSOURCE - S TEMP=" " - S TNAME=SNAME_"/"_$E(NAME,1,35-$L(SNAME)) - S TEMP=TEMP_$$LJ^XLFSTR(TNAME,36," ") - S TEMP=TEMP_$$RJ^XLFSTR(TOT,8," ") - S TEMP=TEMP_$$RJ^XLFSTR(APPL,8," ") - S TEMP=TEMP_$$RJ^XLFSTR(NAPPL,7," ") - S TEMP=TEMP_$$RJ^XLFSTR(DUE,7," ") - S TEMP=TEMP_$$RJ^XLFSTR(NDUE,7," ") - Q TEMP - ; -FREF(NUMBER,NAME,SNAME,TOT,APPL,NAPPL,DUE,NDUE,ETYP) ;Format finding entry - N TEMP,TNAME,TSOURCE - S TEMP=" " - S TNAME=$E(NAME,1,31) - S TEMP=TEMP_" "_$$LJ^XLFSTR(TNAME,31," ") - S TEMP=TEMP_" "_$$RJ^XLFSTR(TOT,8," ") - I ETYP'="FC" D - .S TEMP=TEMP_$$RJ^XLFSTR(APPL,8," ") - .S TEMP=TEMP_$$RJ^XLFSTR(NAPPL,7," ") - .S TEMP=TEMP_$$RJ^XLFSTR(DUE,7," ") - .S TEMP=TEMP_$$RJ^XLFSTR(NDUE,7," ") - Q TEMP - ; -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 VALMSG="+ Next Screen - Prev Screen ?? More Actions" - Q - ; -HLP ;Help code - N ORU,ORUPRMT,XQORM - S SUB="PXRMETTH" - D EN^VALM("PXRM EXTRACT HELP") - Q - ; -INIT ;Init - S VALMCNT=0 - 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 - ; -PEXIT ;Protocol exit code - S VALMSG="+ Next Screen - Prev Screen ?? More Actions" - D XQORM - Q - ; -PLIST(IEN) ;Patient list display - N IND,PLIEN,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 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 - ; +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" + D ENDR^%ZISS + S VALMCNT=0,TOGGLE=0,TOGGLE1=0 + D EN^VALM("PXRM EXTRACT SUMMARY") + Q + ; +BLDLIST(IEN,FINDINGS,PATIENT) ;Build workfile. + 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,SNAME,STATION,TOT + ;Build the list in alphabetical order. + 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($G(^PXD(811.9,RIEN,0)),U) + .S STATION=$P(DATA,U,3),SARRAY="" + .D GETS^DIQ(4,STATION,99,"E","SARRAY") + .S SNAME=$G(SARRAY(4,STATION_",",99,"E")) + .I SNAME="" S SNAME=STATION + .S TOT=+$P(DATA,U,5),APPL=+$P(DATA,U,6),NAPPL=+$P(DATA,U,7) + .S DUE=+$P(DATA,U,8),NDUE=+$P(DATA,U,9) + .S PLIST=$P(DATA,U,4) + .I PLIST,PLIST'=OLIST D + ..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,"IDX",VALMCNT,PLCNT)="" + ..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 + .I +FINDINGS>0 D FBLD(PATIENT) + ; + S ^TMP("PXRMETT",$J,"VALMCNT")=VALMCNT + ;M ^TMP("PXRMETT",$J)=LIST + Q + ; +FBLD(PATIENT) ;Build finding list + N APPL,DATA,DUE,ETYP,EVAL,GNAM,GTYP + N NAPPL,NDUE,OGNAM,SEQ,SUB,TIEN,TNAME,TOTAL + S SUB=0,OGNAM="" + F S SUB=$O(^PXRMXT(810.3,IEN,3,IND,1,SUB)) Q:'SUB D + .S DATA=$G(^PXRMXT(810.3,IEN,3,IND,1,SUB,0)) Q:DATA="" + .S TIEN=$P(DATA,U,2) Q:'TIEN + .S TNAME=$P($G(^PXRMD(811.5,TIEN,0)),U) + .S SEQ=$P(DATA,U),ETYP=$P(DATA,U,3),GNAM=$P(DATA,U,9),GTYP=$P(DATA,U,10) + .S TOT=+$P(DATA,U,4),APPL=+$P(DATA,U,5),NAPPL=+$P(DATA,U,6) + .S DUE=+$P(DATA,U,7),NDUE=+$P(DATA,U,8) + .I OGNAM'=GNAM D + ..I OGNAM'="" D + ...S VALMCNT=VALMCNT+1 + ...S ^TMP("PXRMETT",$J,VALMCNT,0)="" + ...S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)="" + ..S OGNAM=GNAM,VALMCNT=VALMCNT+1 + ..S ^TMP("PXRMETT",$J,VALMCNT,0)=$$RJ^XLFSTR("Counting Group: ",21)_GNAM + ..S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)="",VALMCNT=VALMCNT+1 + ..S ^TMP("PXRMETT",$J,VALMCNT,0)=$J("",6)_$$LJ^XLFSTR($$TXT^PXRMEPM(ETYP,GTYP),49) + ..S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)="" + .S VALMCNT=VALMCNT+1 + .S ^TMP("PXRMETT",$J,VALMCNT,0)=$$FREF(VALMCNT,TNAME,SEQ,TOT,APPL,NAPPL,DUE,NDUE,ETYP) + .S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)="" + .I +PATIENT>0 D PBLD(IEN,IND,SUB) + S VALMCNT=VALMCNT+1 + S ^TMP("PXRMETT",$J,VALMCNT,0)="" + S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)="" + 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) + ;Refresh + S VALMBCK="R",VALMBG=1 + Q + ; +FRE(NUMBER,NAME,SNAME,TOT,APPL,NAPPL,DUE,NDUE) ;Format reminder entry + N TEMP,TNAME,TSOURCE + S TEMP=" " + S TNAME=SNAME_"/"_$E(NAME,1,35-$L(SNAME)) + S TEMP=TEMP_$$LJ^XLFSTR(TNAME,36," ") + S TEMP=TEMP_$$RJ^XLFSTR(TOT,8," ") + S TEMP=TEMP_$$RJ^XLFSTR(APPL,8," ") + S TEMP=TEMP_$$RJ^XLFSTR(NAPPL,7," ") + S TEMP=TEMP_$$RJ^XLFSTR(DUE,7," ") + S TEMP=TEMP_$$RJ^XLFSTR(NDUE,7," ") + Q TEMP + ; +FREF(NUMBER,NAME,SNAME,TOT,APPL,NAPPL,DUE,NDUE,ETYP) ;Format finding entry + N TEMP,TNAME,TSOURCE + S TEMP=" " + S TNAME=$E(NAME,1,31) + S TEMP=TEMP_" "_$$LJ^XLFSTR(TNAME,31," ") + S TEMP=TEMP_" "_$$RJ^XLFSTR(TOT,8," ") + I ETYP'="FC" D + .S TEMP=TEMP_$$RJ^XLFSTR(APPL,8," ") + .S TEMP=TEMP_$$RJ^XLFSTR(NAPPL,7," ") + .S TEMP=TEMP_$$RJ^XLFSTR(DUE,7," ") + .S TEMP=TEMP_$$RJ^XLFSTR(NDUE,7," ") + 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 + ; +HLP ;Help code + N ORU,ORUPRMT,XQORM + S SUB="PXRMETTH" + D EN^VALM("PXRM EXTRACT HELP") + Q + ; +INIT ;Init + S VALMCNT=0 + 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 + ; +PEXIT ;Protocol exit code + S VALMSG="+ Next Screen - Prev Screen ?? More Actions" + D XQORM + Q + ; +PLIST(IEN) ;Patient list display + N IND,PLIEN,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 PLIEN=^TMP("PXRMETT",$J,"SEL",IND) + .D START^PXRMLPP(PLIEN) + ; + S VALMBCK="R" + Q diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMETX.m b/r/CLINICAL_REMINDERS-PXRM/PXRMETX.m index ee72d10e..1a6de244 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMETX.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMETX.m @@ -1,279 +1,272 @@ -PXRMETX ; SLC/PJH - Run Extract for QUERI ;11:42 AM 17 Dec 2008 - ;;2.0;CLINICAL REMINDERS;**4,6,7**;Feb 04, 2005;Build 1 - ; 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) - N IEN,LIST,LUVALUE,MODE,NEXT - S LUVALUE(1)=ID - D FIND^DIC(810.2,"","","U",.LUVALUE,"","","","","LIST") - ;Get ien of extract parameter - S IEN=$P(LIST("DILIST",2,1),U,1) Q:'IEN - ;Get next extract period - S NEXT=$P($G(^PXRM(810.2,IEN,0)),U,6) Q:NEXT="" - ;Node is Extract and Transmit - S MODE=$S($P($G(^PXRM(810.2,IEN,100)),U)="N":0,1:1) - ;Run extract - D RUN^PXRMETX(IEN,NEXT,MODE,PURGE) - ;Purge Extract Summary - D PRGES^PXRMETXU - ;Purge Patient Lists - D PRGPL^PXRMETXU - Q - ; -GETNAME(NAME,CLASS) ;Get the extract name. - I '$D(^PXRMXT(810.3,"B",NAME)) Q NAME - N CNT,NEW - S (CNT,NEW)=0 - ;If name exists concatenate count - F D Q:NEW - .I '$D(^PXRMXT(810.3,"B",NAME)) S NEW=1 Q - .S CNT=CNT+1,NAME=$P(NAME,"/")_"/"_$$RJ^XLFSTR(CNT,2,0) - Q NAME - ; -IHD ;Monthly IHD Extract, called from option PXRM EXTRACT VA-IHD QUERI. - D AUTO("VA-IHD QUERI","Y") - Q - ; -MAIL(NAME,NEXT,MODE) ;Completion mail message - N FREQ,TEXT - S FREQ="year" - I $E(NEXT)="M" S FREQ="month" - I $E(NEXT)="Q" S FREQ="quarter" - ; - I MODE=0 S TEXT="Extract and Transmission" - I MODE=1 S TEXT="Extract (No Transmission)" - I MODE=2 S TEXT="Manual Extract and Transmission" - I MODE=3 S TEXT="Manual Extract (No Transmission)" - ; - S TEXT=NAME_" "_TEXT_" completed for "_FREQ_" "_NEXT - D MES^PXRMEUT(TEXT) - Q - ; -MH ;Monthly MH Extract, called from option PXRM EXTRACT VA-MH QUERI. - D AUTO("VA-MH QUERI","Y") - Q - ; - ;Begin WV change wv/so 12/17/2008 - ; -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 - ;End WV change - ; -RUN(IEN,NEXT,MODE,PURGE) ;Process extract parameter - ; IEN is ien of Extract Parameter - ; NEXT is period to extract - ; MODE = 0 is extract and transmission - ; MODE = 1 is extract only - ; MODE = 2 is manual extract and transmission (doesn't update 810.2) - ; MODE = 3 is manual extract only (doesn't update 810.2) - ; - N CLASS,FDA,FDAIEN,MSG - N PXRMIDOD,PXRMLIST,PXRMNODE,PXRMRULE,PXRMSTRT,PXRMXIEN,PATCREAT,XNAME - N ITER - ;Initialise - K ^TMP("PXRMETX",$J),^TMP("PXRMETX1",$J) - ;Workfile node for ^TMP - S PXRMNODE="PXRMRULE" - ;Get details from parameter file - N DATA,INDP,INTP,LIST,NAME,PARTYPE,PERIOD,SNAME,TEXT,YEAR - ;Get class from extract parameter - S CLASS=$P($G(^PXRM(810.2,IEN,100)),U) - ;Otherwise default to local - I $G(CLASS)="" S CLASS="L" - ; - S DATA=$G(^PXRM(810.2,IEN,0)) - ;Determine Extract Name and period - S NAME=$P(DATA,U),PARTYPE=$P(DATA,U,2) - S YEAR=$P(NEXT,"/",2),PERIOD=$P(NEXT,"/") - ;Calculate report period start and end dates - D CALC^PXRMEUT(NEXT,.PXRMSTRT,.PXRMSTOP) - ;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 SEQ="" - F S SEQ=$O(^PXRM(810.2,IEN,10,"B",SEQ)) Q:'SEQ D - .S SUB=$O(^PXRM(810.2,IEN,10,"B",SEQ,"")) Q:'SUB - .S DATA=$G(^PXRM(810.2,IEN,10,SUB,0)) Q:DATA="" - .S PXRMRULE=$P(DATA,U,2) Q:'PXRMRULE - .S LIST=$P(DATA,U,3) Q:LIST="" - .I LIST["yyyy" S LIST=$P(LIST,"yyyy")_YEAR_$P(LIST,"yyyy",2) - .I LIST["nn" S LIST=$P(LIST,"nn")_$E(PERIOD,2,10)_$P(LIST,"nn",2) - .S INDP=+$P(DATA,U,4) - .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 - .; - .D START^PXRMRULE(PXRMRULE,PXRMLIST,PXRMNODE,PXRMSTRT,PXRMSTOP,IEN,YEAR,PERIOD,INDP,INTP,ITER) - .;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) - ;Create extract summary entry - S FDA(810.3,"+1,",.01)=NAME - S FDA(810.3,"+1,",.02)=PXRMSTRT - S FDA(810.3,"+1,",.03)=PXRMSTOP - S FDA(810.3,"+1,",.06)=$$NOW^XLFDT - S FDA(810.3,"+1,",1)=IEN - S FDA(810.3,"+1,",2)=PARTYPE - S FDA(810.3,"+1,",3)=$E(PERIOD,2,99) - S FDA(810.3,"+1,",4)=YEAR - S FDA(810.3,"+1,",5)=$S(MODE<2:"A",1:"M") - S FDA(810.3,"+1,",7)=$E(PERIOD) - I PURGE="Y" S FDA(810.3,"+1,",50)=1 - S FDA(810.3,"+1,",100)=CLASS - D UPDATE^DIE("","FDA","FDAIEN","MSG") - I $D(MSG) D AWRITE^PXRMUTIL("MSG") G EXIT - ; - ;Update extract summary from ^TMP - D UPDEX(FDAIEN(1)) - ; - ;Transmit results - I (MODE=0)!(MODE=2) D TRANS(FDAIEN(1)) - ; - ;Update extract parameters - I MODE<2 D UPDPAR - ; - ;Mail message that extract completed - D MAIL(NAME,NEXT,MODE) - ; -EXIT ;Clear workfile - K ^TMP("PXRMETX",$J),^TMP("PXRMETX1",$J) - Q - ; -TRANS(PXRMXIEN) ;Transmit HL7 messages - N HL7ID,NAME,NEXT - S HL7ID="" - D HL7^PXRM7API(PXRMXIEN,1,.HL7ID) - H 2 - ;Lock extract summary - D LOCK(PXRMXIEN) Q:$D(DUOUT) - ;Update run information - S NAME=$P($G(^PXRMXT(810.3,PXRMXIEN,0)),U) - S NEXT=$P($G(^PXRMXT(810.3,PXRMXIEN,4)),U,3) - S FDA(810.3,"?1,",.01)=NAME - S FDA(810.36,"?+2,?1,",.01)=HL7ID - S FDA(810.36,"?+2,?1,",.02)=$$NOW^XLFDT - D UPDATE^DIE("","FDA","","MSG") - ;Unlock extract summary - D UNLOCK(PXRMXIEN) - Q - ; -UPDEX(IEN) ;Update extract summary - N DUOUT - ;Lock extract summary - D LOCK(IEN) Q:$D(DUOUT) - ; - ;Update totals section - N APPL,CNT,DFN,DUE,DATA,ETYP,EVAL - N FAPPL,FCNT,FDATA,FDUE,FEVAL,FGNAM,FGSTA,FIND,FNAPPL,FNDUE,FSEQ - N GDATA,GSEQ,INST,NAPPL,NDUE,PCNT,PXRMLIST,RCNT,RIEN,RSEQ,SEQ,TEMP - S SEQ="",CNT=1,RSEQ=0 - F S SEQ=$O(^TMP("PXRMETX",$J,SEQ)) Q:SEQ="" D - .S INST=0 - .F S INST=$O(^TMP("PXRMETX",$J,SEQ,INST)) Q:'INST D - ..S RCNT="" - ..F S RCNT=$O(^TMP("PXRMETX",$J,SEQ,INST,RCNT)) Q:RCNT="" D - ...S DATA=$G(^TMP("PXRMETX",$J,SEQ,INST,RCNT)) Q:'DATA - ...S RIEN=$P(DATA,U,1),EVAL=$P(DATA,U,2),APPL=$P(DATA,U,3) - ...S NAPPL=$P(DATA,U,4),DUE=$P(DATA,U,5),NDUE=$P(DATA,U,6) - ...S PXRMLIST=$P(DATA,U,7) - ...S CNT=CNT+1,RSEQ=RSEQ+1 - ...S TEMP=$$RJ^XLFSTR(RSEQ,3,0)_U_RIEN_U_INST_U_PXRMLIST_U_EVAL_U_APPL_U_NAPPL_U_DUE_U_NDUE - ...S ^PXRMXT(810.3,IEN,3,RSEQ,0)=TEMP - ...S ^PXRMXT(810.3,IEN,3,"B",$P(TEMP,U,1),RSEQ)="" - ...;For each count type - ...S GSEQ="",FCNT=0 - ...F S GSEQ=$O(^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ)) Q:GSEQ="" D - ....S GDATA=$G(^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ)) - ....S FGNAM=$P(GDATA,U),ETYP=$P(GDATA,U,2),FGSTA=$P(GDATA,U,3) - ....;For each term - ....S FSEQ=0 - ....F S FSEQ=$O(^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ,FSEQ)) Q:FSEQ="" D - .....;Get the term ien - .....S FIND=$P($G(^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ,FSEQ)),U),FCNT=FCNT+1 - .....;Update finding totals - .....S FDATA=$G(^TMP("PXRMETX",$J,SEQ,INST,RCNT,GSEQ,FSEQ)) - .....S FEVAL=$P(FDATA,U,2),FAPPL=$P(FDATA,U,3),FNAPPL=$P(FDATA,U,4) - .....S FDUE=$P(FDATA,U,5),FNDUE=$P(FDATA,U,6) - .....S TEMP=FSEQ_U_$P(FIND,";")_U_ETYP_U_FEVAL_U_FAPPL_U_FNAPPL_U_FDUE_U_FNDUE_U_FGNAM_U_FGSTA - .....S ^PXRMXT(810.3,IEN,3,RSEQ,1,FCNT,0)=TEMP - .....; - .....;AGP REMOVE UNTIL A DECISION CAN BE MADE - .....;S DFN=0,PCNT=0 - .....;F S DFN=$O(^TMP("PXRMETX",$J,SEQ,INST,RCNT,GSEQ,FSEQ,DFN)) Q:DFN'>0 D - .....;.S PCNT=PCNT+1,^PXRMXT(810.3,IEN,3,RSEQ,1,FCNT,1,PCNT,0)=DFN - .....;I PCNT>0 S ^PXRMXT(810.3,IEN,3,RSEQ,1,FCNT,1,0)="^810.3316PA"_U_PCNT_U_PCNT - ....I FCNT>0 S ^PXRMXT(810.3,IEN,3,RSEQ,1,0)="^810.331I"_U_FCNT_U_FCNT - .I RSEQ>0 S ^PXRMXT(810.3,IEN,3,0)="^810.33I"_U_RSEQ_U_RSEQ - ;Unlock extract summary - D UNLOCK(IEN) - Q - ; - ;File locking -LOCK(PXRMXIEN) L +^PXRMXT(810.3,PXRMXIEN):0 - I '$T W !!?5,"Another user is using this extract summary" S DUOUT=1 - Q - ; -UNLOCK(PXRMXIEN) L -^PXRMXT(810.3,PXRMXIEN) Q - ; -UPDPAR ;Update parameters when run complete - N DATA,LAST,NEXT,PERIOD,TYPE,YEAR - S DATA=$G(^PXRM(810.2,IEN,0)),NEXT=$P(DATA,U,6),TYPE=$P(DATA,U,3) - ;Last run updated - S LAST=NEXT - ;Calculate next run - I TYPE="Y" S NEXT=NEXT+1 - I "QM"[TYPE D - .N NUM - .S PERIOD=$P(NEXT,"/",1),YEAR=$P(NEXT,"/",2) - .S NUM=$P(PERIOD,TYPE,2)+1 - .I TYPE="Q",NUM>4 S NUM=1,YEAR=YEAR+1 - .I TYPE="M",NUM>12 S NUM=1,YEAR=YEAR+1 - .S NEXT=TYPE_NUM_"/"_YEAR - ;Update last and next run fields - S $P(^PXRM(810.2,IEN,0),U,4,6)=LAST_U_$$NOW^XLFDT_U_NEXT - Q - ; +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) + N IEN,LIST,LUVALUE,MODE,NEXT + S LUVALUE(1)=ID + D FIND^DIC(810.2,"","","U",.LUVALUE,"","","","","LIST") + ;Get ien of extract parameter + S IEN=$P(LIST("DILIST",2,1),U,1) Q:'IEN + ;Get next extract period + S NEXT=$P($G(^PXRM(810.2,IEN,0)),U,6) Q:NEXT="" + ;Node is Extract and Transmit + S MODE=$S($P($G(^PXRM(810.2,IEN,100)),U)="N":0,1:1) + ;Run extract + D RUN^PXRMETX(IEN,NEXT,MODE,PURGE) + ;Purge Extract Summary + D PRGES^PXRMETXU + ;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 + ; +GETNAME(NAME,CLASS) ;Get the extract name. + I '$D(^PXRMXT(810.3,"B",NAME)) Q NAME + N CNT,NEW + S (CNT,NEW)=0 + ;If name exists concatenate count + F D Q:NEW + .I '$D(^PXRMXT(810.3,"B",NAME)) S NEW=1 Q + .S CNT=CNT+1,NAME=$P(NAME,"/")_"/"_$$RJ^XLFSTR(CNT,2,0) + Q NAME + ; +IHD ;Monthly IHD Extract, called from option PXRM EXTRACT VA-IHD QUERI. + D AUTO("VA-IHD QUERI","Y") + Q + ; +MAIL(NAME,NEXT,MODE) ;Completion mail message + N FREQ,TEXT + S FREQ="year" + I $E(NEXT)="M" S FREQ="month" + I $E(NEXT)="Q" S FREQ="quarter" + ; + I MODE=0 S TEXT="Extract and Transmission" + I MODE=1 S TEXT="Extract (No Transmission)" + I MODE=2 S TEXT="Manual Extract and Transmission" + I MODE=3 S TEXT="Manual Extract (No Transmission)" + ; + S TEXT=NAME_" "_TEXT_" completed for "_FREQ_" "_NEXT + D MES^PXRMEUT(TEXT) + Q + ; +MH ;Monthly MH Extract, called from option PXRM EXTRACT VA-MH QUERI. + D AUTO("VA-MH QUERI","Y") + 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 + ; NEXT is period to extract + ; MODE = 0 is extract and transmission + ; MODE = 1 is extract only + ; MODE = 2 is manual extract and transmission (doesn't update 810.2) + ; MODE = 3 is manual extract only (doesn't update 810.2) + ; + N CLASS,FDA,FDAIEN,MSG + N PXRMLIST,PXRMNODE,PXRMRULE,PXRMSTRT,PXRMXIEN,PATCREAT,XNAME + ;Initialise + K ^TMP("PXRMETX",$J),^TMP("PXRMETX1",$J) + ;Workfile node for ^TMP + S PXRMNODE="PXRMRULE" + ;Get details from parameter file + N DATA,INDP,INTP,LIST,NAME,PARTYPE,PERIOD,SNAME,TEXT,YEAR + ;Get class from extract parameter + S CLASS=$P($G(^PXRM(810.2,IEN,100)),U) + ;Otherwise default to local + I $G(CLASS)="" S CLASS="L" + ; + S DATA=$G(^PXRM(810.2,IEN,0)) + ;Determine Extract Name and period + S NAME=$P(DATA,U),PARTYPE=$P(DATA,U,2) + S YEAR=$P(NEXT,"/",2),PERIOD=$P(NEXT,"/") + ;Calculate report period start and end dates + D CALC^PXRMEUT(NEXT,.PXRMSTRT,.PXRMSTOP) + ;Determine output name for patient list and extract summary + S XNAME=NAME_" "_YEAR_" "_PERIOD + ;Process (single) Denominator rule into patient list + N SEQ,SUB + S SEQ="" + F S SEQ=$O(^PXRM(810.2,IEN,10,"B",SEQ)) Q:'SEQ D + .S SUB=$O(^PXRM(810.2,IEN,10,"B",SEQ,"")) Q:'SUB + .S DATA=$G(^PXRM(810.2,IEN,10,SUB,0)) Q:DATA="" + .S PXRMRULE=$P(DATA,U,2) Q:'PXRMRULE + .S LIST=$P(DATA,U,3) Q:LIST="" + .I LIST["yyyy" S LIST=$P(LIST,"yyyy")_YEAR_$P(LIST,"yyyy",2) + .I LIST["nn" S LIST=$P(LIST,"nn")_$E(PERIOD,2,10)_$P(LIST,"nn",2) + .S INDP=+$P(DATA,U,4) + .S INTP=+$P(DATA,U,5) + .;Create new patient list + .S PATCREAT="Y",PXRMLIST=$$CRLST^PXRMRULE(LIST,CLASS) Q:'PXRMLIST + .; + .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 + .D REM^PXRMETXR(SUB,PXRMLIST,PXRMSTRT,PXRMSTOP,PARTYPE) + ; + ;Get the name + S NAME=$$GETNAME(XNAME) + ;Create extract summary entry + S FDA(810.3,"+1,",.01)=NAME + S FDA(810.3,"+1,",.02)=PXRMSTRT + S FDA(810.3,"+1,",.03)=PXRMSTOP + S FDA(810.3,"+1,",.06)=$$NOW^XLFDT + S FDA(810.3,"+1,",1)=IEN + S FDA(810.3,"+1,",2)=PARTYPE + S FDA(810.3,"+1,",3)=$E(PERIOD,2,99) + S FDA(810.3,"+1,",4)=YEAR + S FDA(810.3,"+1,",5)=$S(MODE<2:"A",1:"M") + S FDA(810.3,"+1,",7)=$E(PERIOD) + I PURGE="Y" S FDA(810.3,"+1,",50)=1 + S FDA(810.3,"+1,",100)=CLASS + D UPDATE^DIE("","FDA","FDAIEN","MSG") + I $D(MSG) D AWRITE^PXRMUTIL("MSG") G EXIT + ; + ;Update extract summary from ^TMP + D UPDEX(FDAIEN(1)) + ; + ;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 + I MODE<2 D UPDPAR + ; + ;Mail message that extract completed + D MAIL(NAME,NEXT,MODE) + ; +EXIT ;Clear workfile + K ^TMP("PXRMETX",$J),^TMP("PXRMETX1",$J) + Q + ; +TRANS(PXRMXIEN) ;Transmit HL7 messages + N HL7ID,NAME,NEXT + S HL7ID="" + D HL7^PXRM7API(PXRMXIEN,1,.HL7ID) + H 2 + ;Lock extract summary + D LOCK(PXRMXIEN) Q:$D(DUOUT) + ;Update run information + S NAME=$P($G(^PXRMXT(810.3,PXRMXIEN,0)),U) + S NEXT=$P($G(^PXRMXT(810.3,PXRMXIEN,4)),U,3) + S FDA(810.3,"?1,",.01)=NAME + S FDA(810.36,"?+2,?1,",.01)=HL7ID + S FDA(810.36,"?+2,?1,",.02)=$$NOW^XLFDT + D UPDATE^DIE("","FDA","","MSG") + ;Unlock extract summary + D UNLOCK(PXRMXIEN) + Q + ; +UPDEX(IEN) ;Update extract summary + N DUOUT + ;Lock extract summary + D LOCK(IEN) Q:$D(DUOUT) + ; + ;Update totals section + N APPL,CNT,DFN,DUE,DATA,ETYP,EVAL + N FAPPL,FCNT,FDATA,FDUE,FEVAL,FGNAM,FGSTA,FIND,FNAPPL,FNDUE,FSEQ + N GDATA,GSEQ,INST,NAPPL,NDUE,PCNT,PXRMLIST,RCNT,RIEN,RSEQ,SEQ,TEMP + S SEQ="",CNT=1,RSEQ=0 + F S SEQ=$O(^TMP("PXRMETX",$J,SEQ)) Q:SEQ="" D + .S INST=0 + .F S INST=$O(^TMP("PXRMETX",$J,SEQ,INST)) Q:'INST D + ..S RCNT="" + ..F S RCNT=$O(^TMP("PXRMETX",$J,SEQ,INST,RCNT)) Q:RCNT="" D + ...S DATA=$G(^TMP("PXRMETX",$J,SEQ,INST,RCNT)) Q:'DATA + ...S RIEN=$P(DATA,U,1),EVAL=$P(DATA,U,2),APPL=$P(DATA,U,3) + ...S NAPPL=$P(DATA,U,4),DUE=$P(DATA,U,5),NDUE=$P(DATA,U,6) + ...S PXRMLIST=$P(DATA,U,7) + ...S CNT=CNT+1,RSEQ=RSEQ+1 + ...S TEMP=$$RJ^XLFSTR(RSEQ,3,0)_U_RIEN_U_INST_U_PXRMLIST_U_EVAL_U_APPL_U_NAPPL_U_DUE_U_NDUE + ...S ^PXRMXT(810.3,IEN,3,RSEQ,0)=TEMP + ...S ^PXRMXT(810.3,IEN,3,"B",$P(TEMP,U,1),RSEQ)="" + ...;For each count type + ...S GSEQ="",FCNT=0 + ...F S GSEQ=$O(^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ)) Q:GSEQ="" D + ....S GDATA=$G(^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ)) + ....S FGNAM=$P(GDATA,U),ETYP=$P(GDATA,U,2),FGSTA=$P(GDATA,U,3) + ....;For each term + ....S FSEQ=0 + ....F S FSEQ=$O(^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ,FSEQ)) Q:FSEQ="" D + .....;Get the term ien + .....S FIND=$P($G(^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ,FSEQ)),U),FCNT=FCNT+1 + .....;Update finding totals + .....S FDATA=$G(^TMP("PXRMETX",$J,SEQ,INST,RCNT,GSEQ,FSEQ)) + .....S FEVAL=$P(FDATA,U,2),FAPPL=$P(FDATA,U,3),FNAPPL=$P(FDATA,U,4) + .....S FDUE=$P(FDATA,U,5),FNDUE=$P(FDATA,U,6) + .....S TEMP=FSEQ_U_$P(FIND,";")_U_ETYP_U_FEVAL_U_FAPPL_U_FNAPPL_U_FDUE_U_FNDUE_U_FGNAM_U_FGSTA + .....S ^PXRMXT(810.3,IEN,3,RSEQ,1,FCNT,0)=TEMP + .....; + .....;AGP REMOVE UNTIL A DECISION CAN BE MADE + .....;S DFN=0,PCNT=0 + .....;F S DFN=$O(^TMP("PXRMETX",$J,SEQ,INST,RCNT,GSEQ,FSEQ,DFN)) Q:DFN'>0 D + .....;.S PCNT=PCNT+1,^PXRMXT(810.3,IEN,3,RSEQ,1,FCNT,1,PCNT,0)=DFN + .....;I PCNT>0 S ^PXRMXT(810.3,IEN,3,RSEQ,1,FCNT,1,0)="^810.3316PA"_U_PCNT_U_PCNT + ....I FCNT>0 S ^PXRMXT(810.3,IEN,3,RSEQ,1,0)="^810.331I"_U_FCNT_U_FCNT + .I RSEQ>0 S ^PXRMXT(810.3,IEN,3,0)="^810.33I"_U_RSEQ_U_RSEQ + ;Unlock extract summary + D UNLOCK(IEN) + Q + ; + ;File locking +LOCK(PXRMXIEN) L +^PXRMXT(810.3,PXRMXIEN):0 + I '$T W !!?5,"Another user is using this extract summary" S DUOUT=1 + Q + ; +UNLOCK(PXRMXIEN) L -^PXRMXT(810.3,PXRMXIEN) Q + ; +UPDPAR ;Update parameters when run complete + N DATA,LAST,NEXT,PERIOD,TYPE,YEAR + S DATA=$G(^PXRM(810.2,IEN,0)),NEXT=$P(DATA,U,6),TYPE=$P(DATA,U,3) + ;Last run updated + S LAST=NEXT + ;Calculate next run + I TYPE="Y" S NEXT=NEXT+1 + I "QM"[TYPE D + .N NUM + .S PERIOD=$P(NEXT,"/",1),YEAR=$P(NEXT,"/",2) + .S NUM=$P(PERIOD,TYPE,2)+1 + .I TYPE="Q",NUM>4 S NUM=1,YEAR=YEAR+1 + .I TYPE="M",NUM>12 S NUM=1,YEAR=YEAR+1 + .S NEXT=TYPE_NUM_"/"_YEAR + ;Update last and next run fields + S $P(^PXRM(810.2,IEN,0),U,4,6)=LAST_U_$$NOW^XLFDT_U_NEXT + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMETXR.m b/r/CLINICAL_REMINDERS-PXRM/PXRMETXR.m index ceacde1b..0ede38fa 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMETXR.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMETXR.m @@ -1,251 +1,248 @@ -PXRMETXR ; SLC/PJH,PKR - Reminder section of extract ;02/22/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ; Called from PXRMETX - ; -DATE ;Check if finding is most recent in evaluation group - N FDATE,GDATE - ;Determine finding date and existing group date - S FDATE=$G(FIEV(FNUM,"DATE")),GDATE=$G(GROUP(GSEQ,"DATE")) Q:FDATE="" - ;Ignore findings outside to the extract period - ;I $$FMDIFF^XLFDT(PXRMSTRT,FDATE,2)>0 Q - ;If this is first or only entry in group then save finding date - I 'GDATE S GROUP(GSEQ,"DATE")=FDATE,GROUP(GSEQ)=FSEQ Q - ;Save finding if most recent date for the group - I $$FMDIFF^XLFDT(FDATE,GDATE,2)>0 S GROUP(GSEQ,"DATE")=FDATE,GROUP(GSEQ)=FSEQ Q - Q - ; -FIND(SEQ,RCNT,PXRMSTRT,PXRMSTOP) ;Process findings for reminder - ;Default is extract no findings - N DATA,FCNT,FIEN,FIND,FNUM,FSEQ,GDATA,GROUP,GSEQ,GTYP - S FNUM=0,FCNT=0 - F S FNUM=$O(FIEV(FNUM)) Q:'FNUM D - .;Ignore if not found for patient - .I +FIEV(FNUM)=0 Q - .;Only terms are counted - .S FIND=$G(FIEV(FNUM,"TERM IEN")) Q:FIND="" - .;Check if in list to be accumulated - .I '$D(REM(RCNT,FIND)) Q - .;Find groups to which finding belongs - .S GSEQ="" - .F S GSEQ=$O(REM(RCNT,FIND,GSEQ)) Q:GSEQ="" D - ..;Determine Evaluation type - ..S GTYP=REM(RCNT,FIND,GSEQ) - ..;Ignore utilization groups - ..I GTYP="UR" Q - ..;Sequence determines where the finding will be stored - ..S FSEQ="" - ..F S FSEQ=$O(REM(RCNT,FIND,GSEQ,FSEQ)) Q:FSEQ="" D - ...;Evaluation Group logic to save latest entry only - ...I GTYP="MRFP" D DATE Q - ...;Save finding totals - ...D UPD(1) - ; - ;Check for group totals - S GSEQ="" - F S GSEQ=$O(GROUP(GSEQ)) Q:GSEQ="" D - .S GDATA=$G(GROUP(GSEQ)) Q:GDATA="" - .;Update if found - .S FSEQ=$P(GDATA,U) D UPD(1) - ; - ;Utilization counts are done separately - N CNT,FDATA,FIND,FINDPA,FTIEN,GTYP,TERMARR,TFIEVAL - ;modify start date to include incomplete dates - I $E(PXRMSTRT,6,7)="01" S PXRMSTRT=$E(PXRMSTRT,1,5)_"00" - ;Include incomplete dates in January - I $E(PXRMSTRT,4,5)="01" S PXRMSTRT=$E(PXRMSTRT,1,3)_"0000" - ;Set start and stop dates for term - ;S $P(FINDPA(0),U,8)=PXRMSTRT,$P(FINDPA(0),U,11)=PXRMSTOP - S $P(FINDPA(0),U,11)=PXRMSTOP - ;Count all entries - S $P(FINDPA(0),U,14)="*" - ; - S FTIEN="",GTYP="UR" - F S FTIEN=$O(FUTIL(RCNT,FTIEN)) Q:FTIEN="" D - .S GSEQ="" - .F S GSEQ=$O(FUTIL(RCNT,FTIEN,GSEQ)) Q:GSEQ="" D - ..S FSEQ="" - ..F S FSEQ=$O(FUTIL(RCNT,FTIEN,GSEQ,FSEQ)) Q:FSEQ="" D - ...;Recover list of term findings - ...K TERMARR M TERMARR=FUTIL(RCNT,FTIEN,GSEQ,FSEQ) - ...;Process term - ...K TFIEVAL D EVALTERM^PXRMTERM(DFN,.FINDPA,.TERMARR,.TFIEVAL) - ...D URCNT(PXRMSTRT,PXRMSTOP,.TFIEVAL) - ;Determine count from PLIST then add to ETX - ;S CNT=+$O(PLIST(1,999999),-1) Q:'CNT - ;D UPD(CNT) - Q - ; -FRULE(FRIEN,RCNT,SEQ,REM,FUTIL) ;Build array of findings in the finding rule - N DATA,FIND,FSEQ,GIEN,GNAM,GSEQ,GTYP,GSTA,SUB,TLIST - S GSEQ=0 - F S GSEQ=$O(^PXRM(810.7,FRIEN,10,"B",GSEQ)) Q:GSEQ="" D - .S SUB=$O(^PXRM(810.7,FRIEN,10,"B",GSEQ,"")) Q:'SUB - .S DATA=$G(^PXRM(810.7,FRIEN,10,SUB,0)) Q:DATA="" - .;Get the finding group ien and reminder status - .S GIEN=$P(DATA,U,2),GSTA=$P(DATA,U,3) Q:'GIEN - .;If no status then report finding totals for all patients - .I GSTA="" S GSTA="T" - .;Get finding group info - .S DATA=$G(^PXRM(810.8,GIEN,0)) Q:DATA="" - .;Get group name and count type - .S GTYP=$P(DATA,U,3),GNAM=$P(DATA,U) Q:GTYP="" - .;Save group in workfile - .S ^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ)=GNAM_U_GTYP_U_GSTA - .;Get all findings in group - .S FSEQ=0 - .F S FSEQ=$O(^PXRM(810.8,GIEN,10,"B",FSEQ)) Q:FSEQ="" D - ..S SUB=$O(^PXRM(810.8,GIEN,10,"B",FSEQ,"")) Q:'SUB - ..S DATA=$G(^PXRM(810.8,GIEN,10,SUB,0)) Q:DATA="" - ..;Get the finding ien and exclusion status - ..S FIND=$P(DATA,U,2) Q:'FIND - ..;Initialize count for finding - ..S ^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ,FSEQ)=FIND - ..;Reminder evaluation counts work from REM - ..I GTYP'="UR" D Q - ...S REM(RCNT,FIND,GSEQ,FSEQ)="" - ...S REM(RCNT,FIND,GSEQ)=GTYP - ..;Utilization counts work from FUTIL - ..D TERM^PXRMLDR(FIND,.TLIST) - ..;Save TLIST - ..M FUTIL(RCNT,FIND,GSEQ,FSEQ)=TLIST - Q - ; -REM(SUB,PXRMLIST,PXRMSTRT,PXRMSTOP,PARTYPE) ;Run reminders against patient - ;lists. - N APPL,DATA,DEFARR,DEFSITE,DFN,DUE,FIEV,FRIEN,FUTIL,IND,INST - N PXRMDATE,RCNT,REM,REMSEQ,RIEN,RNAM,STATUS,SUB1,TODAY - N END,START - ;S START=$H - S TODAY=$$DT^XLFDT - ;Evaluation date is period end except if the period is incomplete - S PXRMDATE=$S($$FMDIFF^XLFDT(PXRMSTOP,TODAY,2)>0:TODAY,1:PXRMSTOP) - ;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) - ; - ;Process patient list - S IND=0,DEFSITE=+$P($$SITE^VASITE,U,3) - F S IND=$O(^PXRMXP(810.5,PXRMLIST,30,IND)) Q:'IND D - .S DFN=$P($G(^PXRMXP(810.5,PXRMLIST,30,IND,0)),U) Q:'DFN - .S INST=$P($G(^PXRMXP(810.5,PXRMLIST,30,IND,0)),U,2) - .I INST="" S INST=DEFSITE - .S RCNT=0 - .F S RCNT=$O(REM(RCNT)) Q:'RCNT D - ..S RIEN=$P(REM(RCNT),U),RNAM=$P(REM(RCNT),U,2),FRIEN=$P(REM(RCNT),U,3) - ..;Clear evaluation arrays. - ..K ^TMP("PXRHM",$J),^TMP("PXRMID",$J),FIEV - ..;Evaluate reminders and store results - ..D DEF^PXRMLDR(RIEN,.DEFARR) - ..D EVAL^PXRM(DFN,.DEFARR,1,1,.FIEV,PXRMDATE) - ..;Determine update from reminder status - ..S STATUS=$P($G(^TMP("PXRHM",$J,RIEN,RNAM)),U) I STATUS="" Q - ..;Ignore not applicables - ..S APPL=$S(STATUS["DUE":1,STATUS="RESOLVED":1,STATUS="DONE":1,1:0) - ..;Check if due - ..S DUE=$S(STATUS="DUE NOW":1,1:0) - ..;Compliance totals - ..S DATA=$G(^TMP("PXRMETX",$J,SEQ,INST,RCNT)) - ..;Reminder ien - ..I $P(DATA,U)="" S $P(DATA,U)=RIEN - ..;Evaluated total - ..S $P(DATA,U,2)=$P(DATA,U,2)+1 - ..;Applicable total - ..S $P(DATA,U,3)=$P(DATA,U,3)+APPL - ..;Not applicable total - ..I 'APPL,'DUE S $P(DATA,U,4)=$P(DATA,U,4)+1 - ..;Due total - ..S $P(DATA,U,5)=$P(DATA,U,5)+DUE - ..;Not due count - ..I APPL,'DUE S $P(DATA,U,6)=$P(DATA,U,6)+1 - ..;Add patient list - ..I $P(DATA,U,7)="" S $P(DATA,U,7)=PXRMLIST - ..;Update workfile - ..S ^TMP("PXRMETX",$J,SEQ,INST,RCNT)=DATA - ..;Save finding totals - ..I PARTYPE="CF" D FIND(SEQ,RCNT,PXRMSTRT,PXRMSTOP) - ;Clear evaluation fields - K ^TMP("PXRHM",$J),^TMP("PXRMID",$J) - ;S END=$H - ;W !,"REMINDER EVALUATION TIME" - ;D DETIME^PXRMXSEL(START,END) - Q - ; -REMF(RIEN,RCNT,SEQ,REM) ;Build array of all findings in the reminder - N GNAM,GSEQ,FIND,FSEQ,GTYP,SUB - S GNAM="Finding totals",GSEQ="001",FSEQ=0,GTYP="MRF" - ;Save group name - S ^TMP("PXRMETX",$J,SEQ,RCNT,GSEQ)=GNAM_U_GTYP - ;Select all findings in the reminder - S SUB=0 - F S SUB=$O(^PXD(811.9,RIEN,20,SUB)) Q:'SUB D - .;Ignore if finding is not a term - .S FIND=$P($G(^PXD(811.9,RIEN,20,SUB,0)),U) Q:FIND'["PXRMD(811.5" - .;Convert to term ien - .S FIND=$P(FIND,";") - .;Build sequence number - .S FSEQ=FSEQ+1,FSEQ=$$RJ^XLFSTR(FSEQ,3,0) - .;Evaluation counts - .S REM(RCNT,FIND,GSEQ,FSEQ)="" - .S REM(RCNT,FIND,GSEQ)=GTYP - .;Update Workfile - .S ^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ,FSEQ)=FIND - Q - ; -URCNT(PXRMSTRT,PXRMSTOP,TFIEVAL) ; - ;Handle counting all valid occurrences for the finding items. - ;Includes historical entries that were entered within the reporting - ;period, cut the encounter date if it is outside the reporting period. - N CNT,DATEENT,FDATE,FILE,FNUM,FOCCNUM,HIST,NODE,SCAT,VIEN - S CNT=0,FNUM=0 - F S FNUM=$O(TFIEVAL(FNUM)) Q:FNUM'>0 D - .S FILE=$G(TFIEVAL(FNUM,"FILE NUMBER")) - .S HIST=$S(FILE=9000010.18:1,FILE=9000010.13:1,FILE=9000010.23:1,FILE=9000010.16:1,FILE=9000010.07:1,FILE=9000010.12:1,FILE=9000010.15:1,1:0) - .S FOCCNUM=0 F S FOCCNUM=$O(TFIEVAL(FNUM,FOCCNUM)) Q:FOCCNUM'>0 D - ..S FDATE=$P(TFIEVAL(FNUM,FOCCNUM,"DATE"),".") Q:FDATE'>0 - ..I HIST=0,FDATE=PXRMSTRT!(FDATE>PXRMSTRT) S CNT=CNT+1 - ..I HIST=1 D - ...S VIEN=TFIEVAL(FNUM,FOCCNUM,"VISIT") Q:VIEN'>0 - ...S NODE=$G(^AUPNVSIT(VIEN,0)) - ...S SCAT=$P(NODE,U,7),DATEENT=$P($P(NODE,U,2),".") - ...I FDATE=PXRMSTRT!(FDATE>PXRMSTRT),SCAT'="E" S CNT=CNT+1 Q - ...I SCAT="E",(DATEENT=PXRMSTRT!(DATEENT>PXRMSTRT))&(DATEENT=PXRMSTOP!(DATEENT0 Q + ;If this is first or only entry in group then save finding date + I 'GDATE S GROUP(GSEQ,"DATE")=FDATE,GROUP(GSEQ)=FSEQ Q + ;Save finding if most recent date for the group + I $$FMDIFF^XLFDT(FDATE,GDATE,2)>0 S GROUP(GSEQ,"DATE")=FDATE,GROUP(GSEQ)=FSEQ Q + Q + ; +FIND(SEQ,RCNT,PXRMSTRT,PXRMSTOP) ;Process findings for reminder + ;Default is extract no findings + N DATA,FCNT,FIEN,FIND,FNUM,FSEQ,GDATA,GROUP,GSEQ,GTYP + S FNUM=0,FCNT=0 + F S FNUM=$O(FIEV(FNUM)) Q:'FNUM D + .;Ignore if not found for patient + .I +FIEV(FNUM)=0 Q + .;Only terms are counted + .S FIND=$G(FIEV(FNUM,"TERM IEN")) Q:FIND="" + .;Check if in list to be accumulated + .I '$D(REM(RCNT,FIND)) Q + .;Find groups to which finding belongs + .S GSEQ="" + .F S GSEQ=$O(REM(RCNT,FIND,GSEQ)) Q:GSEQ="" D + ..;Determine Evaluation type + ..S GTYP=REM(RCNT,FIND,GSEQ) + ..;Ignore utilization groups + ..I GTYP="UR" Q + ..;Sequence determines where the finding will be stored + ..S FSEQ="" + ..F S FSEQ=$O(REM(RCNT,FIND,GSEQ,FSEQ)) Q:FSEQ="" D + ...;Evaluation Group logic to save latest entry only + ...I GTYP="MRFP" D DATE Q + ...;Save finding totals + ...D UPD(1) + ; + ;Check for group totals + S GSEQ="" + F S GSEQ=$O(GROUP(GSEQ)) Q:GSEQ="" D + .S GDATA=$G(GROUP(GSEQ)) Q:GDATA="" + .;Update if found + .S FSEQ=$P(GDATA,U) D UPD(1) + ; + ;Utilization counts are done separately + N CNT,FDATA,FIND,FINDPA,FTIEN,GTYP,TERMARR,TFIEVAL + ;modify start date to include incomplete dates + I $E(PXRMSTRT,6,7)="01" S PXRMSTRT=$E(PXRMSTRT,1,5)_"00" + ;Include incomplete dates in January + I $E(PXRMSTRT,4,5)="01" S PXRMSTRT=$E(PXRMSTRT,1,3)_"0000" + ;Set start and stop dates for term + ;S $P(FINDPA(0),U,8)=PXRMSTRT,$P(FINDPA(0),U,11)=PXRMSTOP + S $P(FINDPA(0),U,11)=PXRMSTOP + ;Count all entries + S $P(FINDPA(0),U,14)="*" + ; + S FTIEN="",GTYP="UR" + F S FTIEN=$O(FUTIL(RCNT,FTIEN)) Q:FTIEN="" D + .S GSEQ="" + .F S GSEQ=$O(FUTIL(RCNT,FTIEN,GSEQ)) Q:GSEQ="" D + ..S FSEQ="" + ..F S FSEQ=$O(FUTIL(RCNT,FTIEN,GSEQ,FSEQ)) Q:FSEQ="" D + ...;Recover list of term findings + ...K TERMARR M TERMARR=FUTIL(RCNT,FTIEN,GSEQ,FSEQ) + ...;Process term + ...K TFIEVAL D EVALTERM^PXRMTERM(DFN,.FINDPA,.TERMARR,.TFIEVAL) + ...D URCNT(PXRMSTRT,PXRMSTOP,.TFIEVAL) + ;Determine count from PLIST then add to ETX + ;S CNT=+$O(PLIST(1,999999),-1) Q:'CNT + ;D UPD(CNT) + Q + ; +FRULE(FRIEN,RCNT,SEQ,REM,FUTIL) ;Build array of findings in the finding rule + N DATA,FIND,FSEQ,GIEN,GNAM,GSEQ,GTYP,GSTA,SUB,TLIST + S GSEQ=0 + F S GSEQ=$O(^PXRM(810.7,FRIEN,10,"B",GSEQ)) Q:GSEQ="" D + .S SUB=$O(^PXRM(810.7,FRIEN,10,"B",GSEQ,"")) Q:'SUB + .S DATA=$G(^PXRM(810.7,FRIEN,10,SUB,0)) Q:DATA="" + .;Get the finding group ien and reminder status + .S GIEN=$P(DATA,U,2),GSTA=$P(DATA,U,3) Q:'GIEN + .;If no status then report finding totals for all patients + .I GSTA="" S GSTA="T" + .;Get finding group info + .S DATA=$G(^PXRM(810.8,GIEN,0)) Q:DATA="" + .;Get group name and count type + .S GTYP=$P(DATA,U,3),GNAM=$P(DATA,U) Q:GTYP="" + .;Save group in workfile + .S ^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ)=GNAM_U_GTYP_U_GSTA + .;Get all findings in group + .S FSEQ=0 + .F S FSEQ=$O(^PXRM(810.8,GIEN,10,"B",FSEQ)) Q:FSEQ="" D + ..S SUB=$O(^PXRM(810.8,GIEN,10,"B",FSEQ,"")) Q:'SUB + ..S DATA=$G(^PXRM(810.8,GIEN,10,SUB,0)) Q:DATA="" + ..;Get the finding ien and exclusion status + ..S FIND=$P(DATA,U,2) Q:'FIND + ..;Initialize count for finding + ..S ^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ,FSEQ)=FIND + ..;Reminder evaluation counts work from REM + ..I GTYP'="UR" D Q + ...S REM(RCNT,FIND,GSEQ,FSEQ)="" + ...S REM(RCNT,FIND,GSEQ)=GTYP + ..;Utilization counts work from FUTIL + ..D TERM^PXRMLDR(FIND,.TLIST) + ..;Save TLIST + ..M FUTIL(RCNT,FIND,GSEQ,FSEQ)=TLIST + Q + ; +REM(SUB,PXRMLIST,PXRMSTRT,PXRMSTOP,PARTYPE) ;Run reminders against patient + ;lists. + N APPL,DATA,DEFARR,DEFSITE,DFN,DUE,FIEV,FRIEN,FUTIL,IND,INST + N PXRMDATE,RCNT,REM,RIEN,RNAM,STATUS,SUB1,TODAY + N END,START + ;S START=$H + S TODAY=$$DT^XLFDT + ;Evaluation date is period end except if the period is incomplete + S PXRMDATE=$S($$FMDIFF^XLFDT(PXRMSTOP,TODAY,2)>0:TODAY,1:PXRMSTOP) + ;Scan reminders for this parameter set + S (RCNT,SUB1)=0 + 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 + S IND=0,DEFSITE=+$P($$SITE^VASITE,U,3) + F S IND=$O(^PXRMXP(810.5,PXRMLIST,30,IND)) Q:'IND D + .S DFN=$P($G(^PXRMXP(810.5,PXRMLIST,30,IND,0)),U) Q:'DFN + .S INST=$P($G(^PXRMXP(810.5,PXRMLIST,30,IND,0)),U,2) + .I INST="" S INST=DEFSITE + .S RCNT=0 + .F S RCNT=$O(REM(RCNT)) Q:'RCNT D + ..S RIEN=$P(REM(RCNT),U),RNAM=$P(REM(RCNT),U,2),FRIEN=$P(REM(RCNT),U,3) + ..;Clear evaluation arrays. + ..K ^TMP("PXRHM",$J),^TMP("PXRMID",$J),FIEV + ..;Evaluate reminders and store results + ..D DEF^PXRMLDR(RIEN,.DEFARR) + ..D EVAL^PXRM(DFN,.DEFARR,1,1,.FIEV,PXRMDATE) + ..;Determine update from reminder status + ..S STATUS=$P($G(^TMP("PXRHM",$J,RIEN,RNAM)),U) I STATUS="" Q + ..;Ignore not applicables + ..S APPL=$S(STATUS["DUE":1,STATUS="RESOLVED":1,STATUS="DONE":1,1:0) + ..;Check if due + ..S DUE=$S(STATUS="DUE NOW":1,1:0) + ..;Compliance totals + ..S DATA=$G(^TMP("PXRMETX",$J,SEQ,INST,RCNT)) + ..;Reminder ien + ..I $P(DATA,U)="" S $P(DATA,U)=RIEN + ..;Evaluated total + ..S $P(DATA,U,2)=$P(DATA,U,2)+1 + ..;Applicable total + ..S $P(DATA,U,3)=$P(DATA,U,3)+APPL + ..;Not applicable total + ..I 'APPL,'DUE S $P(DATA,U,4)=$P(DATA,U,4)+1 + ..;Due total + ..S $P(DATA,U,5)=$P(DATA,U,5)+DUE + ..;Not due count + ..I APPL,'DUE S $P(DATA,U,6)=$P(DATA,U,6)+1 + ..;Add patient list + ..I $P(DATA,U,7)="" S $P(DATA,U,7)=PXRMLIST + ..;Update workfile + ..S ^TMP("PXRMETX",$J,SEQ,INST,RCNT)=DATA + ..;Save finding totals + ..I PARTYPE="CF" D FIND(SEQ,RCNT,PXRMSTRT,PXRMSTOP) + ;Clear evaluation fields + K ^TMP("PXRHM",$J),^TMP("PXRMID",$J) + ;S END=$H + ;W !,"REMINDER EVALUATION TIME" + ;D DETIME^PXRMXSEL(START,END) + Q + ; +REMF(RIEN,RCNT,SEQ,REM) ;Build array of all findings in the reminder + N GNAM,GSEQ,FIND,FSEQ,GTYP,SUB + S GNAM="Finding totals",GSEQ="001",FSEQ=0,GTYP="MRF" + ;Save group name + S ^TMP("PXRMETX",$J,SEQ,RCNT,GSEQ)=GNAM_U_GTYP + ;Select all findings in the reminder + S SUB=0 + F S SUB=$O(^PXD(811.9,RIEN,20,SUB)) Q:'SUB D + .;Ignore if finding is not a term + .S FIND=$P($G(^PXD(811.9,RIEN,20,SUB,0)),U) Q:FIND'["PXRMD(811.5" + .;Convert to term ien + .S FIND=$P(FIND,";") + .;Build sequence number + .S FSEQ=FSEQ+1,FSEQ=$$RJ^XLFSTR(FSEQ,3,0) + .;Evaluation counts + .S REM(RCNT,FIND,GSEQ,FSEQ)="" + .S REM(RCNT,FIND,GSEQ)=GTYP + .;Update Workfile + .S ^TMP("PXRMETX1",$J,SEQ,RCNT,GSEQ,FSEQ)=FIND + Q + ; +URCNT(PXRMSTRT,PXRMSTOP,TFIEVAL) ; + ;Handle counting all valid occurrences for the finding items. + ;Includes historical entries that were entered within the reporting + ;period, cut the encounter date if it is outside the reporting period. + N CNT,DATEENT,FDATE,FILE,FNUM,FOCCNUM,HIST,NODE,SCAT,VIEN + S CNT=0,FNUM=0 + F S FNUM=$O(TFIEVAL(FNUM)) Q:FNUM'>0 D + .S FILE=$G(TFIEVAL(FNUM,"FILE NUMBER")) + .S HIST=$S(FILE=9000010.18:1,FILE=9000010.13:1,FILE=9000010.23:1,FILE=9000010.16:1,FILE=9000010.07:1,FILE=9000010.12:1,FILE=9000010.15:1,1:0) + .S FOCCNUM=0 F S FOCCNUM=$O(TFIEVAL(FNUM,FOCCNUM)) Q:FOCCNUM'>0 D + ..S FDATE=$P(TFIEVAL(FNUM,FOCCNUM,"DATE"),".") Q:FDATE'>0 + ..I HIST=0,FDATE=PXRMSTRT!(FDATE>PXRMSTRT) S CNT=CNT+1 + ..I HIST=1 D + ...S VIEN=TFIEVAL(FNUM,FOCCNUM,"VISIT") Q:VIEN'>0 + ...S NODE=$G(^AUPNVSIT(VIEN,0)) + ...S SCAT=$P(NODE,U,7),DATEENT=$P($P(NODE,U,2),".") + ...I FDATE=PXRMSTRT!(FDATE>PXRMSTRT),SCAT'="E" S CNT=CNT+1 Q + ...I SCAT="E",(DATEENT=PXRMSTRT!(DATEENT>PXRMSTRT))&(DATEENT=PXRMSTOP!(DATEENT12 S NYR=NYR+1,NMON=1 - .S CMON=CMON*3-2 - ;If monthly use start of next month - I ETYPE="M" D - .S CMON=$E(PERIOD,2,99),NMON=CMON+1 I NMON>12 S NYR=NYR+1,NMON=1 - ;Zero fill the month fields - S CMON=$$RJ^XLFSTR(CMON,2,0),NMON=$$RJ^XLFSTR(NMON,2,0) - ;Zero fill the year fields - S CYR=$$RJ^XLFSTR(CYR,2,0),NYR=$$RJ^XLFSTR(NYR,2,0) - ;Report start date is start of current period - S START=3_CYR_CMON_"01" - ;Report end date is start of next period less one day - S END=$$FMADD^XLFDT(3_NYR_NMON_"01",-1) - Q - ; - ;================================================= -DATES(BDATE,EDATE,LIT) ;Get a past date range. -BEGIN ;Select the beginning date. - N DIR,%DT,X,Y - K DIROUT,DIRUT,DTOUT,DUOUT - S DIR(0)="DA^::ETX" - S DIR("A")="Enter "_LIT_" BEGINNING DATE: " - S DIR("PRE")="S X=$$DCHECK^PXRMDATE(X) K:X=-1 X" - S DIR("?")="For detailed help type ??" - S DIR("??")=U_"D BHELP^PXRMEUT" - W ! - D ^DIR K DIR - I $D(DIROUT) S DTOUT=1 - I $D(DTOUT)!($D(DUOUT)) Q - S BDATE=Y - I $E(Y,6,7)="00" W $C(7)," ?? Enter exact date" G BEGIN - S BDATE=Y - ; -END ;Select the ending date. - S DIR(0)="DA^"_BDATE_"::ETX" - S DIR("A")="Enter "_LIT_" ENDING DATE: " - S DIR("PRE")="S X=$$DCHECK^PXRMDATE(X) K:X=-1 X" - S DIR("?")="This date cannot be before "_$$FMTE^XLFDT(BDATE,"D")_". For detailed help type ??" - S DIR("??")=U_"D EHELP^PXRMEUT" - D ^DIR - I $D(DIROUT) S DTOUT=1 - I $D(DTOUT) Q - I $D(DUOUT) G BEGIN - S EDATE=Y - I $E(Y,6,7)="00" W $C(7)," ?? Enter exact date" G END - K DIROUT,DIRUT,DTOUT,DUOUT - Q - ; - ;================================================= -DOCUMENT(PXRMLIST,PXRMRULE,INDP,INTP,BEG,END) ;Document how the - ;list was built. - N CDATE,CLASS,CREATOR,IND,LDATA,LNAME - N NDL,NL,NPAT,OUTPUT,SNAME,SOURCE,TEXT,TYPE,VALMCNT - K ^TMP("PXRMLRED",$J) - S LDATA=$G(^PXRMXP(810.5,PXRMLIST,0)) - S LNAME=$P(LDATA,U,1) - S CDATE=$P(LDATA,U,4) - S SOURCE=$P(LDATA,U,5),SNAME="NONE" - ;Check if generated from #810.2 - I SOURCE S SNAME="Extract Parameter - "_$P($G(^PXRM(810.2,SOURCE,0)),U) - ;If not check if generated from #810.4 - I 'SOURCE S SOURCE=$P(LDATA,U,6) S:SOURCE SNAME="List Rule - "_$P($G(^PXRM(810.4,SOURCE,0)),U) - ;Creator - S CREATOR=+$P(LDATA,U,7) - S CREATOR=$S(CREATOR>0:$$GET1^DIQ(200,CREATOR,.01),1:"None") - ;Type - S TYPE=$P(LDATA,U,8) - S TYPE=$$EXTERNAL^DILFD(810.5,.08,"",TYPE,.EM) - ;Class - S CLASS=$P($G(^PXRMXP(810.5,PXRMLIST,100)),U,1) - S CLASS=$S(CLASS="N":"National",CLASS="V":"VISN",1:"Local") - S NPAT=$P(^PXRMXP(810.5,PXRMLIST,30,0),U,4) - S TEXT(1)="List Name: "_LNAME_" ("_NPAT_" patients)" - S TEXT(2)=" Created: "_$$FMTE^XLFDT(CDATE,"5Z") - S TEXT(2)=$$LJ^XLFSTR(TEXT(2),40)_"Creator: "_CREATOR - S TEXT(3)=" Class: "_CLASS - S TEXT(3)=$$LJ^XLFSTR(TEXT(3),40)_"Type: "_TYPE - S TEXT(4)=" Source: "_SNAME - S TEXT(5)=" Patient List Beginning Date: "_$$FMTE^XLFDT(BEG,"5Z") - S TEXT(6)=" Patient List Ending Date: "_$$FMTE^XLFDT(END,"5Z") - S TEXT(7)=" " - S NL=7 - F IND=1:1:NL S ^PXRMXP(810.5,PXRMLIST,200,IND,0)=TEXT(IND) - D BLDLIST^PXRMLRED(PXRMRULE,3) - F IND=1:1:VALMCNT S NL=NL+1,^PXRMXP(810.5,PXRMLIST,200,NL,0)=^TMP("PXRMLRED",$J,IND,0) - S NL=NL+1,^PXRMXP(810.5,PXRMLIST,200,NL,0)=" --- List Build Information ---" - S NL=NL+1,^PXRMXP(810.5,PXRMLIST,200,NL,0)="List Build Beginning Date: "_$$FMTE^XLFDT(BEG,"5Z") - S NL=NL+1,^PXRMXP(810.5,PXRMLIST,200,NL,0)="List Build Ending Date: "_$$FMTE^XLFDT(END,"5Z") - S NL=NL+1,^PXRMXP(810.5,PXRMLIST,200,NL,0)=" " - S NL=NL+1,^PXRMXP(810.5,PXRMLIST,200,NL,0)="Include deceased patients: "_$S(INDP:"Yes",1:"No") - S NL=NL+1,^PXRMXP(810.5,PXRMLIST,200,NL,0)="Include test patients: "_$S(INTP:"Yes",1:"No") - ;Get the beginning and ending date information - D DOCDATES^PXRMEUT1(PXRMRULE,BEG,END,.NDL,.OUTPUT) - F IND=1:1:NDL S NL=NL+1,^PXRMXP(810.5,PXRMLIST,200,NL,0)=OUTPUT(IND) - S ^PXRMXP(810.5,PXRMLIST,200,0)=U_U_NL_U_NL_U_DT_U - K ^TMP("PXRMLRED",$J) - Q - ; - ;================================================= -EHELP ;Write the ending date help. - N EDHTEXT,%DT - S EDHTEXT(1)="This is the ending date for the "_LIT_"." - D HELP^PXRMEUT(.EDHTEXT) - S %DT="P",%DT(0)=-DT - D HELP^%DTC - Q - ; - ;================================================= -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) - W ! - Q - ; - ;================================================= -LDELOK(LISTIEN) ;Return a 1 if it is ok for this user to delete the list. - N CREATOR,DELOK - S CREATOR=$P(^PXRMXP(810.5,LISTIEN,0),U,7) - S DELOK=$S(CREATOR=DUZ:1,$D(^XUSEC("PXRM MANAGER",DUZ)):1,1:0) - Q DELOK - ; - ;================================================= -MES(TEXT) ;General mail message - N XMSUB - K ^TMP("PXRMXMZ",$J) - S XMSUB="CLINICAL REMINDER EXTRACT" - S ^TMP("PXRMXMZ",$J,1,0)=TEXT - D SEND^PXRMMSG(XMSUB) - Q - ; - ;================================================= -PERIOD(FREQ) ;Calculate next period - N CMON,CUR,CYR,ETYPE,NEXT,PERIOD,YEAR - ;Format current date YY/MM/DD - S CUR=$$FMTE^XLFDT($$NOW^XLFDT,7) - ;extract year and period - S YEAR=$P(CUR,"/"),PERIOD=$P(CUR,"/",2) - ;If yearly current year - I FREQ="Y" D - .S NEXT=YEAR - ;If quarterly use current quarter - I FREQ="Q" D - .S NEXT="Q"_((PERIOD-1\3)+1)_"/"_YEAR - ;If monthly use current month - I FREQ="M" D - .S NEXT="M"_PERIOD_"/"_YEAR - Q NEXT - ; - ;================================================= -RMPAT(NODE,INDP,INTP) ;Remove dead and test patients from - ;the list. - I INDP,INTP Q - N DFN,DOD,REMOVE - S DFN=0 - F S DFN=$O(^TMP($J,NODE,DFN)) Q:DFN="" D - .;DBIA 3744 - . S REMOVE=$S('INTP:$$TESTPAT^VADPT(DFN),1:0) - . I REMOVE K ^TMP($J,NODE,DFN) Q - . I INDP Q - .;DBIA #10035 - . S DOD=+$P($G(^DPT(DFN,.35)),U,1) - . I DOD=0 Q - . K ^TMP($J,NODE,DFN) - Q - ; +PXRMEUT ; SLC/PJH - General extract utilities ;06/27/2006 + ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21 + ; + ;================================================= +ASKNUM(TEXT,MIN,MAX) ; + N DIR,X,Y + K DIROUT,DIRUT,DTOUT,DUOUT + S DIR(0)="N"_U_MIN_":"_MAX + S DIR("A")=TEXT + S DIR("B")=MIN + S DIR("?")="Enter a number between "_MIN_" and "_MAX_"." + W ! + D ^DIR + I $D(DTOUT)!$D(DUOUT) S Y=MIN + Q Y + ; + ;================================================= +ASKYN(DEF,TEXT,RTN,HLP) ; + N DIR,X,Y + K DIROUT,DIRUT,DTOUT,DUOUT + S DIR(0)="Y0" + S DIR("A")=TEXT + S DIR("B")=DEF + S DIR("?")="Enter Y or N." + I $G(RTN)'="",$G(HLP)'="" D + . S DIR("?")="Enter Y or N. For detailed help type ??" + . S DIR("??")=U_"D HELP^"_RTN_"(HLP)" + W ! + D ^DIR + I $D(DTOUT)!$D(DUOUT) S Y=DEF + Q Y + ; + ;================================================= +BHELP ;Write the beginning date help. + N BDHTEXT,%DT + S BDHTEXT(1)="This is the beginning date for the "_LIT_"." + D HELP^PXRMEUT(.BDHTEXT) + S %DT="P",%DT(0)=-DT + D HELP^%DTC + Q + ; + ;================================================= +CALC(NEXT,START,END) ;Calculate period start and end dates + ;Next is current run period + N CMON,CYR,ETYPE,NMON,NYR,PERIOD,YEAR + ;extract year and period (M1,M2,Q1,Q2,Y etc) + I NEXT["/" S YEAR=$P(NEXT,"/",2),PERIOD=$P(NEXT,"/"),ETYPE=$E(PERIOD) + I NEXT?4N S YEAR=NEXT,PERIOD="",ETYPE="Y" + ;Two digit year + S CYR=$E(YEAR,3,4),NYR=CYR + ;If yearly use Jan 1st of current year and next + I ETYPE="Y" D + .S CMON="1",NMON="1",NYR=NYR+1 + ;If quarterly use start of first month of next quarter + I ETYPE="Q" D + .S CMON=$E(PERIOD,2,99),NMON=CMON*3+1 I NMON>12 S NYR=NYR+1,NMON=1 + .S CMON=CMON*3-2 + ;If monthly use start of next month + I ETYPE="M" D + .S CMON=$E(PERIOD,2,99),NMON=CMON+1 I NMON>12 S NYR=NYR+1,NMON=1 + ;Zero fill the month fields + S CMON=$$RJ^XLFSTR(CMON,2,0),NMON=$$RJ^XLFSTR(NMON,2,0) + ;Zero fill the year fields + S CYR=$$RJ^XLFSTR(CYR,2,0),NYR=$$RJ^XLFSTR(NYR,2,0) + ;Report start date is start of current period + S START=3_CYR_CMON_"01" + ;Report end date is start of next period less one day + S END=$$FMADD^XLFDT(3_NYR_NMON_"01",-1) + Q + ; + ;================================================= +DATES(BDATE,EDATE,LIT) ;Get a past date range. +BEGIN ;Select the beginning date. + N DIR,%DT,X,Y + K DIROUT,DIRUT,DTOUT,DUOUT + S DIR(0)="DA^::ETX" + S DIR("A")="Enter "_LIT_" BEGINNING DATE: " + S DIR("PRE")="S X=$$DCHECK^PXRMDATE(X) K:X=-1 X" + S DIR("?")="For detailed help type ??" + S DIR("??")=U_"D BHELP^PXRMEUT" + W ! + D ^DIR K DIR + I $D(DIROUT) S DTOUT=1 + I $D(DTOUT)!($D(DUOUT)) Q + S BDATE=Y + I $E(Y,6,7)="00" W $C(7)," ?? Enter exact date" G BEGIN + S BDATE=Y + ; +END ;Select the ending date. + S DIR(0)="DA^"_BDATE_"::ETX" + S DIR("A")="Enter "_LIT_" ENDING DATE: " + S DIR("PRE")="S X=$$DCHECK^PXRMDATE(X) K:X=-1 X" + S DIR("?")="This date cannot be before "_$$FMTE^XLFDT(BDATE,"D")_". For detailed help type ??" + S DIR("??")=U_"D EHELP^PXRMEUT" + D ^DIR + I $D(DIROUT) S DTOUT=1 + I $D(DTOUT) Q + I $D(DUOUT) G BEGIN + S EDATE=Y + I $E(Y,6,7)="00" W $C(7)," ?? Enter exact date" G END + K DIROUT,DIRUT,DTOUT,DUOUT + Q + ; + ;================================================= +DOCUMENT(PXRMLIST,PXRMRULE,INDP,INTP,BEG,END) ;Document how the + ;list was built. + N CDATE,CLASS,CREATOR,IND,LDATA,LNAME + N NDL,NL,NPAT,OUTPUT,SNAME,SOURCE,TEXT,TYPE,VALMCNT + K ^TMP("PXRMLRED",$J) + S LDATA=$G(^PXRMXP(810.5,PXRMLIST,0)) + S LNAME=$P(LDATA,U,1) + S CDATE=$P(LDATA,U,4) + S SOURCE=$P(LDATA,U,5),SNAME="NONE" + ;Check if generated from #810.2 + I SOURCE S SNAME="Extract Parameter - "_$P($G(^PXRM(810.2,SOURCE,0)),U) + ;If not check if generated from #810.4 + I 'SOURCE S SOURCE=$P(LDATA,U,6) S:SOURCE SNAME="List Rule - "_$P($G(^PXRM(810.4,SOURCE,0)),U) + ;Creator + S CREATOR=+$P(LDATA,U,7) + S CREATOR=$S(CREATOR>0:$$GET1^DIQ(200,CREATOR,.01),1:"None") + ;Type + S TYPE=$P(LDATA,U,8) + S TYPE=$$EXTERNAL^DILFD(810.5,.08,"",TYPE,.EM) + ;Class + S CLASS=$P($G(^PXRMXP(810.5,PXRMLIST,100)),U,1) + S CLASS=$S(CLASS="N":"National",CLASS="V":"VISN",1:"Local") + S NPAT=$P(^PXRMXP(810.5,PXRMLIST,30,0),U,4) + S TEXT(1)="List Name: "_LNAME_" ("_NPAT_" patients)" + S TEXT(2)=" Created: "_$$FMTE^XLFDT(CDATE,"5Z") + S TEXT(2)=$$LJ^XLFSTR(TEXT(2),40)_"Creator: "_CREATOR + S TEXT(3)=" Class: "_CLASS + S TEXT(3)=$$LJ^XLFSTR(TEXT(3),40)_"Type: "_TYPE + S TEXT(4)=" Source: "_SNAME + S TEXT(5)=" Patient List Beginning Date: "_$$FMTE^XLFDT(BEG,"5Z") + S TEXT(6)=" Patient List Ending Date: "_$$FMTE^XLFDT(END,"5Z") + S TEXT(7)=" " + S NL=7 + F IND=1:1:NL S ^PXRMXP(810.5,PXRMLIST,200,IND,0)=TEXT(IND) + D BLDLIST^PXRMLRED(PXRMRULE,3) + F IND=1:1:VALMCNT S NL=NL+1,^PXRMXP(810.5,PXRMLIST,200,NL,0)=^TMP("PXRMLRED",$J,IND,0) + S NL=NL+1,^PXRMXP(810.5,PXRMLIST,200,NL,0)=" --- List Build Information ---" + S NL=NL+1,^PXRMXP(810.5,PXRMLIST,200,NL,0)="List Build Beginning Date: "_$$FMTE^XLFDT(BEG,"5Z") + S NL=NL+1,^PXRMXP(810.5,PXRMLIST,200,NL,0)="List Build Ending Date: "_$$FMTE^XLFDT(END,"5Z") + S NL=NL+1,^PXRMXP(810.5,PXRMLIST,200,NL,0)=" " + S NL=NL+1,^PXRMXP(810.5,PXRMLIST,200,NL,0)="Include deceased patients: "_$S(INDP:"Yes",1:"No") + S NL=NL+1,^PXRMXP(810.5,PXRMLIST,200,NL,0)="Include test patients: "_$S(INTP:"Yes",1:"No") + ;Get the beginning and ending date information + D DOCDATES^PXRMEUT1(PXRMRULE,BEG,END,.NDL,.OUTPUT) + F IND=1:1:NDL S NL=NL+1,^PXRMXP(810.5,PXRMLIST,200,NL,0)=OUTPUT(IND) + S ^PXRMXP(810.5,PXRMLIST,200,0)=U_U_NL_U_NL_U_DT_U + K ^TMP("PXRMLRED",$J) + Q + ; + ;================================================= +EHELP ;Write the ending date help. + N EDHTEXT,%DT + S EDHTEXT(1)="This is the ending date for the "_LIT_"." + D HELP^PXRMEUT(.EDHTEXT) + S %DT="P",%DT(0)=-DT + D HELP^%DTC + Q + ; + ;================================================= +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 + ; + ;================================================= +LDELOK(LISTIEN) ;Return a 1 if it is ok for this user to delete the list. + N CREATOR,DELOK + S CREATOR=$P(^PXRMXP(810.5,LISTIEN,0),U,7) + S DELOK=$S(CREATOR=DUZ:1,$D(^XUSEC("PXRM MANAGER",DUZ)):1,1:0) + Q DELOK + ; + ;================================================= +MES(TEXT) ;General mail message + N XMSUB + K ^TMP("PXRMXMZ",$J) + S XMSUB="CLINICAL REMINDER EXTRACT" + S ^TMP("PXRMXMZ",$J,1,0)=TEXT + D SEND^PXRMMSG(XMSUB) + Q + ; + ;================================================= +PERIOD(FREQ) ;Calculate next period + N CMON,CUR,CYR,ETYPE,NEXT,PERIOD,YEAR + ;Format current date YY/MM/DD + S CUR=$$FMTE^XLFDT($$NOW^XLFDT,7) + ;extract year and period + S YEAR=$P(CUR,"/"),PERIOD=$P(CUR,"/",2) + ;If yearly current year + I FREQ="Y" D + .S NEXT=YEAR + ;If quarterly use current quarter + I FREQ="Q" D + .S NEXT="Q"_((PERIOD-1\3)+1)_"/"_YEAR + ;If monthly use current month + I FREQ="M" D + .S NEXT="M"_PERIOD_"/"_YEAR + Q NEXT + ; + ;================================================= +RMPAT(NODE,INDP,INTP) ;Remove dead and test patients from + ;the list. + I INDP,INTP Q + N DFN,DOD,REMOVE + S DFN=0 + F S DFN=$O(^TMP($J,NODE,DFN)) Q:DFN="" D + .;DBIA 3744 + . S REMOVE=$S('INTP:$$TESTPAT^VADPT(DFN),1:0) + . I REMOVE K ^TMP($J,NODE,DFN) Q + . I INDP Q + .;DBIA #10035 + . S DOD=+$P($G(^DPT(DFN,.35)),U,1) + . I DOD=0 Q + . K ^TMP($J,NODE,DFN) + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMEUT1.m b/r/CLINICAL_REMINDERS-PXRM/PXRMEUT1.m index 618b9c23..7b075402 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMEUT1.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMEUT1.m @@ -1,155 +1,113 @@ -PXRMEUT1 ; SLC/PKR - General extract utilities ;05/08/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ;================================================= -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 - ; - ;================================================= -DAYSIM(FMDATE) ;Given a FileMan date return the number of days in the month. - N MONTH - S MONTH=$E(FMDATE,4,5) - S DAYS=$S(MONTH="01":31,MONTH="02":28,MONTH="03":31,MONTH="04":30,MONTH="05":31,MONTH="06":30,MONTH="07":31,MONTH="08":31,MONTH="09":30,MONTH="10":31,MONTH="11":30,MONTH="12":31,1:"") - I MONTH="02" D - . N LYEAR,YEAR - . S YEAR=$E(FMDATE,1,3)+1700 - . S LYEAR=$S((YEAR#4=0)&(YEAR#100'=0):1,YEAR#400=0:1,1:0) - . I LYEAR S DAYS=29 - Q DAYS - ; - ;================================================= -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 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 SEQ="",NL=0 - F S SEQ=$O(^PXRM(810.4,RULESET,30,"B",SEQ)) Q:'SEQ D - . 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. - . S FRIEN=$P(RSDATA,U,2) Q:'FRIEN - .;Check if entry is a finding rule (not a set or reminder rule) - . S FRDATA=$G(^PXRM(810.4,FRIEN,0)),FRTYP=$P(FRDATA,U,3) Q:FRTYP=3 - . S FRDATES=$P(FRDATA,U,4,5) - .;Get term IEN for finding rule - . I FRTYP=1 S FRTIEN=$P(FRDATA,U,7) Q:'FRTIEN - .;Get Reminder definition IEN for Reminder rule - . I FRTYP=2 S RRIEN=$P(FRDATA,U,10) Q:'RRIEN - .;Determine RBDT and REDT - . D RDATES(RSDATES,FRDATES,LBBDT,LBEDT,.RBDT,.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) - .;Reminder Definition List Rule - . I FRTYP=2 D REM(RRIEN,LBBDT,LBEDT,RBDT,REDT,.PXRMFVPL,.NL,.OUTPUT) - Q - ; - ;================================================= -FMULPRT(FARR,PXRMFVPL,NL,OUTPUT) ;Print the finding multiple - ;information. - ;Q - N BDT,EDT,DERROR,FNAME,FTYPE,IND,NOCC,TBDT,TEDT,TEMP,VPTR - S IND=0 - F S IND=+$O(FARR(20,IND)) Q:IND=0 D - . S VPTR=$P(FARR(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 - .;Set the finding parameters. - . D SSPAR^PXRMUTIL(FARR(20,IND,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 - ; - ;================================================= -RDATES(RSDATES,FRDATES,LBBDT,LBEDT,RBDT,REDT) ;Determine the beginning and - ;ending dates. - ;Date precedence: LIST BUILD < RULE SET < FINDING RULE < TERM/REMINDER - S RBDT=$P(FRDATES,U,1),REDT=$P(FRDATES,U,2) - I RBDT="",REDT="" S RBDT=$P(RSDATES,U,1),REDT=$P(RSDATES,U,2) - I RBDT="",REDT="" S RBDT=LBBDT,REDT=LBEDT - I RBDT="" S RBDT=0 - I REDT="" S REDT=LBEDT - I REDT=0 S REDT=DT - ;Convert RBDT and REDT to FileMan dates. - S RBDT=$$DCONV(RBDT,LBBDT,LBEDT) - S REDT=$$DCONV(REDT,LBBDT,LBEDT) - ;If the month is missing use January for the beginning date and - ;December for the ending date. - I $E(RBDT,4,5)="00" S RBDT=$E(RBDT,1,3)_"01"_$E(RBDT,6,7) - I $E(REDT,4,5)="00" S REDT=$E(REDT,1,3)_"12"_$E(REDT,6,7) - ;If the day is missing use the first for beginning date and the end - ;of the month for ending date. - I $E(RBDT,6,7)="00" S RBDT=$E(RBDT,1,5)_"01" - I $E(REDT,6,7)="00" S REDT=$E(REDT,1,5)_$$DAYSIM(REDT) - Q - ; - ;================================================= -REM(IEN,LBBDT,LBEDT,RBDT,REDT,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) - Q - ; - ;================================================= -TERM(IEN,LBBDT,LBEDT,RBDT,REDT,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) - Q - ; +PXRMEUT1 ; SLC/PKR - General extract utilities ;08/09/2006 + ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21 + ;================================================= +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) + ; + ;================================================= +DAYSIM(FMDATE) ;Given a FileMan date return the number of days in the month. + N MONTH + S MONTH=$E(FMDATE,4,5) + S DAYS=$S(MONTH="01":31,MONTH="02":28,MONTH="03":31,MONTH="04":30,MONTH="05":31,MONTH="06":30,MONTH="07":31,MONTH="08":31,MONTH="09":30,MONTH="10":31,MONTH="11":30,MONTH="12":31,1:"") + I MONTH="02" D + . N LYEAR,YEAR + . S YEAR=$E(FMDATE,1,3)+1700 + . S LYEAR=$S((YEAR#4=0)&(YEAR#100'=0):1,YEAR#400=0:1,1:0) + . I LYEAR S DAYS=29 + Q DAYS + ; + ;================================================= +DOCDATES(RULESET,LBBDT,LBEDT,NL,OUTPUT) ; + 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 + ;Build the variable pointer list. + D BLDRLIST^PXRMVPTR(811.902,.01,.PXRMFVPL) + S SEQ="",NL=0 + F S SEQ=$O(^PXRM(810.4,RULESET,30,"B",SEQ)) Q:'SEQ D + . 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 RSDATES=$G(^PXRM(810.4,RULESET,30,SUB,1)) + .;Finding rule ien. + . S FRIEN=$P(RSDATA,U,2) Q:'FRIEN + .;Check if entry is a finding rule (not a set or reminder rule) + . S FRDATA=$G(^PXRM(810.4,FRIEN,0)),FRTYP=$P(FRDATA,U,3) Q:FRTYP=3 + . S FRDATES=$P(FRDATA,U,4,5) + .;Get term IEN for finding rule + . I FRTYP=1 S FRTIEN=$P(FRDATA,U,7) Q:'FRTIEN + .;Get Reminder definition IEN for Reminder rule + . I FRTYP=2 S RRIEN=$P(FRDATA,U,10) Q:'RRIEN + .;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) + .;Term finding rules + . I FRTYP=1 D TERM(FRTIEN,.FINDPA,.PXRMFVPL,.NL,.OUTPUT) + .;Reminder Definition List Rule + . I FRTYP=2 D REM(RRIEN,.FINDPA,.PXRMFVPL,.NL,.OUTPUT) + Q + ; + ;================================================= +FMULPRT(DEFARR,FINDPA,PXRMFVPL,NL,OUTPUT) ;Print the finding multiple + ;information. + N BDT,EDT,FNAME,FTYPE,IND,NOCC,PFINDPA,TFINDPA,VPTR + S IND=0 + 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 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") + Q + ; + ;================================================= +RDATES(RSDATES,FRDATES,LBBDT,LBEDT,RBDT,REDT) ;Determine the beginning and + ;ending dates. + ;Date precedence: LIST BUILD < RULE SET < FINDING RULE < TERM/REMINDER + S RBDT=$P(FRDATES,U,1),REDT=$P(FRDATES,U,2) + I RBDT="",REDT="" S RBDT=$P(RSDATES,U,1),REDT=$P(RSDATES,U,2) + I RBDT="",REDT="" S RBDT=LBBDT,REDT=LBEDT + I RBDT="" S RBDT=0 + I REDT="" S REDT=LBEDT + I REDT=0 S REDT=$$DT^XLFDT + ;Convert RBDT and REDT to FileMan dates. + S RBDT=$$DCONV(RBDT,LBBDT,LBEDT) + S REDT=$$DCONV(REDT,LBBDT,LBEDT) + ;If the month is missing use January for the beginning date and + ;December for the ending date. + I $E(RBDT,4,5)="00" S RBDT=$E(RBDT,1,3)_"01"_$E(RBDT,6,7) + I $E(REDT,4,5)="00" S REDT=$E(REDT,1,3)_"12"_$E(REDT,6,7) + ;If the day is missing use the first for beginning date and the end + ;of the month for ending date. + I $E(RBDT,6,7)="00" S RBDT=$E(RBDT,1,5)_"01" + I $E(REDT,6,7)="00" S REDT=$E(REDT,1,5)_$$DAYSIM(REDT) + Q + ; + ;================================================= +REM(IEN,FINDPA,PXRMFVPL,NL,OUTPUT) ; + N DEFARR + D DEF^PXRMLDR(IEN,.DEFARR) + S NL=NL+1,OUTPUT(NL)=" REMINDER DEFINITION "_$P(DEFARR(0),U,1) + D FMULPRT(.DEFARR,.FINDPA,.PXRMFVPL,.NL,.OUTPUT) + Q + ; + ;================================================= +TERM(IEN,FINDPA,PXRMFVPL,NL,OUTPUT) ; + N TERMARR + D TERM^PXRMLDR(IEN,.TERMARR) + S NL=NL+1,OUTPUT(NL)=" TERM "_$P(TERMARR(0),U,1) + D FMULPRT(.TERMARR,.FINDPA,.PXRMFVPL,.NL,.OUTPUT) + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMEVFI.m b/r/CLINICAL_REMINDERS-PXRM/PXRMEVFI.m index be6621db..68e07d6d 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMEVFI.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMEVFI.m @@ -1,42 +1,42 @@ -PXRMEVFI ; SLC/PKR - Driver for finding evaluation. ;04/02/2007 - ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123 - ; - ;===================================================== -EVAL(DFN,DEFARR,FIEVAL) ;Evaluate the findings by group using the "E" - ;index. - N ENODE - S ENODE="" - F S ENODE=$O(DEFARR("E",ENODE)) Q:ENODE="" D - . I ENODE="AUTTEDT(" D EVALFI^PXRMEDU(DFN,.DEFARR,ENODE,.FIEVAL) Q - . I ENODE="AUTTEXAM(" D EVALFI^PXRMEXAM(DFN,.DEFARR,ENODE,.FIEVAL) Q - . I ENODE="AUTTHF(" D EVALFI^PXRMHF(DFN,.DEFARR,ENODE,.FIEVAL) Q - . I ENODE="AUTTIMM(" D EVALFI^PXRMIMM(DFN,.DEFARR,ENODE,.FIEVAL) Q - . I ENODE="AUTTSK(" D EVALFI^PXRMSKIN(DFN,.DEFARR,ENODE,.FIEVAL) Q - . I ENODE="GMRD(120.51," D EVALFI^PXRMVITL(DFN,.DEFARR,ENODE,.FIEVAL) Q - . I ENODE="LAB(60," D EVALFI^PXRMLAB(DFN,.DEFARR,ENODE,.FIEVAL) Q - . I ENODE="ORD(101.43," D EVALFI^PXRMORDR(DFN,.DEFARR,ENODE,.FIEVAL) Q - . I ENODE="PXD(811.2," D EVALFI^PXRMTAX(DFN,.DEFARR,ENODE,.FIEVAL) Q - . I ENODE="PXRMD(810.9," D EVALFI^PXRMLOCF(DFN,.DEFARR,ENODE,.FIEVAL) Q - . I ENODE="PXRMD(811.4," D EVALFI^PXRMCF(DFN,.DEFARR,ENODE,.FIEVAL) Q - . I ENODE="PXRMD(811.5," D EVALFI^PXRMTERM(DFN,.DEFARR,ENODE,.FIEVAL) Q - . I ENODE="PS(50.605," D EVALFI^PXRMDRCL(DFN,.DEFARR,ENODE,.FIEVAL) Q - . I ENODE="PSDRUG(" D EVALFI^PXRMDRUG(DFN,.DEFARR,ENODE,.FIEVAL) Q - . 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 - ;Evaluate function findings. - D EVAL^PXRMFF(DFN,.DEFARR,.FIEVAL) - Q - ; - ;===================================================== -EVALPL(DEFARR,FINUM,PLIST) ;Create a patient list for a regular - ;finding. - N FINDPA,TERMARR - S FINDPA(0)=DEFARR(20,FINUM,0) - S FINDPA(3)=DEFARR(20,FINUM,3) - S FINDPA(10)=DEFARR(20,FINUM,10) - S FINDPA(11)=DEFARR(20,FINUM,11) - D GENTERM^PXRMPLST(FINDPA(0),FINUM,.TERMARR) - D EVALPL^PXRMTERL(.FINDPA,.TERMARR,PLIST) - Q - ; +PXRMEVFI ; SLC/PKR - Driver for finding evaluation. ;12/01/2004 + ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005 + ; + ;===================================================== +EVAL(DFN,DEFARR,FIEVAL) ;Evaluate the findings by group using the "E" + ;index. + N ENODE + S ENODE="" + F S ENODE=$O(DEFARR("E",ENODE)) Q:ENODE="" D + . I ENODE="AUTTEDT(" D EVALFI^PXRMEDU(DFN,.DEFARR,ENODE,.FIEVAL) Q + . I ENODE="AUTTEXAM(" D EVALFI^PXRMEXAM(DFN,.DEFARR,ENODE,.FIEVAL) Q + . I ENODE="AUTTHF(" D EVALFI^PXRMHF(DFN,.DEFARR,ENODE,.FIEVAL) Q + . I ENODE="AUTTIMM(" D EVALFI^PXRMIMM(DFN,.DEFARR,ENODE,.FIEVAL) Q + . I ENODE="AUTTSK(" D EVALFI^PXRMSKIN(DFN,.DEFARR,ENODE,.FIEVAL) Q + . I ENODE="GMRD(120.51," D EVALFI^PXRMVITL(DFN,.DEFARR,ENODE,.FIEVAL) Q + . I ENODE="LAB(60," D EVALFI^PXRMLAB(DFN,.DEFARR,ENODE,.FIEVAL) Q + . I ENODE="ORD(101.43," D EVALFI^PXRMORDR(DFN,.DEFARR,ENODE,.FIEVAL) Q + . I ENODE="PXD(811.2," D EVALFI^PXRMTAX(DFN,.DEFARR,ENODE,.FIEVAL) Q + . I ENODE="PXRMD(810.9," D EVALFI^PXRMLOCF(DFN,.DEFARR,ENODE,.FIEVAL) Q + . I ENODE="PXRMD(811.4," D EVALFI^PXRMCF(DFN,.DEFARR,ENODE,.FIEVAL) Q + . I ENODE="PXRMD(811.5," D EVALFI^PXRMTERM(DFN,.DEFARR,ENODE,.FIEVAL) Q + . I ENODE="PS(50.605," D EVALFI^PXRMDRCL(DFN,.DEFARR,ENODE,.FIEVAL) Q + . I ENODE="PSDRUG(" D EVALFI^PXRMDRUG(DFN,.DEFARR,ENODE,.FIEVAL) Q + . 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," D EVALFI^PXRMMH(DFN,.DEFARR,ENODE,.FIEVAL) Q + ;Evaluate function findings. + D EVAL^PXRMFF(DFN,.DEFARR,.FIEVAL) + Q + ; + ;===================================================== +EVALPL(DEFARR,FINUM,PLIST) ;Create a patient list for a regular + ;finding. + N FINDPA,TERMARR + S FINDPA(0)=DEFARR(20,FINUM,0) + S FINDPA(3)=DEFARR(20,FINUM,3) + S FINDPA(10)=DEFARR(20,FINUM,10) + S FINDPA(11)=DEFARR(20,FINUM,11) + D GENTERM^PXRMPLST(FINDPA(0),FINUM,.TERMARR) + D EVALPL^PXRMTERM(.FINDPA,.TERMARR,PLIST) + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMEXCF.m b/r/CLINICAL_REMINDERS-PXRM/PXRMEXCF.m index 0cb5abe7..7c664729 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMEXCF.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMEXCF.m @@ -1,66 +1,76 @@ -PXRMEXCF ; SLC/PKR - Reminder exchange routines for computed findings. ;06/28/2007 - ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123 - ;============================================== -EXISTS(ROUTINE) ;Return true if routine ROUTINE exists. - I ROUTINE="" Q 0 - N RTN - S RTN="^"_ROUTINE - Q $S($T(@RTN)'="":1,1:0) - ; - ;============================================== -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 PCS,ROUTINE,SAME,TEXT,X,Y - S NEWNAME="" - 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 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) - E D - . 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="C" D - . N CDONE - . S CDONE=0 - . F Q:CDONE D - .. S NEWNAME=$$GETNAME^PXRMEXIU(ATTR("MIN FIELD LENGTH"),ATTR("FIELD LENGTH")) - .. I NEWNAME="" S ACTION="S",CDONE=1 Q - .. S EXISTS=$$EXISTS^PXRMEXCF(NEWNAME) - .. I EXISTS W !,"Routine ",NEWNAME," already exists, try again." - .. E D Q - ... S CDONE=1 - ... S NAMECHG(ATTR("FILE NUMBER"),ROUTINE)=NEWNAME - ; - I (ACTION="I")&(EXISTS) D - .;If the action is overwrite double check that overwrite is what the - .;user really wants to do. - . K DIR - . S DIR(0)="Y"_U_"A" - . S DIR("A")="Are you sure you want to overwrite" - . S DIR("B")="N" - . D ^DIR - . I $D(DIROUT)!$D(DIRUT) S Y=0 - . I $D(DTOUT)!$D(DUOUT) S Y=0 - . I 'Y S ACTION="S" - . S NAMECHG(ATTR("FILE NUMBER"),ROUTINE)=NEWNAME - Q ACTION - ; +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. + I ROUTINE="" Q 0 + N RTN + S RTN="^"_ROUTINE + Q $S($T(@RTN)'="":1,1:0) + ; + ;============================================== +GETRACT(ATTR,NEWNAME,NAMECHG,RTN,EXISTS) ;Get the action for a routine. + 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 + . S SAME=$$SAME(.ATTR,.RTN) + . S TEXT(1)="Routine "_ROUTINE_" already exists " + . 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?" + . S DIR("B")="I" + . S ACTION=$$GETACT^PXRMEXIU(CHOICES,.DIR) + ; + I ACTION="Q" Q ACTION + ; + I ACTION="C" D + . N CDONE + . S CDONE=0 + . F Q:CDONE D + .. S NEWNAME=$$GETNAME^PXRMEXIU(ATTR("MIN FIELD LENGTH"),ATTR("FIELD LENGTH")) + .. I NEWNAME="" S ACTION="S",CDONE=1 Q + .. S EXISTS=$$EXISTS^PXRMEXCF(NEWNAME) + .. I EXISTS W !,"Routine ",NEWNAME," already exists, try again." + .. E D Q + ... S CDONE=1 + ... S NAMECHG(ATTR("FILE NUMBER"),ROUTINE)=NEWNAME + ; + I (ACTION="I")&(EXISTS) D + .;If the action is overwrite double check that overwrite is what the + .;user really wants to do. + . K DIR + . S DIR(0)="Y"_U_"A" + . S DIR("A")="Are you sure you want to overwrite" + . S DIR("B")="N" + . D ^DIR + . I $D(DIROUT)!$D(DIRUT) S Y=0 + . I $D(DTOUT)!$D(DUOUT) S Y=0 + . I 'Y S ACTION="S" + . S NAMECHG(ATTR("FILE NUMBER"),ROUTINE)=NEWNAME + 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 + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMEXCS.m b/r/CLINICAL_REMINDERS-PXRM/PXRMEXCS.m index 1e1a0aa8..5f0c2e00 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMEXCS.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMEXCS.m @@ -1,140 +1,74 @@ -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,"") - . 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,"") - . 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 - ; - ;==================================================== -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) - Q CS - ; - ;==================================================== -HFCS(PATH,FILENAME) ;Return checksum for host file. - N CS,GBL,GBLZISH,SUCCESS - K ^TMP($J,"PXRMHFCS") - S GBL="^TMP($J,""PXRMHFCS"")" - S GBLZISH="^TMP($J,""PXRMHFCS"",1)" - S GBLZISH=$NA(@GBLZISH) - S SUCCESS=$$FTG^%ZISH(PATH,FILENAME,GBLZISH,3) - S CS=$S(SUCCESS:$$HFCSGBL(GBL),1:-1) - K ^TMP($J,"PXRMHFCS") - Q CS - ; - ;==================================================== -HFCSGBL(GBL) ;Return checksum for host file loaded into global GBL. - 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) - Q CS - ; - ;==================================================== -MMCS(XMZ) ;Return checksum for MailMan message ien XMZ. - N CS,IND,LINE,NLINES - 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) - 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 - 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) - Q CS - ; - ;==================================================== -RTNCS(ROUTINE) ;Return checksum for a routine ROUTINE. - N CS,DIF,RA,X,XCNP - S XCNP=0 - S DIF="RA(" - S X=ROUTINE - ;Make sure the routine exists. - X ^%ZOSF("TEST") - I $T D - . X ^%ZOSF("LOAD") - . S CS=$$ROUTINE(.RA) - E S CS=-1 - 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 - ; +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,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 + ; + ;==================================================== +HFCS(PATH,FILENAME) ;Return checksum for host file. + N CS,GBL,GBLZISH,SUCCESS + K ^TMP($J,"PXRMHFCS") + S GBL="^TMP($J,""PXRMHFCS"")" + S GBLZISH="^TMP($J,""PXRMHFCS"",1)" + S GBLZISH=$NA(@GBLZISH) + S SUCCESS=$$FTG^%ZISH(PATH,FILENAME,GBLZISH,3) + S CS=$S(SUCCESS:$$HFCSGBL(GBL),1:-1) + K ^TMP($J,"PXRMHFCS") + Q CS + ; + ;==================================================== +HFCSGBL(GBL) ;Return checksum for host file loaded into global GBL. + N CS,IND,LINE + S (CS,IND)=0 + 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 + ; + ;==================================================== +MMCS(XMZ) ;Return checksum for MailMan message ien XMZ. + N CS,IND,LINE,NLINES + 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=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,LINE + S (CS,IND)=0 + F S IND=$O(RA(IND)) Q:+IND=0 S CS=CS+$$LINECS(IND,RA(IND,0)) + Q CS + ; + ;==================================================== +RTN(ROUTINE) ;Return checksum for a routine ROUTINE. + N CS,DIF,RA,X,XCNP + S XCNP=0 + S DIF="RA(" + S X=ROUTINE + ;Make sure the routine exists. + X ^%ZOSF("TEST") + I $T D + . X ^%ZOSF("LOAD") + . S CS=$$ROUTINE(.RA) + E S CS=-1 + Q CS + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMEXDG.m b/r/CLINICAL_REMINDERS-PXRM/PXRMEXDG.m index 6447959e..ac525f0d 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMEXDG.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMEXDG.m @@ -1,231 +1,211 @@ -PXRMEXDG ;SLC/PJH - Reminder Dialog Exchange index build ;05/16/2007 - ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123 - ; - ;===================================================================== -DIALOG(RIEN,DLIST,FLIST,OLIST,TLIST,SPONLIST) ; - ; - ;Routine to get dialog details for a given reminder - ; - ;Called as DIALOG^PXRMEXDG(RIEN,.DLIST,.FLIST) - ; - ;RIEN - Reminder IEN - ;DLIST - List of dialogs (components first) - ;FLIST - Finding list used by PXRMEXPR - ;OLIST - List of embedded TIU objects - ;TLIST - List of embedded TIU templates - ; - ;Initialize - K DLIST - N DARRAY,DCNT,DIALOG,DIEN,FCNT,FINDING,OCNT,RCNT,RESULT,TEMP - ;Check if reminder exists - Q:'$D(^PXD(811.9,RIEN,0)) - ;Get dialog ien from reminder definition - S DIEN=$P($G(^PXD(811.9,RIEN,51)),U) Q:'DIEN - ;Check dialog pointer is valid - Q:'$D(^PXRMD(801.41,DIEN)) - ;Dialog and Finding count - S DCNT=0,FCNT=0,RCNT=0,TCNT=0 - ;Get details - D GETSPON^PXRMEXPR(801.41,DIEN,.SPONLIST) - D DGET(DIEN,.SPONLIST) - ; - ;Now build the dialog list (components first) - S DCNT="",OCNT=0 - F S DCNT=$O(DARRAY(DCNT),-1) Q:'DCNT D - .;Ignore dialogs previously encountered - .S DIEN=DARRAY(DCNT) Q:$D(DIALOG(DIEN)) - .;Save dialog in output array - .S OCNT=OCNT+1,DIALOG(DIEN)="",TEMP("DIALOG",OCNT)=DIEN - ; - ;Save the dialog and result details to DLIST - 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 CNT=1:1 S DIEN=$G(TEMP(DTYP,CNT)) Q:'DIEN D - ..S COUNT=COUNT+1,DLIST("DIALOG",COUNT,DIEN)="" - ; - I COUNT>0 S DLIST("DIALOG")=801.41 - ; - ;Add Dialog Findings to FLIST if not aready present - N DIC,DO,IEN,FNAME,FNUM,SUB - S SUB=0 - F S SUB=$O(TEMP("FINDING",SUB)) Q:'SUB D - .S IEN=$P(TEMP("FINDING",SUB),";"),DIC=U_$P(TEMP("FINDING",SUB),";",2) - .K DO D DO^DIC1 - .S FNUM=+DO(2),FNAME=$P(DO,U) I ('FNUM)!(FNAME="") Q - .;Check if present in FLIST - .I $D(FLIST(FNAME,"F",IEN)) Q - .;Otherwise add to list - .S:'$D(FLIST(FNAME)) FLIST(FNAME)=FNUM S FLIST(FNAME,"F",IEN)="" - .;Add the Health Factor category to FLIST - .I FNAME="HEALTH FACTORS" D - ..N HFCAT - ..S HFCAT=$P($G(^AUTTHF(IEN,0)),U,3) S:HFCAT FLIST(FNAME,"C",HFCAT)="" - ; - ;Store any TIU components - N GLOB,DIEN,CNT - ;Set global for search - S GLOB="^PXRMD(801.41," - ;Search through all component dialogs - S CNT=0 - F S CNT=$O(DLIST("DIALOG",CNT)) Q:'CNT D - .S DIEN=$O(DLIST("DIALOG",CNT,"")) Q:'DIEN - .;Search Dialog Text for TIU Objects and Templates - .D TIUSRCH(GLOB,DIEN,25,.OLIST,.TLIST) - .;Search P/N Text for TIU Objects and Templates - .D TIUSRCH(GLOB,DIEN,35,.OLIST,.TLIST) - ; - Q - ; - ;Get the dialog components - ;------------------------- -DGET(D0,SPONLIST) ;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 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) - .;Additional Finding Items - .D DFINDA(D0) - .;Result groups - .D DRESULT(D0) - ; - ;Dialog components - N DCOMP,DCOMP1,DDATA,DSUB - S DSUB=0 - F S DSUB=$O(^PXRMD(801.41,D0,10,DSUB)) Q:'DSUB D - .;Get any component dialogs - .S DCOMP=$P($G(^PXRMD(801.41,D0,10,DSUB,0)),U,2) Q:'DCOMP - .;If component exists get sub-components - .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 - .;Sub-components - .D DGET(DCOMP,.SPONLIST) - .;I $G(DCOMP1)'="" D DGET(DCOMP1) S DCOMP1="" - Q - ; - ;Build list of finding items - ;--------------------------- -DFIND(DIEN) ; - N FIND,FIEN,FGLOB,FNAM - ;Finding Item - S FIND=$P($G(^PXRMD(801.41,DIEN,1)),U,5) - ;If a finding item exists check and save -LOOP ; - I FIND]"" D - .;Finding item defined - .S FIEN=$P(FIND,";"),FGLOB=$P(FIND,";",2) Q:'FIEN Q:FGLOB="" - .;And finding item exists - .Q:'$D(@(U_FGLOB_FIEN_",0)")) - .;Finding name - .S FNAM=$P($G(@(U_FGLOB_FIEN_",0)")),U) S:FNAM="" FNAM="???" - .;And not previously saved - .I '$D(FINDING(FIND)) D - ..S FCNT=FCNT+1,FINDING(FIND)="",TEMP("FINDING",FCNT)=FIND - I $G(^PXRMD(801.41,DIEN,49))'="",$P(^PXRMD(801.41,DIEN,49),U)>0 D - .S FIND=$P(^PXRMD(801.41,DIEN,49),U) - .I $D(FLIST("REMINDER TERM","F",FIND)) Q - .I '$D(FLIST("REMINDER TERM")) S FLIST("REMINDER TERM")="811.5" - .S FLIST("REMINDER TERM","F",FIND)="" - .D GETTFIND^PXRMEXPR(.FLIST) - Q - ; - ;Build list of additional findings - ;--------------------------------- -DFINDA(DIEN) ; - N FIND,FIEN,FGLOB,FNAM,FSUB - S FSUB=0 - F S FSUB=$O(^PXRMD(801.41,DIEN,3,FSUB)) Q:'FSUB D - .;Additional Finding Item - .S FIND=$P($G(^PXRMD(801.41,DIEN,3,FSUB,0)),U) - .;If a finding item exists check and save - .I FIND]"" D - ..;Finding item defined - ..S FIEN=$P(FIND,";"),FGLOB=$P(FIND,";",2) Q:'FIEN Q:FGLOB="" - ..;And finding item exists - ..Q:'$D(@(U_FGLOB_FIEN_",0)")) - ..;Finding name - ..S FNAM=$P($G(@(U_FGLOB_FIEN_",0)")),U) S:FNAM="" FNAM="???" - ..;And not previously saved - ..I '$D(FINDING(FIND)) D - ...S FCNT=FCNT+1,FINDING(FIND)="",TEMP("FINDING",FCNT)=FIND - Q - ; - ;Build list of result groups - ;--------------------------- -DRESULT(DIEN) ; - N CNT,RIEN,RECNT,RGCNT - ;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 - Q - ; - ;Extract TIU Objects/Templates from any WP text - ;---------------------------------------------- -TIUSRCH(GLOB,IEN,NODE,OLIST,TLIST) ; - N OCNT,TCNT,TEXT - ;Add to existing arrays - S OCNT=+$O(OLIST(""),-1),TCNT=+$O(TLIST(""),-1),SUB=0 - ;Scan WP fields - F S SUB=$O(@(GLOB_IEN_","_NODE_","_SUB_")")) Q:'SUB D - .;Get individual line - .S TEXT=$G(@(GLOB_IEN_","_NODE_","_SUB_",0)")) Q:TEXT="" - .;Most text lines will have no TIU link so ignore them - .I (TEXT'["|")&(TEXT'["{FLD:") Q - .;Templates are in format {FLD:fldname} (only applies to dialogs) - .I GLOB[801.41 D TIUXTR("{FLD:","}",TEXT,.TLIST,.TCNT) - .;Objects are in format |Objectname| - .D TIUXTR("|","|",TEXT,.OLIST,.OCNT) - Q - ; -TIUXTR(SRCH,SRCH1,TEXT,OUTPUT,CNT) ; - N EXIST,IC,TXT,ONAME - S TXT=TEXT - F D Q:TXT'[SRCH - .S TXT=$E(TXT,$F(TXT,SRCH),$L(TXT)) Q:TXT'[SRCH1 - .S ONAME=$P(TXT,SRCH1) Q:ONAME="" - .;Check if already selected - .S EXIST=0,IC=0 - .F S IC=$O(OUTPUT(IC)) Q:'IC Q:EXIST D - ..I $G(OUTPUT(IC))=ONAME S EXIST=1 - .;Save array of object/template names - .I 'EXIST S CNT=CNT+1,OUTPUT(CNT)=ONAME - Q +PXRMEXDG ;SLC/PJH - Reminder Dialog Exchange index build ;02/25/2004 + ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005 + ; + ;===================================================================== +DIALOG(RIEN,DLIST,FLIST,OLIST,TLIST) ; + ; + ;Routine to get dialog details for a given reminder + ; + ;Called as DIALOG^PXRMEXDG(RIEN,.DLIST,.FLIST) + ; + ;RIEN - Reminder IEN + ;DLIST - List of dialogs (components first) + ;FLIST - Finding list used by PXRMEXPR + ;OLIST - List of embedded TIU objects + ;TLIST - List of embedded TIU templates + ; + ;Initialize + K DLIST + N DARRAY,DCNT,DIALOG,DIEN,FCNT,FINDING,OCNT,RCNT,RESULT,TEMP + ;Check if reminder exists + Q:'$D(^PXD(811.9,RIEN,0)) + ;Get dialog ien from reminder definition + S DIEN=$P($G(^PXD(811.9,RIEN,51)),U) Q:'DIEN + ;Check dialog pointer is valid + Q:'$D(^PXRMD(801.41,DIEN)) + ;Dialog and Finding count + S DCNT=0,FCNT=0,RCNT=0,TCNT=0 + ;Get details + D DGET(DIEN) + ; + ;Now build the dialog list (components first) + S DCNT="",OCNT=0 + F S DCNT=$O(DARRAY(DCNT),-1) Q:'DCNT D + .;Ignore dialogs previously encountered + .S DIEN=DARRAY(DCNT) Q:$D(DIALOG(DIEN)) + .;Save dialog in output array + .S OCNT=OCNT+1,DIALOG(DIEN)="",TEMP("DIALOG",OCNT)=DIEN + ; + ;Save the dialog and result details to DLIST + N CNT,COUNT,DTYP + S COUNT=0 + 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)="" + ; + I COUNT>0 S DLIST("DIALOG")=801.41 + ; + ;Add Dialog Findings to FLIST if not aready present + N DIC,DO,IEN,FNAME,FNUM,SUB + S SUB=0 + F S SUB=$O(TEMP("FINDING",SUB)) Q:'SUB D + .S IEN=$P(TEMP("FINDING",SUB),";"),DIC=U_$P(TEMP("FINDING",SUB),";",2) + .K DO D DO^DIC1 + .S FNUM=+DO(2),FNAME=$P(DO,U) I ('FNUM)!(FNAME="") Q + .;Check if present in FLIST + .I $D(FLIST(FNAME,"F",IEN)) Q + .;Otherwise add to list + .S:'$D(FLIST(FNAME)) FLIST(FNAME)=FNUM S FLIST(FNAME,"F",IEN)="" + .;Add the Health Factor category to FLIST + .I FNAME="HEALTH FACTORS" D + ..N HFCAT + ..S HFCAT=$P($G(^AUTTHF(IEN,0)),U,3) S:HFCAT FLIST(FNAME,"C",HFCAT)="" + ; + ;Store any TIU components + N GLOB,DIEN,CNT + ;Set global for search + S GLOB="^PXRMD(801.41," + ;Search through all component dialogs + S CNT=0 + F S CNT=$O(DLIST("DIALOG",CNT)) Q:'CNT D + .S DIEN=$O(DLIST("DIALOG",CNT,"")) Q:'DIEN + .;Search Dialog Text for TIU Objects and Templates + .D TIUSRCH(GLOB,DIEN,25,.OLIST,.TLIST) + .;Search P/N Text for TIU Objects and Templates + .D TIUSRCH(GLOB,DIEN,35,.OLIST,.TLIST) + ; + Q + ; + ;Get the dialog components + ;------------------------- +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) 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 + .;Finding items + .D DFIND(D0) + .;Additional Finding Items + .D DFINDA(D0) + .;Result groups + .D DRESULT(D0) + ; + ;Dialog components + N DCOMP,DCOMP1,DDATA,DSUB + S DSUB=0 + F S DSUB=$O(^PXRMD(801.41,D0,10,DSUB)) Q:'DSUB D + .;Get any component dialogs + .S DCOMP=$P($G(^PXRMD(801.41,D0,10,DSUB,0)),U,2) Q:'DCOMP + .;If component exists get sub-components + .S DDATA=$G(^PXRMD(801.41,DCOMP,0)) Q:DDATA="" + .;Exclude national PXRM prompts + .I $E(DDATA,1,4)="PXRM",$P($G(^PXRMD(801.41,DCOMP,100)),U)="N" Q + .;Sub-components + .D DGET(DCOMP) + .;I $G(DCOMP1)'="" D DGET(DCOMP1) S DCOMP1="" + Q + ; + ;Build list of finding items + ;--------------------------- +DFIND(DIEN) ; + N FIND,FIEN,FGLOB,FNAM + ;Finding Item + S FIND=$P($G(^PXRMD(801.41,DIEN,1)),U,5) + ;If a finding item exists check and save +LOOP ; + I FIND]"" D + .;Finding item defined + .S FIEN=$P(FIND,";"),FGLOB=$P(FIND,";",2) Q:'FIEN Q:FGLOB="" + .;And finding item exists + .Q:'$D(@(U_FGLOB_FIEN_",0)")) + .;Finding name + .S FNAM=$P($G(@(U_FGLOB_FIEN_",0)")),U) S:FNAM="" FNAM="???" + .;And not previously saved + .I '$D(FINDING(FIND)) D + ..S FCNT=FCNT+1,FINDING(FIND)="",TEMP("FINDING",FCNT)=FIND + I $G(^PXRMD(801.41,DIEN,49))'="",$P(^PXRMD(801.41,DIEN,49),U)>0 D + .S FIND=$P(^PXRMD(801.41,DIEN,49),U) + .I $D(FLIST("REMINDER TERM","F",FIND)) Q + .I '$D(FLIST("REMINDER TERM")) S FLIST("REMINDER TERM")="811.5" + .S FLIST("REMINDER TERM","F",FIND)="" + .D GETTFIND^PXRMEXPR(.FLIST) + Q + ; + ;Build list of additional findings + ;--------------------------------- +DFINDA(DIEN) ; + N FIND,FIEN,FGLOB,FNAM,FSUB + S FSUB=0 + F S FSUB=$O(^PXRMD(801.41,DIEN,3,FSUB)) Q:'FSUB D + .;Additional Finding Item + .S FIND=$P($G(^PXRMD(801.41,DIEN,3,FSUB,0)),U) + .;If a finding item exists check and save + .I FIND]"" D + ..;Finding item defined + ..S FIEN=$P(FIND,";"),FGLOB=$P(FIND,";",2) Q:'FIEN Q:FGLOB="" + ..;And finding item exists + ..Q:'$D(@(U_FGLOB_FIEN_",0)")) + ..;Finding name + ..S FNAM=$P($G(@(U_FGLOB_FIEN_",0)")),U) S:FNAM="" FNAM="???" + ..;And not previously saved + ..I '$D(FINDING(FIND)) D + ...S FCNT=FCNT+1,FINDING(FIND)="",TEMP("FINDING",FCNT)=FIND + Q + ; + ;Build list of result groups + ;--------------------------- +DRESULT(DIEN) ; + N RIEN + ;Result Group/Element pointer + 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 + ; + ;Extract TIU Objects/Templates from any WP text + ;---------------------------------------------- +TIUSRCH(GLOB,IEN,NODE,OLIST,TLIST) ; + N OCNT,TCNT,TEXT + ;Add to existing arrays + S OCNT=+$O(OLIST(""),-1),TCNT=+$O(TLIST(""),-1),SUB=0 + ;Scan WP fields + F S SUB=$O(@(GLOB_IEN_","_NODE_","_SUB_")")) Q:'SUB D + .;Get individual line + .S TEXT=$G(@(GLOB_IEN_","_NODE_","_SUB_",0)")) Q:TEXT="" + .;Most text lines will have no TIU link so ignore them + .I (TEXT'["|")&(TEXT'["{FLD:") Q + .;Templates are in format {FLD:fldname} (only applies to dialogs) + .I GLOB[801.41 D TIUXTR("{FLD:","}",TEXT,.TLIST,.TCNT) + .;Objects are in format |Objectname| + .D TIUXTR("|","|",TEXT,.OLIST,.OCNT) + Q + ; +TIUXTR(SRCH,SRCH1,TEXT,OUTPUT,CNT) ; + N EXIST,IC,TXT,ONAME + S TXT=TEXT + F D Q:TXT'[SRCH + .S TXT=$E(TXT,$F(TXT,SRCH),$L(TXT)) Q:TXT'[SRCH1 + .S ONAME=$P(TXT,SRCH1) Q:ONAME="" + .;Check if already selected + .S EXIST=0,IC=0 + .F S IC=$O(OUTPUT(IC)) Q:'IC Q:EXIST D + ..I $G(OUTPUT(IC))=ONAME S EXIST=1 + .;Save array of object/template names + .I 'EXIST S CNT=CNT+1,OUTPUT(CNT)=ONAME + Q diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMEXFI.m b/r/CLINICAL_REMINDERS-PXRM/PXRMEXFI.m index 915e23e8..a3ee0298 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMEXFI.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMEXFI.m @@ -1,153 +1,131 @@ -PXRMEXFI ; SLC/PKR/PJH - Exchange utilities for file entries.;07/05/2007 - ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123 - ;============================================== -DELALL(FILENUM,NAME) ;Delete all file entries named NAME. - N IEN,IND,LIST,MSG - D FIND^DIC(FILENUM,"","@","K",NAME,"*","","","","LIST","MSG") - I $P(LIST("DILIST",0),U,1)=0 Q - S IND=0 - F S IND=$O(LIST("DILIST",2,IND)) Q:IND="" D - . S IEN=LIST("DILIST",2,IND) - . D DELETE(FILENUM,IEN) - Q - ; - ;============================================== -DELETE(FILENUM,DA) ;Delete a file entry. - N DIK - 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 - ; - ;============================================== -FOKTI(FILENUM) ;Check if it is ok to install/transport this FILE. - ; - ;Drugs not allowed. - I FILENUM=50 Q 0 - ; - ;VA Generic not allowed. - I FILENUM=50.6 Q 0 - ; - ;VA Drug Class not allowed. - I FILENUM=50.605 Q 0 - ; - ;Lab tests not allowed. - I FILENUM=60 Q 0 - ; - ;Radiology procedures not allowed. - I FILENUM=71 Q 0 - ; - ;ICD9 (used in Dialogs) not allowed. - I FILENUM=80 Q 0 - ; - ;ICD0 not allowed. - I FILENUM=80.1 Q 0 - ; - ;CPT (used in Dialogs) not allowed. - I FILENUM=81 Q 0 - ; - ;Order Dialogs not allowed. - I FILENUM=101.41 Q 0 - ; - ;Orderable Items not allowed. - I FILENUM=101.43 Q 0 - ; - ;Sites cannot create entries in GMRV VITAL TYPE. - I FILENUM=120.51 Q 0 - ; - ;Mental Health Instruments not allowed. - I FILENUM=601 Q 0 - I FILENUM=601.71 Q 0 - ; - I FILENUM=790.404 Q 0 - ; - ;If control gets to here then it is an allowed file type. - Q 1 - ; - ;============================================== -GETFACT(PT01,ATTR,NEWPT01,NAMECHG,IEN) ;Get the action for a file. - N ACTION,CHOICES,CSUM,DIR,FILENUM,MSG,RESULT - N SAME,X,Y - ;See if this entry is already defined. -CHK ; - S NEWPT01="" - 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) - E D - . W !!,ATTR("FILE NAME")," entry ",PT01," is NEW," - . W !,"what do you want to do?" - . S CHOICES="CIQS" - . S DIR("B")="I" - . S ACTION=$$GETACT^PXRMEXIU(CHOICES,.DIR) - ; - I ACTION="Q" Q ACTION - I ACTION="C" D - . S NEWPT01=$$GETUNAME^PXRMEXIU(.ATTR) - .;Make sure the NEW .01 passes any input transforms. - . I NEWPT01="" S ACTION="S" - . E D CHK^DIE(ATTR("FILE NUMBER"),.01,"",NEWPT01,.RESULT,"MSG") - I $G(RESULT)="^" D G CHK - . D AWRITE^PXRMUTIL("MSG") - . K RESULT - ; - I ACTION="O" D - .;If the action is overwrite double check that is what the user - .;really wants to do. - . N DIROUT,DIRUT,DTOUT,DUOUT - . K DIR - . S DIR(0)="Y"_U_"A" - . S DIR("A")="Are you sure you want to overwrite" - . S DIR("B")="N" - . D ^DIR - . I $D(DIROUT)!$D(DIRUT) S Y=0 - . I $D(DTOUT)!$D(DUOUT) S Y=0 - . S ACTION=$S(Y:"O",1:"S") - ; - I ACTION="P" D - . N DIC,Y - . S DIC=ATTR("FILE NUMBER") - . S DIC(0)="AEMQ" - . D ^DIC - . I Y=-1 S ACTION="S" - . E S NEWPT01=$P(Y,U,2) - ; - I NEWPT01'="" S NAMECHG(ATTR("FILE NUMBER"),PT01)=NEWPT01 - Q ACTION - ; - ;============================================== -SETATTR(ATTR,FILE,PT01) ;Set the file attributes for the file FILE. - N MSG - S ATTR("FILE NUMBER")=FILE - S ATTR("FILE NAME")=$$GET1^DID(FILE,"","","NAME","","MSG") - ;This call gets the field length. - D FIELD^DID(FILE,.01,"","FIELD LENGTH","ATTR","MSG") - S ATTR("MIN FIELD LENGTH")=3 - S (ATTR("NAME"),ATTR("PT01"))=PT01 - Q - ; +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. + N IEN,IND,LIST,MSG + D FIND^DIC(FILENUM,"","@","K",NAME,"*","","","","LIST","MSG") + I $P(LIST("DILIST",0),U,1)=0 Q + S IND=0 + F S IND=$O(LIST("DILIST",2,IND)) Q:IND="" D + . S IEN=LIST("DILIST",2,IND) + . D DELETE(FILENUM,IEN) + Q + ; + ;============================================== +DELETE(FILENUM,DA) ;Delete a file entry. + N DIK + S DIK=$$ROOT^DILFD(FILENUM) + D ^DIK + Q + ; + ;============================================== +FOKTI(FILENUM) ;Check if it is ok to install/transport this FILE. + ; + ;Drugs not allowed. + I FILENUM=50 Q 0 + ; + ;VA Generic not allowed. + I FILENUM=50.6 Q 0 + ; + ;VA Drug Class not allowed. + I FILENUM=50.605 Q 0 + ; + ;Lab tests not allowed. + I FILENUM=60 Q 0 + ; + ;Radiology procedures not allowed. + I FILENUM=71 Q 0 + ; + ;ICD9 (used in Dialogs) not allowed. + I FILENUM=80 Q 0 + ; + ;ICD0 not allowed. + I FILENUM=80.1 Q 0 + ; + ;CPT (used in Dialogs) not allowed. + I FILENUM=81 Q 0 + ; + ;Order Dialogs not allowed. + I FILENUM=101.41 Q 0 + ; + ;Orderable Items not allowed. + I FILENUM=101.43 Q 0 + ; + ;Sites cannot create entries in GMRV VITAL TYPE. + I FILENUM=120.51 Q 0 + ; + ;Mental Health Instruments not allowed. + I FILENUM=601 Q 0 + ; + I FILENUM=790.404 Q 0 + ; + ;If control gets to here then it is an allowed file type. + Q 1 + ; + ;============================================== +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 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," + . W !,"what do you want to do?" + . S CHOICES="CIQS" + . S DIR("B")="I" + . S ACTION=$$GETACT^PXRMEXIU(CHOICES,.DIR) + ; + I ACTION="Q" Q ACTION + I ACTION="C" D + . S NEWPT01=$$GETUNAME^PXRMEXIU(.ATTR) + .;Make sure the NEW .01 passes any input transforms. + . I NEWPT01="" S ACTION="S" + . E D CHK^DIE(ATTR("FILE NUMBER"),.01,"",NEWPT01,.RESULT,"MSG") + I $G(RESULT)="^" D G CHK + . D AWRITE^PXRMUTIL("MSG") + . K RESULT + ; + I ACTION="O" D + .;If the action is overwrite double check that is what the user + .;really wants to do. + . N DIROUT,DIRUT,DTOUT,DUOUT + . K DIR + . S DIR(0)="Y"_U_"A" + . S DIR("A")="Are you sure you want to overwrite" + . S DIR("B")="N" + . D ^DIR + . I $D(DIROUT)!$D(DIRUT) S Y=0 + . I $D(DTOUT)!$D(DUOUT) S Y=0 + . S ACTION=$S(Y:"O",1:"S") + ; + I ACTION="P" D + . N DIC,Y + . S DIC=ATTR("FILE NUMBER") + . S DIC(0)="AEMQ" + . D ^DIC + . I Y=-1 S ACTION="S" + . E S NEWPT01=$P(Y,U,2) + ; + I NEWPT01'="" S NAMECHG(ATTR("FILE NUMBER"),PT01)=NEWPT01 + Q ACTION + ; + ;============================================== +SETATTR(ATTR,FILE) ;Set the file attributes for the file FILE. + N MSG + S ATTR("FILE NUMBER")=FILE + S ATTR("FILE NAME")=$$GET1^DID(FILE,"","","NAME","","MSG") + ;This call gets the field length. + D FIELD^DID(FILE,.01,"","FIELD LENGTH","ATTR","MSG") + S ATTR("MIN FIELD LENGTH")=3 + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMEXID.m b/r/CLINICAL_REMINDERS-PXRM/PXRMEXID.m index a7cfae44..5a942130 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMEXID.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMEXID.m @@ -1,283 +1,245 @@ -PXRMEXID ;SLC/PJH - Reminder Dialog Exchange Install Routine.;08/16/2007 - ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123 - ; - ;================================================== - ; - ;Install all dialog components in an exchange file entry - ;------------------------------------------------ -INSALL N ALL,DIROUT,DIRUT,DTOUT,DUOUT,IND,PXRMDONE - ; - ;Set the install date and time. - S IND="",PXRMDONE=0 - ; - ;Go to full screen mode. - D FULL^VALM1 - ; - ;Check if all or none exists - option to install all unchanged - N DNAME - 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 - .D INSCOM(IND,1) - ; - ;Clear lock - D UNLOCK - ; - ;Rebuild display workfile - D DISP^PXRMEXLD(PXRMMODE) - ; - K PXRMNMCH - Q - ; - ;Build list of descendents names - ;------------------------------- -INSBLD(NAME,INAME) ; - N DNAME,IDATA,ISEQ - S ISEQ=0 - 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)="" - .;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 - ; - ;Install component IND - ;--------------------- -INSCOM(IND,SILENT) ; - N ACTION,ATTR,CSUM,DTYP,EXIEN,END,EXISTS,FILENUM,IND120,JND120 - N NEWPT01,PT01,START,REPL,SAME,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="" - S JND120=$P(TEMP,U,6) Q:'JND120 - S IND120=$P(TEMP,U,5) Q:'IND120 - S TEMP=^PXD(811.8,PXRMRIEN,100,START,0),PT01=$P(TEMP,"~",2) Q:PT01="" - S DTYP=$G(^TMP("PXRMEXTMP",$J,"DTYP",PT01)) - I DTYP="dialog" S DTYP="reminder dialog" - ; - ;Go to full screen mode. - D FULL^VALM1 - ; - ;Check for descendents - S REPL=$$CHKREPL^PXRMEXD1(PT01) - I 'SILENT&($$INSDSC(PT01)!(REPL>0)) D Q:PXRMDONE - .N ANS,INDS,TEXT - .S TEXT(1)=PT01_" ("_DTYP_") contains sub-components." - .S TEXT="Install all sub-components with the "_DTYP_": " - .;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) - ..;Check if all or none exists - option to install all unchanged - ..D EXIST^PXRMEXIX(.ALL,PT01,DTYP,.INAME) Q:PXRMDONE - ..;Start at the end of the list - ..S IND="" - ..F S IND=$O(^TMP("PXRMEXLD",$J,"SEL",IND),-1) Q:PXRMDONE!(IND=INDS) D - ...N PT01,START,TEMP - ...S TEMP=^TMP("PXRMEXLD",$J,"SEL",IND),START=$P(TEMP,U,2) Q:START="" - ...S PT01=$P(^PXD(811.8,PXRMRIEN,100,START,0),"~",2) Q:PT01="" - ...;Ignore namechanges - ...I $D(PXRMNMCH(801.41,PT01)) Q - ...;Only install descendents - ...I $D(INAME(PT01)) D INSCOM(IND,1) - ; -SETENTRY ; - D SETATTR^PXRMEXFI(.ATTR,FILENUM,PT01) - S ACTION="" - ;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) - ;Save what was done for the installation summary. - S ^TMP("PXRMEXIAD",$J,IND,ATTR("FILE NAME"),ATTR("PT01"),ACTION)=NEWPT01 - ;Clear heading - S VALMHDR(2)="" - ;If the ACTION is Quit then quit the entire install. - I ACTION="Q" S PXRMDONE=1 S VALMHDR(2)="Install not completed" Q - ;If the ACTION is Skip then skip this component. - I ACTION="S" S VALMBCK="R" Q - ;If the ACTION is Replace then skip this component. - I ACTION="P" S VALMBCK="R",VALMHDR(2)=PT01_" replaced with "_NEWPT01 Q - ;Install this component. - D FILE^PXRMEXIC(PXRMRIEN,EXIEN,IND120,JND120,ACTION,.ATTR,.PXRMNMCH) - S VALMBCK="R" - I PXRMDONE S VALMHDR(2)="Install aborted" Q - I NEWPT01="" S VALMHDR(2)=PT01_" ("_DTYP_") installed from exchange file." - I NEWPT01'="" S VALMHDR(2)=PT01_" installed as "_NEWPT01_"." - ;If reminder dialog - disable and give option to link - I DTYP="reminder dialog" D - .N DNAME - .S DNAME=PT01 - .I NEWPT01'="" S DNAME=NEWPT01 - .D INSLNK(DNAME) - Q - ; - ;Check for descendents (either elements or prompts) - ;-------------------------------------------------- -INSDSC(NAME) ; - N DATA,DFOUND,SUB - S DFOUND=0,SUB=0 - 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 - 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 - ;----------------------------------- -INSLNK(DNAME) ; - N DIEN,DISABLE,DSRC,RNAME - N DA,DIE,DR - ;Disable - S DIEN=$O(^PXRMD(801.41,"B",DNAME,"")) Q:'DIEN - ;Set dialog as disabled - S DISABLE="DISABLED IN EXCHANGE" - ;Except for National dialogs - I $P(^PXRMD(801.41,DIEN,100),U)="N" S DISABLE="" - ; - S DR="3///^S X=DISABLE",DIE="^PXRMD(801.41,",DA=$P(DIEN,U) - D ^DIE - ; - ;Quit if already linked - I $D(^PXD(811.9,"AG",DIEN)) Q - ; - S RNAME="" - ;If reminder was renamed use as default - I $D(PXRMNMCH(811.9)) D - .S RNAME=$O(PXRMNMCH(811.9,"")) Q:RNAME="" - .S RNAME=$G(PXRMNMCH(811.9,RNAME)) - ;Otherwise use original reminder name as default - I RNAME="" D - .N DATA,FOUND,RIEN,SUB - .;Rebuild ^TMP("PXRMEXLC",$J - .D CDISP^PXRMEXLC(PXRMRIEN) - .; - .S SUB="",FOUND=0 - .F S SUB=$O(^TMP("PXRMEXLC",$J,"SEL",SUB),-1) Q:'SUB Q:FOUND D - ..S DATA=$G(^TMP("PXRMEXLC",$J,"SEL",SUB)) Q:$P(DATA,U)'=811.9 - ..S RIEN=$P(DATA,U,4),FOUND=1 Q:'RIEN - ..S RNAME=$P($G(^PXD(811.9,RIEN,0)),U) - ; -TAG W !!,"Reminder Dialog "_DNAME_" is not linked to a reminder.",! - ;Select reminder to link - S IEN=$$SELECT^PXRMINQ("^PXD(811.9,","Select Reminder to Link: ",RNAME) - ;Update reminder link in #811.9 - I $P(IEN,U)'=-1 D - .N DA,DIE,DIK,DR - .;Set reminder to dialog pointer - .S DR="51///^S X=DNAME",DIE="^PXD(811.9,",DA=$P(IEN,U) - .D ^DIE - .;If source reminder is null replace with linked reminder - .S DSRC=$P($G(^PXRMD(801.41,DIEN,0)),U,2) Q:DSRC - .S DSRC=$P(IEN,U) - .S DR="2///^S X=DSRC",DIE="^PXRMD(801.41,",DA=$P(DIEN,U) - .D ^DIE - Q - ; - ;Install Selected Components - ;--------------------------- -INSSEL N ALL,IND,PXRMDONE,VALMY - N DIROUT,DIRUT,DTOUT,DUOUT - N VALMBG,VALMLST - S VALMBG=1,VALMLST=+$O(^TMP("PXRMEXLD",$J,"IDX",""),-1) - ;Get the list to install. - D EN^VALM2(XQORNOD(0)) - ; - ;Set the install date and time. - S ALL="",PXRMDONE=0 - ; - ;Lock the entire file - Q:'$$LOCK - ; - S IND=0 - F S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE) D INSCOM(IND,0) - ; - ;Clear locks - D UNLOCK - ; - ;Rebuild workfile - D DISP^PXRMEXLD(PXRMMODE) - Q - ; - ;Install the exchange entry PXRMRIEN - ;----------------------------------- -INSTALL N IEN,IND,VALMY - ;Make sure the component list exists for this entry. PXRMRIEN is - ;set in INSTALL^PXRMEXLR. - I '$D(^PXD(811.8,PXRMRIEN,120)) D CLIST^PXRMEXU1(.PXRMRIEN) - I PXRMRIEN=-1 Q - ;Format the component list for display. - D CDISP^PXRMEXLC(PXRMRIEN) - S VALMBCK="R",VALMCNT=$O(^TMP("PXRMEXLD",$J,"IDX"),-1) - Q - ; -PXRM(NAME) ;Validate prompts - ; - ;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 - 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 - ;Otherwise local - Q 0 - ; - ;Lock the dialog file -LOCK() ; - L +^PXRMD(801.41):0 I Q 1 - E W !,"Another user is editing this file, try later" H 2 - Q 0 - ; - ;Clear lock -UNLOCK L -^PXRMD(801.41) - Q +PXRMEXID ;SLC/PJH - Reminder Dialog Exchange Install Routine.;11/14/2003 + ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005 + ; + ;================================================== + ; + ;Install all dialog components in an exchange file entry + ;------------------------------------------------ +INSALL N ALL,DIROUT,DIRUT,DTOUT,DUOUT,IND,PXRMDONE + K ^TMP("PXRMEXIA",$J) + ; + ;Set the install date and time. + S IND="",PXRMDONE=0,^TMP("PXRMEXIA",$J,"DT")=$$NOW^XLFDT + ; + ;Go to full screen mode. + D FULL^VALM1 + ; + ;Check if all or none exists - option to install all unchanged + N DNAME + S DNAME=$G(^TMP("PXRMEXTMP",$J,"PXRMDNAM")) + D EXIST^PXRMEXIX(.ALL,DNAME,"reminder dialog","") + ; + ;Lock the entire file + Q:'$$LOCK + ; + ;Install all components + F S IND=$O(^TMP("PXRMEXLD",$J,"SEL",IND),-1) Q:(+IND=0)!(PXRMDONE) D + .D INSCOM(IND,1) + ; + ;Clear lock + D UNLOCK + ; + ;Rebuild display workfile + D DISP^PXRMEXLD(PXRMMODE) + ; + K PXRMNMCH + Q + ; + ;Build list of descendents names + ;------------------------------- +INSBLD(NAME,INAME) ; + N DNAME,IDATA,ISEQ + S ISEQ=0 + 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="" Q:$$PXRM(DNAME) S INAME(DNAME)="" + .;Check for descendants + .I $D(^TMP("PXRMEXTMP",$J,"DMAP",DNAME)) D INSBLD(DNAME,.INAME) + Q + ; + ;Install component IND + ;--------------------- +INSCOM(IND,SILENT) ; + 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="" + S JND120=$P(TEMP,U,6) Q:'JND120 + S IND120=$P(TEMP,U,5) Q:'IND120 + S TEMP=^PXD(811.8,PXRMRIEN,100,START,0),PT01=$P(TEMP,"~",2) Q:PT01="" + S DTYP=$G(^TMP("PXRMEXTMP",$J,"DTYP",PT01)) + I DTYP="dialog" S DTYP="reminder dialog" + ; + ;Go to full screen mode. + D FULL^VALM1 + ; + ;Check for descendents + I 'SILENT,$$INSDSC(PT01) D Q:PXRMDONE + .N ANS,INDS,TEXT + .S TEXT(1)=PT01_" ("_DTYP_") contains sub-components." + .S TEXT="Install all sub-components with the "_DTYP_": " + .;Give option to install all descendents + .D ASK^PXRMEXIX(.ANS,.TEXT,1) Q:PXRMDONE + .I $G(ANS)="Y" D + ..S INDS=IND + ..N IDATA,INAME,IND + ..;Build list of decendents to install + ..D INSBLD(PT01,.INAME) + ..;Check if all or none exists - option to install all unchanged + ..D EXIST^PXRMEXIX(.ALL,PT01,DTYP,.INAME) Q:PXRMDONE + ..;Start at the end of the list + ..S IND="" + ..F S IND=$O(^TMP("PXRMEXLD",$J,"SEL",IND),-1) Q:PXRMDONE!(IND=INDS) D + ...N PT01,START,TEMP + ...S TEMP=^TMP("PXRMEXLD",$J,"SEL",IND),START=$P(TEMP,U,2) Q:START="" + ...S PT01=$P(^PXD(811.8,PXRMRIEN,100,START,0),"~",2) Q:PT01="" + ...;Ignore namechanges + ...I $D(PXRMNMCH(801.41,PT01)) Q + ...;Only install descendents + ...I $D(INAME(PT01)) D INSCOM(IND,1) + ; + 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 + ;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("PXRMEXIA",$J,IND,ATTR("FILE NAME"),ATTR("PT01"),ACTION)=NEWPT01 + ;Clear heading + S VALMHDR(2)="" + ;If the ACTION is Quit then quit the entire install. + I ACTION="Q" S PXRMDONE=1 S VALMHDR(2)="Install not completed" Q + ;If the ACTION is Skip then skip this component. + I ACTION="S" S VALMBCK="R" Q + ;If the ACTION is Replace then skip this component. + I ACTION="P" S VALMBCK="R",VALMHDR(2)=PT01_" replaced with "_NEWPT01 Q + ;Install this component. + D FILE^PXRMEXIC(PXRMRIEN,EXIEN,IND120,JND120,ACTION,.ATTR,.PXRMNMCH) + S VALMBCK="R" + I PXRMDONE S VALMHDR(2)="Install aborted" Q + I NEWPT01="" S VALMHDR(2)=PT01_" ("_DTYP_") installed from exchange file." + I NEWPT01'="" S VALMHDR(2)=PT01_" installed as "_NEWPT01_"." + ;If reminder dialog - disable and give option to link + I DTYP="reminder dialog" D + .N DNAME + .S DNAME=PT01 + .I NEWPT01'="" S DNAME=NEWPT01 + .D INSLNK(DNAME) + Q + ; + ;Check for descendents (either elements or prompts) + ;-------------------------------------------------- +INSDSC(NAME) ; + N DATA,DFOUND,SUB + S DFOUND=0,SUB=0 + 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="" + .I '$$PXRM($P(DATA,U)) S DFOUND=1 + Q DFOUND + ; + ;Option to link dialog to a reminder + ;----------------------------------- +INSLNK(DNAME) ; + N DIEN,DISABLE,DSRC,RNAME + N DA,DIE,DR + ;Disable + S DIEN=$O(^PXRMD(801.41,"B",DNAME,"")) Q:'DIEN + ;Set dialog as disabled + S DISABLE="DISABLED IN EXCHANGE" + ;Except for National dialogs + I $P(^PXRMD(801.41,DIEN,100),U)="N" S DISABLE="" + ; + S DR="3///^S X=DISABLE",DIE="^PXRMD(801.41,",DA=$P(DIEN,U) + D ^DIE + ; + ;Quit if already linked + I $D(^PXD(811.9,"AG",DIEN)) Q + ; + S RNAME="" + ;If reminder was renamed use as default + I $D(PXRMNMCH(811.9)) D + .S RNAME=$O(PXRMNMCH(811.9,"")) Q:RNAME="" + .S RNAME=$G(PXRMNMCH(811.9,RNAME)) + ;Otherwise use original reminder name as default + I RNAME="" D + .N DATA,FOUND,RIEN,SUB + .;Rebuild ^TMP("PXRMEXLC",$J + .D CDISP^PXRMEXLC(PXRMRIEN) + .; + .S SUB="",FOUND=0 + .F S SUB=$O(^TMP("PXRMEXLC",$J,"SEL",SUB),-1) Q:'SUB Q:FOUND D + ..S DATA=$G(^TMP("PXRMEXLC",$J,"SEL",SUB)) Q:$P(DATA,U)'=811.9 + ..S RIEN=$P(DATA,U,4),FOUND=1 Q:'RIEN + ..S RNAME=$P($G(^PXD(811.9,RIEN,0)),U) + ; +TAG W !!,"Reminder Dialog "_DNAME_" is not linked to a reminder.",! + ;Select reminder to link + S IEN=$$SELECT^PXRMINQ("^PXD(811.9,","Select Reminder to Link: ",RNAME) + ;Update reminder link in #811.9 + I $P(IEN,U)'=-1 D + .N DA,DIE,DIK,DR + .;Set reminder to dialog pointer + .S DR="51///^S X=DNAME",DIE="^PXD(811.9,",DA=$P(IEN,U) + .D ^DIE + .;If source reminder is null replace with linked reminder + .S DSRC=$P($G(^PXRMD(801.41,DIEN,0)),U,2) Q:DSRC + .S DSRC=$P(IEN,U) + .S DR="2///^S X=DSRC",DIE="^PXRMD(801.41,",DA=$P(DIEN,U) + .D ^DIE + Q + ; + ;Install Selected Components + ;--------------------------- +INSSEL N ALL,IND,PXRMDONE,VALMY + N DIROUT,DIRUT,DTOUT,DUOUT + N VALMBG,VALMLST + S VALMBG=1,VALMLST=+$O(^TMP("PXRMEXLD",$J,"IDX",""),-1) + ;Get the list to install. + D EN^VALM2(XQORNOD(0)) + ; + K ^TMP("PXRMEXIA",$J) + ;Set the install date and time. + S ALL="",PXRMDONE=0,^TMP("PXRMEXIA",$J,"DT")=$$NOW^XLFDT + ; + ;Lock the entire file + Q:'$$LOCK + ; + S IND=0 + F S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE) D + .D INSCOM(IND,0) + ; + ;Clear locks + D UNLOCK + ; + ;Rebuild workfile + D DISP^PXRMEXLD(PXRMMODE) + Q + ; + ;Install the exchange entry PXRMRIEN + ;----------------------------------- +INSTALL N IEN,IND,VALMY + ;Make sure the component list exists for this entry. PXRMRIEN is + ;set in INSTALL^PXRMEXLR. + I '$D(^PXD(811.8,PXRMRIEN,120)) D CLIST^PXRMEXU1(.PXRMRIEN) + I PXRMRIEN=-1 Q + ;Format the component list for display. + D CDISP^PXRMEXLC(PXRMRIEN) + S VALMBCK="R",VALMCNT=$O(^TMP("PXRMEXLD",$J,"IDX"),-1) + Q + ; +PXRM(NAME) ;Validate prompts + ; + ;Ignore non-PXRM + I $E(NAME,1,4)'="PXRM" Q 0 + ; + ;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 + ;Check class + I $P($G(^PXRMD(801.41,DIEN,100)),U)="N" Q 1 + ;Otherwise local + Q 0 + ; + ;Lock the dialog file +LOCK() ; + L +^PXRMD(801.41):0 I Q 1 + E W !,"Another user is editing this file, try later" H 2 + Q 0 + ; + ;Clear lock +UNLOCK L -^PXRMD(801.41) + Q diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMEXIU.m b/r/CLINICAL_REMINDERS-PXRM/PXRMEXIU.m index 9b40fe9b..9f688701 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMEXIU.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMEXIU.m @@ -1,252 +1,262 @@ -PXRMEXIU ; SLC/PKR/PJH - Utilities for installing repository entries. ;07/27/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ;=============================================== -DEF(FDA,NAMECHG) ;Check the reminder definition to make sure the related - ;reminder exists and all the findings exist. - N ABBR,ALIST,IEN,IENS,FILENUM,FINDING,LRD,OFINDING,PT01 - N RRG,SPONSOR,TEXT,VERSN - S IENS=$O(FDA(811.9,"")) - ; - ;Related reminder guideline field 1.4. - I $D(FDA(811.9,IENS,1.4)) D - . S RRG=FDA(811.9,IENS,1.4) - . S IEN=$$EXISTS^PXRMEXIU(811.9,RRG) - . I IEN=0 D - ..;Get replacement. - .. N DIC,X,Y - .. S TEXT(1)=" " - .. S TEXT(2)="The Related Reminder Guideline does not exist on your system!" - .. S TEXT(3)="It is "_RRG_" input a replacement or ^ to leave it empty." - .. D MES^XPDUTL(.TEXT) - ..;If this is being called during a KIDS install we need echoing on. - .. I $D(XPDNM) X ^%ZOSF("EON") - .. S DIC=811.9,DIC(0)="AEMQ" - .. D ^DIC - .. I $D(XPDNM) X ^%ZOSF("EOFF") - .. I Y=-1 K FDA(811.9,IENS,1.4) - .. E S FDA(811.9,IENS,1.4)=$P(Y,U,2) - ; - ;Sponsor field 101. - I $D(FDA(811.9,IENS,101)) D - . S SPONSOR=FDA(811.9,IENS,101) - . S IEN=$$FIND1^DIC(811.6,"","",SPONSOR) - . I IEN=0 D - ..;Get replacement. - .. N DIC,X,Y - .. S TEXT(1)=" " - .. S TEXT(2)="The Sponsor does not exist on your system!" - .. S TEXT(3)="It is "_SPONSOR_" input a replacement or ^ to leave it empty." - .. D MES^XPDUTL(.TEXT) - ..;If this is being called during a KIDS install we need echoing on. - .. I $D(XPDNM) X ^%ZOSF("EON") - .. S DIC=811.6,DIC(0)="AEMQ" - .. D ^DIC - .. I $D(XPDNM) X ^%ZOSF("EOFF") - .. I Y=-1 K FDA(811.9,IENS,101) - .. E S FDA(811.9,IENS,101)=$P(Y,U,2) - ; - ;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,""))) - I IEN=0 K FDA(811.9,IENS,51) - ; - ;Search the finding multiple for replacements and missing findings. - D BLDALIST^PXRMVPTR(811.902,.01,.ALIST) - S IENS="" - F S IENS=$O(FDA(811.902,IENS)) Q:IENS="" D - . S (FINDING,OFINDING)=FDA(811.902,IENS,.01) - . S ABBR=$P(FINDING,".",1) - . S PT01=$P(FINDING,".",2) - . S FILENUM=$P(ALIST(ABBR),U,1) - . I $D(NAMECHG(FILENUM,PT01)) D - .. S FINDING=ABBR_"."_NAMECHG(FILENUM,PT01) - .. S FDA(811.902,IENS,.01)=FINDING - . S IEN=+$$VFIND1(FINDING,.ALIST) - . I IEN>0 S FDA(811.902,IENS,.01)=ABBR_".`"_IEN - . I IEN=0 D - ..;Get replacement - .. N DIC,DUOUT,TEXT,X,Y - .. S TEXT="Finding "_FINDING_" does not exist; input a replacement or ^ to quit the install." - .. W !,TEXT - .. S DIC=FILENUM - .. I DIC="60" S DIC("S")="I $$LABPANEL^PXRMEXIU(Y)" - .. S DIC(0)="AEMNQ" - .. 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="" K FDA - .. I Y="" Q - .. S FINDING=ABBR_"."_$P(Y,U,2),FDA(811.902,IENS,.01)=FINDING - .;Save the finding information for the history. - . S ^TMP("PXRMEXIA",$J,"DEFF",$P(IENS,",",1),OFINDING)=FINDING - .;Save changes to Orderable items for dialog - . I FILENUM=101.43,OFINDING'=FINDING - . S NAMECHG(FILENUM,$P(OFINDING,".",2))=$P(FINDING,".",2) - S VERSN=$$GETTAGV^PXRMEXU3(^PXD(811.8,PXRMRIEN,100,3,0),"") - I VERSN=1.5 D CEFD^PXRMDATE(.FDA) - Q - ; - ;=============================================== -EXISTS(FILENUM,NAME,FLAG) ;Check for existence of an entry with the - ;same name. Return 0 for null name - I NAME="" Q 0 - ;Return the ien if it does, 0 otherwise. - N IEN - I FILENUM=0 S IEN=$$EXISTS^PXRMEXCF(NAME) Q - N FLAGS,RESULT - S RESULT=NAME - ;Special lookup for files 80 and 80.1, they do not have a standard "B" - ;cross-reference. - I (FILENUM=80)!(FILENUM=80.1) D - .;Name may or may not have the necessary space appended, make sure - .;it does. - . S RESULT=$S($E(NAME,$L(NAME))'=" ":NAME_" ",1:NAME) - . S FLAGS="MX" - E S FLAGS="BX" - I FILENUM=811.6 S FLAGS=FLAGS_"U" - ;File 8927.1 only allows upper case .01s. - I FILENUM=8927.1 S RESULT=$$UP^XLFSTR(NAME) - S IEN=$$FIND1^DIC(FILENUM,"",FLAGS,RESULT) - I +IEN>0 Q IEN - ;If IEN is null then there was an error try FIND^DIC. - N FILENAME,LIST,MSG,NFOUND,TEXT - D FIND^DIC(FILENUM,"","",FLAGS,NAME,"","","","","LIST","MSG") - S NFOUND=+$P(LIST("DILIST",0),U,1) - I NFOUND=0 Q 0 - I NFOUND=1 Q LIST("DILIST",2,1) - ;Multiple entries with the same name found. - S FILENAME=$$GET1^DID(FILENUM,"","","NAME") - S TEXT(1)="Warning there are "_NFOUND_" "_FILENAME_" entries with the name "_NAME_"!" - S TEXT(2)="If this is used as a finding, and it is not resolved by FileMan during" - S TEXT(3)="installation, any component using this finding will not install." - D EN^DDIOL(.TEXT) - I $G(FLAG)="W" H 3 Q LIST("DILIST",2,1) - I NFOUND>1 S IEN=$$GETIEN^PXRMEXU0(NFOUND,.LIST) - Q IEN - ; - ;=============================================== -GETACT(CHOICES,DIR) ;Get the action - ;If CHOICES is empty the only action is skip. - I CHOICES="" Q "S" - N DIROUT,DIRUT,DTOUT,DUOUT,X,Y - S DIR(0)="S"_U - I CHOICES["C" S DIR(0)=DIR(0)_"C:Create a new entry by copying to a new name" - I CHOICES["D" S DIR(0)=DIR(0)_";D:Delete (from the reminder/dialog)" - I CHOICES["I" S DIR(0)=DIR(0)_";I:Install" - I CHOICES["M" S DIR(0)=DIR(0)_";M:Merge findings" - I CHOICES["O" S DIR(0)=DIR(0)_";O:Overwrite the current entry" - I CHOICES["P" S DIR(0)=DIR(0)_";P:Replace (in the reminder/dialog) with an existing entry" - I CHOICES["Q" S DIR(0)=DIR(0)_";Q:Quit the install" - I CHOICES["R" S DIR(0)=DIR(0)_";R:Restart" - I CHOICES["S" S DIR(0)=DIR(0)_";S:Skip, do not install this entry" - ;If this is being called during a KIDS install we need echoing on. - I $D(XPDNM) X ^%ZOSF("EON") - D ^DIR - I $D(XPDNM) X ^%ZOSF("EOFF") - I $D(DIROUT)!$D(DIRUT) S Y="S" - I $D(DTOUT)!($D(DUOUT)) S Y="S" - Q Y - ; - ;=============================================== -GETNAME(MIN,MAX) ;Get a name to use. - N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y - S DIR(0)="FAOU"_U_MIN_":"_MAX - S DIR("A")="Input the new name: " - D ^DIR - I $D(DIROUT)!$D(DIRUT) Q "" - I $D(DTOUT)!$D(DUOUT) Q "" - Q Y - ; - ;=============================================== -GETUNAME(ATTR) ;Get a unique name to use, ATTR holds the attributes. - N IEN,NEWPT01,TEXT -GNEW S NEWPT01=$$GETNAME(ATTR("MIN FIELD LENGTH"),ATTR("FIELD LENGTH")) - S IEN=+$$EXISTS(ATTR("FILE NUMBER"),NEWPT01) - I IEN>0 D G GNEW - . S TEXT=ATTR("FILE NAME")_" entry "_NEWPT01_" already exists, what do you want to do?" - . D EN^DDIOL(TEXT) - E S ATTR("NAME")=NEWPT01 - Q NEWPT01 - ; - ;=============================================== -HF(FDA,NAMECHG) ;Check the health factor to make sure a category does not - ;have a category. - N IENS - S IENS=$O(FDA(9999999.64,"")) - I IENS="" Q - I FDA(9999999.64,IENS,.1)="CATEGORY" K FDA(9999999.64,IENS,.03) - Q - ; - ;=============================================== -LABPANEL(IEN) ; - N NODE - S NODE=^LAB(60,IEN,0) - I $P(NODE,U,4)'["CH" Q 1 - I $P(NODE,U,5)="" Q 0 - Q 1 - ; - ;=============================================== -REXISTS(NAME,DATEP) ;See if this Exchange File entry already exists. - N IEN,LUVALUE - S LUVALUE(1)=NAME - S LUVALUE(2)=DATEP - S IEN=+$$FIND1^DIC(811.8,"","KU",.LUVALUE) - Q IEN - ; - ;=============================================== -TERM(FDA,NAMECHG) ;Check the reminder term to make sure all the - ;findings exist. - N ABBR,ALIST,IEN,IENS,FILENUM,FINDING,OFINDING,PT01 - ;Search the finding multiple for replacements and missing findings. - D BLDALIST^PXRMVPTR(811.52,.01,.ALIST) - S IENS="" - F S IENS=$O(FDA(811.52,IENS)) Q:IENS="" D - . S (FINDING,OFINDING)=FDA(811.52,IENS,.01) - . S ABBR=$P(FINDING,".",1) - . S PT01=$P(FINDING,".",2) - . S FILENUM=$P(ALIST(ABBR),U,1) - . I $D(NAMECHG(FILENUM,PT01)) D - .. S FINDING=ABBR_"."_NAMECHG(FILENUM,PT01) - .. S FDA(811.52,IENS,.01)=FINDING - . S IEN=+$$VFIND1(FINDING,.ALIST) - . I IEN>0 S FDA(811.52,IENS,.01)=ABBR_".`"_IEN - . I IEN=0 D - ..;Get replacement - .. N DIC,DUOUT,TEXT,X,Y - .. S TEXT="Finding "_FINDING_" does not exist; input a replacement or ^ to quit the install." - .. D BMES^XPDUTL(TEXT) - .. S DIC=FILENUM - .. I DIC="60" S DIC("S")="I $$LABPANEL^PXRMEXIU(Y)" - .. S DIC(0)="AEMNQ" - .. 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) D - .... S Y="" - .... K FDA - .. I Y="" K FDA(811.52,IENS) - .. E D - ... S FINDING=ABBR_"."_$P(Y,U,2) - ... S FDA(811.52,IENS,.01)=FINDING - .;Save the finding information for the history. - . S ^TMP("PXRMEXIA",$J,"TRMF",$P(IENS,",",1),OFINDING)=FINDING - Q - ; - ;=============================================== -VFIND1(VPTR,ALIST) ;Given a variable pointer of the form ABBR.NAME - ;and ALIST which contains the link between abbreviations and files - ;return the IEN if it exists and 0 if no match if found. - N ABBR,IEN,FILENUM,PT01,RESULT - S IEN=0 - S ABBR=$P(VPTR,".",1) - S PT01=$P(VPTR,".",2,99) - S FILENUM=$P(ALIST(ABBR),U,1) - S IEN=$$EXISTS(FILENUM,PT01) - Q IEN - ; +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 + ;reminder exists and all the findings exist. + N ABBR,ALIST,IEN,IENS,FILENUM,FINDING,LRD,OFINDING,PT01 + N RRG,SPONSOR,TEXT,VERSN + S IENS=$O(FDA(811.9,"")) + ; + ;Related reminder guideline field 1.4. + I $D(FDA(811.9,IENS,1.4)) D + . S RRG=FDA(811.9,IENS,1.4) + . S IEN=$$EXISTS^PXRMEXIU(811.9,RRG) + . I IEN=0 D + ..;Get replacement. + .. N DIC,X,Y + .. S TEXT(1)=" " + .. S TEXT(2)="The Related Reminder Guideline does not exist on your system!" + .. S TEXT(3)="It is "_RRG_" input a replacement or ^ to leave it empty." + .. D MES^XPDUTL(.TEXT) + ..;If this is being called during a KIDS install we need echoing on. + .. I $D(XPDNM) X ^%ZOSF("EON") + .. S DIC=811.9,DIC(0)="AEMQ" + .. D ^DIC + .. I $D(XPDNM) X ^%ZOSF("EOFF") + .. I Y=-1 K FDA(811.9,IENS,1.4) + .. E S FDA(811.9,IENS,1.4)=$P(Y,U,2) + ; + ;Sponsor field 101. + I $D(FDA(811.9,IENS,101)) D + . S SPONSOR=FDA(811.9,IENS,101) + . S IEN=$$FIND1^DIC(811.6,"","",SPONSOR) + . I IEN=0 D + ..;Get replacement. + .. N DIC,X,Y + .. S TEXT(1)=" " + .. S TEXT(2)="The Sponsor does not exist on your system!" + .. S TEXT(3)="It is "_SPONSOR_" input a replacement or ^ to leave it empty." + .. D MES^XPDUTL(.TEXT) + ..;If this is being called during a KIDS install we need echoing on. + .. I $D(XPDNM) X ^%ZOSF("EON") + .. S DIC=811.6,DIC(0)="AEMQ" + .. D ^DIC + .. I $D(XPDNM) X ^%ZOSF("EOFF") + .. I Y=-1 K FDA(811.9,IENS,101) + .. E S FDA(811.9,IENS,101)=$P(Y,U,2) + ; + ;Linked reminder dialog field 51. + S LRD=+$G(FDA(811.9,IENS,51)) + S IEN=$$EXISTS^PXRMEXIU(801.41,LRD) + I IEN=0 K FDA(811.9,IENS,51) + ; + ;Search the finding multiple for replacements and missing findings. + D BLDALIST^PXRMVPTR(811.902,.01,.ALIST) + S IENS="" + F S IENS=$O(FDA(811.902,IENS)) Q:IENS="" D + . S (FINDING,OFINDING)=FDA(811.902,IENS,.01) + . S ABBR=$P(FINDING,".",1) + . S PT01=$P(FINDING,".",2) + . S FILENUM=$P(ALIST(ABBR),U,1) + . I $D(NAMECHG(FILENUM,PT01)) D + .. S FINDING=ABBR_"."_NAMECHG(FILENUM,PT01) + .. S FDA(811.902,IENS,.01)=FINDING + . S IEN=+$$VFIND1(FINDING,.ALIST) + . I IEN>0 S FDA(811.902,IENS,.01)=ABBR_".`"_IEN + . I IEN=0 D + ..;Get replacement + .. N DIC,DUOUT,TEXT,X,Y + .. S TEXT="Finding "_FINDING_" does not exist; input a replacement or ^ to quit the install." + .. W !,TEXT + .. S DIC=FILENUM + .. I DIC="60" S DIC("S")="I $$LABPANEL^PXRMEXIU(Y)" + .. S DIC(0)="AEMNQ" + .. 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="" K FDA + .. I Y="" Q + .. S FINDING=ABBR_"."_$P(Y,U,2),FDA(811.902,IENS,.01)=FINDING + .;Save the finding information for the history. + . S ^TMP("PXRMEXIA",$J,"DEFF",$P(IENS,",",1),OFINDING)=FINDING + .;Save changes to Orderable items for dialog + . I FILENUM=101.43,OFINDING'=FINDING + . S NAMECHG(FILENUM,$P(OFINDING,".",2))=$P(FINDING,".",2) + S VERSN=$$GETTAGV^PXRMEXU3(^PXD(811.8,PXRMRIEN,100,3,0),"") + I VERSN=1.5 D CEFD^PXRMDATE(.FDA) + Q + ; + ;=============================================== +EXISTS(FILENUM,NAME,FLAG) ;Check for existence of an entry with the + ;same name. Return 0 for null name + I NAME="" Q 0 + ;Return the ien if it does, 0 otherwise. + N IEN + I FILENUM=0 S IEN=$$EXISTS^PXRMEXCF(NAME) Q + N FLAGS,RESULT + S RESULT=NAME + ;Special lookup for files 80 and 80.1, they do not have a standard "B" + ;cross-reference. + I (FILENUM=80)!(FILENUM=80.1) D + .;Name may or may not have the necessary space appended, make sure + .;it does. + . S RESULT=$S($E(NAME,$L(NAME))'=" ":NAME_" ",1:NAME) + . S FLAGS="MX" + E S FLAGS="BX" + I FILENUM=811.6 S FLAGS=FLAGS_"U" + ;File 8927.1 only allows upper case .01s. + I FILENUM=8927.1 S RESULT=$$UP^XLFSTR(NAME) + S IEN=$$FIND1^DIC(FILENUM,"",FLAGS,RESULT) + I +IEN>0 Q IEN + ;If IEN is null then there was an error try FIND^DIC. + N FILENAME,LIST,MSG,NFOUND,TEXT + D FIND^DIC(FILENUM,"","",FLAGS,NAME,"","","","","LIST","MSG") + S NFOUND=+$P(LIST("DILIST",0),U,1) + I NFOUND=0 Q 0 + I NFOUND=1 Q LIST("DILIST",2,1) + ;Multiple entries with the same name found. + S FILENAME=$$GET1^DID(FILENUM,"","","NAME") + S TEXT(1)="Warning there are "_NFOUND_" "_FILENAME_" entries with the name "_NAME_"!" + S TEXT(2)="If this is used as a finding, and it is not resolved by FileMan during" + S TEXT(3)="installation, any component using this finding will not install." + D EN^DDIOL(.TEXT) + I $G(FLAG)="W" H 3 Q LIST("DILIST",2,1) + I NFOUND>1 S IEN=$$GETIEN^PXRMEXU0(NFOUND,.LIST) + Q IEN + ; + ;=============================================== +GETACT(CHOICES,DIR) ;Get the action + ;If CHOICES is empty the only action is skip. + I CHOICES="" Q "S" + N DIROUT,DIRUT,DTOUT,DUOUT,X,Y + S DIR(0)="S"_U + I CHOICES["C" S DIR(0)=DIR(0)_"C:Create a new entry by copying to a new name" + I CHOICES["D" S DIR(0)=DIR(0)_";D:Delete (from the reminder/dialog)" + I CHOICES["I" S DIR(0)=DIR(0)_";I:Install" + I CHOICES["M" S DIR(0)=DIR(0)_";M:Merge findings" + I CHOICES["O" S DIR(0)=DIR(0)_";O:Overwrite the current entry" + I CHOICES["P" S DIR(0)=DIR(0)_";P:Replace (in the reminder/dialog) with an existing entry" + I CHOICES["Q" S DIR(0)=DIR(0)_";Q:Quit the install" + I CHOICES["R" S DIR(0)=DIR(0)_";R:Restart" + I CHOICES["S" S DIR(0)=DIR(0)_";S:Skip, do not install this entry" + ;If this is being called during a KIDS install we need echoing on. + I $D(XPDNM) X ^%ZOSF("EON") + D ^DIR + I $D(XPDNM) X ^%ZOSF("EOFF") + I $D(DIROUT)!$D(DIRUT) S Y="S" + I $D(DTOUT)!($D(DUOUT)) S Y="S" + Q Y + ; + ;=============================================== +GETNAME(MIN,MAX) ;Get a name to use. + N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y + S DIR(0)="FAOU"_U_MIN_":"_MAX + S DIR("A")="Input the new name: " + D ^DIR + I $D(DIROUT)!$D(DIRUT) Q "" + I $D(DTOUT)!$D(DUOUT) Q "" + Q Y + ; + ;=============================================== +GETUNAME(ATTR) ;Get a unique name to use, ATTR holds the attributes. + N IEN,NEWPT01,TEXT +GNEW S NEWPT01=$$GETNAME(ATTR("MIN FIELD LENGTH"),ATTR("FIELD LENGTH")) + S IEN=+$$EXISTS(ATTR("FILE NUMBER"),NEWPT01) + I IEN>0 D G GNEW + . S TEXT=ATTR("FILE NAME")_" entry "_NEWPT01_" already exists, what do you want to do?" + . D EN^DDIOL(TEXT) + E S ATTR("NAME")=NEWPT01 + Q NEWPT01 + ; + ;=============================================== +HF(FDA,NAMECHG) ;Check the health factor to make sure a category does not + ;have a category. + N IENS + S IENS=$O(FDA(9999999.64,"")) + I IENS="" Q + I FDA(9999999.64,IENS,.1)="CATEGORY" K FDA(9999999.64,IENS,.03) + Q + ; + ;=============================================== +LABPANEL(IEN) ; + N NODE + S NODE=^LAB(60,IEN,0) + I $P(NODE,U,4)'["CH" Q 1 + I $P(NODE,U,5)="" Q 0 + Q 1 + ; + ;=============================================== +REXISTS(NAME,DATEP) ;See if this Exchange File entry already exists. + N IEN,LUVALUE + S LUVALUE(1)=NAME + S LUVALUE(2)=DATEP + S IEN=+$$FIND1^DIC(811.8,"","KU",.LUVALUE) + Q IEN + ; + ;=============================================== +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. + N ABBR,ALIST,IEN,IENS,FILENUM,FINDING,OFINDING,PT01 + ;Search the finding multiple for replacements and missing findings. + D BLDALIST^PXRMVPTR(811.52,.01,.ALIST) + S IENS="" + F S IENS=$O(FDA(811.52,IENS)) Q:IENS="" D + . S (FINDING,OFINDING)=FDA(811.52,IENS,.01) + . S ABBR=$P(FINDING,".",1) + . S PT01=$P(FINDING,".",2) + . S FILENUM=$P(ALIST(ABBR),U,1) + . I $D(NAMECHG(FILENUM,PT01)) D + .. S FINDING=ABBR_"."_NAMECHG(FILENUM,PT01) + .. S FDA(811.52,IENS,.01)=FINDING + . S IEN=+$$VFIND1(FINDING,.ALIST) + . I IEN>0 S FDA(811.52,IENS,.01)=ABBR_".`"_IEN + . I IEN=0 D + ..;Get replacement + .. N DIC,DUOUT,TEXT,X,Y + .. S TEXT="Finding "_FINDING_" does not exist; input a replacement or ^ to quit the install." + .. D BMES^XPDUTL(TEXT) + .. S DIC=FILENUM + .. I DIC="60" S DIC("S")="I $$LABPANEL^PXRMEXIU(Y)" + .. S DIC(0)="AEMNQ" + .. 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) D + .... S Y="" + .... K FDA + .. I Y="" K FDA(811.52,IENS) + .. E D + ... S FINDING=ABBR_"."_$P(Y,U,2) + ... S FDA(811.52,IENS,.01)=FINDING + .;Save the finding information for the history. + . S ^TMP("PXRMEXIA",$J,"TRMF",$P(IENS,",",1),OFINDING)=FINDING + Q + ; + ;=============================================== +VFIND1(VPTR,ALIST) ;Given a variable pointer of the form ABBR.NAME + ;and ALIST which contains the link between abbreviations and files + ;return the IEN if it exists and 0 if no match if found. + N ABBR,IEN,FILENUM,PT01,RESULT + S IEN=0 + S ABBR=$P(VPTR,".",1) + S PT01=$P(VPTR,".",2,99) + S FILENUM=$P(ALIST(ABBR),U,1) + S IEN=$$EXISTS(FILENUM,PT01) + Q IEN + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMEXIX.m b/r/CLINICAL_REMINDERS-PXRM/PXRMEXIX.m index dec9cb26..623754f5 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMEXIX.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMEXIX.m @@ -1,137 +1,136 @@ -PXRMEXIX ;SLC/PJH - Reminder Dialog Exchange checks. ;10/10/2007 - ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123 - ; - ;===================================================================== - ; - ;Yes/No Prompts - ;-------------- -ASK(YESNO,TEXT,HELP) ; - W ! - N DIR,X,Y - K DIROUT,DIRUT,DTOUT,DUOUT - S DIR(0)="YA0" - M DIR("A")=TEXT - S DIR("B")="Y" - S DIR("?")="Enter Y or N. For detailed help type ??" - S DIR("??")=U_"D HLP^PXRMEXIX(HELP)" - D ^DIR K DIR - I $D(DIROUT) S DTOUT=1 - I $D(DTOUT)!($D(DUOUT)) S PXRMDONE=1 Q - S YESNO=$E(Y(0)) - Q - ; - ;Dialog check - all exist, none exist or some exist - ;-------------------------------------------------- -EXIST(ALL,DNAME,DTYP,INAME) ; - ;0 - None exist - ;1 - All exist - ;2 - Some exist - ; - ;Look for component dialogs in DMAP node from PXRMEXIC - N DONE,DOTHER,EXISTS,FILE,MODE - S ALL="",DONE=0,MODE="",NAME="" - ; - I DTYP="reminder dialog" D - .F S NAME=$O(^TMP("PXRMEXTMP",$J,"DMAP",NAME)) Q:NAME="" D Q:DONE - ..;Check if dialog exists - ..S EXISTS=$$EXISTS^PXRMEXIU(801.41,NAME) - ..;If exists accumulate list of ancestors - ..I EXISTS D OTHER(NAME,.DOTHER) - ..;Quit if some exist and some don't - ..I MODE=1,'EXISTS S MODE=2,DONE=1 Q - ..I MODE=0,EXISTS S MODE=2,DONE=1 Q - ..;Set all exists flag if dialog found - ..I MODE="",EXISTS S MODE=1 - ..;Set none exists flag if dialog not found - ..I MODE="",'EXISTS S MODE=0 - ; - I DTYP'="reminder dialog" D - .F S NAME=$O(INAME(NAME)) Q:NAME="" D Q:DONE - ..;Treat namechanges as 'done' - ..I $D(PXRMNMCH(801.41,NAME)) Q - ..;Check if dialog exists - ..S EXISTS=$$EXISTS^PXRMEXIU(801.41,NAME) - ..;If exists accumulate list of ancestors - ..I EXISTS D OTHER(NAME,.DOTHER) - ..;Quit if some exist and some don't - ..I MODE=1,'EXISTS S MODE=2,DONE=1 Q - ..I MODE=0,EXISTS S MODE=2,DONE=1 Q - ..;Set all exists flag if dialog found - ..I MODE="",EXISTS S MODE=1 - ..;Set none exists flag if dialog not found - ..I MODE="",'EXISTS S MODE=0 - ; - ;If all or none exist give option to install all without prompting - N ANS,TEXT - I MODE=0 D - .S TEXT(1)="All dialog components for "_DNAME_" are new." - I MODE=1 D - .S TEXT(1)="All dialog components for "_DNAME_" already exist." - .S TEXT(2)="",TEXT(4)="" - .S TEXT(3)="Components not used by any other dialogs." - .;Warn if used by other dialogs - .I $D(DOTHER) D - ..S TEXT(3)="WARNING - some components already used by:" - ..N CNT,DLIT,DNAME,DTYP,FIRST,NAME - ..S CNT=4,DNAME="",TEXT(CNT)="" - ..F S DNAME=$O(DOTHER(DNAME)) Q:DNAME="" D - ...S NAME="",FIRST=1,CNT=CNT+1 - ...S DTYP=DOTHER(DNAME) - ...I DTYP="R" S DTYP="Reminder Dialog" - ...I DTYP="G" S DTYP="Dialog Group" - ...I DTYP="E" S DTYP="Dialog Element" - ...;S CNT=CNT+1,FIRST=0,TEXT(CNT)=DLIT_NAME_" ("_DTYP_")" - ...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: " - ;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 - ; - ;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 - ; - ;General help text routine. - ;-------------------------- -HLP(CALL) ; - N HTEXT - N DIWF,DIWL,DIWR,IC - S DIWF="C75",DIWL=0,DIWR=75 - ; - I CALL=1 D - .S HTEXT(1)="Enter 'Yes' to install 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." - I CALL=3 D - .S HTEXT(1)="Select IFE to INSTALL reminder or dialog from this exchange" - .S HTEXT(2)="entry. Select DFE to DELETE this entry from the exchange file. " - .S HTEXT(3)="Select IH to view the installation HISTORY for this entry." - 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 +PXRMEXIX ;SLC/PJH - Reminder Dialog Exchange checks. ;12/22/2004 + ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005 + ; + ;===================================================================== + ; + ;Yes/No Prompts + ;-------------- +ASK(YESNO,TEXT,HELP) ; + W ! + N DIR,X,Y + K DIROUT,DIRUT,DTOUT,DUOUT + S DIR(0)="YA0" + M DIR("A")=TEXT + S DIR("B")="Y" + S DIR("?")="Enter Y or N. For detailed help type ??" + S DIR("??")=U_"D HLP^PXRMEXIX(HELP)" + D ^DIR K DIR + I $D(DIROUT) S DTOUT=1 + I $D(DTOUT)!($D(DUOUT)) S PXRMDONE=1 Q + S YESNO=$E(Y(0)) + Q + ; + ;Dialog check - all exist, none exist or some exist + ;-------------------------------------------------- +EXIST(ALL,DNAME,DTYP,INAME) ; + ;0 - None exist + ;1 - All exist + ;2 - Some exist + ; + ;Look for component dialogs in DMAP node from PXRMEXIC + N DONE,DOTHER,EXISTS,FILE,MODE + S ALL="",DONE=0,MODE="",NAME="" + ; + I DTYP="reminder dialog" D + .F S NAME=$O(^TMP("PXRMEXTMP",$J,"DMAP",NAME)) Q:NAME="" D Q:DONE + ..;Check if dialog exists + ..S EXISTS=$$EXISTS^PXRMEXIU(801.41,NAME) + ..;If exists accumulate list of ancestors + ..I EXISTS D OTHER(NAME,.DOTHER) + ..;Quit if some exist and some don't + ..I MODE=1,'EXISTS S MODE=2,DONE=1 Q + ..I MODE=0,EXISTS S MODE=2,DONE=1 Q + ..;Set all exists flag if dialog found + ..I MODE="",EXISTS S MODE=1 + ..;Set none exists flag if dialog not found + ..I MODE="",'EXISTS S MODE=0 + ; + I DTYP'="reminder dialog" D + .F S NAME=$O(INAME(NAME)) Q:NAME="" D Q:DONE + ..;Treat namechanges as 'done' + ..I $D(PXRMNMCH(801.41,NAME)) Q + ..;Check if dialog exists + ..S EXISTS=$$EXISTS^PXRMEXIU(801.41,NAME) + ..;If exists accumulate list of ancestors + ..I EXISTS D OTHER(NAME,.DOTHER) + ..;Quit if some exist and some don't + ..I MODE=1,'EXISTS S MODE=2,DONE=1 Q + ..I MODE=0,EXISTS S MODE=2,DONE=1 Q + ..;Set all exists flag if dialog found + ..I MODE="",EXISTS S MODE=1 + ..;Set none exists flag if dialog not found + ..I MODE="",'EXISTS S MODE=0 + ; + ;If all or none exist give option to install all without prompting + N ANS,TEXT + I MODE=0 D + .S TEXT(1)="All dialog components for "_DNAME_" are new." + I MODE=1 D + .S TEXT(1)="All dialog components for "_DNAME_" already exist." + .S TEXT(2)="",TEXT(4)="" + .S TEXT(3)="Components not used by any other dialogs." + .;Warn if used by other dialogs + .I $D(DOTHER) D + ..S TEXT(3)="WARNING - some components already used by:" + ..N CNT,DLIT,DNAME,DTYP,FIRST,NAME + ..S CNT=4,DNAME="",TEXT(CNT)="" + ..F S DNAME=$O(DOTHER(DNAME)) Q:DNAME="" D + ...S NAME="",FIRST=1,CNT=CNT+1 + ...S DTYP=DOTHER(DNAME) + ...I DTYP="R" S DTYP="Reminder Dialog" + ...I DTYP="G" S DTYP="Dialog Group" + ...I DTYP="E" S DTYP="Dialog Element" + ...;S CNT=CNT+1,FIRST=0,TEXT(CNT)=DLIT_NAME_" ("_DTYP_")" + ...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:" + ;Give option to install all descendents + D ASK(.ANS,.TEXT,2) I $G(ANS)="Y" S ALL=1 + 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 + ; + ;General help text routine. + ;-------------------------- +HLP(CALL) ; + N HTEXT + N DIWF,DIWL,DIWR,IC + S DIWF="C75",DIWL=0,DIWR=75 + ; + I CALL=1 D + .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 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" + .S HTEXT(2)="entry. Select DFE to DELETE this entry from the exchange file. " + .S HTEXT(3)="Select IH to view the installation HISTORY for this entry." + 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 diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMEXLB.m b/r/CLINICAL_REMINDERS-PXRM/PXRMEXLB.m index af62ef59..52a4bafa 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMEXLB.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMEXLB.m @@ -1,211 +1,188 @@ -PXRMEXLB ;SLC/PJH - Reminder Dialog Exchange. ;05/16/2007 - ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123 - ; - ;===================================================================== - ; - ;Build list of dialog components - called once from PXRMEXLC - ;------------------------------- -DBUILD(IND,NITEMS,FILENUM) ; - N DARRAY,DDATA,DDLG,DEND,DLOC,DMAP,DNAM,DNODE,DSEQ,DSTRT,DSUB,FILE,JND - N REPCNT,RESGRP,TEMPRESL,CNT - ; - K ^TMP("PXRMEXTMP",$J),^TMP("PXRMEXFND",$J) - ; - ;Scan dialog components in 120 and save name and type - S JND=0 - F S JND=$O(^PXD(811.8,IEN,120,IND,1,JND)) Q:'JND D - .S DDATA=$G(^PXD(811.8,IEN,120,IND,1,JND,0)) Q:DDATA="" - .S DNAM=$P(DDATA,U),DSTRT=$P(DDATA,U,2),DEND=$P(DDATA,U,3) - .;Extract dialog type and text and findings from exchange file - .D DPARSE - ;Scan dialog components in 120 and save dialog links - S JND="B",REPCNT=0 - 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="" - .S DSTRT=$P(DDATA,U,2),DEND=$P(DDATA,U,3) - .S DDLG=$P(DDATA,U),DSUB=DSTRT+2 - .I JND=NITEMS D - ..S ^TMP("PXRMEXTMP",$J,"PXRMDNAM")=DDLG - ..I $P($G(^PXD(811.8,IEN,100,DSUB,0)),";",3)'["100~NATIONAL" Q - ..S ^TMP("PXRMEXTMP",$J,"PXRMDNAT")="" - .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,";") - ..S DNODE=$P(DNODE,";",3) - ..;;Modified Exchange to handle dialogs with replacement dialogs - ..I $E(DNODE,1,4)="118~" D - ...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 - ..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=$P(DNODE,";",3) I $E(DNODE,1,2)'="2~" Q - ..S DNAM=$P(DNODE,"~",2) Q:DNAM="" - ..S DLOC=$G(^TMP("PXRMEXTMP",$J,"DLOC",DNAM)) - ..S ^TMP("PXRMEXTMP",$J,"DMAP",DDLG,DSEQ)=DNAM_U_DLOC - ; - ;Build index of dialog findings by name - N FDATA,FILENAM,FILENUM,FNAME - S IND=0 - F S IND=$O(^PXD(811.8,IEN,120,IND)) Q:'IND D - .S FDATA=$G(^PXD(811.8,IEN,120,IND,0)) Q:FDATA="" - .S FILENAM=$P(FDATA,U),FILENUM=$P(FDATA,U,2) Q:FILENAM="" Q:'FILENUM - .;Ignore reminder dialogs - .I FILENAM="REMINDER DIALOG" Q - .;Ignore reminder terms - .I FILENAM="REMINDER TERM" Q - .;Strip off trailing S in finding file name - .I $E(FILENAM,$L(FILENAM))="S" S $E(FILENAM,$L(FILENAM))="" - .S JND=0 - .F S JND=$O(^PXD(811.8,IEN,120,IND,1,JND)) Q:'JND D - ..S FNAME=$P($G(^PXD(811.8,IEN,120,IND,1,JND,0)),U) Q:FNAME="" - ..;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 - ; - ;Scan exchange file to get dialog fields - ;--------------------------------------- -DPARSE N DCNT,DFIND,DFIAD,DFNAM,DFQUIT,DLCT,DLINES,DSUB,DTEXT,DTXT,DTYP - ; - ;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;" - 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="" - .I $P(DDATA,";")'=801.41 Q - .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" - ; - ;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 - .;search for WP text - .S DSUB=$G(DARRAY(25)) D:DSUB - ..S DTEXT=$P($G(^PXD(811.8,IEN,100,DSUB,0)),";",3) Q:DTEXT="" - ..;Get the line count - ..S DLINES=$P(DTEXT,"~",3),DCNT=0 - ..;Get the wp text lines - ..F DLCT=DSUB+1:1:DSUB+DLINES D - ...S DTEXT=$G(^PXD(811.8,IEN,100,DLCT,0)) - ...S DCNT=DCNT+1,DTXT(DCNT)=DTEXT - ...;Check for embedded TIU templates - ...D DTIU(DNAM,DTEXT) - ..;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 - ..S DFIND=$P($G(^PXD(811.8,IEN,100,DSUB,0)),";",3) Q:DFIND="" - ..;Finding name - ..S DFIND=$P(DFIND,"~",2) Q:DFIND="" - ..I $P(DFIND,".")="ICD9" S DFIND=$P(DFIND," ") - .; - .;Search for additional finding - start after WP text - .S DSUB=+$G(DARRAY(25)) D:DSUB - ..S DCNT=0,DFQUIT=0 - ..F DLCT=DSUB+1+DLINES:1 D Q:DFQUIT Q:DLCT>DEND - ...S DTEXT=$G(^PXD(811.8,IEN,100,DLCT,0)) - ...;Ignore line if this is not an additional finding - ...I $P(DTEXT,";")'=801.4118 S:$P(DTEXT,";")>801.4118 DFQUIT=1 Q - ...S DFNAM=$P(DTEXT,"~",2) Q:DFNAM="" - ...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 - .;search for prompt caption - .S DSUB=$G(DARRAY(24)) Q:'DSUB - .S DTEXT=$P($G(^PXD(811.8,IEN,100,DSUB,0)),";",3) Q:DTEXT="" - .S DTXT=$P(DTEXT,"~",2) - ; - I DTYP="group" D - .;search for group caption - .S DSUB=$G(DARRAY(5)) Q:'DSUB - .S DTEXT=$P($G(^PXD(811.8,IEN,100,DSUB,0)),";",3) Q:DTEXT="" - .S DTXT=$P(DTEXT,"~",2) - .Q - ; - ;Save dialog type - S ^TMP("PXRMEXTMP",$J,"DTYP",DNAM)=DTYP - ;Save dialog component text (first line only) - S ^TMP("PXRMEXTMP",$J,"DTXT",DNAM)=DTXT - ; - ;Save main finding - I DFIND]"" S ^TMP("PXRMEXTMP",$J,"DFND",DNAM,1)=$P(DFIND,".",2,99) - ;Save additional findings - S DSUB=0 - F S DSUB=$O(DFIAD(DSUB)) Q:'DSUB D - .S ^TMP("PXRMEXTMP",$J,"DFND",DNAM,DSUB+1)=$P(DFIAD(DSUB),".",2,99) - ; - ;Save additional WP text lines - S DSUB=0 - F S DSUB=$O(DTXT(DSUB)) Q:'DSUB D - .S ^TMP("PXRMEXTMP",$J,"DTXT",DNAM,DSUB)=DTXT(DSUB) - ; - ;Save dialog's position in exchange file - S ^TMP("PXRMEXTMP",$J,"DLOC",DNAM)=DSTRT_U_DEND_U_IND_U_JND - Q - ; - ;Extract any TIU templates - ;------------------------- -DTIU(DNAM,TEXT) ; - N IC,TCNT,TLIST,TNAM - ;Templates are in format {FLD:fldname} - S TCNT=0 D TIUXTR^PXRMEXDG("{FLD:","}",TEXT,.TLIST,.TCNT) Q:'TCNT - ; - F IC=1:1:TCNT D - .S TNAM=$G(TLIST(TCNT)) Q:TNAM="" - .S ^TMP("PXRMEXTMP",$J,"DTIU",DNAM,TNAM)="" - Q - ; - ;Process WP fields - ;----------------- -DWP(TEXT) ; - N DIWF,DIWL,DIWR,IC,X - S DIWF="C50",DIWL=0,DIWR=50 - ; - K ^UTILITY($J,"W") - S IC="" - F S IC=$O(TEXT(IC)) Q:IC="" D - .S X=TEXT(IC) - .D ^DIWP - ; - K TEXT - S IC=0 - F S IC=$O(^UTILITY($J,"W",0,IC)) Q:IC="" D - .S DTEXT=$G(^UTILITY($J,"W",0,IC,0)) - .I IC=1 S TEXT=DTEXT Q - .S TEXT(IC-1)=DTEXT - ; - K ^UTILITY($J,"W") - Q +PXRMEXLB ;SLC/PJH - Reminder Dialog Exchange. ;07/01/2004 + ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005 + ; + ;===================================================================== + ; + ;Build list of dialog components - called once from PXRMEXLC + ;------------------------------- +DBUILD(IND,NITEMS,FILENUM) ; + N DARRAY,DDATA,DDLG,DEND,DLOC,DMAP,DNAM,DNODE,DSEQ,DSTRT,DSUB,JND + ; + K ^TMP("PXRMEXTMP",$J),^TMP("PXRMEXFND",$J) + ; + ;Scan dialog components in 120 and save name and type + S JND=0 + F S JND=$O(^PXD(811.8,IEN,120,IND,1,JND)) Q:'JND D + .S DDATA=$G(^PXD(811.8,IEN,120,IND,1,JND,0)) Q:DDATA="" + .S DNAM=$P(DDATA,U),DSTRT=$P(DDATA,U,2),DEND=$P(DDATA,U,3) + .;Extract dialog type and text and findings from exchange file + .D DPARSE + ;Scan dialog components in 120 and save dialog links + 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="" + .S DSTRT=$P(DDATA,U,2),DEND=$P(DDATA,U,3) + .S DDLG=$P(DDATA,U),DSUB=DSTRT+2 + .I JND=NITEMS D + ..S ^TMP("PXRMEXTMP",$J,"PXRMDNAM")=DDLG + ..I $P($G(^PXD(811.8,IEN,100,DSUB,0)),";",3)'["100~NATIONAL" Q + ..S ^TMP("PXRMEXTMP",$J,"PXRMDNAT")="" + .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,";",3)'["118~") Q + ..S DNODE=$P(DNODE,";",3) + ..;;Modified Exchange to handle dialogs with replacement dialogs + ..I $E(DNODE,1,4)="118~" D + ...S DNAM=$P(DNODE,"~",2) Q:DNAM="" + ...S DLOC=$G(^TMP("PXRMEXTMP",$J,"DLOC",DNAM)) + ...S ^TMP("PXRMEXTMP",$J,"DREPL",DDLG)=DNAM_U_DLOC + ..I $E(DNODE,1,4)'=".01~" Q + ..S DSEQ=$P(DNODE,"~",2) Q:DSEQ="" + ..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="" + ..S DLOC=$G(^TMP("PXRMEXTMP",$J,"DLOC",DNAM)) + ..S ^TMP("PXRMEXTMP",$J,"DMAP",DDLG,DSEQ)=DNAM_U_DLOC + ; + ;Build index of dialog findings by name + ; + ; + N FDATA,FILENAM,FILENUM,FNAME + S IND=0 + F S IND=$O(^PXD(811.8,IEN,120,IND)) Q:'IND D + .S FDATA=$G(^PXD(811.8,IEN,120,IND,0)) Q:FDATA="" + .S FILENAM=$P(FDATA,U),FILENUM=$P(FDATA,U,2) Q:FILENAM="" Q:'FILENUM + .;Ignore reminder dialogs + .I FILENAM="REMINDER DIALOG" Q + .;Ignore reminder terms + .I FILENAM="REMINDER TERM" Q + .;Strip off trailing S in finding file name + .I $E(FILENAM,$L(FILENAM))="S" S $E(FILENAM,$L(FILENAM))="" + .S JND=0 + .F S JND=$O(^PXD(811.8,IEN,120,IND,1,JND)) Q:'JND D + ..S FNAME=$P($G(^PXD(811.8,IEN,120,IND,1,JND,0)),U) Q:FNAME="" + ..;Save entry + ..S ^TMP("PXRMEXFND",$J,FNAME)=FILENUM_U_FILENAM_U_IND + Q + ; + ;Scan exchange file to get dialog fields + ;--------------------------------------- +DPARSE N DCNT,DFIND,DFIAD,DFNAM,DFQUIT,DLCT,DLINES,DSUB,DTEXT,DTXT,DTYP + ; + ;Find where all the field numbers are kept + 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="" + .I $P(DDATA,";")'=801.41 Q + .S DFNUM=$P(DDATA,";",3),DFNUM=$P(DFNUM,"~") Q:DFNUM="" + .I DSTRING[(";"_DFNUM_";") S DARRAY(DFNUM)=DSUB + ; + ;Determine dialog component type + S DSUB=DARRAY(4) Q:'DSUB + S DTYP=$P($G(^PXD(811.8,IEN,100,DSUB,0)),"~",2) + 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") D + .;search for WP text + .S DSUB=$G(DARRAY(25)) D:DSUB + ..S DTEXT=$P($G(^PXD(811.8,IEN,100,DSUB,0)),";",3) Q:DTEXT="" + ..;Get the line count + ..S DLINES=$P(DTEXT,"~",3),DCNT=0 + ..;Get the wp text lines + ..F DLCT=DSUB+1:1:DSUB+DLINES D + ...S DTEXT=$G(^PXD(811.8,IEN,100,DLCT,0)) + ...S DCNT=DCNT+1,DTXT(DCNT)=DTEXT + ...;Check for embedded TIU templates + ...D DTIU(DNAM,DTEXT) + ..;Reformat text to 50 characters + ..D DWP(.DTXT) + .; + .;Search for finding item + .S DSUB=$G(DARRAY(15)) D:DSUB + ..S DFIND=$P($G(^PXD(811.8,IEN,100,DSUB,0)),";",3) Q:DFIND="" + ..;Finding name + ..S DFIND=$P(DFIND,"~",2) Q:DFIND="" + ..I $P(DFIND,".")="ICD9" S DFIND=$P(DFIND," ") + .; + .;Search for additional finding - start after WP text + .S DSUB=+$G(DARRAY(25)) D:DSUB + ..S DCNT=0,DFQUIT=0 + ..F DLCT=DSUB+1+DLINES:1 D Q:DFQUIT Q:DLCT>DEND + ...S DTEXT=$G(^PXD(811.8,IEN,100,DLCT,0)) + ...;Ignore line if this is not an additional finding + ...I $P(DTEXT,";")'=801.4118 S:$P(DTEXT,";")>801.4118 DFQUIT=1 Q + ...S DFNAM=$P(DTEXT,"~",2) Q:DFNAM="" + ...I $P(DFNAM,".")="ICD9" S DFNAM=$P(DFNAM," ") + ...S DCNT=DCNT+1,DFIAD(DCNT)=DFNAM + ; + I DTYP="prompt" D + .;search for prompt caption + .S DSUB=$G(DARRAY(24)) Q:'DSUB + .S DTEXT=$P($G(^PXD(811.8,IEN,100,DSUB,0)),";",3) Q:DTEXT="" + .S DTXT=$P(DTEXT,"~",2) + ; + I DTYP="group" D + .;search for group caption + .S DSUB=$G(DARRAY(5)) Q:'DSUB + .S DTEXT=$P($G(^PXD(811.8,IEN,100,DSUB,0)),";",3) Q:DTEXT="" + .S DTXT=$P(DTEXT,"~",2) + .Q + ; + ;Save dialog type + S ^TMP("PXRMEXTMP",$J,"DTYP",DNAM)=DTYP + ;Save dialog component text (first line only) + S ^TMP("PXRMEXTMP",$J,"DTXT",DNAM)=DTXT + ; + ;Save main finding + I DFIND]"" S ^TMP("PXRMEXTMP",$J,"DFND",DNAM,1)=$P(DFIND,".",2,99) + ;Save additional findings + S DSUB=0 + F S DSUB=$O(DFIAD(DSUB)) Q:'DSUB D + .S ^TMP("PXRMEXTMP",$J,"DFND",DNAM,DSUB+1)=$P(DFIAD(DSUB),".",2,99) + ; + ;Save additional WP text lines + S DSUB=0 + F S DSUB=$O(DTXT(DSUB)) Q:'DSUB D + .S ^TMP("PXRMEXTMP",$J,"DTXT",DNAM,DSUB)=DTXT(DSUB) + ; + ;Save dialog's position in exchange file + S ^TMP("PXRMEXTMP",$J,"DLOC",DNAM)=DSTRT_U_DEND_U_IND_U_JND + Q + ; + ;Extract any TIU templates + ;------------------------- +DTIU(DNAM,TEXT) ; + N IC,TCNT,TLIST,TNAM + ;Templates are in format {FLD:fldname} + S TCNT=0 D TIUXTR^PXRMEXDG("{FLD:","}",TEXT,.TLIST,.TCNT) Q:'TCNT + ; + F IC=1:1:TCNT D + .S TNAM=$G(TLIST(TCNT)) Q:TNAM="" + .S ^TMP("PXRMEXTMP",$J,"DTIU",DNAM,TNAM)="" + Q + ; + ;Process WP fields + ;----------------- +DWP(TEXT) ; + N DIWF,DIWL,DIWR,IC,X + S DIWF="C50",DIWL=0,DIWR=50 + ; + K ^UTILITY($J,"W") + S IC="" + F S IC=$O(TEXT(IC)) Q:IC="" D + .S X=TEXT(IC) + .D ^DIWP + ; + K TEXT + S IC=0 + F S IC=$O(^UTILITY($J,"W",0,IC)) Q:IC="" D + .S DTEXT=$G(^UTILITY($J,"W",0,IC,0)) + .I IC=1 S TEXT=DTEXT Q + .S TEXT(IC-1)=DTEXT + ; + K ^UTILITY($J,"W") + Q diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMEXLC.m b/r/CLINICAL_REMINDERS-PXRM/PXRMEXLC.m index 3f7f810e..4e969516 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMEXLC.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMEXLC.m @@ -1,105 +1,192 @@ -PXRMEXLC ; SLC/PKR/PJH - Routines to display repository entry components. ;08/03/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ;====================================================== -BLDLIST(FORCE) ;Build a list of all repository entries. - ;If FORCE is true then force rebuilding of the list. - I FORCE K ^TMP("PXRMEXLR",$J) - I $D(^TMP("PXRMEXLR",$J,"VALMCNT")) S VALMCNT=^TMP("PXRMEXLR",$J,"VALMCNT") - E D - . D REXL^PXRMLIST("PXRMEXLR") - . S VALMCNT=^TMP("PXRMEXLR",$J,"VALMCNT") - Q - ; - ;====================================================== -CDISP(IEN) ;Format component list for display. - N CAT,CMPNT,END,EOKTI,EXISTS,FILENUM,FOKTI,IND,INDEX,JND,JNDS,KND - N MSG,NCMPNT,NDLINE,NDSEL,NITEMS,NLINE,NSEL,PT01,START,TEMP,TEMP0,TYPE - K ^TMP("PXRMEXLC",$J),^TMP("PXRMEXLD",$J) - S (NDLINE,NLINE)=0 - S (NDSEL,NSEL)=1 - ;Load the description. - F IND=1:1:$P(^PXD(811.8,IEN,110,0),U,4) D - . S NLINE=NLINE+1 - . S ^TMP("PXRMEXLC",$J,NLINE,0)=^PXD(811.8,IEN,110,IND,0) - . S ^TMP("PXRMEXLC",$J,"IDX",NLINE,NSEL)="" - S NLINE=NLINE+1 - S ^TMP("PXRMEXLC",$J,NLINE,0)=" " - S ^TMP("PXRMEXLC",$J,"IDX",NLINE,NSEL)="" - S NCMPNT=^PXD(811.8,IEN,119) - ;Load the text for display. - F IND=1:1:NCMPNT D - . S NLINE=NLINE+1 - . S TEMP=^PXD(811.8,IEN,120,IND,0) - . S ^TMP("PXRMEXLC",$J,NLINE,0)=$P(TEMP,U,1) - . S ^TMP("PXRMEXLC",$J,"IDX",NLINE,NSEL)="" - . S FILENUM=$P(TEMP,U,2) - . S FOKTI=$$FOKTI^PXRMEXFI(FILENUM) - . S NITEMS=$P(TEMP,U,3) - . I $P(TEMP,U,1)="REMINDER DIALOG" D - ..;Save details of the dialog in ^TMP("PXRMEXTMP") - .. S JNDS=NITEMS D DBUILD^PXRMEXLB(IND,NITEMS,FILENUM) - . E S JNDS=1 - . F JND=JNDS:1:NITEMS D - .. S TEMP=^PXD(811.8,IEN,120,IND,1,JND,0) - .. S EOKTI=FOKTI - .. S PT01=$P(TEMP,U,1) - .. S EXISTS=$S(FILENUM=0:$$EXISTS^PXRMEXCF(PT01),1:$$EXISTS^PXRMEXIU(FILENUM,PT01,"W")) - ..;If this is an education topic and it starts with VA- it - ..;cannot be transported because of PCE's screen. - .. ;I (FILENUM=9999999.09)&(PT01["VA-") S EOKTI=0 - ..;If this is a health factor see if it is a category. - .. S CAT="" - .. I (FILENUM=9999999.64) D - ... S TYPE="" - ... S START=$P(TEMP,U,2) - ... S END=$P(TEMP,U,3) - ... F KND=START:1:END D - .... S TEMP0=$P(^PXD(811.8,IEN,100,KND,0),";",3) - .... I $P(TEMP0,"~",1)=.1 S TYPE=$P(TEMP0,"~",2) - ... I TYPE="CATEGORY" S CAT="X" - .. S NLINE=NLINE+1 - .. I IND=1,JND=1 S NSEL=1,INDEX=$S(EOKTI:NSEL,1:"") - .. E D - ...;If entries in this file are ok to install add them to the - ...;selectable list. Make sure the first selectable entry exists - ...;before incrementing NSEL. - ... I EOKTI S NSEL=$S($D(^TMP("PXRMEXLC",$J,"SEL",1)):NSEL+1,1:NSEL),INDEX=NSEL - ... E S INDEX="" - .. S ^TMP("PXRMEXLC",$J,NLINE,0)=$$FMTDATA(INDEX,PT01,CAT,EXISTS) - .. S ^TMP("PXRMEXLC",$J,"IDX",NLINE,NSEL)="" - ..;Store the file number, node 120 indexes and the ien if it exists. - .. I INDEX=NSEL S ^TMP("PXRMEXLC",$J,"SEL",NSEL)=FILENUM_U_IND_U_JND_U_EXISTS - . S NLINE=NLINE+1 - . S ^TMP("PXRMEXLC",$J,NLINE,0)="" - . S ^TMP("PXRMEXLC",$J,"IDX",NLINE,NSEL)="" - Q - ; - ;====================================================== -FMTDATA(NSEL,PT01,CAT,EXISTS) ;Format items for display. - N NSTI,TEMP - S TEMP=$$RJ^XLFSTR(NSEL,4," ")_" "_$E(PT01,1,54) - I CAT="X" D - . S NSTI=63-$L(TEMP) - . S TEMP=TEMP_$$INSCHR(NSTI," ")_"X" - I EXISTS D - . S NSTI=75-$L(TEMP) - . S TEMP=TEMP_$$INSCHR(NSTI," ")_"X" - Q TEMP - ; - ;====================================================== -INSCHR(NUM,CHR) ;Return a string of NUM characters (CHR). - N IND,TEMP - S TEMP="" - I NUM<1 Q TEMP - F IND=1:1:NUM S TEMP=TEMP_CHR - Q 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 - Q - ; +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. + ;If FORCE is true then force rebuilding of the list. + I FORCE K ^TMP("PXRMEXLR",$J) + I $D(^TMP("PXRMEXLR",$J,"VALMCNT")) S VALMCNT=^TMP("PXRMEXLR",$J,"VALMCNT") + E D + . 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 + ; + ;====================================================== +CDISP(IEN) ;Format component list for display. + N CAT,CMPNT,END,EOKTI,EXISTS,FILENUM,FOKTI,IND,INDEX,JND,JNDS,KND + N MSG,NCMPNT,NDLINE,NDSEL,NITEMS,NLINE,NSEL,PT01,START,TEMP,TEMP0,TYPE + K ^TMP("PXRMEXLC",$J),^TMP("PXRMEXLD",$J) + S (NDLINE,NLINE)=0 + S (NDSEL,NSEL)=1 + ;Load the description. + F IND=1:1:$P(^PXD(811.8,IEN,110,0),U,4) D + . S NLINE=NLINE+1 + . S ^TMP("PXRMEXLC",$J,NLINE,0)=^PXD(811.8,IEN,110,IND,0) + . S ^TMP("PXRMEXLC",$J,"IDX",NLINE,NSEL)="" + S NLINE=NLINE+1 + S ^TMP("PXRMEXLC",$J,NLINE,0)=" " + S ^TMP("PXRMEXLC",$J,"IDX",NLINE,NSEL)="" + S NCMPNT=^PXD(811.8,IEN,119) + ;Load the text for display. + F IND=1:1:NCMPNT D + . S NLINE=NLINE+1 + . S TEMP=^PXD(811.8,IEN,120,IND,0) + . S ^TMP("PXRMEXLC",$J,NLINE,0)=$P(TEMP,U,1) + . S ^TMP("PXRMEXLC",$J,"IDX",NLINE,NSEL)="" + . S FILENUM=$P(TEMP,U,2) + . S FOKTI=$$FOKTI^PXRMEXFI(FILENUM) + . S NITEMS=$P(TEMP,U,3) + . I $P(TEMP,U,1)="REMINDER DIALOG" D + ..;Save details of the dialog in ^TMP("PXRMEXTMP") + .. S JNDS=NITEMS D DBUILD^PXRMEXLB(IND,NITEMS,FILENUM) + . E S JNDS=1 + . F JND=JNDS:1:NITEMS D + .. S TEMP=^PXD(811.8,IEN,120,IND,1,JND,0) + .. S EOKTI=FOKTI + .. S PT01=$P(TEMP,U,1) + .. S EXISTS=$S(FILENUM=0:$$EXISTS^PXRMEXCF(PT01),1:$$EXISTS^PXRMEXIU(FILENUM,PT01,"W")) + ..;If this is an education topic and it starts with VA- it + ..;cannot be transported because of PCE's screen. + .. ;I (FILENUM=9999999.09)&(PT01["VA-") S EOKTI=0 + ..;If this is a health factor see if it is a category. + .. S CAT="" + .. I (FILENUM=9999999.64) D + ... S TYPE="" + ... S START=$P(TEMP,U,2) + ... S END=$P(TEMP,U,3) + ... F KND=START:1:END D + .... S TEMP0=$P(^PXD(811.8,IEN,100,KND,0),";",3) + .... I $P(TEMP0,"~",1)=.1 S TYPE=$P(TEMP0,"~",2) + ... I TYPE="CATEGORY" S CAT="X" + .. S NLINE=NLINE+1 + .. I IND=1,JND=1 S NSEL=1,INDEX=$S(EOKTI:NSEL,1:"") + .. E D + ...;If entries in this file are ok to install add them to the + ...;selectable list. Make sure the first selectable entry exists + ...;before incrementing NSEL. + ... I EOKTI S NSEL=$S($D(^TMP("PXRMEXLC",$J,"SEL",1)):NSEL+1,1:NSEL),INDEX=NSEL + ... E S INDEX="" + .. S ^TMP("PXRMEXLC",$J,NLINE,0)=$$FMTDATA(INDEX,PT01,CAT,EXISTS) + .. S ^TMP("PXRMEXLC",$J,"IDX",NLINE,NSEL)="" + ..;Store the file number, node 120 indexes and the ien if it exists. + .. I INDEX=NSEL S ^TMP("PXRMEXLC",$J,"SEL",NSEL)=FILENUM_U_IND_U_JND_U_EXISTS + . S NLINE=NLINE+1 + . S ^TMP("PXRMEXLC",$J,NLINE,0)="" + . S ^TMP("PXRMEXLC",$J,"IDX",NLINE,NSEL)="" + 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 + S TEMP=$$RJ^XLFSTR(NSEL,4," ")_" "_$E(PT01,1,54) + I CAT="X" D + . S NSTI=63-$L(TEMP) + . S TEMP=TEMP_$$INSCHR(NSTI," ")_"X" + I EXISTS D + . S NSTI=75-$L(TEMP) + . S TEMP=TEMP_$$INSCHR(NSTI," ")_"X" + Q 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 + S TEMP="" + I NUM<1 Q TEMP + F IND=1:1:NUM S TEMP=TEMP_CHR + Q TEMP + ; + ;====================================================== +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 diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMEXLD.m b/r/CLINICAL_REMINDERS-PXRM/PXRMEXLD.m index 17dcc718..98ff0248 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMEXLD.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMEXLD.m @@ -1,106 +1,296 @@ -PXRMEXLD ;SLC/PJH - Reminder Dialog Exchange Main Routine. ;08/07/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; -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 ; - K ^TMP("PXRMEXLD",$J) - Q - ; -DISP(VIEW) ;Build the requested view and display it. - D BLDDISP^PXRMEXD1(VIEW) - ;Change header - I VIEW=0 D CHGCAP^VALM("HEADER2","Dialog Details") - I VIEW=1 D CHGCAP^VALM("HEADER2","Dialog Text") - I VIEW=2 D CHGCAP^VALM("HEADER2","Dialog Findings") - 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" - ;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 - N CNT,FOUND,OK - S FOUND=0,OK=1 - F CNT=1:1 S SEL=$P(STRING,",",CNT) Q:'SEL D - .;Invalid selection - .I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("SEL",SEL))) D Q - ..S OK=0 W $C(7),!,SEL_" is not a valid item number." H 2 - .S FOUND=1 - Q:OK&FOUND 1 - Q 0 - ; -XQORM S XQORM("#")=$O(^ORD(101,"B","PXRM EXCH SELECT DIALOG",0))_U_"1:"_VALMCNT - S XQORM("A")="Select Action: " - Q - ; -XSEL ;PXRM EXCH SELECT DIALOG validation - N ALL,CNT,ERR,IEN,IND,PXRMDONE,SELECT,SEL - S ALL="",PXRMDONE=0,PXRMBG=$G(VALMBG) - ;Invalid selection - S SELECT=$P(XQORNOD(0),"=",2) I '$$VALID(SELECT) S VALMBCK="R" Q - ; - ;Sort the SELECTION into reverse order - D ORDER^PXRMEXLC(.SELECT,-1) - ; - ;Lock the file - I '$$LOCK^PXRMEXID S VALMBCK="R" Q - ; - ;Install dialog component(s) - S CNT=0 - F CNT=1:1 S SEL=$P(SELECT,",",CNT) Q:'SEL D Q:PXRMDONE - .D INSCOM^PXRMEXID(SEL,0) - ; - ;Unlock file - D UNLOCK^PXRMEXID - ; - ;Rebuild Workfile - D DISP^PXRMEXLD(PXRMMODE) - ; - ;Refresh - S VALMBCK="R" I $D(PXRMBG) S VALMBG=PXRMBG - Q +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 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) + 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=1 D CHGCAP^VALM("HEADER2","Dialog Text") + I VIEW=2 D CHGCAP^VALM("HEADER2","Dialog Findings") + I VIEW=3 D CHGCAP^VALM("HEADER2","Dialog Summary") + I VIEW=4 D CHGCAP^VALM("HEADER2","Dialog Usage") + ; + S VALMCNT=NLINE,^TMP("PXRMEXLD",$J,"VALMCNT")=VALMCNT,VALMBG=1 + ; + K ^TMP($J,"PXRMEXREP"),PXRMEXRP + ;Reset protocol + D XQORM + Q + ; + ;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 + F CNT=1:1 S SEL=$P(STRING,",",CNT) Q:'SEL D + .;Invalid selection + .I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("SEL",SEL))) D Q + ..S OK=0 W $C(7),!,SEL_" is not a valid item number." H 2 + .S FOUND=1 + Q:OK&FOUND 1 + Q 0 + ; +XQORM S XQORM("#")=$O(^ORD(101,"B","PXRM EXCH SELECT DIALOG",0))_U_"1:"_VALMCNT + S XQORM("A")="Select Action: " + Q + ; +XSEL ;PXRM EXCH SELECT DIALOG validation + N ALL,CNT,ERR,IEN,IND,PXRMDONE,SELECT,SEL + S ALL="",PXRMDONE=0,PXRMBG=$G(VALMBG) + ;Invalid selection + S SELECT=$P(XQORNOD(0),"=",2) I '$$VALID(SELECT) S VALMBCK="R" Q + ; + ;Sort the SELECTION into reverse order + D ORDER(.SELECT,-1) + ; + ;Lock the file + I '$$LOCK^PXRMEXID S VALMBCK="R" Q + ; + ;Install dialog component(s) + S CNT=0 + F CNT=1:1 S SEL=$P(SELECT,",",CNT) Q:'SEL D Q:PXRMDONE + .D INSCOM^PXRMEXID(SEL,0) + ; + ;Unlock file + D UNLOCK^PXRMEXID + ; + ; + ;Rebuild Workfile + D DISP^PXRMEXLD(PXRMMODE) + ; + ;Refresh + S VALMBCK="R" I $D(PXRMBG) S VALMBG=PXRMBG + Q diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMEXLI.m b/r/CLINICAL_REMINDERS-PXRM/PXRMEXLI.m index c4b55efb..6e5dd349 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMEXLI.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMEXLI.m @@ -1,163 +1,161 @@ -PXRMEXLI ; SLC/PKR - List Manager routines for repository entry install. ;08/08/2007 - ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123 - ; - ;================================================ -INSALL ;Install all components in a repository entry. - N IND,INSTALL - ;Initialize the name change storage. - K PXRMNMCH - S (IND,INSTALL,PXRMDONE)=0 - F S IND=$O(^TMP("PXRMEXLC",$J,"SEL",IND)) Q:(+IND=0)!(PXRMDONE) D - . D INSCOM(IND,.INSTALL) - ; - ;If anything was installed rebuild the display. - I INSTALL D CDISP^PXRMEXLC(PXRMRIEN) - ; - ;Save the install history in the repository. - D SAVHIST^PXRMEXU1 - Q - ; - ;================================================ -INSCOM(IND,INSTALL) ;Install component IND. - ;PXRMRIEN is not passed because this is invoked by the ListManger - ;action to install a repository entry. - N ACTION,ATTR,END,EXISTS,FIELDNUM,FILENUM,IND120,JND120 - N NEWNAME,NEWPT01,PT01,RTN,START,TEMP,TEMP0 - S TEMP=^TMP("PXRMEXLC",$J,"SEL",IND) - S FILENUM=$P(TEMP,U,1) - S EXISTS=$P(TEMP,U,4) - ;Dialogs use their own installation screen. - I FILENUM=801.41 D Q - . D START^PXRMEXLD - . S VALMBCK="R" - S IND120=$P(TEMP,U,2) - S JND120=$P(TEMP,U,3) - S TEMP=^PXD(811.8,PXRMRIEN,120,IND120,1,JND120,0) - S START=$P(TEMP,U,2) - S END=$P(TEMP,U,3) - S TEMP=^PXD(811.8,PXRMRIEN,100,START,0) - ;Go to full screen mode. - D FULL^VALM1 - I ((FILENUM=0)!(FILENUM=811.4)),DUZ(0)'="@" D Q - . I FILENUM=0 W !,"Only programmers can install routines." - . I FILENUM=811.4 W !,"Only programmers can install Reminder Computed Findings." - . H 2 - . S VALMBCK="R" - 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. - . S ^TMP("PXRMEXIA",$J,IND,"ROUTINE",ATTR("NAME"),ACTION)=NEWNAME - E D - .;Make sure we have the .01, some files have .001. - . S TEMP0=$P(TEMP,";",3) - . S FIELDNUM=$P(TEMP0,"~",1) - . 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) - . S ACTION=$$GETFACT^PXRMEXFI(PT01,.ATTR,.NEWPT01,.PXRMNMCH,EXISTS) - .;Save what was done for the installation summary. - . S ^TMP("PXRMEXIA",$J,IND,ATTR("FILE NAME"),ATTR("PT01"),ACTION)=NEWPT01 - ;If the ACTION is Quit then quit the entire install. - I ACTION="Q" S PXRMDONE=1 Q - ;If the ACTION is Skip then skip this component. - I ACTION="S" S VALMBCK="R" Q - ;If the ACTION is rePlace then skip this component. - I ACTION="P" S VALMBCK="R" Q - ;Install this component. - I FILENUM=0 D - . S NEWPT01=$G(PXRMNMCH(ATTR("FILE NUMBER"),ATTR("NAME"))) - . I NEWPT01="" S NEWPT01=ATTR("NAME") - . D RTNSAVE^PXRMEXIC(.RTN,NEWPT01) - . S INSTALL=1 - E D - . D FILE^PXRMEXIC(PXRMRIEN,EXISTS,IND120,JND120,ACTION,.ATTR,.PXRMNMCH) - . S INSTALL=1 - S VALMBCK="R" - Q - ; - ;================================================ -INSSEL ;Get a list of components to install. - N IND,INSTALL,VALMBG,VALMLST,VALMY - ; - S VALMBG=1,VALMLST=+$O(^TMP("PXRMEXLC",$J,"IDX",""),-1) - ; - ;Get the list to install. - D EN^VALM2(XQORNOD(0)) - ;If there is no list quit. - I '$D(VALMY) Q - ; - ;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) - ; - ;If anything was installed rebuild the display. - I INSTALL D CDISP^PXRMEXLC(PXRMRIEN) - ; - ;Save the install history in the repository. - D SAVHIST^PXRMEXU1 - Q - ; - ;================================================ -INSTALL ;Install the repository entry PXRMRIEN. - N IEN,IND,VALMY - ;Make sure the component list exists for this entry. PXRMRIEN is - ;set in INSTALL^PXRMEXLR. - 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) - S VALMCNT=$O(^TMP("PXRMEXLC",$J,"IDX"),-1) - S VALMBCK="R" - D XQORM - Q - ; - ;================================================ - ;Exit action added to PXRM EXCH INSTALL MENU -PEXIT ;PXRM EXCH INSTALL MENU protocol exit code - S VALMSG="+ Next Screen - Prev Screen ?? More Actions" - ;Reset after page up/down etc - D XQORM - 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 - S SELECT=$P(XQORNOD(0),"=",2) - I '$$VALID^PXRMEXLD(SELECT) S VALMBCK="R" Q - ; - ;Sort selections into ascending sequence order - D ORDER^PXRMEXLC(.SELECT,1) - ; - 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" - ; - ;Install selected component - N INSTALL - S INSTALL=0,CNT=0,PXRMDONE=0 - F CNT=1:1 S SEL=$P(SELECT,",",CNT) Q:'SEL D Q:PXRMDONE - . D INSCOM(SEL,.INSTALL) - ; - ;If anything was installed rebuild the display. - I INSTALL D CDISP^PXRMEXLC(PXRMRIEN) - ; - ;Save the install history in the repository. - D SAVHIST^PXRMEXU1 - ; - ;Clear any renames made in the last session - K PXRMNMCH - Q +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 + S (IND,INSTALL,PXRMDONE)=0 + F S IND=$O(^TMP("PXRMEXLC",$J,"SEL",IND)) Q:(+IND=0)!(PXRMDONE) D + . D INSCOM(IND,.INSTALL) + ; + ;If anything was installed rebuild the display. + I INSTALL D CDISP^PXRMEXLC(PXRMRIEN) + ; + ;Save the install history in the repository. + D SAVHIST^PXRMEXU1 + Q + ; + ;================================================ +INSCOM(IND,INSTALL) ;Install component IND. + ;PXRMRIEN is not passed because this is invoked by the ListManger + ;action to install a repository entry. + N ACTION,ATTR,END,EXISTS,FIELDNUM,FILENUM,IND120,JND120 + N NEWNAME,NEWPT01,PT01,RTN,START,TEMP,TEMP0 + S TEMP=^TMP("PXRMEXLC",$J,"SEL",IND) + S FILENUM=$P(TEMP,U,1) + S EXISTS=$P(TEMP,U,4) + ;Dialogs use their own installation screen. + I FILENUM=801.41 D Q + . D START^PXRMEXLD + . S VALMBCK="R" + S IND120=$P(TEMP,U,2) + S JND120=$P(TEMP,U,3) + S TEMP=^PXD(811.8,PXRMRIEN,120,IND120,1,JND120,0) + S START=$P(TEMP,U,2) + S END=$P(TEMP,U,3) + S TEMP=^PXD(811.8,PXRMRIEN,100,START,0) + ;Go to full screen mode. + D FULL^VALM1 + I ((FILENUM=0)!(FILENUM=811.4)),DUZ(0)'="@" D Q + . I FILENUM=0 W !,"Only programmers can install routines." + . I FILENUM=811.4 W !,"Only programmers can install Reminder Computed Findings." + . H 2 + . S VALMBCK="R" + I FILENUM=0 D + . D RTNLD^PXRMEXIC(PXRMRIEN,START,END,.ATTR,.RTN) + . S ACTION=$$GETRACT^PXRMEXCF(.ATTR,.NEWNAME,.PXRMNMCH,.RTN,EXISTS) + .;Save what was done for the installation summary. + . S ^TMP("PXRMEXIA",$J,IND,"ROUTINE",ATTR("NAME"),ACTION)=NEWNAME + E D + .;Make sure we have the .01, some files have .001. + . S TEMP0=$P(TEMP,";",3) + . S FIELDNUM=$P(TEMP0,"~",1) + . I FIELDNUM=.001 S TEMP=^PXD(811.8,PXRMRIEN,100,(START+1),0) + . S PT01=$P(TEMP,"~",2) + . D SETATTR^PXRMEXFI(.ATTR,FILENUM) + . S ACTION=$$GETFACT^PXRMEXFI(PT01,.ATTR,.NEWPT01,.PXRMNMCH,EXISTS) + .;Save what was done for the installation summary. + . S ^TMP("PXRMEXIA",$J,IND,ATTR("FILE NAME"),ATTR("PT01"),ACTION)=NEWPT01 + ;If the ACTION is Quit then quit the entire install. + I ACTION="Q" S PXRMDONE=1 Q + ;If the ACTION is Skip then skip this component. + I ACTION="S" S VALMBCK="R" Q + ;If the ACTION is rePlace then skip this component. + I ACTION="P" S VALMBCK="R" Q + ;Install this component. + I FILENUM=0 D + . S NEWPT01=$G(PXRMNMCH(ATTR("FILE NUMBER"),ATTR("NAME"))) + . I NEWPT01="" S NEWPT01=ATTR("NAME") + . D RTNSAVE^PXRMEXIC(.RTN,NEWPT01) + . S INSTALL=1 + E D + . D FILE^PXRMEXIC(PXRMRIEN,EXISTS,IND120,JND120,ACTION,.ATTR,.PXRMNMCH) + . S INSTALL=1 + S VALMBCK="R" + Q + ; + ;================================================ +INSSEL ;Get a list of components to install. + N IND,INSTALL,VALMBG,VALMLST,VALMY + ; + S VALMBG=1,VALMLST=+$O(^TMP("PXRMEXLC",$J,"IDX",""),-1) + ; + ;Get the list to install. + D EN^VALM2(XQORNOD(0)) + ;If there is no list quit. + 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 + .D INSCOM(IND,.INSTALL) + ; + ;If anything was installed rebuild the display. + I INSTALL D CDISP^PXRMEXLC(PXRMRIEN) + ; + ;Save the install history in the repository. + D SAVHIST^PXRMEXU1 + Q + ; + ;================================================ +INSTALL ;Install the repository entry PXRMRIEN. + N IEN,IND,VALMY + ;Make sure the component list exists for this entry. PXRMRIEN is + ;set in INSTALL^PXRMEXLR. + I '$D(^PXD(811.8,PXRMRIEN,120)) D CLIST^PXRMEXU1(.PXRMRIEN) + I PXRMRIEN=-1 Q + ;Format the component list for display. + D CDISP^PXRMEXLC(PXRMRIEN) + S VALMCNT=$O(^TMP("PXRMEXLC",$J,"IDX"),-1) + S VALMBCK="R" + D XQORM + Q + ; + ;Exit action added to PXRM EXCH INSTALL MENU +PEXIT ;PXRM EXCH INSTALL MENU protocol exit code + S VALMSG="+ Next Screen - Prev Screen ?? More Actions" + ;Reset after page up/down etc + D XQORM + 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 + S SELECT=$P(XQORNOD(0),"=",2) + I '$$VALID^PXRMEXLD(SELECT) S VALMBCK="R" Q + ; + ;Sort selections into ascending sequence order + D ORDER^PXRMEXLD(.SELECT,1) + ; + K ^TMP("PXRMEXIA",$J) + ;Set the install date and time. + S ^TMP("PXRMEXIA",$J,"DT")=$$NOW^XLFDT + ; + ;Install selected component + N INSTALL + S INSTALL=0,CNT=0,PXRMDONE=0 + F CNT=1:1 S SEL=$P(SELECT,",",CNT) Q:'SEL D Q:PXRMDONE + . D INSCOM(SEL,.INSTALL) + ; + ;If anything was installed rebuild the display. + I INSTALL D CDISP^PXRMEXLC(PXRMRIEN) + ; + ;Save the install history in the repository. + D SAVHIST^PXRMEXU1 + ; + ;Clear any renames made in the last session + K PXRMNMCH + Q diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMEXLM.m b/r/CLINICAL_REMINDERS-PXRM/PXRMEXLM.m index fac1ff7a..83f98165 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMEXLM.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMEXLM.m @@ -1,242 +1,248 @@ -PXRMEXLM ; SLC/PKR/PJH - Clinical Reminder Exchange List Manager routines. ;10/11/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ;===================================================== -CRE ;Create a packed reminder and store it in the repository. - N RTP,SUCCESS,TMPIND - K VALMHDR - S RTP=$$GETREM^PXRMEXPU("pack") - I +RTP'>0 D Q - . S VALMHDR(1)="No reminder selected!" - . S VALMBCK="R" - S TMPIND="PXRMEXPR" - D PACK^PXRMEXPR(RTP,TMPIND) - D STOREPR^PXRMEXU2(.SUCCESS,RTP,TMPIND,"REMINDER") - I SUCCESS D - . S VALMHDR(1)="Packed reminder for "_$P(RTP,U,2) - . S VALMHDR(2)="was saved in Exchange File." - . D BLDLIST^PXRMEXLC(1) - E D - . S VALMHDR(1)="Creation of packed reminder for "_$P(RTP,U,2) - . S VALMHDR(2)="failed; it was not saved!" - S VALMBCK="R" - Q - ; - ;===================================================== -DEFINQ ;Reminder definition inquiry. - N GBL,IEN,PXRMROOT,VALMCNT - S GBL="^TMP(""PXRMRINQ"",$J)" - S GBL=$NA(@GBL) - S PXRMROOT="^PXD(811.9," - S IEN=$$SELECT^PXRMINQ(PXRMROOT,"Select Reminder Definition: ","") - S IEN=$P(IEN,U,1) - I IEN=-1 S VALMBCK="R" Q - K ^TMP("PXRMRINQ",$J) - D REMVAR^PXRMINQ(GBL,IEN) - S VALMCNT=$O(^TMP("PXRMRINQ",$J,""),-1) - D EN^VALM("PXRM EX DEFINITION INQUIRY") - K ^TMP("PXRMRINQ",$J) - S VALMBCK="R" - Q - ; - ;===================================================== -ENTRY ;Entry code - D BLDLIST^PXRMEXLC(0) - D XQORM - Q - ; - ;===================================================== -EXIT ;Exit code - K ^TMP("PXRMEXDH",$J) - K ^TMP("PXRMEXHF",$J) - K ^TMP("PXRMEXFND",$J) - K ^TMP("PXRMEXIA",$J) - K ^TMP("PXRMEXIAD",$J) - K ^TMP("PXRMEXID",$J) - K ^TMP("PXRMEXIH",$J) - K ^TMP("PXRMEXLC",$J) - K ^TMP("PXRMEXLD",$J) - K ^TMP("PXRMEXLHF",$J) - K ^TMP("PXRMEXLMM",$J) - K ^TMP("PXRMEXLR",$J) - K ^TMP("PXRMEXMH",$J) - K ^TMP("PXRMEXMM",$J) - K ^TMP("PXRMEXRI",$J) - K ^TMP("PXRMEXTMP",$J) - K ^TMP("PXRMEXTXT",$J) - D CLEAN^VALM10 - D FULL^VALM1 - S VALMBCK="Q" - Q - ; - ;===================================================== -HDR ; Header code - S VALMHDR(1)="Exchange File Entries." - S VALMSG="+ Next Screen - Prev Screen ?? More Actions" - Q - ; - ;===================================================== -HELP ;Help code - ;The following variables have to be newed so that when we return - ;from the help display they will be defined. - N ORU,ORUPRMT,XQORM - D EN^VALM("PXRM EX MAIN HELP") - Q - ; - ;===================================================== -INIT ;Init - S VALMCNT=0 - Q - ; - ;===================================================== -LDHF ;Load a host file into the repository. - N IND,FILE,PATH,RBL,SUCCESS,TEMP - ;Select the host file to load. - D CLEAR^VALM1 - S TEMP=$$GETEHF^PXRMEXHF - I TEMP="" S VALMBCK="R" Q - S PATH=$P(TEMP,U,1) - S FILE=$P(TEMP,U,2) - D LHF^PXRMEXHF(.SUCCESS,PATH,FILE) - S RBL=SUCCESS - I SUCCESS D - . S VALMHDR(1)="Host file "_PATH_FILE_" successfully loaded." - E D - . S VALMHDR(1)="There were problems loading host file "_PATH_FILE_"." - . S TEMP="" - . S IND="" - . F S IND=$O(SUCCESS(IND)) Q:+IND=0 D - .. I SUCCESS(IND) S RBL=1 Q - .. I +$O(SUCCESS(IND))=0 S TEMP=TEMP_IND - .. E S TEMP=TEMP_IND_", " - . S VALMHDR(2)="Entries with problems were "_TEMP_"." - ;Rebuild the list for display. - D BLDLIST^PXRMEXLC(RBL) - S VALMBCK="R" - Q - ; - ;===================================================== -LDMM ;Load a MailMan message into the repository. - N IND,RBL,TEMP,XMZ - ;Select the MailMan message to load. - D CLEAR^VALM1 - S XMZ=$$GETMESSN^PXRMEXMM - I XMZ=-1 W !,"No packed reminder definitions selected/found!" H 2 - I +XMZ'>0 S VALMBCK="R" Q - D LMM^PXRMEXMM(.SUCCESS,XMZ) - S RBL=SUCCESS - I SUCCESS D - . S VALMHDR(1)="MailMan message "_XMZ_" successfully loaded." - .;Rebuild the list for display. - . D BLDLIST^PXRMEXLC(1) - E D - . S VALMHDR(1)="There were problems loading MailMan message "_XMZ_"." - . S TEMP="" - . S IND="" - . F S IND=$O(SUCCESS(IND)) Q:+IND=0 D - .. I SUCCESS(IND) S RBL=1 Q - .. I +$O(SUCCESS(IND))=0 S TEMP=TEMP_IND - .. E S TEMP=TEMP_IND_", " - . S VALMHDR(2)="Entries with problems were "_TEMP_"." - ;Rebuild the list for display. - D BLDLIST^PXRMEXLC(RBL) - S VALMBCK="R" - Q - ; - ;===================================================== -LRDEF ;List the name and print name of all reminder definitions. - N VALMCNT - I $D(^TMP("PXRMEXLD",$J,"VALMCNT")) S VALMCNT=^TMP("PXRMEXLD",$J,"VALMCNT") - E D - . N ARO,DEFLIST - . S ARO=$$QUERYAO^PXRMLIST - . S ^TMP("PXRMEXLD",$J,"ARO")=ARO - . D RDEF^PXRMLIST(.DEFLIST,ARO) - . M ^TMP("PXRMEXLD",$J)=DEFLIST - . S VALMCNT=DEFLIST("VALMCNT") - I '$G(^TMP("PXRMEXLD",$J,"ARO")) D CHGCAP^VALM("INACTIVE","Inactive") - D EN^VALM("PXRM EX REMINDER LIST") - Q - ; - ;===================================================== -PEXIT ;PXRM EXCH MENU protocol exit code - S VALMSG="+ Next Screen - Prev Screen ?? More Actions" - ;Reset after page up/down etc - D XQORM - 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 - 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 repository ien. - S PXRMRIEN=^TMP("PXRMEXLR",$J,"SEL",SEL) - ; - ;Full screen mode - D FULL^VALM1 - ; - ;Option to Install, Delete or Install History - N DIR,DIROUT,DIRUT,DTOUT,DUOUT,OPTION,X,Y - S DIR(0)="SBM"_U_"IFE:Install Exchange File Entry;" - S DIR(0)=DIR(0)_"DFE:Delete Exchange File Entry;" - S DIR(0)=DIR(0)_"IH:Installation History;" - S DIR("A")="Select Action: " - S DIR("B")="IFE" - S DIR("?")="Select from the codes displayed. For detailed help type ??" - S DIR("??")=U_"D HLP^PXRMEXIX(3)" - D ^DIR - I $D(DIROUT)!$D(DIRUT) S VALMBCK="R" Q - I $D(DTOUT)!$D(DUOUT) S VALMBCK="R" Q - S OPTION=Y - ; - ;Install - I OPTION="IFE" D - .D EN^VALM("PXRM EX LIST COMPONENTS") - .K ^TMP("PXRMEXLC",$J) - ; - I OPTION="DFE" D - .N COUNT,DELLIST,IEN,IND,RELIST,VALMY - .S DELLIST(PXRMRIEN)="" - .D DELETE^PXRMEXU1(.DELLIST) - .;Rebuild the list for List Manager to display. - .K ^TMP("PXRMEXLR",$J) - .D REXL^PXRMLIST("PXRMEXLR") - .S VALMCNT=^TMP("PXRMEXLR",$J,"VALMCNT") - .S VALMHDR(1)="Deleted 1 exchange file entry",VALMHDR(2)=" ",VALMBCK="R" - ; - I OPTION="IH" D START^PXRMEXIH - ; - S VALMBCK="R" - Q +PXRMEXLM ; SLC/PKR/PJH - Clinical Reminder Exchange List Manager routines. ;12/22/2004 + ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005 + ; + ;===================================================== +CRE ;Create a packed reminder and store it in the repository. + N RTP,SUCCESS,TMPIND + K VALMHDR + S RTP=$$GETREM^PXRMEXPU("pack") + I +RTP'>0 D Q + . S VALMHDR(1)="No reminder selected!" + . S VALMBCK="R" + S TMPIND="PXRMEXPR" + D PACK^PXRMEXPR(RTP,TMPIND) + D STOREPR^PXRMEXU2(.SUCCESS,RTP,TMPIND,"REMINDER") + I SUCCESS D + . S VALMHDR(1)="Packed reminder for "_$P(RTP,U,2) + . S VALMHDR(2)="was saved in Exchange File." + . D BLDLIST^PXRMEXLC(1) + E D + . S VALMHDR(1)="Creation of packed reminder for "_$P(RTP,U,2) + . S VALMHDR(2)="failed; it was not saved!" + S VALMBCK="R" + Q + ; + ;===================================================== +DEFINQ ;Reminder definition inquiry. + N GBL,IEN,PXRMROOT,VALMCNT + S GBL="^TMP(""PXRMRINQ"",$J)" + S GBL=$NA(@GBL) + S PXRMROOT="^PXD(811.9," + S IEN=$$SELECT^PXRMINQ(PXRMROOT,"Select Reminder Definition: ","") + S IEN=$P(IEN,U,1) + I IEN=-1 S VALMBCK="R" Q + K ^TMP("PXRMRINQ",$J) + D REMVAR^PXRMINQ(GBL,IEN) + S VALMCNT=$O(^TMP("PXRMRINQ",$J,""),-1) + D EN^VALM("PXRM EX DEFINITION INQUIRY") + K ^TMP("PXRMRINQ",$J) + S VALMBCK="R" + Q + ; + ;===================================================== +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 XQORM + Q + ; + ;===================================================== +EXIT ;Exit code + K ^TMP("PXRMEXDH",$J) + K ^TMP("PXRMEXHF",$J) + K ^TMP("PXRMEXFND",$J) + K ^TMP("PXRMEXIA",$J) + K ^TMP("PXRMEXID",$J) + K ^TMP("PXRMEXIH",$J) + K ^TMP("PXRMEXLC",$J) + K ^TMP("PXRMEXLD",$J) + K ^TMP("PXRMEXLHF",$J) + K ^TMP("PXRMEXLMM",$J) + K ^TMP("PXRMEXLR",$J) + K ^TMP("PXRMEXMH",$J) + K ^TMP("PXRMEXMM",$J) + K ^TMP("PXRMEXRI",$J) + K ^TMP("PXRMEXTMP",$J) + K ^TMP("PXRMEXTXT",$J) + D CLEAN^VALM10 + D FULL^VALM1 + S VALMBCK="Q" + Q + ; + ;===================================================== +HDR ; Header code + S VALMHDR(1)="Exchange File Entries." + S VALMSG="+ Next Screen - Prev Screen ?? More Actions" + Q + ; + ;===================================================== +HELP ;Help code + ;The following variables have to be newed so that when we return + ;from the help display they will be defined. + N ORU,ORUPRMT,XQORM + D EN^VALM("PXRM EX MAIN HELP") + Q + ; + ;===================================================== +INIT ;Init + S VALMCNT=0 + Q + ; + ;===================================================== +LDHF ;Load a host file into the repository. + N IND,FILE,PATH,RBL,SUCCESS,TEMP + ;Select the host file to load. + D CLEAR^VALM1 + S TEMP=$$GETEHF^PXRMEXHF + I TEMP="" S VALMBCK="R" Q + S PATH=$P(TEMP,U,1) + S FILE=$P(TEMP,U,2) + D LHF^PXRMEXHF(.SUCCESS,PATH,FILE) + S RBL=SUCCESS + I SUCCESS D + . S VALMHDR(1)="Host file "_PATH_FILE_" successfully loaded." + E D + . S VALMHDR(1)="There were problems loading host file "_PATH_FILE_"." + . S TEMP="" + . S IND="" + . F S IND=$O(SUCCESS(IND)) Q:+IND=0 D + .. I SUCCESS(IND) S RBL=1 Q + .. I +$O(SUCCESS(IND))=0 S TEMP=TEMP_IND + .. E S TEMP=TEMP_IND_", " + . S VALMHDR(2)="Entries with problems were "_TEMP_"." + ;Rebuild the list for display. + D BLDLIST^PXRMEXLC(RBL) + S VALMBCK="R" + Q + ; + ;===================================================== +LDMM ;Load a MailMan message into the repository. + N IND,RBL,TEMP,XMZ + ;Select the MailMan message to load. + D CLEAR^VALM1 + S XMZ=$$GETMESSN^PXRMEXMM + I XMZ=-1 W !,"No packed reminder definitions selected/found!" H 2 + I +XMZ'>0 S VALMBCK="R" Q + D LMM^PXRMEXMM(.SUCCESS,XMZ) + S RBL=SUCCESS + I SUCCESS D + . S VALMHDR(1)="MailMan message "_XMZ_" successfully loaded." + .;Rebuild the list for display. + . D BLDLIST^PXRMEXLC(1) + E D + . S VALMHDR(1)="There were problems loading MailMan message "_XMZ_"." + . S TEMP="" + . S IND="" + . F S IND=$O(SUCCESS(IND)) Q:+IND=0 D + .. I SUCCESS(IND) S RBL=1 Q + .. I +$O(SUCCESS(IND))=0 S TEMP=TEMP_IND + .. E S TEMP=TEMP_IND_", " + . S VALMHDR(2)="Entries with problems were "_TEMP_"." + ;Rebuild the list for display. + D BLDLIST^PXRMEXLC(RBL) + S VALMBCK="R" + Q + ; + ;===================================================== +LRDEF ;List the name and print name of all reminder definitions. + N VALMCNT + I $D(^TMP("PXRMEXLD",$J,"VALMCNT")) S VALMCNT=^TMP("PXRMEXLD",$J,"VALMCNT") + E D + . N ARO,DEFLIST + . S ARO=$$QUERYAO^PXRMLIST + . S ^TMP("PXRMEXLD",$J,"ARO")=ARO + . D RDEF^PXRMLIST(.DEFLIST,ARO) + . M ^TMP("PXRMEXLD",$J)=DEFLIST + . S VALMCNT=DEFLIST("VALMCNT") + I '$G(^TMP("PXRMEXLD",$J,"ARO")) D CHGCAP^VALM("INACTIVE","Inactive") + D EN^VALM("PXRM EX REMINDER LIST") + Q + ; + ;===================================================== +PEXIT ;PXRM EXCH MENU protocol exit code + S VALMSG="+ Next Screen - Prev Screen ?? More Actions" + ;Reset after page up/down etc + D XQORM + 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 + 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 repository ien. + S PXRMRIEN=^TMP("PXRMEXLR",$J,"IDX",SEL,SEL) + ; + ;Full screen mode + D FULL^VALM1 + ; + ;Option to Install, Delete or Install History + N DIR,DIROUT,DIRUT,DTOUT,DUOUT,OPTION,X,Y + S DIR(0)="SBM"_U_"IFE:Install Exchange File Entry;" + S DIR(0)=DIR(0)_"DFE:Delete Exchange File Entry;" + S DIR(0)=DIR(0)_"IH:Installation History;" + S DIR("A")="Select Action: " + S DIR("B")="IFE" + S DIR("?")="Select from the codes displayed. For detailed help type ??" + S DIR("??")=U_"D HLP^PXRMEXIX(3)" + D ^DIR + I $D(DIROUT)!$D(DIRUT) S VALMBCK="R" Q + I $D(DTOUT)!$D(DUOUT) S VALMBCK="R" Q + S OPTION=Y + ; + ;Install + I OPTION="IFE" D + .D EN^VALM("PXRM EX LIST COMPONENTS") + .K ^TMP("PXRMEXLC",$J) + ; + I OPTION="DFE" D + .N COUNT,DELLIST,IEN,IND,RELIST,VALMY + .S DELLIST(PXRMRIEN)="" + .D DELETE^PXRMEXU1(.DELLIST) + .;Rebuild the list for List Manager to display. + .K ^TMP("PXRMEXLR",$J) + .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 + .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 diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMEXLR.m b/r/CLINICAL_REMINDERS-PXRM/PXRMEXLR.m index daaae44b..575d964d 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMEXLR.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMEXLR.m @@ -1,120 +1,254 @@ -PXRMEXLR ; SLC/PKR/PJH - List Manager routines for existing repository entries. ;07/30/2007 - ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123 - ;================================================== -CHF ;Create a host file containing repository entries. - N IND,FILE,LENH2,PATH,SUCCESS,TEMP,VALMY - ;Get the list to store. - D EN^VALM2(XQORNOD(0)) - ;If there is no list quit. - I '$D(VALMY) Q - ;Get the host file to use. - D CLEAR^VALM1 - S TEMP=$$GETHFS^PXRMEXHF - I TEMP=0 S VALMBCK="R" Q - S PATH=$P(TEMP,U,1) - S FILE=$P(TEMP,U,2) - D CHF^PXRMEXHF(.SUCCESS,.VALMY,PATH,FILE) - S VALMHDR(1)="Successfully stored entries" - S VALMHDR(2)="Failed to store entries" - S LENH2=$L(VALMHDR(2)) - S IND="" - F S IND=$O(SUCCESS(IND)) Q:+IND=0 D - . I SUCCESS(IND) S VALMHDR(1)=VALMHDR(1)_" "_IND - . E S VALMHDR(2)=VALMHDR(2)_" "_IND - I $L(VALMHDR(2))=LENH2 K VALMHDR(2) - S VALMBCK="R" - Q - ; - ;================================================== -CMM ;Create a MailMan message containing packed reminders. - N SUCCESS,TEMP,VALMY - ;Get the list to store. - D EN^VALM2(XQORNOD(0)) - ;If there is no list quit. - I '$D(VALMY) Q - ;Get a new message number to store the entries in. - D CMM^PXRMEXMM(.SUCCESS,.VALMY) - I $D(SUCCESS("XMZ")) S VALMHDR(1)="Successfully stored entries in message "_SUCCESS("XMZ")_"." - E S VALMHDR(1)="Failed to store entries" - S VALMBCK="R" - Q - ; - ;================================================== -DELETE ;Get a list of repository entries and delete them. - N COUNT,DELLIST,IEN,IND,RELIST,VALMY - ;Get the list to delete. - D MIENLIST(.DELLIST) - S COUNT=+$G(DELLIST("COUNT")) - I COUNT=0 Q - D DELETE^PXRMEXU1(.DELLIST) - ;Rebuild the list for List Manager to display. - K ^TMP("PXRMEXLR",$J) - D REXL^PXRMLIST("PXRMEXLR") - ; - S VALMHDR(1)="Deleted "_DELLIST("COUNT")_" Exchange File" - I COUNT>1 S VALMHDR(1)=VALMHDR(1)_" entries." - I COUNT=1 S VALMHDR(1)=VALMHDR(1)_" entry." - I COUNT=0 S VALMHDR(1)="No entries selected." - S VALMHDR(2)=" " - S VALMBCK="R" - Q - ; - ;================================================== -EXIT ; Exit code - D CLEAN^VALM10 - D FULL^VALM1 - S VALMBCK="R" - K ^TMP("PXRMEXLR",$J) - Q - ; - ;================================================== -INSTALL ;Get a list of repository entries and install them. - N IND,PXRMRIEN,VALMY - D EN^VALM2(XQORNOD(0)) - ;If there is no list quit. - I '$D(VALMY) Q - ;PXRMDONE is newed in PXRMEXLM - S PXRMDONE=0 - S IND="" - F S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE) D - .;Get the repository ien. - . S PXRMRIEN=^TMP("PXRMEXLR",$J,"SEL",IND) - .;The list template calls INSTALL^PXRMEXLI - . D EN^VALM("PXRM EX LIST COMPONENTS") - . K ^TMP("PXRMEXLC",$J) - Q - ; - ;================================================== -HDR ; Header code - S VALMHDR(1)="" - D CHGCAP^VALM("RNAME","Reminder Name") - D CHGCAP^VALM("PNAME","Date Loaded") - Q - ; - ;================================================== -HELP ; Help code - S X="?" D DISP^XQORM1 W !! - Q - ; - ;================================================== -MIENLIST(LIST) ;Get a list of List Manager repository entries and turn it - ;into iens. - N COUNT,IEN,VALMY - D EN^VALM2(XQORNOD(0)) - ;If there is no list quit. - I '$D(VALMY) Q - S COUNT=0 - S IND="" - 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 LIST(IEN)="" - S LIST("COUNT")=COUNT - Q - ; - ;================================================== -PEXIT ;PXRM EXCH INSTALLATION MENU protocol exit code - S VALMSG="+ Next Screen - Prev Screen ?? More Actions" - Q - ; +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. + N IND,FILE,LENH2,PATH,SUCCESS,TEMP,VALMY + ;Get the list to store. + D EN^VALM2(XQORNOD(0)) + ;If there is no list quit. + I '$D(VALMY) Q + ;Get the host file to use. + D CLEAR^VALM1 + S TEMP=$$GETHFS^PXRMEXHF + I TEMP=0 S VALMBCK="R" Q + S PATH=$P(TEMP,U,1) + S FILE=$P(TEMP,U,2) + D CHF^PXRMEXHF(.SUCCESS,.VALMY,PATH,FILE) + S VALMHDR(1)="Successfully stored entries" + S VALMHDR(2)="Failed to store entries" + S LENH2=$L(VALMHDR(2)) + S IND="" + F S IND=$O(SUCCESS(IND)) Q:+IND=0 D + . I SUCCESS(IND) S VALMHDR(1)=VALMHDR(1)_" "_IND + . E S VALMHDR(2)=VALMHDR(2)_" "_IND + I $L(VALMHDR(2))=LENH2 K VALMHDR(2) + S VALMBCK="R" + Q + ; + ;================================================== +CMM ;Create a MailMan message containing packed reminders. + N SUCCESS,TEMP,VALMY + ;Get the list to store. + D EN^VALM2(XQORNOD(0)) + ;If there is no list quit. + I '$D(VALMY) Q + ;Get a new message number to store the entries in. + D CMM^PXRMEXMM(.SUCCESS,.VALMY) + I $D(SUCCESS("XMZ")) S VALMHDR(1)="Successfully stored entries in message "_SUCCESS("XMZ")_"." + E S VALMHDR(1)="Failed to store entries" + S VALMBCK="R" + Q + ; + ;================================================== +DELETE ;Get a list of repository entries and delete them. + N COUNT,DELLIST,IEN,IND,RELIST,VALMY + ;Get the list to delete. + D MIENLIST(.DELLIST) + S COUNT=+$G(DELLIST("COUNT")) + I COUNT=0 Q + D DELETE^PXRMEXU1(.DELLIST) + ;Rebuild the list for List Manager to display. + K ^TMP("PXRMEXLR",$J) + 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" + I COUNT>1 S VALMHDR(1)=VALMHDR(1)_" entries." + I COUNT=1 S VALMHDR(1)=VALMHDR(1)_" entry." + I COUNT=0 S VALMHDR(1)="No entries selected." + S VALMHDR(2)=" " + S VALMBCK="R" + Q + ; + ;================================================== +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 + D FULL^VALM1 + S VALMBCK="R" + K ^TMP("PXRMEXLR",$J) + Q + ; + ;================================================== +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 + D EN^VALM2(XQORNOD(0)) + ;If there is no list quit. + I '$D(VALMY) Q + ;PXRMDONE is newed in PXRMEXLM + S PXRMDONE=0 + S IND="" + F S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE) D + .;Get the repository ien. + . S PXRMRIEN=^TMP("PXRMEXLR",$J,"IDX",IND,IND) + .;The list template calls INSTALL^PXRMEXLI + . D EN^VALM("PXRM EX LIST COMPONENTS") + . K ^TMP("PXRMEXLC",$J) + Q + ; + ;================================================== +HDR ; Header code + S VALMHDR(1)="" + D CHGCAP^VALM("RNAME","Reminder Name") + D CHGCAP^VALM("PNAME","Date Loaded") + Q + ; + ;================================================== +HELP ; Help code + S X="?" D DISP^XQORM1 W !! + Q + ; + ;================================================== +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. + N COUNT,IEN,VALMY + D EN^VALM2(XQORNOD(0)) + ;If there is no list quit. + I '$D(VALMY) Q + S COUNT=0 + S IND="" + F S IND=$O(VALMY(IND)) Q:+IND=0 D + . S COUNT=COUNT+1 + . S IEN=^TMP("PXRMEXLR",$J,"IDX",IND,IND) + . S LIST(IEN)="" + S LIST("COUNT")=COUNT + Q + ; + ;================================================== +PEXIT ;PXRM EXCH INSTALLATION MENU protocol exit code + S VALMSG="+ Next Screen - Prev Screen ?? More Actions" + ;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 diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMEXPR.m b/r/CLINICAL_REMINDERS-PXRM/PXRMEXPR.m index 9f711b74..4d46975b 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMEXPR.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMEXPR.m @@ -1,232 +1,233 @@ -PXRMEXPR ; SLC/PKR/PJH - Routines to create packed reminder definitions. ;12/12/2006 - ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123 - ;=============================================================== -ADDFILE(FLIST,ROOT,FILENAME) ;Add a file to the list of finding files. - N DIC,DO,FILENUM - S DIC="^"_ROOT - K DO - D DO^DIC1 - S FILENUM=+DO(2) - S FILENAME=$P(DO,U,1) - S FLIST(FILENAME)=FILENUM - Q - ; - ;=============================================================== -ADDFIND(FLIST,FILENAME,IEN) ;Add a finding to the list of findings. - S FLIST(FILENAME,"F",IEN)="" - ;Make sure categories are included for any health factors and they - ;come first in the list of health factors. - I FILENAME="HEALTH FACTORS" D - . N CAT - . S CAT=$P(^AUTTHF(IEN,0),U,3) - . S FLIST(FILENAME,"C",CAT)="" - Q - ; - ;=============================================================== -BLDSPON(RIEN,FINDLIST,SPONLIST) ;Build the sponsor list. - N DIEN,IEN,IND,IND0 - ;Start with the definition. - 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) - ;Go through the finding list to find additional sponsors. - S IND="" - F S IND=$O(FINDLIST(IND)) Q:IND="" D - . S FILENUM=FINDLIST(IND) - . I (FILENUM'<800)&(FILENUM'>811.9) D - .. S IND0="" - .. F S IND0=$O(FINDLIST(IND,IND0)) Q:IND0="" D - ... S IEN="" - ... F S IEN=+$O(FINDLIST(IND,IND0,IEN)) Q:IEN=0 D - .... D GETSPON(FILENUM,IEN,.SPONLIST) - ;Add any associated sponsors to the begining of the list. - S IND="" - F S IND=$O(SPONLIST("S",IND)) Q:IND="" D - . S IND0=0 - . F S IND0=+$O(^PXRMD(811.6,IND,2,IND0)) Q:IND0=0 D - .. S IEN=+^PXRMD(811.6,IND,2,IND0,0) - .. S SPONLIST("A",IEN)="" - Q - ; - ;=============================================================== -BLDTEXT(TMPIND) ;Combine the source information and the user's input into the - ;"TEXT" array. - N IC,IND - S (IC,IND)=0 - F S IC=$O(^TMP(TMPIND,$J,"SRC",IC)) Q:+IC=0 D - . S IND=IND+1 - . S ^TMP(TMPIND,$J,"TEXT",1,IND)=^TMP(TMPIND,$J,"SRC",IC) - ; - S IC=0 - F S IC=$O(^TMP(TMPIND,$J,"TXT",1,IC)) Q:+IC=0 D - . S IND=IND+1 - . S ^TMP(TMPIND,$J,"TEXT",1,IND)=^TMP(TMPIND,$J,"TXT",1,IC,0) - Q - ; - ;=============================================================== -GETDFIND(RIEN,FLIST) ;Build the list of definition findings. - ;FLIST has the format FLIST(FILENAME)=file number, and for each - ;finding from the file FLIST(FILENAME,"F",IEN)="". For Health Factors - ;category entries are FLIST(FILENAME,"C",IEN)="". - N FILENAME,IEN,ROOT - S ROOT="" - F S ROOT=$O(^PXD(811.9,RIEN,20,"E",ROOT)) Q:ROOT="" D - . D ADDFILE(.FLIST,ROOT,.FILENAME) - . S IEN=0 - . F S IEN=$O(^PXD(811.9,RIEN,20,"E",ROOT,IEN)) Q:+IEN=0 D - .. D ADDFIND(.FLIST,FILENAME,IEN) - Q - ; - ;=============================================================== -GETSPON(FILENUM,IEN,SPONLIST) ;Add sponsors to the sponsor list. - N ENTRY,ROOT,SPONSOR - S ROOT=$$GET1^DID(FILENUM,"","","GLOBAL NAME") - S ENTRY=ROOT_IEN_",100)" - S ENTRY=$G(@ENTRY) - S SPONSOR=$P(ENTRY,U,2) - I SPONSOR'="" S SPONLIST("S",SPONSOR)="" - Q - ; - ;=============================================================== -GETTFIND(FLIST) ;If there are any terms in the list of findings go through - ;them and add the mapped findings to the list of findings. - I '$D(FLIST("REMINDER TERM")) Q - N FILENAME,ROOT,TIEN - S TIEN=0 - F S TIEN=$O(FLIST("REMINDER TERM","F",TIEN)) Q:+TIEN=0 D - . S ROOT="" - . F S ROOT=$O(^PXRMD(811.5,TIEN,20,"E",ROOT)) Q:ROOT="" D - .. D ADDFILE(.FLIST,ROOT,.FILENAME) - .. S IEN=0 - .. F S IEN=$O(^PXRMD(811.5,TIEN,20,"E",ROOT,IEN)) Q:+IEN=0 D - ... D ADDFIND(.FLIST,FILENAME,IEN) - Q - ; - ;=============================================================== -GETTEXT(RIEN,TMPIND,INDEX) ;Let the user input some text. - N DIC,DWLW,DWPK - ;If this is the description text, load the reminder description as - ;the default. - S RIEN=+RIEN - I RIEN>0 M ^TMP(TMPIND,$J,INDEX,1)=^PXD(811.9,RIEN,1) - S DIC="^TMP(TMPIND,$J,"""_INDEX_""",1," - S DWLW=72 - S DWPK=1 - D EN^DIWE - Q - ; - ;=============================================================== -PACK(RTP,TMPIND) ;Create the packed reminder, store it in - ;^TMP(TMPIND,$J). TMPIND should be namespaced and set by the caller. - ;Save the source information - I +RTP'>0 Q - K ^TMP(TMPIND,$J),^TMP("PXRMEXCS",$J) - D PUTSRC(RTP,TMPIND) - ; - ;Have the user input text that describes the reminder. - W !,"Enter a description of the reminder you are packing." H 3 - D GETTEXT(RTP,TMPIND,"DESC") - ; - ;Have the user input keywords for indexing the reminder. - W !,"Enter keywords or phrases to help index the reminder you are packing." - W !,"Separate the keywords or phrases on each line with commas." H 3 - D GETTEXT(0,TMPIND,"KEYWORD") - ; - ;Combine the source and input text into the "TEXT" array. - D BLDTEXT(TMPIND) - ; - W !,"Packing the reminder ... " - ;Build lists of the various reminder components. - N CF,IEN,IND0,FINDLIST,FILELIST,FILENAME,FILENUM,DLGLIST - N NUMF,NUMR,OBJLIST,RIEN,ROUTINE,RTNLIST - N SERROR,SPONLIST,TEMLIST - S RIEN=$P(RTP,U,1) - ; - ;Get the list of definition findings and start the sponsor list. - D GETDFIND(RIEN,.FINDLIST) - ; - ;Add term findings to the list. - D GETTFIND(.FINDLIST) - ; - ;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) - ; - ;If there were education topics make sure subtopics are included. - D SUB^PXRMEXED(.FINDLIST) - ; - ;The finding list is complete, search the definition, dialog and - ;all the findings for sponsors. - D BLDSPON(RIEN,.FINDLIST,.SPONLIST) - ; - ;Put sponsors first on the file list. - S NUMF=0 - S IND0=0 - F S IND0=$O(SPONLIST(IND0)) Q:IND0="" D - . S IEN=0 - . F S IEN=$O(SPONLIST(IND0,IEN)) Q:IEN="" D - .. S NUMF=NUMF+1 - .. S FILELIST(NUMF)="REMINDER SPONSOR"_U_811.6_U_IEN - ; - ;Look for any computed findings and put the associated routines - ;on the routine list. - S (IEN,NUMR)=0 - F S IEN=$O(FINDLIST("REMINDER COMPUTED FINDINGS","F",IEN)) Q:IEN="" D - . S ROUTINE=$P(^PXRMD(811.4,IEN,0),U,2) - . S NUMR=NUMR+1 - . S RTNLIST(NUMR)=ROUTINE - ; - ;Go through the finding list and create the file list in the same - ;order as the finding list. - S FILENAME="" - F S FILENAME=$O(FINDLIST(FILENAME)) Q:FILENAME="" D - . S FILENUM=FINDLIST(FILENAME) - . S IND0="" - . F S IND0=$O(FINDLIST(FILENAME,IND0)) Q:IND0="" D - .. S IEN=0 - .. F S IEN=$O(FINDLIST(FILENAME,IND0,IEN)) Q:IEN="" D - ... S NUMF=NUMF+1 - ... S FILELIST(NUMF)=FILENAME_U_FILENUM_U_IEN - ; - ;Add TIU templates to the file list. - S IND0=0 - F S IND0=$O(TEMLIST(IND0)) Q:IND0="" D - . S IEN=$$EXISTS^PXRMEXIU(8927.1,TEMLIST(IND0)) - . S NUMF=NUMF+1 - . S FILELIST(NUMF)="TIU TEMPLATE FIELD"_U_8927.1_U_IEN - ; - ;Put the reminder at next to last. - S NUMF=NUMF+1 - S FILELIST(NUMF)="REMINDER DEFINITION"_U_811.9_U_RIEN - ; - ;Put dialogs last on the file list. - S FILENUM=$G(DLGLIST("DIALOG")) - S IND0="" - F S IND0=$O(DLGLIST("DIALOG",IND0)) Q:IND0="" D - . S IEN="" - . F S IEN=$O(DLGLIST("DIALOG",IND0,IEN)) Q:IEN="" D - .. S NUMF=NUMF+1 - .. S FILELIST(NUMF)="REMINDER DIALOG"_U_FILENUM_U_IEN - ; - S SERROR=0 - ;Put any routines into the ^TMP array. - D GRTN^PXRMEXPU(.RTNLIST,NUMR,TMPIND,.SERROR) - ;Put the GETS^DIQ extracts of the findings, dialogs, and - ;reminder definition into the ^TMP array. - D GDIQF^PXRMEXPU(.FILELIST,NUMF,TMPIND,.SERROR) - ; - ;If there were any errors saving the data kill the ^TMP array. - I SERROR K ^TMP(TMPIND,$J) - Q - ; - ;=============================================================== -PUTSRC(RTP,TMPIND) ;Save the source information - N LOC - S LOC=$$SITE^VASITE - S ^TMP(TMPIND,$J,"SRC","REMINDER")=$P(RTP,U,2) - S ^TMP(TMPIND,$J,"SRC","USER")=$$GET1^DIQ(200,DUZ,.01) - S ^TMP(TMPIND,$J,"SRC","SITE")=$P(LOC,U,2) - S ^TMP(TMPIND,$J,"SRC","DATE")=$$FMTE^XLFDT($$NOW^XLFDT,"5Z") - Q - ; +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. + N DIC,DO,FILENUM + S DIC="^"_ROOT + K DO + D DO^DIC1 + S FILENUM=+DO(2) + S FILENAME=$P(DO,U,1) + S FLIST(FILENAME)=FILENUM + Q + ; + ;=============================================================== +ADDFIND(FLIST,FILENAME,IEN) ;Add a finding to the list of findings. + S FLIST(FILENAME,"F",IEN)="" + ;Make sure categories are included for any health factors and they + ;come first in the list of health factors. + I FILENAME="HEALTH FACTORS" D + . N CAT + . S CAT=$P(^AUTTHF(IEN,0),U,3) + . S FLIST(FILENAME,"C",CAT)="" + Q + ; + ;=============================================================== +BLDSPON(RIEN,FINDLIST,SPONLIST) ;Build the sponsor list. + N DIEN,IEN,IND,IND0 + ;Start with the definition. + 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) + ;Go through the finding list to find additional sponsors. + S IND="" + F S IND=$O(FINDLIST(IND)) Q:IND="" D + . S FILENUM=FINDLIST(IND) + . I (FILENUM'<800)&(FILENUM'>811.9) D + .. S IND0="" + .. F S IND0=$O(FINDLIST(IND,IND0)) Q:IND0="" D + ... S IEN="" + ... F S IEN=+$O(FINDLIST(IND,IND0,IEN)) Q:IEN=0 D + .... D GETSPON(FILENUM,IEN,.SPONLIST) + ;Add any associated sponsors to the begining of the list. + S IND="" + F S IND=$O(SPONLIST("S",IND)) Q:IND="" D + . S IND0=0 + . F S IND0=+$O(^PXRMD(811.6,IND,2,IND0)) Q:IND0=0 D + .. S IEN=+^PXRMD(811.6,IND,2,IND0,0) + .. S SPONLIST("A",IEN)="" + Q + ; + ;=============================================================== +BLDTEXT(TMPIND) ;Combine the source information and the user's input into the + ;"TEXT" array. + N IC,IND + S (IC,IND)=0 + F S IC=$O(^TMP(TMPIND,$J,"SRC",IC)) Q:+IC=0 D + . S IND=IND+1 + . S ^TMP(TMPIND,$J,"TEXT",1,IND)=^TMP(TMPIND,$J,"SRC",IC) + ; + S IC=0 + F S IC=$O(^TMP(TMPIND,$J,"TXT",1,IC)) Q:+IC=0 D + . S IND=IND+1 + . S ^TMP(TMPIND,$J,"TEXT",1,IND)=^TMP(TMPIND,$J,"TXT",1,IC,0) + Q + ; + ;=============================================================== +GETDFIND(RIEN,FLIST) ;Build the list of definition findings. + ;FLIST has the format FLIST(FILENAME)=file number, and for each + ;finding from the file FLIST(FILENAME,"F",IEN)="". For Health Factors + ;category entries are FLIST(FILENAME,"C",IEN)="". + N FILENAME,IEN,ROOT + S ROOT="" + F S ROOT=$O(^PXD(811.9,RIEN,20,"E",ROOT)) Q:ROOT="" D + . D ADDFILE(.FLIST,ROOT,.FILENAME) + . S IEN=0 + . F S IEN=$O(^PXD(811.9,RIEN,20,"E",ROOT,IEN)) Q:+IEN=0 D + .. D ADDFIND(.FLIST,FILENAME,IEN) + Q + ; + ;=============================================================== +GETSPON(FILENUM,IEN,SPONLIST) ;Add sponsors to the sponsor list. + N ENTRY,ROOT,SPONSOR + S ROOT=$$GET1^DID(FILENUM,"","","GLOBAL NAME") + S ENTRY=ROOT_IEN_",100)" + S ENTRY=$G(@ENTRY) + S SPONSOR=$P(ENTRY,U,2) + I SPONSOR'="" S SPONLIST("S",SPONSOR)="" + Q + ; + ;=============================================================== +GETTFIND(FLIST) ;If there are any terms in the list of findings go through + ;them and add the mapped findings to the list of findings. + I '$D(FLIST("REMINDER TERM")) Q + N FILENAME,ROOT,TIEN + S TIEN=0 + F S TIEN=$O(FLIST("REMINDER TERM","F",TIEN)) Q:+TIEN=0 D + . S ROOT="" + . F S ROOT=$O(^PXRMD(811.5,TIEN,20,"E",ROOT)) Q:ROOT="" D + .. D ADDFILE(.FLIST,ROOT,.FILENAME) + .. S IEN=0 + .. F S IEN=$O(^PXRMD(811.5,TIEN,20,"E",ROOT,IEN)) Q:+IEN=0 D + ... D ADDFIND(.FLIST,FILENAME,IEN) + Q + ; + ;=============================================================== +GETTEXT(RIEN,TMPIND,INDEX) ;Let the user input some text. + N DIC,DWLW,DWPK + ;If this is the description text, load the reminder description as + ;the default. + S RIEN=+RIEN + I RIEN>0 M ^TMP(TMPIND,$J,INDEX,1)=^PXD(811.9,RIEN,1) + S DIC="^TMP(TMPIND,$J,"""_INDEX_""",1," + S DWLW=72 + S DWPK=1 + D EN^DIWE + Q + ; + ;=============================================================== +PACK(RTP,TMPIND) ;Create the packed reminder, store it in + ;^TMP(TMPIND,$J). TMPIND should be namespaced and set by the caller. + ;Save the source information + I +RTP'>0 Q + K ^TMP(TMPIND,$J) + D PUTSRC(RTP,TMPIND) + ; + ;Have the user input text that describes the reminder. + W !,"Enter a description of the reminder you are packing." H 3 + D GETTEXT(RTP,TMPIND,"DESC") + ; + ;Have the user input keywords for indexing the reminder. + W !,"Enter keywords or phrases to help index the reminder you are packing." + W !,"Separate the keywords or phrases on each line with commas." H 3 + D GETTEXT(0,TMPIND,"KEYWORD") + ; + ;Combine the source and input text into the "TEXT" array. + D BLDTEXT(TMPIND) + ; + W !,"Packing the reminder ... " + ;Build lists of the various reminder components. + N CF,IEN,IND0,FINDLIST,FILELIST,FILENAME,FILENUM,DLGLIST + N NUMF,NUMR,OBJLIST,RIEN,ROUTINE,RTNLIST + N SERROR,SPONLIST,TEMLIST + S RIEN=$P(RTP,U,1) + ; + ;Get the list of definition findings and start the sponsor list. + D GETDFIND(RIEN,.FINDLIST) + ; + ;Add term findings to the list. + D GETTFIND(.FINDLIST) + ; + ;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) + ; + ;If there were education topics make sure subtopics are included. + D SUB^PXRMEXED(.FINDLIST) + ; + ;The finding list is complete, search the definition, dialog and + ;all the findings for sponsors. + D BLDSPON(RIEN,.FINDLIST,.SPONLIST) + ; + ;Put sponsors first on the file list. + S NUMF=0 + S IND0=0 + F S IND0=$O(SPONLIST(IND0)) Q:IND0="" D + . S IEN=0 + . F S IEN=$O(SPONLIST(IND0,IEN)) Q:IEN="" D + .. S NUMF=NUMF+1 + .. S FILELIST(NUMF)="REMINDER SPONSOR"_U_811.6_U_IEN + ; + ;Look for any computed findings and put the associated routines + ;on the routine list. + S (IEN,NUMR)=0 + F S IEN=$O(FINDLIST("REMINDER COMPUTED FINDINGS","F",IEN)) Q:IEN="" D + . S ROUTINE=$P(^PXRMD(811.4,IEN,0),U,2) + . S NUMR=NUMR+1 + . S RTNLIST(NUMR)=ROUTINE + ; + ;Go through the finding list and create the file list in the same + ;order as the finding list. + S FILENAME="" + F S FILENAME=$O(FINDLIST(FILENAME)) Q:FILENAME="" D + . S FILENUM=FINDLIST(FILENAME) + . S IND0="" + . F S IND0=$O(FINDLIST(FILENAME,IND0)) Q:IND0="" D + .. S IEN=0 + .. F S IEN=$O(FINDLIST(FILENAME,IND0,IEN)) Q:IEN="" D + ... S NUMF=NUMF+1 + ... S FILELIST(NUMF)=FILENAME_U_FILENUM_U_IEN + ; + ;Add TIU templates to the file list. + S IND0=0 + F S IND0=$O(TEMLIST(IND0)) Q:IND0="" D + . S IEN=$$EXISTS^PXRMEXIU(8927.1,TEMLIST(IND0)) + . S NUMF=NUMF+1 + . S FILELIST(NUMF)="TIU TEMPLATE FIELD"_U_8927.1_U_IEN + ; + ;Put the reminder at next to last. + S NUMF=NUMF+1 + S FILELIST(NUMF)="REMINDER DEFINITION"_U_811.9_U_RIEN + ; + ;Put dialogs last on the file list. + S FILENUM=$G(DLGLIST("DIALOG")) + S IND0="" + F S IND0=$O(DLGLIST("DIALOG",IND0)) Q:IND0="" D + . S IEN="" + . F S IEN=$O(DLGLIST("DIALOG",IND0,IEN)) Q:IEN="" D + .. S NUMF=NUMF+1 + .. S FILELIST(NUMF)="REMINDER DIALOG"_U_FILENUM_U_IEN + ; + S SERROR=0 + ;Put any routines into the ^TMP array. + D GRTN^PXRMEXPU(.RTNLIST,NUMR,TMPIND,.SERROR) + ;Put the GETS^DIQ extracts of the findings, dialogs, and + ;reminder definition into the ^TMP array. + D GDIQF^PXRMEXPU(.FILELIST,NUMF,TMPIND,.SERROR) + ; + ;If there were any errors saving the data kill the ^TMP array. + I SERROR K ^TMP(TMPIND,$J) + Q + ; + ;=============================================================== +PUTSRC(RTP,TMPIND) ;Save the source information + N LOC + 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) + S ^TMP(TMPIND,$J,"SRC","DATE")=$$FMTE^XLFDT($$NOW^XLFDT,"5Z") + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMEXPU.m b/r/CLINICAL_REMINDERS-PXRM/PXRMEXPU.m index 9051f21a..ebb99e22 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMEXPU.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMEXPU.m @@ -1,197 +1,189 @@ -PXRMEXPU ; SLC/PKR - Utilities for packing and unpacking repository entries. ;09/10/2007 - ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123 - ;================================================== -BTTABLE(DIQOUT,IENROOT,TTABLE) ;Build the DIQOUT to FDA iens translation table. - N FILENUM,IENS,IENT,IND,UP - S FILENUM=$O(DIQOUT("")) - I FILENUM="" Q - ;DBIA #2631 - S UP=$G(^DD(FILENUM,0,"UP")) - ;Top level file in DIQOUT should not have an up node. - I UP="" D - . S IENS=$O(DIQOUT(FILENUM,"")),IND=+IENS - . S TTABLE(FILENUM,IENS)="+"_IENS - E D Q - . W !,"BTTABLE^PXRMEXPU - DIQOUT problem, do not have correct top level" - ; - F S FILENUM=$O(DIQOUT(FILENUM)) Q:FILENUM="" D - . S UP=$G(^DD(FILENUM,0,"UP")) - . S IENS="" - . F S IENS=$O(DIQOUT(FILENUM,IENS)) Q:IENS="" D - .. S IND=IND+1 - .. S IENT=$P(IENS,",",2,99) - .. S TTABLE(FILENUM,IENS)="+"_IND_","_TTABLE(UP,IENT) - .. S IENROOT(IND)=$P(IENS,",",1) - Q - ; - ;================================================== -CLDIQOUT(DIQOUT) ;Clean up DIQOUT remove null entries and change .01's - ;to the resolved form. - N ABBR,IENS,INTERNAL,FIELD,FILENUM,LINE - N PTRTO,ROOT,TYPE,WPLCNT,VLIST,VPTRLIST - S FILENUM="" - F S FILENUM=$O(DIQOUT(FILENUM)) Q:FILENUM="" D - . K TYPE,VPTRLIST - . S IENS="" - . F S IENS=$O(DIQOUT(FILENUM,IENS)) Q:IENS="" D - .. S FIELD="" - .. F S FIELD=$O(DIQOUT(FILENUM,IENS,FIELD)) Q:FIELD="" D - ...;If there is no data then don't keep this entry. - ... I DIQOUT(FILENUM,IENS,FIELD)="" K DIQOUT(FILENUM,IENS,FIELD) Q - ...;Get the field type, if it is a variable-pointer then set up - ...;the resolved form. - ... 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 - ... I TYPE(FILENUM,FIELD)="VARIABLE-POINTER" D - .... I '$D(VPTRLIST(FILENUM,FIELD)) D - ..... K VLIST - ..... D BLDRLIST^PXRMVPTR(FILENUM,FIELD,.VLIST) - ..... M VPTRLIST(FILENUM,FIELD)=VLIST - .... S INTERNAL=$$GET1^DIQ(FILENUM,IENS,FIELD,"I") - .... S (PTRTO,ROOT)=$P(INTERNAL,";",2) - .... S ABBR=$P(VPTRLIST(FILENUM,FIELD,ROOT),U,4) - .... S DIQOUT(FILENUM,IENS,FIELD)=ABBR_"."_DIQOUT(FILENUM,IENS,FIELD) - ... I TYPE(FILENUM,FIELD)="WORD-PROCESSING" D - .... S (LINE,WPLCNT)=0 - .... F S LINE=$O(DIQOUT(FILENUM,IENS,FIELD,LINE)) Q:LINE="" D - ..... S WPLCNT=WPLCNT+1 - .... I WPLCNT>0 S DIQOUT(FILENUM,IENS,FIELD)="WP-start~"_WPLCNT - .... E K DIQOUT(FILENUM,IENS,FIELD) - ...;For fields that point to files 80 and 80.1 we have to append a space - ...;so FileMan can resolve the pointers when installing a component. - ... I PTRTO["ICD" S DIQOUT(FILENUM,IENS,FIELD)=DIQOUT(FILENUM,IENS,FIELD)_" " - Q - ; - ;================================================== -CONTOFDA(DIQOUT,IENROOT) ;Convert the iens from the form - ;returned by GETS^DIQ to the FDA laygo form used by UPDATE^DIE. - ;DIQOUT contains the GETS^DIQ output. If any of the fields are - ;variable pointers change them to the resolved form. - N IENS,IENSA,FIELD,FILENUM,TTABLE,TYPE - ;Clean up DIQOUT remove null entries and change .01's to the resolved - ;form. - D CLDIQOUT(.DIQOUT) - ;Convert the iens to the adding FDA form . - D BTTABLE(.DIQOUT,.IENROOT,.TTABLE) - S FILENUM="" - F S FILENUM=$O(DIQOUT(FILENUM)) Q:FILENUM="" D - . S IENS="" - . F S IENS=$O(DIQOUT(FILENUM,IENS)) Q:IENS="" D - .. S IENSA=TTABLE(FILENUM,IENS) - .. S FIELD="" - .. F S FIELD=$O(DIQOUT(FILENUM,IENS,FIELD)) Q:FIELD="" D - ... M DIQOUT(FILENUM,IENSA,FIELD)=DIQOUT(FILENUM,IENS,FIELD) - .. K DIQOUT(FILENUM,IENS) - Q - ; - ;================================================== -GDIQF(LIST,NUM,TMPIND,SERROR) ;Save file entries into ^TMP(TMPIND,$J). - N CSUM,DIQOUT,IENROOT,IND,FIELD,FILENAME,IENS,MSG,PT01,TEMP - S ^TMP(TMPIND,$J,"NUMF")=NUM - F IND=1:1:NUM D - . S TEMP=LIST(IND) - . S FILENAME=$P(TEMP,U,1) - . S FILENUM=$P(TEMP,U,2) - . S IEN=$P(TEMP,U,3) - . K DIQOUT,IENROOT - .;If the file entry is ok to install then get the entire entry, - .;otherwise just get the .01. - . I $$FOKTI^PXRMEXFI(FILENUM) S FIELD="**" - . E S FIELD=.01 - . D GETS^DIQ(FILENUM,IEN,FIELD,"N","DIQOUT","MSG") - . I $D(MSG) D Q - .. S SERROR=1,IND=NUM - .. N ETEXT - .. S ETEXT="GETS^DIQ failed for "_FILENAME_", ien="_IEN_";" - .. W !,ETEXT - .. W !,"it returned the following error:" - .. D AWRITE^PXRMUTIL("MSG") - .. H 2 - .. K MSG - .;Remove edit history from all reminder files. - . D RMEH(FILENUM,.DIQOUT) - .;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 - . M ^TMP(TMPIND,$J,IND,FILENAME_"_IENROOT")=IENROOT - Q - ; - ;================================================== -GETREM(ACTION) ;Get the reminder to save. - N DIC,DUOUT,X,Y - S DIC="^PXD(811.9," - S DIC(0)="AEMQ" - S DIC("A")="Select Reminder Definition to "_ACTION_": " - D ^DIC - Q Y - ; - ;================================================== -GRTN(LIST,NUM,TMPIND,SERROR) ;Save routines into ^TMP(TMPIND,$J). - N DIF,IEN,IND,RA,TEMP,X,XCNP - S ^TMP(TMPIND,$J,"NUMR")=NUM - S X="" - F IND=1:1:NUM D - .;Make sure the routine exists. - . S X=LIST(IND) - . X ^%ZOSF("TEST") - . I $T D - .. K RA - .. S DIF="RA(" - .. 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 - .. W !,"Warning could not find routine ",X - .. H 2 - Q - ; - ;================================================== -RMEH(FILENUM,DIQOUT,NOSTUB) ;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 - ;Edit History is stored in node 110 for all files, get the - ;subfile number. - D FIELD^DID(FILENUM,110,"","SPECIFIER","TARGET") - S SFN=+$G(TARGET("SPECIFIER")) - I SFN=0 Q - ;Clean out the history. - S IENS="" - 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") - S DIQOUT(SFN,IENS,1)=$$GET1^DIQ(200,DUZ,.01) - S DIQOUT(SFN,IENS,2)="DIQOUT("_SFN_","_IENS_"2)" - S DIQOUT(SFN,IENS,2,1)="Exchange Stub" - Q - ; - ;================================================== -UPDATE(SUCCESS,FDA,FDAIEN) ;Call to add new entries to the repository. - N MSG - ;Try to eliminate gaps in the repository. - S $P(^PXD(811.8,0),U,3)=0 - D UPDATE^DIE("E","FDA","FDAIEN","MSG") - I $D(MSG) D - . N DATE,RNAME - . S SUCCESS=0 - . W !,"The update failed, UPDATE^DIE returned the following error message:" - . D AWRITE^PXRMUTIL("MSG") - . S RNAME=FDA(811.8,"+1,",.01) - . S DATE=FDA(811.8,"+1,",.03) - . W !!,"Exchange File entry ",RNAME," date packed ",DATE," did not get stored!" - . W !,"Examine the above error message for the reason.",! - . H 2 - E S SUCCESS=1 - Q - ; +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. + N FILENUM,IENS,IENT,IND,UP + S FILENUM=$O(DIQOUT("")) + I FILENUM="" Q + ;DBIA #2631 + S UP=$G(^DD(FILENUM,0,"UP")) + ;Top level file in DIQOUT should not have an up node. + I UP="" D + . S IENS=$O(DIQOUT(FILENUM,"")),IND=+IENS + . S TTABLE(FILENUM,IENS)="+"_IENS + E D Q + . W !,"BTTABLE^PXRMEXPU - DIQOUT problem do not have correct top level" + ; + F S FILENUM=$O(DIQOUT(FILENUM)) Q:FILENUM="" D + . S UP=$G(^DD(FILENUM,0,"UP")) + . S IENS="" + . F S IENS=$O(DIQOUT(FILENUM,IENS)) Q:IENS="" D + .. S IND=IND+1 + .. S IENT=$P(IENS,",",2,99) + .. S TTABLE(FILENUM,IENS)="+"_IND_","_TTABLE(UP,IENT) + .. S IENROOT(IND)=$P(IENS,",",1) + Q + ; + ;================================================== +CLDIQOUT(DIQOUT) ;Clean up DIQOUT remove null entries and change .01's + ;to the resolved form. + N ABBR,IENS,INTERNAL,FIELD,FILENUM,LINE + N PTRTO,ROOT,TYPE,WPLCNT,VLIST,VPTRLIST + S FILENUM="" + F S FILENUM=$O(DIQOUT(FILENUM)) Q:FILENUM="" D + . K TYPE,VPTRLIST + . S IENS="" + . F S IENS=$O(DIQOUT(FILENUM,IENS)) Q:IENS="" D + .. S FIELD="" + .. F S FIELD=$O(DIQOUT(FILENUM,IENS,FIELD)) Q:FIELD="" D + ...;If there is no data then don't keep this entry. + ... I DIQOUT(FILENUM,IENS,FIELD)="" K DIQOUT(FILENUM,IENS,FIELD) Q + ...;Get the field type, if it is a variable-pointer then set up + ...;the resolved form. + ... 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:"") + ...;If the field's type is COMPUTED then don't transport it. + ... I TYPE(FILENUM,FIELD)="COMPUTED" K DIQOUT(FILENUM,IENS,FIELD) Q + ... I TYPE(FILENUM,FIELD)="VARIABLE-POINTER" D + .... I '$D(VPTRLIST(FILENUM,FIELD)) D + ..... K VLIST + ..... D BLDRLIST^PXRMVPTR(FILENUM,FIELD,.VLIST) + ..... M VPTRLIST(FILENUM,FIELD)=VLIST + .... S INTERNAL=$$GET1^DIQ(FILENUM,IENS,FIELD,"I") + .... S (PTRTO,ROOT)=$P(INTERNAL,";",2) + .... S ABBR=$P(VPTRLIST(FILENUM,FIELD,ROOT),U,4) + .... S DIQOUT(FILENUM,IENS,FIELD)=ABBR_"."_DIQOUT(FILENUM,IENS,FIELD) + ... I TYPE(FILENUM,FIELD)="WORD-PROCESSING" D + .... S (LINE,WPLCNT)=0 + .... F S LINE=$O(DIQOUT(FILENUM,IENS,FIELD,LINE)) Q:LINE="" D + ..... S WPLCNT=WPLCNT+1 + .... I WPLCNT>0 S DIQOUT(FILENUM,IENS,FIELD)="WP-start~"_WPLCNT + .... E K DIQOUT(FILENUM,IENS,FIELD) + ...;For fields that point to files 80 and 80.1 we have to append a space + ...;so FileMan can resolve the pointers when installing a component. + ... I PTRTO["ICD" S DIQOUT(FILENUM,IENS,FIELD)=DIQOUT(FILENUM,IENS,FIELD)_" " + Q + ; + ;================================================== +CONTOFDA(DIQOUT,IENROOT) ;Convert the iens from the form + ;returned by GETS^DIQ to the FDA laygo form used by UPDATE^DIE. + ;DIQOUT contains the GETS^DIQ output. If any of the fields are + ;variable pointers change them to the resolved form. + N IENS,IENSA,FIELD,FILENUM,TTABLE,TYPE + ;Clean up DIQOUT remove null entries and change .01's to the resolved + ;form. + D CLDIQOUT(.DIQOUT) + ;Convert the iens to the adding FDA form . + D BTTABLE(.DIQOUT,.IENROOT,.TTABLE) + S FILENUM="" + F S FILENUM=$O(DIQOUT(FILENUM)) Q:FILENUM="" D + . S IENS="" + . F S IENS=$O(DIQOUT(FILENUM,IENS)) Q:IENS="" D + .. S IENSA=TTABLE(FILENUM,IENS) + .. S FIELD="" + .. F S FIELD=$O(DIQOUT(FILENUM,IENS,FIELD)) Q:FIELD="" D + ... M DIQOUT(FILENUM,IENSA,FIELD)=DIQOUT(FILENUM,IENS,FIELD) + .. K DIQOUT(FILENUM,IENS) + Q + ; + ;================================================== +GDIQF(LIST,NUM,TMPIND,SERROR) ;Save file entries into ^TMP(TMPIND,$J). + N DIQOUT,IENROOT,IND,FIELD,FILENAME,IENS,MSG,PT01,TEMP + S ^TMP(TMPIND,$J,"NUMF")=NUM + F IND=1:1:NUM D + . S TEMP=LIST(IND) + . S FILENAME=$P(TEMP,U,1) + . S FILENUM=$P(TEMP,U,2) + . S IEN=$P(TEMP,U,3) + . K DIQOUT,IENROOT + .;If the file entry is ok to install then get the entire entry, + .;otherwise just get the .01. + . I $$FOKTI^PXRMEXFI(FILENUM) S FIELD="**" + . E S FIELD=.01 + . D GETS^DIQ(FILENUM,IEN,FIELD,"","DIQOUT","MSG") + . I $D(MSG) D Q + .. S SERROR=1,IND=NUM + .. N ETEXT + .. S ETEXT="GETS^DIQ failed for "_FILENAME_", ien="_IEN_";" + .. W !,ETEXT + .. W !,"it returned the following error:" + .. D AWRITE^PXRMUTIL("MSG") + .. H 2 + .. K MSG + .;Remove edit history from all reminder files. + . D RMEH(FILENUM,.DIQOUT) + .;Convert the iens to the FDA adding form. + . D CONTOFDA(.DIQOUT,.IENROOT) + .;Load the converted DIQOUT into TMP. + . M ^TMP(TMPIND,$J,IND,FILENAME)=DIQOUT + . M ^TMP(TMPIND,$J,IND,FILENAME_"_IENROOT")=IENROOT + Q + ; + ;================================================== +GETREM(ACTION) ;Get the reminder to save. + N DIC,DUOUT,X,Y + S DIC="^PXD(811.9," + S DIC(0)="AEMQ" + S DIC("A")="Select Reminder Definition to "_ACTION_": " + D ^DIC + Q Y + ; + ;================================================== +GRTN(LIST,NUM,TMPIND,SERROR) ;Save routines into ^TMP(TMPIND,$J). + N DIF,IEN,IND,TEMP,X,XCNP + S ^TMP(TMPIND,$J,"NUMR")=NUM + S X="" + F IND=1:1:NUM D + .;Make sure the routine exists. + . S X=LIST(IND) + . X ^%ZOSF("TEST") + . I $T D + .. S DIF="^TMP(TMPIND,$J,""ROUTINE"","""_X_"""," + .. S XCNP=0 + .. X ^%ZOSF("LOAD") + . E D + .. S SERROR=1 + .. W !,"Warning could not find routine ",X + .. H 2 + Q + ; + ;================================================== +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 IEN,SFN,TARGET + ;Edit History is stored in node 110 for all files, get the + ;subfile number. + D FIELD^DID(FILENUM,110,"","SPECIFIER","TARGET") + S SFN=+$G(TARGET("SPECIFIER")) + I SFN=0 Q + ;Clean out the history. + S IENS="" + F S IENS=$O(DIQOUT(SFN,IENS)) Q:IENS="" K DIQOUT(SFN,IENS) + ;Create a stub for the install. + S IENS="1,"_$O(DIQOUT(FILENUM,"")) + S DIQOUT(SFN,IENS,.01)=$$FMTE^XLFDT($$NOW^XLFDT,"5Z") + S DIQOUT(SFN,IENS,1)=$$GET1^DIQ(200,DUZ,.01) + S DIQOUT(SFN,IENS,2)="DIQOUT("_SFN_","_IENS_"2)" + S DIQOUT(SFN,IENS,2,1)="Exchange Stub" + Q + ; + ;================================================== +UPDATE(SUCCESS,FDA,FDAIEN) ;Call to add new entries to the repository. + N MSG + ;Try to eliminate gaps in the repository. + S $P(^PXD(811.8,0),U,3)=0 + D UPDATE^DIE("E","FDA","FDAIEN","MSG") + I $D(MSG) D + . N DATE,RNAME + . S SUCCESS=0 + . W !,"The update failed, UPDATE^DIE returned the following error message:" + . D AWRITE^PXRMUTIL("MSG") + . S RNAME=FDA(811.8,"+1,",.01) + . S DATE=FDA(811.8,"+1,",.03) + . W !!,"Exchange File entry ",RNAME," date packed ",DATE," did not get stored!" + . W !,"Examine the above error message for the reason.",! + . H 2 + E S SUCCESS=1 + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMEXSI.m b/r/CLINICAL_REMINDERS-PXRM/PXRMEXSI.m index e128122a..0885ab14 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMEXSI.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMEXSI.m @@ -1,138 +1,172 @@ -PXRMEXSI ; SLC/PKR/PJH - Silent repository entry install. ;09/28/2007 - ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123 - ; - ;=================================================== -INITMPG ;Initialize ^TMP arrays. - K ^TMP("PXRMEXFND",$J) - K ^TMP("PXRMEXIA",$J) - K ^TMP("PXRMEXIAD",$J) - K ^TMP("PXRMEXLC",$J) - K ^TMP("PXRMEXLD",$J) - K ^TMP("PXRMEXTMP",$J) - Q - ; - ;=================================================== -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 - 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 - S START=$P(TEMP,U,2) - S END=$P(TEMP,U,3) - 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" - . 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" - .;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 - ;Install this component. - I FILENUM=0 D RTNSAVE^PXRMEXIC(.RTN,ATTR("NAME")) - E D FILE^PXRMEXIC(PXRMRIEN,EXISTS,IND120,JND120,ACTION,.ATTR,.PXRMNMCH) - 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") - Q - ; - ;=================================================== -INSTALL(PXRMRIEN,ACTION,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 - S NOR=$G(NOR) - ;Initialize ^TMP globals. - D INITMPG - ;Build the component list. - K ^PXD(811.8,PXRMRIEN,100,"B") - K ^PXD(811.8,PXRMRIEN,120) - D CLIST^PXRMEXU1(.PXRMRIEN) - I PXRMRIEN=-1 Q - ;Build the selectable list. - D CDISP^PXRMEXLC(PXRMRIEN) - ;Set the install date and time and type. - 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 - . S TEMP=^TMP("PXRMEXLC",$J,"SEL",IND) - . S FILENUM=$P(TEMP,U,1) - .;If NOR is true do not install routines. - . I FILENUM=0,NOR Q - . ;Install dialog components - . I FILENUM=801.41 N PXRMDONE S PXRMDONE=0 D INSDLG(PXRMRIEN,ACTION) Q - . ;Install component - . E D INSCOM(PXRMRIEN,ACTION,IND,TEMP,.REMNAME,"PXRMEXIA") - ; - ;Get the dialog name - S DNAME=$G(^TMP("PXRMEXTMP",$J,"PXRMDNAM")) - ;Link the dialog if it exists - I DNAME'="" D - . N DIEN,RIEN - .;Get the dialog ien - . S DIEN=$$EXISTS^PXRMEXIU(801.41,DNAME) Q:'DIEN - .;Get the reminder ien - . S RIEN=+$$EXISTS^PXRMEXIU(811.9,$G(REMNAME)) Q:'RIEN - . I RIEN>0 D - .. N DA,DIE,DIK,DR - ..;Set reminder to dialog pointer - .. S DR="51///^S X=DNAME",DIE="^PXD(811.9,",DA=RIEN - .. D ^DIE - ; - ;Save the install history. - D SAVHIST^PXRMEXU1 - ;If any components were skipped send the message. - I $D(^TMP("PXRMEXNI",$J)) D - . N NE,XMSUB - . S NE=$O(^TMP("PXRMEXNI",$J,""),-1)+1 - . S ^TMP("PXRMEXNI",$J,NE,0)="Please review and make changes as necessary." - . K ^TMP("PXRMXMZ",$J) - . M ^TMP("PXRMXMZ",$J)=^TMP("PXRMEXNI",$J) - . S XMSUB="COMPONENTS SKIPPED DURING SILENT MODE INSTALL" - . D SEND^PXRMMSG(XMSUB) - ;Cleanup TMP globals. - D INITMPG - Q - ; +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("PXRMEXIA",$J) + K ^TMP("PXRMEXLC",$J) + K ^TMP("PXRMEXLD",$J) + K ^TMP("PXRMEXTMP",$J) + Q + ; + ;=================================================== +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) + S TEMP=^PXD(811.8,PXRMRIEN,120,IND120,1,JND120,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) + .;Save what was done for the installation summary. + . S ^TMP("PXRMEXIA",$J,IND,"ROUTINE",ATTR("NAME"),ACTION)="" + E D + . S PT01=$P(TEMP,"~",2) + . S (ATTR("NAME"),ATTR("PT01"))=PT01 + . D SETATTR^PXRMEXFI(.ATTR,FILENUM) + .;Save what was done for the installation summary. + . 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) ;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,NOR) ;Install all components in a repository entry. + ;If NOR is true do not install routines. + N DNAME,FILENUM,IND,PXRMNMCH,REMNAME,TEMP + S NOR=$G(NOR) + ;Initialize ^TMP globals. + D INITMPG + ;Build the component list. + K ^PXD(811.8,PXRMRIEN,100,"B") + K ^PXD(811.8,PXRMRIEN,120) + D CLIST^PXRMEXU1(.PXRMRIEN) + I PXRMRIEN=-1 Q + ;Build the selectable list. + D CDISP^PXRMEXLC(PXRMRIEN) + ;Set the install date and time. + S ^TMP("PXRMEXIA",$J,"DT")=$$NOW^XLFDT + ;Initialize the name change storage. + K PXRMNMCH + S IND=0 + 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) + .;If NOR is true do not install routines. + . I FILENUM=0,NOR Q + . ;Install dialog components + . I FILENUM=801.41 N PXRMDONE S PXRMDONE=0 D INSDLG(PXRMRIEN) Q + . ;Install component + . E D INSCOM(PXRMRIEN,IND,TEMP,.REMNAME) + ; + ;Get the dialog name + S DNAME=$G(^TMP("PXRMEXTMP",$J,"PXRMDNAM")) + ;Link the dialog if it exists + I DNAME'="" D + . N DIEN,RIEN + .;Get the dialog ien + . S DIEN=$$EXISTS^PXRMEXIU(801.41,DNAME) Q:'DIEN + .;Get the reminder ien + . S RIEN=+$$EXISTS^PXRMEXIU(811.9,$G(REMNAME)) Q:'RIEN + . I RIEN>0 D + .. N DA,DIE,DIK,DR + ..;Set reminder to dialog pointer + .. S DR="51///^S X=DNAME",DIE="^PXD(811.9,",DA=RIEN + .. D ^DIE + ; + ;Save the install history. + D SAVHIST^PXRMEXU1 + ;If any components were skipped send the message. + I $D(^TMP("PXRMEXNI",$J)) D + . N NE,XMSUB + . S NE=$O(^TMP("PXRMEXNI",$J,""),-1)+1 + . S ^TMP("PXRMEXNI",$J,NE,0)="Please review and make changes as necessary." + . K ^TMP("PXRMXMZ",$J) + . M ^TMP("PXRMXMZ",$J)=^TMP("PXRMEXNI",$J) + . S XMSUB="COMPONENTS SKIPPED DURING SILENT MODE INSTALL" + . D SEND^PXRMMSG(XMSUB) + ;Cleanup TMP globals. + D INITMPG + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMEXU1.m b/r/CLINICAL_REMINDERS-PXRM/PXRMEXU1.m index c78be186..972d1a83 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMEXU1.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMEXU1.m @@ -1,227 +1,217 @@ -PXRMEXU1 ; SLC/PKR/PJH - Reminder exchange repository utilities, #1.;08/16/2007 - ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123 - ;===================================================== -CLIST(IEN) ;Build the list of components for the repository - ;entry IEN. EXTYPE is the type of Exchange entry. The default is - ;reminder. - N COMIND,COMORDR,CSTART,CSUM,END,FILENAME,FILENUM - N IND,INDEXAT,JND,LINE,NCMPNT,NCTYPE,NITEMS,NLINES,NUMCMPNT - N PT01,START,TEMP,TAG,TYPE,UCOM,VERSN - S LINE=^PXD(811.8,IEN,100,1,0) - ;Make sure it is XML version 1. - I LINE'["" D Q - . W !,"Not an Exchange File entry!" - . S IEN=-1 - . H 2 - S LINE=^PXD(811.8,IEN,100,3,0) - S VERSN=$$GETTAGV^PXRMEXU3(LINE,"") - S LINE=^PXD(811.8,IEN,100,4,0) - S INDEXAT=+$P(LINE,"",2) - S LINE=^PXD(811.8,IEN,100,INDEXAT,0) - I LINE'="" D Q - . W !,"Index missing, cannot continue!" - . S IEN=-1 - . H 2 - S JND=INDEXAT+1 - S LINE=^PXD(811.8,IEN,100,JND,0) - S NCMPNT=+$$GETTAGV^PXRMEXU3(LINE,"") - K ^TMP($J,"CMPNT") - F IND=1:1:NCMPNT D - . K END,START - . F S JND=JND+1,LINE=^PXD(811.8,IEN,100,JND,0) Q:LINE="" D - .. S TAG=$$GETTAG^PXRMEXU3(LINE) - .. I TAG["START" S START(TAG)=+$$GETTAGV^PXRMEXU3(LINE,TAG) - .. I TAG["END" S END(TAG)=+$$GETTAGV^PXRMEXU3(LINE,TAG) - . I $D(START("")) D - .. S CSTART=START("") - .. S ^TMP($J,"CMPNT",IND,"TYPE")="ROUTINE" - .. S LINE=^PXD(811.8,IEN,100,CSTART+1,0) - .. S ^TMP($J,"CMPNT",IND,"NAME")=$$GETTAGV^PXRMEXU3(LINE,"") - .. S ^TMP($J,"CMPNT",IND,"FILENUM")=0 - ..;Save the actual start and end of the code. - .. S ^TMP($J,"CMPNT",IND,"START")=START("") - .. S ^TMP($J,"CMPNT",IND,"END")=END("") - . I $D(START("")) D - .. S CSTART=START("") - .. S LINE=^PXD(811.8,IEN,100,CSTART+1,0) - .. S (^TMP($J,"CMPNT",IND,"TYPE"),^TMP($J,"CMPNT",IND,"FILENAME"))=$$GETTAGV^PXRMEXU3(LINE,"",1) - .. S LINE=^PXD(811.8,IEN,100,CSTART+2,0) - .. S ^TMP($J,"CMPNT",IND,"FILENUM")=$$GETTAGV^PXRMEXU3(LINE,"") - .. S LINE=^PXD(811.8,IEN,100,CSTART+3,0) - .. S (^TMP($J,"CMPNT",IND,"NAME"),^TMP($J,"CMPNT",IND,"POINT_01"))=$$GETTAGV^PXRMEXU3(LINE,"",1) - ..;Save the actual start and end of the FileMan FDA. - .. S ^TMP($J,"CMPNT",IND,"FDA_START")=START("") - .. S ^TMP($J,"CMPNT",IND,"FDA_END")=END("") - .. S ^TMP($J,"CMPNT",IND,"IEN_ROOT_START")=$G(START("")) - .. S ^TMP($J,"CMPNT",IND,"IEN_ROOT_END")=$G(END("")) - ;Build some indexes to order the component list. - F IND=1:1:NCMPNT D - . S TYPE=^TMP($J,"CMPNT",IND,"TYPE") - . S COMIND(TYPE,IND)="" - . S UCOM(TYPE)="" - ;Build the component order for display and install. - D CORDER^PXRMEXCO(IEN,.UCOM,.NUMCMPNT,.COMORDR) - ;Set the 0 node. - S ^PXD(811.8,IEN,120,0)=U_"811.802A"_U_NCMPNT_U_NCMPNT - S NCTYPE=0 - S NITEMS=0 - F NCTYPE=1:1:NUMCMPNT D - . S TYPE=$O(COMORDR(NCTYPE,"")) - . S NITEMS=0 - . S IND="" - . F S IND=$O(COMIND(TYPE,IND)) Q:IND="" D - .. S NITEMS=NITEMS+1 - .. I NITEMS=1 S FILENUM=^TMP($J,"CMPNT",IND,"FILENUM") - .. I TYPE="ROUTINE" S TEMP=^TMP($J,"CMPNT",IND,"NAME")_U_^TMP($J,"CMPNT",IND,"START")_U_^TMP($J,"CMPNT",IND,"END") - .. E S TEMP=^TMP($J,"CMPNT",IND,"NAME")_U_^TMP($J,"CMPNT",IND,"FDA_START")_U_^TMP($J,"CMPNT",IND,"FDA_END")_U_$G(^TMP($J,"CMPNT",IND,"IEN_ROOT_START"))_U_$G(^TMP($J,"CMPNT",IND,"IEN_ROOT_END")) - .. S ^PXD(811.8,IEN,120,NCTYPE,1,NITEMS,0)=TEMP - . S ^PXD(811.8,IEN,120,NCTYPE,0)=TYPE_U_FILENUM_U_NITEMS - . S ^PXD(811.8,IEN,120,NCTYPE,1,0)=U_"811.8021A"_U_NITEMS_U_NITEMS - ; - ;Save the number of component types. - S ^PXD(811.8,IEN,119)=NCTYPE - K ^TMP($J,"CMPNT") - Q - ; - ;===================================================== -DELETE(LIST) ;Delete the repository entries in LIST. - N DA,DIK - S DIK="^PXD(811.8," - S DA="" - F S DA=$O(LIST(DA)) Q:+DA=0 D ^DIK - Q - ; - ;===================================================== -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 - Q - ; - ;===================================================== -DESC(RIEN,DESL,DESC,KEYWORD) ;Build the description. - N JND,LC,NKEYW - S LC=1 - S ^PXD(811.8,RIEN,110,LC,0)="Reminder: "_DESL("RNAME") - S LC=LC+1 - S ^PXD(811.8,RIEN,110,LC,0)="Source: "_DESL("SOURCE") - S LC=LC+1 - S ^PXD(811.8,RIEN,110,LC,0)="Date Packed: "_DESL("DATEP") - S LC=LC+1 - S ^PXD(811.8,RIEN,110,LC,0)="Package Version: "_DESL("VRSN") - S LC=LC+1 - S ^PXD(811.8,RIEN,110,LC,0)="" - ;Add the user's description. - S LC=LC+1 - S ^PXD(811.8,RIEN,110,LC,0)="Description:" - F JND=1:1:+$P($G(@DESC@(1,0)),U,4) D - . S LC=LC+1 - . S ^PXD(811.8,RIEN,110,LC,0)=@DESC@(1,JND,0) - S LC=LC+1 - S ^PXD(811.8,RIEN,110,LC,0)="" - ;Add the keywords. - S LC=LC+1 - S ^PXD(811.8,RIEN,110,LC,0)="Keywords:" - S NKEYW=+$P($G(@KEYWORD@(1,0)),U,4) - I NKEYW=0 D - . S LC=LC+1 - . S ^PXD(811.8,RIEN,110,LC,0)="No keywords given" - F JND=1:1:NKEYW D - . S LC=LC+1 - . S ^PXD(811.8,RIEN,110,LC,0)=@KEYWORD@(1,JND,0) - S LC=LC+1 - S ^PXD(811.8,RIEN,110,LC,0)="" - S LC=LC+1 - S ^PXD(811.8,RIEN,110,LC,0)="Components:" - S ^PXD(811.8,RIEN,110,0)=U_811.804_U_LC_U_LC - Q - ; - ;===================================================== -RIEN(LIEN) ;Given the list ien return the repository ien. - N RIEN - S RIEN=$G(^TMP("PXRMEXLR",$J,"SEL",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 - ;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) - 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 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(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 - ; +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 + ;entry IEN. EXTYPE is the type of Exchange entry. The default is + ;reminder. + N COMIND,COMORDR,CSTART,CSUM,END,FILENAME,FILENUM + N IND,INDEXAT,JND,LINE,NCMPNT,NCTYPE,NITEMS,NLINES,NUMCMPNT + N PT01,START,TEMP,TAG,TYPE,UCOM,VERSN + S LINE=^PXD(811.8,IEN,100,1,0) + ;Make sure it is XML version 1. + I LINE'["" D Q + . W !,"Not an Exchange File entry!" + . S IEN=-1 + . H 2 + S LINE=^PXD(811.8,IEN,100,3,0) + S VERSN=$$GETTAGV^PXRMEXU3(LINE,"") + S LINE=^PXD(811.8,IEN,100,4,0) + S INDEXAT=+$P(LINE,"",2) + S LINE=^PXD(811.8,IEN,100,INDEXAT,0) + I LINE'="" D Q + . W !,"Index missing, cannot continue!" + . S IEN=-1 + . H 2 + S JND=INDEXAT+1 + S LINE=^PXD(811.8,IEN,100,JND,0) + S NCMPNT=+$$GETTAGV^PXRMEXU3(LINE,"") + K ^TMP($J,"CMPNT") + F IND=1:1:NCMPNT D + . K END,START + . F S JND=JND+1,LINE=^PXD(811.8,IEN,100,JND,0) Q:LINE="" D + .. S TAG=$$GETTAG^PXRMEXU3(LINE) + .. I TAG["START" S START(TAG)=+$$GETTAGV^PXRMEXU3(LINE,TAG) + .. I TAG["END" S END(TAG)=+$$GETTAGV^PXRMEXU3(LINE,TAG) + . I $D(START("")) D + .. S CSTART=START("") + .. S ^TMP($J,"CMPNT",IND,"TYPE")="ROUTINE" + .. S LINE=^PXD(811.8,IEN,100,CSTART+1,0) + .. S ^TMP($J,"CMPNT",IND,"NAME")=$$GETTAGV^PXRMEXU3(LINE,"") + .. S ^TMP($J,"CMPNT",IND,"FILENUM")=0 + ..;Save the actual start and end of the code. + .. S ^TMP($J,"CMPNT",IND,"START")=START("") + .. S ^TMP($J,"CMPNT",IND,"END")=END("") + . I $D(START("")) D + .. S CSTART=START("") + .. S LINE=^PXD(811.8,IEN,100,CSTART+1,0) + .. S (^TMP($J,"CMPNT",IND,"TYPE"),^TMP($J,"CMPNT",IND,"FILENAME"))=$$GETTAGV^PXRMEXU3(LINE,"",1) + .. S LINE=^PXD(811.8,IEN,100,CSTART+2,0) + .. S ^TMP($J,"CMPNT",IND,"FILENUM")=$$GETTAGV^PXRMEXU3(LINE,"") + .. S LINE=^PXD(811.8,IEN,100,CSTART+3,0) + .. S (^TMP($J,"CMPNT",IND,"NAME"),^TMP($J,"CMPNT",IND,"POINT_01"))=$$GETTAGV^PXRMEXU3(LINE,"",1) + ..;Save the actual start and end of the FileMan FDA. + .. S ^TMP($J,"CMPNT",IND,"FDA_START")=START("") + .. S ^TMP($J,"CMPNT",IND,"FDA_END")=END("") + .. S ^TMP($J,"CMPNT",IND,"IEN_ROOT_START")=$G(START("")) + .. S ^TMP($J,"CMPNT",IND,"IEN_ROOT_END")=$G(END("")) + ;Build some indexes to order the component list. + F IND=1:1:NCMPNT D + . S TYPE=^TMP($J,"CMPNT",IND,"TYPE") + . S COMIND(TYPE,IND)="" + . S UCOM(TYPE)="" + ;Build the component order for display and install. + D CORDER^PXRMEXCO(IEN,.UCOM,.NUMCMPNT,.COMORDR) + ;Set the 0 node. + S ^PXD(811.8,IEN,120,0)=U_"811.802A"_U_NCMPNT_U_NCMPNT + S NCTYPE=0 + S NITEMS=0 + F NCTYPE=1:1:NUMCMPNT D + . S TYPE=$O(COMORDR(NCTYPE,"")) + . S NITEMS=0 + . S IND="" + . F S IND=$O(COMIND(TYPE,IND)) Q:IND="" D + .. S NITEMS=NITEMS+1 + .. I NITEMS=1 S FILENUM=^TMP($J,"CMPNT",IND,"FILENUM") + .. I TYPE="ROUTINE" S TEMP=^TMP($J,"CMPNT",IND,"NAME")_U_^TMP($J,"CMPNT",IND,"START")_U_^TMP($J,"CMPNT",IND,"END") + .. E S TEMP=^TMP($J,"CMPNT",IND,"NAME")_U_^TMP($J,"CMPNT",IND,"FDA_START")_U_^TMP($J,"CMPNT",IND,"FDA_END")_U_$G(^TMP($J,"CMPNT",IND,"IEN_ROOT_START"))_U_$G(^TMP($J,"CMPNT",IND,"IEN_ROOT_END")) + .. S ^PXD(811.8,IEN,120,NCTYPE,1,NITEMS,0)=TEMP + . S ^PXD(811.8,IEN,120,NCTYPE,0)=TYPE_U_FILENUM_U_NITEMS + . S ^PXD(811.8,IEN,120,NCTYPE,1,0)=U_"811.8021A"_U_NITEMS_U_NITEMS + ; + ;Save the number of component types. + S ^PXD(811.8,IEN,119)=NCTYPE + K ^TMP($J,"CMPNT") + Q + ; + ;===================================================== +DELETE(LIST) ;Delete the repository entries in LIST. + N DA,DIK + S DIK="^PXD(811.8," + S DA="" + F S DA=$O(LIST(DA)) Q:+DA=0 D ^DIK + Q + ; + ;===================================================== +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 + ; + ;===================================================== +DESC(RIEN,DESL,DESC,KEYWORD) ;Build the description. + N JND,LC,NKEYW + S LC=1 + S ^PXD(811.8,RIEN,110,LC,0)="Reminder: "_DESL("RNAME") + S LC=LC+1 + S ^PXD(811.8,RIEN,110,LC,0)="Source: "_DESL("SOURCE") + S LC=LC+1 + S ^PXD(811.8,RIEN,110,LC,0)="Date Packed: "_DESL("DATEP") + S LC=LC+1 + S ^PXD(811.8,RIEN,110,LC,0)="Package Version: "_DESL("VRSN") + S LC=LC+1 + S ^PXD(811.8,RIEN,110,LC,0)="" + ;Add the user's description. + S LC=LC+1 + S ^PXD(811.8,RIEN,110,LC,0)="Description:" + F JND=1:1:+$P($G(@DESC@(1,0)),U,4) D + . S LC=LC+1 + . S ^PXD(811.8,RIEN,110,LC,0)=@DESC@(1,JND,0) + S LC=LC+1 + S ^PXD(811.8,RIEN,110,LC,0)="" + ;Add the keywords. + S LC=LC+1 + S ^PXD(811.8,RIEN,110,LC,0)="Keywords:" + S NKEYW=+$P($G(@KEYWORD@(1,0)),U,4) + I NKEYW=0 D + . S LC=LC+1 + . S ^PXD(811.8,RIEN,110,LC,0)="No keywords given" + F JND=1:1:NKEYW D + . S LC=LC+1 + . S ^PXD(811.8,RIEN,110,LC,0)=@KEYWORD@(1,JND,0) + S LC=LC+1 + S ^PXD(811.8,RIEN,110,LC,0)="" + S LC=LC+1 + S ^PXD(811.8,RIEN,110,LC,0)="Components:" + S ^PXD(811.8,RIEN,110,0)=U_811.804_U_LC_U_LC + Q + ; + ;===================================================== +RIEN(LIEN) ;Given the list ien return the repository ien. + N RIEN + 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,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)!(JND>IND) + ;Set the 0 node. + S ^PXD(811.8,PXRMRIEN,130,0)=U_"811.803DA"_U_JND_U_JND + S IND=JND + 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(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" + K ^TMP("PXRMEXIA",$J) + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMEXU2.m b/r/CLINICAL_REMINDERS-PXRM/PXRMEXU2.m index 3fb7028e..129c603d 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMEXU2.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMEXU2.m @@ -1,196 +1,195 @@ -PXRMEXU2 ; SLC/PKR/PJH - Reminder exchange repository utilities, #2. ;11/21/2007 - ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123 - ;===================================================== -FDA(IND,LC,TMPIND,FILENAME) ;Build the XML FDA output. - N FIELD,FILENUM,INDEX,INDEX0,JND,SIENS,WPC - S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" - S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" - S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" - Q - ; - ;===================================================== -IENROOT(IND,LC,TMPIND,FILENAME) ;Build the XML IEN_ROOT output. - N INDEX,VALUE - S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" - S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" - S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" - Q - ; - ;===================================================== -STOREPR(SUCCESS,RTM,TMPIND,EXTYPE) ;^TMP(TMPIND,$J contains data to be - ;stored in the repository. Routines will be found in - ;^TMP(TMPIND,$J,"ROUTINE",ROUTINE NAME,n) where n is the line number. - ;File entries will be found in ^TMP(TMPIND,$J,N,FILENAME,indexes). - ;This is output from the GETS^DIQ call. There are NUMF file entries. - ;Format and store it as XML in the repository. - N DATE,DTEST,FDA,FILENAME,FILENUM - N IENROOT,IND,JND,LC,LINE,NCMPNT,NEWFILE,NUMF,PT01,RNAME - N SIENS,SOURCE,TEMP,VERSN - ;If anything went wrong in the packing process then ^TMP(TMPIND,$J - ;will not exist. - I '$D(^TMP(TMPIND,$J)) S SUCCESS=0 Q - ; - K ^TMP($J,"CIND") - K ^TMP("PXRMEXRS",$J) - S ^TMP("PXRMEXRS",$J,1,0)="" - S ^TMP("PXRMEXRS",$J,2,0)="" - S VERSN=$P(^PXRM(800,1,"VERSION"),U,1) - S ^TMP("PXRMEXRS",$J,3,0)=""_VERSN_"" - ;The pointer to the index will be on line 4 so leave room. - S LC=4 - ;Save the source information. - S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" - S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=""_$$TOXML^PXRMEXU3(^TMP(TMPIND,$J,"SRC","REMINDER"))_"" - S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=""_$$TOXML^PXRMEXU3(^TMP(TMPIND,$J,"SRC","USER"))_"" - S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=""_$$TOXML^PXRMEXU3(^TMP(TMPIND,$J,"SRC","SITE"))_"" - S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=""_^TMP(TMPIND,$J,"SRC","DATE")_"" - S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" - ; - ;Save the Exchange Type. - I EXTYPE="" S EXTYPE="REMINDER" - S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=""_$$TOXML^PXRMEXU3(EXTYPE)_"" - ; - ;Save the description. - S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" - ; - ;Save the keywords or phrases. - S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" - S IND=0 - F S IND=$O(^TMP(TMPIND,$J,"KEYWORD",1,IND)) Q:+IND=0 D - . S TEMP=^TMP(TMPIND,$J,"KEYWORD",1,IND,0) - . I TEMP["," D - .. F JND=1:1:$L(TEMP,",") D - ... S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=""_$$TOXML^PXRMEXU3($P(TEMP,",",JND))_"" - . E S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=""_$$TOXML^PXRMEXU3(TEMP)_"" - S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" - ; - S NCMPNT=0 - ;Do routines first. - S RNAME="" - F S RNAME=$O(^TMP(TMPIND,$J,"ROUTINE",RNAME)) Q:RNAME="" D - . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" - . S NCMPNT=NCMPNT+1 - . S ^TMP($J,"CIND",NCMPNT,"M_ROUTINE_START")=LC - . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=""_RNAME_"" - . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=""_^TMP("PXRMEXCS",$J,"ROUTINE",RNAME)_"" - . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" - . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" - . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" - . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" - . S ^TMP($J,"CIND",NCMPNT,"ROUTINE_CODE_END")=LC-3 - ; - ;Do file entries. - ;For word processing fields the first line is - ;file number;source ien string;field~WP-start~line count - ;The next line count lines are the WP data. - S NUMF=+$G(^TMP(TMPIND,$J,"NUMF")) - S FILENAME="" - F IND=1:1:NUMF D - . F S FILENAME=$O(^TMP(TMPIND,$J,IND,FILENAME)) Q:FILENAME="" D - .. I FILENAME["IENROOT" D - ... S NEWFILE=0 - ... S IENROOT=1 - .. E D - ... S NEWFILE=1 - ... S IENROOT=0 - .. I NEWFILE D - ... S FILENUM=$O(^TMP(TMPIND,$J,IND,FILENAME,"")) - ... S SIENS=$O(^TMP(TMPIND,$J,IND,FILENAME,FILENUM,"")) - ... S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" - ... S NCMPNT=NCMPNT+1 - ... S ^TMP($J,"CIND",NCMPNT,"FILE_START")=LC - ... S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=""_$$TOXML^PXRMEXU3(FILENAME)_"" - ... S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=""_FILENUM_"" - ... S LC=LC+1,PT01=^TMP(TMPIND,$J,IND,FILENAME,FILENUM,SIENS,.01) - ... S ^TMP("PXRMEXRS",$J,LC,0)=""_$$TOXML^PXRMEXU3(PT01)_"" - ... S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=""_+SIENS_"" - ... S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=""_^TMP("PXRMEXCS",$J,IND,FILENAME)_"" - ... S ^TMP($J,"CIND",NCMPNT,"FDA_START")=LC+3 - ... D FDA(IND,.LC,TMPIND,FILENAME) - ... S ^TMP($J,"CIND",NCMPNT,"FDA_END")=LC-2 - ..;The ien root information always comes after the FDA. - .. I IENROOT D - ... S ^TMP($J,"CIND",NCMPNT,"IEN_ROOT_START")=LC+3 - ... D IENROOT(IND,.LC,TMPIND,FILENAME) - ... S ^TMP($J,"CIND",NCMPNT,"IEN_ROOT_END")=LC-2 - . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" - ;Save the index. - S LC=LC+1,^TMP("PXRMEXRS",$J,4,0)=""_LC_"" - S ^TMP("PXRMEXRS",$J,LC,0)="" - S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=""_NCMPNT_"" - F IND=1:1:NCMPNT D - . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" - . S JND="" - . F S JND=$O(^TMP($J,"CIND",IND,JND)) Q:JND="" D - .. S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<"_JND_">"_^TMP($J,"CIND",IND,JND)_"" - . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" - S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" - S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" - ;Establish the entry in the repository. - S RNAME=$P(RTM,U,2) - S SOURCE=^TMP(TMPIND,$J,"SRC","USER")_" at "_^TMP(TMPIND,$J,"SRC","SITE") - S DATE=^TMP(TMPIND,$J,"SRC","DATE") - S FDA(811.8,"+1,",.01)=RNAME - S FDA(811.8,"+1,",.02)=SOURCE - S FDA(811.8,"+1,",.03)=DATE - S FDA(811.8,"+1,",115)=EXTYPE - D UPDATE^PXRMEXPU(.SUCCESS,.FDA,.IENROOT) - I SUCCESS D - . M ^PXD(811.8,IENROOT(1),100)=^TMP("PXRMEXRS",$J) - .;Set the 0 node. - . S ^PXD(811.8,IENROOT(1),100,0)=U_811.801_U_LC_U_LC - .;Save the Exchange Type. - . S ^PXD(811.8,IENROOT(1),115)=$G(EXTYPE) - .;Create the description for this repository entry. - . N DATEP,DESC,DESL,KEYWORD,RNAME,SOURCE - . S DESL("RNAME")=^TMP(TMPIND,$J,"SRC","REMINDER") - . 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 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) - Q - ; - ;===================================================== -XMLOUT(IEN) ;Write out the XML content of repository entry ien. - N LC,NLINES - S NLINES=$O(^PXD(811.8,IEN,100,""),-1) - F LC=1:1:NLINES W !,^PXD(811.8,IEN,100,LC,0) - Q - ; +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. + N FIELD,FILENUM,INDEX,INDEX0,JND,SIENS,WPC + S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" + S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" + S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" + Q + ; + ;===================================================== +IENROOT(IND,LC,TMPIND,FILENAME) ;Build the XML IEN_ROOT output. + N INDEX,VALUE + S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" + S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" + S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" + Q + ; + ;===================================================== +STOREPR(SUCCESS,RTM,TMPIND,EXTYPE) ;^TMP(TMPIND,$J contains data to be + ;stored in the repository. Routines will be found in + ;^TMP(TMPIND,$J,"ROUTINE",ROUTINE NAME,n) where n is the line number. + ;File entries will be found in ^TMP(TMPIND,$J,N,FILENAME,indexes). + ;This is output from the GETS^DIQ call. There are NUMF file entries. + ;Format and store it as XML in the repository. + N DATE,DTEST,FDA,FILENAME,FILENUM + N IENROOT,IND,JND,LC,LINE,NCMPNT,NEWFILE,NUMF,PT01,RNAME + N SIENS,SOURCE,TEMP,VERSN + ;If anything went wrong in the packing process then ^TMP(TMPIND,$J + ;will not exist. + I '$D(^TMP(TMPIND,$J)) S SUCCESS=0 Q + ; + K ^TMP($J,"CIND") + K ^TMP("PXRMEXRS",$J) + S ^TMP("PXRMEXRS",$J,1,0)="" + S ^TMP("PXRMEXRS",$J,2,0)="" + S VERSN=^PXRM(800,1,"VERSION") + S ^TMP("PXRMEXRS",$J,3,0)=""_VERSN_"" + ;The pointer to the index will be on line 4 so leave room. + S LC=4 + ;Save the source information. + S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" + S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=""_$$TOXML^PXRMEXU3(^TMP(TMPIND,$J,"SRC","REMINDER"))_"" + S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=""_$$TOXML^PXRMEXU3(^TMP(TMPIND,$J,"SRC","USER"))_"" + S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=""_$$TOXML^PXRMEXU3(^TMP(TMPIND,$J,"SRC","SITE"))_"" + S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=""_^TMP(TMPIND,$J,"SRC","DATE")_"" + S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" + ; + ;Save the Exchange Type. + I EXTYPE="" S EXTYPE="REMINDER" + S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=""_$$TOXML^PXRMEXU3(EXTYPE)_"" + ; + ;Save the description. + S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" + ; + ;Save the keywords or phrases. + S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" + S IND=0 + F S IND=$O(^TMP(TMPIND,$J,"KEYWORD",1,IND)) Q:+IND=0 D + . S TEMP=^TMP(TMPIND,$J,"KEYWORD",1,IND,0) + . I TEMP["," D + .. F JND=1:1:$L(TEMP,",") D + ... S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=""_$$TOXML^PXRMEXU3($P(TEMP,",",JND))_"" + . E S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=""_$$TOXML^PXRMEXU3(TEMP)_"" + S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" + ; + S NCMPNT=0 + ;Do routines first. + S RNAME="" + F S RNAME=$O(^TMP(TMPIND,$J,"ROUTINE",RNAME)) Q:RNAME="" D + . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" + . S NCMPNT=NCMPNT+1 + . S ^TMP($J,"CIND",NCMPNT,"M_ROUTINE_START")=LC + . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=""_RNAME_"" + . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" + . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" + . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" + . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" + . S ^TMP($J,"CIND",NCMPNT,"ROUTINE_CODE_END")=LC-3 + ; + ;Do file entries. + ;For word processing fields the first line is + ;file number;source ien string;field~WP-start~line count + ;The next line count lines are the WP data. + S NUMF=+$G(^TMP(TMPIND,$J,"NUMF")) + S FILENAME="" + F IND=1:1:NUMF D + . F S FILENAME=$O(^TMP(TMPIND,$J,IND,FILENAME)) Q:FILENAME="" D + .. I FILENAME["IENROOT" D + ... S NEWFILE=0 + ... S IENROOT=1 + .. E D + ... S NEWFILE=1 + ... S IENROOT=0 + .. I NEWFILE D + ... S FILENUM=$O(^TMP(TMPIND,$J,IND,FILENAME,"")) + ... S SIENS=$O(^TMP(TMPIND,$J,IND,FILENAME,FILENUM,"")) + ... S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" + ... S NCMPNT=NCMPNT+1 + ... S ^TMP($J,"CIND",NCMPNT,"FILE_START")=LC + ... S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=""_$$TOXML^PXRMEXU3(FILENAME)_"" + ... S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=""_FILENUM_"" + ... S LC=LC+1,PT01=^TMP(TMPIND,$J,IND,FILENAME,FILENUM,SIENS,.01) + ... S ^TMP("PXRMEXRS",$J,LC,0)=""_$$TOXML^PXRMEXU3(PT01)_"" + ... S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=""_+SIENS_"" + ... S ^TMP($J,"CIND",NCMPNT,"FDA_START")=LC+3 + ... D FDA(IND,.LC,TMPIND,FILENAME) + ... S ^TMP($J,"CIND",NCMPNT,"FDA_END")=LC-2 + ..;The ien root information always comes after the FDA. + .. I IENROOT D + ... S ^TMP($J,"CIND",NCMPNT,"IEN_ROOT_START")=LC+3 + ... D IENROOT(IND,.LC,TMPIND,FILENAME) + ... S ^TMP($J,"CIND",NCMPNT,"IEN_ROOT_END")=LC-2 + . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" + ;Save the index. + S LC=LC+1,^TMP("PXRMEXRS",$J,4,0)=""_LC_"" + S ^TMP("PXRMEXRS",$J,LC,0)="" + S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=""_NCMPNT_"" + F IND=1:1:NCMPNT D + . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" + . S JND="" + . F S JND=$O(^TMP($J,"CIND",IND,JND)) Q:JND="" D + .. S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<"_JND_">"_^TMP($J,"CIND",IND,JND)_"" + . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" + S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" + S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="" + ;Establish the entry in the repository. + S RNAME=$P(RTM,U,2) + S SOURCE=^TMP(TMPIND,$J,"SRC","USER")_" at "_^TMP(TMPIND,$J,"SRC","SITE") + S DATE=^TMP(TMPIND,$J,"SRC","DATE") + S FDA(811.8,"+1,",.01)=RNAME + S FDA(811.8,"+1,",.02)=SOURCE + S FDA(811.8,"+1,",.03)=DATE + S FDA(811.8,"+1,",115)=EXTYPE + D UPDATE^PXRMEXPU(.SUCCESS,.FDA,.IENROOT) + I SUCCESS D + . M ^PXD(811.8,IENROOT(1),100)=^TMP("PXRMEXRS",$J) + .;Set the 0 node. + . S ^PXD(811.8,IENROOT(1),100,0)=U_811.801_U_LC_U_LC + .;Save the Exchange Type. + . S ^PXD(811.8,IENROOT(1),115)=$G(EXTYPE) + .;Create the description for this repository entry. + . N DATEP,DESC,DESL,KEYWORD,RNAME,SOURCE + . S DESL("RNAME")=^TMP(TMPIND,$J,"SRC","REMINDER") + . 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")=$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") + K ^TMP("PXRMEXRS",$J) + K ^TMP(TMPIND,$J) + Q + ; + ;===================================================== +XMLOUT(IEN) ;Write out the XML content of repository entry ien. + N LC,NLINES + S NLINES=$O(^PXD(811.8,IEN,100,""),-1) + F LC=1:1:NLINES W !,^PXD(811.8,IEN,100,LC,0) + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMEXU4.m b/r/CLINICAL_REMINDERS-PXRM/PXRMEXU4.m index 69d4f228..34373335 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMEXU4.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMEXU4.m @@ -1,246 +1,215 @@ -PXRMEXU4 ; SLC/PJH,PKR - Reminder Exchange #4, dialog changes. ;05/16/2007 - ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123 - ;=============================================== -DLG(FDA,NAMECHG) ;Check the dialog for renamed entries, called by - ;silent installer. KIDSDONE is newed in INSDLG^PXRMEXSI. - N ABBR,ACTION,ALIST,DNAM,IEN,IENS,FILENUM,FINDING,NEWNAM,OFINDING - N ORITEM,OORITEM,PT01,RESULT,RRG,SRC,WP - S IENS=$O(FDA(801.41,"")) - ;Definition .01 - S (PT01,DNAM)=FDA(801.41,IENS,.01) - I $D(NAMECHG(801.41,PT01)) D - .S (FDA(801.41,IENS,.01),DNAM)=NAMECHG(801.41,PT01) - ; - ;Build list of finding types - 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("WH")=790.404 - ;Plus field 17 file - S ALIST("OI")=101.43 - ; - ;Process SOURCE REMINDER - S SRC=$G(FDA(801.41,IENS,2)) - I SRC]"" D - .S IEN=$$EXISTS^PXRMEXIU(811.9,SRC) - .I IEN=0 K FDA(801.41,IENS,2) - ; - ;Clear RESULT if not defined - S RESULT=$G(FDA(801.41,IENS,55)) - I RESULT]"" D - .S IEN=$$EXISTS^PXRMEXIU(801.41,RESULT) - .I IEN=0 K FDA(801.41,IENS,55) - ; - ;Process ORDERABLE ITEM - S (ORITEM,OORITEM)=$G(FDA(801.41,IENS,17)),ACTION="" - I ORITEM'="" D I ACTION="Q" K FDA S (PXRMDONE,KIDSDONE)=1 Q - .S PT01=ORITEM - .S ABBR="OI",FILENUM=$P(ALIST(ABBR),U) - .I $D(NAMECHG(FILENUM,PT01)) D - ..S ORITEM=NAMECHG(FILENUM,PT01) - ..S FDA(801.41,IENS,17)=ORITEM - .S IEN=+$$VFIND1^PXRMEXIU(ABBR_"."_ORITEM,.ALIST) - .I IEN=0 D - ..;Get replacement - ..N DIC,DIR,DUOUT,MSG,X,Y - ..S MSG(1)=" " - ..S MSG(2)="ORDERABLE ITEM entry "_ORITEM_" 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.41,IENS,17) Q - ..S DIC=FILENUM - ..S DIC(0)="AEMNQ" - ..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") - ...;If this is being called during a KIDS install we need echoing on. - ...I $D(DUOUT) S Y="" Q - ...I Y=-1 D BMES^XPDUTL("You must input a replacement!") - ..I Y="" S ACTION="Q" Q - ..S ORITEM=$P(Y,U,2) - ..S FDA(801.41,IENS,17)=ORITEM - .;Save the finding information for the history. - .I ORITEM'=OORITEM D - .. S ^TMP("PXRMEXIA",$J,"DIAF",$P(IENS,",",1),ABBR_"."_OORITEM)=ABBR_"."_ORITEM - ; - ;Process FINDING ITEM - S (FINDING,OFINDING)=$G(FDA(801.41,IENS,15)),ACTION="" - I FINDING'="" D I ACTION="Q" K FDA S (PXRMDONE,KIDSDONE)=1 Q - .S ABBR=$P(FINDING,".",1) - .S PT01=$P(FINDING,".",2) - .S FILENUM=$P(ALIST(ABBR),U,1) - .I $D(NAMECHG(FILENUM,PT01)) D - ..S FINDING=ABBR_"."_NAMECHG(FILENUM,PT01) - ..S FDA(801.41,IENS,15)=FINDING - .S IEN=+$$VFIND1^PXRMEXIU(FINDING,.ALIST) - .I IEN=0 D - ..;Get replacement - ..N DIC,DIR,DUOUT,MSG,X,Y - ..S MSG(1)=" " - ..S MSG(2)="FINDING entry "_FINDING_" 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.41,IENS,15) Q - ..S DIC=FILENUM - ..S DIC(0)="AEMNQ" - ..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") - ...;If this is being called during a KIDS install we need echoing on. - ...I $D(DUOUT) S Y="" Q - ...I Y=-1 D BMES^XPDUTL("You must input a replacement!") - ..I Y="" S ACTION="Q" Q - ..S FINDING=ABBR_"."_$P(Y,U,2) - ..S FDA(801.41,IENS,15)=FINDING - .;Save the finding information for the history. - .I FINDING'=OFINDING D - .. S ^TMP("PXRMEXIA",$J,"DIAF",$P(IENS,",",1),OFINDING)=FINDING - .;Convert ICD9 codes to `ien format - .I $P(FINDING,".")="ICD9" S FDA(801.41,IENS,15)="ICD9."_$$ICD9(FINDING) - ; - ;Look for replacements of TIU templates. - I $D(NAMECHG(8927.1)) D - .S WP=$G(FDA(801.41,IENS,25)) - .I WP'="" D TIURPL("{FLD:",WP,.NAMECHG,8927.1) - .S WP=$G(FDA(801.41,IENS,35)) - ; - ;Process ADDITIONAL FINDINGS - S IENS="",ACTION="" - F S IENS=$O(FDA(801.4118,IENS)) Q:IENS="" D I ACTION="Q" K FDA S (PXRMDONE,KIDSDONE)=1 Q - . S (FINDING,OFINDING)=FDA(801.4118,IENS,.01) - . S ABBR=$P(FINDING,".",1) - . S PT01=$P(FINDING,".",2) - . S FILENUM=$P(ALIST(ABBR),U,1) - . I $D(NAMECHG(FILENUM,PT01)) D - .. S FINDING=ABBR_"."_NAMECHG(FILENUM,PT01) - .. S FDA(801.4118,IENS,.01)=FINDING - . S IEN=+$$VFIND1^PXRMEXIU(FINDING,.ALIST) - . I IEN=0 D Q:ACTION="Q" - ..;Get replacement - .. N DIC,DIR,DUOUT,MSG,X,Y - .. S MSG(1)=" " - .. S MSG(2)="ADDITIONAL FINDING entry "_FINDING_" 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.4118,IENS) Q - .. S DIC=FILENUM - .. S DIC(0)="AEMNQ" - .. 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 - .. S FINDING=ABBR_"."_$P(Y,U,2) - .. S FDA(801.4118,IENS,.01)=FINDING - . ;Save the finding information for the history. - . I FINDING'=OFINDING D - .. S ^TMP("PXRMEXIA",$J,"DIAF",$P(IENS,",",1),OFINDING)=FINDING - . ;Convert ICD9 codes to `ien format - . I $P(FINDING,".")="ICD9" S FDA(801.4118,IENS,.01)=$$ICD9(FINDING) - ; - I ACTION="Q" S (PXRMDONE,KIDSDONE)=1 Q - ;Process DIALOG COMPONENT - S IENS="",ACTION="" - F S IENS=$O(FDA(801.412,IENS)) Q:IENS="" D I ACTION="Q" K FDA S (PXRMDONE,KIDSDONE)=1 Q - . S PT01=$G(FDA(801.412,IENS,2)) Q:PT01="" - . S FILENUM=801.41,NEWNAM=$G(NAMECHG(FILENUM,PT01)) - .I NEWNAM'="" D - .. S FDA(801.412,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)="COMPONENT DIALOG 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.412,IENS) Q - .. S DIC=FILENUM - .. S DIC(0)="AEMNQ" - .. S DIC("S")="I ""EG""[$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.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 - ; - ;=============================================== - ;Convert ICD9 codes to `ien format -ICD9(CODE) ; - N IEN - S IEN=$$FIND1^DIC(80,"","AMX",$P(CODE,".",2,99)) - I 'IEN Q "" - Q "`"_IEN - ; - ;=============================================== -TIURPL(SRCH,WP,NAMEGHC,FILENUM) ;Replace TIU templates whose names have - ;changed. - N IND,RS,TEXT,TS,TYPE - I FILENUM=8927.1 S TYPE="TIU TEMPLATE" - E S TYPE="TIU OBJECT" - S IND=1 - F S TEXT=$G(@WP@(IND)) Q:TEXT="" D - .I TEXT[SRCH D - ..S TS="" - ..F S TS=$O(NAMECHG(FILENUM,TS)) Q:TS="" D - ...S RS=NAMECHG(FILENUM,TS) Q:TEXT'[TS - ...S @WP@(IND)=$$STRREP^PXRMUTIL(TEXT,TS,RS) - ...;Save the replacement information for the history. - ...S ^TMP("PXRMEXIA",$J,"DIATIU",TYPE,TS)=RS - ...S ^TMP("PXRMEXIA",$J,"DIATIU",TYPE,TS,DNAM)="" - .S IND=IND+1 - Q - ; +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 + ;silent installer. KIDSDONE is newed in INSDLG^PXRMEXSI. + N ABBR,ACTION,ALIST,DNAM,IEN,IENS,FILENUM,FINDING,NEWNAM,OFINDING + N ORITEM,OORITEM,PT01,RESULT,RRG,SRC,WP + S IENS=$O(FDA(801.41,"")) + ;Definition .01 + S (PT01,DNAM)=FDA(801.41,IENS,.01) + I $D(NAMECHG(801.41,PT01)) D + .S (FDA(801.41,IENS,.01),DNAM)=NAMECHG(801.41,PT01) + ; + ;Build list of finding types + D BLDALIST^PXRMVPTR(801.4118,.01,.ALIST) + ;Plus field 15 files + S ALIST("MH")=601,ALIST("TX")=811.2 + S ALIST("WH")=790.404 + ;Plus field 17 file + S ALIST("OI")=101.43 + ; + ;Process SOURCE REMINDER + S SRC=$G(FDA(801.41,IENS,2)) + I SRC]"" D + .S IEN=$$EXISTS^PXRMEXIU(811.9,SRC) + .I IEN=0 K FDA(801.41,IENS,2) + ; + ;Clear RESULT if not defined + S RESULT=$G(FDA(801.41,IENS,55)) + I RESULT]"" D + .S IEN=$$EXISTS^PXRMEXIU(801.41,RESULT) + .I IEN=0 K FDA(801.41,IENS,55) + ; + ;Process ORDERABLE ITEM + S (ORITEM,OORITEM)=$G(FDA(801.41,IENS,17)),ACTION="" + I ORITEM'="" D I ACTION="Q" K FDA S (PXRMDONE,KIDSDONE)=1 Q + .S PT01=ORITEM + .S ABBR="OI",FILENUM=$P(ALIST(ABBR),U) + .I $D(NAMECHG(FILENUM,PT01)) D + ..S ORITEM=NAMECHG(FILENUM,PT01) + ..S FDA(801.41,IENS,17)=ORITEM + .S IEN=+$$VFIND1^PXRMEXIU(ABBR_"."_ORITEM,.ALIST) + .I IEN=0 D + ..;Get replacement + ..N DIC,DIR,DUOUT,MSG,X,Y + ..S MSG(1)=" " + ..S MSG(2)="ORDERABLE ITEM entry "_ORITEM_" 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.41,IENS,17) Q + ..S DIC=FILENUM + ..S DIC(0)="AEMNQ" + ..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") + ...;If this is being called during a KIDS install we need echoing on. + ...I $D(DUOUT) S Y="" Q + ...I Y=-1 D BMES^XPDUTL("You must input a replacement!") + ..I Y="" S ACTION="Q" Q + ..S ORITEM=$P(Y,U,2) + ..S FDA(801.41,IENS,17)=ORITEM + .;Save the finding information for the history. + .I ORITEM'=OORITEM D + .. S ^TMP("PXRMEXIA",$J,"DIAF",$P(IENS,",",1),ABBR_"."_OORITEM)=ABBR_"."_ORITEM + ; + ;Process FINDING ITEM + S (FINDING,OFINDING)=$G(FDA(801.41,IENS,15)),ACTION="" + I FINDING'="" D I ACTION="Q" K FDA S (PXRMDONE,KIDSDONE)=1 Q + .S ABBR=$P(FINDING,".",1) + .S PT01=$P(FINDING,".",2) + .S FILENUM=$P(ALIST(ABBR),U,1) + .I $D(NAMECHG(FILENUM,PT01)) D + ..S FINDING=ABBR_"."_NAMECHG(FILENUM,PT01) + ..S FDA(801.41,IENS,15)=FINDING + .S IEN=+$$VFIND1^PXRMEXIU(FINDING,.ALIST) + .I IEN=0 D + ..;Get replacement + ..N DIC,DIR,DUOUT,MSG,X,Y + ..S MSG(1)=" " + ..S MSG(2)="FINDING entry "_FINDING_" 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.41,IENS,15) Q + ..S DIC=FILENUM + ..S DIC(0)="AEMNQ" + ..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") + ...;If this is being called during a KIDS install we need echoing on. + ...I $D(DUOUT) S Y="" Q + ...I Y=-1 D BMES^XPDUTL("You must input a replacement!") + ..I Y="" S ACTION="Q" Q + ..S FINDING=ABBR_"."_$P(Y,U,2) + ..S FDA(801.41,IENS,15)=FINDING + .;Save the finding information for the history. + .I FINDING'=OFINDING D + .. S ^TMP("PXRMEXIA",$J,"DIAF",$P(IENS,",",1),OFINDING)=FINDING + .;Convert ICD9 codes to `ien format + .I $P(FINDING,".")="ICD9" S FDA(801.41,IENS,15)="ICD9."_$$ICD9(FINDING) + ; + ;Look for replacements of TIU templates. + I $D(NAMECHG(8927.1)) D + .S WP=$G(FDA(801.41,IENS,25)) + .I WP'="" D TIURPL("{FLD:",WP,.NAMECHG,8927.1) + .S WP=$G(FDA(801.41,IENS,35)) + ; + ;Process ADDITIONAL FINDINGS + S IENS="",ACTION="" + F S IENS=$O(FDA(801.4118,IENS)) Q:IENS="" D I ACTION="Q" K FDA S (PXRMDONE,KIDSDONE)=1 Q + . S (FINDING,OFINDING)=FDA(801.4118,IENS,.01) + . S ABBR=$P(FINDING,".",1) + . S PT01=$P(FINDING,".",2) + . S FILENUM=$P(ALIST(ABBR),U,1) + . I $D(NAMECHG(FILENUM,PT01)) D + .. S FINDING=ABBR_"."_NAMECHG(FILENUM,PT01) + .. S FDA(801.4118,IENS,.01)=FINDING + . S IEN=+$$VFIND1^PXRMEXIU(FINDING,.ALIST) + . I IEN=0 D Q:ACTION="Q" + ..;Get replacement + .. N DIC,DIR,DUOUT,MSG,X,Y + .. S MSG(1)=" " + .. S MSG(2)="ADDITIONAL FINDING entry "_FINDING_" 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.4118,IENS) Q + .. S DIC=FILENUM + .. S DIC(0)="AEMNQ" + .. 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 + .. S FINDING=ABBR_"."_$P(Y,U,2) + .. S FDA(801.4118,IENS,.01)=FINDING + . ;Save the finding information for the history. + . I FINDING'=OFINDING D + .. S ^TMP("PXRMEXIA",$J,"DIAF",$P(IENS,",",1),OFINDING)=FINDING + . ;Convert ICD9 codes to `ien format + . I $P(FINDING,".")="ICD9" S FDA(801.4118,IENS,.01)=$$ICD9(FINDING) + ; + I ACTION="Q" S (PXRMDONE,KIDSDONE)=1 Q + ;Process DIALOG COMPONENT + S IENS="",ACTION="" + F S IENS=$O(FDA(801.412,IENS)) Q:IENS="" D I ACTION="Q" K FDA S (PXRMDONE,KIDSDONE)=1 Q + . S PT01=$G(FDA(801.412,IENS,2)) Q:PT01="" + . S FILENUM=801.41,NEWNAM=$G(NAMECHG(FILENUM,PT01)) + .I NEWNAM'="" D + .. S FDA(801.412,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)="COMPONENT DIALOG 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.412,IENS) Q + .. S DIC=FILENUM + .. S DIC(0)="AEMNQ" + .. S DIC("S")="I ""EG""[$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.412,IENS,2)=$P(Y,U,2) + Q + ; + ;=============================================== + ;Convert ICD9 codes to `ien format +ICD9(CODE) ; + N IEN + S IEN=$$FIND1^DIC(80,"","AMX",$P(CODE,".",2,99)) + I 'IEN Q "" + Q "`"_IEN + ; + ;=============================================== +TIURPL(SRCH,WP,NAMEGHC,FILENUM) ;Replace TIU templates whose names have + ;changed. + N IND,RS,TEXT,TS,TYPE + I FILENUM=8927.1 S TYPE="TIU TEMPLATE" + E S TYPE="TIU OBJECT" + S IND=1 + F S TEXT=$G(@WP@(IND)) Q:TEXT="" D + .I TEXT[SRCH D + ..S TS="" + ..F S TS=$O(NAMECHG(FILENUM,TS)) Q:TS="" D + ...S RS=NAMECHG(FILENUM,TS) Q:TEXT'[TS + ...S @WP@(IND)=$$STRREP^PXRMUTIL(TEXT,TS,RS) + ...;Save the replacement information for the history. + ...S ^TMP("PXRMEXIA",$J,"DIATIU",TYPE,TS)=RS + ...S ^TMP("PXRMEXIA",$J,"DIATIU",TYPE,TS,DNAM)="" + .S IND=IND+1 + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMFF.m b/r/CLINICAL_REMINDERS-PXRM/PXRMFF.m index 76072dc7..e5da8bf2 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMFF.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMFF.m @@ -1,127 +1,127 @@ -PXRMFF ;SLC/PKR - Clinical Reminders function finding evaluation. ;3/29/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ;=========================================== -EVAL(DFN,DEFARR,FIEVAL) ;Evaluate function findings. - N FFIND,FFN,FILIST,FN,FUN,FUNIND,FUNN,FVALUE,JND - N LOGIC,NL,ROUTINE,TEMP - I '$D(DEFARR(25)) Q - S FFN="FF" - F S FFN=$O(DEFARR(25,FFN)) Q:FFN'["FF" D - . K FN - . S FUNIND=0 - . F S FUNIND=+$O(DEFARR(25,FFN,5,FUNIND)) Q:FUNIND=0 D - .. S FUNN=$P(DEFARR(25,FFN,5,FUNIND,0),U,1) - .. S FUN=$P(DEFARR(25,FFN,5,FUNIND,0),U,2) - .. S TEMP=^PXRMD(802.4,FUN,0) - .. S ROUTINE=$P(TEMP,U,2,3)_"(.FILIST,.FIEVAL,.FVALUE)" - .. K FILIST - .. S (JND,NL)=0 - .. F S JND=+$O(DEFARR(25,FFN,5,FUNIND,20,JND)) Q:JND=0 D - ... S NL=NL+1 - ... S FILIST(NL)=DEFARR(25,FFN,5,FUNIND,20,JND,0) - .. S FILIST(0)=NL - .. D @ROUTINE - .. S FN(FUNIND)=FVALUE - . S LOGIC=$G(DEFARR(25,FFN,10)) - . S LOGIC=$S(LOGIC'="":LOGIC,1:0) - . I @LOGIC - . S FIEVAL(FFN)=$T - . S FIEVAL(FFN,"NUMBER")=$P(FFN,"FF",2) - . S FIEVAL(FFN,"FINDING")=$G(FUN)_";PXRMD(802.4," - Q - ; - ;=========================================== -EVALPL(DEFARR,FFIND,PLIST) ;Build a list of patients based on a function - ;finding. - N COUNT,DAS,DATE,DFN - N FI,FIEVAL,FIEVT,FIL,FILIST,FILENUM,FINDPA,FN - N FUN,FUNNM,FUNN,FUNNUM,FVALUE - N IND,ITEM,JND,LOGIC,LNAME,NFI,NFUN,ROUTINE,TEMP,TERMARR,UNIQFIL - S LOGIC=DEFARR(25,FFIND,10) - I LOGIC="" Q - ;Build the list of functions and findings used by the function finding. - S (FUNNUM,NFUN)=0 - F S FUNNUM=+$O(DEFARR(25,FFIND,5,FUNNUM)) Q:FUNNUM=0 D - . S NFUN=NFUN+1 - . S FUNN=$P(DEFARR(25,FFIND,5,FUNNUM,0),U,1) - . S FUN=$P(DEFARR(25,FFIND,5,FUNNUM,0),U,2) - . S TEMP=^PXRMD(802.4,FUN,0) - . S ROUTINE(NFUN)=$P(TEMP,U,2,3)_"(.FIL,.FIEVAL,.FVALUE)" - . S (FI,NFI)=0 - . F S FI=+$O(DEFARR(25,FFIND,5,FUNNUM,20,FI)) Q:FI=0 D - .. S NFI=NFI+1,FILIST(NFUN,NFI)=DEFARR(25,FFIND,5,FUNNUM,20,FI,0) - . S FILIST(NFUN,0)=NFI - ;A finding may be used in more than one function in the function - ;finding so build a list of the unique findings. - F IND=1:1:NFUN D - . F JND=1:1:FILIST(IND,0) D - .. S TEMP=$P(DEFARR(20,FILIST(IND,JND),0),U,1) - .. S ITEM=$P(TEMP,";",1) - .. S FILENUM=$$GETFNUM^PXRMDATA($P(TEMP,";",2)) - .. S UNIQFIL(FILIST(IND,JND))="" - K ^TMP($J,"PXRMFFDFN") - S IND=0 - F S IND=$O(UNIQFIL(IND)) Q:IND="" D - . S FINDPA(0)=DEFARR(20,IND,0) - . S FINDPA(3)=DEFARR(20,IND,3) - . S FINDPA(10)=DEFARR(20,IND,10) - . S FINDPA(11)=DEFARR(20,IND,11) - . D GENTERM^PXRMPLST(FINDPA(0),IND,.TERMARR) - . S LNAME(IND)="PXRMFF"_IND - . K ^TMP($J,LNAME(IND)) - . D EVALPL^PXRMTERL(.FINDPA,.TERMARR,LNAME(IND)) - .;Get rid of the false part of the list. - . K ^TMP($J,LNAME(IND),0) - .;Build a complete list of patients. - . S DFN=0 - . F S DFN=$O(^TMP($J,LNAME(IND),1,DFN)) Q:DFN="" S ^TMP($J,"PXRMFFDFN",DFN)="" - ;Evaluate the function finding for each patient. If the function - ;finding is true then add the patient to PLIST. - S DFN=0 - F S DFN=$O(^TMP($J,"PXRMFFDFN",DFN)) Q:DFN="" D - . K FIEVAL - . S IND="" - . F S IND=$O(UNIQFIL(IND)) Q:IND="" D - .. S FIEVAL(IND)=0 - .. S ITEM="" - .. F S ITEM=$O(^TMP($J,LNAME(IND),1,DFN,ITEM)) Q:ITEM="" D - ... S COUNT=0 - ... F S COUNT=$O(^TMP($J,LNAME(IND),1,DFN,ITEM,COUNT)) Q:COUNT="" D - .... S FILENUM=$O(^TMP($J,LNAME(IND),1,DFN,ITEM,COUNT,"")) - .... S TEMP=^TMP($J,LNAME(IND),1,DFN,ITEM,COUNT,FILENUM) - .... S DAS=$P(TEMP,U,1) - .... S DATE=$P(TEMP,U,2) - .... K FIEVT - .... D GETDATA^PXRMDATA(FILENUM,DAS,.FIEVT) - .... M FIEVAL(IND,COUNT)=FIEVT - .... S FIEVAL(IND,COUNT,"DATE")=DATE,FIEVAL(IND,COUNT)=1 - .;Save the top level results for each finding. - . S IND=0 - . F S IND=$O(FIEVAL(IND)) Q:IND="" D - .. K FIEVT M FIEVT=FIEVAL(IND) - .. S NFI=+$O(FIEVT(""),-1) - .. D SFRES^PXRMUTIL(-1,NFI,.FIEVT) - .. K FIEVAL(IND) M FIEVAL(IND)=FIEVT - .;Evaluate the function finding for this patient. - . K FN - . F IND=1:1:NFUN D - .. K FIL M FIL=FILIST(IND) - .. D @ROUTINE(IND) - .. S FN(IND)=FVALUE - . I @LOGIC S ^TMP($J,PLIST,1,DFN,1,FFIND)="" - ;Clean up. - K ^TMP($J,"PXRMFFDFN") - S IND="" - F S IND=$O(UNIQFIL(IND)) Q:IND="" K ^TMP($J,LNAME(IND)) - Q - ; - ;=========================================== -MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output. - ;None currently defined. - Q - ; - ;=========================================== -OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical - ;maintenance output. None currently defined. - Q - ; +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. + N FFIND,FFN,FILIST,FN,FUN,FUNIND,FUNN,FVALUE,JND + N LOGIC,NL,ROUTINE,TEMP + I '$D(DEFARR(25)) Q + S FFN="FF" + F S FFN=$O(DEFARR(25,FFN)) Q:FFN'["FF" D + . K FN + . S FUNIND=0 + . F S FUNIND=+$O(DEFARR(25,FFN,5,FUNIND)) Q:FUNIND=0 D + .. S FUNN=$P(DEFARR(25,FFN,5,FUNIND,0),U,1) + .. S FUN=$P(DEFARR(25,FFN,5,FUNIND,0),U,2) + .. S TEMP=^PXRMD(802.4,FUN,0) + .. S ROUTINE=$P(TEMP,U,2,3)_"(.FILIST,.FIEVAL,.FVALUE)" + .. K FILIST + .. S (JND,NL)=0 + .. F S JND=+$O(DEFARR(25,FFN,5,FUNIND,20,JND)) Q:JND=0 D + ... S NL=NL+1 + ... S FILIST(NL)=DEFARR(25,FFN,5,FUNIND,20,JND,0) + .. S FILIST(0)=NL + .. D @ROUTINE + .. S FN(FUNIND)=FVALUE + . S LOGIC=$G(DEFARR(25,FFN,10)) + . S LOGIC=$S(LOGIC'="":LOGIC,1:0) + . I @LOGIC + . S FIEVAL(FFN)=$T + . S FIEVAL(FFN,"NUMBER")=$P(FFN,"FF",2) + . S FIEVAL(FFN,"FINDING")=$G(FUN)_";PXRMD(802.4," + Q + ; + ;=========================================== +EVALPL(DEFARR,FFIND,PLIST) ;Build a list of patients based on a function + ;finding. + N COUNT,DAS,DATE,DFN + N FI,FIEVAL,FIEVT,FIL,FILIST,FILENUM,FINDPA,FN + N FUN,FUNNM,FUNN,FUNNUM,FVALUE + N IND,ITEM,JND,LOGIC,LNAME,NFI,NFUN,ROUTINE,TEMP,TERMARR,UNIQFIL + S LOGIC=DEFARR(25,FFIND,10) + I LOGIC="" Q + ;Build the list of functions and findings used by the function finding. + S (FUNNUM,NFUN)=0 + F S FUNNUM=+$O(DEFARR(25,FFIND,5,FUNNUM)) Q:FUNNUM=0 D + . S NFUN=NFUN+1 + . S FUNN=$P(DEFARR(25,FFIND,5,FUNNUM,0),U,1) + . S FUN=$P(DEFARR(25,FFIND,5,FUNNUM,0),U,2) + . S TEMP=^PXRMD(802.4,FUN,0) + . S ROUTINE(NFUN)=$P(TEMP,U,2,3)_"(.FIL,.FIEVAL,.FVALUE)" + . S (FI,NFI)=0 + . F S FI=+$O(DEFARR(25,FFIND,5,FUNNUM,20,FI)) Q:FI=0 D + .. S NFI=NFI+1,FILIST(NFUN,NFI)=DEFARR(25,FFIND,5,FUNNUM,20,FI,0) + . S FILIST(NFUN,0)=NFI + ;A finding may be used in more than one function in the function + ;finding so build a list of the unique findings. + F IND=1:1:NFUN D + . F JND=1:1:FILIST(IND,0) D + .. S TEMP=$P(DEFARR(20,FILIST(IND,JND),0),U,1) + .. S ITEM=$P(TEMP,";",1) + .. S FILENUM=$$GETFNUM^PXRMDATA($P(TEMP,";",2)) + .. S UNIQFIL(FILIST(IND,JND))="" + K ^TMP($J,"PXRMFFDFN") + S IND=0 + F S IND=$O(UNIQFIL(IND)) Q:IND="" D + . S FINDPA(0)=DEFARR(20,IND,0) + . S FINDPA(3)=DEFARR(20,IND,3) + . S FINDPA(10)=DEFARR(20,IND,10) + . S FINDPA(11)=DEFARR(20,IND,11) + . D GENTERM^PXRMPLST(FINDPA(0),IND,.TERMARR) + . S LNAME(IND)="PXRMFF"_IND + . K ^TMP($J,LNAME(IND)) + . D EVALPL^PXRMTERM(.FINDPA,.TERMARR,LNAME(IND)) + .;Get rid of the false part of the list. + . K ^TMP($J,LNAME(IND),0) + .;Build a complete list of patients. + . S DFN=0 + . F S DFN=$O(^TMP($J,LNAME(IND),1,DFN)) Q:DFN="" S ^TMP($J,"PXRMFFDFN",DFN)="" + ;Evaluate the function finding for each patient. If the function + ;finding is true then add the patient to PLIST. + S DFN=0 + F S DFN=$O(^TMP($J,"PXRMFFDFN",DFN)) Q:DFN="" D + . K FIEVAL + . S IND="" + . F S IND=$O(UNIQFIL(IND)) Q:IND="" D + .. S FIEVAL(IND)=0 + .. S ITEM="" + .. F S ITEM=$O(^TMP($J,LNAME(IND),1,DFN,ITEM)) Q:ITEM="" D + ... S COUNT=0 + ... F S COUNT=$O(^TMP($J,LNAME(IND),1,DFN,ITEM,COUNT)) Q:COUNT="" D + .... S FILENUM=$O(^TMP($J,LNAME(IND),1,DFN,ITEM,COUNT,"")) + .... S TEMP=^TMP($J,LNAME(IND),1,DFN,ITEM,COUNT,FILENUM) + .... S DAS=$P(TEMP,U,1) + .... S DATE=$P(TEMP,U,2) + .... K FIEVT + .... D GETDATA^PXRMDATA(FILENUM,DAS,.FIEVT) + .... M FIEVAL(IND,COUNT)=FIEVT + .... S FIEVAL(IND,COUNT,"DATE")=DATE,FIEVAL(IND,COUNT)=1 + .;Save the top level results for each finding. + . S IND=0 + . F S IND=$O(FIEVAL(IND)) Q:IND="" D + .. K FIEVT M FIEVT=FIEVAL(IND) + .. S NFI=+$O(FIEVT(""),-1) + .. D SFRES^PXRMUTIL(-1,NFI,.FIEVT) + .. K FIEVAL(IND) M FIEVAL(IND)=FIEVT + .;Evaluate the function finding for this patient. + . K FN + . F IND=1:1:NFUN D + .. K FIL M FIL=FILIST(IND) + .. D @ROUTINE(IND) + .. S FN(IND)=FVALUE + . I @LOGIC S ^TMP($J,PLIST,1,DFN,1,FFIND)="" + ;Clean up. + K ^TMP($J,"PXRMFFDFN") + S IND="" + F S IND=$O(UNIQFIL(IND)) Q:IND="" K ^TMP($J,LNAME(IND)) + Q + ; + ;=========================================== +MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output. + ;None currently defined. + Q + ; + ;=========================================== +OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical + ;maintenance output. None currently defined. + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMFF0.m b/r/CLINICAL_REMINDERS-PXRM/PXRMFF0.m index 019b71ed..fe4c6183 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMFF0.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMFF0.m @@ -1,108 +1,88 @@ -PXRMFF0 ;SLC/PKR - Clinical Reminders function finding routines. ;09/11/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ;============================================ -COUNT(LIST,FIEVAL,COUNT) ; - N IND,JND,KND - S COUNT=0 - F IND=1:1:LIST(0) D - . S JND=LIST(IND),KND=0 - . F S KND=+$O(FIEVAL(JND,KND)) Q:KND=0 D - .. I FIEVAL(JND,KND) S COUNT=COUNT+1 - Q - ; - ;=========================================== -DIFFDATE(LIST,FIEVAL,DIFF) ;Return the difference in days between the - ;first two findings in the list. - I LIST(0)<2 S DIFF=2 Q - N DATE1,DATE2,DAYS,IND,JND - S DATE1=+$G(FIEVAL(LIST(1),"DATE")) - S DATE2=+$G(FIEVAL(LIST(2),"DATE")) - S DAYS=$$FMDIFF^XLFDT(DATE1,DATE2) - S DIFF=$S(DAYS<0:-DAYS,1:DAYS) - Q - ; - ;=========================================== -DUR(LIST,FIEVAL,DUR) ; - N EDT,IND,JND,KND,SDT - F IND=1:1:LIST(0) D - . S JND=LIST(IND) - . I FIEVAL(JND)=0 S (EDT,SDT)=0 Q - .;Check for finding with start and stop date. - . I $D(FIEVAL(JND,"START DATE")) D - .. S SDT=+$G(FIEVAL(JND,"START DATE")) - .. S EDT=+$G(FIEVAL(JND,"STOP DATE")) - .. I EDT=0 S EDT=+$G(FIEVAL(JND,"DATE")) - . E D - ..;Get start and stop for multiple occurrences. - .. S KND=$O(FIEVAL(JND,"A"),-1) - .. S EDT=$S(KND="":0,1:$G(FIEVAL(JND,KND,"DATE"))) - .. S KND=+$O(FIEVAL(JND,"")) - .. S SDT=$S(KND=0:0,1:$G(FIEVAL(JND,KND,"DATE"))) - ;Return the duration in days. - S DUR=$$FMDIFF^XLFDT(EDT,SDT) - I DUR<0 S DUR=-DUR - Q - ; - ;============================================ -FI(LIST,FIEVAL,LV) ;Given a regular finding return its true/false value. - S LV=FIEVAL(LIST(1)) - Q - ; - ;============================================ -MAXDATE(LIST,FIEVAL,MAXDATE) ;Given a list of findings return the maximum - ;date. This will be the newest date. - N DATE,IND - S MAXDATE=0 - F IND=1:1:LIST(0) D - . S DATE=$G(FIEVAL(LIST(IND),"DATE")) - . I DATE>MAXDATE S MAXDATE=DATE - Q - ; - ;============================================ -MINDATE(LIST,FIEVAL,MINDATE) ;Given a list of findings return the minimum - ;date. This will be the oldest non-null or zero date. - N DATE,IND - S MINDATE=9991231 - F IND=1:1:LIST(0) D - . S DATE=$G(FIEVAL(LIST(IND),"DATE")) - . I DATEMRD S MRD=DATE - Q - ; - ;============================================ -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. - S VALUE=$G(FIEVAL(LIST(1),LIST(2),LIST(3))) - Q - ; +PXRMFF0 ;SLC/PKR - Clinical Reminders function finding routines. ;06/23/2006 + ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21 + ; + ;============================================ +COUNT(LIST,FIEVAL,COUNT) ; + N IND,JND,KND + S COUNT=0 + F IND=1:1:LIST(0) D + . S JND=LIST(IND),KND=0 + . F S KND=+$O(FIEVAL(JND,KND)) Q:KND=0 D + .. I FIEVAL(JND,KND) S COUNT=COUNT+1 + Q + ; + ;=========================================== +DIFFDATE(LIST,FIEVAL,DIFF) ;Return the difference in days between the + ;first two findings in the list. + I LIST(0)<2 S DIFF=2 Q + N DATE1,DATE2,DAYS,IND,JND + S DATE1=+$G(FIEVAL(LIST(1),"DATE")) + S DATE2=+$G(FIEVAL(LIST(2),"DATE")) + S DAYS=$$FMDIFF^XLFDT(DATE1,DATE2) + S DIFF=$S(DAYS<0:-DAYS,1:DAYS) + Q + ; + ;=========================================== +DUR(LIST,FIEVAL,DUR) ; + N EDT,IND,JND,KND,SDT + F IND=1:1:LIST(0) D + . S JND=LIST(IND) + . I FIEVAL(JND)=0 S (EDT,SDT)=0 Q + .;Check for finding with start and stop date. + . I $D(FIEVAL(JND,"START DATE")) D + .. S SDT=+$G(FIEVAL(JND,"START DATE")) + .. S EDT=+$G(FIEVAL(JND,"STOP DATE")) + .. I EDT=0 S EDT=+$G(FIEVAL(JND,"DATE")) + . E D + ..;Get start and stop for multiple occurrences. + .. S KND=$O(FIEVAL(JND,"A"),-1) + .. S EDT=$S(KND="":0,1:$G(FIEVAL(JND,KND,"DATE"))) + .. S KND=+$O(FIEVAL(JND,"")) + .. S SDT=$S(KND=0:0,1:$G(FIEVAL(JND,KND,"DATE"))) + ;Return the duration in days. + S DUR=$$FMDIFF^XLFDT(EDT,SDT) + I DUR<0 S DUR=-DUR + Q + ; + ;============================================ +FI(LIST,FIEVAL,LV) ;Given a regular finding return its true/false value. + S LV=FIEVAL(LIST(1)) + Q + ; + ;============================================ +MAXDATE(LIST,FIEVAL,MAXDATE) ;Given a list of findings return the maximum + ;date. This will be the newest date. + N DATE,IND + S MAXDATE=0 + F IND=1:1:LIST(0) D + . S DATE=$G(FIEVAL(LIST(IND),"DATE")) + . I DATE>MAXDATE S MAXDATE=DATE + Q + ; + ;============================================ +MINDATE(LIST,FIEVAL,MINDATE) ;Given a list of findings return the minimum + ;date. This will be the oldest non-null or zero date. + N DATE,IND + S MINDATE=9991231 + F IND=1:1:LIST(0) D + . S DATE=$G(FIEVAL(LIST(IND),"DATE")) + . I DATEMRD S MRD=DATE + Q + ; + ;============================================ +VALUE(LIST,FIEVAL,VALUE) ;Given a finding return one of its "CSUB" + ;values. + S VALUE=$G(FIEVAL(LIST(1),LIST(2),LIST(3))) + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMFFAT.m b/r/CLINICAL_REMINDERS-PXRM/PXRMFFAT.m index fcefffc9..26e7f0b0 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMFFAT.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMFFAT.m @@ -1,56 +1,52 @@ -PXRMFFAT ;SLC/PKR - Function Finding argument type routines. ;09/11/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ;============================================ -ARGTYPE(FUNCTION,AN) ;Given a FUNCTION and argument number return the - ;corresponding argument type. Possible argument types are: - ; F - finding - ; N - number - ; S - string - ; U - undefined - N ROUTINE - ;The routine for any function is the same as the name of the - ;function except for functions with "_" in the name. In that - ;case the "_" is removed. - S ROUTINE="$$"_$TR(FUNCTION,"_","")_"(AN)" - Q @ROUTINE - ; - ;============================================ -COUNT(AN) ; - Q $S(AN=1:"F",1:"U") - ; - ;=========================================== -DIFFDATE(AN) ; - Q $S(AN=1:"F",AN=2:"F",1:"U") - ; - ;=========================================== -DUR(AN) ; - Q $S(AN=1:"F",1:"U") - ; - ;============================================ -FI(AN) ; - Q $S(AN=1:"F",1:"U") - ; - ;============================================ -MAXDATE(AN) ; - I AN>0,AN<100 Q "F" - E Q "U" - ; - ;============================================ -MINDATE(AN) ; - I AN>0,AN<100 Q "F" - E Q "U" - ; - ;============================================ -MRD(AN) ; - I AN>0,AN<100 Q "F" - E Q "U" - ; - ;============================================ -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") - ; +PXRMFFAT ;SLC/PKR - Function Finding argument type routines. ;08/03/2006 + ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21 + ; + ;============================================ +ARGTYPE(FUNCTION,AN) ;Given a FUNCTION and argument number return the + ;corresponding argument type. Possible argument types are: + ; F - finding + ; N - number + ; S - string + ; U - undefined + N ROUTINE + ;The routine for any function is the same as the name of the + ;function except for functions with "_" in the name. In that + ;case the "_" is removed. + S ROUTINE="$$"_$TR(FUNCTION,"_","")_"(AN)" + Q @ROUTINE + ; + ;============================================ +COUNT(AN) ; + Q $S(AN=1:"F",1:"U") + ; + ;=========================================== +DIFFDATE(AN) ; + Q $S(AN=1:"F",AN=2:"F",1:"U") + ; + ;=========================================== +DUR(AN) ; + Q $S(AN=1:"F",1:"U") + ; + ;============================================ +FI(AN) ; + Q $S(AN=1:"F",1:"U") + ; + ;============================================ +MAXDATE(AN) ; + I AN>0,AN<100 Q "F" + E Q "U" + ; + ;============================================ +MINDATE(AN) ; + I AN>0,AN<100 Q "F" + E Q "U" + ; + ;============================================ +MRD(AN) ; + I AN>0,AN<100 Q "F" + E Q "U" + ; + ;============================================ +VALUE(AN) ; + Q $S(AN=1:"F",AN=2:"N",AN=3:"S",1:"U") + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMFFDB.m b/r/CLINICAL_REMINDERS-PXRM/PXRMFFDB.m index 498e1353..b30fe941 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMFFDB.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMFFDB.m @@ -1,258 +1,255 @@ -PXRMFFDB ;SLC/PKR - Function finding data structure builder. ;10/31/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ;=========================================== -BASE2(NUM) ;Convert a base 10 integer to base 2. - N BD,BIN - S BIN="" - F Q:NUM=0 D - . S BD=$S((NUM\2)=(NUM/2):0,1:1) - . S BIN=BD_BIN,NUM=NUM\2 - Q BIN - ; - ;=========================================== -CRESLOG(NUM,FLIST,RESLOG) ;Check the resolution logic to see if - ;it can be made true solely by function findings. If that is the case - ;warn the user. Called by BLDRESLS^PXRMLOGX - N AGEFI,BP,FI,FF,FFL,IND,JND,KND,LE,LEN,LND,NFF,NTC,SEXFI,TEMP,VALUE - S (AGEFI,SEXFI)=0 - S NFF=0 - F IND=1:1:NUM D - . S JND=$P(FLIST,";",IND) - . I +JND=JND S FI(JND)=0 Q - . I JND["FF" S NFF=NFF+1,FF=$P(JND,"FF",2),FFL(NFF)=FF - I NFF=0 Q - ;Generate and test all combinations of true and false FFs. - S VALUE=0 - S NTC=$$PWR^XLFMTH(2,NFF)-1 - F IND=1:1:NTC Q:VALUE D - . S BIN=$$BASE2(IND) - . S LEN=$L(BIN) - . S LE=NFF-LEN - .;Fill in the values for the implied preceeding 0s. - . F JND=1:1:LE S KND=FFL(JND),FF(KND)=0 - . S LND=0 - . F JND=LE+1:1:NFF D - .. S KND=FFL(JND),LND=LND+1 - .. S FF(KND)=$E(BIN,LND) - . I @RESLOG - . S VALUE=$T - I VALUE D - . N RESLSTR - . S RESLSTR=RESLOG - . F IND=1:1:NUM D - .. S JND=$P(FLIST,";",IND) - .. S TEMP=$S(JND["FF":"FF("_$P(JND,"FF",2)_")",1:"FI("_JND_")") - .. S RESLOG=$$STRREP^PXRMUTIL(RESLOG,TEMP,@TEMP) - . S RESLOG=$$STRREP^PXRMUTIL(RESLOG,"AGE",AGEFI) - . S RESLOG=$$STRREP^PXRMUTIL(RESLOG,"SEX",SEXFI) - . W !!,"Warning - your resolution logic can be satisfied by function findings only." - . W !,"If this happens it will not be possible to calculate a resolution date and" - . W !,"the reminder will not be resolved. Here is a case where the logic evaluates" - . W !,"to true:" - . W !,RESLSTR - . W !,RESLOG - . W ! - Q - ; - ;============================================================= -FFBUILD(X,DA) ;Given a function finding logical string build the data - ;structure. This is called by a new-style cross-reference after - ;the function string has passed the input transform so we don't need - ;to validate the elements. - ;Do not execute as part of a verify fields. - I $G(DIUTIL)="VERIFY FIELDS" Q - ;Do not execute as part of exchange. - I $G(PXRMEXCH) Q - N FDA,FUNNUM,FUNP,IENB,IENS,IND,JND,L2,L3,LEN,LIST,LOGIC,OPER,MSG - N PFSTACK,REPL,RS,TEMP,TS,XS - S IENB=DA_","_DA(1)_"," - S OPER="!&-+<>='" - S XS=$$PSPACE(X) - D POSTFIX^PXRMSTAC(XS,OPER,.PFSTACK) - S (FUNNUM,L2)=0 - F IND=1:1:PFSTACK(0) D - . S TEMP=PFSTACK(IND) - . I $D(^PXRMD(802.4,"B",TEMP)) D - .. S FUNP=$O(^PXRMD(802.4,"B",TEMP,"")) - .. S FUNNUM=FUNNUM+1,L2=L2+1 - .. S IENS="+"_L2_","_IENB - .. S FDA(811.9255,IENS,.01)=FUNNUM - .. S FDA(811.9255,IENS,.02)=FUNP - .. S IND=IND+1 - .. S LIST=$TR(PFSTACK(IND),"~"," ") - .. S REPL(FUNNUM)=TEMP_"("_LIST_")"_U_"FN("_FUNNUM_")" - .. S L3=L2 - .. S LEN=$L(LIST,",") - .. F JND=1:1:LEN D - ... S L3=L3+1 - ... S IENS="+"_L3_",+"_L2_","_IENB - ... S TS=$P(LIST,",",JND) - ... S TS=$TR(TS,"""","") - ... S FDA(811.9256,IENS,.01)=TS - .. S L2=L3 - ;Build the logic string - S LOGIC=X - F IND=1:1:FUNNUM D - . S TS=$P(REPL(IND),U,1) - . S RS=$P(REPL(IND),U,2) - . S LOGIC=$$STRREP^PXRMUTIL(LOGIC,TS,RS) - S FDA(811.925,IENB,10)=LOGIC - D UPDATE^DIE("","FDA","IENB","MSG") - I $D(MSG) D - . W !,"The update failed, UPDATE^DIE returned the following error message:" - . D AWRITE^PXRMUTIL("MSG") - Q - ; - ;============================================================= -FFKILL(X,DA) ;This is the kill logic for the function string. - ;Do not execute as part of a verify fields. - I $G(DIUTIL)="VERIFY FIELDS" Q - ;Do not execute as part of exchange. - I $G(PXRMEXCH) Q - K ^PXD(811.9,DA(1),25,DA,5),^PXD(811.9,DA(1),25,DA,10) - Q - ; - ;============================================================= -ISGRV(VAR) ;Return true if VAR is a global reminder variable. - I VAR="PXRMAGE" Q 1 - I VAR="PXRMDOB" Q 1 - I VAR="PXRMLAD" Q 1 - I VAR="PXRMSEX" Q 1 - Q 0 - ; - ;============================================================= -ISSTR(STRING) ;Return true if STRING really is a string and it is not - ;executable Mumps code. - N VALID,X - S VALID=0 - ;Valid strings are "text" or because of $P ,"text" or ",U". - I $E(STRING,1)="""",$E(STRING,$L(STRING))="""" S VALID=1 - I 'VALID,$E(STRING,1)=",",$E(STRING,2)="""",$E(STRING,$L(STRING))="""" S VALID=1 - I 'VALID,STRING=",U" S VALID=1 - I 'VALID Q VALID - S X=STRING - D ^DIM - S VALID=$S($D(X)=0:1,1:0) - Q VALID - ; - ;============================================================= -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) - Q OPR - ; - ;============================================================= -VFFORM(TEMP,X) ;Make sure the function has a valid form, i.e., function - ;followed by an argument list. - N DONE,LP,RP,START,VALID - S DONE=0,VALID=1,START=0 - F Q:DONE D - . S START=$F(X,TEMP,START) - . I START=0 S DONE=1 Q - . S LP=$E(X,START) - . I LP'="(" S VALID=0,DONE=1 Q - . S START=$F(X,")",START) - . S RP=$E(X,START-1) - . I RP'=")" S VALID=0 - I 'VALID D - . N TEXT - . S TEXT="Function "_TEMP_" must be followed by an argument list!" - . D EN^DDIOL(.TEXT) - Q VALID - ; - ;============================================================= -VFINDING(X,DAI) ;Make sure a finding number is a valid member of the - ;definition finding multiple. Input transform for function - ;finding finding number. - ;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 - I '$D(DAI) Q 1 - ;If X is not numeric it is not a finding number. - I +X'=X Q 1 - I $D(^PXD(811.9,DAI,20,X,0)) Q 1 - E D Q 0 - . N TEXT - . S TEXT="Finding number "_X_" does not exist!" - . D EN^DDIOL(TEXT) - ; - ;============================================================= -VFSTRING(FFSTRING,DA) ;Make sure a function finding string is valid. - ;The elements can be functions, operators, and numbers. - ;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 - I '$D(DA) Q 1 - N DAI,DATE,FUNIEN,IND,LIST,MFUN,OPER,PFSTACK,TEMP,TEXT,VALID - S DAI=DA(1) - S OPER="!&-+<>='" - ;Define the allowed M functions. - S MFUN("$P")="" - D POSTFIX^PXRMSTAC(FFSTRING,OPER,.PFSTACK) - S VALID=1 - F IND=1:1:PFSTACK(0) Q:'VALID D - . S TEMP=PFSTACK(IND) - . I $D(^PXRMD(802.4,"B",TEMP)) D Q - .. S VALID=$$VFFORM(TEMP,X) - .. I 'VALID Q - .. S FUNIEN=$O(^PXRMD(802.4,"B",TEMP,"")) - .. S IND=IND+1 - .. S LIST=$G(PFSTACK(IND)) - .. S VALID=$$VLIST(LIST,DAI,TEMP,FUNIEN) - .;Check for operator - . I OPER[TEMP Q - .;Check for number - . I TEMP=+TEMP Q - .;Check for allowed M function. - . I $D(MFUN(TEMP)) Q - .;Check for a global reminder variable - . I $$ISGRV(TEMP) Q - .;Check for a non-executable string. - . I $$ISSTR(TEMP) Q - . S VALID=0 - . S TEXT=TEMP_" is not a valid Function Finding element!" - . D EN^DDIOL(TEXT) - I VALID D - . N X - . S X="I "_FFSTRING - . D ^DIM - . I $D(X)=0 S VALID=0 - I 'VALID D - . S TEMP=FFSTRING_" is not a valid function string" - . D EN^DDIOL(TEMP) - Q VALID - ; - ;============================================================= -VLIST(LIST,DAI,FUNCTION,FUNIEN) ;Make sure the function argument list - ;is valid. - N AT,IND,LEN,PATTERN,VALID,X - S LEN=$L(LIST,",") - I LEN=0 D Q 0 - . N TEXT - . S TEXT="The argument list is not defined!" - . D EN^DDIOL(TEXT) - S PATTERN=$P(^PXRMD(802.4,FUNIEN,0),U,5) - S VALID=$S(LIST?@PATTERN:1,1:0) - I 'VALID D Q 0 - . N TEXT - . S TEXT="Argument list "_LIST_" is not correct for function "_$P(^PXRMD(802.4,FUNIEN,0),U,1) - . D EN^DDIOL(TEXT) - F IND=1:1:LEN D - . S X=$P(LIST,",",IND) - . S AT=$$ARGTYPE^PXRMFFAT(FUNCTION,IND) - . I AT="U" S VALID=0 Q - . I AT="F",'$$VFINDING(X,DAI) S VALID=0 - Q VALID - ; +PXRMFFDB ;SLC/PKR - Function finding data structure builder. ;06/22/2006 + ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21 + ; + ;=========================================== +BASE2(NUM) ;Convert a base 10 integer to base 2. + N BD,BIN + S BIN="" + F Q:NUM=0 D + . S BD=$S((NUM\2)=(NUM/2):0,1:1) + . S BIN=BD_BIN,NUM=NUM\2 + Q BIN + ; + ;=========================================== +CRESLOG(NUM,FLIST,RESLOG) ;Check the resolution logic to see if + ;it can be made true solely by function findings. If that is the case + ;warn the user. Called by BLDRESLS^PXRMLOGX + N AGEFI,BP,FI,FF,FFL,IND,JND,KND,LE,LEN,LND,NFF,NTC,SEXFI,TEMP,VALUE + S (AGEFI,SEXFI)=0 + S NFF=0 + F IND=1:1:NUM D + . S JND=$P(FLIST,";",IND) + . I +JND=JND S FI(JND)=0 Q + . I JND["FF" S NFF=NFF+1,FF=$P(JND,"FF",2),FFL(NFF)=FF + I NFF=0 Q + ;Generate and test all combinations of true and false FFs. + S VALUE=0 + S NTC=$$PWR^XLFMTH(2,NFF)-1 + F IND=1:1:NTC Q:VALUE D + . S BIN=$$BASE2(IND) + . S LEN=$L(BIN) + . S LE=NFF-LEN + .;Fill in the values for the implied preceeding 0s. + . F JND=1:1:LE S KND=FFL(JND),FF(KND)=0 + . S LND=0 + . F JND=LE+1:1:NFF D + .. S KND=FFL(JND),LND=LND+1 + .. S FF(KND)=$E(BIN,LND) + . I @RESLOG + . S VALUE=$T + I VALUE D + . N RESLSTR + . S RESLSTR=RESLOG + . F IND=1:1:NUM D + .. S JND=$P(FLIST,";",IND) + .. S TEMP=$S(JND["FF":"FF("_$P(JND,"FF",2)_")",1:"FI("_JND_")") + .. S RESLOG=$$STRREP^PXRMUTIL(RESLOG,TEMP,@TEMP) + . S RESLOG=$$STRREP^PXRMUTIL(RESLOG,"AGE",AGEFI) + . S RESLOG=$$STRREP^PXRMUTIL(RESLOG,"SEX",SEXFI) + . W !!,"Warning - your resolution logic can be satisfied by function findings only." + . W !,"If this happens it will not be possible to calculate a resolution date and" + . W !,"the reminder will not be resolved. Here is a case where the logic evaluates" + . W !,"to true:" + . W !,RESLSTR + . W !,RESLOG + . W ! + Q + ; + ;============================================================= +FFBUILD(X,DA) ;Given a function finding logical string build the data + ;structure. This is called by a new-style cross-reference after + ;the function string has passed the input transform so we don't need + ;to validate the elements. + ;Do not execute as part of a verify fields. + I $G(DIUTIL)="VERIFY FIELDS" Q + ;Do not execute as part of exchange. + I $G(PXRMEXCH) Q + N FDA,FUNNUM,FUNP,IENB,IENS,IND,JND,L2,L3,LEN,LIST,LOGIC,OPER,MSG + N PFSTACK,REPL,RS,TEMP,TS,XS + S IENB=DA_","_DA(1)_"," + S OPER="!&<>='" + S XS=$$PSPACE(X) + D POSTFIX^PXRMSTAC(XS,OPER,.PFSTACK) + S (FUNNUM,L2)=0 + F IND=1:1:PFSTACK(0) D + . S TEMP=PFSTACK(IND) + . I $D(^PXRMD(802.4,"B",TEMP)) D + .. S FUNP=$O(^PXRMD(802.4,"B",TEMP,"")) + .. S FUNNUM=FUNNUM+1,L2=L2+1 + .. S IENS="+"_L2_","_IENB + .. S FDA(811.9255,IENS,.01)=FUNNUM + .. S FDA(811.9255,IENS,.02)=FUNP + .. S IND=IND+1 + .. S LIST=$TR(PFSTACK(IND),"~"," ") + .. S REPL(FUNNUM)=TEMP_"("_LIST_")"_U_"FN("_FUNNUM_")" + .. S L3=L2 + .. S LEN=$L(LIST,",") + .. F JND=1:1:LEN D + ... S L3=L3+1 + ... S IENS="+"_L3_",+"_L2_","_IENB + ... S TS=$P(LIST,",",JND) + ... S TS=$TR(TS,"""","") + ... S FDA(811.9256,IENS,.01)=TS + .. S L2=L3 + ;Build the logic string + S LOGIC=X + F IND=1:1:FUNNUM D + . S TS=$P(REPL(IND),U,1) + . S RS=$P(REPL(IND),U,2) + . S LOGIC=$$STRREP^PXRMUTIL(LOGIC,TS,RS) + S FDA(811.925,IENB,10)=LOGIC + D UPDATE^DIE("","FDA","IENB","MSG") + I $D(MSG) D + . W !,"The update failed, UPDATE^DIE returned the following error message:" + . D AWRITE^PXRMUTIL("MSG") + Q + ; + ;============================================================= +FFKILL(X,DA) ;This is the kill logic for the function string. + ;Do not execute as part of a verify fields. + I $G(DIUTIL)="VERIFY FIELDS" Q + ;Do not execute as part of exchange. + I $G(PXRMEXCH) Q + K ^PXD(811.9,DA(1),25,DA,5),^PXD(811.9,DA(1),25,DA,10) + Q + ; + ;============================================================= +ISGRV(VAR) ;Return true if VAR is a global reminder variable. + I VAR="PXRMAGE" Q 1 + I VAR="PXRMDOB" Q 1 + I VAR="PXRMLAD" Q 1 + I VAR="PXRMSEX" Q 1 + Q 0 + ; + ;============================================================= +ISSTR(STRING) ;Return true if STRING really is a string and it is not + ;executable Mumps code. + N VALID,X + S VALID=0 + ;Valid strings are "text" or because of $P ,"text" or ",U". + I $E(STRING,1)="""",$E(STRING,$L(STRING))="""" S VALID=1 + I 'VALID,$E(STRING,1)=",",$E(STRING,2)="""",$E(STRING,$L(STRING))="""" S VALID=1 + I 'VALID,STRING=",U" S VALID=1 + I 'VALID Q VALID + S X=STRING + D ^DIM + S VALID=$S($D(X)=0:1,1:0) + Q VALID + ; + ;============================================================= +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. + 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 + ; + ;============================================================= +VFFORM(TEMP,X) ;Make sure the function has a valid form, i.e., function + ;followed by an argument list. + N DONE,LP,RP,START,VALID + S DONE=0,VALID=1,START=0 + F Q:DONE D + . S START=$F(X,TEMP,START) + . I START=0 S DONE=1 Q + . S LP=$E(X,START) + . I LP'="(" S VALID=0,DONE=1 Q + . S START=$F(X,")",START) + . S RP=$E(X,START-1) + . I RP'=")" S VALID=0 + I 'VALID D + . N TEXT + . S TEXT="Function "_TEMP_" must be followed by an argument list!" + . D EN^DDIOL(.TEXT) + Q VALID + ; + ;============================================================= +VFINDING(X,DAI) ;Make sure a finding number is a valid member of the + ;definition finding multiple. Input transform for function + ;finding finding number. + ;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 + I '$D(DAI) Q 1 + ;If X is not numeric it is not a finding number. + I +X'=X Q 1 + I $D(^PXD(811.9,DAI,20,X,0)) Q 1 + E D Q 0 + . N TEXT + . S TEXT="Finding number "_X_" does not exist!" + . D EN^DDIOL(TEXT) + ; + ;============================================================= +VFSTRING(FFSTRING,DA) ;Make sure a function finding string is valid. + ;The elements can be functions, operators, and numbers. + ;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 + I '$D(DA) Q 1 + N DAI,DATE,FUNIEN,IND,LIST,MFUN,OPER,PFSTACK,TEMP,TEXT,VALID + S DAI=DA(1) + S OPER="!&<>='" + ;Define the allowed M functions. + S MFUN("$P")="" + D POSTFIX^PXRMSTAC(FFSTRING,OPER,.PFSTACK) + S VALID=1 + F IND=1:1:PFSTACK(0) Q:'VALID D + . S TEMP=PFSTACK(IND) + . I $D(^PXRMD(802.4,"B",TEMP)) D Q + .. S VALID=$$VFFORM(TEMP,X) + .. I 'VALID Q + .. S FUNIEN=$O(^PXRMD(802.4,"B",TEMP,"")) + .. S IND=IND+1 + .. S LIST=$G(PFSTACK(IND)) + .. S VALID=$$VLIST(LIST,DAI,TEMP,FUNIEN) + .;Check for operator + . I OPER[TEMP Q + .;Check for number + . I TEMP=+TEMP Q + .;Check for allowed M function. + . I $D(MFUN(TEMP)) Q + .;Check for a global reminder variable + . I $$ISGRV(TEMP) Q + .;Check for a non-executable string. + . I $$ISSTR(TEMP) Q + . S VALID=0 + . S TEXT=TEMP_" is not a valid Function Finding element!" + . D EN^DDIOL(TEXT) + I VALID D + . N X + . S X="I "_FFSTRING + . D ^DIM + . I $D(X)=0 S VALID=0 + I 'VALID D + . S TEMP=FFSTRING_" is not a valid function string" + . D EN^DDIOL(TEMP) + Q VALID + ; + ;============================================================= +VLIST(LIST,DAI,FUNCTION,FUNIEN) ;Make sure the function argument list + ;is valid. + N AT,IND,LEN,PATTERN,VALID,X + S LEN=$L(LIST,",") + I LEN=0 D Q 0 + . N TEXT + . S TEXT="The argument list is not defined!" + . D EN^DDIOL(TEXT) + S PATTERN=$P(^PXRMD(802.4,FUNIEN,0),U,5) + S VALID=$S(LIST?@PATTERN:1,1:0) + I 'VALID D Q 0 + . N TEXT + . S TEXT="Argument list "_LIST_" is not correct for function "_$P(^PXRMD(802.4,FUNIEN,0),U,1) + . D EN^DDIOL(TEXT) + F IND=1:1:LEN D + . S X=$P(LIST,",",IND) + . S AT=$$ARGTYPE^PXRMFFAT(FUNCTION,IND) + . I AT="U" S VALID=0 Q + . I AT="F",'$$VFINDING(X,DAI) S VALID=0 + Q VALID + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMGECN.m b/r/CLINICAL_REMINDERS-PXRM/PXRMGECN.m index f7ff85f9..163cd3b1 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMGECN.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMGECN.m @@ -1,122 +1,122 @@ -PXRMGECN ;SLC/JVS GEC-Score Reports-cont'd ;06/01/2007 - ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123 - Q -SUM ;By Summary by Patient - N CAT,HF,DATE,DFN,Y,HFN,CNTREF,X,REFNUM,SUM,GSUM,CATDANA - N DATER,SDATE,SCNT - D E^PXRMGECV("HS1",1,BDT,EDT,"F",DFNONLY) - I FORMAT="D" S FOR=0 - I FORMAT="F" S FOR=1 - W @IOF - S CATDANA("GEC REFERRAL BASIC ADL")="" - S CATDANA("GEC REFERRAL IADL")="" - S CATDANA("GEC REFERRAL SKILLED CARE")="" - S CATDANA("GEC REFERRAL PATIENT BEHAVIORS/SYMPTOM")="" - ; - S Y=1,SUM=0,DATER=0,GSUM=0 - S DFN="" F S DFN=$O(^TMP("PXRMGEC",$J,"HS1",DFN)) Q:DFN=""!(Y=0) D - .S CNTREF="",REFNUM=0 F S CNTREF=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF)) Q:CNTREF=""!(Y=0) D - ..S REFNUM=REFNUM+1 - ..S SDATE=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF,0)) D - ...S DATER=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF,SDATE,0)) - ..S DATE=0 F S DATE=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF,DATE)) Q:DATE=""!(Y=0) D - ...S VDT=0 F S VDT=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF,DATE,VDT)) Q:VDT=""!(Y=0) D - ....S CAT=0 F S CAT=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF,DATE,VDT,CAT)) Q:CAT=""!(Y=0) D - .....Q:'$D(CATDANA(CAT)) - .....S SUM=0 - .....S DATEV=0 F S DATEV=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF,DATE,VDT,CAT,DATEV)) Q:DATEV=""!(Y=0) D - ......S DA=0 F S DA=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF,DATE,VDT,CAT,DATEV,DA)) Q:DA=""!(Y=0) D - .......S HFN=$$HFNAME^PXRMGECR(DA) - .......S SUM=SUM+$$VALUE($P($G(^AUPNVHF(DA,0)),"^",1)) - .......S CATSUM(CAT)=SUM - ..S GSUM=+$G(CATSUM("GEC REFERRAL IADL"))+(+$G(CATSUM("GEC REFERRAL BASIC ADL")))+(+$G(CATSUM("GEC REFERRAL SKILLED CARE")))+(+$G(CATSUM("GEC REFERRAL PATIENT BEHAVIORS/SYMPTOM"))) - ..S ^TMP("PXRMGEC",$J,"S",DFN,SDATE,DATER,+$G(CATSUM("GEC REFERRAL IADL")),+$G(CATSUM("GEC REFERRAL BASIC ADL")),+$G(CATSUM("GEC REFERRAL SKILLED CARE")),+$G(CATSUM("GEC REFERRAL PATIENT BEHAVIORS/SYMPTOM")),GSUM)="" - ..K CATSUM - ; -DIS ;Start of Display - S REF="^TMP(""PXRMGEC"",$J,""S"")" - W !,"==============================================================================" - W !,"GEC Patient-Summary (Score)" - W !,"Data on Complete Referrals Only" - W !,"From: "_$$FMTE^XLFDT(BDT,"5ZM")_" To: "_$$FMTE^XLFDT(EDT,"5ZM") - W ! - I FOR W !,?33,"Finished",?49,"Basic",?55,"Skilled",?63,"Patient",?73,"TOTAL" - I FOR W !,"Name",?22,"SSN",?33,"Date",?44,"IADL",?49,"ADL",?55,"Care",?63,"Behaviors",?73,"ACROSS" - I 'FOR W !,"Name^SSN^Referral Date^IADL^Basic ADL^Skilled Care^Behaviors^Totals" - W !,"==============================================================================" - N S1,S2,S3,S4,S5,S1T,S2T,S3T,S4T,S5T - S (S1T,S2T,S3T,S4T,S5T,CNT)=0 - S DFN="" F S DFN=$O(@REF@(DFN)) Q:DFN="" D - .S SDATE="" F S SDATE=$O(@REF@(DFN,SDATE)) Q:SDATE="" D - ..S DATER="" F S DATER=$O(@REF@(DFN,SDATE,DATER)) Q:DATER="" D - ...S CNT=CNT+1 - ...S S1="" F S S1=$O(@REF@(DFN,SDATE,DATER,S1)) Q:S1="" D - ....S S1T=S1T+S1 - ....S S2="" F S S2=$O(@REF@(DFN,SDATE,DATER,S1,S2)) Q:S2="" D - .....S S2T=S2T+S2 - .....S S3="" F S S3=$O(@REF@(DFN,SDATE,DATER,S1,S2,S3)) Q:S3="" D - ......S S3T=S3T+S3 - ......S S4="" F S S4=$O(@REF@(DFN,SDATE,DATER,S1,S2,S3,S4)) Q:S4="" D - .......S S4T=S4T+S4 - .......S S5="" F S S5=$O(@REF@(DFN,SDATE,DATER,S1,S2,S3,S4,S5)) Q:S5="" D - ........S S5T=S5T+S5 - ........I FOR W !,$E($P(DFN," ",1,$L(DFN," ")-1),1,19),?20," ("_$P(DFN," ",$L(DFN," "))_")",?33,$P($$FMTE^XLFDT(DATER,"5ZM"),"@",1),?44,$J(S1,3),?49,$J(S2,3),?55,$J(S3,3),?63,$J(S4,3),?73,$J(S5,3) - ........D PB Q:Y=0 - ........I 'FOR W !,$P(DFN," ",1,$L(DFN," ")-1),"^",$P(DFN," ",$L(DFN," ")),"^",$P($$FMTE^XLFDT(DATER,"5ZM"),"@",1),"^",S1,"^",S2,"^",S3,"^",S4,"^",S5 - Q:CNT=0 - I FOR W !,?44,"_________________________________" D PB Q:Y=0 - I FOR W !,?33,"Totals > >",?44,$J(S1T,3),?49,$J(S2T,3),?55,$J(S3T,3),?63,$J(S4T,3),?72,$J(S5T,4) D PB Q:Y=0 - I FOR W !,?34,"Means > >",?44,$J($FN(S1T/CNT,"",1),3),?49,$J($FN(S2T/CNT,"",1),3),?55,$J($FN(S3T/CNT,"",1),3),?63,$J($FN(S4T/CNT,"",1),3),?72,$J($FN(S5T/CNT,"",1),4) - D PB Q:Y=0 - S (S1T,S2T,S3T,S4T,S5T,SCNT)=0 - N S1TDEV,S1TDEVT,S2TDEV,S2TDEVT,S3TDEV,S3TDEVT,S4TDEV,S4TDEVT,S5TDEV,S5TDEVT - S (S1TDEVT,S2TDEVT,S3TDEVT,S4TDEVT,S5TDEVT)=0 - S DFN="" F S DFN=$O(@REF@(DFN)) Q:DFN="" D - .S SDATE="" F S SDATE=$O(@REF@(DFN,SDATE)) Q:SDATE="" D - ..S DATER="" F S DATER=$O(@REF@(DFN,SDATE,DATER)) Q:DATER="" D - ...S S1="" F S S1=$O(@REF@(DFN,SDATE,DATER,S1)) Q:S1="" D - ....S S1TDEV=(S1-(S1T/CNT))*(S1-(S1T/CNT)) S S1TDEVT=S1TDEVT+S1TDEV - ....S S2="" F S S2=$O(@REF@(DFN,SDATE,DATER,S1,S2)) Q:S2="" D - .....S S2TDEV=(S2-(S2T/CNT))*(S2-(S2T/CNT)) S S2TDEVT=S2TDEVT+S2TDEV - .....S S3="" F S S3=$O(@REF@(DFN,SDATE,DATER,S1,S2,S3)) Q:S3="" D - ......S S3TDEV=(S3-(S3T/CNT))*(S3-(S3T/CNT)) S S3TDEVT=S3TDEVT+S3TDEV - ......S S4="" F S S4=$O(@REF@(DFN,SDATE,DATER,S1,S2,S3,S4)) Q:S4="" D - .......S S4TDEV=(S4-(S4T/CNT))*(S4-(S4T/CNT)) S S4TDEVT=S4TDEVT+S4TDEV - .......S S5="" F S S5=$O(@REF@(DFN,SDATE,DATER,S1,S2,S3,S4,S5)) Q:S5="" D - ........S S5TDEV=(S5-(S5T/CNT))*(S5-(S5T/CNT)) S S5TDEVT=S5TDEVT+S5TDEV - I FOR W !,?20,"Standard Deviations > >" - I CNT<2 S CNT=CNT+1 - I FOR W ?44,$J($FN($$SQROOT(S1TDEVT/(CNT-1)),"",1),3),?49,$J($FN($$SQROOT(S2TDEVT/(CNT-1)),"",1),3),?55,$J($FN($$SQROOT(S3TDEVT/(CNT-1)),"",1),3),?63,$J($FN($$SQROOT(S4TDEVT/(CNT-1)),"",1),3),?72,$J($FN($$SQROOT(S5TDEVT/(CNT-1)),"",1),4) - D PB Q:Y=0 - W ! D PB Q:Y=0 - K ^TMP("PXRMGEC",$J) - D KILL^%ZISS - Q - ; -SQROOT(NUM) ;Calculat Square Root - N PREC,ROOT S ROOT=0 GOTO SQROOTX:NUM=0 - S:NUM<0 NUM=-NUM S ROOT=$S(NUM>1:NUM\1,1:1/NUM) - S ROOT=$E(ROOT,1,$L(ROOT)+1\2) S:NUM'>1 ROOT=1/ROOT - F PREC=1:1:6 S ROOT=NUM/ROOT+ROOT*.5 -SQROOTX Q ROOT - ; -VALUE(DA) ;Return value for score - N CAT,SYN,VALUE,PICE - S SYN=$P($G(^AUTTHF(DA,0)),"^",9) - Q:$E(SYN,5,5)'="F" VALUE - Q:SYN="" VALUE - Q:$E(SYN,5,5)="C" VALUE - S VALUE=$P(SYN," ",$L(SYN," ")) - Q VALUE - ; - ; -PB ;PAGE BREAK - S Y="" - I $Y=(IOSL-2) D - .K DIR - .S DIR(0)="E" - .D ^DIR - .I Y=1 W @IOF S $Y=0 - K DIR - Q - ; +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 + D E^PXRMGECV("HS1",1,BDT,EDT,"F",DFNONLY) + I FORMAT="D" S FOR=0 + I FORMAT="F" S FOR=1 + W @IOF + S CATDANA("GEC REFERRAL BASIC ADL")="" + S CATDANA("GEC REFERRAL IADL")="" + S CATDANA("GEC REFERRAL SKILLED CARE")="" + S CATDANA("GEC REFERRAL PATIENT BEHAVIORS/SYMPTOM")="" + ; + S Y=1,SUM=0,DATER=0,GSUM=0 + S DFN="" F S DFN=$O(^TMP("PXRMGEC",$J,"HS1",DFN)) Q:DFN=""!(Y=0) D + .S CNTREF="",REFNUM=0 F S CNTREF=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF)) Q:CNTREF=""!(Y=0) D + ..S REFNUM=REFNUM+1 + ..S SDATE=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF,0)) D + ...S DATER=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF,SDATE,0)) + ..S DATE=0 F S DATE=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF,DATE)) Q:DATE=""!(Y=0) D + ...S VDT=0 F S VDT=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF,DATE,VDT)) Q:VDT=""!(Y=0) D + ....S CAT=0 F S CAT=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF,DATE,VDT,CAT)) Q:CAT=""!(Y=0) D + .....Q:'$D(CATDANA(CAT)) + .....S SUM=0 + .....S DATEV=0 F S DATEV=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF,DATE,VDT,CAT,DATEV)) Q:DATEV=""!(Y=0) D + ......S DA=0 F S DA=$O(^TMP("PXRMGEC",$J,"HS1",DFN,CNTREF,DATE,VDT,CAT,DATEV,DA)) Q:DA=""!(Y=0) D + .......S HFN=$$HFNAME^PXRMGECR(DA) + .......S SUM=SUM+$$VALUE($P($G(^AUPNVHF(DA,0)),"^",1)) + .......S CATSUM(CAT)=SUM + ..S GSUM=+$G(CATSUM("GEC REFERRAL IADL"))+(+$G(CATSUM("GEC REFERRAL BASIC ADL")))+(+$G(CATSUM("GEC REFERRAL SKILLED CARE")))+(+$G(CATSUM("GEC REFERRAL PATIENT BEHAVIORS/SYMPTOM"))) + ..S ^TMP("PXRMGEC",$J,"S",DFN,SDATE,DATER,+$G(CATSUM("GEC REFERRAL IADL")),+$G(CATSUM("GEC REFERRAL BASIC ADL")),+$G(CATSUM("GEC REFERRAL SKILLED CARE")),+$G(CATSUM("GEC REFERRAL PATIENT BEHAVIORS/SYMPTOM")),GSUM)="" + ..K CATSUM + ; +DIS ;Start of Display + S REF="^TMP(""PXRMGEC"",$J,""S"")" + W !,"==============================================================================" + W !,"GEC Patient-Summary (Score)" + W !,"Data on Complete Referrals Only" + W !,"From: "_$$FMTE^XLFDT(BDT,"5ZM")_" To: "_$$FMTE^XLFDT(EDT,"5ZM") + W ! + I FOR W !,?33,"Finished",?49,"Basic",?55,"Skilled",?63,"Patient",?73,"TOTAL" + I FOR W !,"Name",?22,"SSN",?33,"Date",?44,"IADL",?49,"ADL",?55,"Care",?63,"Behaviors",?73,"ACROSS" + I 'FOR W !,"Name^SSN^Referral Date^IADL^Basic ADL^Skilled Care^Behaviors^Totals" + W !,"==============================================================================" + N S1,S2,S3,S4,S5,S1T,S2T,S3T,S4T,S5T + S (S1T,S2T,S3T,S4T,S5T,CNT)=0 + S DFN="" F S DFN=$O(@REF@(DFN)) Q:DFN="" D + .S SDATE="" F S SDATE=$O(@REF@(DFN,SDATE)) Q:SDATE="" D + ..S DATER="" F S DATER=$O(@REF@(DFN,SDATE,DATER)) Q:DATER="" D + ...S CNT=CNT+1 + ...S S1="" F S S1=$O(@REF@(DFN,SDATE,DATER,S1)) Q:S1="" D + ....S S1T=S1T+S1 + ....S S2="" F S S2=$O(@REF@(DFN,SDATE,DATER,S1,S2)) Q:S2="" D + .....S S2T=S2T+S2 + .....S S3="" F S S3=$O(@REF@(DFN,SDATE,DATER,S1,S2,S3)) Q:S3="" D + ......S S3T=S3T+S3 + ......S S4="" F S S4=$O(@REF@(DFN,SDATE,DATER,S1,S2,S3,S4)) Q:S4="" D + .......S S4T=S4T+S4 + .......S S5="" F S S5=$O(@REF@(DFN,SDATE,DATER,S1,S2,S3,S4,S5)) Q:S5="" D + ........S S5T=S5T+S5 + ........I FOR W !,$E($P(DFN," ",1,$L(DFN," ")-1),1,19),?20," ("_$P(DFN," ",$L(DFN," "))_")",?33,$P($$FMTE^XLFDT(DATER,"5ZM"),"@",1),?44,$J(S1,3),?49,$J(S2,3),?55,$J(S3,3),?63,$J(S4,3),?73,$J(S5,3) + ........D PB Q:Y=0 + ........I 'FOR W !,$P(DFN," ",1,$L(DFN," ")-1),"^",$P(DFN," ",$L(DFN," ")),"^",$P($$FMTE^XLFDT(DATER,"5ZM"),"@",1),"^",S1,"^",S2,"^",S3,"^",S4,"^",S5 + Q:CNT=0 + I FOR W !,?44,"_________________________________" D PB Q:Y=0 + I FOR W !,?33,"Totals > >",?44,$J(S1T,3),?49,$J(S2T,3),?55,$J(S3T,3),?63,$J(S4T,3),?72,$J(S5T,4) D PB Q:Y=0 + I FOR W !,?34,"Means > >",?44,$J($FN(S1T/CNT,"",1),3),?49,$J($FN(S2T/CNT,"",1),3),?55,$J($FN(S3T/CNT,"",1),3),?63,$J($FN(S4T/CNT,"",1),3),?72,$J($FN(S5T/CNT,"",1),4) + D PB Q:Y=0 + S (S1T,S2T,S3T,S4T,S5T,SCNT)=0 + N S1TDEV,S1TDEVT,S2TDEV,S2TDEVT,S3TDEV,S3TDEVT,S4TDEV,S4TDEVT,S5TDEV,S5TDEVT + S (S1TDEVT,S2TDEVT,S3TDEVT,S4TDEVT,S5TDEVT)=0 + S DFN="" F S DFN=$O(@REF@(DFN)) Q:DFN="" D + .S SDATE="" F S SDATE=$O(@REF@(DFN,SDATE)) Q:SDATE="" D + ..S DATER="" F S DATER=$O(@REF@(DFN,SDATE,DATER)) Q:DATER="" D + ...S S1="" F S S1=$O(@REF@(DFN,SDATE,DATER,S1)) Q:S1="" D + ....S S1TDEV=(S1-(S1T/CNT))*(S1-(S1T/CNT)) S S1TDEVT=S1TDEVT+S1TDEV + ....S S2="" F S S2=$O(@REF@(DFN,SDATE,DATER,S1,S2)) Q:S2="" D + .....S S2TDEV=(S2-(S2T/CNT))*(S2-(S2T/CNT)) S S2TDEVT=S2TDEVT+S2TDEV + .....S S3="" F S S3=$O(@REF@(DFN,SDATE,DATER,S1,S2,S3)) Q:S3="" D + ......S S3TDEV=(S3-(S3T/CNT))*(S3-(S3T/CNT)) S S3TDEVT=S3TDEVT+S3TDEV + ......S S4="" F S S4=$O(@REF@(DFN,SDATE,DATER,S1,S2,S3,S4)) Q:S4="" D + .......S S4TDEV=(S4-(S4T/CNT))*(S4-(S4T/CNT)) S S4TDEVT=S4TDEVT+S4TDEV + .......S S5="" F S S5=$O(@REF@(DFN,SDATE,DATER,S1,S2,S3,S4,S5)) Q:S5="" D + ........S S5TDEV=(S5-(S5T/CNT))*(S5-(S5T/CNT)) S S5TDEVT=S5TDEVT+S5TDEV + I FOR W !,?20,"Standard Deviations > >" + I CNT<2 S CNT=CNT+1 + I FOR W ?44,$J($FN($$SQROOT(S1TDEVT/(CNT-1)),"",1),3),?49,$J($FN($$SQROOT(S2TDEVT/(CNT-1)),"",1),3),?55,$J($FN($$SQROOT(S3TDEVT/(CNT-1)),"",1),3),?63,$J($FN($$SQROOT(S4TDEVT/(CNT-1)),"",1),3),?72,$J($FN($$SQROOT(S5TDEVT/(CNT-1)),"",1),4) + D PB Q:Y=0 + W ! D PB Q:Y=0 + K ^TMP("PXRMGEC",$J) + D KILL^%ZISS + Q + ; +SQROOT(NUM) ;Calculat Square Root + N PREC,ROOT S ROOT=0 GOTO SQROOTX:NUM=0 + S:NUM<0 NUM=-NUM S ROOT=$S(NUM>1:NUM\1,1:1/NUM) + S ROOT=$E(ROOT,1,$L(ROOT)+1\2) S:NUM'>1 ROOT=1/ROOT + F PREC=1:1:6 S ROOT=NUM/ROOT+ROOT*.5 +SQROOTX Q ROOT + ; +VALUE(DA) ;Return value for score + N CAT,SYN,VALUE,PICE + S SYN=$P($G(^AUTTHF(DA,0)),"^",9) + Q:$E(SYN,5,5)'="F" VALUE + Q:SYN="" VALUE + Q:$E(SYN,5,5)="C" VALUE + S VALUE=$P(SYN," ",$L(SYN," ")) + Q VALUE + ; + ; +PB ;PAGE BREAK + S Y="" + I $Y=(IOSL-2) D + .K DIR + .S DIR(0)="E" + .D ^DIR + .I Y=1 W @IOF S $Y=0 + K DIR + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMHF.m b/r/CLINICAL_REMINDERS-PXRM/PXRMHF.m index d0b7edd1..0c9a26ec 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMHF.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMHF.m @@ -1,175 +1,174 @@ -PXRMHF ; SLC/PKR - Handle Health Factor findings. ;06/01/2007 - ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123 - ; - ;===================================================== -CATSORT(FIEVAL,FIND0,FARR) ;Sort all the true health factor findings - ;according to the category criteria. FIND0 will be defined only - ;for terms. - N CAT,CATLIST,DATE,IND,FI,HFIEN,LDATE,NTRUE,WCR - S HFIEN="" - F S HFIEN=$O(FARR("E","AUTTHF(",HFIEN)) Q:HFIEN="" D - . S FI=0 - . F S FI=$O(FARR("E","AUTTHF(",HFIEN,FI)) Q:FI="" D - .. I 'FIEVAL(FI) Q - ..;Get the Within Category Rank - .. S WCR=$P(FARR(20,FI,0),U,10) - .. I WCR="" S WCR=$P(FIND0,U,10) - .. I WCR="" S WCR=9999 - ..;If Within Category Rank is 0 ignore the category and treat it like - ..;regular finding (exclude it from the list). - .. I WCR>0 D - ... S CAT=$P(^AUTTHF(HFIEN,0),U,3) - ...;If the category is null then send a warning. - ... I CAT="" D WARN(^AUTTHF(HFIEN,0)) Q - ... S CATLIST(CAT,FIEVAL(FI,"DATE"),WCR,FI)="" - ... I $G(PXRMDEBG) S FIEVAL(FI,"CAT^WCR")=CAT_U_WCR - ;No health factors to categorize then quit. - I '$D(CATLIST) Q - ;Only the most recent HF in a category can be true. - S CAT="" - F S CAT=$O(CATLIST(CAT)) Q:CAT="" D - . S LDATE=$O(CATLIST(CAT,""),-1) - .;For each category set all but the most recent HF false. - . S DATE="" - . F S DATE=$O(CATLIST(CAT,DATE)) Q:DATE=LDATE D - .. S WCR="" - .. F S WCR=$O(CATLIST(CAT,DATE,WCR)) Q:WCR="" D - ... S FI="" - ... F S FI=$O(CATLIST(CAT,DATE,WCR,FI)) Q:FI="" D - .... S FIEVAL(FI)=0 - ....;If there are multiple occurrences set them all false. - .... S IND=0 - .... F S IND=+$O(FIEVAL(FI,IND)) Q:IND=0 S FIEVAL(FI,IND)=0 - .; - .;If there is more than on HF on the most recent date then only the - .;one with the highest WCR can be true. The highest possible WCR is 1. - .;Set all with lower WCRs false. - .;If the most recent health factor has multiple occurrences only - .;the first occurrence can be true. - . S (NTRUE,WCR)=0 - . F S WCR=$O(CATLIST(CAT,LDATE,WCR)) Q:WCR="" D - .. S FI="" - .. F S FI=$O(CATLIST(CAT,LDATE,WCR,FI)) Q:FI="" D - ... I NTRUE=0 D Q - ....;If there are multiple sub-occurrences set them all false. - .... S (IND,NTRUE)=1 - .... F S IND=+$O(FIEVAL(FI,IND)) Q:IND=0 S FIEVAL(FI,IND)=0 - ... S FIEVAL(FI)=0 - ...;If there are multiple sub-occurrences set them all false. - ... S IND=0 - ... F S IND=+$O(FIEVAL(FI,IND)) Q:IND=0 S FIEVAL(FI,IND)=0 - Q - ; - ;===================================================== -EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate health factor findings. - N FIEVT,FILENUM,FINDPA,FINDING,HFIEN,NOINDEX - S FILENUM=$$GETFNUM^PXRMDATA(ENODE) - I $G(^PXRMINDX(FILENUM,"DATE BUILT"))="" D - . D NOINDEX^PXRMERRH("D",PXRMITEM,FILENUM) - . S NOINDEX=1 - E S NOINDEX=0 - S HFIEN="" - F S HFIEN=$O(DEFARR("E",ENODE,HFIEN)) Q:+HFIEN=0 D - . S FINDING="" - . F S FINDING=$O(DEFARR("E",ENODE,HFIEN,FINDING)) Q:+FINDING=0 D - .. I NOINDEX S FIEVAL(FINDING)=0 Q - .. K FINDPA - .. M FINDPA=DEFARR(20,FINDING) - .. K FIEVT - .. D FIEVAL^PXRMINDX(FILENUM,"PI",DFN,HFIEN,.FINDPA,.FIEVT) - .. M FIEVAL(FINDING)=FIEVT - .. S FIEVAL(FINDING,"FINDING")=$P(FINDPA(0),U,1) - ;Sort all the true true findings by category. - D CATSORT(.FIEVAL,"",.DEFARR) - Q - ; - ;===================================================== -EVALPL(FINDPA,ENODE,TERMARR,PLIST) ;Evaluate health factor term findings - ;for patient lists. - D EVALPL^PXRMINDL(.FINDPA,ENODE,.TERMARR,PLIST) - Q - ; - ;===================================================== -EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;Evaluate health factor terms. - N BDT,EDT,FIEVT,HFIEN,NOINDEX,PFINDPA - N TFINDPA,TFINDING - I $G(^PXRMINDX(9000010.23,"DATE BUILT"))="" D - . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),9000010.23) - . S NOINDEX=1 - E S NOINDEX=0 - S HFIEN="" - F S HFIEN=$O(TERMARR("E",ENODE,HFIEN)) Q:+HFIEN=0 D - . S TFINDING="" - . F S TFINDING=$O(TERMARR("E",ENODE,HFIEN,TFINDING)) Q:+TFINDING=0 D - .. I NOINDEX S TFIEVAL(TFINDING)=0 Q - .. K FIEVT,PFINDPA,TFINDPA - .. M TFINDPA=TERMARR(20,TFINDING) - ..;Set the finding parameters. - .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA) - .. D FIEVAL^PXRMINDX(9000010.23,"PI",DFN,HFIEN,.PFINDPA,.FIEVT) - .. M TFIEVAL(TFINDING)=FIEVT - .. S TFIEVAL(TFINDING,"FINDING")=$P(TFINDPA(0),U,1) - ;Sort all the true true findings by category. - D CATSORT(.TFIEVAL,FINDPA(0),.TERMARR) - Q - ; - ;===================================================== -GETDATA(DAS,FIEVT) ;Return data for a specified V Health Factor entry. - ;DBIA #4250 - D VHF^PXPXRM(DAS,.FIEVT) - Q - ; - ;===================================================== -MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output. - N EM,FIEN,IND,JND,LVL,NAME,NOUT,PNAME,TEMP,TEXTOUT,VDATE - S FIEN=$P(IFIEVAL("FINDING"),";",1) - S PNAME=$P(^AUTTHF(FIEN,0),U,1) - S NAME="Health Factor: "_PNAME_" = " - S IND=0 - F S IND=+$O(IFIEVAL(IND)) Q:IND=0 D - . S LVL=$G(IFIEVAL(IND,"VALUE")) - . I LVL'="" S LVL=$$EXTERNAL^DILFD(9000010.23,.04,"",LVL,.EM) - . S VDATE=IFIEVAL(IND,"DATE") - . S TEMP=NAME_LVL_" ("_$$EDATE^PXRMDATE(VDATE)_")" - . D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT) - . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND) - S NLINES=NLINES+1,TEXT(NLINES)="" - Q - ; - ;===================================================== -OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical - ;maintenance output. - 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 - S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Health Factor: "_PNAME - S IND=0 - F S IND=+$O(IFIEVAL(IND)) Q:IND=0 D - . S VDATE=IFIEVAL(IND,"DATE") - . S TEMP=$$EDATE^PXRMDATE(VDATE) - . S LVL=$G(IFIEVAL(IND,"VALUE")) - . I LVL'="" D - .. S TEMP=TEMP_" level/severity - " - .. S TEMP=TEMP_$$EXTERNAL^DILFD(9000010.23,.04,"",LVL,.EM) - . D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT) - . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND) - . I IFIEVAL(IND,"COMMENTS")'="" D - .. S TEMP="Comments: "_IFIEVAL(IND,"COMMENTS") - .. D FORMATS^PXRMTEXT(INDENT+3,PXRMRM,TEMP,.NOUT,.TEXTOUT) - .. F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND) - S NLINES=NLINES+1,TEXT(NLINES)="" - Q - ; - ;===================================================== -WARN(HF0) ;Issue a warning if a health factor is missing its category. - N XMSUB - K ^TMP("PXRMXMZ",$J) - S XMSUB="CLINICAL REMINDER DATA PROBLEM, HEALTH FACTOR" - S ^TMP("PXRMXMZ",$J,1,0)="Health Factor "_$P(HF0,U,1) - S ^TMP("PXRMXMZ",$J,2,0)="does not have a category, this is a required field." - S ^TMP("PXRMXMZ",$J,3,0)="This health factor will be ignored for all patients until the problem is fixed." - D SEND^PXRMMSG(XMSUB) - Q - ; +PXRMHF ; SLC/PKR - Handle Health Factor findings. ;12/23/2004 + ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005 + ; + ;===================================================== +CATSORT(FIEVAL,FIND0,FARR) ;Sort all the true health factor findings + ;according to the category criteria. FIND0 will be defined only + ;for terms. + N CAT,CATLIST,DATE,IND,FI,HFIEN,LDATE,NTRUE,WCR + S HFIEN="" + F S HFIEN=$O(FARR("E","AUTTHF(",HFIEN)) Q:HFIEN="" D + . S FI=0 + . F S FI=$O(FARR("E","AUTTHF(",HFIEN,FI)) Q:FI="" D + .. I 'FIEVAL(FI) Q + ..;Get the Within Category Rank + .. S WCR=$P(FARR(20,FI,0),U,10) + .. I WCR="" S WCR=$P(FIND0,U,10) + .. I WCR="" S WCR=9999 + ..;If Within Category Rank is 0 ignore the category and treat it like + ..;regular finding (exclude it from the list). + .. I WCR>0 D + ... S CAT=$P(^AUTTHF(HFIEN,0),U,3) + ...;If the category is null then send a warning. + ... I CAT="" D WARN(^AUTTHF(HFIEN,0)) Q + ... S CATLIST(CAT,FIEVAL(FI,"DATE"),WCR,FI)="" + ... I $G(PXRMDEBG) S FIEVAL(FI,"CAT^WCR")=CAT_U_WCR + ;No health factors to categorize then quit. + I '$D(CATLIST) Q + ;Only the most recent HF in a category can be true. + S CAT="" + F S CAT=$O(CATLIST(CAT)) Q:CAT="" D + . S LDATE=$O(CATLIST(CAT,""),-1) + .;For each category set all but the most recent HF false. + . S DATE="" + . F S DATE=$O(CATLIST(CAT,DATE)) Q:DATE=LDATE D + .. S WCR="" + .. F S WCR=$O(CATLIST(CAT,DATE,WCR)) Q:WCR="" D + ... S FI="" + ... F S FI=$O(CATLIST(CAT,DATE,WCR,FI)) Q:FI="" D + .... S FIEVAL(FI)=0 + ....;If there are multiple occurrences set them all false. + .... S IND=0 + .... F S IND=+$O(FIEVAL(FI,IND)) Q:IND=0 S FIEVAL(FI,IND)=0 + .; + .;If there is more than on HF on the most recent date then only the + .;one with the highest WCR can be true. The highest possible WCR is 1. + .;Set all with lower WCRs false. + .;If the most recent health factor has multiple occurrences only + .;the first occurrence can be true. + . S (NTRUE,WCR)=0 + . F S WCR=$O(CATLIST(CAT,LDATE,WCR)) Q:WCR="" D + .. S FI="" + .. F S FI=$O(CATLIST(CAT,LDATE,WCR,FI)) Q:FI="" D + ... I NTRUE=0 D Q + ....;If there are multiple sub-occurrences set them all false. + .... S (IND,NTRUE)=1 + .... F S IND=+$O(FIEVAL(FI,IND)) Q:IND=0 S FIEVAL(FI,IND)=0 + ... S FIEVAL(FI)=0 + ...;If there are multiple sub-occurrences set them all false. + ... S IND=0 + ... F S IND=+$O(FIEVAL(FI,IND)) Q:IND=0 S FIEVAL(FI,IND)=0 + Q + ; + ;===================================================== +EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate health factor findings. + N FIEVT,FILENUM,FINDPA,FINDING,HFIEN,NOINDEX + S FILENUM=$$GETFNUM^PXRMDATA(ENODE) + I $G(^PXRMINDX(FILENUM,"DATE BUILT"))="" D + . D NOINDEX^PXRMERRH("D",PXRMITEM,FILENUM) + . S NOINDEX=1 + E S NOINDEX=0 + S HFIEN="" + F S HFIEN=$O(DEFARR("E",ENODE,HFIEN)) Q:+HFIEN=0 D + . S FINDING="" + . F S FINDING=$O(DEFARR("E",ENODE,HFIEN,FINDING)) Q:+FINDING=0 D + .. I NOINDEX S FIEVAL(FINDING)=0 Q + .. K FINDPA + .. M FINDPA=DEFARR(20,FINDING) + .. K FIEVT + .. D FIEVAL^PXRMINDX(FILENUM,"PI",DFN,HFIEN,.FINDPA,.FIEVT) + .. M FIEVAL(FINDING)=FIEVT + .. S FIEVAL(FINDING,"FINDING")=$P(FINDPA(0),U,1) + ;Sort all the true true findings by category. + D CATSORT(.FIEVAL,"",.DEFARR) + Q + ; + ;===================================================== +EVALPL(FINDPA,ENODE,TERMARR,PLIST) ;Evaluate health factor term findings + ;for patient lists. + D EVALPL^PXRMINDL(.FINDPA,ENODE,.TERMARR,PLIST) + Q + ; + ;===================================================== +EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;Evaluate health factor terms. + N BDT,EDT,FIEVT,HFIEN,NOINDEX,PFINDPA + N TFINDPA,TFINDING + I $G(^PXRMINDX(9000010.23,"DATE BUILT"))="" D + . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),9000010.23) + . S NOINDEX=1 + E S NOINDEX=0 + S HFIEN="" + F S HFIEN=$O(TERMARR("E",ENODE,HFIEN)) Q:+HFIEN=0 D + . S TFINDING="" + . F S TFINDING=$O(TERMARR("E",ENODE,HFIEN,TFINDING)) Q:+TFINDING=0 D + .. I NOINDEX S TFIEVAL(TFINDING)=0 Q + .. K FIEVT,PFINDPA,TFINDPA + .. M TFINDPA=TERMARR(20,TFINDING) + ..;Set the finding parameters. + .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA) + .. D FIEVAL^PXRMINDX(9000010.23,"PI",DFN,HFIEN,.PFINDPA,.FIEVT) + .. M TFIEVAL(TFINDING)=FIEVT + .. S TFIEVAL(TFINDING,"FINDING")=$P(TFINDPA(0),U,1) + ;Sort all the true true findings by category. + D CATSORT(.TFIEVAL,FINDPA(0),.TERMARR) + Q + ; + ;===================================================== +GETDATA(DAS,FIEVT) ;Return data for a specified V Health Factor entry. + ;DBIA #4250 + D VHF^PXPXRM(DAS,.FIEVT) + Q + ; + ;===================================================== +MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output. + N EM,FIEN,IND,JND,LVL,NAME,NOUT,PNAME,TEMP,TEXTOUT,VDATE + S FIEN=$P(IFIEVAL("FINDING"),";",1) + S PNAME=$P(^AUTTHF(FIEN,0),U,1) + S NAME="Health Factor: "_PNAME_" = " + S IND=0 + F S IND=+$O(IFIEVAL(IND)) Q:IND=0 D + . S LVL=$G(IFIEVAL(IND,"VALUE")) + . I LVL'="" S LVL=$$EXTERNAL^DILFD(9000010.23,.04,"",LVL,.EM) + . S VDATE=IFIEVAL(IND,"DATE") + . S TEMP=NAME_LVL_" ("_$$EDATE^PXRMDATE(VDATE)_")" + . D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT) + . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND) + S NLINES=NLINES+1,TEXT(NLINES)="" + Q + ; + ;===================================================== +OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical + ;maintenance output. + N EM,FIEN,IND,JND,LVL,NOUT,PNAME,TEMP,TEXTOUT,VDATE + S FIEN=$P(IFIEVAL("FINDING"),";",1) + S PNAME=$P(^AUTTHF(FIEN,0),U,1) + S NLINES=NLINES+1 + S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Health Factor: "_PNAME + S IND=0 + F S IND=+$O(IFIEVAL(IND)) Q:IND=0 D + . S VDATE=IFIEVAL(IND,"DATE") + . S TEMP=$$EDATE^PXRMDATE(VDATE) + . S LVL=$G(IFIEVAL(IND,"VALUE")) + . I LVL'="" D + .. S TEMP=TEMP_" level/severity - " + .. S TEMP=TEMP_$$EXTERNAL^DILFD(9000010.23,.04,"",LVL,.EM) + . D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT) + . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND) + . I IFIEVAL(IND,"COMMENTS")'="" D + .. S TEMP="Comments: "_IFIEVAL(IND,"COMMENTS") + .. D FORMATS^PXRMTEXT(INDENT+3,PXRMRM,TEMP,.NOUT,.TEXTOUT) + .. F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND) + S NLINES=NLINES+1,TEXT(NLINES)="" + Q + ; + ;===================================================== +WARN(HF0) ;Issue a warning if a health factor is missing its category. + N XMSUB + K ^TMP("PXRMXMZ",$J) + S XMSUB="CLINICAL REMINDER DATA PROBLEM, HEALTH FACTOR" + S ^TMP("PXRMXMZ",$J,1,0)="Health Factor "_$P(HF0,U,1) + S ^TMP("PXRMXMZ",$J,2,0)="does not have a category, this is a required field." + S ^TMP("PXRMXMZ",$J,3,0)="This health factor will be ignored for all patients until the problem is fixed." + D SEND^PXRMMSG(XMSUB) + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMINDC.m b/r/CLINICAL_REMINDERS-PXRM/PXRMINDC.m index 0e474bb6..7abb14cc 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMINDC.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMINDC.m @@ -1,251 +1,250 @@ -PXRMINDC ; SLC/PKR - Index counting routines. ;03/06/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ;======================================================== -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, - ;9000010.11, 9000010.12, 9000010.13, 9000010.16, 9000010.23 - N DAS,DATE,DFN,IND,ITEM,YEAR - I '$D(ZTQUEUED) W !,"Counting file number "_FILENUM - S IND=0 - S DFN="" - F S DFN=$O(^PXRMINDX(FILENUM,"PI",DFN)) Q:DFN="" D - . S IND=IND+1 - . I '$D(ZTQUEUED),(IND#10000=0) W "." - . S ITEM="" - . F S ITEM=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM)) Q:ITEM="" D - .. S DATE="" - .. F S DATE=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM,DATE)) Q:DATE="" D - ... S YEAR=$E(DATE,1,3) - ... S DAS="" - ... F S DAS=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM,DATE,DAS)) Q:DAS="" D - .... S COUNT(YEAR)=$G(COUNT(YEAR))+1 - Q - ; - ;======================================================== -CNT6(FILENUM,COUNT) ;Get date counts for indexes where the date - ;is at subscript 6. Works for file numbers: - ;9000010.07, 9000010.18 - N DAS,DATE,DFN,IND,ITEM,TYPE,YEAR - I '$D(ZTQUEUED) W !,"Counting file number "_FILENUM - S IND=0 - S DFN="" - F S DFN=$O(^PXRMINDX(FILENUM,"PPI",DFN)) Q:DFN="" D - . S IND=IND+1 - . I '$D(ZTQUEUED),(IND#10000=0) W "." - . S TYPE="" - . F S TYPE=$O(^PXRMINDX(FILENUM,"PPI",DFN,TYPE)) Q:TYPE="" D - .. S ITEM="" - .. F S ITEM=$O(^PXRMINDX(FILENUM,"PPI",DFN,TYPE,ITEM)) Q:ITEM="" D - ... S DATE="" - ... F S DATE=$O(^PXRMINDX(FILENUM,"PPI",DFN,TYPE,ITEM,DATE)) Q:DATE="" D - .... S YEAR=$E(DATE,1,3) - .... S DAS="" - .... F S DAS=$O(^PXRMINDX(FILENUM,"PPI",DFN,TYPE,ITEM,DATE,DAS)) Q:DAS="" D - ..... S COUNT(YEAR)=$G(COUNT(YEAR))+1 - Q - ; - ;======================================================== -CNTPL(FILENUM,COUNT) ;Get date counts for Problem List indexes where the - ;date is at subscript 7. Works for file numbers: - ;9000011 - N DAS,DATE,DFN,IND,ITEM,PRIORITY,STATUS,TYPE,YEAR - I '$D(ZTQUEUED) W !,"Counting file number "_FILENUM - S IND=0 - S DFN="" - F S DFN=$O(^PXRMINDX(FILENUM,"PSPI",DFN)) Q:DFN="" D - . S IND=IND+1 - . I '$D(ZTQUEUED),(IND#10000=0) W "." - . S STATUS="" - . F S STATUS=$O(^PXRMINDX(FILENUM,"PSPI",DFN,STATUS)) Q:STATUS="" D - .. S PRIORITY="" - .. F S PRIORITY=$O(^PXRMINDX(FILENUM,"PSPI",DFN,STATUS,PRIORITY)) Q:PRIORITY="" D - ... S ITEM="" - ... F S ITEM=$O(^PXRMINDX(FILENUM,"PSPI",DFN,STATUS,PRIORITY,ITEM)) Q:ITEM="" D - .... S DATE="" - .... F S DATE=$O(^PXRMINDX(FILENUM,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE)) Q:DATE="" D - ..... S YEAR=$E(DATE,1,3) - ..... S DAS="" - ..... F S DAS=$O(^PXRMINDX(FILENUM,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE,DAS)) Q:DAS="" D - ...... S COUNT(YEAR)=$G(COUNT(YEAR))+1 - Q - ; - ;======================================================== -CNTPTF(FILENUM,COUNT) ;Get date counts for PTF indexes where the - ;date is at subscript 7. Works for file numbers: - ;45 - N DAS,DATE,DFN,IND,ITEM,NODE,TYPE,YEAR - I '$D(ZTQUEUED) W !,"Counting file number "_FILENUM - S IND=0 - F TYPE="ICD0","ICD9" D - . S DFN="" - . F S DFN=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN)) Q:DFN="" D - .. S IND=IND+1 - .. I '$D(ZTQUEUED),(IND#10000=0) W "." - .. S NODE="" - .. F S NODE=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE)) Q:NODE="" D - ... S ITEM="" - ... F S ITEM=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE,ITEM)) Q:ITEM="" D - .... S DATE="" - .... F S DATE=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE,ITEM,DATE)) Q:DATE="" D - ..... S YEAR=$E(DATE,1,3) - ..... S DAS="" - ..... F S DAS=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE,ITEM,DATE,DAS)) Q:DAS="" D - ...... S COUNT(YEAR)=$G(COUNT(YEAR))+1 - Q - ; - ;======================================================== -CNTSS(FILENUM,COUNT) ;Get date counts for indexes where the start date - ;is at subscript 5 and the stop date is at subscript 6. - ;Works for file numbers: 52, 55, 100 - N DAS,DFN,IND,ITEM,START,STOP,YEAR - I '$D(ZTQUEUED) W !,"Counting file number "_FILENUM - S IND=0 - S DFN="" - F S DFN=$O(^PXRMINDX(FILENUM,"PI",DFN)) Q:DFN="" D - . S IND=IND+1 - . I '$D(ZTQUEUED),(IND#10000=0) W "." - . S ITEM="" - . F S ITEM=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM)) Q:ITEM="" D - .. S START="" - .. F S START=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM,START)) Q:START="" D - ... S YEAR=$E(START,1,3) - ... S STOP="" - ... F S STOP=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM,START,STOP)) Q:STOP="" D - .... S DAS="" - .... F S DAS=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM,START,STOP,DAS)) Q:DAS="" D - ..... S COUNT(YEAR)=$G(COUNT(YEAR))+1 - Q - ; - ;======================================================== -COUNT ;Driver for making index counts. - N GBL,LIST,TASKIT - W !,"Which indexes do you want to count?" - D SEL^PXRMSXRM(.LIST,.GBL) - I LIST="" Q - ;See if this should be tasked. - S TASKIT=$$ASKTASK^PXRMSXRM - I TASKIT D - . W !,"Queue the Clinical Reminders Index count." - . D TASKIT(LIST,.GBL,.ROUTINE) - E D RUNNOW(LIST,.GBL) - Q - ; - ;======================================================== -MESSAGE(FILENUM,COUNT,TOTAL,START,END) ;Build the MailMan message giving the - ;count breakdown. - N COFF,ML,NAME,NL,PERC,TEXT,YEAR,XMSUB - K ^TMP("PXRMXMZ",$J) - S ML=$$MAX^XLFMTH($L(TOTAL)+2,8) - S COFF=ML-5 - S NAME=$$GET1^DID(FILENUM,"","","NAME") - S XMSUB="Yearly data distribution for global "_NAME - S ^TMP("PXRMXMZ",$J,1,0)="File name: "_NAME - S ^TMP("PXRMXMZ",$J,2,0)="Count finished at "_$$FMTE^XLFDT($$NOW^XLFDT,"5Z") - S ^TMP("PXRMXMZ",$J,3,0)=$$ETIME^PXRMSXRM(START,END) - S ^TMP("PXRMXMZ",$J,4,0)=" " - S ^TMP("PXRMXMZ",$J,5,0)="Year"_$$INSCHR^PXRMEXLC(COFF," ")_"Count"_$J("%",8) - S ^TMP("PXRMXMZ",$J,6,0)="----"_$$INSCHR^PXRMEXLC(COFF," ")_"-----"_$J("-----",10) - S NL=6,YEAR=0 - F S YEAR=$O(COUNT(YEAR)) Q:YEAR="" D - . S PERC=100*COUNT(YEAR)/TOTAL - . S TEXT=YEAR_$J(COUNT(YEAR),ML,0)_$J(PERC,10,2) - . S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=TEXT - S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=" " - S TEXT="Total entries: "_TOTAL - S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=TEXT - I TOTAL=0 D - . I '$D(^PXRMINDX(FILENUM)) S TEXT="The index for file "_NAME_" does not exist!" - . S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=TEXT - I TOTAL>0,'$D(^PXRMINDX(FILENUM,"DATE BUILT")) D - . S TEXT="Warning, the index for file "_NAME_" may be incomplete or corrupted!" - . S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=TEXT - D SEND^PXRMMSG(XMSUB) - K ^TMP("PXRMXMZ",$J) - Q - ; - ;=============================================================== -RUNNOW(LIST,GBL) ;Run the routines now. - N COUNT,END,FN,IND,LI,NUM,ROUTINE,RTN,START,TOTAL - S ROUTINE(45)="CNTPTF^PXRMINDC" - S ROUTINE(52)="CNTSS^PXRMINDC" - S ROUTINE(55)="CNTSS^PXRMINDC" - S ROUTINE(63)="CNT5^PXRMINDC" - S ROUTINE(70)="CNT5^PXRMINDC" - S ROUTINE(100)="CNTSS^PXRMINDC" - 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" - S ROUTINE(9000010.11)="CNT5^PXRMINDC" - S ROUTINE(9000010.12)="CNT5^PXRMINDC" - S ROUTINE(9000010.13)="CNT5^PXRMINDC" - S ROUTINE(9000010.16)="CNT5^PXRMINDC" - S ROUTINE(9000010.18)="CNT6^PXRMINDC" - S ROUTINE(9000010.23)="CNT5^PXRMINDC" - S NUM=$L(LIST,",")-1 - F IND=1:1:NUM D - . S LI=$P(LIST,",",IND) - . S FN=GBL(LI) - . S RTN=ROUTINE(FN) - . S RTN=RTN_"("_FN_",.COUNT)" - . S START=$H - . K COUNT - . I $D(^PXRMINDX(FN)) D @RTN - . S END=$H - . D TOTAL(.COUNT,.TOTAL) - . D MESSAGE(FN,.COUNT,TOTAL,START,END) - Q - ; - ;=============================================================== -TASKIT(LIST,GBL,ROUTINE) ;Count the indexes as a tasked job. - N DIR,DIROUT,DIRUT,DTOUT,DUOUT,MINDT,SDTIME,X,Y - S MINDT=$$NOW^XLFDT - 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(0)="DAU"_U_MINDT_"::RSX" - D ^DIR - I $D(DIROUT)!$D(DIRUT) Q - I $D(DTOUT)!$D(DUOUT) Q - S SDTIME=Y - K DIR - ;Put the task into the queue. - K ZTSAVE - S ZTSAVE("LIST")="" - S ZTSAVE("GBL(")="" - S ZTRTN="TASKJOB^PXRMINDC" - S ZTDESC="Clinical Reminders Index count" - S ZTDTH=SDTIME - S ZTIO="" - D ^%ZTLOAD - W !,"Task number ",ZTSK," queued." - Q - ; - ;=============================================================== -TASKJOB ;Execute as tasked job. LIST and GBL come through ZTSAVE. - N IND,LI,NUM - S ZTREQ="@" - S ZTSTOP=0 - S NUM=$L(LIST,",")-1 - F IND=1:1:NUM D - .;Check to see if the task has had a stop request - . I $$S^%ZTLOAD S ZTSTOP=1,IND=NUM Q - . S LI=$P(LIST,",",IND)_"," - . D RUNNOW^PXRMINDC(LI,.GBL) - Q - ; - ;======================================================== -TOTAL(COUNT,TOTAL) ;Convert the FileMan years in COUNT to regular - ;years get the total number of entries in count. - N TC,YEAR - S (TOTAL,YEAR)=0 - F S YEAR=$O(COUNT(YEAR)) Q:YEAR="" D - . S TOTAL=TOTAL+COUNT(YEAR) - . S TC(YEAR+1700)=COUNT(YEAR) - K COUNT - M COUNT=TC - Q - ; +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, + ;9000010.11, 9000010.12, 9000010.13, 9000010.16, 9000010.23 + N DAS,DATE,DFN,IND,ITEM,YEAR + I '$D(ZTQUEUED) W !,"Counting file number "_FILENUM + S IND=0 + S DFN="" + F S DFN=$O(^PXRMINDX(FILENUM,"PI",DFN)) Q:DFN="" D + . S IND=IND+1 + . I '$D(ZTQUEUED),(IND#10000=0) W "." + . S ITEM="" + . F S ITEM=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM)) Q:ITEM="" D + .. S DATE="" + .. F S DATE=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM,DATE)) Q:DATE="" D + ... S YEAR=$E(DATE,1,3) + ... S DAS="" + ... F S DAS=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM,DATE,DAS)) Q:DAS="" D + .... S COUNT(YEAR)=$G(COUNT(YEAR))+1 + Q + ; + ;======================================================== +CNT6(FILENUM,COUNT) ;Get date counts for indexes where the date + ;is at subscript 6. Works for file numbers: + ;9000010.07, 9000010.18 + N DAS,DATE,DFN,IND,ITEM,TYPE,YEAR + I '$D(ZTQUEUED) W !,"Counting file number "_FILENUM + S IND=0 + S DFN="" + F S DFN=$O(^PXRMINDX(FILENUM,"PPI",DFN)) Q:DFN="" D + . S IND=IND+1 + . I '$D(ZTQUEUED),(IND#10000=0) W "." + . S TYPE="" + . F S TYPE=$O(^PXRMINDX(FILENUM,"PPI",DFN,TYPE)) Q:TYPE="" D + .. S ITEM="" + .. F S ITEM=$O(^PXRMINDX(FILENUM,"PPI",DFN,TYPE,ITEM)) Q:ITEM="" D + ... S DATE="" + ... F S DATE=$O(^PXRMINDX(FILENUM,"PPI",DFN,TYPE,ITEM,DATE)) Q:DATE="" D + .... S YEAR=$E(DATE,1,3) + .... S DAS="" + .... F S DAS=$O(^PXRMINDX(FILENUM,"PPI",DFN,TYPE,ITEM,DATE,DAS)) Q:DAS="" D + ..... S COUNT(YEAR)=$G(COUNT(YEAR))+1 + Q + ; + ;======================================================== +CNTPL(FILENUM,COUNT) ;Get date counts for Problem List indexes where the + ;date is at subscript 7. Works for file numbers: + ;9000011 + N DAS,DATE,DFN,IND,ITEM,PRIORITY,STATUS,TYPE,YEAR + I '$D(ZTQUEUED) W !,"Counting file number "_FILENUM + S IND=0 + S DFN="" + F S DFN=$O(^PXRMINDX(FILENUM,"PSPI",DFN)) Q:DFN="" D + . S IND=IND+1 + . I '$D(ZTQUEUED),(IND#10000=0) W "." + . S STATUS="" + . F S STATUS=$O(^PXRMINDX(FILENUM,"PSPI",DFN,STATUS)) Q:STATUS="" D + .. S PRIORITY="" + .. F S PRIORITY=$O(^PXRMINDX(FILENUM,"PSPI",DFN,STATUS,PRIORITY)) Q:PRIORITY="" D + ... S ITEM="" + ... F S ITEM=$O(^PXRMINDX(FILENUM,"PSPI",DFN,STATUS,PRIORITY,ITEM)) Q:ITEM="" D + .... S DATE="" + .... F S DATE=$O(^PXRMINDX(FILENUM,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE)) Q:DATE="" D + ..... S YEAR=$E(DATE,1,3) + ..... S DAS="" + ..... F S DAS=$O(^PXRMINDX(FILENUM,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE,DAS)) Q:DAS="" D + ...... S COUNT(YEAR)=$G(COUNT(YEAR))+1 + Q + ; + ;======================================================== +CNTPTF(FILENUM,COUNT) ;Get date counts for PTF indexes where the + ;date is at subscript 7. Works for file numbers: + ;45 + N DAS,DATE,DFN,IND,ITEM,NODE,TYPE,YEAR + I '$D(ZTQUEUED) W !,"Counting file number "_FILENUM + S IND=0 + F TYPE="ICD0","ICD9" D + . S DFN="" + . F S DFN=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN)) Q:DFN="" D + .. S IND=IND+1 + .. I '$D(ZTQUEUED),(IND#10000=0) W "." + .. S NODE="" + .. F S NODE=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE)) Q:NODE="" D + ... S ITEM="" + ... F S ITEM=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE,ITEM)) Q:ITEM="" D + .... S DATE="" + .... F S DATE=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE,ITEM,DATE)) Q:DATE="" D + ..... S YEAR=$E(DATE,1,3) + ..... S DAS="" + ..... F S DAS=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE,ITEM,DATE,DAS)) Q:DAS="" D + ...... S COUNT(YEAR)=$G(COUNT(YEAR))+1 + Q + ; + ;======================================================== +CNTSS(FILENUM,COUNT) ;Get date counts for indexes where the start date + ;is at subscript 5 and the stop date is at subscript 6. + ;Works for file numbers: 52, 55, 100 + N DAS,DFN,IND,ITEM,START,STOP,YEAR + I '$D(ZTQUEUED) W !,"Counting file number "_FILENUM + S IND=0 + S DFN="" + F S DFN=$O(^PXRMINDX(FILENUM,"PI",DFN)) Q:DFN="" D + . S IND=IND+1 + . I '$D(ZTQUEUED),(IND#10000=0) W "." + . S ITEM="" + . F S ITEM=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM)) Q:ITEM="" D + .. S START="" + .. F S START=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM,START)) Q:START="" D + ... S YEAR=$E(START,1,3) + ... S STOP="" + ... F S STOP=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM,START,STOP)) Q:STOP="" D + .... S DAS="" + .... F S DAS=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM,START,STOP,DAS)) Q:DAS="" D + ..... S COUNT(YEAR)=$G(COUNT(YEAR))+1 + Q + ; + ;======================================================== +COUNT ;Driver for making index counts. + N GBL,LIST,TASKIT + W !,"Which indexes do you want to count?" + D SEL^PXRMSXRM(.LIST,.GBL) + I LIST="" Q + ;See if this should be tasked. + S TASKIT=$$ASKTASK^PXRMSXRM + I TASKIT D + . W !,"Queue the Clinical Reminders Index count." + . D TASKIT(LIST,.GBL,.ROUTINE) + E D RUNNOW(LIST,.GBL) + Q + ; + ;======================================================== +MESSAGE(FILENUM,COUNT,TOTAL,START,END) ;Build the MailMan message giving the + ;count breakdown. + N COFF,ML,NAME,NL,PERC,TEXT,YEAR,XMSUB + K ^TMP("PXRMXMZ",$J) + S ML=$$MAX^XLFMTH($L(TOTAL)+2,8) + S COFF=ML-5 + S NAME=$$GET1^DID(FILENUM,"","","NAME") + S XMSUB="Yearly data distribution for global "_NAME + S ^TMP("PXRMXMZ",$J,1,0)="File name: "_NAME + S ^TMP("PXRMXMZ",$J,2,0)="Count finished at "_$$FMTE^XLFDT($$NOW^XLFDT,"5Z") + S ^TMP("PXRMXMZ",$J,3,0)=$$ETIME^PXRMSXRM(START,END) + S ^TMP("PXRMXMZ",$J,4,0)=" " + S ^TMP("PXRMXMZ",$J,5,0)="Year"_$$INSCHR^PXRMEXLC(COFF," ")_"Count"_$J("%",8) + S ^TMP("PXRMXMZ",$J,6,0)="----"_$$INSCHR^PXRMEXLC(COFF," ")_"-----"_$J("-----",10) + S NL=6,YEAR=0 + F S YEAR=$O(COUNT(YEAR)) Q:YEAR="" D + . S PERC=100*COUNT(YEAR)/TOTAL + . S TEXT=YEAR_$J(COUNT(YEAR),ML,0)_$J(PERC,10,2) + . S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=TEXT + S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=" " + S TEXT="Total entries: "_TOTAL + S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=TEXT + I TOTAL=0 D + . I '$D(^PXRMINDX(FILENUM)) S TEXT="The index for file "_NAME_" does not exist!" + . S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=TEXT + I TOTAL>0,'$D(^PXRMINDX(FILENUM,"DATE BUILT")) D + . S TEXT="Warning, the index for file "_NAME_" may be incomplete or corrupted!" + . S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=TEXT + D SEND^PXRMMSG(XMSUB) + K ^TMP("PXRMXMZ",$J) + Q + ; + ;=============================================================== +RUNNOW(LIST,GBL) ;Run the routines now. + N COUNT,END,FN,IND,LI,NUM,ROUTINE,RTN,START,TOTAL + S ROUTINE(45)="CNTPTF^PXRMINDC" + S ROUTINE(52)="CNTSS^PXRMINDC" + S ROUTINE(55)="CNTSS^PXRMINDC" + S ROUTINE(63)="CNT5^PXRMINDC" + S ROUTINE(70)="CNT5^PXRMINDC" + S ROUTINE(100)="CNTSS^PXRMINDC" + S ROUTINE(120.5)="CNT5^PXRMINDC" + S ROUTINE(601.2)="CNT5^PXRMINDC" + S ROUTINE(9000011)="CNTPL^PXRMINDC" + S ROUTINE(9000010.07)="CNT6^PXRMINDC" + S ROUTINE(9000010.11)="CNT5^PXRMINDC" + S ROUTINE(9000010.12)="CNT5^PXRMINDC" + S ROUTINE(9000010.13)="CNT5^PXRMINDC" + S ROUTINE(9000010.16)="CNT5^PXRMINDC" + S ROUTINE(9000010.18)="CNT6^PXRMINDC" + S ROUTINE(9000010.23)="CNT5^PXRMINDC" + S NUM=$L(LIST,",")-1 + F IND=1:1:NUM D + . S LI=$P(LIST,",",IND) + . S FN=GBL(LI) + . S RTN=ROUTINE(FN) + . S RTN=RTN_"("_FN_",.COUNT)" + . S START=$H + . K COUNT + . I $D(^PXRMINDX(FN)) D @RTN + . S END=$H + . D TOTAL(.COUNT,.TOTAL) + . D MESSAGE(FN,.COUNT,TOTAL,START,END) + Q + ; + ;=============================================================== +TASKIT(LIST,GBL,ROUTINE) ;Count the indexes as a tasked job. + N DIR,DIROUT,DIRUT,DTOUT,DUOUT,MINDT,SDTIME,X,Y + S MINDT=$$NOW^XLFDT + 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(0)="DAU"_U_MINDT_"::RSX" + D ^DIR + I $D(DIROUT)!$D(DIRUT) Q + I $D(DTOUT)!$D(DUOUT) Q + S SDTIME=Y + K DIR + ;Put the task into the queue. + K ZTSAVE + S ZTSAVE("LIST")="" + S ZTSAVE("GBL(")="" + S ZTRTN="TASKJOB^PXRMINDC" + S ZTDESC="Clinical Reminders Index count" + S ZTDTH=SDTIME + S ZTIO="" + D ^%ZTLOAD + W !,"Task number ",ZTSK," queued." + Q + ; + ;=============================================================== +TASKJOB ;Execute as tasked job. LIST and GBL come through ZTSAVE. + N IND,LI,NUM + S ZTREQ="@" + S ZTSTOP=0 + S NUM=$L(LIST,",")-1 + F IND=1:1:NUM D + .;Check to see if the task has had a stop request + . I $$S^%ZTLOAD S ZTSTOP=1,IND=NUM Q + . S LI=$P(LIST,",",IND)_"," + . D RUNNOW^PXRMINDC(LI,.GBL) + Q + ; + ;======================================================== +TOTAL(COUNT,TOTAL) ;Convert the FileMan years in COUNT to regular + ;years get the total number of entries in count. + N TC,YEAR + S (TOTAL,YEAR)=0 + F S YEAR=$O(COUNT(YEAR)) Q:YEAR="" D + . S TOTAL=TOTAL+COUNT(YEAR) + . S TC(YEAR+1700)=COUNT(YEAR) + K COUNT + M COUNT=TC + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMINDD.m b/r/CLINICAL_REMINDERS-PXRM/PXRMINDD.m index bf2fcc76..6ff26fae 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMINDD.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMINDD.m @@ -1,238 +1,237 @@ -PXRMINDD ; SLC/PKR - Index string date checking routines. ;03/06/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ;======================================================== -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 - ;9000010.11, 9000010.12, 9000010.13, 9000010.16, 9000010.23 - N DAS,DATE,DFN,IND,ITEM - I '$D(ZTQUEUED) W !,"Checking file number "_FILENUM - S IND=0 - S DFN="" - F S DFN=$O(^PXRMINDX(FILENUM,"PI",DFN)) Q:DFN="" D - . S IND=IND+1 - . I '$D(ZTQUEUED),(IND#10000=0) W "." - . S ITEM="" - . F S ITEM=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM)) Q:ITEM="" D - .. S DATE="" - .. F S DATE=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM,DATE)) Q:DATE="" D - ... I +DATE=DATE Q - ... S DAS="" - ... F S DAS=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM,DATE,DAS)) Q:DAS="" D - .... S NSD=NSD+1 - .... S ^TMP($J,"SDATE",NSD)="^PXRMINDX("_FILENUM_",""PI"","_DFN_","_ITEM_","""_DATE_""","_DAS_")" - Q - ; - ;======================================================== -CNT6(FILENUM,NSD) ;Check for string dates for indexes where the date - ;is at subscript 6. Works for file numbers: - ;9000010.07, 9000010.18 - N DAS,DATE,DFN,IND,ITEM,TYPE - I '$D(ZTQUEUED) W !,"Checking file number "_FILENUM - S IND=0 - S DFN="" - F S DFN=$O(^PXRMINDX(FILENUM,"PPI",DFN)) Q:DFN="" D - . S IND=IND+1 - . I '$D(ZTQUEUED),(IND#10000=0) W "." - . S TYPE="" - . F S TYPE=$O(^PXRMINDX(FILENUM,"PPI",DFN,TYPE)) Q:TYPE="" D - .. S ITEM="" - .. F S ITEM=$O(^PXRMINDX(FILENUM,"PPI",DFN,TYPE,ITEM)) Q:ITEM="" D - ... S DATE="" - ... F S DATE=$O(^PXRMINDX(FILENUM,"PPI",DFN,TYPE,ITEM,DATE)) Q:DATE="" D - .... I +DATE=DATE Q - .... S DAS="" - .... F S DAS=$O(^PXRMINDX(FILENUM,"PPI",DFN,TYPE,ITEM,DATE,DAS)) Q:DAS="" D - ..... S NSD=NSD+1 - ..... S ^TMP($J,"SDATE",NSD)="^PXRMINDX("_FILENUM_",""PPI"","_DFN_","_TYPE_","_ITEM_","""_DATE_""","_DAS_")" - Q - ; - ;======================================================== -CNTPL(FILENUM,NSD) ;Check for string date for Problem List indexes where the - ;date is at subscript 7. Works for file numbers: - ;9000011 - N DAS,DATE,DFN,IND,ITEM,PRIORITY,STATUS,TYPE - I '$D(ZTQUEUED) W !,"Checking file number "_FILENUM - S IND=0 - S DFN="" - F S DFN=$O(^PXRMINDX(FILENUM,"PSPI",DFN)) Q:DFN="" D - . S IND=IND+1 - . I '$D(ZTQUEUED),(IND#10000=0) W "." - . S STATUS="" - . F S STATUS=$O(^PXRMINDX(FILENUM,"PSPI",DFN,STATUS)) Q:STATUS="" D - .. S PRIORITY="" - .. F S PRIORITY=$O(^PXRMINDX(FILENUM,"PSPI",DFN,STATUS,PRIORITY)) Q:PRIORITY="" D - ... S ITEM="" - ... F S ITEM=$O(^PXRMINDX(FILENUM,"PSPI",DFN,STATUS,PRIORITY,ITEM)) Q:ITEM="" D - .... S DATE="" - .... F S DATE=$O(^PXRMINDX(FILENUM,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE)) Q:DATE="" D - ..... I +DATE=DATE Q - ..... S DAS="" - ..... F S DAS=$O(^PXRMINDX(FILENUM,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE,DAS)) Q:DAS="" D - ...... S NSD=NSD+1 - ...... S ^TMP($J,"SDATE",NSD)="^PXRMINDX("_FILENUM_",""PSPI"","_DFN_","_STATUS_","_PRIORITY_","_ITEM_","""_DATE_""","_DAS_")" - Q - ; - ;======================================================== -CNTPTF(FILENUM,NSD) ;Check for string dates for PTF indexes where the - ;date is at subscript 7. Works for file numbers: - ;45 - N DAS,DATE,DFN,IND,ITEM,NODE,TYPE - I '$D(ZTQUEUED) W !,"Checking file number "_FILENUM - S IND=0 - F TYPE="ICD0","ICD9" D - . S DFN="" - . F S DFN=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN)) Q:DFN="" D - .. S IND=IND+1 - .. I '$D(ZTQUEUED),(IND#10000=0) W "." - .. S NODE="" - .. F S NODE=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE)) Q:NODE="" D - ... S ITEM="" - ... F S ITEM=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE,ITEM)) Q:ITEM="" D - .... S DATE="" - .... F S DATE=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE,ITEM,DATE)) Q:DATE="" D - ..... I +DATE=DATE Q - ..... S DAS="" - ..... F S DAS=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE,ITEM,DATE,DAS)) Q:DAS="" D - ...... S NSD=NSD+1 - ...... S ^TMP($J,"SDATE",NSD)="^PXRMINDX("_FILENUM_","_TYPE_",""PNI"","_DFN_","_NODE_","_ITEM_","""_DATE_""","_DAS_")" - Q - ; - ;======================================================== -CNTSS(FILENUM,NSD) ;Check for string dates for indexes where the start date - ;is at subscript 5 and the stop date is at subscript 6. - ;Works for file numbers: 52, 55, 100 - N DAS,DFN,IND,ITEM,START,STOP - I '$D(ZTQUEUED) W !,"Checking file number "_FILENUM - S IND=0 - S DFN="" - F S DFN=$O(^PXRMINDX(FILENUM,"PI",DFN)) Q:DFN="" D - . S IND=IND+1 - . I '$D(ZTQUEUED),(IND#10000=0) W "." - . S ITEM="" - . F S ITEM=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM)) Q:ITEM="" D - .. S START="" - .. F S START=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM,START)) Q:START="" D - ... I +START=START Q - ... S STOP="" - ... F S STOP=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM,START,STOP)) Q:STOP="" D - .... S DAS="" - .... F S DAS=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM,START,STOP,DAS)) Q:DAS="" D - ..... S NSD=NSD+1 - ..... S ^TMP($J,"SDATE",NSD)="^PXRMINDX("_FILENUM_",""PI"","_DFN_","_ITEM_","""_START_""","_STOP_","_DAS_")" - Q - ; - ;======================================================== -CHECK ;Driver for making index date checks. - N GBL,LIST,TASKIT - W !,"Which indexes do you want to check?" - D SEL^PXRMSXRM(.LIST,.GBL) - I LIST="" Q - ;See if this should be tasked. - S TASKIT=$$ASKTASK^PXRMSXRM - I TASKIT D - . W !,"Queue the Clinical Reminders Index date check." - . D TASKIT(LIST,.GBL,.ROUTINE) - E D RUNNOW(LIST,.GBL) - Q - ; - ;======================================================== -MESSAGE(FILENUM,NSD,START,END) ;Build the MailMan message giving the - ;list of entries with string dates. - N IND,NAME,NL,TEXT,XMSUB - K ^TMP("PXRMXMZ",$J) - S XMSUB="CR Index string date check for file #"_FILENUM - S NAME=$$GET1^DID(FILENUM,"","","NAME")_", file #"_FILENUM - I NSD=0 S TEXT="No string dates were found for "_NAME_"." - I NSD>0 S TEXT="A total of "_NSD_" string dates were found for "_NAME_"." - S ^TMP("PXRMXMZ",$J,1,0)=TEXT - S ^TMP("PXRMXMZ",$J,2,0)="Check finished at "_$$FMTE^XLFDT($$NOW^XLFDT,"5Z") - S ^TMP("PXRMXMZ",$J,3,0)=$$ETIME^PXRMSXRM(START,END) - S ^TMP("PXRMXMZ",$J,4,0)=" " - I NSD=0,'$D(^PXRMINDX(FILENUM)) D - . S ^TMP("PXRMXMZ",$J,5,0)="The index for file number "_FILENUM_" does not exist." - . S ^TMP("PXRMXMZ",$J,6,0)=" " - I NSD>0 D - . S ^TMP("PXRMXMZ",$J,5,0)="The following entries with string dates were found:" - . S NL=5 - . F IND=1:1:NSD D - .. S NL=NL+1 - .. S ^TMP("PXRMXMZ",$J,NL,0)=" "_^TMP($J,"SDATE",IND) - . S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=" " - D SEND^PXRMMSG(XMSUB) - K ^TMP($J,"SDATE"),^TMP("PXRMXMZ",$J) - Q - ; - ;=============================================================== -RUNNOW(LIST,GBL) ;Run the routines now. - N END,FN,IND,LI,NSD,NUM,ROUTINE,RTN,START,TOTAL - K ^TMP($J,"SDATE") - S ROUTINE(45)="CNTPTF^PXRMINDD" - S ROUTINE(52)="CNTSS^PXRMINDD" - S ROUTINE(55)="CNTSS^PXRMINDD" - S ROUTINE(63)="CNT5^PXRMINDD" - S ROUTINE(70)="CNT5^PXRMINDD" - S ROUTINE(100)="CNTSS^PXRMINDD" - 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" - S ROUTINE(9000010.11)="CNT5^PXRMINDD" - S ROUTINE(9000010.12)="CNT5^PXRMINDD" - S ROUTINE(9000010.13)="CNT5^PXRMINDD" - S ROUTINE(9000010.16)="CNT5^PXRMINDD" - S ROUTINE(9000010.18)="CNT6^PXRMINDD" - S ROUTINE(9000010.23)="CNT5^PXRMINDD" - S NUM=$L(LIST,",")-1 - F IND=1:1:NUM D - . S LI=$P(LIST,",",IND) - . S NSD=0 - . S FN=GBL(LI) - . S RTN=ROUTINE(FN) - . S RTN=RTN_"("_FN_",.NSD)" - . S START=$H - . I $D(^PXRMINDX(FN)) D @RTN - . S END=$H - . D MESSAGE(FN,NSD,START,END) - Q - ; - ;=============================================================== -TASKIT(LIST,GBL,ROUTINE) ;Check the indexes as a tasked job. - N DIR,DIROUT,DIRUT,DTOUT,DUOUT,MINDT,SDTIME,X,Y - S MINDT=$$NOW^XLFDT - 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(0)="DAU"_U_MINDT_"::RSX" - D ^DIR - I $D(DIROUT)!$D(DIRUT) Q - I $D(DTOUT)!$D(DUOUT) Q - S SDTIME=Y - K DIR - ;Put the task into the queue. - K ZTSAVE - S ZTSAVE("LIST")="" - S ZTSAVE("GBL(")="" - S ZTRTN="TASKJOB^PXRMINDD" - S ZTDESC="Clinical Reminders Index string date check" - S ZTDTH=SDTIME - S ZTIO="" - D ^%ZTLOAD - W !,"Task number ",ZTSK," queued." - Q - ; - ;=============================================================== -TASKJOB ;Execute as tasked job. LIST and GBL come through ZTSAVE. - N IND,LI,NUM - S ZTREQ="@" - S ZTSTOP=0 - S NUM=$L(LIST,",")-1 - F IND=1:1:NUM D - .;Check to see if the task has had a stop request - . I $$S^%ZTLOAD S ZTSTOP=1,IND=NUM Q - . S LI=$P(LIST,",",IND)_"," - . D RUNNOW^PXRMINDD(LI,.GBL) - Q - ; +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, + ;9000010.11, 9000010.12, 9000010.13, 9000010.16, 9000010.23 + N DAS,DATE,DFN,IND,ITEM + I '$D(ZTQUEUED) W !,"Checking file number "_FILENUM + S IND=0 + S DFN="" + F S DFN=$O(^PXRMINDX(FILENUM,"PI",DFN)) Q:DFN="" D + . S IND=IND+1 + . I '$D(ZTQUEUED),(IND#10000=0) W "." + . S ITEM="" + . F S ITEM=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM)) Q:ITEM="" D + .. S DATE="" + .. F S DATE=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM,DATE)) Q:DATE="" D + ... I +DATE=DATE Q + ... S DAS="" + ... F S DAS=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM,DATE,DAS)) Q:DAS="" D + .... S NSD=NSD+1 + .... S ^TMP($J,"SDATE",NSD)="^PXRMINDX("_FILENUM_",""PI"","_DFN_","_ITEM_","""_DATE_""","_DAS_")" + Q + ; + ;======================================================== +CNT6(FILENUM,NSD) ;Check for string dates for indexes where the date + ;is at subscript 6. Works for file numbers: + ;9000010.07, 9000010.18 + N DAS,DATE,DFN,IND,ITEM,TYPE + I '$D(ZTQUEUED) W !,"Checking file number "_FILENUM + S IND=0 + S DFN="" + F S DFN=$O(^PXRMINDX(FILENUM,"PPI",DFN)) Q:DFN="" D + . S IND=IND+1 + . I '$D(ZTQUEUED),(IND#10000=0) W "." + . S TYPE="" + . F S TYPE=$O(^PXRMINDX(FILENUM,"PPI",DFN,TYPE)) Q:TYPE="" D + .. S ITEM="" + .. F S ITEM=$O(^PXRMINDX(FILENUM,"PPI",DFN,TYPE,ITEM)) Q:ITEM="" D + ... S DATE="" + ... F S DATE=$O(^PXRMINDX(FILENUM,"PPI",DFN,TYPE,ITEM,DATE)) Q:DATE="" D + .... I +DATE=DATE Q + .... S DAS="" + .... F S DAS=$O(^PXRMINDX(FILENUM,"PPI",DFN,TYPE,ITEM,DATE,DAS)) Q:DAS="" D + ..... S NSD=NSD+1 + ..... S ^TMP($J,"SDATE",NSD)="^PXRMINDX("_FILENUM_",""PPI"","_DFN_","_TYPE_","_ITEM_","""_DATE_""","_DAS_")" + Q + ; + ;======================================================== +CNTPL(FILENUM,NSD) ;Check for string date for Problem List indexes where the + ;date is at subscript 7. Works for file numbers: + ;9000011 + N DAS,DATE,DFN,IND,ITEM,PRIORITY,STATUS,TYPE + I '$D(ZTQUEUED) W !,"Checking file number "_FILENUM + S IND=0 + S DFN="" + F S DFN=$O(^PXRMINDX(FILENUM,"PSPI",DFN)) Q:DFN="" D + . S IND=IND+1 + . I '$D(ZTQUEUED),(IND#10000=0) W "." + . S STATUS="" + . F S STATUS=$O(^PXRMINDX(FILENUM,"PSPI",DFN,STATUS)) Q:STATUS="" D + .. S PRIORITY="" + .. F S PRIORITY=$O(^PXRMINDX(FILENUM,"PSPI",DFN,STATUS,PRIORITY)) Q:PRIORITY="" D + ... S ITEM="" + ... F S ITEM=$O(^PXRMINDX(FILENUM,"PSPI",DFN,STATUS,PRIORITY,ITEM)) Q:ITEM="" D + .... S DATE="" + .... F S DATE=$O(^PXRMINDX(FILENUM,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE)) Q:DATE="" D + ..... I +DATE=DATE Q + ..... S DAS="" + ..... F S DAS=$O(^PXRMINDX(FILENUM,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE,DAS)) Q:DAS="" D + ...... S NSD=NSD+1 + ...... S ^TMP($J,"SDATE",NSD)="^PXRMINDX("_FILENUM_",""PSPI"","_DFN_","_STATUS_","_PRIORITY_","_ITEM_","""_DATE_""","_DAS_")" + Q + ; + ;======================================================== +CNTPTF(FILENUM,NSD) ;Check for string dates for PTF indexes where the + ;date is at subscript 7. Works for file numbers: + ;45 + N DAS,DATE,DFN,IND,ITEM,NODE,TYPE + I '$D(ZTQUEUED) W !,"Checking file number "_FILENUM + S IND=0 + F TYPE="ICD0","ICD9" D + . S DFN="" + . F S DFN=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN)) Q:DFN="" D + .. S IND=IND+1 + .. I '$D(ZTQUEUED),(IND#10000=0) W "." + .. S NODE="" + .. F S NODE=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE)) Q:NODE="" D + ... S ITEM="" + ... F S ITEM=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE,ITEM)) Q:ITEM="" D + .... S DATE="" + .... F S DATE=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE,ITEM,DATE)) Q:DATE="" D + ..... I +DATE=DATE Q + ..... S DAS="" + ..... F S DAS=$O(^PXRMINDX(FILENUM,TYPE,"PNI",DFN,NODE,ITEM,DATE,DAS)) Q:DAS="" D + ...... S NSD=NSD+1 + ...... S ^TMP($J,"SDATE",NSD)="^PXRMINDX("_FILENUM_","_TYPE_",""PNI"","_DFN_","_NODE_","_ITEM_","""_DATE_""","_DAS_")" + Q + ; + ;======================================================== +CNTSS(FILENUM,NSD) ;Check for string dates for indexes where the start date + ;is at subscript 5 and the stop date is at subscript 6. + ;Works for file numbers: 52, 55, 100 + N DAS,DFN,IND,ITEM,START,STOP + I '$D(ZTQUEUED) W !,"Checking file number "_FILENUM + S IND=0 + S DFN="" + F S DFN=$O(^PXRMINDX(FILENUM,"PI",DFN)) Q:DFN="" D + . S IND=IND+1 + . I '$D(ZTQUEUED),(IND#10000=0) W "." + . S ITEM="" + . F S ITEM=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM)) Q:ITEM="" D + .. S START="" + .. F S START=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM,START)) Q:START="" D + ... I +START=START Q + ... S STOP="" + ... F S STOP=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM,START,STOP)) Q:STOP="" D + .... S DAS="" + .... F S DAS=$O(^PXRMINDX(FILENUM,"PI",DFN,ITEM,START,STOP,DAS)) Q:DAS="" D + ..... S NSD=NSD+1 + ..... S ^TMP($J,"SDATE",NSD)="^PXRMINDX("_FILENUM_",""PI"","_DFN_","_ITEM_","""_START_""","_STOP_","_DAS_")" + Q + ; + ;======================================================== +CHECK ;Driver for making index date checks. + N GBL,LIST,TASKIT + W !,"Which indexes do you want to check?" + D SEL^PXRMSXRM(.LIST,.GBL) + I LIST="" Q + ;See if this should be tasked. + S TASKIT=$$ASKTASK^PXRMSXRM + I TASKIT D + . W !,"Queue the Clinical Reminders Index date check." + . D TASKIT(LIST,.GBL,.ROUTINE) + E D RUNNOW(LIST,.GBL) + Q + ; + ;======================================================== +MESSAGE(FILENUM,NSD,START,END) ;Build the MailMan message giving the + ;list of entries with string dates. + N IND,NAME,NL,TEXT,XMSUB + K ^TMP("PXRMXMZ",$J) + S XMSUB="CR Index string date check for file #"_FILENUM + S NAME=$$GET1^DID(FILENUM,"","","NAME")_", file #"_FILENUM + I NSD=0 S TEXT="No string dates were found for "_NAME_"." + I NSD>0 S TEXT="A total of "_NSD_" string dates were found for "_NAME_"." + S ^TMP("PXRMXMZ",$J,1,0)=TEXT + S ^TMP("PXRMXMZ",$J,2,0)="Check finished at "_$$FMTE^XLFDT($$NOW^XLFDT,"5Z") + S ^TMP("PXRMXMZ",$J,3,0)=$$ETIME^PXRMSXRM(START,END) + S ^TMP("PXRMXMZ",$J,4,0)=" " + I NSD=0,'$D(^PXRMINDX(FILENUM)) D + . S ^TMP("PXRMXMZ",$J,5,0)="The index for file number "_FILENUM_" does not exist." + . S ^TMP("PXRMXMZ",$J,6,0)=" " + I NSD>0 D + . S ^TMP("PXRMXMZ",$J,5,0)="The following entries with string dates were found:" + . S NL=5 + . F IND=1:1:NSD D + .. S NL=NL+1 + .. S ^TMP("PXRMXMZ",$J,NL,0)=" "_^TMP($J,"SDATE",IND) + . S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=" " + D SEND^PXRMMSG(XMSUB) + K ^TMP($J,"SDATE"),^TMP("PXRMXMZ",$J) + Q + ; + ;=============================================================== +RUNNOW(LIST,GBL) ;Run the routines now. + N END,FN,IND,LI,NSD,NUM,ROUTINE,RTN,START,TOTAL + K ^TMP($J,"SDATE") + S ROUTINE(45)="CNTPTF^PXRMINDD" + S ROUTINE(52)="CNTSS^PXRMINDD" + S ROUTINE(55)="CNTSS^PXRMINDD" + S ROUTINE(63)="CNT5^PXRMINDD" + S ROUTINE(70)="CNT5^PXRMINDD" + S ROUTINE(100)="CNTSS^PXRMINDD" + S ROUTINE(120.5)="CNT5^PXRMINDD" + S ROUTINE(601.2)="CNT5^PXRMINDD" + S ROUTINE(9000011)="CNTPL^PXRMINDD" + S ROUTINE(9000010.07)="CNT6^PXRMINDD" + S ROUTINE(9000010.11)="CNT5^PXRMINDD" + S ROUTINE(9000010.12)="CNT5^PXRMINDD" + S ROUTINE(9000010.13)="CNT5^PXRMINDD" + S ROUTINE(9000010.16)="CNT5^PXRMINDD" + S ROUTINE(9000010.18)="CNT6^PXRMINDD" + S ROUTINE(9000010.23)="CNT5^PXRMINDD" + S NUM=$L(LIST,",")-1 + F IND=1:1:NUM D + . S LI=$P(LIST,",",IND) + . S NSD=0 + . S FN=GBL(LI) + . S RTN=ROUTINE(FN) + . S RTN=RTN_"("_FN_",.NSD)" + . S START=$H + . I $D(^PXRMINDX(FN)) D @RTN + . S END=$H + . D MESSAGE(FN,NSD,START,END) + Q + ; + ;=============================================================== +TASKIT(LIST,GBL,ROUTINE) ;Check the indexes as a tasked job. + N DIR,DIROUT,DIRUT,DTOUT,DUOUT,MINDT,SDTIME,X,Y + S MINDT=$$NOW^XLFDT + 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(0)="DAU"_U_MINDT_"::RSX" + D ^DIR + I $D(DIROUT)!$D(DIRUT) Q + I $D(DTOUT)!$D(DUOUT) Q + S SDTIME=Y + K DIR + ;Put the task into the queue. + K ZTSAVE + S ZTSAVE("LIST")="" + S ZTSAVE("GBL(")="" + S ZTRTN="TASKJOB^PXRMINDD" + S ZTDESC="Clinical Reminders Index string date check" + S ZTDTH=SDTIME + S ZTIO="" + D ^%ZTLOAD + W !,"Task number ",ZTSK," queued." + Q + ; + ;=============================================================== +TASKJOB ;Execute as tasked job. LIST and GBL come through ZTSAVE. + N IND,LI,NUM + S ZTREQ="@" + S ZTSTOP=0 + S NUM=$L(LIST,",")-1 + F IND=1:1:NUM D + .;Check to see if the task has had a stop request + . I $$S^%ZTLOAD S ZTSTOP=1,IND=NUM Q + . S LI=$P(LIST,",",IND)_"," + . D RUNNOW^PXRMINDD(LI,.GBL) + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMINDL.m b/r/CLINICAL_REMINDERS-PXRM/PXRMINDL.m index 97294a46..7ee53563 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMINDL.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMINDL.m @@ -1,122 +1,120 @@ -PXRMINDL ; SLC/PKR - List building routines. ;07/26/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ;================================================ -EVALPL(FINDPA,ENODE,TERMARR,PLIST) ;General patient list term evaluator. - ;Return the list in ^TMP($J,PLIST) - N ITEM,FILENUM,PFINDPA - N SSFIND,TEMP,TFINDING,TFINDPA - S FILENUM=$$GETFNUM^PXRMDATA(ENODE) - I $G(^PXRMINDX(FILENUM,"DATE BUILT"))="" D Q - . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),FILENUM) - S ITEM="" - F S ITEM=$O(TERMARR("E",ENODE,ITEM)) Q:ITEM="" D - . S TFINDING="" - . F S TFINDING=$O(TERMARR("E",ENODE,ITEM,TFINDING)) Q:+TFINDING=0 D - .. K PFINDPA,TFINDPA - .. M TFINDPA=TERMARR(20,TFINDING) - ..;Set the finding parameters. - .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA) - .. D GPLIST(FILENUM,"IP",ITEM,.PFINDPA,PLIST) - Q - ; - ;================================================ -FPLIST(FILENUM,SNODE,ITEM,NOCC,BDT,EDT,PLIST) ;Find patient list data for - ;regular files. Return the list in ^TMP($J,PLIST). - N DAS,DATE,DFN,DS,NFOUND - K ^TMP($J,PLIST) - I FILENUM=601.84 D SEVALPL^PXRMMH(ITEM,NOCC,BDT,EDT,PLIST) Q - S DS=$S(EDT[".":EDT+.0000001,1:EDT+.240001) - S DFN=0 - F S DFN=$O(^PXRMINDX(FILENUM,SNODE,ITEM,DFN)) Q:DFN="" D - . S NFOUND=0 - . S DATE=DS - . F S DATE=+$O(^PXRMINDX(FILENUM,SNODE,ITEM,DFN,DATE),-1) Q:(DATE=0)!(DATEEDTT,SDIR=1 S DONE=1 Q - . S DAS=$O(^PXRMINDX(FILENUM,SNODE,DFN,ITEM,DATE,"")) - . S NFOUND=NFOUND+1 - . S FLIST(NFOUND)=DAS_U_DATE - . I NFOUND=NGET S DONE=1 Q - Q - ; - ;================================================================ -FPDATSS(FILENUM,SNODE,DFN,ITEM,NGET,SDIR,BDT,EDT,USESTRT,NFOUND,FLIST) ;Find - ;patient data for findings that have a start and stop date. FLIST - ;is returned in date order, i.e., FLIST(1) is the most recent. - N DAS,DONE,EDTT,OVERLAP,SDATE,START,STOP,TDATE,TIND,TLIST - S EDTT=$S(EDT[".":EDT+.0000001,1:EDT+.240001) - S (DONE,NFOUND)=0 - S START=$S(SDIR=+1:0,1:EDTT) - F S START=+$O(^PXRMINDX(FILENUM,SNODE,DFN,ITEM,START),SDIR) Q:(START=0)!(DONE)!(START>EDTT) D - . S STOP="" - . F S STOP=$O(^PXRMINDX(FILENUM,SNODE,DFN,ITEM,START,STOP),SDIR) Q:(STOP="")!(DONE) D - ..;Items that do not have a stop date are flagged by "U". - .. S SDATE=$S(USESTRT:START,STOP["U":$$NOW^PXRMDATE_"U",1:STOP) - .. S OVERLAP=$$OVERLAP(START,SDATE,BDT,EDT) - .. I OVERLAP="O" D - ... S DAS=$O(^PXRMINDX(FILENUM,SNODE,DFN,ITEM,START,STOP,"")) - ... S NFOUND=NFOUND+1,TLIST(SDATE,NFOUND)=DAS_U_SDATE - ..;Some orders and non-VA meds may not have a Stop Date so we have - ..;to check all entries. - .. I FILENUM="55NVA" Q - .. I FILENUM=100 Q - .. I OVERLAP="L",SDIR=-1 S DONE=1 Q - .. I OVERLAP="R",SDIR=1 S DONE=1 Q - ;Return up to NGET of the most recent/oldest entries. - S NFOUND=0,TDATE="" - F S TDATE=$O(TLIST(TDATE),SDIR) Q:(TDATE="")!(NFOUND=NGET) D - . S TIND=0 - . F S TIND=$O(TLIST(TDATE,TIND)) Q:(TIND="")!(NFOUND=NGET) D - .. S NFOUND=NFOUND+1,FLIST(NFOUND)=TLIST(TDATE,TIND) - Q - ; - ;================================================================ -OVERLAP(START,STOP,BDT,EDT) ;Determine if the date range defined by START and - ;STOP overlaps with the date range defined by BDT and EDT. The return - ;value "O" means they overlap, "L" means START, STOP is to the - ;left of BDT, EDT and "R" means it is to the right. - I EDTEDTT,SDIR=1 S DONE=1 Q + . S DAS=$O(^PXRMINDX(FILENUM,SNODE,DFN,ITEM,DATE,"")) + . S NFOUND=NFOUND+1 + . S FLIST(NFOUND)=DAS_U_DATE + . I NFOUND=NGET S DONE=1 Q + Q + ; + ;================================================================ +FPDATSS(FILENUM,SNODE,DFN,ITEM,NGET,SDIR,BDT,EDT,USESTRT,NFOUND,FLIST) ;Find + ;patient data for findings that have a start and stop date. FLIST + ;is returned in date order, i.e., FLIST(1) is the most recent. + N DAS,DONE,EDTT,OVERLAP,SDATE,START,STOP,TDATE,TIND,TLIST + S EDTT=$S(EDT[".":EDT+.0000001,1:EDT+.240001) + S (DONE,NFOUND)=0 + S START=$S(SDIR=+1:0,1:EDTT) + F S START=+$O(^PXRMINDX(FILENUM,SNODE,DFN,ITEM,START),SDIR) Q:(START=0)!(DONE)!(START>EDTT) D + . S STOP="" + . F S STOP=$O(^PXRMINDX(FILENUM,SNODE,DFN,ITEM,START,STOP),SDIR) Q:(STOP="")!(DONE) D + ..;Items that do not have a stop date are flagged by "U". + .. S SDATE=$S(USESTRT:START,STOP["U":$$NOW^PXRMDATE_"U",1:STOP) + .. S OVERLAP=$$OVERLAP(START,SDATE,BDT,EDT) + .. I OVERLAP="O" D + ... S DAS=$O(^PXRMINDX(FILENUM,SNODE,DFN,ITEM,START,STOP,"")) + ... S NFOUND=NFOUND+1,TLIST(SDATE,NFOUND)=DAS_U_SDATE + ..;Some orders and non-VA meds may not have a Stop Date so we have + ..;to check all entries. + .. I FILENUM="55NVA" Q + .. I FILENUM=100 Q + .. I OVERLAP="L",SDIR=-1 S DONE=1 Q + .. I OVERLAP="R",SDIR=1 S DONE=1 Q + ;Return up to NGET of the most recent/oldest entries. + S NFOUND=0,TDATE="" + F S TDATE=$O(TLIST(TDATE),SDIR) Q:(TDATE="")!(NFOUND=NGET) D + . S TIND=0 + . F S TIND=$O(TLIST(TDATE,TIND)) Q:(TIND="")!(NFOUND=NGET) D + .. S NFOUND=NFOUND+1,FLIST(NFOUND)=TLIST(TDATE,TIND) + Q + ; + ;================================================================ +OVERLAP(START,STOP,BDT,EDT) ;Determine if the date range defined by START and + ;STOP overlaps with the date range defined by BDT and EDT. The return + ;value "O" means they overlap, "L" means START, STOP is to the + ;left of BDT, EDT and "R" means it is to the right. + I EDT0 S NE=NE+1 - .;Process the refill mutiple. - . S DA1=0 - . F S DA1=+$O(^PSRX(DA,1,DA1)) Q:DA1=0 D - .. S TEMP=$G(^PSRX(DA,1,DA1,0)) - .. S DSUP=+$P(TEMP,U,10) - .. S RDATE=+$P(TEMP,U,18) - .. I RDATE>0 S NE=NE+1 - .;Process the partial fill multiple. - . S DA1=0 - . F S DA1=+$O(^PSRX(DA,"P",DA1)) Q:DA1=0 D - .. S TEMP=$G(^PSRX(DA,"P",DA1,0)) - .. S DSUP=+$P(TEMP,U,10) - .. S RDATE=+$P(TEMP,U,19) - .. I RDATE>0 S NE=NE+1 - Q NE - ; - ;=============================================================== -NEPTF() ;Return number of entries in PTF. - N D1,DA,DATE,DFN,ICD0,ICD9,JND,NE0,NE9,TEMP70,TEMP0,TEMPP,TEMPS - ;DBIA #4177 - S (DA,NE0,NE9)=0 - F S DA=+$O(^DGPT(DA)) Q:DA=0 D - . S TEMP0=$G(^DGPT(DA,0)) - . S DFN=$P(TEMP0,U,1) - . I DFN="" Q - . S D1=0 - . F S D1=+$O(^DGPT(DA,"S",D1)) Q:D1=0 D - .. S TEMPS=$G(^DGPT(DA,"S",D1,0)) - .. S DATE=$P(TEMPS,U,1) - .. I DATE="" Q - .. F JND=8,9,10,11,12 D - ... S ICD0=$P(TEMPS,U,JND) - ... I (ICD0'=""),$D(^ICD0(ICD0)) S NE0=NE0+1 - .; - . S D1=0 - . F S D1=+$O(^DGPT(DA,"P",D1)) Q:D1=0 D - .. S TEMPP=$G(^DGPT(DA,"P",D1,0)) - .. S DATE=$P(TEMPP,U,1) - .. I DATE="" Q - .. F JND=5,6,7,8,9 D - ... S ICD0=$P(TEMPP,U,JND) - ... I (ICD0'=""),$D(^ICD0(ICD0)) S NE0=NE0+1 - .; - .;Discharge ICD9 codes - . I $D(^DGPT(DA,70)) D - .. S TEMP70=$G(^DGPT(DA,70)) - .. F JND=10,11,16,17,18,19,20,21,22,23,24 D - ... S ICD9=$P(TEMP70,U,JND) - ... I (ICD9'=""),$D(^ICD9(ICD9)) S NE9=NE9+1 - .; - .;Movement ICD9 codes - . I '$D(^DGPT(DA,"M")) Q - . S D1=0 - . F S D1=$O(^DGPT(DA,"M",D1)) Q:+D1=0 D - .. S TEMPS=$G(^DGPT(DA,"M",D1,0)) - .. S DATE=$P(TEMPS,U,10) - .. I DATE="" Q - .. F JND=5,6,7,8,9,11,12,13,14,15 D - ... S ICD9=$P(TEMPS,U,JND) - ... I (ICD9'=""),$D(^ICD9(ICD9)) S NE9=NE9+1 - Q NE0+NE9 - ; - ;=============================================================== -NERAD() ;Return number of entries in RAD/NUC MED PATIENT. - N IEN,NE - ;DBIA #4183 - S (IEN,NE)=0 - F S IEN=$O(^RADPT(IEN)) Q:+IEN=0 S NE=NE+$P($G(^RADPT(IEN,"DT",0)),U,4) - Q NE - ; - ;=============================================================== -NEVCPT() ;Return number of entries in V CPT. - ;DBIA #4176 - Q $P(^AUPNVCPT(0),U,4) - ; - ;=============================================================== -NEVHF() ;Return number of entries in V HEALTH FACTORS. - ;DBIA #4176 - Q $P(^AUPNVHF(0),U,4) - ; - ;=============================================================== -NEVIMM() ;Return number of entries in V IMMUNIZATION - ;DBIA #4176 - Q $P(^AUPNVIMM(0),U,4) - ; - ;=============================================================== -NEVIT() ;Return number of entries in GMRV VITAL MEASUREMENT - ;DBIA #4178 - Q $P(^GMR(120.5,0),U,4) - ; - ;=============================================================== -NEVPED() ;Return number of entries in V PATIENT ED. - ;DBIA #4176 - Q $P(^AUPNVPED(0),U,4) - ; - ;=============================================================== -NEVPOV() ;Return number of entries in V POV. - ;DBIA #4176 - Q $P(^AUPNVPOV(0),U,4) - ; - ;=============================================================== -NEVSK() ;Return number of entries in V SKIN TEST. - ;DBIA #4176 - Q $P(^AUPNVSK(0),U,4) - ; - ;=============================================================== -NEVXAM() ;Return number of entries in V EXAM. - ;DBIA #4176 - Q $P(^AUPNVXAM(0),U,4) - ; - ;=============================================================== -NEYTD() ;Return number of entries in PSYCH INSTRUMENT PATIENT - N DATE,DFN,NE,TEST - ;DBIA #4184 - S (DFN,NE)=0 - F S DFN=$O(^YTD(601.2,DFN)) Q:+DFN=0 D - . S TEST=0 - . F S TEST=$O(^YTD(601.2,DFN,1,TEST)) Q:+TEST=0 D - .. S DATE=0 - .. F S DATE=$O(^YTD(601.2,DFN,1,TEST,1,DATE)) Q:+DATE=0 S NE=NE+1 - Q NE - ; - ;=============================================================== -SETDATA(GBL,GLIST,NUMGBL,RTN,SF) ; - S NUMGBL=16 - S GLIST(1)="LABORATORY TEST (CH, Anatomic Path, Micro)",GBL(1)=63 - S GLIST(2)="MENTAL HEALTH",GBL(2)=601.2 - S GLIST(3)="ORDER",GBL(3)=100 - S GLIST(4)="PTF",GBL(4)=45 - S GLIST(5)="PHARMACY PATIENT",GBL(5)=55 - S GLIST(6)="PRESCRIPTION",GBL(6)=52 - S GLIST(7)="PROBLEM LIST",GBL(7)=9000011 - S GLIST(8)="RADIOLOGY",GBL(8)=70 - S GLIST(9)="V CPT",GBL(9)=9000010.18 - S GLIST(10)="V EXAM",GBL(10)=9000010.13 - S GLIST(11)="V HEALTH FACTORS",GBL(11)=9000010.23 - S GLIST(12)="V IMMUNIZATION",GBL(12)=9000010.11 - S GLIST(13)="V PATIENT ED",GBL(13)=9000010.16 - S GLIST(14)="V POV",GBL(14)=9000010.07 - S GLIST(15)="V SKIN TEST",GBL(15)=9000010.12 - S GLIST(16)="VITAL MEASUREMENT",GBL(16)=120.5 - S RTN(45)="NEPTF^PXRMISE" - S RTN(52)="NEPSRX^PXRMISE" - S RTN(55)="NEPS^PXRMISE" - S RTN(63)="NELR^PXRMLABS" - S RTN(70)="NERAD^PXRMISE" - S RTN(100)="NEOR^PXRMISE" - S RTN(120.5)="NEVIT^PXRMISE" - S RTN(601.2)="NEYTD^PXRMISE" - S RTN(9000011)="NEPROB^PXRMISE" - S RTN(9000010.07)="NEVPOV^PXRMISE" - S RTN(9000010.11)="NEVIMM^PXRMISE" - S RTN(9000010.12)="NEVSK^PXRMISE" - S RTN(9000010.13)="NEVXAM^PXRMISE" - S RTN(9000010.16)="NEVPED^PXRMISE" - S RTN(9000010.18)="NEVCPT^PXRMISE" - S RTN(9000010.23)="NEVHF^PXRMISE" - D LSF^PXRMISF(.SF) - Q - ; +PXRMISE ; SLC/PKR - Index size estimating routines. ;01/12/2005 + ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005 + ; + ;======================================================== +EST ;Driver for making index counts. + N BLOCKS,FUNCTION,GBL,GLIST,IND,NE,NL,NUMGBL,RTN + N SF,TASKIT,TBLOCKS,XMSUB + D SETDATA(.GBL,.GLIST,.NUMGBL,.RTN,.SF) + I +SF=-1 D ERRORMSG^PXRMISF(SF) Q + S (NL,TBLOCKS)=0 + S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)="Start time "_$$FMTE^XLFDT($$NOW^XLFDT,"5Z") + S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)="" + S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)="Size Estimate for ^PXRMINDX" + F IND=1:1:NUMGBL D + . S FUNCTION="S NE=$$"_RTN(GBL(IND)) + . X FUNCTION + . S BLOCKS=NE*SF(GBL(IND)) + . S BLOCKS=$FN(BLOCKS,"","")+1 + . S TBLOCKS=TBLOCKS+BLOCKS + . S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)="" + . S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)="Estimates for "_GLIST(IND) + . S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=" Number of entries: "_NE + . S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=" Number of blocks: "_BLOCKS + S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)="" + S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)="Total estimated blocks: "_TBLOCKS + S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)="" + S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)="End time "_$$FMTE^XLFDT($$NOW^XLFDT,"5Z") + S XMSUB="Size estimate for index global" + D SEND^PXRMMSG(XMSUB) + S ZTREQ="@" + Q + ; + ;=============================================================== +ESTTASK ;Task the index size estimation. + N DIR,DTOUT,DUOUT,MINDT,SDTIME,X,Y + S MINDT=$$NOW^XLFDT + 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")="It must be after "_$$FMTE^XLFDT(MINDT,"5Z")_" " + S DIR(0)="DAU"_U_MINDT_"::RSX" + D ^DIR + I $D(DTOUT)!$D(DUOUT) Q + S SDTIME=Y + K DIR + ;Put the task into the queue. + S ZTRTN="EST^PXRMISE" + S ZTDESC="Clinical Reminders index size estimation" + S ZTDTH=SDTIME + S ZTIO="" + D ^%ZTLOAD + W !,"Task number ",ZTSK," queued." + Q + ; + ;=============================================================== +NEOR() ;Return number of entries in OR. + ;DBIA #4180 + Q $P(^OR(100,0),U,4) + ; + ;=============================================================== +NEPROB() ;Return number of entries in PROBLEM LIST. + ;DBIA #3837 + Q $P(^AUPNPROB(0),U,4) + ; + ;=============================================================== +NEPS() ;Return number of entries in PS(55). + N ADD,DA,DA1,DFN,DRUG,IND,NE,SDATE,SOL,STARTD,TEMP + ;DBIA #4181 + S (DFN,IND,NE)=0 + F S DFN=+$O(^PS(55,DFN)) Q:DFN=0 D + .;Process Unit Dose. + . S DA=0 + . F S DA=+$O(^PS(55,DFN,5,DA)) Q:DA=0 D + .. S TEMP=$G(^PS(55,DFN,5,DA,2)) + .. S STARTD=$P(TEMP,U,2) + .. I STARTD="" Q + ..;If the order is purged then SDATE is 1. + .. S SDATE=$P(TEMP,U,4) + .. I SDATE=1 Q + .. S DA1=0 + .. F S DA1=+$O(^PS(55,DFN,5,DA,1,DA1)) Q:DA1=0 D + ... S DRUG=$P(^PS(55,DFN,5,DA,1,DA1,0),U,1) + ... I DRUG="" Q + ... S NE=NE+1 + .;Process the IV mutiple. + . S DA=0 + . F S DA=+$O(^PS(55,DFN,"IV",DA)) Q:DA=0 D + .. S TEMP=$G(^PS(55,DFN,"IV",DA,0)) + .. S STARTD=$P(TEMP,U,2) + .. I STARTD="" Q + .. S SDATE=$P(TEMP,U,3) + .. I SDATE=1 Q + ..;Process Additives + .. S DA1=0 + .. F S DA1=+$O(^PS(55,DFN,"IV",DA,"AD",DA1)) Q:DA1=0 D + ... S ADD=$P(^PS(55,DFN,"IV",DA,"AD",DA1,0),U,1) + ... I ADD="" Q + ... S DRUG=$P($G(^PS(52.6,ADD,0)),U,2) + ... I DRUG="" Q + ... S NE=NE+1 + ..;Process Solutions + .. S DA1=0 + .. F S DA1=+$O(^PS(55,DFN,"IV",DA,"SOL",DA1)) Q:DA1=0 D + ... S SOL=$P(^PS(55,DFN,"IV",DA,"SOL",DA1,0),U,1) + ... I SOL="" Q + ... S DRUG=$P($G(^PS(52.7,SOL,0)),U,2) + ... I DRUG="" Q + ... S NE=NE+1 + Q NE + ; + ;=============================================================== +NEPSRX() ;Return number of entries in PSRX + N DA,DA1,DATE,DSUP,DFN,DRUG,NE,RDATE,TEMP + ;DBIA #4182 + S (DA,NE)=0 + F S DA=+$O(^PSRX(DA)) Q:DA=0 D + . S TEMP=$G(^PSRX(DA,0)) + . S DFN=$P(TEMP,U,2) + . I DFN="" Q + . S DRUG=$P(TEMP,U,6) + . I DRUG="" Q + . S DSUP=$P(TEMP,U,8) + . I DSUP="" Q + . S RDATE=+$P($G(^PSRX(DA,2)),U,13) + . I RDATE>0 S NE=NE+1 + .;Process the refill mutiple. + . S DA1=0 + . F S DA1=+$O(^PSRX(DA,1,DA1)) Q:DA1=0 D + .. S TEMP=$G(^PSRX(DA,1,DA1,0)) + .. S DSUP=+$P(TEMP,U,10) + .. S RDATE=+$P(TEMP,U,18) + .. I RDATE>0 S NE=NE+1 + .;Process the partial fill multiple. + . S DA1=0 + . F S DA1=+$O(^PSRX(DA,"P",DA1)) Q:DA1=0 D + .. S TEMP=$G(^PSRX(DA,"P",DA1,0)) + .. S DSUP=+$P(TEMP,U,10) + .. S RDATE=+$P(TEMP,U,19) + .. I RDATE>0 S NE=NE+1 + Q NE + ; + ;=============================================================== +NEPTF() ;Return number of entries in PTF. + N D1,DA,DATE,DFN,ICD0,ICD9,JND,NE0,NE9,TEMP70,TEMP0,TEMPP,TEMPS + ;DBIA #4177 + S (DA,NE0,NE9)=0 + F S DA=+$O(^DGPT(DA)) Q:DA=0 D + . S TEMP0=$G(^DGPT(DA,0)) + . S DFN=$P(TEMP0,U,1) + . I DFN="" Q + . S D1=0 + . F S D1=+$O(^DGPT(DA,"S",D1)) Q:D1=0 D + .. S TEMPS=$G(^DGPT(DA,"S",D1,0)) + .. S DATE=$P(TEMPS,U,1) + .. I DATE="" Q + .. F JND=8,9,10,11,12 D + ... S ICD0=$P(TEMPS,U,JND) + ... I (ICD0'=""),$D(^ICD0(ICD0)) S NE0=NE0+1 + .; + . S D1=0 + . F S D1=+$O(^DGPT(DA,"P",D1)) Q:D1=0 D + .. S TEMPP=$G(^DGPT(DA,"P",D1,0)) + .. S DATE=$P(TEMPP,U,1) + .. I DATE="" Q + .. F JND=5,6,7,8,9 D + ... S ICD0=$P(TEMPP,U,JND) + ... I (ICD0'=""),$D(^ICD0(ICD0)) S NE0=NE0+1 + .; + .;Discharge ICD9 codes + . I $D(^DGPT(DA,70)) D + .. S TEMP70=$G(^DGPT(DA,70)) + .. F JND=10,11,16,17,18,19,20,21,22,23,24 D + ... S ICD9=$P(TEMP70,U,JND) + ... I (ICD9'=""),$D(^ICD9(ICD9)) S NE9=NE9+1 + .; + .;Movement ICD9 codes + . I '$D(^DGPT(DA,"M")) Q + . S D1=0 + . F S D1=$O(^DGPT(DA,"M",D1)) Q:+D1=0 D + .. S TEMPS=$G(^DGPT(DA,"M",D1,0)) + .. S DATE=$P(TEMPS,U,10) + .. I DATE="" Q + .. F JND=5,6,7,8,9,11,12,13,14,15 D + ... S ICD9=$P(TEMPS,U,JND) + ... I (ICD9'=""),$D(^ICD9(ICD9)) S NE9=NE9+1 + Q NE0+NE9 + ; + ;=============================================================== +NERAD() ;Return number of entries in RAD/NUC MED PATIENT. + N IEN,NE + ;DBIA #4183 + S (IEN,NE)=0 + F S IEN=$O(^RADPT(IEN)) Q:+IEN=0 S NE=NE+$P($G(^RADPT(IEN,"DT",0)),U,4) + Q NE + ; + ;=============================================================== +NEVCPT() ;Return number of entries in V CPT. + ;DBIA #4176 + Q $P(^AUPNVCPT(0),U,4) + ; + ;=============================================================== +NEVHF() ;Return number of entries in V HEALTH FACTORS. + ;DBIA #4176 + Q $P(^AUPNVHF(0),U,4) + ; + ;=============================================================== +NEVIMM() ;Return number of entries in V IMMUNIZATION + ;DBIA #4176 + Q $P(^AUPNVIMM(0),U,4) + ; + ;=============================================================== +NEVIT() ;Return number of entries in GMRV VITAL MEASUREMENT + ;DBIA #4178 + Q $P(^GMR(120.5,0),U,4) + ; + ;=============================================================== +NEVPED() ;Return number of entries in V PATIENT ED. + ;DBIA #4176 + Q $P(^AUPNVPED(0),U,4) + ; + ;=============================================================== +NEVPOV() ;Return number of entries in V POV. + ;DBIA #4176 + Q $P(^AUPNVPOV(0),U,4) + ; + ;=============================================================== +NEVSK() ;Return number of entries in V SKIN TEST. + ;DBIA #4176 + Q $P(^AUPNVSK(0),U,4) + ; + ;=============================================================== +NEVXAM() ;Return number of entries in V EXAM. + ;DBIA #4176 + Q $P(^AUPNVXAM(0),U,4) + ; + ;=============================================================== +NEYTD() ;Return number of entries in PSYCH INSTRUMENT PATIENT + N DATE,DFN,NE,TEST + ;DBIA #4184 + S (DFN,NE)=0 + F S DFN=$O(^YTD(601.2,DFN)) Q:+DFN=0 D + . S TEST=0 + . F S TEST=$O(^YTD(601.2,DFN,1,TEST)) Q:+TEST=0 D + .. S DATE=0 + .. F S DATE=$O(^YTD(601.2,DFN,1,TEST,1,DATE)) Q:+DATE=0 S NE=NE+1 + Q NE + ; + ;=============================================================== +SETDATA(GBL,GLIST,NUMGBL,RTN,SF) ; + S NUMGBL=16 + S GLIST(1)="LABORATORY TEST (CH, Anatomic Path, Micro)",GBL(1)=63 + S GLIST(2)="MENTAL HEALTH",GBL(2)=601.2 + S GLIST(3)="ORDER",GBL(3)=100 + S GLIST(4)="PTF",GBL(4)=45 + S GLIST(5)="PHARMACY PATIENT",GBL(5)=55 + S GLIST(6)="PRESCRIPTION",GBL(6)=52 + S GLIST(7)="PROBLEM LIST",GBL(7)=9000011 + S GLIST(8)="RADIOLOGY",GBL(8)=70 + S GLIST(9)="V CPT",GBL(9)=9000010.18 + S GLIST(10)="V EXAM",GBL(10)=9000010.13 + S GLIST(11)="V HEALTH FACTORS",GBL(11)=9000010.23 + S GLIST(12)="V IMMUNIZATION",GBL(12)=9000010.11 + S GLIST(13)="V PATIENT ED",GBL(13)=9000010.16 + S GLIST(14)="V POV",GBL(14)=9000010.07 + S GLIST(15)="V SKIN TEST",GBL(15)=9000010.12 + S GLIST(16)="VITAL MEASUREMENT",GBL(16)=120.5 + S RTN(45)="NEPTF^PXRMISE" + S RTN(52)="NEPSRX^PXRMISE" + S RTN(55)="NEPS^PXRMISE" + S RTN(63)="NELR^PXRMLABS" + S RTN(70)="NERAD^PXRMISE" + S RTN(100)="NEOR^PXRMISE" + S RTN(120.5)="NEVIT^PXRMISE" + S RTN(601.2)="NEYTD^PXRMISE" + S RTN(9000011)="NEPROB^PXRMISE" + S RTN(9000010.07)="NEVPOV^PXRMISE" + S RTN(9000010.11)="NEVIMM^PXRMISE" + S RTN(9000010.12)="NEVSK^PXRMISE" + S RTN(9000010.13)="NEVXAM^PXRMISE" + S RTN(9000010.16)="NEVPED^PXRMISE" + S RTN(9000010.18)="NEVCPT^PXRMISE" + S RTN(9000010.23)="NEVHF^PXRMISE" + D LSF^PXRMISF(.SF) + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMLCD.m b/r/CLINICAL_REMINDERS-PXRM/PXRMLCD.m index 06277ecc..393b82c5 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMLCD.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMLCD.m @@ -1,51 +1,50 @@ -PXRMLCD ; SLC/PKR - Reminder Patient List Patients ;11/02/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ;Display list creation documentation. - ;=========================================================== -DCDOC ;Display creation documentation. - N IND,LISTIEN,VALMY - D EN^VALM2(XQORNOD(0)) - ;If there is no list quit. - I '$D(VALMY) Q - ;PXRMDONE is newed in PXRMLPU - S IND="",PXRMDONE=0 - F S IND=$O(VALMY(IND)) Q:(IND="")!(PXRMDONE) D - . S LISTIEN=^TMP("PXRMLPU",$J,"SEL",IND) - . D EN^PXRMLCD(LISTIEN) - S VALMBCK="R" - Q - ; - ;=========================================================== -EN(LISTIEN) ; - N VALMBCK,VALMBG,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD - K ^TMP("PXRMLCD",$J) - I $D(^PXRMXP(810.5,LISTIEN,200)) D - . M ^TMP("PXRMLCD",$J)=^PXRMXP(810.5,LISTIEN,200) - . S VALMCNT=$P(^PXRMXP(810.5,LISTIEN,200,0),U,4) - I '$D(^PXRMXP(810.5,LISTIEN,200)) D - . S ^TMP("PXRMLCD",$J,1,0)="No documentation is available." - . S VALMCNT=1 - D EN^VALM("PXRM PATIENT LIST CREATION DOC") - Q - ; - ;=========================================================== -EXIT ;Exit code - K ^TMP("PXRMLCD",$J) - D CLEAN^VALM10 - D FULL^VALM1 - S VALMBCK="R" - Q - ; - ;=========================================================== -HDR ; Header code - S VALMHDR(1)="Documentation for creation of patient list:" - S VALMHDR(2)=" "_$P(^PXRMXP(810.5,LISTIEN,0),U,1) - S VALMSG="+ Next Screen - Prev Screen ?? More Actions" - Q - ; - ;=========================================================== -HELP ;Help code - S X="?" D DISP^XQORM1 W !! - Q - ; +PXRMLCD ; SLC/PKR - Reminder Patient List Patients ;06/30/2005 + ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21 + ; + ;Display list creation documentation. + ;=========================================================== +DCDOC ;Display creation documentation. + N IND,LISTIEN,VALMY + D EN^VALM2(XQORNOD(0)) + ;If there is no list quit. + I '$D(VALMY) Q + ;PXRMDONE is newed in PXRMLPU + S IND="",PXRMDONE=0 + F S IND=$O(VALMY(IND)) Q:(IND="")!(PXRMDONE) D + . S LISTIEN=^TMP("PXRMLPU",$J,"IDX",IND,IND) + . D EN^PXRMLCD(LISTIEN) + S VALMBCK="R" + Q + ; + ;=========================================================== +EN(LISTIEN) ; + N VALMBCK,VALMBG,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD + K ^TMP("PXRMLCD",$J) + I $D(^PXRMXP(810.5,LISTIEN,200)) D + . M ^TMP("PXRMLCD",$J)=^PXRMXP(810.5,LISTIEN,200) + . S VALMCNT=$P(^PXRMXP(810.5,LISTIEN,200,0),U,4) + I '$D(^PXRMXP(810.5,LISTIEN,200)) D + . S ^TMP("PXRMLCD",$J,1,0)="No documentation is available." + . S VALMCNT=1 + D EN^VALM("PXRM PATIENT LIST CREATION DOC") + Q + ; + ;=========================================================== +EXIT ;Exit code + K ^TMP("PXRMLCD",$J) + D CLEAN^VALM10 + D FULL^VALM1 + S VALMBCK="R" + Q + ; + ;=========================================================== +HDR ; Header code + 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 + ; + ;=========================================================== +HELP ;Help code + S X="?" D DISP^XQORM1 W !! + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMLCR.m b/r/CLINICAL_REMINDERS-PXRM/PXRMLCR.m index e2723a81..3bde7af0 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMLCR.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMLCR.m @@ -1,168 +1,165 @@ -PXRMLCR ; SLC/PJH - Create Patient List from individual finding rule; 10/18/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ; Called from PXRM PATIENT LIST CREATE protocol - ; -START N BEG,DUOUT,DTOUT,END,LIT,PXRMDPAT,PXRMLIST,PXRMNODE,PXRMRULE,PXRMTPAT - N TEXT - ;Initialise - K ^TMP("PXRMLCR",$J) - ;Node for ^TMP lists created in PXRMRULE - S PXRMNODE="PXRMRULE",LIT="Patient List" - ;Reset screen mode - W IORESET - ;Set prompt text - S TEXT="Select PATIENT LIST name: " - ;Select Patient List -LIST D PLIST(.PXRMLIST,TEXT,"") I $D(DUOUT)!$D(DTOUT) D Q - . I $G(PXRMLIST)="" Q - . I $P($G(^PXRMXP(810.5,PXRMLIST,0)),U,4)'="" Q - . S DA=PXRMLIST,DIK="^PXRMXP(810.5," D ^DIK - ; -SECURE ;option to secure the list - K PATCREAT - I $D(PATCREAT)=0 S PATCREAT="N" D ASK^PXRMXD(.PATCREAT,"Secure list?: ",2) Q:$D(DTOUT) G:$D(DUOUT) START - ; -PURGE ;Option to purge the list - K PLISTPUG - S PLISTPUG="N" D ASK^PXRMXD(.PLISTPUG,"Purge Patient List after 5 years?: ",5) Q:$D(DTOUT) G:$D(DUOUT) SECURE - ;Select rule set. -RULE D LRULE(.PXRMRULE) Q:$D(DTOUT) G:$D(DUOUT) LIST - ;Select Date Range -DATE D DATES^PXRMEUT(.BEG,.END,LIT) Q:$D(DTOUT) G:$D(DUOUT) RULE - ; - ;Ask whether to include deceased and test patients. -DPAT S PXRMDPAT=$$ASKYN^PXRMEUT("N","Include deceased patients on the list") - Q:$D(DTOUT) G:$D(DUOUT) DATE -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 - S ZTDESC="CREATE PATIENT LIST" - S ZTRTN="RUN^PXRMLCR(PXRMRULE,PXRMLIST,PXRMNODE,BEG,END,PXRMDPAT,PXRMTPAT)" - S ZTSAVE("BEG")="" - S ZTSAVE("END")="" - S ZTSAVE("PATCREAT")="" - S ZTSAVE("PXRMDPAT")="" - S ZTSAVE("PXRMLIST")="" - S ZTSAVE("PXRMNODE")="" - S ZTSAVE("PXRMRULE")="" - S ZTSAVE("PXRMTPAT")="" - S ZTSAVE("PLISTPUG")="" - S ZTIO="" - ; - ;Select and verify start date/time for task - N DIR,DTOUT,DUOUT,MINDT,SDTIME,STIME,X,Y - S MINDT=$$NOW^XLFDT - W !,"Queue the "_ZTDESC_" for "_$P($G(^PXRMXP(810.5,PXRMLIST,0)),U)_": " - 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(0)="DAU"_U_MINDT_"::RSX" - D ^DIR - I $D(DTOUT)!$D(DUOUT) Q - S SDTIME=Y - ; - ;Put the task into the queue. - S ZTDTH=SDTIME - D ^%ZTLOAD - W !,"Task number ",ZTSK," queued." H 2 -EXIT Q - ; -HELP(CALL) ;General help text routine - N HTEXT - I CALL=1 D - .S HTEXT(1)="Enter 'Y' to overwrite this existing list. Enter 'N' to" - .S HTEXT(2)="use a different patient list name." - ; - I CALL=2 D - .S HTEXT(1)="Enter 'Y' to make the list private or 'N' to make it public." - .S HTEXT(2)="You can give other users access to your private lists in the Patient List Menu screens." - ; - I CALL=3 D - .S HTEXT(1)="Enter Y to save the patient to a Reminder Patient List. Enter N to not save the output." - ; - 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!" - D HELP^PXRMEUT(.HTEXT) - Q - ; -PLIST(LIST,TEXT,IENO) ;Select Patient List - N X,Y,DIC,DLAYGO -PL1 S DIC=810.5,DLAYGO=DIC,DIC(0)="QAEMZL" - 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" - W ! - D ^DIC - I X="" W !,"A patient list name must be entered" G PL1 - I X=(U_U) S DTOUT=1 - I Y=-1 S DUOUT=1 - I $D(DTOUT)!$D(DUOUT) Q - ; - ;I copy mode dissallow copy to same list - I IENO=$P(Y,U) W !,"A patient list cannot be copied to itself." G PL1 - ; - I ($P(Y,U,3)=1) S LIST=$P(Y,U) Q - ;Check if OK to overwrite - N OWRITE - S OWRITE=$$ASKYN^PXRMEUT("N","Okay to overwite "_$P(Y,U,2),"PXRMLCR",1) - Q:$D(DTOUT) G:$D(DUOUT)!('OWRITE) PL1 - S OWRITE=$$LDELOK^PXRMEUT($P(Y,U,1)) - I 'OWRITE D G PL1 - . W !,"In order to overwrite a list you must be the creator or a Reminder Manager!" - ;Return list ien - S LIST=$P(Y,U) - Q - ; -LRULE(RULE) ;Select List Rule - N X,Y,DIC -LR1 S DIC=810.4,DIC(0)="QAEMZ" - S DIC("A")="Select LIST RULE SET: " - ;Only allow rule sets with components - S DIC("S")="I $P(^(0),U,3)=3" - W ! - D ^DIC - I X="" W !,"A list rule set name must be entered" G LR1 - I X=(U_U) S DTOUT=1 - I Y=-1 S DUOUT=1 - I $D(DTOUT)!$D(DUOUT) Q - ;Return rule ien - S RULE=$P(Y,U) - ;Check that rule set is valid - N ERROR,LR,LRTYPE,NL,OP,SEQ,SUB,TEMP,TEXT - S SUB=$O(^PXRM(810.4,RULE,30,0)) - I SUB="" W !,"Rule set has no component rules" G LR1 - S (ERROR,SUB)=0,NL=1 - F S SUB=$O(^PXRM(810.4,RULE,30,SUB)) Q:'SUB D Q:ERROR - .S TEMP=$G(^PXRM(810.4,RULE,30,SUB,0)) - .S SEQ=$P(TEMP,U,1),LR=$P(TEMP,U,2),OP=$P(TEMP,U,3) - .I SEQ="" S NL=NL+1,TEXT(NL)=" Sequence is missing.",ERROR=1 - .I LR="" S NL=NL+1,TEXT(NL)=" List rule is missing.",ERROR=1 - .I OP="" S NL=NL+1,TEXT(NL)=" Operation is missing.",ERROR=1 - .;The Insert operation can only be used with finding rules. - .I OP="F",LR'="" D - ..S LRTYPE=$P(^PXRM(810.4,LR,0),U,3) - ..I LRTYPE'=1 S NL=NL+1,TEXT(NL)=" Insert operation can only be used with finding rules.",ERROR=1 - I ERROR D G LR1 - .S TEXT(1)="The rule set is incomplete or incorrect:" - .D EN^DDIOL(.TEXT) - Q - ; - ;Build list and clear ^TMP files -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,"") - ;Clear ^TMP lists created for rule - D CLEAR^PXRMRULE(PXRMRULE,PXRMNODE) - Q - ; -REMOVE(IEN) ; - S $P(^PXRM(810.4,IEN,0),U,10)="" - Q "@1" - ; +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 + ; +START N BEG,DUOUT,DTOUT,END,LIT,PXRMDPAT,PXRMLIST,PXRMNODE,PXRMRULE,PXRMTPAT + N TEXT + ;Initialise + K ^TMP("PXRMLCR",$J) + ;Node for ^TMP lists created in PXRMRULE + S PXRMNODE="PXRMRULE",LIT="Patient List" + ;Reset screen mode + W IORESET + ;Set prompt text + S TEXT="Select PATIENT LIST name: " + ;Select Patient List +LIST D PLIST(.PXRMLIST,TEXT,"") I $D(DUOUT)!$D(DTOUT) D Q + . I $G(PXRMLIST)="" Q + . I $P($G(^PXRMXP(810.5,PXRMLIST,0)),U,4)'="" Q + . S DA=PXRMLIST,DIK="^PXRMXP(810.5," D ^DIK + ; +SECURE ;option to secure the list + K PATCREAT + I $D(PATCREAT)=0 S PATCREAT="N" D ASK^PXRMXD(.PATCREAT,"Secure list?: ",2) Q:$D(DTOUT) G:$D(DUOUT) START + ; +PURGE ;Option to purge the list + K PLISTPUG + S PLISTPUG="N" D ASK^PXRMXD(.PLISTPUG,"Purge Patient List after 5 years?: ",5) Q:$D(DTOUT) G:$D(DUOUT) SECURE + ;Select rule set. +RULE D LRULE(.PXRMRULE) Q:$D(DTOUT) G:$D(DUOUT) LIST + ;Select Date Range +DATE D DATES^PXRMEUT(.BEG,.END,LIT) Q:$D(DTOUT) G:$D(DUOUT) RULE + ; + ;Ask whether to include deceased and test patients. +DPAT S PXRMDPAT=$$ASKYN^PXRMEUT("N","Include deceased patients on the list") + Q:$D(DTOUT) G:$D(DUOUT) DATE +TPAT S PXRMTPAT=$$ASKYN^PXRMEUT("N","Include test patients on the list") + Q:$D(DTOUT) G:$D(DUOUT) DPAT + ;Build patient list in background + N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE + S ZTDESC="CREATE PATIENT LIST" + S ZTRTN="RUN^PXRMLCR(PXRMRULE,PXRMLIST,PXRMNODE,BEG,END,PXRMDPAT,PXRMTPAT)" + S ZTSAVE("BEG")="" + S ZTSAVE("END")="" + S ZTSAVE("PATCREAT")="" + S ZTSAVE("PXRMDPAT")="" + S ZTSAVE("PXRMLIST")="" + S ZTSAVE("PXRMNODE")="" + S ZTSAVE("PXRMRULE")="" + S ZTSAVE("PXRMTPAT")="" + S ZTSAVE("PLISTPUG")="" + S ZTIO="" + ; + ;Select and verify start date/time for task + N DIR,DTOUT,DUOUT,MINDT,SDTIME,STIME,X,Y + S MINDT=$$NOW^XLFDT + W !,"Queue the "_ZTDESC_" for "_$P($G(^PXRMXP(810.5,PXRMLIST,0)),U)_": " + 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(0)="DAU"_U_MINDT_"::RSX" + D ^DIR + I $D(DTOUT)!$D(DUOUT) Q + S SDTIME=Y + ; + ;Put the task into the queue. + S ZTDTH=SDTIME + D ^%ZTLOAD + W !,"Task number ",ZTSK," queued." H 2 +EXIT Q + ; +HELP(CALL) ;General help text routine + N HTEXT + I CALL=1 D + .S HTEXT(1)="Enter 'Y' to overwrite this existing list. Enter 'N' to" + .S HTEXT(2)="use a different patient list name." + ; + I CALL=2 D + .S HTEXT(1)="Enter 'Y' to make the list private or 'N' to make it public." + .S HTEXT(2)="You can give other users access to your private lists in the Patient List Menu screens." + ; + I CALL=3 D + .S HTEXT(1)="Enter Y to save the patient to a Reminder Patient List. Enter N to not save the output." + ; + 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 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 + ; +PLIST(LIST,TEXT,IENO) ;Select Patient List + N X,Y,DIC,DLAYGO +PL1 S DIC=810.5,DLAYGO=DIC,DIC(0)="QAEMZL" + S DIC("A")=TEXT + S DIC("S")="I $P($G(^(100)),U)'=""N""" + S DIC("DR")="100///L" + W ! + D ^DIC + I X="" W !,"A patient list name must be entered" G PL1 + I X=(U_U) S DTOUT=1 + I Y=-1 S DUOUT=1 + I $D(DTOUT)!$D(DUOUT) Q + ; + ;I copy mode dissallow copy to same list + I IENO=$P(Y,U) W !,"A patient list cannot be copied to itself." G PL1 + ; + I ($P(Y,U,3)=1) S LIST=$P(Y,U) Q + ;Check if OK to overwrite + N OWRITE + S OWRITE=$$ASKYN^PXRMEUT("N","Okay to overwite "_$P(Y,U,2),"PXRMLCR",1) + Q:$D(DTOUT) G:$D(DUOUT)!('OWRITE) PL1 + S OWRITE=$$LDELOK^PXRMEUT($P(Y,U,1)) + I 'OWRITE D G PL1 + . W !,"In order to overwrite a list you must be the creator or a Reminder Manager!" + ;Return list ien + S LIST=$P(Y,U) + Q + ; +LRULE(RULE) ;Select List Rule + N X,Y,DIC +LR1 S DIC=810.4,DIC(0)="QAEMZ" + S DIC("A")="Select LIST RULE SET: " + ;Only allow rule sets with components + S DIC("S")="I $P(^(0),U,3)=3" + W ! + D ^DIC + I X="" W !,"A list rule set name must be entered" G LR1 + I X=(U_U) S DTOUT=1 + I Y=-1 S DUOUT=1 + I $D(DTOUT)!$D(DUOUT) Q + ;Return rule ien + S RULE=$P(Y,U) + ;Check that rule set is valid + N ERROR,LR,LRTYPE,NL,OP,SEQ,SUB,TEMP,TEXT + S SUB=$O(^PXRM(810.4,RULE,30,0)) + I SUB="" W !,"Rule set has no component rules" G LR1 + S (ERROR,SUB)=0,NL=1 + F S SUB=$O(^PXRM(810.4,RULE,30,SUB)) Q:'SUB D Q:ERROR + .S TEMP=$G(^PXRM(810.4,RULE,30,SUB,0)) + .S SEQ=$P(TEMP,U,1),LR=$P(TEMP,U,2),OP=$P(TEMP,U,3) + .I SEQ="" S NL=NL+1,TEXT(NL)=" Sequence is missing.",ERROR=1 + .I LR="" S NL=NL+1,TEXT(NL)=" List rule is missing.",ERROR=1 + .I OP="" S NL=NL+1,TEXT(NL)=" Operation is missing.",ERROR=1 + .;The Insert operation can only be used with finding rules. + .I OP="F",LR'="" D + ..S LRTYPE=$P(^PXRM(810.4,LR,0),U,3) + ..I LRTYPE'=1 S NL=NL+1,TEXT(NL)=" Insert operation can only be used with finding rules.",ERROR=1 + I ERROR D G LR1 + .S TEXT(1)="The rule set is incomplete or incorrect:" + .D EN^DDIOL(.TEXT) + Q + ; + ;Build list and clear ^TMP files +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) + ;Clear ^TMP lists created for rule + D CLEAR^PXRMRULE(PXRMRULE,PXRMNODE) + Q + ; +REMOVE(IEN) ; + S $P(^PXRM(810.4,IEN,0),U,10)="" + Q "@1" + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMLIST.m b/r/CLINICAL_REMINDERS-PXRM/PXRMLIST.m index 092994ae..307ddd3f 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMLIST.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMLIST.m @@ -1,107 +1,104 @@ -PXRMLIST ; SLC/PKR/PJH - Clinical Reminders list functions. ;07/17/2007 - ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123 - ;Used in the reminder exchange utility for building lists of - ;reminders, Exchange File entries, etc. - ;======================================================= -FRDEF(NAME,PNAME) ;Format the reminder name and print name. - N IND,TEMP - S TEMP=$$LJ^XLFSTR(NAME,40," ") - S TEMP=TEMP_PNAME - Q TEMP - ; - ;======================================================= -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 - S TSOURCE=$E($P(SOURCE,",",1),1,12)_"@"_$E($P(SOURCE," at ",2),1,12) - S TEMP=TEMP_U_TSOURCE - S DATE=$$FMTE^XLFDT(DATE,"5Z") - S TEMP=TEMP_U_DATE - D COLFMT^PXRMTEXT(FMTSTR,TEMP," ",.NL,.OUTPUT) - Q - ; - ;======================================================= -LIST ;Print a list of location lists. - N BY,DIC,FLDS,FR,L,PXRMEDOK - S PXRMEDOK=1 - S BY=".01" - S DIC="^PXRMD(810.9," - S FLDS="[PXRM LOCATION LIST LIST]" - S FR="" - S L=0 - D EN1^DIP - Q - ; - ;======================================================= -MRKINACT(TEXT) ;Append the inactive mark to TEXT in column 77. - N IC,NSPA - S NSPA=77-$L(TEXT) - F IC=1:1:NSPA S TEXT=TEXT_" " - S TEXT=TEXT_"X" - Q TEXT - ; - ;======================================================= -QUERYAO() ;See if the user wants only active reminders listed. - N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y - S DIR(0)="YA" - S DIR("A")="List active reminders only? " - S DIR("B")="Y" - W ! - D ^DIR - Q Y - ; - ;======================================================= -RDEF(DEFLIST,ARO) ;Build a list of the name and print name of all - ;reminder definitions. - N INACTIVE,IEN,NAME,PNAME,REMINDER - S INACTIVE="" - ;Build the list of reminders in alphabetical order. - S VALMCNT=0 - S NAME="" - F S NAME=$O(^PXD(811.9,"B",NAME)) Q:NAME="" D - . S IEN=$O(^PXD(811.9,"B",NAME,"")) - . S REMINDER=^PXD(811.9,IEN,0) - . S INACTIVE=$P(REMINDER,U,6) - . I (ARO)&(INACTIVE) Q - . S VALMCNT=VALMCNT+1 - . S PNAME=$P(REMINDER,U,3) - . S DEFLIST(VALMCNT,0)=$$FRDEF(NAME,PNAME) - . I INACTIVE D - .. S DEFLIST(VALMCNT,0)=$$MRKINACT(DEFLIST(VALMCNT,0)) - S DEFLIST("VALMCNT")=VALMCNT - Q - ; - ;======================================================= -REXL(RLIST) ;Build a list of exchange repository entries. - N DATE,EXIEN,FMTSTR,IND,NAME,NL,NUM,OUTPUT,SOURCE,STR - ;Build the list in alphabetical order. - S FMTSTR=$$LMFMTSTR^PXRMTEXT(.VALMDDF,"RLLL") - S (NUM,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 - Q - ; - ;======================================================= -SPONSOR ;Print a list of Sponsors. - N BY,DIC,FLDS,FR,L,PXRMEDOK - S PXRMEDOK=1 - S BY=".01" - S DIC="^PXRMD(811.6," - S FLDS="[PXRM SPONSOR LIST]" - S FR="" - S L=0 - D EN1^DIP - Q - ; +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. + ;======================================================= +FRDEF(NAME,PNAME) ;Format the reminder name and print name. + N IND,TEMP + S TEMP=$$LJ^XLFSTR(NAME,40," ") + S TEMP=TEMP_PNAME + Q TEMP + ; + ;======================================================= +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_$$LJ^XLFSTR(TSOURCE,23," ") + S DATE=$$FMTE^XLFDT(DATE,"5Z") + S TEMP=TEMP_" "_$$LJ^XLFSTR(DATE,30," ") + Q TEMP + ; + ;======================================================= +LIST ;Print a list of location lists. + N BY,DIC,FLDS,FR,L,PXRMEDOK + S PXRMEDOK=1 + S BY=".01" + S DIC="^PXRMD(810.9," + S FLDS="[PXRM LOCATION LIST LIST]" + S FR="" + S L=0 + D EN1^DIP + Q + ; + ;======================================================= +MRKINACT(TEXT) ;Append the inactive mark to TEXT in column 77. + N IC,NSPA + S NSPA=77-$L(TEXT) + F IC=1:1:NSPA S TEXT=TEXT_" " + S TEXT=TEXT_"X" + Q TEXT + ; + ;======================================================= +QUERYAO() ;See if the user wants only active reminders listed. + N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y + S DIR(0)="YA" + S DIR("A")="List active reminders only? " + S DIR("B")="Y" + W ! + D ^DIR + Q Y + ; + ;======================================================= +RDEF(DEFLIST,ARO) ;Build a list of the name and print name of all + ;reminder definitions. + N INACTIVE,IEN,NAME,PNAME,REMINDER + S INACTIVE="" + ;Build the list of reminders in alphabetical order. + S VALMCNT=0 + S NAME="" + F S NAME=$O(^PXD(811.9,"B",NAME)) Q:NAME="" D + . S IEN=$O(^PXD(811.9,"B",NAME,"")) + . S REMINDER=^PXD(811.9,IEN,0) + . S INACTIVE=$P(REMINDER,U,6) + . I (ARO)&(INACTIVE) Q + . S VALMCNT=VALMCNT+1 + . S PNAME=$P(REMINDER,U,3) + . S DEFLIST(VALMCNT,0)=$$FRDEF(NAME,PNAME) + . I INACTIVE D + .. S DEFLIST(VALMCNT,0)=$$MRKINACT(DEFLIST(VALMCNT,0)) + S DEFLIST("VALMCNT")=VALMCNT + Q + ; + ;======================================================= +RE(RLIST,IEN) ;Build a list of repository entries. + N DATE,IND,NAME,SOURCE + ;Build the list in alphabetical order. + 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 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 + ; + ;======================================================= +SPONSOR ;Print a list of Sponsors. + N BY,DIC,FLDS,FR,L,PXRMEDOK + S PXRMEDOK=1 + S BY=".01" + S DIC="^PXRMD(811.6," + S FLDS="[PXRM SPONSOR LIST]" + S FR="" + S L=0 + D EN1^DIP + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMLLED.m b/r/CLINICAL_REMINDERS-PXRM/PXRMLLED.m index cd5ae851..30a52101 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMLLED.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMLLED.m @@ -1,93 +1,93 @@ -PXRMLLED ; SLC/PJH - Edit a location list. ;06/25/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ;================================================================ - N CS1,CS2,DA,DIC,DLAYGO,DTOUT,DUOUT,FILEA,IENA,NUM,Y -GETNAME ;Get the name of the location list to edit. - K DA,DIC,DLAYGO,DTOUT,DUOUT,Y - S DIC="^PXRMD(810.9," - S DIC(0)="AEMQL" - S DIC("A")="Select Location List: " - S DIC("S")="I $$VEDIT^PXRMUTIL(DIC,Y)" - S DLAYGO=810.9 - ;Set the starting place for additions. - D SETSTART^PXRMCOPY(DIC) - W ! - D ^DIC - I ($D(DTOUT))!($D(DUOUT)) Q - I Y=-1 G END - S DA=$P(Y,U,1) - S CS1=$$FILE^PXRMEXCS(810.9,DA) - D EDIT(DIC,DA) - ;See if any changes have been made, if so do the edit history. - S CS2=$$FILE^PXRMEXCS(810.9,DA) - I CS2'=0,CS2'=CS1 D SEHIST^PXRMUTIL(810.9,DIC,DA) - G GETNAME -END ; - Q - ; - ;================================================================ -EDIT(ROOT,DA) ; - N DIE,DR,DIDEL,X,Y - S DIE=ROOT,DIDEL=810.9 -NAME S DR=".01" - D ^DIE - I '$D(DA) Q - I $D(Y) Q -CLASS ; - ;Class -RETRY W !! - S DR="100" - D ^DIE - I $D(Y) G NAME - ;Sponsor - S DR="101" - D ^DIE - I $D(Y) G RETRY - ;Make sure Class and Sponsor Class are in synch. - S RESULT=$$VSPONSOR^PXRMINTR(X) - I RESULT=0 S DIE("NO^")="Other value" G RETRY - I RESULT=1 K DIE("NO^") - ;Review date -RD W !! - S DR="102" - D ^DIE - I $D(Y) G RETRY - ; - ;Description -DES S DR="1" - D ^DIE - I $D(Y) G RD - ; - ;Clinic Stops -CS S DR="40.7" - S DR(2,810.9001)=".01;1" - D ^DIE - I $D(Y) G RD - ; - ;Hospital Locations -HL S DR="44" - D ^DIE - I $D(Y) G CS - Q - ; - ;================================================================ -KAMIS(X,DA) ;Kill the AMIS Reporting Stop Code. - ;Do not execute as part of a verify fields. - I $G(DIUTIL)="VERIFY FIELDS" Q - ;Do not execute as part of exchange. - I $G(PXRMEXCH) Q - S $P(^PXRMD(810.9,DA(1),40.7,DA,0),U,2)="" - Q - ; - ;================================================================ -SAMIS(X,DA) ;Set the AMIS Reporting Stop Code. - ;Do not execute as part of a verify fields. - I $G(DIUTIL)="VERIFY FIELDS" Q - ;Do not execute as part of exchange. - I $G(PXRMEXCH) Q - N AMIS - S AMIS=$P(^DIC(40.7,X,0),U,2) - S $P(^PXRMD(810.9,DA(1),40.7,DA,0),U,2)=AMIS - Q - ; +PXRMLLED ; SLC/PJH - Edit a location list. ;12/23/2005 + ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21 + ; + ;================================================================ + N CS1,CS2,DA,DIC,DLAYGO,DTOUT,DUOUT,FILEA,IENA,NUM,Y +GETNAME ;Get the name of the location list to edit. + K DA,DIC,DLAYGO,DTOUT,DUOUT,Y + S DIC="^PXRMD(810.9," + S DIC(0)="AEMQL" + S DIC("A")="Select Location List: " + S DIC("S")="I $$VEDIT^PXRMUTIL(DIC,Y)" + S DLAYGO=810.9 + ;Set the starting place for additions. + D SETSTART^PXRMCOPY(DIC) + W ! + D ^DIC + I ($D(DTOUT))!($D(DUOUT)) Q + I Y=-1 G END + S DA=$P(Y,U,1) + S CS1=$$FILE^PXRMEXCS(810.9,DA) + D EDIT(DIC,DA) + ;See if any changes have been made, if so do the edit history. + S CS2=$$FILE^PXRMEXCS(810.9,DA) + I CS2'=0,CS2'=CS1 D SEHIST^PXRMUTIL(810.9,DIC,DA) + G GETNAME +END ; + Q + ; + ;================================================================ +EDIT(ROOT,DA) ; + N DIE,DR,DIDEL,X,Y + S DIE=ROOT,DIDEL=810.9 +NAME S DR=".01" + D ^DIE + I '$D(DA) Q + I $D(Y) Q +CLASS ; + ;Class +RETRY W !! + S DR="100" + D ^DIE + I $D(Y) G NAME + ;Sponsor + S DR="101" + D ^DIE + I $D(Y) G RETRY + ;Make sure Class and Sponsor Class are in synch. + S RESULT=$$VSPONSOR^PXRMINTR(X) + I RESULT=0 S DIE("NO^")="Other value" G RETRY + I RESULT=1 K DIE("NO^") + ;Review date +RD W !! + S DR="102" + D ^DIE + I $D(Y) G RETRY + ; + ;Description +DES S DR="1" + D ^DIE + I $D(Y) G RD + ; + ;Clinic Stops +CS S DR="40.7" + S DR(2,810.9001)=".01;1" + D ^DIE + I $D(Y) G DES + ; + ;Hospital Locations +HL S DR="44" + D ^DIE + I $D(Y) G CS + Q + ; + ;================================================================ +KAMIS(X,DA) ;Kill the AMIS Reporting Stop Code. + ;Do not execute as part of a verify fields. + I $G(DIUTIL)="VERIFY FIELDS" Q + ;Do not execute as part of exchange. + I $G(PXRMEXCH) Q + S $P(^PXRMD(810.9,DA(1),40.7,DA,0),U,2)="" + Q + ; + ;================================================================ +SAMIS(X,DA) ;Set the AMIS Reporting Stop Code. + ;Do not execute as part of a verify fields. + I $G(DIUTIL)="VERIFY FIELDS" Q + ;Do not execute as part of exchange. + I $G(PXRMEXCH) Q + N AMIS + S AMIS=$P(^DIC(40.7,X,0),U,2) + S $P(^PXRMD(810.9,DA(1),40.7,DA,0),U,2)=AMIS + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMLOCF.m b/r/CLINICAL_REMINDERS-PXRM/PXRMLOCF.m index bdca2871..62f00eb1 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMLOCF.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMLOCF.m @@ -1,254 +1,235 @@ -PXRMLOCF ; SLC/PKR - Handle location findings. ;10/11/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ;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 - ;Set the finding search parameters. - D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT) - 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 - ;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),INVDATEETIME Q - . I INVDATE=INVBD,TIMEINVBD S DONE=1 Q - . I (SDIR=-1),INVDATEETIME Q - . I INVDATE=INVBD,TIMEEDT S DONE=1 Q + . I SDIR=-1,VDATEINVBD S DONE=1 Q - .. S TIME="."_$P(INVDT,".",2) - .. I INVDATE=INVED,TIME>ETIME Q - .. I INVDATE=INVBD,TIMEINVBD S DONE=1 Q + .. S TIME=+("."_$P(INVDT,".",2)) + .. I INVDATE=INVED,TIME>ETIME 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 + ...;Check the associated appointment for a valid status. + ... I '$$VAPSTAT^PXRMVSIT(DAS) Q + ... S TEMP=^AUPNVSIT(DAS,0) + ... S DFN=$P(TEMP,U,5) + ... S DATE=$P(TEMP,U,1) + ... S ^TMP($J,TGLIST,DFN,INVDT,DAS)=DATE_U_HLOC + ;Return the NOCC most recent for each patient. + S DFN=0 + F S DFN=$O(^TMP($J,TGLIST,DFN)) Q:DFN="" D + . S (INVDT,NFOUND)=0 + . F S INVDT=$O(^TMP($J,TGLIST,DFN,INVDT)) Q:(NFOUND=NOCC)!(INVDT="") D + .. S DAS="" + .. F S DAS=$O(^TMP($J,TGLIST,DFN,INVDT,DAS)) Q:(NFOUND=NOCC)!(DAS="") D + ... S NFOUND=NFOUND+1 + ... S ^TMP($J,PLIST,DFN,NFOUND)=DAS_U_^TMP($J,TGLIST,DFN,INVDT,DAS) + K ^TMP($J,TGLIST) + Q + ; + ;============================================= +GPLIST(FILENUM,SNODE,ITEM,PFINDPA,PLIST) ;Add to the patient list. + ; Return the list in ^TMP($J,PLIST). + ;^TMP($J,PLIST,T/F,DFN,IND,FILENUM)=DAS^DATE^HLOC^VALUE + N BDT,CASESEN,COND,CONVAL,DAS,DATE,EDT,DFN,FIEVD,FLIST + N ICOND,IEN,IND,IPLIST,LNAME,NOCC,NFOUND,NGET,NP,SAVE,STATUSA + N TEMP,TGLIST,TPLIST,UCIFS,VALUE,VSLIST + S TGLIST="GPLIST_PXRMLOCL" + ;Set the finding search parameters. + D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT) + S NOCC=$S(NOCC<0:-NOCC,1:NOCC) + D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST) + S NGET=$S(UCIFS:"*",$D(STATUSA):"*",1:NOCC) + ;Get a list of unique locations. + S LNAME=$P(^PXRMD(810.9,ITEM,0),U,1) + I LNAME="VA-ALL LOCATIONS" D ALLLOCS("HLOCL") + I LNAME'="VA-ALL LOCATIONS" D LOCLIST^PXRMLOCF(ITEM,"HLOCL") + D FPLIST(FILENUM,"HLOCL",NGET,BDT,EDT,TGLIST) + S DFN="" + F S DFN=$O(^TMP($J,TGLIST,DFN)) Q:DFN="" D + . K TPLIST + . M TPLIST=^TMP($J,TGLIST,DFN) + . S (IND,NFOUND)=0 + . K IPLIST + . F S IND=$O(TPLIST(IND)) Q:(IND="")!(NFOUND=NOCC) D + .. S TEMP=TPLIST(IND) + .. S DAS=$P(TEMP,U,1) + .. D GETDATA^PXRMDATA(FILENUM,DAS,.FIEVD) + .. S VALUE=$G(FIEVD("VALUE")) + .. 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 IPLIST(CONVAL,DFN,NFOUND,FILENUM)=TEMP_U_VALUE + . M ^TMP($J,PLIST)=IPLIST + K ^TMP($J,"HLOCL"),^TMP($J,TGLIST) + Q + ; + ;============================================= +PCSTOPL ;Print the Clinic Stop list. Called by the print template PXRM + ;LOCATION LIST INQUIRY. + N AMIS,CSTOP,IND,JND,SKIP,TEMP + S (IND,SKIP)=0 + F S IND=+$O(^PXRMD(810.9,D0,40.7,IND)) Q:IND=0 D + . S TEMP=^PXRMD(810.9,D0,40.7,IND,0) + . S CSTOP=$P(TEMP,U,1) + .; DBIA #557 + . S CSTOP=$P(^DIC(40.7,CSTOP,0),U,1) + . S AMIS=$P(TEMP,U,2) + . I SKIP W ! S SKIP=0 + . W !,?2,CSTOP,?34,AMIS + . I '$D(^PXRMD(810.9,D0,40.7,IND,1)) Q + . S SKIP=1 + . W !,?4,"Credit Stops to Exclude:" + . S JND=0 + . F S JND=+$O(^PXRMD(810.9,D0,40.7,IND,1,JND)) Q:JND=0 D + .. S TEMP=^PXRMD(810.9,D0,40.7,IND,1,JND,0) + .. S TEMP=$P(^DIC(40.7,TEMP,0),U,1,2) + .. S CSTOP=$P(TEMP,U,1) + .. S AMIS=$P(TEMP,U,2) + .. W !,?6,CSTOP,?38,AMIS + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMLPAU.m b/r/CLINICAL_REMINDERS-PXRM/PXRMLPAU.m index 47cdd9f8..055e923f 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMLPAU.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMLPAU.m @@ -1,179 +1,181 @@ -PXRMLPAU ; SLC/AGP - Reminder Patient List ;09/06/2007 - ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123 - ; - ;Main entry point for PXRM PATIENT LIST -START(IEN) ; - N PXRMDONE,VALMBCK,VALMSG,X,XMZ - S X="IORESET" - S VALMCNT=0 - D EN^VALM("PXRM PATIENT LIST AUTH USERS") - W IORESET - Q - ; -BLDLIST ; - N PLIST,PIEN - K ^TMP("PXRMLPAU",$J) - K ^TMP("PXRMLPAH",$J) - D LIST(.PLIST,.PIEN) - I $D(PLIST)=0 G EXIT - M ^TMP("PXRMLPAU",$J)=PLIST - S VALMCNT=PLIST("VALMCNT") - F IND=1:1:VALMCNT D - .S ^TMP("PXRMLPAU",$J,"IDX",IND,IND)=PIEN(IND) - Q - ; -LIST(RLIST,PIEN) ;Build a list of patient list users. - N ACCESS,ARRAY,COUNT,DATE,DFN,IND,SIEN,FNAME,NAME,NODE,LEVEL - ;Build the list in alphabetical order. - S VALMCNT=0 - S DFN="" - F S DFN=$O(^PXRMXP(810.5,IEN,40,"B",DFN)) Q:DFN="" D - .S IND="" - .F S IND=$O(^PXRMXP(810.5,IEN,40,"B",DFN,IND)) Q:'IND D - ..S ACCESS=$P($G(^PXRMXP(810.5,IEN,40,IND,0)),U,2) - ..S FNAME=$$GET1^DIQ(200,DFN,.01) Q:$G(FNAME)="" - ..S ARRAY(FNAME)=$G(IND)_U_$G(ACCESS) - I $D(ARRAY)=0 Q - S NAME="" F S NAME=$O(ARRAY(NAME)) Q:NAME="" D - .S VALMCNT=VALMCNT+1 - .S RLIST(VALMCNT,0)=$$FRE(VALMCNT,NAME,$P($G(ARRAY(NAME)),U,2)) - .S PIEN(VALMCNT)=$P($G(ARRAY(NAME)),U) - S RLIST("VALMCNT")=VALMCNT - Q - ; -FRE(NUMBER,NAME,ACCESS) ;Format entry number, name, source, - ;and date packed. - N TEMP,TNAME,TSOURCE - S TEMP=$$RJ^XLFSTR(NUMBER,5," ") - S TNAME=$E(NAME,1,45) - S TEMP=TEMP_" "_TNAME - S TEMP=$$LJ^XLFSTR(TEMP,40," ")_ACCESS - Q TEMP - ; -ENTRY ;Entry code - D BLDLIST,XQORM - Q - ; -EXIT ;Exit code - K ^TMP("PXRMLPAU",$J) - K ^TMP("PXRMLPAH",$J) - D CLEAN^VALM10 - D FULL^VALM1 - Q - ; -HDR ; Header code - S VALMHDR(1)="Available Patient Lists." - S VALMSG="+ Next Screen - Prev Screen ?? More Actions" - Q - ; -HLP ;Help code - N ORU,ORUPRMT,SUB,XQORM - S SUB="PXRMLPAH" - D EN^VALM("PXRM PATIENT LIST HELP") - Q - ; -INIT ;Init - S VALMCNT=0 - Q - ; -PEXIT ;PXRM MENU protocol exit code - S VALMSG="+ Next Screen - Prev Screen ?? More Actions" - ;Reset after page up/down etc - D XQORM - Q - ; -ADD ;add a user - N CREAT,CNT,DIC,DIE,FDA,MSG,USER,Y - S CREAT=$P($G(^PXRMXP(810.5,IEN,0)),U,7) - I $G(CREAT)'=DUZ D G ADDE - . W !,"Only the creator of this list can add an user." H 2 - D FULL^VALM1 - S DIC="^VA(200," - S DIC(0)="QAEB" - S DIC("A")="Select Users: " - D ^DIC - I Y=-1 Q - S USER=+Y - K Y - K DIROUT,DIRUT,DTOUT,DUOUT - S DIR(0)="S^F:Full Control;V:View Only" - S DIR("A")="Select level of control: " - S DIR("B")="V" - S DIR("?")="Enter F or V. For detailed help type ??" - W ! - D ^DIR K DIR - 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 - S YESNO=$E(Y(0)) - S FDA(810.54,"+2,"_IEN_",",.01)=USER - S FDA(810.54,"+2,"_IEN_",",1)=Y - D UPDATE^DIE("","FDA","","MSG") - I $D(MSG)>0 D AWRITE^PXRMUTIL("MSG") H 2 -ADDE ; - D BLDLIST - S VALMBCK="R" - Q - ; -XQORM ; - S XQORM("#")=$O(^ORD(101,"B","PXRM PATIENT LIST AUTH USER SELECT",0))_U_"1:"_VALMCNT - S XQORM("A")="Select Item: " - Q - ; -XSEL ;PXRM SELECT COMPONENT validation - N EPIEN,LISTIEN,LRIEN,SEL - 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 patient list ien - S LISTIEN=^TMP("PXRMLPAU",$J,"IDX",SEL,SEL) - ;Full screen mode - D FULL^VALM1 - D PDELETE - ; - ;Option to Install, Delete or Install History - ; - S VALMBCK="R" - Q - ; -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.\\" - D HELP^PXRMEUT(.HTEXT) - Q - ; -PDELETE ;Patient list delete - ; - ;Full Screen - W IORESET - ; - 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 - D EN^VALM2(XQORNOD(0)) - ;If there is no list quit. - I '$D(VALMY) D BLDLIST S VALMBCK="R" Q - S IND="",PXRMDONE=0 - F S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE) D - .;Get the patient list ien. - .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" - ; -PDELEX ; - D BLDLIST - ; - S VALMBCK="R" - Q - ; +PXRMLPAU ; SLC/AGP - Reminder Patient List ;07/29/2004 + ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005 + ; + ;Main entry point for PXRM PATIENT LIST +START(IEN) ; + N PXRMDONE,VALMBCK,VALMSG,X,XMZ + S X="IORESET" + S VALMCNT=0 + D EN^VALM("PXRM PATIENT LIST AUTH USERS") + W IORESET + Q + ; +BLDLIST ; + N PLIST,PIEN + K ^TMP("PXRMLPAU",$J) + K ^TMP("PXRMLPAH",$J) + D LIST(.PLIST,.PIEN) + I $D(PLIST)=0 G EXIT + M ^TMP("PXRMLPAU",$J)=PLIST + S VALMCNT=PLIST("VALMCNT") + F IND=1:1:VALMCNT D + .S ^TMP("PXRMLPAU",$J,"IDX",IND,IND)=PIEN(IND) + Q + ; +LIST(RLIST,PIEN) ;Build a list of patient list users. + N ACCESS,ARRAY,COUNT,DATE,DFN,IND,SIEN,FNAME,NAME,NODE,LEVEL + ;Build the list in alphabetical order. + S VALMCNT=0 + S DFN="" + F S DFN=$O(^PXRMXP(810.5,IEN,40,"B",DFN)) Q:DFN="" D + .S IND="" + .F S IND=$O(^PXRMXP(810.5,IEN,40,"B",DFN,IND)) Q:'IND D + ..S ACCESS=$P($G(^PXRMXP(810.5,IEN,40,IND,0)),U,2) + ..S FNAME=$$GET1^DIQ(200,DFN,.01) Q:$G(FNAME)="" + ..S ARRAY(FNAME)=$G(IND)_U_$G(ACCESS) + I $D(ARRAY)=0 Q + S NAME="" F S NAME=$O(ARRAY(NAME)) Q:NAME="" D + .S VALMCNT=VALMCNT+1 + .S RLIST(VALMCNT,0)=$$FRE(VALMCNT,NAME,$P($G(ARRAY(NAME)),U,2)) + .S PIEN(VALMCNT)=$P($G(ARRAY(NAME)),U) + S RLIST("VALMCNT")=VALMCNT + Q + ; +FRE(NUMBER,NAME,ACCESS) ;Format entry number, name, source, + ;and date packed. + N TEMP,TNAME,TSOURCE + S TEMP=$$RJ^XLFSTR(NUMBER,5," ") + S TNAME=$E(NAME,1,45) + S TEMP=TEMP_" "_TNAME + S TEMP=$$LJ^XLFSTR(TEMP,40," ")_ACCESS + Q TEMP + ; +ENTRY ;Entry code + D BLDLIST,XQORM + Q + ; +EXIT ;Exit code + K ^TMP("PXRMLPAU",$J) + K ^TMP("PXRMLPAH",$J) + D CLEAN^VALM10 + D FULL^VALM1 + Q + ; +HDR ; Header code + S VALMHDR(1)="Available Patient Lists." + S VALMSG="+ Next Screen - Prev Screen ?? More Actions" + Q + ; +HLP ;Help code + N ORU,ORUPRMT,SUB,XQORM + S SUB="PXRMLPAH" + D EN^VALM("PXRM PATIENT LIST HELP") + Q + ; +INIT ;Init + S VALMCNT=0 + Q + ; +PEXIT ;PXRM MENU protocol exit code + S VALMSG="+ Next Screen - Prev Screen ?? More Actions" + ;Reset after page up/down etc + D XQORM + Q + ; +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 $G(CREAT)'=DUZ D G ADDE + . W !,"Only the creator of this list can add an user." H 2 + D FULL^VALM1 + S DIC="^VA(200," + S DIC(0)="QAEB" + S DIC("A")="Select Users: " + D ^DIC + I Y=-1 Q + S USER=+Y + K Y + K DIROUT,DIRUT,DTOUT,DUOUT + S DIR(0)="S^F:Full Control;V:View Only" + S DIR("A")="Select level of control: " + S DIR("B")="V" + S DIR("?")="Enter F or V. For detailed help type ??" + W ! + D ^DIR K DIR + I $D(DIROUT) S DTOUT=1 + I $D(DTOUT)!($D(DUOUT)) 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 + S FDA(810.54,"+2,"_IEN_",",1)=Y + D UPDATE^DIE("","FDA","","MSG") + I $D(MSG)>0 D AWRITE^PXRMUTIL("MSG") H 2 +ADDE ; + D BLDLIST + S VALMBCK="R" + Q + ; +XQORM ; + S XQORM("#")=$O(^ORD(101,"B","PXRM PATIENT LIST AUTH USER SELECT",0))_U_"1:"_VALMCNT + S XQORM("A")="Select Item: " + Q + ; +XSEL ;PXRM SELECT COMPONENT validation + N EPIEN,LISTIEN,LRIEN,SEL + 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 patient list ien + S LISTIEN=^TMP("PXRMLPAU",$J,"IDX",SEL,SEL) + ;Full screen mode + D FULL^VALM1 + D PDELETE + ; + ;Option to Install, Delete or Install History + ; + S VALMBCK="R" + Q + ; +HELP(CALL) ;General help text routine + N HTEXT + ; + I CALL=1 D + .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 + ; +PDELETE ;Patient list delete + ; + ;Full Screen + W IORESET + ; + 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 an user." H 2 + D EN^VALM2(XQORNOD(0)) + ;If there is no list quit. + I '$D(VALMY) D BLDLIST S VALMBCK="R" Q + S IND="",PXRMDONE=0 + F S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE) D + .;Get the patient list ien. + .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 DELETED" + ; +PDELEX ; + D BLDLIST + ; + S VALMBCK="R" + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMLPHS.m b/r/CLINICAL_REMINDERS-PXRM/PXRMLPHS.m index ad709756..8b73aa3b 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMLPHS.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMLPHS.m @@ -1,83 +1,84 @@ -PXRMLPHS ; SLC/PJH,PKR - Run Health Summaries from Patient List ;03/26/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ;External Ref DBIA #398 - ; -HSA(LISTIEN) ;Run health summary for all patients on this patient list. - N HSIEN,PLNODE - ;Initialise - D FULL^VALM1 - ;Reset screen mode - W IORESET - ; - ;Select Health Summary - D HSEL(.HSIEN) Q:$D(DTOUT)!$D(DUOUT) - ; - S PLNODE="PXRMLPHS"_$J_$$NOW^XLFDT - K ^XTMP(PLNODE) - S ^XTMP(PLNODE,0)=$$FMADD^XLFDT(DT,2)_U_DT_"HSI LIST" - D SORT(LISTIEN,PLNODE) - D QUE(HSIEN,PLNODE) - Q - ; -HSEL(IEN) ;Select Health Summary Type - N X,Y,DIC -HS1 S DIC=142,DIC(0)="QAEMZ" - S DIC("A")="Select HEALTH SUMMARY TYPE: " - W ! - D ^DIC - I X="" W !,"A health summary type name must be entered" G HS1 - I X=(U_U) S DTOUT=1 - I Y=-1 S DUOUT=1 - I $D(DTOUT)!$D(DUOUT) Q - ;Return HS ien - S IEN=$P(Y,U) - Q - ; -HSI(PLNODE) ;Print health summary for selected patients. - N HSIEN - ;Initialise - D FULL^VALM1 - ;Reset screen mode - W IORESET - ; - ;Select Health Summary - D HSEL(.HSIEN) Q:$D(DTOUT)!$D(DUOUT) - D QUE(HSIEN,PLNODE) - Q - ; -PRINT(HSIEN,PLNODE) ;Print HS for Patient List IEN - N DFN,DIROUT,SUB - ;Print HS for each patient - S SUB=0 - F S SUB=$O(^XTMP(PLNODE,SUB)) Q:(SUB="")!$D(DIROUT) D - .S DFN=^XTMP(PLNODE,SUB) - .D ENX^GMTSDVR(DFN,HSIEN,"","") ; DBIA #398 - ; - ;Clear workfile - K ^XTMP(PLNODE) - Q - ; -QUE(HSIEN,PLNODE) ;Determine whether the report should be queued. - N PXRMQUE,%ZIS,ZTDESC,ZTRTN,ZTSK,ZTSAVE - S %ZIS="M" - S ZTDESC="Patient List Health Summaries - print" - S ZTRTN="PRINT^PXRMLPHS(HSIEN,PLNODE)" - S ZTSAVE("HSIEN")="" - S ZTSAVE("PLNODE")="" - S PXRMQUE=$$DEVICE^PXRMXQUE(ZTRTN,ZTDESC,.ZTSAVE,.%ZIS,1) - S VALMBCK="R" - Q - ; -SORT(LISTIEN,PLNODE) ;Sort workfile as required - N DATA,DFN,IND,PNAME - ;Build the list in alphabetical order. - S IND=0 - F S IND=$O(^PXRMXP(810.5,LISTIEN,30,IND)) Q:'IND D - .S DATA=$G(^PXRMXP(810.5,LISTIEN,30,IND,0)) Q:DATA="" - .S DFN=$P(DATA,U) Q:'DFN - .;DBIA #10035 - .S PNAME=$P(^DPT(DFN,0),U,1) Q:PNAME="" - .S ^XTMP(PLNODE,PNAME)=DFN - Q - ; +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 + ; +HSA(LISTIEN) ;Run health summary for all patients on this patient list. + N HSIEN,PLNODE + ;Initialise + D FULL^VALM1 + ;Reset screen mode + W IORESET + ; + ;Select Health Summary + D HSEL(.HSIEN) Q:$D(DTOUT)!$D(DUOUT) + ; + S PLNODE="PXRMLPHS"_$J_$$NOW^XLFDT + K ^XTMP(PLNODE) + S ^XTMP(PLNODE,0)=$$FMADD^XLFDT(DT,2)_U_DT_"HSI LIST" + D SORT(LISTIEN,PLNODE) + D QUE(HSIEN,PLNODE) + Q + ; +HSEL(IEN) ;Select Health Summary Type + N X,Y,DIC +HS1 S DIC=142,DIC(0)="QAEMZ" + S DIC("A")="Select HEALTH SUMMARY TYPE: " + W ! + D ^DIC + I X="" W !,"A health summary type name must be entered" G HS1 + I X=(U_U) S DTOUT=1 + I Y=-1 S DUOUT=1 + I $D(DTOUT)!$D(DUOUT) Q + ;Return HS ien + S IEN=$P(Y,U) + Q + ; +HSI(PLNODE) ;Print health summary for selected patients. + N HSIEN + ;Initialise + D FULL^VALM1 + ;Reset screen mode + W IORESET + ; + ;Select Health Summary + D HSEL(.HSIEN) Q:$D(DTOUT)!$D(DUOUT) + D QUE(HSIEN,PLNODE) + Q + ; +PRINT(HSIEN,PLNODE) ;Print HS for Patient List IEN + N DFN,DIROUT,SUB + ;Print HS for each patient + S SUB=0 + F S SUB=$O(^XTMP(PLNODE,SUB)) Q:(SUB="")!$D(DIROUT) D + .S DFN=^XTMP(PLNODE,SUB) + .D ENX^GMTSDVR(DFN,HSIEN,"","") ; DBIA #398 + ; + ;Clear workfile + K ^XTMP(PLNODE) + Q + ; +QUE(HSIEN,PLNODE) ;Determine whether the report should be queued. + N PXRMQUE,RETZTSK,%ZIS,ZTDESC,ZTRTN,ZTSK,ZTSAVE + S %ZIS="M" + S ZTDESC="Patient List Health Summaries - print" + S ZTRTN="PRINT^PXRMLPHS(HSIEN,PLNODE)" + S ZTSAVE("HSIEN")="" + S ZTSAVE("PLNODE")="" + S RETZTSK=1 + S PXRMQUE=$$DEVICE^PXRMXQUE(ZTRTN,ZTDESC,.ZTSAVE,.%ZIS,.RETZTSK) + S VALMBCK="R" + Q + ; +SORT(LISTIEN,PLNODE) ;Sort workfile as required + N DATA,DFN,IND,PNAME + ;Build the list in alphabetical order. + S IND=0 + F S IND=$O(^PXRMXP(810.5,LISTIEN,30,IND)) Q:'IND D + .S DATA=$G(^PXRMXP(810.5,LISTIEN,30,IND,0)) Q:DATA="" + .S DFN=$P(DATA,U) Q:'DFN + .;DBIA #10035 + .S PNAME=$P(^DPT(DFN,0),U,1) Q:PNAME="" + .S ^XTMP(PLNODE,PNAME)=DFN + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMLPP.m b/r/CLINICAL_REMINDERS-PXRM/PXRMLPP.m index 2570800f..38078c53 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMLPP.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMLPP.m @@ -1,259 +1,237 @@ -PXRMLPP ; SLC/PKR/PJH - Reminder Patient List Patients ;04/04/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ;Main entry point for PXRM PATIENT LIST -START(IEN) ; - N CDATE,CLASS,CREATOR,INDP,INTP,LDATA,LNAME,PXRMVIEW,SNAME,SOURCE,TYPE - N VALMBCK,VALMBG,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD - ;Get Patient List record and associated data. - S LDATA=$G(^PXRMXP(810.5,IEN,0)) - S LNAME=$P(LDATA,U,1) - S CDATE=$P(LDATA,U,4) - S SOURCE=$P(LDATA,U,5),SNAME="" - ;Check if generated from #810.2 - I SOURCE S SNAME="Extract Parameter - "_$P($G(^PXRM(810.2,SOURCE,0)),U) - ;If not check if generated from #810.4 - I SNAME="" D - . S SOURCE=$P(LDATA,U,6) - . I SOURCE'="" S SNAME="List Rule - "_$P($G(^PXRM(810.4,SOURCE,0)),U) - ;If still no source check for created from Reminder Due Report. - I SNAME="" D - . S SOURCE=$P(LDATA,U,9) - . I SOURCE'="" S SNAME="Reminder Due Report" - ;If there still is no source then assume it was generated in the - ;past by a Reminder Due Report. - I SNAME="" S SNAME="Reminder Due Report" - ;Creator - S CREATOR=+$P(LDATA,U,7) - S CREATOR=$S(CREATOR>0:$$GET1^DIQ(200,CREATOR,.01),1:"None") - ;Type - S TYPE=$P(LDATA,U,8) - S TYPE=$$EXTERNAL^DILFD(810.5,.08,"",TYPE,.EM) - ;Class - 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" - S VALMCNT=0 - D EN^VALM("PXRM PATIENT LIST PATIENTS") - Q - ; -BLDLIST(IEN) ;Build a list of all patients - N IND,INCINST - S INCINST=+$P(^PXRMXP(810.5,IEN,0),U,10) - I 'INCINST D CHGCAP^VALM("HEADER3","") - K ^TMP("PXRMLPP",$J),^TMP("PXRMLPPA",$J),^TMP("PXRMLPPI",$J) - D LIST(.VALMCNT,.IEN,INCINST) - F IND=1:1:VALMCNT D - .S ^TMP("PXRMLPP",$J,"IDX",IND,IND)=^TMP("PXRMLPPI",$J,IND) - K ^TMP("PXRMLPPI",$J) - Q -DEM ; - D FULL^VALM1 - D EN^PXRMPDR(IEN) - S VALMBCK="R" - Q - ; -EDIT ;Edit selected patient list fields. - N DA,DIE,DR,TEMP - S DA=IEN,DIE="^PXRMXP(810.5," - S DR=".01;.08" - I $D(^XUSEC("PXRM MANAGER",DUZ)) S DR=DR_";.07" - D ^DIE - S TEMP=^PXRMXP(810.5,IEN,0) - S LNAME=$P(TEMP,U,1),CREATOR=$P(TEMP,U,7),TYPE=$P(TEMP,U,8) - S CREATOR=$P(^VA(200,CREATOR,0),U,1) - D HDR^PXRMLPP - S VALMBCK="R" - Q - ; -EDITOK(IEN) ;Screen for protocol PXRM PATIENT LIST EDIT, return true if - ;the user is permitted to edit the selected patient list. - I $D(^XUSEC("PXRM MANAGER",DUZ)) Q 1 - N CREATOR - S CREATOR=$P(^PXRMXP(810.5,IEN,0),U,7) - Q $S(CREATOR=DUZ:1,1:0) - ; -ENTRY ;Entry code - D BLDLIST(IEN) - D XQORM - Q - ; -EXIT ;Exit code - K ^TMP("PXRMLPP",$J) - K ^TMP("PXRMLPPH",$J) - D CLEAN^VALM10 - D FULL^VALM1 - S VALMBCK="R" - 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 - ; -HDR ; Header code - N TEXT - S VALMHDR(1)="List Name: "_LNAME - S VALMHDR(2)=" Created: "_$$FMTE^XLFDT(CDATE,"5Z") - S VALMHDR(2)=$$LJ^XLFSTR(VALMHDR(2),40)_"Creator: "_CREATOR - S VALMHDR(3)=" Class: "_CLASS - 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 - ; -HLP ;Help code - N ORU,ORUPRMT,SUB,XQORM - S SUB="PXRMLPPH" - D EN^VALM("PXRM PATIENT LIST HELP") - Q -HSA ;Print Health Summary for all patients on list - D HSA^PXRMLPHS(IEN) - S VALMBCK="R" - Q - ; -HSI ;Print Health Summary for selected patients. - ;Full Screen - W IORESET - N IND,DFN,PLNODE,PNAME,VALMY - D EN^VALM2(XQORNOD(0)) - ;If there is no list quit. - I '$D(VALMY) Q - S PLNODE="PXRMLPHS"_$J_$$NOW^XLFDT - K ^XTMP(PLNODE) - S ^XTMP(PLNODE,0)=$$FMADD^XLFDT(DT,2)_U_DT_"HSI LIST" - S IND="",PXRMDONE=0 - F S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE) D - .;Get the patient list ien. - .S DFN=^TMP("PXRMLPP",$J,"IDX",IND,IND) - .;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) - S VALMBCK="R" - Q - ; -INIT ;Init - S VALMCNT=0 - Q - ; -LIST(VALMCNT,IEN,INCINST) ;Build a list of patients. - N DATA,DECEASED,DFN,IND,INST,NEXT,PNAME,SUB,TESTP - ;Build the ordered list. - S IND=0,SUB="NAME" - F S IND=$O(^PXRMXP(810.5,IEN,30,IND)) Q:'IND D - .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) - .;Lists built before PXRM*2*4 will only have the Institution ien. - .I INST="" S INST=$P(DATA,U,2) - .I INST="" S INST="NONE" - .I PXRMVIEW="I" S SUB=INST - .S ^TMP("PXRMLPPA",$J,SUB,PNAME,DFN)=DECEASED_U_TESTP_U_INST - ;Transfer to list manager array - S SUB="",VALMCNT=0 - F S SUB=$O(^TMP("PXRMLPPA",$J,SUB)) Q:SUB="" D - .S (INST,PNAME)="" - .F S PNAME=$O(^TMP("PXRMLPPA",$J,SUB,PNAME)) Q:PNAME="" D - ..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) - ...S VALMCNT=VALMCNT+1 - ...S ^TMP("PXRMLPP",$J,VALMCNT,0)=$$FRE(VALMCNT,PNAME,DFN,DECEASED,TESTP,INST) - ...S ^TMP("PXRMLPPI",$J,VALMCNT)=DFN - K ^TMP("PXRMLPPA",$J) - Q - ; -PEXIT ;PXRM PATIENT LIST PATIENTS MENU protocol exit code - S VALMSG="+ Next Screen - Prev Screen ?? More Actions" - D XQORM - Q - ; -USER ; - I $P($G(^PXRMXP(810.5,IEN,0)),U,8)="PUB" D FULL^VALM1 W !,"This option is locked for Public Lists." H 2 Q - D FULL^VALM1 - D START^PXRMLPAU(IEN) - S VALMBCK="R" - Q - ; -USR(IEN) ;Screen for protocol PXRM PATIENT LIST AUTH USER - N TYPE - S TYPE=$P(^PXRMXP(810.5,IEN,0),U,8) - ;Public lists cannot have individual user access. - I TYPE="PUB" Q "N" - Q $$ACCESS^PXRMLPU(IEN) - ; -VIEW ;Select view - W IORESET - S VALMBCK="R",VALMBG=1 - N X,Y,CODE,DIR - K DIROUT,DIRUT,DTOUT,DUOUT - S DIR(0)="S"_U_"I:Sort by Institution and Name;" - S DIR(0)=DIR(0)_"N:Sort by Name;" - S DIR("A")="TYPE OF VIEW" - S DIR("B")=$S(PXRMVIEW="N":"I",1:"N") - S DIR("?")="Select from the codes displayed." - D ^DIR K DIR - I $D(DIROUT) S DTOUT=1 - I $D(DTOUT)!($D(DUOUT)) Q - ;Change display type - S PXRMVIEW=Y - ;Rebuild Workfile - D BLDLIST^PXRMLPP(IEN),HDR - Q - ; -XSEL ;PXRM PATIENT LIST PATIENT SELECT validation - N EPIEN,DFN,SEL - 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 patient list ien - S DFN=^TMP("PXRMLPP",$J,"IDX",SEL,SEL) - ;Full screen mode - D FULL^VALM1 - ;Print individual Health Summary - D HSI^PXRMLPHS(DFN) - S VALMBCK="R" - Q - ; -XQORM S XQORM("#")=$O(^ORD(101,"B","PXRM PATIENT LIST PATIENT SELECT",0))_U_"1:"_VALMCNT - S XQORM("A")="Select Item: " - Q - ; +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,LDATA,LNAME,PXRMVIEW,SNAME,SOURCE,TYPE + N VALMBCK,VALMBG,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD + ;Get Patient List record and associated data. + S LDATA=$G(^PXRMXP(810.5,IEN,0)) + S LNAME=$P(LDATA,U,1) + S CDATE=$P(LDATA,U,4) + S SOURCE=$P(LDATA,U,5),SNAME="" + ;Check if generated from #810.2 + I SOURCE S SNAME="Extract Parameter - "_$P($G(^PXRM(810.2,SOURCE,0)),U) + ;If not check if generated from #810.4 + I SNAME="" D + . S SOURCE=$P(LDATA,U,6) + . I SOURCE'="" S SNAME="List Rule - "_$P($G(^PXRM(810.4,SOURCE,0)),U) + ;If still no source check for created from Reminder Due Report. + I SNAME="" D + . S SOURCE=$P(LDATA,U,9) + . I SOURCE'="" S SNAME="Reminder Due Report" + ;If there still is no source then assume it was generated in the + ;past by a Reminder Due Report. + I SNAME="" S SNAME="Reminder Due Report" + ;Creator + S CREATOR=+$P(LDATA,U,7) + S CREATOR=$S(CREATOR>0:$$GET1^DIQ(200,CREATOR,.01),1:"None") + ;Type + S TYPE=$P(LDATA,U,8) + S TYPE=$$EXTERNAL^DILFD(810.5,.08,"",TYPE,.EM) + ;Class + S CLASS=$P($G(^PXRMXP(810.5,IEN,100)),U) + S CLASS=$S(CLASS="N":"National",CLASS="V":"VISN",1:"Local") + ;Default view by name. + S PXRMVIEW="N" + S VALMCNT=0 + D EN^VALM("PXRM PATIENT LIST PATIENTS") + Q + ; +BLDLIST(IEN) ;Build a list of all patients + N IND,INCINST + S INCINST=+$P(^PXRMXP(810.5,IEN,0),U,10) + I 'INCINST D CHGCAP^VALM("HEADER3","") + K ^TMP("PXRMLPP",$J),^TMP("PXRMLPPA",$J),^TMP("PXRMLPPI",$J) + D LIST(.VALMCNT,.IEN,INCINST) + F IND=1:1:VALMCNT D + .S ^TMP("PXRMLPP",$J,"IDX",IND,IND)=^TMP("PXRMLPPI",$J,IND) + K ^TMP("PXRMLPPI",$J) + Q +DEM ; + D FULL^VALM1 + D EN^PXRMPDR(IEN) + S VALMBCK="R" + Q + ; +EDIT ;Edit selected patient list fields. + N DA,DIE,DR,TEMP + S DA=IEN,DIE="^PXRMXP(810.5," + S DR=".01;.08" + I $D(^XUSEC("PXRM MANAGER",DUZ)) S DR=DR_";.07" + D ^DIE + S TEMP=^PXRMXP(810.5,IEN,0) + S LNAME=$P(TEMP,U,1),CREATOR=$P(TEMP,U,7),TYPE=$P(TEMP,U,8) + S CREATOR=$P(^VA(200,CREATOR,0),U,1) + D HDR^PXRMLPP + S VALMBCK="R" + Q + ; +EDITOK(IEN) ;Screen for protocol PXRM PATIENT LIST EDIT, return true if + ;the user is permitted to edit the selected patient list. + I $D(^XUSEC("PXRM MANAGER",DUZ)) Q 1 + N CREATOR + S CREATOR=$P(^PXRMXP(810.5,IEN,0),U,7) + Q $S(CREATOR=DUZ:1,1:0) + ; +ENTRY ;Entry code + D BLDLIST(IEN) + D XQORM + Q + ; +EXIT ;Exit code + K ^TMP("PXRMLPP",$J) + K ^TMP("PXRMLPPH",$J) + D CLEAN^VALM10 + D FULL^VALM1 + S VALMBCK="R" + Q + ; +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 + 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)=" Class: "_CLASS + S VALMHDR(3)=$$LJ^XLFSTR(VALMHDR(3),40)_"Type: "_TYPE + S VALMHDR(4)=" Source: "_SNAME + S VALMSG="+ Next Screen - Prev Screen ?? More Actions" + Q + ; +HLP ;Help code + N ORU,ORUPRMT,SUB,XQORM + S SUB="PXRMLPPH" + D EN^VALM("PXRM PATIENT LIST HELP") + Q +HSA ;Print Health Summary for all patients on list + D HSA^PXRMLPHS(IEN) + S VALMBCK="R" + Q + ; +HSI ;Print Health Summary for selected patients. + ;Full Screen + W IORESET + N IND,DFN,PLNODE,PNAME,VALMY + D EN^VALM2(XQORNOD(0)) + ;If there is no list quit. + I '$D(VALMY) Q + S PLNODE="PXRMLPHS"_$J_$$NOW^XLFDT + K ^XTMP(PLNODE) + S ^XTMP(PLNODE,0)=$$FMADD^XLFDT(DT,2)_U_DT_"HSI LIST" + S IND="",PXRMDONE=0 + F S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE) D + .;Get the patient list ien. + .S DFN=^TMP("PXRMLPP",$J,"IDX",IND,IND) + .;DBIA #10035 + .S PNAME=$P(^DPT(DFN,0),U,1) + .S ^XTMP(PLNODE,PNAME)=DFN + D HSI^PXRMLPHS(PLNODE) + S VALMBCK="R" + Q + ; +INIT ;Init + S VALMCNT=0 + Q + ; +LIST(VALMCNT,IEN,INCINST) ;Build a list of patients. + N DATA,DFN,IND,INST,NEXT,PNAME,SUB + ;Build the ordered list. + S IND=0,SUB="NAME" + F S IND=$O(^PXRMXP(810.5,IEN,30,IND)) Q:'IND D + .S DATA=$G(^PXRMXP(810.5,IEN,30,IND,0)) Q:DATA="" + .S DFN=$P(DATA,U) Q:'DFN + .;#DBIA 10035 + .S PNAME=$P($G(^DPT(DFN,0)),U,1) + .S INSTNUM=$P(DATA,U,2) S:INSTNUM="" INSTNUM="NONE" + .S INST=$P(DATA,U,3) + .;Lists built before PXRM*2*4 will only have the Institution ien. + .I INST="" S INST=$P(DATA,U,2) + .I INST="" S INST="NONE" + .I PXRMVIEW="I" S SUB=INST + .S ^TMP("PXRMLPPA",$J,SUB,PNAME,DFN)=INST + ;Transfer to list manager array + S SUB="",VALMCNT=0 + F S SUB=$O(^TMP("PXRMLPPA",$J,SUB)) Q:SUB="" D + .S (INST,PNAME)="" + .F S PNAME=$O(^TMP("PXRMLPPA",$J,SUB,PNAME)) Q:PNAME="" D + ..S DFN="" + ..F S DFN=$O(^TMP("PXRMLPPA",$J,SUB,PNAME,DFN)) Q:DFN="" D + ...I INCINST S INST=^TMP("PXRMLPPA",$J,SUB,PNAME,DFN) + ...S VALMCNT=VALMCNT+1 + ...S ^TMP("PXRMLPP",$J,VALMCNT,0)=$$FRE(VALMCNT,PNAME,INST,DFN) + ...S ^TMP("PXRMLPPI",$J,VALMCNT)=DFN + K ^TMP("PXRMLPPA",$J) + Q + ; +PEXIT ;PXRM PATIENT LIST PATIENTS MENU protocol exit code + S VALMSG="+ Next Screen - Prev Screen ?? More Actions" + D XQORM + Q + ; +USER ; + I $P($G(^PXRMXP(810.5,IEN,0)),U,8)="PUB" D FULL^VALM1 W !,"This option is locked for Public Lists." H 2 Q + D FULL^VALM1 + D START^PXRMLPAU(IEN) + S VALMBCK="R" + Q + ; +USR(IEN) ;Screen for protocol PXRM PATIENT LIST AUTH USER + N TYPE + S TYPE=$P(^PXRMXP(810.5,IEN,0),U,8) + ;Public lists cannot have individual user access. + I TYPE="PUB" Q "N" + Q $$ACCESS^PXRMLPU(IEN) + ; +VIEW ;Select view + W IORESET + S VALMBCK="R",VALMBG=1 + N X,Y,CODE,DIR + K DIROUT,DIRUT,DTOUT,DUOUT + S DIR(0)="S"_U_"I:Sort by Institution and Name;" + S DIR(0)=DIR(0)_"N:Sort by Name;" + S DIR("A")="TYPE OF VIEW" + S DIR("B")=$S(PXRMVIEW="N":"I",1:"N") + S DIR("?")="Select from the codes displayed." + D ^DIR K DIR + I $D(DIROUT) S DTOUT=1 + I $D(DTOUT)!($D(DUOUT)) Q + ;Change display type + S PXRMVIEW=Y + ;Rebuild Workfile + D BLDLIST^PXRMLPP(IEN),HDR + Q + ; +XSEL ;PXRM PATIENT LIST PATIENT SELECT validation + N EPIEN,DFN,SEL + 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 patient list ien + S DFN=^TMP("PXRMLPP",$J,"IDX",SEL,SEL) + ;Full screen mode + D FULL^VALM1 + ;Print individual Health Summary + D HSI^PXRMLPHS(DFN) + S VALMBCK="R" + Q + ; +XQORM S XQORM("#")=$O(^ORD(101,"B","PXRM PATIENT LIST PATIENT SELECT",0))_U_"1:"_VALMCNT + S XQORM("A")="Select Item: " + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMLPU.m b/r/CLINICAL_REMINDERS-PXRM/PXRMLPU.m index 926250a1..aa4f3ae2 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMLPU.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMLPU.m @@ -1,286 +1,295 @@ -PXRMLPU ; SLC/PKR/PJH - Reminder Patient List ;10/11/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ;Main entry point for PXRM PATIENT LIST -START(MODE) ; - N PXRMDONE,VALMBCK,VALMSG,X,XMZ,MODE1 - S X="IORESET" - D ENDR^%ZISS - S VALMCNT=0 - D EN^VALM("PXRM PATIENT LIST USER") - W IORESET - D KILL^%ZISS - Q - ; -ACCESS(IEN,NODE) ; - ;Holders of the PXRM MANAGER key have full access to all lists. - ;DBIA #10076 - I $D(^XUSEC("PXRM MANAGER",DUZ)) Q "F" - N ACCESS,TYPE - I $G(NODE)="" S NODE=$G(^PXRMXP(810.5,IEN,0)) - S TYPE=$P(NODE,U,8) - I TYPE="" Q "F" - I TYPE="PUB" Q "F" - I $P(NODE,U,7)=DUZ Q "F" - S ACCESS="N" - I TYPE="PVT",$D(^PXRMXP(810.5,IEN,40,"B",DUZ)) D - . N USIEN,STATUS - . S USIEN=$O(^PXRMXP(810.5,IEN,40,"B",DUZ,"")) - . S ACCESS=$S(USIEN="":"N",1:$P(^PXRMXP(810.5,IEN,40,USIEN,0),U,2)) - Q ACCESS - ; -BLDLIST ; - N PLIST - K ^TMP("PXRMLPU",$J) - K ^TMP("PXRMLPUH",$J) - S PLIST="PXRMLPU" - D LIST(MODE,PLIST) - S VALMCNT=+$G(^TMP("PXRMLPU",$J,"VALMCNT")) - Q - ; -ENTRY ;Entry code - ;MODE=0 ORDER BY NAME - ;MODE=1 ORDER BY TYPE - I $G(MODE)'>0 S MODE=0 - D BLDLIST,XQORM - Q - ; -EXIT ;Exit code - K ^TMP("PXRMLPU",$J) - K ^TMP("PXRMLPUH",$J) - D CLEAN^VALM10 - D FULL^VALM1 - S VALMBCK="R" - Q - ; -HDR ; Header code - N NAME - S VALMHDR(1)="Available Patient Lists." - Q - ; -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 DCD to display creation documentation.\\" - .S HTEXT(5)="Select DSP to display the patient list.\\" - D HELP^PXRMEUT(.HTEXT) - Q - ; -HLP ;Help code - N ORU,ORUPRMT,SUB,XQORM - S SUB="PXRMLPUH" - D EN^VALM("PXRM PATIENT LIST HELP") - Q - ; -INIT ;Init - S VALMCNT=0 - 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") - ;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="" - 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) - ..I ACCESS="N" Q - ..S FNAME=$P($G(DATA),U),DATE=$P($G(DATA),U,4) - ..S COUNT=+$P($G(^PXRMXP(810.5,IND,30,0)),U,4) - ..S TYPE=$P(DATA,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 - I '$D(^TMP($J,PLIST)) Q - ;Loop through ARRAY to populate the output list - ;sub is either the type of list or 'NAME'. If sort is - ;by TYPE show PVT lists first. - 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 ^TMP(PLIST,$J,"VALMCNT")=VALMCNT - K ^TMP($J,PLIST) - Q - ; -PCOPY ;Patient list copy - S SUB="PXRMLPU" - D PCOPY1(SUB) - D BLDLIST - S VALMBCK="R" - Q - ; -PCOPY1(SUB) ; - ;Full Screen - W IORESET - N IND,LISTIEN,VALMY - D EN^VALM2(XQORNOD(0)) - ;If there is no list quit. - I '$D(VALMY) Q - S IND="",PXRMDONE=0 - 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) - Q - ; -PDELETE ;Patient list delete - ;Full Screen - W IORESET - N DELOK,IND,LISTIEN,NODE,VALMY - D EN^VALM2(XQORNOD(0)) - ;If there is no list quit. - I '$D(VALMY) Q - S IND="",PXRMDONE=0 - F S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE) D - .;Get the patient list ien. - .S LISTIEN=^TMP("PXRMLPU",$J,"SEL",IND) - .S NODE=$G(^PXRMXP(810.5,LISTIEN,0)) - .S DELOK=$$LDELOK^PXRMEUT(LISTIEN) - .I DELOK D DELETE^PXRMRUL1(LISTIEN) Q - .E D Q - ..W !,"In order to delete a list you must be the creator or a Reminder Manager!" - ..S PXRMDONE=1 H 2 - D BLDLIST - S VALMBCK="R" - Q - ; -PEXIT ;Protocol exit code - S VALMSG="+ Next Screen - Prev Screen ?? More Actions" - ;Reset after page up/down etc - D XQORM - Q - ; -POERR ;Patient list copy to OERR Team (#101.21) - ;Full Screen - W IORESET - N ACCESS,IND,LISTIEN,NODE,USIEN,VALMY - D EN^VALM2(XQORNOD(0)) - ;If there is no list quit. - I '$D(VALMY) Q - S IND="",PXRMDONE=0 - F S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE) D - .;Get the patient list ien. - .S LISTIEN=^TMP("PXRMLPU",$J,"SEL",IND) - .S NODE=$G(^PXRMXP(810.5,LISTIEN,0)) - .S ACCESS=$$ACCESS^PXRMLPU(LISTIEN,NODE) - .I ACCESS="F" D OERR^PXRMLPOE(LISTIEN) - .I ACCESS="N" D - ..W !,"The list cannot be copied; you must have full access to copy the list to an OE/RR team!" - ..S PXRMDONE=1 H 2 - S VALMBCK="R" - Q - ; -PLIST ;Patient list inquiry. - N CREAT,NAME,IND,LISTIEN,USIEN,VALMY,CREAT,NODE,TRUE - D EN^VALM2(XQORNOD(0)) - ;If there is no list quit. - I '$D(VALMY) Q - ;PXRMDONE is newed in PXRMLPU - S PXRMDONE=0 - S IND="" - F S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE) D - .S LISTIEN=^TMP("PXRMLPU",$J,"SEL",IND) - .D START^PXRMLPP(LISTIEN) - D BLDLIST - S VALMBCK="R" - Q - ; -VIEW ; - D FULL^VALM1 - N DIR,DTOUT,DUOUT,DIROUT,DIROUT,Y - S DIR(0)="SO^N:NAME;T:TYPE" - S DIR("A")="Select View Type" - D ^DIR - I $D(DTOUT),$D(DUOUT),$D(DIROUT) Q - I Y="N" S MODE=0 D ENTRY - I Y="T" S MODE=1 D ENTRY - Q - ; -XQORM ; - S XQORM("#")=$O(^ORD(101,"B","PXRM PATIENT LIST USER SELECT ENTRY",0))_U_"1:"_VALMCNT - S XQORM("A")="Select Item: " - Q - ; -XSEL ;SELECT validation - N EPIEN,LEVEL,LISTIEN,LRIEN,NODE,SEL - 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 patient list ien - S LISTIEN=^TMP("PXRMLPU",$J,"SEL",SEL) - ;Get extract definition ien (if present) - S EPIEN=$P($G(^PXRMXP(810.5,LISTIEN,0)),U,5) - ;Get list rule ien - S LRIEN=$P($G(^PXRMXP(810.5,LISTIEN,0)),U,6) - S NODE=$G(^PXRMXP(810.5,LISTIEN,0)) - ; - ;Full screen mode - D FULL^VALM1 - ; - ;Option to Install, Delete or Install History - N ACCESS,DELOK,DIR,OPTION,RIEN,X,Y - K DIROUT,DIRUT,DTOUT,DUOUT - S ACCESS=$$ACCESS(LISTIEN,NODE) - S DELOK=$$LDELOK^PXRMEUT(LISTIEN) - S DIR(0)="SBM"_U_"CO:Copy Patient List;" - S DIR(0)=DIR(0)_"COE:Copy to OE/RR Team;" - I DELOK S DIR(0)=DIR(0)_"DE:Delete Patient List;" - S DIR(0)=DIR(0)_"DCD:Display Creation Documentation;" - S DIR(0)=DIR(0)_"DSP:Display Patient List;" - S DIR("A")="Select Action: " - S DIR("B")="DSP" - S DIR("?")="Select from the codes displayed. For detailed help type ??" - S DIR("??")=U_"D HELP^PXRMLPU(1)" - D ^DIR K DIR - I $D(DIROUT) S DTOUT=1 - I $D(DTOUT)!($D(DUOUT)) S VALMBCK="R" Q - S OPTION=Y - ; - I $G(OPTION)="" G XSELE - ; - ;Copy patient list - I OPTION="CO" D COPY^PXRMRUL1(LISTIEN) - Q:$D(DUOUT)!$D(DTOUT) - ; - ;Copy to OE/RR Team - I OPTION="COE" D OERR^PXRMLPOE(LISTIEN) - Q:$D(DUOUT)!$D(DTOUT) - ; - ;Delete patient list - I OPTION="DE" D PDELETE - ; - ;Display creation documentation - I OPTION="DCD" D EN^PXRMLCD(LISTIEN) - ; - ;Display patient list - I OPTION="DSP" D START^PXRMLPP(LISTIEN) - ; -XSELE ; - D CLEAN^VALM10 - D BLDLIST,XQORM - S VALMBCK="R" - Q +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 +START(MODE) ; + N PXRMDONE,VALMBCK,VALMSG,X,XMZ,MODE1 + S X="IORESET" + D ENDR^%ZISS + S VALMCNT=0 + D EN^VALM("PXRM PATIENT LIST USER") + W IORESET + D KILL^%ZISS + Q + ; +ACCESS(IEN,NODE) ; + ;Holders of the PXRM MANAGER key have full access to all lists. + ;DBIA #10076 + I $D(^XUSEC("PXRM MANAGER",DUZ)) Q "F" + N ACCESS,TYPE + I $G(NODE)="" S NODE=$G(^PXRMXP(810.5,IEN,0)) + S TYPE=$P(NODE,U,8) + I TYPE="" Q "F" + I TYPE="PUB" Q "F" + I $P(NODE,U,7)=DUZ Q "F" + S ACCESS="N" + I TYPE="PVT",$D(^PXRMXP(810.5,IEN,40,"B",DUZ)) D + . N USIEN,STATUS + . S USIEN=$O(^PXRMXP(810.5,IEN,40,"B",DUZ,"")) + . S ACCESS=$S(USIEN="":"N",1:$P(^PXRMXP(810.5,IEN,40,USIEN,0),U,2)) + Q ACCESS + ; +BLDLIST ; + N IEN,PLIST + K ^TMP("PXRMLPU",$J) + K ^TMP("PXRMLPUH",$J) + S PLIST="PXRMLPU" + 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 + ; +ENTRY ;Entry code + ;MODE=0 ORDER BY NAME + ;MODE=1 ORDER BY TYPE + I $G(MODE)'>0 S MODE=0 + D BLDLIST,XQORM + Q + ; +EXIT ;Exit code + K ^TMP("PXRMLPU",$J) + K ^TMP("PXRMLPUH",$J) + D CLEAN^VALM10 + D FULL^VALM1 + S VALMBCK="R" + 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 + S VALMHDR(1)="Available Patient Lists." + Q + ; +HELP(CALL) ;General help text routine + N HTEXT + I CALL=1 D + .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 + ; +HLP ;Help code + N ORU,ORUPRMT,SUB,XQORM + S SUB="PXRMLPUH" + D EN^VALM("PXRM PATIENT LIST HELP") + Q + ; +INIT ;Init + S VALMCNT=0 + Q + ; +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="",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 NODE=$G(^PXRMXP(810.5,IND,0)) + ..S ACCESS=$$ACCESS(IND,NODE) + ..I ACCESS="N" Q + ..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(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 + I '$D(^TMP($J,PLIST)) Q + ;Loop through ARRAY to populate the output list + ;sub is either the type of list or 'NAME'. If sort is + ;by TYPE show PVT lists first. + 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 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) + Q + ; +PCOPY ;Patient list copy + S SUB="PXRMLPU" + D PCOPY1(SUB) + D BLDLIST + S VALMBCK="R" + Q + ; +PCOPY1(SUB) ; + ;Full Screen + W IORESET + N IND,LISTIEN,VALMY + D EN^VALM2(XQORNOD(0)) + ;If there is no list quit. + I '$D(VALMY) Q + S IND="",PXRMDONE=0 + F S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE) D + .;Get the patient list ien. + .S LISTIEN=^TMP(SUB,$J,"IDX",IND,IND) + .D COPY^PXRMRULE(LISTIEN) + Q + ; +PDELETE ;Patient list delete + ;Full Screen + W IORESET + N DELOK,IND,LISTIEN,NODE,VALMY + D EN^VALM2(XQORNOD(0)) + ;If there is no list quit. + I '$D(VALMY) Q + S IND="",PXRMDONE=0 + F S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE) D + .;Get the patient list ien. + .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^PXRMRULE(LISTIEN) Q + .E D Q + ..W !,"In order to delete a list you must be the creator or a Reminder Manager!" + ..S PXRMDONE=1 H 2 + D BLDLIST + S VALMBCK="R" + Q + ; +PEXIT ;Protocol exit code + S VALMSG="+ Next Screen - Prev Screen ?? More Actions" + ;Reset after page up/down etc + D XQORM + Q + ; +POERR ;Patient list copy to OERR Team (#101.21) + ;Full Screen + W IORESET + N ACCESS,IND,LISTIEN,NODE,USIEN,VALMY + D EN^VALM2(XQORNOD(0)) + ;If there is no list quit. + I '$D(VALMY) Q + S IND="",PXRMDONE=0 + F S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE) D + .;Get the patient list ien. + .S LISTIEN=^TMP("PXRMLPU",$J,"IDX",IND,IND) + .S NODE=$G(^PXRMXP(810.5,LISTIEN,0)) + .S ACCESS=$$ACCESS^PXRMLPU(LISTIEN,NODE) + .I ACCESS="F" D OERR^PXRMLPOE(LISTIEN) + .I ACCESS="N" D + ..W !,"The list cannot be copied; you must have full access to copy the list to an OE/RR team!" + ..S PXRMDONE=1 H 2 + S VALMBCK="R" + Q + ; +PLIST ;Patient list inquiry. + N CREAT,NAME,IND,LISTIEN,USIEN,VALMY,CREAT,NODE,TRUE + D EN^VALM2(XQORNOD(0)) + ;If there is no list quit. + I '$D(VALMY) Q + ;PXRMDONE is newed in PXRMLPU + S PXRMDONE=0 + S IND="" + F S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE) D + .S LISTIEN=^TMP("PXRMLPU",$J,"IDX",IND,IND) + .D START^PXRMLPP(LISTIEN) + D BLDLIST + S VALMBCK="R" + Q + ; +VIEW ; + D FULL^VALM1 + N DIR,DTOUT,DUOUT,DIROUT,DIROUT,Y + S DIR(0)="SO^N:NAME;T:TYPE" + S DIR("A")="Select View Type" + D ^DIR + I $D(DTOUT),$D(DUOUT),$D(DIROUT) Q + I Y="N" S MODE=0 D ENTRY + I Y="T" S MODE=1 D ENTRY + Q + ; +XQORM ; + S XQORM("#")=$O(^ORD(101,"B","PXRM PATIENT LIST USER SELECT ENTRY",0))_U_"1:"_VALMCNT + S XQORM("A")="Select Item: " + Q + ; +XSEL ;SELECT validation + N EPIEN,LEVEL,LISTIEN,LRIEN,NODE,SEL + 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 patient list ien + 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) + ;Get list rule ien + S LRIEN=$P($G(^PXRMXP(810.5,LISTIEN,0)),U,6) + S NODE=$G(^PXRMXP(810.5,LISTIEN,0)) + ; + ;Full screen mode + D FULL^VALM1 + ; + ;Option to Install, Delete or Install History + N ACCESS,DELOK,DIR,OPTION,RIEN,X,Y + K DIROUT,DIRUT,DTOUT,DUOUT + S ACCESS=$$ACCESS(LISTIEN,NODE) + S DELOK=$$LDELOK^PXRMEUT(LISTIEN) + S DIR(0)="SBM"_U_"CO:Copy Patient List;" + S DIR(0)=DIR(0)_"COE:Copy to OE/RR Team;" + I DELOK S DIR(0)=DIR(0)_"DE:Delete Patient List;" + S DIR(0)=DIR(0)_"DCD:Display Creation Documentation;" + S DIR(0)=DIR(0)_"DSP:Display Patient List;" + S DIR("A")="Select Action: " + S DIR("B")="DSP" + S DIR("?")="Select from the codes displayed. For detailed help type ??" + S DIR("??")=U_"D HELP^PXRMLPM(1)" + D ^DIR K DIR + I $D(DIROUT) S DTOUT=1 + I $D(DTOUT)!($D(DUOUT)) S VALMBCK="R" Q + S OPTION=Y + ; + I $G(OPTION)="" G XSELE + ; + ;Copy patient list + I OPTION="CO" D COPY^PXRMRULE(LISTIEN) + Q:$D(DUOUT)!$D(DTOUT) + ; + ;Copy to OE/RR Team + I OPTION="COE" D OERR^PXRMLPOE(LISTIEN) + Q:$D(DUOUT)!$D(DTOUT) + ; + ;Delete patient list + I OPTION="DE" D PDELETE + ; + ;Display creation documentation + I OPTION="DCD" D EN^PXRMLCD(LISTIEN) + ; + ;Display patient list + I OPTION="DSP" D START^PXRMLPP(LISTIEN) + ; +XSELE ; + D CLEAN^VALM10 + D BLDLIST,XQORM + S VALMBCK="R" + Q diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMLRM.m b/r/CLINICAL_REMINDERS-PXRM/PXRMLRM.m index ed9b0ee1..bf1437e5 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMLRM.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMLRM.m @@ -1,205 +1,204 @@ -PXRMLRM ; SLC/PJH/PKR - List Rule Management ; 09/06/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ;Main entry point for PXRM LIST RULE MANAGEMENT -START N PXRMDONE,PXRMTYP,VALMBCK,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD - S X="IORESET" - D ENDR^%ZISS - S VALMCNT=0 - ;Default view is Rule Sets - S PXRMTYP=3 - D EN^VALM("PXRM LIST RULE MANAGEMENT") - Q - ; -BLDLIST ;Build workfile - K ^TMP("PXRMLRM",$J) - N IEN,IND,PLIST - D LIST(.PLIST,.IEN,PXRMTYP) - M ^TMP("PXRMLRM",$J)=PLIST - S VALMCNT=PLIST("VALMCNT") - F IND=1:1:VALMCNT D - .S ^TMP("PXRMLRM",$J,"IDX",IND,IND)=IEN(IND) - I PXRMTYP=1 D CHGCAP^VALM("HEADER2","Finding Rule Name") - I PXRMTYP=2 D CHGCAP^VALM("HEADER2","Reminder Rule Name") - I PXRMTYP=3 D CHGCAP^VALM("HEADER2","Rule Set Name") - I PXRMTYP=4 D CHGCAP^VALM("HEADER2","Report Output Rule Name") - I PXRMTYP=5 D CHGCAP^VALM("HEADER2","Patient List Rule Name") - Q - ; -ENTRY ;Entry code - D BLDLIST,XQORM - Q - ; -EXIT ;Exit code - K ^TMP("PXRMLRM",$J) - K ^TMP("PXRMLRMH",$J) - D CLEAN^VALM10 - D FULL^VALM1 - S VALMBCK="Q" - 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,60) - S TEMP=TEMP_" "_$$LJ^XLFSTR(TNAME,60," ") - S TCLASS=$S(CLASS="N":"NATIONAL",CLASS="V":"VISN",1:"LOCAL") - S TEMP=TEMP_" "_TCLASS - Q TEMP - ; -HDR ; Header code - 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 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." - ; - D HELP^PXRMEUT(.HTEXT) - Q - ; -HLP ;Help code - N ORU,ORUPRMT,SUB,XQORM - S SUB="PXRMLRMH" - D EN^VALM("PXRM LIST RULE HELP") - Q - ; -INIT ;Init - S VALMCNT=0 - Q - ; -LIST(RLIST,IEN,LRTYP) ;Build a list of list rule entries. - N DATA,IND,LRCLASS,LRNAME,NAME - ;Build the list in alphabetical order. - S VALMCNT=0 - S NAME="" - F S NAME=$O(^PXRM(810.4,"B",NAME)) Q:NAME="" D - .S IND=$O(^PXRM(810.4,"B",NAME,"")) Q:'IND - .S DATA=$G(^PXRM(810.4,IND,0)) - .I $P(DATA,U,3)'=LRTYP Q - .S LRNAME=$P(DATA,U) - .S LRCLASS=$P($G(^PXRM(810.4,IND,100)),U) - .S VALMCNT=VALMCNT+1 - .S RLIST(VALMCNT,0)=$$FRE(VALMCNT,LRNAME,LRCLASS) - .S IEN(VALMCNT)=IND - S RLIST("VALMCNT")=VALMCNT - Q - ; -LRADD ;Add Rule Option - ; - ;Reset Screen Mode - W IORESET - ; - ;Add Rule - D ADD^PXRMLRED - ; - ;Rebuild Workfile - D BLDLIST - S VALMBCK="R" - Q - ; -LRINQ ;Rule Inquiry - PXRM LIST RULE DISPLAY/EDIT entry - N IND,LRIEN,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 LRIEN=^TMP("PXRMLRM",$J,"IDX",IND,IND) - .D START^PXRMLRED(LRIEN,PXRMTYP) - D BLDLIST - S VALMBCK="R" - Q - ; -PEXIT ;Protocol exit code - S VALMSG="+ Next Screen - Prev Screen ?? More Actions" - ;Reset after page up/down etc - D XQORM - Q - ; -VIEW ;Select view - W IORESET - S VALMBCK="R" - N X,Y,CODE,DIR - K DIROUT,DIRUT,DTOUT,DUOUT - S DIR(0)="S"_U_"F:Finding Rule;" - S DIR(0)=DIR(0)_"P:Patient List Rule;" - S DIR(0)=DIR(0)_"R:Reminder Rule;" - S DIR(0)=DIR(0)_"S:Rule Set;" - S DIR("A")="TYPE OF VIEW" - S DIR("B")="F" - S DIR("?")="Select from the codes displayed. For detailed help type ??" - S DIR("??")=U_"D HELP^PXRMLRM(2)" - D ^DIR K DIR - I $D(DIROUT) S DTOUT=1 - I $D(DTOUT)!($D(DUOUT)) Q - ;Change display type - S PXRMTYP=$S(Y="F":1,Y="P":5,Y="S":3,1:4) - S PXRMTYP=$S(Y="F":1,Y="P":5,Y="S":3,Y="R":2,1:4) - ;Rebuild Workfile - D BLDLIST,HDR - Q - ; -XSEL ;PXRM LIST RULE MANAGEMENT SELECT ENTRY validation - N SEL,IEN - 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 IEN=^TMP("PXRMLRM",$J,"IDX",SEL,SEL) - ; - ;Option to Display/Edit or Test Rule Set. - N DIR,OPTION,RIEN,X,Y - K DIROUT,DIRUT,DTOUT,DUOUT - S DIR(0)="SBM"_U_"DR:Display/Edit Rule;" - I $G(PXRMTYP)=3 S DIR(0)=DIR(0)_"TEST:Test Rule Set" - S DIR("A")="Select Action: " - S DIR("B")="DR" - S DIR("?")="Select from the codes displayed." - D ^DIR K DIR - I $D(DIROUT) S DTOUT=1 - I $D(DTOUT)!($D(DUOUT)) S VALMBCK="R" Q - S OPTION=Y - I $G(OPTION)="" G XSELE - ; - ;Display/Edit - I OPTION="DR" D START^PXRMLRED(IEN,PXRMTYP) - Q:$D(DUOUT)!$D(DTOUT) - ; - ;Rule set test - I OPTION="TEST" D RSTEST^PXRMRST(IEN) - Q:$D(DUOUT)!$D(DTOUT) - ; -XSELE ; - D CLEAN^VALM10 - D BLDLIST,XQORM - S VALMBCK="R" - Q - ; -XQORM S XQORM("#")=$O(^ORD(101,"B","PXRM LIST RULE MANAGEMENT SELECT ENTRY",0))_U_"1:"_VALMCNT - S XQORM("A")="Select Item: " - Q - ; +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 +START N PXRMDONE,PXRMTYP,VALMBCK,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD + S X="IORESET" + D ENDR^%ZISS + S VALMCNT=0 + ;Default view is Rule Sets + S PXRMTYP=3 + D EN^VALM("PXRM LIST RULE MANAGEMENT") + Q + ; +BLDLIST ;Build workfile + K ^TMP("PXRMLRM",$J) + N IEN,IND,PLIST + D LIST(.PLIST,.IEN,PXRMTYP) + M ^TMP("PXRMLRM",$J)=PLIST + S VALMCNT=PLIST("VALMCNT") + F IND=1:1:VALMCNT D + .S ^TMP("PXRMLRM",$J,"IDX",IND,IND)=IEN(IND) + I PXRMTYP=1 D CHGCAP^VALM("HEADER2","Finding Rule Name") + I PXRMTYP=2 D CHGCAP^VALM("HEADER2","Reminder Rule Name") + I PXRMTYP=3 D CHGCAP^VALM("HEADER2","Rule Set Name") + I PXRMTYP=4 D CHGCAP^VALM("HEADER2","Report Output Rule Name") + I PXRMTYP=5 D CHGCAP^VALM("HEADER2","Patient List Rule Name") + Q + ; +ENTRY ;Entry code + D BLDLIST,XQORM + Q + ; +EXIT ;Exit code + K ^TMP("PXRMLRM",$J) + K ^TMP("PXRMLRMH",$J) + D CLEAN^VALM10 + D FULL^VALM1 + S VALMBCK="Q" + 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,60) + S TEMP=TEMP_" "_$$LJ^XLFSTR(TNAME,60," ") + S TCLASS=$S(CLASS="N":"NATIONAL",CLASS="V":"VISN",1:"LOCAL") + S TEMP=TEMP_" "_TCLASS + Q TEMP + ; +HDR ; Header code + 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 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 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) + Q + ; +HLP ;Help code + N ORU,ORUPRMT,SUB,XQORM + S SUB="PXRMLRMH" + D EN^VALM("PXRM LIST RULE HELP") + Q + ; +INIT ;Init + S VALMCNT=0 + Q + ; +LIST(RLIST,IEN,LRTYP) ;Build a list of list rule entries. + N DATA,IND,LRCLASS,LRNAME,NAME + ;Build the list in alphabetical order. + S VALMCNT=0 + S NAME="" + F S NAME=$O(^PXRM(810.4,"B",NAME)) Q:NAME="" D + .S IND=$O(^PXRM(810.4,"B",NAME,"")) Q:'IND + .S DATA=$G(^PXRM(810.4,IND,0)) + .I $P(DATA,U,3)'=LRTYP Q + .S LRNAME=$P(DATA,U) + .S LRCLASS=$P($G(^PXRM(810.4,IND,100)),U) + .S VALMCNT=VALMCNT+1 + .S RLIST(VALMCNT,0)=$$FRE(VALMCNT,LRNAME,LRCLASS) + .S IEN(VALMCNT)=IND + S RLIST("VALMCNT")=VALMCNT + Q + ; +LRADD ;Add Rule Option + ; + ;Reset Screen Mode + W IORESET + ; + ;Add Rule + D ADD^PXRMLRED + ; + ;Rebuild Workfile + D BLDLIST + S VALMBCK="R" + Q + ; +LRINQ ;Rule Inquiry - PXRM LIST RULE DISPLAY/EDIT entry + N IND,LRIEN,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 LRIEN=^TMP("PXRMLRM",$J,"IDX",IND,IND) + .D START^PXRMLRED(LRIEN,PXRMTYP) + D BLDLIST + S VALMBCK="R" + Q + ; +PEXIT ;Protocol exit code + S VALMSG="+ Next Screen - Prev Screen ?? More Actions" + ;Reset after page up/down etc + D XQORM + Q + ; +VIEW ;Select view + W IORESET + S VALMBCK="R" + N X,Y,CODE,DIR + K DIROUT,DIRUT,DTOUT,DUOUT + S DIR(0)="S"_U_"F:Finding Rule;" + S DIR(0)=DIR(0)_"P:Patient List Rule;" + S DIR(0)=DIR(0)_"R:Reminder Rule;" + S DIR(0)=DIR(0)_"S:Rule Set;" + S DIR("A")="TYPE OF VIEW" + S DIR("B")="F" + S DIR("?")="Select from the codes displayed. For detailed help type ??" + S DIR("??")=U_"D HELP^PXRMLRM(2)" + D ^DIR K DIR + I $D(DIROUT) S DTOUT=1 + I $D(DTOUT)!($D(DUOUT)) Q + ;Change display type + S PXRMTYP=$S(Y="F":1,Y="P":5,Y="S":3,1:4) + S PXRMTYP=$S(Y="F":1,Y="P":5,Y="S":3,Y="R":2,1:4) + ;Rebuild Workfile + D BLDLIST,HDR + Q + ; +XSEL ;PXRM LIST RULE MANAGEMENT SELECT ENTRY validation + N SEL,IEN + 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 IEN=^TMP("PXRMLRM",$J,"IDX",SEL,SEL) + ; + ;Option to Display/Edit or Test Rule Set. + N DIR,OPTION,RIEN,X,Y + K DIROUT,DIRUT,DTOUT,DUOUT + S DIR(0)="SBM"_U_"DR:Display/Edit Rule;" + I $G(PXRMTYP)=3 S DIR(0)=DIR(0)_"TEST:Test Rule Set" + S DIR("A")="Select Action: " + S DIR("B")="DR" + S DIR("?")="Select from the codes displayed." + D ^DIR K DIR + I $D(DIROUT) S DTOUT=1 + I $D(DTOUT)!($D(DUOUT)) S VALMBCK="R" Q + S OPTION=Y + I $G(OPTION)="" G XSELE + ; + ;Display/Edit + I OPTION="DR" D START^PXRMLRED(IEN,PXRMTYP) + Q:$D(DUOUT)!$D(DTOUT) + ; + ;Rule set test + I OPTION="TEST" D RSTEST^PXRMRST(IEN) + Q:$D(DUOUT)!$D(DTOUT) + ; +XSELE ; + D CLEAN^VALM10 + D BLDLIST,XQORM + S VALMBCK="R" + Q + ; +XQORM S XQORM("#")=$O(^ORD(101,"B","PXRM LIST RULE MANAGEMENT SELECT ENTRY",0))_U_"1:"_VALMCNT + S XQORM("A")="Select Item: " + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMMH.m b/r/CLINICAL_REMINDERS-PXRM/PXRMMH.m index 7bf6aeb0..13670579 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMMH.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMMH.m @@ -1,214 +1,182 @@ -PXRMMH ; SLC/PKR - Handle mental health findings. ;11/23/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ;======================================================= -EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate mental health findings. - D EVALFI^PXRMINDX(DFN,.DEFARR,ENODE,.FIEVAL) - Q - ; - ;======================================================= -EVALPL(FINDPA,ENODE,TERMARR,PLIST) ;Evaluate mental health term findings - ;for patient lists. - D EVALPL^PXRMINDL(.FINDPA,ENODE,.TERMARR,PLIST) - Q - ; - ;======================================================= -EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;Evaluate mental - ;health instrument terms. - D EVALTERM^PXRMINDX(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) - Q - ; - ;======================================================= -GETDATA(DASP,FIEVT) ;Return the data for a MH Administrations 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) - 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")_" = " - 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) - . D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT) - . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND) - S NLINES=NLINES+1,TEXT(NLINES)="" - Q - ; - ;======================================================= -OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical - ;maintenance output. - N IND,JND,MHTEST,NOUT,SCALE,SNAME,SCORE,TEXTOUT - S MHTEST=IFIEVAL("MH TEST") - 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 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) - . D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT) - . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND) - S NLINES=NLINES+1,TEXT(NLINES)="" - Q - ; - ;======================================================= -SCHELP(MHIEN) ;Xecutable help for MH SCALE - N DATA,IND,JND,NUM,SCALE,SNUM - 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 JND=JND+1 - . S NUM=6-$L(IND) - . S SCALE(JND)=$$INSCHR^PXRMEXLC(NUM," ")_(IND)_" "_$P(DATA("S",IND),U,1) - 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) - E S MHIEN=0 - D SCHELP(MHIEN) - Q - ; - ;======================================================= -SCHELPT ;Xecutable help for MH SCALE in 811.5 findings. - N MHIEN,TFIND0 - S TFIND0=^PXRMD(811.5,DA(1),20,DA,0) - I TFIND0["YTT(601.71" S MHIEN=$P(TFIND0,";",1) - E S MHIEN=0 - D SCHELP(MHIEN) - Q - ; - ;======================================================= -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 - 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. - 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) - I NFOUND=0 Q - F IND=1:1:NFOUND S FLIST(IND)=DATA(IND+1) - Q - ; - ;======================================================= -SEVALPL(ITEM,NOCC,BDT,EDT,PLIST) ;Use MH API to get patient list. Called - ;from PXRMINDL. - 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) - 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 - 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) - 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 - 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) - ; - ;======================================================= -VSCALEF(X) ;Make sure that the mental health scale is valid for a finding. - 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 FIND0 - S FIND0=^PXD(811.9,DA(1),20,DA,0) - Q $$VSCALE(X,FIND0) - ; - ;======================================================= -VSCALET(X) ;Make sure that the mental health scale is valid for a - ;term finding. - 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 TFIND0 - S TFIND0=^PXRMD(811.5,DA(1),20,DA,0) - 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 - ; +PXRMMH ; SLC/PKR - Handle mental health findings. ;04/05/2005 + ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21 + ; + ;======================================================= +EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate mental health findings. + D EVALFI^PXRMINDX(DFN,.DEFARR,ENODE,.FIEVAL) + Q + ; + ;======================================================= +EVALPL(FINDPA,ENODE,TERMARR,PLIST) ;Evaluate mental health term findings + ;for patient lists. + D EVALPL^PXRMINDL(.FINDPA,ENODE,.TERMARR,PLIST) + Q + ;======================================================= +EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;Evaluate mental + ;health instrument terms. + D EVALTERM^PXRMINDX(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) + Q + ; + ;======================================================= +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 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,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=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) + S NLINES=NLINES+1,TEXT(NLINES)="" + Q + ; + ;======================================================= +OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical + ;maintenance output. + 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 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) + S NLINES=NLINES+1,TEXT(NLINES)="" + Q + ; + ;======================================================= +SCHELP(MHIEN) ;Xecutable help for MH SCALE + 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) + 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 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 + ; + ;======================================================= +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" S MHIEN=$P(FIND0,";",1) + E S MHIEN=0 + D SCHELP(MHIEN) + Q + ; + ;======================================================= +SCHELPT ;Xecutable help for MH SCALE in 811.5 findings. + N MHIEN,TFIND0 + S TFIND0=^PXRMD(811.5,DA(1),20,DA,0) + I TFIND0["YTT(601" S MHIEN=$P(TFIND0,";",1) + E S MHIEN=0 + D SCHELP(MHIEN) + Q + ; + ;======================================================= +SEVALFI(DFN,ITEM,NGET,SDIR,BDT,EDT,NFOUND,FLIST) ; + N FIEV,FINDING,IND,YS,YSDATA + S YS("CODE")=ITEM,YS("DFN")=DFN + S YS("BEGIN")=BDT,YS("END")=EDT + ;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 #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)=YSDATA(IND+1) + Q + ; + ;======================================================= +SEVALPL(ITEM,NOCC,BDT,EDT,PLIST) ;Use MH API to get patient list. Called + ;from PXRMINDL. + N YS + ;YTAPI10A 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 #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 MHIEN,MHTEST,SCALE,VALID + S MHTEST=$P(FIND0,U,1) + S MHIEN=$P(MHTEST,";",1) + I +X>0 D Q VALID + . S VALID=$S($D(^YTT(601,MHIEN,"S",X)):1,1:0) + E D + . S SCALE=$O(^YTT(601,MHIEN,"S","C",X,"")) + . S VALID=$S(SCALE="":0,1:1) + Q VALID + ; + ;======================================================= +VSCALEF(X) ;Make sure that the mental health scale is valid for a finding. + 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 FIND0 + S FIND0=^PXD(811.9,DA(1),20,DA,0) + Q $$VSCALE(X,FIND0) + ; + ;======================================================= +VSCALET(X) ;Make sure that the mental health scale is valid for a + ;term finding. + 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 TFIND0 + S TFIND0=^PXRMD(811.5,DA(1),20,DA,0) + Q $$VSCALE(X,TFIND0) + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMMST.m b/r/CLINICAL_REMINDERS-PXRM/PXRMMST.m index 90af2862..388f8279 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMMST.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMMST.m @@ -1,253 +1,253 @@ -PXRMMST ; SLC/PKR - Routines for dealing with MST. ;03/29/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ;Use of DGMSTAPI supported by DBIA #2716. - ;==================================================== -GSYINFO(TYPE) ;Return the Clinical Reminders MST synchronization date - ;and the number of updates made. The format is an up-arrow delimited - ;string. The first piece is the date and the second is the number - ;of updates. If TYPE is "I" then the data for the initial - ;synchronization is returned. For any other value the data for the - ;last daily synchronization is returned. - I $G(TYPE)="I" Q $P($G(^PXRM(800,1,"MST")),U,1,2) Q - Q $P($G(^PXRM(800,1,"MST")),U,3,4) - ; - ;==================================================== -QUE ;Queue the MST synchronization job. - N DIR,DIROUT,DIRUT,DTOUT,DUOUT,MINDT,SDTIME,STIME,X,Y - S MINDT=$$NOW^XLFDT - 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(0)="DAU"_U_MINDT_"::RSX" - D ^DIR - I $D(DIROUT)!$D(DIRUT) Q - I $D(DTOUT)!$D(DUOUT) Q - S SDTIME=Y - K DIR - S DIR(0)="YA" - S DIR("A")="Do you want to run the MST synchronization at the same time every day? " - S DIR("B")="Y" - D ^DIR - I $D(DIROUT)!$D(DIRUT) Q - I $D(DTOUT)!$D(DUOUT) Q - S STIME=$S(Y:"1."_$P(SDTIME,".",2),1:-1) - ; - ;Put the task into the queue. - K ZTSAVE - S ZTSAVE("STIME")=STIME - S ZTRTN="SYNCH^PXRMMST" - S ZTDESC="Clinical Reminders MST synchronization job" - S ZTDTH=SDTIME - S ZTIO="" - D ^%ZTLOAD - W !,"Task number ",ZTSK," queued." - Q - ; - ;==================================================== -STATUS(DFN,TEST,DATE,VALUE,TEXT) ;Computed finding for checking a - ;patient's MST status. - N IEN,TEMP - S TEMP=$$GETSTAT^DGMSTAPI(DFN) - S IEN=$P(TEMP,U,1) - I IEN=-1 D Q - . S TEST=0,VALUE="",DATE=$$NOW^PXRMDATE - I IEN=0 D Q - . S TEST=0 - . S VALUE=$P(TEMP,U,2) - . S DATE=$P(TEMP,U,3) - . S TEXT="No MST status found" - ;If we get to here then a valid entry was found. - S TEST=1 - S VALUE=$P(TEMP,U,2) - S DATE=$P(TEMP,U,3) - Q - ; - ;==================================================== -STCODE(TERM) ;Return the MST status code based on the term name. - N STCODE - S STCODE=$S(TERM="VA-MST DECLINES REPORT":"D",TERM="VA-MST NEGATIVE REPORT":"N",TERM="VA-MST POSITIVE REPORT":"Y",1:"U") - Q STCODE - ; - ;==================================================== -SYNCH ;Synchronize the MST history file. - N INID,LTIME,NUMUPD,START,TEMP - ;STIME is passed from QUE via ZTSAVE. - D UPDSTAT(.NUMUPD,.START) - ;If the initial sync data has been stored then update the daily - ;data. - S INID=+$P($G(^PXRM(800,1,"MST")),U,1) - I INID>0 D - . S $P(^PXRM(800,1,"MST"),U,3)=$$NOW^XLFDT - . S $P(^PXRM(800,1,"MST"),U,4)=NUMUPD - . S $P(^PXRM(800,1,"MST"),U,6)=START - E D - . S $P(^PXRM(800,1,"MST"),U,1)=$$NOW^XLFDT - . S $P(^PXRM(800,1,"MST"),U,2)=NUMUPD - . S $P(^PXRM(800,1,"MST"),U,5)=START - ; - ;Cleanup the task stuff. - I STIME=-1 S ZTREQ="@" Q - E D - . S TEMP=$G(^PXRM(800,1,"MST")) - . S LTIME=+$P(TEMP,U,3) - . I LTIME=0 S LTIME=+$P(TEMP,U,1) - .;Adding STIME sets the new starting time at exactly one day following - .;the previous starting time. - . S $P(ZTREQ,U,1)=$P(LTIME,".",1)+STIME - Q - ; - ;==================================================== -SYNREP ;Provide a report of the synchronization data. - N EDTIME,EITIME,IDATE,LDATE,NIUPD,NLUPD,TEMP - S TEMP=$G(^PXRM(800,1,"MST")) - S IDATE=$$FMTE^XLFDT($P(TEMP,U,1)) - I IDATE=0 S IDATE="none" - S NIUPD=$P(TEMP,U,2) - S EITIME=$$FMDIFF^XLFDT($P(TEMP,U,1),$P(TEMP,U,5),2) - S LDATE=$$FMTE^XLFDT($P(TEMP,U,3)) - I LDATE=0 S LDATE="none" - S NLUPD=$P(TEMP,U,4) - S EDTIME=$$FMDIFF^XLFDT($P(TEMP,U,3),$P(TEMP,U,6),2) - W !!,"Clinical Reminders MST Synchronization Report" - W !,"---------------------------------------------" - W !,"Initial synchronization date: ",IDATE - W !,"Number of updates made: ",NIUPD - I EITIME>60 D - . S EITIME=$$FMDIFF^XLFDT($P(TEMP,U,1),$P(TEMP,U,5),3) - . W !,"Elapsed time: ",EITIME - E W !,"Elapsed time: ",EITIME," secs" - W !!,"Last daily synchronization date: ",LDATE - W !,"Number of updates made: ",NLUPD - I EDTIME>60 D - . S EDTIME=$$FMDIFF^XLFDT($P(TEMP,U,3),$P(TEMP,U,6),3) - . W !,"Elapsed time: ",EDTIME - E W !,"Elapsed time: ",EDTIME," secs" - Q - ; - ;==================================================== -UPDATE(DFN,VISIT,SOURCE,STCODE,TYPE) ;Make an update to the MST History file. - N DATE,MSTDATE,PROV,STAT,TEMP,UPDSTAT,VPRVIEN - S UPDSTAT=-1 - ;If the update is because of a protocol event use NOW for the - ;date/time. If it is being done as part of a synchronization use - ;the date the visit was created. - S DATE=$S(TYPE="PROTOCOL":$$NOW^XLFDT,1:$P($G(^AUPNVSIT(VISIT,0)),U,2)) - ;If the date does not contain the time use noon. - I DATE'["." S DATE=DATE_".12" - S STAT=$$GETSTAT^DGMSTAPI(DFN) - S MSTDATE=$S($P(STAT,U,1)>0:$P(STAT,U,3),1:0) - I DATE>MSTDATE D - .;Determine the provider. - . S TEMP=$P(SOURCE,";",2)_$P(SOURCE,";",1)_",12)" - . S PROV=$P($G(@TEMP),U,4) - . I PROV="" D - ..;DBIA #2316 - .. S VPRVIEN=+$O(^AUPNVPRV("AD",VISIT,"")) - .. I VPRVIEN>0 S PROV=$P(^AUPNVPRV(VPRVIEN,0),U,1) - . S UPDSTAT=$$NEWSTAT^DGMSTAPI(DFN,STCODE,DATE,PROV) - . I +UPDSTAT=-1 D - .. N FN,GBL,IEN,NAME,TARGET,XMSUB,VADM - .. K ^TMP("PXRMXMZ",$J) - .. S XMSUB="CLINICAL REMINDER MST UPDATE PROBLEM" - .. S ^TMP("PXRMXMZ",$J,1,0)="NEWSTAT^DGMSTAPI returned the following error:" - .. S ^TMP("PXRMXMZ",$J,2,0)=$P(UPDSTAT,U,2) - .. S ^TMP("PXRMXMZ",$J,3,0)="The following data was passed to NEWSTAT^DGMSTAPI" - .. S ^TMP("PXRMXMZ",$J,4,0)="DFN = "_DFN - .. S ^TMP("PXRMXMZ",$J,5,0)="Status code = "_STCODE - .. S ^TMP("PXRMXMZ",$J,6,0)="Date = "_DATE - .. S ^TMP("PXRMXMZ",$J,7,0)="Provider = "_PROV - .. S ^TMP("PXRMXMZ",$J,8,0)="Data source = "_SOURCE - .. S ^TMP("PXRMXMZ",$J,9,0)="This corresponds to the following:" - .. D DEM^VADPT - .. S ^TMP("PXRMXMZ",$J,10,0)="Patient = "_VADM(1) - .. S ^TMP("PXRMXMZ",$J,11,0)="SSN = "_$P(VADM(2),U,2) - .. S ^TMP("PXRMXMZ",$J,12,0)="MST Status = "_$$EXTERNAL^DILFD(29.11,3,"",STCODE) - .. S ^TMP("PXRMXMZ",$J,13,0)="Date = "_$$FMTE^XLFDT(DATE,"5Z") - .. S TEMP=$S(PROV="":"Unknown",1:TEMP=$$GET1^DIQ(200,PROV,.01,"","","")) - .. I TEMP="" S TEMP="Unknown" - .. S ^TMP("PXRMXMZ",$J,14,0)="Provider = "_TEMP - .. S GBL=$P($P(SOURCE,";",2),"(",1) - .. S TEMP=GBL_"(0)" - .. S FN=+$P(@TEMP,U,2) - .. S TEMP=GBL_"("_$P(SOURCE,";",1)_",0)" - .. S TEMP=$G(@TEMP) - .. S IEN=$P(TEMP,U,1) - .. D FIELD^DID(FN,.01,"N","POINTER","TARGET") - .. S GBL="^"_$P(TARGET("POINTER"),"(",1) - .. S TEMP=GBL_"(0)" - .. S FN=$P(@TEMP,U,1) - .. S TEMP=GBL_"("_IEN_",0)" - .. S NAME=$P(@TEMP,U,1) - .. S ^TMP("PXRMXMZ",$J,14,0)="Data type = "_FN - .. S ^TMP("PXRMXMZ",$J,15,0)="Name = "_NAME - .. D SEND^PXRMMSG(XMSUB) - Q UPDSTAT - ; - ;==================================================== -UPDPAT(DFN,VISIT,VFL) ;Update the MST history file for a single patient - ;using term mappings. Called from DATACHG^PXRMPINF which is invoked - ;by the protocol PXK VISIT DATA EVENT. - N AFTER,BEFORE,DGBL,SP,STCODE,SIEN,SOURCE - N TEMP,TERM,TERMIEN,VF - ;Search all the MST terms to build patient lists. - F TERM="VA-MST DECLINES REPORT","VA-MST NEGATIVE REPORT","VA-MST POSITIVE REPORT" D - . S TERMIEN=$O(^PXRMD(811.5,"B",TERM,"")) - . S VF="" - . F S VF=$O(VFL(VF)) Q:VF="" D - .. I VFL(VF)=U Q - .. S DGBL=$P(VFL(VF),U,1) - .. I '$D(^PXRMD(811.5,TERMIEN,20,"E",DGBL)) Q - .. S SIEN="" - .. F S SIEN=$O(^TMP("PXKCO",$J,VISIT,VF,SIEN)) Q:SIEN="" D - ... S AFTER=$G(^TMP("PXKCO",$J,VISIT,VF,SIEN,0,"AFTER")) - ... S BEFORE=$G(^TMP("PXKCO",$J,VISIT,VF,SIEN,0,"BEFORE")) - ... I AFTER=BEFORE Q - ... S SP=$P(AFTER,U,1) - ... I SP="" Q - ... I '$D(^PXRMD(811.5,TERMIEN,20,"E",DGBL,SP)) Q - ... S SOURCE=SIEN_";^"_$P(VFL(VF),U,2) - ...;The status code depends on the term name. - ... S STCODE=$$STCODE(TERM) - ... S TEMP=$$UPDATE(DFN,VISIT,SOURCE,STCODE,"PROTOCOL") - Q - ; - ;==================================================== -UPDSTAT(NUMUPD,START) ;Update the MST history file using term mappings. - N DAS,DATA,DFN,FILENUM,FINDPA,INDEX,ITEM,NOCC,STCODE,SOURCE - N TEMP,TERM,TERMARR,TERMIEN,UPDSTAT,VDATE,VISIT - S FINDPA="" - ;Set the start time for the synchronization. - S START=$$NOW^XLFDT - S INDEX="PXRM_MST_LIST" - S NUMUPD=0 - ;Search all the MST terms to build patient lists. Only V file data - ;is used for the update. - F TERM="VA-MST DECLINES REPORT","VA-MST NEGATIVE REPORT","VA-MST POSITIVE REPORT" D - . K TERMARR,^TMP($J,INDEX) - .;The status code depends on the term name. - . S STCODE=$$STCODE(TERM) - . S TERMIEN=$O(^PXRMD(811.5,"B",TERM,"")) - . I TERMIEN="" Q - . D TERM^PXRMLDR(TERMIEN,.TERMARR) - . D EVALPL^PXRMTERL(.FINDPA,.TERMARR,INDEX) - . S DFN=0 - . F S DFN=+$O(^TMP($J,INDEX,1,DFN)) Q:DFN=0 D - .. S ITEM="" - .. F S ITEM=$O(^TMP($J,INDEX,1,DFN,ITEM)) Q:ITEM="" D - ... S NOCC=0 - ... F S NOCC=$O(^TMP($J,INDEX,1,DFN,ITEM,NOCC)) Q:NOCC="" D - .... S FILENUM="" - .... F S FILENUM=$O(^TMP($J,INDEX,1,DFN,ITEM,NOCC,FILENUM)) Q:FILENUM="" D - ..... S TEMP=^TMP($J,INDEX,1,DFN,ITEM,NOCC,FILENUM) - ..... S DAS=$P(TEMP,U,1) - ..... K DATA - ..... D GETDATA^PXRMDATA(FILENUM,DAS,.DATA) - ..... S VISIT=$G(DATA("VISIT")) - ..... I VISIT="" Q - ..... S SOURCE=DAS_";"_^PXRMINDX(FILENUM,"GLOBAL NAME") - ..... S UPDSTAT=$$UPDATE(DFN,VISIT,SOURCE,STCODE,"SYNCH") - ..... I UPDSTAT'=-1 S NUMUPD=NUMUPD+1 - K ^TMP($J,INDEX) - Q - ; +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. + ;==================================================== +GSYINFO(TYPE) ;Return the Clinical Reminders MST synchronization date + ;and the number of updates made. The format is an up-arrow delimited + ;string. The first piece is the date and the second is the number + ;of updates. If TYPE is "I" then the data for the initial + ;synchronization is returned. For any other value the data for the + ;last daily synchronization is returned. + I $G(TYPE)="I" Q $P($G(^PXRM(800,1,"MST")),U,1,2) Q + Q $P($G(^PXRM(800,1,"MST")),U,3,4) + ; + ;==================================================== +QUE ;Queue the MST synchronization job. + N DIR,DIROUT,DIRUT,DTOUT,DUOUT,MINDT,SDTIME,STIME,X,Y + S MINDT=$$NOW^XLFDT + 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(0)="DAU"_U_MINDT_"::RSX" + D ^DIR + I $D(DIROUT)!$D(DIRUT) Q + I $D(DTOUT)!$D(DUOUT) Q + S SDTIME=Y + K DIR + S DIR(0)="YA" + S DIR("A")="Do you want to run the MST synchronization at the same time every day? " + S DIR("B")="Y" + D ^DIR + I $D(DIROUT)!$D(DIRUT) Q + I $D(DTOUT)!$D(DUOUT) Q + S STIME=$S(Y:"1."_$P(SDTIME,".",2),1:-1) + ; + ;Put the task into the queue. + K ZTSAVE + S ZTSAVE("STIME")=STIME + S ZTRTN="SYNCH^PXRMMST" + S ZTDESC="Clinical Reminders MST synchronization job" + S ZTDTH=SDTIME + S ZTIO="" + D ^%ZTLOAD + W !,"Task number ",ZTSK," queued." + Q + ; + ;==================================================== +STATUS(DFN,TEST,DATE,VALUE,TEXT) ;Computed finding for checking a + ;patient's MST status. + N IEN,TEMP + S TEMP=$$GETSTAT^DGMSTAPI(DFN) + S IEN=$P(TEMP,U,1) + I IEN=-1 D Q + . S TEST=0,VALUE="",DATE=$$NOW^PXRMDATE + I IEN=0 D Q + . S TEST=0 + . S VALUE=$P(TEMP,U,2) + . S DATE=$P(TEMP,U,3) + . S TEXT="No MST status found" + ;If we get to here then a valid entry was found. + S TEST=1 + S VALUE=$P(TEMP,U,2) + S DATE=$P(TEMP,U,3) + Q + ; + ;==================================================== +STCODE(TERM) ;Return the MST status code based on the term name. + N STCODE + S STCODE=$S(TERM="VA-MST DECLINES REPORT":"D",TERM="VA-MST NEGATIVE REPORT":"N",TERM="VA-MST POSITIVE REPORT":"Y",1:"U") + Q STCODE + ; + ;==================================================== +SYNCH ;Synchronize the MST history file. + N INID,LTIME,NUMUPD,START,TEMP + ;STIME is passed from QUE via ZTSAVE. + D UPDSTAT(.NUMUPD,.START) + ;If the initial sync data has been stored then update the daily + ;data. + S INID=+$P($G(^PXRM(800,1,"MST")),U,1) + I INID>0 D + . S $P(^PXRM(800,1,"MST"),U,3)=$$NOW^XLFDT + . S $P(^PXRM(800,1,"MST"),U,4)=NUMUPD + . S $P(^PXRM(800,1,"MST"),U,6)=START + E D + . S $P(^PXRM(800,1,"MST"),U,1)=$$NOW^XLFDT + . S $P(^PXRM(800,1,"MST"),U,2)=NUMUPD + . S $P(^PXRM(800,1,"MST"),U,5)=START + ; + ;Cleanup the task stuff. + I STIME=-1 S ZTREQ="@" Q + E D + . S TEMP=$G(^PXRM(800,1,"MST")) + . S LTIME=+$P(TEMP,U,3) + . I LTIME=0 S LTIME=+$P(TEMP,U,1) + .;Adding STIME sets the new starting time at exactly one day following + .;the previous starting time. + . S $P(ZTREQ,U,1)=$P(LTIME,".",1)+STIME + Q + ; + ;==================================================== +SYNREP ;Provide a report of the synchronization data. + N EDTIME,EITIME,IDATE,LDATE,NIUPD,NLUPD,TEMP + S TEMP=$G(^PXRM(800,1,"MST")) + S IDATE=$$FMTE^XLFDT($P(TEMP,U,1)) + I IDATE=0 S IDATE="none" + S NIUPD=$P(TEMP,U,2) + S EITIME=$$FMDIFF^XLFDT($P(TEMP,U,1),$P(TEMP,U,5),2) + S LDATE=$$FMTE^XLFDT($P(TEMP,U,3)) + I LDATE=0 S LDATE="none" + S NLUPD=$P(TEMP,U,4) + S EDTIME=$$FMDIFF^XLFDT($P(TEMP,U,3),$P(TEMP,U,6),2) + W !!,"Clinical Reminders MST Synchronization Report" + W !,"---------------------------------------------" + W !,"Initial synchronization date: ",IDATE + W !,"Number of updates made: ",NIUPD + I EITIME>60 D + . S EITIME=$$FMDIFF^XLFDT($P(TEMP,U,1),$P(TEMP,U,5),3) + . W !,"Elapsed time: ",EITIME + E W !,"Elapsed time: ",EITIME," secs" + W !!,"Last daily synchronization date: ",LDATE + W !,"Number of updates made: ",NLUPD + I EDTIME>60 D + . S EDTIME=$$FMDIFF^XLFDT($P(TEMP,U,3),$P(TEMP,U,6),3) + . W !,"Elapsed time: ",EDTIME + E W !,"Elapsed time: ",EDTIME," secs" + Q + ; + ;==================================================== +UPDATE(DFN,VISIT,SOURCE,STCODE,TYPE) ;Make an update to the MST History file. + N DATE,MSTDATE,PROV,STAT,TEMP,UPDSTAT,VPRVIEN + S UPDSTAT=-1 + ;If the update is because of a protocol event use NOW for the + ;date/time. If it is being done as part of a synchronization use + ;the date the visit was created. + S DATE=$S(TYPE="PROTOCOL":$$NOW^XLFDT,1:$P($G(^AUPNVSIT(VISIT,0)),U,2)) + ;If the date does not contain the time use noon. + I DATE'["." S DATE=DATE_".12" + S STAT=$$GETSTAT^DGMSTAPI(DFN) + S MSTDATE=$S($P(STAT,U,1)>0:$P(STAT,U,3),1:0) + I DATE>MSTDATE D + .;Determine the provider. + . S TEMP=$P(SOURCE,";",2)_$P(SOURCE,";",1)_",12)" + . S PROV=$P($G(@TEMP),U,4) + . I PROV="" D + ..;DBIA #2316 + .. S VPRVIEN=+$O(^AUPNVPRV("AD",VISIT,"")) + .. I VPRVIEN>0 S PROV=$P(^AUPNVPRV(VPRVIEN,0),U,1) + . S UPDSTAT=$$NEWSTAT^DGMSTAPI(DFN,STCODE,DATE,PROV) + . I +UPDSTAT=-1 D + .. N FN,GBL,IEN,NAME,TARGET,XMSUB,VADM + .. K ^TMP("PXRMXMZ",$J) + .. S XMSUB="CLINICAL REMINDER MST UPDATE PROBLEM" + .. S ^TMP("PXRMXMZ",$J,1,0)="NEWSTAT^DGMSTAPI returned the following error:" + .. S ^TMP("PXRMXMZ",$J,2,0)=$P(UPDSTAT,U,2) + .. S ^TMP("PXRMXMZ",$J,3,0)="The following data was passed to NEWSTAT^DGMSTAPI" + .. S ^TMP("PXRMXMZ",$J,4,0)="DFN = "_DFN + .. S ^TMP("PXRMXMZ",$J,5,0)="Status code = "_STCODE + .. S ^TMP("PXRMXMZ",$J,6,0)="Date = "_DATE + .. S ^TMP("PXRMXMZ",$J,7,0)="Provider = "_PROV + .. S ^TMP("PXRMXMZ",$J,8,0)="Data source = "_SOURCE + .. S ^TMP("PXRMXMZ",$J,9,0)="This corresponds to the following:" + .. D DEM^VADPT + .. S ^TMP("PXRMXMZ",$J,10,0)="Patient = "_VADM(1) + .. S ^TMP("PXRMXMZ",$J,11,0)="SSN = "_$P(VADM(2),U,2) + .. S ^TMP("PXRMXMZ",$J,12,0)="MST Status = "_$$EXTERNAL^DILFD(29.11,3,"",STCODE) + .. S ^TMP("PXRMXMZ",$J,13,0)="Date = "_$$FMTE^XLFDT(DATE,"5Z") + .. S TEMP=$S(PROV="":"Unknown",1:TEMP=$$GET1^DIQ(200,PROV,.01,"","","")) + .. I TEMP="" S TEMP="Unknown" + .. S ^TMP("PXRMXMZ",$J,14,0)="Provider = "_TEMP + .. S GBL=$P($P(SOURCE,";",2),"(",1) + .. S TEMP=GBL_"(0)" + .. S FN=+$P(@TEMP,U,2) + .. S TEMP=GBL_"("_$P(SOURCE,";",1)_",0)" + .. S TEMP=$G(@TEMP) + .. S IEN=$P(TEMP,U,1) + .. D FIELD^DID(FN,.01,"N","POINTER","TARGET") + .. S GBL="^"_$P(TARGET("POINTER"),"(",1) + .. S TEMP=GBL_"(0)" + .. S FN=$P(@TEMP,U,1) + .. S TEMP=GBL_"("_IEN_",0)" + .. S NAME=$P(@TEMP,U,1) + .. S ^TMP("PXRMXMZ",$J,14,0)="Data type = "_FN + .. S ^TMP("PXRMXMZ",$J,15,0)="Name = "_NAME + .. D SEND^PXRMMSG(XMSUB) + Q UPDSTAT + ; + ;==================================================== +UPDPAT(DFN,VISIT,VFL) ;Update the MST history file for a single patient + ;using term mappings. Called from DATACHG^PXRMPINF which is invoked + ;by the protocol PXK VISIT DATA EVENT. + N AFTER,BEFORE,DGBL,SP,STCODE,SIEN,SOURCE + N TEMP,TERM,TERMIEN,VF + ;Search all the MST terms to build patient lists. + F TERM="VA-MST DECLINES REPORT","VA-MST NEGATIVE REPORT","VA-MST POSITIVE REPORT" D + . S TERMIEN=$O(^PXRMD(811.5,"B",TERM,"")) + . S VF="" + . F S VF=$O(VFL(VF)) Q:VF="" D + .. I VFL(VF)=U Q + .. S DGBL=$P(VFL(VF),U,1) + .. I '$D(^PXRMD(811.5,TERMIEN,20,"E",DGBL)) Q + .. S SIEN="" + .. F S SIEN=$O(^TMP("PXKCO",$J,VISIT,VF,SIEN)) Q:SIEN="" D + ... S AFTER=$G(^TMP("PXKCO",$J,VISIT,VF,SIEN,0,"AFTER")) + ... S BEFORE=$G(^TMP("PXKCO",$J,VISIT,VF,SIEN,0,"BEFORE")) + ... I AFTER=BEFORE Q + ... S SP=$P(AFTER,U,1) + ... I SP="" Q + ... I '$D(^PXRMD(811.5,TERMIEN,20,"E",DGBL,SP)) Q + ... S SOURCE=SIEN_";^"_$P(VFL(VF),U,2) + ...;The status code depends on the term name. + ... S STCODE=$$STCODE(TERM) + ... S TEMP=$$UPDATE(DFN,VISIT,SOURCE,STCODE,"PROTOCOL") + Q + ; + ;==================================================== +UPDSTAT(NUMUPD,START) ;Update the MST history file using term mappings. + N DAS,DATA,DFN,FILENUM,FINDPA,INDEX,ITEM,NOCC,STCODE,SOURCE + N TEMP,TERM,TERMARR,TERMIEN,UPDSTAT,VDATE,VISIT + S FINDPA="" + ;Set the start time for the synchronization. + S START=$$NOW^XLFDT + S INDEX="PXRM_MST_LIST" + S NUMUPD=0 + ;Search all the MST terms to build patient lists. Only V file data + ;is used for the update. + F TERM="VA-MST DECLINES REPORT","VA-MST NEGATIVE REPORT","VA-MST POSITIVE REPORT" D + . K TERMARR,^TMP($J,INDEX) + .;The status code depends on the term name. + . S STCODE=$$STCODE(TERM) + . S TERMIEN=$O(^PXRMD(811.5,"B",TERM,"")) + . I TERMIEN="" Q + . D TERM^PXRMLDR(TERMIEN,.TERMARR) + . D EVALPL^PXRMTERM(.FINDPA,.TERMARR,INDEX) + . S DFN=0 + . F S DFN=+$O(^TMP($J,INDEX,1,DFN)) Q:DFN=0 D + .. S ITEM="" + .. F S ITEM=$O(^TMP($J,INDEX,1,DFN,ITEM)) Q:ITEM="" D + ... S NOCC=0 + ... F S NOCC=$O(^TMP($J,INDEX,1,DFN,ITEM,NOCC)) Q:NOCC="" D + .... S FILENUM="" + .... F S FILENUM=$O(^TMP($J,INDEX,1,DFN,ITEM,NOCC,FILENUM)) Q:FILENUM="" D + ..... S TEMP=^TMP($J,INDEX,1,DFN,ITEM,NOCC,FILENUM) + ..... S DAS=$P(TEMP,U,1) + ..... K DATA + ..... D GETDATA^PXRMDATA(FILENUM,DAS,.DATA) + ..... S VISIT=$G(DATA("VISIT")) + ..... I VISIT="" Q + ..... S SOURCE=DAS_";"_^PXRMINDX(FILENUM,"GLOBAL NAME") + ..... S UPDSTAT=$$UPDATE(DFN,VISIT,SOURCE,STCODE,"SYNCH") + ..... I UPDSTAT'=-1 S NUMUPD=NUMUPD+1 + K ^TMP($J,INDEX) + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMOUTC.m b/r/CLINICAL_REMINDERS-PXRM/PXRMOUTC.m index c22dd1dd..9e0c2dab 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMOUTC.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMOUTC.m @@ -1,142 +1,136 @@ -PXRMOUTC ; SLC/PKR - Clinical Maintenance output. ;07/06/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ;================================================ -CM(DEFARR,PXRMPDEM,PCLOGIC,RESLOGIC,RESDATE,FIEVAL) ;Prepare the - ;clinical maintenance output. - N IND,JND,FIDATA,FINDING,FLIST,FTYPE - N HDR,NHDR,IFIEVAL,LIST,NFLINES,NTXT,NUM - N TEMP,TEXT - S NTXT=0 - ;Check for a dead patient - I +$G(PXRMPDEM("DOD"))>0 D - . S TEMP=$$FMTE^XLFDT(PXRMPDEM("DOD"),"5DZ") - . S TEXT="Patient is deceased, date of death: "_TEMP - . D ADDTXT^PXRMOUTU(1,PXRMRM,.NTXT,TEXT) - ;Display the frequency information only if there is resolution logic. - I RESLOGIC'="" D FREQ(.DEFARR,.NTXT,.TEXT) - ;Output the AGE match/no match text. - D AGE^PXRMFNFT(PXRMPDEM("DFN"),.DEFARR,.FIEVAL,.NTXT) - ;Process the findings in the order: patient cohort, resolution, - ;age, and informational. - M FIDATA=FIEVAL - F FTYPE="PCL","RES","AGE","INFO" D - . S LIST=$S(FTYPE="PCL":DEFARR(32),FTYPE="RES":DEFARR(36),FTYPE="AGE":DEFARR(40),FTYPE="INFO":DEFARR(42)) - .;Output the general logic text. - . I FTYPE="PCL" D LOGIC^PXRMFNFT(PXRMPDEM("DFN"),PCLOGIC,FTYPE,"D",.DEFARR,.NTXT) - . I FTYPE="RES",$P(PCLOGIC,U,1) D LOGIC^PXRMFNFT(PXRMPDEM("DFN"),RESLOGIC,FTYPE,"D",.DEFARR,.NTXT) - .;Process the findings for each type. - . K TEXT - . S (NHDR,NFLINES)=0 - . S NUM=+$P(LIST,U,1) - . S FLIST=$P(LIST,U,2) - . F IND=1:1:NUM D - .. S FINDING=$P(FLIST,";",IND) - ..;No output for age or sex findings. - .. I (FINDING="AGE")!(FINDING="SEX") Q - ..;Make sure each finding is processed only once. - .. 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) - .. E S IFIEVAL=0 - ..;If the finding is false all we need to do is process the not found - ..;text. If it is true we also need to output the finding information. - .. I IFIEVAL D FOUT(1,.IFIEVAL,.NFLINES,.TEXT) - ..;Output the found/not found text for the finding. -FNF .. D FINDING^PXRMFNFT(3,PXRMPDEM("DFN"),FINDING,.IFIEVAL,.NFLINES,.TEXT) - ..;Make sure each finding is processed only once. - .. K FIDATA(FINDING) - .; - .;If there was any text for this finding type create a header. - . D HEADER(FTYPE,NFLINES,RESDATE,.NHDR,.HDR) - .;Output the header and the finding text. - . D ADDTXTA^PXRMOUTU(1,PXRMRM,.NTXT,NHDR,.HDR) - . D COPYTXT^PXRMOUTU(.NTXT,NFLINES,.TEXT) - ;Output INFO nodes - D INFO^PXRMOUTU(PXRMITEM,.NTXT) - Q - ; - ;================================================ -FOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Do output for individual findings - ;in the FINDING array. - I $D(IFIEVAL("TERM")) D OUTPUT^PXRMTERM(1,.IFIEVAL,.NFLINES,.TEXT) Q - N FTYPE - S FTYPE=$P(IFIEVAL("FINDING"),U,1) - S FTYPE=$P(FTYPE,";",2) - I FTYPE="AUTTEDT(" D OUTPUT^PXRMEDU(INDENT,.IFIEVAL,.NLINES,.TEXT) Q - I FTYPE="AUTTEXAM(" D OUTPUT^PXRMEXAM(INDENT,.IFIEVAL,.NLINES,.TEXT) Q - I FTYPE="AUTTHF(" D OUTPUT^PXRMHF(INDENT,.IFIEVAL,.NLINES,.TEXT) Q - I FTYPE="AUTTIMM(" D OUTPUT^PXRMIMM(INDENT,.IFIEVAL,.NLINES,.TEXT) Q - I FTYPE="AUTTSK(" D OUTPUT^PXRMSKIN(INDENT,.IFIEVAL,.NLINES,.TEXT) Q - I FTYPE="GMRD(120.51," D OUTPUT^PXRMVITL(INDENT,.IFIEVAL,.NLINES,.TEXT) Q - I FTYPE="LAB(60," D OUTPUT^PXRMLAB(INDENT,.IFIEVAL,.NLINES,.TEXT) Q - I FTYPE="ORD(101.43," D OUTPUT^PXRMORDR(INDENT,.IFIEVAL,.NLINES,.TEXT) Q - I FTYPE="PS(50.605," D OUTPUT^PXRMDRCL(INDENT,.IFIEVAL,.NLINES,.TEXT) Q - I FTYPE="PSDRUG(" D OUTPUT^PXRMDRUG(INDENT,.IFIEVAL,.NLINES,.TEXT) Q - I FTYPE="PSNDF(50.6," D OUTPUT^PXRMDGEN(INDENT,.IFIEVAL,.NLINES,.TEXT) Q - I FTYPE="PS(55," D OUTPUT^PXRMDIN(INDENT,.IFIEVAL,.NLINES,.TEXT) Q - I FTYPE="PS(55NVA," D OUTPUT^PXRMDNVA(INDENT,.IFIEVAL,.NLINES,.TEXT) Q - I FTYPE="PSRX(" D OUTPUT^PXRMDOUT(INDENT,.IFIEVAL,.NLINES,.TEXT) Q - I FTYPE="PXD(811.2," D OUTPUT^PXRMTAX(INDENT,.IFIEVAL,.NLINES,.TEXT) Q - I FTYPE="PXRMD(802.4," D OUTPUT^PXRMFF(INDENT,.IFIEVAL,.NLINES,.TEXT) Q - I FTYPE="PXRMD(810.9," D OUTPUT^PXRMLOCF(INDENT,.IFIEVAL,.NLINES,.TEXT) Q - 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 - Q - ; - ;================================================ -FREQ(DEFARR,NTXT,TEXT) ;Display the frequency information. - N FREQ,TEMP - ;If there was a custom date due print out that information. - I $D(^TMP(PXRMPID,$J,PXRMITEM,"zCDUE")) D - . S TEMP=^TMP(PXRMPID,$J,PXRMITEM,"zCDUE") - . S TEXT=$$OUTPUT^PXRMCDUE(TEMP,.DEFARR) - . I DEFARR(31)["AGE" D - .. S TEMP=$G(^TMP(PXRMPID,$J,PXRMITEM,"zFREQARNG")) - .. I TEMP'="" S TEXT=TEXT_" Applicable"_$$FMTAGE^PXRMAGE($P(TEMP,U,2),$P(TEMP,U,3))_"." - . D ADDTXT^PXRMOUTU(1,PXRMRM,.NTXT,TEXT) - E D - . S TEMP=$G(^TMP(PXRMPID,$J,PXRMITEM,"zFREQARNG")) - . I TEMP'="" D - .. S FREQ=$P(TEMP,U,1) - .. S TEXT=$$FMTFREQ^PXRMAGE(FREQ) - .. I FREQ=-1 S TEXT=TEXT_" for this patient." - .. I DEFARR(31)["AGE",FREQ'=-1 S TEXT=TEXT_$$FMTAGE^PXRMAGE($P(TEMP,U,2),$P(TEMP,U,3))_"." - .. D ADDTXT^PXRMOUTU(1,PXRMRM,.NTXT,TEXT) - Q - ; - ;================================================ -HEADER(FTYPE,NLINES,RESDATE,NHDR,HDR) ;Create a finding header. - I FTYPE="RES" D Q - . I +RESDATE'=0 D Q - .. S HDR(2)="Resolution: Last done "_$$EDATE^PXRMDATE(RESDATE) - .. S NHDR=2 - .. S HDR(1)="\\" - . I '$D(HDR(2)),NLINES>0 D - .. S HDR(2)="Resolution:" - .. S NHDR=2 - .. S HDR(1)="\\" - ; - I NLINES=0 Q - I FTYPE="PCL" D Q - . S NHDR=2 - . S HDR(1)="\\" - . S HDR(2)="Cohort:" - ; - I FTYPE="AGE" D Q - . S NHDR=2 - . S HDR(1)="\\" - . S HDR(2)="Age/Frequency:" - ; - I FTYPE="INFO" D Q - . S NHDR=2 - . S HDR(1)="\\" - . S HDR(2)="Information:" - Q - ; +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,FIDATA,FINDING,FLIST,FTYPE + N HDR,NHDR,IFIEVAL,LIST,NFLINES,NTXT,NUM + N TEMP,TEXT + S NTXT=0 + ;Check for a dead patient + I +$G(PXRMPDEM("DOD"))>0 D + . S TEMP=$$FMTE^XLFDT(PXRMPDEM("DOD"),"5DZ") + . S TEXT="Patient is deceased, date of death: "_TEMP + . D ADDTXT^PXRMOUTU(1,PXRMRM,.NTXT,TEXT) + ;Display the frequency information only if there is resolution logic. + I RESLOGIC'="" D FREQ(.DEFARR,.NTXT,.TEXT) + ;Output the AGE match/no match text. + D AGE^PXRMFNFT(PXRMPDEM("DFN"),.DEFARR,.FIEVAL,.NTXT) + ;Process the findings in the order: patient cohort, resolution, + ;age, and informational. + M FIDATA=FIEVAL + F FTYPE="PCL","RES","AGE","INFO" D + . S LIST=$S(FTYPE="PCL":DEFARR(32),FTYPE="RES":DEFARR(36),FTYPE="AGE":DEFARR(40),FTYPE="INFO":DEFARR(42)) + .;Output the general logic text. + . I FTYPE="PCL" D LOGIC^PXRMFNFT(PXRMPDEM("DFN"),PCLOGIC,FTYPE,"D",.DEFARR,.NTXT) + . I FTYPE="RES",$P(PCLOGIC,U,1) D LOGIC^PXRMFNFT(PXRMPDEM("DFN"),RESLOGIC,FTYPE,"D",.DEFARR,.NTXT) + .;Process the findings for each type. + . K TEXT + . S (NHDR,NFLINES)=0 + . S NUM=+$P(LIST,U,1) + . S FLIST=$P(LIST,U,2) + . F IND=1:1:NUM D + .. S FINDING=$P(FLIST,";",IND) + ..;No output for age or sex findings. + .. I (FINDING="AGE")!(FINDING="SEX") Q + ..;Make sure each finding is processed only once. + .. I '$D(FIDATA(FINDING)) Q + .. K IFIEVAL + .. 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 + ..;text. If it is true we also need to output the finding information. + .. I IFIEVAL D FOUT(1,.IFIEVAL,.NFLINES,.TEXT) + ..;Output the found/not found text for the finding. +FNF .. D FINDING^PXRMFNFT(3,PXRMPDEM("DFN"),FINDING,.IFIEVAL,.NFLINES,.TEXT) + ..;Make sure each finding is processed only once. + .. K FIDATA(FINDING) + .; + .;If there was any text for this finding type create a header. + . D HEADER(FTYPE,NFLINES,RESDATE,.NHDR,.HDR) + .;Output the header and the finding text. + . D ADDTXTA^PXRMOUTU(1,PXRMRM,.NTXT,NHDR,.HDR) + . D COPYTXT^PXRMOUTU(.NTXT,NFLINES,.TEXT) + ;Output INFO nodes + D INFO^PXRMOUTU(PXRMITEM,.NTXT) + Q + ; + ;================================================ +FOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Do output for individual findings + ;in the FINDING array. + I $D(IFIEVAL("TERM")) D OUTPUT^PXRMTERM(1,.IFIEVAL,.NFLINES,.TEXT) Q + N FTYPE + S FTYPE=$P(IFIEVAL("FINDING"),U,1) + S FTYPE=$P(FTYPE,";",2) + I FTYPE="AUTTEDT(" D OUTPUT^PXRMEDU(INDENT,.IFIEVAL,.NLINES,.TEXT) Q + I FTYPE="AUTTEXAM(" D OUTPUT^PXRMEXAM(INDENT,.IFIEVAL,.NLINES,.TEXT) Q + I FTYPE="AUTTHF(" D OUTPUT^PXRMHF(INDENT,.IFIEVAL,.NLINES,.TEXT) Q + I FTYPE="AUTTIMM(" D OUTPUT^PXRMIMM(INDENT,.IFIEVAL,.NLINES,.TEXT) Q + I FTYPE="AUTTSK(" D OUTPUT^PXRMSKIN(INDENT,.IFIEVAL,.NLINES,.TEXT) Q + I FTYPE="GMRD(120.51," D OUTPUT^PXRMVITL(INDENT,.IFIEVAL,.NLINES,.TEXT) Q + I FTYPE="LAB(60," D OUTPUT^PXRMLAB(INDENT,.IFIEVAL,.NLINES,.TEXT) Q + I FTYPE="ORD(101.43," D OUTPUT^PXRMORDR(INDENT,.IFIEVAL,.NLINES,.TEXT) Q + I FTYPE="PS(50.605," D OUTPUT^PXRMDRCL(INDENT,.IFIEVAL,.NLINES,.TEXT) Q + I FTYPE="PSDRUG(" D OUTPUT^PXRMDRUG(INDENT,.IFIEVAL,.NLINES,.TEXT) Q + I FTYPE="PSNDF(50.6," D OUTPUT^PXRMDGEN(INDENT,.IFIEVAL,.NLINES,.TEXT) Q + I FTYPE="PS(55," D OUTPUT^PXRMDIN(INDENT,.IFIEVAL,.NLINES,.TEXT) Q + I FTYPE="PS(55NVA," D OUTPUT^PXRMDNVA(INDENT,.IFIEVAL,.NLINES,.TEXT) Q + I FTYPE="PSRX(" D OUTPUT^PXRMDOUT(INDENT,.IFIEVAL,.NLINES,.TEXT) Q + I FTYPE="PXD(811.2," D OUTPUT^PXRMTAX(INDENT,.IFIEVAL,.NLINES,.TEXT) Q + I FTYPE="PXRMD(802.4," D OUTPUT^PXRMFF(INDENT,.IFIEVAL,.NLINES,.TEXT) Q + I FTYPE="PXRMD(810.9," D OUTPUT^PXRMLOCF(INDENT,.IFIEVAL,.NLINES,.TEXT) Q + 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," D OUTPUT^PXRMMH(INDENT,.IFIEVAL,.NLINES,.TEXT) Q + Q + ; + ;================================================ +FREQ(DEFARR,NTXT,TEXT) ;Display the frequency information. + N FREQ,TEMP + ;If there was a custom date due print out that information. + I $D(^TMP(PXRMPID,$J,PXRMITEM,"zCDUE")) D + . S TEMP=^TMP(PXRMPID,$J,PXRMITEM,"zCDUE") + . S TEXT=$$OUTPUT^PXRMCDUE(TEMP,.DEFARR) + . I DEFARR(31)["AGE" D + .. S TEMP=$G(^TMP(PXRMPID,$J,PXRMITEM,"zFREQARNG")) + .. I TEMP'="" S TEXT=TEXT_" Applicable"_$$FMTAGE^PXRMAGE($P(TEMP,U,2),$P(TEMP,U,3))_"." + . D ADDTXT^PXRMOUTU(1,PXRMRM,.NTXT,TEXT) + E D + . S TEMP=$G(^TMP(PXRMPID,$J,PXRMITEM,"zFREQARNG")) + . I TEMP'="" D + .. S FREQ=$P(TEMP,U,1) + .. S TEXT=$$FMTFREQ^PXRMAGE(FREQ) + .. I FREQ=-1 S TEXT=TEXT_" for this patient." + .. I DEFARR(31)["AGE",FREQ'=-1 S TEXT=TEXT_$$FMTAGE^PXRMAGE($P(TEMP,U,2),$P(TEMP,U,3))_"." + .. D ADDTXT^PXRMOUTU(1,PXRMRM,.NTXT,TEXT) + Q + ; + ;================================================ +HEADER(FTYPE,NLINES,RESDATE,NHDR,HDR) ;Create a finding header. + I FTYPE="RES" D Q + . I +RESDATE'=0 D Q + .. S HDR(2)="Resolution: Last done "_$$EDATE^PXRMDATE(RESDATE) + .. S NHDR=2 + .. S HDR(1)="\\" + . I '$D(HDR(2)),NLINES>0 D + .. S HDR(2)="Resolution:" + .. S NHDR=2 + .. S HDR(1)="\\" + ; + I NLINES=0 Q + I FTYPE="PCL" D Q + . S NHDR=2 + . S HDR(1)="\\" + . S HDR(2)="Cohort:" + ; + I FTYPE="AGE" D Q + . S NHDR=2 + . S HDR(1)="\\" + . S HDR(2)="Age/Frequency:" + ; + I FTYPE="INFO" D Q + . S NHDR=2 + . S HDR(1)="\\" + . S HDR(2)="Information:" + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMOUTM.m b/r/CLINICAL_REMINDERS-PXRM/PXRMOUTM.m index a639f519..61c5ba88 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMOUTM.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMOUTM.m @@ -1,134 +1,128 @@ -PXRMOUTM ; SLC/PKR - MyHealtheVet output. ;07/06/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ;================================================ -FOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Do output for individual findings - ;in the FINDING array. - I $D(IFIEVAL("TERM")) D MHVOUT^PXRMTERM(1,.IFIEVAL,.NFLINES,.TEXT) Q - N FTYPE - S FTYPE=$P(IFIEVAL("FINDING"),U,1) - S FTYPE=$P(FTYPE,";",2) - I FTYPE="AUTTEDT(" D MHVOUT^PXRMEDU(INDENT,.IFIEVAL,.NLINES,.TEXT) Q - I FTYPE="AUTTEXAM(" D MHVOUT^PXRMEXAM(INDENT,.IFIEVAL,.NLINES,.TEXT) Q - I FTYPE="AUTTHF(" D MHVOUT^PXRMHF(INDENT,.IFIEVAL,.NLINES,.TEXT) Q - I FTYPE="AUTTIMM(" D MHVOUT^PXRMIMM(INDENT,.IFIEVAL,.NLINES,.TEXT) Q - I FTYPE="AUTTSK(" D MHVOUT^PXRMSKIN(INDENT,.IFIEVAL,.NLINES,.TEXT) Q - I FTYPE="GMRD(120.51," D MHVOUT^PXRMVITL(INDENT,.IFIEVAL,.NLINES,.TEXT) Q - I FTYPE="LAB(60," D MHVOUT^PXRMLAB(INDENT,.IFIEVAL,.NLINES,.TEXT) Q - I FTYPE="ORD(101.43," D MHVOUT^PXRMORDR(INDENT,.IFIEVAL,.NLINES,.TEXT) Q - I FTYPE="PS(50.605," D MHVOUT^PXRMDRCL(INDENT,.IFIEVAL,.NLINES,.TEXT) Q - I FTYPE="PSDRUG(" D MHVOUT^PXRMDRUG(INDENT,.IFIEVAL,.NLINES,.TEXT) Q - I FTYPE="PS(55," D MHVOUT^PXRMDIN(INDENT,.IFIEVAL,.NLINES,.TEXT) Q - I FTYPE="PS(55NVA," D MHVOUT^PXRMDNVA(INDENT,.IFIEVAL,.NLINES,.TEXT) Q - I FTYPE="PSRX(" D MHVOUT^PXRMDOUT(INDENT,.IFIEVAL,.NLINES,.TEXT) Q - I FTYPE="PSNDF(50.6," D MHVOUT^PXRMDGEN(INDENT,.IFIEVAL,.NLINES,.TEXT) Q - I FTYPE="PXD(811.2," D MHVOUT^PXRMTAX(INDENT,.IFIEVAL,.NLINES,.TEXT) Q - I FTYPE="PXRMD(802.4," D MHVOUT^PXRMFF(INDENT,.IFIEVAL,.NLINES,.TEXT) Q - I FTYPE="PXRMD(810.9," D MHVOUT^PXRMLOCF(INDENT,.IFIEVAL,.NLINES,.TEXT) Q - 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 - Q - ; - ;================================================ -MHVC(DEFARR,PXRMPDEM,PCLOGIC,RESLOGIC,RESDATE,FIEVAL) ;Prepare the - ;MyHealtheVet combined output. - N PNAME,RIEN - S RIEN=DEFARR("IEN") - S PNAME=$O(^TMP("PXRHM",$J,RIEN,"")) - S ^TMP("PXRMMHVC",$J,RIEN,"STATUS")=^TMP("PXRHM",$J,RIEN,PNAME) - D MHVD(.DEFARR,.PXRMPDEM,PCLOGIC,RESLOGIC,RESDATE,.FIEVAL,0) - M ^TMP("PXRMMHVC",$J,RIEN,"DETAIL")=^TMP("PXRHM",$J,RIEN,PNAME,"TXT") - K ^TMP("PXRHM",$J,RIEN,PNAME,"TXT") - D MHVS(.DEFARR,.PXRMPDEM,PCLOGIC,RESLOGIC,RESDATE,.FIEVAL,0) - M ^TMP("PXRMMHVC",$J,RIEN,"SUMMARY")=^TMP("PXRHM",$J,RIEN,PNAME,"TXT") - K ^TMP("PXRHM",$J,RIEN,PNAME) - Q - ; - ;================================================ -MHVD(DEFARR,PXRMPDEM,PCLOGIC,RESLOGIC,RESDATE,FIEVAL,WEB) ;Prepare the - ;MyHealtheVet detailed output. - N IND,JND,FIDATA,FINDING,FLIST,FTYPE - N HDR,NHDR,IFIEVAL,LIST,NFLINES,NTXT,NUM - N TEXT - S NTXT=0 - ;Output the AGE match/no match text. - D AGE^PXRMFNFT(PXRMPDEM("DFN"),.DEFARR,.FIEVAL,.NTXT) - ;Process the findings in the order: patient cohort, resolution, - ;age, and informational. - M FIDATA=FIEVAL - F FTYPE="PCL","RES","AGE","INFO" D - . S LIST=$S(FTYPE="PCL":DEFARR(32),FTYPE="RES":DEFARR(36),FTYPE="AGE":DEFARR(40),FTYPE="INFO":DEFARR(42)) - .;Output the general logic text. - . I FTYPE="PCL" D LOGIC^PXRMFNFT(PXRMPDEM("DFN"),PCLOGIC,FTYPE,"D",.DEFARR,.NTXT) - . I FTYPE="RES",$P(PCLOGIC,U,1) D LOGIC^PXRMFNFT(PXRMPDEM("DFN"),RESLOGIC,FTYPE,"D",.DEFARR,.NTXT) - .;Process the findings for each type. - . K TEXT - . S (NHDR,NFLINES)=0 - . S NUM=+$P(LIST,U,1) - . S FLIST=$P(LIST,U,2) - . F IND=1:1:NUM D - .. S FINDING=$P(FLIST,";",IND) - ..;No output for age or sex findings. - .. I (FINDING="AGE")!(FINDING="SEX") Q - ..;Make sure each finding is processed only once. - .. 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) - .. E S IFIEVAL=0 - ..;Output the found/not found text for the finding. - .. D FINDING^PXRMFNFT(3,PXRMPDEM("DFN"),FINDING,.IFIEVAL,.NFLINES,.TEXT) - ..;If the finding is true output the finding information. - .. I IFIEVAL D FOUT(1,.IFIEVAL,.NFLINES,.TEXT) - ..;Make sure each finding is processed only once. - .. K FIDATA(FINDING) - .; - .;If there was any text for this finding type create a header. - .;Output the header and the finding text. - . D COPYTXT^PXRMOUTU(.NTXT,NFLINES,.TEXT) - I WEB D WEB(DEFARR("IEN"),.NTXT) - Q - ; - ;================================================ -MHVS(DEFARR,PXRMPDEM,PCLOGIC,RESLOGIC,RESDATE,FIEVAL,WEB) ;Prepare the - ;MyHealtheVet summary output. - N NTXT - S NTXT=0 - D LOGIC^PXRMFNFT(PXRMPDEM("DFN"),PCLOGIC,"PCL","S",.DEFARR,.NTXT) - I $P(PCLOGIC,U,1) D LOGIC^PXRMFNFT(PXRMPDEM("DFN"),RESLOGIC,"RES","S",.DEFARR,.NTXT) - I WEB D WEB(DEFARR("IEN"),.NTXT) - Q - ; - ;================================================ -WEB(RIEN,NTXT) ;Output the web site information. - N DES,IEN,IND,NL,TEXT,TITLE,URL - I '$D(^PXD(811.9,RIEN,50)) Q - S TEXT="\\ Please check these web sites for more information:\\" - D ADDTXT^PXRMOUTU(1,PXRMRM,.NTXT,TEXT) - S IEN=0 - F S IEN=+$O(^PXD(811.9,RIEN,50,IEN)) Q:IEN=0 D - . S TEXT=$G(^PXD(811.9,RIEN,50,IEN,0)) - . S URL=$P(TEXT,U,1) - . I URL="" Q - . S TITLE=$P(TEXT,U,2) - . S DES=$D(^PXD(811.9,RIEN,50,IEN,1)) - . S TEXT(1)="Web Site: "_TITLE_"\\" - . S TEXT(2)="URL: "_URL_$S('DES:"\\",1:"") - . D ADDTXTA^PXRMOUTU(2,PXRMRM,.NTXT,2,.TEXT) - .;If there is a description output it. - . I 'DES Q - . K TEXT - . S (IND,NL)=0 - . F S IND=+$O(^PXD(811.9,RIEN,50,IEN,1,IND)) Q:IND=0 D - .. S NL=NL+1 - .. S TEXT(NL)=^PXD(811.9,RIEN,50,IEN,1,IND,0) - . S TEXT(NL)=TEXT(NL)_"\\" - . D ADDTXTA^PXRMOUTU(3,PXRMRM,.NTXT,NL,.TEXT) - Q - ; +PXRMOUTM ; SLC/PKR - MyHealtheVet output. ;10/12/2005 + ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21 + ; + ;================================================ +FOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Do output for individual findings + ;in the FINDING array. + I $D(IFIEVAL("TERM")) D MHVOUT^PXRMTERM(1,.IFIEVAL,.NFLINES,.TEXT) Q + N FTYPE + S FTYPE=$P(IFIEVAL("FINDING"),U,1) + S FTYPE=$P(FTYPE,";",2) + I FTYPE="AUTTEDT(" D MHVOUT^PXRMEDU(INDENT,.IFIEVAL,.NLINES,.TEXT) Q + I FTYPE="AUTTEXAM(" D MHVOUT^PXRMEXAM(INDENT,.IFIEVAL,.NLINES,.TEXT) Q + I FTYPE="AUTTHF(" D MHVOUT^PXRMHF(INDENT,.IFIEVAL,.NLINES,.TEXT) Q + I FTYPE="AUTTIMM(" D MHVOUT^PXRMIMM(INDENT,.IFIEVAL,.NLINES,.TEXT) Q + I FTYPE="AUTTSK(" D MHVOUT^PXRMSKIN(INDENT,.IFIEVAL,.NLINES,.TEXT) Q + I FTYPE="GMRD(120.51," D MHVOUT^PXRMVITL(INDENT,.IFIEVAL,.NLINES,.TEXT) Q + I FTYPE="LAB(60," D MHVOUT^PXRMLAB(INDENT,.IFIEVAL,.NLINES,.TEXT) Q + I FTYPE="ORD(101.43," D MHVOUT^PXRMORDR(INDENT,.IFIEVAL,.NLINES,.TEXT) Q + I FTYPE="PS(50.605," D MHVOUT^PXRMDRCL(INDENT,.IFIEVAL,.NLINES,.TEXT) Q + I FTYPE="PSDRUG(" D MHVOUT^PXRMDRUG(INDENT,.IFIEVAL,.NLINES,.TEXT) Q + I FTYPE="PS(55," D MHVOUT^PXRMDIN(INDENT,.IFIEVAL,.NLINES,.TEXT) Q + I FTYPE="PS(55NVA," D MHVOUT^PXRMDNVA(INDENT,.IFIEVAL,.NLINES,.TEXT) Q + I FTYPE="PSRX(" D MHVOUT^PXRMDOUT(INDENT,.IFIEVAL,.NLINES,.TEXT) Q + I FTYPE="PSNDF(50.6," D MHVOUT^PXRMDGEN(INDENT,.IFIEVAL,.NLINES,.TEXT) Q + I FTYPE="PXD(811.2," D MHVOUT^PXRMTAX(INDENT,.IFIEVAL,.NLINES,.TEXT) Q + I FTYPE="PXRMD(802.4," D MHVOUT^PXRMFF(INDENT,.IFIEVAL,.NLINES,.TEXT) Q + I FTYPE="PXRMD(810.9," D MHVOUT^PXRMLOCF(INDENT,.IFIEVAL,.NLINES,.TEXT) Q + 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," D MHVOUT^PXRMMH(INDENT,.IFIEVAL,.NLINES,.TEXT) Q + Q + ; + ;================================================ +MHVC(DEFARR,PXRMPDEM,PCLOGIC,RESLOGIC,RESDATE,FIEVAL) ;Prepare the + ;MyHealtheVet combined output. + N PNAME,RIEN + S RIEN=DEFARR("IEN") + S PNAME=$O(^TMP("PXRHM",$J,RIEN,"")) + S ^TMP("PXRMMHVC",$J,RIEN,"STATUS")=^TMP("PXRHM",$J,RIEN,PNAME) + D MHVD(.DEFARR,.PXRMPDEM,PCLOGIC,RESLOGIC,RESDATE,.FIEVAL,0) + M ^TMP("PXRMMHVC",$J,RIEN,"DETAIL")=^TMP("PXRHM",$J,RIEN,PNAME,"TXT") + K ^TMP("PXRHM",$J,RIEN,PNAME,"TXT") + D MHVS(.DEFARR,.PXRMPDEM,PCLOGIC,RESLOGIC,RESDATE,.FIEVAL,0) + M ^TMP("PXRMMHVC",$J,RIEN,"SUMMARY")=^TMP("PXRHM",$J,RIEN,PNAME,"TXT") + K ^TMP("PXRHM",$J,RIEN,PNAME) + Q + ; + ;================================================ +MHVD(DEFARR,PXRMPDEM,PCLOGIC,RESLOGIC,RESDATE,FIEVAL,WEB) ;Prepare the + ;MyHealtheVet detailed output. + N IND,FIDATA,FINDING,FLIST,FTYPE + N HDR,NHDR,IFIEVAL,LIST,NFLINES,NTXT,NUM + N TEXT + S NTXT=0 + ;Output the AGE match/no match text. + D AGE^PXRMFNFT(PXRMPDEM("DFN"),.DEFARR,.FIEVAL,.NTXT) + ;Process the findings in the order: patient cohort, resolution, + ;age, and informational. + M FIDATA=FIEVAL + F FTYPE="PCL","RES","AGE","INFO" D + . S LIST=$S(FTYPE="PCL":DEFARR(32),FTYPE="RES":DEFARR(36),FTYPE="AGE":DEFARR(40),FTYPE="INFO":DEFARR(42)) + .;Output the general logic text. + . I FTYPE="PCL" D LOGIC^PXRMFNFT(PXRMPDEM("DFN"),PCLOGIC,FTYPE,"D",.DEFARR,.NTXT) + . I FTYPE="RES",$P(PCLOGIC,U,1) D LOGIC^PXRMFNFT(PXRMPDEM("DFN"),RESLOGIC,FTYPE,"D",.DEFARR,.NTXT) + .;Process the findings for each type. + . K TEXT + . S (NHDR,NFLINES)=0 + . S NUM=+$P(LIST,U,1) + . S FLIST=$P(LIST,U,2) + . F IND=1:1:NUM D + .. S FINDING=$P(FLIST,";",IND) + ..;No output for age or sex findings. + .. I (FINDING="AGE")!(FINDING="SEX") Q + ..;Make sure each finding is processed only once. + .. I '$D(FIDATA(FINDING)) Q + .. K IFIEVAL + .. I FIEVAL(FINDING) M IFIEVAL=FIEVAL(FINDING) + .. E S IFIEVAL=0 + ..;Output the found/not found text for the finding. + .. D FINDING^PXRMFNFT(3,PXRMPDEM("DFN"),FINDING,.IFIEVAL,.NFLINES,.TEXT) + ..;If the finding is true output the finding information. + .. I IFIEVAL D FOUT(1,.IFIEVAL,.NFLINES,.TEXT) + ..;Make sure each finding is processed only once. + .. K FIDATA(FINDING) + .; + .;If there was any text for this finding type create a header. + .;Output the header and the finding text. + . D COPYTXT^PXRMOUTU(.NTXT,NFLINES,.TEXT) + I WEB D WEB(DEFARR("IEN"),.NTXT) + Q + ; + ;================================================ +MHVS(DEFARR,PXRMPDEM,PCLOGIC,RESLOGIC,RESDATE,FIEVAL,WEB) ;Prepare the + ;MyHealtheVet summary output. + N NTXT + S NTXT=0 + D LOGIC^PXRMFNFT(PXRMPDEM("DFN"),PCLOGIC,"PCL","S",.DEFARR,.NTXT) + I $P(PCLOGIC,U,1) D LOGIC^PXRMFNFT(PXRMPDEM("DFN"),RESLOGIC,"RES","S",.DEFARR,.NTXT) + I WEB D WEB(DEFARR("IEN"),.NTXT) + Q + ; + ;================================================ +WEB(RIEN,NTXT) ;Output the web site information. + N DES,IEN,IND,NL,TEXT,TITLE,URL + I '$D(^PXD(811.9,RIEN,50)) Q + S TEXT="\\ Please check these web sites for more information:\\" + D ADDTXT^PXRMOUTU(1,PXRMRM,.NTXT,TEXT) + S IEN=0 + F S IEN=+$O(^PXD(811.9,RIEN,50,IEN)) Q:IEN=0 D + . S TEXT=$G(^PXD(811.9,RIEN,50,IEN,0)) + . S URL=$P(TEXT,U,1) + . I URL="" Q + . S TITLE=$P(TEXT,U,2) + . S DES=$D(^PXD(811.9,RIEN,50,IEN,1)) + . S TEXT(1)="Web Site: "_TITLE_"\\" + . S TEXT(2)="URL: "_URL_$S('DES:"\\",1:"") + . D ADDTXTA^PXRMOUTU(2,PXRMRM,.NTXT,2,.TEXT) + .;If there is a description output it. + . I 'DES Q + . K TEXT + . S (IND,NL)=0 + . F S IND=+$O(^PXD(811.9,RIEN,50,IEN,1,IND)) Q:IND=0 D + .. S NL=NL+1 + .. S TEXT(NL)=^PXD(811.9,RIEN,50,IEN,1,IND,0) + . S TEXT(NL)=TEXT(NL)_"\\" + . D ADDTXTA^PXRMOUTU(3,PXRMRM,.NTXT,NL,.TEXT) + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMPARS.m b/r/CLINICAL_REMINDERS-PXRM/PXRMPARS.m index 8fae53e4..91e8d68c 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMPARS.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMPARS.m @@ -1,73 +1,65 @@ -PXRMPARS ; SLC/PJH - Edit PXRM(800 reminder parameters. ;04/02/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ;called by protocol PXRM EDIT SITE DISCLAIMER - ; -DISC(DA) ;Edit default disclaimer - Q:'$$LOCK(DA) - N DIC,DIE,DR,Y - ;Edit - S DIC="^PXRM(800,",DIE=800,DR=2 - 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 - ; - ;called by protocol PXRM EDIT WEB SITE - ; -WEB(DA) ;Edit default web site - Q:'$$LOCK(DA) - ;Edit - N DTOUT,DUOUT - F D Q:$D(DUOUT)!$D(DTOUT) - .D WLIST,WSET,WURL(DA) - Q - ; -WLIST ;Display web sites - N FIRST,SUB,SUB1 - S FIRST=1,SUB="" - F S SUB=$O(^PXRM(800,DA,1,"B",SUB)) Q:SUB="" D - .S SUB1=0 - .F S SUB1=$O(^PXRM(800,DA,1,"B",SUB,SUB1)) Q:'SUB1 D - ..I FIRST S FIRST=0 W !!,"Choose from:",! - ..W ?8,$P($G(^PXRM(800,DA,1,SUB1,0)),U),! - I FIRST W !!,"No default web sites defined",! - Q - ; -WSET ;Set node if not defined - S:'$D(^PXRM(800,DA,1,0)) ^PXRM(800,DA,1,0)="^800.04" - Q - ; -WURL(IEN) ;Edit individual URL - N DA,DIC,DIE,DR,Y - S DA(1)=IEN - S DIC="^PXRM(800,"_IEN_",1," - S DIC(0)="QEAL" - S DIC("A")="Select URL: " - S DIC("P")="800.04" - D ^DIC I Y=-1 S DTOUT=1 Q - S DIE=DIC K DIC - S DA=+Y - ;Finding record fields - S DR=".01;.02;1" - ;Edit finding record - D ^DIE - I $D(Y) S DTOUT=1 Q - ;Check if deleted - I '$D(DA) Q - Q - ; -LOCK(DA) ;Lock the record - L +^PXRM(800,DA):0 I Q 1 - E W !!,?5,"Another user is editing this file, try later" H 2 Q 0 - ; -UNLOCK(DA) ;Unlock the record - L -^PXRM(800,DA) - Q +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 + ; +DISC(DA) ;Edit default disclaimer + Q:'$$LOCK(DA) + N DIC,DIE,DR,Y + ;Edit + S DIC="^PXRM(800,",DIE=800,DR=2 + D ^DIE + D FORMAT^PXRMDISC + Q + ; + ;called by protocol PXRM EDIT WEB SITE + ; +WEB(DA) ;Edit default web site + Q:'$$LOCK(DA) + ;Edit + N DTOUT,DUOUT + F D Q:$D(DUOUT)!$D(DTOUT) + .D WLIST,WSET,WURL(DA) + Q + ; +WLIST ;Display web sites + N FIRST,SUB,SUB1 + S FIRST=1,SUB="" + F S SUB=$O(^PXRM(800,DA,1,"B",SUB)) Q:SUB="" D + .S SUB1=0 + .F S SUB1=$O(^PXRM(800,DA,1,"B",SUB,SUB1)) Q:'SUB1 D + ..I FIRST S FIRST=0 W !!,"Choose from:",! + ..W ?8,$P($G(^PXRM(800,DA,1,SUB1,0)),U),! + I FIRST W !!,"No default web sites defined",! + Q + ; +WSET ;Set node if not defined + S:'$D(^PXRM(800,DA,1,0)) ^PXRM(800,DA,1,0)="^800.04" + Q + ; +WURL(IEN) ;Edit individual URL + N DA,DIC,DIE,DR,Y + S DA(1)=IEN + S DIC="^PXRM(800,"_IEN_",1," + S DIC(0)="QEAL" + S DIC("A")="Select URL: " + S DIC("P")="800.04" + D ^DIC I Y=-1 S DTOUT=1 Q + S DIE=DIC K DIC + S DA=+Y + ;Finding record fields + S DR=".01;.02;1" + ;Edit finding record + D ^DIE + I $D(Y) S DTOUT=1 Q + ;Check if deleted + I '$D(DA) Q + Q + ; +LOCK(DA) ;Lock the record + L +^PXRM(800,DA):0 I Q 1 + E W !!,?5,"Another user is editing this file, try later" H 2 Q 0 + ; +UNLOCK(DA) ;Unlock the record + L -^PXRM(800,DA) + Q diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMPDR.m b/r/CLINICAL_REMINDERS-PXRM/PXRMPDR.m index 7445f4c4..cb466fd7 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMPDR.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMPDR.m @@ -1,195 +1,200 @@ -PXRMPDR ;SLC/AGP,PKR - Patient List Demographic report main routine ;11/16/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; -EN(PLIEN) ; -- main entry point for PXRM PATIENT LIST DEMOGRAPHIC - N ARRAY,DC,DDATA,DELIM,DTOUT,DUOUT - W @IOF - K ^TMP("PXRMPLD",$J),^TMP("PXRMPLN",$J) - S DELIM=0 -OPTION ; - W !,"Select the items to include on the report." -ADDSEL D ADDSEL^PXRMPDRS(.DDATA,"ADD") - I $D(DTOUT)!$D(DUOUT) Q -APPSEL D APPSEL^PXRMPDRS(.DDATA,"APP") - I $D(DTOUT)!$D(DUOUT) G ADDSEL -DEMSEL D DEMSEL^PXRMPDRS(.DDATA,"DEM") - I $D(DTOUT)!$D(DUOUT) G APPSEL -PFACSEL S DDATA("PFAC",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") - I $D(DTOUT)!$D(DUOUT) G PFACSEL -DATASEL D DATASEL^PXRMPDRS(PLIEN,.DDATA,"FIND") - I $D(DTOUT)!$D(DUOUT) G ELIGSEL -INPSEL D INPSEL^PXRMPDRS(.DDATA,"INP") - I $D(DTOUT)!$D(DUOUT) G DATASEL -REMDATA D REMSEL^PXRMPDRS(PLIEN,.DDATA,"REM") - 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 $D(DTOUT)!$D(DUOUT) G OPTION -DEVICE ; - N DESC,DIR,PXRMQUE,RTN,SAVE,%ZIS - 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 - I $D(DTOUT)!$D(DUOUT) G EXIT - S DIR(0)="E" D ^DIR -EXIT D KVA^VADPT - K ^TMP("PXRMPLD",$J),^TMP("PXRMPLN",$J) - Q - ; -GETPDATA(DELIM,DC,PLIEN,DDATA) ; - N DATA,DATE,DCREAT,DFN,DTYPE,ERRMSG - N GETADD,GETAPP,GETDEM,GETELIG,GETFIND,GETINP,GETREM - N IEN,IND,JND,KND,LND - N LISTNAME,PIECE - N PDATA,PNAME,RIEN,TDATA - K ^TMP("PXRMPD",$J) - 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 IEN=0 - F S IEN=+$O(^PXRMXP(810.5,PLIEN,30,IEN)) Q:IEN=0 D - . S DFN=$P(^PXRMXP(810.5,PLIEN,30,IEN,0),U,1) I DFN="" Q - .;#DBIA 10035 - . S PNAME=$P($G(^DPT(DFN,0)),U,1) - . I PNAME="" S PNAME="UNDEFINED"_DFN - . S ^TMP("PXRMPLN",$J,PNAME,DFN)="" - . S PDATA="" - . I GETDEM 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) - .... S TDATA=$P(VADM(KND),U,PIECE) - .... S LND="" - .... F S LND=$O(VADM(KND,LND)) Q:LND="" D - ..... 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 - ..;DBIA #1850 - .. S TDATA=$$GET1^DIQ(2,DFN,27.02,"E","","ERRMSG") - .. I TDATA="" S TDATA="NONE" - .. S ^TMP("PXRMPLD",$J,DFN,"PFAC")=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) - .... S TDATA=$P(VAPA(KND),U,PIECE) - .... S $P(PDATA,U,KND)=TDATA - .. I PDATA'="" S ^TMP("PXRMPLD",$J,DFN,"ADD")=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) - .... S TDATA=$P(VAIN(KND),U,PIECE) - .... S $P(PDATA,U,KND)=TDATA - .. I PDATA'="" S ^TMP("PXRMPLD",$J,DFN,"INP")=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) - .... 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="" - . D KVA^VADPT - . I GETREM D - .. S IND=0 - .. F S IND=$O(DDATA("REM","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="" - . 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) - ... 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 - ;Get appointment data for all patients on the list. - I GETAPP D - . N ARRAY,COUNT - . 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) - .. S KND=0 - .. F S KND=$O(DDATA("APP",JND,KND)) Q:KND="" S ARRAY("FLDS")=ARRAY("FLDS")_KND_";" - . K ^TMP($J,"PXRMPL"),^TMP($J,"SDAMA301") - . S IND=0 - . F S IND=+$O(^PXRMXP(810.5,PLIEN,30,IND)) Q:IND=0 D - .. S DFN=$P(^PXRMXP(810.5,PLIEN,30,IND,0),U,1) - .. I DFN'="" S ^TMP($J,"PXRMPL",DFN)="" - . S COUNT=$$SDAPI^SDAMA301(.ARRAY) - . I COUNT=-1 D Q - .. D APPERR^PXRMPDRS - .. S DDATA("APP","ERROR")="" - .. K ^TMP($J,"PXRMPL"),^TMP($J,"SDAMA301") - . F IND=1:1:COUNT D - .. S DFN="" - .. F S DFN=$O(^TMP($J,"SDAMA301",DFN)) Q:DFN="" D - ... S (JND,KND)=0 - ... F S JND=$O(^TMP($J,"SDAMA301",DFN,JND)) Q:JND="" D - .... S DATE=0 - .... F S DATE=$O(^TMP($J,"SDAMA301",DFN,JND,DATE)) Q:DATE="" D - ..... S KND=KND+1 - ..... S TDATA=^TMP($J,"SDAMA301",DFN,JND,DATE) - ..... S PDATA=$$FMTE^XLFDT($P(TDATA,U,1)) - ..... S TDATA=$P(TDATA,U,2),TDATA=$P(TDATA,";",2) - ..... S PDATA=PDATA_U_TDATA - ..... S ^TMP("PXRMPLD",$J,DFN,"APP",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) - Q - ; -LENGTH(STR,STR1) ; - I ($L(STR)+$L(STR1))>245 W !,STR S STR=STR1 - E S STR=STR_U_STR1,STR1="" - Q - ; -PAGE ; - I ($E(IOST,1,2)="C-")&(IO=IO(0)) D - .S DIR(0)="E" - .W ! - .D ^DIR K DIR - I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)) S DONE=1 Q - W:$D(IOF) @IOF - S PAGE=PAGE+1 - I ($E(IOST,1,2)="C-")&(IO=IO(0)) W @IOF - Q - ; +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 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 BACK=0,DELIM=0,QUIT=0 +OPTION ; + W !,"Select the items to include on the report." +ADDSEL D ADDSEL^PXRMPDRS(.ADDDATA) + I $D(DTOUT)!$D(DUOUT) Q +APPSEL D APPSEL^PXRMPDRS(.APPDATA) + I $D(DTOUT)!$D(DUOUT) G ADDSEL +DEMSEL D DEMSEL^PXRMPDRS(.DEMDATA) + I $D(DTOUT)!$D(DUOUT) G APPSEL +PFACSEL S PFACDATA(0)=$$ASKYN^PXRMEUT("N","Include the patient's preferred facility") + I $D(DTOUT)!$D(DUOUT) G DEMSEL + 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,.FINDDATA) + I $D(DTOUT)!$D(DUOUT) G ELIGSEL +INPSEL D INPSEL^PXRMPDRS(.INPDATA) + I $D(DTOUT)!$D(DUOUT) G DATASEL +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 + I DELIM S DC=$$DELIMSEL^PXRMXSD + I $D(DTOUT)!$D(DUOUT) G OPTION +DEVICE ; + N DIR,PXRMQUE,%ZIS,ZTDESC,ZTRTN,ZTSAVE + S %ZIS="M" + 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 + K ^TMP("PXRMPLD",$J),^TMP("PXRMPLN",$J) + Q + ; +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 + N IEN,IND,JND,KND,LND + N LISTNAME,PIECE + N PDATA,PNAME,RIEN,TDATA + K ^TMP("PXRMPD",$J) + S LISTNAME=$P(^PXRMXP(810.5,PLIEN,0),U,1) + S DCREAT=$P(^PXRMXP(810.5,PLIEN,0),U,4) + 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 + . S DFN=$P(^PXRMXP(810.5,PLIEN,30,IEN,0),U,1) I DFN="" Q + .;#DBIA 10035 + . S PNAME=$P($G(^DPT(DFN,0)),U,1) + . I PNAME="" S PNAME="UNDEFINED"_DFN + . S ^TMP("PXRMPLN",$J,PNAME,DFN)="" + . S PDATA="" + . I GETDEM D + .. N VADM + .. D DEM^VADPT + .. 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="" + .... F S LND=$O(VADM(KND,LND)) Q:LND="" D + ..... I TDATA'="" S TDATA=TDATA_"~" + ..... S TDATA=TDATA_$P(VADM(KND,LND),U,PIECE) + .... 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,"PFACDATA")=TDATA + . I GETADD D + .. N VAPA + .. D ADD^VADPT + .. 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,"ADDDATA")=PDATA,PDATA="" + . I GETINP D + .. N VAIP + .. D INP^VADPT + .. 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,"INPDATA")=PDATA,PDATA="" + . I GETELIG D + .. N VAEL + .. D ELIG^VADPT + .. 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,"ELIGDATA")=PDATA,PDATA="" + . D KVA^VADPT + . I GETREM D + .. S IND=0 + .. 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,"REMDATA",RIEN)=PDATA,PDATA="" + . I GETFIND D + .. N DL + .. 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,"FINDDATA",JND)=DATA + ;Get appointment data for all patients on the list. + I GETAPP D + . N ARRAY,COUNT + . S ARRAY(1)=DT,ARRAY(3)="I;R" + . S ARRAY(4)="^TMP($J,""PXRMPL""",ARRAY("FLDS")="" + . F IND=1:1:APPDATA("LEN") D + .. S JND=$P(APPDATA,",",IND) + .. S KND=0 + .. 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 + . F S IND=+$O(^PXRMXP(810.5,PLIEN,30,IND)) Q:IND=0 D + .. S DFN=$P(^PXRMXP(810.5,PLIEN,30,IND,0),U,1) + .. I DFN'="" S ^TMP($J,"PXRMPL",DFN)="" + . S COUNT=$$SDAPI^SDAMA301(.ARRAY) + . I COUNT=-1 D Q + .. D APPERR^PXRMPDRS + .. S APPDATA("ERROR")="" + .. K ^TMP($J,"PXRMPL"),^TMP($J,"SDAMA301") + . F IND=1:1:COUNT D + .. S DFN="" + .. F S DFN=$O(^TMP($J,"SDAMA301",DFN)) Q:DFN="" D + ... S (JND,KND)=0 + ... F S JND=$O(^TMP($J,"SDAMA301",DFN,JND)) Q:JND="" D + .... S DATE=0 + .... F S DATE=$O(^TMP($J,"SDAMA301",DFN,JND,DATE)) Q:DATE="" D + ..... S KND=KND+1 + ..... S TDATA=^TMP($J,"SDAMA301",DFN,JND,DATE) + ..... S PDATA=$$FMTE^XLFDT($P(TDATA,U,1)) + ..... S TDATA=$P(TDATA,U,2),TDATA=$P(TDATA,";",2) + ..... S PDATA=PDATA_U_TDATA + ..... S ^TMP("PXRMPLD",$J,DFN,"APPDATA",KND)=PDATA + . K ^TMP($J,"PXRMPL"),^TMP($J,"SDAMA301") + 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 + ; +LENGTH(STR,STR1) ; + I ($L(STR)+$L(STR1))>245 W !,STR S STR=STR1 + E S STR=STR_U_STR1,STR1="" + Q + ; +PAGE ; + I ($E(IOST)="C")&(IO=IO(0)) D + .S DIR(0)="E" + .W ! + .D ^DIR K DIR + I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)) S DONE=1 Q + W:$D(IOF) @IOF + S PAGE=PAGE+1 + I $E(IOST)="C",IO=IO(0) W @IOF + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMPDRP.m b/r/CLINICAL_REMINDERS-PXRM/PXRMPDRP.m index dbd02ae1..7a056cb8 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMPDRP.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMPDRP.m @@ -1,300 +1,307 @@ -PXRMPDRP ;SLC/AGP,PKR - Patient List Demographic report print routine ;11/16/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; -ADDTXT(TEXT) ;Accumulate text in ^TMP. - S LINCNT=LINCNT+1 - S ^TMP("PXRMPDEM",$J,LINCNT)=TEXT - Q - ; -APPHDR(DC,DDATA,SUB) ;Build the appointment header. - I DDATA(SUB,"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) - .. S LND="" - .. F S LND=$O(DDATA(SUB,KND,LND)) Q:LND="" D - ... S TEMP=$P(DDATA(SUB,KND,LND),U,1) - ... S HDR=HDR_TEMP_IND_DC - S DDATA(SUB,"HDR")=HDR - Q - ; -APPPRINT(DFN,DDATA,SUB) ;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) - . 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) - 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)) - . S LINE="" - . I PDATE S LINE=LINE_$P(TEMP,U,1) - . I PCLINIC S LINE=LINE_" "_$P(TEMP,U,2) - . D ADDTXT(LINE) - Q - ; -DELIMHDR(DC,DDATA,SUB) ;Build the delimited header for a data type. - I DDATA(SUB,"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) - . 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) - .. 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) ; - ;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 - D TITLE(PLIEN,1) - ;Create 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) - S PNAME=":" - F S PNAME=$O(^TMP("PXRMPLN",$J,PNAME)) Q:PNAME="" D - . S DFN="" - . F S DFN=$O(^TMP("PXRMPLN",$J,PNAME,DFN)) Q:DFN="" 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 - .. W "\\" - Q - ; -DELTITLE(DC,DATALIST,DDATA) ;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 "\\" - Q - ; -FINDPR(DFN,DDATA,SUB) ;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)) - . I TEMP="" Q - . S LINE=" "_$P(DDATA(SUB,JND,JND),U,1)_": "_TEMP - . D ADDTXT(LINE) - Q - ; -OUTPUT ;Output the text. - N IND,LC,LO,VSIZE - S VSIZE=IOSL-2 - S (LC,LO)=0 - F IND=1:1:LINCNT D - . S LC=LC+1,LO=LO+1 - . W !,^TMP("PXRMPDEM",$J,LC) - . I LO=VSIZE D - .. D PAGE - .. I $D(DTOUT)!$D(DUOUT) S IND=LINCNT Q - .. S LO=0 - Q - ; -PAGE ; - I ($E(IOST,1,2)="C-")&(IO=IO(0)) D - . N DIR - . S DIR(0)="E" - . W ! - . D ^DIR K DIR - 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. - N IND,JND,KND,LINE,LND,PIECE,TEMP - I DDATA(SUB,"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) - .. S LND="" - .. F S LND=$O(DDATA(SUB,KND,LND)) Q:LND="" D - ... S PIECE=$P(DDATA(SUB,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. - N IND,JND,KND,LINE,LND,TEMP,TTEMP - S TEMP=$G(^TMP("PXRMPLD",$J,DFN,DTYPE)) - S LINE="" - F IND=1:1:DDATA(DTYPE,"LEN") D - . S JND=$P(DDATA(DTYPE),",",IND) - . S KND="" - . F S KND=$O(DDATA(DTYPE,JND,KND)) Q:KND="" D - .. S MAX=$P(DDATA(DTYPE,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 - W LINE - 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 - D ADDTXT("Patient's Preferred Facility") - D ADDTXT(" "_$G(^TMP("PXRMPLD",$J,DFN,"PFAC"))) - Q - ; -PFINDATA(DFN,DC,DDATA,SUB) ;Print the finding data. - N IND,JND,LINE,TEMP - I DDATA(SUB,"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)) - . S LINE=LINE_TEMP_DC - W LINE - Q - ; -PREMDATA(DFN,DC,DDATA,SUB) ;Print the reminder data. - N IND,JND,LINE,TEMP - I DDATA(SUB,"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))) - . S LINE=LINE_$P(TEMP,U,2)_DC_$P(TEMP,U,3)_"^"_$P(TEMP,U,4)_DC - W LINE - Q - ; -REGPR(PLIEN,DDATA,SUB) ; - ;Print the regular report.. - N DATATYPE,DFN,PNAME,LINCNT - K ^TMP("PXRMPDEM",$J) - S LINCNT=0 - D TITLE(PLIEN,0) - S PNAME=":" - F S PNAME=$O(^TMP("PXRMPLN",$J,PNAME)) Q:PNAME="" D - . S DFN=0 - . F S DFN=$O(^TMP("PXRMPLN",$J,PNAME,DFN)) Q:DFN="" D - .. D ADDTXT(" ") - .. D ADDTXT("---------- "_PNAME_" DFN="_DFN_" ----------") - .. 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 - D OUTPUT - K ^TMP("PXRMPDEM",$J) - Q - ; -REMHDR(DC,DDATA,SUB) ;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) - . 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. - 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)) - . 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=54-$L(LINE)-($L(DUE)/2) - . S LINE=LINE_$$INSCHR^PXRMEXLC(NSP," ")_DUE - . S NSP=69-$L(LINE)-($L(LAST)/2) - . S LINE=LINE_$$INSCHR^PXRMEXLC(NSP," ")_LAST - . D ADDTXT(LINE) - Q - ; -TITLE(PLIEN,DELIM) ;Print the report title. - N LISTNAME - S LISTNAME=$P(^PXRMXP(810.5,PLIEN,0),U,1) - I DELIM D - . W @IOF - . W !,"Patient Demographic Report" - . W !," Patient List: "_LISTNAME - . W !," Created on "_$$FMTE^XLFDT(DCREAT) - I 'DELIM D - . D ADDTXT("Patient Demographic Report") - . D ADDTXT(" Patient List: "_LISTNAME) - . D ADDTXT(" Created on "_$$FMTE^XLFDT(DCREAT)) - Q - ; -VADPTPR(DFN,DNAME,DTYPE,DDATA,SUB) ;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) - . S KND="" - . F S KND=$O(DDATA(SUB,JND,KND)) Q:KND="" D - .. S TTEMP=$P(TEMP,U,KND) - .. S MAX=+$P(DDATA(SUB,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) - ... D ADDTXT(LINE) - Q - ; +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. + S LINCNT=LINCNT+1 + S ^TMP("PXRMPDEM",$J,LINCNT)=TEXT + 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:APPDATA("MAX") D + . F JND=1:1:APPDATA("LEN") D + .. S KND=$P(APPDATA,",",JND) + .. S LND="" + .. 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 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: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(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,"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) + . I PCLINIC S LINE=LINE_" "_$P(TEMP,U,2) + . D ADDTXT(LINE) + 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:DATA("LEN") D + . S JND=$P(DATA,",",IND) + . S KND="" + . 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 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 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) + ;Output the delimited header. + F IND=1:1:NDT D + . 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 + . S DFN="" + . F S DFN=$O(^TMP("PXRMPLN",$J,PNAME,DFN)) Q:DFN="" D + .. W !,PNAME_DC + .. F IND=1:1:NDT D + ... 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,ADDDATA,APPDATA,DEMDATA,FINDDATA,INPDATA,PFACDATA,REMDATA) ;Combine + ;all the headers to create the delimited title. + W !,"PATIENT"_DC + 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,FINDDATA) ;Print finding information. + N IND,JND,LINE,TEMP + D ADDTXT(" ") + S LINE="Finding Data" + D ADDTXT(LINE) + 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(FINDDATA(JND,JND),U,1)_": "_TEMP + . D ADDTXT(LINE) + Q + ; +OUTPUT ;Output the text. + N IND,LC,LO,VSIZE + S VSIZE=IOSL-2 + S (LC,LO)=0 + F IND=1:1:LINCNT D + . S LC=LC+1,LO=LO+1 + . W !,^TMP("PXRMPDEM",$J,LC) + . I LO=VSIZE D + .. D PAGE + .. I $D(DTOUT)!$D(DUOUT) S IND=LINCNT Q + .. S LO=0 + Q + ; +PAGE ; + I ($E(IOST)="C")&(IO=IO(0)) D + . N DIR + . S DIR(0)="E" + . W ! + . D ^DIR K DIR + I $D(DUOUT)!$D(DTOUT) Q + W:$D(IOF) @IOF + 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 APPDATA("LEN")'>0 Q + S LINE="" + 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(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,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:DATA("LEN") D + . S JND=$P(DATA,",",IND) + . S KND="" + . 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 + W LINE + 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,"PFACDATA"))) + Q + ; +PFINDATA(DFN,DC,FINDDATA) ;Print the finding data. + N IND,JND,LINE,TEMP + I FINDDATA("LEN")'>0 Q + S LINE="" + 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,REMDATA) ;Print the reminder data. + N IND,JND,LINE,TEMP + I REMDATA("LEN")'>0 Q + S LINE="" + 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,ADDDATA,APPDATA,DEMDATA,FINDDATA,INPDATA,PFACDATA,REMDATA) ; + ;Print the regular report.. + N DATATYPE,DFN,PNAME,LINCNT + K ^TMP("PXRMPDEM",$J) + S LINCNT=0 + D TITLE(PLIEN,0) + S PNAME=":" + F S PNAME=$O(^TMP("PXRMPLN",$J,PNAME)) Q:PNAME="" D + . S DFN=0 + . F S DFN=$O(^TMP("PXRMPLN",$J,PNAME,DFN)) Q:DFN="" D + .. D ADDTXT(" ") + .. D ADDTXT("---------- "_PNAME_" DFN="_DFN_" ----------") + .. S DATATYPE="" + .. F S DATATYPE=$O(^TMP("PXRMPLD",$J,DFN,DATATYPE)) Q:DATATYPE="" D + ... 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,REMDATA) ;Build the reminder data delimited header. + N HDR,IND,JND + S HDR="" + 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 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: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(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 + . S NSP=69-$L(LINE)-($L(LAST)/2) + . S LINE=LINE_$$INSCHR^PXRMEXLC(NSP," ")_LAST + . D ADDTXT(LINE) + Q + ; +TITLE(PLIEN,DELIM) ;Print the report title. + N LISTNAME + S LISTNAME=$P(^PXRMXP(810.5,PLIEN,0),U,1) + I DELIM D + . W @IOF + . W !,"Patient Demographic Report" + . W !," Patient List: "_LISTNAME + . W !," Created on "_$$FMTE^XLFDT(DCREAT) + I 'DELIM D + . D ADDTXT("Patient Demographic Report") + . D ADDTXT(" Patient List: "_LISTNAME) + . D ADDTXT(" Created on "_$$FMTE^XLFDT(DCREAT)) + Q + ; +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:DATA("LEN") D + . S JND=$P(DATA,",",IND) + . S KND="" + . F S KND=$O(DATA(JND,KND)) Q:KND="" D + .. S TTEMP=$P(TEMP,U,KND) + .. S MAX=+$P(DATA(JND,KND),U,3) + .. I MAX=0 S MAX=1 + .. F LND=1:1:MAX D + ... S LINE=" "_$P(DATA(JND,KND),U,1)_": "_$P(TTEMP,"~",LND) + ... D ADDTXT(LINE) + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMPDRS.m b/r/CLINICAL_REMINDERS-PXRM/PXRMPDRS.m index 4932dc87..821c5432 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMPDRS.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMPDRS.m @@ -1,195 +1,195 @@ -PXRMPDRS ;SLC/PKR - Patient List Demographic Report data selection. ;03/22/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; -ADDSEL(DATA,SUB) ;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")="Enter your selection(s)" - S ADDLIST("?")="^D HELP^PXRMPDRS" - W !!,"Select from the following address items:" - S LIST=$$SEL^PXRMPDRS(.ADDLIST,2) - I $D(DTOUT)!$D(DUOUT) Q - S DATA(SUB)=LIST - S DATA(SUB,"LEN")=$L(LIST,",")-1 - Q - ; -APPERR ; - N ECODE - I $D(ZTQUEUED) D Q - . N NL,TIME - . S TIME=$$NOW^XLFDT - . S TIME=$$FMTE^XLFDT(TIME) - . K ^TMP("PXRMXMZ",$J) - . S ^TMP("PXRMXMZ",$J,1,0)="The Patient Demographic Report requested by "_$$GET1^DIQ(200,DBDUZ,.01)_" on " - . S ^TMP("PXRMXMZ",$J,2,0)=TIME_" was supposed to include appointment data." - . S ^TMP("PXRMXMZ",$J,3,0)="Appointment data could not be obtained from the Scheduling database due to the" - . S ^TMP("PXRMXMZ",$J,4,0)="following error(s):" - . S ECODE=0,NL=4 - . F S ECODE=$O(^TMP($J,"SDAMA301",ECODE)) Q:ECODE="" D - .. S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=" "_^TMP($J,"SDAMA301",ECODE) - . D SEND^PXRMMSG("Scheduling database error(s)",1) - . S ZTSTOP=1 - ; - I '$D(ZTQUEUED) D Q - . W @IOF - . W !,"Appointment data could not be obtained from the Scheduling database due to the" - . W !,"following error(s):" - . S ECODE=0 - . F S ECODE=$O(^TMP($J,"SDAMA301",ECODE)) Q:ECODE="" D - .. W !," ",^TMP($J,"SDAMA301",ECODE) - Q - ; -APPSEL(DATA,SUB) ;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 - ;in VAPA. The first piece of APPDATA is the name of the data and the - ;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")="Enter your selection(s)" - S APPLIST("?")="^D HELP^PXRMPDRS" - W !!,"Select from the following future appointment items:" - 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) - Q - ; -DATASEL(LISTIEN,DATA,SUB) ; Build a list of data that is availble for - ;this patient list and let the user select what they want. - N IND,DATALIST,DTYPE - S DTYPE="",IND=0 - 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 - ;If there is no data quit. - I IND=0 S DATA(SUB,"LEN")=0 Q - S DATALIST("A")="Enter your selections(s)" - S DATALIST("?")="^D HELP^PXRMPDRS" - W !!,"Select from the following patient data:" - S LIST=$$SEL^PXRMPDRS(.DATALIST,IND) - I $D(DTOUT)!$D(DUOUT) Q - S DATA(SUB)=LIST - S DATA(SUB,"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 - ;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")="Enter your selection(s)" - S DEMLIST("?")="^D HELP^PXRMPDRS" -DSEL W !!,"Select from the following demographic items:" - 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 JND=$P(LIST,",",IND) - . S KND=$O(DATA(SUB,JND,"")) - . S TEMP=$P(DATA(SUB,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) - I $D(DTOUT)!$D(DUOUT) K DTOUT,DUOUT G DSEL - Q - ; -ELIGSEL(DATA,SUB) ;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 - ;in VAEL. The first piece of ELIGDATA is the name of the data and the - ;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")="Enter your selection(s)" - S ELIGLIST("?")="^D HELP^PXRMPDRS" - W !!,"Select from the following eligibility items:" - S LIST=$$SEL^PXRMPDRS(.ELIGLIST,7) - I $D(DTOUT)!$D(DUOUT) Q - S DATA(SUB)=LIST - S DATA(SUB,"LEN")=$L(LIST,",")-1 - Q - ; -HELP ; -- help code. - W !!,"You can choose any combination of numbers i.e., 1-4 or 1,3-5" - W !!,"See the Clinical Reminders Managers manual for detailed explanations of each" - W !,"of the selection items." - Q - ; -INPSEL(DATA,SUB) ;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 - ;in VAIN. The first piece of INPDATA is the name of the data and the - ;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")="Enter your selection(s)" - S INPLIST("?")="^D HELP^PXRMPDRS" - W !!,"Select from the following inpatient items:" - S LIST=$$SEL^PXRMPDRS(.INPLIST,5) - I $D(DTOUT)!$D(DUOUT) Q - S DATA(SUB)=LIST - S DATA(SUB,"LEN")=$L(LIST,",")-1 - Q - ; -REMSEL(PLIEN,DATA,SUB) ;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 - N IEN,IND,REMLIST,RNAME - S (IEN,IND)=0 - F S IEN=$O(^PXRMXP(810.5,PLIEN,45,"B",IEN)) Q:IEN="" D - . S RNAME=$P(^PXD(811.9,IEN,0),U,3) - . 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 REMLIST("A",IND)=" "_IND_" - "_RNAME - S REMLIST("A")="Enter your selection(s)" - S REMLIST("?")="^D HELP^PXRMPDRS" - W !!,"Include due status information for the following reminder(s):" - S LIST=$$SEL^PXRMPDRS(.REMLIST,IND) - I $D(DTOUT)!$D(DUOUT) Q - S DATA(SUB)=LIST - S DATA(SUB,"LEN")=$L(LIST,",")-1 - Q - ; -SEL(SELLIST,LEN) ;Select global list - N DIR,X,Y - M DIR=SELLIST - S DIR(0)="LO^1:"_LEN - D ^DIR - Q Y - ; +PXRMPDRS ;SLC/PKR - Patient List Demographic Report data selection. ;07/18/2006 + ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21 + ; +ADDSEL(ADDDATA) ;Let the user select the address information they want. + N ADDLIST,LIST + 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" + W !!,"Select from the following address items:" + S LIST=$$SEL^PXRMPDRS(.ADDLIST,2) + I $D(DTOUT)!$D(DUOUT) Q + S ADDDATA=LIST + S ADDDATA("LEN")=$L(LIST,",")-1 + Q + ; +APPERR ; + N ECODE + I $D(ZTQUEUED) D Q + . N NL,TIME + . S TIME=$$NOW^XLFDT + . S TIME=$$FMTE^XLFDT(TIME) + . K ^TMP("PXRMXMZ",$J) + . S ^TMP("PXRMXMZ",$J,1,0)="The Patient Demographic Report requested by "_$$GET1^DIQ(200,DBDUZ,.01)_" on " + . S ^TMP("PXRMXMZ",$J,2,0)=TIME_" was supposed to include appointment data." + . S ^TMP("PXRMXMZ",$J,3,0)="Appointment data could not be obtained from the Scheduling database due to the" + . S ^TMP("PXRMXMZ",$J,4,0)="following error(s):" + . S ECODE=0,NL=4 + . F S ECODE=$O(^TMP($J,"SDAMA301",ECODE)) Q:ECODE="" D + .. S NL=NL+1,^TMP("PXRMXMZ",$J,NL,0)=" "_^TMP($J,"SDAMA301",ECODE) + . D SEND^PXRMMSG("Scheduling database error(s)",1) + . S ZTSTOP=1 + ; + I '$D(ZTQUEUED) D Q + . W @IOF + . W !,"Appointment data could not be obtained from the Scheduling database due to the" + . W !,"following error(s):" + . S ECODE=0 + . F S ECODE=$O(^TMP($J,"SDAMA301",ECODE)) Q:ECODE="" D + .. W !," ",^TMP($J,"SDAMA301",ECODE) + Q + ; +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 + ;in VAPA. The first piece of APPDATA is the name of the data and the + ;second piece is the piece of VAPA this is displayed. + N APPLIST,LIST,MAX + 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" + W !!,"Select from the following future appointment items:" + S LIST=$$SEL^PXRMPDRS(.APPLIST,2) + I $D(DTOUT)!$D(DUOUT) Q + 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,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 + S DTYPE="",IND=0 + F S DTYPE=$O(^PXRMXP(810.5,LISTIEN,35,"B",DTYPE)) Q:DTYPE="" D + . S IND=IND+1,DATALIST("A",IND)=" "_IND_" - "_DTYPE + . S FINDDATA(IND,IND)=DTYPE + ;If there is no data quit. + I IND=0 S FINDDATA("LEN")=0 Q + S DATALIST("A")="Enter your selections(s)" + S DATALIST("?")="^D HELP^PXRMPDRS" + W !!,"Select from the following patient data:" + S LIST=$$SEL^PXRMPDRS(.DATALIST,IND) + I $D(DTOUT)!$D(DUOUT) Q + S FINDDATA=LIST + S FINDDATA("LEN")=$L(LIST,",")-1 + Q + ; +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",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" +DSEL W !!,"Select from the following demographic items:" + S LIST=$$SEL^PXRMPDRS(.DEMLIST,11) + I $D(DTOUT)!$D(DUOUT) Q + S DEMDATA=LIST + S DEMDATA("LEN")=$L(LIST,",")-1 + F IND=1:1:DEMDATA("LEN") D + . S JND=$P(LIST,",",IND) + . S KND=$O(DEMDATA(JND,"")) + . S TEMP=$P(DEMDATA(JND,KND),U,1) + . I TEMP="SSN" D + .. N FULLSSN + .. D SSN^PXRMXSD(.FULLSSN) + .. 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(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 + ;in VAEL. The first piece of ELIGDATA is the name of the data and the + ;second piece is the piece of VAEL this is displayed. + N ELIGLIST,ITEM,LIST + 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" + W !!,"Select from the following eligibility items:" + S LIST=$$SEL^PXRMPDRS(.ELIGLIST,7) + I $D(DTOUT)!$D(DUOUT) Q + S ELIGDATA=LIST + S ELIGDATA("LEN")=$L(LIST,",")-1 + Q + ; +HELP ; -- help code. + W !!,"You can choose any combination of numbers i.e., 1-4 or 1,3-5" + W !!,"See the Clinical Reminders Managers manual for detailed explanations of each" + W !,"of the selection items." + Q + ; +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 + ;in VAIN. The first piece of INPDATA is the name of the data and the + ;second piece is the piece of VAIN this is displayed. + N INPLIST,ITEM,LIST + 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" + W !!,"Select from the following inpatient items:" + S LIST=$$SEL^PXRMPDRS(.INPLIST,5) + I $D(DTOUT)!$D(DUOUT) Q + S INPDATA=LIST + S INPDATA("LEN")=$L(LIST,",")-1 + Q + ; +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 REMDATA("LEN")=0 Q + N IEN,IND,REMLIST,RNAME + S (IEN,IND)=0 + F S IEN=$O(^PXRMXP(810.5,PLIEN,45,"B",IEN)) Q:IEN="" D + . S RNAME=$P(^PXD(811.9,IEN,0),U,3) + . I RNAME="" S RNAME=$P(^PXD(811.9,IEN,0),U,1) + . S IND=IND+1 + . S REMDATA("RNAME",IND)=RNAME + . S REMDATA("IEN",IND)=IEN + . S REMLIST("A",IND)=" "_IND_" - "_RNAME + S REMLIST("A")="Enter your selection(s)" + S REMLIST("?")="^D HELP^PXRMPDRS" + W !!,"Include due status information for the following reminder(s):" + S LIST=$$SEL^PXRMPDRS(.REMLIST,IND) + I $D(DTOUT)!$D(DUOUT) Q + S REMDATA=LIST + S REMDATA("LEN")=$L(LIST,",")-1 + Q + ; +SEL(SELLIST,LEN) ;Select global list + N DIR,X,Y + M DIR=SELLIST + S DIR(0)="LO^1:"_LEN + D ^DIR + Q Y + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMPLST.m b/r/CLINICAL_REMINDERS-PXRM/PXRMPLST.m index a2725d04..3becefbc 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMPLST.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMPLST.m @@ -1,250 +1,251 @@ -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 - ; - ;Input : RIEN - Reminder IEN - ; PLIST - List returned in ^TMP($J,PLIST,DFN) - ; DFNONLY - If true list contains only DFN information - ; PXRMDATE - Evaluation date - ;=================================================== -BLDPLST(DEFARR,PLIST,DFNONLY) ; - N DFN,DOBE,DOBS,ELE,ERROR,ERRSTR,IND,FNUM - N LIST1,LIST2,LNAME,LSP,LSTACK - N NDR,NOT,OPER,PCLOG,PFSTACK,SEX,TYPE - ; - ;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 - ;check it here. - S PCLOG=DEFARR(31) - I PCLOG="" Q - S OPER="!&~" - ;Get the sex field, if PCLOG does not contain SEX set it to null. - S SEX=$S(PCLOG["SEX":$P(DEFARR(0),U,9),1:"") - ;If PCLOG contains age build the corresponding date of birth range(s). - I PCLOG["AGE" D DOBR(.DEFARR,.NDR,.DOBS,.DOBE) - ;Replace &' with ~ so the stack will be built properly. - S PCLOG=$$STRREP^PXRMUTIL(PCLOG,"&'","~") - D POSTFIX^PXRMSTAC(PCLOG,OPER,.PFSTACK) - ;Process the logic. - D CFSAA(.PFSTACK) - S (IND,ERROR,LSP,LSTACK(0),NOT)=0 - F Q:(IND'DOBE) S DEL=1 - .. I DEL K ^TMP($J,TGLIST,0,DFN),^TMP($J,TGLIST,1,DFN) - ;Remove patients on a list with a higher rank from all lists with - ;a lower rank. - F IND=1:1:NUMAFI D - . F JND=IND+1:1:NUMAFI D LOGOP("AGEFI"_RF(JND),"AGEFI"_RF(IND),"~") - F IND=1:1:NUMAFI D - . D LOGOP(LNAME,"AGEFI"_RF(IND),LOGOP(IND)) - . K ^TMP($J,"AGEFI"_RF(IND)) - Q - ; - ;================================================== -CFSAA(STACK) ;Check for the first three elements on the stack being - ;SEX, AGE, and &. If that is the case replace the with the "special" - ;finding SAA. - N EL1,EL2,EL3,SAA - S SAA=0 - S EL1=$G(STACK(1)),EL2=$G(STACK(2)),EL3=$G(STACK(3)) - I EL1="SEX",EL2="AGE",EL3="&" S SAA=1 - I EL1="AGE",EL2="SEX",EL3="&" S SAA=1 - I 'SAA Q - ;Create a new pseudo-element for SEX&AGE. - S EL1=$$POP^PXRMSTAC(.STACK) - S EL1=$$POP^PXRMSTAC(.STACK) - S EL1=$$POP^PXRMSTAC(.STACK) - D PUSH^PXRMSTAC(.STACK,"SAA") - Q - ; - ;================================================== -DOBR(DEFARR,NDR,DOBS,DOBE) ;Build the date of birth range. - N IND,FREQ,MINAGE,MAXAGE,TEMP - S (IND,NDR)=0 - F S IND=+$O(DEFARR(7,IND)) Q:IND=0 D - . S TEMP=DEFARR(7,IND,0) - . S FREQ=$P(TEMP,U,1) - . I (FREQ="0Y")!(FREQ="") Q - . S MINAGE=$P(TEMP,U,2) - . S MAXAGE=$P(TEMP,U,3) - . S NDR=NDR+1 - . S DOBE(NDR)=$S(MINAGE="":$$NOW^PXRMDATE,1:$$GETDOB(MINAGE,"MIN")) - . S DOBS(NDR)=$S(MAXAGE="":0,1:$$GETDOB(MAXAGE,"MAX")) - Q - ; - ;================================================== -GENTERM(FINDING,FINUM,TERMARR) ;Given a reminder finding generate a term - ;for patient list evaluation. - N IEN,IND,TEMP,TYPE - S TEMP=$P(FINDING,U,1) - S IEN=$P(TEMP,";",1) - S TYPE=$P(TEMP,";",2) - ;If the finding is a term just load the term. - I TYPE="PXRMD(811.5," D TERM^PXRMLDR(IEN,.TERMARR) Q - S TERMARR(0)="GENERATED" - S TERMARR("IEN")=0 - M TERMARR(20,1)=DEFARR(20,FINUM) - S TERMARR("E",TYPE,IEN,1)="" - Q - ; - ;================================================== -GETDOB(AGE,TYPE) ;Given an age in years return the corresponding date of - ;birth. If TYPE is MIN then find the date of birth that will make them - ;that age. If TYPE is MAX find the last day that will make them - ;that age, i.e., the next day is their birthday. - N DATE,DOB - S DATE=$$NOW^PXRMDATE - I TYPE="MIN" S DOB=DATE-(10000*AGE) - I TYPE="MAX" S DOB=DATE-(10000*(AGE+1)),DOB=$$FMADD^XLFDT(DOB,1) - Q DOB - ; - ;================================================== -LOGOP(LIST1,LIST2,LOGOP) ;Given LIST1 and LIST2 apply the logical - ;operator LOGOP to generate a new list and return it in LIST1 - N DFN1,DFN2 - I LOGOP="&" D Q - . S DFN1="" - . F S DFN1=$O(^TMP($J,LIST1,1,DFN1)) Q:DFN1="" D - .. I $D(^TMP($J,LIST2,1,DFN1)) M ^TMP($J,LIST1,1,DFN1)=^TMP($J,LIST2,1,DFN1) Q - .. K ^TMP($J,LIST1,1,DFN1) - ; - ;"~" represents "&'". - I LOGOP="~" D Q - . S DFN1="" - . F S DFN1=$O(^TMP($J,LIST1,1,DFN1)) Q:DFN1="" D - .. I $D(^TMP($J,LIST2,1,DFN1)) K ^TMP($J,LIST1,1,DFN1) - ; - I LOGOP="!" D - . S DFN2="" - . F S DFN2=$O(^TMP($J,LIST2,1,DFN2)) Q:DFN2="" D - .. M ^TMP($J,LIST1,1,DFN2)=^TMP($J,LIST2,1,DFN2) - Q - ; - ;================================================== -LSA(SEX,NDR,DOBS,DOBE,LNAME) ;Build a list from a SEX & AGE finding. - ;Reference to ^DPT DBIA #10035 - N DFN,DS,IND,SEXOK - F IND=1:1:NDR D - . S DS=DOBS(IND)-.000001 - . F S DS=$O(^DPT("ADOB",DS)) Q:(DS>DOBE(IND))!(DS="") D - .. S DFN="" - .. F S DFN=$O(^DPT("ADOB",DS,DFN)) Q:DFN="" D - ... S SEXOK=$S(SEX="":1,$D(^DPT("ASX",SEX,DFN)):1,1:0) - ... I SEXOK S ^TMP($J,LNAME,1,DFN,1,"SAA")="" - Q - ; - ;================================================== -LSEX(SEX,LNAME,LSTACK) ;Build a list from a SEX finding. - ;Reference to ^DPT DBIA #10035 - N ELIST - ;Start with the existing list to build a list based on sex. - S ELIST=$$POP^PXRMSTAC(.LSTACK) - D PUSH^PXRMSTAC(.LSTACK,ELIST) - S DFN=0 - F S DFN=$O(^TMP($J,ELIST,1,DFN)) Q:DFN="" D - . I $D(^DPT("ASX",SEX,DFN)) S ^TMP($J,LNAME,1,DFN,SEX,1)="" - Q - ; +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 + ; PLIST - List returned in ^TMP($J,PLIST,DFN) + ; DFNONLY - If true list contains only DFN information + ; PXRMDATE - Evaluation date + ;=================================================== +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 + ;check it here. + S PCLOG=DEFARR(31) + I PCLOG="" Q + S OPER="!&~" + ;Get the sex field, if PCLOG does not contain SEX set it to null. + S SEX=$S(PCLOG["SEX":$P(DEFARR(0),U,9),1:"") + ;If PCLOG contains age build the corresponding date of birth range(s). + I PCLOG["AGE" D DOBR(.DEFARR,.NDR,.DOBS,.DOBE) + ;Replace &' with ~ so the stack will be built properly. + S PCLOG=$$STRREP^PXRMUTIL(PCLOG,"&'","~") + D POSTFIX^PXRMSTAC(PCLOG,OPER,.PFSTACK) + ;Process the logic. + D CFSAA(.PFSTACK) + S (IND,ERROR,LSP,LSTACK(0),NOT)=0 + F Q:(IND'DOBE) S DEL=1 + .. I DEL K ^TMP($J,TGLIST,0,DFN),^TMP($J,TGLIST,1,DFN) + ;Remove patients on a list with a higher rank from all lists with + ;a lower rank. + F IND=1:1:NUMAFI D + . F JND=IND+1:1:NUMAFI D LOGOP("AGEFI"_RF(JND),"AGEFI"_RF(IND),"~") + F IND=1:1:NUMAFI D + . D LOGOP(LNAME,"AGEFI"_RF(IND),LOGOP(IND)) + . K ^TMP($J,"AGEFI"_RF(IND)) + Q + ; + ;================================================== +CFSAA(STACK) ;Check for the first three elements on the stack being + ;SEX, AGE, and &. If that is the case replace the with the "special" + ;finding SAA. + N EL1,EL2,EL3,SAA + S SAA=0 + S EL1=$G(STACK(1)),EL2=$G(STACK(2)),EL3=$G(STACK(3)) + I EL1="SEX",EL2="AGE",EL3="&" S SAA=1 + I EL1="AGE",EL2="SEX",EL3="&" S SAA=1 + I 'SAA Q + ;Create a new pseudo-element for SEX&AGE. + S EL1=$$POP^PXRMSTAC(.STACK) + S EL1=$$POP^PXRMSTAC(.STACK) + S EL1=$$POP^PXRMSTAC(.STACK) + D PUSH^PXRMSTAC(.STACK,"SAA") + Q + ; + ;================================================== +DOBR(DEFARR,NDR,DOBS,DOBE) ;Build the date of birth range. + N IND,FREQ,MINAGE,MAXAGE,TEMP + S (IND,NDR)=0 + F S IND=+$O(DEFARR(7,IND)) Q:IND=0 D + . S TEMP=DEFARR(7,IND,0) + . S FREQ=$P(TEMP,U,1) + . I (FREQ="0Y")!(FREQ="") Q + . S MINAGE=$P(TEMP,U,2) + . S MAXAGE=$P(TEMP,U,3) + . S NDR=NDR+1 + . S DOBE(NDR)=$S(MINAGE="":$$NOW^PXRMDATE,1:$$GETDOB(MINAGE,"MIN")) + . S DOBS(NDR)=$S(MAXAGE="":0,1:$$GETDOB(MAXAGE,"MAX")) + Q + ; + ;================================================== +GENTERM(FINDING,FINUM,TERMARR) ;Given a reminder finding generate a term + ;for patient list evaluation. + N IEN,IND,TEMP,TYPE + S TEMP=$P(FINDING,U,1) + S IEN=$P(TEMP,";",1) + S TYPE=$P(TEMP,";",2) + ;If the finding is a term just load the term. + I TYPE="PXRMD(811.5," D TERM^PXRMLDR(IEN,.TERMARR) Q + S TERMARR(0)="GENERATED" + S TERMARR("IEN")=0 + M TERMARR(20,1)=DEFARR(20,FINUM) + S TERMARR("E",TYPE,IEN,1)="" + Q + ; + ;================================================== +GETDOB(AGE,TYPE) ;Given an age in years return the corresponding date of + ;birth. If TYPE is MIN then find the date of birth that will make them + ;that age. If TYPE is MAX find the last day that will make them + ;that age, i.e., the next day is their birthday. + N DATE,DOB + S DATE=$$NOW^PXRMDATE + I TYPE="MIN" S DOB=DATE-(10000*AGE) + I TYPE="MAX" S DOB=DATE-(10000*(AGE+1)),DOB=$$FMADD^XLFDT(DOB,1) + Q DOB + ; + ;================================================== +LOGOP(LIST1,LIST2,LOGOP) ;Given LIST1 and LIST2 apply the logical + ;operator LOGOP to generate a new list and return it in LIST1 + N DFN1,DFN2 + I LOGOP="&" D Q + . S DFN1="" + . F S DFN1=$O(^TMP($J,LIST1,1,DFN1)) Q:DFN1="" D + .. I $D(^TMP($J,LIST2,1,DFN1)) M ^TMP($J,LIST1,1,DFN1)=^TMP($J,LIST2,1,DFN1) Q + .. K ^TMP($J,LIST1,1,DFN1) + ; + ;"~" represents "&'". + I LOGOP="~" D Q + . S DFN1="" + . F S DFN1=$O(^TMP($J,LIST1,1,DFN1)) Q:DFN1="" D + .. I $D(^TMP($J,LIST2,1,DFN1)) K ^TMP($J,LIST1,1,DFN1) + ; + I LOGOP="!" D + . S DFN2="" + . F S DFN2=$O(^TMP($J,LIST2,1,DFN2)) Q:DFN2="" D + .. M ^TMP($J,LIST1,1,DFN2)=^TMP($J,LIST2,1,DFN2) + Q + ; + ;================================================== +LSA(SEX,NDR,DOBS,DOBE,LNAME) ;Build a list from a SEX & AGE finding. + ;Reference to ^DPT DBIA #10035 + N DFN,DS,IND,SEXOK + F IND=1:1:NDR D + . S DS=DOBS(IND)-.1 + . F S DS=$O(^DPT("ADOB",DS)) Q:(DS>DOBE(IND))!(DS="") D + .. S DFN="" + .. F S DFN=$O(^DPT("ADOB",DS,DFN)) Q:DFN="" D + ... S SEXOK=$S(SEX="":1,$D(^DPT("ASX",SEX,DFN)):1,1:0) + ... I SEXOK S ^TMP($J,LNAME,1,DFN,1,"SAA")="" + Q + ; + ;================================================== +LSEX(SEX,LNAME,LSTACK) ;Build a list from a SEX finding. + ;Reference to ^DPT DBIA #10035 + N ELIST + ;Start with the existing list to build a list based on sex. + S ELIST=$$POP^PXRMSTAC(.LSTACK) + D PUSH^PXRMSTAC(.LSTACK,ELIST) + S DFN=0 + F S DFN=$O(^TMP($J,ELIST,1,DFN)) Q:DFN="" D + . I $D(^DPT("ASX",SEX,DFN)) S ^TMP($J,LNAME,1,DFN,SEX,1)="" + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMPTD2.m b/r/CLINICAL_REMINDERS-PXRM/PXRMPTD2.m index fc1e6b60..492a89bf 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMPTD2.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMPTD2.m @@ -1,60 +1,60 @@ -PXRMPTD2 ; SLC/PKR/PJH - Reminder Inquiry print template routines.;03/06/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ;================================================ -DATE(FIND0,PIECE,FLDNUM,TITLE,RJC,PAD,FILENUM,FLG) ;Standard DATE - N DATE,X - 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 - .D ^DIWP - Q - ; - ;================================================ -ENTRYNAM(VPTR) ;Given the variable pointer return the entry name. The - ;variable pointer list contains the information necessary to do the - ;look up. - N IEN,FILENUM,NAME,ROOT - I VPTR="" Q "" - S IEN=$P(VPTR,";",1),ROOT=$P(VPTR,";",2),FILENUM=$P(PXRMFVPL(ROOT),U,1) - S NAME=$$GET1^DIQ(FILENUM,IEN,.01,"","","") - Q NAME - ; - ;================================================ -FREQ(FREQ) ;Format frequency. - I FREQ=-1 Q "Cannot be determined" - I +FREQ=0 Q FREQ_" - Not indicated" - I FREQ="99Y" Q "99Y - Once" - Q +FREQ_($S(FREQ?1N.N1"D":" day",FREQ?1N.N1"M":" month",FREQ?1N.N1"Y":" year",1:""))_$S(+FREQ>1:"s",1:"") - ; - ;================================================ -FTYPE(VPTR,CNT) ;Return finding type. - N FTYPE,ROOT - I VPTR="" Q "UNDEFINED?" - S ROOT=$P(VPTR,";",2) - I '$D(PXRMFVPL) N PXRMFVPL D BLDRLIST^PXRMVPTR(811.902,.01,.PXRMFVPL) - S FTYPE=$S(CNT=1:$P(PXRMFVPL(ROOT),U,4),1:$P(PXRMFVPL(ROOT),U,2)) - Q FTYPE - ; - ;================================================ -GENFREQ(PXF0) ;Print age range frequency set for findings. - N PXF,PXW,PXAMIN,PXAMAX - S PXF=$P(PXF0,U,4) - I PXF="" Q "" - S PXAMIN=$P(PXF0,U,2),PXAMAX=$P(PXF0,U,3) - S PXW=$$FREQ(PXF) - S PXW=PXW_$$FMTAGE^PXRMAGE(PXAMIN,PXAMAX) - Q PXW - ; - ;================================================ -GENIEN(FINDING) ;Return internal entry number for findings. - N F0,IEN,PREFIX,ROOT,VPTR - S ROOT="^PXD(811.9,D0,20,FINDING,0)" - S F0=@ROOT - S VPTR=$P(F0,U,1) - I VPTR="" Q "UNDEFINED" - S IEN=$P(VPTR,";",1),ROOT=$P(VPTR,";",2) - I '$D(PXRMFVPL) N PXRMFVPL D BLDRLIST^PXRMVPTR(811.902,.01,.PXRMFVPL) - S VPTR=PXRMFVPL(ROOT) - S PREFIX=$P(VPTR,U,4) - Q " (FI("_+FINDING_")="_PREFIX_"("_IEN_"))" - ; +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 + N DATE,X + S DATE=$P($G(FIND0),U,PIECE) + I DATE'="" D + .S DATE=$$FMTE^XLFDT(DATE,"D"),X=$$RJ^XLFSTR(TITLE,RJC,PAD),X=X_" "_DATE + .D ^DIWP + Q + ; + ;================================================ +ENTRYNAM(VPTR) ;Given the variable pointer return the entry name. The + ;variable pointer list contains the information necessary to do the + ;look up. + N IEN,FILENUM,NAME,ROOT + I VPTR="" Q "" + S IEN=$P(VPTR,";",1),ROOT=$P(VPTR,";",2),FILENUM=$P(PXRMFVPL(ROOT),U,1) + S NAME=$$GET1^DIQ(FILENUM,IEN,.01,"","","") + Q NAME + ; + ;================================================ +FREQ(FREQ) ;Format frequency. + I FREQ=-1 Q "Cannot be determined" + I +FREQ=0 Q FREQ_" - Not indicated" + I FREQ="99Y" Q "99Y - Once" + Q +FREQ_($S(FREQ?1N.N1"D":" day",FREQ?1N.N1"M":" month",FREQ?1N.N1"Y":" year",1:""))_$S(+FREQ>1:"s",1:"") + ; + ;================================================ +FTYPE(VPTR,CNT) ;Return finding type. + N FTYPE,ROOT + I VPTR="" Q "UNDEFINED?" + S ROOT=$P(VPTR,";",2) + I '$D(PXRMFVPL) N PXRMFVPL D BLDRLIST^PXRMVPTR(811.902,.01,.PXRMFVPL) + S FTYPE=$S(CNT=1:$P(PXRMFVPL(ROOT),U,4),1:$P(PXRMFVPL(ROOT),U,2)) + Q FTYPE + ; + ;================================================ +GENFREQ(PXF0) ;Print age range frequency set for findings. + N PXF,PXW,PXAMIN,PXAMAX + S PXF=$P(PXF0,U,4) + I PXF="" Q "" + S PXAMIN=$P(PXF0,U,2),PXAMAX=$P(PXF0,U,3) + S PXW=$$FREQ(PXF) + S PXW=PXW_$$FMTAGE^PXRMAGE(PXAMIN,PXAMAX) + Q PXW + ; + ;================================================ +GENIEN(FINDING) ;Return internal entry number for findings. + N F0,IEN,PREFIX,ROOT,VPTR + S ROOT="^PXD(811.9,D0,20,FINDING,0)" + S F0=@ROOT + S VPTR=$P(F0,U,1) + I VPTR="" Q "UNDEFINED" + S IEN=$P(VPTR,";",1),ROOT=$P(VPTR,";",2) + I '$D(PXRMFVPL) N PXRMFVPL D BLDRLIST^PXRMVPTR(811.902,.01,.PXRMFVPL) + S VPTR=PXRMFVPL(ROOT) + S PREFIX=$P(VPTR,U,4) + Q " (FI("_+FINDING_")="_PREFIX_"("_IEN_"))" + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMPTDF.m b/r/CLINICAL_REMINDERS-PXRM/PXRMPTDF.m index 9677b6fd..932ff06e 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMPTDF.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMPTDF.m @@ -1,271 +1,261 @@ -PXRMPTDF ; SLC/PKR/PJH - Reminder Inquiry print template routines. ;06/07/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ;================================================ -PFIND ;Print the reminder definition finding multiple. - N DIWF,FIELD,FILENUM,FINDING,FIND0,FIND3,FINDNAM,FL,HFCAT,HFIEN - N IEN1,IND,INT,LEN,PAD,PADS,PARRAY,RJC,RFIND,RTERM,SCNT,SIEN,STAT0 - ;If called by a FileMan print build the variable pointer list. - I '$D(PXRMFVPL) N PXRMFVPL D BLDRLIST^PXRMVPTR(811.902,.01,.PXRMFVPL) - ;No printing is done by PFIND it accumulates all output using ^DIWP. - ;The print template outputs the text with ^DIWW. - ;Because of the way DIWP works we need to format all the found and - ;not found text first and store it in ^TMP. - K ^TMP($J,"W") - S FILENUM="811.902" - S RJC=30,PAD=" ",PADS="" - F IND=1:1:(RJC+2) S PADS=PADS_PAD - S FINDING=0 - F S FINDING=$O(^PXD(811.9,D0,20,FINDING)) Q:+FINDING=0 D - .D WPFORMAT(FINDING,20,RJC,1) - .D WPFORMAT(FINDING,20,RJC,2) - K ^UTILITY($J,"W") - S FINDING=0 - F S FINDING=$O(^PXD(811.9,D0,25,FINDING)) Q:+FINDING=0 D - .D WPFORMAT(FINDING,25,RJC,1) - .D WPFORMAT(FINDING,25,RJC,2) - S DIWF="C80",DIWL=2 - K ^UTILITY($J,"W") - S FINDING=0 - F S FINDING=$O(^PXD(811.9,D0,20,FINDING)) Q:+FINDING=0 D - .S FIND0=^PXD(811.9,D0,20,FINDING,0) - .S FIELD=$P(FIND0,U,1) - .S RTERM=FIELD - .S X=" " - .D ^DIWP - .S FINDNAM=$$ENTRYNAM^PXRMPTD2(FIELD) - .I FINDNAM="" S FINDNAM="?" - .S X=$$RJ^XLFSTR("---- Begin:",12,PAD) - .S X=X_" "_FINDNAM - .S RFIND=$$GENIEN^PXRMPTD2(FINDING) - .S X=X_" "_RFIND_" " - .S LEN=(75-$L(X)) - .F INT=1:1:LEN S X=X_"-" - .D ^DIWP - .; - .S X=$$RJ^XLFSTR("Finding Type:",RJC,PAD) - .S X=X_" "_$$FTYPE^PXRMPTD2(FIELD,0) - .D ^DIWP - .I RFIND["HF" D - ..S HFIEN=$P($P($P(RFIND,"HF",2),"(",2),")") - ..S HFCAT=$P($G(^AUTTHF(HFIEN,0)),U,3) - ..S HFCAT=$S(HFCAT="":"UNDEFINED",1:$P($G(^AUTTHF(HFCAT,0)),U,1)) - ..S X=$$RJ^XLFSTR("Health Factor Category:",RJC,PAD) - ..S X=X_" "_HFCAT - ..D ^DIWP - .; - .S FIELD=$P(FIND0,U,4) - .I $L(FIELD)>0 D - ..S X=$$RJ^XLFSTR("Match Frequency/Age:",RJC,PAD) - ..S X=X_" "_$$GENFREQ^PXRMPTD2(FIND0) - ..D ^DIWP - .; - .D SFDISP(FIND0,5,6,"Rank Frequency:",RJC,PAD,FILENUM) - .D SFDISP(FIND0,6,7,"Use in Resolution Logic:",RJC,PAD,FILENUM) - .D SFDISP(FIND0,7,8,"Use in Patient Cohort Logic:",RJC,PAD,FILENUM) - .D DATE^PXRMPTD2(FIND0,8,9,"Beginning Date/Time:",RJC,PAD,FILENUM) - .D DATE^PXRMPTD2(FIND0,11,12,"Ending Date/Time:",RJC,PAD,FILENUM) - .D SFDISP(FIND0,14,17,"Occurrence Count:",RJC,PAD,FILENUM) - .D SFDISP(FIND0,9,10,"Use Inactive Problems:",RJC,PAD,FILENUM) - .D SFDISP(FIND0,10,11,"Within Category Rank:",RJC,PAD,FILENUM) - .D SFDISP(FIND0,16,28,"Include Visit Data:",RJC,PAD,FILENUM) - .D SFDISP(FIND0,12,13,"MH Scale:",RJC,PAD,FILENUM) - .D SFDISP(FIND0,13,16,"Rx Type:",RJC,PAD,FILENUM) - .D SFDISP(FIND0,15,27,"Use Start Date:",RJC,PAD,FILENUM) - .I $D(^PXD(811.9,D0,20,FINDING,5,0))=1 D - ..S (SCNT,SIEN)=0 - ..F S SIEN=$O(^PXD(811.9,D0,20,FINDING,5,SIEN)) Q:SIEN="" D - ...S STAT0=$G(^PXD(811.9,D0,20,FINDING,5,SIEN,0)) - ...D STATUS(STAT0,"Status List:",RJC) S SCNT=SCNT+1 - .S FIND0=$G(^PXD(811.9,D0,20,FINDING,3)) - .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) - .I $G(^PXD(811.9,D0,20,FINDING,15))'="" D - ..S X=$$RJ^XLFSTR("Computed Finding Parameter:",RJC,PAD) - ..S X=X_" "_$G(^PXD(811.9,D0,20,FINDING,15)) - ..D ^DIWP - .D WPOUT(FINDING,20,"Found Text:",RJC,PAD,PADS,1) - .D WPOUT(FINDING,20,"Not Found Text:",RJC,PAD,PADS,2) - .I RTERM["PXRMD(811.5" S IEN1=$P(RTERM,";") D RTERM - .S X=$$RJ^XLFSTR("---- End:",10,PADS) - .S X=X_" "_FINDNAM_" " - .S LEN=(75-$L(X)) - .F INT=1:1:(LEN) S X=X_"-" - .D ^DIWP - .S X=" " - .D ^DIWP - ; - ;Function Findings - I +$P($G(^PXD(811.9,D0,25,0)),U,4)>0 D - .S X=" " - .D ^DIWP - .S X="Function Findings:" - .D ^DIWP - .;Build the list of findings for this reminder. - .D BLDFLST^PXRMPTL(D0,.FL) - .S FILENUM="811.925",FINDING=0 - .F S FINDING=$O(^PXD(811.9,D0,25,FINDING)) Q:+FINDING=0 D - ..S FIND0=$G(^PXD(811.9,D0,25,FINDING,0)) - ..S FIND3=$G(^PXD(811.9,D0,25,FINDING,3)) - ..I FIND3="" Q - ..S FIELD=$P(FIND0,U,1) - ..S FINDNAM="FF("_FIELD_")" - ..S X=" " - ..D ^DIWP - ..S X=$$RJ^XLFSTR("---- Begin:",12,PAD) - ..S X=X_" "_FINDNAM - ..S LEN=(75-$L(X)) - ..F INT=1:1:LEN S X=X_"-" - ..D ^DIWP - ..; - ..D SFDISP(FIND3,1,3,"Function String:",RJC,PAD,FILENUM) - ..S X=" Expanded Function String:" D ^DIWP - ..D DISLOGF^PXRMPTL(D0,FINDING,.FL,.PARRAY) - ..S INT=0 - ..F S INT=$O(PARRAY(INT)) Q:'INT D - ...S X=$J("",6)_PARRAY(INT) D ^DIWP - ..; - ..S FIELD=$P(FIND0,U,4) - ..I $L(FIELD)>0 D - ...S X=$$RJ^XLFSTR("Match Frequency/Age:",RJC,PAD) - ...S X=X_" "_$$GENFREQ^PXRMPTD2(FIND0) - ...D ^DIWP - ..; - ..D SFDISP(FIND0,5,10,"Rank Frequency:",RJC,PAD,FILENUM) - ..D SFDISP(FIND0,6,11,"Use in Resolution Logic:",RJC,PAD,FILENUM) - ..D SFDISP(FIND0,7,12,"Use in Patient Cohort Logic:",RJC,PAD,FILENUM) - ..; - ..D WPOUT(FINDING,25,"Found Text:",RJC,PAD,PADS,1) - ..D WPOUT(FINDING,25,"Not Found Text:",RJC,PAD,PADS,2) - ..S X=$$RJ^XLFSTR("---- End:",10,PADS) - ..S X=X_" "_FINDNAM_" " - ..S LEN=(75-$L(X)) - ..F INT=1:1:(LEN) S X=X_"-" - ..D ^DIWP - ..S X=" " - ..D ^DIWP - ; - K ^TMP($J,"W") - ;^UTILITY($J,"W") will be killed by ^DIWW in the print template. - Q - ; - ;================================================ -RTERM ;Reminder Term - N CNT,RJT,SCNT,SIEN,STAT0,TERM,TERM3,TERMNUM,TERMS - S CNT=0,RJT=RJC+10,TERMNUM="811.52" - S TERMS=0 F S TERMS=$O(^PXRMD(811.5,IEN1,20,TERMS)) Q:+TERMS=0 D - .S TERM=$G(^PXRMD(811.5,IEN1,20,TERMS,0)) - .S TERM3=$G(^PXRMD(811.5,IEN1,20,TERMS,3)) - .D SFDISP(TERM,1,.01,"Mapped Finding Item:",RJT,PAD,TERMNUM,CNT) - .D SFDISP(TERM,8,9,"Beginning Date/Time:",RJT,PAD,TERMNUM) - .D SFDISP(TERM,9,10,"Use Inactive Problems:",RJT,PAD,TERMNUM) - .D SFDISP(TERM,11,12,"Ending Date/Time:",RJT,PAD,TERMNUM) - .D SFDISP(TERM,10,11,"Within Category Rank:",RJT,PAD,TERMNUM) - .D SFDISP(TERM,12,13,"MH Scale:",RJT,PAD,TERMNUM) - .D SFDISP(TERM,13,16,"RX Type:",RJT,PAD,TERMNUM) - .D SFDISP(TERM,14,17,"Occurrence Count:",RJT,PAD,TERMNUM) - .I $D(^PXRMD(811.5,IEN1,20,TERMS,5,0))=1 D - ..S (SCNT,SIEN)=0 - ..F S SIEN=$O(^PXRMD(811.5,IEN1,20,TERMS,5,SIEN)) Q:SIEN="" D - ...S STAT0=$G(^PXRMD(811.5,IEN1,20,TERMS,5,SIEN,0)) - ...D STATUS(STAT0,"Status List:",RJT) S SCNT=SCNT+1 - .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) - .I $G(^PXRMD(811.5,IEN1,20,TERMS,15))'="" D - ..S X=$$RJ^XLFSTR("Computed Finding Parameter:",RJT,PAD) - ..S X=X_" "_$G(^PXRMD(811.5,IEN1,20,TERMS,15)) - ..D ^DIWP - .S X="" - .D ^DIWP - .S CNT=CNT+1 - I CNT=0 D Q - .S X=$$RJ^XLFSTR("RT Mapped Finding:",RJC,PAD) - .S X=X_" No Reminder Finding Found" - .D ^DIWP - Q - ; - ;================================================ -SFDISP(FIND0,PIECE,FLDNUM,TITLE,RJC,PAD,FILENUM,FLG) ;Standard finding - ;multiple field display. - N FIELD,HFCAT,HFIEN,NAME,TYPE,X - S NAME="" - S FIELD=$P(FIND0,U,PIECE) - I (PIECE=1)&(FLDNUM=".01")&(FILENUM="811.52") D - .I FLG=0 D - ..S X="" - ..D ^DIWP - ..S RTERM=$P($P(RFIND,"=",2),")")_")" - ..S X=$$RJ^XLFSTR("Mapped Findings:",40) - ..D ^DIWP - .S TYPE=$$FTYPE^PXRMPTD2(FIELD,1),NAME=$$ENTRYNAM^PXRMPTD2(FIELD) - .S X=$$RJ^XLFSTR(TITLE,RJC,PAD) - .S X=X_" "_TYPE_"."_NAME - .D ^DIWP - .I TYPE="HF" D - ..S HFIEN=$P(TERM,";") - ..S HFCAT=$P($G(^AUTTHF(HFIEN,0)),U,3) - ..S HFCAT=$P($G(^AUTTHF(HFCAT,0)),U) - ..S X=$$RJ^XLFSTR("Health Factor Category:",RJC,PAD) - ..S X=X_" "_HFCAT - ..D ^DIWP - I NAME'="" Q - I $L(FIELD)>0 D - .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 "" - ; - ;================================================ -STATUS(STAT0,TITLE,SPACE) ; - I $L(STAT0)>0 D - .I SCNT=0 S X=$$RJ^XLFSTR(TITLE,SPACE,PAD) - .I SCNT>0 S X=$$RJ^XLFSTR("",SPACE,PAD) - .S X=X_" "_STAT0 - .D ^DIWP - Q - ; - ;================================================ -WPFORMAT(FINDING,NODE,RJC,INDEX) ;Format found/not found word processing text. - I '$D(^PXD(811.9,D0,NODE,FINDING,INDEX,1,0)) Q - ;Save the title using the current format for DIWP. - N DIWF,DIWL,DIWR,IND,NLINES,SC,X - K ^UTILITY($J,"W") - S DIWF="|",DIWL=RJC+2,DIWR=78 - S IND=0 - F S IND=$O(^PXD(811.9,D0,NODE,FINDING,INDEX,IND)) Q:+IND=0 D - .S X=$G(^PXD(811.9,D0,NODE,FINDING,INDEX,IND,0)) - .D ^DIWP - ;Find where this stuff went. - S SC=$O(^UTILITY($J,"W","")) - ;Save into ^TMP. - S NLINES=^UTILITY($J,"W",SC) - S ^TMP($J,"W",FINDING,NODE,INDEX)=NLINES - F IND=1:1:NLINES D - .S ^TMP($J,"W",FINDING,NODE,INDEX,IND)=^UTILITY($J,"W",SC,IND,0) - K ^UTILITY($J,"W") - Q - ; - ;================================================ -WPOUT(FINDING,NODE,TITLE,RJC,PAD,PADS,INDEX) ;Output found/not found word processing - ;text. - I $D(^TMP($J,"W",FINDING,NODE,INDEX)) D - .N IND,X - .S X=$$RJ^XLFSTR(TITLE,RJC,PAD)_" "_^TMP($J,"W",FINDING,NODE,INDEX,1) - .D ^DIWP - .F IND=2:1:^TMP($J,"W",FINDING,NODE,INDEX) D - ..S X=PADS_^TMP($J,"W",FINDING,NODE,INDEX,IND) - ..D ^DIWP - Q - ; +PXRMPTDF ; SLC/PKR/PJH - Reminder Inquiry print template routines. ;01/30/2006 + ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21 + ; + ;================================================ +PFIND ;Print the reminder definition finding multiple. + N DIWF,FIELD,FILENUM,FINDING,FIND0,FIND3,FINDNAM,FL,HFCAT,HFIEN + N IEN1,IND,INT,LEN,PAD,PADS,PARRAY,RJC,RFIND,RTERM,SCNT,SIEN,STAT0 + ;If called by a FileMan print build the variable pointer list. + I '$D(PXRMFVPL) N PXRMFVPL D BLDRLIST^PXRMVPTR(811.902,.01,.PXRMFVPL) + ;No printing is done by PFIND it accumulates all output using ^DIWP. + ;The print template outputs the text with ^DIWW. + ;Because of the way DIWP works we need to format all the found and + ;not found text first and store it in ^TMP. + K ^TMP($J,"W") + S FILENUM="811.902" + S RJC=30,PAD=" ",PADS="" + F IND=1:1:(RJC+2) S PADS=PADS_PAD + S FINDING=0 + F S FINDING=$O(^PXD(811.9,D0,20,FINDING)) Q:+FINDING=0 D + .D WPFORMAT(FINDING,20,RJC,1) + .D WPFORMAT(FINDING,20,RJC,2) + K ^UTILITY($J,"W") + S FINDING=0 + F S FINDING=$O(^PXD(811.9,D0,25,FINDING)) Q:+FINDING=0 D + .D WPFORMAT(FINDING,25,RJC,1) + .D WPFORMAT(FINDING,25,RJC,2) + S DIWF="C80",DIWL=2 + K ^UTILITY($J,"W") + S FINDING=0 + F S FINDING=$O(^PXD(811.9,D0,20,FINDING)) Q:+FINDING=0 D + .S FIND0=^PXD(811.9,D0,20,FINDING,0) + .S FIELD=$P(FIND0,U,1) + .S RTERM=FIELD + .S X=" " + .D ^DIWP + .S FINDNAM=$$ENTRYNAM^PXRMPTD2(FIELD) + .I FINDNAM="" S FINDNAM="?" + .S X=$$RJ^XLFSTR("---- Begin:",12,PAD) + .S X=X_" "_FINDNAM + .S RFIND=$$GENIEN^PXRMPTD2(FINDING) + .S X=X_" "_RFIND_" " + .S LEN=(75-$L(X)) + .F INT=1:1:LEN S X=X_"-" + .D ^DIWP + .; + .S X=$$RJ^XLFSTR("Finding Type:",RJC,PAD) + .S X=X_" "_$$FTYPE^PXRMPTD2(FIELD,0) + .D ^DIWP + .I RFIND["HF" D + ..S HFIEN=$P($P($P(RFIND,"HF",2),"(",2),")") + ..S HFCAT=$P($G(^AUTTHF(HFIEN,0)),U,3) + ..S HFCAT=$S(HFCAT="":"UNDEFINED",1:$P($G(^AUTTHF(HFCAT,0)),U,1)) + ..S X=$$RJ^XLFSTR("Health Factor Category:",RJC,PAD) + ..S X=X_" "_HFCAT + ..D ^DIWP + .; + .S FIELD=$P(FIND0,U,4) + .I $L(FIELD)>0 D + ..S X=$$RJ^XLFSTR("Match Frequency/Age:",RJC,PAD) + ..S X=X_" "_$$GENFREQ^PXRMPTD2(FIND0) + ..D ^DIWP + .; + .D SFDISP(FIND0,5,6,"Rank Frequency:",RJC,PAD,FILENUM) + .D SFDISP(FIND0,6,7,"Use in Resolution Logic:",RJC,PAD,FILENUM) + .D SFDISP(FIND0,7,8,"Use in Patient Cohort Logic:",RJC,PAD,FILENUM) + .D DATE^PXRMPTD2(FIND0,8,9,"Beginning Date/Time:",RJC,PAD,FILENUM) + .D DATE^PXRMPTD2(FIND0,11,12,"Ending Date/Time:",RJC,PAD,FILENUM) + .D SFDISP(FIND0,14,17,"Occurrence Count:",RJC,PAD,FILENUM) + .D SFDISP(FIND0,9,10,"Use Inactive Problems:",RJC,PAD,FILENUM) + .D SFDISP(FIND0,10,11,"Within Category Rank:",RJC,PAD,FILENUM) + .D SFDISP(FIND0,16,28,"Include Visit Data:",RJC,PAD,FILENUM) + .D SFDISP(FIND0,12,13,"MH Scale:",RJC,PAD,FILENUM) + .D SFDISP(FIND0,13,16,"Rx Type:",RJC,PAD,FILENUM) + .D SFDISP(FIND0,15,27,"Use Start Date:",RJC,PAD,FILENUM) + .I $D(^PXD(811.9,D0,20,FINDING,5,0))=1 D + ..S (SCNT,SIEN)=0 + ..F S SIEN=$O(^PXD(811.9,D0,20,FINDING,5,SIEN)) Q:SIEN="" D + ...S STAT0=$G(^PXD(811.9,D0,20,FINDING,5,SIEN,0)) + ...D STATUS(STAT0,"Status List:",RJC) S SCNT=SCNT+1 + .S FIND0=$G(^PXD(811.9,D0,20,FINDING,3)) + .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 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) + ..S X=X_" "_$G(^PXD(811.9,D0,20,FINDING,15)) + ..D ^DIWP + .D WPOUT(FINDING,20,"Found Text:",RJC,PAD,PADS,1) + .D WPOUT(FINDING,20,"Not Found Text:",RJC,PAD,PADS,2) + .I RTERM["PXRMD(811.5" S IEN1=$P(RTERM,";") D RTERM + .S X=$$RJ^XLFSTR("---- End:",10,PADS) + .S X=X_" "_FINDNAM_" " + .S LEN=(75-$L(X)) + .F INT=1:1:(LEN) S X=X_"-" + .D ^DIWP + .S X=" " + .D ^DIWP + ; + ;Function Findings + I +$P($G(^PXD(811.9,D0,25,0)),U,4)>0 D + .S X=" " + .D ^DIWP + .S X="Function Findings:" + .D ^DIWP + .;Build the list of findings for this reminder. + .D BLDFLST^PXRMPTL(D0,.FL) + .S FILENUM="811.925",FINDING=0 + .F S FINDING=$O(^PXD(811.9,D0,25,FINDING)) Q:+FINDING=0 D + ..S FIND0=$G(^PXD(811.9,D0,25,FINDING,0)) + ..S FIND3=$G(^PXD(811.9,D0,25,FINDING,3)) + ..I FIND3="" Q + ..S FIELD=$P(FIND0,U,1) + ..S FINDNAM="FF("_FIELD_")" + ..S X=" " + ..D ^DIWP + ..S X=$$RJ^XLFSTR("---- Begin:",12,PAD) + ..S X=X_" "_FINDNAM + ..S LEN=(75-$L(X)) + ..F INT=1:1:LEN S X=X_"-" + ..D ^DIWP + ..; + ..D SFDISP(FIND3,1,3,"Function String:",RJC,PAD,FILENUM) + ..S X=" Expanded Function String:" D ^DIWP + ..D DISLOGF^PXRMPTL(D0,FINDING,.FL,.PARRAY) + ..S INT=0 + ..F S INT=$O(PARRAY(INT)) Q:'INT D + ...S X=$J("",6)_PARRAY(INT) D ^DIWP + ..; + ..S FIELD=$P(FIND0,U,4) + ..I $L(FIELD)>0 D + ...S X=$$RJ^XLFSTR("Match Frequency/Age:",RJC,PAD) + ...S X=X_" "_$$GENFREQ^PXRMPTD2(FIND0) + ...D ^DIWP + ..; + ..D SFDISP(FIND0,5,10,"Rank Frequency:",RJC,PAD,FILENUM) + ..D SFDISP(FIND0,6,11,"Use in Resolution Logic:",RJC,PAD,FILENUM) + ..D SFDISP(FIND0,7,12,"Use in Patient Cohort Logic:",RJC,PAD,FILENUM) + ..; + ..D WPOUT(FINDING,25,"Found Text:",RJC,PAD,PADS,1) + ..D WPOUT(FINDING,25,"Not Found Text:",RJC,PAD,PADS,2) + ..S X=$$RJ^XLFSTR("---- End:",10,PADS) + ..S X=X_" "_FINDNAM_" " + ..S LEN=(75-$L(X)) + ..F INT=1:1:(LEN) S X=X_"-" + ..D ^DIWP + ..S X=" " + ..D ^DIWP + ; + K ^TMP($J,"W") + ;^UTILITY($J,"W") will be killed by ^DIWW in the print template. + Q + ; + ;================================================ +RTERM ;Reminder Term + N CNT,RJT,SCNT,SIEN,STAT0,TERM,TERM3,TERMNUM,TERMS + S CNT=0,RJT=RJC+10,TERMNUM="811.52" + S TERMS=0 F S TERMS=$O(^PXRMD(811.5,IEN1,20,TERMS)) Q:+TERMS=0 D + .S TERM=$G(^PXRMD(811.5,IEN1,20,TERMS,0)) + .S TERM3=$G(^PXRMD(811.5,IEN1,20,TERMS,3)) + .D SFDISP(TERM,1,.01,"Mapped Finding Item:",RJT,PAD,TERMNUM,CNT) + .D SFDISP(TERM,8,9,"Beginning Date/Time:",RJT,PAD,TERMNUM) + .D SFDISP(TERM,9,10,"Use Inactive Problems:",RJT,PAD,TERMNUM) + .D SFDISP(TERM,11,12,"Ending Date/Time:",RJT,PAD,TERMNUM) + .D SFDISP(TERM,10,11,"Within Category Rank:",RJT,PAD,TERMNUM) + .D SFDISP(TERM,12,13,"MH Scale:",RJT,PAD,TERMNUM) + .D SFDISP(TERM,13,16,"RX Type:",RJT,PAD,TERMNUM) + .D SFDISP(TERM,14,17,"Occurrence Count:",RJT,PAD,TERMNUM) + .I $D(^PXRMD(811.5,IEN1,20,TERMS,5,0))=1 D + ..S (SCNT,SIEN)=0 + ..F S SIEN=$O(^PXRMD(811.5,IEN1,20,TERMS,5,SIEN)) Q:SIEN="" D + ...S STAT0=$G(^PXRMD(811.5,IEN1,20,TERMS,5,SIEN,0)) + ...D STATUS(STAT0,"Status List:",RJT) S SCNT=SCNT+1 + .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 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=X_" "_$G(^PXRMD(811.5,IEN1,20,TERMS,15)) + ..D ^DIWP + .S X="" + .D ^DIWP + .S CNT=CNT+1 + I CNT=0 D Q + .S X=$$RJ^XLFSTR("RT Mapped Finding:",RJC,PAD) + .S X=X_" No Reminder Finding Found" + .D ^DIWP + Q + ; + ;================================================ +SFDISP(FIND0,PIECE,FLDNUM,TITLE,RJC,PAD,FILENUM,FLG) ;Standard finding + ;multiple field display. + N FIELD,HFCAT,HFIEN,NAME,TYPE,X + S NAME="" + S FIELD=$P(FIND0,U,PIECE) + I (PIECE=1)&(FLDNUM=".01")&(FILENUM="811.52") D + .I FLG=0 D + ..S X="" + ..D ^DIWP + ..S RTERM=$P($P(RFIND,"=",2),")")_")" + ..S X=$$RJ^XLFSTR("Mapped Findings:",40) + ..D ^DIWP + .S TYPE=$$FTYPE^PXRMPTD2(FIELD,1),NAME=$$ENTRYNAM^PXRMPTD2(FIELD) + .S X=$$RJ^XLFSTR(TITLE,RJC,PAD) + .S X=X_" "_TYPE_"."_NAME + .D ^DIWP + .I TYPE="HF" D + ..S HFIEN=$P(TERM,";") + ..S HFCAT=$P($G(^AUTTHF(HFIEN,0)),U,3) + ..S HFCAT=$P($G(^AUTTHF(HFCAT,0)),U) + ..S X=$$RJ^XLFSTR("Health Factor Category:",RJC,PAD) + ..S X=X_" "_HFCAT + ..D ^DIWP + I NAME'="" Q + I $L(FIELD)>0 D + .S X=$$RJ^XLFSTR(TITLE,RJC,PAD) + .S X=X_" "_$$EXTERNAL^DILFD(FILENUM,FLDNUM,"",FIELD,"") + .D ^DIWP + Q + ; + ;================================================ +STATUS(STAT0,TITLE,SPACE) ; + I $L(STAT0)>0 D + .I SCNT=0 S X=$$RJ^XLFSTR(TITLE,SPACE,PAD) + .I SCNT>0 S X=$$RJ^XLFSTR("",SPACE,PAD) + .S X=X_" "_STAT0 + .D ^DIWP + Q + ; + ;================================================ +WPFORMAT(FINDING,NODE,RJC,INDEX) ;Format found/not found word processing text. + I '$D(^PXD(811.9,D0,NODE,FINDING,INDEX,1,0)) Q + ;Save the title using the current format for DIWP. + N DIWF,DIWL,DIWR,IND,NLINES,SC,X + K ^UTILITY($J,"W") + S DIWF="|",DIWL=RJC+2,DIWR=78 + S IND=0 + F S IND=$O(^PXD(811.9,D0,NODE,FINDING,INDEX,IND)) Q:+IND=0 D + .S X=$G(^PXD(811.9,D0,NODE,FINDING,INDEX,IND,0)) + .D ^DIWP + ;Find where this stuff went. + S SC=$O(^UTILITY($J,"W","")) + ;Save into ^TMP. + S NLINES=^UTILITY($J,"W",SC) + S ^TMP($J,"W",FINDING,NODE,INDEX)=NLINES + F IND=1:1:NLINES D + .S ^TMP($J,"W",FINDING,NODE,INDEX,IND)=^UTILITY($J,"W",SC,IND,0) + K ^UTILITY($J,"W") + Q + ; + ;================================================ +WPOUT(FINDING,NODE,TITLE,RJC,PAD,PADS,INDEX) ;Output found/not found word processing + ;text. + I $D(^TMP($J,"W",FINDING,NODE,INDEX)) D + .N IND,X + .S X=$$RJ^XLFSTR(TITLE,RJC,PAD)_" "_^TMP($J,"W",FINDING,NODE,INDEX,1) + .D ^DIWP + .F IND=2:1:^TMP($J,"W",FINDING,NODE,INDEX) D + ..S X=PADS_^TMP($J,"W",FINDING,NODE,INDEX,IND) + ..D ^DIWP + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMPTTR.m b/r/CLINICAL_REMINDERS-PXRM/PXRMPTTR.m index cc3a3f74..5ade016a 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMPTTR.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMPTTR.m @@ -1,139 +1,138 @@ -PXRMPTTR ;SLC/PKR - Routines for term print templates ;06/01/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ;==================================================== -DATE(FIND0,PIECE,FLDNUM,TITLE,RJC,PAD,FILENUM,FLG) ;Standard DATE - N DATE,TEXT - S DATE=$P($G(FIND0),U,PIECE) - I DATE'="" D - . S DATE=$$FMTE^XLFDT(DATE,"D") - . S TEXT=$$RJ^XLFSTR(TITLE,RJC,PAD) - . S TEXT=TEXT_" "_DATE - . W !,TEXT - Q - ; - ;==================================================== -GENIEN(FINDING) ;Return internal entry number for findings. - N F0,IEN,PREFIX,ROOT,VPTR - S ROOT="^PXRMD(811.5,D0,20,FINDING,0)" - S F0=@ROOT - S VPTR=$P(F0,U,1) - S IEN=$P(VPTR,";",1) - S ROOT=$P(VPTR,";",2) - I '$D(PXRMFVPL) N PXRMFVPL D BLDRLIST^PXRMVPTR(811.52,.01,.PXRMFVPL) - S VPTR=PXRMFVPL(ROOT) - S PREFIX=$P(VPTR,U,4) - Q " (FI("_+FINDING_")="_PREFIX_"("_IEN_"))" - ; - ;==================================================== -ENTRYNAM(VPTR) ;Given the variable pointer return the entry name. The - ;variable pointer list contains the information necessary to do the - ;look up. - N IEN,FILENUM,NAME,ROOT - S IEN=$P(VPTR,";",1) - S ROOT=$P(VPTR,";",2) - S FILENUM=$P(PXRMFVPL(ROOT),U,1) - S NAME=$$GET1^DIQ(FILENUM,IEN,.01,"","","") - Q NAME - ; - ;==================================================== -PFIND ;Print the reminder term finding multiple. - N CFP,FIELD,FINDING,FIND0,HFCAT,HFIEN,PAD,PXRMFVPL - N RJC,SCNT,SIEN,STAT0,TEXT - ;If called by a FileMan print build the variable pointer list. - I '$D(PXRMFVPL) N PXRMFVPL D BLDRLIST^PXRMVPTR(811.52,.01,.PXRMFVPL) - S PAD=" ",RJC=31 - S FINDING=0 - F S FINDING=$O(^PXRMD(811.5,D0,20,FINDING)) Q:+FINDING=0 D - . S FIND0=^PXRMD(811.5,D0,20,FINDING,0) - . S FIELD=$P(FIND0,U,1) - . S TEXT=$$RJ^XLFSTR("Finding Item:",RJC,PAD) - . S TEXT=TEXT_" "_$$ENTRYNAM(FIELD) - . S TEXT=TEXT_" "_$$TRMIEN(FINDING) - . W !!,TEXT - .; - . S TEXT=$$RJ^XLFSTR("Finding Type:",RJC,PAD) - . S TEXT=TEXT_" "_$$TFTYPE(FIELD) - . W !,TEXT - . I FIND0["AUTTHF" D - .. S HFIEN=$P($P(FIND0,U),";") - .. S HFCAT=$P($G(^AUTTHF(HFIEN,0)),U,3) - .. S HFCAT=$P($G(^AUTTHF(HFCAT,0)),U) - .. S TEXT=$$RJ^XLFSTR("Health Factor Category:",RJC,PAD) - .. S TEXT=TEXT_" "_HFCAT - .. W !,TEXT - .; - . S FIELD=$P(FIND0,U,4) - . I $L(FIELD)>0 D - .. S TEXT=$$RJ^XLFSTR("Match Frequency/Age:",RJC,PAD) - .. S TEXT=TEXT_" "_$$GENFREQ^PXRMPTD2(FIND0) - .. W !,TEXT - .; - . D DATE(FIND0,8,9,"Beginning Date/Time:",RJC,PAD) - . D DATE(FIND0,11,12,"Ending Date/Time Date:",RJC,PAD) - . D SFDISP(FIND0,14,17,"Occurrence Count:",RJC,PAD) - . D SFDISP(FIND0,9,10,"Use Inactive Problems:",RJC,PAD) - . D SFDISP(FIND0,10,11,"Within Category Rank:",RJC,PAD) - . D SFDISP(FIND0,12,13,"MH Scale:",RJC,PAD) - . D SFDISP(FIND0,16,28,"Include Visit Data:",RJC,PAD) - . D SFDISP(FIND0,13,16,"Rx Type:",RJC,PAD) - . D SFDISP(FIND0,15,27,"Use Start Date:",RJC,PAD) - . I $D(^PXRMD(811.5,D0,20,FINDING,5,0))=1 D - .. S (SCNT,SIEN)=0 - .. F S SIEN=$O(^PXRMD(811.5,D0,20,FINDING,5,SIEN)) Q:SIEN="" D - ... S STAT0=$G(^PXRMD(811.5,D0,20,FINDING,5,SIEN,0)) - ... D STATUS(STAT0,"Status List:") S SCNT=SCNT+1 - .; - . S FIND0=$G(^PXRMD(811.5,D0,20,FINDING,3)) - . 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) - . I $G(^PXRMD(811.5,D0,20,FINDING,15))'="" D - .. S CFP=$$RJ^XLFSTR("Computed Finding Parameter:",RJC,PAD) - .. S CFP=CFP_" "_$G(^PXRMD(811.5,D0,20,FINDING,15)) - .. W !,CFP - Q - ; - ;==================================================== -SFDISP(FIND0,PIECE,FLDNUM,TITLE,RJC,PAD) ;Standard finding multiple - ;field display. - N FIELD,TEXT - S FIELD=$P(FIND0,U,PIECE) - I $L(FIELD)>0 D - . 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 - ; - ;==================================================== -STATUS(STAT0,TITLE) ; Status display - I $L(STAT0)>0 D - . N STATUS - . I SCNT=0 S STATUS=$$RJ^XLFSTR(TITLE,RJC,PAD) - . I SCNT>0 S STATUS=$$RJ^XLFSTR("",RJC,PAD) - . S STATUS=STATUS_" "_STAT0 - . W !,STATUS - Q - ; - ;==================================================== -TFTYPE(VPTR) ;Return Term finding type - N ROOT,TFTYPE - S ROOT=$P(VPTR,";",2) - I '$D(PXRMFVPL) N PXRMFVPL D BLDRLIST^PXRMVPTR(811.52,.01,.PXRMFVPL) - S TFTYPE=$P(PXRMFVPL(ROOT),U,2) - Q TFTYPE - ; - ;==================================================== -TRMIEN(FINDING) ;Return internal entry number for TERM findings. - N F0,IEN,PREFIX,ROOT,VPTR - S ROOT="^PXRMD(811.5,D0,20,FINDING,0)" - S F0=@ROOT - S VPTR=$P(F0,U,1) - S IEN=$P(VPTR,";",1) - S ROOT=$P(VPTR,";",2) - I '$D(PXRMFVPL) N PXRMFVPL D BLDRLIST^PXRMVPTR(811.52,.01,.PXRMFVPL) - S VPTR=PXRMFVPL(ROOT) - S PREFIX=$P(VPTR,U,4) - Q " (FI("_+FINDING_")="_PREFIX_"("_IEN_"))" - ; +PXRMPTTR ;SLC/PKR - Routines for term print templates ;01/30/2006 + ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21 + ; + ;==================================================== +DATE(FIND0,PIECE,FLDNUM,TITLE,RJC,PAD,FILENUM,FLG) ;Standard DATE + N DATE,TEXT + S DATE=$P($G(FIND0),U,PIECE) + I DATE'="" D + . S DATE=$$FMTE^XLFDT(DATE,"D") + . S TEXT=$$RJ^XLFSTR(TITLE,RJC,PAD) + . S TEXT=TEXT_" "_DATE + . W !,TEXT + Q + ; + ;==================================================== +GENIEN(FINDING) ;Return internal entry number for findings. + N F0,IEN,PREFIX,ROOT,VPTR + S ROOT="^PXRMD(811.5,D0,20,FINDING,0)" + S F0=@ROOT + S VPTR=$P(F0,U,1) + S IEN=$P(VPTR,";",1) + S ROOT=$P(VPTR,";",2) + I '$D(PXRMFVPL) N PXRMFVPL D BLDRLIST^PXRMVPTR(811.52,.01,.PXRMFVPL) + S VPTR=PXRMFVPL(ROOT) + S PREFIX=$P(VPTR,U,4) + Q " (FI("_+FINDING_")="_PREFIX_"("_IEN_"))" + ; + ;==================================================== +ENTRYNAM(VPTR) ;Given the variable pointer return the entry name. The + ;variable pointer list contains the information necessary to do the + ;look up. + N IEN,FILENUM,NAME,ROOT + S IEN=$P(VPTR,";",1) + S ROOT=$P(VPTR,";",2) + S FILENUM=$P(PXRMFVPL(ROOT),U,1) + S NAME=$$GET1^DIQ(FILENUM,IEN,.01,"","","") + Q NAME + ; + ;==================================================== +PFIND ;Print the reminder term finding multiple. + N CFP,FIELD,FINDING,FIND0,HFCAT,HFIEN,PAD,PXRMFVPL + N RJC,SCNT,SIEN,STAT0,TEXT + ;If called by a FileMan print build the variable pointer list. + I '$D(PXRMFVPL) N PXRMFVPL D BLDRLIST^PXRMVPTR(811.52,.01,.PXRMFVPL) + S PAD=" ",RJC=31 + S FINDING=0 + F S FINDING=$O(^PXRMD(811.5,D0,20,FINDING)) Q:+FINDING=0 D + . S FIND0=^PXRMD(811.5,D0,20,FINDING,0) + . S FIELD=$P(FIND0,U,1) + . S TEXT=$$RJ^XLFSTR("Finding Item:",RJC,PAD) + . S TEXT=TEXT_" "_$$ENTRYNAM(FIELD) + . S TEXT=TEXT_" "_$$TRMIEN(FINDING) + . W !!,TEXT + .; + . S TEXT=$$RJ^XLFSTR("Finding Type:",RJC,PAD) + . S TEXT=TEXT_" "_$$TFTYPE(FIELD) + . W !,TEXT + . I FIND0["AUTTHF" D + .. S HFIEN=$P($P(FIND0,U),";") + .. S HFCAT=$P($G(^AUTTHF(HFIEN,0)),U,3) + .. S HFCAT=$P($G(^AUTTHF(HFCAT,0)),U) + .. S TEXT=$$RJ^XLFSTR("Health Factor Category:",RJC,PAD) + .. S TEXT=TEXT_" "_HFCAT + .. W !,TEXT + .; + . S FIELD=$P(FIND0,U,4) + . I $L(FIELD)>0 D + .. S TEXT=$$RJ^XLFSTR("Match Frequency/Age:",RJC,PAD) + .. S TEXT=TEXT_" "_$$GENFREQ^PXRMPTD2(FIND0) + .. W !,TEXT + .; + . D DATE(FIND0,8,9,"Beginning Date/Time:",RJC,PAD) + . D DATE(FIND0,11,12,"Ending Date/Time Date:",RJC,PAD) + . D SFDISP(FIND0,14,17,"Occurrence Count:",RJC,PAD) + . D SFDISP(FIND0,9,10,"Use Inactive Problems:",RJC,PAD) + . D SFDISP(FIND0,10,11,"Within Category Rank:",RJC,PAD) + . D SFDISP(FIND0,12,13,"MH Scale:",RJC,PAD) + . D SFDISP(FIND0,16,28,"Include Visit Data:",RJC,PAD) + . D SFDISP(FIND0,13,16,"Rx Type:",RJC,PAD) + . D SFDISP(FIND0,15,27,"Use Start Date:",RJC,PAD) + . I $D(^PXRMD(811.5,D0,20,FINDING,5,0))=1 D + .. S (SCNT,SIEN)=0 + .. F S SIEN=$O(^PXRMD(811.5,D0,20,FINDING,5,SIEN)) Q:SIEN="" D + ... S STAT0=$G(^PXRMD(811.5,D0,20,FINDING,5,SIEN,0)) + ... D STATUS(STAT0,"Status List:") S SCNT=SCNT+1 + .; + . S FIND0=$G(^PXRMD(811.5,D0,20,FINDING,3)) + . D SFDISP(FIND0,1,14,"Condition:",RJC,PAD) + . D SFDISP(FIND0,2,15,"Condition Case Sensitive:",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 CFP=CFP_" "_$G(^PXRMD(811.5,D0,20,FINDING,15)) + .. W !,CFP + Q + ; + ;==================================================== +SFDISP(FIND0,PIECE,FLDNUM,TITLE,RJC,PAD) ;Standard finding multiple + ;field display. + N FIELD,TEXT + S FIELD=$P(FIND0,U,PIECE) + I $L(FIELD)>0 D + . S TEXT=$$RJ^XLFSTR(TITLE,RJC,PAD) + . S TEXT=TEXT_" "_$$EXTERNAL^DILFD(811.52,FLDNUM,"",FIELD,"") + . W !,TEXT + Q + ; + ;==================================================== +STATUS(STAT0,TITLE) ; Status display + I $L(STAT0)>0 D + . N STATUS + . I SCNT=0 S STATUS=$$RJ^XLFSTR(TITLE,RJC,PAD) + . I SCNT>0 S STATUS=$$RJ^XLFSTR("",RJC,PAD) + . S STATUS=STATUS_" "_STAT0 + . W !,STATUS + Q + ; + ;==================================================== +TFTYPE(VPTR) ;Return Term finding type + N ROOT,TFTYPE + S ROOT=$P(VPTR,";",2) + I '$D(PXRMFVPL) N PXRMFVPL D BLDRLIST^PXRMVPTR(811.52,.01,.PXRMFVPL) + S TFTYPE=$P(PXRMFVPL(ROOT),U,2) + Q TFTYPE + ; + ;==================================================== +TRMIEN(FINDING) ;Return internal entry number for TERM findings. + N F0,IEN,PREFIX,ROOT,VPTR + S ROOT="^PXRMD(811.5,D0,20,FINDING,0)" + S F0=@ROOT + S VPTR=$P(F0,U,1) + S IEN=$P(VPTR,";",1) + S ROOT=$P(VPTR,";",2) + I '$D(PXRMFVPL) N PXRMFVPL D BLDRLIST^PXRMVPTR(811.52,.01,.PXRMFVPL) + S VPTR=PXRMFVPL(ROOT) + S PREFIX=$P(VPTR,U,4) + Q " (FI("_+FINDING_")="_PREFIX_"("_IEN_"))" + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMREDF.m b/r/CLINICAL_REMINDERS-PXRM/PXRMREDF.m index 237adeb1..d3b4d0c6 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMREDF.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMREDF.m @@ -1,329 +1,327 @@ -PXRMREDF ; SLC/PJH - Edit PXRM reminder findings. ;01/09/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ; Called by PXRMREDT which newes and initialized DEF, DEF1, DEF2. - ; -SET S:'$D(^PXD(811.9,DA,20,0)) ^PXD(811.9,DA,20,0)="^811.902V" Q - ;Display ALL findings - ; - ;-------------------- -DSPALL(TYPE,NODE,DA,LIST) ; - N FIRST,SUB,SUB1,SUB2 - S FIRST=1,SUB="",SUB1="",SUB2="" - F S SUB=$O(LIST(SUB)) Q:SUB="" D - .S SUB1=0 - .F S SUB1=$O(LIST(SUB,SUB1)) Q:SUB1="" D - ..S SUB2=0 F S SUB2=$O(LIST(SUB,SUB1,SUB2)) Q:SUB2="" D - ...I FIRST S FIRST=0 W !!,"Choose from:",! - ...W SUB - ...W ?5,SUB1,?65,"Finding #: "_SUB2,! - I FIRST,TYPE="D" W !!,"Reminder has no findings",! - I FIRST,TYPE="T" W !!,"Reminder Term has no findings",! - ;Update - D LIST^PXRMREDT(NODE,DA,.LIST) - Q - ; - ;Edit individual FINDING entry - ;----------------------------- -FEDIT(IEN) ; - N CFIEN,DA,DIC,DIE,DR,ETYPE,GLOB - N STATUS,TERMSTAT,TIEN,TERMTYPE,VF,WPIEN,Y - S DA(1)=IEN - S DIC="^PXD(811.9,"_IEN_",20," - I $P(^PXD(811.9,IEN,100),U)="N",$G(PXRMINST)'=1 S DIC(0)="QEA" - E S DIC(0)="QEAL" - S DIC("A")="Select FINDING: " - S DIC("P")="811.902V" - 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)) - S SDA(2)=DA(1),SDA(1)=DA - ;Save term IEN - S STATUS=0 - I TYPE="CF" 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" - 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) - S DR=".01;3;I X=""0Y"" S Y=6;1;2;6;7;8;9;12;17" - ;Taxonomy - use inactive problems - I TYPE="TX" D - .S TERMSTAT=$$TAXNODE^PXRMSTA1($P($P(Y,U,2),";"),"H") - .I TERMSTAT="P" S DR=DR_";10" Q - .I TERMSTAT'=0 S DR=DR_";10",STATUS=1 - I TYPE="RT" D - .S TERMTYPE=$$TERMTYPE(TIEN) - .I TERMTYPE["H" S DR=DR_";11" - ;Health Factor - within category rank - I TYPE="HF" S DR=DR_";11" - ;If V file INCLUDE VISIT DATA - S VF=$S(TYPE="ED":1,TYPE="EX":1,TYPE="HF":1,TYPE="IM":1,TYPE="ST":1,TYPE="TX":1,1:0) - I TYPE="RT",$P(TERMTYPE,U,2)="VF" S VF=1 - I VF S DR=DR_";28" - ; - ;Mental Health - scale - I TYPE="MH" S DR=DR_";13" - ;Radiology procedure. - I TYPE="RP" S STATUS=1 - ;Orderable Item - I TYPE="OI" S DR=DR_";27",STATUS=1 - ;Rx Type - I (TYPE="DC")!(TYPE="DG")!(TYPE="DR") S DR=DR_";16;27",STATUS=1 - ;Condition - S DR=DR_";14;15;18" - I TYPE="CF" S DR=DR_";26" - ;Found/not found text - S DR=DR_";4;5" - ; - I TYPE="RT" D - . I TERMTYPE["D" S DR=DR_";16;27",STATUS=1 - . I TERMTYPE["O" S DR=DR_";27",STATUS=1 - . I TERMTYPE["R" S STATUS=1 - . I TERMTYPE["T" S STATUS=1 - .I TERMTYPE[2 D - .. N MSG - .. S MSG(1)="Cannot set a status since the term contains multiple types of findings" - .. S MSG(2)="Edit the status field at the term level for each finding" H 2 - .. D EN^DDIOL(.MSG) - ;Edit finding record - D ^DIE - S $P(^PXD(811.9,IEN,20,0),U,3)=0 - I $D(Y) S DTOUT=1 Q - ;Check if deleted - I '$D(DA) Q - I STATUS=1,$D(Y)=0 D STATUS^PXRMSTA1(.DA,"D") - ; - S ETYPE=$P(^PXD(811.9,IEN,20,SDA(1),0),U,1) - ;Option to edit term findings - I $P(ETYPE,";",2)="PXRMD(811.5," D - . S TIEN=$P(ETYPE,";",1) - . D TMAP(IEN,TIEN) - Q - ; - ;Edit individual function finding entry - ;----------------------------- -FFEDIT(IEN) ; - N DA,DIC,DIE,DR,Y - S DA(1)=IEN - S DIC="^PXD(811.9,"_IEN_",25," - S DIC(0)="QEAL" - S DIC("A")="Select FUNCTION FINDING: " - D ^DIC - I Y=-1 S DTOUT=1 Q - S DIE=DIC K DIC - S DA=+Y - ;Finding record fields - S DR=".01;3" - ;Edit finding record - D ^DIE - I $D(Y) S DTOUT=1 Q - I '$D(DA) Q - ;If the function string is null don't do the rest of the fields. - I $G(^PXD(811.9,IEN,25,DA,3))="" Q - S DR="1;2;11;12;15;I X=""0Y"" S Y=16;13;14;16" - D ^DIE - I $D(Y) S DTOUT=1 Q - I '$D(DA) Q - ;Check if deleted - Q - ; - ;Edit Reminder Function Findings - ;---------------------- -FFIND ; - N DTOUT,DUOUT - F D Q:$D(DUOUT)!$D(DTOUT) - .D FFEDIT(DA) I $D(DUOUT)!$D(DTOUT) Q - K DUOUT,DTOUT - Q - ; - ;Edit Reminder Findings - ;---------------------- -FIND(LIST) ; - N DTOUT,DUOUT,NODE,SDA - D SET ; Check if node defined - S NODE="^PXD(811.9)" - F D Q:$D(DUOUT)!$D(DTOUT) - .;Display list of existing reminder findings - .W !!,"Reminder Definition Findings" - .D DSPALL("D",NODE,DA,.LIST) - .;Edit findings - .D FEDIT(DA) I $D(DUOUT)!$D(DTOUT) D LIST^PXRMREDT(NODE,DA,.LIST) Q - .;Update list with finding changes - .D LIST^PXRMREDT(NODE,DA,.LIST) - Q - ; - ;General help text routine - ;------------------------- -HELP(CALL) ; - N HTEXT - N DIWF,DIWL,DIWR,IC - S DIWF="C70",DIWL=0,DIWR=70 - ; - I CALL=1 D - .S HTEXT(1)="Select the type of finding you wish to change or add." - .S HTEXT(2)="Type '?' for a list of the available finding types." - I CALL=2 D - .S HTEXT(1)="Select section of the reminder you wish to edit or 'All'" - .S HTEXT(2)="to step through all sections of the reminder definition." - I CALL=3 D - .S HTEXT(1)="Select 'Y' to edit the findings mapped to this term" - .S HTEXT(2)="or 'N' to return to select another reminder finding." - ; - 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 - ; - ;Display TERM findings - ;-------------------- -TDSP(DA) ; - N FIRST,SUB,TLST S FIRST=1,SUB="",SUB1="" - ;Build list of term findings - D TLST(.TLST,DA) - ;Display list - F S SUB=$O(TLST(SUB)) Q:SUB="" D - .S SUB1=0 - .F S SUB1=$O(TLST(SUB,SUB1)) Q:SUB1="" D - ..I FIRST S FIRST=0 W !!,"Reminder Term Findings:",!! - ..W SUB - ..W ?8,SUB1,! - I FIRST W !!,"Term has no mapped findings",!! - Q - ; - ;List Reminders using this term - ;------------------------------ -TERMS(TIEN,RIEN) ; - ;RIEN will be the reminder ien if called from reminder edit - ;or zero if called from term edit - N ARRAY,FIND,IEN,SUB,TCNT,RNAME - ;Scan all reminders in file #811.9 - S IEN=0,FIND="PXRMD(811.5,",TCNT=0 - F S IEN=$O(^PXD(811.9,IEN)) Q:'IEN D - .;Exclude current reminder called in reminder edit - .I RIEN,IEN=RIEN Q - .;Check the term findings - .I '$D(^PXD(811.9,IEN,20,"E",FIND,TIEN)) Q - .;Add to reminder array - .S RNAME=$P($G(^PXD(811.9,IEN,0)),U) - .I RNAME="" S RNAME=IEN - .I '$D(ARRAY(RNAME)) S TCNT=TCNT+1 - .S ARRAY(RNAME)="" - ; - ;Display list of reminders using the term - I TCNT D - .N TXT - .S TXT="This Reminder Term is" S:RIEN TXT=TXT_" also" - .S TXT=TXT_" used by the following Reminder Definition" - .I TCNT>1 S TXT=TXT_"s" - .W !!,TXT_":" - .S RNAME="" F S RNAME=$O(ARRAY(RNAME)) Q:RNAME="" W !," ",RNAME - Q - ; - ;------------------------------ - ;Check term for finding item to edit status item -TERMTYPE(TIEN) ; - N DRUG,FOUND,HF,ORD,OTHER,RAD,RESULT,TAX,TYPE,VF - S (DRUG,FOUND,HF,ORD,OTHER,RAD,RESULT,TAX,VF)=0 - S TYPE="" F S TYPE=$O(^PXRMD(811.5,TIEN,20,"B",TYPE)) Q:TYPE="" D - . I TYPE["AUTTEDT(" S (OTHER,VF)=1 Q - . I TYPE["AUTTHF(" S (HF,OTHER,VF)=1 Q - . I TYPE["AUTTIMM(" S (OTHER,VF)=1 Q - . I TYPE["AUTTSK(" S (OTHER,VF)=1 Q - . I TYPE["ORD" S (ORD,FOUND)=1 Q - . I TYPE["PS" S (DRUG,FOUND)=1 Q - . I TYPE["PXD(811.2" S (FOUND,TAX,VF)=1 Q - . I TYPE["RAMIS" S (FOUND,RAD)=1 Q - . S OTHER=1 - I RAD=1,ORD=0,TAX=0,DRUG=0,OTHER=0 S RESULT="R" - I RAD=0,ORD=1,TAX=0,DRUG=0,OTHER=0 S RESULT="O" - I RAD=0,ORD=0,TAX=1,DRUG=0,OTHER=0 S RESULT="T" - I RAD=0,ORD=0,TAX=0,DRUG=1,OTHER=0 S RESULT="D" - I OTHER=1 S RESULT=1 I FOUND=1 S RESULT=2 - I RESULT="T" S RESULT=$$TAXTYPE^PXRMSTA1(TIEN,"") - I HF=1 S RESULT="H"_RESULT - I VF=1 S RESULT=RESULT_U_"VF" - Q RESULT - ; - ;Build list of mapped findings for term - ;-------------------------------------- -TLST(ARRAY,DA) ; - N TYPE,DATA,GLOB,IEN,NAME,NODE,SUB - ;Clear passed arrays - K ARRAY - ;Build cross reference global to file number - ;Get each finding - S SUB=0 F S SUB=$O(^PXRMD(811.5,DA,20,SUB)) Q:'SUB D - .S DATA=$G(^PXRMD(811.5,DA,20,SUB,0)) I DATA="" Q - .;Determine global and global ien - .S NODE=$P(DATA,U),GLOB=$P(NODE,";",2),IEN=$P(NODE,";") - .;Ignore null entries - .I (GLOB="")!(IEN="") Q - .;Work out the file type - .S TYPE=$G(DEF1(GLOB)) Q:TYPE="" - .S NAME=$P($G(@(U_GLOB_IEN_",0)")),U) - .S ARRAY(TYPE,NAME)="" - Q - ; - ;Map Term findings - ;----------------- -TMAP(RIEN,TIEN) ; - N TOPT,TNAM - ;Display any other reminders using this term - D TERMS(TIEN,RIEN) - ;Term name - S TNAM=$P($G(^PXRMD(811.5,TIEN,0)),U) - ;Give option to edit mapped findings (Y/N) - D TMASK(.TOPT,TNAM) Q:$D(DUOUT)!($D(DTOUT)) - ;Edit term findings - I TOPT="Y" D TRMED(TIEN) - Q - ; - ;Option to edit term findings - ;---------------------------- -TMASK(YESNO,TNAM) ; - N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y - S DIR(0)="YA0" - S DIR("A")="Do you want to edit mapped findings for "_TNAM_": " - S (DIR("B"),YESNO)="N" - S DIR("?")="Enter Y or N. For detailed help type ??" - S DIR("??")=U_"D HELP^PXRMREDF(3)" - W ! - D ^DIR K DIR - I $D(DIROUT)!$D(DIRUT) Q - I $D(DTOUT)!$D(DUOUT) Q - S YESNO=$E(Y(0)) - Q - ; - ;Term edit - ;--------- -TRMED(DA) ; - N CS1,CS2,DIC,DLAYGO,DTOUT,DUOUT,Y - K DLAYGO,DTOUT,DUOUT,Y - ;Display term findings - D TDSP(DA) - ;Initialize change history - S CS1=$$FILE^PXRMEXCS(811.5,DA) - ;Edit term findings - S DIC="^PXRMD(811.5," - D EDIT^PXRMTMED(DIC,DA) - ;Update change history - S CS2=$$FILE^PXRMEXCS(811.5,DA) - I CS2=0 Q - I CS2'=CS1 D SEHIST^PXRMUTIL(811.5,DIC,DA) - Q - ; +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. + ; +SET S:'$D(^PXD(811.9,DA,20,0)) ^PXD(811.9,DA,20,0)="^811.902V" Q + ;Display ALL findings + ; + ;-------------------- +DSPALL(TYPE,NODE,DA,LIST) ; + N FIRST,SUB,SUB1,SUB2 + S FIRST=1,SUB="",SUB1="",SUB2="" + F S SUB=$O(LIST(SUB)) Q:SUB="" D + .S SUB1=0 + .F S SUB1=$O(LIST(SUB,SUB1)) Q:SUB1="" D + ..S SUB2=0 F S SUB2=$O(LIST(SUB,SUB1,SUB2)) Q:SUB2="" D + ...I FIRST S FIRST=0 W !!,"Choose from:",! + ...W SUB + ...W ?5,SUB1,?65,"Finding #: "_SUB2,! + I FIRST,TYPE="D" W !!,"Reminder has no findings",! + I FIRST,TYPE="T" W !!,"Reminder Term has no findings",! + ;Update + D LIST^PXRMREDT(NODE,DA,.LIST) + Q + ; + ;Edit individual FINDING entry + ;----------------------------- +FEDIT(IEN) ; + N CFIEN,DA,DIC,DIE,DR,ETYPE,GLOB + N STATUS,TERMSTAT,TIEN,TERMTYPE,VF,WPIEN,Y + S DA(1)=IEN + S DIC="^PXD(811.9,"_IEN_",20," + I $P(^PXD(811.9,IEN,100),U)="N",$G(PXRMINST)'=1 S DIC(0)="QEA" + E S DIC(0)="QEAL" + S DIC("A")="Select FINDING: " + S DIC("P")="811.902V" + D ^DIC I Y=-1 S DTOUT=1 Q + S DIE=DIC K DIC + S DA=+Y,GLOB=$P($P(Y,U,2),";",2) Q:GLOB="" + S TYPE=$G(DEF1(GLOB)) + S SDA(2)=DA(1),SDA(1)=DA + ;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 !!,"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" + ;Finding record fields + W !!,"Editing Finding Number: "_$G(DA) + S DR=".01;3;I X=""0Y"" S Y=6;1;2;6;7;8;9;12;17" + ;Taxonomy - use inactive problems + I TYPE="TX" D + .S TERMSTAT=$$TAXNODE^PXRMSTA1($P($P(Y,U,2),";"),"H") + .I TERMSTAT="P" S DR=DR_";10" Q + .I TERMSTAT'=0 S DR=DR_";10",STATUS=1 + I TYPE="RT" D + .S TERMTYPE=$$TERMTYPE(TIEN) + .I TERMTYPE["H" S DR=DR_";11" + ;Health Factor - within category rank + I TYPE="HF" S DR=DR_";11" + ;If V file INCLUDE VISIT DATA + S VF=$S(TYPE="ED":1,TYPE="EX":1,TYPE="HF":1,TYPE="IM":1,TYPE="ST":1,TYPE="TX":1,1:0) + I TYPE="RT",$P(TERMTYPE,U,2)="VF" S VF=1 + I VF S DR=DR_";28" + ; + ;Mental Health - scale + I TYPE="MH" S DR=DR_";13" + ;Radiology procedure. + I TYPE="RP" S STATUS=1 + ;Orderable Item + I TYPE="OI" S DR=DR_";27",STATUS=1 + ;Rx Type + I (TYPE="DC")!(TYPE="DG")!(TYPE="DR") S DR=DR_";16;27",STATUS=1 + ;Condition + S DR=DR_";14;15;18" + I TYPE="CF" S DR=DR_";26" + ;Found/not found text + S DR=DR_";4;5" + ; + I TYPE="RT" D + . I TERMTYPE["D" S DR=DR_";16;27",STATUS=1 + . I TERMTYPE["O" S DR=DR_";27",STATUS=1 + . I TERMTYPE["R" S STATUS=1 + . I TERMTYPE["T" S STATUS=1 + .I TERMTYPE[2 D + .. N MSG + .. S MSG(1)="Cannot set a status since the term contains multiple types of findings" + .. S MSG(2)="Edit the status field at the term level for each finding" H 2 + .. D EN^DDIOL(.MSG) + ;Edit finding record + D ^DIE + S $P(^PXD(811.9,IEN,20,0),U,3)=0 + I $D(Y) S DTOUT=1 Q + ;Check if deleted + I '$D(DA) Q + I STATUS=1 D STATUS^PXRMSTA1(.DA,"D") + ; + S ETYPE=$P(^PXD(811.9,IEN,20,SDA(1),0),U,1) + ;Option to edit term findings + I $P(ETYPE,";",2)="PXRMD(811.5," D + . S TIEN=$P(ETYPE,";",1) + . D TMAP(IEN,TIEN) + Q + ; + ;Edit individual function finding entry + ;----------------------------- +FFEDIT(IEN) ; + N DA,DIC,DIE,DR,Y + S DA(1)=IEN + S DIC="^PXD(811.9,"_IEN_",25," + S DIC(0)="QEAL" + S DIC("A")="Select FUNCTION FINDING: " + D ^DIC + I Y=-1 S DTOUT=1 Q + S DIE=DIC K DIC + S DA=+Y + ;Finding record fields + S DR=".01;3" + ;Edit finding record + D ^DIE + I $D(Y) S DTOUT=1 Q + I '$D(DA) Q + ;If the function string is null don't do the rest of the fields. + I $G(^PXD(811.9,IEN,25,DA,3))="" Q + S DR="1;2;11;12;15;I X=""0Y"" S Y=16;13;14;16" + D ^DIE + I $D(Y) S DTOUT=1 Q + I '$D(DA) Q + ;Check if deleted + Q + ; + ;Edit Reminder Function Findings + ;---------------------- +FFIND ; + N DTOUT,DUOUT + F D Q:$D(DUOUT)!$D(DTOUT) + .D FFEDIT(DA) I $D(DUOUT)!$D(DTOUT) Q + K DUOUT,DTOUT + Q + ; + ;Edit Reminder Findings + ;---------------------- +FIND(LIST) ; + N DTOUT,DUOUT,NODE,SDA + D SET ; Check if node defined + S NODE="^PXD(811.9)" + F D Q:$D(DUOUT)!$D(DTOUT) + .;Display list of existing reminder findings + .W !!,"Reminder Definition Findings" + .D DSPALL("D",NODE,DA,.LIST) + .;Edit findings + .D FEDIT(DA) I $D(DUOUT)!$D(DTOUT) D LIST^PXRMREDT(NODE,DA,.LIST) Q + .;Update list with finding changes + .D LIST^PXRMREDT(NODE,DA,.LIST) + Q + ; + ;General help text routine + ;------------------------- +HELP(CALL) ; + N HTEXT + N DIWF,DIWL,DIWR,IC + S DIWF="C70",DIWL=0,DIWR=70 + ; + I CALL=1 D + .S HTEXT(1)="Select the type of finding you wish to change or add." + .S HTEXT(2)="Type '?' for a list of the available finding types." + I CALL=2 D + .S HTEXT(1)="Select section of the reminder you wish to edit or 'All'" + .S HTEXT(2)="to step through all sections of the reminder definition." + I CALL=3 D + .S HTEXT(1)="Select 'Y' to edit the findings mapped to this term" + .S HTEXT(2)="or 'N' to return to select another reminder finding." + ; + 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 + ; + ;Display TERM findings + ;-------------------- +TDSP(DA) ; + N FIRST,SUB,TLST S FIRST=1,SUB="",SUB1="" + ;Build list of term findings + D TLST(.TLST,DA) + ;Display list + F S SUB=$O(TLST(SUB)) Q:SUB="" D + .S SUB1=0 + .F S SUB1=$O(TLST(SUB,SUB1)) Q:SUB1="" D + ..I FIRST S FIRST=0 W !!,"Reminder Term Findings:",!! + ..W SUB + ..W ?8,SUB1,! + I FIRST W !!,"Term has no mapped findings",!! + Q + ; + ;List Reminders using this term + ;------------------------------ +TERMS(TIEN,RIEN) ; + ;RIEN will be the reminder ien if called from reminder edit + ;or zero if called from term edit + N ARRAY,FIND,IEN,SUB,TCNT,RNAME + ;Scan all reminders in file #811.9 + S IEN=0,FIND="PXRMD(811.5,",TCNT=0 + F S IEN=$O(^PXD(811.9,IEN)) Q:'IEN D + .;Exclude current reminder called in reminder edit + .I RIEN,IEN=RIEN Q + .;Check the term findings + .I '$D(^PXD(811.9,IEN,20,"E",FIND,TIEN)) Q + .;Add to reminder array + .S RNAME=$P($G(^PXD(811.9,IEN,0)),U) + .I RNAME="" S RNAME=IEN + .I '$D(ARRAY(RNAME)) S TCNT=TCNT+1 + .S ARRAY(RNAME)="" + ; + ;Display list of reminders using the term + I TCNT D + .N TXT + .S TXT="This Reminder Term is" S:RIEN TXT=TXT_" also" + .S TXT=TXT_" used by the following Reminder Definition" + .I TCNT>1 S TXT=TXT_"s" + .W !!,TXT_":" + .S RNAME="" F S RNAME=$O(ARRAY(RNAME)) Q:RNAME="" W !," ",RNAME + Q + ; + ;------------------------------ + ;Check term for finding item to edit status item +TERMTYPE(TIEN) ; + N DRUG,FOUND,HF,ORD,OTHER,RAD,RESULT,TAX,TYPE,VF + S (DRUG,FOUND,HF,ORD,OTHER,RAD,RESULT,TAX,VF)=0 + S TYPE="" F S TYPE=$O(^PXRMD(811.5,TIEN,20,"B",TYPE)) Q:TYPE="" D + . I TYPE["AUTTEDT(" S (OTHER,VF)=1 Q + . I TYPE["AUTTHF(" S (HF,OTHER,VF)=1 Q + . I TYPE["AUTTIMM(" S (OTHER,VF)=1 Q + . I TYPE["AUTTSK(" S (OTHER,VF)=1 Q + . I TYPE["ORD" S (ORD,FOUND)=1 Q + . I TYPE["PS" S (DRUG,FOUND)=1 Q + . I TYPE["PXD(811.2" S (FOUND,TAX,VF)=1 Q + . I TYPE["RAMIS" S (FOUND,RAD)=1 Q + . S OTHER=1 + I RAD=1,ORD=0,TAX=0,DRUG=0,OTHER=0 S RESULT="R" + I RAD=0,ORD=1,TAX=0,DRUG=0,OTHER=0 S RESULT="O" + I RAD=0,ORD=0,TAX=1,DRUG=0,OTHER=0 S RESULT="T" + I RAD=0,ORD=0,TAX=0,DRUG=1,OTHER=0 S RESULT="D" + I OTHER=1 S RESULT=1 I FOUND=1 S RESULT=2 + I RESULT="T" S RESULT=$$TAXTYPE^PXRMSTA1(TIEN,"") + I HF=1 S RESULT="H"_RESULT + I VF=1 S RESULT=RESULT_U_"VF" + Q RESULT + ; + ;Build list of mapped findings for term + ;-------------------------------------- +TLST(ARRAY,DA) ; + N TYPE,DATA,GLOB,IEN,NAME,NODE,SUB + ;Clear passed arrays + K ARRAY + ;Build cross reference global to file number + ;Get each finding + S SUB=0 F S SUB=$O(^PXRMD(811.5,DA,20,SUB)) Q:'SUB D + .S DATA=$G(^PXRMD(811.5,DA,20,SUB,0)) I DATA="" Q + .;Determine global and global ien + .S NODE=$P(DATA,U),GLOB=$P(NODE,";",2),IEN=$P(NODE,";") + .;Ignore null entries + .I (GLOB="")!(IEN="") Q + .;Work out the file type + .S TYPE=$G(DEF1(GLOB)) Q:TYPE="" + .S NAME=$P($G(@(U_GLOB_IEN_",0)")),U) + .S ARRAY(TYPE,NAME)="" + Q + ; + ;Map Term findings + ;----------------- +TMAP(RIEN,TIEN) ; + N TOPT,TNAM + ;Display any other reminders using this term + D TERMS(TIEN,RIEN) + ;Term name + S TNAM=$P($G(^PXRMD(811.5,TIEN,0)),U) + ;Give option to edit mapped findings (Y/N) + D TMASK(.TOPT,TNAM) Q:$D(DUOUT)!($D(DTOUT)) + ;Edit term findings + I TOPT="Y" D TRMED(TIEN) + Q + ; + ;Option to edit term findings + ;---------------------------- +TMASK(YESNO,TNAM) ; + N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y + S DIR(0)="YA0" + S DIR("A")="Do you want to edit mapped findings for "_TNAM_": " + S (DIR("B"),YESNO)="N" + S DIR("?")="Enter Y or N. For detailed help type ??" + S DIR("??")=U_"D HELP^PXRMREDF(3)" + W ! + D ^DIR K DIR + I $D(DIROUT)!$D(DIRUT) Q + I $D(DTOUT)!$D(DUOUT) Q + S YESNO=$E(Y(0)) + Q + ; + ;Term edit + ;--------- +TRMED(DA) ; + N CS1,CS2,DIC,DLAYGO,DTOUT,DUOUT,Y + K DLAYGO,DTOUT,DUOUT,Y + ;Display term findings + D TDSP(DA) + ;Initialize change history + S CS1=$$FILE^PXRMEXCS(811.5,DA) + ;Edit term findings + S DIC="^PXRMD(811.5," + D EDIT^PXRMTMED(DIC,DA) + ;Update change history + S CS2=$$FILE^PXRMEXCS(811.5,DA) + I CS2=0 Q + I CS2'=CS1 D SEHIST^PXRMUTIL(811.5,DIC,DA) + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMREDT.m b/r/CLINICAL_REMINDERS-PXRM/PXRMREDT.m index fd58bca0..7b11338b 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMREDT.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMREDT.m @@ -1,321 +1,310 @@ -PXRMREDT ; SLC/PKR,PJH - Edit PXRM reminder definition. ;10/04/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ;======================================================= -EEDIT ;Entry point for PXRM DEFINITION EDIT option. - ;Build list of finding file definitions. - N DEF,DEF1,DEF2 - D DEF^PXRMRUTL("811.902",.DEF,.DEF1,.DEF2) - ; - N DA,DIC,DLAYGO,DTOUT,DUOUT,Y - S DIC="^PXD(811.9," - S DIC(0)="AEMQL" - S DIC("A")="Select Reminder Definition: " - S DLAYGO=811.9 -GETNAME ;Get the name of the reminder definition to edit. - ;Set the starting place for additions. - D SETSTART^PXRMCOPY(DIC) - W ! - S DIC("W")="W $$LUDISP^PXRMREDT(Y)" - D ^DIC - I ($D(DTOUT))!($D(DUOUT)) Q - I Y=-1 G END - S DA=$P(Y,U,1) - D ALL(DIC,DA) - G GETNAME -END ; - Q - ; - ;======================================================= - ;Select section of reminder to edit, also called at ALL by PXRMEDIT. - ;---------------------------------- -ALL(DIC,DA) ; - ;Get list of findings/terms for reminder - N BLDLOGIC,CS1,CS2,LIST,NODE,OPTION,TYPE - S BLDLOGIC=0 - ;Save the original checksum. - S CS1=$$FILE^PXRMEXCS(811.9,DA) - ;Build finding list - S NODE="^PXD(811.9)" - D LIST(NODE,DA,.LIST) - ;If this is a new reminder enter all fields - I $P(Y,U,3)=1 D EDIT(DIC,DA) Q - ;National reminder allows editing of term findings only - I '$$VEDIT^PXRMUTIL(DIC,DA) D Q:$D(DUOUT)!$D(DTOUT) - .S TYPE="" - .F S TYPE=$O(LIST(TYPE)) Q:TYPE="" D - .. I TYPE="RT" Q - .. K LIST(TYPE) - .I '$D(LIST) S DUOUT=1 Q - .S BLDLOGIC=1 - .D TFIND(DA,.LIST) - .I $D(Y) S DUOUT=1 - ;Otherwise choose fields to edit - I $$VEDIT^PXRMUTIL(DIC,DA) F D Q:$D(DUOUT)!$D(DTOUT) - .D OPTION Q:$D(DUOUT)!$D(DTOUT) - .;All details - .I OPTION="A" D - .. S BLDLOGIC=1 - .. D EDIT(DIC,DA) - .;Set up local variables - .N DIE,DR S DIE=DIC N DIC - .;Descriptions - .I OPTION="G" D - ..D GEN - .;Baseline Frequency - .I OPTION="B" D - ..S BLDLOGIC=1 - ..D BASE - .;Findings - .I OPTION="F" D - ..S BLDLOGIC=1 - ..D FIND(.LIST) - .;Function findings - .I OPTION="FF" D - ..S BLDLOGIC=1 - ..D FFIND - .;Logic - .I OPTION="L" D - ..S BLDLOGIC=1 - ..D LOGIC - .;Custom date due - . I OPTION="C" D - ..S BLDLOGIC=1 - ..D CDUE - .;Dialog - .I OPTION="D" D - ..D DIALOG - .;Web addresses - .I OPTION="W" D - ..D WEB - .;If necessary build the internal logic strings. - .I BLDLOGIC D BLDALL^PXRMLOGX(DA,"","") - ;See if any changes have been made. - S CS2=$$FILE^PXRMEXCS(811.9,DA) - I CS2=0 Q - ;If the file has been edited, do the edit history. - I CS2'=CS1 D SEHIST^PXRMUTIL(811.9,DIC,DA) - Q - ; - ;Reminder Edit - ;------------- -EDIT(ROOT,DA) ; - N DIC,DIDEL,DIE,DR,RESULT - S DIE=ROOT,DIDEL=811.9 - ;Edit the fields in the same order they are printed by a reminder - ;inquiry. - ;Reminder name - W !! - S DR=".01" - D ^DIE - ;If DA is undefined then the entry was deleted and we are done. - I '$D(DA) S DTOUT=1 Q - I $D(Y) S DTOUT=1 Q - ; - ;Other fields - D GEN Q:$D(Y) - D BASE Q:$D(Y) - D FIND(.LIST) Q:$D(Y) - D FFIND Q:$D(Y) - D LOGIC Q:$D(Y) - D DIALOG Q:$D(Y) - D WEB Q:$D(Y) - Q - ; -GEN ;Print name - W !! - S DR="1.2" - D ^DIE - I $D(Y) Q - ; -CLASS ; - ;Class - W !! - S DR="100" - D ^DIE - I $D(Y) Q - ;Sponsor - S DR="101" - D ^DIE - I $D(Y) Q - ;Make sure Class and Sponsor Class are in synch. - S RESULT=$$VSPONSOR^PXRMINTR(X) - I RESULT=0 G CLASS - ;Review date, Usage - S DR="102;103" - D ^DIE - I $D(Y) Q - ; - ;Related VA-* reminder - W !! - S DR="1.4" - D ^DIE - I $D(Y) Q - ; - ;Inactive flag - W !! - S DR="1.6" - D ^DIE - I $D(Y) Q - ;Ignore on N/A - S DR=1.8 - D ^DIE - I $D(Y) Q - ; - ;Recision Date - S DR="69" - D ^DIE - I $D(Y) Q - ; - ;Reminder description - W !! - S DR="2" - D ^DIE - I $D(Y) Q - ; - ;Technical description - W !! - S DR="3" - D ^DIE - ; - ;Priority - W !! - S DR="1.91" - D ^DIE - Q - ; -BASE W !!,"Baseline Frequency" - ;Do in advance time frame - S DR=1.3 - D ^DIE - I $D(Y) Q - ; - ;Sex specific - S DR=1.9 - D ^DIE - I $D(Y) Q -FARS ; - W !!,"Baseline frequency age range set" - S DR="7" - S DR(2,811.97)=".01;1;2;3;4" - D ^DIE - I $$OVLAP^PXRMAGE G FARS - D SNMLA^PXRMFNFT(DA) - Q - ; -FIND(LIST) ;Edit findings (multiple) - D FIND^PXRMREDF(.LIST) - D SNMLF^PXRMFNFT(DA,20) - Q - ; -FFIND W !!,"Function Findings" - D FFIND^PXRMREDF - D SNMLF^PXRMFNFT(DA,25) - Q - ; -LOGIC W !!,"Patient Cohort and Resolution Logic" - S DR="30T;60T;61T;70T;71T;34T;65T;66T;75T;76T" - D ^DIE - ;Make sure the Patient Cohort Logic at least contains the default. - I $G(^PXD(811.9,DA,31))="" D - . S ^PXD(811.9,DA,31)="(SEX)&(AGE)" - . S ^PXD(811.9,DA,32)="2"_U_"SEX;AGE" - D SNMLL^PXRMFNFT(DA) - Q -CDUE W !!,"Custom Date Due" - S DR=45 - D ^DIE - Q - ; -DIALOG W !!,"Reminder Dialog" - S DR="51" - D ^DIE - Q - ; -WEB W !!,"Web Addresses for Reminder Information" - S DR="50" - D ^DIE - Q - ; - ;Get full list of findings - ;------------------------- -LIST(GBL,DA,ARRAY) ; - N CNT,DATA,GLOB,IEN,NAME,NODE,SUB,TYPE - ;Clear passed arrays - K ARRAY - S CNT=0 - ;Build cross reference global to file number - ;Get each finding - S SUB=0 F S SUB=$O(@GBL@(DA,20,SUB)) Q:'SUB D - .S DATA=$G(@GBL@(DA,20,SUB,0)) I DATA="" Q - .;Determine global and global ien - .S NODE=$P(DATA,U),GLOB=$P(NODE,";",2),IEN=$P(NODE,";") - .;Ignore null entries - .I (GLOB="")!(IEN="") Q - .;Work out the file type - .S TYPE=$G(DEF1(GLOB)) Q:TYPE="" - .S CNT=CNT+1 - .I $P($G(@(U_GLOB_IEN_",0)")),U)="" D - ..W !,"**WARNING** Finding #"_SUB_" does not exist, select finding `"_SUB_" to edit it." Q - .E S NAME=$P($G(@(U_GLOB_IEN_",0)")),U) S ARRAY(TYPE,NAME,SUB)=IEN - .;E S NAME=$P($G(@(U_GLOB_IEN_",0)")),U) S ARRAY(TYPE,NAME,SUB)=$G(SUB) - Q - ; - ;Choose which part of Reminder to edit - ;------------------------------------- -OPTION N DIR,X,Y - ;Display warning message if un-mapped terms exist - K DIROUT,DIRUT,DTOUT,DUOUT - S DIR(0)="SO"_U - S DIR(0)=DIR(0)_"A:All reminder details;" - S DIR(0)=DIR(0)_"G:General;" - S DIR(0)=DIR(0)_"B:Baseline Frequency;" - S DIR(0)=DIR(0)_"F:Findings;" - S DIR(0)=DIR(0)_"FF:Function Findings;" - S DIR(0)=DIR(0)_"L:Logic;" - S DIR(0)=DIR(0)_"C:Custom date due;" - S DIR(0)=DIR(0)_"D:Reminder Dialog;" - S DIR(0)=DIR(0)_"W:Web Addresses;" - S DIR("A")="Select section to edit" - S DIR("?")="Select which section of the reminder you wish to edit." - S DIR("??")="^D HELP^PXRMREDF(2)" - D ^DIR K DIR - I Y="" S DUOUT=1 Q - I $D(DIROUT) S DTOUT=1 - I $D(DTOUT)!$D(DUOUT) Q - S OPTION=Y - 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 - S IND=0,NAME="" - F S NAME=$O(LIST("RT",NAME)) Q:NAME="" D - . S IND=IND+1 - . S NAMELIST(IND)=$$RJ^XLFSTR(IND,3)_" "_NAME - . S SUB=$O(LIST("RT",NAME,"")) - . S IENLIST(IND)=LIST("RT",NAME,SUB) - M DIR("A")=NAMELIST - S DIR("A")="Enter your list" - S DIR(0)="LO^1:"_IND - W !!,"Select term(s) for finding edit:" - D ^DIR - I $D(DIROUT)!$D(DIRUT) S LIST="" Q - I $D(DUOUT)!$D(DTOUT) S LIST="" Q - F IND=1:1:$L(Y,",")-1 D - . S JND=$P(Y,",",IND) - . S NAME=$P(NAMELIST(JND),JND,2) - . W !!,"Reminder Term:",NAME - . D TMAP^PXRMREDF(DA,IENLIST(JND)) - Q - ; +PXRMREDT ; SLC/PKR,PJH - Edit PXRM reminder definition. ;02/09/2006 + ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21 + ; + ;======================================================= +EEDIT ;Entry point for PXRM DEFINITION EDIT option. + ;Build list of finding file definitions. + N DEF,DEF1,DEF2 + D DEF^PXRMRUTL("811.902",.DEF,.DEF1,.DEF2) + ; + N DA,DIC,DLAYGO,DTOUT,DUOUT,Y + S DIC="^PXD(811.9," + S DIC(0)="AEMQL" + S DIC("A")="Select Reminder Definition: " + S DLAYGO=811.9 +GETNAME ;Get the name of the reminder definition to edit. + ;Set the starting place for additions. + D SETSTART^PXRMCOPY(DIC) + W ! + D ^DIC + I ($D(DTOUT))!($D(DUOUT)) Q + I Y=-1 G END + S DA=$P(Y,U,1) + D ALL(DIC,DA) + G GETNAME +END ; + Q + ; + ;======================================================= + ;Select section of reminder to edit, also called at ALL by PXRMEDIT. + ;---------------------------------- +ALL(DIC,DA) ; + ;Get list of findings/terms for reminder + N BLDLOGIC,CS1,CS2,LIST,NODE,OPTION,TYPE + S BLDLOGIC=0 + ;Save the original checksum. + S CS1=$$FILE^PXRMEXCS(811.9,DA) + ;Build finding list + S NODE="^PXD(811.9)" + D LIST(NODE,DA,.LIST) + ;If this is a new reminder enter all fields + I $P(Y,U,3)=1 D EDIT(DIC,DA) Q + ;National reminder allows editing of term findings only + I '$$VEDIT^PXRMUTIL(DIC,DA) D Q:$D(DUOUT)!$D(DTOUT) + .S TYPE="" + .F S TYPE=$O(LIST(TYPE)) Q:TYPE="" D + .. I TYPE="RT" Q + .. K LIST(TYPE) + .I '$D(LIST) S DUOUT=1 Q + .S BLDLOGIC=1 + .D TFIND(DA,.LIST) + .I $D(Y) S DUOUT=1 + ;Otherwise choose fields to edit + I $$VEDIT^PXRMUTIL(DIC,DA) F D Q:$D(DUOUT)!$D(DTOUT) + .D OPTION Q:$D(DUOUT)!$D(DTOUT) + .;All details + .I OPTION="A" D + .. S BLDLOGIC=1 + .. D EDIT(DIC,DA) + .;Set up local variables + .N DIE,DR S DIE=DIC N DIC + .;Descriptions + .I OPTION="G" D + ..D GEN + .;Baseline Frequency + .I OPTION="B" D + ..S BLDLOGIC=1 + ..D BASE + .;Findings + .I OPTION="F" D + ..S BLDLOGIC=1 + ..D FIND(.LIST) + .;Function findings + .I OPTION="FF" D + ..S BLDLOGIC=1 + ..D FFIND + .;Logic + .I OPTION="L" D + ..S BLDLOGIC=1 + ..D LOGIC + .;Custom date due + . I OPTION="C" D + ..S BLDLOGIC=1 + ..D CDUE + .;Dialog + .I OPTION="D" D + ..D DIALOG + .;Web addresses + .I OPTION="W" D + ..D WEB + .;If necessary build the internal logic strings. + .I BLDLOGIC D BLDALL^PXRMLOGX(DA,"","") + ;See if any changes have been made. + S CS2=$$FILE^PXRMEXCS(811.9,DA) + I CS2=0 Q + ;If the file has been edited, do the edit history. + I CS2'=CS1 D SEHIST^PXRMUTIL(811.9,DIC,DA) + Q + ; + ;Reminder Edit + ;------------- +EDIT(ROOT,DA) ; + N DIC,DIDEL,DIE,DR,RESULT + S DIE=ROOT,DIDEL=811.9 + ;Edit the fields in the same order they are printed by a reminder + ;inquiry. + ;Reminder name + W !! + S DR=".01" + D ^DIE + ;If DA is undefined then the entry was deleted and we are done. + I '$D(DA) S DTOUT=1 Q + I $D(Y) S DTOUT=1 Q + ; + ;Other fields + D GEN Q:$D(Y) + D BASE Q:$D(Y) + D FIND(.LIST) Q:$D(Y) + D FFIND Q:$D(Y) + D LOGIC Q:$D(Y) + D DIALOG Q:$D(Y) + D WEB Q:$D(Y) + Q + ; +GEN ;Print name + W !! + S DR="1.2" + D ^DIE + I $D(Y) Q + ; +CLASS ; + ;Class + W !! + S DR="100" + D ^DIE + I $D(Y) Q + ;Sponsor + S DR="101" + D ^DIE + I $D(Y) Q + ;Make sure Class and Sponsor Class are in synch. + S RESULT=$$VSPONSOR^PXRMINTR(X) + I RESULT=0 G CLASS + ;Review date, Usage + S DR="102;103" + D ^DIE + I $D(Y) Q + ; + ;Related VA-* reminder + W !! + S DR="1.4" + D ^DIE + I $D(Y) Q + ; + ;Inactive flag + W !! + S DR="1.6" + D ^DIE + I $D(Y) Q + ;Ignore on N/A + S DR=1.8 + D ^DIE + I $D(Y) Q + ; + ;Recision Date + S DR="69" + D ^DIE + I $D(Y) Q + ; + ;Reminder description + W !! + S DR="2" + D ^DIE + I $D(Y) Q + ; + ;Technical description + W !! + S DR="3" + D ^DIE + ; + ;Priority + W !! + S DR="1.91" + D ^DIE + Q + ; +BASE W !!,"Baseline Frequency" + ;Do in advance time frame + S DR=1.3 + D ^DIE + I $D(Y) Q + ; + ;Sex specific + S DR=1.9 + D ^DIE + I $D(Y) Q +FARS ; + W !!,"Baseline frequency age range set" + S DR="7" + S DR(2,811.97)=".01;1;2;3;4" + D ^DIE + I $$OVLAP^PXRMAGE G FARS + D SNMLA^PXRMFNFT(DA) + Q + ; +FIND(LIST) ;Edit findings (multiple) + D FIND^PXRMREDF(.LIST) + D SNMLF^PXRMFNFT(DA,20) + Q + ; +FFIND W !!,"Function Findings" + D FFIND^PXRMREDF + D SNMLF^PXRMFNFT(DA,25) + Q + ; +LOGIC W !!,"Patient Cohort and Resolution Logic" + S DR="30T;60T;61T;70T;71T;34T;65T;66T;75T;76T" + D ^DIE + ;Make sure the Patient Cohort Logic at least contains the default. + I $G(^PXD(811.9,DA,31))="" D + . S ^PXD(811.9,DA,31)="(SEX)&(AGE)" + . S ^PXD(811.9,DA,32)="2"_U_"SEX;AGE" + D SNMLL^PXRMFNFT(DA) + Q +CDUE W !!,"Custom Date Due" + S DR=45 + D ^DIE + Q + ; +DIALOG W !!,"Reminder Dialog" + S DR="51" + D ^DIE + Q + ; +WEB W !!,"Web Addresses for Reminder Information" + S DR="50" + D ^DIE + Q + ; + ;Get full list of findings + ;------------------------- +LIST(GBL,DA,ARRAY) ; + N CNT,DATA,GLOB,IEN,NAME,NODE,SUB,TYPE + ;Clear passed arrays + K ARRAY + S CNT=0 + ;Build cross reference global to file number + ;Get each finding + S SUB=0 F S SUB=$O(@GBL@(DA,20,SUB)) Q:'SUB D + .S DATA=$G(@GBL@(DA,20,SUB,0)) I DATA="" Q + .;Determine global and global ien + .S NODE=$P(DATA,U),GLOB=$P(NODE,";",2),IEN=$P(NODE,";") + .;Ignore null entries + .I (GLOB="")!(IEN="") Q + .;Work out the file type + .S TYPE=$G(DEF1(GLOB)) Q:TYPE="" + .S CNT=CNT+1 + .I $P($G(@(U_GLOB_IEN_",0)")),U)="" D + ..W !,"**WARNING** Finding #"_SUB_" does not exist, select finding `"_SUB_" to edit it." Q + .E S NAME=$P($G(@(U_GLOB_IEN_",0)")),U) S ARRAY(TYPE,NAME,SUB)=IEN + .;E S NAME=$P($G(@(U_GLOB_IEN_",0)")),U) S ARRAY(TYPE,NAME,SUB)=$G(SUB) + Q + ; + ;Choose which part of Reminder to edit + ;------------------------------------- +OPTION N DIR,X,Y + ;Display warning message if un-mapped terms exist + K DIROUT,DIRUT,DTOUT,DUOUT + S DIR(0)="SO"_U + S DIR(0)=DIR(0)_"A:All reminder details;" + S DIR(0)=DIR(0)_"G:General;" + S DIR(0)=DIR(0)_"B:Baseline Frequency;" + S DIR(0)=DIR(0)_"F:Findings;" + S DIR(0)=DIR(0)_"FF:Function Findings;" + S DIR(0)=DIR(0)_"L:Logic;" + S DIR(0)=DIR(0)_"C:Custom date due;" + S DIR(0)=DIR(0)_"D:Reminder Dialog;" + S DIR(0)=DIR(0)_"W:Web Addresses;" + S DIR("A")="Select section to edit" + S DIR("?")="Select which section of the reminder you wish to edit." + S DIR("??")="^D HELP^PXRMREDF(2)" + D ^DIR K DIR + I Y="" S DUOUT=1 Q + I $D(DIROUT) S DTOUT=1 + I $D(DTOUT)!$D(DUOUT) Q + S OPTION=Y + Q + ; + ;------------------------------------- +TFIND(DA,LIST) ;Allow edit of term findings for national reminders. + N DIR,IENLIST,IND,NAME,NAMELIST,SUB,X,Y + S IND=0,NAME="" + F S NAME=$O(LIST("RT",NAME)) Q:NAME="" D + . S IND=IND+1 + . S NAMELIST(IND)=$$RJ^XLFSTR(IND,3)_" "_NAME + . S SUB=$O(LIST("RT",NAME,"")) + . S IENLIST(IND)=LIST("RT",NAME,SUB) + M DIR("A")=NAMELIST + S DIR("A")="Enter your list" + S DIR(0)="LO^1:"_IND + W !!,"Select term(s) for finding edit:" + D ^DIR + 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 NAME=$P(NAMELIST(IND),IND,2) + . W !!,"Reminder Term:",NAME + . D TMAP^PXRMREDF(DA,IENLIST(IND)) + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMRPCC.m b/r/CLINICAL_REMINDERS-PXRM/PXRMRPCC.m index 23c2e20f..f3a0381c 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMRPCC.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMRPCC.m @@ -1,150 +1,145 @@ -PXRMRPCC ;SLC/PJH - PXRM REMINDER DIALOG ;11/26/2007 - ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123 - ; -ACTIVE(ORY,ORREM) ;Check if active dialog exist for reminders - ; - ; input parameter ORREM is array of reminder ien [.01#811.9] - N DDIS,DIEN,OCNT,RIEN,RSTA - S OCNT=0,RIEN=0 - ;Get reminder ien from array - F S RIEN=$O(ORREM(RIEN)) Q:'RIEN D - .;Dialog ien for reminder - .S DIEN=$P($G(^PXD(811.9,RIEN,51)),U),RSTA=0 - .;Dialog status - .I DIEN S DDIS=$P($G(^PXRMD(801.41,DIEN,0)),U,3) - .;If dialog and dialog not disabled - .I DIEN,DDIS="" S RSTA=1 - .;Return reminder and if active dialog exists - .S OCNT=OCNT+1,ORY(OCNT)=RIEN_U_RSTA - Q - ; - ; -DIALOG(ORY,ORREM,DFN) ;Load reminder dialog associated with the reminder - ; - ; input parameter ORREM - reminder ien [.01,#811.9] - ; - S RIEN=ORREM - N DATA,DIEN - S DIEN=$G(^PXD(811.9,ORREM,51)) - ; - ;Quit if no dialog for this reminder - I 'DIEN S ORY(1)="-1^no dialog for this reminder" Q - ; - ;Check if a reminder dialog and enabled - S DATA=$G(^PXRMD(801.41,DIEN,0)) - ; - I $P(DATA,U,4)'="R" S ORY(1)="-1^reminder dialog invalid" Q - ; - I $P(DATA,U,3) S ORY(1)="-1^reminder dialog disabled" Q - ; - ;Load dialog lines into local array - S ORY(0)=0_U_+$P($G(^PXRMD(801.41,DIEN,0)),U,17) - D LOAD^PXRMDLL(DIEN,$G(DFN)) - Q - ; -HDR(ORY,ORLOC) ;Progress Note Header by location/service/user - N ORSRV,PASS - ;S ORSRV=$G(^VA(200,DUZ,5)) I +ORSRV>0 S ORSRV=$P(ORSRV,U) - S ORSRV=$$GET1^DIQ(200,DUZ,29,"I") - S PASS=DUZ_";VA(200," - I +$G(ORLOC) S PASS=PASS_"^LOC.`"_ORLOC - I ORSRV>0 S PASS=PASS_"^SRV.`"_+$G(ORSRV) - S ORY=$$GET^XPAR(PASS_"^DIV^SYS^PKG","PXRM PROGRESS NOTE HEADERS",1,"Q") - Q - ; -PROMPT(ORY,ORDLG,ORDCUR,ORFTYP) ;Load additional prompts for a dialog element - ; - ; input parameters - ; - ; ORDLG - dialog element ien [.01,#801.41] - ; ORDCUR - 0 = current, 1 = Historical for taxonomies only - ; ORFTYP - finding type (CPT/POV) for taxonomies only - ; - ; These fields can be found in the output array of DIALOG^PXRMRPCC - ; - D LOAD^PXRMDLLA(ORDLG,ORDCUR,$G(ORFTYP)) - Q - ; -RES(ORY,ORREM) ; Reminder Resources/Inquiry - ; - ; input parameter ORREM - reminder ien [.01,#811.9] - ; - D REMVAR^PXRMINQ(.ORY,ORREM) - Q - ; -MH(ORY,OTEST) ; Mental Health dialog - ; - ; Input mental health instrument NAME - ; - K ^TMP($J,"YSQU") - N ARRAY,CNT,CNT1,FNODE,FSUB,IC,NODE,OCNT,SUB,YS - ;DBIA #5056 - S YS("CODE")=OTEST D SHOWALL^YTQPXRM5(.ARRAY,.YS) - S OCNT=0,CNT=0 - S SUB="ARRAY",OCNT=0 - F S SUB=$Q(@SUB) Q:SUB="" D - .S FSUB=$P($P(SUB,"(",2),")"),FNODE="" - .F IC=1:1 S NODE=$P(FSUB,",",IC) Q:NODE="" D - ..I $E(NODE)="""" S NODE=$P(NODE,"""",2) - ..S $P(FNODE,";",IC)=NODE - .Q:FNODE="" - .S OCNT=OCNT+1,ORY(OCNT)=FNODE_U_@SUB - Q - ; -MHR(ORY,RESULT,ORES) ; Mental Health score and P/N text - ; - ; Input MH result IEN and mental health instrument response - ; - D START^PXRMDLR(.ORY,RESULT,.ORES) - ; - Q - ; -MHS(ORY,YS) ; Mental Health save response - ; - ; Input mental health instrument response - N ANS,ARRAY,X - S ANS=$G(YS("R1")) K YS("R1") - S YS("ADATE")=YS("ADATE")_"."_$P($$NOW^XLFDT,".",2) - F X=1:1:$L(ANS) I $E(ANS,X)'="X" S YS(X)=X_U_$E(ANS,X) - ;DBIA #4463 - D SAVECR^YTQPXRM4(.ARRAY,.YS) - Q - ; -MST(ORY,DFN,DGMSTDT,DGMSTSC,DGMSTPR,FTYP,FIEN,RESULT) ; File MST status - ;This is obsolete and can be removed when the GUI is changed not - ;to use it. - Q - ; -WH(ORY,RESULT) ; - N CNT,CNT1,CNT2,NODE,PIECNT,PUR,TYPE,TYP1,WVIEN,WVRESULT,WVNOT,WVPURIEN - N PRINT - K ^TMP("WV RPT",$J) - I '$D(RESULT) Q - S (CNT2,WVPURIEN,PUR)=0 - S CNT=0 F S CNT=$O(RESULT(CNT)) Q:CNT="" D - . I $P($G(RESULT(CNT)),U)["WHIEN" D - . . S CNT2=CNT2+1 - . . S WVIEN=$P($P($G(RESULT(CNT)),U),":",2),WVRESULT(CNT2)=$G(WVIEN) - . . S WVRESULT(CNT2)=WVRESULT(CNT2)_U_$P($P($G(RESULT(CNT)),U,3),":",2) - . I $P($G(RESULT(CNT)),U)["WHPur" D - . . S NODE=$G(RESULT(CNT)),PUR=$P($P($G(NODE),U),":",2) - . . S CNT1=1,TYPE=$P($G(NODE),U,2) - . . I TYPE'[":" D - ...S WVNOT(PUR,CNT1)=$P($G(NODE),U,5)_U_$P($G(NODE),U,2)_U_$P($G(NODE),U,3)_U_$P($P($G(NODE),U,4),":",2) - ..I TYPE[":" D - ...S PIECNT=0 - ...F X=1:1:$L(TYPE) I $E(TYPE,X)=":" S PIECNT=PIECNT+1 I PIECNT>0 D - ....S PRINT="" - ....S TYP1=$P($G(TYPE),":",PIECNT) - ....I TYP1="L" S PRINT=$P($G(NODE),U,3) - ....S WVNOT(PUR,CNT1)=$P($G(NODE),U,5)_U_$G(TYP1)_U_$G(PRINT)_U_$P($P($G(NODE),U,4),":",2),CNT1=CNT1+1 - ...S PIECNT=PIECNT+1 - ...S PRINT="" - ...S TYP1=$P($G(TYPE),":",PIECNT) - ...I TYP1="L" S PRINT=$P($G(NODE),U,3) - ...S WVNOT(PUR,CNT1)=$P($G(NODE),U,5)_U_$G(TYP1)_U_$G(PRINT)_U_$P($P($G(NODE),U,4),":",2) - K WHMUFIND,WHFIND,WHNAME - ;DBIA #4104 - D NEW^WVRPCNO(.WVRESULT,.WVNOT) - Q - ; +PXRMRPCC ;SLC/PJH - PXRM REMINDER DIALOG ;04/12/2002 + ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005 + ; +ACTIVE(ORY,ORREM) ;Check if active dialog exist for reminders + ; + ; input parameter ORREM is array of reminder ien [.01#811.9] + N DDIS,DIEN,OCNT,RIEN,RSTA + S OCNT=0,RIEN=0 + ;Get reminder ien from array + F S RIEN=$O(ORREM(RIEN)) Q:'RIEN D + .;Dialog ien for reminder + .S DIEN=$P($G(^PXD(811.9,RIEN,51)),U),RSTA=0 + .;Dialog status + .I DIEN S DDIS=$P($G(^PXRMD(801.41,DIEN,0)),U,3) + .;If dialog and dialog not disabled + .I DIEN,DDIS="" S RSTA=1 + .;Return reminder and if active dialog exists + .S OCNT=OCNT+1,ORY(OCNT)=RIEN_U_RSTA + Q + ; + ; +DIALOG(ORY,ORREM,DFN) ;Load reminder dialog associated with the reminder + ; + ; input parameter ORREM - reminder ien [.01,#811.9] + ; + S RIEN=ORREM + N DATA,DIEN + S DIEN=$G(^PXD(811.9,ORREM,51)) + ; + ;Quit if no dialog for this reminder + I 'DIEN S ORY(1)="-1^no dialog for this reminder" Q + ; + ;Check if a reminder dialog and enabled + S DATA=$G(^PXRMD(801.41,DIEN,0)) + ; + I $P(DATA,U,4)'="R" S ORY(1)="-1^reminder dialog invalid" Q + ; + I $P(DATA,U,3) S ORY(1)="-1^reminder dialog disabled" Q + ; + ;Load dialog lines into local array + D LOAD^PXRMDLL(DIEN,$G(DFN)) + Q + ; +HDR(ORY,ORLOC) ;Progress Note Header by location/service/user + N ORSRV,PASS + ;S ORSRV=$G(^VA(200,DUZ,5)) I +ORSRV>0 S ORSRV=$P(ORSRV,U) + S ORSRV=$$GET1^DIQ(200,DUZ,29,"I") + S PASS=DUZ_";VA(200," + I +$G(ORLOC) S PASS=PASS_"^LOC.`"_ORLOC + I ORSRV>0 S PASS=PASS_"^SRV.`"_+$G(ORSRV) + S ORY=$$GET^XPAR(PASS_"^DIV^SYS^PKG","PXRM PROGRESS NOTE HEADERS",1,"Q") + Q + ; +PROMPT(ORY,ORDLG,ORDCUR,ORFTYP) ;Load additional prompts for a dialog element + ; + ; input parameters + ; + ; ORDLG - dialog element ien [.01,#801.41] + ; ORDCUR - 0 = current, 1 = Historical for taxonomies only + ; ORFTYP - finding type (CPT/POV) for taxonomies only + ; + ; These fields can be found in the output array of DIALOG^PXRMRPCC + ; + D LOAD^PXRMDLLA(ORDLG,ORDCUR,$G(ORFTYP)) + Q + ; +RES(ORY,ORREM) ; Reminder Resources/Inquiry + ; + ; input parameter ORREM - reminder ien [.01,#811.9] + ; + D REMVAR^PXRMINQ(.ORY,ORREM) + Q + ; +MH(ORY,OTEST) ; Mental Health dialog + ; + ; Input mental health instrument NAME + ; + N YS,ARRAY S YS("CODE")=OTEST D SHOWALL^YTAPI3(.ARRAY,.YS) ; DBIA #2895 + ; + N FNODE,FSUB,IC,NODE,OCNT,SUB + S SUB="ARRAY",OCNT=0 + F S SUB=$Q(@SUB) Q:SUB="" D + .S FSUB=$P($P(SUB,"(",2),")"),FNODE="" + .F IC=1:1 S NODE=$P(FSUB,",",IC) Q:NODE="" D + ..I $E(NODE)="""" S NODE=$P(NODE,"""",2) + ..S $P(FNODE,";",IC)=NODE + .Q:FNODE="" + .S OCNT=OCNT+1,ORY(OCNT)=FNODE_U_@SUB + Q + ; +MHR(ORY,RESULT,ORES) ; Mental Health score and P/N text + ; + ; Input MH result IEN and mental health instrument response + ; + D ^PXRMDLR + ; + Q + ; +MHS(ORY,YS) ; Mental Health save response + ; + ; Input mental health instrument response + N ARRAY + D SAVEIT^YTAPI1(.ARRAY,.YS) ; DBIA #2893 + I ARRAY(1)'="[DATA]" S ORY(1)="-1^"_ARRAY(1)_ARRAY(2) + I ARRAY(1)="[DATA]" S ORY(1)=ARRAY(1)_ARRAY(2) + Q + ; +MST(ORY,DFN,DGMSTDT,DGMSTSC,DGMSTPR,FTYP,FIEN,RESULT) ; File MST status + ;This is obsolete and can be removed when the GUI is changed not + ;to use it. + Q + ; +WH(ORY,RESULT) ; + N CNT,CNT1,CNT2,NODE,PIECNT,PUR,TYPE,TYP1,WVIEN,WVRESULT,WVNOT,WVPURIEN + N PRINT + K ^TMP("WV RPT",$J) + I '$D(RESULT) Q + S (CNT2,WVPURIEN,PUR)=0 + S CNT=0 F S CNT=$O(RESULT(CNT)) Q:CNT="" D + . I $P($G(RESULT(CNT)),U)["WHIEN" D + . . S CNT2=CNT2+1 + . . S WVIEN=$P($P($G(RESULT(CNT)),U),":",2),WVRESULT(CNT2)=$G(WVIEN) + . . S WVRESULT(CNT2)=WVRESULT(CNT2)_U_$P($P($G(RESULT(CNT)),U,3),":",2) + . I $P($G(RESULT(CNT)),U)["WHPur" D + . . S NODE=$G(RESULT(CNT)),PUR=$P($P($G(NODE),U),":",2) + . . S CNT1=1,TYPE=$P($G(NODE),U,2) + . . I TYPE'[":" D + ...S WVNOT(PUR,CNT1)=$P($G(NODE),U,5)_U_$P($G(NODE),U,2)_U_$P($G(NODE),U,3)_U_$P($P($G(NODE),U,4),":",2) + ..I TYPE[":" D + ...S PIECNT=0 + ...F X=1:1:$L(TYPE) I $E(TYPE,X)=":" S PIECNT=PIECNT+1 I PIECNT>0 D + ....S PRINT="" + ....S TYP1=$P($G(TYPE),":",PIECNT) + ....I TYP1="L" S PRINT=$P($G(NODE),U,3) + ....S WVNOT(PUR,CNT1)=$P($G(NODE),U,5)_U_$G(TYP1)_U_$G(PRINT)_U_$P($P($G(NODE),U,4),":",2),CNT1=CNT1+1 + ...S PIECNT=PIECNT+1 + ...S PRINT="" + ...S TYP1=$P($G(TYPE),":",PIECNT) + ...I TYP1="L" S PRINT=$P($G(NODE),U,3) + ...S WVNOT(PUR,CNT1)=$P($G(NODE),U,5)_U_$G(TYP1)_U_$G(PRINT)_U_$P($P($G(NODE),U,4),":",2) + K WHMUFIND,WHFIND,WHNAME + ;DBIA #4104 + D NEW^WVRPCNO(.WVRESULT,.WVNOT) + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMRUL1.m b/r/CLINICAL_REMINDERS-PXRM/PXRMRUL1.m index fb4bd408..4851e27a 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMRUL1.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMRUL1.m @@ -1,229 +1,99 @@ -PXRMRUL1 ; SLC/AGP,PKR - Patient list routines. ; 03/29/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ; -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. - I TFIEV(1)=0 Q - N DATA,DONE,IND,LEN,REF,ROOT,START,SUB,TEMP - S REF="TFIEV(1,""CSUB"")" - 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)-1 - . S IND=$E(REF,START,LEN) - . S DATA(TNAME_IND)=@REF - . S REF=$Q(@REF) - . I REF'[ROOT S DONE=1 - I $D(DATA) M ^TMP($J,FROUT,DFN,"DATA")=DATA - Q - ; -INST(DFN) ;Get the PCMM Institution. - N DATE,INST - ;Check PCMM - S DATE=$S($G(PXRMDATE)'="":$P(PXRMDATE,"."),1:DT) - ;DBIA #1916 - S INST=$P($$INSTPCTM^SCAPMC(DFN,DATE),U,3,4) - 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 - N DFN1,DFN2 - I LOGOP="&" D Q - . S DFN1="" - . F S DFN1=$O(^TMP($J,LIST1,DFN1)) Q:DFN1="" D - .. I $D(^TMP($J,LIST2,DFN1)) M ^TMP($J,LIST1,DFN1)=^TMP($J,LIST2,DFN1) Q - .. K ^TMP($J,LIST1,DFN1) - ; - ;"~" represents "&'". - I LOGOP="~" D Q - . S DFN1="" - . F S DFN1=$O(^TMP($J,LIST1,DFN1)) Q:DFN1="" D - .. I $D(^TMP($J,LIST2,DFN1)) K ^TMP($J,LIST1,DFN1) - ; - I LOGOP="!" D - . S DFN2="" - . F S DFN2=$O(^TMP($J,LIST2,DFN2)) Q:DFN2="" D - .. M ^TMP($J,LIST1,DFN2)=^TMP($J,LIST2,DFN2) - 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) - ;Remove, Select or Add Findings operations - I FRACT="A" D LOGOP(FROUT,PNODE,"!") Q - I FRACT="D" D LOGOP(FROUT,PNODE,"~") Q - I FRACT="S" 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 - ;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) - S $P(FINDPA(0),U,8)=RSTART,$P(FINDPA(0),U,11)=RSTOP,PXRMDATE=RSTOP - ; - ;Add operation - I FRACT="A" D Q - .;Process term for date range - .D EVALPL^PXRMTERL(.FINDPA,.TERMARR,PNODE) - .;Merge lists if operation is add - .M ^TMP($J,FROUT)=^TMP($J,PNODE,1) - ;Remove, Select or Insert Findings operations - I FRACT="F" S PXRMDEBG=1 - S DFN=0 - F S DFN=$O(^TMP($J,FROUT,DFN)) Q:'DFN D - .I INST S ^TMP($J,FROUT,DFN,"INST")=$$INST(DFN) Q - .;Evaluate term - .K TFIEV D IEVALTER^PXRMTERM(DFN,.FINDPA,.TERMARR,1,.TFIEV) - .;Delete any ^TMP patient in PLIST if action is remove - .I FRACT="R",TFIEV(1) K ^TMP($J,FROUT,DFN) Q - .;Delete any ^TMP patient not in PLIST if action is select - .I FRACT="S",'TFIEV(1) K ^TMP($J,FROUT,DFN) Q - .I FRACT="F",TFIEV(1) D - .. S FINDING=TFIEV(1,"FINDING") - .. I '$D(FNAME(FINDING)) S FNAME(FINDING)=$$GETFNAME^PXRMDATA(FINDING) - .. S TFIEV(1,"CSUB","FINDING NAME")=FNAME(FINDING) - .. D INSERT(FROUT,DFN,TNAME,.TFIEV,RSTOP) - Q - ; -UNLOCK L -^PXRMXP(810.5,LIST) Q - ; +PXRMRUL1 ; SLC/AGP,PKR - Patient list routines. ; 08/11/2006 + ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21 + ; +DATECHK(DATE) ; + I DATE=0 Q 1 + S DATE=$$STRREP^PXRMUTIL(DATE,"BDT","T") + Q $$VDT^PXRMINTR(DATE) + ; +INSERT(FROUT,DFN,TNAME,TFIEV,RSTOP) ;Save patient data. + I TFIEV(1)=0 Q + N DATA,DONE,IND,LEN,REF,ROOT,START,SUB,TEMP + S REF="TFIEV(1,""CSUB"")" + 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)-1 + . S IND=$E(REF,START,LEN) + . S DATA(TNAME_IND)=@REF + . S REF=$Q(@REF) + . I REF'[ROOT S DONE=1 + I $D(DATA) M ^TMP($J,FROUT,DFN,"DATA")=DATA + Q + ; +INST(DFN) ;Get the PCMM Institution. + N DATE,INST + ;Check PCMM + S DATE=$S($G(PXRMDATE)'="":$P(PXRMDATE,"."),1:DT) + ;DBIA #1916 + S INST=$P($$INSTPCTM^SCAPMC(DFN,DATE),U,3,4) + Q INST + ; +LOGOP(LIST1,LIST2,LOGOP) ;Given LIST1 and LIST2 apply the logical + ;operator LOGOP to generate a new list and return it in LIST1 + N DFN1,DFN2 + I LOGOP="&" D Q + . S DFN1="" + . F S DFN1=$O(^TMP($J,LIST1,DFN1)) Q:DFN1="" D + .. I $D(^TMP($J,LIST2,DFN1)) M ^TMP($J,LIST1,DFN1)=^TMP($J,LIST2,DFN1) Q + .. K ^TMP($J,LIST1,DFN1) + ; + ;"~" represents "&'". + I LOGOP="~" D Q + . S DFN1="" + . F S DFN1=$O(^TMP($J,LIST1,DFN1)) Q:DFN1="" D + .. I $D(^TMP($J,LIST2,DFN1)) K ^TMP($J,LIST1,DFN1) + ; + I LOGOP="!" D + . S DFN2="" + . F S DFN2=$O(^TMP($J,LIST2,DFN2)) Q:DFN2="" D + .. M ^TMP($J,LIST1,DFN2)=^TMP($J,LIST2,DFN2) + Q + ; +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 + I FRACT="D" D LOGOP(FROUT,PNODE,"~") Q + I FRACT="S" D LOGOP(FROUT,PNODE,"&") Q + Q + ; +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 start and end dates + S $P(FINDPA(0),U,8)=RSTART,$P(FINDPA(0),U,11)=RSTOP,PXRMDATE=RSTOP + ; + ;Add operation + I FRACT="A" D Q + .;Process term for date range + .D EVALPL^PXRMTERM(.FINDPA,.TERMARR,PNODE) + .;Merge lists if operation is add + .M ^TMP($J,FROUT)=^TMP($J,PNODE,1) + ;Remove, Select or Insert Findings operations + I FRACT="F" S PXRMDEBG=1 + S DFN=0 + F S DFN=$O(^TMP($J,FROUT,DFN)) Q:'DFN D + .I INST S ^TMP($J,FROUT,DFN,"INST")=$$INST(DFN) Q + .;Evaluate term + .K TFIEV D IEVALTER^PXRMTERM(DFN,.FINDPA,.TERMARR,1,.TFIEV) + .;Delete any ^TMP patient in PLIST if action is remove + .I FRACT="R",TFIEV(1) K ^TMP($J,FROUT,DFN) Q + .;Delete any ^TMP patient not in PLIST if action is select + .I FRACT="S",'TFIEV(1) K ^TMP($J,FROUT,DFN) Q + .I FRACT="F",TFIEV(1) D + .. S FINDING=TFIEV(1,"FINDING") + .. I '$D(FNAME(FINDING)) S FNAME(FINDING)=$$GETFNAME^PXRMDATA(FINDING) + .. S TFIEV(1,"CSUB","FINDING NAME")=FNAME(FINDING) + .. D INSERT(FROUT,DFN,TNAME,.TFIEV,RSTOP) + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMRULE.m b/r/CLINICAL_REMINDERS-PXRM/PXRMRULE.m index c7efdf5e..934b1725 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMRULE.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMRULE.m @@ -1,221 +1,298 @@ -PXRMRULE ; SLC/PJH - Build Patient list from Rule Set ;03/27/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ; Called from PXRM PATIENT LIST CREATE protocol - ; -CLEAR(RULE,NODE) ;Clear workfile entries - N SEQ - S SEQ="" - F S SEQ=$O(^PXRM(810.4,RULE,30,"B",SEQ)) Q:'SEQ D - .K ^TMP($J,NODE_SEQ) - ;clear FDA array - K ^TMP($J,"PXRMFDA") - Q - ; -INTR ;Input transform for #810.4 fields - Q - ; -LOAD(NODE,LIEN) ;Load Patient List - N DATA,DFN,SUB - S SUB=0 - F S SUB=$O(^PXRMXP(810.5,LIEN,30,SUB)) Q:'SUB D - .S DATA=$G(^PXRMXP(810.5,LIEN,30,SUB,0)),DFN=$P(DATA,U) Q:'DFN - .;Store the patient IEN and institution in ^TMP - .S ^TMP($J,NODE,DFN)=$P(DATA,U,2)_U_$P($G(DATA),U,3)_U_$P($G(DATA),U,4) - Q - ; -PATS(FRACT,FROUT,PNODE,LIST) ;Process Patient List finding rule - ; - N LIEN,LUVALUE - ;Insert year and period into extract list name - I YEAR]"",LIST["yyyy" S LIST=$P(LIST,"yyyy")_YEAR_$P(LIST,"yyyy",2) - I PERIOD]"",LIST["nn" S LIST=$P(LIST,"nn")_$E(PERIOD,2,10)_$P(LIST,"nn",2) - ; - S LUVALUE(1)=LIST - S LIEN=+$$FIND1^DIC(810.5,"","KUX",.LUVALUE) Q:'LIEN - ; - ;Add operation Load list - 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) ; - ;Process rule set - ;Clear ^TMP - D CLEAR(RULESET,NODE) - ; - N CLASS,FRACT,FRDATA,FRDATES,FRIEN,FRLST,FRLIEN,FROLST,FROUT,FRPAT - N FRPERM,FRSTRT,FRTIEN,FRTYP,FSEQ,INC,INST,PXRMDATE,PXRMDDOC - N RBDT,REDT,RRIEN,RSDATA,RSDATES,SEQ,SUB - ;Get class from extract parameter - I PAR S CLASS=$P($G(^PXRM(810.2,PAR,100)),U) - ;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 - F S SEQ=$O(^PXRM(810.4,RULESET,30,"B",SEQ)) Q:'SEQ D - .;Save first sequence as default - .I INC=0 S INC=1,FSEQ=SEQ - .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 RSDATES=$G(^PXRM(810.4,RULESET,30,SUB,1)) - .;Finding rule ien and action - .S FRIEN=$P(RSDATA,U,2),FRACT=$P(RSDATA,U,3) Q:'FRIEN Q:FRACT="" - .;Check if entry is a finding rule (not a set or reminder rule) - .S FRDATA=$G(^PXRM(810.4,FRIEN,0)),FRTYP=$P(FRDATA,U,3) Q:FRTYP=3 - .S FRDATES=$P(FRDATA,U,4,5) - .;Get term IEN for finding rule - .I FRTYP=1 S FRTIEN=$P(FRDATA,U,7) Q:'FRTIEN - .;Get Reminder definition IEN for Reminder rule - .I FRTYP=2 S RRIEN=$P(FRDATA,U,10) Q:'RRIEN - .;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) - .;Determine RBDT and REDT - .D RDATES^PXRMEUT1(RSDATES,FRDATES,LBBDT,LBEDT,.RBDT,.REDT) - .S PXRMDATE=LBEDT - .;Get start sequence or start patient list - .S FRSTRT=$P(RSDATA,U,4),FRPAT=$P(RSDATA,U,5) - .;If sequence is defined use it - .I FRSTRT S FROUT=NODE_FRSTRT - .;If neither exist use first as default - .I FRSTRT="",FRPAT="" S FROUT=NODE_FSEQ - .;If start is patient list load patient list into workfile - .I FRSTRT="",FRPAT]"" S FROUT=NODE_SEQ D LOAD(FROUT,FRPAT) - .;Name of permanent list - .S FRPERM=$P(RSDATA,U,6) - .; - .;Build patient list in TMP - .N DFN,PNODE,TLIST - .S PNODE="PXRMEVAL" - .K ^TMP($J,PNODE) - .;Term finding rules - .I FRTYP=1 D TERM^PXRMRUL1(FRACT,FRTIEN,LBBDT,LBEDT,RBDT,REDT,PNODE,.INST) - .;Reminder Definition List Rule - .I FRTYP=2 D REM^PXRMRUL1(FRACT,RRIEN,LBBDT,LBEDT,RBDT,REDT,PNODE) - .;Patient list finding rules - .I FRTYP=5 D PATS(FRACT,FROUT,PNODE,FRLST) - .;Clear results file - .K ^TMP($J,PNODE) - .; - .;Build permanent list if required - .I FRPERM]"" D - ..N FRPIEN - ..;Get patient list IEN or create new patient list - ..S FRPIEN=$$CRLST^PXRMRUL1(FRPERM,CLASS) Q:'FRPIEN - ..;Update patient list - ..D UPDLST(FROUT,FRPIEN,PAR,RULESET,INST,INDP,INTP) - ; - ;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 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 - ;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 - ; - ;Clear existing list. - K ^PXRMXP(810.5,LIST,30),^PXRMXP(810.5,LIST,35),^PXRMXP(810.5,LIST,45),^PXRMXP(810.5,LIST,200) - ; - ;Merge ^TMP into Patient List - S (DECEASED,TESTP)="" - S (CNT,DFN)=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 ^PXRMXP(810.5,LIST,30,"B",DFN,CNT)="" - .; - .;Save the reminder evaluation information only from Reports - .I $D(^TMP($J,NODE,DFN,"REM"))>0 D - ..S (RIEN,RCNT,RNCNT)=0 - ..F S RIEN=$O(^TMP($J,NODE,DFN,"REM",RIEN)) Q:RIEN'>0 D - ...S RNAMEL(RIEN)="" - ...S VALUE=^TMP($J,NODE,DFN,"REM",RIEN) - ...S RCNT=RCNT+1 - ...S ^PXRMXP(810.5,LIST,30,CNT,"REM",RCNT,0)=VALUE - ...S ^PXRMXP(810.5,LIST,30,CNT,"REM","B",RIEN,RCNT)="" - ..S ^PXRMXP(810.5,LIST,30,CNT,1,0)=U_"810.532A"_U_RCNT_U_RCNT - .; - .I '$D(^TMP($J,NODE,DFN,"DATA")) Q - .S DCNT=0,DNAME="" - .F S DNAME=$O(^TMP($J,NODE,DFN,"DATA",DNAME)) Q:DNAME="" D - ..S DNAMEL(DNAME)="" - ..S VALUE=^TMP($J,NODE,DFN,"DATA",DNAME) - ..S DCNT=DCNT+1 - ..S ^PXRMXP(810.5,LIST,30,CNT,"DATA",DCNT,0)=DNAME_U_VALUE - ..S ^PXRMXP(810.5,LIST,30,CNT,"DATA","B",DNAME,DCNT)="" - .S ^PXRMXP(810.5,LIST,30,CNT,1,0)=U_"810.531A"_U_DCNT_U_DCNT - S ^PXRMXP(810.5,LIST,30,0)=U_"810.53P"_U_CNT_U_CNT - ; - ;Save the reminder information - S RNCNT=0,RIEN=0 - F S RIEN=$O(RNAMEL(RIEN)) Q:RIEN'>0 D - .S RNCNT=RNCNT+1 - .S ^PXRMXP(810.5,LIST,45,RCNT,0)=RIEN - .S ^PXRMXP(810.5,LIST,45,"B",RIEN,RNCNT)="" - I RNCNT>0 S ^PXRMXP(810.5,LIST,45,0)=U_"810.545P"_U_RNCNT_U_RNCNT - ; - ;Save the data types. - S DCNT=0,DNAME="" - F S DNAME=$O(DNAMEL(DNAME)) Q:DNAME="" D - .S DCNT=DCNT+1 - .S ^PXRMXP(810.5,LIST,35,DCNT,0)=DNAME - .S ^PXRMXP(810.5,LIST,35,"B",DNAME,DCNT)="" - I DCNT>0 S ^PXRMXP(810.5,LIST,35,0)=U_"810.535A"_U_DCNT_U_DCNT - S ^PXRMXP(810.5,LIST,30,0)=U_"810.53P"_U_CNT_U_CNT - ; - ;Update header info - S TYPE=$S($G(PATCREAT)="Y":"PVT",1:"PUB") - K PATCREAT - S FDA(810.5,"?+1,",.01)=NAME - S FDA(810.5,"?+1,",.04)=$$NOW^XLFDT - S FDA(810.5,"?+1,",.05)=EPIEN - S FDA(810.5,"?+1,",.06)=RULE - S FDA(810.5,"?+1,",.07)=$G(DUZ) - S FDA(810.5,"?+1,",.08)=TYPE - I $G(INST)=1 S FDA(810.5,"?+1,",.1)=1 - S FDA(810.5,"?+1,",50)=$S($G(PLISTPUG)="Y":1,1:0) - D UPDATE^DIE("","FDA","","MSG") - ;Error - I $D(MSG) D ERR^PXRMRUL1 - ;Unlock patient list - D UNLOCK^PXRMRUL1 - Q - ; +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 + N SEQ + S SEQ="" + F S SEQ=$O(^PXRM(810.4,RULE,30,"B",SEQ)) Q:'SEQ D + .K ^TMP($J,NODE_SEQ) + ;clear FDA array + K ^TMP($J,"PXRMFDA") + 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 + ; +LOAD(NODE,LIEN) ;Load Patient List + N DATA,DFN,SUB + S SUB=0 + F S SUB=$O(^PXRMXP(810.5,LIEN,30,SUB)) Q:'SUB D + .S DATA=$G(^PXRMXP(810.5,LIEN,30,SUB,0)),DFN=$P(DATA,U) Q:'DFN + .;Store the patient IEN and institution in ^TMP + .S ^TMP($J,NODE,DFN)=$P(DATA,U,2)_U_$P($G(DATA),U,3)_U_$P($G(DATA),U,4) + Q + ; +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 + ;Insert year and period into extract list name + I YEAR]"",LIST["yyyy" S LIST=$P(LIST,"yyyy")_YEAR_$P(LIST,"yyyy",2) + I PERIOD]"",LIST["nn" S LIST=$P(LIST,"nn")_$E(PERIOD,2,10)_$P(LIST,"nn",2) + ; + S LUVALUE(1)=LIST + S LIEN=+$$FIND1^DIC(810.5,"","KUX",.LUVALUE) Q:'LIEN + ; + ;Add operation Load list + I FRACT="A" D LOAD(FROUT,LIEN) Q + ; + ;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 + D CLEAR(RULESET,NODE) + ; + N CLASS,FRACT,FRDATA,FRDATES,FRIEN,FRLST,FRLIEN,FROLST,FROUT,FRPAT + N FRPERM,FRSTRT,FRTIEN,FRTYP,FSEQ,INC,INST,PXRMDATE + N RBDT,REDT,RRIEN,RSDATA,RSDATES,SEQ,SUB + ;Get class from extract parameter + I PAR S CLASS=$P($G(^PXRM(810.2,PAR,100)),U) + ;Otherwise default to local + I $G(CLASS)="" S CLASS="L" + ;Get each finding rule in sequence + S SEQ="",INC=0 + F S SEQ=$O(^PXRM(810.4,RULESET,30,"B",SEQ)) Q:'SEQ D + .;Save first sequence as default + .I INC=0 S INC=1,FSEQ=SEQ + .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 RSDATES=$G(^PXRM(810.4,RULESET,30,SUB,1)) + .;Finding rule ien and action + .S FRIEN=$P(RSDATA,U,2),FRACT=$P(RSDATA,U,3) Q:'FRIEN Q:FRACT="" + .;Check if entry is a finding rule (not a set or reminder rule) + .S FRDATA=$G(^PXRM(810.4,FRIEN,0)),FRTYP=$P(FRDATA,U,3) Q:FRTYP=3 + .S FRDATES=$P(FRDATA,U,4,5) + .;Get term IEN for finding rule + .I FRTYP=1 S FRTIEN=$P(FRDATA,U,7) Q:'FRTIEN + .;Get Reminder definition IEN for Reminder rule + .I FRTYP=2 S RRIEN=$P(FRDATA,U,10) Q:'RRIEN + .;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="" + ..S FROLST=$P(FRDATA,U,8) + ..I +FROLST>0 S FRLST=$P($G(^PXRMXP(810.5,FROLST,0)),U) + .;Determine RBDT and REDT + .D RDATES^PXRMEUT1(RSDATES,FRDATES,LBBDT,LBEDT,.RBDT,.REDT) + .S PXRMDATE=LBEDT + .;Get start sequence or start patient list + .S FRSTRT=$P(RSDATA,U,4),FRPAT=$P(RSDATA,U,5) + .;If sequence is defined use it + .I FRSTRT S FROUT=NODE_FRSTRT + .;If neither exist use first as default + .I FRSTRT="",FRPAT="" S FROUT=NODE_FSEQ + .;If start is patient list load patient list into workfile + .I FRSTRT="",FRPAT]"" S FROUT=NODE_SEQ D LOAD(FROUT,FRPAT) + .;Name of permanent list + .S FRPERM=$P(RSDATA,U,6) + .; + .;Build patient list in TMP + .N DFN,PNODE,TLIST + .S PNODE="PXRMEVAL" + .K ^TMP($J,PNODE) + .;Term finding rules + .I FRTYP=1 D TERM^PXRMRUL1(FRACT,FRTIEN,RBDT,REDT,PNODE,.INST) + .;Reminder Definition List Rule + .I FRTYP=2 D REM^PXRMRUL1(FRACT,RRIEN,RBDT,REDT,PNODE) + .;Patient list finding rules + .I FRTYP=5 D PATS(FRLST) + .;Clear results file + .K ^TMP($J,PNODE) + .; + .;Build permanent list if required + .I FRPERM]"" D + ..N FRPIEN + ..;Get patient list IEN or create new patient list + ..S FRPIEN=$$CRLST(FRPERM,CLASS) Q:'FRPIEN + ..;Update patient list + ..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) + . D DOCUMENT^PXRMEUT(LIST,RULESET,INDP,INTP,LBBDT,LBEDT) + 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 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 (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 CNT=CNT+1,^PXRMXP(810.5,LIST,30,CNT,0)=DFN_U_INSTNUM_U_INSTNAM + .S ^PXRMXP(810.5,LIST,30,"B",DFN,CNT)="" + .; + .;Save the reminder evaluation information only from Reports + .I $D(^TMP($J,NODE,DFN,"REM"))>0 D + ..S (RIEN,RCNT,RNCNT)=0 + ..F S RIEN=$O(^TMP($J,NODE,DFN,"REM",RIEN)) Q:RIEN'>0 D + ...S RNAMEL(RIEN)="" + ...S VALUE=^TMP($J,NODE,DFN,"REM",RIEN) + ...S RCNT=RCNT+1 + ...S ^PXRMXP(810.5,LIST,30,CNT,"REM",RCNT,0)=VALUE + ...S ^PXRMXP(810.5,LIST,30,CNT,"REM","B",RIEN,RCNT)="" + ..S ^PXRMXP(810.5,LIST,30,CNT,1,0)=U_"810.532A"_U_RCNT_U_RCNT + .; + .I '$D(^TMP($J,NODE,DFN,"DATA")) Q + .S DCNT=0,DNAME="" + .F S DNAME=$O(^TMP($J,NODE,DFN,"DATA",DNAME)) Q:DNAME="" D + ..S DNAMEL(DNAME)="" + ..S VALUE=^TMP($J,NODE,DFN,"DATA",DNAME) + ..S DCNT=DCNT+1 + ..S ^PXRMXP(810.5,LIST,30,CNT,"DATA",DCNT,0)=DNAME_U_VALUE + ..S ^PXRMXP(810.5,LIST,30,CNT,"DATA","B",DNAME,DCNT)="" + .S ^PXRMXP(810.5,LIST,30,CNT,1,0)=U_"810.531A"_U_DCNT_U_DCNT + S ^PXRMXP(810.5,LIST,30,0)=U_"810.53P"_U_CNT_U_CNT + ; + ;Save the reminder information + S RNCNT=0,RIEN=0 + F S RIEN=$O(RNAMEL(RIEN)) Q:RIEN'>0 D + .S RNCNT=RNCNT+1 + .S ^PXRMXP(810.5,LIST,45,RCNT,0)=RIEN + .S ^PXRMXP(810.5,LIST,45,"B",RIEN,RNCNT)="" + I RNCNT>0 S ^PXRMXP(810.5,LIST,45,0)=U_"810.545P"_U_RNCNT_U_RNCNT + ; + ;Save the data types. + S DCNT=0,DNAME="" + F S DNAME=$O(DNAMEL(DNAME)) Q:DNAME="" D + .S DCNT=DCNT+1 + .S ^PXRMXP(810.5,LIST,35,DCNT,0)=DNAME + .S ^PXRMXP(810.5,LIST,35,"B",DNAME,DCNT)="" + I DCNT>0 S ^PXRMXP(810.5,LIST,35,0)=U_"810.535A"_U_DCNT_U_DCNT + S ^PXRMXP(810.5,LIST,30,0)=U_"810.53P"_U_CNT_U_CNT + ; + ;Update header info + S TYPE=$S($G(PATCREAT)="Y":"PVT",1:"PUB") + K PATCREAT + S FDA(810.5,"?+1,",.01)=NAME + S FDA(810.5,"?+1,",.04)=$$NOW^XLFDT + S FDA(810.5,"?+1,",.05)=EPIEN + S FDA(810.5,"?+1,",.06)=RULE + S FDA(810.5,"?+1,",.07)=$G(DUZ) + S FDA(810.5,"?+1,",.08)=TYPE + I $G(INST)=1 S FDA(810.5,"?+1,",.1)=1 + S FDA(810.5,"?+1,",50)=$S($G(PLISTPUG)="Y":1,1:0) + D UPDATE^DIE("","FDA","","MSG") + ;Error + I $D(MSG) D ERR + ;Unlock patient list + D UNLOCK + Q + ; +UNLOCK L -^PXRMXP(810.5,LIST) Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMSTA1.m b/r/CLINICAL_REMINDERS-PXRM/PXRMSTA1.m index 6b1365be..a3f60a8a 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMSTA1.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMSTA1.m @@ -1,251 +1,251 @@ -PXRMSTA1 ; SLC/AGP - Routines for building status list. ;09/06/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ;This routine and PXRMSTA2 will allow users to select the - ;approriate status for Orders, Medication, Taxonomy, Problem List, - ;and Radiology Procedure findings items. - ; -CLEAR(GBL,FILE,DA) ; - N IEN,NODE,DIK,TEMP - I FILE="D" S DIK="^PXD(811.9,"_DA(2)_",20,"_DA(1)_",5," - I FILE="T" S DIK="^PXRMD(811.5,"_DA(2)_",20,"_DA(1)_",5," - S DA=0 F S DA=$O(@GBL@(DA(2),20,DA(1),5,DA)) Q:DA'>0 S TEMP(DA)="" - S DA=0 F S DA=$O(TEMP(DA)) Q:DA'>0 D ^DIK - Q - ; -STATUS(DA,FILE) ; - N ANS,DELSTS,DELALL,GBL,NODE,PXRMRX,STATUS,STS,TAXIEN,TERMIEN,TAXTYPE,TTYPE,TYPE - N RXTYPE,TAXNODE,TERMTYPE,Y - N CSTATUS,UPDATE,HTEXT,OSTAUS,WILD - S DA(2)=DA(1),DA(1)=DA,DA="",UPDATE=0,DELALL=0 - I FILE="D" S GBL="^PXD(811.9)" - I FILE="T" S GBL="^PXRMD(811.5)" - S NODE=$G(@GBL@(DA(2),20,DA(1),0)) - S TYPE=$P($G(@GBL@(DA(2),20,DA(1),0)),U) - S WILD=0 - ;check for current defined statuses if none set the default values - I FILE="D",$P($G(@GBL@(DA(2),20,DA(1),5,0)),U,4)'>0 D DEFAULT(GBL,TYPE,NODE,FILE,0,.DA) - ;I FILE="T",$P($G(@GBL@(DA(2),20,DA(1),5,0)),U,4)>0 D - ;.S STS="" F S STS=$O(@GBL@(DA(2),20,DA(1),5,"B",STS)) Q:STS="" S DELSTS(STS)="" - ;display the current status - D DISPLAY(GBL,UPDATE,.WILD,DELALL) - ;do inital prompt - D ADDDEL($G(ANS),GBL,FILE,TYPE,NODE,WILD,.DA,.UPDATE,.DELALL) - Q - ; -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 "ADDASQ"'[ANS Q - I ANS="A",WILD=1 D - .W !,"Wildcard is already on the status list all possible statuses will be evaluated." - .W !,"To add a specific status please remove the wildcard first." - .S UPDATE=0 H 1 - I ANS="A",WILD=0 D ADD(GBL,FILE,.CSTATUS,TYPE,.WILD,.DA,.UPDATE) - I ANS="D" D DELETE(GBL,FILE,.CSTATUS,NODE,.WILD,.DA,.UPDATE,.DELALL) - I ANS="S" S UPDATE="S" - I ANS="Q" S UPDATE="Q" - I UPDATE'="S",UPDATE'="Q" S DELALL=0 D ADDDEL("",GBL,FILE,TYPE,NODE,.WILD,.DA,.UPDATE,.DELALL) - ; only update the new record if the action is Save - I UPDATE="S" D UPDATE(FILE,.UPDATE,.CSTATUS,.DA,.DELALL) - Q - ; -ADD(GBL,FILE,CSTATUS,TYPE,WILD,DA,UPDATE) ; - N ANS,STATUS,TERMIEN - ;Find what types of finding is in the term - I TYPE["PXRMD(811.5," D - .S TERMIEN=$P($G(TYPE),";") - .S TYPE=$$TERMSTAT(TERMIEN) I TYPE=0 Q - .I TYPE["PXD" S TAXTYPE=$$TAXTYPE(TERMIEN,"") - I TYPE=0 Q - ;find out what is in the taxonomy - I TYPE["PXD(811.2,",$G(TAXTYPE)="" S TAXTYPE=$$TAXNODE($P(TYPE,";"),"") - 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)="P" D DATA^PXRMSTA2(FILE,.DA,"PROB","",.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 - .D SRXTYL^PXRMRXTY(NODE,.RXTYPE) - .D DATA^PXRMSTA2(FILE,.DA,"DRUG",.RXTYPE,.STATUS) - ;radiology and orderable item finding item - D DATA^PXRMSTA2(FILE,.DA,TYPE,"",.STATUS) -ADDEX ; - I '$D(STATUS) S UPDATE=0 Q - S STAT="" F S STAT=$O(STATUS(STAT)) Q:STAT=""!(WILD)=1 D - .I STAT["*" S WILD=1 Q - .S CSTATUS(STAT)="" - I WILD=1 K CSTATUS S CSTATUS("*")="" - S UPDATE=1 D DISPLAY(GBL,UPDATE,.WILD,0) - Q - ; -DEFAULT(GBL,TYPE,NODE,RFILE,DELETE,DA) ; - N ANS,FDA,FILE,IND,MSG,STATUS,TERMIEN - S FILE="" - I TYPE["PXRMD(811.5," D - .S TERMIEN=$P($G(TYPE),";") - .S TYPE=$$TERMSTAT(TERMIEN) I TYPE=0 S STATUS="" Q - .I TYPE["PXD" S TAXTYPE=$$TAXTYPE(TERMIEN,"") - I TYPE=0 Q - I TYPE["PXD(811.2,",$G(TAXTYPE)="" S TAXTYPE=$$TAXNODE($P(TYPE,";"),"") - 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 FILE="",TYPE="ORD(101.43," S FILE=100 - I FILE="",TYPE="RAMIS(71," S FILE=70 - I FILE="",TYPE["PSDRUG("!(TYPE["PS(50.605")!(TYPE["PSNDF") D - .N DSTATUS,NAME,STATUSI,STATUSN,STATUSO,RXTYPE - .D SRXTYL^PXRMRXTY(NODE,.RXTYPE) - .I $D(RXTYPE("O")) D DEFAULT^PXRMSTAT(52,.STATUSO) D - ..F IND=1:1:STATUSO(0) S DSTATUS(STATUSO(IND))="" - .I $D(RXTYPE("I")) D DEFAULT^PXRMSTAT(55,.STATUSI) D - ..F IND=1:1:STATUSI(0) S DSTATUS(STATUSI(IND))="" - .I $D(RXTYPE("N")) D DEFAULT^PXRMSTAT("55NVA",.STATUSN) D - ..F IND=1:1:STATUSN(0) S DSTATUS(STATUSN(IND))="" - .S NAME="",IND=0 F S NAME=$O(DSTATUS(NAME)) Q:NAME="" D - ..S IND=IND+1 S STATUS(IND)=NAME - .S STATUS(0)=IND - I '$D(STATUS) D DEFAULT^PXRMSTAT(FILE,.STATUS) - F IND=1:1:STATUS(0) Q:$D(MSG)>0 D - .I DELETE=1 S CSTATUS(STATUS(IND))="" Q - .I $D(@GBL@(DA(2),20,DA(1),5,"B",STATUS(IND))) Q - .I RFILE="D" S FDA(811.90221,"+3,"_DA(1)_","_DA(2)_",",.01)=STATUS(IND) - .I RFILE="T" S FDA(811.54,"+3,"_DA(1)_","_DA(2)_",",.01)=STATUS(IND) - .D UPDATE^DIE("","FDA","","MSG") - I $D(MSG)>0 D AWRITE^PXRMUTIL("MSG") H 2 - Q - ; -DELETE(GBL,FILE,CSTATUS,NODE,WILD,DA,UPDATE,DELALL) ; - N ANS,CNT,DIK,NUM,NAME,DIR,TMP,TMPARR,Y - S CNT=0,NAME="" F S NAME=$O(CSTATUS(NAME)) Q:NAME="" D - .S CNT=CNT+1 S TMPARR(CNT)=CNT_" - "_NAME,TMP(CNT)=NAME - S DIR(0)="LO^1:"_CNT_"" - M DIR("A")=TMPARR - S DIR("A")="Select which status to be deleted" - ;S DIR("?")=HELP - D ^DIR - I $D(DTOUT)!($D(DUOUT))!($G(Y)="") Q - S CNT=0 F X=1:1:$L(Y(0)) D - .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 - S UPDATE=1 - I FILE="T",$D(CSTATUS)'>0 S DELALL=1 - ;.S DIK="^PXRMD(811.5,"_DA(2)_",20,"_DA(1)_",5," - ;D CLEAR(GBL,FILE,.DA) - ;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 - ;I '$D(CSTATUS) D CLEAR(GBL,FILE,.DA) D DEFAULT(GBL,TYPE,NODE,FILE,1,.DA) - ;I '$D(CSTATUS),FILE="D" D DEFAULT(GBL,TYPE,NODE,FILE,1,.DA) - D DISPLAY(GBL,UPDATE,.WILD,DELALL) - Q - ; -DISPLAY(GBL,UPDATE,WILD,DELALL) ; - ;display statuses defined in the 5 node or display statuses if CStatus - ;array has been loaded - N NAME - S NAME="" - 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 - W !!,"Statuses already defined for this finding item:" - ;I $D(CSTATUS)'>0,UPDATE=1 D - ;.F S NAME=$O(@GBL@(DA(2),20,DA(1),5,"B",NAME)) Q:NAME="" D - ;..S CSTATUS(NAME)=$O(^PXD(811.9,DA(2),20,DA(1),5,"B","NAME","")) - I $D(CSTATUS)'>0,UPDATE=0 D - .F S NAME=$O(@GBL@(DA(2),20,DA(1),5,"B",NAME)) Q:NAME="" D - ..I NAME["*" S WILD=1 - ..W !,NAME S CSTATUS(NAME)=$O(^PXD(811.9,DA(2),20,DA(1),5,"B","NAME","")) - I UPDATE=1 F S NAME=$O(CSTATUS(NAME)) Q:NAME="" W !,NAME I NAME["*" S WILD=1 - W ! - Q - ; - ; -UPDATE(FILE,UPDATE,CSTATUS,DA,DELALL) ; - N FDA,MSG,NAME - I UPDATE="S" S UPDATE=1 - I UPDATE=0,$D(CSTATUS) G EXIT - D CLEAR(GBL,FILE,.DA) - I $D(CSTATUS)'>0 S UPDATE=0,DELALL=0 G EXIT - I $D(CSTATUS)'>0 S UPDATE=1,DELALL=1 G EXIT - S NAME="" F S NAME=$O(CSTATUS(NAME)) Q:NAME=""!($D(MSG)>0) D - .I FILE="D" S FDA(811.90221,"+3,"_DA(1)_","_DA(2)_",",.01)=NAME - .I FILE="T" S FDA(811.54,"+3,"_DA(1)_","_DA(2)_",",.01)=NAME - .D UPDATE^DIE("","FDA","","MSG") - I $D(MSG)>0 D AWRITE^PXRMUTIL("MSG") H 2 -EXIT ; - Q - ; -PROMPT(STR) ; - 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 DIR(0)=STR - S DIR("B")="S" - S DIR("?")="Select one of the above option or '^' to quit. Enter ?? for detail help." - S DIR("??")=U_"D HELP^PXRMEUT(.HTEXT)" - D ^DIR - I $G(Y)="" S Y=U - Q Y - ; -ASK(STR,HTEXT) ; - N DIR,HTEXT - I '$D(HTEXT) D - .S HTEXT(1)="Enter 'Y' to continue editing the Status List or '^' to Quit" - S DIR(0)="YA0" - S DIR("A")=STR - S DIR("B")="N" - S DIR("?")="Select either 'Y' or 'N' or '^' to quit. Enter ?? for detail help." - S DIR("??")=U_"D HELP^PXRMEUT(.HTEXT)" - D ^DIR - Q Y - ; -TAXTYPE(TERMIEN,HELP) ; - ;use to determine the Rx type of the term and the type of taxonomy - N ARRAY,BOTH,CNT,IEN,TAXNODE,RAD,PL,RESULT,TYPE - S (BOTH,PL,RAD,RESULT)=0 - S IEN=0 F S IEN=$O(^PXRMD(811.5,TERMIEN,20,IEN)) Q:+IEN'>0 D - .S TAXNODE=$G(^PXRMD(811.5,TERMIEN,20,IEN,0)) - .S ARRAY($P($P($G(TAXNODE),U),";"))="" - I $D(ARRAY)>0 S IEN=0 F S IEN=$O(ARRAY(IEN)) Q:IEN'>0 D - .S TYPE=$$TAXNODE(IEN,$G(HELP)) - .I TYPE="R" S RAD=1 - .I TYPE="P" S PL=1 - .I TYPE="B" S BOTH=1 - I RAD=1,PL=1 S RESULT="B" Q - I RAD=1,PL=0,BOTH=0 S RESULT="R" - I RAD=0,PL=1,BOTH=0 S RESULT="P" - Q RESULT - ; -TAXNODE(TAXIEN,HELP) ; - ;use to determine the type of taxonomy - N TAXNODE,ICD,CPT,ARRAY,RAD,PL,BOTH,RADM,PLM,RESULT - S (BOTH,PL,PLM,RAD,RADM,RESULT)=0 - D CHECK^PXRMBXTL(TAXIEN,"") - I $D(^PXD(811.3,TAXIEN,71,"RCPTP"))>0 S RAD=1 - I $D(^PXD(811.3,TAXIEN,"PDS",9000011))>0 S PL=1 - I RAD=1,PL=1 S RESULT="B" - I RAD=1,PL=0 S RESULT="R" - I RAD=0,PL=1 S RESULT="P" - Q RESULT - ; - ; -TERMSTAT(TIEN) ; - N CNT,FIEN,NODE - S (CNT,FIEN)=0 - S TYPE=0 F S FIEN=$O(^PXRMD(811.5,TIEN,20,FIEN)) Q:+FIEN=0!(CNT=1) D - . S NODE=$G(^PXRMD(811.5,TIEN,20,FIEN,0)),TYPE=$P(NODE,U),CNT=CNT+1 - Q TYPE - ; -WARN ; - ;If the whole entry is being deleted don't give the warning. - I $G(PXRMDEFD) Q - I $G(PXRMTMD) Q - ;Do not execute as part of exchange. - I $G(PXRMEXCH) Q - N TEXT - S TEXT(1)="" - S TEXT(2)="Since you changed the value of Rx Type, you should review the status list" - S TEXT(3)="for the finding to make sure it is still appropriate." - S TEXT(4)="" - D EN^DDIOL(.TEXT) - Q - ; - ; +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 + ;approriate status for Orders, Medication, Taxonomy, Problem List, + ;and Radiology Procedure findings items. + ; +CLEAR(GBL,FILE,DA) ; + N IEN,NODE,DIK,TEMP + I FILE="D" S DIK="^PXD(811.9,"_DA(2)_",20,"_DA(1)_",5," + I FILE="T" S DIK="^PXRMD(811.5,"_DA(2)_",20,"_DA(1)_",5," + S DA=0 F S DA=$O(@GBL@(DA(2),20,DA(1),5,DA)) Q:DA'>0 S TEMP(DA)="" + S DA=0 F S DA=$O(TEMP(DA)) Q:DA'>0 D ^DIK + Q + ; +STATUS(DA,FILE) ; + N ANS,DELSTS,DELALL,GBL,NODE,PXRMRX,STATUS,STS,TAXIEN,TERMIEN,TAXTYPE,TTYPE,TYPE + N RXTYPE,TAXNODE,TERMTYPE,Y + N CSTATUS,UPDATE,HTEXT,OSTAUS,WILD + S DA(2)=DA(1),DA(1)=DA,DA="",UPDATE=0,DELALL=0 + I FILE="D" S GBL="^PXD(811.9)" + I FILE="T" S GBL="^PXRMD(811.5)" + S NODE=$G(@GBL@(DA(2),20,DA(1),0)) + S TYPE=$P($G(@GBL@(DA(2),20,DA(1),0)),U) + S WILD=0 + ;check for current defined statuses if none set the default values + I FILE="D",$P($G(@GBL@(DA(2),20,DA(1),5,0)),U,4)'>0 D DEFAULT(GBL,TYPE,NODE,FILE,0,.DA) + ;I FILE="T",$P($G(@GBL@(DA(2),20,DA(1),5,0)),U,4)>0 D + ;.S STS="" F S STS=$O(@GBL@(DA(2),20,DA(1),5,"B",STS)) Q:STS="" S DELSTS(STS)="" + ;display the current status + D DISPLAY(GBL,UPDATE,.WILD,DELALL) + ;do inital prompt + D ADDDEL($G(ANS),GBL,FILE,TYPE,NODE,WILD,.DA,.UPDATE,.DELALL) + Q + ; +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","S") + I "ADDASQ"'[ANS Q + I ANS="A",WILD=1 D + .W !,"Wildcard is already on the status list all possible statuses will be evaluated." + .W !,"To add a specific status please remove the wildcard first." + .S UPDATE=0 H 1 + I ANS="A",WILD=0 D ADD(GBL,FILE,.CSTATUS,TYPE,.WILD,.DA,.UPDATE) + I ANS="D" D DELETE(GBL,FILE,.CSTATUS,NODE,.WILD,.DA,.UPDATE,.DELALL) + I ANS="S" S UPDATE="S" + I ANS="Q" S UPDATE="Q" + I UPDATE'="S",UPDATE'="Q" S DELALL=0 D ADDDEL("",GBL,FILE,TYPE,NODE,.WILD,.DA,.UPDATE,.DELALL) + ; only update the new record if the action is Save + I UPDATE="S" D UPDATE(FILE,.UPDATE,.CSTATUS,.DA,.DELALL) + Q + ; +ADD(GBL,FILE,CSTATUS,TYPE,WILD,DA,UPDATE) ; + N ANS,STATUS,TERMIEN + ;Find what types of finding is in the term + I TYPE["PXRMD(811.5," D + .S TERMIEN=$P($G(TYPE),";") + .S TYPE=$$TERMSTAT(TERMIEN) I TYPE=0 Q + .I TYPE["PXD" S TAXTYPE=$$TAXTYPE(TERMIEN,"") + I TYPE=0 Q + ;find out what is in the taxonomy + I TYPE["PXD(811.2,",$G(TAXTYPE)="" S TAXTYPE=$$TAXNODE($P(TYPE,";"),"") + I TYPE[";" S TYPE=$P($G(TYPE),";",2) + I TYPE="PXD(811.2," D G ADDEX + .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) + ; handle drug finding items + I TYPE["PSDRUG("!(TYPE["PS(50.605")!(TYPE["PSNDF") D G ADDEX + .D SRXTYL^PXRMRXTY(NODE,.RXTYPE) + .D DATA^PXRMSTA2(FILE,.DA,"DRUG",.RXTYPE,.STATUS) + ;radiology and orderable item finding item + D DATA^PXRMSTA2(FILE,.DA,TYPE,"",.STATUS) +ADDEX ; + I '$D(STATUS) S UPDATE=0 Q + S STAT="" F S STAT=$O(STATUS(STAT)) Q:STAT=""!(WILD)=1 D + .I STAT["*" S WILD=1 Q + .S CSTATUS(STAT)="" + I WILD=1 K CSTATUS S CSTATUS("*")="" + S UPDATE=1 D DISPLAY(GBL,UPDATE,.WILD,0) + Q + ; +DEFAULT(GBL,TYPE,NODE,RFILE,DELETE,DA) ; + N ANS,FDA,FILE,IND,MSG,STATUS,TERMIEN + S FILE="" + I TYPE["PXRMD(811.5," D + .S TERMIEN=$P($G(TYPE),";") + .S TYPE=$$TERMSTAT(TERMIEN) I TYPE=0 S STATUS="" Q + .I TYPE["PXD" S TAXTYPE=$$TAXTYPE(TERMIEN,"") + I TYPE=0 Q + I TYPE["PXD(811.2,",$G(TAXTYPE)="" S TAXTYPE=$$TAXNODE($P(TYPE,";"),"") + I TYPE[";" S TYPE=$P($G(TYPE),";",2) + I TYPE="PXD(811.2," D + .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 + I FILE="",TYPE["PSDRUG("!(TYPE["PS(50.605")!(TYPE["PSNDF") D + .N DSTATUS,NAME,STATUSI,STATUSN,STATUSO,RXTYPE + .D SRXTYL^PXRMRXTY(NODE,.RXTYPE) + .I $D(RXTYPE("O")) D DEFAULT^PXRMSTAT(52,.STATUSO) D + ..F IND=1:1:STATUSO(0) S DSTATUS(STATUSO(IND))="" + .I $D(RXTYPE("I")) D DEFAULT^PXRMSTAT(55,.STATUSI) D + ..F IND=1:1:STATUSI(0) S DSTATUS(STATUSI(IND))="" + .I $D(RXTYPE("N")) D DEFAULT^PXRMSTAT("55NVA",.STATUSN) D + ..F IND=1:1:STATUSN(0) S DSTATUS(STATUSN(IND))="" + .S NAME="",IND=0 F S NAME=$O(DSTATUS(NAME)) Q:NAME="" D + ..S IND=IND+1 S STATUS(IND)=NAME + .S STATUS(0)=IND + I '$D(STATUS) D DEFAULT^PXRMSTAT(FILE,.STATUS) + F IND=1:1:STATUS(0) Q:$D(MSG)>0 D + .I DELETE=1 S CSTATUS(STATUS(IND))="" Q + .I $D(@GBL@(DA(2),20,DA(1),5,"B",STATUS(IND))) Q + .I RFILE="D" S FDA(811.90221,"+3,"_DA(1)_","_DA(2)_",",.01)=STATUS(IND) + .I RFILE="T" S FDA(811.54,"+3,"_DA(1)_","_DA(2)_",",.01)=STATUS(IND) + .D UPDATE^DIE("","FDA","","MSG") + I $D(MSG)>0 D AWRITE^PXRMUTIL("MSG") H 2 + Q + ; +DELETE(GBL,FILE,CSTATUS,NODE,WILD,DA,UPDATE,DELALL) ; + N ANS,CNT,DIK,NUM,NAME,DIR,TMP,TMPARR,Y + S CNT=0,NAME="" F S NAME=$O(CSTATUS(NAME)) Q:NAME="" D + .S CNT=CNT+1 S TMPARR(CNT)=CNT_" - "_NAME,TMP(CNT)=NAME + S DIR(0)="LO^1:"_CNT_"" + M DIR("A")=TMPARR + S DIR("A")="Select which status to be deleted" + ;S DIR("?")=HELP + D ^DIR + I $D(DTOUT)!($D(DUOUT))!($G(Y)="") Q + S CNT=0 F X=1:1:$L(Y(0)) D + .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 + S UPDATE=1 + I FILE="T",$D(CSTATUS)'>0 S DELALL=1 + ;.S DIK="^PXRMD(811.5,"_DA(2)_",20,"_DA(1)_",5," + ;D CLEAR(GBL,FILE,.DA) + ;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 + ;I '$D(CSTATUS) D CLEAR(GBL,FILE,.DA) D DEFAULT(GBL,TYPE,NODE,FILE,1,.DA) + ;I '$D(CSTATUS),FILE="D" D DEFAULT(GBL,TYPE,NODE,FILE,1,.DA) + D DISPLAY(GBL,UPDATE,.WILD,DELALL) + Q + ; +DISPLAY(GBL,UPDATE,WILD,DELALL) ; + ;display statuses defined in the 5 node or display statuses if CStatus + ;array has been loaded + N NAME + S NAME="" + 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 + W !!,"Statuses already defined for this finding item:" + ;I $D(CSTATUS)'>0,UPDATE=1 D + ;.F S NAME=$O(@GBL@(DA(2),20,DA(1),5,"B",NAME)) Q:NAME="" D + ;..S CSTATUS(NAME)=$O(^PXD(811.9,DA(2),20,DA(1),5,"B","NAME","")) + I $D(CSTATUS)'>0,UPDATE=0 D + .F S NAME=$O(@GBL@(DA(2),20,DA(1),5,"B",NAME)) Q:NAME="" D + ..I NAME["*" S WILD=1 + ..W !,NAME S CSTATUS(NAME)=$O(^PXD(811.9,DA(2),20,DA(1),5,"B","NAME","")) + I UPDATE=1 F S NAME=$O(CSTATUS(NAME)) Q:NAME="" W !,NAME I NAME["*" S WILD=1 + W ! + Q + ; + ; +UPDATE(FILE,UPDATE,CSTATUS,DA,DELALL) ; + N FDA,MSG,NAME + I UPDATE="S" S UPDATE=1 + I UPDATE=0,$D(CSTATUS) G EXIT + D CLEAR(GBL,FILE,.DA) + I $D(CSTATUS)'>0 S UPDATE=0,DELALL=0 G EXIT + I $D(CSTATUS)'>0 S UPDATE=1,DELALL=1 G EXIT + S NAME="" F S NAME=$O(CSTATUS(NAME)) Q:NAME=""!($D(MSG)>0) D + .I FILE="D" S FDA(811.90221,"+3,"_DA(1)_","_DA(2)_",",.01)=NAME + .I FILE="T" S FDA(811.54,"+3,"_DA(1)_","_DA(2)_",",.01)=NAME + .D UPDATE^DIE("","FDA","","MSG") + I $D(MSG)>0 D AWRITE^PXRMUTIL("MSG") H 2 +EXIT ; + Q + ; +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 DIR(0)=STR + S DIR("B")="S" + S DIR("?")="Select one of the above option or '^' to quit. Enter ?? for detail help." + S DIR("??")=U_"D HELP^PXRMEUT(.HTEXT)" + D ^DIR + I $G(Y)="" S Y=U + Q Y + ; +ASK(STR,HTEXT) ; + N DIR,HTEXT + I '$D(HTEXT) D + .S HTEXT(1)="Enter 'Y' to continue editing the Status List or '^' to Quit" + S DIR(0)="YA0" + S DIR("A")=STR + S DIR("B")="N" + S DIR("?")="Select either 'Y' or 'N' or '^' to quit. Enter ?? for detail help." + S DIR("??")=U_"D HELP^PXRMEUT(.HTEXT)" + D ^DIR + Q Y + ; +TAXTYPE(TERMIEN,HELP) ; + ;use to determine the Rx type of the term and the type of taxonomy + N ARRAY,BOTH,CNT,IEN,TAXNODE,RAD,PL,RESULT,TYPE + S (BOTH,PL,RAD,RESULT)=0 + S IEN=0 F S IEN=$O(^PXRMD(811.5,TERMIEN,20,IEN)) Q:+IEN'>0 D + .S TAXNODE=$G(^PXRMD(811.5,TERMIEN,20,IEN,0)) + .S ARRAY($P($P($G(TAXNODE),U),";"))="" + I $D(ARRAY)>0 S IEN=0 F S IEN=$O(ARRAY(IEN)) Q:IEN'>0 D + .S TYPE=$$TAXNODE(IEN,$G(HELP)) + .I TYPE="R" S RAD=1 + .I TYPE="P" S PL=1 + .I TYPE="B" S BOTH=1 + I RAD=1,PL=1 S RESULT="B" Q + I RAD=1,PL=0,BOTH=0 S RESULT="R" + I RAD=0,PL=1,BOTH=0 S RESULT="P" + Q RESULT + ; +TAXNODE(TAXIEN,HELP) ; + ;use to determine the type of taxonomy + N TAXNODE,ICD,CPT,ARRAY,RAD,PL,BOTH,RADM,PLM,RESULT + S (BOTH,PL,PLM,RAD,RADM,RESULT)=0 + D CHECK^PXRMBXTL(TAXIEN,"") + I $D(^PXD(811.3,TAXIEN,71,"RCPTP"))>0 S RAD=1 + I $D(^PXD(811.3,TAXIEN,"PDS",9000011))>0 S PL=1 + I RAD=1,PL=1 S RESULT="B" + I RAD=1,PL=0 S RESULT="R" + I RAD=0,PL=1 S RESULT="P" + Q RESULT + ; + ; +TERMSTAT(TIEN) ; + N CNT,FIEN,NODE + S (CNT,FIEN)=0 + S TYPE=0 F S FIEN=$O(^PXRMD(811.5,TIEN,20,FIEN)) Q:+FIEN=0!(CNT=1) D + . S NODE=$G(^PXRMD(811.5,TIEN,20,FIEN,0)),TYPE=$P(NODE,U),CNT=CNT+1 + Q TYPE + ; +WARN ; + ;If the whole entry is being deleted don't give the warning. + I $G(PXRMDEFD) Q + I $G(PXRMTMD) Q + ;Do not execute as part of exchange. + I $G(PXRMEXCH) Q + N TEXT + S TEXT(1)="" + S TEXT(2)="Since you changed the value of Rx Type, you should review the status list" + S TEXT(3)="for the finding to make sure it is still appropriate." + S TEXT(4)="" + D EN^DDIOL(.TEXT) + Q + ; + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMSTA2.m b/r/CLINICAL_REMINDERS-PXRM/PXRMSTA2.m index e9db6a0c..aee5c5e2 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMSTA2.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMSTA2.m @@ -1,134 +1,130 @@ -PXRMSTA2 ; SLC/AGP - Routines for building status list. ;03/27/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; -DATA(FILE,DA,TYPE,RXTYPE,STATUS) ; - ; this sub routine get the list of statuses from the apporiate global - ; - N ARRAY,ARRAY1,CNT,CODE,DEF,OUTPUT,SARRAY,STAT -LOOP ; - ;get build status list into a local array from each pharmacy type of - ;finding item - 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 ARRAYFOR(.SARRAY,.ARRAY,"I") K CODE - . . D STATUS^PSS55MIS(55.01,100,"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 ARRAYFOR(.SARRAY,.ARRAY,"O") K CODE - . . I $D(OUTPUT)>0 K ARRAY1 M ARRAY1=OUTPUT K OUTPUT D COMPARE(.ARRAY,.ARRAY1,"",.OUTPUT) - . . E M OUTPUT=ARRAY - . 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") - . . S SARRAY("POINTER")=SARRAY("POINTER")_"0:ACTIVE;" - . . D ARRAYFOR(.SARRAY,.ARRAY,"N") K CODE - . . I $D(OUTPUT)>0 K ARRAY1 M ARRAY1=OUTPUT K OUTPUT D COMPARE(.ARRAY,.ARRAY1,"",.OUTPUT) - . . E M OUTPUT=ARRAY - ; - I TYPE="PROB" S OUTPUT("ACTIVE")="ACTIVE",OUTPUT("INACTIVE")="INACTIVE" - I TYPE="ORD(101.43," D - . S CNT=0,STAT="" F S STAT=$O(^ORD(100.01,"B",STAT)) Q:STAT="" D - . . S CNT=CNT+1 S OUTPUT(STAT)=STAT - I TYPE="RAMIS(71,"!(TYPE="TAX") D - . S TYPE="RAMIS(71," - . S CNT=0,STAT="" F S STAT=$O(^RA(72,"B",STAT)) Q:STAT="" D - . . S CNT=CNT+1 S OUTPUT(STAT)=STAT - .;I TYPE'="TAX" Q - .;I '$D(OUTPUT("ACTIVE")) S OUTPUT("ACTIVE")="ACTIVE" - .;I '$D(OUTPUT("INACTIVE")) S OUTPUT("INACTIVE")="INACTIVE" - D SELECT(.OUTPUT,FILE,TYPE,.STATUS,.DA) - ; - Q - ; -COMPARE(ARRAY,ARRAY1,TYPE,OUTPUT) ; - ; this sub routine is use to combine the InPatient and - ; Both Pharmacy type into one array - N ARY,CNT,COMP,NODE - K OUTPUT - S COMP="" - ; - ;inpatient pharmacy list is built from two seperated fields in file #55 - ;this is used to combined the two fields into one array - I $G(TYPE)="I" D - . F S COMP=$O(ARRAY(COMP)) Q:COMP="" D - . . S OUTPUT(COMP)=ARRAY(COMP) - . S (COMP)="" F S COMP=$O(ARRAY1(COMP)) Q:COMP="" D - . . I '$D(OUTPUT(COMP)) S OUTPUT(COMP)=ARRAY1(COMP) - ; - ;this section is uses to combine the different RX Types into one array - I $G(TYPE)'="I" D - . F S COMP=$O(ARRAY(COMP)) Q:COMP="" D - . . S NODE=$G(ARRAY(COMP)) - . . S OUTPUT(COMP)=NODE - . S COMP="" F S COMP=$O(ARRAY1(COMP)) Q:COMP="" D - . . S NODE=$G(ARRAY1(COMP)) - . . I '$D(OUTPUT(COMP)) S OUTPUT(COMP)=NODE Q - . . I $D(OUTPUT(COMP)) S $P(OUTPUT(COMP),U,2)=$P(OUTPUT(COMP),U,2)_$P(NODE,U,2) - Q - ; -ARRAYFOR(ARRAY,OUTPUT,DEF) ; - ;this sub routine is use to format the array data into a standard - ;format - ; - N CNT,COMP,PIECE,STR,TYPE - S PIECE=0 - ; - ;determine the number of pieces minus one in the string - F CNT=1:1:$L(ARRAY("POINTER")) I $E(ARRAY("POINTER"),CNT)=";" S PIECE=PIECE+1 I PIECE>0 D - . S STR=$P($P($G(ARRAY("POINTER")),";",PIECE),":",2) - . S OUTPUT($P($P($G(ARRAY("POINTER")),";",PIECE),":",2))=STR_U_$G(DEF) - ; - ;add last piece in the string to the array - I PIECE>0 S PIECE=PIECE+1 D - . I $P($G(ARRAY("POINTER")),";",PIECE)'="" D - . . S OUTPUT($P($P($G(ARRAY("POINTER")),";",PIECE),":",2))=$P($P($G(ARRAY("POINTER")),";",PIECE),":",2)_U_$G(DEF) - Q - ; -SELECT(ARRAY,FILE,TYPE,STATUS,DA) ; - ; this sub routine is use to sort through the formated array and - ; set up the DIR call - ; - N CHECK,CNT,CNT1,DIR,DUOUT,DTOUT,EMPTY,EXTR - N HELP,LENGTH,NODE,STAT,STR,TEXT,TMP,X,Y - N TMPARR,NUM -DISPLAY ; - I TYPE="DRUG" S TEXT="Select a Medication Status or enter '^' to Quit",HELP="Select a status from the Medication Status list or '^' to Quit" - I TYPE="ORD(101.43," S TEXT="Select a Order Status from or enter '^' to Quit",HELP="Select a Order Status from the status list or '^' to Quit" - I TYPE="RAMIS(71," S TEXT="Select a Radiology Procedure Status or enter '^' to Quit",HELP="Select a Radiology Procedure Status from the status list or '^' to Quit" - ;I TYPE="TAX" S TEXT="Select a Taxonomy Status or enter '^' to Quit",HELP="Select a Taxonomy Status from the status list or '^' to Quit" - ;I TYPE="PROB" S TEXT="Select a Problem Status or enter '^' to Quit",HELP="Select a Taxonomy Status from the status list or '^' to Quit" - ; - S CNT=0,CNT1=0,STAT="" - ;if text is not entered into the prompt or no match is found display - ;entire list of statuses for this finding item - ; - ;Add wildcard character - S CNT=CNT+1,CNT1=CNT1+1,TMP(CNT)=CNT_" - * (WildCard)",TMPARR(CNT)="*" - ;Add status from file to the selectable list - F S STAT=$O(ARRAY(STAT)) Q:STAT="" D - . S NODE=$G(ARRAY(STAT)) - . S STR=$P(NODE,U) - . S CNT=CNT+1,CNT1=CNT1+1 - . I TYPE="DRUG" S TMP(CNT)=CNT_" - "_STR_"("_$P(NODE,U,2)_")",TMPARR(CNT)=STR - . E S TMP(CNT)=CNT_" - "_STR,TMPARR(CNT)=STR - ; - S DIR(0)="LO^1:"_CNT_"" - M DIR("A")=TMP - S DIR("A")=TEXT - S DIR("?")=HELP - D ^DIR - I $D(DTOUT)!($D(DUOUT))!($G(Y)="") K STATUS Q - S CNT=0 F X=1:1:$L(Y(0)) D - .I $E(Y(0),X)="," S CNT=CNT+1,NUM=$P(Y(0),",",CNT),STATUS(TMPARR(NUM))="" - ;S STATUS=Y(0) - ;I STATUS="WildCard" S STATUS="*" - Q - ; +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) ; + ; this sub routine get the list of statuses from the apporiate global + ; + N ARRAY,ARRAY1,CNT,CODE,DEF,OUTPUT,SARRAY,STAT +LOOP ; + ;get build status list into a local array from each pharmacy type of + ;finding item + I TYPE="DRUG" D + .I $D(RXTYPE("I"))>0 D + . . D FIELD^DID(55.06,28,"","POINTER","SARRAY") + . . D ARRAYFOR(.SARRAY,.ARRAY,"I") K CODE + . . 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 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) + . . E M OUTPUT=ARRAY + . I $D(RXTYPE("N"))>0 D + . . K ARRAY,ARRAY1,CODE + . . D FIELD^DID(55.05,5,"","POINTER","SARRAY") + . . S SARRAY("POINTER")=SARRAY("POINTER")_"0:ACTIVE;" + . . D ARRAYFOR(.SARRAY,.ARRAY,"N") K CODE + . . I $D(OUTPUT)>0 K ARRAY1 M ARRAY1=OUTPUT K OUTPUT D COMPARE(.ARRAY,.ARRAY1,"",.OUTPUT) + . . E M OUTPUT=ARRAY + ; + I TYPE="PROB" S OUTPUT("ACTIVE")="ACTIVE",OUTPUT("INACTIVE")="INACTIVE" + I TYPE="ORD(101.43," D + . S CNT=0,STAT="" F S STAT=$O(^ORD(100.01,"B",STAT)) Q:STAT="" D + . . S CNT=CNT+1 S OUTPUT(STAT)=STAT + I TYPE="RAMIS(71,"!(TYPE="TAX") D + . S TYPE="RAMIS(71," + . S CNT=0,STAT="" F S STAT=$O(^RA(72,"B",STAT)) Q:STAT="" D + . . S CNT=CNT+1 S OUTPUT(STAT)=STAT + .;I TYPE'="TAX" Q + .;I '$D(OUTPUT("ACTIVE")) S OUTPUT("ACTIVE")="ACTIVE" + .;I '$D(OUTPUT("INACTIVE")) S OUTPUT("INACTIVE")="INACTIVE" + D SELECT(.OUTPUT,FILE,TYPE,.STATUS,.DA) + ; + Q + ; +COMPARE(ARRAY,ARRAY1,TYPE,OUTPUT) ; + ; this sub routine is use to combine the InPatient and + ; Both Pharmacy type into one array + N ARY,CNT,COMP,NODE + K OUTPUT + S COMP="" + ; + ;inpatient pharmacy list is built from two seperated fields in file #55 + ;this is used to combined the two fields into one array + I $G(TYPE)="I" D + . F S COMP=$O(ARRAY(COMP)) Q:COMP="" D + . . S OUTPUT(COMP)=ARRAY(COMP) + . S (COMP)="" F S COMP=$O(ARRAY1(COMP)) Q:COMP="" D + . . I '$D(OUTPUT(COMP)) S OUTPUT(COMP)=ARRAY1(COMP) + ; + ;this section is uses to combine the different RX Types into one array + I $G(TYPE)'="I" D + . F S COMP=$O(ARRAY(COMP)) Q:COMP="" D + . . S NODE=$G(ARRAY(COMP)) + . . S OUTPUT(COMP)=NODE + . S COMP="" F S COMP=$O(ARRAY1(COMP)) Q:COMP="" D + . . S NODE=$G(ARRAY1(COMP)) + . . I '$D(OUTPUT(COMP)) S OUTPUT(COMP)=NODE Q + . . I $D(OUTPUT(COMP)) S $P(OUTPUT(COMP),U,2)=$P(OUTPUT(COMP),U,2)_$P(NODE,U,2) + Q + ; +ARRAYFOR(ARRAY,OUTPUT,DEF) ; + ;this sub routine is use to format that array data into a standard + ;format + ; + N CNT,COMP,PIECE,STR,TYPE + S PIECE=0 + ; + ;determine the number of pieces minus one in the string + F CNT=1:1:$L(ARRAY("POINTER")) I $E(ARRAY("POINTER"),CNT)=";" S PIECE=PIECE+1 I PIECE>0 D + . S STR=$P($P($G(ARRAY("POINTER")),";",PIECE),":",2) + . S OUTPUT($P($P($G(ARRAY("POINTER")),";",PIECE),":",2))=STR_U_$G(DEF) + ; + ;add last piece in the string to the array + I PIECE>0 S PIECE=PIECE+1 D + . I $P($G(ARRAY("POINTER")),";",PIECE)'="" D + . . S OUTPUT($P($P($G(ARRAY("POINTER")),";",PIECE),":",2))=$P($P($G(ARRAY("POINTER")),";",PIECE),":",2)_U_$G(DEF) + Q + ; +SELECT(ARRAY,FILE,TYPE,STATUS,DA) ; + ; this sub routine is use to sort through the formated array and + ; set up the DIR call + ; + N CHECK,CNT,CNT1,DIR,DUOUT,DTOUT,EMPTY,EXTR + N HELP,LENGTH,NODE,STAT,STR,TEXT,TMP,X,Y + N TMPARR,NUM +DISPLAY ; + I TYPE="DRUG" S TEXT="Select a Medication Status or enter '^' to Quit",HELP="Select a status from the Medication Status list or '^' to Quit" + I TYPE="ORD(101.43," S TEXT="Select a Order Status from or enter '^' to Quit",HELP="Select a Order Status from the status list or '^' to Quit" + I TYPE="RAMIS(71," S TEXT="Select a Radiology Procedure Status or enter '^' to Quit",HELP="Select a Radiology Procedure Status from the status list or '^' to Quit" + ;I TYPE="TAX" S TEXT="Select a Taxonomy Status or enter '^' to Quit",HELP="Select a Taxonomy Status from the status list or '^' to Quit" + ;I TYPE="PROB" S TEXT="Select a Problem Status or enter '^' to Quit",HELP="Select a Taxonomy Status from the status list or '^' to Quit" + ; + S CNT=0,CNT1=0,STAT="" + ;if text is not entered into the prompt or no match is found display + ;entire list of statuses for this finding item + ; + ;Add wildcard character + S CNT=CNT+1,CNT1=CNT1+1,TMP(CNT)=CNT_" - * (WildCard)",TMPARR(CNT)="*" + ;Add status from file to the selectable list + F S STAT=$O(ARRAY(STAT)) Q:STAT="" D + . S NODE=$G(ARRAY(STAT)) + . S STR=$P(NODE,U) + . S CNT=CNT+1,CNT1=CNT1+1 + . I TYPE="DRUG" S TMP(CNT)=CNT_" - "_STR_"("_$P(NODE,U,2)_")",TMPARR(CNT)=STR + . E S TMP(CNT)=CNT_" - "_STR,TMPARR(CNT)=STR + ; + S DIR(0)="LO^1:"_CNT_"" + M DIR("A")=TMP + S DIR("A")=TEXT + S DIR("?")=HELP + D ^DIR + I $D(DTOUT)!($D(DUOUT))!($G(Y)="") K STATUS Q + S CNT=0 F X=1:1:$L(Y(0)) D + .I $E(Y(0),X)="," S CNT=CNT+1,NUM=$P(Y(0),",",CNT),STATUS(TMPARR(NUM))="" + ;S STATUS=Y(0) + ;I STATUS="WildCard" S STATUS="*" + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMSXRM.m b/r/CLINICAL_REMINDERS-PXRM/PXRMSXRM.m index b9dcefa5..96887b53 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMSXRM.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMSXRM.m @@ -1,183 +1,181 @@ -PXRMSXRM ; SLC/PKR - Main driver for building indexes. ;11/23/2007 - ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123 - ; - ;========================================== -ADDERROR(GLOBAL,IDEN,NERROR) ;Add to the error list. - S NERROR=NERROR+1 - S ^TMP("PXRMERROR",$J,NERROR,0)="GLOBAL: "_GLOBAL_" ENTRY: "_IDEN - Q - ; - ;========================================== -ASKTASK() ;See if this should be tasked. - N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y - S DIR(0)="YO" - S DIR("A")="Do you want this to be tasked" - S DIR("B")="Y" - D ^DIR - I $D(DIROUT)!$D(DIRUT) Q "" - I $D(DUOUT)!$D(DTOUT) Q "" - Q Y - ; - ;========================================== -COMMSG(GLOBAL,START,END,NE,NERROR) ;Send a MailMan message providing - ;notification that the indexing completed. - N XMSUB - K ^TMP("PXRMXMZ",$J) - S XMSUB="Index for global "_GLOBAL_" sucessfully built" - S ^TMP("PXRMXMZ",$J,1,0)="Build of Clinical Reminders index for global "_GLOBAL_" completed." - S ^TMP("PXRMXMZ",$J,2,0)="Build finished at "_$$FMTE^XLFDT($$NOW^XLFDT,"5Z") - S ^TMP("PXRMXMZ",$J,3,0)=NE_" entries were created." - S ^TMP("PXRMXMZ",$J,4,0)=$$ETIME(START,END) - S ^TMP("PXRMXMZ",$J,5,0)=NERROR_" errors were encountered." - I NERROR>0 S ^TMP("PXRMXMZ",$J,6,0)="Another MailMan message will contain the error information." - D SEND^PXRMMSG(XMSUB) - Q - ; - ;========================================== -DETIME(START,END) ;Write out the elapsed time. - ;START and END are $H times. - N TEXT - S TEXT=$$ETIME(START,END) - D MES^XPDUTL(TEXT) - Q - ; - ;========================================== -ERRMSG(NERROR,GLOBAL) ;If there were errors send an error message. - N END,IND,MAXERR,NE,XMSUB - I NERROR=0 Q - ;Return the last MAXERR errors - S MAXERR=+$G(^PXRM(800,1,"MIERR")) - I MAXERR=0 S MAXERR=200 - K ^TMP("PXRMXMZ",$J) - S END=$S(NERROR'>MAXERR:NERROR,1:MAXERR) - S NE=NERROR+1 - F IND=1:1:END S NE=NE-1,^TMP("PXRMXMZ",$J,IND,0)=^TMP("PXRMERROR",$J,NE,0) - I END=MAXERR S ^TMP("PXRMXMZ",$J,MAXERR+1,0)="GLOBAL: "_GLOBAL_"- Maximum number of errors reached, will not report any more." - K ^TMP("PXRMERROR",$J) - S XMSUB="CLINICAL REMINDER INDEX BUILD ERROR(S) FOR GLOBAL "_GLOBAL - D SEND^PXRMMSG(XMSUB) - Q - ; - ;========================================== -ETIME(START,END) ;Calculate and format the elapsed time. - ;START and END are $H times. - N ETIME,TEXT - S ETIME=$$HDIFF^XLFDT(END,START,2) - I ETIME>90 D - . S ETIME=$$HDIFF^XLFDT(END,START,3) - . S TEXT="Elapsed time: "_ETIME - E S TEXT="Elapsed time: "_ETIME_" secs" - Q TEXT - ; - ;========================================== -INDEX ;Driver for building the various indexes. - N GBL,LIST,ROUTINE,TASKIT - S ROUTINE(45)="INDEX^DGPTDDCR" ;DBIA #4521 - S ROUTINE(52)="PSRX^PSOPXRMI" ;DBIA #4522 - S ROUTINE(55)="PSPA^PSSSXRD" ;DBIA #4172 - S ROUTINE(63)="LAB^LRPXSXRL" ;DBIA #4247 - S ROUTINE(70)="RAD^RAPXRM" ;DBIA #3731 - S ROUTINE(100)="INDEX^ORPXRM" ;DBIA #4498 - 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 - S ROUTINE(9000010.11)="VIMM^PXPXRMI1" ;DBIA #4519 - S ROUTINE(9000010.12)="VSK^PXPXRMI2" ;DBIA #4520 - S ROUTINE(9000010.13)="VXAM^PXPXRMI2" ;DBIA #4520 - S ROUTINE(9000010.16)="VPED^PXPXRMI2" ;DBIA #4520 - S ROUTINE(9000010.18)="VCPT^PXPXRMI1" ;DBIA #4519 - S ROUTINE(9000010.23)="VHF^PXPXRMI1" ;DBIA #4519 - ;Get the list - W !,"Which indexes do you want to (re)build?" - D SEL(.LIST,.GBL) - I LIST="" Q - ;See if this should be tasked. - S TASKIT=$$ASKTASK - I TASKIT="" Q - I TASKIT D - . W !,"Queue the Clinical Reminders index job." - . D TASKIT(LIST,.GBL,.ROUTINE) - E D RUNNOW(LIST,.GBL,.ROUTINE) - Q - ; - ;========================================== -RUNNOW(LIST,GBL,ROUTINE) ;Run the routines now. - N IND,LI,NUM,RTN - S NUM=$L(LIST,",")-1 - F IND=1:1:NUM D - . S LI=$P(LIST,",",IND) - . S RTN=ROUTINE(GBL(LI)) - . D @RTN - Q - ; - ;========================================== -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 - M DIR("A")=ALIST - S DIR("A")="Enter your list" - S DIR(0)="LO^1:"_INUM - D ^DIR - I $D(DIROUT)!$D(DIRUT) S LIST="" Q - I $D(DUOUT)!$D(DTOUT) S LIST="" Q - S LIST=Y - Q - ; - ;========================================== -TASKIT(LIST,GBL,ROUTINE) ;Build the indexes as a tasked job. - N DIR,DIROUT,DIRUT,DTOUT,DUOUT,MINDT,SDTIME,X,Y - S MINDT=$$NOW^XLFDT - 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(0)="DAU"_U_MINDT_"::RSX" - D ^DIR - I $D(DIROUT)!$D(DIRUT) Q - I $D(DUOUT)!$D(DTOUT) Q - S SDTIME=Y - ;Put the task into the queue. - K ZTSAVE - S ZTSAVE("LIST")="" - S ZTSAVE("GBL(")="" - S ZTSAVE("ROUTINE(")="" - S ZTRTN="TASKJOB^PXRMSXRM" - S ZTDESC="Clinical Reminders index build" - S ZTDTH=SDTIME - S ZTIO="" - D ^%ZTLOAD - W !,"Task number ",ZTSK," queued." - Q - ; - ;========================================== -TASKJOB ;Execute as tasked job. LIST, GBL, and ROUTINE come through - ;ZTSAVE. - N IND,LI,NUM,RTN - S ZTREQ="@" - S ZTSTOP=0 - S NUM=$L(LIST,",")-1 - F IND=1:1:NUM D - .;Check to see if the task has had a stop request - . I $$S^%ZTLOAD S ZTSTOP=1,IND=NUM Q - . S LI=$P(LIST,",",IND) - . S RTN=ROUTINE(GBL(LI)) - . D @RTN - Q - ; +PXRMSXRM ; SLC/PKR - Main driver for building indexes. ;12/20/2004 + ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005 + ; + ;========================================== +ADDERROR(GLOBAL,IDEN,NERROR) ;Add to the error list. + S NERROR=NERROR+1 + S ^TMP("PXRMERROR",$J,NERROR,0)="GLOBAL: "_GLOBAL_" ENTRY: "_IDEN + Q + ; + ;========================================== +ASKTASK() ;See if this should be tasked. + N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y + S DIR(0)="YO" + S DIR("A")="Do you want this to be tasked" + S DIR("B")="Y" + D ^DIR + I $D(DIROUT)!$D(DIRUT) Q "" + I $D(DUOUT)!$D(DTOUT) Q "" + Q Y + ; + ;========================================== +COMMSG(GLOBAL,START,END,NE,NERROR) ;Send a MailMan message providing + ;notification that the indexing completed. + N XMSUB + K ^TMP("PXRMXMZ",$J) + S XMSUB="Index for global "_GLOBAL_" sucessfully built" + S ^TMP("PXRMXMZ",$J,1,0)="Build of Clinical Reminders index for global "_GLOBAL_" completed." + S ^TMP("PXRMXMZ",$J,2,0)="Build finished at "_$$FMTE^XLFDT($$NOW^XLFDT,"5Z") + S ^TMP("PXRMXMZ",$J,3,0)=NE_" entries were created." + S ^TMP("PXRMXMZ",$J,4,0)=$$ETIME(START,END) + S ^TMP("PXRMXMZ",$J,5,0)=NERROR_" errors were encountered." + I NERROR>0 S ^TMP("PXRMXMZ",$J,6,0)="Another MailMan message will contain the error information." + D SEND^PXRMMSG(XMSUB) + Q + ; + ;========================================== +DETIME(START,END) ;Write out the elapsed time. + ;START and END are $H times. + N TEXT + S TEXT=$$ETIME(START,END) + D MES^XPDUTL(TEXT) + Q + ; + ;========================================== +ERRMSG(NERROR,GLOBAL) ;If there were errors send an error message. + N END,IND,MAXERR,NE,XMSUB + I NERROR=0 Q + ;Return the last MAXERR errors + S MAXERR=+$G(^PXRM(800,1,"MIERR")) + I MAXERR=0 S MAXERR=200 + K ^TMP("PXRMXMZ",$J) + S END=$S(NERROR'>MAXERR:NERROR,1:MAXERR) + S NE=NERROR+1 + F IND=1:1:END S NE=NE-1,^TMP("PXRMXMZ",$J,IND,0)=^TMP("PXRMERROR",$J,NE,0) + I END=MAXERR S ^TMP("PXRMXMZ",$J,MAXERR+1,0)="GLOBAL: "_GLOBAL_"- Maximum number of errors reached, will not report any more." + K ^TMP("PXRMERROR",$J) + S XMSUB="CLINICAL REMINDER INDEX BUILD ERROR(S) FOR GLOBAL "_GLOBAL + D SEND^PXRMMSG(XMSUB) + Q + ; + ;========================================== +ETIME(START,END) ;Calculate and format the elapsed time. + ;START and END are $H times. + N ETIME,TEXT + S ETIME=$$HDIFF^XLFDT(END,START,2) + I ETIME>90 D + . S ETIME=$$HDIFF^XLFDT(END,START,3) + . S TEXT="Elapsed time: "_ETIME + E S TEXT="Elapsed time: "_ETIME_" secs" + Q TEXT + ; + ;========================================== +INDEX ;Driver for building the various indexes. + N GBL,LIST,ROUTINE,TASKIT + S ROUTINE(45)="INDEX^DGPTDDCR" ;DBIA #4521 + S ROUTINE(52)="PSRX^PSOPXRMI" ;DBIA #4522 + S ROUTINE(55)="PSPA^PSSSXRD" ;DBIA #4172 + S ROUTINE(63)="LAB^LRPXSXRL" ;DBIA #4247 + S ROUTINE(70)="RAD^RAPXRM" ;DBIA #3731 + S ROUTINE(100)="INDEX^ORPXRM" ;DBIA #4498 + S ROUTINE(120.5)="VITALS^GMVPXRM" ;DBIA #3647 + S ROUTINE(601.2)="INDEX^YTPXRM" ;DBIA #4523 + S ROUTINE(9000011)="INDEX^GMPLPXRM" ;DBIA #4516 + S ROUTINE(9000010.07)="VPOV^PXPXRMI2" ;DBIA #4520 + S ROUTINE(9000010.11)="VIMM^PXPXRMI1" ;DBIA #4519 + S ROUTINE(9000010.12)="VSK^PXPXRMI2" ;DBIA #4520 + S ROUTINE(9000010.13)="VXAM^PXPXRMI2" ;DBIA #4520 + S ROUTINE(9000010.16)="VPED^PXPXRMI2" ;DBIA #4520 + S ROUTINE(9000010.18)="VCPT^PXPXRMI1" ;DBIA #4519 + S ROUTINE(9000010.23)="VHF^PXPXRMI1" ;DBIA #4519 + ;Get the list + W !,"Which indexes do you want to (re)build?" + D SEL(.LIST,.GBL) + I LIST="" Q + ;See if this should be tasked. + S TASKIT=$$ASKTASK + I TASKIT="" Q + I TASKIT D + . W !,"Queue the Clinical Reminders index job." + . D TASKIT(LIST,.GBL,.ROUTINE) + E D RUNNOW(LIST,.GBL,.ROUTINE) + Q + ; + ;========================================== +RUNNOW(LIST,GBL,ROUTINE) ;Run the routines now. + N IND,LI,NUM,RTN + S NUM=$L(LIST,",")-1 + F IND=1:1:NUM D + . S LI=$P(LIST,",",IND) + . S RTN=ROUTINE(GBL(LI)) + . D @RTN + Q + ; + ;========================================== +SEL(LIST,GBL) ;Select global list + 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:16" + D ^DIR + I $D(DIROUT)!$D(DIRUT) S LIST="" Q + I $D(DUOUT)!$D(DTOUT) S LIST="" Q + S LIST=Y + Q + ; + ;========================================== +TASKIT(LIST,GBL,ROUTINE) ;Build the indexes as a tasked job. + N DIR,DIROUT,DIRUT,DTOUT,DUOUT,MINDT,SDTIME,X,Y + S MINDT=$$NOW^XLFDT + 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(0)="DAU"_U_MINDT_"::RSX" + D ^DIR + I $D(DIROUT)!$D(DIRUT) Q + I $D(DUOUT)!$D(DTOUT) Q + S SDTIME=Y + ;Put the task into the queue. + K ZTSAVE + S ZTSAVE("LIST")="" + S ZTSAVE("GBL(")="" + S ZTSAVE("ROUTINE(")="" + S ZTRTN="TASKJOB^PXRMSXRM" + S ZTDESC="Clinical Reminders index build" + S ZTDTH=SDTIME + S ZTIO="" + D ^%ZTLOAD + W !,"Task number ",ZTSK," queued." + Q + ; + ;========================================== +TASKJOB ;Execute as tasked job. LIST, GBL, and ROUTINE come through + ;ZTSAVE. + N IND,LI,NUM,RTN + S ZTREQ="@" + S ZTSTOP=0 + S NUM=$L(LIST,",")-1 + F IND=1:1:NUM D + .;Check to see if the task has had a stop request + . I $$S^%ZTLOAD S ZTSTOP=1,IND=NUM Q + . S LI=$P(LIST,",",IND) + . S RTN=ROUTINE(GBL(LI)) + . D @RTN + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMTAX.m b/r/CLINICAL_REMINDERS-PXRM/PXRMTAX.m index 3c7bc249..e1ac04ef 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMTAX.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMTAX.m @@ -1,213 +1,213 @@ -PXRMTAX ; SLC/PKR - Handle taxonomy finding. ;10/11/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ;================================================== -EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate taxonomy findings. - N FIEVT,FINDPA,FINDING - N TAXIEN - S TAXIEN="" - F S TAXIEN=$O(DEFARR("E",ENODE,TAXIEN)) Q:+TAXIEN=0 D - . S FINDING="" - . F S FINDING=$O(DEFARR("E",ENODE,TAXIEN,FINDING)) Q:+FINDING=0 D - .. K FINDPA - .. M FINDPA=DEFARR(20,FINDING) - .. K FIEVT - .. D FIEVAL(DFN,TAXIEN,.FINDPA,.FIEVT) - .. M FIEVAL(FINDING)=FIEVT - Q - ; - ;================================================== -EVALPL(FINDPA,ENODE,TERMARR,PLIST) ;Evaluate taxonomy terms for - ;building patient lists. - N PFIND3,PFIND4,PFINDPA,TAXIEN - N TFINDPA,TFINDING - S TAXIEN="" - F S TAXIEN=$O(TERMARR("E",ENODE,TAXIEN)) Q:+TAXIEN=0 D - . S TFINDING="" - . F S TFINDING=$O(TERMARR("E",ENODE,TAXIEN,TFINDING)) Q:+TFINDING=0 D - .. K PFINDPA,TFINDPA - .. M TFINDPA=TERMARR(20,TFINDING) - ..;Set the finding parameters. - .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA) - .. D GPLIST(TAXIEN,.PFINDPA,PLIST) - Q - ; - ;================================================== -EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;Evaluate taxonomy - ;terms. - N FIEVT,PFINDPA - N TAXIEN,TFINDPA,TFINDING - S TAXIEN="" - F S TAXIEN=$O(TERMARR("E",ENODE,TAXIEN)) Q:+TAXIEN=0 D - . S TFINDING="" - . F S TFINDING=$O(TERMARR("E",ENODE,TAXIEN,TFINDING)) Q:+TFINDING=0 D - .. K FIEVT,PFINDPA,TFINDPA - .. M TFINDPA=TERMARR(20,TFINDING) - ..;Set the finding parameters. - .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA) - .. D FIEVAL(DFN,TAXIEN,.PFINDPA,.FIEVT) - .. M TFIEVAL(TFINDING)=FIEVT - Q - ; - ;================================================== -FIEVAL(DFN,TAXIEN,FINDPA,FIEVAL) ; - N BDT,CASESEN,COND,CONVAL,DAS,DATE,EDT,ENS,FIEVT,FILENUM,FLIST - N ICOND,IND,INS,INVFD - N NFOUND,NGET,NICD0,NICD9,NCPT,NOCC,NP,NRCPT,PLS - N RAS,SAVE,SDIR,STATUSA,TAXARR,TLIST,UCIFS,USEINP,VSLIST - ;Set the finding search parameters. - D SSPAR^PXRMUTIL(FINDPA(0),.NOCC,.BDT,.EDT) - S INVFD=$P(FINDPA(0),U,16) - D TAX^PXRMLDR(TAXIEN,.TAXARR) - I TAXARR(0)["NO LOCK" S FIEVAL(1)=0 Q - D SETVAR^PXRMTAXS(.TAXARR,.ENS,.INS,.NICD0,.NICD9,.NCPT,.NRCPT,.PLS,.RAS) - D SCPAR^PXRMCOND(.FINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST) - S SDIR=$S(NOCC<0:+1,1:-1) - S NOCC=$S(NOCC<0:-NOCC,1:NOCC) - S NGET=$S(UCIFS:50,1:NOCC) - ; - I (NICD0>0),INS D FPDAT^PXRMDGPT(DFN,.TAXARR,NGET,SDIR,BDT,EDT,"ICD0",.TLIST) - ; - I (NICD9>0),INS D FPDAT^PXRMDGPT(DFN,.TAXARR,NGET,SDIR,BDT,EDT,"ICD9",.TLIST) - I (NICD9>0),ENS D FPDAT^PXRMVPOV(DFN,.TAXARR,NGET,SDIR,BDT,EDT,.TLIST) - I (NICD9>0),PLS D - . K STATUSA - . D GETSTATI^PXRMSTAT(9000011,.FINDPA,.STATUSA) - . D FPDAT^PXRMPROB(DFN,.TAXARR,NGET,SDIR,BDT,EDT,.STATUSA,.TLIST) - ; - I (NCPT>0),(ENS) D FPDAT^PXRMVCPT(DFN,.TAXARR,NGET,SDIR,BDT,EDT,.TLIST) - ; - I (NRCPT>0),(RAS) D - . K STATUSA - . D GETSTATI^PXRMSTAT(70,.FINDPA,.STATUSA) - . D FPDAT^PXRMRCPT(DFN,.TAXARR,NOCC,BDT,EDT,.STATUSA,.TLIST) - ; - ;Process the found list, returning the NOCC most recent results. - S NFOUND=0 - S DATE="" - F S DATE=$O(TLIST(DATE),SDIR) Q:(DATE="")!(NFOUND=NOCC) D - . S IND=0 - . F S IND=$O(TLIST(DATE,IND)) Q:(IND="")!(NFOUND=NOCC) D - .. S FILENUM=0 - .. F S FILENUM=$O(TLIST(DATE,IND,FILENUM)) Q:FILENUM="" D - ... S NFOUND=NFOUND+1 - ... S DAS=$P(TLIST(DATE,IND,FILENUM),U,1) - ... S FLIST(NFOUND)=TLIST(DATE,IND,FILENUM) - ... S FLIST(NFOUND)=DAS_U_DATE_U_FILENUM_U_$P(TLIST(DATE,IND,FILENUM),U,2,10) - I NFOUND=0 S FIEVAL=0 Q - S NP=0 - F IND=1:1:NFOUND Q:NP=NOCC D - . S DAS=$P(FLIST(IND),U,1) - . S FILENUM=$P(FLIST(IND),U,3) - . D GETDATA^PXRMDATA(FILENUM,DAS,.FIEVT) - . I $D(FIEVT("VISIT")) D GETDATA^PXRMVSIT(FIEVT("VISIT"),.FIEVT,0) - . S CONVAL=$S(COND'="":$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.FIEVT),1:1) - . S SAVE=$S('UCIFS:1,(UCIFS&CONVAL):1,1:0) - . I SAVE D - .. S NP=NP+1 - .. S FIEVAL(NP)=CONVAL - .. S FIEVAL(NP,"CONDITION")=CONVAL - .. S FIEVAL(NP,"CODEP")=$P(FLIST(IND),U,4) - .. S FIEVAL(NP,"DAS")=DAS - .. S FIEVAL(NP,"DATE")=$P(FLIST(IND),U,2) - .. S FIEVAL(NP,"FILE NUMBER")=FILENUM - .. S FIEVAL(NP,"FILE SPECIFIC")=$P(FLIST(IND),U,5,10) - .. S FIEVAL(NP,"FINDING")=TAXIEN_";PXD(811.2," - .. M FIEVAL(NP)=FIEVT - .. I $G(PXRMDEBG) M FIEVAL(NP,"CSUB")=FIEVT - ;Save the finding result. - D SFRES^PXRMUTIL(SDIR,NP,.FIEVAL) - Q - ; - ;================================================== -GPLIST(TAXIEN,FINDPA,PLIST) ;Get the list of patients with - ;taxonomy TAXIEN. Return the list as: - ; ^TMP($J,PLIST,T/F,DFN,TAXIEN,COUNT,FILE NUMBER) - ; =DAS^DATE^CODE^TYPE^file specific. TAXIEN is like the item for - ;non-taxonomy findings. - N BDT,COND,DATE,DFN,DLIST,EDT,ENS,FILENUM - N ICOND,IND,INS,IPLIST - N NF,NFOUND,NICD0,NICD9,NCPT,NF,NGET,NOCC,NRCPT - N PLS,RAS,STATUSA,UCIFS,USEINP,TAXARR,TF,TLIST,VSLIST - ;Set the finding search parameters. - S TLIST="GPLIST_PXRMTAX" - K ^TMP($J,TLIST) - D SSPAR^PXRMUTIL(FINDPA(0),.NOCC,.BDT,.EDT) - D TAX^PXRMLDR(TAXIEN,.TAXARR) - D SETVAR^PXRMTAXS(.TAXARR,.ENS,.INS,.NICD0,.NICD9,.NCPT,.NRCPT,.PLS,.RAS) - D SCPAR^PXRMCOND(.FINDPA,.COND,.UCIFS,.ICOND,.VSLIST) - ; - I (NICD0>0),INS D GPLIST^PXRMDGPT(.TAXARR,NOCC,BDT,EDT,"ICD0",TLIST) - ; - I (NICD9>0),INS D GPLIST^PXRMDGPT(.TAXARR,NOCC,BDT,EDT,"ICD9",TLIST) - I (NICD9>0),PLS D - . K STATUSA - . D GETSTATI^PXRMSTAT(9000011,.FINDPA,.STATUSA) - . D GPLIST^PXRMPROB(.TAXARR,NOCC,BDT,EDT,.STATUSA,TLIST) - I (NICD9>0),ENS D GPLIST^PXRMVPOV(.TAXARR,NOCC,BDT,EDT,TLIST) - ; - I (NCPT>0),ENS D GPLIST^PXRMVCPT(.TAXARR,NOCC,BDT,EDT,TLIST) - ; - I (NRCPT>0),RAS D GPLIST^PXRMRCPT(.TAXARR,.FINDPA,TLIST) - ;Conditions for taxonomies only apply to radiology findings, this - ;is taken care of in PXRMRCPT. - ;Process the found list, return up to NOCC of the most recent entries. - F TF=0,1 D - . I '$D(^TMP($J,TLIST,TF)) Q - . S DFN="" - . F S DFN=$O(^TMP($J,TLIST,TF,DFN)) Q:DFN="" D - .. K DLIST,IPLIST - .. S NFOUND=0 - .. S NF="" - .. F S NF=$O(^TMP($J,TLIST,TF,DFN,NF),-1) Q:NF="" D - ... S FILENUM=0 - ... F S FILENUM=$O(^TMP($J,TLIST,TF,DFN,NF,FILENUM)) Q:FILENUM="" D - .... S NFOUND=NFOUND+1 - .... S DATE=$P(^TMP($J,TLIST,TF,DFN,NF,FILENUM),U,2) - .... S DLIST(DATE,NFOUND)=NF_U_FILENUM - ..; - .. S DATE="",NFOUND=0 - .. F S DATE=$O(DLIST(DATE),-1) Q:(DATE="")!(NFOUND=NOCC) D - ... S NF=0 - ... F S NF=$O(DLIST(DATE,NF)) Q:(NF="")!(NFOUND=NOCC) D - .... S NFOUND=NFOUND+1 - .... S IND=$P(DLIST(DATE,NF),U,1) - .... S FILENUM=$P(DLIST(DATE,NF),U,2) - .... S IPLIST(TF,DFN,TAXIEN,NFOUND,FILENUM)=^TMP($J,TLIST,TF,DFN,IND,FILENUM) - .. M ^TMP($J,PLIST)=IPLIST - K ^TMP($J,TLIST) - Q - ; - ;================================================== -MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output. - N IND,FILENUM,FNA,OCCLIST,TIFIEVAL - S IND=0 - F S IND=+$O(IFIEVAL(IND)) Q:IND=0 S FILENUM=IFIEVAL(IND,"FILE NUMBER"),FNA(FILENUM,IND)="" - S FILENUM="" - F S FILENUM=$O(FNA(FILENUM)) Q:FILENUM="" D - . K OCCLIST - . M OCCLIST=FNA(FILENUM) - . I FILENUM=45 D MHVOUT^PXRMDGPT(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q - . I FILENUM=70 D MHVOUT^PXRMRCPT(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q - . I FILENUM=9000010.07 D MHVOUT^PXRMVPOV(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q - . I FILENUM=9000010.18 D MHVOUT^PXRMVCPT(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q - . I FILENUM=9000011 D MHVOUT^PXRMPROB(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) - Q - ; - ;================================================== -OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical - ;maintenance output. - N IND,FILENUM,FNA,OCCLIST,TIFIEVAL - S IND=0 - F S IND=+$O(IFIEVAL(IND)) Q:IND=0 S FILENUM=IFIEVAL(IND,"FILE NUMBER"),FNA(FILENUM,IND)="" - S FILENUM="" - F S FILENUM=$O(FNA(FILENUM)) Q:FILENUM="" D - . K OCCLIST - . M OCCLIST=FNA(FILENUM) - . I FILENUM=45 D OUTPUT^PXRMDGPT(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q - . I FILENUM=70 D OUTPUT^PXRMRCPT(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q - . I FILENUM=9000010.07 D OUTPUT^PXRMVPOV(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q - . I FILENUM=9000010.18 D OUTPUT^PXRMVCPT(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q - . I FILENUM=9000011 D OUTPUT^PXRMPROB(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) - Q - ; +PXRMTAX ; SLC/PKR - Handle taxonomy finding. ;07/17/2006 + ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21 + ; + ;================================================== +EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate taxonomy findings. + N FIEVT,FINDPA,FINDING + N TAXIEN + S TAXIEN="" + F S TAXIEN=$O(DEFARR("E",ENODE,TAXIEN)) Q:+TAXIEN=0 D + . S FINDING="" + . F S FINDING=$O(DEFARR("E",ENODE,TAXIEN,FINDING)) Q:+FINDING=0 D + .. K FINDPA + .. M FINDPA=DEFARR(20,FINDING) + .. K FIEVT + .. D FIEVAL(DFN,TAXIEN,.FINDPA,.FIEVT) + .. M FIEVAL(FINDING)=FIEVT + Q + ; + ;================================================== +EVALPL(FINDPA,ENODE,TERMARR,PLIST) ;Evaluate taxonomy terms for + ;building patient lists. + N PFIND3,PFIND4,PFINDPA,TAXIEN + N TFINDPA,TFINDING + S TAXIEN="" + F S TAXIEN=$O(TERMARR("E",ENODE,TAXIEN)) Q:+TAXIEN=0 D + . S TFINDING="" + . F S TFINDING=$O(TERMARR("E",ENODE,TAXIEN,TFINDING)) Q:+TFINDING=0 D + .. K PFINDPA,TFINDPA + .. M TFINDPA=TERMARR(20,TFINDING) + ..;Set the finding parameters. + .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA) + .. D GPLIST(TAXIEN,.PFINDPA,PLIST) + Q + ; + ;================================================== +EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;Evaluate taxonomy + ;terms. + N FIEVT,PFINDPA + N TAXIEN,TFINDPA,TFINDING + S TAXIEN="" + F S TAXIEN=$O(TERMARR("E",ENODE,TAXIEN)) Q:+TAXIEN=0 D + . S TFINDING="" + . F S TFINDING=$O(TERMARR("E",ENODE,TAXIEN,TFINDING)) Q:+TFINDING=0 D + .. K FIEVT,PFINDPA,TFINDPA + .. M TFINDPA=TERMARR(20,TFINDING) + ..;Set the finding parameters. + .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA) + .. D FIEVAL(DFN,TAXIEN,.PFINDPA,.FIEVT) + .. M TFIEVAL(TFINDING)=FIEVT + Q + ; + ;================================================== +FIEVAL(DFN,TAXIEN,FINDPA,FIEVAL) ; + N BDT,CASESEN,COND,CONVAL,DAS,DATE,EDT,ENS,FIEVT,FILENUM,FLIST + N ICOND,IND,INS,INVFD + N NFOUND,NGET,NICD0,NICD9,NCPT,NOCC,NP,NRCPT,PLS + N RAS,SAVE,SDIR,STATUSA,TAXARR,TLIST,UCIFS,USEINP,VSLIST + ;Set the finding search parameters. + D SSPAR^PXRMUTIL(FINDPA(0),.NOCC,.BDT,.EDT) + S INVFD=$P(FINDPA(0),U,16) + D TAX^PXRMLDR(TAXIEN,.TAXARR) + I TAXARR(0)["NO LOCK" S FIEVAL(1)=0 Q + D SETVAR^PXRMTAXS(.TAXARR,.ENS,.INS,.NICD0,.NICD9,.NCPT,.NRCPT,.PLS,.RAS) + D SCPAR^PXRMCOND(.FINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST) + S SDIR=$S(NOCC<0:+1,1:-1) + S NOCC=$S(NOCC<0:-NOCC,1:NOCC) + S NGET=$S(UCIFS:"*",1:NOCC) + ; + I (NICD0>0),INS D FPDAT^PXRMDGPT(DFN,.TAXARR,NGET,SDIR,BDT,EDT,"ICD0",.TLIST) + ; + I (NICD9>0),INS D FPDAT^PXRMDGPT(DFN,.TAXARR,NGET,SDIR,BDT,EDT,"ICD9",.TLIST) + I (NICD9>0),ENS D FPDAT^PXRMVPOV(DFN,.TAXARR,NGET,SDIR,BDT,EDT,.TLIST) + I (NICD9>0),PLS D + . K STATUSA + . D GETSTATI^PXRMSTAT(9000011,.FINDPA,.STATUSA) + . D FPDAT^PXRMPROB(DFN,.TAXARR,NGET,SDIR,BDT,EDT,.STATUSA,.TLIST) + ; + I (NCPT>0),(ENS) D FPDAT^PXRMVCPT(DFN,.TAXARR,NGET,SDIR,BDT,EDT,.TLIST) + ; + I (NRCPT>0),(RAS) D + . K STATUSA + . D GETSTATI^PXRMSTAT(70,.FINDPA,.STATUSA) + . D FPDAT^PXRMRCPT(DFN,.TAXARR,NOCC,BDT,EDT,.STATUSA,.TLIST) + ; + ;Process the found list, returning the NOCC most recent results. + S NFOUND=0 + S DATE="" + F S DATE=$O(TLIST(DATE),SDIR) Q:(DATE="")!(NFOUND=NOCC) D + . S IND=0 + . F S IND=$O(TLIST(DATE,IND)) Q:(IND="")!(NFOUND=NOCC) D + .. S FILENUM=0 + .. F S FILENUM=$O(TLIST(DATE,IND,FILENUM)) Q:FILENUM="" D + ... S NFOUND=NFOUND+1 + ... S DAS=$P(TLIST(DATE,IND,FILENUM),U,1) + ... S FLIST(NFOUND)=TLIST(DATE,IND,FILENUM) + ... S FLIST(NFOUND)=DAS_U_DATE_U_FILENUM_U_$P(TLIST(DATE,IND,FILENUM),U,2,10) + I NFOUND=0 S FIEVAL=0 Q + S NP=0 + F IND=1:1:NFOUND Q:NP=NOCC D + . S DAS=$P(FLIST(IND),U,1) + . S FILENUM=$P(FLIST(IND),U,3) + . D GETDATA^PXRMDATA(FILENUM,DAS,.FIEVT) + . I $D(FIEVT("VISIT")) D GETDATA^PXRMVSIT(FIEVT("VISIT"),.FIEVT,0) + . S CONVAL=$S(COND'="":$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.FIEVT),1:1) + . S SAVE=$S('UCIFS:1,(UCIFS&CONVAL):1,1:0) + . I SAVE D + .. S NP=NP+1 + .. S FIEVAL(NP)=CONVAL + .. S FIEVAL(NP,"CONDITION")=CONVAL + .. S FIEVAL(NP,"CODEP")=$P(FLIST(IND),U,4) + .. S FIEVAL(NP,"DAS")=DAS + .. S FIEVAL(NP,"DATE")=$P(FLIST(IND),U,2) + .. S FIEVAL(NP,"FILE NUMBER")=FILENUM + .. S FIEVAL(NP,"FILE SPECIFIC")=$P(FLIST(IND),U,5,10) + .. S FIEVAL(NP,"FINDING")=TAXIEN_";PXD(811.2," + .. M FIEVAL(NP)=FIEVT + .. I $G(PXRMDEBG) M FIEVAL(NP,"CSUB")=FIEVT + ;Save the finding result. + D SFRES^PXRMUTIL(SDIR,NP,.FIEVAL) + Q + ; + ;================================================== +GPLIST(TAXIEN,FINDPA,PLIST) ;Get the list of patients with + ;taxonomy TAXIEN. Return the list as: + ; ^TMP($J,PLIST,T/F,DFN,TAXIEN,COUNT,FILE NUMBER) + ; =DAS^DATE^CODE^TYPE^file specific. TAXIEN is like the item for + ;non-taxonomy findings. + N BDT,COND,DATE,DFN,DLIST,EDT,ENS,FILENUM + N ICOND,IND,INS,IPLIST + N NF,NFOUND,NICD0,NICD9,NCPT,NF,NGET,NOCC,NRCPT + N PLS,RAS,STATUSA,UCIFS,USEINP,TAXARR,TF,TLIST,VSLIST + ;Set the finding search parameters. + S TLIST="GPLIST_PXRMTAX" + K ^TMP($J,TLIST) + D SSPAR^PXRMUTIL(FINDPA(0),.NOCC,.BDT,.EDT) + D TAX^PXRMLDR(TAXIEN,.TAXARR) + D SETVAR^PXRMTAXS(.TAXARR,.ENS,.INS,.NICD0,.NICD9,.NCPT,.NRCPT,.PLS,.RAS) + D SCPAR^PXRMCOND(.FINDPA,.COND,.UCIFS,.ICOND,.VSLIST) + ; + I (NICD0>0),INS D GPLIST^PXRMDGPT(.TAXARR,NOCC,BDT,EDT,"ICD0",TLIST) + ; + I (NICD9>0),INS D GPLIST^PXRMDGPT(.TAXARR,NOCC,BDT,EDT,"ICD9",TLIST) + I (NICD9>0),PLS D + . K STATUSA + . D GETSTATI^PXRMSTAT(9000011,.FINDPA,.STATUSA) + . D GPLIST^PXRMPROB(.TAXARR,NOCC,BDT,EDT,.STATUSA,TLIST) + I (NICD9>0),ENS D GPLIST^PXRMVPOV(.TAXARR,NOCC,BDT,EDT,TLIST) + ; + I (NCPT>0),ENS D GPLIST^PXRMVCPT(.TAXARR,NOCC,BDT,EDT,TLIST) + ; + I (NRCPT>0),RAS D GPLIST^PXRMRCPT(.TAXARR,.FINDPA,TLIST) + ;Conditions for taxonomies only apply to radiology findings, this + ;is taken care of in PXRMRCPT. + ;Process the found list, return up to NOCC of the most recent entries. + F TF=0,1 D + . I '$D(^TMP($J,TLIST,TF)) Q + . S DFN="" + . F S DFN=$O(^TMP($J,TLIST,TF,DFN)) Q:DFN="" D + .. K DLIST,IPLIST + .. S NFOUND=0 + .. S NF="" + .. F S NF=$O(^TMP($J,TLIST,TF,DFN,NF),-1) Q:NF="" D + ... S FILENUM=0 + ... F S FILENUM=$O(^TMP($J,TLIST,TF,DFN,NF,FILENUM)) Q:FILENUM="" D + .... S NFOUND=NFOUND+1 + .... S DATE=$P(^TMP($J,TLIST,TF,DFN,NF,FILENUM),U,2) + .... S DLIST(DATE,NFOUND)=NF_U_FILENUM + ..; + .. S DATE="",NFOUND=0 + .. F S DATE=$O(DLIST(DATE),-1) Q:(DATE="")!(NFOUND=NOCC) D + ... S NF=0 + ... F S NF=$O(DLIST(DATE,NF)) Q:(NF="")!(NFOUND=NOCC) D + .... S NFOUND=NFOUND+1 + .... S IND=$P(DLIST(DATE,NF),U,1) + .... S FILENUM=$P(DLIST(DATE,NF),U,2) + .... S IPLIST(TF,DFN,TAXIEN,NFOUND,FILENUM)=^TMP($J,TLIST,TF,DFN,IND,FILENUM) + .. M ^TMP($J,PLIST)=IPLIST + K ^TMP($J,TLIST) + Q + ; + ;================================================== +MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output. + N IND,FILENUM,FNA,OCCLIST,TIFIEVAL + S IND=0 + F S IND=+$O(IFIEVAL(IND)) Q:IND=0 S FILENUM=IFIEVAL(IND,"FILE NUMBER"),FNA(FILENUM,IND)="" + S FILENUM="" + F S FILENUM=$O(FNA(FILENUM)) Q:FILENUM="" D + . K OCCLIST + . M OCCLIST=FNA(FILENUM) + . I FILENUM=45 D MHVOUT^PXRMDGPT(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q + . I FILENUM=70 D MHVOUT^PXRMRCPT(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q + . I FILENUM=9000010.07 D MHVOUT^PXRMVPOV(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q + . I FILENUM=9000010.18 D MHVOUT^PXRMVCPT(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q + . I FILENUM=9000011 D MHVOUT^PXRMPROB(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) + Q + ; + ;================================================== +OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical + ;maintenance output. + N IND,FILENUM,FNA,OCCLIST,TIFIEVAL + S IND=0 + F S IND=+$O(IFIEVAL(IND)) Q:IND=0 S FILENUM=IFIEVAL(IND,"FILE NUMBER"),FNA(FILENUM,IND)="" + S FILENUM="" + F S FILENUM=$O(FNA(FILENUM)) Q:FILENUM="" D + . K OCCLIST + . M OCCLIST=FNA(FILENUM) + . I FILENUM=45 D OUTPUT^PXRMDGPT(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q + . I FILENUM=70 D OUTPUT^PXRMRCPT(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q + . I FILENUM=9000010.07 D OUTPUT^PXRMVPOV(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q + . I FILENUM=9000010.18 D OUTPUT^PXRMVCPT(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q + . I FILENUM=9000011 D OUTPUT^PXRMPROB(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMTERM.m b/r/CLINICAL_REMINDERS-PXRM/PXRMTERM.m index e73007e6..675c69a6 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMTERM.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMTERM.m @@ -1,193 +1,227 @@ -PXRMTERM ; SLC/PKR - Handle reminder terms. ;04/23/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ;============================================= -COPY(NOCC,SDIR,TFIEVAL,DATEORDR,FINDING,FIEVAL) ;Copy the NOCC date ordered - ;findings from TFIEVAL to FIEVAL(FINDING). - N DATE,IND,JND,MRS,NFOUND,TFI - ;Start with most recent and go to oldest finding. - S MRS=1 - S NFOUND=0 - S DATE="" - F S DATE=$O(DATEORDR(DATE),SDIR) Q:(NFOUND=NOCC)!(DATE="") D - . S TFI=0 - . F S TFI=$O(DATEORDR(DATE,TFI)) Q:(NFOUND=NOCC)!(TFI="") D - .. I MRS D - ...;Save the main result node. - ... S FIEVAL(FINDING)=TFIEVAL(TFI) - ... S MRS=0 - ... I 'FIEVAL(FINDING) Q - ... S JND="@" - ... F S JND=$O(TFIEVAL(TFI,JND)) Q:JND="" M FIEVAL(FINDING,JND)=TFIEVAL(TFI,JND) - .. I 'FIEVAL(FINDING) Q - .. S IND=0 - .. F S IND=$O(DATEORDR(DATE,TFI,IND)) Q:(NFOUND=NOCC)!(IND="") D - ...;Only save true sub-results. - ... I 'TFIEVAL(TFI,IND) Q - ... S NFOUND=NFOUND+1 - ... M FIEVAL(FINDING,NFOUND)=TFIEVAL(TFI,IND) - ... S FIEVAL(FINDING,NFOUND,"FILE NUMBER")=TFIEVAL(TFI,"FILE NUMBER") - ... S FIEVAL(FINDING,NFOUND,"FINDING")=TFIEVAL(TFI,"FINDING") - ... S JND=0 - ... F S JND=$O(TFIEVAL(TFI,IND,JND)) Q:JND="" M FIEVAL(FINDING,NFOUND,JND)=TFIEVAL(TFI,IND,JND) - Q - ; - ;============================================= -DORDER(TFIEVAL,DATEORDR) ;Order term findings by date, term finding, - ;and term finding occurrence. - N DATE,FI,IND - K DATEORDR - S FI=0 - F S FI=+$O(TFIEVAL(FI)) Q:FI=0 D - . S IND=0 - . F S IND=+$O(TFIEVAL(FI,IND)) Q:IND=0 D - .. S DATE=$G(TFIEVAL(FI,IND,"DATE")) - .. I DATE'="" S DATEORDR(DATE,FI,IND)="" - Q - ; - ;============================================= -EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate all reminder terms in a - ;definition. - N CASESEN,CONVAL,DATE,DATEORDR - N FIEVT,FINDING,FINDPA,IND,NOCC - N SDIR,TFIND3,TFIND4,TERMARR,TERMIEN,TFI,TFIEVAL,UCIFS - S TERMIEN="" - F S TERMIEN=$O(DEFARR("E",ENODE,TERMIEN)) Q:+TERMIEN=0 D - . I '$D(^PXRMD(811.5,TERMIEN,20,"E")) D Q - .. S ^TMP(PXRMPID,$J,PXRMITEM,"WARNING","NOFI",TERMIEN)="Warning no findings items in reminder term "_$P(^PXRMD(811.5,TERMIEN,0),U,1) - .. S FINDING="" - .. F S FINDING=$O(DEFARR("E",ENODE,TERMIEN,FINDING)) Q:FINDING="" S FIEVAL(FINDING)=0 - . D TERM^PXRMLDR(TERMIEN,.TERMARR) - . S FINDING="" - . F S FINDING=$O(DEFARR("E",ENODE,TERMIEN,FINDING)) Q:+FINDING=0 D - .. S FIEVAL(FINDING)=0 - .. S FIEVAL(FINDING,"TERM")=TERMARR(0) - .. S FIEVAL(FINDING,"TERM IEN")=TERMIEN - .. K FINDPA,TFIEVAL - .. M FINDPA=DEFARR(20,FINDING) - .. D EVALTERM(DFN,.FINDPA,.TERMARR,.TFIEVAL) - .. I $G(PXRMTDEB) M ^TMP("PXRMTDEB",$J,FINDING)=TFIEVAL - ..;Set NOCC and SDIR. - .. S NOCC=$P(FINDPA(0),U,14) - .. I NOCC="" S NOCC=1 - .. S SDIR=$S(NOCC<0:+1,1:-1) - .. S NOCC=$S(NOCC<0:-NOCC,1:NOCC) - ..;Order the term findings by date. - .. D DORDER(.TFIEVAL,.DATEORDR) - .. D COPY(NOCC,SDIR,.TFIEVAL,.DATEORDR,FINDING,.FIEVAL) - Q - ; - ;============================================= -EVALTERM(DFN,FINDPA,TERMARR,TFIEVAL) ;Evaluate all the findings in - ;a term. Use the "E" cross-reference just like the finding evaluation. - N ENODE - S ENODE="" - F S ENODE=$O(TERMARR("E",ENODE)) Q:ENODE="" D - . I ENODE="AUTTEDT(" D EVALTERM^PXRMEDU(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q - . I ENODE="AUTTEXAM(" D EVALTERM^PXRMEXAM(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q - . I ENODE="AUTTHF(" D EVALTERM^PXRMHF(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q - . I ENODE="AUTTIMM(" D EVALTERM^PXRMIMM(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q - . I ENODE="AUTTSK(" D EVALTERM^PXRMSKIN(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q - . I ENODE="GMRD(120.51," D EVALTERM^PXRMVITL(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q - . I ENODE="LAB(60," D EVALTERM^PXRMLAB(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q - . I ENODE="ORD(101.43," D EVALTERM^PXRMORDR(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q - . I ENODE="PXD(811.2," D EVALTERM^PXRMTAX(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q - . I ENODE="PXRMD(810.9," D EVALTERM^PXRMLOCF(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q - . I ENODE="PXRMD(811.4," D EVALTERM^PXRMCF(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q - . I ENODE="PS(50.605," D EVALTERM^PXRMDRCL(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q - . I ENODE="PS(55," D EVALTERM^PXRMDIN(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q - . I ENODE="PS(55NVA," D EVALTERM^PXRMDNVA(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q - . I ENODE="PSDRUG(" D EVALTERM^PXRMDRUG(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q - . I ENODE="PSRX(" D EVALTERM^PXRMDOUT(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q - . 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 - Q - ; - ;============================================= -IEVALTER(DFN,FINDPA,TERMARR,FINDING,FIEVAL) ;Evaluate an individual term - ;put the result in FIEVAL(FINDING). - N DATEORDR,NOCC,SDIR,TFIEVAL - I $D(PXRMPDEM) G DEMOK - N PXRMPDEM D DEM^PXRMPINF(DFN,DT,.PXRMPDEM) - ;Create the local demographic variables for use in Condition. - N PXRMAGE,PXRMDOB,PXRMDOD,PXRMLAD,PXRMSEX - S PXRMAGE=PXRMPDEM("AGE"),PXRMDOB=PXRMPDEM("DOB"),PXRMDOD=PXRMPDEM("DOD") - S PXRMLAD=PXRMPDEM("LAD"),PXRMSEX=PXRMPDEM("SEX") -DEMOK S FIEVAL(FINDING)=0 - D EVALTERM(DFN,.FINDPA,.TERMARR,.TFIEVAL) - ;Set NOCC and SDIR. - S NOCC=$P(FINDPA(0),U,14) - I NOCC="" S NOCC=1 - S SDIR=$S(NOCC<0:+1,1:-1) - S NOCC=$S(NOCC<0:-NOCC,1:NOCC) - ;Order the term findings by date. - D DORDER(.TFIEVAL,.DATEORDR) - D COPY(NOCC,SDIR,.TFIEVAL,.DATEORDR,FINDING,.FIEVAL) - Q - ; - ;============================================= -MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output. - D OPT(INDENT,.IFIEVAL,.NLINES,.TEXT,"MHV") - Q - ; - ;============================================= -OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical - ;maintenance output. - D OPT(INDENT,.IFIEVAL,.NLINES,.TEXT,"CM") - Q - ; - ;============================================= -OPT(INDENT,IFIEVAL,NLINES,TEXT,TYPE) ;General output. - N DG,DGL,DGN,IEN,IND,JND,KND,INDENTT,FILENUM,TEMP,TIFIEVAL - ;Build the display grouping. - S FILENUM=IFIEVAL(1,"FILE NUMBER") - S IEN=$P(IFIEVAL(1,"FINDING"),";",1) - S DG(FILENUM,IEN)=1,DGL(1)=FILENUM_U_IEN,DGL(1,1)="" - S (DGN,IND)=1 - F S IND=+$O(IFIEVAL(IND)) Q:IND=0 D - . S FILENUM=IFIEVAL(IND,"FILE NUMBER") - . S IEN=$P(IFIEVAL(IND,"FINDING"),";",1) - . I '$D(DG(FILENUM,IEN)) D - .. S DGN=DGN+1,DG(FILENUM,IEN)=DGN - .. S DGL(DGN)=FILENUM_U_IEN,DGL(DGN,IND)="" - . I $D(DG(FILENUM,IEN)) D - .. S TEMP=DG(FILENUM,IEN),DGL(TEMP,IND)="" - S INDENTT=INDENT+1 - S TEMP=$$INSCHR^PXRMEXLC(INDENT," ")_"Reminder Term: "_$P(FIEVAL(FINDING,"TERM"),U,1) - S NLINES=NLINES+1,TEXT(NLINES)=TEMP - F IND=1:1:DGN D - . K TIFIEVAL - . S (JND,KND)=0 - . F S JND=$O(DGL(IND,JND)) Q:JND="" D - .. S KND=KND+1 - .. I KND=1 M TIFIEVAL=IFIEVAL(JND) - .. M TIFIEVAL(KND)=IFIEVAL(JND) - . I TYPE="CM" D FOUT^PXRMOUTC(INDENTT,.TIFIEVAL,.NLINES,.TEXT) - . I TYPE="MHV" D FOUT^PXRMOUTM(INDENTT,.TIFIEVAL,.NLINES,.TEXT) - Q - ; - ;============================================= -SPFINDPA(FINDPA,TFINDPA,PFINDPA) ;Set the finding parameter array - ;for terms. - N FIND0,PIECE,PFIND0,TFIND0,VAL - S FIND0=$G(FINDPA(0)) - S (PFIND0,TFIND0)=TFINDPA(0) - ;Set the 0 node. - F PIECE=9,10,12,13,14,15,16 D - . S VAL=$P(TFIND0,U,PIECE) - . I VAL="" S VAL=$P(FIND0,U,PIECE) - . S $P(PFIND0,U,PIECE)=VAL - ;BDT and EDT are treated as a pair. - I $P(TFIND0,U,8)="",$P(TFIND0,U,11)="" F PIECE=8,11 S $P(PFIND0,U,PIECE)=$P(FIND0,U,PIECE) - E F PIECE=8,11 S $P(PFIND0,U,PIECE)=$P(TFIND0,U,PIECE) - S PFINDPA(0)=PFIND0 - I $P($G(TFINDPA(3)),U,1)'="" S PFINDPA(3)=TFINDPA(3),PFINDPA(10)=TFINDPA(10),PFINDPA(11)=TFINDPA(11) - E S PFINDPA(3)=$G(FINDPA(3)),PFINDPA(10)=$G(FINDPA(10)),PFINDPA(11)=$G(FINDPA(11)) - ;Get the status list. - I $D(TFINDPA(5)) M PFINDPA(5)=TFINDPA(5) - E M PFINDPA(5)=FINDPA(5) - I $D(TFINDPA(15)) S PFINDPA(15)=TFINDPA(15) - E S PFINDPA(15)=$G(FINDPA(15)) - Q - ; +PXRMTERM ; SLC/PKR - Handle reminder terms. ;06/29/2006 + ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21 + ; + ;============================================= +COPY(NOCC,SDIR,TFIEVAL,DATEORDR,FINDING,FIEVAL) ;Copy the NOCC date ordered + ;findings from TFIEVAL to FIEVAL(FINDING). + N DATE,IND,JND,MRS,NFOUND,TFI + ;Start with most recent and go to oldest finding. + S MRS=1 + S NFOUND=0 + S DATE="" + F S DATE=$O(DATEORDR(DATE),SDIR) Q:(NFOUND=NOCC)!(DATE="") D + . S TFI=0 + . F S TFI=$O(DATEORDR(DATE,TFI)) Q:(NFOUND=NOCC)!(TFI="") D + .. I MRS D + ...;Save the main result node. + ... S FIEVAL(FINDING)=TFIEVAL(TFI) + ... S MRS=0 + ... I 'FIEVAL(FINDING) Q + ... S 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 + .. F S IND=$O(DATEORDR(DATE,TFI,IND)) Q:(NFOUND=NOCC)!(IND="") D + ...;Only save true sub-results. + ... I 'TFIEVAL(TFI,IND) Q + ... S NFOUND=NFOUND+1 + ... M FIEVAL(FINDING,NFOUND)=TFIEVAL(TFI,IND) + ... S FIEVAL(FINDING,NFOUND,"FILE NUMBER")=TFIEVAL(TFI,"FILE NUMBER") + ... S FIEVAL(FINDING,NFOUND,"FINDING")=TFIEVAL(TFI,"FINDING") + ... S JND=0 + ... F S JND=$O(TFIEVAL(TFI,IND,JND)) Q:JND="" M FIEVAL(FINDING,NFOUND,JND)=TFIEVAL(TFI,IND,JND) + Q + ; + ;============================================= +DORDER(TFIEVAL,DATEORDR) ;Order term findings by date, term finding, + ;and term finding occurrence. + N DATE,FI,IND + K DATEORDR + S FI=0 + F S FI=+$O(TFIEVAL(FI)) Q:FI=0 D + . S IND=0 + . F S IND=+$O(TFIEVAL(FI,IND)) Q:IND=0 D + .. S DATE=$G(TFIEVAL(FI,IND,"DATE")) + .. I DATE'="" S DATEORDR(DATE,FI,IND)="" + Q + ; + ;============================================= +EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate all reminder terms in a + ;definition. + N CASESEN,CONVAL,DATE,DATEORDR + N FIEVT,FINDING,FINDPA,IND,NOCC + N SDIR,TFIND3,TFIND4,TERMARR,TERMIEN,TFI,TFIEVAL,UCIFS + S TERMIEN="" + F S TERMIEN=$O(DEFARR("E",ENODE,TERMIEN)) Q:+TERMIEN=0 D + . I '$D(^PXRMD(811.5,TERMIEN,20,"E")) D Q + .. S ^TMP(PXRMPID,$J,PXRMITEM,"WARNING","NOFI",TERMIEN)="Warning no findings items in reminder term "_$P(^PXRMD(811.5,TERMIEN,0),U,1) + .. S FINDING="" + .. F S FINDING=$O(DEFARR("E",ENODE,TERMIEN,FINDING)) Q:FINDING="" S FIEVAL(FINDING)=0 + . D TERM^PXRMLDR(TERMIEN,.TERMARR) + . S FINDING="" + . F S FINDING=$O(DEFARR("E",ENODE,TERMIEN,FINDING)) Q:+FINDING=0 D + .. S FIEVAL(FINDING)=0 + .. S FIEVAL(FINDING,"TERM")=TERMARR(0) + .. S FIEVAL(FINDING,"TERM IEN")=TERMIEN + .. K FINDPA,TFIEVAL + .. M FINDPA=DEFARR(20,FINDING) + .. D EVALTERM(DFN,.FINDPA,.TERMARR,.TFIEVAL) + .. I $G(PXRMTDEB) M ^TMP("PXRMTDEB",$J,FINDING)=TFIEVAL + ..;Set NOCC and SDIR. + .. S NOCC=$P(FINDPA(0),U,14) + .. I NOCC="" S NOCC=1 + .. S SDIR=$S(NOCC<0:+1,1:-1) + .. S NOCC=$S(NOCC<0:-NOCC,1:NOCC) + ..;Order the term findings by date. + .. D DORDER(.TFIEVAL,.DATEORDR) + .. D COPY(NOCC,SDIR,.TFIEVAL,.DATEORDR,FINDING,.FIEVAL) + Q + ; + ;============================================= +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. + N ENODE + S ENODE="" + F S ENODE=$O(TERMARR("E",ENODE)) Q:ENODE="" D + . I ENODE="AUTTEDT(" D EVALTERM^PXRMEDU(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q + . I ENODE="AUTTEXAM(" D EVALTERM^PXRMEXAM(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q + . I ENODE="AUTTHF(" D EVALTERM^PXRMHF(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q + . I ENODE="AUTTIMM(" D EVALTERM^PXRMIMM(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q + . I ENODE="AUTTSK(" D EVALTERM^PXRMSKIN(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q + . I ENODE="GMRD(120.51," D EVALTERM^PXRMVITL(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q + . I ENODE="LAB(60," D EVALTERM^PXRMLAB(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q + . I ENODE="ORD(101.43," D EVALTERM^PXRMORDR(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q + . I ENODE="PXD(811.2," D EVALTERM^PXRMTAX(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q + . I ENODE="PXRMD(810.9," D EVALTERM^PXRMLOCF(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q + . I ENODE="PXRMD(811.4," D EVALTERM^PXRMCF(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q + . I ENODE="PS(50.605," D EVALTERM^PXRMDRCL(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q + . I ENODE="PS(55," D EVALTERM^PXRMDIN(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q + . I ENODE="PS(55NVA," D EVALTERM^PXRMDNVA(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q + . I ENODE="PSDRUG(" D EVALTERM^PXRMDRUG(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q + . I ENODE="PSRX(" D EVALTERM^PXRMDOUT(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q + . 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," D EVALTERM^PXRMMH(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q + Q + ; + ;============================================= +IEVALTER(DFN,FINDPA,TERMARR,FINDING,FIEVAL) ;Evaluate an individual term + ;put the result in FIEVAL(FINDING). + N DATEORDR,NOCC,SDIR,TFIEVAL + I $D(PXRMPDEM) G DEMOK + N PXRMPDEM D DEM^PXRMPINF(DFN,DT,.PXRMPDEM) + ;Create the local demographic variables for use in Condition. + N PXRMAGE,PXRMDOB,PXRMDOD,PXRMLAD,PXRMSEX + S PXRMAGE=PXRMPDEM("AGE"),PXRMDOB=PXRMPDEM("DOB"),PXRMDOD=PXRMPDEM("DOD") + S PXRMLAD=PXRMPDEM("LAD"),PXRMSEX=PXRMPDEM("SEX") +DEMOK S FIEVAL(FINDING)=0 + D EVALTERM(DFN,.FINDPA,.TERMARR,.TFIEVAL) + ;Set NOCC and SDIR. + S NOCC=$P(FINDPA(0),U,14) + I NOCC="" S NOCC=1 + S SDIR=$S(NOCC<0:+1,1:-1) + S NOCC=$S(NOCC<0:-NOCC,1:NOCC) + ;Order the term findings by date. + D DORDER(.TFIEVAL,.DATEORDR) + D COPY(NOCC,SDIR,.TFIEVAL,.DATEORDR,FINDING,.FIEVAL) + Q + ; + ;============================================= +MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output. + D OPT(INDENT,.IFIEVAL,.NLINES,.TEXT,"MHV") + Q + ; + ;============================================= +OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical + ;maintenance output. + D OPT(INDENT,.IFIEVAL,.NLINES,.TEXT,"CM") + Q + ; + ;============================================= +OPT(INDENT,IFIEVAL,NLINES,TEXT,TYPE) ;General output. + 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") + S IEN=$P(IFIEVAL(1,"FINDING"),";",1) + S DG(FILENUM,IEN)=1,DGL(1)=FILENUM_U_IEN,DGL(1,1)="" + S (DGN,IND)=1 + F S IND=+$O(IFIEVAL(IND)) Q:IND=0 D + . S FILENUM=IFIEVAL(IND,"FILE NUMBER") + . S IEN=$P(IFIEVAL(IND,"FINDING"),";",1) + . I '$D(DG(FILENUM,IEN)) D + .. S DGN=DGN+1,DG(FILENUM,IEN)=DGN + .. S DGL(DGN)=FILENUM_U_IEN,DGL(DGN,IND)="" + . I $D(DG(FILENUM,IEN)) D + .. S TEMP=DG(FILENUM,IEN),DGL(TEMP,IND)="" + S INDENTT=INDENT+1 + S TEMP=$$INSCHR^PXRMEXLC(INDENT," ")_"Reminder Term: "_$P(FIEVAL(FINDING,"TERM"),U,1) + S NLINES=NLINES+1,TEXT(NLINES)=TEMP + F IND=1:1:DGN D + . K TIFIEVAL + . S (JND,KND)=0 + . F S JND=$O(DGL(IND,JND)) Q:JND="" D + .. S KND=KND+1 + .. 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) + Q + ; + ;============================================= +SPFINDPA(FINDPA,TFINDPA,PFINDPA) ;Set the finding parameter array + ;for terms. + N FIND0,PIECE,PFIND0,TFIND0,VAL + S FIND0=$G(FINDPA(0)) + S (PFIND0,TFIND0)=TFINDPA(0) + ;Set the 0 node. + F PIECE=9,10,12,13,14,15,16 D + . S VAL=$P(TFIND0,U,PIECE) + . I VAL="" S VAL=$P(FIND0,U,PIECE) + . S $P(PFIND0,U,PIECE)=VAL + ;BDT and EDT are treated as a pair. + I $P(TFIND0,U,8)="",$P(TFIND0,U,11)="" F PIECE=8,11 S $P(PFIND0,U,PIECE)=$P(FIND0,U,PIECE) + E F PIECE=8,11 S $P(PFIND0,U,PIECE)=$P(TFIND0,U,PIECE) + S PFINDPA(0)=PFIND0 + I $P($G(TFINDPA(3)),U,1)'="" S PFINDPA(3)=TFINDPA(3),PFINDPA(10)=TFINDPA(10),PFINDPA(11)=TFINDPA(11) + E S PFINDPA(3)=$G(FINDPA(3)),PFINDPA(10)=$G(FINDPA(10)),PFINDPA(11)=$G(FINDPA(11)) + ;Get the status list. + I $D(TFINDPA(5)) M PFINDPA(5)=TFINDPA(5) + E M PFINDPA(5)=FINDPA(5) + I $D(TFINDPA(15)) S PFINDPA(15)=TFINDPA(15) + E S PFINDPA(15)=$G(FINDPA(15)) + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMTEXT.m b/r/CLINICAL_REMINDERS-PXRM/PXRMTEXT.m index 9a9d4190..b83d6759 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMTEXT.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMTEXT.m @@ -1,201 +1,94 @@ -PXRMTEXT ; SLC/PKR - Text formatting utility routines. ;07/19/2007 - ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123 - ; - ;============================================ -NEWLINE ;Put TEXT on a new line to the output, make sure it does not end - ;with a " ". - N TLEN - ;If there is no text in TEXT don't do anything. - I TEXT=INDSTR Q - S TLEN=$L(TEXT) - I $E(TEXT,TLEN)=" " S TEXT=$E(TEXT,1,TLEN-1) - S NOUT=NOUT+1,TEXTOUT(NOUT)=TEXT - S TEXT=INDSTR,CLEN=0 - Q - ; - ;============================================ -BLANK ;Add a blank line (line containing just " ") to the output. - S NOUT=NOUT+1,TEXTOUT(NOUT)=" " - S TEXT=INDSTR,CLEN=0 - 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. - N LENWORD - S LENWORD=$L(WORD) - I (CLEN+LENWORD)>WIDTH D - . D NEWLINE - . I WORD'[" " S WORD=WORD_" ",LENWORD=LENWORD+1 - . S TEXT=INDSTR_WORD,CLEN=LENWORD - E D - . I WORD'[" " S WORD=WORD_" ",LENWORD=LENWORD+1 - . S TEXT=TEXT_WORD,CLEN=CLEN+LENWORD - 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 - ;is in TEXTOUT. "\\" is the end of line marker. Lines ending with - ;"\\" will not have anything appended to them. A blank line can - ;be created by creating a line containing just "\\". Lines containing - ;nothing but whitespace will also act like a "\\". - I NIN=0 S NOUT=0 Q - N ACHAR,ALLWSP,CHAR,CLEN,END,IND,INDENT,INDSTR,JND - N LWSP,NWSP,START,TEMP,TEXT,TLEN,WIDTH,W1,W2,WORD - ;Catalog the whitespace so we have places to break and look for - ;end of line markers. - F IND=1:1:NIN D - . S TEMP=TEXTIN(IND) - . S TLEN=$L(TEMP) - . S ALLWSP=1,NWSP=0 - . F JND=1:1:TLEN D - .. S CHAR=$E(TEMP,JND) - .. S ACHAR=$A(CHAR) - .. I ACHAR>32 S ALLWSP=0 - .. E S NWSP=NWSP+1,LWSP(IND,NWSP)=JND - .;Mark the end of the line. - . S NWSP=NWSP+1,LWSP(IND,NWSP)=TLEN,LWSP(IND)=NWSP - . I ALLWSP S LWSP(IND,"ALLWSP")="" - I LM<1 S LM=1 - S WIDTH=RM-LM+1 - S INDENT=LM-1 - S INDSTR="" - F IND=1:1:INDENT S INDSTR=INDSTR_" " - S NOUT=0 - S TEXT=INDSTR,CLEN=0 - F IND=1:1:NIN D - .;If there is a blank line force whatever is in TEXT to be output by - .;calling NEWLINE and then add the blank. - . I $D(LWSP(IND,"ALLWSP")) D NEWLINE,BLANK Q - . S TEMP=TEXTIN(IND) - . S (END,NWSP)=0 - . F NWSP=1:1:LWSP(IND) D - .. S START=END+1,END=LWSP(IND,NWSP) - .. S WORD=$E(TEMP,START,END) - .. I WORD["\\" D Q - ... S W1=$P(WORD,"\\",1) - ... D CHECKLEN(W1) - ... D NEWLINE - ... S W2=$P(WORD,"\\",2) - ... I W2'="" D CHECKLEN(W2) - .. D CHECKLEN(WORD) - ;Output the last line. - D NEWLINE - Q - ; - ;============================================ -FORMATS(LM,RM,TEXTLINE,NOUT,TEXTOUT) ;Take a single line of input text - ;and format it. - N TEXTIN - S TEXTIN(1)=TEXTLINE - D FORMAT(LM,RM,1,.TEXTIN,.NOUT,.TEXTOUT) - 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 - ; +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 " ". + N TLEN + ;If there is no text in TEXT don't do anything. + I TEXT=INDSTR Q + S TLEN=$L(TEXT) + I $E(TEXT,TLEN)=" " S TEXT=$E(TEXT,1,TLEN-1) + S NOUT=NOUT+1,TEXTOUT(NOUT)=TEXT + S TEXT=INDSTR,CLEN=0 + Q + ; + ;================================================================ +BLANK ;Add a blank line (line containing just " ") to the output. + S NOUT=NOUT+1,TEXTOUT(NOUT)=" " + S TEXT=INDSTR,CLEN=0 + 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. + N LENWORD + S LENWORD=$L(WORD) + I (CLEN+LENWORD)>WIDTH D + . D NEWLINE + . I WORD'[" " S WORD=WORD_" ",LENWORD=LENWORD+1 + . S TEXT=INDSTR_WORD,CLEN=LENWORD + E D + . I WORD'[" " S WORD=WORD_" ",LENWORD=LENWORD+1 + . S TEXT=TEXT_WORD,CLEN=CLEN+LENWORD + 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 + ;is in TEXTOUT. "\\" is the end of line marker. Lines ending with + ;"\\" will not have anything appended to them. A blank line can + ;be created by creating a line containing just "\\". Lines containing + ;nothing but whitespace will also act like a "\\". + I NIN=0 S NOUT=0 Q + N ACHAR,ALLWSP,CHAR,CLEN,END,IND,INDENT,INDSTR,JND + N LWSP,NWSP,START,TEMP,TEXT,TLEN,WIDTH,W1,W2,WORD + ;Catalog the whitespace so we have places to break and look for + ;end of line markers. + F IND=1:1:NIN D + . S TEMP=TEXTIN(IND) + . S TLEN=$L(TEMP) + . S ALLWSP=1,NWSP=0 + . F JND=1:1:TLEN D + .. S CHAR=$E(TEMP,JND) + .. S ACHAR=$A(CHAR) + .. I ACHAR>32 S ALLWSP=0 + .. E S NWSP=NWSP+1,LWSP(IND,NWSP)=JND + .;Mark the end of the line. + . S NWSP=NWSP+1,LWSP(IND,NWSP)=TLEN,LWSP(IND)=NWSP + . I ALLWSP S LWSP(IND,"ALLWSP")="" + I LM<1 S LM=1 + S WIDTH=RM-LM+1 + S INDENT=LM-1 + S INDSTR="" + F IND=1:1:INDENT S INDSTR=INDSTR_" " + S NOUT=0 + S TEXT=INDSTR,CLEN=0 + F IND=1:1:NIN D + .;If there is a blank line force whatever is in TEXT to be output by + .;calling NEWLINE and then add the blank. + . I $D(LWSP(IND,"ALLWSP")) D NEWLINE,BLANK Q + . S TEMP=TEXTIN(IND) + . S (END,NWSP)=0 + . F NWSP=1:1:LWSP(IND) D + .. S START=END+1,END=LWSP(IND,NWSP) + .. S WORD=$E(TEMP,START,END) + .. I WORD["\\" D Q + ... S W1=$P(WORD,"\\",1) + ... D CHECKLEN(W1) + ... D NEWLINE + ... S W2=$P(WORD,"\\",2) + ... I W2'="" D CHECKLEN(W2) + .. D CHECKLEN(WORD) + ;Output the last line. + D NEWLINE + Q + ; + ;================================================================ +FORMATS(LM,RM,TEXTLINE,NOUT,TEXTOUT) ;Take a single line of input text + ;and format it. + N TEXTIN + S TEXTIN(1)=TEXTLINE + D FORMAT(LM,RM,1,.TEXTIN,.NOUT,.TEXTOUT) + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMTMED.m b/r/CLINICAL_REMINDERS-PXRM/PXRMTMED.m index be1a04dd..cc5ac03e 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMTMED.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMTMED.m @@ -1,116 +1,114 @@ -PXRMTMED ; SLC/PKR/PJH - Edit a reminder term. ;04/18/2007 - ;;2.0;CLINICAL REMINDERS;**1,4,6**;Feb 04, 2005;Build 123 - ; - ;======================================================= - N CS1,CS2,DA,DIC,DLAYGO,DTOUT,DUOUT,Y -GETNAME ;Get the name of the term to edit. - K DA,DIC,DLAYGO,DTOUT,DUOUT,Y - S DIC="^PXRMD(811.5," - S DIC(0)="AEMQL" - S DIC("A")="Select Reminder Term: " - S DLAYGO=811.5 - ;Set the starting place for additions. - D SETSTART^PXRMCOPY(DIC) - W ! - D ^DIC - I ($D(DTOUT))!($D(DUOUT)) Q - I Y=-1 G END - S DA=$P(Y,U,1) - S CS1=$$FILE^PXRMEXCS(811.5,DA) - D EDIT(DIC,DA) - I $G(DA)="" G GETNAME - S CS2=$$FILE^PXRMEXCS(811.5,DA) - I CS2=0 G GETNAME - I CS2'=CS1 D SEHIST^PXRMUTIL(811.5,DIC,DA) - G GETNAME -END ; - Q - ; - ;======================================================= -CLASS(DA,DIE) ; - N DR,RESULT,X,Y -RETRY W ! - S DR="100" D ^DIE I $D(Y) Q - ;Sponsor - S DR="101" D ^DIE I $D(Y) Q - ;Make sure Class and Sponsor Class are in synch. - S RESULT=$$VSPONSOR^PXRMINTR(X) - I RESULT=0 S DIE("NO^")="Other value" G RETRY - I RESULT=1 K DIE("NO^") - ;Review date, Usage - S DR="102;1" D ^DIE I $D(Y) Q - Q - ; - ;======================================================= -EDIT(ROOT,DA) ; - N CLASS,DIC,DIE,DR,DIDEL,PXRMTMD,RESULT,TCONT,Y - ;PXRMTMD is set by a xref on the .01 as a flag that the entire - ;entry is being deleted. - S CLASS=$P($G(^PXRMD(811.5,DA,100)),U,1) - S DIE=ROOT - I CLASS'="N"!(($G(PXRMINST)=1)&($G(DUZ(0))="@")) D - . S DR=".01" - . D ^DIE - . I $G(DA)'="" D CLASS(DA,DIE) - I $G(DA)="" Q - S TCONT=1 - F D FINDING(DIE,DA) Q:TCONT=0 - Q - ; - ;======================================================= -FINDING(DIE,DA,LIST) ; - 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 NODE="^PXRMD(811.5)" - D LIST^PXRMREDT(NODE,DA,.LIST) - D DSPALL^PXRMREDF("T",NODE,DA,.LIST) - S DA(1)=DA - S IEN=DA - S DIC=DIE_DA(1)_",20," - S DIC(0)="QEAL" - S DIC("A")="Select Finding: " - D ^DIC I Y=-1 S DTOUT=1,TCONT=0 Q - S DIE=DIC - 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 - W !,"Editing Finding Number: "_$G(DA) - ;Finding record fields - S DR=".01;9;12;17" - I GLOB="PXRMD(811.4," S DR=DR_";26" - ;Taxonomy - use inactive problems - I GLOB="PXD(811.2," D - .S TERMSTAT=$$TAXNODE^PXRMSTA1($P($P(Y,U,2),";"),"H") - .I TERMSTAT="P" S DR=DR_";10" Q - .I TERMSTAT'=0 S DR=DR_";10",STATUS=1 - ;Health Factor - within category rank - I GLOB="AUTTHF(" S DR=DR_";11" - ;If V file INCLUDE VISIT DATA - S VF=$S(GLOB["AUTTEDT":1,GLOB["AUTTEXAM":1,GLOB["AUTTHF":1,GLOB["AUTTIMM":1,GLOB="AUTTSK":1,GLOB["PXD(811.2":1,1:0) - I VF S DR=DR_";28" - ;Mental Health - scale - I GLOB="YTT(601.71," S DR=DR_";13" - ;Radiology procedure - I GLOB="RAMIS(71," S STATUS=1 - ;Orderable item - I GLOB="ORD(101.43," S DR=DR_";27",STATUS=1 - ;Rx Type - I GLOB="PSDRUG("!(GLOB="PS(50.605,")!(GLOB="PSNDF(50.6,") S DR=DR_";16;27",STATUS=1 - ;Condition - S DR=DR_";14;15;18" - ; - ;Edit finding record - D ^DIE - I STATUS=1,$D(DA)>0,$D(Y)=0 D STATUS^PXRMSTA1(.DA,"T") - S $P(^PXRMD(811.5,IEN,20,0),U,3)=0 - Q - ; +PXRMTMED ; SLC/PKR/PJH - Edit a reminder term. ;01/30/2006 + ;;2.0;CLINICAL REMINDERS;**1,4**;Feb 04, 2005;Build 21 + ; + ;======================================================= + N CS1,CS2,DA,DIC,DLAYGO,DTOUT,DUOUT,Y +GETNAME ;Get the name of the term to edit. + K DA,DIC,DLAYGO,DTOUT,DUOUT,Y + S DIC="^PXRMD(811.5," + S DIC(0)="AEMQL" + S DIC("A")="Select Reminder Term: " + S DLAYGO=811.5 + ;Set the starting place for additions. + D SETSTART^PXRMCOPY(DIC) + W ! + D ^DIC + I ($D(DTOUT))!($D(DUOUT)) Q + I Y=-1 G END + S DA=$P(Y,U,1) + S CS1=$$FILE^PXRMEXCS(811.5,DA) + D EDIT(DIC,DA) + I $G(DA)="" G GETNAME + S CS2=$$FILE^PXRMEXCS(811.5,DA) + I CS2=0 G GETNAME + I CS2'=CS1 D SEHIST^PXRMUTIL(811.5,DIC,DA) + G GETNAME +END ; + Q + ; + ;======================================================= +CLASS(DA,DIE) ; + N DR,RESULT,X,Y +RETRY W ! + S DR="100" D ^DIE I $D(Y) Q + ;Sponsor + S DR="101" D ^DIE I $D(Y) Q + ;Make sure Class and Sponsor Class are in synch. + S RESULT=$$VSPONSOR^PXRMINTR(X) + I RESULT=0 S DIE("NO^")="Other value" G RETRY + I RESULT=1 K DIE("NO^") + ;Review date, Usage + S DR="102;1" D ^DIE I $D(Y) Q + Q + ; + ;======================================================= +EDIT(ROOT,DA) ; + N CLASS,DIC,DIE,DR,DIDEL,PXRMTMD,RESULT,TCONT,Y + ;PXRMTMD is set by a xref on the .01 as a flag that the entire + ;entry is being deleted. + S CLASS=$P($G(^PXRMD(811.5,DA,100)),U,1) + S DIE=ROOT + I CLASS'="N"!(($G(PXRMINST)=1)&($G(DUZ(0))="@")) D + . S DR=".01" + . D ^DIE + . I $G(DA)'="" D CLASS(DA,DIE) + I $G(DA)="" Q + S TCONT=1 + F D FINDING(DIE,DA) Q:TCONT=0 + Q + ; + ;======================================================= +FINDING(DIE,DA,LIST) ; + N CFIEN,GLOB,IEN,LIST,NODE,TERMSTAT,VF,WPIEN + N DEF,DEF1,DEF2,STATUS + S STATUS=0 + D DEF^PXRMRUTL("811.52",.DEF,.DEF1,.DEF2) + S NODE="^PXRMD(811.5)" + D LIST^PXRMREDT(NODE,DA,.LIST) + D DSPALL^PXRMREDF("T",NODE,DA,.LIST) + S DA(1)=DA + S IEN=DA + S DIC=DIE_DA(1)_",20," + S DIC(0)="QEAL" + S DIC("A")="Select Finding: " + D ^DIC I Y=-1 S DTOUT=1,TCONT=0 Q + S DIE=DIC + 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 ! + W !,"Editing Finding Number: "_$G(DA) + ;Finding record fields + S DR=".01;9;12;17" + I GLOB="PXRMD(811.4," S DR=DR_";26" + ;Taxonomy - use inactive problems + I GLOB="PXD(811.2," D + .S TERMSTAT=$$TAXNODE^PXRMSTA1($P($P(Y,U,2),";"),"H") + .I TERMSTAT="P" S DR=DR_";10" Q + .I TERMSTAT'=0 S DR=DR_";10",STATUS=1 + ;Health Factor - within category rank + I GLOB="AUTTHF(" S DR=DR_";11" + ;If V file INCLUDE VISIT DATA + S VF=$S(GLOB["AUTTEDT":1,GLOB["AUTTEXAM":1,GLOB["AUTTHF":1,GLOB["AUTTIMM":1,GLOB="AUTTSK":1,GLOB["PXD(811.2":1,1:0) + I VF S DR=DR_";28" + ;Mental Health - scale + I GLOB="YTT(601," S DR=DR_";13" + ;Radiology procedure + I GLOB="RAMIS(71," S STATUS=1 + ;Orderable item + I GLOB="ORD(101.43," S DR=DR_";27",STATUS=1 + ;Rx Type + I GLOB="PSDRUG("!(GLOB="PS(50.605,")!(GLOB="PSNDF(50.6,") S DR=DR_";16;27",STATUS=1 + ;Condition + S DR=DR_";14;15;18" + ; + ;Edit finding record + D ^DIE + I STATUS=1,$D(DA)>0 D STATUS^PXRMSTA1(.DA,"T") + S $P(^PXRMD(811.5,IEN,20,0),U,3)=0 + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMUTIL.m b/r/CLINICAL_REMINDERS-PXRM/PXRMUTIL.m index 7f4ff2bf..d7bf3f2f 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMUTIL.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMUTIL.m @@ -1,247 +1,204 @@ -PXRMUTIL ; SLC/PKR/PJH - Utility routines for use by PXRM. ;10/02/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ;================================= -ATTVALUE(STRING,ATTR,SEP,AVSEP) ;STRING contains a list of attribute value - ;pairs. Each pair is separated by SEP and the attribute value pair - ;is separated by AVSEP. Return the value for the attribute ATTR. - N AVPAIR,IND,NUMAVP,VALUE - S NUMAVP=$L(STRING,SEP) - S VALUE="" - F IND=1:1:NUMAVP Q:VALUE'="" D - . S AVPAIR=$P(STRING,SEP,IND) - . I AVPAIR[ATTR S VALUE=$P(AVPAIR,AVSEP,2) - 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). - N DONE,IND,LEN,PROOT,ROOT,START,TEMP - I REF="" Q - 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) - . W !,PROOT_IND,"=",@REF - . S REF=$Q(@REF) - . I REF'[ROOT S DONE=1 - 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. - ;If it is a local it is indexed for the broker. If it is a global - ;it should be passed in closed form i.e., ^TMP("PXRMTEST",$J). - ;It will be returned formatted for ListMan i.e., - ;^TMP("PXRMTEST",$J,N,0). - N %ZIS,ARRAY,BY,DC,DHD,DIC,DONE,FF,FILENAME,FILESPEC,FR,GBL,HFNAME - N IND,IOP,L,NOW,PATH,SUCCESS,TO,UNIQN - S BY="NUMBER",(FR,TO)=+$P(IEN,U,1),DHD="@@" - ;Make sure the PXRM WORKSTATION device exists. - D MKWSDEV^PXRMHOST - ;Set up the output file before DIP is called. - S PATH=$$PWD^%ZISH - S NOW=$$NOW^XLFDT - S NOW=$TR(NOW,".","") - S UNIQN=$J_NOW - S FILENAME="PXRMWSD"_UNIQN_".DAT" - S HFNAME=PATH_FILENAME - S IOP="PXRM WORKSTATION;80" - S %ZIS("HFSMODE")="W" - S %ZIS("HFSNAME")=HFNAME - S L=0,DIC=PXRMROOT - D EN1^DIP - ;Move the host file into a global. - S GBL="^TMP(""PXRMUTIL"",$J,1,0)" - S GBL=$NA(@GBL) - K ^TMP("PXRMUTIL",$J) - S SUCCESS=$$FTG^%ZISH(PATH,FILENAME,GBL,3) - ;Look for a form feed, remove it and all subsequent lines. - S FF=$C(12) - I $G(VAR)["^" D - . S VAR=$NA(@VAR) - . S VAR=$P(VAR,")",1) - . S VAR=VAR_",IND,0)" - . S (DONE,IND)=0 - . F Q:DONE S IND=$O(^TMP("PXRMUTIL",$J,IND)) Q:+IND=0 D - .. I ^TMP("PXRMUTIL",$J,IND,0)=FF S DONE=1 Q - .. S @VAR=^TMP("PXRMUTIL",$J,IND,0) - E D - . S (DONE,IND)=0 - . F Q:DONE S IND=$O(^TMP("PXRMUTIL",$J,IND)) Q:+IND=0 D - .. S VAR(IND)=^TMP("PXRMUTIL",$J,IND,0) - .. I VAR(IND)=FF K ARRAY(IND) S DONE=1 - K ^TMP("PXRMUTIL",$J) - ;Delete the host file. - S FILESPEC(FILENAME)="" - S SUCCESS=$$DEL^%ZISH(PATH,$NA(FILESPEC)) - 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 - ;A, N=26 returns BA etc. - N ALPH - S ALPH(0)="A",ALPH(1)="B",ALPH(2)="C",ALPH(3)="D",ALPH(4)="E" - S ALPH(5)="F",ALPH(6)="G",ALPH(7)="H",ALPH(8)="I",ALPH(9)="J" - S ALPH(10)="K",ALPH(11)="L",ALPH(12)="M",ALPH(13)="N",ALPH(14)="O" - S ALPH(15)="P",ALPH(16)="Q",ALPH(17)="R",ALPH(18)="S",ALPH(19)="T" - S ALPH(20)="U",ALPH(21)="V",ALPH(22)="W",ALPH(23)="X",ALPH(24)="Y" - S ALPH(25)="Z" - ; - N ANUM,DIGIT,NUM,P26,PC,PWR - S ANUM="",NUM=NUMBER,PWR=0 - S P26(PWR)=1 - F PWR=1:1 S P26(PWR)=26*P26(PWR-1) I P26(PWR)>NUMBER Q - S PWR=PWR-1 - F PC=PWR:-1:0 D - . S DIGIT=NUM\P26(PC) - . S ANUM=ANUM_ALPH(DIGIT) - . S NUM=NUM-(DIGIT*P26(PC)) - 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. - N DIC,DIR,DWLW,DWPK,ENTRY,FDA,FDAIEN,IENS,IND,MSG,SFN,TARGET,X,Y - K ^TMP("PXRMWP",$J) - D FIELD^DID(FILENUM,"EDIT HISTORY","","SPECIFIER","TARGET") - S SFN=+$G(TARGET("SPECIFIER")) - I SFN=0 Q - S ENTRY=ROOT_IEN_",110)" - S IND=$O(@ENTRY@("B"),-1) - S IND=IND+1 - S IENS="+"_IND_","_IEN_"," - S FDAIEN(IEN)=IEN - S FDA(SFN,IENS,.01)=$$FMTE^XLFDT($$NOW^XLFDT,"5Z") - S FDA(SFN,IENS,1)=$$GET1^DIQ(200,DUZ,.01) - ;Prompt the user for edit comments. - S DIC="^TMP(""PXRMWP"",$J," - S DWLW=72 - S DWPK=1 - W !,"Input your edit comments." - S DIR(0)="Y"_U_"AO" - S DIR("A")="Edit" - S DIR("B")="NO" - D ^DIR - I Y D - . D EN^DIWE - . K ^TMP("PXRMWP",$J,0) - . I $D(^TMP("PXRMWP",$J)) S FDA(SFN,IENS,2)="^TMP(""PXRMWP"",$J)" - D UPDATE^DIE("E","FDA","FDAIEN","MSG") - I $D(MSG) D AWRITE^PXRMUTIL("MSG") - K ^TMP("PXRMWP",$J) - Q - ; - ;================================= -SFRES(SDIR,NRES,FIEVAL) ;Save the finding result. - I NRES=0 S FIEVAL=0 Q - N DATE,IND,OA,SUB,TF - F IND=1:1:NRES S OA(FIEVAL(IND,"DATE"),FIEVAL(IND),IND)="" - ;If SDIR is positive get the oldest date otherwise get the most - ;recent date. - S DATE=$S(SDIR>0:$O(OA("")),1:$O(OA(""),-1)) - ;If there is a true finding on DATE get it. - S TF=$O(OA(DATE,""),-1) - S IND=$O(OA(DATE,TF,"")) - S FIEVAL=TF - S SUB="" - F S SUB=$O(FIEVAL(IND,SUB)) Q:SUB="" M FIEVAL(SUB)=FIEVAL(IND,SUB) - 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 - ;Convert the dates to FileMan dates. - S BDT=$S(BDT="":0,BDT=0:0,1:$$CTFMD^PXRMDATE(BDT)) - I EDT="" S EDT="T" - S EDT=$$CTFMD^PXRMDATE(EDT) - ;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 - ; - ;================================= -STRREP(STRING,TS,RS) ;Replace every occurrence of the target string (TS) - ;in STRING with the replacement string (RS). - ;Example 9.19 (page 220) in "The Complete Mumps" by John Lewkowicz: - ; F Q:STRING'[TS S STRING=$P(STRING,TS)_RS_$P(STRING,TS,2,999) - ;fails if any portion of the target string is contained in the with - ;string. Therefore a more elaborate version is required. - ; - N IND,NPCS,STR - I STRING'[TS Q STRING - ;Count the number of pieces using the target string as the delimiter. - S NPCS=$L(STRING,TS) - ;Extract the pieces and concatenate RS - S STR="" - F IND=1:1:NPCS-1 S STR=STR_$P(STRING,TS,IND)_RS - S STR=STR_$P(STRING,TS,NPCS) - Q STR - ; - ;================================= -VEDIT(ROOT,IEN) ;This is used as a DIC("S") screen to select which entries - ;a user can edit. - N CLASS,ENTRY,VALID - S ENTRY=ROOT_IEN_")" - S CLASS=$P($G(@ENTRY@(100)),U,1) - I CLASS="N" D - . I ($G(PXRMINST)=1),(DUZ(0)="@") S VALID=1 - . E S VALID=0 - E S VALID=1 - Q VALID - ; +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 + ;is separated by AVSEP. Return the value for the attribute ATTR. + N AVPAIR,IND,NUMAVP,VALUE + S NUMAVP=$L(STRING,SEP) + S VALUE="" + F IND=1:1:NUMAVP Q:VALUE'="" D + . S AVPAIR=$P(STRING,SEP,IND) + . I AVPAIR[ATTR S VALUE=$P(AVPAIR,AVSEP,2) + Q VALUE + ; + ;=========================================================== +AWRITE(REF) ;Write all the descendants of the array reference. + ;REF is the starting array reference, for example A or ^TMP("PXRM",$J). + N DONE,IND,LEN,PROOT,ROOT,START,TEMP + I REF="" Q + 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) + . W !,PROOT_IND,"=",@REF + . S REF=$Q(@REF) + . I REF'[ROOT S DONE=1 + 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. + ;If it is a local it is indexed for the broker. If it is a global + ;it should be passed in closed form i.e., ^TMP("PXRMTEST",$J). + ;It will be returned formatted for ListMan i.e., + ;^TMP("PXRMTEST",$J,N,0). + N %ZIS,ARRAY,BY,DC,DHD,DIC,DONE,FF,FILENAME,FILESPEC,FR,GBL,HFNAME + N IND,IOP,L,NOW,PATH,SUCCESS,TO,UNIQN + S BY="NUMBER",(FR,TO)=+$P(IEN,U,1),DHD="@@" + ;Make sure the PXRM WORKSTATION device exists. + D MKWSDEV^PXRMHOST + ;Set up the output file before DIP is called. + S PATH=$$PWD^%ZISH + S NOW=$$NOW^XLFDT + S NOW=$TR(NOW,".","") + S UNIQN=$J_NOW + S FILENAME="PXRMWSD"_UNIQN_".DAT" + S HFNAME=PATH_FILENAME + S IOP="PXRM WORKSTATION;80" + S %ZIS("HFSMODE")="W" + S %ZIS("HFSNAME")=HFNAME + S L=0,DIC=PXRMROOT + D EN1^DIP + ;Move the host file into a global. + S GBL="^TMP(""PXRMUTIL"",$J,1,0)" + S GBL=$NA(@GBL) + K ^TMP("PXRMUTIL",$J) + S SUCCESS=$$FTG^%ZISH(PATH,FILENAME,GBL,3) + ;Look for a form feed, remove it and all subsequent lines. + S FF=$C(12) + I $G(VAR)["^" D + . S VAR=$NA(@VAR) + . S VAR=$P(VAR,")",1) + . S VAR=VAR_",IND,0)" + . S (DONE,IND)=0 + . F Q:DONE S IND=$O(^TMP("PXRMUTIL",$J,IND)) Q:+IND=0 D + .. I ^TMP("PXRMUTIL",$J,IND,0)=FF S DONE=1 Q + .. S @VAR=^TMP("PXRMUTIL",$J,IND,0) + E D + . S (DONE,IND)=0 + . F Q:DONE S IND=$O(^TMP("PXRMUTIL",$J,IND)) Q:+IND=0 D + .. S VAR(IND)=^TMP("PXRMUTIL",$J,IND,0) + .. I VAR(IND)=FF K ARRAY(IND) S DONE=1 + K ^TMP("PXRMUTIL",$J) + ;Delete the host file. + S FILESPEC(FILENAME)="" + S SUCCESS=$$DEL^%ZISH(PATH,$NA(FILESPEC)) + 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 + ;A, N=26 returns BA etc. + N ALPH + S ALPH(0)="A",ALPH(1)="B",ALPH(2)="C",ALPH(3)="D",ALPH(4)="E" + S ALPH(5)="F",ALPH(6)="G",ALPH(7)="H",ALPH(8)="I",ALPH(9)="J" + S ALPH(10)="K",ALPH(11)="L",ALPH(12)="M",ALPH(13)="N",ALPH(14)="O" + S ALPH(15)="P",ALPH(16)="Q",ALPH(17)="R",ALPH(18)="S",ALPH(19)="T" + S ALPH(20)="U",ALPH(21)="V",ALPH(22)="W",ALPH(23)="X",ALPH(24)="Y" + S ALPH(25)="Z" + ; + N ANUM,DIGIT,NUM,P26,PC,PWR + S ANUM="",NUM=NUMBER,PWR=0 + S P26(PWR)=1 + F PWR=1:1 S P26(PWR)=26*P26(PWR-1) I P26(PWR)>NUMBER Q + S PWR=PWR-1 + F PC=PWR:-1:0 D + . S DIGIT=NUM\P26(PC) + . S ANUM=ANUM_ALPH(DIGIT) + . S NUM=NUM-(DIGIT*P26(PC)) + Q ANUM + ; + ;=========================================================== +SEHIST(FILENUM,ROOT,IEN) ;Set the edit date and edit by and prompt the + ;user for the edit comment. + N DIC,DIR,DWLW,DWPK,ENTRY,FDA,FDAIEN,IENS,IND,MSG,SFN,TARGET,X,Y + K ^TMP("PXRMWP",$J) + D FIELD^DID(FILENUM,"EDIT HISTORY","","SPECIFIER","TARGET") + S SFN=+$G(TARGET("SPECIFIER")) + I SFN=0 Q + S ENTRY=ROOT_IEN_",110)" + S IND=$O(@ENTRY@("B"),-1) + S IND=IND+1 + S IENS="+"_IND_","_IEN_"," + S FDAIEN(IEN)=IEN + S FDA(SFN,IENS,.01)=$$FMTE^XLFDT($$NOW^XLFDT,"5Z") + S FDA(SFN,IENS,1)=$$GET1^DIQ(200,DUZ,.01) + ;Prompt the user for edit comments. + S DIC="^TMP(""PXRMWP"",$J," + S DWLW=72 + S DWPK=1 + W !,"Input your edit comments." + S DIR(0)="Y"_U_"AO" + S DIR("A")="Edit" + S DIR("B")="NO" + D ^DIR + I Y D + . D EN^DIWE + . K ^TMP("PXRMWP",$J,0) + . I $D(^TMP("PXRMWP",$J)) S FDA(SFN,IENS,2)="^TMP(""PXRMWP"",$J)" + D UPDATE^DIE("E","FDA","FDAIEN","MSG") + I $D(MSG) D AWRITE^PXRMUTIL("MSG") + K ^TMP("PXRMWP",$J) + Q + ; + ;=========================================================== +SFRES(SDIR,NRES,FIEVAL) ;Save the finding result. + I NRES=0 S FIEVAL=0 Q + N DATE,IND,OA,SUB,TF + F IND=1:1:NRES S OA(FIEVAL(IND,"DATE"),FIEVAL(IND),IND)="" + ;If SDIR is positive get the oldest date otherwise get the most + ;recent date. + S DATE=$S(SDIR>0:$O(OA("")),1:$O(OA(""),-1)) + ;If there is a true finding on DATE get it. + S TF=$O(OA(DATE,""),-1) + S IND=$O(OA(DATE,TF,"")) + S FIEVAL=TF + S SUB="" + F S SUB=$O(FIEVAL(IND,SUB)) Q:SUB="" M FIEVAL(SUB)=FIEVAL(IND,SUB) + 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="" S NOCC=1 + ;Convert the dates to FileMan dates. + S BDT=$S(BDT="":0,BDT=0:0,1:$$CTFMD^PXRMDATE(BDT)) + I EDT="" S EDT="T" + S EDT=$$CTFMD^PXRMDATE(EDT) + ;If EDT does not contain a time set it to the end of the day. + I EDT'["." S EDT=EDT_".235959" + Q + ; + ;=========================================================== +STRREP(STRING,TS,RS) ;Replace every occurrence of the target string (TS) + ;in STRING with the replacement string (RS). + ;Example 9.19 (page 220) in "The Complete Mumps" by John Lewkowicz: + ; F Q:STRING'[TS S STRING=$P(STRING,TS)_RS_$P(STRING,TS,2,999) + ;fails if any portion of the target string is contained in the with + ;string. Therefore a more elaborate version is required. + ; + N IND,NPCS,STR + I STRING'[TS Q STRING + ;Count the number of pieces using the target string as the delimiter. + S NPCS=$L(STRING,TS) + ;Extract the pieces and concatenate RS + S STR="" + F IND=1:1:NPCS-1 S STR=STR_$P(STRING,TS,IND)_RS + S STR=STR_$P(STRING,TS,NPCS) + Q STR + ; + ;=========================================================== +VEDIT(ROOT,IEN) ;This is used as a DIC("S") screen to select which entries + ;a user can edit. + N CLASS,ENTRY,VALID + S ENTRY=ROOT_IEN_")" + S CLASS=$P($G(@ENTRY@(100)),U,1) + I CLASS="N" D + . I ($G(PXRMINST)=1),(DUZ(0)="@") S VALID=1 + . E S VALID=0 + E S VALID=1 + Q VALID + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMVITL.m b/r/CLINICAL_REMINDERS-PXRM/PXRMVITL.m index 3a2d15b2..fb84222b 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMVITL.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMVITL.m @@ -1,89 +1,82 @@ -PXRMVITL ; SLC/PKR - Handle vitals findings. ;09/20/2007 - ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123 - ; - ;=========================================================== -EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate vital measurement findings. - D EVALFI^PXRMINDX(DFN,.DEFARR,ENODE,.FIEVAL) - Q - ; - ;=========================================================== -EVALPL(FINDPA,ENODE,TERMARR,PLIST) ;Evaluate vital measurement - ;term findings for patient lists. - D EVALPL^PXRMINDL(.FINDPA,ENODE,.TERMARR,PLIST) - Q - ; - ;=========================================================== -EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;Evaluate vital measurement - ;terms. - D EVALTERM^PXRMINDX(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) - Q - ; - ;=========================================================== -GETDATA(DAS,FIEVT) ;Return data for a GMRV Vital Measurement entry. - N EM,IND,GMRVDATA,STOP,TEMP,TYPE - ;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" - . 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("RATE"),FIEVT("VALUE"))=$P(GMRVDATA(7),U,1) - S IND=0 - ;Load the external form of the qualifiers. - F S IND=$O(GMRVDATA(12,IND)) Q:IND="" D - . S TEMP=$P(GMRVDATA(12,IND),U,1) - .;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 - ; - ;=========================================================== -MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output. - N DATE,EM,IND,JND,NAME,NOUT,RATE,TEMP,TEXTOUT,TYPE - S TYPE=$$EXTERNAL^DILFD(120.5,.03,"",IFIEVAL("TYPE"),.EM) - S NAME="Vital Measurement: "_TYPE_" = " - S IND=0 - F S IND=+$O(IFIEVAL(IND)) Q:IND=0 D - . S RATE=$G(IFIEVAL(IND,"VALUE")) - . I RATE="" S RATE="MISSING" - . S DATE=IFIEVAL(IND,"DATE") - . S TEMP=NAME_RATE_" ("_$$EDATE^PXRMDATE(DATE)_")" - . D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT) - . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND) - S NLINES=NLINES+1,TEXT(NLINES)="" - Q - ; - ;=========================================================== -OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical - ;maintenance output. - N DATE,EM,IND,JND,NOUT,RATE,TEMP,TEXTOUT,TYPE - S NLINES=NLINES+1 - S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Vital Measurement: "_IFIEVAL("TYPE") - S IND=0 - F S IND=+$O(IFIEVAL(IND)) Q:IND=0 D - . S DATE=IFIEVAL(IND,"DATE") - . S TEMP=$$EDATE^PXRMDATE(DATE) - . S RATE=$G(IFIEVAL(IND,"VALUE")) - . I RATE="" S RATE="MISSING" - . S TEMP=TEMP_"; rate - "_RATE - . D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT) - . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND) - .;If there are qualifiers display them. - . I $D(IFIEVAL(IND,"QUALIFIER")) D - .. S TEMP="Qualifiers:" - .. N QIND S QIND=0 - .. S QIND=$O(IFIEVAL(IND,"QUALIFIER",QIND)) S TEMP=TEMP_" "_IFIEVAL(IND,"QUALIFIER",QIND) - .. F S QIND=$O(IFIEVAL(IND,"QUALIFIER",QIND)) Q:QIND="" S TEMP=TEMP_", "_IFIEVAL(IND,"QUALIFIER",QIND) - .. D FORMATS^PXRMTEXT(INDENT+3,PXRMRM,TEMP,.NOUT,.TEXTOUT) - .. F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND) - S NLINES=NLINES+1,TEXT(NLINES)="" - Q - ; +PXRMVITL ; SLC/PKR - Handle vitals findings. ;10/21/2004 + ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005 + ; + ;=========================================================== +EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate vital measurement findings. + D EVALFI^PXRMINDX(DFN,.DEFARR,ENODE,.FIEVAL) + Q + ; + ;=========================================================== +EVALPL(FINDPA,ENODE,TERMARR,PLIST) ;Evaluate vital measurement + ;term findings for patient lists. + D EVALPL^PXRMINDL(.FINDPA,ENODE,.TERMARR,PLIST) + Q + ; + ;=========================================================== +EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;Evaluate vital measurement + ;terms. + D EVALTERM^PXRMINDX(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) + Q + ; + ;=========================================================== +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 ^GMRV(120.5" + . D SEND^PXRMMSG("Bad entry in Vitals index.") + S FIEVT("TYPE")=$P(GMRVDATA(3),U,1) + S (FIEVT("RATE"),FIEVT("VALUE"))=$P(GMRVDATA(7),U,1) + S IND=0 + ;Load the external form of the qualifiers. + F S IND=$O(GMRVDATA(12,IND)) Q:IND="" D + . S TEMP=$P(GMRVDATA(12,IND),U,1) + .;DBIA #4504 + . I TEMP'="" S FIEVT("QUALIFIER",IND)=$P($G(^GMRD(120.52,+TEMP,0)),U,1) + Q + ; + ;=========================================================== +MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output. + N DATE,EM,IND,JND,NAME,NOUT,RATE,TEMP,TEXTOUT,TYPE + S TYPE=$$EXTERNAL^DILFD(120.5,.03,"",IFIEVAL("TYPE"),.EM) + S NAME="Vital Measurement: "_TYPE_" = " + S IND=0 + F S IND=+$O(IFIEVAL(IND)) Q:IND=0 D + . S RATE=$G(IFIEVAL(IND,"VALUE")) + . I RATE="" S RATE="MISSING" + . S DATE=IFIEVAL(IND,"DATE") + . S TEMP=NAME_RATE_" ("_$$EDATE^PXRMDATE(DATE)_")" + . D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT) + . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND) + S NLINES=NLINES+1,TEXT(NLINES)="" + Q + ; + ;=========================================================== +OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical + ;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: "_TYPE + S IND=0 + F S IND=+$O(IFIEVAL(IND)) Q:IND=0 D + . S DATE=IFIEVAL(IND,"DATE") + . S TEMP=$$EDATE^PXRMDATE(DATE) + . S RATE=$G(IFIEVAL(IND,"VALUE")) + . I RATE="" S RATE="MISSING" + . S TEMP=TEMP_"; rate - "_RATE + . D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT) + . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND) + .;If there are qualifiers display them. + . I $D(IFIEVAL(IND,"QUALIFIER")) D + .. S TEMP="Qualifiers:" + .. N QIND S QIND=0 + .. S QIND=$O(IFIEVAL(IND,"QUALIFIER",QIND)) S TEMP=TEMP_" "_IFIEVAL(IND,"QUALIFIER",QIND) + .. F S QIND=$O(IFIEVAL(IND,"QUALIFIER",QIND)) Q:QIND="" S TEMP=TEMP_", "_IFIEVAL(IND,"QUALIFIER",QIND) + .. D FORMATS^PXRMTEXT(INDENT+3,PXRMRM,TEMP,.NOUT,.TEXTOUT) + .. F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND) + S NLINES=NLINES+1,TEXT(NLINES)="" + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMVPTR.m b/r/CLINICAL_REMINDERS-PXRM/PXRMVPTR.m index 2b454394..92268cc7 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMVPTR.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMVPTR.m @@ -1,44 +1,43 @@ -PXRMVPTR ; SLC/PKR - Routines for dealing with variable pointers. ; 02/06/2001 - ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123 - ; - ;================================================== -BLDALIST(FILE,FIELD,LIST) ;Build a list of variable pointer information - ;indexed by the abbreviation. - N ABBR,FN,IND,ROOT,TEMP - S IND=0 - F S IND=$O(^DD(FILE,FIELD,"V",IND)) Q:+IND=0 D - . S TEMP=^DD(FILE,FIELD,"V",IND,0) - . S FN=$P(TEMP,U,1) - . S ROOT=$$ROOT^DILFD(FN) - . S ROOT=$P(ROOT,"^",2) - . S ABBR=$P(TEMP,U,4) - . S LIST(ABBR)=TEMP - Q - ; - ;================================================== -BLDNLIST(FILE,FIELD,LIST) ;Build a list of variable pointer information - ;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 - . S TEMP=^DD(FILE,FIELD,"V",IND,0) - . S FN=$P(TEMP,U,1) - . S ROOT=$$ROOT^DILFD(FN) - . S ROOT=$P(ROOT,"^",2) - . S LIST(FN)=TEMP - Q - ; - ;================================================== -BLDRLIST(FILE,FIELD,LIST) ;Build a list of variable pointer information - ;indexed by the root. - N FN,IND,ROOT,TEMP - S IND=0 - F S IND=$O(^DD(FILE,FIELD,"V",IND)) Q:+IND=0 D - . S TEMP=^DD(FILE,FIELD,"V",IND,0) - . S FN=$P(TEMP,U,1) - . S ROOT=$$ROOT^DILFD(FN) - . S ROOT=$P(ROOT,"^",2) - . S LIST(ROOT)=TEMP - Q - ; +PXRMVPTR ; SLC/PKR - Routines for dealing with variable pointers. ; 02/06/2001 + ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005 + ; + ;================================================== +BLDALIST(FILE,FIELD,LIST) ;Build a list of variable pointer information + ;indexed by the abbreviation. + N ABBR,FN,IND,ROOT,TEMP + S IND=0 + F S IND=$O(^DD(FILE,FIELD,"V",IND)) Q:+IND=0 D + . S TEMP=^DD(FILE,FIELD,"V",IND,0) + . S FN=$P(TEMP,U,1) + . S ROOT=$$ROOT^DILFD(FN) + . S ROOT=$P(ROOT,"^",2) + . S ABBR=$P(TEMP,U,4) + . S LIST(ABBR)=TEMP + Q + ; + ;================================================== +BLDNLIST(FILE,FIELD,LIST) ;Build a list of variable pointer information + ;indexed by the file number. + N FN,IND,ROOT,TEMP + S IND=0 + F S IND=$O(^DD(FILE,FIELD,"V",IND)) Q:+IND=0 D + . S TEMP=^DD(FILE,FIELD,"V",IND,0) + . S FN=$P(TEMP,U,1) + . S ROOT=$$ROOT^DILFD(FN) + . S ROOT=$P(ROOT,"^",2) + . S LIST(FN)=TEMP + Q + ; + ;================================================== +BLDRLIST(FILE,FIELD,LIST) ;Build a list of variable pointer information + ;indexed by the root. + N FN,IND,ROOT,TEMP + S IND=0 + F S IND=$O(^DD(FILE,FIELD,"V",IND)) Q:+IND=0 D + . S TEMP=^DD(FILE,FIELD,"V",IND,0) + . S FN=$P(TEMP,U,1) + . S ROOT=$$ROOT^DILFD(FN) + . S ROOT=$P(ROOT,"^",2) + . S LIST(ROOT)=TEMP + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMVSIT.m b/r/CLINICAL_REMINDERS-PXRM/PXRMVSIT.m index e530b515..8a78a975 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMVSIT.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMVSIT.m @@ -1,97 +1,87 @@ -PXRMVSIT ; SLC/PKR - Visit related info for reminders. ;02/22/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ;====================================================== -GETDATA(DA,DATA,SVALUE) ;Return data for a specific Visit file entry. - ;DBIA #2028 for Visit file. - N DONE,IEN,HTEMP,LOE,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) - ;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) - ;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)) - ;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 - Q - ; - ;====================================================== -GAPSTAT(VIEN) ;Return the status of the appointment associated with the - ;visit. - ;DBIA #4850 - Q $$STATUS^SDPCE(VIEN) - ; - ;====================================================== -HENC(VIEN,INDENT,NLINES,TEXT) ;Display location and comment for historical - ;encounters associated with the V files. - N COMMENT,HLOC,LOCATION,OLOC,NIN,TEXTIN,VDATA - D GETDATA(VIEN,.VDATA) I VDATA("SERVICE CATEGORY")'="E" Q - S NIN=0 - S LOCATION=VDATA("LOC. OF ENCOUNTER") - I LOCATION'="" D - . S LOCATION=$$GET1^DIQ(4,LOCATION,.01)_" "_$$GET1^DIQ(4,LOCATION,99) - . S NIN=NIN+1,TEXTIN(NIN)="Location of Encounter: "_LOCATION_"\\" - S HLOC=VDATA("HOSPITAL LOCATION") - I HLOC'="" D - . S HLOC=$$GET1^DIQ(44,HLOC,.01) - . S NIN=NIN+1,TEXTIN(NIN)="Hospital Location: "_HLOC_"\\" - S OLOC=VDATA("OUTSIDE LOCATION") - I OLOC'="" D - . S NIN=NIN+1,TEXTIN(NIN)="Outside Location: "_OLOC_"\\" - S COMMENT=VDATA("COMMENT") - I COMMENT'="" D - . S NIN=NIN+1,TEXTIN(NIN)="Comment: "_COMMENT - I NIN>0 D - . N JND,NOUT,TEXTOUT - . S NLINES=NLINES+1 - . S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Historical Encounter Information:" - . D FORMAT^PXRMTEXT(INDENT+2,PXRMRM,NIN,.TEXTIN,.NOUT,.TEXTOUT) - . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND) - Q - ; - ;====================================================== -ISHIST(VIEN) ;Return true if the encounter was historical. - ;DBIA #2028 - I $P($G(^AUPNVSIT(VIEN,0)),U,7)="E" Q 1 - Q 0 - ; - ;====================================================== -VAPSTAT(VIEN) ;Return true if the appointment associated with - ;the visit has a valid appointment status. - ;Return false if the status is one of the following: - ;CANCELLED BY CLINIC - ;CANCELLED BY CLINIC & AUTO RE-BOOK - ;CANCELLED BY PATIENT - ;CANCELLED BY PATIENT & AUTO-REBOOK - ;DELETED - ;NO ACTION TAKEN - ;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) - Q VALID - ; +PXRMVSIT ; SLC/PKR - Visit related info for reminders. ;07/06/2006 + ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21 + ; + ;====================================================== +GETDATA(DA,FIEVT,SVALUE) ;Return data for a specific Visit file entry. + ;DBIA #2028 for Visit file. + N HTEMP,TEMP + S TEMP=^AUPNVSIT(DA,0) + 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(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 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 FIEVT("STATUS")=$$STATUS^SDPCE(DA) + Q + ; + ;====================================================== +GAPSTAT(VIEN) ;Return the status of the appointment associated with the + ;visit. + ;DBIA #4850 + Q $$STATUS^SDPCE(VIEN) + ; + ;====================================================== +HENC(VIEN,INDENT,NLINES,TEXT) ;Display location and comment for historical + ;encounters associated with the V files. + N COMMENT,HLOC,LOCATION,OLOC,NIN,TEXTIN,VDATA + D GETDATA(VIEN,.VDATA) I VDATA("SERVICE CATEGORY")'="E" Q + S NIN=0 + S LOCATION=VDATA("LOC. OF ENCOUNTER") + I LOCATION'="" D + . S LOCATION=$$GET1^DIQ(4,LOCATION,.01)_" "_$$GET1^DIQ(4,LOCATION,99) + . S NIN=NIN+1,TEXTIN(NIN)="Location of Encounter: "_LOCATION_"\\" + S HLOC=VDATA("HOSPITAL LOCATION") + I HLOC'="" D + . S HLOC=$$GET1^DIQ(44,HLOC,.01) + . S NIN=NIN+1,TEXTIN(NIN)="Hospital Location: "_HLOC_"\\" + S OLOC=VDATA("OUTSIDE LOCATION") + I OLOC'="" D + . S NIN=NIN+1,TEXTIN(NIN)="Outside Location: "_OLOC_"\\" + S COMMENT=VDATA("COMMENT") + I COMMENT'="" D + . S NIN=NIN+1,TEXTIN(NIN)="Comment: "_COMMENT + I NIN>0 D + . N JND,NOUT,TEXTOUT + . S NLINES=NLINES+1 + . S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Historical Encounter Information:" + . D FORMAT^PXRMTEXT(INDENT+2,PXRMRM,NIN,.TEXTIN,.NOUT,.TEXTOUT) + . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND) + Q + ; + ;====================================================== +ISHIST(VIEN) ;Return true if the encounter was historical. + ;DBIA #2028 + I $P($G(^AUPNVSIT(VIEN,0)),U,7)="E" Q 1 + Q 0 + ; + ;====================================================== +VAPSTAT(VIEN) ;Return true if the appointment associated with + ;the visit has a valid appointment status. + ;Return false if the status is one of the following: + ;CANCELLED BY CLINIC + ;CANCELLED BY CLINIC & AUTO RE-BOOK + ;CANCELLED BY PATIENT + ;CANCELLED BY PATIENT & AUTO-REBOOK + ;DELETED + ;NO ACTION TAKEN + ;NO-SHOW + ;NO-SHOW & AUTO RE-BOOK + 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,1:1) + Q VALID + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMXD.m b/r/CLINICAL_REMINDERS-PXRM/PXRMXD.m index 67197b53..9397f926 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMXD.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMXD.m @@ -1,282 +1,273 @@ -PXRMXD ; SLC/PJH - Reminder Due reports DRIVER ;11/27/2006 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; -START ; Arrays and strings - N PXRMIOD,PXRMXST,PXRMOPT,PXRMQUE,PXRMXTMP,PXRMSEL - N PXRMFAC,PXRMFACN,PXRMSCAT,PXRMSRT,PXRMTYP - N REMINDER,PXRMINP,PXRMFCMB,PXRMLCMB,PXRMTCMB,PXRMTOT - ; Addenda - N PXRMOTM,PXRMPAT,PXRMPCM,PXRMPRV,PXRMTMP,PXRMRCAT,PXRMREM - N PXRMCS,PXRMCSN,PXRMLOCN,PXRMLCHL,PXRMLCSC,PXRMCGRP,PXRMCGRN - N PXRMLIS - ; Counters - N NCAT,NFAC,NLOC,NPAT,NPCM,NOTM,NPRV,NREM,NCS,NHL,NCGRP - ; Flags and Dates - N PXRMFD,PXRMSDT,PXRMBDT,PXRMEDT,PXRMREP,PXRMPRIM,PXRMFUT,PXRMDLOC - N PXRMRT,PXRMSSN,PXRMTABC,PXRMTABS,PXRMTMP,TITLE,VALUE - N DBDOWN,DBDUZ,DBERR,PXRMLIST,PXRMLIS1,Y - N PLISTPUG - N PXRMTPAT,PXRMDPAT,PXRMPML - ; - S PXRMRT="PXRMX",PXRMTYP="X",PXRMFCMB="N",PXRMLCMB="N",PXRMTCMB="N" - ; - I '$D(PXRMUSER) N PXRMUSER S PXRMUSER=0 - ; - ;Guarantee the timestamp is unique. - H 1 - S PXRMXST=$$NOW^XLFDT - S PXRMXTMP=PXRMRT_PXRMXST - S ^XTMP(PXRMXTMP,0)=$$FMADD^XLFDT(DT,7)_U_DT_U_"PXRM Reminder Due Report" - ; - ;Check for existing report templates -REP ; - S PXRMINP=0 - D:PXRMUSER ^PXRMXTB D:'PXRMUSER ^PXRMXT I $D(DTOUT)!$D(DUOUT) G EXIT - ;Run report from template details - I PXRMTMP'="" D G:$D(DUOUT)&'$D(DTOUT) REP Q - .D START^PXRMXTA("JOB^PXRMXQUE") K DUOUT,DIRUT,DTOUT - ; - ;Select sample criteria -SEL ; - D SELECT^PXRMXSD(.PXRMSEL) I $D(DTOUT) G EXIT - I $D(DUOUT) G:PXRMTMP="" EXIT G REP - ; -FAC ;Get the facility list. - I "IRPO"'[PXRMSEL D G:$D(DTOUT) EXIT G:$D(DUOUT) SEL - .D FACILITY^PXRMXSU(.PXRMFAC) Q:$D(DTOUT)!$D(DUOUT) - ; - ;Check if combined facility report is required -COMB I "IRPO"'[PXRMSEL,NFAC>1 D G:$D(DTOUT) EXIT G:$D(DUOUT) FAC - .D COMB^PXRMXSD(.PXRMFCMB,"Facilities","N") - ; -OPT ;Variable prompts - ; - ;Get Individual Patient list - I PXRMSEL="I" K PXRMPAT D PAT^PXRMXSU(.PXRMPAT) - ;Get Patient list #810.5 - I PXRMSEL="R" K PXRMLIST D LIST^PXRMXSU(.PXRMLIST) - ;Get OE/RRteam list - I PXRMSEL="O" K PXRMOTM D OERR^PXRMXSU(.PXRMOTM) - ;Get PCMM team - I PXRMSEL="T" K PXRMPCM D PCMM^PXRMXSU(.PXRMPCM) - ;Get provider list - I PXRMSEL="P" K PXRMPRV D PROV^PXRMXSU(.PXRMPRV) - ;Get the location list. - I PXRMSEL="L" K PXRMCS,PXRMCSN,PXRMLOCN,PXRMLCHL,PXRMCGRP,PXRMCGRN D - .D LOC^PXRMXSU("Determine encounter counts for","HS") - I $D(DTOUT) G EXIT - I $D(DUOUT) G:"IRPO"[PXRMSEL SEL G:NFAC>1 COMB G FAC - ; - ;Check if inpatient location report - S PXRMINP=$$INP - ; - ; Primary Provider or All (PCMM Provider only) -PRIME I PXRMSEL="P" D G:$D(DTOUT) EXIT G:$D(DUOUT) OPT - .D PRIME^PXRMXSD(.PXRMPRIM) - ; -DR ; Get the date range. - S PXRMFD="P" - ; No prompt if individual patients selected - ; Single dates only if PCMM teams/providers and OE/RR teams selected - ; Choice of previous/future date range if location selected - ; - ; Prior encounters/future appointments (location only) -PREV I PXRMSEL="L" D PREV^PXRMXSD(.PXRMFD) G:$D(DTOUT) EXIT G:$D(DUOUT) OPT - ; Date range input (location only) - I PXRMSEL="L" D G:$D(DTOUT) EXIT G:$D(DUOUT) PREV - .I PXRMFD="P" D PDR^PXRMXDUT(.PXRMBDT,.PXRMEDT,"ENCOUNTER") - .I PXRMFD="F" D FDR^PXRMXDUT(.PXRMBDT,.PXRMEDT,"APPOINTMENT") - .I PXRMFD="A" D PDR^PXRMXDUT(.PXRMBDT,.PXRMEDT,"ADMISSION") - .I PXRMFD="C" S PXRMBDT=DT,PXRMEDT=DT - ; Due Effective Date -DUE D SDR^PXRMXDUT(.PXRMSDT) G:$D(DTOUT) EXIT - I $D(DUOUT) G:PXRMSEL="L" PREV G OPT - ; -SCAT ;Get the service categories. - I PXRMSEL="L",PXRMFD="P" D - .D SCAT^PXRMXSC - .I $D(DTOUT)!$D(DUOUT) Q - I $D(DTOUT) G EXIT - I $D(DUOUT) G DUE - ; -TYP ;Determine type of report (detail/summary) - S PXRMREP="S" - D REP^PXRMXSD(.PXRMREP) I $D(DTOUT) G EXIT - I $D(DUOUT) G SCAT - ; - ;Check if combined location report is required -LCOMB S NLOC=0 - I PXRMREP="D",PXRMSEL="L" D G:$D(DTOUT) EXIT G:$D(DUOUT) TYP - .N DEFAULT,TEXT - .D NLOC - .I NLOC>1 D COMB^PXRMXSD(.PXRMLCMB,TEXT,DEFAULT) - ; - ;Check if combined OE/RR team report is required -TCOMB I PXRMREP="D",PXRMSEL="O",$G(NOTM)>1 D G:$D(DTOUT) EXIT G:$D(DUOUT) TYP - .N DEFAULT,TEXT - .S DEFAULT="N",TEXT="OE/RR teams" - .D COMB^PXRMXSD(.PXRMTCMB,TEXT,DEFAULT) - ; -FUT ;For detailed report give option to display future appointments - S PXRMFUT="N" - I PXRMREP="D",'PXRMINP D G:$D(DTOUT) EXIT I $D(DUOUT) G:(PXRMSEL="L")&(NLOC>1) LCOMB G:(PXRMSEL="O")&($G(NOTM)>1) TCOMB G TYP - .D FUTURE^PXRMXSD(.PXRMFUT,"Display All Future Appointments: ",5) - .I PXRMFUT="Y" D Q:$D(DTOUT)!$D(DUOUT) - ..D FUTURE^PXRMXSD(.PXRMDLOC,"Display Appointment Location: ",15) - ; -SRT ;For detailed report give option to sort by appointment date - S PXRMSRT="N" - I PXRMREP="D",("RI"'[PXRMSEL) D G:$D(DTOUT) EXIT I $D(DUOUT) G:(PXRMSEL="L")&(PXRMINP)&(NLOC>1) LCOMB G:PXRMINP TYP G:(PXRMSEL="O")&($G(NOTM)>1) TCOMB G FUT - .;Option to sort by Bed for inpatients - .I PXRMSEL="L",PXRMINP D BED^PXRMXSD(.PXRMSRT) Q - .;Otherwise option to sort by appt. date - .D SRT^PXRMXSD(.PXRMSRT) - ; - ;Option to print full SSN -SSN I PXRMREP="D" D G:$D(DTOUT) EXIT I $D(DUOUT) G:"IR"[PXRMSEL FUT G SRT - .D SSN^PXRMXSD(.PXRMSSN) - ; - ;Option to print without totals, with totals or totals only -TOT I PXRMREP="S" D G:$D(DTOUT) EXIT I $D(DUOUT) G TYP - .;Default is normal report - .S PXRMTOT="I" - .;Ignore patient and patient list reports - .I "RI"[PXRMSEL Q - .;Only prompt if more than one location, team or provider is selected - .I PXRMSEL="P",NPRV<2 Q - .I "OT"[PXRMSEL,NOTM<2 Q - .;Ignore reports for all locations - .I PXRMSEL="L",PXRMLCMB="Y" Q - .I PXRMSEL="L" N DEFAULT,TEXT D NLOC Q:NLOC<2 - .;Prompt for options - .N LIT1,LIT2,LIT3 - .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 - ; - ;Create combined reminder list - D MERGE^PXRMXS1 - ; -SAV ;Option to create a new report template - I PXRMTMP="" D ^PXRMXTU G:$D(DTOUT) EXIT I $D(DUOUT) G RCAT - ; - ;Option to print delimiter separated output -TABS D G:$D(DTOUT) EXIT I $D(DUOUT) G SAV - .D TABS^PXRMXSD(.PXRMTABS) - ;Select chracter -TCHAR I PXRMTABS="Y" D G:$D(DTOUT) EXIT G:$D(DUOUT) TABS - .S PXRMTABC=$$DELIMSEL^PXRMXSD - ; -DPAT ;Ask whether to include deceased and test patients. - S PXRMDPAT=$$ASKYN^PXRMEUT("N","Include deceased patients on the list") - N PXRMIDOD I PXRMDPAT>0 S PXRMIDOD=1 - Q:$D(DTOUT) G:$D(DUOUT) TABS -TPAT ; - S PXRMTPAT=$$ASKYN^PXRMEUT("N","Include test patients on the list") - Q:$D(DTOUT) G:$D(DUOUT) DPAT -PATLIST ; - K PATCREAT - N PATLST - I PXRMSEL'="I"&(PXRMUSER'="Y") D - . D ASK(.PATLST,"Save due patients to a patient list: ",3) - . I $G(PATLST)="" Q - . I $G(PATLST)="N" S PXRMLIS1="" Q - . I $G(PATLST)="Y" D - ..S PATCREAT="N" - ..D ASK(.PATCREAT,"Secure list?: ",3) I $D(DTOUT)!($D(DUOUT)) Q - ..K PLISTPUG - ..S PLISTPUG="N" D ASK^PXRMXD(.PLISTPUG,"Purge Patient List after 5 years?: ",5) - I $G(PATLST)="" G:$D(DTOUT) EXIT I $D(DUOUT) G TPAT - G:$D(DTOUT) EXIT I $D(DUOUT) G PATLIST - I $G(PATLST)="Y" S TEXT="Select PATIENT LIST name: " D PLIST^PXRMLCR(.PXRMLIS1,TEXT,"") Q:$D(DUOUT)!$D(DTOUT) - ;Determine whether the report should be queued. -JOB ; - D JOB^PXRMXQUE - Q - ; - ;Option PXRM REMINDERS DUE (USER) -USER N PXRMUSER - S PXRMUSER=+$G(DUZ) - G START - ; - ; -EXIT ;Clean things up. - D EXIT^PXRMXGUT - Q - ; - ;Check if inpatient report -INP() ;Applies to location reports only - I PXRMSEL'="L" Q 0 - ;For all inpatient locations default is automatic - I $P(PXRMLCSC,U)="HAI" Q 1 - ;For selected locations check if all locations are wards - I $P(PXRMLCSC,U)="HS" Q $$INP^PXRMXAP(PXRMLCSC,.PXRMLOCN) - ;Otherwise - Q 0 - ; - ;Prompt text -LIT N LIT - S LIT=$S(PXRMSEL="P":"Provider","OT"[PXRMSEL:"Team",1:"Location") - I PXRMFCMB="N" D - .S LIT1="Individual "_LIT_"s only" - .S LIT2="Individual "_LIT_"s plus Totals by Facility" - .S LIT3="Totals by Facility only" - I PXRMFCMB="Y" D - .S LIT1="Individual "_LIT_"s only" - .S LIT2="Individual "_LIT_"s plus Overall Total" - .S LIT3="Overall Total only" - Q - ; - ;Check if multiple locations -NLOC S DEFAULT="N",NLOC=1,TEXT="Locations" - I $P(PXRMLCSC,U)["HA" S DEFAULT="Y",NLOC=999 - I $P(PXRMLCSC,U)="CA" S DEFAULT="Y",NCS=999 - I $E(PXRMLCSC)="C" S TEXT="Clinic Stops",NLOC=NCS - I $E(PXRMLCSC)="G" S TEXT="Clinic Groups",NLOC=NCGRP - I $P(PXRMLCSC,U)="HS" S NLOC=NHL S:$$INP TEXT="Inpatient Locations" - ;Special coding if more than one facility and location - I $P(PXRMLCSC,U)="HS",NFAC>1,NLOC>1 D - .N FAC,HLOCIEN,HLNAME,IC,MULT - .S IC=0 S:PXRMFCMB="Y" FAC="COMBINED" - .;Build list of locations by facility - .F S IC=$O(PXRMLCHL(IC)) Q:'IC D - ..S HLOCIEN=$P(PXRMLCHL(IC),U,2),FAC=$$FACL^PXRMXAP(HLOCIEN) Q:'FAC - ..S HLNAME=$P(PXRMLCHL(IC),U) Q:HLNAME="" - ..S MULT(FAC,HLNAME)="" - .S MULT=0,FAC=0 - .;Count locations in each facility - .F S FAC=$O(MULT(FAC)) Q:'FAC D Q:MULT - ..S IC=0,HLNAME="" - ..F S HLNAME=$O(MULT(FAC,HLNAME)) Q:HLNAME="" S IC=IC+1 - ..I IC>1 S MULT=1 - .;If only one location per facility suppress combined location option - .I 'MULT S NLOC=1 - Q - ; -ASK(YESNO,PROMPT,NUM) ; - N X,Y,TEXT - K DIROUT,DIRUT,DTOUT,DUOUT - S DIR(0)="YA0" - S DIR("A")=PROMPT - S DIR("B")="N" - S DIR("?")="Enter Y or N. For detailed help type ??" - S DIR("??")=U_"D HELP^PXRMLCR("_NUM_")" - W ! - D ^DIR K DIR - I $D(DIROUT) S DTOUT=1 - I $D(DTOUT)!($D(DUOUT)) Q - S YESNO=$E(Y(0)) - Q - ; +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 PXRMIOD,PXRMXST,PXRMOPT,PXRMQUE,PXRMXTMP,PXRMSEL + N PXRMFAC,PXRMFACN,PXRMSCAT,PXRMSRT,PXRMTYP + N REMINDER,PXRMINP,PXRMFCMB,PXRMLCMB,PXRMTCMB,PXRMTOT + ; Addenda + N PXRMOTM,PXRMPAT,PXRMPCM,PXRMPRV,PXRMTMP,PXRMRCAT,PXRMREM + N PXRMCS,PXRMCSN,PXRMLOCN,PXRMLCHL,PXRMLCSC,PXRMCGRP,PXRMCGRN + N PXRMLIS + ; Counters + N NCAT,NFAC,NLOC,NPAT,NPCM,NOTM,NPRV,NREM,NCS,NHL,NCGRP + ; Flags and Dates + N PXRMFD,PXRMSDT,PXRMBDT,PXRMEDT,PXRMREP,PXRMPRIM,PXRMFUT,PXRMDLOC + N PXRMRT,PXRMSSN,PXRMTABC,PXRMTABS,PXRMTMP,TITLE,VALUE + N DBDOWN,DBDUZ,DBERR,PXRMLIST,PXRMLIS1,Y + N PLISTPUG + N PXRMTPAT,PXRMDPAT + ; + S PXRMRT="PXRMX",PXRMTYP="X",PXRMFCMB="N",PXRMLCMB="N",PXRMTCMB="N" + ; + I '$D(PXRMUSER) N PXRMUSER S PXRMUSER=0 + ; + ;Guarantee the timestamp is unique. + H 1 + S PXRMXST=$$NOW^XLFDT + S PXRMXTMP=PXRMRT_PXRMXST + S ^XTMP(PXRMXTMP,0)=$$FMADD^XLFDT(DT,7)_U_DT_U_"PXRM Reminder Due Report" + ; + ;Check for existing report templates +REP ; + S PXRMINP=0 + D:PXRMUSER ^PXRMXTB D:'PXRMUSER ^PXRMXT I $D(DTOUT)!$D(DUOUT) G EXIT + ;Run report from template details + I PXRMTMP'="" D G:$D(DUOUT)&'$D(DTOUT) REP Q + .D START^PXRMXTA("JOB^PXRMXQUE") K DUOUT,DIRUT,DTOUT + ; + ;Select sample criteria +SEL ; + D SELECT^PXRMXSD(.PXRMSEL) I $D(DTOUT) G EXIT + I $D(DUOUT) G:PXRMTMP="" EXIT G REP + ; +FAC ;Get the facility list. + I "IRPO"'[PXRMSEL D G:$D(DTOUT) EXIT G:$D(DUOUT) SEL + .D FACILITY^PXRMXSU(.PXRMFAC) Q:$D(DTOUT)!$D(DUOUT) + ; + ;Check if combined facility report is required +COMB I "IRPO"'[PXRMSEL,NFAC>1 D G:$D(DTOUT) EXIT G:$D(DUOUT) FAC + .D COMB^PXRMXSD(.PXRMFCMB,"Facilities","N") + ; +OPT ;Variable prompts + ; + ;Get Individual Patient list + I PXRMSEL="I" K PXRMPAT D PAT^PXRMXSU(.PXRMPAT) + ;Get Patient list #810.5 + I PXRMSEL="R" K PXRMLIST D LIST^PXRMXSU(.PXRMLIST) + ;Get OE/RRteam list + I PXRMSEL="O" K PXRMOTM D OERR^PXRMXSU(.PXRMOTM) + ;Get PCMM team + I PXRMSEL="T" K PXRMPCM D PCMM^PXRMXSU(.PXRMPCM) + ;Get provider list + I PXRMSEL="P" K PXRMPRV D PROV^PXRMXSU(.PXRMPRV) + ;Get the location list. + I PXRMSEL="L" K PXRMCS,PXRMCSN,PXRMLOCN,PXRMLCHL,PXRMCGRP,PXRMCGRN D + .D LOC^PXRMXSU("Determine encounter counts for","HS") + I $D(DTOUT) G EXIT + I $D(DUOUT) G:"IRPO"[PXRMSEL SEL G:NFAC>1 COMB G FAC + ; + ;Check if inpatient location report + S PXRMINP=$$INP + ; + ; Primary Provider or All (PCMM Provider only) +PRIME I PXRMSEL="P" D G:$D(DTOUT) EXIT G:$D(DUOUT) OPT + .D PRIME^PXRMXSD(.PXRMPRIM) + ; +DR ; Get the date range. + S PXRMFD="P" + ; No prompt if individual patients selected + ; Single dates only if PCMM teams/providers and OE/RR teams selected + ; Choice of previous/future date range if location selected + ; + ; Prior encounters/future appointments (location only) +PREV I PXRMSEL="L" D PREV^PXRMXSD(.PXRMFD) G:$D(DTOUT) EXIT G:$D(DUOUT) OPT + ; Date range input (location only) + I PXRMSEL="L" D G:$D(DTOUT) EXIT G:$D(DUOUT) PREV + .I PXRMFD="P" D PDR^PXRMXDUT(.PXRMBDT,.PXRMEDT,"ENCOUNTER") + .I PXRMFD="F" D FDR^PXRMXDUT(.PXRMBDT,.PXRMEDT,"APPOINTMENT") + .I PXRMFD="A" D PDR^PXRMXDUT(.PXRMBDT,.PXRMEDT,"ADMISSION") + .I PXRMFD="C" S PXRMBDT=DT,PXRMEDT=DT + ; Due Effective Date +DUE D SDR^PXRMXDUT(.PXRMSDT) G:$D(DTOUT) EXIT + I $D(DUOUT) G:PXRMSEL="L" PREV G OPT + ; +SCAT ;Get the service categories. + I PXRMSEL="L",PXRMFD="P" D + .D SCAT^PXRMXSC + .I $D(DTOUT)!$D(DUOUT) Q + I $D(DTOUT) G EXIT + I $D(DUOUT) G DUE + ; +TYP ;Determine type of report (detail/summary) + S PXRMREP="S" + D REP^PXRMXSD(.PXRMREP) I $D(DTOUT) G EXIT + I $D(DUOUT) G SCAT + ; + ;Check if combined location report is required +LCOMB S NLOC=0 + I PXRMREP="D",PXRMSEL="L" D G:$D(DTOUT) EXIT G:$D(DUOUT) TYP + .N DEFAULT,TEXT + .D NLOC + .I NLOC>1 D COMB^PXRMXSD(.PXRMLCMB,TEXT,DEFAULT) + ; + ;Check if combined OE/RR team report is required +TCOMB I PXRMREP="D",PXRMSEL="O",$G(NOTM)>1 D G:$D(DTOUT) EXIT G:$D(DUOUT) TYP + .N DEFAULT,TEXT + .S DEFAULT="N",TEXT="OE/RR teams" + .D COMB^PXRMXSD(.PXRMTCMB,TEXT,DEFAULT) + ; +FUT ;For detailed report give option to display future appointments + S PXRMFUT="N" + I PXRMREP="D",'PXRMINP D G:$D(DTOUT) EXIT I $D(DUOUT) G:(PXRMSEL="L")&(NLOC>1) LCOMB G:(PXRMSEL="O")&($G(NOTM)>1) TCOMB G TYP + .D FUTURE^PXRMXSD(.PXRMFUT,"Display All Future Appointments: ",5) + .I PXRMFUT="Y" D Q:$D(DTOUT)!$D(DUOUT) + ..D FUTURE^PXRMXSD(.PXRMDLOC,"Display Appointment Location: ",15) + ; +SRT ;For detailed report give option to sort by appointment date + S PXRMSRT="N" + I PXRMREP="D",("RI"'[PXRMSEL) D G:$D(DTOUT) EXIT I $D(DUOUT) G:(PXRMSEL="L")&(PXRMINP)&(NLOC>1) LCOMB G:PXRMINP TYP G:(PXRMSEL="O")&($G(NOTM)>1) TCOMB G FUT + .;Option to sort by Bed for inpatients + .I PXRMSEL="L",PXRMINP D BED^PXRMXSD(.PXRMSRT) Q + .;Otherwise option to sort by appt. date + .D SRT^PXRMXSD(.PXRMSRT) + ; + ;Option to print full SSN +SSN I PXRMREP="D" D G:$D(DTOUT) EXIT I $D(DUOUT) G:"IR"[PXRMSEL FUT G SRT + .D SSN^PXRMXSD(.PXRMSSN) + ; + ;Option to print without totals, with totals or totals only +TOT I PXRMREP="S" D G:$D(DTOUT) EXIT I $D(DUOUT) G TYP + .;Default is normal report + .S PXRMTOT="I" + .;Ignore patient and patient list reports + .I "RI"[PXRMSEL Q + .;Only prompt if more than one location, team or provider is selected + .I PXRMSEL="P",NPRV<2 Q + .I "OT"[PXRMSEL,NOTM<2 Q + .;Ignore reports for all locations + .I PXRMSEL="L",PXRMLCMB="Y" Q + .I PXRMSEL="L" N DEFAULT,TEXT D NLOC Q:NLOC<2 + .;Prompt for options + .N LIT1,LIT2,LIT3 + .D LIT,TOTALS^PXRMXSD(.PXRMTOT,LIT1,LIT2,LIT3) + ; + ;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 + ; + ;Create combined reminder list + D MERGE^PXRMXS1 + ; +SAV ;Option to create a new report template + I PXRMTMP="" D ^PXRMXTU G:$D(DTOUT) EXIT I $D(DUOUT) G RCAT + ; + ;Option to print delimiter separated output +TABS D G:$D(DTOUT) EXIT I $D(DUOUT) G SAV + .D TABS^PXRMXSD(.PXRMTABS) + ;Select chracter +TCHAR I PXRMTABS="Y" D G:$D(DTOUT) EXIT G:$D(DUOUT) TABS + .S PXRMTABC=$$DELIMSEL^PXRMXSD + ; +DPAT ;Ask whether to include deceased and test patients. + S PXRMDPAT=$$ASKYN^PXRMEUT("N","Include deceased patients on the list") + N PXRMIDOD I PXRMDPAT>0 S PXRMIDOD=1 + Q:$D(DTOUT) G:$D(DUOUT) TABS +TPAT ; + S PXRMTPAT=$$ASKYN^PXRMEUT("N","Include test patients on the list") + Q:$D(DTOUT) G:$D(DUOUT) DPAT +PATLIST ; + K PATCREAT + N PATLST + I PXRMSEL'="I"&(PXRMUSER'="Y") D + . D ASK(.PATLST,"Save due patients to a patient list: ",3) + . I $G(PATLST)="" Q + . I $G(PATLST)="N" S PXRMLIS1="" Q + . I $G(PATLST)="Y" D + ..S PATCREAT="N" + ..D ASK(.PATCREAT,"Secure list?: ",3) I $D(DTOUT)!($D(DUOUT)) Q + ..K PLISTPUG + ..S PLISTPUG="N" D ASK^PXRMXD(.PLISTPUG,"Purge Patient List after 5 years?: ",5) + I $G(PATLST)="" G:$D(DTOUT) EXIT I $D(DUOUT) G TPAT + G:$D(DTOUT) EXIT I $D(DUOUT) G PATLIST + I $G(PATLST)="Y" S TEXT="Select PATIENT LIST name: " D PLIST^PXRMLCR(.PXRMLIS1,TEXT,"") Q:$D(DUOUT)!$D(DTOUT) + ;Determine whether the report should be queued. +JOB ; + D JOB^PXRMXQUE + Q + ; + ;Option PXRM REMINDERS DUE (USER) +USER N PXRMUSER + S PXRMUSER=+$G(DUZ) + G START + ; + ; +EXIT ;Clean things up. + D EXIT^PXRMXGUT + Q + ; + ;Check if inpatient report +INP() ;Applies to location reports only + I PXRMSEL'="L" Q 0 + ;For all inpatient locations default is automatic + I $P(PXRMLCSC,U)="HAI" Q 1 + ;For selected locations check if all locations are wards + I $P(PXRMLCSC,U)="HS" Q $$INP^PXRMXAP(PXRMLCSC,.PXRMLOCN) + ;Otherwise + Q 0 + ; + ;Prompt text +LIT N LIT + S LIT=$S(PXRMSEL="P":"Provider","OT"[PXRMSEL:"Team",1:"Location") + I PXRMFCMB="N" D + .S LIT1="Individual "_LIT_"s only" + .S LIT2="Individual "_LIT_"s plus Totals by Facility" + .S LIT3="Totals by Facility only" + I PXRMFCMB="Y" D + .S LIT1="Individual "_LIT_"s only" + .S LIT2="Individual "_LIT_"s plus Overall Total" + .S LIT3="Overall Total only" + Q + ; + ;Check if multiple locations +NLOC S DEFAULT="N",NLOC=1,TEXT="Locations" + I $P(PXRMLCSC,U)["HA" S DEFAULT="Y",NLOC=999 + I $P(PXRMLCSC,U)="CA" S DEFAULT="Y",NCS=999 + I $E(PXRMLCSC)="C" S TEXT="Clinic Stops",NLOC=NCS + I $E(PXRMLCSC)="G" S TEXT="Clinic Groups",NLOC=NCGRP + I $P(PXRMLCSC,U)="HS" S NLOC=NHL S:$$INP TEXT="Inpatient Locations" + ;Special coding if more than one facility and location + I $P(PXRMLCSC,U)="HS",NFAC>1,NLOC>1 D + .N FAC,HLOCIEN,HLNAME,IC,MULT + .S IC=0 S:PXRMFCMB="Y" FAC="COMBINED" + .;Build list of locations by facility + .F S IC=$O(PXRMLCHL(IC)) Q:'IC D + ..S HLOCIEN=$P(PXRMLCHL(IC),U,2),FAC=$$FACL^PXRMXAP(HLOCIEN) Q:'FAC + ..S HLNAME=$P(PXRMLCHL(IC),U) Q:HLNAME="" + ..S MULT(FAC,HLNAME)="" + .S MULT=0,FAC=0 + .;Count locations in each facility + .F S FAC=$O(MULT(FAC)) Q:'FAC D Q:MULT + ..S IC=0,HLNAME="" + ..F S HLNAME=$O(MULT(FAC,HLNAME)) Q:HLNAME="" S IC=IC+1 + ..I IC>1 S MULT=1 + .;If only one location per facility suppress combined location option + .I 'MULT S NLOC=1 + Q + ; +ASK(YESNO,PROMPT,NUM) ; + N X,Y,TEXT + K DIROUT,DIRUT,DTOUT,DUOUT + S DIR(0)="YA0" + S DIR("A")=PROMPT + S DIR("B")="N" + S DIR("?")="Enter Y or N. For detailed help type ??" + S DIR("??")=U_"D HELP^PXRMLCR("_NUM_")" + W ! + D ^DIR K DIR + I $D(DIROUT) S DTOUT=1 + I $D(DTOUT)!($D(DUOUT)) Q + S YESNO=$E(Y(0)) + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMXDT1.m b/r/CLINICAL_REMINDERS-PXRM/PXRMXDT1.m index d32d1622..ed26cbe8 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMXDT1.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMXDT1.m @@ -1,186 +1,186 @@ -PXRMXDT1 ; SLC/PJH - Build Patient list SUBROUTINES;08/16/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ; Called by label from PXRMXSEO,PXRMXSE - ; - ;Combined report duplicate check (Summary report) -NEW(SUB,SUB1,SUB2) ; - ;Existing entry - I $D(^TMP("PXRMCMB",$J,SUB,SUB1,SUB2)) Q 0 - ;New entry - S ^TMP("PXRMCMB",$J,SUB,SUB1,SUB2)="" - Q 1 - ; - ;Individual patient report duplicate patient check -NEWIP(DFN) ; - ;Existing entry - I $D(^TMP("PXRMCMB3",$J,DFN)) Q 0 - ;New entry - S ^TMP("PXRMCMB3",$J,DFN)="" - Q 1 - ;Combined report duplicate check (Detail report) -NEWP(SUB,DFN) ; - ;Existing entry - I $D(^TMP("PXRMCMB1",$J,SUB,DFN)) Q 0 - ;New entry - S ^TMP("PXRMCMB1",$J,SUB,DFN)="" - Q 1 - ; - ;Combined report duplicate check (Patient totals) -NEWT(FACILITY,DFN) ; - ;Existing entry - I $D(^TMP("PXRMCMB2",$J,FACILITY,DFN)) Q 0 - ;New entry - S ^TMP("PXRMCMB2",$J,FACILITY,DFN)="" - Q 1 - ; - ;Detailed report -SDET(DFN,STATUS,NAM,FACILITY,INP) ; - I $G(^XTMP(PXRMXTMP,PX,FACILITY,NAM))="" D - .S ^XTMP(PXRMXTMP,PX,FACILITY,NAM)=NAM - ;Applicable - S DDAT="N/A" - N APPL,FAPPTDT,DEFARR,DNEXT,DNEXT1,FIEV,PXRMDATE,BID,TMPSUB - S APPL=0,FAPPTDT=0 - ;Add any that aren't N/A, Ignore on N/A or NEVER to applicable total - I ($P(STATUS,U)'="")&(STATUS'["NEVER")&(STATUS'["N/A")&(STATUS'["ERROR")&(STATUS'["CNBD") S APPL=1 - ;If DUE NOW save details - I $G(STATUS)'["DUE NOW" S PNAM=" " - I $G(STATUS)["DUE NOW" D - .N BED - .S DDUE=$P($G(STATUS),U,2) - .S DLAST=$P($G(STATUS),U,3) - .;Demographics - .S PNAM=$P($G(^DPT(DFN,0)),U),BID=$P($G(^DPT(DFN,0)),U,9) - .I PNAM="" S PNAM=" " - .E S PNAM=PNAM_U_BID - .;Next appointment for location or clinic - .;For detailed provider report get next appoint. for assoc. clinic - .S DNEXT="" - .I PXRMSEL="L"!(PXRMSEL="P") S TMPSUB="PXRM FUTURE APPT" - .E S TMPSUB="SDAMA301" - .I PXRMFCMB="Y",PXRMLCMB="Y",$D(^TMP($J,TMPSUB,DFN))>0 D - ..N APPTCNT,LOC - ..S LOC=0,APPTCNT=0 - ..F S LOC=$O(^TMP($J,TMPSUB,DFN,LOC)) Q:(LOC'>0)!(APPTCNT=1) D - ...S DNEXT=$O(^TMP($J,TMPSUB,DFN,LOC,"")) I +DNEXT>0 S APPTCNT=1 Q - .S DNEXT=$O(^TMP($J,TMPSUB,DFN,$G(INP),"")) - .I PXRMFCMB="N",PXRMLCMB="Y" D - ..S DNEXT1=$O(^TMP($J,"PXRM FACILITY FUTURE APPT",DFN,FACILITY,"")) Q:DNEXT1'>0 - ..I +DNEXT=0!(DNEXT>DNEXT1) S DNEXT=DNEXT1 - .S BED=$G(^DPT(DFN,.101)) S:BED="" BED="NONE" - .;Sort by next appointment date - .I PXRMSRT="Y" S DDAT=$P(DNEXT,".") S:DDAT="" DDAT="NONE" - .;Patient ward/bed used only for inpatient reports - .I PXRMFUT="Y" S DNEXT="" - .N TXT - .S TXT=DFN_U_DDUE_U_DLAST_U_$G(DNEXT)_$S($G(BED)'="":U_BED,1:"") - .I $G(BED)'="",BED'="NONE" S DDAT=BED - .N BED - .S BED="" - .I $G(PXRMINP) D - ..S BED=$G(^DPT(DFN,.101)) S:BED="" BED="NONE" - ..S TXT=TXT_U_BED - ..;Sort by bed - ..I PXRMSRT="B" S DDAT=BED - .;Duplicate check for combined report - .I PXRMFCMB="Y",'$$NEW(NAM,DDAT,PNAM) Q - .;I PXRMFCMB'="Y",PXRMLCMB="Y",'$$NEW^PXRMXSEO(NAM,DDAT,PNAM) Q - .;Save entry in ^XTMP - .S ^XTMP(PXRMXTMP,PX,FACILITY,NAM,DDAT,PNAM)=TXT - .;Total of reminders overdue - .N CNT - .S CNT=$P(^XTMP(PXRMXTMP,PX,FACILITY,NAM),U,2) - .S $P(^XTMP(PXRMXTMP,PX,FACILITY,NAM),U,2)=CNT+1 - ;Total of patients checked/applicable - N CNT,NEW - S NEW=1 I PXRMFCMB="Y" S NEW=$$NEWP(NAM,DFN) - I NEW=1 D - .S CNT=$P(^XTMP(PXRMXTMP,PX,FACILITY,NAM),U,3) - .S $P(^XTMP(PXRMXTMP,PX,FACILITY,NAM),U,3)=CNT+1 - .S CNT=$P(^XTMP(PXRMXTMP,PX,FACILITY,NAM),U,4) - .S $P(^XTMP(PXRMXTMP,PX,FACILITY,NAM),U,4)=CNT+APPL - I PXRMFUT="Y"&($G(STATUS)["DUE NOW") D - .N APPTARY,APPTDT,CIEN,CNT,NODE,SUB - .S SUB="" I $D(^TMP($J,"PXRM FUTURE APPT",DFN))>0 S SUB="PXRM FUTURE APPT" - .I SUB="",$D(^TMP($J,"SDAMA301",DFN))>0 S SUB="SDAMA301" - .I SUB="" Q - .S CNT=0 - .S CIEN=0 F S CIEN=$O(^TMP($J,SUB,DFN,CIEN)) Q:CIEN'>0 D - ..S APPTDT=0 - ..F S APPTDT=$O(^TMP($J,SUB,DFN,CIEN,APPTDT)) Q:APPTDT'>0 D - ...S NODE=$G(^TMP($J,SUB,DFN,CIEN,APPTDT)) - ...S APPTARY(APPTDT)=APPTDT_U_$P($P(NODE,U,2),";",2)_U_$P($P(NODE,U,22),";",2) - .S APPTDT=0 F S APPTDT=$O(APPTARY(APPTDT)) Q:APPTDT'>0 S CNT=CNT+1,^XTMP(PXRMXTMP,PX,FACILITY,NAM,DDAT,PNAM,CNT,0)=APPTARY(APPTDT) - Q - ; -SUM(DFN,STATUS,FACILITY,NAM) ; - N DUE,EVAL - S (DUE,EVAL)=0 - ;Add dues to totals of reminders due and reminders applicable - I STATUS["DUE NOW" D - .S DUE=1,EVAL=1 - ;Add any that aren't N/A, Ignore on N/A,ERROR or NEVER to applicable total - S STATUS=$P(STATUS,U) - I (STATUS'=" ")&(STATUS'["NEVER")&(STATUS'="N/A")&(STATUS'["ERROR")&(STATUS'["CNBD") S EVAL=1 - ;Update XTMP - Total of reminders due - I "IR"[PXRMTOT D - .;Combined facility duplicate check - .I PXRMFCMB="Y",'$$NEW(NAM,DFN,ITEM) Q - .N CNT - .S CNT=$P($G(^XTMP(PXRMXTMP,PX,FACILITY,NAM,ITEM)),U,1) - .S $P(^XTMP(PXRMXTMP,PX,FACILITY,NAM,ITEM),U,1)=CNT+EVAL - .;Total of reminders evaluated - .S CNT=$P($G(^XTMP(PXRMXTMP,PX,FACILITY,NAM,ITEM)),U,2) - .S $P(^XTMP(PXRMXTMP,PX,FACILITY,NAM,ITEM),U,2)=CNT+DUE - ; - ;Totals - I "RT"[PXRMTOT D - .;Check for duplicate patient at FACILITY level - .I $D(^TMP("PXRMDUP",$J,FACILITY,DFN,ITEM)) Q - .;Set duplicate check - .S ^TMP("PXRMDUP",$J,FACILITY,DFN,ITEM)="" - .I $G(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL"))="" D - ..S ^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL")="TOTAL" - .N CNT - .S CNT=$P($G(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL",ITEM)),U,1) - .S $P(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL",ITEM),U,1)=CNT+EVAL - .S CNT=$P($G(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL",ITEM)),U,2) - .S $P(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL",ITEM),U,2)=CNT+DUE - ; - ;Total of patients - I "IR"[PXRMTOT D - .I PXRMSEL="I",$$NEWIP(DFN)<1 Q - .I $$NEWP(@SUB,DFN)=0 Q - .I $G(^XTMP(PXRMXTMP,PX,FACILITY,@SUB))="" S ^XTMP(PXRMXTMP,PX,FACILITY,@SUB)=NAM - .N CNT S CNT=$P($G(^XTMP(PXRMXTMP,PX,FACILITY,@SUB)),U,3) - .S $P(^XTMP(PXRMXTMP,PX,FACILITY,@SUB),U,3)=CNT+1 - ; - ;Total reports - I "TR"[PXRMTOT D - .I '$$NEWT(FACILITY,DFN) Q - .I $G(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL"))="" D - ..S ^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL")=NAM - .N CNT - .S CNT=$P($G(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL")),U,3) - .S $P(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL"),U,3)=CNT+1 - Q - ; -ERRMSG(TYPE) ; - N CNT,CNT1,CNT2,STR,NLINES,OUTPUT,TIME - K ^TMP("PXRMXMZ",$J) - S NLINES=0,CNT=0,CNT1=2 - 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) - 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 S CNT=$O(DBERR(CNT)) Q:CNT'>0 S STR(CNT1)="\\"_DBERR(CNT),CNT1=CNT1+1 - .D FORMAT^PXRMTEXT(1,80,2,.STR,.NLINES,.OUTPUT) - .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):" - .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) - .S ZTSTOP=1 - Q +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 + ; + ;Combined report duplicate check (Summary report) +NEW(SUB,SUB1,SUB2) ; + ;Existing entry + I $D(^TMP("PXRMCMB",$J,SUB,SUB1,SUB2)) Q 0 + ;New entry + S ^TMP("PXRMCMB",$J,SUB,SUB1,SUB2)="" + Q 1 + ; + ;Individual patient report duplicate patient check +NEWIP(DFN) ; + ;Existing entry + I $D(^TMP("PXRMCMB3",$J,DFN)) Q 0 + ;New entry + S ^TMP("PXRMCMB3",$J,DFN)="" + Q 1 + ;Combined report duplicate check (Detail report) +NEWP(SUB,DFN) ; + ;Existing entry + I $D(^TMP("PXRMCMB1",$J,SUB,DFN)) Q 0 + ;New entry + S ^TMP("PXRMCMB1",$J,SUB,DFN)="" + Q 1 + ; + ;Combined report duplicate check (Patient totals) +NEWT(FACILITY,DFN) ; + ;Existing entry + I $D(^TMP("PXRMCMB2",$J,FACILITY,DFN)) Q 0 + ;New entry + S ^TMP("PXRMCMB2",$J,FACILITY,DFN)="" + Q 1 + ; + ;Detailed report +SDET(DFN,STATUS,NAM,FACILITY,INP) ; + I $G(^XTMP(PXRMXTMP,PX,FACILITY,NAM))="" D + .S ^XTMP(PXRMXTMP,PX,FACILITY,NAM)=NAM + ;Applicable + S DDAT="N/A" + N APPL,FAPPTDT,DEFARR,DNEXT,DNEXT1,FIEV,PXRMDATE,BID,TMPSUB + S APPL=0,FAPPTDT=0 + ;Add any that aren't N/A, Ignore on N/A or NEVER to applicable total + I ($P(STATUS,U)'="")&(STATUS'["NEVER")&(STATUS'["N/A")&(STATUS'["ERROR")&(STATUS'["CNBD") S APPL=1 + ;If DUE NOW save details + I $G(STATUS)'["DUE NOW" S PNAM=" " + I $G(STATUS)["DUE NOW" D + .N BED + .S DDUE=$P($G(STATUS),U,2) + .S DLAST=$P($G(STATUS),U,3) + .;Demographics + .S PNAM=$P($G(^DPT(DFN,0)),U),BID=$P($G(^DPT(DFN,0)),U,9) + .I PNAM="" S PNAM=" " + .E S PNAM=PNAM_U_BID + .;Next appointment for location or clinic + .;For detailed provider report get next appoint. for assoc. clinic + .S DNEXT="" + .I PXRMSEL="L"!(PXRMSEL="P") S TMPSUB="PXRM FUTURE APPT" + .E S TMPSUB="SDAMA301" + .I PXRMFCMB="Y",PXRMLCMB="Y",$D(^TMP($J,TMPSUB,DFN))>0 D + ..N APPTCNT,LOC + ..S LOC=0,APPTCNT=0 + ..F S LOC=$O(^TMP($J,TMPSUB,DFN,LOC)) Q:(LOC'>0)!(APPTCNT=1) D + ...S DNEXT=$O(^TMP($J,TMPSUB,DFN,LOC,"")) I +DNEXT>0 S APPTCNT=1 Q + .S DNEXT=$O(^TMP($J,TMPSUB,DFN,$G(INP),"")) + .I PXRMFCMB="N",PXRMLCMB="Y" D + ..S DNEXT1=$O(^TMP($J,"PXRM FACILITY FUTURE APPT",DFN,FACILITY,"")) Q:DNEXT1'>0 + ..I +DNEXT=0!(DNEXT>DNEXT1) S DNEXT=DNEXT1 + .S BED=$G(^DPT(DFN,.101)) S:BED="" BED="NONE" + .;Sort by next appointment date + .I PXRMSRT="Y" S DDAT=$P(DNEXT,".") S:DDAT="" DDAT="NONE" + .;Patient ward/bed used only for inpatient reports + .I PXRMFUT="Y" S DNEXT="" + .N TXT + .S TXT=DFN_U_DDUE_U_DLAST_U_$G(DNEXT)_$S($G(BED)'="":U_BED,1:"") + .I $G(BED)'="",BED'="NONE" S DDAT=BED + .N BED + .S BED="" + .I $G(PXRMINP) D + ..S BED=$G(^DPT(DFN,.101)) S:BED="" BED="NONE" + ..S TXT=TXT_U_BED + ..;Sort by bed + ..I PXRMSRT="B" S DDAT=BED + .;Duplicate check for combined report + .I PXRMFCMB="Y",'$$NEW(NAM,DDAT,PNAM) Q + .;I PXRMFCMB'="Y",PXRMLCMB="Y",'$$NEW^PXRMXSEO(NAM,DDAT,PNAM) Q + .;Save entry in ^XTMP + .S ^XTMP(PXRMXTMP,PX,FACILITY,NAM,DDAT,PNAM)=TXT + .;Total of reminders overdue + .N CNT + .S CNT=$P(^XTMP(PXRMXTMP,PX,FACILITY,NAM),U,2) + .S $P(^XTMP(PXRMXTMP,PX,FACILITY,NAM),U,2)=CNT+1 + ;Total of patients checked/applicable + N CNT,NEW + S NEW=1 I PXRMFCMB="Y" S NEW=$$NEWP(NAM,DFN) + I NEW=1 D + .S CNT=$P(^XTMP(PXRMXTMP,PX,FACILITY,NAM),U,3) + .S $P(^XTMP(PXRMXTMP,PX,FACILITY,NAM),U,3)=CNT+1 + .S CNT=$P(^XTMP(PXRMXTMP,PX,FACILITY,NAM),U,4) + .S $P(^XTMP(PXRMXTMP,PX,FACILITY,NAM),U,4)=CNT+APPL + I PXRMFUT="Y"&($G(STATUS)["DUE NOW") D + .N APPTARY,APPTDT,CIEN,CNT,NODE,SUB + .S SUB="" I $D(^TMP($J,"PXRM FUTURE APPT",DFN))>0 S SUB="PXRM FUTURE APPT" + .I SUB="",$D(^TMP($J,"SDAMA301",DFN))>0 S SUB="SDAMA301" + .I SUB="" Q + .S CNT=0 + .S CIEN=0 F S CIEN=$O(^TMP($J,SUB,DFN,CIEN)) Q:CIEN'>0 D + ..S APPTDT=0 + ..F S APPTDT=$O(^TMP($J,SUB,DFN,CIEN,APPTDT)) Q:APPTDT'>0 D + ...S NODE=$G(^TMP($J,SUB,DFN,CIEN,APPTDT)) + ...S APPTARY(APPTDT)=APPTDT_U_$P($P(NODE,U,2),";",2)_U_$P($P(NODE,U,22),";",2) + .S APPTDT=0 F S APPTDT=$O(APPTARY(APPTDT)) Q:APPTDT'>0 S CNT=CNT+1,^XTMP(PXRMXTMP,PX,FACILITY,NAM,DDAT,PNAM,CNT,0)=APPTARY(APPTDT) + Q + ; +SUM(DFN,STATUS,FACILITY,NAM) ; + N DUE,EVAL + S (DUE,EVAL)=0 + ;Add dues to totals of reminders due and reminders applicable + I STATUS["DUE NOW" D + .S DUE=1,EVAL=1 + ;Add any that aren't N/A, Ignore on N/A,ERROR or NEVER to applicable total + S STATUS=$P(STATUS,U) + I (STATUS'=" ")&(STATUS'["NEVER")&(STATUS'="N/A")&(STATUS'["ERROR")&(STATUS'["CNBD") S EVAL=1 + ;Update XTMP - Total of reminders due + I "IR"[PXRMTOT D + .;Combined facility duplicate check + .I PXRMFCMB="Y",'$$NEW(NAM,DFN,ITEM) Q + .N CNT + .S CNT=$P($G(^XTMP(PXRMXTMP,PX,FACILITY,NAM,ITEM)),U,1) + .S $P(^XTMP(PXRMXTMP,PX,FACILITY,NAM,ITEM),U,1)=CNT+EVAL + .;Total of reminders evaluated + .S CNT=$P($G(^XTMP(PXRMXTMP,PX,FACILITY,NAM,ITEM)),U,2) + .S $P(^XTMP(PXRMXTMP,PX,FACILITY,NAM,ITEM),U,2)=CNT+DUE + ; + ;Totals + I "RT"[PXRMTOT D + .;Check for duplicate patient at FACILITY level + .I $D(^TMP("PXRMDUP",$J,FACILITY,DFN,ITEM)) Q + .;Set duplicate check + .S ^TMP("PXRMDUP",$J,FACILITY,DFN,ITEM)="" + .I $G(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL"))="" D + ..S ^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL")="TOTAL" + .N CNT + .S CNT=$P($G(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL",ITEM)),U,1) + .S $P(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL",ITEM),U,1)=CNT+EVAL + .S CNT=$P($G(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL",ITEM)),U,2) + .S $P(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL",ITEM),U,2)=CNT+DUE + ; + ;Total of patients + I "IR"[PXRMTOT D + .I PXRMSEL="I",$$NEWIP(DFN)<1 Q + .I $$NEWP(@SUB,DFN)=0 Q + .I $G(^XTMP(PXRMXTMP,PX,FACILITY,@SUB))="" S ^XTMP(PXRMXTMP,PX,FACILITY,@SUB)=NAM + .N CNT S CNT=$P($G(^XTMP(PXRMXTMP,PX,FACILITY,@SUB)),U,3) + .S $P(^XTMP(PXRMXTMP,PX,FACILITY,@SUB),U,3)=CNT+1 + ; + ;Total reports + I "TR"[PXRMTOT D + .I '$$NEWT(FACILITY,DFN) Q + .I $G(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL"))="" D + ..S ^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL")=NAM + .N CNT + .S CNT=$P($G(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL")),U,3) + .S $P(^XTMP(PXRMXTMP,PX,FACILITY,"TOTAL"),U,3)=CNT+1 + Q + ; +DBDOWN(TYPE) ; + N CNT,CNT1,CNT2,STR,NLINES,OUTPUT,TIME + K ^TMP("PXRMXMZ",$J) + S NLINES=0,CNT=0,CNT1=2 + I TYPE="C" D Q + .M ^TMP("PXRMXMZ",$J)=^TMP($J,"PXRM CNBD") + .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 S CNT=$O(DBERR(CNT)) Q:CNT'>0 S STR(CNT1)="\\"_DBERR(CNT),CNT1=CNT1+1 + .D FORMAT^PXRMTEXT(1,80,2,.STR,.NLINES,.OUTPUT) + .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))_" 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) + .S ZTSTOP=1 + Q diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMXGPR.m b/r/CLINICAL_REMINDERS-PXRM/PXRMXGPR.m index bfd482b5..e26354a2 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMXGPR.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMXGPR.m @@ -1,233 +1,233 @@ -PXRMXGPR ; SLC/PJH - Reminder Due print calls ;11/16/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ;Called from PXRMXPR - ; - ;Print Selection criteria -HEAD(PSTART) ; - I SUB="TOTAL" N NAM S NAM="TOTAL REPORT" - I PXRMTABS="Y" D Q - .N FFAC,FNAM - .S FNAM=NAM - .I "CES"[PXRMTABC S FNAM=$TR(FNAM,SEP,"_") - .I PXRMFCMB="N","LT"[PXRMSEL D Q - ..S FFAC=$TR(FACPNAME,SEP,"_") - ..W !,"0"_SEP_FFAC_"_"_FNAM_SEP_SEP - .I PXRMFCMB="N","LT"'[PXRMSEL W !,"0"_SEP_FNAM_SEP_SEP Q - .I PXRMFCMB="Y" W !,"0"_SEP_"COMBINED_REPORT_"_FNAM_SEP_SEP Q - I "LT"[PXRMSEL D - .I PXRMFCMB="N" W !,?PSTART,"Facility: ",FACPNAME Q - .W !,?PSTART,"Combined Report: " - .N FACN,LENGTH,TEXT - .S FACN=0,LENGTH=17+PSTART - .F S FACN=$O(PXRMFACN(FACN)) Q:'FACN D - ..S TEXT=$P(PXRMFACN(FACN),U)_" ("_FACN_")" - ..I $O(PXRMFACN(FACN)) S TEXT=TEXT_", " - ..I (LENGTH+$L(TEXT))>80 S LENGTH=17+PSTART W !,?(17+PSTART) - ..W TEXT S LENGTH=LENGTH+$L(TEXT) - I "PTO"[PXRMSEL D - .I SUB="TOTAL" W !,?PSTART,NAM Q - .W !,?PSTART,"Reminders "_PXRMTX_" for ",NAM - I PXRMSEL="L" W !,?PSTART,"Reminders "_PXRMTX_" "_SD_" - ",NAM - I PXRMSEL="L" D - .I "PF"[PXRMFD W " for ",BD," to ",ED - .I PXRMFD="A" W " admissions from ",BD," to ",ED - .I PXRMFD="C" W " for current inpatients" - I PXRMSEL'="L" W " for ",SD - W:PXRMSEL="I" ! - ; - Q - ; - ;Output the provider report criteria -CRIT(PSTART,PLSTCRIT) ; - N CNT,RCCNT,RCDES,RICNT,RIDES,UNDL - S CNT=0 - S UNDL=$TR($J("",79)," ","_") D LITS^PXRMXPR1 - S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART-8)_"Report Criteria:",CNT=CNT+1 - I PXRMTMP'="" S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Report Title:",22)_$P(PXRMTMP,U,3),CNT=CNT+1 - S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Patient Sample:",22)_PXRMFLD,CNT=CNT+1 - I PXRMSEL'="L" S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR(PXRMFLD_":",22) D DISP(.CNT,.PLSTCRIT) - I PXRMSEL="L" D - .S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR(PXRMFLD_":",22)_DES,CNT=CNT+1 - .I $E(PXRMLCSC,2)'="A" S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",10) D DISP(.CNT,.PLSTCRIT) - I $D(PXRMRCAT) D - .S RCCNT=0 - .F S RCCNT=$O(PXRMRCAT(RCCNT)) Q:'RCCNT D - ..S RCDES=$P(PXRMRCAT(RCCNT),U,2) - ..I RCCNT=1 S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Reminder Category:",22)_RCDES_U_6,CNT=CNT+1 - ..I RCCNT>1 S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",22)_RCDES - .S RICNT=0 - .F S RICNT=$O(PXRMREM(RICNT)) Q:'RICNT D - ..S RIDES=$P(PXRMREM(RICNT),U,2) - ..I RICNT=1 S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Individual Reminder:",22)_RIDES_U_6,CNT=CNT+1 - ..I RICNT>1 S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",22)_RIDES,CNT=CNT+1 - S PLSTCRIT(CNT)=U_6,CNT=CNT+1 - I PXRMREP="D" D - .S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Reminder:",22)_RDES,CNT=CNT+1 - .;Display future appointments for Reminder Due report only - .I PXRMRT="PXRMX" S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_"Appointments:" D - ..I PXRMFUT="Y" S PLSTCRIT(CNT)=PLSTCRIT(CNT)_$$LJ^XLFSTR(" ",32-$L(PLSTCRIT(CNT)))_"All Future Appointments",CNT=CNT+1 - ..I PXRMFUT="N" S PLSTCRIT(CNT)=PLSTCRIT(CNT)_$$LJ^XLFSTR(" ",32-$L(PLSTCRIT(CNT)))_"Next Appointment only",CNT=CNT+1 - I PXRMSEL="P" S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("All/Primary:",22)_CDES,CNT=CNT+1 - I PXRMSEL="L" D S CNT=CNT+1 - .S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Date Range:",22) - .I "PAF"[PXRMFD S PLSTCRIT(CNT)=PLSTCRIT(CNT)_BD_" to "_ED Q - .I PXRMFD="C" S PLSTCRIT(CNT)=PLSTCRIT(CNT)_"not applicable" Q - S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Effective Due Date:",22)_SD,CNT=CNT+1 - S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Date run:",22)_RD,CNT=CNT+1 - I PXRMTMP'="" D - .S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Template Name:",22)_$P(PXRMTMP,U,2),CNT=CNT+1 - .I PXRMUSER S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Requested by:",22)_$$GET1^DIQ(200,DUZ,.01)_U_3,CNT=CNT+1 - I (PXRMFCMB="Y")!(PXRMLCMB="Y")!(PXRMTCMB="Y") D - .N LIT,TEXT - .S LIT=$S(PXRMSEL="P":"Providers","OT"[PXRMSEL:"Teams",1:"Locations") - .S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Combined report:",22) - .I PXRMFCMB="Y",PXRMLCMB="Y" S TEXT="Combined Facility and Combined "_LIT - .I PXRMFCMB="Y",PXRMLCMB="N" S TEXT="Combined Facility by Individual "_LIT - .I PXRMLCMB="Y",PXRMFCMB="N" S TEXT="Combined "_LIT - .I PXRMTCMB="Y" S TEXT="Combined "_LIT - .S PLSTCRIT(CNT)=PLSTCRIT(CNT)_TEXT,CNT=CNT+1 - .S PLSTCRIT(CNT)=U_3,CNT=CNT+1 - I PXRMREP="S","IRT"[PXRMTOT,"IR"'[PXRMSEL D - .N LIT1,LIT2,LIT3,TEXT - .D LIT^PXRMXD - .S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Summary report:",22) - .I PXRMTOT="I" S TEXT=LIT1 - .I PXRMTOT="R" S TEXT=LIT2 - .I PXRMTOT="T" S TEXT=LIT3 - .S PLSTCRIT(CNT)=PLSTCRIT(CNT)_TEXT,CNT=CNT+1 - .S PLSTCRIT(CNT)=U_3,CNT=CNT+1 - I $D(PXRMSCAT),PXRMSCAT]"",PXRMFD="P" D OSCAT(PXRMSCAT,PSTART,.CNT,.PLSTCRIT) - N CHECK,CNT,NODE,STR - S CNT=0 F S CNT=$O(PLSTCRIT(CNT)) Q:CNT'>0 D - .S NODE=$G(PLSTCRIT(CNT)),CHECK=$P(NODE,U,2),STR=$P(NODE,U) - .I CHECK>0 D CHECK(CHECK) I STR="" Q - .W !,STR - W !,UNDL,! - Q - ; - ;Display selected teams/providers -DISP(CNT,PLSTCRIT) ; - N IC - S IC="" - I PXRMSEL="P" F S IC=$O(PXRMPRV(IC)) Q:IC="" D - .I IC=1 S PLSTCRIT(CNT)=PLSTCRIT(CNT)_$P(PXRMPRV(IC),U,2),CNT=CNT+1 - .I IC>1 S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",32)_$P(PXRMPRV(IC),U,2),CNT=CNT+1 - .S PLSTCRIT(CNT)=U_3,CNT=CNT+1 - I PXRMSEL="T" F S IC=$O(PXRMPCM(IC)) Q:IC="" D - .I IC=1 S PLSTCRIT(CNT)=PLSTCRIT(CNT)_$P(PXRMPCM(IC),U,2),CNT=CNT+1 - .I IC>1 S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",32)_$P(PXRMPCM(IC),U,2),CNT=CNT+1 - .S PLSTCRIT(CNT)=U_3,CNT=CNT+1 - I PXRMSEL="O" F S IC=$O(PXRMOTM(IC)) Q:IC="" D - .I IC=1 S PLSTCRIT(CNT)=PLSTCRIT(CNT)_$P(PXRMOTM(IC),U,3),CNT=CNT+1 - .I IC>1 S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",32)_$P(PXRMOTM(IC),U,2),CNT=CNT+1 - .S PLSTCRIT(CNT)=U_3,CNT=CNT+1 - I PXRMSEL="I" F S IC=$O(PXRMPAT(IC)) Q:IC="" D - .I IC=1 S PLSTCRIT(CNT)=PLSTCRIT(CNT)_$P(PXRMPAT(IC),U,2),CNT=CNT+1 - .I IC>1 S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",32)_$P(PXRMPAT(IC),U,2),CNT=CNT+1 - .S PLSTCRIT(CNT)=U_3,CNT=CNT+1 - I PXRMSEL="R" F S IC=$O(PXRMLIST(IC)) Q:IC="" D - .I IC=1 S PLSTCRIT(CNT)=PLSTCRIT(CNT)_$P(PXRMLIST(IC),U,2),CNT=CNT+1 - .I IC>1 S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",32)_$P(PXRMLIST(IC),U,2),CNT=CNT+1 - .S PLSTCRIT(CNT)=U_3,CNT=CNT+1 - I PXRMSEL="L" D - .I $E(PXRMLCSC)="H" F S IC=$O(^XTMP(PXRMXTMP,"HLOC",IC)) Q:IC="" D - ..S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",32)_$P(^XTMP(PXRMXTMP,"HLOC",IC),U,2),CNT=CNT+1 - ..S PLSTCRIT(CNT)=U_3,CNT=CNT+1 - .I $E(PXRMLCSC)="C" F S IC=$O(PXRMCS(IC)) Q:IC="" D - ..S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",32)_$P(PXRMCS(IC),U,1)_" "_$P(PXRMCS(IC),U,3),CNT=CNT+1 - ..S PLSTCRIT(CNT)=U_3,CNT=CNT+1 - .I $E(PXRMLCSC)="G" F S IC=$O(PXRMCGRP(IC)) Q:IC="" D - ..S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",32)_$P(PXRMCGRP(IC),U,2),CNT=CNT+1 - ..S PLSTCRIT(CNT)=U_3,CNT=CNT+1 - Q - ; - ;Output the service categories -OSCAT(SCL,PSTART,CNT,PLSTCRIT) ; - N IC,CSTART,EM,SC,SCTEXT - S CSTART=PSTART+3 - S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Service categories:",22)_SCL,CNT=CNT+1 - F IC=1:1:$L(SCL,",") D - .S SC=$P(SCL,",",IC) - .S SCTEXT=$$EXTERNAL^DILFD(9000010,.07,"",SC,.EM) - .S PLSTCRIT(CNT)=U_3,CNT=CNT+1 - .S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",CSTART)_SC_" - "_SCTEXT,CNT=CNT+1 - Q - ; - ;If necessary, write the header -COL(NEWPAGE) ; - I NEWPAGE D Q:DONE - .I PXRMTABS="N" D PAGE - .I PXRMTABS="Y" W !! - D CHECK(0) Q:DONE - D HEAD(0) - S HEAD=0 - I PXRMTABS="Y" Q - I PXRMREP="D" D - .N PNAM - .S PNAM=$P(PXRMREM(1),U,4) I PNAM="" S PNAM=$P(PXRMREM(1),U,2) - .W !!,PNAM,": ",COUNT - .W:COUNT>1 " patients have the reminder "_PXRMTX - .W:COUNT=1 " patient has the reminder "_PXRMTX - N IC F IC=0:1:2 W !,?PXRMT(IC),PXRMH(IC) - Q - ; - ;form feed to new page -PAGE I ($E(IOST,1,2)="C-")&(IO=IO(0))&(PAGE>0) D - .S DIR(0)="E" - .W ! - .D ^DIR K DIR - I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)) S DONE=1 Q - W:$D(IOF)&(PAGE>0) @IOF - S PAGE=PAGE+1,FIRST=0 - I $E(IOST,1,2)="C-",IO=IO(0) W @IOF - E W ! - N TEMP,TEXTLEN - S TEMP=$$NOW^XLFDT,TEMP=$$FMTE^XLFDT(TEMP,"P") - S TEMP=TEMP_" Page "_PAGE - S TEXTLEN=$L(TEMP) - W ?(IOM-TEXTLEN),TEMP - S TEXTLEN=$L(PXRMOPT) - I TEXTLEN>0 D - .W !! - .W ?((IOM-TEXTLEN)/2),PXRMOPT - Q - ; - ;count of patients in sample -TOTAL N LIT - I PXRMTABS="Y" D Q - .I PXRMREP="D" W !,"0"_SEP_"PATIENTS"_SEP_TOTAL_SEP_"APPLICABLE"_SEP_APPL Q - .I PXRMREP="S" W !,"0"_SEP_"PATIENTS"_SEP_TOTAL_SEP_SEP_$TR(SUB,SEP,"_") Q - I (PXRMRT="PXRMX")!(PXRMREP="S") W ! - ;S LIT=" patient." - ;I TOTAL>1 S LIT=" patients." - S LIT=$S(TOTAL=0:" patients.",TOTAL=1:" patient.",1:" patients.") - W !,"Report run on "_TOTAL_LIT - I PXRMREP="D" D - .S LIT=$S(APPL=0:" patients.",APPL=1:" patient.",1:" patients.") - .W !,"Applicable to "_APPL_LIT - Q - ; - ;Null report prints if no patients found -NULL I PXRMSEL="L" D - .I PXRMFD="P" W !!,"No patient visits found" - .I PXRMFD="A" W !!,"No patient admissions found" - .I PXRMFD="C" W !!,"No current inpatient found" - .I PXRMFD="F" W !!,"No patient appointments found" - I PXRMSEL="P" W !!,"No patients found for provider(s) selected" - I "OT"[PXRMSEL W !!,"No patients found for team(s) selected" - Q - ; - ;Null report if no patients due/satisfied - detailed report only -NONE D PAGE - D HEAD(0) - W !!,"No patients with reminders "_PXRMTX - Q - ; -SPACER(TEXT,LENGTH) ; - Q - ; - ;Check for page throw -CHECK(CNT) ; - I PXRMTABS="N",$Y>(IOSL-BMARG-CNT) D PAGE - Q +PXRMXGPR ; SLC/PJH - Reminder Due print calls ;01/09/2006 + ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21 + ; + ;Called from PXRMXPR + ; + ;Print Selection criteria +HEAD(PSTART) ; + I SUB="TOTAL" N NAM S NAM="TOTAL REPORT" + I PXRMTABS="Y" D Q + .N FFAC,FNAM + .S FNAM=NAM + .I "CES"[PXRMTABC S FNAM=$TR(FNAM,SEP,"_") + .I PXRMFCMB="N","LT"[PXRMSEL D Q + ..S FFAC=$TR(FACPNAME,SEP,"_") + ..W !,"0"_SEP_FFAC_"_"_FNAM_SEP_SEP + .I PXRMFCMB="N","LT"'[PXRMSEL W !,"0"_SEP_FNAM_SEP_SEP Q + .I PXRMFCMB="Y" W !,"0"_SEP_"COMBINED_REPORT_"_FNAM_SEP_SEP Q + I "LT"[PXRMSEL D + .I PXRMFCMB="N" W !,?PSTART,"Facility: ",FACPNAME Q + .W !,?PSTART,"Combined Report: " + .N FACN,LENGTH,TEXT + .S FACN=0,LENGTH=17+PSTART + .F S FACN=$O(PXRMFACN(FACN)) Q:'FACN D + ..S TEXT=$P(PXRMFACN(FACN),U)_" ("_FACN_")" + ..I $O(PXRMFACN(FACN)) S TEXT=TEXT_", " + ..I (LENGTH+$L(TEXT))>80 S LENGTH=17+PSTART W !,?(17+PSTART) + ..W TEXT S LENGTH=LENGTH+$L(TEXT) + I "PTO"[PXRMSEL D + .I SUB="TOTAL" W !,?PSTART,NAM Q + .W !,?PSTART,"Reminders "_PXRMTX_" for ",NAM + I PXRMSEL="L" W !,?PSTART,"Reminders "_PXRMTX_" "_SD_" - ",NAM + I PXRMSEL="L" D + .I "PF"[PXRMFD W " for ",BD," to ",ED + .I PXRMFD="A" W " admissions from ",BD," to ",ED + .I PXRMFD="C" W " for current inpatients" + I PXRMSEL'="L" W " for ",SD + W:PXRMSEL="I" ! + ; + Q + ; + ;Output the provider report criteria +CRIT(PSTART,PLSTCRIT) ; + N CNT,RCCNT,RCDES,RICNT,RIDES,UNDL + S CNT=0 + S UNDL=$TR($J("",79)," ","_") D LITS^PXRMXPR1 + S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART-8)_"Report Criteria:",CNT=CNT+1 + I PXRMTMP'="" S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Report Title:",22)_$P(PXRMTMP,U,3),CNT=CNT+1 + S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Patient Sample:",22)_PXRMFLD,CNT=CNT+1 + I PXRMSEL'="L" S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR(PXRMFLD_":",22) D DISP(.CNT,.PLSTCRIT) + I PXRMSEL="L" D + .S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR(PXRMFLD_":",22)_DES,CNT=CNT+1 + .I $E(PXRMLCSC,2)'="A" S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",10) D DISP(.CNT,.PLSTCRIT) + I $D(PXRMRCAT) D + .S RCCNT=0 + .F S RCCNT=$O(PXRMRCAT(RCCNT)) Q:'RCCNT D + ..S RCDES=$P(PXRMRCAT(RCCNT),U,2) + ..I RCCNT=1 S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Reminder Category:",22)_RCDES_U_6,CNT=CNT+1 + ..I RCCNT>1 S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",22)_RCDES + .S RICNT=0 + .F S RICNT=$O(PXRMREM(RICNT)) Q:'RICNT D + ..S RIDES=$P(PXRMREM(RICNT),U,2) + ..I RICNT=1 S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Individual Reminder:",22)_RIDES_U_6,CNT=CNT+1 + ..I RICNT>1 S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",22)_RIDES,CNT=CNT+1 + S PLSTCRIT(CNT)=U_6,CNT=CNT+1 + I PXRMREP="D" D + .S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Reminder:",22)_RDES,CNT=CNT+1 + .;Display future appointments for Reminder Due report only + .I PXRMRT="PXRMX" S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_"Appointments:" D + ..I PXRMFUT="Y" S PLSTCRIT(CNT)=PLSTCRIT(CNT)_$$LJ^XLFSTR(" ",32-$L(PLSTCRIT(CNT)))_"All Future Appointments",CNT=CNT+1 + ..I PXRMFUT="N" S PLSTCRIT(CNT)=PLSTCRIT(CNT)_$$LJ^XLFSTR(" ",32-$L(PLSTCRIT(CNT)))_"Next Appointment only",CNT=CNT+1 + I PXRMSEL="P" S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("All/Primary:",22)_CDES,CNT=CNT+1 + I PXRMSEL="L" D S CNT=CNT+1 + .S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Date Range:",22) + .I "PAF"[PXRMFD S PLSTCRIT(CNT)=PLSTCRIT(CNT)_BD_" to "_ED Q + .I PXRMFD="C" S PLSTCRIT(CNT)=PLSTCRIT(CNT)_"not applicable" Q + S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Effective Due Date:",22)_SD,CNT=CNT+1 + S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Date run:",22)_RD,CNT=CNT+1 + I PXRMTMP'="" D + .S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Template Name:",22)_$P(PXRMTMP,U,2),CNT=CNT+1 + .I PXRMUSER S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Requested by:",22)_$$GET1^DIQ(200,DUZ,.01)_U_3,CNT=CNT+1 + I (PXRMFCMB="Y")!(PXRMLCMB="Y")!(PXRMTCMB="Y") D + .N LIT,TEXT + .S LIT=$S(PXRMSEL="P":"Providers","OT"[PXRMSEL:"Teams",1:"Locations") + .S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Combined report:",22) + .I PXRMFCMB="Y",PXRMLCMB="Y" S TEXT="Combined Facility and Combined "_LIT + .I PXRMFCMB="Y",PXRMLCMB="N" S TEXT="Combined Facility by Individual "_LIT + .I PXRMLCMB="Y",PXRMFCMB="N" S TEXT="Combined "_LIT + .I PXRMTCMB="Y" S TEXT="Combined "_LIT + .S PLSTCRIT(CNT)=PLSTCRIT(CNT)_TEXT,CNT=CNT+1 + .S PLSTCRIT(CNT)=U_3,CNT=CNT+1 + I PXRMREP="S","IRT"[PXRMTOT,"IR"'[PXRMSEL D + .N LIT1,LIT2,LIT3,TEXT + .D LIT^PXRMXD + .S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Summary report:",22) + .I PXRMTOT="I" S TEXT=LIT1 + .I PXRMTOT="R" S TEXT=LIT2 + .I PXRMTOT="T" S TEXT=LIT3 + .S PLSTCRIT(CNT)=PLSTCRIT(CNT)_TEXT,CNT=CNT+1 + .S PLSTCRIT(CNT)=U_3,CNT=CNT+1 + I $D(PXRMSCAT),PXRMSCAT]"",PXRMFD="P" D OSCAT(PXRMSCAT,PSTART,.CNT,.PLSTCRIT) + N CHECK,CNT,NODE,STR + S CNT=0 F S CNT=$O(PLSTCRIT(CNT)) Q:CNT'>0 D + .S NODE=$G(PLSTCRIT(CNT)),CHECK=$P(NODE,U,2),STR=$P(NODE,U) + .I CHECK>0 D CHECK(CHECK) I STR="" Q + .W !,STR + W !,UNDL,! + Q + ; + ;Display selected teams/providers +DISP(CNT,PLSTCRIT) ; + N IC + S IC="" + I PXRMSEL="P" F S IC=$O(PXRMPRV(IC)) Q:IC="" D + .I IC=1 S PLSTCRIT(CNT)=PLSTCRIT(CNT)_$P(PXRMPRV(IC),U,2),CNT=CNT+1 + .I IC>1 S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",32)_$P(PXRMPRV(IC),U,2),CNT=CNT+1 + .S PLSTCRIT(CNT)=U_3,CNT=CNT+1 + I PXRMSEL="T" F S IC=$O(PXRMPCM(IC)) Q:IC="" D + .I IC=1 S PLSTCRIT(CNT)=PLSTCRIT(CNT)_$P(PXRMPCM(IC),U,2),CNT=CNT+1 + .I IC>1 S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",32)_$P(PXRMPCM(IC),U,2),CNT=CNT+1 + .S PLSTCRIT(CNT)=U_3,CNT=CNT+1 + I PXRMSEL="O" F S IC=$O(PXRMOTM(IC)) Q:IC="" D + .I IC=1 S PLSTCRIT(CNT)=PLSTCRIT(CNT)_$P(PXRMOTM(IC),U,3),CNT=CNT+1 + .I IC>1 S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",32)_$P(PXRMOTM(IC),U,2),CNT=CNT+1 + .S PLSTCRIT(CNT)=U_3,CNT=CNT+1 + I PXRMSEL="I" F S IC=$O(PXRMPAT(IC)) Q:IC="" D + .I IC=1 S PLSTCRIT(CNT)=PLSTCRIT(CNT)_$P(PXRMPAT(IC),U,2),CNT=CNT+1 + .I IC>1 S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",32)_$P(PXRMPAT(IC),U,2),CNT=CNT+1 + .S PLSTCRIT(CNT)=U_3,CNT=CNT+1 + I PXRMSEL="R" F S IC=$O(PXRMLIST(IC)) Q:IC="" D + .I IC=1 S PLSTCRIT(CNT)=PLSTCRIT(CNT)_$P(PXRMLIST(IC),U,2),CNT=CNT+1 + .I IC>1 S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",32)_$P(PXRMLIST(IC),U,2),CNT=CNT+1 + .S PLSTCRIT(CNT)=U_3,CNT=CNT+1 + I PXRMSEL="L" D + .I $E(PXRMLCSC)="H" F S IC=$O(^XTMP(PXRMXTMP,"HLOC",IC)) Q:IC="" D + ..S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",32)_$P(^XTMP(PXRMXTMP,"HLOC",IC),U,2),CNT=CNT+1 + ..S PLSTCRIT(CNT)=U_3,CNT=CNT+1 + .I $E(PXRMLCSC)="C" F S IC=$O(PXRMCS(IC)) Q:IC="" D + ..S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",32)_$P(PXRMCS(IC),U,1)_" "_$P(PXRMCS(IC),U,3),CNT=CNT+1 + ..S PLSTCRIT(CNT)=U_3,CNT=CNT+1 + .I $E(PXRMLCSC)="G" F S IC=$O(PXRMCGRP(IC)) Q:IC="" D + ..S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",32)_$P(PXRMCGRP(IC),U,2),CNT=CNT+1 + ..S PLSTCRIT(CNT)=U_3,CNT=CNT+1 + Q + ; + ;Output the service categories +OSCAT(SCL,PSTART,CNT,PLSTCRIT) ; + N IC,CSTART,EM,SC,SCTEXT + S CSTART=PSTART+3 + S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",PSTART)_$$LJ^XLFSTR("Service categories:",22)_SCL,CNT=CNT+1 + F IC=1:1:$L(SCL,",") D + .S SC=$P(SCL,",",IC) + .S SCTEXT=$$EXTERNAL^DILFD(9000010,.07,"",SC,.EM) + .S PLSTCRIT(CNT)=U_3,CNT=CNT+1 + .S PLSTCRIT(CNT)=$$RJ^XLFSTR(" ",CSTART)_SC_" - "_SCTEXT,CNT=CNT+1 + Q + ; + ;If necessary, write the header +COL(NEWPAGE) ; + I NEWPAGE D Q:DONE + .I PXRMTABS="N" D PAGE + .I PXRMTABS="Y" W !! + D CHECK(0) Q:DONE + D HEAD(0) + S HEAD=0 + I PXRMTABS="Y" Q + I PXRMREP="D" D + .N PNAM + .S PNAM=$P(PXRMREM(1),U,4) I PNAM="" S PNAM=$P(PXRMREM(1),U,2) + .W !!,PNAM,": ",COUNT + .W:COUNT>1 " patients have the reminder "_PXRMTX + .W:COUNT=1 " patient has the reminder "_PXRMTX + N IC F IC=0:1:2 W !,?PXRMT(IC),PXRMH(IC) + Q + ; + ;form feed to new page +PAGE I ($E(IOST)="C")&(IO=IO(0))&(PAGE>0) D + .S DIR(0)="E" + .W ! + .D ^DIR K DIR + I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)) S DONE=1 Q + W:$D(IOF)&(PAGE>0) @IOF + S PAGE=PAGE+1,FIRST=0 + I $E(IOST)="C",IO=IO(0) W @IOF + E W ! + N TEMP,TEXTLEN + S TEMP=$$NOW^XLFDT,TEMP=$$FMTE^XLFDT(TEMP,"P") + S TEMP=TEMP_" Page "_PAGE + S TEXTLEN=$L(TEMP) + W ?(IOM-TEXTLEN),TEMP + S TEXTLEN=$L(PXRMOPT) + I TEXTLEN>0 D + .W !! + .W ?((IOM-TEXTLEN)/2),PXRMOPT + Q + ; + ;count of patients in sample +TOTAL N LIT + I PXRMTABS="Y" D Q + .I PXRMREP="D" W !,"0"_SEP_"PATIENTS"_SEP_TOTAL_SEP_"APPLICABLE"_SEP_APPL Q + .I PXRMREP="S" W !,"0"_SEP_"PATIENTS"_SEP_TOTAL_SEP_SEP_$TR(SUB,SEP,"_") Q + I (PXRMRT="PXRMX")!(PXRMREP="S") W ! + ;S LIT=" patient." + ;I TOTAL>1 S LIT=" patients." + S LIT=$S(TOTAL=0:" patients.",TOTAL=1:" patient.",1:" patients.") + W !,"Report run on "_TOTAL_LIT + I PXRMREP="D" D + .S LIT=$S(APPL=0:" patients.",APPL=1:" patient.",1:" patients.") + .W !,"Applicable to "_APPL_LIT + Q + ; + ;Null report prints if no patients found +NULL I PXRMSEL="L" D + .I PXRMFD="P" W !!,"No patient visits found" + .I PXRMFD="A" W !!,"No patient admissions found" + .I PXRMFD="C" W !!,"No current inpatient found" + .I PXRMFD="F" W !!,"No patient appointments found" + I PXRMSEL="P" W !!,"No patients found for provider(s) selected" + I "OT"[PXRMSEL W !!,"No patients found for team(s) selected" + Q + ; + ;Null report if no patients due/satisfied - detailed report only +NONE D PAGE + D HEAD(0) + W !!,"No patients with reminders "_PXRMTX + Q + ; +SPACER(TEXT,LENGTH) ; + Q + ; + ;Check for page throw +CHECK(CNT) ; + I PXRMTABS="N",$Y>(IOSL-BMARG-CNT) D PAGE + Q diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMXGUT.m b/r/CLINICAL_REMINDERS-PXRM/PXRMXGUT.m index 2043ec30..27381d0a 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMXGUT.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMXGUT.m @@ -1,98 +1,90 @@ -PXRMXGUT ; SLC/PJH - General utilities for reminder reports; 11/16/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ;======================================= -EOR ;End of report display. - I $E(IOST,1,2)="C-",IO=IO(0) D - . S DIR(0)="EA" - . S DIR("A")="End of the report. Press ENTER/RETURN to continue..." - . W ! - . D ^DIR K DIR - Q - ; - ;======================================= -EXIT ;Clean things up. - D ^%ZISC - D HOME^%ZIS - K IO("Q") - K DIRUT,DTOUT,DUOUT,POP - K ^TMP(PXRMXTMP) - K ^XTMP(PXRMXTMP) - K ^TMP("PXRMX",$J) - K ^TMP($J,"PXRM PATIENT LIST") - K ^TMP($J,"PXRM PATIENT EVAL") - K ^TMP($J,"PXRM FUTURE APPT") - K ^TMP($J,"PXRM FACILITY FUTURE APPT") - K ^TMP($J,"SDAMA301") - K ^TMP($J,"SORT") - Q - ; - ;======================================= -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 - ; - ;======================================= -USTRINS(STRING,CHAR) ;Given a string, which is assumed to be in alphabetical - ;order and a character which is not already in the string insert the - ;character into the string in alphabetical order. For example: - ;STRING CHAR RETURNS - ;CEQ A ACEQ - ;CEQ E CEQ - ;CEQ F CEFQ - ;CEQ T CEQT - ; - N CH1,CH2,DONE,IC,LEN,STR - S LEN=$L(STRING) - ;Special case of empty STRING. - I LEN=0 Q CHAR - ; - S DONE=0 - S STR="" - S CH1=$E(STRING,1,1) - I (CH1]CHAR) S STR=STR_CHAR_CH1,DONE=1 - E S STR=STR_CH1 - I CH1=CHAR S DONE=1 - ; - ;Special case of STRING of length 1. - I (LEN=1)&('DONE) S STR=STR_CHAR,DONE=1 - ; - F IC=2:1:LEN D - . S CH2=$E(STRING,IC,IC) - . I DONE S STR=STR_CH2 - . E D - .. I (CHAR]CH1)&(CH2]CHAR) S STR=STR_CHAR_CH2,DONE=1 - .. E S STR=STR_CH2 - .. I CH2=CHAR S DONE=1 - .. S CH1=CH2 - ; - ;If we made it all the way through the loop and we are still not - ;done then append CHAR. - I ('DONE) S STR=STR_CHAR - 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 - ; +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)="C",IO=IO(0) D + . S DIR(0)="EA" + . S DIR("A")="End of the report. Press ENTER/RETURN to continue..." + . W ! + . D ^DIR K DIR + Q + ; + ;======================================= +EXIT ;Clean things up. + D ^%ZISC + D HOME^%ZIS + K IO("Q") + K DIRUT,DTOUT,DUOUT,POP + K ^TMP(PXRMXTMP) + K ^XTMP(PXRMXTMP) + K ^TMP("PXRMX",$J) + K ^TMP($J,"PXRM PATIENT LIST") + K ^TMP($J,"PXRM PATIENT EVAL") + K ^TMP($J,"PXRM FUTURE APPT") + K ^TMP($J,"PXRM FACILITY FUTURE APPT") + K ^TMP($J,"SDAMA301") + K ^TMP($J,"SORT") + 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 + ; + ;======================================= +USTRINS(STRING,CHAR) ;Given a string, which is assumed to be in alphabetical + ;order and a character which is not already in the string insert the + ;character into the string in alphabetical order. For example: + ;STRING CHAR RETURNS + ;CEQ A ACEQ + ;CEQ E CEQ + ;CEQ F CEFQ + ;CEQ T CEQT + ; + N CH1,CH2,DONE,IC,LEN,STR + S LEN=$L(STRING) + ;Special case of empty STRING. + I LEN=0 Q CHAR + ; + S DONE=0 + S STR="" + S CH1=$E(STRING,1,1) + I (CH1]CHAR) S STR=STR_CHAR_CH1,DONE=1 + E S STR=STR_CH1 + I CH1=CHAR S DONE=1 + ; + ;Special case of STRING of length 1. + I (LEN=1)&('DONE) S STR=STR_CHAR,DONE=1 + ; + F IC=2:1:LEN D + . S CH2=$E(STRING,IC,IC) + . I DONE S STR=STR_CH2 + . E D + .. I (CHAR]CH1)&(CH2]CHAR) S STR=STR_CHAR_CH2,DONE=1 + .. E S STR=STR_CH2 + .. I CH2=CHAR S DONE=1 + .. S CH1=CH2 + ; + ;If we made it all the way through the loop and we are still not + ;done then append CHAR. + I ('DONE) S STR=STR_CHAR + Q STR + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMXPR.m b/r/CLINICAL_REMINDERS-PXRM/PXRMXPR.m index 37f1f83a..2c2c16a5 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMXPR.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMXPR.m @@ -1,284 +1,283 @@ -PXRMXPR ; SLC/PJH - Print Reminder Due report. ;11/27/2006 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ; Called/Jobbed after PXRMXSE1 - ; -START N BMARG,CRITERIA,C1S,C2S,C3S,C1HS,C2HS,C3HS,DONE,FIRST,HEAD - N INDENT,PAGE,MOD,DES,ADES,CDES,RDES,SDES,MISSED,SEP - N PLSTCRIT,PXRMOPT,PXRMFLD,PXRMHDR,PXRMHDRS,PXRMT,PXRMH - N BD,ED,EMPCHK,SD,RD - N PXRMTX - S PXRMTX="due" - ; - I PXRMREP="D" D - .S EMPCHK=$P($G(^PXRM(800,1,"TRUNCATE EMPLOYEE SSN")),U) - .I EMPCHK="" S EMPCHK="Y" - ; - ; Format Date Range - I PXRMSEL="L" D - .S BD=$$FMTE^XLFDT(PXRMBDT,"5D") - .S ED=$$FMTE^XLFDT(PXRMEDT,"5D") - ; Format due effective date - S SD=$$FMTE^XLFDT(PXRMSDT,"5P") - ; Format run date - S RD=$$FMTE^XLFDT(PXRMXST,"5P") - ; - U IO - S DONE=0 - ; - ;Delimited report. - S SEP=$S(PXRMTABS="Y":PXRMTABC,1:"") - ; - ;Setup initial formatting parameters. - S INDENT=3 - S BMARG=2,PAGE=0,HEAD=1 - ; - I +$G(XQY)>0 N XQOPT D OP^XQCHK - S PXRMOPT=$P($G(XQOPT),U,2) - I ($L(PXRMOPT)>0)&(PXRMOPT'["Clinical") S PXRMOPT="Clinical "_PXRMOPT - I PXRMREP="D" D - .S RDES=$P(REMINDER(1),U,2) - .S PXRMOPT=PXRMOPT_" - Detailed Report" - .N IC F IC=0,3,4 S PXRMH(IC)="",PXRMT(IC)=0 - .S PXRMH(1)="Date Due Last Done Next Appt" - .S PXRMH(2)="-------- --------- ---------" - .I $G(PXRMINP) D - ..S PXRMH(1)="Date Due Last Done Ward/Bed" - ..S PXRMH(2)="-------- --------- --------" - .F IC=1,2 S PXRMT(IC)=40 - .S ADES="Next Appointment only" - .I PXRMFUT="Y" S ADES="All Future Appointments" - .S SDES="Sorted by Patient Name" - .I PXRMSRT="Y" S SDES="Sorted by Appointment Date" - I PXRMREP="S" D - .S PXRMOPT=PXRMOPT_" - Summary Report" - .S PXRMH(0)="# Patients with Reminders",PXRMT(0)=50 - .S PXRMH(1)="Applicable Due" - .S PXRMH(2)="---------- ---" - .N IC F IC=1,2 S PXRMT(IC)=50 - .S PXRMH(3)="Denominator" - .S PXRMH(4)="-----------" - .F IC=3,4 S PXRMT(IC)=0 - ; - ;Print Criteria Page if normal report - S CRITERIA=0 I PXRMTABS="N" S CRITERIA=1 - ;or delimited report with notemplate - I PXRMTABS="Y",PXRMTMP="" S CRITERIA=1 - ; - ;Build array of locations/providers with no patients selected in - ;MISSED. - D NOPATS^PXRMXPR1(.MISSED) - ; - ;Print either criteria page or summary header - I CRITERIA D G:DONE EXIT - .D PAGE^PXRMXGPR Q:DONE - .D CRIT^PXRMXGPR(10,.PLSTCRIT) Q:DONE - ;Header if delimited output from a template - I 'CRITERIA D - .N HDR1,HDR2,HDR3 - .S HDR1="",HDR2="",HDR3="" - .I PXRMTMP]"" S HDR1="TITLE:"_$P(PXRMTMP,U,2)_U_"TEMPLATE:"_$P(PXRMTMP,U,3) - .I PXRMTMP="" D - ..N PXRMFLD,DES,CDES D LITS^PXRMXPR1 S HDR1=PXRMFLD_U_$G(DES)_U_$G(CDES) - .I PXRMSEL="L" S HDR2="START:"_BD_U_"END:"_ED - .S HDR2=HDR2_U_"RUN:"_RD_"Effective Date:"_SD - .I PXRMFCMB="Y" S HDR3="COMBINED FACILITY" - .I PXRMLCMB="Y" S $P(HDR3,SEP,2)="COMBINED LOCATION" - .I PXRMTCMB="Y" S $P(HDR3,SEP,2)="COMBINED OE/RR TEAMS" - .I PXRMREP="S" D - ..N LIT1,LIT2,LIT3 - ..D LIT^PXRMXD - ..I PXRMTOT="I" S $P(HDR3,SEP,3)=$$UP^XLFSTR(LIT1) - ..I PXRMTOT="R" S $P(HDR3,SEP,3)=$$UP^XLFSTR(LIT2) - ..I PXRMTOT="T" S $P(HDR3,SEP,3)=$$UP^XLFSTR(LIT3) - .S PLSTCRIT(1)=HDR1,PLSTCRIT(2)=HDR2,PLSTCRIT(3)=HDR3 - .W !,HDR1,!,HDR2,!,HDR3,! - ; - ;Kill items marked as found - K ^XTMP(PXRMXTMP,"MARKED AS FOUND") - ; - ;Setup the final formatting parameters. - S C1HS=INDENT+3 - S C1S=0 - S C2HS=C1S+2 - S C2S=C2HS - S C3HS=C2HS+5 - S C3S=C3HS - S HEAD=1 - S INDENT=10 - ; - ; Update last run date - I $G(PXRMTMP)'="" D UPD^PXRMXTU - ; - ; Get report detail from ^XTMP - N PNAM,SUB,DFN,BID,NAM,FAC,MOD,SRT,TOTAL,APPL,FACPNAME,PX,TTOTAL - S TTOTAL=0 - ; Set subroutine label from report format - S MOD="SUMARY" I PXRMREP="D" S MOD="DETAIL" - ; - S FAC=0,PX="PXRM" - F S FAC=$O(^XTMP(PXRMXTMP,PX,FAC)) Q:FAC="" Q:DONE D - .;Get facility name for Location and PCMM team report - .I "TL"[PXRMSEL,PXRMFCMB="N" D - ..S FACPNAME=$P(PXRMFACN(FAC),U,1)_" "_$P(PXRMFACN(FAC),U,2) - .;Report from ^XTMP - label MOD is DETAIL/SUMARY - .S (PNAM,SUB,NAM,SRT)="" - .I PXRMSEL="I" S SUB="INDIVIDUAL PATIENTS" D @MOD Q:DONE - .I PXRMSEL'="I" D - ..;Sort internal IENs into alpha order - ..D XSORT - ..F S SRT=$O(^TMP($J,"SORT",SRT)) Q:SRT="" Q:DONE D - ...S SUB=$G(^TMP($J,"SORT",SRT)) D @MOD - ..I MOD="SUMARY","RT"[PXRMTOT S SUB="TOTAL" D @MOD - ; - ; Null report if no patients selected - 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) - ; - ;Print Patient List - I $G(PATLST)="Y" D FOOTER^PXRMXPR1(.PLSTCRIT) - ; - ;Print Error message - I $D(^XTMP(PXRMXTMP,"ERROR"))>0!($D(^XTMP(PXRMXTMP,"CNBD"))>0) D ERROR^PXRMXBSY -EXIT ; - D TIMING^PXRMXGUT - D EXIT^PXRMXGUT - ; - ;Allow the task to be cleaned up upon successful completion. - I $D(ZTQUEUED) S ZTREQ="@" - ; - D EOR^PXRMXGUT - Q - ; - ;Report by Patient -DETAIL N JJ,VA,DATE,COUNT,DDAT,EMP - N BED,DDUE,DDONE,DNEXT,FDAT1,FDAT2,FDAT3,FNAM,FTXT - S NAM=$G(^XTMP(PXRMXTMP,PX,FAC,SUB)),HEAD=1 - S COUNT=$P(NAM,U,2),TOTAL=$P(NAM,U,3),APPL=$P(NAM,U,4),NAM=$P(NAM,U,1) - S DDAT="",JJ=0 - ; Get list of patients for each appointment date - F S DDAT=$O(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT)) Q:DDAT="" Q:DONE D PAT - ; No patients due - I JJ=0 D:'DONE NONE^PXRMXGPR - ; Total patients - D:'DONE TOTAL^PXRMXGPR - S TTOTAL=TTOTAL+TOTAL - Q - ; -PAT ;Extract and print patient detail - N DNEXT1,NODE,PNUM - F S PNAM=$O(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM)) Q:PNAM="" Q:DONE D - .S JJ=JJ+1 - .;Format print line - .S (BID,DNEXT1,FDAT1,FDAT2,FDAT3,DNEXT1)="" I PNAM'["No patients found" D - ..S FDAT2="N/A",FDAT3="None" - ..S NODE=$G(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM)) - ..S DDUE=$P(NODE,U,2),DDONE=$P(NODE,U,3),DNEXT=$P(NODE,U,4) - ..S BED=$P(NODE,U,5) - ..S DFN=$P(NODE,U) S BID=$P($G(PNAM),U,2) - ..I PXRMSSN="N" S BID=$E(BID,6,9) - ..I PXRMSSN="Y",EMPCHK="Y" D EMP S:EMP BID=$E(BID,6,9) - ..S BID="("_BID_")" - ..S FDAT1=$$FMTE^XLFDT(DDUE,"5D") - ..I DDONE S FDAT2=$$FMTE^XLFDT(DDONE,"5D") - ..I BED'="NONE" S FDAT3=$P(NODE,U,5),DNEXT1=$$FMTE^XLFDT(DNEXT,"5D") - ..I DNEXT,FDAT3="None" S FDAT3=$$FMTE^XLFDT(DNEXT,"5D") - .;Print - .D CHECK Q:DONE - .;Normal output - .I PXRMTABS="N" D - ..S PNUM=JJ#10000 - ..S PNUM=$$RJ^XLFSTR(PNUM,4) - ..W !,PNUM,?5,$E($P($G(PNAM),U),1,33-$L(BID))," ",BID,?40,FDAT1,?52,FDAT2 - ..I ('$G(PXRMINP)),PXRMFUT'="Y" W ?64,$S(BED'="NONE":BED_" (Inp.)",1:FDAT3) - ..I $G(PXRMINP) W ?64,BED - ..I DNEXT1'="",PXRMFUT'="Y" W !,?64,DNEXT1 - .;Delimited report - .I PXRMTABS="Y" D - ..N FNAM - ..S FNAM=$P($G(PNAM),U) - ..I FNAM'["No patients found" S FNAM=$E(FNAM,1,33-$L(BID))_" "_BID - ..I "CES"[PXRMTABC S FNAM=$TR(FNAM,SEP,"_"),FDAT1=$TR(FDAT1,SEP,"_") - ..I BED="NONE" S BED=" " - ..W !,JJ_SEP_FNAM_SEP_FDAT1_SEP_FDAT2 I $G(PXRMINP) W SEP_BED - ..I ('$G(PXRMINP)),PXRMFUT'="Y" W SEP_FDAT3_SEP_BED - .;--- - .; Future Appointments - .I PXRMFUT="Y" D - ..N CNT,ADAT,ALOC,ATYP,FIRST,NONE - ..S CNT=0,NONE=1,FIRST=1 - ..I '$D(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM)) Q - ..F S CNT=$O(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM,CNT)) Q:CNT'>0 D - ...S ADAT=$P(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM,CNT,0),U) - ...I PXRMDLOC="Y" D - ....S ALOC=$P(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM,CNT,0),U,2) - ....S ATYP=$P(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM,CNT,0),U,3) - ...S ADAT=$$FMTE^XLFDT(ADAT,"2P") - ...I FIRST D S FIRST=0,NONE=0 - ....I PXRMTABS="N" W ?64,$S(BED'="NONE":BED_" (Inp.)",1:"") - ...D CHECK - ...I PXRMDLOC="Y" D - ....I PXRMTABS="N" W !,?8,ADAT,?30,$E(ALOC,1,25),?60,$E(ATYP,1,20) - ....I PXRMTABS="Y" W SEP_ADAT_SEP_$E(ALOC,1,25)_SEP_$E(ATYP,1,20) - ...I PXRMDLOC="N" D - ....I PXRMTABS="N" W !,?10,ADAT - ....I PXRMTABS="Y" W SEP_ADAT - ..I NONE,PXRMTABS="N" W ?64,FDAT3 - ..I NONE,PXRMTABS="Y" W SEP_FDAT3 - ..I PXRMTABS="Y" W $S(BED'="NONE":SEP_BED_" (Inp.)",1:"") - ..K ^UTILITY("VASD",$J) - Q - ; - ;Summary by Reminder -SUMARY N JJ,EVAL,DUE,RNAM,RNUM,ITEM,COUNT,FTXT - S NAM=$G(^XTMP(PXRMXTMP,PX,FAC,SUB)),HEAD=1 - S TOTAL=$P(NAM,U,3),COUNT=$P(NAM,U,2),NAM=$P(NAM,U,1) - S RNUM=$O(REMINDER(""),-1) - ;Get reminders in alpha order - F JJ=1:1:RNUM D Q:DONE - .S ITEM=$P(REMINDER(JJ),U,1),RNAM=$P(REMINDER(JJ),U,4) - .S:RNAM="" RNAM=$P(REMINDER(JJ),U,2) - .; zero lines will be printed - .S DUE=$G(^XTMP(PXRMXTMP,PX,FAC,SUB,ITEM)) - .S EVAL=+$P(DUE,U,1),DUE=+$P(DUE,U,2) - .;Print - .D CHECK Q:DONE - .;Normal Report - .I PXRMTABS="N" W !,JJ,?5,RNAM,?48,$J(EVAL,10),?63,$J(DUE,10) - .;Condensed Report - .I PXRMTABS="Y" D - ..I "CES"[PXRMTABC S RNAM=$TR(RNAM,SEP,"_") - ..W !,JJ_SEP_RNAM_SEP_EVAL_SEP_DUE_SEP_$TR(NAM,SEP,"_") - D:'DONE TOTAL^PXRMXGPR - I $G(SUB)'="TOTAL",PXRMTOT'="T" S TTOTAL=TTOTAL+TOTAL - I $G(SUB)="TOTAL",PXRMTOT="T" S TTOTAL=TTOTAL+TOTAL - Q - ; - ;Check line count before writing line -CHECK I ((PXRMTABS="N")&($Y>(IOSL-BMARG-3)))!(HEAD=1) D COL^PXRMXGPR(1) - Q - ; - ;Check if employee -EMP N VAEL - D ELIG^VADPT - ;Check TYPE (#391) field - I $P($G(VAEL(6)),U,2)="EMPLOYEE" S EMP=1 Q - ;Check PATIENT ELIGABILITY (#361) field - N ELIG - S ELIG=0,EMP=0 - F S ELIG=$O(VAEL(1,ELIG)) Q:'ELIG D Q:EMP - .I $P($G(VAEL(1,ELIG)),U,2)="EMPLOYEE" S EMP=1 - Q - ; - ;Sort internal numbers into Alpha order -XSORT N SUB,NAM - K ^TMP($J,"SORT") - S SUB="" - F S SUB=$O(^XTMP(PXRMXTMP,PX,FAC,SUB)) Q:SUB="" D - .Q:SUB="TOTAL" - .S NAM=$P(^XTMP(PXRMXTMP,PX,FAC,SUB),U) - .I NAM="" S NAM=SUB - .S ^TMP($J,"SORT",NAM)=SUB - Q - ; +PXRMXPR ; SLC/PJH - Print Reminder Due report. ;01/14/2006 + ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21 + ; + ; Called/Jobbed after PXRMXSE1 + ; +START N BMARG,CRITERIA,C1S,C2S,C3S,C1HS,C2HS,C3HS,DONE,FIRST,HEAD + N INDENT,PAGE,MOD,DES,ADES,CDES,RDES,SDES,MISSED,SEP + N PLSTCRIT,PXRMOPT,PXRMFLD,PXRMHDR,PXRMHDRS,PXRMT,PXRMH + N BD,ED,EMPCHK,SD,RD + N PXRMTX + S PXRMTX="due" + ; + I PXRMREP="D" D + .S EMPCHK=$P($G(^PXRM(800,1,"TRUNCATE EMPLOYEE SSN")),U) + .I EMPCHK="" S EMPCHK="Y" + ; + ; Format Date Range + I PXRMSEL="L" D + .S BD=$$FMTE^XLFDT(PXRMBDT,"5D") + .S ED=$$FMTE^XLFDT(PXRMEDT,"5D") + ; Format due effective date + S SD=$$FMTE^XLFDT(PXRMSDT,"5P") + ; Format run date + S RD=$$FMTE^XLFDT(PXRMXST,"5P") + ; + U IO + S DONE=0 + ; + ;Delimited report. + S SEP=$S(PXRMTABS="Y":PXRMTABC,1:"") + ; + ;Setup initial formatting parameters. + S INDENT=3 + S BMARG=2,PAGE=0,HEAD=1 + ; + I +$G(XQY)>0 N XQOPT D OP^XQCHK + S PXRMOPT=$P($G(XQOPT),U,2) + I ($L(PXRMOPT)>0)&(PXRMOPT'["Clinical") S PXRMOPT="Clinical "_PXRMOPT + I PXRMREP="D" D + .S RDES=$P(REMINDER(1),U,2) + .S PXRMOPT=PXRMOPT_" - Detailed Report" + .N IC F IC=0,3,4 S PXRMH(IC)="",PXRMT(IC)=0 + .S PXRMH(1)="Date Due Last Done Next Appt" + .S PXRMH(2)="-------- --------- ---------" + .I $G(PXRMINP) D + ..S PXRMH(1)="Date Due Last Done Ward/Bed" + ..S PXRMH(2)="-------- --------- --------" + .F IC=1,2 S PXRMT(IC)=40 + .S ADES="Next Appointment only" + .I PXRMFUT="Y" S ADES="All Future Appointments" + .S SDES="Sorted by Patient Name" + .I PXRMSRT="Y" S SDES="Sorted by Appointment Date" + I PXRMREP="S" D + .S PXRMOPT=PXRMOPT_" - Summary Report" + .S PXRMH(0)="# Patients with Reminders",PXRMT(0)=50 + .S PXRMH(1)="Applicable Due" + .S PXRMH(2)="---------- ---" + .N IC F IC=1,2 S PXRMT(IC)=50 + .S PXRMH(3)="Denominator" + .S PXRMH(4)="-----------" + .F IC=3,4 S PXRMT(IC)=0 + ; + ;Print Criteria Page if normal report + S CRITERIA=0 I PXRMTABS="N" S CRITERIA=1 + ;or delimited report with notemplate + I PXRMTABS="Y",PXRMTMP="" S CRITERIA=1 + ; + ;Build array of locations/providers with no patients selected in + ;MISSED. + D NOPATS^PXRMXPR1(.MISSED) + ; + ;Print either criteria page or summary header + I CRITERIA D G:DONE EXIT + .D PAGE^PXRMXGPR Q:DONE + .D CRIT^PXRMXGPR(10,.PLSTCRIT) Q:DONE + ;Header if delimited output from a template + I 'CRITERIA D + .N HDR1,HDR2,HDR3 + .S HDR1="",HDR2="",HDR3="" + .I PXRMTMP]"" S HDR1="TITLE:"_$P(PXRMTMP,U,2)_U_"TEMPLATE:"_$P(PXRMTMP,U,3) + .I PXRMTMP="" D + ..N PXRMFLD,DES,CDES D LITS^PXRMXPR1 S HDR1=PXRMFLD_U_$G(DES)_U_$G(CDES) + .I PXRMSEL="L" S HDR2="START:"_BD_U_"END:"_ED + .S HDR2=HDR2_U_"RUN:"_RD_"Effective Date:"_SD + .I PXRMFCMB="Y" S HDR3="COMBINED FACILITY" + .I PXRMLCMB="Y" S $P(HDR3,SEP,2)="COMBINED LOCATION" + .I PXRMTCMB="Y" S $P(HDR3,SEP,2)="COMBINED OE/RR TEAMS" + .I PXRMREP="S" D + ..N LIT1,LIT2,LIT3 + ..D LIT^PXRMXD + ..I PXRMTOT="I" S $P(HDR3,SEP,3)=$$UP^XLFSTR(LIT1) + ..I PXRMTOT="R" S $P(HDR3,SEP,3)=$$UP^XLFSTR(LIT2) + ..I PXRMTOT="T" S $P(HDR3,SEP,3)=$$UP^XLFSTR(LIT3) + .S PLSTCRIT(1)=HDR1,PLSTCRIT(2)=HDR2,PLSTCRIT(3)=HDR3 + .W !,HDR1,!,HDR2,!,HDR3,! + ; + ;Kill items marked as found + K ^XTMP(PXRMXTMP,"MARKED AS FOUND") + ; + ;Setup the final formatting parameters. + S C1HS=INDENT+3 + S C1S=0 + S C2HS=C1S+2 + S C2S=C2HS + S C3HS=C2HS+5 + S C3S=C3HS + S HEAD=1 + S INDENT=10 + ; + ; Update last run date + I $G(PXRMTMP)'="" D UPD^PXRMXTU + ; + ; Get report detail from ^XTMP + N PNAM,SUB,DFN,BID,NAM,FAC,MOD,SRT,TOTAL,APPL,FACPNAME,PX,TTOTAL + S TTOTAL=0 + ; Set subroutine label from report format + S MOD="SUMARY" I PXRMREP="D" S MOD="DETAIL" + ; + S FAC=0,PX="PXRM" + F S FAC=$O(^XTMP(PXRMXTMP,PX,FAC)) Q:FAC="" Q:DONE D + .;Get facility name for Location and PCMM team report + .I "TL"[PXRMSEL,PXRMFCMB="N" D + ..S FACPNAME=$P(PXRMFACN(FAC),U,1)_" "_$P(PXRMFACN(FAC),U,2) + .;Report from ^XTMP - label MOD is DETAIL/SUMARY + .S (PNAM,SUB,NAM,SRT)="" + .I PXRMSEL="I" S SUB="INDIVIDUAL PATIENTS" D @MOD Q:DONE + .I PXRMSEL'="I" D + ..;Sort internal IENs into alpha order + ..D XSORT + ..F S SRT=$O(^TMP($J,"SORT",SRT)) Q:SRT="" Q:DONE D + ...S SUB=$G(^TMP($J,"SORT",SRT)) D @MOD + ..I MOD="SUMARY","RT"[PXRMTOT S SUB="TOTAL" D @MOD + ; + ; Null report if no patients selected + I ('DONE),$O(^XTMP(PXRMXTMP,PX,""))="" D NULL^PXRMXGPR G EXIT + ; Report selected patient sample with no patients + I $D(MISSED) D MISSED^PXRMXPR1(0,.MISSED) + ; + ;Print Patient List + I $G(PATLST)="Y" D FOOTER^PXRMXPR1(.PLSTCRIT) + ; + ;Print Error message + I $D(^XTMP(PXRMXTMP,"ERROR"))>0!($D(^XTMP(PXRMXTMP,"CNBD"))>0) D ERROR^PXRMXBSY +EXIT ; + D EXIT^PXRMXGUT + ; + ;Allow the task to be cleaned up upon successful completion. + I $D(ZTQUEUED) S ZTREQ="@" + ; + D EOR^PXRMXGUT + Q + ; + ;Report by Patient +DETAIL N JJ,VA,DATE,COUNT,DDAT,EMP + N BED,DDUE,DDONE,DNEXT,FDAT1,FDAT2,FDAT3,FNAM,FTXT + S NAM=$G(^XTMP(PXRMXTMP,PX,FAC,SUB)),HEAD=1 + S COUNT=$P(NAM,U,2),TOTAL=$P(NAM,U,3),APPL=$P(NAM,U,4),NAM=$P(NAM,U,1) + S DDAT="",JJ=0 + ; Get list of patients for each appointment date + F S DDAT=$O(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT)) Q:DDAT="" Q:DONE D PAT + ; No patients due + I JJ=0 D:'DONE NONE^PXRMXGPR + ; Total patients + D:'DONE TOTAL^PXRMXGPR + S TTOTAL=TTOTAL+TOTAL + Q + ; +PAT ;Extract and print patient detail + N DNEXT1,NODE,PNUM + F S PNAM=$O(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM)) Q:PNAM="" Q:DONE D + .S JJ=JJ+1 + .;Format print line + .S (BID,DNEXT1,FDAT1,FDAT2,FDAT3,DNEXT1)="" I PNAM'["No patients found" D + ..S FDAT2="N/A",FDAT3="None" + ..S NODE=$G(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM)) + ..S DDUE=$P(NODE,U,2),DDONE=$P(NODE,U,3),DNEXT=$P(NODE,U,4) + ..S BED=$P(NODE,U,5) + ..S DFN=$P(NODE,U) S BID=$P($G(PNAM),U,2) + ..I PXRMSSN="N" S BID=$E(BID,6,9) + ..I PXRMSSN="Y",EMPCHK="Y" D EMP S:EMP BID=$E(BID,6,9) + ..S BID="("_BID_")" + ..S FDAT1=$$FMTE^XLFDT(DDUE,"5D") + ..I DDONE S FDAT2=$$FMTE^XLFDT(DDONE,"5D") + ..I BED'="NONE" S FDAT3=$P(NODE,U,5),DNEXT1=$$FMTE^XLFDT(DNEXT,"5D") + ..I DNEXT,FDAT3="None" S FDAT3=$$FMTE^XLFDT(DNEXT,"5D") + .;Print + .D CHECK Q:DONE + .;Normal output + .I PXRMTABS="N" D + ..S PNUM=JJ#10000 + ..S PNUM=$$RJ^XLFSTR(PNUM,4) + ..W !,PNUM,?5,$E($P($G(PNAM),U),1,33-$L(BID))," ",BID,?40,FDAT1,?52,FDAT2 + ..I ('$G(PXRMINP)),PXRMFUT'="Y" W ?64,$S(BED'="NONE":BED_" (Inp.)",1:FDAT3) + ..I $G(PXRMINP) W ?64,BED + ..I DNEXT1'="",PXRMFUT'="Y" W !,?64,DNEXT1 + .;Delimited report + .I PXRMTABS="Y" D + ..N FNAM + ..S FNAM=$P($G(PNAM),U) + ..I FNAM'["No patients found" S FNAM=$E(FNAM,1,33-$L(BID))_" "_BID + ..I "CES"[PXRMTABC S FNAM=$TR(FNAM,SEP,"_"),FDAT1=$TR(FDAT1,SEP,"_") + ..I BED="NONE" S BED=" " + ..W !,JJ_SEP_FNAM_SEP_FDAT1_SEP_FDAT2 I $G(PXRMINP) W SEP_BED + ..I ('$G(PXRMINP)),PXRMFUT'="Y" W SEP_FDAT3_SEP_BED + .;--- + .; Future Appointments + .I PXRMFUT="Y" D + ..N CNT,ADAT,ALOC,ATYP,FIRST,NONE + ..S CNT=0,NONE=1,FIRST=1 + ..I '$D(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM)) Q + ..F S CNT=$O(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM,CNT)) Q:CNT'>0 D + ...S ADAT=$P(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM,CNT,0),U) + ...I PXRMDLOC="Y" D + ....S ALOC=$P(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM,CNT,0),U,2) + ....S ATYP=$P(^XTMP(PXRMXTMP,PX,FAC,SUB,DDAT,PNAM,CNT,0),U,3) + ...S ADAT=$$FMTE^XLFDT(ADAT,"2P") + ...I FIRST D S FIRST=0,NONE=0 + ....I PXRMTABS="N" W ?64,$S(BED'="NONE":BED_" (Inp.)",1:"") + ...D CHECK + ...I PXRMDLOC="Y" D + ....I PXRMTABS="N" W !,?8,ADAT,?30,$E(ALOC,1,25),?60,$E(ATYP,1,20) + ....I PXRMTABS="Y" W SEP_ADAT_SEP_$E(ALOC,1,25)_SEP_$E(ATYP,1,20) + ...I PXRMDLOC="N" D + ....I PXRMTABS="N" W !,?10,ADAT + ....I PXRMTABS="Y" W SEP_ADAT + ..I NONE,PXRMTABS="N" W ?64,FDAT3 + ..I NONE,PXRMTABS="Y" W SEP_FDAT3 + ..I PXRMTABS="Y" W $S(BED'="NONE":SEP_BED_" (Inp.)",1:"") + ..K ^UTILITY("VASD",$J) + Q + ; + ;Summary by Reminder +SUMARY N JJ,EVAL,DUE,RNAM,RNUM,ITEM,COUNT,FTXT + S NAM=$G(^XTMP(PXRMXTMP,PX,FAC,SUB)),HEAD=1 + S TOTAL=$P(NAM,U,3),COUNT=$P(NAM,U,2),NAM=$P(NAM,U,1) + S RNUM=$O(REMINDER(""),-1) + ;Get reminders in alpha order + F JJ=1:1:RNUM D Q:DONE + .S ITEM=$P(REMINDER(JJ),U,1),RNAM=$P(REMINDER(JJ),U,4) + .S:RNAM="" RNAM=$P(REMINDER(JJ),U,2) + .; zero lines will be printed + .S DUE=$G(^XTMP(PXRMXTMP,PX,FAC,SUB,ITEM)) + .S EVAL=+$P(DUE,U,1),DUE=+$P(DUE,U,2) + .;Print + .D CHECK Q:DONE + .;Normal Report + .I PXRMTABS="N" W !,JJ,?5,RNAM,?48,$J(EVAL,10),?63,$J(DUE,10) + .;Condensed Report + .I PXRMTABS="Y" D + ..I "CES"[PXRMTABC S RNAM=$TR(RNAM,SEP,"_") + ..W !,JJ_SEP_RNAM_SEP_EVAL_SEP_DUE_SEP_$TR(NAM,SEP,"_") + D:'DONE TOTAL^PXRMXGPR + I $G(SUB)'="TOTAL",PXRMTOT'="T" S TTOTAL=TTOTAL+TOTAL + I $G(SUB)="TOTAL",PXRMTOT="T" S TTOTAL=TTOTAL+TOTAL + Q + ; + ;Check line count before writing line +CHECK I ((PXRMTABS="N")&($Y>(IOSL-BMARG-3)))!(HEAD=1) D COL^PXRMXGPR(1) + Q + ; + ;Check if employee +EMP N VAEL + D ELIG^VADPT + ;Check TYPE (#391) field + I $P($G(VAEL(6)),U,2)="EMPLOYEE" S EMP=1 Q + ;Check PATIENT ELIGABILITY (#361) field + N ELIG + S ELIG=0,EMP=0 + F S ELIG=$O(VAEL(1,ELIG)) Q:'ELIG D Q:EMP + .I $P($G(VAEL(1,ELIG)),U,2)="EMPLOYEE" S EMP=1 + Q + ; + ;Sort internal numbers into Alpha order +XSORT N SUB,NAM + K ^TMP($J,"SORT") + S SUB="" + F S SUB=$O(^XTMP(PXRMXTMP,PX,FAC,SUB)) Q:SUB="" D + .Q:SUB="TOTAL" + .S NAM=$P(^XTMP(PXRMXTMP,PX,FAC,SUB),U) + .I NAM="" S NAM=SUB + .S ^TMP($J,"SORT",NAM)=SUB + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMXPR1.m b/r/CLINICAL_REMINDERS-PXRM/PXRMXPR1.m index 70d9f5ed..302d1200 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMXPR1.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMXPR1.m @@ -1,116 +1,116 @@ -PXRMXPR1 ; SLC/AGP - Print Reminder Due report carryover code. ;01/05/2006 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ;Patient list display -FOOTER(PLSTCRIT) ; - N CNT,CNT1,COUNT,TEXT - ;Count patients in list - S COUNT=+$O(^PXRMXP(810.5,PXRMLIS1,30,"A"),-1) - ; - I COUNT=0 W !!!,"No patients due. Patient List not created" Q - W !!!,"Patient List "_$P($G(^PXRMXP(810.5,PXRMLIS1,0)),U)_" created by "_$$GET1^DIQ(200,DUZ,.01)_" on "_$$FMTE^XLFDT($P($G(^PXRMXP(810.5,PXRMLIS1,0)),U,4),1) - W !!,"List contains "_COUNT_" patients, report run on "_TTOTAL_" patients." - ; - ;Screen out formatting lines and second piece of criteria array - S (CNT,CNT1)=0 F S CNT=$O(PLSTCRIT(CNT)) Q:CNT'>0 D - .I $P($G(PLSTCRIT(CNT)),U)="",$P($G(PLSTCRIT(CNT)),U,2)>0 Q - .S CNT1=CNT1+1 S TEXT(CNT1)=$P($G(PLSTCRIT(CNT)),U) - ;Store Report Criteria in the document multiple of the patient list - F CNT1=1:1:CNT1 S ^PXRMXP(810.5,PXRMLIS1,200,CNT1,0)=TEXT(CNT1) - S ^PXRMXP(810.5,PXRMLIS1,200,0)=U_"810.51"_U_CNT1_U_CNT1 - Q - ; - ;Set up literals for display -LITS ; - I PXRMSEL="I" S PXRMFLD="Individual Patients" - I PXRMSEL="R" S PXRMFLD="Patient List" - I PXRMSEL="P" S PXRMFLD="PCMM Provider" - I PXRMSEL="O" S PXRMFLD="OE/RR Team" - I PXRMSEL="T" S PXRMFLD="PCMM Team" - I PXRMSEL="L" D - .S PXRMFLD="Location" - .I $P(PXRMLCSC,U)="HS" S DES="Selected Hospital Locations" - .I $P(PXRMLCSC,U)="HA" S DES="All Outpatient Locations" - .I $P(PXRMLCSC,U)="HAI" S DES="All Inpatient Locations" - .I $P(PXRMLCSC,U)="CS" S DES="Selected Clinic Stops" - .I $P(PXRMLCSC,U)="CA" S DES="All Clinic Stops" - .I $P(PXRMLCSC,U)="GS" S DES="Selected Clinic Groups" - .I PXRMFD="P" S DES=DES_" (Prior Encounters)" - .I PXRMFD="F" S DES=DES_" (Future Appoints.)" - .I PXRMFD="A" S DES=DES_" (Admissions)" - .I PXRMFD="C" S DES=DES_" (Current Inpatients)" - I PXRMSEL="P" D - .I PXRMPRIM="A" S CDES="All patients on list" - .I PXRMPRIM="P" S CDES="Primary care assigned patients only" - Q - ; - ;Report missed locations if report is partially successful -MISSED(PSTART,MISSED) ; - ;Delimited report from template - I PXRMTABS="Y",PXRMTMP'="" D Q - .W !!?PSTART,"The following had no patients selected",! - .N SUB - .S SUB="" - .F S SUB=$O(MISSED(SUB)) Q:SUB="" D - ..W !?PSTART+10,SUB - ;Other reports - N LIT,SUB - D CHECK^PXRMXGPR(5) Q:DONE - S LIT=PXRMFLD - I PXRMSEL="L",$E(PXRMLCSC)="G" S LIT="Clinic Group" - W !!?PSTART,"The following ",LIT,"(s) had no patients selected",! - S SUB="" - F S SUB=$O(MISSED(SUB)) Q:SUB="" D - .D CHECK^PXRMXGPR(3) Q:DONE - .W !?PSTART+10,SUB - Q - ; - ;Build array of locations/providers/teams with no patients -NOPATS(MISSED) ; - N DATA,IC,LTYPE,MARK - S IC="" - I PXRMSEL="P" D Q - . F S IC=$O(PXRMPRV(IC)) Q:IC="" D - .. S DATA=PXRMPRV(IC) - .. D TEST(DATA,$P(DATA,U,1),.MISSED) - I PXRMSEL="T" D - . F S IC=$O(PXRMPCM(IC)) Q:IC="" D - .. S DATA=PXRMPCM(IC) - .. D TEST(DATA,$P(DATA,U,1),.MISSED) - I PXRMSEL="O" D - . F S IC=$O(PXRMOTM(IC)) Q:IC="" D - .. S DATA=PXRMOTM(IC) - .. D TEST(DATA,$P(DATA,U,1),.MISSED) - S LTYPE=$E($G(PXRMLCSC)) - I LTYPE="H" D - . F S IC=$O(^XTMP(PXRMXTMP,"HLOC",IC)) Q:IC="" D - .. S DATA=^XTMP(PXRMXTMP,"HLOC",IC) - .. D TEST(DATA,IC,.MISSED) - I LTYPE="C" D - . F S IC=$O(PXRMCS(IC)) Q:IC="" D - .. S DATA=PXRMCS(IC) - .. D TEST(DATA,$P(DATA,U,3),.MISSED) - I LTYPE="G" D - . F S IC=$O(PXRMCGRP(IC)) Q:IC="" D - .. S DATA=PXRMCGRP(IC) - .. D TEST(DATA,$P(DATA,U,1),.MISSED) - Q - ; - ;Check for match on location -TEST(DATA,IEN,MISSED) ; - N SUB - I $D(^XTMP(PXRMXTMP,"MARKED AS FOUND",IEN)) Q - I PXRMSEL'="L" S MISSED($P(DATA,U,2))="" Q - N LTYPE - S LTYPE=$E(PXRMLCSC) - I LTYPE="H" S SUB=IEN D - . N FACNAM,FACNUM,HLOC - . S HLOC=$P(DATA,U,2) Q:HLOC="" - . S FACNUM=$$HFAC^PXRMXSL1(IEN) - . S FACNAM=$S(FACNUM="":"?",1:$P($G(PXRMFACN(FACNUM)),U,1)) - . I FACNAM'="" S SUB=HLOC_" ("_FACNAM_")" - I LTYPE="C" S SUB=$P(DATA,U,1)_" "_$P(DATA,U,3) - I LTYPE="G" S SUB=$P(DATA,U,2) - S MISSED(SUB)="" - Q - ; +PXRMXPR1 ; SLC/AGP - Print Reminder Due report carryover code. ;01/05/2006 + ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21 + ; + ;Patient list display +FOOTER(PLSTCRIT) ; + N CNT,CNT1,COUNT,TEXT + ;Count patients in list + S COUNT=+$O(^PXRMXP(810.5,PXRMLIS1,30,"A"),-1) + ; + I COUNT=0 W !!!,"No patients due. Patient List not created" Q + W !!!,"Patient List "_$P($G(^PXRMXP(810.5,PXRMLIS1,0)),U)_" created by "_$$GET1^DIQ(200,DUZ,.01)_" on "_$$FMTE^XLFDT($P($G(^PXRMXP(810.5,PXRMLIS1,0)),U,4),1) + W !!,"List contains "_COUNT_" patients, report run on "_TTOTAL_" patients." + ; + ;Screen out formatting lines and second piece of criteria array + S (CNT,CNT1)=0 F S CNT=$O(PLSTCRIT(CNT)) Q:CNT'>0 D + .I $P($G(PLSTCRIT(CNT)),U)="",$P($G(PLSTCRIT(CNT)),U,2)>0 Q + .S CNT1=CNT1+1 S TEXT(CNT1)=$P($G(PLSTCRIT(CNT)),U) + ;Store Report Criteria in the document multiple of the patient list + F CNT1=1:1:CNT1 S ^PXRMXP(810.5,PXRMLIS1,200,CNT1,0)=TEXT(CNT1) + S ^PXRMXP(810.5,PXRMLIS1,200,0)=U_"810.51"_U_CNT1_U_CNT1 + Q + ; + ;Set up literals for display +LITS ; + I PXRMSEL="I" S PXRMFLD="Individual Patients" + I PXRMSEL="R" S PXRMFLD="Patient List" + I PXRMSEL="P" S PXRMFLD="PCMM Provider" + I PXRMSEL="O" S PXRMFLD="OE/RR Team" + I PXRMSEL="T" S PXRMFLD="PCMM Team" + I PXRMSEL="L" D + .S PXRMFLD="Location" + .I $P(PXRMLCSC,U)="HS" S DES="Selected Hospital Locations" + .I $P(PXRMLCSC,U)="HA" S DES="All Outpatient Locations" + .I $P(PXRMLCSC,U)="HAI" S DES="All Inpatient Locations" + .I $P(PXRMLCSC,U)="CS" S DES="Selected Clinic Stops" + .I $P(PXRMLCSC,U)="CA" S DES="All Clinic Stops" + .I $P(PXRMLCSC,U)="GS" S DES="Selected Clinic Groups" + .I PXRMFD="P" S DES=DES_" (Prior Encounters)" + .I PXRMFD="F" S DES=DES_" (Future Appoints.)" + .I PXRMFD="A" S DES=DES_" (Admissions)" + .I PXRMFD="C" S DES=DES_" (Current Inpatients)" + I PXRMSEL="P" D + .I PXRMPRIM="A" S CDES="All patients on list" + .I PXRMPRIM="P" S CDES="Primary care assigned patients only" + Q + ; + ;Report missed locations if report is partially successful +MISSED(PSTART,MISSED) ; + ;Delimited report from template + I PXRMTABS="Y",PXRMTMP'="" D Q + .W !!?PSTART,"The following had no patients selected",! + .N SUB + .S SUB="" + .F S SUB=$O(MISSED(SUB)) Q:SUB="" D + ..W !?PSTART+10,SUB + ;Other reports + N LIT,SUB + D CHECK^PXRMXGPR(5) Q:DONE + S LIT=PXRMFLD + I PXRMSEL="L",$E(PXRMLCSC)="G" S LIT="Clinic Group" + W !!?PSTART,"The following ",LIT,"(s) had no patients selected",! + S SUB="" + F S SUB=$O(MISSED(SUB)) Q:SUB="" D + .D CHECK^PXRMXGPR(3) Q:DONE + .W !?PSTART+10,SUB + Q + ; + ;Build array of locations/providers/teams with no patients +NOPATS(MISSED) ; + N DATA,IC,LTYPE,MARK + S IC="" + I PXRMSEL="P" D + . F S IC=$O(PXRMPRV(IC)) Q:IC="" D + .. S DATA=PXRMPRV(IC) + .. D TEST(DATA,$P(DATA,U,1),.MISSED) + I PXRMSEL="T" D + . F S IC=$O(PXRMPCM(IC)) Q:IC="" D + .. S DATA=PXRMPCM(IC) + .. D TEST(DATA,$P(DATA,U,1),.MISSED) + I PXRMSEL="O" D + . F S IC=$O(PXRMOTM(IC)) Q:IC="" D + .. S DATA=PXRMOTM(IC) + .. D TEST(DATA,$P(DATA,U,1),.MISSED) + S LTYPE=$E($G(PXRMLCSC)) + I LTYPE="H" D + . F S IC=$O(^XTMP(PXRMXTMP,"HLOC",IC)) Q:IC="" D + .. S DATA=^XTMP(PXRMXTMP,"HLOC",IC) + .. D TEST(DATA,IC,.MISSED) + I LTYPE="C" D + . F S IC=$O(PXRMCS(IC)) Q:IC="" D + .. S DATA=PXRMCS(IC) + .. D TEST(DATA,$P(DATA,U,3),.MISSED) + I LTYPE="G" D + . F S IC=$O(PXRMCGRP(IC)) Q:IC="" D + .. S DATA=PXRMCGRP(IC) + .. D TEST(DATA,$P(DATA,U,1),.MISSED) + Q + ; + ;Check for match on location +TEST(DATA,IEN,MISSED) ; + N SUB + I $D(^XTMP(PXRMXTMP,"MARKED AS FOUND",IEN)) Q + I PXRMSEL'="L" S MISSED($P(DATA,U,2))="" Q + N LTYPE + S LTYPE=$E(PXRMLCSC) + I LTYPE="H" S SUB=IEN D + . N FACNAM,FACNUM,HLOC + . S HLOC=$P(DATA,U,2) Q:HLOC="" + . S FACNUM=$$HFAC^PXRMXSL1(IEN) + . S FACNAM=$S(FACNUM="":"?",1:$P($G(PXRMFACN(FACNUM)),U,1)) + . I FACNAM'="" S SUB=HLOC_" ("_FACNAM_")" + I LTYPE="C" S SUB=$P(DATA,U,1)_" "_$P(DATA,U,3) + I LTYPE="G" S SUB=$P(DATA,U,2) + S MISSED(SUB)="" + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMXQUE.m b/r/CLINICAL_REMINDERS-PXRM/PXRMXQUE.m index d9dc3d4c..20171dc7 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMXQUE.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMXQUE.m @@ -1,141 +1,139 @@ -PXRMXQUE ; SLC/PJH - Reminder reports general queuing routine.;03/23/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ;Determine whether the report should be queued. -JOB ; - N %ZIS S %ZIS="Q" - W ! - D ^%ZIS - I POP G EXIT^PXRMXD - S PXRMIOD=ION_";"_IOST_";"_IOM_";"_IOSL - S PXRMQUE=$G(IO("Q")) - ; - I PXRMQUE D Q - . ;Queue the report. - . N DESC,PXRMIOV,ROUTINE,TASK,ZTDTH - . S DESC="Reminder Due Report - sort" - . S PXRMIOV="" - . S ROUTINE="^PXRMXSE1" - . M ^TMP("PXRM-MESS",$J)=^TMP("XM-MESS",$J) - . S TASK=$$QUE^PXRMXQUE(DESC,PXRMIOV,ROUTINE,"SAVE^PXRMXQUE") Q:TASK="" - . S ^XTMP(PXRMXTMP,"SORTZTSK")=TASK - . M ^TMP("XM-MESS",$J)=^TMP("PXRM-MESS",$J) - . K ^TMP("PXRM-MESS",$J) - .; - . S DESC="Reminder Due Report - print" - . S PXRMIOV=PXRMIOD - . S ROUTINE="^PXRMXPR" - . S ZTDTH="@" - . S ^XTMP(PXRMXTMP,"PRZTSK")=$$QUE^PXRMXQUE(DESC,PXRMIOV,ROUTINE,"SAVE^PXRMXQUE") - I 'PXRMQUE D ^PXRMXSE1 - Q - ; -QUE(DESC,PXRMIOV,ROUTINE,SAVE) ;Queue a task. - N ZTDESC,ZTIO,ZTRTN,ZTSAVE - D @SAVE - S ZTDESC=DESC - S ZTIO=PXRMIOV - S ZTRTN=ROUTINE - D ^%ZTLOAD - I $D(ZTSK)=0 W !!,DESC," cancelled" - E W !!,DESC," has been queued, task number ",ZTSK - Q $G(ZTSK) - ; -DEVICE(RTN,DESC,SAVE,%ZIS,RETZTSK) ; - ;Pass RETZTSK as number such as 1 if you want to get ZTSK. - N 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) - ; - ;======================================================================= -REQUE(DESC,ROUTINE,TASK) ;Reque a task. - N ZTDTH,ZTRTN,ZTIO,ZTDESC,ZTSK - S ZTDESC=DESC - S ZTRTN=ROUTINE - S ZTSK=TASK - S ZTDTH=$$NOW^XLFDT - D REQ^%ZTLOAD - I ZTSK(0)=1 Q - ;There was a problem, send an error message. - K ZTSK S ZTSK=TASK - D ISQED^%ZTLOAD - N LC,SUB - K ^TMP("PXRMXMZ",$J) - S ^TMP("PXRMXMZ",$J,1,0)="Could not start the print task, task information:" - S ^TMP("PXRMXMZ",$J,2,0)=" Task number "_TASK - S LC=2,SUB="" - F S SUB=$O(ZTSK(SUB)) Q:SUB="" D - . S LC=LC+1 - . S ^TMP("PXRMXMZ",$J,LC,0)=" ZTSK("_SUB_")="_ZTSK(SUB) - S LC=LC+1,^TMP("PXRMXMZ",$J,LC,0)=" Print start time="_ZTDTH - S LC=LC+1,^TMP("PXRMXMZ",$J,LC,0)=" Submit time="_$P(PXRMXTMP,"PXRMX",2) - S LC=LC+1,^TMP("PXRMXMZ",$J,LC,0)="PXRMXTMP="_$G(PXRMXTMP) - D SEND^PXRMMSG("REMINDER REPORT ERROR",DUZ) - Q - ; - ;======================================================================= -SAVE ;Save the variables for queing. - S ZTSAVE("PXRMBDT")="",ZTSAVE("PXRMEDT")="",ZTSAVE("PXRMSDT")="" - S ZTSAVE("PXRMCS(")="",ZTSAVE("NCS")="" - S ZTSAVE("PXRMCGRP(")="",ZTSAVE("NCGRP")="" - S ZTSAVE("PXRMFAC(")="",ZTSAVE("NFAC")="" - S ZTSAVE("PXRMFACN(")="" - S ZTSAVE("PXRMFCMB")="" - S ZTSAVE("PXRMFUT")="",ZTSAVE("PXRMDLOC")="" - S ZTSAVE("PXRMFD")="" - S ZTSAVE("PXRMINP")="" - S ZTSAVE("PXRMIOD")="" - S ZTSAVE("PXRMLCHL(")="",ZTSAVE("NHL")="" - S ZTSAVE("PXRMLCMB")="" - S ZTSAVE("PXRMLCSC")="" - S ZTSAVE("PXRMPRIM")="" - S ZTSAVE("PXRMQUE")="" - S ZTSAVE("PXRMREP")="" - S ZTSAVE("PXRMRT")="" - S ZTSAVE("PXRMSCAT")="",ZTSAVE("PXRMSCAT(")="" - S ZTSAVE("PXRMSEL")="" - S ZTSAVE("PXRMSRT")="" - S ZTSAVE("PXRMSSN")="" - S ZTSAVE("PXRMTABC")="" - S ZTSAVE("PXRMTABS")="" - S ZTSAVE("PXRMTCMB")="" - S ZTSAVE("PXRMTMP")="" - S ZTSAVE("PXRMTOT")="" - S ZTSAVE("PXRMXTMP")="" - ; Time initiated - S ZTSAVE("PXRMXST")="" - ; New selection criteria - S ZTSAVE("PXRMOTM(")="",ZTSAVE("NOTM")="" - S ZTSAVE("PXRMPRV(")="",ZTSAVE("NPRV")="" - S ZTSAVE("PXRMPAT(")="",ZTSAVE("NPAT")="" - S ZTSAVE("PXRMPCM(")="",ZTSAVE("NPCM")="" - S ZTSAVE("PXRMREM(")="",ZTSAVE("NREM")="" - S ZTSAVE("PXRMRCAT(")="",ZTSAVE("NCAT")="" - S ZTSAVE("PXRMUSER")="" - ;Reminder list - S ZTSAVE("REMINDER(")="" - ; Arrays by IEN - S ZTSAVE("PXRMLOCN(")="" - S ZTSAVE("PXRMCSN(")="" - S ZTSAVE("PXRMCGRN(")="" - ;Patient List - S ZTSAVE("PATCREAT")="" - S ZTSAVE("PATLST")="" - S ZTSAVE("PXRMLIST(")="" - S ZTSAVE("PXRMLIS1")="" - S ZTSAVE("PLISTPUG")="" - ;User DUZ - S ZTSAVE("DBDUZ")="" - S ZTSAVE("DBERR")="" - S ZTSAVE("PXRMRERR(")="" - ;Dubug information - S ZTSAVE("PXRMDBUG")="" - S ZTSAVE("PXRMDBUS")="" - ;Patient Information - S ZTSAVE("PXRMTPAT")="" - S ZTSAVE("PXRMDPAT")="" - I +$G(PXRMIDOD)>0 S ZTSAVE("PXRMIDOD")="" - S ZTSAVE("PXRMPML")="" - Q +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. +JOB ; + N %ZIS S %ZIS="Q" + W ! + D ^%ZIS + I POP G EXIT^PXRMXD + S PXRMIOD=ION_";"_IOST_";"_IOM_";"_IOSL + S PXRMQUE=$G(IO("Q")) + ; + I PXRMQUE D Q + . ;Queue the report. + . N DESC,PXRMIOV,ROUTINE,TASK,ZTDTH + . S DESC="Reminder Due Report - sort" + . S PXRMIOV="" + . S ROUTINE="^PXRMXSE1" + . M ^TMP("PXRM-MESS",$J)=^TMP("XM-MESS",$J) + . S TASK=$$QUE^PXRMXQUE(DESC,PXRMIOV,ROUTINE,"SAVE^PXRMXQUE") Q:TASK="" + . S ^XTMP(PXRMXTMP,"SORTZTSK")=TASK + . M ^TMP("XM-MESS",$J)=^TMP("PXRM-MESS",$J) + . K ^TMP("PXRM-MESS",$J) + .; + . S DESC="Reminder Due Report - print" + . S PXRMIOV=PXRMIOD + . S ROUTINE="^PXRMXPR" + . S ZTDTH="@" + . S ^XTMP(PXRMXTMP,"PRZTSK")=$$QUE^PXRMXQUE(DESC,PXRMIOV,ROUTINE,"SAVE^PXRMXQUE") + I 'PXRMQUE D ^PXRMXSE1 + Q + ; +QUE(DESC,PXRMIOV,ROUTINE,SAVE) ;Queue a task. + N ZTDESC,ZTIO,ZTRTN,ZTSAVE + D @SAVE + S ZTDESC=DESC + S ZTIO=PXRMIOV + S ZTRTN=ROUTINE + D ^%ZTLOAD + I $D(ZTSK)=0 W !!,DESC," cancelled" + E W !!,DESC," has been queued, task number ",ZTSK + Q $G(ZTSK) + ; +DEVICE(ZTRTN,ZTDESC,ZTSAVE,%ZIS,ZTSK) ; + W ! + 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 + ; + ;======================================================================= +REQUE(DESC,ROUTINE,TASK) ;Reque a task. + N ZTDTH,ZTRTN,ZTIO,ZTDESC,ZTSK + S ZTDESC=DESC + S ZTRTN=ROUTINE + S ZTSK=TASK + S ZTDTH=$$NOW^XLFDT + D REQ^%ZTLOAD + I ZTSK(0)=1 Q + ;There was a problem, send an error message. + K ZTSK S ZTSK=TASK + D ISQED^%ZTLOAD + N LC,SUB + K ^TMP("PXRMXMZ",$J) + S ^TMP("PXRMXMZ",$J,1,0)="Could not start the print task, task information:" + S ^TMP("PXRMXMZ",$J,2,0)=" Task number "_TASK + S LC=2,SUB="" + F S SUB=$O(ZTSK(SUB)) Q:SUB="" D + . S LC=LC+1 + . S ^TMP("PXRMXMZ",$J,LC,0)=" ZTSK("_SUB_")="_ZTSK(SUB) + S LC=LC+1,^TMP("PXRMXMZ",$J,LC,0)=" Print start time="_ZTDTH + S LC=LC+1,^TMP("PXRMXMZ",$J,LC,0)=" Submit time="_$P(PXRMXTMP,"PXRMX",2) + S LC=LC+1,^TMP("PXRMXMZ",$J,LC,0)="PXRMXTMP="_$G(PXRMXTMP) + D SEND^PXRMMSG("REMINDER REPORT ERROR",DUZ) + Q + ; + ;======================================================================= +SAVE ;Save the variables for queing. + S ZTSAVE("PXRMBDT")="",ZTSAVE("PXRMEDT")="",ZTSAVE("PXRMSDT")="" + S ZTSAVE("PXRMCS(")="",ZTSAVE("NCS")="" + S ZTSAVE("PXRMCGRP(")="",ZTSAVE("NCGRP")="" + S ZTSAVE("PXRMFAC(")="",ZTSAVE("NFAC")="" + S ZTSAVE("PXRMFACN(")="" + S ZTSAVE("PXRMFCMB")="" + S ZTSAVE("PXRMFUT")="",ZTSAVE("PXRMDLOC")="" + S ZTSAVE("PXRMFD")="" + S ZTSAVE("PXRMINP")="" + S ZTSAVE("PXRMIOD")="" + S ZTSAVE("PXRMLCHL(")="",ZTSAVE("NHL")="" + S ZTSAVE("PXRMLCMB")="" + S ZTSAVE("PXRMLCSC")="" + S ZTSAVE("PXRMPRIM")="" + S ZTSAVE("PXRMQUE")="" + S ZTSAVE("PXRMREP")="" + S ZTSAVE("PXRMRT")="" + S ZTSAVE("PXRMSCAT")="",ZTSAVE("PXRMSCAT(")="" + S ZTSAVE("PXRMSEL")="" + S ZTSAVE("PXRMSRT")="" + S ZTSAVE("PXRMSSN")="" + S ZTSAVE("PXRMTABC")="" + S ZTSAVE("PXRMTABS")="" + S ZTSAVE("PXRMTCMB")="" + S ZTSAVE("PXRMTMP")="" + S ZTSAVE("PXRMTOT")="" + S ZTSAVE("PXRMXTMP")="" + ; Time initiated + S ZTSAVE("PXRMXST")="" + ; New selection criteria + S ZTSAVE("PXRMOTM(")="",ZTSAVE("NOTM")="" + S ZTSAVE("PXRMPRV(")="",ZTSAVE("NPRV")="" + S ZTSAVE("PXRMPAT(")="",ZTSAVE("NPAT")="" + S ZTSAVE("PXRMPCM(")="",ZTSAVE("NPCM")="" + S ZTSAVE("PXRMREM(")="",ZTSAVE("NREM")="" + S ZTSAVE("PXRMRCAT(")="",ZTSAVE("NCAT")="" + S ZTSAVE("PXRMUSER")="" + ;Reminder list + S ZTSAVE("REMINDER(")="" + ; Arrays by IEN + S ZTSAVE("PXRMLOCN(")="" + S ZTSAVE("PXRMCSN(")="" + S ZTSAVE("PXRMCGRN(")="" + ;Patient List + S ZTSAVE("PATCREAT")="" + S ZTSAVE("PATLST")="" + S ZTSAVE("PXRMLIST(")="" + S ZTSAVE("PXRMLIS1")="" + S ZTSAVE("PLISTPUG")="" + ;User DUZ + S ZTSAVE("DBDUZ")="" + S ZTSAVE("DBERR")="" + S ZTSAVE("PXRMRERR(")="" + ;Dubug information + S ZTSAVE("PXRMDBUG")="" + S ZTSAVE("PXRMDBUS")="" + ;Patient Information + S ZTSAVE("PXRMTPAT")="" + S ZTSAVE("PXRMDPAT")="" + I +$G(PXRMIDOD)>0 S ZTSAVE("PXRMIDOD")="" + Q diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMXSC.m b/r/CLINICAL_REMINDERS-PXRM/PXRMXSC.m index e10d0099..0e8b9e29 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMXSC.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMXSC.m @@ -1,80 +1,75 @@ -PXRMXSC ; SLC/PJH - Reminder reports service category selection ;12/18/2006 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; -SCAT ;Get the list of service categories. - N DIR,DIEA,IC,JC,NSC,PCESVC,SCA,VALID,X,Y - K DIRUT,DTOUT,DUOUT - ;Build a list of allowed service categories. PCE uses a subset of the - ;categories in the file. These are stored in PCESVC. - S PCESVC="" - D HELP^DIE(9000010,"",.07,"S","SCA") - S NSC=SCA("DIHELP") - S DIR("?")=U_"D SCATHELP^PXRMXSC" - S DIR("??")=U_"D SCATHELP^PXRMXSC" -SCATP ; - S DIR(0)="FU"_U_"1:"_NSC - S DIR("A")="Select SERVICE CATEGORIES" - S DIR("B")="A,I" - W ! - D ^DIR K DIR - I $D(DIROUT) S DTOUT=1 - I $D(DTOUT)!($D(DUOUT)) Q - ;Make sure we have a valid list. - S VALID=$$VSCLIST(Y,PCESVC) - I 'VALID G SCATP - S PXRMSCAT=$$UP^XLFSTR(Y) - F IC=1:1:$L(PXRMSCAT,",") S X=$P(PXRMSCAT,",",IC),PXRMSCAT(X)="" - Q - ; - ;====================================================== -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 - 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 - ; - ;====================================================== -VSCLIST(LIST,SLIST) ;LIST is a comma separated list of service categories. SLIST - ;is the standard list of service categories. Make sure all the - ;elements of LIST are in the standard list SLIST. If they are, then - ;LIST is valid. Used for selection in reminder reports and as input - ;transform SERVICE CATEGORY LIST in the REMINDER REPORT TEMPLATE - ;file #810.1. - I LIST="" Q 1 - I $G(SLIST)="" D - . N IC,SCA,TEMP - . D HELP^DIE(9000010,"",.07,"S","SCA") - . S SLIST="" - . F IC=2:1:SCA("DIHELP") D - .. S TEMP=$P(SCA("DIHELP",IC)," ",1) - .. I SLIST="" S SLIST=TEMP - .. E S SLIST=SLIST_","_TEMP - N IC,LE,LEN,VALID - S LIST=$$UP^XLFSTR(LIST) - S VALID=1 - S LEN=$L(LIST,",") - F IC=1:1:LEN D - . S LE=$P(LIST,",",IC) - . I LE="" D Q - .. D EN^DDIOL("Null is not a valid service category!") - .. S VALID=0 - . I SLIST'[LE D - .. D EN^DDIOL(LE_" is an invalid service category!") - .. S VALID=0 - Q VALID - ; +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. + N DIR,DIEA,IC,JC,NSC,PCESVC,SCA,VALID,X,Y + K DIRUT,DTOUT,DUOUT + ;Build a list of allowed service categories. PCE uses a subset of the + ;categories in the file. These are stored in PCESVC. + S PCESVC="" + D HELP^DIE(9000010,"",.07,"S","SCA") + S NSC=SCA("DIHELP") + 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 ; + S DIR(0)="FU"_U_"1:"_NSC + S DIR("A")="Select SERVICE CATEGORIES" + S DIR("B")="A,I" + W ! + D ^DIR K DIR + I $D(DIROUT) S DTOUT=1 + I $D(DTOUT)!($D(DUOUT)) Q + ;Make sure we have a valid list. + S VALID=$$VSCLIST(Y,PCESVC) + I 'VALID G SCATP + S PXRMSCAT=$$UP^XLFSTR(Y) + F IC=1:1:$L(PXRMSCAT,",") S X=$P(PXRMSCAT,",",IC),PXRMSCAT(X)="" + Q + ; + ;====================================================== +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." + Q + ; + ;====================================================== +VSCLIST(LIST,SLIST) ;LIST is a comma separated list of service categories. SLIST + ;is the standard list of service categories. Make sure all the + ;elements of LIST are in the standard list SLIST. If they are, then + ;LIST is valid. Used for selection in reminder reports and as input + ;transform SERVICE CATEGORY LIST in the REMINDER REPORT TEMPLATE + ;file #810.1. + I LIST="" Q 1 + I $G(SLIST)="" D + . N IC,SCA,TEMP + . D HELP^DIE(9000010,"",.07,"S","SCA") + . S SLIST="" + . F IC=2:1:SCA("DIHELP") D + .. S TEMP=$P(SCA("DIHELP",IC)," ",1) + .. I SLIST="" S SLIST=TEMP + .. E S SLIST=SLIST_","_TEMP + N IC,LE,LEN,VALID + S LIST=$$UP^XLFSTR(LIST) + S VALID=1 + S LEN=$L(LIST,",") + F IC=1:1:LEN D + . S LE=$P(LIST,",",IC) + . I LE="" D Q + .. D EN^DDIOL("Null is not a valid service category!") + .. S VALID=0 + . I SLIST'[LE D + .. D EN^DDIOL(LE_" is an invalid service category!") + .. S VALID=0 + Q VALID + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMXSE1.m b/r/CLINICAL_REMINDERS-PXRM/PXRMXSE1.m index 390c63e9..a6592efe 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMXSE1.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMXSE1.m @@ -1,200 +1,197 @@ -PXRMXSE1 ; SLC/PJH - Build Patient lists for Reminder Due report; 08/16/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ; Called/jobbed from PXRMXD - ; - ; Input - PXRMSEL,PXRMXTMP - ; PXRM* - ; Output- ^XTMP(PXRMXTMP - ; - ; -START ; - N LIT,TOTAL,TODAY,ZTSTOP,BUSY - S DBDOWN=0 - S TOTAL=0,ZTSTOP="",TODAY=$$DT^XLFDT-.0001 - ; - K ^TMP($J,"PXRM PATIENT LIST"),^TMP($J,"PXRM PATIENT EVAL") - K ^TMP($J,"PXRM FUTURE APPT"),^TMP($J,"SDAMA301") - K ^TMP($J),^TMP(PXRMRT,$J),^TMP("PXRMDUP",$J) - K ^TMP("PXRMCMB",$J),^TMP("PXRMCMB1",$J),^TMP("PXRMCMB2",$J) - N PXRMRERR - ; - I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY) - ; - ;OE/RR team selected (PXRMOTM) - I PXRMSEL="O" D OERR^PXRMXSL1 - ; - ;PCMM team selected (PXRMPCM) - I PXRMSEL="T" D PCMMT^PXRMXSL1 - ; - N HLIEN,FACILITY - ;Location selected (PXRMLCHL,PXRMCGRP) - I PXRMSEL="L" D G:ZTSTOP=1 EXIT - .;Build Clinic List - .D BHLOC^PXRMXSL1 - .;Prior Visits - build patient list in ^TMP - .I PXRMFD="P" D VISITS^PXRMXSL2 I DBDOWN=1 Q - .;Inpatient Admissions and current inpatient locations - .I PXRMFD="A"!(PXRMFD="C") D INPADM^PXRMXSL1 - .;Future Appointments - build patient list in ^TMP - .I PXRMFD="F" D APPTS^PXRMXSL2 I DBDOWN=1 Q - .;End task requested - .Q:ZTSTOP=1 - ;Update ^XTMP from ^TMP - I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY) - ; - ;PCMM provider selected (PXRMPRV) - I PXRMSEL="P" D PCMMP^PXRMXSL1 - ; - ;Individual Patients selected (PXRMPAT) - I PXRMSEL="I" D IND^PXRMXSL1 - ; - ;Patient List selected (PXRMLIST) - I PXRMSEL="R" D LIST^PXRMXSL1 - ; - I DBDOWN=1 G EXIT - S START=$H - D EVAL^PXRMXEVL("PXRM PATIENT EVAL",.REMINDER) - D XTMP(START) - ; - ;Update patient list - I PXRMSEL'="I"&(PXRMUSER'="Y")&($G(PXRMLIS1)'="") D - .;If no patients due delete patient list - .I +$O(^TMP($J,"PXRMXPAT",""))=0 D Q - ..N DA,DIK S DA=PXRMLIS1,DIK="^PXRMXP(810.5," D ^DIK - .;Otherwise create patient list - .D UPDLST^PXRMRULE("PXRMXPAT",PXRMLIS1,"","","",PXRMDPAT,PXRMTPAT) - .S $P(^PXRMXP(810.5,PXRMLIS1,0),U,9)=1 - K ^TMP($J,"PXRMXPAT") - K ^TMP($J),^TMP(PXRMRT,$J),^TMP("PXRMDUP",$J) - K ^TMP("PXRMCMB",$J),^TMP("PXRMCMB1",$J),^TMP("PXRMCMB2",$J),^TMP("PXRMCMB3",$J) - K DBDOWN - ; -DONE ; - ;Sorting is done. - I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) W ! D DONE^PXRMXBSY("done") - ; - ;I PXRMDBUG="Y" D DEBUG("End of evaluation:",PXRMREP,"^XTMP(PXRMXTMP,PX)") - ;Print the report information. - I PXRMQUE D Q - .;Start the printing that was queued but not scheduled. - .N DESC,ROUTINE,TASK - .S ROUTINE="^PXRMXPR" - .S DESC="Reminder Due Report - print" - .S TASK=$G(^XTMP(PXRMXTMP,"PRZTSK")) - .I TASK="" D NOPRZTSK(PXRMXTMP) Q - .D REQUE^PXRMXQUE(DESC,ROUTINE,TASK) - .S ZTREQ="@" - I 'PXRMQUE D ^PXRMXPR - Q - ; -AWRITE(REF,LS) ;This line tag is a copy of AWRITE^PXRMUTIL - N CNT,DONE,IC,IND,LEN,PROOT,ROOT,START,TEMP - I REF="" Q - S PROOT=$P(REF,")",1) - S TEMP=$NA(@REF) - S ROOT=$P(TEMP,")",1) - S REF=$Q(@REF) - I REF'[ROOT Q - S DONE=0,CNT=LS - F IC=0:0 Q:(REF="")!(DONE) D - . S START=$F(REF,ROOT) - . S LEN=$L(REF) - . S IND=$E(REF,START,LEN) - . S CNT=CNT+1,^TMP("PXRMXMZ",$J,CNT,0)=PROOT_IND_"="_@REF - . S REF=$Q(@REF) - . I REF'[ROOT S DONE=1 - Q - ; -DEBUG(LOC,TYPE,REF) ; - N CNT,DDAT,FACILITY,HEADER,PNAM,PX,SUB - K ^TMP("PXRMXMZ",$J) - S PX="PXRM" - I TYPE'="P"&(TYPE'="DEBUG") D Q - .D AWRITE(REF,0) - .D SEND^PXRMMSG("Debug output: "_LOC_" Reminder Report type "_TYPE_" ("_$$NOW^XLFDT_")",DUZ) - D AWRITE(REF,0) - S HEADER=LOC_" ("_$$NOW^XLFDT_")" - D SEND^PXRMMSG("Debug output: "_HEADER,DUZ) - Q - ; -ERROR(STATUS,ITEM) ; - ;Create XTMP entry for Reminders that error out or could not be - ;determing on evaluation - N ERRNAME - S STATUS=$P(STATUS,U) - S ERRNAME=$P(^PXD(811.9,ITEM,0),U) - I $D(^XTMP(PXRMXTMP,STATUS,ERRNAME))>0,^XTMP(PXRMXTMP,STATUS,ERRNAME)>0 D - .S ^XTMP(PXRMXTMP,STATUS,ERRNAME)=^XTMP(PXRMXTMP,STATUS,ERRNAME)+1 - E S ^XTMP(PXRMXTMP,STATUS,ERRNAME)=1 - Q - ; - ;End Task requested -EXIT ; - S ZTSK=$G(^XTMP(PXRMXTMP,"PRZTSK")) - I ZTSK>0 D KILL^%ZTLOAD - D EXIT^PXRMXGUT - K DBDOWN - Q - ; -NOPRZTSK(PXRMXTMP) ;Could not get PRZTSK send an error message - N TEXT - K ^TMP("PXRMXMZ",$J) - S TEXT(1,0)="The task number for the print job cannot be determined." - S TEXT(2,0)="The reason is:" - I '$D(^XTMP(PXRMXTMP)) S TEXT(3,0)=" The ^XTMP(PXRMXTMP) global is not defined." - I $D(^XTMP(PXRMXTMP)),'$D(^XTMP(PXRMXTMP,"PRZTSK")) S TEXT(3,0)=" ^XTMP(PXRMXTMP,""PRZTSK"") does not exist." - I $D(^XTMP(PXRMXTMP,"PRZTSK")) S TEXT(3,0)=" ^XMTP(PXRMXTMP,""PRZTSK"") is null." - S TEXT(4,0)="PXRMXTMP="_PXRMXTMP - M ^TMP("PXRMXMZ",$J)=TEXT - D SEND^PXRMMSG("REMINDER REPORT ERROR",DUZ) - Q - ; -XTMP(START) ; - N CNT,CCNT,DDAT,INP,ITEM,LIT,LSSN,MCNBD,MCNBDR,NAME - N SUB,STATUS,TEMP,TEMP1,TEXT - K ^TMP($J,"PXRM CNBD") - S CCNT=0,MCNBD=$G(^PXRM(800,1,"MIERR")),MCNBDR=0 - ;I PXRMDBUG="Y" D DEBUG("PATIENT DATA","P","^TMP($J,""PXRM PATIENT EVAL"")") - S BUSY=0,SUB="NAM",TEMP=0,PX="PXRM" - N DDAT,DDUE,DEMARR,DFN,DLAST,DNEXT,FACILITY,NAM,PNAM - S FACILITY="",DDAT="N/A" - F S FACILITY=$O(^TMP(PXRMRT,$J,FACILITY)) Q:FACILITY="" D - .S NAM="" - .F S NAM=$O(^TMP(PXRMRT,$J,FACILITY,NAM)) Q:NAM="" D - ..S DFN="" F S DFN=$O(^TMP(PXRMRT,$J,FACILITY,NAM,DFN)) Q:DFN="" D - ...I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D SPIN^PXRMXBSY("Evaluating Reminders",.BUSY) - ...S INP=$G(^TMP(PXRMRT,$J,FACILITY,NAM,DFN)) - ...S CNT=0 F S CNT=$O(REMINDER(CNT)) Q:CNT'>0 D - ....S ITEM=$P(REMINDER(CNT),U,1),LIT=$P(REMINDER(CNT),U,4) - ....I LIT="" S LIT=$P(REMINDER(CNT),U,2) - ....S STATUS=$G(^TMP($J,"PXRM PATIENT EVAL",DFN,ITEM)) - ....I STATUS="" Q - ....I STATUS["ERROR"!(STATUS["CNBD") D - .....D ERROR(STATUS,ITEM) I STATUS["ERROR"!(MCNBDR=1) Q - .....I CCNT=0 D Q - ......S ^TMP($J,"PXRM CNBD",1,0)=$$RJ^XLFSTR(" ",5)_$$LJ^XLFSTR("PATIENT NAME",30)_$$RJ^XLFSTR("LAST 4",10) - ......S (TEMP,TEMP1)="" - ......F X=1:1:30 S TEMP=TEMP_"_" - ......F X=1:1:6 S TEMP1=TEMP1_"_" - ......S ^TMP($J,"PXRM CNBD",2,0)=$$RJ^XLFSTR(" ",5)_$$LJ^XLFSTR(TEMP,30)_$$RJ^XLFSTR(TEMP1,10) - ......S CCNT=2 - .....S CCNT=CCNT+1 - .....I CCNT>MCNBD S MCNBDR=1 Q - .....S NAME=$P(^DPT(DFN,0),U) - .....S LSSN=$E($P(^DPT(DFN,0),U,9),6,9) - .....S ^TMP($J,"PXRM CNBD",CCNT,0)=$$RJ^XLFSTR(" ",5)_$$LJ^XLFSTR(NAME,30)_$$RJ^XLFSTR(LSSN,10) - ....;Add reminder status to patient list TMP Global - ....I STATUS["DUE NOW" S ^TMP($J,"PXRMXPAT",DFN,"REM",ITEM)=ITEM_U_STATUS - ....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") - 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 PXRMDBUG="Y" D DEBUG("DEBUG PATIENT DATA EVALUATION","DEBUG","^TMP($J,""PXRMDEBUG"")") - K ^TMP($J,"PXRM PATIENT EVAL") - Q - ; +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 + ; + ; Input - PXRMSEL,PXRMXTMP + ; PXRM* + ; Output- ^XTMP(PXRMXTMP + ; + ; +START ; + N LIT,TOTAL,TODAY,ZTSTOP,BUSY + S DBDOWN=0 + S TOTAL=0,ZTSTOP="",TODAY=$$DT^XLFDT-.0001 + ; + K ^TMP($J,"PXRM PATIENT LIST"),^TMP($J,"PXRM PATIENT EVAL") + K ^TMP($J,"PXRM FUTURE APPT"),^TMP($J,"SDAMA301") + K ^TMP($J),^TMP(PXRMRT,$J),^TMP("PXRMDUP",$J) + K ^TMP("PXRMCMB",$J),^TMP("PXRMCMB1",$J),^TMP("PXRMCMB2",$J) + N PXRMRERR + ; + I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY) + ; + ;OE/RR team selected (PXRMOTM) + I PXRMSEL="O" D OERR^PXRMXSL1 + ; + ;PCMM team selected (PXRMPCM) + I PXRMSEL="T" D PCMMT^PXRMXSL1 + ; + N HLIEN,FACILITY + ;Location selected (PXRMLCHL,PXRMCGRP) + I PXRMSEL="L" D G:ZTSTOP=1 EXIT + .;Build Clinic List + .D BHLOC^PXRMXSL1 + .;Prior Visits - build patient list in ^TMP + .I PXRMFD="P" D VISITS^PXRMXSL2 I DBDOWN=1 Q + .;Inpatient Admissions and current inpatient locations + .I PXRMFD="A"!(PXRMFD="C") D INPADM^PXRMXSL1 + .;Future Appointments - build patient list in ^TMP + .I PXRMFD="F" D APPTS^PXRMXSL2 I DBDOWN=1 Q + .;End task requested + .Q:ZTSTOP=1 + ;Update ^XTMP from ^TMP + I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY) + ; + ;PCMM provider selected (PXRMPRV) + I PXRMSEL="P" D PCMMP^PXRMXSL1 + ; + ;Individual Patients selected (PXRMPAT) + I PXRMSEL="I" D IND^PXRMXSL1 + ; + ;Patient List selected (PXRMLIST) + I PXRMSEL="R" D LIST^PXRMXSL1 + ; + I DBDOWN=1 G EXIT + S START=$H + D EVAL^PXRMXEVL("PXRM PATIENT EVAL",.REMINDER) + D XTMP(START) + ; + ;Update patient list + I PXRMSEL'="I"&(PXRMUSER'="Y")&($G(PXRMLIS1)'="") D + .;If no patients due delete patient list + .I +$O(^TMP($J,"PXRMXPAT",""))=0 D Q + ..N DA,DIK S DA=PXRMLIS1,DIK="^PXRMXP(810.5," D ^DIK + .;Otherwise create patient list + .D UPDLST^PXRMRULE("PXRMXPAT",PXRMLIS1,"","") + .S $P(^PXRMXP(810.5,PXRMLIS1,0),U,9)=1 + K ^TMP($J,"PXRMXPAT") + K ^TMP($J),^TMP(PXRMRT,$J),^TMP("PXRMDUP",$J) + K ^TMP("PXRMCMB",$J),^TMP("PXRMCMB1",$J),^TMP("PXRMCMB2",$J),^TMP("PXRMCMB3",$J) + K DBDOWN + ; +DONE ; + ;Sorting is done. + I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) W ! D DONE^PXRMXBSY("done") + ; + ;I PXRMDBUG="Y" D DEBUG("End of evaluation:",PXRMREP,"^XTMP(PXRMXTMP,PX)") + ;Print the report information. + I PXRMQUE D Q + .;Start the printing that was queued but not scheduled. + .N DESC,ROUTINE,TASK + .S ROUTINE="^PXRMXPR" + .S DESC="Reminder Due Report - print" + .S TASK=$G(^XTMP(PXRMXTMP,"PRZTSK")) + .I TASK="" D NOPRZTSK(PXRMXTMP) Q + .D REQUE^PXRMXQUE(DESC,ROUTINE,TASK) + .S ZTREQ="@" + I 'PXRMQUE D ^PXRMXPR + Q + ; +AWRITE(REF,LS) ;This line tag is a copy of AWRITE^PXRMUTIL + N CNT,DONE,IC,IND,LEN,PROOT,ROOT,START,TEMP + I REF="" Q + S PROOT=$P(REF,")",1) + S TEMP=$NA(@REF) + S ROOT=$P(TEMP,")",1) + S REF=$Q(@REF) + I REF'[ROOT Q + S DONE=0,CNT=LS + F IC=0:0 Q:(REF="")!(DONE) D + . S START=$F(REF,ROOT) + . S LEN=$L(REF) + . S IND=$E(REF,START,LEN) + . S CNT=CNT+1,^TMP("PXRMXMZ",$J,CNT,0)=PROOT_IND_"="_@REF + . S REF=$Q(@REF) + . I REF'[ROOT S DONE=1 + Q + ; +DEBUG(LOC,TYPE,REF) ; + N CNT,DDAT,FACILITY,HEADER,PNAM,PX,SUB + K ^TMP("PXRMXMZ",$J) + S PX="PXRM" + I TYPE'="P"&(TYPE'="DEBUG") D Q + .D AWRITE(REF,0) + .D SEND^PXRMMSG("Debug output: "_LOC_" Reminder Report type "_TYPE_" ("_$$NOW^XLFDT_")",DUZ) + D AWRITE(REF,0) + S HEADER=LOC_" ("_$$NOW^XLFDT_")" + D SEND^PXRMMSG("Debug output: "_HEADER,DUZ) + Q + ; +ERROR(STATUS,ITEM) ; + ;Create XTMP entry for Reminders that error out or could not be + ;determing on evaluation + N ERRNAME + S STATUS=$P(STATUS,U) + S ERRNAME=$P(^PXD(811.9,ITEM,0),U) + I $D(^XTMP(PXRMXTMP,STATUS,ERRNAME))>0,^XTMP(PXRMXTMP,STATUS,ERRNAME)>0 D + .S ^XTMP(PXRMXTMP,STATUS,ERRNAME)=^XTMP(PXRMXTMP,STATUS,ERRNAME)+1 + E S ^XTMP(PXRMXTMP,STATUS,ERRNAME)=1 + Q + ; + ;End Task requested +EXIT ; + S ZTSK=$G(^XTMP(PXRMXTMP,"PRZTSK")) + I ZTSK>0 D KILL^%ZTLOAD + D EXIT^PXRMXGUT + K DBDOWN + Q + ; +NOPRZTSK(PXRMXTMP) ;Could not get PRZTSK send an error message + N TEXT + K ^TMP("PXRMXMZ",$J) + S TEXT(1,0)="The task number for the print job cannot be determined." + S TEXT(2,0)="The reason is:" + I '$D(^XTMP(PXRMXTMP)) S TEXT(3,0)=" The ^XTMP(PXRMXTMP) global is not defined." + I $D(^XTMP(PXRMXTMP)),'$D(^XTMP(PXRMXTMP,"PRZTSK")) S TEXT(3,0)=" ^XTMP(PXRMXTMP,""PRZTSK"") does not exist." + I $D(^XTMP(PXRMXTMP,"PRZTSK")) S TEXT(3,0)=" ^XMTP(PXRMXTMP,""PRZTSK"") is null." + S TEXT(4,0)="PXRMXTMP="_PXRMXTMP + M ^TMP("PXRMXMZ",$J)=TEXT + D SEND^PXRMMSG("REMINDER REPORT ERROR",DUZ) + Q + ; +XTMP(START) ; + 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 PXRMDBUG="Y" D DEBUG("PATIENT DATA","P","^TMP($J,""PXRM PATIENT EVAL"")") + S BUSY=0,SUB="NAM",TEMP=0,PX="PXRM" + N DDAT,DDUE,DEMARR,DFN,DLAST,DNEXT,FACILITY,NAM,PNAM + S FACILITY="",DDAT="N/A" + F S FACILITY=$O(^TMP(PXRMRT,$J,FACILITY)) Q:FACILITY="" D + .S NAM="" + .F S NAM=$O(^TMP(PXRMRT,$J,FACILITY,NAM)) Q:NAM="" D + ..S DFN="" F S DFN=$O(^TMP(PXRMRT,$J,FACILITY,NAM,DFN)) Q:DFN="" D + ...I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D SPIN^PXRMXBSY("Evaluating Reminders",.BUSY) + ...S INP=$G(^TMP(PXRMRT,$J,FACILITY,NAM,DFN)) + ...S CNT=0 F S CNT=$O(REMINDER(CNT)) Q:CNT'>0 D + ....S ITEM=$P(REMINDER(CNT),U,1),LIT=$P(REMINDER(CNT),U,4) + ....I LIT="" S LIT=$P(REMINDER(CNT),U,2) + ....S STATUS=$G(^TMP($J,"PXRM PATIENT EVAL",DFN,ITEM)) + ....I STATUS="" Q + ....I STATUS["ERROR"!(STATUS["CNBD") D + .....D ERROR(STATUS,ITEM) I STATUS["ERROR"!(MCNBDR=1) Q + .....I CCNT=0 D Q + ......S ^TMP($J,"PXRM CNBD",1,0)=$$RJ^XLFSTR(" ",5)_$$LJ^XLFSTR("PATIENT NAME",30)_$$RJ^XLFSTR("LAST 4",10) + ......S (TEMP,TEMP1)="" + ......F X=1:1:30 S TEMP=TEMP_"_" + ......F X=1:1:6 S TEMP1=TEMP1_"_" + ......S ^TMP($J,"PXRM CNBD",2,0)=$$RJ^XLFSTR(" ",5)_$$LJ^XLFSTR(TEMP,30)_$$RJ^XLFSTR(TEMP1,10) + ......S CCNT=2 + .....S CCNT=CCNT+1 + .....I CCNT>MCNBD S MCNBDR=1 Q + .....S NAME=$P(^DPT(DFN,0),U) + .....S LSSN=$E($P(^DPT(DFN,0),U,9),6,9) + .....S ^TMP($J,"PXRM CNBD",CCNT,0)=$$RJ^XLFSTR(" ",5)_$$LJ^XLFSTR(NAME,30)_$$RJ^XLFSTR(LSSN,10) + ....;Add reminder status to patient list TMP Global + ....I STATUS["DUE NOW" S ^TMP($J,"PXRMXPAT",DFN,"REM",ITEM)=ITEM_U_STATUS + ....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 DBDOWN^PXRMXDT1("C") + K ^TMP($J,"PXRM CNBD") + S END=$H + 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") + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMXSL1.m b/r/CLINICAL_REMINDERS-PXRM/PXRMXSL1.m index 5bd188ec..e0c9fda5 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMXSL1.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMXSL1.m @@ -1,238 +1,218 @@ -PXRMXSL1 ; SLC/PJH - Process Visits/Appts Reminder Due report;02/07/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ; Called from PXRMXSE - ; -TMP(DFN,NAM,FACILITY,INP) ;Update ^TMP("PXRMX" - I PXRMFCMB="Y" S FACILITY="COMBINED FACILITIES" - I PXRMLCMB="Y" S NAM="COMBINED LOCATIONS" - S ^TMP("PXRMX",$J,FACILITY,NAM,DFN)=INP - Q - ; - ;Mark location as found -MARK(IC) ; - S ^XTMP(PXRMXTMP,"MARKED AS FOUND",IC)="" - Q - ; - ;Check if facility is on list, PXMRFACN. -HFAC(HLOCIEN) ; - N DIV,HFAC - ;DBIA #2804 - S HFAC=$P(^SC(HLOCIEN,0),U,4) - I HFAC="" S DIV=$P($G(^SC(HLOCIEN,0)),U,15) S:DIV'="" HFAC=$P($G(^DG(40.8,DIV,0)),U,7) - I HFAC="" S HFAC=+$P($$SITE^VASITE,U,3) - I HFAC="" Q "" - 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'0 D - .S FACILITY=$P(^XTMP(PXRMXTMP,"HLOC",HIEN),U,1) - .;Get WARDIEN,WARDNAM and return DFN's in PATS - .N PATS - .I PXRMFD="C" D WARD^PXRMXAP(HIEN,.PATS) - .I PXRMFD="A" D - ..; Get admissions from patient movements and return DFN's in PATS - ..S BD=PXRMBDT-.0001 - ..S ED=PXRMEDT+.2359 - ..D ADM^PXRMXAP(HIEN,.PATS,BD,ED) - .;Split report by location - .I PXRMLCMB="N" S NAM=$P(^XTMP(PXRMXTMP,"HLOC",HIEN),U,2) - .;Build ^TMP for selected patients - .S DFN="",FOUND=0 - .F S DFN=$O(PATS(DFN)) Q:DFN="" D - ..S ^TMP($J,"PXRM PATIENT EVAL",DFN)="" - ..D TMP(DFN,NAM,FACILITY,HIEN) D MARK(HIEN) - Q - ; -BHLOC ; - N CLINIEN,END,FACILITY,NAM,HLIEN,I,START,TEXT - N INACT,REACT - I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY) - ;All inpatient, outpatient all location credit stop and encounter - S START=$H - I $P(PXRMLCSC,U)["HA"!($P(PXRMLCSC,U)="CA") D - .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) - ..;All inpatient location - ..I $P(PXRMLCSC,U)="HAI",$D(^SC(HLIEN,42)) S ^XTMP(PXRMXTMP,"HLOC",HLIEN)=FACILITY_U_NAM Q - ..;All outpatient locations - ..I $P(PXRMLCSC,U)="HA",'$D(^SC(HLIEN,42)) S ^XTMP(PXRMXTMP,"HLOC",HLIEN)=FACILITY_U_NAM Q - ..;All encounters with a credit stop - ..I $P(PXRMLCSC,U)="CA",$P($G(^SC(HLIEN,0)),U,7)>0 S ^XTMP(PXRMXTMP,"HLOC",HLIEN)=FACILITY_U_NAM Q - ;Select hosiptal locations - I $P(PXRMLCSC,U,1)="HS" D - .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 ^XTMP(PXRMXTMP,"HLOC",HLIEN)=FACILITY_U_NAM - ;Select Credit Stops - I PXRMSEL="L",$P(PXRMLCSC,U)="CS" D - .S CLINIEN=0 F S CLINIEN=$O(PXRMCSN(CLINIEN)) Q:CLINIEN'>0 D - ..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 ^XTMP(PXRMXTMP,"HLOC",HLIEN)=FACILITY_U_NAM_U_$P(PXRMCS($G(PXRMCSN(CLINIEN))),U,3) - ;Selected Clinic Groups - I PXRMSEL="L",$E(PXRMLCSC)="G" D - .S CGRPIEN=0 F S CGRPIEN=$O(PXRMCGRN(CGRPIEN)) Q:CGRPIEN'>0 D - ..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) ; - 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 - ; -OERR ; - N CNT,II,NAM,OTM - I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY) - S II="" - ;Get patient list for each team - F S II=$O(PXRMOTM(II)) Q:II="" D - .S OTM=$P(PXRMOTM(II),U),NAM=$P(PXRMOTM(II),U,2) - .;Build list of patients for OE/RR team ; DBIA #2692 - .K ^TMP($J,"OTM") - .D TEAMPTS^ORQPTQ1("^TMP($J,""OTM"",",OTM,1) - .I $G(^TMP($J,"OTM",1))["No patients found" Q - .I PXRMTCMB="Y" N OTM,NAM S OTM="COMBINED",NAM="COMBINED TEAMS" - .S CNT=0 F S CNT=$O(^TMP($J,"OTM",CNT)) Q:CNT'>0 D - ..I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")))&(DBDOWN=0) D SPIN^PXRMXBSY("Collecting patients from OE/RR List",.BUSY) - ..S DFN=$P(^TMP($J,"OTM",CNT),U) - ..D UPD1(DFN,NAM,"FACILITY",II) - .D MARK(OTM) - K ^TMP($J,"OTM") - I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DONE^PXRMXBSY("Done") - I PXRMREP="D",$D(^TMP($J,"PXRM PATIENT EVAL"))>0 D SDAM301^PXRMXSL2(DT,"",PXRMSEL,PXRMFD,PXRMREP) - Q - ; - ;PCMM provider selected -PCMMP ; - 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 - S SCDT("INCL")=0 - S II="" - ;Get patient list for each PROVIDER - F S II=$O(PXRMPRV(II)) Q:II="" D - .S PCM=$P(PXRMPRV(II),U),NAM=$P(PXRMPRV(II),U,2) - .;Get patients for practs. roles - excluding assoc clinics - .K ^TMP($J,"PCM") - .N SCTEAM D PTPR^PXRMXAP(PCM,PXRMREP) - .I $O(^TMP($J,"PCM",0))="" Q - .;Save in ^TMP in alpha order within team number (internal) - .S CNT=0 F S CNT=$O(^TMP($J,"PCM",CNT)) Q:CNT'>0 D - ..S DFN=$P(^TMP($J,"PCM",CNT),U) - ..I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")))&(DBDOWN=0) D SPIN^PXRMXBSY("Collecting patients from Primary Provider List",.BUSY) - ..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 $G(DCLN)'="" S PXRMDCLN(DCLN)="" - ..D UPD1(DFN,NAM,"FACILITY",+$G(DCLN)) - .D MARK(PCM) - K ^TMP($J,"PCM") - I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DONE^PXRMXBSY("Done") - I PXRMREP="D",$D(^TMP($J,"PXRM PATIENT EVAL"))>0 D SDAM301^PXRMXSL2(DT,"",PXRMSEL,PXRMFD,PXRMREP) - Q - ; - ;PCMM team selected -PCMMT ; - I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY) - N CNT,SCDT,LIST,SCERR,SCLIST,II,PCM,NAM,PNAM,OK - S SCDT("BEGIN")=PXRMSDT,SCDT("END")=PXRMSDT - ;Include patient if in team on any day in range - S SCDT("INCL")=0 - S II="" - ;Get patient list for each team - F S II=$O(PXRMPCM(II)) Q:II="" D - .S PCM=$P(PXRMPCM(II),U),NAM=$P(PXRMPCM(II),U,2) - .K ^TMP($J,"PCM") - .S OK=$$PTTM^PXRMXAP(PCM,.SCERR) Q:'OK - .I $O(^TMP($J,"PCM",0))="" Q - .S FACILITY=$$FAC^PXRMXAP(PCM) - .S CNT=0 F S CNT=$O(^TMP($J,"PCM",CNT)) Q:CNT'>0 D - ..S DFN=$P(^TMP($J,"PCM",CNT),U) - ..I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")))&(DBDOWN=0) D SPIN^PXRMXBSY("Collecting patients from PCMM Team List",.BUSY) - ..D UPD1(DFN,NAM,FACILITY,II) - .D MARK(PCM) - K ^TMP($J,"PCM") - I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DONE^PXRMXBSY("Done") - I PXRMREP="D",$D(^TMP($J,"PXRM PATIENT EVAL"))>0 D SDAM301^PXRMXSL2(DT,"",PXRMSEL,PXRMFD,PXRMREP) - Q - ; - ;Individual Patients selected -IND ; - N CNT,DFN,DUMMY,LIST,NAM - S (DUMMY,NAM)="PATIENT" - S CNT=0 F S CNT=$O(PXRMPAT(CNT)) Q:CNT'>0 D - .S DFN=$P(PXRMPAT(CNT),U) - .D UPD1(DFN,"INDIVIDUAL PATIENTS","FACILITY",DFN) - I PXRMREP="D",$D(^TMP($J,"PXRM PATIENT EVAL"))>0 D SDAM301^PXRMXSL2(DT,"",PXRMSEL,PXRMFD,PXRMREP) - Q - ; - ;Patient lists selected -LIST ; - I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY) - N DFN,DSUB,DUMMY,LCNT,LIEN,LIST,NAM - S (DUMMY,NAM)="PATIENT",LCNT=0 - F S LCNT=$O(PXRMLIST(LCNT)) Q:'LCNT D - .S LIEN=$P(PXRMLIST(LCNT),U) Q:'LIEN - .S NAM=$P(^PXRMXP(810.5,LIEN,0),U) - .S DSUB=0 - .F S DSUB=$O(^PXRMXP(810.5,LIEN,30,DSUB)) Q:'DSUB D - ..S DFN=$P($G(^PXRMXP(810.5,LIEN,30,DSUB,0)),U) Q:'DFN - ..I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")))&(DBDOWN=0) D SPIN^PXRMXBSY("Collecting patients from Reminder Patient List",.BUSY) - ..D UPD1(DFN,NAM,"FACILITY",LIEN) - I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DONE^PXRMXBSY("Done") - I PXRMREP="D",$D(^TMP($J,"PXRM PATIENT EVAL"))>0 D SDAM301^PXRMXSL2(DT,"",PXRMSEL,PXRMFD,PXRMREP) - Q - ; -UPD1(DFN,NAM,FACILITY,INP) ; - ;Remove test patients. - I 'PXRMTPAT,$$TESTPAT^VADPT(DFN)=1 Q - ;Remove patients that are deceased. - I 'PXRMDPAT,$P($G(^DPT(DFN,.35)),U,1)>0 Q - S ^TMP($J,"PXRM PATIENT LIST",DFN)="" - S ^TMP($J,"PXRM PATIENT EVAL",DFN)="" - D TMP(DFN,NAM,FACILITY,INP) - Q - ; +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 + ; +TMP(DFN,NAM,FACILITY,INP) ;Update ^TMP("PXRMX" + I PXRMFCMB="Y" S FACILITY="COMBINED FACILITIES" + I PXRMLCMB="Y" S NAM="COMBINED LOCATIONS" + S ^TMP("PXRMX",$J,FACILITY,NAM,DFN)=INP + Q + ; + ;Mark location as found +MARK(IC) ; + S ^XTMP(PXRMXTMP,"MARKED AS FOUND",IC)="" + Q + ; + ;Check if facility is on list, PXMRFACN. +HFAC(HLOCIEN) ; + N DIV,HFAC + ;DBIA #2804 + S HFAC=$P(^SC(HLOCIEN,0),U,4) + I HFAC="" S DIV=$P($G(^SC(HLOCIEN,0)),U,15) S:DIV'="" HFAC=$P($G(^DG(40.8,DIV,0)),U,7) + I HFAC="" S HFAC=+$P($$SITE^VASITE,U,3) + I HFAC="" Q "" + I '$D(PXRMFACN(HFAC)) Q "" + Q HFAC + ; +INPADM ; + ;Build list of inpatients admissions and current patients on a ward + N BD,DFN,ED,FACILITY,HIEN,NAM + S NAM="All Locations" + S HIEN=0 + F S HIEN=$O(^XTMP(PXRMXTMP,"HLOC",HIEN)) Q:HIEN'>0 D + .S FACILITY=$P(^XTMP(PXRMXTMP,"HLOC",HIEN),U,1) + .;Get WARDIEN,WARDNAM and return DFN's in PATS + .N PATS + .I PXRMFD="C" D WARD^PXRMXAP(HIEN,.PATS) + .I PXRMFD="A" D + ..; Get admissions from patient movements and return DFN's in PATS + ..S BD=PXRMBDT-.0001 + ..S ED=PXRMEDT+.2359 + ..D ADM^PXRMXAP(HIEN,.PATS,BD,ED) + .;Split report by location + .I PXRMLCMB="N" S NAM=$P(^XTMP(PXRMXTMP,"HLOC",HIEN),U,2) + .;Build ^TMP for selected patients + .S DFN="",FOUND=0 + .F S DFN=$O(PATS(DFN)) Q:DFN="" D + ..S ^TMP($J,"PXRM PATIENT EVAL",DFN)="" + ..D TMP(DFN,NAM,FACILITY,HIEN) D MARK(HIEN) + Q + ; +BHLOC ; + 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 START=$H + I $P(PXRMLCSC,U)["HA"!($P(PXRMLCSC,U)="CA") D + .S HLIEN=0 F S HLIEN=$O(^SC(HLIEN)) Q:HLIEN'>0 D + ..S FACILITY=$$HFAC(HLIEN) I FACILITY'>0 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) + ..;All inpatient location + ..I $P(PXRMLCSC,U)="HAI",$D(^SC(HLIEN,42)) S ^XTMP(PXRMXTMP,"HLOC",HLIEN)=FACILITY_U_NAM Q + ..;All outpatient locations + ..I $P(PXRMLCSC,U)="HA",'$D(^SC(HLIEN,42)) S ^XTMP(PXRMXTMP,"HLOC",HLIEN)=FACILITY_U_NAM Q + ..;All encounters with a credit stop + ..I $P(PXRMLCSC,U)="CA",$P($G(^SC(HLIEN,0)),U,7)>0 S ^XTMP(PXRMXTMP,"HLOC",HLIEN)=FACILITY_U_NAM Q + ;Select hosiptal locations + I $P(PXRMLCSC,U,1)="HS" D + .S HLIEN=0 F S HLIEN=$O(PXRMLOCN(HLIEN)) Q:HLIEN'>0 D + ..S FACILITY=$$HFAC(HLIEN) I FACILITY'>0 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 ^XTMP(PXRMXTMP,"HLOC",HLIEN)=FACILITY_U_NAM + ;Select Credit Stops + I PXRMSEL="L",$P(PXRMLCSC,U)="CS" D + .S CLINIEN=0 F S CLINIEN=$O(PXRMCSN(CLINIEN)) Q:CLINIEN'>0 D + ..S HLIEN=0 F S HLIEN=$O(^SC("AST",CLINIEN,HLIEN)) Q:HLIEN'>0 D + ...S FACILITY=$$HFAC(HLIEN) I FACILITY'>0 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 ^XTMP(PXRMXTMP,"HLOC",HLIEN)=FACILITY_U_NAM_U_$P(PXRMCS($G(PXRMCSN(CLINIEN))),U,3) + ;Selected Clinic Groups + I PXRMSEL="L",$E(PXRMLCSC)="G" D + .S CGRPIEN=0 F S CGRPIEN=$O(PXRMCGRN(CGRPIEN)) Q:CGRPIEN'>0 D + ..S HLIEN=0 F S HLIEN=$O(^SC("ASCRPW",CGRPIEN,HLIEN)) Q:HLIEN'>0 D + ...S FACILITY=$$HFAC(HLIEN) I FACILITY'>0 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 + 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="Elapsed time for "_SECTION_": "_ETIME + E S TEXT="Elapsed time for "_SECTION_": "_ETIME_" secs" + D MES^XPDUTL(TEXT) + Q + ; +OERR ; + N CNT,II,NAM,OTM + I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY) + S II="" + ;Get patient list for each team + F S II=$O(PXRMOTM(II)) Q:II="" D + .S OTM=$P(PXRMOTM(II),U),NAM=$P(PXRMOTM(II),U,2) + .;Build list of patients for OE/RR team ; DBIA #2692 + .K ^TMP($J,"OTM") + .D TEAMPTS^ORQPTQ1("^TMP($J,""OTM"",",OTM,1) + .I $G(^TMP($J,"OTM",1))["No patients found" Q + .I PXRMTCMB="Y" N OTM,NAM S OTM="COMBINED",NAM="COMBINED TEAMS" + .S CNT=0 F S CNT=$O(^TMP($J,"OTM",CNT)) Q:CNT'>0 D + ..I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")))&(DBDOWN=0) D SPIN^PXRMXBSY("Collecting patients from OE/RR List",.BUSY) + ..S DFN=$P(^TMP($J,"OTM",CNT),U) + ..D UPD1(DFN,NAM,"FACILITY",II) + .D MARK(OTM) + K ^TMP($J,"OTM") + I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DONE^PXRMXBSY("Done") + I PXRMREP="D",$D(^TMP($J,"PXRM PATIENT EVAL"))>0 D SDAM301^PXRMXSL2(DT,"",PXRMSEL,PXRMFD,PXRMREP) + Q + ; + ;PCMM provider selected +PCMMP ; + I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY) + N CNT,SCDT,LIST,SCERR,SCLIST,II,PCM,NAM,PNAM,PXRM,OK + S SCDT("BEGIN")=PXRMSDT,SCDT("END")=PXRMSDT + ;Include patient if in team on any day in range + S SCDT("INCL")=0 + S II="" + ;Get patient list for each PROVIDER + F S II=$O(PXRMPRV(II)) Q:II="" D + .S PCM=$P(PXRMPRV(II),U),NAM=$P(PXRMPRV(II),U,2) + .;Get patients for practs. roles - excluding assoc clinics + .K ^TMP($J,"PCM") + .N SCTEAM D PTPR^PXRMXAP(PCM,PXRMREP) + .I $O(^TMP($J,"PCM",0))="" Q + .;Save in ^TMP in alpha order within team number (internal) + .S CNT=0 F S CNT=$O(^TMP($J,"PCM",CNT)) Q:CNT'>0 D + ..S DFN=$P(^TMP($J,"PCM",CNT),U) + ..I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")))&(DBDOWN=0) D SPIN^PXRMXBSY("Collecting patients from Primary Provider List",.BUSY) + ..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)'="" S ^XTMP(PXRMXTMP,"HLOC",DCLN)="" + ..I $G(DCLN)'="" S PXRMDCLN(DCLN)="" + ..D UPD1(DFN,NAM,"FACILITY",+$G(DCLN)) + .D MARK(PCM) + K ^TMP($J,"PCM") + I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DONE^PXRMXBSY("Done") + I PXRMREP="D",$D(^TMP($J,"PXRM PATIENT EVAL"))>0 D SDAM301^PXRMXSL2(DT,"",PXRMSEL,PXRMFD,PXRMREP) + Q + ; + ;PCMM team selected +PCMMT ; + I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY) + N CNT,SCDT,LIST,SCERR,SCLIST,II,PCM,NAM,PNAM,OK + S SCDT("BEGIN")=PXRMSDT,SCDT("END")=PXRMSDT + ;Include patient if in team on any day in range + S SCDT("INCL")=0 + S II="" + ;Get patient list for each team + F S II=$O(PXRMPCM(II)) Q:II="" D + .S PCM=$P(PXRMPCM(II),U),NAM=$P(PXRMPCM(II),U,2) + .K ^TMP($J,"PCM") + .S OK=$$PTTM^PXRMXAP(PCM,.SCERR) Q:'OK + .I $O(^TMP($J,"PCM",0))="" Q + .S FACILITY=$$FAC^PXRMXAP(PCM) + .S CNT=0 F S CNT=$O(^TMP($J,"PCM",CNT)) Q:CNT'>0 D + ..S DFN=$P(^TMP($J,"PCM",CNT),U) + ..I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")))&(DBDOWN=0) D SPIN^PXRMXBSY("Collecting patients from PCMM Team List",.BUSY) + ..D UPD1(DFN,NAM,FACILITY,II) + .D MARK(PCM) + K ^TMP($J,"PCM") + I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DONE^PXRMXBSY("Done") + I PXRMREP="D",$D(^TMP($J,"PXRM PATIENT EVAL"))>0 D SDAM301^PXRMXSL2(DT,"",PXRMSEL,PXRMFD,PXRMREP) + Q + ; + ;Individual Patients selected +IND ; + N CNT,DFN,DUMMY,LIST,NAM + S (DUMMY,NAM)="PATIENT" + S CNT=0 F S CNT=$O(PXRMPAT(CNT)) Q:CNT'>0 D + .S DFN=$P(PXRMPAT(CNT),U) + .D UPD1(DFN,"INDIVIDUAL PATIENTS","FACILITY",DFN) + I PXRMREP="D",$D(^TMP($J,"PXRM PATIENT EVAL"))>0 D SDAM301^PXRMXSL2(DT,"",PXRMSEL,PXRMFD,PXRMREP) + Q + ; + ;Patient lists selected +LIST ; + I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY) + N DFN,DSUB,DUMMY,LCNT,LIEN,LIST,NAM + S (DUMMY,NAM)="PATIENT",LCNT=0 + F S LCNT=$O(PXRMLIST(LCNT)) Q:'LCNT D + .S LIEN=$P(PXRMLIST(LCNT),U) Q:'LIEN + .S NAM=$P(^PXRMXP(810.5,LIEN,0),U) + .S DSUB=0 + .F S DSUB=$O(^PXRMXP(810.5,LIEN,30,DSUB)) Q:'DSUB D + ..S DFN=$P($G(^PXRMXP(810.5,LIEN,30,DSUB,0)),U) Q:'DFN + ..I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")))&(DBDOWN=0) D SPIN^PXRMXBSY("Collecting patients from Reminder Patient List",.BUSY) + ..D UPD1(DFN,NAM,"FACILITY",LIEN) + I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DONE^PXRMXBSY("Done") + I PXRMREP="D",$D(^TMP($J,"PXRM PATIENT EVAL"))>0 D SDAM301^PXRMXSL2(DT,"",PXRMSEL,PXRMFD,PXRMREP) + Q + ; +UPD1(DFN,NAM,FACILITY,INP) ; + ;Remove test patients. + I 'PXRMTPAT,$$TESTPAT^VADPT(DFN)=1 Q + ;Remove patients that are deceased. + I 'PXRMDPAT,$P($G(^DPT(DFN,.35)),U,1)>0 Q + S ^TMP($J,"PXRM PATIENT LIST",DFN)="" + S ^TMP($J,"PXRM PATIENT EVAL",DFN)="" + D TMP(DFN,NAM,FACILITY,INP) + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMXSL2.m b/r/CLINICAL_REMINDERS-PXRM/PXRMXSL2.m index 90d0211d..fd83e89f 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMXSL2.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMXSL2.m @@ -1,233 +1,170 @@ -PXRMXSL2 ; SLC/AGP - Process Visits/Appts Reminder Due report; 08/16/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; -APPTS ; - ;Call to SDAMA301 for future appointments - 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 PXRMEDT["." S EDT=PXRMEDT - E S EDT=PXRMEDT+.2359 - D SDAM301(BDT,EDT,PXRMSEL,PXRMFD,PXRMREP) - I DBDOWN=1 Q - S DFN=0 F S DFN=$O(^TMP($J,"SDAMA301",DFN)) Q:DFN'>0!(ZTSTOP=1) D - .;Remove test patients. - .I 'PXRMTPAT,$$TESTPAT^VADPT(DFN)=1 Q - .;Remove patients that are deceased. - .I 'PXRMDPAT,$P($G(^DPT(DFN,.35)),U,1)>0 Q - .S APPTDT=0 F S APPTDT=$O(^TMP($J,"SDAMA301",DFN,APPTDT)) Q:APPTDT'>0!(ZTSTOP=1) D - ..S NODE=$G(^TMP($J,"SDAMA301",DFN,APPTDT)) - ..S HLIEN=$P($P(NODE,U,2),";") - ..S FACILITY=$P(^XTMP(PXRMXTMP,"HLOC",HLIEN),U,1) - ..S NAM=$P(^XTMP(PXRMXTMP,"HLOC",HLIEN),U,2) - ..I PXRMREP="D" D - ...S ^TMP($J,"PXRM FUTURE APPT",DFN,HLIEN,APPTDT)=NODE - ...S ^TMP($J,"PXRM FACILITY FUTURE APPT",DFN,FACILITY,APPTDT)=NODE - ..I $$S^%ZTLOAD S ZTSTOP=1 Q - ..D TMP^PXRMXSL1(DFN,NAM,FACILITY,HLIEN),MARK^PXRMXSL1(HLIEN) - ..S ^TMP($J,"PXRM PATIENT EVAL",DFN)="" - K ^TMP($J,"SDAMA301") - Q - ; -GETHFAC(HLOCIEN) ; - N DIV,HFAC - ;DBIA #2804 - S HFAC=$P(^SC(HLOCIEN,0),U,4) - I HFAC="" S DIV=$P($G(^SC(HLOCIEN,0)),U,15) S:DIV'="" HFAC=$P($G(^DG(40.8,DIV,0)),U,7) - I HFAC="" S HFAC=+$P($$SITE^VASITE,U,3) - Q +HFAC - ; -SDAM301(BD,ED,PXRMSEL,PXRMFD,PXRMREP) ; - N ARRAY,BUSY,FACILITY,NAM,OPIEN,STATUS,TEXT - K ^TMP($J,"PXRM FUTURE APPT") - K ^TMP($J,"PXRM FACILITY FUTURE APPT") - ; - I ED'>0 S ARRAY(1)=BD - I ED>0 S ARRAY(1)=BD_";"_ED - I PXRMREP="D",PXRMSEL="L",PXRMFD="P" S ARRAY(1)=BD - ; - I $D(^XTMP(PXRMXTMP,"HLOC"))>0 S ARRAY(2)="^XTMP(PXRMXTMP,""HLOC""," - ;S ARRAY(3)=$S(PXRMFD="P":"R;I;NS;NSR;CP;CPR;CC;CCR;NT",1:"R;I") - S ARRAY(3)=$S(PXRMFD="P":"R;I",1:"R;I;NT") - I $D(^TMP($J,"PXRM PATIENT LIST"))>0 S ARRAY(4)="^TMP($J,""PXRM PATIENT LIST""" - S ARRAY("FLDS")="1;2;3;10;12;13;14;22" - I $D(^TMP($J,"PXRM PATIENT LIST"))=0 S ARRAY("SORT")="P" - ; - N END,START,BUSY - S START=$H - S BUSY=0 - ;DBIA #4433 - I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY) - I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y"))) D SPIN^PXRMXBSY("Calling the scheduling package to gather appointment data",.BUSY) - 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 COUNT<0 D Q - .N CNT - .S DBDOWN=1,CNT=0 - .F S CNT=$O(^TMP($J,"SDAMA301",CNT)) Q:CNT'>0 D - ..S DBERR(CNT)=$G(^TMP($J,"SDAMA301",CNT)) - .D ERRMSG^PXRMXDT1("E") - ; -LOOP ; - I PXRMFD'="P"!(PXRMSEL'="L") Q - N APPTDT,CIEN,DFN,FUTDT,NODE,TEXT,VIEN - ;LOOP THROUGH PATIENT - S START=$H - S BUSY=0 - S FUTDT=$S(DT>$P(ED,"."):DT,1:$P(ED,".")) - I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D SPIN^PXRMXBSY("Sorting SDAMA301 Output",.BUSY) - S DFN=0 F S DFN=$O(^TMP($J,"SDAMA301",DFN)) Q:DFN'>0 D - .; - .;LOOP THROUGH CLINICS - .S CIEN=0 - .F S CIEN=$O(^TMP($J,"SDAMA301",DFN,CIEN)) Q:CIEN'>0 D - ..S APPTDT=0 - ..F S APPTDT=$O(^TMP($J,"SDAMA301",DFN,CIEN,APPTDT)) Q:APPTDT'>0 D - ...I PXRMREP="S",$P(APPTDT,".")>$P(ED,".") Q - ...S NODE=$G(^TMP($J,"SDAMA301",DFN,CIEN,APPTDT)) - ...;S STATUS=$P($P(NODE,U,3),";") - ...;I ($P(ED,".")+1)>($P(APPTDT,".")),STATUS'="I",STATUS'="R",STATUS'="NT" D - ...;.K ^TMP($J,"PXRM PATIENT LIST",DFN,CIEN,APPTDT) - ...; - ...;if report is detailed report store future appointment - ...I $P(APPTDT,".")>FUTDT D - ....S ^TMP($J,"PXRM FUTURE APPT",DFN,CIEN,APPTDT)=NODE - ....S ^TMP($J,"PXRM FACILITY FUTURE APPT",DFN,$$GETHFAC(CIEN),APPTDT)=NODE - K ^TMP($J,"SDAMA301") - 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 - 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 DOD,START,END - S START=$H - K ^TMP($J,"PXRM PATIENT LIST") - I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY) - S DEND=$S(PXRMEDT[".":PXRMEDT,1:PXRMEDT+.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(PXRMBDT,".",1),BTIME=+("."_$P(PXRMBDT,".",2)) - S INVED=9999999-$P(DEND,".",1),ETIME=+("."_$P(DEND,".",2)) - S DS=INVED-.000001 - S HLOC="" - F S HLOC=$O(^XTMP(PXRMXTMP,"HLOC",HLOC)) Q:HLOC="" D - . S INVDT=DS,DONE=0 - . F S INVDT=$O(^AUPNVSIT("AHL",HLOC,INVDT)) Q:(DONE)!(INVDT="") D - ..I $$S^%ZTLOAD S ZTSTOP=1 Q - ..I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")))&(DBDOWN=0) D SPIN^PXRMXBSY("Building Patient List",.BUSY) - .. S INVDATE=$P(INVDT,".",1) - .. I INVDATE>INVBD S DONE=1 Q - .. S TIME=+("."_$P(INVDT,".",2)) - .. I INVDATE=INVED,TIME>ETIME 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 - ... S TEMP=^AUPNVSIT(DAS,0) - ... I $$VAPSTAT^PXRMVSIT(DAS)=0 Q - ... S SC=$P(TEMP,U,7) - ... I SC="" Q - ... I '$D(PXRMSCAT(SC)) Q - ... S DFN=$P(TEMP,U,5) - ... ;Remove Test Patients - ... I 'PXRMTPAT,$$TESTPAT^VADPT(DFN)=1 Q - ... ;Remove Patient that are deceased - ... I 'PXRMDPAT,$P($G(^DPT(DFN,.35)),U,1)>0 Q - ... S DATE=$P(TEMP,U,1) - ... S ^TMP($J,"PXRM PATIENT LIST",DFN,HLOC,DATE,DAS)="" - 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 DBDOWN=1 Q - S START=$H - S BUSY=0 - N NODE - I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY) - N DFN,HLIEN,NAM,FACILITY,LSEL,TEMP - 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 +PXRMXSL2 ; SLC/AGP - Process Visits/Appts Reminder Due report; 06/07/2006 + ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21 + ; +APPTS ; + ;Call to SDAMA301 for future appointments + N APPTDT,BDT,EDT,NODE,DFN,FACILITY,HLIEN,NAM + S NAM="All Locations" + I PXRMBDT["." S BDT=PXRMBDT + E S BDT=PXRMBDT-.0001 + I PXRMEDT["." S EDT=PXRMEDT + E S EDT=PXRMEDT+.2359 + D SDAM301(BDT,EDT,PXRMSEL,PXRMFD,PXRMREP) + I DBDOWN=1 Q + S DFN=0 F S DFN=$O(^TMP($J,"SDAMA301",DFN)) Q:DFN'>0!(ZTSTOP=1) D + .;Remove test patients. + .I 'PXRMTPAT,$$TESTPAT^VADPT(DFN)=1 Q + .;Remove patients that are deceased. + .I 'PXRMDPAT,$P($G(^DPT(DFN,.35)),U,1)>0 Q + .S APPTDT=0 F S APPTDT=$O(^TMP($J,"SDAMA301",DFN,APPTDT)) Q:APPTDT'>0!(ZTSTOP=1) D + ..S NODE=$G(^TMP($J,"SDAMA301",DFN,APPTDT)) + ..S HLIEN=$P($P(NODE,U,2),";") + ..S FACILITY=$P(^XTMP(PXRMXTMP,"HLOC",HLIEN),U,1) + ..S NAM=$P(^XTMP(PXRMXTMP,"HLOC",HLIEN),U,2) + ..I PXRMREP="D" D + ...S ^TMP($J,"PXRM FUTURE APPT",DFN,HLIEN,APPTDT)=NODE + ...S ^TMP($J,"PXRM FACILITY FUTURE APPT",DFN,FACILITY,APPTDT)=NODE + ..I $$S^%ZTLOAD S ZTSTOP=1 Q + ..D TMP^PXRMXSL1(DFN,NAM,FACILITY,HLIEN),MARK^PXRMXSL1(HLIEN) + ..S ^TMP($J,"PXRM PATIENT EVAL",DFN)="" + K ^TMP($J,"SDAMA301") + Q + ; +GETHFAC(HLOCIEN) ; + N DIV,HFAC + ;DBIA #2804 + S HFAC=$P(^SC(HLOCIEN,0),U,4) + I HFAC="" S DIV=$P($G(^SC(HLOCIEN,0)),U,15) S:DIV'="" HFAC=$P($G(^DG(40.8,DIV,0)),U,7) + I HFAC="" S HFAC=+$P($$SITE^VASITE,U,3) + Q +HFAC + ; +SDAM301(BD,ED,PXRMSEL,PXRMFD,PXRMREP) ; + N ARRAY,BUSY,FACILITY,NAM,OPIEN,STATUS + K ^TMP($J,"PXRM FUTURE APPT") + K ^TMP($J,"PXRM FACILITY FUTURE APPT") + ; + I ED'>0 S ARRAY(1)=BD + I ED>0 S ARRAY(1)=BD_";"_ED + I PXRMREP="D",PXRMSEL="L",PXRMFD="P" S ARRAY(1)=BD + ; + I $D(^XTMP(PXRMXTMP,"HLOC"))>0 S ARRAY(2)="^XTMP(PXRMXTMP,""HLOC""," + ;S ARRAY(3)=$S(PXRMFD="P":"R;I;NS;NSR;CP;CPR;CC;CCR;NT",1:"R;I") + S ARRAY(3)=$S(PXRMFD="P":"R;I",1:"R;I;NT") + I $D(^TMP($J,"PXRM PATIENT LIST"))>0 S ARRAY(4)="^TMP($J,""PXRM PATIENT LIST""" + S ARRAY("FLDS")="1;2;3;10;12;13;14;22" + I $D(^TMP($J,"PXRM PATIENT LIST"))=0 S ARRAY("SORT")="P" + ; + N END,START,BUSY + S START=$H + S BUSY=0 + ;DBIA #4433 + I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY) + I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y"))) D SPIN^PXRMXBSY("Calling the scheduling package to gather appointment data",.BUSY) + S COUNT=$$SDAPI^SDAMA301(.ARRAY) + S END=$H + 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 + .S DBDOWN=1,CNT=0 + .F S CNT=$O(^TMP($J,"SDAMA301",CNT)) Q:CNT'>0 D + ..S DBERR(CNT)=$G(^TMP($J,"SDAMA301",CNT)) + .D DBDOWN^PXRMXDT1("E") + ; +LOOP ; + I PXRMFD'="P"!(PXRMSEL'="L") Q + N APPTDT,CIEN,DFN,FUTDT,NODE,VIEN + ;LOOP THROUGH PATIENT + S START=$H + S BUSY=0 + S FUTDT=$S(DT>$P(ED,"."):DT,1:$P(ED,".")) + I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D SPIN^PXRMXBSY("Sorting SDAMA301 Output",.BUSY) + S DFN=0 F S DFN=$O(^TMP($J,"SDAMA301",DFN)) Q:DFN'>0 D + .; + .;LOOP THROUGH CLINICS + .S CIEN=0 + .F S CIEN=$O(^TMP($J,"SDAMA301",DFN,CIEN)) Q:CIEN'>0 D + ..S APPTDT=0 + ..F S APPTDT=$O(^TMP($J,"SDAMA301",DFN,CIEN,APPTDT)) Q:APPTDT'>0 D + ...I PXRMREP="S",$P(APPTDT,".")>$P(ED,".") Q + ...S NODE=$G(^TMP($J,"SDAMA301",DFN,CIEN,APPTDT)) + ...;S STATUS=$P($P(NODE,U,3),";") + ...;I ($P(ED,".")+1)>($P(APPTDT,".")),STATUS'="I",STATUS'="R",STATUS'="NT" D + ...;.K ^TMP($J,"PXRM PATIENT LIST",DFN,CIEN,APPTDT) + ...; + ...;if report is detailed report store future appointment + ...I $P(APPTDT,".")>FUTDT D + ....S ^TMP($J,"PXRM FUTURE APPT",DFN,CIEN,APPTDT)=NODE + ....S ^TMP($J,"PXRM FACILITY FUTURE APPT",DFN,$$GETHFAC(CIEN),APPTDT)=NODE + K ^TMP($J,"SDAMA301") + S END=$H + I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DONE^PXRMXBSY("Done") + 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 BTIME,DAS,DATE,DEND,DFN,DONE,DS,ETIME,HLOC,INVBD,INVDATE,INVDT,INVED + N NFOUND,SC,TEMP,TGLIST,TIME + N DOD,START,END + S START=$H + K ^TMP($J,"PXRM PATIENT LIST") + I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY) + S DEND=$S(PXRMEDT[".":PXRMEDT,1:PXRMEDT+.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(PXRMBDT,".",1),BTIME=+("."_$P(PXRMBDT,".",2)) + S INVED=9999999-$P(DEND,".",1),ETIME=+("."_$P(DEND,".",2)) + S DS=INVED-1 + S HLOC="" + F S HLOC=$O(^XTMP(PXRMXTMP,"HLOC",HLOC)) Q:HLOC="" D + . S INVDT=DS,DONE=0 + . F S INVDT=$O(^AUPNVSIT("AHL",HLOC,INVDT)) Q:(DONE)!(INVDT="") D + ..I $$S^%ZTLOAD S ZTSTOP=1 Q + ..I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")))&(DBDOWN=0) D SPIN^PXRMXBSY("Building Patient List",.BUSY) + .. S INVDATE=$P(INVDT,".",1) + .. I INVDATE>INVBD S DONE=1 Q + .. S TIME=+("."_$P(INVDT,".",2)) + .. I INVDATE=INVED,TIME>ETIME 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 + ... S TEMP=^AUPNVSIT(DAS,0) + ... I $$VAPSTAT^PXRMVSIT(DAS)=0 Q + ... S SC=$P(TEMP,U,7) + ... I SC="" Q + ... I '$D(PXRMSCAT(SC)) Q + ... S DFN=$P(TEMP,U,5) + ... ;Remove Test Patients + ... I 'PXRMTPAT,$$TESTPAT^VADPT(DFN)=1 Q + ... ;Remove Patient that are deceased + ... I 'PXRMDPAT,$P($G(^DPT(DFN,.35)),U,1)>0 Q + ... S DATE=$P(TEMP,U,1) + ... S ^TMP($J,"PXRM PATIENT LIST",DFN,HLOC,DATE,DAS)="" + S END=$H + I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DONE^PXRMXBSY("Done") + 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) + N DFN,HLIEN,NAM,FACILITY,LSEL,TEMP + 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 + 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 diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMXTB.m b/r/CLINICAL_REMINDERS-PXRM/PXRMXTB.m index 402149e9..1f7dd803 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMXTB.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMXTB.m @@ -1,89 +1,88 @@ -PXRMXTB ; SLC/PJH - Reminder Reports Template Load ;11/27/2006 - ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123 - ; - ; Called from PXRMXD - ; - ;Select Template - ;--------------- -START N X,Y,CNT,FOUND,PXRMFLD,DIC,MSG - N ERR,SEQ,TMPLST,LIST - K DIROUT,DIRUT,DTOUT,DUOUT - S PXRMTMP="",FOUND=0 - ; - ;Check if any templates exist for the user - D GETLST^XPAR(.TMPLST,"USR","PXRM REPORT TEMPLATE (USER)","Q",.ERR) - I ERR>0 W !!,?5,"Error: "_$P(ERR,U,2) S DUOUT=1 H 2 Q - I 'TMPLST W !!,?5,"No report Templates for this user" S DUOUT=1 H 2 Q - ;Build list of templates - S SEQ=0 - F S SEQ=$O(TMPLST(SEQ)) Q:'SEQ D - .S Y=$P(TMPLST(SEQ),U,2) Q:'Y - .S LIST(Y)="" - ; - ;Select template required - W ! - S CNT=0,DIC=810.1,DIC(0)="AEQMZ" - S DIC("A")="Select REPORT TEMPLATE:" - S DIC("S")="I $D(LIST(+Y)),$P(^PXRMPT(810.1,+Y,0),U,3)=PXRMTYP" - D ^DIC - W !!,"1" - I X="" S DUOUT=1 - I X=(U_U) S DTOUT=1 - I '$D(DTOUT),('$D(DUOUT)) D - .I +Y'=-1 D Q - ..S CNT=CNT+1,ARRAY(CNT)=Y_U_Y(0,0)_U_$P(Y(0),U,3) - K DIC - ; - ;Load template into local array - I (+Y'=-1)&('$D(DTOUT))&('$D(DUOUT)) D - .L +^PXRMPT(810.1,$P(Y,U)):0 - .E W !!?5,"Another user is editing this entry." S DUOUT=1 Q - .;Load template into an array - .S PXRMTMP=Y_U_$P(Y(0),U,2) D LOAD^PXRMXT - .L -^PXRMPT(810.1,$P(PXRMTMP,U)) - .;Exit if problem loading template - .I $D(MSG) S DTOUT=1 Q - .;Display Template information - .D:'$D(MSG) ^PXRMXTD -EXIT Q - ; -XREF ; - K MREF,XREF - S XREF("NAME")=.01 - S XREF("TITLE")=1.9 - S XREF("PXRMTYP")=1.1 - S XREF("PXRMSEL")=1.2 - S XREF("PXRMPRIM")=1.3 - S XREF("PXRMREP")=1.4 - S XREF("PXRMLCSC")=1.5 - S XREF("PXRMFD")=1.6 - S XREF("PXRMPML")=1.7 - S XREF("PXRMREM")=2 - S XREF("PXRMFAC")=3 - S XREF("PXRMPRV")=4 - S XREF("RUN")=5 - S XREF("PXRMPAT")=6 - S XREF("PXRMOTM")=7 - S XREF("PXRMPCM")=8 - S XREF("PXRMSCAT")=9 - S XREF("PXRMLCHL")=10 - S XREF("PXRMCS")=11 - S XREF("PXRMCGRP")=12 - S XREF("PXRMRCAT")=13 - S XREF("PXRMLIST")=14 - ; - S MREF("REMINDER")=.01 - S MREF("PATIENT")=.01 - S MREF("PROVIDER")=.01 - S MREF("OERR TEAM")=.01 - S MREF("PCMM TEAM")=.01 - S MREF("FACILITY")=.01 - S MREF("SERVICE")=.01 - S MREF("LOCATION")=.01 - S MREF("STOP CODE")=.01 - S MREF("CLINIC GROUP")=.01 - S MREF("DISPLAY ORDER")=.02 - S MREF("REMINDER CATEGORY")=.01 - S MREF("DISPLAY")=.02 - S MREF("PXRMLIST")=.01 - Q +PXRMXTB ; SLC/PJH - Reminder Reports Template Load ;08/01/2001 + ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005 + ; + ; Called from PXRMXD + ; + ;Select Template + ;--------------- +START N X,Y,CNT,FOUND,PXRMFLD,DIC,MSG + N ERR,SEQ,TMPLST,LIST + K DIROUT,DIRUT,DTOUT,DUOUT + S PXRMTMP="",FOUND=0 + ; + ;Check if any templates exist for the user + D GETLST^XPAR(.TMPLST,"USR","PXRM REPORT TEMPLATE (USER)","Q",.ERR) + I ERR>0 W !!,?5,"Error: "_$P(ERR,U,2) S DUOUT=1 H 2 Q + I 'TMPLST W !!,?5,"No report Templates for this user" S DUOUT=1 H 2 Q + ;Build list of templates + S SEQ=0 + F S SEQ=$O(TMPLST(SEQ)) Q:'SEQ D + .S Y=$P(TMPLST(SEQ),U,2) Q:'Y + .S LIST(Y)="" + ; + ;Select template required + W ! + S CNT=0,DIC=810.1,DIC(0)="AEQMZ" + S DIC("A")="Select REPORT TEMPLATE:" + S DIC("S")="I $D(LIST(+Y)),$P(^PXRMPT(810.1,+Y,0),U,3)=PXRMTYP" + D ^DIC + W !!,"1" + I X="" S DUOUT=1 + I X=(U_U) S DTOUT=1 + I '$D(DTOUT),('$D(DUOUT)) D + .I +Y'=-1 D Q + ..S CNT=CNT+1,ARRAY(CNT)=Y_U_Y(0,0)_U_$P(Y(0),U,3) + K DIC + ; + ;Load template into local array + I (+Y'=-1)&('$D(DTOUT))&('$D(DUOUT)) D + .L +^PXRMPT(810.1,$P(Y,U)):0 + .E W !!?5,"Another user is editing this entry." S DUOUT=1 Q + .;Load template into an array + .S PXRMTMP=Y_U_$P(Y(0),U,2) D LOAD^PXRMXT + .L -^PXRMPT(810.1,$P(PXRMTMP,U)) + .;Exit if problem loading template + .I $D(MSG) S DTOUT=1 Q + .;Display Template information + .D:'$D(MSG) ^PXRMXTD +EXIT Q + ; +XREF ; + K MREF,XREF + S XREF("NAME")=.01 + S XREF("TITLE")=1.9 + S XREF("PXRMTYP")=1.1 + S XREF("PXRMSEL")=1.2 + S XREF("PXRMPRIM")=1.3 + S XREF("PXRMREP")=1.4 + S XREF("PXRMLCSC")=1.5 + S XREF("PXRMFD")=1.6 + S XREF("PXRMREM")=2 + S XREF("PXRMFAC")=3 + S XREF("PXRMPRV")=4 + S XREF("RUN")=5 + S XREF("PXRMPAT")=6 + S XREF("PXRMOTM")=7 + S XREF("PXRMPCM")=8 + S XREF("PXRMSCAT")=9 + S XREF("PXRMLCHL")=10 + S XREF("PXRMCS")=11 + S XREF("PXRMCGRP")=12 + S XREF("PXRMRCAT")=13 + S XREF("PXRMLIST")=14 + ; + S MREF("REMINDER")=.01 + S MREF("PATIENT")=.01 + S MREF("PROVIDER")=.01 + S MREF("OERR TEAM")=.01 + S MREF("PCMM TEAM")=.01 + S MREF("FACILITY")=.01 + S MREF("SERVICE")=.01 + S MREF("LOCATION")=.01 + S MREF("STOP CODE")=.01 + S MREF("CLINIC GROUP")=.01 + S MREF("DISPLAY ORDER")=.02 + S MREF("REMINDER CATEGORY")=.01 + S MREF("DISPLAY")=.02 + S MREF("PXRMLIST")=.01 + Q diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMXTD.m b/r/CLINICAL_REMINDERS-PXRM/PXRMXTD.m index a6455d32..eca1dafc 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMXTD.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMXTD.m @@ -1,103 +1,102 @@ -PXRMXTD ; SLC/PJH - Reminder Reports Template Display ;11/16/2007 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ; Called from PXRMXT/PXRMXTF - ; - ; - ;Display Template information -START ;---------------------------- - N PAGE,BMARG,DONE,SD,ED,DES,RDES,CDES,PSTART,PXRMOPT,IC,CNT - S PAGE=1,BMARG=0,DONE=0,SD="",ED="",PSTART=10,CNT=0 - ; - D LITS^PXRMXPR1 - ; - I PXRMREP="D" S PXRMOPT="Detailed Report" - I PXRMREP="S" S PXRMOPT="Summary Report" - W !!?(PSTART),"Report Title:",?32,$P(PXRMTMP,U,3) - W !?PSTART,"Report Type:",?32,$G(PXRMOPT) - W !?PSTART,"Patient Sample:",?32,PXRMFLD - I "LT"[PXRMSEL D - .W !,?PSTART,"Facility:" D FAC - I PXRMSEL'="L" W !,?PSTART,PXRMFLD,":" D ARRS - I PXRMSEL="L" D - .W !?PSTART,PXRMFLD,":",?32,DES - .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:" - .W ?32,$P(PXRMRCAT(IC),U,3),?35,$P(PXRMRCAT(IC),U,2) D CHECK(1) - I DONE Q - S IC="" F S IC=$O(PXRMREM(IC)) Q:IC="" D Q:DONE - .W !,?PSTART W:IC=1 "Reminder:" - .W ?32,$P(PXRMREM(IC),U,3),?35,$P(PXRMREM(IC),U,2) D CHECK(1) - I DONE Q - I PXRMSEL="P" W !,?PSTART,"All/Primary:",?32,CDES - W !?(PSTART),"Template Name:",?32,$P(PXRMTMP,U,2) - W !?PSTART,"Date last run:",?32,$S(RUN]"":RUN,1:"n/a") - I $D(PXRMSCAT),PXRMSCAT]"",PXRMFD="P" D OSCAT(PXRMSCAT,PSTART) -EXIT Q - ; - ;Display selected teams/providers - ;-------------------------------- -ARRS N IC - S IC="" - I PXRMSEL="P" F S IC=$O(PXRMPRV(IC)) Q:IC="" D Q:DONE - .W:IC>1 ! W ?32,$P(PXRMPRV(IC),U,2) D CHECK(1) - I PXRMSEL="T" F S IC=$O(PXRMPCM(IC)) Q:IC="" D Q:DONE - .W:IC>1 ! W ?32,$P(PXRMPCM(IC),U,2) D CHECK(1) - I PXRMSEL="O" F S IC=$O(PXRMOTM(IC)) Q:IC="" D Q:DONE - .W:IC>1 ! W ?32,$P(PXRMOTM(IC),U,2) D CHECK(1) - I PXRMSEL="I" F S IC=$O(PXRMPAT(IC)) Q:IC="" D Q:DONE - .W:IC>1 ! W ?32,$P(PXRMPAT(IC),U,2) D CHECK(1) - I PXRMSEL="R" F S IC=$O(PXRMLIST(IC)) Q:IC="" D Q:DONE - .W:IC>1 ! W ?32,$P(PXRMLIST(IC),U,2) D CHECK(1) - I PXRMSEL="L" D - .I $E(PXRMLCSC)="H" F S IC=$O(PXRMLCHL(IC)) Q:IC="" D - ..W:IC>1 ! W ?32,$P(PXRMLCHL(IC),U) D CHECK(1) - .I $E(PXRMLCSC)="C" F S IC=$O(PXRMCS(IC)) Q:IC="" D - ..W:IC>1 ! W ?32,$P(PXRMCS(IC),U)," ",$P(PXRMCS(IC),U,3) - ..D CHECK(1) - .I $E(PXRMLCSC)="G" F S IC=$O(PXRMCGRP(IC)) Q:IC="" D - ..W:IC>1 ! W ?32,$P(PXRMCGRP(IC),U)," ",$P(PXRMCGRP(IC),U,2) - ..D CHECK(1) - Q - ; - ;Display selected Facilities - ;--------------------------- -FAC N IC - S IC="" - F S IC=$O(PXRMFAC(IC)) Q:IC="" D Q:DONE - .W:IC>1 ! W ?32,$P(PXRMFAC(IC),U,2) D CHECK(1) - Q - ; - ; - ;Output the service categeories - ;------------------------------ -OSCAT(SCL,PSTART) ; - N IC,CSTART,EM,SC,SCTEXT - S CSTART=PSTART+3 - W !,?PSTART,"Service categories:",?32,SCL - F IC=1:1:$L(SCL,",") D - .S SC=$P(SCL,",",IC) - .S SCTEXT=$$EXTERNAL^DILFD(9000010,.07,"",SC,.EM) - .W !,?CSTART,SC," - ",SCTEXT - .D CHECK(1) - Q - ; - ;Check for page throw - ;-------------------- -CHECK(LEAVE) ; - S CNT=CNT+1 - I CNT>(IOSL-BMARG-LEAVE) D PAGE S CNT=0 - Q - ; - ;form feed to new page - ;--------------------- -PAGE I ($E(IOST,1,2)="C-")&(IO=IO(0))&(PAGE>0) D - .S DIR(0)="E" - .W ! - .D ^DIR K DIR - I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)) S DONE=1 Q - W ! - Q +PXRMXTD ; SLC/PJH - Reminder Reports Template Display ;11/03/2005 + ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21 + ; + ; Called from PXRMXT/PXRMXTF + ; + ; + ;Display Template information +START ;---------------------------- + N PAGE,BMARG,DONE,SD,ED,DES,RDES,CDES,PSTART,PXRMOPT,IC,CNT + S PAGE=1,BMARG=0,DONE=0,SD="",ED="",PSTART=10,CNT=0 + ; + D LITS^PXRMXPR1 + ; + I PXRMREP="D" S PXRMOPT="Detailed Report" + I PXRMREP="S" S PXRMOPT="Summary Report" + W !!?(PSTART),"Report Title:",?32,$P(PXRMTMP,U,3) + W !?PSTART,"Report Type:",?32,$G(PXRMOPT) + W !?PSTART,"Patient Sample:",?32,PXRMFLD + I "LT"[PXRMSEL D + .W !,?PSTART,"Facility:" D FAC + I PXRMSEL'="L" W !,?PSTART,PXRMFLD,":" D ARRS + I PXRMSEL="L" D + .W !?PSTART,PXRMFLD,":",?32,DES + .I $E(PXRMLCSC,2)'="A" W ! D ARRS + I DONE Q + S IC="" F S IC=$O(PXRMRCAT(IC)) Q:IC="" D Q:DONE + .W !,?PSTART W:IC=1 "Category:" + .W ?32,$P(PXRMRCAT(IC),U,3),?35,$P(PXRMRCAT(IC),U,2) D CHECK(1) + I DONE Q + S IC="" F S IC=$O(PXRMREM(IC)) Q:IC="" D Q:DONE + .W !,?PSTART W:IC=1 "Reminder:" + .W ?32,$P(PXRMREM(IC),U,3),?35,$P(PXRMREM(IC),U,2) D CHECK(1) + I DONE Q + I PXRMSEL="P" W !,?PSTART,"All/Primary:",?32,CDES + W !?(PSTART),"Template Name:",?32,$P(PXRMTMP,U,2) + W !?PSTART,"Date last run:",?32,$S(RUN]"":RUN,1:"n/a") + I $D(PXRMSCAT),PXRMSCAT]"",PXRMFD="P" D OSCAT(PXRMSCAT,PSTART) +EXIT Q + ; + ;Display selected teams/providers + ;-------------------------------- +ARRS N IC + S IC="" + I PXRMSEL="P" F S IC=$O(PXRMPRV(IC)) Q:IC="" D Q:DONE + .W:IC>1 ! W ?32,$P(PXRMPRV(IC),U,2) D CHECK(1) + I PXRMSEL="T" F S IC=$O(PXRMPCM(IC)) Q:IC="" D Q:DONE + .W:IC>1 ! W ?32,$P(PXRMPCM(IC),U,2) D CHECK(1) + I PXRMSEL="O" F S IC=$O(PXRMOTM(IC)) Q:IC="" D Q:DONE + .W:IC>1 ! W ?32,$P(PXRMOTM(IC),U,2) D CHECK(1) + I PXRMSEL="I" F S IC=$O(PXRMPAT(IC)) Q:IC="" D Q:DONE + .W:IC>1 ! W ?32,$P(PXRMPAT(IC),U,2) D CHECK(1) + I PXRMSEL="R" F S IC=$O(PXRMLIST(IC)) Q:IC="" D Q:DONE + .W:IC>1 ! W ?32,$P(PXRMLIST(IC),U,2) D CHECK(1) + I PXRMSEL="L" D + .I $E(PXRMLCSC)="H" F S IC=$O(PXRMLCHL(IC)) Q:IC="" D + ..W:IC>1 ! W ?32,$P(PXRMLCHL(IC),U) D CHECK(1) + .I $E(PXRMLCSC)="C" F S IC=$O(PXRMCS(IC)) Q:IC="" D + ..W:IC>1 ! W ?32,$P(PXRMCS(IC),U)," ",$P(PXRMCS(IC),U,3) + ..D CHECK(1) + .I $E(PXRMLCSC)="G" F S IC=$O(PXRMCGRP(IC)) Q:IC="" D + ..W:IC>1 ! W ?32,$P(PXRMCGRP(IC),U)," ",$P(PXRMCGRP(IC),U,2) + ..D CHECK(1) + Q + ; + ;Display selected Facilities + ;--------------------------- +FAC N IC + S IC="" + F S IC=$O(PXRMFAC(IC)) Q:IC="" D Q:DONE + .W:IC>1 ! W ?32,$P(PXRMFAC(IC),U,2) D CHECK(1) + Q + ; + ; + ;Output the service categeories + ;------------------------------ +OSCAT(SCL,PSTART) ; + N IC,CSTART,EM,SC,SCTEXT + S CSTART=PSTART+3 + W !,?PSTART,"Service categories:",?32,SCL + F IC=1:1:$L(SCL,",") D + .S SC=$P(SCL,",",IC) + .S SCTEXT=$$EXTERNAL^DILFD(9000010,.07,"",SC,.EM) + .W !,?CSTART,SC," - ",SCTEXT + .D CHECK(1) + Q + ; + ;Check for page throw + ;-------------------- +CHECK(LEAVE) ; + S CNT=CNT+1 + I CNT>(IOSL-BMARG-LEAVE) D PAGE S CNT=0 + Q + ; + ;form feed to new page + ;--------------------- +PAGE I ($E(IOST)="C")&(IO=IO(0))&(PAGE>0) D + .S DIR(0)="E" + .W ! + .D ^DIR K DIR + I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)) S DONE=1 Q + W ! + Q diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMXTE.m b/r/CLINICAL_REMINDERS-PXRM/PXRMXTE.m index 42d3370f..e1f26d81 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMXTE.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMXTE.m @@ -1,94 +1,92 @@ -PXRMXTE ; SLC/PJH - Reminder Reports Template Edit ;11/27/2006 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ; Called from PXRMYD,PXRMXD - ; - ;Option to Edit - ;-------------- -EDIT ; - N DIDEL,DIE,DR K DTOUT,DUOUT - ;Edit report name, title and PXRMSEL (patient sample) - S DIE=810.1,DA=$P(PXRMTMP,U),DR=".01T;1.9;1.2",DIDEL=810.1 - D ^DIE I $D(Y) S DUOUT=1 Q - ;Check if template has been deleted - I '$D(DA) Q - ;Get updated value of PXRMXSEL - N PXRMSEL,PXRMFUT S PXRMSEL=X - ;Needed for 1.6 validation - Prior/Future or Current/Admissions - ;N PXRMINP - ;Further fields depend on value in PXRMXSEL - I PXRMSEL="I" S DR="6T~R",PXRMINP=0 - I PXRMSEL="R" S DR="14T",PXRMINP=0 - I PXRMSEL="L" D Q:$D(DUOUT) - .;Get location report type - .S DR="3T;1.5R" D ^DIE I $D(Y) S DUOUT=1 Q - .N PXRMLCSC S PXRMLCSC=X,DR="",PXRMINP=0 - .;All location reports - prompt for prior/future/current/admissions - .I PXRMLCSC="HAI" S PXRMINP=1,DR="1.6" Q - .I PXRMLCSC="HA" S PXRMINP=0,DR="1.6" - .I PXRMLCSC="CA" S PXRMINP=0,DR="1.6" - .D ^DIE I $D(Y) S DUOUT=1 Q - .S PXRMFUT=X,DR="" - .;Selected Location/Stop Code/Clinic Group fields - .I PXRMLCSC="HS" D Q:$D(DUOUT) - ..S DR="10T~R" - ..D ^DIE I $D(Y) S DUOUT=1 Q - ..;Determine if locations input are all wards - ..S PXRMINP=$$INP^PXRMXAP(PXRMLCSC,.PXRMLOCN) - ..;Select Prior/Future or Current Inpatient/Admissions - ..S DR="1.6" - ..D ^DIE I $D(Y) S DUOUT=1 Q - ..S PXRMFUT=X,DR="" - .;Clinic Stop input and prior/future - .I PXRMLCSC="CS" S PXRMINP=0,DR="11T~R;1.6" D I $G(DUOUT)=1 Q - ..D ^DIE I $D(Y) S DUOUT=1 Q - ..S PXRMFUT=X,DR="" - .;Clinic Group input and prior/future - .I PXRMLCSC="GS" S PXRMINP=0,DR="12T~R;1.6" D I $G(DUOUT)=1 Q - ..D ^DIE I $D(Y) S DUOUT=1 Q - ..S PXRMFUT=X,DR="" - .;Service categories (except for inpatient reports) - .I PXRMINP=0,PXRMFUT'="F",PXRMFUT'="C" S DR=DR_";9T~R" - ;OE/RR teams - I PXRMSEL="O" S DR="7T~R" - ;PCMM Provider and Primary care/All - I PXRMSEL="P" S DR="4T~R;1.3" - ;PCMM teams - I PXRMSEL="T" S DR="3T~R;8T~R" - ;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 - .N IEN,CNT,NODE - .S CNT=0,IEN=0 F S IEN=$O(^PXRMPT(810.1,DA,12,IEN)) Q:IEN'>0 D - ..S CNT=CNT+1,NODE=$G(^PXRMPT(810.1,DA,12,IEN,0)) - ..S PXRMTCAT(DA,CNT)=$P(NODE,U)_U_$P($G(^PXRMD(811.7,$P(NODE,U),0)),U)_U_$P(NODE,U,2) - S DR=DR_";13T" - ;Reminders - I $D(^PXRMPT(810.1,DA,1,0))>0 D - .N IEN,CNT,NODE,REMNODE - .S CNT=0,IEN=0 F S IEN=$O(^PXRMPT(810.1,DA,1,IEN)) Q:IEN'>0 D - ..S CNT=CNT+1,NODE=$G(^PXRMPT(810.1,DA,1,IEN,0)) - ..S REMNODE=$G(^PXD(811.9,$P(NODE,U),0)) - ..S PXRMTREM(DA,CNT)=$P(NODE,U)_U_$P(REMNODE,U)_U_$P(NODE,U,2)_U_$P($G(REMNODE),U,3) - S DR=DR_";2T" - ; - ;Strip of any leading semi-colons - I $E(DR)=";" S DR=$P(DR,";",2,99) - ; - D ^DIE I $D(Y) S DUOUT=1 Q - ; - ;If all reminders have been deleted from the template disallow save - I +$P($G(^PXRMPT(810.1,DA,1,0)),U,4)=0 D - .;Check categories also - .I +$P($G(^PXRMPT(810.1,DA,12,0)),U,4)>0 D Q - .. N CAT,CATIEN - .. S CAT=0 F S CAT=$O(^PXRMPT(810.1,DA,12,CAT)) Q:+CAT'>0 D - ... S CATIEN=$P($G(^PXRMPT(810.1,DA,12,CAT,0)),U) - ... I +$P($G(^PXRMD(811.7,CATIEN,2,0)),U,4)<1 W !!,"** WARNING **",!,"Reminder Category "_$P($G(^PXRMD(811.7,CATIEN,0)),U)_" does not have any reminders assigned to it" - .S DUOUT=1 - .W !!,"No reminders defined" - Q - ; +PXRMXTE ; SLC/PJH - Reminder Reports Template Edit ;08/03/2006 + ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21 + ; + ; Called from PXRMYD,PXRMXD + ; + ;Option to Edit + ;-------------- +EDIT ; + N DIDEL,DIE,DR K DTOUT,DUOUT + ;Edit report name, title and PXRMSEL (patient sample) + S DIE=810.1,DA=$P(PXRMTMP,U),DR=".01T;1.9;1.2",DIDEL=810.1 + D ^DIE I $D(Y) S DUOUT=1 Q + ;Check if template has been deleted + I '$D(DA) Q + ;Get updated value of PXRMXSEL + N PXRMSEL,PXRMFUT S PXRMSEL=X + ;Needed for 1.6 validation - Prior/Future or Current/Admissions + ;N PXRMINP + ;Further fields depend on value in PXRMXSEL + I PXRMSEL="I" S DR="6T~R",PXRMINP=0 + I PXRMSEL="R" S DR="14T",PXRMINP=0 + I PXRMSEL="L" D Q:$D(DUOUT) + .;Get location report type + .S DR="3T;1.5R" D ^DIE I $D(Y) S DUOUT=1 Q + .N PXRMLCSC S PXRMLCSC=X,DR="",PXRMINP=0 + .;All location reports - prompt for prior/future/current/admissions + .I PXRMLCSC="HAI" S PXRMINP=1,DR="1.6" Q + .I PXRMLCSC="HA" S PXRMINP=0,DR="1.6" + .I PXRMLCSC="CA" S PXRMINP=0,DR="1.6" + .D ^DIE I $D(Y) S DUOUT=1 Q + .S PXRMFUT=X,DR="" + .;Selected Location/Stop Code/Clinic Group fields + .I PXRMLCSC="HS" D Q:$D(DUOUT) + ..S DR="10T~R" + ..D ^DIE I $D(Y) S DUOUT=1 Q + ..;Determine if locations input are all wards + ..S PXRMINP=$$INP^PXRMXAP(PXRMLCSC,.PXRMLOCN) + ..;Select Prior/Future or Current Inpatient/Admissions + ..S DR="1.6" + ..D ^DIE I $D(Y) S DUOUT=1 Q + ..S PXRMFUT=X,DR="" + .;Clinic Stop input and prior/future + .I PXRMLCSC="CS" S PXRMINP=0,DR="11T~R;1.6" D I $G(DUOUT)=1 Q + ..D ^DIE I $D(Y) S DUOUT=1 Q + ..S PXRMFUT=X,DR="" + .;Clinic Group input and prior/future + .I PXRMLCSC="GS" S PXRMINP=0,DR="12T~R;1.6" D I $G(DUOUT)=1 Q + ..D ^DIE I $D(Y) S DUOUT=1 Q + ..S PXRMFUT=X,DR="" + .;Service categories (except for inpatient reports) + .I PXRMINP=0,PXRMFUT'="F",PXRMFUT'="C" S DR=DR_";9T~R" + ;OE/RR teams + I PXRMSEL="O" S DR="7T~R" + ;PCMM Provider and Primary care/All + I PXRMSEL="P" S DR="4T~R;1.3" + ;PCMM teams + I PXRMSEL="T" S DR="3T~R;8T~R" + ;Report type (detail or summary) + S DR=DR_";1.4" + ;Reminder Categories + I $D(^PXRMPT(810.1,DA,12,0))>0 D + .N IEN,CNT,NODE + .S CNT=0,IEN=0 F S IEN=$O(^PXRMPT(810.1,DA,12,IEN)) Q:IEN'>0 D + ..S CNT=CNT+1,NODE=$G(^PXRMPT(810.1,DA,12,IEN,0)) + ..S PXRMTCAT(DA,CNT)=$P(NODE,U)_U_$P($G(^PXRMD(811.7,$P(NODE,U),0)),U)_U_$P(NODE,U,2) + S DR=DR_";13T" + ;Reminders + I $D(^PXRMPT(810.1,DA,1,0))>0 D + .N IEN,CNT,NODE,REMNODE + .S CNT=0,IEN=0 F S IEN=$O(^PXRMPT(810.1,DA,1,IEN)) Q:IEN'>0 D + ..S CNT=CNT+1,NODE=$G(^PXRMPT(810.1,DA,1,IEN,0)) + ..S REMNODE=$G(^PXD(811.9,$P(NODE,U),0)) + ..S PXRMTREM(DA,CNT)=$P(NODE,U)_U_$P(REMNODE,U)_U_$P(NODE,U,2)_U_$P($G(REMNODE),U,3) + S DR=DR_";2T" + ; + ;Strip of any leading semi-colons + I $E(DR)=";" S DR=$P(DR,";",2,99) + ; + D ^DIE I $D(Y) S DUOUT=1 Q + ; + ;If all reminders have been deleted from the template disallow save + I +$P($G(^PXRMPT(810.1,DA,1,0)),U,4)=0 D + .;Check categories also + .I +$P($G(^PXRMPT(810.1,DA,12,0)),U,4)>0 D Q + .. N CAT,CATIEN + .. S CAT=0 F S CAT=$O(^PXRMPT(810.1,DA,12,CAT)) Q:+CAT'>0 D + ... S CATIEN=$P($G(^PXRMPT(810.1,DA,12,CAT,0)),U) + ... I +$P($G(^PXRMD(811.7,CATIEN,2,0)),U,4)<1 W !!,"** WARNING **",!,"Reminder Category "_$P($G(^PXRMD(811.7,CATIEN,0)),U)_" does not have any reminders assigned to it" + .S DUOUT=1 + .W !!,"No reminders defined" + Q + ; diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMXTF.m b/r/CLINICAL_REMINDERS-PXRM/PXRMXTF.m index 24a27535..4fdfd2eb 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMXTF.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMXTF.m @@ -1,150 +1,150 @@ -PXRMXTF ; SLC/PJH - Reminder Reports Template Filing ;05/02/2002 - ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123 - ; - ; Called from PXRMXTA - ; - ;Select template name and file - ;----------------------------- -START N NEWIEN,NEWTEMP,OLDTEMP - ;Save original name - S OLDTEMP=$P(PXRMTMP,U,2) - ;Reset PXRMTMP in case the template name field has been edited - S $P(PXRMTMP,U,2)=$P($G(^PXRMPT(810.1,$P(PXRMTMP,U,1),0)),U) - ;Redisplay changes made - D REDISP - ;Prompt template name - D NAME - ;Rollback ^DIE changes if edit is abandoned - I $D(DTOUT)!$D(DUOUT) D ROLL Q - ; - I NEWTEMP=$P(PXRMTMP,U,2),NEWTEMP=OLDTEMP D MESS(1,NEWTEMP) - I NEWTEMP=$P(PXRMTMP,U,2),NEWTEMP'=OLDTEMP D MESS(3,OLDTEMP,NEWTEMP) - ; - ;If a new template ID is selected then create a new template - I NEWTEMP'=$P(PXRMTMP,U,2) D I $D(MSG) S DTOUT=1 Q - .;Create template header - .D HEADER - .;Save edited template detail to new template name - .D REFILE Q:$D(MSG) - .;Save Message - .D MESS(2,NEWTEMP) - .;File original arrays to old template (rollback ^DIE changes) - .D FILE^PXRMXTU(PXRMTMP,1,1) - .;Set selected template ID - .S PXRMTMP=NEWIEN - ; - ;Reload arrays - D LOAD^PXRMXT I $D(MSG) S DTOUT=1 Q -EXIT Q - ; - ;Rename edited template - ;---------------------- -NAME N X,Y,TEXT,DIR - K DIROUT,DIRUT,DTOUT,DUOUT - S DIR(0)="FAU"_U_"3:30"_U_"K:'$$OK^PXRMXTF(X) X" - S DIR("A")="STORE REPORT LOGIC IN TEMPLATE NAME: " - S DIR("B")=$P(PXRMTMP,U,2) - S DIR("?")="Enter template name. For detailed help type ??" - S DIR("??")=U_"D HELP^PXRMXTF(1)" - W ! - D ^DIR K DIR - I $D(DIROUT) S DTOUT=1 - I $D(DTOUT)!($D(DUOUT)) Q - S NEWTEMP=Y - Q - ; - ;Check if the template name is in use - ;------------------------------------ -OK(NAME) ; - ;Original template name may be used - I X=DIR("B") Q 1 - I $E(DIR("B"),1,$L(X))=X Q 0 - ;Else check if template name defined - I '$D(^PXRMPT(810.1,"B",NAME)) Q 1 - Q 0 - ; - ;Create Template header and get IEN - ;---------------------------------- -HEADER N DATA,IEN,NUM - ;Otherwise create a new entry - S DATA=$G(^PXRMPT(810.1,0)),IEN=$P(DATA,U,3),NUM=$P(DATA,U,4) - F S IEN=IEN+1 Q:'$D(^PXRMPT(IEN,0)) - S ^PXRMPT(810.1,IEN,0)=NEWTEMP - S ^PXRMPT(810.1,"B",NEWTEMP,IEN)="" - S $P(^PXRMPT(810.1,0),U,3)=IEN,$P(^PXRMPT(810.1,0),U,4)=NUM+1 - S NEWIEN=IEN_U_NEWTEMP - Q - ; - ;Redisplay edited template details - ;--------------------------------------------- -REDISP N PXRMLCSC,PXRMPRIM,PXRMREP,PXRMSEL,PXRMTYP,PXRMFD,RUN,PXRMCS - N PXRMREM,PXRMFAC,PXRMPRV,PXRMPAT,PXRMOTM,PXRMSCAT,PXRMLCHL,PXRMCS - N PXRMLIST,TITLE - ; - ;Load temporary arrays from edited template PXRMTMP - D LOAD^PXRMXT I $D(MSG) Q - ;Clear last run date - S RUN="" - ;Display - D ^PXRMXTD - ; - Q - ; - ;Copy edited template details to new template - ;--------------------------------------------- -REFILE N PXRMLCSC,PXRMPRIM,PXRMREP,PXRMSEL,PXRMTYP,PXRMFD,RUN,PXRMCS - N PXRMREM,PXRMFAC,PXRMPRV,PXRMPAT,PXRMOTM,PXRMSCAT,PXRMLCHL,PXRMCS - N PXRMLIST,TITLE - ; - ;Load temporary arrays from edited template PXRMTMP - D LOAD^PXRMXT I $D(MSG) Q - ;Clear last run date - S RUN="" - ;Save arrays to new ID - D FILE^PXRMXTU(NEWIEN,1,0) Q:$D(MSG) - Q - ; - ;Rollback changes (also called from PXRMXTA) - ;---------------- -ROLL ; - D FILE^PXRMXTU(PXRMTMP,1,1) - I $D(MSG) S DTOUT=1 Q - ;Changes not saved message - D MESS(0,$P(PXRMTMP,U,2)) - Q - ; - ;Filing messages - ;--------------- -MESS(MODE,INP,INP1) ; - I MODE=0 W !,"Changes to template '"_INP_"' have not been saved" Q - I MODE=1 W !,"Changes to template '"_INP_"' have been saved" - I MODE=2 W !,"A new template '"_INP_"' has been created" - I MODE=3 W !,"Template '"_INP_"' renamed as '"_INP1_"'" - I MODE=4 W !,"Template '"_INP_"' not saved" - Q - ; - ;General help text routine. Write out the text in the HTEXT array - ;---------------------------------------------------------------- -HELP(CALL) ; - N HTEXT - N DIWF,DIWL,DIWR,IC - S DIWF="C70",DIWL=0,DIWR=70 - ; - I CALL=1 D - .S HTEXT(1)="To save or rename the existing template use the default" - .S HTEXT(2)="name. To create a new template and leave the original " - .S HTEXT(3)="unchanged enter a different template name " - .S HTEXT(4)="that is not in use." - ; - 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 +PXRMXTF ; SLC/PJH - Reminder Reports Template Filing ;05/02/2002 + ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005 + ; + ; Called from PXRMXTA + ; + ;Select template name and file + ;----------------------------- +START N NEWIEN,NEWTEMP,OLDTEMP + ;Save original name + S OLDTEMP=$P(PXRMTMP,U,2) + ;Reset PXRMTMP in case the template name field has been edited + S $P(PXRMTMP,U,2)=$P($G(^PXRMPT(810.1,$P(PXRMTMP,U,1),0)),U) + ;Redisplay changes made + D REDISP + ;Prompt template name + D NAME + ;Rollback ^DIE changes if edit is abandoned + I $D(DTOUT)!$D(DUOUT) D ROLL Q + ; + I NEWTEMP=$P(PXRMTMP,U,2),NEWTEMP=OLDTEMP D MESS(1,NEWTEMP) + I NEWTEMP=$P(PXRMTMP,U,2),NEWTEMP'=OLDTEMP D MESS(3,OLDTEMP,NEWTEMP) + ; + ;If a new template ID is selected then create a new template + I NEWTEMP'=$P(PXRMTMP,U,2) D I $D(MSG) S DTOUT=1 Q + .;Create template header + .D HEADER + .;Save edited template detail to new template name + .D REFILE Q:$D(MSG) + .;Save Message + .D MESS(2,NEWTEMP) + .;File original arrays to old template (rollback ^DIE changes) + .D FILE^PXRMXTU(PXRMTMP,1,1) + .;Set selected template ID + .S PXRMTMP=NEWIEN + ; + ;Reload arrays + D LOAD^PXRMXT I $D(MSG) S DTOUT=1 Q +EXIT Q + ; + ;Rename edited template + ;---------------------- +NAME N X,Y,TEXT,DIR + K DIROUT,DIRUT,DTOUT,DUOUT + S DIR(0)="FAU"_U_"3:30"_U_"K:'$$OK^PXRMXTF(X) X" + S DIR("A")="STORE REPORT LOGIC IN TEMPLATE NAME: " + S DIR("B")=$P(PXRMTMP,U,2) + S DIR("?")="Enter template name. For detailed help type ??" + S DIR("??")=U_"D HELP^PXRMXTF(1)" + W ! + D ^DIR K DIR + I $D(DIROUT) S DTOUT=1 + I $D(DTOUT)!($D(DUOUT)) Q + S NEWTEMP=Y + Q + ; + ;Check if the template name is in use + ;------------------------------------ +OK(NAME) ; + ;Original template name may be used + I X=DIR("B") Q 1 + I $E(DIR("B"),1,$L(X))=X Q 0 + ;Else check if template name defined + I '$D(^PXRMPT(810.1,"B",NAME)) Q 1 + Q 0 + ; + ;Create Template header and get IEN + ;---------------------------------- +HEADER N DATA,IEN,NUM + ;Otherwise create a new entry + S DATA=$G(^PXRMPT(810.1,0)),IEN=$P(DATA,U,3),NUM=$P(DATA,U,4) + F S IEN=IEN+1 Q:'$D(^PXRMPT(IEN,0)) + S ^PXRMPT(810.1,IEN,0)=NEWTEMP + S ^PXRMPT(810.1,"B",NEWTEMP,IEN)="" + S $P(^PXRMPT(810.1,0),U,3)=IEN,$P(^PXRMPT(810.1,0),U,4)=NUM+1 + S NEWIEN=IEN_U_NEWTEMP + Q + ; + ;Redisplay edited template details + ;--------------------------------------------- +REDISP N PXRMLCSC,PXRMPRIM,PXRMREP,PXRMSEL,PXRMTYP,PXRMFD,RUN,PXRMCS + N PXRMREM,PXRMFAC,PXRMPRV,PXRMPAT,PXRMOTM,PXRMSCAT,PXRMLCHL,PXRMCS + N PXRMLIST,TITLE + ; + ;Load temporary arrays from edited template PXRMTMP + D LOAD^PXRMXT I $D(MSG) Q + ;Clear last run date + S RUN="" + ;Display + D ^PXRMXTD + ; + Q + ; + ;Copy edited template details to new template + ;--------------------------------------------- +REFILE N PXRMLCSC,PXRMPRIM,PXRMREP,PXRMSEL,PXRMTYP,PXRMFD,RUN,PXRMCS + N PXRMREM,PXRMFAC,PXRMPRV,PXRMPAT,PXRMOTM,PXRMSCAT,PXRMLCHL,PXRMCS + N PXRMLIST,TITLE + ; + ;Load temporary arrays from edited template PXRMTMP + D LOAD^PXRMXT I $D(MSG) Q + ;Clear last run date + S RUN="" + ;Save arrays to new ID + D FILE^PXRMXTU(NEWIEN,1,0) Q:$D(MSG) + Q + ; + ;Rollback changes (also called from PXRMXTA) + ;---------------- +ROLL ; + D FILE^PXRMXTU(PXRMTMP,1,1) + I $D(MSG) S DTOUT=1 Q + ;Changes not saved message + D MESS(0,$P(PXRMTMP,U,2)) + Q + ; + ;Filing messages + ;--------------- +MESS(MODE,INP,INP1) ; + I MODE=0 W !,"Changes to template '"_INP_"' have not been saved" Q + I MODE=1 W !,"Changes to template '"_INP_"' have been saved" + I MODE=2 W !,"A new template '"_INP_"' has been created" + I MODE=3 W !,"Template '"_INP_"' renamed as '"_INP1_"'" + I MODE=4 W !,"Template '"_INP_"' not saved" + Q + ; + ;General help text routine. Write out the text in the HTEXT array + ;---------------------------------------------------------------- +HELP(CALL) ; + N HTEXT + N DIWF,DIWL,DIWR,IC + S DIWF="C70",DIWL=0,DIWR=70 + ; + I CALL=1 D + .S HTEXT(1)="To save or rename the existing template use the default" + .S HTEXT(2)="name. To create a new template and leave the original " + .S HTEXT(3)="unchanged enter a different template name " + .S HTEXT(4)="that is not in use." + ; + 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 diff --git a/r/CLINICAL_REMINDERS-PXRM/PXRMXTU.m b/r/CLINICAL_REMINDERS-PXRM/PXRMXTU.m index 945381f6..0649b0a7 100644 --- a/r/CLINICAL_REMINDERS-PXRM/PXRMXTU.m +++ b/r/CLINICAL_REMINDERS-PXRM/PXRMXTU.m @@ -1,216 +1,216 @@ -PXRMXTU ; SLC/PJH - Reminder Reports Template Update ;11/27/2006 - ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123 - ; - ; Called from PXRMYD,PXRMXD (also at UPD from PXRMXPR/PXRMYPR) - ; - ;Option to create a new template - ;------------------------------- -START N PXRMASK,MSG D ASK(.PXRMASK) - I $G(PXRMASK)="Y" D SAVE -EXIT Q - ; - ;Ask name for new template - ;------------------------- -SAVE N X,Y,DIC,DLAYGO -SAV1 S DIC=810.1,DLAYGO=DIC,DIC(0)="QAELX" - S DIC("A")="STORE REPORT LOGIC IN TEMPLATE NAME: " - W ! - D ^DIC - I X="" W !,"A template name must be entered" G SAV1 - I X=(U_U) S DTOUT=1 - I Y=-1 S DUOUT=1 W !,"Details not saved" Q - I $D(DTOUT)!$D(DUOUT) Q - ;Check - I ($P(Y,U,3)'=1) W !,"This template name already exists" G SAV1 - ;Get template name and title - S PXRMTMP=Y,TITLE=$P($G(^PXRMPT(810.1,$P(Y,U),0)),U,2) - S $P(PXRMTMP,U,3)=TITLE - ;File details - D FILE(Y,1,0) - ;File not saved message - I $D(MSG) D Q - .N DA,DIK - .S DA=$P(Y,U),DIK="^PXRMPT(810.1," D ^DIK - .D MESS^PXRMXTF(4,$P(PXRMTMP,U,2)) - ;File saved message - D MESS^PXRMXTF(1,$P(PXRMTMP,U,2)) - Q - ; - ;File template detail - ;-------------------- -FILE(INP,UPD,CLR) ; - N CNT,FDA,FDAIEN,FNO,IC,INT,MODE,NAME,X - S FDAIEN(1)=$P(INP,U),NAME=$P(INP,U,2) - ;Save exit flags - needed for rollback - N DUOUT,DTOUT - ; - ;Update or Add - S MODE=$S(UPD:(FDAIEN(1)_","),1:"+1,") - ;Delete entries from existing template - I CLR D - .N DA S DA=0 - .F S DA=$O(^PXRMPT(810.1,FDAIEN(1),DA)) Q:'DA D - ..K ^PXRMPT(810.1,FDAIEN(1),DA) - ; - I PXRMSEL="L" S X=PXRMLCSC,PXRMLCSC=$P(PXRMLCSC,U) - ; - N MREF,XREF - D XREF^PXRMXTB - ; - ;Save single fields into FDA - F IC="NAME","PXRMLCSC","PXRMPRIM","PXRMREP","PXRMSEL","PXRMTYP","PXRMPML" D - .S FDA(810.1,MODE,XREF(IC))=$G(@IC) - F IC="PXRMFD","PXRMSCAT","RUN","TITLE" D - .S FDA(810.1,MODE,XREF(IC))=$G(@IC) - ; - I PXRMSEL="L" S PXRMLCSC=X - ; - ;Save Arrays into FDA - ; - ;Reminder Items - S CNT=1 - D SUB1(.PXRMREM,"810.12",1) - ;Save Facility codes - D SUB1(.PXRMFAC,"810.13",1) - ;Save Provider codes - D SUB1(.PXRMPRV,"810.14",1) - ;Save Patient codes - D SUB1(.PXRMPAT,"810.16",1) - ;Save OE/RR Team codes - D SUB1(.PXRMOTM,"810.17",1) - ;Save PCMM Team codes - D SUB1(.PXRMPCM,"810.18",1) - ;Save Hospital Location codes - D SUB1(.PXRMLCHL,"810.11",2) - ;Save Clinic Stop codes - D SUB1(.PXRMCS,"810.111",2) - ;Save Clinic groups - D SUB1(.PXRMCGRP,"810.112",1) - ;Save Reminder Categories - D SUB1(.PXRMRCAT,"810.113",1) - ;Save Patient lists - D SUB1(.PXRMLIST,"810.114",1) - ; - ;Update template file - D UPDATE^DIE("S","FDA","FDAIEN","MSG") - ; - I $D(MSG) D - .W !!,"Update failed, UPDATE^DIE returned the following error message:" - .S IC="MSG" - .F S IC=$Q(@IC) Q:IC="" W !,IC,"=",@IC - .W !,"Examine the above error message for the reason.",! - .H 2 - Q - ; - ;Save arrays into FDA - ;-------------------- -SUB1(OUTPUT,VAR,PIECE) ; - S IC="" - ;This is use for saving individual reminders back to the original - ;template - I VAR=810.12,$D(PXRMTREM($P(INP,U)))>0 D Q - .F S IC=$O(PXRMTREM($P(INP,U),IC)) Q:IC="" D - ..S INT=$P(PXRMTREM($P(INP,U),IC),U,PIECE),CNT=CNT+1 - ..S FDA(VAR,"+"_CNT_","_MODE,.01)=INT - ..S FDA(VAR,"+"_CNT_","_MODE,.02)=IC - ; - ;This is use for saving individual reminders category back to the - ;original template - I VAR=810.113,$D(PXRMTCAT($P(INP,U)))>0 D Q - .F S IC=$O(PXRMTCAT($P(INP,U),IC)) Q:IC="" D - ..S INT=$P(PXRMTCAT($P(INP,U),IC),U,PIECE),CNT=CNT+1 - ..S FDA(VAR,"+"_CNT_","_MODE,.01)=INT - ..S FDA(VAR,"+"_CNT_","_MODE,.02)=IC - ; - ;this is use for saving everything else to the template - F S IC=$O(OUTPUT(IC)) Q:IC="" D - .S INT=$P(OUTPUT(IC),U,PIECE),CNT=CNT+1 - .S FDA(VAR,"+"_CNT_","_MODE,.01)=INT - .;Save Display order for reminders and categories - .I (VAR=810.12)!(VAR=810.113) S FDA(VAR,"+"_CNT_","_MODE,.02)=IC - Q - ; - ;Save Service Categories into FDA - ;-------------------------------- -SUB2(FLD,VAR) ; - F IC=1:1 S INT=$E(@FLD,IC) Q:INT="" D - .S CNT=CNT+1,FDA(VAR,"+"_CNT_","_MODE,.01)=INT - Q - ; - ; - ;Option to save a new template - ;----------------------------- -ASK(YESNO) ; - N X,Y,TEXT - K DIROUT,DIRUT,DTOUT,DUOUT - S DIR(0)="YA0" - S DIR("A")="Create a new report template: " - S DIR("B")="N" - S DIR("?")="Enter Y or N. For detailed help type ??" - S DIR("??")=U_"D HELP^PXRMXTU(1)" - W ! - D ^DIR K DIR - I $D(DIROUT) S DTOUT=1 - I $D(DTOUT)!($D(DUOUT)) Q - S YESNO=$E(Y(0)) - Q - ; - ;General help text routine. Write out the text in the HTEXT array - ;---------------------------------------------------------------- -HELP(CALL) ; - N HTEXT - N DIWF,DIWL,DIWR,IC - S DIWF="C70",DIWL=0,DIWR=70 - ; - I CALL=1 D - .S HTEXT(1)="Enter 'Y' to save the reporting parameters as a report" - .S HTEXT(2)="template from which the report may be re-run in future." - ; - 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 - ; - ;Save template info to new name - ;------------------------------ -COPY N PXRMLCSC,PXRMPRIM,PRRMREP,PXRMSEL,PXRMTYP,PXRMFD,RUN,PXRMCS - N PXRMREM,PXRMFAC,PXRMPRV,PXRMPAT,PXRMOTM,PXRMSCAT,PXRMLCHL,PXRMCS - ;Load arrays from original template PXRMTMP - D LOAD^PXRMXT I $D(MSG) Q - ;Clear last run date - S RUN="" - ;Save arrays to new ID - D FILE(NEWTEMP,0) - Q - ; - ;Update print template last run date (called from PXRMYPR/PXRMXPR) - ;----------------------------------------------------------------- -UPD S ^PXRMPT(810.1,$P(PXRMTMP,U),7)=PXRMXST - Q - ; - ;Called as an input transform for 810.1/NAME - ;------------------------------------------- -NAME Q:'$D(X) Q:X="" Q:$G(PXRMTYP)="" - ;Disallow duplicate template names - Q:'$D(^PXRMPT(810.1,"B",X)) - W !,"This template name already exists" K X - Q - ; - ;Called as an input transform for 810.1/PXRMFD - ;--------------------------------------------- -INP Q:'$D(X) Q:X="" - ;If inpatient wards prompt only for Admissions/Current Patients - I $G(PXRMINP),"FP"[X D - .W !,"Select either Inpatient Admissions or Current Inpatients" K X - ;If other locations prompt only for Prior visits/Future Appts - I '$G(PXRMINP),"AC"[X D - .W !,"Select either Future Appointments or Prior Visits" K X - Q +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) + ; + ;Option to create a new template + ;------------------------------- +START N PXRMASK,MSG D ASK(.PXRMASK) + I $G(PXRMASK)="Y" D SAVE +EXIT Q + ; + ;Ask name for new template + ;------------------------- +SAVE N X,Y,DIC,DLAYGO +SAV1 S DIC=810.1,DLAYGO=DIC,DIC(0)="QAELX" + S DIC("A")="STORE REPORT LOGIC IN TEMPLATE NAME: " + W ! + D ^DIC + I X="" W !,"A template name must be entered" G SAV1 + I X=(U_U) S DTOUT=1 + I Y=-1 S DUOUT=1 W !,"Details not saved" Q + I $D(DTOUT)!$D(DUOUT) Q + ;Check + I ($P(Y,U,3)'=1) W !,"This template name already exists" G SAV1 + ;Get template name and title + S PXRMTMP=Y,TITLE=$P($G(^PXRMPT(810.1,$P(Y,U),0)),U,2) + S $P(PXRMTMP,U,3)=TITLE + ;File details + D FILE(Y,1,0) + ;File not saved message + I $D(MSG) D Q + .N DA,DIK + .S DA=$P(Y,U),DIK="^PXRMPT(810.1," D ^DIK + .D MESS^PXRMXTF(4,$P(PXRMTMP,U,2)) + ;File saved message + D MESS^PXRMXTF(1,$P(PXRMTMP,U,2)) + Q + ; + ;File template detail + ;-------------------- +FILE(INP,UPD,CLR) ; + N CNT,FDA,FDAIEN,FNO,IC,INT,MODE,NAME,X + S FDAIEN(1)=$P(INP,U),NAME=$P(INP,U,2) + ;Save exit flags - needed for rollback + N DUOUT,DTOUT + ; + ;Update or Add + S MODE=$S(UPD:(FDAIEN(1)_","),1:"+1,") + ;Delete entries from existing template + I CLR D + .N DA S DA=0 + .F S DA=$O(^PXRMPT(810.1,FDAIEN(1),DA)) Q:'DA D + ..K ^PXRMPT(810.1,FDAIEN(1),DA) + ; + I PXRMSEL="L" S X=PXRMLCSC,PXRMLCSC=$P(PXRMLCSC,U) + ; + N MREF,XREF + D XREF^PXRMXTB + ; + ;Save single fields into FDA + 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 + .S FDA(810.1,MODE,XREF(IC))=$G(@IC) + ; + I PXRMSEL="L" S PXRMLCSC=X + ; + ;Save Arrays into FDA + ; + ;Reminder Items + S CNT=1 + D SUB1(.PXRMREM,"810.12",1) + ;Save Facility codes + D SUB1(.PXRMFAC,"810.13",1) + ;Save Provider codes + D SUB1(.PXRMPRV,"810.14",1) + ;Save Patient codes + D SUB1(.PXRMPAT,"810.16",1) + ;Save OE/RR Team codes + D SUB1(.PXRMOTM,"810.17",1) + ;Save PCMM Team codes + D SUB1(.PXRMPCM,"810.18",1) + ;Save Hospital Location codes + D SUB1(.PXRMLCHL,"810.11",2) + ;Save Clinic Stop codes + D SUB1(.PXRMCS,"810.111",2) + ;Save Clinic groups + D SUB1(.PXRMCGRP,"810.112",1) + ;Save Reminder Categories + D SUB1(.PXRMRCAT,"810.113",1) + ;Save Patient lists + D SUB1(.PXRMLIST,"810.114",1) + ; + ;Update template file + D UPDATE^DIE("S","FDA","FDAIEN","MSG") + ; + I $D(MSG) D + .W !!,"Update failed, UPDATE^DIE returned the following error message:" + .S IC="MSG" + .F S IC=$Q(@IC) Q:IC="" W !,IC,"=",@IC + .W !,"Examine the above error message for the reason.",! + .H 2 + Q + ; + ;Save arrays into FDA + ;-------------------- +SUB1(OUTPUT,VAR,PIECE) ; + S IC="" + ;This is use for saving individual reminders back to the original + ;template + I VAR=810.12,$D(PXRMTREM($P(INP,U)))>0 D Q + .F S IC=$O(PXRMTREM($P(INP,U),IC)) Q:IC="" D + ..S INT=$P(PXRMTREM($P(INP,U),IC),U,PIECE),CNT=CNT+1 + ..S FDA(VAR,"+"_CNT_","_MODE,.01)=INT + ..S FDA(VAR,"+"_CNT_","_MODE,.02)=IC + ; + ;This is use for saving individual reminders category back to the + ;original template + I VAR=810.113,$D(PXRMTCAT($P(INP,U)))>0 D Q + .F S IC=$O(PXRMTCAT($P(INP,U),IC)) Q:IC="" D + ..S INT=$P(PXRMTCAT($P(INP,U),IC),U,PIECE),CNT=CNT+1 + ..S FDA(VAR,"+"_CNT_","_MODE,.01)=INT + ..S FDA(VAR,"+"_CNT_","_MODE,.02)=IC + ; + ;this is use for saving everything else to the template + F S IC=$O(OUTPUT(IC)) Q:IC="" D + .S INT=$P(OUTPUT(IC),U,PIECE),CNT=CNT+1 + .S FDA(VAR,"+"_CNT_","_MODE,.01)=INT + .;Save Display order for reminders and categories + .I (VAR=810.12)!(VAR=810.113) S FDA(VAR,"+"_CNT_","_MODE,.02)=IC + Q + ; + ;Save Service Categories into FDA + ;-------------------------------- +SUB2(FLD,VAR) ; + F IC=1:1 S INT=$E(@FLD,IC) Q:INT="" D + .S CNT=CNT+1,FDA(VAR,"+"_CNT_","_MODE,.01)=INT + Q + ; + ; + ;Option to save a new template + ;----------------------------- +ASK(YESNO) ; + N X,Y,TEXT + K DIROUT,DIRUT,DTOUT,DUOUT + S DIR(0)="YA0" + S DIR("A")="Create a new report template: " + S DIR("B")="N" + S DIR("?")="Enter Y or N. For detailed help type ??" + S DIR("??")=U_"D HELP^PXRMXTU(1)" + W ! + D ^DIR K DIR + I $D(DIROUT) S DTOUT=1 + I $D(DTOUT)!($D(DUOUT)) Q + S YESNO=$E(Y(0)) + Q + ; + ;General help text routine. Write out the text in the HTEXT array + ;---------------------------------------------------------------- +HELP(CALL) ; + N HTEXT + N DIWF,DIWL,DIWR,IC + S DIWF="C70",DIWL=0,DIWR=70 + ; + I CALL=1 D + .S HTEXT(1)="Enter 'Y' to save the reporting parameters as a report" + .S HTEXT(2)="template from which the report may be re-run in future." + ; + 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 + ; + ;Save template info to new name + ;------------------------------ +COPY N PXRMLCSC,PXRMPRIM,PRRMREP,PXRMSEL,PXRMTYP,PXRMFD,RUN,PXRMCS + N PXRMREM,PXRMFAC,PXRMPRV,PXRMPAT,PXRMOTM,PXRMSCAT,PXRMLCHL,PXRMCS + ;Load arrays from original template PXRMTMP + D LOAD^PXRMXT I $D(MSG) Q + ;Clear last run date + S RUN="" + ;Save arrays to new ID + D FILE(NEWTEMP,0) + Q + ; + ;Update print template last run date (called from PXRMYPR/PXRMXPR) + ;----------------------------------------------------------------- +UPD S ^PXRMPT(810.1,$P(PXRMTMP,U),7)=PXRMXST + Q + ; + ;Called as an input transform for 810.1/NAME + ;------------------------------------------- +NAME Q:'$D(X) Q:X="" Q:$G(PXRMTYP)="" + ;Disallow duplicate template names + Q:'$D(^PXRMPT(810.1,"B",X)) + W !,"This template name already exists" K X + Q + ; + ;Called as an input transform for 810.1/PXRMFD + ;--------------------------------------------- +INP Q:'$D(X) Q:X="" + ;If inpatient wards prompt only for Admissions/Current Patients + I $G(PXRMINP),"FP"[X D + .W !,"Select either Inpatient Admissions or Current Inpatients" K X + ;If other locations prompt only for Prior visits/Future Appts + I '$G(PXRMINP),"AC"[X D + .W !,"Select either Future Appointments or Prior Visits" K X + Q diff --git a/r/CMOP-PSX/PSXBLD1.m b/r/CMOP-PSX/PSXBLD1.m index 45476cb0..404882a5 100644 --- a/r/CMOP-PSX/PSXBLD1.m +++ b/r/CMOP-PSX/PSXBLD1.m @@ -1,103 +1,103 @@ -PSXBLD1 ;BIR/BAB,HTW,WPB-Document Data for Transmission ;10/15/98 10:38 AM - ;;2.0;CMOP;**3,18,19,42,41,49,57,64**;11 Apr 97;Build 1 - ;Reference to ^PSRX( supported by DBIA #1977 - ;Reference to ^PSDRUG( supported by DBIA #1983 - ;Reference to ^PS(55, supported by DBIA #2228 - ;Reference to ^PS(59.7, supported by DBIA #694 - ;Reference to ^PS(59, supported by DBIA #1976 - ;Reference to PROD2^PSNAPIS supported by DBIA #2531 -MRX ;Multi rx - G:'$P(PSOPAR,"^",18) SUS - F ZZ=0:0 S ZZ=$O(^PS(55,DFN,"P",ZZ)) Q:'ZZ S NBR=0 D RZX -BUILD ; - F PSA=0:0 S PSA=$O(RX(PSA)) Q:'PSA D SCRNEW - K NAME,REFILL,PSDT2,NBR,PSRX,PSA,TN,AMC,PSRFL,X1,X2,PSRXX,RXNUM,ZZ - G SUS -SCRNEW ; - S IEN50=+$P(^PSRX(PSA,0),U,6),NAME=$P(^PSDRUG(IEN50,0),U) - I '$D(^PSDRUG(IEN50,"ND")) G S1 - S IENDF=$P($G(^PSDRUG(IEN50,"ND")),U),ZD1=$P($G(^("ND")),U,3) - I $G(IENDF),($G(ZD1)) S ZX=$$PROD2^PSNAPIS(IENDF,ZD1),ZNDF=$P($G(ZX),"^") -S1 S ZPRT=$S($G(ZNDF):ZNDF,1:NAME) K ZNDF,IENDF,NAME,IEN50,ZD1 - S ZPRT=$E(ZPRT,1,30) - S REFILL=$P(RX(PSA),"^",2) - S PSDT2=$P(RX(PSA),"^",1),PSDT2=PSDT2+17000000 - S RXNUM=$P($G(^PSRX(PSA,0)),"^") - S NBR=NBR+1,PSXORD("M",NBR)="NTE|5||"_RXNUM_"\F\"_ZPRT_"\F\"_REFILL_"\F\"_PSDT2_$S($P(PSOPAR,"^",19):"\F\"_PSOINST_"-"_PSA,1:"") - Q -REFILL F AMC=0:0 S AMC=$O(^PSRX(PSRXX,1,AMC)) Q:'AMC S PSRFL=PSRFL-1 - I PSRFL>0 S X1=DT,X2=$P(^PSRX(PSRXX,0),"^",8)-10 D C^%DTC I X'<$P(^(2),"^",6) S PSRFL=0 - Q -RZX S PSRXX=+^PS(55,DFN,"P",ZZ,0) I $D(^PSRX(PSRXX,0)) S PSRFL=$P(^(0),"^",9) D:$D(^(1))&PSRFL REFILL I PSRFL>0,$P(^PSRX(PSRXX,"STA"),"^",1)<10,13456'[$E($P(^("STA"),"^",1)),$P(^(2),"^",6)>DT S RX(PSRXX)=$P(^(2),"^",6)_"^"_PSRFL - Q -SUS ;Susp Notif-(PSXDTRG-last date transmitted) - Q:'$G(DFN)!('$G(PSXDTRG)) - S CT=1 - F I=PSXDTRG:0 S I=$O(^PS(55,DFN,"P","A",I)) Q:'I D - .F J=0:0 S J=$O(^PS(55,DFN,"P","A",I,J)) Q:'J S JJ=J D:$D(JJ) S CT=CT+1 - ..S NODE=$G(^PSRX(JJ,0)) Q:NODE']"" - ..S STATUS=+$P(^PSRX(JJ,"STA"),"^",1) Q:STATUS'=5!(STATUS>10) - ..Q:$D(^PSX(550.2,PSXBAT,15,"B",JJ)) ;built in PSXRPPL PSX*2*42 - ..S ERX=$P(NODE,U) - ..S IEN50=$P(NODE,"^",6),NAME=$P(^PSDRUG(IEN50,0),U) - ..I '$D(^PSDRUG(IEN50,"ND")) G S2 - ..S IENDF=$P($G(^PSDRUG(IEN50,"ND")),U),ZD1=$P($G(^("ND")),U,3) - ..I $G(IENDF),($G(ZD1)) S ZX=$$PROD2^PSNAPIS(IENDF,ZD1),ZNDF=$P($G(ZX),"^") -S2 ..S ZPRT=$S($G(ZNDF):ZNDF,1:NAME) - ..S ZPRT=$E(ZPRT,1,30) - ..S PSXORD("E",CT)="NTE|6||"_ERX_"\F\"_ZPRT - ..K NODE,STATUS,ERX,IEN50,IENDF,ZD1,ZNDF,ZPRT,NAME,ZX - K I,J,NODE,STATUS,JJ,ZPRT,NAME,IENDF,IEN50,CT,RX - Q -DIV ;NTE|1||Site #\S\Div Name\S\Facility #\F\Street Add 1\S\Street Add 2\S\City\S\State Abbrev\S\Zip Code\F\Area Code & Phone # - S PSXERFLG=0,PSXER=3 - S TNODE=$G(^PS(59,PSOSITE,0)) - ;Set site address to refill div if selected in system parameters - I $P($G(^PS(59.7,1,40.1)),"^",4) S REFDIV=$P(^(40.1),"^",4) D - .S TNODE1=$G(^PS(59,REFDIV,0)),TNODE=TNODE1 K TNODE1 - S PSXFAC=$P($G(PSXSYS),U,2) - S STATE=$P(TNODE,"^",8),SITE=$P(TNODE,U,6) S (TEMP,Y)=TNODE - S:STATE="" PSXER=PSXER_"^"_1,PSXERFLG=1 - S:SITE="" PSXER=PSXER_"^"_2,PSXERFLG=1 - S:$P(TNODE,U,1)="" PSXER=PSXER_"^"_3,PSXERFLG=1 - S:$P(TNODE,U,2)="" PSXER=PSXER_"^"_4,PSXERFLG=1 - S:$P(TNODE,U,7)="" PSXER=PSXER_"^"_5,PSXERFLG=1 - S:$P(TNODE,U,5)="" PSXER=PSXER_"^"_6,PSXERFLG=1 - S:$P(TNODE,U,3)="" PSXER=PSXER_"^"_7,PSXERFLG=1 - S:$P(TNODE,U,4)="" PSXER=PSXER_"^"_8,PSXERFLG=1 - ;VMP OIFO BAY PINES;ELR;PSX*2*57 SET PSXERFLG=0 NEXT LINE AND LINE AFTER THAT - I PSXERFLG=1 D ER1^PSXERR S PSXERFLG=0,PSXDIVER=1 Q - Q:$G(PSXPRECK)=1 - S SZIP=$P(TNODE,U,5) I $L(SZIP)>5 S SZIP=$E(SZIP,1,5)_"-"_$E(SZIP,6,9) - S PSXORD("A")="NTE|1||"_SITE_"\S\"_$P(TNODE,U,1)_"\S\"_PSXFAC_"\F\"_$P(TNODE,U,2)_"\S\\S\"_$P(TNODE,U,7)_"\S\"_$P(^DIC(5,STATE,0),U,2)_"\S\"_SZIP_"\F\"_"("_$P(TNODE,U,3)_") "_$P(TNODE,U,4) - K SZIP -ORD ; - S DIWL=1,DIWR=45,DIWF="C45" - F NODE=6,7,4 K ^UTILITY($J,"W") S (RECL,REC)=0 F S REC=$O(^PS(59,PSOSITE,NODE,REC)) Q:REC'>0 S X=^(REC,0),NODE=NODE D - . I REC'>7 S Y=X D STRIP^PSXBLD S X=Y D ^DIWP,SET I 1 - . E S WARN(NODE)=REC - D:$D(WARN) WARN - K DIWF,DIWL,DIWR,I,NODE,STATE,SITE,TNODE,NUM,REC,Y,Y,X,Z,^UTILITY($J,"W") - Q -WARN ;send msg - S XMSUB=">>WARNING<< CMOP Pharmacy Site Prescription Instructions" - ;N TXT,XT - S XT(6)="NARRATIVE REFILLABLE RX" - S XT(7)="NARRATIVE NON REFILLABLE RX" - S XT(4)="NARRATIVE FOR COPAY DOCUMENT" - S TXT(1)="The following Pharmacy Site instruction(s) exceed seven lines." - S TXT(2)="This exceeds CMOP limits." - S TXT(3)="Lines beyond seven are not being sent to the CMOP." - S TXT(4)=" ",TXT(5)="Pharmacy Site: "_$$GET1^DIQ(59,PSOSITE,.01),L=5 - F NODE=6,7,4 I $DATA(WARN(NODE)) S L=L+1,TXT(L)=XT(NODE)_" "_WARN(NODE)_" lines" - S XMTEXT="TXT(" - D GRP1^PSXNOTE - S XMY(DUZ)="" - D ^XMD - Q -SET ; - K PSXORDD S NUM=0 - F S NUM=$O(^UTILITY($J,"W",1,NUM)) Q:NUM'>0 S PSXORDD(NUM)=$G(^UTILITY($J,"W",1,NUM,0)) S PSXORDD(NUM)=$S(NODE=4:"NTE|4||"_PSXORDD(NUM),NODE=6:"NTE|2||"_PSXORDD(NUM),NODE=7:"NTE|3||"_PSXORDD(NUM),1:0) - ;F CNT=1:2 S CNT=$O(PSXORDD(CNT)) Q:CNT="" S XX=$L(PSXORDD(CNT)),PSXORDD(CNT-1)=PSXORDD(CNT-1)_"\R\"_$E(PSXORDD(CNT),8,XX) K PSXORDD(CNT) - S %X="PSXORDD(",%Y=$S(NODE=4:"PSXORD(""D"",",NODE=6:"PSXORD(""B"",",NODE=7:"PSXORD(""C"",",1:0) D %XY^%RCR K %X,%Y,TEMP - Q +PSXBLD1 ;BIR/BAB,HTW,WPB-Document Data for Transmission ;10/15/98 10:38 AM + ;;2.0;CMOP;**3,18,19,42,41,49,57**;11 Apr 97 + ;Reference to ^PSRX( supported by DBIA #1977 + ;Reference to ^PSDRUG( supported by DBIA #1983 + ;Reference to ^PS(55, supported by DBIA #2228 + ;Reference to ^PS(59.7, supported by DBIA #694 + ;Reference to ^PS(59, supported by DBIA #1976 + ;Reference to PROD2^PSNAPIS supported by DBIA #2531 +MRX ;Multi rx + G:'$P(PSOPAR,"^",18) SUS + F ZZ=0:0 S ZZ=$O(^PS(55,DFN,"P",ZZ)) Q:'ZZ S NBR=0 D RZX +BUILD ; + F PSA=0:0 S PSA=$O(RX(PSA)) Q:'PSA D SCRNEW + K NAME,REFILL,PSDT2,NBR,PSRX,PSA,TN,AMC,PSRFL,X1,X2,PSRXX,RXNUM,ZZ + G SUS +SCRNEW ; + S IEN50=+$P(^PSRX(PSA,0),U,6),NAME=$P(^PSDRUG(IEN50,0),U) + I '$D(^PSDRUG(IEN50,"ND")) G S1 + S IENDF=$P($G(^PSDRUG(IEN50,"ND")),U),ZD1=$P($G(^("ND")),U,3) + I $G(IENDF),($G(ZD1)) S ZX=$$PROD2^PSNAPIS(IENDF,ZD1),ZNDF=$P($G(ZX),"^") +S1 S ZPRT=$S($G(ZNDF):ZNDF,1:NAME) K ZNDF,IENDF,NAME,IEN50,ZD1 + S ZPRT=$E(ZPRT,1,30) + S REFILL=$P(RX(PSA),"^",2) + S PSDT2=$P(RX(PSA),"^",1),PSDT2=PSDT2+17000000 + S RXNUM=$P($G(^PSRX(PSA,0)),"^") + S NBR=NBR+1,PSXORD("M",NBR)="NTE|5||"_RXNUM_"\F\"_ZPRT_"\F\"_REFILL_"\F\"_PSDT2_$S($P(PSOPAR,"^",19):"\F\"_PSOINST_"-"_PSA,1:"") + Q +REFILL F AMC=0:0 S AMC=$O(^PSRX(PSRXX,1,AMC)) Q:'AMC S PSRFL=PSRFL-1 + I PSRFL>0 S X1=DT,X2=$P(^PSRX(PSRXX,0),"^",8)-10 D C^%DTC I X'<$P(^(2),"^",6) S PSRFL=0 + Q +RZX S PSRXX=+^PS(55,DFN,"P",ZZ,0) I $D(^PSRX(PSRXX,0)) S PSRFL=$P(^(0),"^",9) D:$D(^(1))&PSRFL REFILL I PSRFL>0,$P(^PSRX(PSRXX,"STA"),"^",1)<10,13456'[$E($P(^("STA"),"^",1)),$P(^(2),"^",6)>DT S RX(PSRXX)=$P(^(2),"^",6)_"^"_PSRFL + Q +SUS ;Susp Notif-(PSXDTRG-last date transmitted) + Q:'$G(DFN)!('$G(PSXDTRG)) + S CT=1 + F I=PSXDTRG:0 S I=$O(^PS(55,DFN,"P","A",I)) Q:'I D + .F J=0:0 S J=$O(^PS(55,DFN,"P","A",I,J)) Q:'J S JJ=J D:$D(JJ) S CT=CT+1 + ..S NODE=$G(^PSRX(JJ,0)) Q:NODE']"" + ..S STATUS=+$P(^PSRX(JJ,"STA"),"^",1) Q:STATUS'=5!(STATUS>10) + ..Q:$D(^PSX(550.2,PSXBAT,15,"B",JJ)) ;built in PSXRPPL PSX*2*42 + ..S ERX=$P(NODE,U) + ..S IEN50=$P(NODE,"^",6),NAME=$P(^PSDRUG(IEN50,0),U) + ..I '$D(^PSDRUG(IEN50,"ND")) G S2 + ..S IENDF=$P($G(^PSDRUG(IEN50,"ND")),U),ZD1=$P($G(^("ND")),U,3) + ..I $G(IENDF),($G(ZD1)) S ZX=$$PROD2^PSNAPIS(IENDF,ZD1),ZNDF=$P($G(ZX),"^") +S2 ..S ZPRT=$S($G(ZNDF):ZNDF,1:NAME) + ..S ZPRT=$E(ZPRT,1,30) + ..S PSXORD("E",CT)="NTE|6||"_ERX_"\F\"_ZPRT + ..K NODE,STATUS,ERX,IEN50,IENDF,ZD1,ZNDF,ZPRT,NAME,ZX + K I,J,NODE,STATUS,JJ,ZPRT,NAME,IENDF,IEN50,CT,RX + Q +DIV ;NTE|1||Site #\S\Div Name\S\Facility #\F\Street Add 1\S\Street Add 2\S\City\S\State Abbrev\S\Zip Code\F\Area Code & Phone # + S PSXERFLG=0,PSXER=3 + S TNODE=$G(^PS(59,PSOSITE,0)) + ;Set site address to refill div if selected in system parameters + I $P($G(^PS(59.7,1,40.1)),"^",4) S REFDIV=$P(^(40.1),"^",4) D + .S TNODE1=$G(^PS(59,REFDIV,0)),TNODE=TNODE1 K TNODE1 + S PSXFAC=$P($G(PSXSYS),U,2) + S STATE=$P(TNODE,"^",8),SITE=$P(TNODE,U,6) S (TEMP,Y)=TNODE + S:STATE="" PSXER=PSXER_"^"_1,PSXERFLG=1 + S:SITE="" PSXER=PSXER_"^"_2,PSXERFLG=1 + S:$P(TNODE,U,1)="" PSXER=PSXER_"^"_3,PSXERFLG=1 + S:$P(TNODE,U,2)="" PSXER=PSXER_"^"_4,PSXERFLG=1 + S:$P(TNODE,U,7)="" PSXER=PSXER_"^"_5,PSXERFLG=1 + S:$P(TNODE,U,5)="" PSXER=PSXER_"^"_6,PSXERFLG=1 + S:$P(TNODE,U,3)="" PSXER=PSXER_"^"_7,PSXERFLG=1 + S:$P(TNODE,U,4)="" PSXER=PSXER_"^"_8,PSXERFLG=1 + ;VMP OIFO BAY PINES;ELR;PSX*2*57 SET PSXERFLG=0 NEXT LINE AND LINE AFTER THAT + I PSXERFLG=1 D ER1^PSXERR S PSXERFLG=0,PSXDIVER=1 Q + Q:$G(PSXPRECK)=1 + S SZIP=$P(TNODE,U,5) I $L(SZIP)>5 S SZIP=$E(SZIP,1,5)_"-"_$E(SZIP,6,9) + S PSXORD("A")="NTE|1||"_SITE_"\S\"_$P(TNODE,U,1)_"\S\"_PSXFAC_"\F\"_$P(TNODE,U,2)_"\S\\S\"_$P(TNODE,U,7)_"\S\"_$P(^DIC(5,STATE,0),U,2)_"\S\"_SZIP_"\F\"_"("_$P(TNODE,U,3)_") "_$P(TNODE,U,4) + K SZIP +ORD ; + S DIWL=1,DIWR=45,DIWF="C45" + F NODE=6,7,4 K ^UTILITY($J,"W") S (RECL,REC)=0 F S REC=$O(^PS(59,PSOSITE,NODE,REC)) Q:REC'>0 S X=^(REC,0),NODE=NODE D + . I REC'>7 S Y=X D STRIP^PSXBLD S X=Y D ^DIWP,SET I 1 + . E S WARN(NODE)=REC + D:$D(WARN) WARN + K DIWF,DIWL,DIWR,I,NODE,STATE,SITE,TNODE,NUM,REC,Y,Y,X,Z,^UTILITY($J,"W") + Q +WARN ;send msg + S XMSUB=">>WARNING<< CMOP Pharmacy Site Prescription Instructions" + ;N TXT,XT + S XT(6)="NARRATIVE REFILLABLE RX" + S XT(7)="NARRATIVE NON REFILLABLE RX" + S XT(4)="NARRATIVE FOR COPAY DOCUMENT" + S TXT(1)="The following Pharmacy Site instruction(s) exceed seven lines." + S TXT(2)="This exceeds CMOP limits." + S TXT(3)="Lines beyound seven are not being sent to the CMOP." + S TXT(4)=" ",TXT(5)="Pharmacy Site: "_$$GET1^DIQ(59,PSOSITE,.01),L=5 + F NODE=6,7,4 I $DATA(WARN(NODE)) S L=L+1,TXT(L)=XT(NODE)_" "_WARN(NODE)_" lines" + S XMTEXT="TXT(" + D GRP1^PSXNOTE + S XMY(DUZ)="" + D ^XMD + Q +SET ; + K PSXORDD S NUM=0 + F S NUM=$O(^UTILITY($J,"W",1,NUM)) Q:NUM'>0 S PSXORDD(NUM)=$G(^UTILITY($J,"W",1,NUM,0)) S PSXORDD(NUM)=$S(NODE=4:"NTE|4||"_PSXORDD(NUM),NODE=6:"NTE|2||"_PSXORDD(NUM),NODE=7:"NTE|3||"_PSXORDD(NUM),1:0) + ;F CNT=1:2 S CNT=$O(PSXORDD(CNT)) Q:CNT="" S XX=$L(PSXORDD(CNT)),PSXORDD(CNT-1)=PSXORDD(CNT-1)_"\R\"_$E(PSXORDD(CNT),8,XX) K PSXORDD(CNT) + S %X="PSXORDD(",%Y=$S(NODE=4:"PSXORD(""D"",",NODE=6:"PSXORD(""B"",",NODE=7:"PSXORD(""C"",",1:0) D %XY^%RCR K %X,%Y,TEMP + Q diff --git a/r/CMOP-PSX/PSXMISC1.m b/r/CMOP-PSX/PSXMISC1.m index 5b152c8c..01418c67 100644 --- a/r/CMOP-PSX/PSXMISC1.m +++ b/r/CMOP-PSX/PSXMISC1.m @@ -1,146 +1,145 @@ -PSXMISC1 ;BIR/WPB,BAB-Transmission Data Validation ;MAR 1,2002@13:13:34 - ;;2.0;CMOP;**3,18,23,28,30,42,41,52,54,58,64**;11 Apr 97;Build 1 - ;Reference to ^PSDRUG( supported by DBIA #1983 - ;Reference to ^PS(52.5, supported by DBIA #1978 - ;Reference to ^PSRX( supported by DBIA #1977 - ;Reference to ^PS(55, supported by DBIA #2228 - ;Reference to PROD2^PSNAPIS supported by DBIA #2531 - ;Reference to ^PSSLOCK supported by DBIA #2789 - ;Reference to CHKRX^PSOBAI supported by DBIA #4910 -CHKDATA ;checks the data elements in PSRX before putting the rx in 550.2 - Q:'$D(^PS(52.5,REC,0)) - K DRUGCHK,PSXRXERR,PSXDGST,WARNS - S (RXN,PSXPTR)=$P($G(^PS(52.5,REC,0)),"^",1) I PSXPTR="" S PSXOK=8 Q - D PSOL^PSSLOCK(RXN) S PSOMSG=+PSOMSG ; sets PSOMSG - I ($P(^PS(52.5,REC,0),U,3)'=XDFN)!($P(^PSRX(PSXPTR,0),U,2)'=XDFN) S PSXOK=8 Q - I '$D(^PSRX(PSXPTR,0)) S PSXOK=8 Q - S RXNUM=$P($G(^PSRX(PSXPTR,0)),"^",6),RXEX=$P($G(^PSRX(PSXPTR,0)),"^",1) - I $G(^PSDRUG(RXNUM,"ND"))'="" D - .S PTRA=$P($G(^PSDRUG(RXNUM,"ND")),U,1),PTRB=$P($G(^PSDRUG(RXNUM,"ND")),U,3) - .I $G(PTRA)'="" S ZX=$$PROD2^PSNAPIS(PTRA,PTRB),DRUGCHK=$P($G(ZX),"^",3) - S:$G(DRUGCHK)'="" PSXDGST=$P(ZX,"^",2)_"^"_$P(ZX,"^") - I '$D(DRUGCHK) S DRUGCHK=0 - S:'$D(^PSDRUG("AQ",RXNUM)) PSXOK=1 - S:$G(DRUGCHK)'=1 PSXOK=1 - I $P(^PSDRUG(RXNUM,2),"^",3)'["O" S PSXOK=1,PSXCK=RXNUM D UNMARK^PSXUTL - S:$P($G(^PSRX(PSXPTR,"STA")),U,1)'=5 PSXOK=5 - ;gets the fill number by ordering thru the refill node for the last - ;refill number - S FILNUM=0 F REF=0:0 S REF=$O(^PSRX(PSXPTR,1,REF)) Q:REF'>0 S:REF>0 FILNUM=REF S:REF="" FILNUM=0 - ;I $G(PSXFLAG)=2 S PSXOK=0 Q - S RXF=FILNUM - S REL=$S(RXF>0:$P($G(^PSRX(RXN,1,RXF,0)),U,18),RXF=0:$P($G(^PSRX(RXN,2)),U,13),1:"") I $G(REL)'="" S PSXOK=6 - S:((PSXOK=0)&(FILNUM>0)&($P($G(^PSRX(PSXPTR,1,FILNUM,0)),"^",2)'="M")) PSXOK=3 - S:((PSXOK=0)&(FILNUM'>0)&($P($G(^PSRX(PSXPTR,0)),"^",11)'="M")) PSXOK=3 - I $G(^PS(52.5,REC,"P"))="1" S PSXOK=4 - S PSXDIV=$S(FILNUM=0:$P($G(^PSRX(PSXPTR,2)),U,9),FILNUM>0:$P($G(^PSRX(PSXPTR,1,FILNUM,0)),"^",9),1:"") - ;If trans div does not match Rx div eliminate - I PSXDIV'=PSOSITE S PSXOK=7 Q - ; Changes for Controlled subs - N PSXCSC,PSXCSD S PSXCSRX="" - S PSXCSC=$P($G(^PSDRUG(RXNUM,0)),"^",3) - ;Can't trans DEA schedule 1 or 2 - I $G(PSXCSC)[1!$G(PSXCSC)[2 S PSXOK=10 Q - ;If CS must be DEA 3-5 to qualify - F PSXCSD=3:1:5 I PSXCSC[PSXCSD S PSXCSRX=1 - ;If not CS drug and CS trans eliminate - I ($G(PSXCSRX)<1)&($G(PSXCS)=1) S PSXOK=9 Q - ;If CS drug and not CS trans eliminate - I ($G(PSXCSRX)=1)&($G(PSXCS)<1) S PSXOK=9 Q - ; Checks for do not mail and expiration date thereof - ; moved to under NOGO - ; - G:PSXOK'=0 STOP -NOGO ;any rx that does not pass the following checks will not be transmitted - ;and an error message will be generated and sent to the user who - ;initiated the transmission. All that pass the checks will be sent. - S RXERR=0,PSXRXERR=RXEX_"^"_RXF - I RXEX[" " S RXERR=13,PSXRXERR=PSXRXERR_"^"_RXERR - S QTY=$S(RXF>0:$P($G(^PSRX(RXN,1,RXF,0)),U,4),RXF=0:$P($G(^PSRX(RXN,0)),U,7),1:"") G:$G(QTY)'=""&($G(QTY)>0)&(QTY?.N)!(QTY?.N1".".N) NG1 S RXERR=2,PSXRXERR=PSXRXERR_"^"_RXERR -NG1 S PHY=$S(RXF>0:$P($G(^PSRX(RXN,1,RXF,0)),U,17),RXF=0:$P($G(^PSRX(RXN,0)),U,4),1:"") I PHY="" S RXERR=3,PSXRXERR=PSXRXERR_"^"_RXERR - S DAYS=$S(RXF>0:$P($G(^PSRX(RXN,1,RXF,0)),U,10),RXF=0:$P($G(^PSRX(RXN,0)),U,8),1:"") I (DAYS'>0)!(DAYS="") S RXERR=4,PSXRXERR=PSXRXERR_"^"_RXERR - S PHARCLK=$S(RXF>0:$P($G(^PSRX(RXN,1,RXF,0)),U,7),RXF=0:$P($G(^PSRX(RXN,0)),U,16),1:"") I PHARCLK="" S RXERR=9,PSXRXERR=PSXRXERR_"^"_RXERR - S DRUG=$P($G(^PSRX(RXN,0)),U,6),PSTAT=$P($G(^(0)),U,3),FDATE=$P($G(^PSRX(RXN,2)),U,2) - D TSTSIG - S DFN=$P($G(^PSRX(RXN,0)),U,2) D ADD^VADPT I ($G(VAPA(1))="")!($G(VAPA(4))="")!($P($G(VAPA(5)),"^",2)="")!($G(VAPA(6))'>0)!($P($G(VAPA(11)),"^",2)'>0) S RXERR=10,PSXRXERR=PSXRXERR_"^"_RXERR - D DEM^VADPT - I VADM(1)["MERGING" S RXERR=17,PSXRXERR=PSXRXERR_"^"_RXERR - ;MVP OIFO BAY PINES;ELR;PSX*2*52 CHANGED RXERR FROM 10 TO 19. ADDED NEW ERROR IN PSXERR - I $G(VA("PID"))["000-00" S RXERR=19,PSXRXERR=PSXRXERR_"^"_RXERR ; SSN ["000-00" indicates test patient - S (CNTR,XC,DUPFLG)=0,DUPRX="" F S XC=$O(^PSRX("B",RXEX,XC)) Q:XC'>0 S CNTR=CNTR+1,DUPRX=DUPRX_"^"_XC - I CNTR>1 D - .Q:$P(DUPRX,"^",3)="" - .F I2=2:1 S I1=$P(DUPRX,"^",I2) Q:I1="" S PSREC=$O(^PS(52.5,"B",I1,"")) Q:$G(PSREC)'>0 S:($P(^PS(52.5,PSREC,0),"^",2)0 PSXRXERR=PSXRXERR_"^"_"14" - K CNTR,XC,DUPRX,I2,I1,PSREC,DUPFLG - I $D(^PSRX(PSXPTR,4,0)) D - .S RXERR="" - .S ZX=0 F S ZX=$O(^PSRX(PSXPTR,4,ZX)) Q:ZX'>0 D - ..I $P(^PSRX(PSXPTR,4,ZX,0),"^",3)=RXF&($P(^PSRX(PSXPTR,4,ZX,0),"^",4)'=3) S RXERR=12 - ..I $P(^PSRX(PSXPTR,4,ZX,0),"^",3)=RXF&($P(^PSRX(PSXPTR,4,ZX,0),"^",4)=3) S RXERR="" - .I RXERR'="" S PSXRXERR=PSXRXERR_"^"_RXERR - I DRUG="" S RXERR=5,PSXRXERR=PSXRXERR_"^"_RXERR - I DRUG S WARNS=$P(^PSDRUG(DRUG,0),"^",8) D - .;IF USING NEW WARNING SOURCE, LENGTH OF OLD WARNINGS DOESN'T MATTER - .I '$D(PSSWSITE) S PSSWSITE=+$O(^PS(59.7,0)) - .I $P($G(^PS(59.7,PSSWSITE,10)),"^",10)="N" Q - .I $G(WARNS) S:$L(WARNS)>11 RXERR=16,PSXRXERR=PSXRXERR_"^"_RXERR - I SIG="" S RXERR=6,PSXRXERR=PSXRXERR_"^"_RXERR - I PSTAT="" S RXERR=7,PSXRXERR=PSXRXERR_"^"_RXERR - I FDATE'?7N S RXERR=8,PSXRXERR=PSXRXERR_"^"_RXERR - I '$$MAILOK(RXN) D - . S COM="Removed from CMOP Suspense - Mail Status Change" D NOW^%DTC S DTTM=% K % D ACTLOG^PSXRPPL - . D DELETE^PSXRPPL S PSXOK=1 - . ;MVP OIFO BAY PINES;ELR;PSX*2*5 DELETE MM MSG FOR DO NOT MAIL - . ;S RXERR=15,PSXRXERR=PSXRXERR_"^"_RXERR ;mail message to users - I $D(^TMP($J,"PSXBAI",DFN)),'$G(^TMP($J,"PSXBAI",DFN)) D - . S PSXOK=8 - . D CHKACT(PSXPTR) - . I '$G(PSXFIRST) K PSXRXERR Q - . S COM="Bad Address Indicator or Foreign Address. Not removed from CMOP Suspense" D NOW^%DTC S DTTM=% K % D ACTLOG^PSXRPPL - . S RXERR=20,PSXRXERR=PSXRXERR_"^"_RXERR ;mail message to users -PSOMSG I +PSOMSG=0 S RXERR=18,PSXRXERR=PSXRXERR_"^"_RXERR ; from PSSLOCK - I $P($G(PSXRXERR),"^",3)'="" S PSXOK=8 D ER7^PSXERR -STOP K DAYS,DRUG,FDATE,PHARCLK,PHY,PSTAT,QTY,RXERR,RXEX,SIG,VAPA(1),DRUGCHK,PTRA,PTRB,REL,RXNUM,PHARCLK1,ZX,VAPA(4),VAPA(5),VAPA(6) - Q - ; -TSTSIG ; include testing for BAD characters in SIG - I $P(^PSRX(RXN,"SIG"),"^",2)'>0 S SIG=$P(^PSRX(RXN,"SIG"),"^") D TSTCHAR - I $P(^PSRX(RXN,"SIG"),"^",2)=1 N L S L=0 F S L=$O(^PSRX(RXN,"SIG1",L)) Q:L'>0 S SIG=$G(^PSRX(RXN,"SIG1",L,0)) D TSTCHAR Q:SIG="" - Q -TSTCHAR ; test each character of SIG for certain characters - N I,C - I '$D(^TMP($J,"PSXCHAR")) D - . F I=0:1:31 S ^TMP($J,"PSXCHAR",I)="" - . F I=92,94,124,127 S ^TMP($J,"PSXCHAR",I)="" - F I=1:1:$L(SIG) S C=$A($E(SIG,I)) I $D(^TMP($J,"PSXCHAR",C)) S SIG="" Q - Q -MAILOK(TRX) ; return 1 if patient still in mail status & ok to CMOP - N PSOMDT,PSOMC,DFN - S DFN=$P(^PSRX(TRX,0),"^",2),PSOMDT=$P($G(^PS(55,DFN,0)),"^",5),PSOMC=$P($G(^PS(55,DFN,0)),"^",3) - I (PSOMC>1&(PSOMDT>DT))!(PSOMC>1&(PSOMDT<1)) Q 0 - Q 1 -ADDROK(TRX) ; return 1 if not foreign and not bad address indicator - N DFN,PSOFORGN - S DFN=$P($G(^PSRX(TRX,0)),"^",2) I DFN="" Q:0 - ;BHW;PSX*2*64;Changed Quit below from Q:+(^TMP... to Q +(^TMP... - I $D(^TMP($J,"PSXBAI",DFN)) Q +(^TMP($J,"PSXBAI",DFN)) - D ADD^VADPT - S PSOFORGN=$P($G(VAPA(25)),"^",2) I PSOFORGN'="",PSOFORGN'["UNITED STATES" S PSOFORGN=1 - I PSOFORGN S ^TMP($J,"PSXBAI",DFN)=0 Q 0 - I $T(CHKRX^PSOBAI)']"" S ^TMP($J,"PSXBAI",DFN)=1 Q 1 - N PSORX,PSOBADR - S PSORX=TRX - S PSOBADR=$$CHKRX^PSOBAI(PSORX) - I '$P(PSOBADR,"^") S ^TMP($J,"PSXBAI",DFN)=1 Q 1 - I $P(PSOBADR,"^",2)=1 S ^TMP($J,"PSXBAI",DFN)=1 Q 1 - S ^TMP($J,"PSXBAI",DFN)=0 - Q 0 - ; -CHKACT(RXN) ; SEE IF FILL IS ALREADY ON ACTIVITY LOG FOR FOREIGN OR BAD ADDRESS - N JJ,RFCNT,XX,COM - S PSXFIRST=1 - S COM="Bad Address Indicator or Foreign Address." - S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(RXN,1,RF)) Q:'RF S RFCNT=$S(RF<6:RF,1:RF+1) - S JJ=0 F S JJ=$O(^PSRX(RXN,"A",JJ)) Q:'JJ S XX=$G(^PSRX(RXN,"A",JJ,0)) I $P(XX,"^",4)=RFCNT,$P(XX,"^",5)[COM S PSXFIRST=0 Q - Q +PSXMISC1 ;BIR/WPB,BAB-Transmission Data Validation ;MAR 1,2002@13:13:34 + ;;2.0;CMOP;**3,18,23,28,30,42,41,52,54,58**;11 Apr 97;Build 2 + ;Reference to ^PSDRUG( supported by DBIA #1983 + ;Reference to ^PS(52.5, supported by DBIA #1978 + ;Reference to ^PSRX( supported by DBIA #1977 + ;Reference to ^PS(55, supported by DBIA #2228 + ;Reference to PROD2^PSNAPIS supported by DBIA #2531 + ;Reference to ^PSSLOCK supported by DBIA #2789 + ;Reference to CHKRX^PSOBAI supported by DBIA #4910 +CHKDATA ;checks the data elements in PSRX before putting the rx in 550.2 + Q:'$D(^PS(52.5,REC,0)) + K DRUGCHK,PSXRXERR,PSXDGST,WARNS + S (RXN,PSXPTR)=$P($G(^PS(52.5,REC,0)),"^",1) I PSXPTR="" S PSXOK=8 Q + D PSOL^PSSLOCK(RXN) S PSOMSG=+PSOMSG ; sets PSOMSG + I ($P(^PS(52.5,REC,0),U,3)'=XDFN)!($P(^PSRX(PSXPTR,0),U,2)'=XDFN) S PSXOK=8 Q + I '$D(^PSRX(PSXPTR,0)) S PSXOK=8 Q + S RXNUM=$P($G(^PSRX(PSXPTR,0)),"^",6),RXEX=$P($G(^PSRX(PSXPTR,0)),"^",1) + I $G(^PSDRUG(RXNUM,"ND"))'="" D + .S PTRA=$P($G(^PSDRUG(RXNUM,"ND")),U,1),PTRB=$P($G(^PSDRUG(RXNUM,"ND")),U,3) + .I $G(PTRA)'="" S ZX=$$PROD2^PSNAPIS(PTRA,PTRB),DRUGCHK=$P($G(ZX),"^",3) + S:$G(DRUGCHK)'="" PSXDGST=$P(ZX,"^",2)_"^"_$P(ZX,"^") + I '$D(DRUGCHK) S DRUGCHK=0 + S:'$D(^PSDRUG("AQ",RXNUM)) PSXOK=1 + S:$G(DRUGCHK)'=1 PSXOK=1 + I $P(^PSDRUG(RXNUM,2),"^",3)'["O" S PSXOK=1,PSXCK=RXNUM D UNMARK^PSXUTL + S:$P($G(^PSRX(PSXPTR,"STA")),U,1)'=5 PSXOK=5 + ;gets the fill number by ordering thru the refill node for the last + ;refill number + S FILNUM=0 F REF=0:0 S REF=$O(^PSRX(PSXPTR,1,REF)) Q:REF'>0 S:REF>0 FILNUM=REF S:REF="" FILNUM=0 + ;I $G(PSXFLAG)=2 S PSXOK=0 Q + S RXF=FILNUM + S REL=$S(RXF>0:$P($G(^PSRX(RXN,1,RXF,0)),U,18),RXF=0:$P($G(^PSRX(RXN,2)),U,13),1:"") I $G(REL)'="" S PSXOK=6 + S:((PSXOK=0)&(FILNUM>0)&($P($G(^PSRX(PSXPTR,1,FILNUM,0)),"^",2)'="M")) PSXOK=3 + S:((PSXOK=0)&(FILNUM'>0)&($P($G(^PSRX(PSXPTR,0)),"^",11)'="M")) PSXOK=3 + I $G(^PS(52.5,REC,"P"))="1" S PSXOK=4 + S PSXDIV=$S(FILNUM=0:$P($G(^PSRX(PSXPTR,2)),U,9),FILNUM>0:$P($G(^PSRX(PSXPTR,1,FILNUM,0)),"^",9),1:"") + ;If trans div does not match Rx div eliminate + I PSXDIV'=PSOSITE S PSXOK=7 Q + ; Changes for Controlled subs + N PSXCSC,PSXCSD S PSXCSRX="" + S PSXCSC=$P($G(^PSDRUG(RXNUM,0)),"^",3) + ;Can't trans DEA schedule 1 or 2 + I $G(PSXCSC)[1!$G(PSXCSC)[2 S PSXOK=10 Q + ;If CS must be DEA 3-5 to qualify + F PSXCSD=3:1:5 I PSXCSC[PSXCSD S PSXCSRX=1 + ;If not CS drug and CS trans eliminate + I ($G(PSXCSRX)<1)&($G(PSXCS)=1) S PSXOK=9 Q + ;If CS drug and not CS trans eliminate + I ($G(PSXCSRX)=1)&($G(PSXCS)<1) S PSXOK=9 Q + ; Checks for do not mail and expiration date thereof + ; moved to under NOGO + ; + G:PSXOK'=0 STOP +NOGO ;any rx that does not pass the following checks will not be transmitted + ;and an error message will be generated and sent to the user who + ;initiated the transmission. All that pass the checks will be sent. + S RXERR=0,PSXRXERR=RXEX_"^"_RXF + I RXEX[" " S RXERR=13,PSXRXERR=PSXRXERR_"^"_RXERR + S QTY=$S(RXF>0:$P($G(^PSRX(RXN,1,RXF,0)),U,4),RXF=0:$P($G(^PSRX(RXN,0)),U,7),1:"") G:$G(QTY)'=""&($G(QTY)>0)&(QTY?.N)!(QTY?.N1".".N) NG1 S RXERR=2,PSXRXERR=PSXRXERR_"^"_RXERR +NG1 S PHY=$S(RXF>0:$P($G(^PSRX(RXN,1,RXF,0)),U,17),RXF=0:$P($G(^PSRX(RXN,0)),U,4),1:"") I PHY="" S RXERR=3,PSXRXERR=PSXRXERR_"^"_RXERR + S DAYS=$S(RXF>0:$P($G(^PSRX(RXN,1,RXF,0)),U,10),RXF=0:$P($G(^PSRX(RXN,0)),U,8),1:"") I (DAYS'>0)!(DAYS="") S RXERR=4,PSXRXERR=PSXRXERR_"^"_RXERR + S PHARCLK=$S(RXF>0:$P($G(^PSRX(RXN,1,RXF,0)),U,7),RXF=0:$P($G(^PSRX(RXN,0)),U,16),1:"") I PHARCLK="" S RXERR=9,PSXRXERR=PSXRXERR_"^"_RXERR + S DRUG=$P($G(^PSRX(RXN,0)),U,6),PSTAT=$P($G(^(0)),U,3),FDATE=$P($G(^PSRX(RXN,2)),U,2) + D TSTSIG + S DFN=$P($G(^PSRX(RXN,0)),U,2) D ADD^VADPT I ($G(VAPA(1))="")!($G(VAPA(4))="")!($P($G(VAPA(5)),"^",2)="")!($G(VAPA(6))'>0)!($P($G(VAPA(11)),"^",2)'>0) S RXERR=10,PSXRXERR=PSXRXERR_"^"_RXERR + D DEM^VADPT + I VADM(1)["MERGING" S RXERR=17,PSXRXERR=PSXRXERR_"^"_RXERR + ;MVP OIFO BAY PINES;ELR;PSX*2*52 CHANGED RXERR FROM 10 TO 19. ADDED NEW ERROR IN PSXERR + I $G(VA("PID"))["000-00" S RXERR=19,PSXRXERR=PSXRXERR_"^"_RXERR ; SSN ["000-00" indicates test patient + S (CNTR,XC,DUPFLG)=0,DUPRX="" F S XC=$O(^PSRX("B",RXEX,XC)) Q:XC'>0 S CNTR=CNTR+1,DUPRX=DUPRX_"^"_XC + I CNTR>1 D + .Q:$P(DUPRX,"^",3)="" + .F I2=2:1 S I1=$P(DUPRX,"^",I2) Q:I1="" S PSREC=$O(^PS(52.5,"B",I1,"")) Q:$G(PSREC)'>0 S:($P(^PS(52.5,PSREC,0),"^",2)0 PSXRXERR=PSXRXERR_"^"_"14" + K CNTR,XC,DUPRX,I2,I1,PSREC,DUPFLG + I $D(^PSRX(PSXPTR,4,0)) D + .S RXERR="" + .S ZX=0 F S ZX=$O(^PSRX(PSXPTR,4,ZX)) Q:ZX'>0 D + ..I $P(^PSRX(PSXPTR,4,ZX,0),"^",3)=RXF&($P(^PSRX(PSXPTR,4,ZX,0),"^",4)'=3) S RXERR=12 + ..I $P(^PSRX(PSXPTR,4,ZX,0),"^",3)=RXF&($P(^PSRX(PSXPTR,4,ZX,0),"^",4)=3) S RXERR="" + .I RXERR'="" S PSXRXERR=PSXRXERR_"^"_RXERR + I DRUG="" S RXERR=5,PSXRXERR=PSXRXERR_"^"_RXERR + I DRUG S WARNS=$P(^PSDRUG(DRUG,0),"^",8) D + .;IF USING NEW WARNING SOURCE, LENGTH OF OLD WARNINGS DOESN'T MATTER + .I '$D(PSSWSITE) S PSSWSITE=+$O(^PS(59.7,0)) + .I $P($G(^PS(59.7,PSSWSITE,10)),"^",10)="N" Q + .I $G(WARNS) S:$L(WARNS)>11 RXERR=16,PSXRXERR=PSXRXERR_"^"_RXERR + I SIG="" S RXERR=6,PSXRXERR=PSXRXERR_"^"_RXERR + I PSTAT="" S RXERR=7,PSXRXERR=PSXRXERR_"^"_RXERR + I FDATE'?7N S RXERR=8,PSXRXERR=PSXRXERR_"^"_RXERR + I '$$MAILOK(RXN) D + . S COM="Removed from CMOP Suspense - Mail Status Change" D NOW^%DTC S DTTM=% K % D ACTLOG^PSXRPPL + . D DELETE^PSXRPPL S PSXOK=1 + . ;MVP OIFO BAY PINES;ELR;PSX*2*5 DELETE MM MSG FOR DO NOT MAIL + . ;S RXERR=15,PSXRXERR=PSXRXERR_"^"_RXERR ;mail message to users + I $D(^TMP($J,"PSXBAI",DFN)),'$G(^TMP($J,"PSXBAI",DFN)) D + . S PSXOK=8 + . D CHKACT(PSXPTR) + . I '$G(PSXFIRST) K PSXRXERR Q + . S COM="Bad Address Indicator or Foreign Address. Not removed from CMOP Suspense" D NOW^%DTC S DTTM=% K % D ACTLOG^PSXRPPL + . S RXERR=20,PSXRXERR=PSXRXERR_"^"_RXERR ;mail message to users +PSOMSG I +PSOMSG=0 S RXERR=18,PSXRXERR=PSXRXERR_"^"_RXERR ; from PSSLOCK + I $P($G(PSXRXERR),"^",3)'="" S PSXOK=8 D ER7^PSXERR +STOP K DAYS,DRUG,FDATE,PHARCLK,PHY,PSTAT,QTY,RXERR,RXEX,SIG,VAPA(1),DRUGCHK,PTRA,PTRB,REL,RXNUM,PHARCLK1,ZX,VAPA(4),VAPA(5),VAPA(6) + Q + ; +TSTSIG ; include testing for BAD characters in SIG + I $P(^PSRX(RXN,"SIG"),"^",2)'>0 S SIG=$P(^PSRX(RXN,"SIG"),"^") D TSTCHAR + I $P(^PSRX(RXN,"SIG"),"^",2)=1 N L S L=0 F S L=$O(^PSRX(RXN,"SIG1",L)) Q:L'>0 S SIG=$G(^PSRX(RXN,"SIG1",L,0)) D TSTCHAR Q:SIG="" + Q +TSTCHAR ; test each character of SIG for certain characters + N I,C + I '$D(^TMP($J,"PSXCHAR")) D + . F I=0:1:31 S ^TMP($J,"PSXCHAR",I)="" + . F I=92,94,124,127 S ^TMP($J,"PSXCHAR",I)="" + F I=1:1:$L(SIG) S C=$A($E(SIG,I)) I $D(^TMP($J,"PSXCHAR",C)) S SIG="" Q + Q +MAILOK(TRX) ; return 1 if patient still in mail status & ok to CMOP + N PSOMDT,PSOMC,DFN + S DFN=$P(^PSRX(TRX,0),"^",2),PSOMDT=$P($G(^PS(55,DFN,0)),"^",5),PSOMC=$P($G(^PS(55,DFN,0)),"^",3) + I (PSOMC>1&(PSOMDT>DT))!(PSOMC>1&(PSOMDT<1)) Q 0 + Q 1 +ADDROK(TRX) ; return 1 if not foreign and not bad address indicator + N DFN,PSOFORGN + S DFN=$P($G(^PSRX(TRX,0)),"^",2) I DFN="" Q:0 + I $D(^TMP($J,"PSXBAI",DFN)) Q:+(^TMP($J,"PSXBAI",DFN)) + D ADD^VADPT + S PSOFORGN=$P($G(VAPA(25)),"^",2) I PSOFORGN'="",PSOFORGN'["UNITED STATES" S PSOFORGN=1 + I PSOFORGN S ^TMP($J,"PSXBAI",DFN)=0 Q 0 + I $T(CHKRX^PSOBAI)']"" S ^TMP($J,"PSXBAI",DFN)=1 Q 1 + N PSORX,PSOBADR + S PSORX=TRX + S PSOBADR=$$CHKRX^PSOBAI(PSORX) + I '$P(PSOBADR,"^") S ^TMP($J,"PSXBAI",DFN)=1 Q 1 + I $P(PSOBADR,"^",2)=1 S ^TMP($J,"PSXBAI",DFN)=1 Q 1 + S ^TMP($J,"PSXBAI",DFN)=0 + Q 0 + ; +CHKACT(RXN) ; SEE IF FILL IS ALREADY ON ACTIVITY LOG FOR FOREIGN OR BAD ADDRESS + N JJ,RFCNT,XX,COM + S PSXFIRST=1 + S COM="Bad Address Indicator or Foreign Address." + S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(RXN,1,RF)) Q:'RF S RFCNT=$S(RF<6:RF,1:RF+1) + S JJ=0 F S JJ=$O(^PSRX(RXN,"A",JJ)) Q:'JJ S XX=$G(^PSRX(RXN,"A",JJ,0)) I $P(XX,"^",4)=RFCNT,$P(XX,"^",5)[COM S PSXFIRST=0 Q + Q diff --git a/r/CONSULT_REQUEST_TRACKING-GMRC-GMRS-GMRT/GMRCP5D.m b/r/CONSULT_REQUEST_TRACKING-GMRC-GMRS-GMRT/GMRCP5D.m index 94a006e7..ed2aafbd 100644 --- a/r/CONSULT_REQUEST_TRACKING-GMRC-GMRS-GMRT/GMRCP5D.m +++ b/r/CONSULT_REQUEST_TRACKING-GMRC-GMRS-GMRT/GMRCP5D.m @@ -1,204 +1,204 @@ -GMRCP5D ;SLC/DCM,RJS,JFR - Print Consult form 513 (Gather Data - Addendums, Headers, Service reports and Comments) ;8/19/03 15:31 - ;;3.0;CONSULT/REQUEST TRACKING;**4,12,15,22,29,35,38,61**;Dec 27, 1997;Build 2 - ; -FORMAT(GMRCIFN,GMRCRD,PAGEWID) ; - ; - I $L($P(GMRCRD,U,15)) D - .I $O(^TMP("GMRCR",$J,"MCAR",0)) D - ..N GMRCSVC - ..S GMRCSVC=$P($G(^GMR(123.5,+$P(GMRCRD,U,5),0)),U,1) - ..S:$L(GMRCSVC) GMRCSVC=GMRCSVC_" " - ..; - ..; Medicine Results? - ..S GMRCR0=0 F S GMRCR0=$O(^TMP("GMRCR",$J,"MCAR",GMRCR0)) Q:'GMRCR0 D - ...D SUB("H","SREP",GMRCR0,$$CENTER(GMRCSVC_"Service Report #"_GMRCR0_" continued.")) - ...D SUB("H","SREP",GMRCR0," ") - ...D BLD("SREP",GMRCR0,1,0,$$CENTER("Medicine Package Report")) - ...D BLD("SREP",GMRCR0,1,0,"") - ...N LN - ...S LN=0 F S LN=$O(^TMP("GMRCR",$J,"MCAR",GMRCR0,LN)) Q:'LN D - ....D BLD("SREP",GMRCR0,1,0,$G(^TMP("GMRCR",$J,"MCAR",GMRCR0,LN,0))) - ; - ; Build Processing Activities - S GMRCR0=0 F S GMRCR0=$O(^GMR(123,GMRCIFN,40,GMRCR0)) Q:'GMRCR0 D - .N GMRCR1,GMRC400,CMT,USER,GMRCDT,RPRV,GMRC402,GMRCISIT - .S GMRCR1=+$O(^GMR(123,GMRCIFN,40,GMRCR0,0)) Q:GMRCR1'=1 - .S GMRC400=$G(^GMR(123,GMRCIFN,40,GMRCR0,0)) - .S GMRC402=$G(^GMR(123,GMRCIFN,40,GMRCR0,2)) - .S CMT=$$PRCMT^GMRCP5B(+$P(GMRC400,U,2)) Q:'$L(CMT) - .S GMRCDT=$P(GMRC400,U,3) S:'GMRCDT GMRCDT=$P(GMRC400,U,1) - .S GMRCDT=$$EXDT(GMRCDT)_" "_$P(GMRC402,U,3) - .;Following lines modified in patch *38 - .;I $P(^GMR(123,GMRCIFN,0),U,23) D ;commented out - .;.S GMRCISIT=$$GET1^DIQ(4,$P(^GMR(123,GMRCIFN,0),U,23),.01) ;commented out - .;.S GMRCISIT="Entered at: "_GMRCISIT ;commented out - .I $L(GMRC402) D ;ADDED - ..S GMRCISIT=$$GET1^DIQ(123,GMRCIFN,.07) ;ADDED - .I '$D(GMRCISIT) D ;ADDED - ..S GMRCISIT=$$KSP^XUPARAM("INST") ;ADDED - ..I GMRCISIT'="" S GMRCISIT=$$GET1^DIQ(4,GMRCISIT,.01) ;ADDED - ..I GMRCISIT="" S GMRCISIT=$$GET1^DIQ(123,GMRCIFN,.05) ;ADDED - .S GMRCISIT="Entered at: "_GMRCISIT ;ADDED - .;End of modifications for patch *38 - .S RPRV=$$GET1^DIQ(200,+$P(GMRC400,U,4),.01) - .I '$L(RPRV) S RPRV=$P(GMRC402,U,2) - .S:($L(RPRV)) RPRV="Responsible Person: "_RPRV - .S USER=$$GET1^DIQ(200,+$P(GMRC400,U,5),.01) - .I '$L(USER) S USER=$P(GMRC402,U) - .S USER="Entered by: "_USER_" - "_GMRCDT - .D SUB("H","COM",GMRCR0,CMT_" Comment ("_USER_") continued.") - .D SUB("H","COM",GMRCR0," ") - .D BLD("COM",GMRCR0,1,0,"") - .D BLD("COM",GMRCR0,1,0,$$CENTER("("_CMT_" Comment)")) - .I $P(GMRC400,U,2)=17!($P(GMRC400,U,2)=25) D - .. N FWDLN,FWDRS - .. S FWDLN="Forwarded from: " - .. S FWDRS=$P($G(^GMR(123,GMRCIFN,40,GMRCR0,3)),U) - .. I $L(FWDRS) S FWDLN=FWDLN_FWDRS - .. I '$L(FWDRS) S FWDLN=FWDLN_$$GET1^DIQ(123.5,+$P(GMRC400,U,6),.01) - .. D BLD("COM",GMRCR0,1,5,FWDLN) - .D BLD("COM",GMRCR0,1,5,USER) - .D:($L(RPRV)) BLD("COM",GMRCR0,1,5,RPRV) - .D:($L($G(GMRCISIT))) BLD("COM",GMRCR0,1,5,GMRCISIT) - .; - .N GMRCR2 S GMRCR2=0 - .F S GMRCR2=$O(^GMR(123,GMRCIFN,40,GMRCR0,GMRCR1,GMRCR2)) Q:'GMRCR2 D - ..D BLD("COM",GMRCR0,1,0,$G(^GMR(123,GMRCIFN,40,GMRCR0,GMRCR1,GMRCR2,0))) - ; - Q - ; -ADDEND(GMRCIFN,GMRCR0,GMRCNDX,GMRCRD,PAGEWID) ; - ; - N GMRCADD,GMRCNDX,GMRCR1,GMRCV,TEXT,GMRCX - ; - S GMRCADD=0 F S GMRCADD=$O(^TMP("GMRCR",$J,"RES",GMRCR0,"ADD",GMRCADD)) Q:'GMRCADD D - .N GMRCSGNM,GMRCNMDT,GMRCTIT,GMRCMODE,GMRCCSDT,GMRCCTIT,GMRCCSGM - .; - .F GMRCV="GMRCSGNM","GMRCNMDT","GMRCTIT","GMRCMODE" D - ..S @GMRCV=$G(^TMP("GMRCR",$J,"RES",GMRCR0,"ADD",GMRCADD,GMRCV)) - .; - . F GMRCV="GMRCCSDT","GMRCCTIT","GMRCCSGM","GMRCCSIG" D - .. S @GMRCV=$G(^TMP("GMRCR",$J,"RES",GMRCR0,"ADD",GMRCADD,GMRCV)) - .S GMRCNDX=$O(^TMP("GMRC",$J,"OUTPUT","RES"," "),-1)+1 - .I $L($G(GMRCRPT)) D SUB("H","RES",GMRCNDX,"Addendum #"_GMRCADD_" To Consult Note #"_GMRCR0_" for "_GMRCRPT_" continued.") - .I '$L($G(GMRCRPT)) D SUB("H","RES",GMRCNDX,"Addendum #"_GMRCADD_" To Consult Note #"_GMRCR0_" continued.") - .D SUB("H","RES",GMRCNDX," ") - .I $L($G(GMRCSGNM)) D - ..D SUB("F","RES",GMRCNDX," ") - ..I (GMRCMODE="electronic") S GMRCX=" Addendum Signature: "_GMRCSGNM_" /es/ "_$$EXDT($G(GMRCNMDT)) - ..I '(GMRCMODE="electronic") S GMRCX=" Addendum Author: "_GMRCSGNM S:$L($G(GMRCNMDT)) GMRCX=GMRCX_" Last edited: "_$$EXDT(GMRCNMDT) - ..D SUB("F","RES",GMRCNDX,GMRCX) - ..D:$L($G(GMRCTIT)) SUB("F","RES",GMRCNDX," "_GMRCTIT) - .I $L($G(GMRCCSDT)) D - ..D SUB("F","RES",GMRCNDX," ") - ..I (GMRCCSGM="electronic") S GMRCX=" Addendum CoSignature: "_GMRCCSIG_" /es/ "_$$EXDT(GMRCCSDT) - ..I '(GMRCCSGM="electronic") S GMRCX=" Addendum CoSignature: "_GMRCCSIG_" /chart/ "_$$EXDT(GMRCCSDT) - ..D SUB("F","RES",GMRCNDX,GMRCX) - ..D:$L($G(GMRCCTIT)) SUB("F","RES",GMRCNDX," "_GMRCCTIT) - .D BLD("RES",GMRCNDX,1,0," ") - .I $L($G(GMRCRPT)) D BLD("RES",GMRCNDX,1,0,$$CENTER("ADDENDUM #"_GMRCADD_" TO CONSULT NOTE #"_GMRCR0_" FOR "_GMRCRPT)) - .I '$L($G(GMRCRPT)) D BLD("RES",GMRCNDX,1,0,$$CENTER("ADDENDUM #"_GMRCADD_" TO CONSULT NOTE #"_GMRCR0)) - .D BLD("RES",GMRCNDX,1,0," ") - .S GMRCR1=0 F S GMRCR1=$O(^TMP("GMRCR",$J,"RES",GMRCR0,"ADD",GMRCADD,GMRCR1)) Q:'GMRCR1 D - ..D BLD("RES",GMRCNDX,1,0,$G(^TMP("GMRCR",$J,"RES",GMRCR0,"ADD",GMRCADD,GMRCR1,0))) - Q - ; -HDR ; Header code for form 513 - ; - N PG,GMRCFROM - ; - F PG=0,1 D - .D BLD("HDR",PG,1,0,GMRCDVL) - .D BLD("HDR",PG,1,6,"MEDICAL RECORD") - .D BLD("HDR",PG,0,29,"|") - .D BLD("HDR",PG,0,36,"CONSULTATION SHEET") - .I PG D BLD("HDR",PG,0,60,"Page ","GMRCPG,65") I 1 - .E I '$G(GMRCGUI) D BLD("HDR",PG,0,60,"Page ","GMRCPG,65") - .; - .D BLD("HDR",PG,1,0,GMRCDVL) - .D BLD("HDR",PG,1,0,"Consult Request: "_$$CONSRQ(GMRCIFN)) - .D BLD("HDR",PG,1,55,"|Consult No.: "_GMRCIFN) - .; - D BLD("HDR",1,1,0,GMRCEQL) - D BLD("HDR",0,1,0,GMRCDVL) - ; - I $G(CMT) D BLD("HDR",0,1,27,"("_$$PRCMT^GMRCP5B(CMT)_")") Q - ; - S GMRCFROM=$P($G(^SC(+$P(GMRCRD,U,6),0)),U,1) - ; - I '$L(GMRCFROM) D - .N VAIN - .D INP^VADPT - .S GMRCFROM=$P($G(VAIN(4)),U,2) - .I $L($G(VAIN(5))) S GMRCFROM=GMRCFROM_" (Rm/Bd: "_$G(VAIN(5))_" )" - ;No location, IFC - consulting site - I '$L(GMRCFROM),$P(GMRCRD,U,23),$P($G(GMRCRD(12)),U,5)="F" D - .I $P(GMRCRD,U,21) S GMRCFROM=$$GET1^DIQ(4,$P(GMRCRD,U,21),.01) - .E S GMRCFROM=$$GET1^DIQ(4,$P(GMRCRD,U,23),.01) - ; - D BLD("HDR",0,1,0,"To: "_$P($G(^GMR(123.5,+$P(GMRCRD,U,5),0)),U,1)) - D BLD("HDR",0,1,5,"From: "_GMRCFROM) - D BLD("HDR",0,0,49,"|Requested: "_$$EXDT($P(GMRCRD,U,7))) - ; - D BLD("HDR",0,1,0,GMRCDVL) - D BLD("HDR",0,1,0,"Requesting Facility: "_$E(GMRCFAC,1,22)) - I $P(GMRCRD,U,11) D BLD("HDR",0,0,45,"|ATTENTION: "_$E($P($G(^VA(200,+$P(GMRCRD,U,11),0)),U,1),1,21)) - I $P(GMRCRD,U,23) D - . D BLD("HDR",0,1,0,"Remote Consult No.: "_GMRCINO) - . D BLD("HDR",0,1,0,"Role: "_GMRCIRL) - D BLD("HDR",0,1,0,GMRCEQL) - ; - Q - ; -CENTER(X) ; - ; - N TEXT,COL - S COL=35-($L(X)\2) Q:(COL<1) X - S $E(TEXT,COL)=X - Q TEXT - ; -BLD(SUB,NDX,LINE,TAB,TEXT,RUNTIME) ; - ; - Q:'$L($G(SUB)) - N LINECNT - ; - F LINECNT=1:1:+LINE S ^TMP("GMRC",$J,"OUTPUT",SUB,NDX,$$LASTLN(SUB,NDX)+1,0)="" - ; - S $E(^TMP("GMRC",$J,"OUTPUT",SUB,NDX,$$LASTLN(SUB,NDX),0),TAB+1)=TEXT - I $L($G(RUNTIME)) S ^TMP("GMRC",$J,"OUTPUT",SUB,NDX,$$LASTLN(SUB,NDX),1)=RUNTIME - ; - S GMRCLAST=SUB - Q - ; -SUB(ZONE,SUB,NDX,TEXT) ; - ; - N NEXT - S NEXT=$O(^TMP("GMRC",$J,"OUTPUT",SUB,NDX,ZONE," "),-1)+1 - S ^TMP("GMRC",$J,"OUTPUT",SUB,NDX,ZONE,NEXT,0)=TEXT - Q - ; -LASTLN(SUB,NDX) ; - Q +$O(^TMP("GMRC",$J,"OUTPUT",SUB,NDX," "),-1) - ; -CONSRQ(IFN) ; - ; - N PTR,LINK,REF,GMRCRQ - I +$P(^GMR(123,+IFN,0),U,8) D - . S GMRCRQ=$P(^GMR(123,+IFN,0),U,8) - . S GMRCRQ=$$GET1^DIQ(123.3,+GMRCRQ,.01) - . I '$L(GMRCRQ) S GMRCRQ="Procedure" - I $L($G(GMRCRQ)) Q GMRCRQ - I $L($G(^GMR(123,IFN,1.11))) D - . N SERV,TYPE - . S SERV=$$UP^XLFSTR($$GET1^DIQ(123.5,$P(^GMR(123,IFN,0),U,5),.01)) - . S TYPE=$$UP^XLFSTR(^GMR(123,IFN,1.11)) I TYPE'=SERV D - . I TYPE'=SERV S GMRCRQ=$E(^GMR(123,IFN,1.11),1,36) - Q:$L($G(GMRCRQ)) GMRCRQ Q "Consult" - ; -EXDT(X) ;EXTERNAL DATE FORMAT - ; - N DATE,TIME,HR,MN,PD,Y,%DT - Q:'$L(X) "" - I '(X?7N.1".".6N) S %DT="PTS" D ^%DT S X=Y - Q $$FMTE^XLFDT(X,"5PMZ") - ; +GMRCP5D ;SLC/DCM,RJS,JFR - Print Consult form 513 (Gather Data - Addendums, Headers, Service reports and Comments) ;8/19/03 15:31 + ;;3.0;CONSULT/REQUEST TRACKING;**4,12,15,22,29,35,38**;Dec 27, 1997 + ; +FORMAT(GMRCIFN,GMRCRD,PAGEWID) ; + ; + I $L($P(GMRCRD,U,15)) D + .I $O(^TMP("GMRCR",$J,"MCAR",0)) D + ..N GMRCSVC + ..S GMRCSVC=$P($G(^GMR(123.5,+$P(GMRCRD,U,5),0)),U,1) + ..S:$L(GMRCSVC) GMRCSVC=GMRCSVC_" " + ..; + ..; Medicine Results? + ..S GMRCR0=0 F S GMRCR0=$O(^TMP("GMRCR",$J,"MCAR",GMRCR0)) Q:'GMRCR0 D + ...D SUB("H","SREP",GMRCR0,$$CENTER(GMRCSVC_"Service Report #"_GMRCR0_" continued.")) + ...D SUB("H","SREP",GMRCR0," ") + ...D BLD("SREP",GMRCR0,1,0,$$CENTER("Medicine Package Report")) + ...D BLD("SREP",GMRCR0,1,0,"") + ...N LN + ...S LN=0 F S LN=$O(^TMP("GMRCR",$J,"MCAR",GMRCR0,LN)) Q:'LN D + ....D BLD("SREP",GMRCR0,1,0,$G(^TMP("GMRCR",$J,"MCAR",GMRCR0,LN,0))) + ; + ; Build Processing Activities + S GMRCR0=0 F S GMRCR0=$O(^GMR(123,GMRCIFN,40,GMRCR0)) Q:'GMRCR0 D + .N GMRCR1,GMRC400,CMT,USER,GMRCDT,RPRV,GMRC402,GMRCISIT + .S GMRCR1=+$O(^GMR(123,GMRCIFN,40,GMRCR0,0)) Q:GMRCR1'=1 + .S GMRC400=$G(^GMR(123,GMRCIFN,40,GMRCR0,0)) + .S GMRC402=$G(^GMR(123,GMRCIFN,40,GMRCR0,2)) + .S CMT=$$PRCMT^GMRCP5B(+$P(GMRC400,U,2)) Q:'$L(CMT) + .S GMRCDT=$P(GMRC400,U,3) S:'GMRCDT GMRCDT=$P(GMRC400,U,1) + .S GMRCDT=$$EXDT(GMRCDT)_" "_$P(GMRC402,U,3) + .;Following lines modified in patch *38 + .;I $P(^GMR(123,GMRCIFN,0),U,23) D ;commented out + .;.S GMRCISIT=$$GET1^DIQ(4,$P(^GMR(123,GMRCIFN,0),U,23),.01) ;commented out + .;.S GMRCISIT="Entered at: "_GMRCISIT ;commented out + .I $L(GMRC402) D ;ADDED + ..S GMRCISIT=$$GET1^DIQ(123,GMRCIFN,.07) ;ADDED + .I '$D(GMRCISIT) D ;ADDED + ..S GMRCISIT=$$KSP^XUPARAM("INST") ;ADDED + ..I GMRCISIT'="" S GMRCISIT=$$GET1^DIQ(4,GMRCISIT,.01) ;ADDED + ..I GMRCISIT="" S GMRCISIT=$$GET1^DIQ(123,GMRCIFN,.05) ;ADDED + .S GMRCISIT="Entered at: "_GMRCISIT ;ADDED + .;End of modifications for patch *38 + .S RPRV=$$GET1^DIQ(200,+$P(GMRC400,U,4),.01) + .I '$L(RPRV) S RPRV=$P(GMRC402,U,2) + .S:($L(RPRV)) RPRV="Responsible Person: "_RPRV + .S USER=$$GET1^DIQ(200,+$P(GMRC400,U,5),.01) + .I '$L(USER) S USER=$P(GMRC402,U) + .S USER="Entered by: "_USER_" - "_GMRCDT + .D SUB("H","COM",GMRCR0,CMT_" Comment ("_USER_") continued.") + .D SUB("H","COM",GMRCR0," ") + .D BLD("COM",GMRCR0,1,0,"") + .D BLD("COM",GMRCR0,1,0,$$CENTER("("_CMT_" Comment)")) + .I $P(GMRC400,U,2)=17!($P(GMRC400,U,2)=25) D + .. N FWDLN,FWDRS + .. S FWDLN="Forwarded from: " + .. S FWDRS=$P($G(^GMR(123,GMRCIFN,40,GMRCR0,3)),U) + .. I $L(FWDRS) S FWDLN=FWDLN_FWDRS + .. I '$L(FWDRS) S FWDLN=FWDLN_$$GET1^DIQ(123.5,+$P(GMRC400,U,6),.01) + .. D BLD("COM",GMRCR0,1,5,FWDLN) + .D BLD("COM",GMRCR0,1,5,USER) + .D:($L(RPRV)) BLD("COM",GMRCR0,1,5,RPRV) + .D:($L($G(GMRCISIT))) BLD("COM",GMRCR0,1,5,GMRCISIT) + .; + .N GMRCR2 S GMRCR2=0 + .F S GMRCR2=$O(^GMR(123,GMRCIFN,40,GMRCR0,GMRCR1,GMRCR2)) Q:'GMRCR2 D + ..D BLD("COM",GMRCR0,1,0,$G(^GMR(123,GMRCIFN,40,GMRCR0,GMRCR1,GMRCR2,0))) + ; + Q + ; +ADDEND(GMRCIFN,GMRCR0,GMRCNDX,GMRCRD,PAGEWID) ; + ; + N GMRCADD,GMRCNDX,GMRCR1,GMRCV,TEXT,GMRCX + ; + S GMRCADD=0 F S GMRCADD=$O(^TMP("GMRCR",$J,"RES",GMRCR0,"ADD",GMRCADD)) Q:'GMRCADD D + .N GMRCSGNM,GMRCNMDT,GMRCTIT,GMRCMODE,GMRCCSDT,GMRCCTIT,GMRCCSGM + .; + .F GMRCV="GMRCSGNM","GMRCNMDT","GMRCTIT","GMRCMODE" D + ..S @GMRCV=$G(^TMP("GMRCR",$J,"RES",GMRCR0,"ADD",GMRCADD,GMRCV)) + .; + . F GMRCV="GMRCCSDT","GMRCCTIT","GMRCCSGM","GMRCCSIG" D + .. S @GMRCV=$G(^TMP("GMRCR",$J,"RES",GMRCR0,"ADD",GMRCADD,GMRCV)) + .S GMRCNDX=$O(^TMP("GMRC",$J,"OUTPUT","RES"," "),-1)+1 + .I $L($G(GMRCRPT)) D SUB("H","RES",GMRCNDX,"Addendum #"_GMRCADD_" To Consult Note #"_GMRCR0_" for "_GMRCRPT_" continued.") + .I '$L($G(GMRCRPT)) D SUB("H","RES",GMRCNDX,"Addendum #"_GMRCADD_" To Consult Note #"_GMRCR0_" continued.") + .D SUB("H","RES",GMRCNDX," ") + .I $L($G(GMRCSGNM)) D + ..D SUB("F","RES",GMRCNDX," ") + ..I (GMRCMODE="electronic") S GMRCX=" Addendum Signature: "_GMRCSGNM_" /es/ "_$$EXDT($G(GMRCNMDT)) + ..I '(GMRCMODE="electronic") S GMRCX=" Addendum Author: "_GMRCSGNM S:$L($G(GMRCNMDT)) GMRCX=GMRCX_" Last edited: "_$$EXDT(GMRCNMDT) + ..D SUB("F","RES",GMRCNDX,GMRCX) + ..D:$L($G(GMRCTIT)) SUB("F","RES",GMRCNDX," "_GMRCTIT) + .I $L($G(GMRCCSDT)) D + ..D SUB("F","RES",GMRCNDX," ") + ..I (GMRCCSGM="electronic") S GMRCX=" Addendum CoSignature: "_GMRCCSIG_" /es/ "_$$EXDT(GMRCCSDT) + ..I '(GMRCCSGM="electronic") S GMRCX=" Addendum CoSignature: "_GMRCCSIG_" /chart/ "_$$EXDT(GMRCCSDT) + ..D SUB("F","RES",GMRCNDX,GMRCX) + ..D:$L($G(GMRCCTIT)) SUB("F","RES",GMRCNDX," "_GMRCCTIT) + .D BLD("RES",GMRCNDX,1,0," ") + .I $L($G(GMRCRPT)) D BLD("RES",GMRCNDX,1,0,$$CENTER("ADDENDUM #"_GMRCADD_" TO CONSULT NOTE #"_GMRCR0_" FOR "_GMRCRPT)) + .I '$L($G(GMRCRPT)) D BLD("RES",GMRCNDX,1,0,$$CENTER("ADDENDUM #"_GMRCADD_" TO CONSULT NOTE #"_GMRCR0)) + .D BLD("RES",GMRCNDX,1,0," ") + .S GMRCR1=0 F S GMRCR1=$O(^TMP("GMRCR",$J,"RES",GMRCR0,"ADD",GMRCADD,GMRCR1)) Q:'GMRCR1 D + ..D BLD("RES",GMRCNDX,1,0,$G(^TMP("GMRCR",$J,"RES",GMRCR0,"ADD",GMRCADD,GMRCR1,0))) + Q + ; +HDR ; Header code for form 513 + ; + N PG,GMRCFROM + ; + F PG=0,1 D + .D BLD("HDR",PG,1,0,GMRCDVL) + .D BLD("HDR",PG,1,6,"MEDICAL RECORD") + .D BLD("HDR",PG,0,29,"|") + .D BLD("HDR",PG,0,36,"CONSULTATION SHEET") + .I PG D BLD("HDR",PG,0,60,"Page ","GMRCPG,65") I 1 + .E I '$G(GMRCGUI) D BLD("HDR",PG,0,60,"Page ","GMRCPG,65") + .; + .D BLD("HDR",PG,1,0,GMRCDVL) + .D BLD("HDR",PG,1,0,"Consult Request: "_$$CONSRQ(GMRCIFN)) + .D BLD("HDR",PG,0,55,"|Consult No.: "_GMRCIFN) + .; + D BLD("HDR",1,1,0,GMRCEQL) + D BLD("HDR",0,1,0,GMRCDVL) + ; + I $G(CMT) D BLD("HDR",0,1,27,"("_$$PRCMT^GMRCP5B(CMT)_")") Q + ; + S GMRCFROM=$P($G(^SC(+$P(GMRCRD,U,6),0)),U,1) + ; + I '$L(GMRCFROM) D + .N VAIN + .D INP^VADPT + .S GMRCFROM=$P($G(VAIN(4)),U,2) + .I $L($G(VAIN(5))) S GMRCFROM=GMRCFROM_" (Rm/Bd: "_$G(VAIN(5))_" )" + ;No location, IFC - consulting site + I '$L(GMRCFROM),$P(GMRCRD,U,23),$P($G(GMRCRD(12)),U,5)="F" D + .I $P(GMRCRD,U,21) S GMRCFROM=$$GET1^DIQ(4,$P(GMRCRD,U,21),.01) + .E S GMRCFROM=$$GET1^DIQ(4,$P(GMRCRD,U,23),.01) + ; + D BLD("HDR",0,1,0,"To: "_$P($G(^GMR(123.5,+$P(GMRCRD,U,5),0)),U,1)) + D BLD("HDR",0,1,5,"From: "_GMRCFROM) + D BLD("HDR",0,0,49,"|Requested: "_$$EXDT($P(GMRCRD,U,7))) + ; + D BLD("HDR",0,1,0,GMRCDVL) + D BLD("HDR",0,1,0,"Requesting Facility: "_$E(GMRCFAC,1,22)) + I $P(GMRCRD,U,11) D BLD("HDR",0,0,45,"|ATTENTION: "_$E($P($G(^VA(200,+$P(GMRCRD,U,11),0)),U,1),1,21)) + I $P(GMRCRD,U,23) D + . D BLD("HDR",0,1,0,"Remote Consult No.: "_GMRCINO) + . D BLD("HDR",0,1,0,"Role: "_GMRCIRL) + D BLD("HDR",0,1,0,GMRCEQL) + ; + Q + ; +CENTER(X) ; + ; + N TEXT,COL + S COL=35-($L(X)\2) Q:(COL<1) X + S $E(TEXT,COL)=X + Q TEXT + ; +BLD(SUB,NDX,LINE,TAB,TEXT,RUNTIME) ; + ; + Q:'$L($G(SUB)) + N LINECNT + ; + F LINECNT=1:1:+LINE S ^TMP("GMRC",$J,"OUTPUT",SUB,NDX,$$LASTLN(SUB,NDX)+1,0)="" + ; + S $E(^TMP("GMRC",$J,"OUTPUT",SUB,NDX,$$LASTLN(SUB,NDX),0),TAB+1)=TEXT + I $L($G(RUNTIME)) S ^TMP("GMRC",$J,"OUTPUT",SUB,NDX,$$LASTLN(SUB,NDX),1)=RUNTIME + ; + S GMRCLAST=SUB + Q + ; +SUB(ZONE,SUB,NDX,TEXT) ; + ; + N NEXT + S NEXT=$O(^TMP("GMRC",$J,"OUTPUT",SUB,NDX,ZONE," "),-1)+1 + S ^TMP("GMRC",$J,"OUTPUT",SUB,NDX,ZONE,NEXT,0)=TEXT + Q + ; +LASTLN(SUB,NDX) ; + Q +$O(^TMP("GMRC",$J,"OUTPUT",SUB,NDX," "),-1) + ; +CONSRQ(IFN) ; + ; + N PTR,LINK,REF,GMRCRQ + I +$P(^GMR(123,+IFN,0),U,8) D + . S GMRCRQ=$P(^GMR(123,+IFN,0),U,8) + . S GMRCRQ=$$GET1^DIQ(123.3,+GMRCRQ,.01) + . I '$L(GMRCRQ) S GMRCRQ="Procedure" + I $L($G(GMRCRQ)) Q GMRCRQ + I $L($G(^GMR(123,IFN,1.11))) D + . N SERV,TYPE + . S SERV=$$UP^XLFSTR($$GET1^DIQ(123.5,$P(^GMR(123,IFN,0),U,5),.01)) + . S TYPE=$$UP^XLFSTR(^GMR(123,IFN,1.11)) I TYPE'=SERV D + . I TYPE'=SERV S GMRCRQ=$E(^GMR(123,IFN,1.11),1,36) + Q:$L($G(GMRCRQ)) GMRCRQ Q "Consult" + ; +EXDT(X) ;EXTERNAL DATE FORMAT + ; + N DATE,TIME,HR,MN,PD,Y,%DT + Q:'$L(X) "" + I '(X?7N.1".".6N) S %DT="PTS" D ^%DT S X=Y + Q $$FMTE^XLFDT(X,"5PMZ") + ; diff --git a/r/CONSULT_REQUEST_TRACKING-GMRC-GMRS-GMRT/GMRCSTL7.m b/r/CONSULT_REQUEST_TRACKING-GMRC-GMRS-GMRT/GMRCSTL7.m index 253b9ede..a370eb9c 100644 --- a/r/CONSULT_REQUEST_TRACKING-GMRC-GMRS-GMRT/GMRCSTL7.m +++ b/r/CONSULT_REQUEST_TRACKING-GMRC-GMRS-GMRT/GMRCSTL7.m @@ -1,257 +1,197 @@ -GMRCSTL7 ;SLC/JFR/WAT - DRIVER FOR CSLT PER MONITOR ;4/8/05 10:28 - ;;3.0;CONSULT/REQUEST TRACKING;**41,60**;DEC 27, 1997;Build 9 - ; - ;This routine invokes ICRs - ;1519(XUTMDEVQ,10103(XLFDT),10104(XLFSTR),3744(VADPT),10089(%ZISC),10026(DIR) - Q - ; -EN ; start here - K GMRCQUT - N DIROUT,DTOUT,DUOUT,DIR,Y,X,GMRCTMP,GMRCDG,GMRCSVC,GMRCSVNM,GMRCDT1 - N GMRCDT2,GMRCFMT,GMRCGRP,VALMBCK,GMRCSAVE - N GMRC30ST,GMRC30SP - D CAVEATS - ;Ask for service - S DIR(0)="P^123.5:EMQ",DIR("??")="^D LISTALL^GMRCASV" - S DIR("A")="Select Service/Specialty" - D ^DIR - I $D(DTOUT)!($D(DUOUT))!($D(DIROUT))!(X="") D EXIT Q - S GMRCDG=+Y,GMRCSVNM=$P(Y,U,2) - ;Ask for current FY - N DIROUT,DTOUT,DUOUT,DIR,Y,X,GMRCFY - S DIR(0)="F^4:4^K:(X-1700)>($E(DT,1,3)+1) X" - S DIR("A")="Current Fiscal Year (i.e. 2008)" - S DIR("A",1)="Ensure you are providing fiscal year, NOT calendar year." - D ^DIR - I $D(DTOUT)!($D(DUOUT))!($D(DIROUT))!(X="") D EXIT Q - S GMRCFY=X - N DIROUT,DTOUT,DUOUT,DIR,Y,X,GMRCQTR,GMRCYR - S DIR(0)="N^1:4" - S DIR("A")="Enter a number 1 - 4" - S DIR("A",1)="For which quarter are you running the report: first, second, third or fourth?" - D ^DIR - I $D(DTOUT)!($D(DUOUT))!($D(DIROUT))!(X="") D EXIT Q - S GMRCQTR=X - ;if first quarter - I $G(GMRCQTR)=1 D - .;use FY-1 to set year part of date range to the previous calendar year - .S GMRCYR=$G(GMRCFY)-1700 S GMRCYR=$G(GMRCYR)-1,GMRCDT1=$E($G(GMRCYR),1,3)_"1001" S GMRCDT2=$G(GMRCYR)_"1231" - I $G(GMRCQTR)=2 D - .S GMRCYR=$G(GMRCFY)-1700 S GMRCDT1=$E($G(GMRCYR),1,3)_"0101" S GMRCDT2=$G(GMRCYR)_"0331" - I $G(GMRCQTR)=3 D - .S GMRCYR=$G(GMRCFY)-1700 S GMRCDT1=$E($G(GMRCYR),1,3)_"0401" S GMRCDT2=$G(GMRCYR)_"0630" - I $G(GMRCQTR)=4 D - .S GMRCYR=$G(GMRCFY)-1700 S GMRCDT1=$E($G(GMRCYR),1,3)_"0701" S GMRCDT2=$G(GMRCYR)_"0930" - S GMRC30ST=$$FMADD^XLFDT(GMRCDT1,-30),GMRC30SP=$$FMADD^XLFDT(GMRCDT2,-30) - ; what type of report - N DIROUT,DTOUT,DUOUT,DIR,Y,X - S DIR(0)="S:O^S:Summary;D:Delimited",DIR("A")="What type of report" - D ^DIR - I $D(DTOUT)!($D(DUOUT))!($D(DIROUT))!(X="") D EXIT Q - S GMRCFMT=$S(Y="S":"CP",1:"DEL") - ; - W @IOF - S GMRCSAVE("GMRCFMT")="" - S GMRCSAVE("GMRCDG")="" - S GMRCSAVE("GMRCDT1")="" - S GMRCSAVE("GMRCDT2")="" - S GMRCSAVE("GMRC30ST")="" - S GMRCSAVE("GMRC30SP")="" - S GMRCSAVE("GMRCSVNM")="" - S GMRCSAVE("GMRCFY")="" - S GMRCSAVE("GMRCQTR")="" - ; - N DIROUT,DTOUT,DUOUT,DIR,Y,X S DIR(0)="FO",DIR("A")="ENTER ""?"" FOR MORE HELP OR RETURN TO CONTINUE" - S DIR("A",1)="MARGIN WIDTH IS BEST AT 256" - S DIR("?")="^D MARGHLP^GMRCSTL7" - D:GMRCFMT="DEL" ^DIR - I $D(DTOUT)!($D(DUOUT))!($D(DIROUT)) D EXIT Q - D EN^XUTMDEVQ("PRNTQ^GMRCSTL7","CONSULT PERFORMANCE MONITOR",.GMRCSAVE) - ; - D EXIT - ; - Q -MARGHLP ;help text to set margins - W !,"Specify a device with optional parameters in the format" - W !,?8,"Device Name;Right Margin;Page Length" - W !,?21,"or" - W !,?5,"Device Name;Subtype;Right Margin;Page Length" - W !!,"Or in the new format" - W !,?14,"Device Name;/settings" - W !,?21,"or" - W !,?10,"Device Name;Subtype;/settings" - W !,"For example" - W !,?17,"HOME;80;999" - W !,?21,"or" - W !,?13,"HOME;C-VT320;/M80L999" - Q - ; -ENOR(RETURN,GMRCSVC,GMRC30ST,GMRC30SP,GMRCSTAT,GMRCST2,GMRCARRN) ;Entry point - ;.RETURN: This is the root to the returned temp array. - ;GMRCSVC: Service for which consults are to be displayed. - ;GMRC30ST: 30 days prior to quarter start date - ;GMRC30SP: 30 days prior to quarter end date - ;GMRCSTAT: The list of status to include separated by commas - ;GMRCARRN: Format of report becomes ^TMP array element - ; "CP": Summary Report; "DEL": Delimited Report - ; - ;This temp array is used internally by the report: - ;^TMP("GMRCSLIST",$J,n)=ien^name^parient ien^"+" if grouper^status - ; status is "" tracking and/or grouper - ; 1 grouper only - ; 2 tracking only - ; 9 disabled - ; - N GMRCEDT1,GMRCEDT2,GMRCDG,GMRCHEAD,GMRCGRP,VALMCNT,VALMBCK - K ^TMP("GMRCR",$J,GMRCARRN) - S RETURN="^TMP(""GMRCR"",$J,GMRCARRN)" - I '($D(GMRCSVC)#2) S GMRCSVC=1 - Q:'$D(^GMR(123.5,$G(GMRCSVC),0)) - ;Build service array - S GMRCDG=GMRCSVC - D SERV1^GMRCASV - ;Get external form of date range - D LISTDATE^GMRCSTU1(GMRCDT1,$G(GMRCDT2),.GMRCEDT1,.GMRCEDT2) - ; - N GMRCDA,INDEX,STATUS,STATUS2,LOOP,GROUPER - N GMRCSVCG,GMRCPT,GMRCSVCP,GRP,PIECE,TYPE - ; - K ^TMP("GMRCR",$J,GMRCARRN),^TMP("GMRCRINDEX",$J),^TMP("GMRCT",$J) - ; - S GROUPER=0 - S GROUPER(0)=0 - I GMRCARRN="DEL" D - . N STR - . S STR="Svc;30DayRng;60DayRng;CmpIn30;Cmp31-60;B4Qtr;PndB4Qtr;%Cmp30;%Cmp60;%UnRsB4Qtr;IS30Rng;IS60Rng;ISCmp30;ISCmp31-60;ISB4Qtr;ISPndB4Qtr;%ISCmp30;%ISCmp60;%ISUnRsB4Qtr;" - . S STR=STR_"IR30Rng;IR60Rng;IRCmp30;IRCmp31-60;IRB4Qtr;IRPndB4Qtr;%IRCmp30;%IRCmp60;%IRUnRsB4Qtr" - . S ^TMP("GMRCR",$J,GMRCARRN,1,0)=STR - S INDEX="" - ;Loop on Service - F S INDEX=$O(^TMP("GMRCSLIST",$J,INDEX)) Q:INDEX="" D - .S GMRCSVC=$P(^TMP("GMRCSLIST",$J,INDEX),"^",1) - .S GMRCSVCP=$P(^TMP("GMRCSLIST",$J,INDEX),"^",2) - .S GMRCSVCG=$P(^TMP("GMRCSLIST",$J,INDEX),"^",3) - .N SUBIDX - .;pieces for tmp arrays, 1 to 6 are local, 7 to 12 are IFC placer, 13 to 18 are IFC filler - .;;total for 30 day start/end^total for 60 day start/end^results n 30 days^results n 60 days^total before quarter^total pending before quarter - .S ^TMP("GMRCT",$J,1,GMRCSVC,"DATA")="0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0" - .S ^TMP("GMRCT",$J,2,GMRCSVC,"DATA")="0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0" - .;Check if starting a new Grouper - .F Q:GROUPER(GROUPER)=GMRCSVCG D - ..;End of a group so print the group totals - ..I GROUPER(GROUPER)=GMRCSVCG D - ... I GMRCARRN="CP" D - ....D PRTTOT^GMRCSTL8(2,GROUPER(GROUPER),GMRCARRN) - ...I GMRCARRN="DEL" D - ....D DELTOT^GMRCSTL8(2,GROUPER(GROUPER),GMRCARRN) - ..;pop grouper from stack - ..S GROUPER=GROUPER-1 - .I $P(^TMP("GMRCSLIST",$J,INDEX),"^",4)="+" D - ..;push new grouper on stack - ..S GROUPER=GROUPER+1 - ..S GROUPER(GROUPER)=GMRCSVC - .;Loop for one status at a time - .F LOOP=1:1:$L(GMRCSTAT,",") S STATUS=$P(GMRCSTAT,",",LOOP) D - ..D ONESTAT^GMRCSTL8(GMRCARRN,INDEX,STATUS,GMRC30ST,GMRC30SP,"30") - .F LOOP=1:1:$L(GMRCSTAT,",") S STATUS=$P(GMRCSTAT,",",LOOP) D - ..D ONESTAT^GMRCSTL8(GMRCARRN,INDEX,STATUS,$$FMADD^XLFDT(GMRC30ST,-30),$$FMADD^XLFDT(GMRC30SP,-30),"60") - .S GMRCDT1=$$FMADD^XLFDT(GMRC30ST,30) ;add 30 days back to set date back to start of FY quarter. - .F LOOP=1:1:$L(GMRCST2,",") S STATUS2=$P(GMRCST2,",",LOOP) D - ..D ONESTAT2^GMRCSTL8(GMRCARRN,INDEX,STATUS2,$$FMADD^XLFDT(GMRCDT1,-60)) - .F GRP=GROUPER:-1:1 D - ..F PIECE=1:1:18 D - ...S $P(^TMP("GMRCT",$J,2,GROUPER(GRP),"DATA"),U,PIECE)=$P(^TMP("GMRCT",$J,2,GROUPER(GRP),"DATA"),U,PIECE)+$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,PIECE) - .; - .;Print the totals for this service that are >0 - .I GMRCARRN="CP" D - ..D PRTTOT^GMRCSTL8(1,GMRCSVC,GMRCSVCP,GMRCARRN) - .I GMRCARRN="DEL" D - ..D DELTOT^GMRCSTL8(1,GMRCSVC,GMRCSVCP,GMRCARRN) - .Q - ; - ;Done, so now list the group totals for the top group - ;F GROUPER=GROUPER:-1:1 D ; left for looking at all totals in future - I $G(GROUPER) S GROUPER=1 D - .I GMRCARRN="CP" D - ..D PRTTOT^GMRCSTL8(2,GROUPER(GROUPER),$P(^GMR(123.5,GROUPER(GROUPER),0),"^",1),GMRCARRN) - .I GMRCARRN="DEL" D - ..D DELTOT^GMRCSTL8(2,GROUPER(GROUPER),$P(^GMR(123.5,GROUPER(GROUPER),0),"^",1),GMRCARRN) - Q -PRNTQ ;Build report and print it - ; - N GMRCPG,GMRCTMP,IDX,GMRCQUT,TEMP - S GMRCPG=1 - D SERV1^GMRCASV - D HEAD(GMRCPG) S GMRCPG=GMRCPG+1 - S TEMP=$S($G(GMRCQTR)=4:"4",$G(GMRCQTR)=3:"3",$G(GMRCQTR)=2:"2",1:"1")_"Q"_"FY"_$E($G(GMRCFY),3,4) - S TEMP="Consult/Request Performance Monitor - "_TEMP - W $J("",40-($L(TEMP)/2)+.5)_TEMP - S TEMP="Fiscal Quarter Dates: "_$$FMTE^XLFDT(GMRCDT1)_" - "_$$FMTE^XLFDT(GMRCDT2) - W !,$J("",40-($L(TEMP)/2)+.5)_TEMP - S TEMP="30 Days Before Start/End: "_$$FMTE^XLFDT(GMRC30ST)_" - "_$$FMTE^XLFDT(GMRC30SP) - W !,$J("",40-($L(TEMP)/2)+.5)_TEMP - S TEMP="60 Days Before Start/End: "_$$FMTE^XLFDT($$FMADD^XLFDT(GMRC30ST,-30))_" - "_$$FMTE^XLFDT($$FMADD^XLFDT(GMRC30SP,-30)) - W !,$J("",40-($L(TEMP)/2)+.5)_TEMP,! - I '$D(IO("Q")) D WAIT^DICD W !! - I '$O(^TMP("GMRCSLIST",$J,0)) D G EXIT - .W !!,"No records to print" - D ENOR^GMRCSTL7(.GMRCTMP,GMRCDG,GMRC30ST,GMRC30SP,"2,5,6,8,9","1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,99",GMRCFMT) - I '$D(^TMP("GMRCR",$J,GMRCFMT)) D - .W !!,"No records to print",! - S IDX="" - F S IDX=$O(^TMP("GMRCR",$J,GMRCFMT,IDX)) Q:'IDX!($G(GMRCQUT)) D - .I IOSL-$Y<3 D - ..I $E(IOST,1,2)["C-" D - ...N DIR S DIR(0)="E" D ^DIR - ...I 'Y S GMRCQUT=1 - ..Q:$G(GMRCQUT) - ..D HEAD(GMRCPG) S GMRCPG=GMRCPG+1 - .Q:$G(GMRCQUT) - .W ^TMP("GMRCR",$J,GMRCFMT,IDX,0),! - D:$D(^TMP("GMRCR",$J,GMRCFMT)) CAVEATS - I GMRCFMT="CP",'$G(GMRCQUT) D - .Q:$O(^TMP("GMRCT",$J,0,""))="" - .I IOSL-$Y<6 D HEAD(GMRCPG) S GMRCPG=GMRCPG+1 - .W !!!,$$REPEAT^XLFSTR("-",IOM-5) - .W !,"Consult services not meeting the criteria of this report for",!,"the specified date range:",! - .S IDX="" - .F S IDX=$O(^TMP("GMRCT",$J,0,IDX)) Q:IDX=""!($G(GMRCQUT)) D - ..I IOSL-$Y<3 D - ...I $E(IOST,1,2)["C-" D - ....N DIR S DIR(0)="E" D ^DIR - ....I 'Y S GMRCQUT=1 - ...Q:$G(GMRCQUT) - ...D HEAD(GMRCPG) S GMRCPG=GMRCPG+1 - ..Q:$G(GMRCQUT) - ..W ?4,IDX,! - D ^%ZISC - D EXIT - Q - ; -HEAD(PAGE) ; print header for CPM - W @IOF - I PAGE>1 D - .S TEMP=$S($G(GMRCQTR)=4:"4",$G(GMRCQTR)=3:"3",$G(GMRCQTR)=2:"2",1:"1")_"Q"_"FY"_$E($G(GMRCFY),3,4) - .S TEMP="Consult/Request Performance Monitor - "_TEMP - .W !,$J("",40-($L(TEMP)/2)+.5)_TEMP,! - W !,$J("Run Date: "_$$HTE^XLFDT($H),0),$J("Page: "_PAGE,48) - W !,$$REPEAT^XLFSTR("-",IOM-2),!! - Q - ; -CAVEATS ; brief explanatory text - W !!,"Resubmitted requests are evaluated based on the original Date of Request." - W !!,"The following are excluded from this report:" - W !," -Requests sent to test patients." - W !," -Requests not marked as Outpatient in the REQUEST/CONSULTATION file." - W !," -Services flagged as part of the interface between Consults/Request Tracking" - W !,?2,"and Prosthetics." - W !," -Administrative requests flagged via the Administrative fields in the" - W !,?2,"REQUEST SERVICES and REQUEST/CONSULTATION files. This is not retroactive" - W !,?2,"and only applies to services/requests leveraging the Administrative-flagging" - W !,?2,"capability included in GMRC*3.0*60, available on or about June 2008.",!! - Q - ; -EXIT F ARR="GMRCR","GMRCS","GMRCSLIST","GMRCT" K ^TMP(ARR,$J) - K ARR - Q - ; +GMRCSTL7 ;SLC/JFR - DRIVER FOR CSLT PER MONITOR ;4/8/05 10:28 + ;;3.0;CONSULT/REQUEST TRACKING;**41**;DEC 27, 1997 + ; + Q + ; +EN ; start here + K GMRCQUT + N DIROUT,DTOUT,DUOUT,DIR,DIRUT,GMRCTMP,GMRCDG,GMRCSVC,GMRCSVNM,GMRCDT1 + N GMRCDT2,GMRCFMT,GMRCGRP,VALMBCK,GMRCSAVE + ; + ;Ask for service + N Y + S DIR(0)="PO^123.5:EMQ",DIR("??")="^D LISTALL^GMRCASV" + S DIR("A")="Select Service/Specialty" + D ^DIR + I Y<1 Q + S GMRCDG=+Y,GMRCSVNM=$P(Y,U,2) + ; + ;Ask for date range + D ^GMRCSPD + I $D(GMRCQUT) G EXIT + ; + ; what type of report + K DIR,X,Y + S DIR(0)="S:O^S:Summary;D:Delimited",DIR("A")="What type of report" + D ^DIR + I Y="" G EXIT + S GMRCFMT=$S(Y="S":"CP",1:"DEL") + ; + W @IOF + S GMRCSAVE("GMRCFMT")="" + S GMRCSAVE("GMRCDG")="" + S GMRCSAVE("GMRCDT1")="" + S GMRCSAVE("GMRCDT2")="" + S GMRCSAVE("GMRCSVNM")="" + ; + D EN^XUTMDEVQ("PRNTQ^GMRCSTL7","CONSULT PERFORMANCE MONITOR",.GMRCSAVE) + ; + D EXIT + ; + Q + ; +ENOR(RETURN,GMRCSVC,GMRCDT1,GMRCDT2,GMRCSTAT,GMRCARRN) ;Entry point + ;.RETURN: This is the root to the returned temp array. + ;GMRCSVC: Service for which consults are to be displayed. + ;GMRCDT1: Starting date or "ALL" + ;GMRCDT2: Ending date if not GMRCDT1="ALL" + ;GMRCSTAT: The list of status to include separated by commas + ;GMRCARRN: Format of report becomes ^TMP array element + ; "CP": Summary Report; "DEL": Delimited Report + ; + ;This temp array is used internally by the report: + ;^TMP("GMRCSLIST",$J,n)=ien^name^parient ien^"+" if grouper^status + ; status is "" tracking and/or grouper + ; 1 grouper only + ; 2 tracking only + ; 9 disabled + ; + N GMRCEDT1,GMRCEDT2,GMRCDG,GMRCHEAD,GMRCGRP,VALMCNT,VALMBCK + K ^TMP("GMRCR",$J,GMRCARRN) + S RETURN="^TMP(""GMRCR"",$J,GMRCARRN)" + I '($D(GMRCSVC)#2) S GMRCSVC=1 + Q:'$D(^GMR(123.5,$G(GMRCSVC),0)) + ;Build service array + S GMRCDG=GMRCSVC + D SERV1^GMRCASV + ;Get external form of date range + I '($D(GMRCDT1)#2) S GMRCDT1="ALL" + S:GMRCDT1="ALL" GMRCDT2=0 + D LISTDATE^GMRCSTU1(GMRCDT1,$G(GMRCDT2),.GMRCEDT1,.GMRCEDT2) + ; + N GMRCDA,INDEX,STATUS,LOOP,GROUPER + N STS,GMRCD,GMRCDT,GMRCSVCG,TEMP,GMRCPT,LINETEMP + N GMRCPTN,GMRCPTSN,GMRCDLA,GMRCXDT,GMRCLOC,GMRCSVCP + N GRP,GMRCIRF,GMRCIRFN,GMRCIDD,GMRCST,GMRCRDT + ; + K ^TMP("GMRCR",$J,GMRCARRN),^TMP("GMRCRINDEX",$J),^TMP("GMRCTOT",$J) + ; + S GROUPER=0 + S GROUPER(0)=0 + I GMRCARRN="DEL" D + . N STR + . S STR="Service;Total;Unresolved;Complete;Comp w/Results;%Complete;" + . S STR=STR_"%Comp w/Results" + . S ^TMP("GMRCR",$J,GMRCARRN,1,0)=STR + S INDEX="" + ;Loop on Service + F S INDEX=$O(^TMP("GMRCSLIST",$J,INDEX)) Q:INDEX="" D + .S GMRCSVC=$P(^TMP("GMRCSLIST",$J,INDEX),"^",1) + .S GMRCSVCP=$P(^TMP("GMRCSLIST",$J,INDEX),"^",2) + .S GMRCSVCG=$P(^TMP("GMRCSLIST",$J,INDEX),"^",3) + .S ^TMP("GMRCTOT",$J,1,GMRCSVC,"T")=0 + .S ^TMP("GMRCTOT",$J,1,GMRCSVC,"P")=0 + .S ^TMP("GMRCTOT",$J,1,GMRCSVC,"R")=0 + .S ^TMP("GMRCTOT",$J,1,GMRCSVC,"C")=0 + .S ^TMP("GMRCTOT",$J,2,GMRCSVC,"T")=0 + .S ^TMP("GMRCTOT",$J,2,GMRCSVC,"P")=0 + .S ^TMP("GMRCTOT",$J,2,GMRCSVC,"R")=0 + .S ^TMP("GMRCTOT",$J,2,GMRCSVC,"C")=0 + . ;Check if starting a new Grouper + . F Q:GROUPER(GROUPER)=GMRCSVCG D + ..;End of a group so print the group totals + ..I GROUPER(GROUPER)=GMRCSVCG D + ... I GMRCARRN="CP" D + .... D PRTTOT^GMRCSTL8(2,GROUPER(GROUPER),GMRCARRN) + ... I GMRCARRN="DEL" D + .... D DELTOT^GMRCSTL8(2,GROUPER(GROUPER),GMRCARRN) + ..;pop grouper from stack + ..S GROUPER=GROUPER-1 + .I $P(^TMP("GMRCSLIST",$J,INDEX),"^",4)="+" D + ..;push new grouper on stack + ..S GROUPER=GROUPER+1 + ..S GROUPER(GROUPER)=GMRCSVC + .;Loop for one status at a time + .F LOOP=1:1:$L(GMRCSTAT,",") S STATUS=$P(GMRCSTAT,",",LOOP) D + .. D ONESTAT^GMRCSTL8(GMRCARRN,INDEX,STATUS,GMRCDT1,GMRCDT2) + .F GRP=GROUPER:-1:1 D + ..; pending for this service to all of its groupers + ..S ^TMP("GMRCTOT",$J,2,GROUPER(GRP),"P")=$G(^TMP("GMRCTOT",$J,2,GROUPER(GRP),"P"))+^TMP("GMRCTOT",$J,1,GMRCSVC,"P") + .. ; completed w/results for all groupers + .. S ^TMP("GMRCTOT",$J,2,GROUPER(GRP),"R")=$G(^TMP("GMRCTOT",$J,2,GROUPER(GRP),"R"))+^TMP("GMRCTOT",$J,1,GMRCSVC,"R") + ..; for all status for this service to all of its groupers + ..S ^TMP("GMRCTOT",$J,2,GROUPER(GRP),"T")=$G(^TMP("GMRCTOT",$J,2,GROUPER(GRP),"T"))+^TMP("GMRCTOT",$J,1,GMRCSVC,"T") + .. ; add all completed for all groupers + .. S ^TMP("GMRCTOT",$J,2,GROUPER(GRP),"C")=$G(^TMP("GMRCTOT",$J,2,GROUPER(GRP),"C"))+^TMP("GMRCTOT",$J,1,GMRCSVC,"C") + .; + .;Print the totals for this service that are >0 + . I GMRCARRN="CP" D + .. D PRTTOT^GMRCSTL8(1,GMRCSVC,GMRCSVCP,GMRCARRN) + . I GMRCARRN="DEL" D + .. D DELTOT^GMRCSTL8(1,GMRCSVC,GMRCSVCP,GMRCARRN) + . Q + ; + ;Done, so now list the group totals for the top group + ;F GROUPER=GROUPER:-1:1 D ; left for looking at all totals in future + I $G(GROUPER) S GROUPER=1 D + . I GMRCARRN="CP" D + .. D PRTTOT^GMRCSTL8(2,GROUPER(GROUPER),$P(^GMR(123.5,GROUPER(GROUPER),0),"^",1),GMRCARRN) + . I GMRCARRN="DEL" D + .. D DELTOT^GMRCSTL8(2,GROUPER(GROUPER),$P(^GMR(123.5,GROUPER(GROUPER),0),"^",1),GMRCARRN) + Q + ; +PRNTQ ;Build report and print it + ; + N GMRCPG,GMRCTMP,IDX,GMRCQUT,TEMP + S GMRCPG=1 + D SERV1^GMRCASV + D HEAD(GMRCPG) S GMRCPG=GMRCPG+1 + W !,$J("",23)_"Consult/Request Performance Monitor" + S TEMP="FROM: "_$$FMTE^XLFDT(GMRCDT1)_" TO: "_$$FMTE^XLFDT(GMRCDT2) + I GMRCDT1="ALL" S TEMP="ALL DATES" + W !,$J("",40-($L(TEMP)/2)+.5)_TEMP,! + I '$O(^TMP("GMRCSLIST",$J,0)) D G EXIT + . W !!,"No records to print" + D ENOR^GMRCSTL7(.GMRCTMP,GMRCDG,GMRCDT1,GMRCDT2,"5,6,8,2,9",GMRCFMT) + I '$D(^TMP("GMRCR",$J,GMRCFMT)) D + . W !!,"No records to print",! + S IDX="" + F S IDX=$O(^TMP("GMRCR",$J,GMRCFMT,IDX)) Q:'IDX!($G(GMRCQUT)) D + . I IOSL-$Y<3 D + .. I $E(IOST,1,2)["C-" D + ... N DIR S DIR(0)="E" D ^DIR + ... I 'Y S GMRCQUT=1 + .. Q:$G(GMRCQUT) + .. D HEAD(GMRCPG) S GMRCPG=GMRCPG+1 + . Q:$G(GMRCQUT) + . W ^TMP("GMRCR",$J,GMRCFMT,IDX,0),! + I GMRCFMT="CP",'$G(GMRCQUT) D + . Q:$O(^TMP("GMRCTOT",$J,0,""))="" + . I IOSL-$Y<6 D HEAD(GMRCPG) S GMRCPG=GMRCPG+1 + . W !!!,$$REPEAT^XLFSTR("-",IOM-5) + . W !,"Consult services with no activity meeting the criteria of this report in",!,"the specified date range:",! + . S IDX="" + . F S IDX=$O(^TMP("GMRCTOT",$J,0,IDX)) Q:IDX=""!($G(GMRCQUT)) D + .. I IOSL-$Y<3 D + ... I $E(IOST,1,2)["C-" D + .... N DIR S DIR(0)="E" D ^DIR + .... I 'Y S GMRCQUT=1 + ... Q:$G(GMRCQUT) + ... D HEAD(GMRCPG) S GMRCPG=GMRCPG+1 + .. Q:$G(GMRCQUT) + .. W ?4,IDX,! + D ^%ZISC + D EXIT + Q + ; +HEAD(PAGE) ; print header for CPM + W @IOF + W "Consult Performance Monitor",?40,$$HTE^XLFDT($H) + W ?73,"Page: ",PAGE,! + W $$REPEAT^XLFSTR("-",IOM-2),! + Q + ; +EXIT F ARR="GMRCR","GMRCS","GMRCSLIST","GMRCTOT" K ^TMP(ARR,$J) + K ARR + Q + ; diff --git a/r/CONSULT_REQUEST_TRACKING-GMRC-GMRS-GMRT/GMRCSTL8.m b/r/CONSULT_REQUEST_TRACKING-GMRC-GMRS-GMRT/GMRCSTL8.m index 9691527e..95309359 100644 --- a/r/CONSULT_REQUEST_TRACKING-GMRC-GMRS-GMRT/GMRCSTL8.m +++ b/r/CONSULT_REQUEST_TRACKING-GMRC-GMRS-GMRT/GMRCSTL8.m @@ -1,194 +1,113 @@ -GMRCSTL8 ;SLC/JFR/WAT - Totals format for CPM ; 4/05/05 10:39 - ;;3.0;CONSULT/REQUEST TRACKING;**41,60**;DEC 27, 1997;Build 9 - ; This routine invokes ICRs - ; 875 (file 100.01), 2638 (file 100.01),10104 (XLFSTR),10103 (XLFDT),3744 (VADPT) - ; - ; portions copied from GMRCSTL1 & GMRCSTL2 - Q ; can't start here -PRTTOT(GEN,INDEX,NAME,ARRN) ; totals for printed report - N QUIT S QUIT=0 D NOACTVT Q:QUIT=1 - N GMRCPCT,LAYOUT,FRMT,ROWTEXT,CALC1,CALC2,CALC3,ROWTXT - N COUNT,SVCUSG - S COUNT=$O(^TMP("GMRCR",$J,ARRN," "),-1) - I GEN=2 D - .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)="" - .S SVCUSG=$P(^GMR(123.5,INDEX,0),U,2) I $G(SVCUSG) S NAME=NAME_$S(SVCUSG=1:" ",SVCUSG=2:" ",1:"") - .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)=" GROUPER: "_NAME_" Totals:" - .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)=$J("WITHIN IFC IFC",75) - .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)=$J("FACILITY SENT REC'D",77) - I GEN=1 D - .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)=" " - .I $P(^GMR(123.5,INDEX,0),U,2)=9 S NAME=NAME_" " - .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)="SERVICE: "_NAME - .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)=$J("WITHIN IFC IFC",76) - .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)=$J("FACILITY SENT REC'D",78) - .S ROWTXT=$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U),8)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,7),10)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,13),9) - .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)="All Requests in 30 Days Before Start/End of Qtr:"_ROWTXT - .S ROWTXT=$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,2),8)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,8),10)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,14),9) - .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)="All Requests in 60 Days Before Start/End of Qtr:"_ROWTXT - I GEN=2 D - .S ROWTXT=$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U),8)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,7),10)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,13),9) - .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)="All Requests in 30 Days Before Start/End of Qtr:"_ROWTXT - .S ROWTXT=$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,2),8)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,8),10)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,14),9) - .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)="All Requests in 60 Days Before Start/End of Qtr:"_ROWTXT - I GEN=1!(GEN=2) D - .S ROWTXT=$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,3),12)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,9),10)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,15),9) - .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)="Complete with Results in 30 Days of Request:"_ROWTXT - .S ROWTXT=$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,4),12)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,10),10)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,16),9) - .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)="Complete with Results 31-60 Days of Request:"_ROWTXT - .S ROWTXT=$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,5),10)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,11),10)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,17),9) - .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)="All Requests Created 60 Days Before Qtr Start:"_ROWTXT - .S ROWTXT=$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,6),10)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,12),10)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,18),9) - .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)="All Requests Pending 60 Days Before Qtr Start:"_ROWTXT - .;% complete in 30 days of request - .I $P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U)>0 S CALC1=$J(($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,3)/$P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U))*100,2,2)_"%" - .S ROWTXT=$S($G(CALC1)="":$$REPEAT^XLFSTR(" ",10-$L("N / A"))_"N / A",1:$$REPEAT^XLFSTR(" ",10-$L(CALC1))_CALC1) - .I $P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,7)>0 S CALC2=$J(($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,9)/$P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,7))*100,2,2)_"%" - .S ROWTXT=ROWTXT_$S('$D(CALC2):$$REPEAT^XLFSTR(" ",10-$L("N / A"))_"N / A",1:$$REPEAT^XLFSTR(" ",10-$L(CALC2))_CALC2) - .I $P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,13)>0 S CALC3=$J(($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,15)/$P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,13))*100,2,2)_"%" - .S ROWTXT=ROWTXT_$S($G(CALC3)="":$$REPEAT^XLFSTR(" ",9-$L("N / A"))_"N / A",1:$$REPEAT^XLFSTR(" ",9-$L(CALC3))_CALC3) - .S COUNT=COUNT+1 - .S ^TMP("GMRCR",$J,ARRN,COUNT,0)="Percent Complete w/Results in 30 Days of Request: "_ROWTXT - .;% complete in 60 days of request - .K CALC1,CALC2,CALC3 - .I $P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,2)>0 S CALC1=$J(($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,4)/$P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,2))*100,2,2)_"%" - .S ROWTXT=$S($G(CALC1)="":$$REPEAT^XLFSTR(" ",10-$L("N / A"))_"N / A",1:$$REPEAT^XLFSTR(" ",10-$L(CALC1))_CALC1) - .I $P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,8)>0 S CALC2=$J(($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,10)/$P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,8))*100,2,2)_"%" - .S ROWTXT=ROWTXT_$S('$D(CALC2):$$REPEAT^XLFSTR(" ",10-$L("N / A"))_"N / A",1:$$REPEAT^XLFSTR(" ",10-$L(CALC2))_CALC2) - .I $P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,14)>0 S CALC3=$J(($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,16)/$P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,14))*100,2,2)_"%" - .S ROWTXT=ROWTXT_$S($G(CALC3)="":$$REPEAT^XLFSTR(" ",9-$L("N / A"))_"N / A",1:$$REPEAT^XLFSTR(" ",9-$L(CALC3))_CALC3) - .S COUNT=COUNT+1 - .S ^TMP("GMRCR",$J,ARRN,COUNT,0)="Percent Complete w/Results 31-60 Days of Request: "_ROWTXT - .;% pending before quarter start - .K CALC1,CALC2,CALC3 - .I $P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,5)>0 S CALC1=$J(($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,6)/$P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,5))*100,2,2)_"%" - .S ROWTXT=$S($G(CALC1)="":$$REPEAT^XLFSTR(" ",10-$L("N / A"))_"N / A",1:$$REPEAT^XLFSTR(" ",10-$L(CALC1))_CALC1) - .I $P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,11)>0 S CALC2=$J(($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,12)/$P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,11))*100,2,2)_"%" - .S ROWTXT=ROWTXT_$S('$D(CALC2):$$REPEAT^XLFSTR(" ",10-$L("N / A"))_"N / A",1:$$REPEAT^XLFSTR(" ",10-$L(CALC2))_CALC2) - .I $P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,17)>0 S CALC3=$J(($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,18)/$P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,17))*100,2,2)_"%" - .S ROWTXT=ROWTXT_$S($G(CALC3)="":$$REPEAT^XLFSTR(" ",9-$L("N / A"))_"N / A",1:$$REPEAT^XLFSTR(" ",9-$L(CALC3))_CALC3) - .S COUNT=COUNT+1 - .S ^TMP("GMRCR",$J,ARRN,COUNT,0)="Percent Still Pending Created Before Qtr Start: "_ROWTXT - Q -DELTOT(GEN,INDEX,NAME,ARRN) ; format for delimited - N QUIT S QUIT=0 D NOACTVT Q:QUIT=1 - N STRING,COUNT,PIECE,INCR,SVCUSG - S SVCUSG=$P(^GMR(123.5,INDEX,0),U,2) I $G(SVCUSG) S NAME=NAME_$S(SVCUSG=1:" ",SVCUSG=2:" ",1:"") - S COUNT=$O(^TMP("GMRCR",$J,ARRN," "),-1),STRING=$S(GEN=2:"GROUPER: ",1:"")_NAME_";" - F PIECE=1:1:18 D - .S STRING=STRING_$P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,PIECE)_";" - .I PIECE=6!(PIECE=12)!(PIECE=18) D - ..S INCR=$S(PIECE=6:0,PIECE=12:6,1:12) - ..;percents - ..I $P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,(1+INCR))=0 S STRING=STRING_"N/A;" - ..E S GMRCPCT=($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,(3+INCR))/$P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,(1+INCR)))*100,STRING=STRING_$J(GMRCPCT,0,2)_";" - ..I $P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,(2+INCR))=0 S STRING=STRING_"N/A;" - ..E S GMRCPCT=($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,(4+INCR))/$P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,(2+INCR)))*100,STRING=STRING_$J(GMRCPCT,0,2)_";" - ..I $P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,(5+INCR))=0 S STRING=STRING_"N/A;" - ..E S GMRCPCT=($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,(6+INCR))/$P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,(5+INCR)))*100,STRING=STRING_$J(GMRCPCT,0,2)_";" - S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)=STRING - Q -NOACTVT ;services with no activity for the reporting period - N CONT,PIECE S CONT=1 - I GEN=1&($P(^GMR(123.5,INDEX,0),U,2)=1) S QUIT=1 Q ;;don't add to list if service is a grouper only... - F PIECE=1:1:18 D Q:CONT=0 - .I $P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,PIECE)>0 S CONT=0 Q - S:CONT=1 ^TMP("GMRCT",$J,0,NAME)="",QUIT=1 - Q -ONESTAT(ARRN,SVCN,STAT,DT1,DT2,STR) ;Process one status - ;Input -- ARRN "CP" - to be printed or "DEL" - in delimited format - ;SVCN = node in ^TMP("GMRCLIST,$J..STAT = status being worked on..DT1 = starting date..DT2 = ending date - ;STR = string value used to store 30/60 day results in correct piece of ^tmp arrays - ;Output - None - N GMRCPT,GMRCXDT,TEMP,GMRCSVC,GMRCSVCG,GMRCSVCP,GMRCQT,FLG,TYPE - S GMRCSVC=$P(^TMP("GMRCSLIST",$J,SVCN),"^",1) - S GMRCSVCP=$P(^TMP("GMRCSLIST",$J,SVCN),"^",2) - S GMRCSVCG=$P(^TMP("GMRCSLIST",$J,SVCN),"^",3) - S GMRCXDT=9999999-DT2-.6 ;start searching the global at a date a fraction newer than DT2 (the end date for this search) - F S GMRCXDT=$O(^GMR(123,"AE",GMRCSVC,STAT,GMRCXDT)) Q:GMRCXDT=""!(GMRCXDT>(9999999-DT1)) D - .S GMRCPT=0 - .;Loop for one consult at a time - .F S GMRCPT=$O(^GMR(123,"AE",GMRCSVC,STAT,GMRCXDT,GMRCPT)) Q:GMRCPT="" D - ..S FLG=0 D EXCLUDE Q:$G(FLG)=1 - ..S TYPE="" D REQTYPE - ..I TYPE="LOCAL" D ;set totals for 30 and 60 day range - ...S:STR="30" $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U)=$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U)+1 - ...S:STR="60" $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,2)=$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,2)+1 - ...I STAT=2 D - ....Q:'$O(^GMR(123,+$G(GMRCPT),50,0)) ;Q if no results - ....D CHKRNG - ..I TYPE="IFCP" D - ...S:STR="30" $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,7)=$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,7)+1 - ...S:STR="60" $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,8)=$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,8)+1 - ...D:STAT=2 CHKRNG - ..I TYPE="IFCF" D - ...S:STR="30" $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,13)=$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,13)+1 - ...S:STR="60" $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,14)=$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,14)+1 - ...D:STAT=2 CHKRNG - Q - ; -ONESTAT2(ARRN,SVCN,STAT,DT1) ;all statuses, all requests, before quarter start - ;Input -- ARRN "CP" - to be printed or "DEL" - in delimited format - ;SVCN = node in ^TMP("GMRCLIST,$J..STAT = status being worked on..DT1 = 60 days before starting date of current quarter - ;Output -- None - N GMRCPT,GMRCXDT,TEMP,GMRCSVC,GMRCSVCG,GMRCSVCP,FLG,TYPE - S GMRCSVC=$P(^TMP("GMRCSLIST",$J,SVCN),"^",1) - S GMRCSVCP=$P(^TMP("GMRCSLIST",$J,SVCN),"^",2) - S GMRCSVCG=$P(^TMP("GMRCSLIST",$J,SVCN),"^",3) - S GMRCXDT="" - F S GMRCXDT=$O(^GMR(123,"AE",GMRCSVC,STAT,GMRCXDT)) Q:GMRCXDT="" D - .S GMRCPT=0 - .;Loop for one consult at a time - .F S GMRCPT=$O(^GMR(123,"AE",GMRCSVC,STAT,GMRCXDT,GMRCPT)) Q:GMRCPT="" D - ..Q:GMRCXDT<(9999999-DT1-.6) ; - ..S FLG=0 D EXCLUDE Q:$G(FLG)=1 - ..S TYPE="" D REQTYPE - ..I TYPE="LOCAL" D - ...S $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,5)=$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,5)+1 - ...; get unresolved requests for the period - ...S:",3,4,5,6,8,9,11,99,"[(","_STAT_",") $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,6)=$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,6)+1 - ..I TYPE="IFCP" D - ...S $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,11)=$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,11)+1 - ...S:",3,4,5,6,8,9,11,99,"[(","_STAT_",") $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,12)=$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,12)+1 - ..I TYPE="IFCF" D - ...S $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,17)=$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,17)+1 - ...S:",3,4,5,6,8,9,11,99,"[(","_STAT_",") $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,18)=$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,18)+1 - Q -REQTYPE ;If the request is being requested and performed locally, this field will be blank; Placer done elsewhere, Filler done locally - I $P(^GMR(123,$G(GMRCPT),0),U,23)="" S TYPE="LOCAL" Q - I $P(^GMR(123,$G(GMRCPT),0),U,23)'=""&($P($G(^GMR(123,GMRCPT,12)),U,5)="P") S TYPE="IFCP" Q - I $P(^GMR(123,$G(GMRCPT),0),U,23)'=""&($P($G(^GMR(123,GMRCPT,12)),U,5)="F") S TYPE="IFCF" Q - Q -EXCLUDE ;exclude these request types from the count - N PROS - ; Check for bad "AE" x-ref - I '$D(^GMR(123,GMRCPT,0)) D S FLG=1 Q - .K ^GMR(123,"AE",GMRCSVC,STAT,GMRCXDT,GMRCPT) - I $$TESTPAT^VADPT(+$P(^GMR(123,GMRCPT,0),U,2)) S FLG=1 Q ; exclude test pats - D I $G(PROS) S FLG=1 Q - .N SVC S SVC=$P(^GMR(123,GMRCPT,0),U,5) - .I +$G(^GMR(123.5,SVC,"INT")) S PROS=1 ; exclude PROS consults - I $P($G(^GMR(123,GMRCPT,0)),U,18)'="O" S FLG=1 Q ; only getting outpat - I $G(^GMR(123,GMRCPT,70))["Y" S FLG=1 Q ; exclude admin requests - Q -CHKRNG ;check if request is complete within 30/60 days of Desired Date or Date of Request - N DTOR,DTCMPL S DTOR="",DTCMPL="" - Q:'$O(^GMR(123,+$G(GMRCPT),50,0))&('$O(^GMR(123,+$G(GMRCPT),51,0))) - I $D(^GMR(123,+$G(GMRCPT),60))=1 S DTOR=$P(^GMR(123,+$G(GMRCPT),60),U,1) ;check for desired date CPRS GUI v28 - S:$G(DTOR)="" DTOR=$P(^GMR(123,+$G(GMRCPT),0),U,7) - ; if request is completed and has results, was it completed within 30 or 60 days of the Date of Request, field 3 in 123 [0;7] - ;order through activity multiple (40) and find the entry for completed 40, [0:2] - value of 10 is complete/update - N CHK S CHK=0 - F S CHK=$O(^GMR(123,+$G(GMRCPT),40,CHK)) Q:CHK="B" D - .;get the date/time of completion 40, [0;3] - .I $D(^GMR(123,+$G(GMRCPT),40,CHK,0)) S:($P(^GMR(123,GMRCPT,40,CHK,0),U,2)=10) DTCMPL=$P(^GMR(123,GMRCPT,40,CHK,0),U,3) - I $G(DTCMPL) D - .I (STR="30")&(DTCMPL<=$$FMADD^XLFDT(DTOR,30)) D - ..S:TYPE="LOCAL" $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,3)=+$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,3)+1 - ..S:TYPE="IFCP" $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,9)=+$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,9)+1 - ..S:TYPE="IFCF" $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,15)=+$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,15)+1 - .I STR'="30"&(DTCMPL<=$$FMADD^XLFDT(DTOR,60))&(DTCMPL>$$FMADD^XLFDT(DTOR,30)) D - ..S:TYPE="LOCAL" $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,4)=+$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,4)+1 - ..S:TYPE="IFCP" $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,10)=+$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,10)+1 - ..S:TYPE="IFCF" $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,16)=+$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,16)+1 - Q +GMRCSTL8 ;SLC/JFR - Totals format for CPM ; 4/05/05 10:39 + ;;3.0;CONSULT/REQUEST TRACKING;**41**;DEC 27, 1997 + ; This routine invokes IA #875, #2638 + ; This routine invokes IA #10035,#44, #10040 + ; + ; portions copied from GMRCSTL1 & GMRCSTL2 + ; + Q ; can't start here + ; +PRTTOT(GEN,INDEX,NAME,ARRN) ; totals for printed report + N COUNT + S COUNT=$O(^TMP("GMRCR",$J,ARRN," "),-1) + I GEN=2 D + . S COUNT=COUNT+1 + . S ^TMP("GMRCR",$J,ARRN,COUNT,0)="" + . S COUNT=COUNT+1 + . S ^TMP("GMRCR",$J,ARRN,COUNT,0)=" GROUPER: "_NAME_" Totals:" + I GEN=1 D + . I ^TMP("GMRCTOT",$J,1,INDEX,"T")=0 D Q ;collect zero servs for summ + .. Q:$P(^GMR(123.5,INDEX,0),U,2)=1 + .. S ^TMP("GMRCTOT",$J,0,NAME)="" + . S COUNT=COUNT+1 + . S ^TMP("GMRCR",$J,ARRN,COUNT,0)=" " + . S COUNT=COUNT+1 + . S ^TMP("GMRCR",$J,ARRN,COUNT,0)="SERVICE: "_NAME + . S COUNT=COUNT+1 + . S ^TMP("GMRCR",$J,ARRN,COUNT,0)="Total Requests To Service:"_$J(^TMP("GMRCTOT",$J,1,INDEX,"T"),30,0) + I GEN=2,^TMP("GMRCTOT",$J,2,INDEX,"T")>0 D + . S COUNT=COUNT+1 + . S ^TMP("GMRCR",$J,ARRN,COUNT,0)="Total Requests To Grouper:"_$J(^TMP("GMRCTOT",$J,2,INDEX,"T"),30,0) + I $G(^TMP("GMRCTOT",$J,GEN,INDEX,"T"))>0 D + . S COUNT=COUNT+1 + . S ^TMP("GMRCR",$J,ARRN,COUNT,0)="Total Requests Pending Resolution: "_$J(^TMP("GMRCTOT",$J,GEN,INDEX,"P"),21,0) + . S COUNT=COUNT+1 + . S ^TMP("GMRCR",$J,ARRN,COUNT,0)="Total Requests completed: "_$J(^TMP("GMRCTOT",$J,GEN,INDEX,"C"),30,0) + . S COUNT=COUNT+1 + . S ^TMP("GMRCR",$J,ARRN,COUNT,0)="Total Requests completed with Results: "_$J(^TMP("GMRCTOT",$J,GEN,INDEX,"R"),17,0) + . N GMRCPCT + . I ^TMP("GMRCTOT",$J,GEN,INDEX,"T")=0 S GMRCPCT="N/A" + . I '$D(GMRCPCT) S GMRCPCT=(^TMP("GMRCTOT",$J,GEN,INDEX,"C")/^TMP("GMRCTOT",$J,GEN,INDEX,"T"))*100 + . S COUNT=COUNT+1 + . S ^TMP("GMRCR",$J,ARRN,COUNT,0)="Percentage of total requests completed: "_$S(+GMRCPCT'=GMRCPCT:$J(GMRCPCT,16),1:($J(GMRCPCT,19,2)_"%")) + . K GMRCPCT + . I ^TMP("GMRCTOT",$J,GEN,INDEX,"C")=0 S GMRCPCT="N/A" + . I '$D(GMRCPCT) S GMRCPCT=(^TMP("GMRCTOT",$J,GEN,INDEX,"R")/^TMP("GMRCTOT",$J,GEN,INDEX,"C"))*100 + . S COUNT=COUNT+1 + . S ^TMP("GMRCR",$J,ARRN,COUNT,0)="Percentage of total completed requests with results: "_$S(+GMRCPCT'=GMRCPCT:GMRCPCT,1:($J(GMRCPCT,6,2)_"%")) + Q + ; +DELTOT(GEN,INDEX,NAME,ARRN) ; format for delimited + ; + I ^TMP("GMRCTOT",$J,GEN,INDEX,"T")=0 Q + N STRING,COUNT + S COUNT=$O(^TMP("GMRCR",$J,ARRN," "),-1) + S STRING=$S(GEN=2:"GROUPER: ",1:"")_NAME_";" + S STRING=STRING_^TMP("GMRCTOT",$J,GEN,INDEX,"T")_";" + S STRING=STRING_^TMP("GMRCTOT",$J,GEN,INDEX,"P")_";" + S STRING=STRING_^TMP("GMRCTOT",$J,GEN,INDEX,"C")_";" + S STRING=STRING_^TMP("GMRCTOT",$J,GEN,INDEX,"R")_";" + D ;get % completed + . N GMRCPCT + . S GMRCPCT=(^TMP("GMRCTOT",$J,GEN,INDEX,"C")/^TMP("GMRCTOT",$J,GEN,INDEX,"T"))*100 + . S STRING=STRING_$J(GMRCPCT,0,2)_";" + . Q + D ; get % completed w/results + . I ^TMP("GMRCTOT",$J,GEN,INDEX,"C")=0 S STRING=STRING_"N/A;" Q + . N GMRCPCT + . S GMRCPCT=(^TMP("GMRCTOT",$J,GEN,INDEX,"R")/^TMP("GMRCTOT",$J,GEN,INDEX,"C"))*100 + . S STRING=STRING_$J(GMRCPCT,0,2) + . Q + S COUNT=COUNT+1 + S ^TMP("GMRCR",$J,ARRN,COUNT,0)=STRING + Q + ; +ONESTAT(ARRN,SVCN,STAT,DT1,DT2) ;Process one status + ; Input -- ARRN "CP" - to be printed + ; "DEL" - in delimited format + ; SVCN = node in ^TMP("GMRCLIST,$J + ; STAT = status being worked on + ; DT1 = starting date + ; DT2 = ending date + ; + ; Output - None + ; + N GMRCPT,GMRCXDT,TEMP,GMRCSVC,GMRCSVCG,GMRCSVCP + S GMRCSVC=$P(^TMP("GMRCSLIST",$J,SVCN),"^",1) + S GMRCSVCP=$P(^TMP("GMRCSLIST",$J,SVCN),"^",2) + S GMRCSVCG=$P(^TMP("GMRCSLIST",$J,SVCN),"^",3) + S GMRCXDT=$S(DT1="ALL":0,1:9999999-DT2-.6) + F S GMRCXDT=$O(^GMR(123,"AE",GMRCSVC,STAT,GMRCXDT)) Q:GMRCXDT=""!(GMRCXDT>(9999999-DT1)) D + .S GMRCPT=0 + .;Loop for one consult at a time + .F S GMRCPT=$O(^GMR(123,"AE",GMRCSVC,STAT,GMRCXDT,GMRCPT)) Q:GMRCPT="" D + .. N PROS + ..; Check for bad "AE" x-ref + ..I '$D(^GMR(123,GMRCPT,0)) D Q + ...K ^GMR(123,"AE",GMRCSVC,STAT,GMRCXDT,GMRCPT) + .. I $$TESTPAT^VADPT(+$P(^GMR(123,GMRCPT,0),U,2)) Q ; exclude test pats + .. D I $G(PROS) Q + ... N SVC S SVC=$P(^GMR(123,GMRCPT,0),U,5) + ... I +$G(^GMR(123.5,SVC,"INT")) S PROS=1 ; exclude PROS consults + .. I $P($G(^GMR(123,GMRCPT,12)),U,5)="P" Q ; exclude IFC placer + ..; Add to totals + ..; for all status for this service + ..S ^TMP("GMRCTOT",$J,1,GMRCSVC,"T")=^TMP("GMRCTOT",$J,1,GMRCSVC,"T")+1 + ..; pending for this service + ..S:",3,4,5,6,8,9,11,99,"[(","_STAT_",") ^TMP("GMRCTOT",$J,1,GMRCSVC,"P")=^TMP("GMRCTOT",$J,1,GMRCSVC,"P")+1 + .. I STAT=2 D + ... S ^TMP("GMRCTOT",$J,1,GMRCSVC,"C")=+$G(^TMP("GMRCTOT",$J,1,GMRCSVC,"C"))+1 + ... Q:'$O(^GMR(123,+$G(GMRCPT),50,0)) ; Q if no results + ... S ^TMP("GMRCTOT",$J,1,GMRCSVC,"R")=+$G(^TMP("GMRCTOT",$J,1,GMRCSVC,"R"))+1 + Q + ; diff --git a/r/CONSULT_REQUEST_TRACKING-GMRC-GMRS-GMRT/GMRCSTU.m b/r/CONSULT_REQUEST_TRACKING-GMRC-GMRS-GMRT/GMRCSTU.m index 263b0d38..00c390af 100644 --- a/r/CONSULT_REQUEST_TRACKING-GMRC-GMRS-GMRT/GMRCSTU.m +++ b/r/CONSULT_REQUEST_TRACKING-GMRC-GMRS-GMRT/GMRCSTU.m @@ -1,225 +1,222 @@ -GMRCSTU ;SLC/DCM,dee - Statistic Utilities for C/RT ;09/26/02 10:16 - ;;3.0;CONSULT/REQUEST TRACKING;**1,7,29,30,43,61**;DEC 27, 1997;Build 2 - Q - ; -GETDT(GMRCO) ;get the date that the consult/request was accepted by service - N ND,GMRCDA - S COMPLDT=9999999 - S ND=0 F S ND=$O(^GMR(123,GMRCO,40,ND)) Q:ND?1A.E!(ND="") D - .S:$P(^GMR(123,GMRCO,40,ND,0),"^",2)=21 GMRCDA=$P(^(0),"^",1) - .S:$P(^GMR(123,GMRCO,40,ND,0),"^",2)=1 GMRCDA(1)=$P(^(0),"^",1) - .S:$P(^GMR(123,GMRCO,40,ND,0),"^",2)=15 GMRCDA(15)=$P(^(0),"^",3) - .I $P(^GMR(123,GMRCO,40,ND,0),"^",2)=10,$P(^(0),"^",3)0 - .I $P(^TMP("GMRCSLIST",$J,INDEX),"^",5)'=1 D - ..S GMRCDT="" - ..F S GMRCDT=$O(^GMR(123,"AE",ND,2,GMRCDT)) Q:GMRCDT="" D - ...S GMRCO=0 - ...F S GMRCO=$O(^GMR(123,"AE",ND,2,GMRCDT,GMRCO)) Q:GMRCO="" D W:GMRCWRIT&'(GMRCND#25) "." - ....D GETDT(GMRCO) - ....I COMPLDT<9999999,$S(GMRCDT1="ALL":1,RCVDT'GMRCDT2):1,1:0) D - .....S X1=COMPLDT - .....S X2=RCVDT - .....D ^%DTC - .....IF X=0 D - ......S X=$$FMDIFF^XLFDT(COMPLDT,RCVDT,3) - ......S X=+$P(X," ",2)/24 - ......S X3=$E(X,1,3) - ......S X4=$E(X,4) - ......S:X4>4 X3=X3+.01 - ......S X=X3 - .....S $P(^TMP("GMRCSVC",$J,1,ND,"T"),U)=$P(^TMP("GMRCSVC",$J,1,ND,"T"),U)+X - .....S $P(^TMP("GMRCSVC",$J,1,ND,"T"),"^",2)=$P(^TMP("GMRCSVC",$J,1,ND,"T"),"^",2)+1 - .....S $P(^TMP("GMRCSVC",$J,1,ND,"T"),"^",3)=$P(^TMP("GMRCSVC",$J,1,ND,"T"),"^",3)+(X*X) - .....I $P(^GMR(123,GMRCO,0),"^",18)="I" D - ......S $P(^TMP("GMRCSVC",$J,1,ND,"I"),"^",1)=$P(^TMP("GMRCSVC",$J,1,ND,"I"),"^",1)+X - ......S $P(^TMP("GMRCSVC",$J,1,ND,"I"),"^",2)=$P(^TMP("GMRCSVC",$J,1,ND,"I"),"^",2)+1 - ......S $P(^TMP("GMRCSVC",$J,1,ND,"I"),"^",3)=$P(^TMP("GMRCSVC",$J,1,ND,"I"),"^",3)+(X*X) - .....E I $P(^GMR(123,GMRCO,0),"^",18)="O" D - ......S $P(^TMP("GMRCSVC",$J,1,ND,"O"),"^",1)=$P(^TMP("GMRCSVC",$J,1,ND,"O"),"^",1)+X - ......S $P(^TMP("GMRCSVC",$J,1,ND,"O"),"^",2)=$P(^TMP("GMRCSVC",$J,1,ND,"O"),"^",2)+1 - ......S $P(^TMP("GMRCSVC",$J,1,ND,"O"),"^",3)=$P(^TMP("GMRCSVC",$J,1,ND,"O"),"^",3)+(X*X) - .....E D - ......S $P(^TMP("GMRCSVC",$J,1,ND,"U"),"^",1)=$P(^TMP("GMRCSVC",$J,1,ND,"U"),"^",1)+X - ......S $P(^TMP("GMRCSVC",$J,1,ND,"U"),"^",2)=$P(^TMP("GMRCSVC",$J,1,ND,"U"),"^",2)+1 - ......S $P(^TMP("GMRCSVC",$J,1,ND,"U"),"^",3)=$P(^TMP("GMRCSVC",$J,1,ND,"U"),"^",3)+(X*X) - .....S GMRCND=GMRCND+1 - .D PARENTS^GMRCSTU1(ND,+$P(^TMP("GMRCSLIST",$J,INDEX),"^",3)) - S ND=0 -STAT ;Do the statistics - F S ND=$O(^TMP("GMRCSVC",$J,2,ND)) Q:ND="" D - .I $P($G(^TMP("GMRCSVC",$J,1,ND,"T")),"^",1)>0 D DOSTAT^GMRCSTU1(1,ND) - .I $P(^TMP("GMRCSVC",$J,2,ND,"T"),"^",1)>0 D DOSTAT^GMRCSTU1(2,ND) - K ^TMP("GMRCR",$J,"PRL") - S GMRCCT=0 - S GMRCDT2=GMRCDTP ;reset date value to print report heading - D LISTDATE^GMRCSTU1(GMRCDT1,GMRCDT2,.GMRCEDT1,.GMRCEDT2) - S TAB="" - S $P(TAB," ",40)="" - S GMRCCT=GMRCCT+1 - S ^TMP("GMRCR",$J,"PRL",GMRCCT,0)=$E(TAB,1,19)_"Consult/Request Completion Time Statistics" - S GMRCCT=GMRCCT+1 - S TEMPTMP="FROM: "_GMRCEDT1_" TO: "_GMRCEDT2 - S ^TMP("GMRCR",$J,"PRL",GMRCCT,0)=$E(TAB,1,40-($L(TEMPTMP)/2))_TEMPTMP - S GMRCCT=GMRCCT+1 - S ^TMP("GMRCR",$J,"PRL",GMRCCT,0)="" - S INDEX=0 - S GROUPER=0 - S GROUPER(0)=0 - F S INDEX=$O(^TMP("GMRCSLIST",$J,INDEX)) Q:INDEX="" D - .S ND=$P(^TMP("GMRCSLIST",$J,INDEX),"^",1) - .Q:$P(^TMP("GMRCSLIST",$J,INDEX),"^",5)=9&'$D(^TMP("GMRCSVC",$J,2,ND)) - .F Q:GROUPER(GROUPER)=$P(^TMP("GMRCSLIST",$J,INDEX),"^",3) D - ..;End of a group so print the group totals - ..D SERVSTAT^GMRCSTU1(.GMRCCT,2,GROUPER(GROUPER),GROUPER(GROUPER)) - ..;pop grouper from stack - ..S GROUPER=GROUPER-1 - .I $P(^TMP("GMRCSLIST",$J,INDEX),"^",4)="+" D - ..;Start of a new group so print the group heading. - ..S GMRCCT=GMRCCT+1 - ..S TEMPTMP="GROUPER: "_$P(^GMR(123.5,ND,0),"^",1) - ..S:$P(^TMP("GMRCSLIST",$J,INDEX),"^",3)>0 TEMPTMP=TEMPTMP_" in Group: "_$P(^GMR(123.5,$P(^TMP("GMRCSLIST",$J,INDEX),"^",3),0),"^",1) - ..S ^TMP("GMRCR",$J,"PRL",GMRCCT,0)=$E(TAB,1,40-(($L(TEMPTMP)/2)+.5))_TEMPTMP - ..S GMRCCT=GMRCCT+1 - ..S ^TMP("GMRCR",$J,"PRL",GMRCCT,0)="" - ..;push new grouper on stack - ..S GROUPER=GROUPER+1 - ..S GROUPER(GROUPER)=ND - .Q:$P(^TMP("GMRCSLIST",$J,INDEX),"^",5)=1 - .Q:$P(^TMP("GMRCSLIST",$J,INDEX),"^",5)=9 - .D SERVSTAT^GMRCSTU1(.GMRCCT,1,ND,GROUPER(GROUPER)) - ;Now list the group totals for the current groups. - F GROUPER=GROUPER:-1:1 D - .;End of a group so print the group totals - .D SERVSTAT^GMRCSTU1(.GMRCCT,2,GROUPER(GROUPER),GROUPER(GROUPER)) - ;Done building list. - S VALMCNT=GMRCCT,VALMBCK="R" -KILL ;kill variables and exit - S:$D(GMRCQUT) VALMBCK="Q" - K ^TMP("GMRCS",$J),^TMP("GMRCSLIST",$J) - Q -PRNT ;print statistics to a printer - ;Called from a List Manager action - Q:'$D(^TMP("GMRCR",$J,"PRL",2,0)) - I $D(IOTM),$D(IOBM),$D(IOSTBM) D FULL^VALM1 - D PRNTASK - D PRNTIT("PRL","PRNTQ^GMRCSTU","CONSULT/REQUEST PACKAGE PRINT COMPLETION TIME STATISTICS FROM LIST MANAGER DISPLAY") - Q - ; -PRNTASK ;Ask for device - N POP,%ZIS - K GMRCQUT - S POP=0 - S %ZIS="MQ" - D ^%ZIS - I POP D Q - .S GMRCMSG="Printer Busy. Try Again Later." - .D EXAC^GMRCADC(GMRCMSG) - .K GMRCMSG - .S GMRCQUT=1 - Q - ; -PRNTIT(TMPNAME,QUERTN,QUEDESC) ;Send list to printer - N ANSWER,INDEX,DOLLARH,ZTRTN,ZTDESC - I $D(IO("Q")) D Q - .S DOLLARH=$H - .M ^XTMP("GMRCR","$"_$J,DOLLARH,"PRINT")=^TMP("GMRCR",$J,TMPNAME) - .S ZTRTN=QUERTN - .S ZTDESC=QUEDESC - .S ZTSAVE("J")="$"_$J - .S ZTSAVE("DOLLARH")="" - .S ZTSAVE("TMPNAME")="" - .S ZTSAVE("GMRCDG")="" - .S ZTSAVE("GMRCDT1")="" - .S ZTSAVE("GMRCDT2")="" - .D ^%ZTLOAD,^%ZISC - .K ZTSAVE - .S VALMBCK="R" - U IO - S ANSWER="" - S INDEX="" - F S INDEX=$O(^TMP("GMRCR",$J,TMPNAME,INDEX)) Q:INDEX="" W ^TMP("GMRCR",$J,TMPNAME,INDEX,0),! I IOST["C-",$S($D(IOSL)#2:$Y>(IOSL-2),1:$Y>22) R "Press To Continue, '^' To Quit: ",ANSWER:DTIME Q:'$T!(ANSWER["^") W @IOF - I ANSWER'["^",IOST["C-",$Y>1 R !,"Press To Continue: ",ANSWER:DTIME - U IO(0) - D ^%ZISC - S VALMBCK="R" - Q - ; -PRNTQ ;Print Queued report from ^XTMP global then kill off ^XTMP - N INDEX - U IO - S INDEX="" - F S INDEX=$O(^XTMP("GMRCR",J,DOLLARH,"PRINT",INDEX)) Q:INDEX="" W ^XTMP("GMRCR",J,DOLLARH,"PRINT",INDEX,0),! - K ^XTMP("GMRCR",J,DOLLARH,"PRINT"),J,DOLLARH - D ^%ZISC - Q +GMRCSTU ;SLC/DCM,dee - Statistic Utilities for C/RT ;09/26/02 10:16 + ;;3.0;CONSULT/REQUEST TRACKING;**1,7,29,30,43**;DEC 27, 1997 + Q + ; +GETDT(GMRCO) ;get the date that the consult/request was accepted by service + N ND,GMRCDA + S COMPLDT=9999999 + S ND=0 F S ND=$O(^GMR(123,GMRCO,40,ND)) Q:ND?1A.E!(ND="") D + .S:$P(^GMR(123,GMRCO,40,ND,0),"^",2)=21 GMRCDA=$P(^(0),"^",1) + .S:$P(^GMR(123,GMRCO,40,ND,0),"^",2)=1 GMRCDA(1)=$P(^(0),"^",1) + .S:$P(^GMR(123,GMRCO,40,ND,0),"^",2)=15 GMRCDA(15)=$P(^(0),"^",3) + .I $P(^GMR(123,GMRCO,40,ND,0),"^",2)=10,$P(^(0),"^",3)0 + .I $P(^TMP("GMRCSLIST",$J,INDEX),"^",5)'=1 D + ..S GMRCDT="" + ..F S GMRCDT=$O(^GMR(123,"AE",ND,2,GMRCDT)) Q:GMRCDT="" D + ...S GMRCO=0 + ...F S GMRCO=$O(^GMR(123,"AE",ND,2,GMRCDT,GMRCO)) Q:GMRCO="" D W:GMRCWRIT&'(GMRCND#25) "." + ....D GETDT(GMRCO) + ....I COMPLDT<9999999,$S(GMRCDT1="ALL":1,RCVDT'GMRCDT2):1,1:0) D + .....S X1=COMPLDT + .....S X2=RCVDT + .....D ^%DTC + .....IF X=0 D + ......S X=$$FMDIFF^XLFDT(COMPLDT,RCVDT,3) + ......S X=+$P(X," ",2)/24 + ......S X3=$E(X,1,3) + ......S X4=$E(X,4) + ......S:X4>4 X3=X3+.01 + ......S X=X3 + .....S $P(^TMP("GMRCSVC",$J,1,ND,"T"),U)=$P(^TMP("GMRCSVC",$J,1,ND,"T"),U)+X + .....S $P(^TMP("GMRCSVC",$J,1,ND,"T"),"^",2)=$P(^TMP("GMRCSVC",$J,1,ND,"T"),"^",2)+1 + .....S $P(^TMP("GMRCSVC",$J,1,ND,"T"),"^",3)=$P(^TMP("GMRCSVC",$J,1,ND,"T"),"^",3)+(X*X) + .....I $P(^GMR(123,GMRCO,0),"^",18)="I" D + ......S $P(^TMP("GMRCSVC",$J,1,ND,"I"),"^",1)=$P(^TMP("GMRCSVC",$J,1,ND,"I"),"^",1)+X + ......S $P(^TMP("GMRCSVC",$J,1,ND,"I"),"^",2)=$P(^TMP("GMRCSVC",$J,1,ND,"I"),"^",2)+1 + ......S $P(^TMP("GMRCSVC",$J,1,ND,"I"),"^",3)=$P(^TMP("GMRCSVC",$J,1,ND,"I"),"^",3)+(X*X) + .....E I $P(^GMR(123,GMRCO,0),"^",18)="O" D + ......S $P(^TMP("GMRCSVC",$J,1,ND,"O"),"^",1)=$P(^TMP("GMRCSVC",$J,1,ND,"O"),"^",1)+X + ......S $P(^TMP("GMRCSVC",$J,1,ND,"O"),"^",2)=$P(^TMP("GMRCSVC",$J,1,ND,"O"),"^",2)+1 + ......S $P(^TMP("GMRCSVC",$J,1,ND,"O"),"^",3)=$P(^TMP("GMRCSVC",$J,1,ND,"O"),"^",3)+(X*X) + .....E D + ......S $P(^TMP("GMRCSVC",$J,1,ND,"U"),"^",1)=$P(^TMP("GMRCSVC",$J,1,ND,"U"),"^",1)+X + ......S $P(^TMP("GMRCSVC",$J,1,ND,"U"),"^",2)=$P(^TMP("GMRCSVC",$J,1,ND,"U"),"^",2)+1 + ......S $P(^TMP("GMRCSVC",$J,1,ND,"U"),"^",3)=$P(^TMP("GMRCSVC",$J,1,ND,"U"),"^",3)+(X*X) + .....S GMRCND=GMRCND+1 + .D PARENTS^GMRCSTU1(ND,+$P(^TMP("GMRCSLIST",$J,INDEX),"^",3)) + S ND=0 +STAT ;Do the statistics + F S ND=$O(^TMP("GMRCSVC",$J,2,ND)) Q:ND="" D + .I $P($G(^TMP("GMRCSVC",$J,1,ND,"T")),"^",1)>0 D DOSTAT^GMRCSTU1(1,ND) + .I $P(^TMP("GMRCSVC",$J,2,ND,"T"),"^",1)>0 D DOSTAT^GMRCSTU1(2,ND) + K ^TMP("GMRCR",$J,"PRL") + S GMRCCT=0 + D LISTDATE^GMRCSTU1(GMRCDT1,GMRCDT2,.GMRCEDT1,.GMRCEDT2) + S TAB="" + S $P(TAB," ",40)="" + S GMRCCT=GMRCCT+1 + S ^TMP("GMRCR",$J,"PRL",GMRCCT,0)=$E(TAB,1,19)_"Consult/Request Completion Time Statistics" + S GMRCCT=GMRCCT+1 + S TEMPTMP="FROM: "_GMRCEDT1_" TO: "_GMRCEDT2 + S ^TMP("GMRCR",$J,"PRL",GMRCCT,0)=$E(TAB,1,40-($L(TEMPTMP)/2))_TEMPTMP + S GMRCCT=GMRCCT+1 + S ^TMP("GMRCR",$J,"PRL",GMRCCT,0)="" + S INDEX=0 + S GROUPER=0 + S GROUPER(0)=0 + F S INDEX=$O(^TMP("GMRCSLIST",$J,INDEX)) Q:INDEX="" D + .S ND=$P(^TMP("GMRCSLIST",$J,INDEX),"^",1) + .Q:$P(^TMP("GMRCSLIST",$J,INDEX),"^",5)=9&'$D(^TMP("GMRCSVC",$J,2,ND)) + .F Q:GROUPER(GROUPER)=$P(^TMP("GMRCSLIST",$J,INDEX),"^",3) D + ..;End of a group so print the group totals + ..D SERVSTAT^GMRCSTU1(.GMRCCT,2,GROUPER(GROUPER),GROUPER(GROUPER)) + ..;pop grouper from stack + ..S GROUPER=GROUPER-1 + .I $P(^TMP("GMRCSLIST",$J,INDEX),"^",4)="+" D + ..;Start of a new group so print the group heading. + ..S GMRCCT=GMRCCT+1 + ..S TEMPTMP="GROUPER: "_$P(^GMR(123.5,ND,0),"^",1) + ..S:$P(^TMP("GMRCSLIST",$J,INDEX),"^",3)>0 TEMPTMP=TEMPTMP_" in Group: "_$P(^GMR(123.5,$P(^TMP("GMRCSLIST",$J,INDEX),"^",3),0),"^",1) + ..S ^TMP("GMRCR",$J,"PRL",GMRCCT,0)=$E(TAB,1,40-(($L(TEMPTMP)/2)+.5))_TEMPTMP + ..S GMRCCT=GMRCCT+1 + ..S ^TMP("GMRCR",$J,"PRL",GMRCCT,0)="" + ..;push new grouper on stack + ..S GROUPER=GROUPER+1 + ..S GROUPER(GROUPER)=ND + .Q:$P(^TMP("GMRCSLIST",$J,INDEX),"^",5)=1 + .Q:$P(^TMP("GMRCSLIST",$J,INDEX),"^",5)=9 + .D SERVSTAT^GMRCSTU1(.GMRCCT,1,ND,GROUPER(GROUPER)) + ;Now list the group totals for the current groups. + F GROUPER=GROUPER:-1:1 D + .;End of a group so print the group totals + .D SERVSTAT^GMRCSTU1(.GMRCCT,2,GROUPER(GROUPER),GROUPER(GROUPER)) + ;Done building list. + S VALMCNT=GMRCCT,VALMBCK="R" +KILL ;kill variables and exit + S:$D(GMRCQUT) VALMBCK="Q" + K ^TMP("GMRCS",$J),^TMP("GMRCSLIST",$J) + Q +PRNT ;print statistics to a printer + ;Called from a List Manager action + Q:'$D(^TMP("GMRCR",$J,"PRL",2,0)) + I $D(IOTM),$D(IOBM),$D(IOSTBM) D FULL^VALM1 + D PRNTASK + D PRNTIT("PRL","PRNTQ^GMRCSTU","CONSULT/REQUEST PACKAGE PRINT COMPLETION TIME STATISTICS FROM LIST MANAGER DISPLAY") + Q + ; +PRNTASK ;Ask for device + N POP,%ZIS + K GMRCQUT + S POP=0 + S %ZIS="MQ" + D ^%ZIS + I POP D Q + .S GMRCMSG="Printer Busy. Try Again Later." + .D EXAC^GMRCADC(GMRCMSG) + .K GMRCMSG + .S GMRCQUT=1 + Q + ; +PRNTIT(TMPNAME,QUERTN,QUEDESC) ;Send list to printer + N ANSWER,INDEX,DOLLARH,ZTRTN,ZTDESC + I $D(IO("Q")) D Q + .S DOLLARH=$H + .M ^XTMP("GMRCR","$"_$J,DOLLARH,"PRINT")=^TMP("GMRCR",$J,TMPNAME) + .S ZTRTN=QUERTN + .S ZTDESC=QUEDESC + .S ZTSAVE("J")="$"_$J + .S ZTSAVE("DOLLARH")="" + .S ZTSAVE("TMPNAME")="" + .S ZTSAVE("GMRCDG")="" + .S ZTSAVE("GMRCDT1")="" + .S ZTSAVE("GMRCDT2")="" + .D ^%ZTLOAD,^%ZISC + .K ZTSAVE + .S VALMBCK="R" + U IO + S ANSWER="" + S INDEX="" + F S INDEX=$O(^TMP("GMRCR",$J,TMPNAME,INDEX)) Q:INDEX="" W ^TMP("GMRCR",$J,TMPNAME,INDEX,0),! I IOST["C-",$S($D(IOSL)#2:$Y>(IOSL-2),1:$Y>22) R "Press To Continue, '^' To Quit: ",ANSWER:DTIME Q:'$T!(ANSWER["^") W @IOF + I ANSWER'["^",IOST["C-",$Y>1 R !,"Press To Continue: ",ANSWER:DTIME + U IO(0) + D ^%ZISC + S VALMBCK="R" + Q + ; +PRNTQ ;Print Queued report from ^XTMP global then kill off ^XTMP + N INDEX + U IO + S INDEX="" + F S INDEX=$O(^XTMP("GMRCR",J,DOLLARH,"PRINT",INDEX)) Q:INDEX="" W ^XTMP("GMRCR",J,DOLLARH,"PRINT",INDEX,0),! + K ^XTMP("GMRCR",J,DOLLARH,"PRINT"),J,DOLLARH + D ^%ZISC + Q diff --git a/r/CONTROLLED_SUBSTANCES-PSD/PSDACT1.m b/r/CONTROLLED_SUBSTANCES-PSD/PSDACT1.m index d2a8ba71..a51ef25d 100644 --- a/r/CONTROLLED_SUBSTANCES-PSD/PSDACT1.m +++ b/r/CONTROLLED_SUBSTANCES-PSD/PSDACT1.m @@ -1,108 +1,107 @@ -PSDACT1 ;BIR/JPW,BJW-Print Daily Activity Log (cont'd) ; 17 Jun 98 - ;;3.0; CONTROLLED SUBSTANCES ;**10,14,30,65**;13 Feb 97;Build 5 - ;Reference to ^PRC(442 supported by IA #682 - ;Reference to ^PRCS(410 supported by IA #198 - ;Reference to ^PSDRUG( supported by IA #221 - ;Reference to ^PSRX( supported by IA #986 - ;Reference to ^DD(58.81 supported by IA #10154 - ;Reference to PSD(58.8 supported by DBIA # 2711 - ;Reference to PSD(58.81 supported by DBIA # 2808 - ;References to PSD(58.84 supported by IA # 3485 - ;modified for nois:tua-0498-32173,new code added to t6 - ;op v.7 chg the status loc in file 52 -START ;entry for compile - K ^TMP("PSDACT",$J) - I $D(ALL) F PSDR=0:0 S PSDR=$O(^PSD(58.8,+PSDS,1,PSDR)) Q:'PSDR I $D(^PSD(58.8,+PSDS,1,PSDR,0)) S PSDRG(+PSDR)="" - F PSD=PSDSD:0 S PSD=$O(^PSD(58.81,"ACT",PSD)) Q:'PSD!(PSD>PSDED) F PSDR=0:0 S PSDR=$O(^PSD(58.81,"ACT",PSD,PSDS,PSDR)) Q:'PSDR D - .Q:'$D(PSDRG(PSDR)) - .F TYP=0:0 S TYP=$O(^PSD(58.81,"ACT",PSD,PSDS,PSDR,TYP)) Q:'TYP!(TYP=12) F PSDA=0:0 S PSDA=$O(^PSD(58.81,"ACT",PSD,PSDS,PSDR,TYP,PSDA)) Q:'PSDA D SET - G:$D(ZTQUEUED) PRTQUE G PRINT^PSDACT2 -END ; - D KVAR^VADPT - K %,%DT,%H,%I,%ZIS,ACT,ALL,BFWD,C,DA,DATE,DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,LN,MFG,NAOU,NODE,NQTY,NUM - K PAT,PG,PHARM,POP,PSD,PSDA,PSDATE,PSDED,PSDEV,PSDIO,PSDOUT,PSDPN,PSDR,PSDRG,PSDRGN,PSDS,PSDSD,PSDSN,PSDUZ,PSDUZN,RX,TEXT,TYP,QTY,TYPE,X,Y,VA("BID"),VA("PID") - K ^TMP("PSDACT",$J),ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK - D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" - Q -SET ;sets data - ;Dave B (PSD*3*14) Disregard if type is 15. - Q:'$D(^PSD(58.81,PSDA,0)) Q:TYP=5 Q:TYP=15 S NODE=^(0),QTY=$P(NODE,"^",6),BFWD=$P(NODE,"^",10) - S PSDRGN=$S($P($G(^PSDRUG(PSDR,0)),"^")]"":$P(^(0),"^"),1:"ZZ/"_PSDR_" NAME MISSING") - S PSDUZ=$S(TYP=3:+$P($G(^PSD(58.81,PSDA,1)),"^",14),TYP=4:+$P($G(^PSD(58.81,PSDA,1)),"^",14),TYP=13:+$P($G(^PSD(58.81,PSDA,5)),"^",2),TYP=14:+$P($G(^PSD(58.81,PSDA,4)),"^",2),1:+$P(NODE,"^",7)) - S:TYP=2 PSDUZ=$S(+$P($G(^PSD(58.81,PSDA,1)),"^"):+$P($G(^(1)),"^"),1:+$P(NODE,"^",7)) - S PSDUZN=$P($G(^VA(200,+PSDUZ,0)),"^"),PSDUZN=$S(PSDUZN]"":$E($P(PSDUZN,",",2))_$E(PSDUZN),1:"**") - I TYP=1 D T1 G TMP - I TYP=2 D T2 G TMP - I TYP=3 Q:'$D(^PSD(58.81,PSDA,3)) D T3 G TMP - Q:TYP=4 - I TYP=6 Q:'$D(^PSD(58.81,PSDA,6)) D T6 G TMP - I TYP=7 D T7 G TMP - I TYP=9 D T9 G TMP - I TYP=11 D T11 G TMP - I TYP=13 Q:'$D(^PSD(58.81,PSDA,5)) D T13 G TMP - I TYP=14 Q:'$D(^PSD(58.81,PSDA,4)) D T14 G TMP - I TYP=16 D T16 G TMP - I TYP>18 D TOTH -TMP ; - S PSDUZN=$P($G(^VA(200,+PSDUZ,0)),"^"),PSDUZN=$S(PSDUZN]"":$E($P(PSDUZN,",",2))_$E(PSDUZN),1:"**") - ;PSD*3*30 (Dave B - Identify person with more than just **) - I $G(PSDUZN)="**" S PSDUZ=$P($G(^PSD(58.81,PSDA,0)),"^",7),PSDUZN=$P($G(^VA(200,+PSDUZ,0)),"^"),PSDUZN=$S(PSDUZN]"":$E($P(PSDUZN,",",2))_$E(PSDUZN),1:"**") - S ^TMP("PSDACT",$J,PSDRGN,PSD,TYP,PSDA)=BFWD_"^"_NUM_"^"_TEXT_"^"_QTY_"^"_PSDUZN I $D(PSDRTS) S ^TMP("PSDACT",$J,PSDRGN,PSD,TYP,PSDA)=^TMP("PSDACT",$J,PSDRGN,PSD,TYP,PSDA)_"^1" - K PSDRTS Q -T1 S NUM="***",TEXT="RECEIPT INTO PHARMACY" - I $P($G(^PSD(58.81,PSDA,8)),"^")]"" S NUM=$P($G(^PSD(58.81,PSDA,8)),"^") Q - I +$P(NODE,"^",9) S NUM=+$P(NODE,"^",9),NUM=$P($G(^PRC(442,NUM,0)),"^") Q - I +$P(NODE,"^",8) S NUM=+$P(NODE,"^",8),NUM=$P($G(^PRCS(410,NUM,0)),"^") Q - Q -T2 S QTY=-QTY,NUM="DISP",NAOU=+$P(NODE,"^",18) S:NAOU NAOU=$P($G(^PSD(58.8,+NAOU,0)),"^") S TEXT=$S(NAOU]"":NAOU,1:"DISPENSED FROM PHARMACY") - I +$P(NODE,"^",17) S NUM="GS # "_$P(NODE,"^",17) - Q -T3 S NUM="GS # ",TEXT="RETURNED TO STOCK" - I +$P(NODE,"^",17) S NUM=NUM_$P(NODE,"^",17) - ;PSD*3*30 (Dave B - more precise infor on RTS) - I $G(NUM)="GS # " D - .S RX=$P($G(^PSD(58.81,PSDA,6)),"^"),RXNUM=$P($G(^PSD(58.81,PSDA,6)),"^",5) - .S PAT=$P($G(^PSRX(RX,0)),"^",2) I PAT S DFN=PAT D PID^VADPT6 S Y=PAT,C=$P(^DD(58.81,73,0),"^",2) D Y^DIQ S TEXT=Y_"("_VA("BID")_")" K DFN,VA("BID"),VA("PID") - .S NUM="RX # "_$G(RXNUM)_" ("_$S($P($G(^PSD(58.81,PSDA,6)),U,2):"R"_$P($G(^(6)),U,2),$P($G(^(6)),U,4):"P"_$P($G(^(6)),U,4),1:"O")_")" - .S QTY=$P(^PSD(58.81,PSDA,3),"^",2),BFWD=$P(^PSD(58.81,PSDA,0),"^",10),PSDRTS=1 Q - I $G(PSDRTS)=1 Q - S QTY=$P(^PSD(58.81,PSDA,3),"^",2),BFWD=$P(^(3),"^",7) - Q -T6 S QTY=-QTY,NUM="RX # ",TEXT="OUTPATIENT RX" N RXNUM - S RX=+$P(^PSD(58.81,PSDA,6),"^"),RXNUM=$S($P(^(6),"^",5)]"":$P(^(6),"^",5),$P($G(^PSRX(RX,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN"),NUM=NUM_RXNUM - S NUM=NUM_" ("_$S($P($G(^PSD(58.81,PSDA,6)),U,2):"R"_$P($G(^(6)),U,2),$P($G(^(6)),U,4):"P"_$P($G(^(6)),U,4),1:"O")_")" - S PAT=+$P($G(^PSRX(RX,0)),"^",2) - S PSDRXIN=RX D VER^PSDOPT - ;W !,TEXT," ",RXNUM - S TEXT=$S('$O(^PSRX("B",RXNUM,0)):"RX DELETED",$G(PSDSTA)=13:"RX DELETED",1:"UNKNOWN") - ;W !,TEXT - K PSDSTA,PSOVR,PSDRXIN - I PAT S DFN=PAT D PID^VADPT6 D - .K C S Y=PAT,C=$P(^DD(58.81,73,0),"^",2) D Y^DIQ S TEXT=Y_" ("_VA("BID")_")" K DFN,VA("BID"),VA("PID") - Q -T7 S NUM="GS # ",TEXT="CANCEL UNVERIFIED ORDER",QTY=0 - I +$P(NODE,"^",17) S NUM=NUM_$P(NODE,"^",17) - Q -T9 S NUM="ADJ",TEXT=$S($D(^PSD(58.81,+PSDA,9)):$P(NODE,"^",16),1:"ADJUSTMENT") - I $P(NODE,"^",16)]"" S TEXT=$P(NODE,"^",16) - I $D(^PSD(58.81,PSDA,3)) S NUM="DEST # "_$P(^(3),"^",8),TEXT="HOLDING FOR DESTRUCTION" - Q -T11 S NUM="***",TEXT="INITIALIZE BALANCE AT SETUP" - Q -T13 S NUM="GS # ",TEXT="CANCEL VERIFIED ORDER" - I +$P(NODE,"^",17) S NUM=NUM_$P(NODE,"^",17) - S QTY=$P(^PSD(58.81,PSDA,5),"^",3),BFWD=$P(^(5),"^",5) - Q -T14 S NUM="GS # ",TEXT="EDIT VERIFIED ORDER" - I +$P(NODE,"^",17) S NUM=NUM_$P(NODE,"^",17) - S:$D(^PSD(58.81,PSDA,8)) TEXT="EDIT VERIFIED INVOICE",NUM=$P(^PSD(58.81,PSDA,8),"^",1) ; <*65-RJS> - S QTY=$P(^PSD(58.81,PSDA,4),"^",4),BFWD=$P(^(4),"^",7) - Q -T16 S NUM="TRV",TEXT="TRANSFER TO VAULT" - Q -TOTH ;Type = 19,20,21,22 - S NUM="INV",TEXT=$G(^PSD(58.84,+TYP,0)),QTY="" - Q -PRTQUE ;queues print after compile - K ZTSAVE,ZTIO S ZTIO=PSDIO,ZTRTN="PRINT^PSDACT2",ZTDESC="CS PHARM Print Daily Activity Log",ZTDTH=$H,ZTSAVE("^TMP(""PSDACT"",$J,")="",ZTSAVE("PSDSN")="",ZTSAVE("PSDATE")="" - D ^%ZTLOAD K ZTSK G END +PSDACT1 ;BIR/JPW,BJW-Print Daily Activity Log (cont'd) ; 17 Jun 98 + ;;3.0; CONTROLLED SUBSTANCES ;**10,14,30**;13 Feb 97 + ;Reference to ^PRC(442 supported by IA #682 + ;Reference to ^PRCS(410 supported by IA #198 + ;Reference to ^PSDRUG( supported by IA #221 + ;Reference to ^PSRX( supported by IA #986 + ;Reference to ^DD(58.81 supported by IA #10154 + ;Reference to PSD(58.8 supported by DBIA # 2711 + ;Reference to PSD(58.81 supported by DBIA # 2808 + ;References to PSD(58.84 supported by IA # 3485 + ;modified for nois:tua-0498-32173,new code added to t6 + ;op v.7 chg the status loc in file 52 +START ;entry for compile + K ^TMP("PSDACT",$J) + I $D(ALL) F PSDR=0:0 S PSDR=$O(^PSD(58.8,+PSDS,1,PSDR)) Q:'PSDR I $D(^PSD(58.8,+PSDS,1,PSDR,0)) S PSDRG(+PSDR)="" + F PSD=PSDSD:0 S PSD=$O(^PSD(58.81,"ACT",PSD)) Q:'PSD!(PSD>PSDED) F PSDR=0:0 S PSDR=$O(^PSD(58.81,"ACT",PSD,PSDS,PSDR)) Q:'PSDR D + .Q:'$D(PSDRG(PSDR)) + .F TYP=0:0 S TYP=$O(^PSD(58.81,"ACT",PSD,PSDS,PSDR,TYP)) Q:'TYP!(TYP=12) F PSDA=0:0 S PSDA=$O(^PSD(58.81,"ACT",PSD,PSDS,PSDR,TYP,PSDA)) Q:'PSDA D SET + G:$D(ZTQUEUED) PRTQUE G PRINT^PSDACT2 +END ; + D KVAR^VADPT + K %,%DT,%H,%I,%ZIS,ACT,ALL,BFWD,C,DA,DATE,DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,LN,MFG,NAOU,NODE,NQTY,NUM + K PAT,PG,PHARM,POP,PSD,PSDA,PSDATE,PSDED,PSDEV,PSDIO,PSDOUT,PSDPN,PSDR,PSDRG,PSDRGN,PSDS,PSDSD,PSDSN,PSDUZ,PSDUZN,RX,TEXT,TYP,QTY,TYPE,X,Y,VA("BID"),VA("PID") + K ^TMP("PSDACT",$J),ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK + D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" + Q +SET ;sets data + ;Dave B (PSD*3*14) Disregard if type is 15. + Q:'$D(^PSD(58.81,PSDA,0)) Q:TYP=5 Q:TYP=15 S NODE=^(0),QTY=$P(NODE,"^",6),BFWD=$P(NODE,"^",10) + S PSDRGN=$S($P($G(^PSDRUG(PSDR,0)),"^")]"":$P(^(0),"^"),1:"ZZ/"_PSDR_" NAME MISSING") + S PSDUZ=$S(TYP=3:+$P($G(^PSD(58.81,PSDA,1)),"^",14),TYP=4:+$P($G(^PSD(58.81,PSDA,1)),"^",14),TYP=13:+$P($G(^PSD(58.81,PSDA,5)),"^",2),TYP=14:+$P($G(^PSD(58.81,PSDA,4)),"^",2),1:+$P(NODE,"^",7)) + S:TYP=2 PSDUZ=$S(+$P($G(^PSD(58.81,PSDA,1)),"^"):+$P($G(^(1)),"^"),1:+$P(NODE,"^",7)) + S PSDUZN=$P($G(^VA(200,+PSDUZ,0)),"^"),PSDUZN=$S(PSDUZN]"":$E($P(PSDUZN,",",2))_$E(PSDUZN),1:"**") + I TYP=1 D T1 G TMP + I TYP=2 D T2 G TMP + I TYP=3 Q:'$D(^PSD(58.81,PSDA,3)) D T3 G TMP + Q:TYP=4 + I TYP=6 Q:'$D(^PSD(58.81,PSDA,6)) D T6 G TMP + I TYP=7 D T7 G TMP + I TYP=9 D T9 G TMP + I TYP=11 D T11 G TMP + I TYP=13 Q:'$D(^PSD(58.81,PSDA,5)) D T13 G TMP + I TYP=14 Q:'$D(^PSD(58.81,PSDA,4)) D T14 G TMP + I TYP=16 D T16 G TMP + I TYP>18 D TOTH +TMP ; + S PSDUZN=$P($G(^VA(200,+PSDUZ,0)),"^"),PSDUZN=$S(PSDUZN]"":$E($P(PSDUZN,",",2))_$E(PSDUZN),1:"**") + ;PSD*3*30 (Dave B - Identify person with more than just **) + I $G(PSDUZN)="**" S PSDUZ=$P($G(^PSD(58.81,PSDA,0)),"^",7),PSDUZN=$P($G(^VA(200,+PSDUZ,0)),"^"),PSDUZN=$S(PSDUZN]"":$E($P(PSDUZN,",",2))_$E(PSDUZN),1:"**") + S ^TMP("PSDACT",$J,PSDRGN,PSD,TYP,PSDA)=BFWD_"^"_NUM_"^"_TEXT_"^"_QTY_"^"_PSDUZN I $D(PSDRTS) S ^TMP("PSDACT",$J,PSDRGN,PSD,TYP,PSDA)=^TMP("PSDACT",$J,PSDRGN,PSD,TYP,PSDA)_"^1" + K PSDRTS Q +T1 S NUM="***",TEXT="RECEIPT INTO PHARMACY" + I $P($G(^PSD(58.81,PSDA,8)),"^")]"" S NUM=$P($G(^PSD(58.81,PSDA,8)),"^") Q + I +$P(NODE,"^",9) S NUM=+$P(NODE,"^",9),NUM=$P($G(^PRC(442,NUM,0)),"^") Q + I +$P(NODE,"^",8) S NUM=+$P(NODE,"^",8),NUM=$P($G(^PRCS(410,NUM,0)),"^") Q + Q +T2 S QTY=-QTY,NUM="DISP",NAOU=+$P(NODE,"^",18) S:NAOU NAOU=$P($G(^PSD(58.8,+NAOU,0)),"^") S TEXT=$S(NAOU]"":NAOU,1:"DISPENSED FROM PHARMACY") + I +$P(NODE,"^",17) S NUM="GS # "_$P(NODE,"^",17) + Q +T3 S NUM="GS # ",TEXT="RETURNED TO STOCK" + I +$P(NODE,"^",17) S NUM=NUM_$P(NODE,"^",17) + ;PSD*3*30 (Dave B - more precise infor on RTS) + I $G(NUM)="GS # " D + .S RX=$P($G(^PSD(58.81,PSDA,6)),"^"),RXNUM=$P($G(^PSD(58.81,PSDA,6)),"^",5) + .S PAT=$P($G(^PSRX(RX,0)),"^",2) I PAT S DFN=PAT D PID^VADPT6 S Y=PAT,C=$P(^DD(58.81,73,0),"^",2) D Y^DIQ S TEXT=Y_"("_VA("BID")_")" K DFN,VA("BID"),VA("PID") + .S NUM="RX # "_$G(RXNUM)_" ("_$S($P($G(^PSD(58.81,PSDA,6)),U,2):"R"_$P($G(^(6)),U,2),$P($G(^(6)),U,4):"P"_$P($G(^(6)),U,4),1:"O")_")" + .S QTY=$P(^PSD(58.81,PSDA,3),"^",2),BFWD=$P(^PSD(58.81,PSDA,0),"^",10),PSDRTS=1 Q + I $G(PSDRTS)=1 Q + S QTY=$P(^PSD(58.81,PSDA,3),"^",2),BFWD=$P(^(3),"^",7) + Q +T6 S QTY=-QTY,NUM="RX # ",TEXT="OUTPATIENT RX" N RXNUM + S RX=+$P(^PSD(58.81,PSDA,6),"^"),RXNUM=$S($P(^(6),"^",5)]"":$P(^(6),"^",5),$P($G(^PSRX(RX,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN"),NUM=NUM_RXNUM + S NUM=NUM_" ("_$S($P($G(^PSD(58.81,PSDA,6)),U,2):"R"_$P($G(^(6)),U,2),$P($G(^(6)),U,4):"P"_$P($G(^(6)),U,4),1:"O")_")" + S PAT=+$P($G(^PSRX(RX,0)),"^",2) + S PSDRXIN=RX D VER^PSDOPT + ;W !,TEXT," ",RXNUM + S TEXT=$S('$O(^PSRX("B",RXNUM,0)):"RX DELETED",$G(PSDSTA)=13:"RX DELETED",1:"UNKNOWN") + ;W !,TEXT + K PSDSTA,PSOVR,PSDRXIN + I PAT S DFN=PAT D PID^VADPT6 D + .K C S Y=PAT,C=$P(^DD(58.81,73,0),"^",2) D Y^DIQ S TEXT=Y_" ("_VA("BID")_")" K DFN,VA("BID"),VA("PID") + Q +T7 S NUM="GS # ",TEXT="CANCEL UNVERIFIED ORDER",QTY=0 + I +$P(NODE,"^",17) S NUM=NUM_$P(NODE,"^",17) + Q +T9 S NUM="ADJ",TEXT=$S($D(^PSD(58.81,+PSDA,9)):$P(NODE,"^",16),1:"ADJUSTMENT") + I $P(NODE,"^",16)]"" S TEXT=$P(NODE,"^",16) + I $D(^PSD(58.81,PSDA,3)) S NUM="DEST # "_$P(^(3),"^",8),TEXT="HOLDING FOR DESTRUCTION" + Q +T11 S NUM="***",TEXT="INITIALIZE BALANCE AT SETUP" + Q +T13 S NUM="GS # ",TEXT="CANCEL VERIFIED ORDER" + I +$P(NODE,"^",17) S NUM=NUM_$P(NODE,"^",17) + S QTY=$P(^PSD(58.81,PSDA,5),"^",3),BFWD=$P(^(5),"^",5) + Q +T14 S NUM="GS # ",TEXT="EDIT VERIFIED ORDER" + I +$P(NODE,"^",17) S NUM=NUM_$P(NODE,"^",17) + S QTY=$P(^PSD(58.81,PSDA,4),"^",4),BFWD=$P(^(4),"^",7) + Q +T16 S NUM="TRV",TEXT="TRANSFER TO VAULT" + Q +TOTH ;Type = 19,20,21,22 + S NUM="INV",TEXT=$G(^PSD(58.84,+TYP,0)),QTY="" + Q +PRTQUE ;queues print after compile + K ZTSAVE,ZTIO S ZTIO=PSDIO,ZTRTN="PRINT^PSDACT2",ZTDESC="CS PHARM Print Daily Activity Log",ZTDTH=$H,ZTSAVE("^TMP(""PSDACT"",$J,")="",ZTSAVE("PSDSN")="",ZTSAVE("PSDATE")="" + D ^%ZTLOAD K ZTSK G END diff --git a/r/CONTROLLED_SUBSTANCES-PSD/PSDNRGS.m b/r/CONTROLLED_SUBSTANCES-PSD/PSDNRGS.m index 8e268c63..e8c59d9f 100644 --- a/r/CONTROLLED_SUBSTANCES-PSD/PSDNRGS.m +++ b/r/CONTROLLED_SUBSTANCES-PSD/PSDNRGS.m @@ -1,57 +1,53 @@ -PSDNRGS ;BIR/JPW-Receive Green Sheet for NAOU ; 6 Jan 94 - ;;3.0; CONTROLLED SUBSTANCES ;**56,66,65**;13 Feb 97;Build 5 - I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE) - S OK=$S($D(^XUSEC("PSJ RNURSE",DUZ)):1,$D(^XUSEC("PSD NURSE",DUZ)):1,$D(^XUSEC("PSJ RPHARM",DUZ)):2,$D(^XUSEC("PSJ PHARM TECH",DUZ)):2,1:0) - I 'OK W $C(7),!!,?9,"** Please contact your Coordinator for access to complete",!,?12,"narcotic orders.",!!,"PSJ RNURSE, PSD NURSE, PSJ RPHARM, or PSJ PHARM TECH security key required.",! K OK Q - I $P($G(^VA(200,DUZ,20)),U,4)']"" N XQH S XQH="PSD ESIG" D EN^XQH Q - W !!,"Receive Controlled Substances Orders and Green Sheet" S PSDUZ=DUZ,PSDUZN=$S($P($G(^VA(200,PSDUZ,0)),"^")]"":$P(^(0),"^"),1:"") - N X,X1 D SIG^XUSESIG Q:X1="" -ASKN ;ask naou - W ! K DA,DIC S DIC=58.8,DIC(0)="QEAZ",DIC("A")="Select NAOU: " - S:OK=1 DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$S('$D(^(""I"")):1,'^(""I""):1,+^(""I"")>DT:1,1:0),$P(^(0),""^"",2)=""N"",'$P(^(0),""^"",7)" - S:OK=2 DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$S('$D(^(""I"")):1,'^(""I""):1,+^(""I"")>DT:1,1:0),$P(^(0),""^"",2)=""N""" - D ^DIC K DIC G:Y<0 END S AOU=+Y,AOUN=$P(Y,"^",2) -GS ;select green sheet # - W ! K DA,DIC S DIC("A")="Select the Green Sheet #: ",DIC=58.81,DIC(0)="QEASZ",D="D" - S DIC("S")="I $P(^(0),""^"",11),$P(^(0),""^"",11)<12" - D IX^DIC K DIC G:Y<0 ASKN S PSDA=+Y -ORD S STAT=+$P(Y(0),"^",11),PSDPN=$P(Y(0),"^",17),STATN="" I STAT S STATN=$P($G(^PSD(58.82,STAT,0)),"^") - S ORD=+$P(Y(0),"^",20),NAOU=+$P(Y(0),"^",18),NAOUN=$P($G(^PSD(58.8,NAOU,0)),"^"),PSDR=+$P(Y(0),"^",5),PSDRN=$P($G(^PSDRUG(PSDR,0)),"^"),QTY=+$P(Y(0),"^",6) - ; >> RJS - *65 - L +^PSD(58.81,PSDA):$S($G(DILOCKTM)>0:DILOCKTM,1:3) - I '$T W !,"The Green Sheet # ",PSDPN," is currently in use by another user",!,"Please select another Green Sheet.",! G GS - I $D(^PSD(58.81,PSDA,4)),+$P(^(4),"^",3) S QTY=$P(^(4),"^",3) - I AOU'=NAOU W $C(7),!!,"The Green Sheet # ",PSDPN," is assigned to ",NAOUN,".",!,"Please select another Green Sheet.",! L -^PSD(58.81,PSDA) G GS ; 0:DILOCKTM,1:3) I Q - ;PSD*3*56;REMOVED CHECK FOR PATIENT ID - S $P(^PSD(58.8,NAOU,1,PSDR,0),"^",4)=$P(^PSD(58.8,NAOU,1,PSDR,0),"^",4)+QTY - L -^PSD(58.8,NAOU,1,PSDR,0) - ;update transaction file (58.81) - S OREC=$P($G(^PSD(58.8,NAOU,1,PSDR,3,ORD,0)),"^",7) - K DA,DIE,DR S DA=PSDA,DIE=58.81 - S DR="10////"_$S('$P($G(^PSD(58.8,NAOU,2)),U,5):4,$P($G(^PSD(58.81,PSDA,9)),U):4,1:13)_";20////"_OREC_";21////"_RECD_";27////"_QTY_";I OK=1 S Y=""@1"";15COMMENTS;@1" - D ^DIE K DA,DIE,DR - I OK=2 S $P(^PSD(58.81,PSDA,1),"^",11)=PSDUZ - W !!,"Updating your records now..." - ;update worksheet file (58.85) to be purged - S DA=+$O(^PSD(58.85,"AD",NAOU,PSDR,ORD,0)) I DA,$D(^PSD(58.85,DA,0)) K DIE,DR S DIE=58.85,DR="6////4" D ^DIE K DA,DIE,DR - W "done.",!! - S STAT=$P($G(^PSD(58.81,PSDA,0)),"^",11) W ?5,"*** Your Green Sheet #"_PSDPN_" is now "_$S($P($G(^PSD(58.82,STAT,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")_" ***",! - L -^PSD(58.81,PSDA) ;< RJS - *65 - G GS -END K %,%DT,%H,%I,AOU,AOUN,D,DA,DIC,DIE,DR,DTOUT,DUOUT - K NAOU,NAOUN,OK,ORD,OREC,PSDPN,PSDR,PSDRN,PSDUZ,PSDUZN,QTY,RECD,RECDT,RQTY,STAT,STATN,SUB,PSDA,X,Y - Q +PSDNRGS ;BIR/JPW-Receive Green Sheet for NAOU ; 6 Jan 94 + ;;3.0; CONTROLLED SUBSTANCES ;**56,66**;13 Feb 97;Build 3 + I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE) + S OK=$S($D(^XUSEC("PSJ RNURSE",DUZ)):1,$D(^XUSEC("PSD NURSE",DUZ)):1,$D(^XUSEC("PSJ RPHARM",DUZ)):2,$D(^XUSEC("PSJ PHARM TECH",DUZ)):2,1:0) + I 'OK W $C(7),!!,?9,"** Please contact your Coordinator for access to complete",!,?12,"narcotic orders.",!!,"PSJ RNURSE, PSD NURSE, PSJ RPHARM, or PSJ PHARM TECH security key required.",! K OK Q + I $P($G(^VA(200,DUZ,20)),U,4)']"" N XQH S XQH="PSD ESIG" D EN^XQH Q + W !!,"Receive Controlled Substances Orders and Green Sheet" S PSDUZ=DUZ,PSDUZN=$S($P($G(^VA(200,PSDUZ,0)),"^")]"":$P(^(0),"^"),1:"") + N X,X1 D SIG^XUSESIG Q:X1="" +ASKN ;ask naou + W ! K DA,DIC S DIC=58.8,DIC(0)="QEAZ",DIC("A")="Select NAOU: " + S:OK=1 DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$S('$D(^(""I"")):1,'^(""I""):1,+^(""I"")>DT:1,1:0),$P(^(0),""^"",2)=""N"",'$P(^(0),""^"",7)" + S:OK=2 DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$S('$D(^(""I"")):1,'^(""I""):1,+^(""I"")>DT:1,1:0),$P(^(0),""^"",2)=""N""" + D ^DIC K DIC G:Y<0 END S AOU=+Y,AOUN=$P(Y,"^",2) +GS ;select green sheet # + W ! K DA,DIC S DIC("A")="Select the Green Sheet #: ",DIC=58.81,DIC(0)="QEASZ",D="D" + S DIC("S")="I $P(^(0),""^"",11),$P(^(0),""^"",11)<12" + D IX^DIC K DIC G:Y<0 ASKN S PSDA=+Y +ORD S STAT=+$P(Y(0),"^",11),PSDPN=$P(Y(0),"^",17),STATN="" I STAT S STATN=$P($G(^PSD(58.82,STAT,0)),"^") + S ORD=+$P(Y(0),"^",20),NAOU=+$P(Y(0),"^",18),NAOUN=$P($G(^PSD(58.8,NAOU,0)),"^"),PSDR=+$P(Y(0),"^",5),PSDRN=$P($G(^PSDRUG(PSDR,0)),"^"),QTY=+$P(Y(0),"^",6) + I $D(^PSD(58.81,PSDA,4)),+$P(^(4),"^",3) S QTY=$P(^(4),"^",3) + I AOU'=NAOU W $C(7),!!,"The Green Sheet # ",PSDPN," is assigned to ",NAOUN,".",!,"Please select another Green Sheet.",! G GS + I '$D(^PSD(58.8,NAOU,1,PSDR,3,ORD,0)) W $C(7),!!,"There's no data on ",NAOUN," for Green Sheet # ",PSDPN,".",!,"Contact your Pharmacy Coordinator for assistance.",! G END + I STAT'=3 W $C(7),!!,"This Green Sheet has a status of "_$S(STATN]"":STATN,1:"UNKNOWN")_".",!,"Please select another Green Sheet.",! G GS + D NOW^%DTC S (RECD,Y)=+$E(%,1,12) X ^DD("DD") S RECDT=Y +REC ;receive at order level in 58.8 + W !!,"Accessing ",PSDRN," information...",!! + K DA,DIR,DIRUT S DIR(0)="58.81,27",DIR("B")=QTY D ^DIR K DIR I $D(DIRUT) W !!,"Quantity not entered. No action taken.",!,"This order remains ",STATN,!! G END + S RQTY=Y I RQTY'=QTY W $C(7),!!,"The quantity received does not match the quantity dispensed.",!,"This order must be returned to pharmacy for investigation.",!! G GS + K DA,DIE,DR S DA=ORD,DA(1)=PSDR,DA(2)=NAOU + S DIE="^PSD(58.8,"_DA(2)_",1,"_DA(1)_",3," + S DR=$S(OK=1:"6////"_PSDUZ,1:"6RECEIVED BY NURSE")_";20////"_QTY_";15////"_RECD_";10////4;22////"_$P($G(^PSD(58.8,NAOU,1,PSDR,0)),U,4)_";25////"_$P($G(^PSD(58.8,NAOU,1,PSDR,0)),U,4) D ^DIE K DA,DIE,DR + I ($D(Y))!($D(DTOUT)) W $C(7),!!,"*** THIS ORDER HAS NOT BEEN RECEIVED ***",!,"Receiving nurses name must be entered.",!!,"The status remains "_STATN,! G END +UPDATE ;update 58.8 and 58.81 + ;updating drug balance in 58.8 + F L +^PSD(58.8,NAOU,1,PSDR,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q + ;PSD*3*56;REMOVED CHECK FOR PATIENT ID + S $P(^PSD(58.8,NAOU,1,PSDR,0),"^",4)=$P(^PSD(58.8,NAOU,1,PSDR,0),"^",4)+QTY + L -^PSD(58.8,NAOU,1,PSDR,0) + ;update transaction file (58.81) + S OREC=$P($G(^PSD(58.8,NAOU,1,PSDR,3,ORD,0)),"^",7) + K DA,DIE,DR S DA=PSDA,DIE=58.81 + S DR="10////"_$S('$P($G(^PSD(58.8,NAOU,2)),U,5):4,$P($G(^PSD(58.81,PSDA,9)),U):4,1:13)_";20////"_OREC_";21////"_RECD_";27////"_QTY_";I OK=1 S Y=""@1"";15COMMENTS;@1" + D ^DIE K DA,DIE,DR + I OK=2 S $P(^PSD(58.81,PSDA,1),"^",11)=PSDUZ + W !!,"Updating your records now..." + ;update worksheet file (58.85) to be purged + S DA=+$O(^PSD(58.85,"AD",NAOU,PSDR,ORD,0)) I DA,$D(^PSD(58.85,DA,0)) K DIE,DR S DIE=58.85,DR="6////4" D ^DIE K DA,DIE,DR + W "done.",!! + S STAT=$P($G(^PSD(58.81,PSDA,0)),"^",11) W ?5,"*** Your Green Sheet #"_PSDPN_" is now "_$S($P($G(^PSD(58.82,STAT,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")_" ***",! + G GS +END K %,%DT,%H,%I,AOU,AOUN,D,DA,DIC,DIE,DR,DTOUT,DUOUT + K NAOU,NAOUN,OK,ORD,OREC,PSDPN,PSDR,PSDRN,PSDUZ,PSDUZN,QTY,RECD,RECDT,RQTY,STAT,STATN,SUB,PSDA,X,Y + Q diff --git a/r/CONTROLLED_SUBSTANCES-PSD/PSDNTF.m b/r/CONTROLLED_SUBSTANCES-PSD/PSDNTF.m index 977cc475..0e50de59 100644 --- a/r/CONTROLLED_SUBSTANCES-PSD/PSDNTF.m +++ b/r/CONTROLLED_SUBSTANCES-PSD/PSDNTF.m @@ -1,84 +1,77 @@ -PSDNTF ;BIR/JPW-Transfer Green Sheet - From this NAOU ; 8/29/07 1:25pm - ;;3.0; CONTROLLED SUBSTANCES ;**8,56,63,66,64**;13 Feb 97;Build 33 - ;**Y2K compliance**;display 4 digit year on va forms - I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE) - S OK=$S($D(^XUSEC("PSJ RNURSE",DUZ)):1,$D(^XUSEC("PSD NURSE",DUZ)):1,$D(^XUSEC("PSJ RPHARM",DUZ)):1,1:0) - I 'OK W $C(7),!!,?9,"** Please contact your Coordinator for access to",!,?12,"transfer narcotic orders.",!!,"PSJ RNURSE, PSD NURSE, or PSJ RPHARM security key required.",! K OK Q - W !!,"Transfer a Green Sheet from this NAOU" S PSDUZ=DUZ,PSDUZN=$P($G(^VA(200,PSDUZ,0)),"^") -ASKN ;ask transfer from naou - W ! K DA,DIC S DIC=58.8,DIC(0)="QEAZ",DIC("A")="Select Transfer from NAOU: " - S DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$S('$D(^(""I"")):1,'^(""I""):1,+^(""I"")>DT:1,1:0),$P(^(0),""^"",2)=""N"",'$P(^(0),""^"",7)" - D ^DIC K DIC G:Y<0 END S AOU=+Y,AOUN=$P(Y,"^",2) -GS ;select green sheet # - W ! K DA,DIC S DIC("A")="Select the Green Sheet #: ",DIC=58.81,DIC(0)="QEASZ",D="D" - S DIC("S")="I $P(^(0),""^"",11)=4!($P(^(0),U,11)=13),$P(^(0),""^"",18)=AOU",DIC("W")="W "" "",$P($G(^PSDRUG($P(^(0),U,5),0)),U),"" => "",$P($G(^DPT(+$P($G(^PSD(58.81,Y,9)),U),0)),U)" - D IX^DIC K DIC G:Y<0 END S PSDA=+Y - S STAT=+$P(Y(0),"^",11),PSDPN=$P(Y(0),"^",17),STATN="" I STAT S STATN=$P($G(^PSD(58.82,STAT,0)),"^") - S ORD=+$P(Y(0),"^",20),NAOU=+$P(Y(0),"^",18),NAOUN=$P($G(^PSD(58.8,NAOU,0)),"^"),PSDR=+$P(Y(0),"^",5),PSDRN=$P($G(^PSDRUG(PSDR,0)),"^") - S MFG=$P(Y(0),"^",13),LOT=$P(Y(0),"^",14),EXP=$P(Y(0),"^",15),QTY=+$P(Y(0),"^",6),PSDS=+$P(Y(0),"^",3) - S NBKU=$P($G(^PSD(58.8,+PSDS,1,+PSDR,0)),"^",8) - I $D(^PSD(58.81,PSDA,4)),+$P(^(4),"^",3) S QTY=+$P(^(4),"^",3) - I AOU'=NAOU W !!,"The Green Sheet # ",PSDPN," does not reside on ",AOUN,".",!,"Please select another Green Sheet.",! G ASKN - I '$D(^PSD(58.8,NAOU,1,PSDR,3,ORD,0)) W $C(7),!!,"There's no data on ",NAOUN," for Green Sheet # ",PSDPN,".",!,"Contact your Pharmacy Coordinator for assistance.",! G END - I STAT'=4,STAT'=13 W !!,"This Green Sheet has a status of "_$S(STATN]"":STATN,1:"UNKNOWN")_".",!,"Please contact your Pharmacy Coordinator for assistance.",! G END - I 'QTY W !!,"Previous transfer quantity was 0.",!,"Use option 'Transfer GS for PCA/Infusion Signed Out to Patient'",! G END -ASKT ;ask transfer to naou - W ! K DA,DIC S DIC=58.8,DIC(0)="QEAZ",DIC("A")="Select Transfer To NAOU: " - S DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$S('$D(^(""I"")):1,'^(""I""):1,+^(""I"")>DT:1,1:0),$P(^(0),""^"",2)=""N"",'$P(^(0),""^"",7)" - D ^DIC K DIC G:Y<0 END S NAOUT=+Y,NAOUTN=$P(Y,"^",2) - I NAOUT=AOU W !!,"You may not transfer a Green Sheet to your NAOU!",!,"Please select another NAOU.",!! G ASKT - ;*64 - N PSDGS,PSDGSPTQ,PSDGSP0,PSDGSP9 - S PSDGS=0 F S PSDGS=$O(^PSD(58.81,"D",PSDPN,PSDGS)) Q:'PSDGS D - .S PSDGSP0=$G(^PSD(58.81,PSDGS,0)),PSDGSP9=$G(^PSD(58.81,PSDGS,9)) - .I $P(PSDGSP0,"^",2)=17,$P(PSDGSP9,"^",1)]"" S PSDGSPTQ=$G(PSDGSPTQ)+$P(PSDGSP9,"^",3) - I $G(PSDGSPTQ) W !!,"Green Sheet "_PSDPN_" has dose(s) signed out to patient.",! - I QTY=1 S RQTY=1 W !,"Quantity to Transfer (",NBKU,"/1)",! G OK -QTY ; - W !,"Quantity to Transfer ("_NBKU_"/"_QTY_"): " R X:DTIME I '$T!(X="^")!(X="") S PSDOUT=1 W !!,"**** No action taken. ****",!! G END - ;I X'?1.6N!(X=0) W !!,"Enter a whole number between 1 and ",QTY,! G QTY - I +X'=X!(X>999999)!(X'>0)!(X?.E1"."4N.N) D G QTY - . W !!,"Enter a number between .01 and ",QTY,! - I X>QTY W $C(7),!!,"The quantity returned must not exceed "_QTY_"!",! G QTY - S RQTY=X -OK ;if perpetual NAOU and not ordered for patient - D:QTY=1&('$P($G(^PSD(58.81,PSDA,9)),U)) G:$G(PSDOUT) END - .W !,PSDRN," Current Balance: ",$P($G(^PSD(58.8,NAOU,1,PSDR,0)),U,4)," ",NBKU,! - .S DIR(0)="Y",DIR("A")="Is this a PCA syringe that has already been signed out for a patient",DIR("B")="Y",DIR("?")="If you answer no, your balance will be subtracted by one" D ^DIR K DIR I $D(DIRUT) S PSDOUT=1 Q - .Q:Y'=1 - .S RQTY(1)=1 - .S DIC="^DPT(",DIC(0)="AEMQ",DIC("A")="Scan/Enter Patient: " - .W ! D ^DIC K DIC I Y<1 S PSDOUT=1 W !!,"No action taken.",!! Q - .S PAT=+Y - ;ask ok to transfer - W ! K DA,DIR,DIRUT S DIR(0)="Y",DIR("A")="Are you sure",DIR("B")="NO" - S DIR("?",1)="Answer 'YES' to transfer this Green Sheet to another NAOU or",DIR("?")="answer 'NO' to leave the Green Sheet status active on your NAOU." - D ^DIR K DIR G:$D(DIRUT) END G:'Y GS - D NOW^%DTC S (RECD,Y)=+$E(%,1,12) X ^DD("DD") S RECDT=Y -COM ;complete at order level in 58.8 - W !!,"Accessing ",PSDRN," information...",!! - S BQTY=$S($P($G(^PSD(58.8,NAOU,1,PSDR,3,ORD,0)),"^",22):$P(^(0),"^",22)-RQTY,1:QTY-RQTY) - W !!,"Updating your records now..." - ;update transaction file (58.81) - K DA,DIE,DR S DA=PSDA,DIE=58.81,DR="64////"_RECD_";65////"_PSDUZ_";66////"_NAOUT_";70////"_RQTY_";10////10;73////"_$G(PAT) D ^DIE K DA,DIE,DR - I $D(Y)!$D(DTOUT) W $C(7),!!,"** THIS GREEN SHEET HAS NOT BEEN TRANSFERRED **",!!,"The status remains "_STATN,! G END - ;update order - K DA,DIE,DR S DA=ORD,DA(1)=PSDR,DA(2)=NAOU,DIE="^PSD(58.8,"_DA(2)_",1,"_DA(1)_",3,",DR="10////10;22////"_BQTY D ^DIE K DA,DIE,DR - ;update naou bal - F L +^PSD(58.8,NAOU,1,PSDR,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q - ;PSD*3*56;REMOVED CHECK FOR PATIENT ID - S:'$G(RQTY(1)) $P(^PSD(58.8,NAOU,1,PSDR,0),"^",4)=$P(^PSD(58.8,NAOU,1,PSDR,0),"^",4)-RQTY - W:$P($G(^PSD(58.8,NAOU,2)),U,5) !,PSDRN," Remaining Balance: ",$P($G(^PSD(58.8,NAOU,1,PSDR,0)),U,4)," ",NBKU,! - L -^PSD(58.8,NAOU,1,PSDR,0) - S STAT=$P($G(^PSD(58.81,PSDA,0)),"^",11) - W ?2,!,"*** The status of your Green Sheet #"_PSDPN_" is now",!,$S($P($G(^PSD(58.82,STAT,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")_" ***",! -PRINT ;print 2321 - W !!,"Number of copies of VA FORM 10-2321? " R NUM:DTIME I '$T!(NUM="^")!(NUM="") W !!,"No copies printed!!",!! Q - I NUM'?1N!(NUM=0) W !!,"Enter a whole number between 1 and 9",! G PRINT - S Y=RECD X ^DD("DD") S PSDYR=$P(Y,",",2),PSDYR=$E(PSDYR,1,4) - S (PG,PSDOUT)=0,REAS="",COMP=999,RECDT=$E(RECD,4,5)_"/"_$E(RECD,6,7)_"/"_PSDYR - I EXP S (EXP1,EXPD)=$$FMTE^XLFDT(EXP,"5D") S:'$P(EXP1,"/",2) EXPD=$P(EXP1,"/")_"/"_$P(EXP1,"/",3) S EXP=EXPD - D ^PSDGSRV2 -END K %,%DT,%H,%I,AOU,AOUN,BQTY,COMP,D,DA,DIC,DIE,DIR,DIROUT,DIRUT,DR,DTOUT,DUOUT,EXP,EXP1,EXPD,LOT,MFG - K NAOU,NAOUN,NAOUT,NAOUTN,NBKU,NUM,OK,ORD,PG,PSDA,PSDOUT,PSDPN,PSDR,PSDRN,PSDS,PSDUZ,PSDUZN,PSDYR,QTY,REAS,RECD,RECDT,RQTY,STAT,STATN,X,Y - Q +PSDNTF ;BIR/JPW-Transfer Green Sheet - From this NAOU ; 1 Mar 98 + ;;3.0; CONTROLLED SUBSTANCES ;**8,56,63,66**;13 Feb 97;Build 3 + ;**Y2K compliance**;display 4 digit year on va forms + I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE) + S OK=$S($D(^XUSEC("PSJ RNURSE",DUZ)):1,$D(^XUSEC("PSD NURSE",DUZ)):1,$D(^XUSEC("PSJ RPHARM",DUZ)):1,1:0) + I 'OK W $C(7),!!,?9,"** Please contact your Coordinator for access to",!,?12,"transfer narcotic orders.",!!,"PSJ RNURSE, PSD NURSE, or PSJ RPHARM security key required.",! K OK Q + W !!,"Transfer a Green Sheet from this NAOU" S PSDUZ=DUZ,PSDUZN=$P($G(^VA(200,PSDUZ,0)),"^") +ASKN ;ask transfer from naou + W ! K DA,DIC S DIC=58.8,DIC(0)="QEAZ",DIC("A")="Select Transfer from NAOU: " + S DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$S('$D(^(""I"")):1,'^(""I""):1,+^(""I"")>DT:1,1:0),$P(^(0),""^"",2)=""N"",'$P(^(0),""^"",7)" + D ^DIC K DIC G:Y<0 END S AOU=+Y,AOUN=$P(Y,"^",2) +GS ;select green sheet # + W ! K DA,DIC S DIC("A")="Select the Green Sheet #: ",DIC=58.81,DIC(0)="QEASZ",D="D" + S DIC("S")="I $P(^(0),""^"",11)=4!($P(^(0),U,11)=13),$P(^(0),""^"",18)=AOU",DIC("W")="W "" "",$P($G(^PSDRUG($P(^(0),U,5),0)),U),"" => "",$P($G(^DPT(+$P($G(^PSD(58.81,Y,9)),U),0)),U)" + D IX^DIC K DIC G:Y<0 END S PSDA=+Y + S STAT=+$P(Y(0),"^",11),PSDPN=$P(Y(0),"^",17),STATN="" I STAT S STATN=$P($G(^PSD(58.82,STAT,0)),"^") + S ORD=+$P(Y(0),"^",20),NAOU=+$P(Y(0),"^",18),NAOUN=$P($G(^PSD(58.8,NAOU,0)),"^"),PSDR=+$P(Y(0),"^",5),PSDRN=$P($G(^PSDRUG(PSDR,0)),"^") + S MFG=$P(Y(0),"^",13),LOT=$P(Y(0),"^",14),EXP=$P(Y(0),"^",15),QTY=+$P(Y(0),"^",6),PSDS=+$P(Y(0),"^",3) + S NBKU=$P($G(^PSD(58.8,+PSDS,1,+PSDR,0)),"^",8) + I $D(^PSD(58.81,PSDA,4)),+$P(^(4),"^",3) S QTY=+$P(^(4),"^",3) + I AOU'=NAOU W !!,"The Green Sheet # ",PSDPN," does not reside on ",AOUN,".",!,"Please select another Green Sheet.",! G ASKN + I '$D(^PSD(58.8,NAOU,1,PSDR,3,ORD,0)) W $C(7),!!,"There's no data on ",NAOUN," for Green Sheet # ",PSDPN,".",!,"Contact your Pharmacy Coordinator for assistance.",! G END + I STAT'=4,STAT'=13 W !!,"This Green Sheet has a status of "_$S(STATN]"":STATN,1:"UNKNOWN")_".",!,"Please contact your Pharmacy Coordinator for assistance.",! G END +ASKT ;ask transfer to naou + W ! K DA,DIC S DIC=58.8,DIC(0)="QEAZ",DIC("A")="Select Transfer To NAOU: " + S DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$S('$D(^(""I"")):1,'^(""I""):1,+^(""I"")>DT:1,1:0),$P(^(0),""^"",2)=""N"",'$P(^(0),""^"",7)" + D ^DIC K DIC G:Y<0 END S NAOUT=+Y,NAOUTN=$P(Y,"^",2) + I NAOUT=AOU W !!,"You may not transfer a Green Sheet to your NAOU!",!,"Please select another NAOU.",!! G ASKT + I QTY=1 S RQTY=1 W !,"Quantity to Transfer (",NBKU,"/1)",! G OK +QTY ; + W !,"Quantity to Transfer ("_NBKU_"/"_QTY_"): " R X:DTIME I '$T!(X="^")!(X="") S PSDOUT=1 W !!,"**** No action taken. ****",!! G END + ;I X'?1.6N!(X=0) W !!,"Enter a whole number between 1 and ",QTY,! G QTY + I +X'=X!(X>999999)!(X'>0)!(X?.E1"."4N.N) D G QTY + . W !!,"Enter a number between .01 and ",QTY,! + I X>QTY W $C(7),!!,"The quantity returned must not exceed "_QTY_"!",! G QTY + S RQTY=X +OK ;if perpetual NAOU and not ordered for patient + D:QTY=1&('$P($G(^PSD(58.81,PSDA,9)),U)) G:$G(PSDOUT) END + .W !,PSDRN," Current Balance: ",$P($G(^PSD(58.8,NAOU,1,PSDR,0)),U,4)," ",NBKU,! + .S DIR(0)="Y",DIR("A")="Is this a PCA syringe that has already been signed out for a patient",DIR("B")="Y",DIR("?")="If you answer no, your balance will be subtracted by one" D ^DIR K DIR I $D(DIRUT) S PSDOUT=1 Q + .Q:Y'=1 + .S RQTY(1)=1 + .S DIC="^DPT(",DIC(0)="AEMQ",DIC("A")="Scan/Enter Patient: " + .W ! D ^DIC K DIC I Y<1 S PSDOUT=1 W !!,"No action taken.",!! Q + .S PAT=+Y + ;ask ok to transfer + W ! K DA,DIR,DIRUT S DIR(0)="Y",DIR("A")="Are you sure",DIR("B")="NO" + S DIR("?",1)="Answer 'YES' to transfer this Green Sheet to another NAOU or",DIR("?")="answer 'NO' to leave the Green Sheet status active on your NAOU." + D ^DIR K DIR G:$D(DIRUT) END G:'Y GS + D NOW^%DTC S (RECD,Y)=+$E(%,1,12) X ^DD("DD") S RECDT=Y +COM ;complete at order level in 58.8 + W !!,"Accessing ",PSDRN," information...",!! + S BQTY=$S($P($G(^PSD(58.8,NAOU,1,PSDR,3,ORD,0)),"^",22):$P(^(0),"^",22)-RQTY,1:QTY-RQTY) + W !!,"Updating your records now..." + ;update transaction file (58.81) + K DA,DIE,DR S DA=PSDA,DIE=58.81,DR="64////"_RECD_";65////"_PSDUZ_";66////"_NAOUT_";70////"_RQTY_";10////10;73////"_$G(PAT) D ^DIE K DA,DIE,DR + I $D(Y)!$D(DTOUT) W $C(7),!!,"** THIS GREEN SHEET HAS NOT BEEN TRANSFERRED **",!!,"The status remains "_STATN,! G END + ;update order + K DA,DIE,DR S DA=ORD,DA(1)=PSDR,DA(2)=NAOU,DIE="^PSD(58.8,"_DA(2)_",1,"_DA(1)_",3,",DR="10////10;22////"_BQTY D ^DIE K DA,DIE,DR + ;update naou bal + F L +^PSD(58.8,NAOU,1,PSDR,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q + ;PSD*3*56;REMOVED CHECK FOR PATIENT ID + S:'$G(RQTY(1)) $P(^PSD(58.8,NAOU,1,PSDR,0),"^",4)=$P(^PSD(58.8,NAOU,1,PSDR,0),"^",4)-RQTY + W:$P($G(^PSD(58.8,NAOU,2)),U,5) !,PSDRN," Remaining Balance: ",$P($G(^PSD(58.8,NAOU,1,PSDR,0)),U,4)," ",NBKU,! + L -^PSD(58.8,NAOU,1,PSDR,0) + S STAT=$P($G(^PSD(58.81,PSDA,0)),"^",11) + W ?2,!,"*** The status of your Green Sheet #"_PSDPN_" is now",!,$S($P($G(^PSD(58.82,STAT,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")_" ***",! +PRINT ;print 2321 + W !!,"Number of copies of VA FORM 10-2321? " R NUM:DTIME I '$T!(NUM="^")!(NUM="") W !!,"No copies printed!!",!! Q + I NUM'?1N!(NUM=0) W !!,"Enter a whole number between 1 and 9",! G PRINT + S Y=RECD X ^DD("DD") S PSDYR=$P(Y,",",2),PSDYR=$E(PSDYR,1,4) + S (PG,PSDOUT)=0,REAS="",COMP=999,RECDT=$E(RECD,4,5)_"/"_$E(RECD,6,7)_"/"_PSDYR + I EXP S (EXP1,EXPD)=$$FMTE^XLFDT(EXP,"5D") S:'$P(EXP1,"/",2) EXPD=$P(EXP1,"/")_"/"_$P(EXP1,"/",3) S EXP=EXPD + D ^PSDGSRV2 +END K %,%DT,%H,%I,AOU,AOUN,BQTY,COMP,D,DA,DIC,DIE,DIR,DIROUT,DIRUT,DR,DTOUT,DUOUT,EXP,EXP1,EXPD,LOT,MFG + K NAOU,NAOUN,NAOUT,NAOUTN,NBKU,NUM,OK,ORD,PG,PSDA,PSDOUT,PSDPN,PSDR,PSDRN,PSDS,PSDUZ,PSDUZN,PSDYR,QTY,REAS,RECD,RECDT,RQTY,STAT,STATN,X,Y + Q diff --git a/r/CONTROLLED_SUBSTANCES-PSD/PSDNTT.m b/r/CONTROLLED_SUBSTANCES-PSD/PSDNTT.m index 5ff0cb39..280fd6c4 100644 --- a/r/CONTROLLED_SUBSTANCES-PSD/PSDNTT.m +++ b/r/CONTROLLED_SUBSTANCES-PSD/PSDNTT.m @@ -1,41 +1,39 @@ -PSDNTT ;BIR/JPW-Transfer Green Sheet - Receive this NAOU ; 6/25/07 12:16pm - ;;3.0; CONTROLLED SUBSTANCES ;**64**;13 Feb 97;Build 33 - I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE) - S OK=$S($D(^XUSEC("PSJ RNURSE",DUZ)):1,$D(^XUSEC("PSD NURSE",DUZ)):1,1:0) - I 'OK W $C(7),!!,?9,"** Please contact your Coordinator for access to transfer",!,?12,"narcotic orders.",!!,"PSJ RNURSE or PSD NURSE security key required.",! K OK Q - I $P($G(^VA(200,DUZ,20)),U,4)']"" N XQH S XQH="PSD ESIG" D EN^XQH Q - W !!,"Receive a transferred Green Sheet into this NAOU" S PSDUZ=DUZ,PSDUZN=$P($G(^VA(200,PSDUZ,0)),"^") -ASKN ;ask transfer to naou - W ! K DA,DIC S DIC=58.8,DIC(0)="QEAZ",DIC("A")="Select Receive Transfer In NAOU: " - S DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$S('$D(^(""I"")):1,'^(""I""):1,+^(""I"")>DT:1,1:0),$P(^(0),""^"",2)=""N"",'$P(^(0),""^"",7)" - D ^DIC K DIC G:Y<0 END S AOU=+Y,AOUN=$P(Y,"^",2) -GS ;select green sheet # - W ! K DA,DIC S DIC("A")="Select the Green Sheet #: ",DIC=58.81,DIC(0)="QEASZ",D="D" - S DIC("S")="I $P(^(0),""^"",11)=10,'$P($G(^(7)),""^"",4),($P($G(^(7)),""^"",3)=AOU)!($P(^(0),""^"",18)=AOU)" - D IX^DIC K DIC G:Y<0 END S PSDA=+Y - S STAT=+$P(Y(0),"^",11),PSDPN=$P(Y(0),"^",17),STATN="" I STAT S STATN=$P($G(^PSD(58.82,STAT,0)),"^") - S ORD=+$P(Y(0),"^",20),PSDRG=+$P(Y(0),"^",5),PSDRGN=$P($G(^PSDRUG(PSDRG,0)),"^") - S NAOUF=+$P(Y(0),"^",18),NAOUFN=$P($G(^PSD(58.8,+NAOUF,0)),"^") - S PSDSP=$P($G(^PSD(58.8,NAOUF,1,PSDRG,3,ORD,0)),"^",14) - S MFG=$P(Y(0),"^",13),LOT=$P(Y(0),"^",14),EXP=$P(Y(0),"^",15),PSDS=+$P(Y(0),"^",3) - S QTY=+$P(Y(0),"^",6) I $D(^PSD(58.81,+PSDA,4)),+$P(^(4),"^",3) S QTY=+$P(^(4),"^",3) - S RQTY=+$P($G(^PSD(58.81,PSDA,7)),"^",7) - S NAOU=+$P($G(^PSD(58.81,PSDA,7)),"^",3),NAOUN=$P($G(^PSD(58.8,NAOU,0)),"^") - S PAT=+$P($G(^PSD(58.81,PSDA,9)),U) - I STAT'=10 W !!,"This Green Sheet has a status of "_$S(STATN]"":STATN,1:"UNKNOWN")_".",!,"Please contact your Pharmacy Coordinator for assistance.",! G END - ;*64 - I RQTY=0 W !!,"Quantity of zero was transferred. Use menu option",!,"'Receive GS for PCA/Infusion Signed Out to Patient'",! G END - D CHK G:PSDOUT END N X,X1 D SIG^XUSESIG G:X1="" END - D ^PSDNTT1 -END K %,%DT,%H,%I,AOU,AOUN,D,DA,DIC,DIE,DIK,DINUM,DIR,DIROUT,DIRUT,DLAYGO,DR,DTOUT,DUOUT,EXP,FLAG,JJ,LOT,MFG - K NAOU,NAOUF,NAOUFN,NAOUN,NAOUT,NAOUTN,OK,ORD,PAT,PSDA,PSDOUT,PSDPN,PSDREC,PSDRG,PSDRGN,PSDRN,PSDS,PSDSP,PSDT,PSDUZ,PSDUZN,QTY,RECD,RECDT,RQTY,STAT,STATN,X,Y - K XMDUZ,XMSUB,XMTEXT,XMY,^TMP("PSDNTMSG",$J) - Q -CHK ;check transfer to naou - S PSDOUT=0 W !!,?5,"The Green Sheet # ",PSDPN," and quantity of ",RQTY - I AOU'=NAOU W " was being transferred",!,?10,"*** from ",NAOUFN,!,?10,"*** to ",NAOUN,".",!!,$C(7),?5,"You are transferring it from ",NAOUFN,!,?10,"*** to ",AOUN,"." - I AOU=NAOU W " is being transferred ",!,?10,"*** from ",NAOUFN,!,?10,"*** to ",NAOUN,"." - W ! K DA,DIR,DIRUT S DIR(0)="Y",DIR("A")="Do you wish to complete this transfer",DIR("B")="NO" - S DIR("?",1)="Answer 'YES' to complete this Green Sheet transfer,",DIR("?")="answer 'NO' or '^' to quit without completing the transfer." - D ^DIR K DIR I 'Y!($D(DIRUT)) S PSDOUT=1 W !!,"Receive Green Sheet # ",PSDPN," transfer into another NAOU not completed.",!! Q - Q +PSDNTT ;BIR/JPW-Transfer Green Sheet - Receive this NAOU ; 22 Jun 93 + ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97 + I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE) + S OK=$S($D(^XUSEC("PSJ RNURSE",DUZ)):1,$D(^XUSEC("PSD NURSE",DUZ)):1,1:0) + I 'OK W $C(7),!!,?9,"** Please contact your Coordinator for access to transfer",!,?12,"narcotic orders.",!!,"PSJ RNURSE or PSD NURSE security key required.",! K OK Q + I $P($G(^VA(200,DUZ,20)),U,4)']"" N XQH S XQH="PSD ESIG" D EN^XQH Q + W !!,"Receive a transferred Green Sheet into this NAOU" S PSDUZ=DUZ,PSDUZN=$P($G(^VA(200,PSDUZ,0)),"^") +ASKN ;ask transfer to naou + W ! K DA,DIC S DIC=58.8,DIC(0)="QEAZ",DIC("A")="Select Receive Transfer In NAOU: " + S DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$S('$D(^(""I"")):1,'^(""I""):1,+^(""I"")>DT:1,1:0),$P(^(0),""^"",2)=""N"",'$P(^(0),""^"",7)" + D ^DIC K DIC G:Y<0 END S AOU=+Y,AOUN=$P(Y,"^",2) +GS ;select green sheet # + W ! K DA,DIC S DIC("A")="Select the Green Sheet #: ",DIC=58.81,DIC(0)="QEASZ",D="D" + S DIC("S")="I $P(^(0),""^"",11)=10,'$P($G(^(7)),""^"",4),($P($G(^(7)),""^"",3)=AOU)!($P(^(0),""^"",18)=AOU)" + D IX^DIC K DIC G:Y<0 END S PSDA=+Y + S STAT=+$P(Y(0),"^",11),PSDPN=$P(Y(0),"^",17),STATN="" I STAT S STATN=$P($G(^PSD(58.82,STAT,0)),"^") + S ORD=+$P(Y(0),"^",20),PSDRG=+$P(Y(0),"^",5),PSDRGN=$P($G(^PSDRUG(PSDRG,0)),"^") + S NAOUF=+$P(Y(0),"^",18),NAOUFN=$P($G(^PSD(58.8,+NAOUF,0)),"^") + S PSDSP=$P($G(^PSD(58.8,NAOUF,1,PSDRG,3,ORD,0)),"^",14) + S MFG=$P(Y(0),"^",13),LOT=$P(Y(0),"^",14),EXP=$P(Y(0),"^",15),PSDS=+$P(Y(0),"^",3) + S QTY=+$P(Y(0),"^",6) I $D(^PSD(58.81,+PSDA,4)),+$P(^(4),"^",3) S QTY=+$P(^(4),"^",3) + S RQTY=+$P($G(^PSD(58.81,PSDA,7)),"^",7) + S NAOU=+$P($G(^PSD(58.81,PSDA,7)),"^",3),NAOUN=$P($G(^PSD(58.8,NAOU,0)),"^") + S PAT=+$P($G(^PSD(58.81,PSDA,9)),U) + I STAT'=10 W !!,"This Green Sheet has a status of "_$S(STATN]"":STATN,1:"UNKNOWN")_".",!,"Please contact your Pharmacy Coordinator for assistance.",! G END + D CHK G:PSDOUT END N X,X1 D SIG^XUSESIG G:X1="" END + D ^PSDNTT1 +END K %,%DT,%H,%I,AOU,AOUN,D,DA,DIC,DIE,DIK,DINUM,DIR,DIROUT,DIRUT,DLAYGO,DR,DTOUT,DUOUT,EXP,FLAG,JJ,LOT,MFG + K NAOU,NAOUF,NAOUFN,NAOUN,NAOUT,NAOUTN,OK,ORD,PAT,PSDA,PSDOUT,PSDPN,PSDREC,PSDRG,PSDRGN,PSDRN,PSDS,PSDSP,PSDT,PSDUZ,PSDUZN,QTY,RECD,RECDT,RQTY,STAT,STATN,X,Y + K XMDUZ,XMSUB,XMTEXT,XMY,^TMP("PSDNTMSG",$J) + Q +CHK ;check transfer to naou + S PSDOUT=0 W !!,?5,"The Green Sheet # ",PSDPN," and quantity of ",RQTY + I AOU'=NAOU W " was being transferred",!,?10,"*** from ",NAOUFN,!,?10,"*** to ",NAOUN,".",!!,$C(7),?5,"You are transferring it from ",NAOUFN,!,?10,"*** to ",AOUN,"." + I AOU=NAOU W " is being transferred ",!,?10,"*** from ",NAOUFN,!,?10,"*** to ",NAOUN,"." + W ! K DA,DIR,DIRUT S DIR(0)="Y",DIR("A")="Do you wish to complete this transfer",DIR("B")="NO" + S DIR("?",1)="Answer 'YES' to complete this Green Sheet transfer,",DIR("?")="answer 'NO' or '^' to quit without completing the transfer." + D ^DIR K DIR I 'Y!($D(DIRUT)) S PSDOUT=1 W !!,"Receive Green Sheet # ",PSDPN," transfer into another NAOU not completed.",!! Q + Q diff --git a/r/CONTROLLED_SUBSTANCES-PSD/PSDSITE.m b/r/CONTROLLED_SUBSTANCES-PSD/PSDSITE.m index c666bb57..3bb505a4 100644 --- a/r/CONTROLLED_SUBSTANCES-PSD/PSDSITE.m +++ b/r/CONTROLLED_SUBSTANCES-PSD/PSDSITE.m @@ -1,50 +1,50 @@ -PSDSITE ;BIR/JPW,LTL-Site Parameters for CS ; 3 May 95 - ;;3.0; CONTROLLED SUBSTANCES ;**65**;13 Feb 97;Build 5 -SITE ;entry for selecting inpatient sites in file 59.4 - K DIC,DLAYGO S DIC="^PS(59.4,",DLAYGO=59.4,DIC(0)="QEAL",D="B",DZ="??" - D DQ^DICQ K D,DZ W ! D ^DIC K DIC G:Y<0 END - K DA,DIE,DR S DIE=59.4,DA=+Y,DR="31"_"Is "_$P(Y,U,2)_" selectable for Controlled Subs" W ! D ^DIE K DIE -END K DA,DIC,DIE,DLAYGO,DR,DTOUT,DUOUT,X,Y - Q - ; -LOW ;if auto generate, check low range for numbers - I '$D(X) S PSDFLAG=1 Q - K PSD,PSDFLAG,PSDL F PSD=0:0 S PSD=$O(^PSD(58.8,PSD)) Q:'PSD I $D(^PSD(58.8,PSD,0)),$D(^(2)),$P(^(2),"^") D - .I +$P(^PSD(58.8,PSD,2),"^",2),+$P(^(2),"^",3) S PSDL(+PSD)="" - I $O(PSDL(0)) F PSD=0:0 S PSD=+$O(PSDL(PSD)) Q:'PSD D - .I X'<$P($G(^PSD(58.8,PSD,2)),"^",2),(X'>$P($G(^(2)),"^",3)),PSD'=DA D MSG S PSDFLAG=1 Q - W:$D(PSDFLAG) " Select another range.",! K PSD,PSDL - Q - ; -HIGH ;validates high range for dispensing numbers - I '$D(X) S PSDFLAG=1 Q - K PSD,PSDFLAG,PSDH,PSDL F PSD=0:0 S PSD=$O(^PSD(58.8,PSD)) Q:'PSD I $D(^PSD(58.8,PSD,0)),$D(^(2)),$P(^(2),"^") D - .I +$P(^PSD(58.8,PSD,2),"^",2) S PSDL(+$P(^(2),"^",2))=PSD - S PSDL=+$P($G(^PSD(58.8,DA,2)),"^",2),PSDH=+$O(PSDL(PSDL)) I PSDH S PSD=+$P(PSDL(PSDH),"^") - I X'>PSDL W !!,"High dispensing # must be larger than your low dispensing # "_PSDL_".",!! S PSDFLAG=1 Q - I PSDH,X' Dispensing Site "_$S($P(^PSD(58.8,PSD,0),"^")]"":$P(^(0),"^"),1:"NAME MISSING")_" <=",!,"has set aside the range "_$P($G(^PSD(58.8,PSD,2)),"^",2)_" through "_$P($G(^(2)),"^",3)_"." - Q - ; -LAST ;checks range for 'last dispensed' - I '$D(X) S PSDFLAG=1 Q - I $D(PSDEN) D LAST1 K LOW,HIGH,PSDCHK Q - I X<$P($G(^PSD(58.8,DA,2)),"^",2) D MSG1 S PSDFLAG=1 Q - I X>$P($G(^PSD(58.8,DA,2)),"^",3) D MSG1 S PSDFLAG=1 - Q - ; -MSG1 ;prints message if not in dispensing range - W $C(7),!!,"Last number dispensed must be within the range "_$P($G(^PSD(58.8,DA,2)),"^",2)_" to "_$S($P($G(^(2)),"^",3):$P($G(^(2)),"^",3),1:999999999)_".",! - Q -LAST1 ;checks LOW/HIGH range and LAST dispensed - I XHIGH D MSG2 S PSDFLAG=1 - Q -MSG2 ;prints msg if not in dispensing range - S PSDCHK=1 - W $C(7),!!,"Last number dispensed must be within the range ",LOW," to ",HIGH,".",! - Q +PSDSITE ;BIR/JPW,LTL-Site Parameters for CS ; 3 May 95 + ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97 +SITE ;entry for selecting inpatient sites in file 59.4 + K DIC,DLAYGO S (DIC,DLAYGO)="^PS(59.4,",DIC(0)="QEAL",D="B",DZ="??" + D DQ^DICQ K D,DZ W ! D ^DIC K DIC G:Y<0 END + K DA,DIE,DR S DIE=59.4,DA=+Y,DR="31"_"Is "_$P(Y,U,2)_" selectable for Controlled Subs" W ! D ^DIE K DIE +END K DA,DIC,DIE,DLAYGO,DR,DTOUT,DUOUT,X,Y + Q + ; +LOW ;if auto generate, check low range for numbers + I '$D(X) S PSDFLAG=1 Q + K PSD,PSDFLAG,PSDL F PSD=0:0 S PSD=$O(^PSD(58.8,PSD)) Q:'PSD I $D(^PSD(58.8,PSD,0)),$D(^(2)),$P(^(2),"^") D + .I +$P(^PSD(58.8,PSD,2),"^",2),+$P(^(2),"^",3) S PSDL(+PSD)="" + I $O(PSDL(0)) F PSD=0:0 S PSD=+$O(PSDL(PSD)) Q:'PSD D + .I X'<$P($G(^PSD(58.8,PSD,2)),"^",2),(X'>$P($G(^(2)),"^",3)),PSD'=DA D MSG S PSDFLAG=1 Q + W:$D(PSDFLAG) " Select another range.",! K PSD,PSDL + Q + ; +HIGH ;validates high range for dispensing numbers + I '$D(X) S PSDFLAG=1 Q + K PSD,PSDFLAG,PSDH,PSDL F PSD=0:0 S PSD=$O(^PSD(58.8,PSD)) Q:'PSD I $D(^PSD(58.8,PSD,0)),$D(^(2)),$P(^(2),"^") D + .I +$P(^PSD(58.8,PSD,2),"^",2) S PSDL(+$P(^(2),"^",2))=PSD + S PSDL=+$P($G(^PSD(58.8,DA,2)),"^",2),PSDH=+$O(PSDL(PSDL)) I PSDH S PSD=+$P(PSDL(PSDH),"^") + I X'>PSDL W !!,"High dispensing # must be larger than your low dispensing # "_PSDL_".",!! S PSDFLAG=1 Q + I PSDH,X' Dispensing Site "_$S($P(^PSD(58.8,PSD,0),"^")]"":$P(^(0),"^"),1:"NAME MISSING")_" <=",!,"has set aside the range "_$P($G(^PSD(58.8,PSD,2)),"^",2)_" through "_$P($G(^(2)),"^",3)_"." + Q + ; +LAST ;checks range for 'last dispensed' + I '$D(X) S PSDFLAG=1 Q + I $D(PSDEN) D LAST1 K LOW,HIGH,PSDCHK Q + I X<$P($G(^PSD(58.8,DA,2)),"^",2) D MSG1 S PSDFLAG=1 Q + I X>$P($G(^PSD(58.8,DA,2)),"^",3) D MSG1 S PSDFLAG=1 + Q + ; +MSG1 ;prints message if not in dispensing range + W $C(7),!!,"Last number dispensed must be within the range "_$P($G(^PSD(58.8,DA,2)),"^",2)_" to "_$S($P($G(^(2)),"^",3):$P($G(^(2)),"^",3),1:999999999)_".",! + Q +LAST1 ;checks LOW/HIGH range and LAST dispensed + I XHIGH D MSG2 S PSDFLAG=1 + Q +MSG2 ;prints msg if not in dispensing range + S PSDCHK=1 + W $C(7),!!,"Last number dispensed must be within the range ",LOW," to ",HIGH,".",! + Q diff --git a/r/DIETETICS-FH/FHASM1.m b/r/DIETETICS-FH/FHASM1.m index c7dd814c..ca50a6e2 100644 --- a/r/DIETETICS-FH/FHASM1.m +++ b/r/DIETETICS-FH/FHASM1.m @@ -1,179 +1,179 @@ -FHASM1 ; HISC/REL - Nutrition Assessment ;1/25/00 12:08 - ;;5.5;DIETETICS;**8,14**;Jan 28, 2005;Build 1 - W @IOF,!!?20,"N U T R I T I O N A S S E S S M E N T",!! S X="T",%DT="X" D ^%DT S DT=+Y -F1 ; Select Patient - S FHALL=1 D ^FHOMDPA G KILL^XUSCLEAN:'FHDFN - S:DFN'>0 DFN="" - I $G(DFN),$P($G(^DPT(DFN,.35)),"^",1) W *7,!!?5," [ Patient has expired. ]" G KILL^XUSCLEAN - S (ADM,ASN,FHASK,KNEE,EXT,DTP,FHCAS,FHCASD,FHASS,FHFFC,FHFEC,FHFPC,FHCFRBO,FHCM,FHEF,FHKCAL,FHLOC)="",(FHHWF,FHQUIT)=0 - S (ADT,SEX,AGE,HGT,HGP,WGT,WGP,DWGT,UWGT,IBW,FRM,AMP,KCAL,PRO,FLD,RC,XD,BMI,BMIP,FHCLI,FHPLXSV)="" - S (NOW,NB,TSF,TSFP,SCA,SCAP,ACIR,ACIRP,CCIR,CCIRP,BFAMA,BFAMAP,FHAPP,FHEDU,DEWGT,WARD,FHSPC)="" - S (FHDIPL,FHDIPLD,FHAST,FHDINF,FHDINFD,FHFUD,FHDIST,FHDIDI,FHDITF,FHDIDI,FHDITF,FHDITFDT,FHDITFCM,FHDITFML,FHDITFKC,FHVHGT,FHDVHGT)="" - S (TSF,TSFP,SCA,SCAP,ACIR,ACIRP,CCIR,CCIRP,BFAMA,BFAMAP,BMI,BMIP,X1,X2,FHFUDS,EKKG,FHFDC,FHFDCSV)="" - S (WCCM,CIBW,CERBO,CENB,PCTB,SEF,CFRB,CFRBO,CPRBO,NWGT,DNWGT,FHYN,FHDINA,FHVWGT,FHDVWGT,FHPL)="" - S FHCLI=DUZ - K ^TMP("FH",$J) S FHQTALL=0 - ;get current diet and tf - S Y="" - I DFN D - .F I=0:0 S I=$O(^FHPT("AW",I)) Q:I'>0 I $D(^FHPT("AW",I,FHDFN)) S FHLOC=I Q - .I $G(FHLOC),$D(^FH(119.6,FHLOC,0)) S FHCLI=$P($G(^FH(119.6,FHLOC,0)),U,2) - .S WARD=$G(^DPT(DFN,.1)) I WARD'="" S ADM=$G(^DPT("CN",WARD,DFN)) - .I ADM D CUR^FHORD7 S X1="" - .S FHDIDI=$S(Y'="":Y,1:"No Order") - .W !,"Current Diet: ",FHDIDI - .Q:'ADM - .S TF=$P(^FHPT(FHDFN,"A",ADM,0),"^",4) - .Q:'TF - .S FHDITFDT=$P($G(^FHPT(FHDFN,"A",ADM,"TF",TF,0)),U,1) - .S FHDITFCM=$P($G(^FHPT(FHDFN,"A",ADM,"TF",TF,0)),U,5) - .S FHDITFML=$P($G(^FHPT(FHDFN,"A",ADM,"TF",TF,0)),U,6) - .S FHDITFKC=$P($G(^FHPT(FHDFN,"A",ADM,"TF",TF,0)),U,7) - .F TF2=0:0 S TF2=$O(^FHPT(FHDFN,"A",ADM,"TF",TF,"P",TF2)) Q:TF2<1 D - ..S Y=^(TF2,0),TUN=$P(Y,"^",1) - ..I TUN,$D(^FH(118.2,TUN,0)) S FHDITFPR(TUN)=Y - .W ?30,"Tubefeeding: " I $D(FHDITFPR) F FHTUN=0:0 S FHTUN=$O(FHDITFPR(FHTUN)) Q:FHTUN'>0 W $P($G(^FH(118.2,FHTUN,0)),"^",1) I $O(FHDITFPR(FHTUN))'="" W ", " - K Y -STA ;if pt has Work in Progress assessment, ask user to Edit or Create or Delete Assessment. - D PATNAME^FHOMUTL - S AGE=FHAGE - I $D(^FHPT(FHDFN,"N",0)) D - .S FHCAS=$P(^FHPT(FHDFN,"N",0),U,3) - .Q:'FHCAS - .S FHCASD=$P(^FHPT(FHDFN,"N",FHCAS,0),U,1) - .I $D(^FHPT(FHDFN,"N",FHCAS,"DI")) S FHASS=$P($G(^FHPT(FHDFN,"N",FHCAS,"DI")),U,6) - .S FHAST=0 - .F FHA=0:0 S FHA=$O(^FHPT(FHDFN,"N",FHA)) Q:'FHA D - ..S FHASSD=$P($G(^FHPT(FHDFN,"N",FHA,"DI")),U,6) - ..I (FHASSD="W")!(FHASS="") S FHAST=1 - ..I $D(^FHPT(FHDFN,"N",FHA,0)),'$D(^FHPT(FHDFN,"N",FHA,"DI")) S FHAST=1 - I 'FHCAS!(FHAST=0) G CRE - D ASK^FHASM2 G:FHQUIT KILL^XUSCLEAN - I FHASK="D" S DIK="^FHPT("_FHDFN_",""N"",",DA(1)=FHDFN,DA=FHCAS D ^DIK W ?65,"Deleted..." G F1 - I FHASK="E" S ADT=FHCAS D SVAR G:SEX=""!(AGE="") P1 G F3A -CRE ;create new assessment - ;D:FHCAS PRTA^FHASM2 - S FHASK="C" - W !!,"Creating new Assessment...",! - I (FHSEX="")!(FHAGE="") G P1 - E S NAM=FHPTNM,SEX=FHSEX,AGE=FHAGE - S X="NOW",%DT="XT" D ^%DT S ADT=Y - I SEX=""!(AGE="") G P1 -F2 S X="NOW",%DT="XT" D ^%DT S ADT=Y -F3 I DFN,$D(^FHPT(FHDFN,"N",9999999-ADT)) S ADT=$$FMADD^XLFDT(ADT,,,1) G F3 -F3A ;start here if edit - S FHAP=$G(^FH(119.9,1,3)),FHU=$P(FHAP,"^",1),NAM=FHPTNM - G:'FHDFN F4 S XX=$O(^FHPT(FHDFN,"N",0)) G:XX="" F4 S XX=$G(^(XX,0)),HGT=$P(XX,"^",4),HGP=$P(XX,"^",5) - I HGP'="S" S X1=$S(HGT\12:HGT\12_"'",1:"")_$S(HGT#12:" "_(HGT#12)_"""",1:""),X2=+$J(HGT*2.54,0,0)_"CM",X1=$S(FHU'="M":X1,1:X2) -F4 ; If Multidivisional site Select Communications Office - S FHCOMM="" I $P($G(^FH(119.9,1,0)),U,20)'="N" D I FHCOMM="" Q - .K DIC S DIC="^FH(119.73," S DIC(0)="AEMQ" D ^DIC - .I Y=-1 Q - .S FHCOMM=+Y - ;get ht and wt from vitals. - I DFN S GMRVSTR="WT" D EN6^GMRVUTL S FHDVWGT=$P(X,"^",1),FHVWGT=$P(X,"^",8),GMRVSTR="HT" D EN6^GMRVUTL S FHVHGT=$P(X,"^",8) - I X1="" S (X1,HGT)=FHVHGT -F4A W !!,"Height: " W:X1'="" X1,"// " R X:DTIME G:'$T!(X["^") KIL I X="",X1'="" S Y0=$J(HGT,0,0),H1=Y0 G F5 - D TR,HGT I Y<1 D HGP G F4A - S:X1'=Y FHHWF=1 - S HGT=Y,H1=Y0,HGP=Y1 -F5 I FHVWGT'="" S WGT=FHVWGT - W !!,"Weight: " W:WGT'="" WGT_" lbs","// " R X:DTIME G:'$T!(X["^") KIL I X="",WGT S X=WGT_"#" - S:X="a" X="A" - I X="A",AGE>39 D A^FHASM2D G:Y<1 F5 S:WGT'=Y FHHWF=1 S WGT=Y,WGP="A" G F6 - D WGT I Y<1 D WGP W:AGE>39 !,"You may enter an A to calculate weight anthropometrically." G F5 - S:WGT'=Y FHHWF=1 - S WGT=Y,WGP=Y1 I FHDVWGT'="" S DWGT=$P(FHDVWGT,".",1) -F6 G:'FHHWF F7 - S %DT="AEP",%DT("A")="Date Weight Taken: " - I 'DWGT,FHDVWGT S DTP=$E(FHDVWGT,4,5)_"/"_$E(FHDVWGT,6,7)_"/"_$E(FHDVWGT,2,3) - I DWGT S DTP=$E(DWGT,4,5)_"/"_$E(DWGT,6,7)_"/"_$E(DWGT,2,3) - S:DTP'="" %DT("B")=DTP S:DTP="" %DT("B")="TODAY" - S %DT(0)="-T" W ! D ^%DT K %DT G KIL:X["^"!$D(DTOUT),F6:Y<1 - S DWGT=Y - ; -F7 S:UWGT X=UWGT W !!,"Usual Weight: " W:UWGT'="" UWGT_" lbs","// " R X:DTIME G:'$T!(X["^") KIL I X="" G F8 - D WGT I Y<1 D WGP G F7 - S UWGT=Y -F8 K %DT,A1,K,X,Y G ^FHASM2 -HGT ; Convert Height to inches - S A1=+X I 'A1 S Y=-1 Q - S X=$P(X,A1,2,99) S:$E(X,1)=" " X=$E(X,2,99) I "SMK"[$E(X,1) S Y=A1 S:FHU="M" Y=Y/2.54 G H1 - I """I"[$E(X,1) S Y=A1 G H1 - I $E(X,1)="C" S Y=A1/2.54 G H1 - I "'F"'[$E(X,1) S Y=-1 G H2 - S Y=A1*12 F K=1:1 Q:$E(X,K)?.N - I $E(X,K,99)="" G H1 - S A1=+$E(X,K,99),X=$P(X,A1,2,99) S:$E(X,1)=" " X=$E(X,2,99) - I """I"'[$E(X,1) S Y=-1 G H2 - S Y=Y+A1 -H1 I X["K" D K^FHASM2D -H2 I Y<12!(Y>96) S Y=-1 - S:Y>0 Y0=+$J(Y,0,0),Y=+$J(Y,0,1) S Y1=$S(X["K":"K",X["S":"S",1:"") Q -HGP ; Height Help - W !!,"Enter height as: 6' 2"" or 74"" or 74IN or 6FT 2 IN or 30CM" - W !,"Add an S if height is stated rather than measured." - W !,"Add a K if value is a Knee Height measurement." - W !,"Height should be between 12"" and 96"" (8')." Q -WGT ; Convert Weight to lbs. - D TR S A1=+X I 'A1 S Y=-1 Q - S X=$P(X,A1,2,99) S:$E(X,1)=" " X=$E(X,2,99) I "SM"[$E(X,1) S Y=A1 S:FHU="M" Y=Y*2.2 G W1 - I $E(X,1)="O" S Y=A1/16 G W1 - I $E(X,1)="G" S Y=A1/1000*2.2 G W1 - I $E(X,1)="K" S Y=A1*2.2 G W1 - I "L#"'[$E(X,1) S Y=-1 G W1 - S Y=A1 F K=1:1 Q:$E(X,K)?.N - I $E(X,K,99)="" G W1 - S A1=+$E(X,K,99),X=$P(X,A1,2,99) S:$E(X,1)=" " X=$E(X,2,99) - I $E(X,1)'="O" S Y=-1 G W1 - S Y=A1/16+Y -W1 I Y<0!(Y>750) S Y=-1 - S:Y>0 Y0=+$J(Y,0,0),Y=+$J(Y,0,1) S Y1="" S:X["S" Y1="S" Q -WGP ; Weight help - W !!,"Enter Weight as 150# or 150# 6OZ or 800G or 70KG" - W !,"Add an S if weight is stated rather than measured." - W !,"Enter an A to determine weight anthropometrically." - W !,"Weight should be between 0 Lbs and 750 Lbs." Q -TR ; Translate Lower to Upper Case - D TR^FH - Q -KIL ; Final variable kill - ;if X not equal ^, update or create nutrition assessment - G:$G(FHQUIT) ASKUS - I $D(X),X=U G ASKUS - D SDAT^FHASM7 - ; - G KILL^XUSCLEAN -PAT S (FHDFN,DFN,SEX,AGE,PID)="" R !!,"Enter Patient's Name: ",NAM:DTIME G:'$T!(NAM["^") KILL^XUSCLEAN - I NAM["?"!(NAM'?.ANP)!(NAM="") W *7,!?5,"Enter Patient's Name to be printed on the report." G PAT -P1 I SEX="" R !,"Sex: ",SEX:DTIME S:SEX="" SEX="?" G:'$T!(SEX["^") KILL^XUSCLEAN S X=SEX D TR S SEX=X I $P("FEMALE",SEX,1)'="",$P("MALE",SEX,1)'="" W *7," Enter M or F" S SEX="" G P1 - S SEX=$E(SEX,1) -P2 I AGE="" R !,"Age: ",AGE:DTIME S:AGE="" AGE="?" G:'$T!(AGE["^") KILL^XUSCLEAN S X=AGE D TR S AGE=X - S:AGE["M" AGE=+$J($P(AGE,"M",1)/12,0,2) I AGE'>0!(AGE>124) W !?5,"Enter Age Less Than 124 in Years or Months (followed by M) but Not Both" S AGE="" G P2 - G F2 -SVAR ;set variables of incomplete assessment. - Q:'$D(^FHPT(FHDFN,"N",0)) - S FHA0=$G(^FHPT(FHDFN,"N",FHCAS,0)) - S ADT=$P(FHA0,U,1),SEX=$P(FHA0,U,2),AGE=$P(FHA0,U,3),HGT=$P(FHA0,U,4) - S HGP=$P(FHA0,U,5),WGT=$P(FHA0,U,6),WGP=$P(FHA0,U,7),DWGT=$P(FHA0,U,8) - S UWGT=$P(FHA0,U,9),IBW=$P(FHA0,U,10),FRM=$P(FHA0,U,11),AMP=$P(FHA0,U,12) - S KCAL=$P(FHA0,U,16),PRO=$P(FHA0,U,17),FLD=$P(FHA0,U,18),RC=$P(FHA0,U,19) - S XD=$P(FHA0,U,20),BMI=$P(FHA0,U,21),BMIP=$P(FHA0,U,22) - S NOW=$P(FHA0,U,24),NB=$P(FHA0,U,25) - S FHA1=$G(^FHPT(FHDFN,"N",FHCAS,1)) - S TSF=$P(FHA1,U,1),TSFP=$P(FHA1,U,2),SCA=$P(FHA1,U,3),SCAP=$P(FHA1,U,4),ACIR=$P(FHA1,U,5) - S ACIRP=$P(FHA1,U,6),CCIR=$P(FHA1,U,7),CCIRP=$P(FHA1,U,8),BFAMA=$P(FHA1,U,9),BFAMAP=$P(FHA1,U,10) - S WCCM=$P(FHA1,U,11),CIBW=$P(FHA1,U,12),CERBO=$P(FHA1,U,13),CENB=$P(FHA1,U,14),PCTB=$P(FHA1,U,15) - S SEF=$P(FHA1,U,16),CFRB=$P(FHA1,U,17),CFRBO=$P(FHA1,U,18),CPRBO=$P(FHA1,U,19),EKKG=$P(FHA1,U,20) - S FHAPP=$G(^FHPT(FHDFN,"N",FHCAS,2)) - S FHA3=$G(^FHPT(FHDFN,"N",FHCAS,3)) - S FHYN=$P(FHA3,U,1),FHFEC=$P(FHA3,U,2),FHFPC=$P(FHA3,U,3),FHDINA=$P(FHA3,U,4),FHEDU=$P(FHA3,U,5) - S FHFDCSV=$P(FHA3,U,6),FHPL=$P(FHA3,U,7),FHSPC=$P(FHA3,U,8) - S FHADI=$G(^FHPT(FHDFN,"N",FHCAS,"DI")) - S FHDIPL=$P(FHADI,U,1),FHDIPLD=$P(FHADI,U,2),FHDINF=$P(FHADI,U,3),FHDINFD=$P(FHADI,U,4) - S (FHFUD,FHFUDS)=$P(FHADI,U,5),FHDIST=$P(FHADI,U,6),FHDIDI=$P(FHADI,U,7),FHDITF=$P(FHADI,U,8) - Q -ASKUS R !!,"Do you wish to SAVE this Assessment Y// ",X:DTIME G:'$T!(X["^") KILL^XUSCLEAN - S:X="" X="Y" D TR I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7,!," Answer YES or NO" G ASKUS - I X'?1"Y".E G KILL^XUSCLEAN - D SDAT^FHASM7 G KILL^XUSCLEAN +FHASM1 ; HISC/REL - Nutrition Assessment ;1/25/00 12:08 + ;;5.5;DIETETICS;**8**;Jan 28, 2005;Build 28 + W @IOF,!!?20,"N U T R I T I O N A S S E S S M E N T",!! S X="T",%DT="X" D ^%DT S DT=+Y +F1 ; Select Patient + S FHALL=1 D ^FHOMDPA G KILL^XUSCLEAN:'FHDFN + S:DFN'>0 DFN="" + I $G(DFN),$P($G(^DPT(DFN,.35)),"^",1) W *7,!!?5," [ Patient has expired. ]" G KILL^XUSCLEAN + S (ADM,ASN,FHASK,KNEE,EXT,DTP,FHCAS,FHCASD,FHASS,FHFFC,FHFEC,FHFPC,FHCFRBO,FHCM,FHEF,FHKCAL,FHLOC)="",(FHHWF,FHQUIT)=0 + S (ADT,SEX,AGE,HGT,HGP,WGT,WGP,DWGT,UWGT,IBW,FRM,AMP,KCAL,PRO,FLD,RC,XD,BMI,BMIP,FHCLI,FHPLXSV)="" + S (NOW,NB,TSF,TSFP,SCA,SCAP,ACIR,ACIRP,CCIR,CCIRP,BFAMA,BFAMAP,FHAPP,FHEDU,DEWGT,WARD,FHSPC)="" + S (FHDIPL,FHDIPLD,FHAST,FHDINF,FHDINFD,FHFUD,FHDIST,FHDIDI,FHDITF,FHDIDI,FHDITF,FHDITFDT,FHDITFCM,FHDITFML,FHDITFKC,FHVHGT,FHDVHGT)="" + S (TSF,TSFP,SCA,SCAP,ACIR,ACIRP,CCIR,CCIRP,BFAMA,BFAMAP,BMI,BMIP,X1,X2,FHFUDS,EKKG,FHFDC,FHFDCSV)="" + S (WCCM,CIBW,CERBO,CENB,PCTB,SEF,CFRB,CFRBO,CPRBO,NWGT,DNWGT,FHYN,FHDINA,FHVWGT,FHDVWGT,FHPL)="" + S FHCLI=DUZ + K ^TMP("FH",$J) S FHQTALL=0 + ;get current diet and tf + S Y="" + I DFN D + .F I=0:0 S I=$O(^FHPT("AW",I)) Q:I'>0 I $D(^FHPT("AW",I,FHDFN)) S FHLOC=I Q + .I $G(FHLOC),$D(^FH(119.6,FHLOC,0)) S FHCLI=$P($G(^FH(119.6,FHLOC,0)),U,2) + .S WARD=$G(^DPT(DFN,.1)) I WARD'="" S ADM=$G(^DPT("CN",WARD,DFN)) + .D:ADM CUR^FHORD7 + .S FHDIDI=$S(Y'="":Y,1:"No Order") + .W !,"Current Diet: ",FHDIDI + .Q:'ADM + .S TF=$P(^FHPT(FHDFN,"A",ADM,0),"^",4) + .Q:'TF + .S FHDITFDT=$P($G(^FHPT(FHDFN,"A",ADM,"TF",TF,0)),U,1) + .S FHDITFCM=$P($G(^FHPT(FHDFN,"A",ADM,"TF",TF,0)),U,5) + .S FHDITFML=$P($G(^FHPT(FHDFN,"A",ADM,"TF",TF,0)),U,6) + .S FHDITFKC=$P($G(^FHPT(FHDFN,"A",ADM,"TF",TF,0)),U,7) + .F TF2=0:0 S TF2=$O(^FHPT(FHDFN,"A",ADM,"TF",TF,"P",TF2)) Q:TF2<1 D + ..S Y=^(TF2,0),TUN=$P(Y,"^",1) + ..I TUN,$D(^FH(118.2,TUN,0)) S FHDITFPR(TUN)=Y + .W ?30,"Tubefeeding: " I $D(FHDITFPR) F FHTUN=0:0 S FHTUN=$O(FHDITFPR(FHTUN)) Q:FHTUN'>0 W $P($G(^FH(118.2,FHTUN,0)),"^",1) I $O(FHDITFPR(FHTUN))'="" W ", " + K Y +STA ;if pt has Work in Progress assessment, ask user to Edit or Create or Delete Assessment. + D PATNAME^FHOMUTL + S AGE=FHAGE + I $D(^FHPT(FHDFN,"N",0)) D + .S FHCAS=$P(^FHPT(FHDFN,"N",0),U,3) + .Q:'FHCAS + .S FHCASD=$P(^FHPT(FHDFN,"N",FHCAS,0),U,1) + .I $D(^FHPT(FHDFN,"N",FHCAS,"DI")) S FHASS=$P($G(^FHPT(FHDFN,"N",FHCAS,"DI")),U,6) + .S FHAST=0 + .F FHA=0:0 S FHA=$O(^FHPT(FHDFN,"N",FHA)) Q:'FHA D + ..S FHASSD=$P($G(^FHPT(FHDFN,"N",FHA,"DI")),U,6) + ..I (FHASSD="W")!(FHASS="") S FHAST=1 + ..I $D(^FHPT(FHDFN,"N",FHA,0)),'$D(^FHPT(FHDFN,"N",FHA,"DI")) S FHAST=1 + I 'FHCAS!(FHAST=0) G CRE + D ASK^FHASM2 G:FHQUIT KILL^XUSCLEAN + I FHASK="D" S DIK="^FHPT("_FHDFN_",""N"",",DA(1)=FHDFN,DA=FHCAS D ^DIK W ?65,"Deleted..." G F1 + I FHASK="E" S ADT=FHCAS D SVAR G:SEX=""!(AGE="") P1 G F3A +CRE ;create new assessment + ;D:FHCAS PRTA^FHASM2 + S FHASK="C" + W !!,"Creating new Assessment...",! + I (FHSEX="")!(FHAGE="") G P1 + E S NAM=FHPTNM,SEX=FHSEX,AGE=FHAGE + S X="NOW",%DT="XT" D ^%DT S ADT=Y + I SEX=""!(AGE="") G P1 +F2 S X="NOW",%DT="XT" D ^%DT S ADT=Y +F3 I DFN,$D(^FHPT(FHDFN,"N",9999999-ADT)) S ADT=$$FMADD^XLFDT(ADT,,,1) G F3 +F3A ;start here if edit + S FHAP=$G(^FH(119.9,1,3)),FHU=$P(FHAP,"^",1),NAM=FHPTNM + G:'FHDFN F4 S XX=$O(^FHPT(FHDFN,"N",0)) G:XX="" F4 S XX=$G(^(XX,0)),HGT=$P(XX,"^",4),HGP=$P(XX,"^",5) + I HGP'="S" S X1=$S(HGT\12:HGT\12_"'",1:"")_$S(HGT#12:" "_(HGT#12)_"""",1:""),X2=+$J(HGT*2.54,0,0)_"CM",X1=$S(FHU'="M":X1,1:X2) +F4 ; If Multidivisional site Select Communications Office + S FHCOMM="" I $P($G(^FH(119.9,1,0)),U,20)'="N" D I FHCOMM="" Q + .K DIC S DIC="^FH(119.73," S DIC(0)="AEMQ" D ^DIC + .I Y=-1 Q + .S FHCOMM=+Y + ;get ht and wt from vitals. + I DFN S GMRVSTR="WT" D EN6^GMRVUTL S FHDVWGT=$P(X,"^",1),FHVWGT=$P(X,"^",8),GMRVSTR="HT" D EN6^GMRVUTL S FHVHGT=$P(X,"^",8) + I X1="" S (X1,HGT)=FHVHGT +F4A W !!,"Height: " W:X1'="" X1,"// " R X:DTIME G:'$T!(X["^") KIL I X="",X1'="" S Y0=$J(HGT,0,0),H1=Y0 G F5 + D TR,HGT I Y<1 D HGP G F4A + S:X1'=Y FHHWF=1 + S HGT=Y,H1=Y0,HGP=Y1 +F5 I FHVWGT'="" S WGT=FHVWGT + W !!,"Weight: " W:WGT'="" WGT_" lbs","// " R X:DTIME G:'$T!(X["^") KIL I X="",WGT S X=WGT_"#" + S:X="a" X="A" + I X="A",AGE>39 D A^FHASM2D G:Y<1 F5 S:WGT'=Y FHHWF=1 S WGT=Y,WGP="A" G F6 + D WGT I Y<1 D WGP W:AGE>39 !,"You may enter an A to calculate weight anthropometrically." G F5 + S:WGT'=Y FHHWF=1 + S WGT=Y,WGP=Y1,DWGT=$P(FHDVWGT,".",1) +F6 G:'FHHWF F7 + S %DT="AEP",%DT("A")="Date Weight Taken: " + I 'DWGT,FHDVWGT S DTP=$E(FHDVWGT,4,5)_"/"_$E(FHDVWGT,6,7)_"/"_$E(FHDVWGT,2,3) + I DWGT S DTP=$E(DWGT,4,5)_"/"_$E(DWGT,6,7)_"/"_$E(DWGT,2,3) + S:DTP'="" %DT("B")=DTP S:DTP="" %DT("B")="TODAY" + S %DT(0)="-T" W ! D ^%DT K %DT G KIL:X["^"!$D(DTOUT),F6:Y<1 + S DWGT=Y + ; +F7 S:UWGT X=UWGT W !!,"Usual Weight: " W:UWGT'="" UWGT_" lbs","// " R X:DTIME G:'$T!(X["^") KIL I X="" G F8 + D WGT I Y<1 D WGP G F7 + S UWGT=Y +F8 K %DT,A1,K,X,Y G ^FHASM2 +HGT ; Convert Height to inches + S A1=+X I 'A1 S Y=-1 Q + S X=$P(X,A1,2,99) S:$E(X,1)=" " X=$E(X,2,99) I "SMK"[$E(X,1) S Y=A1 S:FHU="M" Y=Y/2.54 G H1 + I """I"[$E(X,1) S Y=A1 G H1 + I $E(X,1)="C" S Y=A1/2.54 G H1 + I "'F"'[$E(X,1) S Y=-1 G H2 + S Y=A1*12 F K=1:1 Q:$E(X,K)?.N + I $E(X,K,99)="" G H1 + S A1=+$E(X,K,99),X=$P(X,A1,2,99) S:$E(X,1)=" " X=$E(X,2,99) + I """I"'[$E(X,1) S Y=-1 G H2 + S Y=Y+A1 +H1 I X["K" D K^FHASM2D +H2 I Y<12!(Y>96) S Y=-1 + S:Y>0 Y0=+$J(Y,0,0),Y=+$J(Y,0,1) S Y1=$S(X["K":"K",X["S":"S",1:"") Q +HGP ; Height Help + W !!,"Enter height as: 6' 2"" or 74"" or 74IN or 6FT 2 IN or 30CM" + W !,"Add an S if height is stated rather than measured." + W !,"Add a K if value is a Knee Height measurement." + W !,"Height should be between 12"" and 96"" (8')." Q +WGT ; Convert Weight to lbs. + D TR S A1=+X I 'A1 S Y=-1 Q + S X=$P(X,A1,2,99) S:$E(X,1)=" " X=$E(X,2,99) I "SM"[$E(X,1) S Y=A1 S:FHU="M" Y=Y*2.2 G W1 + I $E(X,1)="O" S Y=A1/16 G W1 + I $E(X,1)="G" S Y=A1/1000*2.2 G W1 + I $E(X,1)="K" S Y=A1*2.2 G W1 + I "L#"'[$E(X,1) S Y=-1 G W1 + S Y=A1 F K=1:1 Q:$E(X,K)?.N + I $E(X,K,99)="" G W1 + S A1=+$E(X,K,99),X=$P(X,A1,2,99) S:$E(X,1)=" " X=$E(X,2,99) + I $E(X,1)'="O" S Y=-1 G W1 + S Y=A1/16+Y +W1 I Y<0!(Y>750) S Y=-1 + S:Y>0 Y0=+$J(Y,0,0),Y=+$J(Y,0,1) S Y1="" S:X["S" Y1="S" Q +WGP ; Weight help + W !!,"Enter Weight as 150# or 150# 6OZ or 800G or 70KG" + W !,"Add an S if weight is stated rather than measured." + W !,"Enter an A to determine weight anthropometrically." + W !,"Weight should be between 0 Lbs and 750 Lbs." Q +TR ; Translate Lower to Upper Case + D TR^FH + Q +KIL ; Final variable kill + ;if X not equal ^, update or create nutrition assessment + G:$G(FHQUIT) ASKUS + I $D(X),X=U G ASKUS + D SDAT^FHASM7 + ; + G KILL^XUSCLEAN +PAT S (FHDFN,DFN,SEX,AGE,PID)="" R !!,"Enter Patient's Name: ",NAM:DTIME G:'$T!(NAM["^") KILL^XUSCLEAN + I NAM["?"!(NAM'?.ANP)!(NAM="") W *7,!?5,"Enter Patient's Name to be printed on the report." G PAT +P1 I SEX="" R !,"Sex: ",SEX:DTIME S:SEX="" SEX="?" G:'$T!(SEX["^") KILL^XUSCLEAN S X=SEX D TR S SEX=X I $P("FEMALE",SEX,1)'="",$P("MALE",SEX,1)'="" W *7," Enter M or F" S SEX="" G P1 + S SEX=$E(SEX,1) +P2 I AGE="" R !,"Age: ",AGE:DTIME S:AGE="" AGE="?" G:'$T!(AGE["^") KILL^XUSCLEAN S X=AGE D TR S AGE=X + S:AGE["M" AGE=+$J($P(AGE,"M",1)/12,0,2) I AGE'>0!(AGE>124) W !?5,"Enter Age Less Than 124 in Years or Months (followed by M) but Not Both" S AGE="" G P2 + G F2 +SVAR ;set variables of incomplete assessment. + Q:'$D(^FHPT(FHDFN,"N",0)) + S FHA0=$G(^FHPT(FHDFN,"N",FHCAS,0)) + S ADT=$P(FHA0,U,1),SEX=$P(FHA0,U,2),AGE=$P(FHA0,U,3),HGT=$P(FHA0,U,4) + S HGP=$P(FHA0,U,5),WGT=$P(FHA0,U,6),WGP=$P(FHA0,U,7),DWGT=$P(FHA0,U,8) + S UWGT=$P(FHA0,U,9),IBW=$P(FHA0,U,10),FRM=$P(FHA0,U,11),AMP=$P(FHA0,U,12) + S KCAL=$P(FHA0,U,16),PRO=$P(FHA0,U,17),FLD=$P(FHA0,U,18),RC=$P(FHA0,U,19) + S XD=$P(FHA0,U,20),BMI=$P(FHA0,U,21),BMIP=$P(FHA0,U,22) + S NOW=$P(FHA0,U,24),NB=$P(FHA0,U,25) + S FHA1=$G(^FHPT(FHDFN,"N",FHCAS,1)) + S TSF=$P(FHA1,U,1),TSFP=$P(FHA1,U,2),SCA=$P(FHA1,U,3),SCAP=$P(FHA1,U,4),ACIR=$P(FHA1,U,5) + S ACIRP=$P(FHA1,U,6),CCIR=$P(FHA1,U,7),CCIRP=$P(FHA1,U,8),BFAMA=$P(FHA1,U,9),BFAMAP=$P(FHA1,U,10) + S WCCM=$P(FHA1,U,11),CIBW=$P(FHA1,U,12),CERBO=$P(FHA1,U,13),CENB=$P(FHA1,U,14),PCTB=$P(FHA1,U,15) + S SEF=$P(FHA1,U,16),CFRB=$P(FHA1,U,17),CFRBO=$P(FHA1,U,18),CPRBO=$P(FHA1,U,19),EKKG=$P(FHA1,U,20) + S FHAPP=$G(^FHPT(FHDFN,"N",FHCAS,2)) + S FHA3=$G(^FHPT(FHDFN,"N",FHCAS,3)) + S FHYN=$P(FHA3,U,1),FHFEC=$P(FHA3,U,2),FHFPC=$P(FHA3,U,3),FHDINA=$P(FHA3,U,4),FHEDU=$P(FHA3,U,5) + S FHFDCSV=$P(FHA3,U,6),FHPL=$P(FHA3,U,7),FHSPC=$P(FHA3,U,8) + S FHADI=$G(^FHPT(FHDFN,"N",FHCAS,"DI")) + S FHDIPL=$P(FHADI,U,1),FHDIPLD=$P(FHADI,U,2),FHDINF=$P(FHADI,U,3),FHDINFD=$P(FHADI,U,4) + S (FHFUD,FHFUDS)=$P(FHADI,U,5),FHDIST=$P(FHADI,U,6),FHDIDI=$P(FHADI,U,7),FHDITF=$P(FHADI,U,8) + Q +ASKUS R !!,"Do you wish to SAVE this Assessment Y// ",X:DTIME G:'$T!(X["^") KILL^XUSCLEAN + S:X="" X="Y" D TR I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7,!," Answer YES or NO" G ASKUS + I X'?1"Y".E G KILL^XUSCLEAN + D SDAT^FHASM7 G KILL^XUSCLEAN diff --git a/r/DIETETICS-FH/FHASM3.m b/r/DIETETICS-FH/FHASM3.m index 25905750..4f0e0a36 100644 --- a/r/DIETETICS-FH/FHASM3.m +++ b/r/DIETETICS-FH/FHASM3.m @@ -1,97 +1,96 @@ -FHASM3 ; HISC/REL - Antropometrics and TIU Notes ;5/14/93 09:17 - ;;5.5;DIETETICS;**8,14**;Jan 28, 2005;Build 1 - I EXT="Y" G NEXT -EXT R !!,"Do you wish Anthropometric Assessment? NO// ",EXT:DTIME S:EXT=U FHQUIT=1 G:'$T!(EXT["^") KIL^FHASM1 - S:EXT="" EXT="N" - S X=EXT D TR^FHASM1 S EXT=X - I $P("YES",EXT,1)'="",$P("NO",EXT,1)'="" W *7,!," Enter YES if you have Anthropometric measurements; Otherwise NO" G EXT - S EXT=$E(EXT,1) I EXT="Y" D ANT G:EXT="" KIL^FHASM1 -NEXT ; Calculate BMI - S A2=HGT*.0254,BMI=+$J(WGT/2.2/(A2*A2),0,1) - ;update nutrition assessment data in #115. - ; - ; - D ^FHASM3A G ^FHASM4 -ANT ; Anthropometric measurements - W !!,"Triceps Skin Fold (mm): " W:$D(TSF) TSF_"// " R X:DTIME G QT:'$T!(X["^") - S:X'="" TSF=X - S:TSF="" TSF=X - G A1:TSF="" - I TSF'?.N.1".".N!(TSF<1)!(TSF>100) W !?5,"Enter value between 1 and 100; outside values should be assessed manually" G ANT -A1 W !,"Subscapular Skinfold (mm): " W:$D(SCA) SCA_"// " R X:DTIME G QT:'$T!(X["^") - S:X'="" SCA=X - S:SCA="" SCA=X - G A2:SCA="" - I SCA'?.N.1".".N!(SCA<1)!(SCA>100) W !?5,"Enter value between 1 and 100; outside values should be assessed manually" G A1 -A2 W !,"Arm Circumference (cm): " W:$G(ACIR) ACIR_"// " R X:DTIME G QT:'$T!(X["^") - S:X'="" ACIR=X - S:SCA="" ACIR=X - G A3:ACIR="" - I ACIR'?.N.1".".N!(ACIR<5)!(ACIR>100) W !?5,"Enter number between 5 and 100; outside values should be assessed manually" G A2 -A3 W !,"Calf Circumference (cm): " W:$G(CCIR) CCIR_"// " R X:DTIME G QT:'$T!(X["^") - S:X'="" CCIR=X - S:CCIR="" CCIR=X - G A4:CCIR="" - I CCIR'?.N.1".".N!(CCIR<10)!(CCIR>250) W !?5,"Enter value between 10 and 250; outside values should be assessed manually" G A3 -A4 I ACIR,TSF S X1=ACIR-(TSF/10*3.1416),BFAMA=X1*X1/12.5664-$S(AGE<18:0,SEX="M":10,1:6.5),BFAMA=$J(BFAMA,0,1) - Q -QT S EXT="" Q - ; -REC ;recalculate calorie, protien and fluid requirements. - I '$G(IBW)!'$G(WGT)!'$G(HGT)!'$G(AGE) Q - I $D(CFRBO) S CB=CFRBO,W2=$S(CB=2:IBW,CB=3:WGT-IBW*.25+IBW,1:WGT)/2.2 - Q:'$G(W2) - ;calorie - I $D(CENB),CENB=3 D - .I SEX="M" S KCAL=(10*W2)+(6.25*2.54*HGT)-(5*AGE)+5 - .I SEX="F" S KCAL=(10*W2)+(6.25*2.54*HGT)-(5*AGE)-161 - .S KCAL=$J(KCAL,0,0) - I $D(CENB),CENB=1 D - .I SEX="F" S KCAL=(655.10+(9.56*W2)+(1.85*HGT*2.54)-(4.68*AGE)) - .I SEX="M" S KCAL=(66.47+(13.75*W2)+(5.0*HGT*2.54)-(6.67*AGE)) - .I $D(SEF),$G(AF) S KCAL=+$J(KCAL*AF*SEF,0,0) - .S KCAL=$J(KCAL,0,0) - I $D(CENB),(CENB=2),$G(EKKG) S KCAL=+$J(EKKG*W2,0,0) - ;fluid - I $G(CFRB),CFRB=1 D - .S:AGE>17 FLD=35 - .S:AGE>64 FLD=30 - .S FLD=W2*FLD - I $D(CFRB),CFRB=2 S W1=W2,FLD=$S(W1<10:W1*100,W1<20:W1-10*50+1000,1:W1-20*25+1500) - I $D(CFRB),CFRB=3 S FLD=KCAL - I $D(CFRB),CFRB=4 S FLD=.5*KCAL - I $D(CFRB),CFRB=5 S X=W2,X1=.425 D PWR^FHASM6 S FLD=Y,X=HGT*2.54,X1=.725 D PWR^FHASM6 S FLD=FLD*Y*.007184*1500 - S FLD=+$J(FLD,0,0) - I FLD'?1N.N!(FLD<0)!(FLD>10000) W *7,!,"Fluid level must be between 0-10000 ml/day" S FHQTALL=1 Q - S FLD=+$J(FLD,0,0) - ;protien - S P1=$S(AGE>18:.8,AGE>14:.84,AGE>10:1,AGE>6:1.2,AGE>3:1.5,AGE>1:1.8,AGE>.5:2,1:2.2) - I P1=FHPL S PRO=+$J(P1*W2,0,0) - I P1'=FHPL S PRO=+$J(FHPL*W2,0,0) - I PRO'="",(PRO'>0!(PRO>400)) W *7," Protien level is greater than 0 but not more than 400." S FHQTALL=1 - ;FOLLOW-UP DATE. - S (FHDD,DTP)="" - I $G(RC),FHFUD
100) W !?5,"Enter value between 1 and 100; outside values should be assessed manually" G ANT +A1 W !,"Subscapular Skinfold (mm): " W:$D(SCA) SCA_"// " R X:DTIME G QT:'$T!(X["^") + S:X'="" SCA=X + S:SCA="" SCA=X + G A2:SCA="" + I SCA'?.N.1".".N!(SCA<1)!(SCA>100) W !?5,"Enter value between 1 and 100; outside values should be assessed manually" G A1 +A2 W !,"Arm Circumference (cm): " W:$G(ACIR) ACIR_"// " R X:DTIME G QT:'$T!(X["^") + S:X'="" ACIR=X + S:SCA="" ACIR=X + G A3:ACIR="" + I ACIR'?.N.1".".N!(ACIR<5)!(ACIR>100) W !?5,"Enter number between 5 and 100; outside values should be assessed manually" G A2 +A3 W !,"Calf Circumference (cm): " W:$G(CCIR) CCIR_"// " R X:DTIME G QT:'$T!(X["^") + S:X'="" CCIR=X + S:CCIR="" CCIR=X + G A4:CCIR="" + I CCIR'?.N.1".".N!(CCIR<10)!(CCIR>250) W !?5,"Enter value between 10 and 250; outside values should be assessed manually" G A3 +A4 I ACIR,TSF S X1=ACIR-(TSF/10*3.1416),BFAMA=X1*X1/12.5664-$S(AGE<18:0,SEX="M":10,1:6.5),BFAMA=$J(BFAMA,0,1) + Q +QT S EXT="" Q + ; +REC ;recalculate calorie, protien and fluid requirements. + I '$G(IBW)!'$G(WGT)!'$G(HGT)!'$G(AGE) Q + I $D(CFRBO) S CB=CFRBO,W2=$S(CB=2:IBW,CB=3:WGT-IBW*.25+IBW,1:WGT)/2.2 + Q:'$G(W2) + ;calorie + I $D(CENB),CENB=3 D + .I SEX="M" S KCAL=(10*W2)+(6.25*2.54*HGT)-(5*AGE)+5 + .I SEX="F" S KCAL=(10*W2)+(6.25*2.54*HGT)-(5*AGE)-161 + .S KCAL=$J(KCAL,0,0) + I $D(CENB),CENB=1 D + .I SEX="F" S KCAL=(655.10+(9.56*W2)+(1.85*HGT*2.54)-(4.68*AGE)) + .I SEX="M" S KCAL=(66.47+(13.75*W2)+(5.0*HGT*2.54)-(6.67*AGE)) + .I $D(SEF),$G(AF) S KCAL=+$J(KCAL*AF*SEF,0,0) + .S KCAL=$J(KCAL,0,0) + I $D(CENB),(CENB=2),$G(EKKG) S KCAL=+$J(EKKG*W2,0,0) + ;fluid + I $G(CFRB),CFRB=1 D + .S:AGE>17 FLD=35 + .S:AGE>64 FLD=30 + .S FLD=W2*FLD + I $D(CFRB),CFRB=2 S W1=W2,FLD=$S(W1<10:W1*100,W1<20:W1-10*50+1000,1:W1-20*25+1500) + I $D(CFRB),CFRB=3 S FLD=KCAL + I $D(CFRB),CFRB=4 S FLD=.5*KCAL + I $D(CFRB),CFRB=5 S X=W2,X1=.425 D PWR^FHASM6 S FLD=Y,X=HGT*2.54,X1=.725 D PWR^FHASM6 S FLD=FLD*Y*.007184*1500 + S FLD=+$J(FLD,0,0) + I FLD'?1N.N!(FLD<0)!(FLD>10000) W *7,!,"Fluid level must be between 0-10000 ml/day" S FHQTALL=1 Q + S FLD=+$J(FLD,0,0) + ;protien + S P1=$S(AGE>18:.8,AGE>14:.84,AGE>10:1,AGE>6:1.2,AGE>3:1.5,AGE>1:1.8,AGE>.5:2,1:2.2) + S PRO=+$J(P1*W2,0,0) + I PRO'="",(PRO'>0!(PRO>400)) W *7," Protien level is greater than 0 but not more than 400." S FHQTALL=1 + ;FOLLOW-UP DATE. + S (FHDD,DTP)="" + I $G(RC),FHFUD
200) W !?5,"Enter 0-200 grams of protein intake" G E32 -E33 R !,"Enter Urinary Nitrogen Output (gm/24hr): ",X2:DTIME S:X2=U FHQUIT=1 G KIL^FHASM1:'$T!(X2["^"),E35:X2="" - I X2'?.N.1".".N!(X2<0)!(X2>30) W !?5,"Enter 0-30 gms of Urinary Nitrogen output (24 hr UUN)" G E33 -E34 R !,"Enter Insensible Nitrogen Output (gm/24hr): 4// ",X3:DTIME S:X3="" X3=4 S:X3=U FHQUIT=1 G:'$T!(X3["^") KIL^FHASM1 - I X3'?.N.1".".N!(X3<0)!(X3>10) W !?5,"Insensible Nitrogen output should be between 0-10 grams" G E34 - S NB=X1/6.25-(X2+X3),NB=$J(NB,0,0) W !,"Nitrogen Balance: ",NB -E35 G:'FHDFN KIL -EDU ; - W !!,"Did you educate patient on Food/Drug Interactions (Y/N): " W:FHEDU'="" FHEDU_"//" W:FHEDU="" "N//" R X:DTIME - G KIL^FHASM1:'$T!(X["^") - I X="",FHEDU="" S X="N" - I X="",FHEDU'="" S X=FHEDU - D TR^FH - I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7,!,"Enter 'Y' for yes or 'N' for no." G EDU - S FHEDU=$E(X,1) -EDC ;food/drug comment. - S FHFDC=FHFDCSV - W !!,"Food/Drug Comment: ",FHFDCSV,"// " R FHFDC:DTIME I '$T!(FHFDC["^") S FHQUIT=1 G KIL^FHASM1 - I FHFDC="@" S FHFDCSV="" W " deleted..." G DPL - I (FHFDC=""),(FHFDCSV'="") S FHFDC=FHFDCSV - I FHFDC["?"!($L(FHFDC)>30) W *7,!,"Enter Food/Drug Comment or Hit Return to Accept or @ to Delete and cannot exceed 30 characters!!" G EDC - S FHFDCSV=FHFDC - ;adding diagnosis, follow-up date -DPL ;get diagnosis from Problem List package. - D:DFN LIST^GMPLUTL2(.FHPLIST,DFN,"A","") - S FHDIACT=0 - I $D(FHPLIST(0)) S FHDIACT=FHPLIST(0) -DP1 I FHDIACT D - .S FHDCH="" - .W !!,"Patient's Diagnosis from Problem List:",! - .F FHDLI=0:0 S FHDLI=$O(FHPLIST(FHDLI)) Q:'FHDLI D - ..S DTP=$P(FHPLIST(FHDLI),U,6) D DTP^FH - ..W !,?6,FHDLI_" ",$P(FHPLIST(FHDLI),U,3)," - Date entered: ",DTP - G:'FHDIACT ANF - W !!,"Diagnosis: " W:FHDIPL'="" FHDIPL W "// " R FHDCH:DTIME S:FHDCH=U FHQUIT=1 G:'$T!(FHDCH["^") KIL^FHASM1 - G:FHDCH="" ANF - I FHDCH="@" S (FHDIPL,FHDIPLD)="" G ANF - I '$D(FHPLIST(FHDCH)) W !!,*7,"Choose a number from the list or Hit Return to accept default!!",! G DP1 - S FHDIPL=$P(FHPLIST(FHDCH),U,3),FHDIPLD=$P(FHPLIST(FHDCH),U,6) -ANF ;problem through NFS. - S AFDIA=FHDINA - W !!,"Problem: ",FHDINA,"// " R AFDIA:DTIME I '$T!(AFDIA["^") S FHQUIT=1 G KIL^FHASM1 - I AFDIA="@" S FHDINA="" W " deleted..." G DNF - I (AFDIA=""),(FHDINA'="") S AFDIA=FHDINA - I AFDIA["?"!($L(AFDIA)>30) W *7,!,"Enter patient's Problem or Hit Return to Accept or @ to Delete and cannot exceed 30 characters!!" G ANF - S FHDINA=AFDIA - ; -DNF ;aditional problem through NFS. - S NFDIA=FHDINF - W !!,"Additional Problem: ",FHDINF,"// " R NFDIA:DTIME I '$T!(NFDIA["^") S FHQUIT=1 G KIL^FHASM1 - I NFDIA="@" S FHDINF="" W " deleted..." G E4 - I (NFDIA=""),(FHDINF'="") S NFDIA=FHDINF - I NFDIA["?"!($L(NFDIA)>30) W *7,!,"Enter Additional Problem of a patient or Hit Return to Accept or @ to Delete and cannot exceed 30 characters!!" G DNF - S FHDINF=NFDIA - ; -E4 ; - S APP=FHAPP - W !!,"Appearance: ",FHAPP,"// " R APP:DTIME I '$T!(APP["^") S FHQUIT=1 G KIL^FHASM1 - I APP="@" S FHAPP="" W " deleted..." G EC1 - I (APP=""),(FHAPP'="") S APP=FHAPP - I APP["?"!(APP'?.ANP)!($L(APP)>60) W *7,!,"Enter Physical Appearance of patient or Hit Return to Accept or @ to Delete and cannot exceed 60 characters." G E4 - S FHAPP=APP -EC1 W ! S DIC="^FH(115.3,",DIC(0)="AEQMZ",DIC("B")=XD D ^DIC K DIC G KIL^FHASM1:X["^"!$D(DTOUT) S XD=$S(Y>0:+Y,1:"") -E5 W ! S DIC="^FH(115.4,",DIC(0)="AEQMZ",DIC("B")=RC,DIC("S")="I $P(^(0),U,2)'=""""" D ^DIC K DIC G KIL^FHASM1:X["^"!$D(DTOUT) S RC=$S(Y>0:+Y,1:"") - W !!,"Comments:" K ^TMP("FH",$J) S DIC="^TMP(""FH"",$J,",DWPK=1 - I FHASK="E",$D(^FHPT(FHDFN,"N",FHCAS,"X")) M ^TMP("FH",$J)=^FHPT(FHDFN,"N",FHCAS,"X") D EN^DIWE G FDT - D EN^DIWE -FDT ;enter follow-up date. - S (FHDD,DTP)="" - I $G(RC) D - .S X=$P($G(^FH(115.4,RC,0)),U,2) D TR^FH - .I X["NORMAL" D - ..S:FHLOC FHDD=$P($G(^FH(119.6,FHLOC,0)),U,20) - ..S:FHDD DTP="T+"_FHDD - ..S:'FHDD DTP="T+11" - .I X["MILD" D - ..S:FHLOC FHDD=$P($G(^FH(119.6,FHLOC,0)),U,21) - ..S:FHDD DTP="T+"_FHDD - ..S:'FHDD DTP="T+9" - .I X["MODERATE" D - ..S:FHLOC FHDD=$P($G(^FH(119.6,FHLOC,0)),U,22) - ..S:FHDD DTP="T+"_FHDD - ..S:'FHDD DTP="T+7" - .I X["SEVERE" D - ..S:FHLOC FHDD=$P($G(^FH(119.6,FHLOC,0)),U,23) - ..S:FHDD DTP="T+"_FHDD - ..S:'FHDD DTP="T+5" - K %DT S %DT="AEF",%DT("A")="Enter Follow-up Assessment Date: " - I FHFUD'="",FHFUD>DT S DTP=$E(FHFUD,4,5)_"/"_$E(FHFUD,6,7)_"/"_$E(FHFUD,2,3) - S:DTP'="" %DT("B")=DTP S:DTP="" %DT("B")="TODAY" - S %DT(0)=DT - W ! D ^%DT K %DT G KIL^FHASM1:X["^"!$D(DTOUT),FDT:Y<1 - S FHFUD=Y -SDAT ;create or update nutrition assessment and file to Progress Notes. - G:'$D(FHASK) KILL^XUSCLEAN - I '$D(^FHPT(FHDFN,0)) S ^(0)=FHDFN - I '$D(^FHPT(FHDFN,"N",0)) S ^FHPT(FHDFN,"N",0)="^115.011D^^" - K DIC,DD,DO S DIC="^FHPT(FHDFN,""N"",",DIC(0)="L",DLAYGO=115,DA(1)=FHDFN - I FHASK="E" S ASN=FHCAS D REC^FHASM3 ;re-calculate calorie, protien and fluid requirement. - I FHASK="C" S X=ADT,DINUM=9999999-ADT D FILE^DICN S ASN=+Y ;if not an update, create. - D NOW^%DTC S NOW=% - S A2=HGT*.0254,BMI=+$J(WGT/2.2/(A2*A2),0,1) - S Y=ADT_"^"_SEX_"^"_AGE_"^"_HGT_"^"_HGP_"^"_WGT_"^"_WGP_"^"_DWGT_"^"_UWGT_"^"_IBW_"^"_FRM_"^"_AMP_"^^^^"_KCAL_"^"_PRO_"^"_FLD_"^"_RC_"^"_XD_"^"_BMI_"^"_BMIP_"^"_DUZ_"^"_NOW_"^"_NB - S ^FHPT(FHDFN,"N",ASN,0)=Y - S:'FHFUD FHFUD=DT - S FHASN1=TSF_U_TSFP_U_SCA_U_SCAP_U_ACIR_U_ACIRP_U_CCIR_U_CCIRP_U_BFAMA_U_BFAMAP_U_WCCM_U_CIBW_U_CERBO_U_CENB_U_PCTB_U_SEF_U_CFRB_U_CFRBO_U_CPRBO_U_EKKG - S ^FHPT(FHDFN,"N",ASN,1)=FHASN1 - S ^FHPT(FHDFN,"N",ASN,2)=FHAPP - S ^FHPT(FHDFN,"N",ASN,3)=FHYN_U_FHFEC_U_FHFPC_U_FHDINA_U_FHEDU_U_FHFDCSV_U_FHPL_U_FHSPC - S ^FHPT(FHDFN,"N",ASN,"DI")=FHDIPL_U_FHDIPLD_U_FHDINF_U_FHDINFD_U_FHFUD_U_FHDIST_U_FHDIDI_U_FHDITFDT - S $P(^FHPT(FHDFN,"N",ASN,"DI"),U,10)=FHDITFML - S $P(^FHPT(FHDFN,"N",ASN,"DI"),U,11)=FHDITFKC - S $P(^FHPT(FHDFN,"N",ASN,4),U,1)=FHDITFCM - I $D(FHDITFPR),'$D(^FHPT(FHDFN,"N",ASN,"TF")) F FHTUN=0:0 S FHTUN=$O(FHDITFPR(FHTUN)) Q:FHTUN'>0 D - .S Y=FHTUN K DIC,DO S DA(2)=FHDFN,DA(1)=ASN - .S DIC="^FHPT("_DA(2)_",""N"","_DA(1)_",""TF""," - .S DIC(0)="L",DIC("P")=$P(^DD(115.011,67.1,0),U,2),X=+Y - .D FILE^DICN I Y=-1 Q - .K DIE S DA(2)=FHDFN,DA(1)=ASN,DA=+Y - .S FH1=$P(FHDITFPR(FHTUN),U,2),FH2=$P(FHDITFPR(FHTUN),U,3) - .S DIE="^FHPT("_DA(2)_",""N"","_DA(1)_",""TF""," - .S DR="1////^S X=FH1;2////^S X=FH2" D ^DIE - I FHFUDS,(FHFUDS'=FHFUD) K ^FHPT("E",FHFUDS,FHDFN,ASN) - I FHFUD S DA(1)=FHDFN,DA=ASN,DIK="^FHPT(DA(1)"_",""N"",",DIK(1)="64^E" D IX^DIK - G:'$D(LRTST) E7 - S N1=0 F K=0:0 S K=$O(LRTST(K)) Q:K="" S ^FHPT(FHDFN,"N",ASN,"L",K,0)=LRTST(K),N1=N1+1 - I N1,'$D(^FHPT(FHDFN,"N",ASN,"L",0)) S ^(0)="^115.021^^" -E7 G:'$D(^TMP("FH",$J)) E8 - S ^FHPT(FHDFN,"N",ASN,"X",0)=^TMP("FH",$J,0) - S N1=0 F K=0:0 S K=$O(^TMP("FH",$J,K)) Q:K'>0 S N1=N1+1,^FHPT(FHDFN,"N",ASN,"X",N1,0)=^TMP("FH",$J,K,0) -E8 S DTE=ADT,S1=1,S2="I",S3=$S('RC:"",1:"Nutrition Status: "_$P(^FH(115.4,RC,0),"^",2)) - I $G(DFN) D FIL^FHASE3 I 'RC G E9 - I '$D(^FHPT(FHDFN,"S",0)) S ^(0)="^115.012D^^" - K DIC,DD,DO S DIC="^FHPT(FHDFN,""S"",",DIC(0)="L",DLAYGO=115,DA(1)=FHDFN,X=ADT,DINUM=9999999-ADT D FILE^DICN S ASE=+Y - I $G(DFN) D DID^FHDPA S $P(^FHPT(FHDFN,"S",ASE,0),"^",2,3)=RC_"^"_DUZ S:FHWRD $P(^(0),"^",6)=FHWRD -E9 ;D P0^FHASMR -E6 R !!,"Save as Work in Progress or Complete or Delete this assessment: W// ",X:DTIME G:'$T!(X["^") KILL^XUSCLEAN - S:X="" X="W" D TR^FHASM1 - I ($E(X)'="W"),($E(X)'="C"),($E(X)'="D") W *7,!," Answer 'W' to file as Work in progress or 'C' to Complete and send to TIU or 'D' to Delete" G E6 - I $E(X)="D" S DA(1)=FHDFN,DIK="^FHPT(FHDFN,""N"",",DA=ASN D ^DIK W !!,"Deleted...",! G KILL^XUSCLEAN - I $E(X)="W" S $P(^FHPT(FHDFN,"N",ASN,"DI"),U,6)="W" W !!,"This Assessment has been saved as Work in Progress...",! - I $E(X)="C" D - .;send assessment to TIU if pt has entry in #2 and is inpatient. - .I $G(DFN) S WARD=$G(^DPT(DFN,.1)) I WARD'="" D ^FHASMR2 K ^TMP($J) I $G(FHOUT) D Q - ..W !!,"TIU Progress Note was NOT created!!" - ..S $P(^FHPT(FHDFN,"N",ASN,"DI"),U,6)="W" - .S $P(^FHPT(FHDFN,"N",ASN,"DI"),U,6)="C" - .W !!,"Assessment is completed" I $G(DFN),WARD'="" W " and forwarded to TIU" W "...",! -KIL G KILL^XUSCLEAN +FHASM7 ; HISC/REL - KCAL Distribution ;8/18/93 11:05 + ;;5.5;DIETETICS;**8**;Jan 28, 2005;Build 28 + S PRT=0,(ASN,NB)="" +E31 S FH7FLG=1 D ^FHASMR1 K FH7FLG + R !!,"Do you want to do a NITROGEN BALANCE? NO// ",X:DTIME G:'$T!(X["^") KIL^FHASM1 S:X="" X="N" D TR^FHASM1 I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7," Answer YES or NO" G E31 + I $E(X,1)="N" G KIL:'FHDFN,EDU +E32 R !!,"Enter Protein Intake (gm/24hr): ",X1:DTIME S:X1=U FHQUIT=1 G KIL^FHASM1:'$T!(X1["^"),E35:X1="" + I X1'?.N.1".".N!(X1<0)!(X1>200) W !?5,"Enter 0-200 grams of protein intake" G E32 +E33 R !,"Enter Urinary Nitrogen Output (gm/24hr): ",X2:DTIME S:X2=U FHQUIT=1 G KIL^FHASM1:'$T!(X2["^"),E35:X2="" + I X2'?.N.1".".N!(X2<0)!(X2>30) W !?5,"Enter 0-30 gms of Urinary Nitrogen output (24 hr UUN)" G E33 +E34 R !,"Enter Insensible Nitrogen Output (gm/24hr): 4// ",X3:DTIME S:X3="" X3=4 S:X3=U FHQUIT=1 G:'$T!(X3["^") KIL^FHASM1 + I X3'?.N.1".".N!(X3<0)!(X3>10) W !?5,"Insensible Nitrogen output should be between 0-10 grams" G E34 + S NB=X1/6.25-(X2+X3),NB=$J(NB,0,0) W !,"Nitrogen Balance: ",NB +E35 G:'FHDFN KIL +EDU ; + W !!,"Did you educate patient on Food/Drug Interactions (Y/N): " W:FHEDU'="" FHEDU_"//" W:FHEDU="" "N//" R X:DTIME + G KIL^FHASM1:'$T!(X["^") + I X="",FHEDU="" S X="N" + I X="",FHEDU'="" S X=FHEDU + D TR^FH + I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7,!,"Enter 'Y' for yes or 'N' for no." G EDU + S FHEDU=$E(X,1) +EDC ;food/drug comment. + S FHFDC=FHFDCSV + W !!,"Food/Drug Comment: ",FHFDCSV,"// " R FHFDC:DTIME I '$T!(FHFDC["^") S FHQUIT=1 G KIL^FHASM1 + I FHFDC="@" S FHFDCSV="" W " deleted..." G DPL + I (FHFDC=""),(FHFDCSV'="") S FHFDC=FHFDCSV + I FHFDC["?"!($L(FHFDC)>30) W *7,!,"Enter Food/Drug Comment or Hit Return to Accept or @ to Delete and cannot exceed 30 characters!!" G EDC + S FHFDCSV=FHFDC + ;adding diagnosis, follow-up date +DPL ;get diagnosis from Problem List package. + D:DFN LIST^GMPLUTL2(.FHPLIST,DFN,"A","") + S FHDIACT=0 + I $D(FHPLIST(0)) S FHDIACT=FHPLIST(0) +DP1 I FHDIACT D + .S FHDCH="" + .W !!,"Patient's Diagnosis from Problem List:",! + .F FHDLI=0:0 S FHDLI=$O(FHPLIST(FHDLI)) Q:'FHDLI D + ..S DTP=$P(FHPLIST(FHDLI),U,6) D DTP^FH + ..W !,?6,FHDLI_" ",$P(FHPLIST(FHDLI),U,3)," - Date entered: ",DTP + G:'FHDIACT ANF + W !!,"Diagnosis: " W:FHDIPL'="" FHDIPL W "// " R FHDCH:DTIME S:FHDCH=U FHQUIT=1 G:'$T!(FHDCH["^") KIL^FHASM1 + G:FHDCH="" ANF + I FHDCH="@" S (FHDIPL,FHDIPLD)="" G ANF + I '$D(FHPLIST(FHDCH)) W !!,*7,"Choose a number from the list or Hit Return to accept default!!",! G DP1 + S FHDIPL=$P(FHPLIST(FHDCH),U,3),FHDIPLD=$P(FHPLIST(FHDCH),U,6) +ANF ;problem through NFS. + S AFDIA=FHDINA + W !!,"Problem: ",FHDINA,"// " R AFDIA:DTIME I '$T!(AFDIA["^") S FHQUIT=1 G KIL^FHASM1 + I AFDIA="@" S FHDINA="" W " deleted..." G DNF + I (AFDIA=""),(FHDINA'="") S AFDIA=FHDINA + I AFDIA["?"!($L(AFDIA)>30) W *7,!,"Enter patient's Problem or Hit Return to Accept or @ to Delete and cannot exceed 30 characters!!" G ANF + S FHDINA=AFDIA + ; +DNF ;aditional problem through NFS. + S NFDIA=FHDINF + W !!,"Additional Problem: ",FHDINF,"// " R NFDIA:DTIME I '$T!(NFDIA["^") S FHQUIT=1 G KIL^FHASM1 + I NFDIA="@" S FHDINF="" W " deleted..." G E4 + I (NFDIA=""),(FHDINF'="") S NFDIA=FHDINF + I NFDIA["?"!($L(NFDIA)>30) W *7,!,"Enter Additional Problem of a patient or Hit Return to Accept or @ to Delete and cannot exceed 30 characters!!" G DNF + S FHDINF=NFDIA + ; +E4 ; + S APP=FHAPP + W !!,"Appearance: ",FHAPP,"// " R APP:DTIME I '$T!(APP["^") S FHQUIT=1 G KIL^FHASM1 + I APP="@" S FHAPP="" W " deleted..." G EC1 + I (APP=""),(FHAPP'="") S APP=FHAPP + I APP["?"!(APP'?.ANP)!($L(APP)>60) W *7,!,"Enter Physical Appearance of patient or Hit Return to Accept or @ to Delete and cannot exceed 60 characters." G E4 + S FHAPP=APP +EC1 W ! S DIC="^FH(115.3,",DIC(0)="AEQMZ",DIC("B")=XD D ^DIC K DIC G KIL^FHASM1:X["^"!$D(DTOUT) S XD=$S(Y>0:+Y,1:"") +E5 W ! S DIC="^FH(115.4,",DIC(0)="AEQMZ",DIC("B")=RC,DIC("S")="I $P(^(0),U,2)'=""""" D ^DIC K DIC G KIL^FHASM1:X["^"!$D(DTOUT) S RC=$S(Y>0:+Y,1:"") + W !!,"Comments:" K ^TMP("FH",$J) S DIC="^TMP(""FH"",$J,",DWPK=1 + I FHASK="E",$D(^FHPT(FHDFN,"N",FHCAS,"X")) M ^TMP("FH",$J)=^FHPT(FHDFN,"N",FHCAS,"X") D EN^DIWE G FDT + D EN^DIWE +FDT ;enter follow-up date. + S (FHDD,DTP)="" + I $G(RC) D + .S X=$P($G(^FH(115.4,RC,0)),U,2) D TR^FH + .I X["NORMAL" D + ..S:FHLOC FHDD=$P($G(^FH(119.6,FHLOC,0)),U,20) + ..S:FHDD DTP="T+"_FHDD + ..S:'FHDD DTP="T+11" + .I X["MILD" D + ..S:FHLOC FHDD=$P($G(^FH(119.6,FHLOC,0)),U,21) + ..S:FHDD DTP="T+"_FHDD + ..S:'FHDD DTP="T+9" + .I X["MODERATE" D + ..S:FHLOC FHDD=$P($G(^FH(119.6,FHLOC,0)),U,22) + ..S:FHDD DTP="T+"_FHDD + ..S:'FHDD DTP="T+7" + .I X["SEVERE" D + ..S:FHLOC FHDD=$P($G(^FH(119.6,FHLOC,0)),U,23) + ..S:FHDD DTP="T+"_FHDD + ..S:'FHDD DTP="T+5" + K %DT S %DT="AEF",%DT("A")="Enter Follow-up Assessment Date: " + I FHFUD'="",FHFUD>DT S DTP=$E(FHFUD,4,5)_"/"_$E(FHFUD,6,7)_"/"_$E(FHFUD,2,3) + S:DTP'="" %DT("B")=DTP S:DTP="" %DT("B")="TODAY" + S %DT(0)=DT + W ! D ^%DT K %DT G KIL^FHASM1:X["^"!$D(DTOUT),FDT:Y<1 + S FHFUD=Y +SDAT ;create or update nutrition assessment and file to Progress Notes. + G:'$D(FHASK) KILL^XUSCLEAN + I '$D(^FHPT(FHDFN,0)) S ^(0)=FHDFN + I '$D(^FHPT(FHDFN,"N",0)) S ^FHPT(FHDFN,"N",0)="^115.011D^^" + K DIC,DD,DO S DIC="^FHPT(FHDFN,""N"",",DIC(0)="L",DLAYGO=115,DA(1)=FHDFN + I FHASK="E" S ASN=FHCAS D REC^FHASM3 ;re-calculate calorie, protien and fluid requirement. + I FHASK="C" S X=ADT,DINUM=9999999-ADT D FILE^DICN S ASN=+Y ;if not an update, create. + D NOW^%DTC S NOW=% + S A2=HGT*.0254,BMI=+$J(WGT/2.2/(A2*A2),0,1) + S Y=ADT_"^"_SEX_"^"_AGE_"^"_HGT_"^"_HGP_"^"_WGT_"^"_WGP_"^"_DWGT_"^"_UWGT_"^"_IBW_"^"_FRM_"^"_AMP_"^^^^"_KCAL_"^"_PRO_"^"_FLD_"^"_RC_"^"_XD_"^"_BMI_"^"_BMIP_"^"_DUZ_"^"_NOW_"^"_NB + S ^FHPT(FHDFN,"N",ASN,0)=Y + S:'FHFUD FHFUD=DT + S FHASN1=TSF_U_TSFP_U_SCA_U_SCAP_U_ACIR_U_ACIRP_U_CCIR_U_CCIRP_U_BFAMA_U_BFAMAP_U_WCCM_U_CIBW_U_CERBO_U_CENB_U_PCTB_U_SEF_U_CFRB_U_CFRBO_U_CPRBO_U_EKKG + S ^FHPT(FHDFN,"N",ASN,1)=FHASN1 + S ^FHPT(FHDFN,"N",ASN,2)=FHAPP + S ^FHPT(FHDFN,"N",ASN,3)=FHYN_U_FHFEC_U_FHFPC_U_FHDINA_U_FHEDU_U_FHFDCSV_U_FHPL_U_FHSPC + S ^FHPT(FHDFN,"N",ASN,"DI")=FHDIPL_U_FHDIPLD_U_FHDINF_U_FHDINFD_U_FHFUD_U_FHDIST_U_FHDIDI_U_FHDITFDT + S $P(^FHPT(FHDFN,"N",ASN,"DI"),U,10)=FHDITFML + S $P(^FHPT(FHDFN,"N",ASN,"DI"),U,11)=FHDITFKC + S $P(^FHPT(FHDFN,"N",ASN,4),U,1)=FHDITFCM + I $D(FHDITFPR),'$D(^FHPT(FHDFN,"N",ASN,"TF")) F FHTUN=0:0 S FHTUN=$O(FHDITFPR(FHTUN)) Q:FHTUN'>0 D + .S Y=FHTUN K DIC,DO S DA(2)=FHDFN,DA(1)=ASN + .S DIC="^FHPT("_DA(2)_",""N"","_DA(1)_",""TF""," + .S DIC(0)="L",DIC("P")=$P(^DD(115.011,67.1,0),U,2),X=+Y + .D FILE^DICN I Y=-1 Q + .K DIE S DA(2)=FHDFN,DA(1)=ASN,DA=+Y + .S FH1=$P(FHDITFPR(FHTUN),U,2),FH2=$P(FHDITFPR(FHTUN),U,3) + .S DIE="^FHPT("_DA(2)_",""N"","_DA(1)_",""TF""," + .S DR="1////^S X=FH1;2////^S X=FH2" D ^DIE + I FHFUDS,(FHFUDS'=FHFUD) K ^FHPT("E",FHFUDS,FHDFN,ASN) + I FHFUD S DA(1)=FHDFN,DA=ASN,DIK="^FHPT(DA(1)"_",""N"",",DIK(1)="64^E" D IX^DIK + G:'$D(LRTST) E7 + S N1=0 F K=0:0 S K=$O(LRTST(K)) Q:K="" S ^FHPT(FHDFN,"N",ASN,"L",K,0)=LRTST(K),N1=N1+1 + I N1,'$D(^FHPT(FHDFN,"N",ASN,"L",0)) S ^(0)="^115.021^^" +E7 G:'$D(^TMP("FH",$J)) E8 + S ^FHPT(FHDFN,"N",ASN,"X",0)=^TMP("FH",$J,0) + S N1=0 F K=0:0 S K=$O(^TMP("FH",$J,K)) Q:K'>0 S N1=N1+1,^FHPT(FHDFN,"N",ASN,"X",N1,0)=^TMP("FH",$J,K,0) +E8 S DTE=ADT,S1=1,S2="I",S3=$S('RC:"",1:"Nutrition Status: "_$P(^FH(115.4,RC,0),"^",2)) + I $G(DFN) D FIL^FHASE3 I 'RC G E9 + I '$D(^FHPT(FHDFN,"S",0)) S ^(0)="^115.012D^^" + K DIC,DD,DO S DIC="^FHPT(FHDFN,""S"",",DIC(0)="L",DLAYGO=115,DA(1)=FHDFN,X=ADT,DINUM=9999999-ADT D FILE^DICN S ASE=+Y + I $G(DFN) D DID^FHDPA S $P(^FHPT(FHDFN,"S",ASE,0),"^",2,3)=RC_"^"_DUZ S:FHWRD $P(^(0),"^",6)=FHWRD +E9 ;D P0^FHASMR +E6 R !!,"Save as Work in Progress or Complete or Delete this assessment: W// ",X:DTIME G:'$T!(X["^") KILL^XUSCLEAN + S:X="" X="W" D TR^FHASM1 + I ($E(X)'="W"),($E(X)'="C"),($E(X)'="D") W *7,!," Answer 'W' to file as Work in progress or 'C' to Complete and send to TIU or 'D' to Delete" G E6 + I $E(X)="D" S DA(1)=FHDFN,DIK="^FHPT(FHDFN,""N"",",DA=ASN D ^DIK W !!,"Deleted...",! G KILL^XUSCLEAN + I $E(X)="W" S $P(^FHPT(FHDFN,"N",ASN,"DI"),U,6)="W" W !!,"This Assessment has been saved as Work in Progress...",! + I $E(X)="C" D + .;send assessment to TIU if pt has entry in #2. + .I $G(DFN) D ^FHASMR2 K ^TMP($J) I $G(FHOUT) D Q + ..W !!,"TIU Progress Note was NOT created!!" + ..S $P(^FHPT(FHDFN,"N",ASN,"DI"),U,6)="W" + .S $P(^FHPT(FHDFN,"N",ASN,"DI"),U,6)="C" + .W !!,"Assessment is completed" W:$G(DFN) " and forwarded to TIU" W "...",! +KIL G KILL^XUSCLEAN diff --git a/r/DIETETICS-FH/FHASMR2.m b/r/DIETETICS-FH/FHASMR2.m index 7aa6a8df..c29bbc68 100644 --- a/r/DIETETICS-FH/FHASMR2.m +++ b/r/DIETETICS-FH/FHASMR2.m @@ -1,181 +1,181 @@ -FHASMR2 ;HISC/RVD - Progress Notes To TIU ;04/27/07 06:59 - ;;5.5;DIETETICS;**8,14**;Apr 27, 2007;Build 1 - ;input var: fhdfn,na ien (var ASN),dfn - ;only process inpatient assessment. - ;uses DBIA #1911 -EN ; save note to a temp global - K ^TMP("TIUP",$J) - D NOW^%DTC S NOW=% K % S FHN=1 - S ($P(LN5," ",5),$P(LN10," ",10),$P(LN20," ",20),$P(LN25," ",25),$P(LN30," ",30))="" - S ($P(LN35," ",35),$P(LN40," ",40),$P(LN45," ",45),$P(LN50," ",45),$P(LN55," ",55),$P(LN60," ",60))="" - S ($P(LN65," ",65))="" - S ^TMP("TIUP",$J,FHN,0)=NAM_LN10_$S(SEX="M":"Male",1:"Female")_LN10_"Age: "_AGE - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" - S DTP=ADT D DTP^FH S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN25_"Date of Assessment: "_$E(DTP,1,9) - S (FHRDIPLD,FHRDIST,FHRDIPL,FHRDINFD,FHRDINA,FHRDINFD,FHRDINF,FHREDU,FHRDIDI,FHRDITF,FHRDITFM,FHRDITFK,FHRDITFC,FHRNWGT,FHRDNWGT,FHRFUD,FHRFEC,FHRFPC,FHRFDC)="" D DIA -EN1 S DTP="" I FHRDIPLD S DTP=FHRDIPLD D DTP^FH - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Diagnosis: "_$E(FHRDIPL,1,30) - S DTP="" I FHRDINFD S DTP=FHRDINFD D DTP^FH - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Problem: "_$E(FHRDINA,1,30) - S DTP="" I FHRDINFD S DTP=FHRDINFD D DTP^FH - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Additional Problem: "_$E(FHRDINF,1,30) - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" - S FHN=FHN+1 - S ^TMP("TIUP",$J,FHN,0)="Current Diet: "_$E(FHRDIDI,1,53) - I FHRDITF'="" D - .S DTP=FHRDITF D DTP^FH - .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Tubefeed Ordered: "_DTP - .I ASN I $D(^FHPT(FHDFN,"N",ASN,"TF")) F FHTUN=0:0 S FHTUN=$O(^FHPT(FHDFN,"N",ASN,"TF",FHTUN)) Q:FHTUN'>0 D - ..S FHASTFZN=$G(^FHPT(FHDFN,"N",ASN,"TF",FHTUN,0)) - ..S TNM=$P(FHASTFZN,U,1),STR=$P(FHASTFZN,U,2),QUA=$P(FHASTFZN,U,3) - ..S FHTFPROD=$P($G(^FH(118.2,TNM,0)),"^",1)_", "_$S(STR=4:"Full",STR=1:"1/4",STR=2:"1/2",1:"3/4")_" Str., "_QUA - ..S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=" "_FHTFPROD - .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Total Quantity: "_FHRDITFM_"ml"_LN5_"Total KCAL: "_FHRDITFK - .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Tubefeed Comment: "_FHRDITFC - K FHRDIPL,FHRDIPLD,FHRDINF,FHRDINFD,FHRDIDI,FHTFPROD,FHRDITF,FHRDITFM,FHRDITFK,FHRDITFC,DTP - S X1=$S(HGT\12:HGT\12_"'",1:"")_$S(HGT#12:" "_(HGT#12)_"""",1:""),X2=+$J(HGT*2.54,0,0)_" cm" - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="",FHN=FHN+1 - S ^TMP("TIUP",$J,FHN,0)="Height: "_$S(FHU'="M":X1,1:X2)_" ("_$S(FHU'="M":X2,1:X1)_")" I HGP'="" S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_" "_$S(HGP="K":"knee hgt",HGP="S":"stated",1:"") - S X1=WGT_" lbs",X2=+$J(WGT/2.2,0,1)_" kg" - S FHN=FHN+1 - S ^TMP("TIUP",$J,FHN,0)="Weight: "_$S(FHU'="M":X1,1:X2)_" ("_$S(FHU'="M":X2,1:X1)_")" I WGP'="" S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_" "_$S(WGP="A":"anthro",WGP="S":"stated",1:"") - S DTP=DWGT D DTP^FH - S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_LN5_" Weight Taken: "_DTP - S X1=FHRNWGT_" lbs",X2=+$J(FHRNWGT/2.2,0,1)_" kg" - K FHRNWGT,FHRDNWGT - I UWGT S X1=UWGT_" lbs",X2=+$J(UWGT/2.2,0,1)_" kg" - S FHN=FHN+1 - S ^TMP("TIUP",$J,FHN,0)="Usual Weight: " - I UWGT S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_$S(FHU'="M":X1,1:X2)_" ("_$S(FHU'="M":X2,1:X1)_")" - S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_LN5_"% Usual Wt: " - I UWGT S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_$J(WGT/UWGT*100,3,0)_"%" - S X1=IBW_" lbs",X2=+$J(IBW/2.2,0,1)_" kg" - S FHN=FHN+1 - S ^TMP("TIUP",$J,FHN,0)="Target Weight: "_$S(FHU'="M":X1,1:X2)_" ("_$S(FHU'="M":X2,1:X1)_") % Target Wt: " - I IBW S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_$J(WGT/IBW*100,3,0)_"%" - I AMP S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_"Target weight adjusted for amputation" - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Frame Size: "_$S(FRM="S":"Small",FRM="M":"Medium",FRM="L":"Large",1:"") - S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_LN10_" Body Mass Index: "_BMI - S EXT="" I $G(TSF)!$G(SCA)!$G(ACIR)!$G(CCIR) S EXT="Y" - G:EXT'="Y" EN2 ;there is no antthropometric measurement. - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="",FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN25_"Anthropometric Measurements" - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN35_"%ile %ile" - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_"Triceps Skinfold (mm) "_$J(+TSF,3,0)_" "_$J(TSFP,3)_LN5_"Arm Circumference (cm) " - S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_$J(+ACIR,3,0)_" "_$J(ACIRP,3) - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_"Subscapular Skinfold (mm) " - S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_$J(+SCA,3,0)_" "_$J(SCAP,3)_" Bone-free AMA (cm2) " - S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_$J(+BFAMA,3,0)_" "_$J(BFAMAP,3) - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_"Calf Circumference (cm) " - S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_$J(+CCIR,3,0)_" "_$J(CCIRP,3) -EN2 ;skip here if there is no anthropometric measurement. - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN30_"Laboratory Data" - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_"Test"_LN20_"Result units"_LN10_"Ref. range"_LN10_"Date" - S N1=0 F K=0:0 S K=$O(LRTST(K)) Q:K="" D LAB - I 'N1 D - .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" - .S FHN=FHN+1,^TMP("TIYP",$J,FHN,0)=LN5_"No laboratory data available last "_$S($D(^FH(119.9,1,3)):$P(^(3),"^",2),1:90)_" days" - S N=PRO/6.25 -DRU ;pharmacy data. - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_"Medications" - S PX=1 D DRUG^FHASM4 - I $D(PSCA) D - .F FHI=0:0 S FHI=$O(PSCA(FHI)) Q:FHI'>0 S FHJ="" F S FHJ=$O(PSCA(FHI,FHJ)) Q:FHJ="" D - ..S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" - ..S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_FHJ - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Educated on Food/Drug Interactions: "_$S(FHREDU="Y":"Yes",1:"No") K FHREDU - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="FOOD/DRUG COMMENT: "_FHRFDC - K FHI,FHJ,PSD,PSCA - ; - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Energy Requirements: "_KCAL_" Kcal/day" - I N S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_" Kcal:N "_$J(KCAL/N,0,0)_":1" - I NB'="" S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_" N-Bal: "_NB - I FHRFEC'="" D - .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_"Energy calculation is based on: "_FHRFEC - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Protein Requirements: "_PRO_" gm/day" - I N S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_" NPC:N "_$J(KCAL-(PRO*4)/N,0,0)_":1" - I FHRFPC'="" D - .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_"Protein calculation is based on: "_FHRFPC - K FHRFEC,FHRFPC - I FLD'="" D - .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Fluid Requirements: "_FLD_" ml/day" - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" - I FHAPP'="" D - .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Appearance: "_FHAPP - I XD D - .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Nutrition Class: "_$P($G(^FH(115.3,XD,0)),"^",1) - I RC D - .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Nutrition Status: "_$P($G(^FH(115.4,RC,0)),"^",2) - D DCOM - Q -DIA ;get data from DI node. - I ASN S FHDIA=$G(^FHPT(FHDFN,"N",ASN,"DI")) Q:FHDIA="" D - .S FHRDIPL=$P(FHDIA,U,1) - .S FHRDIPLD=$P(FHDIA,U,2) - .S FHRDINF=$P(FHDIA,U,3) - .S FHRDINFD=$P(FHDIA,U,4) - .S FHRFUD=$P(FHDIA,U,5) - .S FHRDIST=$P(FHDIA,U,6) - .S FHRDIDI=$P(FHDIA,U,7) - .S FHRDITF=$P(FHDIA,U,8) - .S FHRDITFM=$P(FHDIA,U,10) - .S FHRDITFK=$P(FHDIA,U,11) - .S FHRDITFC=$P($G(^FHPT(FHDFN,"N",ASN,4)),U,1) - .S FHRFEC=$P($G(^FHPT(FHDFN,"N",ASN,3)),U,2) - .S FHRFPC=$P($G(^FHPT(FHDFN,"N",ASN,3)),U,3) - .S FHRDINA=$P($G(^FHPT(FHDFN,"N",ASN,3)),U,4) - .S FHREDU=$P($G(^FHPT(FHDFN,"N",ASN,3)),U,5) - .S FHRFDC=$P($G(^FHPT(FHDFN,"N",ASN,3)),U,6) - Q -DCOM ;print follow up date and status and comments - S DTP="" I FHRFUD S DTP=FHRFUD D DTP^FH - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Follow-up Date: "_DTP - K FHRFUD,FHRDIST - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Comments:" - I ASN F K=0:0 S K=$O(^FHPT(FHDFN,"N",ASN,"X",K)) Q:K<1 D - .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=^FHPT(FHDFN,"N",ASN,"X",K,0) - S SIGN=$P(^FHPT(FHDFN,"N",ASN,0),U,23) - D NOW^%DTC S FHRDT=%,FHIFN="",FHESBY=FHCLI K %,%H,%I,X - ;Use data from user selection from file 8925.1 - K DIC,DA W !!,"Enter a Progress Note Title for this Assessment!!",! - S DIC=8925.1,DIC(0)="AEQMZ",DIC("S")="I ($P($G(^TIU(8925.1,+Y,0)),U,7)'=13),($P(^(0),U,1)[""NUTRITION""),($P(^(0),U,4)=""DOC"")" D ^DIC - K DIC I X["^"!$D(DTOUT)!(Y<1) S FHOUT=1 Q - S FHIEN1=+Y - ;call TIU to create a progress notes; DBIA #1911 - ;D NEW^TIUPNAPI(.FHIFN,DFN,DUZ,FHRDT,FHIEN1,"","","",FHESBY,"","") - D NEW^TIUPNAPI(.FHIFN,DFN,DUZ,FHRDT,FHIEN1,"","","","","","") - I $P(FHIFN,U,1)'>0 S FHOUT=1 - K FHIFN,FHRDT,FHTITLE,FHESBY,FHTIUST,FH251,FHIEN1 - ;done - Q -Q6 D FOOT Q -LAB S X1=$P(LRTST(K),"^",7) Q:X1="" S DTP=X1\1 D DTP^FH - I 'N1 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" S N1=N1+1 - S FHLABTE=$P(LRTST(K),U,1)_" " - S FHLABRE=$P(LRTST(K),U,6)_" " - S FHLABUN=$P(LRTST(K),U,4)_" " - S FHLABRR=$P(LRTST(K),U,5)_" " - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=$E(FHLABTE,1,20)_" "_$E(FHLABRE,1,11)_" "_$E(FHLABUN,1,13)_" "_$E(FHLABRR,1,20)_" "_DTP - Q -HEAD ; Page Header - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=DTP_LN30_"NUTRITION ASSESSMENT" - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN - Q -FOOT ; Page Footer - D SITE^FH - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" - I $G(DFN) S W1=$G(^DPT(DFN,.1)) S:$D(^DPT(DFN,.101)) W1=W1_"/"_^DPT(DFN,.101) I W1'="" D - .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" - .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN30_W1_LN5_"(Vice SF 509)" - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN - S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" - Q +FHASMR2 ;HISC/RVD - Progress Notes To TIU ;04/27/07 06:59 + ;;5.5;DIETETICS;**8**;Apr 27, 2007;Build 28 + ;input var: fhdfn,na ien (var ASN),dfn + ;only process inpatient assessment. + ;uses DBIA #1911 +EN ; save note to a temp global + K ^TMP("TIUP",$J) + D NOW^%DTC S NOW=% K % S FHN=1 + S ($P(LN5," ",5),$P(LN10," ",10),$P(LN20," ",20),$P(LN25," ",25),$P(LN30," ",30))="" + S ($P(LN35," ",35),$P(LN40," ",40),$P(LN45," ",45),$P(LN50," ",45),$P(LN55," ",55),$P(LN60," ",60))="" + S ($P(LN65," ",65))="" + S ^TMP("TIUP",$J,FHN,0)=NAM_LN10_$S(SEX="M":"Male",1:"Female")_LN10_"Age: "_AGE + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" + S DTP=ADT D DTP^FH S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN25_"Date of Assessment: "_$E(DTP,1,9) + S (FHRDIPLD,FHRDIST,FHRDIPL,FHRDINFD,FHRDINA,FHRDINFD,FHRDINF,FHREDU,FHRDIDI,FHRDITF,FHRDITFM,FHRDITFK,FHRDITFC,FHRNWGT,FHRDNWGT,FHRFUD,FHRFEC,FHRFPC,FHRFDC)="" D DIA +EN1 S DTP="" I FHRDIPLD S DTP=FHRDIPLD D DTP^FH + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Diagnosis: "_$E(FHRDIPL,1,30) + S DTP="" I FHRDINFD S DTP=FHRDINFD D DTP^FH + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Problem: "_$E(FHRDINA,1,30) + S DTP="" I FHRDINFD S DTP=FHRDINFD D DTP^FH + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Additional Problem: "_$E(FHRDINF,1,30) + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" + S FHN=FHN+1 + S ^TMP("TIUP",$J,FHN,0)="Current Diet: "_$E(FHRDIDI,1,53) + I FHRDITF'="" D + .S DTP=FHRDITF D DTP^FH + .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Tubefeed Ordered: "_DTP + .I ASN I $D(^FHPT(FHDFN,"N",ASN,"TF")) F FHTUN=0:0 S FHTUN=$O(^FHPT(FHDFN,"N",ASN,"TF",FHTUN)) Q:FHTUN'>0 D + ..S FHASTFZN=$G(^FHPT(FHDFN,"N",ASN,"TF",FHTUN,0)) + ..S TNM=$P(FHASTFZN,U,1),STR=$P(FHASTFZN,U,2),QUA=$P(FHASTFZN,U,3) + ..S FHTFPROD=$P($G(^FH(118.2,TNM,0)),"^",1)_", "_$S(STR=4:"Full",STR=1:"1/4",STR=2:"1/2",1:"3/4")_" Str., "_QUA + ..S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=" "_FHTFPROD + .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Total Quantity: "_FHRDITFM_"ml"_LN5_"Total KCAL: "_FHRDITFK + .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Tubefeed Comment: "_FHRDITFC + K FHRDIPL,FHRDIPLD,FHRDINF,FHRDINFD,FHRDIDI,FHTFPROD,FHRDITF,FHRDITFM,FHRDITFK,FHRDITFC,DTP + S X1=$S(HGT\12:HGT\12_"'",1:"")_$S(HGT#12:" "_(HGT#12)_"""",1:""),X2=+$J(HGT*2.54,0,0)_" cm" + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="",FHN=FHN+1 + S ^TMP("TIUP",$J,FHN,0)="Height: "_$S(FHU'="M":X1,1:X2)_" ("_$S(FHU'="M":X2,1:X1)_")" I HGP'="" S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_" "_$S(HGP="K":"knee hgt",HGP="S":"stated",1:"") + S X1=WGT_" lbs",X2=+$J(WGT/2.2,0,1)_" kg" + S FHN=FHN+1 + S ^TMP("TIUP",$J,FHN,0)="Weight: "_$S(FHU'="M":X1,1:X2)_" ("_$S(FHU'="M":X2,1:X1)_")" I WGP'="" S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_" "_$S(WGP="A":"anthro",WGP="S":"stated",1:"") + S DTP=DWGT D DTP^FH + S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_LN5_" Weight Taken: "_DTP + S X1=FHRNWGT_" lbs",X2=+$J(FHRNWGT/2.2,0,1)_" kg" + K FHRNWGT,FHRDNWGT + I UWGT S X1=UWGT_" lbs",X2=+$J(UWGT/2.2,0,1)_" kg" + S FHN=FHN+1 + S ^TMP("TIUP",$J,FHN,0)="Usual Weight: " + I UWGT S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_$S(FHU'="M":X1,1:X2)_" ("_$S(FHU'="M":X2,1:X1)_")" + S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_LN5_"% Usual Wt: " + I UWGT S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_$J(WGT/UWGT*100,3,0)_"%" + S X1=IBW_" lbs",X2=+$J(IBW/2.2,0,1)_" kg" + S FHN=FHN+1 + S ^TMP("TIUP",$J,FHN,0)="Target Weight: "_$S(FHU'="M":X1,1:X2)_" ("_$S(FHU'="M":X2,1:X1)_") % Target Wt: " + I IBW S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_$J(WGT/IBW*100,3,0)_"%" + I AMP S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_"Target weight adjusted for amputation" + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Frame Size: "_$S(FRM="S":"Small",FRM="M":"Medium",FRM="L":"Large",1:"") + S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_LN10_" Body Mass Index: "_BMI + S EXT="" I $G(TSF)!$G(SCA)!$G(ACIR)!$G(CCIR) S EXT="Y" + G:EXT'="Y" EN2 ;there is no antthropometric measurement. + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="",FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN25_"Anthropometric Measurements" + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN35_"%ile %ile" + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_"Triceps Skinfold (mm) "_$J(+TSF,3,0)_" "_$J(TSFP,3)_LN5_"Arm Circumference (cm) " + S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_$J(+ACIR,3,0)_" "_$J(ACIRP,3) + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_"Subscapular Skinfold (mm) " + S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_$J(+SCA,3,0)_" "_$J(SCAP,3)_" Bone-free AMA (cm2) " + S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_$J(+BFAMA,3,0)_" "_$J(BFAMAP,3) + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_"Calf Circumference (cm) " + S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_$J(+CCIR,3,0)_" "_$J(CCIRP,3) +EN2 ;skip here if there is no anthropometric measurement. + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN30_"Laboratory Data" + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_"Test"_LN20_"Result units"_LN10_"Ref. range"_LN10_"Date" + S N1=0 F K=0:0 S K=$O(LRTST(K)) Q:K="" D LAB + I 'N1 D + .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" + .S FHN=FHN+1,^TMP("TIYP",$J,FHN,0)=LN5_"No laboratory data available last "_$S($D(^FH(119.9,1,3)):$P(^(3),"^",2),1:90)_" days" + S N=PRO/6.25 +DRU ;pharmacy data. + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_"Medications" + S PX=1 D DRUG^FHASM4 + I $D(PSCA) D + .F FHI=0:0 S FHI=$O(PSCA(FHI)) Q:FHI'>0 S FHJ="" F S FHJ=$O(PSCA(FHI,FHJ)) Q:FHJ="" D + ..S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" + ..S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_FHJ + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Educated on Food/Drug Interactions: "_$S(FHREDU="Y":"Yes",1:"No") K FHREDU + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="FOOD/DRUG COMMENT: "_FHRFDC + K FHI,FHJ,PSD,PSCA + ; + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Energy Requirements: "_KCAL_" Kcal/day" + I N S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_" Kcal:N "_$J(KCAL/N,0,0)_":1" + I NB'="" S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_" N-Bal: "_NB + I FHRFEC'="" D + .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_"Energy calculation is based on: "_FHRFEC + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Protein Requirements: "_PRO_" gm/day" + I N S ^TMP("TIUP",$J,FHN,0)=^TMP("TIUP",$J,FHN,0)_" NPC:N "_$J(KCAL-(PRO*4)/N,0,0)_":1" + I FHRFPC'="" D + .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN5_"Protein calculation is based on: "_FHRFPC + K FHRFEC,FHRFPC + I FLD'="" D + .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Fluid Requirements: "_FLD_" ml/day" + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" + I FHAPP'="" D + .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Appearance: "_FHAPP + I XD D + .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Nutrition Class: "_$P($G(^FH(115.3,XD,0)),"^",1) + I RC D + .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Nutrition Status: "_$P($G(^FH(115.4,RC,0)),"^",2) + D DCOM + Q +DIA ;get data from DI node. + I ASN S FHDIA=$G(^FHPT(FHDFN,"N",ASN,"DI")) Q:FHDIA="" D + .S FHRDIPL=$P(FHDIA,U,1) + .S FHRDIPLD=$P(FHDIA,U,2) + .S FHRDINF=$P(FHDIA,U,3) + .S FHRDINFD=$P(FHDIA,U,4) + .S FHRFUD=$P(FHDIA,U,5) + .S FHRDIST=$P(FHDIA,U,6) + .S FHRDIDI=$P(FHDIA,U,7) + .S FHRDITF=$P(FHDIA,U,8) + .S FHRDITFM=$P(FHDIA,U,10) + .S FHRDITFK=$P(FHDIA,U,11) + .S FHRDITFC=$P($G(^FHPT(FHDFN,"N",ASN,4)),U,1) + .S FHRFEC=$P($G(^FHPT(FHDFN,"N",ASN,3)),U,2) + .S FHRFPC=$P($G(^FHPT(FHDFN,"N",ASN,3)),U,3) + .S FHRDINA=$P($G(^FHPT(FHDFN,"N",ASN,3)),U,4) + .S FHREDU=$P($G(^FHPT(FHDFN,"N",ASN,3)),U,5) + .S FHRFDC=$P($G(^FHPT(FHDFN,"N",ASN,3)),U,6) + Q +DCOM ;print follow up date and status and comments + S DTP="" I FHRFUD S DTP=FHRFUD D DTP^FH + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Follow-up Date: "_DTP + K FHRFUD,FHRDIST + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="Comments:" + I ASN F K=0:0 S K=$O(^FHPT(FHDFN,"N",ASN,"X",K)) Q:K<1 D + .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=^FHPT(FHDFN,"N",ASN,"X",K,0) + S SIGN=$P(^FHPT(FHDFN,"N",ASN,0),U,23) + S FHRDT=DT,FHIFN="",FHESBY=FHCLI + ;Use data from user selection from file 8925.1 + K DIC,DA W !!,"Enter a Progress Note Title for this Assessment!!",! + S DIC=8925.1,DIC(0)="AEQMZ",DIC("S")="I ($P($G(^TIU(8925.1,+Y,0)),U,7)'=13),($P(^(0),U,1)[""NUTRITION""),($P(^(0),U,4)=""DOC"")" D ^DIC + K DIC I X["^"!$D(DTOUT)!(Y<1) S FHOUT=1 Q + S FHIEN1=+Y + ;call TIU to create a progress notes; DBIA #1911 + ;D NEW^TIUPNAPI(.FHIFN,DFN,DUZ,FHRDT,FHIEN1,"","","",FHESBY,"","") + D NEW^TIUPNAPI(.FHIFN,DFN,DUZ,FHRDT,FHIEN1,"","","","","","") + I $P(FHIFN,U,1)'>0 S FHOUT=1 + K FHIFN,FHRDT,FHTITLE,FHESBY,FHTIUST,FH251,FHIEN1 + ;done + Q +Q6 D FOOT Q +LAB S X1=$P(LRTST(K),"^",7) Q:X1="" S DTP=X1\1 D DTP^FH + I 'N1 S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" S N1=N1+1 + S FHLABTE=$P(LRTST(K),U,1)_" " + S FHLABRE=$P(LRTST(K),U,6)_" " + S FHLABUN=$P(LRTST(K),U,4)_" " + S FHLABRR=$P(LRTST(K),U,5)_" " + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=$E(FHLABTE,1,20)_" "_$E(FHLABRE,1,9)_" "_$E(FHLABUN,1,14)_" "_$E(FHLABRR,1,21)_" "_DTP + Q +HEAD ; Page Header + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=DTP_LN30_"NUTRITION ASSESSMENT" + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN + Q +FOOT ; Page Footer + D SITE^FH + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" + I $G(DFN) S W1=$G(^DPT(DFN,.1)) S:$D(^DPT(DFN,.101)) W1=W1_"/"_^DPT(DFN,.101) I W1'="" D + .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" + .S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN30_W1_LN5_"(Vice SF 509)" + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)=LN + S FHN=FHN+1,^TMP("TIUP",$J,FHN,0)="" + Q diff --git a/r/DIETETICS-FH/FHASP1.m b/r/DIETETICS-FH/FHASP1.m index 604001d7..94cc05f9 100644 --- a/r/DIETETICS-FH/FHASP1.m +++ b/r/DIETETICS-FH/FHASP1.m @@ -1,82 +1,82 @@ -FHASP1 ; HISC/REL/JH - Nutrition Profile (cont) ;5/2/01 10:14 - ;;5.5;DIETETICS;**8,9**;Jan 28, 2005;Build 7 - ; - I '$G(FHET) S X="T-365",%DT="XT" D ^%DT S FHET=Y K %DT - S DTP=FHET D DTP^FH S FHENDATE=DTP - S N1=0 - W !!?22,"Dietetic Encounters since ",FHENDATE - F FHET=FHET:0 S FHET=$O(^FHEN("AP",DFN,FHET)) Q:FHET<1!(ANS="^") F ASN=0:0 S ASN=$O(^FHEN("AP",DFN,FHET,ASN)) Q:ASN<1 D:$Y'0 S Z=^(NDT,0) I "I"[$P(Z,"^",2) D CLIN Q:ANS="^" - K ^TMP($J) - S FHCNT="" - D GETAPPT^SDAMA201(DFN,"1;2;12","R",DT,,.FHCNT,"") - G:'$D(^TMP($J,"SDAMA201","GETAPPT")) NOAPP - I $D(^TMP($J,"SDAMA201","GETAPPT")) S FHTMP=$NA(^TMP($J,"SDAMA201","GETAPPT")) - I $D(@FHTMP@("ERROR")) D PRERR - I $G(FHCNT) F FHI=0:0 S FHI=$O(@FHTMP@(FHI)) Q:FHI'>0 D CLIN I ANS="^" K ^TMP($J) Q - K ^TMP($J) - ;end changes in patch #41 - Q:ANS="^" -NOAPP I 'N1 W !!?5,"No scheduled appointments." - D FOOT^FHASP Q -LST S X0=$G(^FHEN(ASN,0)) Q:$P(X0,"^",4)<3 - S X1=$G(^FHEN(ASN,"P",DFN,0)) - W:'N1 ! S N1=N1+1,DTP=$P(X0,"^",2) D DTP^FH W !?5,$E(DTP,1,9)," " S Y=$P(X0,"^",4),Y=$P($G(^FH(115.6,+Y,0)),"^",1) W Y I $P(X0,"^",7)="F" W " (FU)" - S Y=$P(X0,"^",9) W ", ",$S(Y="G":"Group",1:"Individual") - S Y=$P(X0,"^",11) W:Y'="" !?10,Y S Y=$P(X1,"^",4) W:Y'="" !?10,Y Q - ;patch #41 -CLIN ;S SC=+$P(Z,"^",1),Y=$P($G(^SC(SC,0)),"^",1) Q:Y="" - S NDT=@FHTMP@(FHI,1) - S SC=$P(@FHTMP@(FHI,2),U,1) - S Y=$P(@FHTMP@(FHI,2),U,2) Q:Y="" - D:$Y'0:P(M,"L",P1),1:"") S:P2'="" P2=$O(P(M,"D",P2)) S X2=$S(P2>0:P(M,"D",P2),1:"") Q:P1=""&(P2="") D P0 Q:ANS="^" W:MM'=M ! - . Q - Q:ANS="^" - I $O(P(""))="" W !,"No Food Preferences on file",! - Q -P0 I X1'="" W ?12 S X=X1 D P1 S X1=X - I X2'="" W ?46 S X=X2 D P1 S X2=X - Q:X1=""&(X2="") D:$Y'0 S Z=^(NDT,0) I "I"[$P(Z,"^",2) D CLIN Q:ANS="^" + K ^TMP($J) + S FHCNT="" + D GETAPPT^SDAMA201(DFN,"1;2;12","R",DT,,.FHCNT,"") + G:'$D(^TMP($J,"SDAMA201","GETAPPT")) NOAPP + I $D(^TMP($J,"SDAMA201","GETAPPT")) S FHTMP=$NA(^TMP($J,"SDAMA201","GETAPPT")) + I $D(@FHTMP@("ERROR")) D PRERR + I $G(FHCNT) F FHI=0:0 S FHI=$O(@FHTMP@(FHI)) Q:FHI'>0 D CLIN I ANS="^" K ^TMP($J) Q + K ^TMP($J) + ;end changes in patch #41 + Q:ANS="^" +NOAPP I 'N1 W !!?5,"No scheduled appointments." + D FOOT^FHASP Q +LST S X0=$G(^FHEN(ASN,0)) Q:$P(X0,"^",4)<3 + S X1=$G(^FHEN(ASN,"P",DFN,0)) + W:'N1 ! S N1=N1+1,DTP=$P(X0,"^",2) D DTP^FH W !?5,$E(DTP,1,9)," " S Y=$P(X0,"^",4),Y=$P($G(^FH(115.6,+Y,0)),"^",1) W Y I $P(X0,"^",7)="F" W " (FU)" + S Y=$P(X0,"^",9) W ", ",$S(Y="G":"Group",1:"Individual") + S Y=$P(X0,"^",11) W:Y'="" !?10,Y S Y=$P(X1,"^",4) W:Y'="" !?10,Y Q + ;patch #41 +CLIN ;S SC=+$P(Z,"^",1),Y=$P($G(^SC(SC,0)),"^",1) Q:Y="" + S NDT=@FHTMP@(FHI,1) + S SC=$P(@FHTMP@(FHI,2),U,1) + S Y=$P(@FHTMP@(FHI,2),U,2) Q:Y="" + D:$Y'0:P(M,"L",P1),1:"") S:P2'="" P2=$O(P(M,"D",P2)) S X2=$S(P2>0:P(M,"D",P2),1:"") Q:P1=""&(P2="") D P0 Q:ANS="^" W:MM'=M ! + . Q + Q:ANS="^" + I $O(P(""))="" W !,"No Food Preferences on file",! + Q +P0 I X1'="" W ?12 S X=X1 D P1 S X1=X + I X2'="" W ?46 S X=X2 D P1 S X2=X + Q:X1=""&(X2="") D:$Y'FHEDT W !!,"END DATE BEFORE START DATE!",! H 1 Q - K ^TMP($J,"FH") S FHEDT=FHEDT_.99 - F FHDFN=0:0 S FHDFN=$O(^FHPT(FHDFN)) Q:FHDFN'>0 F FHADM=0:0 S FHADM=$O(^FHPT(FHDFN,"A",FHADM)) Q:FHADM'>0 D - .I '$D(^FHPT(FHDFN,0)) Q - .; Quit if patient is deceased - DSS developer added lines DATA+9,10,13 - .S FHDCEASE=$$GET1^DIQ(2,$P(^FHPT(FHDFN,0),U,3),".351","I") - .Q:FHDCEASE&(FHDCEASEFHEDT Q - .I '$P(FHZN,U,14),FHDCEASE S $P(FHZN,U,14)=FHDCEASE - .S FHDDTM=$P(FHZN,U,14) I FHDDTM'="",FHDDTM0!(FHDATE>FHEDT) D - ..S FHDSEQ=$P($G(^FHPT(FHDFN,"A",FHADM,"AC",FHDATE,0)),U,2) - ..S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"DI",FHDSEQ,0)) - ..I FHDATE0!(FHDATE>FHEDT) D - ..S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"EL",FHDATE,0)) - ..I FHDATE0 D - ..S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"SF",FHSF,0)) - ..S FHDATE=$P(FHNODE,U,2) I FHDATE>FHEDT Q - ..S FHCDATE=$P(FHNODE,U,32) I FHCDATE'="" I FHCDATE0 D - ..S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"SP",FHSO,0)) - ..S FHDATE=$P(FHNODE,U,4) I FHDATE>FHEDT Q - ..S FHCDATE=$P(FHNODE,U,6) I FHCDATE'="" I FHCDATE0 D - ..S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"TF",FHTF,0)) - ..S FHDATE=$P(FHNODE,U,1) I FHDATE>FHEDT Q - ..S FHCDATE=$P(FHNODE,U,11) I FHCDATE'="" I FHCDATE0 D - ...S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"TF",FHTF,"P",FHTFPR,0)) - ...S ^TMP($J,"FH",FHADM,FHDFN,FHDATE,"TF",FHTFPR,"P")=FHNODE - ...Q - ..Q - .Q - ; Get outpatient meals - S X1=FHSDT,X2=-1 D C^%DTC S FHSDTX1=X_.99 - ; Get recurring meals - F FHOMDT=FHSDTX1:0 S FHOMDT=$O(^FHPT("RM",FHOMDT)) Q:FHOMDT=""!(FHOMDT'0 D - .....S FHTUZN=$G(^FHPT(FHDFN,"OP",FHRNUM,"TF",FHZ,0)) - .....S ^TMP($J,"FH",FHOMDT,FHDFN,FHRNUM,"RMTF",FHZ)=FHTUZN I '$D(^TMP($J,"FH","ZN",FHDFN)) S ^TMP($J,"FH","ZN",FHDFN)=^FHPT(FHDFN,0) - ; Get special meals - F FHOMDT=FHSDTX1:0 S FHOMDT=$O(^FHPT("SM",FHOMDT)) Q:FHOMDT=""!(FHOMDT'FHEDT W !!,"END DATE BEFORE START DATE!",! H 1 Q + K ^TMP($J,"FH") S FHEDT=FHEDT_.99 + F FHDFN=0:0 S FHDFN=$O(^FHPT(FHDFN)) Q:FHDFN'>0 F FHADM=0:0 S FHADM=$O(^FHPT(FHDFN,"A",FHADM)) Q:FHADM'>0 F FHDATE=FHSDT:0 S FHDATE=$O(^FHPT(FHDFN,"A",FHADM,"AC",FHDATE)) Q:FHDATE'>0!(FHDATE>FHEDT) D + .S FHDSEQ=$P($G(^FHPT(FHDFN,"A",FHADM,"AC",FHDATE,0)),U,2) + .S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"DI",FHDSEQ,0)) + .S ^TMP($J,"FH",FHDATE,FHDFN,FHADM,"INP")=FHNODE I '$D(^TMP($J,"FH","ZN",FHDFN)) S ^TMP($J,"FH","ZN",FHDFN)=^FHPT(FHDFN,0) + ; Get additional feedings for inpatient + F FHDFN=0:0 S FHDFN=$O(^FHPT(FHDFN)) Q:FHDFN'>0 F FHADM=0:0 S FHADM=$O(^FHPT(FHDFN,"A",FHADM)) Q:'FHADM D + .F FHEL=FHSDT:0 S FHEL=$O(^FHPT(FHDFN,"A",FHADM,"EL",FHEL)) Q:FHEL'>0!(FHEL>FHEDT) D + ..S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"EL",FHEL,0)) + ..S ^TMP($J,"FH",FHEL,FHDFN,FHADM,"EL")=FHNODE I '$D(^TMP($J,"FH","ZN",FHDFN)) S ^TMP($J,"FH","ZN",FHDFN)=^FHPT(FHDFN,0) + .F FHSF=0:0 S FHSF=$O(^FHPT(FHDFN,"A",FHADM,"SF",FHSF)) Q:FHSF'>0 D + ..S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"SF",FHSF,0)),FHSFDT=$P(FHNODE,U,2) + ..I FHSFDTFHEDT) Q + ..S ^TMP($J,"FH",FHSFDT,FHDFN,FHADM,"SF")=FHNODE I '$D(^TMP($J,"FH","ZN",FHDFN)) S ^TMP($J,"FH","ZN",FHDFN)=^FHPT(FHDFN,0) + .F FHSO=0:0 S FHSO=$O(^FHPT(FHDFN,"A",FHADM,"SP",FHSO)) Q:FHSO'>0 D + ..S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"SP",FHSO,0)),FHSODT=$P(FHNODE,U,4) + ..I FHSODTFHEDT) Q + ..S ^TMP($J,"FH",FHSODT,FHDFN,FHADM,"SO")=FHNODE I '$D(^TMP($J,"FH","ZN",FHDFN)) S ^TMP($J,"FH","ZN",FHDFN)=^FHPT(FHDFN,0) + .F FHTF=0:0 S FHTF=$O(^FHPT(FHDFN,"A",FHADM,"TF",FHTF)) Q:FHTF'>0 D + ..S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"TF",FHTF,0)),FHTFDT=$P(FHNODE,U,1) + ..I FHTFDTFHEDT) Q + ..S ^TMP($J,"FH",FHTFDT,FHDFN,FHADM,"TF")=FHNODE I '$D(^TMP($J,"FH","ZN",FHDFN)) S ^TMP($J,"FH","ZN",FHDFN)=^FHPT(FHDFN,0) + ..F FHTFPR=0:0 S FHTFPR=$O(^FHPT(FHDFN,"A",FHADM,"TF",FHTF,"P",FHTFPR)) Q:FHTFPR'>0 D + ...S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"TF",FHTF,"P",FHTFPR,0)) + ...S ^TMP($J,"FH",FHTFDT,FHDFN,FHADM,"TF",FHTFPR,"P")=FHNODE I '$D(^TMP($J,"FH","ZN",FHDFN)) S ^TMP($J,"FH","ZN",FHDFN)=^FHPT(FHDFN,0) + ..Q + .Q + ; Get outpatient meals + S X1=FHSDT,X2=-1 D C^%DTC S FHSDTX1=X_.99 + ; Get recurring meals + F FHOMDT=FHSDTX1:0 S FHOMDT=$O(^FHPT("RM",FHOMDT)) Q:FHOMDT=""!(FHOMDT'0 D + .....S FHTUZN=$G(^FHPT(FHDFN,"OP",FHRNUM,"TF",FHZ,0)) + .....S ^TMP($J,"FH",FHOMDT,FHDFN,FHRNUM,"RMTF",FHZ)=FHTUZN I '$D(^TMP($J,"FH","ZN",FHDFN)) S ^TMP($J,"FH","ZN",FHDFN)=^FHPT(FHDFN,0) + ; Get special meals + F FHOMDT=FHSDTX1:0 S FHOMDT=$O(^FHPT("SM",FHOMDT)) Q:FHOMDT=""!(FHOMDT'2 D DPLL^FHLABEL,KIL Q - I 'D3 F L=1:1:18 W ! -KIL K ^TMP($J) G KILL^XUSCLEAN -Q2 K ^TMP($J,"L"),^TMP($J,"I"),^TMP($J,"SF"),C S P1=$S(TIM=10:5,TIM=2:13,1:21),T0=$P(DT,".",1)_"."_$S(TIM=10:1,TIM=2:14,1:2),P3=7,N1=0 - I XX="W" S P0=$P($G(^FH(119.6,W1,0)),"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0) D F0 - I XX="S" F W1=0:0 S W1=$O(^FH(119.6,W1)) Q:W1<1 S X=^(W1,0),D2=$P(X,"^",9) I D1=D2 S P0=$P(X,"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0) D F0 - D SF0 - G ^FHNO21:'D3,PRT -F0 S WRDN=$P(^FH(119.6,W1,0),"^",1),FHDFN=0 -F1 S FHDFN=$O(^FHPT("AW",W1,FHDFN)) Q:FHDFN'>0 S ADM=$G(^FHPT("AW",W1,FHDFN)) G:ADM<1 F1 - G:'$D(^FHPT(FHDFN,"A",ADM,0)) F1 S X1=^(0),NO=$P(X1,"^",7) G:'NO F1 - I 'D3 S IS=$P(X1,"^",10) I IS S IS=$P($G(^FH(119.4,IS,0)),"^",3) S:IS'="N" IS="" - D CHK G:'NO F1 - S Y=$G(^FHPT(FHDFN,"A",ADM,"SF",NO,0)) - S Y=$P(Y,"^",P1,P1+7) G:Y?."^" F1 D:D3 CALC - I 'D3 D - .D PATNAME^FHOMUTL I DFN="" Q - .S $P(Y,"^",9)=IS - .S LNOD=$S(XX="S":D2_"~"_$P($G(^FH(119.74,D2,0)),"^",1),1:P0_"~"_WRDN) - .S RI=$G(^DPT(DFN,.108)) S RE=$S(RI:$O(^FH(119.6,"AR",+RI,W1,0)),1:"") - .S R0=$S(RE:$P($G(^FH(119.6,W1,"R",+RE,0)),"^",2),1:"") - .S R0=$S(R0<1:99,R0<10:"0"_R0,1:R0) - .S RM=$G(^DPT(DFN,.101)),PNOD=P0_"~"_R0_RM_"~"_FHDFN,WRD=P0_$E(WRDN,1,27-$L(RM))_"/"_RM - .S ^TMP($J,"L",LNOD,PNOD)=Y_"^"_WRD Q - G F1 - Q - ; -CHK S FHORD=$P(X1,"^",2),X1=$P(X1,"^",3) G:FHORD<1 C1 - I X1>1,X1'>T0 G C2 -C0 I '$D(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)) G C2 - S X1=$P(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),"^",7) I X1'="",X1'="X" S NO="" -C1 K FHORD,A1,K,X1 Q -C2 S A1=0 F K=0:0 S K=$O(^FHPT(FHDFN,"A",ADM,"AC",K)) Q:K<1!(K>T0) S A1=K - G:'A1 C1 S FHORD=$P(^FHPT(FHDFN,"A",ADM,"AC",A1,0),"^",2) G:FHORD'<1 C0 K ^FHPT(FHDFN,"A",ADM,"AC",A1) G C2 -SUM K C,^TMP($J,"SF") S P0=$S(TIM=2:13,TIM=8:21,1:5),P3=$S(TIM="ALL":23,1:7),N1=0 - I XX="W" S X=$G(^FH(119.6,W1,0)) D S0 - I XX="S" F W1=0:0 S W1=$O(^FH(119.6,W1)) Q:W1<1 S X=^(W1,0),D2=$P(X,"^",9) I D1=D2 D S0 - D SF0 - G PRT -S0 S WRDN=$P(^FH(119.6,W1,0),"^",1),FHDFN=0 -S1 S FHDFN=$O(^FHPT("AW",W1,FHDFN)) Q:FHDFN="" S ADM=$G(^FHPT("AW",W1,FHDFN)) G:ADM<1 S1 - G:'$D(^FHPT(FHDFN,"A",ADM,0)) S1 S X1=^(0),NO=$P(X1,"^",7) G:'NO S1 - S Y=$P(^FHPT(FHDFN,"A",ADM,"SF",NO,0),"^",P0,P0+P3) G:Y?."^" S1 D CALC - G S1 -PRT S DTP=DT D DTP^FH S DTE=DTP_" "_$S(TIM="ALL":"ALL",TIM=10:TIM_" AM",1:TIM_" PM") - S Y=$S(XX="S":$P($G(^FH(119.74,D1,0)),"^",1),1:WRDN) - W @IOF W:D3=2 !?5,"**** CONSOLIDATED ****" W !?3,"**** INGREDIENTS LIST ****",! W:D3=1 ! W ?(33-$L(Y)\2),Y,!?9,DTE,!! - F L=0:0 S L=$O(^FH(118,L)) Q:L<1 S:$D(C(L)) ^TMP($J,"SF",$P($G(^FH(118,L,0)),"^",1),L)="" - S A1="" F S A1=$O(^TMP($J,"SF",A1)) Q:A1="" F L=0:0 S L=$O(^TMP($J,"SF",A1,L)) Q:L<1 W !,$E(A1,1,26),?28,$J(C(L),5,0) - W !!?4,"**** PATIENTS = ",N1," ****",! Q -CALC S N1=N1+1 - F L=1:2:P3 S Z=$P(Y,"^",L) I Z'="" S Q=$P(Y,"^",L+1) S:'Q Q=1 S:'$D(C(Z)) C(Z)=0 S C(Z)=C(Z)+Q - Q - ; -SF0 ;outpatient SFs - F FHDFN=0:0 S FHDFN=$O(^FHPT("RM",DT,FHDFN)) Q:FHDFN'>0 F ADM=0:0 S ADM=$O(^FHPT("RM",DT,FHDFN,ADM)) Q:ADM'>0 D - .S FHODAT=$G(^FHPT(FHDFN,"OP",ADM,0)),FHNO=$P($G(^FHPT(FHDFN,"OP",ADM,"SF",0)),U,3) Q:'$G(FHNO) - .S FHMEAL=$P(FHODAT,U,4),FHOWARD=$P(FHODAT,U,3) - .S X1=$G(^FH(119.6,FHOWARD,0)) - .Q:'FHOWARD!'$D(^FH(119.6,FHOWARD,0)) - .I XX="W",W1 Q:W1'=FHOWARD - .S WRDN=$P(X1,U,1) - .I XX="S" S D2=$P(X1,"^",9) Q:D1'=D2 I D1=D2 S P0=$P(X1,"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0) - .S P1=$S(FHMEAL="N":13,FHMEAL="E":21,1:5) - .I (FHMEAL="B"),(TIM'=10) Q - .I (FHMEAL="N"),(TIM'=2) Q - .I (FHMEAL="E"),(TIM'=8) Q - .I 'D3 S IS=$P($G(^FHPT(FHDFN,0)),"^",5) I IS S IS=$P($G(^FH(119.4,IS,0)),"^",3) S:IS'="N" IS="" - .S Y=$G(^FHPT(FHDFN,"OP",ADM,"SF",FHNO,0)) - .S Y=$P(Y,"^",P1,P1+7) Q:Y?."^" I D3 D CLC1 - .S N1=N1+1 - .S RM="",RMIEN=$P(FHODAT,U,18) I $G(RMIEN),$D(^DG(405.4,RMIEN,0)) S RM=$E($P(^DG(405.4,RMIEN,0),U,1),1,10) - .I 'D3 D - ..D PATNAME^FHOMUTL - ..S $P(Y,"^",9)=IS - ..S LNOD=$S(XX="S":D2_"~"_$P($G(^FH(119.74,D2,0)),"^",1),1:P0_"~"_WRDN) - ..S RI="***" S RE=$S(RI:$O(^FH(119.6,"AR",+RI,W1,0)),1:"") - ..S R0=$S(RE:$P($G(^FH(119.6,W1,"R",+RE,0)),"^",2),1:"") - ..S R0=$S(R0<1:99,R0<10:"0"_R0,1:R0) - ..S PNOD=P0_"~"_R0_RM_"~"_FHDFN,WRD=P0_$E(WRDN,1,20-$L(RM))_"/"_RM - ..S ^TMP($J,"L",LNOD,PNOD)=Y_"^"_WRD - Q -CLC1 ; - F L=1:2:P3 S Z=$P(Y,"^",L) I Z'="" S Q=$P(Y,"^",L+1) S:'Q Q=1 S:'$D(C(Z)) C(Z)=0 S C(Z)=C(Z)+Q - Q +FHNO2 ; HISC/REL/NCA - Supplemental Feeding Labels ;8/26/94 12:01 + ;;5.5;DIETETICS;**5**;Jan 28, 2005;Build 53 + ;patch #5 - add outpatient SFs. +D0 R !!,"Select by S=SUPPLEMENTAL FEEDING SITE or W=WARD: ",XX:DTIME G:'$T!("^"[XX) KIL I "sw"[XX S X=XX D TR^FH S XX=X + I XX'?1U!("SW"'[XX) W *7," Enter S or W" G D0 + I XX="S" S D1=$O(^FH(119.74,0)) I D1'<1,$O(^FH(119.74,D1))<1 G D3 + I XX="W" S WRD=$O(^FH(119.6,0)) I WRD'<1,$O(^FH(119.6,WRD))<1 G D3 + I XX="S" G D2 +D1 R !!,"Select WARD: ",X:DTIME G:'$T!("^"[X) KIL + K DIC S DIC="^FH(119.6,",DIC(0)="EMQ" D ^DIC G:Y<1 D1 S W1=+Y + S D1=$P($G(^FH(119.6,W1,0)),"^",9) G D3 +D2 R !!,"Select SUPPLEMENTAL FEEDING SITE: ",X:DTIME G:'$T!("^"[X) KIL + K DIC S DIC="^FH(119.74,",DIC(0)="EMQ" D ^DIC G:Y<1 D2 S D1=+Y,W1=0 +D3 R !!,"Select Supplemental Feeding Time (10,2,8,ALL): ",TIM:DTIME G KIL:'$T!(U[TIM) I TIM="all" S X=TIM D TR^FH S TIM=X + I TIM'=2,TIM'=8,TIM'=10,TIM'="ALL" W *7," Enter a time, 10,2,8, or ALL" G D3 + W ! K DIR,LABSTART S DIR(0)="NA^1:10",DIR("A")="If using laser label sheets, what row do you want to begin printing at? ",DIR("B")=1 D ^DIR + Q:$D(DIRUT) S LABSTART=Y +D4 R !!,"Do you want Ingredient list only? N// ",D3:DTIME G:'$T!(D3="^") KIL S:D3="" D3="N" S X=D3 D TR^FH S D3=X I $P("YES",D3,1)'="",$P("NO",D3,1)'="" W *7," Answer YES or NO" G D4 + S D3=$E(D3,1),D3=D3="Y" G:'D3 D6 +D5 R !!,"Consolidated List only? Y// ",X:DTIME G:'$T!(X="^") KIL S:X="" X="Y" D TR^FH I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7," Answer YES or NO" G D5 + S X=$E(X,1) S:X="Y" D3=D3+1 +D6 I 'D3,'D1,XX="L" W !!,"No Supplemental Feeding Site associated with this location." G KIL + W:'D3 !!,"Place Labels in Printer" +PR K IOP S %ZIS="MQ",%ZIS("A")="Select "_$S('D3:"LABEL",1:"LIST")_" Printer: " W ! D ^%ZIS K %ZIS,IOP G:POP KIL + I $D(IO("Q")) S FHPGM="Q1^FHNO2",FHLST="XX^TIM^W1^D1^D3^LABSTART" D EN2^FH G KIL + U IO D Q1 D ^%ZISC K %ZIS,IOP G KIL +Q1 ; Process Printing Supplemental Feeding Labels + S TIMSAV=TIM + D NOW^%DTC S NOW=%,DT=%\1 G:D3=2 SUM + I 'D3 Q:'D1 S FHPAR=$G(^FH(119.74,D1,0)),LAB=$P($G(^FH(119.9,1,"D",IOS,0)),"^",2) S:'LAB LAB=1 + S COUNT=0,LINE=1 I TIM="ALL" S TIM=10 D Q2 S TIM=2 D Q2 S TIM=8 + D Q2 + I $G(LAB)>2 D DPLL^FHLABEL,KIL Q + I 'D3 F L=1:1:18 W ! +KIL K ^TMP($J) G KILL^XUSCLEAN +Q2 K ^TMP($J,"L"),^TMP($J,"I"),^TMP($J,"SF"),C S P1=$S(TIM=10:5,TIM=2:13,1:21),T0=$P(DT,".",1)_"."_$S(TIM=10:1,TIM=2:14,1:2),P3=7,N1=0 + I XX="W" S P0=$P($G(^FH(119.6,W1,0)),"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0) D F0 + I XX="S" F W1=0:0 S W1=$O(^FH(119.6,W1)) Q:W1<1 S X=^(W1,0),D2=$P(X,"^",9) I D1=D2 S P0=$P(X,"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0) D F0 + D SF0 + G ^FHNO21:'D3,PRT +F0 S WRDN=$P(^FH(119.6,W1,0),"^",1),FHDFN=0 +F1 S FHDFN=$O(^FHPT("AW",W1,FHDFN)) Q:FHDFN'>0 S ADM=$G(^FHPT("AW",W1,FHDFN)) G:ADM<1 F1 + G:'$D(^FHPT(FHDFN,"A",ADM,0)) F1 S X1=^(0),NO=$P(X1,"^",7) G:'NO F1 + I 'D3 S IS=$P(X1,"^",10) I IS S IS=$P($G(^FH(119.4,IS,0)),"^",3) S:IS'="N" IS="" + D CHK G:'NO F1 + S Y=$G(^FHPT(FHDFN,"A",ADM,"SF",NO,0)) + S Y=$P(Y,"^",P1,P1+7) G:Y?."^" F1 D:D3 CALC + I 'D3 D + .D PATNAME^FHOMUTL I DFN="" Q + .S $P(Y,"^",9)=IS + .S LNOD=$S(XX="S":D2_"~"_$P($G(^FH(119.74,D2,0)),"^",1),1:P0_"~"_WRDN) + .S RI=$G(^DPT(DFN,.108)) S RE=$S(RI:$O(^FH(119.6,"AR",+RI,W1,0)),1:"") + .S R0=$S(RE:$P($G(^FH(119.6,W1,"R",+RE,0)),"^",2),1:"") + .S R0=$S(R0<1:99,R0<10:"0"_R0,1:R0) + .S RM=$G(^DPT(DFN,.101)),PNOD=P0_"~"_R0_RM_"~"_FHDFN,WRD=P0_$E(WRDN,1,27-$L(RM))_"/"_RM + .S ^TMP($J,"L",LNOD,PNOD)=Y_"^"_WRD Q + G F1 + Q + ; +CHK S FHORD=$P(X1,"^",2),X1=$P(X1,"^",3) G:FHORD<1 C1 + I X1>1,X1'>T0 G C2 +C0 I '$D(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)) G C2 + S X1=$P(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),"^",7) I X1'="",X1'="X" S NO="" +C1 K FHORD,A1,K,X1 Q +C2 S A1=0 F K=0:0 S K=$O(^FHPT(FHDFN,"A",ADM,"AC",K)) Q:K<1!(K>T0) S A1=K + G:'A1 C1 S FHORD=$P(^FHPT(FHDFN,"A",ADM,"AC",A1,0),"^",2) G:FHORD'<1 C0 K ^FHPT(FHDFN,"A",ADM,"AC",A1) G C2 +SUM K C,^TMP($J,"SF") S P0=$S(TIM=2:13,TIM=8:21,1:5),P3=$S(TIM="ALL":23,1:7),N1=0 + I XX="W" S X=$G(^FH(119.6,W1,0)) D S0 + I XX="S" F W1=0:0 S W1=$O(^FH(119.6,W1)) Q:W1<1 S X=^(W1,0),D2=$P(X,"^",9) I D1=D2 D S0 + D SF0 + G PRT +S0 S WRDN=$P(^FH(119.6,W1,0),"^",1),FHDFN=0 +S1 S FHDFN=$O(^FHPT("AW",W1,FHDFN)) Q:FHDFN="" S ADM=$G(^FHPT("AW",W1,FHDFN)) G:ADM<1 S1 + G:'$D(^FHPT(FHDFN,"A",ADM,0)) S1 S X1=^(0),NO=$P(X1,"^",7) G:'NO S1 + S Y=$P(^FHPT(FHDFN,"A",ADM,"SF",NO,0),"^",P0,P0+P3) G:Y?."^" S1 D CALC + G S1 +PRT S DTP=DT D DTP^FH S DTE=DTP_" "_$S(TIM="ALL":"ALL",TIM=10:TIM_" AM",1:TIM_" PM") + S Y=$S(XX="S":$P($G(^FH(119.74,D1,0)),"^",1),1:WRDN) + W @IOF W:D3=2 !?5,"**** CONSOLIDATED ****" W !?3,"**** INGREDIENTS LIST ****",! W:D3=1 ! W ?(33-$L(Y)\2),Y,!?9,DTE,!! + F L=0:0 S L=$O(^FH(118,L)) Q:L<1 S:$D(C(L)) ^TMP($J,"SF",$P($G(^FH(118,L,0)),"^",1),L)="" + S A1="" F S A1=$O(^TMP($J,"SF",A1)) Q:A1="" F L=0:0 S L=$O(^TMP($J,"SF",A1,L)) Q:L<1 W !,$E(A1,1,26),?28,$J(C(L),5,0) + W !!?4,"**** PATIENTS = ",N1," ****",! Q +CALC S N1=N1+1 + F L=1:2:P3 S Z=$P(Y,"^",L) I Z'="" S Q=$P(Y,"^",L+1) S:'Q Q=1 S:'$D(C(Z)) C(Z)=0 S C(Z)=C(Z)+Q + Q + ; +SF0 ;outpatient SFs + F FHDFN=0:0 S FHDFN=$O(^FHPT("RM",DT,FHDFN)) Q:FHDFN'>0 F ADM=0:0 S ADM=$O(^FHPT("RM",DT,FHDFN,ADM)) Q:ADM'>0 D + .S FHODAT=$G(^FHPT(FHDFN,"OP",ADM,0)),FHNO=$P($G(^FHPT(FHDFN,"OP",ADM,"SF",0)),U,3) Q:'$G(FHNO) + .S FHMEAL=$P(FHODAT,U,4),FHOWARD=$P(FHODAT,U,3) + .S X1=$G(^FH(119.6,FHOWARD,0)),WRDN=$P(X1,U,1) + .Q:'FHOWARD!'$D(^FH(119.6,FHOWARD,0)) + .I XX="W",W1 Q:W1'=FHOWARD + .I XX="S" S D2=$P(X1,"^",9) Q:D1'=D2 I D1=D2 S P0=$P(X1,"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0) + .S P1=$S(FHMEAL="N":13,FHMEAL="E":21,1:5) + .I (FHMEAL="B"),(TIM'=10) Q + .I (FHMEAL="N"),(TIM'=2) Q + .I (FHMEAL="E"),(TIM'=8) Q + .I 'D3 S IS=$P($G(^FHPT(FHDFN,0)),"^",5) I IS S IS=$P($G(^FH(119.4,IS,0)),"^",3) S:IS'="N" IS="" + .S Y=$G(^FHPT(FHDFN,"OP",ADM,"SF",FHNO,0)) + .S Y=$P(Y,"^",P1,P1+7) Q:Y?."^" I D3 D CLC1 + .S N1=N1+1 + .S RM="",RMIEN=$P(FHODAT,U,18) I $G(RMIEN),$D(^DG(405.4,RMIEN,0)) S RM=$E($P(^DG(405.4,RMIEN,0),U,1),1,10) + .I 'D3 D + ..D PATNAME^FHOMUTL + ..S $P(Y,"^",9)=IS + ..S LNOD=$S(XX="S":D2_"~"_$P($G(^FH(119.74,D2,0)),"^",1),1:P0_"~"_WRDN) + ..S RI="***" S RE=$S(RI:$O(^FH(119.6,"AR",+RI,W1,0)),1:"") + ..S R0=$S(RE:$P($G(^FH(119.6,W1,"R",+RE,0)),"^",2),1:"") + ..S R0=$S(R0<1:99,R0<10:"0"_R0,1:R0) + ..S PNOD=P0_"~"_R0_RM_"~"_FHDFN,WRD=P0_$E(WRDN,1,20-$L(RM))_"/"_RM + ..S ^TMP($J,"L",LNOD,PNOD)=Y_"^"_WRD + Q +CLC1 ; + F L=1:2:P3 S Z=$P(Y,"^",L) I Z'="" S Q=$P(Y,"^",L+1) S:'Q Q=1 S:'$D(C(Z)) C(Z)=0 S C(Z)=C(Z)+Q + Q diff --git a/r/DIETETICS-FH/FHOMPP.m b/r/DIETETICS-FH/FHOMPP.m index d875a897..e8b95550 100644 --- a/r/DIETETICS-FH/FHOMPP.m +++ b/r/DIETETICS-FH/FHOMPP.m @@ -1,80 +1,80 @@ -FHOMPP ; OIFO/RTK - Patient Profile for Outpatients ;7/2/2007 - ;;5.5;DIETETICS;**9**;Jan 28, 2005;Build 7 - D DEV Q -DEV ;get device and set up queue - W ! K %ZIS,IOP S %ZIS="Q" D ^%ZIS Q:POP - I '$D(IO("Q")) U IO D DISP,^%ZISC,END Q - S ZTRTN="DISP^FHOMPP" - S ZTSAVE("FHDFN")="" - S ZTDESC="Outpatient Meals Recurring Meals Display" D ^%ZTLOAD - D ^%ZISC K %ZIS,IOP - D END Q -DISP ; - S EX="" D HDR - D ALG^FHCLN I ALG'="" W !!,"Allergies: ",ALG - K ^TMP($J) F FHFP=0:0 S FHFP=$O(^FHPT(FHDFN,"P",FHFP)) Q:FHFP'>0 D - .S FHFPZN=$G(^FHPT(FHDFN,"P",FHFP,0)) - .S FHFPIEN=$P(FHFPZN,U,1),FHMEAL=$P(FHFPZN,U,2),FHQTY=$P(FHFPZN,U,3) - .Q:FHFPIEN="" - .S FHNORD=$S($L(FHMEAL)=3:1,$E(FHMEAL)="B":2,$E(FHMEAL)="N":3,1:4) - .S FHMEAL=FHNORD_FHMEAL - .S FHFPLD=$P($G(^FH(115.2,FHFPIEN,0)),U,2) Q:FHFPLD="" - .S FHFPNM=$P($G(^FH(115.2,FHFPIEN,0)),U,1) Q:FHFPNM="" - .S ^TMP($J,FHFPLD,FHMEAL,FHFPIEN)=FHQTY_" "_FHFPNM - .Q - W !!,"Food Preferences Currently on file: " - I $D(^TMP($J,"L")) W !!?20,"Likes" - S FHM="" F S FHM=$O(^TMP($J,"L",FHM)) Q:FHM=""!(EX=U) D - .F FHP=0:0 S FHP=$O(^TMP($J,"L",FHM,FHP)) Q:FHP'>0 W !!,^TMP($J,"L",FHM,FHP) I $Y>(IOSL-4) D PG I EX=U Q - I $D(^TMP($J,"D")) W !!?20,"Dislikes" - S FHM="" F S FHM=$O(^TMP($J,"D",FHM)) Q:FHM=""!(EX=U) D - .F FHP=0:0 S FHP=$O(^TMP($J,"D",FHM,FHP)) Q:FHP'>0 W !!,^TMP($J,"D",FHM,FHP) I $Y>(IOSL-4) D PG I EX=U Q - ; - S FHIPX=$P($G(^FHPT(FHDFN,0)),U,5) I FHIPX'="" W !!,"Isolation/Precaution type is ",$P($G(^FH(119.4,FHIPX,0)),"^",1) I $Y>(IOSL-4) D PG I EX=U Q - W !!,"Recurring Meals on File: " I $Y>(IOSL-4) D PG I EX=U Q - W ! S STDT=DT S FHPP=1 D DISP^FHOMRR1 K FHPP - I EX'=U,IOST?1"C".E W ! K DIR S DIR(0)="E" D ^DIR - Q -PG ; - I IOST?1"C".E W ! K DIR S DIR(0)="E" D ^DIR I 'Y S EX=U Q - D HDR Q -HDR ; - W:$Y @IOF - W !!,"OUTPATIENT NAME: " D PATNAME^FHOMUTL W FHPTNM," ",FHSSN - W ?65,FHSEX," Age ",FHAGE Q -END ; - K FHM,FHP,FHT Q - ; -CPRS ; Call from FHWOR71 to get outpatient profile for CPRS - ; Data is returned in ^TMP($J,"FHPROF",DFN,FHX) - S FHZ115="P"_DFN D CHECK^FHOMDPA I FHDFN="" Q "-1^Invalid outpatient" - K ^TMP($J,"FHPROF"),^TMP($J,"L"),^TMP($J,"D") S (FHX,N)=0 D PATNAME^FHOMUTL - S FHB="" F I=1:1:80 S FHB=FHB_" " - S ^TMP($J,"FHPROF",DFN,FHX)="OUTPATIENT NAME: "_FHPTNM_" "_FHSSN - S FHJ=66 D PAD^FHOMPP1 S ^TMP($J,"FHPROF",DFN,FHX)=^TMP($J,"FHPROF",DFN,FHX)_PAD_FHSEX_" Age "_FHAGE - D ALG^FHCLN I ALG'="" S N=1 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)="Allergies: "_ALG - F FHFP=0:0 S FHFP=$O(^FHPT(FHDFN,"P",FHFP)) Q:FHFP'>0 D - .S FHFPZN=$G(^FHPT(FHDFN,"P",FHFP,0)) - .S FHFPIEN=$P(FHFPZN,U,1),FHMEAL=$P(FHFPZN,U,2),FHQTY=$P(FHFPZN,U,3) - .Q:FHFPIEN="" - .S FHNORD=$S($L(FHMEAL)=3:1,$E(FHMEAL)="B":2,$E(FHMEAL)="N":3,1:4) - .S FHMEAL=FHNORD_FHMEAL - .S FHFPLD=$P($G(^FH(115.2,FHFPIEN,0)),U,2) Q:FHFPLD="" - .S FHFPNM=$P($G(^FH(115.2,FHFPIEN,0)),U,1) Q:FHFPNM="" - .S ^TMP($J,FHFPLD,FHMEAL,FHFPIEN)=FHQTY_" "_FHFPNM - .Q - S N=1 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)="Food Preferences Currently on file: " - I $D(^TMP($J,"L")) S N=1 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)="Likes" - S FHM="" F S FHM=$O(^TMP($J,"L",FHM)) Q:FHM="" D - .F FHP=0:0 S FHP=$O(^TMP($J,"L",FHM,FHP)) Q:FHP'>0 S N=0 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)=^TMP($J,"L",FHM,FHP) - I $D(^TMP($J,"D")) S N=1 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)="Dislikes" - S FHM="" F S FHM=$O(^TMP($J,"D",FHM)) Q:FHM="" D - .F FHP=0:0 S FHP=$O(^TMP($J,"D",FHM,FHP)) Q:FHP'>0 S N=0 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)=^TMP($J,"D",FHM,FHP) - ; - S N=1 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)="Recurring Meals on File: " - S STDT=DT D ^FHOMPP1 - Q -NEWL ;New line before next line of text in ^TMP global - I N=1 S FHX=FHX+1,^TMP($J,"FHPROF",DFN,FHX)=" " - S FHX=FHX+1 - Q +FHOMPP ; OIFO/RTK - Patient Profile for Outpatients ;6/23/03 1:04 + ;;5.5;DIETETICS;;Jan 28, 2005 + D DEV Q +DEV ;get device and set up queue + W ! K %ZIS,IOP S %ZIS="Q" D ^%ZIS Q:POP + I '$D(IO("Q")) U IO D DISP,^%ZISC,END Q + S ZTRTN="DISP^FHOMPP" + S ZTSAVE("FHDFN")="" + S ZTDESC="Outpatient Meals Recurring Meals Display" D ^%ZTLOAD + D ^%ZISC K %ZIS,IOP + D END Q +DISP ; + S EX="" D HDR + D ALG^FHCLN I ALG'="" W !!,"Allergies: ",ALG + K ^TMP($J) F FHFP=0:0 S FHFP=$O(^FHPT(FHDFN,"P",FHFP)) Q:FHFP'>0 D + .S FHFPZN=$G(^FHPT(FHDFN,"P",FHFP,0)) + .S FHFPIEN=$P(FHFPZN,U,1),FHMEAL=$P(FHFPZN,U,2),FHQTY=$P(FHFPZN,U,3) + .Q:FHFPIEN="" + .S FHNORD=$S($L(FHMEAL)=3:1,$E(FHMEAL)="B":2,$E(FHMEAL)="N":3,1:4) + .S FHMEAL=FHNORD_FHMEAL + .S FHFPLD=$P($G(^FH(115.2,FHFPIEN,0)),U,2) Q:FHFPLD="" + .S FHFPNM=$P($G(^FH(115.2,FHFPIEN,0)),U,1) Q:FHFPNM="" + .S ^TMP($J,FHFPLD,FHMEAL,FHFPIEN)=FHQTY_" "_FHFPNM + .Q + W !!,"Food Preferences Currently on file: " + I $D(^TMP($J,"L")) W !!?20,"Likes" + S FHM="" F S FHM=$O(^TMP($J,"L",FHM)) Q:FHM=""!(EX=U) D + .F FHP=0:0 S FHP=$O(^TMP($J,"L",FHM,FHP)) Q:FHP'>0 W !!,^TMP($J,"L",FHM,FHP) I $Y>(IOSL-4) D PG I EX=U Q + I $D(^TMP($J,"D")) W !!?20,"Dislikes" + S FHM="" F S FHM=$O(^TMP($J,"D",FHM)) Q:FHM=""!(EX=U) D + .F FHP=0:0 S FHP=$O(^TMP($J,"D",FHM,FHP)) Q:FHP'>0 W !!,^TMP($J,"D",FHM,FHP) I $Y>(IOSL-4) D PG I EX=U Q + ; + S FHIPX=$P($G(^FHPT(FHDFN,0)),U,5) I FHIPX'="" W !!,"Isolation/Precaution type is ",$P($G(^FH(119.4,FHIPX,0)),"^",1) I $Y>(IOSL-4) D PG I EX=U Q + W !!,"Recurring Meals on File: " I $Y>(IOSL-4) D PG I EX=U Q + W ! S STDT=DT S FHPP=1 D DISP^FHOMRR1 K FHPP + I EX'=U,IOST?1"C".E W ! K DIR S DIR(0)="E" D ^DIR + Q +PG ; + I IOST?1"C".E W ! K DIR S DIR(0)="E" D ^DIR I 'Y S EX=U Q + D HDR Q +HDR ; + W:$Y @IOF + W !!,"OUTPATIENT NAME: " D PATNAME^FHOMUTL W FHPTNM," ",FHSSN + W ?65,FHSEX," Age ",FHAGE Q +END ; + K FHM,FHP,FHT Q + ; +CPRS ; Call from FHWOR71 to get outpatient profile for CPRS + ; Data is returned in ^TMP($J,"FHPROF",DFN,FHX) + S FHZ115="P"_DFN D CHECK^FHOMDPA I FHDFN="" Q "-1^Invalid outpatient" + K ^TMP($J,"FHPROF",DFN) S (FHX,N)=0 D PATNAME^FHOMUTL + S FHB="" F I=1:1:80 S FHB=FHB_" " + S ^TMP($J,"FHPROF",DFN,FHX)="OUTPATIENT NAME: "_FHPTNM_" "_FHSSN + S FHJ=66 D PAD^FHOMPP1 S ^TMP($J,"FHPROF",DFN,FHX)=^TMP($J,"FHPROF",DFN,FHX)_PAD_FHSEX_" Age "_FHAGE + D ALG^FHCLN I ALG'="" S N=1 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)="Allergies: "_ALG + F FHFP=0:0 S FHFP=$O(^FHPT(FHDFN,"P",FHFP)) Q:FHFP'>0 D + .S FHFPZN=$G(^FHPT(FHDFN,"P",FHFP,0)) + .S FHFPIEN=$P(FHFPZN,U,1),FHMEAL=$P(FHFPZN,U,2),FHQTY=$P(FHFPZN,U,3) + .Q:FHFPIEN="" + .S FHNORD=$S($L(FHMEAL)=3:1,$E(FHMEAL)="B":2,$E(FHMEAL)="N":3,1:4) + .S FHMEAL=FHNORD_FHMEAL + .S FHFPLD=$P($G(^FH(115.2,FHFPIEN,0)),U,2) Q:FHFPLD="" + .S FHFPNM=$P($G(^FH(115.2,FHFPIEN,0)),U,1) Q:FHFPNM="" + .S ^TMP($J,FHFPLD,FHMEAL,FHFPIEN)=FHQTY_" "_FHFPNM + .Q + S N=1 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)="Food Preferences Currently on file: " + I $D(^TMP($J,"L")) S N=1 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)="Likes" + S FHM="" F S FHM=$O(^TMP($J,"L",FHM)) Q:FHM="" D + .F FHP=0:0 S FHP=$O(^TMP($J,"L",FHM,FHP)) Q:FHP'>0 S N=0 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)=^TMP($J,"L",FHM,FHP) Q + I $D(^TMP($J,"D")) S N=1 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)="Dislikes" + S FHM="" F S FHM=$O(^TMP($J,"D",FHM)) Q:FHM="" D + .F FHP=0:0 S FHP=$O(^TMP($J,"D",FHM,FHP)) Q:FHP'>0 S N=0 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)=^TMP($J,"D",FHM,FHP) Q + ; + S N=1 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)="Recurring Meals on File: " + S STDT=DT D ^FHOMPP1 + Q +NEWL ;New line before next line of text in ^TMP global + I N=1 S FHX=FHX+1,^TMP($J,"FHPROF",DFN,FHX)=" " + S FHX=FHX+1 + Q diff --git a/r/DIETETICS-FH/FHORC5.m b/r/DIETETICS-FH/FHORC5.m index 4b0b5360..60a50efd 100644 --- a/r/DIETETICS-FH/FHORC5.m +++ b/r/DIETETICS-FH/FHORC5.m @@ -1,22 +1,20 @@ -FHORC5 ; HISC/REL - Consult Management ;4/12/06 13:26 - ;;5.5;DIETETICS;**4,12**;Jan 28, 2005;Build 3 - ; 10/17/2007 BP/KAM FH*5.5*12 Rem Call 210883 Remove Old Clinician Field (#1) -EN9 ; Enter/Edit Ward Assignments - K DIC S (DIC,DIE)="^FH(119.6,",DIC(0)="AEQM" - W ! D ^DIC G KIL:U[X!$D(DTOUT),EN9:Y<1 S OLD=$S($P(Y,"^",3):"",1:$P(^FH(119.6,+Y,0),"^",2)) - ; 10/17/2007 BP/KAM *12 Rem Call 210883 Removed field #1 in next line - S DA=+Y,DR="112" D ^DIE S NEW=$P(^FH(119.6,DA,0),"^",2) I 'NEW!('OLD) K OLD,NEW,X,Y G EN9 - D:OLD'=NEW EN2^FHORC4 K OLD,NEW,X,Y G EN9 -EN10 ; List Ward Assignments - W ! S L=0,DIC="^FH(119.6,",FLDS="[FHORWRD]",BY=".01" - S (FR,TO)="",DHD="NUTRITION LOCATION ASSIGNMENTS" D EN1^DIP,RSET Q -EN11 ; Enter/Edit Consult Types - S (DIC,DIE)="^FH(119.5,",DIC(0)="AEQLM",DIC("DR")=".01",DLAYGO=119.5 - W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN11:Y<1 - S DA=+Y,DR=".01:2;S FHA1=X;3;S Y=$S(FHA1=""Y"":4,1:5);4;5:99" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.5 D ^DIE K DA,DIE,DIDEL,DR,FHA1 G EN11 -EN12 ; List Consult Types - W !!,"The list requires a 132 column printer.",! - W ! S L=0,DIC="^FH(119.5,",FLDS="[FHORCON]",BY=".01" - S (FR,TO)="",DHD="CONSULTATION TYPES" D EN1^DIP,RSET Q -RSET K %ZIS S IOP="" D ^%ZIS -KIL K %,%ZIS,IOP,BY,DA,DHD,DIC,DIE,DR,FLDS,FR,L,NEW,OLD,TO,X,Y Q +FHORC5 ; HISC/REL - Consult Management ;4/12/06 13:26 + ;;5.5;DIETETICS;**4**;Jan 28, 2005;Build 32 +EN9 ; Enter/Edit Ward Assignments + K DIC S (DIC,DIE)="^FH(119.6,",DIC(0)="AEQM" + W ! D ^DIC G KIL:U[X!$D(DTOUT),EN9:Y<1 S OLD=$S($P(Y,"^",3):"",1:$P(^FH(119.6,+Y,0),"^",2)) + S DA=+Y,DR="1;112" D ^DIE S NEW=$P(^FH(119.6,DA,0),"^",2) I 'NEW!('OLD) K OLD,NEW,X,Y G EN9 + D:OLD'=NEW EN2^FHORC4 K OLD,NEW,X,Y G EN9 +EN10 ; List Ward Assignments + W ! S L=0,DIC="^FH(119.6,",FLDS="[FHORWRD]",BY=".01" + S (FR,TO)="",DHD="NUTRITION LOCATION ASSIGNMENTS" D EN1^DIP,RSET Q +EN11 ; Enter/Edit Consult Types + S (DIC,DIE)="^FH(119.5,",DIC(0)="AEQLM",DIC("DR")=".01",DLAYGO=119.5 + W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN11:Y<1 + S DA=+Y,DR=".01:2;S FHA1=X;3;S Y=$S(FHA1=""Y"":4,1:5);4;5:99" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.5 D ^DIE K DA,DIE,DIDEL,DR,FHA1 G EN11 +EN12 ; List Consult Types + W !!,"The list requires a 132 column printer.",! + W ! S L=0,DIC="^FH(119.5,",FLDS="[FHORCON]",BY=".01" + S (FR,TO)="",DHD="CONSULTATION TYPES" D EN1^DIP,RSET Q +RSET K %ZIS S IOP="" D ^%ZIS +KIL K %,%ZIS,IOP,BY,DA,DHD,DIC,DIE,DR,FLDS,FR,L,NEW,OLD,TO,X,Y Q diff --git a/r/DIETETICS-FH/FHPRO.m b/r/DIETETICS-FH/FHPRO.m index d9f7e915..8fb22e6a 100644 --- a/r/DIETETICS-FH/FHPRO.m +++ b/r/DIETETICS-FH/FHPRO.m @@ -1,52 +1,47 @@ -FHPRO ; HISC/REL/RTK - Food Production Manager ;4/12/06 15:53 - ;;5.5;DIETETICS;**4,5,12**;Jan 28, 2005;Build 3 - ; - ; 10/16/2007 BY/KAM FH*5.5*12 Rem Call 210883 Remove access to old - ; Clinician field -EN2 ; Enter/Edit Nutrition Locations (Inpatient Wards/Outpatient Clinics) - W ! K DIR,DIC S DIR("A")="Select WARD or OUTPATIENT Location: " - S DIR(0)="SAO^W:Ward Location;O:Outpatient Location" D ^DIR I $D(DIRUT) G KIL - I Y'=-1 S FHANS=Y - I FHANS="W" D EN2WRD Q - I FHANS="O" D EN2OL Q - Q -EN2WRD ;Ward locations - K DIC S (DIC,DIE)="^FH(119.6,",DIC(0)="AEQLM",DLAYGO=119.6 - S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN2:Y<1 - ; S DR=".01;2:2.5;... POTENTIAL CHG FOR 210883 WAS S DR=".01:2.5;3" - ; 10/16/2007 BP/KAM FH*5.5*12 changed next line to remove access to field # 1 Clinician (Old Clinician field) - S DA=+Y,DR=".01;2:2.5;3;S:X="""" Y=4;3.5;4;S:X="""" Y=5;4.5;5;S:'X Y=6;5.5;6:29;99;107;107.5;108;108.5;109;109.5;110;110.5;111;111.5;112" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.6 D ^DIE,KIL G EN2 -EN2OL ;Outpatient locations - K DIC S (DIC,DIE)="^FH(119.6,",DIC(0)="AEQLM",DLAYGO=119.6 - S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN2:Y<1 - S DA=+Y,DR=".01;2;2.6;3;S:X="""" Y=4;3.5;4;S:X="""" Y=5;4.5;5;S:'X Y=6;5.5;6;7;103:106;11;20:99;107;107.5;108;108.5;109;109.5;110;110.5;111;111.5;112" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.6 D ^DIE,KIL G EN2 -EN3 ; Enter/Edit Production Diets - K DIC S (DIC,DIE)="^FH(116.2,",DIC(0)="AEQLM",DLAYGO=116.2 - S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN3:Y<1 - S DA=+Y,DR=$S(DA=1:"1:8",1:".01:7.5;10;S:X'=""Y"" Y=8;11;8;12:99") S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=116.2 D ^DIE I '$D(DA) D KIL G EN3 - S:$O(^FH(116.2,DA,"R",0))<1 $P(^FH(116.2,DA,0),"^",4)="N" D KIL G EN3 -EN4 ; List Production Diets - W !!,"The list requires a 132 column printer.",! - W ! S L=0,DIC="^FH(116.2,",FLDS="[FHPROD]",BY="8,.01" - S FR="@",TO="",DHD="PRODUCTION DIETS" D EN1^DIP,RSET Q -EN5 ; Enter/Edit Production Facilities - K DIC S (DIC,DIE)="^FH(119.71,",DIC(0)="AEQLM",DLAYGO=119.71 - S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN5:Y<1 - S DA=+Y,DR=".01:99" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.71 D ^DIE,KIL G EN5 -EN6 ; Enter/Edit Service Points - K DIC S (DIC,DIE)="^FH(119.72,",DIC(0)="AEQLM",DLAYGO=119.72 - S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN6:Y<1 - S DA=+Y S DR=".01:99" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.72 D ^DIE I '$D(DA) D KIL G EN6 - S DA(1)=DA S DIK="^FH(119.72,DA(1),""A""," F DA=0:0 S DA=$O(^FH(119.72,DA(1),"A",DA)) Q:DA'>0 I $P($G(^(DA,0)),"^",2,8)?."^" D ^DIK - S DIK="^FH(119.72,DA(1),""B""," F DA=0:0 S DA=$O(^FH(119.72,DA(1),"B",DA)) Q:DA'>0 I $P($G(^(DA,0)),"^",2,22)?."^" D ^DIK - D KIL G EN6 -EN7 ; Enter/Edit Communication Offices - K DIC S (DIC,DIE)="^FH(119.73,",DIC(0)="AEQLM",DLAYGO=119.73 - S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN7:Y<1 - S DA=+Y,DR=".01:99" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.73 D ^DIE,KIL G EN7 -EN8 ; Enter/Edit Supplemental Feeding Sites - K DIC S (DIC,DIE)="^FH(119.74,",DIC(0)="AEQLM",DLAYGO=119.74 - S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN8:Y<1 - S DA=+Y,DR=".01:99" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.74 D ^DIE,KIL G EN8 -RSET K %ZIS S IOP="" D ^%ZIS -KIL G KILL^XUSCLEAN +FHPRO ; HISC/REL/RTK - Food Production Manager ;4/12/06 15:53 + ;;5.5;DIETETICS;**4,5**;Jan 28, 2005;Build 53 +EN2 ; Enter/Edit Nutrition Locations (Inpatient Wards/Outpatient Clinics) + W ! K DIR,DIC S DIR("A")="Select WARD or OUTPATIENT Location: " + S DIR(0)="SAO^W:Ward Location;O:Outpatient Location" D ^DIR Q:$D(DIRUT) + I Y'=-1 S FHANS=Y + I FHANS="W" D EN2WRD Q + I FHANS="O" D EN2OL Q + Q +EN2WRD ;Ward locations + K DIC S (DIC,DIE)="^FH(119.6,",DIC(0)="AEQLM",DLAYGO=119.6 + S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN2:Y<1 + S DA=+Y,DR=".01:2.5;3;S:X="""" Y=4;3.5;4;S:X="""" Y=5;4.5;5;S:'X Y=6;5.5;6:29;99;107;107.5;108;108.5;109;109.5;110;110.5;111;111.5;112" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.6 D ^DIE,KIL G EN2 +EN2OL ;Outpatient locations + K DIC S (DIC,DIE)="^FH(119.6,",DIC(0)="AEQLM",DLAYGO=119.6 + S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN2:Y<1 + S DA=+Y,DR=".01;2;2.6;3;S:X="""" Y=4;3.5;4;S:X="""" Y=5;4.5;5;S:'X Y=6;5.5;6;7;103:106;11;20:99;107;107.5;108;108.5;109;109.5;110;110.5;111;111.5;112" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.6 D ^DIE,KIL G EN2 +EN3 ; Enter/Edit Production Diets + K DIC S (DIC,DIE)="^FH(116.2,",DIC(0)="AEQLM",DLAYGO=116.2 + S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN3:Y<1 + S DA=+Y,DR=$S(DA=1:"1:8",1:".01:7.5;10;S:X'=""Y"" Y=8;11;8;12:99") S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=116.2 D ^DIE I '$D(DA) D KIL G EN3 + S:$O(^FH(116.2,DA,"R",0))<1 $P(^FH(116.2,DA,0),"^",4)="N" D KIL G EN3 +EN4 ; List Production Diets + W !!,"The list requires a 132 column printer.",! + W ! S L=0,DIC="^FH(116.2,",FLDS="[FHPROD]",BY="8,.01" + S FR="@",TO="",DHD="PRODUCTION DIETS" D EN1^DIP,RSET Q +EN5 ; Enter/Edit Production Facilities + K DIC S (DIC,DIE)="^FH(119.71,",DIC(0)="AEQLM",DLAYGO=119.71 + S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN5:Y<1 + S DA=+Y,DR=".01:99" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.71 D ^DIE,KIL G EN5 +EN6 ; Enter/Edit Service Points + K DIC S (DIC,DIE)="^FH(119.72,",DIC(0)="AEQLM",DLAYGO=119.72 + S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN6:Y<1 + S DA=+Y S DR=".01:99" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.72 D ^DIE I '$D(DA) D KIL G EN6 + S DA(1)=DA S DIK="^FH(119.72,DA(1),""A""," F DA=0:0 S DA=$O(^FH(119.72,DA(1),"A",DA)) Q:DA'>0 I $P($G(^(DA,0)),"^",2,8)?."^" D ^DIK + S DIK="^FH(119.72,DA(1),""B""," F DA=0:0 S DA=$O(^FH(119.72,DA(1),"B",DA)) Q:DA'>0 I $P($G(^(DA,0)),"^",2,22)?."^" D ^DIK + D KIL G EN6 +EN7 ; Enter/Edit Communication Offices + K DIC S (DIC,DIE)="^FH(119.73,",DIC(0)="AEQLM",DLAYGO=119.73 + S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN7:Y<1 + S DA=+Y,DR=".01:99" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.73 D ^DIE,KIL G EN7 +EN8 ; Enter/Edit Supplemental Feeding Sites + K DIC S (DIC,DIE)="^FH(119.74,",DIC(0)="AEQLM",DLAYGO=119.74 + S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN8:Y<1 + S DA=+Y,DR=".01:99" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.74 D ^DIE,KIL G EN8 +RSET K %ZIS S IOP="" D ^%ZIS +KIL G KILL^XUSCLEAN diff --git a/r/DIETETICS-FH/FHPRW.m b/r/DIETETICS-FH/FHPRW.m index 5f6a370e..4ae6e080 100644 --- a/r/DIETETICS-FH/FHPRW.m +++ b/r/DIETETICS-FH/FHPRW.m @@ -1,76 +1,70 @@ -FHPRW ;Hines OIFO/REL,RTK - List Dietetic Locations ;5/13/94 14:57 - ;;5.5;DIETETICS;**12**;Jan 28, 2005;Build 3 - ; 10/24/07 BAY/KAM FH*5.5*12 CALL 214407 Display new Clinician Field -F1 R !!,"Select LOCATION (or ALL): ",X:DTIME G:'$T!("^"[X) KIL D:X="all" TR^FH I X="ALL" S WRD=0 - E K DIC S DIC="^FH(119.6,",DIC(0)="EQM" D ^DIC K DIC G:Y<1 F1 S WRD=+Y - I 'WRD W !!,"Verifying completeness of room-bed & ward assignments ..." D VER - W ! K IOP,%ZIS S %ZIS("A")="Select LIST Printer: ",%ZIS="MQ" D ^%ZIS K %ZIS,IOP G:POP KIL - I $D(IO("Q")) S FHPGM="Q1^FHPRW",FHLST="WRD" D EN2^FH G KIL - U IO D Q1 D ^%ZISC K %ZIS,IOP G KIL -Q1 ; Print Dietetic Ward Profile - K ^TMP($J) D NOW^%DTC S NOW=%,PG=0 I WRD S K1=WRD D Q2 W ! Q - F NX=0:0 S NX=$O(^FH(119.6,NX)) Q:NX<1 S X=$G(^(NX,0)),P0=$P(X,"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0),WRDN=$P(X,"^",1),^TMP($J,"FHW",P0_"~"_WRDN)=NX - S NX="" F S NX=$O(^TMP($J,"FHW",NX)) Q:NX="" S K1=+$G(^(NX)) I K1 D Q2 - W ! Q -Q2 S X=^FH(119.6,K1,0),NODE1=$G(^FH(119.6,K1,1)) D BLD,HDR - W !!,"Print Order:",?22,$P(X,"^",4) - W !,"Type of Location:",?22,$S($P(X,U,3)="O":"OUTPATIENT",1:"INPATIENT") - ; - ;10/24/07 BAY/KAM *12 214407 Print new Clinician Multiple field - N C1 S C1="" - F S C1=$O(^FH(119.6,K1,2,C1)) Q:C1="" D - . S Z=$G(^FH(119.6,K1,2,C1,0)) I Z W !,"Assigned Clinician(s):",?22,$P($G(^VA(200,Z,0)),"^",1) - ; - W !,"Tray Assembly:",?22 S Z=$P(X,"^",5) I Z W $P($G(^FH(119.72,Z,0)),"^",1) S Z=$P(X,"^",17) S:Z="" Z=100 W " (",Z,"%)" - W !,"Cafeteria:",?22 S Z=$P(X,"^",6) I Z W $P($G(^FH(119.72,Z,0)),"^",1) S Z=$P(X,"^",18) S:Z="" Z=100 W " (",Z,"%)" - W !,"Dining Room:",?22 S Z=$P(X,"^",7) I Z W "Yes" S Z=$P(X,"^",19) S:Z="" Z=100 W " (",Z,"%)" - W !,"Supplemental Fdgs.:",?22 S Z=$P(X,"^",9) I Z W $P($G(^FH(119.74,Z,0)),"^",1) - W !,"Diet Communication:",?22 S Z=$P(X,"^",8) I Z W $P($G(^FH(119.73,Z,0)),"^",1) - W !!,"Admission Diet:",?22 S Z=$P(X,"^",15) I Z W $P($G(^FH(111,Z,0)),"^",1) - E I $P(X,"^",16)="Y" W "NO ORDER" - W !!,"Review Frequencies:" - W !!?5,"NPO's:" S Z=$P(X,"^",11) W:Z ?19,$J(Z,3,0)," days" - W ?45,"Admit Status:" S Z=$P(X,"^",14) W:Z ?59,$J(Z,3,0)," days" - W !?5,"Tubefeedings:" S Z=$P(X,"^",12) W:Z ?19,$J(Z,3,0)," days" - W ?45,"Supp. Fdgs.:" S Z=$P(X,"^",13) W:Z ?59,$J(Z,3,0)," days" - W !!?5,"Status I:" S Z=$P(X,"^",20) W:Z ?19,$J(Z,3,0)," days" - W ?45,"Status III:" S Z=$P(X,"^",22) W:Z ?59,$J(Z,3,0)," days" - W !?5,"Status II:" S Z=$P(X,"^",21) W:Z ?19,$J(Z,3,0)," days" - W ?45,"Status IV:" S Z=$P(X,"^",23) W:Z ?59,$J(Z,3,0)," days" - S FHY=$P(X,"^",24) W !!,"Bulk Nourishment Orders:",! - K P S N=0,NM="" F S NM=$O(^TMP($J,"B",NM)) Q:NM="" S N=N+1,P(N)=$J(^(NM),3,0)_" "_$P(NM,"~",1) - I N S (Z,K)=N+1\2 F LL=1:1:Z W !?5,P(LL) S K=K+1 I $D(P(K)) W ?45,P(K) - W !!,"Room-Beds Assigned:",! - K P S N=0,NM="" F S NM=$O(^TMP($J,"R",NM)) Q:NM="" S N=N+1,P(N)=$P(NM,"~",1) - I N S Z=N+3\4 S K(22)=Z,K(39)=2*Z,K(54)=3*Z F LL=1:1:Z W !?5,P(LL) F MM=22,39,54 S K(MM)=K(MM)+1 I $D(P(K(MM))) W ?MM,P(K(MM)) - W !!,"Default MAS Wards:",! - K P S N=0,NM="" F S NM=$O(^TMP($J,"W",NM)) Q:NM="" S N=N+1,P(N)=$P(NM,"~",1) - I N S (Z,K)=N+1\2 F LL=1:1:Z W !?5,P(LL) S K=K+1 I $D(P(K)) W ?45,P(K) - W !!,"Print Cafeteria on Tray Tickets: ",$S(FHY="Y":"YES",1:"NO") - S FHOL=$P(NODE1,U,1),FHOLFIL=$S(FHOL["SC(":44,FHOL["DIC(42":42,1:0) - S FHOLNM="" I FHOLFIL D - .S FHOLIEN=$P(FHOL,";",1) - .I FHOLFIL=42 S FHOLNM=$P($G(^DIC(42,FHOLIEN,0)),U,1) - .I FHOLFIL=44 S FHOLNM=$P($G(^SC(FHOLIEN,0)),U,1) - .W !!,"Outpatient Location: ",FHOLNM,! - W !,"Maximum # of Days to Schedule Recurring Meal: ",$P(NODE1,U,2) - W !,"Number of Days for Review of Recurring Meal: ",$P(NODE1,U,3) - W !!,"Non-VA Facility? ",$S($P(NODE1,U,4)="Y":"YES",1:"NO") - W ! Q -BLD ; Build temp files - K ^TMP($J,"B"),^TMP($J,"R"),^TMP($J,"W") - F LL=0:0 S LL=$O(^FH(119.6,K1,"BN",LL)) Q:LL<1 S Y=^(LL,0) D B1 - F LL=0:0 S LL=$O(^FH(119.6,K1,"W",LL)) Q:LL<1 S Y=^(LL,0) D B2 - F LL=0:0 S LL=$O(^FH(119.6,K1,"R",LL)) Q:LL<1 S Y=^(LL,0) D B3 - Q -B1 S N=+Y,Q=$P(Y,"^",2) Q:'N!('Q) S N=$P($G(^FH(118,N,0)),"^",1) Q:N="" S ^TMP($J,"B",N_"~"_(+Y))=Q Q -B2 S N=$P($G(^DIC(42,+Y,0)),"^",1) Q:N="" S ^TMP($J,"W",N_"~"_(+Y))="" Q -B3 S N=$P($G(^DG(405.4,+Y,0)),"^",1) Q:N="" S ^TMP($J,"R",N_"~"_(+Y))="" Q -HDR W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1,DTP=NOW D DTP^FH W !,$E(DTP,1,9),?19,"D I E T E T I C L O C A T I O N P R O F I L E",?73,"Page ",PG - S Y=$P(X,"^",1) W !!?(78-$L(Y)\2),Y - W !,"-------------------------------------------------------------------------------",! Q -VER ; Verify completeness of data base - F LL=0:0 S LL=$O(^DG(405.4,LL)) Q:LL'>0 I '$D(^FH(119.6,"AR",LL)) W !,"Room ",$P(^DG(405.4,LL,0),"^",1)," not assigned to any Dietetic Ward" - F LL=0:0 S LL=$O(^DIC(42,LL)) Q:LL'>0 I $G(^DIC(42,LL,"ORDER")),'$D(^FH(119.6,"AW",LL)) W !,"MAS Ward ",$P(^DIC(42,LL,0),"^",1)," not assigned to any Dietetics Ward" - Q -KIL K ^TMP($J) G KILL^XUSCLEAN +FHPRW ;Hines OIFO/REL,RTK - List Dietetic Locations ;5/13/94 14:57 + ;;5.5;DIETETICS;;Jan 28, 2005 +F1 R !!,"Select LOCATION (or ALL): ",X:DTIME G:'$T!("^"[X) KIL D:X="all" TR^FH I X="ALL" S WRD=0 + E K DIC S DIC="^FH(119.6,",DIC(0)="EQM" D ^DIC K DIC G:Y<1 F1 S WRD=+Y + I 'WRD W !!,"Verifying completeness of room-bed & ward assignments ..." D VER + W ! K IOP,%ZIS S %ZIS("A")="Select LIST Printer: ",%ZIS="MQ" D ^%ZIS K %ZIS,IOP G:POP KIL + I $D(IO("Q")) S FHPGM="Q1^FHPRW",FHLST="WRD" D EN2^FH G KIL + U IO D Q1 D ^%ZISC K %ZIS,IOP G KIL +Q1 ; Print Dietetic Ward Profile + K ^TMP($J) D NOW^%DTC S NOW=%,PG=0 I WRD S K1=WRD D Q2 W ! Q + F NX=0:0 S NX=$O(^FH(119.6,NX)) Q:NX<1 S X=$G(^(NX,0)),P0=$P(X,"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0),WRDN=$P(X,"^",1),^TMP($J,"FHW",P0_"~"_WRDN)=NX + S NX="" F S NX=$O(^TMP($J,"FHW",NX)) Q:NX="" S K1=+$G(^(NX)) I K1 D Q2 + W ! Q +Q2 S X=^FH(119.6,K1,0),NODE1=$G(^FH(119.6,K1,1)) D BLD,HDR + W !!,"Print Order:",?22,$P(X,"^",4) + W !,"Type of Location:",?22,$S($P(X,U,3)="O":"OUTPATIENT",1:"INPATIENT") + W !,"Assigned Clinician:",?22 S Z=$P(X,"^",2) I Z W $P($G(^VA(200,Z,0)),"^",1) + W !,"Tray Assembly:",?22 S Z=$P(X,"^",5) I Z W $P($G(^FH(119.72,Z,0)),"^",1) S Z=$P(X,"^",17) S:Z="" Z=100 W " (",Z,"%)" + W !,"Cafeteria:",?22 S Z=$P(X,"^",6) I Z W $P($G(^FH(119.72,Z,0)),"^",1) S Z=$P(X,"^",18) S:Z="" Z=100 W " (",Z,"%)" + W !,"Dining Room:",?22 S Z=$P(X,"^",7) I Z W "Yes" S Z=$P(X,"^",19) S:Z="" Z=100 W " (",Z,"%)" + W !,"Supplemental Fdgs.:",?22 S Z=$P(X,"^",9) I Z W $P($G(^FH(119.74,Z,0)),"^",1) + W !,"Diet Communication:",?22 S Z=$P(X,"^",8) I Z W $P($G(^FH(119.73,Z,0)),"^",1) + W !!,"Admission Diet:",?22 S Z=$P(X,"^",15) I Z W $P($G(^FH(111,Z,0)),"^",1) + E I $P(X,"^",16)="Y" W "NO ORDER" + W !!,"Review Frequencies:" + W !!?5,"NPO's:" S Z=$P(X,"^",11) W:Z ?19,$J(Z,3,0)," days" + W ?45,"Admit Status:" S Z=$P(X,"^",14) W:Z ?59,$J(Z,3,0)," days" + W !?5,"Tubefeedings:" S Z=$P(X,"^",12) W:Z ?19,$J(Z,3,0)," days" + W ?45,"Supp. Fdgs.:" S Z=$P(X,"^",13) W:Z ?59,$J(Z,3,0)," days" + W !!?5,"Status I:" S Z=$P(X,"^",20) W:Z ?19,$J(Z,3,0)," days" + W ?45,"Status III:" S Z=$P(X,"^",22) W:Z ?59,$J(Z,3,0)," days" + W !?5,"Status II:" S Z=$P(X,"^",21) W:Z ?19,$J(Z,3,0)," days" + W ?45,"Status IV:" S Z=$P(X,"^",23) W:Z ?59,$J(Z,3,0)," days" + S FHY=$P(X,"^",24) W !!,"Bulk Nourishment Orders:",! + K P S N=0,NM="" F S NM=$O(^TMP($J,"B",NM)) Q:NM="" S N=N+1,P(N)=$J(^(NM),3,0)_" "_$P(NM,"~",1) + I N S (Z,K)=N+1\2 F LL=1:1:Z W !?5,P(LL) S K=K+1 I $D(P(K)) W ?45,P(K) + W !!,"Room-Beds Assigned:",! + K P S N=0,NM="" F S NM=$O(^TMP($J,"R",NM)) Q:NM="" S N=N+1,P(N)=$P(NM,"~",1) + I N S Z=N+3\4 S K(22)=Z,K(39)=2*Z,K(54)=3*Z F LL=1:1:Z W !?5,P(LL) F MM=22,39,54 S K(MM)=K(MM)+1 I $D(P(K(MM))) W ?MM,P(K(MM)) + W !!,"Default MAS Wards:",! + K P S N=0,NM="" F S NM=$O(^TMP($J,"W",NM)) Q:NM="" S N=N+1,P(N)=$P(NM,"~",1) + I N S (Z,K)=N+1\2 F LL=1:1:Z W !?5,P(LL) S K=K+1 I $D(P(K)) W ?45,P(K) + W !!,"Print Cafeteria on Tray Tickets: ",$S(FHY="Y":"YES",1:"NO") + S FHOL=$P(NODE1,U,1),FHOLFIL=$S(FHOL["SC(":44,FHOL["DIC(42":42,1:0) + S FHOLNM="" I FHOLFIL D + .S FHOLIEN=$P(FHOL,";",1) + .I FHOLFIL=42 S FHOLNM=$P($G(^DIC(42,FHOLIEN,0)),U,1) + .I FHOLFIL=44 S FHOLNM=$P($G(^SC(FHOLIEN,0)),U,1) + .W !!,"Outpatient Location: ",FHOLNM,! + W !,"Maximum # of Days to Schedule Recurring Meal: ",$P(NODE1,U,2) + W !,"Number of Days for Review of Recurring Meal: ",$P(NODE1,U,3) + W !!,"Non-VA Facility? ",$S($P(NODE1,U,4)="Y":"YES",1:"NO") + W ! Q +BLD ; Build temp files + K ^TMP($J,"B"),^TMP($J,"R"),^TMP($J,"W") + F LL=0:0 S LL=$O(^FH(119.6,K1,"BN",LL)) Q:LL<1 S Y=^(LL,0) D B1 + F LL=0:0 S LL=$O(^FH(119.6,K1,"W",LL)) Q:LL<1 S Y=^(LL,0) D B2 + F LL=0:0 S LL=$O(^FH(119.6,K1,"R",LL)) Q:LL<1 S Y=^(LL,0) D B3 + Q +B1 S N=+Y,Q=$P(Y,"^",2) Q:'N!('Q) S N=$P($G(^FH(118,N,0)),"^",1) Q:N="" S ^TMP($J,"B",N_"~"_(+Y))=Q Q +B2 S N=$P($G(^DIC(42,+Y,0)),"^",1) Q:N="" S ^TMP($J,"W",N_"~"_(+Y))="" Q +B3 S N=$P($G(^DG(405.4,+Y,0)),"^",1) Q:N="" S ^TMP($J,"R",N_"~"_(+Y))="" Q +HDR W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1,DTP=NOW D DTP^FH W !,$E(DTP,1,9),?19,"D I E T E T I C L O C A T I O N P R O F I L E",?73,"Page ",PG + S Y=$P(X,"^",1) W !!?(78-$L(Y)\2),Y + W !,"-------------------------------------------------------------------------------",! Q +VER ; Verify completeness of data base + F LL=0:0 S LL=$O(^DG(405.4,LL)) Q:LL'>0 I '$D(^FH(119.6,"AR",LL)) W !,"Room ",$P(^DG(405.4,LL,0),"^",1)," not assigned to any Dietetic Ward" + F LL=0:0 S LL=$O(^DIC(42,LL)) Q:LL'>0 I $G(^DIC(42,LL,"ORDER")),'$D(^FH(119.6,"AW",LL)) W !,"MAS Ward ",$P(^DIC(42,LL,0),"^",1)," not assigned to any Dietetics Ward" + Q +KIL K ^TMP($J) G KILL^XUSCLEAN diff --git a/r/DIETETICS-FH/FHREP1.m b/r/DIETETICS-FH/FHREP1.m index cd437136..a22f897a 100644 --- a/r/DIETETICS-FH/FHREP1.m +++ b/r/DIETETICS-FH/FHREP1.m @@ -1,86 +1,86 @@ -FHREP1 ; HISC/NCA - Inventory Worksheet and Report ;3/9/95 08:28 - ;;5.5;DIETETICS;**13**;Jan 28, 2005;Build 1 -EN2 ; Print the Inventory Worksheet & Report - S FHXX="F" - R !!,"Select W=Worksheet or R=Report: ",FHR:DTIME G:'$T!("^"[FHR) KIL^FHREP - I "wr"[FHR S X=FHR D TR^FH S FHR=X - I FHR'?1U!("WR"'[FHR) W *7," Enter W or R" G EN2 -E0 ; Read in Month and Year - D NOW^%DTC S NOW=%\1 - K %DT W !!,"Enter Mth/Yr: "_+$E(NOW,4,5)_"/"_$E(NOW,2,3)_"// " R X:DTIME G:'$T!(X["^") KIL^FHREP - I X="" S X=$E(NOW,1,5)_"00" - S %DT="M" D ^%DT K %DT I Y<1!($E(Y,1,5)>$E(NOW,1,5)) W *7," Answer Month and Yr as Mth/Yr or Mth Yr.",!?25," CANNOT be greater than now." G E0 - S MTH=+$E(Y,4,5),MTH=$P("January February March April May June July August September October November December"," ",MTH),YR=$E(Y,2,3),MTH=MTH_" "_YR - I FHR="W" D F1^FHREP G:FHXX["^"!("^"[X) KIL^FHREP - I FHR="R" D D1^FHREP G:"^"[X KIL^FHREP -E1 K IOP S %ZIS="MQ",%ZIS("B")="HOME" W ! D ^%ZIS K %ZIS,IOP G:POP KIL^FHREP - I $D(IO("Q")) S FHPGM="Q0^FHREP1",FHLST="FHR^FHXX^MTH^SRT" D EN2^FH G KIL^FHREP - U IO D Q0 D ^%ZISC K %ZIS,IOP G KIL^FHREP -Q0 ; Process Printing worksheet or report - D Q1 G KIL^FHREP -Q1 ; Loop through Ingredients - K ^TMP($J) S ANS="",(K,GRDTOT,OLD,SUBTOT,TOTAL,PG)=0 D NOW^%DTC S DTP=% D DTP^FH S HD=DTP S CK=1 - F K=0:0 S K=$O(^FHING(K)) Q:K<1 S X=$P($G(^(K,0)),"^",19) I X="Y" S X=$G(^(0)) D LP S:OK ^TMP($J,P0_$S(FHXX="S":$E(L0,1,15),1:"FG"_P0),ING)=K_"^"_UP_"^"_COST_"^"_QOH_"^"_UDC_"^"_UDQ_"^"_$E(MIN,1,5) - S REC=0 - S P0="" F L1=0:0 S P0=$O(^TMP($J,P0)) Q:P0=""!(ANS="^") S ING="" F L2=0:0 S ING=$O(^TMP($J,P0,ING)) Q:ING="" S XX=^(ING) D P1 Q:ANS="^" - I FHR="R",ANS="",SRT W !!,?55,"TOTAL: ",$J(SUBTOT,8,2) - I FHR="R",ANS="",'SRT D SUB W !!?49,"GRAND TOTAL: ",$J(GRDTOT,8,2) - Q -LP ; Get Food Group or Storage - S ING=$P(X,"^",1),UP=$P(X,"^",5),COST=$P(X,"^",9),QOH=$P(X,"^",11),UDC=$P(X,"^",23),UDQ=$P(X,"^",24),MIN=$P(X,"^",25),OK=1,L0="" - S DTP=UDC D:DTP'="" DTP^FH S UDC=DTP,DTP=UDQ D:DTP'="" DTP^FH S UDQ=DTP - I FHXX="F" S P0=$P(X,"^",13) S:P0<1!(P0>6) P0=7 S:SRT&(P0'=SRT) OK=0 Q - S LOC=$P(X,"^",12),L0=$P($G(^FH(113.1,+LOC,0)),"^",1) S:L0="" L0="UNCLASSIFIED" S P0=$P($G(^FH(113.1,+LOC,0)),"^",3),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0) S:SRT&(LOC'=SRT) OK=0 - Q -P1 ; Loop to print or if FHR="E" edit QOH - S K=$P(XX,"^",1),UP=$P(XX,"^",2),COST=$P(XX,"^",3),QOH=$P(XX,"^",4),UDC=$P(XX,"^",5),UDQ=$P(XX,"^",6),MIN=$P(XX,"^",7),REC=REC+1 - I FHR="E" D Q - .W !!,"Ingredient: ",$P(^FHING(K,0),"^",1) - .W:UDQ'="" !?12,"QOH LAST UPDATED ON ",UDQ,! - .K DIE S DIE="^FHING(",DA=K - .S:OKAY DR="8;S:X=COST Y=""@1"";29////"_DT_";@1;10;S:X=QOH Y="""";30////"_DT - .S:'OKAY DR="10;S:X=QOH Y="""";30////"_DT D ^DIE S:$D(DTOUT) CK=0 S:$D(Y)!$D(DTOUT) ANS="^" K DA,DIE,DR,DTOUT,Y - .Q - D CHK Q:ANS="^" - D:$Y'<(IOSL-5) HD W ! Q:ANS="^" - I $L(ING)'>30 D - .W !,$J(MIN,5),?6,ING,?39,UP,?43,$J(COST,8,3) - .I FHR="W" W ?53,UDC,?63,$J(QOH,8,2),?73,"_____" Q - .W ?55,$J(QOH,8,2),?64,$J(TOTAL,8,2) - .Q - E D - .S L=$L($E(ING,1,30),",") - .S:L=1 L=L+1 W !,$J(MIN,5),?6,$P(ING,",",1,L-1),"," - .W !?6,$P(ING,",",L,99),?39,UP,?43,$J(COST,8,3) - .I FHR="W" W ?53,UDC,?63,$J(QOH,8,2),?73,"_____" Q - .W ?55,$J(QOH,8,2),?64,$J(TOTAL,8,2) - .Q - Q -CHK ; Check the Food Group or Storage to do Subtotal & Grandtotal - S P1=$S(FHXX="F":+P0,1:$E(P0,3,17)) - I REC=1 S OLD=P1 D HDR - I OLD'=P1 D:FHR="R" SUB D HD - S OLD=P1 - ; Calculate subtotal grand total - Q:FHR'="R" - S TOTAL=COST*QOH - S SUBTOT=SUBTOT+TOTAL - S GRDTOT=GRDTOT+TOTAL - Q -SUB ; Write subtotal - W !!,?52,"SUBTOTAL: ",$J(SUBTOT,8,2) - S SUBTOT=0 - Q -HD ; Check for end of page - G:REC=1 HDR - I IOST?1"C".E W:$X>1 ! W *7 K DIR S DIR(0)="E" D ^DIR I 'Y S ANS="^" Q -HDR ; Heading for the Inventory - W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1 - W !,HD,?70,"Page ",PG,!!?22,"I N V E N T O R Y " W $S(FHR="W":"W O R K S H E E T",1:"R E P O R T"),!! - W ?(80-$L(MTH)/2),MTH,!! - I FHXX="F" S P2="FOOD GROUP: "_$P("MEAT PRODUCTS^MILK PRODUCTS^FRUITS & VEGETABLES^BREADS^COMMERCIAL NUTRITION SUPPLEMENTS^MISCELLANEOUS^UNCLASSIFIED","^",+P1) - E S P2=P1 - W ?(80-$L(P2)/2),P2,!! - I FHR="W" W !?56,"DATE",!?47,"ITEM",?56,"LAST",?66,"QOH",?74,"QOH",!,"ITEM#",?20,"NAME",?38,"U/P",?47,"COST",?55,"UPDATE",?63,"LAST MTH",?72,"CURRENT",! Q - W !?47,"ITEM",?58,"QOH",?67,"TOTAL",!,"ITEM#",?20,"NAME",?38,"U/P",?47,"COST",?56,"CURRENT",?68,"COST",! - Q +FHREP1 ; HISC/NCA - Inventory Worksheet and Report ;3/9/95 08:28 + ;;5.5;DIETETICS;;Jan 28, 2005 +EN2 ; Print the Inventory Worksheet & Report + S FHXX="F" + R !!,"Select W=Worksheet or R=Report: ",FHR:DTIME G:'$T!("^"[FHR) KIL^FHREP + I "wr"[FHR S X=FHR D TR^FH S FHR=X + I FHR'?1U!("WR"'[FHR) W *7," Enter W or R" G EN2 +E0 ; Read in Month and Year + D NOW^%DTC S NOW=%\1 + K %DT W !!,"Enter Mth/Yr: "_+$E(NOW,4,5)_"/"_$E(NOW,2,3)_"// " R X:DTIME G:'$T!(X["^") KIL^FHREP + I X="" S X=$E(NOW,1,5)_"00" + D ^%DT I Y<1!($E(Y,1,5)>$E(NOW,1,5)) W *7," Answer Month and Yr as Mth/Yr or Mth Yr.",!?25," CANNOT be greater than now." G E0 + S MTH=+$E(Y,4,5),MTH=$P("January February March April May June July August September October November December"," ",MTH),YR=$E(Y,2,3),MTH=MTH_" "_YR + I FHR="W" D F1^FHREP G:FHXX["^"!("^"[X) KIL^FHREP + I FHR="R" D D1^FHREP G:"^"[X KIL^FHREP +E1 K IOP S %ZIS="MQ",%ZIS("B")="HOME" W ! D ^%ZIS K %ZIS,IOP G:POP KIL^FHREP + I $D(IO("Q")) S FHPGM="Q0^FHREP1",FHLST="FHR^FHXX^MTH^SRT" D EN2^FH G KIL^FHREP + U IO D Q0 D ^%ZISC K %ZIS,IOP G KIL^FHREP +Q0 ; Process Printing worksheet or report + D Q1 G KIL^FHREP +Q1 ; Loop through Ingredients + K ^TMP($J) S ANS="",(K,GRDTOT,OLD,SUBTOT,TOTAL,PG)=0 D NOW^%DTC S DTP=% D DTP^FH S HD=DTP S CK=1 + F K=0:0 S K=$O(^FHING(K)) Q:K<1 S X=$P($G(^(K,0)),"^",19) I X="Y" S X=$G(^(0)) D LP S:OK ^TMP($J,P0_$S(FHXX="S":$E(L0,1,15),1:"FG"_P0),ING)=K_"^"_UP_"^"_COST_"^"_QOH_"^"_UDC_"^"_UDQ_"^"_$E(MIN,1,5) + S REC=0 + S P0="" F L1=0:0 S P0=$O(^TMP($J,P0)) Q:P0=""!(ANS="^") S ING="" F L2=0:0 S ING=$O(^TMP($J,P0,ING)) Q:ING="" S XX=^(ING) D P1 Q:ANS="^" + I FHR="R",ANS="",SRT W !!,?55,"TOTAL: ",$J(SUBTOT,8,2) + I FHR="R",ANS="",'SRT D SUB W !!?49,"GRAND TOTAL: ",$J(GRDTOT,8,2) + Q +LP ; Get Food Group or Storage + S ING=$P(X,"^",1),UP=$P(X,"^",5),COST=$P(X,"^",9),QOH=$P(X,"^",11),UDC=$P(X,"^",23),UDQ=$P(X,"^",24),MIN=$P(X,"^",25),OK=1,L0="" + S DTP=UDC D:DTP'="" DTP^FH S UDC=DTP,DTP=UDQ D:DTP'="" DTP^FH S UDQ=DTP + I FHXX="F" S P0=$P(X,"^",13) S:P0<1!(P0>6) P0=7 S:SRT&(P0'=SRT) OK=0 Q + S LOC=$P(X,"^",12),L0=$P($G(^FH(113.1,+LOC,0)),"^",1) S:L0="" L0="UNCLASSIFIED" S P0=$P($G(^FH(113.1,+LOC,0)),"^",3),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0) S:SRT&(LOC'=SRT) OK=0 + Q +P1 ; Loop to print or if FHR="E" edit QOH + S K=$P(XX,"^",1),UP=$P(XX,"^",2),COST=$P(XX,"^",3),QOH=$P(XX,"^",4),UDC=$P(XX,"^",5),UDQ=$P(XX,"^",6),MIN=$P(XX,"^",7),REC=REC+1 + I FHR="E" D Q + .W !!,"Ingredient: ",$P(^FHING(K,0),"^",1) + .W:UDQ'="" !?12,"QOH LAST UPDATED ON ",UDQ,! + .K DIE S DIE="^FHING(",DA=K + .S:OKAY DR="8;S:X=COST Y=""@1"";29////"_DT_";@1;10;S:X=QOH Y="""";30////"_DT + .S:'OKAY DR="10;S:X=QOH Y="""";30////"_DT D ^DIE S:$D(DTOUT) CK=0 S:$D(Y)!$D(DTOUT) ANS="^" K DA,DIE,DR,DTOUT,Y + .Q + D CHK Q:ANS="^" + D:$Y'<(IOSL-5) HD W ! Q:ANS="^" + I $L(ING)'>30 D + .W !,$J(MIN,5),?6,ING,?39,UP,?43,$J(COST,8,3) + .I FHR="W" W ?53,UDC,?63,$J(QOH,8,2),?73,"_____" Q + .W ?55,$J(QOH,8,2),?64,$J(TOTAL,8,2) + .Q + E D + .S L=$L($E(ING,1,30),",") + .S:L=1 L=L+1 W !,$J(MIN,5),?6,$P(ING,",",1,L-1),"," + .W !?6,$P(ING,",",L,99),?39,UP,?43,$J(COST,8,3) + .I FHR="W" W ?53,UDC,?63,$J(QOH,8,2),?73,"_____" Q + .W ?55,$J(QOH,8,2),?64,$J(TOTAL,8,2) + .Q + Q +CHK ; Check the Food Group or Storage to do Subtotal & Grandtotal + S P1=$S(FHXX="F":+P0,1:$E(P0,3,17)) + I REC=1 S OLD=P1 D HDR + I OLD'=P1 D:FHR="R" SUB D HD + S OLD=P1 + ; Calculate subtotal grand total + Q:FHR'="R" + S TOTAL=COST*QOH + S SUBTOT=SUBTOT+TOTAL + S GRDTOT=GRDTOT+TOTAL + Q +SUB ; Write subtotal + W !!,?52,"SUBTOTAL: ",$J(SUBTOT,8,2) + S SUBTOT=0 + Q +HD ; Check for end of page + G:REC=1 HDR + I IOST?1"C".E W:$X>1 ! W *7 K DIR S DIR(0)="E" D ^DIR I 'Y S ANS="^" Q +HDR ; Heading for the Inventory + W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1 + W !,HD,?70,"Page ",PG,!!?22,"I N V E N T O R Y " W $S(FHR="W":"W O R K S H E E T",1:"R E P O R T"),!! + W ?(80-$L(MTH)/2),MTH,!! + I FHXX="F" S P2="FOOD GROUP: "_$P("MEAT PRODUCTS^MILK PRODUCTS^FRUITS & VEGETABLES^BREADS^COMMERCIAL NUTRITION SUPPLEMENTS^MISCELLANEOUS^UNCLASSIFIED","^",+P1) + E S P2=P1 + W ?(80-$L(P2)/2),P2,!! + I FHR="W" W !?56,"DATE",!?47,"ITEM",?56,"LAST",?66,"QOH",?74,"QOH",!,"ITEM#",?20,"NAME",?38,"U/P",?47,"COST",?55,"UPDATE",?63,"LAST MTH",?72,"CURRENT",! Q + W !?47,"ITEM",?58,"QOH",?67,"TOTAL",!,"ITEM#",?20,"NAME",?38,"U/P",?47,"COST",?56,"CURRENT",?68,"COST",! + Q diff --git a/r/DIETETICS-FH/FHSELA1.m b/r/DIETETICS-FH/FHSELA1.m index b40fbde0..bce1091f 100644 --- a/r/DIETETICS-FH/FHSELA1.m +++ b/r/DIETETICS-FH/FHSELA1.m @@ -1,173 +1,168 @@ -FHSELA1 ;Hines OIFO/RTK - Map GMR Allergy file to Food Prefs ;3/07/2007 - ;;5.5;DIETETICS;**8,12**;Jan 28, 2005;Build 3 - ; - ;10/16/2007 BAY/KAM FH*5.5*12 Remedy Call 210385 Do not allow - ; user to change Food Preference name or - ; LIKE/DISLIKE field - ; -CREATE ; Check for any missing Allergy-type FP's or one's not renamed in 115.2 - ; and allow user to create the FP on the fly - D ^FHSELA2 S NUM=0,FHQUIT=0 - W !!!,"The following Allergy Food Preference titles are not on file." - W !,"You may use this option to create these Food Preference entries:" - D CRLIST I NUM=0 W !,"No Food Preferences need to be mapped." D EXIT Q - I FHQUIT=1 D EXIT Q - I FHRESP=""!(FHRESP="M") D EXIT Q - S FHAFPNM=$P(FHLIST(FHRESP),"^",1) - W !,FHAFPNM," " - K DIR S DIR("A")="Add to Food Preference file",DIR(0)="Y" D ^DIR - I $D(DIRUT) D EXIT Q - I Y'=1 D CREATE Q - D ADD - W !!," ...done. ",FHAFPNM," Food Preference has been added!" H 1 - D CREATE Q - D EXIT Q -CRLIST ; - W !!?5,"MISSING FOOD PREFERENCE LIST" - W !?5,"============================" - S FHSEL=0,FHK="" - F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK=""!(FHQUIT=1)!(FHSEL=1) D - .S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99) - .S FHZ1="ALLERGY - "_$P(FHFPS,";",1) - .I $D(^FH(115.2,"B",FHZ1)) Q - .S NUM=NUM+1,PAD=$S($L(NUM)=1:" ",1:"") W !,PAD,NUM - .W ?8,FHZ1 - .S FHLIST(NUM)=FHZ1_"^"_FHFPS - .I NUM#5=0!($O(^TMP($J,"FHALG",FHK))="") D PG Q - .Q - I FHQUIT=0,FHSEL=0,NUM#5'=0 D PG Q - Q -ADD ; - S FHALGMZ=1 - S X=FHAFPNM K DIC,DO - S (DIC,DIE)="^FH(115.2,",DIC(0)="L" D FILE^DICN - ; 10/16/2007 BP/KAM FH*5.5*12 Default DISLIKE and prevent Food Preference name change in the next line - S (FHDA,DA)=+Y,DR="26;1////D" - D ^DIE K DA,DIE,DR - D TRAN^FHSEL1 - Q -PG ; - S FHRESP="" W ! K DIR - S DIR("A")="Select Food Preference or 'M' to see more ('^' to EXIT)" - S DIR(0)="F",DIR("B")="M" D ^DIR I $D(DIRUT) S FHQUIT=1 Q - S FHRESP=Y - I FHRESP?1"M" Q - I FHRESP?1.3N,FHRESP>0,FHRESP<(NUM+1) S FHSEL=1 Q - W !!,"Select from 1 to ",NUM D PG Q - Q -MAP ; Map allergies by setting pointers in 115.2 to correct entries in 120.82 - D ^FHSELA2 - S FHK="" - F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK="" D - .S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99) - .S FHZ1="ALLERGY - "_$P(FHFPS,";",1) - .I '$D(^FH(115.2,"B",FHZ1)) Q ;not set-up in 115.2, can't map - .S FHFPIEN=$O(^FH(115.2,"B",FHZ1,"")) - .S FHALMP=$P(FHFPS,";",2,99) I FHALMP="" Q ;no allergies to map - .S FHZ=0 F S FHZ=FHZ+1 S FHANAM=$P(FHALMP,";",FHZ) Q:FHANAM="" D - ..D LOOKUP - Q -LOOKUP ; Look-up the Allergy in 120.82 and set the pointer - S FHX=FHANAM - F FHVAL=0:0 S FHVAL=$O(^GMRD(120.82,"B",FHX,FHVAL)) Q:FHVAL'>0 D - .I $D(^FH(115.2,FHFPIEN,"ALG","B",FHVAL)) Q ;pointer already exists - .S Y=FHVAL K DIC,DO S DA(1)=FHFPIEN,DIC="^FH(115.2,"_DA(1)_",""ALG""," - .S DIC(0)="L",DIC("P")=$P(^DD(115.2,25,0),U,2),X=+Y - .D FILE^DICN - Q -DISPMAP ; - W !!,"This option can be used to display the Standard GMR Allergy" - W !,"entries and the Food Preferences they map to.",!! K DIR - S DIR("A")="Display Map by Allergies or by Food Preferences (A/F): " - S DIR(0)="SA^A:Allergies;F:Food Preferences" D ^DIR - I $D(DIRUT) D EXIT Q - S FHSEL=Y - D DEV - Q -DEV ;get device and set up queue - W ! K %ZIS,IOP S %ZIS="Q" D ^%ZIS Q:POP - I '$D(IO("Q")) U IO D LISTMAP,^%ZISC,EXIT Q - S ZTRTN="LISTMAP^FHSELA1",ZTSAVE("FHSEL")="" - S ZTDESC="GMR Allergy/Food Preference Map Display" D ^%ZTLOAD - D ^%ZISC K %ZIS,IOP - D EXIT - Q -LISTMAP ; List Map by Allergies or by Food Preferences - I FHSEL="A" D LISTAL Q - I FHSEL="F" D LISTFP Q - Q -LISTFP ; List all the Allergy-type Food Pref's and corresponding GMR Allergies - D ^FHSELA2 - S FHK="" W !!,"ALLERGY TYPE FOOD PREFERENCE MAP" - W !!,"NFS Food Preference Title",?40,"GMR Standard Allergy(s)" - W !,"===================================" - W ?40,"===================================" - F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK="" D - .S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99),FHZ1=$P(FHFPS,";",1) - .W !,"ALLERGY - ",FHZ1 - .S FHALMP=$P(FHFPS,";",2,99) I FHALMP="" W ?40,"** NONE **" Q - .S FHZ=0,N=0 F S FHZ=FHZ+1,FHANAM=$P(FHALMP,";",FHZ) Q:FHANAM="" D - ..W ?40,$S(FHZ>1:",",1:"") S N=N+$L(FHANAM)+1 W:N>40 !?40 S:N>40 N=0 W FHANAM I N=0 S N=N+$L(FHANAM)+1 - D EXIT Q -LISTAL ; List all the GMR Allergies and the Food Pref to map to - D ^FHSELA2 - S FHK="" W !!,"GMR STANDARD FOOD ALLERGY MAP" - W !!,"GMR Allergy Name",?25,"Corresponding NFS Food Preference" - W !,"=======================",?25,"====================================" - F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK="" D - .S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99),FHZ1=$P(FHFPS,";",1) - .S FHALMP=$P(FHFPS,";",2,99) I FHALMP="" Q - .S FHZ=0,N=0 F S FHZ=FHZ+1,FHANAM=$P(FHALMP,";",FHZ) Q:FHANAM="" D - ..S ^TMP($J,"FHAL",FHANAM)="ALLERGY - "_FHZ1 - S FHANAMZ="" - F S FHANAMZ=$O(^TMP($J,"FHAL",FHANAMZ)) Q:FHANAMZ="" D - .W !,FHANAMZ,?25,"...maps to: ",^TMP($J,"FHAL",FHANAMZ) - D EXIT Q -MISSING ; List all Food Pref's with no pointers to 120.82 - D ^FHSELA2 - S FHK="" - F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK="" D - .S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99),FHZ1=$P(FHFPS,";",1) - .I $P(FHFPS,";",2)'="" Q - .W !?5,"ALLERGY - ",FHZ1," does not have corresponding 120.82 entries" - D EXIT Q -CHECK ; Check for any missing Allergy-type FP's or one's not renamed in 115.2 - D ^FHSELA2 - S FHK="",FLG=0 - W !,"The following Food Preferences titles were not found in file #115.2:" - F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK="" D - .S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99) - .S FHZ1="ALLERGY - "_$P(FHFPS,";",1) - .I '$D(^FH(115.2,"B",FHZ1)) W !,FHZ1 S FLG=1 - I FLG=0 W !,"ALL FOOD PREFERENCES HAVE BEEN RENAMED!" - D EXIT Q - ; -UPDATE ;Update Food Preferences for all Patient's based on Allergies - D ^FHSELA2 S FHCOUNT=0,FHQT=0 - W !!,"...Updating Patient Food Preferences based on Food-Type Allergies" - W "..." K FHMISS F FHDFN=0:0 S FHDFN=$O(^FHPT(FHDFN)) Q:FHDFN'>0 D - .S FHCOUNT=FHCOUNT+1 I FHCOUNT#100=0 W "." - .D GETZN^FHOMUTL I FILE'="P" Q - .S DFN=IEN D ALG^FHCLN I '$O(^TMP($J,"FHGMRAL","")) Q - .F FHGMRN=0:0 S FHGMRN=$O(^TMP($J,"FHGMRAL",FHGMRN)) Q:FHGMRN="" D UPDFP1^FHWGMR - I $G(FHPST8)=1 K ^TMP($J,"FHGMRAL"),^TMP($J,"FHMISS"),FHGMRN,FHMSAL,FHMSFP,FHMSPT,FHPST8,FHCOUNT Q - D LIST - K ^TMP($J,"FHGMRAL"),^TMP($J,"FHMISS"),FHGMRN,FHMSAL,FHMSFP,FHMSPT,FHPST8,FHCOUNT,FHQT - Q -LIST ; - I '$D(^TMP($J,"FHMISS")) Q - W !!,"The following entries need to be mapped in order to automatically" - W !,"update the Patient Food Preferences:",! S FHCOUNT=0,FHQT=0 - S FHMSFP="" F S FHMSFP=$O(^TMP($J,"FHMISS",FHMSFP)) Q:FHMSFP=""!(FHQT=1) D - .W !,"'ALLERGY - ",FHMSFP,"'" S FHCOUNT=FHCOUNT+1 - .S FHMSPT="" F S FHMSPT=$O(^TMP($J,"FHMISS",FHMSFP,FHMSPT)) Q:FHMSPT="" D - ..S FHMSAL=$P($G(^TMP($J,"FHMISS",FHMSFP,FHMSPT)),U,1) - ..W !?3,"Patient: ",$E(FHMSPT,1,30),?43,"Allergy: ",FHMSAL - ..S FHCOUNT=FHCOUNT+1 - ..I FHCOUNT>14 S FHCOUNT=0 W ! K DIR S DIR(0)="E" D ^DIR W ! I X="^" S FHQT=1 - Q -EXIT ; - D MAP - K ^TMP($J,"FHALG"),^TMP($J,"FHAL") - K FHFPIEN,FHK,FHX,FHZ,FHFPS,FHZ1,FHVAL,N,FHANAM,FHANAMZ - K FHQUIT,NUM,FHRESP,FHAFPNM,FHSEL,PAD,FHLIST,FHALGMZ,FHALMP +FHSELA1 ;Hines OIFO/RTK - Map GMR Allergy file to Food Prefs ;3/07/2007 + ;;5.5;DIETETICS;**8**;Jan 28, 2005;Build 28 + ; +CREATE ; Check for any missing Allergy-type FP's or one's not renamed in 115.2 + ; and allow user to create the FP on the fly + D ^FHSELA2 S NUM=0,FHQUIT=0 + W !!!,"The following Allergy Food Preference titles are not on file." + W !,"You may use this option to create these Food Preference entries:" + D CRLIST I NUM=0 W !,"No Food Preferences need to be mapped." D EXIT Q + I FHQUIT=1 D EXIT Q + I FHRESP=""!(FHRESP="M") D EXIT Q + S FHAFPNM=$P(FHLIST(FHRESP),"^",1) + W !,FHAFPNM," " + K DIR S DIR("A")="Add to Food Preference file",DIR(0)="Y" D ^DIR + I $D(DIRUT) D EXIT Q + I Y'=1 D CREATE Q + D ADD + W !!," ...done. ",FHAFPNM," Food Preference has been added!" H 1 + D CREATE Q + D EXIT Q +CRLIST ; + W !!?5,"MISSING FOOD PREFERENCE LIST" + W !?5,"============================" + S FHSEL=0,FHK="" + F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK=""!(FHQUIT=1)!(FHSEL=1) D + .S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99) + .S FHZ1="ALLERGY - "_$P(FHFPS,";",1) + .I $D(^FH(115.2,"B",FHZ1)) Q + .S NUM=NUM+1,PAD=$S($L(NUM)=1:" ",1:"") W !,PAD,NUM + .W ?8,FHZ1 + .S FHLIST(NUM)=FHZ1_"^"_FHFPS + .I NUM#5=0!($O(^TMP($J,"FHALG",FHK))="") D PG Q + .Q + I FHQUIT=0,FHSEL=0,NUM#5'=0 D PG Q + Q +ADD ; + S FHALGMZ=1 + S X=FHAFPNM K DIC,DO + S (DIC,DIE)="^FH(115.2,",DIC(0)="L" D FILE^DICN + S (FHDA,DA)=+Y,DR=".01;26;1//DISLIKE;S:X=""D"" Y=0;3;20;S:'X Y=99;21;99" + D ^DIE K DA,DIE,DR + D TRAN^FHSEL1 + Q +PG ; + S FHRESP="" W ! K DIR + S DIR("A")="Select Food Preference or 'M' to see more ('^' to EXIT)" + S DIR(0)="F",DIR("B")="M" D ^DIR I $D(DIRUT) S FHQUIT=1 Q + S FHRESP=Y + I FHRESP?1"M" Q + I FHRESP?1.3N,FHRESP>0,FHRESP<(NUM+1) S FHSEL=1 Q + W !!,"Select from 1 to ",NUM D PG Q + Q +MAP ; Map allergies by setting pointers in 115.2 to correct entries in 120.82 + D ^FHSELA2 + S FHK="" + F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK="" D + .S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99) + .S FHZ1="ALLERGY - "_$P(FHFPS,";",1) + .I '$D(^FH(115.2,"B",FHZ1)) Q ;not set-up in 115.2, can't map + .S FHFPIEN=$O(^FH(115.2,"B",FHZ1,"")) + .S FHALMP=$P(FHFPS,";",2,99) I FHALMP="" Q ;no allergies to map + .S FHZ=0 F S FHZ=FHZ+1 S FHANAM=$P(FHALMP,";",FHZ) Q:FHANAM="" D + ..D LOOKUP + Q +LOOKUP ; Look-up the Allergy in 120.82 and set the pointer + S FHX=FHANAM + F FHVAL=0:0 S FHVAL=$O(^GMRD(120.82,"B",FHX,FHVAL)) Q:FHVAL'>0 D + .I $D(^FH(115.2,FHFPIEN,"ALG","B",FHVAL)) Q ;pointer already exists + .S Y=FHVAL K DIC,DO S DA(1)=FHFPIEN,DIC="^FH(115.2,"_DA(1)_",""ALG""," + .S DIC(0)="L",DIC("P")=$P(^DD(115.2,25,0),U,2),X=+Y + .D FILE^DICN + Q +DISPMAP ; + W !!,"This option can be used to display the Standard GMR Allergy" + W !,"entries and the Food Preferences they map to.",!! K DIR + S DIR("A")="Display Map by Allergies or by Food Preferences (A/F): " + S DIR(0)="SA^A:Allergies;F:Food Preferences" D ^DIR + I $D(DIRUT) D EXIT Q + S FHSEL=Y + D DEV + Q +DEV ;get device and set up queue + W ! K %ZIS,IOP S %ZIS="Q" D ^%ZIS Q:POP + I '$D(IO("Q")) U IO D LISTMAP,^%ZISC,EXIT Q + S ZTRTN="LISTMAP^FHSELA1",ZTSAVE("FHSEL")="" + S ZTDESC="GMR Allergy/Food Preference Map Display" D ^%ZTLOAD + D ^%ZISC K %ZIS,IOP + D EXIT + Q +LISTMAP ; List Map by Allergies or by Food Preferences + I FHSEL="A" D LISTAL Q + I FHSEL="F" D LISTFP Q + Q +LISTFP ; List all the Allergy-type Food Pref's and corresponding GMR Allergies + D ^FHSELA2 + S FHK="" W !!,"ALLERGY TYPE FOOD PREFERENCE MAP" + W !!,"NFS Food Preference Title",?40,"GMR Standard Allergy(s)" + W !,"===================================" + W ?40,"===================================" + F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK="" D + .S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99),FHZ1=$P(FHFPS,";",1) + .W !,"ALLERGY - ",FHZ1 + .S FHALMP=$P(FHFPS,";",2,99) I FHALMP="" W ?40,"** NONE **" Q + .S FHZ=0,N=0 F S FHZ=FHZ+1,FHANAM=$P(FHALMP,";",FHZ) Q:FHANAM="" D + ..W ?40,$S(FHZ>1:",",1:"") S N=N+$L(FHANAM)+1 W:N>40 !?40 S:N>40 N=0 W FHANAM I N=0 S N=N+$L(FHANAM)+1 + D EXIT Q +LISTAL ; List all the GMR Allergies and the Food Pref to map to + D ^FHSELA2 + S FHK="" W !!,"GMR STANDARD FOOD ALLERGY MAP" + W !!,"GMR Allergy Name",?25,"Corresponding NFS Food Preference" + W !,"=======================",?25,"====================================" + F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK="" D + .S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99),FHZ1=$P(FHFPS,";",1) + .S FHALMP=$P(FHFPS,";",2,99) I FHALMP="" Q + .S FHZ=0,N=0 F S FHZ=FHZ+1,FHANAM=$P(FHALMP,";",FHZ) Q:FHANAM="" D + ..S ^TMP($J,"FHAL",FHANAM)="ALLERGY - "_FHZ1 + S FHANAMZ="" + F S FHANAMZ=$O(^TMP($J,"FHAL",FHANAMZ)) Q:FHANAMZ="" D + .W !,FHANAMZ,?25,"...maps to: ",^TMP($J,"FHAL",FHANAMZ) + D EXIT Q +MISSING ; List all Food Pref's with no pointers to 120.82 + D ^FHSELA2 + S FHK="" + F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK="" D + .S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99),FHZ1=$P(FHFPS,";",1) + .I $P(FHFPS,";",2)'="" Q + .W !?5,"ALLERGY - ",FHZ1," does not have corresponding 120.82 entries" + D EXIT Q +CHECK ; Check for any missing Allergy-type FP's or one's not renamed in 115.2 + D ^FHSELA2 + S FHK="",FLG=0 + W !,"The following Food Preferences titles were not found in file #115.2:" + F S FHK=$O(^TMP($J,"FHALG",FHK)) Q:FHK="" D + .S FHFPS=$P(^TMP($J,"FHALG",FHK),";",1,99) + .S FHZ1="ALLERGY - "_$P(FHFPS,";",1) + .I '$D(^FH(115.2,"B",FHZ1)) W !,FHZ1 S FLG=1 + I FLG=0 W !,"ALL FOOD PREFERENCES HAVE BEEN RENAMED!" + D EXIT Q + ; +UPDATE ;Update Food Preferences for all Patient's based on Allergies + D ^FHSELA2 S FHCOUNT=0,FHQT=0 + W !!,"...Updating Patient Food Preferences based on Food-Type Allergies" + W "..." K FHMISS F FHDFN=0:0 S FHDFN=$O(^FHPT(FHDFN)) Q:FHDFN'>0 D + .S FHCOUNT=FHCOUNT+1 I FHCOUNT#100=0 W "." + .D GETZN^FHOMUTL I FILE'="P" Q + .S DFN=IEN D ALG^FHCLN I '$O(^TMP($J,"FHGMRAL","")) Q + .F FHGMRN=0:0 S FHGMRN=$O(^TMP($J,"FHGMRAL",FHGMRN)) Q:FHGMRN="" D UPDFP1^FHWGMR + I $G(FHPST8)=1 K ^TMP($J,"FHGMRAL"),^TMP($J,"FHMISS"),FHGMRN,FHMSAL,FHMSFP,FHMSPT,FHPST8,FHCOUNT Q + D LIST + K ^TMP($J,"FHGMRAL"),^TMP($J,"FHMISS"),FHGMRN,FHMSAL,FHMSFP,FHMSPT,FHPST8,FHCOUNT,FHQT + Q +LIST ; + I '$D(^TMP($J,"FHMISS")) Q + W !!,"The following entries need to be mapped in order to automatically" + W !,"update the Patient Food Preferences:",! S FHCOUNT=0,FHQT=0 + S FHMSFP="" F S FHMSFP=$O(^TMP($J,"FHMISS",FHMSFP)) Q:FHMSFP=""!(FHQT=1) D + .W !,"'ALLERGY - ",FHMSFP,"'" S FHCOUNT=FHCOUNT+1 + .S FHMSPT="" F S FHMSPT=$O(^TMP($J,"FHMISS",FHMSFP,FHMSPT)) Q:FHMSPT="" D + ..S FHMSAL=$P($G(^TMP($J,"FHMISS",FHMSFP,FHMSPT)),U,1) + ..W !?3,"Patient: ",$E(FHMSPT,1,30),?43,"Allergy: ",FHMSAL + ..S FHCOUNT=FHCOUNT+1 + ..I FHCOUNT>14 S FHCOUNT=0 W ! K DIR S DIR(0)="E" D ^DIR W ! I X="^" S FHQT=1 + Q +EXIT ; + D MAP + K ^TMP($J,"FHALG"),^TMP($J,"FHAL") + K FHFPIEN,FHK,FHX,FHZ,FHFPS,FHZ1,FHVAL,N,FHANAM,FHANAMZ + K FHQUIT,NUM,FHRESP,FHAFPNM,FHSEL,PAD,FHLIST,FHALGMZ,FHALMP diff --git a/r/DIETETICS-FH/FHSELA2.m b/r/DIETETICS-FH/FHSELA2.m index 4b50833a..a1e1eafe 100644 --- a/r/DIETETICS-FH/FHSELA2.m +++ b/r/DIETETICS-FH/FHSELA2.m @@ -1,309 +1,309 @@ -FHSELA2 ;Hines OIFO/RTK - Map GMR Allergy file to Food Prefs ;3/07/2007 - ;;5.5;DIETETICS;**8,13**;Jan 28, 2005;Build 1 - ; -TMPGL ; Create ^TMP Global - K ^TMP($J,"FHALG") S FHK=0 - F S FHK=FHK+1,FHFPS=$T(FPS+FHK),FHZ1=$P(FHFPS,";",3) Q:FHZ1="" D - .S ^TMP($J,"FHALG",FHZ1)=$P(FHFPS,";",3,99) -EXIT K FHK,FHFPS,FHZ1 - Q -FPS ;; - ;;ALCOHOL;ALCOHOL - ;;ALCOHOL, BEER;HOPS - ;;ALCOHOL, GIN;GIN - ;;ALCOHOL, RUM;RUM - ;;ALCOHOL, SCOTCH;SCOTCH - ;;ALCOHOL, TEQUILA;TEQUILA - ;;ALCOHOL, VODKA;VODKA - ;;ALCOHOL, WINE;WINE - ;;ALCOHOL, WINE, WHITE;WHITE WINE - ;;ALFALFA SPROUTS;ALFALFA SPROUTS - ;;ALMONDS;ALMONDS - ;;ANISE OIL;ANISE OIL - ;;APPLES;APPLE JUICE;APPLES - ;;APRICOTS;APRICOTS - ;;ARTICHOKES;ARTICHOKES - ;;ARTIFICIAL COLORS;ARTIFICIAL COLORS;BLACK DYES;BLUE DYES;FD&C BLUE DYE #2;FD&C GREEN DYE #6;GREEN DYES;PINK DYES;PURPLE DYES - ;;ASPARAGUS;ASPARAGUS - ;;AVOCADOS;AVOCADOS - ;;BACON;BACON - ;;BANANAS;BANANAS - ;;BARBEQUE SAUCE;BARBEQUE SAUCE - ;;BARLEY;BARLEY;MALT BARLEY - ;;BASIL;BASIL - ;;BEANS;BEANS;LEGUMES - ;;BEANS, BAKED;BAKED BEANS - ;;BEANS, FAVA;FAVA BEANS (BROAD BEANS) - ;;BEANS, GREEN;GREEN BEANS - ;;BEANS, LENTILS;LENTILS - ;;BEANS, LIMA;LIMA BEANS - ;;BEANS, PINTO;PINTO BEANS - ;;BEANS, SOY;SOYBEANS - ;;BEANS, STRING;STRING BEANS - ;;BEANS, WHITE;WHITE BEANS - ;;BEEF;BEEF;BEEF PRODUCTS - ;;BEEF, CORNED;CORNED BEEF - ;;BEETS;BEETS - ;;BEETS, PICKLES;PICKLED BEETS - ;;BERRIES;BERRIES - ;;BLACKBERRIES;BLACKBERRIES - ;;BLUEBERRIES;BLUEBERRIES - ;;BROCCOLI;BROCCOLI - ;;BRUSSELS SPROUTS;BRUSSELS SPROUTS - ;;BUCKWHEAT;BUCKWHEAT - ;;BUTTER;BUTTER - ;;CABBAGE;CABBAGE - ;;CAFFEINE;CAFFEINE;COFFEE;COFFEE BEANS - ;;CAFFEINE, COLAS;COLA DRINKS - ;;CANTALOUPE;CANTALOUPE - ;;CARBONATED BEVERAGES;CARBONATED BEVERAGES;SOFT DRINKS - ;;CARROTS;CARROTS - ;;CATSUP;CATSUP - ;;CAULIFLOWER;CAULIFLOWER - ;;CAVIAR;CAVIAR - ;;CELERY;CELERY - ;;CEREAL;CEREALS - ;;CEREAL, CORNFLAKES;CORNFLAKES - ;;CEREAL, CRM OF WHEAT;CREAM OF WHEAT - ;;CEREAL, GRITS;GRITS - ;;CEREAL, OATMEAL;OATMEAL - ;;CHEESE;CHEESE - ;;CHEESE, BLUE;BLUE CHEESE - ;;CHEESE, CHEDDAR;CHEDDAR CHEESE - ;;CHEESE, COTTAGE;COTTAGE CHEESE - ;;CHEESE, FETA;FETA CHEESE - ;;CHEESE, GOAT;GOAT CHEESE - ;;CHEESE, PARMESAN;PARMESAN CHEESE - ;;CHEESE, RICOTTA;RICOTTA CHEESE - ;;CHEESE, SWISS;SWISS CHEESE - ;;CHERRIES;CHERRIES;CHERRY JUICE - ;;CHICKEN;CHICKEN - ;;CHICKPEAS;CHICKPEAS - ;;CHICORY;CHICORY - ;;CHILI;CHILI - ;;CHIVES;CHIVES - ;;CHOCOLATE;CHOCOLATE;COCOA - ;;CILANTRO;CILANTRO;CUMIN - ;;CINNAMON;CINNAMON;CINNAMON OIL - ;;CITRUS;CITRUS;CITRUS FRUIT;CITRUS JUICE - ;;CLOVES;CLOVES - ;;COCONUT;COCONUTS - ;;COLA;COLA DRINKS - ;;CORN;CORN - ;;CRACKERS;CRACKERS - ;;CRACKERS, GRAHAM;GRAHAM CRACKERS - ;;CRANBERRIES;CRANBERRIES - ;;CREAM, SOUR;SOUR CREAM - ;;CREAMER, NON-DAIRY;NON-DAIRY CREAMER - ;;CREAMER, POWDER;POWDERED CREAMER - ;;CUCUMBERS;CUCUMBERS - ;;DAIRY PRODUCTS;DAIRY PRODUCTS - ;;DATES;DATES - ;;DILL;DILL - ;;DUCK;DUCK;WATERFOWL - ;;DYES, VEGETABLES;VEGETABLE DYES - ;;EGGNOG;EGGNOG - ;;EGGPLANT;EGGPLANT - ;;EGGS;EGGS;EGG PRODUCTS;EGG WHITES;EGG YOLKS - ;;EGGS, SUBSTITUTES;EGG, SUBSTITUTES - ;;FAT EMULSIONS;FAT EMULSIONS - ;;FIGS;FIGS - ;;FISH;FISH - ;;FISH, ABALONE;ABALONE - ;;FISH, ANCHOVIES;ANCHOVIES - ;;FISH, CATFISH;CATFISH - ;;FISH, COD;CODFISH - ;;FISH, FLOUNDER;FLOUNDER - ;;FISH, HERRING;HERRING - ;;FISH, MACKEREL;MACKEREL - ;;FISH, PERCH;PERCH - ;;FISH, RED SNAPPER;RED SNAPPER - ;;FISH, SALMON;SALMON - ;;FISH, SARDINES;SARDINES - ;;FISH, SHARK;SHARK - ;;FISH, SWORDFISH;SWORDFISH - ;;FISH, TROUT;TROUT - ;;FISH, TUNA;TUNA - ;;FISH, WHITE;WHITE FISH - ;;FLAVORING, HICKORY;HICKORY - ;;FLAVORING, LICORICE;LICORICE - ;;FLAVORING, VANILLA;VANILLA - ;;FOOD PRESERVATIVES;FOOD PRESERVATIVES - ;;FRUIT, FRESH;FRESH FRUIT - ;;FROG;FROG LEGS;FROGS - ;;FRUIT;FRUIT - ;;FRUIT JUICE;FRUIT JUICE - ;;FRUITCAKES;FRUITCAKES - ;;GARLIC;GARLIC - ;;GELATIN;GELATIN - ;;GINGER;GINGER - ;;GLUTEN;GLUTENS - ;;GRAINS;GRAINS - ;;GRAPEFRUIT;GRAPEFRUIT - ;;GRAPES;GRAPES - ;;GRAVY;GRAVY - ;;GREENS, COLLARD;COLLARD GREENS - ;;GREENS, MUSTARD;MUSTARD GREENS - ;;GREENS, TURNIP;TURNIP GREENS - ;;GREEN LEAFY VEG;GREEN LEAFY VEGETABLES - ;;GUAVA;GUAVA - ;;HOMINY;HOMINY - ;;HONEY;HONEY - ;;HONEYDEW;HONEYDEW - ;;HORSERADISH;HORSERADISH - ;;IODINE;IODIZED SALT - ;;JUICE;JUICE - ;;KIWI;KIWI FRUIT - ;;LACTOSE;LACTOSE - ;;LEEKS;LEEKS - ;;LEMON;LEMON JUICE;LEMONS - ;;LETTUCE;LETTUCE - ;;LIMES;LIMES - ;;LYCHEE NUTS;LYCHEES - ;;MALTOSE;MALTOSE - ;;MANGOS;MANGOS - ;;MARSHMALLOWS;MARSHMALLOWS - ;;MAYONNAISE;MAYONNAISE - ;;MEAT;MEAT - ;;MEAT, LAMB;LAMB - ;;MEAT, LIVER;LIVER - ;;MEAT, PROCESSED;PROCESSED MEATS - ;;MEAT, RED;RED MEAT - ;;MEAT, VENISON;VENISON - ;;MELONS;MELONS - ;;MELONS, MUSK;MUSK MELONS - ;;MELONS, WATER;WATERMELONS - ;;MILK;MILK;DAIRY PRODUCTS - ;;MILK, BUTTER;BUTTERMILK - ;;MILK, GOAT;GOAT MILK - ;;MILK, YOGURT;YOGURT - ;;MINT;MINT - ;;MODIFIED FOOD STARCH;MODIFIED FOOD STARCH;FOOD STARCH, MODIFIED - ;;MSG;MONOSODIUM GLUTAMATE - ;;MUSHROOMS;MUSHROOMS - ;;MUSTARD;MUSTARD - ;;MUTTON/LAMB;MUTTON - ;;NECTARINES;NECTARINES - ;;NITRITES;NITRITES - ;;NON-FOOD RELATED;EGGSHELLS - ;;NUTMEG;NUTMEG - ;;NUTS;BRAZIL NUTS;CASHEWS;CHESTNUTS;HAZELNUTS;MACADAMIA NUTS;NUTS;PECANS - ;;NUTS, PEANUT;PEANUT BUTTER;PEANUT OIL;PEANUTS - ;;NUTS, PINE;PINE NUTS - ;;NUTS, PISTACHIOS;PISTACHIOS - ;;NUTS, TREE;PECANS;TREE NUTS - ;;NUTS, WALNUT;WALNUTS - ;;OATS;OATS - ;;OIL, COCONUT;COCONUT OIL - ;;OIL, COTTONSEED;COTTONSEED OIL - ;;OIL, PALM;PALM OIL - ;;OIL, SAFFLOWER;SAFFLOWER OIL - ;;OIL, SOY;SOYBEAN OIL - ;;OIL, SUNFLOWER;SUNFLOWER OIL - ;;OKRA;OKRA - ;;OLIVES;BLACK OLIVES;OLIVES - ;;ONIONS;ONIONS - ;;ONIONS, RED;RED ONIONS - ;;ORANGE;ORANGE;ORANGES;ORANGE JUICE;ORANGE OIL - ;;OREGANO;OREGANO - ;;OYSTERS;OYSTERS - ;;PAPAYAS;PAPAYAS - ;;PAPRIKA;PAPRIKA - ;;PARSLEY;PARSLEY - ;;PARSNIP;PARSNIP - ;;PASSION FRUIT;PASSION FRUIT - ;;PEACHES;PEACHES - ;;PEARS;PEARS - ;;PEAS;PEAS - ;;PEAS, BLACK-EYED;BLACK-EYED PEAS - ;;PEAS, ENGLISH;ENGLISH PEAS - ;;PEAS, SNOW;SNOW PEAS - ;;PEPPER;PEPPER;WHITE PEPPER - ;;PEPPER, BLACK;BLACK PEPPER;PEPPER - ;;PEPPERMINT;PEPPERMINT - ;;PEPPERONI;PEPPERONI - ;;PEPPERS;BELL PEPPERS;PEPPERS - ;;PEPPERS, CHILI;CHILI PEPPER;CHILI PEPPERS - ;;PEPPERS, GREEN;GREEN BELL PEPPERS;PEPPERS - ;;PEPPERS, HOT;CAPSAICIN;CAYENNE PEPPER;HOT PEPPER;HOT PEPPERS;JALAPENO PEPPERS - ;;PEPPERS, RED;RED BELL PEPPERS - ;;PERSIMMONS;PERSIMMONS - ;;PHEASANT;PHEASANT - ;;PICKLES;PICKLES - ;;PIMENTOS;PIMENTOS - ;;PINEAPPLE;PINEAPPLES - ;;PIZZA;PIZZA - ;;PLUMS;PLUMS - ;;POPCORN;POPCORN - ;;POPPY SEEDS;POPPY SEEDS - ;;PORK;PORK;PORK PRODUCTS;HAM - ;;PORK, HAM;HAM - ;;POTATOES;POTATOES - ;;POTATOES, SALAD;POTATO SALAD - ;;POTATOES, SWEET/YAMS;SWEET POTATOES;YAMS - ;;POULTRY;FOWL;POULTRY - ;;PRUNES;PRUNES - ;;PUDDING, TAPIOCA;TAPIOCA PUDDING - ;;PUMPKIN;PUMPKINS - ;;RABBIT;RABBIT - ;;RADISH;RADISHES - ;;RAISINS;RAISINS - ;;RASPBERRIES;RASPBERRIES - ;;RED DYES;FD&C RED DYE #1;FD&C RED DYE #2;FD&C RED DYE #3;FD&C RED DYE #40;FD&C RED DYE #40 LAKE;FD&C RED DYE #5;RED DYES - ;;RHUBARB;RHUBARB - ;;RICE;RICE;WHITE RICE - ;;ROSEMARY;ROSEMARY - ;;RUTABAGAS;RUTABAGAS - ;;RYE;RYE - ;;SALAD DRESSING, ITAL;ITALIAN DRESSING - ;;SALT;NON-IODIZED SALT;SALT - ;;SALT, SUBSTITUTES;SALT SUBSTITUTES - ;;SAUERKRAUT;SAUERKRAUT - ;;SAUSAGES;SAUSAGES - ;;SEAFOOD;SEAFOOD - ;;SEEDS;SEEDS - ;;SEEDS, SUNFLOWER;SUNFLOWER SEEDS - ;;SESAME;SESAME;SESAME OIL;SESAME SEEDS - ;;SHELLFISH;CLAMS;CRAB;CRAWFISH;CRUSTACEANS;LOBSTER;MUSSELS;SCALLOPS;SHELL FISH;SHELLFISH - ;;SHERBET;SHERBET - ;;SHRIMP;SHRIMP - ;;SNAILS;SNAILS - ;;SOUR CREAM;SOUR CREAM - ;;SOY;SOY;SOY MILK;SOY PRODUCTS;SOY SAUCE;SOYBEANS;TOFU - ;;SOY SAUCE;SOY SAUCE - ;;SPAGHETTI;SPAGHETTI - ;;SPAM;SPAM - ;;SPICES;CONDIMENTS;SPICES - ;;SPINACH;SPINACH - ;;SQUASH;SQUASH - ;;SQUID;SQUID - ;;STARCHY FOODS;STARCHES - ;;STRAWBERRIES;STRAWBERRIES;STRAWBERRIES PLUS - ;;SUCRALOSE;SUCRALOSE - ;;SUGAR;SUGAR;SUGAR BEETS;WHITE SUGAR - ;;SUGAR SUB;ARTIFICIAL SWEETENERS - ;;SUGAR SUB, ASPARTAME;ASPARTAME - ;;SUGAR SUB, SACCHARIN;SACCHARIN;SWEET'N LOW - ;;SUGAR, BROWN;BROWN SUGAR - ;;SULFITES;SULFITES - ;;SYRUP, MAPLE;MAPLE SYRUP - ;;TANGERINES;TANGERINES - ;;TARRAGON;TARRAGON - ;;TEA;TEA - ;;TOFFEE;TOFFEE - ;;TOMATO;TOMATO;TOMATO JUICE;TOMATO PRODUCTS;TOMATO SAUCE;TOMATOES - ;;TOMATOES, FRESH;FRESH TOMATOES - ;;TUMERIC;TUMERIC - ;;TURKEY;TURKEY - ;;TURNIPS;TURNIPS - ;;VEAL;VEAL - ;;VEGETABLES;VEGETABLES - ;;VEGETABLES, GREEN;GREEN VEGETABLES - ;;VINEGAR;VINEGAR - ;;WATERFOWL;WATERFOWL - ;;WHEAT;FLOUR;WHEAT - ;;WHEY;WHEY - ;;WINE, RED;RED WINE - ;;YEAST;YEAST - ;;YELLOW DYES;FD&C YELLOW DYE #10;FD&C YELLOW DYE #2;FD&C YELLOW DYE #5;FD&C YELLOW DYE #6;FD&C YELLOW DYE #6 LAKE;TARTRAZINE;YELLOW DYES - ;;ZUCCHINI;ZUCCHINI +FHSELA2 ;Hines OIFO/RTK - Map GMR Allergy file to Food Prefs ;3/07/2007 + ;;5.5;DIETETICS;**8**;Jan 28, 2005;Build 28 + ; +TMPGL ; Create ^TMP Global + K ^TMP($J,"FHALG") S FHK=0 + F S FHK=FHK+1,FHFPS=$T(FPS+FHK),FHZ1=$P(FHFPS,";",3) Q:FHZ1="" D + .S ^TMP($J,"FHALG",FHZ1)=$P(FHFPS,";",3,99) +EXIT K FHK,FHFPS,FHZ1 + Q +FPS ;; + ;;ALCOHOL;ALCOHOL + ;;ALCOHOL, BEER;HOPS + ;;ALCOHOL, GIN;GIN + ;;ALCOHOL, RUM;RUM + ;;ALCOHOL, SCOTCH;SCOTCH + ;;ALCOHOL, TEQUILA;TEQUILA + ;;ALCOHOL, VODKA;VODKA + ;;ALCOHOL, WINE;WINE + ;;ALCOHOL, WINE, WHITE;WHITE WINE + ;;ALFALFA SPROUTS;ALFALFA SPROUTS + ;;ALMONDS;ALMONDS + ;;ANISE OIL;ANISE OIL + ;;APPLES;APPLE JUICE;APPLES + ;;APRICOTS;APRICOTS + ;;ARTICHOKES;ARTICHOKES + ;;ARTIFICIAL COLORS;ARTIFICIAL COLORS;BLACK DYES;BLUE DYES;FD&C BLUE DYE #2;FD&C GREEN DYE #6;GREEN DYES;PINK DYES;PURPLE DYES + ;;ASPARAGUS;ASPARAGUS + ;;AVOCADOS;AVOCADOS + ;;BACON;BACON + ;;BANANAS;BANANAS + ;;BARBEQUE SAUCE;BARBEQUE SAUCE + ;;BARLEY;BARLEY;MALT BARLEY + ;;BASIL;BASIL + ;;BEANS;BEANS;LEGUMES + ;;BEANS, BAKED;BAKED BEANS + ;;BEANS, FAVA;FAVA BEANS (BROAD BEANS) + ;;BEANS, GREEN;GREEN BEANS + ;;BEANS, LENTILS;LENTILS + ;;BEANS, LIMA;LIMA BEANS + ;;BEANS, PINTO;PINTO BEANS + ;;BEANS, SOY;SOYBEANS + ;;BEANS, STRING;STRING BEANS + ;;BEANS, WHITE;WHITE BEANS + ;;BEEF;BEEF;BEEF PRODUCTS + ;;BEEF, CORNED;CORNED BEEF + ;;BEETS;BEETS + ;;BEETS, PICKLES;PICKLED BEETS + ;;BERRIES;BERRIES + ;;BLACKBERRIES;BLACKBERRIES + ;;BLUEBERRIES;BLUEBERRIES + ;;BROCCOLI;BROCCOLI + ;;BRUSSELS SPROUTS;BRUSSELS SPROUTS + ;;BUCKWHEAT;BUCKWHEAT + ;;BUTTER;BUTTER + ;;CABBAGE;CABBAGE + ;;CAFFEINE;CAFFEINE;COFFEE;COFFEE BEANS + ;;CAFFEINE, COLAS;COLA DRINKS + ;;CANTALOUPE;CANTALOUPE + ;;CARBONATED BEVERAGES;CARBONATED BEVERAGES;SOFT DRINKS + ;;CARROTS;CARROTS + ;;CATSUP;CATSUP + ;;CAULIFLOWER;CAULIFLOWER + ;;CAVIAR;CAVIAR + ;;CELERY;CELERY + ;;CEREAL;CEREALS + ;;CEREAL, CORNFLAKES;CORNFLAKES + ;;CEREAL, CRM OF WHEAT;CREAM OF WHEAT + ;;CEREAL, GRITS;GRITS + ;;CEREAL, OATMEAL;OATMEAL + ;;CHEESE;CHEESE + ;;CHEESE, BLUE;BLUE CHEESE + ;;CHEESE, CHEDDAR;CHEDDAR CHEESE + ;;CHEESE, COTTAGE;COTTAGE CHEESE + ;;CHEESE, FETA;FETA CHEESE + ;;CHEESE, GOAT;GOAT CHEESE + ;;CHEESE, PARMESAN;PARMESAN CHEESE + ;;CHEESE, RICOTTA;RICOTTA CHEESE + ;;CHEESE, SWISS;SWISS CHEESE + ;;CHERRIES;CHERRIES;CHERRY JUICE + ;;CHICKEN;CHICKEN + ;;CHICKPEAS;CHICKPEAS + ;;CHICORY;CHICORY + ;;CHILI;CHILI + ;;CHIVES;CHIVES + ;;CHOCOLATE;CHOCOLATE;COCOA + ;;CILANTRO;CILANTRO;CUMIN + ;;CINNAMON;CINNAMON;CINNAMON OIL + ;;CITRUS;CITRUS;CITRUS FRUIT;CITRUS JUICE + ;;CLOVES;CLOVES + ;;COCONUT;COCONUTS + ;;COLA;COLA DRINKS + ;;CORN;CORN + ;;CRACKERS;CRACKERS + ;;CRACKERS, GRAHAM;GRAHAM CRACKERS + ;;CRANBERRIES;CRANBERRIES + ;;CREAM, SOUR;SOUR CREAM + ;;CREAMER, NON-DAIRY;NON-DAIRY CREAMER + ;;CREAMER, POWDER;POWDERED CREAMER + ;;CUCUMBERS;CUCUMBERS + ;;DAIRY PRODUCTS;DAIRY PRODUCTS + ;;DATES;DATES + ;;DILL;DILL + ;;DUCK;DUCK;WATERFOWL + ;;DYES, VEGETABLES;VEGETABLE DYES + ;;EGGNOG;EGGNOG + ;;EGGPLANT;EGGPLANT + ;;EGGS;EGGS;EGG PRODUCTS;EGG WHITES;EGG YOLKS + ;;EGGS, SUBSTITUTES;EGG, SUBSTITUTES + ;;FAT EMULSIONS;FAT EMULSIONS + ;;FIGS;FIGS + ;;FISH;FISH + ;;FISH, ABALONE;ABALONE + ;;FISH, ANCHOVIES;ANCHOVIES + ;;FISH, CATFISH;CATFISH + ;;FISH, COD;CODFISH + ;;FISH, FLOUNDER;FLOUNDER + ;;FISH, HERRING;HERRING + ;;FISH, MACKEREL;MACKEREL + ;;FISH, PERCH;PERCH + ;;FISH, RED SNAPPER;RED SNAPPER + ;;FISH, SALMON;SALMON + ;;FISH, SARDINES;SARDINES + ;;FISH, SHARK;SHARK + ;;FISH, SWORDFISH;SWORDFISH + ;;FISH, TROUT;TROUT + ;;FISH, TUNA;TUNA + ;;FISH, WHITE;WHITE FISH + ;;FLAVORING, HICKORY;HICKORY + ;;FLAVORING, LICORICE;LICORICE + ;;FLAVORING, VANILLA;VANILLA + ;;FOOD PRESERVATIVES;FOOD PRESERVATIVES + ;;FRUIT, FRESH;FRESH FRUIT + ;;FROG;FROG LEGS;FROGS + ;;FRUIT;FRUIT + ;;FRUIT JUICE;FRUIT JUICE + ;;FRUITCAKES;FRUITCAKES + ;;GARLIC;GARLIC + ;;GELATIN;GELATIN + ;;GINGER;GINGER + ;;GLUTEN;GLUTENS + ;;GRAINS;GRAINS + ;;GRAPEFRUIT;GRAPEFRUIT + ;;GRAPES;GRAPES + ;;GRAVY;GRAVY + ;;GREENS, COLLARD;COLLARD GREENS + ;;GREENS, MUSTARD;MUSTARD GREENS + ;;GREENS, TURNIP;TURNIP GREENS + ;;GREEN LEAFY VEGETABLES;GREEN LEAFY VEGETABLES + ;;GUAVA;GUAVA + ;;HOMINY;HOMINY + ;;HONEY;HONEY + ;;HONEYDEW;HONEYDEW + ;;HORSERADISH;HORSERADISH + ;;IODINE;IODIZED SALT + ;;JUICE;JUICE + ;;KIWI;KIWI FRUIT + ;;LACTOSE;LACTOSE + ;;LEEKS;LEEKS + ;;LEMON;LEMON JUICE;LEMONS + ;;LETTUCE;LETTUCE + ;;LIMES;LIMES + ;;LYCHEE NUTS;LYCHEES + ;;MALTOSE;MALTOSE + ;;MANGOS;MANGOS + ;;MARSHMALLOWS;MARSHMALLOWS + ;;MAYONNAISE;MAYONNAISE + ;;MEAT;MEAT + ;;MEAT, LAMB;LAMB + ;;MEAT, LIVER;LIVER + ;;MEAT, PROCESSED;PROCESSED MEATS + ;;MEAT, RED;RED MEAT + ;;MEAT, VENISON;VENISON + ;;MELONS;MELONS + ;;MELONS, MUSK;MUSK MELONS + ;;MELONS, WATER;WATERMELONS + ;;MILK;MILK;DAIRY PRODUCTS + ;;MILK, BUTTER;BUTTERMILK + ;;MILK, GOAT;GOAT MILK + ;;MILK, YOGURT;YOGURT + ;;MINT;MINT + ;;MODIFIED FOOD STARCH;MODIFIED FOOD STARCH;FOOD STARCH, MODIFIED + ;;MSG;MONOSODIUM GLUTAMATE + ;;MUSHROOMS;MUSHROOMS + ;;MUSTARD;MUSTARD + ;;MUTTON/LAMB;MUTTON + ;;NECTARINES;NECTARINES + ;;NITRITES;NITRITES + ;;NON-FOOD RELATED;EGGSHELLS + ;;NUTMEG;NUTMEG + ;;NUTS;BRAZIL NUTS;CASHEWS;CHESTNUTS;HAZELNUTS;MACADAMIA NUTS;NUTS;PECANS + ;;NUTS, PEANUT;PEANUT BUTTER;PEANUT OIL;PEANUTS + ;;NUTS, PINE;PINE NUTS + ;;NUTS, PISTACHIOS;PISTACHIOS + ;;NUTS, TREE;PECANS;TREE NUTS + ;;NUTS, WALNUT;WALNUTS + ;;OATS;OATS + ;;OIL, COCONUT;COCONUT OIL + ;;OIL, COTTONSEED;COTTONSEED OIL + ;;OIL, PALM;PALM OIL + ;;OIL, SAFFLOWER;SAFFLOWER OIL + ;;OIL, SOY;SOYBEAN OIL + ;;OIL, SUNFLOWER;SUNFLOWER OIL + ;;OKRA;OKRA + ;;OLIVES;BLACK OLIVES;OLIVES + ;;ONIONS;ONIONS + ;;ONIONS, RED;RED ONIONS + ;;ORANGE;ORANGE;ORANGES;ORANGE JUICE;ORANGE OIL + ;;OREGANO;OREGANO + ;;OYSTERS;OYSTERS + ;;PAPAYAS;PAPAYAS + ;;PAPRIKA;PAPRIKA + ;;PARSLEY;PARSLEY + ;;PARSNIP;PARSNIP + ;;PASSION FRUIT;PASSION FRUIT + ;;PEACHES;PEACHES + ;;PEARS;PEARS + ;;PEAS;PEAS + ;;PEAS, BLACK-EYED;BLACK-EYED PEAS + ;;PEAS, ENGLISH;ENGLISH PEAS + ;;PEAS, SNOW;SNOW PEAS + ;;PEPPER;PEPPER;WHITE PEPPER + ;;PEPPER, BLACK;BLACK PEPPER;PEPPER + ;;PEPPERMINT;PEPPERMINT + ;;PEPPERONI;PEPPERONI + ;;PEPPERS;BELL PEPPERS;PEPPERS + ;;PEPPERS, CHILI;CHILI PEPPER;CHILI PEPPERS + ;;PEPPERS, GREEN;GREEN BELL PEPPERS;PEPPERS + ;;PEPPERS, HOT;CAPSAICIN;CAYENNE PEPPER;HOT PEPPER;HOT PEPPERS;JALAPENO PEPPERS + ;;PEPPERS, RED;RED BELL PEPPERS + ;;PERSIMMONS;PERSIMMONS + ;;PHEASANT;PHEASANT + ;;PICKLES;PICKLES + ;;PIMENTOS;PIMENTOS + ;;PINEAPPLE;PINEAPPLES + ;;PIZZA;PIZZA + ;;PLUMS;PLUMS + ;;POPCORN;POPCORN + ;;POPPY SEEDS;POPPY SEEDS + ;;PORK;PORK;PORK PRODUCTS;HAM + ;;PORK, HAM;HAM + ;;POTATOES;POTATOES + ;;POTATOES, SALAD;POTATO SALAD + ;;POTATOES, SWEET/YAMS;SWEET POTATOES;YAMS + ;;POULTRY;FOWL;POULTRY + ;;PRUNES;PRUNES + ;;PUDDING, TAPIOCA;TAPIOCA PUDDING + ;;PUMPKIN;PUMPKINS + ;;RABBIT;RABBIT + ;;RADISH;RADISHES + ;;RAISINS;RAISINS + ;;RASPBERRIES;RASPBERRIES + ;;RED DYES;FD&C RED DYE #1;FD&C RED DYE #2;FD&C RED DYE #3;FD&C RED DYE #40;FD&C RED DYE #40 LAKE;FD&C RED DYE #5;RED DYES + ;;RHUBARB;RHUBARB + ;;RICE;RICE;WHITE RICE + ;;ROSEMARY;ROSEMARY + ;;RUTABAGAS;RUTABAGAS + ;;RYE;RYE + ;;SALAD DRESSING, ITAL;ITALIAN DRESSING + ;;SALT;NON-IODIZED SALT;SALT + ;;SALT, SUBSTITUTES;SALT SUBSTITUTES + ;;SAUERKRAUT;SAUERKRAUT + ;;SAUSAGES;SAUSAGES + ;;SEAFOOD;SEAFOOD + ;;SEEDS;SEEDS + ;;SEEDS, SUNFLOWER;SUNFLOWER SEEDS + ;;SESAME;SESAME;SESAME OIL;SESAME SEEDS + ;;SHELLFISH;CLAMS;CRAB;CRAWFISH;CRUSTACEANS;LOBSTER;MUSSELS;SCALLOPS;SHELL FISH;SHELLFISH + ;;SHERBET;SHERBET + ;;SHRIMP;SHRIMP + ;;SNAILS;SNAILS + ;;SOUR CREAM;SOUR CREAM + ;;SOY;SOY;SOY MILK;SOY PRODUCTS;SOY SAUCE;SOYBEANS;TOFU + ;;SOY SAUCE;SOY SAUCE + ;;SPAGHETTI;SPAGHETTI + ;;SPAM;SPAM + ;;SPICES;CONDIMENTS;SPICES + ;;SPINACH;SPINACH + ;;SQUASH;SQUASH + ;;SQUID;SQUID + ;;STARCHY FOODS;STARCHES + ;;STRAWBERRIES;STRAWBERRIES;STRAWBERRIES PLUS + ;;SUCRALOSE;SUCRALOSE + ;;SUGAR;SUGAR;SUGAR BEETS;WHITE SUGAR + ;;SUGAR SUB;ARTIFICIAL SWEETENERS + ;;SUGAR SUB, ASPARTAME;ASPARTAME + ;;SUGAR SUB, SACCHARIN;SACCHARIN;SWEET'N LOW + ;;SUGAR, BROWN;BROWN SUGAR + ;;SULFITES;SULFITES + ;;SYRUP, MAPLE;MAPLE SYRUP + ;;TANGERINES;TANGERINES + ;;TARRAGON;TARRAGON + ;;TEA;TEA + ;;TOFFEE;TOFFEE + ;;TOMATO;TOMATO;TOMATO JUICE;TOMATO PRODUCTS;TOMATO SAUCE;TOMATOES + ;;TOMATOES, FRESH;FRESH TOMATOES + ;;TUMERIC;TUMERIC + ;;TURKEY;TURKEY + ;;TURNIPS;TURNIPS + ;;VEAL;VEAL + ;;VEGETABLES;VEGETABLES + ;;VEGETABLES, GREEN;GREEN VEGETABLES + ;;VINEGAR;VINEGAR + ;;WATERFOWL;WATERFOWL + ;;WHEAT;FLOUR;WHEAT + ;;WHEY;WHEY + ;;WINE, RED;RED WINE + ;;YEAST;YEAST + ;;YELLOW DYES;FD&C YELLOW DYE #10;FD&C YELLOW DYE #2;FD&C YELLOW DYE #5;FD&C YELLOW DYE #6;FD&C YELLOW DYE #6 LAKE;TARTRAZINE;YELLOW DYES + ;;ZUCCHINI;ZUCCHINI diff --git a/r/DRUG_ACCOUNTABILITY-PSA/PSABRKU3.m b/r/DRUG_ACCOUNTABILITY-PSA/PSABRKU3.m index e8c6f789..4fc16234 100644 --- a/r/DRUG_ACCOUNTABILITY-PSA/PSABRKU3.m +++ b/r/DRUG_ACCOUNTABILITY-PSA/PSABRKU3.m @@ -1,109 +1,100 @@ -PSABRKU3 ;BIR/JMB/PDW-Upload and Process Prime Vendor Invoice Data - CONT'D ;8/13/97 - ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**26,41,47,67**; 10/24/97;Build 15 - ;Checking the X12 invoice data. - S (PSASTCNT,PSAITCNT,PSACTRL(1))=0 - K ^TMP($J,"PSAPV SET"),PSAERR - S PSALAST="" - S PSALINE=0 F S PSALINE=$O(^TMP($J,"PSAPVS",PSALINE)) Q:PSALINE="" S PSADATA=^(PSALINE) D - .;check segment order - .D ^PSABRKU5 S PSALAST=$P(PSADATA,"^") -ISA .;control header - .I PSALAST="ISA" D Q - ..S PSASTCNT=0 - ..S PSAISA=PSADATA,PSACTRL="" I $L($P(PSADATA,"^",14))'=9 S PSASEG="ISA" D MSG^PSABRKU8 - .; -IEA .;control trailer - .I PSALAST="IEA" D Q - ..I $P(PSADATA,"^",3)'=$P(PSAISA,"^",14) S PSASEG="IEA" D MSG^PSABRKU8 - .; -GS .;group header - .I PSALAST="GS" S PSAGS=PSADATA D Q - ..F %=3,4 S PSAPC=$S(%=3:7,1:9) I $P(PSADATA,"^",%)'=$TR($P(PSAISA,"^",PSAPC)," ") S PSASEG="GS" D MSG^PSABRKU8 - .; -GE .;group trailer - .I PSALAST="GE" D Q - ..I $P(PSADATA,"^",3)'=$P($G(PSAGS),"^",7) S PSASEG="GE" D MSG^PSABRKU8 - .; -ST .;set header - .I PSALAST="ST" D Q - ..S PSAST=PSADATA,PSACTRL=$P(PSADATA,"^",3),PSASTCNT=1,PSAITCNT=0,PSANTYPE="" - ..I $L(PSACTRL)<4!($L(PSACTRL)>10) S PSASEG="ST" D MSG^PSABRKU8 Q - .. I PSACTRL="0001" S PSACTRL=0 D RESETST - ..;PSA*3*41 - McKesson probability of multiple files, may have to - ..;increment transaction set control numbers in 'ST' & 'SE' - ..I $D(^TMP($J,"PSAPV SET",PSACTRL,"IN")) D RESETST - ..I $D(^XTMP("PSAPV",PSACTRL)) D RESETST ;may already be on file - .; -SE .;set trailer - .I PSALAST="SE" S PSASTCNT=PSASTCNT+1 D Q - ..I $G(PSACTRL(1))'>0,$P(PSADATA,"^",3)'=PSACTRL S PSASEG="SE1" D MSG^PSABRKU8 Q - ..I PSASTCNT'=$P(PSADATA,"^",2) S PSASEG="SE2" D MSG^PSABRKU8 - .; -BIG .;beginning segment for invoice - .I PSALAST="BIG" S PSASTCNT=PSASTCNT+1 D Q - ..I $P(PSADATA,"^",4)="" S $P(PSADATA,"^",4)=$P(PSADATA,"^",2) - ..S $P(PSADATA,"^",5)=$TR($P(PSADATA,"^",5)," ") - ..S ^TMP($J,"PSAPV SET",PSACTRL,"IN")=$P(PSADATA,"^",2,5) - .; -REF .;(not used) - .I PSALAST="REF" S PSASTCNT=PSASTCNT+1 Q - .; - .;buyer, seller, shipping addresses -N1 .I PSALAST="N1" S PSASTCNT=PSASTCNT+1,PSANTYPE=$P(PSADATA,"^",2) D Q - ..I PSANTYPE'="BY",PSANTYPE'="DS",PSANTYPE'="ST" S PSASEG="N1" D MSG^PSABRKU8 Q - ..S ^TMP($J,"PSAPV SET",PSACTRL,PSANTYPE)=$P(PSADATA,"^",3) - .; -N2 .I PSALAST="N2" D Q - ..D:PSANTYPE="" NTYPE - ..S $P(^TMP($J,"PSAPV SET",PSACTRL,PSANTYPE),"^",2)=$P(PSADATA,"^",2) S PSASTCNT=PSASTCNT+1 - .; -N3 .I PSALAST="N3" D Q - ..D:PSANTYPE="" NTYPE - ..S $P(^TMP($J,"PSAPV SET",PSACTRL,PSANTYPE),"^",3)=$P(PSADATA,"^",2) S PSASTCNT=PSASTCNT+1 - .; -N4 .I PSALAST="N4" D Q - ..D:PSANTYPE="" NTYPE - ..S $P(^TMP($J,"PSAPV SET",PSACTRL,PSANTYPE),"^",4,6)=$P(PSADATA,"^",2,4) S PSASTCNT=PSASTCNT+1,PSANTYPE="" - .; -DTM .;date time reference - .I PSALAST="DTM" S PSASTCNT=PSASTCNT+1 D Q - ..S %=$S($P(PSADATA,"^",2)="002":5,$P(PSADATA,"^",2)="035":6,1:0) I '% Q - ..S $P(^TMP($J,"PSAPV SET",PSACTRL,"IN"),"^",%)=$P(PSADATA,"^",3) - .; -IT1 .;invoice line item - .I PSALAST="IT1" S PSASTCNT=PSASTCNT+1,PSAITCNT=PSAITCNT+1 D ITEM Q - .;BGN PSA*3*67 -PID .;generic vendor item name - .I PSALAST="PID" S PSASTCNT=PSASTCNT+1,$P(^TMP($J,"PSAPV SET",PSACTRL,"IT",PSAITEM),"^",29)=$S($P(PSADATA,"^",6)=$P(^TMP($J,"PSAPV SET",PSACTRL,"IT",PSAITEM),"^",28):"Unknown",1:$P(PSADATA,"^",6)) Q -PO4 .;DESCRIPTION OF ITEM - .I PSALAST="PO4" S PSASTCNT=PSASTCNT+1,$P(^TMP($J,"PSAPV SET",PSACTRL,"IT",PSAITEM),"^",30)=$P(PSADATA,"^",3)_"^"_$P(PSADATA,"^",9) D Q - .;END PSA*3*67 -CTT .;item count - .I PSALAST="CTT" S PSASTCNT=PSASTCNT+1 D Q - ..I PSAITCNT'=$P(PSADATA,"^",2) S PSASEG="CTT" D MSG^PSABRKU8 - .; -UNKNOWN .;Segment we don't use - .S PSASTCNT=PSASTCNT+1 - ; -ERROR S PSASEG=$O(PSAERR("")) D:PSASEG'="" ERROR^PSABRKU8 - Q - ; -NTYPE S PSASEG="NONTYPE" D NONTYPE^PSABRKU8 - Q - ; -ITEM ;check line item - I '$P(PSADATA,"^",2) S PSASEG="IT1-1" D MSG^PSABRKU8 Q - I $P(PSADATA,"^",6)'="DS" S PSASEG="IT1-2" D MSG^PSABRKU8 Q - I $P(PSADATA,"^",8)="",$P(PSADATA,"^",10)="",$P(PSADATA,"^",12)="" S PSASEG="IT1-3" D MSG^PSABRKU8 Q - ;"IT1" Seg=Qty Invoiced ^ Unit of Measure ^ Unit Price ^ Basic Unit Code "DS" ^ NDC ^ VSN - S PSAITEM=+$P(PSADATA,"^",2),^TMP($J,"PSAPV SET",PSACTRL,"IT",PSAITEM)=+$P(PSADATA,"^",3)_"^"_$P(PSADATA,"^",4)_"^"_$P(PSADATA,"^",5)_"^"_$P(PSADATA,"^",8)_"^"_$P(PSADATA,"^",10) - I $P(PSADATA,"^",12)'="",$P(PSADATA,"^",11)="UP" S $P(^TMP($J,"PSAPV SET",PSACTRL,"IT",PSAITEM),"^",26)=$P(PSADATA,"^",12) - ;Next line to add vendor Generic Description - I $P(PSADATA,"^",14)'="" S $P(^TMP($J,"PSAPV SET",PSACTRL,"IT",PSAITEM),"^",28)=$P(PSADATA,"^",14) - ;Eop67 - Q -RESETST ;Reset PSACTRL - S PSACTRL(1)=+PSACTRL+1,X1=PSACTRL(1) - S PSACTRL=X1 I $D(^TMP($J,"PSAPV SET",PSACTRL)) G RESETST - I $D(^XTMP("PSAPV",PSACTRL)) G RESETST - Q +PSABRKU3 ;BIR/JMB/PDW-Upload and Process Prime Vendor Invoice Data - CONT'D ;8/13/97 + ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**26,41,47**; 10/24/97 + ;Checking the X12 invoice data. + S (PSASTCNT,PSAITCNT,PSACTRL(1))=0 + K ^TMP($J,"PSAPV SET"),PSAERR + S PSALAST="" + S PSALINE=0 F S PSALINE=$O(^TMP($J,"PSAPVS",PSALINE)) Q:PSALINE="" S PSADATA=^(PSALINE) D + .;check segment order + .D ^PSABRKU5 S PSALAST=$P(PSADATA,"^") +ISA .;control header + .I PSALAST="ISA" D Q + ..S PSASTCNT=0 + ..S PSAISA=PSADATA,PSACTRL="" I $L($P(PSADATA,"^",14))'=9 S PSASEG="ISA" D MSG^PSABRKU8 + .; +IEA .;control trailer + .I PSALAST="IEA" D Q + ..I $P(PSADATA,"^",3)'=$P(PSAISA,"^",14) S PSASEG="IEA" D MSG^PSABRKU8 + .; +GS .;group header + .I PSALAST="GS" S PSAGS=PSADATA D Q + ..F %=3,4 S PSAPC=$S(%=3:7,1:9) I $P(PSADATA,"^",%)'=$TR($P(PSAISA,"^",PSAPC)," ") S PSASEG="GS" D MSG^PSABRKU8 + .; +GE .;group trailer + .I PSALAST="GE" D Q + ..I $P(PSADATA,"^",3)'=$P($G(PSAGS),"^",7) S PSASEG="GE" D MSG^PSABRKU8 + .; +ST .;set header + .I PSALAST="ST" D Q + ..S PSAST=PSADATA,PSACTRL=$P(PSADATA,"^",3),PSASTCNT=1,PSAITCNT=0,PSANTYPE="" + ..I $L(PSACTRL)<4!($L(PSACTRL)>10) S PSASEG="ST" D MSG^PSABRKU8 Q + .. I PSACTRL="0001" S PSACTRL=0 D RESETST + ..;PSA*3*41 - McKesson probability of multiple files, may have to + ..;increment transaction set control numbers in 'ST' & 'SE' + ..I $D(^TMP($J,"PSAPV SET",PSACTRL,"IN")) D RESETST + ..I $D(^XTMP("PSAPV",PSACTRL)) D RESETST ;may already be on file + .; +SE .;set trailer + .I PSALAST="SE" S PSASTCNT=PSASTCNT+1 D Q + ..I $G(PSACTRL(1))'>0,$P(PSADATA,"^",3)'=PSACTRL S PSASEG="SE1" D MSG^PSABRKU8 Q + ..I PSASTCNT'=$P(PSADATA,"^",2) S PSASEG="SE2" D MSG^PSABRKU8 + .; +BIG .;beginning segment for invoice + .I PSALAST="BIG" S PSASTCNT=PSASTCNT+1 D Q + ..I $P(PSADATA,"^",4)="" S $P(PSADATA,"^",4)=$P(PSADATA,"^",2) + ..S $P(PSADATA,"^",5)=$TR($P(PSADATA,"^",5)," ") + ..S ^TMP($J,"PSAPV SET",PSACTRL,"IN")=$P(PSADATA,"^",2,5) + .; +REF .;(not used) + .I PSALAST="REF" S PSASTCNT=PSASTCNT+1 Q + .; + .;buyer, seller, shipping addresses +N1 .I PSALAST="N1" S PSASTCNT=PSASTCNT+1,PSANTYPE=$P(PSADATA,"^",2) D Q + ..I PSANTYPE'="BY",PSANTYPE'="DS",PSANTYPE'="ST" S PSASEG="N1" D MSG^PSABRKU8 Q + ..S ^TMP($J,"PSAPV SET",PSACTRL,PSANTYPE)=$P(PSADATA,"^",3) + .; +N2 .I PSALAST="N2" D Q + ..D:PSANTYPE="" NTYPE + ..S $P(^TMP($J,"PSAPV SET",PSACTRL,PSANTYPE),"^",2)=$P(PSADATA,"^",2) S PSASTCNT=PSASTCNT+1 + .; +N3 .I PSALAST="N3" D Q + ..D:PSANTYPE="" NTYPE + ..S $P(^TMP($J,"PSAPV SET",PSACTRL,PSANTYPE),"^",3)=$P(PSADATA,"^",2) S PSASTCNT=PSASTCNT+1 + .; +N4 .I PSALAST="N4" D Q + ..D:PSANTYPE="" NTYPE + ..S $P(^TMP($J,"PSAPV SET",PSACTRL,PSANTYPE),"^",4,6)=$P(PSADATA,"^",2,4) S PSASTCNT=PSASTCNT+1,PSANTYPE="" + .; +DTM .;date time reference + .I PSALAST="DTM" S PSASTCNT=PSASTCNT+1 D Q + ..S %=$S($P(PSADATA,"^",2)="002":5,$P(PSADATA,"^",2)="035":6,1:0) I '% Q + ..S $P(^TMP($J,"PSAPV SET",PSACTRL,"IN"),"^",%)=$P(PSADATA,"^",3) + .; +IT1 .;invoice line item + .I PSALAST="IT1" S PSASTCNT=PSASTCNT+1,PSAITCNT=PSAITCNT+1 D ITEM Q +CTT .;item count + .I PSALAST="CTT" S PSASTCNT=PSASTCNT+1 D Q + ..I PSAITCNT'=$P(PSADATA,"^",2) S PSASEG="CTT" D MSG^PSABRKU8 + .; +UNKNOWN .;Segment we don't use + .S PSASTCNT=PSASTCNT+1 + ; +ERROR S PSASEG=$O(PSAERR("")) D:PSASEG'="" ERROR^PSABRKU8 + Q + ; +NTYPE S PSASEG="NONTYPE" D NONTYPE^PSABRKU8 + Q + ; +ITEM ;check line item + I '$P(PSADATA,"^",2) S PSASEG="IT1-1" D MSG^PSABRKU8 Q + I $P(PSADATA,"^",6)'="DS" S PSASEG="IT1-2" D MSG^PSABRKU8 Q + I $P(PSADATA,"^",8)="",$P(PSADATA,"^",10)="",$P(PSADATA,"^",12)="" S PSASEG="IT1-3" D MSG^PSABRKU8 Q + ;"IT1" Seg=Qty Invoiced ^ Unit of Measure ^ Unit Price ^ Basic Unit Code "DS" ^ NDC ^ VSN + S PSAITEM=+$P(PSADATA,"^",2),^TMP($J,"PSAPV SET",PSACTRL,"IT",PSAITEM)=+$P(PSADATA,"^",3)_"^"_$P(PSADATA,"^",4)_"^"_$P(PSADATA,"^",5)_"^"_$P(PSADATA,"^",8)_"^"_$P(PSADATA,"^",10) + I $P(PSADATA,"^",12)'="",$P(PSADATA,"^",11)="UP" S $P(^TMP($J,"PSAPV SET",PSACTRL,"IT",PSAITEM),"^",26)=$P(PSADATA,"^",12) + Q +RESETST ;Reset PSACTRL + S PSACTRL(1)=+PSACTRL+1,X1=PSACTRL(1) + S PSACTRL=X1 I $D(^TMP($J,"PSAPV SET",PSACTRL)) G RESETST + I $D(^XTMP("PSAPV",PSACTRL)) G RESETST + Q diff --git a/r/DRUG_ACCOUNTABILITY-PSA/PSABRKU5.m b/r/DRUG_ACCOUNTABILITY-PSA/PSABRKU5.m index 327e402c..bd696ac5 100644 --- a/r/DRUG_ACCOUNTABILITY-PSA/PSABRKU5.m +++ b/r/DRUG_ACCOUNTABILITY-PSA/PSABRKU5.m @@ -1,33 +1,42 @@ -PSABRKU5 ;BIR/DB-Upload and Process Prime Vendor Invoice Data - CONT'D ;7/23/97 - ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**26,67**; 10/24/97;Build 15 - ;This routine checks for correct X12 formating. - ; -ORDER ; check order of code sheets - S PSANEXT=$P(PSADATA,"^") - ; - I PSALAST="GE",PSANEXT="GS" Q - I PSALAST="GE",PSANEXT'="IEA" D ORDERROR("GE",PSANEXT,"IEA") Q - ; - I PSALAST="ISA",PSANEXT'="GS" D ORDERROR("ISA",PSANEXT,"GS") Q - ; - I PSALAST="SE",PSANEXT="ST" Q - I PSALAST="SE",PSANEXT'="GE" D ORDERROR("SE",PSANEXT,"GE") Q - ; - I PSALAST="GS",PSANEXT'="ST" D ORDERROR("GS",PSANEXT,"ST") Q - ; - I PSALAST="CTT",PSANEXT'="SE" D ORDERROR("CTT",PSANEXT,"SE") Q - ; - I PSALAST="ST",PSANEXT'="BIG" D ORDERROR("ST",PSANEXT,"BIG") Q - ; - ;adding next two lines for new format - I PSALAST="IT1",PSANEXT="PID" Q - I PSALAST="PO4",PSANEXT'="IT1",PSANEXT'="CTT"&(PSANEXT'="TDS") D ORDERROR("PO4",PSANEXT,"CTT") Q - ;End of PSA*3*67 Changes - Q - ; -ORDERROR(PSALAST,PSANEW,PSAEXPEC) ;Segments out of order - ;ISA segment should be first - I PSALAST="" S PSASEG="ORDER1" D MSG^PSABRKU8 Q - ;Segments other than ISA - S PSASEG="ORDER2" D MSG^PSABRKU8 - Q +PSABRKU5 ;BIR/JMB-Upload and Process Prime Vendor Invoice Data - CONT'D ;7/23/97 + ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**26**; 10/24/97 + ;This routine checks for correct X12 formating. + ; +ORDER ; check order of code sheets + ; isa <--------------+ + ; gs <----------+ | + ; st <------+ | | + ; | big | | | + ; | it1 <--+ | | | + ; | ... | | | |--repeats + ; | it1 <--+ | | | + ; | ctt | | | + ; se <------+ | | + ; ge <----------+ | + ; iea <--------------+ + S PSANEXT=$P(PSADATA,"^") + ; + I PSALAST="GE",PSANEXT="GS" Q + I PSALAST="GE",PSANEXT'="IEA" D ORDERROR("GE",PSANEXT,"IEA") Q + ; + I PSALAST="ISA",PSANEXT'="GS" D ORDERROR("ISA",PSANEXT,"GS") Q + ; + I PSALAST="SE",PSANEXT="ST" Q + I PSALAST="SE",PSANEXT'="GE" D ORDERROR("SE",PSANEXT,"GE") Q + ; + I PSALAST="GS",PSANEXT'="ST" D ORDERROR("GS",PSANEXT,"ST") Q + ; + I PSALAST="CTT",PSANEXT'="SE" D ORDERROR("CTT",PSANEXT,"SE") Q + ; + I PSALAST="ST",PSANEXT'="BIG" D ORDERROR("ST",PSANEXT,"BIG") Q + ; + I PSALAST="IT1",PSANEXT="IT1" Q + I PSALAST="IT1",PSANEXT'="CTT"&(PSANEXT'="TDS") D ORDERROR("IT1",PSANEXT,"CTT") Q + Q + ; +ORDERROR(PSALAST,PSANEW,PSAEXPEC) ;Segments out of order + ;ISA segment should be first + I PSALAST="" S PSASEG="ORDER1" D MSG^PSABRKU8 Q + ;Segments other than ISA + S PSASEG="ORDER2" D MSG^PSABRKU8 + Q diff --git a/r/DRUG_ACCOUNTABILITY-PSA/PSAENTO.m b/r/DRUG_ACCOUNTABILITY-PSA/PSAENTO.m index 393bb010..31cb2a94 100644 --- a/r/DRUG_ACCOUNTABILITY-PSA/PSAENTO.m +++ b/r/DRUG_ACCOUNTABILITY-PSA/PSAENTO.m @@ -1,104 +1,104 @@ -PSAENTO ;BIR/LTL,JMB-Set Up/Edit a Pharmacy Location - CONT'D ;7/23/97 - ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**12,21,43,63**; 10/24/97;Build 10 - ;This routines is called by PSAENT. - ; - ;References to global ^PRC(441 are covered by IA #214 - ;References to global ^PRCP(445 are covered by IA #214 - ;References to global ^PS(52.6, are covered by IA #270 - ;References to global ^PS(52.7 are covered by IA #770 - ;References to global ^PS(59, are covered by IA #212 - ;References to global ^PS(59.5 are covered by IA #1884 - ;References to global ^PSDRUG( are covered by IA #2095 - ;References to global ^PSDRUG("AB" are covered by IA #2095 - ; - ;External references to $$DESCR^PRCPUX1 are covered by IA #259 - ;External references to $$INVNAME^PRCPUX1 are covered by IA #259 - ; - ; - ; -OP G:$P($G(^PSD(58.8,+$G(PSALOC),0)),U,10) OPC - S Y=1 S PSA=$O(^PS(59,0)) D:$O(^PS(59,PSA)) G:Y<0 QUIT - .;more than one OP site - .W !!,"Because there is more than one Outpatient Site at this facility, I need you to " - .S DIC="^PS(59,",DIC(0)="AEMQ",DIC("A")="select an Outpatient Site: " D ^DIC K DIC S PSAOSIT=+Y - S:'$D(PSAOSIT) PSAOSIT=+$O(^PS(59,0)) - ;if IP changed to combined, check for existing OP and zap - I +$G(PSALOC),+$G(PSAOC),$O(^PSD(58.8,"AOP",+PSAOSIT,"")),($O(^PSD(58.8,"AOP",+PSAOSIT,""))'=$G(PSALOC)) S DIE="^PSD(58.8,",DA=$O(^PSD(58.8,"AOP",+PSAOSIT,"")),DR="20////@" D ^DIE K DIE - I $G(PSALOC),'$O(^PSD(58.8,"AOP",+PSAOSIT,"")) S DIE="^PSD(58.8,",DA=PSALOC,DR="20////^S X=+PSAOSIT" D ^DIE K DIE -DAVEB I '$O(^PSD(58.8,"AOP",+PSAOSIT,"")) D G:Y<0 QUIT - .;DAVE B (PSA*3*12) dic(0) was AEMQLZ; *43 added back Z - .S DIC="^PSD(58.8,",DIC(0)="AELXZ",DLAYGO=58.8,DIC("A")="Please select Location: ",DIC("B")=$S(PSAITY=2:"OUTPATIENT",PSAITY=3:"COMBINED (IP/OP)",1:"") - .S DIC("DR")="1////P;20////^S X=+PSAOSIT",DIC("S")="I $P($G(^(0)),U,2)=""P"",$S($P($G(^(0)),U,10):$P($G(^(0)),U,10)=+PSAOSIT,1:1)" - .S:PSAITY=3 DIC("W")="W ?30,""IP SITE: "",$P($G(^PS(59.4,+$P($G(^(0)),U,3),0)),U)" - .D ^DIC K DIC,DLAYGO S:Y>0 PSALOC=+Y,PSALOCN=Y(0,0) - S:'$D(PSALOC) PSALOC=$O(^PSD(58.8,"AOP",+PSAOSIT,"")),PSALOCN=$P($G(^PSD(58.8,+PSALOC,0)),U) -OPC W !!,"Outpatient site selection affects the collection of dispensing data.",! - S DIE="^PSD(58.8,",DA=PSALOC,DR="20//^S X=$P($G(^PS(59,+PSAOSIT,0)),U)" D ^DIE K DIE I $D(DTOUT)!($D(Y)) G QUIT ;; <3*63 RJS> - S PSAOSIT=+$P($G(^PSD(58.8,PSALOC,0)),"^",10) - G:'PSALOC QUIT - N PSADT,PSAT,PSAQTY,PSAY - G:$G(PSAPVMEN) DRUGS -ED S DIE=58.8,DA=PSALOC,DR="[PSAENT]" D ^DIE K DIE,DA G:$D(Y) QUIT G:'$D(PSAINV) DRUGS D:$O(^PRCP(445,PSAINV,1,0)) G:$D(DIRUT) QUIT -QUES .S DIR(0)="Y",DIR("A",1)="Would you like to loop through "_$$INVNAME^PRCPUX1($G(PSAINV))_"'S",DIR("A")="items to check for any new entries that are ready to load" - .S DIR("?")="I will check for items that are linked to the DRUG file but not yet stocked." - .W ! D ^DIR K DIR Q:'Y S PSAIT=0 D - ..S DIR(0)="Y",DIR("A")="Load inventory quantities also",DIR("B")="Yes",DIR("?")="Inventory quantities will be multiplied by the dispensing unit conversion factor." D ^DIR K DIR Q:$D(DIRUT) S:Y=1 PSAY=1 - ..S:'$D(^PSD(58.8,+PSALOC,1,0)) ^(0)="^58.8001IP^^" -LOOP ..F S PSAIT=$O(^PRCP(445,+PSAINV,1,PSAIT)) Q:'PSAIT I '$G(^PRC(441,PSAIT,3)),$O(^PSDRUG("AB",+PSAIT,0)) S PSADRUG=$O(^PSDRUG("AB",PSAIT,0)) D:'$D(^PSD(58.8,+PSALOC,1,+PSADRUG,0)) Q:$D(DIRUT) - ...Q:'$S('$D(^PSDRUG(PSADRUG,"I")):1,+^("I")>DT:1,1:0) - ...S DIR(0)="Y",DIR("A",1)="OK to load "_$P($G(^PSDRUG(PSADRUG,0)),U)_" from the DRUG file",DIR("A")="linked to inventory item: "_$$DESCR^PRCPUX1($G(PSAINV),$G(PSAIT)),DIR("B")="Yes" D ^DIR K DIR Q:Y<1 S X=PSADRUG - ...S:$G(PSAY) DIC("DR")="3//^S X=PSAQTY;S PSAQTY=X" -ITEM ...S DA(1)=PSALOC,DIC="^PSD(58.8,PSALOC,1,",DIC(0)="EMQL",DLAYGO=58.8,PSAQTY=$P($G(^PRCP(445,+PSAINV,1,PSAIT,0)),U,7)*$S($P($G(^(0)),U,29):$P(^(0),U,29),1:1) D ^DIC K DIC,DLAYGO Q:Y<0 - ...Q:'$G(PSAY) - ...W !,"Updating Beginning balance and transaction history.",! - ...D NOW^%DTC S PSADT=+$E(%,1,12) K % - ...S ^PSD(58.8,+PSALOC,1,+PSADRUG,5,0)="^58.801A^^" - ...S DIC="^PSD(58.8,+PSALOC,1,+PSADRUG,5,",DIC(0)="LM",(X,DINUM)=$E(DT,1,5)*100,DA(2)=PSALOC,DA(1)=PSADRUG,DIC("DR")="1////^S X=$G(PSAQTY);5////^S X=$G(PSAQTY)",DLAYGO=58.8 D ^DIC K DIC,DLAYGO - ...F L +^PSD(58.81,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q -FIND ...S PSAT=$P(^PSD(58.81,0),U,3)+1 I $D(^PSD(58.81,PSAT)) S $P(^PSD(58.81,0),U,3)=$P(^PSD(58.81,0),U,3)+1 G FIND - ...S DIC="^PSD(58.81,",DIC(0)="L",DLAYGO=58.81,(DINUM,X)=PSAT D ^DIC K DIC,DLAYGO L -^PSD(58.81,0) - ...S DIE="^PSD(58.81,",DA=PSAT,DR="1////11;2////^S X=PSALOC;3////^S X=PSADT;4////^S X=PSADRUG;5////^S X=PSAQTY;6////^S X=DUZ;9////0" D ^DIE K DIE - ...S:'$D(^PSD(58.8,+PSALOC,1,+PSADRUG,4,0)) ^(0)="^58.800119PA^^" - ...S DIC="^PSD(58.8,+PSALOC,1,+PSADRUG,4,",DLAYGO=58.8,DIC(0)="L",(X,DINUM)=PSAT - ...S DA(2)=PSALOC,DA(1)=PSADRUG D ^DIC K DA,DIC,DLAYGO - ...I $O(^PS(52.6,"AC",+PSADRUG,0))!($O(^PS(52.7,"AC",+PSADRUG,0))) S PSAIT(1)=PSAIT,PSAIT(2)=$P($G(^PSDRUG(+PSADRUG,0)),U),PSAIT(4)=$G(^PSDRUG(+PSADRUG,660)),PSAIT=PSADRUG D ^PSAPSI4 S PSAIT=PSAIT(1) -DRUGS W ! S DIR(0)="Y",DIR("A")="Add/edit drugs",DIR("B")="No" D ^DIR K DIR D:Y=1 ^PSADRUG - Q:'+$G(PSAOSIT) -IV I '$O(^PSD(58.8,PSALOC,3.5,0)) W ! S DIR(0)="Y",DIR("A")="Does the outpatient site dispense IVs to IV rooms",DIR("B")="No" D ^DIR K DIR G:Y=0 QUIT - S PSALEN=$L($P($G(^PS(59,+PSAOSIT,0)),"^")),PSALEN=PSALEN+16 -IV1 W @IOF,!?((80-PSALEN)/2),$P($G(^PS(59,+PSAOSIT,0)),"^")_" Outpatient Site",!! - I $O(^PSD(58.8,PSALOC,3.5,0)) D - .W "Currently linked IV Rooms:" S PSANOW=0 - .F S PSANOW=$O(^PSD(58.8,PSALOC,3.5,PSANOW)) Q:'PSANOW S PSANOW($P($G(^PS(59.5,PSANOW,0)),"^"))="" - .S PSANOW="" F S PSANOW=$O(PSANOW(PSANOW)) Q:PSANOW="" W ?27,PSANOW,! - S DIR(0)="SAO^L:Link;U:Unlink",DIR("A")="Link or unlink IV rooms (L/U): " D ^DIR K DIR G:$G(DIRUT) QUIT G:Y="U" UNLINK - W !!,"Enter the IV rooms that receive IVs from the outpatient site.",! - K DIC S DIC="^PS(59.5,",DIC(0)="AEQZ" - F D ^DIC Q:$G(DTOUT)!($G(DUOUT))!(Y<0) D - .S PSAIVLOC=+$O(^PSD(58.8,"AIV",+Y,0)) - .I PSAIVLOC,PSAIVLOC'=PSALOC W !!,"<< "_Y(0,0)_" is already linked to the "_$P($G(^PS(59,+$P($G(^PSD(58.8,PSALOC,0)),"^",10),0)),"^"),!?4,"outpatient site in the "_$P($G(^PSD(58.8,PSALOC,0)),"^")_" pharmacy location. >>",! K Y Q - .I PSAIVLOC,PSAIVLOC=PSALOC W !!,"<< "_Y(0,0)_" is already linked to this outpatient site. >>",! K Y Q - .S:$D(Y(0,0)) PSAIV(Y(0,0))=+Y - K DIC S PSAIV=$O(PSAIV("")) I PSAIV="" W !!,"<< No IV rooms were selected to be linked to the Outpatient site. >>",! G QUIT - W @IOF W !?((80-PSALEN)/2),$P($G(^PS(59,+PSAOSIT,0)),"^")_" Outpatient Site",!!,"IV rooms to be linked:" - S PSAIV="" F S PSAIV=$O(PSAIV(PSAIV)) Q:PSAIV="" W ?23,PSAIV,! - S DIR(0)="Y",DIR("A")="Should the IV rooms be linked",DIR("B")="N" D ^DIR K DIR I 'Y K PSAIV G IV1 - S:'$D(^PSD(58.8,PSALOC,3.5,0)) ^PSD(58.8,PSALOC,3.5,0)="^58.831P^^" - W ! S DIC="^PSD(58.8,"_PSALOC_",3.5,",DIC(0)="ML",PSAIV="" K DD,DO - W !,"Linking IV rooms" - F S PSAIV=$O(PSAIV(PSAIV)) Q:PSAIV="" K DD,DO S (X,DINUM)=PSAIV(PSAIV),DA(1)=PSALOC D FILE^DICN W "." - W !,"The IV rooms were linked successfully." - K DIC,PSAIV,DINUM,X -QUIT Q -UNLINK ;Unlink IV Rooms - S DIR(0)="Y",DIR("B")="N",PSANOW="" W ! - F S PSANOW=$O(PSANOW(PSANOW)) Q:PSANOW="" S DIR("A")="Unlink "_PSANOW D ^DIR Q:$G(DIRUT) I Y S PSANOW(PSANOW)=Y,PSADEL(PSANOW)="" - S PSANOW="",PSADEL=$O(PSADEL(PSANOW)) - W @IOF,!?((80-PSALEN)/2),$P($G(^PS(59,+PSAOSIT,0)),"^")_" Outpatient Site",!! - I PSADEL'="" W !,"To be unlinked:" S PSANOW="" D - .F S PSANOW=$O(PSADEL(PSANOW)) Q:PSANOW="" W ?16,PSANOW,! - .W ! S DIR(0)="Y",DIR("B")="N",DIR("A")="Okay to unlink the IV Rooms" D ^DIR K DIR Q:$G(DIRUT) I 'Y W !,"No IV rooms were unlinked." Q - .W !,"Unlinking IV rooms" - .S PSANOW="",DIE="^PSD(58.8,"_PSALOC_",3.5,",DA(1)=PSALOC F S PSANOW=$O(PSADEL(PSANOW)) Q:PSANOW="" S DA=$O(^PS(59.5,"B",PSANOW,0)),DR=".01///@" D ^DIE W "." - .K DIE W !,"IV rooms unlinked." - Q +PSAENTO ;BIR/LTL,JMB-Set Up/Edit a Pharmacy Location - CONT'D ;7/23/97 + ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**12,21,43**; 10/24/97 + ;This routines is called by PSAENT. + ; + ;References to global ^PRC(441 are covered by IA #214 + ;References to global ^PRCP(445 are covered by IA #214 + ;References to global ^PS(52.6, are covered by IA #270 + ;References to global ^PS(52.7 are covered by IA #770 + ;References to global ^PS(59, are covered by IA #212 + ;References to global ^PS(59.5 are covered by IA #1884 + ;References to global ^PSDRUG( are covered by IA #2095 + ;References to global ^PSDRUG("AB" are covered by IA #2095 + ; + ;External references to $$DESCR^PRCPUX1 are covered by IA #259 + ;External references to $$INVNAME^PRCPUX1 are covered by IA #259 + ; + ; + ; +OP G:$P($G(^PSD(58.8,+$G(PSALOC),0)),U,10) OPC + S Y=1 S PSA=$O(^PS(59,0)) D:$O(^PS(59,PSA)) G:Y<0 QUIT + .;more than one OP site + .W !!,"Because there is more than one Outpatient Site at this facility, I need you to " + .S DIC="^PS(59,",DIC(0)="AEMQ",DIC("A")="select an Outpatient Site: " D ^DIC K DIC S PSAOSIT=+Y + S:'$D(PSAOSIT) PSAOSIT=+$O(^PS(59,0)) + ;if IP changed to combined, check for existing OP and zap + I +$G(PSALOC),+$G(PSAOC),$O(^PSD(58.8,"AOP",+PSAOSIT,"")),($O(^PSD(58.8,"AOP",+PSAOSIT,""))'=$G(PSALOC)) S DIE="^PSD(58.8,",DA=$O(^PSD(58.8,"AOP",+PSAOSIT,"")),DR="20////@" D ^DIE K DIE + I $G(PSALOC),'$O(^PSD(58.8,"AOP",+PSAOSIT,"")) S DIE="^PSD(58.8,",DA=PSALOC,DR="20////^S X=+PSAOSIT" D ^DIE K DIE +DAVEB I '$O(^PSD(58.8,"AOP",+PSAOSIT,"")) D G:Y<0 QUIT + .;DAVE B (PSA*3*12) dic(0) was AEMQLZ; *43 added back Z + .S DIC="^PSD(58.8,",DIC(0)="AELXZ",DLAYGO=58.8,DIC("A")="Please select Location: ",DIC("B")=$S(PSAITY=2:"OUTPATIENT",PSAITY=3:"COMBINED (IP/OP)",1:"") + .S DIC("DR")="1////P;20////^S X=+PSAOSIT",DIC("S")="I $P($G(^(0)),U,2)=""P"",$S($P($G(^(0)),U,10):$P($G(^(0)),U,10)=+PSAOSIT,1:1)" + .S:PSAITY=3 DIC("W")="W ?30,""IP SITE: "",$P($G(^PS(59.4,+$P($G(^(0)),U,3),0)),U)" + .D ^DIC K DIC,DLAYGO S:Y>0 PSALOC=+Y,PSALOCN=Y(0,0) + S:'$D(PSALOC) PSALOC=$O(^PSD(58.8,"AOP",+PSAOSIT,"")),PSALOCN=$P($G(^PSD(58.8,+PSALOC,0)),U) +OPC W !!,"Outpatient site selection affects the collection of dispensing data.",! + S DIE="^PSD(58.8,",DA=PSALOC,DR="20//^S X=$P($G(^PS(59,+PSAOSIT,0)),U)" D ^DIE K DIE G:$D(Y) QUIT + S PSAOSIT=+$P($G(^PSD(58.8,PSALOC,0)),"^",10) + G:'PSALOC QUIT + N PSADT,PSAT,PSAQTY,PSAY + G:$G(PSAPVMEN) DRUGS +ED S DIE=58.8,DA=PSALOC,DR="[PSAENT]" D ^DIE K DIE,DA G:$D(Y) QUIT G:'$D(PSAINV) DRUGS D:$O(^PRCP(445,PSAINV,1,0)) G:$D(DIRUT) QUIT +QUES .S DIR(0)="Y",DIR("A",1)="Would you like to loop through "_$$INVNAME^PRCPUX1($G(PSAINV))_"'S",DIR("A")="items to check for any new entries that are ready to load" + .S DIR("?")="I will check for items that are linked to the DRUG file but not yet stocked." + .W ! D ^DIR K DIR Q:'Y S PSAIT=0 D + ..S DIR(0)="Y",DIR("A")="Load inventory quantities also",DIR("B")="Yes",DIR("?")="Inventory quantities will be multiplied by the dispensing unit conversion factor." D ^DIR K DIR Q:$D(DIRUT) S:Y=1 PSAY=1 + ..S:'$D(^PSD(58.8,+PSALOC,1,0)) ^(0)="^58.8001IP^^" +LOOP ..F S PSAIT=$O(^PRCP(445,+PSAINV,1,PSAIT)) Q:'PSAIT I '$G(^PRC(441,PSAIT,3)),$O(^PSDRUG("AB",+PSAIT,0)) S PSADRUG=$O(^PSDRUG("AB",PSAIT,0)) D:'$D(^PSD(58.8,+PSALOC,1,+PSADRUG,0)) Q:$D(DIRUT) + ...Q:'$S('$D(^PSDRUG(PSADRUG,"I")):1,+^("I")>DT:1,1:0) + ...S DIR(0)="Y",DIR("A",1)="OK to load "_$P($G(^PSDRUG(PSADRUG,0)),U)_" from the DRUG file",DIR("A")="linked to inventory item: "_$$DESCR^PRCPUX1($G(PSAINV),$G(PSAIT)),DIR("B")="Yes" D ^DIR K DIR Q:Y<1 S X=PSADRUG + ...S:$G(PSAY) DIC("DR")="3//^S X=PSAQTY;S PSAQTY=X" +ITEM ...S DA(1)=PSALOC,DIC="^PSD(58.8,PSALOC,1,",DIC(0)="EMQL",DLAYGO=58.8,PSAQTY=$P($G(^PRCP(445,+PSAINV,1,PSAIT,0)),U,7)*$S($P($G(^(0)),U,29):$P(^(0),U,29),1:1) D ^DIC K DIC,DLAYGO Q:Y<0 + ...Q:'$G(PSAY) + ...W !,"Updating Beginning balance and transaction history.",! + ...D NOW^%DTC S PSADT=+$E(%,1,12) K % + ...S ^PSD(58.8,+PSALOC,1,+PSADRUG,5,0)="^58.801A^^" + ...S DIC="^PSD(58.8,+PSALOC,1,+PSADRUG,5,",DIC(0)="LM",(X,DINUM)=$E(DT,1,5)*100,DA(2)=PSALOC,DA(1)=PSADRUG,DIC("DR")="1////^S X=$G(PSAQTY);5////^S X=$G(PSAQTY)",DLAYGO=58.8 D ^DIC K DIC,DLAYGO + ...F L +^PSD(58.81,0):0 I Q +FIND ...S PSAT=$P(^PSD(58.81,0),U,3)+1 I $D(^PSD(58.81,PSAT)) S $P(^PSD(58.81,0),U,3)=$P(^PSD(58.81,0),U,3)+1 G FIND + ...S DIC="^PSD(58.81,",DIC(0)="L",DLAYGO=58.81,(DINUM,X)=PSAT D ^DIC K DIC,DLAYGO L -^PSD(58.81,0) + ...S DIE="^PSD(58.81,",DA=PSAT,DR="1////11;2////^S X=PSALOC;3////^S X=PSADT;4////^S X=PSADRUG;5////^S X=PSAQTY;6////^S X=DUZ;9////0" D ^DIE K DIE + ...S:'$D(^PSD(58.8,+PSALOC,1,+PSADRUG,4,0)) ^(0)="^58.800119PA^^" + ...S DIC="^PSD(58.8,+PSALOC,1,+PSADRUG,4,",DLAYGO=58.8,DIC(0)="L",(X,DINUM)=PSAT + ...S DA(2)=PSALOC,DA(1)=PSADRUG D ^DIC K DA,DIC,DLAYGO + ...I $O(^PS(52.6,"AC",+PSADRUG,0))!($O(^PS(52.7,"AC",+PSADRUG,0))) S PSAIT(1)=PSAIT,PSAIT(2)=$P($G(^PSDRUG(+PSADRUG,0)),U),PSAIT(4)=$G(^PSDRUG(+PSADRUG,660)),PSAIT=PSADRUG D ^PSAPSI4 S PSAIT=PSAIT(1) +DRUGS W ! S DIR(0)="Y",DIR("A")="Add/edit drugs",DIR("B")="No" D ^DIR K DIR D:Y=1 ^PSADRUG + Q:'+$G(PSAOSIT) +IV I '$O(^PSD(58.8,PSALOC,3.5,0)) W ! S DIR(0)="Y",DIR("A")="Does the outpatient site dispense IVs to IV rooms",DIR("B")="No" D ^DIR K DIR G:Y=0 QUIT + S PSALEN=$L($P($G(^PS(59,+PSAOSIT,0)),"^")),PSALEN=PSALEN+16 +IV1 W @IOF,!?((80-PSALEN)/2),$P($G(^PS(59,+PSAOSIT,0)),"^")_" Outpatient Site",!! + I $O(^PSD(58.8,PSALOC,3.5,0)) D + .W "Currently linked IV Rooms:" S PSANOW=0 + .F S PSANOW=$O(^PSD(58.8,PSALOC,3.5,PSANOW)) Q:'PSANOW S PSANOW($P($G(^PS(59.5,PSANOW,0)),"^"))="" + .S PSANOW="" F S PSANOW=$O(PSANOW(PSANOW)) Q:PSANOW="" W ?27,PSANOW,! + S DIR(0)="SAO^L:Link;U:Unlink",DIR("A")="Link or unlink IV rooms (L/U): " D ^DIR K DIR G:$G(DIRUT) QUIT G:Y="U" UNLINK + W !!,"Enter the IV rooms that receive IVs from the outpatient site.",! + K DIC S DIC="^PS(59.5,",DIC(0)="AEQZ" + F D ^DIC Q:$G(DTOUT)!($G(DUOUT))!(Y<0) D + .S PSAIVLOC=+$O(^PSD(58.8,"AIV",+Y,0)) + .I PSAIVLOC,PSAIVLOC'=PSALOC W !!,"<< "_Y(0,0)_" is already linked to the "_$P($G(^PS(59,+$P($G(^PSD(58.8,PSALOC,0)),"^",10),0)),"^"),!?4,"outpatient site in the "_$P($G(^PSD(58.8,PSALOC,0)),"^")_" pharmacy location. >>",! K Y Q + .I PSAIVLOC,PSAIVLOC=PSALOC W !!,"<< "_Y(0,0)_" is already linked to this outpatient site. >>",! K Y Q + .S:$D(Y(0,0)) PSAIV(Y(0,0))=+Y + K DIC S PSAIV=$O(PSAIV("")) I PSAIV="" W !!,"<< No IV rooms were selected to be linked to the Outpatient site. >>",! G QUIT + W @IOF W !?((80-PSALEN)/2),$P($G(^PS(59,+PSAOSIT,0)),"^")_" Outpatient Site",!!,"IV rooms to be linked:" + S PSAIV="" F S PSAIV=$O(PSAIV(PSAIV)) Q:PSAIV="" W ?23,PSAIV,! + S DIR(0)="Y",DIR("A")="Should the IV rooms be linked",DIR("B")="N" D ^DIR K DIR I 'Y K PSAIV G IV1 + S:'$D(^PSD(58.8,PSALOC,3.5,0)) ^PSD(58.8,PSALOC,3.5,0)="^58.831P^^" + W ! S DIC="^PSD(58.8,"_PSALOC_",3.5,",DIC(0)="ML",PSAIV="" K DD,DO + W !,"Linking IV rooms" + F S PSAIV=$O(PSAIV(PSAIV)) Q:PSAIV="" K DD,DO S (X,DINUM)=PSAIV(PSAIV),DA(1)=PSALOC D FILE^DICN W "." + W !,"The IV rooms were linked successfully." + K DIC,PSAIV,DINUM,X +QUIT Q +UNLINK ;Unlink IV Rooms + S DIR(0)="Y",DIR("B")="N",PSANOW="" W ! + F S PSANOW=$O(PSANOW(PSANOW)) Q:PSANOW="" S DIR("A")="Unlink "_PSANOW D ^DIR Q:$G(DIRUT) I Y S PSANOW(PSANOW)=Y,PSADEL(PSANOW)="" + S PSANOW="",PSADEL=$O(PSADEL(PSANOW)) + W @IOF,!?((80-PSALEN)/2),$P($G(^PS(59,+PSAOSIT,0)),"^")_" Outpatient Site",!! + I PSADEL'="" W !,"To be unlinked:" S PSANOW="" D + .F S PSANOW=$O(PSADEL(PSANOW)) Q:PSANOW="" W ?16,PSANOW,! + .W ! S DIR(0)="Y",DIR("B")="N",DIR("A")="Okay to unlink the IV Rooms" D ^DIR K DIR Q:$G(DIRUT) I 'Y W !,"No IV rooms were unlinked." Q + .W !,"Unlinking IV rooms" + .S PSANOW="",DIE="^PSD(58.8,"_PSALOC_",3.5,",DA(1)=PSALOC F S PSANOW=$O(PSADEL(PSANOW)) Q:PSANOW="" S DA=$O(^PS(59.5,"B",PSANOW,0)),DR=".01///@" D ^DIE W "." + .K DIE W !,"IV rooms unlinked." + Q diff --git a/r/DRUG_ACCOUNTABILITY-PSA/PSAORDP1.m b/r/DRUG_ACCOUNTABILITY-PSA/PSAORDP1.m index 884863b8..8302df53 100644 --- a/r/DRUG_ACCOUNTABILITY-PSA/PSAORDP1.m +++ b/r/DRUG_ACCOUNTABILITY-PSA/PSAORDP1.m @@ -1,150 +1,147 @@ -PSAORDP1 ;BIR/JMB-Print Orders - CONT'D ;9/19/97 - ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,12,21,61,65,67**; 10/24/97;Build 15 - ;This routine prints invoices. - ; - ;References to global ^DIC(51.5 are covered by IA #1931 - ;References to global ^PSDRUG( are covered by IA #2095 - ;References to global ^PSDRUG("C" are covered by IA #2095 - ; -DQ S IOM=80 D NOW^%DTC S Y=% D DD^%DT S PSARUN=$E(Y,1,18),PSAPAGE=1,$P(PSASLN,"-",80)="",$P(PSADLN,"=",80)="",(PSADJDRG,PSAOUT)=0,PSAFPG=1 - S PSAEND=0,PSAORDER=$P(^PSD(58.811,PSAORD,0),"^") D HEADER^PSAORDP2 - S PSAIN=$G(^PSD(58.811,PSAORD,1,PSAINV,0)),PSAINVN=$P(PSAIN,"^"),PSASTA=$P(PSAIN,"^",3),PSADEL=+$P(PSAIN,"^",6),PSAREC=+$P(PSAIN,"^",7) -START W !,"PRIME VENDOR : ",$S($P($G(^PSD(58.811,PSAORD,0)),"^",2)'="":$P($G(^(0)),"^",2),1:"UNKNOWN") - W !!,"ORDER# : "_PSAORDER,?40,"ORDER DATE : "_$$DATE($P(PSAIN,"^",4)) - W !,"INVOICE#: "_PSAINVN,?40,"INVOICE DATE : "_$$DATE($P(PSAIN,"^",2)) - W !,"STATUS : "_$S(PSASTA="P":"PROCESSED",PSASTA="V":"VERIFIED",PSASTA="L":"LOCKED VERIFYING",PSASTA="C":"COMPLETED",1:"UNKNOWN")_$S(+$P(PSAIN,"^",13):" (SUPPLY INVOICE)",1:"") ;;<*65 RJS> - W ?40,"DELIVERY DATE: "_$S(PSADEL:$$DATE(PSADEL),1:"UNKNOWN") - W !?40,"DATE RECEIVED: "_$S(PSAREC:$$DATE(PSAREC),PSADEL:$$DATE(PSADEL),1:"UNKNOWN"),! - S PSADJDRG=0 S (PSAIECST,PSAAECST)=0 D LINE - ; -EXIT ;Kills - K %,DIR,DIRUT,PSAAECST,PSACIEN,PSADATA,PSADATE,PSADEC,PSADEL,PSADJ,PSADJD,PSADJDP,PSADJDRG,PSADJSUP,PSADJDV,PSADPDT,PSADPDUZ,PSADVDT,PSADVDUZ,PSADJO,PSADJOP,PSADJOV - K PSADJP,PSADJPP,PSADJPV,PSADJQ,PSADJQP,PSADJQV,PSADLN,PSADRG,PSAECOST,PSAEND,PSAFPG,PSAICOST,PSAIECST,PSAIN,PSAINVN - K PSALN,PSAMORE,PSANDC,PSANODE,PSAOPDT,PSAOPDUZ,PSAORDER,PSAOU,PSAOVDT,PSAOVDUZ,PSAPAGE,PSAPPDT,PSAPPDUZ,PSAPRICE - K PSAPVDT,PSAPVDUZ,PSAQPDT,PSAQPDUZ,PSAQPREA,PSAQVDT,PSAQVDUZ,PSAQVREA,PSAREC,PSARUN,PSAS,PSASLN,PSASS,PSASTA,PSATOT,Y - Q - ; -DATE(PSADATE) ;convert date - S %=$E(PSADATE,4,5)_"/"_$E(PSADATE,6,7)_"/"_$E(PSADATE,2,3) - I $TR(%,"/")="" S %="UNKNOWN" - Q % - ; -LINE ;print line items - D LINEHDR^PSAORDP2 S (PSAICOST,PSALN,PSATOT)=0 - F S PSALN=+$O(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN)) Q:'PSALN!(PSAOUT) D Q:PSAOUT - .Q:'$D(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,0)) - .S PSADATA=^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,0) - .K PSADJQP,PSAQPDUZ,PSAQPDT,PSAQPREA,PSADJQV,PSAQVDUZ,PSAQVDT,PSAQVREA - .K PSADJOP,PSAOPDUZ,PSAOPDT,PSADJOV,PSAOVDUZ,PSAOVDT - .K PSADJPP,PSAPPDUZ,PSAPPDT,PSADJPV,PSAPVDUZ,PSAPVDT - .K PSADJDP,PSADPDUZ,PSADPDT,PSADJDV,PSADVDUZ,PSADVDT - .S PSADJSUP=0 - .I $D(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2)) S PSAMORE=4 D - ..S:+$P(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2),"^") PSAMORE=5 - ..S:+$P(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2),"^",2) PSAMORE=PSAMORE+1 - .E S PSAMORE=4 - .I ($Y+PSAMORE)>IOSL D:$E(IOST,1,2)="C-" SCREEN^PSAORDP2 Q:PSAOUT D HEADER^PSAORDP2,LINEHDR^PSAORDP2 - .W !,$P(PSADATA,"^") -DRUG .S PSADRG=0,PSADJ=+$O(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,1,"B","D",0)) - .I $G(PSADJ) D - ..S PSANODE=$G(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,1,PSADJ,0)) - ..S PSADJD=$S($P(PSANODE,"^",6)'="":$P(PSANODE,"^",6),1:$P(PSANODE,"^",2)) - ..I $G(PSADJD),$L(PSADJD)=$L(+PSADJD),$P($G(^PSDRUG(+PSADJD,0)),"^")'="" D Q - ...W ?8,"*"_$P($G(^PSDRUG(+PSADJD,0)),"^") S PSADJDRG=1,PSADRG=PSADJD - ...I $P(PSANODE,"^",6)'="" S PSADJDV=$P(PSANODE,"^",6),PSADVDT=$P(PSANODE,"^",8),PSADVDUZ=$P(PSANODE,"^",9) - ...I $P(PSANODE,"^",2)'="" S PSADJDP=$P(PSANODE,"^",2),PSADPDT=$P(PSANODE,"^",4),PSADPDUZ=$P(PSANODE,"^",5) - ..I $G(PSADJD),$L(PSADJD)=$L(+PSADJD),$P($G(^PSDRUG(+PSADJD,0)),"^")="" S PSADJ=0 Q - ..W ?7,"**"_PSADJD S PSADJSUP=1,PSADRG=0 - ..I $P(PSANODE,"^",6)'="" S PSADJDV=$P(PSANODE,"^",6),PSADVDT=$P(PSANODE,"^",8),PSADVDUZ=$P(PSANODE,"^",9) - ..I $P(PSANODE,"^",2)'="" S PSADJDP=$P(PSANODE,"^",2),PSADPDT=$P(PSANODE,"^",4),PSADPDUZ=$P(PSANODE,"^",5) - .I '$G(PSADJ) D - ..S PSADRG=$S(+$P(PSADATA,"^",2)&($P($G(^PSDRUG(+$P(PSADATA,"^",2),0)),"^")'=""):+$P(PSADATA,"^",2),1:0) - ..W ?9,$S(+$P(PSADATA,"^",2)&($P($G(^PSDRUG(+$P(PSADATA,"^",2),0)),"^")'=""):$P(^PSDRUG(+$P(PSADATA,"^",2),0),"^"),1:"DRUG UNKNOWN") -CS .I +$P(PSADATA,"^",10) W " (CONTROLLED SUBS)" I $P($G(^PSD(58.8,+$P(PSAIN,"^",12),1,PSADRG,0)),"^",14),$P($G(^(0)),"^",14)'>DT W !?5,"*** INACTIVE IN MASTER VAULT ***" - .E I PSADRG,$P($G(^PSD(58.8,+$P(PSAIN,"^",5),1,PSADRG,0)),"^",14),$P($G(^(0)),"^",14)'>DT W !?5,"*** INACTIVE IN PHARMACY LOCATION ***" - .I PSADRG,$D(^PSDRUG(+PSADRG,"I")) W !?5,"*** INACTIVE IN DRUG FILE ***" - .; -UPC .W:$P(PSADATA,"^",13)'="" !?9,"UPC: "_$P(PSADATA,"^",13) -NDC .S PSANDC=$P(PSADATA,"^",11) - .I $E(PSANDC)'="S" D PSANDC1^PSAHELP S PSANDC=PSANDCX K PSANDCX W !?9,PSANDC - .S PSASUB=$S(+$P($G(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2)),"^",3):+$P($G(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2)),"^",3),$G(PSANDC)'="":$S(+$O(^PSDRUG("C",PSANDC,+PSADRG,0)):+$O(^PSDRUG("C",PSANDC,+PSADRG,0)),1:0),1:0) -VSN .W ?25,$S($P(PSADATA,"^",12)'="":$P(PSADATA,"^",12),1:"VSN UNKNOWN") - .; -QTY .;No Adj. Qty - .S PSAIECST=PSAIECST+($P(PSADATA,"^",3)*$P(PSADATA,"^",5)) - .S PSADJP=0,PSADJ=+$O(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,1,"B","P",0)) - .I $G(PSADJ) S PSANODE=$G(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,1,PSADJ,0)),PSAPRICE=$S($P(PSANODE,"^",6)'="":$P(PSANODE,"^",6),1:+$P(PSANODE,"^",2)) - .I '$G(PSADJ) S PSAPRICE=$P(PSADATA,"^",5) - .S PSADJQ="",PSADJ=+$O(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,1,"B","Q",0)) - .I $G(PSADJ) S PSANODE=$G(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,1,PSADJ,0)),PSADJQ=$S($P(PSANODE,"^",6)'="":+$P(PSANODE,"^",6),1:$P(PSANODE,"^",2)) - .;Adj. Qty - .I $G(PSADJQ) D - ..I $P(PSANODE,"^",6)'="" S PSADJQV=$P(PSANODE,"^",6),PSAQVREA=$P(PSANODE,"^",7),PSAQVDT=$P(PSANODE,"^",8),PSAQVDUZ=$P(PSANODE,"^",9) - ..I $P(PSANODE,"^",2)'="" S PSADJQP=$P(PSANODE,"^",2),PSAQPREA=$P(PSANODE,"^",3),PSAQPDT=$P(PSANODE,"^",4),PSAQPDUZ=$P(PSANODE,"^",5) - ..S PSAECOST=PSADJQ*PSAPRICE,PSAAECST=PSAAECST+PSAECOST - ..W ?40,$S($G(PSADJQV)'="":$J(PSADJQV,6),1:$J(PSADJQP,6))_"("_$P(PSADATA,"^",3)_")" - .I '$G(PSADJQ) W ?40,$J($P(PSADATA,"^",3),6) S PSAECOST=$P(PSADATA,"^",3)*PSAPRICE,PSAAECST=PSAAECST+PSAECOST - .; -OU .;Order Unit - .S PSAOU=$S(+$P(PSADATA,"^",4):$P($G(^DIC(51.5,+$P(PSADATA,"^",4),0)),"^"),+PSASUB&(+$P($G(^PSDRUG(PSADRG,1,+PSASUB,0)),"^",5)):$P($G(^DIC(51.5,+$P($G(^PSDRUG(PSADRG,1,+PSASUB,0)),"^",5),0)),"^"),1:"") - .S PSADJO="",PSADJ=+$O(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,1,"B","O",0)) - .I $G(PSADJ) S PSANODE=$G(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,1,PSADJ,0)),PSADJO=$S($P(PSANODE,"^",6)'="":$P(PSANODE,"^",6),1:$P(PSANODE,"^",2)) - .;Adj. Order Unit - .I PSADJO'="" D - ..I $P(PSANODE,"^",6)'="" S PSADJOV=$P(PSANODE,"^",6),PSAOVDT=$P(PSANODE,"^",8),PSAOVDUZ=$P(PSANODE,"^",9) - ..I $P(PSANODE,"^",2)'="" S PSADJOP=$P(PSANODE,"^",2),PSAOPDT=$P(PSANODE,"^",4),PSAOPDUZ=$P(PSANODE,"^",5) - ..W ?53,$S(+PSADJO:$P($G(^DIC(51.5,+PSADJO,0)),"^"),1:"UNKNOWN")_" ("_$S(PSAOU'="":PSAOU,1:"")_")" - .I PSADJO="" W ?53,$S(PSAOU'="":PSAOU,1:"()") - .; -PRICE .;Unit price - .S PSADEC=$S($L($P($P(PSADATA,"^",5),".",2))>1:$L($P($P(PSADATA,"^",5),".",2)),1:2) - .S PSADJP=0,PSADJ=+$O(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,1,"B","P",0)) - .I $G(PSADJ) S PSANODE=$G(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,1,PSADJ,0)),PSADJP=$S(+$P(PSANODE,"^",6):+$P(PSANODE,"^",6),1:+$P(PSANODE,"^",2)) - .;Adj. Unit Price - .I $G(PSADJP) D - ..I +$P(PSANODE,"^",6) S PSADJPV=$P(PSANODE,"^",6),PSAPVDT=$P(PSANODE,"^",8),PSAPVDUZ=$P(PSANODE,"^",9) - ..I +$P(PSANODE,"^",2) S PSADJPP=$P(PSANODE,"^",2),PSAPPDT=$P(PSANODE,"^",4),PSAPPDUZ=$P(PSANODE,"^",5) - ..W ?60,$J(PSADJP,7,2)_" ("_$S(+$P(PSADATA,"^",5):$P(PSADATA,"^",5),$P(PSADATA,"^",5)=0:0,1:"")_")" - .I '$G(PSADJP) D - ..I +$P(PSADATA,"^",5)!($P(PSADATA,"^",5)=0) W ?60,$S(+$P(PSADATA,"^",5):$J($P(PSADATA,"^",5),7,PSADEC),1:0) Q - ..W ?65,"(Blank)" - .; -XCOST .;Extended cost - .W:PSADJP ?67,$J(PSAECOST,7,2) W:'PSADJP ?70,$J(PSAECOST,9,2) - .; -LEVELS .;DAVE B (PSA*3*3) - .S OU=$P($G(^PSDRUG(+PSADRG,660)),"^",2) I OU'="" S OU=$P($G(^DIC(51.5,OU,0)),"^",1) - .W !!,"Drug file Data - Dispense Unit: ",$P($G(^PSDRUG(+PSADRG,660)),"^",8),?40,"Order Unit : ",$G(OU) - .;W !,?20," Disp. Unit: ",$P($G(^PSDRUG(+PSADRG,660)),"^",8) - .W " DUOU: ",$P($G(^PSDRUG(+PSADRG,660)),"^",5) - .W !,"Invoiced ",?40,"Order Unit : ",$S($P(PSADATA,"^",4)=""!($P(PSADATA,"^",4)=0):"None Sent",1:$S($P(PSADATA,"^",4)["~":"Invalid: "_$P(PSADATA,"^",4),1:$P(^DIC(51.5,$P(PSADATA,"^",4),0),"^"))) - .W " DUOU: ",$S(+$P($G(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2)),"^")'=0:$P(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2),"^"),1:"nothing changed") - .K OU - .W:+$P($G(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2)),"^",4)'=0 !?9,"STOCK LEVEL : "_$FN(+$P(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2),"^",4),",") - .W:+$P($G(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2)),"^",2)'=0 !?9,"REORDER LEVEL: "_$FN(+$P(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2),"^",2),",") - .; - .;BGN 67 - .D DISP2^PSAP67 - .;END 67 - .I $Y+5>IOSL D:$E(IOST,1,2)="C-" SCREEN^PSAORDP2 Q:PSAOUT D HEADER^PSAORDP2 D LINEHDR^PSAORDP2 - .D ^PSAORDP2 Q:PSAOUT - .W ! - Q:PSAOUT - I $Y+5>IOSL D:$E(IOST,1,2)="C-" SCREEN^PSAORDP2 Q:PSAOUT D HEADER^PSAORDP2 - W !,PSASLN - S PSADJSUP=$S($P($G(^PSD(58.811,PSAORD,1,PSAINV,0)),"^",13)=1:1,1:0) - I $G(PSAAECST)'=$G(PSAIECST) D - .W !?47,"TOTAL ADJUSTED COST",?67,$J(PSAAECST,12,2),! - .I +$O(^PSD(58.811,PSAORD,1,PSAINV,2,0)) D - ..S PSACIEN=0 F S PSACIEN=+$O(^PSD(58.811,PSAORD,1,PSAINV,2,PSACIEN)) Q:'PSACIEN D - ...Q:'$D(^PSD(58.811,PSAORD,1,PSAINV,2,PSACIEN,0)) - ...I $Y+3>IOSL D:$E(IOST,1,2)="C-" SCREEN^PSAORDP2 Q:PSAOUT D HEADER^PSAORDP2 - ...W:+$P(^PSD(58.811,PSAORD,1,PSAINV,2,PSACIEN,0),"^",3) ?55,"CREDIT MEMO "_$J($P(^(0),"^",3),12,2),! - W !?47,"TOTAL INVOICED COST",?67,$J(PSAIECST,12,2) - S PSAEND=1 - I $E(IOST)'="C" D - .I PSADJDRG D:$Y+4>IOSL HEADER^PSAORDP2 W !!," * THE DRUG WAS MATCHED TO THE DRUG FILE.",! - .I PSADJSUP D:$Y+4>IOSL HEADER^PSAORDP2 W !,"** THE ITEM IS A SUPPLY ITEM.",! - D:$E(IOST,1,2)="C-" SCREEN^PSAORDP2 - W ! - Q +PSAORDP1 ;BIR/JMB-Print Orders - CONT'D ;9/19/97 + ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,12,21,61,65**; 10/24/97;Build 2 + ;This routine prints invoices. + ; + ;References to global ^DIC(51.5 are covered by IA #1931 + ;References to global ^PSDRUG( are covered by IA #2095 + ;References to global ^PSDRUG("C" are covered by IA #2095 + ; +DQ S IOM=80 D NOW^%DTC S Y=% D DD^%DT S PSARUN=$E(Y,1,18),PSAPAGE=1,$P(PSASLN,"-",80)="",$P(PSADLN,"=",80)="",(PSADJDRG,PSAOUT)=0,PSAFPG=1 + S PSAEND=0,PSAORDER=$P(^PSD(58.811,PSAORD,0),"^") D HEADER^PSAORDP2 + S PSAIN=$G(^PSD(58.811,PSAORD,1,PSAINV,0)),PSAINVN=$P(PSAIN,"^"),PSASTA=$P(PSAIN,"^",3),PSADEL=+$P(PSAIN,"^",6),PSAREC=+$P(PSAIN,"^",7) +START W !,"PRIME VENDOR : ",$S($P($G(^PSD(58.811,PSAORD,0)),"^",2)'="":$P($G(^(0)),"^",2),1:"UNKNOWN") + W !!,"ORDER# : "_PSAORDER,?40,"ORDER DATE : "_$$DATE($P(PSAIN,"^",4)) + W !,"INVOICE#: "_PSAINVN,?40,"INVOICE DATE : "_$$DATE($P(PSAIN,"^",2)) + W !,"STATUS : "_$S(PSASTA="P":"PROCESSED",PSASTA="V":"VERIFIED",PSASTA="L":"LOCKED VERIFYING",PSASTA="C":"COMPLETED",1:"UNKNOWN")_$S(+$P(PSAIN,"^",13):" (SUPPLY INVOICE)",1:"") ;;<*65 RJS> + W ?40,"DELIVERY DATE: "_$S(PSADEL:$$DATE(PSADEL),1:"UNKNOWN") + W !?40,"DATE RECEIVED: "_$S(PSAREC:$$DATE(PSAREC),PSADEL:$$DATE(PSADEL),1:"UNKNOWN"),! + S PSADJDRG=0 S (PSAIECST,PSAAECST)=0 D LINE + ; +EXIT ;Kills + K %,DIR,DIRUT,PSAAECST,PSACIEN,PSADATA,PSADATE,PSADEC,PSADEL,PSADJ,PSADJD,PSADJDP,PSADJDRG,PSADJSUP,PSADJDV,PSADPDT,PSADPDUZ,PSADVDT,PSADVDUZ,PSADJO,PSADJOP,PSADJOV + K PSADJP,PSADJPP,PSADJPV,PSADJQ,PSADJQP,PSADJQV,PSADLN,PSADRG,PSAECOST,PSAEND,PSAFPG,PSAICOST,PSAIECST,PSAIN,PSAINVN + K PSALN,PSAMORE,PSANDC,PSANODE,PSAOPDT,PSAOPDUZ,PSAORDER,PSAOU,PSAOVDT,PSAOVDUZ,PSAPAGE,PSAPPDT,PSAPPDUZ,PSAPRICE + K PSAPVDT,PSAPVDUZ,PSAQPDT,PSAQPDUZ,PSAQPREA,PSAQVDT,PSAQVDUZ,PSAQVREA,PSAREC,PSARUN,PSAS,PSASLN,PSASS,PSASTA,PSATOT,Y + Q + ; +DATE(PSADATE) ;convert date + S %=$E(PSADATE,4,5)_"/"_$E(PSADATE,6,7)_"/"_$E(PSADATE,2,3) + I $TR(%,"/")="" S %="UNKNOWN" + Q % + ; +LINE ;print line items + D LINEHDR^PSAORDP2 S (PSAICOST,PSALN,PSATOT)=0 + F S PSALN=+$O(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN)) Q:'PSALN!(PSAOUT) D Q:PSAOUT + .Q:'$D(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,0)) + .S PSADATA=^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,0) + .K PSADJQP,PSAQPDUZ,PSAQPDT,PSAQPREA,PSADJQV,PSAQVDUZ,PSAQVDT,PSAQVREA + .K PSADJOP,PSAOPDUZ,PSAOPDT,PSADJOV,PSAOVDUZ,PSAOVDT + .K PSADJPP,PSAPPDUZ,PSAPPDT,PSADJPV,PSAPVDUZ,PSAPVDT + .K PSADJDP,PSADPDUZ,PSADPDT,PSADJDV,PSADVDUZ,PSADVDT + .S PSADJSUP=0 + .I $D(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2)) S PSAMORE=4 D + ..S:+$P(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2),"^") PSAMORE=5 + ..S:+$P(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2),"^",2) PSAMORE=PSAMORE+1 + .E S PSAMORE=4 + .I ($Y+PSAMORE)>IOSL D:$E(IOST,1,2)="C-" SCREEN^PSAORDP2 Q:PSAOUT D HEADER^PSAORDP2,LINEHDR^PSAORDP2 + .W !,$P(PSADATA,"^") +DRUG .S PSADRG=0,PSADJ=+$O(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,1,"B","D",0)) + .I $G(PSADJ) D + ..S PSANODE=$G(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,1,PSADJ,0)) + ..S PSADJD=$S($P(PSANODE,"^",6)'="":$P(PSANODE,"^",6),1:$P(PSANODE,"^",2)) + ..I $G(PSADJD),$L(PSADJD)=$L(+PSADJD),$P($G(^PSDRUG(+PSADJD,0)),"^")'="" D Q + ...W ?8,"*"_$P($G(^PSDRUG(+PSADJD,0)),"^") S PSADJDRG=1,PSADRG=PSADJD + ...I $P(PSANODE,"^",6)'="" S PSADJDV=$P(PSANODE,"^",6),PSADVDT=$P(PSANODE,"^",8),PSADVDUZ=$P(PSANODE,"^",9) + ...I $P(PSANODE,"^",2)'="" S PSADJDP=$P(PSANODE,"^",2),PSADPDT=$P(PSANODE,"^",4),PSADPDUZ=$P(PSANODE,"^",5) + ..I $G(PSADJD),$L(PSADJD)=$L(+PSADJD),$P($G(^PSDRUG(+PSADJD,0)),"^")="" S PSADJ=0 Q + ..W ?7,"**"_PSADJD S PSADJSUP=1,PSADRG=0 + ..I $P(PSANODE,"^",6)'="" S PSADJDV=$P(PSANODE,"^",6),PSADVDT=$P(PSANODE,"^",8),PSADVDUZ=$P(PSANODE,"^",9) + ..I $P(PSANODE,"^",2)'="" S PSADJDP=$P(PSANODE,"^",2),PSADPDT=$P(PSANODE,"^",4),PSADPDUZ=$P(PSANODE,"^",5) + .I '$G(PSADJ) D + ..S PSADRG=$S(+$P(PSADATA,"^",2)&($P($G(^PSDRUG(+$P(PSADATA,"^",2),0)),"^")'=""):+$P(PSADATA,"^",2),1:0) + ..W ?9,$S(+$P(PSADATA,"^",2)&($P($G(^PSDRUG(+$P(PSADATA,"^",2),0)),"^")'=""):$P(^PSDRUG(+$P(PSADATA,"^",2),0),"^"),1:"DRUG UNKNOWN") +CS .I +$P(PSADATA,"^",10) W " (CONTROLLED SUBS)" I $P($G(^PSD(58.8,+$P(PSAIN,"^",12),1,PSADRG,0)),"^",14),$P($G(^(0)),"^",14)'>DT W !?5,"*** INACTIVE IN MASTER VAULT ***" + .E I PSADRG,$P($G(^PSD(58.8,+$P(PSAIN,"^",5),1,PSADRG,0)),"^",14),$P($G(^(0)),"^",14)'>DT W !?5,"*** INACTIVE IN PHARMACY LOCATION ***" + .I PSADRG,$D(^PSDRUG(+PSADRG,"I")) W !?5,"*** INACTIVE IN DRUG FILE ***" + .; +UPC .W:$P(PSADATA,"^",13)'="" !?9,"UPC: "_$P(PSADATA,"^",13) +NDC .S PSANDC=$P(PSADATA,"^",11) + .I $E(PSANDC)'="S" D PSANDC1^PSAHELP S PSANDC=PSANDCX K PSANDCX W !?9,PSANDC + .S PSASUB=$S(+$P($G(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2)),"^",3):+$P($G(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2)),"^",3),$G(PSANDC)'="":$S(+$O(^PSDRUG("C",PSANDC,+PSADRG,0)):+$O(^PSDRUG("C",PSANDC,+PSADRG,0)),1:0),1:0) +VSN .W ?25,$S($P(PSADATA,"^",12)'="":$P(PSADATA,"^",12),1:"VSN UNKNOWN") + .; +QTY .;No Adj. Qty + .S PSAIECST=PSAIECST+($P(PSADATA,"^",3)*$P(PSADATA,"^",5)) + .S PSADJP=0,PSADJ=+$O(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,1,"B","P",0)) + .I $G(PSADJ) S PSANODE=$G(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,1,PSADJ,0)),PSAPRICE=$S($P(PSANODE,"^",6)'="":$P(PSANODE,"^",6),1:+$P(PSANODE,"^",2)) + .I '$G(PSADJ) S PSAPRICE=$P(PSADATA,"^",5) + .S PSADJQ="",PSADJ=+$O(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,1,"B","Q",0)) + .I $G(PSADJ) S PSANODE=$G(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,1,PSADJ,0)),PSADJQ=$S($P(PSANODE,"^",6)'="":+$P(PSANODE,"^",6),1:$P(PSANODE,"^",2)) + .;Adj. Qty + .I $G(PSADJQ) D + ..I $P(PSANODE,"^",6)'="" S PSADJQV=$P(PSANODE,"^",6),PSAQVREA=$P(PSANODE,"^",7),PSAQVDT=$P(PSANODE,"^",8),PSAQVDUZ=$P(PSANODE,"^",9) + ..I $P(PSANODE,"^",2)'="" S PSADJQP=$P(PSANODE,"^",2),PSAQPREA=$P(PSANODE,"^",3),PSAQPDT=$P(PSANODE,"^",4),PSAQPDUZ=$P(PSANODE,"^",5) + ..S PSAECOST=PSADJQ*PSAPRICE,PSAAECST=PSAAECST+PSAECOST + ..W ?40,$S($G(PSADJQV)'="":$J(PSADJQV,6),1:$J(PSADJQP,6))_"("_$P(PSADATA,"^",3)_")" + .I '$G(PSADJQ) W ?40,$J($P(PSADATA,"^",3),6) S PSAECOST=$P(PSADATA,"^",3)*PSAPRICE,PSAAECST=PSAAECST+PSAECOST + .; +OU .;Order Unit + .S PSAOU=$S(+$P(PSADATA,"^",4):$P($G(^DIC(51.5,+$P(PSADATA,"^",4),0)),"^"),+PSASUB&(+$P($G(^PSDRUG(PSADRG,1,+PSASUB,0)),"^",5)):$P($G(^DIC(51.5,+$P($G(^PSDRUG(PSADRG,1,+PSASUB,0)),"^",5),0)),"^"),1:"") + .S PSADJO="",PSADJ=+$O(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,1,"B","O",0)) + .I $G(PSADJ) S PSANODE=$G(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,1,PSADJ,0)),PSADJO=$S($P(PSANODE,"^",6)'="":$P(PSANODE,"^",6),1:$P(PSANODE,"^",2)) + .;Adj. Order Unit + .I PSADJO'="" D + ..I $P(PSANODE,"^",6)'="" S PSADJOV=$P(PSANODE,"^",6),PSAOVDT=$P(PSANODE,"^",8),PSAOVDUZ=$P(PSANODE,"^",9) + ..I $P(PSANODE,"^",2)'="" S PSADJOP=$P(PSANODE,"^",2),PSAOPDT=$P(PSANODE,"^",4),PSAOPDUZ=$P(PSANODE,"^",5) + ..W ?53,$S(+PSADJO:$P($G(^DIC(51.5,+PSADJO,0)),"^"),1:"UNKNOWN")_" ("_$S(PSAOU'="":PSAOU,1:"")_")" + .I PSADJO="" W ?53,$S(PSAOU'="":PSAOU,1:"()") + .; +PRICE .;Unit price + .S PSADEC=$S($L($P($P(PSADATA,"^",5),".",2))>1:$L($P($P(PSADATA,"^",5),".",2)),1:2) + .S PSADJP=0,PSADJ=+$O(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,1,"B","P",0)) + .I $G(PSADJ) S PSANODE=$G(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,1,PSADJ,0)),PSADJP=$S(+$P(PSANODE,"^",6):+$P(PSANODE,"^",6),1:+$P(PSANODE,"^",2)) + .;Adj. Unit Price + .I $G(PSADJP) D + ..I +$P(PSANODE,"^",6) S PSADJPV=$P(PSANODE,"^",6),PSAPVDT=$P(PSANODE,"^",8),PSAPVDUZ=$P(PSANODE,"^",9) + ..I +$P(PSANODE,"^",2) S PSADJPP=$P(PSANODE,"^",2),PSAPPDT=$P(PSANODE,"^",4),PSAPPDUZ=$P(PSANODE,"^",5) + ..W ?60,$J(PSADJP,7,2)_" ("_$S(+$P(PSADATA,"^",5):$P(PSADATA,"^",5),$P(PSADATA,"^",5)=0:0,1:"")_")" + .I '$G(PSADJP) D + ..I +$P(PSADATA,"^",5)!($P(PSADATA,"^",5)=0) W ?60,$S(+$P(PSADATA,"^",5):$J($P(PSADATA,"^",5),7,PSADEC),1:0) Q + ..W ?65,"(Blank)" + .; +XCOST .;Extended cost + .W:PSADJP ?67,$J(PSAECOST,7,2) W:'PSADJP ?70,$J(PSAECOST,9,2) + .; +LEVELS .;DAVE B (PSA*3*3) + .S OU=$P($G(^PSDRUG(+PSADRG,660)),"^",2) I OU'="" S OU=$P($G(^DIC(51.5,OU,0)),"^",1) + .W !!,"Drug file Data - Dispense Unit: ",$P($G(^PSDRUG(+PSADRG,660)),"^",8),?40,"Order Unit : ",$G(OU) + .;W !,?20," Disp. Unit: ",$P($G(^PSDRUG(+PSADRG,660)),"^",8) + .W " DUOU: ",$P($G(^PSDRUG(+PSADRG,660)),"^",5) + .W !,"Invoiced ",?40,"Order Unit : ",$S($P(PSADATA,"^",4)=""!($P(PSADATA,"^",4)=0):"None Sent",1:$S($P(PSADATA,"^",4)["~":"Invalid: "_$P(PSADATA,"^",4),1:$P(^DIC(51.5,$P(PSADATA,"^",4),0),"^"))) + .W " DUOU: ",$S(+$P($G(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2)),"^")'=0:$P(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2),"^"),1:"nothing changed") + .K OU + .W:+$P($G(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2)),"^",4)'=0 !?9,"STOCK LEVEL : "_$FN(+$P(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2),"^",4),",") + .W:+$P($G(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2)),"^",2)'=0 !?9,"REORDER LEVEL: "_$FN(+$P(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2),"^",2),",") + .; + .I $Y+5>IOSL D:$E(IOST,1,2)="C-" SCREEN^PSAORDP2 Q:PSAOUT D HEADER^PSAORDP2 D LINEHDR^PSAORDP2 + .D ^PSAORDP2 Q:PSAOUT + .W ! + Q:PSAOUT + I $Y+5>IOSL D:$E(IOST,1,2)="C-" SCREEN^PSAORDP2 Q:PSAOUT D HEADER^PSAORDP2 + W !,PSASLN + S PSADJSUP=$S($P($G(^PSD(58.811,PSAORD,1,PSAINV,0)),"^",13)=1:1,1:0) + I $G(PSAAECST)'=$G(PSAIECST) D + .W !?47,"TOTAL ADJUSTED COST",?67,$J(PSAAECST,12,2),! + .I +$O(^PSD(58.811,PSAORD,1,PSAINV,2,0)) D + ..S PSACIEN=0 F S PSACIEN=+$O(^PSD(58.811,PSAORD,1,PSAINV,2,PSACIEN)) Q:'PSACIEN D + ...Q:'$D(^PSD(58.811,PSAORD,1,PSAINV,2,PSACIEN,0)) + ...I $Y+3>IOSL D:$E(IOST,1,2)="C-" SCREEN^PSAORDP2 Q:PSAOUT D HEADER^PSAORDP2 + ...W:+$P(^PSD(58.811,PSAORD,1,PSAINV,2,PSACIEN,0),"^",3) ?55,"CREDIT MEMO "_$J($P(^(0),"^",3),12,2),! + W !?47,"TOTAL INVOICED COST",?67,$J(PSAIECST,12,2) + S PSAEND=1 + I $E(IOST)'="C" D + .I PSADJDRG D:$Y+4>IOSL HEADER^PSAORDP2 W !!," * THE DRUG WAS MATCHED TO THE DRUG FILE.",! + .I PSADJSUP D:$Y+4>IOSL HEADER^PSAORDP2 W !,"** THE ITEM IS A SUPPLY ITEM.",! + D:$E(IOST,1,2)="C-" SCREEN^PSAORDP2 + W ! + Q diff --git a/r/DRUG_ACCOUNTABILITY-PSA/PSAPROC4.m b/r/DRUG_ACCOUNTABILITY-PSA/PSAPROC4.m index 69d5f41d..a2abd822 100644 --- a/r/DRUG_ACCOUNTABILITY-PSA/PSAPROC4.m +++ b/r/DRUG_ACCOUNTABILITY-PSA/PSAPROC4.m @@ -1,124 +1,118 @@ -PSAPROC4 ;BIR/JMB-Process Uploaded Prime Vendor Invoice Data - CONT'D ;7/23/97 - ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,21,63**; 10/24/97;Build 10 - ;References to ^PSDRUG( are covered by IA #2095 - ;References to ^DIC(51.5 are covered by IA #1931 - ;This routine allows the user to edit invoices with errors or missing - ;data. - ; -MANYNDCS ;List drug synonym data & ask user which on to use - K PSADIFF,PSASAME S (PSACNT,PSAFND,PSAIEN50)=0,PSANDC=$P($P(^XTMP("PSAPV",PSACTRL,"IT",PSALINE),"^",4),"~") - F S PSAIEN50=$O(^PSDRUG("C",PSANDC,PSAIEN50)) Q:'PSAIEN50 S PSASYN=0 D - .F S PSASYN=$O(^PSDRUG("C",PSANDC,PSAIEN50,PSASYN)) Q:'PSASYN D - ..Q:'$D(^PSDRUG(PSAIEN50,1,PSASYN,0)) - ..;DAVE B (PSA*3*3) - ..Q:$D(^PSDRUG(PSAIEN50,"I")) - ..I $P(^PSDRUG(PSAIEN50,1,PSASYN,0),"^",4)=PSAVSN S PSAFND=PSAFND+1,PSASAME(PSAFND)=PSAIEN50_"^"_PSASYN - ..I $P(^PSDRUG(PSAIEN50,1,PSASYN,0),"^",4)'=PSAVSN S PSACNT=PSACNT+1,PSADIFF(PSACNT)=PSAIEN50_"^"_PSASYN - G:PSAFND SAME G:PSACNT DIFF - Q - ; -SAME ;If more than one drug with same VSN, assign to correct drug. - W !,"There is more than one item in the DRUG file",!,"with the same NDC and Vendor Stock Number.",! - S (PSACNT,PSAMENU)=0 F S PSACNT=$O(PSASAME(PSACNT)) Q:'PSACNT D - .S PSAIEN50=$P(PSASAME(PSACNT),"^"),PSASYN=$P(PSASAME(PSACNT),"^",2),PSANODE=^PSDRUG(PSAIEN50,1,PSASYN,0) S PSAMENU=PSAMENU+1 - .Q:'$D(^PSDRUG(PSAIEN50,1,PSASYN,0)) - .D LIST Q:PSAOUT - D CHOOSE Q:PSAOUT!(Y="") - I PSAPICK=PSAMENU D ASKDRUG^PSANDF G KILL - I PSAPICK0:DILOCKTM,1:3) I Q - .;(PSA*3*24 - Dave B. Jun 2 00 - Improper DIC call) - .;(PSA*3*61 - add N DO. DICN will use DO if defined, we do not want to use it since DIC is defined. - .N DO S DIC="^PSD(58.811,",DIC(0)="L",X=PSAORD D FILE^DICN K DIC L -^PSD(58.811,0) S PSAIEN=+Y - F L +^PSD(58.811,PSAIEN,0):10 I Q - S:'$D(^PSD(58.811,PSAIEN,1,0)) DIC("P")=$P(^DD(58.811,2,0),"^",2) - S DA(1)=PSAIEN,DIC="^PSD(58.811,"_DA(1)_",1,",DIC(0)="L",X=$P(PSAIN,"^",2),DLAYGO=58.811 D ^DIC K DA,DLAYGO S PSAIEN1=+Y - S DA(1)=PSAIEN,DA=PSAIEN1,DIE=DIC K DIC - S PSALOCDR=$P($G(PSAIN),"^",7) - S PSADELDR=$P($G(PSAIN),"^",6) - S PSACSDR=$S($P(PSAIN,"^",10)="ALL CS":"A",$P(PSAIN,"^",9)="CS":"S",1:"N") - S PSARECD=$P($G(PSAIN),"^",11) - S PSAMV=$S(+$P(PSAIN,"^",12):$P(PSAIN,"^",12),1:"") - S PSASUP=$S($P(PSAIN,"^",13)="SUP":1,1:"") - ;DAVE B ( PSA*3*12) Invalid Concatenation of zero node - S ^PSD(58.811,DA(1),1,DA,0)=$P(^(0),"^")_"^"_$P(PSAIN,"^",1)_"^P^"_$P(PSAIN,"^",3)_"^"_$G(PSALOCDR)_"^"_$G(PSADELDR)_"^"_$G(PSARECD)_"^"_$G(PSACSDR)_"^^"_DUZ_"^^"_$G(PSAMV)_"^"_$G(PSASUP) - S DIK=DIE D IX^DIK - K ^TMP($J,"PSADIF"),PSADIFLC ;*42 pre verify storage for OU, DUOU, Cost, NDC changes - S PSALINE=0 F S PSALINE=$O(^XTMP("PSAPV",PSACTRL,"IT",PSALINE)) Q:PSALINE="" D LINE - D SCANDIF,MM ;*42 look for differences to drug file SEND EMAIL - I PSACRED K DA S DA(1)=PSAIEN,DA=PSAIEN1,DIE="^PSD(58.811,"_DA(1)_",1,",DR="10///^S X=1" D ^DIE K DIE - S $P(^PSD(58.811,PSAIEN,0),"^",2)=$P($G(^XTMP("PSAPV",PSACTRL,"DS")),"^") - L -^PSD(58.811,PSAIEN,0) - K ^XTMP("PSAPV",PSACTRL) - Q - ; -LINE ;Files line items. - S PSADATA=^XTMP("PSAPV",PSACTRL,"IT",PSALINE) S:'$D(^PSD(58.811,PSAIEN,1,PSAIEN1,1,0)) DIC("P")=$P(^DD(58.8112,5,0),"^",2) - ;PSA*3*31 Dave B - Check for invoice already in file - S DA(2)=PSAIEN,DA(1)=PSAIEN1,(DA,X)=PSALINE,DIC="^PSD(58.811,"_DA(2)_",1,"_DA(1)_",1,",DIC(0)="L",DLAYGO=58.811 D ^DIC S PSAIEN2=+Y K DA,DIC,DLAYGO - ; - ;DAVEB PSA*3*3 (5may98) - S PSADRG=$P($G(PSADATA),"^",6) - S PSASYN=$P($G(PSADATA),"^",7) - K PSAUNIT - I $G(PSASYN)'="",$G(PSADRG)'="" S PSAUNIT=+$P($G(^PSDRUG(PSADRG,1,PSASYN,0)),"^",5) - ; - ;DAVE B (PSA*3*12) Assignment of order unit didn't take into - ;account the adjusted order unit. - S PSAUNIT=$S($D(PSAUNIT):PSAUNIT,$P(PSADATA,"^",12)'="":$P(PSADATA,"^",12),+$P($P(PSADATA,"^",2),"~",2):+$P($P(PSADATA,"^",2),"~",2),1:0) - S PSACS=$S($P(PSADATA,"^",19)="CS":1,1:0),PSANDC=$P($P(PSADATA,"^",4),"~"),PSAVSN=$P($P(PSADATA,"^",5),"~"),PSAUPC=$P($P(PSADATA,"^",26),"~") - I PSANDC="",$P($P(PSADATA,"^",26),"~")'="" S PSANDC="S"_$P($P(PSADATA,"^",26),"~") - S DA(2)=PSAIEN,DA(1)=PSAIEN1,DA=$S($D(PSAIEN2):PSAIEN2,1:PSALINE),DIE="^PSD(58.811,"_DA(2)_",1,"_DA(1)_",1," - ;DaveB (4may98) hard code filing data - S $P(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",3)=+PSADATA - S $P(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",11)=PSANDC - S $P(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",12)=PSAVSN - S $P(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",13)=PSAUPC - S $P(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",10)=PSACS - S $P(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",2)=PSADRG - S $P(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",4)=PSAUNIT - S $P(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",5)=$P(PSADATA,"^",3) - S $P(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",6)=DT - S $P(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",7)=DUZ - ;BGN 67 - S $P(^PSD(58.811,DA(2),1,DA(1),3,DA,0),"^",1)=$P(PSADATA,"^",28) - S $P(^PSD(58.811,DA(2),1,DA(1),3,DA,0),"^",2)=$P(PSADATA,"^",29) - S $P(^PSD(58.811,DA(2),1,DA(1),3,DA,0),"^",3)=$P(PSADATA,"^",30) - S $P(^PSD(58.811,DA(2),1,DA(1),3,DA,0),"^",4)=$P(PSADATA,"^",31) - ;END 67 - S DIK=DIE D IX^DIK - ;End PSA*3*7 - ; - I +$P(PSADATA,"^",15)!($D(^XTMP("PSAPV",PSACTRL,"IT",PSALINE,"SUP"))) D ADJDRUG - I $P(PSADATA,"^",8)'="" D QTY - I +$P(PSADATA,"^",12) D OU - I +$P(PSADATA,"^",23) D PRICE - ;Adds the reorder level and/or dispense units per order unit - I +$P(PSADATA,"^",7)!(+$P(PSADATA,"^",20))!(+$P(PSADATA,"^",21))!(+$P(PSADATA,"^",27)) D - .S ^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSAIEN2,2)=$P(PSADATA,"^",20)_"^"_$P(PSADATA,"^",21)_"^"_$S(+$P(PSADATA,"^",7):+$P(PSADATA,"^",7),1:0)_"^"_+$P(PSADATA,"^",27) - ;Bgn 67 - I $P(PSADATA,"^",5)'="" S ^XTMP("PSAVSN",$P(PSADATA,"^",5))=$P(PSADATA,"^",28)_"^"_$P(PSADATA,"^",29)_"^"_$P(PSADATA,"^",30)_"^"_$P(PSADATA,"^",31) - ;End 67 - K ^XTMP("PSAPV",PSACTRL,"IT",PSALINE) - Q -ADJDRUG ;Records adjusted drug received - S PSAFLD="D" - I +$P(PSADATA,"^",15) S PSADJ=+$P(PSADATA,"^",15),PSADUZ=+$P(PSADATA,"^",16),PSADT=+$P(PSADATA,"^",17),PSAREA="" D RECORD Q - I $D(^XTMP("PSAPV",PSACTRL,"IT",PSALINE,"SUP")) S PSASNODE=^XTMP("PSAPV",PSACTRL,"IT",PSALINE,"SUP"),PSADJ=$P(PSASNODE,"^",3),PSADUZ=+$P(PSASNODE,"^"),PSADT=+$P(PSASNODE,"^",2),PSAREA="" D RECORD - Q -OU ;Records adjusted order unit - S PSAFLD="O",PSADJ=+$P(PSADATA,"^",12),PSADUZ=+$P(PSADATA,"^",13),PSADT=+$P(PSADATA,"^",14),PSAREA="" - D RECORD - Q -PRICE ;Records adjusted price per order unit - S PSAFLD="P",PSADJ=+$P(PSADATA,"^",23),PSADUZ=+$P(PSADATA,"^",24),PSADT=+$P(PSADATA,"^",25),PSAREA="" - S:PSADJ'=+$P(PSADATA,"^",3) PSACRED=1 - D RECORD - Q -QTY ;Records adjusted quantity received. - S PSAFLD="Q",PSADJ=+$P(PSADATA,"^",8),PSADUZ=+$P(PSADATA,"^",9),PSADT=+$P(PSADATA,"^",10),PSAREA=$P(PSADATA,"^",11) - S:PSADJ'=+$P(PSADATA,"^") PSACRED=1 - D RECORD - Q -RECORD ;Adds adjusted data to DA ORDERS file - K DA S DA(3)=PSAIEN,DA(2)=PSAIEN1,DA(1)=PSAIEN2,X=PSAFLD - S:'$D(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSAIEN2,1,0)) DIC("P")=$P(^DD(58.81125,9,0),"^",2) - ;PSA*3*27 (DAVE B) removed killing of DA variable on next line - S DIC="^PSD(58.811,"_DA(3)_",1,"_DA(2)_",1,"_DA(1)_",1,",DIC(0)="L",DLAYGO=58.811 D ^DIC S PSAIEN3=+Y K DLAYGO - ; - ;PSA*3*3 - ;DAVEB Hard code filing - S DIE=DIC,DA=PSAIEN3 - S $P(^PSD(58.811,DA(3),1,DA(2),1,DA(1),1,DA,0),"^",2)=PSADJ - S $P(^PSD(58.811,DA(3),1,DA(2),1,DA(1),1,DA,0),"^",3)=$G(PSAREA) - S $P(^PSD(58.811,DA(3),1,DA(2),1,DA(1),1,DA,0),"^",4)=DT - S $P(^PSD(58.811,DA(3),1,DA(2),1,DA(1),1,DA,0),"^",5)=DUZ - ; - ;S DIE=DIC,DA=PSAIEN3,DR="1///"_PSADJ_$S(PSAREA'="":";2////^S X=PSAREA",1:"")_";3///^S X="_PSADT_";4///^S X="_PSADUZ K DIC D ^DIE - S DIK=DIE,DA=PSAIEN3 D IX1^DIK K DA,DIE,DIK,PSAFLD - Q - ;*42 CHANGES -SCANDIF ; inspect invoice for noted differences in OU,DUOU,PPDU,NDC - ;NEEDS PSAIEN, PSAIEN1 - K ^TMP($J,"PSADIF"),PSADIFLC - S PSALINE=0 F S PSALINE=$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE)) Q:PSALINE'>0 D CHECK - Q -MM ; - I $D(^TMP($J,"PSADIF")) D MESSAGE - Q -CHECK ;Check line item for differences to drug file *42 - N ITM,ITMI,DRG,DRIEN,DIF,ZZ,XX,XXX,PCNT,PDIF,T,IENS - ; use new API call to retrieve item fields see PSAUTL6 - D ITEM^PSAUTL6(PSAIEN,PSAIEN1,PSALINE,.ITM) - D ITEM^PSAUTL6(PSAIEN,PSAIEN1,PSALINE,.ITMI,"I") - I ITM(2)'>0 Q ;zero quantity will not be filed - S ITM("OU")=ITM(3),ITM("DUOU")=ITM(10),ITM("NDC")=ITM(13),ITM("PPOU")=ITM(4),ITM("PPDU")=$J(ITM("PPOU")/ITM("DUOU"),1,4) - S DRIEN=+ITMI(1) - S DRG("OU")=$$GET1^DIQ(50,DRIEN,12),DRG("DUOU")=$$GET1^DIQ(50,DRIEN,15),DRG("NDC")=$$GET1^DIQ(50,DRIEN,31),DRG("PPDU")=$$GET1^DIQ(50,DRIEN,16) - K DIF - F XX="OU","DUOU","NDC" I ITM(XX)'=DRG(XX) S DIF(XX)="" - I ITM("PPDU")'=DRG("PPDU") S PCNT=.05*DRG("PPDU"),PDIF=DRG("PPDU")-ITM("PPDU") S:PDIF<0 PDIF=-1*PDIF S:PDIF>PCNT DIF("PPDU")="" - I $D(DIF) D - . F ZZ=" ",$J(ITM(.01),3)_" "_ITM(1) D SET - . S XXX="" F S XXX=$O(DIF(XXX)) Q:XXX="" D - .. S ZZ=" ",T=XXX,ZZ=$$SETSTR^VALM1(T,ZZ,4,$L(T)) - .. S T="Old: "_DRG(XXX),ZZ=$$SETSTR^VALM1(T,ZZ,13,$L(T)) - .. S T="New: "_ITM(XXX),ZZ=$$SETSTR^VALM1(T,ZZ,36,$L(T)) - .. D SET - Q -SET ;set differences into ^TMP - S:'$G(PSADIFLC) PSADIFLC=3 - S ^TMP($J,"PSADIF",PSADIFLC,0)=ZZ,PSADIFLC=PSADIFLC+1 - Q -MESSAGE ;differences found, notify user and send message to g.PSA NDC UPDATES. - K DIR N IENS - S PSAORD=$$GET1^DIQ(58.811,PSAIEN,.01),IENS=PSAIEN1_","_PSAIEN - S PSAINV=$$GET1^DIQ(58.8112,IENS,.01) - S XMSUB="PRE Verify "_PSAORD_" : "_PSAINV_" Variance Report" - S ^TMP($J,"PSADIF",1,0)=XMSUB,^TMP($J,"PSADIF",2,0)=" " - W !,XMSUB,! - W !,"Noted differences between the invoice line items and the drug file have",!,"been found. A mail message is being sent to G.PSA NDC UPDATES." - W !!," Please check the message for accuracy.",! - K DIR S DIR(0)="E",DIR("A")=" - continue" D ^DIR - K DIR - S XMTEXT="^TMP($J,""PSADIF"",",XMY("G.PSA NDC UPDATES")="" - D ^XMD - K PSADIFLC,^TMP($J,"PSADIF") - Q +PSAPROC7 ;BIR/JMB-Process Uploaded Prime Vendor Invoice Data - CONT'D ;9/6/97 + ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,12,27,21,42,61,64**; 10/24/97;Build 4 + ;This routine takes the data in XTMP and moves it to DA ORDERS file. + ;It deletes the data in XTMP after it is copies. + ; + ;References to ^PSDRUG( are covered by IA #2095 +INVOICE ;PSA*3*21 (3JAN01) - FILE INVOICE IMMEDIATELY + ; + S PSAIN=$G(^XTMP("PSAPV",PSACTRL,"IN")) Q:PSAIN="" + Q:$P(PSAIN,"^",8)'="P" + S PSAORD=$P(PSAIN,"^",4),PSAIEN=+$O(^PSD(58.811,"B",PSAORD,0)),PSACRED=0 + I 'PSAIEN D + .F L +^PSD(58.811,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q + .;(PSA*3*24 - Dave B. Jun 2 00 - Improper DIC call) + .;(PSA*3*61 - add N DO. DICN will use DO if defined, we do not want to use it since DIC is defined. + .N DO S DIC="^PSD(58.811,",DIC(0)="L",X=PSAORD D FILE^DICN K DIC L -^PSD(58.811,0) S PSAIEN=+Y + F L +^PSD(58.811,PSAIEN,0):10 I Q + S:'$D(^PSD(58.811,PSAIEN,1,0)) DIC("P")=$P(^DD(58.811,2,0),"^",2) + S DA(1)=PSAIEN,DIC="^PSD(58.811,"_DA(1)_",1,",DIC(0)="L",X=$P(PSAIN,"^",2),DLAYGO=58.811 D ^DIC K DA,DLAYGO S PSAIEN1=+Y + S DA(1)=PSAIEN,DA=PSAIEN1,DIE=DIC K DIC + S PSALOCDR=$P($G(PSAIN),"^",7) + S PSADELDR=$P($G(PSAIN),"^",6) + S PSACSDR=$S($P(PSAIN,"^",10)="ALL CS":"A",$P(PSAIN,"^",9)="CS":"S",1:"N") + S PSARECD=$P($G(PSAIN),"^",11) + S PSAMV=$S(+$P(PSAIN,"^",12):$P(PSAIN,"^",12),1:"") + S PSASUP=$S($P(PSAIN,"^",13)="SUP":1,1:"") + ;DAVE B ( PSA*3*12) Invalid Concatenation of zero node + S ^PSD(58.811,DA(1),1,DA,0)=$P(^(0),"^")_"^"_$P(PSAIN,"^",1)_"^P^"_$P(PSAIN,"^",3)_"^"_$G(PSALOCDR)_"^"_$G(PSADELDR)_"^"_$G(PSARECD)_"^"_$G(PSACSDR)_"^^"_DUZ_"^^"_$G(PSAMV)_"^"_$G(PSASUP) + S DIK=DIE D IX^DIK + K ^TMP($J,"PSADIF"),PSADIFLC ;*42 pre verify storage for OU, DUOU, Cost, NDC changes + S PSALINE=0 F S PSALINE=$O(^XTMP("PSAPV",PSACTRL,"IT",PSALINE)) Q:PSALINE="" D LINE + D SCANDIF,MM ;*42 look for differences to drug file SEND EMAIL + I PSACRED K DA S DA(1)=PSAIEN,DA=PSAIEN1,DIE="^PSD(58.811,"_DA(1)_",1,",DR="10///^S X=1" D ^DIE K DIE + S $P(^PSD(58.811,PSAIEN,0),"^",2)=$P($G(^XTMP("PSAPV",PSACTRL,"DS")),"^") + L -^PSD(58.811,PSAIEN,0) + K ^XTMP("PSAPV",PSACTRL) + Q + ; +LINE ;Files line items. + S PSADATA=^XTMP("PSAPV",PSACTRL,"IT",PSALINE) S:'$D(^PSD(58.811,PSAIEN,1,PSAIEN1,1,0)) DIC("P")=$P(^DD(58.8112,5,0),"^",2) + ;PSA*3*31 Dave B - Check for invoice already in file + S DA(2)=PSAIEN,DA(1)=PSAIEN1,(DA,X)=PSALINE,DIC="^PSD(58.811,"_DA(2)_",1,"_DA(1)_",1,",DIC(0)="L",DLAYGO=58.811 D ^DIC S PSAIEN2=+Y K DA,DIC,DLAYGO + ; + ;DAVEB PSA*3*3 (5may98) + S PSADRG=$P($G(PSADATA),"^",6) + S PSASYN=$P($G(PSADATA),"^",7) + K PSAUNIT + I $G(PSASYN)'="",$G(PSADRG)'="" S PSAUNIT=+$P($G(^PSDRUG(PSADRG,1,PSASYN,0)),"^",5) + ; + ;DAVE B (PSA*3*12) Assignment of order unit didn't take into + ;account the adjusted order unit. + S PSAUNIT=$S($D(PSAUNIT):PSAUNIT,$P(PSADATA,"^",12)'="":$P(PSADATA,"^",12),+$P($P(PSADATA,"^",2),"~",2):+$P($P(PSADATA,"^",2),"~",2),1:0) + S PSACS=$S($P(PSADATA,"^",19)="CS":1,1:0),PSANDC=$P($P(PSADATA,"^",4),"~"),PSAVSN=$P($P(PSADATA,"^",5),"~"),PSAUPC=$P($P(PSADATA,"^",26),"~") + I PSANDC="",$P($P(PSADATA,"^",26),"~")'="" S PSANDC="S"_$P($P(PSADATA,"^",26),"~") + S DA(2)=PSAIEN,DA(1)=PSAIEN1,DA=$S($D(PSAIEN2):PSAIEN2,1:PSALINE),DIE="^PSD(58.811,"_DA(2)_",1,"_DA(1)_",1," + ;DaveB (4may98) hard code filing data + S $P(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",3)=+PSADATA + S $P(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",11)=PSANDC + S $P(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",12)=PSAVSN + S $P(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",13)=PSAUPC + S $P(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",10)=PSACS + S $P(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",2)=PSADRG + S $P(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",4)=PSAUNIT + S $P(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",5)=$P(PSADATA,"^",3) + S $P(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",6)=DT + S $P(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",7)=DUZ + S DIK=DIE D IX^DIK + ;End PSA*3*7 + ; + I +$P(PSADATA,"^",15)!($D(^XTMP("PSAPV",PSACTRL,"IT",PSALINE,"SUP"))) D ADJDRUG + I $P(PSADATA,"^",8)'="" D QTY + I +$P(PSADATA,"^",12) D OU + I +$P(PSADATA,"^",23) D PRICE + ;Adds the reorder level and/or dispense units per order unit + I +$P(PSADATA,"^",7)!(+$P(PSADATA,"^",20))!(+$P(PSADATA,"^",21))!(+$P(PSADATA,"^",27)) D + .S ^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSAIEN2,2)=$P(PSADATA,"^",20)_"^"_$P(PSADATA,"^",21)_"^"_$S(+$P(PSADATA,"^",7):+$P(PSADATA,"^",7),1:0)_"^"_+$P(PSADATA,"^",27) + K ^XTMP("PSAPV",PSACTRL,"IT",PSALINE) + Q +ADJDRUG ;Records adjusted drug received + S PSAFLD="D" + I +$P(PSADATA,"^",15) S PSADJ=+$P(PSADATA,"^",15),PSADUZ=+$P(PSADATA,"^",16),PSADT=+$P(PSADATA,"^",17),PSAREA="" D RECORD Q + I $D(^XTMP("PSAPV",PSACTRL,"IT",PSALINE,"SUP")) S PSASNODE=^XTMP("PSAPV",PSACTRL,"IT",PSALINE,"SUP"),PSADJ=$P(PSASNODE,"^",3),PSADUZ=+$P(PSASNODE,"^"),PSADT=+$P(PSASNODE,"^",2),PSAREA="" D RECORD + Q +OU ;Records adjusted order unit + S PSAFLD="O",PSADJ=+$P(PSADATA,"^",12),PSADUZ=+$P(PSADATA,"^",13),PSADT=+$P(PSADATA,"^",14),PSAREA="" + D RECORD + Q +PRICE ;Records adjusted price per order unit + S PSAFLD="P",PSADJ=+$P(PSADATA,"^",23),PSADUZ=+$P(PSADATA,"^",24),PSADT=+$P(PSADATA,"^",25),PSAREA="" + S:PSADJ'=+$P(PSADATA,"^",3) PSACRED=1 + D RECORD + Q +QTY ;Records adjusted quantity received. + S PSAFLD="Q",PSADJ=+$P(PSADATA,"^",8),PSADUZ=+$P(PSADATA,"^",9),PSADT=+$P(PSADATA,"^",10),PSAREA=$P(PSADATA,"^",11) + S:PSADJ'=+$P(PSADATA,"^") PSACRED=1 + D RECORD + Q +RECORD ;Adds adjusted data to DA ORDERS file + K DA S DA(3)=PSAIEN,DA(2)=PSAIEN1,DA(1)=PSAIEN2,X=PSAFLD + S:'$D(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSAIEN2,1,0)) DIC("P")=$P(^DD(58.81125,9,0),"^",2) + ;PSA*3*27 (DAVE B) removed killing of DA variable on next line + S DIC="^PSD(58.811,"_DA(3)_",1,"_DA(2)_",1,"_DA(1)_",1,",DIC(0)="L",DLAYGO=58.811 D ^DIC S PSAIEN3=+Y K DLAYGO + ; + ;PSA*3*3 + ;DAVEB Hard code filing + S DIE=DIC,DA=PSAIEN3 + S $P(^PSD(58.811,DA(3),1,DA(2),1,DA(1),1,DA,0),"^",2)=PSADJ + S $P(^PSD(58.811,DA(3),1,DA(2),1,DA(1),1,DA,0),"^",3)=$G(PSAREA) + S $P(^PSD(58.811,DA(3),1,DA(2),1,DA(1),1,DA,0),"^",4)=DT + S $P(^PSD(58.811,DA(3),1,DA(2),1,DA(1),1,DA,0),"^",5)=DUZ + ; + ;S DIE=DIC,DA=PSAIEN3,DR="1///"_PSADJ_$S(PSAREA'="":";2////^S X=PSAREA",1:"")_";3///^S X="_PSADT_";4///^S X="_PSADUZ K DIC D ^DIE + S DIK=DIE,DA=PSAIEN3 D IX1^DIK K DA,DIE,DIK,PSAFLD + Q + ;*42 CHANGES +SCANDIF ; inspect invoice for noted differences in OU,DUOU,PPDU,NDC + ;NEEDS PSAIEN, PSAIEN1 + K ^TMP($J,"PSADIF"),PSADIFLC + S PSALINE=0 F S PSALINE=$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE)) Q:PSALINE'>0 D CHECK + Q +MM ; + I $D(^TMP($J,"PSADIF")) D MESSAGE + Q +CHECK ;Check line item for differences to drug file *42 + N ITM,ITMI,DRG,DRIEN,DIF,ZZ,XX,XXX,PCNT,PDIF,T,IENS + ; use new API call to retrieve item fields see PSAUTL6 + D ITEM^PSAUTL6(PSAIEN,PSAIEN1,PSALINE,.ITM) + D ITEM^PSAUTL6(PSAIEN,PSAIEN1,PSALINE,.ITMI,"I") + I ITM(2)'>0 Q ;zero quantity will not be filed + S ITM("OU")=ITM(3),ITM("DUOU")=ITM(10),ITM("NDC")=ITM(13),ITM("PPOU")=ITM(4),ITM("PPDU")=$J(ITM("PPOU")/ITM("DUOU"),1,4) + S DRIEN=+ITMI(1) + S DRG("OU")=$$GET1^DIQ(50,DRIEN,12),DRG("DUOU")=$$GET1^DIQ(50,DRIEN,15),DRG("NDC")=$$GET1^DIQ(50,DRIEN,31),DRG("PPDU")=$$GET1^DIQ(50,DRIEN,16) + K DIF + F XX="OU","DUOU","NDC" I ITM(XX)'=DRG(XX) S DIF(XX)="" + I ITM("PPDU")'=DRG("PPDU") S PCNT=.05*DRG("PPDU"),PDIF=DRG("PPDU")-ITM("PPDU") S:PDIF<0 PDIF=-1*PDIF S:PDIF>PCNT DIF("PPDU")="" + I $D(DIF) D + . F ZZ=" ",$J(ITM(.01),3)_" "_ITM(1) D SET + . S XXX="" F S XXX=$O(DIF(XXX)) Q:XXX="" D + .. S ZZ=" ",T=XXX,ZZ=$$SETSTR^VALM1(T,ZZ,4,$L(T)) + .. S T="Old: "_DRG(XXX),ZZ=$$SETSTR^VALM1(T,ZZ,13,$L(T)) + .. S T="New: "_ITM(XXX),ZZ=$$SETSTR^VALM1(T,ZZ,36,$L(T)) + .. D SET + Q +SET ;set differences into ^TMP + S:'$G(PSADIFLC) PSADIFLC=3 + S ^TMP($J,"PSADIF",PSADIFLC,0)=ZZ,PSADIFLC=PSADIFLC+1 + Q +MESSAGE ;differences found, notify user and send message to g.PSA NDC UPDATES. + K DIR N IENS + S PSAORD=$$GET1^DIQ(58.811,PSAIEN,.01),IENS=PSAIEN1_","_PSAIEN + S PSAINV=$$GET1^DIQ(58.8112,IENS,.01) + S XMSUB="PRE Verify "_PSAORD_" : "_PSAINV_" Variance Report" + S ^TMP($J,"PSADIF",1,0)=XMSUB,^TMP($J,"PSADIF",2,0)=" " + W !,XMSUB,! + W !,"Noted differences between the invoice line items and the drug file have",!,"been found. A mail message is being sent to G.PSA NDC UPDATES." + W !!," Please check the message for accuracy.",! + K DIR S DIR(0)="E",DIR("A")=" - continue" D ^DIR + K DIR + S XMTEXT="^TMP($J,""PSADIF"",",XMY("G.PSA NDC UPDATES")="" + D ^XMD + K PSADIFLC,^TMP($J,"PSADIF") + Q diff --git a/r/DRUG_ACCOUNTABILITY-PSA/PSAUDP.m b/r/DRUG_ACCOUNTABILITY-PSA/PSAUDP.m index 6c4dfe7f..bda557b0 100644 --- a/r/DRUG_ACCOUNTABILITY-PSA/PSAUDP.m +++ b/r/DRUG_ACCOUNTABILITY-PSA/PSAUDP.m @@ -1,59 +1,57 @@ -PSAUDP ;BIR/LTL,JMB-Nightly Background Job - CONT'D ;7/23/97 - ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**6,3,12,14,25,64,66**; 10/24/97;Build 2 - ; - ;Reference to ^PS(57.6 are covered by IA #772 -PICKLST ;ask for parameters PSA*3*25 - I '$D(^PSD(58.812,1,"T","B","UNIT DOSE"))!('$D(^PSD(58.812,1,"T"))) D - .S ^PSD(58.812,1,"T",0)="^58.8123A^1^1" - .S X="T-2W" D ^%DT S ^PSD(58.812,1,"T",1,0)="UNIT DOSE^"_Y_"^",X="T-1W" D ^%DT S $P(^PSD(58.812,1,"T",1,0),"^",3)=Y K X,Y - .S ^PSD(58.812,1,"T","B","UNIT DOSE",1)="" - S XX=$O(^PSD(58.812,1,"T","B","UNIT DOSE",0)) Q:XX'>0 S JOBIEN=XX D NOW^%DTC S STRTDATE=%,PARDATA=$G(^PSD(58.812,1,"T",JOBIEN,0)) - S PSABGN=$P(PARDATA,"^",2),PSAEND=$P(PARDATA,"^",3) - S X="T-7" D ^%DT I Y'=PSAEND G DONE - S $P(^PSD(58.812,1,"T",JOBIEN,0),"^",2)=PSAEND,X1=PSAEND,X2=7 D C^%DTC S $P(^PSD(58.812,1,"T",JOBIEN,0),"^",3)=X ;Reset date parameters - ;Go back two weeks, gather 1 weeks worth of data - S PSAD0=PSABGN-.000001 - S PSAEND=PSAEND_".2359" -DATE ;Loop through dates - S PSAD0=$O(^PS(57.6,PSAD0)) G DONE:PSAD0'>0 G DONE:PSAD0>PSAEND K PSAD1 -WRD S PSAD1=$S('$D(PSAD1):$O(^PS(57.6,PSAD0,1,0)),1:$O(^PS(57.6,PSAD0,1,PSAD1))) G DATE:PSAD1'>0 K PSAD2 -PVDR ;Loop through providers - S PSAD2=$S('$D(PSAD2):$O(^PS(57.6,PSAD0,1,PSAD1,1,0)),1:$O(^PS(57.6,PSAD0,1,PSAD1,1,PSAD2))) G WRD:PSAD2'>0 K PSAD3 -DRG S PSAD3=$S('$D(PSAD3):$O(^PS(57.6,PSAD0,1,PSAD1,1,PSAD2,1,0)),1:$O(^PS(57.6,PSAD0,1,PSAD1,1,PSAD2,1,PSAD3))) G PVDR:PSAD3'>0 S DATA=$G(^PS(57.6,PSAD0,1,PSAD1,1,PSAD2,1,PSAD3,0)) - S PSAIP=PSAD1,PSA50=PSAD3,PSADT=PSAD0 K PSALOC -LOC S PSALOC=$S('$D(PSALOC):$O(^PSD(58.8,"AB",PSAD1,0)),1:$O(^PSD(58.8,"AB",PSAD1,PSALOC))) G DRG:PSALOC'>0 I $D(^PSD(58.8,PSALOC,"I")),$P($G(^PSD(58.8,PSALOC,"I")),"^")'>DT G LOC - S PSAQTY=$P($G(DATA),"^",2)-$P($G(DATA),"^",4) - I $D(^PSD(58.8,PSALOC,1,PSA50)) D PROCESS - G LOC - ; - Q -DONE ; -END K DA,DATA,DIC,DIE,DR,PSA50,PSAD0,PSAD1,PSAD2,PSAD3,PSADT,PSAIP,PSALOC,PSANUM,PSAQTY,X,Y,PSABGN,PSAEND,PARDATA,JOBIEN,X - Q -PROCESS ;Stuff last UD dispensing fld with DT - F L +^PSD(58.8,PSALOC,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q - S DIE="^PSD(58.8,",DA=PSALOC,DR="27////"_PSADT D ^DIE K DIE,DA,DR - ;Subtract dispensing from balance - S PSABAL=$P($G(^PSD(58.8,PSALOC,1,PSA50,0)),"^",4) - S $P(^PSD(58.8,PSALOC,1,PSA50,0),"^",4)=PSABAL-$G(PSAQTY) - ;If no monthly activity node, add node with beginning balance. - I '$D(^PSD(58.8,PSALOC,1,PSA50,5,+$E(PSADT,1,5)*100,0)) D - .S DIC="^PSD(58.8,PSALOC,1,PSA50,5,",DIC(0)="L",DIC("P")=$P(^DD(58.8001,20,0),U,2),(X,DINUM)=$E(PSADT,1,5)*100,DA(2)=PSALOC,DA(1)=PSA50 - .S DIC("DR")="1////^S X=$G(PSABAL)",DLAYGO=58.8 D ^DIC K DIC,DLAYGO - .;Add current month's node and stuff beginning & ending balance. - .S DIC="^PSD(58.8,PSALOC,1,PSA50,5,",DIC(0)="L",(X,DINUM)=$E(PSADT-100-(+$E(PSADT,4,5)=1*8800),1,5)*100,DA(2)=PSALOC,DA(1)=PSA50,DLAYGO=58.8 D ^DIC K DIC,DLAYGO S DA=+Y - .S DIE="^PSD(58.8,PSALOC,1,PSA50,5,",DA(2)=PSALOC,DA(1)=PSA50,DR="3////^S X=$G(PSABAL)" D ^DIE K DIE - ;Stuff total dispensed - S DIE="^PSD(58.8,PSALOC,1,PSA50,5,",DA(2)=PSALOC,DA(1)=PSA50,DA=$E(PSADT,1,5)*100,DR="9////^S X=$P($G(^(0)),U,6)+PSAQTY" D ^DIE K DIE,DA - ;Get next transaction node number - F L +^PSD(58.81,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q ;; << *66 RJS -FIND S PSANUM=$P(^PSD(58.81,0),"^",3)+1 I $D(^PSD(58.81,PSANUM)) S $P(^PSD(58.81,0),"^",3)=$P(^PSD(58.81,0),"^",3)+1 G FIND - ;Add next transaction node with data. - S DIC="^PSD(58.81,",DIC(0)="L",DLAYGO=58.81,(DINUM,X)=PSANUM D ^DIC K DIC,DLAYGO - S DIE="^PSD(58.81,",DA=PSANUM - S DR="1////2;2////^S X=PSALOC;3////^S X=PSADT;4////^S X=PSA50;5////^S X=PSAQTY;9////^S X=$G(PSABAL)" D ^DIE K DIE,DA - L -^PSD(58.81,0) ;; >> *66 RJS - ;Add activity node - S DIC="^PSD(58.8,PSALOC,1,PSA50,4,",DIC(0)="L",(X,DINUM)=PSANUM,DIC("P")=$P(^DD(58.8001,19,0),"^",2),DA(2)=PSALOC,DA(1)=PSA50,DLAYGO=58.8 D ^DIC K DA,DIC,DLAYGO - L -^PSD(58.8,PSALOC,0) - Q +PSAUDP ;BIR/LTL,JMB-Nightly Background Job - CONT'D ;7/23/97 + ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**6,3,12,14,25,64**; 10/24/97;Build 4 + ; + ;Reference to ^PS(57.6 are covered by IA #772 +PICKLST ;ask for parameters PSA*3*25 + I '$D(^PSD(58.812,1,"T","B","UNIT DOSE"))!('$D(^PSD(58.812,1,"T"))) D + .S ^PSD(58.812,1,"T",0)="^58.8123A^1^1" + .S X="T-2W" D ^%DT S ^PSD(58.812,1,"T",1,0)="UNIT DOSE^"_Y_"^",X="T-1W" D ^%DT S $P(^PSD(58.812,1,"T",1,0),"^",3)=Y K X,Y + .S ^PSD(58.812,1,"T","B","UNIT DOSE",1)="" + S XX=$O(^PSD(58.812,1,"T","B","UNIT DOSE",0)) Q:XX'>0 S JOBIEN=XX D NOW^%DTC S STRTDATE=%,PARDATA=$G(^PSD(58.812,1,"T",JOBIEN,0)) + S PSABGN=$P(PARDATA,"^",2),PSAEND=$P(PARDATA,"^",3) + S X="T-7" D ^%DT I Y'=PSAEND G DONE + S $P(^PSD(58.812,1,"T",JOBIEN,0),"^",2)=PSAEND,X1=PSAEND,X2=7 D C^%DTC S $P(^PSD(58.812,1,"T",JOBIEN,0),"^",3)=X ;Reset date parameters + ;Go back two weeks, gather 1 weeks worth of data + S PSAD0=PSABGN-.000001 + S PSAEND=PSAEND_".2359" +DATE ;Loop through dates + S PSAD0=$O(^PS(57.6,PSAD0)) G DONE:PSAD0'>0 G DONE:PSAD0>PSAEND K PSAD1 +WRD S PSAD1=$S('$D(PSAD1):$O(^PS(57.6,PSAD0,1,0)),1:$O(^PS(57.6,PSAD0,1,PSAD1))) G DATE:PSAD1'>0 K PSAD2 +PVDR ;Loop through providers + S PSAD2=$S('$D(PSAD2):$O(^PS(57.6,PSAD0,1,PSAD1,1,0)),1:$O(^PS(57.6,PSAD0,1,PSAD1,1,PSAD2))) G WRD:PSAD2'>0 K PSAD3 +DRG S PSAD3=$S('$D(PSAD3):$O(^PS(57.6,PSAD0,1,PSAD1,1,PSAD2,1,0)),1:$O(^PS(57.6,PSAD0,1,PSAD1,1,PSAD2,1,PSAD3))) G PVDR:PSAD3'>0 S DATA=$G(^PS(57.6,PSAD0,1,PSAD1,1,PSAD2,1,PSAD3,0)) + S PSAIP=PSAD1,PSA50=PSAD3,PSADT=PSAD0 K PSALOC +LOC S PSALOC=$S('$D(PSALOC):$O(^PSD(58.8,"AB",PSAD1,0)),1:$O(^PSD(58.8,"AB",PSAD1,PSALOC))) G DRG:PSALOC'>0 I $D(^PSD(58.8,PSALOC,"I")),$P($G(^PSD(58.8,PSALOC,"I")),"^")'>DT G LOC + S PSAQTY=$P($G(DATA),"^",2)-$P($G(DATA),"^",4) + I $D(^PSD(58.8,PSALOC,1,PSA50)) D PROCESS + G LOC + ; + Q +DONE ; +END K DA,DATA,DIC,DIE,DR,PSA50,PSAD0,PSAD1,PSAD2,PSAD3,PSADT,PSAIP,PSALOC,PSANUM,PSAQTY,X,Y,PSABGN,PSAEND,PARDATA,JOBIEN,X + Q +PROCESS ;Stuff last UD dispensing fld with DT + F L +^PSD(58.8,PSALOC,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q + S DIE="^PSD(58.8,",DA=PSALOC,DR="27////"_PSADT D ^DIE K DIE,DA,DR + ;Subtract dispensing from balance + S PSABAL=$P($G(^PSD(58.8,PSALOC,1,PSA50,0)),"^",4) + S $P(^PSD(58.8,PSALOC,1,PSA50,0),"^",4)=PSABAL-$G(PSAQTY) + ;If no monthly activity node, add node with beginning balance. + I '$D(^PSD(58.8,PSALOC,1,PSA50,5,+$E(PSADT,1,5)*100,0)) D + .S DIC="^PSD(58.8,PSALOC,1,PSA50,5,",DIC(0)="L",DIC("P")=$P(^DD(58.8001,20,0),U,2),(X,DINUM)=$E(PSADT,1,5)*100,DA(2)=PSALOC,DA(1)=PSA50 + .S DIC("DR")="1////^S X=$G(PSABAL)",DLAYGO=58.8 D ^DIC K DIC,DLAYGO + .;Add current month's node and stuff beginning & ending balance. + .S DIC="^PSD(58.8,PSALOC,1,PSA50,5,",DIC(0)="L",(X,DINUM)=$E(PSADT-100-(+$E(PSADT,4,5)=1*8800),1,5)*100,DA(2)=PSALOC,DA(1)=PSA50,DLAYGO=58.8 D ^DIC K DIC,DLAYGO S DA=+Y + .S DIE="^PSD(58.8,PSALOC,1,PSA50,5,",DA(2)=PSALOC,DA(1)=PSA50,DR="3////^S X=$G(PSABAL)" D ^DIE K DIE + ;Stuff total dispensed + S DIE="^PSD(58.8,PSALOC,1,PSA50,5,",DA(2)=PSALOC,DA(1)=PSA50,DA=$E(PSADT,1,5)*100,DR="9////^S X=$P($G(^(0)),U,6)+PSAQTY" D ^DIE K DIE,DA + ;Get next transaction node number +FIND S PSANUM=$P(^PSD(58.81,0),"^",3)+1 I $D(^PSD(58.81,PSANUM)) S $P(^PSD(58.81,0),"^",3)=$P(^PSD(58.81,0),"^",3)+1 G FIND + ;Add next transaction node with data. + S DIC="^PSD(58.81,",DIC(0)="L",DLAYGO=58.81,(DINUM,X)=PSANUM D ^DIC K DIC,DLAYGO + S DIE="^PSD(58.81,",DA=PSANUM + S DR="1////2;2////^S X=PSALOC;3////^S X=PSADT;4////^S X=PSA50;5////^S X=PSAQTY;9////^S X=$G(PSABAL)" D ^DIE K DIE,DA + ;Add activity node + S DIC="^PSD(58.8,PSALOC,1,PSA50,4,",DIC(0)="L",(X,DINUM)=PSANUM,DIC("P")=$P(^DD(58.8001,19,0),"^",2),DA(2)=PSALOC,DA(1)=PSA50,DLAYGO=58.8 D ^DIC K DA,DIC,DLAYGO + L -^PSD(58.8,PSALOC,0) + Q diff --git a/r/DRUG_ACCOUNTABILITY-PSA/PSAUP4.m b/r/DRUG_ACCOUNTABILITY-PSA/PSAUP4.m index 418f7325..888204f2 100644 --- a/r/DRUG_ACCOUNTABILITY-PSA/PSAUP4.m +++ b/r/DRUG_ACCOUNTABILITY-PSA/PSAUP4.m @@ -1,177 +1,176 @@ -PSAUP4 ;BIR/JMB-Upload and Process Prime Vendor Invoice Data - CONT'D ;9/19/97 - ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,12,20,21,67**; 10/24/97;Build 15 - ;This routine prints invoices from the ^XTMP global on the screen or - ;to a printer. - ; - ;References to ^PSDRUG( are covered by IA #2095 - ;References to ^DIC(51.5( are covered by IA #1931 - ; - W !!,"Enter the device which will be used to print",!,"the invoices with all items, errors, and adjustments.",! - S %ZIS="Q" D ^%ZIS I POP S PSAOUT=1 Q - I $D(IO("Q")) S ZTDESC="Drug Acct. - Prime Vendor Invoice Upload Report",ZTRTN="DQ^PSAUP4" D ^%ZTLOAD Q - ; -DQ ;queue starts here - S IOM=80 - D NOW^%DTC S Y=% D DD^%DT S PSARUN=$E(Y,1,18),$P(PSASLN,"-",80)="",$P(PSADLN,"=",80)="",(PSADJDRG,PSADJSUP,PSAOUT)=0,PSAFPG=1 - U IO - S PSACTRL=0 F S PSACTRL=$O(^XTMP("PSAPV",PSACTRL)) Q:PSACTRL=""!(PSAOUT) D START - W @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" K IO("Q") - ; -EXIT ;Kills printing variables only - K %,%ZIS,DIR,DIRUT,PSAAECST,PSABY,PSACS,PSACTRL,PSADATA,PSADATE,PSADEC,PSADRG,PSADJDRG,PSADJORD,PSADJQTY,PSADJSUP,PSADLN,PSADS,PSAECOST,PSAEND,PSAFPG,PSAICOST,PSAIECST - K PSAIN,PSALINE,PSANDC,PSAODT,PSAODUZ,PSAOREA,PSAOUT,PSAPAGE,PSAPHARM,PSAQDT,PSAQDUZ,PSAQREA,PSAMV,PSARUN,PSAS,PSASLN,PSASS,PSAST,PSASTA,PSATOT,Y,ZTDESC,ZTRTN,ZTSK - Q - ; -START S PSAPAGE=1,PSAEND=0 D HEADER S PSAIN=$G(^XTMP("PSAPV",PSACTRL,"IN")) - S (PSADJDRG,PSADJSUP,PSAIECST,PSAAECST)=0,PSAPHARM=$P(PSAIN,"^",7),PSAMV=$P(PSAIN,"^",12) - W !,"PRIME VENDOR : ",$S($P($G(^XTMP("PSAPV",PSACTRL,"DS")),"^")'="":$P($G(^("DS")),"^"),1:"UNKNOWN") - W !!,"ORDER# : "_$P(PSAIN,"^",4),?40,"ORDER DATE : "_$$DATE($P(PSAIN,"^",3)) - W !,"INVOICE#: "_$P(PSAIN,"^",2),?40,"INVOICE DATE: "_$$DATE(+PSAIN) - S PSASTA=$P(PSAIN,"^",8) - W !,"STATUS : "_$S(PSASTA="":"UPLOADED WITH ERRORS",PSASTA="OK":"UPLOADED WITHOUT ERRORS",PSASTA="P":"PROCESSED",1:"UNKNOWN")_$S($P(PSAIN,"^",13)="SUP":" (SUPPLY INVOICE)",1:"") - I $Y+8>IOSL D:$E(IOST,1,2)="C-" SCREEN Q:PSAOUT D HEADER - I $E(IOST,1,2)="C-" D LINE Q - W !!,"DELIVERY DATE REQUESTED: ",$$DATE($P(PSAIN,"^",5)) - W !,"DATE RECEIVED : "_$S(+$P(PSAIN,"^",11)&($$DATE(+$P(PSAIN,"^",11))):" ("_$$DATE($P(PSAIN,"^",6))_")",1:$$DATE($P(PSAIN,"^",6))) - I $Y+8>IOSL D:$E(IOST,1,2)="C-" SCREEN Q:$G(PSAOUT) D HEADER - ; -BUYSHIP W !!,"BUYER INFORMATION:",?40,"SHIPPING INFORMATION:" - S PSABY=$G(^XTMP("PSAPV",PSACTRL,"BY")) - S PSAST=$G(^XTMP("PSAPV",PSACTRL,"ST")) - W !?2,$P(PSABY,"^"),?42,$P(PSAST,"^") - I $P(PSABY,"^",2)'=""!($P(PSAST,"^",2)'="") W ! W:$P(PSABY,"^",2)'="" ?2,$P(PSABY,"^",2) W:$P(PSAST,"^",2)'="" ?42,$P(PSAST,"^",2) - I $P(PSABY,"^",3)'=""!($P(PSAST,"^",3)'="") W ! W:$P(PSABY,"^",3)'="" ?2,$P(PSABY,"^",3) W:$P(PSAST,"^",3)'="" ?42,$P(PSAST,"^",3) - W !?2,$P(PSABY,"^",4)_" "_$P(PSABY,"^",5)_" ",$P(PSABY,"^",6) - W ?42,$P(PSAST,"^",4)_" "_$P(PSAST,"^",5)_" ",$P(PSAST,"^",6) - I $Y+8>IOSL D:$E(IOST,1,2)="C-" SCREEN Q:PSAOUT D HEADER - ; -DISTRIB W !!,"DISTRIBUTOR INFORMATION:" - S PSADS=$G(^XTMP("PSAPV",PSACTRL,"DS")) - W !?2,$P(PSADS,"^") - W:$P(PSADS,"^",2)'="" !?2,$P(PSADS,"^",2) - W:$P(PSADS,"^",3)'="" !?2,$P(PSADS,"^",3) - W !?2,$P(PSADS,"^",4)_" "_$P(PSADS,"^",5)_" ",$P(PSADS,"^",6) - I $Y+8>IOSL D:$E(IOST,1,2)="C-" SCREEN Q:PSAOUT D HEADER - D LINE - Q - ; -DATE(PSADATE) ;convert date - S %=$E(PSADATE,4,5)_"/"_$E(PSADATE,6,7)_"/"_$E(PSADATE,2,3) - I $TR(%,"/")="" S %="UNKNOWN" - Q % - ; -LINE ;print line items - D LINEHDR - S (PSAICOST,PSALINE,PSATOT)=0 F S PSALINE=$O(^XTMP("PSAPV",PSACTRL,"IT",PSALINE)) Q:'PSALINE!(PSAOUT) S PSADATA=^(PSALINE),PSADRG=0 D Q:PSAOUT - .I $Y+5>IOSL D:$E(IOST,1,2)="C-" SCREEN Q:PSAOUT D HEADER,LINEHDR - .K PSADJQTY,PSAQDUZ,PSAQDT,PSAQREA,PSADJORD,PSAODUZ,PSAODT,PSAOREA - .W !,PSALINE -DRUG .;Drug - .I +$P(PSADATA,"^",15) S PSADRG=+$P(PSADATA,"^",15) W ?8,"*"_$P($G(^PSDRUG(+$P(PSADATA,"^",15),0)),"^")_$S(+$P(PSADATA,"^",6)&($P($G(^PSDRUG(+$P(PSADATA,"^",6),0)),"^")'=""):" ("_$P(^PSDRUG(+$P(PSADATA,"^",6),0),"^")_")",1:"") S PSADJDRG=1 - .I PSADRG,$D(^PSDRUG(PSADRG,"I")) W !,?5,"** INACTIVE IN DRUG FILE **" - .I '+$P(PSADATA,"^",15) D - ..I +$P(PSADATA,"^",6),$P($G(^PSDRUG(+$P(PSADATA,"^",6),0)),"^")'="" W ?9,$P(^PSDRUG(+$P(PSADATA,"^",6),0),"^") S PSADRG=+$P(PSADATA,"^",6) Q - ..I $P($G(^XTMP("PSAPV",PSACTRL,"IT",PSALINE,"SUP")),"^",3)'="" W ?7,"**"_$P(^XTMP("PSAPV",PSACTRL,"IT",PSALINE,"SUP"),"^",3) S PSADJSUP=1,PSADRG=0 Q - ..W ?9,"DRUG UNKNOWN" - .I $P(PSADATA,"^",19)="CS" W " (CONTROLLED SUBS)" I $P($G(^PSD(58.8,+$P(PSAIN,"^",12),1,PSADRG,0)),"^",14),$P($G(^(0)),"^",14)'>DT W !?5,"*** INACTIVE IN MASTER VAULT" - .E I PSADRG,$P($G(^PSD(58.8,+$P(PSAIN,"^",7),1,PSADRG,0)),"^",14),$P($G(^(0)),"^",14)'>DT W !?5,"*** INACTIVE IN PHARMACY LOCATION" - .;UPC - .I $P($P(PSADATA,"^",26),"~")'="" W !?9,"UPC: "_$P($P(PSADATA,"^",26),"~") - .;NDC - .S PSANDC=$P($P(PSADATA,"^",4),"~") - .I $E(PSANDC)'="S" D - ..W !?9 D PSANDC1^PSAHELP S PSANDC=PSANDCX - ..I PSANDC'="" W PSANDC Q - ..W "NDC UNKNOWN" - .; - .;VSN - .W ?25,$S($P($P(PSADATA,"^",5),"~")'="":$E($P($P(PSADATA,"^",5),"~"),1,14),1:"VSN UNKNOWN") - .; - .;QTY - .;No Adjusted Qty - .S PSAIECST=PSAIECST+($P(PSADATA,"^")*$P(PSADATA,"^",3)) - .I $P(PSADATA,"^",8)="" W ?40,$J($P(PSADATA,"^"),6) S PSAECOST=$P(PSADATA,"^")*$P(PSADATA,"^",3),PSAAECST=PSAAECST+PSAECOST - .;Adj. Qty (P) - .I $P(PSADATA,"^",8)'="" D - ..S PSADJQTY=$P(PSADATA,"^",8),PSAQDUZ=$P(PSADATA,"^",9),PSAQDT=$P(PSADATA,"^",10),PSAQREA=$P(PSADATA,"^",11) - ..S PSAECOST=PSADJQTY*$P(PSADATA,"^",3),PSAAECST=PSAAECST+PSAECOST - ..W ?40,$J($P(PSADATA,"^",8),6)_"("_$P(PSADATA,"^")_")" - .; -OU .;Order Unit - .I '+$P(PSADATA,"^",12) D - ..I +$P($P(PSADATA,"^",2),"~",2),$P($G(^DIC(51.5,+$P($P(PSADATA,"^",2),"~",2),0)),"^")'="" W ?53,$P($G(^DIC(51.5,+$P($P(PSADATA,"^",2),"~",2),0)),"^") Q - ..I $P($G(PSADATA),"^",2)'="",$P($G(PSADATA),"^",2)'["~",'$D(^DIC(51.5,"B",$P(PSADATA,"^",2))) W ?48," ?-> "_$P(PSADATA,"^",2) - ..I $P($P(PSADATA,"^",2),"~")="" D ^PSAHELP - .;Adj. OU (P) - .I +$P(PSADATA,"^",12) S PSADJORD=$P(PSADATA,"^",12),PSAODUZ=$P(PSADATA,"^",13),PSAODT=$P(PSADATA,"^",14) W ?53,$P($G(^DIC(51.5,+$P(PSADATA,"^",12),0)),"^")_"("_$P($P(PSADATA,"^",2),"~")_")" - .;Unit price - .S PSADEC=$S($L($P($P(PSADATA,"^",3),".",2))>1:$L($P($P(PSADATA,"^",3),".",2)),1:2) - .W ?59,$J($P(PSADATA,"^",3),7,PSADEC) - .;Extended cost - .W ?67,$J(PSAECOST,12,2) - .I $Y+9>IOSL,+$P(PSADATA,"^",21),+$P(PSADATA,"^",27) D:$E(IOST,1,2)="C-" SCREEN Q:PSAOUT D HEADER,LINEHDR - .I $G(PSADRG) D HAVEDRG - .I '$G(PSADRG) W !?9,"STOCK LEVEL : ",!?9,"REORDER LEVEL: "_$P(PSADATA,"^",21),!?9,"DISPENSE UNITS/ORDER UNIT: " D DISP^PSAP67 - .; - .;Print Adj Qty - .I $G(PSADJQTY)'="" D - ..I $Y+5>IOSL D:$E(IOST,1,2)="C-" SCREEN Q:PSAOUT D HEADER,LINEHDR - ..W !!?9,"ADJUSTED QUANTITY: "_PSADJQTY,!?9,$$DATE(PSAQDT)_" "_$P($G(^VA(200,+PSAQDUZ,0)),"^"),!?11,PSAQREA - .;Print Adj OU - .I +$G(PSADJORD) D - ..I $Y+5>IOSL D:$E(IOST,1,2)="C-" SCREEN Q:PSAOUT D HEADER,LINEHDR - ..W !!,?9,"ADJUSTED ORDER UNIT: "_$P($G(^DIC(51.5,+PSADJORD,0)),"^") - ..W !?9,$$DATE(PSAODT)_" "_$P($G(^VA(200,+PSAODUZ,0)),"^")_" - "_$P($G(^DIC(51.5,PSADJORD,0)),"^") - .W ! - Q:PSAOUT - I $Y+6>IOSL D:$E(IOST,1,2)="C-" SCREEN Q:PSAOUT D HEADER - W !,PSASLN - W:$G(PSAAECST)'=$G(PSAIECST) !?48,"TOTAL ADUSTED COST",?67,$J(PSAAECST,12,2),! - W !?48,"TOTAL INVOICED COST",?67,$J(PSAIECST,12,2) - S PSAEND=1 - I $Y+5>IOSL D:$E(IOST,1,2)="C-" SCREEN Q:PSAOUT D HEADER - I PSADJDRG,$E(IOST)'="C" W !!,"* THE DRUG WAS MATCHED TO THE DRUG FILE." - I PSADJSUP,$E(IOST)'="C" W !!,"* THE ITEM IS A SUPPLY ITEM." - D:$E(IOST,1,2)="C-" SCREEN - Q - ; -LINEHDR ;item header - W !?50,"ORDER",?62,"COST/",?71,"EXTENDED" - W !,"LINE#",?9,"NDC",?25,"VSN",?43,"QTY",?51,"UNIT",?62,"UNIT",?75,"COST",!,PSADLN,! - Q - ; -HEADER ;Page header - I PSAFPG&($E(IOST,1,2)="C-") W @IOF G HDR1 - S PSAFPG=0 - W:'PSAFPG @IOF -HDR1 W !?20,"DRUG ACCOUNTABILITY/INVENTORY INTERFACE" - W !?26,"PRIME VENDOR UPLOAD REPORT",! - W:PSAPAGE'=1 !,"ORDER#: "_$P(PSAIN,"^",4)_" INVOICE#: "_$P(PSAIN,"^",2) - I $E(IOST,1,2)="C-" W ?(74-$L(PSAPAGE)),"PAGE "_PSAPAGE,!,PSADLN - I $E(IOST)'="C" W !,"RUN: "_PSARUN,?(74-$L(PSAPAGE)),"PAGE "_PSAPAGE,!,PSADLN - S PSAPAGE=PSAPAGE+1 - Q -SCREEN ;Hold on screen - S PSAS=20-$Y I PSAS F PSASS=1:1:PSAS W ! - I PSADJDRG,PSAEND W !," * THE DRUG WAS MATCHED TO THE DRUG FILE." - I PSADJSUP,PSAEND W !,"** THE ITEM IS A SUPPLY ITEM." - S DIR(0)="E" D ^DIR K DIR I $G(DIRUT) S PSAOUT=1 - Q - ; -HAVEDRG ;Display data if drug is found. - ;DAVE B (PSA*3*20) 7SEP99 ADDED $G TO NEXT LINE - S PSACS=$S($P($G(^PSDRUG(PSADRG,2)),"^",3)["N":1,1:0) - I PSACS D - .I PSAMV,+$P($G(^PSD(58.8,PSAMV,0)),"^",14) D Q - ..W !?9,"STOCK LEVEL : "_$S(+$P(PSADATA,"^",27):+$P(PSADATA,"^",27),1:+$P($G(^PSD(58.8,PSAMV,1,PSADRG,0)),"^",3)) - ..W !?9,"REORDER LEVEL: "_$S(+$P(PSADATA,"^",21):+$P(PSADATA,"^",21),1:+$P($G(^PSD(58.8,PSAMV,1,PSADRG,0)),"^",5)) - .I 'PSAMV W !?9,"STOCK LEVEL : "_$P(PSADATA,"^",27),!?9,"REORDER LEVEL: "_$P(PSADATA,"^",21) - I 'PSACS D - .I PSAPHARM,+$P($G(^PSD(58.8,PSAPHARM,0)),"^",14) D - ..W !?9,"STOCK LEVEL : "_$S(+$P(PSADATA,"^",27):+$P(PSADATA,"^",27),1:+$P($G(^PSD(58.8,PSAPHARM,1,PSADRG,0)),"^",3)) - ..W !?9,"REORDER LEVEL: "_$S(+$P(PSADATA,"^",21):+$P(PSADATA,"^",21),1:+$P($G(^PSD(58.8,PSAPHARM,1,PSADRG,0)),"^",5)) - .I 'PSAPHARM W !?9,"STOCK LEVEL : "_$P(PSADATA,"^",27),!?9,"REORDER LEVEL: "_$P(PSADATA,"^",21) - W !?9,"DISPENSE UNITS/ORDER UNIT: " - W $S(+$P(PSADATA,"^",20):+$P(PSADATA,"^",20),+$P($G(^PSDRUG(PSADRG,1,+$P(PSADATA,"^",7),0)),"^",7):+$P($G(^PSDRUG(PSADRG,1,+$P(PSADATA,"^",7),0)),"^",7),1:"") - D DISP^PSAP67 - Q +PSAUP4 ;BIR/JMB-Upload and Process Prime Vendor Invoice Data - CONT'D ;9/19/97 + ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,12,20,21**; 10/24/97 + ;This routine prints invoices from the ^XTMP global on the screen or + ;to a printer. + ; + ;References to ^PSDRUG( are covered by IA #2095 + ;References to ^DIC(51.5( are covered by IA #1931 + ; + W !!,"Enter the device which will be used to print",!,"the invoices with all items, errors, and adjustments.",! + S %ZIS="Q" D ^%ZIS I POP S PSAOUT=1 Q + I $D(IO("Q")) S ZTDESC="Drug Acct. - Prime Vendor Invoice Upload Report",ZTRTN="DQ^PSAUP4" D ^%ZTLOAD Q + ; +DQ ;queue starts here + S IOM=80 + D NOW^%DTC S Y=% D DD^%DT S PSARUN=$E(Y,1,18),$P(PSASLN,"-",80)="",$P(PSADLN,"=",80)="",(PSADJDRG,PSADJSUP,PSAOUT)=0,PSAFPG=1 + U IO + S PSACTRL=0 F S PSACTRL=$O(^XTMP("PSAPV",PSACTRL)) Q:PSACTRL=""!(PSAOUT) D START + W @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" K IO("Q") + ; +EXIT ;Kills printing variables only + K %,%ZIS,DIR,DIRUT,PSAAECST,PSABY,PSACS,PSACTRL,PSADATA,PSADATE,PSADEC,PSADRG,PSADJDRG,PSADJORD,PSADJQTY,PSADJSUP,PSADLN,PSADS,PSAECOST,PSAEND,PSAFPG,PSAICOST,PSAIECST + K PSAIN,PSALINE,PSANDC,PSAODT,PSAODUZ,PSAOREA,PSAOUT,PSAPAGE,PSAPHARM,PSAQDT,PSAQDUZ,PSAQREA,PSAMV,PSARUN,PSAS,PSASLN,PSASS,PSAST,PSASTA,PSATOT,Y,ZTDESC,ZTRTN,ZTSK + Q + ; +START S PSAPAGE=1,PSAEND=0 D HEADER S PSAIN=$G(^XTMP("PSAPV",PSACTRL,"IN")) + S (PSADJDRG,PSADJSUP,PSAIECST,PSAAECST)=0,PSAPHARM=$P(PSAIN,"^",7),PSAMV=$P(PSAIN,"^",12) + W !,"PRIME VENDOR : ",$S($P($G(^XTMP("PSAPV",PSACTRL,"DS")),"^")'="":$P($G(^("DS")),"^"),1:"UNKNOWN") + W !!,"ORDER# : "_$P(PSAIN,"^",4),?40,"ORDER DATE : "_$$DATE($P(PSAIN,"^",3)) + W !,"INVOICE#: "_$P(PSAIN,"^",2),?40,"INVOICE DATE: "_$$DATE(+PSAIN) + S PSASTA=$P(PSAIN,"^",8) + W !,"STATUS : "_$S(PSASTA="":"UPLOADED WITH ERRORS",PSASTA="OK":"UPLOADED WITHOUT ERRORS",PSASTA="P":"PROCESSED",1:"UNKNOWN")_$S($P(PSAIN,"^",13)="SUP":" (SUPPLY INVOICE)",1:"") + I $Y+8>IOSL D:$E(IOST,1,2)="C-" SCREEN Q:PSAOUT D HEADER + I $E(IOST,1,2)="C-" D LINE Q + W !!,"DELIVERY DATE REQUESTED: ",$$DATE($P(PSAIN,"^",5)) + W !,"DATE RECEIVED : "_$S(+$P(PSAIN,"^",11)&($$DATE(+$P(PSAIN,"^",11))):" ("_$$DATE($P(PSAIN,"^",6))_")",1:$$DATE($P(PSAIN,"^",6))) + I $Y+8>IOSL D:$E(IOST,1,2)="C-" SCREEN Q:$G(PSAOUT) D HEADER + ; +BUYSHIP W !!,"BUYER INFORMATION:",?40,"SHIPPING INFORMATION:" + S PSABY=$G(^XTMP("PSAPV",PSACTRL,"BY")) + S PSAST=$G(^XTMP("PSAPV",PSACTRL,"ST")) + W !?2,$P(PSABY,"^"),?42,$P(PSAST,"^") + I $P(PSABY,"^",2)'=""!($P(PSAST,"^",2)'="") W ! W:$P(PSABY,"^",2)'="" ?2,$P(PSABY,"^",2) W:$P(PSAST,"^",2)'="" ?42,$P(PSAST,"^",2) + I $P(PSABY,"^",3)'=""!($P(PSAST,"^",3)'="") W ! W:$P(PSABY,"^",3)'="" ?2,$P(PSABY,"^",3) W:$P(PSAST,"^",3)'="" ?42,$P(PSAST,"^",3) + W !?2,$P(PSABY,"^",4)_" "_$P(PSABY,"^",5)_" ",$P(PSABY,"^",6) + W ?42,$P(PSAST,"^",4)_" "_$P(PSAST,"^",5)_" ",$P(PSAST,"^",6) + I $Y+8>IOSL D:$E(IOST,1,2)="C-" SCREEN Q:PSAOUT D HEADER + ; +DISTRIB W !!,"DISTRIBUTOR INFORMATION:" + S PSADS=$G(^XTMP("PSAPV",PSACTRL,"DS")) + W !?2,$P(PSADS,"^") + W:$P(PSADS,"^",2)'="" !?2,$P(PSADS,"^",2) + W:$P(PSADS,"^",3)'="" !?2,$P(PSADS,"^",3) + W !?2,$P(PSADS,"^",4)_" "_$P(PSADS,"^",5)_" ",$P(PSADS,"^",6) + I $Y+8>IOSL D:$E(IOST,1,2)="C-" SCREEN Q:PSAOUT D HEADER + D LINE + Q + ; +DATE(PSADATE) ;convert date + S %=$E(PSADATE,4,5)_"/"_$E(PSADATE,6,7)_"/"_$E(PSADATE,2,3) + I $TR(%,"/")="" S %="UNKNOWN" + Q % + ; +LINE ;print line items + D LINEHDR + S (PSAICOST,PSALINE,PSATOT)=0 F S PSALINE=$O(^XTMP("PSAPV",PSACTRL,"IT",PSALINE)) Q:'PSALINE!(PSAOUT) S PSADATA=^(PSALINE),PSADRG=0 D Q:PSAOUT + .I $Y+5>IOSL D:$E(IOST,1,2)="C-" SCREEN Q:PSAOUT D HEADER,LINEHDR + .K PSADJQTY,PSAQDUZ,PSAQDT,PSAQREA,PSADJORD,PSAODUZ,PSAODT,PSAOREA + .W !,PSALINE +DRUG .;Drug + .I +$P(PSADATA,"^",15) S PSADRG=+$P(PSADATA,"^",15) W ?8,"*"_$P($G(^PSDRUG(+$P(PSADATA,"^",15),0)),"^")_$S(+$P(PSADATA,"^",6)&($P($G(^PSDRUG(+$P(PSADATA,"^",6),0)),"^")'=""):" ("_$P(^PSDRUG(+$P(PSADATA,"^",6),0),"^")_")",1:"") S PSADJDRG=1 + .I PSADRG,$D(^PSDRUG(PSADRG,"I")) W !,?5,"** INACTIVE IN DRUG FILE **" + .I '+$P(PSADATA,"^",15) D + ..I +$P(PSADATA,"^",6),$P($G(^PSDRUG(+$P(PSADATA,"^",6),0)),"^")'="" W ?9,$P(^PSDRUG(+$P(PSADATA,"^",6),0),"^") S PSADRG=+$P(PSADATA,"^",6) Q + ..I $P($G(^XTMP("PSAPV",PSACTRL,"IT",PSALINE,"SUP")),"^",3)'="" W ?7,"**"_$P(^XTMP("PSAPV",PSACTRL,"IT",PSALINE,"SUP"),"^",3) S PSADJSUP=1,PSADRG=0 Q + ..W ?9,"DRUG UNKNOWN" + .I $P(PSADATA,"^",19)="CS" W " (CONTROLLED SUBS)" I $P($G(^PSD(58.8,+$P(PSAIN,"^",12),1,PSADRG,0)),"^",14),$P($G(^(0)),"^",14)'>DT W !?5,"*** INACTIVE IN MASTER VAULT" + .E I PSADRG,$P($G(^PSD(58.8,+$P(PSAIN,"^",7),1,PSADRG,0)),"^",14),$P($G(^(0)),"^",14)'>DT W !?5,"*** INACTIVE IN PHARMACY LOCATION" + .;UPC + .I $P($P(PSADATA,"^",26),"~")'="" W !?9,"UPC: "_$P($P(PSADATA,"^",26),"~") + .;NDC + .S PSANDC=$P($P(PSADATA,"^",4),"~") + .I $E(PSANDC)'="S" D + ..W !?9 D PSANDC1^PSAHELP S PSANDC=PSANDCX + ..I PSANDC'="" W PSANDC Q + ..W "NDC UNKNOWN" + .; + .;VSN + .W ?25,$S($P($P(PSADATA,"^",5),"~")'="":$E($P($P(PSADATA,"^",5),"~"),1,14),1:"VSN UNKNOWN") + .; + .;QTY + .;No Adjusted Qty + .S PSAIECST=PSAIECST+($P(PSADATA,"^")*$P(PSADATA,"^",3)) + .I $P(PSADATA,"^",8)="" W ?40,$J($P(PSADATA,"^"),6) S PSAECOST=$P(PSADATA,"^")*$P(PSADATA,"^",3),PSAAECST=PSAAECST+PSAECOST + .;Adj. Qty (P) + .I $P(PSADATA,"^",8)'="" D + ..S PSADJQTY=$P(PSADATA,"^",8),PSAQDUZ=$P(PSADATA,"^",9),PSAQDT=$P(PSADATA,"^",10),PSAQREA=$P(PSADATA,"^",11) + ..S PSAECOST=PSADJQTY*$P(PSADATA,"^",3),PSAAECST=PSAAECST+PSAECOST + ..W ?40,$J($P(PSADATA,"^",8),6)_"("_$P(PSADATA,"^")_")" + .; +OU .;Order Unit + .I '+$P(PSADATA,"^",12) D + ..I +$P($P(PSADATA,"^",2),"~",2),$P($G(^DIC(51.5,+$P($P(PSADATA,"^",2),"~",2),0)),"^")'="" W ?53,$P($G(^DIC(51.5,+$P($P(PSADATA,"^",2),"~",2),0)),"^") Q + ..I $P($G(PSADATA),"^",2)'="",$P($G(PSADATA),"^",2)'["~",'$D(^DIC(51.5,"B",$P(PSADATA,"^",2))) W ?48," ?-> "_$P(PSADATA,"^",2) + ..I $P($P(PSADATA,"^",2),"~")="" D ^PSAHELP + .;Adj. OU (P) + .I +$P(PSADATA,"^",12) S PSADJORD=$P(PSADATA,"^",12),PSAODUZ=$P(PSADATA,"^",13),PSAODT=$P(PSADATA,"^",14) W ?53,$P($G(^DIC(51.5,+$P(PSADATA,"^",12),0)),"^")_"("_$P($P(PSADATA,"^",2),"~")_")" + .;Unit price + .S PSADEC=$S($L($P($P(PSADATA,"^",3),".",2))>1:$L($P($P(PSADATA,"^",3),".",2)),1:2) + .W ?59,$J($P(PSADATA,"^",3),7,PSADEC) + .;Extended cost + .W ?67,$J(PSAECOST,12,2) + .I $Y+9>IOSL,+$P(PSADATA,"^",21),+$P(PSADATA,"^",27) D:$E(IOST,1,2)="C-" SCREEN Q:PSAOUT D HEADER,LINEHDR + .I $G(PSADRG) D HAVEDRG + .I '$G(PSADRG) W !?9,"STOCK LEVEL : ",!?9,"REORDER LEVEL: "_$P(PSADATA,"^",21),!?9,"DISPENSE UNITS/ORDER UNIT: " + .; + .;Print Adj Qty + .I $G(PSADJQTY)'="" D + ..I $Y+5>IOSL D:$E(IOST,1,2)="C-" SCREEN Q:PSAOUT D HEADER,LINEHDR + ..W !!?9,"ADJUSTED QUANTITY: "_PSADJQTY,!?9,$$DATE(PSAQDT)_" "_$P($G(^VA(200,+PSAQDUZ,0)),"^"),!?11,PSAQREA + .;Print Adj OU + .I +$G(PSADJORD) D + ..I $Y+5>IOSL D:$E(IOST,1,2)="C-" SCREEN Q:PSAOUT D HEADER,LINEHDR + ..W !!,?9,"ADJUSTED ORDER UNIT: "_$P($G(^DIC(51.5,+PSADJORD,0)),"^") + ..W !?9,$$DATE(PSAODT)_" "_$P($G(^VA(200,+PSAODUZ,0)),"^")_" - "_$P($G(^DIC(51.5,PSADJORD,0)),"^") + .W ! + Q:PSAOUT + I $Y+6>IOSL D:$E(IOST,1,2)="C-" SCREEN Q:PSAOUT D HEADER + W !,PSASLN + W:$G(PSAAECST)'=$G(PSAIECST) !?48,"TOTAL ADUSTED COST",?67,$J(PSAAECST,12,2),! + W !?48,"TOTAL INVOICED COST",?67,$J(PSAIECST,12,2) + S PSAEND=1 + I $Y+5>IOSL D:$E(IOST,1,2)="C-" SCREEN Q:PSAOUT D HEADER + I PSADJDRG,$E(IOST)'="C" W !!,"* THE DRUG WAS MATCHED TO THE DRUG FILE." + I PSADJSUP,$E(IOST)'="C" W !!,"* THE ITEM IS A SUPPLY ITEM." + D:$E(IOST,1,2)="C-" SCREEN + Q + ; +LINEHDR ;item header + W !?50,"ORDER",?62,"COST/",?71,"EXTENDED" + W !,"LINE#",?9,"NDC",?25,"VSN",?43,"QTY",?51,"UNIT",?62,"UNIT",?75,"COST",!,PSADLN,! + Q + ; +HEADER ;Page header + I PSAFPG&($E(IOST,1,2)="C-") W @IOF G HDR1 + S PSAFPG=0 + W:'PSAFPG @IOF +HDR1 W !?20,"DRUG ACCOUNTABILITY/INVENTORY INTERFACE" + W !?26,"PRIME VENDOR UPLOAD REPORT",! + W:PSAPAGE'=1 !,"ORDER#: "_$P(PSAIN,"^",4)_" INVOICE#: "_$P(PSAIN,"^",2) + I $E(IOST,1,2)="C-" W ?(74-$L(PSAPAGE)),"PAGE "_PSAPAGE,!,PSADLN + I $E(IOST)'="C" W !,"RUN: "_PSARUN,?(74-$L(PSAPAGE)),"PAGE "_PSAPAGE,!,PSADLN + S PSAPAGE=PSAPAGE+1 + Q +SCREEN ;Hold on screen + S PSAS=20-$Y I PSAS F PSASS=1:1:PSAS W ! + I PSADJDRG,PSAEND W !," * THE DRUG WAS MATCHED TO THE DRUG FILE." + I PSADJSUP,PSAEND W !,"** THE ITEM IS A SUPPLY ITEM." + S DIR(0)="E" D ^DIR K DIR I $G(DIRUT) S PSAOUT=1 + Q + ; +HAVEDRG ;Display data if drug is found. + ;DAVE B (PSA*3*20) 7SEP99 ADDED $G TO NEXT LINE + S PSACS=$S($P($G(^PSDRUG(PSADRG,2)),"^",3)["N":1,1:0) + I PSACS D + .I PSAMV,+$P($G(^PSD(58.8,PSAMV,0)),"^",14) D Q + ..W !?9,"STOCK LEVEL : "_$S(+$P(PSADATA,"^",27):+$P(PSADATA,"^",27),1:+$P($G(^PSD(58.8,PSAMV,1,PSADRG,0)),"^",3)) + ..W !?9,"REORDER LEVEL: "_$S(+$P(PSADATA,"^",21):+$P(PSADATA,"^",21),1:+$P($G(^PSD(58.8,PSAMV,1,PSADRG,0)),"^",5)) + .I 'PSAMV W !?9,"STOCK LEVEL : "_$P(PSADATA,"^",27),!?9,"REORDER LEVEL: "_$P(PSADATA,"^",21) + I 'PSACS D + .I PSAPHARM,+$P($G(^PSD(58.8,PSAPHARM,0)),"^",14) D + ..W !?9,"STOCK LEVEL : "_$S(+$P(PSADATA,"^",27):+$P(PSADATA,"^",27),1:+$P($G(^PSD(58.8,PSAPHARM,1,PSADRG,0)),"^",3)) + ..W !?9,"REORDER LEVEL: "_$S(+$P(PSADATA,"^",21):+$P(PSADATA,"^",21),1:+$P($G(^PSD(58.8,PSAPHARM,1,PSADRG,0)),"^",5)) + .I 'PSAPHARM W !?9,"STOCK LEVEL : "_$P(PSADATA,"^",27),!?9,"REORDER LEVEL: "_$P(PSADATA,"^",21) + W !?9,"DISPENSE UNITS/ORDER UNIT: " + W $S(+$P(PSADATA,"^",20):+$P(PSADATA,"^",20),+$P($G(^PSDRUG(PSADRG,1,+$P(PSADATA,"^",7),0)),"^",7):+$P($G(^PSDRUG(PSADRG,1,+$P(PSADATA,"^",7),0)),"^",7),1:"") + Q diff --git a/r/DRUG_ACCOUNTABILITY-PSA/PSAUTL1.m b/r/DRUG_ACCOUNTABILITY-PSA/PSAUTL1.m index ed3ebf5c..f35e70e4 100644 --- a/r/DRUG_ACCOUNTABILITY-PSA/PSAUTL1.m +++ b/r/DRUG_ACCOUNTABILITY-PSA/PSAUTL1.m @@ -1,119 +1,122 @@ -PSAUTL1 ;BIR/JMB-Prime Vendor Invoice Data Utility ;9/19/97 - ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,12,15,21,48,49,54,67**; 10/24/97;Build 15 - ;This routine contains utilities to get the location name, display an - ;error-free item, display an item with errors, and display a line ready - ;for verification. - ;References to global ^PS(59.4, are covered under IA #2505 - ;References to global ^DIC(51.5, are covered under IA #1931 - ;References to global ^PS(59, are covered under IA #212 - ;References to ^PSDRUG( are covered by IA #2095 - ; -SITES ;Gets the combined IP/OP's IP & OP site names - ;PSA*3*22 (DAVE B) no location defined - I $G(PSALOC)'>0 S (PSAISITN,PSAOSITN)="Unknown",PSACOMB=" No location identified" Q - ;End PSA*3*22 - S PSAISIT=+$P($G(^PSD(58.8,PSALOC,0)),"^",3) D OPSITE - I $G(PSAOSIT)="" S PSAOSIT=0 - S PSAISITN=$S($P($G(^PS(59.4,PSAISIT,0)),"^")'="":$P($G(^PS(59.4,PSAISIT,0)),"^"),1:"UNKNOWN") - I PSAISIT,PSAOSIT S PSACOMB=": "_PSAISITN_" (IP) "_PSAOSITN_" (OP)" Q - I PSAISIT S PSACOMB=": "_PSAISITN_" (IP)" Q - I PSAOSIT S PSACOMB=": "_PSAOSITN_" (OP)" Q - ;DAVE B (PSA*3*12) no DA sites defined - S PSACOMB="No Inpatient or Outpatient Sites defined" - Q -OPSITE ;PSA*3*25 - check for multiple OP sites - ;VMP OIFO BAY PINES;ELR;PSA*3*49 ADDED THE FOLLOWING LINE - S (PSAOSIT,PSAOSITN)="" - K PSAOSITC - Q:'$D(PSALOC) - I '$D(^PSD(58.8,+PSALOC,7)),$P(^PSD(58.8,+PSALOC,0),"^",10)'="" S PSAOSIT=$P(^PSD(58.8,+PSALOC,0),"^",10),PSAOSITN=$P($G(^PS(59,PSAOSIT,0)),"^"),PSAOSITN=$S($G(PSAOSITN)="":"Unknown",1:PSAOSITN) - S XX=0 F S XX=$O(^PSD(58.8,+PSALOC,7,XX)) Q:XX'>0 S PSAOSIT=XX,PSAOSITC=$G(PSAOSITC)+1,SN=$P($G(^PS(59,XX,0)),"^") D - .I PSAOSITC=1 S PSAOSITN=SN Q - .S PSAOSITN=PSAOSITN_" & "_SN - I $G(PSAOSITN)="",$P(^PSD(58.8,+PSALOC,0),"^",10)'="" S PSAOSIT=$P(^PSD(58.8,+PSALOC,0),"^",10),PSAOSITN=$P($G(^PS(59,+PSAOSIT,0)),"^") - S PSAOSITN=$S($G(PSAOSITN)="":"unknown",1:PSAOSITN) - Q - ; -DISPLAY ;Displays an error-free line item - S PSADISP=1 - S PSAIEN=$P(PSADATA,"^",6),PSASUB=$P($P(PSADATA,"^",7),"~"),PSANDC=$P($P(PSADATA,"^",4),"~"),PSAVSN=$P($P(PSADATA,"^",5),"~") - W !,PSALINE_" "_$S($P($G(^PSDRUG(PSAIEN,0)),"^")'="":$P(^PSDRUG(PSAIEN,0),"^"),1:"UNKNOWN") - I PSAIEN D - .I $P($G(^PSDRUG(PSAIEN,2)),"^",3)["N" W " (Controlled Substance)" I $P($G(^PSD(58.8,+$P(PSAIN,"^",12),1,PSAIEN,0)),"^",14),$P($G(^(0)),"^",14)'>DT W !,$C(7),$C(7),"** INACTIVE IN MASTER VAULT **" Q - .I $P($G(^PSD(58.8,+$P(PSAIN,"^",7),1,PSAIEN,0)),"^",14),$P($G(^(0)),"^",14)'>DT W !,$C(7),$C(7),"** INACTIVE IN PHARMACY LOCATION **" - .I $D(^PSDRUG(PSAIEN,"I")) W !?5,"** INACTIVE IN DRUG FILE **" - W !,"Qty Invoiced: "_+$P(PSADATA,"^") - W:$P($P(PSADATA,"^",26),"~")'="" ?38,"UPC: "_$P($P(PSADATA,"^",26),"~") - W !,"Order Unit : " - S PSAOU=$S(+$P(PSADATA,"^",12):+$P(PSADATA,"^",12),+$P($P(PSADATA,"^",2),"~",2):+$P($P(PSADATA,"^",2),"~",2),PSAIEN&(PSASUB)&(+$P($G(^PSDRUG(PSAIEN,1,PSASUB,0)),"^",5)):+$P(^PSDRUG(PSAIEN,1,PSASUB,0),"^",5),1:0) - W $S(PSAOU:$P($G(^DIC(51.5,+PSAOU,0)),"^"),1:"UNKNOWN") - W:$E(PSANDC)'="S" ?38,"NDC: " D PSANDC1^PSAHELP W PSANDCX K PSANDCX - W !,"Unit Price : $"_$P(PSADATA,"^",3),?38,"VSN: "_$S(PSAVSN'="":PSAVSN,1:"Blank"),! - I $P(PSADATA,U,13)=.5 D ;*48 AUTO OU UPDATE FOR MCKESSON - .W !,"*****>",!,"Note: The order unit was changed from EACH to ",$P($G(^DIC(51.5,+PSAOU,0)),"^")," by Drug Accountability" - .W !," during the upload of the invoiced data. Adjustments may be necessary.",!,"*****<" - ;bgn *67 - W !,"PV-Drug-Description : ",$S($P(PSADATA,"^",28)'="":$P(PSADATA,"^",28),1:"Unknown") - W ?55,"PV-DUOU : ",$S($P(PSADATA,"^",31)'="":$P(PSADATA,"^",31),1:"Unknown") - W !,"PV-Drug-Generic Name : ",$S($P(PSADATA,"^",29)'="":$P(PSADATA,"^",29),1:"Unknown") - W ?55,"PV-UNITS : ",$S($P(PSADATA,"^",30)'="":$P(PSADATA,"^",30),1:"Unknown"),! - ;end *67 - W !,"Dispense Units: "_$S(+PSAIEN&($P($G(^PSDRUG(+PSAIEN,660)),"^",8)'=""):$P($G(^PSDRUG(+PSAIEN,660)),"^",8),1:"Blank") - W !,"Dispense Units Per Order Unit: "_$S($P(PSADATA,"^",20):+$P(PSADATA,"^",20),+PSASUB&(+$P($G(^PSDRUG(+PSAIEN,1,PSASUB,0)),"^",7)):+$P($G(^PSDRUG(+PSAIEN,1,PSASUB,0)),"^",7),1:"Blank") - S PSALOC=$S($P(PSADATA,"^",19)="":+$P(PSAIN,"^",7),1:+$P(PSAIN,"^",12)) - Q:'+$P($G(^PSD(58.8,+PSALOC,0)),"^",14)!('$G(PSAIEN)) - S PSASTOCK=$S(+$P(PSADATA,"^",27):+$P(PSADATA,"^",27),+$P($G(^PSD(58.8,+PSALOC,1,+PSAIEN,0)),"^",3):+$P($G(^PSD(58.8,+PSALOC,1,+PSAIEN,0)),"^",3),1:"Blank") - W !,"Stock Level : "_PSASTOCK - S PSAREORD=$S(+$P(PSADATA,"^",21):+$P(PSADATA,"^",21),+$P($G(^PSD(58.8,+PSALOC,1,+PSAIEN,0)),"^",5):+$P($G(^PSD(58.8,+PSALOC,1,+PSAIEN,0)),"^",5),1:"Blank") ;*48 - W !,"Reorder Level : "_PSAREORD,! - Q - ; -EDITDISP ;Displays a line item with errors. - W @IOF,!?23,"<<< PROCESS LINE ITEM SCREEN >>>",!,"Order#: "_$P(PSAIN,"^",4)_" Invoice#: "_$P(PSAIN,"^",2)_" Invoice Date: "_$$FMTE^XLFDT(+PSAIN),!,PSASLN -EDIT1 S PSADATA=$G(^XTMP("PSAPV",PSACTRL,"IT",PSALINE)) - S PSASUB=+$P(PSADATA,"^",7) ;*54 - S PSAIEN=+$P(PSADATA,"^",15) I PSAIEN ;*54 - E S PSAIEN=+$P(PSADATA,"^",6) ;*54 - S PSALOC=$S($P(PSADATA,"^",19)="":+$P(PSAIN,"^",7),1:+$P(PSAIN,"^",12)) - W !,PSALINE_" "_$S($D(^XTMP("PSAPV",PSACTRL,"IT",PSALINE,"SUP")):$P(^XTMP("PSAPV",PSACTRL,"IT",PSALINE,"SUP"),"^",3),PSAIEN&($P($G(^PSDRUG(PSAIEN,0)),"^")'=""):$P(^PSDRUG(PSAIEN,0),"^"),1:"UNKNOWN ITEM") - I PSAIEN D - .I $P($G(^PSDRUG(PSAIEN,2)),"^",3)["N" W " (Controlled Substance)" I $P($G(^PSD(58.8,+$P(PSAIN,"^",12),1,PSAIEN,0)),"^",14),$P($G(^(0)),"^",14)'>DT W !,$C(7),$C(7),"** INACTIVE IN MASTER VAULT **" Q - .I $P($G(^PSD(58.8,+$P(PSAIN,"^",7),1,PSAIEN,0)),"^",14),$P($G(^(0)),"^",14)'>DT W !,$C(7),$C(7),"** INACTIVE IN PHARMACY LOCATION **" - ; - W !,"Qty Invoiced: " - I $P(PSADATA,"^",8)'="" W $P(PSADATA,"^",8)_" ("_$S(+PSADATA:+PSADATA,$P(PSADATA,"^")=0:0,1:"Blank")_")" - I $P(PSADATA,"^",8)="" W $S(+PSADATA:+PSADATA,$P(PSADATA,"^")=0:0,1:"Blank") - W:$P($P(PSADATA,"^",26),"~")'="" ?38,"UPC: "_$P($P(PSADATA,"^",26),"~") - ; - W !,"Order Unit : " - I +$P(PSADATA,"^",12) D - .W $P($G(^DIC(51.5,+$P(PSADATA,"^",12),0)),"^") - .W " ("_$S($P($P(PSADATA,"^",2),"~")'="":$P($P(PSADATA,"^",2),"~"),$P($G(^DIC(51.5,+$P($P(PSADATA,"^",2),"~",3),0)),"^")'="":$P($G(^DIC(51.5,+$P($P(PSADATA,"^",2),"~",3),0)),"^"),1:"Blank")_")" - I '+$P(PSADATA,"^",12) D - .W $S(+$P($P(PSADATA,"^",2),"~",2):$P($P(PSADATA,"^",2),"~"),PSAIEN&(PSASUB)&(+$P($G(^PSDRUG(PSAIEN,1,PSASUB,0)),"^",5)):$P($G(^DIC(51.5,+$P(^PSDRUG(PSAIEN,1,PSASUB,0),"^",5),0)),"^"),1:"Blank") - ; - W:$E(PSANDC)'="S" ?38,"NDC: " D PSANDC1^PSAHELP W PSANDCX K PSANDCX - S PSAPRICE=$P(PSADATA,"^",3) - I +PSAPRICE,$L($P(PSAPRICE,".",2))<2 S PSAPRICE=$P(PSAPRICE,".")_"."_$P(PSAPRICE,".",2)_$E("00",1,(2-$L($P(PSAPRICE,".",2)))) - W !,"Unit Price : $"_$S($G(PSAPRICE):PSAPRICE,PSAPRICE=0:0,1:"Blank"),?38,"VSN: "_$S(PSAVSN'="":PSAVSN,1:"Blank"),! - I $P(PSADATA,U,13)=.5 D ;*48 AUTO OU UPDATE FOR MCKESSON - .N PSAOU S PSAOU=$P(PSADATA,U,12) - .W !,"*****>",!,"Note: The order unit was changed from EACH to ",$P($G(^DIC(51.5,+PSAOU,0)),"^")," by Drug Accountability" - .W !," during the upload of the invoiced data. Adjustments may be necessary.",!,"*****<" - ;bgn *67 - W !,"PV-Drug-Description : ",$S($P(PSADATA,"^",28)'="":$P(PSADATA,"^",28),1:"Unknown") - W ?55,"PV-DUOU : ",$S($P(PSADATA,"^",31)'="":$P(PSADATA,"^",31),1:"Unknown") - W !,"PV-Drug-Generic Name : ",$S($P(PSADATA,"^",29)'="":$P(PSADATA,"^",29),1:"Unknown") - W ?55,"PV-UNITS : ",$S($P(PSADATA,"^",30)'="":$P(PSADATA,"^",30),1:"Unknown"),! - ;end *67 - S PSAIN=^XTMP("PSAPV",PSACTRL,"IN"),PSALOC=$S($P(PSADATA,"^",19)="CS":+$P(PSAIN,"^",12),1:+$P(PSAIN,"^",7)) -DU W !,"Dispense Units: "_$S(+PSAIEN&($P($G(^PSDRUG(+PSAIEN,660)),"^",8)'=""):$P($G(^PSDRUG(+PSAIEN,660)),"^",8),1:"Blank") -DUOU W !,"Dispense Units Per Order Unit: "_$S($P(PSADATA,"^",20):+$P(PSADATA,"^",20),+PSASUB&(+$P($G(^PSDRUG(+PSAIEN,1,PSASUB,0)),"^",7)):+$P($G(^PSDRUG(+PSAIEN,1,PSASUB,0)),"^",7),1:"Blank"),! - ; - Q:'+$P($G(^PSD(58.8,+PSALOC,0)),"^",14) - ; - S PSASTOCK=$S(+$P(PSADATA,"^",27):+$P(PSADATA,"^",27),+$P($G(^PSD(58.8,+PSALOC,1,+PSAIEN,0)),"^",3):+$P($G(^PSD(58.8,+PSALOC,1,+PSAIEN,0)),"^",3),1:"Blank") - W "Stock Level : "_PSASTOCK - S PSAREORD=$S(+$P(PSADATA,"^",21):+$P(PSADATA,"^",21),+$P($G(^PSD(58.8,+PSALOC,1,+PSAIEN,0)),"^",5):+$P($G(^PSD(58.8,+PSALOC,1,+PSAIEN,0)),"^",5),1:"Blank") - W !,"Reorder Level : "_PSAREORD,! - Q +PSAUTL1 ;BIR/JMB-Prime Vendor Invoice Data Utility ;9/19/97 + ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,12,15,21,48,49,54**; 10/24/97 + ;This routine contains utilities to get the location name, display an + ;error-free item, display an item with errors, and display a line ready + ;for verification. + ;References to global ^PS(59.4, are covered under IA #2505 + ;References to global ^DIC(51.5, are covered under IA #1931 + ;References to global ^PS(59, are covered under IA #212 + ;References to ^PSDRUG( are covered by IA #2095 + ; +SITES ;Gets the combined IP/OP's IP & OP site names + ;PSA*3*22 (DAVE B) no location defined + I $G(PSALOC)'>0 S (PSAISITN,PSAOSITN)="Unknown",PSACOMB=" No location identified" Q + ;End PSA*3*22 + S PSAISIT=+$P($G(^PSD(58.8,PSALOC,0)),"^",3) D OPSITE + I $G(PSAOSIT)="" S PSAOSIT=0 + S PSAISITN=$S($P($G(^PS(59.4,PSAISIT,0)),"^")'="":$P($G(^PS(59.4,PSAISIT,0)),"^"),1:"UNKNOWN") + I PSAISIT,PSAOSIT S PSACOMB=": "_PSAISITN_" (IP) "_PSAOSITN_" (OP)" Q + I PSAISIT S PSACOMB=": "_PSAISITN_" (IP)" Q + I PSAOSIT S PSACOMB=": "_PSAOSITN_" (OP)" Q + ;DAVE B (PSA*3*12) no DA sites defined + S PSACOMB="No Inpatient or Outpatient Sites defined" + Q +OPSITE ;PSA*3*25 - check for multiple OP sites + ;VMP OIFO BAY PINES;ELR;PSA*3*49 ADDED THE FOLLOWING LINE + S (PSAOSIT,PSAOSITN)="" + K PSAOSITC + Q:'$D(PSALOC) + I '$D(^PSD(58.8,+PSALOC,7)),$P(^PSD(58.8,+PSALOC,0),"^",10)'="" S PSAOSIT=$P(^PSD(58.8,+PSALOC,0),"^",10),PSAOSITN=$P($G(^PS(59,PSAOSIT,0)),"^"),PSAOSITN=$S($G(PSAOSITN)="":"Unknown",1:PSAOSITN) + S XX=0 F S XX=$O(^PSD(58.8,+PSALOC,7,XX)) Q:XX'>0 S PSAOSIT=XX,PSAOSITC=$G(PSAOSITC)+1,SN=$P($G(^PS(59,XX,0)),"^") D + .I PSAOSITC=1 S PSAOSITN=SN Q + .S PSAOSITN=PSAOSITN_" & "_SN + I $G(PSAOSITN)="",$P(^PSD(58.8,+PSALOC,0),"^",10)'="" S PSAOSIT=$P(^PSD(58.8,+PSALOC,0),"^",10),PSAOSITN=$P($G(^PS(59,+PSAOSIT,0)),"^") + S PSAOSITN=$S($G(PSAOSITN)="":"unknown",1:PSAOSITN) + Q + ; +DISPLAY ;Displays an error-free line item + S PSADISP=1 + S PSAIEN=$P(PSADATA,"^",6),PSASUB=$P($P(PSADATA,"^",7),"~"),PSANDC=$P($P(PSADATA,"^",4),"~"),PSAVSN=$P($P(PSADATA,"^",5),"~") + W !,PSALINE_" "_$S($P($G(^PSDRUG(PSAIEN,0)),"^")'="":$P(^PSDRUG(PSAIEN,0),"^"),1:"UNKNOWN") + I PSAIEN D + .I $P($G(^PSDRUG(PSAIEN,2)),"^",3)["N" W " (Controlled Substance)" I $P($G(^PSD(58.8,+$P(PSAIN,"^",12),1,PSAIEN,0)),"^",14),$P($G(^(0)),"^",14)'>DT W !,$C(7),$C(7),"** INACTIVE IN MASTER VAULT **" Q + .I $P($G(^PSD(58.8,+$P(PSAIN,"^",7),1,PSAIEN,0)),"^",14),$P($G(^(0)),"^",14)'>DT W !,$C(7),$C(7),"** INACTIVE IN PHARMACY LOCATION **" + .I $D(^PSDRUG(PSAIEN,"I")) W !?5,"** INACTIVE IN DRUG FILE **" + W !,"Qty Invoiced: "_+$P(PSADATA,"^") + W:$P($P(PSADATA,"^",26),"~")'="" ?38,"UPC: "_$P($P(PSADATA,"^",26),"~") + W !,"Order Unit : " + S PSAOU=$S(+$P(PSADATA,"^",12):+$P(PSADATA,"^",12),+$P($P(PSADATA,"^",2),"~",2):+$P($P(PSADATA,"^",2),"~",2),PSAIEN&(PSASUB)&(+$P($G(^PSDRUG(PSAIEN,1,PSASUB,0)),"^",5)):+$P(^PSDRUG(PSAIEN,1,PSASUB,0),"^",5),1:0) + W $S(PSAOU:$P($G(^DIC(51.5,+PSAOU,0)),"^"),1:"UNKNOWN") + W:$E(PSANDC)'="S" ?38,"NDC: " D PSANDC1^PSAHELP W PSANDCX K PSANDCX + W !,"Unit Price : $"_$P(PSADATA,"^",3),?38,"VSN: "_$S(PSAVSN'="":PSAVSN,1:"Blank"),! + I $P(PSADATA,U,13)=.5 D ;*48 AUTO OU UPDATE FOR MCKESSON + . W !,"*****>",!,"Note: The order unit was changed from EACH to ",$P($G(^DIC(51.5,+PSAOU,0)),"^")," by Drug Accountability" + . W !," during the upload of the invoiced data. Adjustments may be necessary.",!,"*****<" + ;*54 display VSN XTMP Drug Description and DUOU >==> + N PSAFLDT S PSAFLDT="February 2006" + N XXX S XXX=$G(^XTMP("PSAVSN",PSAVSN)) D + . I $G(^XTMP("PSAVSN",0)) S PSAFLDT=$P(^XTMP("PSAVSN",0),"^",4) + . W !,"PV-Drug-Descrip: " + . I '$L(XXX) W "Not Available. Item is OTC or new after ",PSAFLDT,! Q + . W ?20,$P(XXX,"~",2),?55,"PV-DUOU: ",+XXX,! + ;*54 display VSN XTMP Drug Description and DUOU <==< + W !,"Dispense Units: "_$S(+PSAIEN&($P($G(^PSDRUG(+PSAIEN,660)),"^",8)'=""):$P($G(^PSDRUG(+PSAIEN,660)),"^",8),1:"Blank") + W !,"Dispense Units Per Order Unit: "_$S($P(PSADATA,"^",20):+$P(PSADATA,"^",20),+PSASUB&(+$P($G(^PSDRUG(+PSAIEN,1,PSASUB,0)),"^",7)):+$P($G(^PSDRUG(+PSAIEN,1,PSASUB,0)),"^",7),1:"Blank") + S PSALOC=$S($P(PSADATA,"^",19)="":+$P(PSAIN,"^",7),1:+$P(PSAIN,"^",12)) + Q:'+$P($G(^PSD(58.8,+PSALOC,0)),"^",14)!('$G(PSAIEN)) + S PSASTOCK=$S(+$P(PSADATA,"^",27):+$P(PSADATA,"^",27),+$P($G(^PSD(58.8,+PSALOC,1,+PSAIEN,0)),"^",3):+$P($G(^PSD(58.8,+PSALOC,1,+PSAIEN,0)),"^",3),1:"Blank") + W !,"Stock Level : "_PSASTOCK + S PSAREORD=$S(+$P(PSADATA,"^",21):+$P(PSADATA,"^",21),+$P($G(^PSD(58.8,+PSALOC,1,+PSAIEN,0)),"^",5):+$P($G(^PSD(58.8,+PSALOC,1,+PSAIEN,0)),"^",5),1:"Blank") ;*48 + W !,"Reorder Level : "_PSAREORD,! + Q + ; +EDITDISP ;Displays a line item with errors. + W @IOF,!?23,"<<< PROCESS LINE ITEM SCREEN >>>",!,"Order#: "_$P(PSAIN,"^",4)_" Invoice#: "_$P(PSAIN,"^",2)_" Invoice Date: "_$$FMTE^XLFDT(+PSAIN),!,PSASLN +EDIT1 S PSADATA=$G(^XTMP("PSAPV",PSACTRL,"IT",PSALINE)) + S PSASUB=+$P(PSADATA,"^",7) ;*54 + S PSAIEN=+$P(PSADATA,"^",15) I PSAIEN ;*54 + E S PSAIEN=+$P(PSADATA,"^",6) ;*54 + S PSALOC=$S($P(PSADATA,"^",19)="":+$P(PSAIN,"^",7),1:+$P(PSAIN,"^",12)) + W !,PSALINE_" "_$S($D(^XTMP("PSAPV",PSACTRL,"IT",PSALINE,"SUP")):$P(^XTMP("PSAPV",PSACTRL,"IT",PSALINE,"SUP"),"^",3),PSAIEN&($P($G(^PSDRUG(PSAIEN,0)),"^")'=""):$P(^PSDRUG(PSAIEN,0),"^"),1:"UNKNOWN ITEM") + I PSAIEN D + .I $P($G(^PSDRUG(PSAIEN,2)),"^",3)["N" W " (Controlled Substance)" I $P($G(^PSD(58.8,+$P(PSAIN,"^",12),1,PSAIEN,0)),"^",14),$P($G(^(0)),"^",14)'>DT W !,$C(7),$C(7),"** INACTIVE IN MASTER VAULT **" Q + .I $P($G(^PSD(58.8,+$P(PSAIN,"^",7),1,PSAIEN,0)),"^",14),$P($G(^(0)),"^",14)'>DT W !,$C(7),$C(7),"** INACTIVE IN PHARMACY LOCATION **" + ; + W !,"Qty Invoiced: " + I $P(PSADATA,"^",8)'="" W $P(PSADATA,"^",8)_" ("_$S(+PSADATA:+PSADATA,$P(PSADATA,"^")=0:0,1:"Blank")_")" + I $P(PSADATA,"^",8)="" W $S(+PSADATA:+PSADATA,$P(PSADATA,"^")=0:0,1:"Blank") + W:$P($P(PSADATA,"^",26),"~")'="" ?38,"UPC: "_$P($P(PSADATA,"^",26),"~") + ; + W !,"Order Unit : " + I +$P(PSADATA,"^",12) D + .W $P($G(^DIC(51.5,+$P(PSADATA,"^",12),0)),"^") + .W " ("_$S($P($P(PSADATA,"^",2),"~")'="":$P($P(PSADATA,"^",2),"~"),$P($G(^DIC(51.5,+$P($P(PSADATA,"^",2),"~",3),0)),"^")'="":$P($G(^DIC(51.5,+$P($P(PSADATA,"^",2),"~",3),0)),"^"),1:"Blank")_")" + I '+$P(PSADATA,"^",12) D + .W $S(+$P($P(PSADATA,"^",2),"~",2):$P($P(PSADATA,"^",2),"~"),PSAIEN&(PSASUB)&(+$P($G(^PSDRUG(PSAIEN,1,PSASUB,0)),"^",5)):$P($G(^DIC(51.5,+$P(^PSDRUG(PSAIEN,1,PSASUB,0),"^",5),0)),"^"),1:"Blank") + ; + W:$E(PSANDC)'="S" ?38,"NDC: " D PSANDC1^PSAHELP W PSANDCX K PSANDCX + S PSAPRICE=$P(PSADATA,"^",3) + I +PSAPRICE,$L($P(PSAPRICE,".",2))<2 S PSAPRICE=$P(PSAPRICE,".")_"."_$P(PSAPRICE,".",2)_$E("00",1,(2-$L($P(PSAPRICE,".",2)))) + W !,"Unit Price : $"_$S($G(PSAPRICE):PSAPRICE,PSAPRICE=0:0,1:"Blank"),?38,"VSN: "_$S(PSAVSN'="":PSAVSN,1:"Blank"),! + I $P(PSADATA,U,13)=.5 D ;*48 AUTO OU UPDATE FOR MCKESSON + . N PSAOU S PSAOU=$P(PSADATA,U,12) + . W !,"*****>",!,"Note: The order unit was changed from EACH to ",$P($G(^DIC(51.5,+PSAOU,0)),"^")," by Drug Accountability" + . W !," during the upload of the invoiced data. Adjustments may be necessary.",!,"*****<" + N PSAFLDT S PSAFLDT="February 2006" + N XXX S XXX=$G(^XTMP("PSAVSN",PSAVSN)) D + .I $G(^XTMP("PSAVSN",0)) S PSAFLDT=$P(^XTMP("PSAVSN",0),"^",4) + . W !,"PV-Drug-Descrip: " + . I '$L(XXX) W "Not Available. Item is OTC or new after ",PSAFLDT,! Q + . W ?20,$P(XXX,"~",2),?55,"PV-DUOU: ",+XXX,! + ;*54 display VSN XTMP Drug Description and DUOU <==< + S PSAIN=^XTMP("PSAPV",PSACTRL,"IN"),PSALOC=$S($P(PSADATA,"^",19)="CS":+$P(PSAIN,"^",12),1:+$P(PSAIN,"^",7)) +DU W !,"Dispense Units: "_$S(+PSAIEN&($P($G(^PSDRUG(+PSAIEN,660)),"^",8)'=""):$P($G(^PSDRUG(+PSAIEN,660)),"^",8),1:"Blank") +DUOU W !,"Dispense Units Per Order Unit: "_$S($P(PSADATA,"^",20):+$P(PSADATA,"^",20),+PSASUB&(+$P($G(^PSDRUG(+PSAIEN,1,PSASUB,0)),"^",7)):+$P($G(^PSDRUG(+PSAIEN,1,PSASUB,0)),"^",7),1:"Blank"),! + ; + Q:'+$P($G(^PSD(58.8,+PSALOC,0)),"^",14) + ; + S PSASTOCK=$S(+$P(PSADATA,"^",27):+$P(PSADATA,"^",27),+$P($G(^PSD(58.8,+PSALOC,1,+PSAIEN,0)),"^",3):+$P($G(^PSD(58.8,+PSALOC,1,+PSAIEN,0)),"^",3),1:"Blank") + W "Stock Level : "_PSASTOCK + S PSAREORD=$S(+$P(PSADATA,"^",21):+$P(PSADATA,"^",21),+$P($G(^PSD(58.8,+PSALOC,1,+PSAIEN,0)),"^",5):+$P($G(^PSD(58.8,+PSALOC,1,+PSAIEN,0)),"^",5),1:"Blank") + W !,"Reorder Level : "_PSAREORD,! + Q diff --git a/r/DRUG_ACCOUNTABILITY-PSA/PSAUTL4.m b/r/DRUG_ACCOUNTABILITY-PSA/PSAUTL4.m index 49d20178..075556f4 100644 --- a/r/DRUG_ACCOUNTABILITY-PSA/PSAUTL4.m +++ b/r/DRUG_ACCOUNTABILITY-PSA/PSAUTL4.m @@ -1,81 +1,82 @@ -PSAUTL4 ;BIR ISC/JMB-Verify Invoices Utility ; 8/19/97 - ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,21,48,54,61,67**; 10/24/97;Build 15 - ; - ;References to ^DIC(51.5 are covered by IA #1931 - ;References to ^PSDRUG( are covered by IA #2095 - I $G(PSADICW)=1 S PSALINE=Y - ;This routine contains a utility to display a line item ready for - ;verification. It is called by PSAVER1 and PSAVER2. - ; -VERDISP ;Displays a line item on a processed or verified invoice - W PSALINEN_" " -DRUG S PSADJ=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","D",0)) - I $G(PSADJ) D - .S PSANODE=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0)) - .S PSADJD=$S($P(PSANODE,"^",6)'="":$P(PSANODE,"^",6),1:$P(PSANODE,"^",2)) - .I PSADJD'?1.N S PSASUP=1 - .S PSADRG=$S(PSADJ&('PSASUP):$G(PSADJD),PSADJ&(PSASUP):0,1:+$P(PSADATA,"^",2)) - .I $G(PSADJD),$L(PSADJD)=$L(+PSADJD),$P($G(^PSDRUG(+PSADJD,0)),"^")'="" W "*"_$P($G(^PSDRUG(+PSADJD,0)),"^") S (PSADRG,PSA50IEN)=+PSADJD Q - .I $G(PSADJD),$L(PSADJD)=$L(+PSADJD),$P($G(^PSDRUG(+PSADJD,0)),"^")="" S (PSADJ,PSADRG)=0 Q - .W ?7,"**"_PSADJD S PSADJSUP=1,(PSADRG,PSA50IEN)=PSADJD - I '$G(PSADJ) D - .S (PSA50IEN,PSADRG)=$S(+$P(PSADATA,"^",2)&($P($G(^PSDRUG(+$P(PSADATA,"^",2),0)),"^")'=""):+$P(PSADATA,"^",2),1:0) - .W $S(+$P(PSADATA,"^",2)&($P($G(^PSDRUG(+$P(PSADATA,"^",2),0)),"^")'=""):$P(^PSDRUG(+$P(PSADATA,"^",2),0),"^"),1:"DRUG UNKNOWN") - I PSADRG D - .I $P($G(^PSDRUG(PSADRG,2)),"^",3)["N" W " (Controlled Substance)" I $P($G(^PSD(58.8,+$P(PSAIN,"^",12),1,PSADRG,0)),"^",14),$P($G(^(0)),"^",14)'>DT W !,$C(7),$C(7),"** INACTIVE IN MASTER VAULT **" - .I $D(^PSDRUG(PSADRG,"I")) W !?5,"** INACTIVE IN DRUG FILE **" Q - .I $P($G(^PSD(58.8,+$P(PSAIN,"^",5),1,PSADRG,0)),"^",14),$P($G(^(0)),"^",14)'>DT W !,$C(7),$C(7),"** INACTIVE IN PHARMACY LOCATION **" -QTY W !,"Qty Invoiced: " - ;No Adj. Qty - S PSADJQ="",PSADJ=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","Q",0)) - I $G(PSADJ) S PSANODE=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0)),PSADJQ=$S($P(PSANODE,"^",6)'="":+$P(PSANODE,"^",6),1:$P(PSANODE,"^",2)) - ;Adj. Qty - I $G(PSADJQ) S PSAQTY=PSADJQ W PSAQTY_" ("_$S($P(PSADATA,"^",3):$P(PSADATA,"^",3),$P(PSADATA,"^",3)=0:0,1:"Blank")_")" - I '$G(PSADJQ) W $P(PSADATA,"^",3) S PSAQTY=$P(PSADATA,"^",3) -UPC S PSAUPC=$P(PSADATA,U,13) W:PSAUPC'="" ?38,"UPC: "_PSAUPC -OU W !,"Order Unit : " - S PSAOU=$S(+$P(PSADATA,"^",4)&($P($G(^DIC(51.5,+$P(PSADATA,"^",4),0)),"^")'=""):+$P(PSADATA,"^",4),1:"") - S PSATEMP=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2)) - I +$P(PSATEMP,"^",3),PSADRG,+$P($G(^PSDRUG(PSADRG,1,+$P(PSATEMP,"^",3),0)),"^",5) S PSAOU=+$P(^PSDRUG(PSADRG,1,+$P(PSATEMP,"^",3),0),"^",5) - S PSADJO="",PSADJ=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","O",0)) - I $G(PSADJ) S PSANODE=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0)),PSADJO=$S($P(PSANODE,"^",6)'="":$P(PSANODE,"^",6),1:$P(PSANODE,"^",2)) - ;Adj. Order Unit - I PSADJO'="" W $S(+PSADJO&($P($G(^DIC(51.5,+PSADJO,0)),"^")'=""):$P($G(^DIC(51.5,+PSADJO,0)),"^"),1:"UNKNOWN")_" ("_$S(PSAOU:$P($G(^DIC(51.5,+PSAOU,0)),"^"),1:"Blank")_")" S PSAOU=+PSADJO - I PSADJO="" W $S(+PSAOU:$P($G(^DIC(51.5,+PSAOU,0)),"^"),1:"Blank") - ; -NDC S PSANDC=$P(PSADATA,"^",11) - I $E(PSANDC)'="S" W ?38,"NDC: " D PSANDC1^PSAHELP W PSANDCX K PSANDCX - ; -PRICE W !,"Unit Price : $" - S PSADJP=0,PSADJ=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","P",0)) - I $G(PSADJ) S PSANODE=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0)),PSADJP=$S(+$P(PSANODE,"^",6):+$P(PSANODE,"^",6),1:+$P(PSANODE,"^",2)) - ;Adj. Unit Price - I $G(PSADJP) D - .I $L($P(PSADJP,".",2))<2 S PSADJP=$P(PSADJP,".")_"."_$P(PSADJP,".",2)_$E("00",1,(2-$L($P(PSADJP,".",2)))) - .W $FN(PSADJP,",")_" ($"_$S(+$P(PSADATA,"^",5):$FN($P(PSADATA,"^",5),","),$P(PSADATA,"^",5)=0:"0.00",1:"")_")" - .S PSAPRICE=PSADJP - I '$G(PSADJP) D - .S PSAPRICE=+$P(PSADATA,"^",5) - .I $G(PSAPRICE)!(PSAPRICE=0) W $S($G(PSAPRICE):PSAPRICE,1:"0.00") Q - .W "Blank" - ; -VSN S:$D(PSADATA) PSAVSN=$P(PSADATA,"^",12) ;*48 - W ?38,"VSN: "_$S(PSAVSN'="":PSAVSN,1:"Blank"),! - ;bgn *67 - S PSAP67=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,3,PSALINE,0)) - W !,"PV-Drug-Description : ",$S($P(PSAP67,"^",1)'="":$P(PSAP67,"^",1),1:"Unknown") - W ?55,"PV-DUOU : ",$S($P(PSAP67,"^",4)'="":$P(PSAP67,"^",4),1:"Unknown") - W !,"PV-Drug-Generic Name : ",$S($P(PSAP67,"^",2)'="":$P(PSAP67,"^",2),1:"Unknown") - W ?55,"PV-UNITS : ",$S($P(PSAP67,"^",3)'="":$P(PSAP67,"^",3),1:"Unknown"),! - ;end *67 -VDU S PSADUOU=+$P(PSATEMP,"^"),PSAREORD=+$P(PSATEMP,"^",2),PSASUB=+$P(PSATEMP,"^",3),PSASTOCK=+$P(PSATEMP,"^",4) - W !,"Dispense Units: "_$S($P($G(^PSDRUG(+PSADRG,660)),"^",8)'="":$P($G(^PSDRUG(+PSADRG,660)),"^",8),1:"Blank") -VDUOU W !,"Dispense Units Per Order Unit: "_$S(+PSADUOU:+PSADUOU,+PSASUB&(+$P($G(^PSDRUG(+PSADRG,1,PSASUB,0)),"^",7)):+$P($G(^PSDRUG(+PSADRG,1,PSASUB,0)),"^",7),1:"Blank"),! - ; - Q:'+$P($G(^PSD(58.8,+PSALOC,0)),"^",14) - ; -STOCK S PSASTOCK=$S(+PSASTOCK:+PSASTOCK,+$P($G(^PSD(58.8,+PSALOC,1,+PSADRG,0)),"^",3):+$P($G(^PSD(58.8,+PSALOC,1,+PSADRG,0)),"^",3),1:"Blank") - W "Stock Level : "_PSASTOCK -REORDER S PSAREORD=$S(+PSAREORD:+PSAREORD,+$P($G(^PSD(58.8,+PSALOC,1,+PSADRG,0)),"^",5):+$P($G(^PSD(58.8,+PSALOC,1,+PSADRG,0)),"^",5),1:"Blank") - W !,"Reorder Level : "_PSAREORD,! - Q +PSAUTL4 ;BIR ISC/JMB-Verify Invoices Utility ; 8/19/97 + ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,21,48,54,61**; 10/24/97;Build 1 + ; + ;References to ^DIC(51.5 are covered by IA #1931 + ;References to ^PSDRUG( are covered by IA #2095 + I $G(PSADICW)=1 S PSALINE=Y + ;This routine contains a utility to display a line item ready for + ;verification. It is called by PSAVER1 and PSAVER2. + ; +VERDISP ;Displays a line item on a processed or verified invoice + W PSALINEN_" " +DRUG S PSADJ=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","D",0)) + I $G(PSADJ) D + .S PSANODE=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0)) + .S PSADJD=$S($P(PSANODE,"^",6)'="":$P(PSANODE,"^",6),1:$P(PSANODE,"^",2)) + .I PSADJD'?1.N S PSASUP=1 + .S PSADRG=$S(PSADJ&('PSASUP):$G(PSADJD),PSADJ&(PSASUP):0,1:+$P(PSADATA,"^",2)) + .I $G(PSADJD),$L(PSADJD)=$L(+PSADJD),$P($G(^PSDRUG(+PSADJD,0)),"^")'="" W "*"_$P($G(^PSDRUG(+PSADJD,0)),"^") S (PSADRG,PSA50IEN)=+PSADJD Q + .I $G(PSADJD),$L(PSADJD)=$L(+PSADJD),$P($G(^PSDRUG(+PSADJD,0)),"^")="" S (PSADJ,PSADRG)=0 Q + .W ?7,"**"_PSADJD S PSADJSUP=1,(PSADRG,PSA50IEN)=PSADJD + I '$G(PSADJ) D + .S (PSA50IEN,PSADRG)=$S(+$P(PSADATA,"^",2)&($P($G(^PSDRUG(+$P(PSADATA,"^",2),0)),"^")'=""):+$P(PSADATA,"^",2),1:0) + .W $S(+$P(PSADATA,"^",2)&($P($G(^PSDRUG(+$P(PSADATA,"^",2),0)),"^")'=""):$P(^PSDRUG(+$P(PSADATA,"^",2),0),"^"),1:"DRUG UNKNOWN") + I PSADRG D + .I $P($G(^PSDRUG(PSADRG,2)),"^",3)["N" W " (Controlled Substance)" I $P($G(^PSD(58.8,+$P(PSAIN,"^",12),1,PSADRG,0)),"^",14),$P($G(^(0)),"^",14)'>DT W !,$C(7),$C(7),"** INACTIVE IN MASTER VAULT **" + .I $D(^PSDRUG(PSADRG,"I")) W !?5,"** INACTIVE IN DRUG FILE **" Q + .I $P($G(^PSD(58.8,+$P(PSAIN,"^",5),1,PSADRG,0)),"^",14),$P($G(^(0)),"^",14)'>DT W !,$C(7),$C(7),"** INACTIVE IN PHARMACY LOCATION **" +QTY W !,"Qty Invoiced: " + ;No Adj. Qty + S PSADJQ="",PSADJ=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","Q",0)) + I $G(PSADJ) S PSANODE=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0)),PSADJQ=$S($P(PSANODE,"^",6)'="":+$P(PSANODE,"^",6),1:$P(PSANODE,"^",2)) + ;Adj. Qty + I $G(PSADJQ) S PSAQTY=PSADJQ W PSAQTY_" ("_$S($P(PSADATA,"^",3):$P(PSADATA,"^",3),$P(PSADATA,"^",3)=0:0,1:"Blank")_")" + I '$G(PSADJQ) W $P(PSADATA,"^",3) S PSAQTY=$P(PSADATA,"^",3) +UPC S PSAUPC=$P(PSADATA,U,13) W:PSAUPC'="" ?38,"UPC: "_PSAUPC +OU W !,"Order Unit : " + S PSAOU=$S(+$P(PSADATA,"^",4)&($P($G(^DIC(51.5,+$P(PSADATA,"^",4),0)),"^")'=""):+$P(PSADATA,"^",4),1:"") + S PSATEMP=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2)) + I +$P(PSATEMP,"^",3),PSADRG,+$P($G(^PSDRUG(PSADRG,1,+$P(PSATEMP,"^",3),0)),"^",5) S PSAOU=+$P(^PSDRUG(PSADRG,1,+$P(PSATEMP,"^",3),0),"^",5) + S PSADJO="",PSADJ=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","O",0)) + I $G(PSADJ) S PSANODE=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0)),PSADJO=$S($P(PSANODE,"^",6)'="":$P(PSANODE,"^",6),1:$P(PSANODE,"^",2)) + ;Adj. Order Unit + I PSADJO'="" W $S(+PSADJO&($P($G(^DIC(51.5,+PSADJO,0)),"^")'=""):$P($G(^DIC(51.5,+PSADJO,0)),"^"),1:"UNKNOWN")_" ("_$S(PSAOU:$P($G(^DIC(51.5,+PSAOU,0)),"^"),1:"Blank")_")" S PSAOU=+PSADJO + I PSADJO="" W $S(+PSAOU:$P($G(^DIC(51.5,+PSAOU,0)),"^"),1:"Blank") + ; +NDC S PSANDC=$P(PSADATA,"^",11) + I $E(PSANDC)'="S" W ?38,"NDC: " D PSANDC1^PSAHELP W PSANDCX K PSANDCX + ; +PRICE W !,"Unit Price : $" + S PSADJP=0,PSADJ=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","P",0)) + I $G(PSADJ) S PSANODE=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0)),PSADJP=$S(+$P(PSANODE,"^",6):+$P(PSANODE,"^",6),1:+$P(PSANODE,"^",2)) + ;Adj. Unit Price + I $G(PSADJP) D + .I $L($P(PSADJP,".",2))<2 S PSADJP=$P(PSADJP,".")_"."_$P(PSADJP,".",2)_$E("00",1,(2-$L($P(PSADJP,".",2)))) + .W $FN(PSADJP,",")_" ($"_$S(+$P(PSADATA,"^",5):$FN($P(PSADATA,"^",5),","),$P(PSADATA,"^",5)=0:"0.00",1:"")_")" + .S PSAPRICE=PSADJP + I '$G(PSADJP) D + .S PSAPRICE=+$P(PSADATA,"^",5) + .I $G(PSAPRICE)!(PSAPRICE=0) W $S($G(PSAPRICE):PSAPRICE,1:"0.00") Q + .W "Blank" + ; +VSN S:$D(PSADATA) PSAVSN=$P(PSADATA,"^",12) ;*48 + W ?38,"VSN: "_$S(PSAVSN'="":PSAVSN,1:"Blank"),! + ;*54 display VSN XTMP Drug Description and DUOU |==> + N PSAFLDT S PSAFLDT="February 2006" + N XXX I PSAVSN'="" S XXX=$G(^XTMP("PSAVSN",PSAVSN)) D + . I $G(^XTMP("PSAVSN",0)) S PSAFLDT=$P(^XTMP("PSAVSN",0),"^",4) + . W !,"PV-Drug-Descrip: " + . I '$L(XXX) W "Not Available. Item is OTC or new after ",PSAFLDT,! Q + . W ?20,$P(XXX,"~",2),?55,"PV-DUOU: ",+XXX,! + ;*54 display VSN XTMP Drug Description and DUOU <==| +VDU S PSADUOU=+$P(PSATEMP,"^"),PSAREORD=+$P(PSATEMP,"^",2),PSASUB=+$P(PSATEMP,"^",3),PSASTOCK=+$P(PSATEMP,"^",4) + W !,"Dispense Units: "_$S($P($G(^PSDRUG(+PSADRG,660)),"^",8)'="":$P($G(^PSDRUG(+PSADRG,660)),"^",8),1:"Blank") +VDUOU W !,"Dispense Units Per Order Unit: "_$S(+PSADUOU:+PSADUOU,+PSASUB&(+$P($G(^PSDRUG(+PSADRG,1,PSASUB,0)),"^",7)):+$P($G(^PSDRUG(+PSADRG,1,PSASUB,0)),"^",7),1:"Blank"),! + ; + Q:'+$P($G(^PSD(58.8,+PSALOC,0)),"^",14) + ; +STOCK S PSASTOCK=$S(+PSASTOCK:+PSASTOCK,+$P($G(^PSD(58.8,+PSALOC,1,+PSADRG,0)),"^",3):+$P($G(^PSD(58.8,+PSALOC,1,+PSADRG,0)),"^",3),1:"Blank") + W "Stock Level : "_PSASTOCK +REORDER S PSAREORD=$S(+PSAREORD:+PSAREORD,+$P($G(^PSD(58.8,+PSALOC,1,+PSADRG,0)),"^",5):+$P($G(^PSD(58.8,+PSALOC,1,+PSADRG,0)),"^",5),1:"Blank") + W !,"Reorder Level : "_PSAREORD,! + Q diff --git a/r/DRUG_ACCOUNTABILITY-PSA/PSAVER7.m b/r/DRUG_ACCOUNTABILITY-PSA/PSAVER7.m index 5ef31763..386d7fa5 100644 --- a/r/DRUG_ACCOUNTABILITY-PSA/PSAVER7.m +++ b/r/DRUG_ACCOUNTABILITY-PSA/PSAVER7.m @@ -1,96 +1,93 @@ -PSAVER7 ;BIR/JMB-Verify Invoices - CONT'D ;7/23/97 - ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**12,21,42,56,64,66**; 10/24/97;Build 2 - ;Background Job - ;This routine increments pharmacy location and master vault balances - ;in 58.8 after invoices have been verified. This routine is called - ;by PSAVER6. - ; - ;References to ^PSDRUG( are covered by IA #2095 -TR ;File transaction data in 58.81 - I $D(PSADUREC),'PSADUREC Q ;*56 block '0' quantity edits - I $D(PSAQTY),'PSAQTY Q ;*56 block '0' quantity edits - F L +^PSD(58.81,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q -FIND S PSAT=$P(^PSD(58.81,0),"^",3)+1 I $D(^PSD(58.81,PSAT)) S $P(^PSD(58.81,0),"^",3)=$P(^PSD(58.81,0),"^",3)+1 G FIND - S DIC="^PSD(58.81,",DIC(0)="L",DLAYGO=58.81,(DINUM,X)=PSAT D ^DIC K DIC,DINUM,DLAYGO L -^PSD(58.81,0) - S DIE="^PSD(58.81,",DA=PSAT,DR="1////1;2////^S X=PSALOC;3////^S X=PSADT;4////^S X=PSADRG;5////^S X=PSADUREC;6////^S X=PSAVDUZ;9////^S X=PSABAL;71////^S X=PSAINV;106////^S X=PSAORD" - I $G(PSACS) S DR=DR_";100////^S X=PSACS" - F L +^PSD(58.81,DA,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q - D ^DIE L -^PSD(58.81,DA,0) K DIE - S:'$D(^PSD(58.8,PSALOC,1,PSADRG,4,0)) DIC("P")=$P(^DD(58.8001,19,0),"^",2) - S DA(2)=PSALOC,DA(1)=PSADRG,(X,DINUM)=PSAT,DIC="^PSD(58.8,"_DA(2)_",1,"_DA(1)_",4,",DIC(0)="L",DLAYGO=58.8 - F L +^PSD(58.8,PSALOC,1,PSADRG,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q - D ^DIC L -^PSD(58.8,PSALOC,1,PSADRG,0) K DIC,DINUM,DLAYGO - ; -50 S PSAODASH=$P($G(^PSDRUG(PSADRG,2)),"^",4) - S PSAONDC=$P(PSAODASH,"-")_$P(PSAODASH,"-",2)_$P(PSAODASH,"-",3) - ;(PSA*3*21) NDC & PRICING UPDATES (DAVE BLOCKER 10NOV99) - S PSADUOU=$S($G(PSADUOU)'>0:1,1:PSADUOU) - S PSADUREC=(PSAQTY*PSADUOU) - S DIE="^PSDRUG(",DA=PSADRG,DR="50////^S X="_(PSADUREC+$G(^PSDRUG(PSADRG,660.1))) - F L +^PSDRUG(DA,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q - D ^DIE L -^PSDRUG(DA,0) K DIE,DA,DR - ;This section replaces most of the routine - ;PSAOU = order unit from invoice - ;PSAPOU & PSANPOU = Price of Order Unit from invoice - ;PSADUOU=Dispense Units per OU form invoice data - ;PSANPDU= Price of Dispense Units per Order Unit - ; - ;Drug file Information - K DRUG - S PSANODE=$G(^PSDRUG(PSADRG,660)) - F X=2,3,5,6 S DRUG(X)=$P($G(PSANODE),"^",X) - ; - S PSANPDU=$J(($G(PSAPOU)/$G(PSADUOU)),0,3) ;Price of Order Unit divide by Disp. Units per Order Unit - ;PSA*3*42 |> (let changes happen and file, put changes into mail message) - S DIE="^PSDRUG(",(DA,OLDDA)=PSADRG,DR="12////^S X=PSAOU;15////^S X=PSADUOU;Q;13////^S X=PSAPOU" ;*42;*56 - F L +^PSDRUG(DA,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q - D ^DIE K DIE,DA,DR - ; <| PSA*42 -PTCH21 ;PSA*3*21 (Vendor's VSN changing to 8 digits, check also) - ;If NDC or VSN changes should it create to synonym entry ? - I $G(^PSDRUG(PSADRG,1,PSASUB,0))="" G NDC - I $G(^PSDRUG(PSADRG,1,PSASUB,0)) S PSAEDTT=0,DATA=^PSDRUG(PSADRG,1,PSASUB,0) D - .I PSAVSN'=$P(DATA,"^",4) S PSAEDTT=1 ;VSN - .I PSAPOU'=$P(DATA,"^",6) S PSAEDTT=1 ;Price per order unit - .I PSADUOU'=$P(DATA,"^",7) S PSAEDTT=1 ;Dispense Units per Order Unit - .I PSANPDU'=$P(DATA,"^",8) S PSAEDTT=1 ;New Price per dispense unit - .I $G(PSAEDTT)>0 D - ..S DA=PSASUB,DA(1)=PSADRG,DIE="^PSDRUG("_DA(1)_",1," - ..S DR="2////^S X=PSADASH"_$S(PSACS:";1////C",1:";1////D")_";400////^S X=PSAVSN;401////^S X=PSAOU"_$S(+PSAPOU:";402////^S X=PSAPOU",1:"")_";403////^S X=PSADUOU"_";404///^S X=PSANPDU"_";405///^S X=PSAVEND" - ..D ^DIE K DIE,DR,DA -NDC ;NDC UPDATE - I PSANDC'="",PSANDC'=PSAONDC D ;*42 - .S DIE="^PSDRUG(",DA=PSADRG,DR="31////^S X=PSADASH" - .F L +^PSDRUG(DA,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q - .D ^DIE L -^PSDRUG(DA,0) K DIE,DA,DR -SYNONYM ;Adds/edits the SYNONYM multiple in DRUG file >>*66 RJS - G:PSANDC="" END - S DA(1)=PSADRG ;; << *66 RJS - ; - S PSANPDU=$J(($G(PSAPOU)/$G(PSADUOU)),0,3) ;Price of Order Unit divide by Disp. Units per Order Unit - S:'$D(^PSDRUG(PSADRG,1,0)) DIC("P")="50.1A" - ; *56 Search for earliest best match of synonyms, start at bottom go up - ; if VSN use it, if several VSNs use the first, IF VSN match NDCs must match also. - ; if no VSN, make a new synonym - ; no "B" synonym index exists -T0 N PSYNDA,PSYN0,PSTNDC,PSTVSN,PSMNDC,PSMBTH S (PSMNDC,PSMBTH)=0 - S PSYNDA="" F S PSYNDA=$O(^PSDRUG(PSADRG,1,PSYNDA),-1) Q:PSYNDA'>0 D - . S PSYN0=^PSDRUG(PSADRG,1,PSYNDA,0),PSTNDC=$P(PSYN0,U),PSTVSN=$P(PSYN0,U,4) ;zero node, test values of NDC VSN - . I PSTNDC'=PSANDC Q - . I PSTVSN=PSAVSN S PSMBTH=PSYNDA Q ;both VSN & NDC matches -T1 S PSASUB=$S(PSMBTH:PSMBTH,1:0) ;PSAMBTH Match both vsn,ndc - ;end *56 - I 'PSASUB!(PSASUB&('$D(^PSDRUG(PSADRG,1,PSASUB,0)))) D - .S DIC="^PSDRUG("_DA(1)_",1,",DIC(0)="Z",X=PSANDC,DLAYGO=50 - .F L +^PSDRUG(PSADRG,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q - .D FILE^DICN L -^PSDRUG(PSADRG,0) K DIC,DLAYGO S PSASUB=+Y - .K DIC,DA,DR,DIE - I PSASUB,$D(^PSDRUG(PSADRG,1,PSASUB,0)) S DA=PSASUB - S DA(1)=PSADRG,DIE="^PSDRUG("_DA(1)_",1," - S DR="2////^S X=PSADASH"_$S($G(PSACS)>0:";1////C",1:";1////D")_";400////^S X=PSAVSN;401////^S X=PSAOU"_$S(+PSAPOU:";402////^S X=PSAPOU",1:"")_";403////^S X=PSADUOU"_";404///^S X=PSANPDU;405///^S X=PSAVEND" - F L +^PSDRUG(PSADRG,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q - D ^DIE L -^PSDRUG(PSADRG,0) - K DIE,DR,X1,X2,DATA -END ; FINAL CLEANUP << *66 RJS - L -^PSDRUG(OLDDA,0) K OLDDA ;; >> *66 RJS - Q +PSAVER7 ;BIR/JMB-Verify Invoices - CONT'D ;7/23/97 + ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**12,21,42,56,64**; 10/24/97;Build 4 + ;Background Job + ;This routine increments pharmacy location and master vault balances + ;in 58.8 after invoices have been verified. This routine is called + ;by PSAVER6. + ; + ;References to ^PSDRUG( are covered by IA #2095 +TR ;File transaction data in 58.81 + I $D(PSADUREC),'PSADUREC Q ;*56 block '0' quantity edits + I $D(PSAQTY),'PSAQTY Q ;*56 block '0' quantity edits + F L +^PSD(58.81,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q +FIND S PSAT=$P(^PSD(58.81,0),"^",3)+1 I $D(^PSD(58.81,PSAT)) S $P(^PSD(58.81,0),"^",3)=$P(^PSD(58.81,0),"^",3)+1 G FIND + S DIC="^PSD(58.81,",DIC(0)="L",DLAYGO=58.81,(DINUM,X)=PSAT D ^DIC K DIC,DINUM,DLAYGO L -^PSD(58.81,0) + S DIE="^PSD(58.81,",DA=PSAT,DR="1////1;2////^S X=PSALOC;3////^S X=PSADT;4////^S X=PSADRG;5////^S X=PSADUREC;6////^S X=PSAVDUZ;9////^S X=PSABAL;71////^S X=PSAINV;106////^S X=PSAORD" + I $G(PSACS) S DR=DR_";100////^S X=PSACS" + F L +^PSD(58.81,DA,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q + D ^DIE L -^PSD(58.81,DA,0) K DIE + S:'$D(^PSD(58.8,PSALOC,1,PSADRG,4,0)) DIC("P")=$P(^DD(58.8001,19,0),"^",2) + S DA(2)=PSALOC,DA(1)=PSADRG,(X,DINUM)=PSAT,DIC="^PSD(58.8,"_DA(2)_",1,"_DA(1)_",4,",DIC(0)="L",DLAYGO=58.8 + F L +^PSD(58.8,PSALOC,1,PSADRG,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q + D ^DIC L -^PSD(58.8,PSALOC,1,PSADRG,0) K DIC,DINUM,DLAYGO + ; +50 S PSAODASH=$P($G(^PSDRUG(PSADRG,2)),"^",4) + S PSAONDC=$P(PSAODASH,"-")_$P(PSAODASH,"-",2)_$P(PSAODASH,"-",3) + ;(PSA*3*21) NDC & PRICING UPDATES (DAVE BLOCKER 10NOV99) + S PSADUOU=$S($G(PSADUOU)'>0:1,1:PSADUOU) + S PSADUREC=(PSAQTY*PSADUOU) + S DIE="^PSDRUG(",DA=PSADRG,DR="50////^S X="_(PSADUREC+$G(^PSDRUG(PSADRG,660.1))) + F L +^PSDRUG(DA,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q + D ^DIE L -^PSDRUG(DA,0) K DIE,DA,DR + ;This section replaces most of the routine + ;PSAOU = order unit from invoice + ;PSAPOU & PSANPOU = Price of Order Unit from invoice + ;PSADUOU=Dispense Units per OU form invoice data + ;PSANPDU= Price of Dispense Units per Order Unit + ; + ;Drug file Information + K DRUG + S PSANODE=$G(^PSDRUG(PSADRG,660)) + F X=2,3,5,6 S DRUG(X)=$P($G(PSANODE),"^",X) + ; + S PSANPDU=$J(($G(PSAPOU)/$G(PSADUOU)),0,3) ;Price of Order Unit divide by Disp. Units per Order Unit + ;PSA*3*42 |> (let changes happen and file, put changes into mail message) + S DIE="^PSDRUG(",DA=PSADRG,DR="12////^S X=PSAOU;15////^S X=PSADUOU;Q;13////^S X=PSAPOU" ;*42;*56 + F L +^PSDRUG(DA,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q + D ^DIE K DIE,DA,DR + ; <| PSA*42 +PTCH21 ;PSA*3*21 (Vendor's VSN changing to 8 digits, check also) + ;If NDC or VSN changes should it create to synonym entry ? + I $G(^PSDRUG(PSADRG,1,PSASUB,0))="" G NDC + I $G(^PSDRUG(PSADRG,1,PSASUB,0)) S PSAEDTT=0,DATA=^PSDRUG(PSADRG,1,PSASUB,0) D + .I PSAVSN'=$P(DATA,"^",4) S PSAEDTT=1 ;VSN + .I PSAPOU'=$P(DATA,"^",6) S PSAEDTT=1 ;Price per order unit + .I PSADUOU'=$P(DATA,"^",7) S PSAEDTT=1 ;Dispense Units per Order Unit + .I PSANPDU'=$P(DATA,"^",8) S PSAEDTT=1 ;New Price per dispense unit + .I $G(PSAEDTT)>0 D + ..S DA=PSASUB,DA(1)=PSADRG,DIE="^PSDRUG("_DA(1)_",1," + ..S DR="2////^S X=PSADASH"_$S(PSACS:";1////C",1:";1////D")_";400////^S X=PSAVSN;401////^S X=PSAOU"_$S(+PSAPOU:";402////^S X=PSAPOU",1:"")_";403////^S X=PSADUOU"_";404///^S X=PSANPDU"_";405///^S X=PSAVEND" + ..D ^DIE K DIE,DR,DA +NDC ;NDC UPDATE + I PSANDC'="",PSANDC'=PSAONDC D ;*42 + .S DIE="^PSDRUG(",DA=PSADRG,DR="31////^S X=PSADASH" + .F L +^PSDRUG(DA,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q + .D ^DIE L -^PSDRUG(DA,0) K DIE,DA,DR +SYNONYM ;Adds/edits the SYNONYM multiple in DRUG file + Q:PSANDC="" K DA,DR S DA(1)=PSADRG + ; + S PSANPDU=$J(($G(PSAPOU)/$G(PSADUOU)),0,3) ;Price of Order Unit divide by Disp. Units per Order Unit + S:'$D(^PSDRUG(PSADRG,1,0)) DIC("P")="50.1A" + ; *56 Search for earliest best match of synonyms, start at bottom go up + ; if VSN use it, if several VSNs use the first, IF VSN match NDCs must match also. + ; if no VSN, make a new synonym + ; no "B" synonym index exists +T0 N PSYNDA,PSYN0,PSTNDC,PSTVSN,PSMNDC,PSMBTH S (PSMNDC,PSMBTH)=0 + S PSYNDA="" F S PSYNDA=$O(^PSDRUG(PSADRG,1,PSYNDA),-1) Q:PSYNDA'>0 D + . S PSYN0=^PSDRUG(PSADRG,1,PSYNDA,0),PSTNDC=$P(PSYN0,U),PSTVSN=$P(PSYN0,U,4) ;zero node, test values of NDC VSN + . I PSTNDC'=PSANDC Q + . I PSTVSN=PSAVSN S PSMBTH=PSYNDA Q ;both VSN & NDC matches +T1 S PSASUB=$S(PSMBTH:PSMBTH,1:0) ;PSAMBTH Match both vsn,ndc + ;end *56 + I 'PSASUB!(PSASUB&('$D(^PSDRUG(PSADRG,1,PSASUB,0)))) D + .S DIC="^PSDRUG("_DA(1)_",1,",DIC(0)="Z",X=PSANDC,DLAYGO=50 + .F L +^PSDRUG(PSADRG,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q + .D FILE^DICN L -^PSDRUG(PSADRG,0) K DIC,DLAYGO S PSASUB=+Y + .K DIC,DA,DR,DIE + I PSASUB,$D(^PSDRUG(PSADRG,1,PSASUB,0)) S DA=PSASUB + S DA(1)=PSADRG,DIE="^PSDRUG("_DA(1)_",1," + S DR="2////^S X=PSADASH"_$S($G(PSACS)>0:";1////C",1:";1////D")_";400////^S X=PSAVSN;401////^S X=PSAOU"_$S(+PSAPOU:";402////^S X=PSAPOU",1:"")_";403////^S X=PSADUOU"_";404///^S X=PSANPDU;405///^S X=PSAVEND" + F L +^PSDRUG(PSADRG,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q + D ^DIE L -^PSDRUG(PSADRG,0) + K DIE,DR,X1,X2,DATA + Q diff --git a/r/DRUG_ACCOUNTABILITY-PSA/PSAVERA.m b/r/DRUG_ACCOUNTABILITY-PSA/PSAVERA.m index 0e4d9300..87fd5abf 100644 --- a/r/DRUG_ACCOUNTABILITY-PSA/PSAVERA.m +++ b/r/DRUG_ACCOUNTABILITY-PSA/PSAVERA.m @@ -1,87 +1,139 @@ -PSAVERA ;BHM/DBM - Change verified invoice data;16AUG05 - ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**21,36,40,53,63**; 10/24/97;Build 10 - ; - ;References to ^DIC(51.5 are covered by IA #1931 - ;References to ^PSDRUG( are covered by IA #2095 - D Q - D HOME^%ZIS S XX="VERIFIED INVOICE ALTERATION SCREEN" W @IOF,!!,?((IOM/2)-($L(XX)/2)),XX,!! -ORDR ;Get Order Number - S DIC(0)="AEQMZ",DIC("A")="Select Order Number: ",DIC="^PSD(58.811," D ^DIC K DIC G Q:+Y'>0 S PSAIEN=+Y,PSAORD=$P(Y,U,2) - ; -INV ;Get Invoice Number - S DIC(0)="AEQMZ",DIC("A")="Select Invoice Number: ",DIC="^PSD(58.811,"_PSAIEN_",1,",D="ASTAT" D ^DIC K DIC G Q:+Y'>0 S PSAIEN1=+Y,PSAINV=$P(Y,U,2) - S DATA=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,0)) - S PSALOC=$S($P(DATA,"^",12)'="":$P(DATA,"^",12),1:$P(DATA,"^",5)) I $G(PSALOC)="" S PSALOC="No Location identified" - D ^PSAVERA1 - K DATA,PSAITM,LINENUM,X,X1,X2,X3,DIC,DA,DR D HDR -DISP S PSAITM=$S('$D(PSAITM):$O(INVARRAY(PSAORD,PSAINV,0)),1:$O(INVARRAY(PSAORD,PSAINV,PSAITM))) G LINEASK:PSAITM'>0 S LINENUM=$G(LINENUM)+1 - S DATA=$G(INVARRAY(PSAORD,PSAINV,PSAITM)),PSAOU=$P(DATA,"^",4) I $G(PSAOU) S PSAOU(1)=$P($G(^DIC(51.5,$P(DATA,"^",4),0)),"^") ;Current Order Unit ;; <*63 RJS - W !,PSAITM,?10,$S($P($P(DATA,"^",1),"~",1)'>0:$P($P(DATA,"^",1),"~",1),1:$P($P(DATA,"^",1),"~",2)),?45,$S($G(PSAOU)="":"none",$G(PSAOU(1))'="":$G(PSAOU(1)),1:$G(PSAAOU)),?55,$J($P($G(DATA),"^",2),4),?61,$P(DATA,"^",5) ;; *63 RJS> - I IOST["C-",$Y>(IOSL-5) S DIR(0)="E" D ^DIR G Q:$G(DUOUT)=1 D HDR - G DISP -LINEASK ;ask for line number - W !,"Enter the corresponding item number to edit: " R AN:DTIME I AN["^"!(AN="") G Q - I AN<1!(AN>LINENUM) W !,"Enter a number between 1 & ",LINENUM,! G LINEASK - I "?"[AN W !,"Select the number that corresponds to the line item that needs editing",! K AN G LINEASK - S DATA=$G(INVARRAY(PSAORD,PSAINV,AN)) - S PSALINE=AN,PSAIN="NADA" I '$D(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,0)) W !,"Invalid line selection." G LINEASK - S PSADATA=^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,0),PSASUP=0 - S PSACS=0 S:+$P(PSADATA,"^",10) PSACS=$G(PSACS)+1 - S PSANDC=$P(PSADATA,"^",11) - S PSALINEN="" D VERDISP^PSAUTL4 W !,PSASLN,! - S PSAVEND=$P(^PSD(58.811,PSAIEN,0),"^",2) - S PSAODUOU=PSADUOU - ;; *63 - S PSA581="" F S PSA581=$O(^PSD(58.81,"PV",PSAINV,PSA581)) Q:'PSA581 I $P(^PSD(58.81,PSA581,0),U,5)=PSADRG S PSABFR(581)=$G(^PSD(58.81,PSA581,0)) - S:$G(PSABFR(581)) PSDTRN=$P(PSABFR(581),U,1),PSABFR("Q")=$S($G(^PSD(58.81,PSDTRN,4)):$P(^PSD(58.81,PSDTRN,4),"^",3),1:$P(^PSD(58.81,PSDTRN,0),"^",6)) ; <*63 RJS > -DRG W !,"Select (D)rug or (O)rder Unit " R AN:DTIME G Q:AN["^"!(AN="") W $S("Dd"[AN:"rug","oO"[AN:"rder Unit",1:"??") I "DdOo"'[AN W !,"Enter a 'D' to edit the Drug, or 'O' to edit the order unit",! K AN G DRG - I "Dd"'[AN D ^PSAVERA3 G Q ;;*63 - ;Get either new name of drug or supply item description - S PSABFR=$P(DATA,"~",1),PSABFR(1)=$S(PSABFR'?.N:PSABFR,1:$P($P(DATA,"^"),"~",2)),PSABFR("NDC")=$P(PSADATA,"^",11) ;;*63 -DRGAGN D - .S X1=0 F S X1=$O(^PSDRUG(PSABFR,1,X1)) Q:X1'>0 S DATA=$G(^PSDRUG(PSABFR,1,X1,0)) I $P(DATA,"^",2)=PSABFR("NDC") S PSABFR("SYNNODE")=X1 ;;*63 - D PSANDC1^PSAHELP S PSADASH=PSANDCX K PSANDCX - I $G(PSABFR("SYNNODE"))="",$E(PSABFR("NDC"))'="S" S PSABFR("NDC")="S"_PSABFR("NDC") G DRGAGN ;may be supply, try again - I $G(PSABFR("SYNNODE"))'="" S PSASUB=PSABFR("SYNNODE") D - .S DATA=$G(^PSDRUG(PSABFR,1,PSASUB,0)),PSAOU=$P(DATA,"^",5),PSAPOU=$P(DATA,"^",6),PSADUOU=$P(DATA,"^",7),PSAPDUOU=$P(DATA,"^",8) - .S PSADU=$P($G(^PSDRUG(PSABFR,660)),"^",8) - I ($G(PSAOU)=""!$G(PSAPOU)=""!$G(PSADUOU)=""!$G(PSAPDUOU)="") W !!,"Sorry, I could not find the necessary information to change the drug selection.",! G Q - W !,"Current Drug : ",PSABFR(1) -DRG1 S PSAGAIN=0,DIC("A")="Select name of Correct Drug: ",PSABFR=PSADRG,DIC(0)="AEQMZ",DIC="^PSDRUG(" D ^DIC K DIC G Q:PSAOUT - I $G(DTOUT)!($G(DUOT))!(Y<0) S PSAOUT=1 Q - S (PSADJ,PSADRG)=+Y - W !!,"Comparing drug file data..." - S PSAODU=$P($G(^PSDRUG(PSADRG,660)),"^",8),PSAXDUOU=$P($G(^PSDRUG(PSADRG,660)),"^",5) - I $P($G(^PSDRUG(PSADRG,660)),"^",2)'=$G(PSAOU) W !,"The Order Units are different between these two drugs." - I $P($G(^PSDRUG(PSADRG,660)),"^",8)'=$G(PSADU) W !,"Please Enter an appropriate Dispense Unit" S DIE="^PSDRUG(",DA=PSADRG,DR="14.5" D ^DIE S PSADU=$P(^PSDRUG(PSADRG,660),"^",8) - I $P($G(^PSDRUG(PSADRG,660)),"^",5)'=$G(PSADUOU) W !,"Please enter the appropriate Dispense Units per order unit" S DIE="^PSDRUG(",DA=PSADRG,DR="15" D ^DIE S PSADUOU=$P(^PSDRUG(PSADRG,660),"^",5) - K DIE,DA,DR -ASK R !!,"Are you sure about this ? NO// ",AN:DTIME G NOCHNG:AN["^"!(AN="") - S AN=$E(AN) I "yYnN"'[AN W !,"Answer yes, and the data on file for the current drug will be transferred",!,"to the new drug selection.",!,"That includes Order Unit, Dispense Unit, Dispense Units per Order Unit, etc.",!! G ASK - I "Nn"[AN G NOCHNG ;*53 - S PSAAFTER=PSADRG,PSADRG=PSABFR - I $D(^PSDRUG(PSADRG))&$G(PSABFR(581)) D - .W !,"Removing "_PSABFR("Q")_" from "_PSABFR(1) - .S FMDATA=$P($G(^PSDRUG(PSADRG,660.1)),"^")-PSABFR("Q"),DIE="^PSDRUG(",DA=PSADRG,DR="50////^S X="_FMDATA - .F L +^PSDRUG(DA,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q - .D ^DIE L -^PSDRUG(DA,0) K FMDATA - S PSADRG=PSAAFTER - I $G(PSAPOU)="",$G(PSAPRICE)'="" S PSAPOU=PSAPRICE - W !,"Adding "_($G(PSAQTY)*$G(PSADUOU))_" to "_$P($G(^PSDRUG(PSADRG,0)),"^") - W !,"Entering new drug selection as an adjustment." - S PSAREA="",PSADJFLD="D",PSADJ=PSADRG D RECORD^PSAVER2,50^PSAVER7 -FILE ;File dispense units per order units into 58.811 - S DIE="^PSD(58.811,"_PSAIEN_",1,"_PSAIEN1_",1,",DA=PSALINE,DA(1)=PSAIEN1,DA(2)=PSAIEN,DR="10///"_PSADUOU D ^DIE - G:$D(^PSD(58.811,"ASTAT","P",PSAIEN,PSAIEN1)) Q ;; *63 RJS - D UPDATE^PSAVERA1 G Q - ; -HDR W @IOF,!?25,"EDIT VERIFIED INVOICED ITEM SCREEN",!,PSASLN,! - W !,?44,"Order",!,"#",?10,"Drug/Item Name",?45,"Unit",?56,"Qnty.",?67,"NDC",!,PSASLN,! Q -Q K AN,D,DA,DATA,DIC,DIR,INVARRAY,LINENUM,POP,PSA50IEN,PSA581,PSAABAL,PSAAFTER,PSAAQTY,PSABAL,PSABFR,PSACS,PSADASH,PSADATA,PSADJ,PSADJD,PSADJFLD,PSADJO,PSADJP,PSADJQ,PSADRG,PSADRUGN,PSADT - K PSADU,PSADUOU,PSADUREC,PSAEDTT,PSAGAIN,PSAIEN,PSAIEN1,PSAIN,PSAINV,PSAITM,PSALINE,PSALINEN,PSALOC,PSANDC,PSANDUOU,PSANEW,PSANODE,PSANPDU,PSANQTY,PSAODASH,PSAODU,PSAODUOU,PSAONDC,PSAORD - K PSAOU,PSAOUT,PSAPOU,PSAPRICE,PSAQTY,PSAREA,PSAREORD,PSASET,PSASLN,PSASTOCK,PSASUB,PSASUP,PSASUPP,PSAT,PSATEMP,PSAUPC,PSAVDUZ,PSAVEND,PSAVER,PSAVSN,PSAXDUOU,PSDTRN,X,X1,X2,X3,XX,XXX,Y - Q -NOCHNG ;*53 said no to changes, backout the edits on the new drug choice. - K DIE,DR,DA - S DIE="^PSDRUG(",DA=PSADRG,DR="14.5////^S X=PSAODU;15////^S X=PSAXDUOU" D ^DIE - W !,"NO CHANGE",! G Q +PSAVERA ;BHM/DBM - Change verified invoice data;16AUG05 + ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**21,36,40,53**; 10/24/97 + ; + ;References to ^DIC(51.5 are covered by IA #1931 + ;References to ^PSDRUG( are covered by IA #2095 + D Q + D HOME^%ZIS S XX="VERIFIED INVOICE ALTERATION SCREEN" W @IOF,!!,?((IOM/2)-($L(XX)/2)),XX,!! +ORDR ;Get Order Number + S DIC(0)="AEQMZ",DIC("A")="Select Order Number: ",DIC="^PSD(58.811," D ^DIC K DIC G Q:+Y'>0 S PSAIEN=+Y,PSAORD=$P(Y,U,2) + ; +INV ;Get Invoice Number + S DIC(0)="AEQMZ",DIC("A")="Select Invoice Number: ",DIC="^PSD(58.811,"_PSAIEN_",1,",D="ASTAT" D ^DIC K DIC G Q:+Y'>0 S PSAIEN1=+Y,PSAINV=$P(Y,U,2) + ; + S DATA=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,0)) + S PSALOC=$S($P(DATA,"^",12)'="":$P(DATA,"^",12),1:$P(DATA,"^",5)) I $G(PSALOC)="" S PSALOC="No Location identified" + D ^PSAVERA1 + ; + K DATA,PSAITM,LINENUM,X,X1,X2,X3,DIC,DA,DR D HDR +DISP S PSAITM=$S('$D(PSAITM):$O(INVARRAY(PSAORD,PSAINV,0)),1:$O(INVARRAY(PSAORD,PSAINV,PSAITM))) G LINEASK:PSAITM'>0 S LINENUM=$G(LINENUM)+1 + S DATA=$G(INVARRAY(PSAORD,PSAINV,PSAITM)) + S PSAOU=$P(DATA,"^",4) I $G(PSAOU) S PSAOU(1)=$P($G(^DIC(51.5,$P(DATA,"^",4),0)),"^") ;Current Order Unit + W !,PSAITM,?10,$S($P($P(DATA,"^",1),"~",1)'>0:$P($P(DATA,"^",1),"~",1),1:$P($P(DATA,"^",1),"~",2)),?45,$S($G(PSAOU)="":"none",$G(PSAOU(1))'="":$G(PSAOU(1)),1:$G(PSAAOU)),?55,$J($P($G(DATA),"^",2),4),?61,$P(DATA,"^",5) + I IOST["C-",$Y>(IOSL-5) S DIR(0)="E" D ^DIR G Q:$G(DUOUT)=1 D HDR + G DISP +LINEASK ;ask for line number + W !,"Enter the corresponding item number to edit: " R AN:DTIME I AN["^"!(AN="") G Q + I AN<1!(AN>LINENUM) W !,"Enter a number between 1 & ",LINENUM,! G LINEASK + I "?"[AN W !,"Select the number that corresponds to the line item that needs editing",! K AN G LINEASK + S DATA=$G(INVARRAY(PSAORD,PSAINV,AN)) + S PSALINE=AN,PSAIN="NADA" I '$D(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,0)) W !,"Invalid line selection." G LINEASK + S PSADATA=^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,0),PSASUP=0 + S PSACS=0 S:+$P(PSADATA,"^",10) PSACS=$G(PSACS)+1 + S PSANDC=$P(PSADATA,"^",11) + S PSALINEN="" D VERDISP^PSAUTL4 W !,PSASLN,! + S PSAVEND=$P(^PSD(58.811,PSAIEN,0),"^",2) + ;VMP OIFO BAY PINES;VGF;PSA*3.0*40;GET ORIGINAL DISPENSE UNITS PER ORDER UNIT FOR SUBTRACTION + S PSAODUOU=PSADUOU + ; +DRG W !,"Select (D)rug or (O)rder Unit " R AN:DTIME G Q:AN["^"!(AN="") W $S("Dd"[AN:"rug","oO"[AN:"rder Unit",1:"??") I "DdOo"'[AN W !,"Enter a 'D' to edit the Drug, or 'O' to edit the order unit",! K AN G DRG + I "Dd"'[AN G ^PSAVERA3 + ;Get either new name of drug or supply item description + S PSABEFOR=$P(DATA,"~",1),PSABEFOR(1)=$S(PSABEFOR'?.N:PSABEFOR,1:$P($P(DATA,"^"),"~",2)) + S PSABEFOR("NDC")=$P(PSADATA,"^",11) +DRGAGN D + .S X1=0 F S X1=$O(^PSDRUG(PSABEFOR,1,X1)) Q:X1'>0 S DATA=$G(^PSDRUG(PSABEFOR,1,X1,0)) I $P(DATA,"^",2)=PSABEFOR("NDC") S PSABEFOR("SYNNODE")=X1 + D PSANDC1^PSAHELP S PSADASH=PSANDCX K PSANDCX + I $G(PSABEFOR("SYNNODE"))="",$E(PSABEFOR("NDC"))'="S" S PSABEFOR("NDC")="S"_PSABEFOR("NDC") G DRGAGN ;may be supply, try again + I $G(PSABEFOR("SYNNODE"))'="" S PSASUB=PSABEFOR("SYNNODE") D + .S DATA=$G(^PSDRUG(PSABEFOR,1,PSASUB,0)),PSAOU=$P(DATA,"^",5),PSAPOU=$P(DATA,"^",6),PSADUOU=$P(DATA,"^",7),PSAPDUOU=$P(DATA,"^",8) + .S PSADU=$P($G(^PSDRUG(PSABEFOR,660)),"^",8) + I ($G(PSAOU)=""!$G(PSAPOU)=""!$G(PSADUOU)=""!$G(PSAPDUOU)="") W !!,"Sorry, I could not find the necessary information to change the drug selection.",! G Q + W !,"Current Drug : ",PSABEFOR(1) +DRG1 S PSAGAIN=0,DIC("A")="Select name of Correct Drug: ",PSABEFOR=PSADRG,DIC(0)="AEQMZ",DIC="^PSDRUG(" D ^DIC K DIC G Q:PSAOUT + I $G(DTOUT)!($G(DUOT)) S PSAOUT=1 Q + S (PSADJ,PSADRG)=+Y + W !!,"Comparing drug file data..." + S PSAODU=$P($G(^PSDRUG(PSADRG,660)),"^",8),PSAXDUOU=$P($G(^PSDRUG(PSADRG,660)),"^",5) + I $P($G(^PSDRUG(PSADRG,660)),"^",2)'=$G(PSAOU) W !,"The Order Units are different between these two drugs." + I $P($G(^PSDRUG(PSADRG,660)),"^",8)'=$G(PSADU) W !,"Please Enter an appropriate Dispense Unit" S DIE="^PSDRUG(",DA=PSADRG,DR="14.5" D ^DIE S PSADU=$P(^PSDRUG(PSADRG,660),"^",8) + ;VMP OIFO BAY PINES;VGF;PSA*3.0*36 + I $P($G(^PSDRUG(PSADRG,660)),"^",5)'=$G(PSADUOU) W !,"Please enter the appropriate Dispense Units per order unit" S DIE="^PSDRUG(",DA=PSADRG,DR="15" D ^DIE S PSADUOU=$P(^PSDRUG(PSADRG,660),"^",5) + K DIE,DA,DR +ASK R !!,"Are you sure about this ? NO// ",AN:DTIME G NOCHNG:AN["^"!(AN="") + S AN=$E(AN) I "yYnN"'[AN W !,"Answer yes, and the data on file for the current drug will be transferred",!,"to the new drug selection.",!,"That includes Order Unit, Dispense Unit, Dispense Units per Order Unit, etc.",!! G ASK + I "Nn"[AN G NOCHNG ;*53 + ;VMP OIFO BAY PINES;VGF;PSA*3.0*36 + S PSAAFTER=PSADRG,PSADRG=PSABEFOR + I $D(^PSDRUG(PSADRG)) D + .;VMP OIFO BAY PINES;VGF;PSA*3.0*40 + .W !,"Removing "_($G(PSAQTY)*$G(PSAODUOU))_" from "_PSABEFOR(1) + .S FMDATA=$P($G(^PSDRUG(PSADRG,660.1)),"^")-(PSAODUOU*PSAQTY) + .S DIE="^PSDRUG(",DA=PSADRG,DR="50////^S X="_FMDATA + .F L +^PSDRUG(DA,0):0 I Q + .D ^DIE + .L -^PSDRUG(DA,0) + .K FMDATA + S PSADRG=PSAAFTER + I $G(PSAPOU)="",$G(PSAPRICE)'="" S PSAPOU=PSAPRICE + W !,"Adding "_($G(PSAQTY)*$G(PSADUOU))_" to "_$P($G(^PSDRUG(PSADRG,0)),"^") + W !,"Entering new drug selection as an adjustment." + S PSAREA="",PSADJFLD="D",PSADJ=PSADRG D RECORD^PSAVER2 + D 50^PSAVER7 +FILE ;File dispense units per order units into 58.811 + S DIE="^PSD(58.811,"_PSAIEN_",1,"_PSAIEN1_",1," + S DA=PSALINE,DA(1)=PSAIEN1,DA(2)=PSAIEN + S DR="10///"_PSADUOU + D ^DIE + ;File data in 58.8 + ;PSALOC= Either PSALOC or PSALOCB + ;VMP OIFO BAY PINES;VGF;PSA*3.0*40;UPDATE + S PSADRG=PSABEFOR + F L +^PSD(58.8,PSALOC,1,PSADRG,0):0 I Q + S PSADUREC=PSAQTY*$G(PSAODUOU) + S PSABAL=$P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",4) + S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",4)=PSABAL-PSADUREC + L -^PSD(58.8,PSALOC,1,PSADRG,0) + ;VMP OIFO BAY PINES;VGF;PSA*3.0*40;ADDED *$G(PSADUOU) + S PSADRG=PSAAFTER + S PSADUREC=PSAQTY*$G(PSADUOU) + D NOW^%DTC S PSADT=+$E(%,1,14) + I '$D(^PSD(58.8,PSALOC,1,PSADRG,0)) D + .S:'$D(^PSD(58.8,PSALOC,1,0)) DIC("P")=$P(^DD(58.8,10,0),"^",2) + .S DA(1)=PSALOC,DIC="^PSD(58.8,"_DA(1)_",1,",(DA,DINUM,X)=PSADRG,DIC(0)="L",DLAYGO=58.8 ;*53 + .F L +^PSD(58.8,PSALOC,0):0 I Q + .D FILE^DICN L -^PSD(58.8,PSALOC,0) K DIC,DA,DLAYGO + F L +^PSD(58.8,PSALOC,1,PSADRG,0):0 I Q + S PSABAL=$P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",4) + I $P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",1)'=PSADRG S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",1)=PSADRG + S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",4)=PSADUREC+PSABAL + I +$P($G(^PSD(58.8,PSALOC,0)),"^",14) D + .I PSASTOCK'=$P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",3) S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",3)=PSASTOCK + .I PSAREORD'=$P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",5) S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",5)=PSAREORD + S:'$D(^PSD(58.8,PSALOC,1,PSADRG,5,0)) DIC("P")=$P(^DD(58.8001,20,0),"^",2) + I '$D(^PSD(58.8,PSALOC,1,PSADRG,5,$E(DT,1,5)*100,0)) D + .S DIC="^PSD(58.8,"_PSALOC_",1,"_PSADRG_",5,",DIC(0)="L",DIC("DR")="1////^S X=$G(PSABAL)",(X,DINUM)=$E(DT,1,5)*100,DA(2)=PSALOC,DA(1)=PSADRG,DLAYGO=58.8 D ^DIC K DIC + .S X="T-1M" D ^%DT S DIC="^PSD(58.8,"_PSALOC_",1,"_PSADRG_",5,",DIC(0)="L",(X,DINUM)=$E(Y,1,5)*100 D ^DIC K DIC,DLAYGO S DA=+Y + .S DA(2)=PSALOC,DA(1)=PSADRG,DIE="^PSD(58.8,"_DA(2)_",1,"_DA(1)_",5,",DR="3////^S X=$G(PSABAL)" D ^DIE K DIE + S DA(2)=PSALOC,DA(1)=PSADRG,DIE="^PSD(58.8,"_DA(2)_",1,"_DA(1)_",5,",DA=$E(DT,1,5)*100,DR="5////^S X="_($P($G(^(0)),"^",3)+PSADUREC) D ^DIE K DIE + L -^PSD(58.8,PSALOC,1,PSADRG,0) + W !,"updating pharmacy location file." +FILE581 ;Update transaction file + S PSAVDUZ=DUZ +FIND S PSAT=$P(^PSD(58.81,0),"^",3)+1 I $D(^PSD(58.81,PSAT)) S $P(^PSD(58.81,0),"^",3)=$P(^PSD(58.81,0),"^",3)+1 G FIND + S DIC="^PSD(58.81,",DIC(0)="L",DLAYGO=58.81,(DINUM,X)=PSAT D ^DIC K DIC,DINUM,DLAYGO L -^PSD(58.81,0) + S DIE="^PSD(58.81,",DA=PSAT,DR="1////1;2////^S X=PSALOC;3////^S X=PSADT;4////^S X=PSADRG;5////^S X=PSADUREC;6////^S X=PSAVDUZ;9////^S X=PSABAL;71////^S X=PSAINV;106////^S X=PSAORD" + I $G(PSACS)>0 S DR=DR_";100////^S X=PSACS" + F L +^PSD(58.81,DA,0):0 I Q + D ^DIE L -^PSD(58.81,DA,0) K DIE W !,"updating transaction file." Q + ; +HDR W @IOF,!?25,"EDIT VERIFIED INVOICED ITEM SCREEN",!,PSASLN,! + W !,?44,"Order",!,"#",?10,"Drug/Item Name",?45,"Unit",?56,"Qnty.",?67,"NDC",!,PSASLN,! Q +Q K AN,D,DA,DATA,DIC,DIR,INVARRAY,LINENUM,PSA50IEN,PSABAL,PSABEFOR,PSACS,PSADATA,PSADJ,PSADJFLD,PSADRG,PSADT,PSADUREC,PSAGAIN,PSAIEN,PSAIEN1,PSAIN,PSAINV,PSALINE,PSALINEN + K PSALOC,PSANDC,PSAORD,PSAOUT,PSAQTY,PSAREA,PSAREORD,PSASLN,PSASTOCK,PSASUB,PSASUP,PSASUPP,PSAT,PSAVER,X,X1,X2,X3,XX,XXX,Y,PSAODUOU + K PSAODU,PSAODUOU,PSAXDUOU + Q +NOCHNG ;*53 said no to changes, backout the edits on the new drug choice. + K DIE,DR,DA + S DIE="^PSDRUG(",DA=PSADRG,DR="14.5////^S X=PSAODU;15////^S X=PSAXDUOU" D ^DIE + W !,"NO CHANGE",! G Q diff --git a/r/DRUG_ACCOUNTABILITY-PSA/PSAVERA1.m b/r/DRUG_ACCOUNTABILITY-PSA/PSAVERA1.m index a72d6b4e..6dda2904 100644 --- a/r/DRUG_ACCOUNTABILITY-PSA/PSAVERA1.m +++ b/r/DRUG_ACCOUNTABILITY-PSA/PSAVERA1.m @@ -1,136 +1,82 @@ -PSAVERA1 ;BHM/DB - Edit previously verified invoices;16NOV99 - ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**21,61,63**; 10/24/97;Build 10 - ;References to ^DIC(51.5 are covered by IA #1931 - ;References to ^PSDRUG( are covered by IA #2095 - ; - S $P(PSASLN,"=",79)="" K PSALINE -DISPLN S PSALINE=$S('$D(PSALINE):$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,0)),1:$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE))) G Q:PSALINE'>0 S CNT=$G(CNT)+1 - S PSADATA=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,0)) - S PSATEMP=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2)) - S PSAVSN=$P(PSADATA,"^",12),PSAOUT=0 -DRUG S PSADJ=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","D",0)) - I $G(PSADJ) D - .S PSANODE=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0)) - .S PSADJD=$S($P(PSANODE,"^",6)'="":$P(PSANODE,"^",6),1:$P(PSANODE,"^",2)) - .S PSASUP=$S(PSADJD'?1.N:1,1:0) - .S PSADRG=$S(PSADJ&('PSASUP):$G(PSADJD),PSADJ&(PSASUP):0,1:+$P(PSADATA,"^",2)) - .I $G(PSADJD),$L(PSADJD)=$L(+PSADJD),$P($G(^PSDRUG(+PSADJD,0)),"^")'="" S (PSADRG,PSA50IEN)=+PSADJD Q - .I $G(PSADJD),$L(PSADJD)=$L(+PSADJD),$P($G(^PSDRUG(+PSADJD,0)),"^")="" S (PSADJ,PSADRG)=0 Q - .S PSADJSUP=1,(PSADRG,PSA50IEN)=PSADJD - I '$G(PSADJ) D - .S (PSA50IEN,PSADRG)=$S(+$P(PSADATA,"^",2)&($P($G(^PSDRUG(+$P(PSADATA,"^",2),0)),"^")'=""):+$P(PSADATA,"^",2),1:0) - S PSADRUGN=$S($P($G(^PSDRUG(PSADRG,0)),"^")'="":$P($G(^PSDRUG(PSADRG,0)),"^"),1:"Unknown Drug Name") -QTY ;Quantity - ;No Adj. Qty - S PSADJQ="",PSADJ=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","Q",0)) - I $G(PSADJ) S PSANODE=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0)),PSADJQ=$S($P(PSANODE,"^",6)'="":+$P(PSANODE,"^",6),1:$P(PSANODE,"^",2)) - ;Adj. Qty - I $G(PSADJQ) S PSAQTY=PSADJQ - I '$G(PSADJQ) S PSAQTY=$P(PSADATA,"^",3) -UPC S:$P(PSADATA,"^",13) PSAUPC=$P(PSADATA,"^",13) -OU ;W !,"Order Unit : " - S PSAOU=$S(+$P(PSADATA,"^",4)&($P($G(^DIC(51.5,+$P(PSADATA,"^",4),0)),"^")'=""):+$P(PSADATA,"^",4),1:"") - S PSATEMP=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2)) - I +$P(PSATEMP,"^",3),PSADRG,+$P($G(^PSDRUG(PSADRG,1,+$P(PSATEMP,"^",3),0)),"^",5) S PSAOU=+$P(^PSDRUG(PSADRG,1,+$P(PSATEMP,"^",3),0),"^",5) - S PSADJO="",PSADJ=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","O",0)) - I $G(PSADJ) S PSANODE=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0)),PSADJO=$S($P(PSANODE,"^",6)'="":$P(PSANODE,"^",6),1:$P(PSANODE,"^",2)) - ;Adj. Order Unit - I PSADJO'="" S PSAOU=+PSADJO - I PSADJO="" ;W $S(+PSAOU:$P($G(^DIC(51.5,+PSAOU,0)),"^"),1:"Blank") - ; -NDC S PSANDC=$P(PSADATA,"^",11) - ;I $E(PSANDC)'="S" W ?38,"NDC: "_$S(PSANDC'="":$E(PSANDC,1,6)_"-"_$E(PSANDC,7,10)_"-"_$E(PSANDC,11,12),1:"Blank") - ; -PRICE ;W !,"Unit Price : $" - S PSADJP=0,PSADJ=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","P",0)) - I $G(PSADJ) S PSANODE=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0)),PSADJP=$S(+$P(PSANODE,"^",6):+$P(PSANODE,"^",6),1:+$P(PSANODE,"^",2)) - ;Adj. Unit Price - I $G(PSADJP) D - .I $L($P(PSADJP,".",2))<2 S PSADJP=$P(PSADJP,".")_"."_$P(PSADJP,".",2)_$E("00",1,(2-$L($P(PSADJP,".",2)))) - .;W $FN(PSADJP,",")_" ($"_$S(+$P(PSADATA,"^",5):$FN($P(PSADATA,"^",5),","),$P(PSADATA,"^",5)=0:"0.00",1:"")_")" - .S PSAPRICE=PSADJP - I '$G(PSADJP) D - .S PSAPRICE=+$P(PSADATA,"^",5) - .;I $G(PSAPRICE)!(PSAPRICE=0) W $S($G(PSAPRICE):PSAPRICE,1:"0.00") Q - .;W "Blank" - ; -VSN ;W ?38,"VSN: "_$S(PSAVSN'="":PSAVSN,1:"Blank"),! -VDU S PSADUOU=+$P(PSATEMP,"^"),PSAREORD=+$P(PSATEMP,"^",2),PSASUB=+$P(PSATEMP,"^",3),PSASTOCK=+$P(PSATEMP,"^",4) - S INVARRAY(PSAORD,PSAINV,PSALINE)=$G(PSADRG)_"~"_$G(PSADRUGN)_"^"_$G(PSAQTY)_"^"_$G(PSALOC)_"^"_$G(PSAOU)_"^"_$G(PSANDC)_"^"_$G(PSAPRICE)_"^"_$G(PSAVSN)_"^"_$G(PSAUPC) - ; - I '+$P($G(^PSD(58.8,+PSALOC,0)),"^",14) G DISPLN - ; -STOCK S PSASTOCK=$S(+PSASTOCK:+PSASTOCK,+$P($G(^PSD(58.8,+PSALOC,1,+PSADRG,0)),"^",3):+$P($G(^PSD(58.8,+PSALOC,1,+PSADRG,0)),"^",3),1:"Blank") -REORDER S PSAREORD=$S(+PSAREORD:+PSAREORD,+$P($G(^PSD(58.8,+PSALOC,1,+PSADRG,0)),"^",5):+$P($G(^PSD(58.8,+PSALOC,1,+PSADRG,0)),"^",5),1:"Blank") - S INVARRAY(PSAORD,PSAINV,PSALINE)=$G(INVARRAY(PSAORD,PSAINV,PSALINE))_"^"_$G(PSASTOCK)_"^"_$G(PSAREORD) - G DISPLN -ASK R !!,"Enter an '^' to abort, to continue, or a corresponding line item number: ",AN:DTIME I AN="" G DISPLN - I AN["^" G Q - I AN<0!(AN>CNT) W !,"Enter a number between 1 and ",CNT G ASK - S (PSALINE,PSALINEN)=AN -PROCSS I '$D(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,0)) W !,"Invalid line number." G ASK - S PSADATA=^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,0),PSASUP=0 - S PSANDC=$P(PSADATA,"^",11),PSAVSN=$P(PSADATA,"^",12),PSALOC=$S($P(PSADATA,"^",10):+$P(PSAIN,"^",12),1:+$P(PSAIN,"^",5)) -VIEW S PSALINEN=" " D VERDISP^PSAUTL4 W !,PSASLN,! - W "1. Drug",!,"2. Order Unit",! S PSACHO=2 - S DIR(0)="LO^1:"_PSACHO,DIR("A")="Edit fields",DIR("?")="Enter the number(s) of the data to be edited" S DIR("??")="^D DDQOR^PSAVER3" - D ^DIR K DIR I $G(DTOUT)!($G(DUOUT)) S PSAOUT=1 Q - Q:Y="" S PSAFLDS=Y,PSASET=0 ;D VERDISP^PSAUTL4 W PSASLN -FIELDS F PSAPCF=1:1 S PSAFLD=$P(PSAFLDS,",",PSAPCF) Q:'PSAFLD!(PSAOUT) D - .I PSAFLD=1 D ASKDRUG^PSAVERA2 Q - .I PSAFLD=2 D OU^PSAVER2 Q -Q Q - ; -UPDATE ; *63 RJS CODE REMOVED FROM PSAVERA AND CALLED BY PSAVERA - ;File data in 58.8 - ;PSALOC= Either PSALOC or PSALOCB - S PSADRG=PSABFR - F L +^PSD(58.8,PSALOC,1,PSADRG,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q - S PSADUREC=PSAQTY*$G(PSAODUOU),PSABAL=$P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",4),$P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",4)=PSABAL-$G(PSABFR("Q")) - L -^PSD(58.8,PSALOC,1,PSADRG,0) - S PSADRG=PSAAFTER,PSAABAL=PSABAL,PSADUREC=PSAQTY*$G(PSADUOU) - D NOW^%DTC S PSADT=+$E(%,1,14) - I '$D(^PSD(58.8,PSALOC,1,PSADRG,0)) D - .S:'$D(^PSD(58.8,PSALOC,1,0)) DIC("P")=$P(^DD(58.8,10,0),"^",2) - .S DA(1)=PSALOC,DIC="^PSD(58.8,"_DA(1)_",1,",(DA,DINUM,X)=PSADRG,DIC(0)="L",DLAYGO=58.8 ;*53 - .F L +^PSD(58.8,PSALOC,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q - .D FILE^DICN L -^PSD(58.8,PSALOC,0) K DIC,DA,DLAYGO - F L +^PSD(58.8,PSALOC,1,PSADRG,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q - S PSABAL=$P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",4) - I $P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",1)'=PSADRG S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",1)=PSADRG - S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",4)=PSADUREC+PSABAL - I +$P($G(^PSD(58.8,PSALOC,0)),"^",14) D - .I PSASTOCK'=$P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",3) S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",3)=PSASTOCK - .I PSAREORD'=$P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",5) S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",5)=PSAREORD - S:'$D(^PSD(58.8,PSALOC,1,PSADRG,5,0)) DIC("P")=$P(^DD(58.8001,20,0),"^",2) - I '$D(^PSD(58.8,PSALOC,1,PSADRG,5,$E(DT,1,5)*100,0)) D - .S DIC="^PSD(58.8,"_PSALOC_",1,"_PSADRG_",5,",DIC(0)="L",DIC("DR")="1////^S X=$G(PSABAL)",(X,DINUM)=$E(DT,1,5)*100,DA(2)=PSALOC,DA(1)=PSADRG,DLAYGO=58.8 D ^DIC K DIC - .S X="T-1M" D ^%DT S DIC="^PSD(58.8,"_PSALOC_",1,"_PSADRG_",5,",DIC(0)="L",(X,DINUM)=$E(Y,1,5)*100 D ^DIC K DIC,DLAYGO S DA=+Y - .S DA(2)=PSALOC,DA(1)=PSADRG,DIE="^PSD(58.8,"_DA(2)_",1,"_DA(1)_",5,",DR="3////^S X=$G(PSABAL)" D ^DIE K DIE - S DA(2)=PSALOC,DA(1)=PSADRG,DIE="^PSD(58.8,"_DA(2)_",1,"_DA(1)_",5,",DA=$E(DT,1,5)*100,DR="5////^S X="_($P($G(^(0)),"^",3)+PSADUREC) D ^DIE K DIE - L -^PSD(58.8,PSALOC,1,PSADRG,0) - W !,"updating pharmacy location file." -FILE581 ;Update transaction file ;;*63 - S PSAVDUZ=DUZ,PSAREA="EDIT VERIFIED INVOICE" - I '$G(PSABFR(581)) D NEW581 Q - I PSADRG'=PSABFR S PSANQTY=0,PSAAQTY=$G(PSABFR("Q"))*-1 - I PSADRG=PSABFR S PSANQTY=PSADUREC D - .S PSAAQTY=PSADUREC-$G(PSABFR("Q")) -FIND S PSAT=$P(^PSD(58.81,0),"^",3)+1 I $D(^PSD(58.81,PSAT)) S $P(^PSD(58.81,0),"^",3)=$P(^PSD(58.81,0),"^",3)+1 G FIND - S DIC="^PSD(58.81,",DIC(0)="L",DLAYGO=58.81,(DINUM,X)=PSAT D ^DIC K DIC,DINUM,DLAYGO L -^PSD(58.81,0) - S DIE="^PSD(58.81,",DA=PSAT - I PSAAFTER'=PSABFR S PSADRG=PSABFR - S DR="1////14;2////^S X=PSALOC;3////^S X=PSADT;4////^S X=PSADRG;48////^S X=PSADT;49////^S X=PSAVDUZ;50////^S X=PSANQTY;51////^S X=PSAAQTY;53////^S X=PSAREA;54////^S X=PSAABAL;71////^S X=PSAINV;106////^S X=PSAORD" - F L +^PSD(58.81,DA,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q - D ^DIE L -^PSD(58.81,DA,0) K DIE - I PSAAFTER'=PSABFR S PSADRG=PSAAFTER D NEW581 - Q - ; -NEW581 S PSAT=$P(^PSD(58.81,0),"^",3)+1 I $D(^PSD(58.81,PSAT)) S $P(^PSD(58.81,0),"^",3)=$P(^PSD(58.81,0),"^",3)+1 G NEW581 - S DIC="^PSD(58.81,",DIC(0)="L",DLAYGO=58.81,(DINUM,X)=PSAT D ^DIC K DIC,DINUM,DLAYGO L -^PSD(58.81,0) - S PSADUREC=PSAQTY*$G(PSADUOU) - S DIE="^PSD(58.81,",DA=PSAT,DR="1////1;2////^S X=PSALOC;3////^S X=PSADT;4////^S X=PSADRG;5////^S X=PSADUREC;6////^S X=PSAVDUZ;9////^S X=PSABAL;71////^S X=PSAINV;106////^S X=PSAORD" - I $G(PSACS)>0 S DR=DR_";100////^S X=PSACS" - F L +^PSD(58.81,DA,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q - D ^DIE L -^PSD(58.81,DA,0) K DIE W !,"updating transaction file." Q - Q +PSAVERA1 ;BHM/DB - Edit previously verified invoices;16NOV99 + ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**21,61**; 10/24/97;Build 1 + ;References to ^DIC(51.5 are covered by IA #1931 + ;References to ^PSDRUG( are covered by IA #2095 + ; + S $P(PSASLN,"=",79)="" K PSALINE +DISPLN S PSALINE=$S('$D(PSALINE):$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,0)),1:$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE))) G Q:PSALINE'>0 S CNT=$G(CNT)+1 + S PSADATA=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,0)) + S PSATEMP=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2)) + S PSAVSN=$P(PSADATA,"^",12),PSAOUT=0 +DRUG S PSADJ=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","D",0)) + I $G(PSADJ) D + .S PSANODE=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0)) + .S PSADJD=$S($P(PSANODE,"^",6)'="":$P(PSANODE,"^",6),1:$P(PSANODE,"^",2)) + .S PSASUP=$S(PSADJD'?1.N:1,1:0) + .S PSADRG=$S(PSADJ&('PSASUP):$G(PSADJD),PSADJ&(PSASUP):0,1:+$P(PSADATA,"^",2)) + .I $G(PSADJD),$L(PSADJD)=$L(+PSADJD),$P($G(^PSDRUG(+PSADJD,0)),"^")'="" S (PSADRG,PSA50IEN)=+PSADJD Q + .I $G(PSADJD),$L(PSADJD)=$L(+PSADJD),$P($G(^PSDRUG(+PSADJD,0)),"^")="" S (PSADJ,PSADRG)=0 Q + .S PSADJSUP=1,(PSADRG,PSA50IEN)=PSADJD + I '$G(PSADJ) D + .S (PSA50IEN,PSADRG)=$S(+$P(PSADATA,"^",2)&($P($G(^PSDRUG(+$P(PSADATA,"^",2),0)),"^")'=""):+$P(PSADATA,"^",2),1:0) + S PSADRUGN=$S($P($G(^PSDRUG(PSADRG,0)),"^")'="":$P($G(^PSDRUG(PSADRG,0)),"^"),1:"Unknown Drug Name") +QTY ;Quantity + ;No Adj. Qty + S PSADJQ="",PSADJ=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","Q",0)) + I $G(PSADJ) S PSANODE=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0)),PSADJQ=$S($P(PSANODE,"^",6)'="":+$P(PSANODE,"^",6),1:$P(PSANODE,"^",2)) + ;Adj. Qty + I $G(PSADJQ) S PSAQTY=PSADJQ + I '$G(PSADJQ) S PSAQTY=$P(PSADATA,"^",3) +UPC S:$P(PSADATA,"^",13) PSAUPC=$P(PSADATA,"^",13) +OU ;W !,"Order Unit : " + S PSAOU=$S(+$P(PSADATA,"^",4)&($P($G(^DIC(51.5,+$P(PSADATA,"^",4),0)),"^")'=""):+$P(PSADATA,"^",4),1:"") + S PSATEMP=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2)) + I +$P(PSATEMP,"^",3),PSADRG,+$P($G(^PSDRUG(PSADRG,1,+$P(PSATEMP,"^",3),0)),"^",5) S PSAOU=+$P(^PSDRUG(PSADRG,1,+$P(PSATEMP,"^",3),0),"^",5) + S PSADJO="",PSADJ=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","O",0)) + I $G(PSADJ) S PSANODE=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0)),PSADJO=$S($P(PSANODE,"^",6)'="":$P(PSANODE,"^",6),1:$P(PSANODE,"^",2)) + ;Adj. Order Unit + I PSADJO'="" S PSAOU=+PSADJO + I PSADJO="" ;W $S(+PSAOU:$P($G(^DIC(51.5,+PSAOU,0)),"^"),1:"Blank") + ; +NDC S PSANDC=$P(PSADATA,"^",11) + ;I $E(PSANDC)'="S" W ?38,"NDC: "_$S(PSANDC'="":$E(PSANDC,1,6)_"-"_$E(PSANDC,7,10)_"-"_$E(PSANDC,11,12),1:"Blank") + ; +PRICE ;W !,"Unit Price : $" + S PSADJP=0,PSADJ=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","P",0)) + I $G(PSADJ) S PSANODE=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0)),PSADJP=$S(+$P(PSANODE,"^",6):+$P(PSANODE,"^",6),1:+$P(PSANODE,"^",2)) + ;Adj. Unit Price + I $G(PSADJP) D + .I $L($P(PSADJP,".",2))<2 S PSADJP=$P(PSADJP,".")_"."_$P(PSADJP,".",2)_$E("00",1,(2-$L($P(PSADJP,".",2)))) + .;W $FN(PSADJP,",")_" ($"_$S(+$P(PSADATA,"^",5):$FN($P(PSADATA,"^",5),","),$P(PSADATA,"^",5)=0:"0.00",1:"")_")" + .S PSAPRICE=PSADJP + I '$G(PSADJP) D + .S PSAPRICE=+$P(PSADATA,"^",5) + .;I $G(PSAPRICE)!(PSAPRICE=0) W $S($G(PSAPRICE):PSAPRICE,1:"0.00") Q + .;W "Blank" + ; +VSN ;W ?38,"VSN: "_$S(PSAVSN'="":PSAVSN,1:"Blank"),! +VDU S PSADUOU=+$P(PSATEMP,"^"),PSAREORD=+$P(PSATEMP,"^",2),PSASUB=+$P(PSATEMP,"^",3),PSASTOCK=+$P(PSATEMP,"^",4) + S INVARRAY(PSAORD,PSAINV,PSALINE)=$G(PSADRG)_"~"_$G(PSADRUGN)_"^"_$G(PSAQTY)_"^"_$G(PSALOC)_"^"_$G(PSAOU)_"^"_$G(PSANDC)_"^"_$G(PSAPRICE)_"^"_$G(PSAVSN)_"^"_$G(PSAUPC) + ; + I '+$P($G(^PSD(58.8,+PSALOC,0)),"^",14) G DISPLN + ; +STOCK S PSASTOCK=$S(+PSASTOCK:+PSASTOCK,+$P($G(^PSD(58.8,+PSALOC,1,+PSADRG,0)),"^",3):+$P($G(^PSD(58.8,+PSALOC,1,+PSADRG,0)),"^",3),1:"Blank") +REORDER S PSAREORD=$S(+PSAREORD:+PSAREORD,+$P($G(^PSD(58.8,+PSALOC,1,+PSADRG,0)),"^",5):+$P($G(^PSD(58.8,+PSALOC,1,+PSADRG,0)),"^",5),1:"Blank") + S INVARRAY(PSAORD,PSAINV,PSALINE)=$G(INVARRAY(PSAORD,PSAINV,PSALINE))_"^"_$G(PSASTOCK)_"^"_$G(PSAREORD) + G DISPLN +ASK R !!,"Enter an '^' to abort, to continue, or a corresponding line item number: ",AN:DTIME I AN="" G DISPLN + I AN["^" G Q + I AN<0!(AN>CNT) W !,"Enter a number between 1 and ",CNT G ASK + S (PSALINE,PSALINEN)=AN +PROCSS I '$D(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,0)) W !,"Invalid line number." G ASK + S PSADATA=^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,0),PSASUP=0 + S PSANDC=$P(PSADATA,"^",11),PSAVSN=$P(PSADATA,"^",12),PSALOC=$S($P(PSADATA,"^",10):+$P(PSAIN,"^",12),1:+$P(PSAIN,"^",5)) +VIEW S PSALINEN=" " D VERDISP^PSAUTL4 W !,PSASLN,! + W "1. Drug",!,"2. Order Unit",! S PSACHO=2 + S DIR(0)="LO^1:"_PSACHO,DIR("A")="Edit fields",DIR("?")="Enter the number(s) of the data to be edited" S DIR("??")="^D DDQOR^PSAVER3" + D ^DIR K DIR I $G(DTOUT)!($G(DUOUT)) S PSAOUT=1 Q + Q:Y="" S PSAFLDS=Y,PSASET=0 ;D VERDISP^PSAUTL4 W PSASLN +FIELDS F PSAPCF=1:1 S PSAFLD=$P(PSAFLDS,",",PSAPCF) Q:'PSAFLD!(PSAOUT) D + .I PSAFLD=1 D ASKDRUG^PSAVERA2 Q + .I PSAFLD=2 D OU^PSAVER2 Q +Q Q diff --git a/r/DSS_EXTRACTS-ECX/ECX802.m b/r/DSS_EXTRACTS-ECX/ECX802.m index b34b7dea..ef45d02e 100644 --- a/r/DSS_EXTRACTS-ECX/ECX802.m +++ b/r/DSS_EXTRACTS-ECX/ECX802.m @@ -1,4 +1,4 @@ -ECX802 ; DRIVER FOR COMPILED XREFS FOR FILE #727.802 ; 12/13/08 +ECX802 ; DRIVER FOR COMPILED XREFS FOR FILE #727.802 ; 12/27/07 ; N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2 I '$D(DIKSAT) S DIKLK=DIK_DA_")" L +@DIKLK:10 K:'$T DIKLK diff --git a/r/DSS_EXTRACTS-ECX/ECX8021.m b/r/DSS_EXTRACTS-ECX/ECX8021.m index 275a9d0e..01582c4a 100644 --- a/r/DSS_EXTRACTS-ECX/ECX8021.m +++ b/r/DSS_EXTRACTS-ECX/ECX8021.m @@ -1,4 +1,4 @@ -ECX8021 ; COMPILED XREF FOR FILE #727.802 ; 12/13/08 +ECX8021 ; COMPILED XREF FOR FILE #727.802 ; 12/27/07 ; S DIKZK=2 S DIKZ(0)=$G(^ECX(727.802,DA,0)) diff --git a/r/DSS_EXTRACTS-ECX/ECX8022.m b/r/DSS_EXTRACTS-ECX/ECX8022.m index c9b8f98a..1838efb5 100644 --- a/r/DSS_EXTRACTS-ECX/ECX8022.m +++ b/r/DSS_EXTRACTS-ECX/ECX8022.m @@ -1,4 +1,4 @@ -ECX8022 ; COMPILED XREF FOR FILE #727.802 ; 12/13/08 +ECX8022 ; COMPILED XREF FOR FILE #727.802 ; 12/27/07 ; S DIKZK=1 S DIKZ(0)=$G(^ECX(727.802,DA,0)) diff --git a/r/DSS_EXTRACTS-ECX/ECX808.m b/r/DSS_EXTRACTS-ECX/ECX808.m index e6b8bbf3..6d37b29d 100644 --- a/r/DSS_EXTRACTS-ECX/ECX808.m +++ b/r/DSS_EXTRACTS-ECX/ECX808.m @@ -1,4 +1,4 @@ -ECX808 ; DRIVER FOR COMPILED XREFS FOR FILE #727.808 ; 12/13/08 +ECX808 ; DRIVER FOR COMPILED XREFS FOR FILE #727.808 ; 12/27/07 ; N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2 I '$D(DIKSAT) S DIKLK=DIK_DA_")" L +@DIKLK:10 K:'$T DIKLK diff --git a/r/DSS_EXTRACTS-ECX/ECX8081.m b/r/DSS_EXTRACTS-ECX/ECX8081.m index 4f9767d7..20746e7a 100644 --- a/r/DSS_EXTRACTS-ECX/ECX8081.m +++ b/r/DSS_EXTRACTS-ECX/ECX8081.m @@ -1,4 +1,4 @@ -ECX8081 ; COMPILED XREF FOR FILE #727.808 ; 12/13/08 +ECX8081 ; COMPILED XREF FOR FILE #727.808 ; 12/27/07 ; S DIKZK=2 S DIKZ(0)=$G(^ECX(727.808,DA,0)) diff --git a/r/DSS_EXTRACTS-ECX/ECX8082.m b/r/DSS_EXTRACTS-ECX/ECX8082.m index 350f683b..32d6abfc 100644 --- a/r/DSS_EXTRACTS-ECX/ECX8082.m +++ b/r/DSS_EXTRACTS-ECX/ECX8082.m @@ -1,4 +1,4 @@ -ECX8082 ; COMPILED XREF FOR FILE #727.808 ; 12/13/08 +ECX8082 ; COMPILED XREF FOR FILE #727.808 ; 12/27/07 ; S DIKZK=1 S DIKZ(0)=$G(^ECX(727.808,DA,0)) diff --git a/r/DSS_EXTRACTS-ECX/ECX809.m b/r/DSS_EXTRACTS-ECX/ECX809.m index 454731f0..1ec2281a 100644 --- a/r/DSS_EXTRACTS-ECX/ECX809.m +++ b/r/DSS_EXTRACTS-ECX/ECX809.m @@ -1,4 +1,4 @@ -ECX809 ; DRIVER FOR COMPILED XREFS FOR FILE #727.809 ; 12/13/08 +ECX809 ; DRIVER FOR COMPILED XREFS FOR FILE #727.809 ; 12/27/07 ; N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2 I '$D(DIKSAT) S DIKLK=DIK_DA_")" L +@DIKLK:10 K:'$T DIKLK diff --git a/r/DSS_EXTRACTS-ECX/ECX8091.m b/r/DSS_EXTRACTS-ECX/ECX8091.m index 826f71b9..05e52a58 100644 --- a/r/DSS_EXTRACTS-ECX/ECX8091.m +++ b/r/DSS_EXTRACTS-ECX/ECX8091.m @@ -1,4 +1,4 @@ -ECX8091 ; COMPILED XREF FOR FILE #727.809 ; 12/13/08 +ECX8091 ; COMPILED XREF FOR FILE #727.809 ; 12/27/07 ; S DIKZK=2 S DIKZ(0)=$G(^ECX(727.809,DA,0)) diff --git a/r/DSS_EXTRACTS-ECX/ECX8092.m b/r/DSS_EXTRACTS-ECX/ECX8092.m index 0b255481..58068b69 100644 --- a/r/DSS_EXTRACTS-ECX/ECX8092.m +++ b/r/DSS_EXTRACTS-ECX/ECX8092.m @@ -1,4 +1,4 @@ -ECX8092 ; COMPILED XREF FOR FILE #727.809 ; 12/13/08 +ECX8092 ; COMPILED XREF FOR FILE #727.809 ; 12/27/07 ; S DIKZK=1 S DIKZ(0)=$G(^ECX(727.809,DA,0)) diff --git a/r/DSS_EXTRACTS-ECX/ECX810.m b/r/DSS_EXTRACTS-ECX/ECX810.m index 1f8f9ba3..238233bb 100644 --- a/r/DSS_EXTRACTS-ECX/ECX810.m +++ b/r/DSS_EXTRACTS-ECX/ECX810.m @@ -1,4 +1,4 @@ -ECX810 ; DRIVER FOR COMPILED XREFS FOR FILE #727.81 ; 12/13/08 +ECX810 ; DRIVER FOR COMPILED XREFS FOR FILE #727.81 ; 12/27/07 ; N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2 I '$D(DIKSAT) S DIKLK=DIK_DA_")" L +@DIKLK:10 K:'$T DIKLK diff --git a/r/DSS_EXTRACTS-ECX/ECX8101.m b/r/DSS_EXTRACTS-ECX/ECX8101.m index 0a29d129..686966c9 100644 --- a/r/DSS_EXTRACTS-ECX/ECX8101.m +++ b/r/DSS_EXTRACTS-ECX/ECX8101.m @@ -1,4 +1,4 @@ -ECX8101 ; COMPILED XREF FOR FILE #727.81 ; 12/13/08 +ECX8101 ; COMPILED XREF FOR FILE #727.81 ; 12/27/07 ; S DIKZK=2 S DIKZ(0)=$G(^ECX(727.81,DA,0)) diff --git a/r/DSS_EXTRACTS-ECX/ECX8102.m b/r/DSS_EXTRACTS-ECX/ECX8102.m index 3cf25d4b..f9e7008e 100644 --- a/r/DSS_EXTRACTS-ECX/ECX8102.m +++ b/r/DSS_EXTRACTS-ECX/ECX8102.m @@ -1,4 +1,4 @@ -ECX8102 ; COMPILED XREF FOR FILE #727.81 ; 12/13/08 +ECX8102 ; COMPILED XREF FOR FILE #727.81 ; 12/27/07 ; S DIKZK=1 S DIKZ(0)=$G(^ECX(727.81,DA,0)) diff --git a/r/DSS_EXTRACTS-ECX/ECX811.m b/r/DSS_EXTRACTS-ECX/ECX811.m index 29a2a854..c4045f2c 100644 --- a/r/DSS_EXTRACTS-ECX/ECX811.m +++ b/r/DSS_EXTRACTS-ECX/ECX811.m @@ -1,4 +1,4 @@ -ECX811 ; DRIVER FOR COMPILED XREFS FOR FILE #727.811 ; 12/13/08 +ECX811 ; DRIVER FOR COMPILED XREFS FOR FILE #727.811 ; 12/25/06 ; N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2 I '$D(DIKSAT) S DIKLK=DIK_DA_")" L +@DIKLK:10 K:'$T DIKLK diff --git a/r/DSS_EXTRACTS-ECX/ECX8111.m b/r/DSS_EXTRACTS-ECX/ECX8111.m index da3e7b38..41c90b5e 100644 --- a/r/DSS_EXTRACTS-ECX/ECX8111.m +++ b/r/DSS_EXTRACTS-ECX/ECX8111.m @@ -1,4 +1,4 @@ -ECX8111 ; COMPILED XREF FOR FILE #727.811 ; 12/13/08 +ECX8111 ; COMPILED XREF FOR FILE #727.811 ; 12/25/06 ; S DIKZK=2 S DIKZ(0)=$G(^ECX(727.811,DA,0)) diff --git a/r/DSS_EXTRACTS-ECX/ECX8112.m b/r/DSS_EXTRACTS-ECX/ECX8112.m index 6f545125..7ca30ba0 100644 --- a/r/DSS_EXTRACTS-ECX/ECX8112.m +++ b/r/DSS_EXTRACTS-ECX/ECX8112.m @@ -1,4 +1,4 @@ -ECX8112 ; COMPILED XREF FOR FILE #727.811 ; 12/13/08 +ECX8112 ; COMPILED XREF FOR FILE #727.811 ; 12/25/06 ; S DIKZK=1 S DIKZ(0)=$G(^ECX(727.811,DA,0)) diff --git a/r/DSS_EXTRACTS-ECX/ECX813.m b/r/DSS_EXTRACTS-ECX/ECX813.m index 72453620..1e1bf2ba 100644 --- a/r/DSS_EXTRACTS-ECX/ECX813.m +++ b/r/DSS_EXTRACTS-ECX/ECX813.m @@ -1,4 +1,4 @@ -ECX813 ; DRIVER FOR COMPILED XREFS FOR FILE #727.813 ; 12/13/08 +ECX813 ; DRIVER FOR COMPILED XREFS FOR FILE #727.813 ; 12/27/07 ; N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2 I '$D(DIKSAT) S DIKLK=DIK_DA_")" L +@DIKLK:10 K:'$T DIKLK diff --git a/r/DSS_EXTRACTS-ECX/ECX8131.m b/r/DSS_EXTRACTS-ECX/ECX8131.m index a00cac1a..a0678d96 100644 --- a/r/DSS_EXTRACTS-ECX/ECX8131.m +++ b/r/DSS_EXTRACTS-ECX/ECX8131.m @@ -1,4 +1,4 @@ -ECX8131 ; COMPILED XREF FOR FILE #727.813 ; 12/13/08 +ECX8131 ; COMPILED XREF FOR FILE #727.813 ; 12/27/07 ; S DIKZK=2 S DIKZ(0)=$G(^ECX(727.813,DA,0)) diff --git a/r/DSS_EXTRACTS-ECX/ECX8132.m b/r/DSS_EXTRACTS-ECX/ECX8132.m index 199a61a1..84f65ed0 100644 --- a/r/DSS_EXTRACTS-ECX/ECX8132.m +++ b/r/DSS_EXTRACTS-ECX/ECX8132.m @@ -1,4 +1,4 @@ -ECX8132 ; COMPILED XREF FOR FILE #727.813 ; 12/13/08 +ECX8132 ; COMPILED XREF FOR FILE #727.813 ; 12/27/07 ; S DIKZK=1 S DIKZ(0)=$G(^ECX(727.813,DA,0)) diff --git a/r/DSS_EXTRACTS-ECX/ECX814.m b/r/DSS_EXTRACTS-ECX/ECX814.m index c3a3e545..ad115f35 100644 --- a/r/DSS_EXTRACTS-ECX/ECX814.m +++ b/r/DSS_EXTRACTS-ECX/ECX814.m @@ -1,4 +1,4 @@ -ECX814 ; DRIVER FOR COMPILED XREFS FOR FILE #727.814 ; 12/13/08 +ECX814 ; DRIVER FOR COMPILED XREFS FOR FILE #727.814 ; 12/25/06 ; N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2 I '$D(DIKSAT) S DIKLK=DIK_DA_")" L +@DIKLK:10 K:'$T DIKLK diff --git a/r/DSS_EXTRACTS-ECX/ECX8141.m b/r/DSS_EXTRACTS-ECX/ECX8141.m index 40ef0969..fd8afaab 100644 --- a/r/DSS_EXTRACTS-ECX/ECX8141.m +++ b/r/DSS_EXTRACTS-ECX/ECX8141.m @@ -1,4 +1,4 @@ -ECX8141 ; COMPILED XREF FOR FILE #727.814 ; 12/13/08 +ECX8141 ; COMPILED XREF FOR FILE #727.814 ; 12/25/06 ; S DIKZK=2 S DIKZ(0)=$G(^ECX(727.814,DA,0)) diff --git a/r/DSS_EXTRACTS-ECX/ECX8142.m b/r/DSS_EXTRACTS-ECX/ECX8142.m index 7b0de3fa..d83379d0 100644 --- a/r/DSS_EXTRACTS-ECX/ECX8142.m +++ b/r/DSS_EXTRACTS-ECX/ECX8142.m @@ -1,4 +1,4 @@ -ECX8142 ; COMPILED XREF FOR FILE #727.814 ; 12/13/08 +ECX8142 ; COMPILED XREF FOR FILE #727.814 ; 12/25/06 ; S DIKZK=1 S DIKZ(0)=$G(^ECX(727.814,DA,0)) diff --git a/r/DSS_EXTRACTS-ECX/ECX815.m b/r/DSS_EXTRACTS-ECX/ECX815.m index 4a0f420e..ffb3db13 100644 --- a/r/DSS_EXTRACTS-ECX/ECX815.m +++ b/r/DSS_EXTRACTS-ECX/ECX815.m @@ -1,4 +1,4 @@ -ECX815 ; DRIVER FOR COMPILED XREFS FOR FILE #727.815 ; 12/13/08 +ECX815 ; DRIVER FOR COMPILED XREFS FOR FILE #727.815 ; 12/25/06 ; N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2 I '$D(DIKSAT) S DIKLK=DIK_DA_")" L +@DIKLK:10 K:'$T DIKLK diff --git a/r/DSS_EXTRACTS-ECX/ECX8151.m b/r/DSS_EXTRACTS-ECX/ECX8151.m index 2de2ff07..d428b6db 100644 --- a/r/DSS_EXTRACTS-ECX/ECX8151.m +++ b/r/DSS_EXTRACTS-ECX/ECX8151.m @@ -1,4 +1,4 @@ -ECX8151 ; COMPILED XREF FOR FILE #727.815 ; 12/13/08 +ECX8151 ; COMPILED XREF FOR FILE #727.815 ; 12/25/06 ; S DIKZK=2 S DIKZ(0)=$G(^ECX(727.815,DA,0)) diff --git a/r/DSS_EXTRACTS-ECX/ECX8152.m b/r/DSS_EXTRACTS-ECX/ECX8152.m index 0c5a6e62..f00121b2 100644 --- a/r/DSS_EXTRACTS-ECX/ECX8152.m +++ b/r/DSS_EXTRACTS-ECX/ECX8152.m @@ -1,4 +1,4 @@ -ECX8152 ; COMPILED XREF FOR FILE #727.815 ; 12/13/08 +ECX8152 ; COMPILED XREF FOR FILE #727.815 ; 12/25/06 ; S DIKZK=1 S DIKZ(0)=$G(^ECX(727.815,DA,0)) diff --git a/r/DSS_EXTRACTS-ECX/ECX817.m b/r/DSS_EXTRACTS-ECX/ECX817.m index 45e9ee67..900ce9a8 100644 --- a/r/DSS_EXTRACTS-ECX/ECX817.m +++ b/r/DSS_EXTRACTS-ECX/ECX817.m @@ -1,4 +1,4 @@ -ECX817 ; DRIVER FOR COMPILED XREFS FOR FILE #727.817 ; 12/13/08 +ECX817 ; DRIVER FOR COMPILED XREFS FOR FILE #727.817 ; 12/27/07 ; N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2 I '$D(DIKSAT) S DIKLK=DIK_DA_")" L +@DIKLK:10 K:'$T DIKLK diff --git a/r/DSS_EXTRACTS-ECX/ECX8171.m b/r/DSS_EXTRACTS-ECX/ECX8171.m index bdba35ef..f6df6f04 100644 --- a/r/DSS_EXTRACTS-ECX/ECX8171.m +++ b/r/DSS_EXTRACTS-ECX/ECX8171.m @@ -1,4 +1,4 @@ -ECX8171 ; COMPILED XREF FOR FILE #727.817 ; 12/13/08 +ECX8171 ; COMPILED XREF FOR FILE #727.817 ; 12/27/07 ; S DIKZK=2 S DIKZ(0)=$G(^ECX(727.817,DA,0)) diff --git a/r/DSS_EXTRACTS-ECX/ECX8172.m b/r/DSS_EXTRACTS-ECX/ECX8172.m index ed77c2ab..7ea35256 100644 --- a/r/DSS_EXTRACTS-ECX/ECX8172.m +++ b/r/DSS_EXTRACTS-ECX/ECX8172.m @@ -1,4 +1,4 @@ -ECX8172 ; COMPILED XREF FOR FILE #727.817 ; 12/13/08 +ECX8172 ; COMPILED XREF FOR FILE #727.817 ; 12/27/07 ; S DIKZK=1 S DIKZ(0)=$G(^ECX(727.817,DA,0)) diff --git a/r/DSS_EXTRACTS-ECX/ECX819.m b/r/DSS_EXTRACTS-ECX/ECX819.m index e6a6699d..f0d0d3c1 100644 --- a/r/DSS_EXTRACTS-ECX/ECX819.m +++ b/r/DSS_EXTRACTS-ECX/ECX819.m @@ -1,4 +1,4 @@ -ECX819 ; DRIVER FOR COMPILED XREFS FOR FILE #727.819 ; 12/13/08 +ECX819 ; DRIVER FOR COMPILED XREFS FOR FILE #727.819 ; 12/27/07 ; N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2 I '$D(DIKSAT) S DIKLK=DIK_DA_")" L +@DIKLK:10 K:'$T DIKLK diff --git a/r/DSS_EXTRACTS-ECX/ECX8191.m b/r/DSS_EXTRACTS-ECX/ECX8191.m index 04defa58..0645ee10 100644 --- a/r/DSS_EXTRACTS-ECX/ECX8191.m +++ b/r/DSS_EXTRACTS-ECX/ECX8191.m @@ -1,4 +1,4 @@ -ECX8191 ; COMPILED XREF FOR FILE #727.819 ; 12/13/08 +ECX8191 ; COMPILED XREF FOR FILE #727.819 ; 12/27/07 ; S DIKZK=2 S DIKZ(0)=$G(^ECX(727.819,DA,0)) diff --git a/r/DSS_EXTRACTS-ECX/ECX8192.m b/r/DSS_EXTRACTS-ECX/ECX8192.m index d9290eb7..f42defd4 100644 --- a/r/DSS_EXTRACTS-ECX/ECX8192.m +++ b/r/DSS_EXTRACTS-ECX/ECX8192.m @@ -1,4 +1,4 @@ -ECX8192 ; COMPILED XREF FOR FILE #727.819 ; 12/13/08 +ECX8192 ; COMPILED XREF FOR FILE #727.819 ; 12/27/07 ; S DIKZK=1 S DIKZ(0)=$G(^ECX(727.819,DA,0)) diff --git a/r/DSS_EXTRACTS-ECX/ECX824.m b/r/DSS_EXTRACTS-ECX/ECX824.m index 1e1a797d..855731e0 100644 --- a/r/DSS_EXTRACTS-ECX/ECX824.m +++ b/r/DSS_EXTRACTS-ECX/ECX824.m @@ -1,4 +1,4 @@ -ECX824 ; DRIVER FOR COMPILED XREFS FOR FILE #727.824 ; 12/13/08 +ECX824 ; DRIVER FOR COMPILED XREFS FOR FILE #727.824 ; 12/27/07 ; N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2 I '$D(DIKSAT) S DIKLK=DIK_DA_")" L +@DIKLK:10 K:'$T DIKLK diff --git a/r/DSS_EXTRACTS-ECX/ECX8241.m b/r/DSS_EXTRACTS-ECX/ECX8241.m index d3ea07d5..117b6e0d 100644 --- a/r/DSS_EXTRACTS-ECX/ECX8241.m +++ b/r/DSS_EXTRACTS-ECX/ECX8241.m @@ -1,4 +1,4 @@ -ECX8241 ; COMPILED XREF FOR FILE #727.824 ; 12/13/08 +ECX8241 ; COMPILED XREF FOR FILE #727.824 ; 12/27/07 ; S DIKZK=2 S DIKZ(0)=$G(^ECX(727.824,DA,0)) diff --git a/r/DSS_EXTRACTS-ECX/ECX8242.m b/r/DSS_EXTRACTS-ECX/ECX8242.m index 42e934d2..4c2004f3 100644 --- a/r/DSS_EXTRACTS-ECX/ECX8242.m +++ b/r/DSS_EXTRACTS-ECX/ECX8242.m @@ -1,4 +1,4 @@ -ECX8242 ; COMPILED XREF FOR FILE #727.824 ; 12/13/08 +ECX8242 ; COMPILED XREF FOR FILE #727.824 ; 12/27/07 ; S DIKZK=1 S DIKZ(0)=$G(^ECX(727.824,DA,0)) diff --git a/r/DSS_EXTRACTS-ECX/ECX825.m b/r/DSS_EXTRACTS-ECX/ECX825.m index d14571a7..e52a7bfc 100644 --- a/r/DSS_EXTRACTS-ECX/ECX825.m +++ b/r/DSS_EXTRACTS-ECX/ECX825.m @@ -1,4 +1,4 @@ -ECX825 ; DRIVER FOR COMPILED XREFS FOR FILE #727.825 ; 12/13/08 +ECX825 ; DRIVER FOR COMPILED XREFS FOR FILE #727.825 ; 12/25/06 ; N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2 I '$D(DIKSAT) S DIKLK=DIK_DA_")" L +@DIKLK:10 K:'$T DIKLK diff --git a/r/DSS_EXTRACTS-ECX/ECX8251.m b/r/DSS_EXTRACTS-ECX/ECX8251.m index b8cdf130..7c7aa4cb 100644 --- a/r/DSS_EXTRACTS-ECX/ECX8251.m +++ b/r/DSS_EXTRACTS-ECX/ECX8251.m @@ -1,4 +1,4 @@ -ECX8251 ; COMPILED XREF FOR FILE #727.825 ; 12/13/08 +ECX8251 ; COMPILED XREF FOR FILE #727.825 ; 12/25/06 ; S DIKZK=2 S DIKZ(0)=$G(^ECX(727.825,DA,0)) diff --git a/r/DSS_EXTRACTS-ECX/ECX8252.m b/r/DSS_EXTRACTS-ECX/ECX8252.m index 166d21b6..7833aa6a 100644 --- a/r/DSS_EXTRACTS-ECX/ECX8252.m +++ b/r/DSS_EXTRACTS-ECX/ECX8252.m @@ -1,4 +1,4 @@ -ECX8252 ; COMPILED XREF FOR FILE #727.825 ; 12/13/08 +ECX8252 ; COMPILED XREF FOR FILE #727.825 ; 12/25/06 ; S DIKZK=1 S DIKZ(0)=$G(^ECX(727.825,DA,0)) diff --git a/r/DSS_EXTRACTS-ECX/ECX826.m b/r/DSS_EXTRACTS-ECX/ECX826.m index 46332b9e..4b583852 100644 --- a/r/DSS_EXTRACTS-ECX/ECX826.m +++ b/r/DSS_EXTRACTS-ECX/ECX826.m @@ -1,4 +1,4 @@ -ECX826 ; DRIVER FOR COMPILED XREFS FOR FILE #727.826 ; 12/13/08 +ECX826 ; DRIVER FOR COMPILED XREFS FOR FILE #727.826 ; 12/25/06 ; N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2 I '$D(DIKSAT) S DIKLK=DIK_DA_")" L +@DIKLK:10 K:'$T DIKLK diff --git a/r/DSS_EXTRACTS-ECX/ECX8261.m b/r/DSS_EXTRACTS-ECX/ECX8261.m index bcdd1d48..c5e02dd3 100644 --- a/r/DSS_EXTRACTS-ECX/ECX8261.m +++ b/r/DSS_EXTRACTS-ECX/ECX8261.m @@ -1,4 +1,4 @@ -ECX8261 ; COMPILED XREF FOR FILE #727.826 ; 12/13/08 +ECX8261 ; COMPILED XREF FOR FILE #727.826 ; 12/25/06 ; S DIKZK=2 S DIKZ(0)=$G(^ECX(727.826,DA,0)) diff --git a/r/DSS_EXTRACTS-ECX/ECX8262.m b/r/DSS_EXTRACTS-ECX/ECX8262.m index bf45ed8a..67ae2df0 100644 --- a/r/DSS_EXTRACTS-ECX/ECX8262.m +++ b/r/DSS_EXTRACTS-ECX/ECX8262.m @@ -1,4 +1,4 @@ -ECX8262 ; COMPILED XREF FOR FILE #727.826 ; 12/13/08 +ECX8262 ; COMPILED XREF FOR FILE #727.826 ; 12/25/06 ; S DIKZK=1 S DIKZ(0)=$G(^ECX(727.826,DA,0)) diff --git a/r/DSS_EXTRACTS-ECX/ECX827.m b/r/DSS_EXTRACTS-ECX/ECX827.m index a5e20ff9..5c1b511e 100644 --- a/r/DSS_EXTRACTS-ECX/ECX827.m +++ b/r/DSS_EXTRACTS-ECX/ECX827.m @@ -1,4 +1,4 @@ -ECX827 ; DRIVER FOR COMPILED XREFS FOR FILE #727.827 ; 12/13/08 +ECX827 ; DRIVER FOR COMPILED XREFS FOR FILE #727.827 ; 12/27/07 ; N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2 I '$D(DIKSAT) S DIKLK=DIK_DA_")" L +@DIKLK:10 K:'$T DIKLK diff --git a/r/DSS_EXTRACTS-ECX/ECX8271.m b/r/DSS_EXTRACTS-ECX/ECX8271.m index 519a4beb..933ccee4 100644 --- a/r/DSS_EXTRACTS-ECX/ECX8271.m +++ b/r/DSS_EXTRACTS-ECX/ECX8271.m @@ -1,4 +1,4 @@ -ECX8271 ; COMPILED XREF FOR FILE #727.827 ; 12/13/08 +ECX8271 ; COMPILED XREF FOR FILE #727.827 ; 12/27/07 ; S DIKZK=2 S DIKZ(0)=$G(^ECX(727.827,DA,0)) diff --git a/r/DSS_EXTRACTS-ECX/ECX8272.m b/r/DSS_EXTRACTS-ECX/ECX8272.m index 711a3633..bf06bf5f 100644 --- a/r/DSS_EXTRACTS-ECX/ECX8272.m +++ b/r/DSS_EXTRACTS-ECX/ECX8272.m @@ -1,4 +1,4 @@ -ECX8272 ; COMPILED XREF FOR FILE #727.827 ; 12/13/08 +ECX8272 ; COMPILED XREF FOR FILE #727.827 ; 12/27/07 ; S DIKZK=1 S DIKZ(0)=$G(^ECX(727.827,DA,0)) diff --git a/r/DSS_EXTRACTS-ECX/ECXADM.m b/r/DSS_EXTRACTS-ECX/ECXADM.m index db5de5c1..62945512 100644 --- a/r/DSS_EXTRACTS-ECX/ECXADM.m +++ b/r/DSS_EXTRACTS-ECX/ECXADM.m @@ -1,203 +1,189 @@ -ECXADM ;ALB/JAP,BIR/DMA,CML,PTD-Admissions Extract ; 10/15/07 12:14pm - ;;3.0;DSS EXTRACTS;**1,4,11,8,13,24,33,39,46,71,84,92,107,105**;Dec 22, 1997;Build 70 -BEG ;entry point from option - D SETUP I ECFILE="" Q - D ^ECXTRAC,^ECXKILL - Q - ; -START ; start package specific extract - S QFLG=0 - S ECED=ECED+.3,ECD=ECSD1 - F S ECD=$O(^DGPM("ATT1",ECD)),ECDA=0 Q:('ECD)!(ECD>ECED) D - .F S ECDA=$O(^DGPM("ATT1",ECD,ECDA)) Q:ECDA="" D - ..I $D(^DGPM(ECDA,0)) D - ...S EC=^DGPM(ECDA,0),ECXDFN=$P(EC,U,3) D GET - Q - ; -GET ;gather extract data - N ADM,W,X,ECXNPRFI,ECXATTPC,ECXPRVPC,ECXEST - ;patient demographics - S ECXERR=0 D PAT(ECXDFN,ECD,.ECXERR) - Q:ECXERR - I $$ENROLLM^ECXUTL2(ECXDFN) - S ECXFAC=$P($G(^DIC(42,+$P(EC,U,6),0)),U,11) - S ECXPDIV=$$GETDIV^ECXDEPT(ECXFAC) ;Get production division - ;admission data - S ELGA=$P($G(^DIC(8,+$P(EC,U,20),0)),U,9) - I ELGA S ELGA=$$ELIG^ECXUTL3(ELGA,ECXSVC) - S (ECDRG,ECDIA,ECXSADM)="",ECPTF=+$P(EC,U,16) I ECPTF,$D(^DGPT(ECPTF,"M")) D PTF - ;get encounter classification - S (ECXAO,ECXECE,ECXIR,ECXMIL,ECXHNC)="",ECXVISIT=$P(EC,U,27) - I ECXVISIT'="" D - .D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) I ECXERR K ECXERR Q - .S ECXAO=$G(ECXVIST("AO")),ECXIR=$G(ECXVIST("IR")) - .S ECXMIL=$G(ECXVIST("MST")),ECXHNC=$G(ECXVIST("HNC")) - .S ECXECE=$G(ECXVIST("PGE")) - ;use movement record date & time - S ADM=$$INP^ECXUTL2(ECXDFN,ECD) - S ECXA=$P(ADM,U),ECXMN=$P(ADM,U,2),ECXSPC=$P(ADM,U,3) - S (ECXADMDT,ECXDATE)=$P(ADM,U,4) - ;if movement# doesn't match cross-ref ien, then quit - Q:ECXMN'=ECDA - S ECTM=$$ECXTIME^ECXUTL(ECXDATE) - S ECXDATE=$$ECXDATE^ECXUTL(ECXDATE,ECXYM) - S W=$P(ADM,U,9) - S ECXWRD=$P(W,";",1),ECXFAC=$P(W,";",2),ECXDSSD=$P(W,";",3) - S ECXPRV=$P(ADM,U,7),ECXPRNPI="",ECXATT=$P(ADM,U,8),ECXATNPI="" - S ECXDOM=$P(ADM,U,10),ECXATTPC=$P(ADM,U,12),ECXPRVPC=$P(ADM,U,11) - N ECXUSRTN - S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",$E(ECXATT,2,$L(ECXATT)),ECD) - S:+ECXUSRTN'>0 ECXUSRTN="" - S ECATTNPI=$P(ECXUSRTN,U) - S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",$E(ECXPRV,2,$L(ECXPRV)),ECD) - S:+ECXUSRTN'>0 ECXUSRTN="" - S ECPWNPI=$P(ECXUSRTN,U) - ; - ;- Observation patient indicator (YES/NO) - S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXSPC) - ; - ;- Patient Type - S ECXPTYPE=$$TYPE^ECXUTL5(ECXDFN) - ; - ;- If null encounter number, don't file record - S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,,ECXSPC,ECXOBS,ECHEAD,,) - D:ECXENC'="" FILE - Q - ; -PAT(ECXDFN,ECXDATE,ECXERR) ;get patient demographic data - N OK,X - K ECXPAT - S ECXDATE=$P(ECXDATE,".") - S OK=$$PAT^ECXUTL3(ECXDFN,ECXDATE,"1;2;3;4;5",.ECXPAT) - I 'OK S ECXERR=1 K ECXPAT Q - S ECXSSN=ECXPAT("SSN") - S ECXPNM=ECXPAT("NAME") - S ECXMPI=ECXPAT("MPI") - S ECXSEX=ECXPAT("SEX") - S ECXDOB=ECXPAT("DOB") - S ECXELIG=ECXPAT("ELIG") - S ECXVET=ECXPAT("VET") - S ECXVNS=ECXPAT("VIETNAM") - S ECXPOS=ECXPAT("POS") - S ECXMNS=ECXPAT("MEANS") - S ECXRACE=ECXPAT("RACE") - S ECXRELG=ECXPAT("RELIGION") - S ECXEMP=ECXPAT("EMPLOY") - S ECXMAR=ECXPAT("MARITAL") - S ECXPST=ECXPAT("POW STAT") - S ECXPLOC=ECXPAT("POW LOC") - S ECXRST=ECXPAT("IR STAT") - S ECXAST=ECXPAT("AO STAT") - S ECXMST=ECXPAT("MST STAT") - S ECXSTATE=ECXPAT("STATE") - S ECXCNTY=ECXPAT("COUNTY") - S ECXZIP=ECXPAT("ZIP") - S ECXENRL=ECXPAT("ENROLL LOC") - S ECXSVC=ECXPAT("SC%") - S ECXPHI=ECXPAT("PHI") - S ECXHI=+$$INSUR^IBBAPI(ECXDFN,ECXDATE) - S ECXEST=ECXPAT("EC STAT") - ; - ;-OEF/OIF Data - S ECXOEF=ECXPAT("ECXOEF") - S ECXOEFDT=ECXPAT("ECXOEFDT") - ; - ;- Agent Orange location - S ECXAOL=ECXPAT("AOL") - ; - ; - Head and Neck Cancer Indicator - S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) - ; - Race and Ethnicity - S ECXETH=ECXPAT("ETHNIC") - S ECXRC1=ECXPAT("RACE1") - ; - ;get primary care data - S X=$$PRIMARY^ECXUTL2(ECXDFN,ECXDATE) - S ECPTTM=$P(X,U),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4) - S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7) - ;get combat veteran data - I $$CVEDT^ECXUTL5(ECXDFN,ECD) - ;get national patient record flag if exist - D NPRF^ECXUTL5 - ;get emergency response indicator (FEMA) - S ECXERI=ECXPAT("ERI") - Q - ; -PTF ; get admitting DRG, diagnosis, source of admission from PTF - ;use number for DRG and .01 for diagnosis - N EC,EC1,ECX - S EC=1 I $D(^DGPT(ECPTF,"M",2,0)) S EC=2 - S EC1=+$P(^DGPT(ECPTF,"M",EC,0),U,5) - S ECDRG=$P($G(^DGPT(ECPTF,"M",EC,"P")),U) - S ECDIA=$P($G(^ICD9(EC1,0)),U) - S ECX=+$P($G(^DGPT(ECPTF,101)),U),ECXSADM=$P($G(^DIC(45.1,ECX,0)),U,11) - Q - ; -FILE ;file the extract record - ;node0 - ;facility^dfn^ssn^name^in/out^day^primary care team^sex^dob^ - ;religion^employment status^health ins^state^county^zip^ - ;eligibility^vet^vietnam^agent orange^radiation^pow^ - ;period of service^means test^marital status^ - ;ward^treating specialty^attending physician^mov #^DRG^diagnosis^ - ;time^primary care provider^race^primary ward provider - ;node1 - ;mpi^dss dept^attending npi^pc provider npi^ward provider npi^ - ;admission elig^mst status^^sharing payor^ - ;sharing insurance^enrollment location^ - ;pc prov person class^assoc pc provider^assoc pc prov person class^ - ;assoc pc prov npi^dom^enrollment cat^enrollment stat^enrollment - ;priority^purple heart ind.^obs pat ind^encounter num^agent orange - ;loc^production div^pow loc^source of admission^head & neck canc. ind - ;^ethnicity^race1^enrollment priority_sub group^user enrollee^patient - ;type^combat vet elig^combat vet elig end date^enc cv eligible^ - ;national patient record flag ECXNPRFI^att phy person class ECXATTPC - ;^primary ward provider person class ECXPRVPC^environ contamin ECXEST - ;^emergency response indicator(FEMA) ECXERI^agent orange indic ECXAO - ;^environ contam ECXECE^encoun head/neck ECXHNC^encoun MST ECXMIL^rad - ;encoun ECXIR^ OEF/OIF ECXOEF^ OEF/OIF return date ECXOEFDT - ;^associate pc provider npi ECASNPI^attending physician npi ECATNPI^ - ;primary care provider npi ECPTNPI^primary ward provider npi ECPWNPI - ; - ;Convert specialty to PTF Code - ; - N ECXDATA - S ECXDATA=$$TSDATA^DGACT(42.4,+ECXSPC,.ECXDATA) - S ECXSPC=$G(ECXDATA(7)) - ; - N DA,DIK - S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 - S ECODE=EC7_U_EC23_U_ECXFAC_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U_ECXDATE_U - S ECODE=ECODE_ECPTTM_U_ECXSEX_U_ECXDOB_U_ECXRELG_U - S ECODE=ECODE_ECXEMP_U_ECXHI_U_ECXSTATE_U_ECXCNTY_U_ECXZIP_U - S ECODE=ECODE_ECXELIG_U_ECXVET_U_ECXVNS_U_ECXAST_U_ECXRST_U_ECXPST_U - S ECODE=ECODE_ECXPOS_U_ECXMNS_U_ECXMAR_U - S ECODE=ECODE_ECXWRD_U_ECXSPC_U_ECXATT_U_ECDA_U_ECDRG_U_ECDIA_U - S ECODE=ECODE_ECTM_U_ECPTPR_U_ECXRACE_U_ECXPRV_U - S ECODE1=ECXMPI_U_ECXDSSD_U_""_U_""_U_""_U_ELGA_U - S ECODE1=ECODE1_ECXMST_U_U_U_U_ECXENRL_U_ECCLAS_U - S ECODE1=ECODE1_ECASPR_U_ECCLAS2_U_U_ECXDOM_U_ECXCAT_U - S ECODE1=ECODE1_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPHI_U_ECXOBS_U_ECXENC_U_ECXAOL_U - S ECODE1=ECODE1_ECXPDIV_U_ECXPLOC_U_ECXSADM_U_ECXHNCI_U_ECXETH_U - S ECODE1=ECODE1_ECXRC1 - I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI - I ECXLOGIC>2005 S ECODE1=ECODE1_U_ECXATTPC_U_ECXPRVPC_U_ECXEST - I ECXLOGIC>2006 S ECODE1=ECODE1_U_ECXERI_U_ECXAO_U_ECXECE_U_ECXHNC_U_ECXMIL_U_ECXIR_U - I ECXLOGIC>2007 S ECODE2=ECXOEF_U_ECXOEFDT_U_ECASNPI_U_ECATTNPI_U_ECPTNPI_U_ECPWNPI - S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,^ECX(ECFILE,EC7,2)=$G(ECODE2) - S ECRN=ECRN+1 - S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA - Q - ; -SETUP ;Set required input for ECXTRAC. - S ECHEAD="ADM" - D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) - Q - ; -LOCAL ; to extract nightly for local use not to be transmitted to TSI - ; should be queued with a 1D frequency - D SETUP,^ECXTLOCL,^ECXKILL Q - ; -QUE ; entry point for the background requeuing handled by ECXTAUTO - D SETUP,QUE^ECXTAUTO,^ECXKILL Q - ; +ECXADM ;ALB/JAP,BIR/DMA,CML,PTD-Admissions Extract ; 04/12/2007 + ;;3.0;DSS EXTRACTS;**1,4,11,8,13,24,33,39,46,71,84,92,107**;Dec 22, 1997;Build 9 +BEG ;entry point from option + D SETUP I ECFILE="" Q + D ^ECXTRAC,^ECXKILL + Q + ; +START ; start package specific extract + S QFLG=0 + S ECED=ECED+.3,ECD=ECSD1 + F S ECD=$O(^DGPM("ATT1",ECD)),ECDA=0 Q:('ECD)!(ECD>ECED) D + .F S ECDA=$O(^DGPM("ATT1",ECD,ECDA)) Q:ECDA="" D + ..I $D(^DGPM(ECDA,0)) D + ...S EC=^DGPM(ECDA,0),ECXDFN=$P(EC,U,3) D GET + Q + ; +GET ;gather extract data + N ADM,W,X,ECXNPRFI,ECXATTPC,ECXPRVPC,ECXEST + ;patient demographics + S ECXERR=0 D PAT(ECXDFN,ECD,.ECXERR) + Q:ECXERR + I $$ENROLLM^ECXUTL2(ECXDFN) + S ECXFAC=$P($G(^DIC(42,+$P(EC,U,6),0)),U,11) + S ECXPDIV=$$GETDIV^ECXDEPT(ECXFAC) ;Get production division + ;admission data + S ELGA=$P($G(^DIC(8,+$P(EC,U,20),0)),U,9) + I ELGA S ELGA=$$ELIG^ECXUTL3(ELGA,ECXSVC) + S (ECDRG,ECDIA,ECXSADM)="",ECPTF=+$P(EC,U,16) I ECPTF,$D(^DGPT(ECPTF,"M")) D PTF + ;get encounter classification + S (ECXAO,ECXECE,ECXIR,ECXMIL,ECXHNC)="",ECXVISIT=$P(EC,U,27) + I ECXVISIT'="" D + .D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) I ECXERR K ECXERR Q + .S ECXAO=$G(ECXVIST("AO")),ECXIR=$G(ECXVIST("IR")) + .S ECXMIL=$G(ECXVIST("MST")),ECXHNC=$G(ECXVIST("HNC")) + .S ECXECE=$G(ECXVIST("PGE")) + ;use movement record date & time + S ADM=$$INP^ECXUTL2(ECXDFN,ECD) + S ECXA=$P(ADM,U),ECXMN=$P(ADM,U,2),ECXSPC=$P(ADM,U,3) + S (ECXADMDT,ECXDATE)=$P(ADM,U,4) + ;if movement# doesn't match cross-ref ien, then quit + Q:ECXMN'=ECDA + S ECTM=$$ECXTIME^ECXUTL(ECXDATE) + S ECXDATE=$$ECXDATE^ECXUTL(ECXDATE,ECXYM) + S W=$P(ADM,U,9) + S ECXWRD=$P(W,";",1),ECXFAC=$P(W,";",2),ECXDSSD=$P(W,";",3) + S ECXPRV=$P(ADM,U,7),ECXPRNPI="",ECXATT=$P(ADM,U,8),ECXATNPI="" + S ECXDOM=$P(ADM,U,10),ECXATTPC=$P(ADM,U,12),ECXPRVPC=$P(ADM,U,11) + ; + ;- Observation patient indicator (YES/NO) + S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXSPC) + ; + ;- Patient Type + S ECXPTYPE=$$TYPE^ECXUTL5(ECXDFN) + ; + ;- If null encounter number, don't file record + S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,,ECXSPC,ECXOBS,ECHEAD,,) + D:ECXENC'="" FILE + Q + ; +PAT(ECXDFN,ECXDATE,ECXERR) ;get patient demographic data + N OK,X + K ECXPAT + S ECXDATE=$P(ECXDATE,".") + S OK=$$PAT^ECXUTL3(ECXDFN,ECXDATE,"1;2;3;4;5",.ECXPAT) + I 'OK S ECXERR=1 K ECXPAT Q + S ECXSSN=ECXPAT("SSN") + S ECXPNM=ECXPAT("NAME") + S ECXMPI=ECXPAT("MPI") + S ECXSEX=ECXPAT("SEX") + S ECXDOB=ECXPAT("DOB") + S ECXELIG=ECXPAT("ELIG") + S ECXVET=ECXPAT("VET") + S ECXVNS=ECXPAT("VIETNAM") + S ECXPOS=ECXPAT("POS") + S ECXMNS=ECXPAT("MEANS") + S ECXRACE=ECXPAT("RACE") + S ECXRELG=ECXPAT("RELIGION") + S ECXEMP=ECXPAT("EMPLOY") + S ECXMAR=ECXPAT("MARITAL") + S ECXPST=ECXPAT("POW STAT") + S ECXPLOC=ECXPAT("POW LOC") + S ECXRST=ECXPAT("IR STAT") + S ECXAST=ECXPAT("AO STAT") + S ECXMST=ECXPAT("MST STAT") + S ECXSTATE=ECXPAT("STATE") + S ECXCNTY=ECXPAT("COUNTY") + S ECXZIP=ECXPAT("ZIP") + S ECXENRL=ECXPAT("ENROLL LOC") + S ECXSVC=ECXPAT("SC%") + S ECXPHI=ECXPAT("PHI") + S ECXHI=+$$INSUR^IBBAPI(ECXDFN,ECXDATE) + S ECXEST=ECXPAT("EC STAT") + ; + ;- Agent Orange location + S ECXAOL=ECXPAT("AOL") + ; + ; - Head and Neck Cancer Indicator + S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) + ; - Race and Ethnicity + S ECXETH=ECXPAT("ETHNIC") + S ECXRC1=ECXPAT("RACE1") + ; + ;get primary care data + S X=$$PRIMARY^ECXUTL2(ECXDFN,ECXDATE) + S ECPTTM=$P(X,U),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4) + S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7) + ;get combat veteran data + I $$CVEDT^ECXUTL5(ECXDFN,ECD) + ;get national patient record flag if exist + D NPRF^ECXUTL5 + ;get emergency response indicator (FEMA) + S ECXERI=ECXPAT("ERI") + Q + ; +PTF ; get admitting DRG, diagnosis, source of admission from PTF + ;use number for DRG and .01 for diagnosis + N EC,EC1,ECX + S EC=1 I $D(^DGPT(ECPTF,"M",2,0)) S EC=2 + S EC1=+$P(^DGPT(ECPTF,"M",EC,0),U,5) + S ECDRG=$P($G(^DGPT(ECPTF,"M",EC,"P")),U) + S ECDIA=$P($G(^ICD9(EC1,0)),U) + S ECX=+$P($G(^DGPT(ECPTF,101)),U),ECXSADM=$P($G(^DIC(45.1,ECX,0)),U,11) + Q + ; +FILE ;file the extract record + ;node0 + ;facility^dfn^ssn^name^in/out^day^primary care team^sex^dob^ + ;religion^employment status^health ins^state^county^zip^ + ;eligibility^vet^vietnam^agent orange^radiation^pow^ + ;period of service^means test^marital status^ + ;ward^treating specialty^attending physician^mov #^DRG^diagnosis^ + ;time^primary care provider^race^primary ward provider + ;node1 + ;mpi^dss dept^attending npi^pc provider npi^ward provider npi^ + ;admission elig^mst status^^sharing payor^ + ;sharing insurance^enrollment location^ + ;pc prov person class^assoc pc provider^assoc pc prov person class^ + ;assoc pc prov npi^dom^enrollment cat^enrollment stat^enrollment + ;priority^purple heart ind.^obs pat ind^encounter num^agent orange + ;loc^production div^pow loc^source of admission^head & neck canc. ind + ;^ethnicity^race1^enrollment priority_sub group^user enrollee^patient + ;type^combat vet elig^combat vet elig end date^enc cv eligible^ + ;national patient record flag ECXNPRFI^att phy person class ECXATTPC + ;^primary ward provider person class ECXPRVPC^environ contamin ECXEST + ;^emergency response indicator(FEMA) ECXERI^agent orange indic ECXAO + ;^environ contam ECXECE^encoun head/neck ECXHNC^encoun MST ECXMIL^rad + ;encoun ECXIR + ; + ;Convert specialty to PTF Code + ; + N ECXDATA + S ECXDATA=$$TSDATA^DGACT(42.4,+ECXSPC,.ECXDATA) + S ECXSPC=$G(ECXDATA(7)) + ; + N DA,DIK + S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 + S ECODE=EC7_U_EC23_U_ECXFAC_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U_ECXDATE_U + S ECODE=ECODE_ECPTTM_U_ECXSEX_U_ECXDOB_U_ECXRELG_U + S ECODE=ECODE_ECXEMP_U_ECXHI_U_ECXSTATE_U_ECXCNTY_U_ECXZIP_U + S ECODE=ECODE_ECXELIG_U_ECXVET_U_ECXVNS_U_ECXAST_U_ECXRST_U_ECXPST_U + S ECODE=ECODE_ECXPOS_U_ECXMNS_U_ECXMAR_U + S ECODE=ECODE_ECXWRD_U_ECXSPC_U_ECXATT_U_ECDA_U_ECDRG_U_ECDIA_U + S ECODE=ECODE_ECTM_U_ECPTPR_U_ECXRACE_U_ECXPRV_U + S ECODE1=ECXMPI_U_ECXDSSD_U_ECXATNPI_U_ECPTNPI_U_ECXPRNPI_U_ELGA_U + S ECODE1=ECODE1_ECXMST_U_U_U_U_ECXENRL_U_ECCLAS_U + S ECODE1=ECODE1_ECASPR_U_ECCLAS2_U_ECASNPI_U_ECXDOM_U_ECXCAT_U + S ECODE1=ECODE1_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPHI_U_ECXOBS_U_ECXENC_U_ECXAOL_U + S ECODE1=ECODE1_ECXPDIV_U_ECXPLOC_U_ECXSADM_U_ECXHNCI_U_ECXETH_U + S ECODE1=ECODE1_ECXRC1 + I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI + I ECXLOGIC>2005 S ECODE1=ECODE1_U_ECXATTPC_U_ECXPRVPC_U_ECXEST + I ECXLOGIC>2006 S ECODE1=ECODE1_U_ECXERI_U_ECXAO_U_ECXECE_U_ECXHNC_U_ECXMIL_U_ECXIR + S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1 + S ECRN=ECRN+1 + S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA + Q + ; +SETUP ;Set required input for ECXTRAC. + S ECHEAD="ADM" + D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) + Q + ; +LOCAL ; to extract nightly for local use not to be transmitted to TSI + ; should be queued with a 1D frequency + D SETUP,^ECXTLOCL,^ECXKILL Q + ; +QUE ; entry point for the background requeuing handled by ECXTAUTO + D SETUP,QUE^ECXTAUTO,^ECXKILL Q + ; diff --git a/r/DSS_EXTRACTS-ECX/ECXAPHA2.m b/r/DSS_EXTRACTS-ECX/ECXAPHA2.m index 124d4688..7970231e 100644 --- a/r/DSS_EXTRACTS-ECX/ECXAPHA2.m +++ b/r/DSS_EXTRACTS-ECX/ECXAPHA2.m @@ -1,115 +1,106 @@ -ECXAPHA2 ;ALB/TMD-Pharmacy Extracts Unusual Volumes Report ; 10/18/07 2:10pm - ;;3.0;DSS EXTRACTS;**40,49,84,104,105**;Dec 22, 1997;Build 70 - ; -EN ; entry point - N COUNT,ECUNIT,LINE,ECDFN,ECD,ECDRG,ECDAY,ECDFN,ECQTY,ECUNIT,ECCOST,ECDS - K ^TMP($J) - S (COUNT,ECDS)=0,ECUNIT="" - S ECD=ECSD1,ECED=ECED+.3 - S LINE=$S(ECXOPT=1:"PRE",ECXOPT=2:"IVP",ECXOPT=3:"UDP",1:"EXIT") - D @LINE - Q - ; -PRE ; entry point for PRE data - N ECRFL,ECRX,ECREF,ECDATA,ECDATA1,ECPRC,IEN - K ^TMP($J,"ECXDSS") - ;call pharmacy api pso52ex - D EXTRACT^PSO52EX(ECD,ECED,"ECXDSS") - S ECREF="RF" - ;order thru fills and refills; refill values 0 thru 11 - ; Note: refill 0 = original fill - F S ECD=$O(^TMP($J,"ECXDSS","AL",ECD)),IEN=0 Q:'ECD Q:ECD>ECED Q:ECXERR F S IEN=$O(^(ECD,IEN)),ECRFL="" Q:'IEN Q:ECXERR F S ECRFL=$O(^(IEN,ECRFL)) Q:'ECRFL Q:ECXERR D PRE2 - ; - ;order thru partial fills - S ECD=ECSD1,ECREF="P" - F S ECD=$O(^TMP($J,"ECXDSS","AM",ECD)),IEN=0 Q:'ECD Q:ECD>ECED Q:ECXERR F S IEN=$O(^(ECD,IEN)),ECRFL="" Q:'IEN Q:ECXERR F S ECRFL=$O(^(IEN,ECRFL)) Q:'ECRFL Q:ECXERR D PRE2 - K ^TMP($J,"ECXDSS") - Q - ; -PRE2 ; get Prescription data - I (ECREF="RF")&(ECRFL) D - .S ECQTY=+^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,1) - .S ECDS=+^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,1.1) - .S ECPRC=^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,1.2) - I (ECREF="RF")&('ECRFL) D - .S ECQTY=+^TMP($J,"ECXDSS",IEN,7) - .S ECDS=+^TMP($J,"ECXDSS",IEN,8) - .S ECPRC=+^TMP($J,"ECXDSS",IEN,17) - I ECREF="P" D - .S ECQTY=+^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,.04) - .S ECDS=+^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,.041) - .S ECPRC=+^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,.042) - ;check to see if quantity>threshold - I ECQTY>ECTHLD D - .S ECDAY=ECD - .S ECDFN=$P(^TMP($J,"ECXDSS",IEN,2),U) - .S ECDRG=+$P(^TMP($J,"ECXDSS",IEN,6),U) - .S ECCOST=ECQTY*ECPRC - .D FILE Q:ECXERR - Q - ; -IVP ; entry point for IVP Data - N DFN,ON,DA,SA,ECCOUNT - F S ECD=$O(^ECX(728.113,"A",ECD)),DFN=0 Q:'ECD Q:ECD>ECED Q:ECXERR F S DFN=$O(^ECX(728.113,"A",ECD,DFN)),ON=0 Q:'DFN F S ON=$O(^ECX(728.113,"A",ECD,DFN,ON)),DA=0 Q:'ON K ^TMP($J,"A"),^("S") D Q:ECXERR - .F S DA=$O(^ECX(728.113,"A",ECD,DFN,ON,DA)) Q:'DA Q:ECXERR I $D(^ECX(728.113,DA,0)) S EC=^(0) Q:ECXERR D - ..S ECDRG=$P(EC,U,4) - ..S SA=$S($P(EC,U,8)]"":"A",$P(EC,U,9):"S",1:"") - ..; set up new record for first DA for this drug - ..I '$D(^TMP($J,SA,ECDRG)) D - ...S ECQTY=+$S(SA="A":+$P(EC,U,7),SA="S":+$P(EC,U,9),1:0) - ...S ECUNIT=$S(SA="A":$P(EC,U,8),SA="S":"ML",1:"") - ...S ECCOST=$P(EC,U,12),ECDFN=DFN - ...S ^TMP($J,SA,ECDRG)=ECUNIT_U_ECD_U_ECDFN_U_ECCOST_U_ECQTY - ...S ^(ECDRG,1)=0 - ..; add to qty (0,1, or -1) to total - ..S ^TMP($J,SA,ECDRG,1)=^TMP($J,SA,ECDRG,1)+$S($P(EC,U,6)=1:1,$P(EC,U,6)=4:0,1:-1) - .; looped thru all DAs for this order - now check for unusual volumes - .F SA="S","A" S ECDRG="" F S ECDRG=$O(^TMP($J,SA,ECDRG)) Q:ECDRG="" Q:ECXERR D - ..S ECQTY=$P(^TMP($J,SA,ECDRG),U,5),ECCOUNT=^(ECDRG,1) - ..S ECQTY=ECQTY*ECCOUNT - ..; check to see if quantity is outside of threshold range - ..I (ECQTY>ECTHLD)!(ECQTY<-ECTHLD) D - ...S ECUNIT=$P(^TMP($J,SA,ECDRG),U) - ...S ECDAY=$P(^(ECDRG),U,2) - ...S ECDFN=$P(^(ECDRG),U,3) - ...S ECCOST=$P(^(ECDRG),U,4)*ECCOUNT - ...D FILE Q:ECXERR - K ^TMP($J,"A"),^("S") - Q - ; -UDP ; entry point for UDP data - N ECXJ,ECDATA - F S ECD=$O(^ECX(728.904,"A",ECD)) Q:'ECD Q:ECD>ECED Q:ECXERR D - .S ECXJ=0 F S ECXJ=$O(^ECX(728.904,"A",ECD,ECXJ)) Q:'ECXJ Q:ECXERR I $D(^ECX(728.904,ECXJ,0)) D - ..S DATA=^ECX(728.904,ECXJ,0),ECQTY=$P(DATA,U,5) - ..;check to see if quantity>threshold - ..I ECQTY>ECTHLD D - ...S ECDFN=$P(DATA,U,2),ECDRG=$P(DATA,U,4),ECCOST=$P(DATA,U,8),ECDAY=ECD - ...D FILE Q:ECXERR - Q - ; -FILE ; put records in temp file to print later - N OK,ECXPAT,ECNAME,ECSSN,ECGNAME,ECNDC,ECPROD,ECFKEY,ECXPHA - ; get demographics - S OK=$$PAT^ECXUTL3(ECDFN,$P(ECD,"."),"1;",.ECXPAT) - I 'OK Q - S ECNAME=ECXPAT("NAME") - S ECSSN=ECXPAT("SSN") - S ECDAY=$E(ECDAY,4,5)_"/"_$E(ECDAY,6,7) - ; get drug file data - S ECXPHA="",ECXPHA=$$PHAAPI^ECXUTL5(ECDRG) - S ECGNAME=$P(ECXPHA,U) - S ECNDC=$P(ECXPHA,U,3) - S ECNDC=$$RJ^XLFSTR($P(ECNDC,"-"),6,0)_$$RJ^XLFSTR($P(ECNDC,"-",2),4,0)_$$RJ^XLFSTR($P(ECNDC,"-",3),2,0) - S ECNDC=$TR(ECNDC,"*",0) - S ECPROD=$P(ECXPHA,U,6) - S ECPROD=$$RJ^XLFSTR(ECPROD,5,0) - S ECFKEY=ECPROD_ECNDC - I ECXOPT'=2 S ECUNIT=$P(ECXPHA,U,8) - ; file - S ^TMP($J,ECFKEY,-ECQTY,ECDAY,ECSSN)=ECNAME_U_ECSSN_U_ECDAY_U_ECGNAME_U_ECFKEY_U_ECQTY_U_ECUNIT_U_"$"_$FNUMBER(ECCOST,",",2)_U_ECDS - S COUNT=COUNT+1 - I COUNT#100=0 I $$S^ZTLOAD S (ZSTOP,ECXERR)=1 - Q - ; -EXIT S ECXERR=1 Q +ECXAPHA2 ;ALB/TMD-Pharmacy Extracts Unusual Volumes Report ; 2/06/07 10:36am + ;;3.0;DSS EXTRACTS;**40,49,84,104**;Dec 22, 1997;Build 8 + ; +EN ; entry point + N COUNT,ECUNIT,LINE,ECDFN,ECD,ECDRG,ECDAY,ECDFN,ECQTY,ECUNIT,ECCOST,ECDS + K ^TMP($J) + S (COUNT,ECDS)=0,ECUNIT="" + S ECD=ECSD1,ECED=ECED+.3 + S LINE=$S(ECXOPT=1:"PRE",ECXOPT=2:"IVP",ECXOPT=3:"UDP",1:"EXIT") + D @LINE + Q + ; +PRE ; entry point for PRE data + ; order through fills, refills and partial refills + N ECRFL,ECRX,ECREF,ECDATA,ECDATA1,ECPRC + S ECREF=1 + F S ECD=$O(^PSRX("AL",ECD)),ECRX=0 Q:'ECD Q:ECD>ECED Q:ECXERR F S ECRX=$O(^PSRX("AL",ECD,ECRX)),ECRFL="" Q:'ECRX Q:ECXERR F S ECRFL=$O(^PSRX("AL",ECD,ECRX,ECRFL)) Q:ECRFL="" Q:ECXERR D PRE2 + S ECD=ECSD1,ECREF="P" + F S ECD=$O(^PSRX("AM",ECD)),ECRX=0 Q:'ECD Q:ECD>ECED Q:ECXERR F S ECRX=$O(^PSRX("AM",ECD,ECRX)),ECRFL="" Q:'ECRX F S ECRFL=$O(^PSRX("AM",ECD,ECRX,ECRFL)) Q:ECRFL="" Q:ECXERR D PRE2 + Q + ; +PRE2 ; get Prescription data + S ECDATA=$G(^PSRX(ECRX,0)) + I ECRFL D + .S ECDATA1=$G(^PSRX(ECRX,ECREF,ECRFL,0)) + .S ECQTY=+$P(ECDATA1,U,4) + .S ECDS=+$P(ECDATA1,U,10) + .S ECPRC=+$P(ECDATA1,U,11) + I 'ECRFL D + .S ECQTY=+$P(ECDATA,U,7) + .S ECDS=+$P(ECDATA,U,8) + .S ECPRC=+$P(ECDATA,U,17) + ;check to see if quantity>threshold + I ECQTY>ECTHLD D + .S ECDAY=ECD + .S ECDFN=$P(ECDATA,U,2) + .S ECDRG=+$P(ECDATA,U,6) + .S ECCOST=ECQTY*ECPRC + .D FILE Q:ECXERR + Q + ; +IVP ; entry point for IVP Data + N DFN,ON,DA,SA,ECCOUNT + F S ECD=$O(^ECX(728.113,"A",ECD)),DFN=0 Q:'ECD Q:ECD>ECED Q:ECXERR F S DFN=$O(^ECX(728.113,"A",ECD,DFN)),ON=0 Q:'DFN F S ON=$O(^ECX(728.113,"A",ECD,DFN,ON)),DA=0 Q:'ON K ^TMP($J,"A"),^("S") D Q:ECXERR + .F S DA=$O(^ECX(728.113,"A",ECD,DFN,ON,DA)) Q:'DA Q:ECXERR I $D(^ECX(728.113,DA,0)) S EC=^(0) Q:ECXERR D + ..S ECDRG=$P(EC,U,4) + ..S SA=$S($P(EC,U,8)]"":"A",$P(EC,U,9):"S",1:"") + ..; set up new record for first DA for this drug + ..I '$D(^TMP($J,SA,ECDRG)) D + ...S ECQTY=+$S(SA="A":+$P(EC,U,7),SA="S":+$P(EC,U,9),1:0) + ...S ECUNIT=$S(SA="A":$P(EC,U,8),SA="S":"ML",1:"") + ...S ECCOST=$P(EC,U,12),ECDFN=DFN + ...S ^TMP($J,SA,ECDRG)=ECUNIT_U_ECD_U_ECDFN_U_ECCOST_U_ECQTY + ...S ^(ECDRG,1)=0 + ..; add to qty (0,1, or -1) to total + ..S ^TMP($J,SA,ECDRG,1)=^TMP($J,SA,ECDRG,1)+$S($P(EC,U,6)=1:1,$P(EC,U,6)=4:0,1:-1) + .; looped thru all DAs for this order - now check for unusual volumes + .F SA="S","A" S ECDRG="" F S ECDRG=$O(^TMP($J,SA,ECDRG)) Q:ECDRG="" Q:ECXERR D + ..S ECQTY=$P(^TMP($J,SA,ECDRG),U,5),ECCOUNT=^(ECDRG,1) + ..S ECQTY=ECQTY*ECCOUNT + ..; check to see if quantity is outside of threshold range + ..I (ECQTY>ECTHLD)!(ECQTY<-ECTHLD) D + ...S ECUNIT=$P(^TMP($J,SA,ECDRG),U) + ...S ECDAY=$P(^(ECDRG),U,2) + ...S ECDFN=$P(^(ECDRG),U,3) + ...S ECCOST=$P(^(ECDRG),U,4)*ECCOUNT + ...D FILE Q:ECXERR + K ^TMP($J,"A"),^("S") + Q + ; +UDP ; entry point for UDP data + N ECXJ,ECDATA + F S ECD=$O(^ECX(728.904,"A",ECD)) Q:'ECD Q:ECD>ECED Q:ECXERR D + .S ECXJ=0 F S ECXJ=$O(^ECX(728.904,"A",ECD,ECXJ)) Q:'ECXJ Q:ECXERR I $D(^ECX(728.904,ECXJ,0)) D + ..S DATA=^ECX(728.904,ECXJ,0),ECQTY=$P(DATA,U,5) + ..;check to see if quantity>threshold + ..I ECQTY>ECTHLD D + ...S ECDFN=$P(DATA,U,2),ECDRG=$P(DATA,U,4),ECCOST=$P(DATA,U,8),ECDAY=ECD + ...D FILE Q:ECXERR + Q + ; +FILE ; put records in temp file to print later + N OK,ECXPAT,ECNAME,ECSSN,ECGNAME,ECNDC,ECPROD,ECFKEY,ECXPHA + ; get demographics + S OK=$$PAT^ECXUTL3(ECDFN,$P(ECD,"."),"1;",.ECXPAT) + I 'OK Q + S ECNAME=ECXPAT("NAME") + S ECSSN=ECXPAT("SSN") + S ECDAY=$E(ECDAY,4,5)_"/"_$E(ECDAY,6,7) + ; get drug file data + S ECXPHA="",ECXPHA=$$PHAAPI^ECXUTL5(ECDRG) + S ECGNAME=$P(ECXPHA,U) + S ECNDC=$P(ECXPHA,U,3) + S ECNDC=$$RJ^XLFSTR($P(ECNDC,"-"),6,0)_$$RJ^XLFSTR($P(ECNDC,"-",2),4,0)_$$RJ^XLFSTR($P(ECNDC,"-",3),2,0) + S ECNDC=$TR(ECNDC,"*",0) + S ECPROD=$P(ECXPHA,U,6) + S ECPROD=$$RJ^XLFSTR(ECPROD,5,0) + S ECFKEY=ECPROD_ECNDC + I ECXOPT'=2 S ECUNIT=$P(ECXPHA,U,8) + ; file + S ^TMP($J,ECFKEY,-ECQTY,ECDAY,ECSSN)=ECNAME_U_ECSSN_U_ECDAY_U_ECGNAME_U_ECFKEY_U_ECQTY_U_ECUNIT_U_"$"_$FNUMBER(ECCOST,",",2)_U_ECDS + S COUNT=COUNT+1 + I COUNT#100=0 I $$S^ZTLOAD S (ZSTOP,ECXERR)=1 + Q + ; +EXIT S ECXERR=1 Q diff --git a/r/DSS_EXTRACTS-ECX/ECXATRT.m b/r/DSS_EXTRACTS-ECX/ECXATRT.m index 368bfc70..947bcf93 100644 --- a/r/DSS_EXTRACTS-ECX/ECXATRT.m +++ b/r/DSS_EXTRACTS-ECX/ECXATRT.m @@ -1,169 +1,169 @@ -ECXATRT ;ALB/JAP - TRT Extract Audit Report ;O4/12/2007 - ;;3.0;DSS EXTRACTS;**1,6,8,107,105**;Dec 22, 1997;Build 70 - ; -EN ;entry point for TRT extract audit report - N %X,%Y,X,Y,DIC,DA,DR,DIQ,DIR - S ECXERR=0 - ;ecxaud=0 for 'extract' audit - S ECXHEAD="TRT",ECXAUD=0 - W !!,"Setup for ",ECXHEAD," Extract Audit Report --",!! - ;select extract - D AUDIT^ECXUTLA(ECXHEAD,.ECXERR,.ECXARRAY,ECXAUD) - Q:ECXERR - ;currently, this extract does not capture divisional data - S ECXALL=1 - D TRT^ECXDVSN(.ECXDIV,ECXALL,.ECXERR) - I ECXERR=1 D Q - .W !!,?5,"Try again later... exiting.",! - .D AUDIT^ECXKILL - ;determine output device and queue if requested - W ! - S ECXPGM="PROCESS^ECXATRT",ECXDESC="TRT Extract Audit Report" - S ECXSAVE("ECXHEAD")="",ECXSAVE("ECXALL")="",ECXSAVE("ECXDIV(")="",ECXSAVE("ECXARRAY(")="" - W ! - D DEVICE^ECXUTLA(ECXPGM,ECXDESC,.ECXSAVE) - I ECXSAVE("POP")=1 D Q - .W !!,?5,"Try again later... exiting.",! - .D AUDIT^ECXKILL - I ECXSAVE("ZTSK")=0 D - .K ECXSAVE,ECXPGM,ECXDESC - .D PROCESS^ECXATRT - I IO'=IO(0) D ^%ZISC - D HOME^%ZIS - D AUDIT^ECXKILL - Q - ; -PROCESS ;process data in file #727.817 - N X,Y,W,DATA,DATE,DIV,IEN,TS,SPEC,FTS,FTSNM,SERV,ECX,QQFLG,CNT,A1,A2,NUM,MN,NEWFTS,NEWSPEC - K ^TMP($J,"ECXAUD"),^TMP($J,"ECXSPEC") - S (QQFLG,CNT)=0 - S ECXEXT=ECXARRAY("EXTRACT"),ECXDEF=ECXARRAY("DEF") - S X=ECXARRAY("START") D ^%DT S ECXSTART=Y S X=ECXARRAY("END") D ^%DT S ECXEND=Y - ;get run date in external format - D NOW^%DTC S Y=$E(%,1,12) D DD^%DT S ECXRUN=Y - ;set up the specialty array for site/division - I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q - S DIV="" F S DIV=$O(ECXDIV(DIV)) Q:DIV="" D - .S DIC="^DIC(42.4,",DR=".01;3",DIQ(0)="E",DIQ="ECX" - .S SPEC="" F S SPEC=$O(^DIC(42.4,"B",SPEC)) Q:SPEC="" S TS=$O(^(SPEC,0)) D - ..K ECX S DA=TS D EN^DIQ1 - ..S SPEC=$G(ECX(42.4,TS,.01,"E")),SERV=$G(ECX(42.4,TS,3,"E")) S:SERV="" SERV="Unknown" - ..S ^TMP($J,"ECXSPEC",DIV,TS)=0_U_SERV_U_SPEC,NUM(TS)=0 - ;set up the specialty to facility treating specialty conversion array; - ;determine if active between ecxstart and ecxend; - ;ignore if facility treating specialty not active within date range of report; - S DIC="^DIC(45.7,",DR=".01;1",DIQ(0)="I",DIQ="ECX" - S FTSNM="" F S FTSNM=$O(^DIC(45.7,"B",FTSNM)) Q:FTSNM="" S FTS=$O(^(FTSNM,0)) D - .K ECX S DA=FTS D EN^DIQ1 - .S FTSNM=$G(ECX(45.7,FTS,.01,"I")),TS=$G(ECX(45.7,FTS,1,"I")) - .Q:TS="" - .S A1=$$ACTIVE^DGACT(45.7,FTS,ECXSTART),A2=$$ACTIVE^DGACT(45.7,FTS,ECXEND) - .Q:A1=0&(A2=0) - .;num(ts) will hold the number of active facility treat. specialties (file #45.7) associated - .;with this national specialty (file #42.4). - .I '$D(NUM(TS)) S NUM(TS)=0 - .S ^TMP($J,"ECXTS",TS,FTS)=FTSNM,^TMP($J,"ECXREVTS",FTS)=TS,NUM(TS)=NUM(TS)+1 - ;get extract records in date range - S IEN="" F S IEN=$O(^ECX(727.817,"AC",ECXEXT,IEN)) Q:IEN="" D Q:QQFLG - .S DATA=^ECX(727.817,IEN,0),DATE=$P(DATA,U,9),DIV=$P(DATA,U,4) - .;currently the 4th piece of extract record is always null for trt - .S:DIV="" DIV=1 - .;convert free text date to fm internal format date - .S $E(DATE,1,2)=$E(DATE,1,2)-17 - .Q:$L(DATE)<7 Q:(DATEECXEND) - .I $D(ECXDIV(DIV)) D - ..;ts is the old specialty, newfts is the new facility treat. spec. for the movement date; - ..;after patch #1 'losing treating specialty los' field (#17) is non-null only for actual specialty changes; - ..;so should be able to distinguish true ts changes from provider-only changes; - ..;although it will still be possible that old and new specialty are the same, but facility - ..;treat. spec. was changed, but we've lost that info in the extract. - ..; - ..;filter out those records which are definitely provider-only changes; - ..;these are the records that have 'losing treating specialty los' which is null; - ..;but for extracts done prior to patch #1, still need to compare old & new specialty. - ..; - ..;convert 15th and 16th piece from PTF code back to Specialty - ..;ECX*3.0*107 - ..; - ..N ECXTS - ..S ECXTS=$P(DATA,U,15) I ECXTS'="" S ECXTS=$O(^DIC(42.4,"C",$G(ECXTS),0)),$P(DATA,U,15)=ECXTS - ..S ECXTS=$P(DATA,U,16) I ECXTS'="" S ECXTS=$O(^DIC(42.4,"C",$G(ECXTS),0)),$P(DATA,U,16)=ECXTS - ..S NEWTS=$P(DATA,U,15),TS=$P(DATA,U,16),LOS=$P(DATA,U,17) - ..;leaving this next line in here for v3.0 extracts done prior to patch #1 - ..Q:(NUM(+TS)=1)&(NEWTS=TS) - ..Q:LOS="" - ..S $P(^(TS),U,1)=$P(^TMP($J,"ECXSPEC",DIV,TS),U,1)+1,CNT=CNT+1 - ..I $D(ZTQUEUED),(CNT>499),'(CNT#500),$$S^%ZTLOAD S QQFLG=1,ZTSTOP=1 K ZTREQ - ;after all extract records processed, arrange by service and specialty; - ;total can only be associated with specialty, not facility treating specialty; - ;include specialty only if total loss is non-zero - I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q - S DIV="" F S DIV=$O(ECXDIV(DIV)) Q:DIV="" I $D(^TMP($J,"ECXSPEC",DIV)) D - .S TS="" F S TS=$O(^TMP($J,"ECXSPEC",DIV,TS)) Q:TS="" D - ..S TOT=+$P(^TMP($J,"ECXSPEC",DIV,TS),U,1) I TOT>0 D - ...S SERV=$P(^(TS),U,2),SPEC=$P(^(TS),U,3) - ...S ^TMP($J,"ECXAUD",DIV,SERV,SPEC)=TOT_U_TS - ;print the report - D PRINT - D AUDIT^ECXKILL - Q - ; -PRINT ;print trt data by site, by service, by specialty - N JJ,SS,LN,P,DIV,DIVNM,GTOT,SVCTOT,PG,QFLG,DIR,DIRUT,DTOUT,DUOUT - U IO - I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q - S (QFLG,PG)=0,$P(LN,"-",80)="" - ;division associated with the treat. spec. change is not actually known; division is dss site - S DIV="" S DIV=$O(ECXDIV(DIV)) Q:DIV="" S GTOT=0 - D HEADER - I '$D(^TMP($J,"ECXAUD",DIV)) D Q - .W !!,?5,"No data available for this DSS Site.",!! - I $D(^TMP($J,"ECXAUD",DIV)) S SERV="" F S SERV=$O(^TMP($J,"ECXAUD",DIV,SERV)) Q:SERV="" D Q:QFLG - .S SVCTOT=0 - .;write the service name - .D:($Y+3>IOSL) HEADER Q:QFLG W !,SERV - .S SPEC="" F S SPEC=$O(^TMP($J,"ECXAUD",DIV,SERV,SPEC)) Q:SPEC="" D Q:QFLG - ..;write the specialty name and total - ..S TOT=$P(^TMP($J,"ECXAUD",DIV,SERV,SPEC),U,1),TS=$P(^(SPEC),U,2) - ..W ?22,$E(SPEC,1,30)_" ("_TS_")",?68,$$RJ^XLFSTR(TOT,5," "),! - ..S SVCTOT=SVCTOT+TOT,GTOT=GTOT+TOT - ..S FTS="" F S FTS=$O(^TMP($J,"ECXTS",TS,FTS)) Q:FTS="" D Q:QFLG - ...S FTSNM=^TMP($J,"ECXTS",TS,FTS) - ...D:($Y+3>IOSL) HEADER Q:QFLG W ?25,$E(FTSNM,1,30),! - .;write the service subtotal - .Q:QFLG - .W ?22,$E(LN,1,54),! - .D:($Y+3>IOSL) HEADER Q:QFLG W "Total for "_SERV_":",?68,$$RJ^XLFSTR(SVCTOT,5," "),! - ;write the grandtotal for all services at facility - D:($Y+3>IOSL) HEADER Q:QFLG W !!,"Grand Total for all Services:",?68,$$RJ^XLFSTR(GTOT,5," ") - ;print the audit descriptive narrative - I $E(IOST)'="C" D - .W @IOF S PG=PG+1 - .W !,ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract Audit Report" - .W !,"DSS Extract Log #: "_ECXEXT - .W !,"Date Range of Audit: "_ECXARRAY("START")_" to "_ECXARRAY("END") - .W !,"Report Run Date/Time: "_ECXRUN,?68,"Page: ",PG - .W !!,LN,!! - .S DIC="^ECX(727.1,",DA=ECXARRAY("DEF"),DR="1" D EN^DIQ - I $E(IOST)="C",'QFLG D - .S SS=22-$Y F JJ=1:1:SS W ! - .S DIR(0)="E" W ! D ^DIR K DIR - Q - ; -HEADER ;header and page control - N JJ,SS - I $E(IOST)="C" D - .S SS=22-$Y F JJ=1:1:SS W ! - .I PG>0 S DIR(0)="E" W ! D ^DIR K DIR S:'Y QFLG=1 - Q:QFLG - W:$Y!($E(IOST)="C") @IOF S PG=PG+1 - ;W !,ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract Audit Report" - W !,"Treating Specialty Change"_" ("_ECXHEAD_") Extract Audit Report" - W !,"DSS Extract Log #: "_ECXARRAY("EXTRACT") - W !,"Date Range of Audit: "_ECXARRAY("START")_" to "_ECXARRAY("END") - W !,"Report Run Date/Time: "_ECXRUN - W !,"DSS Site: "_$P(ECXDIV(DIV),U,2)_" ("_$P(ECXDIV(DIV),U,3)_")",?68,"Page: "_PG - W !!,"Service",?22,"Specialty (DSS Code)",?68,"# of Losses" - W !,?25,"Facility Treating Specialty" - W !,LN,! - Q +ECXATRT ;ALB/JAP - TRT Extract Audit Report ;O4/12/2007 + ;;3.0;DSS EXTRACTS;**1,6,8,107**;Dec 22, 1997;Build 9 + ; +EN ;entry point for TRT extract audit report + N %X,%Y,X,Y,DIC,DA,DR,DIQ,DIR + S ECXERR=0 + ;ecxaud=0 for 'extract' audit + S ECXHEAD="TRT",ECXAUD=0 + W !!,"Setup for ",ECXHEAD," Extract Audit Report --",!! + ;select extract + D AUDIT^ECXUTLA(ECXHEAD,.ECXERR,.ECXARRAY,ECXAUD) + Q:ECXERR + ;currently, this extract does not capture divisional data + S ECXALL=1 + D TRT^ECXDVSN(.ECXDIV,ECXALL,.ECXERR) + I ECXERR=1 D Q + .W !!,?5,"Try again later... exiting.",! + .D AUDIT^ECXKILL + ;determine output device and queue if requested + W ! + S ECXPGM="PROCESS^ECXATRT",ECXDESC="TRT Extract Audit Report" + S ECXSAVE("ECXHEAD")="",ECXSAVE("ECXALL")="",ECXSAVE("ECXDIV(")="",ECXSAVE("ECXARRAY(")="" + W ! + D DEVICE^ECXUTLA(ECXPGM,ECXDESC,.ECXSAVE) + I ECXSAVE("POP")=1 D Q + .W !!,?5,"Try again later... exiting.",! + .D AUDIT^ECXKILL + I ECXSAVE("ZTSK")=0 D + .K ECXSAVE,ECXPGM,ECXDESC + .D PROCESS^ECXATRT + I IO'=IO(0) D ^%ZISC + D HOME^%ZIS + D AUDIT^ECXKILL + Q + ; +PROCESS ;process data in file #727.817 + N X,Y,W,DATA,DATE,DIV,IEN,TS,SPEC,FTS,FTSNM,SERV,ECX,QQFLG,CNT,A1,A2,NUM,MN,NEWFTS,NEWSPEC + K ^TMP($J,"ECXAUD"),^TMP($J,"ECXSPEC") + S (QQFLG,CNT)=0 + S ECXEXT=ECXARRAY("EXTRACT"),ECXDEF=ECXARRAY("DEF") + S X=ECXARRAY("START") D ^%DT S ECXSTART=Y S X=ECXARRAY("END") D ^%DT S ECXEND=Y + ;get run date in external format + D NOW^%DTC S Y=$E(%,1,12) D DD^%DT S ECXRUN=Y + ;set up the specialty array for site/division + I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q + S DIV="" F S DIV=$O(ECXDIV(DIV)) Q:DIV="" D + .S DIC="^DIC(42.4,",DR=".01;3",DIQ(0)="E",DIQ="ECX" + .S SPEC="" F S SPEC=$O(^DIC(42.4,"B",SPEC)) Q:SPEC="" S TS=$O(^(SPEC,0)) D + ..K ECX S DA=TS D EN^DIQ1 + ..S SPEC=$G(ECX(42.4,TS,.01,"E")),SERV=$G(ECX(42.4,TS,3,"E")) S:SERV="" SERV="Unknown" + ..S ^TMP($J,"ECXSPEC",DIV,TS)=0_U_SERV_U_SPEC,NUM(TS)=0 + ;set up the specialty to facility treating specialty conversion array; + ;determine if active between ecxstart and ecxend; + ;ignore if facility treating specialty not active within date range of report; + S DIC="^DIC(45.7,",DR=".01;1",DIQ(0)="I",DIQ="ECX" + S FTSNM="" F S FTSNM=$O(^DIC(45.7,"B",FTSNM)) Q:FTSNM="" S FTS=$O(^(FTSNM,0)) D + .K ECX S DA=FTS D EN^DIQ1 + .S FTSNM=$G(ECX(45.7,FTS,.01,"I")),TS=$G(ECX(45.7,FTS,1,"I")) + .Q:TS="" + .S A1=$$ACTIVE^DGACT(45.7,FTS,ECXSTART),A2=$$ACTIVE^DGACT(45.7,FTS,ECXEND) + .Q:A1=0&(A2=0) + .;num(ts) will hold the number of active facility treat. specialties (file #45.7) associated + .;with this national specialty (file #42.4). + .I '$D(NUM(TS)) S NUM(TS)=0 + .S ^TMP($J,"ECXTS",TS,FTS)=FTSNM,^TMP($J,"ECXREVTS",FTS)=TS,NUM(TS)=NUM(TS)+1 + ;get extract records in date range + S IEN="" F S IEN=$O(^ECX(727.817,"AC",ECXEXT,IEN)) Q:IEN="" D Q:QQFLG + .S DATA=^ECX(727.817,IEN,0),DATE=$P(DATA,U,9),DIV=$P(DATA,U,4) + .;currently the 4th piece of extract record is always null for trt + .S:DIV="" DIV=1 + .;convert free text date to fm internal format date + .S $E(DATE,1,2)=$E(DATE,1,2)-17 + .Q:$L(DATE)<7 Q:(DATEECXEND) + .I $D(ECXDIV(DIV)) D + ..;ts is the old specialty, newfts is the new facility treat. spec. for the movement date; + ..;after patch #1 'losing treating specialty los' field (#17) is non-null only for actual specialty changes; + ..;so should be able to distinguish true ts changes from provider-only changes; + ..;although it will still be possible that old and new specialty are the same, but facility + ..;treat. spec. was changed, but we've lost that info in the extract. + ..; + ..;filter out those records which are definitely provider-only changes; + ..;these are the records that have 'losing treating specialty los' which is null; + ..;but for extracts done prior to patch #1, still need to compare old & new specialty. + ..; + ..;convert 15th and 16th piece from PTF code back to Specialty + ..;ECX*3.0*107 + ..; + ..N ECXTS + ..S ECXTS=$P(DATA,U,15),ECXTS=$O(^DIC(42.4,$G(ECXTS),"C",$P(DATA,U,15),0)),$P(DATA,U,15)=ECXTS + ..S ECXTS=$P(DATA,U,16),ECXTS=$O(^DIC(42.4,$G(ECXTS),"C",$P(DATA,U,16),0)),$P(DATA,U,16)=ECXTS + ..S NEWTS=$P(DATA,U,15),TS=$P(DATA,U,16),LOS=$P(DATA,U,17) + ..;leaving this next line in here for v3.0 extracts done prior to patch #1 + ..Q:(NUM(TS)=1)&(NEWTS=TS) + ..Q:LOS="" + ..S $P(^(TS),U,1)=$P(^TMP($J,"ECXSPEC",DIV,TS),U,1)+1,CNT=CNT+1 + ..I $D(ZTQUEUED),(CNT>499),'(CNT#500),$$S^%ZTLOAD S QQFLG=1,ZTSTOP=1 K ZTREQ + ;after all extract records processed, arrange by service and specialty; + ;total can only be associated with specialty, not facility treating specialty; + ;include specialty only if total loss is non-zero + I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q + S DIV="" F S DIV=$O(ECXDIV(DIV)) Q:DIV="" I $D(^TMP($J,"ECXSPEC",DIV)) D + .S TS="" F S TS=$O(^TMP($J,"ECXSPEC",DIV,TS)) Q:TS="" D + ..S TOT=+$P(^TMP($J,"ECXSPEC",DIV,TS),U,1) I TOT>0 D + ...S SERV=$P(^(TS),U,2),SPEC=$P(^(TS),U,3) + ...S ^TMP($J,"ECXAUD",DIV,SERV,SPEC)=TOT_U_TS + ;print the report + D PRINT + D AUDIT^ECXKILL + Q + ; +PRINT ;print trt data by site, by service, by specialty + N JJ,SS,LN,P,DIV,DIVNM,GTOT,SVCTOT,PG,QFLG,DIR,DIRUT,DTOUT,DUOUT + U IO + I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q + S (QFLG,PG)=0,$P(LN,"-",80)="" + ;division associated with the treat. spec. change is not actually known; division is dss site + S DIV="" S DIV=$O(ECXDIV(DIV)) Q:DIV="" S GTOT=0 + D HEADER + I '$D(^TMP($J,"ECXAUD",DIV)) D Q + .W !!,?5,"No data available for this DSS Site.",!! + I $D(^TMP($J,"ECXAUD",DIV)) S SERV="" F S SERV=$O(^TMP($J,"ECXAUD",DIV,SERV)) Q:SERV="" D Q:QFLG + .S SVCTOT=0 + .;write the service name + .D:($Y+3>IOSL) HEADER Q:QFLG W !,SERV + .S SPEC="" F S SPEC=$O(^TMP($J,"ECXAUD",DIV,SERV,SPEC)) Q:SPEC="" D Q:QFLG + ..;write the specialty name and total + ..S TOT=$P(^TMP($J,"ECXAUD",DIV,SERV,SPEC),U,1),TS=$P(^(SPEC),U,2) + ..W ?22,$E(SPEC,1,30)_" ("_TS_")",?68,$$RJ^XLFSTR(TOT,5," "),! + ..S SVCTOT=SVCTOT+TOT,GTOT=GTOT+TOT + ..S FTS="" F S FTS=$O(^TMP($J,"ECXTS",TS,FTS)) Q:FTS="" D Q:QFLG + ...S FTSNM=^TMP($J,"ECXTS",TS,FTS) + ...D:($Y+3>IOSL) HEADER Q:QFLG W ?25,$E(FTSNM,1,30),! + .;write the service subtotal + .Q:QFLG + .W ?22,$E(LN,1,54),! + .D:($Y+3>IOSL) HEADER Q:QFLG W "Total for "_SERV_":",?68,$$RJ^XLFSTR(SVCTOT,5," "),! + ;write the grandtotal for all services at facility + D:($Y+3>IOSL) HEADER Q:QFLG W !!,"Grand Total for all Services:",?68,$$RJ^XLFSTR(GTOT,5," ") + ;print the audit descriptive narrative + I $E(IOST)'="C" D + .W @IOF S PG=PG+1 + .W !,ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract Audit Report" + .W !,"DSS Extract Log #: "_ECXEXT + .W !,"Date Range of Audit: "_ECXARRAY("START")_" to "_ECXARRAY("END") + .W !,"Report Run Date/Time: "_ECXRUN,?68,"Page: ",PG + .W !!,LN,!! + .S DIC="^ECX(727.1,",DA=ECXARRAY("DEF"),DR="1" D EN^DIQ + I $E(IOST)="C",'QFLG D + .S SS=22-$Y F JJ=1:1:SS W ! + .S DIR(0)="E" W ! D ^DIR K DIR + Q + ; +HEADER ;header and page control + N JJ,SS + I $E(IOST)="C" D + .S SS=22-$Y F JJ=1:1:SS W ! + .I PG>0 S DIR(0)="E" W ! D ^DIR K DIR S:'Y QFLG=1 + Q:QFLG + W:$Y!($E(IOST)="C") @IOF S PG=PG+1 + ;W !,ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract Audit Report" + W !,"Treating Specialty Change"_" ("_ECXHEAD_") Extract Audit Report" + W !,"DSS Extract Log #: "_ECXARRAY("EXTRACT") + W !,"Date Range of Audit: "_ECXARRAY("START")_" to "_ECXARRAY("END") + W !,"Report Run Date/Time: "_ECXRUN + W !,"DSS Site: "_$P(ECXDIV(DIV),U,2)_" ("_$P(ECXDIV(DIV),U,3)_")",?68,"Page: "_PG + W !!,"Service",?22,"Specialty (DSS Code)",?68,"# of Losses" + W !,?25,"Facility Treating Specialty" + W !,LN,! + Q diff --git a/r/DSS_EXTRACTS-ECX/ECXDIVIV.m b/r/DSS_EXTRACTS-ECX/ECXDIVIV.m index 49873b4c..eab7d64d 100644 --- a/r/DSS_EXTRACTS-ECX/ECXDIVIV.m +++ b/r/DSS_EXTRACTS-ECX/ECXDIVIV.m @@ -1,88 +1,84 @@ -ECXDIVIV ;BIR/CML-Enter/Edit and Print IV Room Division ; 3/13/07 10:48am - ;;3.0;DSS EXTRACTS;**8,105**;Dec 22, 1997;Build 70 - ; -ED ;enter/edit division field for iv rooms - N CHKFLG,DIC,DIE,DA,DR - W !!,"This option allows editing of the DIVISION field for IV Rooms.",! - S CHKFLG=0,OUT=0 - D CHK Q:CHKFLG - F D Q:OUT - .W ! S DIC=59.5,DIC(0)="QEAMZ" D ^DIC - .I Y<0 S OUT=1 Q - .I $G(^PS(59.5,+Y,"I"))]"" W " *INACTIVE*",$C(7) - .S DIE=DIC,DA=+Y - .S DR=.02 D ^DIE K DA - Q - ; -PRT ;print worksheet - W !!,"This option will produce a worksheet listing all entries in the IV Room file" - W !,"(#59.5). It should be used to help DSS and Pharmacy services define and" - W !,"review the DIVISION assignments for each IV Room.",!! S QFLG=0 - S QFLG=0,CHKFLG=0 - D CHK Q:CHKFLG - D EN^XUTMDEVQ("START^ECXDIVIV","DSS - IV Room List") - I POP D - .W !,"NO DEVICE SELECTED OR REPORT PRINTED!!" - .D PAUSE - K ^TMP($J,"ECXDSS") - Q - ; -START ;queued entry point - N CHKFLG,DIV,DIVNM,INACT,IV,IVRM,JJ,LN1,LN2,PDT,PG,QFLG,SS,X,Y - I '$D(DT) S DT=$$HTFM^XLFDT(+$H) - K ^TMP("ECXDIVIV",$J),^TMP($J,"ECXDSS") S QFLG=0,IV=0 - ;call pharmacy encapsulation api and return all iv rooms information - D ALL^PSJ59P5(,"??","ECXDSS") - F S IV=$O(^TMP($J,"ECXDSS",IV)) Q:'IV D - .S IVRM=$G(^TMP($J,"ECXDSS",IV,.01)),DIV=$P($G(^(.02)),U) - .S DIVNM=$S(DIV="":"ZZZ",1:$E($P(^DG(40.8,DIV,0),U),1,30)) - .K INACT I $P($G(^TMP($J,"ECXDSS",IV,19)),U)]"" S INACT=$P(^(19),U,2) - .S ^TMP("ECXDIVIV",$J,DIVNM,IVRM)=$S($D(INACT):INACT,1:"") - ;print report - S PG=0,PDT=$$FMTE^XLFDT(DT),$P(LN1,"-",81)="",$P(LN2,"_",30)="" - D HDR - I '$D(^TMP("ECXDIVIV",$J)) W !!,"No Data found for this worksheet." - I $D(^TMP("ECXDIVIV",$J)) S DIVNM="" D - .F S DIVNM=$O(^TMP("ECXDIVIV",$J,DIVNM)) Q:DIVNM="" Q:QFLG D - ..S IVRM="" - ..F S IVRM=$O(^TMP("ECXDIVIV",$J,DIVNM,IVRM)) Q:IVRM="" Q:QFLG D - ...S INACT=^TMP("ECXDIVIV",$J,DIVNM,IVRM) - ...D:$Y+4>IOSL HDR Q:QFLG - ...W !!,IVRM,?34,$S(DIVNM="ZZZ":LN2,1:DIVNM),?60,INACT - I $E(IOST)="C"&('QFLG) D PAUSE - K ^TMP("ECXDIVIV",$J) S:$D(ZTQUEUED) ZTREQ="@" - W:$E(IOST)'="C" @IOF - D ^%ZISC - Q - ; -HDR ;header - I $E(IOST)="C" S SS=22-$Y F JJ=1:1:SS W ! - I $E(IOST)="C",PG>0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 - Q:QFLG - S PG=PG+1 W:$Y!($E(IOST)="C") @IOF - W !,"IV Room Worksheet",?72,"Page: ",PG,!,"Printed ",PDT - W !!,"IV ROOM",?34,"DIVISION",?60,"INACTIVE DATE",!,LN1 - Q - ; -CHK ;check for existence of necessary files for division functionality - S CHKFLG=0 - D ALL^PSJ59P5(,"??","ECXIV") - I '$O(^TMP($J,"ECXIV",0)) D I CHKFLG D EXIT Q - .W !,"The IV Room file (#59.5) does not exist!" - .S CHKFLG=1 D PAUSE - I '$D(^ECX(728.113,0)) D I CHKFLG D EXIT Q - .W $C(7),!!,"Your facility appears to be running a version of Inpatient Medications prior to" - .W !,"version 4.5 which is necessary to use this option." - .S CHKFLG=1 D PAUSE - I '$D(^TMP($J,"ECXIV",$O(^TMP($J,"ECXIV",0)),.02)) D - .W $C(7),!!,"The Inpatient Medications Patch PSJ*4.5*27 has not yet been installed!" - .W !,"It must be loaded before you can proceed with this option." - .S CHKFLG=1 D PAUSE -EXIT K ^TMP($J,"ECXIV") - Q - ; -PAUSE ;pause screen - I $E(IOST)="C" D - .S SS=22-$Y F JJ=1:1:SS W ! - .S DIR(0)="E" W ! D ^DIR K DIR - Q +ECXDIVIV ;BIR/CML-Enter/Edit and Print IV Room Division ; [ 11/15/96 11:12 AM ] + ;;3.0;DSS EXTRACTS;**8**;Dec 22, 1997 + ; +ED ;enter/edit division field for iv rooms + N CHKFLG,DIC,DIE,DA,DR + W !!,"This option allows editing of the DIVISION field for IV Rooms.",! + S CHKFLG=0,OUT=0 + D CHK Q:CHKFLG + F D Q:OUT + .W ! S DIC=59.5,DIC(0)="QEAMZ" D ^DIC + .I Y<0 S OUT=1 Q + .I $G(^PS(59.5,+Y,"I"))]"" W " *INACTIVE*",$C(7) + .S DIE=DIC,DA=+Y + .S DR=.02 D ^DIE K DA + Q + ; +PRT ;print worksheet + W !!,"This option will produce a worksheet listing all entries in the IV Room file" + W !,"(#59.5). It should be used to help DSS and Pharmacy services define and" + W !,"review the DIVISION assignments for each IV Room.",!! S QFLG=0 + S QFLG=0,CHKFLG=0 + D CHK Q:CHKFLG + D EN^XUTMDEVQ("START^ECXDIVIV","DSS - IV Room List") + I POP D + .W !,"NO DEVICE SELECTED OR REPORT PRINTED!!" + .D PAUSE + Q + ; +START ;queued entry point + N CHKFLG,DIV,DIVNM,INACT,IV,IVRM,JJ,LN1,LN2,PDT,PG,QFLG,SS,X,Y + I '$D(DT) S DT=$$HTFM^XLFDT(+$H) + K ^TMP("ECXDIVIV",$J) S QFLG=0,IV=0 + F S IV=$O(^PS(59.5,IV)) Q:'IV I $D(^PS(59.5,IV,0)) D + .S IVRM=$E($P(^PS(59.5,IV,0),U),1,30),DIV=$P(^(0),U,4) + .S DIVNM=$S(DIV="":"ZZZ",1:$E($P(^DG(40.8,DIV,0),U),1,30)) + .K INACT I $P($G(^PS(59.5,IV,"I")),U)]"" S INACT=$$FMTE^XLFDT($P(^PS(59.5,IV,"I"),U),1) + .S ^TMP("ECXDIVIV",$J,DIVNM,IVRM)=$S($D(INACT):INACT,1:"") + ;print report + S PG=0,PDT=$$FMTE^XLFDT(DT),$P(LN1,"-",81)="",$P(LN2,"_",30)="" + D HDR + I '$D(^TMP("ECXDIVIV",$J)) W !!,"No Data found for this worksheet." + I $D(^TMP("ECXDIVIV",$J)) S DIVNM="" D + .F S DIVNM=$O(^TMP("ECXDIVIV",$J,DIVNM)) Q:DIVNM="" Q:QFLG D + ..S IVRM="" + ..F S IVRM=$O(^TMP("ECXDIVIV",$J,DIVNM,IVRM)) Q:IVRM="" Q:QFLG D + ...S INACT=^TMP("ECXDIVIV",$J,DIVNM,IVRM) + ...D:$Y+4>IOSL HDR Q:QFLG + ...W !!,IVRM,?34,$S(DIVNM="ZZZ":LN2,1:DIVNM),?60,INACT + I $E(IOST)="C"&('QFLG) D PAUSE + K ^TMP("ECXDIVIV",$J) S:$D(ZTQUEUED) ZTREQ="@" + W:$E(IOST)'="C" @IOF + D ^%ZISC + Q + ; +HDR ;header + I $E(IOST)="C" S SS=22-$Y F JJ=1:1:SS W ! + I $E(IOST)="C",PG>0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 + Q:QFLG + S PG=PG+1 W:$Y!($E(IOST)="C") @IOF + W !,"IV Room Worksheet",?72,"Page: ",PG,!,"Printed ",PDT + W !!,"IV ROOM",?34,"DIVISION",?60,"INACTIVE DATE",!,LN1 + Q + ; +CHK ;check for existence of necessary files for division functionality + S CHKFLG=0 + I '$O(^PS(59.5,0)) D Q:CHKFLG + .W !,"The IV Room file (#59.5) does not exist!" + .S CHKFLG=1 D PAUSE + I '$D(^ECX(728.113,0)) D Q:CHKFLG + .W $C(7),!!,"Your facility appears to be running a version of Inpatient Medications prior to" + .W !,"version 4.5 which is necessary to use this option." + .S CHKFLG=1 D PAUSE + K TEST1 D FIELD^DID(59.5,.02,"","TYPE","TEST1") + I '$D(TEST1) D + .W $C(7),!!,"The Inpatient Medications Patch PSJ*4.5*27 has not yet been installed!" + .W !,"It must be loaded before you can proceed with this option." + .S CHKFLG=1 D PAUSE + Q + ; +PAUSE ;pause screen + I $E(IOST)="C" D + .S SS=22-$Y F JJ=1:1:SS W ! + .S DIR(0)="E" W ! D ^DIR K DIR + Q diff --git a/r/DSS_EXTRACTS-ECX/ECXDRUG2.m b/r/DSS_EXTRACTS-ECX/ECXDRUG2.m index fd5e3afe..3c8363d1 100644 --- a/r/DSS_EXTRACTS-ECX/ECXDRUG2.m +++ b/r/DSS_EXTRACTS-ECX/ECXDRUG2.m @@ -1,100 +1,92 @@ -ECXDRUG2 ;ALB/TMD-Pharmacy Extracts Incomplete Feeder Key Report ; 2/19/08 3:44pm - ;;3.0;DSS EXTRACTS;**40,68,84,105,111**;Dec 22, 1997;Build 4 - ; -EN ; entry point - N ECD,LINE,ECDRG,ECQTY,ECPRC - K ^TMP($J) - S ECD=ECSD1,ECED=ECED+.3 - S LINE=$S(ECXOPT=1:"PRE",ECXOPT=2:"IVP",ECXOPT=3:"UDP",1:"EXIT") - D @LINE - Q - ; -PRE ; entry point for PRE data - ; order through fills, refills and partial refills - N ECRFL,ECRX,ECREF,ECDATA,ECDATA1 - K ^TMP($J,"ECXDSS") - ;call pharmacy api pso52ex - D EXTRACT^PSO52EX(ECD,ECED,"ECXDSS") - S ECREF="RF" - ;order thru fills and refills; refill values 0 thru 11 - ; Note: refill 0 = original fill - F S ECD=$O(^TMP($J,"ECXDSS","AL",ECD)),IEN=0 Q:'ECD Q:ECD>ECED Q:ECXERR F S IEN=$O(^(ECD,IEN)),ECRFL="" Q:'IEN Q:ECXERR F S ECRFL=$O(^(IEN,ECRFL)) Q:ECRFL']"" Q:ECXERR D PRE2 - ; - ;order thru partial fills - S ECD=ECSD1,ECREF="P" - F S ECD=$O(^TMP($J,"ECXDSS","AM",ECD)),IEN=0 Q:'ECD Q:ECD>ECED Q:ECXERR F S IEN=$O(^(ECD,IEN)),ECRFL="" Q:'IEN Q:ECXERR F S ECRFL=$O(^(IEN,ECRFL)) Q:'ECRFL Q:ECXERR D PRE2 - K ^TMP($J,"ECXDSS") - Q - ; -PRE2 ; get Prescription data - S ECDRG=+$P(^TMP($J,"ECXDSS",IEN,6),U) - I ECRFL>0&(ECREF="RF") D - .S ECQTY=^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,1),ECPRC=^(1.2) - I ECRFL>0&(ECREF="P") D - .S ECQTY=^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,.04),ECPRC=^(.042) - I 'ECRFL S ECQTY=^TMP($J,"ECXDSS",IEN,7),ECPRC=^(17) - D TEST - Q - ; -IVP ; entry point for IVP data - N ON,DFN,DA,SA - F S ECD=$O(^ECX(728.113,"A",ECD)),DFN=0 Q:'ECD Q:ECXERR Q:ECD>ECED F S DFN=$O(^ECX(728.113,"A",ECD,DFN)),ON=0 Q:'DFN Q:ECXERR F S ON=$O(^ECX(728.113,"A",ECD,DFN,ON)),DA=0 Q:'ON K ^TMP($J,"A"),^("S") D - .F S DA=$O(^ECX(728.113,"A",ECD,DFN,ON,DA)) Q:'DA I $D(^ECX(728.113,DA,0)) S EC=^(0) D - ..S ECDRG=$P(EC,U,4) - ..S SA=$S($P(EC,U,8)]"":"A",$P(EC,U,9):"S",1:"") - ..I SA'="" D - ...I '$D(^TMP($J,SA,ECDRG)) S ^(ECDRG)=0,$P(^(ECDRG),U,2)=$P(EC,U,12) - ...S $P(^TMP($J,SA,ECDRG),U)=$P(^TMP($J,SA,ECDRG),U)+$S($P(EC,U,6)=1:1,$P(EC,U,6)=4:0,1:-1) - .;looped thru all DAs for this order - now put it together - .F SA="S","A" S ECDRG="" F S ECDRG=$O(^TMP($J,SA,ECDRG)) Q:ECDRG="" D - ..S ECQTY=$P(^TMP($J,SA,ECDRG),U),ECPRC=$P(^(ECDRG),U,2) - ..D TEST - K ^TMP($J,"A"),^TMP($J,"S") - Q - ; -UDP ; entry point for UDP data - N ECXJ,ECDATA - F S ECD=$O(^ECX(728.904,"A",ECD)) Q:'ECD Q:ECD>ECED Q:ECXERR D - .S ECXJ=0 F S ECXJ=$O(^ECX(728.904,"A",ECD,ECXJ)) Q:'ECXJ Q:ECXERR I $D(^ECX(728.904,ECXJ,0)) D - ..S DATA=^ECX(728.904,ECXJ,0) - ..S ECDRG=$P(DATA,U,4),ECQTY=$P(DATA,U,5),ECCOST=$P(DATA,U,8) - ..S ECPRC=ECCOST/ECQTY - ..D TEST - Q - ; -TEST ; retrieve NDC and PSNDF VA Product Code Entry and test for missing NDC or VA Prod Code - N ECTYPE,ECNDC,ECZERO,K,ECPROD,ECFCHAR,ECSTOCK,ECXPHA - S ECTYPE=0,ECXPHA="" - ; call pharmacy drug file (#50) api via ecxutl5 - S ECXPHA=$$PHAAPI^ECXUTL5(ECDRG) - S ECNDC=$P(ECXPHA,U,3) - S ECNDC=$$RJ^XLFSTR($P(ECNDC,"-"),6,0)_$$RJ^XLFSTR($P(ECNDC,"-",2),4,0)_$$RJ^XLFSTR($P(ECNDC,"-",3),2,0),ECNDC=$TR(ECNDC,"*",0) - S ECZERO=1,ECSTOCK=0 F K=1:1:$L(ECNDC) D Q:'ECZERO!ECSTOCK - .S ECFCHAR=$E(ECNDC,K) - .I ECFCHAR="S" S ECSTOCK=1 Q - .I ECFCHAR'=0 S ECZERO=0 Q - I ECZERO!ECSTOCK!(ECNDC["N/A") S ECTYPE=2 - S ECPROD=$P(ECXPHA,U,6),ECPROD=$$RJ^XLFSTR(ECPROD,5,0) - I ECTYPE,'ECPROD S ECTYPE=3 - I 'ECTYPE,'ECPROD S ECTYPE=1 - I ECTYPE D FILE - Q - ; -FILE ; file record - N ECFKEY,ECGNAME,STATS,ECCOUNT,QTY,COST,ECCOST - ; create new record if none exists for this drug - I '$D(^TMP($J,ECDRG)) D - .S ECFKEY=ECPROD_ECNDC - .S ECGNAME=$P($G(^PSDRUG(ECDRG,0)),U) - .S ^TMP($J,ECDRG)=ECGNAME_U_ECFKEY_U_ECPRC_U_ECTYPE - .S ^TMP($J,ECDRG,0)="0^0^0" - ; add stats to record - S STATS=^TMP($J,ECDRG,0) - S ECCOUNT=$P(STATS,U),QTY=$P(STATS,U,2),COST=$P(STATS,U,3) - S ECCOUNT=ECCOUNT+1 - S ECCOST=ECQTY*ECPRC - S ECQTY=ECQTY+QTY,ECCOST=ECCOST+COST - S ^TMP($J,ECDRG,0)=ECCOUNT_U_ECQTY_U_ECCOST - Q - ; -EXIT S ECXERR=1 Q +ECXDRUG2 ;ALB/TMD-Pharmacy Extracts Incomplete Feeder Key Report ; 6/13/05 3:31pm + ;;3.0;DSS EXTRACTS;**40,68,84**;Dec 22, 1997 + ; +EN ; entry point + N ECD,LINE,ECDRG,ECQTY,ECPRC + K ^TMP($J) + S ECD=ECSD1,ECED=ECED+.3 + S LINE=$S(ECXOPT=1:"PRE",ECXOPT=2:"IVP",ECXOPT=3:"UDP",1:"EXIT") + D @LINE + Q + ; +PRE ; entry point for PRE data + ; order through fills, refills and partial refills + N ECRFL,ECRX,ECREF,ECDATA,ECDATA1 + S ECREF=1 + F S ECD=$O(^PSRX("AL",ECD)),ECRX=0 Q:'ECD Q:ECD>ECED Q:ECXERR F S ECRX=$O(^PSRX("AL",ECD,ECRX)),ECRFL="" Q:'ECRX F S ECRFL=$O(^PSRX("AL",ECD,ECRX,ECRFL)) Q:ECRFL="" Q:ECXERR D PRE2 + S ECD=ECSD1,ECREF="P" + F S ECD=$O(^PSRX("AM",ECD)),ECRX=0 Q:'ECD Q:ECD>ECED Q:ECXERR F S ECRX=$O(^PSRX("AM",ECD,ECRX)),ECRFL="" Q:'ECRX F S ECRFL=$O(^PSRX("AM",ECD,ECRX,ECRFL)) Q:ECRFL="" D PRE2 + Q + ; +PRE2 ; get Prescription data + S ECDATA=$G(^PSRX(ECRX,0)) + S ECDRG=+$P(ECDATA,U,6) + I ECRFL D + .S ECDATA1=$G(^PSRX(ECRX,ECREF,ECRFL,0)) + .S ECQTY=+$P(ECDATA1,U,4),ECPRC=+$P(ECDATA1,U,11) + I 'ECRFL S ECQTY=+$P(ECDATA,U,7),ECPRC=+$P(ECDATA,U,17) + D TEST + Q + ; +IVP ; entry point for IVP data + N ON,DFN,DA,SA + F S ECD=$O(^ECX(728.113,"A",ECD)),DFN=0 Q:'ECD Q:ECXERR Q:ECD>ECED F S DFN=$O(^ECX(728.113,"A",ECD,DFN)),ON=0 Q:'DFN Q:ECXERR F S ON=$O(^ECX(728.113,"A",ECD,DFN,ON)),DA=0 Q:'ON K ^TMP($J,"A"),^("S") D + .F S DA=$O(^ECX(728.113,"A",ECD,DFN,ON,DA)) Q:'DA I $D(^ECX(728.113,DA,0)) S EC=^(0) D + ..S ECDRG=$P(EC,U,4) + ..S SA=$S($P(EC,U,8)]"":"A",$P(EC,U,9):"S",1:"") + ..I SA'="" D + ...I '$D(^TMP($J,SA,ECDRG)) S ^(ECDRG)=0,$P(^(ECDRG),U,2)=$P(EC,U,12) + ...S $P(^TMP($J,SA,ECDRG),U)=$P(^TMP($J,SA,ECDRG),U)+$S($P(EC,U,6)=1:1,$P(EC,U,6)=4:0,1:-1) + .;looped thru all DAs for this order - now put it together + .F SA="S","A" S ECDRG="" F S ECDRG=$O(^TMP($J,SA,ECDRG)) Q:ECDRG="" D + ..S ECQTY=$P(^TMP($J,SA,ECDRG),U),ECPRC=$P(^(ECDRG),U,2) + ..D TEST + K ^TMP($J,"A"),^TMP($J,"S") + Q + ; +UDP ; entry point for UDP data + N ECXJ,ECDATA + F S ECD=$O(^ECX(728.904,"A",ECD)) Q:'ECD Q:ECD>ECED Q:ECXERR D + .S ECXJ=0 F S ECXJ=$O(^ECX(728.904,"A",ECD,ECXJ)) Q:'ECXJ Q:ECXERR I $D(^ECX(728.904,ECXJ,0)) D + ..S DATA=^ECX(728.904,ECXJ,0) + ..S ECDRG=$P(DATA,U,4),ECQTY=$P(DATA,U,5),ECCOST=$P(DATA,U,8) + ..S ECPRC=ECCOST/ECQTY + ..D TEST + Q + ; +TEST ; retrieve NDC and PSNDF VA Product Code Entry and test for missing NDC or VA Prod Code + N ECTYPE,ECNDC,ECZERO,K,ECPROD,ECFCHAR,ECSTOCK,ECXPHA + S ECTYPE=0,ECXPHA="" + ; call pharmacy drug file (#50) api via ecxutl5 + S ECXPHA=$$PHAAPI^ECXUTL5(ECDRG) + S ECNDC=$P(ECXPHA,U,3) + S ECNDC=$$RJ^XLFSTR($P(ECNDC,"-"),6,0)_$$RJ^XLFSTR($P(ECNDC,"-",2),4,0)_$$RJ^XLFSTR($P(ECNDC,"-",3),2,0),ECNDC=$TR(ECNDC,"*",0) + S ECZERO=1,ECSTOCK=0 F K=1:1:$L(ECNDC) D Q:'ECZERO!ECSTOCK + .S ECFCHAR=$E(ECNDC,K) + .I ECFCHAR="S" S ECSTOCK=1 Q + .I ECFCHAR'=0 S ECZERO=0 Q + I ECZERO!ECSTOCK!(ECNDC["N/A") S ECTYPE=2 + S ECPROD=$P(ECXPHA,U,6),ECPROD=$$RJ^XLFSTR(ECPROD,5,0) + I ECTYPE,'ECPROD S ECTYPE=3 + I 'ECTYPE,'ECPROD S ECTYPE=1 + I ECTYPE D FILE + Q + ; +FILE ; file record + N ECFKEY,ECGNAME,STATS,ECCOUNT,QTY,COST,ECCOST + ; create new record if none exists for this drug + I '$D(^TMP($J,ECDRG)) D + .S ECFKEY=ECPROD_ECNDC + .S ECGNAME=$P($G(^PSDRUG(ECDRG,0)),U) + .S ^TMP($J,ECDRG)=ECGNAME_U_ECFKEY_U_ECPRC_U_ECTYPE + .S ^TMP($J,ECDRG,0)="0^0^0" + ; add stats to record + S STATS=^TMP($J,ECDRG,0) + S ECCOUNT=$P(STATS,U),QTY=$P(STATS,U,2),COST=$P(STATS,U,3) + S ECCOUNT=ECCOUNT+1 + S ECCOST=ECQTY*ECPRC + S ECQTY=ECQTY+QTY,ECCOST=ECCOST+COST + S ^TMP($J,ECDRG,0)=ECCOUNT_U_ECQTY_U_ECCOST + Q + ; +EXIT S ECXERR=1 Q diff --git a/r/DSS_EXTRACTS-ECX/ECXDVSN.m b/r/DSS_EXTRACTS-ECX/ECXDVSN.m index b15a69bf..32d29035 100644 --- a/r/DSS_EXTRACTS-ECX/ECXDVSN.m +++ b/r/DSS_EXTRACTS-ECX/ECXDVSN.m @@ -1,228 +1,220 @@ -ECXDVSN ;ALB/JAP - Division selection utility ; 8/13/07 1:11pm - ;;3.0;DSS EXTRACTS;**8,105**;Dec 22, 1997;Build 70 -ADM(ECXDIV,ECXALL,ECXSTART,ECXEND,ECXERR) ;division information for ADM extract audit report - ;selected inpatient divisions from medical center division file (#40.8) - ; input - ; ECXDIV = array of inpatient divisions selected (required) - ; passed by reference array containing - ; selected divisions; - ; ECXALL = 1/0 (optional) - ; 1==> user wants all inpatient divisions OR - ; facility is non-divisional - ; 0==> user wants to select some divisions - ; if ECXALL not defined, then assume 1 - ; ECXSTART = start date of date range (optional) - ; ECXEND = end date of date range (optional) - ; ECXERR = passed by reference for error return (required) - ; output - ; ECXDIV = array of divisions selected from file #40.8; - ; if ECXALL=1, then array contains all divisions - ; if ECXALL=0, then array contains user-selected divisions - ; ECXDIV(ien in file #40.8) = ien in file #4^name^station number^primary indicator^active indicator^dss id - ; error CODE - ; ECXERR = 1, if input problem occurs - ; 0, otherwise - N OUT,DIC,X,Y,NM,ECXD,ECXIEN,ECXDIEN,ECXACT,ECXNAME,ECXNUM - S (OUT,ECXERR)=0 - ;if start date or end date missing, then both default to today - I '$G(ECXSTART)!('$G(ECXEND)) S (ECXSTART,ECXEND)=DT - S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1 - I ECXALL=1 D - .S NM="" F S NM=$O(^DG(40.8,"B",NM)) Q:NM="" S ECXIEN=$O(^(NM,"")) D - ..Q:+$P(^DG(40.8,ECXIEN,0),U,3)=1 - ..K Y S DIC="^DG(40.8,",DIC(0)="NZ",X=ECXIEN D ^DIC - ..Q:Y=-1 - ..S ECXNAME=$P(Y(0),U,1),ECXNUM=$P(Y(0),U,2),ECXDIEN=$P(Y(0),U,7) - ..S ECXDIV(ECXIEN)=ECXDIEN_U_ECXNAME_U_ECXNUM - ..D ACTDIV(ECXIEN,ECXSTART,ECXEND,.ECXD,.ECXACT) - ..S ECXDIV(ECXIEN)=ECXDIV(ECXIEN)_U_ECXD_U_ECXACT - ..I $D(^ECX(727.3,ECXIEN)) D - ...S ECXDIV(ECXIEN)=ECXDIV(ECXIEN)_U_$P($G(^ECX(727.3,ECXIEN,0)),U,2) - I ECXALL=0 F Q:OUT!ECXERR D - .K Y S DIC="^DG(40.8,",DIC(0)="AEMQZ",DIC("S")="I $P(^(0),U,3)'=1" - .D ^DIC I $G(DUOUT)!($G(DTOUT)) S OUT=1,ECXERR=1 Q - .I Y=-1,X="" S OUT=1 Q - .S ECXIEN=+Y,ECXNAME=$P(Y(0),U,1),ECXNUM=$P(Y(0),U,2),ECXDIEN=$P(Y(0),U,7) - .S ECXDIV(ECXIEN)=ECXDIEN_U_ECXNAME_U_ECXNUM - .D ACTDIV(ECXIEN,ECXSTART,ECXEND,.ECXD,.ECXACT) - .S ECXDIV(ECXIEN)=ECXDIV(ECXIEN)_U_ECXD_U_ECXACT - .I $D(^ECX(727.3,ECXIEN)) D - ..S ECXDIV(ECXIEN)=ECXDIV(ECXIEN)_U_$P($G(^ECX(727.3,ECXIEN,0)),U,2) - .I 'ECXACT W !!,?5,"Please note: Division "_ECXNUM_" was not active during",!,?5," selected date range.",! - I ECXERR=1 K ECXDIV - I '$D(ECXDIV) S ECXERR=1 - Q -ACTDIV(ECXIEN,ECXSTART,ECXEND,ECXD,ECXACT) ;determine if division active at anytime during date range - ;to be called by ADM^ECXDVSN - ; input - ; ECXIEN = ien in file #40.8; required - ; ECXSTART = start of date range; FM format; required - ; ECXEND = end of date range; FM format; required - ; output - ; ECXD = 1/0; passed by reference - ; 1 indicates primary division - ; ECXACT = 1/0; passed by reference - ; returns 0, if division not active during date range; - ; note: only start date and end date are checked; if division - ; inactive on both dates, then division assumed inactive - ; for entire date range - ;assume division active; set ecxact=1 - S ECXACT=1 - ;check if division active on start date or end date; - ;these dates are normally within the same month - F ECXDATE=ECXSTART,ECXEND D - .S DATE(ECXDATE)=$$SITE^VASITE(ECXDATE,ECXIEN) - .S ECXD=0 - .I ECXIEN=$$PRIM^VASITE(ECXDATE) S ECXD=1 - ;if not active on start date and not active on end date, reset ecxact=0 - I DATE(ECXSTART)=-1,DATE(ECXEND)=-1 S ECXACT=0 - Q -MOV(ECXDIV,ECXALL,ECXSTART,ECXEND,ECXERR) ;division information for MOV extract audit report - ;selected divisions from medical center division file (#40.8) - ; input - ; (see ADM) - ; output - ; (see ADM) - D ADM^ECXDVSN(.ECXDIV,ECXALL,ECXSTART,ECXEND,.ECXERR) - Q -PAS(ECXDIV,ECXALL,ECXERR) ;setup division/site information for PAS extract audit report - ; input - ; ECXDIV = passed by reference array variable - ; ECXALL = 1 - ; output - ; ECXDIV = data for default division/site; - ; ECXDIV(1)=ien in file #4^name^station number - ; where the INSTITUTION file pointer is obtained from file #728 - S ECXALL=1 D DEFAULT^ECXDVSN(.ECXDIV,ECXALL,.ECXERR) - Q -TRT(ECXDIV,ECXALL,ECXERR) ;setup division/site information for TRT extract audit report - ; input - ; ECXDIV = passed by reference array variable - ; ECXALL = 1 - ; output - ; ECXDIV = data for default division/site; - ; ECXDIV(1)=ien in file #4^name^station number - ; where the INSTITUTION file pointer is obtained from file #728 - S ECXALL=1 D DEFAULT^ECXDVSN(.ECXDIV,ECXALL,.ECXERR) - Q -DEFAULT(ECXDIV,ECXALL,ECXERR) ;default division/site information for audit report - ; input - ; ECXDIV = passed by reference array variable - ; ECXALL = 1 - ; output - ; ECXDIV = data for default division/site; - ; ECXDIV(1)=ien in file #4^name^station number - ; where the INSTITUTION file pointer is obtained from file #728 - N DIV,ECX - S ECXERR=0 - S DIV=$P($G(^ECX(728,1,0)),U,1) - I DIV="" S ECXERR=1 Q - K ECX S DIC="^DIC(4,",DIQ(0)="I",DIQ="ECX",DA=DIV,DR=".01;99" D EN^DIQ1 - I $D(ECX) S ECXDIV(1)=DIV_U_ECX(4,DIV,.01,"I")_U_ECX(4,DIV,99,"I") - I '$D(ECX) S ECXERR=1 - I '$D(ECXDIV) S ECXERR=1 - Q -DEN(ECXDIV,ECXALL,ECXERR) ;setup division/site information for DEN extract audit report - ; input - ; ECXDIV = passed by reference array variable (required) - ; ECXALL = 0/1 (optional) - ; '0' indicates user to select dental division; - ; '1' indicates 'all' dental divisions or only one division - ; exists in file #225; default is '1' - ; output - ; ECXDIV = data for dental division/site; - ; ECXDIV(ien in file #225)=ien in file #4^name^station number - ; ECXERR = 0/1 - ; if input problem, then '1' returned - N X,Y,DIC,DTOUT,DUOUT,DIRUT,OUT,ECXD,ECXIEN - S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1 - S ECXERR=0,ECXD="" - ;if ecxall=1, then all dental divisions/sites - I ECXALL=1 D - .F S ECXD=$O(^DENT(225,"B",ECXD)) Q:ECXD="" S ECXIEN=$O(^(ECXD,"")) D - ..S $P(ECXDIV(ECXIEN),U,3)=ECXD S DIC="^DIC(4,",DIC(0)="MX",X=ECXD D ^DIC - ..S:+Y>0 ECXDIV(ECXIEN)=Y S:+Y=-1 ECXDIV(ECXIEN)=U - ..S ECXDIV(ECXIEN)=ECXDIV(ECXIEN)_U_ECXD - ;if ecxall=0, user selects some/all dental divisions/sites - I ECXALL=0 S OUT=0 D - .F Q:OUT!ECXERR D - ..S DIC="^DENT(225,",DIC(0)="AEMQ" K X,Y D ^DIC - ..I $G(DUOUT)!($G(DTOUT)) S OUT=1,ECXERR=1 Q - ..I Y=-1,X="" S OUT=1 Q - ..S ECXIEN=+Y,ECXD=$P(Y,U,2) K X,Y - ..S DIC="^DIC(4,",DIC(0)="MX",X=ECXD D ^DIC - ..S:+Y>0 ECXDIV(ECXIEN)=Y S:+Y=-1 ECXDIV(ECXIEN)=U - ..S ECXDIV(ECXIEN)=ECXDIV(ECXIEN)_U_ECXD - I ECXERR=1 K ECXDIV - I '$D(ECXDIV) S ECXERR=1 - Q -ECS(ECXDIV,ECXALL,ECXERR) ;setup division/location information for ECS extract audit report - ; input - ; ECXDIV = passed by reference array variable (required) - ; ECXALL = 0/1 (optional) - ; '0' indicates user to select EC location(s); - ; '1' indicates 'all' locations or only one location - ; exists in file #4 "LOC" index; - ; default is '1' - ; output - ; ECXDIV = data for EC location; - ; ECXDIV(ien in file #4)=ien in file #4^name^station number - ; where the INSTITUTION file pointer is obtained from - ; "LOC" index in file #4 - ; ECXERR = 0/1 - ; if input problem, then '1' returned - ; - N X,Y,I,DIC,DIR,DIRUT,DTOUT,DUOUT,NM,OUT,ECXD,ECXIEN,ECXLOC - S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1 - S ECXERR=0,ECXD="",I=0 - ;get all available ec locations in ecxloc array - F S ECXD=$O(^DIC(4,"LOC",ECXD)) Q:ECXD="" S I=I+1,ECXIEN=$O(^(ECXD,"")),ECXLOC(I)=ECXD_U_ECXIEN_U_$P($G(^DIC(4,ECXIEN,99)),U,1) - ;if ecxall=1, then all ec locations - I ECXALL=1 S I="" D Q - .F S I=$O(ECXLOC(I)) Q:I="" D - ..S ECXIEN=$P(ECXLOC(I),U,2) - ..S ECXDIV(ECXIEN)=ECXIEN_U_$P(ECXLOC(I),U,1)_U_$P(ECXLOC(I),U,3) - I ECXALL=0 S OUT=0,I=0 D - .W !!,"Event Capture Locations:",! S I=0,DIR(0)="SXO^" - .;spaces are embedded in dir(0) to prevent user from selecting by alpha characters in name - .F S I=$O(ECXLOC(I)) Q:I="" S NM=$P(ECXLOC(I),U,1) W !,?10,I_" ",NM S DIR(0)=DIR(0)_I_":"_"- "_NM_";" - .W ! - .F Q:OUT!ECXERR D - ..S DIR("A")="Select Event Capture Location",DIR("S")="I +Y=Y" - ..D ^DIR - ..I $G(DTOUT)!($G(DUOUT)) S ECXERR=1 Q - ..I X="" D Q - ...I '$D(ECXDIV) W !!,"No Location selected...exiting.",! S OUT=1 Q - ...W !!,"You have selected the following Location(s):",! - ...S I=0 F S I=$O(ECXDIV(I)) Q:I="" W !,?10,$P(ECXDIV(I),U,2)_" ("_$P(ECXDIV(I),U,3)_")" - ...W ! K X,Y,DIR S DIR(0)="Y",DIR("A")="Is that ok",DIR("B")="YES" D ^DIR - ...I $D(DIRUT) S ECXERR=1 - ...I Y=0 S ECXERR=1 - ...S OUT=1 - ..S ECXIEN=$P(ECXLOC(X),U,2) - ..S ECXDIV(ECXIEN)=ECXIEN_U_$P(ECXLOC(X),U,1)_U_$P(ECXLOC(X),U,3) - ;exit - I ECXERR=1 K ECXDIV - I '$D(ECXDIV) S ECXERR=1 - Q -NUT() ; Set Divisions into screen array (prompt is one/many/all) - ;Input : SCRNARR - Screen array full global reference - ;Output : 1 = OK 0 = User abort/timeout - ; @SCRNARR@("DIVISION") = User pick all divisions ? - ; 1 = Yes (all) 0 = No - ; @SCRNARR@("DIVISION",PtrDiv) = Division name - ;Note : @SCRNARR@("DIVISION") is initialized (KILLed) on input - ; : @SCRNARR@("DIVISION",PtrDiv) is only set when the user - ; picked individual divisions (i.e. didn't pick all) - ; - ;Declare variables - N VAUTD,Y,SCANARR - ;Get division selection - S DIC="^DIC(4," - S VAUTSTR="PATIENT DIVISION" - S VAUTVB="SCANARR" - S VAUTNI=2 - D FIRST^VAUTOMA - I Y<0 Q 1 - M @SCRNARR@("DIVISION")=SCANARR - Q 0 +ECXDVSN ;ALB/JAP - Division selection utility ;Sep 29, 1997 + ;;3.0;DSS EXTRACTS;**8**;Dec 22, 1997 + ; +ADM(ECXDIV,ECXALL,ECXSTART,ECXEND,ECXERR) ;division information for ADM extract audit report + ;selected inpatient divisions from medical center division file (#40.8) + ; input + ; ECXDIV = array of inpatient divisions selected (required) + ; passed by reference array containing + ; selected divisions; + ; ECXALL = 1/0 (optional) + ; 1==> user wants all inpatient divisions OR + ; facility is non-divisional + ; 0==> user wants to select some divisions + ; if ECXALL not defined, then assume 1 + ; ECXSTART = start date of date range (optional) + ; ECXEND = end date of date range (optional) + ; ECXERR = passed by reference for error return (required) + ; output + ; ECXDIV = array of divisions selected from file #40.8; + ; if ECXALL=1, then array contains all divisions + ; if ECXALL=0, then array contains user-selected divisions + ; ECXDIV(ien in file #40.8) = ien in file #4^name^station number^primary indicator^active indicator^dss id + ; error CODE + ; ECXERR = 1, if input problem occurs + ; 0, otherwise + ; + N OUT,DIC,X,Y,NM,ECXD,ECXIEN,ECXDIEN,ECXACT,ECXNAME,ECXNUM + S (OUT,ECXERR)=0 + ;if start date or end date missing, then both default to today + I '$G(ECXSTART)!('$G(ECXEND)) S (ECXSTART,ECXEND)=DT + S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1 + I ECXALL=1 D + .S NM="" F S NM=$O(^DG(40.8,"B",NM)) Q:NM="" S ECXIEN=$O(^(NM,"")) D + ..Q:+$P(^DG(40.8,ECXIEN,0),U,3)=1 + ..K Y S DIC="^DG(40.8,",DIC(0)="NZ",X=ECXIEN D ^DIC + ..Q:Y=-1 + ..S ECXNAME=$P(Y(0),U,1),ECXNUM=$P(Y(0),U,2),ECXDIEN=$P(Y(0),U,7) + ..S ECXDIV(ECXIEN)=ECXDIEN_U_ECXNAME_U_ECXNUM + ..D ACTDIV(ECXIEN,ECXSTART,ECXEND,.ECXD,.ECXACT) + ..S ECXDIV(ECXIEN)=ECXDIV(ECXIEN)_U_ECXD_U_ECXACT + ..I $D(^ECX(727.3,ECXIEN)) D + ...S ECXDIV(ECXIEN)=ECXDIV(ECXIEN)_U_$P($G(^ECX(727.3,ECXIEN,0)),U,2) + I ECXALL=0 F Q:OUT!ECXERR D + .K Y S DIC="^DG(40.8,",DIC(0)="AEMQZ",DIC("S")="I $P(^(0),U,3)'=1" + .D ^DIC I $G(DUOUT)!($G(DTOUT)) S OUT=1,ECXERR=1 Q + .I Y=-1,X="" S OUT=1 Q + .S ECXIEN=+Y,ECXNAME=$P(Y(0),U,1),ECXNUM=$P(Y(0),U,2),ECXDIEN=$P(Y(0),U,7) + .S ECXDIV(ECXIEN)=ECXDIEN_U_ECXNAME_U_ECXNUM + .D ACTDIV(ECXIEN,ECXSTART,ECXEND,.ECXD,.ECXACT) + .S ECXDIV(ECXIEN)=ECXDIV(ECXIEN)_U_ECXD_U_ECXACT + .I $D(^ECX(727.3,ECXIEN)) D + ..S ECXDIV(ECXIEN)=ECXDIV(ECXIEN)_U_$P($G(^ECX(727.3,ECXIEN,0)),U,2) + .I 'ECXACT W !!,?5,"Please note: Division "_ECXNUM_" was not active during",!,?5," selected date range.",! + I ECXERR=1 K ECXDIV + I '$D(ECXDIV) S ECXERR=1 + Q + ; +ACTDIV(ECXIEN,ECXSTART,ECXEND,ECXD,ECXACT) ;determine if division active at anytime during date range + ;to be called by ADM^ECXDVSN + ; input + ; ECXIEN = ien in file #40.8; required + ; ECXSTART = start of date range; FM format; required + ; ECXEND = end of date range; FM format; required + ; output + ; ECXD = 1/0; passed by reference + ; 1 indicates primary division + ; ECXACT = 1/0; passed by reference + ; returns 0, if division not active during date range; + ; note: only start date and end date are checked; if division + ; inactive on both dates, then division assumed inactive + ; for entire date range + ;assume division active; set ecxact=1 + S ECXACT=1 + ;check if division active on start date or end date; + ;these dates are normally within the same month + F ECXDATE=ECXSTART,ECXEND D + .S DATE(ECXDATE)=$$SITE^VASITE(ECXDATE,ECXIEN) + .S ECXD=0 + .I ECXIEN=$$PRIM^VASITE(ECXDATE) S ECXD=1 + ;if not active on start date and not active on end date, reset ecxact=0 + I DATE(ECXSTART)=-1,DATE(ECXEND)=-1 S ECXACT=0 + Q + ; +MOV(ECXDIV,ECXALL,ECXSTART,ECXEND,ECXERR) ;division information for MOV extract audit report + ;selected divisions from medical center division file (#40.8) + ; input + ; (see ADM) + ; output + ; (see ADM) + ; + D ADM^ECXDVSN(.ECXDIV,ECXALL,ECXSTART,ECXEND,.ECXERR) + Q + ; +PAS(ECXDIV,ECXALL,ECXERR) ;setup division/site information for PAS extract audit report + ; input + ; ECXDIV = passed by reference array variable + ; ECXALL = 1 + ; output + ; ECXDIV = data for default division/site; + ; ECXDIV(1)=ien in file #4^name^station number + ; where the INSTITUTION file pointer is obtained from file #728 + ; + S ECXALL=1 D DEFAULT^ECXDVSN(.ECXDIV,ECXALL,.ECXERR) + Q + ; +TRT(ECXDIV,ECXALL,ECXERR) ;setup division/site information for TRT extract audit report + ; input + ; ECXDIV = passed by reference array variable + ; ECXALL = 1 + ; output + ; ECXDIV = data for default division/site; + ; ECXDIV(1)=ien in file #4^name^station number + ; where the INSTITUTION file pointer is obtained from file #728 + ; + S ECXALL=1 D DEFAULT^ECXDVSN(.ECXDIV,ECXALL,.ECXERR) + Q + ; +DEFAULT(ECXDIV,ECXALL,ECXERR) ;default division/site information for audit report + ; input + ; ECXDIV = passed by reference array variable + ; ECXALL = 1 + ; output + ; ECXDIV = data for default division/site; + ; ECXDIV(1)=ien in file #4^name^station number + ; where the INSTITUTION file pointer is obtained from file #728 + ; + N DIV,ECX + S ECXERR=0 + S DIV=$P($G(^ECX(728,1,0)),U,1) + I DIV="" S ECXERR=1 Q + K ECX S DIC="^DIC(4,",DIQ(0)="I",DIQ="ECX",DA=DIV,DR=".01;99" D EN^DIQ1 + I $D(ECX) S ECXDIV(1)=DIV_U_ECX(4,DIV,.01,"I")_U_ECX(4,DIV,99,"I") + I '$D(ECX) S ECXERR=1 + I '$D(ECXDIV) S ECXERR=1 + Q + ; +DEN(ECXDIV,ECXALL,ECXERR) ;setup division/site information for DEN extract audit report + ; input + ; ECXDIV = passed by reference array variable (required) + ; ECXALL = 0/1 (optional) + ; '0' indicates user to select dental division; + ; '1' indicates 'all' dental divisions or only one division + ; exists in file #225; default is '1' + ; output + ; ECXDIV = data for dental division/site; + ; ECXDIV(ien in file #225)=ien in file #4^name^station number + ; ECXERR = 0/1 + ; if input problem, then '1' returned + N X,Y,DIC,DTOUT,DUOUT,DIRUT,OUT,ECXD,ECXIEN + S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1 + S ECXERR=0,ECXD="" + ;if ecxall=1, then all dental divisions/sites + I ECXALL=1 D + .F S ECXD=$O(^DENT(225,"B",ECXD)) Q:ECXD="" S ECXIEN=$O(^(ECXD,"")) D + ..S $P(ECXDIV(ECXIEN),U,3)=ECXD S DIC="^DIC(4,",DIC(0)="MX",X=ECXD D ^DIC + ..S:+Y>0 ECXDIV(ECXIEN)=Y S:+Y=-1 ECXDIV(ECXIEN)=U + ..S ECXDIV(ECXIEN)=ECXDIV(ECXIEN)_U_ECXD + ;if ecxall=0, user selects some/all dental divisions/sites + I ECXALL=0 S OUT=0 D + .F Q:OUT!ECXERR D + ..S DIC="^DENT(225,",DIC(0)="AEMQ" K X,Y D ^DIC + ..I $G(DUOUT)!($G(DTOUT)) S OUT=1,ECXERR=1 Q + ..I Y=-1,X="" S OUT=1 Q + ..S ECXIEN=+Y,ECXD=$P(Y,U,2) K X,Y + ..S DIC="^DIC(4,",DIC(0)="MX",X=ECXD D ^DIC + ..S:+Y>0 ECXDIV(ECXIEN)=Y S:+Y=-1 ECXDIV(ECXIEN)=U + ..S ECXDIV(ECXIEN)=ECXDIV(ECXIEN)_U_ECXD + I ECXERR=1 K ECXDIV + I '$D(ECXDIV) S ECXERR=1 + Q + ; +ECS(ECXDIV,ECXALL,ECXERR) ;setup division/location information for ECS extract audit report + ; input + ; ECXDIV = passed by reference array variable (required) + ; ECXALL = 0/1 (optional) + ; '0' indicates user to select EC location(s); + ; '1' indicates 'all' locations or only one location + ; exists in file #4 "LOC" index; + ; default is '1' + ; output + ; ECXDIV = data for EC location; + ; ECXDIV(ien in file #4)=ien in file #4^name^station number + ; where the INSTITUTION file pointer is obtained from + ; "LOC" index in file #4 + ; ECXERR = 0/1 + ; if input problem, then '1' returned + ; + N X,Y,I,DIC,DIR,DIRUT,DTOUT,DUOUT,NM,OUT,ECXD,ECXIEN,ECXLOC + S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1 + S ECXERR=0,ECXD="",I=0 + ;get all available ec locations in ecxloc array + F S ECXD=$O(^DIC(4,"LOC",ECXD)) Q:ECXD="" S I=I+1,ECXIEN=$O(^(ECXD,"")),ECXLOC(I)=ECXD_U_ECXIEN_U_$P($G(^DIC(4,ECXIEN,99)),U,1) + ;if ecxall=1, then all ec locations + I ECXALL=1 S I="" D Q + .F S I=$O(ECXLOC(I)) Q:I="" D + ..S ECXIEN=$P(ECXLOC(I),U,2) + ..S ECXDIV(ECXIEN)=ECXIEN_U_$P(ECXLOC(I),U,1)_U_$P(ECXLOC(I),U,3) + I ECXALL=0 S OUT=0,I=0 D + .W !!,"Event Capture Locations:",! S I=0,DIR(0)="SXO^" + .;spaces are embedded in dir(0) to prevent user from selecting by alpha characters in name + .F S I=$O(ECXLOC(I)) Q:I="" S NM=$P(ECXLOC(I),U,1) W !,?10,I_" ",NM S DIR(0)=DIR(0)_I_":"_"- "_NM_";" + .W ! + .F Q:OUT!ECXERR D + ..S DIR("A")="Select Event Capture Location",DIR("S")="I +Y=Y" + ..D ^DIR + ..I $G(DTOUT)!($G(DUOUT)) S ECXERR=1 Q + ..I X="" D Q + ...I '$D(ECXDIV) W !!,"No Location selected...exiting.",! S OUT=1 Q + ...W !!,"You have selected the following Location(s):",! + ...S I=0 F S I=$O(ECXDIV(I)) Q:I="" W !,?10,$P(ECXDIV(I),U,2)_" ("_$P(ECXDIV(I),U,3)_")" + ...W ! K X,Y,DIR S DIR(0)="Y",DIR("A")="Is that ok",DIR("B")="YES" D ^DIR + ...I $D(DIRUT) S ECXERR=1 + ...I Y=0 S ECXERR=1 + ...S OUT=1 + ..S ECXIEN=$P(ECXLOC(X),U,2) + ..S ECXDIV(ECXIEN)=ECXIEN_U_$P(ECXLOC(X),U,1)_U_$P(ECXLOC(X),U,3) + ;exit + I ECXERR=1 K ECXDIV + I '$D(ECXDIV) S ECXERR=1 + Q diff --git a/r/DSS_EXTRACTS-ECX/ECXDVSN1.m b/r/DSS_EXTRACTS-ECX/ECXDVSN1.m index 1beba303..b612fe44 100644 --- a/r/DSS_EXTRACTS-ECX/ECXDVSN1.m +++ b/r/DSS_EXTRACTS-ECX/ECXDVSN1.m @@ -1,159 +1,157 @@ -ECXDVSN1 ;ALB/JAP - Division selection utility (cont.) ; 3/30/07 7:56am - ;;3.0;DSS EXTRACTS;**8,105**;Dec 22, 1997;Build 70 - ; -ECQ(ECXDIV,ECXALL,ECXERR) ;setup division/site information for QSR extract audit report - ; input - ; ECXDIV = passed by reference array variable (required) - ; ECXALL = 0/1 (optional) - ; '0' indicates user to select QUASAR site/division; - ; '1' indicates 'all' sites/divisions or only one site/division - ; exists in file #509850.8; currently only one site is allowed - ; to be defined; - ; default is '1' - ; output - ; ECXDIV = data for QUASAR site/division; - ; ECXDIV(ien in file #4)=ien in file #509850.8^name^station number - ; ECXERR = 0/1 - ; if input problem, then '1' returned - ; - N X,Y,DIC,OUT,ECX,ECXD,ECXIEN - S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1 - ;currently, only ONE site may be defined in file #509850.8 - S:ECXALL=0 ECXALL=1 - S ECXERR=0,ECXD="" - ;if ecxall=1, then all QUASAR sites/divisions; but there's only one - I ECXALL=1 D - .F S ECXD=$O(^ACK(509850.8,"B",ECXD)) Q:ECXD="" S ECXIEN=$O(^(ECXD,"")) D - ..K ECX S DIC="^DIC(4,",DIQ(0)="I",DIQ="ECX",DA=ECXD,DR=".01;99" D EN^DIQ1 - ..I $D(ECX) S ECXDIV(ECXD)=ECXIEN_U_ECX(4,ECXD,.01,"I")_U_ECX(4,ECXD,99,"I") - ..I '$D(ECX) S ECXERR=1 - I ECXERR=1 K ECXDIV - I '$D(ECXDIV) S ECXERR=1 - Q - ; -LAB(ECXACC,ECXALL,ECXERR) ;setup accession area information for LAB extract audit report - ; input - ; ECXACC = passed by reference array variable (required) - ; ECXALL = 0/1 (optional) - ; '0' indicates user to select Accession Area(s); - ; '1' indicates 'all' Accession Areas are selected - ; default is '1' - ; output - ; ECXACC = data for Accession Area(s); - ; ECXACC(ien in file #68)=name^abbreviation - ; ECXERR = 0/1 - ; if input problem, then '1' returned - ; - N X,Y,DIC,DIQ,DA,DR,DTOUT,DUOUT,DIRUT,OUT,ECX,ECXA,ECXIEN - S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1 - S ECXERR=0,ECXA="" - ;if ecxall=1, then all accession areas are selected - I ECXALL=1 D - .;^LRO(68,"B",xxx,ien)=1 indicates a synonym; skip synonyms - .F S ECXA=$O(^LRO(68,"B",ECXA)) Q:ECXA="" S ECXIEN=$O(^(ECXA,"")) D - ..Q:^LRO(68,"B",ECXA,ECXIEN)=1 - ..K ECX S DIC="^LRO(68,",DR=".01;.09",DIQ="ECX",DA=ECXIEN D EN^DIQ1 - ..Q:'$D(ECX) - ..;acc. areas with ZZ in name indicates no longer used - ..Q:$E(ECX(68,ECXIEN,.01),1,2)="ZZ" - ..S ECXACC(ECXIEN)=ECX(68,ECXIEN,.01)_U_ECX(68,ECXIEN,.09) - ;if ecxall=0, user selects some/all acc. areas - ;allow user to choose "ZZ"'d acc. area even though it may currently be inactive - I ECXALL=0 S OUT=0 D - .F Q:OUT!ECXERR D - ..S DIC="^LRO(68,",DIC(0)="AEMQZ" K X,Y D ^DIC - ..I $G(DUOUT)!($G(DTOUT)) S OUT=1,ECXERR=1 Q - ..I Y=-1,X="" S OUT=1 Q - ..S ECXACC(+Y)=$P(Y(0),U,1)_U_$P(Y(0),U,11) - I ECXERR=1 K ECXACC - I '$D(ECXACC) S ECXERR=1 - Q - ; -NUR(ECXDIV,ECXALL,ECXERR) ;setup accession area information for LAB extract audit report - ; input - ; ECXDIV = passed by reference array variable (required) - ; ECXALL = 0/1 (optional) - ; '0' indicates user to select nursing location(s)/division(s); - ; '1' indicates 'all' nursing locations and medical center divisions - ; are selected or facility is non-divisional; - ; default is '1' - ; output - ; ECXDIV = data for nursing location(s) and medical center division(s); - ; ECXDIV("D",ien in file #40.8)=ien in file #4^name^station number - ; ECXDIV(ien in file #211.4,ien in file #40.8)=ien in file #44 - ; ECXERR = 0/1 - ; if input problem, then '1' returned - ; - ;N X,Y,DIC,DIQ,DA,OUT,ECX,ECXLOC,ECXSC,ECXDIEN,ECXNLIEN,ECXNLNM,ECXPRIME - S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1 - S (ECXERR,OUT)=0,ECXSC="" - ;get ien in file #40.8 of primary division - S ECXPRIME=$$PRIM^VASITE(DT) - ;associate nursing locations with medical center divisions - F S ECXSC=$O(^NURSF(211.4,"B",ECXSC)) Q:ECXSC="" S ECXNLIEN="" F S ECXNLIEN=$O(^NURSF(211.4,"B",ECXSC,ECXNLIEN)) Q:ECXNLIEN="" D - .K ECX - .S ECXDIEN=0,ECXNLNM="",DIC="^SC(",DIQ(0)="I",DIQ="ECX",DA=ECXSC,DR=".01;3.5" D EN^DIQ1 - .;if the 15th piece is null or y=-1 then ecxdien=primary division as default - .I $D(ECX) S ECXDIEN=+ECX(44,ECXSC,3.5,"I"),ECXNLNM=ECX(44,ECXSC,.01,"I") - .S:ECXDIEN=0 ECXDIEN=ECXPRIME - .S ECXLOC(ECXDIEN)="",ECXLOC(ECXDIEN,ECXNLIEN)=ECXSC_U_ECXNLNM - ; - ;if ecxall=1 don't prompt; setup all nursing locations and divisions incl. those w/o division - I ECXALL=1 S ECXDIEN="" D - .F S ECXDIEN=$O(ECXLOC(ECXDIEN)) Q:ECXDIEN="" D - ..S DIC="^DG(40.8,",DIC(0)="NXZ",X=ECXDIEN D ^DIC I +Y>0 D - ...S ECXDIV("D",ECXDIEN)=$P(Y(0),U,7)_U_$P(Y(0),U,1)_U_$P(Y(0),U,2),ECXNLIEN="" - ...F S ECXNLIEN=$O(ECXLOC(ECXDIEN,ECXNLIEN)) Q:ECXNLIEN="" S ECXDIV(ECXNLIEN,ECXDIEN)=ECXLOC(ECXDIEN,ECXNLIEN) - ; - ;if ecxall=0 let user select division(s) - I ECXALL=0 F Q:OUT!ECXERR D - .S DIC="^DG(40.8,",DIC(0)="AEMQZ",DIC("S")="I $P(^(0),U,3)'=1" - .D ^DIC I $G(DUOUT)!($G(DTOUT)) S OUT=1,ECXERR=1 Q - .I Y=-1,X="" S OUT=1 Q - .S ECXDIEN=+Y,NM=$P(Y,U,2) - .I '$D(ECXLOC(ECXDIEN)) D Q - ..W !!,?5,"Division "_NM_" not associated with Nursing Locations.",!,?5,"Try again...",! - .S ECXDIV("D",ECXDIEN)=$P(Y(0),U,7)_U_$P(Y(0),U,1)_U_$P(Y(0),U,2),ECXNLIEN="" - .F S ECXNLIEN=$O(ECXLOC(ECXDIEN,ECXNLIEN)) Q:ECXNLIEN="" S ECXDIV(ECXNLIEN,ECXDIEN)=ECXLOC(ECXDIEN,ECXNLIEN) - ;in case of user up-arrow out or timeout, make sure nothing returned in ecxdiv - I ECXERR=1 K ECXDIV - I '$D(ECXDIV) S ECXERR=1 - Q - ; -PRE(ECXDIV,ECXALL,ECXERR) ;setup site information for PRE extract audit report - ; input - ; ECXDIV = passed by reference array variable (required) - ; ECXALL = 0/1 (optional) - ; '0' indicates user to select Pharmacy site(s); - ; '1' indicates 'all' sites are selected - ; default is '1' - ; output - ; ECXDIV = data for Pharmacy site(s); - ; ECXDIV(ien in file #59)=IEN in file #59^name^site number^IEN in file #4 - ; ECXERR = 0/1 - ; if input problem, then '1' returned - ; - N X,Y,DIC,DIQ,DA,OUT,ECXARR,ECXP,ECXIEN,ARRAY - S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1 - S ECXERR=0,ECXP="",ARRAY="^TMP($J,""ECXDSS"")" - K @ARRAY - ;if ecxall=1, then all pharmacy sites are selected or there's only one - I ECXALL=1 S ECXP="" D - .D PSS^PSO59(,"??","ECXDSS") - .F S ECXP=$O(@ARRAY@("B",ECXP)) Q:ECXP="" S ECXIEN=$O(^(ECXP,0)) Q:'ECXIEN Q:'$D(^(ECXIEN)) D - ..S ECXDIV(ECXIEN)=ECXIEN_U_@ARRAY@(ECXIEN,.01)_U_^(.06)_U_^(100) - ;if ecxall=0, then user selects pharmacy site(s) - I ECXALL=0 S OUT=0 D - .F Q:OUT!ECXERR D - ..N DIC,X,Y,DUOUT,DTOUT - ..S DIC="^PS(59,",DIC(0)="AEMQZ" - ..D DIC^PSODI(59,.DIC,.X) - ..I $G(DUOUT)!($G(DTOUT)) S OUT=1,ECXERR=1 Q - ..I Y=-1,X="" S OUT=1 Q - ..D PSS^PSO59(+Y,,"ECXDSS") - ..Q:'$D(@ARRAY) - ..S ECXDIV(ECXIEN)=ECXIEN_U_@ARRAY@(ECXIEN,.01)_U_^(.06)_U_^(100) - ; - I ECXERR=1 K ECXDIV - I '$D(ECXDIV) S ECXERR=1 - Q +ECXDVSN1 ;ALB/JAP - Division selection utility (cont.) ;Sep 30, 1997 + ;;3.0;DSS EXTRACTS;**8**;Dec 22, 1997 + ; +ECQ(ECXDIV,ECXALL,ECXERR) ;setup division/site information for QSR extract audit report + ; input + ; ECXDIV = passed by reference array variable (required) + ; ECXALL = 0/1 (optional) + ; '0' indicates user to select QUASAR site/division; + ; '1' indicates 'all' sites/divisions or only one site/division + ; exists in file #509850.8; currently only one site is allowed + ; to be defined; + ; default is '1' + ; output + ; ECXDIV = data for QUASAR site/division; + ; ECXDIV(ien in file #4)=ien in file #509850.8^name^station number + ; ECXERR = 0/1 + ; if input problem, then '1' returned + ; + N X,Y,DIC,OUT,ECX,ECXD,ECXIEN + S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1 + ;currently, only ONE site may be defined in file #509850.8 + S:ECXALL=0 ECXALL=1 + S ECXERR=0,ECXD="" + ;if ecxall=1, then all QUASAR sites/divisions; but there's only one + I ECXALL=1 D + .F S ECXD=$O(^ACK(509850.8,"B",ECXD)) Q:ECXD="" S ECXIEN=$O(^(ECXD,"")) D + ..K ECX S DIC="^DIC(4,",DIQ(0)="I",DIQ="ECX",DA=ECXD,DR=".01;99" D EN^DIQ1 + ..I $D(ECX) S ECXDIV(ECXD)=ECXIEN_U_ECX(4,ECXD,.01,"I")_U_ECX(4,ECXD,99,"I") + ..I '$D(ECX) S ECXERR=1 + I ECXERR=1 K ECXDIV + I '$D(ECXDIV) S ECXERR=1 + Q + ; +LAB(ECXACC,ECXALL,ECXERR) ;setup accession area information for LAB extract audit report + ; input + ; ECXACC = passed by reference array variable (required) + ; ECXALL = 0/1 (optional) + ; '0' indicates user to select Accession Area(s); + ; '1' indicates 'all' Accession Areas are selected + ; default is '1' + ; output + ; ECXACC = data for Accession Area(s); + ; ECXACC(ien in file #68)=name^abbreviation + ; ECXERR = 0/1 + ; if input problem, then '1' returned + ; + N X,Y,DIC,DIQ,DA,DR,DTOUT,DUOUT,DIRUT,OUT,ECX,ECXA,ECXIEN + S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1 + S ECXERR=0,ECXA="" + ;if ecxall=1, then all accession areas are selected + I ECXALL=1 D + .;^LRO(68,"B",xxx,ien)=1 indicates a synonym; skip synonyms + .F S ECXA=$O(^LRO(68,"B",ECXA)) Q:ECXA="" S ECXIEN=$O(^(ECXA,"")) D + ..Q:^LRO(68,"B",ECXA,ECXIEN)=1 + ..K ECX S DIC="^LRO(68,",DR=".01;.09",DIQ="ECX",DA=ECXIEN D EN^DIQ1 + ..Q:'$D(ECX) + ..;acc. areas with ZZ in name indicates no longer used + ..Q:$E(ECX(68,ECXIEN,.01),1,2)="ZZ" + ..S ECXACC(ECXIEN)=ECX(68,ECXIEN,.01)_U_ECX(68,ECXIEN,.09) + ;if ecxall=0, user selects some/all acc. areas + ;allow user to choose "ZZ"'d acc. area even though it may currently be inactive + I ECXALL=0 S OUT=0 D + .F Q:OUT!ECXERR D + ..S DIC="^LRO(68,",DIC(0)="AEMQZ" K X,Y D ^DIC + ..I $G(DUOUT)!($G(DTOUT)) S OUT=1,ECXERR=1 Q + ..I Y=-1,X="" S OUT=1 Q + ..S ECXACC(+Y)=$P(Y(0),U,1)_U_$P(Y(0),U,11) + I ECXERR=1 K ECXACC + I '$D(ECXACC) S ECXERR=1 + Q + ; +NUR(ECXDIV,ECXALL,ECXERR) ;setup accession area information for LAB extract audit report + ; input + ; ECXDIV = passed by reference array variable (required) + ; ECXALL = 0/1 (optional) + ; '0' indicates user to select nursing location(s)/division(s); + ; '1' indicates 'all' nursing locations and medical center divisions + ; are selected or facility is non-divisional; + ; default is '1' + ; output + ; ECXDIV = data for nursing location(s) and medical center division(s); + ; ECXDIV("D",ien in file #40.8)=ien in file #4^name^station number + ; ECXDIV(ien in file #211.4,ien in file #40.8)=ien in file #44 + ; ECXERR = 0/1 + ; if input problem, then '1' returned + ; + ;N X,Y,DIC,DIQ,DA,OUT,ECX,ECXLOC,ECXSC,ECXDIEN,ECXNLIEN,ECXNLNM,ECXPRIME + S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1 + S (ECXERR,OUT)=0,ECXSC="" + ;get ien in file #40.8 of primary division + S ECXPRIME=$$PRIM^VASITE(DT) + ;associate nursing locations with medical center divisions + F S ECXSC=$O(^NURSF(211.4,"B",ECXSC)) Q:ECXSC="" S ECXNLIEN="" F S ECXNLIEN=$O(^NURSF(211.4,"B",ECXSC,ECXNLIEN)) Q:ECXNLIEN="" D + .K ECX + .S ECXDIEN=0,ECXNLNM="",DIC="^SC(",DIQ(0)="I",DIQ="ECX",DA=ECXSC,DR=".01;3.5" D EN^DIQ1 + .;if the 15th piece is null or y=-1 then ecxdien=primary division as default + .I $D(ECX) S ECXDIEN=+ECX(44,ECXSC,3.5,"I"),ECXNLNM=ECX(44,ECXSC,.01,"I") + .S:ECXDIEN=0 ECXDIEN=ECXPRIME + .S ECXLOC(ECXDIEN)="",ECXLOC(ECXDIEN,ECXNLIEN)=ECXSC_U_ECXNLNM + ; + ;if ecxall=1 don't prompt; setup all nursing locations and divisions incl. those w/o division + I ECXALL=1 S ECXDIEN="" D + .F S ECXDIEN=$O(ECXLOC(ECXDIEN)) Q:ECXDIEN="" D + ..S DIC="^DG(40.8,",DIC(0)="NXZ",X=ECXDIEN D ^DIC I +Y>0 D + ...S ECXDIV("D",ECXDIEN)=$P(Y(0),U,7)_U_$P(Y(0),U,1)_U_$P(Y(0),U,2),ECXNLIEN="" + ...F S ECXNLIEN=$O(ECXLOC(ECXDIEN,ECXNLIEN)) Q:ECXNLIEN="" S ECXDIV(ECXNLIEN,ECXDIEN)=ECXLOC(ECXDIEN,ECXNLIEN) + ; + ;if ecxall=0 let user select division(s) + I ECXALL=0 F Q:OUT!ECXERR D + .S DIC="^DG(40.8,",DIC(0)="AEMQZ",DIC("S")="I $P(^(0),U,3)'=1" + .D ^DIC I $G(DUOUT)!($G(DTOUT)) S OUT=1,ECXERR=1 Q + .I Y=-1,X="" S OUT=1 Q + .S ECXDIEN=+Y,NM=$P(Y,U,2) + .I '$D(ECXLOC(ECXDIEN)) D Q + ..W !!,?5,"Division "_NM_" not associated with Nursing Locations.",!,?5,"Try again...",! + .S ECXDIV("D",ECXDIEN)=$P(Y(0),U,7)_U_$P(Y(0),U,1)_U_$P(Y(0),U,2),ECXNLIEN="" + .F S ECXNLIEN=$O(ECXLOC(ECXDIEN,ECXNLIEN)) Q:ECXNLIEN="" S ECXDIV(ECXNLIEN,ECXDIEN)=ECXLOC(ECXDIEN,ECXNLIEN) + ;in case of user up-arrow out or timeout, make sure nothing returned in ecxdiv + I ECXERR=1 K ECXDIV + I '$D(ECXDIV) S ECXERR=1 + Q + ; +PRE(ECXDIV,ECXALL,ECXERR) ;setup site information for PRE extract audit report + ; input + ; ECXDIV = passed by reference array variable (required) + ; ECXALL = 0/1 (optional) + ; '0' indicates user to select Pharmacy site(s); + ; '1' indicates 'all' sites are selected + ; default is '1' + ; output + ; ECXDIV = data for Pharmacy site(s); + ; ECXDIV(ien in file #59)=IEN in file #59^name^site number^IEN in file #4 + ; ECXERR = 0/1 + ; if input problem, then '1' returned + ; + N X,Y,DIC,DIQ,DA,OUT,ECXARR,ECXP,ECXIEN + S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1 + S ECXERR=0,ECXP="" + ;if ecxall=1, then all pharmacy sites are selected or there's only one + I ECXALL=1 S ECXP="" D + .F S ECXP=$O(^PS(59,"B",ECXP)) Q:ECXP="" S ECXIEN=$O(^(ECXP,"")) D + ..K ECXARR S DIC="^PS(59,",DR=".01;.06;100",DIQ="ECXARR",DA=ECXIEN D EN^DIQ1 + ..Q:'$D(ECXARR) + ..S ECXDIV(ECXIEN)=ECXIEN_U_ECXARR(59,ECXIEN,.01)_U_ECXARR(59,ECXIEN,.06)_U_ECXARR(59,ECXIEN,100) + ;if ecxall=0, then user selects pharmacy site(s) + I ECXALL=0 S OUT=0 D + .F Q:OUT!ECXERR D + ..S DIC="^PS(59,",DIC(0)="AEMQZ" K X,Y D ^DIC + ..I $G(DUOUT)!($G(DTOUT)) S OUT=1,ECXERR=1 Q + ..I Y=-1,X="" S OUT=1 Q + ..K ECXARR S (ECXIEN,DA)=+Y,DIC="^PS(59,",DR=".01;.06;100",DIQ="ECXARR" D EN^DIQ1 + ..Q:'$D(ECXARR) + ..S ECXDIV(ECXIEN)=ECXIEN_U_ECXARR(59,ECXIEN,.01)_U_ECXARR(59,ECXIEN,.06)_U_ECXARR(59,ECXIEN,100) + ; + I ECXERR=1 K ECXDIV + I '$D(ECXDIV) S ECXERR=1 + Q diff --git a/r/DSS_EXTRACTS-ECX/ECXEC.m b/r/DSS_EXTRACTS-ECX/ECXEC.m index db46ad8e..0f4dddbe 100644 --- a/r/DSS_EXTRACTS-ECX/ECXEC.m +++ b/r/DSS_EXTRACTS-ECX/ECXEC.m @@ -1,185 +1,176 @@ -ECXEC ;ALB/JAP,BIR/JLP,PTD-DSS Event Capture Extract ; 10/2/07 2:33pm - ;;3.0;DSS EXTRACTS;**11,8,13,24,27,33,39,46,49,71,89,92,105**;Dec 22, 1997;Build 70 -BEG ;entry point from option - I '$D(^ECH) W !,"Event Capture is not initialized",!! Q - D SETUP I ECFILE="" Q - D ^ECXTRAC,^ECXKILL - Q -START ;begin EC extract - N X,Y,ECDCM,ECXNPRFI - S ECED=ECED+.3,ECLL=0 - K ^TMP("EC",$J) - F S ECLL=$O(^ECH("AC1",ECLL)),ECD=ECSD-.1 Q:'ECLL D - .F S ECD=$O(^ECH("AC1",ECLL,ECD)),ECDA=0 Q:(ECD>ECED)!('ECD) D - ..F S ECDA=$O(^ECH("AC1",ECLL,ECD,ECDA)) Q:'ECDA D UPDATE - Q - ; -UPDATE ;sets record and updates counters - S ECCH=^ECH(ECDA,0),ECL=$P(ECCH,U,4),ECXDFN=$P(ECCH,U,2) - S ECXPDIV=$$RADDIV^ECXDEPT(ECL) ;Get production division from file 4 - S ECDT=$P(ECCH,U,3),ECM=$P(ECCH,U,6),ECC=$P(ECCH,U,8) - Q:'$$PATDEM^ECXUTL2(ECXDFN,ECDT,"1;3;5;") - S ECTM=$$ECXTIME^ECXUTL(ECDT),ECP=$P(ECCH,U,9) - Q:ECP']"" - S ECO=$P(ECCH,U,12),ECV=$P(ECCH,U,10),ECDU=$P(ECCH,U,7) - S ECXUNIT=$G(^ECD(ECDU,0)),ECCS=+$P(ECXUNIT,U,4),ECDCM=$P(ECXUNIT,U,5) - S ECXDSSP="",ECXDSSD=$E(ECDCM,1,10),ECUSTOP=$P(ECXUNIT,U,10),ECUPCE=$P(ECXUNIT,U,14) - S ICD9=$P($G(^ECH(ECDA,"P")),U,2) S:ICD9="" ICD9=" " - S ECXICD9=$P($G(^ICD9(ICD9,0)),U) - F I=1:1:4 S @("ECXICD9"_I)="" - S (CNT,I)=0 - F S CNT=$O(^ECH(ECDA,"DX",CNT)) Q:'CNT D Q:I>3 - .S ICD9=$P($G(^ECH(ECDA,"DX",CNT,0)),U) D:ICD9'="" - ..S I=I+1,@("ECXICD9"_I)=$P($G(^ICD9(ICD9,0)),U) - ;derivation of dss identifier depends on whether dss unit is - ;set to send data to pce - S ECAC=$P($G(ECCH),U,19) - ;if this is a record that 'goes to pce', then get the dss identifier - ;from the clinic stop codes - S (ECAC1S,ECAC2S)="000" - I ECUPCE="A"!(ECUPCE="O"&(ECXA="O")) D - .D:+ECAC - ..S ECAC1=$P($G(^SC(+ECAC,0)),U,7),ECAC2=$P($G(^(0)),U,18) - ..I 'ECAC2 S ECAC2S="000" - ..I 'ECAC1 S (ECAC1S,ECAC2S)="000" Q - ..S ECAC1S=$P($G(^DIC(40.7,+ECAC1,0)),U,2) - ..S ECAC2S=$P($G(^DIC(40.7,+ECAC2,0)),U,2) - ..S ECAC1S=$$RJ^XLFSTR(ECAC1S,3,0),ECAC2S=$$RJ^XLFSTR(ECAC2S,3,0) - .S:'ECAC (ECAC1S,ECAC2S)="000" - ;if this record doesn't go to pce, then get the dss identifier - ;from the dss unit - I ECUPCE=""!(ECUPCE="N")!(ECUPCE="O"&(ECXA="I")) D - .I +ECUSTOP D - ..S ECAC1S=$P($G(^DIC(40.7,+ECUSTOP,0)),U,2) - ..S ECAC1S=$$RJ^XLFSTR(ECAC1S,3,0),ECAC2S="000" - .I 'ECUSTOP D - ..S (ECAC1S,ECAC2S)="000" - S ECDSS=ECAC1S_ECAC2S - I ECXLOGIC>2003 I "^18^23^24^36^41^65^94^"[("^"_ECXTS_"^") S ECDSS=$$TSMAP^ECXUTL4(ECXTS) - S ECXDIV="" - ; - ;- Ord Div, Contrct St/End Dates, Contrct Type placeholders for FY2002 - S (ECXODIV,ECXCSDT,ECXCEDT,ECXCTYP)="" - ;setup provider(s) as'2'_ien - S (ECU1A,ECU2A,ECU3A,ECU1NPI,ECU2NPI,ECU3NPI,ECXPPC1,ECXPPC2,ECXPPC3)="" - S (ECU1,ECU2,ECU3)="" - K ECXPRV S ECXPROV=$$GETPRV^ECPRVMUT(ECDA,.ECXPRV) I ECXPROV Q - F I=1:1:3 S Y=$O(ECXPRV("")) I Y'="" S @("ECU"_I)=+ECXPRV(Y) K ECXPRV(Y) - S:$L(ECU1) ECXPPC1=$$PRVCLASS^ECXUTL(ECU1,ECDT),ECU1A="2"_$P(ECU1,";") - S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECU1,ECDT) - S:+ECXUSRTN'>0 ECXUSRTN="" S ECU1NPI=$P(ECXUSRTN,U) - S:$L(ECU2) ECXPPC2=$$PRVCLASS^ECXUTL(ECU2,ECDT),ECU2A="2"_$P(ECU2,";") - S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECU2,ECDT) - S:+ECXUSRTN'>0 ECXUSRTN="" S ECU2NPI=$P(ECXUSRTN,U) - S:$L(ECU3) ECXPPC3=$$PRVCLASS^ECXUTL(ECU3,ECDT),ECU3A="2"_$P(ECU3,";") - S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECU3,ECDT) - S:+ECXUSRTN'>0 ECXUSRTN="" S ECU3NPI=$P(ECXUSRTN,U) - ;change for version 2 where ECP is a variable pointer and we want to - ;expand it category = category or null if stored as 0 - D:ECP[";" - .S ECP=$S(ECP["ICPT":$P(^ICPT(+ECP,0),U)_"01",ECP<90000:$P(^EC(725,+ECP,0),U,2)_"N",1:$P(^EC(725,+ECP,0),U,2)_"L"),ECC=$S(ECC:ECC,1:"") - ;pick up EC to PCE data from "P" in File 721 - S ECPCE=$G(^ECH(ECDA,"P")),ECPCE1=$P(ECPCE,U),ECPCE2=$P(ECPCE,U,2) - S ECPCE7=$S($P(ECPCE,U,7)=1:"Y",1:"N") - S ECXCMOD="" - I $D(^ECH(ECDA,"MOD")) D - .S MOD=0,M="" - .F S MOD=$O(^ECH(ECDA,"MOD",MOD)) Q:'MOD S M=$P(^(MOD,0),U) D - ..I M S ECXCMOD=ECXCMOD_M_";" - .K MOD,M - S:ECP?1.N ECP=$$CPT^ECXUTL3($E(ECP,1,5),"",ECV) - S ECXCPT=$$CPT^ECXUTL3(ECPCE1,ECXCMOD,ECV) - ; - ;- Observation Patient Indicator (YES/NO) - S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECDSS) - ; - ;- CNH status (YES/NO) - S ECXCNH=$$CNHSTAT^ECXUTL4(ECXDFN) - ; - ;- encounter classification - S (ECXAO,ECXECE,ECXHNC,ECXMIL,ECXIR)="",ECXVISIT=$P(ECCH,U,21) - I ECXVISIT'="" D - .D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) I ECXERR K ECXERR Q - .S ECXAO=$G(ECXVIST("AO")),ECXECE=$G(ECXVIST("PGE")) - .S ECXHNC=$G(ECXVIST("HNC")),ECXMIL=$G(ECXVIST("MST")),ECXIR=$G(ECXVIST("IR")) - ; - Head and Neck Cancer Indicator - S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) - ; - ; - Get national patient record flag Indicator if exist - D NPRF^ECXUTL5 - ; - ; - If no encounter number don't file record - S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECDT,ECXTS,ECXOBS,ECHEAD,ECDSS,ECCS) - D:ECXENC'="" FILE - Q - ; -FILE ;file record in #727.815 - ;node0 - ;ecode=inst ECL^dfn ECXDFN^ssn ECXSSN^name ECXPNM^i/o status ECXA^day^ - ;DSS unit ECDU^category ECC^procedure ECP^volume ECV^ - ;cost center ECCS^ordering sec ECO^section ECM^ - ;provider ECU1A^prov per cls ECXPPC1^prov 2 ECU2A^prov#2 per cls ECXPPC2 - ;^prov 3 ECU3A^prov#3 per cls ECXPPC3^^mov # ECXMN^treat spec ECXTS - ;^time ECTM^primary care team ECPTTM^primary care provider ECPTPR - ;^pce cpt code (ECXCPT)^primary icd-9 code ECXICD9^secondary icd-9 - ;ECXICD91^secondary icd-9 ECXICD92^secondary icd-9 ECXICD93^secondary - ;icd-9 ECXICD94^agent orange ECXAST^radiation exposure ECXRST^ - ;environmental contaminants ECXEST^service connected ECPTPR^sent to pce - ;ECPCE7^^dss identifier ECDSS^dss dept - ;node1 - ;mpi ECXMPI^dss dept ECXDSSD^PLACEHOLDER - ;placeholder^placeholder^placeholder^ - ;placeholder^pc prov person class ECCLAS^ - ;assoc pc prov ECASPR^assoc pc prov person class ECCLAS2^ - ;placeholder^ - ;divison ECXDIV^mst status ECXMST^dom ECXDOM^date of birth ECXDOB^ - ;enrollment category ECXCAT^ enrollment status ECXSTAT^enrollment - ;priority ECXPRIOR^period of service ECXPOS^purple heart indicator - ;ECXPHI^observ pat ind ECXOBS^encounter num ECXENC^ - ;ao loc ECXAOL^ord div ECXODIV^contr st dt ECXCSDT^ - ;contr end dt ECXCEDT^contr typ ECXCTYP^CNH stat ECXCNH^ - ;production division ECXPDIV^eligibility ECXELIG^ - ;head & neck cancer ind. ECXHNCI^ethnicity ECXETH^race1 ECXRAC1 - ;enrollment location ECXENRL^^enrollment priority - ;ECXPRIOR_enrollment subgroup ECXSBGRP^user enrollee ECXUESTA^patient - ;type ECXPTYPE^combat vet elig ECXCVE^combat vet elig end date - ;ECXCVEDT^enc cv eligible ECXCVENC^national patient record flag - ;ECXNPRFI^emerg response indic(FEMA) ECXERI^agent orange indic ECXAO^ - ;environ contam ECXECE^head/neck cancer ECXHNC^encntr mst ECXMIL - ;^radiation ECXIR^OEF/OIF ECXOEF^OEF/OIF return date ECXOEFDT - ;^associate pc provider npi ECASNPI^primary care provider npi ECPTNPI^ - ;provider npi ECU1NPI^provider #2 ECU2NPI^provider #3 ECU3NPI - N DA,DIK - S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 - S ECODE=EC7_U_EC23_U_ECL_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U - S ECODE=ECODE_$$ECXDATE^ECXUTL(ECDT,ECXYM)_U_ECDU_U_ECC_U - S ECODE=ECODE_ECP_U_ECV_U_ECCS_U_ECO_U_ECM_U_ECU1A_U_ECXPPC1_U - S ECODE=ECODE_ECU2A_U_ECXPPC2_U_ECU3A_U_ECXPPC3_U_U_ECXMN_U - S ECODE=ECODE_ECXTS_U_ECTM_U - S ECODE=ECODE_ECPTTM_U_ECPTPR_U_ECXCPT_U_ECXICD9_U - S ECODE=ECODE_ECXICD91_U_ECXICD92_U_ECXICD93_U - S ECODE=ECODE_ECXICD94_U_ECXAST_U_ECXRST_U_ECXEST_U - S ECODE=ECODE_ECSC_U_ECPCE7_U_U_ECDSS_U_U - S ECODE1=ECXMPI_U_ECXDSSD_U_U_U_U_ECCLAS_U - S ECODE1=ECODE1_U_ECASPR_U_ECCLAS2_U_U_ECXDIV_U - S ECODE1=ECODE1_ECXMST_U_ECXDOM_U_ECXDOB_U_ECXCAT_U_ECXSTAT_U - S ECODE1=ECODE1_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPOS_U_ECXPHI_U_ECXOBS_U_ECXENC_U_ECXAOL_U - S ECODE1=ECODE1_ECXODIV_U_ECXCSDT_U_ECXCEDT_U_ECXCTYP_U_ECXCNH_U_ECXPDIV_U - S ECODE1=ECODE1_ECXELIG_U_ECXHNCI_U_ECXETH_U_ECXRC1 - I ECXLOGIC>2003 S ECODE1=ECODE1_U_ECXENRL_U - I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U - I ECXLOGIC>2004 S ECODE2=ECXCVEDT_U_ECXCVENC_U_ECXNPRFI - I ECXLOGIC>2006 S ECODE2=ECODE2_U_ECXERI_U_ECXAO_U_ECXECE_U_ECXHNC_U_ECXMIL_U_ECXIR_U - I ECXLOGIC>2007 S ECODE2=ECODE2_U_ECXOEF_U_ECXOEFDT_U_ECASNPI_U_ECPTNPI_U_ECU1NPI_U_ECU2NPI_U_ECU3NPI - S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,^ECX(ECFILE,EC7,2)=$G(ECODE2),ECRN=ECRN+1 - S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA - I $D(ZTQUEUED),$$S^%ZTLOAD - Q - ; -SETUP ;Set required input for ECXTRAC - S ECHEAD="ECS" - D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) - Q - ; -QUE ; entry point for the background requeuing handled by ECXTAUTO - D SETUP,QUE^ECXTAUTO,^ECXKILL Q +ECXEC ;ALB/JAP,BIR/JLP,PTD-DSS Event Capture Extract [ 02/14/97 2:26 PM ] ; 12/2/04 12:35pm + ;;3.0;DSS EXTRACTS;**11,8,13,24,27,33,39,46,49,71,89,92**;Dec 22, 1997;Build 30 +BEG ;entry point from option + I '$D(^ECH) W !,"Event Capture is not initialized",!! Q + D SETUP I ECFILE="" Q + D ^ECXTRAC,^ECXKILL + Q +START ;begin EC extract + N X,Y,ECDCM,ECXNPRFI + S ECED=ECED+.3,ECLL=0 + K ^TMP("EC",$J) + F S ECLL=$O(^ECH("AC1",ECLL)),ECD=ECSD-.1 Q:'ECLL D + .F S ECD=$O(^ECH("AC1",ECLL,ECD)),ECDA=0 Q:(ECD>ECED)!('ECD) D + ..F S ECDA=$O(^ECH("AC1",ECLL,ECD,ECDA)) Q:'ECDA D UPDATE + Q + ; +UPDATE ;sets record and updates counters + S ECCH=^ECH(ECDA,0),ECL=$P(ECCH,U,4),ECXDFN=$P(ECCH,U,2) + S ECXPDIV=$$RADDIV^ECXDEPT(ECL) ;Get production division from file 4 + S ECDT=$P(ECCH,U,3),ECM=$P(ECCH,U,6),ECC=$P(ECCH,U,8) + Q:'$$PATDEM^ECXUTL2(ECXDFN,ECDT,"1;3;5;") + S ECTM=$$ECXTIME^ECXUTL(ECDT),ECP=$P(ECCH,U,9) + Q:ECP']"" + S ECO=$P(ECCH,U,12),ECV=$P(ECCH,U,10),ECDU=$P(ECCH,U,7) + S ECXUNIT=$G(^ECD(ECDU,0)),ECCS=+$P(ECXUNIT,U,4),ECDCM=$P(ECXUNIT,U,5) + S ECXDSSP="",ECXDSSD=$E(ECDCM,1,10),ECUSTOP=$P(ECXUNIT,U,10),ECUPCE=$P(ECXUNIT,U,14) + S ICD9=$P($G(^ECH(ECDA,"P")),U,2) S:ICD9="" ICD9=" " + S ECXICD9=$P($G(^ICD9(ICD9,0)),U) + F I=1:1:4 S @("ECXICD9"_I)="" + S (CNT,I)=0 + F S CNT=$O(^ECH(ECDA,"DX",CNT)) Q:'CNT D Q:I>3 + .S ICD9=$P($G(^ECH(ECDA,"DX",CNT,0)),U) D:ICD9'="" + ..S I=I+1,@("ECXICD9"_I)=$P($G(^ICD9(ICD9,0)),U) + ;derivation of dss identifier depends on whether dss unit is + ;set to send data to pce + S ECAC=$P($G(ECCH),U,19) + ;if this is a record that 'goes to pce', then get the dss identifier + ;from the clinic stop codes + S (ECAC1S,ECAC2S)="000" + I ECUPCE="A"!(ECUPCE="O"&(ECXA="O")) D + .D:+ECAC + ..S ECAC1=$P($G(^SC(+ECAC,0)),U,7),ECAC2=$P($G(^(0)),U,18) + ..I 'ECAC2 S ECAC2S="000" + ..I 'ECAC1 S (ECAC1S,ECAC2S)="000" Q + ..S ECAC1S=$P($G(^DIC(40.7,+ECAC1,0)),U,2) + ..S ECAC2S=$P($G(^DIC(40.7,+ECAC2,0)),U,2) + ..S ECAC1S=$$RJ^XLFSTR(ECAC1S,3,0),ECAC2S=$$RJ^XLFSTR(ECAC2S,3,0) + .S:'ECAC (ECAC1S,ECAC2S)="000" + ;if this record doesn't go to pce, then get the dss identifier + ;from the dss unit + I ECUPCE=""!(ECUPCE="N")!(ECUPCE="O"&(ECXA="I")) D + .I +ECUSTOP D + ..S ECAC1S=$P($G(^DIC(40.7,+ECUSTOP,0)),U,2) + ..S ECAC1S=$$RJ^XLFSTR(ECAC1S,3,0),ECAC2S="000" + .I 'ECUSTOP D + ..S (ECAC1S,ECAC2S)="000" + S ECDSS=ECAC1S_ECAC2S + I ECXLOGIC>2003 I "^18^23^24^36^41^65^94^"[("^"_ECXTS_"^") S ECDSS=$$TSMAP^ECXUTL4(ECXTS) + S ECXDIV="" + ; + ;- Ord Div, Contrct St/End Dates, Contrct Type placeholders for FY2002 + S (ECXODIV,ECXCSDT,ECXCEDT,ECXCTYP)="" + ;setup provider(s) as'2'_ien + S (ECU1A,ECU2A,ECU3A,ECU1NPI,ECU2NPI,ECU3NPI,ECXPPC1,ECXPPC2,ECXPPC3)="" + S (ECU1,ECU2,ECU3)="" + K ECXPRV S ECXPROV=$$GETPRV^ECPRVMUT(ECDA,.ECXPRV) I ECXPROV Q + F I=1:1:3 S Y=$O(ECXPRV("")) I Y'="" S @("ECU"_I)=+ECXPRV(Y) K ECXPRV(Y) + S:$L(ECU1) ECXPPC1=$$PRVCLASS^ECXUTL(ECU1,ECDT),ECU1A="2"_$P(ECU1,";") + S:$L(ECU2) ECXPPC2=$$PRVCLASS^ECXUTL(ECU2,ECDT),ECU2A="2"_$P(ECU2,";") + S:$L(ECU3) ECXPPC3=$$PRVCLASS^ECXUTL(ECU3,ECDT),ECU3A="2"_$P(ECU3,";") + ;change for version 2 where ECP is a variable pointer and we want to + ;expand it category = category or null if stored as 0 + D:ECP[";" + .S ECP=$S(ECP["ICPT":$P(^ICPT(+ECP,0),U)_"01",ECP<90000:$P(^EC(725,+ECP,0),U,2)_"N",1:$P(^EC(725,+ECP,0),U,2)_"L"),ECC=$S(ECC:ECC,1:"") + ;pick up EC to PCE data from "P" in File 721 + S ECPCE=$G(^ECH(ECDA,"P")),ECPCE1=$P(ECPCE,U),ECPCE2=$P(ECPCE,U,2) + S ECPCE7=$S($P(ECPCE,U,7)=1:"Y",1:"N") + S ECXCMOD="" + I $D(^ECH(ECDA,"MOD")) D + .S MOD=0,M="" + .F S MOD=$O(^ECH(ECDA,"MOD",MOD)) Q:'MOD S M=$P(^(MOD,0),U) D + ..I M S ECXCMOD=ECXCMOD_M_";" + .K MOD,M + S:ECP?1.N ECP=$$CPT^ECXUTL3($E(ECP,1,5),"",ECV) + S ECXCPT=$$CPT^ECXUTL3(ECPCE1,ECXCMOD,ECV) + ; + ;- Observation Patient Indicator (YES/NO) + S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECDSS) + ; + ;- CNH status (YES/NO) + S ECXCNH=$$CNHSTAT^ECXUTL4(ECXDFN) + ; + ;- encounter classification + S (ECXAO,ECXECE,ECXHNC,ECXMIL,ECXIR)="",ECXVISIT=$P(ECCH,U,21) + I ECXVISIT'="" D + .D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) I ECXERR K ECXERR Q + .S ECXAO=$G(ECXVIST("AO")),ECXECE=$G(ECXVIST("PGE")) + .S ECXHNC=$G(ECXVIST("HNC")),ECXMIL=$G(ECXVIST("MST")),ECXIR=$G(ECXVIST("IR")) + ; - Head and Neck Cancer Indicator + S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) + ; + ; - Get national patient record flag Indicator if exist + D NPRF^ECXUTL5 + ; + ; - If no encounter number don't file record + S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECDT,ECXTS,ECXOBS,ECHEAD,ECDSS,ECCS) + D:ECXENC'="" FILE + Q + ; +FILE ;file record in #727.815 + ;node0 + ;ecode=inst ECL^dfn ECXDFN^ssn ECXSSN^name ECXPNM^i/o status ECXA^day^ + ;DSS unit ECDU^category ECC^procedure ECP^volume ECV^ + ;cost center ECCS^ordering sec ECO^section ECM^ + ;provider ECU1A^prov per cls ECXPPC1^prov 2 ECU2A^prov#2 per cls ECXPPC2 + ;^prov 3 ECU3A^prov#3 per cls ECXPPC3^^mov # ECXMN^treat spec ECXTS + ;^time ECTM^primary care team ECPTTM^primary care provider ECPTPR + ;^pce cpt code (ECXCPT)^primary icd-9 code ECXICD9^secondary icd-9 + ;ECXICD91^secondary icd-9 ECXICD92^secondary icd-9 ECXICD93^secondary + ;icd-9 ECXICD94^agent orange ECXAST^radiation exposure ECXRST^ + ;environmental contaminants ECXEST^service connected ECPTPR^sent to pce + ;ECPCE7^^dss identifier ECDSS^dss dept + ;node1 + ;mpi ECXMPI^dss dept ECXDSSD^provider npi ECXPRV2^ + ;provider #2 npi ECU2NPI^provider #3 npi ECU3NPI^^ + ;pc provider npi ECPTNPI^pc prov person class ECCLAS^ + ;assoc pc prov ECASPR^assoc pc prov person class ECCLAS2^ + ;assoc pc prov npi ECASNPI^ + ;divison ECXDIV^mst status ECXMST^dom ECXDOM^date of birth ECXDOB^ + ;enrollment category ECXCAT^ enrollment status ECXSTAT^enrollment + ;priority ECXPRIOR^period of service ECXPOS^purple heart indicator + ;ECXPHI^observ pat ind ECXOBS^encounter num ECXENC^ + ;ao loc ECXAOL^ord div ECXODIV^contr st dt ECXCSDT^ + ;contr end dt ECXCEDT^contr typ ECXCTYP^CNH stat ECXCNH^ + ;production division ECXPDIV^eligibility ECXELIG^ + ;head & neck cancer ind. ECXHNCI^ethnicity ECXETH^race1 ECXRAC1 + ;enrollment location ECXENRL^^enrollment priority + ;ECXPRIOR_enrollment subgroup ECXSBGRP^user enrollee ECXUESTA^patient + ;type ECXPTYPE^combat vet elig ECXCVE^combat vet elig end date + ;ECXCVEDT^enc cv eligible ECXCVENC^national patient record flag + ;ECXNPRFI^emerg response indic(FEMA) ECXERI^agent orange indic ECXAO^ + ;environ contam ECXECE^head/neck cancer ECXHNC^encntr mst ECXMIL + ;^radiation ECXIR + N DA,DIK + S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 + S ECODE=EC7_U_EC23_U_ECL_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U + S ECODE=ECODE_$$ECXDATE^ECXUTL(ECDT,ECXYM)_U_ECDU_U_ECC_U + S ECODE=ECODE_ECP_U_ECV_U_ECCS_U_ECO_U_ECM_U_ECU1A_U_ECXPPC1_U + S ECODE=ECODE_ECU2A_U_ECXPPC2_U_ECU3A_U_ECXPPC3_U_U_ECXMN_U + S ECODE=ECODE_ECXTS_U_ECTM_U + S ECODE=ECODE_ECPTTM_U_ECPTPR_U_ECXCPT_U_ECXICD9_U + S ECODE=ECODE_ECXICD91_U_ECXICD92_U_ECXICD93_U + S ECODE=ECODE_ECXICD94_U_ECXAST_U_ECXRST_U_ECXEST_U + S ECODE=ECODE_ECSC_U_ECPCE7_U_U_ECDSS_U_U + S ECODE1=ECXMPI_U_ECXDSSD_U_ECU1NPI_U_ECU2NPI_U_ECU3NPI_U_ECCLAS_U + S ECODE1=ECODE1_ECPTNPI_U_ECASPR_U_ECCLAS2_U_ECASNPI_U_ECXDIV_U + S ECODE1=ECODE1_ECXMST_U_ECXDOM_U_ECXDOB_U_ECXCAT_U_ECXSTAT_U + S ECODE1=ECODE1_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPOS_U_ECXPHI_U_ECXOBS_U_ECXENC_U_ECXAOL_U + S ECODE1=ECODE1_ECXODIV_U_ECXCSDT_U_ECXCEDT_U_ECXCTYP_U_ECXCNH_U_ECXPDIV_U + S ECODE1=ECODE1_ECXELIG_U_ECXHNCI_U_ECXETH_U_ECXRC1 + I ECXLOGIC>2003 S ECODE1=ECODE1_U_ECXENRL_U + I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U + I ECXLOGIC>2004 S ECODE2=ECXCVEDT_U_ECXCVENC_U_ECXNPRFI + I ECXLOGIC>2006 S ECODE2=ECODE2_U_ECXERI_U_ECXAO_U_ECXECE_U_ECXHNC_U_ECXMIL_U_ECXIR_U + S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,^ECX(ECFILE,EC7,2)=$G(ECODE2),ECRN=ECRN+1 + S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA + I $D(ZTQUEUED),$$S^%ZTLOAD + Q + ; +SETUP ;Set required input for ECXTRAC + S ECHEAD="ECS" + D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) + Q + ; +QUE ; entry point for the background requeuing handled by ECXTAUTO + D SETUP,QUE^ECXTAUTO,^ECXKILL Q diff --git a/r/DSS_EXTRACTS-ECX/ECXFELOC.m b/r/DSS_EXTRACTS-ECX/ECXFELOC.m index b043038d..e8f660eb 100644 --- a/r/DSS_EXTRACTS-ECX/ECXFELOC.m +++ b/r/DSS_EXTRACTS-ECX/ECXFELOC.m @@ -1,62 +1,60 @@ -ECXFELOC ;BIR/DMA,CML-Print Feeder Locations; [ 05/07/96 8:41 AM ] ; 6/12/07 6:29am - ;;3.0;DSS EXTRACTS;**1,8,105**;Dec 22, 1997;Build 70 -EN ;entry point from option - W !!,"Print list of feeder locations.",! S QFLG=1 - K %ZIS S %ZIS="Q" D ^%ZIS Q:POP - I $D(IO("Q")) S ZTDESC="Feeder Location List (DSS)",ZTRTN="START^ECXFELOC" D ^%ZTLOAD D ^%ZISC G OUT - U IO -START ;queued entry point - I '$D(DT) S DT=$$HTFM^XLFDT(+$H) - K ^TMP($J) S (QFLG,PG)=0,$P(LN,"-",81)="" -LAB S EC=0 F S EC=$O(^LRO(68,EC)) Q:'EC I $D(^(EC,0)) S EC1=^(0),^TMP($J,"LAB",$P(EC1,U,11),EC)=$P(EC1,U) -ECS S EC=0 I $P($G(^EC(720.1,1,0)),U,2) D G IV - .F S EC=$O(^ECJ(EC)) Q:'EC I $D(^(EC,0)) S EC1=$P(^(0),"-",1,2),EC2=$P($G(^ECD(+$P(EC1,"-",2),0)),U),^TMP($J,"ECS",EC1,EC1)=EC2 - F S EC=$O(^ECK(EC)) Q:'EC I $D(^(EC,0)) S EC1=$P(^(0),"-",1,2),EC2=$P($G(^ECD(+$P(EC1,"-",2),0)),U),^TMP($J,"ECS",EC1,EC1)=EC2 -IV S EC=0 F S EC=$O(^DG(40.8,EC)) Q:'EC I $D(^DG(40.8,EC,0)) S EC1=$E($P(^(0),U),1,30),^TMP($J,"IVP","IVP"_EC,EC)="IV Pharmacy-"_EC1 -CLI S EC=0 F S EC=$O(^SC(EC)) Q:'EC I $D(^(EC,0)) S EC1=^(0),ECS=$P(EC1,U,15),ECSC=$P($G(^DIC(40.7,+$P(EC1,U,7),0)),U,2),ECD=$P(EC1,U) S:'ECS ECS=1 D - .I $P(EC1,U,17)'="Y",$P(EC1,U,3)="C" S DAT=$G(^SC(EC,"I")),ID=+DAT,RD=$P(DAT,U,2) I 'ID!(ID>DT)!(RD&(RD0 G V6 - ;dbia (#4689) - S EC=0 F S EC=$O(^DIC(59,EC)) Q:'EC I $D(^(EC,0)) S EC1=$E($P(^(0),U),1,30),^TMP($J,"PRE","PRE"_EC,EC)="Prescriptions-"_EC1 - G RAD -V6 S EC=0 F S EC=$O(@ARRAY@(EC)) Q:'EC I $D(^(EC)) S EC1=$E(@ARRAY@(EC,.01),1,30),^TMP($J,"PRE","PRE"_EC,EC)="Prescriptions-"_EC1 - K @ARRAY -RAD S EC=0 F S EC=$O(^RA(79,EC)),EC1=0 Q:'EC I $D(^(EC,0)) S ECD=$P(^(0),U) F S EC1=$O(^RA(79.2,EC1)) Q:'EC1 I $D(^(EC1,0)) S ECD1=$P(^(0),U),^TMP($J,"RAD",EC_"-"_EC1,EC_"-"_EC1)=ECD_"-"_ECD1 -NUR S EC=0 F S EC=$O(^NURSF(211.4,EC)) Q:'EC I $D(^(EC,0)) S EC1=$P(^(0),U),EC1=$P($G(^SC(+EC1,0)),U),^TMP($J,"NUR",EC,EC)=EC1 -SUR F EC=1:1:14 S EC2=$P($T(@EC),";",3) F EC1="I","A","D","M","P","C","S" S EC3=$P($T(@EC1),";",3),^TMP($J,"SUR",$P(EC2,U)_EC1,EC)=$P(EC2,U,2)_"-"_EC3 -1 ;;ORGE^GENERAL PURPOSE OPERATING ROOM -2 ;;OROR^ORTHOPEDIC OPERATING ROOM -3 ;;ORCA^CARDIAC OPERATING ROOM -4 ;;ORNE^NEUROSURGERY OPERATING ROOM -5 ;;ORCN^CARDIAC/NEURO OPERATING ROOM -6 ;;ORAM^AMBULATORY OPERATING ROOM -7 ;;ORIN^INTENSIVE CARE UNIT -8 ;;OREN^ENDOSCOPY ROOM -9 ;;ORCY^CYSTOSCOPY ROOM -10 ;;ORWA^WARD -11 ;;ORCL^CLINIC -12 ;;ORDE^DEDICATED ROOM -13 ;;OROT^OTHER LOCATION -14 ;;ORNO^UNKNOWN -I ;;IMPLANTS -A ;;ANESTHESIA TIME -D ;;SURGERY TIME (DENTAL) -M ;;SURGERY TIME (MEDICINE) -P ;;SURGERY TIME (PSYCH) -C ;;SURGERY TIME (SPINAL CORD) -S ;;SURGERY TIME (SURGERY) -UDP S EC=0 F S EC=$O(^DG(40.8,EC)) Q:'EC I $D(^DG(40.8,EC,0)) S EC1=$E($P(^(0),U),1,30),^TMP($J,"UDP","UDP"_EC,EC)="Unit Dose Medications-"_EC1 -DEN S EC=0 F S EC=$O(^DENT(225,EC)) Q:'EC I $D(^(EC,0)) S EC1=$P(^(0),U),^TMP($J,"DEN",EC1,EC)="Dental "_EC1 - ; -PRINT ; - S EC="" F S EC=$O(^TMP($J,EC)),EC1="" Q:EC="" Q:QFLG D HEAD Q:QFLG F S EC1=$O(^TMP($J,EC,EC1)),EC2="" Q:EC1="" Q:QFLG F S EC2=$O(^TMP($J,EC,EC1,EC2)) Q:EC2="" Q:QFLG D - .W !,?5,EC1,?23,^(EC2) I $Y+3>IOSL D HEAD Q:QFLG -OUT I $E(IOST)="C"&('QFLG) S DIR(0)="E" D D ^DIR K DIR - .S SS=22-$Y F JJ=1:1:SS W ! - K ^TMP($J),DAT,EC,EC1,EC2,EC3,ECD,ECD1,ECS,ECSC,ID,JJ,LN,PG,POP,QFLG,RD,SS,X,Y - W:$E(IOST)'="C" @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" Q -HEAD ; - I $E(IOST)="C" S SS=22-$Y F JJ=1:1:SS W ! - I $E(IOST)="C",PG>0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q - S PG=PG+1 W:$Y!($E(IOST)="C") @IOF W !,?15,"Feeder Location List For Feeder System ",EC,?72,"Page: ",PG,!!,?5,"FEEDER LOCATION",?23,"DESCRIPTION",!,LN - Q +ECXFELOC ;BIR/DMA,CML-Print Feeder Locations; [ 05/07/96 8:41 AM ] + ;;3.0;DSS EXTRACTS;**1,8**;Dec 22, 1997 +EN ;entry point from option + W !!,"Print list of feeder locations.",! S QFLG=1 + K %ZIS S %ZIS="Q" D ^%ZIS Q:POP + I $D(IO("Q")) S ZTDESC="Feeder Location List (DSS)",ZTRTN="START^ECXFELOC" D ^%ZTLOAD D ^%ZISC G OUT + U IO +START ;queued entry point + I '$D(DT) S DT=$$HTFM^XLFDT(+$H) + K ^TMP($J) S (QFLG,PG)=0,$P(LN,"-",81)="" +LAB S EC=0 F S EC=$O(^LRO(68,EC)) Q:'EC I $D(^(EC,0)) S EC1=^(0),^TMP($J,"LAB",$P(EC1,U,11),EC)=$P(EC1,U) +ECS S EC=0 I $P($G(^EC(720.1,1,0)),U,2) D G IV + .F S EC=$O(^ECJ(EC)) Q:'EC I $D(^(EC,0)) S EC1=$P(^(0),"-",1,2),EC2=$P($G(^ECD(+$P(EC1,"-",2),0)),U),^TMP($J,"ECS",EC1,EC1)=EC2 + F S EC=$O(^ECK(EC)) Q:'EC I $D(^(EC,0)) S EC1=$P(^(0),"-",1,2),EC2=$P($G(^ECD(+$P(EC1,"-",2),0)),U),^TMP($J,"ECS",EC1,EC1)=EC2 +IV S EC=0 F S EC=$O(^DG(40.8,EC)) Q:'EC I $D(^DG(40.8,EC,0)) S EC1=$E($P(^(0),U),1,30),^TMP($J,"IVP","IVP"_EC,EC)="IV Pharmacy-"_EC1 +CLI S EC=0 F S EC=$O(^SC(EC)) Q:'EC I $D(^(EC,0)) S EC1=^(0),ECS=$P(EC1,U,15),ECSC=$P($G(^DIC(40.7,+$P(EC1,U,7),0)),U,2),ECD=$P(EC1,U) S:'ECS ECS=1 D + .I $P(EC1,U,17)'="Y",$P(EC1,U,3)="C" S DAT=$G(^SC(EC,"I")),ID=+DAT,RD=$P(DAT,U,2) I 'ID!(ID>DT)!(RD&(RDIOSL D HEAD Q:QFLG +OUT I $E(IOST)="C"&('QFLG) S DIR(0)="E" D D ^DIR K DIR + .S SS=22-$Y F JJ=1:1:SS W ! + K ^TMP($J),DAT,EC,EC1,EC2,EC3,ECD,ECD1,ECS,ECSC,ID,JJ,LN,PG,POP,QFLG,RD,SS,X,Y + W:$E(IOST)'="C" @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" Q +HEAD ; + I $E(IOST)="C" S SS=22-$Y F JJ=1:1:SS W ! + I $E(IOST)="C",PG>0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q + S PG=PG+1 W:$Y!($E(IOST)="C") @IOF W !,?15,"Feeder Location List For Feeder System ",EC,?72,"Page: ",PG,!!,?5,"FEEDER LOCATION",?23,"DESCRIPTION",!,LN + Q diff --git a/r/DSS_EXTRACTS-ECX/ECXKILL.m b/r/DSS_EXTRACTS-ECX/ECXKILL.m index aa479c6b..4081c963 100644 --- a/r/DSS_EXTRACTS-ECX/ECXKILL.m +++ b/r/DSS_EXTRACTS-ECX/ECXKILL.m @@ -1,39 +1,36 @@ -ECXKILL ;BIR/DMA,PTD-Kill Local Variables ; 5/30/2007 - ;;3.0;DSS EXTRACTS;**9,8,21,24,31,39,49,84,89,92,105**;Dec 22, 1997;Build 70 - ; - K %,%DT,%Y,%ZIS,A,A1,A2,ABR,B,BY,D,D0,D1,DA,DAT,DATA,DATA1,DATA2,DATA6 - K DATAOP,DD,DFN,DHDH,DIC,DIE,DIK,DINUM,DIQ - K ECDAPRNP,ECDPRNPI,ECISNPI,ECDOCNPI - K ECU1NPI,ECU2NPI,ECU3NPI - K DIR,DIRUT,DO,DR,DTOUT,DUOUT,EC,EC0,EC1,EC10,EC11,EC16,EC2,EC23,EC2NODE - K EC3,EC42,EC50,EC6,EC7,ECA,ECAC,ECACA,ECAD,ECADM,ECALL - K ECANE,ECAO,ECARG,ECAS,ECAT,ECATSV,ECB,ECC,ECCA,ECCAN,ECCAT,ECCH,ECCN - K ECCNT,ECCS,ECCSC,ECD,ECD0,ECD1,ECDA,ECDAL,ECDAT - K ECDATA,ECDATA1,ECDATE,ECDEN,ECDEX,ECDF,ECDFN,ECDFN0,ECDI,ECDIA,ECDIF - K ECDIV,ECDL,ECDN,ECDNEW,ECDO,ECDOC,ECDR,ECDRG,ECDS,ECDSSU,ECDT,ECDTTM - K ECDU,ECEC0,ECED,ECED1,ECEDN,ECEDNEW,ECF,ECF1,ECFD,ECFDT,ECFILE,ECFK - K ECFL,ECFR,ECGRP,ECH,ECHD,ECHEAD,ECI,ECID,ECIEN,ECIFN,ECIN - K ECINST,ECINV,ECIV,ECJ,ECK,ECL,ECL1,ECLAN,ECLAST,ECLDT,ECLINK,ECLIST - K ECLL,ECLN,ECLOC,ECLRN,ECLX,ECLY,ECM,ECMAX,ECMIN - K ECXMISS,ECMN,ECMOD,ECMODS,ECMORE,ECMS,ECMSG,ECMSN,ECMT,ECMW,ECMY,ECN - K ECNA,ECNDC,ECNDF,ECNFC,ECNL,ECNO,ECNODE,ECNOGO - K ECNT,ECO,ECO0,ECO1,ECO2,ECOB,ECODE,ECODE0,ECODE1,ECODE2,ECOLD,ECONE,ECOPAY - K ECATTNPI,ECPWNPI,ECXUSNPI,ECPWNPI,ECXOEF,ECXOEFDT,ECPLACE - K ECOPAYT,ECORTY,ECOS,ECP,ECPACK,ECPCE,ECPCE1,ECPCE2,ECPCE3,ECPCE4 - K ECPCE5,ECPCE6,ECPCE7,ECPIECE,ECPN,ECPRC,ECPRO,ECODE2 - K ECPROF,ECPT,ECPTF,ECPTPR,ECPTTM,ECQ,ECQT,ECQTY,ECRD,ECRE,ECRED,ECREF - K ECRFL,ECRN,ECROU,ECRR,ECRS,ECRSD,ECRTN,ECRX,ECS,ECSA,ECSC - K ECSD,ECSD1,ECSDN,ECSN,ECSR,ECSS,ECST,ECSTOP,ECSU,ECT,ECT1,ECTD,ECTD1 - K ECTEMP,ECTM,ECTNTL,ECTOTAL,ECTREAT,ECTRT,ECTS,ECTY,ECXLOGIC,ECXDATES,ECXEST,ECXECE - D ^ECXKILL1 - ; -AUDIT ;kill audit report variables, close slave printer - K %DT,ECX,ECXARRAY,ECXACC,ECXALL,ECXAUD,ECXCODE,ECXD,ECXDEF,ECXDESC,ECXDIV - K ECXRCST,ECXRQST,ECXEND,ECXERR,ECXEXT,ECXHEAD,ECXLOC,ECXPGM,ECXPHCPC - K ECXPRIME,ECXPRO,ECXREPT,ECXRUN,ECXSAVE,ECXSTART,ECXSRCE - K ECXCTAMT,ECXFEKEY,ECXFELOC,ECXFORM,ECXGRPR,ECXHCPC,ECXPHCPC,ECXHCPCS - K ECXLAB,ECXLLC,ECXLMC,ECXQTY,ECXREQ,ECXSTAT,ECXTYPE - K IO("Q"),POP,DIR,DIC,DIE,DA,DR,DO,DIRUT,DUOUT,DTOUT - K ^TMP($J) - I IO=IO(0),IOST'="C" D ^%ZISC - Q +ECXKILL ;BIR/DMA,PTD-Kill Local Variables ; 9/13/05 10:24am + ;;3.0;DSS EXTRACTS;**9,8,21,24,31,39,49,84,89**;Dec 22, 1997 + ; + K %,%DT,%Y,%ZIS,A,A1,A2,ABR,B,BY,D,D0,D1,DA,DAT,DATA,DATA1,DATA2,DATA6 + K DATAOP,DD,DFN,DHDH,DIC,DIE,DIK,DINUM,DIQ + K DIR,DIRUT,DO,DR,DTOUT,DUOUT,EC,EC0,EC1,EC10,EC11,EC16,EC2,EC23,EC2NODE + K EC3,EC42,EC50,EC6,EC7,ECA,ECAC,ECACA,ECAD,ECADM,ECALL + K ECANE,ECAO,ECARG,ECAS,ECAT,ECATSV,ECB,ECC,ECCA,ECCAN,ECCAT,ECCH,ECCN + K ECCNT,ECCS,ECCSC,ECD,ECD0,ECD1,ECDA,ECDAL,ECDAT + K ECDATA,ECDATA1,ECDATE,ECDEN,ECDEX,ECDF,ECDFN,ECDFN0,ECDI,ECDIA,ECDIF + K ECDIV,ECDL,ECDN,ECDNEW,ECDO,ECDOC,ECDR,ECDRG,ECDS,ECDSSU,ECDT,ECDTTM + K ECDU,ECEC0,ECED,ECED1,ECEDN,ECEDNEW,ECF,ECF1,ECFD,ECFDT,ECFILE,ECFK + K ECFL,ECFR,ECGRP,ECH,ECHD,ECHEAD,ECI,ECID,ECIEN,ECIFN,ECIN + K ECINST,ECINV,ECIV,ECJ,ECK,ECL,ECL1,ECLAN,ECLAST,ECLDT,ECLINK,ECLIST + K ECLL,ECLN,ECLOC,ECLRN,ECLX,ECLY,ECM,ECMAX,ECMIN + K ECXMISS,ECMN,ECMOD,ECMODS,ECMORE,ECMS,ECMSG,ECMSN,ECMT,ECMW,ECMY,ECN + K ECNA,ECNDC,ECNDF,ECNFC,ECNL,ECNO,ECNODE,ECNOGO + K ECNT,ECO,ECO0,ECO1,ECO2,ECOB,ECODE,ECODE0,ECODE1,ECOLD,ECONE,ECOPAY + K ECOPAYT,ECORTY,ECOS,ECP,ECPACK,ECPCE,ECPCE1,ECPCE2,ECPCE3,ECPCE4 + K ECPCE5,ECPCE6,ECPCE7,ECPIECE,ECPN,ECPRC,ECPRO,ECODE2 + K ECPROF,ECPT,ECPTF,ECPTPR,ECPTTM,ECQ,ECQT,ECQTY,ECRD,ECRE,ECRED,ECREF + K ECRFL,ECRN,ECROU,ECRR,ECRS,ECRSD,ECRTN,ECRX,ECS,ECSA,ECSC + K ECSD,ECSD1,ECSDN,ECSN,ECSR,ECSS,ECST,ECSTOP,ECSU,ECT,ECT1,ECTD,ECTD1 + K ECTEMP,ECTM,ECTNTL,ECTOTAL,ECTREAT,ECTRT,ECTS,ECTY,ECXLOGIC,ECXDATES,ECXEST,ECXECE + D ^ECXKILL1 + ; +AUDIT ;kill audit report variables, close slave printer + K ECX,ECXARRAY,ECXACC,ECXALL,ECXAUD,ECXCODE,ECXD,ECXDEF,ECXDESC,ECXDIV + K ECXRCST,ECXRQST,ECXEND,ECXERR,ECXEXT,ECXHEAD,ECXLOC,ECXPGM,ECXPHCPC + K ECXPRIME,ECXPRO,ECXREPT,ECXRUN,ECXSAVE,ECXSTART,ECXSRCE + K ECXCTAMT,ECXFEKEY,ECXFELOC,ECXFORM,ECXGRPR,ECXHCPC,ECXPHCPC,ECXHCPCS + K ECXLAB,ECXLLC,ECXLMC,ECXQTY,ECXREQ,ECXSTAT,ECXTYPE + K IO("Q"),POP,DIR,DIC,DIE,DA,DR,DO,DIRUT,DUOUT,DTOUT + K ^TMP($J) + I IO=IO(0),IOST'="C" D ^%ZISC + Q diff --git a/r/DSS_EXTRACTS-ECX/ECXLABN.m b/r/DSS_EXTRACTS-ECX/ECXLABN.m index d68c7bf2..dbfca31e 100644 --- a/r/DSS_EXTRACTS-ECX/ECXLABN.m +++ b/r/DSS_EXTRACTS-ECX/ECXLABN.m @@ -1,154 +1,149 @@ -ECXLABN ;ALB/JAP,BIR/CML-Lab Extract for DSS (New Format - With LMIP Codes) ; 10/23/07 3:01pm - ;;3.0;DSS EXTRACTS;**1,11,8,13,28,24,30,31,32,33,39,42,46,70,71,80,92,107,105**;Dec 22, 1997;Build 70 -BEG ;entry point - D SETUP I ECFILE="" Q - D ^ECXTRAC,^ECXKILL - Q - ; -START ; entry when queued - K ^LRO(64.03),^TMP($J,"ECXP") - N ECDOCPC - S LRSDT=ECSD,LREDT=ECED,QFLG=0 - D ^LRCAPDSS - ;quit if no completion date for API compile - I '$P($G(^LRO(64.03,1,1,1,0)),U,4) Q - ;quit if tasked and user sends stop request - I $D(ZTQUEUED),$$S^%ZTLOAD D Q - .S QFLG=1 - .K ^LRO(64.03) S ^LRO(64.03,0)="WKLD LOG FILE^64.03^" - ;otherwise, continue - K ECXDD D FIELD^DID(64.03,1,,"SPECIFIER","ECXDD") - S ECPROF=$E(+$P(ECXDD("SPECIFIER"),"P",2)),ECLRN=1 K ECXDD - F S ECLRN=$O(^LRO(64.03,ECLRN)) Q:'ECLRN D Q:QFLG - .Q:'$D(^LRO(64.03,ECLRN,0)) - .S EC1=^LRO(64.03,ECLRN,0),ECDOC=ECPROF_$P(EC1,U,2) - .S ECDOCNPI=$$NPI^XUSNPI("Individual_ID",$P(EC1,U,2),$P(EC1,U,4)) - .S:+ECDOCNPI'>0 ECDOCNPI="" S ECDOCNPI=$P(ECDOCNPI,U) - .S ECLOC=$P(EC1,U,15),EC=$P(EC1,U,3),ECDOCPC=$$PRVCLASS^ECXUTL($P(EC1,U,2),$P(EC1,U,4)) - .I EC]"" D GET - K ^LRO(64.03),^TMP($J,"ECXP") S ^LRO(64.03,0)="WKLD LOG FILE^64.03^" - K ECDOCNPI,ECXAGC,ECXL1,ECXL2 - Q - ; -GET ;get data - N X,ECXSTN,QFLAG - S ECF=$S($P(EC,";",2)="DPT(":2,$P(EC,";",2)="LRT(67,":67,1:0) Q:'ECF - S ECIFN=$P(EC,";"),QFLAG=0 - ;resolve ecloc - S ECXL1=+$P(ECLOC,";",1),ECXL2=$P(ECLOC,";",2) - I ECF=2 S ECLOC=$S(ECXL1>0:ECXL1,1:"") I ECXL2]"",ECXL2'="SC(" S ECLOC="" - I ECF=67 D S ECLOC=ECXSTN - .S (ECXSTN,ECXAGC)="" - .I (ECXL2'="DIC(4,")!('$D(^DIC(4,ECXL1))) S ECXSTN="XXXXX",ECXAGC="XX" Q - .S ECXSTN=$P(^DIC(4,ECXL1,"99"),U,1),ECXAGC=$E($P(^(99),U,5),1,2) - .S:ECXSTN="" ECXSTN="ZZZZZ" S:ECXAGC="" ECXAGC="ZZ" - S ECDT=$P(EC1,U,13),ECD=$P(ECDT,"."),ECTM=$$ECXTIME^ECXUTL(ECDT) - S ECWKLD=$P(EC1,U,11),ECWK="" I $D(^LAM(ECWKLD,0)) S ECWK=$P(^(0),U,2) - S (ECXADMDT,ECTREAT,ECNA,ECSN,ECMN,ECPTTM,ECPTPR,ECCLAS)="",ECA="O",ECXERR=0 - S (ECPTNPI,ECASPR,ECCLAS2,ECASNPI)="" - ;get the patient data if record is in file #2 - I ECF=2 D PAT(ECIFN,ECDT,.ECXERR) - Q:ECXERR - ;get patient data if record is in file #67 - I ECF=67 S ECSN="000123456",ECNA="RFRL" I $D(^LRT(67,ECIFN,0)) D Q:QFLAG - .S ECXMPI="",EC0=^LRT(67,ECIFN,0),ECNA=$E($P($P(EC0,U),",")_" ",1,4) - .S ECSN=$P(EC0,U,9),ECXERI="" D - ..S ECNA=$TR(ECNA,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") - ..I ECSN="" S ECSN="000123456" Q - ..S ECSN=$TR(ECSN," "),ECSN=$TR(ECSN,"-") - ..I ($L(ECSN)<9)!($L(ECSN)>10) S ECSN="000123456" Q - ..I $L(ECSN)=9,ECSN'?9N S ECSN="000123456" Q - ..I $L(ECSN)=10,ECSN'?9N1"P" S ECSN="000123456" - ..I '$$SSN^ECXUTL5(ECSN,ECF) S QFLAG=1 - ; - ;- Only set treating spec (TS) to TS in file #64.03 if it does not exist - I ECA="I",ECTREAT="" S ECTREAT=$P($G(^DIC(45.7,+$P(EC1,U,10),0)),U,2) - S (ECXDOM,ECXDSSD)="" - S X=$G(^ECX(727.831,+ECTREAT,0)) S:X'="" ECXDOM=$P(X,U,2) - ; - ;- Get ordering stop code and ordering date - S ECXORDST=+$P(EC1,U,15),ECXORDST=$S(ECXORDST:$P($G(^ECX(728.44,ECXORDST,0)),U,2),1:"") - S ECXORDDT=$S($P(EC1,U,14):$$ECXDATE^ECXUTL($P(EC1,U,14),ECXYM),1:"") - ; - ;- Get Production Division - ECXDIEN added p-80 - N ECXPDIV,ECXDIEN S ECXDIEN=$O(^DIC(4,"D",ECINST,"")),ECXPDIV=$$RADDIV^ECXDEPT(ECXDIEN) ;P-46 - K ECXDIEN - ; - ;- Observation patient indicator (YES/NO) - S ECXOBS=$$OBSPAT^ECXUTL4(ECA,ECTREAT) - ; - ;- If no encounter number don't file record - S ECXENC=$$ENCNUM^ECXUTL4(ECA,ECSN,ECXADMDT,ECD,ECTREAT,ECXOBS,ECHEAD,,) Q:ECXENC="" - ;create extract record only if patient name and accession area exist - I ECNA]"" S ECT=$P(EC1,U,8),ECURG=$P(EC1,U,9),EC=+$P(EC1,U,7) I EC D - .S:ECF=2 ECACA=EC_U_$P($G(^LRO(68,EC,0)),U,11) - .S:ECF=67 ECACA=ECXAGC_U_$P($G(^LRO(68,EC,0)),U,11) - .D FILE - Q - ; -PAT(ECXDFN,ECXDATE,ECXERR) ;get/set patient data - N X,OK,PT - ;get data - I $D(^TMP($J,"ECXP",ECXDFN)) D - .S PT=^TMP($J,"ECXP",ECXDFN),ECNA=$P(PT,U) - .S ECSN=$P(PT,U,2),ECXMPI=$P(PT,U,3),ECXERI=$P(PT,U,4) - ;set data and save for later - I '$D(^TMP($J,"ECXP",ECXDFN)) D Q:'OK - .K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECSD,"."),"1;3",.ECXPAT) - .I 'OK S ECXERR=1 Q - .S ECNA=ECXPAT("NAME"),ECSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI") - .S ECXERI=ECXPAT("ERI") - .S ^TMP($J,"ECXP",ECXDFN)=ECNA_U_ECSN_U_ECXMPI_U_ECXERI - ;get date specific data - S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECA=$P(X,U),ECMN=$P(X,U,2),ECTREAT=$P(X,U,3),ECXADMDT=$P(X,U,4) - S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXDATE,"."),ECPROF) - S ECPTTM=$P(X,U,1),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4) - S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7) - Q - ; -FILE ;file record - ;node0 - ;facility^patient number^SSN (or equivalent)^name^in/out ECA^ - ;day^accession area^abbreviation^test^urgency^treating spec^ - ;location^provider and file^ - ;movement number^file^time^workload code^primary care team^ - ;primary care provider - ;node1 - ;mpi^dss dept^provider npi^pc provider npi^pc prov person class^ - ;assoc pc prov^assoc pc prov person class^assoc pc prov npi^ - ;dom ECXDOM^observ pat ind ECXOBS^encounter num ECXENC^ - ;ord stop code ECXORDST^ord date ECXORDDT^production division - ;ECXPDIV^^ordering provider person class^emergency response indicator - ;(FEMA) ECXERI^associate pc provider npi ECASNPI^primary care provider - ;npi ECPTNPI^provider npi ECDOCNPI - ;ECDOCPC - N DA,DIK - S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 - S ECODE=EC7_U_EC23_U_ECINST_U_ECIFN_U_ECSN_U_ECNA_U_ECA_U - S ECODE=ECODE_$$ECXDATE^ECXUTL(ECD,ECXYM)_U_ECACA_U_ECT_U_ECURG_U - ;convert specialty to PTF Code for transmission - N ECXDATA - S ECXDATA=$$TSDATA^DGACT(42.4,+ECTREAT,.ECXDATA) - S ECTREAT=$G(ECXDATA(7)) - ;done - S ECODE=ECODE_ECTREAT_U_ECLOC_U_ECDOC_U_ECMN_U_ECF_U_ECTM_U_ECWK_U - S ECODE=ECODE_ECPTTM_U_ECPTPR_U - ;(ECACA=acc area^abbreviation) - S ECODE1=ECXMPI_U_ECXDSSD_U_U_U_ECCLAS_U_ECASPR_U - S ECODE1=ECODE1_ECCLAS2_U_U_ECXDOM_U_ECXOBS_U_ECXENC_U - S ECODE1=ECODE1_ECXORDST_U_ECXORDDT_U_ECXPDIV_U - I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECDOCPC - I ECXLOGIC>2006 S ECODE1=ECODE1_U_ECXERI - I ECXLOGIC>2007 S ECODE1=ECODE1_U_ECASNPI_U_ECPTNPI_U_ECDOCNPI - S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1 - S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA - I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 - Q - ; -SETUP ;Set required input for ECXTRAC - S ECHEAD="LAB" - D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) - Q - ; -QUE ; entry point for the background requeuing handled by ECXTAUTO - D SETUP,QUE^ECXTAUTO,^ECXKILL Q +ECXLABN ;ALB/JAP,BIR/CML-Lab Extract for DSS (New Format - With LMIP Codes) ; 4/25/07 8:52am + ;;3.0;DSS EXTRACTS;**1,11,8,13,28,24,30,31,32,33,39,42,46,70,71,80,92,107**;Dec 22, 1997;Build 9 +BEG ;entry point + D SETUP I ECFILE="" Q + D ^ECXTRAC,^ECXKILL + Q + ; +START ; entry when queued + K ^LRO(64.03),^TMP($J,"ECXP") + N ECDOCPC + S LRSDT=ECSD,LREDT=ECED,QFLG=0 + D ^LRCAPDSS + ;quit if no completion date for API compile + I '$P($G(^LRO(64.03,1,1,1,0)),U,4) Q + ;quit if tasked and user sends stop request + I $D(ZTQUEUED),$$S^%ZTLOAD D Q + .S QFLG=1 + .K ^LRO(64.03) S ^LRO(64.03,0)="WKLD LOG FILE^64.03^" + ;otherwise, continue + K ECXDD D FIELD^DID(64.03,1,,"SPECIFIER","ECXDD") + S ECPROF=$E(+$P(ECXDD("SPECIFIER"),"P",2)),ECLRN=1 K ECXDD + F S ECLRN=$O(^LRO(64.03,ECLRN)) Q:'ECLRN D Q:QFLG + .Q:'$D(^LRO(64.03,ECLRN,0)) + .S EC1=^LRO(64.03,ECLRN,0),ECDOC=ECPROF_$P(EC1,U,2),ECDOCNPI="" + .S ECLOC=$P(EC1,U,15),EC=$P(EC1,U,3),ECDOCPC=$$PRVCLASS^ECXUTL($P(EC1,U,2),$P(EC1,U,4)) + .I EC]"" D GET + K ^LRO(64.03),^TMP($J,"ECXP") S ^LRO(64.03,0)="WKLD LOG FILE^64.03^" + K ECDOCNPI,ECXAGC,ECXL1,ECXL2 + Q + ; +GET ;get data + N X,ECXSTN + S ECF=$S($P(EC,";",2)="DPT(":2,$P(EC,";",2)="LRT(67,":67,1:0) Q:'ECF + S ECIFN=$P(EC,";") + ;resolve ecloc + S ECXL1=+$P(ECLOC,";",1),ECXL2=$P(ECLOC,";",2) + I ECF=2 S ECLOC=$S(ECXL1>0:ECXL1,1:"") I ECXL2]"",ECXL2'="SC(" S ECLOC="" + I ECF=67 D S ECLOC=ECXSTN + .S (ECXSTN,ECXAGC)="" + .I (ECXL2'="DIC(4,")!('$D(^DIC(4,ECXL1))) S ECXSTN="XXXXX",ECXAGC="XX" Q + .S ECXSTN=$P(^DIC(4,ECXL1,"99"),U,1),ECXAGC=$E($P(^(99),U,5),1,2) + .S:ECXSTN="" ECXSTN="ZZZZZ" S:ECXAGC="" ECXAGC="ZZ" + S ECDT=$P(EC1,U,13),ECD=$P(ECDT,"."),ECTM=$$ECXTIME^ECXUTL(ECDT) + S ECWKLD=$P(EC1,U,11),ECWK="" I $D(^LAM(ECWKLD,0)) S ECWK=$P(^(0),U,2) + S (ECXADMDT,ECTREAT,ECNA,ECSN,ECMN,ECPTTM,ECPTPR,ECCLAS)="",ECA="O",ECXERR=0 + S (ECPTNPI,ECASPR,ECCLAS2,ECASNPI)="" + ;get the patient data if record is in file #2 + I ECF=2 D PAT(ECIFN,ECDT,.ECXERR) + Q:ECXERR + ;get patient data if record is in file #67 + I ECF=67 S ECSN="000123456",ECNA="RFRL" I $D(^LRT(67,ECIFN,0)) D + .S ECXMPI="",EC0=^LRT(67,ECIFN,0),ECNA=$E($P($P(EC0,U),",")_" ",1,4) + .S ECSN=$P(EC0,U,9),ECXERI="" D + ..S ECNA=$TR(ECNA,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") + ..I ECSN="" S ECSN="000123456" Q + ..S ECSN=$TR(ECSN," "),ECSN=$TR(ECSN,"-") + ..I ($L(ECSN)<9)!($L(ECSN)>10) S ECSN="000123456" Q + ..I $L(ECSN)=9,ECSN'?9N S ECSN="000123456" Q + ..I $L(ECSN)=10,ECSN'?9N1"P" S ECSN="000123456" + ; + ;- Only set treating spec (TS) to TS in file #64.03 if it does not exist + I ECA="I",ECTREAT="" S ECTREAT=$P($G(^DIC(45.7,+$P(EC1,U,10),0)),U,2) + S (ECXDOM,ECXDSSD)="" + S X=$G(^ECX(727.831,+ECTREAT,0)) S:X'="" ECXDOM=$P(X,U,2) + ; + ;- Get ordering stop code and ordering date + S ECXORDST=+$P(EC1,U,15),ECXORDST=$S(ECXORDST:$P($G(^ECX(728.44,ECXORDST,0)),U,2),1:"") + S ECXORDDT=$S($P(EC1,U,14):$$ECXDATE^ECXUTL($P(EC1,U,14),ECXYM),1:"") + ; + ;- Get Production Division - ECXDIEN added p-80 + N ECXPDIV,ECXDIEN S ECXDIEN=$O(^DIC(4,"D",ECINST,"")),ECXPDIV=$$RADDIV^ECXDEPT(ECXDIEN) ;P-46 + K ECXDIEN + ; + ;- Observation patient indicator (YES/NO) + S ECXOBS=$$OBSPAT^ECXUTL4(ECA,ECTREAT) + ; + ;- If no encounter number don't file record + S ECXENC=$$ENCNUM^ECXUTL4(ECA,ECSN,ECXADMDT,ECD,ECTREAT,ECXOBS,ECHEAD,,) Q:ECXENC="" + ;create extract record only if patient name and accession area exist + I ECNA]"" S ECT=$P(EC1,U,8),ECURG=$P(EC1,U,9),EC=+$P(EC1,U,7) I EC D + .S:ECF=2 ECACA=EC_U_$P($G(^LRO(68,EC,0)),U,11) + .S:ECF=67 ECACA=ECXAGC_U_$P($G(^LRO(68,EC,0)),U,11) + .D FILE + Q + ; +PAT(ECXDFN,ECXDATE,ECXERR) ;get/set patient data + N X,OK,PT + ;get data + I $D(^TMP($J,"ECXP",ECXDFN)) D + .S PT=^TMP($J,"ECXP",ECXDFN),ECNA=$P(PT,U) + .S ECSN=$P(PT,U,2),ECXMPI=$P(PT,U,3),ECXERI=$P(PT,U,4) + ;set data and save for later + I '$D(^TMP($J,"ECXP",ECXDFN)) D Q:'OK + .K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECSD,"."),"1;3",.ECXPAT) + .I 'OK S ECXERR=1 Q + .S ECNA=ECXPAT("NAME"),ECSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI") + .S ECXERI=ECXPAT("ERI") + .S ^TMP($J,"ECXP",ECXDFN)=ECNA_U_ECSN_U_ECXMPI_U_ECXERI + ;get date specific data + S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECA=$P(X,U),ECMN=$P(X,U,2),ECTREAT=$P(X,U,3),ECXADMDT=$P(X,U,4) + S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXDATE,"."),ECPROF) + S ECPTTM=$P(X,U,1),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4) + S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7) + Q + ; +FILE ;file record + ;node0 + ;facility^patient number^SSN (or equivalent)^name^in/out ECA^ + ;day^accession area^abbreviation^test^urgency^treating spec^ + ;location^provider and file^ + ;movement number^file^time^workload code^primary care team^ + ;primary care provider + ;node1 + ;mpi^dss dept^provider npi^pc provider npi^pc prov person class^ + ;assoc pc prov^assoc pc prov person class^assoc pc prov npi^ + ;dom ECXDOM^observ pat ind ECXOBS^encounter num ECXENC^ + ;ord stop code ECXORDST^ord date ECXORDDT^production division + ;ECXPDIV^^ordering provider person class^emergency response indicator + ;(FEMA) ECXERI + ;ECDOCPC + N DA,DIK + S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 + S ECODE=EC7_U_EC23_U_ECINST_U_ECIFN_U_ECSN_U_ECNA_U_ECA_U + S ECODE=ECODE_$$ECXDATE^ECXUTL(ECD,ECXYM)_U_ECACA_U_ECT_U_ECURG_U + ;convert specialty to PTF Code for transmission + N ECXDATA + S ECXDATA=$$TSDATA^DGACT(42.4,+ECTREAT,.ECXDATA) + S ECTREAT=$G(ECXDATA(7)) + ;done + S ECODE=ECODE_ECTREAT_U_ECLOC_U_ECDOC_U_ECMN_U_ECF_U_ECTM_U_ECWK_U + S ECODE=ECODE_ECPTTM_U_ECPTPR_U + ;(ECACA=acc area^abbreviation) + S ECODE1=ECXMPI_U_ECXDSSD_U_ECDOCNPI_U_ECPTNPI_U_ECCLAS_U_ECASPR_U + S ECODE1=ECODE1_ECCLAS2_U_ECASNPI_U_ECXDOM_U_ECXOBS_U_ECXENC_U + S ECODE1=ECODE1_ECXORDST_U_ECXORDDT_U_ECXPDIV_U + I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECDOCPC + I ECXLOGIC>2006 S ECODE1=ECODE1_U_ECXERI + S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1 + S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA + I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 + Q + ; +SETUP ;Set required input for ECXTRAC + S ECHEAD="LAB" + D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) + Q + ; +QUE ; entry point for the background requeuing handled by ECXTAUTO + D SETUP,QUE^ECXTAUTO,^ECXKILL Q diff --git a/r/DSS_EXTRACTS-ECX/ECXLABR.m b/r/DSS_EXTRACTS-ECX/ECXLABR.m index bf8777d8..17465d77 100644 --- a/r/DSS_EXTRACTS-ECX/ECXLABR.m +++ b/r/DSS_EXTRACTS-ECX/ECXLABR.m @@ -1,121 +1,118 @@ -ECXLABR ;ALB/JAP,BIR/CML-LAR Extract for DSS (New Format - With LMIP Codes) ; 6/5/07 2:33pm - ;;3.0;DSS EXTRACTS;**8,24,33,37,39,46,71,80,107,105**;Dec 22, 1997;Build 70 -BEG ;entry point from option - D SETUP I ECFILE="" Q - D ^ECXTRAC,^ECXKILL - Q - ; -START ; entry when queued - N X,OK,ECTRS,ECTRANS,ECTRIEN,ECDOC,ECDOCPC - K ^LAR(64.036) S LRSDT=ECSD,LREDT=ECED - D ^LRCAPDAR - ;quit if no completion date for API compile - I '$P($G(^LAR(64.036,1,2,1,0)),U,4) Q - ;build local array of workload codes for local lab tests linked to - ;DSS tests - K ECLOC S ECDTST=0 - F S ECDTST=$O(^ECX(727.2,1,1,ECDTST)) Q:('ECDTST) S ECLTST=0 D - .F S ECLTST=$O(^ECX(727.2,1,1,ECDTST,"LOC",ECLTST)) Q:'ECLTST D - ..S ECLTIEN=+^ECX(727.2,1,1,ECDTST,"LOC",ECLTST,0) - ..S ECWCDA=+$G(^LAB(60,ECLTIEN,64)) - ..I ECWCDA S ECWC=$P(^LAM(ECWCDA,0),U,2),ECLOC(ECWCDA)=ECWC - K ECLTIEN - ;process temporary lab file #64.036 - S QFLG=0,ECLRN=1 - F S ECLRN=$O(^LAR(64.036,ECLRN)) Q:('ECLRN)!(QFLG) D - .I $D(^LAR(64.036,ECLRN,0)) D - ..S EC1=^LAR(64.036,ECLRN,0),ECF=$P(EC1,U,2) - ..Q:ECF="" - ..S ECXDFN=$P(EC1,U,3),ECPTPR=$P($G(EC1),U,11),ECCLASS="" - ..S ECXTIME=$S($P(EC1,U,10)="":"000300",1:$P(EC1,U,10)) - ..S ECXDATE=$P(EC1,U,9)_"."_$P(EC1,U,10) - ..I ECPTPR S ECCLASS=$$PRVCLASS^ECXUTL(ECPTPR,ECXDATE) - ..I ECPTPR S ECPTNPI=$$NPI^XUSNPI("Individual_ID",ECPTPR,+ECXDATE) D - ...S:+ECPTNPI'>0 ECPTNPI="" S ECPTNPI=$P(ECPTNPI,U) - ..S ECORDT=$$ECXDATE^ECXUTL($P(EC1,U,4),ECXYM) - ..S ECORTM=$$ECXTIME^ECXUTL($P(EC1,U,4)_"."_$P(EC1,U,5)) - ..S ECREDT=$$ECXDATE^ECXUTL($P(EC1,U,6),ECXYM) - ..S ECRETM=$$ECXTIME^ECXUTL($P(EC1,U,6)_"."_$P(EC1,U,7)) - ..S ECSCDT=$$ECXDATE^ECXUTL($P(EC1,U,9),ECXYM) - ..S ECSCTM=$$ECXTIME^ECXUTL($P(EC1,U,9)_"."_$P(EC1,U,10)) - ..S (ECXADMDT,ECXDOM,ECXDSSD,ECXPNM,ECXSSN,ECXA,ECXMN,ECXTS)="" - ..I ECF=2 D Q:'OK - ...K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,ECXDATE,"1;",.ECXPAT) - ...Q:'OK - ...S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI") - ...S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECXA=$P(X,U),ECXADMDT=$P(X,U,4) - ...S ECXMN=$P(X,U,2),ECXTS=$P(X,U,3),ECXDOM=$P(X,U,10) - ..;allow for referral patients in future?? - ..;I ECF=67 S ECSN="000123456",ECNA="RFRL" - ..;loop on results multiple - ..; - ..;Get production division ECXDIEN added p-80 - ..N ECXPDIV,ECXDIEN S ECXDIEN=$O(^DIC(4,"D",ECINST,"")),ECXPDIV=$$RADDIV^ECXDEPT(ECXDIEN) ;p-46 - ..K ECXDIEN - ..;- Observation patient indicator (y/n) - ..S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) - ..; - ..;- If no encounter number don't file record - ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,$P(EC1,U,9),ECXTS,ECXOBS,ECHEAD,,) Q:ECXENC="" - ..S ECRES=0 - ..F S ECRES=$O(^LAR(64.036,ECLRN,1,ECRES)) Q:('ECRES)!(QFLG) D - ...I $D(^LAR(64.036,ECLRN,1,ECRES,0)) D Q:QFLG - ....S EC2=^LAR(64.036,ECLRN,1,ECRES,0),ECN=$P(EC2,U),ECRS=$P(EC2,U,2) - ....S ECHL=$E($P(EC2,U,3)),ECWC=+$P(EC2,U,4) - ....S ECWC=$S($D(ECLOC(ECWC)):ECLOC(ECWC),1:"") - ....; - ....; - Free text results translation - ....S ECTRANS="",ECTRS=ECRS - ....I +ECTRS S ECTRS=$TR(ECTRS,",","") D - .....I (ECTRS?.N)!(ECTRS?.N1".".N) S ECRS=ECTRS - ....F Q:$E(ECTRS,1)'=" " S ECTRS=$E(ECTRS,2,$L(ECTRS)) - ....F Q:$E(ECTRS,$L(ECTRS))'=" " S ECTRS=$E(ECTRS,1,($L(ECTRS)-1)) - ....I ECTRS]"" I ECTRS'?.N I ECTRS'?.N1".".N D ;translate - .....S ECTRS=$TR(ECRS,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") - .....S ECTRIEN="",ECTRIEN=$O(^ECX(727.7,"B",ECTRS,ECTRIEN)) - .....S ECTRANS=$S(ECTRIEN:$P(^ECX(727.7,ECTRIEN,0),U,2),1:5) - ....; - ....I ECWC]"" D FILE - K ^LAR(64.036) S ^LAR(64.036,0)="LAB DSS LAR EXTRACT^64.036^" - Q - ; -FILE ;file record - ;node0 - ;facility (ECINST)^dfn (ECXDFN)^ssn (ECXSSN)^name(ECXPNM)^in/out (ECXA)^ - ;day(ECSCDT)^ - ;lab test code (ECN)^results (ECRS)^hi/lo indicator (ECHL)^ - ;date ordered (ECORDT)^time ordered (ECORTM)^date ready (ECREDT)^ - ;time ready (ECRETM)^ - ;movement file # (ECXMN)^treating specialty (ECXTS)^ - ;workload code(ECWC)^ - ;node1 - ;mpi (ECXMPI)^dss dept (ECXDSSD)^dom (ECXDOM)^time (ECSCTM)^ - ;observ pat ind (ECXOBS)^encounter num (ECXENC)^prod div ECXPDIV^ - ;lab results translation ECXTRANS^ordering provider (ECPTPR)^ - ;ordering provider person class (ECCLASS)^ordering provider npi ECPTNPI - N DA,DIK - S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 - S ECODE=EC7_U_EC23_U_ECINST_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U - S ECODE=ECODE_ECSCDT_U_$$RJ^XLFSTR(ECN,4,0)_U_ECRS_U_ECHL_U_ECORDT_U - S ECODE=ECODE_$$LJ^XLFSTR(ECORTM,6,0)_U - ;convert specialty to PTF Code for transmission - N ECXDATA - S ECXDATA=$$TSDATA^DGACT(42.4,+ECXTS,.ECXDATA) - S ECXTS=$G(ECXDATA(7)) - ;done - S ECODE=ECODE_ECREDT_U_$$LJ^XLFSTR(ECRETM,6,0)_U_ECXMN_U_ECXTS_U_ECWC_U - S ECODE1=ECXMPI_U_ECXDSSD_U_ECXDOM_U_ECSCTM_U_ECXOBS_U_ECXENC_U_ECXPDIV_U_ECTRANS - I ECXLOGIC>2004 S ECODE1=ECODE1_U_2_ECPTPR_U_ECCLASS - I ECXLOGIC>2007 S ECODE1=ECODE1_U_ECPTNPI - S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1 - S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA - I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 - Q - ; -SETUP ;Set required input for ECXTRAC - S ECHEAD="LAR" - D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) - Q - ; -QUE ; entry point for the background requeuing handled by ECXTAUTO - D SETUP,QUE^ECXTAUTO,^ECXKILL Q +ECXLABR ;ALB/JAP,BIR/CML-LAR Extract for DSS (New Format - With LMIP Codes) ; 4/12/07 8:43am + ;;3.0;DSS EXTRACTS;**8,24,33,37,39,46,71,80,107**;Dec 22, 1997;Build 9 +BEG ;entry point from option + D SETUP I ECFILE="" Q + D ^ECXTRAC,^ECXKILL + Q + ; +START ; entry when queued + N X,OK,ECTRS,ECTRANS,ECTRIEN,ECDOC,ECDOCPC + K ^LAR(64.036) S LRSDT=ECSD,LREDT=ECED + D ^LRCAPDAR + ;quit if no completion date for API compile + I '$P($G(^LAR(64.036,1,2,1,0)),U,4) Q + ;build local array of workload codes for local lab tests linked to + ;DSS tests + K ECLOC S ECDTST=0 + F S ECDTST=$O(^ECX(727.2,1,1,ECDTST)) Q:('ECDTST) S ECLTST=0 D + .F S ECLTST=$O(^ECX(727.2,1,1,ECDTST,"LOC",ECLTST)) Q:'ECLTST D + ..S ECLTIEN=+^ECX(727.2,1,1,ECDTST,"LOC",ECLTST,0) + ..S ECWCDA=+$G(^LAB(60,ECLTIEN,64)) + ..I ECWCDA S ECWC=$P(^LAM(ECWCDA,0),U,2),ECLOC(ECWCDA)=ECWC + K ECLTIEN + ;process temporary lab file #64.036 + S QFLG=0,ECLRN=1 + F S ECLRN=$O(^LAR(64.036,ECLRN)) Q:('ECLRN)!(QFLG) D + .I $D(^LAR(64.036,ECLRN,0)) D + ..S EC1=^LAR(64.036,ECLRN,0),ECF=$P(EC1,U,2) + ..Q:ECF="" + ..S ECXDFN=$P(EC1,U,3),ECPTPR=$P($G(EC1),U,11),ECCLASS="" + ..S ECXTIME=$S($P(EC1,U,10)="":"000300",1:$P(EC1,U,10)) + ..S ECXDATE=$P(EC1,U,9)_"."_$P(EC1,U,10) + ..I ECPTPR S ECCLASS=$$PRVCLASS^ECXUTL(ECPTPR,ECXDATE) + ..S ECORDT=$$ECXDATE^ECXUTL($P(EC1,U,4),ECXYM) + ..S ECORTM=$$ECXTIME^ECXUTL($P(EC1,U,4)_"."_$P(EC1,U,5)) + ..S ECREDT=$$ECXDATE^ECXUTL($P(EC1,U,6),ECXYM) + ..S ECRETM=$$ECXTIME^ECXUTL($P(EC1,U,6)_"."_$P(EC1,U,7)) + ..S ECSCDT=$$ECXDATE^ECXUTL($P(EC1,U,9),ECXYM) + ..S ECSCTM=$$ECXTIME^ECXUTL($P(EC1,U,9)_"."_$P(EC1,U,10)) + ..S (ECXADMDT,ECXDOM,ECXDSSD,ECXPNM,ECXSSN,ECXA,ECXMN,ECXTS)="" + ..I ECF=2 D Q:'OK + ...K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,ECXDATE,"1;",.ECXPAT) + ...Q:'OK + ...S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI") + ...S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECXA=$P(X,U),ECXADMDT=$P(X,U,4) + ...S ECXMN=$P(X,U,2),ECXTS=$P(X,U,3),ECXDOM=$P(X,U,10) + ..;allow for referral patients in future?? + ..;I ECF=67 S ECSN="000123456",ECNA="RFRL" + ..;loop on results multiple + ..; + ..;Get production division ECXDIEN added p-80 + ..N ECXPDIV,ECXDIEN S ECXDIEN=$O(^DIC(4,"D",ECINST,"")),ECXPDIV=$$RADDIV^ECXDEPT(ECXDIEN) ;p-46 + ..K ECXDIEN + ..;- Observation patient indicator (y/n) + ..S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) + ..; + ..;- If no encounter number don't file record + ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,$P(EC1,U,9),ECXTS,ECXOBS,ECHEAD,,) Q:ECXENC="" + ..S ECRES=0 + ..F S ECRES=$O(^LAR(64.036,ECLRN,1,ECRES)) Q:('ECRES)!(QFLG) D + ...I $D(^LAR(64.036,ECLRN,1,ECRES,0)) D Q:QFLG + ....S EC2=^LAR(64.036,ECLRN,1,ECRES,0),ECN=$P(EC2,U),ECRS=$P(EC2,U,2) + ....S ECHL=$E($P(EC2,U,3)),ECWC=+$P(EC2,U,4) + ....S ECWC=$S($D(ECLOC(ECWC)):ECLOC(ECWC),1:"") + ....; + ....; - Free text results translation + ....S ECTRANS="",ECTRS=ECRS + ....I +ECTRS S ECTRS=$TR(ECTRS,",","") D + .....I (ECTRS?.N)!(ECTRS?.N1".".N) S ECRS=ECTRS + ....F Q:$E(ECTRS,1)'=" " S ECTRS=$E(ECTRS,2,$L(ECTRS)) + ....F Q:$E(ECTRS,$L(ECTRS))'=" " S ECTRS=$E(ECTRS,1,($L(ECTRS)-1)) + ....I ECTRS]"" I ECTRS'?.N I ECTRS'?.N1".".N D ;translate + .....S ECTRS=$TR(ECRS,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") + .....S ECTRIEN="",ECTRIEN=$O(^ECX(727.7,"B",ECTRS,ECTRIEN)) + .....S ECTRANS=$S(ECTRIEN:$P(^ECX(727.7,ECTRIEN,0),U,2),1:5) + ....; + ....I ECWC]"" D FILE + K ^LAR(64.036) S ^LAR(64.036,0)="LAB DSS LAR EXTRACT^64.036^" + Q + ; +FILE ;file record + ;node0 + ;facility (ECINST)^dfn (ECXDFN)^ssn (ECXSSN)^name(ECXPNM)^in/out (ECXA)^ + ;day(ECSCDT)^ + ;lab test code (ECN)^results (ECRS)^hi/lo indicator (ECHL)^ + ;date ordered (ECORDT)^time ordered (ECORTM)^date ready (ECREDT)^ + ;time ready (ECRETM)^ + ;movement file # (ECXMN)^treating specialty (ECXTS)^ + ;workload code(ECWC)^ + ;node1 + ;mpi (ECXMPI)^dss dept (ECXDSSD)^dom (ECXDOM)^time (ECSCTM)^ + ;observ pat ind (ECXOBS)^encounter num (ECXENC)^prod div ECXPDIV^ + ;lab results translation ECXTRANS^ordering provider (ECPTPR)^ + ;ordering provider person class (ECCLASS) + N DA,DIK + S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 + S ECODE=EC7_U_EC23_U_ECINST_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U + S ECODE=ECODE_ECSCDT_U_$$RJ^XLFSTR(ECN,4,0)_U_ECRS_U_ECHL_U_ECORDT_U + S ECODE=ECODE_$$LJ^XLFSTR(ECORTM,6,0)_U + ;convert specialty to PTF Code for transmission + N ECXDATA + S ECXDATA=$$TSDATA^DGACT(42.4,+ECXTS,.ECXDATA) + S ECXTS=$G(ECXDATA(7)) + ;done + S ECODE=ECODE_ECREDT_U_$$LJ^XLFSTR(ECRETM,6,0)_U_ECXMN_U_ECXTS_U_ECWC_U + S ECODE1=ECXMPI_U_ECXDSSD_U_ECXDOM_U_ECSCTM_U_ECXOBS_U_ECXENC_U_ECXPDIV_U_ECTRANS + I ECXLOGIC>2004 S ECODE1=ECODE1_U_2_ECPTPR_U_ECCLASS + S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1 + S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA + I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 + Q + ; +SETUP ;Set required input for ECXTRAC + S ECHEAD="LAR" + D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) + Q + ; +QUE ; entry point for the background requeuing handled by ECXTAUTO + D SETUP,QUE^ECXTAUTO,^ECXKILL Q diff --git a/r/DSS_EXTRACTS-ECX/ECXLBB.m b/r/DSS_EXTRACTS-ECX/ECXLBB.m index 24ad2259..d5029ea1 100644 --- a/r/DSS_EXTRACTS-ECX/ECXLBB.m +++ b/r/DSS_EXTRACTS-ECX/ECXLBB.m @@ -1,218 +1,205 @@ -ECXLBB ;DALOI/KML - DSS BLOOD BANK EXTRACT ; 8/12/08 1:00pm - ;;3.0;DSS EXTRACTS;**78,84,90,92,104,105,102**;Dec 22, 1997;Build 17 - ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021 - ; access to the LAB DATA file (#63) is supported by - ; controlled subscription to IA 525 (global root ^LR) - ; access to the BLOOD PRODUCT (#66) is supported by IA 4510 -BEG ;entry point from option - D SETUP I ECFILE="" Q - D ^ECXTRAC,^ECXKILL - Q -START ; Entry point from tasked job - ; begin package specific extract - N ECTRSP,ECADMT,ECTODT,ECENCTR,ECPAT,ECLRDFN,ECXPHY,ECXPHYPC,ECPHYNPI - N ECD,ECXDFN,ECARRY,EC66,ECERR,ECTRFDT,ECTRFTM,ECX,ECINOUT,ECXINST - ;variables ECFILE,EC23,ECXYM,ECINST,ECSD,ECSD1,ECED passed in - ; by taskmanager - ; ECED defined in ^ECXTRAC - it represents the end date of the extract - ; sort process. TRANSFUSION DATE should be within start and end dates - ; ECED and ECSD were assigned with input provided by the user interface - ; and ECSD1 = ECSD-.1 - ; Read through the TRANSFUSION RECORD sub-file (63.017) of - ; the LAB DATA file (#63) - ;the global nodes containing transfusion record entries are constructed - ; by calculating the TRANSFUSION DATE/TIME (.01) - ; into its reverse date/time representation and then DINUM'd when - ;filing the record entry - ; ECD equals the reverse date/time of ECED+.3 and will need to be - ; reset for each DFN. - I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 Q ;quit if tasked and user sends stop request (QFLG assigned in ECXTRAC) -AUDRPT ; entry point for pre-extract audit report - S ECTODT=9999999-ECSD1,ECLRDFN=0 - F S ECLRDFN=$O(^LR(ECLRDFN)) Q:'ECLRDFN S ECXDFN=$$GETDFN(ECLRDFN),ECERR=$$PAT(ECXDFN) S ECD=9999999-(ECED+.3) F S ECD=$O(^LR(ECLRDFN,1.6,ECD)) Q:ECERR Q:'ECD!(ECD>ECTODT) S EC0=^LR(ECLRDFN,1.6,ECD,0) D - .; ECARRY(1)=TRANSFUSION DATE AND TIME, - .; ECARRY(3)=COMPONENT, ECARRY(4)=COMPONENT ABBREVIATION - .; ECARRY(5)=UNITS POOLED, ECARRY(6)=TRANSFUSION REACTION, - .; ECARRY(7)=VOLUME TRANSFUSED, ECARRY(8)=TRANSFUSION REACTION TYPE - .; ECARRY(9)=REQUESTING PROVIDER, ECARRY(10)=REQUEST. PROV. PERSON CLASS - .; ECARRY(11)=UNIT MODIFIED,ECARRY(12)=UNIT MODIFICATION - .; ECARRY(13)=PRODUCTION DIVISION CODE - . S ECARRY(1)=$P(EC0,"^"),EC66=$G(^LAB(66,$P(EC0,"^",2),0)) - . S ECARRY(3)=$E($P(EC66,"^"),1,15),ECARRY(4)=$P(EC66,"^",2) - . S ECARRY(5)=$S(+$P(EC0,"^",7)=0:1,1:+$P(EC0,"^",7)) - . S ECARRY(6)=$S($P(EC0,"^",8)=1:"Y",1:"N"),ECARRY(7)=$P(EC0,"^",10) - . S ECARRY(8)=$E($P($G(^LAB(65.4,+$P(EC0,"^",11),0)),"^"),1,10) - . S (ECARRY(9),ECARRY(10),ECARRY(13))="" D GETRPRV - . S ECARRY(11)=$$MODIFIED(),(ECXPHY,ECXPHYPC,ECPHYNPI)="" - . S ECARRY(12)=$S(ECARRY(11)="Y":$$UNITMODS(),1:"") - . D GETDATA - . K ECARRY - D AUDRPT^ECXLBB1 - Q -UNITMODS() ; Get modification criteria from fields #.06 and #3 from file #66 - N MODARY,MO,EC66A,MODSTR,STR3 - S MODARY("DIVIDED")="D",MODARY("POOLED")="P",MODARY("WASHED")="W" - S MODARY("FROZEN")="F",MODARY("LEUKOCYTE POOR")="L" - S MODARY("REJUVENATED")="R",MODARY("DEGLYCEROLIZED")="G" - S MODARY("IRRADIATED")="I",MODARY("SEPARATED")="S" - ;if modification criteria is null determine value from description - S MODSTR=$S($P(EC66,U,6)'="":$P(EC66,U,6),1:$$CHKMOD^ECXLBB1($P(EC66,"^"))) - ;get modification criteria for entries at field #3 in file #66 - S MOD=0 F S MOD=$O(^LAB(66,$P(EC0,"^",2),3,MOD)) Q:'MOD D - .S EC66A=$G(^LAB(66,MOD,0)) I EC66A="" Q - .S STR3=$S($P(EC66A,U,6)'="":$P(EC66A,U,6),1:$$CHKMOD^ECXLBB1($P(EC66A,"^"))) - .I STR3'="",MODSTR'[STR3 S MODSTR=MODSTR_STR3 - Q MODSTR -MODIFIED() ; Was unit modified - ; Init variables - N XMATCH,UNIT,MOD,COMPID,MODNODE,MODTO - S (XMATCH,UNIT)=0,MOD="" - ; Check input - Q:'$G(ECLRDFN)!'$P(EC0,U,2) "N" - ;Find xmatch for blood component request - S XMATCH=$O(^LR(ECLRDFN,1.8,$P(EC0,U,2),1,XMATCH)) Q:'XMATCH "N" - ;Get blood inventory file (#65) pointer - S UNIT=$P($G(^LR(ECLRDFN,1.8,$P(EC0,"^",2),1,XMATCH,0)),U) - ;Look at disposition field (#4.1) in blood inventory file (#65) - S MOD=$P($G(^LRD(65,+XMATCH,4)),U),COMPID=$P(EC66,U,3) - ; Get 'the modified to' entry pointer to blood inventory file (#66) - I MOD="MO" S MODTO=0 F S MODTO=$O(^LRD(65,+XMATCH,9,MODTO)) Q:'MODTO D - .S MODNODE=$G(^LRD(65,+XMATCH,9,MODTO,0)) Q:$P(^(0),U,3)'>1 - .Q:$P(MODNODE,U,2)'=COMPID - .; Set the modify to unit ien for file (#66) - Q $S(MOD="MO":"Y",1:"N") -GETRPRV ; get requesting provider, requesting provider person class and - ; production division code - ; input: ECD =INVERTED DATE SUBSCRIPT - ; ECARRY(1)=TRANSFUSION DATE AND TIME - ; note: Accessioned data in file #68 is stored up to 90 days. - N ECXBNOD,ACC,ACCDT,ACCNODE,PERCLS - I ECARRY(1)="" Q ;there is no transfusion date - ;get BLOOD BANK record, field #1, in file #63 located on "BB" node - ;since there is a slight time lapse, $O will find the BB record - S ECXBNOD=$O(^LR(ECLRDFN,"BB",ECD)) I ECXBNOD="" Q - S ECXBNOD=^LR(ECLRDFN,"BB",ECXBNOD,0) I ECXBNOD="" Q - ;Compose accession number,originating from field #.06 subfile #63.01 - ; ex. ACC=BB 0528 27 - S ACC=$P(ECXBNOD,U,6),ACC=$TR($P(ACC," ",2,99)," ") - S ACCDT=$E(ECARRY(1),1,3)_$E(ACC,1,4),NUM=$E(ACC,5,99) - ;Get field #2 from file #68, field #1 from subfile #68.01 which is - ;subfile #68.02. Look at 29=blood bank ien, from 0th node, get fields - ;#6.5 PROVIDER and #26 DIV - I (ACCDT)=""!(NUM="") Q - ; identify bb accession area the patient was in to get the right DIV - S AREA=$$AREA - S ACCNODE=$G(^LRO(68,+AREA,1,ACCDT,1,NUM,0)) - S ECARRY(9)=$P(ACCNODE,U,8) I ECARRY(9)'="" D - . S PERCLS=$$GET^XUA4A72(ECARRY(9),ACCDT) - . I +PERCLS>0 S ECARRY(10)=$P(PERCLS,U,7) - . S ECREQNPI=$$NPI^XUSNPI("Individual_ID",ECARRY(9),ACCDT) - . S:+ECREQNPI'>0 ECREQNPI="" S ECREQNPI=$P(ECREQNPI,U) - . S ECARRY(9)=2_ECARRY(9) - S DIV=$P($G(^LRO(68,+AREA,1,ACCDT,1,NUM,.4)),U) - I DIV'="" S ECARRY(13)=$$RADDIV^ECXDEPT(DIV) - Q -AREA() ; resolve accession area's ien to use and validate - ; Accession number - ; Patient LRDFN - ; note: if there is only one accession area use '29' - N A,CNT,BBLIST,DFN,ACC,AREA,DATE,TDATE,ACCNODE - S (CNT,FLAG,A)=0,DFN="" - ; set the date from the "bb" node in file (#63) - S DATE=$P(ECXBNOD,U) - ; setup array for bb accession areas if more than one - F S A=$O(^LRO(68,A)) Q:'A I $P($G(^LRO(68,A,0)),"^",2)="BB" D - . S BBLIST(A)="" - . S CNT=CNT+1 - I CNT'>1 Q 29 - S AREA=0 F S AREA=$O(BBLIST(AREA)) Q:'AREA D Q:FLAG - . ; get additional accession information for validation - . S ACCNODE=$G(^LRO(68,AREA,1,$P(DATE,"."),1,NUM,0)) - . S ACC=$G(^LRO(68,AREA,1,$P(DATE,"."),1,NUM,.2)) - . S DFN=$P($G(ACCNODE),U) - . S TDATE=$P($G(^LRO(68,AREA,1,$P(DATE,"."),1,NUM,3)),U) - . I (DFN=ECLRDFN)&(ACC=$P(ECXBNOD,U,6))&(DATE=TDATE) S FLAG=1 - Q AREA -GETDATA ; gather rest of extract data that will be recorded in an - ; entry in file 727.829 - S ECTRFDT=$$ECXDOB^ECXUTL(ECARRY(1)),ECTRFTM=$$ECXTIME^ECXUTL(ECARRY(1)) - S ECX=$$INP^ECXUTL2(ECXDFN,ECARRY(1)),ECINOUT=$P(ECX,U),ECTRSP=$P(ECX,U,3),ECADMT=$P(ECX,U,4) ; [FLD #5] - ; - ;- Observation patient indicator (YES/NO) - S ECXOBS=$$OBSPAT^ECXUTL4(ECINOUT,ECTRSP) - ;- If no encounter number don't file record - S ECENCTR=$$ENCNUM^ECXUTL4(ECINOUT,ECPAT("SSN"),ECADMT,ECARRY(1),ECTRSP,ECXOBS,ECHEAD,,) ; [FLD #6] - Q:ECENCTR="" - ;get emergency response indicator (FEMA) - S ECXERI=ECPAT("ERI") - ; - S ECXSTR=$G(EC23)_"^"_ECINST_"^"_ECXDFN_"^"_ECPAT("SSN")_"^"_ECPAT("NAME")_"^"_ECINOUT_"^"_ECENCTR_"^"_ECTRFDT_"^"_ECTRFTM_"^"_ECARRY(3)_"^"_ECARRY(4)_"^"_ECARRY(5)_"^"_ECARRY(7)_"^"_ECARRY(6)_"^"_ECARRY(8)_"^BB"_ECARRY(13)_"^^" - I $G(ECXLOGIC)>2005 S ECXSTR=ECXSTR_U_ECXPHY_U_ECXPHYPC - I $G(ECXLOGIC)>2006 D - .S ECXSTR=ECXSTR_U_ECXERI_U_ECARRY(11)_U_ECARRY(12)_U_ECARRY(9)_U_ECARRY(10)_U_ECARRY(13)_U - I '$D(ECXRPT) D FILE(ECXSTR) Q - S ^TMP("ECXLBB",$J,ECXDFN,ECD)=ECXSTR ;temporary global array - ; used in ECXPLBB (pre-extract audit report) - Q -GETDFN(ECXLRDFN) ; - ; INPUT - LRDFN - ; OUTPUT - DFN - ; Obtains DFN (Patient ID) from LRDFN (Lab Patient ID). - ; If no valid DFN exists, 0 is returned. - S ECXLRDFN=+$G(ECXLRDFN) - I $P($G(^LR(ECXLRDFN,0)),"^",2)'=2 Q 0 - Q +$P(^LR(ECXLRDFN,0),"^",3) - ; -PAT(ECXDFN) ;get/set patient data - ; INPUT - ECXDFN = patient ien (DFN) - ; OUTPUT - ECPAT array: - ; ECPAT("SSN") - ; ECPAT("NAME") - ; returns 0 or 1 in ECXERR - 0=successful - ; 1=error condition - N X,OK,ECXERR - ;get data - S ECXERR=0 - K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,"","1;3",.ECPAT) - I 'OK S ECXERR=1 - Q ECXERR - ; -FILE(ECODE) ; - ; Input - ECODE = extract record - ; - ; record the extract record at a global node in file 727.829 - ; sequence #^year/month of extract^extract #^facility^patient dfn^SSN^ - ; name^i/o pt indicator^encounter #^date of transfusion^time of - ; transfusion^component^component abbrev^# of units^volume in mm^ - ; reaction^reaction type^feeder location^DSS product dept^DSS IP # - ; ordering physician^ordering physician pc^emergency response indicator - ; (FEMA)^unit modified^unit modification^requesting provider^request. - ; provider person class^ordering provider npi ECPHYNPI - ;ECODE1- requesting provider npi ECREQNPI - ;note: DSS product dept and DSS IP # are dependent on the release of - ; ECX*3*61 - N DA,DIK,EC7 - S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 - S ECODE=EC7_"^"_ECODE - I ECXLOGIC>2007 D - .S ECODE=ECODE_ECPHYNPI_U - .S ECODE1=$G(ECREQNPI) - S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=$G(ECODE1),ECRN=ECRN+1 - S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA - Q - ; - ; -SETUP ;Set required input for ECXTRAC. - S ECHEAD="LBB" - D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) - Q - ; -LOCAL ; to extract nightly for local use not to be transmitted to TSI - ; should be queued with a 1D frequency - D SETUP,^ECXTLOCL,^ECXKILL Q - ; -QUE ; entry point for the background requeuing handled by ECXTAUTO - D SETUP,QUE^ECXTAUTO,^ECXKILL - Q - ; - ;ECXLBB +ECXLBB ;DALOI/KML - DSS BLOOD BANK EXTRACT ; 2/22/07 11:42am + ;;3.0;DSS EXTRACTS;**78,84,90,92,104**;Dec 22, 1997;Build 8 + ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021 + ; access to the LAB DATA file (#63) is supported by + ; controlled subscription to IA 525 (global root ^LR) + ; access to the BLOOD PRODUCT (#66) is supported by IA 4510 +BEG ;entry point from option + D SETUP I ECFILE="" Q + D ^ECXTRAC,^ECXKILL + Q + ; +START ; Entry point from tasked job + ; begin package specific extract + N ECTRSP,ECADMT,ECTODT,ECENCTR,ECPAT,ECLRDFN,ECXPHY,ECXPHYPC + N ECD,ECXDFN,ECARRY,EC66,ECERR,ECTRFDT,ECTRFTM,ECX,ECINOUT,ECXINST + ;variables ECFILE,EC23,ECXYM,ECINST,ECSD,ECSD1,ECED passed in + ; by taskmanager + ; ECED defined in ^ECXTRAC - it represents the end date of the extract + ; sort process. TRANSFUSION DATE should be within start and end dates + ; ECED and ECSD were assigned with input provided by the user interface + ; and ECSD1 = ECSD-.1 + ; Read through the TRANSFUSION RECORD sub-file (63.017) of + ; the LAB DATA file (#63) + ;the global nodes containing transfusion record entries are constructed + ; by calculating the TRANSFUSION DATE/TIME (.01) + ; into its reverse date/time representation and then DINUM'd when + ;filing the record entry + ; ECD equals the reverse date/time of ECED+.3 and will need to be + ; reset for each DFN. + I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 Q ;quit if tasked and user sends stop request (QFLG assigned in ECXTRAC) +AUDRPT ; entry point for pre-extract audit report + S ECTODT=9999999-ECSD1,ECLRDFN=0 + F S ECLRDFN=$O(^LR(ECLRDFN)) Q:'ECLRDFN S ECXDFN=$$GETDFN(ECLRDFN),ECERR=$$PAT(ECXDFN) S ECD=9999999-(ECED+.3) F S ECD=$O(^LR(ECLRDFN,1.6,ECD)) Q:ECERR Q:'ECD!(ECD>ECTODT) S EC0=^LR(ECLRDFN,1.6,ECD,0) D + .; ECARRY(1)=TRANSFUSION DATE AND TIME, + .; ECARRY(3)=COMPONENT, ECARRY(4)=COMPONENT ABBREVIATION + .; ECARRY(5)=UNITS POOLED, ECARRY(6)=TRANSFUSION REACTION, + .; ECARRY(7)=VOLUME TRANSFUSED, ECARRY(8)=TRANSFUSION REACTION TYPE + .; ECARRY(9)=REQUESTING PROVIDER, ECARRY(10)=REQUEST. PROV. PERSON CLASS + .; ECARRY(11)=UNIT MODIFIED, ECARRY(12)=UNIT MODIFICATION + .; ECARRY(13)=PRODUCTION DIVISION CODE + . S ECARRY(1)=$P(EC0,"^"),EC66=$G(^LAB(66,$P(EC0,"^",2),0)) + . S ECARRY(3)=$E($P(EC66,"^"),1,15),ECARRY(4)=$P(EC66,"^",2) + . S ECARRY(5)=$S(+$P(EC0,"^",7)=0:1,1:+$P(EC0,"^",7)) + . S ECARRY(6)=$S($P(EC0,"^",8)=1:"Y",1:"N"),ECARRY(7)=$P(EC0,"^",10) + . S ECARRY(8)=$E($P($G(^LAB(65.4,+$P(EC0,"^",11),0)),"^"),1,10) + . S (ECARRY(9),ECARRY(10),ECARRY(13))="" D GETRPRV + . S ECARRY(12)=$$UNITMOD(),ECARRY(11)=$S(ECARRY(12)'="":"Y",1:"N") + . S (ECXPHY,ECXPHYPC)="" + . D GETDATA + . K ECARRY + Q + ; +UNITMOD() ; Get modification criteria from fields #.06 and #3 from file #66 + N MODARY,MO,EC66A,MODSTR,STR3 + S MODARY("DIVIDED")="D",MODARY("POOLED")="P",MODARY("WASHED")="W" + S MODARY("FROZEN")="F",MODARY("LEUKOCYTE POOR")="L" + S MODARY("REJUVENATED")="R",MODARY("DEGLYCEROLIZED")="G" + S MODARY("IRRADIATED")="I",MODARY("SEPARATED")="S" + ;if modification criteria is null determine value from description + S MODSTR=$S($P(EC66,U,6)'="":$P(EC66,U,6),1:$$CHKMOD($P(EC66,"^"))) + ;get modification criteria for entries at field #3 in file #66 + S MOD=0 F S MOD=$O(^LAB(66,$P(EC0,"^",2),3,MOD)) Q:'MOD D + .S EC66A=$G(^LAB(66,MOD,0)) I EC66A="" Q + .S STR3=$S($P(EC66A,U,6)'="":$P(EC66A,U,6),1:$$CHKMOD($P(EC66A,"^"))) + .I STR3'="",MODSTR'[STR3 S MODSTR=MODSTR_STR3 + Q MODSTR + ; +CHKMOD(MD) ;check if modifier is contained in string + N RES,MODX + I MD="" Q "" + S (RES,MODX)="" F S MODX=$O(MODARY(MODX)) Q:MODX="" D I RES'="" Q + .I MD[MODX S RES=MODARY(MODX) + Q RES +GETRPRV ; get requesting provider, requesting provider person class and + ; production division code + ; input: ECD =INVERTED DATE SUBSCRIPT + ; ECARRY(1)=TRANSFUSION DATE AND TIME + ; note: Accessioned data in file #68 is stored up to 90 days. + N ECXBNOD,ACC,ACCDT,ACCNODE,PERCLS + I ECARRY(1)="" Q ;there is no transfusion date + ;get BLOOD BANK record, field #1, in file #63 located on "BB" node + ;since there is a slight time lapse, $O will find the BB record + S ECXBNOD=$O(^LR(ECLRDFN,"BB",ECD)) I ECXBNOD="" Q + S ECXBNOD=^LR(ECLRDFN,"BB",ECXBNOD,0) I ECXBNOD="" Q + ;Compose accession number,originating from field #.06 subfile #63.01 + ; ex. ACC=BB 0528 27 + S ACC=$P(ECXBNOD,U,6),ACC=$TR($P(ACC," ",2,99)," ") + S ACCDT=$E(ECARRY(1),1,3)_$E(ACC,1,4),NUM=$E(ACC,5,99) + ;Get field #2 from file #68, field #1 from subfile #68.01 which is + ;subfile #68.02. Look at 29=blood bank ien, from 0th node, get fields + ;#6.5 PROVIDER and #26 DIV + I (ACCDT)=""!(NUM="") Q + ; identify bb accession area the patient was in to get the right DIV + S AREA=$$AREA + S ACCNODE=$G(^LRO(68,+AREA,1,ACCDT,1,NUM,0)) + S ECARRY(9)=$P(ACCNODE,U,8) I ECARRY(9)'="" D + . S PERCLS=$$GET^XUA4A72(ECARRY(9),ACCDT) + . I +PERCLS>0 S ECARRY(10)=$P(PERCLS,U,7) + . S ECARRY(9)=2_ECARRY(9) + S DIV=$P($G(^LRO(68,+AREA,1,ACCDT,1,NUM,.4)),U) + I DIV'="" S ECARRY(13)=$$RADDIV^ECXDEPT(DIV) + Q + ; +AREA() ; resolve accession area's ien to use and validate + ; Accession number + ; Patient LRDFN + ; note: if there is only one accession area use '29' + N A,CNT,BBLIST,DFN,ACC,AREA,DATE,TDATE,ACCNODE + S (CNT,FLAG,A)=0,DFN="" + ; set the date from the "bb" node in file (#63) + S DATE=$P(ECXBNOD,U) + ; setup array for bb accession areas if more than one + F S A=$O(^LRO(68,A)) Q:'A I $P($G(^LRO(68,A,0)),"^",2)="BB" D + . S BBLIST(A)="" + . S CNT=CNT+1 + I CNT'>1 Q 29 + S AREA=0 F S AREA=$O(BBLIST(AREA)) Q:'AREA D Q:FLAG + . ; get additional accession information for validation + . S ACCNODE=$G(^LRO(68,AREA,1,$P(DATE,"."),1,NUM,0)) + . S ACC=$G(^LRO(68,AREA,1,$P(DATE,"."),1,NUM,.2)) + . S DFN=$P($G(ACCNODE),U) + . S TDATE=$P($G(^LRO(68,AREA,1,$P(DATE,"."),1,NUM,3)),U) + . I (DFN=ECLRDFN)&(ACC=$P(ECXBNOD,U,6))&(DATE=TDATE) S FLAG=1 + Q AREA + ; +GETDATA ; gather rest of extract data that will be recorded in an + ; entry in file 727.829 + S ECTRFDT=$$ECXDOB^ECXUTL(ECARRY(1)),ECTRFTM=$$ECXTIME^ECXUTL(ECARRY(1)) + S ECX=$$INP^ECXUTL2(ECXDFN,ECARRY(1)),ECINOUT=$P(ECX,U),ECTRSP=$P(ECX,U,3),ECADMT=$P(ECX,U,4) ; [FLD #5] + ; + ;- Observation patient indicator (YES/NO) + S ECXOBS=$$OBSPAT^ECXUTL4(ECINOUT,ECTRSP) + ;- If no encounter number don't file record + S ECENCTR=$$ENCNUM^ECXUTL4(ECINOUT,ECPAT("SSN"),ECADMT,ECARRY(1),ECTRSP,ECXOBS,ECHEAD,,) ; [FLD #6] + Q:ECENCTR="" + ;get emergency response indicator (FEMA) + S ECXERI=ECPAT("ERI") + ; + S ECXSTR=$G(EC23)_"^"_ECINST_"^"_ECXDFN_"^"_ECPAT("SSN")_"^"_ECPAT("NAME")_"^"_ECINOUT_"^"_ECENCTR_"^"_ECTRFDT_"^"_ECTRFTM_"^"_ECARRY(3)_"^"_ECARRY(4)_"^"_ECARRY(5)_"^"_ECARRY(7)_"^"_ECARRY(6)_"^"_ECARRY(8)_"^BB"_ECARRY(13)_"^^" + I $G(ECXLOGIC)>2005 S ECXSTR=ECXSTR_U_ECXPHY_U_ECXPHYPC + I $G(ECXLOGIC)>2006 D + .S ECXSTR=ECXSTR_U_ECXERI_U_ECARRY(11)_U_ECARRY(12)_U_ECARRY(9)_U_ECARRY(10)_U_ECARRY(13) + I '$D(ECXRPT) D FILE(ECXSTR) Q + S ^TMP("ECXLBB",$J,ECXDFN,ECD)=ECXSTR ;temporary global array + ; used in ECXPLBB (pre-extract audit report) + Q + ; +GETDFN(ECXLRDFN) ; + ; INPUT - LRDFN + ; OUTPUT - DFN + ; Obtains DFN (Patient ID) from LRDFN (Lab Patient ID). + ; If no valid DFN exists, 0 is returned. + S ECXLRDFN=+$G(ECXLRDFN) + I $P($G(^LR(ECXLRDFN,0)),"^",2)'=2 Q 0 + Q +$P(^LR(ECXLRDFN,0),"^",3) + ; +PAT(ECXDFN) ;get/set patient data + ; INPUT - ECXDFN = patient ien (DFN) + ; OUTPUT - ECPAT array: + ; ECPAT("SSN") + ; ECPAT("NAME") + ; returns 0 or 1 in ECXERR - 0=successful + ; 1=error condition + N X,OK,ECXERR + ;get data + S ECXERR=0 + K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,"","1;3",.ECPAT) + I 'OK S ECXERR=1 + Q ECXERR + ; +FILE(ECODE) ; + ; Input - ECODE = extract record + ; + ; record the extract record at a global node in file 727.829 + ; sequence #^year/month of extract^extract #^facility^patient dfn^SSN^ + ; name^i/o pt indicator^encounter #^date of transfusion^time of + ; transfusion^component^component abbrev^# of units^volume in mm^ + ; reaction^reaction type^feeder location^DSS product dept^DSS IP # + ; ordering physician^ordering physician pc^emergency response indicator + ; (FEMA)^unit modified^unit modification^requesting provider^request. + ; provider person class + ;note: DSS product dept and DSS IP # are dependent on the release of + ; ECX*3*61 + N DA,DIK,EC7 + S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 + S ECODE=EC7_"^"_ECODE + S ^ECX(ECFILE,EC7,0)=ECODE,ECRN=ECRN+1 + S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA + Q + ; + ; +SETUP ;Set required input for ECXTRAC. + S ECHEAD="LBB" + D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) + Q + ; +LOCAL ; to extract nightly for local use not to be transmitted to TSI + ; should be queued with a 1D frequency + D SETUP,^ECXTLOCL,^ECXKILL Q + ; +QUE ; entry point for the background requeuing handled by ECXTAUTO + D SETUP,QUE^ECXTAUTO,^ECXKILL + Q + ; + ;ECXLBB diff --git a/r/DSS_EXTRACTS-ECX/ECXMOV.m b/r/DSS_EXTRACTS-ECX/ECXMOV.m index 3bd1598e..ad68bfc5 100644 --- a/r/DSS_EXTRACTS-ECX/ECXMOV.m +++ b/r/DSS_EXTRACTS-ECX/ECXMOV.m @@ -1,109 +1,107 @@ -ECXMOV ;ALB/JAP,BIR/DMA,PTD-Transfer and Discharge Extract ; 6/6/07 6:46am - ;;3.0;DSS EXTRACTS;**8,24,33,39,41,42,46,65,84,107,105**;Dec 22, 1997;Build 70 -BEG ;entry point from option - D SETUP I ECFILE="" Q - D ^ECXTRAC,^ECXKILL - Q - ; -START ; start package specific extract - N ECXDSC,W,WTO,X1,X2,X,ECXDPRPC,ECXDAPPC - K ECXDD D FIELD^DID(405,.19,,"SPECIFIER","ECXDD") - S ECPRO=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD - S ECED=ECED+.3,QFLG=0 - F ECM=2,3 S ECARG="ATT"_ECM,ECD=ECSD1 D Q:QFLG - .F S ECD=$O(^DGPM(ECARG,ECD)),ECDA=0 Q:('ECD)!(ECD>ECED) D Q:QFLG - ..F S ECDA=$O(^DGPM(ECARG,ECD,ECDA)) Q:'ECDA D Q:QFLG - ...Q:'$D(^DGPM(ECDA,0)) S EC=^(0) - ...S ECXDFN=+$P(EC,U,3),ECMT=$P(EC,U,18),ECXDATE=ECD - ...K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECXDATE,"."),"1;",.ECXPAT) - ...I 'OK K ECXPAT Q - ...S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI") - ...S ECTM=$$ECXTIME^ECXUTL(ECD) - ...S WTO=$P(EC,U,6),ECXWTO=$P($G(^DIC(42,+WTO,44)),U) - ...; - ...;reset EC to admission movement - ...S ECCA=$P(EC,U,14),EC=^DGPM(ECCA,0),ECA=$P(EC,U) - ...; - ...;if date of previous xfer movement is greater than admit date, - ...;then reset EC to that previous xfer movement - ...S ECDL=9999999.9999999-ECD,ECDL=+$O(^DGPM("ATID2",ECXDFN,ECDL)) - ...S ECDAL=+$O(^DGPM("ATID2",ECXDFN,ECDL,0)) - ...I $D(^DGPM(ECDAL,0)),$P(^(0),U)>$P(EC,U) S EC=^(0) - ...; - ...I ECM=2 D - ....;if transact=Transfer,ECD (time)=ASIH (7chars) and >0,set ECXDATE - ....;to Admit DT/time before calling funct to get in/out stat & TS - ....I $L($P(ECD,".",2))=7,+$E($P(ECD,".",2),7)>0 S ECXDATE=ECA - ....S W=$P(EC,U,6) - ...; - ...I ECM=3 D - ....;subtract 1 second from dischg DT so IN5^VADPT call (in ECXUTL2 - ....;API) will pick up discharge movmement record - ....S ECXDATE=$$FMADD^XLFDT(ECXDATE,,,,-1) - ....;set losing ward to ward at discharge - ....N WARD S WARD=$$GET1^DIQ(405,ECDA,200) - ....I WARD'="" S W=+$O(^DIC(42,"B",WARD,0)) - ...; - ...;-Gets inpat/outpat status, DOM, Treating Spec (TS) - ...S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECXA=$P(X,U),ECXDOM=$P(X,U,10),ECXTS=$P(X,U,3) - ...; - ...S (ECXWRD,ECXFAC,ECXDSSD)="" - ...I W'="" D - ....S ECXWRD=$P($G(^DIC(42,W,44)),U),ECXFAC=$P($G(^DIC(42,W,0)),U,11) - ....S ECXDSSD=$P($G(^ECX(727.4,W,0)),U,2) - ...S ECDI=$S(ECM=2:"",1:$$ECXDATE^ECXUTL(ECD,ECXYM)) - ...S X1=ECD,X2=$P(EC,U) D ^%DTC S ECXLOS=X - ...; - ...;- Get discharge PC Team, Primary and Assoc Primary Provider - ...S (ECXDPCT,ECXDPR,ECXDAPR,ECXDPRPC,ECXDAPPC)="" - ...I ECM=3 D - ....S ECXDSC=$$PRIMARY^ECXUTL2(ECXDFN,ECD) - ....S ECXDPCT=$P(ECXDSC,U),ECXDPR=$P(ECXDSC,U,2),ECXDAPR=$P(ECXDSC,U,5),ECXDPRPC=$P(ECXDSC,U,3),ECXDAPPC=$P(ECXDSC,U,6) - ....S ECDAPRNP=$P(ECXDSC,U,7),ECDPRNPI=$P(ECXDSC,U,4) - ...; - ...;Get production division ;p-46 - ...N ECXPDIV S ECXPDIV=$$GETDIV^ECXDEPT(ECXFAC) ;p-46 - ...;- Observation patient indicator (YES/NO) - ...S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) - ...; - ...;- If no encounter number, don't file record - ...S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECA,,ECXTS,ECXOBS,ECHEAD,,) - ...D:ECXENC'="" FILE - Q - ; -FILE ;file the extract record - ;node0 - ;fac ECXFAC^dfn ECXDFN^ssn ECXSSN^name ECXPNM^in/out ECXA^ - ;day (ECD)^^adm date (ECA)^disc date ECDI^mov # ECDA^ - ;type ECM^losing ward ECXWARD^treat spec ^los ECXLOS^^ - ;movement type ECMT^mov time ECTM^gaining ward ECXWTO^ - ;adm time (ECA)^^^ - ;node1 - ;mpi ECXMPI^dss dept ECXDSSD^dom ECXDOM^observ pat ind ECXOBS^ - ;encounter num ECXENC^disch prim prov ECXDPR^disch PC team ECXDPCT^ - ;disch assoc prim prov ECXDAPR^production division ECXPDIV - ;^disch prov person class ECXDPRPC^disch assoc prov pe- - ;rson person class^disch assoc pc prov npi ECDAPRNP^discharge pc provider npi ECDPRNPI - N DA,DIK - S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 - S ECODE=EC7_U_EC23_U_ECXFAC_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U - S ECODE=ECODE_$$ECXDATE^ECXUTL(ECD,ECXYM)_U_U - S ECODE=ECODE_$$ECXDATE^ECXUTL(ECA,ECXYM)_U_ECDI_U_ECDA_U_ECM_U_ECXWRD_U - S ECODE=ECODE_U_ECXLOS_U_U_ECMT_U_ECTM_U_ECXWTO_U - S ECODE=ECODE_$$ECXTIME^ECXUTL(ECA)_U_U_U - S ECODE1=ECXMPI_U_ECXDSSD_U_ECXDOM_U_ECXOBS_U_ECXENC_U_ECXDPR_U - S ECODE1=ECODE1_ECXDPCT_U_ECXDAPR_U_ECXPDIV ;p-46 added ECXPDIV - I ECXLOGIC>2005 S ECODE1=ECODE1_U_ECXDPRPC_U_ECXDAPPC - I ECXLOGIC>2007 S ECODE1=ECODE1_U_$G(ECDAPRNP)_U_$G(ECDPRNPI) - S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1 - S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA - I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 - Q - ; -SETUP ;Set required input for ECXTRAC - S ECHEAD="MOV" - D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) - Q - ; -QUE ; entry point for the background requeuing handled by ECXTAUTO - D SETUP,QUE^ECXTAUTO,^ECXKILL Q +ECXMOV ;ALB/JAP,BIR/DMA,PTD-Transfer and Discharge Extract ; 8/19/05 9:13am + ;;3.0;DSS EXTRACTS;**8,24,33,39,41,42,46,65,84**;Dec 22, 1997 +BEG ;entry point from option + D SETUP I ECFILE="" Q + D ^ECXTRAC,^ECXKILL + Q + ; +START ; start package specific extract + N ECXDSC,W,WTO,X1,X2,X,ECXDPRPC,ECXDAPPC + K ECXDD D FIELD^DID(405,.19,,"SPECIFIER","ECXDD") + S ECPRO=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD + S ECED=ECED+.3,QFLG=0 + F ECM=2,3 S ECARG="ATT"_ECM,ECD=ECSD1 D Q:QFLG + .F S ECD=$O(^DGPM(ECARG,ECD)),ECDA=0 Q:('ECD)!(ECD>ECED) D Q:QFLG + ..F S ECDA=$O(^DGPM(ECARG,ECD,ECDA)) Q:'ECDA D Q:QFLG + ...Q:'$D(^DGPM(ECDA,0)) S EC=^(0) + ...S ECXDFN=+$P(EC,U,3),ECMT=$P(EC,U,18),ECXDATE=ECD + ...K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECXDATE,"."),"1;",.ECXPAT) + ...I 'OK K ECXPAT Q + ...S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI") + ...S ECTM=$$ECXTIME^ECXUTL(ECD) + ...S WTO=$P(EC,U,6),ECXWTO=$P($G(^DIC(42,+WTO,44)),U) + ...; + ...;reset EC to admission movement + ...S ECCA=$P(EC,U,14),EC=^DGPM(ECCA,0),ECA=$P(EC,U) + ...; + ...;if date of previous xfer movement is greater than admit date, + ...;then reset EC to that previous xfer movement + ...S ECDL=9999999.9999999-ECD,ECDL=+$O(^DGPM("ATID2",ECXDFN,ECDL)) + ...S ECDAL=+$O(^DGPM("ATID2",ECXDFN,ECDL,0)) + ...I $D(^DGPM(ECDAL,0)),$P(^(0),U)>$P(EC,U) S EC=^(0) + ...; + ...I ECM=2 D + ....;if transact=Transfer,ECD (time)=ASIH (7chars) and >0,set ECXDATE + ....;to Admit DT/time before calling funct to get in/out stat & TS + ....I $L($P(ECD,".",2))=7,+$E($P(ECD,".",2),7)>0 S ECXDATE=ECA + ....S W=$P(EC,U,6) + ...; + ...I ECM=3 D + ....;subtract 1 second from dischg DT so IN5^VADPT call (in ECXUTL2 + ....;API) will pick up discharge movmement record + ....S ECXDATE=$$FMADD^XLFDT(ECXDATE,,,,-1) + ....;set losing ward to ward at discharge + ....N WARD S WARD=$$GET1^DIQ(405,ECDA,200) + ....I WARD'="" S W=+$O(^DIC(42,"B",WARD,0)) + ...; + ...;-Gets inpat/outpat status, DOM, Treating Spec (TS) + ...S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECXA=$P(X,U),ECXDOM=$P(X,U,10),ECXTS=$P(X,U,3) + ...; + ...S (ECXWRD,ECXFAC,ECXDSSD)="" + ...I W'="" D + ....S ECXWRD=$P($G(^DIC(42,W,44)),U),ECXFAC=$P($G(^DIC(42,W,0)),U,11) + ....S ECXDSSD=$P($G(^ECX(727.4,W,0)),U,2) + ...S ECDI=$S(ECM=2:"",1:$$ECXDATE^ECXUTL(ECD,ECXYM)) + ...S X1=ECD,X2=$P(EC,U) D ^%DTC S ECXLOS=X + ...; + ...;- Get discharge PC Team, Primary and Assoc Primary Provider + ...S (ECXDPCT,ECXDPR,ECXDAPR,ECXDPRPC,ECXDAPPC)="" + ...I ECM=3 D + ....S ECXDSC=$$PRIMARY^ECXUTL2(ECXDFN,ECD) + ....S ECXDPCT=$P(ECXDSC,U),ECXDPR=$P(ECXDSC,U,2),ECXDAPR=$P(ECXDSC,U,5),ECXDPRPC=$P(ECXDSC,U,3),ECXDAPPC=$P(ECXDSC,U,6) + ...; + ...;Get production division ;p-46 + ...N ECXPDIV S ECXPDIV=$$GETDIV^ECXDEPT(ECXFAC) ;p-46 + ...;- Observation patient indicator (YES/NO) + ...S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) + ...; + ...;- If no encounter number, don't file record + ...S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECA,,ECXTS,ECXOBS,ECHEAD,,) + ...D:ECXENC'="" FILE + Q + ; +FILE ;file the extract record + ;node0 + ;fac ECXFAC^dfn ECXDFN^ssn ECXSSN^name ECXPNM^in/out ECXA^ + ;day (ECD)^^adm date (ECA)^disc date ECDI^mov # ECDA^ + ;type ECM^losing ward ECXWARD^treat spec ^los ECXLOS^^ + ;movement type ECMT^mov time ECTM^gaining ward ECXWTO^ + ;adm time (ECA)^^^ + ;node1 + ;mpi ECXMPI^dss dept ECXDSSD^dom ECXDOM^observ pat ind ECXOBS^ + ;encounter num ECXENC^disch prim prov ECXDPR^disch PC team ECXDPCT^ + ;disch assoc prim prov ECXDAPR^production division ECXPDIV + ;^disch prov person class ECXDPRPC^disch assoc prov pe- + ;rson person class + N DA,DIK + S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 + S ECODE=EC7_U_EC23_U_ECXFAC_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U + S ECODE=ECODE_$$ECXDATE^ECXUTL(ECD,ECXYM)_U_U + S ECODE=ECODE_$$ECXDATE^ECXUTL(ECA,ECXYM)_U_ECDI_U_ECDA_U_ECM_U_ECXWRD_U + S ECODE=ECODE_U_ECXLOS_U_U_ECMT_U_ECTM_U_ECXWTO_U + S ECODE=ECODE_$$ECXTIME^ECXUTL(ECA)_U_U_U + S ECODE1=ECXMPI_U_ECXDSSD_U_ECXDOM_U_ECXOBS_U_ECXENC_U_ECXDPR_U + S ECODE1=ECODE1_ECXDPCT_U_ECXDAPR_U_ECXPDIV ;p-46 added ECXPDIV + I ECXLOGIC>2005 S ECODE1=ECODE1_U_ECXDPRPC_U_ECXDAPPC + S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1 + S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA + I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 + Q + ; +SETUP ;Set required input for ECXTRAC + S ECHEAD="MOV" + D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) + Q + ; +QUE ; entry point for the background requeuing handled by ECXTAUTO + D SETUP,QUE^ECXTAUTO,^ECXKILL Q diff --git a/r/DSS_EXTRACTS-ECX/ECXMTL.m b/r/DSS_EXTRACTS-ECX/ECXMTL.m index c5924024..e2a41073 100644 --- a/r/DSS_EXTRACTS-ECX/ECXMTL.m +++ b/r/DSS_EXTRACTS-ECX/ECXMTL.m @@ -1,171 +1,162 @@ -ECXMTL ;ALB/JAP - DSS Mental Health Extract ; 8/17/07 9:52am - ;;3.0;DSS EXTRACTS;**24,30,33,39,46,49,71,82,84,92,105**;Dec 22, 1997;Build 70 - ; -BEG ;entry point from option - D SETUP I ECFILE="" Q - D ^ECXTRAC,^ECXKILL - Q - ; -START ;entry point from tasked job - S QFLG=0 - ;get first record # - S EC7=$O(^ECX(ECFILE,999999999),-1) - ;call mh/dss api for extract record creation - ;variables ecfile,ecxym,ecinst,ecsd,eced passed in by taskmanager - S ECXSEQ=EC7,ECXECX=$P(EC23,U,2),ECXERR=0 - ;call mh api to create extract records - S X="YSDSS" X ^%ZOSF("TEST") I '$T S QFLG=1 Q - D UPD^YSDSS(ECFILE,.ECXSEQ,ECXYM,ECXECX,ECINST,ECSD,ECED,.ECXERR) - Q:ECXERR - Q:QFLG - ;if no error, continue - D UPDATE - Q - ; -UPDATE ;add non-mh data to each record created by mh api - N ECXADT,JJ,ECXNPRFI - S EC7=EC7+1 - F JJ=EC7:1:ECXSEQ Q:QFLG D - .Q:'$D(^ECX(ECFILE,JJ,0)) - .S ECXDFN=$P(^ECX(ECFILE,JJ,0),U,5),ECXDATE=$P(^ECX(ECFILE,JJ,0),U,9),ECXPRV=$P(^ECX(ECFILE,JJ,0),U,18) - .S ECXSCNUM=$P(^ECX(ECFILE,JJ,0),U,23),ECXSCNAM=$P(^ECX(ECFILE,JJ,0),U,24) - .D PAT(ECXDFN,ECXDATE) - .S (ECXPRCLS,ECPRNPI,ECXDIV,ECXPDIV)="" I ECXPRV D PROV(.ECXPRV,ECXDATE) - .S ECXDSSI="" - .I ECXLOGIC>2003 D - ..I "^18^23^24^36^41^65^94^"[("^"_ECXTS_"^") S ECXDSSI=$$TSMAP^ECXUTL4(ECXTS) - .; - .;- Observation patient indicator (YES/NO) - .S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXDSSI) - .; - .;- set national patient record flag if exist - .D NPRF^ECXUTL5 - .; - .;- If no encounter number don't file record - .S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADT,ECXDATE,ECXTS,ECXOBS,ECHEAD,,) Q:ECXENC="" - .S ECD=ECXDATE,ECXDATE=$$ECXDATE^ECXUTL(ECXDATE,ECXYM) - .;adjust scale name & scale number - .S ECXSCNAM=$E(ECXSCNAM,1,10) - .I ECXSCNUM]"",ECXSCNUM'=+ECXSCNUM S ECXSCNUM=+$E(ECXSCNUM,2,99) - .N ECXDEPT S ECXDEPT="" ;dss department use postponed S ECXDEPT=$$MTL^ECXDEPT(ECXDIV,ECXSCNAM,ECINST) ;p-46 line added - .;Set division to external value if extract is for FY05 or higher - .D FILE - Q - ; -PAT(ECXDFN,ECXDATE) ;determine in/outpatient status, demographics, primary care - N OK - S (ECXADT,ECXPNM,ECXSSN,ECXMPI)="" - K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,ECXDATE,"1;3;5;",.ECXPAT) - S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI") - S ECXDOB=ECXPAT("DOB") - ;agent orange status - S ECXAST=ECXPAT("AO STAT") - ;- Purple Heart Indicator, Period of Service, Agent Orange Location - S ECXPHI=$G(ECXPAT("PHI")),ECXPOS=ECXPAT("POS"),ECXAOL=ECXPAT("AOL") - I $$ENROLLM^ECXUTL2(ECXDFN) - ;Combat Veteran Status - S X3=$$CVEDT^ECXUTL5(ECXDFN,$S($G(ECD):ECD,$G(ECXDATE):ECXDATE,1:DT)) - ; - Head and Neck Cancer Indicator - S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) - ; - Race and Ethnicity - S ECXETH=ECXPAT("ETHNIC") - S ECXRC1=ECXPAT("RACE1") - ;get primary care data - S X=$$PRIMARY^ECXUTL2(ECXDFN,ECXDATE),ECPTTM=$P(X,U) - S ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4) - S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7) - ;get inpatient data - S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECXDOM=$P(X,U,10),ECXTS=$P(X,U,3) - S ECXA=$P(X,U),(ECXADT,ECXADMDT)=$P($P(X,U,4),"."),ECXDCDT=$P($P(X,U,6),".") - S ECXWPRV=$P(X,U,7),ECXATT=$P(X,U,8) - S ECWPRNPI=$$NPI^XUSNPI("Individual_ID",ECXWPRV,ECXDATE) - S:+ECWPRNPI'>0 ECWPRNPI="" S ECWPRNPI=$P(ECWPRNPI,U) - S ECATTNPI=$$NPI^XUSNPI("Individual_ID",ECXATT,ECXDATE) - S:+ECATTNPI'>0 ECATTNPI="" S ECATTNPI=$P(ECATTNPI,U) - ;Get ward provider and attending phy person classes - S ECXWPRPC=$P(X,U,11),ECXATTPC=$P(X,U,12) - I ECXADMDT S ECXADMDT=$$ECXDATE^ECXUTL(ECXADMDT,ECXYM) - I ECXDCDT S ECXDCDT=$$ECXDATE^ECXUTL(ECXDCDT,ECXYM) - Q - ; -PROV(ECXPRV,ECXDATE) ;get provider data - N INST,DGIEN,ARR,DIC,DR,DA,DIQ - S ECXPRCLS=$$PRVCLASS^ECXUTL(ECXPRV,ECXDATE) - S ECPRNPI=$$NPI^XUSNPI("Individual_ID",ECXPRV,ECXDATE) - S:+ECPRNPI'>0 ECPRNPI="" S ECPRNPI=$P(ECPRNPI,U) - ;get division identifier using provider - S (ECXDIV,ECXPDIV)="" - S IEN=0 F D Q:'IEN Q:'INST Q:ECXDIV - .;get pointer to file #4 from provider record - .I '$D(^VA(200,ECXPRV,0)) Q - .S IEN=$O(^VA(200,ECXPRV,2,IEN)) - .Q:'IEN - .S DIC="^VA(200,",DR="16",DA=ECXPRV - .S DR(200.02)=".01",DA(200.02)=IEN,DIQ="ARR",DIQ(0)="I" - .D EN^DIQ1 - .S INST=$G(ARR(200.02,IEN,.01,"I")) - .Q:'INST - .;get production division - .S ECXPDIV=$$RADDIV^ECXDEPT(INST) ;p-46 line added - .;get medical center division - .S DGIEN=$O(^DG(40.8,"AD",INST,0)) I DGIEN D - ..S ECXDIV=$P($G(^ECX(727.3,DGIEN,0)),U,2) - S ECXPRV="2"_ECXPRV - Q - ; -FILE ;file record in #727.812 - ;node0 - ;facility^dfn^ssn ECXSSN^name ECXPNM^i/o status ECXA^ - ;day ECXDATE^division ECXDIV^admit date ECXADMDT^ - ;d/c date ECXDCDT^dss id ECXDSSI^pc team ECPTTM^pc provider ECPTPR^ - ;placeholder^pc prov person class ECCLAS^ - ;provider ECXPRV^placeholder^prov person class ECXPRCLS^ - ;test name ECXSCNAM(?)^test ien ECXSCNUM(?)^scale number^scale name^ - ;test score^scale score^attend phys^ward provider - ;node1 - ;mpi^assoc pc provider^placeholder^ - ;assoc pc prov person class^asi class^asi special^asi encounter date^ - ;purple heart ind.^dom prrtp & saartp ind.^enrollment cat^ - ;enrollment stat^enrollment prior^period of serv.^obs. pat ind.^ - ;encounter num^agent orange loc^dob^production division^dss - ;department ECXDEPT^head & neck canc. indi.^ethnicity^race1^^ - ;enrollment prior ECXPRIOR_enrollment subgroup - ;ECXSBGRP^enrollee user ECXUESTA^division ECXDIV^patient type - ;ECXPTYPE^combat vet elig ECXCVE^combat vet elig end date ECXCVEDT^ - ;enc cv eligible ECXCVENC^national patient record flag ECXNPRFI - ;attending phy person class ECXATTPC^ward provider person class - ;ECXWPRPC^^agent orange status ECXAST^asso prov npi ECASNPI^att phy - ;npi ECATTNPI^primary care prov npi ECPTNPI^provider npi ECPRNPI^ward - ;provider npi ECWPRNPI - N DA,DIK,STR - I $P(^ECX(ECFILE,JJ,0),U,21)="ASI" S $P(^ECX(ECFILE,JJ,1),U,7)=ECXDATE - S $P(^ECX(ECFILE,JJ,0),U,6,9)=ECXSSN_U_ECXPNM_U_ECXA_U_ECXDATE - S STR=$S(ECXLOGIC<2005:ECXDIV,1:"")_U_ECXADMDT_U_ECXDCDT_U_ECXDSSI_U_ECPTTM_U_ECPTPR_U - S STR=STR_U_ECCLAS,$P(^ECX(ECFILE,JJ,0),U,10,17)=STR,STR="" - S $P(^ECX(ECFILE,JJ,0),U,18,20)=ECXPRV_U_U_ECXPRCLS - S $P(^ECX(ECFILE,JJ,0),U,23,24)=ECXSCNUM_U_ECXSCNAM - S $P(^ECX(ECFILE,JJ,0),U,27,29)=ECXATT_U_ECXWPRV_U - I '$D(^ECX(ECFILE,JJ,1)) S ^ECX(727.812,JJ,1)="^^^^^" - S $P(^ECX(ECFILE,JJ,1),U,1,4)=ECXMPI_U_ECASPR_U_U_ECCLAS2 - S STR=ECXPHI_U_ECXDOM_U_ECXCAT_U_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPOS_U - S STR=STR_ECXOBS_U_ECXENC_U_ECXAOL_U_ECXDOB_U_ECXPDIV_U_ECXDEPT_U - S STR=STR_ECXHNCI_U_ECXETH_U_ECXRC1_U - I ECXLOGIC>2004 S STR=STR_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXDIV_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI - I ECXLOGIC>2005 S STR=STR_U_ECXATTPC_U_ECXWPRPC - S $P(^ECX(ECFILE,JJ,1),U,8,22)=STR - I ECXLOGIC>2006 S $P(^ECX(ECFILE,JJ,1),U,34)=ECXAST_U - I ECXLOGIC>2007 S $P(^ECX(ECFILE,JJ,1),U,35)=ECASNPI_U_ECATTNPI_U_ECPTNPI_U D - . S ^ECX(ECFILE,JJ,2)=ECPRNPI_U_ECWPRNPI - S DA=JJ,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA - S ECRN=ECRN+1 - I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 - Q - ; -SETUP ;Set required input for ECXTRAC - S ECHEAD="MTL" - D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) - Q - ; -QUE ;Entry point for the background requeuing handled by ECXTAUTO. - D SETUP,QUE^ECXTAUTO,^ECXKILL - Q +ECXMTL ;ALB/JAP - DSS Mental Health Extract ; 9/11/06 11:07am + ;;3.0;DSS EXTRACTS;**24,30,33,39,46,49,71,82,84,92**;Dec 22, 1997;Build 30 + ; +BEG ;entry point from option + D SETUP I ECFILE="" Q + D ^ECXTRAC,^ECXKILL + Q + ; +START ;entry point from tasked job + S QFLG=0 + ;get first record # + S EC7=$O(^ECX(ECFILE,999999999),-1) + ;call mh/dss api for extract record creation + ;variables ecfile,ecxym,ecinst,ecsd,eced passed in by taskmanager + S ECXSEQ=EC7,ECXECX=$P(EC23,U,2),ECXERR=0 + ;call mh api to create extract records + S X="YSDSS" X ^%ZOSF("TEST") I '$T S QFLG=1 Q + D UPD^YSDSS(ECFILE,.ECXSEQ,ECXYM,ECXECX,ECINST,ECSD,ECED,.ECXERR) + Q:ECXERR + Q:QFLG + ;if no error, continue + D UPDATE + Q + ; +UPDATE ;add non-mh data to each record created by mh api + N ECXADT,JJ,ECXNPRFI + S EC7=EC7+1 + F JJ=EC7:1:ECXSEQ Q:QFLG D + .Q:'$D(^ECX(ECFILE,JJ,0)) + .S ECXDFN=$P(^ECX(ECFILE,JJ,0),U,5),ECXDATE=$P(^ECX(ECFILE,JJ,0),U,9),ECXPRV=$P(^ECX(ECFILE,JJ,0),U,18) + .S ECXSCNUM=$P(^ECX(ECFILE,JJ,0),U,23),ECXSCNAM=$P(^ECX(ECFILE,JJ,0),U,24) + .D PAT(ECXDFN,ECXDATE) + .S (ECXPRCLS,ECXPRNPI,ECXDIV,ECXPDIV)="" I ECXPRV D PROV(.ECXPRV,ECXDATE) + .S ECXDSSI="" + .I ECXLOGIC>2003 D + ..I "^18^23^24^36^41^65^94^"[("^"_ECXTS_"^") S ECXDSSI=$$TSMAP^ECXUTL4(ECXTS) + .; + .;- Observation patient indicator (YES/NO) + .S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXDSSI) + .; + .;- set national patient record flag if exist + .D NPRF^ECXUTL5 + .; + .;- If no encounter number don't file record + .S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADT,ECXDATE,ECXTS,ECXOBS,ECHEAD,,) Q:ECXENC="" + .S ECD=ECXDATE,ECXDATE=$$ECXDATE^ECXUTL(ECXDATE,ECXYM) + .;adjust scale name & scale number + .S ECXSCNAM=$E(ECXSCNAM,1,10) + .I ECXSCNUM]"",ECXSCNUM'=+ECXSCNUM S ECXSCNUM=+$E(ECXSCNUM,2,99) + .N ECXDEPT S ECXDEPT="" ;dss department use postponed S ECXDEPT=$$MTL^ECXDEPT(ECXDIV,ECXSCNAM,ECINST) ;p-46 line added + .;Set division to external value if extract is for FY05 or higher + .D FILE + Q + ; +PAT(ECXDFN,ECXDATE) ;determine in/outpatient status, demographics, primary care + N OK + S (ECXADT,ECXPNM,ECXSSN,ECXMPI)="" + K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,ECXDATE,"1;3;5;",.ECXPAT) + S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI") + S ECXDOB=ECXPAT("DOB") + ;agent orange status + S ECXAST=ECXPAT("AO STAT") + ;- Purple Heart Indicator, Period of Service, Agent Orange Location + S ECXPHI=$G(ECXPAT("PHI")),ECXPOS=ECXPAT("POS"),ECXAOL=ECXPAT("AOL") + I $$ENROLLM^ECXUTL2(ECXDFN) + ;Combat Veteran Status + S X3=$$CVEDT^ECXUTL5(ECXDFN,$S($G(ECD):ECD,$G(ECXDATE):ECXDATE,1:DT)) + ; - Head and Neck Cancer Indicator + S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) + ; - Race and Ethnicity + S ECXETH=ECXPAT("ETHNIC") + S ECXRC1=ECXPAT("RACE1") + ;get primary care data + S X=$$PRIMARY^ECXUTL2(ECXDFN,ECXDATE),ECPTTM=$P(X,U) + S ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4) + S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7) + ;get inpatient data + S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECXDOM=$P(X,U,10),ECXTS=$P(X,U,3) + S ECXA=$P(X,U),(ECXADT,ECXADMDT)=$P($P(X,U,4),"."),ECXDCDT=$P($P(X,U,6),".") + S ECXWPRV=$P(X,U,7),ECXATT=$P(X,U,8) + ;Get ward provider and attending phy person classes + S ECXWPRPC=$P(X,U,11),ECXATTPC=$P(X,U,12) + I ECXADMDT S ECXADMDT=$$ECXDATE^ECXUTL(ECXADMDT,ECXYM) + I ECXDCDT S ECXDCDT=$$ECXDATE^ECXUTL(ECXDCDT,ECXYM) + Q + ; +PROV(ECXPRV,ECXDATE) ;get provider data + N INST,DGIEN,ARR,DIC,DR,DA,DIQ + S ECXPRCLS=$$PRVCLASS^ECXUTL(ECXPRV,ECXDATE) + S ECXPRNPI="" + ;get division identifier using provider + S (ECXDIV,ECXPDIV)="" + S IEN=0 F D Q:'IEN Q:'INST Q:ECXDIV + .;get pointer to file #4 from provider record + .I '$D(^VA(200,ECXPRV,0)) Q + .S IEN=$O(^VA(200,ECXPRV,2,IEN)) + .Q:'IEN + .S DIC="^VA(200,",DR="16",DA=ECXPRV + .S DR(200.02)=".01",DA(200.02)=IEN,DIQ="ARR",DIQ(0)="I" + .D EN^DIQ1 + .S INST=$G(ARR(200.02,IEN,.01,"I")) + .Q:'INST + .;get production division + .S ECXPDIV=$$RADDIV^ECXDEPT(INST) ;p-46 line added + .;get medical center division + .S DGIEN=$O(^DG(40.8,"AD",INST,0)) I DGIEN D + ..S ECXDIV=$P($G(^ECX(727.3,DGIEN,0)),U,2) + S ECXPRV="2"_ECXPRV + Q + ; +FILE ;file record in #727.812 + ;node0 + ;facility^dfn^ssn ECXSSN^name ECXPNM^i/o status ECXA^ + ;day ECXDATE^division ECXDIV^admit date ECXADMDT^ + ;d/c date ECXDCDT^dss id ECXDSSI^pc team ECPTTM^pc provider ECPTPR^ + ;pc provider npi ECPTNPI^pc prov person class ECCLAS^ + ;provider ECXPRV^provider npi ECXPRNPI^prov person class ECXPRCLS^ + ;test name ECXSCNAM(?)^test ien ECXSCNUM(?)^scale number^scale name^ + ;test score^scale score^attend phys^ward provider + ;node1 + ;mpi^assoc pc provider^assoc pc provider npi^ + ;assoc pc prov person class^asi class^asi special^asi encounter date^ + ;purple heart ind.^dom prrtp & saartp ind.^enrollment cat^ + ;enrollment stat^enrollment prior^period of serv.^obs. pat ind.^ + ;encounter num^agent orange loc^dob^production division^dss + ;department ECXDEPT^head & neck canc. indi.^ethnicity^race1^^ + ;enrollment prior ECXPRIOR_enrollment subgroup + ;ECXSBGRP^enrollee user ECXUESTA^division ECXDIV^patient type + ;ECXPTYPE^combat vet elig ECXCVE^combat vet elig end date ECXCVEDT^ + ;enc cv eligible ECXCVENC^national patient record flag ECXNPRFI + ;attending phy person class ECXATTPC^ward provider person class + ;ECXWPRPC^^agent orange status ECXAST + N DA,DIK,STR + I $P(^ECX(ECFILE,JJ,0),U,21)="ASI" S $P(^ECX(ECFILE,JJ,1),U,7)=ECXDATE + S $P(^ECX(ECFILE,JJ,0),U,6,9)=ECXSSN_U_ECXPNM_U_ECXA_U_ECXDATE + S STR=$S(ECXLOGIC<2005:ECXDIV,1:"")_U_ECXADMDT_U_ECXDCDT_U_ECXDSSI_U_ECPTTM_U_ECPTPR_U + S STR=STR_ECPTNPI_U_ECCLAS,$P(^ECX(ECFILE,JJ,0),U,10,17)=STR,STR="" + S $P(^ECX(ECFILE,JJ,0),U,18,20)=ECXPRV_U_ECXPRNPI_U_ECXPRCLS + S $P(^ECX(ECFILE,JJ,0),U,23,24)=ECXSCNUM_U_ECXSCNAM + S $P(^ECX(ECFILE,JJ,0),U,27,29)=ECXATT_U_ECXWPRV_U + I '$D(^ECX(ECFILE,JJ,1)) S ^ECX(727.812,JJ,1)="^^^^^" + S $P(^ECX(ECFILE,JJ,1),U,1,4)=ECXMPI_U_ECASPR_U_ECASNPI_U_ECCLAS2 + S STR=ECXPHI_U_ECXDOM_U_ECXCAT_U_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPOS_U + S STR=STR_ECXOBS_U_ECXENC_U_ECXAOL_U_ECXDOB_U_ECXPDIV_U_ECXDEPT_U + S STR=STR_ECXHNCI_U_ECXETH_U_ECXRC1_U + I ECXLOGIC>2004 S STR=STR_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXDIV_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI + I ECXLOGIC>2005 S STR=STR_U_ECXATTPC_U_ECXWPRPC + S $P(^ECX(ECFILE,JJ,1),U,8,22)=STR + I ECXLOGIC>2006 S $P(^ECX(ECFILE,JJ,1),U,34)=ECXAST + S DA=JJ,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA + S ECRN=ECRN+1 + I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 + Q + ; +SETUP ;Set required input for ECXTRAC + S ECHEAD="MTL" + D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) + Q + ; +QUE ;Entry point for the background requeuing handled by ECXTAUTO. + D SETUP,QUE^ECXTAUTO,^ECXKILL + Q diff --git a/r/DSS_EXTRACTS-ECX/ECXNUT.m b/r/DSS_EXTRACTS-ECX/ECXNUT.m index 3b6923bf..863175ba 100644 --- a/r/DSS_EXTRACTS-ECX/ECXNUT.m +++ b/r/DSS_EXTRACTS-ECX/ECXNUT.m @@ -1,150 +1,141 @@ -ECXNUT ;ALB/JRC Nutrition DSS Extract ; 9/24/07 9:33am - ;;3.0;DSS EXTRACTS;**92,107,105**;Dec 22, 1997;Build 70 -BEG ;entry point from option - N EC23,EC7,ECED,ECFILE,ECGRP,ECHEAD,ECINST,ECPACK,ECPIECE,ECRN,ECRTN,ECSD1,ECVER,ECXYM - D SETUP I ECFILE="" Q - D ^ECXTRAC,^ECXKILL - Q - ; -START ; start package specific extract - ;Init variables - N ECSD,ARRAY - S ECED=ECED+.3,ECSD=ECSD1,ARRAY="^TMP($J,""FH"")" - K @ARRAY - ; - ;Call n&fs api and store in ^TMP($J,"FH" global - D DATA^FHDSSAPI(ECSD,ECED) - ; - ;Get n&fs records from ^TMP($J,"FH" global and file - D GETMEALS^ECXNUT1 - ; - ;kill ^tmp global - K @ARRAY - ; - Q - ; -GET ;gather extract data - ;Init variables - N ECXORDPC,ECXSSN,ECXPNM,ECXSEX,ECXDOB,ECXMPI,ECXRC1,ECXETH,ECXVET,ECXENRL,ECXELIG,ECXMST,ECXPST,ECXPLOC,ECXPHI,ECXMNS,ECXSTATE,ECXCNTY,ECXZIP,ECXPOS,ECXAST,ECXAOL,ECXRST,ECXEST,ECXTM,ECXDATE,ECXMN,ECXSPC - N ECXADMDT,ECXWRD,ECXFAC,ECXPRV,ECXPRNPI,ECXATT,ECXATNPI,ECXDOM,ECXATTPC,ECXPRVPC,ECXPDIV,ECXCBOC,ECPTPR,ECCLASS,ECPTTM,ECXOBS,ECXHNCI,ECXNPRFI,ECXERI,ECXENC,ECPAT,ECXERR,ADM,W,X,ECXCAT,ECXCVE,ECXPRIOR,ECXPTYPE,ECXSTAT,ECXUESTA,ECXA,ECORNPI - N ECXOEF,ECXOEFDT - ; - ;- Prefix ordering pro with a 2 and get person class - S ECXORDPC=$$PRVCLASS^ECXUTL(+ECXORDPH,DATE) - S ECORNPI=$$NPI^XUSNPI("Individual_ID",+ECXORDPH,DATE) - S:+ECORNPI'>0 ECORNPI="" S ECORNPI=$P(ECORNPI,U) - S ECXORDPH=$S(ECXORDPH:2_ECXORDPH,1:"") - ; - ;set patient file (#2) dfn and get patient demographics - S ECXDFN=$P($G(^TMP($J,"FH","ZN",FHDFN)),U,3) - S ECXERR=0 D PAT(ECXDFN) - Q:ECXERR - ;Set demographic variables - S ECXSSN=ECPAT("SSN"),ECXPNM=ECPAT("NAME"),ECXSEX=ECPAT("SEX"),ECXDOB=ECPAT("DOB"),ECXMPI=ECPAT("MPI"),ECXRC1=ECPAT("RACE1"),ECXETH=ECPAT("ETHNIC"),ECXVET=ECPAT("VET"),ECXENRL=ECPAT("ENROLL LOC"),ECXELIG=ECPAT("ELIG") - S ECXMST=ECPAT("MST STAT"),ECXPST=ECPAT("POW STAT"),ECXPLOC=ECPAT("POW LOC"),ECXPHI=ECPAT("PHI"),ECXMNS=ECPAT("MEANS"),ECXSTATE=ECPAT("STATE"),ECXCNTY=ECPAT("COUNTY"),ECXZIP=ECPAT("ZIP") - S ECXPOS=ECPAT("POS"),ECXAST=ECPAT("AO STAT"),ECXAOL=ECPAT("AOL"),ECXRST=ECPAT("IR STAT"),ECXEST=ECPAT("EC STAT") - ; - ;Get oef/oif data - S ECXOEF=ECPAT("ECXOEF") - S ECXOEFDT=ECPAT("ECXOEFDT") - ; - ;Get enrollment status - I $$ENROLLM^ECXUTL2(ECXDFN) - ; - S ECXTM=$$ECXTIME^ECXUTL(DATE) - S ECXDATE=$$ECXDATE^ECXUTL(+DATE,ECXYM) - ; - ;- Use movement record date & time - S ADM=$$INP^ECXUTL2(ECXDFN,DATE),ECXA=$P(ADM,U) - S ECXMN=$P(ADM,U,2),ECXSPC=$P(ADM,U,3),ECXADMDT=$P(ADM,U,4) - S W=$P(ADM,U,9),ECXWRD=$P(W,";",1),ECXFAC=$P(W,";",2) - S ECXPRV=$P(ADM,U,7),ECXPRNPI="",ECXATT=$P(ADM,U,8),ECXATNPI="" - S ECXDOM=$P(ADM,U,10),ECXATTPC=$P(ADM,U,12),ECXPRVPC=$P(ADM,U,11) - ; - S ECXPDIV=$$GETDIV^ECXDEPT(ECXFAC) ;Get production division - S ECXCBOC=$$CBOC^ECXSCX2(+ECXFAC) ;Get cboc facility - ; - ;- Get primary care data - S X=$$PRIMARY^ECXUTL2(ECXDFN,DATE) - S ECPTPR=$P(X,U,2),ECCLASS=$P(X,U,3),ECPTTM=$P(X,U),ECPTNPI=$P(X,U,4) - ; - ;- Observation patient indicator (YES/NO) - S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXSPC) - ; - ;- Get head and neck cancer indicator - S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) - ; - ;- Get national patient record flag indicator - N ECXNPRFI D NPRF^ECXUTL5 - ; - ;- National response indicator - S ECXERI=$$EMGRES^DGUTL(ECXDFN) - ; - ;- If null encounter number, don't file record - S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,DATE,ECXSPC,ECXOBS,ECHEAD,,) - D:ECXENC'="" FILE - Q - ; -PAT(ECXDFN) ;get/set patient data - ; INPUT - ECXDFN = patient ien (DFN) - ; OUTPUT - ECPAT array: - ; ECPAT("SSN") - ; ECPAT("NAME") - ; returns 0 or 1 in ECXERR - 0=successful - ; 1=error condition - N X,OK - ;get data - S ECXERR=0 - K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,"","1;2;3;5",.ECPAT) - I 'OK S ECXERR=1 - Q ECXERR - ; -FILE ;file the n&fs extract record - ;node - ;facility^dfn^ssn^name^in/out^day^time^treating specialty^ - ;ordering provider^ordering provider person class^primary - ;care provider^primary person class^primary care team^mpi^dob^sex^ - ;race 1^ethnicity^veteran^enrollment status^enrollment location^ - ;enrollment category^enrollment priority^eligibility^period of - ;service^agent orange status^agent orange location^radiation status - ;^environmental contaminants^mst status^head & neck cancer indicator - ;pow status^pow location^purple heart indicator^means test^state code - ;^county code^zip+4^observation patient indicator^rrtp,prrtp and - ;saartp indicator^encounter number^patient division^food production - ;division^delivery division^product feeder key^food production - ;facility^delivery location type^delivery feeder location^quantity^ - ;cboc^status^user enrollee^patient type^cv status eligibility^ - ;national patient record flag^emergency response indicator^admission - ;date^oef/oif ECXOEF^oef/oif return date ECXOEFDT^ordering provider - ;npi ECORNPI^primary care provider npi ECPTNPI - ; - N DA,DIK,ECODE,ECODE1 - S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 - S ECODE=EC7_U_EC23_U_ECINST_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U - ; - ;convert specialty to PTF Code - ; - N ECXDATA - S ECXDATA=$$TSDATA^DGACT(42.4,+ECXSPC,.ECXDATA) - S ECXSPC=$G(ECXDATA(7)) - ; - S ECODE=ECODE_ECXDATE_U_ECXTM_U_ECXSPC_U_ECXORDPH_U_ECXORDPC_U - S ECODE=ECODE_ECPTPR_U_ECCLASS_U_ECPTTM_U_ECXMPI_U_ECXDOB_U_ECXSEX_U - S ECODE=ECODE_ECXRC1_U_ECXETH_U_ECXVET_U_ECXSTAT_U_ECXENRL_U_ECXCAT_U - S ECODE=ECODE_ECXPRIOR_U_ECXELIG_U_ECXPOS_U_ECXAST_U_ECXAOL_U_ECXRST - S ECODE=ECODE_U_ECXEST_U_ECXMST_U_ECXHNCI_U_ECXPST_U_ECXPLOC_U_ECXPHI - S ECODE=ECODE_U_ECXMNS_U_ECXSTATE_U_ECXCNTY_U - S ECODE1=ECXZIP_U_ECXOBS_U_ECXDOM_U_ECXENC_U_ECXPDIV_U_ECXFPD_U - S ECODE1=ECODE1_ECXFDD_U_ECXKEY_U_ECXFPF_U_ECXDLT_U_ECXDFL_U_ECXQTY_U - S ECODE1=ECODE1_ECXCBOC_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXNPRFI_U - S ECODE1=ECODE1_ECXERI_U_$S(ECXADMDT:$$ECXDATE^ECXUTL(ECXADMDT,ECXYM),1:"") - I ECXLOGIC>2007 S ECODE1=ECODE1_U_ECXOEF_U_ECXOEFDT_U_$G(ECXTFU)_U_ECORNPI_U_ECPTNPI - S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1 - S ECRN=ECRN+1 - S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA - Q - ; -SETUP ;Set required input for ECXTRAC. - S ECHEAD="NUT" - D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) - Q +ECXNUT ;ALB/JRC Nutrition DSS Extract ; 4/2/2007 + ;;3.0;DSS EXTRACTS;**92,107**;Dec 22, 1997;Build 9 +BEG ;entry point from option + N EC23,EC7,ECED,ECFILE,ECGRP,ECHEAD,ECINST,ECPACK,ECPIECE,ECRN,ECRTN,ECSD1,ECVER,ECXYM + D SETUP I ECFILE="" Q + D ^ECXTRAC,^ECXKILL + Q + ; +START ; start package specific extract + ;Init variables + N ECSD + S ECED=ECED+.3,ECSD=ECSD1 + K ^TMP($J,"FH") + ; + ;Call n&fs api and store in ^TMP($J,"FH" global + D DATA^FHDSSAPI(ECSD,ECED) + ; + ;Get n&fs records from ^TMP($J,"FH" global and file + D GETMEALS^ECXNUT1 + ; + ;kill ^tmp global + K ^TMP($J,"FH") + ; + Q + ; +GET ;gather extract data + ;Init variables + N ECXORDPC,ECXSSN,ECXPNM,ECXSEX,ECXDOB,ECXMPI,ECXRC1,ECXETH,ECXVET,ECXENRL,ECXELIG,ECXMST,ECXPST,ECXPLOC,ECXPHI,ECXMNS,ECXSTATE,ECXCNTY,ECXZIP,ECXPOS,ECXAST,ECXAOL,ECXRST,ECXEST,ECXTM,ECXDATE,ECXMN,ECXSPC + N ECXADMDT,ECXWRD,ECXFAC,ECXPRV,ECXPRNPI,ECXATT,ECXATNPI,ECXDOM,ECXATTPC,ECXPRVPC,ECXPDIV,ECXCBOC,ECPTPR,ECCLASS,ECPTTM,ECXOBS,ECXHNCI,ECXNPRFI,ECXERI,ECXENC,ECPAT,ECXERR,ADM,W,X,ECXCAT,ECXCVE,ECXPRIOR,ECXPTYPE,ECXSTAT,ECXUESTA,ECXA + ; + ;- Prefix ordering pro with a 2 and get person class + S ECXORDPC=$$PRVCLASS^ECXUTL(+ECXORDPH,DATE) + S ECXORDPH=$S(ECXORDPH:2_ECXORDPH,1:"") + ; + ;set patient file (#2) dfn and get patient demographics + S ECXDFN=$P($G(^TMP($J,"FH","ZN",FHDFN)),U,3) + S ECXERR=0 D PAT(ECXDFN) + Q:ECXERR + ;Set demographic variables + S ECXSSN=ECPAT("SSN"),ECXPNM=ECPAT("NAME"),ECXSEX=ECPAT("SEX"),ECXDOB=ECPAT("DOB"),ECXMPI=ECPAT("MPI"),ECXRC1=ECPAT("RACE1"),ECXETH=ECPAT("ETHNIC"),ECXVET=ECPAT("VET"),ECXENRL=ECPAT("ENROLL LOC"),ECXELIG=ECPAT("ELIG") + S ECXMST=ECPAT("MST STAT"),ECXPST=ECPAT("POW STAT"),ECXPLOC=ECPAT("POW LOC"),ECXPHI=ECPAT("PHI"),ECXMNS=ECPAT("MEANS"),ECXSTATE=ECPAT("STATE"),ECXCNTY=ECPAT("COUNTY"),ECXZIP=ECPAT("ZIP") + S ECXPOS=ECPAT("POS"),ECXAST=ECPAT("AO STAT"),ECXAOL=ECPAT("AOL"),ECXRST=ECPAT("IR STAT"),ECXEST=ECPAT("EC STAT") + ; + ;Get enrollment status + I $$ENROLLM^ECXUTL2(ECXDFN) + ; + S ECXTM=$$ECXTIME^ECXUTL(DATE) + S ECXDATE=DATE + ; + ;- Use movement record date & time + S ADM=$$INP^ECXUTL2(ECXDFN,DATE),ECXA=$P(ADM,U) + S ECXMN=$P(ADM,U,2),ECXSPC=$P(ADM,U,3),ECXADMDT=$P(ADM,U,4) + S W=$P(ADM,U,9),ECXWRD=$P(W,";",1),ECXFAC=$P(W,";",2) + S ECXPRV=$P(ADM,U,7),ECXPRNPI="",ECXATT=$P(ADM,U,8),ECXATNPI="" + S ECXDOM=$P(ADM,U,10),ECXATTPC=$P(ADM,U,12),ECXPRVPC=$P(ADM,U,11) + ; + S ECXPDIV=$$GETDIV^ECXDEPT(ECXFAC) ;Get production division + S ECXCBOC=$$CBOC^ECXSCX2(+ECXFAC) ;Get cboc facility + ; + ;- Get primary care data + S X=$$PRIMARY^ECXUTL2(ECXDFN,DATE) + S ECPTPR=$P(X,U,2),ECCLASS=$P(X,U,3),ECPTTM=$P(X,U) + ; + ;- Observation patient indicator (YES/NO) + S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXSPC) + ; + ;- Get head and neck cancer indicator + S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) + ; + ;- Get national patient record flag indicator + N ECXNPRFI D NPRF^ECXUTL5 + ; + ;- National response indicator + S ECXERI=$$EMGRES^DGUTL(ECXDFN) + ; + ;- If null encounter number, don't file record + S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,DATE,ECXSPC,ECXOBS,ECHEAD,,) + D:ECXENC'="" FILE + Q + ; +PAT(ECXDFN) ;get/set patient data + ; INPUT - ECXDFN = patient ien (DFN) + ; OUTPUT - ECPAT array: + ; ECPAT("SSN") + ; ECPAT("NAME") + ; returns 0 or 1 in ECXERR - 0=successful + ; 1=error condition + N X,OK + ;get data + S ECXERR=0 + K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,"","1;2;3;5",.ECPAT) + I 'OK S ECXERR=1 + Q ECXERR + ; +FILE ;file the n&fs extract record + ;node + ;facility^dfn^ssn^name^in/out^day^time^treating specialty^ + ;ordering provider^ordering provider person class^primary + ;care provider^primary person class^primary care team^mpi^dob^sex^ + ;race 1^ethnicity^veteran^enrollment status^enrollment location^ + ;enrollment category^enrollment priority^eligibility^period of + ;service^agent orange status^agent orange location^radiation status + ;^environmental contaminants^mst status^head & neck cancer indicator + ;pow status^pow location^purple heart indicator^means test^state code + ;^county code^zip+4^observation patient indicator^rrtp,prrtp and + ;saartp indicator^encounter number^patient division^food production + ;division^delivery division^product feeder key^food production + ;facility^delivery location type^delivery feeder location^quantity^ + ;cboc^status^user enrollee^patient type^cv status eligibility^ + ;national^patient record flag^emergency response indicator^admission + ;date + ; + N DA,DIK,ECODE,ECODE1 + S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 + S ECODE=EC7_U_EC23_U_ECINST_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U + ; + ;convert specialty to PTF Code + ; + N ECXDATA + S ECXDATA=$$TSDATA^DGACT(42.4,+ECXSPC,.ECXDATA) + S ECXSPC=$G(ECXDATA(7)) + ; + S ECODE=ECODE_$$ECXDATE^ECXUTL(DATE,ECXYM)_U_ECXTM_U_ECXSPC_U_ECXORDPH_U_ECXORDPC_U + S ECODE=ECODE_ECPTPR_U_ECCLASS_U_ECPTTM_U_ECXMPI_U_ECXDOB_U_ECXSEX_U + S ECODE=ECODE_ECXRC1_U_ECXETH_U_ECXVET_U_ECXSTAT_U_ECXENRL_U_ECXCAT_U + S ECODE=ECODE_ECXPRIOR_U_ECXELIG_U_ECXPOS_U_ECXAST_U_ECXAOL_U_ECXRST + S ECODE=ECODE_U_ECXEST_U_ECXMST_U_ECXHNCI_U_ECXPST_U_ECXPLOC_U_ECXPHI + S ECODE=ECODE_U_ECXMNS_U_ECXSTATE_U_ECXCNTY_U + S ECODE1=ECXZIP_U_ECXOBS_U_ECXDOM_U_ECXENC_U_ECXPDIV_U_ECXFPD_U + S ECODE1=ECODE1_ECXFDD_U_ECXKEY_U_ECXFPF_U_ECXDLT_U_ECXDFL_U_ECXQTY_U + S ECODE1=ECODE1_ECXCBOC_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXNPRFI_U + S ECODE1=ECODE1_ECXERI_U_$S(ECXADMDT:$$ECXDATE^ECXUTL(ECXADMDT,ECXYM),1:"") + S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1 + S ECRN=ECRN+1 + S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA + Q + ; +SETUP ;Set required input for ECXTRAC. + S ECHEAD="NUT" + D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) + Q diff --git a/r/DSS_EXTRACTS-ECX/ECXNUT1.m b/r/DSS_EXTRACTS-ECX/ECXNUT1.m index 99faaa39..dcdebe22 100644 --- a/r/DSS_EXTRACTS-ECX/ECXNUT1.m +++ b/r/DSS_EXTRACTS-ECX/ECXNUT1.m @@ -1,208 +1,114 @@ -ECXNUT1 ;ALB/JRC Nutrition DSS Extract ; 11/23/07 12:27pm - ;;3.0;DSS EXTRACTS;**92,107,105**;Dec 22, 1997;Build 70 - Q -GETMEALS ;get patient meals - ; variable names: ordate - regular diet order date - ; sdate - diet order npo/withhold date - ; norder - "sf" or "so" order date - ; note: there is a relationship - ; between "sf", "so" and regular diets - ; adate - admission date - ; ddate - discharge date - N I,J,P,D,ECXADM,FHDFN,ORDATE,DATES,NODE,SF,PRODUCT,ECXQTY,ORDER,ECXORDPH,ECXKEY,ECXFPD,ECXFDD,ECXFPF,ECXDLT,ECXDFL,MEAL,MEALS,SORDATE,NUMBER,TF,TFNODE,ECXTFU,SDATE - ;set ecsd to first day of the month before setting meals array - S ECSD=ECSD+.1,ECXTFU="" - ;setup individual meals array for inpatients - F I=ECSD:1:ECED F J=I+.0800,I+.1300,I+.1800 S MEALS(J)=J - ;get "inp", "sf", and "so" inpatient meals - S ECXADM=0 F S ECXADM=$O(@ARRAY@(ECXADM)) Q:'ECXADM D - .S FHDFN=0 F S FHDFN=$O(@ARRAY@(ECXADM,FHDFN)) Q:'FHDFN D - ..S ORDATE=0,(ADATE,DDATE,SDATE)="" - ..F S ORDATE=$O(@ARRAY@(ECXADM,FHDFN,ORDATE)) Q:'ORDATE D - ...Q:$P($G(^TMP($J,"FH",ECXADM,FHDFN,+ORDATE,"INP")),U,7)'="" - ...S DATES=$$GETDATES(),SDATE=ORDATE - ...;create regular diet individual meals - ...S P="INP",D="PD" - ...;get new order date and time if exist - ...S NORDER=$$NEWORDER(D,ORDATE) - ...S NODE=$G(^TMP($J,"FH",ECXADM,FHDFN,ORDATE,"INP")) Q:'NODE - ...S PRODUCT=$P(NODE,U,13),ECXQTY=1,ORDER=""_$P(NODE,U,14)_","_"" - ...;Resolve feeder key for nutrition product - ...S ECXKEY=$$NUTKEY^ECXUTL6(D,PRODUCT) - ...I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL) - ...S MEAL=ORDATE F S MEAL=$O(MEALS(MEAL)) Q:'MEAL D - ....I $P(DATES,U) Q:MEAL>$P(DATES,U) - ....I NORDER]"" Q:MEAL>NORDER - ....I $P(DATES,U,3) Q:MEAL>$P(DATES,U,3) - ....S ECXORDPH=$$GET1^DIQ(100,+ORDER,1,"I") - ....;Get additional data and file record. - ....S DATE=MEAL D GET^ECXNUT - ;create supplemental feeding meals if they exist - S ECXADM=0 F S ECXADM=$O(@ARRAY@(ECXADM)) Q:'ECXADM D - .S FHDFN=0 F S FHDFN=$O(@ARRAY@(ECXADM,FHDFN)) Q:'FHDFN D - ..S ORDATE=0,(ADATE,DDATE,SDATE)="" - ..F S ORDATE=$O(@ARRAY@(ECXADM,FHDFN,ORDATE)) Q:'ORDATE D - ...S DATES=$$GETDATES() - ...;get "sf" orders if they exist - ...N SFNODE S (SFNODE,ECXORDPH,CDATE)="" - ...S SFNODE=$G(@ARRAY@(ECXADM,FHDFN,ORDATE,"SF")) - ...I +SFNODE D - ....S P="INP",D="SF" - ....;get new order date and time if exist - ....S NORDER=$$NEWORDER(D,ORDATE),CDATE=$P(SFNODE,U,32) - ....;order thru all "sf" product fields and generate records - ....F SF=5:2:27 S PRODUCT=$P(SFNODE,U,SF) S ECXQTY=$P(SFNODE,U,(SF+1)) D - .....Q:PRODUCT']"" - .....;Resolve external value for product key - .....S ECXKEY=$$NUTKEY^ECXUTL6("SF",PRODUCT) - .....I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL) - .....;create individual meals - .....F MEAL=ECSD:1:ECED D - ......I CDATE]"" Q:MEAL>CDATE - ......I NORDER]"" Q:MEAL>NORDER - ......I $P(DATES,U,3)]"" Q:MEAL>$P(DATES,U,3) - ......;Get additional data and file record. - ......S DATE=$P(MEAL,".")_"."_$S("57911"[SF:10,"13151719"[SF:14,1:18) - ......D GET^ECXNUT - ;create standing order meals if they exist - S ECXADM=0 F S ECXADM=$O(@ARRAY@(ECXADM)) Q:'ECXADM D - .S FHDFN=0 F S FHDFN=$O(@ARRAY@(ECXADM,FHDFN)) Q:'FHDFN D - ..S ORDATE=0,(ADATE,DDATE,SDATE)="" - ..F S ORDATE=$O(@ARRAY@(ECXADM,FHDFN,ORDATE)) Q:'ORDATE D - ...S DATES=$$GETDATES() - ...N SONODE,NUM S (SONODE,ECXORDPH)="",NUM=0 - ...S NUM=$O(@ARRAY@(ECXADM,FHDFN,ORDATE,"SO",NUM)) Q:'NUM D - ....S SONODE=$G(@ARRAY@(ECXADM,FHDFN,ORDATE,"SO",NUM)) - ....I +SONODE D - .....;create standing order meals - .....N SMEAL S P="INP",D="SO" - .....;get new order date and time if exist - .....S NORDER=$$NEWORDER(D,ORDATE),SMEAL=$P(SONODE,U,3) - .....S PRODUCT=$P(SONODE,U,2),ECXQTY=$P(SONODE,U,8) - .....;Resolve feeder key for nutrition product - .....S ECXKEY=$$NUTKEY^ECXUTL6(D,PRODUCT) - .....I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL) - .....;create individual meals - .....S MEAL=ORDATE F S MEAL=$O(MEALS(MEAL)) Q:'MEAL D - ......N TIME S TIME=$P(MEALS(MEAL),".",2) - ......Q:SMEAL'["B"&(TIME=08) - ......Q:SMEAL'["N"&(TIME=13) - ......Q:SMEAL'["E"&(TIME=18) - ......I $P(DATES,U) Q:MEAL>$P(DATES,U) - ......I NORDER]"" Q:MEAL>NORDER - ......I $P(DATES,U,3) Q:MEAL>$P(DATES,U,3) - ......;Get additional data and file record. - ......S DATE=MEAL D GET^ECXNUT - ;remove individual meals array - K MEALS - ;Get inpatient tube feedings - N P1,PNODE,CDATE,ECXTFU,MEALS - ;set daily meals array for inpatient tube feedings - F I=ECSD:1:ECED S MEALS(I)="" - S (FHDFN,DATE,P1,CDATE)=0,(ECXADM,NODE,ECXORDPH,PNODE)="" - S P="INP",D="TF" F S ECXADM=$O(^TMP($J,"FH",ECXADM)) Q:'ECXADM D - .F S FHDFN=$O(^TMP($J,"FH",ECXADM,FHDFN)) Q:'FHDFN D - ..F S DATE=$O(^TMP($J,"FH",ECXADM,FHDFN,DATE)) Q:'DATE D - ...S NODE=$G(^TMP($J,"FH",ECXADM,FHDFN,DATE,"TF")) Q:'NODE D - ....F S P1=$O(^TMP($J,"FH",ECXADM,FHDFN,DATE,"TF",P1)) Q:'P1 D - .....S PNODE=^TMP($J,"FH",ECXADM,FHDFN,DATE,"TF",P1,"P") - .....S ORDATE=DATE,DATES=$$GETDATES(),CDATE=$P(NODE,U,11) - .....S PRODUCT=$P(PNODE,U,1),ORDER=""_$P(NODE,U,14)_","_"" - .....S ECXQTY=$S($P(PNODE,U,3)["GM":$P(PNODE,U,3),1:$P(PNODE,U,4)) - .....S ECXTFU=$S($P(PNODE,U,3)["GM":"GM",1:"ML") - .....;Resolve external value for product key - .....S ECXKEY=$$NUTKEY^ECXUTL6(D,PRODUCT) - .....I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL) - .....;create daily meals - .....S MEAL=DATE F S MEAL=$O(MEALS(MEAL)) Q:'MEAL D - ......I $P(DATES,U) Q:MEAL>$P(DATES,U) - ......I CDATE]"" Q:MEAL>CDATE - ......I $P(DATES,U,3) Q:MEAL>$P(DATES,U,3) - ......S ECXORDPH=$$GET1^DIQ(100,ORDER,1,"I") - ......;Get additional data and file record. - ......S DATE=MEAL D GET^ECXNUT S DATE=ORDATE - ;Get outpatient recurring meals - S DATE=0,(ECXADM,NODE,ECXORDPH,ECXTFU)="" - S P="OP",D="RM" F S DATE=$O(^TMP($J,"FH",DATE)) Q:'DATE D - . S FHDFN=0 F S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN)) Q:'FHDFN D - .. S NUMBER=0 F S NUMBER=$O(^TMP($J,"FH",DATE,FHDFN,NUMBER)) Q:'NUMBER D - ... S NODE=$G(^TMP($J,"FH",DATE,FHDFN,NUMBER,"RM")) Q:'NODE - ... S PRODUCT=$P(NODE,U,2),ECXQTY=1,ORDER=""_$P(NODE,U,12)_","_"" - ... S PRODUCT=$$GET1^DIQ(111,PRODUCT,4,"I") - ... S ECXORDPH=$$GET1^DIQ(100,ORDER,1,"I") - ... ;Resolve external value for product key - ... S ECXKEY=$$NUTKEY^ECXUTL6("PD",PRODUCT) - ... I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL) - ... ;Get additional data and file record. - ... D GET^ECXNUT - ;Get outpatient tube feedings - S DATE=0,(ECXADM,NODE,ECXORDPH)="" - S P="OP",D="TF" F S DATE=$O(^TMP($J,"FH",DATE)) Q:'DATE D - . S FHDFN=0 F S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN)) Q:'FHDFN D - .. S NUMBER=0 F S NUMBER=$O(^TMP($J,"FH",DATE,FHDFN,NUMBER)) Q:'NUMBER D - ... S NODE=$G(^TMP($J,"FH",DATE,FHDFN,NUMBER,"RMTF")) Q:NODE="" - ... S TF=0 F S TF=$O(^TMP($J,"FH",DATE,FHDFN,NUMBER,"RMTF",TF)) Q:'TF D - .... S TFNODE=^TMP($J,"FH",DATE,FHDFN,NUMBER,"RMTF",TF) - .... S PRODUCT=$P(TFNODE,U,1),ECXQTY=$P(TFNODE,U,4) - .... ;Resolve external value for product key - .... S ECXKEY=$$NUTKEY^ECXUTL6("TF",PRODUCT) - .... I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL) - .... ;Get additional data and file record. - .... D GET^ECXNUT - ;Get outpatient special meals - S (FHDFN,DATE)=0,(ECXADM,NODE,ECXORDPH)="" - S P="OP",D="SM" F S DATE=$O(^TMP($J,"FH",DATE)) Q:'DATE D - . F S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN)) Q:'FHDFN D - .. S NODE=$G(^TMP($J,"FH",DATE,FHDFN,"SM")) Q:'NODE - .. S PRODUCT=$P(NODE,U,4),ECXQTY=1,ECXORDPH=$P(NODE,U,5) - .. S PRODUCT=$$GET1^DIQ(111,PRODUCT,4,"I") - .. ;Resolve external value for product key - .. S ECXKEY=$$NUTKEY^ECXUTL6("SM",PRODUCT) - .. I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL) - .. ;Get additional data and file record. - .. D GET^ECXNUT - ;Get outpatient guest meals - S (FHDFN,DATE)=0,(ECXADM,NODE,ECXORDPH)="" - S P="OP",D="GM" F S DATE=$O(^TMP($J,"FH",DATE)) Q:'DATE D - . F S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN)) Q:'FHDFN D - .. S NODE=$G(^TMP($J,"FH",DATE,FHDFN,"GM")) Q:'NODE - .. S PRODUCT=$P(NODE,U,13),ECXQTY=1 - .. ;Resolve external value for product key - .. S ECXKEY=$$NUTKEY^ECXUTL6("GM",PRODUCT) - .. I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL) - .. ;Get additional data and file record. - .. D GET^ECXNUT - Q -GETDATES() ;Get admit, discharge, npo/withhold dates,for "inp", "sf" and "so" - ; return in string i.e. stop date^admission date^discharge date - ; input: ecxadm - movement file ien - ; fhdfn - nutrition patient file (#115) - ; - ; output: stop date - npo/withhold date - ; admit date - admission date and time - ; discharge date - discharge date and time - ;init variables - N ADATE,DDATE,DATE,STDATE,NORDATE,IENS - ;check input - Q:'$G(ECXADM)!'$G(FHDFN) "0^0^0" - ;get admission and discharge dates - S (ADATE,DDATE,DATE,SDATE,NORDATE,STDATE)="",IENS=""_ECXADM_","_FHDFN_","_"",ADATE=$$GET1^DIQ(115.01,IENS,.01,"I"),DDATE=$$GET1^DIQ(115.01,IENS,18,"I") - ;get "inp" order's npo/withhold date return it as 'stdate' if exist - S DATE=ORDATE F S DATE=$O(@ARRAY@(ECXADM,FHDFN,DATE)) Q:'DATE D - .I $P($G(@ARRAY@(ECXADM,FHDFN,+DATE,"INP")),U,7)'="" S STDATE=DATE - Q STDATE_U_ADATE_U_DDATE -NEWORDER(TYPE,DATE) ;Look for new order for inpatient meal type if exist - ; Input ecxadm - movement # - ; fhdfn - nutrition file (#115) fhdfn - ; date - starting order date to begin lookup - ; type - meal type "sf", "so", or "pd" - ; Output: new order date and time for specific meal type - ;init variables - N NORDER - S NORDER="" - ;check input - Q:$G(TYPE)']""!'$G(DATE) NORDER - F S DATE=$O(@ARRAY@(ECXADM,FHDFN,DATE)) Q:'DATE Q:NORDER D - .S NODE=$G(^TMP($J,"FH",ECXADM,FHDFN,DATE,TYPE)) Q:'NODE - .S NORDER=DATE - Q NORDER +ECXNUT1 ;ALB/JRC Nutrition DSS Extract ; 10/27/06 1:53pm + ;;3.0;DSS EXTRACTS;**92**;Dec 22, 1997;Build 30 + Q + ; +GETMEALS ;get patient meals + ;init variables + N DATE,FHDFN,ECXADM,NODE,PRODUCT,ECXQTY,ORDER,ECXORDPH,ECXKEY,P,D + N ECXFPD,ECXFDD,ECXFPF,ECXDLT,ECXDFL,NUMBER,PNODE,SF,TF,TFNODE + ;S (DATE,FHDFN,NUMBER,ECXQTY)=0,(ECXADM,NODE,ORDER,ECXORDPH)="" + ;Get inpatient diets + ;S P="INP",D="PD" F S DATE=$O(^TMP($J,"FH",DATE)) Q:'DATE D + ;. F S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN)) Q:'FHDFN D + ;.. F S ECXADM=$O(^TMP($J,"FH",DATE,FHDFN,ECXADM)) Q:'ECXADM D + ;... S NODE=$G(^TMP($J,"FH",DATE,FHDFN,ECXADM,"INP")) Q:'NODE + ;... S PRODUCT=$P(NODE,U,13),ECXQTY=1,ORDER=""_$P(NODE,U,14)_","_"" + ;... S ECXORDPH=$$GET1^DIQ(100,+ORDER,1,"I") + ;... ;Resolve feeder key for nutrition product + ;... S ECXKEY=$$NUTKEY^ECXUTL6("PD",PRODUCT) + ;... I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL) + ;... ;Get additional data and file record. + ;... D GET^ECXNUT + ;Get inpatient supplemental feedings + ;S (FHDFN,DATE)=0,(ECXADM,NODE,ORDER,ECXORDPH)="" + ;S P="INP",D="SF" F S DATE=$O(^TMP($J,"FH",DATE)) Q:'DATE D + ;. F S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN)) Q:'FHDFN D + ;.. F S ECXADM=$O(^TMP($J,"FH",DATE,FHDFN,ECXADM)) Q:'ECXADM D + ;... S NODE=$G(^TMP($J,"FH",DATE,FHDFN,ECXADM,"SF")) Q:'NODE + ;... F SF=5:2:27 S PRODUCT=$P(NODE,U,SF) Q:PRODUCT']"" S ECXQTY=1 D + ;.... S ORDER=""_$P(NODE,U,7)_","_"" + ;.... S ECXORDPH=$$GET1^DIQ(100,ORDER,1,"I") + ;.... ;Resolve external value for product key + ;.... S ECXKEY=$$NUTKEY^ECXUTL6("SF",PRODUCT) + ;.... I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL) + ;.... ;Get additional data and file record. + ;.... D GET^ECXNUT + ;Get inpatient standing orders + ;S (FHDFN,DATE)=0,(ECXADM,NODE,ECXORDPH)="" + ;S P="INP",D="SO" F S DATE=$O(^TMP($J,"FH",DATE)) Q:'DATE D + ;. F S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN)) Q:'FHDFN D + ;.. F S ECXADM=$O(^TMP($J,"FH",DATE,FHDFN,ECXADM)) Q:'ECXADM D + ;... S NODE=$G(^TMP($J,"FH",DATE,FHDFN,ECXADM,"SO")) Q:'NODE + ;... S PRODUCT=$P(NODE,U,2),ECXQTY=1 + ;... ;Resolve external value for product key + ;... S ECXKEY=$$NUTKEY^ECXUTL6("SO",PRODUCT) + ;... I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL) + ;... ;Get additional data and file record. + ;... D GET^ECXNUT + ;Get inpatient tube feedings + ;S (FHDFN,DATE,P)=0,(ECXADM,NODE,ECXORDPH,PNODE)="" + ;S P="INP",D="TF" F S DATE=$O(^TMP($J,"FH",DATE)) Q:'DATE D + ;. F S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN)) Q:'FHDFN D + ;.. F S ECXADM=$O(^TMP($J,"FH",DATE,FHDFN,ECXADM)) Q:'ECXADM D + ;... S NODE=$G(^TMP($J,"FH",DATE,FHDFN,ECXADM,"TF")) Q:'NODE + ;... S P=$O(^TMP($J,"FH",DATE,FHDFN,ECXADM,"TF",P)) Q:'P D + ;.... S PNODE=^TMP($J,"FH",DATE,FHDFN,ECXADM,"TF",P,"P") + ;.... S PRODUCT=$P(PNODE,U,1),ECXQTY=$P(PNODE,U,4) + ;.... S ORDER=""_$P(NODE,U,14)_","_"" + ;.... S ECXORDPH=$$GET1^DIQ(100,ORDER,1,"I") + ;.... ;Resolve external value for product key + ;.... S ECXKEY=$$NUTKEY^ECXUTL6("TF",PRODUCT) + ;.... I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL) + ;.... ;Get additional data and file record. + ;.... D GET^ECXNUT + ;Get outpatient recurring meals + S (FHDFN,DATE)=0,(ECXADM,NODE,ECXORDPH)="" + S P="OP",D="RM" F S DATE=$O(^TMP($J,"FH",DATE)) Q:'DATE D + . F S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN)) Q:'FHDFN D + .. S NUMBER=0 F S NUMBER=$O(^TMP($J,"FH",DATE,FHDFN,NUMBER)) Q:'NUMBER D + ... S NODE=$G(^TMP($J,"FH",DATE,FHDFN,NUMBER,"RM")) Q:'NODE + ... S PRODUCT=$P(NODE,U,2),ECXQTY=1,ORDER=""_$P(NODE,U,12)_","_"" + ... S PRODUCT=$$GET1^DIQ(111,PRODUCT,4,"I") + ... S ECXORDPH=$$GET1^DIQ(100,ORDER,1,"I") + ... ;Resolve external value for product key + ... S ECXKEY=$$NUTKEY^ECXUTL6("PD",PRODUCT) + ... I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL) + ... ;Get additional data and file record. + ... D GET^ECXNUT + ;Get outpatient tube feedings + S (FHDFN,DATE,NUMBER)=0,(ECXADM,NODE,ECXORDPH)="" + S P="OP",D="TF" F S DATE=$O(^TMP($J,"FH",DATE)) Q:'DATE D + . F S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN)) Q:'FHDFN D + .. F S NUMBER=$O(^TMP($J,"FH",DATE,FHDFN,NUMBER)) Q:'NUMBER D + ... S NODE=$G(^TMP($J,"FH",DATE,FHDFN,NUMBER,"RMTF")) Q:'NODE + ... S TF=$O(^TMP($J,"FH",DATE,FHDFN,NUMBER,"RMTF",TF)) Q:'TF D + .... S TFNODE=^TMP($J,"FH",DATE,FHDFN,NUMBER,"RMTF",TF) + .... S PRODUCT=$P(TFNODE,U,1),ECXQTY=$P(TFNODE,U,4) + .... ;Resolve external value for product key + .... S ECXKEY=$$NUTKEY^ECXUTL6("TF",PRODUCT) + .... I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL) + .... ;Get additional data and file record. + .... D GET^ECXNUT + ;Get outpatient special meals + S (FHDFN,DATE)=0,(ECXADM,NODE,ECXORDPH)="" + S P="OP",D="SM" F S DATE=$O(^TMP($J,"FH",DATE)) Q:'DATE D + . F S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN)) Q:'FHDFN D + .. S NODE=$G(^TMP($J,"FH",DATE,FHDFN,"SM")) Q:'NODE + .. S PRODUCT=$P(NODE,U,13),ECXQTY=1,ECXORDPH=$P(NODE,U,5) + .. ;Resolve external value for product key + .. S ECXKEY=$$NUTKEY^ECXUTL6("SM",PRODUCT) + .. I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL) + .. ;Get additional data and file record. + .. D GET^ECXNUT + ;Get outpatient guest meals + S (FHDFN,DATE)=0,(ECXADM,NODE,ECXORDPH)="" + S P="OP",D="GM" F S DATE=$O(^TMP($J,"FH",DATE)) Q:'DATE D + . F S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN)) Q:'FHDFN D + .. S NODE=$G(^TMP($J,"FH",DATE,FHDFN,"GM")) Q:'NODE + .. S PRODUCT=$P(NODE,U,13),ECXQTY=1 + .. ;Resolve external value for product key + .. S ECXKEY=$$NUTKEY^ECXUTL6("GM",PRODUCT) + .. I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL) + .. ;Get additional data and file record. + .. D GET^ECXNUT + Q diff --git a/r/DSS_EXTRACTS-ECX/ECXOPRX.m b/r/DSS_EXTRACTS-ECX/ECXOPRX.m index 09d474b9..6f858f97 100644 --- a/r/DSS_EXTRACTS-ECX/ECXOPRX.m +++ b/r/DSS_EXTRACTS-ECX/ECXOPRX.m @@ -1,130 +1,125 @@ -ECXOPRX ;ALB/JAP,BIR/DMA,CML,PTD-Prescription Extract for DSS ; 11/5/07 8:17am - ;;3.0;DSS EXTRACTS;**10,11,8,13,24,30,33,38,39,46,49,71,81,84,92,105**;Dec 22, 1997;Build 70 - ; -BEG ;entry point from option - D SETUP I ECFILE="" Q - D ^ECXTRAC,^ECXKILL - Q - ; -START ;entry when queued - N X,DA,DIC,DIQ,DR,ECXNPRFI,ECRXPTST,ECNONVAP,ECRXNUM,ECXSCRX - S QFLG=0 - I '$D(ECINST) D - .S ECINST=+$P(^ECX(728,1,0),U) K ECXDIC S DA=ECINST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" - .D EN^DIQ1 S ECINST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC - ;before V6 - S ECPROF=6,ECD=$O(^PSRX("AL",0)) I ECD,ECDECED Q:QFLG F S ECRX=$O(^PSRX("AD",ECD,ECRX)),ECRFL="" Q:'ECRX F S ECRFL=$O(^PSRX("AD",ECD,ECRX,ECRFL)) Q:ECRFL="" D STUFF Q:QFLG - Q - ; -V6 ;version 6 or better - K ^TMP($J,"ECXP") - S ECPROF=2,ECED=ECED+.3,ECREF=1,ECD=ECSD1 - F S ECD=$O(^PSRX("AL",ECD)),ECRX=0 Q:'ECD Q:ECD>ECED Q:QFLG F S ECRX=$O(^PSRX("AL",ECD,ECRX)),ECRFL="" Q:'ECRX F S ECRFL=$O(^PSRX("AL",ECD,ECRX,ECRFL)) Q:ECRFL="" D STUFF Q:QFLG - Q:QFLG - S ECREF="P",ECD=ECSD1 - F S ECD=$O(^PSRX("AM",ECD)),ECRX=0 Q:'ECD Q:ECD>ECED Q:QFLG F S ECRX=$O(^PSRX("AM",ECD,ECRX)),ECRFL="" Q:'ECRX F S ECRFL=$O(^PSRX("AM",ECD,ECRX,ECRFL)) Q:ECRFL="" D STUFF Q:QFLG - K ^TMP($J,"ECXP") - Q - ; -STUFF ;get data - N ECXPHA - S ECDATA=$G(^PSRX(ECRX,0)),ECXPHA="" - I ECRFL S ECDATA1=$G(^PSRX(ECRX,ECREF,ECRFL,0)) I ECDATA1="" Q - ;ecref set to 1 in extract+5 and v6+1 and to "P" in v6+2 - ;refill nodes and partial nodes are identical in layout. Fills - ;(ie ecrfl=0)& refills (ie ecrfl>0) from "AL" xref, partials from "AM" - S (ECXDSSD,ECXPROVN,ECXCVE,ECXCVEDT,ECXCVENC,ECRXPTST,ECRXNUM)="",ECXERR=0,ECXDATE=ECD,ECXDFN=$P(ECDATA,U,2),ECDRG=+$P(ECDATA,U,6) - ;- Get rx patient status & rx number - S ECRXPTST=$$RXPTST^ECXUTL5($P(ECDATA,U,3)),ECRXNUM=$P(ECDATA,U,1) - ;- Get provider (either 2_provider or 6_provider depending on version) - S ECXPROV=$S($P(ECDATA,U,4)'="":ECPROF_$P(ECDATA,U,4),1:""),ECXPROVP=$$PRVCLASS^ECXUTL($P(ECDATA,U,4),ECXDATE) - S ECPRVNPI=$$NPI^XUSNPI("Individual_ID",$P(ECDATA,U,4),ECXDATE) - S:+ECPRVNPI'>0 ECPRVNPI="" S ECPRVNPI=$P(ECPRVNPI,U) - ;get classification data - S ECXCLS=$G(^PSRX(ECRX,"IBQ")),ECXMIL=$P(ECXCLS,U,2),ECXAO=$P(ECXCLS,U,3),ECXIR=$P(ECXCLS,U,4),ECXECE=$P(ECXCLS,U,5),ECXHNC=$P(ECXCLS,U,6) - F X="ECXMIL","ECXAO","ECXIR","ECXECE","ECXHNC" S @X=$S(@X:"Y",@X=0:"N",1:"") - ;- Check non-va provider flag and set to 'Y' if exist - S ECNONVAP=$$NONVAP^ECXUTL5($E(ECXPROV,2,99)) - ;get patient specific data - D PAT(ECXDFN,ECXDATE,.ECXERR) Q:ECXERR - I 'ECRFL D - .S ECMW=$P(ECDATA,U,11),ECQTY=+$P(ECDATA,U,7),ECXDIV=$S($D(^PSRX(ECRX,2)):$P(^(2),U,9),1:1) - .S ECPRC=+$P(ECDATA,U,17),ECOPAY=$P($G(^PSRX(ECRX,"IB")),U,2)]"" - I ECRFL D - .S ECMW=$P(ECDATA1,U,2),ECQTY=+$P(ECDATA1,U,4),ECXDIV=$S(+$P(ECDATA1,U,9):$P(ECDATA1,U,9),1:1) - .S ECPRC=+$P(ECDATA1,U,11),ECOPAY=$P($G(^PSRX(ECRX,1,ECRFL,"IB")),U)]"" - S ECXCOST=$J((ECQTY*ECPRC),1,2),ECDS=$S(ECRFL:$P(ECDATA1,U,10),1:$P(ECDATA,U,8)) - ;call pharmacy drug file (#50) api - S ECXPHA=$$PHAAPI^ECXUTL5(ECDRG),ECCAT=$P(ECXPHA,U,2),ECINV=$P(ECXPHA,U,4)["I",ECINV=$S(ECINV:"I",1:""),ECUI=$P(ECXPHA,U,8),ECNDC=$P(ECXPHA,U,3) - S ECNFC=$$RJ^XLFSTR($P(ECNDC,"-"),6,0)_$$RJ^XLFSTR($P(ECNDC,"-",2),4,0)_$$RJ^XLFSTR($P(ECNDC,"-",3),2,0),ECNFC=$TR(ECNFC,"*",0),P1=$P(ECXPHA,U,5),P3=$P(ECXPHA,U,6) - S X="PSNAPIS" X ^%ZOSF("TEST") I $T S ECNFC=$$DSS^PSNAPIS(P1,P3,ECXYM)_ECNFC - I $L(ECNFC)=12 S ECNFC=$$RJ^XLFSTR(P1,4,0)_$$RJ^XLFSTR(P3,3,0)_ECNFC - I ECMW="M" S ECMW=1 I $D(^PSRX("AR",ECD,ECRX)) S ECMW=2 - I ECMW="W" S ECMW="" - S ECXNEW="" I ECRFL=0 S ECXNEW=1 - S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) ;Observation pat indic (YES/NO) - S ECXORDPH="" ;Ordering physician (null for FY2002) - ;- Ordering stop code & Ordering date - S ECXORDST=$P($G(^ECX(728.44,+$P(ECDATA,U,5),0)),U,2),ECXORDDT=$$ECXDATE^ECXUTL(+$P(ECDATA,U,13),ECXYM) - S ECXCNH=$$CNHSTAT^ECXUTL4(ECXDFN) ;CNH status (YES/NO) - ;- DSS Dept and National Prod Division - ;S ECXDSSD=$$PRE^ECXDEPT(ECXDIV,ECMW,ECINST) dss department postponed - N ECXPDIV S ECXPDIV=$$PREDIV^ECXDEPT(ECXDIV) - ;- Set national patient record flag if exist - D NPRF^ECXUTL5 - S ECXSCRX=$$SCRX^ECXUTL5(ECRX) ;Service connected rx - ;- If no encounter number don't file record - S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,,) - I ECXLOGIC>2003 D - .I (ECMW=2)!((ECMW=1)&(ECXLOGIC>2006)),ECXSSN'="" D - ..N TMP S TMP=$$JULDT^ECXUTL4(ECD),ECXENC=$E(ECXSSN,1,9)_TMP_"160",ECXA="O" - I ECXENC'="" D FILE^ECXOPRX1 - Q - ; -PAT(ECXDFN,ECXDATE,ECXERR) ;Determine in/outpatient status, movement number, primary care team and provider - N OK,X,PT - S (ECXCAT,ECXSTAT,ECXPRIOR,ECXSBGRP,ECXOEF,ECXOEFDT)="" - ;get patient data if saved - I $D(^TMP($J,"ECXP",ECXDFN)) D - .S PT=^TMP($J,"ECXP",ECXDFN),ECXSSN=$P(PT,U),ECXPNM=$P(PT,U,2),ECXMPI=$P(PT,U,3),ECXSEX=$P(PT,U,4),ECXDOB=$P(PT,U,5) - .S ECXELIG=$P(PT,U,6),ECXVET=$P(PT,U,7),ECXRACE=$P(PT,U,8),ECXPST=$P(PT,U,9),ECXPLOC=$P(PT,U,10),ECXRST=$P(PT,U,11) - .S ECXAST=$P(PT,U,12),ECXMST=$P(PT,U,13),ECXSTATE=$P(PT,U,14),ECXCNTY=$P(PT,U,15),ECXZIP=$P(PT,U,16),ECXENRL=$P(PT,U,17) - .S ECXPHI=$P(PT,U,20),ECXCAT=$P(PT,U,21),ECXSTAT=$P(PT,U,22),ECXPRIOR=$P(PT,U,23) - .S ECXCNHU=$P(PT,U,24),ECXPOS=$P(PT,U,25),ECXAOL=$P(PT,U,26),ECXHNCI=$P(PT,U,27),ECXETH=$P(PT,U,28),ECXRC1=$P(PT,U,29),ECXMTST=$P(PT,U,30) - .S PT1=$G(^TMP($J,"ECXP",ECXDFN,1)),ECXERI=$P(PT1,U),ECXEST=$P(PT1,U,2),ECXOEF=$P(PT1,U,3),ECXOEFDT=$P(PT1,U,4) - .I $$ENROLLM^ECXUTL2(ECXDFN) - ;set patient data - I '$D(^TMP($J,"ECXP",ECXDFN)) D Q:'OK - .K ECXPAT - .S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECSD1,"."),"1;2;3;5",.ECXPAT) - .I 'OK S ECXERR=1 Q - .S ECXSSN=ECXPAT("SSN"),ECXPNM=ECXPAT("NAME"),ECXMPI=ECXPAT("MPI"),ECXSEX=ECXPAT("SEX"),ECXDOB=ECXPAT("DOB"),ECXELIG=ECXPAT("ELIG") - .S ECXVET=ECXPAT("VET"),ECXRACE=ECXPAT("RACE"),ECXPST=ECXPAT("POW STAT"),ECXPLOC=ECXPAT("POW LOC"),ECXRST=ECXPAT("IR STAT") - .S ECXAST=ECXPAT("AO STAT"),ECXMST=ECXPAT("MST STAT"),ECXSTATE=ECXPAT("STATE"),ECXCNTY=ECXPAT("COUNTY"),ECXZIP=ECXPAT("ZIP"),ECXENRL=ECXPAT("ENROLL LOC") - .S ECXERI=ECXPAT("ERI"),ECXEST=ECXPAT("EC STAT") - .;- CNH Stat (placeholder),Purp Heart Ind,Per of Svce,AO Loc,MT Stat - .S ECXCNHU="",ECXPHI=ECXPAT("PHI"),ECXPOS=ECXPAT("POS"),ECXAOL=ECXPAT("AOL"),ECXMTST=ECXPAT("MEANS") - .I $$ENROLLM^ECXUTL2(ECXDFN) - .S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) ;Head and Neck Cancer Indicator - .S ECXETH=ECXPAT("ETHNIC"),ECXRC1=ECXPAT("RACE1") ;Race and Ethnicity - .; OEF/OIF data - .S ECXOEF=ECXPAT("ECXOEF") - .S ECXOEFDT=ECXPAT("ECXOEFDT") - .S ^TMP($J,"ECXP",ECXDFN)=ECXSSN_U_ECXPNM_U_ECXMPI_U_ECXSEX_U_ECXDOB_U_ECXELIG_U_ECXVET_U_ECXRACE_U_ECXPST_U_ECXPLOC_U_ECXRST_U_ECXAST_U_ECXMST_U_ECXSTATE_U_ECXCNTY_U_ECXZIP_U_ECXENRL_U_U - .S ^TMP($J,"ECXP",ECXDFN)=^TMP($J,"ECXP",ECXDFN)_U_ECXPHI_U_ECXCAT_U_ECXSTAT_U_ECXPRIOR_U_ECXCNHU_U_ECXPOS_U_ECXAOL_U_ECXHNCI_U_ECXETH_U_ECXRC1_U_ECXMTST - .S ^TMP($J,"ECXP",ECXDFN,1)=ECXERI_U_ECXEST_U_ECXOEF_U_ECXOEFDT - ;get inpatient data - S (ECXA,ECXADMDT,ECXDOM,ECXMN,ECXTS)="",X=$$INP^ECXUTL2(ECXDFN,ECXDATE) D - .S ECXA=$P(X,U),ECXMN=$P(X,U,2),ECXTS=$P(X,U,3),ECXDOM=$P(X,U,10),ECXADMDT=$P(X,U,4) - ;get primary care data - S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXDATE,".")),ECPTTM=$P(X,U),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4),ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7) - Q - ; -SETUP ;Set required input for ECXTRAC - S ECHEAD="PRE" - D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) - Q -QUE ; entry point for the background requeuing handled by ECXTAUTO - D SETUP,QUE^ECXTAUTO,^ECXKILL Q +ECXOPRX ;ALB/JAP,BIR/DMA,CML,PTD-Prescription Extract for DSS ; 11/2/06 8:42am + ;;3.0;DSS EXTRACTS;**10,11,8,13,24,30,33,38,39,46,49,71,81,84,92**;Dec 22, 1997;Build 30 + ; +BEG ;entry point from option + D SETUP I ECFILE="" Q + D ^ECXTRAC,^ECXKILL + Q + ; +START ;entry when queued + N X,DA,DIC,DIQ,DR,ECXNPRFI,ECRXPTST,ECNONVAP,ECRXNUM,ECXSCRX + S QFLG=0 + I '$D(ECINST) D + .S ECINST=+$P(^ECX(728,1,0),U) K ECXDIC S DA=ECINST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" + .D EN^DIQ1 S ECINST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC + ;before V6 + S ECPROF=6,ECD=$O(^PSRX("AL",0)) I ECD,ECDECED Q:QFLG F S ECRX=$O(^PSRX("AD",ECD,ECRX)),ECRFL="" Q:'ECRX F S ECRFL=$O(^PSRX("AD",ECD,ECRX,ECRFL)) Q:ECRFL="" D STUFF Q:QFLG + Q + ; +V6 ;version 6 or better + K ^TMP($J,"ECXP") + S ECPROF=2,ECED=ECED+.3,ECREF=1,ECD=ECSD1 + F S ECD=$O(^PSRX("AL",ECD)),ECRX=0 Q:'ECD Q:ECD>ECED Q:QFLG F S ECRX=$O(^PSRX("AL",ECD,ECRX)),ECRFL="" Q:'ECRX F S ECRFL=$O(^PSRX("AL",ECD,ECRX,ECRFL)) Q:ECRFL="" D STUFF Q:QFLG + Q:QFLG + S ECREF="P",ECD=ECSD1 + F S ECD=$O(^PSRX("AM",ECD)),ECRX=0 Q:'ECD Q:ECD>ECED Q:QFLG F S ECRX=$O(^PSRX("AM",ECD,ECRX)),ECRFL="" Q:'ECRX F S ECRFL=$O(^PSRX("AM",ECD,ECRX,ECRFL)) Q:ECRFL="" D STUFF Q:QFLG + K ^TMP($J,"ECXP") + Q + ; +STUFF ;get data + N ECXPHA + S ECDATA=$G(^PSRX(ECRX,0)),ECXPHA="" + I ECRFL S ECDATA1=$G(^PSRX(ECRX,ECREF,ECRFL,0)) I ECDATA1="" Q + ;ecref set to 1 in extract+5 and v6+1 and to "P" in v6+2 + ;refill nodes and partial nodes are identical in layout. Fills + ;(ie ecrfl=0)& refills (ie ecrfl>0) from "AL" xref, partials from "AM" + S (ECXDSSD,ECXPROVN,ECXCVE,ECXCVEDT,ECXCVENC,ECRXPTST,ECRXNUM)="",ECXERR=0,ECXDATE=ECD,ECXDFN=$P(ECDATA,U,2),ECDRG=+$P(ECDATA,U,6) + ;- Get rx patient status & rx number + S ECRXPTST=$$RXPTST^ECXUTL5($P(ECDATA,U,3)),ECRXNUM=$P(ECDATA,U,1) + ;- Get provider (either 2_provider or 6_provider depending on version) + S ECXPROV=$S($P(ECDATA,U,4)'="":ECPROF_$P(ECDATA,U,4),1:""),ECXPROVP=$$PRVCLASS^ECXUTL($P(ECDATA,U,4),ECXDATE) + ;get classification data + S ECXCLS=$G(^PSRX(ECRX,"IBQ")),ECXMIL=$P(ECXCLS,U,2),ECXAO=$P(ECXCLS,U,3),ECXIR=$P(ECXCLS,U,4),ECXECE=$P(ECXCLS,U,5),ECXHNC=$P(ECXCLS,U,6) + F X="ECXMIL","ECXAO","ECXIR","ECXECE","ECXHNC" S @X=$S(@X:"Y",@X=0:"N",1:"") + ;- Check non-va provider flag and set to 'Y' if exist + S ECNONVAP=$$NONVAP^ECXUTL5($E(ECXPROV,2,99)) + ;get patient specific data + D PAT(ECXDFN,ECXDATE,.ECXERR) Q:ECXERR + I 'ECRFL D + .S ECMW=$P(ECDATA,U,11),ECQTY=+$P(ECDATA,U,7),ECXDIV=$S($D(^PSRX(ECRX,2)):$P(^(2),U,9),1:1) + .S ECPRC=+$P(ECDATA,U,17),ECOPAY=$P($G(^PSRX(ECRX,"IB")),U,2)]"" + I ECRFL D + .S ECMW=$P(ECDATA1,U,2),ECQTY=+$P(ECDATA1,U,4),ECXDIV=$S(+$P(ECDATA1,U,9):$P(ECDATA1,U,9),1:1) + .S ECPRC=+$P(ECDATA1,U,11),ECOPAY=$P($G(^PSRX(ECRX,1,ECRFL,"IB")),U)]"" + S ECXCOST=$J((ECQTY*ECPRC),1,2),ECDS=$S(ECRFL:$P(ECDATA1,U,10),1:$P(ECDATA,U,8)) + ;call pharmacy drug file (#50) api + S ECXPHA=$$PHAAPI^ECXUTL5(ECDRG),ECCAT=$P(ECXPHA,U,2),ECINV=$P(ECXPHA,U,4)["I",ECINV=$S(ECINV:"I",1:""),ECUI=$P(ECXPHA,U,8),ECNDC=$P(ECXPHA,U,3) + S ECNFC=$$RJ^XLFSTR($P(ECNDC,"-"),6,0)_$$RJ^XLFSTR($P(ECNDC,"-",2),4,0)_$$RJ^XLFSTR($P(ECNDC,"-",3),2,0),ECNFC=$TR(ECNFC,"*",0),P1=$P(ECXPHA,U,5),P3=$P(ECXPHA,U,6) + S X="PSNAPIS" X ^%ZOSF("TEST") I $T S ECNFC=$$DSS^PSNAPIS(P1,P3,ECXYM)_ECNFC + I $L(ECNFC)=12 S ECNFC=$$RJ^XLFSTR(P1,4,0)_$$RJ^XLFSTR(P3,3,0)_ECNFC + I ECMW="M" S ECMW=1 I $D(^PSRX("AR",ECD,ECRX)) S ECMW=2 + I ECMW="W" S ECMW="" + S ECXNEW="" I ECRFL=0 S ECXNEW=1 + S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) ;Observation pat indic (YES/NO) + S ECXORDPH="" ;Ordering physician (null for FY2002) + ;- Ordering stop code & Ordering date + S ECXORDST=$P($G(^ECX(728.44,+$P(ECDATA,U,5),0)),U,2),ECXORDDT=$$ECXDATE^ECXUTL(+$P(ECDATA,U,13),ECXYM) + S ECXCNH=$$CNHSTAT^ECXUTL4(ECXDFN) ;CNH status (YES/NO) + ;- DSS Dept and National Prod Division + ;S ECXDSSD=$$PRE^ECXDEPT(ECXDIV,ECMW,ECINST) dss department postponed + N ECXPDIV S ECXPDIV=$$PREDIV^ECXDEPT(ECXDIV) + ;- Set national patient record flag if exist + D NPRF^ECXUTL5 + S ECXSCRX=$$SCRX^ECXUTL5(ECRX) ;Service connected rx + ;- If no encounter number don't file record + S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,,) + I ECXLOGIC>2003 D + .I (ECMW=2)!((ECMW=1)&(ECXLOGIC>2006)),ECXSSN'="" D + ..N TMP S TMP=$$JULDT^ECXUTL4(ECD),ECXENC=$E(ECXSSN,1,9)_TMP_"160",ECXA="O" + I ECXENC'="" D FILE^ECXOPRX1 + Q + ; +PAT(ECXDFN,ECXDATE,ECXERR) ;Determine in/outpatient status, movement number, primary care team and provider + N OK,X,PT + S (ECXCAT,ECXSTAT,ECXPRIOR,ECXSBGRP)="" + ;get patient data if saved + I $D(^TMP($J,"ECXP",ECXDFN)) D + .S PT=^TMP($J,"ECXP",ECXDFN),ECXSSN=$P(PT,U),ECXPNM=$P(PT,U,2),ECXMPI=$P(PT,U,3),ECXSEX=$P(PT,U,4),ECXDOB=$P(PT,U,5) + .S ECXELIG=$P(PT,U,6),ECXVET=$P(PT,U,7),ECXRACE=$P(PT,U,8),ECXPST=$P(PT,U,9),ECXPLOC=$P(PT,U,10),ECXRST=$P(PT,U,11) + .S ECXAST=$P(PT,U,12),ECXMST=$P(PT,U,13),ECXSTATE=$P(PT,U,14),ECXCNTY=$P(PT,U,15),ECXZIP=$P(PT,U,16),ECXENRL=$P(PT,U,17) + .S ECXPHI=$P(PT,U,20),ECXCAT=$P(PT,U,21),ECXSTAT=$P(PT,U,22),ECXPRIOR=$P(PT,U,23) + .S ECXCNHU=$P(PT,U,24),ECXPOS=$P(PT,U,25),ECXAOL=$P(PT,U,26),ECXHNCI=$P(PT,U,27),ECXETH=$P(PT,U,28),ECXRC1=$P(PT,U,29),ECXMTST=$P(PT,U,30) + .S PT1=$G(^TMP($J,"ECXP",ECXDFN,1)),ECXERI=$P(PT1,U),ECXEST=$P(PT1,U,2) + .I $$ENROLLM^ECXUTL2(ECXDFN) + ;set patient data + I '$D(^TMP($J,"ECXP",ECXDFN)) D Q:'OK + .K ECXPAT + .S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECSD1,"."),"1;2;3;5",.ECXPAT) + .I 'OK S ECXERR=1 Q + .S ECXSSN=ECXPAT("SSN"),ECXPNM=ECXPAT("NAME"),ECXMPI=ECXPAT("MPI"),ECXSEX=ECXPAT("SEX"),ECXDOB=ECXPAT("DOB"),ECXELIG=ECXPAT("ELIG") + .S ECXVET=ECXPAT("VET"),ECXRACE=ECXPAT("RACE"),ECXPST=ECXPAT("POW STAT"),ECXPLOC=ECXPAT("POW LOC"),ECXRST=ECXPAT("IR STAT") + .S ECXAST=ECXPAT("AO STAT"),ECXMST=ECXPAT("MST STAT"),ECXSTATE=ECXPAT("STATE"),ECXCNTY=ECXPAT("COUNTY"),ECXZIP=ECXPAT("ZIP"),ECXENRL=ECXPAT("ENROLL LOC") + .S ECXERI=ECXPAT("ERI"),ECXEST=ECXPAT("EC STAT") + .;- CNH Stat (placeholder),Purp Heart Ind,Per of Svce,AO Loc,MT Stat + .S ECXCNHU="",ECXPHI=ECXPAT("PHI"),ECXPOS=ECXPAT("POS"),ECXAOL=ECXPAT("AOL"),ECXMTST=ECXPAT("MEANS") + .I $$ENROLLM^ECXUTL2(ECXDFN) + .S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) ;Head and Neck Cancer Indicator + .S ECXETH=ECXPAT("ETHNIC"),ECXRC1=ECXPAT("RACE1") ;Race and Ethnicity + .S ^TMP($J,"ECXP",ECXDFN)=ECXSSN_U_ECXPNM_U_ECXMPI_U_ECXSEX_U_ECXDOB_U_ECXELIG_U_ECXVET_U_ECXRACE_U_ECXPST_U_ECXPLOC_U_ECXRST_U_ECXAST_U_ECXMST_U_ECXSTATE_U_ECXCNTY_U_ECXZIP_U_ECXENRL_U_U + .S ^TMP($J,"ECXP",ECXDFN)=^TMP($J,"ECXP",ECXDFN)_U_ECXPHI_U_ECXCAT_U_ECXSTAT_U_ECXPRIOR_U_ECXCNHU_U_ECXPOS_U_ECXAOL_U_ECXHNCI_U_ECXETH_U_ECXRC1_U_ECXMTST + .S ^TMP($J,"ECXP",ECXDFN,1)=ECXERI_U_ECXEST + ;get inpatient data + S (ECXA,ECXADMDT,ECXDOM,ECXMN,ECXTS)="",X=$$INP^ECXUTL2(ECXDFN,ECXDATE) D + .S ECXA=$P(X,U),ECXMN=$P(X,U,2),ECXTS=$P(X,U,3),ECXDOM=$P(X,U,10),ECXADMDT=$P(X,U,4) + ;get primary care data + S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXDATE,".")),ECPTTM=$P(X,U),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4),ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7) + Q + ; +SETUP ;Set required input for ECXTRAC + S ECHEAD="PRE" + D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) + Q +QUE ; entry point for the background requeuing handled by ECXTAUTO + D SETUP,QUE^ECXTAUTO,^ECXKILL Q diff --git a/r/DSS_EXTRACTS-ECX/ECXOPRX1.m b/r/DSS_EXTRACTS-ECX/ECXOPRX1.m index 63365ec4..9d774de6 100644 --- a/r/DSS_EXTRACTS-ECX/ECXOPRX1.m +++ b/r/DSS_EXTRACTS-ECX/ECXOPRX1.m @@ -1,49 +1,47 @@ -ECXOPRX1 ;ALB/JAP,BIR/DMA,CML,PTD-Prescription Extract for DSS ; 6/6/07 7:23am - ;;3.0;DSS EXTRACTS;**92,107,105**;Dec 22, 1997;Build 70 - ; -FILE ;file record - ;node0 - ;inst^dfn^ssn^name^in/out ECXA^day^division^provider^drug category^mail^ - ;placeholder1^new^placeholder2^qty^cost^placeholder3^mov #^treat spec^placeholder4^unit of issue^dob^elig^vet^copay^ - ;feeder key^investigational^days supply^primary care team^primary care provider^time^race - ;node1 - ;mpi^dss dept ECXDSSD^sex^zip+4^placeholder^placeholder^state^county^pc prov person class^pow status^pow location^ - ;ir status^ao status^sharing agree. payor^sharing agree. ins.^mst status^enroll loc^assoc pc provider^assoc pc prov person class^ - ;placeholder^dom ECXDOM^purple heart ECXPHI^enrollment category ECXCAT^enrollment status ECXSTST^ - ;enrollment priority ECXPRIOR^cnhu status ECXCNHU^period of service ECXPOS^observ pat ind ECXOBS^encounter num ECXENC^ - ;ao loc ECXAOL^ord physician ECXORDPH^ord stop code ECXORDST^ord date ECXORDDT^CNH status ECXCNH^national division ECXPDIV^ - ;MT Stat ECXMTST^head & neck cancer ind. ECXHNCI^ethnicity ECXETH^race ECXRC1^^enrollment priority ECXPRIOR_ - ;enrollment subgroup ECXSBGRP^user enrollee ECXUESTA^patient type ECXPTYPE^combat vet elig ECXCVE^combat vet elig end date ECXCVEDT^ - ;enc cv eligible ECXCVENC^national patient record flag ECXNPRFI^rx patient status ECRXPTST^non-va prescriber ECNONVAP^rx # ECRXNUM - ;^emergency response indicator(FEMA) ECXERI^agent orange enc ECXAO^environ cont PGE ECXECE^head/neck ECXHNC^enc mst ECXMIL^environ contamin ECXEST^ion radiat ECXIR - ;OEF/OIF data ECXOEF^OEFOIF return date ECXOEFDT^associate pc provider npi ECASNPI^primary care provider npi ECPTNPI^provider npi ECPRVNPI - N DA,DIK - S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 - S ECODE=EC7_U_EC23_U_ECINST_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U - S ECODE=ECODE_$$ECXDATE^ECXUTL(ECXDATE,ECXYM)_U_ECXDIV_U - S ECODE=ECODE_ECXPROV_U_ECCAT_U_ECMW_U_ECXPROVP_U_ECXNEW_U_U_ECQTY_U - ;convert specialty to PTF Code for transmission - N ECXDATA - S ECXDATA=$$TSDATA^DGACT(42.4,+ECXTS,.ECXDATA) - S ECXTS=$G(ECXDATA(7)) - ;done - S ECODE=ECODE_ECXCOST_U_U_ECXMN_U_ECXTS_U_U_ECUI_U_ECXDOB_U - S ECODE=ECODE_ECXELIG_U_ECXVET_U_ECOPAY_U_ECNFC_U_ECINV_U_ECDS_U - S ECODE=ECODE_ECPTTM_U_ECPTPR_U_$$ECXTIME^ECXUTL(ECXDATE)_U_ECXRACE_U - S ECODE1=ECXMPI_U_ECXDSSD_U_ECXSEX_U_ECXZIP_U_ECXPROVN_U_U - S ECODE1=ECODE1_ECXSTATE_U_ECXCNTY_U_ECCLAS_U_ECXPST_U_ECXPLOC_U - S ECODE1=ECODE1_ECXRST_U_ECXAST_U_U_U_ECXMST_U_ECXENRL_U - S ECODE1=ECODE1_ECASPR_U_ECCLAS2_U_U_ECXDOM_U_ECXPHI_U_ECXCAT_U - S ECODE1=ECODE1_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXCNHU_U_ECXPOS_U_ECXOBS_U - S ECODE1=ECODE1_ECXENC_U_ECXAOL_U_ECXORDPH_U_ECXORDST_U_ECXORDDT_U - S ECODE1=ECODE1_ECXCNH_U_ECXPDIV_U_ECXMTST_U_ECXHNCI_U_ECXETH_U - S ECODE1=ECODE1_ECXRC1_U - I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U - I ECXLOGIC>2004 S ECODE2=ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI_U_ECRXPTST_U_ECNONVAP - I ECXLOGIC>2005 S ECODE2=ECODE2_U_ECRXNUM - I ECXLOGIC>2006 S ECODE2=ECODE2_U_ECXERI_U_ECXAO_U_ECXECE_U_ECXHNC_U_ECXMIL_U_ECXEST_U_ECXIR_U_ECXSCRX - I ECXLOGIC>2007 S ECODE2=ECODE2_U_ECXOEF_U_ECXOEFDT_U_ECASNPI_U_ECPTNPI_U_ECPRVNPI - S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,^ECX(ECFILE,EC7,2)=$G(ECODE2),ECRN=ECRN+1 - S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA - I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 - Q +ECXOPRX1 ;ALB/JAP,BIR/DMA,CML,PTD-Prescription Extract for DSS ; 4/19/2007 + ;;3.0;DSS EXTRACTS;**92,107**;Dec 22, 1997;Build 9 + ; +FILE ;file record + ;node0 + ;inst^dfn^ssn^name^in/out ECXA^day^division^provider^drug category^mail^ + ;placeholder1^new^placeholder2^qty^cost^placeholder3^mov #^treat spec^placeholder4^unit of issue^dob^elig^vet^copay^ + ;feeder key^investigational^days supply^primary care team^primary care provider^time^race + ;node1 + ;mpi^dss dept ECXDSSD^sex^zip+4^provider npi^pc provider npi^state^county^pc prov person class^pow status^pow location^ + ;ir status^ao status^sharing agree. payor^sharing agree. ins.^mst status^enroll loc^assoc pc provider^assoc pc prov person class^ + ;assoc pc prov npi^dom ECXDOM^purple heart ECXPHI^enrollment category ECXCAT^enrollment status ECXSTST^ + ;enrollment priority ECXPRIOR^cnhu status ECXCNHU^period of service ECXPOS^observ pat ind ECXOBS^encounter num ECXENC^ + ;ao loc ECXAOL^ord physician ECXORDPH^ord stop code ECXORDST^ord date ECXORDDT^CNH status ECXCNH^national division ECXPDIV^ + ;MT Stat ECXMTST^head & neck cancer ind. ECXHNCI^ethnicity ECXETH^race ECXRC1^^enrollment priority ECXPRIOR_ + ;enrollment subgroup ECXSBGRP^user enrollee ECXUESTA^patient type ECXPTYPE^combat vet elig ECXCVE^combat vet elig end date ECXCVEDT^ + ;enc cv eligible ECXCVENC^national patient record flag ECXNPRFI^rx patient status ECRXPTST^non-va prescriber ECNONVAP^rx # ECRXNUM + ;^emergency response indicator(FEMA) ECXERI^agent orange enc ECXAO^environ cont PGE ECXECE^head/neck ECXHNC^enc mst ECXMIL^environ contamin ECXEST^ion radiat ECXIR + N DA,DIK + S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 + S ECODE=EC7_U_EC23_U_ECINST_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U + S ECODE=ECODE_$$ECXDATE^ECXUTL(ECXDATE,ECXYM)_U_ECXDIV_U + S ECODE=ECODE_ECXPROV_U_ECCAT_U_ECMW_U_ECXPROVP_U_ECXNEW_U_U_ECQTY_U + ;convert specialty to PTF Code for transmission + N ECXDATA + S ECXDATA=$$TSDATA^DGACT(42.4,+ECXTS,.ECXDATA) + S ECXTS=$G(ECXDATA(7)) + ;done + S ECODE=ECODE_ECXCOST_U_U_ECXMN_U_ECXTS_U_U_ECUI_U_ECXDOB_U + S ECODE=ECODE_ECXELIG_U_ECXVET_U_ECOPAY_U_ECNFC_U_ECINV_U_ECDS_U + S ECODE=ECODE_ECPTTM_U_ECPTPR_U_$$ECXTIME^ECXUTL(ECXDATE)_U_ECXRACE_U + S ECODE1=ECXMPI_U_ECXDSSD_U_ECXSEX_U_ECXZIP_U_ECXPROVN_U_ECPTNPI_U + S ECODE1=ECODE1_ECXSTATE_U_ECXCNTY_U_ECCLAS_U_ECXPST_U_ECXPLOC_U + S ECODE1=ECODE1_ECXRST_U_ECXAST_U_U_U_ECXMST_U_ECXENRL_U + S ECODE1=ECODE1_ECASPR_U_ECCLAS2_U_ECASNPI_U_ECXDOM_U_ECXPHI_U_ECXCAT_U + S ECODE1=ECODE1_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXCNHU_U_ECXPOS_U_ECXOBS_U + S ECODE1=ECODE1_ECXENC_U_ECXAOL_U_ECXORDPH_U_ECXORDST_U_ECXORDDT_U + S ECODE1=ECODE1_ECXCNH_U_ECXPDIV_U_ECXMTST_U_ECXHNCI_U_ECXETH_U + S ECODE1=ECODE1_ECXRC1_U + I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U + I ECXLOGIC>2004 S ECODE2=ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI_U_ECRXPTST_U_ECNONVAP + I ECXLOGIC>2005 S ECODE2=ECODE2_U_ECRXNUM + I ECXLOGIC>2006 S ECODE2=ECODE2_U_ECXERI_U_ECXAO_U_ECXECE_U_ECXHNC_U_ECXMIL_U_ECXEST_U_ECXIR_U_ECXSCRX + S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,^ECX(ECFILE,EC7,2)=$G(ECODE2),ECRN=ECRN+1 + S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA + I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 + Q diff --git a/r/DSS_EXTRACTS-ECX/ECXPIVDN.m b/r/DSS_EXTRACTS-ECX/ECXPIVDN.m index 1c969ada..9bc77b81 100644 --- a/r/DSS_EXTRACTS-ECX/ECXPIVDN.m +++ b/r/DSS_EXTRACTS-ECX/ECXPIVDN.m @@ -1,135 +1,166 @@ -ECXPIVDN ;ALB/JAP,BIR/DMA,CML,PTD-Extract from IV EXTRACT DATA File (#728.113) ; 10/31/07 1:38pm - ;;3.0;DSS EXTRACTS;**10,11,8,13,24,33,39,46,49,71,84,96,92,107,105**;Dec 22, 1997;Build 70 -BEG ;entry point from option - D SETUP I ECFILE="" Q - D ^ECXTRAC,^ECXKILL - Q - ; -START ; start package specific extract - N DIC,DA,DR,DIQ,DFN,ECXNPRFI,ECXPHA - S QFLG=0 - I '$D(ECINST) D - .S ECINST=+$P(^ECX(728,1,0),U) K ECXDIC S DA=ECINST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" - .D EN^DIQ1 S ECINST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC - S ECED=ECED+.3 - K ^TMP($J,"A"),^TMP($J,"S") - S ECD=ECSD1 - F S ECD=$O(^ECX(728.113,"A",ECD)),DFN=0 Q:'ECD Q:ECD>ECED Q:QFLG F S DFN=$O(^ECX(728.113,"A",ECD,DFN)),ON=0 Q:'DFN F S ON=$O(^ECX(728.113,"A",ECD,DFN,ON)),DA=0 Q:'ON K ^TMP($J,"A"),^TMP($J,"S") S ECVOL=0 D Q:QFLG - .S ECXERR=0 D PAT(DFN,ECD,.ECXERR) - .Q:ECXERR - .F S DA=$O(^ECX(728.113,"A",ECD,DFN,ON,DA)) Q:'DA Q:QFLG I $D(^ECX(728.113,DA,0)) S EC=^(0) D Q:QFLG - ..S DRG=$P(EC,U,4) I $P(EC,U,8)]"" D - ...I '$D(^TMP($J,"A",DRG)) S ^(DRG)=$P(EC,U,7,8),^(DRG,1)=0,^(2)=$P(EC,U,12) - ...S ^(1)=^TMP($J,"A",DRG,1)+$S($P(EC,U,6)=1:1,$P(EC,U,6)=4:0,1:-1) - ..I $P(EC,U,9) D - ...I '$D(^TMP($J,"S",DRG)) S ^(DRG)=$P(EC,U,9)_"^ML",^(DRG,1)=0,^(2)=$P(EC,U,12),ECVOL=$P(EC,U,9)+ECVOL - ...S ^(1)=^TMP($J,"S",DRG,1)+$S($P(EC,U,6)=1:1,$P(EC,U,6)=4:0,1:-1) - ..S ECTYP=$P(EC,U,11),ECTOTC=0,ECDTTM=$$ECXTIME^ECXUTL($P(EC,U,5)) - .;looped thru all DAs for this order - now put it together - .;leave the next line in case the decision is made to send volume designations - .;I ECTYP="H" S ECTYP=ECTYP_$S(ECVOL'>1000:1,ECVOL'>2000:2,1:3) - .S ECXDSSI="" - .;loop thru tmp global and call pharmacy drug file (#50) api - .F SA="S","A" S DRG="" F S DRG=$O(^TMP($J,SA,DRG)) Q:DRG="" S ECXPHA="",ECXPHA=$$PHAAPI^ECXUTL5(DRG) I $P(ECXPHA,U)'="" D STUFF Q:QFLG - K ^TMP($J),CLIN,DA,DFN,DIC,DIK,DRG,ON,SA,X,Y,P1,P3 - Q -STUFF ;get data - N ECORDST - S ECST=^TMP($J,SA,DRG),ECXCNT=^(DRG,1),ECXCOST=^(2),ECXCOST=ECXCOST*ECXCNT,ECVACL=$P(ECXPHA,U,2),ECORDST="" - ;if outpatient get division from iv rm; get dss identifier for clinic - I ECXA="O" D - .;- Only set ward to .5 if outpatient (but NOT observation patient) - .I $G(ECXW)="" S ECXW=.5 - .I $P(EC,U,15) S ECIVRM=$P(EC,U,15),ECXDIV=$$PSJ59P5^ECXUTL5(ECIVRM) - .S CLIN=+$P(EC,U,13),(ECXP1,ECXP2)="000",ECXCL=$G(^ECX(728.44,CLIN,0)) Q:ECXCL="" - .S ECSC=$P(ECXCL,U,4),ECCSC=$P(ECXCL,U,5) - .I ECSC="" S ECSC=$P(ECXCL,U,2),ECCSC=$P(ECXCL,U,3) - .I ECSC S ECXP1=$$RJ^XLFSTR(ECSC,3,0),ECXP2=$$RJ^XLFSTR(ECCSC,3,0) - .I ECSC="" S ECSC=$P($G(^SC(ECXCL,0)),U,7),ECCSC=$P($G(^SC(ECXCL,0)),U,18) I ECSC D - ..S ECXP1=$P($G(^DIC(40.7,ECSC,0)),U,2) S:ECCSC]"" ECXP2=$P($G(^DIC(40.7,ECCSC,0)),U,2) - ..S ECXP1=$$RJ^XLFSTR(ECXP1,3,0),ECXP2=$$RJ^XLFSTR(ECXP2,3,0) - .S ECXDSSI=ECXP1_ECXP2 - .I ECXLOGIC>2003 D - ..I "^18^23^24^36^41^65^94^"[("^"_ECXTS_"^") S ECXDSSI=$$TSMAP^ECXUTL4(ECXTS) - S ECINV=$P(ECXPHA,U,4),ECINV=$S(ECINV["I":"I",1:""),ECST=ECXCNT*ECST_" "_$P(ECST,U,2) - S ECNDC=$P(ECXPHA,U,3),ECNFC=$$RJ^XLFSTR($P(ECNDC,"-"),6,0)_$$RJ^XLFSTR($P(ECNDC,"-",2),4,0)_$$RJ^XLFSTR($P(ECNDC,"-",3),2,0),ECNFC=$TR(ECNFC,"*",0) - S P1=$P(ECXPHA,U,5),P3=$P(ECXPHA,U,6) - S X="PSNAPIS" X ^%ZOSF("TEST") I $T S ECNFC=$$DSS^PSNAPIS(P1,P3,ECXYM)_ECNFC - I $L(ECNFC)=12 S ECNFC=$$RJ^XLFSTR(P1,4,0)_$$RJ^XLFSTR(P3,3,0)_ECNFC - ;- Ordering provider ("2"_provider) - S ECXORDPR=$S(+$P(EC,U,10):"2"_$P(EC,U,10),1:"") - N ECXUSRTN - S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",$P(EC,U,10),$P(EC,U,16)) - S:+ECXUSRTN'>0 ECXUSRTN="" S ECXOPNPI=$P(ECXUSRTN,U) - S ECXORDDT=$P(EC,U,16) ;- Ordering date - ;- Requesting physician (null for FY2002) - S ECXRPHY="" - ;- Department and National Prod Division - S ECXDSSD="" ;dss department use postponed $$IVP^ECXDEPT(ECXDIV) - N ECXPDIV S ECXPDIV=$$GETDIV^ECXDEPT(ECXDIV) - ;- Observation patient indicator (yes/no) - S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXDSSI) - ; - Ordering Date, Ordering Stop Code - S ECXORDST="" I ECXA="O" D - .S ECXORDST=$$DOIVPO^ECXUTL5(DFN,ON) - .I ECXOBS="NO" S ECORDST="160" - .I ECXOBS="YES" S ECORDST=$P($G(^ECX(727.831,+ECXTS,0)),U,6) - ;- If no encounter number don't file record - S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADM,ECD,ECXTS,ECXOBS,ECHEAD,ECORDST,) - ;get BCMA data - S (ECXBCDD,ECXBCDG,ECXBCUA,ECXBCIF)="" - ;get ordering provider person class - S ECXOPPC=$$PRVCLASS^ECXUTL($E(ECXORDPR,2,999),ECXORDDT) - ;set national patient record flag if exist - S ECXDFN=DFN D NPRF^ECXUTL5 K ECXDFN - D:ECXENC'="" FILE^ECXPIVD2 K P1,P3 - Q -PAT(ECXDFN,ECXDATE,ECXERR) ;get patient demographics, primary care, and inpatient data - N X - S (ECXCAT,ECXSTAT,ECXPRIOR,ECXSBGRP,ECXOEF,ECXOEFDT)="" - ;get patient data if saved - I $D(^TMP($J,"ECXP",ECXDFN)) D - .S PT=^TMP($J,"ECXP",ECXDFN),ECXPNM=$P(PT,U),ECXSSN=$P(PT,U,2),ECXMPI=$P(PT,U,3) - .S ECXDOB=$P(PT,U,4),ECXELIG=$P(PT,U,5),ECXSEX=$P(PT,U,6),ECXSTATE=$P(PT,U,7),ECXCNTY=$P(PT,U,8),ECXZIP=$P(PT,U,9) - .S ECXVET=$P(PT,U,10),ECXPOS=$P(PT,U,11),ECXPST=$P(PT,U,12),ECXPLOC=$P(PT,U,13),ECXRST=$P(PT,U,14),ECXAST=$P(PT,U,15) - .S ECXAOL=$P(PT,U,16),ECXPHI=$P(PT,U,17),ECXMST=$P(PT,U,18),ECXENRL=$P(PT,U,19),ECXCNHU=$P(PT,U,20),ECXCAT=$P(PT,U,21) - .S ECXSTAT=$P(PT,U,22),ECXPRIOR=$P(PT,U,23),ECXHNCI=$P(PT,U,24),ECXETH=$P(PT,U,25),ECXRC1=$P(PT,U,26),ECXMTST=$P(PT,U,27) - .S PT1=$G(^TMP($J,"ECXP",ECXDFN,1)),ECXERI=$P(PT1,U),ECXEST=$P(PT1,U,2),ECXOEF=$P(PT1,U,3),ECXOEFDT=$P(PT1,U,4) - .I $$ENROLLM^ECXUTL2(ECXDFN) - ;set patient data - I '$D(^TMP($J,"ECXP",ECXDFN)) D Q:'OK - .K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECXDATE,"."),"1;2;3;5",.ECXPAT) - .I 'OK K ECXPAT S ECXERR=1 Q - .S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI"),ECXDOB=ECXPAT("DOB"),ECXELIG=ECXPAT("ELIG"),ECXSEX=ECXPAT("SEX") - .S ECXSTATE=ECXPAT("STATE"),ECXCNTY=ECXPAT("COUNTY"),ECXZIP=ECXPAT("ZIP"),ECXVET=ECXPAT("VET") - .S ECXPOS=ECXPAT("POS"),ECXPST=ECXPAT("POW STAT"),ECXPLOC=ECXPAT("POW LOC"),ECXRST=ECXPAT("IR STAT") - .S ECXAST=ECXPAT("AO STAT"),ECXAOL=ECXPAT("AOL"),ECXPHI=ECXPAT("PHI"),ECXMST=ECXPAT("MST STAT") - .S ECXENRL=ECXPAT("ENROLL LOC"),ECXMTST=ECXPAT("MEANS"),ECXEST=ECXPAT("EC STAT") - .S ECXCNHU=$$CNHSTAT^ECXUTL4(ECXDFN) ;get CNHU status - .;get enrollment data (category, status and priority) - .I $$ENROLLM^ECXUTL2(ECXDFN) - .S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) ;Head and Neck Cancer Indicator - .; - Race and Ethnicity - .S ECXETH=ECXPAT("ETHNIC"),ECXRC1=ECXPAT("RACE1") - .S ECXERI=ECXPAT("ERI") ;emergency response indicator (FEMA) - .S ECXOEF=ECXPAT("ECXOEF") - .S ECXOEFDT=ECXPAT("ECXOEFDT") - .;save for later - .S ^TMP($J,"ECXP",ECXDFN)=ECXPNM_U_ECXSSN_U_ECXMPI_U_ECXDOB_U_ECXELIG_U_ECXSEX_U_ECXSTATE_U_ECXCNTY_U_ECXZIP_U_ECXVET_U_ECXPOS_U_ECXPST_U_ECXPLOC_U_ECXRST_U_ECXAST - .S ^TMP($J,"ECXP",ECXDFN)=^TMP($J,"ECXP",ECXDFN)_U_ECXAOL_U_ECXPHI_U_ECXMST_U_ECXENRL_U_ECXCNHU_U_ECXCAT_U_ECXSTAT_U_ECXPRIOR_U_ECXHNCI_U_ECXETH_U_ECXRC1_U_ECXMTST - .S ^TMP($J,"ECXP",ECXDFN,1)=ECXERI_U_ECXEST_U_ECXOEF_U_ECXOEFDT - ;get primary care data - S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXDATE,".")) - S ECPTTM=$P(X,U,1),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4),ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7) - ;get inpatient data - S (ECXA,ECXMN,ECXADM,ECXTS,ECXW,ECXDIV)="",X=$$INP^ECXUTL2(ECXDFN,ECXDATE) - S ECXA=$P(X,U),ECXMN=$P(X,U,2),ECXTS=$P(X,U,3),ECXADM=$P(X,U,4),W=$P(X,U,9),ECXDOM=$P(X,U,10),ECXW=$P(W,";"),ECXDIV=$P(W,";",2) - Q -SETUP ;Set required input for ECXTRAC - S ECHEAD="IVP" - D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) - ;variables ecver and ecrtn will be reset in routine ecxtrac if appropriate - S ECVER=7 - Q -QUE ; entry point for the background requeuing handled by ECXTAUTO - D SETUP,QUE^ECXTAUTO,^ECXKILL Q +ECXPIVDN ;ALB/JAP,BIR/DMA,CML,PTD-Extract from IV EXTRACT DATA File (#728.113) ; 4/19/2007 + ;;3.0;DSS EXTRACTS;**10,11,8,13,24,33,39,46,49,71,84,96,92,107**;Dec 22, 1997;Build 9 +START ; start package specific extract + N DIC,DA,DR,DIQ,DFN,ECXNPRFI,ECXPHA + S QFLG=0 + I '$D(ECINST) D + .S ECINST=+$P(^ECX(728,1,0),U) K ECXDIC S DA=ECINST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" + .D EN^DIQ1 S ECINST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC + S ECED=ECED+.3 + K ^TMP($J,"A"),^TMP($J,"S") + S ECD=ECSD1 + F S ECD=$O(^ECX(728.113,"A",ECD)),DFN=0 Q:'ECD Q:ECD>ECED Q:QFLG F S DFN=$O(^ECX(728.113,"A",ECD,DFN)),ON=0 Q:'DFN F S ON=$O(^ECX(728.113,"A",ECD,DFN,ON)),DA=0 Q:'ON K ^TMP($J,"A"),^TMP($J,"S") S ECVOL=0 D Q:QFLG + .S ECXERR=0 D PAT(DFN,ECD,.ECXERR) + .Q:ECXERR + .F S DA=$O(^ECX(728.113,"A",ECD,DFN,ON,DA)) Q:'DA Q:QFLG I $D(^ECX(728.113,DA,0)) S EC=^(0) D Q:QFLG + ..S DRG=$P(EC,U,4) I $P(EC,U,8)]"" D + ...I '$D(^TMP($J,"A",DRG)) S ^(DRG)=$P(EC,U,7,8),^(DRG,1)=0,^(2)=$P(EC,U,12) + ...S ^(1)=^TMP($J,"A",DRG,1)+$S($P(EC,U,6)=1:1,$P(EC,U,6)=4:0,1:-1) + ..I $P(EC,U,9) D + ...I '$D(^TMP($J,"S",DRG)) S ^(DRG)=$P(EC,U,9)_"^ML",^(DRG,1)=0,^(2)=$P(EC,U,12),ECVOL=$P(EC,U,9)+ECVOL + ...S ^(1)=^TMP($J,"S",DRG,1)+$S($P(EC,U,6)=1:1,$P(EC,U,6)=4:0,1:-1) + ..S ECTYP=$P(EC,U,11),ECTOTC=0,ECDTTM=$$ECXTIME^ECXUTL($P(EC,U,5)) + .;looped thru all DAs for this order - now put it together + .;leave the next line in case the decision is made to send volume designations + .;I ECTYP="H" S ECTYP=ECTYP_$S(ECVOL'>1000:1,ECVOL'>2000:2,1:3) + .S ECXDSSI="" + .;loop thru tmp global and call pharmacy drug file (#50) api + .F SA="S","A" S DRG="" F S DRG=$O(^TMP($J,SA,DRG)) Q:DRG="" S ECXPHA="",ECXPHA=$$PHAAPI^ECXUTL5(DRG) I $P(ECXPHA,U)'="" D STUFF Q:QFLG + K ^TMP($J),CLIN,DA,DFN,DIC,DIK,DRG,ON,SA,X,Y,P1,P3 + Q +STUFF ;get data + N ECORDST + S ECST=^TMP($J,SA,DRG),ECXCNT=^(DRG,1),ECXCOST=^(2),ECXCOST=ECXCOST*ECXCNT,ECVACL=$P(ECXPHA,U,2),ECORDST="" + ;if outpatient get division from iv rm; get dss identifier for clinic + I ECXA="O" D + .;- Only set ward to .5 if outpatient (but NOT observation patient) + .I $G(ECXW)="" S ECXW=.5 + .I $P(EC,U,15) S ECIVRM=$P(EC,U,15),ECXDIV=$$PSJ59P5^ECXUTL5(ECIVRM) + .S CLIN=+$P(EC,U,13),(ECXP1,ECXP2)="000",ECXCL=$G(^ECX(728.44,CLIN,0)) Q:ECXCL="" + .S ECSC=$P(ECXCL,U,4),ECCSC=$P(ECXCL,U,5) + .I ECSC="" S ECSC=$P(ECXCL,U,2),ECCSC=$P(ECXCL,U,3) + .I ECSC S ECXP1=$$RJ^XLFSTR(ECSC,3,0),ECXP2=$$RJ^XLFSTR(ECCSC,3,0) + .I ECSC="" S ECSC=$P($G(^SC(ECXCL,0)),U,7),ECCSC=$P($G(^SC(ECXCL,0)),U,18) I ECSC D + ..S ECXP1=$P($G(^DIC(40.7,ECSC,0)),U,2) S:ECCSC]"" ECXP2=$P($G(^DIC(40.7,ECCSC,0)),U,2) + ..S ECXP1=$$RJ^XLFSTR(ECXP1,3,0),ECXP2=$$RJ^XLFSTR(ECXP2,3,0) + .S ECXDSSI=ECXP1_ECXP2 + .I ECXLOGIC>2003 D + ..I "^18^23^24^36^41^65^94^"[("^"_ECXTS_"^") S ECXDSSI=$$TSMAP^ECXUTL4(ECXTS) + S ECINV=$P(ECXPHA,U,4),ECINV=$S(ECINV["I":"I",1:""),ECST=ECXCNT*ECST_" "_$P(ECST,U,2) + S ECNDC=$P(ECXPHA,U,3),ECNFC=$$RJ^XLFSTR($P(ECNDC,"-"),6,0)_$$RJ^XLFSTR($P(ECNDC,"-",2),4,0)_$$RJ^XLFSTR($P(ECNDC,"-",3),2,0),ECNFC=$TR(ECNFC,"*",0) + S P1=$P(ECXPHA,U,5),P3=$P(ECXPHA,U,6) + S X="PSNAPIS" X ^%ZOSF("TEST") I $T S ECNFC=$$DSS^PSNAPIS(P1,P3,ECXYM)_ECNFC + I $L(ECNFC)=12 S ECNFC=$$RJ^XLFSTR(P1,4,0)_$$RJ^XLFSTR(P3,3,0)_ECNFC + ;- Ordering provider ("2"_provider) + S ECXORDPR=$S(+$P(EC,U,10):"2"_$P(EC,U,10),1:""),ECXOPNPI="" + S ECXORDDT=$P(EC,U,16) ;- Ordering date + ;- Requesting physician (null for FY2002) + S ECXRPHY="" + ;- Department and National Prod Division + S ECXDSSD="" ;dss department use postponed $$IVP^ECXDEPT(ECXDIV) + N ECXPDIV S ECXPDIV=$$GETDIV^ECXDEPT(ECXDIV) + ;- Observation patient indicator (yes/no) + S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXDSSI) + ; - Ordering Date, Ordering Stop Code + S ECXORDST="" I ECXA="O" D + .S ECXORDST=$$DOIVPO^ECXUTL5(DFN,ON) + .I ECXOBS="NO" S ECORDST="160" + .I ECXOBS="YES" S ECORDST=$P($G(^ECX(727.831,+ECXTS,0)),U,6) + ;- If no encounter number don't file record + S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADM,ECD,ECXTS,ECXOBS,ECHEAD,ECORDST,) + ;get BCMA data + S (ECXBCDD,ECXBCDG,ECXBCUA,ECXBCIF)="" + ;get ordering provider person class + S ECXOPPC=$$PRVCLASS^ECXUTL($E(ECXORDPR,2,999),ECXORDDT) + ;set national patient record flag if exist + S ECXDFN=DFN D NPRF^ECXUTL5 K ECXDFN + D:ECXENC'="" FILE K P1,P3 + Q +PAT(ECXDFN,ECXDATE,ECXERR) ;get patient demographics, primary care, and inpatient data + N X + S (ECXCAT,ECXSTAT,ECXPRIOR,ECXSBGRP)="" + ;get patient data if saved + I $D(^TMP($J,"ECXP",ECXDFN)) D + .S PT=^TMP($J,"ECXP",ECXDFN),ECXPNM=$P(PT,U),ECXSSN=$P(PT,U,2),ECXMPI=$P(PT,U,3) + .S ECXDOB=$P(PT,U,4),ECXELIG=$P(PT,U,5),ECXSEX=$P(PT,U,6),ECXSTATE=$P(PT,U,7),ECXCNTY=$P(PT,U,8),ECXZIP=$P(PT,U,9) + .S ECXVET=$P(PT,U,10),ECXPOS=$P(PT,U,11),ECXPST=$P(PT,U,12),ECXPLOC=$P(PT,U,13),ECXRST=$P(PT,U,14),ECXAST=$P(PT,U,15) + .S ECXAOL=$P(PT,U,16),ECXPHI=$P(PT,U,17),ECXMST=$P(PT,U,18),ECXENRL=$P(PT,U,19),ECXCNHU=$P(PT,U,20),ECXCAT=$P(PT,U,21) + .S ECXSTAT=$P(PT,U,22),ECXPRIOR=$P(PT,U,23),ECXHNCI=$P(PT,U,24),ECXETH=$P(PT,U,25),ECXRC1=$P(PT,U,26),ECXMTST=$P(PT,U,27) + .S PT1=$G(^TMP($J,"ECXP",ECXDFN,1)),ECXERI=$P(PT1,U),ECXEST=$P(PT1,U,2) + .I $$ENROLLM^ECXUTL2(ECXDFN) + ;set patient data + I '$D(^TMP($J,"ECXP",ECXDFN)) D Q:'OK + .K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECXDATE,"."),"1;2;3;5",.ECXPAT) + .I 'OK K ECXPAT S ECXERR=1 Q + .S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI"),ECXDOB=ECXPAT("DOB"),ECXELIG=ECXPAT("ELIG"),ECXSEX=ECXPAT("SEX") + .S ECXSTATE=ECXPAT("STATE"),ECXCNTY=ECXPAT("COUNTY"),ECXZIP=ECXPAT("ZIP"),ECXVET=ECXPAT("VET") + .S ECXPOS=ECXPAT("POS"),ECXPST=ECXPAT("POW STAT"),ECXPLOC=ECXPAT("POW LOC"),ECXRST=ECXPAT("IR STAT") + .S ECXAST=ECXPAT("AO STAT"),ECXAOL=ECXPAT("AOL"),ECXPHI=ECXPAT("PHI"),ECXMST=ECXPAT("MST STAT") + .S ECXENRL=ECXPAT("ENROLL LOC"),ECXMTST=ECXPAT("MEANS"),ECXEST=ECXPAT("EC STAT") + .S ECXCNHU=$$CNHSTAT^ECXUTL4(ECXDFN) ;get CNHU status + .;get enrollment data (category, status and priority) + .I $$ENROLLM^ECXUTL2(ECXDFN) + .S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) ;Head and Neck Cancer Indicator + .; - Race and Ethnicity + .S ECXETH=ECXPAT("ETHNIC"),ECXRC1=ECXPAT("RACE1") + .S ECXERI=ECXPAT("ERI") ;emergency response indicator (FEMA) + .;save for later + .S ^TMP($J,"ECXP",ECXDFN)=ECXPNM_U_ECXSSN_U_ECXMPI_U_ECXDOB_U_ECXELIG_U_ECXSEX_U_ECXSTATE_U_ECXCNTY_U_ECXZIP_U_ECXVET_U_ECXPOS_U_ECXPST_U_ECXPLOC_U_ECXRST_U_ECXAST + .S ^TMP($J,"ECXP",ECXDFN)=^TMP($J,"ECXP",ECXDFN)_U_ECXAOL_U_ECXPHI_U_ECXMST_U_ECXENRL_U_ECXCNHU_U_ECXCAT_U_ECXSTAT_U_ECXPRIOR_U_ECXHNCI_U_ECXETH_U_ECXRC1_U_ECXMTST + .S ^TMP($J,"ECXP",ECXDFN,1)=ECXERI_U_ECXEST + ;get primary care data + S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXDATE,".")) + S ECPTTM=$P(X,U,1),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4),ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7) + ;get inpatient data + S (ECXA,ECXMN,ECXADM,ECXTS,ECXW,ECXDIV)="",X=$$INP^ECXUTL2(ECXDFN,ECXDATE) + S ECXA=$P(X,U),ECXMN=$P(X,U,2),ECXTS=$P(X,U,3),ECXADM=$P(X,U,4),W=$P(X,U,9),ECXDOM=$P(X,U,10),ECXW=$P(W,";"),ECXDIV=$P(W,";",2) + Q +FILE ;file record + ;node0 + ;fac^dfn^ssn^name^i/o^day^va class^qty^ward^cost^movement #^treat spec^ndc^investigational^iv dispensing fee^new feeder key^total doses^ + ;primary care team^primary care provider^ivp time^adm date^adm time^dss identifier + ;node1 + ;mpi^dss dept^pc provider npi^pc prov person class^assoc pc provider^assoc pc prov person class^assoc pc prov npi^dom^obs pat ind^enc num^ + ;ord pr^ordering stop code^ord dt^req phys^nat prod division^means tst^elig^dob^sex^state^county^zip+4^vet^period of svc^pow stat^pow loc^ir stat^ao stat^ + ;ao loc^purple heart ind.^mst stat^enrollment loc^enrollment cat^enrollment stat^enrollment prior^cnh/sh stat^ord pr npi + ;node2 + ;head & neck cancer ind.^ethnicity^race1^bcma drug dispensed^bcma dose given^bcma unit of administration^bcma ICU flag^ + ;ordering provider person class^^user enrollee ECXUESTA^patient type ECXPTYPE^combat vet elig ECXCVE^ + ;combat vet elig end date ECXCVEDT^enc cv eligible ECXCVENC^national patient record flag ECXNPRFI^emerg resp indic(FEMA) ECXERI^ + ;environ contamin ECXEST + N DA,DIK + S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 + S ECODE=EC7_U_EC23_U_ECXDIV_U_DFN_U_ECXSSN_U_ECXPNM_U_ECXA_U + S ECODE=ECODE_$$ECXDATE^ECXUTL(ECD,ECXYM)_U_ECVACL_U_ECXCNT_U_ECXW_U + ;convert specialty to PTF Code for transmission + N ECXDATA + S ECXDATA=$$TSDATA^DGACT(42.4,+ECXTS,.ECXDATA) + S ECXTS=$G(ECXDATA(7)) + ;done + S ECODE=ECODE_ECXCOST_U_ECXMN_U_ECXTS_U_ECNDC_U_ECINV_U_ECTYP_U_ECNFC_U + S ECODE=ECODE_ECST_U_ECPTTM_U_ECPTPR_U_ECDTTM_U_$$ECXDATE^ECXUTL(ECXADM,ECXYM)_U_$$ECXTIME^ECXUTL(ECXADM)_U_ECXDSSI_U + ;if outpat and not observ patient, admit date="" and admit time="000000" + I ECXA="O",(ECXOBS="NO") S $P(ECODE,U,24)="",$P(ECODE,U,25)="000000" + S ECODE1=ECXMPI_U_ECXDSSD_U_ECPTNPI_U_ECCLAS_U_ECASPR_U_ECCLAS2_U_ECASNPI_U_ECXDOM_U_ECXOBS_U_ECXENC_U_ECXORDPR_U + S ECODE1=ECODE1_ECXORDST_U_$$ECXDATE^ECXUTL(ECXORDDT,ECXYM)_U_ECXRPHY_U_ECXPDIV_U_ECXMTST_U_ECXELIG_U_ECXDOB_U + S ECODE1=ECODE1_ECXSEX_U_ECXSTATE_U_ECXCNTY_U_ECXZIP_U_ECXVET_U_ECXPOS_U_ECXPST_U_ECXPLOC_U_ECXRST_U_ECXAST_U + S ECODE1=ECODE1_ECXAOL_U_ECXPHI_U_ECXMST_U_ECXENRL_U_ECXCAT_U + S ECODE1=ECODE1_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXCNHU_U_ECXOPNPI_U + S ECODE2=ECXHNCI_U_ECXETH_U_ECXRC1 + I ECXLOGIC>2003 D + .S ECODE2=ECODE2_U_ECXBCDD_U_ECXBCDG_U_ECXBCUA_U_ECXBCIF_U_ECXOPPC + I ECXLOGIC>2004 S ECODE2=ECODE2_U_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI + I ECXLOGIC>2006 S ECODE2=ECODE2_U_ECXERI_U_ECXEST + S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1 + S ^ECX(ECFILE,EC7,2)=ECODE2,ECRN=ECRN+1 + S DA=EC7,DIK="^ECX("_ECFILE_"," D IX^DIK K DIK,DA + I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 + Q +SETUP ;Set required input for ECXTRAC + S ECHEAD="IVP" + D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) + ;variables ecver and ecrtn will be reset in routine ecxtrac if appropriate + S ECVER=7 + Q +QUE ; entry point for the background requeuing handled by ECXTAUTO + D SETUP,QUE^ECXTAUTO,^ECXKILL Q diff --git a/r/DSS_EXTRACTS-ECX/ECXPLBB.m b/r/DSS_EXTRACTS-ECX/ECXPLBB.m index 9f24d40d..48b7e7d5 100644 --- a/r/DSS_EXTRACTS-ECX/ECXPLBB.m +++ b/r/DSS_EXTRACTS-ECX/ECXPLBB.m @@ -1,98 +1,98 @@ -ECXPLBB ;DALOI/KML - DSS BLOOD BANK PRE-EXTRACT AUDIT REPORT ; 8/13/07 7:08am - ;;3.0;DSS EXTRACTS;**78,92,105**;Dec 22, 1997;Build 70 - ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021 - ;entry point from option - D SETUP^ECXLBB I ECFILE="" Q - N ECXINST - D DATES - Q:ECED']""&(ECSD']"") - N ECXPOP S ECXPOP=0 D QUE Q:ECXPOP - ; -START ; entry point from tasked job - ; get LAB DATA and build temporary global ^TMP("ECXLBB",$J) - N ECTRSP,ECADMT,ECTODT,ECXRPT,ECOUT,ECXSTR,ECRDT,ECLINE,ECPG,ECQUIT - N ECD,ECXDFN,ECARRY,EC66,ECERR,ECTRFDT,ECTRFTM,ECX,ECINOUT,ECXJOB - N ECXLOGIC - S ECXJOB=$J - K ^TMP("ECXLBB",ECXJOB) - U IO - I $E(IOST,1,2)="C-" W !,"Retrieving records... " - S ECXRPT=1 D AUDRPT^ECXLBB -OUTPUT ; entry point called by EN tag - I '$D(^TMP("ECXLBB",ECXJOB)) W !,"There were no records that met the date range criteria" Q - S (ECPG,ECDATE,ECQUIT,ECXDFN)=0,ECLINE="",$P(ECLINE,"=",80)="=" - S ECSDN=$$FMTE^XLFDT(ECSD,9),ECEDN=$$FMTE^XLFDT(ECED,9),ECRDT=$$FMTE^XLFDT(DT,9) - W:$E(IOST,1,2)="C-" @IOF D HED - F S ECXDFN=$O(^TMP("ECXLBB",ECXJOB,ECXDFN)) Q:'ECXDFN F S ECDATE=$O(^TMP("ECXLBB",ECXJOB,ECXDFN,ECDATE)) Q:'ECDATE Q:ECQUIT S ECXSTR=^(ECDATE) D PRINT - D ^ECXKILL - Q - ; -PRINT ; - I $Y+5>IOSL D Q:ECQUIT - . I $E(IOST,1,2)["C-" S DIR(0)="E" D ^DIR K DIR I 'Y S ECQUIT=1 Q - . W @IOF D HED - W !,$P(ECXSTR,"^",5),?11,$P(ECXSTR,"^",4),?26,$P(ECXSTR,"^",16) - W ?37,$$FMTE^XLFDT($$HL7TFM^XLFDT($P(ECXSTR,"^",8)),2) - W ?49,$P(ECXSTR,"^",11),?60,$J(+$P(ECXSTR,"^",12),2) - Q - ; -HED ; - S ECPG=ECPG+1 - W !,"LBB Extract Audit Report",?72,"Page",$J(ECPG,3) - W !,ECSDN," - ",ECEDN,?58,"Run Date:",$J(ECRDT,12) - W !,?37,"Transf",?57,"Number" - W !,"Name",?14,"SSN",?25,"FDR LOC",?37,"Date",?49,"COMP" - W ?57,"of Units" - W !,ECLINE - Q -DATES ; - N OUT,CHKFLG - I '$D(ECNODE) S ECNODE=7 - I '$D(ECHEAD) S ECHEAD=" " - W @IOF,!,"LBB Extract Audit Report Information for DSS",!! - S:'$D(ECINST) ECINST=+$P(^ECX(728,1,0),U) - S ECXINST=ECINST - K ECXDIC S DA=ECINST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" - D EN^DIQ1 S ECINST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC - S ECLDT=$S($D(^ECX(728,1,ECNODE)):$P(^(ECNODE),U,ECPIECE),1:2610624) - S:ECLDT="" ECLDT=2610624 - S ECOUT=0 F S (ECED,ECSD)="" D Q:ECOUT - . K %DT S %DT="AEX",%DT("A")="Starting with Date: " D ^%DT - . I Y<0 S ECOUT=1 Q - . S ECSD=Y - . K %DT S %DT="AEX",%DT("A")="Ending with Date: " D ^%DT - . I Y<0 S ECOUT=1 Q - . I YIOSL D Q:ECQUIT + . I $E(IOST,1,2)["C-" S DIR(0)="E" D ^DIR K DIR I 'Y S ECQUIT=1 Q + . W @IOF D HED + W !,$P(ECXSTR,"^",5),?11,$P(ECXSTR,"^",4),?26,$P(ECXSTR,"^",16) + W ?37,$$FMTE^XLFDT($$HL7TFM^XLFDT($P(ECXSTR,"^",8)),2) + W ?49,$P(ECXSTR,"^",11),?60,$J(+$P(ECXSTR,"^",12),2) + Q + ; +HED ; + S ECPG=ECPG+1 + W !,"LBB Pre-Extract Audit Report",?72,"Page",$J(ECPG,3) + W !,ECSDN," - ",ECEDN,?58,"Run Date:",$J(ECRDT,12) + W !,?37,"Transf",?57,"Number" + W !,"Name",?14,"SSN",?25,"FDR LOC",?37,"Date",?49,"COMP" + W ?57,"of Units" + W !,ECLINE + Q +DATES ; + N OUT,CHKFLG + I '$D(ECNODE) S ECNODE=7 + I '$D(ECHEAD) S ECHEAD=" " + W @IOF,!,"LBB Pre-Extract Audit Report Information for DSS",!! + S:'$D(ECINST) ECINST=+$P(^ECX(728,1,0),U) + S ECXINST=ECINST + K ECXDIC S DA=ECINST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" + D EN^DIQ1 S ECINST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC + S ECLDT=$S($D(^ECX(728,1,ECNODE)):$P(^(ECNODE),U,ECPIECE),1:2610624) + S:ECLDT="" ECLDT=2610624 + S ECOUT=0 F S (ECED,ECSD)="" D Q:ECOUT + . K %DT S %DT="AEX",%DT("A")="Starting with Date: " D ^%DT + . I Y<0 S ECOUT=1 Q + . S ECSD=Y + . K %DT S %DT="AEX",%DT("A")="Ending with Date: " D ^%DT + . I Y<0 S ECOUT=1 Q + . I Y0 ^ECXTRAC D ^ECXKILL - Q - ; -START ;start package specific extract - ; - ; Input - ; ECSD1 - FM formatted Beginning Date (Set by ECXTRAC) - ; ECED - FM formatted End Date (Set by ECXTRAC) - ; ECSDN - Externally formatted Start Date (Set by ECXTRAC) - ; ECEDN - Externally formatted End Date (Set by ECXTRAC) - ; EC - IEN from file #727 (Set by ECXTRAC) - ; ECXYM - Year and Month of extract (YYYYMM) - ; ECXINST - IEN for division in file #4 - ; ECINST - Station number of selected division - ; - N ECXLNE,ECXCT,ECXDACT,ECX0,ECXLB,ECXED1,ECINSTSV,ECXLNSTR,ECXP - N DIC,DR,DA,DIQ,CPTCODE,ECXNPRFI - D ECXBUL^ECXPRO2(.ECXLNE,ECSDN,ECEDN,EC) - S QFLG=0,ECXLNSTR=ECXLNE,ECXED1=ECED+.9999,ECXCT=ECSD1 - F S ECXCT=$O(^RMPR(660,"CT",ECXCT)) Q:(ECXCT>ECXED1)!('ECXCT)!(QFLG=1) D - .S ECXDACT=0 - .F S ECXDACT=$O(^RMPR(660,"CT",ECXCT,ECXDACT)) Q:('ECXDACT)!(QFLG=1) D - ..;* initialize variables - ..S (ECXDFN,ECXPNM,ECXSSN,ECXSEX,ECXSTAT,ECXDATE,ECXTYPE,ECXSRCE)="" - ..S (ECXHCPCS,ECXPHCPC,ECXRQST,ECXRCST,ECXFORM,ECXCTAMT,ECXLLC)="" - ..S (ECXLMC,ECXGRPR,ECXBILST,ECXQTY,ECXFELOC,ECXFEKEY,ECXA)="" - ..S (ECPTTM,ECPTPR,ECXAST,ECXRST,ECXEST,ECXELIG,ECXVET,ECXZIP)="" - ..S (ECXDOB,ECXDSSD,ECXICD9,ECXAOL,ECXHNCI,ECXETH,ECXRC1,ECXMST)="" - ..F I=1:1:4 S @("ECXICD9"_I)="" - ..Q:'$D(^RMPR(660,ECXDACT,0)) - ..S ECX0=^RMPR(660,ECXDACT,0),ECXLB=$G(^RMPR(660,ECXDACT,"LB")) - ..K ECXP S DIC="^RMPR(660,",DR=".02;11",DA=ECXDACT,DIQ(0)="EI" - ..S DIQ="ECXP" D EN^DIQ1 - ..S ECXDIV=$$GET1^DIQ(660,ECXDACT,8,"I") - ..S ECXDFN=$G(ECXP(660,ECXDACT,.02,"I")) - ..S ECXFORM=$G(ECXP(660,ECXDACT,11,"E"))_U_$G(ECXP(660,ECXDACT,11,"I")) - ..Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXCT) - ..S OK=$$PAT^ECXUTL3(ECXDFN,ECXDATE,"1;5",.ECXPAT) - ..I 'OK S ECXERR=1 K ECXPAT Q - ..;OEF/OIF data - ..S ECXOEF=ECXPAT("ECXOEF") - ..S ECXOEFDT=ECXPAT("ECXOEFDT") - ..Q:'$$NTEG^ECXPRO1(ECXDFN,.ECXLNE,ECXDACT,ECX0,ECXLB,ECINST,ECXFORM) - ..D PROSINFO^ECXPRO1(ECXDACT,ECXLB,ECX0,ECXFORM) - ..S CPTCODE=$E(ECXHCPCS,1,5) - ..;nppd entry date - ..S ECXNPPDT=$$ECXDATE^ECXUTL($P(ECX0,U,1),ECXYM) - ..; - ..;Get production division ;p-46 - ..N ECXPDIV S ECXPDIV=$$RADDIV^ECXDEPT(ECXDIV) ;p-46 - ..;- Observation patient indicator (YES/NO) - ..S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) - ..; - ..;- CNH status (YES/NO) - ..S ECXCNH=$$CNHSTAT^ECXUTL4(ECXDFN) - ..; - ..;get encounter classifications - ..S (ECXAO,ECXECE,ECXHNC,ECXMIL,ECXIR)="" - ..S ECXVISIT=$$GET1^DIQ(660,ECXDACT,8.12,"I") I ECXVISIT'="" D - ...D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) I ECXERR K ECXERR Q - ...S ECXAO=$G(ECXVIST("AO")),ECXECE=$G(ECXVIST("PGE")) - ...S ECXHNC=$G(ECXVIST("HNC")),ECXMIL=$G(ECXVIST("MST")),ECXIR=$G(ECXVIST("IR")) - ..; - Head and Neck Cancer Indicator - ..S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) - ..; - ..; - set national patient record flag if exist - ..D NPRF^ECXUTL5 - ..; - ..;- If no encounter number don't file record - ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,,) Q:ECXENC="" - ..I ECXFORM["-3" F ECXLAB="LAB","ORD" D - ...D FEEDINFO^ECXPRO2(ECXSRCE,CPTCODE,ECXTYPE,ECXSTAT2,ECXRQST,ECXRCST,ECXLAB) - ...Q:ECXFELOC="" D FILE - ..I ECXFORM'["-3" S ECXLAB="NONL" D - ...D FEEDINFO^ECXPRO2(ECXSRCE,CPTCODE,ECXTYPE,ECXSTAT2,ECXRQST,ECXRCST,ECXLAB) - ...Q:ECXFELOC="" D FILE - ;* Send the Exception message - I ECXLNSTR2004 S ECODE1=ECODE1_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI - I ECXLOGIC>2006 S ECODE1=ECODE1_U_ECXERI_U_ECXAO_U_ECXECE_U_ECXHNC_U_ECXMIL_U_ECXIR_U - I ECXLOGIC>2007 S ECODE2=ECXOEF_U_ECXOEFDT_U_ECXNPPDC_U_ECXNPPDT_U_ECASNPI_U_ECPTNPI - S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,^ECX(ECFILE,EC7,2)=$G(ECODE2),ECRN=ECRN+1 - S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA - I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 - Q -SETUP ;Set required input for ECXTRAC - S ECHEAD="PRO" - D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) - S ECINST=$$PDIV^ECXPUTL - Q - ; - ;**Note: LOCAL and QUE are carry over from protocols set by other - ; routines. -LOCAL ;to extract nightly for local use not to be transmitted to TSI - ;QUEUE with 1D frequency - D SETUP,^ECXTLOCL,^ECXKILL Q - ; -QUE ; entry point for the background requeuing handled by ECXTAUTO - D SETUP,QUE^ECXTAUTO,^ECXKILL Q +ECXPRO ;ALB/GTS - Prosthetics Extract for DSS ; 11/2/06 8:56am + ;;3.0;DSS EXTRACTS;**9,13,15,21,24,33,39,46,71,92**;Dec 22, 1997;Build 30 +BEG ;entry point from option + D SETUP I ECFILE="" Q + D:+ECINST>0 ^ECXTRAC D ^ECXKILL + Q + ; +START ;start package specific extract + ; + ; Input + ; ECSD1 - FM formatted Beginning Date (Set by ECXTRAC) + ; ECED - FM formatted End Date (Set by ECXTRAC) + ; ECSDN - Externally formatted Start Date (Set by ECXTRAC) + ; ECEDN - Externally formatted End Date (Set by ECXTRAC) + ; EC - IEN from file #727 (Set by ECXTRAC) + ; ECXYM - Year and Month of extract (YYYYMM) + ; ECXINST - IEN for division in file #4 + ; ECINST - Station number of selected division + ; + N ECXLNE,ECXCT,ECXDACT,ECX0,ECXLB,ECXED1,ECINSTSV,ECXLNSTR,ECXP + N DIC,DR,DA,DIQ,CPTCODE,ECXNPRFI + D ECXBUL^ECXPRO2(.ECXLNE,ECSDN,ECEDN,EC) + S QFLG=0,ECXLNSTR=ECXLNE,ECXED1=ECED+.9999,ECXCT=ECSD1 + F S ECXCT=$O(^RMPR(660,"CT",ECXCT)) Q:(ECXCT>ECXED1)!('ECXCT)!(QFLG=1) D + .S ECXDACT=0 + .F S ECXDACT=$O(^RMPR(660,"CT",ECXCT,ECXDACT)) Q:('ECXDACT)!(QFLG=1) D + ..;* initialize variables + ..S (ECXDFN,ECXPNM,ECXSSN,ECXSEX,ECXSTAT,ECXDATE,ECXTYPE,ECXSRCE)="" + ..S (ECXHCPCS,ECXPHCPC,ECXRQST,ECXRCST,ECXFORM,ECXCTAMT,ECXLLC)="" + ..S (ECXLMC,ECXGRPR,ECXBILST,ECXQTY,ECXFELOC,ECXFEKEY,ECXA)="" + ..S (ECPTTM,ECPTPR,ECXAST,ECXRST,ECXEST,ECXELIG,ECXVET,ECXZIP)="" + ..S (ECXDOB,ECXDSSD,ECXICD9,ECXAOL,ECXHNCI,ECXETH,ECXRC1,ECXMST)="" + ..F I=1:1:4 S @("ECXICD9"_I)="" + ..Q:'$D(^RMPR(660,ECXDACT,0)) + ..S ECX0=^RMPR(660,ECXDACT,0),ECXLB=$G(^RMPR(660,ECXDACT,"LB")) + ..K ECXP S DIC="^RMPR(660,",DR=".02;11",DA=ECXDACT,DIQ(0)="EI" + ..S DIQ="ECXP" D EN^DIQ1 + ..S ECXDIV=$$GET1^DIQ(660,ECXDACT,8,"I") + ..S ECXDFN=$G(ECXP(660,ECXDACT,.02,"I")) + ..S ECXFORM=$G(ECXP(660,ECXDACT,11,"E"))_U_$G(ECXP(660,ECXDACT,11,"I")) + ..Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXCT) + ..Q:'$$NTEG^ECXPRO1(ECXDFN,.ECXLNE,ECXDACT,ECX0,ECXLB,ECINST,ECXFORM) + ..D PROSINFO^ECXPRO1(ECXDACT,ECXLB,ECX0,ECXFORM) + ..S CPTCODE=$E(ECXHCPCS,1,5) + ..; + ..;Get production division ;p-46 + ..N ECXPDIV S ECXPDIV=$$RADDIV^ECXDEPT(ECXDIV) ;p-46 + ..;- Observation patient indicator (YES/NO) + ..S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) + ..; + ..;- CNH status (YES/NO) + ..S ECXCNH=$$CNHSTAT^ECXUTL4(ECXDFN) + ..; + ..;get encounter classifications + ..S (ECXAO,ECXECE,ECXHNC,ECXMIL,ECXIR)="" + ..S ECXVISIT=$$GET1^DIQ(660,ECXDACT,8.12,"I") I ECXVISIT'="" D + ...D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) I ECXERR K ECXERR Q + ...S ECXAO=$G(ECXVIST("AO")),ECXECE=$G(ECXVIST("PGE")) + ...S ECXHNC=$G(ECXVIST("HNC")),ECXMIL=$G(ECXVIST("MST")),ECXIR=$G(ECXVIST("IR")) + ..; - Head and Neck Cancer Indicator + ..S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) + ..; + ..; - set national patient record flag if exist + ..D NPRF^ECXUTL5 + ..; + ..;- If no encounter number don't file record + ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,,) Q:ECXENC="" + ..I ECXFORM["-3" F ECXLAB="LAB","ORD" D + ...D FEEDINFO^ECXPRO2(ECXSRCE,CPTCODE,ECXTYPE,ECXSTAT2,ECXRQST,ECXRCST,ECXLAB) + ...Q:ECXFELOC="" D FILE + ..I ECXFORM'["-3" S ECXLAB="NONL" D + ...D FEEDINFO^ECXPRO2(ECXSRCE,CPTCODE,ECXTYPE,ECXSTAT2,ECXRQST,ECXRCST,ECXLAB) + ...Q:ECXFELOC="" D FILE + ;* Send the Exception message + I ECXLNSTR2004 S ECODE1=ECODE1_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI + I ECXLOGIC>2006 S ECODE1=ECODE1_U_ECXERI_U_ECXAO_U_ECXECE_U_ECXHNC_U_ECXMIL_U_ECXIR + S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1 + S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA + I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 + Q +SETUP ;Set required input for ECXTRAC + S ECHEAD="PRO" + D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) + S ECINST=$$PDIV^ECXPUTL + Q + ; + ;**Note: LOCAL and QUE are carry over from protocols set by other + ; routines. +LOCAL ;to extract nightly for local use not to be transmitted to TSI + ;QUEUE with 1D frequency + D SETUP,^ECXTLOCL,^ECXKILL Q + ; +QUE ; entry point for the background requeuing handled by ECXTAUTO + D SETUP,QUE^ECXTAUTO,^ECXKILL Q diff --git a/r/DSS_EXTRACTS-ECX/ECXPRO1.m b/r/DSS_EXTRACTS-ECX/ECXPRO1.m index 2549c97a..7ba25f34 100644 --- a/r/DSS_EXTRACTS-ECX/ECXPRO1.m +++ b/r/DSS_EXTRACTS-ECX/ECXPRO1.m @@ -1,148 +1,145 @@ -ECXPRO1 ;ALB/GTS - Prosthetics Extract for DSS (Continued) ; 11/8/07 8:02am - ;;3.0;DSS EXTRACTS;**9,11,13,15,21,24,33,37,39,100,105**;Dec 22, 1997;Build 70 - ; -NTEG(ECXDFN,ECXLNE,ECXPIEN,ECXN0,ECXNLB,ECINST,ECXFORM) ;** Check for required fields - ; Input - ; ECXDFN - ien in file #2 - ; ECXLNE - line number variable (passed by reference) - ; ECXPIEN - IEN for the Prosthetics record - ; ECXN0 - zero node of the Prosthetics record - ; ECXNLB - LB node of the Prosthetics record - ; ECINST - station number being extracted - ; ECXFORM - Form Requested On - ; Output (to be KILLed by calling routine) - ; ^TMP("ECX-PRO EXC",$J) - Array for the exception message - ; ECXLNE - The number of the next line in the msg - ; ECXSTAT2 - Patient Station Number - ; ECXDATE - Delivery Date of Prosthesis - ; ECXTYPE - Type of Transaction work performed - ; ECXSRCE - Source of prosthesis - ; ECXHCPCS - CPT/HCPCS code for prosthesis - ; ECXRQST - Requesting Station - ; ECXRCST - Receiving Station - ; ECXPHCPC - PSAS HCPCS code; if 'unknown', then use CPT/HCPCS code - ; ECXNPPDC - NPPD code for repairs or new issues - ; Output (KILLed by NTEG) - ; ECXMISS - 1 indicates missing information - ; ECXGOOD - 0 indicates record should not be extracted - ; - N ECXGOOD,ECXMISS - S (ECXRCST,ECXRQST,ECXNPPDC)="",ECXGOOD=1,ECXSTAT2=$P(ECXN0,U,10) - I ECXSTAT2]"" D - .K ECXDIC - .S DA=ECXSTAT2,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" - .D EN^DIQ1 S ECXSTAT2=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC - .S:(ECINST'=$E(ECXSTAT2,1,3)) ECXGOOD=0 ;*Screen for incorrect Station - ; - ;** Screen out records - S:($P(ECXN0,U,17)'="") ECXGOOD=0 ;*SHIP/DEL is not NULL - S:($P(ECXN0,U,26)'="") ECXGOOD=0 ;*PICKUP/DEL is not NULL - S:(+($P($G(^RMPR(660,ECXPIEN,"AM")),U,2))=1) ECXGOOD=0 ;*NO ADMIN CT=1 - S:(($P(ECXN0,U,15))'="") ECXGOOD=0 ;*HISTORICAL DATA is not NULL - ; - S ECXDATE=$P(ECXN0,U,12),ECXTYPE=$P(ECXN0,U,4),ECXSRCE=$P(ECXN0,U,14) - S ECXHCPCS=$P($G(^ICPT(+$P(ECXN0,U,22),0)),U,1),ECXCMOD="" - S ECXHCPCS=$$CPT^ECXUTL3(ECXHCPCS,ECXCMOD) - ;get psas hcpcs code from file #661.1 - S ECXPHCPC=$P($G(^RMPR(660,ECXPIEN,1)),U,4) D - .;get nppd code for repairs and new issues 10 characters in length. - .I "X5"[ECXTYPE S ECXNPPDC=$TR($$GET1^DIQ(661.1,ECXPHCPC_",",5)," ","_") - .I "IR"[ECXTYPE S ECXNPPDC=$TR($$GET1^DIQ(661.1,ECXPHCPC_",",6)," ","_") - .I +ECXPHCPC S ECXPHCPC=$E($P($G(^RMPR(661.1,ECXPHCPC,0)),U,1),1,5) - .I ECXPHCPC="UNKNOWN" S ECXPHCPC=$E(ECXHCPCS,1,5) - ; - ;* Get Requesting Station Number - I ECXFORM["-3" D - .S ECXRQST=$P(ECXNLB,U,1) - .I ECXRQST]"" D - ..S DA=ECXRQST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" - ..D EN^DIQ1 S ECXRQST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC - S:(ECXFORM'["-3") ECXRQST="" - ; - ;* Screen out records - S:(+$P(ECXFORM,U,2)=13) ECXGOOD=0 ;*FORM REQUESTED ON = 13 - ; - ;* Get Receiving Station Number - I ECXFORM["-3" D - .S ECXRCST=$P(ECXNLB,U,4) - .I ECXRCST]"" D - ..S DA=ECXRCST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" - ..D EN^DIQ1 S ECXRCST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC - S:(ECXFORM'["-3") ECXRCST="" - ; - ;** Check for integrity and set up the problem variable if right DIV - I ECXGOOD D CHK - Q ECXGOOD - ; -CHK ;*Check variables - ; Input - ; Variables set in and Output from NTEG^ECXPRO1 - ; Output - ; ^TMP("ECX-PRO EXC",$J, - Global of records with integrity problems - ; - S ECXMISS="" - I ECXSTAT2']"" S ECXMISS=ECXMISS_"1" - S ECXMISS=ECXMISS_U - I ECXDFN=0 S ECXMISS=ECXMISS_"1" - S ECXMISS=ECXMISS_U - ;I ECXSSN']"" S ECXMISS=ECXMISS_"1" - S ECXMISS=ECXMISS_U - ;I ECXNA=" " S ECXMISS=ECXMISS_"1" - S ECXMISS=ECXMISS_U - I ECXDATE']"" S ECXMISS=ECXMISS_"1" - S ECXMISS=ECXMISS_U - I ECXTYPE']"" S ECXMISS=ECXMISS_"1" - S ECXMISS=ECXMISS_U - I ECXSRCE']"" S ECXMISS=ECXMISS_"1" - S ECXMISS=ECXMISS_U - I ECXHCPCS']"" S ECXMISS=ECXMISS_"1" - S ECXMISS=ECXMISS_U - I ECXFORM["-3" D - .I ECXRQST']"" S ECXMISS=ECXMISS_"1" - S ECXMISS=ECXMISS_U - I ECXFORM']"" S ECXMISS=ECXMISS_"1" - S ECXMISS=ECXMISS_U - I ECXFORM["-3" D - .I ECXRCST']"" S ECXMISS=ECXMISS_"1" - I ECXMISS'="^^^^^^^^^^" D - .S ECXGOOD=0 - .D ECXMISLN^ECXPRO2(ECXMISS,.ECXLNE,ECXPIEN) - Q - ; -PROSINFO(ECXDA,ECXLB,ECX0,ECXFORM) ;*Get Prosthetics Information - ; - ; Input - ; ECDA - The IEN for the Prosthetics record - ; ECX0 - The zero node of the Prosthetics record - ; ECXLB - The LB node of the Prosthetics record - ; ECXFORM - The Form Requested On (to determine Lab transactions) - ; - ; Output (to be KILLed by calling routine) - ; ECXCTAMT - The Cost of Transaction - ; ECXLLC - The Lab Labor Cost - ; ECXLMC - The Lab Material Cost - ; ECXGRPR - The AMIS Grouper number - ; ECXBILST - The Billing Status - ; ECXQTY - The Quantity - ; - S (ECXLLC,ECXLMC,ECXCTAMT)="",ECXBILST=$P($G(^RMPR(660,ECXDA,"AM")),U,3) - S ECXQTY=$P(ECX0,U,7) - S:(+ECXQTY=0) ECXQTY=1 - ; - ;- Set Quantity field to 8 chars (right-justified & padded w/zeros) - S ECXQTY=$$RJ^XLFSTR(ECXQTY,8,0) - S ECXGRPR=$P($G(^RMPR(660,ECXDA,"AMS")),U,1),ECXCTAMT=$P(ECX0,U,16) - I ECXFORM["-3" D - .S ECXCTAMT=$P(ECXLB,U,9),ECXLLC=$P(ECXLB,U,7),ECXLMC=$P(ECXLB,U,8) - ; - ;- If Stock Issue or Inventory Issue, Cost of Transaction=0 - I $P(ECXFORM,U,2)=11!($P(ECXFORM,U,2)=12) S ECXCTAMT=0 - S:ECXCTAMT="" ECXCTAMT=0 S:ECXCTAMT>999999 ECXCTAMT=999999 - S:ECXLLC="" ECXLLC=0 S:ECXLLC>999999 ECXLLC=999999 - S:ECXLMC="" ECXLMC=0 S:ECXLMC>999999 ECXLMC=999999 - ; - ;- Round to next dollar amount - I (ECXCTAMT#1)>.50 S ECXCTAMT=(ECXCTAMT+1)\1 - I (ECXLLC#1)>.50 S ECXLLC=(ECXLLC+1)\1 - I (ECXLMC#1)>.50 S ECXLMC=(ECXLMC+1)\1 - Q +ECXPRO1 ;ALB/GTS - Prosthetics Extract for DSS (Continued) ; DEC 15, 2006 + ;;3.0;DSS EXTRACTS;**9,11,13,15,21,24,33,37,39,100**;Dec 22, 1997;Build 2 + ; +NTEG(ECXDFN,ECXLNE,ECXPIEN,ECXN0,ECXNLB,ECINST,ECXFORM) ;** Check for required fields + ; Input + ; ECXDFN - ien in file #2 + ; ECXLNE - line number variable (passed by reference) + ; ECXPIEN - IEN for the Prosthetics record + ; ECXN0 - zero node of the Prosthetics record + ; ECXNLB - LB node of the Prosthetics record + ; ECINST - station number being extracted + ; ECXFORM - Form Requested On + ; Output (to be KILLed by calling routine) + ; ^TMP("ECX-PRO EXC",$J) - Array for the exception message + ; ECXLNE - The number of the next line in the msg + ; ECXSTAT2 - Patient Station Number + ; ECXDATE - Delivery Date of Prosthesis + ; ECXTYPE - Type of Transaction work performed + ; ECXSRCE - Source of prosthesis + ; ECXHCPCS - CPT/HCPCS code for prosthesis + ; ECXRQST - Requesting Station + ; ECXRCST - Receiving Station + ; ECXPHCPC - PSAS HCPCS code; if 'unknown', then use CPT/HCPCS code + ; Output (KILLed by NTEG) + ; ECXMISS - 1 indicates missing information + ; ECXGOOD - 0 indicates record should not be extracted + ; + N ECXGOOD,ECXMISS + S (ECXRCST,ECXRQST)="",ECXGOOD=1,ECXSTAT2=$P(ECXN0,U,10) + I ECXSTAT2]"" D + .K ECXDIC + .S DA=ECXSTAT2,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" + .D EN^DIQ1 S ECXSTAT2=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC + .S:(ECINST'=$E(ECXSTAT2,1,3)) ECXGOOD=0 ;*Screen for incorrect Station + ; + ;** Screen out records + S:($P(ECXN0,U,17)'="") ECXGOOD=0 ;*SHIP/DEL is not NULL + S:($P(ECXN0,U,26)'="") ECXGOOD=0 ;*PICKUP/DEL is not NULL + S:(+($P($G(^RMPR(660,ECXPIEN,"AM")),U,2))=1) ECXGOOD=0 ;*NO ADMIN CT=1 + S:(($P(ECXN0,U,15))'="") ECXGOOD=0 ;*HISTORICAL DATA is not NULL + ; + S ECXDATE=$P(ECXN0,U,12),ECXTYPE=$P(ECXN0,U,4),ECXSRCE=$P(ECXN0,U,14) + S ECXHCPCS=$P($G(^ICPT(+$P(ECXN0,U,22),0)),U,1),ECXCMOD="" + S ECXHCPCS=$$CPT^ECXUTL3(ECXHCPCS,ECXCMOD) + ;get psas hcpcs code from file #661.1 + S ECXPHCPC=$P($G(^RMPR(660,ECXPIEN,1)),U,4) D + .;I +ECXPHCPC S ECXPHCPC=$P($G(^RMPR(661.1,ECXPHCPC,0)),U,1) + .I +ECXPHCPC S ECXPHCPC=$E($P($G(^RMPR(661.1,ECXPHCPC,0)),U,1),1,5) + .I ECXPHCPC="UNKNOWN" S ECXPHCPC=$E(ECXHCPCS,1,5) + ; + ;* Get Requesting Station Number + I ECXFORM["-3" D + .S ECXRQST=$P(ECXNLB,U,1) + .I ECXRQST]"" D + ..S DA=ECXRQST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" + ..D EN^DIQ1 S ECXRQST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC + S:(ECXFORM'["-3") ECXRQST="" + ; + ;* Screen out records + S:(+$P(ECXFORM,U,2)=13) ECXGOOD=0 ;*FORM REQUESTED ON = 13 + ; + ;* Get Receiving Station Number + I ECXFORM["-3" D + .S ECXRCST=$P(ECXNLB,U,4) + .I ECXRCST]"" D + ..S DA=ECXRCST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" + ..D EN^DIQ1 S ECXRCST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC + S:(ECXFORM'["-3") ECXRCST="" + ; + ;** Check for integrity and set up the problem variable if right DIV + I ECXGOOD D CHK + Q ECXGOOD + ; +CHK ;*Check variables + ; Input + ; Variables set in and Output from NTEG^ECXPRO1 + ; Output + ; ^TMP("ECX-PRO EXC",$J, - Global of records with integrity problems + ; + S ECXMISS="" + I ECXSTAT2']"" S ECXMISS=ECXMISS_"1" + S ECXMISS=ECXMISS_U + I ECXDFN=0 S ECXMISS=ECXMISS_"1" + S ECXMISS=ECXMISS_U + ;I ECXSSN']"" S ECXMISS=ECXMISS_"1" + S ECXMISS=ECXMISS_U + ;I ECXNA=" " S ECXMISS=ECXMISS_"1" + S ECXMISS=ECXMISS_U + I ECXDATE']"" S ECXMISS=ECXMISS_"1" + S ECXMISS=ECXMISS_U + I ECXTYPE']"" S ECXMISS=ECXMISS_"1" + S ECXMISS=ECXMISS_U + I ECXSRCE']"" S ECXMISS=ECXMISS_"1" + S ECXMISS=ECXMISS_U + I ECXHCPCS']"" S ECXMISS=ECXMISS_"1" + S ECXMISS=ECXMISS_U + I ECXFORM["-3" D + .I ECXRQST']"" S ECXMISS=ECXMISS_"1" + S ECXMISS=ECXMISS_U + I ECXFORM']"" S ECXMISS=ECXMISS_"1" + S ECXMISS=ECXMISS_U + I ECXFORM["-3" D + .I ECXRCST']"" S ECXMISS=ECXMISS_"1" + I ECXMISS'="^^^^^^^^^^" D + .S ECXGOOD=0 + .D ECXMISLN^ECXPRO2(ECXMISS,.ECXLNE,ECXPIEN) + Q + ; +PROSINFO(ECXDA,ECXLB,ECX0,ECXFORM) ;*Get Prosthetics Information + ; + ; Input + ; ECDA - The IEN for the Prosthetics record + ; ECX0 - The zero node of the Prosthetics record + ; ECXLB - The LB node of the Prosthetics record + ; ECXFORM - The Form Requested On (to determine Lab transactions) + ; + ; Output (to be KILLed by calling routine) + ; ECXCTAMT - The Cost of Transaction + ; ECXLLC - The Lab Labor Cost + ; ECXLMC - The Lab Material Cost + ; ECXGRPR - The AMIS Grouper number + ; ECXBILST - The Billing Status + ; ECXQTY - The Quantity + ; + S (ECXLLC,ECXLMC,ECXCTAMT)="",ECXBILST=$P($G(^RMPR(660,ECXDA,"AM")),U,3) + S ECXQTY=$P(ECX0,U,7) + S:(+ECXQTY=0) ECXQTY=1 + ; + ;- Set Quantity field to 8 chars (right-justified & padded w/zeros) + S ECXQTY=$$RJ^XLFSTR(ECXQTY,8,0) + S ECXGRPR=$P($G(^RMPR(660,ECXDA,"AMS")),U,1),ECXCTAMT=$P(ECX0,U,16) + I ECXFORM["-3" D + .S ECXCTAMT=$P(ECXLB,U,9),ECXLLC=$P(ECXLB,U,7),ECXLMC=$P(ECXLB,U,8) + ; + ;- If Stock Issue or Inventory Issue, Cost of Transaction=0 + I $P(ECXFORM,U,2)=11!($P(ECXFORM,U,2)=12) S ECXCTAMT=0 + S:ECXCTAMT="" ECXCTAMT=0 S:ECXCTAMT>999999 ECXCTAMT=999999 + S:ECXLLC="" ECXLLC=0 S:ECXLLC>999999 ECXLLC=999999 + S:ECXLMC="" ECXLMC=0 S:ECXLMC>999999 ECXLMC=999999 + ; + ;- Round to next dollar amount + I (ECXCTAMT#1)>.50 S ECXCTAMT=(ECXCTAMT+1)\1 + I (ECXLLC#1)>.50 S ECXLLC=(ECXLLC+1)\1 + I (ECXLMC#1)>.50 S ECXLMC=(ECXLMC+1)\1 + Q diff --git a/r/DSS_EXTRACTS-ECX/ECXPURG.m b/r/DSS_EXTRACTS-ECX/ECXPURG.m index 1883e8b1..d388a594 100644 --- a/r/DSS_EXTRACTS-ECX/ECXPURG.m +++ b/r/DSS_EXTRACTS-ECX/ECXPURG.m @@ -1,78 +1,68 @@ -ECXPURG ;BIR/CML-Driver for Purge of DSS Data from Local Extract & Holding Files ; 4/17/07 2:35pm - ;;3.0;DSS EXTRACTS;**9,24,33,35,49,102**;Dec 22, 1997;Build 17 -EN ;entry point from option - W @IOF,!!,"This option will allow you to purge:" - W !,"1. individual or a range of DSS extracts, or" - W !,"2. data that resides in the ""holding files"" for the IVP and UDP extracts." - W !,"3. data that resides in the ""holding file"" for the VBECS extract" - W !!,"Care must be taken for several reasons:" - W !!,"- You can purge ANY existing extract. This includes transmitted and non-" - W !," transmitted extracts as well as extracts that did not run to completion" - W !," due to errors or system problems." - W !,"- Choosing a range of extracts (or a broad date range for the ""holding" - W !," files"") could mean an excessively large number of records and be very" - W !," CPU intensive. Please be sure to queue this purge for off-hours and" - W !," limit the number of extracts to be purged per a single queued session." - W !,"- The IVP, UDP and VBECS ""holding"" files are intermediate files that" - W !," are populated ""realtime"" by inpatient pharmacy and VBECS activity. These" - W !," files are then used to generate the IVP, UDP and VBECS extracts and CANNOT be" - W !," recreated. Once they are purged for a date range, extracts can no longer be" - W !," generated for that time period." - ; - K DIR W ! - S DIR(0)="SAM^E:Extract Files;I:IVP Holding File;U:UDP Holding File;V:VBECS Holding File" - S DIR("A")="Purge (E)xtract files, (I)VP data, (U)DP data or (V)BECS data? " - D ^DIR K DIR G:$D(DIRUT) QUIT S ECY=Y - I ECY="E" D ^ECXPURG1 I $D(ECLOC) S ZTSAVE("ECLOC(")="",ZTIO="",ZTRTN="PUR1^ECXPURG",ZTDESC="DSS - Purge of Extract Files" D QUE - I ECY="I" D DATES^ECXPURG1 I $D(ECBDT)&($D(ECEDT)) S (ZTSAVE("ECBDT"),ZTSAVE("ECEDT"))="",ZTIO="",ZTRTN="PUR2^ECXPURG",ZTDESC="DSS - Purge of IVP Holding File" D QUE - I ECY="U" D DATES^ECXPURG1 I $D(ECBDT)&($D(ECEDT)) S (ZTSAVE("ECBDT"),ZTSAVE("ECEDT"))="",ZTIO="",ZTRTN="PUR3^ECXPURG",ZTDESC="DSS - Purge of UDP Holding File" D QUE - I ECY="V" D DATES^ECXPURG1 I $D(ECBDT)&($D(ECEDT)) S (ZTSAVE("ECBDT"),ZTSAVE("ECEDT"))="",ZTIO="",ZTRTN="PUR4^ECXPURG",ZTDESC="DSS - Purge of VBECS Holding File" D QUE -QUIT ; - K %X,%Y,EC,ECBDT,ECDATE,ECDT,ECEDT,ECEX,ECFR,ECLOC,ECRC,ECTO,ECTRN,ECTYP,ECY,HDT,HI,JJ,LN,LO,PG,QFLG,SS,X,Y,ZTSK - K ECXDIV - S:$D(ZTQUEUED) ZTREQ="@" - Q -QUE W $C(7),$C(7),!!?3,"<>",! - D ^%ZTLOAD - I $D(ZTSK) W !,"Request queued as Task #",ZTSK,".",! - Q - ; -PUR1 ; entry point for queued purge job of extract files - S ECDA=0 F S ECDA=$O(ECLOC(ECDA)) Q:'ECDA D - .S ECFILE=^ECX(727,ECDA,"FILE"),ECJ=0 - .I ECFILE=727.827 D - ..S DA(1)=1 - ..S DA=$O(^ECX(728,DA(1),"CBOC","B",ECDA,0)) - ..S DIK="^ECX(728,"_DA(1)_","_"""CBOC"""_"," - ..I DA'="" D ^DIK K DIK,DA - .F S ECJ=$O(^ECX(ECFILE,"AC",ECDA,ECJ)) Q:'ECJ D - ..S DIK="^ECX("_ECFILE_",",DA=ECJ D ^DIK K DIK,DA - .I ECFILE=727.816 S ECFILE=727.818,ECJ=0 D - ..F S ECJ=$O(^ECX(ECFILE,"AC",ECDA,ECJ)) Q:'ECJ D - ...S DIK="^ECX("_ECFILE_",",DA=ECJ D ^DIK K DIK,DA - .S ^ECX(727,ECDA,"PURG")=DT - D QUIT - Q - ; -PUR2 ; entry point for queued purge job of IVP holding file (#728.113) - F ECDT=ECBDT-1:0 S ECDT=$O(^ECX(728.113,"A",ECDT)) Q:'ECDT Q:ECDT>ECEDT S ECPT=0 F S ECPT=$O(^ECX(728.113,"A",ECDT,ECPT)) Q:'ECPT D - .S ECOR=0 F S ECOR=$O(^ECX(728.113,"A",ECDT,ECPT,ECOR)) Q:'ECOR D - ..S ECREC=0 F S ECREC=$O(^ECX(728.113,"A",ECDT,ECPT,ECOR,ECREC)) Q:'ECREC D - ...S DIK="^ECX(728.113,",DA=ECREC D ^DIK K DIK,DA - D QUIT - Q - ; -PUR3 ; entry point for queued purge job of UDP holding file (#728.904) - F ECDT=ECBDT-1:0 S ECDT=$O(^ECX(728.904,"A",ECDT)) Q:'ECDT Q:ECDT>ECEDT D - .S ECREC=0 F S ECREC=$O(^ECX(728.904,"A",ECDT,ECREC)) Q:'ECREC D - ..S DIK="^ECX(728.904,",DA=ECREC D ^DIK K DIK,DA - D QUIT - Q - ; -PUR4 ; entry point for queued purge job of VBECS holding file (#6002.03) - N ECDT,ECREC,DIK,DA - S ECDT=ECBDT-1,ECEDT=ECEDT+.9 - F S ECDT=$O(^VBEC(6002.03,"C",ECDT)) Q:'ECDT!(ECDT>ECEDT) D - .S ECREC=0 F S ECREC=$O(^VBEC(6002.03,"C",ECDT,ECREC)) Q:'ECREC D - ..S DIK="^VBEC(6002.03,",DA=ECREC D ^DIK K DIK,DA - Q +ECXPURG ;BIR/CML-Driver for Purge of DSS Data from Local Extract & Holding Files ; [ 12/03/96 5:19 PM ] + ;;3.0;DSS EXTRACTS;**9,24,33,35,49**;Dec 22, 1997 +EN ;entry point from option + W @IOF,!!,"This option will allow you to purge:" + W !,"1. individual or a range of DSS extracts, or" + W !,"2. data that resides in the ""holding files"" for the IVP and UDP extracts." + W !!,"Care must be taken for several reasons:" + W !!,"- You can purge ANY existing extract. This includes transmitted and non-" + W !," transmitted extracts as well as extracts that did not run to completion" + W !," due to errors or system problems." + W !,"- Choosing a range of extracts (or a broad date range for the ""holding" + W !," files"") could mean an excessively large number of records and be very" + W !," CPU intensive. Please be sure to queue this purge for off-hours and" + W !," limit the number of extracts to be purged per a single queued session." + W !,"- The IVP and UDP ""holding"" files are intermediate files that are" + W !," populated ""realtime"" by inpatient pharmacy activity. These files are" + W !," then used to generate the IVP and UDP extracts and CANNOT be recreated." + W !," Once they are purged for a date range, extracts can no longer be" + W !," generated for that time period." + ; + K DIR W ! + S DIR(0)="SAM^E:Extract Files;I:IVP Holding File;U:UDP Holding File" + S DIR("A")="Purge (E)xtract files, (I)VP data, or (U)DP data? " + D ^DIR K DIR G:$D(DIRUT) QUIT S ECY=Y + I ECY="E" D ^ECXPURG1 I $D(ECLOC) S ZTSAVE("ECLOC(")="",ZTIO="",ZTRTN="PUR1^ECXPURG",ZTDESC="DSS - Purge of Extract Files" D QUE + I ECY="I" D DATES^ECXPURG1 I $D(ECBDT)&($D(ECEDT)) S (ZTSAVE("ECBDT"),ZTSAVE("ECEDT"))="",ZTIO="",ZTRTN="PUR2^ECXPURG",ZTDESC="DSS - Purge of IVP Holding File" D QUE + I ECY="U" D DATES^ECXPURG1 I $D(ECBDT)&($D(ECEDT)) S (ZTSAVE("ECBDT"),ZTSAVE("ECEDT"))="",ZTIO="",ZTRTN="PUR3^ECXPURG",ZTDESC="DSS - Purge of UDP Holding File" D QUE +QUIT ; + K %X,%Y,EC,ECBDT,ECDATE,ECDT,ECEDT,ECEX,ECFR,ECLOC,ECRC,ECTO,ECTRN,ECTYP,ECY,HDT,HI,JJ,LN,LO,PG,QFLG,SS,X,Y,ZTSK + K ECXDIV + S:$D(ZTQUEUED) ZTREQ="@" + Q +QUE W $C(7),$C(7),!!?3,"<>",! + D ^%ZTLOAD + I $D(ZTSK) W !,"Request queued as Task #",ZTSK,".",! + Q + ; +PUR1 ; entry point for queued purge job of extract files + S ECDA=0 F S ECDA=$O(ECLOC(ECDA)) Q:'ECDA D + .S ECFILE=^ECX(727,ECDA,"FILE"),ECJ=0 + .I ECFILE=727.827 D + ..S DA(1)=1 + ..S DA=$O(^ECX(728,DA(1),"CBOC","B",ECDA,0)) + ..S DIK="^ECX(728,"_DA(1)_","_"""CBOC"""_"," + ..I DA'="" D ^DIK K DIK,DA + .F S ECJ=$O(^ECX(ECFILE,"AC",ECDA,ECJ)) Q:'ECJ D + ..S DIK="^ECX("_ECFILE_",",DA=ECJ D ^DIK K DIK,DA + .I ECFILE=727.816 S ECFILE=727.818,ECJ=0 D + ..F S ECJ=$O(^ECX(ECFILE,"AC",ECDA,ECJ)) Q:'ECJ D + ...S DIK="^ECX("_ECFILE_",",DA=ECJ D ^DIK K DIK,DA + .S ^ECX(727,ECDA,"PURG")=DT + D QUIT + Q + ; +PUR2 ; entry point for queued purge job of IVP holding file (#728.113) + F ECDT=ECBDT-1:0 S ECDT=$O(^ECX(728.113,"A",ECDT)) Q:'ECDT Q:ECDT>ECEDT S ECPT=0 F S ECPT=$O(^ECX(728.113,"A",ECDT,ECPT)) Q:'ECPT D + .S ECOR=0 F S ECOR=$O(^ECX(728.113,"A",ECDT,ECPT,ECOR)) Q:'ECOR D + ..S ECREC=0 F S ECREC=$O(^ECX(728.113,"A",ECDT,ECPT,ECOR,ECREC)) Q:'ECREC D + ...S DIK="^ECX(728.113,",DA=ECREC D ^DIK K DIK,DA + D QUIT + Q + ; +PUR3 ; entry point for queued purge job of UDP holding file (#728.904) + F ECDT=ECBDT-1:0 S ECDT=$O(^ECX(728.904,"A",ECDT)) Q:'ECDT Q:ECDT>ECEDT D + .S ECREC=0 F S ECREC=$O(^ECX(728.904,"A",ECDT,ECREC)) Q:'ECREC D + ..S DIK="^ECX(728.904,",DA=ECREC D ^DIK K DIK,DA + D QUIT + Q diff --git a/r/DSS_EXTRACTS-ECX/ECXPURG1.m b/r/DSS_EXTRACTS-ECX/ECXPURG1.m index cd6790fd..fbeca78a 100644 --- a/r/DSS_EXTRACTS-ECX/ECXPURG1.m +++ b/r/DSS_EXTRACTS-ECX/ECXPURG1.m @@ -1,124 +1,121 @@ -ECXPURG1 ;BIR/CML-Purge of DSS Extract Files (CONTINUED) ; 5/27/08 9:26am - ;;3.0;DSS EXTRACTS;**2,9,8,24,49,102**;Dec 22, 1997;Build 17 -GET ;compile list of purgable extracts - K HI,LO,ECBDT,ECEDT,ECLOC,^TMP("ECXPURG",$J) - S QFLG=1 W !!,"...one moment please" - S ECEX=0 F S ECEX=$O(^ECX(727,ECEX)) Q:'ECEX I '$G(^ECX(727,ECEX,"PURG")),$D(^ECX(727,ECEX,0)) S EC=^(0) D - .S ^TMP("ECXPURG",$J,$P(EC,U,3),ECEX)="",ECLOC(ECEX)=$P(EC,U,3)_U_$P(EC,U,4,5) - I '$D(^TMP("ECXPURG",$J)) W !!,"There are no extracts that can be purged at this time." G DONE -ASK1 ;ask for print - W ! - K DIR S DIR(0)="Y",DIR("A")="Do you want to print a list of extracts that can be purged",DIR("B")="NO" - D ^DIR K DIR I $D(DIRUT) K ECLOC G DONE - G:'Y ASK2 - W !!,"The right margin for this report is 80.",!! - K ZTSAVE S ZTSAVE("^TMP(""ECXPURG"",$J,")="" - D EN^XUTMDEVQ("PRT^ECXPURG1","DSS - Print Purgable Extracts",.ZTSAVE) I 'POP G ASK2 - W !,"NO DEVICE SELECTED OR REPORT PRINTED!!" -ASK2 ;ask for extract range - ; - ;** Check divisions for purging - N ECCHK,ECTMP - S ECCHK=$$DIV4^XUSER(.ECTMP,DUZ) - I 'ECCHK DO - .W !,"You do not have any divisions defined in your user set up and can not purge." - .S DIR(0)="FAO^1:1",DIR("A")="Hit Return to continue." D ^DIR K DIR,X,Y - .K ECLOC - ; - I 'ECCHK G DONE ;** (essentially) QUIT out of middle - ; - W !,"You will not be able to select an extract that is not from your division.",! - S LO=$O(ECLOC(0)),HI=$O(ECLOC(" "),-1) - S DIR(0)="L^"_LO_":"_HI_"",DIR("A")="Select extracts to be purged" - S DIR("?",1)="Choose the number(s) of the extract(s) you wish to purge,",DIR("?")="(e.g. 1-3,17,20 to choose 1 thru 3, 17, and 20)." - W ! D ^DIR K DIR I $D(DIRUT) K ECLOC G DONE - S JJ=0,Y=","_Y F S JJ=$O(ECLOC(JJ)) Q:'JJ S JZ=","_JJ_"," I Y'[JZ K ECLOC(JJ) - D CBOCCHK(.ECLOC) I '$D(ECLOC) G GET - D DIVCHK(.ECLOC,.ECTMP) - I '$D(ECLOC) W !!,"You have not chosen a valid extract number. Try again." G GET -ASK3 W !!,"I will purge the following extract(s):" - S JJ=0 F S JJ=$O(ECLOC(JJ)) Q:'JJ D - .W !?5,"#",JJ," - ",$P(ECLOC(JJ),U) - .W ?47,$TR($$FMTE^XLFDT($P(ECLOC(JJ),U,2),"5DF")," ","0")," to ",$TR($$FMTE^XLFDT($P(ECLOC(JJ),U,3),"5DF")," ","0") - W !! K DIR S DIR(0)="Y",DIR("A")="Is this OK",DIR("B")="NO" - S DIR("?",1)=" Enter:" - S DIR("?",2)=" ""YES"" if you agree with this list and would like to proceed," - S DIR("?",3)=" ""NO"" if you would like to make a different selection, or" - S DIR("?")=" ""^"" to exit option." - D ^DIR K DIR I $D(DIRUT) K ECLOC G DONE - I 'Y G GET - ; at this point, the local array ECLOC( is passed back to ^ECXPURG - G DONE -QUIT ; - I $E(IOST)="C"&('QFLG) S DIR(0)="E" D D ^DIR K DIR - .S SS=22-$Y F JJ=1:1:SS W ! - W:$E(IOST)'="C" @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" -DONE K ^TMP("ECXPURG",$J),ZTSK Q -PRT ;print list of extracts - S (PG,QFLG)=0,$P(LN,"-",81)="" D NOW^%DTC S Y=$E(%,1,12) X ^DD("DD") S HDT=Y D HDR - S ECTYP="" F S ECTYP=$O(^TMP("ECXPURG",$J,ECTYP)) Q:ECTYP="" Q:QFLG D:$Y+4>IOSL HDR Q:QFLG W !!,ECTYP D - .S ECEX=0 F S ECEX=$O(^TMP("ECXPURG",$J,ECTYP,ECEX)) Q:'ECEX Q:QFLG I $D(^ECX(727,ECEX,0)) S EC=^(0) D - ..S ECDT=$$FMTE^XLFDT($P(EC,U,2),"D") - ..S ECFR=$TR($$FMTE^XLFDT($P(EC,U,4),"5DF")," ","0") - ..S ECTO=$TR($$FMTE^XLFDT($P(EC,U,5),"5DF")," ","0") - ..S ECRC=$P(EC,U,6) S:ECRC="" ECRC="Incomplete" - ..S ECTRN=$$FMTE^XLFDT($G(^ECX(727,ECEX,"TR")),"D") - ..S ECXDIV=$P($G(^ECX(727,ECEX,"DIV")),U,1) I ECXDIV D - ...K ECXDIC S DA=ECXDIV,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" - ...D EN^DIQ1 S ECXDIV=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC - ..D:$Y+3>IOSL HDR Q:QFLG - ..W !?1,ECEX,?11,ECDT,?25,ECFR,"-",ECTO,?48,$J(ECRC,9),?60,ECTRN,?75,ECXDIV - G QUIT -HDR ;HEADER - I $E(IOST)="C" S SS=22-$Y F JJ=1:1:SS W ! - I $E(IOST)="C",PG>0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q - S PG=PG+1 W:$Y!($E(IOST)="C") @IOF W !,"PURGABLE EXTRACTS",?72,"Page: ",PG,!,"Printed on ",HDT,! - W !,"FEEDER SYS",?12,"EXTRACT,",!,"EXTRACT #",?12,"DATE",?33,"FROM-TO",?48,"RECORD CNT",?60,"TRANSMIT DATE",?75,"DIV",!,LN - Q -DATES ;ask for date range for purge of holding files - K HI,LO,ECBDT,ECEDT - I ECY="I" D - .I '$O(^ECX(728.113,0)) W !!,"You have no data in the IVP holding file (file #728.113) to purge." Q - .S LO=$O(^ECX(728.113,"A",0)),HI=$O(^ECX(728.113,"A"," "),-1) - I ECY="U" D - .I '$O(^ECX(728.904,0)) W !!,"You have no data in the UDP holding file (file #728.904) to purge." Q - .S LO=$O(^ECX(728.904,"A",0)),HI=$O(^ECX(728.904,"A"," "),-1) - I ECY="V" D - .I '$O(^VBEC(6002.03,0)) W !!,"You have no data in the VBECS holding file (file #6002.03) to purge." Q - .S LO=$O(^VBEC(6002.03,"C",0)),HI=$O(^VBEC(6002.03,"C"," "),-1) - Q:$G(LO)="" - W @IOF,!!,"This file currently holds ",$S(ECY="I":"IVP",ECY="U":"UDP",1:"VBECS")," data from <",$$FMTE^XLFDT(LO,"D"),"> to <",$$FMTE^XLFDT(HI,"D"),">." - W ! K DIR S DIR(0)="DA^"_LO_":"_HI_":EPX",DIR("A")="Beginning date for purge: " D ^DIR K DIR I $D(DIRUT) K HI,LO Q - S ECBDT=+Y - K DIR S DIR(0)="DA^"_ECBDT_":"_HI_":EPX",DIR("A")="Ending date for purge: " D ^DIR K DIR I $D(DIRUT) K HI,LO,ECBDT Q - S ECEDT=+Y -ASK4 ; ask to confirm date range - W !!,"I will purge the ",$S(ECY="I":"IVP",ECY="U":"UDP",1:"VBECS")," holding file from <",$$FMTE^XLFDT(ECBDT,"D"),"> to <",$$FMTE^XLFDT(ECEDT,"D"),">." - W $C(7),$C(7),!!?3,"** REMEMBER - Once this data is purged it CANNOT be recreated. **" - W !! K DIR S DIR(0)="Y",DIR("A")="Is this OK",DIR("B")="NO" - S DIR("?",1)=" Enter:" - S DIR("?",2)=" ""YES"" if you agree with this date range and wish to proceed," - S DIR("?",3)=" ""NO"" if you would like to make a different selection, or" - S DIR("?")=" ""^"" to exit option." - D ^DIR K DIR I $D(DIRUT) K ECBDT,ECEDT Q - I 'Y G DATES - ; at this point, ECBDT and ECEDT are passed back to ^ECXPURG - Q - ; -DIVCHK(ECLOC,ECTMP) ;**Remove extracts from ECLOC that are for user's div. - N ECLPDA - S ECLPDA=0 - F S ECLPDA=$O(ECLOC(ECLPDA)) Q:(+ECLPDA=0) DO - .I '$D(ECTMP($P(^ECX(727,ECLPDA,"DIV"),U,1))) KILL ECLOC(ECLPDA) - Q -CBOCCHK(ECLOC) ;**Check that CBOC report has been viewed prior to purging - N LOOPDA,YYYMMDD - S LOOPDA=0 - F S LOOPDA=$O(ECLOC(LOOPDA)) Q:(+LOOPDA=0) D - .I ^ECX(727,LOOPDA,"HEAD")="CLI" D - ..S DA(1)=1 - ..S YYYMMDD=$P(^ECX(727,LOOPDA,0),U,4) - ..I YYYMMDD>3030930 I '$D(^ECX(728,DA(1),"CBOC","B",LOOPDA)) D - ...K DIR S DIR(0)="Y",DIR("A")="The CBOC Activity Report has not been viewed. Purge anyway",DIR("B")="NO" - ...D ^DIR K DIR I 'Y K ECLOC(LOOPDA) - Q +ECXPURG1 ;BIR/CML-Purge of DSS Extract Files (CONTINUED) ; [ 12/05/96 11:58 AM ] + ;;3.0;DSS EXTRACTS;**2,9,8,24,49**;Dec 22, 1997 +GET ;compile list of purgable extracts + K HI,LO,ECBDT,ECEDT,ECLOC,^TMP("ECXPURG",$J) + S QFLG=1 W !!,"...one moment please" + S ECEX=0 F S ECEX=$O(^ECX(727,ECEX)) Q:'ECEX I '$G(^ECX(727,ECEX,"PURG")),$D(^ECX(727,ECEX,0)) S EC=^(0) D + .S ^TMP("ECXPURG",$J,$P(EC,U,3),ECEX)="",ECLOC(ECEX)=$P(EC,U,3)_U_$P(EC,U,4,5) + I '$D(^TMP("ECXPURG",$J)) W !!,"There are no extracts that can be purged at this time." G DONE +ASK1 ;ask for print + W ! + K DIR S DIR(0)="Y",DIR("A")="Do you want to print a list of extracts that can be purged",DIR("B")="NO" + D ^DIR K DIR I $D(DIRUT) K ECLOC G DONE + G:'Y ASK2 + W !!,"The right margin for this report is 80.",!! + K ZTSAVE S ZTSAVE("^TMP(""ECXPURG"",$J,")="" + D EN^XUTMDEVQ("PRT^ECXPURG1","DSS - Print Purgable Extracts",.ZTSAVE) I 'POP G ASK2 + W !,"NO DEVICE SELECTED OR REPORT PRINTED!!" +ASK2 ;ask for extract range + ; + ;** Check divisions for purging + N ECCHK,ECTMP + S ECCHK=$$DIV4^XUSER(.ECTMP,DUZ) + I 'ECCHK DO + .W !,"You do not have any divisions defined in your user set up and can not purge." + .S DIR(0)="FAO^1:1",DIR("A")="Hit Return to continue." D ^DIR K DIR,X,Y + .K ECLOC + ; + I 'ECCHK G DONE ;** (essentially) QUIT out of middle + ; + W !,"You will not be able to select an extract that is not from your division.",! + S LO=$O(ECLOC(0)),HI=$O(ECLOC(" "),-1) + S DIR(0)="L^"_LO_":"_HI_"",DIR("A")="Select extracts to be purged" + S DIR("?",1)="Choose the number(s) of the extract(s) you wish to purge,",DIR("?")="(e.g. 1-3,17,20 to choose 1 thru 3, 17, and 20)." + W ! D ^DIR K DIR I $D(DIRUT) K ECLOC G DONE + S JJ=0,Y=","_Y F S JJ=$O(ECLOC(JJ)) Q:'JJ S JZ=","_JJ_"," I Y'[JZ K ECLOC(JJ) + D CBOCCHK(.ECLOC) I '$D(ECLOC) G GET + D DIVCHK(.ECLOC,.ECTMP) + I '$D(ECLOC) W !!,"You have not chosen a valid extract number. Try again." G GET +ASK3 W !!,"I will purge the following extract(s):" + S JJ=0 F S JJ=$O(ECLOC(JJ)) Q:'JJ D + .W !?5,"#",JJ," - ",$P(ECLOC(JJ),U) + .W ?47,$TR($$FMTE^XLFDT($P(ECLOC(JJ),U,2),"5DF")," ","0")," to ",$TR($$FMTE^XLFDT($P(ECLOC(JJ),U,3),"5DF")," ","0") + W !! K DIR S DIR(0)="Y",DIR("A")="Is this OK",DIR("B")="NO" + S DIR("?",1)=" Enter:" + S DIR("?",2)=" ""YES"" if you agree with this list and would like to proceed," + S DIR("?",3)=" ""NO"" if you would like to make a different selection, or" + S DIR("?")=" ""^"" to exit option." + D ^DIR K DIR I $D(DIRUT) K ECLOC G DONE + I 'Y G GET + ; at this point, the local array ECLOC( is passed back to ^ECXPURG + G DONE +QUIT ; + I $E(IOST)="C"&('QFLG) S DIR(0)="E" D D ^DIR K DIR + .S SS=22-$Y F JJ=1:1:SS W ! + W:$E(IOST)'="C" @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" +DONE K ^TMP("ECXPURG",$J),ZTSK Q +PRT ;print list of extracts + S (PG,QFLG)=0,$P(LN,"-",81)="" D NOW^%DTC S Y=$E(%,1,12) X ^DD("DD") S HDT=Y D HDR + S ECTYP="" F S ECTYP=$O(^TMP("ECXPURG",$J,ECTYP)) Q:ECTYP="" Q:QFLG D:$Y+4>IOSL HDR Q:QFLG W !!,ECTYP D + .S ECEX=0 F S ECEX=$O(^TMP("ECXPURG",$J,ECTYP,ECEX)) Q:'ECEX Q:QFLG I $D(^ECX(727,ECEX,0)) S EC=^(0) D + ..S ECDT=$$FMTE^XLFDT($P(EC,U,2),"D") + ..S ECFR=$TR($$FMTE^XLFDT($P(EC,U,4),"5DF")," ","0") + ..S ECTO=$TR($$FMTE^XLFDT($P(EC,U,5),"5DF")," ","0") + ..S ECRC=$P(EC,U,6) S:ECRC="" ECRC="Incomplete" + ..S ECTRN=$$FMTE^XLFDT($G(^ECX(727,ECEX,"TR")),"D") + ..S ECXDIV=$P($G(^ECX(727,ECEX,"DIV")),U,1) I ECXDIV D + ...K ECXDIC S DA=ECXDIV,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" + ...D EN^DIQ1 S ECXDIV=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC + ..D:$Y+3>IOSL HDR Q:QFLG + ..W !?1,ECEX,?11,ECDT,?25,ECFR,"-",ECTO,?48,$J(ECRC,9),?60,ECTRN,?75,ECXDIV + G QUIT +HDR ;HEADER + I $E(IOST)="C" S SS=22-$Y F JJ=1:1:SS W ! + I $E(IOST)="C",PG>0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q + S PG=PG+1 W:$Y!($E(IOST)="C") @IOF W !,"PURGABLE EXTRACTS",?72,"Page: ",PG,!,"Printed on ",HDT,! + W !,"FEEDER SYS",?12,"EXTRACT,",!,"EXTRACT #",?12,"DATE",?33,"FROM-TO",?48,"RECORD CNT",?60,"TRANSMIT DATE",?75,"DIV",!,LN + Q +DATES ;ask for date range for purge of holding files + K HI,LO,ECBDT,ECEDT + I ECY="I" D + .I '$O(^ECX(728.113,0)) W !!,"You have no data in the IVP holding file (file #728.113) to purge." Q + .S LO=$O(^ECX(728.113,"A",0)),HI=$O(^ECX(728.113,"A"," "),-1) + I ECY="U" D + .I '$O(^ECX(728.904,0)) W !!,"You have no data in the UDP holding file (file #728.904) to purge." Q + .S LO=$O(^ECX(728.904,"A",0)),HI=$O(^ECX(728.904,"A"," "),-1) + Q:$G(LO)="" + W @IOF,!!,"This file currently holds ",$S(ECY="I":"IVP",1:"UDP")," data from <",$$FMTE^XLFDT(LO,"D"),"> to <",$$FMTE^XLFDT(HI,"D"),">." + W ! K DIR S DIR(0)="DA^"_LO_":"_HI_":EPX",DIR("A")="Beginning date for purge: " D ^DIR K DIR I $D(DIRUT) K HI,LO Q + S ECBDT=+Y + K DIR S DIR(0)="DA^"_ECBDT_":"_HI_":EPX",DIR("A")="Ending date for purge: " D ^DIR K DIR I $D(DIRUT) K HI,LO,ECBDT Q + S ECEDT=+Y +ASK4 ; ask to confirm date range + W !!,"I will purge the ",$S(ECY="I":"IVP",1:"UDP")," holding file from <",$$FMTE^XLFDT(ECBDT,"D"),"> to <",$$FMTE^XLFDT(ECEDT,"D"),">." + W $C(7),$C(7),!!?3,"** REMEMBER - Once this data is purged it CANNOT be recreated. **" + W !! K DIR S DIR(0)="Y",DIR("A")="Is this OK",DIR("B")="NO" + S DIR("?",1)=" Enter:" + S DIR("?",2)=" ""YES"" if you agree with this date range and wish to proceed," + S DIR("?",3)=" ""NO"" if you would like to make a different selection, or" + S DIR("?")=" ""^"" to exit option." + D ^DIR K DIR I $D(DIRUT) K ECBDT,ECEDT Q + I 'Y G DATES + ; at this point, ECBDT and ECEDT are passed back to ^ECXPURG + Q + ; +DIVCHK(ECLOC,ECTMP) ;**Remove extracts from ECLOC that are for user's div. + N ECLPDA + S ECLPDA=0 + F S ECLPDA=$O(ECLOC(ECLPDA)) Q:(+ECLPDA=0) DO + .I '$D(ECTMP($P(^ECX(727,ECLPDA,"DIV"),U,1))) KILL ECLOC(ECLPDA) + Q +CBOCCHK(ECLOC) ;**Check that CBOC report has been viewed prior to purging + N LOOPDA,YYYMMDD + S LOOPDA=0 + F S LOOPDA=$O(ECLOC(LOOPDA)) Q:(+LOOPDA=0) D + .I ^ECX(727,LOOPDA,"HEAD")="CLI" D + ..S DA(1)=1 + ..S YYYMMDD=$P(^ECX(727,LOOPDA,0),U,4) + ..I YYYMMDD>3030930 I '$D(^ECX(728,DA(1),"CBOC","B",LOOPDA)) D + ...K DIR S DIR(0)="Y",DIR("A")="The CBOC Activity Report has not been viewed. Purge anyway",DIR("B")="NO" + ...D ^DIR K DIR I 'Y K ECLOC(LOOPDA) + Q diff --git a/r/DSS_EXTRACTS-ECX/ECXQSR.m b/r/DSS_EXTRACTS-ECX/ECXQSR.m index a919cfee..98f339f8 100644 --- a/r/DSS_EXTRACTS-ECX/ECXQSR.m +++ b/r/DSS_EXTRACTS-ECX/ECXQSR.m @@ -1,150 +1,190 @@ -ECXQSR ;ALB/JAP,BIR/PTD-DSS QUASAR Extract ; 7/31/07 11:19pm - ;;3.0;DSS EXTRACTS;**11,8,13,26,24,34,33,35,39,43,46,49,64,71,84,92,106,105**;Dec 22, 1997;Build 70 -BEG ;entry point from option - I '$O(^ACK(509850.8,0)) W !,"You must be using the Quality Audiology & Speech Pathology",!,"Audit & Review (QUASAR) software to run this extract.",!! Q - I '$D(^ACK(509850.8,1,"DSS")) W !,"Linkage has not been established between QUASAR and the DSS UNIT file (#724).",!! Q - I '$O(^ACK(509850.6,0)) W !,"There is no data in the A&SP CLINIC VISIT file (#509850.6).",!! Q - D SETUP I ECFILE="" Q - D ^ECXTRAC,^ECXKILL - Q -START ;entry point from tasked job - N ERR,ECXQDT,ECXNPRFI - S QFLG=0,ECED=ECED+.9,ECD=ECSD1,ECXQV="" - D QINST I $D(ERR) Q - S ECL=+^ACK(509850.8,1,0),ECLINK=^ACK(509850.8,1,"DSS") - F S ECD=$O(^ACK(509850.6,"B",ECD)),ECDA=0 Q:(ECD>ECED)!('ECD)!(QFLG) D - .I +ECXQV=3,ECD2003 D - .I "^18^23^24^36^41^65^94^"[("^"_ECXTS_"^") S ECDSS=$$TSMAP^ECXUTL4(ECXTS) - S ECDU=$S(ECSTOP["A":$P(ECLINK,U),ECSTOP["S":$P(ECLINK,U,2),1:"") - Q:'ECDU - S ECDSSU=$G(^ECD(ECDU,0)),ECCS=+$P(ECDSSU,U,4),(ECO,ECM)=+$P(ECDSSU,U,3),ECXDSSD=$E($P(ECDSSU,U,5),1,10) - Q:'$O(^ACK(509850.6,ECDA,3,0)) - ;Create local array of procedure codes and # of times each procedure - ; was performed. - F I=1:1:4 S @("ECXICD9"_I)="" - S (ECDIA,ECXPPC,ECXPRV1,ECXPRV2,ECXPRV3,ECUN1NPI)="" - ;if QUASAR v2 - I +ECXQV=2 D - .S ECXPRV1=$P(EC2NODE,U,7),ECXPRV2=$P(EC2NODE,U,3),ECXPRV3=$P(EC2NODE,U,5),ECPN=0 - .S ECPR1NPI=$$NPI^XUSNPI("Individual_ID",ECXPRV1,ECD) - .S:+ECPR1NPI'>0 ECPR1NPI="" S ECPR1NPI=$P(ECPR1NPI,U) - .S ECPR2NPI=$$NPI^XUSNPI("Individual_ID",ECXPRV2,ECD) - .S:+ECPR2NPI'>0 ECPR2NPI="" S ECPR2NPI=$P(ECPR2NPI,U) - .S ECPR3NPI=$$NPI^XUSNPI("Individual_ID",ECXPRV3,ECD) - .S:+ECPR3NPI'>0 ECPR3NPI="" S ECPR3NPI=$P(ECPR3NPI,U) - .F S ECPN=$O(^ACK(509850.6,ECDA,3,ECPN)) Q:'ECPN D - ..S XX=^ACK(509850.6,ECDA,3,ECPN,0),XX=$P(XX,U),XX=$P($G(^ACK(509850.4,XX,0)),U),ECXCPT=$E($$CPT^ECXUTL3(XX),1,5) - ..I ECXCPT]"" D - ...I '$D(LOC(ECXCPT)) S LOC(ECXCPT)=0_U_ECXPRV1 - ...S $P(LOC(ECXCPT),U)=$P(LOC(ECXCPT),U)+1 - .S ECIEN=$O(^ACK(509850.6,ECDA,1,0)),ECDIA=$P($G(^ICD9(+$G(^ACK(509850.6,ECDA,1,ECIEN,0)),0)),U) - .F I=1:1:4 S ECIEN=$O(^ACK(509850.6,ECDA,1,ECIEN)) Q:'+ECIEN D - ..S @("ECXICD9"_I)=$P($G(^ICD9(+$P(^ACK(509850.6,ECDA,1,ECIEN,0),U),0)),U) - ;if QUASAR v3 - I +ECXQV=3 D - .N CPT,DIA,I,J,MOD,MOD1,P,STR,VOL,ECTP,ARY,ECP,ECPN - .S ECXPRV2=$G(^ACK(509850.6,ECDA,2.7,1,0)),ECXPRV3=$G(^ACK(509850.6,ECDA,2.7,2,0)) - .S ECPN=0 F S ECPN=$O(^ACK(509850.6,ECDA,3,ECPN)) Q:'ECPN D - ..S CPT=^ACK(509850.6,ECDA,3,ECPN,0),ECXCPT=$P(CPT,U),ECTP=+$P(CPT,U,5),ECV=1,ECP="" - ..Q:ECXCPT="" - ..I ECTP D - ...S CPT=$G(^ACK(509850.6,ECDA,7,ECTP,0)),ECP=$P(CPT,U) - ...S ECP=$S(ECP<90000:$P($G(^EC(725,+ECP,0)),U,2)_"N",1:$P($G(^EC(725,+ECP,0)),U,2)_"L") - ...S VOL=+$P(CPT,U,2),ECXPRV1=$P(CPT,U,3) - ..I 'ECTP S VOL=+$P(CPT,U,3),ECXPRV1=$P(CPT,U,4) - ..S ECXCPT=$E($$CPT^ECXUTL3(ECXCPT),1,5),ECXMOD="",MOD=0 - ..F S MOD=$O(^ACK(509850.6,ECDA,3,ECPN,1,MOD)) Q:'MOD D - ...S MOD1=+^ACK(509850.6,ECDA,3,ECPN,1,MOD,0) D:MOD1 - ....S ECXMOD=ECXMOD_MOD1_";" - ..F I=1:1:$L(ECXMOD,";") I $G(ARY(ECXCPT))'[$P(ECXMOD,";",I) D - ...S ARY(ECXCPT)=$G(ARY(ECXCPT))_$P(ECXMOD,";",I)_";" - ..S:VOL ECV=VOL - ..S ECV=ECV+$G(LOC(ECXCPT)),LOC(ECXCPT)=ECV_U_ECXPRV1_U_ECP - .S ECIEN=0 F S ECIEN=$O(^ACK(509850.6,ECDA,1,ECIEN)) Q:'ECIEN D - ..S DIA=^ACK(509850.6,ECDA,1,ECIEN,0),P=$P(DIA,U,2),P=$S(P=1:"P",1:"S") - ..S CNT=$G(STR(P))+1,STR(P,CNT)=$P($G(^ICD9(+DIA,0)),U),STR(P)=CNT - .S ECDIA=$G(STR("P",1)) - .F I=1:1:4 Q:'$D(STR("P",I+1)) S @("ECXICD9"_I)=STR("P",I) - .S:ECDIA="" ECDIA=$G(STR("S",1)),I=2 - .F J=I:1:4 Q:'$D(STR("S",J)) S @("ECXICD9"_J)=STR("S",J) - Q:('$D(LOC))!('$O(^ACK(509850.6,ECDA,1,0))) - ;- Ord Div, Contract St/End Dates, Contract Type placeholders for FY2002 - S (ECXODIV,ECXCSDT,ECXCEDT,ECXCTYP)="" - ;set up Provider Person class - S (ECXCPT,ECXPPC1,ECXPPC2,ECXPPC3)="" - S:ECXPRV2'="" ECXPPC2=$$PRVCLASS^ECXUTL(ECXPRV2,ECD) - S:ECXPRV3'="" ECXPPC3=$$PRVCLASS^ECXUTL(ECXPRV3,ECD) - N DA,DIC,DIK,DR,FILEN,DIQ,XVAR,II,DI - F II=2,3 S XVAR="ECXPRV"_II I @XVAR'="" D - .S DA=@XVAR,(DIC,FILEN)=509850.3,DR=".01",DIQ="ECXQSR",DIQ(0)="I" D EN^DIQ1 - .S DA=ECXQSR(FILEN,DA,DR,"I"),(DIC,FILEN)=8930.3 D EN^DIQ1 S @XVAR=2_ECXQSR(FILEN,DA,DR,"I") K DA,DIC,DR,DIQ,ECXQSR - ; -Observation Patient Indicator (yes/no) - S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECDSS) - ; -CNH status (YES/NO) - S ECXCNH=$$CNHSTAT^ECXUTL4(ECXDFN) - ;get encounter classification - S (ECXAO,ECXECE,ECXIR,ECXMIL,ECXHNC)="",ECXVISIT=$P($G(^ACK(509850.6,ECDA,6)),U,3) - I ECXVISIT'="" D - .D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) I ECXERR K ECXERR Q - .S ECXAO=$G(ECXVIST("AO")),ECXECE=$G(ECXVIST("PGE")) - .S ECXIR=$G(ECXVIST("IR")),ECXMIL=$G(ECXVIST("MST")),ECXHNC=$G(ECXVIST("HNC")) - ; -Head and Neck Cancer Indicator - S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) - ;get enrollment data (category, status and priority) - I $$ENROLLM^ECXUTL2(ECXDFN) - ; -Get national patient record flag Indicator if exist - D NPRF^ECXUTL5 - ; -If no encounter number don't file record - S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECDT,ECXTS,ECXOBS,ECHEAD,ECDSS,) - Q:ECXENC="" - ;Loop through array of unique procedures. Create record in ECODE. - S CPT="" F S CPT=$O(LOC(CPT)) Q:CPT="" D - .S ECV=+$P(LOC(CPT),U),ECXCPT=$$CPT^ECXUTL3(CPT,$G(ARY(CPT)),ECV) - .S ECXPRV1=$P(LOC(CPT),U,2) - .S:ECXPRV1'="" ECXPPC1=$$PRVCLASS^ECXUTL(ECXPRV1,ECD),ECXPRV1=2_ECXPRV1 - .S ECP=$P(LOC(CPT),U,3) I ECP="" S ECP=$$CPT^ECXUTL3(CPT,"",ECV) - .D FILE^ECXQSR1 - K CPT,LOC - Q -SETUP ;Set required input for ECXTRAC - S ECHEAD="ECQ" - D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) - Q -QUE ;Entry point for the background requeuing handled by ECXTAUTO. - D SETUP,QUE^ECXTAUTO,^ECXKILL Q +ECXQSR ;ALB/JAP,BIR/PTD-DSS QUASAR Extract ; 04/16/07 8:58am + ;;3.0;DSS EXTRACTS;**11,8,13,26,24,34,33,35,39,43,46,49,64,71,84,92,106**;Dec 22, 1997;Build 1 +BEG ;entry point from option + I '$O(^ACK(509850.8,0)) W !,"You must be using the Quality Audiology & Speech Pathology",!,"Audit & Review (QUASAR) software to run this extract.",!! Q + I '$D(^ACK(509850.8,1,"DSS")) W !,"Linkage has not been established between QUASAR and the DSS UNIT file (#724).",!! Q + I '$O(^ACK(509850.6,0)) W !,"There is no data in the A&SP CLINIC VISIT file (#509850.6).",!! Q + D SETUP I ECFILE="" Q + D ^ECXTRAC,^ECXKILL + Q +START ;entry point from tasked job + N ERR,ECXQDT,ECXNPRFI + S QFLG=0,ECED=ECED+.9,ECD=ECSD1,ECXQV="" + D QINST I $D(ERR) Q + S ECL=+^ACK(509850.8,1,0),ECLINK=^ACK(509850.8,1,"DSS") + F S ECD=$O(^ACK(509850.6,"B",ECD)),ECDA=0 Q:(ECD>ECED)!('ECD)!(QFLG) D + .I +ECXQV=3,ECD2003 D + .I "^18^23^24^36^41^65^94^"[("^"_ECXTS_"^") S ECDSS=$$TSMAP^ECXUTL4(ECXTS) + S ECDU=$S(ECSTOP["A":$P(ECLINK,U),ECSTOP["S":$P(ECLINK,U,2),1:"") + Q:'ECDU + S ECDSSU=$G(^ECD(ECDU,0)),ECCS=+$P(ECDSSU,U,4),(ECO,ECM)=+$P(ECDSSU,U,3),ECXDSSD=$E($P(ECDSSU,U,5),1,10) + Q:'$O(^ACK(509850.6,ECDA,3,0)) + ;Create local array of procedure codes and # of times each procedure + ; was performed. + F I=1:1:4 S @("ECXICD9"_I)="" + S (ECDIA,ECXPPC,ECXPRV1,ECXPRV2,ECXPRV3,ECUN1NPI)="" + ;if QUASAR v2 + I +ECXQV=2 D + .S ECXPRV1=$P(EC2NODE,U,7),ECXPRV2=$P(EC2NODE,U,3),ECXPRV3=$P(EC2NODE,U,5),ECPN=0 + .F S ECPN=$O(^ACK(509850.6,ECDA,3,ECPN)) Q:'ECPN D + ..S XX=^ACK(509850.6,ECDA,3,ECPN,0),XX=$P(XX,U),XX=$P($G(^ACK(509850.4,XX,0)),U),ECXCPT=$E($$CPT^ECXUTL3(XX),1,5) + ..I ECXCPT]"" D + ...I '$D(LOC(ECXCPT)) S LOC(ECXCPT)=0_U_ECXPRV1 + ...S $P(LOC(ECXCPT),U)=$P(LOC(ECXCPT),U)+1 + .S ECIEN=$O(^ACK(509850.6,ECDA,1,0)),ECDIA=$P($G(^ICD9(+$G(^ACK(509850.6,ECDA,1,ECIEN,0)),0)),U) + .F I=1:1:4 S ECIEN=$O(^ACK(509850.6,ECDA,1,ECIEN)) Q:'+ECIEN D + ..S @("ECXICD9"_I)=$P($G(^ICD9(+$P(^ACK(509850.6,ECDA,1,ECIEN,0),U),0)),U) + ;if QUASAR v3 + I +ECXQV=3 D + .N CPT,DIA,I,J,MOD,MOD1,P,STR,VOL,ECTP,ARY,ECP,ECPN + .S ECXPRV2=$G(^ACK(509850.6,ECDA,2.7,1,0)),ECXPRV3=$G(^ACK(509850.6,ECDA,2.7,2,0)) + .S ECPN=0 F S ECPN=$O(^ACK(509850.6,ECDA,3,ECPN)) Q:'ECPN D + ..S CPT=^ACK(509850.6,ECDA,3,ECPN,0),ECXCPT=$P(CPT,U),ECTP=+$P(CPT,U,5),ECV=1,ECP="" + ..Q:ECXCPT="" + ..I ECTP D + ...S CPT=$G(^ACK(509850.6,ECDA,7,ECTP,0)),ECP=$P(CPT,U) + ...S ECP=$S(ECP<90000:$P($G(^EC(725,+ECP,0)),U,2)_"N",1:$P($G(^EC(725,+ECP,0)),U,2)_"L") + ...S VOL=+$P(CPT,U,2),ECXPRV1=$P(CPT,U,3) + ..I 'ECTP S VOL=+$P(CPT,U,3),ECXPRV1=$P(CPT,U,4) + ..S ECXCPT=$E($$CPT^ECXUTL3(ECXCPT),1,5),ECXMOD="",MOD=0 + ..F S MOD=$O(^ACK(509850.6,ECDA,3,ECPN,1,MOD)) Q:'MOD D + ...S MOD1=+^ACK(509850.6,ECDA,3,ECPN,1,MOD,0) D:MOD1 + ....S ECXMOD=ECXMOD_MOD1_";" + ..F I=1:1:$L(ECXMOD,";") I $G(ARY(ECXCPT))'[$P(ECXMOD,";",I) D + ...S ARY(ECXCPT)=$G(ARY(ECXCPT))_$P(ECXMOD,";",I)_";" + ..S:VOL ECV=VOL + ..S ECV=ECV+$G(LOC(ECXCPT)),LOC(ECXCPT)=ECV_U_ECXPRV1_U_ECP + .S ECIEN=0 F S ECIEN=$O(^ACK(509850.6,ECDA,1,ECIEN)) Q:'ECIEN D + ..S DIA=^ACK(509850.6,ECDA,1,ECIEN,0),P=$P(DIA,U,2),P=$S(P=1:"P",1:"S") + ..S CNT=$G(STR(P))+1,STR(P,CNT)=$P($G(^ICD9(+DIA,0)),U),STR(P)=CNT + .S ECDIA=$G(STR("P",1)) + .F I=1:1:4 Q:'$D(STR("P",I+1)) S @("ECXICD9"_I)=STR("P",I) + .S:ECDIA="" ECDIA=$G(STR("S",1)),I=2 + .F J=I:1:4 Q:'$D(STR("S",J)) S @("ECXICD9"_J)=STR("S",J) + Q:('$D(LOC))!('$O(^ACK(509850.6,ECDA,1,0))) + ;- Ord Div, Contract St/End Dates, Contract Type placeholders for FY2002 + S (ECXODIV,ECXCSDT,ECXCEDT,ECXCTYP)="" + ;set up Provider Person class + S (ECXCPT,ECXPPC1,ECXPPC2,ECXPPC3)="" + S:ECXPRV2'="" ECXPPC2=$$PRVCLASS^ECXUTL(ECXPRV2,ECD) + S:ECXPRV3'="" ECXPPC3=$$PRVCLASS^ECXUTL(ECXPRV3,ECD) + N DA,DIC,DIK,DR,FILEN,DIQ,XVAR,II,DI + F II=2,3 S XVAR="ECXPRV"_II I @XVAR'="" D + .S DA=@XVAR,(DIC,FILEN)=509850.3,DR=".01",DIQ="ECXQSR",DIQ(0)="I" D EN^DIQ1 + .S DA=ECXQSR(FILEN,DA,DR,"I"),(DIC,FILEN)=8930.3 D EN^DIQ1 S @XVAR=2_ECXQSR(FILEN,DA,DR,"I") K DA,DIC,DR,DIQ,ECXQSR + ; -Observation Patient Indicator (yes/no) + S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECDSS) + ; -CNH status (YES/NO) + S ECXCNH=$$CNHSTAT^ECXUTL4(ECXDFN) + ;get encounter classification + S (ECXAO,ECXECE,ECXIR,ECXMIL,ECXHNC)="",ECXVISIT=$P($G(^ACK(509850.6,ECDA,6)),U,3) + I ECXVISIT'="" D + .D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) I ECXERR K ECXERR Q + .S ECXAO=$G(ECXVIST("AO")),ECXECE=$G(ECXVIST("PGE")) + .S ECXIR=$G(ECXVIST("IR")),ECXMIL=$G(ECXVIST("MST")),ECXHNC=$G(ECXVIST("HNC")) + ; -Head and Neck Cancer Indicator + S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) + ;get enrollment data (category, status and priority) + I $$ENROLLM^ECXUTL2(ECXDFN) + ; -Get national patient record flag Indicator if exist + D NPRF^ECXUTL5 + ; -If no encounter number don't file record + S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECDT,ECXTS,ECXOBS,ECHEAD,ECDSS,) + Q:ECXENC="" + ;Loop through array of unique procedures. Create record in ECODE. + S CPT="" F S CPT=$O(LOC(CPT)) Q:CPT="" D + .S ECV=+$P(LOC(CPT),U),ECXCPT=$$CPT^ECXUTL3(CPT,$G(ARY(CPT)),ECV) + .S ECXPRV1=$P(LOC(CPT),U,2) + .S:ECXPRV1'="" ECXPPC1=$$PRVCLASS^ECXUTL(ECXPRV1,ECD),ECXPRV1=2_ECXPRV1 + .S ECP=$P(LOC(CPT),U,3) I ECP="" S ECP=$$CPT^ECXUTL3(CPT,"",ECV) + .D FILE + K CPT,LOC + Q +FILE ;file record in #727.825 + ;node0 + ;inst^dfn ECXDFN^ssn ECXSSN^name ECXPNM^i/o status ECXA^day ECDAY^ + ;DSS unit ECDU^^category ECPTTM^procedure ECP^volume ECV^cost center^ + ;ordering sec ^section^provider ECXPRV1^ECXPPC1^ECXPRV2^ECXPPC2^ECXPRV3^ + ;ECXPPC3^mov # ECXMN^treat spec ECXTS^time ECTIME^primary care team + ;ECPTTM^primary care provider ECPTPR^pce cpt code & modifers ECXCPT^ + ;primary icd-9 code ECDIA^secondary icd-9 #1 ECXICD91^secondary icd-9 + ;#2 ECXICD92^secondary icd-9 #3 ECXICD93^secondary icd-9 #4 ECXICD94^ + ;agent orange ECXAST^radiation exposure ECRST^environmental + ;contaminants ECEST^service connected ECSC^sent to pce^^dss identifier + ;ECDSS^placeholder + ;node1 + ;mpi ECXNPI^dss dept ECXDSSD^provider npi ECUN1NPI^^^pc prov person + ;class ECPTNPI^assoc pc provider ECASPR^assoc pc prov person class + ;ECCLAS2^assoc pc provider npi ECASNPI^divison ECXDIV^dom ECXDOM^ + ;enrollment category ECXCAT^enrollment status ECXSTAT^enrollment prior + ;ECXPRIOR^period of service ECXPOS^purple heart ECXPHI^observ pat ind + ;ECXOBS^encounter num ECXENC^ao loc ECXAOL^ord div ECXODIV^contr st dt + ;ECXCSDT^contr end dt ECXCEDT^contr typ ECXCTYP^CNH stat ECXCNH^ + ;production division ECXPDIV^eligibility ECXELIG^ethnicity ECXETH^ + ;race1 ECXRC1^enrollment location ECXENRL^^enrollment priority + ;ECXPRIOR_enrollment subgroup ECXSBGRP^user enrollee ECXUESTA^patient + ;type ECXPTYPE^combat vet elig ECXCVE^combat vet elig end date ECXCVEDT^ + ;enc cv eligible ECXCVENC^national patient record flag ECXNPRFI^ + ;emergency response indicator(FEMA) ECXERI^agent orange indicator + ;ECXAO^environ contam ECXECE^head/neck ECXHNC^military sexual trauma + ;ECXMIL^radiation encoun ECXIR^nutrition dx + N DA,DIK + S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 + S ECODE=EC7_U_EC23_U + S ECODE=ECODE_ECL_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U_ECDAY_U_ECDU_U_U + S ECODE=ECODE_ECP_U_ECV_U_ECCS_U_ECO_U_ECM_U_ECXPRV1_U_ECXPPC1_U + S ECODE=ECODE_ECXPRV2_U_ECXPPC2_U_ECXPRV3_U_ECXPPC3_U_U + S ECODE=ECODE_ECXMN_U_ECXTS_U_ECTIME_U_ECPTTM_U + S ECODE=ECODE_ECPTPR_U_ECXCPT_U_ECDIA_U_ECXICD91_U_ECXICD92_U + S ECODE=ECODE_ECXICD93_U_ECXICD94_U_ECXAST_U_ECXRST_U_ECXEST_U + S ECODE=ECODE_ECSC_U_"N"_U_U_ECDSS_U_U + S ECODE1=ECXMPI_U_ECXDSSD_U_ECUN1NPI_U_U_U_ECCLAS_U_ECPTNPI_U_ECASPR_U + S ECODE1=ECODE1_ECCLAS2_U_ECASNPI_U_ECXDIV_U_ECXMST_U_ECXDOM_U + S ECODE1=ECODE1_ECXDOB_U_ECXCAT_U_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPOS_U_ECXPHI_U + S ECODE1=ECODE1_ECXOBS_U_ECXENC_U_ECXAOL_U_ECXODIV_U_ECXCSDT_U_ECXCEDT_U + S ECODE1=ECODE1_ECXCTYP_U_ECXCNH_U_ECXPDIV_U_ECXELIG_U_ECXHNCI_U_ECXETH_U + S ECODE1=ECODE1_ECXRC1 + I ECXLOGIC>2003 S ECODE1=ECODE1_U_ECXENRL + I ECXLOGIC>2004 S ECODE1=ECODE1_U_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U + I ECXLOGIC>2004 S ECODE2=ECXCVEDT_U_ECXCVENC_U_ECXNPRFI + I ECXLOGIC>2006 S ECODE2=ECODE2_U_ECXERI_U_ECXAO_U_ECXECE_U_ECXHNC_U_ECXMIL_U_ECXIR_U + S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,^ECX(ECFILE,EC7,2)=$G(ECODE2),ECRN=ECRN+1 + S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA + I $D(ZTQUEUED),$$S^%ZTLOAD + Q +SETUP ;Set required input for ECXTRAC + S ECHEAD="ECQ" + D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) + Q +QUE ;Entry point for the background requeuing handled by ECXTAUTO. + D SETUP,QUE^ECXTAUTO,^ECXKILL Q diff --git a/r/DSS_EXTRACTS-ECX/ECXRAD.m b/r/DSS_EXTRACTS-ECX/ECXRAD.m index f186f2fa..0368502d 100644 --- a/r/DSS_EXTRACTS-ECX/ECXRAD.m +++ b/r/DSS_EXTRACTS-ECX/ECXRAD.m @@ -1,134 +1,129 @@ -ECXRAD ;ALB/JAP,BIR/PDW,PTD-Extract for Radiology ; 5/30/2007 - ;;3.0;DSS EXTRACTS;**11,8,13,16,24,33,39,46,71,84,92,105**;Dec 22, 1997;Build 70 -BEG ;entry point from option - D SETUP I ECFILE="" Q - D ^ECXTRAC,^ECXKILL - Q - ; -START ;start rad extract - S QFLG=0 - K ECXDD D FIELD^DID(70.03,14,,"SPECIFIER","ECXDD") S ECPROF=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD - S ECXDFN="",ECDT=ECSD-.1,ECED1=ECED+.3 - F S ECDT=$O(^RADPT("AR",ECDT)) Q:ECDT>ECED1!(ECDT'>0) D Q:QFLG - .S ECXDFN="" - .F S ECXDFN=$O(^RADPT("AR",ECDT,ECXDFN)) Q:ECXDFN="" I '$D(^TMP("ECL",$J,ECXDFN)) D GET Q:QFLG - K ^TMP("ECL",$J) - Q - ; -GET ;get data - N ECXIEN,X,SUB,TYPE,ECDOCPC,ECXIS,ECXISPC,ECXPRCL,ECXCSC,ECXUSRTN - S ^TMP("ECL",$J,ECXDFN)="" - ;with dfn get all exams within date range - S ECXMDT=ECSD-.1 - F S ECXMDT=$O(^RADPT(ECXDFN,"DT","B",ECXMDT)) Q:((ECXMDT>ECED1)!(ECXMDT="")) D Q:QFLG - .S ECXMDA=$O(^RADPT(ECXDFN,"DT","B",ECXMDT,"")) Q:ECXMDA="" - .S ECXIEN=+$P($G(^RADPT(ECXDFN,"DT",ECXMDA,"P",1,0)),U,11) - .S ECTM=$$ECXTIME^ECXUTL(ECXMDT) S:ECTM>235959 ECTM=235959 - .S ECXDAY=$$ECXDATE^ECXUTL(ECXMDT,ECXYM) - .K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECXMDT,"."),"1;3",.ECXPAT) - .Q:'OK - .S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI") - .;get emergency response indicator (FEMA) - .S ECXERI=ECXPAT("ERI") - .S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXMDT,"."),ECPROF) - .S ECPTTM=$P(X,U,1),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4) - .S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7) - .S X=$$INP^ECXUTL2(ECXDFN,ECXMDT),ECXA=$P(X,U),ECXMN=$P(X,U,2) - .S ECXTS=$P(X,U,3),ECXDOM=$P(X,U,10),ECXADMDT=$P(X,U,4) - .; - .;- Observation patient indicator (YES/NO) - .S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) - .;for dfn & date get exam(s) ien - .S ECXMDA="" - .F S ECXMDA=$O(^RADPT(ECXDFN,"DT","B",ECXMDT,ECXMDA)) Q:+ECXMDA=0 D - ..S ECXDIV=$P(^RADPT(ECXDFN,"DT",ECXMDA,0),U,3),ECLOC=$P(^(0),U,4),ECTY=$P(^(0),U,2) - ..; - ..;- Ordering stop code (based on imaging location) - ..S ECXORDST=$$GET1^DIQ(40.7,$$GET1^DIQ(79.1,$G(ECLOC),22,"I"),1) - ..; - ..;- Get ordering date using Imaging Order ptr to #75.1 in subfile 70.03 - ..S ECXIEN=+$P($G(^RADPT(ECXDFN,"DT",ECXMDA,"P",1,0)),U,11) - ..S ECXORDDT=$$ECXDATE^ECXUTL($P($G(^RAO(75.1,ECXIEN,0)),U,16),ECXYM) - ..; - ..;- If no encounter number don't file record - ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXMDT,ECXTS,ECXOBS,ECHEAD,ECTY,) Q:ECXENC="" - ..;procedures and modifiers for specific exam (case numbers) - ..;ward/clinic,service,provider,diagnostic code - ..S ECCN=0 - ..F S ECCN=$O(^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN)) Q:ECCN'>0 D - ...S ECCA=^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,0) - ...S ECXW=$P(ECCA,U,6),ECXW=$P($G(^DIC(42,+ECXW,44)),U) - ...S:ECXW="" ECXW=$P(ECCA,U,8) - ...S ECDOCNPI=$$NPI^XUSNPI("Individual_ID",$P(ECCA,U,14),ECDT) - ...S:+ECDOCNPI'>0 ECDOCNPI="" S ECDOCNPI=$P(ECDOCNPI,U) - ...S (ECXDSSD,ECXDSSP)="" - ...S ECS=$P(ECCA,U,7),ECDOC=ECPROF_$P(ECCA,U,14),ECDI=$P(ECCA,U,13),ECDOCPC=$$PRVCLASS^ECXUTL($P(ECCA,U,14),ECDT) - ...S ECPRO=$P(ECCA,U,2),ECSTAT=$P($G(^RA(72,+$P(ECCA,U,3),0)),U,3) - ...;get the primary interpreting staff and the person class DBIA #65 - ...S ECXIS=$P(ECCA,U,15),ECXISPC=$$PRVCLASS^ECXUTL(ECXIS,ECDT) - ...S ECISNPI=$$NPI^XUSNPI("Individual_ID",ECXIS,ECDT) - ...S:+ECISNPI'>0 ECISNPI="" S ECISNPI=$P(ECISNPI,U) - ...;prefix interpreting radiologist with a "2" if not null - ...S ECXIS=$S(ECXIS:"2"_ECXIS,1:"") - ...;get the principal clinic ien DBIA #65 - ...S ECXPRCL=$P(ECCA,U,8) - ...;get the clinic stop code from file #44 - ...S ECXCSC=$$GET1^DIQ(40.7,$$GET1^DIQ(44,ECXPRCL,8,"I"),1) - ...Q:'ECPRO - ...Q:+ECSTAT=0 - ...;get CPT code & modifiers - ...S ECPT=+$P($G(^RAMIS(71,+ECPRO,0)),U,9),ECXCMOD="" - ...;quit if this is a 'parent' procedure - ...S TYPE=$P($G(^RAMIS(71,+ECPRO,0)),U,6) - ...Q:((ECPT=0)&(TYPE="P")) - ...;if site is using radiology with cpt modifiers then get them - ...K ARR,ERR D FIELD^DID(70.03,135,,"LABEL","ARR","ERR") - ...I $D(ARR("LABEL")) D - ....K ARR,ERR D FIELD^DID(70.03,135,,"GLOBAL SUBSCRIPT LOCATION","ARR","ERR") - ....Q:$D(ERR("DIERR")) - ....S SUB=$P(ARR("GLOBAL SUBSCRIPT LOCATION"),";") S ECMOD=0 - ....Q:'$D(^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,SUB)) - ....F S ECMOD=$O(^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,SUB,ECMOD)) Q:ECMOD'>0 S ECXCMOD=ECXCMOD_$P(^(ECMOD,0),U)_";" - ...S ECXCPT=$$CPT^ECXUTL3(ECPT,ECXCMOD) - ...;get procedure radiology modifiers - ...S ECMOD=0,ECMODS="" - ...F S ECMOD=$O(^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,"M",ECMOD)) Q:ECMOD'>0 S ECMODS=ECMODS_$P(^(ECMOD,0),U)_";" - ...S ECXPDIV=$$RADDIV^ECXDEPT(ECXDIV) ;p-46 - ...D FILE - Q - ; -FILE ;file record - ;node0 - ;rad div^dfn^ssn^name^in/out (ECXA)^day^cpt code^procedure^img loc^ward^ - ;ser^diag code^req physician^modifiers^mov #^treat spec^time^ - ;imaging type^primary care team^primary care provider - ;node1 - ;mpi^dss dept^placeholder^placeholder^pc prov person class^ - ;assoc pc provider^assoc pc prov person class^placeholder^dom^ - ;observ pat ind^encounter num^ord stop code^ord date^division^ - ;dss product ECXDSSP^requesting provider person class ECDOCPC^interp- - ;reting radiologist ECXIS^interpreting radiologist pc ECXISPC^princi- - ;pal clinic ECXPRCL^clinc stop code ECXCSC^emergency response indicator - ;(FEMA) ECXERI^assoc pc provider npi^interpreting rad npi^pc provider npi^req physician npi - N DA,DIK - S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 - S ECODE=EC7_U_EC23_U_ECXDIV_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U - S ECODE=ECODE_ECXDAY_U_ECXCPT_U_ECPRO_U_ECLOC_U_ECXW_U_ECS_U_ECDI_U - S ECODE=ECODE_ECDOC_U_ECMODS_U_ECXMN_U_ECXTS_U_ECTM_U_ECTY_U_ECPTTM_U - S ECODE=ECODE_ECPTPR_U - S ECODE1=ECXMPI_U_ECXDSSD_U_U_U_ECCLAS_U_ECASPR_U - S ECODE1=ECODE1_ECCLAS2_U_U_ECXDOM_U_ECXOBS_U_ECXENC_U_ECXORDST_U - S ECODE1=ECODE1_ECXORDDT_U_ECXPDIV_U - I ECXLOGIC>2004 S ECODE1=ECODE1_ECXDSSP_U_ECDOCPC - I ECXLOGIC>2005 S ECODE1=ECODE1_U_ECXIS_U_ECXISPC_U_ECXPRCL_U_ECXCSC - I ECXLOGIC>2006 S ECODE1=ECODE1_U_ECXERI - I ECXLOGIC>2007 S ECODE1=ECODE1_U_ECASNPI_U_ECISNPI_U_ECPTNPI_U_ECDOCNPI - S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1 - S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA - I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 - Q - ; -SETUP ;Set required input for ECXTRAC - S ECHEAD="RAD" - D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) - Q +ECXRAD ;ALB/JAP,BIR/PDW,PTD-Extract for Radiology ; 6/23/06 6:52am + ;;3.0;DSS EXTRACTS;**11,8,13,16,24,33,39,46,71,84,92**;Dec 22, 1997;Build 30 +BEG ;entry point from option + D SETUP I ECFILE="" Q + D ^ECXTRAC,^ECXKILL + Q + ; +START ;start rad extract + S QFLG=0 + K ECXDD D FIELD^DID(70.03,14,,"SPECIFIER","ECXDD") S ECPROF=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD + S ECXDFN="",ECDT=ECSD-.1,ECED1=ECED+.3 + F S ECDT=$O(^RADPT("AR",ECDT)) Q:ECDT>ECED1!(ECDT'>0) D Q:QFLG + .S ECXDFN="" + .F S ECXDFN=$O(^RADPT("AR",ECDT,ECXDFN)) Q:ECXDFN="" I '$D(^TMP("ECL",$J,ECXDFN)) D GET Q:QFLG + K ^TMP("ECL",$J) + Q + ; +GET ;get data + N ECXIEN,X,SUB,TYPE,ECDOCPC,ECXIS,ECXISPC,ECXPRCL,ECXCSC + S ^TMP("ECL",$J,ECXDFN)="" + ;with dfn get all exams within date range + S ECXMDT=ECSD-.1 + F S ECXMDT=$O(^RADPT(ECXDFN,"DT","B",ECXMDT)) Q:((ECXMDT>ECED1)!(ECXMDT="")) D Q:QFLG + .S ECXMDA=$O(^RADPT(ECXDFN,"DT","B",ECXMDT,"")) Q:ECXMDA="" + .S ECXIEN=+$P($G(^RADPT(ECXDFN,"DT",ECXMDA,"P",1,0)),U,11) + .S ECTM=$$ECXTIME^ECXUTL(ECXMDT) S:ECTM>235959 ECTM=235959 + .S ECXDAY=$$ECXDATE^ECXUTL(ECXMDT,ECXYM) + .K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECXMDT,"."),"1;3",.ECXPAT) + .Q:'OK + .S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI") + .;get emergency response indicator (FEMA) + .S ECXERI=ECXPAT("ERI") + .S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXMDT,"."),ECPROF) + .S ECPTTM=$P(X,U,1),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4) + .S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7) + .S X=$$INP^ECXUTL2(ECXDFN,ECXMDT),ECXA=$P(X,U),ECXMN=$P(X,U,2) + .S ECXTS=$P(X,U,3),ECXDOM=$P(X,U,10),ECXADMDT=$P(X,U,4) + .; + .;- Observation patient indicator (YES/NO) + .S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) + .;for dfn & date get exam(s) ien + .S ECXMDA="" + .F S ECXMDA=$O(^RADPT(ECXDFN,"DT","B",ECXMDT,ECXMDA)) Q:+ECXMDA=0 D + ..S ECXDIV=$P(^RADPT(ECXDFN,"DT",ECXMDA,0),U,3),ECLOC=$P(^(0),U,4),ECTY=$P(^(0),U,2) + ..; + ..;- Ordering stop code (based on imaging location) + ..S ECXORDST=$$GET1^DIQ(40.7,$$GET1^DIQ(79.1,$G(ECLOC),22,"I"),1) + ..; + ..;- Get ordering date using Imaging Order ptr to #75.1 in subfile 70.03 + ..S ECXIEN=+$P($G(^RADPT(ECXDFN,"DT",ECXMDA,"P",1,0)),U,11) + ..S ECXORDDT=$$ECXDATE^ECXUTL($P($G(^RAO(75.1,ECXIEN,0)),U,16),ECXYM) + ..; + ..;- If no encounter number don't file record + ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXMDT,ECXTS,ECXOBS,ECHEAD,ECTY,) Q:ECXENC="" + ..;procedures and modifiers for specific exam (case numbers) + ..;ward/clinic,service,provider,diagnostic code + ..S ECCN=0 + ..F S ECCN=$O(^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN)) Q:ECCN'>0 D + ...S ECCA=^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,0) + ...S ECXW=$P(ECCA,U,6),ECXW=$P($G(^DIC(42,+ECXW,44)),U) + ...S:ECXW="" ECXW=$P(ECCA,U,8) + ...S (ECXDSSD,ECXDSSP)="" + ...S ECS=$P(ECCA,U,7),ECDOC=ECPROF_$P(ECCA,U,14),ECDOCNPI="",ECDI=$P(ECCA,U,13),ECDOCPC=$$PRVCLASS^ECXUTL($P(ECCA,U,14),ECDT) + ...S ECPRO=$P(ECCA,U,2),ECSTAT=$P($G(^RA(72,+$P(ECCA,U,3),0)),U,3) + ...;get the primary interpreting staff and the person class DBIA #65 + ...S ECXIS=$P(ECCA,U,15),ECXISPC=$$PRVCLASS^ECXUTL(ECXIS,ECDT) + ...;prefix interpreting radiologist with a "2" if not null + ...S ECXIS=$S(ECXIS:"2"_ECXIS,1:"") + ...;get the principal clinic ien DBIA #65 + ...S ECXPRCL=$P(ECCA,U,8) + ...;get the clinic stop code from file #44 + ...S ECXCSC=$$GET1^DIQ(40.7,$$GET1^DIQ(44,ECXPRCL,8,"I"),1) + ...Q:'ECPRO + ...Q:+ECSTAT=0 + ...;get CPT code & modifiers + ...S ECPT=+$P($G(^RAMIS(71,+ECPRO,0)),U,9),ECXCMOD="" + ...;quit if this is a 'parent' procedure + ...S TYPE=$P($G(^RAMIS(71,+ECPRO,0)),U,6) + ...Q:((ECPT=0)&(TYPE="P")) + ...;if site is using radiology with cpt modifiers then get them + ...K ARR,ERR D FIELD^DID(70.03,135,,"LABEL","ARR","ERR") + ...I $D(ARR("LABEL")) D + ....K ARR,ERR D FIELD^DID(70.03,135,,"GLOBAL SUBSCRIPT LOCATION","ARR","ERR") + ....Q:$D(ERR("DIERR")) + ....S SUB=$P(ARR("GLOBAL SUBSCRIPT LOCATION"),";") S ECMOD=0 + ....Q:'$D(^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,SUB)) + ....F S ECMOD=$O(^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,SUB,ECMOD)) Q:ECMOD'>0 S ECXCMOD=ECXCMOD_$P(^(ECMOD,0),U)_";" + ...S ECXCPT=$$CPT^ECXUTL3(ECPT,ECXCMOD) + ...;get procedure radiology modifiers + ...S ECMOD=0,ECMODS="" + ...F S ECMOD=$O(^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,"M",ECMOD)) Q:ECMOD'>0 S ECMODS=ECMODS_$P(^(ECMOD,0),U)_";" + ...S ECXPDIV=$$RADDIV^ECXDEPT(ECXDIV) ;p-46 + ...D FILE + Q + ; +FILE ;file record + ;node0 + ;rad div^dfn^ssn^name^in/out (ECXA)^day^cpt code^procedure^img loc^ward^ + ;ser^diag code^req physician^modifiers^mov #^treat spec^time^ + ;imaging type^primary care team^primary care provider + ;node1 + ;mpi^dss dept^req physician npi^pc provider npi^pc prov person class^ + ;assoc pc provider^assoc pc prov person class^assoc pc prov npi^dom^ + ;observ pat ind^encounter num^ord stop code^ord date^division^ + ;dss product ECXDSSP^requesting provider person class ECDOCPC^interp- + ;reting radiologist ECXIS^interpreting radiologist pc ECXISPC^princi- + ;pal clinic ECXPRCL^clinc stop code ECXCSC^emergency response indicator + ;(FEMA) ECXERI + N DA,DIK + S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 + S ECODE=EC7_U_EC23_U_ECXDIV_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U + S ECODE=ECODE_ECXDAY_U_ECXCPT_U_ECPRO_U_ECLOC_U_ECXW_U_ECS_U_ECDI_U + S ECODE=ECODE_ECDOC_U_ECMODS_U_ECXMN_U_ECXTS_U_ECTM_U_ECTY_U_ECPTTM_U + S ECODE=ECODE_ECPTPR_U + S ECODE1=ECXMPI_U_ECXDSSD_U_ECDOCNPI_U_ECPTNPI_U_ECCLAS_U_ECASPR_U + S ECODE1=ECODE1_ECCLAS2_U_ECASNPI_U_ECXDOM_U_ECXOBS_U_ECXENC_U_ECXORDST_U + S ECODE1=ECODE1_ECXORDDT_U_ECXPDIV_U + I ECXLOGIC>2004 S ECODE1=ECODE1_ECXDSSP_U_ECDOCPC + I ECXLOGIC>2005 S ECODE1=ECODE1_U_ECXIS_U_ECXISPC_U_ECXPRCL_U_ECXCSC + I ECXLOGIC>2006 S ECODE1=ECODE1_U_ECXERI + S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1 + S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA + I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 + Q + ; +SETUP ;Set required input for ECXTRAC + S ECHEAD="RAD" + D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) + Q diff --git a/r/DSS_EXTRACTS-ECX/ECXSCLD.m b/r/DSS_EXTRACTS-ECX/ECXSCLD.m index bf570ecc..b05c1050 100644 --- a/r/DSS_EXTRACTS-ECX/ECXSCLD.m +++ b/r/DSS_EXTRACTS-ECX/ECXSCLD.m @@ -1,103 +1,103 @@ -ECXSCLD ;BIR/DMA,CML-Enter, Print and Edit Entries in 728.44 ; 5/24/07 3:49pm - ;;3.0;DSS EXTRACTS;**2,8,24,30,71,80,105**;Dec 22, 1997;Build 70 -EN ;entry point from option - ;load entries - W !!,"This option creates local entries in the DSS CLINIC AND STOP CODES file.",! - I '$D(^ECX(728.44)) W !,"DSS Clinic stop code file does not exist",!! R X:5 K X Q - K ZTSAVE S ZTDESC="Gather Clinic stop codes for DSS",ZTRTN="START^ECXSCLD",ZTIO="" D ^%ZTLOAD - Q -START ; entry point - S EC=0,ECNT=0 F S EC=$O(^SC(EC)) Q:'EC I $D(^(EC,0)) S ECD=^(0),DAT=$G(^("I")) I $P(ECD,U,3)="C" D FIX - K DIK S DIK="^ECX(728.44,",DIK(1)=".01^B" D ENALL^DIK - ;S $P(^ECX(728.44,0),U,3,4)=ECL_U_ECNT - K ZTDESC,EC,J,ECD,ECD2,ECL,ECS,ECS2,ECP - S ZTREQ="@" Q - ; -FIX ; get stop codes and default style for feeder key - ; 1 if no credit stop code - 5 if credit stop code exists - K ECD2,ECS2 I $D(^ECX(728.44,EC,0)) S ECD2=^(0) F ECS=2,3 S ECS2(ECS)=$P(ECD2,U,ECS) - S ID=+DAT,RD=$P(DAT,U,2) - I $D(ECD2) D - .I ID,ID'>DT I 'RD!(RD>DT) S:$P(ECD2,U,10)'=ID $P(ECD2,U,7)="" S $P(ECD2,U,10)=ID - .I ID,RD,RD'>DT S:$P(ECD2,U,10) $P(ECD2,U,7)="" S $P(ECD2,U,10)="" - .I ID,ID>DT S:$P(ECD2,U,10) $P(ECD2,U,7)="" S $P(ECD2,U,10)="" - .I 'ID,$P(ECD2,U,10) S $P(ECD2,U,7)="",$P(ECD2,U,10)="" - F ECS=7,18 S ECP=+$P(ECD,U,ECS),ECS(ECS)=$P($G(^DIC(40.7,ECP,0)),U,2) - S ECDF=$S(ECS(18)]"":5,1:1) S:$P(ECD,U,17)="Y" ECDF=6 S:$G(^SC(EC,"OOS")) ECDF=6 - S ECL=EC,ECD=EC_U_ECS(7)_U_ECS(18) - I '$D(ECD2) D - .S $P(^ECX(728.44,EC,0),U,1,5)=ECD_U_ECS(7)_U_ECS(18),ECNT=ECNT+1,$P(^(0),U,6)=ECDF - I $D(ECD2) D - .S $P(ECD2,U,1,3)=ECD - .I +ECS(7)'=+ECS2(2)!(+ECS(18)'=+ECS2(3)) S $P(ECD2,U,7)="" - .S ^ECX(728.44,EC,0)=ECD2 - Q - ; -PRINT ; print worksheet for updates - I '$O(^ECX(728.44,0)) W !,"DSS Clinic stop code file does not exist",!! R X:5 K X Q - W !!,"This option produces a worksheet of (A)ll DSS Clinic Stops or only the",!,"(U)nreviewed Clinic Stops that are awaiting approval. Clinics that were" - W !,"defined as ""inactive"" by MAS the last time the option ""Create DSS Clinic",!,"Stop Code File"" was run will be indicated with an ""*"".",! - S DIR(0)="S^A:ALL;U:UNREVIEWED",DIR("A")="Enter ""A"" or ""U""",DIR("?",1)="Enter: ""A"" to print a worksheet of all DSS Clinic Stops,",DIR("?")=" ""U"" to print only the Clinic Stops that have not been approved." - D ^DIR K DIR G END:$D(DIRUT) S ECALL=$E(Y) - S %ZIS="Q" D ^%ZIS Q:POP - I $D(IO("Q")) K ZTSAVE S ZTDESC="DSS clinic stop code work sheet",ZTRTN="SPRINT^ECXSCLD",ZTSAVE("ECALL")="" D ^%ZTLOAD,HOME^%ZIS Q - U IO -SPRINT ; queued entry to print work sheet - S QFLG=0,$P(LN,"-",81)="",PG=0 - S ECDATE=$O(^ECX(728.44,"A1","")) I ECDATE S ECDATE=-ECDATE,ECDATE=$$FMTE^XLFDT(ECDATE,"5DF"),ECDATE=$TR(ECDATE," ","0") - K ^TMP("EC",$J) F J=0:0 S J=$O(^ECX(728.44,J)) Q:'J I $D(^ECX(728.44,J,0)),$S(ECALL="A":1,1:$P(^(0),U,7)="") S ECSD=^(0) I $D(^SC(J,0)) S ECSC=$P(^(0),U),^TMP("EC",$J,ECSC)=$P(ECSD,U,2,200) - D HEAD S ECSC="" I $O(^TMP("EC",$J,ECSC))="" W !!,"NO DATA FOUND FOR WORKSHEET.",! G END - F J=1:1 S ECSC=$O(^TMP("EC",$J,ECSC)) Q:ECSC="" S ECD=^(ECSC) D SHOWEM Q:QFLG - I $E(IOST)="C",'QFLG D SS - K ^TMP("EC",$J),J,ECSC,ECSD,ECDATE,QFLG,PG,LN,SS - W:$Y @IOF D ^%ZISC S ZTREQ="@" - Q - ; -HEAD ; header for worksheet - D SS Q:QFLG - S PG=PG+1 W:$Y!($E(IOST)="C") @IOF W !,"WORKSHEET FOR DSS CLINIC STOPS",?71,"Page: ",PG - I ECDATE]"" W !,"(last reviewed on ",ECDATE,")" - E W !,"(NEVER REVIEWED)" - W ! - W !!,?1,"CLINIC",?31,"STOP",?38,"CREDIT",?47,"DSS",?54,"DSS",?63,"ACTION",?71,"NAT'L" - W !,?31,"CODE",?38,"STOP",?47,"STOP",?54,"CREDIT",?71,"CODE",!,?1,"(* - currently inactive)",?38,"CODE",?47,"CODE",?54,"CODE",!,LN Q - ; -SHOWEM ; list clinics for worksheet - I $Y+4>IOSL D HEAD Q:QFLG - W !!,$E(ECSC,1,31) W:$P(ECD,U,9)]"" "*" F J=1:1:5 W ?$P("31,38,47,54,66",",",J),$S($P(ECD,U,J):$P(ECD,U,J),J<3:"",1:"_____") - S ECN=$P($G(^ECX(728.441,+$P(ECD,U,7),0)),U) W ?71,$S(ECN]"":ECN,1:"____") - Q -SS ;SCROLL STOPS - I $E(IOST)="C" S SS=22-$Y F JJ=1:1:SS W ! - I $E(IOST)="C",PG>0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q - Q - ; -EDIT ; put in DSS stopcodes and which one to send - I '$O(^ECX(728.44,0)) W !,"DSS Clinic stop code file does not exist",!! R X:5 K X Q - W ! S DIC=728.44,DIC(0)="QEAMZ" D ^DIC G END:Y<0 W !,"STOP CODE : ",$P(Y(0),U,2),!,"CREDIT STOP CODE : ",$P(Y(0),U,3) - S DIE=DIC,DA=+Y,DR="3;4;5//1;S:X'=4 Y=6;7;6///"_DT_";8" D ^DIE S:$P(^ECX(728.44,DA,0),U,6)'=4 $P(^(0),U,8)="" S $P(^(0),U,7)="" K DIC,DIE,DA G EDIT - ; -APPROVE ; approve current DSS Stop and Credit Stop codes - W !!,"This option allows you to mark the current clinic entries in the CLINICS AND",!,"STOP CODES file (#728.44) as ""reviewed"". Those entries will then be omitted" - W !,"from the list printed from the ""Clinic and DSS Stop Codes Print"" when you",!,"choose to print only ""unreviewed"" clinics.",! - K DIR S DIR(0)="Y",DIR("A",1)="Are you ready to approve the reviewed information provided by the",DIR("A")="""Clinic and DSS Stop Codes Print""",DIR("B")="NO" - S DIR("?",1)=" Enter:" - S DIR("?",2)=" ""YES"" if you concur with the ""Clinic and DSS Stop Codes Print""," - S DIR("?",3)=" ""NO"" or if you do not want to approve the current information," - S DIR("?")=" ""^"" to exit option." - D ^DIR K DIR I 'Y!($D(DIRUT)) G END - W ! S ZTRTN="APPLOOP^ECXSCLD",ZTIO="",ZTDESC="Approve DSS stop codes for clinic extract" D ^%ZTLOAD W !!,"...approval queued" G END - ; -APPLOOP ; queued entry to approve action codes - F EC=0:0 S EC=$O(^ECX(728.44,EC)) Q:'EC I $D(^(EC,0)) S DA=EC,DIE="^ECX(728.44,",DR="6///"_DT D ^DIE - S ZTREQ="@" G END -END K X,Y,DA,DR,DIC,DIE,QFLG,PG,LN - Q - ; -LOOK ;queued entry to check for new clinics - S ECD=$E(DT,1,5)-1-($E(DT,4,5)="01"*8800),ECD0=ECD_"00",ECXMISS=10,ECGRP="SCX" K ^TMP("ECXS",$J) - F EC=0:0 S EC=$O(^SC(EC)) Q:'EC I $D(^(EC,0)),$P(^(0),U,3)="C",'$D(^ECX(728.44,EC)) S DAT=$G(^SC(EC,"I")) D - .S ID=+DAT,RD=$P(DAT,U,2) I ID,ID
DT) Q - .S ^TMP("ECXS",$J,ECXMISS,0)=$J(EC,6)_" "_$$LJ^XLFSTR($P(^SC(EC,0),U),40),ECXMISS=ECXMISS+1 - D ^ECXSCX1 - Q +ECXSCLD ;BIR/DMA,CML-Enter, Print and Edit Entries in 728.44 ; 9/21/04 7:33am + ;;3.0;DSS EXTRACTS;**2,8,24,30,71,80**;Dec 22, 1997 +EN ;entry point from option + ;load entries + W !!,"This option creates local entries in the DSS CLINIC AND STOP CODES file.",! + I '$D(^ECX(728.44)) W !,"DSS Clinic stop code file does not exist",!! R X:5 K X Q + K ZTSAVE S ZTDESC="Gather Clinic stop codes for DSS",ZTRTN="START^ECXSCLD",ZTIO="" D ^%ZTLOAD + Q +START ; entry point + S EC=0,ECNT=0 F S EC=$O(^SC(EC)) Q:'EC I $D(^(EC,0)) S ECD=^(0),DAT=$G(^("I")) I $P(ECD,U,3)="C" D FIX + K DIK S DIK="^ECX(728.44,",DIK(1)=".01^B" D ENALL^DIK + ;S $P(^ECX(728.44,0),U,3,4)=ECL_U_ECNT + K ZTDESC,EC,J,ECD,ECD2,ECL,ECS,ECS2,ECP + S ZTREQ="@" Q + ; +FIX ; get stop codes and default style for feeder key + ; 1 if no credit stop code - 5 if credit stop code exists + K ECD2,ECS2 I $D(^ECX(728.44,EC,0)) S ECD2=^(0) F ECS=2,3 S ECS2(ECS)=$P(ECD2,U,ECS) + S ID=+DAT,RD=$P(DAT,U,2) + I $D(ECD2) D + .I ID,ID'>DT I 'RD!(RD>DT) S:$P(ECD2,U,10)'=ID $P(ECD2,U,7)="" S $P(ECD2,U,10)=ID + .I ID,RD,RD'>DT S:$P(ECD2,U,10) $P(ECD2,U,7)="" S $P(ECD2,U,10)="" + .I ID,ID>DT S:$P(ECD2,U,10) $P(ECD2,U,7)="" S $P(ECD2,U,10)="" + .I 'ID,$P(ECD2,U,10) S $P(ECD2,U,7)="",$P(ECD2,U,10)="" + F ECS=7,18 S ECP=+$P(ECD,U,ECS),ECS(ECS)=$P($G(^DIC(40.7,ECP,0)),U,2) + S ECDF=$S(ECS(18)]"":5,1:1) S:$P(ECD,U,17)="Y" ECDF=6 S:$G(^SC(EC,"OOS")) ECDF=6 + S ECL=EC,ECD=EC_U_ECS(7)_U_ECS(18) + I '$D(ECD2) D + .S $P(^ECX(728.44,EC,0),U,1,5)=ECD_U_ECS(7)_U_ECS(18),ECNT=ECNT+1,$P(^(0),U,6)=ECDF + I $D(ECD2) D + .S $P(ECD2,U,1,3)=ECD + .I +ECS(7)'=+ECS2(2)!(+ECS(18)'=+ECS2(3)) S $P(ECD2,U,7)="" + .S ^ECX(728.44,EC,0)=ECD2 + Q + ; +PRINT ; print worksheet for updates + I '$O(^ECX(728.44,0)) W !,"DSS Clinic stop code file does not exist",!! R X:5 K X Q + W !!,"This option produces a worksheet of (A)ll DSS Clinic Stops or only the",!,"(U)nreviewed Clinic Stops that are awaiting approval. Clinics that were" + W !,"defined as ""inactive"" by MAS the last time the option ""Create DSS Clinic",!,"Stop Code File"" was run will be indicated with an ""*"".",! + S DIR(0)="S^A:ALL;U:UNREVIEWED",DIR("A")="Enter ""A"" or ""U""",DIR("?",1)="Enter: ""A"" to print a worksheet of all DSS Clinic Stops,",DIR("?")=" ""U"" to print only the Clinic Stops that have not been approved." + D ^DIR K DIR G END:$D(DIRUT) S ECALL=$E(Y) + S %ZIS="Q" D ^%ZIS Q:POP + I $D(IO("Q")) K ZTSAVE S ZTDESC="DSS clinic stop code work sheet",ZTRTN="SPRINT^ECXSCLD",ZTSAVE("ECALL")="" D ^%ZTLOAD,HOME^%ZIS Q + U IO +SPRINT ; queued entry to print work sheet + S QFLG=0,$P(LN,"-",81)="",PG=0 + S ECDATE=$O(^ECX(728.44,"A1","")) I ECDATE S ECDATE=-ECDATE,ECDATE=$$FMTE^XLFDT(ECDATE,"5DF"),ECDATE=$TR(ECDATE," ","0") + K ^TMP("EC",$J) F J=0:0 S J=$O(^ECX(728.44,J)) Q:'J I $D(^ECX(728.44,J,0)),$S(ECALL="A":1,1:$P(^(0),U,7)="") S ECSD=^(0) I $D(^SC(J,0)) S ECSC=$P(^(0),U),^TMP("EC",$J,ECSC)=$P(ECSD,U,2,200) + D HEAD S ECSC="" I $O(^TMP("EC",$J,ECSC))="" W !!,"NO DATA FOUND FOR WORKSHEET.",! G END + F J=1:1 S ECSC=$O(^TMP("EC",$J,ECSC)) Q:ECSC="" S ECD=^(ECSC) D SHOWEM Q:QFLG + I $E(IOST)="C",'QFLG D SS + K ^TMP("EC",$J),J,ECSC,ECSD,ECDATE,QFLG,PG,LN,SS + W:$Y @IOF D ^%ZISC S ZTREQ="@" + Q + ; +HEAD ; header for worksheet + D SS Q:QFLG + S PG=PG+1 W:$Y!($E(IOST)="C") @IOF W !,"WORKSHEET FOR DSS CLINIC STOPS",?71,"Page: ",PG + I ECDATE]"" W !,"(last reviewed on ",ECDATE,")" + E W !,"(NEVER REVIEWED)" + W ! + W !!,?1,"CLINIC",?27,"STOP",?34,"CREDIT",?43,"DSS",?50,"DSS",?59,"ACTION",?67,"NAT'L",?74,"DSS" + W !,?27,"CODE",?34,"STOP",?43,"STOP",?50,"CREDIT",?67,"CODE",?74,"DEPT",!,?1,"(* - currently inactive)",?34,"CODE",?43,"CODE",?50,"CODE",!,LN Q + ; +SHOWEM ; list clinics for worksheet + I $Y+4>IOSL D HEAD Q:QFLG + W !!,$E(ECSC,1,25) W:$P(ECD,U,9)]"" "*" F J=1:1:5 W ?$P("27,34,43,50,62",",",J),$S($P(ECD,U,J):$P(ECD,U,J),J<3:"",1:"_____") + S ECN=$P($G(^ECX(728.441,+$P(ECD,U,7),0)),U) W ?67,$S(ECN]"":ECN,1:"____"),?74,$S($P(ECD,U,10)'="":$P(ECD,U,10),1:"___") + Q +SS ;SCROLL STOPS + I $E(IOST)="C" S SS=22-$Y F JJ=1:1:SS W ! + I $E(IOST)="C",PG>0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q + Q + ; +EDIT ; put in DSS stopcodes and which one to send + I '$O(^ECX(728.44,0)) W !,"DSS Clinic stop code file does not exist",!! R X:5 K X Q + W ! S DIC=728.44,DIC(0)="QEAMZ" D ^DIC G END:Y<0 W !,"STOP CODE : ",$P(Y(0),U,2),!,"CREDIT STOP CODE : ",$P(Y(0),U,3) + S DIE=DIC,DA=+Y,DR="3;4;5//1;S:X'=4 Y=6;7;6///"_DT_";8" D ^DIE S:$P(^ECX(728.44,DA,0),U,6)'=4 $P(^(0),U,8)="" S $P(^(0),U,7)="" K DIC,DIE,DA G EDIT + ; +APPROVE ; approve current DSS Stop and Credit Stop codes + W !!,"This option allows you to mark the current clinic entries in the CLINICS AND",!,"STOP CODES file (#728.44) as ""reviewed"". Those entries will then be omitted" + W !,"from the list printed from the ""Clinic and DSS Stop Codes Print"" when you",!,"choose to print only ""unreviewed"" clinics.",! + K DIR S DIR(0)="Y",DIR("A",1)="Are you ready to approve the reviewed information provided by the",DIR("A")="""Clinic and DSS Stop Codes Print""",DIR("B")="NO" + S DIR("?",1)=" Enter:" + S DIR("?",2)=" ""YES"" if you concur with the ""Clinic and DSS Stop Codes Print""," + S DIR("?",3)=" ""NO"" or if you do not want to approve the current information," + S DIR("?")=" ""^"" to exit option." + D ^DIR K DIR I 'Y!($D(DIRUT)) G END + W ! S ZTRTN="APPLOOP^ECXSCLD",ZTIO="",ZTDESC="Approve DSS stop codes for clinic extract" D ^%ZTLOAD W !!,"...approval queued" G END + ; +APPLOOP ; queued entry to approve action codes + F EC=0:0 S EC=$O(^ECX(728.44,EC)) Q:'EC I $D(^(EC,0)) S DA=EC,DIE="^ECX(728.44,",DR="6///"_DT D ^DIE + S ZTREQ="@" G END +END K X,Y,DA,DR,DIC,DIE,QFLG,PG,LN + Q + ; +LOOK ;queued entry to check for new clinics + S ECD=$E(DT,1,5)-1-($E(DT,4,5)="01"*8800),ECD0=ECD_"00",ECXMISS=10,ECGRP="SCX" K ^TMP("ECXS",$J) + F EC=0:0 S EC=$O(^SC(EC)) Q:'EC I $D(^(EC,0)),$P(^(0),U,3)="C",'$D(^ECX(728.44,EC)) S DAT=$G(^SC(EC,"I")) D + .S ID=+DAT,RD=$P(DAT,U,2) I ID,ID
DT) Q + .S ^TMP("ECXS",$J,ECXMISS,0)=$J(EC,6)_" "_$$LJ^XLFSTR($P(^SC(EC,0),U),40),ECXMISS=ECXMISS+1 + D ^ECXSCX1 + Q diff --git a/r/DSS_EXTRACTS-ECX/ECXSCX1.m b/r/DSS_EXTRACTS-ECX/ECXSCX1.m index 15d78676..4ad5fdfc 100644 --- a/r/DSS_EXTRACTS-ECX/ECXSCX1.m +++ b/r/DSS_EXTRACTS-ECX/ECXSCX1.m @@ -1,211 +1,212 @@ -ECXSCX1 ;ALB/JAP,BIR/DMA-Clinic Extract Message ; 4/11/07 3:26pm - ;;3.0;DSS EXTRACTS;**8,28,24,27,29,30,31,33,84,92,105**;Dec 22, 1997;Build 70 -EN ;entry point from ecxscx - N ECX - ;send missing clinic message - S ECX=$O(^TMP($J,"ECXS","MISS",0)) D - .Q:ECX="" - .S XMSUB="MISSING CLINICS in File #728.44",XMDUZ="DSS SYSTEM" - .K XMY S XMY("G.DSS-"_ECGRP_"@"_^XMB("NETNAME"))="" - .F ECX=1:1:5 S ^TMP($J,"ECXS","MISS",ECX,0)=$P($T(MSG+ECX),";;",2) - .S XMTEXT="^TMP($J,""ECXS"",""MISS""," D ^XMD - ;send no division message - S ECX=$O(^TMP($J,"ECXS","DIV",0)) D - .Q:ECX="" - .S XMSUB="CLINICS w/o DIVISION Data",XMDUZ="DSS SYSTEM" - .K XMY S XMY("G.DSS-"_ECGRP_"@"_^XMB("NETNAME"))="" - .F ECX=1:1:5 S ^TMP($J,"ECXS","DIV",ECX,0)=$P($T(MSG2+ECX),";;",2) - .S XMTEXT="^TMP($J,""ECXS"",""DIV""," D ^XMD - ;cleanup - K ^TMP($J,"ECXS") - Q -MSG ;text for missing clinic - ;;The following clinics have not been entered into the CLINIC AND - ;;STOP CODES file (#728.44). If any listed clinic is currently - ;;active, please use the options 'Create DSS Clinic Stop Code File' - ;;and 'Enter/Edit DSS Stop Codes for Clinics' to update this file. - ;; - ; -MSG2 ;text for missing division - ;;The following clinics in the HOSPITAL LOCATION file (#44) have not - ;;been assigned to a division from the MEDICAL CENTER DIVISION file - ;;(#40.8). CLI extract records associated with these clinics have - ;;been given a default Division identifier of "1". - ;; - ; -MISS ;load ^tmp if clinic missing from #728.44 - N DAT,ID,RD - S (ID,RD)="" - S DAT=$G(^SC(SC,"I")) I DAT]"" S ID=+DAT,RD=$P(DAT,U,2) - ;ignore inactive clinics - I ID,ID
DT) Q - I '$D(^TMP($J,"ECXS","ECXMISS")) S ^TMP($J,"ECXS","ECXMISS")=10 - S ECXMISS=^TMP($J,"ECXS","ECXMISS") - S ^TMP($J,"ECXS","MISS",ECXMISS,0)=$J(SC,6)_" "_$$LJ^XLFSTR($P(^SC(SC,0),U),40)_ECSC_"/"_ECCSC - S ^TMP($J,"ECXS","ECXMISS")=ECXMISS+1 - Q - ; -NODIV ;load ^tmp if clinic w/o division - N DAT,ID,RD - S (ID,RD)="" - S DAT=$G(^SC(SC,"I")) I DAT]"" S ID=+DAT,RD=$P(DAT,U,2) - ;ignore inactive clinics - I ID,ID
DT) Q - I '$D(^TMP($J,"ECXS","ECXMISS")) S ^TMP($J,"ECXS","ECXMISS")=10 - S ECXMISS=^TMP($J,"ECXS","ECXMISS") - S ^TMP($J,"ECXS","DIV",ECXMISS,0)=$J(SC,6)_" "_$$LJ^XLFSTR($P(^SC(SC,0),U),40) - S ^TMP($J,"ECXS","ECXMISS")=ECXMISS+1 - Q - ; -FEEDER(ECXSC,ECXSD,ECXP1,ECXP2,ECXP3,ECXSEND,ECXDIV) ;get transmission style and feeder key variables - ;feeder key = primary stop code_secondary stop code_length of appointment_national clinic code_noshow indicator - ; input - ; ECXSC = ien of clinic in file #44 (required) - ; ECXSD = start date of extract date range (required) - ; ECXP1,ECXP2,ECXP3,ECXSEND passed by reference (required) - ; output (passed-by-reference variables) - ; ECXP1 = primary stop code - ; ECXP2 = secondary stop code - ; ECXP3 = field #7 of file #728.44 - ; ECXSEND = field #5 of file #728.44 - ; ECXDIV = field #3.5 of file #44 - N ECSC,ECCSC,ECSD1,ECXNC,ECXMISS,CLIN,SC - S (ECXP1,ECXP2)="000",ECXP3="0000" - S ECXSEND=1,ECXDIV=0 - Q:+ECXSC=0 - ;get needed data from ^tmp - I $D(^TMP($J,"ECXS","SC",ECXSC)) D - .S CLIN=^TMP($J,"ECXS","SC",ECXSC) - .S ECXP1=$P(CLIN,U),ECXP2=$P(CLIN,U,2),ECXP3=$P(CLIN,U,3),ECXSEND=$P(CLIN,U,4),ECXDIV=$P(CLIN,U,5) - .S ECXDIV=+$P($G(^TMP($J,"ECXCL",ECXSC)),U,4) S:ECXDIV=0 ECXDIV=1 - ;otherwise, set needed data in ^tmp - I '$D(^TMP($J,"ECXS","SC",ECXSC)) D - .;get division or send no division msg - .S ECXDIV=+$P($G(^TMP($J,"ECXCL",ECXSC)),U,4) - .I ECXDIV=0 S SC=ECXSC D NODIV S ECXDIV=1 - .;get other data from file #44 if no #727.44 record; send missing clinic msg - .I '$D(^ECX(728.44,ECXSC,0)) D - ..S ECSC=+$P($G(^SC(ECXSC,0)),U,7),ECCSC=+$P(^(0),U,18) - ..S SC=ECXSC,ECSD1=ECXSD D MISS - ..S:ECSC ECXP1=$P($G(^DIC(40.7,ECSC,0)),U,2),ECXP1=$$RJ^XLFSTR(+ECXP1,3,0) - .;otherwise get other data from file #728.44 - .S EC=$G(^ECX(728.44,ECXSC,0)) D - ..Q:EC="" - ..S ECXSEND=$P(EC,U,6) - ..Q:ECXSEND=6 - ..S ECSC=+$P(EC,U,4),ECCSC=+$P(EC,U,5) - ..I 'ECSC S ECSC=+$P(EC,U,2),ECCSC=+$P(EC,U,3) - ..I ECSC S ECXP1=$$RJ^XLFSTR(ECSC,3,0),ECXP2=$$RJ^XLFSTR(ECCSC,3,0) - ..;if primary stop not valid, use file #44 record - ..I 'ECSC S ECSC=+$P($G(^SC(ECXSC,0)),U,7),ECCSC=+$P($G(^(0)),U,18) I ECSC D - ...S ECXP1=+$P($G(^DIC(40.7,ECSC,0)),U,2) - ...S:ECCSC ECXP2=+$P($G(^DIC(40.7,ECCSC,0)),U,2) - ...S ECXP1=$$RJ^XLFSTR(ECXP1,3,0),ECXP2=$$RJ^XLFSTR(ECXP2,3,0) - .;for action code=1, secondary stop code is always "000" - .I ECXSEND=1 S ECXP2="000" - .;action code of 2 or 3 should not be used, but continue to follow v2t11 logic - .I ECXSEND=2 S ECXP1=ECXP2,ECXP2="000" - .;for action code=4, need to get national clinic code - .I ECXSEND=4 D - ..S ECXNC=+$P($G(^ECX(728.44,ECXSC,0)),U,8) - ..I ECXNC S ECXNC=$P($G(^ECX(728.441,ECXNC,0)),U),ECXP3=$$RJ^XLFSTR(ECXNC,4,0) - .;set data in ^tmp - .S ^TMP($J,"ECXS","SC",ECXSC)=ECXP1_U_ECXP2_U_ECXP3_U_ECXSEND - Q - ; -VISIT(ECXDFN,ECXVISIT,ECXVIST,ECXERR) ;get visit specific data - ;input ECXVISIT = pointer to file #9000010 - ; ECXSVC = sc percentage - ;output ECXVSIT = data array - ; ECXERR = 1 indicates error; otherwise, 0 - N AO,ARRAY,CM,CNT,CPT,DA,DATE,DA,DIQ,ICD,ICD9,IR,LEN,M,MOD,MST,NUM - N PROV,PROVPC,REC,VAL,VISIT,X,Y,PGE - S ECXERR=0,VISIT=ECXVISIT - S (ECXVIST("AO"),ECXVIST("IR"),ECXVIST("PGE"),ECXVIST("HNC"))="" - S (ECXVIST("MST"),ECXVIST("PROV"),ECXVIST("PROV CLASS"))="" - S (ECXVIST("PROV NPI"),ECXVIST("SOURCE"))="" - F I="P",1,2,3,4 S ECXVIST("ICD9"_I)="" - F I=1:1:8 S ECXVIST("CPT"_I)="" - D ENCEVENT^PXAPI(VISIT) - I $O(^TMP("PXKENC",$J,VISIT,""))']"" K ECXVIST S ECXERR=1 - Q:ECXERR - S DATE=$P($P(^TMP("PXKENC",$J,VISIT,"VST",VISIT,0),U,1),".",1) - S ECXVIST("SOURCE")=$P($G(^TMP("PXKENC",$J,VISIT,"VST",VISIT,812)),U,3) - ;get icd9 codes upto 5; else use 799.9 - K ARY S ICD("P")=0,ICD("S")=0,(ARY,REC)="" - F S REC=$O(^TMP("PXKENC",$J,VISIT,"POV",REC)) Q:REC="" D - .S VAL=^TMP("PXKENC",$J,VISIT,"POV",REC,0) Q:'VAL - .I $P(VAL,U,12)="P" D - ..S:'$D(ARY("P",+VAL)) CNT=ICD("P")+1,ICD("P",CNT)=+VAL,ICD("P")=CNT - ..S ARY("P",+VAL)="" - .I $P(VAL,U,12)'="P" D - ..S:'$D(ARY("S",+VAL)) CNT=ICD("S")+1,ICD("S",CNT)=+VAL,ICD("S")=CNT - ..S ARY("S",+VAL)="" - S CNT=0,ECXVIST("ICD9P")=$P($G(^ICD9(+$G(ICD("P",1),0),0)),U) - F I=2:1 Q:'$D(ICD("P",I)) D Q:CNT>4 - .S CNT=CNT+1,ECXVIST("ICD9"_CNT)=$P($G(^ICD9(ICD("P",I),0)),U) - I CNT<4 F I=1:1:8 Q:'$D(ICD("S",I)) D Q:CNT>4 - .I '$D(ARY("P",ICD("S",I))) D - ..S CNT=CNT+1,ECXVIST("ICD9"_CNT)=$P($G(^ICD9(ICD("S",I),0)),U) - ;get first provider designated as primary - ;if no primary, then get first physician provider - ;if no physician, then get first provider - S (PROV,PROVPC)="" - I $O(^TMP("PXKENC",$J,VISIT,"PRV",0)) D - .S (REC,VAL)=0 D - ..F S REC=$O(^TMP("PXKENC",$J,VISIT,"PRV",REC)) Q:('REC)!(VAL) D - ...S:($P(^(REC,0),U,4)="P") VAL=+^(0) - ...S PROV=VAL,PROVPC=$$PRVCLASS^ECXUTL(PROV,DATE) - .I 'VAL S (REC,VAL)=0 D - ..F S REC=$O(^TMP("PXKENC",$J,VISIT,"PRV",REC)) Q:('REC)!(VAL) D - ...S (PROV,VAL)=+^(REC,0) - ...S PROVPC=$$PRVCLASS^ECXUTL(PROV,DATE) Q:PROVPC="" - ...S NUM=$E(PROVPC,2,7) S:(NUM<110000)!(NUM>119999) VAL=0,PROVPC="" - .I 'VAL D - ..S REC=$O(^TMP("PXKENC",$J,VISIT,"PRV",0)) Q:('REC)!(VAL) - ..S VAL=+^(REC,0),PROV=VAL,PROVPC=$$PRVCLASS^ECXUTL(PROV,DATE) - .S:PROV]"" PROV="2"_PROV - S ECXVIST("PROV")=PROV,ECXVIST("PROV CLASS")=PROVPC - S ECXVIST("PROV NPI")="" - ;get cpt codes upto 8 & modifiers upto 5 - S CNT=1,PROV=$E(PROV,2,99) - D:$O(^TMP("PXKENC",$J,VISIT,"CPT",0)) - .S REC=0 D:PROV]"" - ..F S REC=$O(^TMP("PXKENC",$J,VISIT,"CPT",REC)) Q:'REC D Q:CNT>8 - ...S CPT="",NODE=$G(^TMP("PXKENC",$J,VISIT,"CPT",REC,12)) - ...Q:NODE="" - ...S NOD1=$S($P(NODE,U,4)=PROV:^TMP("PXKENC",$J,VISIT,"CPT",REC,0),1:"") - ...Q:$P(NOD1,U)="" - ...S Q="00"_+$P(NOD1,U,16),Q=$S(+Q:$E(Q,$L(Q)-1,$L(Q)),1:"01") - ...S CPT=$P(NOD1,U),M=0,MOD="" - ...F I=1:1:5 S M=$O(^TMP("PXKENC",$J,VISIT,"CPT",REC,1,M)) Q:'M D - ....S MOD=MOD_$S(MOD'="":";",1:"") - ....S MOD=MOD_$P(^TMP("PXKENC",$J,VISIT,"CPT",REC,1,M,0),U) - ...S ECXVIST("CPT"_CNT)=$$CPT^ECXUTL3(CPT,MOD,Q),CNT=CNT+1 - ...K ^TMP("PXKENC",$J,VISIT,"CPT",REC) - ..Q:CNT>8 - .Q:CNT>8 S REC=0 - .F S REC=$O(^TMP("PXKENC",$J,VISIT,"CPT",REC)) Q:'REC D Q:CNT>8 - ..S CPT="",NOD1=$G(^TMP("PXKENC",$J,VISIT,"CPT",REC,0)) - ..Q:$P(NOD1,U)="" - ..S Q="00"_+$P(NOD1,U,16),Q=$S(+Q:$E(Q,$L(Q)-1,$L(Q)),1:"01") - ..S CPT=$P(NOD1,U),M=0,MOD="" - ..F I=1:1:5 S M=$O(^TMP("PXKENC",$J,VISIT,"CPT",REC,1,M)) Q:'M D - ...S MOD=MOD_$S(MOD'="":";",1:"") - ...S MOD=MOD_$P(^TMP("PXKENC",$J,VISIT,"CPT",REC,1,M,0),U) - ..S ECXVIST("CPT"_CNT)=$$CPT^ECXUTL3(CPT,MOD,Q),CNT=CNT+1 - ..K ^TMP("PXKENC",$J,VISIT,"CPT",REC) - ..Q:CNT>8 - S:ECXVIST("CPT1")="" ECXVIST("CPT1")=9919901 - ;ao, ir, mst, pge, hnc - S (AO,IR,MST,PGE,HNC)="" - I $D(^TMP("PXKENC",$J,VISIT,"VST",VISIT,800)) D - .S AO=$P(^TMP("PXKENC",$J,VISIT,"VST",VISIT,800),U,2) - .S IR=$P(^TMP("PXKENC",$J,VISIT,"VST",VISIT,800),U,3),MST=$P(^(800),U,5) - .S PGE=$P(^TMP("PXKENC",$J,VISIT,"VST",VISIT,800),U,4),HNC=$P(^(800),U,6) - .S ECXVIST("AO")=$S(AO=0:"N",AO=1:"Y",1:"") - .S ECXVIST("IR")=$S(IR=0:"N",IR=1:"Y",1:"") - .S ECXVIST("MST")=$S(MST=0:"N",MST=1:"Y",1:"") - .S ECXVIST("PGE")=$S(PGE=0:"N",PGE=1:"Y",1:"") - .S ECXVIST("HNC")=$S(HNC=0:"N",HNC=1:"Y",1:"") - Q +ECXSCX1 ;ALB/JAP,BIR/DMA-Clinic Extract Message ; 8/17/06 7:59am + ;;3.0;DSS EXTRACTS;**8,28,24,27,29,30,31,33,84,92**;Dec 22, 1997;Build 30 +EN ;entry point from ecxscx + N ECX + ;send missing clinic message + S ECX=$O(^TMP($J,"ECXS","MISS",0)) D + .Q:ECX="" + .S XMSUB="MISSING CLINICS in File #728.44",XMDUZ="DSS SYSTEM" + .K XMY S XMY("G.DSS-"_ECGRP_"@"_^XMB("NETNAME"))="" + .F ECX=1:1:5 S ^TMP($J,"ECXS","MISS",ECX,0)=$P($T(MSG+ECX),";;",2) + .S XMTEXT="^TMP($J,""ECXS"",""MISS""," D ^XMD + ;send no division message + S ECX=$O(^TMP($J,"ECXS","DIV",0)) D + .Q:ECX="" + .S XMSUB="CLINICS w/o DIVISION Data",XMDUZ="DSS SYSTEM" + .K XMY S XMY("G.DSS-"_ECGRP_"@"_^XMB("NETNAME"))="" + .F ECX=1:1:5 S ^TMP($J,"ECXS","DIV",ECX,0)=$P($T(MSG2+ECX),";;",2) + .S XMTEXT="^TMP($J,""ECXS"",""DIV""," D ^XMD + ;cleanup + K ^TMP($J,"ECXS") + Q +MSG ;text for missing clinic + ;;The following clinics have not been entered into the CLINIC AND + ;;STOP CODES file (#728.44). If any listed clinic is currently + ;;active, please use the options 'Create DSS Clinic Stop Code File' + ;;and 'Enter/Edit DSS Stop Codes for Clinics' to update this file. + ;; + ; +MSG2 ;text for missing division + ;;The following clinics in the HOSPITAL LOCATION file (#44) have not + ;;been assigned to a division from the MEDICAL CENTER DIVISION file + ;;(#40.8). CLI extract records associated with these clinics have + ;;been given a default Division identifier of "1". + ;; + ; +MISS ;load ^tmp if clinic missing from #728.44 + N DAT,ID,RD + S (ID,RD)="" + S DAT=$G(^SC(SC,"I")) I DAT]"" S ID=+DAT,RD=$P(DAT,U,2) + ;ignore inactive clinics + I ID,ID
DT) Q + I '$D(^TMP($J,"ECXS","ECXMISS")) S ^TMP($J,"ECXS","ECXMISS")=10 + S ECXMISS=^TMP($J,"ECXS","ECXMISS") + S ^TMP($J,"ECXS","MISS",ECXMISS,0)=$J(SC,6)_" "_$$LJ^XLFSTR($P(^SC(SC,0),U),40)_ECSC_"/"_ECCSC + S ^TMP($J,"ECXS","ECXMISS")=ECXMISS+1 + Q + ; +NODIV ;load ^tmp if clinic w/o division + N DAT,ID,RD + S (ID,RD)="" + S DAT=$G(^SC(SC,"I")) I DAT]"" S ID=+DAT,RD=$P(DAT,U,2) + ;ignore inactive clinics + I ID,ID
DT) Q + I '$D(^TMP($J,"ECXS","ECXMISS")) S ^TMP($J,"ECXS","ECXMISS")=10 + S ECXMISS=^TMP($J,"ECXS","ECXMISS") + S ^TMP($J,"ECXS","DIV",ECXMISS,0)=$J(SC,6)_" "_$$LJ^XLFSTR($P(^SC(SC,0),U),40) + S ^TMP($J,"ECXS","ECXMISS")=ECXMISS+1 + Q + ; +FEEDER(ECXSC,ECXSD,ECXP1,ECXP2,ECXP3,ECXSEND,ECXDIV) ;get transmission style and feeder key variables + ;feeder key = primary stop code_secondary stop code_length of appointment_national clinic code_noshow indicator + ; input + ; ECXSC = ien of clinic in file #44 (required) + ; ECXSD = start date of extract date range (required) + ; ECXP1,ECXP2,ECXP3,ECXSEND passed by reference (required) + ; output (passed-by-reference variables) + ; ECXP1 = primary stop code + ; ECXP2 = secondary stop code + ; ECXP3 = field #7 of file #728.44 + ; ECXSEND = field #5 of file #728.44 + ; ECXDIV = field #3.5 of file #44 + N ECSC,ECCSC,ECSD1,ECXNC,ECXMISS,CLIN,SC + S (ECXP1,ECXP2)="000",ECXP3="0000" + S ECXSEND=1,ECXDIV=0 + Q:+ECXSC=0 + ;get needed data from ^tmp + I $D(^TMP($J,"ECXS","SC",ECXSC)) D + .S CLIN=^TMP($J,"ECXS","SC",ECXSC) + .S ECXP1=$P(CLIN,U),ECXP2=$P(CLIN,U,2),ECXP3=$P(CLIN,U,3),ECXSEND=$P(CLIN,U,4),ECXDIV=$P(CLIN,U,5) + .S ECXDIV=+$P($G(^TMP($J,"ECXCL",ECXSC)),U,4) S:ECXDIV=0 ECXDIV=1 + ;otherwise, set needed data in ^tmp + I '$D(^TMP($J,"ECXS","SC",ECXSC)) D + .;get division or send no division msg + .S ECXDIV=+$P($G(^TMP($J,"ECXCL",ECXSC)),U,4) + .I ECXDIV=0 S SC=ECXSC D NODIV S ECXDIV=1 + .;get other data from file #44 if no #727.44 record; send missing clinic msg + .I '$D(^ECX(728.44,ECXSC,0)) D + ..S ECSC=+$P($G(^SC(ECXSC,0)),U,7),ECCSC=+$P(^(0),U,18) + ..S SC=ECXSC,ECSD1=ECXSD D MISS + ..S:ECSC ECXP1=$P($G(^DIC(40.7,ECSC,0)),U,2),ECXP1=$$RJ^XLFSTR(+ECXP1,3,0) + .;otherwise get other data from file #728.44 + .S EC=$G(^ECX(728.44,ECXSC,0)) D + ..Q:EC="" + ..S ECXSEND=$P(EC,U,6) + ..Q:ECXSEND=6 + ..S ECSC=+$P(EC,U,4),ECCSC=+$P(EC,U,5) + ..I 'ECSC S ECSC=+$P(EC,U,2),ECCSC=+$P(EC,U,3) + ..I ECSC S ECXP1=$$RJ^XLFSTR(ECSC,3,0),ECXP2=$$RJ^XLFSTR(ECCSC,3,0) + ..;if primary stop not valid, use file #44 record + ..I 'ECSC S ECSC=+$P($G(^SC(ECXSC,0)),U,7),ECCSC=+$P($G(^(0)),U,18) I ECSC D + ...S ECXP1=+$P($G(^DIC(40.7,ECSC,0)),U,2) + ...S:ECCSC ECXP2=+$P($G(^DIC(40.7,ECCSC,0)),U,2) + ...S ECXP1=$$RJ^XLFSTR(ECXP1,3,0),ECXP2=$$RJ^XLFSTR(ECXP2,3,0) + .;for action code=1, secondary stop code is always "000" + .I ECXSEND=1 S ECXP2="000" + .;action code of 2 or 3 should not be used, but continue to follow v2t11 logic + .I ECXSEND=2 S ECXP1=ECXP2,ECXP2="000" + .;for action code=4, need to get national clinic code + .I ECXSEND=4 D + ..S ECXNC=+$P($G(^ECX(728.44,ECXSC,0)),U,8) + ..I ECXNC S ECXNC=$P($G(^ECX(728.441,ECXNC,0)),U),ECXP3=$$RJ^XLFSTR(ECXNC,4,0) + .;set data in ^tmp + .S ^TMP($J,"ECXS","SC",ECXSC)=ECXP1_U_ECXP2_U_ECXP3_U_ECXSEND + Q + ; +VISIT(ECXDFN,ECXVISIT,ECXVIST,ECXERR) ;get visit specific data + ;input ECXVISIT = pointer to file #9000010 + ; ECXSVC = sc percentage + ;output ECXVSIT = data array + ; ECXERR = 1 indicates error; otherwise, 0 + N AO,ARRAY,CM,CNT,CPT,DA,DATE,DA,DIQ,ICD,ICD9,IR,LEN,M,MOD,MST,NUM + N PROV,PROVPC,REC,VAL,VISIT,X,Y,PGE + S ECXERR=0,VISIT=ECXVISIT + S (ECXVIST("AO"),ECXVIST("IR"),ECXVIST("PGE"),ECXVIST("HNC"))="" + S (ECXVIST("MST"),ECXVIST("PROV"),ECXVIST("PROV CLASS"))="" + S (ECXVIST("PROV NPI"),ECXVIST("SOURCE"))="" + F I="P",1,2,3,4 S ECXVIST("ICD9"_I)="" + F I=1:1:8 S ECXVIST("CPT"_I)="" + D ENCEVENT^PXAPI(VISIT) + I $O(^TMP("PXKENC",$J,VISIT,""))']"" K ECXVIST S ECXERR=1 + Q:ECXERR + S DATE=$P($P(^TMP("PXKENC",$J,VISIT,"VST",VISIT,0),U,1),".",1) + S ECXVIST("SOURCE")=$P($G(^TMP("PXKENC",$J,VISIT,"VST",VISIT,812)),U,3) + ;get icd9 codes upto 5; else use 799.9 + K ARY S ICD("P")=0,ICD("S")=0,(ARY,REC)="" + F S REC=$O(^TMP("PXKENC",$J,VISIT,"POV",REC)) Q:REC="" D + .S VAL=^TMP("PXKENC",$J,VISIT,"POV",REC,0) Q:'VAL + .I $P(VAL,U,12)="P" D + ..S:'$D(ARY("P",+VAL)) CNT=ICD("P")+1,ICD("P",CNT)=+VAL,ICD("P")=CNT + ..S ARY("P",+VAL)="" + .I $P(VAL,U,12)'="P" D + ..S:'$D(ARY("S",+VAL)) CNT=ICD("S")+1,ICD("S",CNT)=+VAL,ICD("S")=CNT + ..S ARY("S",+VAL)="" + S CNT=0,ECXVIST("ICD9P")=$P($G(^ICD9(+$G(ICD("P",1),0),0)),U) + F I=2:1 Q:'$D(ICD("P",I)) D Q:CNT>4 + .S CNT=CNT+1,ECXVIST("ICD9"_CNT)=$P($G(^ICD9(ICD("P",I),0)),U) + I CNT<4 F I=1:1:8 Q:'$D(ICD("S",I)) D Q:CNT>4 + .I '$D(ARY("P",ICD("S",I))) D + ..S CNT=CNT+1,ECXVIST("ICD9"_CNT)=$P($G(^ICD9(ICD("S",I),0)),U) + S:(ECXVIST("ICD9P")="")&(ECXVIST("ICD91")="") ECXVIST("ICD9P")="799.9" + ;get first provider designated as primary + ;if no primary, then get first physician provider + ;if no physician, then get first provider + S (PROV,PROVPC)="" + I $O(^TMP("PXKENC",$J,VISIT,"PRV",0)) D + .S (REC,VAL)=0 D + ..F S REC=$O(^TMP("PXKENC",$J,VISIT,"PRV",REC)) Q:('REC)!(VAL) D + ...S:($P(^(REC,0),U,4)="P") VAL=+^(0) + ...S PROV=VAL,PROVPC=$$PRVCLASS^ECXUTL(PROV,DATE) + .I 'VAL S (REC,VAL)=0 D + ..F S REC=$O(^TMP("PXKENC",$J,VISIT,"PRV",REC)) Q:('REC)!(VAL) D + ...S (PROV,VAL)=+^(REC,0) + ...S PROVPC=$$PRVCLASS^ECXUTL(PROV,DATE) Q:PROVPC="" + ...S NUM=$E(PROVPC,2,7) S:(NUM<110000)!(NUM>119999) VAL=0,PROVPC="" + .I 'VAL D + ..S REC=$O(^TMP("PXKENC",$J,VISIT,"PRV",0)) Q:('REC)!(VAL) + ..S VAL=+^(REC,0),PROV=VAL,PROVPC=$$PRVCLASS^ECXUTL(PROV,DATE) + .S:PROV]"" PROV="2"_PROV + S ECXVIST("PROV")=PROV,ECXVIST("PROV CLASS")=PROVPC + S ECXVIST("PROV NPI")="" + ;get cpt codes upto 8 & modifiers upto 5 + S CNT=1,PROV=$E(PROV,2,99) + D:$O(^TMP("PXKENC",$J,VISIT,"CPT",0)) + .S REC=0 D:PROV]"" + ..F S REC=$O(^TMP("PXKENC",$J,VISIT,"CPT",REC)) Q:'REC D Q:CNT>8 + ...S CPT="",NODE=$G(^TMP("PXKENC",$J,VISIT,"CPT",REC,12)) + ...Q:NODE="" + ...S NOD1=$S($P(NODE,U,4)=PROV:^TMP("PXKENC",$J,VISIT,"CPT",REC,0),1:"") + ...Q:$P(NOD1,U)="" + ...S Q="00"_+$P(NOD1,U,16),Q=$S(+Q:$E(Q,$L(Q)-1,$L(Q)),1:"01") + ...S CPT=$P(NOD1,U),M=0,MOD="" + ...F I=1:1:5 S M=$O(^TMP("PXKENC",$J,VISIT,"CPT",REC,1,M)) Q:'M D + ....S MOD=MOD_$S(MOD'="":";",1:"") + ....S MOD=MOD_$P(^TMP("PXKENC",$J,VISIT,"CPT",REC,1,M,0),U) + ...S ECXVIST("CPT"_CNT)=$$CPT^ECXUTL3(CPT,MOD,Q),CNT=CNT+1 + ...K ^TMP("PXKENC",$J,VISIT,"CPT",REC) + ..Q:CNT>8 + .Q:CNT>8 S REC=0 + .F S REC=$O(^TMP("PXKENC",$J,VISIT,"CPT",REC)) Q:'REC D Q:CNT>8 + ..S CPT="",NOD1=$G(^TMP("PXKENC",$J,VISIT,"CPT",REC,0)) + ..Q:$P(NOD1,U)="" + ..S Q="00"_+$P(NOD1,U,16),Q=$S(+Q:$E(Q,$L(Q)-1,$L(Q)),1:"01") + ..S CPT=$P(NOD1,U),M=0,MOD="" + ..F I=1:1:5 S M=$O(^TMP("PXKENC",$J,VISIT,"CPT",REC,1,M)) Q:'M D + ...S MOD=MOD_$S(MOD'="":";",1:"") + ...S MOD=MOD_$P(^TMP("PXKENC",$J,VISIT,"CPT",REC,1,M,0),U) + ..S ECXVIST("CPT"_CNT)=$$CPT^ECXUTL3(CPT,MOD,Q),CNT=CNT+1 + ..K ^TMP("PXKENC",$J,VISIT,"CPT",REC) + ..Q:CNT>8 + S:ECXVIST("CPT1")="" ECXVIST("CPT1")=9919901 + ;ao, ir, mst, pge, hnc + S (AO,IR,MST,PGE,HNC)="" + I $D(^TMP("PXKENC",$J,VISIT,"VST",VISIT,800)) D + .S AO=$P(^TMP("PXKENC",$J,VISIT,"VST",VISIT,800),U,2) + .S IR=$P(^TMP("PXKENC",$J,VISIT,"VST",VISIT,800),U,3),MST=$P(^(800),U,5) + .S PGE=$P(^TMP("PXKENC",$J,VISIT,"VST",VISIT,800),U,4),HNC=$P(^(800),U,6) + .S ECXVIST("AO")=$S(AO=0:"N",AO=1:"Y",1:"") + .S ECXVIST("IR")=$S(IR=0:"N",IR=1:"Y",1:"") + .S ECXVIST("MST")=$S(MST=0:"N",MST=1:"Y",1:"") + .S ECXVIST("PGE")=$S(PGE=0:"N",PGE=1:"Y",1:"") + .S ECXVIST("HNC")=$S(HNC=0:"N",HNC=1:"Y",1:"") + Q diff --git a/r/DSS_EXTRACTS-ECX/ECXSCX2.m b/r/DSS_EXTRACTS-ECX/ECXSCX2.m index d8a63540..fcc74582 100644 --- a/r/DSS_EXTRACTS-ECX/ECXSCX2.m +++ b/r/DSS_EXTRACTS-ECX/ECXSCX2.m @@ -1,71 +1,68 @@ -ECXSCX2 ;ALB/ESD DSS Clinic Extract Utilities (continued) ; 6/5/2007 - ;;3.0;DSS EXTRACTS;**39,46,49,71,84,92,105**;Dec 22, 1997;Build 70 - ; - ; -INTPAT ;initialize patient variables - S (ECXSSN,ECXPNM,ECPTPR,ECCLAS,ECPTNPI,ECASPR,ECCLAS2,ECASNPI,ECXZIP)="" - S (ECPTTM,ECXVET,ECXRACE,ECXENRL,ECXMPI,ECXSEX)="" - S (ECXDOB,ECXELIG,ECXPST,ECXPLOC,ECXRST,ECXAST,ECXMST,ECXSTATE)="" - S (ECXCNTY,ECXATYP,ECXPVST,ECXMTST,ECXEST,ECXECE,ECXHNC)="" - Q - ; -PAT1(ECXDFN,ECXDATE,ECXERR) ;get patient demographic data - N ECXPAT,K,OK,X - S ECXERR=0 - S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECXDATE,"."),"1;2;3;4;5",.ECXPAT) - I 'OK S ECXERR=1 Q - S ECXSSN=ECXPAT("SSN"),ECXPNM=ECXPAT("NAME"),ECXMPI=ECXPAT("MPI") - S ECXSEX=ECXPAT("SEX"),ECXDOB=ECXPAT("DOB"),ECXELIG=ECXPAT("ELIG") - S ECXVET=ECXPAT("VET"),ECXSVC=ECXPAT("SC%"),ECXRACE=ECXPAT("RACE") - S ECXPST=ECXPAT("POW STAT"),ECXPLOC=ECXPAT("POW LOC") - S ECXRST=ECXPAT("IR STAT"),ECXAST=ECXPAT("AO STAT") - S ECXMST=ECXPAT("MST STAT"),ECXSTATE=ECXPAT("STATE") - S ECXCNTY=ECXPAT("COUNTY"),ECXZIP=ECXPAT("ZIP") - S ECXENRL=ECXPAT("ENROLL LOC"),ECXMTST=ECXPAT("MEANS") - ; changes for 2001 - S ECXPOS=ECXPAT("POS"),ECXPHI=ECXPAT("PHI") - ;- Agent Orange location - S ECXAOL=ECXPAT("AOL") - ;OEF/OIF data - S ECXOEF=ECXPAT("ECXOEF") - S ECXOEFDT=ECXPAT("ECXOEFDT") - I $$ENROLLM^ECXUTL2(ECXDFN) - ; - Head and Neck Cancer Indicator - S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) - ; - Race and Ethnicity - S ECXETH=ECXPAT("ETHNIC") - S ECXRC1=ECXPAT("RACE1") - ; - Environmental Contaminants - S ECXEST=ECXPAT("EC STAT") - ;get emergency response indicator (FEMA) - S ECXERI=ECXPAT("ERI") - Q - ; -PAT2(ECXDFN,ECXDATE) ;get date specific patient data - N K,X - ;get primary care data - S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXDATE,".")) - S ECPTTM=$P(X,U),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4) - S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7) - ;get inpatient data - S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECXA=$P(X,U),ECXTS=$P(X,U,3) - S ECXDOM=$P(X,U,10),ECXADMDT=$P(X,U,4) - ;- set national patient record flag if exist - D NPRF^ECXUTL5 - Q - ; -FILE2(ECXFILE,EC7,ECODE) ;file record - N DA,DIK,X S X="" - F S X=$O(ECODE(X)) Q:X="" S ^ECX(ECXFILE,EC7,X)=ECODE(X) - S DA=EC7,DIK="^ECX("_ECXFILE_"," D IX1^DIK K DIK,DA - I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 - Q - ; -CBOC(MDIV) ;Determine whether patient's facility was CBOC - N LOCARR,DIC,DR,DIQ,DA,INST,FTYP - S DIC=40.8,DA=MDIV,DR=".07",DIQ(0)="I",DIQ="LOCARR" D EN^DIQ1 - S INST=$G(LOCARR(40.8,MDIV,.07,"I")) I INST="" Q "" - K LOCARR S DIC=4,DA=INST,DR="13",DIQ(0)="I",DIQ="LOCARR" D EN^DIQ1 - S FTYP=$G(LOCARR(4,INST,13,"I")) I FTYP="" Q "" - K LOCARR S DIC=4.1,DA=FTYP,DR=".01",DIQ(0)="I",DIQ="LOCARR" D EN^DIQ1 - Q $S($G(LOCARR(4.1,FTYP,.01,"I"))="CBOC":"Y",1:"") +ECXSCX2 ;ALB/ESD DSS Clinic Extract Utilities (continued) ; 11/2/06 8:59am + ;;3.0;DSS EXTRACTS;**39,46,49,71,84,92**;Dec 22, 1997;Build 30 + ; + ; +INTPAT ;initialize patient variables + S (ECXSSN,ECXPNM,ECPTPR,ECCLAS,ECPTNPI,ECASPR,ECCLAS2,ECASNPI,ECXZIP)="" + S (ECPTTM,ECXVET,ECXRACE,ECXENRL,ECXMPI,ECXSEX)="" + S (ECXDOB,ECXELIG,ECXPST,ECXPLOC,ECXRST,ECXAST,ECXMST,ECXSTATE)="" + S (ECXCNTY,ECXATYP,ECXPVST,ECXMTST,ECXEST,ECXECE,ECXHNC)="" + Q + ; +PAT1(ECXDFN,ECXDATE,ECXERR) ;get patient demographic data + N ECXPAT,K,OK,X + S ECXERR=0 + S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECXDATE,"."),"1;2;3;4;5",.ECXPAT) + I 'OK S ECXERR=1 Q + S ECXSSN=ECXPAT("SSN"),ECXPNM=ECXPAT("NAME"),ECXMPI=ECXPAT("MPI") + S ECXSEX=ECXPAT("SEX"),ECXDOB=ECXPAT("DOB"),ECXELIG=ECXPAT("ELIG") + S ECXVET=ECXPAT("VET"),ECXSVC=ECXPAT("SC%"),ECXRACE=ECXPAT("RACE") + S ECXPST=ECXPAT("POW STAT"),ECXPLOC=ECXPAT("POW LOC") + S ECXRST=ECXPAT("IR STAT"),ECXAST=ECXPAT("AO STAT") + S ECXMST=ECXPAT("MST STAT"),ECXSTATE=ECXPAT("STATE") + S ECXCNTY=ECXPAT("COUNTY"),ECXZIP=ECXPAT("ZIP") + S ECXENRL=ECXPAT("ENROLL LOC"),ECXMTST=ECXPAT("MEANS") + ; changes for 2001 + S ECXPOS=ECXPAT("POS"),ECXPHI=ECXPAT("PHI") + ;- Agent Orange location + S ECXAOL=ECXPAT("AOL") + I $$ENROLLM^ECXUTL2(ECXDFN) + ; - Head and Neck Cancer Indicator + S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) + ; - Race and Ethnicity + S ECXETH=ECXPAT("ETHNIC") + S ECXRC1=ECXPAT("RACE1") + ; - Environmental Contaminants + S ECXEST=ECXPAT("EC STAT") + ;get emergency response indicator (FEMA) + S ECXERI=ECXPAT("ERI") + Q + ; +PAT2(ECXDFN,ECXDATE) ;get date specific patient data + N K,X + ;get primary care data + S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXDATE,".")) + S ECPTTM=$P(X,U),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4) + S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7) + ;get inpatient data + S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECXA=$P(X,U),ECXTS=$P(X,U,3) + S ECXDOM=$P(X,U,10),ECXADMDT=$P(X,U,4) + ;- set national patient record flag if exist + D NPRF^ECXUTL5 + Q + ; +FILE2(ECXFILE,EC7,ECODE) ;file record + N DA,DIK,X S X="" + F S X=$O(ECODE(X)) Q:X="" S ^ECX(ECXFILE,EC7,X)=ECODE(X) + S DA=EC7,DIK="^ECX("_ECXFILE_"," D IX1^DIK K DIK,DA + I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 + Q + ; +CBOC(MDIV) ;Determine whether patient's facility was CBOC + N LOCARR,DIC,DR,DIQ,DA,INST,FTYP + S DIC=40.8,DA=MDIV,DR=".07",DIQ(0)="I",DIQ="LOCARR" D EN^DIQ1 + S INST=$G(LOCARR(40.8,MDIV,.07,"I")) I INST="" Q "" + K LOCARR S DIC=4,DA=INST,DR="13",DIQ(0)="I",DIQ="LOCARR" D EN^DIQ1 + S FTYP=$G(LOCARR(4,INST,13,"I")) I FTYP="" Q "" + K LOCARR S DIC=4.1,DA=FTYP,DR=".01",DIQ(0)="I",DIQ="LOCARR" D EN^DIQ1 + Q $S($G(LOCARR(4.1,FTYP,.01,"I"))="CBOC":"Y",1:"") diff --git a/r/DSS_EXTRACTS-ECX/ECXSCXN.m b/r/DSS_EXTRACTS-ECX/ECXSCXN.m index dacbe1d2..efbc63b5 100644 --- a/r/DSS_EXTRACTS-ECX/ECXSCXN.m +++ b/r/DSS_EXTRACTS-ECX/ECXSCXN.m @@ -1,160 +1,157 @@ -ECXSCXN ;ALB/JAP Clinic Extract ; 6/5/07 11:55am - ;;3.0;DSS EXTRACTS;**24,27,29,30,31,32,33,39,46,49,52,71,84,92,107,105**;Dec 22, 1997;Build 70 - ; -BEG ;entry point from option - D SETUP Q:ECFILE="" D ^ECXTRAC,^ECXKILL - Q - ; -START ;entry point from taskmgr - N DIC,EXNUM,I,LOCARR,OUT,P1,P2,P3,PROCESS,SOURCE,STOP,STAT,TOSEND - N TIU,X,Y,ECXNPRFI - F I=1:1:8 S @("ECXCPT"_I)="" - F I=1:1:4 S @("ECXICD9"_I)="" - S (OUT,QFLG,ECRN)=0,(ECXICD9P,ECXOBI)="" - K ^TMP($J,"ECXS"),^TMP($J,"ECXCL") - ;get ien for tiu in file #839.7 - S DIC="^PX(839.7,",DIC(0)="X",X="TEXT INTEGRATION UTILITIES" - D ^DIC S TIU=+Y,ECED=ECED+.3,ECXCLIN=0 K DIC,Y - ;get clinic default appt length, type, division - F S ECXCLIN=$O(^SC(ECXCLIN)) Q:'ECXCLIN D - .K LOCARR S DIC=44,DA=ECXCLIN,DR="2;3.5;1912",DIQ(0)="I",DIQ="LOCARR" - .D EN^DIQ1 - .Q:$G(LOCARR(44,ECXCLIN,2,"I"))'="C" - .S ALEN=+$G(LOCARR(44,ECXCLIN,1912,"I")) - .S ^TMP($J,"ECXCL",ECXCLIN)=ALEN,ALEN=$$RJ^XLFSTR(ALEN,3,0) - .S ^TMP($J,"ECXCL",ECXCLIN)=^TMP($J,"ECXCL",ECXCLIN)_"^"_ALEN_"^"_$G(LOCARR(44,ECXCLIN,2,"I"))_"^"_+$G(LOCARR(44,ECXCLIN,3.5,"I")) - .D FEEDER^ECXSCX1(ECXCLIN,ECSD1,.P1,.P2,.P3,.TOSEND,.ECXDIV) - .K P1,P2,P3,TOSEND,ECXDIV - ;get from file #44 any no-shows & get encounters from #409.68 - D NOSHOW^ECXSCXN1(ECSD1,ECED),ENCNTR(ECSD1,ECED) - ;send missing clinic msg - D:$D(^TMP($J,"ECXS")) EN^ECXSCX1 - K ^TMP($J,"ECXS"),^TMP($J,"ECXCL") - Q - ; -ENCNTR(ECSD1,ECED) ;search file #409.68 for encounter data - N CHKOUT,ECD,JJ,K,OUT,PNODE,PP,STAT,STOP,MDIV - S ECD=ECSD1 - F S ECD=$O(^SCE("B",ECD)) Q:('ECD!(ECD>ECED))!(QFLG) S ECXIEN=0 D - .F S ECXIEN=$O(^SCE("B",ECD,ECXIEN)) Q:'ECXIEN D Q:QFLG - ..Q:'$D(^SCE(ECXIEN,0)) - ..D INTPAT^ECXSCX2 K LOCARR S DIC=409.68,DA=ECXIEN - ..S DR=".01;.02;.03;.04;.05;.06;.07;.08;.11;.12;.13",DIQ(0)="I",DIQ="LOCARR" - ..D EN^DIQ1 - ..S ECXTI=$P($$FMTE^XLFDT(+$G(LOCARR(409.68,ECXIEN,.01,"I")),1),"@",2) - ..S ECXTI=$E(($TR(ECXTI,":","")_"000000"),1,6) - ..S:ECXTI="000000" ECXTI="000300" S MDIV=+$G(LOCARR(409.68,ECXIEN,.11,"I")) - ..S STOP=+$G(LOCARR(409.68,ECXIEN,.03,"I")) - ..S CHKOUT=+$G(LOCARR(409.68,ECXIEN,.07,"I")) - ..S PROCESS=+$G(LOCARR(409.68,ECXIEN,.08,"I")) - ..S STAT=$G(LOCARR(409.68,ECXIEN,.12,"I")) - ..S ECXDFN=+$G(LOCARR(409.68,ECXIEN,.02,"I")) - ..Q:(ECXDFN=0)!('CHKOUT) - ..S:STAT="" STAT="ZZ" S STAT=";"_STAT_";" - ..Q:";3;4;5;6;7;9;10;13;"[STAT - ..Q:('STOP)!(PROCESS=4)!(+$G(LOCARR(409.68,ECXIEN,.06,"I"))) - ..S ECXDATE=+$G(LOCARR(409.68,ECXIEN,.01,"I")) - ..S ECXCLIN=+$G(LOCARR(409.68,ECXIEN,.04,"I")) - ..Q:$P($G(^TMP($J,"ECXCL",ECXCLIN)),U,3)'="C" - ..S ECXVISIT=+$G(LOCARR(409.68,ECXIEN,.05,"I")) - ..S ECXENEL=+$G(LOCARR(409.68,ECXIEN,.13,"I")) - ..Q:'ECXVISIT - ..S ECXERR=0 - ..D PAT1^ECXSCX2(ECXDFN,ECXDATE,.ECXERR) Q:ECXERR - ..D FEEDER^ECXSCX1(ECXCLIN,ECSD1,.P1,.P2,.P3,.TOSEND,.ECXDIV) - ..Q:TOSEND=6 - ..K LOCARR S DIC=40.7,DA=STOP,DR="1",DIQ(0)="I",DIQ="LOCARR" D EN^DIQ1 - ..S ECXSTOP=$$RJ^XLFSTR($G(LOCARR(40.7,STOP,1,"I")),3,0) - ..;get date specific patient data - ..D PAT2^ECXSCX2(ECXDFN,ECXDATE) - ..;get national patient record flag if exist - ..D NPRF^ECXUTL5 - ..;get visit specific data - ..S ECXERR=0 D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) Q:ECXERR - ..F I=1:1:8 S @("ECXCPT"_I)=$G(ECXVIST("CPT"_I)) - ..S ECXICD9P=$G(ECXVIST("ICD9P")) - ..F I=1:1:4 S @("ECXICD9"_I)=$G(ECXVIST("ICD9"_I)) - ..S SOURCE=ECXVIST("SOURCE"),ECXAO=ECXVIST("AO"),ECXIR=ECXVIST("IR") - ..S ECXMIL=ECXVIST("MST"),ECXPROV=ECXVIST("PROV") - ..S ECPRNPI=$$NPI^XUSNPI("Individual_ID",ECXPROV,ECXDATE) - ..S:+ECPRNPI'>0 ECPRNPI="" S ECPRNPI=$P(ECPRNPI,U) - ..S ECXPROVP=ECXVIST("PROV CLASS"),ECXPROVN=ECXVIST("PROV NPI") - ..S ECXECE=ECXVIST("PGE"),ECXHNC=ECXVIST("HNC") - ..K LOCARR S DIC=8,DA=ECXENEL,DR="8",DIQ(0)="I",DIQ="LOCARR" D EN^DIQ1 - ..S ECXENEL=+$G(LOCARR(8,ECXENEL,8,"I")) - ..S:ECXENEL ECXENEL=$$ELIG^ECXUTL3(ECXENEL,ECXSVC) - ..S ECXCBOC=$S(MDIV'="":$$CBOC^ECXSCX2(.MDIV),1:"") ;is cboc facility? - ..;setup feeder key and file in extract records - ..S (ECXKEY,ECXDSSD)="" - ..;xray (105) or lab (108) - ..I (ECXSTOP=105)!(ECXSTOP=108) D Q - ...S ECXKEY=ECXSTOP_"00003000000",ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY) - ...S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE ;- Don't file rec if no encounter num - ..;appointments - ..I PROCESS=1 D Q ;get appt length - ...S (ALEN,JJ,OUT)=0 - ...F S JJ=$O(^SC(ECXCLIN,"S",ECXDATE,JJ)) Q:('JJ)!(OUT) S K=0 D - ....F S K=$O(^SC(ECXCLIN,"S",ECXDATE,JJ,K)) Q:('K)!(OUT) D - .....S ECXOBI=$G(^SC(ECXCLIN,"S",ECXDATE,JJ,K,"OB")),PP=$P($G(^SC(ECXCLIN,"S",ECXDATE,JJ,K,0)),U) - .....S:PP=ECXDFN OUT=1,ALEN=$P(^(0),U,2),ALEN=$$RJ^XLFSTR(ALEN,3,0) - .....S:+ALEN=0 ALEN=$P($G(^TMP($J,"ECXCL",ECXCLIN)),U,2) - ....S ECXSTOP=P1 - ....S PNODE=$G(^DPT(ECXDFN,"S",ECXDATE,0)),ECXPVST=$P(PNODE,U,7),ECXATYP=$P(PNODE,U,16) ;Get purpose of visit & appt type - ....I TOSEND'=3 D - .....S ECXKEY=P1_P2_ALEN_P3_"0",ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY) - .....S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE - ....I TOSEND=3 D - .....S ECXKEY=P1_"000"_ALEN_P3_"0",ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY) - .....S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE - ....I TOSEND=3 D - .....S ECXKEY=P2_"000"_ALEN_P3_"0",ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY) - .....S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE - ..I PROCESS=2 D Q - ...S ALEN=0 - ...I SOURCE=TIU S ALEN=$P($G(^TMP($J,"ECXCL",ECXCLIN)),U,2) - ...S:+ALEN=0 ALEN="030" S ECXKEY=P1_P2_ALEN_P3_"0",ECXSTOP=P1 - ...S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY) - ...S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE - ..;dispositions - ..I PROCESS=3 D Q - ...S ECXKEY=ECXSTOP_"47906000000",ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY) - ...S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE - Q - ; -FILE ;record setup for file #727.827 - N STR - S ECXPDIV=$$GETDIV^ECXDEPT(ECXDIV) ; Get production division - S EC7=$O(^ECX(727.827,999999999),-1),EC7=EC7+1 - S STR(0)=EC7_U_EC23_U_ECXDIV_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U - S STR(0)=STR(0)_$$ECXDATE^ECXUTL(ECXDATE,ECXYM)_U_ECXKEY_U_ECXOBI_U - ;convert specialty to PTF Code for transmission - N ECXDATA - S ECXDATA=$$TSDATA^DGACT(42.4,+ECXTS,.ECXDATA) - S ECXTS=$G(ECXDATA(7)) - ;done - S STR(0)=STR(0)_ECXCLIN_U_ECXTS_U_ECXTI_U_ECPTTM_U_ECPTPR_U_ECCLAS_U - S STR(0)=STR(0)_ECXPROV_U_ECXPROVP_U_ECXCPT1_U_ECXCPT2_U_ECXCPT3_U - S STR(0)=STR(0)_ECXCPT4_U_ECXCPT5_U - S STR(1)=ECXCPT6_U_ECXCPT7_U_ECXCPT8_U_ECXICD9P_U_ECXICD91_U_ECXICD92_U - S STR(1)=STR(1)_ECXICD93_U_ECXICD94_U_ECXDOB_U_ECXELIG_U_ECXVET_U - S STR(1)=STR(1)_ECXRACE_U_ECXPST_U_ECXPLOC_U_ECXRST_U_ECXIR_U_ECXAST_U - S STR(1)=STR(1)_ECXAO_U_ECXMPI_U_ECXDSSD_U_ECXSEX_U_ECXZIP_U - S STR(1)=STR(1)_$G(ECXPCPNP)_U_U_ECXENEL_U_ECXMST_U - S STR(1)=STR(1)_ECXMIL_U_U_U_ECXENRL_U_ECXSTATE_U - S STR(1)=STR(1)_ECXCNTY_U_ECASPR_U_ECCLAS2_U_U_ECXDOM_U_ECXCAT_U - S STR(2)=ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPHI_U_ECXPOS_U_ECXOBS_U_ECXENC_U - S STR(2)=STR(2)_ECXAOL_U_ECXPDIV_U_ECXATYP_U_ECXPVST_U_ECXMTST_U - S STR(2)=STR(2)_ECXHNCI_U_ECXETH_U_ECXRC1 - I ECXLOGIC>2003 S STR(2)=STR(2)_U_ECXCBOC - I ECXLOGIC>2004 S STR(2)=STR(2)_U_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI - I ECXLOGIC>2005 S STR(2)=STR(2)_U_ECXEST_U_ECXECE - I ECXLOGIC>2006 S STR(2)=STR(2)_U_ECXERI_U_ECXHNC - I ECXLOGIC>2007 S STR(2)=STR(2)_U_ECXOEF_U_ECXOEFDT_U_ECASNPI_U_ECPTNPI_U_$G(ECPRNPI) - D FILE2^ECXSCX2(727.827,EC7,.STR) - S ECRN=ECRN+1,$P(^ECX(727.827,0),U,3)=EC7 - Q - ; -SETUP ;set required input for ECXTRAC - S ECHEAD="CLI" - D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) - Q +ECXSCXN ;ALB/JAP Clinic Extract ; 4/19/2007 + ;;3.0;DSS EXTRACTS;**24,27,29,30,31,32,33,39,46,49,52,71,84,92,107**;Dec 22, 1997;Build 9 + ; +BEG ;entry point from option + D SETUP Q:ECFILE="" D ^ECXTRAC,^ECXKILL + Q + ; +START ;entry point from taskmgr + N DIC,EXNUM,I,LOCARR,OUT,P1,P2,P3,PROCESS,SOURCE,STOP,STAT,TOSEND + N TIU,X,Y,ECXNPRFI + F I=1:1:8 S @("ECXCPT"_I)="" + F I=1:1:4 S @("ECXICD9"_I)="" + S (OUT,QFLG,ECRN)=0,(ECXICD9P,ECXOBI)="" + K ^TMP($J,"ECXS"),^TMP($J,"ECXCL") + ;get ien for tiu in file #839.7 + S DIC="^PX(839.7,",DIC(0)="X",X="TEXT INTEGRATION UTILITIES" + D ^DIC S TIU=+Y,ECED=ECED+.3,ECXCLIN=0 K DIC,Y + ;get clinic default appt length, type, division + F S ECXCLIN=$O(^SC(ECXCLIN)) Q:'ECXCLIN D + .K LOCARR S DIC=44,DA=ECXCLIN,DR="2;3.5;1912",DIQ(0)="I",DIQ="LOCARR" + .D EN^DIQ1 + .Q:$G(LOCARR(44,ECXCLIN,2,"I"))'="C" + .S ALEN=+$G(LOCARR(44,ECXCLIN,1912,"I")) + .S ^TMP($J,"ECXCL",ECXCLIN)=ALEN,ALEN=$$RJ^XLFSTR(ALEN,3,0) + .S ^TMP($J,"ECXCL",ECXCLIN)=^TMP($J,"ECXCL",ECXCLIN)_"^"_ALEN_"^"_$G(LOCARR(44,ECXCLIN,2,"I"))_"^"_+$G(LOCARR(44,ECXCLIN,3.5,"I")) + .D FEEDER^ECXSCX1(ECXCLIN,ECSD1,.P1,.P2,.P3,.TOSEND,.ECXDIV) + .K P1,P2,P3,TOSEND,ECXDIV + ;get from file #44 any no-shows & get encounters from #409.68 + D NOSHOW^ECXSCXN1(ECSD1,ECED),ENCNTR(ECSD1,ECED) + ;send missing clinic msg + D:$D(^TMP($J,"ECXS")) EN^ECXSCX1 + K ^TMP($J,"ECXS"),^TMP($J,"ECXCL") + Q + ; +ENCNTR(ECSD1,ECED) ;search file #409.68 for encounter data + N CHKOUT,ECD,JJ,K,OUT,PNODE,PP,STAT,STOP,MDIV + S ECD=ECSD1 + F S ECD=$O(^SCE("B",ECD)) Q:('ECD!(ECD>ECED))!(QFLG) S ECXIEN=0 D + .F S ECXIEN=$O(^SCE("B",ECD,ECXIEN)) Q:'ECXIEN D Q:QFLG + ..Q:'$D(^SCE(ECXIEN,0)) + ..D INTPAT^ECXSCX2 K LOCARR S DIC=409.68,DA=ECXIEN + ..S DR=".01;.02;.03;.04;.05;.06;.07;.08;.11;.12;.13",DIQ(0)="I",DIQ="LOCARR" + ..D EN^DIQ1 + ..S ECXTI=$P($$FMTE^XLFDT(+$G(LOCARR(409.68,ECXIEN,.01,"I")),1),"@",2) + ..S ECXTI=$E(($TR(ECXTI,":","")_"000000"),1,6) + ..S:ECXTI="000000" ECXTI="000300" S MDIV=+$G(LOCARR(409.68,ECXIEN,.11,"I")) + ..S STOP=+$G(LOCARR(409.68,ECXIEN,.03,"I")) + ..S CHKOUT=+$G(LOCARR(409.68,ECXIEN,.07,"I")) + ..S PROCESS=+$G(LOCARR(409.68,ECXIEN,.08,"I")) + ..S STAT=$G(LOCARR(409.68,ECXIEN,.12,"I")) + ..S ECXDFN=+$G(LOCARR(409.68,ECXIEN,.02,"I")) + ..Q:(ECXDFN=0)!('CHKOUT) + ..S:STAT="" STAT="ZZ" S STAT=";"_STAT_";" + ..Q:";3;4;5;6;7;9;10;13;"[STAT + ..Q:('STOP)!(PROCESS=4)!(+$G(LOCARR(409.68,ECXIEN,.06,"I"))) + ..S ECXDATE=+$G(LOCARR(409.68,ECXIEN,.01,"I")) + ..S ECXCLIN=+$G(LOCARR(409.68,ECXIEN,.04,"I")) + ..Q:$P($G(^TMP($J,"ECXCL",ECXCLIN)),U,3)'="C" + ..S ECXVISIT=+$G(LOCARR(409.68,ECXIEN,.05,"I")) + ..S ECXENEL=+$G(LOCARR(409.68,ECXIEN,.13,"I")) + ..Q:'ECXVISIT + ..S ECXERR=0 + ..D PAT1^ECXSCX2(ECXDFN,ECXDATE,.ECXERR) Q:ECXERR + ..D FEEDER^ECXSCX1(ECXCLIN,ECSD1,.P1,.P2,.P3,.TOSEND,.ECXDIV) + ..Q:TOSEND=6 + ..K LOCARR S DIC=40.7,DA=STOP,DR="1",DIQ(0)="I",DIQ="LOCARR" D EN^DIQ1 + ..S ECXSTOP=$$RJ^XLFSTR($G(LOCARR(40.7,STOP,1,"I")),3,0) + ..;get date specific patient data + ..D PAT2^ECXSCX2(ECXDFN,ECXDATE) + ..;get national patient record flag if exist + ..D NPRF^ECXUTL5 + ..;get visit specific data + ..S ECXERR=0 D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) Q:ECXERR + ..F I=1:1:8 S @("ECXCPT"_I)=$G(ECXVIST("CPT"_I)) + ..S ECXICD9P=$G(ECXVIST("ICD9P")) + ..F I=1:1:4 S @("ECXICD9"_I)=$G(ECXVIST("ICD9"_I)) + ..S SOURCE=ECXVIST("SOURCE"),ECXAO=ECXVIST("AO"),ECXIR=ECXVIST("IR") + ..S ECXMIL=ECXVIST("MST"),ECXPROV=ECXVIST("PROV") + ..S ECXPROVP=ECXVIST("PROV CLASS"),ECXPROVN=ECXVIST("PROV NPI") + ..S ECXECE=ECXVIST("PGE"),ECXHNC=ECXVIST("HNC") + ..K LOCARR S DIC=8,DA=ECXENEL,DR="8",DIQ(0)="I",DIQ="LOCARR" D EN^DIQ1 + ..S ECXENEL=+$G(LOCARR(8,ECXENEL,8,"I")) + ..S:ECXENEL ECXENEL=$$ELIG^ECXUTL3(ECXENEL,ECXSVC) + ..S ECXCBOC=$S(MDIV'="":$$CBOC^ECXSCX2(.MDIV),1:"") ;is cboc facility? + ..;setup feeder key and file in extract records + ..S (ECXKEY,ECXDSSD)="" + ..;xray (105) or lab (108) + ..I (ECXSTOP=105)!(ECXSTOP=108) D Q + ...S ECXKEY=ECXSTOP_"00003000000",ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY) + ...S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE ;- Don't file rec if no encounter num + ..;appointments + ..I PROCESS=1 D Q ;get appt length + ...S (ALEN,JJ,OUT)=0 + ...F S JJ=$O(^SC(ECXCLIN,"S",ECXDATE,JJ)) Q:('JJ)!(OUT) S K=0 D + ....F S K=$O(^SC(ECXCLIN,"S",ECXDATE,JJ,K)) Q:('K)!(OUT) D + .....S ECXOBI=$G(^SC(ECXCLIN,"S",ECXDATE,JJ,K,"OB")),PP=$P($G(^SC(ECXCLIN,"S",ECXDATE,JJ,K,0)),U) + .....S:PP=ECXDFN OUT=1,ALEN=$P(^(0),U,2),ALEN=$$RJ^XLFSTR(ALEN,3,0) + .....S:+ALEN=0 ALEN=$P($G(^TMP($J,"ECXCL",ECXCLIN)),U,2) + ....S ECXSTOP=P1 + ....S PNODE=$G(^DPT(ECXDFN,"S",ECXDATE,0)),ECXPVST=$P(PNODE,U,7),ECXATYP=$P(PNODE,U,16) ;Get purpose of visit & appt type + ....I TOSEND'=3 D + .....S ECXKEY=P1_P2_ALEN_P3_"0",ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY) + .....S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE + ....I TOSEND=3 D + .....S ECXKEY=P1_"000"_ALEN_P3_"0",ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY) + .....S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE + ....I TOSEND=3 D + .....S ECXKEY=P2_"000"_ALEN_P3_"0",ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY) + .....S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE + ..I PROCESS=2 D Q + ...S ALEN=0 + ...I SOURCE=TIU S ALEN=$P($G(^TMP($J,"ECXCL",ECXCLIN)),U,2) + ...S:+ALEN=0 ALEN="030" S ECXKEY=P1_P2_ALEN_P3_"0",ECXSTOP=P1 + ...S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY) + ...S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE + ..;dispositions + ..I PROCESS=3 D Q + ...S ECXKEY=ECXSTOP_"47906000000",ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY) + ...S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE + Q + ; +FILE ;record setup for file #727.827 + N STR + S ECXPDIV=$$GETDIV^ECXDEPT(ECXDIV) ; Get production division + S EC7=$O(^ECX(727.827,999999999),-1),EC7=EC7+1 + S STR(0)=EC7_U_EC23_U_ECXDIV_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U + S STR(0)=STR(0)_$$ECXDATE^ECXUTL(ECXDATE,ECXYM)_U_ECXKEY_U_ECXOBI_U + ;convert specialty to PTF Code for transmission + N ECXDATA + S ECXDATA=$$TSDATA^DGACT(42.4,+ECXTS,.ECXDATA) + S ECXTS=$G(ECXDATA(7)) + ;done + S STR(0)=STR(0)_ECXCLIN_U_ECXTS_U_ECXTI_U_ECPTTM_U_ECPTPR_U_ECCLAS_U + S STR(0)=STR(0)_ECXPROV_U_ECXPROVP_U_ECXCPT1_U_ECXCPT2_U_ECXCPT3_U + S STR(0)=STR(0)_ECXCPT4_U_ECXCPT5_U + S STR(1)=ECXCPT6_U_ECXCPT7_U_ECXCPT8_U_ECXICD9P_U_ECXICD91_U_ECXICD92_U + S STR(1)=STR(1)_ECXICD93_U_ECXICD94_U_ECXDOB_U_ECXELIG_U_ECXVET_U + S STR(1)=STR(1)_ECXRACE_U_ECXPST_U_ECXPLOC_U_ECXRST_U_ECXIR_U_ECXAST_U + S STR(1)=STR(1)_ECXAO_U_ECXMPI_U_ECXDSSD_U_ECXSEX_U_ECXZIP_U + S STR(1)=STR(1)_$G(ECXPCPNP)_U_$G(ECXNPIPR)_U_ECXENEL_U_ECXMST_U + S STR(1)=STR(1)_ECXMIL_U_U_U_ECXENRL_U_ECXSTATE_U + S STR(1)=STR(1)_ECXCNTY_U_ECASPR_U_ECCLAS2_U_ECASNPI_U_ECXDOM_U_ECXCAT_U + S STR(2)=ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPHI_U_ECXPOS_U_ECXOBS_U_ECXENC_U + S STR(2)=STR(2)_ECXAOL_U_ECXPDIV_U_ECXATYP_U_ECXPVST_U_ECXMTST_U + S STR(2)=STR(2)_ECXHNCI_U_ECXETH_U_ECXRC1 + I ECXLOGIC>2003 S STR(2)=STR(2)_U_ECXCBOC + I ECXLOGIC>2004 S STR(2)=STR(2)_U_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI + I ECXLOGIC>2005 S STR(2)=STR(2)_U_ECXEST_U_ECXECE + I ECXLOGIC>2006 S STR(2)=STR(2)_U_ECXERI_U_ECXHNC + D FILE2^ECXSCX2(727.827,EC7,.STR) + S ECRN=ECRN+1,$P(^ECX(727.827,0),U,3)=EC7 + Q + ; +SETUP ;set required input for ECXTRAC + S ECHEAD="CLI" + D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) + Q diff --git a/r/DSS_EXTRACTS-ECX/ECXSCXN1.m b/r/DSS_EXTRACTS-ECX/ECXSCXN1.m index 0897cafe..67c3de26 100644 --- a/r/DSS_EXTRACTS-ECX/ECXSCXN1.m +++ b/r/DSS_EXTRACTS-ECX/ECXSCXN1.m @@ -1,47 +1,47 @@ -ECXSCXN1 ;ALB/JAP Clinic Extract No Shows; 8/28/02 1:11pm ; 9/6/07 3:17pm - ;;3.0;DSS EXTRACTS;**71,105**;Dec 22, 1997;Build 70 -NOSHOW(ECXSD,ECXED) ;get noshows from file #44 - ; ECXSD = start date, ECXED = end date - N ALEN,CLIN,JDATE,JJ,NODE,NOSHOW,PP,STAT,MDIV - S CLIN=0 - F S CLIN=$O(^TMP($J,"ECXCL",CLIN)) Q:'CLIN D - .Q:$P($G(^TMP($J,"ECXCL",CLIN)),U,3)'="C" - .S (P1,P2,P3)="" - .D FEEDER^ECXSCX1(CLIN,ECXSD,.P1,.P2,.P3,.TOSEND,.ECXDIV) - .Q:TOSEND=6 - .;find appts in date range - .S JDATE=ECXSD,(ALEN,NOSHOW)="" - .F S JDATE=$O(^SC(CLIN,"S",JDATE)) Q:'JDATE Q:JDATE>ECXED D - ..S ECXDATE=JDATE,JJ=0,ECXTI=$P($$FMTE^XLFDT(JDATE,1),"@",2) - ..S ECXTI=$E(($TR(ECXTI,":","")_"000000"),1,6) - ..S:ECXTI="000000" ECXTI="000300" - ..;get noshows only - no data in check-in/check-out node - ..F S JJ=$O(^SC(CLIN,"S",JDATE,JJ)) Q:'JJ D - ...S K=0 - ...F S K=$O(^SC(CLIN,"S",JDATE,JJ,K)) Q:'K D - ....S PP=$G(^SC(CLIN,"S",JDATE,JJ,K,0)),ECXDFN=$P(PP,U) Q:ECXDFN="" - ....S NODE=$G(^DPT(ECXDFN,"S",JDATE,0)),MDIV=$P($G(^SC(CLIN,0)),U,15) - ....Q:(NODE="")!($P(NODE,U)'=CLIN) - ....S ECXOBI=$G(^SC(CLIN,"S",JDATE,JJ,K,"OB")),STAT=$P(NODE,U,2) - ....S NOSHOW=$S(STAT="N":"N",STAT="NA":"N",1:"") - ....Q:NOSHOW="" D INTPAT^ECXSCX2 S ECXERR=0 - ....D PAT1^ECXSCX2(ECXDFN,ECXDATE,.ECXERR) Q:ECXERR - ....S ALEN=$P(PP,U,2),ALEN=$$RJ^XLFSTR(ALEN,3,0) - ....D PAT2^ECXSCX2(ECXDFN,ECXDATE) - ....S ECXPVST=$P(NODE,U,7),ECXATYP=$P(NODE,U,16) ;Get POV & appt type - ....S:+ALEN=0 ALEN=$P($G(^TMP($J,"ECXCL",CLIN)),U,2) - ....S ECXCLIN=CLIN,ECXSTOP=P1 - ....S:ECXCPT1="" ECXCPT1="9919901" - ....S ECXCBOC=$S(MDIV'="":$$CBOC^ECXSCX2(.MDIV),1:"") - ....S (ECXDSSD,ECXENEL,ECXIR,ECXAO,ECXMIL,ECXPROV,ECXPROVP,ECXPROVN)="" - ....I TOSEND'=3 D - .....S ECXKEY=P1_P2_ALEN_P3_NOSHOW,ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY) - .....S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE^ECXSCXN - ....I TOSEND=3 D - .....S ECXKEY=P1_"000"_ALEN_P3_NOSHOW,ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY) - .....S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE^ECXSCXN - ....I TOSEND=3 D - .....S ECXKEY=P2_"000"_ALEN_P3_NOSHOW,ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY) - .....S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE^ECXSCXN - ....;create a record for noshow appended ekg. The code was removed for CTX-0604-70970 CLI Extract Problem EXPANDED to NoShows - Q +ECXSCXN1 ;ALB/JAP Clinic Extract No Shows; 8/28/02 1:11pm ; 10/26/04 10:35am + ;;3.0;DSS EXTRACTS;**71**;Dec 22, 1997 +NOSHOW(ECXSD,ECXED) ;get noshows from file #44 + ; ECXSD = start date, ECXED = end date + N ALEN,CLIN,JDATE,JJ,NODE,NOSHOW,PP,STAT,MDIV + S CLIN=0 + F S CLIN=$O(^TMP($J,"ECXCL",CLIN)) Q:'CLIN D + .Q:$P($G(^TMP($J,"ECXCL",CLIN)),U,3)'="C" + .S (P1,P2,P3)="" + .D FEEDER^ECXSCX1(CLIN,ECXSD,.P1,.P2,.P3,.TOSEND,.ECXDIV) + .Q:TOSEND=6 + .;find appts in date range + .S JDATE=ECXSD,(ALEN,NOSHOW)="" + .F S JDATE=$O(^SC(CLIN,"S",JDATE)) Q:'JDATE Q:JDATE>ECXED D + ..S ECXDATE=JDATE,JJ=0,ECXTI=$P($$FMTE^XLFDT(JDATE,1),"@",2) + ..S ECXTI=$E(($TR(ECXTI,":","")_"000000"),1,6) + ..S:ECXTI="000000" ECXTI="000300" + ..;get noshows only - no data in check-in/check-out node + ..F S JJ=$O(^SC(CLIN,"S",JDATE,JJ)) Q:'JJ D + ...S K=0 + ...F S K=$O(^SC(CLIN,"S",JDATE,JJ,K)) Q:'K D + ....S PP=$G(^SC(CLIN,"S",JDATE,JJ,K,0)),ECXDFN=$P(PP,U) Q:ECXDFN="" + ....S NODE=$G(^DPT(ECXDFN,"S",JDATE,0)),MDIV=$P($G(^SC(CLIN,0)),U,15) + ....Q:(NODE="")!($P(NODE,U)'=CLIN) + ....S ECXOBI=$G(^SC(CLIN,"S",JDATE,JJ,K,"OB")),STAT=$P(NODE,U,2) + ....S NOSHOW=$S(STAT="N":"N",STAT="NA":"N",1:"") + ....Q:NOSHOW="" D INTPAT^ECXSCX2 S ECXERR=0 + ....D PAT1^ECXSCX2(ECXDFN,ECXDATE,.ECXERR) Q:ECXERR + ....S ALEN=$P(PP,U,2),ALEN=$$RJ^XLFSTR(ALEN,3,0) + ....D PAT2^ECXSCX2(ECXDFN,ECXDATE) + ....S ECXPVST=$P(NODE,U,7),ECXATYP=$P(NODE,U,16) ;Get POV & appt type + ....S:+ALEN=0 ALEN=$P($G(^TMP($J,"ECXCL",CLIN)),U,2) + ....S ECXCLIN=CLIN,ECXSTOP=P1 S:ECXICD9P="" ECXICD9P="799.9" + ....S:ECXCPT1="" ECXCPT1="9919901" + ....S ECXCBOC=$S(MDIV'="":$$CBOC^ECXSCX2(.MDIV),1:"") + ....S (ECXDSSD,ECXENEL,ECXIR,ECXAO,ECXMIL,ECXPROV,ECXPROVP,ECXPROVN)="" + ....I TOSEND'=3 D + .....S ECXKEY=P1_P2_ALEN_P3_NOSHOW,ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY) + .....S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE^ECXSCXN + ....I TOSEND=3 D + .....S ECXKEY=P1_"000"_ALEN_P3_NOSHOW,ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY) + .....S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE^ECXSCXN + ....I TOSEND=3 D + .....S ECXKEY=P2_"000"_ALEN_P3_NOSHOW,ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY) + .....S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE^ECXSCXN + ....;create a record for noshow appended ekg. The code was removed for CTX-0604-70970 CLI Extract Problem EXPANDED to NoShows + Q diff --git a/r/DSS_EXTRACTS-ECX/ECXSURG.m b/r/DSS_EXTRACTS-ECX/ECXSURG.m index 03c1b9fd..9a7c6870 100644 --- a/r/DSS_EXTRACTS-ECX/ECXSURG.m +++ b/r/DSS_EXTRACTS-ECX/ECXSURG.m @@ -1,210 +1,237 @@ -ECXSURG ;ALB/JA,BIR/DMA,PTD-Surgery Extract for DSS ; 11/20/07 8:13am - ;;3.0;DSS EXTRACTS;**1,11,8,13,25,24,33,39,41,42,46,50,71,84,92,99,105**;Dec 22, 1997;Build 70 -BEG ;entry point from option - D SETUP I ECFILE="" Q - D ^ECXTRAC,^ECXKILL - Q - ; -START ; - S QFLG=0,ECED=ECED+.3,ECD=ECSD1 - F S ECD=$O(^SRF("AC",ECD)),ECD0=0 Q:('ECD)!(ECD>ECED)!(QFLG) D - .F S ECD0=$O(^SRF("AC",ECD,ECD0)) Q:'ECD0 D - ..I $D(^SRF(ECD0,0)) S EC=^SRF(ECD0,0),ECXDFN=+$P(EC,U),ECXVISIT=$P(EC,U,15) D STUFF Q:QFLG - Q - ; -STUFF ;gather data - N J,X,Y,PP,DATA1,DATA2,DATAOP,ARR,ERR,SUB,MOD,ECXNONL,ECXSTOP,TIMEDIF - N ECPRO,ECXORCT,ECXPTHA,ECXNPRFI,ECXPA,ECXPAPC,ECSRPC,ECATPC,ECSAPC - N ECXCRST,ECXSTCD,ECXCLIN - S ECXDATE=ECD,ECXERR=0,ECXQ="" - Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXDATE,"1;2;3;5;") - I ECXADMDT="" S ECXADD=ECXADMDT - I ECXADMDT'="" S ECXADD=$$ECXDATE^ECXUTL(ECXADMDT,ECXYM) - S OK=$$PAT^ECXUTL3(ECXDFN,ECXDATE,"1;5",.ECXPAT) - I 'OK S ECXERR=1 K ECXPAT Q - ;OEF/OIF DATA - S ECXOEF=ECXPAT("ECXOEF") - S ECXOEFDT=ECXPAT("ECXOEFDT") - S EC0=^SRF(ECD0,0) - S DATA1=$S($D(^SRF(ECD0,.1)):^(.1),1:"") - S DATA2=$S($D(^SRF(ECD0,.2)):^(.2),1:"") - S DATAOP=$S($D(^SRO(136,ECD0,0)):^(0),1:"") - S ECNO=$G(^SRF(ECD0,"NON")) - ;get data - S ECSR=$P(DATA1,U,4),(ECATNPI,ECSANPI,ECSRNPI)="",ECAT=$P(DATA1,U,13) - S ECSRNPI=$$NPI^XUSNPI("Individual_ID",ECSR,ECXDATE) - S:+ECSRNPI'>0 ECSRNPI="" S ECSRNPI=$P(ECSRNPI,U) - ;-Time patient in OR room (Nurse Time) - S ECXTM=$$ECXTIME^ECXUTL($P(DATA2,U,10)) - S ECXDIV=$S($D(^SRF(ECD0,8)):^(8),1:ECINST) - N ECXPDIV S ECXPDIV=$$RADDIV^ECXDEPT(ECXDIV) ;Production Division - S ECSA=$P($G(^SRF(ECD0,.3)),U,4),ECO=$P(EC0,U,2) - S ECSANPI=$$NPI^XUSNPI("Individual_ID",ECSA,ECXDATE) - S:+ECSANPI'>0 ECSANPI="" S ECSANPI=$P(ECSANPI,U) - ;get principle anesthetist and person class DBIA #103 - S ECXPA=$P($G(^SRF(ECD0,.3)),U,1) - S ECPANPI=$$NPI^XUSNPI("Individual_ID",ECXPA,ECXDATE) - S:+ECPANPI'>0 ECPANPI="" S ECPANPI=$P(ECPANPI,U) - S ECXPAPC=$$PRVCLASS^ECXUTL(ECXPA,ECXDATE) - S ECORTY=$P($G(^SRS(+ECO,2)),U),ECO=$P($G(^SRS(+ECO,0)),U) - S ECSS=$P($G(^SRO(137.45,+$P(EC0,U,4),0)),U,2) - S ECSS=$$RJ^XLFSTR($P($G(^DIC(45.3,+ECSS,0)),U),3,0) - S:ECSS="000" ECSS="999" - ;get classification information - S (ECXAO,ECXHNC)="" I ECXVISIT'="" D - .D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) I ECXERR K ECXERR - .S ECXAO=$G(ECXVIST("AO")),ECXHNC=$G(ECXVIST("HNC")) - ; - Head and Neck Cancer Indicator - S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) - ;look for non-OR - S (ECNT,ECNL,ECXDSSD,ECXNONL,ECXSTOP)="" - I $P(ECNO,U)="Y" D - .S ECSR=$P(ECNO,U,6),ECAT=$P(ECNO,U,7) - .S ECSRNPI=$$NPI^XUSNPI("Individual_ID",ECSR,ECXDATE) - .S:+ECSRNPI'>0 ECSRNPI="" S ECSRNPI=$P(ECSRNPI,U) - .S ECATNPI=$$NPI^XUSNPI("Individual_ID",ECAT,ECXDATE) - .S:+ECATNPI'>0 ECATNPI="" S ECATNPI=$P(ECATNPI,U) - .S ECXTM=$$ECXTIME^ECXUTL($P(ECNO,U,4)) - .S A1=$P(ECNO,U,5),A2=$P(ECNO,U,4),TIME="##" D:(A1&A2) TIME S ECNT=TIME - .S (ECXNONL,ECNL)=+$P(ECNO,U,2),ECNL=$P($G(^ECX(728.44,ECNL,0)),U,9) - .S:ECNL="" ECNL="UNKNOWN" - .; - .;- Get DSS Stop Code to use in encounter number - .S ECXSTOP=$P($G(^ECX(728.44,ECXNONL,0)),U,4) - ; - ;- Get credit stop, stop code and clinic - I $$SUR^ECXUTL6(.ECXCRST,.ECXSTCD,.ECXCLIN) - ; - ;- If surgery cancelled/aborted quit and go to next record - S ECCAN=$P($G(^SRF(ECD0,30)),U) - I +ECCAN S ECCAN=$$CANC^ECXUTL4(ECNL,$P(DATA2,U,10)) - ;on hold for ECXDSSD and ECXDSSP I $P($G(^SRF(ECD0,30)),U) Q - ;get service of attending surgeon - S ECATSV=$P($G(^DIC(49,+$G(^VA(200,+ECAT,5)),730)),U) - ; - ;get surgeon, attending and anesthesia super person classes - S ECSRPC=$$PRVCLASS^ECXUTL(ECSR,ECXDATE) - S ECATPC=$$PRVCLASS^ECXUTL(ECAT,ECXDATE) - S ECSAPC=$$PRVCLASS^ECXUTL(ECSA,ECXDATE) - ; - ;add leading 2s for pointer to 200 - S:ECAT ECAT="2"_ECAT S:ECSR ECSR="2"_ECSR S:ECSA ECSA="2"_ECSA - ;add leading 2 to principle anesthetist IEN - S:ECXPA ECXPA="2"_ECXPA - ;anesthesia technique - S ECANE="",PP="" - I $D(^SRF(ECD0,6,0)) S ECXJ=0 D - .F S ECXJ=$O(^SRF(ECD0,6,ECXJ)) Q:('ECXJ)!(ECANE]"") D - ..S PP=$P($G(^(ECXJ,0)),U,3) S:PP="Y" ECANE=$P(^(0),U,1) - .I ECANE="" S ECXJ=$O(^SRF(ECD0,6,0)) I ECXJ S ECANE=$P(^SRF(ECD0,6,ECXJ,0),U,1) - ;get primary procedure - ;ecode0=p^cpt code^^patient time^operation time^anesthesia time - S ECPT=+$P(DATAOP,U,2),ECXCMOD="" - K ARR,ERR D FIELD^DID(130,28,,"LABEL","ARR","ERR") I $D(ARR("LABEL")) D - .K ARR,ERR D FIELD^DID(130,28,,"GLOBAL SUBSCRIPT LOCATION","ARR","ERR") - .Q:$D(ERR("DIERR")) - .S SUB=$P(ARR("GLOBAL SUBSCRIPT LOCATION"),";"),MOD=0 - .F S MOD=$O(^SRF(ECD0,SUB,MOD)) Q:MOD'>0 D - ..S ECXCMOD=ECXCMOD_$P(^(MOD,0),U)_";" - S ECXCPT=$$CPT^ECXUTL3(ECPT,ECXCMOD) - S ECODE0="P"_U_U ;ECPT_U - F J="10,12","2,3","1,4" D - .N ECNTIME,ECSTIME,ECATIME - .S A2=$P(DATA2,U,$P(J,",")),A1=$P(DATA2,U,$P(J,",",2)),TIME="##" - .I (A1&A2)&(+J=10) D TIME S ECNTIME=TIME - .I (A1&A2)&(+J=1) D TIME S ECATIME=TIME - .I (A1&A2)&(+J=2) D - ..; - ..;-Operation Time (Surgeon Time) - ..;-Get time diff (in secs) & set to .5 if < 7.5 minutes (rounds to 1) - ..S TIMEDIF=$$FMDIFF^XLFDT(A1,A2,2)/900 - ..S TIMEDIF=$S(TIMEDIF>0&(TIMEDIF<.5):.5,1:TIMEDIF) - ..S TIME=$TR($J(TIMEDIF,4,0)," ") - ..S:TIME<0 TIME="###" - ..S:TIME ECSTIME=TIME - .S ECODE0=ECODE0_U_TIME K TIME - ; -Recovery Room Time - S ECRR="" - I $D(^SRF(ECD0,1.1)) D - .S A1=$P(^(1.1),U,8),A2=$P(^(1.1),U,7),TIME="##" D:(A1&A2) TIME - .S ECRR=TIME K TIME - I ECNL]"" S $P(ECODE0,U,5)=ECNT - ; - ; -OR Clean Time in 15 min increments DBIA #103 - S ECXORCT=($$FMDIFF^XLFDT($P($G(DATA2),U,14),$P($G(DATA2),U,13),2)/60)/15 - ; -If no OR clean time recorded set it to 2 - I ECXORCT'>0 S ECXORCT=2 - ; - ; -PT in hold area time in 15 min increments DBIA #103 - I $P($G(DATA2),U,10),$P($G(DATA2),U,15) D - .S ECXPTHA=($$FMDIFF^XLFDT($P($G(DATA2),U,10),$P($G(DATA2),U,15),2)/60)/15 - .S CON=$P($G(^SRF(ECD0,"CON")),U) - .I CON S ECXPTHA=ECXPTHA/2 - .S ECXPTHA=$TR($J(ECXPTHA,3,0)," ") - ; -If hold time is =<0 set it to "" - S:$G(ECXPTHA)'>0 ECXPTHA="" - ; - ;- Observation Patient Indicator (yes/no) - S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECNL) - ; - ;- set national patient record flag if exist - D NPRF^ECXUTL5 - ; - ;- If no encounter number don't file record - S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXSTOP,ECSS) Q:ECXENC="" - ; - ;- Get postop diagnosis codes - I $$SURPODX^ECXUTL6(.ECXPODX,.ECXPODX1,.ECXPODX2,.ECXPODX3,.ECXPODX4,.ECXPODX5) - ; - D FILE^ECXSURG1 - ;get secondary procedures - ;ecode0=s^cpt code - S ECXJ=0 - F S ECXJ=$O(^SRO(136,ECD0,3,ECXJ)) Q:'ECXJ I $D(^(ECXJ,0)),$D(^(0)),$P(^(0),"^")]"" D - .;S ECPT=$P(^SRF(ECD0,13,ECXJ,2),U),ECXCMOD="" - .S ECPT=$P(^SRO(136,ECD0,3,ECXJ,0),U),ECXMOD="" - .S ECPT=$P(^(0),"^"),ECXCMOD="" - .K ARR,ERR - .D FIELD^DID(130.16,4,,"LABEL","ARR","ERR") I $D(ARR("LABEL")) D - ..K ARR,ERR - ..D FIELD^DID(130.16,4,,"GLOBAL SUBSCRIPT LOCATION","ARR","ERR") - ..Q:$D(ERR("DIERR")) - ..S SUB=$P(ARR("GLOBAL SUBSCRIPT LOCATION"),";"),MOD=0 - ..F S MOD=$O(^SRF(ECD0,13,ECXJ,SUB,MOD)) Q:MOD'>0 S ECXCMOD=ECXCMOD_$P(^(MOD,0),U)_";" - .S ECXCPT=$$CPT^ECXUTL3(ECPT,ECXCMOD) - .S ECODE0="S"_U ;_ECPT - .D FILE^ECXSURG1 - ;get prostheses - ;ecode0=i^^^^^^prosthesis^old qty field (null) - S ECXJ=0 - F S ECXJ=$O(^SRF(ECD0,1,ECXJ)) Q:'ECXJ I $D(^(ECXJ,0)) D - .S ECXP=+^SRF(ECD0,1,ECXJ,0),ECXQ=$P($G(^(1)),U,2) S:'ECXQ ECXQ=1 - .S ECODE0="I"_U_U_U_U_U_U_ECXP_U_U - .D FILE^ECXSURG1 - Q - ; - ; -TIME ; given date/time get increment - ;A1=later, A2=earlier, TIME=difference - N CON,TIMEDIF - S CON=$P($G(^SRF(ECD0,"CON")),U) - ; - ;-Get time diff (in secs) & set to .5 if < 7.5 minutes (rounds to 1) - S TIMEDIF=$$FMDIFF^XLFDT(A1,A2,2)/900 - S TIMEDIF=$S(TIMEDIF>0&(TIMEDIF<.5):.5,1:TIMEDIF) - I 'CON D - .S TIME=$J($TR($J(TIMEDIF,4,0)," "),2,1) - .S:TIME>"99.0" TIME="99.0" - I CON D - .S TIME=$J(($TR($J(TIMEDIF,4,0)," ")/2),2,1) - .S:TIME>"99.5" TIME="99.5" - S:TIME<0 TIME="###" - Q - ; -SETUP ;Set required input for ECXTRAC - S ECHEAD="SUR" - D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) - Q - ; -QUE ; entry point for the background requeuing handled by ECXTAUTO - D SETUP,QUE^ECXTAUTO,^ECXKILL Q +ECXSURG ;ALB/JA,BIR/DMA,PTD-Surgery Extract for DSS ; 11/2/06 9:00am + ;;3.0;DSS EXTRACTS;**1,11,8,13,25,24,33,39,41,42,46,50,71,84,92,99**;Dec 22, 1997;Build 2 +BEG ;entry point from option + D SETUP I ECFILE="" Q + D ^ECXTRAC,^ECXKILL + Q + ; +START ; + S QFLG=0,ECED=ECED+.3,ECD=ECSD1 + F S ECD=$O(^SRF("AC",ECD)),ECD0=0 Q:('ECD)!(ECD>ECED)!(QFLG) D + .F S ECD0=$O(^SRF("AC",ECD,ECD0)) Q:'ECD0 D + ..I $D(^SRF(ECD0,0)) S EC=^SRF(ECD0,0),ECXDFN=+$P(EC,U),ECXVISIT=$P(EC,U,15) D STUFF Q:QFLG + Q + ; +STUFF ;gather data + N J,X,Y,PP,DATA1,DATA2,DATAOP,ARR,ERR,SUB,MOD,ECXNONL,ECXSTOP,TIMEDIF + N ECPRO,ECXORCT,ECXPTHA,ECXNPRFI,ECXPA,ECXPAPC,ECSRPC,ECATPC,ECSAPC + S ECXDATE=ECD,ECXERR=0,ECXQ="" + Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXDATE,"1;2;3;5;") + I ECXADMDT="" S ECXADD=ECXADMDT + I ECXADMDT'="" S ECXADD=$$ECXDATE^ECXUTL(ECXADMDT,ECXYM) + S EC0=^SRF(ECD0,0) + S DATA1=$S($D(^SRF(ECD0,.1)):^(.1),1:"") + S DATA2=$S($D(^SRF(ECD0,.2)):^(.2),1:"") + ;S DATAOP=$S($D(^SRF(ECD0,"OP")):^("OP"),1:"") + S DATAOP=$S($D(^SRO(136,ECD0,0)):^(0),1:"") + S ECNO=$G(^SRF(ECD0,"NON")) + ;get data + S ECSR=$P(DATA1,U,4),(ECATNPI,ECSANPI,ECSRNPI)="",ECAT=$P(DATA1,U,13) + ;-Time patient in OR room (Nurse Time) + S ECXTM=$$ECXTIME^ECXUTL($P(DATA2,U,10)) + S ECXDIV=$S($D(^SRF(ECD0,8)):^(8),1:ECINST) + N ECXPDIV S ECXPDIV=$$RADDIV^ECXDEPT(ECXDIV) ;Production Division + S ECSA=$P($G(^SRF(ECD0,.3)),U,4),ECO=$P(EC0,U,2) + ;get principle anesthetist and person class DBIA #103 + S ECXPA=$P($G(^SRF(ECD0,.3)),U,1) + S ECXPAPC=$$PRVCLASS^ECXUTL(ECXPA,ECXDATE) + S ECORTY=$P($G(^SRS(+ECO,2)),U),ECO=$P($G(^SRS(+ECO,0)),U) + S ECSS=$P($G(^SRO(137.45,+$P(EC0,U,4),0)),U,2) + S ECSS=$$RJ^XLFSTR($P($G(^DIC(45.3,+ECSS,0)),U),3,0) + S:ECSS="000" ECSS="999" + ;get classification information + S (ECXAO,ECXHNC)="" I ECXVISIT'="" D + .D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) I ECXERR K ECXERR + .S ECXAO=$G(ECXVIST("AO")),ECXHNC=$G(ECXVIST("HNC")) + ; - Head and Neck Cancer Indicator + S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) + ;look for non-OR + S (ECNT,ECNL,ECXDSSD,ECXNONL,ECXSTOP)="" + I $P(ECNO,U)="Y" D + .S ECSR=$P(ECNO,U,6),ECAT=$P(ECNO,U,7) + .S ECXTM=$$ECXTIME^ECXUTL($P(ECNO,U,4)) + .S A1=$P(ECNO,U,5),A2=$P(ECNO,U,4),TIME="##" D:(A1&A2) TIME S ECNT=TIME + .S (ECXNONL,ECNL)=+$P(ECNO,U,2),ECNL=$P($G(^ECX(728.44,ECNL,0)),U,9) + .S:ECNL="" ECNL="UNKNOWN" + .; + .;- Get DSS Stop Code to use in encounter number + .S ECXSTOP=$P($G(^ECX(728.44,ECXNONL,0)),U,4) + ; + ;- If surgery cancelled/aborted quit and go to next record + S ECCAN=$P($G(^SRF(ECD0,30)),U) + I +ECCAN S ECCAN=$$CANC^ECXUTL4(ECNL,$P(DATA2,U,10)) + ;on hold for ECXDSSD and ECXDSSP I $P($G(^SRF(ECD0,30)),U) Q + ;get service of attending surgeon + S ECATSV=$P($G(^DIC(49,+$G(^VA(200,+ECAT,5)),730)),U) + ; + ;get surgeon, attending and anesthesia super person classes + S ECSRPC=$$PRVCLASS^ECXUTL(ECSR,ECXDATE) + S ECATPC=$$PRVCLASS^ECXUTL(ECAT,ECXDATE) + S ECSAPC=$$PRVCLASS^ECXUTL(ECSA,ECXDATE) + ; + ;add leading 2s for pointer to 200 + S:ECAT ECAT="2"_ECAT S:ECSR ECSR="2"_ECSR S:ECSA ECSA="2"_ECSA + ;add leading 2 to principle anesthetist IEN + S:ECXPA ECXPA="2"_ECXPA + ;anesthesia technique + S ECANE="",PP="" + I $D(^SRF(ECD0,6,0)) S ECXJ=0 D + .F S ECXJ=$O(^SRF(ECD0,6,ECXJ)) Q:('ECXJ)!(ECANE]"") D + ..S PP=$P($G(^(ECXJ,0)),U,3) S:PP="Y" ECANE=$P(^(0),U,1) + .I ECANE="" S ECXJ=$O(^SRF(ECD0,6,0)) I ECXJ S ECANE=$P(^SRF(ECD0,6,ECXJ,0),U,1) + ;get primary procedure + ;ecode0=p^cpt code^^patient time^operation time^anesthesia time + S ECPT=+$P(DATAOP,U,2),ECXCMOD="" + K ARR,ERR D FIELD^DID(130,28,,"LABEL","ARR","ERR") I $D(ARR("LABEL")) D + .K ARR,ERR D FIELD^DID(130,28,,"GLOBAL SUBSCRIPT LOCATION","ARR","ERR") + .Q:$D(ERR("DIERR")) + .S SUB=$P(ARR("GLOBAL SUBSCRIPT LOCATION"),";"),MOD=0 + .F S MOD=$O(^SRF(ECD0,SUB,MOD)) Q:MOD'>0 D + ..S ECXCMOD=ECXCMOD_$P(^(MOD,0),U)_";" + S ECXCPT=$$CPT^ECXUTL3(ECPT,ECXCMOD) + S ECODE0="P"_U_U ;ECPT_U + F J="10,12","2,3","1,4" D + .N ECNTIME,ECSTIME,ECATIME + .S A2=$P(DATA2,U,$P(J,",")),A1=$P(DATA2,U,$P(J,",",2)),TIME="##" + .I (A1&A2)&(+J=10) D TIME S ECNTIME=TIME + .I (A1&A2)&(+J=1) D TIME S ECATIME=TIME + .I (A1&A2)&(+J=2) D + ..; + ..;-Operation Time (Surgeon Time) + ..;-Get time diff (in secs) & set to .5 if < 7.5 minutes (rounds to 1) + ..S TIMEDIF=$$FMDIFF^XLFDT(A1,A2,2)/900 + ..S TIMEDIF=$S(TIMEDIF>0&(TIMEDIF<.5):.5,1:TIMEDIF) + ..S TIME=$TR($J(TIMEDIF,4,0)," ") + ..S:TIME<0 TIME="###" + ..S:TIME ECSTIME=TIME + .S ECODE0=ECODE0_U_TIME K TIME + ; -Recovery Room Time + S ECRR="" + I $D(^SRF(ECD0,1.1)) D + .S A1=$P(^(1.1),U,8),A2=$P(^(1.1),U,7),TIME="##" D:(A1&A2) TIME + .S ECRR=TIME K TIME + I ECNL]"" S $P(ECODE0,U,5)=ECNT + ; + ; -OR Clean Time in 15 min increments DBIA #103 + S ECXORCT=($$FMDIFF^XLFDT($P($G(DATA2),U,14),$P($G(DATA2),U,13),2)/60)/15 + ; -If no OR clean time recorded set it to 2 + I ECXORCT'>0 S ECXORCT=2 + ; + ; -PT in hold area time in 15 min increments DBIA #103 + I $P($G(DATA2),U,10),$P($G(DATA2),U,15) D + .S ECXPTHA=($$FMDIFF^XLFDT($P($G(DATA2),U,10),$P($G(DATA2),U,15),2)/60)/15 + .S CON=$P($G(^SRF(ECD0,"CON")),U) + .I CON S ECXPTHA=ECXPTHA/2 + .S ECXPTHA=$TR($J(ECXPTHA,3,0)," ") + ; -If hold time is =<0 set it to "" + S:$G(ECXPTHA)'>0 ECXPTHA="" + ; + ;- Observation Patient Indicator (yes/no) + S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECNL) + ; + ;- set national patient record flag if exist + D NPRF^ECXUTL5 + ; + ;- If no encounter number don't file record + S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXSTOP,ECSS) Q:ECXENC="" + ; + D FILE + ;get secondary procedures + ;ecode0=s^cpt code + S ECXJ=0 + ;F S ECXJ=$O(^SRF(ECD0,13,ECXJ)) Q:'ECXJ I $D(^(ECXJ,0)),$D(^(2)),$P(^(2),U)]"" D + F S ECXJ=$O(^SRO(136,ECD0,3,ECXJ)) Q:'ECXJ I $D(^(ECXJ,0)),$D(^(0)),$P(^(0),"^")]"" D + .;S ECPT=$P(^SRF(ECD0,13,ECXJ,2),U),ECXCMOD="" + . S ECPT=$P(^SRO(136,ECD0,3,ECXJ,0),"^"),ECXCMOD="" + .K ARR,ERR + .D FIELD^DID(130.16,4,,"LABEL","ARR","ERR") I $D(ARR("LABEL")) D + ..K ARR,ERR + ..D FIELD^DID(130.16,4,,"GLOBAL SUBSCRIPT LOCATION","ARR","ERR") + ..Q:$D(ERR("DIERR")) + ..S SUB=$P(ARR("GLOBAL SUBSCRIPT LOCATION"),";"),MOD=0 + ..F S MOD=$O(^SRF(ECD0,13,ECXJ,SUB,MOD)) Q:MOD'>0 S ECXCMOD=ECXCMOD_$P(^(MOD,0),U)_";" + .S ECXCPT=$$CPT^ECXUTL3(ECPT,ECXCMOD) + .S ECODE0="S"_U ;_ECPT + .D FILE + ;get prostheses + ;ecode0=i^^^^^^prosthesis^old qty field (null) + S ECXJ=0 + F S ECXJ=$O(^SRF(ECD0,1,ECXJ)) Q:'ECXJ I $D(^(ECXJ,0)) D + .S ECXP=+^SRF(ECD0,1,ECXJ,0),ECXQ=$P($G(^(1)),U,2) S:'ECXQ ECXQ=1 + .S ECODE0="I"_U_U_U_U_U_U_ECXP_U_U + .D FILE + Q + ; +FILE ;file record + ;node0 + ;division^dfn^ssn^name^in/out (ECXA)^day^case #^ + ;surg specialty^or room #^ + ;surgeon^attending^anesthesia supervisor^anesthesia technique^ + ;primary/secondary/prostheses^cpt^^pt time^op time^anes time^ + ;prostheses^qty^^ + ;movement number^treating specialty^cancel/abort (ECCAN)^time^or type^ + ;attending's service^non-or dss id^recovery room time^^ + ;primary care team^primary care provider^admission date + ;node1 + ;mpi^dss dept ECXDSSD^surgeon npi^attending npi^anes supervisor npi^ + ;pc provider npi^pc prov person class^ + ;assoc pc provider^assoc pc prov person class^assoc pc prov npi^ + ;cpt&modifiers ECXCPT^dom ECXDOM^enrollment category ECXCAT^ + ;enrollment status ECXSTAT^enrollment priority ECXPRIOR^ + ;period of service ECXPOS^purple heart indicator ECXPHI^ + ;observ pat ind ECXOBS^encounter num ECXENC^ao loc ECXAOL^ + ;production division ECXPDIV^head & neck canc ind ECXHNCI^ + ;ethnicity ECXETH^race1 ECXRC1^new quantity ECXQ^ + ;^user enrollee ECXUESTA^patient type ECXPTYPE^combat vet elig + ;ECXCVE^combat vet elig end date ECXCVEDT^enc cv eligible ECXCVENC + ;or clean time ECXORCT^time pt in hold area ECXPTHA^national patient + ;record flag ECXNPRFI^princ anesthetist ECXPA^surgeon per class ECSRPC + ;node2 + ;atten surgeon per class ECATPC^anesthesia super person class ECSAPC^ + ;princ anesthetist PC ECXPAPC^emergency response indicator(FEMA) ECXERI^ + ;agent orange indic ECXAO^head/neck cancer ECXHNC + ; + N DA,DIK,STR + S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 + S ECODE=EC7_U_EC23_U_ECXDIV_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U + S ECODE=ECODE_$$ECXDATE^ECXUTL(ECXDATE,ECXYM)_U_ECD0_U_ECSS_U_ECO_U + S ECODE=ECODE_ECSR_U_ECAT_U_ECSA_U_ECANE_U_ECODE0_U + S STR=ECXMN_U_ECXTS_U_$S(ECCAN'="":ECCAN,1:"")_U_ECXTM_U_ECORTY_U + S STR=STR_ECATSV_U_ECNL_U_ECRR_U_U_ECPTTM_U_ECPTPR_U_ECXADD_U + S $P(ECODE,U,26,38)=STR + S ECODE1=ECXMPI_U_ECXDSSD_U_ECSRNPI_U_ECATNPI_U_ECSANPI_U_ECPTNPI_U + S ECODE1=ECODE1_ECCLAS_U_ECASPR_U_ECCLAS2_U_ECASNPI_U_ECXCPT_U_ECXDOM_U + S ECODE1=ECODE1_ECXCAT_U_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPOS_U_ECXPHI_U + S ECODE1=ECODE1_ECXOBS_U_ECXENC_U_ECXAOL_U_ECXPDIV_U_ECXHNCI_U + S ECODE1=ECODE1_ECXETH_U_ECXRC1_U_ECXQ_U + I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXORCT_U_ECXPTHA_U_ECXNPRFI + I ECXLOGIC>2005 S ECODE1=ECODE1_U_ECXPA_U_ECSRPC_U,ECODE2=ECATPC_U_ECSAPC_U_ECXPAPC + I ECXLOGIC>2006 S ECODE2=ECODE2_U_ECXERI_U_ECXAO_U_ECXHNC + S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,^ECX(ECFILE,EC7,2)=ECODE2,ECRN=ECRN+1 + S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA + I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 + ; +TIME ; given date/time get increment + ;A1=later, A2=earlier, TIME=difference + N CON,TIMEDIF + S CON=$P($G(^SRF(ECD0,"CON")),U) + ; + ;-Get time diff (in secs) & set to .5 if < 7.5 minutes (rounds to 1) + S TIMEDIF=$$FMDIFF^XLFDT(A1,A2,2)/900 + S TIMEDIF=$S(TIMEDIF>0&(TIMEDIF<.5):.5,1:TIMEDIF) + I 'CON D + .S TIME=$J($TR($J(TIMEDIF,4,0)," "),2,1) + .S:TIME>"99.0" TIME="99.0" + I CON D + .S TIME=$J(($TR($J(TIMEDIF,4,0)," ")/2),2,1) + .S:TIME>"99.5" TIME="99.5" + S:TIME<0 TIME="###" + Q + ; +SETUP ;Set required input for ECXTRAC + S ECHEAD="SUR" + D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) + Q + ; +QUE ; entry point for the background requeuing handled by ECXTAUTO + D SETUP,QUE^ECXTAUTO,^ECXKILL Q diff --git a/r/DSS_EXTRACTS-ECX/ECXTRAC.m b/r/DSS_EXTRACTS-ECX/ECXTRAC.m index ba1fc986..1a6527eb 100644 --- a/r/DSS_EXTRACTS-ECX/ECXTRAC.m +++ b/r/DSS_EXTRACTS-ECX/ECXTRAC.m @@ -1,204 +1,202 @@ -ECXTRAC ;ALB/GTS,JAP,BIR/DMA,CML-Package Extracts for DSS ; 7/29/07 12:51pm - ;;3.0;DSS EXTRACTS;**9,8,14,24,30,33,49,84,105**;Dec 22, 1997;Build 70 - ;Date range, queuing and message sending for package extracts - ;Input - ; ECPACK printed name of package (e.g. Lab, Prescriptions) - ; ECNODE in file 728 where last date is stored - ; ECPIECE piece of node where last date is stored - ; ECRTN in the form of START^ROUTINE - ; ECGRP name of local mail group to receive summary message - ; (MUST BE 1 TO 5 UPPER CASE ALPHA - NO SPACES) - ; ECFILE file number of the local editing file - ; ECXLOGIC Fiscal year extract logic to use (optional) - ; ECXDATES StartDate^EndDate^DoNotUpdate728 (optional) - ;Generates - ; EC23=2nd and 3rd piece of zero node in local editing file - ; =YYMM of end date^pointer to 727 - ; ECXLOGIC=Fiscal year extract logic to use - ; -EN ;entry point - N OUT,CHKFLG - I '$D(ECNODE) S ECNODE=7 - I '$D(ECHEAD) S ECHEAD=" " - I $P($G(^ECX(728,1,ECNODE+.1)),U,ECPIECE)]"" D Q - .W !!,$C(7),ECPACK," extract is already scheduled to run",!! - .D PAUSE - W @IOF,!,"Extract ",ECPACK," Information for DSS",!! - S:'$D(ECINST) ECINST=+$P(^ECX(728,1,0),U) - S ECXINST=ECINST - K ECXDIC S DA=ECINST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" - D EN^DIQ1 S ECINST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC - ;* get last date for all extracts except prosthetics - I ECGRP'="PRO" D - .S ECLDT=$S($D(^ECX(728,1,ECNODE)):$P(^(ECNODE),U,ECPIECE),1:2610624) - .S:ECLDT="" ECLDT=2610624 - ;* get last date for prosthetics - I ECGRP="PRO" D - .N ECXDA1 - .S ECXDA1=$O(^ECX(728,0)) - .I $D(^ECX(728,ECXDA1,1,ECXINST,0)) D - ..S ECLDT=$P(^ECX(728,ECXDA1,1,ECXINST,0),U,2) - .I '$D(^ECX(728,ECXDA1,1,ECXINST,0)) D - ..S DA(1)=ECXDA1 - ..S DIC(0)="L" K ECXDD - ..D FIELD^DID(728,59,,"SPECIFIER","ECXDD") - ..S DIC("P")=ECXDD("SPECIFIER") K ECXDD - ..S DIC="^ECX(728,"_DA(1)_",1,",X=ECXINST,DINUM=X - ..K DD,DO D FILE^DICN - ..K DIC,X,DINUM,Y,DA - ..S ECLDT=2610624 - S X=$G(ECXDATES) S ECSD=$P(X,"^",1),ECED=$P(X,"^",2) - S OUT=0 - I (ECSD="")!(ECED="") F S (ECED,ECSD)="" D Q:OUT - .K %DT S %DT="AEX",%DT("A")="Starting with Date: " D ^%DT - .I Y<0 S OUT=1 Q - .S ECSD=Y - .K %DT S %DT="AEX",%DT("A")="Ending with Date: " D ^%DT - .I Y<0 S OUT=1 Q - .I YDT:1,1:0) - .I CHKFLG D - ..W !!,"All active IV Rooms in the IV Room file (#59.5) must have a ""DIVISION""",!,"assigned to run this extract!" - ..W !!,"This information can be entered using the DSS Extract Manager's Maintenance ",!,"option ""Enter/Edit IV Room Division""." - ..D PAUSE -EXIT K ^TMP($J,"ECXIV") - Q - ; -PAUSE ;pause screen - N DIR,X,Y - S OUT=0 - I $E(IOST)="C" D - .S SS=22-$Y F JJ=1:1:SS W ! - .S DIR(0)="E" W ! D ^DIR K DIR - I 'Y S OUT=1 - W !! - Q +ECXTRAC ;ALB/GTS,JAP,BIR/DMA,CML-Package Extracts for DSS ; 5/9/05 10:39am + ;;3.0;DSS EXTRACTS;**9,8,14,24,30,33,49,84**;Dec 22, 1997 + ;Date range, queuing and message sending for package extracts + ;Input + ; ECPACK printed name of package (e.g. Lab, Prescriptions) + ; ECNODE in file 728 where last date is stored + ; ECPIECE piece of node where last date is stored + ; ECRTN in the form of START^ROUTINE + ; ECGRP name of local mail group to receive summary message + ; (MUST BE 1 TO 5 UPPER CASE ALPHA - NO SPACES) + ; ECFILE file number of the local editing file + ; ECXLOGIC Fiscal year extract logic to use (optional) + ; ECXDATES StartDate^EndDate^DoNotUpdate728 (optional) + ;Generates + ; EC23=2nd and 3rd piece of zero node in local editing file + ; =YYMM of end date^pointer to 727 + ; ECXLOGIC=Fiscal year extract logic to use + ; +EN ;entry point + N OUT,CHKFLG + I '$D(ECNODE) S ECNODE=7 + I '$D(ECHEAD) S ECHEAD=" " + I $P($G(^ECX(728,1,ECNODE+.1)),U,ECPIECE)]"" D Q + .W !!,$C(7),ECPACK," extract is already scheduled to run",!! + .D PAUSE + W @IOF,!,"Extract ",ECPACK," Information for DSS",!! + S:'$D(ECINST) ECINST=+$P(^ECX(728,1,0),U) + S ECXINST=ECINST + K ECXDIC S DA=ECINST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" + D EN^DIQ1 S ECINST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC + ;* get last date for all extracts except prosthetics + I ECGRP'="PRO" D + .S ECLDT=$S($D(^ECX(728,1,ECNODE)):$P(^(ECNODE),U,ECPIECE),1:2610624) + .S:ECLDT="" ECLDT=2610624 + ;* get last date for prosthetics + I ECGRP="PRO" D + .N ECXDA1 + .S ECXDA1=$O(^ECX(728,0)) + .I $D(^ECX(728,ECXDA1,1,ECXINST,0)) D + ..S ECLDT=$P(^ECX(728,ECXDA1,1,ECXINST,0),U,2) + .I '$D(^ECX(728,ECXDA1,1,ECXINST,0)) D + ..S DA(1)=ECXDA1 + ..S DIC(0)="L" K ECXDD + ..D FIELD^DID(728,59,,"SPECIFIER","ECXDD") + ..S DIC("P")=ECXDD("SPECIFIER") K ECXDD + ..S DIC="^ECX(728,"_DA(1)_",1,",X=ECXINST,DINUM=X + ..K DD,DO D FILE^DICN + ..K DIC,X,DINUM,Y,DA + ..S ECLDT=2610624 + S X=$G(ECXDATES) S ECSD=$P(X,"^",1),ECED=$P(X,"^",2) + S OUT=0 + I (ECSD="")!(ECED="") F S (ECED,ECSD)="" D Q:OUT + .K %DT S %DT="AEX",%DT("A")="Starting with Date: " D ^%DT + .I Y<0 S OUT=1 Q + .S ECSD=Y + .K %DT S %DT="AEX",%DT("A")="Ending with Date: " D ^%DT + .I Y<0 S OUT=1 Q + .I YDT:1,1:0) + .I CHKFLG D + ..W !!,"All active IV Rooms in the IV Room file (#59.5) must have a ""DIVISION""",!,"assigned to run this extract!" + ..W !!,"This information can be entered using the DSS Extract Manager's Maintenance ",!,"option ""Enter/Edit IV Room Division""." + ..D PAUSE + Q + ; +PAUSE ;pause screen + N DIR,X,Y + S OUT=0 + I $E(IOST)="C" D + .S SS=22-$Y F JJ=1:1:SS W ! + .S DIR(0)="E" W ! D ^DIR K DIR + I 'Y S OUT=1 + W !! + Q diff --git a/r/DSS_EXTRACTS-ECX/ECXTREX.m b/r/DSS_EXTRACTS-ECX/ECXTREX.m index 0143fb0c..20c027b5 100644 --- a/r/DSS_EXTRACTS-ECX/ECXTREX.m +++ b/r/DSS_EXTRACTS-ECX/ECXTREX.m @@ -1,89 +1,89 @@ -ECXTREX ;BPFO/JRP - Queue DSS Fiscal Year Specific Extract;8-AUG-2003 ; 6/11/07 12:46pm - ;;3.0;DSS EXTRACTS;**49,71,84,92,105**;Dec 22, 1997;Build 70 - ; -EN ;Main entry point - W @IOF - N DIC,X,Y,DTOUT,DUOUT - W !,"****************************************************************" - W !,"* *" - W !,"* This option should be used with caution as it allows for the *" - W !,"* extraction of data using specified fiscal year logic. This *" - W !,"* gives the ability to extract fiscal year 200x data using *" - W !,"* fiscal year 200(x+1) logic and vice versa. Note that data *" - W !,"* extracted via this method may or may not be transmittable to *" - W !,"* the DSS production queue at the Austin Automation Center. *" - W !,"* *" - W !,"*--------------------------------------------------------------*" - W !,"* *" - W !,"* Note that this option does not update the last date used for *" - W !,"* the given extraction. It also does not verify that the time *" - W !,"* frame selected is after the last date used for the extract. *" - W !,"* *" - W !,"****************************************************************" - W !! - ;Pick extract to queue - S DIC="^ECX(727.1," - S DIC(0)="AEQMZ" - S DIC("A")="Select DSS Extract to queue: " - S DIC("S")="I ('$P(^(0),U,12))&($P(^(0),U,8)'="""")&($G(^(7))'[""Inactive"")" - S DIC("W")="W ""("",$P(^(0),U,8),"")""" - D ^DIC - I ($D(DUOUT))!($D(DTOUT))!(Y<1) Q - N ECXRTN,ECXDA - S ECXDA=+Y - ;Get extract specific routine name - S ECXRTN=$G(^ECX(727.1,ECXDA,"ROU")) - I ECXRTN="" D Q - .W !!,"Selected extract is not correctly defined in the EXTRACT" - .W !,"DEFINITIONS file (#727.1). The ROUTINE field (#4) does not" - .W !,"have a value in it." - .W ! - .D PAUSE - ;Get time frame for extract - N STRTDT,ENDDT,DIR,DIRUT,DIROUT,OUT,ECXDATES - S OUT=0 F S (STRTDT,ENDDT)="" D Q:OUT - .;Get start date (must be in past) - .S DIR(0)="DOA" - .S $P(DIR(0),"^",2)=":"_DT_":AEXP" - .S DIR("A")="Starting with Date: " - .D ^DIR - .I $D(DIROUT)!$D(DIRUT)!(Y="") S (STRTDT,ENDDT)="" S OUT=1 Q - .S STRTDT=Y - .K DIR - .;Get end date (must be in same month; must be in past) - .S DIR(0)="DOA" - .S X=$E(STRTDT,1,5)_"01" - .S X=$$FMADD^XLFDT(X,32) - .S X=$$FMADD^XLFDT(X,-($E(X,6,7))) - .I X>DT S X=DT - .S $P(DIR(0),"^",2)=STRTDT_":"_X_":AEXP" - .S DIR("A")="Ending with Date: " - .S DIR("B")=$$FMTE^XLFDT(X,"5D") - .D ^DIR - .I $D(DIROUT)!$D(DIRUT)!(Y="") S (STRTDT,ENDDT)="" S OUT=1 Q - .S ENDDT=Y - .S OUT=1 - Q:(STRTDT="")!(ENDDT="") - S ECXDATES=STRTDT_"^"_ENDDT_"^1" - ;Get extract logic to use - N ECXLOGIC - K DIR - S DIR("A")="Select fiscal year logic to use for extract" - S DIR(0)="SO^" - F X=2003,2004,2005,2006,2007,2008 D - .S Y=$E(X,5) - .S Y=$S((Y="")!(Y=" "):"",1:"Revision "_Y_" of ") - .S DIR(0)=DIR(0)_X_":"_Y_"Fiscal Year "_$E(X,1,4)_";" - D ^DIR - I $D(DIROUT)!$D(DIRUT) Q - S ECXLOGIC=Y - ;Queue extract - D @("BEG^"_ECXRTN) - Q -PAUSE ;pause screen - N DIR,X,Y,DTOUT,DUOUT,DIROUT,DIRUT - S DIR(0)="E" - W !! - D ^DIR - W !! - Q +ECXTREX ;BPFO/JRP - Queue DSS Fiscal Year Specific Extract;8-AUG-2003 ; 11/2/06 9:02am + ;;3.0;DSS EXTRACTS;**49,71,84,92**;Dec 22, 1997;Build 30 + ; +EN ;Main entry point + W @IOF + N DIC,X,Y,DTOUT,DUOUT + W !,"****************************************************************" + W !,"* *" + W !,"* This option should be used with caution as it allows for the *" + W !,"* extraction of data using specified fiscal year logic. This *" + W !,"* gives the ability to extract fiscal year 200x data using *" + W !,"* fiscal year 200(x+1) logic and vice versa. Note that data *" + W !,"* extracted via this method may or may not be transmittable to *" + W !,"* the DSS production queue at the Austin Automation Center. *" + W !,"* *" + W !,"*--------------------------------------------------------------*" + W !,"* *" + W !,"* Note that this option does not update the last date used for *" + W !,"* the given extraction. It also does not verify that the time *" + W !,"* frame selected is after the last date used for the extract. *" + W !,"* *" + W !,"****************************************************************" + W !! + ;Pick extract to queue + S DIC="^ECX(727.1," + S DIC(0)="AEQMZ" + S DIC("A")="Select DSS Extract to queue: " + S DIC("S")="I ('$P(^(0),U,12))&($P(^(0),U,8)'="""")&($G(^(7))'[""Inactive"")" + S DIC("W")="W ""("",$P(^(0),U,8),"")""" + D ^DIC + I ($D(DUOUT))!($D(DTOUT))!(Y<1) Q + N ECXRTN,ECXDA + S ECXDA=+Y + ;Get extract specific routine name + S ECXRTN=$G(^ECX(727.1,ECXDA,"ROU")) + I ECXRTN="" D Q + .W !!,"Selected extract is not correctly defined in the EXTRACT" + .W !,"DEFINITIONS file (#727.1). The ROUTINE field (#4) does not" + .W !,"have a value in it." + .W ! + .D PAUSE + ;Get time frame for extract + N STRTDT,ENDDT,DIR,DIRUT,DIROUT,OUT,ECXDATES + S OUT=0 F S (STRTDT,ENDDT)="" D Q:OUT + .;Get start date (must be in past) + .S DIR(0)="DOA" + .S $P(DIR(0),"^",2)=":"_DT_":AEXP" + .S DIR("A")="Starting with Date: " + .D ^DIR + .I $D(DIROUT)!$D(DIRUT)!(Y="") S (STRTDT,ENDDT)="" S OUT=1 Q + .S STRTDT=Y + .K DIR + .;Get end date (must be in same month; must be in past) + .S DIR(0)="DOA" + .S X=$E(STRTDT,1,5)_"01" + .S X=$$FMADD^XLFDT(X,32) + .S X=$$FMADD^XLFDT(X,-($E(X,6,7))) + .I X>DT S X=DT + .S $P(DIR(0),"^",2)=STRTDT_":"_X_":AEXP" + .S DIR("A")="Ending with Date: " + .S DIR("B")=$$FMTE^XLFDT(X,"5D") + .D ^DIR + .I $D(DIROUT)!$D(DIRUT)!(Y="") S (STRTDT,ENDDT)="" S OUT=1 Q + .S ENDDT=Y + .S OUT=1 + Q:(STRTDT="")!(ENDDT="") + S ECXDATES=STRTDT_"^"_ENDDT_"^1" + ;Get extract logic to use + N ECXLOGIC + K DIR + S DIR("A")="Select fiscal year logic to use for extract" + S DIR(0)="SO^" + F X=2003,2004,2005,2006,2007 D + .S Y=$E(X,5) + .S Y=$S((Y="")!(Y=" "):"",1:"Revision "_Y_" of ") + .S DIR(0)=DIR(0)_X_":"_Y_"Fiscal Year "_$E(X,1,4)_";" + D ^DIR + I $D(DIROUT)!$D(DIRUT) Q + S ECXLOGIC=Y + ;Queue extract + D @("BEG^"_ECXRTN) + Q +PAUSE ;pause screen + N DIR,X,Y,DTOUT,DUOUT,DIROUT,DIRUT + S DIR(0)="E" + W !! + D ^DIR + W !! + Q diff --git a/r/DSS_EXTRACTS-ECX/ECXTRT.m b/r/DSS_EXTRACTS-ECX/ECXTRT.m index c5edf755..175bf3d6 100644 --- a/r/DSS_EXTRACTS-ECX/ECXTRT.m +++ b/r/DSS_EXTRACTS-ECX/ECXTRT.m @@ -1,187 +1,205 @@ -ECXTRT ;ALB/JAP,BIR/DMA,CML,PTD-Treating Specialty Change Extract ; 10/17/07 3:48pm - ;;3.0;DSS EXTRACTS;**1,8,17,24,33,35,39,46,49,84,107,105**;Dec 22, 1997;Build 70 -BEG ;entry point from option - D SETUP I ECFILE="" Q - D ^ECXTRAC,^ECXKILL - Q - ; -START ; start package specific extract - N LOC,SPC,TRT,WRD - S QFLG=0 - K ECXDD D FIELD^DID(405,.19,,"SPECIFIER","ECXDD") - S ECPRO=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD - K ^TMP($J,"ECXTMP") S TRT=0 - F S TRT=$O(^DIC(45.7,TRT)) Q:+TRT=0 S SPC=$P(^DIC(45.7,TRT,0),U,2),^TMP($J,"ECXTMP",TRT)=SPC - S ECED=ECED+.3,ECD=ECSD1 - ;loop through type 6 movements to get treating specialty and provider changes - F S ECD=$O(^DGPM("ATT6",ECD)),ECDA=0 Q:('ECD)!(ECD>ECED)!(QFLG) F S ECDA=$O(^DGPM("ATT6",ECD,ECDA)) Q:'ECDA D Q:QFLG - .I $D(^DGPM(ECDA,0)) S EC=^(0),ECXDFN=+$P(EC,U,3) D Q:QFLG - ..S ECXMVD1=$P(EC,U),WRD=$P(EC,U,6) - ..; - ..;- Call sets ECXA (In/Out indicator) - ..Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXMVD1,"1;",13) - ..S ECMT=$P(EC,U,18),ECXADM=$P(EC,U,14),ECXADT=$P($G(^DGPM(ECXADM,0)),U) - ..;skip the record if its the admission treat. spec. change for this episode of care - ..Q:ECXADM=$P(EC,U,24) - ..S (ECXLOS,ECXLOSA,ECXLOSP)="" S ECXDSSD="" - ..K LOC D SETLOC(ECXDFN,ECXADM,ECPRO,.LOC) - ..;get data for current (new) ts movement - ..S ECD1=9999999.9999999-ECXMVD1 - ..D FINDLOC(ECD1,.LOC,.ECXSPCN,.ECXPRVN,.ECXATTN,.ECXMOVN,.ECXTRTN) - ..Q:ECXSPCN="" - ..S ECD2=$O(LOC(ECD1)) Q:ECD2="" - ..S ECXMVD2=9999999.9999999-ECD2 - ..;get data for previous (losing) ts movement - ..D FINDLOC(ECD2,.LOC,.ECXSPCL,.ECXPRVL,.ECXATTL,.ECXMOVL,.ECXTRTL) - ..;if ts has changed, find los on losing ts - ..D:ECXTRTL'=ECXTRTN PREVTRT^ECXTRT1(.LOC,ECD1,ECD2,ECXTRTL,.ECXLOS) - ..;whether ts has changed or not, see if primary provider has changed - ..;don't bother if there's no data on current primary provider or no change in provider - ..D:(ECXPRVN'="")&(ECXPRVN'=ECXPRVL) PREVPRV^ECXTRT1(.LOC,ECD1,ECXPRVN,ECD2,.ECXPRVL,.ECXLOSP) - ..;whether ts has changed or not, see if attending physician has changed - ..;don't bother if there's no data on current attending physician or no change in attending - ..D:(ECXATTN'="")&(ECXATTN'=ECXATTL) PREVATT^ECXTRT1(.LOC,ECD1,ECXATTN,ECD2,.ECXATTL,.ECXLOSA) - ..S ECXDATE=$$ECXDATE^ECXUTL(ECXMVD1,ECXYM),ECXTIME=$$ECXTIME^ECXUTL(ECXMVD1) - ..S ECXADMDT=$$ECXDATE^ECXUTL(ECXADT,ECXYM),ECXADMTM=$$ECXTIME^ECXUTL(ECXADT),ECXDCDT="" - ..;- Production Division - ..S ECXPDIV="" - ..I ECXLOGIC>2003 S ECXPDIV=$S(WRD="":"",1:$$NPDIV(WRD)) - ..; - ..;- Observation patient indicator (YES/NO) - ..S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) - ..; - ..;- Chg outpat with movemnt/discharge to inpat (to comply w/existing business rule) - ..I ECXA="O"&(ECXOBS="NO")&(ECXMVD1) S ECXA="I" - ..; - ..;- Get providers person classes - .. S ECXATLPC=$$PRVCLASS^ECXUTL($E(ECXATTL,2,999),ECXADT) - .. S ECATLNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXATTL,2,999),ECXADT) - .. S:+ECATLNPI'>0 ECATLNPI="" S ECATLNPI=$P(ECATLNPI,U) - .. S ECXPRNPC=$$PRVCLASS^ECXUTL($E(ECXPRVN,2,999),ECXADT) - .. S ECPRVNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXPRVN,2,999),ECXADT) - .. S:+ECPRVNPI'>0 ECPRVNPI="" S ECPRVNPI=$P(ECPRVNPI,U) - .. S ECXATNPC=$$PRVCLASS^ECXUTL($E(ECXATTN,2,999),ECXADT) - .. S ECATTNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXATTN,2,999),ECXADT) - .. S:+ECATTNPI'>0 ECATTNPI="" S ECATTNPI=$P(ECATTNPI,U) - .. S ECXPRLPC=$$PRVCLASS^ECXUTL($E(ECXPRVL,2,999),ECXADT) - .. S ECPRLNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXPRVL,2,999),ECXADT) - .. S:+ECPRLNPI'>0 ECPRLNPI="" S ECPRLNPI=$P(ECPRLNPI,U) - ..; - ..;- If no encounter number, don't file record - ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADT,,ECXTS,ECXOBS,ECHEAD,,) - ..D:ECXENC'="" FILE^ECXTRT2 - ;for nhcu episodes with intervening asih stays, the los calculated here is not accurate, - ;but it never has been; this is best solution within current extract framework; - ;at discharge the los calculated for nhcu episodes will be the los since admission w/o asih los subtracted; - ; - ;loop through discharges to get last treating specialty - S ECD=ECSD1 - F S ECD=$O(^DGPM("ATT3",ECD)),ECDA=0 Q:'ECD Q:ECD>ECED F S ECDA=$O(^DGPM("ATT3",ECD,ECDA)) Q:'ECDA D Q:QFLG - .I $D(^DGPM(ECDA,0)) S EC=^(0),ECXDFN=+$P(EC,U,3) D Q:QFLG - ..S ECXMVD1=$P(EC,U),WRD=$P(EC,U,6) - ..S (ECXDATE,ECXDCDT)=$$ECXDATE^ECXUTL(ECXMVD1,ECXYM),ECXTIME=$$ECXTIME^ECXUTL(ECXMVD1) - ..I ECXDCDT'>0 S ECXDCDT="" - ..S ECMT=$P(EC,U,18),ECXADM=$P(EC,U,14),ECXADT=$P($G(^DGPM(ECXADM,0)),U,1) - ..S (ECXTRTN,ECXSPCN,ECXPRVN,ECXATTN)="" S (ECXLOS,ECXLOSA,ECXLOSP)="" S ECXDSSD="" - ..K LOC D SETLOC(ECXDFN,ECXADM,ECPRO,.LOC) - ..S ECD1=9999999.9999999-ECXMVD1 - ..;get ts change just before d/c - ..S ECD2=$O(LOC(ECD1)),ECXMVD2=9999999.9999999-ECD2 - ..D FINDLOC(ECD2,.LOC,.ECXSPCL,.ECXPRVL,.ECXATTL,.ECXMOVL,.ECXTRTL) - ..; - ..;- Call sets ECXA (In/Out indicator) using date before discharge - ..Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXMVD2,"1;",13) - ..S ECXADMDT=$$ECXDATE^ECXUTL(ECXADT,ECXYM),ECXADMTM=$$ECXTIME^ECXUTL(ECXADT) - ..;if closest ts change is admission ts, cant go back any further - ..S TRT=$O(LOC(ECD2,0)),REC=$O(LOC(ECD2,TRT,0)) - ..I REC=ECXADM D - ...S X1=ECXMVD1,X2=ECXMVD2 D ^%DTC S ECXLOS=X - ...I ECXPRVL'="" S X1=ECXMVD1,X2=ECXMVD2 D ^%DTC S ECXLOSP=X - ...I ECXATTL'="" S X1=ECXMVD1,X2=ECXMVD2 D ^%DTC S ECXLOSA=X - ..;otherwise, need to find when change to last ts occurred - ..I REC'=ECXADM D - ...D PREVTRT^ECXTRT1(.LOC,ECD1,ECD2,ECXTRTL,.ECXLOS) - ...D PREVPRV^ECXTRT1(.LOC,ECD1,ECXPRVN,ECD2,.ECXPRVL,.ECXLOSP) - ...D PREVATT^ECXTRT1(.LOC,ECD1,ECXATTN,ECD2,.ECXATTL,.ECXLOSA) - ..S:ECXLOS>9999 ECXLOS=9999 S:ECXLOSA>9999 ECXLOSA=9999 - ..S:ECXLOSP>9999 ECXLOSP=9999 - ..;- Production Division - ..S ECXPDIV="" - ..I ECXLOGIC>2003 S ECXPDIV=$S(WRD="":"",1:$$NPDIV(WRD)) - ..; - ..;- Observation patient indicator (YES/NO) - ..S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) - ..; - ..;- Chg outpat with movemnt/discharge to inpat (to comply w/existing business rule) - ..I ECXA="O"&(ECXOBS="NO")&(ECXMVD1) S ECXA="I" - ..; - ..;- Get providers person classes - .. S ECXATLPC=$$PRVCLASS^ECXUTL($E(ECXATTL,2,999),ECXADT) - .. S ECATLNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXATTL,2,999),ECXADT) - .. S:+ECATLNPI'>0 ECATLNPI="" S ECATLNPI=$P(ECATLNPI,U) - .. S ECXPRNPC=$$PRVCLASS^ECXUTL($E(ECXPRVN,2,999),ECXADT) - .. S ECPRVNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXPRVN,2,999),ECXADT) - .. S:+ECPRVNPI'>0 ECPRVNPI="" S ECPRVNPI=$P(ECPRVNPI,U) - .. S ECXATNPC=$$PRVCLASS^ECXUTL($E(ECXATTN,2,999),ECXADT) - .. S ECATTNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXATTN,2,999),ECXADT) - .. S:+ECATTNPI'>0 ECATTNPI="" S ECATTNPI=$P(ECATTNPI,U) - .. S ECXPRLPC=$$PRVCLASS^ECXUTL($E(ECXPRVL,2,999),ECXADT) - .. S ECPRLNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXPRVL,2,999),ECXADT) - .. S:+ECPRLNPI'>0 ECPRLNPI="" S ECPRLNPI=$P(ECPRLNPI,U) - ..; - ..;- If no encounter number don't file record - ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADT,,ECXTS,ECXOBS,ECHEAD,,) - ..D:ECXENC'="" FILE^ECXTRT2 - D KPATDEM^ECXUTL2 - Q - ; -NPDIV(WRD) ;National Production Division - N DIV - S DIV=$$GET1^DIQ(42,WRD,.015,"I") - Q $S(DIV="":"",1:$$GETDIV^ECXDEPT(DIV)) - ; -SETLOC(ECXDFN,ECXADM,ECXPRO,ECXLOC) ;setup the local array from the ATS index - ; output - ; ECXLOC = local array (passed by reference) - ; - N SUB3,SUB4,SUB5,SPC,PRV,ATT,MOV - S SUB3=0 - F S SUB3=$O(^DGPM("ATS",ECXDFN,ECXADM,SUB3)) Q:SUB3="" D - .S (SUB4,SUB5)=0 - .S SUB4=$O(^DGPM("ATS",ECXDFN,ECXADM,SUB3,SUB4)) - .S SUB5=$O(^DGPM("ATS",ECXDFN,ECXADM,SUB3,SUB4,SUB5)) - .S ECXLOC(SUB3,SUB4,SUB5)="",SPC=$G(^TMP($J,"ECXTMP",SUB4)) - .S DATA=$G(^DGPM(SUB5,0)),PRV=$P(DATA,U,8),ATT=$P(DATA,U,19) - .S MOV=$P(DATA,U,14) - .S:PRV]"" PRV=ECXPRO_PRV S:ATT]"" ATT=ECXPRO_ATT - .S ECXLOC(SUB3,SUB4,SUB5)=SPC_U_PRV_U_ATT_U_MOV - Q - ; -FINDLOC(ECXTSD,ECXLOC,ECXSPC,ECXPRV,ECXATT,ECXMOV,ECXTRT) ;find local array node for current ts movement - ; input - ; ECXTSD = inverse date/time for current ts movement; required - ; ECXLOC = local array; passed by reference; required - ; output; data from record contained in MOVE - ; ECXSPC = piece 1 of LOC (passed by reference) - ; ECXPRV = piece 2 of LOC concatenated to PRO (passed by reference) - ; ECXATT = piece 3 of LOC concatenated to PRO (passed by reference) - ; ECXMOV = piece 4 of LOC (passed by reference) - ; ECXTRT = pointer to file #45.7 - ; - N SUB3,SUB4,SUB5,LOC - S (ECXSPC,ECXPRV,ECXATT,ECXMOV)="" - S SUB3=ECXTSD - I $D(ECXLOC(SUB3)) D - .S SUB4=$O(ECXLOC(SUB3,0)),SUB5=$O(ECXLOC(SUB3,SUB4,0)) - .S LOC=ECXLOC(SUB3,SUB4,SUB5),ECXTRT=SUB4,ECXSPC=$P(LOC,U) - .S ECXPRV=$P(LOC,U,2),ECXATT=$P(LOC,U,3),ECXMOV=$P(LOC,U,4) - Q - ; -SETUP ;Set required input for ECXTRAC - S ECHEAD="TRT" - D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) - Q - ; -QUE ; entry point for the background requeuing handled by ECXTAUTO - D SETUP,QUE^ECXTAUTO,^ECXKILL - Q +ECXTRT ;ALB/JAP,BIR/DMA,CML,PTD-Treating Specialty Change Extract ; 04/12/2007 + ;;3.0;DSS EXTRACTS;**1,8,17,24,33,35,39,46,49,84,107**;Dec 22, 1997;Build 9 +BEG ;entry point from option + D SETUP I ECFILE="" Q + D ^ECXTRAC,^ECXKILL + Q + ; +START ; start package specific extract + N LOC,SPC,TRT,WRD + S QFLG=0 + K ECXDD D FIELD^DID(405,.19,,"SPECIFIER","ECXDD") + S ECPRO=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD + K ^TMP($J,"ECXTMP") S TRT=0 + F S TRT=$O(^DIC(45.7,TRT)) Q:+TRT=0 S SPC=$P(^DIC(45.7,TRT,0),U,2),^TMP($J,"ECXTMP",TRT)=SPC + S ECED=ECED+.3,ECD=ECSD1 + ;loop through type 6 movements to get treating specialty and provider changes + F S ECD=$O(^DGPM("ATT6",ECD)),ECDA=0 Q:('ECD)!(ECD>ECED)!(QFLG) F S ECDA=$O(^DGPM("ATT6",ECD,ECDA)) Q:'ECDA D Q:QFLG + .I $D(^DGPM(ECDA,0)) S EC=^(0),ECXDFN=+$P(EC,U,3) D Q:QFLG + ..S ECXMVD1=$P(EC,U),WRD=$P(EC,U,6) + ..; + ..;- Call sets ECXA (In/Out indicator) + ..Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXMVD1,"1;",13) + ..S ECMT=$P(EC,U,18),ECXADM=$P(EC,U,14),ECXADT=$P($G(^DGPM(ECXADM,0)),U) + ..;skip the record if its the admission treat. spec. change for this episode of care + ..Q:ECXADM=$P(EC,U,24) + ..S (ECXLOS,ECXLOSA,ECXLOSP)="" S ECXDSSD="" + ..K LOC D SETLOC(ECXDFN,ECXADM,ECPRO,.LOC) + ..;get data for current (new) ts movement + ..S ECD1=9999999.9999999-ECXMVD1 + ..D FINDLOC(ECD1,.LOC,.ECXSPCN,.ECXPRVN,.ECXATTN,.ECXMOVN,.ECXTRTN) + ..Q:ECXSPCN="" + ..S ECD2=$O(LOC(ECD1)) Q:ECD2="" + ..S ECXMVD2=9999999.9999999-ECD2 + ..;get data for previous (losing) ts movement + ..D FINDLOC(ECD2,.LOC,.ECXSPCL,.ECXPRVL,.ECXATTL,.ECXMOVL,.ECXTRTL) + ..;if ts has changed, find los on losing ts + ..D:ECXTRTL'=ECXTRTN PREVTRT^ECXTRT1(.LOC,ECD1,ECD2,ECXTRTL,.ECXLOS) + ..;whether ts has changed or not, see if primary provider has changed + ..;dont bother if there's no data on current primary provider or no change in provider + ..D:(ECXPRVN'="")&(ECXPRVN'=ECXPRVL) PREVPRV^ECXTRT1(.LOC,ECD1,ECXPRVN,ECD2,.ECXPRVL,.ECXLOSP) + ..;whether ts has changed or not, see if attending physician has changed + ..;dont bother if theres no data on current attending physician or no change in attending + ..D:(ECXATTN'="")&(ECXATTN'=ECXATTL) PREVATT^ECXTRT1(.LOC,ECD1,ECXATTN,ECD2,.ECXATTL,.ECXLOSA) + ..S ECXDATE=$$ECXDATE^ECXUTL(ECXMVD1,ECXYM),ECXTIME=$$ECXTIME^ECXUTL(ECXMVD1) + ..S ECXADMDT=$$ECXDATE^ECXUTL(ECXADT,ECXYM),ECXADMTM=$$ECXTIME^ECXUTL(ECXADT),ECXDCDT="" + ..;- Production Division + ..S ECXPDIV="" + ..I ECXLOGIC>2003 S ECXPDIV=$S(WRD="":"",1:$$NPDIV(WRD)) + ..S (ECXALNPI,ECXANNPI,ECXPLNPI,ECXPNNPI)="" + ..; + ..;- Observation patient indicator (YES/NO) + ..S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) + ..; + ..;- Chg outpat with movemnt/discharge to inpat (to comply w/existing business rule) + ..I ECXA="O"&(ECXOBS="NO")&(ECXMVD1) S ECXA="I" + ..; + ..;- Get providers person classes + .. S ECXATLPC=$$PRVCLASS^ECXUTL($E(ECXATTL,2,999),ECXADT) + .. S ECXPRNPC=$$PRVCLASS^ECXUTL($E(ECXPRVN,2,999),ECXADT) + .. S ECXATNPC=$$PRVCLASS^ECXUTL($E(ECXATTN,2,999),ECXADT) + .. S ECXPRLPC=$$PRVCLASS^ECXUTL($E(ECXPRVL,2,999),ECXADT) + ..; + ..;- If no encounter number, don't file record + ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADT,,ECXTS,ECXOBS,ECHEAD,,) + ..D:ECXENC'="" FILE + ;for nhcu episodes with intervening asih stays, the los calculated here is not accurate, + ;but it never has been; this is best solution within current extract framework; + ;at discharge the los calculated for nhcu apisodes will be the los since admission w/o asih los subtracted; + ; + ;loop through discharges to get last treating specialty + S ECD=ECSD1 + F S ECD=$O(^DGPM("ATT3",ECD)),ECDA=0 Q:'ECD Q:ECD>ECED F S ECDA=$O(^DGPM("ATT3",ECD,ECDA)) Q:'ECDA D Q:QFLG + .I $D(^DGPM(ECDA,0)) S EC=^(0),ECXDFN=+$P(EC,U,3) D Q:QFLG + ..S ECXMVD1=$P(EC,U),WRD=$P(EC,U,6) + ..S (ECXDATE,ECXDCDT)=$$ECXDATE^ECXUTL(ECXMVD1,ECXYM),ECXTIME=$$ECXTIME^ECXUTL(ECXMVD1) + ..I ECXDCDT'>0 S ECXDCDT="" + ..S ECMT=$P(EC,U,18),ECXADM=$P(EC,U,14),ECXADT=$P($G(^DGPM(ECXADM,0)),U,1) + ..S (ECXTRTN,ECXSPCN,ECXPRVN,ECXATTN)="" S (ECXLOS,ECXLOSA,ECXLOSP)="" S ECXDSSD="" + ..K LOC D SETLOC(ECXDFN,ECXADM,ECPRO,.LOC) + ..S ECD1=9999999.9999999-ECXMVD1 + ..;get ts change just before d/c + ..S ECD2=$O(LOC(ECD1)),ECXMVD2=9999999.9999999-ECD2 + ..D FINDLOC(ECD2,.LOC,.ECXSPCL,.ECXPRVL,.ECXATTL,.ECXMOVL,.ECXTRTL) + ..; + ..;- Call sets ECXA (In/Out indicator) using date before discharge + ..Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXMVD2,"1;",13) + ..S ECXADMDT=$$ECXDATE^ECXUTL(ECXADT,ECXYM),ECXADMTM=$$ECXTIME^ECXUTL(ECXADT) + ..;if closest ts change is admission ts, cant go back any further + ..S TRT=$O(LOC(ECD2,0)),REC=$O(LOC(ECD2,TRT,0)) + ..I REC=ECXADM D + ...S X1=ECXMVD1,X2=ECXMVD2 D ^%DTC S ECXLOS=X + ...I ECXPRVL'="" S X1=ECXMVD1,X2=ECXMVD2 D ^%DTC S ECXLOSP=X + ...I ECXATTL'="" S X1=ECXMVD1,X2=ECXMVD2 D ^%DTC S ECXLOSA=X + ..;otherwise, need to find when change to last ts occurred + ..I REC'=ECXADM D + ...D PREVTRT^ECXTRT1(.LOC,ECD1,ECD2,ECXTRTL,.ECXLOS) + ...D PREVPRV^ECXTRT1(.LOC,ECD1,ECXPRVN,ECD2,.ECXPRVL,.ECXLOSP) + ...D PREVATT^ECXTRT1(.LOC,ECD1,ECXATTN,ECD2,.ECXATTL,.ECXLOSA) + ..S:ECXLOS>9999 ECXLOS=9999 S:ECXLOSA>9999 ECXLOSA=9999 + ..S:ECXLOSP>9999 ECXLOSP=9999 + ..;- Production Division + ..S ECXPDIV="" + ..I ECXLOGIC>2003 S ECXPDIV=$S(WRD="":"",1:$$NPDIV(WRD)) + ..S (ECXALNPI,ECXANNPI,ECXPLNPI,ECXPNNPI)="" + ..; + ..;- Observation patient indicator (YES/NO) + ..S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) + ..; + ..;- Chg outpat with movemnt/discharge to inpat (to comply w/existing business rule) + ..I ECXA="O"&(ECXOBS="NO")&(ECXMVD1) S ECXA="I" + ..; + ..;- Get providers person classes + .. S ECXATLPC=$$PRVCLASS^ECXUTL($E(ECXATTL,2,999),ECXADT) + .. S ECXPRNPC=$$PRVCLASS^ECXUTL($E(ECXPRVN,2,999),ECXADT) + .. S ECXATNPC=$$PRVCLASS^ECXUTL($E(ECXATTN,2,999),ECXADT) + .. S ECXPRLPC=$$PRVCLASS^ECXUTL($E(ECXPRVL,2,999),ECXADT) + ..; + ..;- If no encounter number don't file record + ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADT,,ECXTS,ECXOBS,ECHEAD,,) + ..D:ECXENC'="" FILE + D KPATDEM^ECXUTL2 + Q + ; +NPDIV(WRD) ;National Production Division + N DIV + S DIV=$$GET1^DIQ(42,WRD,.015,"I") + Q $S(DIV="":"",1:$$GETDIV^ECXDEPT(DIV)) + ; +SETLOC(ECXDFN,ECXADM,ECXPRO,ECXLOC) ;setup the local array from the ATS index + ; output + ; ECXLOC = local array (passed by reference) + ; + N SUB3,SUB4,SUB5,SPC,PRV,ATT,MOV + S SUB3=0 + F S SUB3=$O(^DGPM("ATS",ECXDFN,ECXADM,SUB3)) Q:SUB3="" D + .S (SUB4,SUB5)=0 + .S SUB4=$O(^DGPM("ATS",ECXDFN,ECXADM,SUB3,SUB4)) + .S SUB5=$O(^DGPM("ATS",ECXDFN,ECXADM,SUB3,SUB4,SUB5)) + .S ECXLOC(SUB3,SUB4,SUB5)="",SPC=$G(^TMP($J,"ECXTMP",SUB4)) + .S DATA=$G(^DGPM(SUB5,0)),PRV=$P(DATA,U,8),ATT=$P(DATA,U,19) + .S MOV=$P(DATA,U,14) + .S:PRV]"" PRV=ECXPRO_PRV S:ATT]"" ATT=ECXPRO_ATT + .S ECXLOC(SUB3,SUB4,SUB5)=SPC_U_PRV_U_ATT_U_MOV + Q + ; +FINDLOC(ECXTSD,ECXLOC,ECXSPC,ECXPRV,ECXATT,ECXMOV,ECXTRT) ;find local array node for current ts movement + ; input + ; ECXTSD = inverse date/time for current ts movement; required + ; ECXLOC = local array; passed by reference; required + ; output; data from record contained in MOVE + ; ECXSPC = piece 1 of LOC (passed by reference) + ; ECXPRV = piece 2 of LOC concatenated to PRO (passed by reference) + ; ECXATT = piece 3 of LOC concatenated to PRO (passed by reference) + ; ECXMOV = piece 4 of LOC (passed by reference) + ; ECXTRT = pointer to file #45.7 + ; + N SUB3,SUB4,SUB5,LOC + S (ECXSPC,ECXPRV,ECXATT,ECXMOV)="" + S SUB3=ECXTSD + I $D(ECXLOC(SUB3)) D + .S SUB4=$O(ECXLOC(SUB3,0)),SUB5=$O(ECXLOC(SUB3,SUB4,0)) + .S LOC=ECXLOC(SUB3,SUB4,SUB5),ECXTRT=SUB4,ECXSPC=$P(LOC,U) + .S ECXPRV=$P(LOC,U,2),ECXATT=$P(LOC,U,3),ECXMOV=$P(LOC,U,4) + Q + ; +FILE ;file the extract record + ;node0 + ;^dfn^ssn^name^i/o (ECXA)^date^product^adm date^d/c date^ + ;mov#^type^new ts^losing ts^losing ts los^ + ;losing attending^movement type^time^adm time^new provider^ + ;new attending^losing provider + ;node1 + ;mpi^dss dept^losing attending npi^new provider npi^new attending npi^ + ;losing provider npi^losing attending los^losing provider los^dom^ + ;observ pat ind^encounter num + ; + ;convert specialties to PTF Codes for transmission + ; + N ECXDATA + S ECXDATA=$$TSDATA^DGACT(42.4,+ECXSPCN,.ECXDATA) + S ECXSPCN=$G(ECXDATA(7)) + S ECXDATA=$$TSDATA^DGACT(42.4,+ECXSPCL,.ECXDATA) + S ECXSPCL=$G(ECXDATA(7)) + ;done + S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 + S ECODE=EC7_U_EC23_U_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U_ECXDATE_U_U + S ECODE=ECODE_ECXADMDT_U_ECXDCDT_U_ECDA_U_6_U_ECXSPCN_U_ECXSPCL_U + S ECODE=ECODE_ECXLOS_U_ECXATTL_U_ECMT_U_ECXTIME_U_ECXADMTM_U_ECXPRVN_U + S ECODE=ECODE_ECXATTN_U_ECXPRVL_U + S ECODE1=ECXMPI_U_ECXDSSD_U_ECXALNPI_U_ECXPNNPI_U_ECXANNPI_U_ECXPLNPI_U + S ECODE1=ECODE1_ECXLOSA_U_ECXLOSP_U_ECXDOM_U_ECXOBS_U_ECXENC_U_ECXPDIV + I ECXLOGIC>2005 S ECODE1=ECODE1_U_ECXATLPC_U_ECXPRNPC_U_ECXATNPC_U_ECXPRLPC + S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1 + S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA + I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 + Q + ; +SETUP ;Set required input for ECXTRAC + S ECHEAD="TRT" + D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) + Q + ; +QUE ; entry point for the background requeuing handled by ECXTAUTO + D SETUP,QUE^ECXTAUTO,^ECXKILL + Q diff --git a/r/DSS_EXTRACTS-ECX/ECXUD.m b/r/DSS_EXTRACTS-ECX/ECXUD.m index 2d7cb5c2..98941d9d 100644 --- a/r/DSS_EXTRACTS-ECX/ECXUD.m +++ b/r/DSS_EXTRACTS-ECX/ECXUD.m @@ -1,184 +1,178 @@ -ECXUD ;ALB/JAP,BIR/DMA,PTD-Extract from UNIT DOSE EXTRACT DATA File (#728.904) ; 10/31/07 1:58pm - ;;3.0;DSS EXTRACTS;**10,8,24,33,39,46,49,71,84,92,107,105**;Dec 22, 1997;Build 70 -BEG ;entry point from option - I '$O(^ECX(728.904,"A",0)) W !,"There are no unit dose orders to extract",!! R X:5 K X Q - D SETUP I ECFILE="" Q - D ^ECXTRAC,^ECXKILL - Q - ; -START ;start package specific extract - S QFLG=0 - S ECED=ECED+.3 - F ECD=ECSD1:0 S ECD=$O(^ECX(728.904,"A",ECD)) Q:'ECD Q:ECD>ECED Q:QFLG D - .S ECXJ=0 F S ECXJ=$O(^ECX(728.904,"A",ECD,ECXJ)) Q:'ECXJ Q:QFLG I $D(^ECX(728.904,ECXJ,0)) D - ..S DATA=^ECX(728.904,ECXJ,0),^(1)=$P(EC23,U,2),^ECX(728.904,"AC",$P(EC23,U,2),ECXJ)="" D STUFF - K ^TMP($J,"ECXP") - Q - ; -STUFF ;get data - N X,W,OK,P1,P3,PSTAT,PT,ECXPHA,ON,ECDRG - S ECXDFN=$P(DATA,U,2),ECDRG=$P(DATA,U,4) - ; - ;get patient specific data - S ECXERR="" D PAT(ECXDFN,ECD,.ECXERR) - Q:ECXERR - ; - S ECXPRO=$P(DATA,U,7),ECPROIEN=+ECXPRO,ECXPRO=$E($P(ECXPRO,";",2))_$P(ECXPRO,";") - S ECXPRNPI=$$NPI^XUSNPI("Individual_ID",ECPROIEN,ECD) - S:+ECXPRNPI'>0 ECXPRNPI="" S ECXPRNPI=$P(ECXPRNPI,U) - S W=$P(DATA,U,6) - S ECXDIV=$P($G(^DIC(42,+W,0)),U,11),ECXW=$P($G(^DIC(42,+W,44)),U) - S ECXUDDT=$$ECXDATE^ECXUTL($P(DATA,U,3),ECXYM) - S ECXUDTM=$E($P($P(DATA,U,3),".",2)_"000000",1,6) - S ECXQTY=$P(DATA,U,5),ECXCOST=$P(DATA,U,8),ON=$P(DATA,U,10) - ;call pharmacy drug file (#50) api via ecxutl5 - S ECXPHA=$$PHAAPI^ECXUTL5(ECDRG) - S ECCAT=$P(ECXPHA,U,2),ECINV=$P(ECXPHA,U,4) - S ECINV=$S(ECINV["I":"I",1:"") - S ECNDC=$P(ECXPHA,U,3) - S ECNFC=$$RJ^XLFSTR($P(ECNDC,"-"),6,0)_$$RJ^XLFSTR($P(ECNDC,"-",2),4,0)_$$RJ^XLFSTR($P(ECNDC,"-",3),2,0),ECNFC=$TR(ECNFC,"*",0) - S P1=$P(ECXPHA,U,5),P3=$P(ECXPHA,U,6),X="PSNAPIS" - X ^%ZOSF("TEST") I $T S ECNFC=$$DSS^PSNAPIS(P1,P3,ECXYM)_ECNFC - I $L(ECNFC)=12 S ECNFC=$$RJ^XLFSTR(P1,4,0)_$$RJ^XLFSTR(P3,3,0)_ECNFC - ; - Department and National Production Division - ;- Use of DSS Department postponed [S ECXDSSD=$$UDP^ECXDEPT(ECXDIV)] - S ECXDSSD="" - S ECXPDIV=$$GETDIV^ECXDEPT(ECXDIV) - ;- Observation patient indicator (YES/NO) - S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) - ;- Ordering Date, Ordering Stop Code - S ECXORDDT=$TR($$FMTE^XLFDT($P(DATA,U,9),"7DF")," /","0") - S ECXORDST="" I ECXA="O" D - .;Get ordering stop code based on FY 2006 logic for outpatient - .S ECXORDST=$$DOUDO^ECXUTL5(ECXDFN,ON) - ;Ordering Provider Person Class - S ECXOPPC=$$PRVCLASS^ECXUTL($E(ECXPRO,2,999),$P(DATA,U,9)) - ;BCMA data (place holder) - S (ECXBCDD,ECXBCDG,ECXBCUA,ECXBCIF)="" - ;- Set national patient record flag if exist - D NPRF^ECXUTL5 - ;- If no encounter number don't file record - S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADM,$P(DATA,U,3),ECXTS,ECXOBS,ECHEAD,,) - D:ECXENC'="" FILE - Q - ; -PAT(ECXDFN,ECXDATE,ECXERR) ;get demographics from patient file - ;init variables - S (ECXCAT,ECXSTAT,ECXPRIOR,ECXSBGRP,ECXOEF,ECXOEFDT)="" - ;get patient data if saved - I $D(^TMP($J,"ECXP",ECXDFN)) D - .S PT=^TMP($J,"ECXP",ECXDFN),ECXPNM=$P(PT,U),ECXSSN=$P(PT,U,2) - .S ECXMPI=$P(PT,U,3),ECXDOB=$P(PT,U,4) - .S ECXELIG=$P(PT,U,5),ECXSEX=$P(PT,U,6) - .S ECXSTATE=$P(PT,U,7),ECXCNTY=$P(PT,U,8),ECXZIP=$P(PT,U,9) - .S ECXVET=$P(PT,U,10),ECXPOS=$P(PT,U,11),ECXPST=$P(PT,U,12) - .S ECXPLOC=$P(PT,U,13),ECXRST=$P(PT,U,14),ECXAST=$P(PT,U,15) - .S ECXAOL=$P(PT,U,16),ECXPHI=$P(PT,U,17),ECXMST=$P(PT,U,18) - .S ECXENRL=$P(PT,U,19),ECXCNHU=$P(PT,U,20),ECXCAT=$P(PT,U,21) - .S ECXSTAT=$P(PT,U,22),ECXPRIOR=$P(PT,U,23),ECXHNCI=$P(PT,U,24) - .S ECXETH=$P(PT,U,25),ECXRC1=$P(PT,U,26),ECXMTST=$P(PT,U,27) - .S PT1=$G(^TMP($J,"ECXP",ECXDFN,1)),ECXERI=$P(PT1,U),ECXEST=$P(PT1,U,2),ECXOEF=$P(PT1,U,3),ECXOEFDT=$P(PT1,U,4) - .I $$ENROLLM^ECXUTL2(ECXDFN) - ;set patient data - I '$D(^TMP($J,"ECXP",ECXDFN)) D Q:'OK - .K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECXDATE,"."),"1;2;3;5",.ECXPAT) - .I 'OK K ECXPAT S ECXERR=1 Q - .S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI") - .S ECXDOB=ECXPAT("DOB"),ECXELIG=ECXPAT("ELIG"),ECXSEX=ECXPAT("SEX") - .S ECXSTATE=ECXPAT("STATE"),ECXCNTY=ECXPAT("COUNTY") - .S ECXZIP=ECXPAT("ZIP"),ECXVET=ECXPAT("VET") - .S ECXPOS=ECXPAT("POS"),ECXPST=ECXPAT("POW STAT") - .S ECXPLOC=ECXPAT("POW LOC"),ECXRST=ECXPAT("IR STAT") - .S ECXAST=ECXPAT("AO STAT"),ECXAOL=ECXPAT("AOL") - .S ECXPHI=ECXPAT("PHI"),ECXMST=ECXPAT("MST STAT") - .S ECXENRL=ECXPAT("ENROLL LOC"),ECXMTST=ECXPAT("MEANS") - .;OEF/OIF data - .S ECXOEF=ECXPAT("ECXOEF") - .S ECXOEFDT=ECXPAT("ECXOEFDT") - .;get CNHU status - .S ECXCNHU=$$CNHSTAT^ECXUTL4(ECXDFN) - .;get enrollment data (category, status and priority) - .I $$ENROLLM^ECXUTL2(ECXDFN) - .; - Head and Neck Cancer Indicator - .S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) - .; - Race and Ethnicity - .S ECXETH=ECXPAT("ETHNIC") - .S ECXRC1=ECXPAT("RACE1") - .;get emergency response indicator (FEMA) - .S ECXERI=ECXPAT("ERI") - .S ECXEST=ECXPAT("EC STAT") - .;save for later - .S ^TMP($J,"ECXP",ECXDFN)=ECXPNM_U_ECXSSN_U_ECXMPI_U_ECXDOB_U_ECXELIG_U_ECXSEX_U_ECXSTATE_U_ECXCNTY_U_ECXZIP_U_ECXVET_U_ECXPOS_U_ECXPST_U_ECXPLOC_U_ECXRST_U_ECXAST - .S ^TMP($J,"ECXP",ECXDFN)=^TMP($J,"ECXP",ECXDFN)_U_ECXAOL_U_ECXPHI_U_ECXMST_U_ECXENRL_U_ECXCNHU_U_ECXCAT_U_ECXSTAT_U_ECXPRIOR_U_ECXHNCI_U_ECXETH_U_ECXRC1_U_ECXMTST - .S ^TMP($J,"ECXP",ECXDFN,1)=ECXERI_U_ECXEST_U_ECXOEF_U_ECXOEFDT - ; - ;get inpatient data - S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECXA=$P(X,U),ECXMN=$P(X,U,2) - S ECXTS=$P(X,U,3),ECXADM=$P(X,U,4),ECXDOM=$P(X,U,10) - ; - ;get primary care data - S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXDATE,".")) - S ECPTTM=$P(X,U),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4) - S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7) - Q - ; -FILE ;file record - ;node0 - ;facility^dfn^ssn^name^in/out^day^drug category^quantity^ward^ - ;provider^cost^mov #^treat spec^ndc^new feeder key^investigational^ - ;udp time^adm date^adm time - ;node1 - ;mpi^dss dept^provider npi^dom^observ pat ind^encounter num^ - ;prod div code^means tst^elig^dob^sex^state^county^zip+4^vet^ - ;period of svc^pow stat^pow loc^ir status^ao status^ao loc^ - ;purple heart ind.^mst status^cnh/sh status^enrollment loc^ - ;enrollment cat^enrollment status^enrollment priority^pc team^ - ;pc provider^pc provider npi^pc provider p.class^assoc. pc provider^ - ;assoc. pc provider npi^assoc. pc provider p.class - ;node2 - ;ordering date^ordering stop code^head & neck cancer ind.^ethnicity^ - ;race1^bcma drug dispensed^bcma dose given^bcma unit of - ;administration^bcma icu flag^ordering provider person class^ - ;^enrollment priority ECXPRIOR_enrollment subgroup - ;ECXSBGRP^user enrollee ECXUESTA^patient type ECXPTYPE^combat vet - ;elig ECXCVE^combat vet elig end date ECXCVEDT^enc cv eligible - ;ECXCVENC^national patient record flag ECXNPRFI^emerg resp indic(FEMA) - ;ECXERI^environ contamin ECXEST^OEF/OIF ECXOEF^OEF/OIF return date ECXOEFDT^associate pc provider npi ECASNPI^primary care provider npi ECPTNPI^provider npi ECXPRNPI - N DA,DIK - S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 - S ECODE=EC7_U_EC23_U_ECXDIV_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U - S ECODE=ECODE_ECXUDDT_U_ECCAT_U_ECXQTY_U_ECXW_U_ECXPRO_U_ECXCOST_U - S ECODE=ECODE_ECXMN_U_ECXTS_U_ECNDC_U_ECNFC_U_ECINV_U_ECXUDTM_U - ;convert specialty to PTF Code for transmission - N ECXDATA - S ECXDATA=$$TSDATA^DGACT(42.4,+ECXTS,.ECXDATA) - S ECXTS=$G(ECXDATA(7)) - ;done - S ECODE=ECODE_$$ECXDATE^ECXUTL(ECXADM,ECXYM)_U - S ECODE=ECODE_$$ECXTIME^ECXUTL(ECXADM)_U - S ECODE1=ECXMPI_U_ECXDSSD_U_U_ECXDOM_U_ECXOBS_U_ECXENC_U - S ECODE1=ECODE1_ECXPDIV_U_ECXMTST_U_ECXELIG_U_ECXDOB_U_ECXSEX_U - S ECODE1=ECODE1_ECXSTATE_U_ECXCNTY_U_ECXZIP_U_ECXVET_U_ECXPOS_U - S ECODE1=ECODE1_ECXPST_U_ECXPLOC_U_ECXRST_U_ECXAST_U - S ECODE1=ECODE1_ECXAOL_U_ECXPHI_U_ECXMST_U_ECXCNHU_U_ECXENRL_U - S ECODE1=ECODE1_ECXCAT_U_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECPTTM_U_ECPTPR_U - S ECODE1=ECODE1_U_ECCLAS_U_ECASPR_U_U_ECCLAS2_U - S ECODE2=ECXORDDT_U_ECXORDST_U_ECXHNCI_U_ECXETH_U_ECXRC1 - I ECXLOGIC>2003 S ECODE2=ECODE2_U_ECXBCDD_U_ECXBCDG_U_ECXBCUA_U_ECXBCIF_U_ECXOPPC - I ECXLOGIC>2004 S ECODE2=ECODE2_U_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI - I ECXLOGIC>2006 S ECODE2=ECODE2_U_ECXERI_U_ECXEST - I ECXLOGIC>2007 S ECODE2=ECODE2_U_ECXOEF_U_ECXOEFDT_U_ECASNPI_U_ECPTNPI_U_ECXPRNPI - S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1 - S ^ECX(ECFILE,EC7,2)=ECODE2,ECRN=ECRN+1 - S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA - I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 - Q - ; -SETUP ;Set required input for ECXTRAC - S ECHEAD="UDP" - D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) - Q - ; -QUE ; entry point for the background requeuing handled by ECXTAUTO - D SETUP,QUE^ECXTAUTO,^ECXKILL - Q +ECXUD ;ALB/JAP,BIR/DMA,PTD-Extract from UNIT DOSE EXTRACT DATA File (#728.904) ;4/19/2007 + ;;3.0;DSS EXTRACTS;**10,8,24,33,39,46,49,71,84,92,107**;Dec 22, 1997;Build 9 +BEG ;entry point from option + I '$O(^ECX(728.904,"A",0)) W !,"There are no unit dose orders to extract",!! R X:5 K X Q + D SETUP I ECFILE="" Q + D ^ECXTRAC,^ECXKILL + Q + ; +START ;start package specific extract + S QFLG=0 + S ECED=ECED+.3 + F ECD=ECSD1:0 S ECD=$O(^ECX(728.904,"A",ECD)) Q:'ECD Q:ECD>ECED Q:QFLG D + .S ECXJ=0 F S ECXJ=$O(^ECX(728.904,"A",ECD,ECXJ)) Q:'ECXJ Q:QFLG I $D(^ECX(728.904,ECXJ,0)) D + ..S DATA=^ECX(728.904,ECXJ,0),^(1)=$P(EC23,U,2),^ECX(728.904,"AC",$P(EC23,U,2),ECXJ)="" D STUFF + K ^TMP($J,"ECXP") + Q + ; +STUFF ;get data + N X,W,OK,P1,P3,PSTAT,PT,ECXPHA,ON,ECDRG + S ECXDFN=$P(DATA,U,2),ECDRG=$P(DATA,U,4) + ; + ;get patient specific data + S ECXERR="" D PAT(ECXDFN,ECD,.ECXERR) + Q:ECXERR + ; + S ECXPRO=$P(DATA,U,7),ECXPRO=$E($P(ECXPRO,";",2))_$P(ECXPRO,";") + S ECXPRNPI="",W=$P(DATA,U,6) + S ECXDIV=$P($G(^DIC(42,+W,0)),U,11),ECXW=$P($G(^DIC(42,+W,44)),U) + S ECXUDDT=$$ECXDATE^ECXUTL($P(DATA,U,3),ECXYM) + S ECXUDTM=$E($P($P(DATA,U,3),".",2)_"000000",1,6) + S ECXQTY=$P(DATA,U,5),ECXCOST=$P(DATA,U,8),ON=$P(DATA,U,10) + ;call pharmacy drug file (#50) api via ecxutl5 + S ECXPHA=$$PHAAPI^ECXUTL5(ECDRG) + S ECCAT=$P(ECXPHA,U,2),ECINV=$P(ECXPHA,U,4) + S ECINV=$S(ECINV["I":"I",1:"") + S ECNDC=$P(ECXPHA,U,3) + S ECNFC=$$RJ^XLFSTR($P(ECNDC,"-"),6,0)_$$RJ^XLFSTR($P(ECNDC,"-",2),4,0)_$$RJ^XLFSTR($P(ECNDC,"-",3),2,0),ECNFC=$TR(ECNFC,"*",0) + S P1=$P(ECXPHA,U,5),P3=$P(ECXPHA,U,6),X="PSNAPIS" + X ^%ZOSF("TEST") I $T S ECNFC=$$DSS^PSNAPIS(P1,P3,ECXYM)_ECNFC + I $L(ECNFC)=12 S ECNFC=$$RJ^XLFSTR(P1,4,0)_$$RJ^XLFSTR(P3,3,0)_ECNFC + ; - Department and National Production Division + ;- Use of DSS Department postponed [S ECXDSSD=$$UDP^ECXDEPT(ECXDIV)] + S ECXDSSD="" + S ECXPDIV=$$GETDIV^ECXDEPT(ECXDIV) + ;- Observation patient indicator (YES/NO) + S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) + ;- Ordering Date, Ordering Stop Code + S ECXORDDT=$TR($$FMTE^XLFDT($P(DATA,U,9),"7DF")," /","0") + S ECXORDST="" I ECXA="O" D + .;Get ordering stop code based on FY 2006 logic for outpatient + .S ECXORDST=$$DOUDO^ECXUTL5(ECXDFN,ON) + ;Ordering Provider Person Class + S ECXOPPC=$$PRVCLASS^ECXUTL($E(ECXPRO,2,999),$P(DATA,U,9)) + ;BCMA data (place holder) + S (ECXBCDD,ECXBCDG,ECXBCUA,ECXBCIF)="" + ;- Set national patient record flag if exist + D NPRF^ECXUTL5 + ;- If no encounter number don't file record + S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADM,$P(DATA,U,3),ECXTS,ECXOBS,ECHEAD,,) + D:ECXENC'="" FILE + Q + ; +PAT(ECXDFN,ECXDATE,ECXERR) ;get demographics from patient file + ;init variables + S (ECXCAT,ECXSTAT,ECXPRIOR,ECXSBGRP)="" + ;get patient data if saved + I $D(^TMP($J,"ECXP",ECXDFN)) D + .S PT=^TMP($J,"ECXP",ECXDFN),ECXPNM=$P(PT,U),ECXSSN=$P(PT,U,2) + .S ECXMPI=$P(PT,U,3),ECXDOB=$P(PT,U,4) + .S ECXELIG=$P(PT,U,5),ECXSEX=$P(PT,U,6) + .S ECXSTATE=$P(PT,U,7),ECXCNTY=$P(PT,U,8),ECXZIP=$P(PT,U,9) + .S ECXVET=$P(PT,U,10),ECXPOS=$P(PT,U,11),ECXPST=$P(PT,U,12) + .S ECXPLOC=$P(PT,U,13),ECXRST=$P(PT,U,14),ECXAST=$P(PT,U,15) + .S ECXAOL=$P(PT,U,16),ECXPHI=$P(PT,U,17),ECXMST=$P(PT,U,18) + .S ECXENRL=$P(PT,U,19),ECXCNHU=$P(PT,U,20),ECXCAT=$P(PT,U,21) + .S ECXSTAT=$P(PT,U,22),ECXPRIOR=$P(PT,U,23),ECXHNCI=$P(PT,U,24) + .S ECXETH=$P(PT,U,25),ECXRC1=$P(PT,U,26),ECXMTST=$P(PT,U,27) + .S PT1=$G(^TMP($J,"ECXP",ECXDFN,1)),ECXERI=$P(PT1,U),ECXEST=$P(PT1,U,2) + .I $$ENROLLM^ECXUTL2(ECXDFN) + ;set patient data + I '$D(^TMP($J,"ECXP",ECXDFN)) D Q:'OK + .K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECXDATE,"."),"1;2;3;5",.ECXPAT) + .I 'OK K ECXPAT S ECXERR=1 Q + .S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI") + .S ECXDOB=ECXPAT("DOB"),ECXELIG=ECXPAT("ELIG"),ECXSEX=ECXPAT("SEX") + .S ECXSTATE=ECXPAT("STATE"),ECXCNTY=ECXPAT("COUNTY") + .S ECXZIP=ECXPAT("ZIP"),ECXVET=ECXPAT("VET") + .S ECXPOS=ECXPAT("POS"),ECXPST=ECXPAT("POW STAT") + .S ECXPLOC=ECXPAT("POW LOC"),ECXRST=ECXPAT("IR STAT") + .S ECXAST=ECXPAT("AO STAT"),ECXAOL=ECXPAT("AOL") + .S ECXPHI=ECXPAT("PHI"),ECXMST=ECXPAT("MST STAT") + .S ECXENRL=ECXPAT("ENROLL LOC"),ECXMTST=ECXPAT("MEANS") + .;get CNHU status + .S ECXCNHU=$$CNHSTAT^ECXUTL4(ECXDFN) + .;get enrollment data (category, status and priority) + .I $$ENROLLM^ECXUTL2(ECXDFN) + .; - Head and Neck Cancer Indicator + .S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) + .; - Race and Ethnicity + .S ECXETH=ECXPAT("ETHNIC") + .S ECXRC1=ECXPAT("RACE1") + .;get emergency response indicator (FEMA) + .S ECXERI=ECXPAT("ERI") + .S ECXEST=ECXPAT("EC STAT") + .;save for later + .S ^TMP($J,"ECXP",ECXDFN)=ECXPNM_U_ECXSSN_U_ECXMPI_U_ECXDOB_U_ECXELIG_U_ECXSEX_U_ECXSTATE_U_ECXCNTY_U_ECXZIP_U_ECXVET_U_ECXPOS_U_ECXPST_U_ECXPLOC_U_ECXRST_U_ECXAST + .S ^TMP($J,"ECXP",ECXDFN)=^TMP($J,"ECXP",ECXDFN)_U_ECXAOL_U_ECXPHI_U_ECXMST_U_ECXENRL_U_ECXCNHU_U_ECXCAT_U_ECXSTAT_U_ECXPRIOR_U_ECXHNCI_U_ECXETH_U_ECXRC1_U_ECXMTST + .S ^TMP($J,"ECXP",ECXDFN,1)=ECXERI_U_ECXEST + ; + ;get inpatient data + S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECXA=$P(X,U),ECXMN=$P(X,U,2) + S ECXTS=$P(X,U,3),ECXADM=$P(X,U,4),ECXDOM=$P(X,U,10) + ; + ;get primary care data + S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXDATE,".")) + S ECPTTM=$P(X,U),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4) + S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7) + Q + ; +FILE ;file record + ;node0 + ;facility^dfn^ssn^name^in/out^day^drug category^quantity^ward^ + ;provider^cost^mov #^treat spec^ndc^new feeder key^investigational^ + ;udp time^adm date^adm time + ;node1 + ;mpi^dss dept^provider npi^dom^observ pat ind^encounter num^ + ;prod div code^means tst^elig^dob^sex^state^county^zip+4^vet^ + ;period of svc^pow stat^pow loc^ir status^ao status^ao loc^ + ;purple heart ind.^mst status^cnh/sh status^enrollment loc^ + ;enrollment cat^enrollment status^enrollment priority^pc team^ + ;pc provider^pc provider npi^pc provider p.class^assoc. pc provider^ + ;assoc. pc provider npi^assoc. pc provider p.class + ;node2 + ;ordering date^ordering stop code^head & neck cancer ind.^ethnicity^ + ;race1^bcma drug dispensed^bcma dose given^bcma unit of + ;administration^bcma icu flag^ordering provider person class^ + ;^enrollment priority ECXPRIOR_enrollment subgroup + ;ECXSBGRP^user enrollee ECXUESTA^patient type ECXPTYPE^combat vet + ;elig ECXCVE^combat vet elig end date ECXCVEDT^enc cv eligible + ;ECXCVENC^national patient record flag ECXNPRFI^emerg resp indic(FEMA) + ;ECXERI^environ contamin ECXEST + N DA,DIK + S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 + S ECODE=EC7_U_EC23_U_ECXDIV_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U + S ECODE=ECODE_ECXUDDT_U_ECCAT_U_ECXQTY_U_ECXW_U_ECXPRO_U_ECXCOST_U + S ECODE=ECODE_ECXMN_U_ECXTS_U_ECNDC_U_ECNFC_U_ECINV_U_ECXUDTM_U + ;convert specialty to PTF Code for transmission + N ECXDATA + S ECXDATA=$$TSDATA^DGACT(42.4,+ECXTS,.ECXDATA) + S ECXTS=$G(ECXDATA(7)) + ;done + S ECODE=ECODE_$$ECXDATE^ECXUTL(ECXADM,ECXYM)_U + S ECODE=ECODE_$$ECXTIME^ECXUTL(ECXADM)_U + S ECODE1=ECXMPI_U_ECXDSSD_U_ECXPRNPI_U_ECXDOM_U_ECXOBS_U_ECXENC_U + S ECODE1=ECODE1_ECXPDIV_U_ECXMTST_U_ECXELIG_U_ECXDOB_U_ECXSEX_U + S ECODE1=ECODE1_ECXSTATE_U_ECXCNTY_U_ECXZIP_U_ECXVET_U_ECXPOS_U + S ECODE1=ECODE1_ECXPST_U_ECXPLOC_U_ECXRST_U_ECXAST_U + S ECODE1=ECODE1_ECXAOL_U_ECXPHI_U_ECXMST_U_ECXCNHU_U_ECXENRL_U + S ECODE1=ECODE1_ECXCAT_U_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECPTTM_U_ECPTPR_U + S ECODE1=ECODE1_ECPTNPI_U_ECCLAS_U_ECASPR_U_ECASNPI_U_ECCLAS2_U + S ECODE2=ECXORDDT_U_ECXORDST_U_ECXHNCI_U_ECXETH_U_ECXRC1 + I ECXLOGIC>2003 S ECODE2=ECODE2_U_ECXBCDD_U_ECXBCDG_U_ECXBCUA_U_ECXBCIF_U_ECXOPPC + I ECXLOGIC>2004 S ECODE2=ECODE2_U_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI + I ECXLOGIC>2006 S ECODE2=ECODE2_U_ECXERI_U_ECXEST + S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1 + S ^ECX(ECFILE,EC7,2)=ECODE2,ECRN=ECRN+1 + S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA + I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 + Q + ; +SETUP ;Set required input for ECXTRAC + S ECHEAD="UDP" + D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) + Q + ; +QUE ; entry point for the background requeuing handled by ECXTAUTO + D SETUP,QUE^ECXTAUTO,^ECXKILL + Q diff --git a/r/DSS_EXTRACTS-ECX/ECXUPRO.m b/r/DSS_EXTRACTS-ECX/ECXUPRO.m index 931f34cf..020a4290 100644 --- a/r/DSS_EXTRACTS-ECX/ECXUPRO.m +++ b/r/DSS_EXTRACTS-ECX/ECXUPRO.m @@ -1,115 +1,114 @@ -ECXUPRO ;ALB/TJL-Prosthetic Extract Unusual Cost Report ; 1/08/08 1:00pm - ;;3.0;DSS EXTRACTS;**49,111**;July 1, 2003;Build 4 - ; -EN ; entry point - N X,Y,DATE,ECRUN,ECXDESC,ECXSAVE,ECXTL,ECTHLD - N ECINST,ECSD,ECSD1,ECSTART,ECED,ECEND,ECXERR,QFLG - S QFLG=0 - S ECINST=$$PDIV^ECXPUTL - ; get today's date - D NOW^%DTC S DATE=X,Y=$E(%,1,12) D DD^%DT S ECRUN=$P(Y,"@") K %DT - D BEGIN Q:QFLG - D SELECT Q:QFLG - S ECXDESC="Prosthetic Extract Unusual Cost Report" - S ECXSAVE("EC*")="" - W !!,"This report requires 132-column format." - D EN^XUTMDEVQ("PROCESS^ECXUPRO",ECXDESC,.ECXSAVE) - I POP W !!,"No device selected...exiting.",! Q - I IO'=IO(0) D ^%ZISC - D HOME^%ZIS - D AUDIT^ECXKILL - Q - ; -BEGIN ; display report description - W @IOF - W !,"This report prints a listing of unusual costs that would be" - W !,"generated by the Prosthetic extract (PRO) as determined by a" - W !,"user-defined threshold value. It should be run prior to the" - W !,"generation of the actual extract(s) to identify and fix, as" - W !,"necessary, any costs determined to be erroneous." - W !!,"Unusual costs are those where the Cost of Transaction is" - W !,"greater than the threshold value." - W !!,"Note: The threshold can be set after a report is selected." - W !!,"Run times for this report will vary depending upon the size of" - W !,"the extract and could take as long as 30 minutes or more to" - W !,"complete. This report has no effect on the actual extracts and" - W !,"can be run as needed." - W !!,"The report is sorted by Feeder Key, then by descending Cost of" - W !,"Transaction and SSN." - S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q - W:$Y!($E(IOST)="C") @IOF,!! - Q - ; -SELECT ; user inputs for threshold cost and date range - N DONE,OUT - ; allow user to set threshold cost - S ECTHLD=500 - W !!,"The default threshold cost for the Prosthetic extract is $"_ECTHLD_".00." - S DIR(0)="Y",DIR("A")="Would you like to change the threshold?",DIR("B")="NO" D ^DIR K DIR I X["^" S QFLG=1 Q - I Y D - .W !!,"Cost > threshold" - .S DIR(0)="N^0:999999",DIR("A")="Enter the new threshold cost" D ^DIR K DIR S ECTHLD=Y I X["^" S QFLG=1 Q - ; get date range from user - W !!,"Enter the date range for which you would like to scan the Prosthetic",!,"Extract records.",! - S DONE=0 F S (ECED,ECSD)="" D Q:QFLG!DONE - .K %DT S %DT="AEX",%DT("A")="Starting with Date: ",%DT(0)=-DATE D ^%DT - .I Y<0 S QFLG=1 Q - .S ECSD=Y,ECSD1=ECSD-.1 - .D DD^%DT S ECSTART=Y - .K %DT S %DT="AEX",%DT("A")="Ending with Date: ",%DT(0)=-DATE D ^%DT - .I Y<0 S QFLG=1 Q - .I YIOSL D HEADER Q:QFLG - ....W !,$P(REC,U),?8,$P(REC,U,2),?21,$P(REC,U,3),?39,$P(REC,U,4),?70,$P(REC,U,5),?93,$$RJ^XLFSTR($P(REC,U,6),8),?110,$$RJ^XLFSTR($P(REC,U,7),11) - Q:QFLG - I COUNT=0 W !!,?8,"No unusual costs to report for this extract" -CLOSE ; - I $E(IOST)="C",'QFLG D - .S SS=22-$Y F JJ=1:1:SS W ! - .S DIR(0)="E" W ! D ^DIR K DIR - Q - ; -HEADER ;header and page control - N SS,JJ - I $E(IOST)="C" D - .S SS=22-$Y F JJ=1:1:SS W ! - .I PG>0 S DIR(0)="E" W ! D ^DIR K DIR S:'Y QFLG=1 - Q:QFLG - W:$Y!($E(IOST)="C") @IOF S PG=PG+1 - W !,"Prosthetic Extract Unusual Cost Report",?124,"Page: "_PG - W !,"Start Date: ",ECSTART,?97,"Report Run Date/Time: "_ECRUN - W !," End Date: ",ECEND,?97," Threshold Value: ",ECTHLD - W !!,?21,"Date of",?43,"PCE CPT/",?112,"Cost of" - W !,"Name",?11,"SSN",?21,"Service",?36,"HCPCS CODE & Modifiers" - W ?72,"Feeder Key",?93,"Quantity",?110,"Transaction" - W !,LN,! - Q - ; +ECXUPRO ;ALB/TJL-Prosthetic Extract Unusual Cost Report ; 7/1/03 1:00pm + ;;3.0;DSS EXTRACTS;**49**;July 1, 2003 + ; +EN ; entry point + N X,Y,DATE,ECRUN,ECXDESC,ECXSAVE,ECXTL,ECTHLD + N ECINST,ECSD,ECSD1,ECSTART,ECED,ECEND,ECXERR,QFLG + S QFLG=0 + S ECINST=$$PDIV^ECXPUTL + ; get today's date + D NOW^%DTC S DATE=X,Y=$E(%,1,12) D DD^%DT S ECRUN=$P(Y,"@") K %DT + D BEGIN Q:QFLG + D SELECT Q:QFLG + S ECXDESC="Prosthetic Extract Unusual Cost Report" + S ECXSAVE("EC*")="" + W !!,"This report requires 132-column format." + D EN^XUTMDEVQ("PROCESS^ECXUPRO",ECXDESC,.ECXSAVE) + I POP W !!,"No device selected...exiting.",! Q + I IO'=IO(0) D ^%ZISC + D HOME^%ZIS + D AUDIT^ECXKILL + Q + ; +BEGIN ; display report description + W @IOF + W !,"This report prints a listing of unusual costs that would be" + W !,"generated by the Prosthetic extract (PRO) as determined by a" + W !,"user-defined threshold value. It should be run prior to the" + W !,"generation of the actual extract(s) to identify and fix, as" + W !,"necessary, any costs determined to be erroneous." + W !!,"Unusual costs are those where the Cost of Transaction is" + W !,"greater than the threshold value." + W !!,"Note: The threshold can be set after a report is selected." + W !!,"Run times for this report will vary depending upon the size of" + W !,"the extract and could take as long as 30 minutes or more to" + W !,"complete. This report has no effect on the actual extracts and" + W !,"can be run as needed." + W !!,"The report is sorted by Feeder Key, then by descending Cost of" + W !,"Transaction and SSN." + S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q + W:$Y!($E(IOST)="C") @IOF,!! + Q + ; +SELECT ; user inputs for threshold cost and date range + N DONE,OUT + ; allow user to set threshold cost + S ECTHLD=500 + W !!,"The default threshold cost for the Prosthetic extract is $"_ECTHLD_".00." + S DIR(0)="Y",DIR("A")="Would you like to change the threshold?",DIR("B")="NO" D ^DIR K DIR I X["^" S QFLG=1 Q + I Y D + .W !!,"Cost > threshold" + .S DIR(0)="N^0:999999",DIR("A")="Enter the new threshold cost" D ^DIR K DIR S ECTHLD=Y I X["^" S QFLG=1 Q + ; get date range from user + W !!,"Enter the date range for which you would like to scan the Prosthetic",!,"Extract records.",! + S DONE=0 F S (ECED,ECSD)="" D Q:QFLG!DONE + .K %DT S %DT="AEX",%DT("A")="Starting with Date: ",%DT(0)=-DATE D ^%DT + .I Y<0 S QFLG=1 Q + .S ECSD=Y,ECSD1=ECSD-.1 + .D DD^%DT S ECSTART=Y + .K %DT S %DT="AEX",%DT("A")="Ending with Date: ",%DT(0)=-DATE D ^%DT + .I Y<0 S QFLG=1 Q + .I YIOSL D HEADER Q:QFLG + ...W !,$P(REC,U),?8,$P(REC,U,2),?21,$P(REC,U,3),?39,$P(REC,U,4),?70,$P(REC,U,5),?93,$$RJ^XLFSTR($P(REC,U,6),8),?110,$$RJ^XLFSTR($P(REC,U,7),11) + Q:QFLG + I COUNT=0 W !!,?8,"No unusual costs to report for this extract" +CLOSE ; + I $E(IOST)="C",'QFLG D + .S SS=22-$Y F JJ=1:1:SS W ! + .S DIR(0)="E" W ! D ^DIR K DIR + Q + ; +HEADER ;header and page control + N SS,JJ + I $E(IOST)="C" D + .S SS=22-$Y F JJ=1:1:SS W ! + .I PG>0 S DIR(0)="E" W ! D ^DIR K DIR S:'Y QFLG=1 + Q:QFLG + W:$Y!($E(IOST)="C") @IOF S PG=PG+1 + W !,"Prosthetic Extract Unusual Cost Report",?124,"Page: "_PG + W !,"Start Date: ",ECSTART,?97,"Report Run Date/Time: "_ECRUN + W !," End Date: ",ECEND,?97," Threshold Value: ",ECTHLD + W !!,?21,"Date of",?43,"PCE CPT/",?112,"Cost of" + W !,"Name",?11,"SSN",?21,"Service",?36,"HCPCS CODE & Modifiers" + W ?72,"Feeder Key",?93,"Quantity",?110,"Transaction" + W !,LN,! + Q + ; diff --git a/r/DSS_EXTRACTS-ECX/ECXUPRO1.m b/r/DSS_EXTRACTS-ECX/ECXUPRO1.m index 26f625dd..95afaf06 100644 --- a/r/DSS_EXTRACTS-ECX/ECXUPRO1.m +++ b/r/DSS_EXTRACTS-ECX/ECXUPRO1.m @@ -1,54 +1,54 @@ -ECXUPRO1 ;ALB/TJL-Prosthetics Extract Unusual Cost Report; 01/08/08 2:49pm - ;;3.0;DSS EXTRACTS;**49,111**;Jul 2, 2003;Build 4 - ; -EN ; entry point - N COUNT,ECDFN,ECD,PROCOST - K ^TMP($J) - S COUNT=0 - S ECD=ECSD1,ECED=ECED+.3 - D GETRECS - Q - ; -GETRECS ; get records that are over the threshold - N PDA,SUBDA,PROLB,PRO0,PROFORM - N DIC,DR,DA,DIQ - S QFLG=0,ECXLNE=1,ECXED1=ECED+.9999 - S PDA=ECSD1 - F S PDA=$O(^RMPR(660,"CT",PDA)) Q:(PDA>ECXED1)!('PDA)!(QFLG=1) D - .S SUBDA=0 - .F S SUBDA=$O(^RMPR(660,"CT",PDA,SUBDA)) Q:('SUBDA)!(QFLG=1) D - ..Q:'$D(^RMPR(660,SUBDA,0)) - ..S PRO0=^RMPR(660,SUBDA,0) - ..S PROLB=$G(^RMPR(660,SUBDA,"LB")) - ..K ECXP S DIC="^RMPR(660,",DR=".02;11",DA=SUBDA,DIQ(0)="EI" - ..S DIQ="ECXP" D EN^DIQ1 - ..S ECXDFN=$G(ECXP(660,SUBDA,.02,"I")) - ..S PROFORM=$G(ECXP(660,SUBDA,11,"E"))_U_$G(ECXP(660,SUBDA,11,"I")) - ..Q:'$$PATDEM^ECXUTL2(ECXDFN,PDA) - ..Q:'$$NTEG^ECXPRO1(ECXDFN,.ECXLNE,SUBDA,PRO0,PROLB,ECINST,PROFORM) - ..S PROCOST=$P(PRO0,U,16) - ..S:PROFORM["-3" PROCOST=$P(PROLB,U,9) - ..S:($P(PROFORM,U,2)=11)!($P(PROFORM,U,2)=12) PROCOST=0 - ..S:PROCOST="" PROCOST=0 - ..S PROCOST=(PROCOST+.5)\1 - ..S:PROCOST>999999 PROCOST=999999 - ..I PROCOST>ECTHLD D FILE - Q -FILE ; put records in temp file to print later - N OK,PROPAT,PRONAME,PROSSN,CPTCODE,ECXFEKEY,PROQTY - S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECD,"."),"1;",.PROPAT) - I 'OK Q - S PRONAME=PROPAT("NAME") - S PROSSN=PROPAT("SSN") - S PRODAY=$E(PDA,4,5)_"/"_$E(PDA,6,7)_"/"_$E(PDA,2,3) - S CPTCODE=$E(ECXHCPCS,1,5) - I PROFORM["-3" F ECXLAB="LAB","ORD" D FEEDINFO^ECXPRO2(ECXSRCE,CPTCODE,ECXTYPE,ECXSTAT2,ECXRQST,ECXRCST,ECXLAB) - I PROFORM'["-3" S ECXLAB="NONL" D FEEDINFO^ECXPRO2(ECXSRCE,CPTCODE,ECXTYPE,ECXSTAT2,ECXRQST,ECXRCST,ECXLAB) - S PROQTY=$P(PRO0,U,7) - S:(+PROQTY=0) PROQTY=1 - S PROQTY=$$RJ^XLFSTR(PROQTY,8,0) - S ^TMP($J,ECXFEKEY,-PROQTY,SUBDA,PROSSN)=PRONAME_U_PROSSN_U_PRODAY_U_ECXHCPCS_U_ECXFEKEY_U_PROQTY_U_"$"_$FNUMBER(PROCOST,",",2) - S COUNT=COUNT+1 - I COUNT#100=0 I $$S^ZTLOAD S (ZSTOP,ECXERR)=1 - Q -EXIT S ECXERR=1 Q +ECXUPRO1 ;ALB/TJL-Prosthetics Extract Unusual Cost Report; 7/2/03 2:49pm + ;;3.0;DSS EXTRACTS;**49**;Jul 2, 2003 + ; +EN ; entry point + N COUNT,ECDFN,ECD,PROCOST + K ^TMP($J) + S COUNT=0 + S ECD=ECSD1,ECED=ECED+.3 + D GETRECS + Q + ; +GETRECS ; get records that are over the threshold + N PDA,SUBDA,PROLB,PRO0,PROFORM + N DIC,DR,DA,DIQ + S QFLG=0,ECXLNE=1,ECXED1=ECED+.9999 + S PDA=ECSD1 + F S PDA=$O(^RMPR(660,"CT",PDA)) Q:(PDA>ECXED1)!('PDA)!(QFLG=1) D + .S SUBDA=0 + .F S SUBDA=$O(^RMPR(660,"CT",PDA,SUBDA)) Q:('SUBDA)!(QFLG=1) D + ..Q:'$D(^RMPR(660,SUBDA,0)) + ..S PRO0=^RMPR(660,SUBDA,0) + ..S PROLB=$G(^RMPR(660,SUBDA,"LB")) + ..K ECXP S DIC="^RMPR(660,",DR=".02;11",DA=SUBDA,DIQ(0)="EI" + ..S DIQ="ECXP" D EN^DIQ1 + ..S ECXDFN=$G(ECXP(660,SUBDA,.02,"I")) + ..S PROFORM=$G(ECXP(660,SUBDA,11,"E"))_U_$G(ECXP(660,SUBDA,11,"I")) + ..Q:'$$PATDEM^ECXUTL2(ECXDFN,PDA) + ..Q:'$$NTEG^ECXPRO1(ECXDFN,.ECXLNE,SUBDA,PRO0,PROLB,ECINST,PROFORM) + ..S PROCOST=$P(PRO0,U,16) + ..S:PROFORM["-3" PROCOST=$P(PROLB,U,9) + ..S:($P(PROFORM,U,2)=11)!($P(PROFORM,U,2)=12) PROCOST=0 + ..S:PROCOST="" PROCOST=0 + ..S PROCOST=(PROCOST+.5)\1 + ..S:PROCOST>999999 PROCOST=999999 + ..I PROCOST>ECTHLD D FILE + Q +FILE ; put records in temp file to print later + N OK,PROPAT,PRONAME,PROSSN,CPTCODE,ECXFEKEY,PROQTY + S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECD,"."),"1;",.PROPAT) + I 'OK Q + S PRONAME=PROPAT("NAME") + S PROSSN=PROPAT("SSN") + S PRODAY=$E(PDA,4,5)_"/"_$E(PDA,6,7)_"/"_$E(PDA,2,3) + S CPTCODE=$E(ECXHCPCS,1,5) + I PROFORM["-3" F ECXLAB="LAB","ORD" D FEEDINFO^ECXPRO2(ECXSRCE,CPTCODE,ECXTYPE,ECXSTAT2,ECXRQST,ECXRCST,ECXLAB) + I PROFORM'["-3" S ECXLAB="NONL" D FEEDINFO^ECXPRO2(ECXSRCE,CPTCODE,ECXTYPE,ECXSTAT2,ECXRQST,ECXRCST,ECXLAB) + S PROQTY=$P(PRO0,U,7) + S:(+PROQTY=0) PROQTY=1 + S PROQTY=$$RJ^XLFSTR(PROQTY,8,0) + S ^TMP($J,ECXFEKEY,-PROQTY,PROSSN)=PRONAME_U_PROSSN_U_PRODAY_U_ECXHCPCS_U_ECXFEKEY_U_PROQTY_U_"$"_$FNUMBER(PROCOST,",",2) + S COUNT=COUNT+1 + I COUNT#100=0 I $$S^ZTLOAD S (ZSTOP,ECXERR)=1 + Q +EXIT S ECXERR=1 Q diff --git a/r/DSS_EXTRACTS-ECX/ECXUSUR.m b/r/DSS_EXTRACTS-ECX/ECXUSUR.m index 265acd7e..7456feca 100644 --- a/r/DSS_EXTRACTS-ECX/ECXUSUR.m +++ b/r/DSS_EXTRACTS-ECX/ECXUSUR.m @@ -1,121 +1,120 @@ -ECXUSUR ;ALB/TJL-Surgery Extract Unusual Volume Report ; 9/4/07 8:19am - ;;3.0;DSS EXTRACTS;**49,71,84,93,105**;July 1, 2003;Build 70 - ; -EN ; entry point - N X,Y,DATE,ECRUN,ECXDESC,ECXSAVE,ECXTL,ECTHLD - N ECSD,ECSD1,ECSTART,ECED,ECEND,ECXERR,QFLG,ECXFLAG - S QFLG=0,ECTHLD="",ECXFLAG=$G(FLAG) - ; get today's date - D NOW^%DTC S DATE=X,Y=$E(%,1,12) D DD^%DT S ECRUN=$P(Y,"@") K %DT - I 'ECXFLAG D BEGIN Q:QFLG - D SELECT Q:QFLG - S ECXDESC=$S(ECXFLAG:"SUR Volume Report",1:"Surgery Extract Unusual Volume Report") - S ECXSAVE("EC*")="" - W !!,"This report requires 132-column format." - D EN^XUTMDEVQ("PROCESS^ECXUSUR",ECXDESC,.ECXSAVE) - I POP W !!,"No device selected...exiting.",! Q - I IO'=IO(0) D ^%ZISC - D HOME^%ZIS - D AUDIT^ECXKILL - Q - ; -BEGIN ; display report description - W @IOF - W !,"This report prints a listing of unusual volumes that would be" - W !,"generated by the Surgery extract (SUR) as determined by a" - W !,"user-defined threshold value. It should be run prior to the" - W !,"generation of the actual extract(s) to identify and fix, as" - W !,"necessary, any volumes determined to be erroneous." - W !!,"Unusual volumes are those where either the Operation Time," - W !,"Patient Time, Anesthesia Time, Recovery Room Time, OR Clean Time" - W !,"or Pt Holding Time field is greater than the threshold value." - W !!,"Note: The threshold can be set after a report is selected." - W !!,"Run times for this report will vary depending upon the size of" - W !,"the extract and could take as long as 30 minutes or more to" - W !,"complete. This report has no effect on the actual extracts and" - W !,"can be run as needed." - W !!,"The report is sorted by descending Volume and Case Number." - S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q - W:$Y!($E(IOST)="C") @IOF,!! - Q - ; -SELECT ; user inputs for threshold volume and date range - N DONE,OUT - ; allow user to set threshold volume - I 'ECXFLAG D - .S ECTHLD=25 - .W !!,"The default threshold volume for the Surgery extract is "_ECTHLD_"." - .W !,"The default threshold volume ("_ECTHLD_") equates to 6 hours." - .S DIR(0)="Y",DIR("A")="Would you like to change the threshold?",DIR("B")="NO" D ^DIR K DIR I X["^" S QFLG=1 Q - .I Y D - ..W !!,"Volume > threshold" - ..S DIR(0)="N^0:99",DIR("A")="Enter the new threshold volume" D ^DIR K DIR S ECTHLD=Y I X["^" S QFLG=1 Q - ; get date range from user - Q:QFLG - W !!,"Enter the date range for which you would like to scan the" - W !,"Surgery Extract records.",! - S DONE=0 F S (ECED,ECSD)="" D Q:QFLG!DONE - .K %DT S %DT="AEX",%DT("A")="Starting with Date: ",%DT(0)=-DATE D ^%DT - .I Y<0 S QFLG=1 Q - .S ECSD=Y,ECSD1=ECSD-.1 - .D DD^%DT S ECSTART=Y - .K %DT S %DT="AEX",%DT("A")="Ending with Date: ",%DT(0)=-DATE D ^%DT - .I Y<0 S QFLG=1 Q - .I YIOSL D HEADER Q:QFLG - ..W !,?1,$P(REC,U),?7,$P(REC,U,2),?18,$P(REC,U,3),?27,$P(REC,U,4) - ..W ?34,$P(REC,U,5),?55,$$RJ^XLFSTR($P(REC,U,7),4) - ..W ?66,$$RJ^XLFSTR($P(REC,U,11),4),?77,$$RJ^XLFSTR($P(REC,U,9),4) - ..W ?86,$$RJ^XLFSTR($P(REC,U,10),4),?93,$$RJ^XLFSTR($P(REC,U,6),4) - ..W ?103,$$RJ^XLFSTR($P(REC,U,8),4),?113,$P(REC,U,14) - ..W ?117,$P(REC,U,13) - Q:QFLG - I COUNT=0 W !!,?8,$S(ECXFLAG=1:"No surgery volumes to report for this extract",1:"No unusual volumes to report for this extract") -CLOSE ; - I $E(IOST)="C",'QFLG D - .S SS=22-$Y F JJ=1:1:SS W ! - .S DIR(0)="E" W ! D ^DIR K DIR - Q - ; -HEADER ;header and page control - N SS,JJ - I $E(IOST)="C" D - .S SS=22-$Y F JJ=1:1:SS W ! - .I PG>0 S DIR(0)="E" W ! D ^DIR K DIR S:'Y QFLG=1 - Q:QFLG - W:$Y!($E(IOST)="C") @IOF S PG=PG+1 - W !,$S(ECXFLAG:"SUR Volume Report",1:"Surgery Extract Unusual Volume Report"),?124,"Page: "_PG - W !,"Start Date: ",ECSTART,?97,"Report Run Date/Time: "_ECRUN - W !," End Date: ",ECEND I 'ECXFLAG W ?97," Threshold Value: ",ECTHLD - W !!,?28,"Case",?38,"Encounter",?52,"Pt Holding",?63,"Anesthesia",?75,"Patient",?83,"Operation",?93,"PACU",?101,"OR Clean",?111,"Canc/",?121,"Principal" - W !,?1,"Name",?10,"SSN",?20,"Day",?27,"Number",?40,"Number" - W ?54,"Time",?66,"Time",?77,"Time",?86,"Time",?93,"Time",?103,"Time" - W ?111,"Abort",?121,"Procedure" - W !,LN,! - Q - ; +ECXUSUR ;ALB/TJL-Surgery Extract Unusual Volume Report ; 4/11/06 10:44AM + ;;3.0;DSS EXTRACTS;**49,71,84,93**;July 1, 2003 + ; +EN ; entry point + N X,Y,DATE,ECRUN,ECXDESC,ECXSAVE,ECXTL,ECTHLD + N ECSD,ECSD1,ECSTART,ECED,ECEND,ECXERR,QFLG,ECXFLAG + S QFLG=0,ECTHLD="",ECXFLAG=$G(FLAG) + ; get today's date + D NOW^%DTC S DATE=X,Y=$E(%,1,12) D DD^%DT S ECRUN=$P(Y,"@") K %DT + I 'ECXFLAG D BEGIN Q:QFLG + D SELECT Q:QFLG + S ECXDESC=$S(ECXFLAG:"SUR Volume Report",1:"Surgery Extract Unusual Volume Report") + S ECXSAVE("EC*")="" + W !!,"This report requires 132-column format." + D EN^XUTMDEVQ("PROCESS^ECXUSUR",ECXDESC,.ECXSAVE) + I POP W !!,"No device selected...exiting.",! Q + I IO'=IO(0) D ^%ZISC + D HOME^%ZIS + D AUDIT^ECXKILL + Q + ; +BEGIN ; display report description + W @IOF + W !,"This report prints a listing of unusual volumes that would be" + W !,"generated by the Surgery extract (SUR) as determined by a" + W !,"user-defined threshold value. It should be run prior to the" + W !,"generation of the actual extract(s) to identify and fix, as" + W !,"necessary, any volumes determined to be erroneous." + W !!,"Unusual volumes are those where either the Operation Time," + W !,"Patient Time, Anesthesia Time, Recovery Room Time, OR Clean Time" + W !,"or Pt Holding Time field is greater than the threshold value." + W !!,"Note: The threshold can be set after a report is selected." + W !!,"Run times for this report will vary depending upon the size of" + W !,"the extract and could take as long as 30 minutes or more to" + W !,"complete. This report has no effect on the actual extracts and" + W !,"can be run as needed." + W !!,"The report is sorted by descending Volume and Case Number." + S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q + W:$Y!($E(IOST)="C") @IOF,!! + Q + ; +SELECT ; user inputs for threshold volume and date range + N DONE,OUT + ; allow user to set threshold volume + I 'ECXFLAG D + .S ECTHLD=25 + .W !!,"The default threshold volume for the Surgery extract is "_ECTHLD_"." + .W !,"The default threshold volume ("_ECTHLD_") equates to 6 hours." + .S DIR(0)="Y",DIR("A")="Would you like to change the threshold?",DIR("B")="NO" D ^DIR K DIR I X["^" S QFLG=1 Q + .I Y D + ..W !!,"Volume > threshold" + ..S DIR(0)="N^0:99",DIR("A")="Enter the new threshold volume" D ^DIR K DIR S ECTHLD=Y I X["^" S QFLG=1 Q + ; get date range from user + Q:QFLG + W !!,"Enter the date range for which you would like to scan the" + W !,"Surgery Extract records.",! + S DONE=0 F S (ECED,ECSD)="" D Q:QFLG!DONE + .K %DT S %DT="AEX",%DT("A")="Starting with Date: ",%DT(0)=-DATE D ^%DT + .I Y<0 S QFLG=1 Q + .S ECSD=Y,ECSD1=ECSD-.1 + .D DD^%DT S ECSTART=Y + .K %DT S %DT="AEX",%DT("A")="Ending with Date: ",%DT(0)=-DATE D ^%DT + .I Y<0 S QFLG=1 Q + .I YIOSL D HEADER Q:QFLG + ..W !,$P(REC,U),?6,$P(REC,U,2),?17,$P(REC,U,3),?26,$P(REC,U,4) + ..W ?33,$P(REC,U,5),?55,$$RJ^XLFSTR($P(REC,U,9),4) + ..W ?63,$$RJ^XLFSTR($P(REC,U,10),4),?74,$$RJ^XLFSTR($P(REC,U,11),4) + ..W ?83,$$RJ^XLFSTR($P(REC,U,6),4),?90,$$RJ^XLFSTR($P(REC,U,8),4) + ..W ?101,$$RJ^XLFSTR($P(REC,U,7),4),?114,$P(REC,U,13) + Q:QFLG + I COUNT=0 W !!,?8,$S(ECXFLAG=1:"No surgery volumes to report for this extract",1:"No unusual volumes to report for this extract") +CLOSE ; + I $E(IOST)="C",'QFLG D + .S SS=22-$Y F JJ=1:1:SS W ! + .S DIR(0)="E" W ! D ^DIR K DIR + Q + ; +HEADER ;header and page control + N SS,JJ + I $E(IOST)="C" D + .S SS=22-$Y F JJ=1:1:SS W ! + .I PG>0 S DIR(0)="E" W ! D ^DIR K DIR S:'Y QFLG=1 + Q:QFLG + W:$Y!($E(IOST)="C") @IOF S PG=PG+1 + W !,$S(ECXFLAG:"SUR Volume Report",1:"Surgery Extract Unusual Volume Report"),?124,"Page: "_PG + W !,"Start Date: ",ECSTART,?97,"Report Run Date/Time: "_ECRUN + W !," End Date: ",ECEND I 'ECXFLAG W ?97," Threshold Value: ",ECTHLD + W !!,?27,"Case",?37,"Encounter",?53,"Patient",?61,"Operation",?71,"Anesthesia",?83,"PACU",?89,"OR Clean",?99,"Pt Holding",?114,"Principal" + W !,"Name",?9,"SSN",?19,"Day",?26,"Number",?39,"Number" + W ?55,"Time",?63,"Time",?74,"Time",?83,"Time",?90,"Time",?101,"Time" + W ?114,"Procedure" + W !,LN,! + Q + ; diff --git a/r/DSS_EXTRACTS-ECX/ECXUSUR1.m b/r/DSS_EXTRACTS-ECX/ECXUSUR1.m index 29bd4af2..1405d7d7 100644 --- a/r/DSS_EXTRACTS-ECX/ECXUSUR1.m +++ b/r/DSS_EXTRACTS-ECX/ECXUSUR1.m @@ -1,124 +1,119 @@ -ECXUSUR1 ;ALB/TJL-Surgery Extract Unusual Volume Report ; 1/8/08 9:58am - ;;3.0;DSS EXTRACTS;**49,71,105,111**;July 1, 2003;Build 4 -EN ; - N ECHEAD,COUNT,TIMEDIF,ECXPROC - S ECHEAD="SUR" - S (COUNT,QFLG)=0,ECED=ECED+.3,ECD=ECSD1 - F S ECD=$O(^SRF("AC",ECD)) Q:('ECD)!(ECD>ECED)!(QFLG) D - .S ECD0=0 - .F S ECD0=$O(^SRF("AC",ECD,ECD0)) Q:'ECD0 D - ..I $D(^SRF(ECD0,0)) S ECXDFN=+$P(^(0),U,1) D STUFF Q:QFLG - Q - ; -STUFF ;gather data - N J,DATA1,DATA2,DATAOP,ECXNONL,ECXSTOP - S ECXDATE=ECD,ECXERR=0,ECXQ="" - Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXDATE,"1;2;3;5;") - S EC0=^SRF(ECD0,0) - S DATA1=$S($D(^SRF(ECD0,.1)):^(.1),1:"") - S DATA2=$S($D(^SRF(ECD0,.2)):^(.2),1:"") - S DATAOP=$S($D(^SRF(ECD0,"OP")):^("OP"),1:"") - S DATAPA=$S($D(^SRF(ECD0,1.1)):^(1.1),1:"") - S ECNO=$G(^SRF(ECD0,"NON")) - ;get data - S ECSS=$P($G(^SRO(137.45,+$P(EC0,U,4),0)),U,2) - S ECSS=$$RJ^XLFSTR($P($G(^DIC(45.3,+ECSS,0)),U),3,0) - S:ECSS="000" ECSS="999" - ;look for non-OR - S (ECNT,ECNL,ECXNONL,ECXSTOP)="" - I $P(ECNO,U)="Y" D - .S A1=$P(ECNO,U,5) - .S A2=$P(ECNO,U,4) - .S TIME="##" - .D:(A1&A2) TIME S ECNT=TIME - .S ECXNONL=+$P(ECNO,U,2) - .S ECNL=$P($G(^ECX(728.44,ECXNONL,0)),U,9) - .I ECNL="" S ECNL="UNKNOWN" - .; - .; Get DSS Stop Code to use in encounter number - .S ECXSTOP=$P($G(^ECX(728.44,ECXNONL,0)),U,4) - ; - ;retrieving anesthesia times first, then operation and patient - ;times, then storing in following order: - ;ecode0="recovery room time^pt hold area time^or clean time^patient - ;time^operation time^anesthesia time - S ECODE0="" - F J="1,4","2,3","10,12","13,14","15,10" D - .S A2=$P(DATA2,U,$P(J,",")) - .S A1=$P(DATA2,U,$P(J,",",2)) - .S TIME="##" - .I (A1&A2) D TIMEDIF(A1,A2) D - ..I +J'=2 D TIME - ..I +J=2 D ;-Operation Time - ...S TIME=$TR($J(TIMEDIF,4,0)," ") - ...;I TIME<0 S TIME="###" - .S ECODE0=TIME_U_ECODE0 K TIME - ; - ;retrieve recovery room (PACU) time - S A2=$P($G(DATAPA),U,7) - S A1=$P($G(DATAPA),U,8) - S TIME="##" - I (A1&A2) D TIME - S ECODE0=TIME_U_ECODE0 K TIME - ; - I ECNL]"" S $P(ECODE0,U,2)=ECNT - ; - ;- Was surgery cancelled/aborted - S ECCAN=$P($G(^SRF(ECD0,30)),U) - I +ECCAN S ECCAN=$$CANC^ECXUTL4(ECNL,$P(DATA2,U,10)) - ; - I ECXFLAG D FILE Q - N PIECE,FILE - S FILE="NO" - F PIECE=1,2,3,4,5,6 D - . I $P(ECODE0,U,PIECE)>ECTHLD S FILE="YES" - . I $P(ECODE0,U,PIECE)<0 S FILE="YES" - ; - I FILE="YES" D FILE Q:ECXERR - Q - ; -FILE ; Store unusual records for display later - N OK,SURPAT,SURNAME,SURSSN,SURDT,VOL - S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECD,"."),"1;",.SURPAT) - I 'OK Q - S SURNAME=SURPAT("NAME") - S SURSSN=SURPAT("SSN") - S SURDT=$E(ECXDATE,4,5)_"/"_$E(ECXDATE,6,7)_"/"_$E(ECXDATE,2,3) - ; - ; Observation Patient Indicator (yes/no) - S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECNL) - ; - ; Principal Procedure - S ECXPROC=$E($P(DATAOP,U),1,15) - ; - ; If no encounter number don't file record - S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXSTOP,ECSS) Q:ECXENC="" - ; - S VOL=$P(ECODE0,U) - I $P(ECODE0,U,2)>VOL S VOL=$P(ECODE0,U,2) - I $P(ECODE0,U,3)>VOL S VOL=$P(ECODE0,U,3) - S ^TMP($J,-VOL,-ECD0)=SURNAME_U_SURSSN_U_SURDT_U_ECD0_U_ECXENC_U_ECODE0_U_ECXPROC_U_ECCAN - S COUNT=COUNT+1 - I COUNT#100=0 I $$S^ZTLOAD S (ZSTOP,ECXERR)=1 - Q - ; -TIME ; given date/time get increment - N CON - S CON=$P($G(^SRF(ECD0,"CON")),U) - D TIMEDIF(A1,A2) - I 'CON D - .S TIME=$J($TR($J(TIMEDIF,4,0)," "),2,1) - .S:TIME>"99.0" TIME="99.0" - I CON D - .S TIME=$J(($TR($J(TIMEDIF,4,0)," ")/2),2,1) - .S:TIME>"99.5" TIME="99.5" - ;S:TIME<0 TIME="###" - Q - ; -TIMEDIF(START,FINISH) ; Set values to be compared, in seconds - ; - S TIMEDIF=$$FMDIFF^XLFDT(START,FINISH,2)/900 - I (TIMEDIF>0)&(TIMEDIF<.5) S TIMEDIF=.5 - Q - ; -EXIT S ECXERR=1 Q +ECXUSUR1 ;ALB/TJL-Surgery Extract Unusual Volume Report ; 12/1/04 4:48pm + ;;3.0;DSS EXTRACTS;**49,71**;July 1, 2003 +EN ; + N ECHEAD,COUNT,TIMEDIF,ECXPROC + S ECHEAD="SUR" + S (COUNT,QFLG)=0,ECED=ECED+.3,ECD=ECSD1 + F S ECD=$O(^SRF("AC",ECD)) Q:('ECD)!(ECD>ECED)!(QFLG) D + .S ECD0=0 + .F S ECD0=$O(^SRF("AC",ECD,ECD0)) Q:'ECD0 D + ..I $D(^SRF(ECD0,0)) S ECXDFN=+$P(^(0),U,1) D STUFF Q:QFLG + Q + ; +STUFF ;gather data + N J,DATA1,DATA2,DATAOP,ECXNONL,ECXSTOP + S ECXDATE=ECD,ECXERR=0,ECXQ="" + Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXDATE,"1;2;3;5;") + S EC0=^SRF(ECD0,0) + S DATA1=$S($D(^SRF(ECD0,.1)):^(.1),1:"") + S DATA2=$S($D(^SRF(ECD0,.2)):^(.2),1:"") + S DATAOP=$S($D(^SRF(ECD0,"OP")):^("OP"),1:"") + S DATAPA=$S($D(^SRF(ECD0,1.1)):^(1.1),1:"") + S ECNO=$G(^SRF(ECD0,"NON")) + ;get data + S ECSS=$P($G(^SRO(137.45,+$P(EC0,U,4),0)),U,2) + S ECSS=$$RJ^XLFSTR($P($G(^DIC(45.3,+ECSS,0)),U),3,0) + S:ECSS="000" ECSS="999" + ;look for non-OR + S (ECNT,ECNL,ECXNONL,ECXSTOP)="" + I $P(ECNO,U)="Y" D + .S A1=$P(ECNO,U,5) + .S A2=$P(ECNO,U,4) + .S TIME="##" + .D:(A1&A2) TIME S ECNT=TIME + .S ECXNONL=+$P(ECNO,U,2) + .S ECNL=$P($G(^ECX(728.44,ECXNONL,0)),U,9) + .I ECNL="" S ECNL="UNKNOWN" + .; + .; Get DSS Stop Code to use in encounter number + .S ECXSTOP=$P($G(^ECX(728.44,ECXNONL,0)),U,4) + ; + ;retrieving anesthesia times first, then operation and patient + ;times, then storing in following order: + ;ecode0="recovery room time^pt hold area time^or clean time^patient + ;time^operation time^anesthesia time + S ECODE0="" + F J="1,4","2,3","10,12","13,14","15,10" D + .S A2=$P(DATA2,U,$P(J,",")) + .S A1=$P(DATA2,U,$P(J,",",2)) + .S TIME="##" + .I (A1&A2) D TIMEDIF(A1,A2) D + ..I +J'=2 D TIME + ..I +J=2 D ;-Operation Time + ...S TIME=$TR($J(TIMEDIF,4,0)," ") + ...;I TIME<0 S TIME="###" + .S ECODE0=TIME_U_ECODE0 K TIME + ; + ;retrieve recovery room (PACU) time + S A2=$P($G(DATAPA),U,7) + S A1=$P($G(DATAPA),U,8) + S TIME="##" + I (A1&A2) D TIME + S ECODE0=TIME_U_ECODE0 K TIME + ; + I ECNL]"" S $P(ECODE0,U,5)=ECNT + ; + I ECXFLAG D FILE Q + N PIECE,FILE + S FILE="NO" + F PIECE=1,2,3,4,5,6 D + . I $P(ECODE0,U,PIECE)>ECTHLD S FILE="YES" + . I $P(ECODE0,U,PIECE)<0 S FILE="YES" + I FILE="YES" D FILE Q:ECXERR + Q + ; +FILE ; Store unusual records for display later + N OK,SURPAT,SURNAME,SURSSN,SURDT,VOL + S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECD,"."),"1;",.SURPAT) + I 'OK Q + S SURNAME=SURPAT("NAME") + S SURSSN=SURPAT("SSN") + S SURDT=$E(ECXDATE,4,5)_"/"_$E(ECXDATE,6,7)_"/"_$E(ECXDATE,2,3) + ; + ; Observation Patient Indicator (yes/no) + S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECNL) + ; + ; Principal Procedure + S ECXPROC=$E($P(DATAOP,U),1,15) + ; + ; If no encounter number don't file record + S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXSTOP,ECSS) Q:ECXENC="" + ; + S VOL=$P(ECODE0,U,4) + I $P(ECODE0,U,5)>VOL S VOL=$P(ECODE0,U,5) + I $P(ECODE0,U,6)>VOL S VOL=$P(ECODE0,U,6) + S ^TMP($J,-VOL,-ECD0)=SURNAME_U_SURSSN_U_SURDT_U_ECD0_U_ECXENC_U_ECODE0_U_ECXPROC + S COUNT=COUNT+1 + I COUNT#100=0 I $$S^ZTLOAD S (ZSTOP,ECXERR)=1 + Q + ; +TIME ; given date/time get increment + N CON + S CON=$P($G(^SRF(ECD0,"CON")),U) + D TIMEDIF(A1,A2) + I 'CON D + .S TIME=$J($TR($J(TIMEDIF,4,0)," "),2,1) + .S:TIME>"99.0" TIME="99.0" + I CON D + .S TIME=$J(($TR($J(TIMEDIF,4,0)," ")/2),2,1) + .S:TIME>"99.5" TIME="99.5" + ;S:TIME<0 TIME="###" + Q + ; +TIMEDIF(START,FINISH) ; Set values to be compared, in seconds + ; + S TIMEDIF=$$FMDIFF^XLFDT(START,FINISH,2)/900 + I (TIMEDIF>0)&(TIMEDIF<.5) S TIMEDIF=.5 + Q + ; +EXIT S ECXERR=1 Q diff --git a/r/DSS_EXTRACTS-ECX/ECXUTL2.m b/r/DSS_EXTRACTS-ECX/ECXUTL2.m index 8653199b..6be42cb1 100644 --- a/r/DSS_EXTRACTS-ECX/ECXUTL2.m +++ b/r/DSS_EXTRACTS-ECX/ECXUTL2.m @@ -1,233 +1,242 @@ -ECXUTL2 ;ALB/JAP - Utilities for DSS Extracts (cont.) ; 6/12/07 6:38am - ;;3.0;DSS EXTRACTS;**8,13,23,24,33,35,39,46,71,84,92,105**;Dec 22, 1997;Build 70 - ; -ECXDEF(ECXHEAD,ECXPACK,ECXGRP,ECXFILE,ECXRTN,ECXPIECE,ECXVER) ;variables specific to extract from file #727.1 - ; input - ; ECXHEAD = extract header code - ; all other formal list parameters passed by reference - ; output - ; ECXPACK = type field (#7) - ; ECXGRP = group field (#9) - ; ECXFILE = file number field (#1) - ; ECXRTN = routine field (#4) - ; ECXPIECE= running piece field (#11) - ; ECXVER = dss version - N ECXIEN,ECXARR,DIC,DA,DR,DIQ - S (ECXPACK,ECXGRP,ECXFILE,ECXRTN,ECXPIECE,ECXVER)="",ECXIEN=0 - S ECXIEN=+$O(^ECX(727.1,"C",ECXHEAD,ECXIEN)) - I ECXIEN=0 D Q - .D MES^XPDUTL(" ") - .D MES^XPDUTL(" It appears that you may have a problem with File #727.1 --") - .D MES^XPDUTL(" ") - .D MES^XPDUTL(" The "_ECHEAD_" Extract is not properly defined.") - .D MES^XPDUTL(" ") - .D MES^XPDUTL(" Contact National VISTA Support for further assistance.") - .D MES^XPDUTL(" ") - .I $E(IOST)="C" D - ..S SS=22-$Y F JJ=1:1:SS W ! - ..S DIR(0)="E" W ! D ^DIR K DIR - .W !! - S DIC="^ECX(727.1,",DA=ECXIEN,DR=".01;1;4;7;9;11",DIQ="ECXARR" - D EN^DIQ1 - S ECXPACK=ECXARR(727.1,ECXIEN,7) - ;if this is an inactive extract type, skip it - I ECXPACK["Inactive" D Q - .D MES^XPDUTL(" ") - .D MES^XPDUTL(" The "_ECHEAD_" Extract is no longer active/valid.") - .D MES^XPDUTL(" ") - .D MES^XPDUTL(" Contact National VISTA Support for further assistance.") - .D MES^XPDUTL(" ") - .I $E(IOST)="C" D - ..S SS=22-$Y F JJ=1:1:SS W ! - ..S DIR(0)="E" W ! D ^DIR K DIR - .W !! - S ECXGRP=ECXARR(727.1,ECXIEN,9) - S ECXFILE=ECXARR(727.1,ECXIEN,1) - S ECXRTN="START^"_ECXARR(727.1,ECXIEN,4) - S ECXPIECE=ECXARR(727.1,ECXIEN,11) - ;version of dss/tsi in Austin as specified by btso - S ECXVER=7 - Q -PATDEM(DFN,DT1,PAR,FLG) ; determine patient information - ; DFN = - ; DT = - ; PAR = - ; FLG = - N DT2,PAT,OK,X - D KPATDEM - S FLG=$G(FLG),PAR=$S($D(PAR):PAR,1:"1;2;3;4;5;"),DT2=$P(DT1,".") - Q:'$$PAT^ECXUTL3(DFN,DT2,PAR,.PAT) 0 - S ECXMPI=PAT("MPI") - I PAR["1" D - .S ECXSSN=PAT("SSN"),ECXPNM=PAT("NAME"),ECXDOB=PAT("DOB") - .S ECXSEX=PAT("SEX"),ECXREL=PAT("RELIGION"),ECXRACE=PAT("RACE") - .S ECXMAR=PAT("MARITAL") - .S ECXETH=PAT("ETHNIC"),ECXRC1=PAT("RACE1") - I PAR["2" D - .S ECXCNTY=PAT("COUNTY"),ECXSTATE=PAT("STATE"),ECXZIP=PAT("ZIP") - I PAR["3" D - .S ECXPOS=PAT("POS"),ECSC=PAT("SC STAT"),ECXSVC=PAT("SC%") - .S ECXVET=PAT("VET"),ECXMEAN=PAT("MEANS"),ECXELIG=PAT("ELIG") - .S ECXENRL=PAT("ENROLL LOC") - .S ECXERI=PAT("ERI") - I PAR["4" S ECXEMP=PAT("EMPLOY") - I PAR["5" D - .S ECXVIET=PAT("VIETNAM"),ECXAST=PAT("AO STAT"),ECXRST=PAT("IR STAT") - .S ECXEST=PAT("EC STAT"),ECXPST=PAT("POW STAT"),ECXPLOC=PAT("POW LOC") - .S ECXPHI=PAT("PHI"),ECXMST=PAT("MST STAT"),ECXAOL=PAT("AOL") - .S ECXOEF=PAT("ECXOEF"),ECXOEFDT=PAT("ECXOEFDT") - I PAR["6" D - .S (ECXPAYOR,ECXSAI)="" D VISN19(DFN,.ECXPAYOR,.ECXSAI) - I FLG'[3 D - .S X=$$PRIMARY(DFN,DT2),ECPTTM=$P(X,U),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3) - .S ECPTNPI=$P(X,U,4),ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6) - .S ECASNPI=$P(X,U,7) - I FLG'[2 D - .S ECXINP=$$INP^ECXUTL2(DFN,DT1),ECXA=$P(ECXINP,U),ECXMN=$P(ECXINP,U,2) - .S ECXTS=$P(ECXINP,U,3),ECXDOM=$P(ECXINP,U,10),ECXADMDT=$P(ECXINP,U,4) - I FLG'[1 S X=$$ENROLLM(DFN) - Q 1 - ; -KPATDEM ; - K ECXADMDT,ECAO,ECASNPI,ECASPR,ECCLAS,ECCLAS2,ECENV,ECPTNPI,ECPTPR,ECPTTM - K ECRE,ECSC,ECXA,ECXAST,ECXCAT,ECXCNTY,ECXEST,ECXENRL,ECXDOB - K ECXDOM,ECXELIG,ECXINP,ECXMPI,ECXMN,ECXNM,ECXPHI,ECXPLOC,ECXMEAN,ECXMST - K ECXPAYOR,ECXPNM,ECXPOS,ECXPRIOR,ECXPST,ECXRACE,ECXREL,ECXRST,ECXSAI - K ECXSEX,ECXSSN,ECXSTAT,ECXSTATE,ECXSVC,ECXTS,ECXVIET,ECXZIP,VA,VAERR - K ECXSBGRP - Q -ENROLLM(DFN,RNDT) ;determines enrollment status, category, priority - ;and user enrollee status - ; input - ; DFN = IEN from Patient file (Required) - ; RNDT = Extract Run Date - ; output - ; ECXSTAT = Enrollment status - ; ECXPRIOR = Enrollment priority - ; ECXCAT = Enrollment priority - ; ECXSBGRP = Enrollment subgroup - ; ECXUESTA = User enrollee - ; return value 0 if no data found, 1 if data found - N CAT,PRIOR,STAT,X,X1,X2,X3,ENRIEN,ENR,FL,SBGRP - S (ECXCAT,ECXPRIOR,ECXSTAT,ECXSBGRP,ECXEUSTA)="" - I $G(DFN)="" Q 0 - ;User enrollee status, if current or future date set to 'U' - ;DBIA #3989 - S ECXUESTA=$S($$UESTAT^EASUER(DFN):"U",1:"") - ;Patient type - S ECXPTYPE=$$TYPE^ECXUTL5(DFN) - ;Combat Veteran Status DBIA #4156 - S X3=$$CVEDT^ECXUTL5(DFN,$S($G(ECD):ECD,$G(ECXDATE):ECXDATE,1:DT)) - ;enrollment priority DBIA - S STAT=$$STATUS^DGENA(DFN),PRIOR=$$PRIORITY^DGENA(DFN) - S CAT=$$CATEGORY^DGENA4(DFN,STAT),SBGRP=$$ENRSBGRP^DGENA4(DFN) - ;find current enrollment when status=2 or 19 - I "^2^19^"[("^"_STAT_"^") S ECXSTAT=STAT,ECXPRIOR=PRIOR,ECXCAT=CAT,ECXSBGRP=$S(SBGRP=1:"a",SBGRP=3:"c",SBGRP=5:"e",SBGRP=7:"g",1:"") Q 1 - ;find previous enrollment - S ENRIEN=$$FINDCUR^DGENA(DFN) I ENRIEN="" Q 0 - I $G(RNDT)="" D NOW^%DTC S RNDT=X - S RNDT=($E(RNDT,1,3)-1)_$E(RNDT,4,7),FL=0 - F S ENRIEN=$$FINDPRI^DGENA(ENRIEN) Q:'ENRIEN D Q:FL - . S ENR=$$GET^DGENA(ENRIEN,.ENR) - . I "^2^19^"[("^"_ENR("STATUS")_"^"),ENR("EFFDATE")>RNDT D - . . S ECXSTAT=ENR("STATUS"),ECXPRIOR=PRIOR,FL=1 - . . S ECXCAT=$$CATEGORY^DGENA4(DFN,ECXSTAT) - . . S ECXSBGRP=$$ENRSBGRP^DGENA4(DFN) - . . S ECXSBGRP=$S(SBGRP=1:"a",SBGRP=3:"c",SBGRP=5:"e",SBGRP=7:"g",1:"") - I FL Q 1 - ;no enrollment status found =2 or 19 - S ECXSTAT=STAT,ECXPRIOR=PRIOR,ECXCAT=CAT,ECXSBGRP=$S(SBGRP=1:"a",SBGRP=3:"c",SBGRP=5:"e",SBGRP=7:"g",1:"") - Q 1 -PRIMARY(ECXDFN,ECXDATE,ECXPREFX) ;determine patient's pc team and pc provider - ; input - ; ECXDFN = file #2 ien (required) - ; ECXDATE = date of interest (required) - ; ECXPREFX = prefix for provider data (optional) - ; defaults to "2" if not specified otherwise - ; output - ; ECXPRIME = pc team ien^prefix_pc provider ien^pc provider person - ;class^pc provider npi^prefix_assoc pc provider ien^assoc pc provider - ;person class^assoc pc provider npi - N ECPTTM,ECPTPR,ECCLAS,ECPRIME,ECASPR,ECCLAS2 - S:'$D(ECXPREFX) ECXPREFX=2 S:(+ECXPREFX=0) ECXPREFX=2 - ;get pc team data - S ECPTTM=+$$OUTPTTM^SDUTL3(ECXDFN,ECXDATE) S:ECPTTM=0 ECPTTM="" - ;get primary pc provider data - S ECPTPR=+$$OUTPTPR^SDUTL3(ECXDFN,ECXDATE) - S ECCLAS="" I ECPTPR>0 S ECCLAS=$$PRVCLASS^ECXUTL(ECPTPR,ECXDATE) - N ECXUSRTN S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECPTPR,ECXDATE) - S:+ECXUSRTN'>0 ECXUSRTN="" S ECPTNPI=$P(ECXUSRTN,U) - S:ECPTPR=0 ECPTPR="" S:ECPTPR]"" ECPTPR=ECXPREFX_ECPTPR - ;assoc pc provider call ok if routine scapmca from patch177 is present - S ECASPR="" - S X="SCAPMCA" X ^%ZOSF("TEST") I $T D - .S ECASPR=+$$OUTPTAP^SDUTL3(ECXDFN,ECXDATE) - S ECCLAS2="" I ECASPR>0 S ECCLAS2=$$PRVCLASS^ECXUTL(ECASPR,ECXDATE) - N ECXUSRTN S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECASPR,ECXDATE) - S:+ECXUSRTN'>0 ECXUSRTN="" S ECASNPI=$P(ECXUSRTN,U) - S:ECASPR=0 ECASPR="" S:ECASPR]"" ECASPR=ECXPREFX_ECASPR - ;assemble - S ECXPRIME=ECPTTM_U_ECPTPR_U_ECCLAS_U_ECPTNPI_U_ECASPR_U_ECCLAS2_U_ECASNPI - Q ECXPRIME -INP(ECXDFN,ECXDATE) ; check for inpatient status - ; input - ; ECXDFN = file #2 ien (required) - ; ECXDATE = date of interest (required) - ; output - ; ECXINP = patient status^movment # (file #405 ien) - ; current treat. spec. (file #42.4 ien)^admission date/time^ - ; current ward (file #42 ien)^discharge date/time^ - ; ward provider^attending phys.^ward (file #44 ien);facility - ; (file #40.8 ien);dss dept^dom - ; where patient status = I for inpatient - ; = O for outpatient - N DFN,DSSDEPT,ECA,ECADM,ECMN,ECTS,ECWARD,ECDC,ECXINP,ECXPRO - N ECXATP,ECXDD,ECXDOM,ECXPROF,ECXPWP,ECXWW,FAC,VAIP,WRD,ECXPWPPC - N ECXATPPC - D FIELD^DID(405,.19,,"SPECIFIER","ECXDD") - S ECXPROF=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD - ;- Inpat/outpat indicator (ECA) initially set to "O" (outpatient) - S DFN=ECXDFN,ECA="O" - S (DSSDEPT,ECMN,ECTS,ECADM,ECWARD,ECDC,ECXATP,ECXPWP,ECXWW,WRD,FAC,ECXPWPPC,ECXATPPC)="" - S VAIP("D")=ECXDATE D IN5^VADPT - S ECMN=$G(VAIP(1)) - I ECMN D - .S ECTS=+$P($G(^DIC(45.7,+VAIP(8),0)),U,2) S:ECTS=0 ECTS="" - .;- Get inpat/outpat indicator - .S ECA=$$INOUTP^ECXUTL4(ECTS) - .S ECADM=+$G(VAIP(13,1)) S:ECADM=0 ECADM="" - .S ECWARD=+$G(VAIP(5)) S:ECWARD=0 ECWARD="" - .I ECWARD D - ..S WRD=+$P($G(^DIC(42,+ECWARD,44)),U) - ..S FAC=$P($G(^DIC(42,+ECWARD,0)),U,11) - ..S DSSDEPT=$P($G(^ECX(727.4,ECWARD,0)),U,2) - .S ECXWW=WRD_";"_FAC_";"_DSSDEPT,ECDC=+$G(VAIP(17,1)) S:ECDC=0 ECDC="" - .S ECXPWP=+VAIP(7) S:ECXPWP=0 ECXPWP="" - .S ECXATP=+VAIP(18) S:ECXATP=0 ECXATP="" - .S ECXPWPPC=$$PRVCLASS^ECXUTL(ECXPWP,ECADM) - .S ECXATPPC=$$PRVCLASS^ECXUTL(ECXATP,ECADM) - .;prefix file #200 iens - .S:ECXPWP ECXPWP=ECXPROF_ECXPWP S:ECXATP ECXATP=ECXPROF_ECXATP - S ECXDOM=$P($G(^ECX(727.831,+ECTS,0)),U,2) - S ECXINP=ECA_U_ECMN_U_ECTS_U_ECADM_U_ECWARD_U_ECDC_U_ECXPWP_U_ECXATP_U_ECXWW_U_ECXDOM_U_ECXPWPPC_U_ECXATPPC - Q ECXINP -VISN19(ECXDFN,ECXPAYOR,ECXSAI) ;visn 19 sharing agreement data - ; input ECXDFN = patient file ien - ; output ECXPAYOR, ECXSAI (passed by reference) - N JJ,ALIAS,INSUR,DIC,DIQ,DA,DR,ECXARY,ECXERR,ECXDA - S (ECXPAYOR,ECXSAI)="" - D GETS^DIQ(2,ECXDFN,"1*,","I","ECXARY","ECXERR") - I $D(ECXERR) Q - S JJ=0 F S JJ=$O(ECXARY(2.01,JJ)) Q:JJ="" D I ECXPAYOR]"" Q - . S ALIAS=$G(ECXARY(2.01,JJ,.01,"I")) - . S ECXPAYOR=$S(ALIAS="SHARING AGREEMENT":"A",ALIAS="TRICARE":"B",ALIAS="CAT C":"C",ALIAS="CATEGORY C":"C",ALIAS="CHAMPVA":"D",ALIAS="CHAMPUS":"E",1:"") - . W !,$G(CNT)+1 - . W !,"The value of ECXPAYOR is: ",ECXPAYOR - ;K ECXARY,ECXERR - I ECXPAYOR]"" D GETS^DIQ(2,ECXDFN,".3121*,","I","ECXARY","ECXERR") D - . I $D(ECXERR) Q - . S JJ=0,ECXDA=$O(ECXARY(2.312,JJ)) I ECXDA="" Q - . S DA=$G(ECXARY(2.312,ECXDA,.01,"I")) I DA="" Q - . S INSUR=$$GET1^DIQ(36,DA,".01","I","","ECXERR") - . I '$D(ECXERR) S ECXSAI=$E(ECXARY(2.312,ECXDA,.01,"I"),1,11) - Q +ECXUTL2 ;ALB/JAP - Utilities for DSS Extracts (cont.) ; 11/2/06 9:03am + ;;3.0;DSS EXTRACTS;**8,13,23,24,33,35,39,46,71,84,92**;Dec 22, 1997;Build 30 + ; +ECXDEF(ECXHEAD,ECXPACK,ECXGRP,ECXFILE,ECXRTN,ECXPIECE,ECXVER) ;variables specific to extract from file #727.1 + ; input + ; ECXHEAD = extract header code + ; all other formal list parameters passed by reference + ; output + ; ECXPACK = type field (#7) + ; ECXGRP = group field (#9) + ; ECXFILE = file number field (#1) + ; ECXRTN = routine field (#4) + ; ECXPIECE= running piece field (#11) + ; ECXVER = dss version + ; + N ECXIEN,ECXARR,DIC,DA,DR,DIQ + S (ECXPACK,ECXGRP,ECXFILE,ECXRTN,ECXPIECE,ECXVER)="",ECXIEN=0 + S ECXIEN=+$O(^ECX(727.1,"C",ECXHEAD,ECXIEN)) + I ECXIEN=0 D Q + .D MES^XPDUTL(" ") + .D MES^XPDUTL(" It appears that you may have a problem with File #727.1 --") + .D MES^XPDUTL(" ") + .D MES^XPDUTL(" The "_ECHEAD_" Extract is not properly defined.") + .D MES^XPDUTL(" ") + .D MES^XPDUTL(" Contact National VISTA Support for further assistance.") + .D MES^XPDUTL(" ") + .I $E(IOST)="C" D + ..S SS=22-$Y F JJ=1:1:SS W ! + ..S DIR(0)="E" W ! D ^DIR K DIR + .W !! + S DIC="^ECX(727.1,",DA=ECXIEN,DR=".01;1;4;7;9;11",DIQ="ECXARR" + D EN^DIQ1 + S ECXPACK=ECXARR(727.1,ECXIEN,7) + ;if this is an inactive extract type, skip it + I ECXPACK["Inactive" D Q + .D MES^XPDUTL(" ") + .D MES^XPDUTL(" The "_ECHEAD_" Extract is no longer active/valid.") + .D MES^XPDUTL(" ") + .D MES^XPDUTL(" Contact National VISTA Support for further assistance.") + .D MES^XPDUTL(" ") + .I $E(IOST)="C" D + ..S SS=22-$Y F JJ=1:1:SS W ! + ..S DIR(0)="E" W ! D ^DIR K DIR + .W !! + S ECXGRP=ECXARR(727.1,ECXIEN,9) + S ECXFILE=ECXARR(727.1,ECXIEN,1) + S ECXRTN="START^"_ECXARR(727.1,ECXIEN,4) + S ECXPIECE=ECXARR(727.1,ECXIEN,11) + ;version of dss/tsi in Austin as specified by btso + S ECXVER=7 + Q + ; +PATDEM(DFN,DT1,PAR,FLG) ; determine patient information + ; DFN = + ; DT = + ; PAR = + ; FLG = + N DT2,PAT,OK,X + D KPATDEM + S FLG=$G(FLG),PAR=$S($D(PAR):PAR,1:"1;2;3;4;5;"),DT2=$P(DT1,".") + Q:'$$PAT^ECXUTL3(DFN,DT2,PAR,.PAT) 0 + S ECXMPI=PAT("MPI") + I PAR["1" D + .S ECXSSN=PAT("SSN"),ECXPNM=PAT("NAME"),ECXDOB=PAT("DOB") + .S ECXSEX=PAT("SEX"),ECXREL=PAT("RELIGION"),ECXRACE=PAT("RACE") + .S ECXMAR=PAT("MARITAL") + .S ECXETH=PAT("ETHNIC"),ECXRC1=PAT("RACE1") + I PAR["2" D + .S ECXCNTY=PAT("COUNTY"),ECXSTATE=PAT("STATE"),ECXZIP=PAT("ZIP") + I PAR["3" D + .S ECXPOS=PAT("POS"),ECSC=PAT("SC STAT"),ECXSVC=PAT("SC%") + .S ECXVET=PAT("VET"),ECXMEAN=PAT("MEANS"),ECXELIG=PAT("ELIG") + .S ECXENRL=PAT("ENROLL LOC") + .S ECXERI=PAT("ERI") + I PAR["4" S ECXEMP=PAT("EMPLOY") + I PAR["5" D + .S ECXVIET=PAT("VIETNAM"),ECXAST=PAT("AO STAT"),ECXRST=PAT("IR STAT") + .S ECXEST=PAT("EC STAT"),ECXPST=PAT("POW STAT"),ECXPLOC=PAT("POW LOC") + .S ECXPHI=PAT("PHI"),ECXMST=PAT("MST STAT"),ECXAOL=PAT("AOL") + I PAR["6" D + .S (ECXPAYOR,ECXSAI)="" D VISN19(DFN,.ECXPAYOR,.ECXSAI) + I FLG'[3 D + .S X=$$PRIMARY(DFN,DT2),ECPTTM=$P(X,U),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3) + .S ECPTNPI=$P(X,U,4),ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6) + .S ECASNPI=$P(X,U,7) + I FLG'[2 D + .S ECXINP=$$INP^ECXUTL2(DFN,DT1),ECXA=$P(ECXINP,U),ECXMN=$P(ECXINP,U,2) + .S ECXTS=$P(ECXINP,U,3),ECXDOM=$P(ECXINP,U,10),ECXADMDT=$P(ECXINP,U,4) + I FLG'[1 S X=$$ENROLLM(DFN) + Q 1 + ; +KPATDEM ; + K ECXADMDT,ECAO,ECASNPI,ECASPR,ECCLAS,ECCLAS2,ECENV,ECPTNPI,ECPTPR,ECPTTM + K ECRE,ECSC,ECXA,ECXAST,ECXCAT,ECXCNTY,ECXEST,ECXENRL,ECXDOB + K ECXDOM,ECXELIG,ECXINP,ECXMPI,ECXMN,ECXNM,ECXPHI,ECXPLOC,ECXMEAN,ECXMST + K ECXPAYOR,ECXPNM,ECXPOS,ECXPRIOR,ECXPST,ECXRACE,ECXREL,ECXRST,ECXSAI + K ECXSEX,ECXSSN,ECXSTAT,ECXSTATE,ECXSVC,ECXTS,ECXVIET,ECXZIP,VA,VAERR + K ECXSBGRP + Q + ; +ENROLLM(DFN,RNDT) ;determines enrollment status, category, priority + ;and user enrollee status + ; input + ; DFN = IEN from Patient file (Required) + ; RNDT = Extract Run Date + ; output + ; ECXSTAT = Enrollment status + ; ECXPRIOR = Enrollment priority + ; ECXCAT = Enrollment priority + ; ECXSBGRP = Enrollment subgroup + ; ECXUESTA = User enrollee + ; return value 0 if no data found, 1 if data found + ; + N CAT,PRIOR,STAT,X,X1,X2,X3,ENRIEN,ENR,FL,SBGRP + S (ECXCAT,ECXPRIOR,ECXSTAT,ECXSBGRP,ECXEUSTA)="" + I $G(DFN)="" Q 0 + ;User enrollee status, if current or future date set to 'U' + ;DBIA #3989 + S ECXUESTA=$S($$UESTAT^EASUER(DFN):"U",1:"") + ;Patient type + S ECXPTYPE=$$TYPE^ECXUTL5(DFN) + ;Combat Veteran Status DBIA #4156 + S X3=$$CVEDT^ECXUTL5(DFN,$S($G(ECD):ECD,$G(ECXDATE):ECXDATE,1:DT)) + ;enrollment priority DBIA + S STAT=$$STATUS^DGENA(DFN),PRIOR=$$PRIORITY^DGENA(DFN) + S CAT=$$CATEGORY^DGENA4(DFN,STAT),SBGRP=$$ENRSBGRP^DGENA4(DFN) + ;find current enrollment when status=2 or 19 + I "^2^19^"[("^"_STAT_"^") S ECXSTAT=STAT,ECXPRIOR=PRIOR,ECXCAT=CAT,ECXSBGRP=$S(SBGRP=1:"a",SBGRP=3:"c",SBGRP=5:"e",SBGRP=7:"g",1:"") Q 1 + ;find previous enrollment + S ENRIEN=$$FINDCUR^DGENA(DFN) I ENRIEN="" Q 0 + I $G(RNDT)="" D NOW^%DTC S RNDT=X + S RNDT=($E(RNDT,1,3)-1)_$E(RNDT,4,7),FL=0 + F S ENRIEN=$$FINDPRI^DGENA(ENRIEN) Q:'ENRIEN D Q:FL + . S ENR=$$GET^DGENA(ENRIEN,.ENR) + . I "^2^19^"[("^"_ENR("STATUS")_"^"),ENR("EFFDATE")>RNDT D + . . S ECXSTAT=ENR("STATUS"),ECXPRIOR=PRIOR,FL=1 + . . S ECXCAT=$$CATEGORY^DGENA4(DFN,ECXSTAT) + . . S ECXSBGRP=$$ENRSBGRP^DGENA4(DFN) + . . S ECXSBGRP=$S(SBGRP=1:"a",SBGRP=3:"c",SBGRP=5:"e",SBGRP=7:"g",1:"") + I FL Q 1 + ;no enrollment status found =2 or 19 + S ECXSTAT=STAT,ECXPRIOR=PRIOR,ECXCAT=CAT,ECXSBGRP=$S(SBGRP=1:"a",SBGRP=3:"c",SBGRP=5:"e",SBGRP=7:"g",1:"") + Q 1 + ; +PRIMARY(ECXDFN,ECXDATE,ECXPREFX) ;determine patient's pc team and pc provider + ; input + ; ECXDFN = file #2 ien (required) + ; ECXDATE = date of interest (required) + ; ECXPREFX = prefix for provider data (optional) + ; defaults to "2" if not specified otherwise + ; output + ; ECXPRIME = pc team ien^prefix_pc provider ien^pc provider person class^pc provider npi + ; ^prefix_assoc pc provider ien^assoc pc provider person class^assoc pc provider npi + ; + N ECPTTM,ECPTPR,ECCLAS,ECPRIME,ECASPR,ECCLAS2 + S:'$D(ECXPREFX) ECXPREFX=2 S:(+ECXPREFX=0) ECXPREFX=2 + ;get pc team data + S ECPTTM=+$$OUTPTTM^SDUTL3(ECXDFN,ECXDATE) S:ECPTTM=0 ECPTTM="" + ;get primary pc provider data + S ECPTPR=+$$OUTPTPR^SDUTL3(ECXDFN,ECXDATE) + S ECCLAS="" I ECPTPR>0 S ECCLAS=$$PRVCLASS^ECXUTL(ECPTPR,ECXDATE) + S:ECPTPR=0 ECPTPR="" S:ECPTPR]"" ECPTPR=ECXPREFX_ECPTPR + S ECPTNPI="" + ;assoc pc provider call ok if routine scapmca from patch177 is present + S ECASPR="" + S X="SCAPMCA" X ^%ZOSF("TEST") I $T D + .S ECASPR=+$$OUTPTAP^SDUTL3(ECXDFN,ECXDATE) + S ECCLAS2="" I ECASPR>0 S ECCLAS2=$$PRVCLASS^ECXUTL(ECASPR,ECXDATE) + S:ECASPR=0 ECASPR="" S:ECASPR]"" ECASPR=ECXPREFX_ECASPR + S ECASNPI="" + ;assemble + S ECXPRIME=ECPTTM_U_ECPTPR_U_ECCLAS_U_ECPTNPI_U_ECASPR_U_ECCLAS2_U_ECASNPI + Q ECXPRIME + ; +INP(ECXDFN,ECXDATE) ; check for inpatient status + ; input + ; ECXDFN = file #2 ien (required) + ; ECXDATE = date of interest (required) + ; output + ; ECXINP = patient status^movment # (file #405 ien) + ; current treat. spec. (file #42.4 ien)^admission date/time^ + ; current ward (file #42 ien)^discharge date/time^ + ; ward provider^attending phys.^ward (file #44 ien);facility + ; (file #40.8 ien);dss dept^dom + ; where patient status = I for inpatient + ; = O for outpatient + ; + N DFN,DSSDEPT,ECA,ECADM,ECMN,ECTS,ECWARD,ECDC,ECXINP,ECXPRO + N ECXATP,ECXDD,ECXDOM,ECXPROF,ECXPWP,ECXWW,FAC,VAIP,WRD,ECXPWPPC + N ECXATPPC + D FIELD^DID(405,.19,,"SPECIFIER","ECXDD") + S ECXPROF=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD + ; + ;- Inpat/outpat indicator (ECA) initially set to "O" (outpatient) + S DFN=ECXDFN,ECA="O" + S (DSSDEPT,ECMN,ECTS,ECADM,ECWARD,ECDC,ECXATP,ECXPWP,ECXWW,WRD,FAC,ECXPWPPC,ECXATPPC)="" + S VAIP("D")=ECXDATE D IN5^VADPT + S ECMN=$G(VAIP(1)) + I ECMN D + .S ECTS=+$P($G(^DIC(45.7,+VAIP(8),0)),U,2) S:ECTS=0 ECTS="" + .; + .;- Get inpat/outpat indicator + .S ECA=$$INOUTP^ECXUTL4(ECTS) + .S ECADM=+$G(VAIP(13,1)) S:ECADM=0 ECADM="" + .S ECWARD=+$G(VAIP(5)) S:ECWARD=0 ECWARD="" + .I ECWARD D + ..S WRD=+$P($G(^DIC(42,+ECWARD,44)),U) + ..S FAC=$P($G(^DIC(42,+ECWARD,0)),U,11) + ..S DSSDEPT=$P($G(^ECX(727.4,ECWARD,0)),U,2) + .S ECXWW=WRD_";"_FAC_";"_DSSDEPT,ECDC=+$G(VAIP(17,1)) S:ECDC=0 ECDC="" + .S ECXPWP=+VAIP(7) S:ECXPWP=0 ECXPWP="" + .S ECXATP=+VAIP(18) S:ECXATP=0 ECXATP="" + .S ECXPWPPC=$$PRVCLASS^ECXUTL(ECXPWP,ECADM) + .S ECXATPPC=$$PRVCLASS^ECXUTL(ECXATP,ECADM) + .;prefix file #200 iens + .S:ECXPWP ECXPWP=ECXPROF_ECXPWP S:ECXATP ECXATP=ECXPROF_ECXATP + S ECXDOM=$P($G(^ECX(727.831,+ECTS,0)),U,2) + S ECXINP=ECA_U_ECMN_U_ECTS_U_ECADM_U_ECWARD_U_ECDC_U_ECXPWP_U_ECXATP_U_ECXWW_U_ECXDOM_U_ECXPWPPC_U_ECXATPPC + Q ECXINP + ; +VISN19(ECXDFN,ECXPAYOR,ECXSAI) ;visn 19 sharing agreement data + ; input ECXDFN = patient file ien + ; output ECXPAYOR, ECXSAI (passed by reference) + ; + N JJ,ALIAS,INSUR,DIC,DIQ,DA,DR,ECXARY,ECXERR,ECXDA + S (ECXPAYOR,ECXSAI)="" + D GETS^DIQ(2,ECXDFN,"1*,","I","ECXARY","ECXERR") + I $D(ECXERR) Q + S JJ=0 F S JJ=$O(ECXARY(2.01,JJ)) Q:JJ="" D I ECXPAYOR]"" Q + . S ALIAS=$G(ECXARY(2.01,JJ,.01,"I")) + . S ECXPAYOR=$S(ALIAS="SHARING AGREEMENT":"A",ALIAS="TRICARE":"B",ALIAS="CAT C":"C",ALIAS="CATEGORY C":"C",ALIAS="CHAMPVA":"D",ALIAS="CHAMPUS":"E",1:"") + . W !,$G(CNT)+1 + . W !,"The value of ECXPAYOR is: ",ECXPAYOR + ;K ECXARY,ECXERR + I ECXPAYOR]"" D GETS^DIQ(2,ECXDFN,".3121*,","I","ECXARY","ECXERR") D + . W !,"This is a test" + . I $D(ECXERR) Q + . S JJ=0,ECXDA=$O(ECXARY(2.312,JJ)) I ECXDA="" Q + . S DA=$G(ECXARY(2.312,ECXDA,.01,"I")) I DA="" Q + . S INSUR=$$GET1^DIQ(36,DA,".01","I","","ECXERR") + . I '$D(ECXERR) S ECXSAI=$E(ECXARY(2.312,ECXDA,.01,"I"),1,11) + Q diff --git a/r/DSS_EXTRACTS-ECX/ECXUTL3.m b/r/DSS_EXTRACTS-ECX/ECXUTL3.m index 70a43657..850f4523 100644 --- a/r/DSS_EXTRACTS-ECX/ECXUTL3.m +++ b/r/DSS_EXTRACTS-ECX/ECXUTL3.m @@ -1,244 +1,239 @@ -ECXUTL3 ;ALB/GTS - Utilities for DSS Extracts ; 9/28/07 1:38pm - ;;3.0;DSS EXTRACTS;**11,24,32,33,35,37,39,42,46,92,105**;Dec 22,1997;Build 70 - ; -OUTPTTM(ECXDFN,ECXDT) ;* Return PC Team from PCMM files or DPT - ; Variables - - ; ECXDFN - IEN from Patient file (Required) - ; ECXDT - Relevant Date for Primary Care Team - ; (Defaults to DT) - ; - ; Returned: ECXTM - - ; Pointer to team file (#404.51) - ; or, if error or none defined, returns 0 - ; - Q:'$G(ECXDFN) 0 ;** Quit if ECXDFN not defined - N ECXTM - S:'$D(ECXDT) ECXDT=DT - I $T(OUTPTTM^SDUTL3)[",SCDATE" D - .S ECXTM=+$$OUTPTTM^SDUTL3(ECXDFN,ECXDT) - I $T(OUTPTTM^SDUTL3)'[",SCDATE" D - .S ECXTM=+$$OUTPTTM^SDUTL3(ECXDFN) - I ECXTM=0 D - .S ECXTM=+$P($G(^DPT(+ECXDFN,"PC")),U,2) - Q ECXTM - ; -OUTPTPR(ECXDFN,ECXDT) ;* Return PC Provider from PCMM files or DPT - ; Variables - - ; ECXDFN - IEN from Patient file (Required) - ; ECXDT - Relevant Date for Primary Care Provider - ; (Defaults to DT) - ; - ; Returned: ECXPR - - ; Pointer to file #200 - ; or, if error or none defined, returns a 0 - ; - Q:'$G(ECXDFN) 0 ;** Quit if ECXDFN not defined - N ECXPR - S:'$D(ECXDT) ECXDT=DT - I $T(OUTPTPR^SDUTL3)[",SCDATE" D - .S ECXPR=+$$OUTPTPR^SDUTL3(ECXDFN,ECXDT) - I $T(OUTPTPR^SDUTL3)'[",SCDATE" D - .S ECXPR=+$$OUTPTPR^SDUTL3(ECXDFN) - I ECXPR=0 D - .S ECXPR=+$G(^DPT(+ECXDFN,"PC")) - Q ECXPR - ; -PAT(ECXDFN,ECXDATE,ECXDATA,ECXPAT) ;Return basic patient data for extract - ; Will not return data associated with test patients (SSN begin w 00000) - ; Variables - - ; Input ECXDFN - Patient internal entry number, DFN file#2; required - ; ECXDATE- Date used to get specific data from GETSTAT^DGMSTAPI - ; for MST. If no date, defaults to today's date, - ; standard FM format, optional - ; ECXDATA- Code indicating which data to return, optional. - ; If code not specified then returns all. Codes are: - ; 1 - DEM^VADPT (demographic data) - ; 2 - ADD^VADPT (current address) - ; 3 - ELIG^VADPT (eligibility & enrollment location) - ; 4 - OPD^VADPT (other patient data) - ; 5 - SVC^VADPT & GETSTAT^DGMSTAPI (service & MST inf) - ; ECXPAT(- Passed by reference; required - ; - ; Output: - ; ECXPAT 0 error or test patient no data in ECXPAT array - ; 1 data returned in ECXPAT array - ; ECXPAT( Local array with patient data. - ; - N SSN,I,ECXCOD,ECXDAT,DFN,VAPA,VADM,VAEL,VAPD,VASV,STR,ECXAR,DIC,DIQ,RCNUM,RCVAL,COLMETH - N DA,DR,PELG,MELIG,ZIP,MPI - I ECXDFN="" Q 0 - S SSN=$$GET1^DIQ(2,ECXDFN,.09,"I"),DFN=ECXDFN,ECXPAT=0 - I $E(SSN,1,3)="000"!(SSN="") K ECXPAT Q 0 ;test patient - ;test patient extended checks; mtl extract excluded - I $G(ECHEAD)'="MTL",'$$SSN^ECXUTL5(SSN) K ECXPAT Q 0 - S STR="NAME;SSN;DOB;SEX;RACE;RELIGION;STATE;COUNTY;ZIP;SC%;MEANS;ELIG;" - S STR=STR_"EMPLOY;AO STAT;IR STAT;EC STAT;POW STAT;POW LOC;MST STAT;" - S STR=STR_"ENROLL LOC;MPI;VIETNAM;POS;MARITAL" - ;initialize return array values - F I=1:1 S ECXDAT=$P(STR,";",I) Q:ECXDAT="" S ECXPAT(ECXDAT)="" - F I=1:1:$L(ECXDATA,";") S ECXDAT=$P(ECXDATA,";",I) I ECXDAT'="" D - . S ECXCOD(ECXDAT)="" - ; - ;- Get ICN if MPI installed - S X="MPIF001" X ^%ZOSF("TEST") I $T D - .; - .;- Get 1st piece (either ICN # or -1 if error) - . S MPI=+$$GETICN^MPIF001(DFN) - .; - .;- If error, set to null - . S ECXPAT("MPI")=$S(MPI>0:MPI,1:"") - D ;get demographic data - . I ECXDATA'="",'$D(ECXCOD(1)) Q - . D DEM^VADPT - . S ECXPAT("NAME")=$E($P(VADM(1),",")_" ",1,4) - . S ECXPAT("SSN")=$P(VADM(2),U),ECXPAT("MARITAL")=$P(VADM(10),U) - . S ECXPAT("DOB")=$$ECXDOB^ECXUTL($P(VADM(3),U)) - . S ECXPAT("SEX")=$P(VADM(5),U),ECXPAT("RELIGION")=$P(VADM(9),U) - . S DIC=10,DR=2,DA=+VADM(8),DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1 - . S ECXPAT("RACE")=$G(ECXAR(10,DA,DR,"I")),ECXPAT=1 - . ;add new race and ethnicity fields for FY2003 - . S (ECXPAT("ETHNIC"),ECXPAT("RACE1"))="" - . S X="DGUTL4" X ^%ZOSF("TEST") I $T D - .. S COLMETH=$$PTR2CODE^DGUTL4($G(VADM(11,1,1)),3,4) I COLMETH="S" D - ... S ECXPAT("ETHNIC")=$$PTR2CODE^DGUTL4(+$G(VADM(11,1)),2,4) - .. S (RCVAL,RCNUM)="" - .. F S RCNUM=$O(VADM(12,RCNUM)) Q:RCNUM="" Q:RCVAL="C" S COLMETH=$$PTR2CODE^DGUTL4(+$G(VADM(12,RCNUM,1)),3,4) I COLMETH="S" D - ... S RCVAL=$$PTR2CODE^DGUTL4(+$G(VADM(12,RCNUM)),1,4) - ... I RCVAL="C" S ECXPAT("RACE1")=RCVAL Q - ... S ECXPAT("RACE1")=ECXPAT("RACE1")_RCVAL - D ;get address information - . I ECXDATA'="",'$D(ECXCOD(2)) Q - . D ADD^VADPT - . S DIC=5,DR=2,DA=+VAPA(5),DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1 - . S ECXPAT("STATE")=$G(ECXAR(5,DA,DR,"I")) - . S DIC=5,DA=+VAPA(5),DR=3,DR(5.01)=2,DA(5.01)=+VAPA(7),DIQ="ECXAR" - . S DIQ(0)="I" D EN^DIQ1 - . S ECXPAT("COUNTY")=$G(ECXAR(5.01,DA(5.01),2,"I")) - . S ECXPAT("ZIP")=$P(VAPA(11),U,2),ECXPAT=1 - D ;get eligibility information - . I ECXDATA'="",'$D(ECXCOD(3)) Q - . D ELIG^VADPT - . S PELG=$P(VAEL(1),U),MELIG=$S(PELG="":"",1:$$GET1^DIQ(8,PELG,8,"I")) - . S ECXPAT("POS")=$P($G(^DIC(21,+VAEL(2),0)),U,3) - . S ECXPAT("SC STAT")=$S(+VAEL(3):"Y",+VAEL(3)=0:"N",1:"") - . S ECXPAT("SC%")=$P(VAEL(3),U,2) - . S ECXPAT("VET")=$S(VAEL(4):"Y",VAEL(4)=0:"N",1:"") - . S ECXPAT("MEANS")=$P(VAEL(9),U),ECXPAT=1 - . S ECXPAT("ELIG")=$$ELIG(MELIG,ECXPAT("SC%")) - . ;get enrollment location - . S DIC=2,DR=27.02,DA=ECXDFN,DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1 - . S ECXDAT=$G(ECXAR(2,ECXDFN,DR,"I")) I ECXDAT K ECXAR D - . . S DIC=4,DA=ECXDAT,DR=99,DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1 - . . S ECXPAT("ENROLL LOC")=ECXAR(4,ECXDAT,DR,"I") - . ;get Emergency Response Indicator (FEMA) - . S ECXPAT("ERI")=$$GET1^DIQ(2,ECXDFN,.181,"I") - D ;get other patient information - . I ECXDATA'="",'$D(ECXCOD(4)) Q - . D OPD^VADPT - . S ECXPAT("EMPLOY")=$P(VAPD(7),U),ECXPAT=1 - D ;get service information - . I ECXDATA'="",'$D(ECXCOD(5)) Q - . D SVC^VADPT - . S ECXPAT("VIETNAM")=$S(VASV(1):"Y",VASV(2)=0:"N",1:"U") - . S ECXPAT("AO STAT")=$S(VASV(2):"Y",VASV(2)=0:"N",1:"U") - . S ECXPAT("IR STAT")=$S(VASV(3):"Y",VASV(3)=0:"N",1:"U") - . S ECXPAT("EC STAT")=$$GET1^DIQ(2,ECXDFN,.322013,"I") - . S ECXPAT("POW STAT")=$S(VASV(4):"Y",VASV(4)=0:"N",1:"U") - . S ECXPAT("POW LOC")=$P(VASV(4,3),U),ECXPAT=1 - . S ECXPAT("PHI")=$S(VASV(9)=1:"Y",VASV(9)=0:"N",1:"") - . ;- Agent Orange Location (K=Korean DMZ,V=Vietnam) - . S ECXPAT("AOL")=$P($G(VASV(2,5)),U) - . ;get patient OEF/OIF status and date of return - . D OEFDATA^ECXUTL4 - . ; - . ;get patient current MST status - . I ECXDATE'="",ECXDATE'["." S ECXDATE=ECXDATE+.9 - . S X="DGMSTAPI" X ^%ZOSF("TEST") I $T D - . . S ECXDAT=$$GETSTAT^DGMSTAPI(DFN,ECXDATE) - . . S ECXPAT("MST STAT")=$S(+ECXDAT>0:$P(ECXDAT,U,2),1:"") - I 'ECXPAT K ECXPAT Q 0 - Q 1 - ; -ELIG(ECXELIG,ECXSVCP) ;Converts veteran eligibility code to NPCD code - ; Variables - - ; Input ECXELIG - Pointer to MAS ELIGIBILITY CODE file #8.1 - ; ECXSVCP - Number value rep. service connected percentage. - ; - ; Output: - ; ECXNCPD NPCD Eligibility Code - ; - N TEXT,IEN,SCPER,FND,NPCD,I,ECXBG,ECXEN,ECXNPCD - I ECXELIG="" Q "" - F I=1:1 S TEXT=$P($T(ELGTXT+I),";",3,999) Q:TEXT="END" D I $D(NPCD) Q - . S IEN=$P(TEXT,";"),SCPER=$P(TEXT,";",2) - . I ECXELIG=IEN D - . . I SCPER="" S NPCD=$P(TEXT,";",3) Q - . . S ECXBG=$S($E(SCPER)="<":0,$E(SCPER)=">":$P(SCPER,">",2)+1,SCPER["-":+SCPER,1:"") - . . S ECXEN=$S($E(SCPER)="<":$P(SCPER,"<",2),$E(SCPER)=">":100,SCPER["-":$P(SCPER,"-",2),1:"") - . . I ECXSVCP'ECXEN S NPCD=$P(TEXT,";",3) - S ECXNPCD=$G(NPCD) - Q ECXNPCD -ELGTXT ;Eligibility codes - ;;1;>49;10;SC 50-100% - ;;2;;20;Aid & Attendance - ;;15;;21;Housebound - ;;16;;22;Mexican Border War - ;;17;;23;WWI - ;;18;;24;POW - ;;3;40-49;30;SC 40-49% - ;;3;30-39;31;SC 30-39% - ;;3;20-29;32;SC 20-29% - ;;3;10-19;33;SC 10-19% - ;;3;<10;34;SC less than 10% - ;;4;;40;NSC - VA Pension - ;;5;;50;NSC - ;;21;;60;Catastrophic Disability - ;;12;;101;CHAMPVA - ;;13;;102;Collateral of Veteran - ;;14;;103;Employee - ;;6;;104;Other Federal Agency - ;;7;;105;Allied Veteran - ;;8;;106;Humanitarian Emergency - ;;9;;107;Sharing Agreement - ;;10;;108;Reimbursable Insurance - ;;19;;109;TRICARE/CHAMPUS - ;;22;;25;Purple Heart Recipient - ;;END - ; -CPT(ECXCPT,ECXMOD,ECXQUA) ;Returns a str with CPT code and modifier codes - ;Return string is composed of a 5 character CPT code 2 character quantity - ;plus up to 5 modifier codes, 2 characters each. - ; Variables - - ; Input ECXCPT - Pointer value to the CPT file (#81) - ; ECXMOD - A string with pointer values to the CPT - ; MODIFIER file (#81.3) separated by ";" - ; ECXQUA - Number of time this procedure performed - ; - ; Output: - ; CPTMOD - String of up to 17 characters, 5 character CPT - ; code 2 character qty plus up to 5 2-character - ; code modifiers. - ; - N CPT,MOD,I,CPTMOD - S ECXQUA=$G(ECXQUA,"01"),ECXMOD=$G(ECXMOD) - S:$L(ECXQUA)'=2 ECXQUA="0"_ECXQUA - S CPT=$$CPT^ICPTCOD(ECXCPT,"") I +CPT=-1 Q "" - S CPT=$P(CPT,U,2)_ECXQUA - F I=1:1:99 I $P(ECXMOD,";",I)'="" D - . S MOD=$$MOD^ICPTMOD($P(ECXMOD,";",I),"I","") - . I +MOD>0,$P(MOD,U,2)'="99" S CPT=CPT_$P(MOD,U,2) - S CPTMOD=$TR($E(CPT,1,17)," ") - Q CPTMOD - ; -CPTOUT(ECXCPT) ;output transform for CPT code plus modifiers - ;input ECXCPT - character string of CPT code plus modifiers (required) - ; - N J,CPTX,MOD,MODS,MODX,CPTMOD - Q:$G(ECXCPT)="" "" - S (CPTMOD,MODX)="" - S CPTX="("_+$E(ECXCPT,6,7)_") "_$E(ECXCPT,1,5),MODS=$E(ECXCPT,8,17) - F J=1:2:9 S MOD=$E(MODS,J,J+1) Q:MOD="" D - .I J>1 S MODX=MODX_", "_MOD Q - .S MODX=MODX_"-"_MOD - S:$L(CPTX)>3 CPTMOD=CPTMOD_CPTX_MODX - Q CPTMOD +ECXUTL3 ;ALB/GTS - Utilities for DSS Extracts ; 11/2/06 9:07am + ;;3.0;DSS EXTRACTS;**11,24,32,33,35,37,39,42,46,92**;Dec 22,1997;Build 30 + ; +OUTPTTM(ECXDFN,ECXDT) ;* Return PC Team from PCMM files or DPT + ; Variables - + ; ECXDFN - IEN from Patient file (Required) + ; ECXDT - Relevant Date for Primary Care Team + ; (Defaults to DT) + ; + ; Returned: ECXTM - + ; Pointer to team file (#404.51) + ; or, if error or none defined, returns 0 + ; + Q:'$G(ECXDFN) 0 ;** Quit if ECXDFN not defined + N ECXTM + S:'$D(ECXDT) ECXDT=DT + I $T(OUTPTTM^SDUTL3)[",SCDATE" D + .S ECXTM=+$$OUTPTTM^SDUTL3(ECXDFN,ECXDT) + I $T(OUTPTTM^SDUTL3)'[",SCDATE" D + .S ECXTM=+$$OUTPTTM^SDUTL3(ECXDFN) + I ECXTM=0 D + .S ECXTM=+$P($G(^DPT(+ECXDFN,"PC")),U,2) + Q ECXTM + ; +OUTPTPR(ECXDFN,ECXDT) ;* Return PC Provider from PCMM files or DPT + ; Variables - + ; ECXDFN - IEN from Patient file (Required) + ; ECXDT - Relevant Date for Primary Care Provider + ; (Defaults to DT) + ; + ; Returned: ECXPR - + ; Pointer to file #200 + ; or, if error or none defined, returns a 0 + ; + Q:'$G(ECXDFN) 0 ;** Quit if ECXDFN not defined + N ECXPR + S:'$D(ECXDT) ECXDT=DT + I $T(OUTPTPR^SDUTL3)[",SCDATE" D + .S ECXPR=+$$OUTPTPR^SDUTL3(ECXDFN,ECXDT) + I $T(OUTPTPR^SDUTL3)'[",SCDATE" D + .S ECXPR=+$$OUTPTPR^SDUTL3(ECXDFN) + I ECXPR=0 D + .S ECXPR=+$G(^DPT(+ECXDFN,"PC")) + Q ECXPR + ; +PAT(ECXDFN,ECXDATE,ECXDATA,ECXPAT) ;Return basic patient data for extract + ; Will not return data associated with test patients (SSN begin w 00000) + ; Variables - + ; Input ECXDFN - Patient internal entry number, DFN file#2; required + ; ECXDATE- Date used to get specific data from GETSTAT^DGMSTAPI + ; for MST. If no date, defaults to today's date, + ; standard FM format, optional + ; ECXDATA- Code indicating which data to return, optional. + ; If code not specified then returns all. Codes are: + ; 1 - DEM^VADPT (demographic data) + ; 2 - ADD^VADPT (current address) + ; 3 - ELIG^VADPT (eligibility & enrollment location) + ; 4 - OPD^VADPT (other patient data) + ; 5 - SVC^VADPT & GETSTAT^DGMSTAPI (service & MST inf) + ; ECXPAT(- Passed by reference; required + ; + ; Output: + ; ECXPAT 0 error or test patient no data in ECXPAT array + ; 1 data returned in ECXPAT array + ; ECXPAT( Local array with patient data. + ; + N SSN,I,ECXCOD,ECXDAT,DFN,VAPA,VADM,VAEL,VAPD,VASV,STR,ECXAR,DIC,DIQ,RCNUM,RCVAL,COLMETH + N DA,DR,PELG,MELIG,ZIP,MPI + I ECXDFN="" Q 0 + S SSN=$$GET1^DIQ(2,ECXDFN,.09,"I"),DFN=ECXDFN,ECXPAT=0 + I $E(SSN,1,5)="00000"!(SSN="") K ECXPAT Q 0 ;test patient + S STR="NAME;SSN;DOB;SEX;RACE;RELIGION;STATE;COUNTY;ZIP;SC%;MEANS;ELIG;" + S STR=STR_"EMPLOY;AO STAT;IR STAT;EC STAT;POW STAT;POW LOC;MST STAT;" + S STR=STR_"ENROLL LOC;MPI;VIETNAM;POS;MARITAL" + ;initialize return array values + F I=1:1 S ECXDAT=$P(STR,";",I) Q:ECXDAT="" S ECXPAT(ECXDAT)="" + F I=1:1:$L(ECXDATA,";") S ECXDAT=$P(ECXDATA,";",I) I ECXDAT'="" D + . S ECXCOD(ECXDAT)="" + ; + ;- Get ICN if MPI installed + S X="MPIF001" X ^%ZOSF("TEST") I $T D + .; + .;- Get 1st piece (either ICN # or -1 if error) + . S MPI=+$$GETICN^MPIF001(DFN) + .; + .;- If error, set to null + . S ECXPAT("MPI")=$S(MPI>0:MPI,1:"") + D ;get demographic data + . I ECXDATA'="",'$D(ECXCOD(1)) Q + . D DEM^VADPT + . S ECXPAT("NAME")=$E($P(VADM(1),",")_" ",1,4) + . S ECXPAT("SSN")=$P(VADM(2),U),ECXPAT("MARITAL")=$P(VADM(10),U) + . S ECXPAT("DOB")=$$ECXDOB^ECXUTL($P(VADM(3),U)) + . S ECXPAT("SEX")=$P(VADM(5),U),ECXPAT("RELIGION")=$P(VADM(9),U) + . S DIC=10,DR=2,DA=+VADM(8),DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1 + . S ECXPAT("RACE")=$G(ECXAR(10,DA,DR,"I")),ECXPAT=1 + . ;add new race and ethnicity fields for FY2003 + . S (ECXPAT("ETHNIC"),ECXPAT("RACE1"))="" + . S X="DGUTL4" X ^%ZOSF("TEST") I $T D + .. S COLMETH=$$PTR2CODE^DGUTL4($G(VADM(11,1,1)),3,4) I COLMETH="S" D + ... S ECXPAT("ETHNIC")=$$PTR2CODE^DGUTL4(+$G(VADM(11,1)),2,4) + .. S (RCVAL,RCNUM)="" + .. F S RCNUM=$O(VADM(12,RCNUM)) Q:RCNUM="" Q:RCVAL="C" S COLMETH=$$PTR2CODE^DGUTL4(+$G(VADM(12,RCNUM,1)),3,4) I COLMETH="S" D + ... S RCVAL=$$PTR2CODE^DGUTL4(+$G(VADM(12,RCNUM)),1,4) + ... I RCVAL="C" S ECXPAT("RACE1")=RCVAL Q + ... S ECXPAT("RACE1")=ECXPAT("RACE1")_RCVAL + D ;get address information + . I ECXDATA'="",'$D(ECXCOD(2)) Q + . D ADD^VADPT + . S DIC=5,DR=2,DA=+VAPA(5),DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1 + . S ECXPAT("STATE")=$G(ECXAR(5,DA,DR,"I")) + . S DIC=5,DA=+VAPA(5),DR=3,DR(5.01)=2,DA(5.01)=+VAPA(7),DIQ="ECXAR" + . S DIQ(0)="I" D EN^DIQ1 + . S ECXPAT("COUNTY")=$G(ECXAR(5.01,DA(5.01),2,"I")) + . S ECXPAT("ZIP")=$P(VAPA(11),U,2),ECXPAT=1 + D ;get eligibility information + . I ECXDATA'="",'$D(ECXCOD(3)) Q + . D ELIG^VADPT + . S PELG=$P(VAEL(1),U),MELIG=$S(PELG="":"",1:$$GET1^DIQ(8,PELG,8,"I")) + . S ECXPAT("POS")=$P($G(^DIC(21,+VAEL(2),0)),U,3) + . S ECXPAT("SC STAT")=$S(+VAEL(3):"Y",+VAEL(3)=0:"N",1:"") + . S ECXPAT("SC%")=$P(VAEL(3),U,2) + . S ECXPAT("VET")=$S(VAEL(4):"Y",VAEL(4)=0:"N",1:"") + . S ECXPAT("MEANS")=$P(VAEL(9),U),ECXPAT=1 + . S ECXPAT("ELIG")=$$ELIG(MELIG,ECXPAT("SC%")) + . ;get enrollment location + . S DIC=2,DR=27.02,DA=ECXDFN,DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1 + . S ECXDAT=$G(ECXAR(2,ECXDFN,DR,"I")) I ECXDAT K ECXAR D + . . S DIC=4,DA=ECXDAT,DR=99,DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1 + . . S ECXPAT("ENROLL LOC")=ECXAR(4,ECXDAT,DR,"I") + . ;get Emergency Response Indicator (FEMA) + . S ECXPAT("ERI")=$$GET1^DIQ(2,ECXDFN,.181,"I") + D ;get other patient information + . I ECXDATA'="",'$D(ECXCOD(4)) Q + . D OPD^VADPT + . S ECXPAT("EMPLOY")=$P(VAPD(7),U),ECXPAT=1 + D ;get service information + . I ECXDATA'="",'$D(ECXCOD(5)) Q + . D SVC^VADPT + . S ECXPAT("VIETNAM")=$S(VASV(1):"Y",VASV(2)=0:"N",1:"U") + . S ECXPAT("AO STAT")=$S(VASV(2):"Y",VASV(2)=0:"N",1:"U") + . S ECXPAT("IR STAT")=$S(VASV(3):"Y",VASV(3)=0:"N",1:"U") + . S ECXPAT("EC STAT")=$$GET1^DIQ(2,ECXDFN,.322013,"I") + . S ECXPAT("POW STAT")=$S(VASV(4):"Y",VASV(4)=0:"N",1:"U") + . S ECXPAT("POW LOC")=$P(VASV(4,3),U),ECXPAT=1 + . S ECXPAT("PHI")=$S(VASV(9)=1:"Y",VASV(9)=0:"N",1:"") + . ;- Agent Orange Location (K=Korean DMZ,V=Vietnam) + . S ECXPAT("AOL")=$P($G(VASV(2,5)),U) + . ;get patient current MST status + . I ECXDATE'="",ECXDATE'["." S ECXDATE=ECXDATE+.9 + . S X="DGMSTAPI" X ^%ZOSF("TEST") I $T D + . . S ECXDAT=$$GETSTAT^DGMSTAPI(DFN,ECXDATE) + . . S ECXPAT("MST STAT")=$S(+ECXDAT>0:$P(ECXDAT,U,2),1:"") + I 'ECXPAT K ECXPAT Q 0 + Q 1 + ; +ELIG(ECXELIG,ECXSVCP) ;Converts veteran eligibility code to NPCD code + ; Variables - + ; Input ECXELIG - Pointer to MAS ELIGIBILITY CODE file #8.1 + ; ECXSVCP - Number value rep. service connected percentage. + ; + ; Output: + ; ECXNCPD NPCD Eligibility Code + ; + N TEXT,IEN,SCPER,FND,NPCD,I,ECXBG,ECXEN,ECXNPCD + I ECXELIG="" Q "" + F I=1:1 S TEXT=$P($T(ELGTXT+I),";",3,999) Q:TEXT="END" D I $D(NPCD) Q + . S IEN=$P(TEXT,";"),SCPER=$P(TEXT,";",2) + . I ECXELIG=IEN D + . . I SCPER="" S NPCD=$P(TEXT,";",3) Q + . . S ECXBG=$S($E(SCPER)="<":0,$E(SCPER)=">":$P(SCPER,">",2)+1,SCPER["-":+SCPER,1:"") + . . S ECXEN=$S($E(SCPER)="<":$P(SCPER,"<",2),$E(SCPER)=">":100,SCPER["-":$P(SCPER,"-",2),1:"") + . . I ECXSVCP'ECXEN S NPCD=$P(TEXT,";",3) + S ECXNPCD=$G(NPCD) + Q ECXNPCD +ELGTXT ;Eligibility codes + ;;1;>49;10;SC 50-100% + ;;2;;20;Aid & Attendance + ;;15;;21;Housebound + ;;16;;22;Mexican Border War + ;;17;;23;WWI + ;;18;;24;POW + ;;3;40-49;30;SC 40-49% + ;;3;30-39;31;SC 30-39% + ;;3;20-29;32;SC 20-29% + ;;3;10-19;33;SC 10-19% + ;;3;<10;34;SC less than 10% + ;;4;;40;NSC - VA Pension + ;;5;;50;NSC + ;;21;;60;Catastrophic Disability + ;;12;;101;CHAMPVA + ;;13;;102;Collateral of Veteran + ;;14;;103;Employee + ;;6;;104;Other Federal Agency + ;;7;;105;Allied Veteran + ;;8;;106;Humanitarian Emergency + ;;9;;107;Sharing Agreement + ;;10;;108;Reimbursable Insurance + ;;19;;109;TRICARE/CHAMPUS + ;;22;;25;Purple Heart Recipient + ;;END + ; +CPT(ECXCPT,ECXMOD,ECXQUA) ;Returns a str with CPT code and modifier codes + ;Return string is composed of a 5 character CPT code 2 character quantity + ;plus up to 5 modifier codes, 2 characters each. + ; Variables - + ; Input ECXCPT - Pointer value to the CPT file (#81) + ; ECXMOD - A string with pointer values to the CPT + ; MODIFIER file (#81.3) separated by ";" + ; ECXQUA - Number of time this procedure performed + ; + ; Output: + ; CPTMOD - String of up to 17 characters, 5 character CPT + ; code 2 character qty plus up to 5 2-character + ; code modifiers. + ; + N CPT,MOD,I,CPTMOD + S ECXQUA=$G(ECXQUA,"01"),ECXMOD=$G(ECXMOD) + S:$L(ECXQUA)'=2 ECXQUA="0"_ECXQUA + S CPT=$$CPT^ICPTCOD(ECXCPT,"") I +CPT=-1 Q "" + S CPT=$P(CPT,U,2)_ECXQUA + F I=1:1:99 I $P(ECXMOD,";",I)'="" D + . S MOD=$$MOD^ICPTMOD($P(ECXMOD,";",I),"I","") + . I +MOD>0,$P(MOD,U,2)'="99" S CPT=CPT_$P(MOD,U,2) + S CPTMOD=$TR($E(CPT,1,17)," ") + Q CPTMOD + ; +CPTOUT(ECXCPT) ;output transform for CPT code plus modifiers + ;input ECXCPT - character string of CPT code plus modifiers (required) + ; + N J,CPTX,MOD,MODS,MODX,CPTMOD + Q:$G(ECXCPT)="" "" + S (CPTMOD,MODX)="" + S CPTX="("_+$E(ECXCPT,6,7)_") "_$E(ECXCPT,1,5),MODS=$E(ECXCPT,8,17) + F J=1:2:9 S MOD=$E(MODS,J,J+1) Q:MOD="" D + .I J>1 S MODX=MODX_", "_MOD Q + .S MODX=MODX_"-"_MOD + S:$L(CPTX)>3 CPTMOD=CPTMOD_CPTX_MODX + Q CPTMOD diff --git a/r/DSS_EXTRACTS-ECX/ECXUTL4.m b/r/DSS_EXTRACTS-ECX/ECXUTL4.m index dd49640c..8a8c59bb 100644 --- a/r/DSS_EXTRACTS-ECX/ECXUTL4.m +++ b/r/DSS_EXTRACTS-ECX/ECXUTL4.m @@ -1,288 +1,272 @@ -ECXUTL4 ;ALB/ESD - Utilities for DSS Extracts ; 11/26/07 10:58am - ;;3.0;DSS EXTRACTS;**39,41,46,49,78,92,105**;Dec 22,1997;Build 70 - ; -OBSPAT(ECXIO,ECXTS,DSSID) ; - ; Get observation patient indicator from DSS TREATING SPECIALTY - ; TRANSLATION file (#727.831) or DSS Identifier - ; - ; Input: - ; ECXIO - Inpatient/Outpatient indicator - ; ECXTS - Treating specialty (from file #42.4) - ; DSSID - DSS Identifier - ; - ;Output: - ; ECXOBS - Observation patient indicator (YES/NO) - ; - ;- Check input vars - S ECXIO=$G(ECXIO),ECXTS=+$G(ECXTS),DSSID=+$G(DSSID) - S ECXOBS="" - D - .;- Look up obs patient indicator if treating spec is in file #727.831 - . I $G(^ECX(727.831,ECXTS,0)) S ECXOBS=$P($G(^ECX(727.831,ECXTS,0)),"^",4) - . I ECXOBS'="" S ECXOBS=$S(ECXOBS="Y":"YES",1:"NO") Q - .; - .;- If outpatient and TS not in file, AND Feeder Key (CLI) or DSS ID - .;- (MTL,IVP,ECQ,QSR,NOS,SUR) is 290-296, Observation Patient Ind=YES - . I ECXIO="O",ECXOBS="",DSSID D - .. I $E(DSSID,1,3)>289&($E(DSSID,1,3)<297) S ECXOBS="YES" - .. E S ECXOBS="NO" - Q $S(ECXOBS'="":ECXOBS,1:"NO") - ; -INOUTP(ECXTS) ; - ; Get inpatient/outpatient indicator from DSS TREATING SPECIALTY - ; TRANSLATION file (#727.831) - ; - ; Input: - ; ECXTS - Treating specialty - ; - ; Output: - ; Inpatient/Outpatient indicator (I/O) - ; - S ECXTS=+$G(ECXTS) - S ECXIO="" - ; - ;- Look up inpat/outpat indicator if treating spec is in file - I $G(^ECX(727.831,ECXTS,0)) S ECXIO=$P($G(^ECX(727.831,ECXTS,0)),"^",5) - Q $S(ECXIO'="":ECXIO,1:"I") - ; -ENCNUM(ECXIO,ECXSSN,ECXADT,ECXVDT,ECXTRT,ECXOBS,ECXEXT,ECXSTP,ECXSTP2) ; - ; Get encounter number - ; - ; Input: - ; ECXIO - Inpat/Outpat indicator = I or O - ; ECXSSN - Patient SSN - ; ECXADT - Admit Date - ; ECXVDT - Visit Date - ; ECXTRT - Treating Spec - ; ECXOBS - Observation Pat Indicator - ; ECXEXT - Extract - ; ECXSTP - Stop Code (or stop code related) variable - ; ECXSTP2 - Stop Code (or stop code related) addtl variable - ; (used for SUR and ECS) - ; - ;Output: - ; Encounter Number - ; - N ENCNUM,ECXDATE,ECXSTCD - S (ENCNUM,ECXSTCD)="" - ; - ;- Check input vars - S ECXEXT=$G(ECXEXT),ECXIO=$G(ECXIO),ECXOBS=$G(ECXOBS),ECXTRT=+$G(ECXTRT) - S ECXSTP=+$G(ECXSTP),ECXSTP2=+$G(ECXSTP2) - S ECXADT=+$G(ECXADT),ECXVDT=+$G(ECXVDT) - ; - ;- Don't use pseudo-SSN in encounter number - S ECXSSN=$E($G(ECXSSN),1,9) - ; - D - . ;- Inpatient - . I ECXIO="I",ECXADT,ECXSSN'="" D Q - .. S ECXDATE=$$ADMITDT(ECXADT) - .. I ECXDATE'="" S ENCNUM=ECXSSN_ECXDATE_"I" - . ; - . ;- Outpatient branch - . I ECXIO="O" D - .. ;- Observation patient (outpatient) - .. I ECXOBS="YES",ECXSSN'="" D Q - ... ; - ... S ECXDATE=$S(ECXADT:$$JULDT(ECXADT),1:$$JULDT(ECXVDT)) - ... S ECXSTCD=$S(+$P($G(^ECX(727.831,ECXTRT,0)),"^",6):+$P($G(^ECX(727.831,ECXTRT,0)),"^",6),1:+$E(ECXSTP,1,3)) - ... Q:ECXDATE=""!(ECXSTCD="") - ... S ENCNUM=ECXSSN_ECXDATE_ECXSTCD - .. ; - .. ;- Outpatient (no observation pat) - .. I ECXOBS="NO",ECXVDT,ECXSSN'="" D Q - ... ; - ... ;- ADM, MOV, TRT have no outpat encounter number - ... I ECXEXT="ADM"!(ECXEXT="MOV")!(ECXEXT="TRT") Q - ... ; - ... ;- Use 1st 3 chars of DSS ID for NOS and ECQ (feeder key for CLI) - ... ;- Use observation stop code for IVP - ... I ECXEXT="CLI"!(ECXEXT="NOS")!(ECXEXT="ECQ")!(ECXEXT="IVP") S ECXSTCD=+$E(ECXSTP,1,3) Q:'ECXSTCD - ... ; - ... ;- Use cost center to obtain stop code for ECS - ... I ECXEXT="ECS" D Q:'ECXSTCD - .... S ECXSTCD=$$ECSCOST(ECXSTP2) - ....; - ....;- If no cost center, use 1st 3 chars of DSS ID - .... I ECXSTCD="" S ECXSTCD=+$E(ECXSTP,1,3) - ... ; - ... ;- These extracts have predetermined stop code values - ... I ECXEXT="DEN" S ECXSTCD=180 - ... I ECXEXT="PRE"!(ECXEXT="UDP") S ECXSTCD=160 - ... I ECXEXT="LAB"!(ECXEXT="LAR")!(ECXEXT="LBB") S ECXSTCD=108 - ... I ECXEXT="MTL" S ECXSTCD=538 - ... I ECXEXT="NUR" S ECXSTCD=950 - ... I ECXEXT="PRO" S ECXSTCD=423 - ... I ECXEXT="NUT" S ECXSTCD="NUT" - ... ; - ... ;- If Imaging Type fld=2, use 109 otherwise use 105 - ... I ECXEXT="RAD" S ECXSTCD=$S(ECXSTP=2:109,1:105) - ... ; - ... ;- Use DSS STOP CODE fld if populated or if SURG SPEC fld=59 use 430 - ... ;- otherwise if null use 429 - ... I ECXEXT="SUR" S ECXSTCD=$S(ECXSTP:ECXSTP,ECXSTP2=59:430,1:429) - ... ; - ... ;- Get Julian Date - ... S ECXDATE=$$JULDT(ECXVDT) - ... I ECXDATE'="" S ENCNUM=ECXSSN_ECXDATE_ECXSTCD - Q ENCNUM - ; -ADMITDT(ECXINDT) ; Returns date in YYMMDD format - ; - ; Input: - ; ECXINDT - Date (can also include time) in internal FM format - ; - ;Output: - ; Date in YYMMDD form - ; - N ECXDT - S ECXDT="" - S ECXINDT=+$G(ECXINDT) - ; - ;- If no input or full FM date not passed in, quit - I 'ECXINDT!($L(ECXINDT)<7) G ADMTDTQ - ; - ;- Date in YYMMDD form - S ECXDT=$TR($$FMTE^XLFDT(ECXINDT,"4DF")," /","0") -ADMTDTQ Q ECXDT - ; - ; -JULDT(ECXINDT) ; Returns Julian Date in MMDDD format - ; - ; Input: - ; ECINDT - Date (can also include time) in internal FM format - ; - ;Output: - ; Julian date in MM_DDD form - ; - N ECXDDD,ECXDT,ECXJUL,ECXMM - S (ECXDDD,ECXMM)="" - ; - ;- If no input or full FM date not passed in, quit - S ECXINDT=+$G(ECXINDT) - I 'ECXINDT!($L(ECXINDT)<7) G JULDTQ - ; - ;- Extract date portion - S ECXDT=$E(ECXINDT,1,7) - ; - ;- Get month (MM) - S ECXMM=$E(ECXINDT,2,3) - ; - ;- Number of day within year (DDD) - S ECXDDD=$$RJ^XLFSTR($$FMDIFF^XLFDT(ECXDT,$E(ECXDT,1,3)_"0101",1)+1,3,"0") -JULDTQ Q ECXMM_ECXDDD - ; -CNHSTAT(ECXDFN) ; Get CNH (Contract Nursing Home) status - ; - ; Input: - ; ECXDFN - Patient DFN - ; - ;Output: - ; CNH status (YES/NO) - ; - N ECXCNH - S ECXDFN=+$G(ECXDFN) - S ECXCNH=$P($G(^DPT(ECXDFN,"NHC")),U) - Q $S(ECXCNH="Y":"YES",ECXCNH="N":"NO",1:"") - ; -CANC(ECXNOR,ECXTMOR) ; Get Surgery Cancelled/Aborted Status - ; - ; Function called after determining CANCEL DATE in SURGERY record exists - ; - ; Input: - ; ECXNOR - Non-OR DSS ID - ; ECXTMOR - Time Pat in OR - ; - ;Output: - ; Cancelled/aborted status (C/A) - ; - N ECXCANC - S ECXCANC="" - S ECXNOR=$G(ECXNOR) - ; - ;- If Non-OR DSS ID or Time Pat in OR, ECXCANC = "A" else = "C" - D - . I ECXNOR'=""&(ECXNOR'="UNKNOWN") S ECXCANC="A" Q - . I +$G(ECXTMOR) S ECXCANC="A" Q - . S ECXCANC="C" - Q ECXCANC - ; -ECSCOST(ECXCOST) ;Get ECS extract stop code based on cost center - ; - ; - ; Input: - ; ECXCOST - ECS extract cost center - ; - ;Output: - ; ECS extract stop code - ; - N ECXFND,ECXSTOP,I - S ECXFND=0 - S ECXSTOP="" - S ECXCOST=+$G(ECXCOST) - D - . I 'ECXCOST Q - . F I=1:1 Q:ECXFND!($P($T(COST+I),";;",2)="END") D - .. I ECXCOST=$P($T(COST+I),";;",2) S ECXSTOP=$P($T(COST+I),";;",3),ECXFND=1 - Q ECXSTOP - ; -COST ;- ECS Cost Center and stop code - ;;833100;;652 - ;;833200;;653 - ;;833300;;681 - ;;834100;;651 - ;;834200;;650 - ;;834300;;681 - ;;834400;;654 - ;;834500;;681 - ;;834600;;681 - ;;834700;;681 - ;;834800;;681 - ;;834900;;681 - ;;836100;;654 - ;;836200;;654 - ;;END - ; -HNCI(ECXDFN) ; Get head & neck cancer indicator - ; - ; Input: - ; ECXDFN - Patient DFN - ; - ;Output: - ; Head/Neck CA DX (Y/N) - ; - N ECXHNCI,DGNT - S ECXHNCI="" - S ECXDFN=+$G(ECXDFN) I ECXDFN D - .I $$GETCUR^DGNTAPI(ECXDFN,"DGNT") S ECXHNCI=$P(DGNT("HNC"),U) - Q ECXHNCI - ; -TSMAP(ECXTS) ;Determines DSS Identifier for the following observation - ; treating specialty - ; Input: - ; ECXTS - Observation Treating Specialty - ; - ; Output: - ; DSS Identifier (Stop Code) - ; - N TS,SC,I - S TS="^18^23^24^36^41^65^94^",SC="^293^295^290^294^296^291^292^" - F I=1:1:$L(TS) Q:$P(TS,"^",I)=ECXTS - Q $P(SC,"^",I)_"000" -OEFDATA ; - ;get patient OEF/OIF status and date of return - S (ECXOEF,ECXOEFDT)="" - I $G(VASV(11))>0 S ECXOEF=ECXOEF_"OIF" - I $G(VASV(12))>0 S ECXOEF=ECXOEF_"OEF" - I $G(VASV(13))>0 S ECXOEF=ECXOEF_"UNK" - I ECXOEF'="" D - . S ECXOEFDT="" - . I $G(VASV(11))>0 S ECXOEFDT=$P($G(VASV(11,$G(VASV(11)),3)),"^") - . I $G(VASV(12))>0,$P($G(VASV(12,$G(VASV(12)),3)),"^")>ECXOEFDT S ECXOEFDT=$P($G(VASV(12,$G(VASV(12)),3)),"^") - . I $G(VASV(13))>0,$P($G(VASV(13,$G(VASV(13)),3)),"^")>ECXOEFDT S ECXOEFDT=$P($G(VASV(13,$G(VASV(13)),3)),"^") - . I ECXOEFDT>0 S ECXOEFDT=17000000+ECXOEFDT - ; - S ECXPAT("ECXOEF")=ECXOEF - S ECXPAT("ECXOEFDT")=ECXOEFDT - Q +ECXUTL4 ;ALB/ESD - Utilities for DSS Extracts ; 11/2/06 9:08am + ;;3.0;DSS EXTRACTS;**39,41,46,49,78,92**;Dec 22,1997;Build 30 + ; +OBSPAT(ECXIO,ECXTS,DSSID) ; + ; Get observation patient indicator from DSS TREATING SPECIALTY + ; TRANSLATION file (#727.831) or DSS Identifier + ; + ; Input: + ; ECXIO - Inpatient/Outpatient indicator + ; ECXTS - Treating specialty (from file #42.4) + ; DSSID - DSS Identifier + ; + ;Output: + ; ECXOBS - Observation patient indicator (YES/NO) + ; + ;- Check input vars + S ECXIO=$G(ECXIO),ECXTS=+$G(ECXTS),DSSID=+$G(DSSID) + S ECXOBS="" + D + .;- Look up obs patient indicator if treating spec is in file #727.831 + . I $G(^ECX(727.831,ECXTS,0)) S ECXOBS=$P($G(^ECX(727.831,ECXTS,0)),"^",4) + . I ECXOBS'="" S ECXOBS=$S(ECXOBS="Y":"YES",1:"NO") Q + .; + .;- If outpatient and TS not in file, AND Feeder Key (CLI) or DSS ID + .;- (MTL,IVP,ECQ,QSR,NOS,SUR) is 290-296, Observation Patient Ind=YES + . I ECXIO="O",ECXOBS="",DSSID D + .. I $E(DSSID,1,3)>289&($E(DSSID,1,3)<297) S ECXOBS="YES" + .. E S ECXOBS="NO" + Q $S(ECXOBS'="":ECXOBS,1:"NO") + ; +INOUTP(ECXTS) ; + ; Get inpatient/outpatient indicator from DSS TREATING SPECIALTY + ; TRANSLATION file (#727.831) + ; + ; Input: + ; ECXTS - Treating specialty + ; + ; Output: + ; Inpatient/Outpatient indicator (I/O) + ; + S ECXTS=+$G(ECXTS) + S ECXIO="" + ; + ;- Look up inpat/outpat indicator if treating spec is in file + I $G(^ECX(727.831,ECXTS,0)) S ECXIO=$P($G(^ECX(727.831,ECXTS,0)),"^",5) + Q $S(ECXIO'="":ECXIO,1:"I") + ; +ENCNUM(ECXIO,ECXSSN,ECXADT,ECXVDT,ECXTRT,ECXOBS,ECXEXT,ECXSTP,ECXSTP2) ; + ; Get encounter number + ; + ; Input: + ; ECXIO - Inpat/Outpat indicator = I or O + ; ECXSSN - Patient SSN + ; ECXADT - Admit Date + ; ECXVDT - Visit Date + ; ECXTRT - Treating Spec + ; ECXOBS - Observation Pat Indicator + ; ECXEXT - Extract + ; ECXSTP - Stop Code (or stop code related) variable + ; ECXSTP2 - Stop Code (or stop code related) addtl variable + ; (used for SUR and ECS) + ; + ;Output: + ; Encounter Number + ; + N ENCNUM,ECXDATE,ECXSTCD + S (ENCNUM,ECXSTCD)="" + ; + ;- Check input vars + S ECXEXT=$G(ECXEXT),ECXIO=$G(ECXIO),ECXOBS=$G(ECXOBS),ECXTRT=+$G(ECXTRT) + S ECXSTP=+$G(ECXSTP),ECXSTP2=+$G(ECXSTP2) + S ECXADT=+$G(ECXADT),ECXVDT=+$G(ECXVDT) + ; + ;- Don't use pseudo-SSN in encounter number + S ECXSSN=$E($G(ECXSSN),1,9) + ; + D + . ;- Inpatient + . I ECXIO="I",ECXADT,ECXSSN'="" D Q + .. S ECXDATE=$$ADMITDT(ECXADT) + .. I ECXDATE'="" S ENCNUM=ECXSSN_ECXDATE_"I" + . ; + . ;- Outpatient branch + . I ECXIO="O" D + .. ;- Observation patient (outpatient) + .. I ECXOBS="YES",ECXSSN'="" D Q + ... ; + ... S ECXDATE=$S(ECXADT:$$JULDT(ECXADT),1:$$JULDT(ECXVDT)) + ... S ECXSTCD=$S(+$P($G(^ECX(727.831,ECXTRT,0)),"^",6):+$P($G(^ECX(727.831,ECXTRT,0)),"^",6),1:+$E(ECXSTP,1,3)) + ... Q:ECXDATE=""!(ECXSTCD="") + ... S ENCNUM=ECXSSN_ECXDATE_ECXSTCD + .. ; + .. ;- Outpatient (no observation pat) + .. I ECXOBS="NO",ECXVDT,ECXSSN'="" D Q + ... ; + ... ;- ADM, MOV, TRT have no outpat encounter number + ... I ECXEXT="ADM"!(ECXEXT="MOV")!(ECXEXT="TRT") Q + ... ; + ... ;- Use 1st 3 chars of DSS ID for NOS and ECQ (feeder key for CLI) + ... ;- Use observation stop code for IVP + ... I ECXEXT="CLI"!(ECXEXT="NOS")!(ECXEXT="ECQ")!(ECXEXT="IVP") S ECXSTCD=+$E(ECXSTP,1,3) Q:'ECXSTCD + ... ; + ... ;- Use cost center to obtain stop code for ECS + ... I ECXEXT="ECS" D Q:'ECXSTCD + .... S ECXSTCD=$$ECSCOST(ECXSTP2) + ....; + ....;- If no cost center, use 1st 3 chars of DSS ID + .... I ECXSTCD="" S ECXSTCD=+$E(ECXSTP,1,3) + ... ; + ... ;- These extracts have predetermined stop code values + ... I ECXEXT="DEN" S ECXSTCD=180 + ... I ECXEXT="PRE"!(ECXEXT="UDP") S ECXSTCD=160 + ... I ECXEXT="LAB"!(ECXEXT="LAR")!(ECXEXT="LBB") S ECXSTCD=108 + ... I ECXEXT="MTL" S ECXSTCD=538 + ... I ECXEXT="NUR" S ECXSTCD=950 + ... I ECXEXT="PRO" S ECXSTCD=423 + ... I ECXEXT="NUT" S ECXSTCD="NUT" + ... ; + ... ;- If Imaging Type fld=2, use 109 otherwise use 105 + ... I ECXEXT="RAD" S ECXSTCD=$S(ECXSTP=2:109,1:105) + ... ; + ... ;- Use DSS STOP CODE fld if populated or if SURG SPEC fld=59 use 430 + ... ;- otherwise if null use 429 + ... I ECXEXT="SUR" S ECXSTCD=$S(ECXSTP:ECXSTP,ECXSTP2=59:430,1:429) + ... ; + ... ;- Get Julian Date + ... S ECXDATE=$$JULDT(ECXVDT) + ... I ECXDATE'="" S ENCNUM=ECXSSN_ECXDATE_ECXSTCD + Q ENCNUM + ; +ADMITDT(ECXINDT) ; Returns date in YYMMDD format + ; + ; Input: + ; ECXINDT - Date (can also include time) in internal FM format + ; + ;Output: + ; Date in YYMMDD form + ; + N ECXDT + S ECXDT="" + S ECXINDT=+$G(ECXINDT) + ; + ;- If no input or full FM date not passed in, quit + I 'ECXINDT!($L(ECXINDT)<7) G ADMTDTQ + ; + ;- Date in YYMMDD form + S ECXDT=$TR($$FMTE^XLFDT(ECXINDT,"4DF")," /","0") +ADMTDTQ Q ECXDT + ; + ; +JULDT(ECXINDT) ; Returns Julian Date in MMDDD format + ; + ; Input: + ; ECINDT - Date (can also include time) in internal FM format + ; + ;Output: + ; Julian date in MM_DDD form + ; + N ECXDDD,ECXDT,ECXJUL,ECXMM + S (ECXDDD,ECXMM)="" + ; + ;- If no input or full FM date not passed in, quit + S ECXINDT=+$G(ECXINDT) + I 'ECXINDT!($L(ECXINDT)<7) G JULDTQ + ; + ;- Extract date portion + S ECXDT=$E(ECXINDT,1,7) + ; + ;- Get month (MM) + S ECXMM=$E(ECXINDT,2,3) + ; + ;- Number of day within year (DDD) + S ECXDDD=$$RJ^XLFSTR($$FMDIFF^XLFDT(ECXDT,$E(ECXDT,1,3)_"0101",1)+1,3,"0") +JULDTQ Q ECXMM_ECXDDD + ; +CNHSTAT(ECXDFN) ; Get CNH (Contract Nursing Home) status + ; + ; Input: + ; ECXDFN - Patient DFN + ; + ;Output: + ; CNH status (YES/NO) + ; + N ECXCNH + S ECXDFN=+$G(ECXDFN) + S ECXCNH=$P($G(^DPT(ECXDFN,"NHC")),U) + Q $S(ECXCNH="Y":"YES",ECXCNH="N":"NO",1:"") + ; +CANC(ECXNOR,ECXTMOR) ; Get Surgery Cancelled/Aborted Status + ; + ; Function called after determining CANCEL DATE in SURGERY record exists + ; + ; Input: + ; ECXNOR - Non-OR DSS ID + ; ECXTMOR - Time Pat in OR + ; + ;Output: + ; Cancelled/aborted status (C/A) + ; + N ECXCANC + S ECXCANC="" + S ECXNOR=$G(ECXNOR) + ; + ;- If Non-OR DSS ID or Time Pat in OR, ECXCANC = "A" else = "C" + D + . I ECXNOR'=""&(ECXNOR'="UNKNOWN") S ECXCANC="A" Q + . I +$G(ECXTMOR) S ECXCANC="A" Q + . S ECXCANC="C" + Q ECXCANC + ; +ECSCOST(ECXCOST) ;Get ECS extract stop code based on cost center + ; + ; + ; Input: + ; ECXCOST - ECS extract cost center + ; + ;Output: + ; ECS extract stop code + ; + N ECXFND,ECXSTOP,I + S ECXFND=0 + S ECXSTOP="" + S ECXCOST=+$G(ECXCOST) + D + . I 'ECXCOST Q + . F I=1:1 Q:ECXFND!($P($T(COST+I),";;",2)="END") D + .. I ECXCOST=$P($T(COST+I),";;",2) S ECXSTOP=$P($T(COST+I),";;",3),ECXFND=1 + Q ECXSTOP + ; +COST ;- ECS Cost Center and stop code + ;;833100;;652 + ;;833200;;653 + ;;833300;;681 + ;;834100;;651 + ;;834200;;650 + ;;834300;;681 + ;;834400;;654 + ;;834500;;681 + ;;834600;;681 + ;;834700;;681 + ;;834800;;681 + ;;834900;;681 + ;;836100;;654 + ;;836200;;654 + ;;END + ; +HNCI(ECXDFN) ; Get head & neck cancer indicator + ; + ; Input: + ; ECXDFN - Patient DFN + ; + ;Output: + ; Head/Neck CA DX (Y/N) + ; + N ECXHNCI,DGNT + S ECXHNCI="" + S ECXDFN=+$G(ECXDFN) I ECXDFN D + .I $$GETCUR^DGNTAPI(ECXDFN,"DGNT") S ECXHNCI=$P(DGNT("HNC"),U) + Q ECXHNCI + ; +TSMAP(ECXTS) ;Determines DSS Identifier for the following observation + ; treating specialty + ; Input: + ; ECXTS - Observation Treating Specialty + ; + ; Output: + ; DSS Identifier (Stop Code) + ; + N TS,SC,I + S TS="^18^23^24^36^41^65^94^",SC="^293^295^290^294^296^291^292^" + F I=1:1:$L(TS) Q:$P(TS,"^",I)=ECXTS + Q $P(SC,"^",I)_"000" diff --git a/r/DSS_EXTRACTS-ECX/ECXUTL5.m b/r/DSS_EXTRACTS-ECX/ECXUTL5.m index 70f38025..42402947 100644 --- a/r/DSS_EXTRACTS-ECX/ECXUTL5.m +++ b/r/DSS_EXTRACTS-ECX/ECXUTL5.m @@ -1,224 +1,208 @@ -ECXUTL5 ;ALB/JRC - Utilities for DSS Extracts ; 10/17/07 3:49pm - ;;3.0;DSS EXTRACTS;**71,84,92,103,105**;Dec 22, 1997;Build 70 - ; -REPEAT(CHAR,TIMES) ;REPEAT A STRING - ;INPUT : CHAR - Character to repeat - ; TIMES - Number of times to repeat CHAR - ;OUTPUT : s - String of CHAR that is TIMES long - ; "" - Error (bad input) - ; - ;CHECK INPUT - Q:($G(CHAR)="") "" - Q:((+$G(TIMES))=0) "" - ;RETURN STRING - Q $TR($J("",TIMES)," ",CHAR) -INSERT(INSTR,OUTSTR,COLUMN,LENGTH) ;INSERT A STRING INTO ANOTHER - ;INPUT : INSTR - String to insert - ; OUTSTR - String to insert into - ; COLUMN - Where to begin insertion (defaults to end of OUTSTR) - ; LENGTH - Number of characters to clear from OUTSTR - ; (defaults to length of INSTR) - ;OUTPUT : s - INSTR will be placed into OUTSTR starting at COLUMN - ; using LENGTH characters - ; "" - Error (bad input) - ; - ;NOTE : This module is based on $$SETSTR^VALM1 - ; - ;CHECK INPUT - Q:('$D(INSTR)) "" - Q:('$D(OUTSTR)) "" - S:('$D(COLUMN)) COLUMN=$L(OUTSTR)+1 - S:('$D(LENGTH)) LENGTH=$L(INSTR) - ;DECLARE VARIABLES - N FRONT,END - S FRONT=$E((OUTSTR_$J("",COLUMN-1)),1,(COLUMN-1)) - S END=$E(OUTSTR,(COLUMN+LENGTH),$L(OUTSTR)) - ;INSERT STRING - Q FRONT_$E((INSTR_$J("",LENGTH)),1,LENGTH)_END -TYPE(DFN) ;Determine patient type DBIA #2511 - ; input - ; DFN = patient ien - ; - ; output - ; ECXPTYPE = patient type external value from fle 391 - ; - ; AC = ACTIVE DUTY MI = MILITARY RETIREE - ; AL = ALLIED VETERAN NO = NON-VETERAN (OTHER) - ; CO = COLLATERAL NS = NSC VETERAN - ; EM = EMPLOYEE SC = SC VETERAN - ; IN = INELIGIBLE TR = TRICARE - ; return value 0 if no data found, 1 if data found - ; - N TYPE,ECXPTYPE - ;Check input - Q:'$D(DFN) "" - S (TYPE,ECXPTYPE)="" - S TYPE=$G(^DPT(DFN,"TYPE")) - I 'TYPE Q ECXPTYPE - S ECXPTYPE=$P($G(^DG(391,TYPE,0)),U,1) - S ECXPTYPE=$E(ECXPTYPE,1,2) - Q ECXPTYPE -CVEDT(DFN,DATE) ;Determine patient CV status DBIA #4156 - ; input - ; DFN = patient ien - ; - ; output - ; ECXCVE = combat veteran status eligibility - ; ECXCVEDT = combat veteran eligibility end date - ; ECXCVENC = combat veteran encounter - ;Initialize variables - N CVSTAT - S (CVSTAT,ECXCVE,ECXCVEDT,ECXCVENC)="" - ;Check input - Q:'$D(DFN) 0 - ;Call CV API - S CVSTAT=$$CVEDT^DGCV(DFN,DATE) - I CVSTAT<1 Q 0 - ;Veteran been given CV eligibility - S ECXCVE=$S($P(CVSTAT,U,3)=1:"Y",$P(CVSTAT,U,3)=0:"E",1:"") - ;Save CV eligibility end date and convert from FM to HL7 format - S ECXCVEDT=$P(CVSTAT,U,2) - S ECXCVEDT=$$FMTHL7^XLFDT(ECXCVEDT) - ;Is the veteran eligible for CV in the date of encounter - S ECXCVENC=$S($P(CVSTAT,U,3)=1:"Y",1:"") - Q 1 -NPRF ;National patient record flags DBIA #3860 - N ECXARR,FLG - S ECXNPRFI="",CNT=$$GETACT^DGPFAPI(ECXDFN,"ECXARR"),FLG="" - I 'CNT Q - F I=1:1:CNT D Q:FLG - .I ECXARR(I,"CATEGORY")["NATIONAL" S ECXNPRFI="Y",FLG=1 - Q -RXPTST(K) ;Rx patient status DBIA #2511 - N ECXDIC,STAT - S (ECXDIC,STAT)="" - ;Check input - Q:'$D(K) STAT - S DA=K,DIC="^PS(53,",DIQ(0)="I",DIQ="ECXDIC",DR="6" - D EN^DIQ1 - S STAT=$G(ECXDIC(53,K,6,"I")) - S STAT=$S(STAT=1:"SC",STAT=2:"AA",STAT=3:"OTH",STAT=4:"INP",STAT=5:"NON",1:"") - Q STAT -NONVAP(K) ;Non-va prescriber DBIA #10060 - N ECXDIC,NONVAP - S (ECXDIC,NONVAP)="" - Q:'$D(K) NONVAP - S DA=K,DIC="^VA(200,",DIQ(0)="I",DIQ="ECXDIC",DR="53.91" - D EN^DIQ1 - S NONVAP=$G(ECXDIC(200,K,53.91,"I")) - I NONVAP S NONVAP="Y" - Q NONVAP -DOIVPO(K,L) ;Add destination for outpatient ivp orders - ; Input K - DFN - ; L - Order # from Pharmacy Patient File (#55) - ; - ; Output ordering stop code - ; - N ECXDIC,ECXDICA,ECXDICB,DOIVPO,CLINIC,SCODE,DIC,DIQ,DR,DA - S (ECXDIC,ECXDICA,ECXDICB,DOIVPO,CLINIC,SCODE)="" - ;Check input - Q:'K!'(L) SCODE - ;Check treating specialty - S SCODE=$$TSSC($G(ECXTS)) I SCODE>0 Q SCODE - ;Go to pharmacy patient file (#55) and return value of field (#136) - S DIC=55,DIQ(0)="I",DIQ="ECXDIC",DR="100",DR(55.01)="136",DA=K,DA(55.01)=L - D EN^DIQ1 - S CLINIC=$G(ECXDIC(55.01,L,136,"I")) - I 'CLINIC Q SCODE - ;Get stop code pointer to file 40.7 from file 44 - S DIC="^SC(",DIQ(0)="I",DIQ="ECXDICA",DR="8",DA=CLINIC D EN^DIQ1 - S SCODE=ECXDICA(44,CLINIC,8,"I") - ;Get stop code external value - S DIC="^DIC(40.7,",DIQ(0)="E",DIQ="ECXDICB",DR="1",DA=SCODE D EN^DIQ1 - S SCODE=$G(ECXDICB(40.7,SCODE,1,"E")) - Q SCODE - ; -DOUDO(K,L) ;Add destination for outpatient udp orders - ; Input K - DFN - ; L - Order # from Pharmacy Patient File (#55) - ; - ; Output ordering stop code - ; - N ECXDIC,ECXDICA,ECXDICB,DOIVPO,CLINIC,SCODE,DIC,DIQ,DR,DA - S (ECXDIC,ECXDICA,ECXDICB,DOIVPO,CLINIC,SCODE)="" - ;Check treating specialty - S SCODE=$$TSSC($G(ECXTS)) I SCODE>0 Q SCODE - ;Check input - Q:'K!'(L) SCODE - S DIC=55,DIQ(0)="I",DIQ="ECXDIC",DR="62",DR(55.06)="130",DA=K,DA(55.06)=L - D EN^DIQ1 - S CLINIC=$G(ECXDIC(55.06,L,130,"I")) - I 'CLINIC Q SCODE - ;Get stop code pointer to file 40.7 from file 44 - S DIC="^SC(",DIQ(0)="I",DIQ="ECXDICA",DR="8",DA=CLINIC D EN^DIQ1 - S SCODE=ECXDICA(44,CLINIC,8,"I") - ;Get stop code external value - S DIC="^DIC(40.7,",DIQ(0)="E",DIQ="ECXDICB",DR="1",DA=SCODE D EN^DIQ1 - S SCODE=$G(ECXDICB(40.7,SCODE,1,"E")) - Q SCODE - ; -PHAAPI(DRUG) ;Call Pharmacy drug file API dbia 4483 - ; Input: drug file (#50) ien - ; - ; Output: generic name ^ classification ^ ndc ^ dea hand - ; ^ ndf file entry # ^ psndf va product entry ^ - ; price per disp unit ^ dispense unit - ; - ;Initialize variables and scratch global - N NAME,CLASS,NDC,INV,NDF,P1,P3,PPDU,UNIT,ARRAY,DATA - S (NAME,CLASS,NDC,INV,NDF,P1,P3,PPDU,ARRAY,DATA)="" - S ARRAY="^TMP($J,""ECXLIST"")" - K @ARRAY - D DATA^PSS50(DRUG,,,,,"ECXLIST") - I @ARRAY@(0)'>0 Q "^^^^^^" - S NAME=@ARRAY@(DRUG,.01),CLASS=@ARRAY@(DRUG,2),NDC=@ARRAY@(DRUG,31) - S INV=@ARRAY@(DRUG,3),P1=$P(@ARRAY@(DRUG,20),U),P3=$P(@ARRAY@(DRUG,22),U),PPDU=@ARRAY@(DRUG,16),UNIT=@ARRAY@(DRUG,14.5) - K @ARRAY - Q NAME_U_CLASS_U_NDC_U_INV_U_P1_U_P3_U_PPDU_U_UNIT - ; -TSSC(X) ;Check treating specialty (ts) and if ts equals any of the following - ;18,23,24,36,41,65,94 then assign predefined code and return value - ; - ; Input: treating specialty - ; Output: Ordering stop code - ; - S CODE=$S(X=18:293,X=23:295,X=24:290,X=36:294,X=41:296,X=65:291,X=94:292,1:"") - Q CODE - ; -PSJ59P5(X) ;Get iv room division - ; Input X - iv room ien - ; - ; Output - field .02 division - ;Init variables - N DIV S DIV="" - ;Check input - I 'X Q DIV - D ALL^PSJ59P5(X,,"ECXDIV") - S DIV=$P($G(^TMP($J,"ECXDIV",X,.02)),U) - K ^TMP($J,"ECXDIV") - Q DIV - ; -SCRX(IEN) ;Service connected prescription - ;Init variables - N DIC,DR,DA,ECXDIQ - ;Check input - I '$G(IEN) Q "" - S DIC=52,DR="116",DA=IEN,DIQ="ECXDIQ" - D DIQ^PSODI(DIC,DIC,DR,DA,DIQ) - Q $S($G(ECXDIQ(52,DA,116))="YES":"Y",$G(ECXDIQ(52,DA,116))="NO":"N",1:"") - ; -SSN(SSN,FILE) ; extended validation of ssn - ; input: ssn - social security number to validate - ; file - optional "", 2 or 67, the only check is for - ; reference lab file (#67) in which case ssn - ; "000123456" is considered a valid ssn. - ; output: 0 - test patient or invalid ssn - ; 1 - valid ssn - ; - ;check input - I $G(SSN)']"" Q 0 - S FILE=$G(FILE) - I (FILE=67)&(SSN="000123456") Q 1 - I "89"[$E(SSN) Q 0 - I (SSN="123456789")!(SSN="111111111")!(SSN="222222222")!(SSN="333333333")!(SSN="444444444")!(SSN="555555555")!($E(SSN,1,3)="666")!($E(SSN,4,5)="00")!($E(SSN,1,3)="000") Q 0 - Q 1 +ECXUTL5 ;ALB/JRC - Utilities for DSS Extracts ; 01/18/07 9:04am + ;;3.0;DSS EXTRACTS;**71,84,92,103**;Dec 22, 1997;Build 1 + ; +REPEAT(CHAR,TIMES) ;REPEAT A STRING + ;INPUT : CHAR - Character to repeat + ; TIMES - Number of times to repeat CHAR + ;OUTPUT : s - String of CHAR that is TIMES long + ; "" - Error (bad input) + ; + ;CHECK INPUT + Q:($G(CHAR)="") "" + Q:((+$G(TIMES))=0) "" + ;RETURN STRING + Q $TR($J("",TIMES)," ",CHAR) +INSERT(INSTR,OUTSTR,COLUMN,LENGTH) ;INSERT A STRING INTO ANOTHER + ;INPUT : INSTR - String to insert + ; OUTSTR - String to insert into + ; COLUMN - Where to begin insertion (defaults to end of OUTSTR) + ; LENGTH - Number of characters to clear from OUTSTR + ; (defaults to length of INSTR) + ;OUTPUT : s - INSTR will be placed into OUTSTR starting at COLUMN + ; using LENGTH characters + ; "" - Error (bad input) + ; + ;NOTE : This module is based on $$SETSTR^VALM1 + ; + ;CHECK INPUT + Q:('$D(INSTR)) "" + Q:('$D(OUTSTR)) "" + S:('$D(COLUMN)) COLUMN=$L(OUTSTR)+1 + S:('$D(LENGTH)) LENGTH=$L(INSTR) + ;DECLARE VARIABLES + N FRONT,END + S FRONT=$E((OUTSTR_$J("",COLUMN-1)),1,(COLUMN-1)) + S END=$E(OUTSTR,(COLUMN+LENGTH),$L(OUTSTR)) + ;INSERT STRING + Q FRONT_$E((INSTR_$J("",LENGTH)),1,LENGTH)_END +TYPE(DFN) ;Determine patient type DBIA #2511 + ; input + ; DFN = patient ien + ; + ; output + ; ECXPTYPE = patient type external value from fle 391 + ; + ; AC = ACTIVE DUTY MI = MILITARY RETIREE + ; AL = ALLIED VETERAN NO = NON-VETERAN (OTHER) + ; CO = COLLATERAL NS = NSC VETERAN + ; EM = EMPLOYEE SC = SC VETERAN + ; IN = INELIGIBLE TR = TRICARE + ; return value 0 if no data found, 1 if data found + ; + N TYPE,ECXPTYPE + ;Check input + Q:'$D(DFN) "" + S (TYPE,ECXPTYPE)="" + S TYPE=$G(^DPT(DFN,"TYPE")) + I 'TYPE Q ECXPTYPE + S ECXPTYPE=$P($G(^DG(391,TYPE,0)),U,1) + S ECXPTYPE=$E(ECXPTYPE,1,2) + Q ECXPTYPE +CVEDT(DFN,DATE) ;Determine patient CV status DBIA #4156 + ; input + ; DFN = patient ien + ; + ; output + ; ECXCVE = combat veteran status eligibility + ; ECXCVEDT = combat veteran eligibility end date + ; ECXCVENC = combat veteran encounter + ;Initialize variables + N CVSTAT + S (CVSTAT,ECXCVE,ECXCVEDT,ECXCVENC)="" + ;Check input + Q:'$D(DFN) 0 + ;Call CV API + S CVSTAT=$$CVEDT^DGCV(DFN,DATE) + I CVSTAT<1 Q 0 + ;Veteran been given CV eligibility + S ECXCVE=$S($P(CVSTAT,U,3)=1:"Y",$P(CVSTAT,U,3)=0:"E",1:"") + ;Save CV eligibility end date and convert from FM to HL7 format + S ECXCVEDT=$P(CVSTAT,U,2) + S ECXCVEDT=$$FMTHL7^XLFDT(ECXCVEDT) + ;Is the veteran eligible for CV in the date of encounter + S ECXCVENC=$S($P(CVSTAT,U,3)=1:"Y",1:"") + Q 1 +NPRF ;National patient record flags DBIA #3860 + N ECXARR,FLG + S ECXNPRFI="",CNT=$$GETACT^DGPFAPI(ECXDFN,"ECXARR"),FLG="" + I 'CNT Q + F I=1:1:CNT D Q:FLG + .I ECXARR(I,"CATEGORY")["NATIONAL" S ECXNPRFI="Y",FLG=1 + Q +RXPTST(K) ;Rx patient status DBIA #2511 + N ECXDIC,STAT + S (ECXDIC,STAT)="" + ;Check input + Q:'$D(K) STAT + S DA=K,DIC="^PS(53,",DIQ(0)="I",DIQ="ECXDIC",DR="6" + D EN^DIQ1 + S STAT=$G(ECXDIC(53,K,6,"I")) + S STAT=$S(STAT=1:"SC",STAT=2:"AA",STAT=3:"OTH",STAT=4:"INP",STAT=5:"NON",1:"") + Q STAT +NONVAP(K) ;Non-va prescriber DBIA #10060 + N ECXDIC,NONVAP + S (ECXDIC,NONVAP)="" + Q:'$D(K) NONVAP + S DA=K,DIC="^VA(200,",DIQ(0)="I",DIQ="ECXDIC",DR="53.91" + D EN^DIQ1 + S NONVAP=$G(ECXDIC(200,K,53.91,"I")) + I NONVAP S NONVAP="Y" + Q NONVAP +DOIVPO(K,L) ;Add destination for outpatient ivp orders + ; Input K - DFN + ; L - Order # from Pharmacy Patient File (#55) + ; + ; Output ordering stop code + ; + N ECXDIC,ECXDICA,ECXDICB,DOIVPO,CLINIC,SCODE,DIC,DIQ,DR,DA + S (ECXDIC,ECXDICA,ECXDICB,DOIVPO,CLINIC,SCODE)="" + ;Check input + Q:'K!'(L) SCODE + ;Check treating specialty + S SCODE=$$TSSC($G(ECXTS)) I SCODE>0 Q SCODE + ;Go to pharmacy patient file (#55) and return value of field (#136) + S DIC=55,DIQ(0)="I",DIQ="ECXDIC",DR="100",DR(55.01)="136",DA=K,DA(55.01)=L + D EN^DIQ1 + S CLINIC=$G(ECXDIC(55.01,L,136,"I")) + I 'CLINIC Q SCODE + ;Get stop code pointer to file 40.7 from file 44 + S DIC="^SC(",DIQ(0)="I",DIQ="ECXDICA",DR="8",DA=CLINIC D EN^DIQ1 + S SCODE=ECXDICA(44,CLINIC,8,"I") + ;Get stop code external value + S DIC="^DIC(40.7,",DIQ(0)="E",DIQ="ECXDICB",DR="1",DA=SCODE D EN^DIQ1 + S SCODE=$G(ECXDICB(40.7,SCODE,1,"E")) + Q SCODE + ; +DOUDO(K,L) ;Add destination for outpatient udp orders + ; Input K - DFN + ; L - Order # from Pharmacy Patient File (#55) + ; + ; Output ordering stop code + ; + N ECXDIC,ECXDICA,ECXDICB,DOIVPO,CLINIC,SCODE,DIC,DIQ,DR,DA + S (ECXDIC,ECXDICA,ECXDICB,DOIVPO,CLINIC,SCODE)="" + ;Check treating specialty + S SCODE=$$TSSC($G(ECXTS)) I SCODE>0 Q SCODE + ;Check input + Q:'K!'(L) SCODE + S DIC=55,DIQ(0)="I",DIQ="ECXDIC",DR="62",DR(55.06)="130",DA=K,DA(55.06)=L + D EN^DIQ1 + S CLINIC=$G(ECXDIC(55.06,L,130,"I")) + I 'CLINIC Q SCODE + ;Get stop code pointer to file 40.7 from file 44 + S DIC="^SC(",DIQ(0)="I",DIQ="ECXDICA",DR="8",DA=CLINIC D EN^DIQ1 + S SCODE=ECXDICA(44,CLINIC,8,"I") + ;Get stop code external value + S DIC="^DIC(40.7,",DIQ(0)="E",DIQ="ECXDICB",DR="1",DA=SCODE D EN^DIQ1 + S SCODE=$G(ECXDICB(40.7,SCODE,1,"E")) + Q SCODE + ; +PHAAPI(DRUG) ;Call Pharmacy drug file API dbia 4483 + ; Input: drug file (#50) ien + ; + ; Output: generic name ^ classification ^ ndc ^ dea hand + ; ^ ndf file entry # ^ psndf va product entry ^ + ; price per disp unit ^ dispense unit + ; + ;Initialize variables and scratch global + N NAME,CLASS,NDC,INV,NDF,P1,P3,PPDU,UNIT,ARRAY,DATA + S (NAME,CLASS,NDC,INV,NDF,P1,P3,PPDU,ARRAY,DATA)="" + S ARRAY="^TMP($J,""ECXLIST"")" + K @ARRAY + D DATA^PSS50(DRUG,,,,,"ECXLIST") + I @ARRAY@(0)'>0 Q "^^^^^^" + S NAME=@ARRAY@(DRUG,.01),CLASS=@ARRAY@(DRUG,2),NDC=@ARRAY@(DRUG,31) + S INV=@ARRAY@(DRUG,3),P1=$P(@ARRAY@(DRUG,20),U),P3=$P(@ARRAY@(DRUG,22),U),PPDU=@ARRAY@(DRUG,16),UNIT=@ARRAY@(DRUG,14.5) + K @ARRAY + Q NAME_U_CLASS_U_NDC_U_INV_U_P1_U_P3_U_PPDU_U_UNIT + ; +TSSC(X) ;Check treating specialty (ts) and if ts equals any of the following + ;18,23,24,36,41,65,94 then assign predefined code and return value + ; + ; Input: treating specialty + ; Output: Ordering stop code + ; + S CODE=$S(X=18:293,X=23:295,X=24:290,X=36:294,X=41:296,X=65:291,X=94:292,1:"") + Q CODE + ; +PSJ59P5(X) ;Get iv room division + ; Input X - iv room ien + ; + ; Output - field .02 division + ;Init variables + N DIV S DIV="" + ;Check input + I 'X Q DIV + D ALL^PSJ59P5(X,,"ECXDIV") + S DIV=$P($G(^TMP($J,"ECXDIV",X,.02)),U) + K ^TMP($J,"ECXDIV") + Q DIV + ; +SCRX(IEN) ;Service connected prescription + ;Init variables + N DIC,DR,DA,ECXDIQ + ;Check input + I '$G(IEN) Q "" + S DIC=52,DR="116",DA=IEN,DIQ="ECXDIQ" + D DIQ^PSODI(DIC,DIC,DR,DA,DIQ) + Q $S($G(ECXDIQ(52,DA,116))="YES":"Y",$G(ECXDIQ(52,DA,116))="NO":"N",1:"") diff --git a/r/DSS_EXTRACTS-ECX/ECXUTL6.m b/r/DSS_EXTRACTS-ECX/ECXUTL6.m index 0070c380..61ce7cf8 100644 --- a/r/DSS_EXTRACTS-ECX/ECXUTL6.m +++ b/r/DSS_EXTRACTS-ECX/ECXUTL6.m @@ -1,175 +1,128 @@ -ECXUTL6 ;ALB/JRC - Utilities for DSS Extracts ; 11/28/07 11:34am - ;;3.0;DSS EXTRACTS;**92,105**;Dec 22, 1997;Build 70 - ; -NUTKEY(P,D) ;Generate n&fs feeder key - ;Required variables - ; p - diet type production diet, standing orders, supplemental - ; feedings, or tube feedings. - ; d - diet ien from files 116.2, 118.3, 118, or 118.2 - ;Check input - I $G(P)=""!'$G(D) Q "" - ;Init variables - N PRO,IENS,CODE,DIET - S (PRO,IENS,CODE,DIET)=0 - S PRO=$O(^ECX(728.45,"B",P,PRO)) - S CODE=D_$S(P="PD":";FH(116.2,",P="SO":";FH(118.3,",P="SF":";FH(118,",P="TF":";FH(118.2,",1:"") - S DIET=0,DIET=$O(^ECX(728.45,+PRO,1,"B",CODE,DIET)) - S IENS=""_DIET_","_PRO_","_"" - Q $$GET1^DIQ(728.451,IENS,1) - ; -NUTLOC(P,D,FPD,FDD,FPF,DLT,DFL) ;Define nutrition fields - ;Required variables - ; p - patient status, inpatient or outpatient - ; - ; d - diet type production diet, standing orders, supplemental - ; feedings, or tube feedings. - ; Output: food production division, food delivery division, food - ; production facility, food delivery type, delivery feeder - ; location - ;Init variables - N WARD,TRSVP,CRSVP,OPLOC,MASWARD - S (CRSVP,TRSVP)=0,(WARD,DLT,DFL,MASWARD)="" - S OPLOC="" - ;Check input - I $G(P)=""!($G(D)="")!'($G(FHDFN)) Q "" - ;Get food production facility for inpatient, use 115.1.13 (dietetic - ;ward) field which points 119.6 (nutrition location), field 3 (tray - ;service point) or field 4 (cafeteria service point), which points to - ;119.72 (production facility) field 2. - I P="INP" D - .S WARD=$P($G(^FHPT(FHDFN,"A",+ECXADM,0)),U,8) - .S TRSVP=$$GET1^DIQ(119.6,WARD,3,"I") - .S CRSVP=$$GET1^DIQ(119.6,WARD,4,"I") - .;Get divisions - .D GETDIV - .Q - ; - ;Get food production facility for outpatient recurring meal, use - ;115.16.2 (outpatient location) which points to file 119.6 (nutrition - ;location) field 3 (tray service point) or field 4 (cafeteria service - ;point), which points to 119.72 (production facility) field 2. - I P["OP",D["RM" D - .S OPLOC=""_$P(NODE,U,3)_","_"",TRSVP=$$GET1^DIQ(119.6,OPLOC,3,"I") - .D GETDIV - .Q - ; - ;Get food production facility for outpatient tube feeding, use - ;115.16.2 (outpatient location) then use 119.6 nutrition location - ;which points to 119.72 field 2. - I P["OP",D["TF" D - .S OPLOC=""_$P(^TMP($J,"FH",DATE,FHDFN,NUMBER,"RM"),U,3)_","_"" - .S TRSVP=$$GET1^DIQ(119.6,OPLOC,3,"I") - .;Get delivery division - .D GETDIV - .Q - ; - ;Get food production facility for special meals, use 115.17.2 - ;location field 2 which is a pointer to 119.6 (nutrition location) - ;which points to 119.72 via field 2 (tray service point) which points - ;to file 119.71 (production facility) field 2. - I P["OP",D["SM" D - .S OPLOC=""_$P(NODE,U,3)_","_"" - .S TRSVP=$$GET1^DIQ(119.6,OPLOC,3,"I") - .;Get delivery division - .D GETDIV - .Q - ; - ;Get food production facility for outpatient guest meals, use - ;115.18.4 (outpatient location) then use 119.6 nutrition location - ;which points to 119.72 (production facility) field 2. - I P["OP",D["GM" D - .S OPLOC=""_$P(NODE,U,5)_","_"",TRSVP=$$GET1^DIQ(119.6,OPLOC,3,"I") - .S FPF=$$GET1^DIQ(119.72,""_TRSVP_","_"",2,"I") - .;Get delivery division - .D GETDIV - .Q - ; - ;Get delivery location type for patients; with inpatients the type of - ;service needs to be pulled from the admission node, with outpatients - ;the type of service needs to be pulled from different nodes and use - ;field 101 of Nutrition Location file (#119.6). Delivery location - ;types only set for the following meals: - ; Inpatient with a production diet - ; Outpatient with a recurring meal - ; Outpatient with a special meal - ; Outpatient with a guest meal - ; all other meals are null - I P="INP",D="PD" D - .S DLT=$P($G(NODE),U,8) - I P="OP",((D="RM")!(D="SM")) D - .S DLT=$E($$GET1^DIQ(119.6,""_$P(NODE,U,3)_","_"",101,"E"),1) - I P="OP",D="GM" D - .S DLT=$E($$GET1^DIQ(119.6,""_$P(NODE,U,5)_","_"",101,"E"),1) - ; - ;Delivery feeder location - I DLT="C" D - .S DFL=$E($$GET1^DIQ(119.6,WARD,4,"E"),1,10) - .S IEN=$$GET1^DIQ(119.72,+CRSVP,2,"I") - .S IEN=""_IEN_";FH(119.71," - .S FPF=$O(^ECX(728.46,"B",IEN,FPF)) - .S FPF=$E($$GET1^DIQ(728.46,FPF,.01,"E"),1,10) - I (DLT["T")!(DLT["D") D - .I P="INP" D - ..S MASWARD=$O(^FH(119.6,+WARD,"W","B",0)) - ..S DFL=$$GET1^DIQ(42,+MASWARD,44,"I") - .I P="OP" D - ..S DFL=$O(^FH(119.6,+OPLOC,"L","B",0)) - I (DLT=""),"SFTFSO"[D D - .S DFL=$S(TRSVP:$$GET1^DIQ(119.6,WARD,3,"E"),1:$$GET1^DIQ(119.6,WARD,4,"E")) - Q 1 - ; -GETDIV ;Get divisions and food production facility - ;Init variables - N IEN,SIEN - S (FDD,FPF,FPD)="" - S IEN=$$GET1^DIQ(119.72,+TRSVP,2,"I") - Q:'IEN - ;Get delivery division - S SIEN=""_+TRSVP_";FH(119.72," - S FDD=$O(^ECX(728.46,"B",SIEN,FDD)) - S FDD=""_$$GET1^DIQ(728.46,FDD,1,"I")_","_"" - S FDD=$$GET1^DIQ(4,FDD,99,"E") - ;Get production division and food production facility - S IEN=""_IEN_";FH(119.71," - S FPF=$O(^ECX(728.46,"B",IEN,FPF)) - S FPD=""_$$GET1^DIQ(728.46,FPF,1,"I")_","_"" - S FPD=$$GET1^DIQ(4,FPD,99,"E") - S FPF=$E($$GET1^DIQ(728.46,FPF,.01,"E"),1,10) - Q - ; -SUR(CRST,STCD,CLINIC) ;Surgery stop codes and clinic (outpatients only) - ;Init variables - S (CRST,STCD,CLINIC)="" - ;Quit if not outpatient - Q:$P(EC0,U,12)'="O" "" - ;Get stop codes (outpatient only) - I $P(EC0,U,12)="O" D - .;Get credit stop code (outpatient only) - .S CRST=""_$$GET1^DIQ(40.7,""_$$GET1^DIQ(44,$$GET1^DIQ(137.45,$P(EC0,U,4),2,"I")_","_""_","_"",2503,"I")_","_"",1,"E") - .;Get stop code (outpatient only) - .S STCD=""_$$GET1^DIQ(40.7,""_$$GET1^DIQ(44,$$GET1^DIQ(137.45,$P(EC0,U,4),2,"I")_","_""_","_"",8,"I")_","_"",1,"E") - ;Clinic for non-or case use associated clinic else non-or location - ;If non-or case - I $P($G(ECNO),U)="Y" S CLINIC=$S($P(EC0,U,21):$P(EC0,U,21),1:$P(ECNO,U,2)) - ;Get stop codes non-or cases - I $P($G(ECNO),U)="Y" D - .;Get credit stop code for non-or case - .S CRST=$$GET1^DIQ(40.7,$$GET1^DIQ(44,CLINIC,2503,"I"),1,"E") - .;Get stop code for non-or case - .S STCD=$$GET1^DIQ(40.7,$$GET1^DIQ(44,CLINIC,8,"I"),1,"E") - ;Clinic, not a non-or case use surgical specialty associated clinic - I $P($G(ECNO),U)'="Y" S CLINIC=$$GET1^DIQ(137.45,+$P(EC0,U,4),2,"I") - Q 1 - ; -SURPODX(PRODX,PODX1,PODX2,PODX3,PODX4,PODX5) ;Get postop diagnosis codes - ;Init variables - N CODE,I,PODX - S (PRODX,PODX1,PODX2,PODX3,PODX4,PODX5)="",CODE=0 - ;Check input - Q:'$D(DATAOP) 0 - ;Get principal postop dx code - S PRODX=$$GET1^DIQ(80,$P(DATAOP,U,3),.01) - ;Get other postop dx codes - S (CODE,I)=0 F S CODE=$O(^SRO(136,ECD0,4,CODE)) Q:'CODE Q:I>5 D - .S I=I+1,PODX="PODX"_I,@PODX=$$GET1^DIQ(80,$P(^SRO(136,ECD0,4,CODE,0),U),.01) - Q 1 +ECXUTL6 ;ALB/JRC - Utilities for DSS Extracts ; 11/2/06 8:30am + ;;3.0;DSS EXTRACTS;**92**;Dec 22, 1997;Build 30 + ; +NUTKEY(P,D) ;Generate n&fs feeder key + ;Required variables + ; p - diet type production diet, standing orders, supplemental + ; feedings, or tube feedings. + ; d - diet ien from files 116.2, 116.3, 118, or 118.2 + ;Check input + I $G(P)=""!'$G(D) Q "" + ;Init variables + N PRO,IENS,CODE,DIET + S (PRO,IENS,CODE,DIET)=0 + S PRO=$O(^ECX(728.45,"B",P,PRO)) + S CODE=D_$S(P="PD":";FH(116.2,",P="SO":";FH(116.3,",P="SF":";FH(118,",P="TF":";FH(118.2,",1:"") + S DIET=0,DIET=$O(^ECX(728.45,+PRO,1,"B",CODE,DIET)) + S IENS=""_DIET_","_PRO_","_"" + Q $$GET1^DIQ(728.451,IENS,1) + ; +NUTLOC(P,D,FPD,FDD,FPF,DLT,DFL) ;Define nutrition fields + ;Required variables + ; p - patient status, inpatient or outpatient + ; + ; d - diet type production diet, standing orders, supplemental + ; feedings, or tube feedings. + ; Output: food production division, food delivery division, food + ; production facility, food delivery type, delivery feeder + ; location + ;Init variables + N WARD,TRSVP,OPLOC,MASWARD + S TRSVP=0,(WARD,ECXDLT,ECXDFL,MASWARD)="" + S OPLOC="" + ;Check input + I $G(P)=""!($G(D)="")!'($G(FHDFN)) Q "" + ;Get food production facility for inpatient, use 115.1.13 (dietetic + ;ward) field which points 119.6 (nutrition location), field 3 (tray + ;service point) or field 4 (cafeteria service point), which points to + ;119.72 (production facility) field 2. + I P="INP" D + .S WARD=$P($G(^FHPT(FHDFN,"A",ECXADM,0)),U,8) + .S TRSVP=$$GET1^DIQ(119.6,WARD,3,"I") + .;Get divisions + .D GETDIV + .Q + ; + ;Get food production facility for outpatient recurring meal, use + ;115.16.2 (outpatient location) which points to file 119.6 (nutrition + ;location) field 3 (tray service point) or field 4 (cafeteria service + ;point), which points to 119.72 (production facility) field 2. + I P["OP",D["RM" D + .S OPLOC=""_$P(NODE,U,3)_","_"",TRSVP=$$GET1^DIQ(119.6,OPLOC,3,"I") + .D GETDIV + .Q + ; + ;Get food production facility for outpatient tube feeding, use + ;115.16.2 (outpatient location) then use 119.6 nutrition location + ;which points to 119.72 field 2. + I P["OP",D["TF" D + .S OPLOC=""_$P(^TMP($J,"FH",DATE,FHDFN,NUMBER,"RM"),U,3)_","_"" + .S TRSVP=$$GET1^DIQ(119.6,OPLOC,3,"I") + .;Get delivery division + .D GETDIV + .Q + ; + ;Get food production facility for special meals, use 115.17.2 + ;location field 2 which is a pointer to 119.6 (nutrition location) + ;which points to 119.72 via field 2 (tray service point) which points + ;to file 119.71 (production facility) field 2. + I P["OP",D["SM" D + .S OPLOC=""_$P(NODE,U,3)_","_"" + .S TRSVP=$$GET1^DIQ(119.6,OPLOC,3,"I") + .;Get delivery division + .D GETDIV + .Q + ; + ;Get food production facility for outpatient guest meals, use + ;115.18.4 (outpatient location) then use 119.6 nutrition location + ;which points to 119.72 (production facility) field 2. + I P["OP",D["GM" D + .S OPLOC=""_$P(NODE,U,5)_","_"",TRSVP=$$GET1^DIQ(119.6,OPLOC,3,"I") + .S ECXFPF=$$GET1^DIQ(119.72,""_TRSVP_","_"",2,"I") + .;Get delivery division + .D GETDIV + .Q + ; + ;Get delivery location type for patients; with inpatients the type of + ;service needs to be pulled from the admission node, with outpatients + ;the type of service needs to be pulled from different nodes and use + ;field 101 of Nutrition Location file (#119.6). Delivery location + ;types only set for the following meals: + ; Inpatient with a production diet + ; Outpatient with a recurring meal + ; Outpatient with a special meal + ; Outpatient with a guest meal + ; all other meals are null + I P="INP",D="PD" D + .S ECXDLT=$P($G(NODE),U,8) + I P="OP",((D="RM")!(D="SM")) D + .S ECXDLT=$E($$GET1^DIQ(119.6,""_$P(NODE,U,3)_","_"",101,"E"),1) + I P="OP",D="GM" D + .S ECXDLT=$E($$GET1^DIQ(119.6,""_$P(NODE,U,5)_","_"",101,"E"),1) + ; + ;Delivery feeder location + I ECXDLT="C" S ECXDFL=$P(NODE,U,8) D + .S ECXDFL=$E($$GET1^DIQ(119.72,ECXDFL,2,"E"),1,10) + I (ECXDLT["T")!(ECXDLT["D") D + .S MASWARD=$O(^FH(119.6,$S(WARD:+WARD,+OPLOC:+OPLOC,1:""),"W","B",0)) + .S ECXDFL=$$GET1^DIQ(42,+MASWARD,44,"I") + Q 1 + ; +GETDIV ;Get divisions and food production facility + ;Init variables + N IEN,SIEN + S (ECXFDD,ECXFPF,ECXFPD)="" + S IEN=$$GET1^DIQ(119.72,+TRSVP,2,"I") + Q:'IEN + ;Get delivery division + S SIEN=""_+TRSVP_";FH(119.72," + S ECXFDD=$O(^ECX(728.46,"B",SIEN,ECXFDD)) + S ECXFDD=""_$$GET1^DIQ(728.46,ECXFDD,1,"I")_","_"" + S ECXFDD=$$GET1^DIQ(4,ECXFDD,99,"E") + ;Get production division and food production facility + S IEN=""_IEN_";FH(119.71," + S ECXFPF=$O(^ECX(728.46,"B",IEN,ECXFPF)) + S ECXFPD=""_$$GET1^DIQ(728.46,ECXFPF,1,"I")_","_"" + S ECXFPD=$$GET1^DIQ(4,ECXFPD,99,"E") + S ECXFPF=$E($$GET1^DIQ(728.46,ECXFPF,.01,"E"),1,10) + Q diff --git a/r/ENGINEERING-EN/ENEQ4.m b/r/ENGINEERING-EN/ENEQ4.m index 7a4fac26..32ccc399 100644 --- a/r/ENGINEERING-EN/ENEQ4.m +++ b/r/ENGINEERING-EN/ENEQ4.m @@ -1,65 +1,64 @@ -ENEQ4 ;WIRMFO/SAB-PURGE EQUIPMENT INV FILE ;12/28/07 13:54 - ;;7.0;ENGINEERING;**40,87**;Aug 17, 1993;Build 16 - ; -DEL ;Delete Equipment Record entry - S ENEDNX=$D(^XUSEC("ENEDNX",DUZ)) - W !!,"This option completely deletes a specific equipment record. If" - W !,"you would rather move equipment records to an archive media, then" - W !,"exit this option and use the Engineering Archive Module instead." -DELSEQ ; select equipment record for deletion - W ! - D GETEQ^ENUTL G:Y'>0 DELX - S ENDA=+Y - F ENI=0,1,2,3 S ENY(ENI)=$G(^ENG(6914,ENDA,ENI)) - ; - ; display equipment data - W @IOF - W !,"ENTRY #: ",ENDA - W !!,?2,"MFGR EQUIP NAME: ",$P(ENY(0),U,2) - W !,?2,"EQUIP CATEGORY: ",$$GET1^DIQ(6914,ENDA,6) - W !,?2,"CSN: ",$$GET1^DIQ(6914,ENDA,18) - S ENX=$$GET1^DIQ(6914,ENDA,"18:2") I ENX]"" W " (",ENX,")" - W !!,?2,"MANUFACTURER: ",$$GET1^DIQ(6914,ENDA,1) - W !,?2,"MODEL: ",$P(ENY(1),U,2),?42,"SERIAL #: ",$P(ENY(1),U,3) - W !!,?2,"CMR: ",$$GET1^DIQ(6914,ENDA,19) - W ?42,"USE STATUS: ",$$GET1^DIQ(6914,ENDA,20) - W !,?2,"ACQUISITION DATE: ",$$FMTE^XLFDT($P(ENY(2),U,4)) - W ?34,"LE: ",$P(ENY(2),U,6) - W ?42,"DISPOSITION DATE: ",$$FMTE^XLFDT($P(ENY(3),U,11)),! - ; - ; validate selection - K ENV - S ENX=$$CHKFA^ENFAUTL(ENDA) - I +ENX S ENV(1)="It is currently reported to Fixed Assets in Austin." - E I $P(ENX,U,2)]"" S ENV(2)="It was previously reported to Fixed Assets in Austin." - I $P(ENY(0),U,4)="NX",'ENEDNX S ENV(3)="Security key ENEDNX is required to delete NX equipment." - I $P(ENY(3),U,1)=1 S ENV(4)="USE STATUS is IN USE." - I $P(ENY(3),U,11)="" S ENV(5)="DISPOSITION DATE is blank." - I $D(^ENG(6916.3,"B",ENDA)) S ENV(6)="It is linked to an IT Assignment record." - I $D(ENV) D G DELSEQ - . W $C(7),!,"This equipment entry can not be deleted because:" - . S ENI=0 F S ENI=$O(ENV(ENI)) Q:'ENI W !,?2,ENV(ENI) - ; - ; confirm deletion - S DIR(0)="Y",DIR("A")="Delete this entry" - D ^DIR K DIR G:$D(DIRUT) DELX I 'Y G DELSEQ - ; - ; first close any open work orders - S ENTXT(1)="Automatically closed when equipment record was deleted." - S DA=0 F S DA=$O(^ENG(6920,"G",ENDA,DA)) Q:'DA I $P($G(^ENG(6920,DA,5)),U,2)="" D - . D WP^DIE(6920,DA_",",40,"A","ENTXT") - . S DIE="^ENG(6920,",DR="36///T;32///^S X=""COMPLETED""" - . D ^DIE - K DIE,DR,ENTXT - ; then delete equipment - S DIK="^ENG(6914,",DA=ENDA D ^DIK K DIK - W !,"Equipment entry # ",ENDA," was deleted." - ; - G DELSEQ - ; -DELX ; delete equipment record exit - K DA,DIC,DIE,DIK,DIROUT,DIRUT,DR,DTOUT,DUOUT,X,Y - K END,ENDA,ENEDNX,ENI,ENV,ENWO,ENX,ENY - Q - ; - ;ENEQ4 +ENEQ4 ;WIRMFO/SAB-PURGE EQUIPMENT INV FILE ;2.25.97 + ;;7.0;ENGINEERING;**40**;Aug 17, 1993 + ; +DEL ;Delete Equipment Record entry + S ENEDNX=$D(^XUSEC("ENEDNX",DUZ)) + W !!,"This option completely deletes a specific equipment record. If" + W !,"you would rather move equipment records to an archive media, then" + W !,"exit this option and use the Engineering Archive Module instead." +DELSEQ ; select equipment record for deletion + W ! + D GETEQ^ENUTL G:Y'>0 DELX + S ENDA=+Y + F ENI=0,1,2,3 S ENY(ENI)=$G(^ENG(6914,ENDA,ENI)) + ; + ; display equipment data + W @IOF + W !,"ENTRY #: ",ENDA + W !!,?2,"MFGR EQUIP NAME: ",$P(ENY(0),U,2) + W !,?2,"EQUIP CATEGORY: ",$$GET1^DIQ(6914,ENDA,6) + W !,?2,"CSN: ",$$GET1^DIQ(6914,ENDA,18) + S ENX=$$GET1^DIQ(6914,ENDA,"18:2") I ENX]"" W " (",ENX,")" + W !!,?2,"MANUFACTURER: ",$$GET1^DIQ(6914,ENDA,1) + W !,?2,"MODEL: ",$P(ENY(1),U,2),?42,"SERIAL #: ",$P(ENY(1),U,3) + W !!,?2,"CMR: ",$$GET1^DIQ(6914,ENDA,19) + W ?42,"USE STATUS: ",$$GET1^DIQ(6914,ENDA,20) + W !,?2,"ACQUISITION DATE: ",$$FMTE^XLFDT($P(ENY(2),U,4)) + W ?34,"LE: ",$P(ENY(2),U,6) + W ?42,"DISPOSITION DATE: ",$$FMTE^XLFDT($P(ENY(3),U,11)),! + ; + ; validate selection + K ENV + S ENX=$$CHKFA^ENFAUTL(ENDA) + I +ENX S ENV(1)="It is currently reported to Fixed Assets in Austin." + E I $P(ENX,U,2)]"" S ENV(2)="It was previously reported to Fixed Assets in Austin." + I $P(ENY(0),U,4)="NX",'ENEDNX S ENV(3)="Security key ENEDNX is required to delete NX equipment." + I $P(ENY(3),U,1)=1 S ENV(4)="USE STATUS is IN USE." + I $P(ENY(3),U,11)="" S ENV(5)="DISPOSITION DATE is blank." + I $D(ENV) D G DELSEQ + . W $C(7),!,"This equipment entry can not be deleted because:" + . S ENI=0 F S ENI=$O(ENV(ENI)) Q:'ENI W !,?2,ENV(ENI) + ; + ; confirm deletion + S DIR(0)="Y",DIR("A")="Delete this entry" + D ^DIR K DIR G:$D(DIRUT) DELX I 'Y G DELSEQ + ; + ; first close any open work orders + S ENTXT(1)="Automatically closed when equipment record was deleted." + S DA=0 F S DA=$O(^ENG(6920,"G",ENDA,DA)) Q:'DA I $P($G(^ENG(6920,DA,5)),U,2)="" D + . D WP^DIE(6920,DA_",",40,"A","ENTXT") + . S DIE="^ENG(6920,",DR="36///T;32///^S X=""COMPLETED""" + . D ^DIE + K DIE,DR,ENTXT + ; then delete equipment + S DIK="^ENG(6914,",DA=ENDA D ^DIK K DIK + W !,"Equipment entry # ",ENDA," was deleted." + ; + G DELSEQ + ; +DELX ; delete equipment record exit + K DA,DIC,DIE,DIK,DIROUT,DIRUT,DR,DTOUT,DUOUT,X,Y + K END,ENDA,ENEDNX,ENI,ENV,ENWO,ENX,ENY + Q + ; + ;ENEQ4 diff --git a/r/ENGINEERING-EN/ENPLS2.m b/r/ENGINEERING-EN/ENPLS2.m index 604c2625..9d46cd7b 100644 --- a/r/ENGINEERING-EN/ENPLS2.m +++ b/r/ENGINEERING-EN/ENPLS2.m @@ -1,90 +1,88 @@ -ENPLS2 ;WISC/SAB - Select Items from List ;12/4/07 13:24 - ;;7.0;ENGINEERING;**23,87**;Aug 17, 1993;Build 16 -EN ; entry point - ; input global - ; ^TMP($J,"SCR)=number of entries in list^screen title - ; ^TMP($J,"SCR",0)=col 1 x pos;col 1 hdr^...^col n x pos;col n hdr - ; ^TMP($J,"SCR",id)=col 1 value^col 2 value^...^col n value - ; output - ; optional ENACL( selected items - ; - ; initialize variables - N ENI,ENID,ENF,ENI,ENS,ENX,ENY - K ENACL - S $P(ENF("DASH"),"-",80)="" - ; get screen info - S ENX=^TMP($J,"SCR") - S ENF("IDM")=$P(ENX,U) - S ENF("HD")=$P(ENX,U,2) - ; get column info - S ENX=^TMP($J,"SCR",0),ENF("CM")=0 - F ENI=1:1 S ENY=$P(ENX,U,ENI) Q:ENY="" D - . S ENF("CM")=ENF("CM")+1 - . S ENF("C"_ENI,"X")=$P(ENY,";",1) - . S ENF("C"_ENI,"L")=$P(ENY,";",2) - . S ENF("C"_ENI,"HD")=$P(ENY,";",3) - S ENF("SM")=(ENF("IDM")-1)\15+1 - S ENF("S")=1 -BLD ; build screen - K ENS - S ENS("IDL")=1+(ENF("S")-1*15) - S ENS("IDM")=$S(15+(ENF("S")-1*15)>ENF("IDM"):ENF("IDM"),1:15+(ENF("S")-1*15)) - ; display screen - D SHD - F ENID=ENS("IDL"):1:ENS("IDM") D W ! - . S ENX=^TMP($J,"SCR",ENID) - . W $J(ENID,3) - . F ENI=1:1:ENF("CM") W ?ENF("C"_ENI,"X"),$P(ENX,U,ENI) -ACT ; prompt for selection - W ! - S DIR("A")="Enter a list or range to select (1-"_ENF("IDM")_"): "_$S(ENF("S")0600:2,1:1) - D ^DIR K DIR Q:$D(DIRUT) - S ENYR=Y - F ENIDX="F","G" D - . S ENDA=0 F S ENDA=$O(^ENG("PROJ",ENIDX,ENYR,ENDA)) Q:'ENDA D - . . S ENY0=$G(^ENG("PROJ",ENDA,0)) Q:$P(ENY0,U)=""!($P(ENY0,U,6)'=ENPR) - . . S ^TMP($J,"R",$P(ENY0,U))=$P(ENY0,U)_U_$P(ENY0,U,3)_U_ENDA - I '$D(^TMP($J,"R")) W !!,"No Projects matched selection criteria!",! Q - S ENI=0,ENPN="" F S ENPN=$O(^TMP($J,"R",ENPN)) Q:ENPN="" S ENI=ENI+1,^TMP($J,"SCR",ENI)=^(ENPN) - S ^TMP($J,"SCR")=ENI_U_"PROGRAM ("_ENPR_") PROJECTS WITH FUNDING YEAR "_ENYR - S ^TMP($J,"SCR",0)="5;11;PROJECT #^19;50;TITLE" - D ^ENPLS2 - ; save selected projects (if any) - S ENC=0,ENJ="" F S ENJ=$O(ENACL(ENJ)) Q:ENJ="" D - . F ENK=1:1 S ENI=$P(ENACL(ENJ),",",ENK) Q:ENI="" D - . . S ENY=^TMP($J,"SCR",ENI),^TMP($J,"L",$P(ENY,U))=$P(ENY,U,3),ENC=ENC+1 - S:ENC ^TMP($J,"L")=ENC_$S(ENTY="F":U_ENFY,1:"") - K ^TMP($J,"R"),^TMP($J,"SCR") - Q - ;ENPLS2 +ENPLS2 ;WISC/SAB - Select Items from List ;7/21/95 + ;;7.0;ENGINEERING;**23**;Aug 17, 1993 +EN ; entry point + ; input global + ; ^TMP($J,"SCR)=number of entries in list^screen title + ; ^TMP($J,"SCR",0)=col 1 x pos;col 1 hdr^...^col n x pos;col n hdr + ; ^TMP($J,"SCR",id)=col 1 value^col 2 value^...^col n value + ; output + ; optional ENACL( selected items + ; + ; initialize variables + N ENI,ENID,ENF,ENI,ENS,ENX,ENY + K ENACL + S $P(ENF("DASH"),"-",80)="" + ; get screen info + S ENX=^TMP($J,"SCR") + S ENF("IDM")=$P(ENX,U) + S ENF("HD")=$P(ENX,U,2) + ; get column info + S ENX=^TMP($J,"SCR",0),ENF("CM")=0 + F ENI=1:1 S ENY=$P(ENX,U,ENI) Q:ENY="" D + . S ENF("CM")=ENF("CM")+1 + . S ENF("C"_ENI,"X")=$P(ENY,";",1) + . S ENF("C"_ENI,"L")=$P(ENY,";",2) + . S ENF("C"_ENI,"HD")=$P(ENY,";",3) + S ENF("SM")=(ENF("IDM")-1)\15+1 + S ENF("S")=1 +BLD ; build screen + K ENS + S ENS("IDL")=1+(ENF("S")-1*15) + S ENS("IDM")=$S(15+(ENF("S")-1*15)>ENF("IDM"):ENF("IDM"),1:15+(ENF("S")-1*15)) + ; display screen + D SHD + F ENID=ENS("IDL"):1:ENS("IDM") D W ! + . S ENX=^TMP($J,"SCR",ENID) + . W $J(ENID,3) + . F ENI=1:1:ENF("CM") W ?ENF("C"_ENI,"X"),$P(ENX,U,ENI) +ACT ; prompt for selection + W ! + S DIR("A")="Enter a list or range to select (1-"_ENF("IDM")_"): "_$S(ENF("S")0600:2,1:1) + D ^DIR K DIR Q:$D(DIRUT) + S ENYR=Y + F ENIDX="F","G" D + . S ENDA=0 F S ENDA=$O(^ENG("PROJ",ENIDX,ENYR,ENDA)) Q:'ENDA D + . . S ENY0=$G(^ENG("PROJ",ENDA,0)) Q:$P(ENY0,U)=""!($P(ENY0,U,6)'=ENPR) + . . S ^TMP($J,"R",$P(ENY0,U))=$P(ENY0,U)_U_$P(ENY0,U,3)_U_ENDA + I '$D(^TMP($J,"R")) W !!,"No Projects matched selection criteria!",! Q + S ENI=0,ENPN="" F S ENPN=$O(^TMP($J,"R",ENPN)) Q:ENPN="" S ENI=ENI+1,^TMP($J,"SCR",ENI)=^(ENPN) + S ^TMP($J,"SCR")=ENI_U_"PROGRAM ("_ENPR_") PROJECTS WITH FUNDING YEAR "_ENYR + S ^TMP($J,"SCR",0)="5;11;PROJECT #^19;50;TITLE" + D ^ENPLS2 + ; save selected projects (if any) + S ENC=0,ENJ="" F S ENJ=$O(ENACL(ENJ)) Q:ENJ="" D + . F ENK=1:1 S ENI=$P(ENACL(ENJ),",",ENK) Q:ENI="" D + . . S ENY=^TMP($J,"SCR",ENI),^TMP($J,"L",$P(ENY,U))=$P(ENY,U,3),ENC=ENC+1 + S:ENC ^TMP($J,"L")=ENC_$S(ENTY="F":U_ENFY,1:"") + K ^TMP($J,"R"),^TMP($J,"SCR") + Q + ;ENPLS2 diff --git a/r/EVENT_CAPTURE-EC--ECT--ECX/ECRRPT.m b/r/EVENT_CAPTURE-EC--ECT--ECX/ECRRPT.m index e5726917..225db867 100644 --- a/r/EVENT_CAPTURE-EC--ECT--ECX/ECRRPT.m +++ b/r/EVENT_CAPTURE-EC--ECT--ECX/ECRRPT.m @@ -1,195 +1,195 @@ -ECRRPT ;ALB/JAM;Event Capture Report RPC Broker ;Jan 2, 2001 - ;;2.0; EVENT CAPTURE ;**25,32,41,56,61,82,94**;8 May 96;Build 4 - ; -REQCHK(ECV) ;Required data check - N I,C - S C=1 - F I=1:1:$L(ECV,U) I '$D(@$P(ECV,U,I)) D - . S ^TMP("ECMSG",$J,C)="0^Required data missing "_$P(ECV,U,I) - . S C=C+1,ECERR=1 - Q -DATECHK(ECSD,ECED) ;Check human format date and converts to FileMan format - ; Input ECSD - Start Date (ex. 10/9/01) - ; ECED - End Date - N ECI,X,Y - S %DT="X" F ECI="ECSD","ECED" S X=@ECI D ^%DT S @ECI=Y - S ECSD=$S(ECSD=-1:DT,1:ECSD),ECED=$S(ECED=-1:DT,1:ECED) - S ECDATE=$$FMTE^XLFDT(ECSD)_"^"_$$FMTE^XLFDT(ECED) - Q -QUEUE ;Queues report to printer - N ZTIO,ZTDESC,ZTRTN,ZTDTH,ZTSAVE,%ZIS,I,IOP,POP - S XNAM=$P($G(^%ZIS(1,ECDEV,0)),U,2) - S IOP="Q;`"_ECDEV,%ZIS="Q" D ^%ZIS I POP D Q - . ;S IOP="Q;"_XNAM,%ZIS="Q" D ^%ZIS I POP D Q - . S ^TMP("ECMSG",$J,1)="0^Device selection unsuccessful" - S ZTIO=ION,ZTDESC=ECDESC,ZTRTN=ECROU - S ZTDTH=$$FMTH^XLFDT(ECQDT) - ;D NOW^%DTC S ZTDTH=$S(%'DT Q - . I STAT="I",ECDT="" Q - . S CRDT=$$FMTE^XLFDT($P(NODE,U,2),"2F") - . S INDT=$$FMTE^XLFDT($P(NODE,U,3),"2F") - . ;S CNT=CNT+1,^TMP($J,"ECCAT",CNT)=CAT_U_$P(NODE,U)_U_CRDT_U_INDT - . S CNT=CNT+1,^TMP($J,"ECCAT",CNT)=CAT_U_$P(NODE,U)_U_$P(CRDT,"@",1)_U_$P(INDT,"@",1) - S RESULTS=$NA(^TMP($J,"ECCAT")) - Q - ; -CATCHK(RESULTS,ECARY) ; - ; - ;Broker call checks whether category is used in an Event Code Screen. - ; RPC: EC DSSCATCHECK - ;INPUTS ECARY - Contains the following subscripted elements - ; ECDA - DSS Unit ien (file #724) - ; - ;OUTPUTS RESULTS - Category used in Event Code Screen, 1-Yes or 0-No - ; - N ECDA,ECFLG,ECX - D SETENV^ECUMRPC - S ECDA=$P(ECARY,U) I ECDA="" Q - S (ECFLG,ECX)=0 - F S ECX=$O(^ECJ("AP",ECX)) Q:'ECX!(ECFLG) D - . I $D(^ECJ("AP",ECX,ECDA)) S ECFLG=1 - S RESULTS=ECFLG - Q -PXCHK(RESULTS,ECARY) ; - ; - ;Checks whether procedure description or national number exist - ;INPUTS ECARY - Contains the following subscripted elements - ; ECP - Procedure description - ; ECN - EC National Number - ; - ;OUTPUTS RESULTS - Px used^National # used, 1-Yes or 0-No ex. 1^0 - ; - N ECX,ECP,ECN - Q:$G(ECARY) - D SETENV^ECUMRPC - S ECP=$P(ECARY,U),ECN=$P(ECARY,U,2),RESULTS="0^0" - I ECP'="",$D(^EC(725,"B",ECP)) S $P(RESULTS,U)=1 - I ECN'="" F ECX="E","D","DL" D I $P(RESULTS,U,2) Q - . I $D(^EC(725,ECX,ECN)) S $P(RESULTS,U,2)=1 - Q -SRCLST(RESULTS,ECARY) ; - ; - ;This broker entry returns an array of codes from a file based on a - ;search string. - ; RPC: EC GETLIST - ; - ;INPUTS ECARY - Contains the following subscripted elements - ; ECSTR - Search string - ; ECFIL - File to search - ; ECDIR - Search order - ; - ;OUTPUTS RESULTS - Array of values based on the search criteria. - ; - N ECNT,DIC,ECSTR,ECFIL,ECORD,ECER,ECDI - D SETENV^ECUMRPC - S ECNT=0,ECFIL=$P(ECARY,U),ECSTR=$P(ECARY,U,2),ECDIR=$P(ECARY,U,3) - S ECORD=$S(ECDIR=-1:"B",1:"I") - K ^TMP($J,"ECFIND"),^TMP("ECSRCH",$J) - I ECFIL="" Q - S ECNUM=44 - I ECFIL=420.1 D CSTCTR ;Cost Center search - I ECFIL=49 D SERVC ;Service search - I ECFIL=723 D MEDSPC ;Medical specialty - I ECFIL=40.7 D STPCDE G EXIT ;Associated stop code - I ECFIL=724 D DUNT G EXIT ;DSS Unit - I ECFIL=726 D ECAT ;Category - I ECFIL=4 D LOC ;Location - I ECFIL=44 D ASCLN G EXIT ;Associated clinic - I ECFIL=757.01 D LEX^ECUMRPC2 G EXIT ;Lex ICD code - I ECFIL=200 D PROV^ECUMRPC2 ;Providers - I $D(ECER) S ^TMP($J,"ECFIND",1)="0^Error occurred during search" G EXIT - D SORT -EXIT K ^TMP("ECSRCH",$J) - S RESULTS=$NA(^TMP($J,"ECFIND")) - Q -ASCLN ;Search for active associated clinics (file #44) - N CNT,NOD,ECDT,INACT,REACT,ERR - S CNT=0,ECDT=DT - F Q:CNT=ECNUM S ECSTR=$O(^SC("B",ECSTR),ECDIR) Q:ECSTR="" S CLN="" D - .F S CLN=$O(^SC("B",ECSTR,CLN),ECDIR) Q:CLN="" S NOD=$G(^SC(CLN,0)) D - ..Q:NOD="" Q:$P(NOD,U,3)'="C" ;Q:+$G(^SC(CLN,"OOS")) - ..S ERR=0 I $D(^SC(CLN,"I")) D I ERR Q - ...S INACT=$P(^SC(CLN,"I"),U),REACT=$P(^SC(CLN,"I"),U,2) - ...I INACT D I ERR Q - ....I REACT="" S:ECDT'(ECNUM-1) Q - ..S STR=$G(^DIC(40.7,IEN,0)) I (STR="")!($P(STR,U,3)'="") Q - ..S STR=$E($P(STR,U),1,30)_" ["_$J($P(STR,U,2),3,0)_"]"_U_$P(STR,U,2)_U_IEN - ..S ECNT=ECNT+1,^TMP($J,"ECFIND",ECNT)=STR - D LISTDIC(ECFIL,"",".01;1",ECORD,ECNUM,ECSTR,"",INDX,"I $P(^(0),""^"",3)=""""!($P(^(0),U,3)'DT)","","^TMP(""ECSRCH"",$J)","ECER") - Q -LOC ;Search for Location (File #4) - D LISTDIC(ECFIL,"",.01,ECORD,ECNUM,ECSTR,"","","I $G(^(""EC""))","","^TMP(""ECSRCH"",$J)","ECER") - Q -LISTDIC(ECFL,ECIEN,ECFLD,ECFLG,ECNUM,ECFRM,ECPRT,ECINDX,ECSCN,ECIND,ECTG,ECER) ; - ;Produces a list of records in a file base on search string - N DIC - D LIST^DIC(ECFL,ECIEN,ECFLD,ECFLG,ECNUM,ECFRM,ECPRT,ECINDX,ECSCN,ECIND,ECTG,ECER) - K ECFL,ECIEN,ECFLD,ECFLG,ECNUM,ECFRM,ECPRT,ECINDX,ECSCN,ECID - Q -SORT ;Extracts data to be returned to broker - N ECNT,STR - S ECNT=0 - F S ECNT=$O(^TMP("ECSRCH",$J,"DILIST","ID",ECNT)) Q:'ECNT D - .S ^TMP($J,"ECFIND",ECNT)=$G(^TMP("ECSRCH",$J,"DILIST","ID",ECNT,.01))_U_^TMP("ECSRCH",$J,"DILIST",2,ECNT) - Q +ECUMRPC1 ;ALB/JAM-Event Capture Management Broker Utilities ;28 Nov 00 + ;;2.0; EVENT CAPTURE ;**25,30,33,72**;8 May 96 + ; +DSSUNT(RESULTS,ECARY) ; + ; + ;This broker entry point returns DSS units from file 724 + ; RPC: EC GETDSSUNIT + ;INPUTS ECARY - Contains the following subscripted elements + ; STAT - Active or inactive DSS Units (optional) + ; A-ctive (default), I-nactive, B-oth + ; + ;OUTPUTS RESULTS - Array of DSS units. Data pieces as follows:- + ; PIECE - Description + ; 1 IEN of DSS Unit + ; 2 Name of DSS Unit + ; 3 Service + ; 4 Medical Specialty + ; 5 Cost Center + ; 6 Unit Number + ; 7 Inactive Flag + ; 8 Associated Stop code (if not sending to PCE) + ; 9 Category flag + ; 10 Default date entry + ; 11 Send to PCE Flag + ; + N UNT,STAT,CNT,CAT,NODE,ECS,STR,SRV,MED,CST,UNO,INACT,ASC,PCE,ACT,NODE + N DFD + D SETENV^ECUMRPC + K ^TMP($J,"ECDSSUNT") + S STAT=$P($G(ECARY),U),(CNT,UNT)=0 S:STAT="" STAT="A" + F S UNT=$O(^ECD(UNT)) Q:'UNT S NODE=$G(^ECD(UNT,0)) I NODE'="" D + . S ECS=$P(NODE,U,8),ACT=$P(NODE,U,6),ACT=$S(ACT:1,1:0) + . Q:'ECS I $S(STAT="A"&(ACT):1,STAT="I"&('ACT):1,1:0) Q + . S CNT=CNT+1,CAT=$P(NODE,U,11),CAT=$S(CAT:"Y",1:"N"),UNO=$P(NODE,U,5) + . S SRV=$$GET1^DIQ(49,$P(NODE,U,2),.01,"I") + . S MED=$$GET1^DIQ(723,$P(NODE,U,3),.01,"I") + . S CST=$$GET1^DIQ(420.1,$P(NODE,U,4),.01,"I") + . S INACT=$P(NODE,U,6),INACT=$S(INACT:"I",1:"A"),ASC=$P(NODE,U,10) + . S:ASC ASC=$$GET1^DIQ(40.7,ASC,.01,"I") + . S DFD=$S($P(NODE,U,12)="N":"N",1:"X"),PCE=$P(NODE,U,14) + . S PCE=$S(PCE="A":PCE,PCE="O":PCE,1:"N") + . S STR=UNT_U_$P(NODE,U)_U_SRV_U_MED_U_CST_U_UNO_U_INACT_U_ASC_U_CAT + . S STR=STR_U_DFD_U_PCE,^TMP($J,"ECDSSUNT",CNT)=STR + S RESULTS=$NA(^TMP($J,"ECDSSUNT")) + Q +CAT(RESULTS,ECARY) ; + ; + ;This broker entry point returns a list of categories from file 726 + ; RPC: EC GETCAT + ;INPUTS ECARY - Contains the following subscripted elements + ; STAT - Active or inactive category (optional) + ; A-ctive (default), I-nactive, B-oth + ; + ;OUTPUTS RESULTS - Array of category. Data pieces as follows:- + ; PIECE - Description + ; 1 IEN of Category + ; 2 Name of Category + ; 3 Creation Date + ; 4 Inactive Date + ; + N STAT,CNT,CAT,NODE,ECDT,INDT,CRDT + D SETENV^ECUMRPC + K ^TMP($J,"ECCAT") + S STAT=$P($G(ECARY),U),(CNT,CAT)=0 S:STAT="" STAT="A" + F S CAT=$O(^EC(726,CAT)) Q:'CAT S NODE=$G(^EC(726,CAT,0)) I NODE'="" D + . S ECDT=$P(NODE,U,3) + . I STAT="A",ECDT'="",ECDT'>DT Q + . I STAT="I",ECDT="" Q + . S CRDT=$$FMTE^XLFDT($P(NODE,U,2),"2F") + . S INDT=$$FMTE^XLFDT($P(NODE,U,3),"2F") + . S CNT=CNT+1,^TMP($J,"ECCAT",CNT)=CAT_U_$P(NODE,U)_U_CRDT_U_INDT + S RESULTS=$NA(^TMP($J,"ECCAT")) + Q + ; +CATCHK(RESULTS,ECARY) ; + ; + ;Broker call checks whether category is used in an Event Code Screen. + ; RPC: EC DSSCATCHECK + ;INPUTS ECARY - Contains the following subscripted elements + ; ECDA - DSS Unit ien (file #724) + ; + ;OUTPUTS RESULTS - Category used in Event Code Screen, 1-Yes or 0-No + ; + N ECDA,ECFLG,ECX + D SETENV^ECUMRPC + S ECDA=$P(ECARY,U) I ECDA="" Q + S (ECFLG,ECX)=0 + F S ECX=$O(^ECJ("AP",ECX)) Q:'ECX!(ECFLG) D + . I $D(^ECJ("AP",ECX,ECDA)) S ECFLG=1 + S RESULTS=ECFLG + Q +PXCHK(RESULTS,ECARY) ; + ; + ;Checks whether procedure description or national number exist + ;INPUTS ECARY - Contains the following subscripted elements + ; ECP - Procedure description + ; ECN - EC National Number + ; + ;OUTPUTS RESULTS - Px used^National # used, 1-Yes or 0-No ex. 1^0 + ; + N ECX,ECP,ECN + Q:$G(ECARY) + D SETENV^ECUMRPC + S ECP=$P(ECARY,U),ECN=$P(ECARY,U,2),RESULTS="0^0" + I ECP'="",$D(^EC(725,"B",ECP)) S $P(RESULTS,U)=1 + I ECN'="" F ECX="E","D","DL" D I $P(RESULTS,U,2) Q + . I $D(^EC(725,ECX,ECN)) S $P(RESULTS,U,2)=1 + Q +SRCLST(RESULTS,ECARY) ; + ; + ;This broker entry returns an array of codes from a file based on a + ;search string. + ; RPC: EC GETLIST + ; + ;INPUTS ECARY - Contains the following subscripted elements + ; ECSTR - Search string + ; ECFIL - File to search + ; ECDIR - Search order + ; + ;OUTPUTS RESULTS - Array of values based on the search criteria. + ; + N ECNT,DIC,ECSTR,ECFIL,ECORD,ECER,ECDI + D SETENV^ECUMRPC + S ECNT=0,ECFIL=$P(ECARY,U),ECSTR=$P(ECARY,U,2),ECDIR=$P(ECARY,U,3) + S ECORD=$S(ECDIR=-1:"B",1:"I") + K ^TMP($J,"ECFIND"),^TMP("ECSRCH",$J) + I ECFIL="" Q + S ECNUM=44 + I ECFIL=420.1 D CSTCTR ;Cost Center search + I ECFIL=49 D SERVC ;Service search + I ECFIL=723 D MEDSPC ;Medical specialty + I ECFIL=40.7 D STPCDE G EXIT ;Associated stop code + I ECFIL=724 D DUNT G EXIT ;DSS Unit + I ECFIL=726 D ECAT ;Category + I ECFIL=4 D LOC ;Location + I ECFIL=44 D ASCLN G EXIT ;Associated clinic + I ECFIL=757.01 D LEX^ECUMRPC2 G EXIT ;Lex ICD code + I ECFIL=200 D PROV^ECUMRPC2 ;Providers + I $D(ECER) S ^TMP($J,"ECFIND",1)="0^Error occurred during search" G EXIT + D SORT +EXIT K ^TMP("ECSRCH",$J) + S RESULTS=$NA(^TMP($J,"ECFIND")) + Q +ASCLN ;Search for active associated clinics (file #44) + N CNT,NOD,ECDT,INACT,REACT,ERR + S CNT=0,ECDT=DT + F Q:CNT=ECNUM S ECSTR=$O(^SC("B",ECSTR),ECDIR) Q:ECSTR="" S CLN="" D + .F S CLN=$O(^SC("B",ECSTR,CLN),ECDIR) Q:CLN="" S NOD=$G(^SC(CLN,0)) D + ..Q:NOD="" Q:$P(NOD,U,3)'="C" ;Q:+$G(^SC(CLN,"OOS")) + ..S ERR=0 I $D(^SC(CLN,"I")) D I ERR Q + ...S INACT=$P(^SC(CLN,"I"),U),REACT=$P(^SC(CLN,"I"),U,2) + ...I INACT D I ERR Q + ....I REACT="" S:ECDT'(ECNUM-1) Q + ..S STR=$G(^DIC(40.7,IEN,0)) I (STR="")!($P(STR,U,3)'="") Q + ..S STR=$E($P(STR,U),1,30)_" ["_$J($P(STR,U,2),3,0)_"]"_U_$P(STR,U,2)_U_IEN + ..S ECNT=ECNT+1,^TMP($J,"ECFIND",ECNT)=STR + D LISTDIC(ECFIL,"",".01;1",ECORD,ECNUM,ECSTR,"",INDX,"I $P(^(0),""^"",3)=""""!($P(^(0),U,3)'DT)","","^TMP(""ECSRCH"",$J)","ECER") + Q +LOC ;Search for Location (File #4) + D LISTDIC(ECFIL,"",.01,ECORD,ECNUM,ECSTR,"","","I $G(^(""EC""))","","^TMP(""ECSRCH"",$J)","ECER") + Q +LISTDIC(ECFL,ECIEN,ECFLD,ECFLG,ECNUM,ECFRM,ECPRT,ECINDX,ECSCN,ECIND,ECTG,ECER) ; + ;Produces a list of records in a file base on search string + N DIC + D LIST^DIC(ECFL,ECIEN,ECFLD,ECFLG,ECNUM,ECFRM,ECPRT,ECINDX,ECSCN,ECIND,ECTG,ECER) + K ECFL,ECIEN,ECFLD,ECFLG,ECNUM,ECFRM,ECPRT,ECINDX,ECSCN,ECID + Q +SORT ;Extracts data to be returned to broker + N ECNT,STR + S ECNT=0 + F S ECNT=$O(^TMP("ECSRCH",$J,"DILIST","ID",ECNT)) Q:'ECNT D + .S ^TMP($J,"ECFIND",ECNT)=$G(^TMP("ECSRCH",$J,"DILIST","ID",ECNT,.01))_U_^TMP("ECSRCH",$J,"DILIST",2,ECNT) + Q diff --git a/r/EVENT_CAPTURE-EC--ECT--ECX/ECUURPC.m b/r/EVENT_CAPTURE-EC--ECT--ECX/ECUURPC.m index 1b0c3386..ab3dc70c 100644 --- a/r/EVENT_CAPTURE-EC--ECT--ECX/ECUURPC.m +++ b/r/EVENT_CAPTURE-EC--ECT--ECX/ECUURPC.m @@ -1,91 +1,90 @@ -ECUURPC ;ALB/JAM;Event Capture Data Entry Broker Utilities ;Aug 28, 2000 - ;;2.0; EVENT CAPTURE ;**25,42,49,94**;8 May 96;Build 4 - ; -ECHELP(RESULTS,ECARY) ; - ; - ;Broker call returns the entries from HELP FILE #9.2 - ; RPC: EC GETSCNHELP - ;INPUTS ECARY - Contains the following elements - ; HLPDA - Help Frame Name - ; - ;OUTPUTS RESULTS - Array of help text in the HELP FRAM File (#9.2) - ; - N HLPDA,DIC,X,Y - S HLPDA=$G(ECARY) I HLPDA="" Q - D SETENV^ECUMRPC K ^TMP($J,"ECHELP") - S DIC="^DIC(9.2,",DIC(0)="MN",X=HLPDA - D ^DIC M ^TMP($J,"ECHELP")=^DIC(9.2,+Y,1) - I $D(^TMP($J,"ECHELP")) D - . S $P(^TMP($J,"ECHELP",0),U)=$P(^DIC(9.2,+Y,0),U,2) - S RESULTS=$NA(^TMP($J,"ECHELP")) - Q -FNDIEN(RESULTS,ECARY) ;find IEN - ;Broker call returns the IEN from a file - ; RPC: EC GETIEN - ;INPUTS ECARY - Contains the following data elements - ; FIL - File number - ; TXT - .01 description - ; - ;OUTPUTS RESULTS - File IEN - ; - N TXT,FIL,DIC,X,Y - D SETENV^ECUMRPC - S FIL=$P(ECARY,U),TXT=$P(ECARY,U,2) I TXT=""!(FIL="") Q - S DIC=FIL,DIC(0)="MN",X=TXT - I FIL=81.3 S DIC("S")="I $P(^DIC(81.3,Y,0),U,5)'=1" ;PATCH 94 - D ^DIC I Y=-1 Q - S RESULTS=+Y - Q -ECDATE(RESULTS,ECARY) ; - ; - ;Broker call returns an Fileman internal date - ; RPC: EC GETDATE - ;INPUTS ECARY - Contains the following elements - ; DTSTR - Date String - ; FLG - Date Flag (optional) - ; - ;OUTPUTS RESULTS - A valid Fileman date format^External format - ; - N ECDTSTR,DIC,X,Y,DTSTR,FLG - D SETENV^ECUMRPC - S DTSTR=$P(ECARY,U),FLG=$P(ECARY,U,2) I DTSTR="" Q - S X=DTSTR,%DT="XT"_$S(FLG="R":"R",1:""),%DT(0)="-NOW" D ^%DT - I +Y<1 S RESULTS="0^Invalid Date/Time" Q - S RESULTS=Y D D^DIQ - S RESULTS=RESULTS_U_Y - Q -PATCH(RESULTS,ECARY) ; - ; - ;Broker call returns 1 if patch X is installed - ; RPC: EC GETPATCH - ;INPUTS ECARY - contains the patch number - ; - ;OUTPUTS RESULTS 1 OR 0 - ; - I ECARY="" Q - D SETENV^ECUMRPC - S RESULTS=$$PATCH^XPDUTL(ECARY) - Q -VERSRV(RESULTS,ECARY,VERSION) ; Return server version of option name and - ; minimum GUI client version. - ; - ;Server/client version consist of 4 pieces, namely - ; major version.minor version.release.build (ex. 2.0.10.1) - ; - ;Broker call returns server version of option name - ; RPC: EC GETVERSION - ;INPUTS ECARY - contains the option name - ; VERSION - EC GUI client version ;stay in partition for session - ; - ;OUTPUTS RESULTS version number OR null ("") - ; current server version^minimum client version - ; - S ECCLVER=$G(VERSION) - I $G(ECARY)="" Q - N ECLST,ECMINV - S ECMINV="2.0.10.1" ; Minimum version of EC GUI client - D FIND^DIC(19,"",1,"X",ECARY,1,,,,"ECLST") - I 'ECLST("DILIST",0) S RESULTS="" Q - S RESULTS=ECLST("DILIST","ID",1,1) - S RESULTS=$P(RESULTS,"version ",2)_U_ECMINV - Q +ECUURPC ;ALB/JAM;Event Capture Data Entry Broker Utilities ;Aug 28, 2000 + ;;2.0; EVENT CAPTURE ;**25,42,49**;8 May 96 + ; +ECHELP(RESULTS,ECARY) ; + ; + ;Broker call returns the entries from HELP FILE #9.2 + ; RPC: EC GETSCNHELP + ;INPUTS ECARY - Contains the following elements + ; HLPDA - Help Frame Name + ; + ;OUTPUTS RESULTS - Array of help text in the HELP FRAM File (#9.2) + ; + N HLPDA,DIC,X,Y + S HLPDA=$G(ECARY) I HLPDA="" Q + D SETENV^ECUMRPC K ^TMP($J,"ECHELP") + S DIC="^DIC(9.2,",DIC(0)="MN",X=HLPDA + D ^DIC M ^TMP($J,"ECHELP")=^DIC(9.2,+Y,1) + I $D(^TMP($J,"ECHELP")) D + . S $P(^TMP($J,"ECHELP",0),U)=$P(^DIC(9.2,+Y,0),U,2) + S RESULTS=$NA(^TMP($J,"ECHELP")) + Q +FNDIEN(RESULTS,ECARY) ;find IEN + ;Broker call returns the IEN from a file + ; RPC: EC GETIEN + ;INPUTS ECARY - Contains the following data elements + ; FIL - File number + ; TXT - .01 description + ; + ;OUTPUTS RESULTS - File IEN + ; + N TXT,FIL,DIC,X,Y + D SETENV^ECUMRPC + S FIL=$P(ECARY,U),TXT=$P(ECARY,U,2) I TXT=""!(FIL="") Q + S DIC=FIL,DIC(0)="MN",X=TXT + D ^DIC I Y=-1 Q + S RESULTS=+Y + Q +ECDATE(RESULTS,ECARY) ; + ; + ;Broker call returns an Fileman internal date + ; RPC: EC GETDATE + ;INPUTS ECARY - Contains the following elements + ; DTSTR - Date String + ; FLG - Date Flag (optional) + ; + ;OUTPUTS RESULTS - A valid Fileman date format^External format + ; + N ECDTSTR,DIC,X,Y,DTSTR,FLG + D SETENV^ECUMRPC + S DTSTR=$P(ECARY,U),FLG=$P(ECARY,U,2) I DTSTR="" Q + S X=DTSTR,%DT="XT"_$S(FLG="R":"R",1:""),%DT(0)="-NOW" D ^%DT + I +Y<1 S RESULTS="0^Invalid Date/Time" Q + S RESULTS=Y D D^DIQ + S RESULTS=RESULTS_U_Y + Q +PATCH(RESULTS,ECARY) ; + ; + ;Broker call returns 1 if patch X is installed + ; RPC: EC GETPATCH + ;INPUTS ECARY - contains the patch number + ; + ;OUTPUTS RESULTS 1 OR 0 + ; + I ECARY="" Q + D SETENV^ECUMRPC + S RESULTS=$$PATCH^XPDUTL(ECARY) + Q +VERSRV(RESULTS,ECARY,VERSION) ; Return server version of option name and + ; minimum GUI client version. + ; + ;Server/client version consist of 4 pieces, namely + ; major version.minor version.release.build (ex. 2.0.10.1) + ; + ;Broker call returns server version of option name + ; RPC: EC GETVERSION + ;INPUTS ECARY - contains the option name + ; VERSION - EC GUI client version ;stay in partition for session + ; + ;OUTPUTS RESULTS version number OR null ("") + ; current server version^minimum client version + ; + S ECCLVER=$G(VERSION) + I $G(ECARY)="" Q + N ECLST,ECMINV + S ECMINV="2.0.10.1" ; Minimum version of EC GUI client + D FIND^DIC(19,"",1,"X",ECARY,1,,,,"ECLST") + I 'ECLST("DILIST",0) S RESULTS="" Q + S RESULTS=ECLST("DILIST","ID",1,1) + S RESULTS=$P(RESULTS,"version ",2)_U_ECMINV + Q diff --git a/r/FEE_BASIS-FB/FBAA79.m b/r/FEE_BASIS-FB/FBAA79.m index 1135a244..feda343d 100644 --- a/r/FEE_BASIS-FB/FBAA79.m +++ b/r/FEE_BASIS-FB/FBAA79.m @@ -1,60 +1,55 @@ -FBAA79 ;AISC/GRR-PRINT FORM 7079 REQUEST FOR OUTPATIENT MEDICAL SERVICES ;7/NOV/2006 - ;;3.5;FEE BASIS;**12,23,101,103**;JAN 30, 1995;Build 19 - ;;Per VHA Directive 2004-038, this routine should not be modified. - W !,"Print 7079's for: " D DT^DICRW,DATE^FBAAUTL G:FBPOP END D SITEP^FBAAUTL G:FBPOP END - I '$D(^FBAAA("AF",2)) W !!,*7,"There are no 7079's to be printed!",! G END - S FBAASCR="" -RDHOW W ! S DIR("A")="Want only those that have not yet been printed",DIR("B")="Yes",DIR(0)="Y" D ^DIR K DIR G END:$D(DIRUT) S:Y FBAASCR="Y" - D OUTPUT^FBAAS79 - S VAR="BEGDATE^ENDDATE^FBAASCR",VAL=BEGDATE_"^"_ENDDATE_"^"_FBAASCR,PGM="START^FBAA79",IOP="Q" D ZIS^FBAAUTL G:FBPOP END -START D SITEP^FBAAUTL G END:FBPOP - S UL="",ULL="----------",FBPG=0 F Z=1:1:12 S UL=UL_ULL - U IO S FBAASCR=$S(FBAASCR="":"I 1",FBAASCR="Y":"I $S('$D(^FBAAA(DFN,1,FBK,1)):1,$P(^FBAAA(DFN,1,FBK,1),""^"",2)']"""":1,1:0)",1:"I 1") - S FBJ=BEGDATE-.001,(DFN,FBK)=0 F ZZ=0:0 S FBJ=$O(^FBAAA("AF",2,FBJ)) Q:FBJ'>0!(FBJ>ENDDATE) F S DFN=$O(^FBAAA("AF",2,FBJ,DFN)) Q:DFN'>0 F S FBK=$O(^FBAAA("AF",2,FBJ,DFN,FBK)) Q:FBK'>0 X FBAASCR I D GOT -END K FBJ,FBK,DFN,Z,FBS,V,FBI,FBPATT,FBPG,FBSITE,UL,ULL,POV,NOV,POS,CC,PSTCD,SSTCD,VSTCD,BEGDATE,ENDDATE,PIDC,REF,VDX,CODE,STATCD,D,FBAASCR,FBDX,FBIDC,FBOUT,FBPDX,FBREM,FBRR,NAME,PGM,POW,VAL,VAR,VFN,VFROM,VTO,YOB,ZZ - K FB7078,FBAABDT,FBAAEDT,FBASSOC,FBLOC,FBPOV,FBPSA,FBPT,FBTT,FBTYPE,FBVEN,FTP,CNT,FBAAOUT,FBAUT,FBPROG,I,J,M,PI,Q,SEX,SSN,TA,DATE,S,Y,DA,DIC - D CLOSE^FBAAUTL Q - Q - ; - ; Utilize new API for Name Standardization - ; -GOT Q:'$D(^DPT(DFN,0)) - S Y(0)=^DPT(DFN,0) - D - .N FBNAMES - .S FBNAMES("FILE")=2,FBNAMES("IENS")=DFN_",",FBNAMES("FIELD")=.01 - .S NAME=$$NAMEFMT^XLFNAME(.FBNAMES) - S SEX=$P(Y(0),U,2) - S SSN=$TR($$SSNL4^FBAAUTL($$SSN^FBAAUTL(DFN)),"-",""),YOB=$S($P(Y(0),U,3)]"":$E($P(Y(0),U,3),1,3)+1700,1:""),POS=$S($D(^DPT(DFN,.32)):$P(^(.32),"^",3),1:""),POS=$S(POS]"":$P(^DIC(21,POS,0),"^",3),1:"") - F I=1:1:7 S FBI(I)="" - I $D(^DPT(DFN,.11)) F I=1:1:7 S FBI(I)=$P(^(.11),"^",I) - S POW=$P($G(^DPT(DFN,.52)),"^",5) - Q:'$D(^FBAAA(DFN,1,FBK)) S Y(0)=^(FBK,0),VFROM=$P(Y(0),"^",1),VTO=$P(Y(0),"^",2),VFN=$P(Y(0),"^",4) I $S($P(Y(0),"^",3)=6:1,$P(Y(0),"^",3)=7:1,1:"") Q - S VDX=$P(Y(0),"^",8),FBPATT=$P(Y(0),"^",18),POV=$$EXTPV^FBAAUTL5($P(Y(0),"^",7)),CODE=$P(Y(0),"^",13),PIDC=$P(Y(0),"^",12),REF=$P(Y(0),"^",21) - S NOV=$P($G(^FBAAA(DFN,1,FBK,1)),"^") - S FBDX=$G(^FBAAA(DFN,1,FBK,3)) - S FBIDC=$P($G(^FBAAA(DFN,4)),"^") - S STATCD=FBI(5),CC=FBI(7) F V=1:1:14 S V(V)="" - S CC=$S(CC']"":"",$D(^DIC(5,+STATCD,1,CC,0)):$P(^(0),"^",3),1:"") - S Y(0)=$S(VFN']"":"",'$D(^FBAAV(VFN,0)):"",$D(^FBAAV(VFN,0)):^(0),1:"") G:$S(VFN']"":1,'$D(^FBAAV(VFN,0)):1,1:0) OVR - F V=2,1,3,14,4,5,6,10 S V(V)=$P(Y(0),"^",V) -OVR F S=1:1:9 S FBS(S)=$P(FBSITE(0),"^",S) - S VSTCD=$S(V(5)']"":" ",$D(^DIC(5,V(5),0)):$P(^(0),"^",2),1:" "),SSTCD=$S(FBS(5)']"":" ",$D(^DIC(5,+FBS(5),0)):$P(^(0),"^",2),1:" "),PSTCD=$S(FBI(5)']"":" ",$D(^DIC(5,+FBI(5),0)):$P(^(0),"^",2),1:" ") - W:FBPG @IOF W UL,!,?46,"Department of Veterans Affairs",?100,"ID Card Number: ",FBIDC,!,?35,"R E Q U E S T F O R O U T P A T I E N T S E R V I C E S",!,UL S FBREM=0,FBOUT=0 - ; - W !,"(1) Veterans Name",?31,"|(2) ID Number | Period of Validity",!,?31,"|",?46,"|" - W !,NAME,?31,"|",?32,SSN,?46,"|"," FROM: ",$$FMTE^XLFDT(VFROM)," TO: ",$$FMTE^XLFDT(VTO),!,UL - W !,"(3) ADDRESS",?31,"|DATE OF ISSUE",?46,"| CONDITIONS FOR WHICH SERVICES ARE REQUESTED (DESCRIPTION OF DISABILITY)",!,?31,"|",?46,"|" - W !,FBI(1),?31,"|",?33,$$FMTE^XLFDT(FBJ),?46,"|"," ",VDX S FBPDX=0 - I FBI(2)]"" W !,FBI(2),?31,"|",?46,"|"," " S FBPDX=FBPDX+1 W ?48,$P(FBDX,"^",FBPDX) - I FBI(3)]"" W !,FBI(3),?31,"|",?46,"|"," " S FBPDX=FBPDX+1 W ?48,$P(FBDX,"^",FBPDX) - W !,FBI(4)," ",PSTCD," ",FBI(6),?31,"|",?46,"|" S FBPDX=FBPDX+1 W ?48,$P(FBDX,"^",FBPDX),!,$E(UL,1,45),?46,"|" S FBPDX=FBPDX+1 W ?48,$P(FBDX,"^",FBPDX) - W !,"Name and Address of Fee Participant",?46,"|" S FBPDX=FBPDX+1 W ?48,$P(FBDX,"^",FBPDX) - W !,?46,"|",!,V(1),?46,"|",!,V(3),?46,"|" W:V(14)]"" !,V(14),?46,"|" - ; PRXM/KJH - Patch 103. Add Referring Provider and NPI to the display. - W !,V(4)," ",VSTCD," ",V(6),?46,"|","REFERRING PROVIDER: " - I REF'="" W $$GET1^DIQ(200,REF,.01) - W !,V(2),?46,"|","NPI: ",$$REFNPI^FBCH78(REF,"",1) - W !,?46,"|","AUTHORIZATION #: ",DFN,"-",FBK,!,UL,! - W ?49,"AUTHORIZATION REMARKS",!,?49,$E(UL,1,21) - D ^FBAA79A S $P(^FBAAA(DFN,1,FBK,1),"^",2)=DT,FBPG=1 Q +FBAA79 ;AISC/GRR-PRINT FORM 7079 REQUEST FOR OUTPATIENT MEDICAL SERVICES ;7/NOV/2006 + ;;3.5;FEE BASIS;**12,23,101**;JAN 30, 1995;Build 2 + ;;Per VHA Directive 2004-038, this routine should not be modified. + W !,"Print 7079's for: " D DT^DICRW,DATE^FBAAUTL G:FBPOP END D SITEP^FBAAUTL G:FBPOP END + I '$D(^FBAAA("AF",2)) W !!,*7,"There are no 7079's to be printed!",! G END + S FBAASCR="" +RDHOW W ! S DIR("A")="Want only those that have not yet been printed",DIR("B")="Yes",DIR(0)="Y" D ^DIR K DIR G END:$D(DIRUT) S:Y FBAASCR="Y" + D OUTPUT^FBAAS79 + S VAR="BEGDATE^ENDDATE^FBAASCR",VAL=BEGDATE_"^"_ENDDATE_"^"_FBAASCR,PGM="START^FBAA79",IOP="Q" D ZIS^FBAAUTL G:FBPOP END +START D SITEP^FBAAUTL G END:FBPOP + S UL="",ULL="----------",FBPG=0 F Z=1:1:12 S UL=UL_ULL + U IO S FBAASCR=$S(FBAASCR="":"I 1",FBAASCR="Y":"I $S('$D(^FBAAA(DFN,1,FBK,1)):1,$P(^FBAAA(DFN,1,FBK,1),""^"",2)']"""":1,1:0)",1:"I 1") + S FBJ=BEGDATE-.001,(DFN,FBK)=0 F ZZ=0:0 S FBJ=$O(^FBAAA("AF",2,FBJ)) Q:FBJ'>0!(FBJ>ENDDATE) F S DFN=$O(^FBAAA("AF",2,FBJ,DFN)) Q:DFN'>0 F S FBK=$O(^FBAAA("AF",2,FBJ,DFN,FBK)) Q:FBK'>0 X FBAASCR I D GOT +END K FBJ,FBK,DFN,Z,FBS,V,FBI,FBPATT,FBPG,FBSITE,UL,ULL,POV,NOV,POS,CC,PSTCD,SSTCD,VSTCD,BEGDATE,ENDDATE,PIDC,VDX,CODE,STATCD,D,FBAASCR,FBDX,FBIDC,FBOUT,FBPDX,FBREM,FBRR,NAME,PGM,POW,VAL,VAR,VFN,VFROM,VTO,YOB,ZZ + K FB7078,FBAABDT,FBAAEDT,FBASSOC,FBLOC,FBPOV,FBPSA,FBPT,FBTT,FBTYPE,FBVEN,FTP,CNT,FBAAOUT,FBAUT,FBPROG,I,J,M,PI,Q,SEX,SSN,TA,DATE,S,Y,DA,DIC + D CLOSE^FBAAUTL Q + Q + ; + ; Utilize new API for Name Standardization + ; +GOT Q:'$D(^DPT(DFN,0)) + S Y(0)=^DPT(DFN,0) + D + .N FBNAMES + .S FBNAMES("FILE")=2,FBNAMES("IENS")=DFN_",",FBNAMES("FIELD")=.01 + .S NAME=$$NAMEFMT^XLFNAME(.FBNAMES) + S SEX=$P(Y(0),U,2) + S SSN=$TR($$SSNL4^FBAAUTL($$SSN^FBAAUTL(DFN)),"-",""),YOB=$S($P(Y(0),U,3)]"":$E($P(Y(0),U,3),1,3)+1700,1:""),POS=$S($D(^DPT(DFN,.32)):$P(^(.32),"^",3),1:""),POS=$S(POS]"":$P(^DIC(21,POS,0),"^",3),1:"") + F I=1:1:7 S FBI(I)="" + I $D(^DPT(DFN,.11)) F I=1:1:7 S FBI(I)=$P(^(.11),"^",I) + S POW=$P($G(^DPT(DFN,.52)),"^",5) + Q:'$D(^FBAAA(DFN,1,FBK)) S Y(0)=^(FBK,0),VFROM=$P(Y(0),"^",1),VTO=$P(Y(0),"^",2),VFN=$P(Y(0),"^",4) I $S($P(Y(0),"^",3)=6:1,$P(Y(0),"^",3)=7:1,1:"") Q + S VDX=$P(Y(0),"^",8),FBPATT=$P(Y(0),"^",18),POV=$$EXTPV^FBAAUTL5($P(Y(0),"^",7)),CODE=$P(Y(0),"^",13),PIDC=$P(Y(0),"^",12),NOV=$P($G(^FBAAA(DFN,1,FBK,1)),"^") + S FBDX=$G(^FBAAA(DFN,1,FBK,3)) + S FBIDC=$P($G(^FBAAA(DFN,4)),"^") + S STATCD=FBI(5),CC=FBI(7) F V=1:1:14 S V(V)="" + S CC=$S(CC']"":"",$D(^DIC(5,+STATCD,1,CC,0)):$P(^(0),"^",3),1:"") + S Y(0)=$S(VFN']"":"",'$D(^FBAAV(VFN,0)):"",$D(^FBAAV(VFN,0)):^(0),1:"") G:$S(VFN']"":1,'$D(^FBAAV(VFN,0)):1,1:0) OVR + F V=2,1,3,14,4,5,6,10 S V(V)=$P(Y(0),"^",V) +OVR F S=1:1:9 S FBS(S)=$P(FBSITE(0),"^",S) + S VSTCD=$S(V(5)']"":" ",$D(^DIC(5,V(5),0)):$P(^(0),"^",2),1:" "),SSTCD=$S(FBS(5)']"":" ",$D(^DIC(5,+FBS(5),0)):$P(^(0),"^",2),1:" "),PSTCD=$S(FBI(5)']"":" ",$D(^DIC(5,+FBI(5),0)):$P(^(0),"^",2),1:" ") + W:FBPG @IOF W UL,!,?46,"Department of Veterans Affairs",?100,"ID Card Number: ",FBIDC,!,?35,"R E Q U E S T F O R O U T P A T I E N T S E R V I C E S",!,UL S FBREM=0,FBOUT=0 + ; + W !,"(1) Veterans Name",?31,"|(2) ID Number | Period of Validity",!,?31,"|",?46,"|" + W !,NAME,?31,"|",?32,SSN,?46,"|"," FROM: ",$$FMTE^XLFDT(VFROM)," TO: ",$$FMTE^XLFDT(VTO),!,UL + W !,"(3) ADDRESS",?31,"|DATE OF ISSUE",?46,"| CONDITIONS FOR WHICH SERVICES ARE REQUESTED (DESCRIPTION OF DISABILITY)",!,?31,"|",?46,"|" + W !,FBI(1),?31,"|",?33,$$FMTE^XLFDT(FBJ),?46,"|"," ",VDX S FBPDX=0 + I FBI(2)]"" W !,FBI(2),?31,"|",?46,"|"," " S FBPDX=FBPDX+1 W ?48,$P(FBDX,"^",FBPDX) + I FBI(3)]"" W !,FBI(3),?31,"|",?46,"|"," " S FBPDX=FBPDX+1 W ?48,$P(FBDX,"^",FBPDX) + W !,FBI(4)," ",PSTCD," ",FBI(6),?31,"|",?46,"|" S FBPDX=FBPDX+1 W ?48,$P(FBDX,"^",FBPDX),!,$E(UL,1,45),?46,"|" S FBPDX=FBPDX+1 W ?48,$P(FBDX,"^",FBPDX) + W !,"Name and Address of Fee Participant",?46,"|" S FBPDX=FBPDX+1 W ?48,$P(FBDX,"^",FBPDX) + W !,?46,"|",!,V(1),?46,"|",!,V(3),?46,"|" W:V(14)]"" !,V(14),?46,"|" + W !,V(4)," ",VSTCD," ",V(6),?46,"|",!,V(2),?46,"|","AUTHORIZATION #: ",DFN,"-",FBK,!,UL,! + W ?49,"AUTHORIZATION REMARKS",!,?49,$E(UL,1,21) + D ^FBAA79A S $P(^FBAAA(DFN,1,FBK,1),"^",2)=DT,FBPG=1 Q diff --git a/r/FEE_BASIS-FB/FBAA79A.m b/r/FEE_BASIS-FB/FBAA79A.m index 94a5cd8b..d62a206d 100644 --- a/r/FEE_BASIS-FB/FBAA79A.m +++ b/r/FEE_BASIS-FB/FBAA79A.m @@ -1,36 +1,30 @@ -FBAA79A ;AISC/GRR-PRINT 7079 CONTINUED ;1/12/98 - ;;3.5;FEE BASIS;**12,103**;JAN 30, 1995;Build 19 - ;;Per VHA Directive 2004-038, this routine should not be modified. - S DIWL=1,DIWF="WC120" K ^UTILITY($J,"W") - I $D(^FBAAA(DFN,1,FBK,2)) F FBRR=0:0 S FBRR=$O(^FBAAA(DFN,1,FBK,2,FBRR)) Q:FBRR'>0 S FBXX=^(FBRR,0),X=FBXX D ^DIWP - D ^DIWW:$D(FBXX) K FBXX - W !,?40,"FOR VA USE ONLY",!,UL - W !," (5) STATE CODE | (6) COUNTY CODE | (7) TYPE OF | (8) YEAR OF BIRTH | (9) WAR | (10) PURPOSE |",!,?16,"|",?34,"|",?37,"PATIENT",?48,"|",?68,"|",?78,"|",?93,"|" - W !,?7,FBI(5),?16,"|",?23,CC,?34,"|",?41,FBPATT,?48,"|",?58,YOB,?68,"|",?74,POS,?78,"|",?87,POV,?93,"|",!,UL - W !,"STATION OF JURISDICTION",?48,"|",?78,"|",?80," (11) CODE",?100,"| (12) SEX",!,?48,"|",?78,"|",?100,"|"," ",$S(SEX="F":"FEMALE",1:"MALE") - W !,"Veterans Administration",?48,"|",?78,"|",?100,"|",$E(UL,101,120) - W !,FBS(2),?48,"|",?78,"|",?80,$S(CODE=1:"SHORT TERM - 1",CODE=2:"HOME NURSING - 2",CODE=3:"ID CARD STATUS - 3",1:""),?100,"| (13) POW" - W:FBS(3)]"" !,FBS(3),?48,"|",?78,"|",?100,"|"," ",$S(POW="Y":"YES",1:"NO") - W !,FBS(4)," ",SSTCD," ",FBS(6),?48,"|",?78,"|",?100,"|" W:FBS(3)']"" " ",$S(POW="Y":"YES",1:"NO") W !,?48,$E(UL,49,120) - W !,?48,"| APPROVED BY (Name and Title)",?110,"(",$S($D(^VA(200,DUZ,0)):$P(^(0),"^",2),1:""),")",!,?48,"|" - W !,"TELEPHONE: ",FBS(7),?48,"|",?50,FBS(8),!,?48,"|",?50,FBS(9),!,UL - W !,?32,"Information On Veterans Administration Program",! - W !,"Acceptance of this request to render the prescribed services will constitute an agreement which is subject",!,"to the following: ",! - W !,?3,"I. SERVICES. If services are not initiated, please return this document to the Station of Jurisdiction with a brief" - W !,?5,"explanation. Unless approved by the VA, services are limited in type and extent to those shown.",! - W !,?3,"II. PERIOD OF VALIDITY. Service must be performed within the period of validity indicated.",!,?5,"If a longer time is needed, please request an extension.",! - W !,?3,"III. REPORTS. Clinical reports are required when an examination only has been requested. Please ",!,?5,"submit reports promptly to the Station Of Jurisdiction.",! - W !,?3,"IV. STATEMENT OF ACCOUNTS. Submit a Statement of Account in your usual manner. Your statement must",!,?5,"include: (1) Patient's Name; (2) Identification NO.; (3) Treatment (CPT) and Dates Rendered; and (4) Fees.",! - W !,?3,"V. FEES. Fees claimed may not exceed those made to the general public for like services.",! - W !,?3,"VI. PAYMENT. Payment by the VA for services rendered and approved is payment in full.",! - W !,?3,"VII. HOSPITALIZATION. When a need for hospital care is indicated, please call the Station of Jurisdiction",!,?5,"for assistance in admitting the veteran to a VA hospital.",! - W !,?3,"VIII. INQUIRIES. Additional information when required may be obtained by contacting the Station Of Jurisdiction.",! - W !,?3,"IX. When submitting claims for payment you must include the NPI and Taxonomy Code of the rendering practitioner, and" - W !,?5,"the NPI and Taxonomy Code of your organization. If, under the HIPAA NPI Final Rule" - W !,?5,"[http://www.cms.hhs.gov/NationalProvIdentStand], your organization is an ""atypical"" provider furnishing services such as" - W !,?5,"taxi, home and vehicle modifications, insect control, habilitation, and respite services and is therefore ineligible" - W !,?5,"for an NPI, it is important that you indicate ""Ineligible for NPI"" on your claim form ." - W !,UL - W !?3,"VA Form 10-7079" - W ?85,"Date Printed: ",$$FMTE^XLFDT(DT),! - Q +FBAA79A ;AISC/GRR-PRINT 7079 CONTINUED ;1/12/98 + ;;3.5;FEE BASIS;**12**;JAN 30, 1995 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + S DIWL=1,DIWF="WC120" K ^UTILITY($J,"W") + I $D(^FBAAA(DFN,1,FBK,2)) F FBRR=0:0 S FBRR=$O(^FBAAA(DFN,1,FBK,2,FBRR)) Q:FBRR'>0 S FBXX=^(FBRR,0),X=FBXX D ^DIWP + D ^DIWW:$D(FBXX) K FBXX + W !,?40,"FOR VA USE ONLY",!,UL + W !," (5) STATE CODE | (6) COUNTY CODE | (7) TYPE OF | (8) YEAR OF BIRTH | (9) WAR | (10) PURPOSE |",!,?16,"|",?34,"|",?37,"PATIENT",?48,"|",?68,"|",?78,"|",?93,"|" + W !,?7,FBI(5),?16,"|",?23,CC,?34,"|",?41,FBPATT,?48,"|",?58,YOB,?68,"|",?74,POS,?78,"|",?87,POV,?93,"|",!,UL + W !,"STATION OF JURISDICTION",?48,"|",?78,"|",?80," (11) CODE",?100,"| (12) SEX",!,?48,"|",?78,"|",?100,"|"," ",$S(SEX="F":"FEMALE",1:"MALE") + W !,"Veterans Administration",?48,"|",?78,"|",?100,"|",$E(UL,101,120) + W !,FBS(2),?48,"|",?78,"|",?80,$S(CODE=1:"SHORT TERM - 1",CODE=2:"HOME NURSING - 2",CODE=3:"ID CARD STATUS - 3",1:""),?100,"| (13) POW" + W:FBS(3)]"" !,FBS(3),?48,"|",?78,"|",?100,"|"," ",$S(POW="Y":"YES",1:"NO") + W !,FBS(4)," ",SSTCD," ",FBS(6),?48,"|",?78,"|",?100,"|" W:FBS(3)']"" " ",$S(POW="Y":"YES",1:"NO") W !,?48,$E(UL,49,120) + W !,?48,"| APPROVED BY (Name and Title)",?110,"(",$S($D(^VA(200,DUZ,0)):$P(^(0),"^",2),1:""),")",!,?48,"|" + W !,"TELEPHONE: ",FBS(7),?48,"|",?50,FBS(8),!,?48,"|",?50,FBS(9),!,UL + W !,?32,"Information On Veterans Administration Program",! + W !,"Acceptance of this request to render the prescribed services will constitute an agreement which is subject",!,"to the following: ",! + W !,?3,"I. SERVICES. If services are not initiated, please return this document to the Station of Jurisdiction with a brief" + W !,?5,"explanation. Unless approved by the VA, services are limited in type and extent to those shown.",! + W !,?3,"II. PERIOD OF VALIDITY. Service must be performed within the period of validity indicated.",!,?5,"If a longer time is needed, please request an extension.",! + W !,?3,"III. REPORTS. Clinical reports are required when an examination only has been requested. Please ",!,?5,"submit reports promptly to the Station Of Jurisdiction.",! + W !,?3,"IV. STATEMENT OF ACCOUNTS. Submit a Statement of Account in your usual manner. Your statement must",!,?5,"include: (1) Patient's Name; (2) Identification NO.; (3) Treatment (CPT) and Dates Rendered; and (4) Fees.",! + W !,?3,"V. FEES. Fees claimed may not exceed those made to the general public for like services.",! + W !,?3,"VI. PAYMENT. Payment by the VA for services rendered and approved is payment in full.",! + W !,?3,"VII. HOSPITALIZATION. When a need for hospital care is indicated, please call the Station of Jurisdiction",!,?5,"for assistance in admitting the veteran to a VA hospital.",! + W !,?3,"VIII. INQUIRIES. Additional information when required may be obtained by contacting the Station Of Jurisdiction.",!,UL + W !?3,"VA Form 10-7079" + W ?85,"Date Printed: ",$$FMTE^XLFDT(DT),! + Q diff --git a/r/FEE_BASIS-FB/FBAAAUT.m b/r/FEE_BASIS-FB/FBAAAUT.m index 99d30ca5..bdfe5715 100644 --- a/r/FEE_BASIS-FB/FBAAAUT.m +++ b/r/FEE_BASIS-FB/FBAAAUT.m @@ -1,58 +1,36 @@ -FBAAAUT ;AISC/DMK - ENTER/EDIT AUTHORIZATION ;3/11/1999 - ;;3.5;FEE BASIS;**13,95,103**;JAN 30, 1995;Build 19 - ;;Per VHA Directive 2004-038, this routine should not be modified. - D SITEP^FBAAUTL G Q:FBPOP S FBAADDYS=+$P(FBSITE(0),"^",13),FBAAASKV=$P(FBSITE(1),"^",1),FBPROG=$S($P(FBSITE(1),"^",6)="":"I 1",1:"I $P(^(0),U,3)=2") - W ! S DIC="^DPT(",DIC(0)="QEAZM" D ^DIC G Q:Y<0 S DFN=+Y - I $P($G(^DPT(DFN,.361)),"^")="" W !!,"ELIGIBILITY HAS NOT BEEN DETERMINED NOR PENDING, CANNOT ENTER AN AUTHORIZATION." G FBAAAUT -CONT I $P($G(^DPT(DFN,.32)),"^",4)=2 W !!?4,"VETERAN HAS A DISHONORABLE DISCHARGE, " S X=$P($G(^(.321)),"^") W $S(X="Y":"ONLY ELIGIBLE FOR AGENT ORANGE EXAM.",1:"NOT ELIGIBLE FOR BENEFITS.") - W ! S DIR("A")="Do you want to continue",DIR(0)="Y",DIR("B")="Yes" D ^DIR K DIR G FBAAAUT:$S($D(DIRUT):1,'Y:1,1:0) -1 S DA=DFN I '$D(^FBAAA(DA,0)) L +^FBAAA(DA) K DD,DO S (X,DINUM)=DA,DIC="^FBAAA(",DIC(0)="LM",DLAYGO=161 D FILE^DICN L -^FBAAA(DFN) K DIC G:Y<0 Q - S:'$D(^FBAAA(DFN,1,0)) ^(0)="^161.01D^^" - D ^FBAADEM K DIRUT,DIROUT,DTOUT,DUOUT -2 W ! S (HID,NID,FBAAP79,FBANEW)="",DA=DFN,DIE="^FBAAA(",DIE("NO^")="",DR="[FBAA AUTHORIZATION]" D ^DIE I $D(FBD1) S FBANEW=$G(^FBAAA(DFN,1,FBD1,0)) - D:'$D(Y)&(HID'="")&(HID'=NID) TRIG K HID,NID,NIDR,TIME G FBAAAUT:FBANEW']"" S X=FBANEW,K=FBD1,J=DT - I FBAAP79="Y" S $P(^FBAAA(DFN,1,FBD1,1),"^",2)="",FBDFN=DFN D CHEKP79 S DFN=FBDFN - I $D(FBAOLD),FBAOLD'=FBANEW,$D(FBAALT),FBAALT="Y" S FBTTYPE="A",FBMST=$S($P(FBANEW,"^",13)=1:"Y",1:""),FBFDC=$S($P(FBAOLD,"^")'=$P(FBANEW,"^"):1,1:"") D MORE - I '$D(^FBAAC(DFN,0)) K DD,DO S (X,DINUM)=DFN,DIC(0)="L",DLAYGO=162,DIC="^FBAAC(" D FILE^DICN K DIC,DLAYGO - G FBAAAUT -TRIG ;Add an entry in Fee Basis ID Card Audit file - I '$D(^FBAA(161.83,DFN)) K DD,DO S (X,DINUM)=DFN,DIC="^FBAA(161.83,",DIC(0)="L",DLAYGO=161.83 D FILE^DICN Q:Y<0 - S:'$D(^FBAA(161.83,DFN,1,0)) ^(0)="^161.831DA^^" - S %DT="XT",X="NOW" D ^%DT K %DT S TIME=Y - L +^FBAA(161.83,DFN) S DIC="^FBAA(161.83,"_DFN_",1,",DIC(0)="LM",DINUM=9999999.9999-TIME,X=TIME,DIC("DR")="1////^S X=HID;2////^S X=NIDR;3////^S X=DUZ",DA(1)=DFN K DD,DO D FILE^DICN I Y<0 L -^FBAA(161.83,DFN) Q - K DIE,DIC,DA,DLAYGO L -^FBAA(161.83,DFN) - Q -ENT ;ENTRY POINT FROM ^FBAAPM TO CREATE MRA TRANSACTION -MORE ; - S DIC="^FBAA(161.26,",DIC(0)="L",DLAYGO=161.26,X=DFN - S DIC("DR")="1///^S X=""P"";2///^S X=FBD1;3///^S X=FBTTYPE;5////^S X=FBFDC;6////^S X=FBMST" - K DD,DO D FILE^DICN K DIC,DLAYGO S DA=+Y - Q - ; -CHEKP79 W ! S DIR("A")="Want to Print 7079 for this patient now",DIR(0)="Y",DIR("B")="No" D ^DIR K DIR I Y S FBK=FBD1 D EN1^FBAAS79 - Q -Q K DA,DAT,DFN,DR,F,FBAASKV,FBAADDYS,FBAALT,FBAAP79,FBAATT,FBANEW,FBAOLD,FBCOUNTY,FBDX,FBI,FBRR,FBSITE,FBTYPE,FBXX,I,J,K,PI,S,T,Z,ZZ,FBAAASKV,FBPROG,DIC,DIE,FBAAX,X,Y,PTYPE,FBPRG,FBAAOUT,FBDFN - K FBAUT,FBD1,FBPOP - Q - ; - ; PROVIDER LOOKUP - ; - ; This function checks the inputed File 200 entry to ensure that it has been assigned the Security Key PROVIDER. - ; - ; Referenced: AUTHORIZATION Sub-File (#161.01) OF FEE BASIS PATIENT File (#161) - REFERRING PROVIDER Field (#104) - ; Referenced: FEE NOTIFICATION/REQUEST File (#162.2) - REFERRING PROVIDER Field (#17) - ; Referenced: VA FORM 10-7078 File (#162.4) - REFERRING PROVIDER Field (#15) - ; - ; Input - FB200IEN - Internal IEN of file 200 entry - ; Output - 0 Blank Input or entry without PROVIDER Security Key - ; - 1 Entry PROVIDER Security Key assigned - ; -PROVIDER(FB200IEN) N Y - ; - Q:$G(FB200IEN)="" 0 - ; - ;Test for PROVIDER Security Key - I $D(^XUSEC("PROVIDER",FB200IEN)) Q 1 - ; - ;Entry did not have PROVIDER Security Key - Q 0 +FBAAAUT ;AISC/DMK-ENTER/EDIT AUTHORIZATION ;3/11/1999 + ;;3.5;FEE BASIS;**13,95**;JAN 30, 1995 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + D SITEP^FBAAUTL G Q:FBPOP S FBAADDYS=+$P(FBSITE(0),"^",13),FBAAASKV=$P(FBSITE(1),"^",1),FBPROG=$S($P(FBSITE(1),"^",6)="":"I 1",1:"I $P(^(0),U,3)=2") + W ! S DIC="^DPT(",DIC(0)="QEAZM" D ^DIC G Q:Y<0 S DFN=+Y + I $P($G(^DPT(DFN,.361)),"^")="" W !!,"ELIGIBILITY HAS NOT BEEN DETERMINED NOR PENDING, CANNOT ENTER AN AUTHORIZATION." G FBAAAUT +CONT I $P($G(^DPT(DFN,.32)),"^",4)=2 W !!?4,"VETERAN HAS A DISHONORABLE DISCHARGE, " S X=$P($G(^(.321)),"^") W $S(X="Y":"ONLY ELIGIBLE FOR AGENT ORANGE EXAM.",1:"NOT ELIGIBLE FOR BENEFITS.") + W ! S DIR("A")="Do you want to continue",DIR(0)="Y",DIR("B")="Yes" D ^DIR K DIR G FBAAAUT:$S($D(DIRUT):1,'Y:1,1:0) +1 S DA=DFN I '$D(^FBAAA(DA,0)) L +^FBAAA(DA) K DD,DO S (X,DINUM)=DA,DIC="^FBAAA(",DIC(0)="LM",DLAYGO=161 D FILE^DICN L -^FBAAA(DFN) K DIC G:Y<0 Q + S:'$D(^FBAAA(DFN,1,0)) ^(0)="^161.01D^^" + D ^FBAADEM K DIRUT,DIROUT,DTOUT,DUOUT +2 W ! S (HID,NID,FBAAP79,FBANEW)="",DA=DFN,DIE="^FBAAA(",DIE("NO^")="",DR="[FBAA AUTHORIZATION]" D ^DIE I $D(FBD1) S FBANEW=$G(^FBAAA(DFN,1,FBD1,0)) + D:'$D(Y)&(HID'="")&(HID'=NID) TRIG K HID,NID,NIDR,TIME G FBAAAUT:FBANEW']"" S X=FBANEW,K=FBD1,J=DT + I FBAAP79="Y" S $P(^FBAAA(DFN,1,FBD1,1),"^",2)="",FBDFN=DFN D CHEKP79 S DFN=FBDFN + I $D(FBAOLD),FBAOLD'=FBANEW,$D(FBAALT),FBAALT="Y" S FBTTYPE="A",FBMST=$S($P(FBANEW,"^",13)=1:"Y",1:""),FBFDC=$S($P(FBAOLD,"^")'=$P(FBANEW,"^"):1,1:"") D MORE + I '$D(^FBAAC(DFN,0)) K DD,DO S (X,DINUM)=DFN,DIC(0)="L",DLAYGO=162,DIC="^FBAAC(" D FILE^DICN K DIC,DLAYGO + G FBAAAUT +TRIG ;Add an entry in Fee Basis ID Card Audit file + I '$D(^FBAA(161.83,DFN)) K DD,DO S (X,DINUM)=DFN,DIC="^FBAA(161.83,",DIC(0)="L",DLAYGO=161.83 D FILE^DICN Q:Y<0 + S:'$D(^FBAA(161.83,DFN,1,0)) ^(0)="^161.831DA^^" + S %DT="XT",X="NOW" D ^%DT K %DT S TIME=Y + L +^FBAA(161.83,DFN) S DIC="^FBAA(161.83,"_DFN_",1,",DIC(0)="LM",DINUM=9999999.9999-TIME,X=TIME,DIC("DR")="1////^S X=HID;2////^S X=NIDR;3////^S X=DUZ",DA(1)=DFN K DD,DO D FILE^DICN I Y<0 L -^FBAA(161.83,DFN) Q + K DIE,DIC,DA,DLAYGO L -^FBAA(161.83,DFN) + Q +ENT ;ENTRY POINT FROM ^FBAAPM TO CREATE MRA TRANSACTION +MORE ; + S DIC="^FBAA(161.26,",DIC(0)="L",DLAYGO=161.26,X=DFN + S DIC("DR")="1///^S X=""P"";2///^S X=FBD1;3///^S X=FBTTYPE;5////^S X=FBFDC;6////^S X=FBMST" + K DD,DO D FILE^DICN K DIC,DLAYGO S DA=+Y + Q + ; +CHEKP79 W ! S DIR("A")="Want to Print 7079 for this patient now",DIR(0)="Y",DIR("B")="No" D ^DIR K DIR I Y S FBK=FBD1 D EN1^FBAAS79 + Q +Q K DA,DAT,DFN,DR,F,FBAASKV,FBAADDYS,FBAALT,FBAAP79,FBAATT,FBANEW,FBAOLD,FBCOUNTY,FBDX,FBI,FBRR,FBSITE,FBTYPE,FBXX,I,J,K,PI,S,T,Z,ZZ,FBAAASKV,FBPROG,DIC,DIE,FBAAX,X,Y,PTYPE,FBPRG,FBAAOUT,FBDFN + K FBAUT,FBD1,FBPOP + Q diff --git a/r/FEE_BASIS-FB/FBAADEM1.m b/r/FEE_BASIS-FB/FBAADEM1.m index 806c8912..0014aea4 100644 --- a/r/FEE_BASIS-FB/FBAADEM1.m +++ b/r/FEE_BASIS-FB/FBAADEM1.m @@ -1,52 +1,48 @@ -FBAADEM1 ;AISC/DMK-DISPLAY PATIENT DEMOGRAPHICS ;14MAY92 - ;;3.5;FEE BASIS;**13,51,103**;JAN 30, 1995;Build 19 - ;;Per VHA Directive 2004-038, this routine should not be modified. -EN N FBDX,FBFDT,FBI,FBRR,FBT,FBTYPE,FBV,FBZ,PSA - S:'$D(FBPROG) FBPROG="I 1" - ; - S Y=$G(^FBAAA(DFN,4)) W:$P(Y,"^")]"" !,"Fee ID Card #: ",$P(Y,"^"),?40,"Fee Card Issue Date: " S Y=$P(Y,"^",2) D PDF W Y,! - ; - I $O(^FBAAA(DFN,1,0)) D Q:FBAAOUT - . D HANG:$Y+5>IOSL Q:FBAAOUT - . W !,"Patient Name: ",VADM(1),?55,"Pt.ID: ",$P(VADM(2),"^",2) - . W !!,"AUTHORIZATIONS:",! - . K FBAUT - . S FBZ=0,FBFDT="9999999" - . F S FBFDT=$O(^FBAAA(DFN,1,"B",FBFDT),-1) Q:'FBFDT D Q:FBAAOUT - . . S FBI=0 F S FBI=$O(^FBAAA(DFN,1,"B",FBFDT,FBI)) Q:'FBI I $D(^FBAAA(DFN,1,FBI,0)) X FBPROG I S FBZ=FBZ+1,X=^(0) D Q:FBAAOUT - . . . S Y=+X,PSA=$P(X,"^",5),FBT=$P(X,"^",13),FBV=+$P(X,"^",4) D PDF - . . . W ?3,"(",FBZ,")",?7,"FR: ",Y,?25,"VENDOR: ",$S($D(^FBAAV(FBV,0)):$P(^(0),"^")_" - "_$P(^(0),"^",2),1:"Not Specified") - . . . S FBDX=$G(^FBAAA(DFN,1,FBI,3)) W !?7,"TO: " S Y=$P(X,"^",2) D PDF W Y,!?25,"Authorization Type: " D - . . . . S FBTYPE=$P(X,"^",3),FBTYPE=$S(FBTYPE=2:"Outpatient - "_$S(FBT=1:"Short Term",FBT=2:"Home Health",FBT=3:"ID Card",1:""),$D(^FBAA(161.8,+FBTYPE,0)):$P(^(0),"^"),1:"Unknown") - . . . W FBTYPE W:$P(X,"^",7) !,?11,"Purpose of Visit: ",$P($G(^FBAA(161.82,$P(X,"^",7),0)),"^") I $P(X,"^",9)["FB583(" W !?25,">> Unauthorized Claim <<" - . . . ; PRXM/KJH - Patch 103. Add Referring Provider and NPI to the display. - . . . W !?11,"DX: ",$P(X,"^",8) W ?40,"REF: " - . . . I $P(X,"^",21)'="" W $$GET1^DIQ(200,$P(X,"^",21),.01) - . . . W !?11,"REF NPI: ",$$REFNPI^FBCH78($P(X,"^",21)),! - . . . W:$P(FBDX,"^")]"" !?15,$P(FBDX,"^") W:$P(FBDX,"^",2)]"" !?15,$P(FBDX,"^",2) - . . . S FBAUT($P(X,"^"))=$P(X,"^",2) - . . . W !?7,"County: ",FBCOUNTY,?40,"PSA: ",$S($D(^DIC(4,+PSA,0)):$P(^(0),"^"),1:"Unknown"),! - . . . S FBDEL=$G(^FBAAA(DFN,1,FBI,"ADEL")) I FBDEL]"" S Y=$P(FBDEL,"^",2) D PDF W ?12,">> DELETE MRA SENT TO AUSTIN ON - ",Y," >>",! - . . . I $D(^FBAAA(DFN,1,FBI,2,0)) K ^UTILITY($J,"W") S DIWL=15,DIWR=70,DIWF="W" D HANG:$Y+6>IOSL Q:FBAAOUT W !?11,"REMARKS:" D - . . . . S FBRR=0 F S FBRR=$O(^FBAAA(DFN,1,FBI,2,FBRR)) Q:'FBRR S (FBXX,X)=^(FBRR,0) D ^DIWP - . . . D ^DIWW:$D(FBXX) K FBXX W ! - . . . K X,FBDX,FBT,FBTYPE,FBV,PSA D HANG:$Y+5>IOSL - ; - D HANG:$Y+5>IOSL Q:FBAAOUT - ; - I $O(^FBAAA(DFN,2,0))>0 D Q:FBAAOUT - . W !,"VENDOR CONTACTS:" - . S (FBZ,FBI)=0 - . F S FBI=$O(^FBAAA(DFN,2,FBI)) Q:'FBI!(FBAAOUT) S FBZ=FBZ+1,X=$G(^(FBI,0)),Y=+X D PDF D - . . W !?3,"(",FBZ,")",?7,"DATE: ",Y,?25,"VENDOR: ",$P(X,"^",2),?55,"PHONE: ",$S($P(X,"^",3)]"":$P(X,"^",3),1:"Not Found") - . . I $D(^FBAAA(DFN,2,FBI,1,0)) K ^UTILITY($J,"W") S DIWL=20,DIWR=70,DIWF="W" D HANG:$Y+5>IOSL Q:FBAAOUT W !?11,"NARRATIVE:",! D - . . . S FBRR=0 F S FBRR=$O(^FBAAA(DFN,2,FBI,1,FBRR)) Q:'FBRR S FBXX=^(FBRR,0) D HANG:$Y+5>IOSL Q:FBAAOUT S X=FBXX D ^DIWP - . . D ^DIWW:$D(FBXX) K FBXX W ! - Q - ; -HANG I $E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR S:'Y FBAAOUT=1 - W @IOF I 'FBAAOUT W !,"Patient Name: ",VADM(1),?55,"Pt.ID: ",$P(VADM(2),"^",2),! - Q - ; -PDF S:Y Y=$$FMTE^XLFDT(Y,5) ; TRANSLATE TO DISPLAY DATE - Q +FBAADEM1 ;AISC/DMK-DISPLAY PATIENT DEMOGRAPHICS ;14MAY92 + ;;3.5;FEE BASIS;**13,51**;JAN 30, 1995 + ;;Per VHA Directive 10-93-142, this routine should not be modified. +EN N FBDX,FBFDT,FBI,FBRR,FBT,FBTYPE,FBV,FBZ,PSA + S:'$D(FBPROG) FBPROG="I 1" + ; + S Y=$G(^FBAAA(DFN,4)) W:$P(Y,"^")]"" !,"Fee ID Card #: ",$P(Y,"^"),?40,"Fee Card Issue Date: " S Y=$P(Y,"^",2) D PDF W Y,! + ; + I $O(^FBAAA(DFN,1,0)) D Q:FBAAOUT + . D HANG:$Y+5>IOSL Q:FBAAOUT + . W !,"Patient Name: ",VADM(1),?55,"Pt.ID: ",$P(VADM(2),"^",2) + . W !!,"AUTHORIZATIONS:",! + . K FBAUT + . S FBZ=0,FBFDT="9999999" + . F S FBFDT=$O(^FBAAA(DFN,1,"B",FBFDT),-1) Q:'FBFDT D Q:FBAAOUT + . . S FBI=0 F S FBI=$O(^FBAAA(DFN,1,"B",FBFDT,FBI)) Q:'FBI I $D(^FBAAA(DFN,1,FBI,0)) X FBPROG I S FBZ=FBZ+1,X=^(0) D Q:FBAAOUT + . . . S Y=+X,PSA=$P(X,"^",5),FBT=$P(X,"^",13),FBV=+$P(X,"^",4) D PDF + . . . W ?3,"(",FBZ,")",?7,"FR: ",Y,?25,"VENDOR: ",$S($D(^FBAAV(FBV,0)):$P(^(0),"^")_" - "_$P(^(0),"^",2),1:"Not Specified") + . . . S FBDX=$G(^FBAAA(DFN,1,FBI,3)) W !?7,"TO: " S Y=$P(X,"^",2) D PDF W Y,!?25,"Authorization Type: " D + . . . . S FBTYPE=$P(X,"^",3),FBTYPE=$S(FBTYPE=2:"Outpatient - "_$S(FBT=1:"Short Term",FBT=2:"Home Health",FBT=3:"ID Card",1:""),$D(^FBAA(161.8,+FBTYPE,0)):$P(^(0),"^"),1:"Unknown") + . . . W FBTYPE W:$P(X,"^",7) !,?11,"Purpose of Visit: ",$P($G(^FBAA(161.82,$P(X,"^",7),0)),"^") I $P(X,"^",9)["FB583(" W !?25,">> Unauthorized Claim <<" + . . . W !?11,"DX: ",$P(X,"^",8) W:$P(FBDX,"^")]"" !?15,$P(FBDX,"^") W:$P(FBDX,"^",2)]"" !?15,$P(FBDX,"^",2) + . . . S FBAUT($P(X,"^"))=$P(X,"^",2) + . . . W !?7,"County: ",FBCOUNTY,?40,"PSA: ",$S($D(^DIC(4,+PSA,0)):$P(^(0),"^"),1:"Unknown"),! + . . . S FBDEL=$G(^FBAAA(DFN,1,FBI,"ADEL")) I FBDEL]"" S Y=$P(FBDEL,"^",2) D PDF W ?12,">> DELETE MRA SENT TO AUSTIN ON - ",Y," >>",! + . . . I $D(^FBAAA(DFN,1,FBI,2,0)) K ^UTILITY($J,"W") S DIWL=15,DIWR=70,DIWF="W" D HANG:$Y+6>IOSL Q:FBAAOUT W !?11,"REMARKS:" D + . . . . S FBRR=0 F S FBRR=$O(^FBAAA(DFN,1,FBI,2,FBRR)) Q:'FBRR S (FBXX,X)=^(FBRR,0) D ^DIWP + . . . D ^DIWW:$D(FBXX) K FBXX W ! + . . . K X,FBDX,FBT,FBTYPE,FBV,PSA D HANG:$Y+5>IOSL + ; + D HANG:$Y+5>IOSL Q:FBAAOUT + ; + I $O(^FBAAA(DFN,2,0))>0 D Q:FBAAOUT + . W !,"VENDOR CONTACTS:" + . S (FBZ,FBI)=0 + . F S FBI=$O(^FBAAA(DFN,2,FBI)) Q:'FBI!(FBAAOUT) S FBZ=FBZ+1,X=$G(^(FBI,0)),Y=+X D PDF D + . . W !?3,"(",FBZ,")",?7,"DATE: ",Y,?25,"VENDOR: ",$P(X,"^",2),?55,"PHONE: ",$S($P(X,"^",3)]"":$P(X,"^",3),1:"Not Found") + . . I $D(^FBAAA(DFN,2,FBI,1,0)) K ^UTILITY($J,"W") S DIWL=20,DIWR=70,DIWF="W" D HANG:$Y+5>IOSL Q:FBAAOUT W !?11,"NARRATIVE:",! D + . . . S FBRR=0 F S FBRR=$O(^FBAAA(DFN,2,FBI,1,FBRR)) Q:'FBRR S FBXX=^(FBRR,0) D HANG:$Y+5>IOSL Q:FBAAOUT S X=FBXX D ^DIWP + . . D ^DIWW:$D(FBXX) K FBXX W ! + Q + ; +HANG I $E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR S:'Y FBAAOUT=1 + W @IOF I 'FBAAOUT W !,"Patient Name: ",VADM(1),?55,"Pt.ID: ",$P(VADM(2),"^",2),! + Q + ; +PDF S:Y Y=$$FMTE^XLFDT(Y,5) ; TRANSLATE TO DISPLAY DATE + Q diff --git a/r/FEE_BASIS-FB/FBAAFSR.m b/r/FEE_BASIS-FB/FBAAFSR.m index 0aad3f8e..f97d502f 100644 --- a/r/FEE_BASIS-FB/FBAAFSR.m +++ b/r/FEE_BASIS-FB/FBAAFSR.m @@ -1,229 +1,225 @@ -FBAAFSR ;WCIOFO/TCK,SS,DMK,SAB-RBRVS FEE SCHEDULE ; 8/26/1999 - ;;3.5;FEE BASIS;**4,53,71,84,92,93,99,102,105**;JAN 30, 1995;Build 1 - ; - Q - ; -RBRVS(CPT,MODL,DOS,ZIP,FAC,TIME) ; calculate RBRVS Fee Schedule amount - ; Input - ; CPT = CPT/HCPCS code (external value) - ; MODL = list of CPT/HCPCS modifiers (external values) - ; delimited by commas (e.g. "26,51") - ; DOS = date of service (fileman format e.g. 2980101) - ; ZIP = ZIP code of service (external 5 digit value) - ; FAC = facility flag =1 if site of service is facility setting - ; TIME = time in minutes, only passed on anesthesia CPT codes - ; Returns string - ; dollar amount^sched year OR null value if not on RBRVS schedule - ; Output - ; FBERR( array of error messages OR undefined if none - ; - N FBAMT,FBCF,FBCPT0,FBCPTY0,FBCY,FBERR,FBGPCIY0 - ; - ; initialization - S FBAMT="" - K FBERR - ; - ; check for required input parameters - I $G(CPT)="" D ERR^FBAAFS("CPT missing") - I $G(DOS)'?7N D ERR^FBAAFS("Date of Service missing") - I $D(FBERR) Q FBAMT - ; - ;if date of service prior to VA implementation, don't use RBRVS - I DOS<2990901 Q FBAMT - ; - ;if modifier SG present, don't use RBRVS, patch FB*3.5*84 - I MODL["SG" Q FBAMT - ; - ; determine schedule calendar year based on date of service - S FBCY=$E(DOS,1,3)+1700 - ; - ;If date of service in 2003 but prior to Mar 1, 2003 treat as 2002 - I $E(DOS,1,3)=303,DOS<3030301 S FBCY=FBCY-1 - ; - ; if year after most recent RBRVS schedule then use prior year schedule - I FBCY>$$LASTCY() S FBCY=FBCY-1 - ; - ; get procedure data from schedule for year - D PROC(CPT,MODL,FBCY) - ; - ; if procedure: - ; - covered - ; - payable - ; - not for anesthesia - ; then calculate amount - I FBCPTY0]"",'$$ANES^FBAAFS(CPT) D - . ; - . ;validate parameters - . I $G(ZIP)="" D ERR^FBAAFS("Missing ZIP Code") - . I $G(FAC)="" D ERR^FBAAFS("Missing Facility Flag") - . I $D(FBERR) Q - . ; - . ; get GPCIs for calendar year - . D ZIP(FBCY,ZIP) - . I FBGPCIY0="" D ERR^FBAAFS("Could not determine GPCIs") Q - . ; - . ; get conversion factor - . S FBCF=$$CF(FBCY,$P(FBCPT0,U,2)) - . I FBCF="" D ERR^FBAAFS("Could not determine the conversion factor") Q - . ; - . ; calculate full schedule amount - . D CALC(FBCY,FAC,FBCPTY0,FBGPCIY0,FBCF) - . ; - . ; apply multiplier based on modifier - . I MODL]"" S FBAMT=FBAMT*$$MULT(FBCY,MODL,FBCPT0,FBCPTY0) - ; - ; return result - Q $S(FBAMT>0:$J(FBAMT,0,2)_U_FBCY,1:"") - ; -PROC(CPT,MODL,FBCY,FBNONPBL) ; get procedure data for RBRVS schedule - ; Input - ; CPT = CPT/HCPCS code (external value) - ; MODL = list of CPT/HCPCS modifiers (external value) - ; delimited by commas - ; FBCY = calendar year (4 digit) - ; FBNONPBL ( optional): - ; if $G(FBNONPBL)=0 then will make search among payable records only in #162.97 - ; ignoring those non-payable ones with field #.08 NONPAYABLE = 1 - ; if $G(FBNONPBL)=1 then will make search among all items in #162.97 - ; - ; Output - ; FBCPT0 = zero node from file 162.97 OR "" if not covered - ; FBCPTY0 = zero node from subfile 162.971 or "" if not covered - N CPTM,MOD,FBI - S (FBCPT0,FBCPTY0)="" - Q:$G(FBCY)']""!($G(CPT)']"") - ; - ; if modifier exists try to find entry with modifier - I MODL]"" D - . F FBI=1:1 S MOD=$P(MODL,",",FBI) Q:MOD="" D Q:FBCPTY0]"" - . . S CPTM=CPT_"-"_MOD - . . D PROC1(CPTM,FBCY,$G(FBNONPBL)) - ; - ; if not found with modifier, try just CPT code - I FBCPTY0="" D PROC1(CPT,FBCY,$G(FBNONPBL)) - ; - Q - ; -PROC1(CPTM,FBCY,FBNONPBL) ; get procedure data for CPT-Modifier - ; input - ; CPTM - CPT Code - Modifier (e.g. 57335-TC or 57335) - ; FBCY - 4 digit calendar year - ; FBNONPBL ( optional): - ; if $G(FBNONPBL)=0 then will make search among payable records only in #162.97 - ; ignoring those non-payable ones with field #.08 NONPAYABLE = 1 - ; if $G(FBNONPBL)=1 then will make search among all items in #162.97 - ; output - ; FBCPT0 = zero node from file 162.97 OR "" if not covered - ; FBCPTY0 = zero node from subfile 162.971 or "" if not covered - N FBDA,FBDA1 - S (FBCPT0,FBCPTY0)="" - S FBDA=$O(^FB(162.97,"B",CPTM,0)) - S FBDA1=$S(FBDA:$O(^FB(162.97,FBDA,"CY","B",FBCY,0)),1:"") - I $G(FBDA),$G(FBDA1) D - . N FBI,FBSUM,FBY - . S FBY=$G(^FB(162.97,FBDA,"CY",FBDA1,0)) - . ;if non-payable records should not be considered - . ;then quit if this is NONPAYBLE - . I +$G(FBNONPBL)=0 Q:$P(FBY,U,8)=1 - . ; check if procedure covered by schedule - . I +$G(FBNONPBL)=0,$$ANES^FBAAFS($P(CPTM,"-")),$P(FBY,U,6)']"" Q ; missing anes base - . I +$G(FBNONPBL)=0,'$$ANES^FBAAFS($P(CPTM,"-")) D I FBSUM'>0 Q ; sum of RVUs = 0 - . . S FBSUM=0 F FBI=3,4,5,6 S FBSUM=FBSUM+$P(FBY,U,FBI) - . ; passed checks - . S FBCPTY0=FBY - . S FBCPT0=$G(^FB(162.97,FBDA,0)) - Q - ; -ZIP(FBCY,ZIP) ; get GPCIs - ; Input - ; FBCY = calendar year (4 digit) - ; ZIP = zip code (5 digit external value) - ; Output - ; FBGPCIY0 = zero node from file 162.96 or "" if not found - S FBGPCIY0="" - Q:$G(FBCY)']""!($G(ZIP)']"") - N FBDA,FBDA1 - S FBDA=$O(^FB(162.96,"B",ZIP,0)) - S FBDA1=$S(FBDA:$O(^FB(162.96,FBDA,"CY","B",FBCY,0)),1:"") - I FBDA,FBDA1 S FBGPCIY0=$G(^FB(162.96,FBDA,"CY",FBDA1,0)) - Q - ; -CF(FBCY,FBDA) ; get conversion factor - ; Input - ; FBCY = calendar year - ; FBDA = optional conversion category (internal) - ; Returns - ; conversion factor from file 162.99 - N FBCF,FBDA1 - I '$G(FBDA) S FBDA=4 ; use Medicine category if not specified - S FBDA1=$O(^FB(162.99,FBDA,"CY","B",FBCY,0)) - S FBCF=$S(FBDA1:$P($G(^FB(162.99,FBDA,"CY",FBDA1,0)),U,2),1:"") - Q +FBCF - ; -CALC(FBCY,FAC,FBCPTY0,FBGPCIY0,FBCF) ; - ; Input - ; FBCY = calendar year (4 digit) - ; FAC = facility flag (0 or 1) - ; FBCPTY0 = zero node from file 162.71 - ; FBGPCI0 = zero node from file 162.61 - ; FBCF = conversion factor (number) - ; Returns $ amount - ; - N GPCI,RVU,FBI,TMP,TMPRVU - S FBAMT=0 - ;Old formula for RBRVS pre-2007 payment amounts - I DOS<3070101 D - .S RVU(1)=$P(FBCPTY0,U,3) - I (DOS=3070101!(DOS>3070101)&(DOS<3080101)) D - .;New formula for RBRVS 2007 payment amounts - .;Multiply Work RVU by the Budget Neutrality Adjustor (0.8994) - .S TMP=$P(FBCPTY0,U,3),TMPRVU=$J((TMP*(.8994)),".",2) - .S RVU(1)=TMPRVU - I DOS=3080101!(DOS>3080101) D - .;New formula for the RBRVS 2008 payment amounts - .;Multiply Work RVU by the Budget Neutrality Adjustor (0.8994) - .S TMP=$P(FBCPTY0,U,3),TMPRVU=$J((TMP*(.8806)),".",2) - .S RVU(1)=TMPRVU - S RVU(2)=$P(FBCPTY0,U,4+FAC) - S RVU(3)=$P(FBCPTY0,U,6) - F FBI=2,3,4 S GPCI(FBI-1)=$P(FBGPCIY0,U,FBI) - S FBAMT=((RVU(1)*GPCI(1))+(RVU(2)*GPCI(2))+(RVU(3)*GPCI(3)))*FBCF - ; some procedures can't be performed in a facility setting by - ; definition. the facility PE RVU for such a procedure is a null - ; value. - ; when facility setting - check for a null PE value and don't return amt - I RVU(2)="",FAC S FBAMT=0 Q - Q - ; -MULT(FBCY,MODL,FBCPT0,FBCPTY0) ;returns multiplier based on table type - ; Input - ; FBCY = calendar year (4 digit) - ; MODL = list of CPT/HCPCS modifiers (external values) - ; delimited by commas - ; FBCPT0 = zero node of file 162.7 for procedure - ; FBCPTY0 = zero node of subfile 162.71 for year - ; Returns - ; multiplier value OR 1 if none - N FBDA,FBDA1,FBI,FBML,FBPD,FBRET,FBTBL,MOD - S FBRET=1 - S FBML=$P(FBCPTY0,U,2) ; mod level table for procedure - I MODL]"",FBML]"",FBCY]"" D - . S FBTBL=FBCY_"-"_FBML ; mod level table for year - . S FBDA=$O(^FB(162.98,"B",FBTBL,0)) - . Q:'FBDA ; table not found - . ; loop thru the modifiers - . F FBI=1:1 S MOD=$P(MODL,",",FBI) Q:MOD="" D - . . I $P($P(FBCPT0,U),"-",2)=MOD Q ; modifier already built in schedule - . . ; look up modifier in mod level table - . . S FBDA1=$O(^FB(162.98,FBDA,"M","B",MOD,0)) - . . Q:'FBDA1 ; modifier not found in table - . . S FBPD=$P($G(^FB(162.98,FBDA,"M",FBDA1,0)),U,2) ; percentage - . . I FBPD>0 S FBRET=FBRET*(FBPD/100) ; multiplier - Q FBRET - ; -LASTCY() ; Determine last calendar year of RBRVS FEE schedule data - ; based on last year for Medicine conversion factor - N YEAR - S YEAR=$O(^FB(162.99,4,"CY","B"," "),-1) - Q YEAR - ;FBAAFSR +FBAAFSR ;WCIOFO/TCK,SS,DMK,SAB-RBRVS FEE SCHEDULE ; 8/26/1999 + ;;3.5;FEE BASIS;**4,53,71,84,92,93,99,102**;JAN 30, 1995;Build 24 + ; + Q + ; +RBRVS(CPT,MODL,DOS,ZIP,FAC,TIME) ; calculate RBRVS Fee Schedule amount + ; Input + ; CPT = CPT/HCPCS code (external value) + ; MODL = list of CPT/HCPCS modifiers (external values) + ; delimited by commas (e.g. "26,51") + ; DOS = date of service (fileman format e.g. 2980101) + ; ZIP = ZIP code of service (external 5 digit value) + ; FAC = facility flag =1 if site of service is facility setting + ; TIME = time in minutes, only passed on anesthesia CPT codes + ; Returns string + ; dollar amount^sched year OR null value if not on RBRVS schedule + ; Output + ; FBERR( array of error messages OR undefined if none + ; + N FBAMT,FBCF,FBCPT0,FBCPTY0,FBCY,FBERR,FBGPCIY0 + ; + ; initialization + S FBAMT="" + K FBERR + ; + ; check for required input parameters + I $G(CPT)="" D ERR^FBAAFS("CPT missing") + I $G(DOS)'?7N D ERR^FBAAFS("Date of Service missing") + I $D(FBERR) Q FBAMT + ; + ;if date of service prior to VA implementation, don't use RBRVS + I DOS<2990901 Q FBAMT + ; + ;if modifier SG present, don't use RBRVS, patch FB*3.5*84 + I MODL["SG" Q FBAMT + ; + ; determine schedule calendar year based on date of service + S FBCY=$E(DOS,1,3)+1700 + ; + ;If date of service in 2003 but prior to Mar 1, 2003 treat as 2002 + I $E(DOS,1,3)=303,DOS<3030301 S FBCY=FBCY-1 + ; + ; if year after most recent RBRVS schedule then use prior year schedule + I FBCY>$$LASTCY() S FBCY=FBCY-1 + ; + ; get procedure data from schedule for year + D PROC(CPT,MODL,FBCY) + ; + ; if procedure: + ; - covered + ; - payable + ; - not for anesthesia + ; then calculate amount + I FBCPTY0]"",'$$ANES^FBAAFS(CPT) D + . ; + . ;validate parameters + . I $G(ZIP)="" D ERR^FBAAFS("Missing ZIP Code") + . I $G(FAC)="" D ERR^FBAAFS("Missing Facility Flag") + . I $D(FBERR) Q + . ; + . ; get GPCIs for calendar year + . D ZIP(FBCY,ZIP) + . I FBGPCIY0="" D ERR^FBAAFS("Could not determine GPCIs") Q + . ; + . ; get conversion factor + . S FBCF=$$CF(FBCY,$P(FBCPT0,U,2)) + . I FBCF="" D ERR^FBAAFS("Could not determine the conversion factor") Q + . ; + . ; calculate full schedule amount + . D CALC(FBCY,FAC,FBCPTY0,FBGPCIY0,FBCF) + . ; + . ; apply multiplier based on modifier + . I MODL]"" S FBAMT=FBAMT*$$MULT(FBCY,MODL,FBCPT0,FBCPTY0) + ; + ; return result + Q $S(FBAMT>0:$J(FBAMT,0,2)_U_FBCY,1:"") + ; +PROC(CPT,MODL,FBCY,FBNONPBL) ; get procedure data for RBRVS schedule + ; Input + ; CPT = CPT/HCPCS code (external value) + ; MODL = list of CPT/HCPCS modifiers (external value) + ; delimited by commas + ; FBCY = calendar year (4 digit) + ; FBNONPBL ( optional): + ; if $G(FBNONPBL)=0 then will make search among payable records only in #162.97 + ; ignoring those non-payable ones with field #.08 NONPAYABLE = 1 + ; if $G(FBNONPBL)=1 then will make search among all items in #162.97 + ; + ; Output + ; FBCPT0 = zero node from file 162.97 OR "" if not covered + ; FBCPTY0 = zero node from subfile 162.971 or "" if not covered + N CPTM,MOD,FBI + S (FBCPT0,FBCPTY0)="" + Q:$G(FBCY)']""!($G(CPT)']"") + ; + ; if modifier exists try to find entry with modifier + I MODL]"" D + . F FBI=1:1 S MOD=$P(MODL,",",FBI) Q:MOD="" D Q:FBCPTY0]"" + . . S CPTM=CPT_"-"_MOD + . . D PROC1(CPTM,FBCY,$G(FBNONPBL)) + ; + ; if not found with modifier, try just CPT code + I FBCPTY0="" D PROC1(CPT,FBCY,$G(FBNONPBL)) + ; + Q + ; +PROC1(CPTM,FBCY,FBNONPBL) ; get procedure data for CPT-Modifier + ; input + ; CPTM - CPT Code - Modifier (e.g. 57335-TC or 57335) + ; FBCY - 4 digit calendar year + ; FBNONPBL ( optional): + ; if $G(FBNONPBL)=0 then will make search among payable records only in #162.97 + ; ignoring those non-payable ones with field #.08 NONPAYABLE = 1 + ; if $G(FBNONPBL)=1 then will make search among all items in #162.97 + ; output + ; FBCPT0 = zero node from file 162.97 OR "" if not covered + ; FBCPTY0 = zero node from subfile 162.971 or "" if not covered + N FBDA,FBDA1 + S (FBCPT0,FBCPTY0)="" + S FBDA=$O(^FB(162.97,"B",CPTM,0)) + S FBDA1=$S(FBDA:$O(^FB(162.97,FBDA,"CY","B",FBCY,0)),1:"") + I $G(FBDA),$G(FBDA1) D + . N FBI,FBSUM,FBY + . S FBY=$G(^FB(162.97,FBDA,"CY",FBDA1,0)) + . ;if non-payable records should not be considered + . ;then quit if this is NONPAYBLE + . I +$G(FBNONPBL)=0 Q:$P(FBY,U,8)=1 + . ; check if procedure covered by schedule + . I +$G(FBNONPBL)=0,$$ANES^FBAAFS($P(CPTM,"-")),$P(FBY,U,6)']"" Q ; missing anes base + . I +$G(FBNONPBL)=0,'$$ANES^FBAAFS($P(CPTM,"-")) D I FBSUM'>0 Q ; sum of RVUs = 0 + . . S FBSUM=0 F FBI=3,4,5,6 S FBSUM=FBSUM+$P(FBY,U,FBI) + . ; passed checks + . S FBCPTY0=FBY + . S FBCPT0=$G(^FB(162.97,FBDA,0)) + Q + ; +ZIP(FBCY,ZIP) ; get GPCIs + ; Input + ; FBCY = calendar year (4 digit) + ; ZIP = zip code (5 digit external value) + ; Output + ; FBGPCIY0 = zero node from file 162.96 or "" if not found + S FBGPCIY0="" + Q:$G(FBCY)']""!($G(ZIP)']"") + N FBDA,FBDA1 + S FBDA=$O(^FB(162.96,"B",ZIP,0)) + S FBDA1=$S(FBDA:$O(^FB(162.96,FBDA,"CY","B",FBCY,0)),1:"") + I FBDA,FBDA1 S FBGPCIY0=$G(^FB(162.96,FBDA,"CY",FBDA1,0)) + Q + ; +CF(FBCY,FBDA) ; get conversion factor + ; Input + ; FBCY = calendar year + ; FBDA = optional conversion category (internal) + ; Returns + ; conversion factor from file 162.99 + N FBCF,FBDA1 + I '$G(FBDA) S FBDA=4 ; use Medicine category if not specified + S FBDA1=$O(^FB(162.99,FBDA,"CY","B",FBCY,0)) + S FBCF=$S(FBDA1:$P($G(^FB(162.99,FBDA,"CY",FBDA1,0)),U,2),1:"") + Q +FBCF + ; +CALC(FBCY,FAC,FBCPTY0,FBGPCIY0,FBCF) ; + ; Input + ; FBCY = calendar year (4 digit) + ; FAC = facility flag (0 or 1) + ; FBCPTY0 = zero node from file 162.71 + ; FBGPCI0 = zero node from file 162.61 + ; FBCF = conversion factor (number) + ; Returns $ amount + ; + N GPCI,RVU,FBI,TMP,TMPRVU + S FBAMT=0 + ;Multiply Work RVU by the Budget Neutrality Adjustor (0.8994) + I DOS<3070101 D + .;Old formula for RBRVS pre-2007 payment amounts + .S RVU(1)=$P(FBCPTY0,U,3) + I DOS>3061231 D + .;New formula for RBRVS 2007 payment amounts + .;Multiply Work RVU by the Budget Neutrality Adjustor (0.8994) + .S TMP=$P(FBCPTY0,U,3),TMPRVU=$J((TMP*(.8994)),".",2) + .S RVU(1)=TMPRVU + S RVU(2)=$P(FBCPTY0,U,4+FAC) + S RVU(3)=$P(FBCPTY0,U,6) + F FBI=2,3,4 S GPCI(FBI-1)=$P(FBGPCIY0,U,FBI) + S FBAMT=((RVU(1)*GPCI(1))+(RVU(2)*GPCI(2))+(RVU(3)*GPCI(3)))*FBCF + ; some procedures can't be performed in a facility setting by + ; definition. the facility PE RVU for such a procedure is a null + ; value. + ; when facility setting - check for a null PE value and don't return amt + I RVU(2)="",FAC S FBAMT=0 Q + Q + ; +MULT(FBCY,MODL,FBCPT0,FBCPTY0) ;returns multiplier based on table type + ; Input + ; FBCY = calendar year (4 digit) + ; MODL = list of CPT/HCPCS modifiers (external values) + ; delimited by commas + ; FBCPT0 = zero node of file 162.7 for procedure + ; FBCPTY0 = zero node of subfile 162.71 for year + ; Returns + ; multiplier value OR 1 if none + N FBDA,FBDA1,FBI,FBML,FBPD,FBRET,FBTBL,MOD + S FBRET=1 + S FBML=$P(FBCPTY0,U,2) ; mod level table for procedure + I MODL]"",FBML]"",FBCY]"" D + . S FBTBL=FBCY_"-"_FBML ; mod level table for year + . S FBDA=$O(^FB(162.98,"B",FBTBL,0)) + . Q:'FBDA ; table not found + . ; loop thru the modifiers + . F FBI=1:1 S MOD=$P(MODL,",",FBI) Q:MOD="" D + . . I $P($P(FBCPT0,U),"-",2)=MOD Q ; modifier already built in schedule + . . ; look up modifier in mod level table + . . S FBDA1=$O(^FB(162.98,FBDA,"M","B",MOD,0)) + . . Q:'FBDA1 ; modifier not found in table + . . S FBPD=$P($G(^FB(162.98,FBDA,"M",FBDA1,0)),U,2) ; percentage + . . I FBPD>0 S FBRET=FBRET*(FBPD/100) ; multiplier + Q FBRET + ; +LASTCY() ; Determine last calendar year of RBRVS FEE schedule data + ; based on last year for Medicine conversion factor + N YEAR + S YEAR=$O(^FB(162.99,4,"CY","B"," "),-1) + Q YEAR + ;FBAAFSR diff --git a/r/FEE_BASIS-FB/FBCH78.m b/r/FEE_BASIS-FB/FBCH78.m index 1dca7291..c68b3ed0 100644 --- a/r/FEE_BASIS-FB/FBCH78.m +++ b/r/FEE_BASIS-FB/FBCH78.m @@ -1,98 +1,56 @@ -FBCH78 ;AISC/DMK-SETS UP 7078/AUTHORIZATION FOR CONTRACT HOSPITAL ;08/07/02 - ;;3.5;FEE BASIS;**43,103**;JAN 30, 1995;Build 19 - ;;Per VHA Directive 2004-038, this routine should not be modified. - S DIC("S")="I $P(^(0),U,15)=3&($P(^(0),U,12)=""Y"")" D ASKV^FBCHREQ G END:$E(X)="^"!($E(X)="")!('$D(FBDA)) - I $P(^FBAA(162.2,FBDA,0),"^",17)]"" W !!,*7,"There already is a 7078 set up for this request.",!,"The number is ",$P(^FB7078($P(^FBAA(162.2,FBDA,0),"^",17),0),"^")," .",! G END -EN S FBVEN=$P(^FBAA(162.2,FBDA,0),"^",2)_";FBAAV(",FBVET=$P(^(0),"^",4),FBFRDT=$P(^(0),"^",5),FBFRDT=FBFRDT\1,FBDOA=$S($P(^(0),"^",19):$P(^(0),"^",19)\1,1:""),FBDXS=$P(^(0),"^",6) - ;FB*3.5*103 ;added FBRP - S FBRP=$P($G(^FBAA(162.2,FBDA,2)),"^") K DA - W !! S %DT="APEX",%DT("A")="AUTHORIZATION TO DATE: " D ^%DT K %DT G END:X="^" S FBTODT=$S(X="":"",1:Y) - I FBTODT]"",FBFRDT>FBTODT W !!,*7,?5,"Authorization To Date must be after Authorization From Date!",! G EN - W !! S %DT="APEX",%DT("A")="DATE OF DISCHARGE: ",%DT("B")=$$DATX^FBAAUTL(FBTODT) D ^%DT K %DT G END:X="^" S FBDOD=$S(X="":"",1:Y) - I FBDOD]"",FBTODT>FBDOD W !!,*7,?5,"Date of Discharge must not be earlier than the Authorization To Date!",! G EN - S DIR(0)="162.4,5",DIR("A")="ADMITTING AUTHORITY" D ^DIR K DIR - G END:$D(DIRUT) S FBADMIT=+Y - S DIR(0)="162.4,6" D ^DIR K DIR - G END:$D(DIRUT) S FBEST=+Y -FBPDIS I FBTODT="" S DIR(0)="162.4,12" D ^DIR K DIR G END:$D(DUOUT),END:$D(DTOUT),NULL^FBCH780:X="" S FBPDIS=+Y - ; -ASKPT I FBTODT]"" S DIR(0)="SAO^00:SURGICAL;10:MEDICAL;86:PSYCHIATRY",DIR("A")="BEDSECTION/TREATING SPECIALTY: ",DIR("?")="^D HELP^FBCH780" D ^DIR K DIR D NOUP^FBCHCD:$D(DIRUT) G ASKPT:$D(DIRUT) S FBPT=Y -7078 S PRCS("A")="Select Obligation Number: ",PRCS("TYPE")="FB" D EN1^PRCS58 G:Y=-1 NOGOOD S (X,FBCHOB)=$P(Y,"^",2) K PRCS("A") S PRCS("TYPE")="FB" D EN1^PRCSUT31 G:Y="" NOGOOD S FB7078=$P(FBCHOB,"-",2)_"."_Y S FBSEQ=Y - S DIC="^FB7078(",DIC(0)="LQ",DLAYGO=162.4,X=""""_FB7078_"""" D ^DIC G:Y<0 PROB S (DA,FBAA78)=+Y - S DIE="^FBAA(162.2,",DA=FBDA,DR="16////^S X=FBAA78" D ^DIE K DIE,DIC,DA,DR -SET78 S DIE="^FB7078(",DA=FBAA78,DR="[FBCH ENTER 7078]" D ^DIE K DIC,DIE,DR,DA - D ^FBCH780 I $G(FBOUT) W !!,*7,"...deleting 7078." D DEL G END - I +Y=0 W !!,*7,Y,!,"...deleting 7078. Use 'Set-up a 7078' after adjusting 1358.",! D DEL G END - K DIE,DIC,DA - I $G(FBVET) S:'$G(DFN) DFN=FBVET D PTF^FBCH780 - G SHOW:FBTODT="" -AUTH D HOME^%ZIS - D:'$D(FBSITE(1)) SITEP^FBAAUTL Q:FBPOP S FBPSA=$S($P(FBSITE(1),"^",3)="":"",$D(^DIC(4,$P(FBSITE(1),"^",3),0)):$P(^(0),"^"),1:"") - S FBVEN=$P(FBVEN,";") - I '$D(^FBAAA(FBVET,0)) L +^FBAAA(FBVET) K DD,DO S (X,DINUM)=FBVET,DIC="^FBAAA(",DIC(0)="LM",DLAYGO=161 D FILE^DICN L -^FBAAA(FBVET) G:Y<0 END - S:'$D(^FBAAA(FBVET,1,0)) ^(0)="^161.01D^^" - K DE,DQ,DR,DIE,DLAYGO -FBDCHG S DIR(0)="161.01,.06" D ^DIR K DIR G END:$D(DTOUT),END:$D(DUOUT) D NULL1^FBCH780:X="" G FBDCHG:X="" S FBDCHG=+Y -FBPUR S FBTYPE=6,DIR(0)="161.01,.07" D ^DIR K DIR S FBPUR=+Y - G END:$D(DTOUT),END:$D(DUOUT) -FBPSA S DIR(0)="161.01,101" D ^DIR K DIR G END:$D(DTOUT),END:$D(DUOUT) D NULL1^FBCH780:X="" G FBPSA:X="" S FBPSA=+Y - ;file entry in authorization multiple of file 161 - S DIC="^FBAAA("_FBVET_",1,",DIC(0)="LM",DLAYGO=161,DA(1)=FBVET,X=FBFRDT K DD,DO D FILE^DICN G:Y<0 END S DA=+Y,DIE("NO^")="" ;DA(1)=FBVET - S FB78=FBAA78_";FB7078(" - ;FB*3.5*103 ;added FBRP - S DIE=DIC,DR=".02////^S X=FBTODT;.03////^S X=6;100////^S X=DUZ;1////^S X=""YES"";.055////^S X=FB78;.06////^S X=FBDCHG;S FBTYPE=6;.04////^S X=FBVEN;.065////^S X=FBPT;101////^S X=FBPSA" - S:$G(FBRP)]"" DR=DR_";104////^S X=FBRP" - S DR=DR_";.095////^S X=1" - S DR(1,161.01,1)="I $D(^FB7078(FBAA78,1,0)) S ^FBAAA(DA(1),1,DA,2,0)=^(0) F FBI=1:1 Q:'$D(^FB7078(FBAA78,1,FBI,0)) I $D(^(0)) S ^FBAAA(DA(1),1,DA,2,FBI,0)=^(0);.07////^S X=FBPUR;.08///^S X=FBDXS;.096;.097//^S X=""N""" - D ^DIE K DIE,DR - S (DIC,DIE)="^FB7078(",DA=FBAA78,DR="9///^S X=""C"";12///^S X=""@""" D ^DIE K DR,DIE,DA,X -SHOW W !! S DA=FBAA78,DR="0;1",DIC="^FB7078(" D EN^DIQ - ; - ;FB*3.5*103 ;added FBRP -END K D,DA,DIC,DIE,DIR,DLAYGO,DR,FBDA,FB7078,FBAA78,FBPT,FBTYPE,FBVEN,FBZ,FBVET,FBFRDT,FBTODT,J,S,POP,X,Y,DFN,FBCHOB,FBCOMM,FBDFN,FBEST,FBI,FBLENT,FBMENT,FBNAME,FBSEQ,FBSSN,FBSW,I,K,PRC,VAL,FB,FBFLG,ZZ,FBPSA,FBSITE,FB78,FBOUT - K FBDCHG,FBPUR,FBPDIS,FBADMIT,FBDXS,A,D0,D1,X1,DIRUT,DTOUT,DUOUT,FBDOA,FBDOD,FBPOP,FBZZ,ZZZ,PRCSCPAN,FBRP - Q -PROB W !!,"The reference number did not get set up with the",!,"IFCAP software. Contact your package coordinator." G END -NOGOOD S DIR(0)="Y",DIR("A")="Obligation number selected is invalid or you are not a control point user in the IFCAP package! Try again",DIR("B")="YES" D ^DIR K DIR G END:$D(DIRUT)!'Y,7078 - ; -OUTP ;ENTRY TO DISPLAY A 7078 - ;FB*3.5*103 ; Display the 0 node fields with computed REFERRING PROVIDER NPI, then 1 node fields - S DIC="^FB7078(",DIC(0)="AEQM",D="D",DIC("A")="Select Patient: " D IX^DIC - G END:X=""!(X="^") - S (DA,FBDA)=+Y,DR="0",DIQ(0)="C" W !! D EN^DIQ K DIQ(0) - S DA=FBDA,DR="1" D EN^DIQ - I $$DISCH^FBCH780(FBDA)]"" W ?2,"DISCHARGE TYPE: ",$$DISCH^FBCH780(FBDA),! - G OUTP - ; -REFNPI(IEN200,IEN162P4,CHKAUTH) ;FB*3.5*103 - ; a new function that returns the REFERRING PROVIDER NPI if it is Active and the provider has authorized use of the NPI - ; If is used in both a Fileman function and in other FB routines. - ; - ; Input - ; IEN200 - IEN to file 200 if known - ; IEN162P4 (optional) - IEN to File 162.4 (if ref prov is not known) - ; CHKAUTH (optional) - Flag on whether to Chek Authorization in file 200 - ; - ; Output - ; A valid/active NPI if one can be determined. Otherwise, nada. - ; - ; If neither IEN is passed in, there is no NPI coming out - I $G(IEN200)<1,$G(IEN162P4)<1 Q "" - ; - ; If there is no referrring provider IEN passed in, try getting it from the IEN from 162.4 (VA FORM 10-7078) - ; return nothing if you can't - I $G(IEN200)<1 S IEN200=$$GET1^DIQ(162.4,IEN162P4_",",15,"I") Q:$G(IEN200)<1 "" - ; - ; Now that we have an IEN to 200 see if we need authorization and have to display/print NPI - ; If the return value is less than 1, then we don't have permission or it was not a valid IEN. - ; IA#5070 - I $G(CHKAUTH) Q:+$$GETRLNPI^XUSNPI(IEN200)<1 "" - ; - ; Go get the NPI for this IEN - N NPI S NPI=$$NPI^XUSNPI("Individual_ID",IEN200) - ; - ; Make sure it is a valid/Active NPI - I +NPI<1!($P(NPI,U,3)="Inactive") Q "" - Q +NPI - ; -DEL S DA=FBAA78,DIK="^FB7078(" D ^DIK K DIK S DA=$O(^FBAA(162.2,"AM",+FBAA78,0)) I DA S DIE="^FBAA(162.2,",DR="16///@" D ^DIE +FBCH78 ;AISC/DMK-SETS UP 7078/AUTHORIZATION FOR CONTRACT HOSPITAL ;08/07/02 + ;;3.5;FEE BASIS;**43**;JAN 30, 1995 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + S DIC("S")="I $P(^(0),U,15)=3&($P(^(0),U,12)=""Y"")" D ASKV^FBCHREQ G END:$E(X)="^"!($E(X)="")!('$D(FBDA)) + I $P(^FBAA(162.2,FBDA,0),"^",17)]"" W !!,*7,"There already is a 7078 set up for this request.",!,"The number is ",$P(^FB7078($P(^FBAA(162.2,FBDA,0),"^",17),0),"^")," .",! G END +EN S FBVEN=$P(^FBAA(162.2,FBDA,0),"^",2)_";FBAAV(",FBVET=$P(^(0),"^",4),FBFRDT=$P(^(0),"^",5),FBFRDT=FBFRDT\1,FBDOA=$S($P(^(0),"^",19):$P(^(0),"^",19)\1,1:""),FBDXS=$P(^(0),"^",6) K DA + W !! S %DT="APEX",%DT("A")="AUTHORIZATION TO DATE: " D ^%DT K %DT G END:X="^" S FBTODT=$S(X="":"",1:Y) + I FBTODT]"",FBFRDT>FBTODT W !!,*7,?5,"Authorization To Date must be after Authorization From Date!",! G EN + W !! S %DT="APEX",%DT("A")="DATE OF DISCHARGE: ",%DT("B")=$$DATX^FBAAUTL(FBTODT) D ^%DT K %DT G END:X="^" S FBDOD=$S(X="":"",1:Y) + I FBDOD]"",FBTODT>FBDOD W !!,*7,?5,"Date of Discharge must not be earlier than the Authorization To Date!",! G EN + S DIR(0)="162.4,5",DIR("A")="ADMITTING AUTHORITY" D ^DIR K DIR + G END:$D(DIRUT) S FBADMIT=+Y + S DIR(0)="162.4,6" D ^DIR K DIR + G END:$D(DIRUT) S FBEST=+Y +FBPDIS I FBTODT="" S DIR(0)="162.4,12" D ^DIR K DIR G END:$D(DUOUT),END:$D(DTOUT),NULL^FBCH780:X="" S FBPDIS=+Y + ; +ASKPT I FBTODT]"" S DIR(0)="SAO^00:SURGICAL;10:MEDICAL;86:PSYCHIATRY",DIR("A")="BEDSECTION/TREATING SPECIALTY: ",DIR("?")="^D HELP^FBCH780" D ^DIR K DIR D NOUP^FBCHCD:$D(DIRUT) G ASKPT:$D(DIRUT) S FBPT=Y +7078 S PRCS("A")="Select Obligation Number: ",PRCS("TYPE")="FB" D EN1^PRCS58 G:Y=-1 NOGOOD S (X,FBCHOB)=$P(Y,"^",2) K PRCS("A") S PRCS("TYPE")="FB" D EN1^PRCSUT31 G:Y="" NOGOOD S FB7078=$P(FBCHOB,"-",2)_"."_Y S FBSEQ=Y + S DIC="^FB7078(",DIC(0)="LQ",DLAYGO=162.4,X=""""_FB7078_"""" D ^DIC G:Y<0 PROB S (DA,FBAA78)=+Y + S DIE="^FBAA(162.2,",DA=FBDA,DR="16////^S X=FBAA78" D ^DIE K DIE,DIC,DA,DR +SET78 S DIE="^FB7078(",DA=FBAA78,DR="[FBCH ENTER 7078]" D ^DIE K DIC,DIE,DR,DA + D ^FBCH780 I $G(FBOUT) W !!,*7,"...deleting 7078." D DEL G END + I +Y=0 W !!,*7,Y,!,"...deleting 7078. Use 'Set-up a 7078' after adjusting 1358.",! D DEL G END + K DIE,DIC,DA + I $G(FBVET) S:'$G(DFN) DFN=FBVET D PTF^FBCH780 + G SHOW:FBTODT="" +AUTH D HOME^%ZIS + D:'$D(FBSITE(1)) SITEP^FBAAUTL Q:FBPOP S FBPSA=$S($P(FBSITE(1),"^",3)="":"",$D(^DIC(4,$P(FBSITE(1),"^",3),0)):$P(^(0),"^"),1:"") + S FBVEN=$P(FBVEN,";") + I '$D(^FBAAA(FBVET,0)) L +^FBAAA(FBVET) K DD,DO S (X,DINUM)=FBVET,DIC="^FBAAA(",DIC(0)="LM",DLAYGO=161 D FILE^DICN L -^FBAAA(FBVET) G:Y<0 END + S:'$D(^FBAAA(FBVET,1,0)) ^(0)="^161.01D^^" + K DE,DQ,DR,DIE,DLAYGO +FBDCHG S DIR(0)="161.01,.06" D ^DIR K DIR G END:$D(DTOUT),END:$D(DUOUT) D NULL1^FBCH780:X="" G FBDCHG:X="" S FBDCHG=+Y +FBPUR S FBTYPE=6,DIR(0)="161.01,.07" D ^DIR K DIR S FBPUR=+Y + G END:$D(DTOUT),END:$D(DUOUT) +FBPSA S DIR(0)="161.01,101" D ^DIR K DIR G END:$D(DTOUT),END:$D(DUOUT) D NULL1^FBCH780:X="" G FBPSA:X="" S FBPSA=+Y + ;file entry in authorization multiple of file 161 + S DIC="^FBAAA("_FBVET_",1,",DIC(0)="LM",DLAYGO=161,DA(1)=FBVET,X=FBFRDT K DD,DO D FILE^DICN G:Y<0 END S DA=+Y,DIE("NO^")="" ;DA(1)=FBVET + S FB78=FBAA78_";FB7078(" + S DIE=DIC,DR=".02////^S X=FBTODT;.03////^S X=6;100////^S X=DUZ;1////^S X=""YES"";.055////^S X=FB78;.06////^S X=FBDCHG;S FBTYPE=6;.04////^S X=FBVEN;.065////^S X=FBPT;101////^S X=FBPSA;.095////^S X=1" + S DR(1,161.01,1)="I $D(^FB7078(FBAA78,1,0)) S ^FBAAA(DA(1),1,DA,2,0)=^(0) F FBI=1:1 Q:'$D(^FB7078(FBAA78,1,FBI,0)) I $D(^(0)) S ^FBAAA(DA(1),1,DA,2,FBI,0)=^(0);.07////^S X=FBPUR;.08///^S X=FBDXS;.096;.097//^S X=""N""" + D ^DIE K DIE,DR + S (DIC,DIE)="^FB7078(",DA=FBAA78,DR="9///^S X=""C"";12///^S X=""@""" D ^DIE K DIE,DIE,DA,X +SHOW W !! S DA=FBAA78,DR="0;1",DIC="^FB7078(" D EN^DIQ + ; +END K D,DA,DIC,DIE,DIR,DLAYGO,DR,FBDA,FB7078,FBAA78,FBPT,FBTYPE,FBVEN,FBZ,FBVET,FBFRDT,FBTODT,J,S,POP,X,Y,DFN,FBCHOB,FBCOMM,FBDFN,FBEST,FBI,FBLENT,FBMENT,FBNAME,FBSEQ,FBSSN,FBSW,I,K,PRC,VAL,FB,FBFLG,ZZ,FBPSA,FBSITE,FB78,FBOUT + K FBDCHG,FBPUR,FBPDIS,FBADMIT,FBDXS,A,D0,D1,X1,DIRUT,DTOUT,DUOUT,FBDOA,FBDOD,FBPOP,FBZZ,ZZZ,PRCSCPAN + Q +PROB W !!,"The reference number did not get set up with the",!,"IFCAP software. Contact your package coordinator." G END +NOGOOD S DIR(0)="Y",DIR("A")="Obligation number selected is invalid or you are not a control point user in the IFCAP package! Try again",DIR("B")="YES" D ^DIR K DIR G END:$D(DIRUT)!'Y,7078 + ; +OUTP ;ENTRY TO DISPLAY A 7078 + S DIC="^FB7078(",DIC(0)="AEQM",D="D",DIC("A")="Select Patient: " D IX^DIC G END:X=""!(X="^") S (DA,FBDA)=+Y,DR="0;1" W !! D EN^DIQ + I $$DISCH^FBCH780(FBDA)]"" W ?2,"DISCHARGE TYPE: ",$$DISCH^FBCH780(FBDA),! + G OUTP +DEL S DA=FBAA78,DIK="^FB7078(" D ^DIK K DIK S DA=$O(^FBAA(162.2,"AM",+FBAA78,0)) I DA S DIE="^FBAA(162.2,",DR="16///@" D ^DIE diff --git a/r/FEE_BASIS-FB/FBCH78A.m b/r/FEE_BASIS-FB/FBCH78A.m index e501d0eb..611023fa 100644 --- a/r/FEE_BASIS-FB/FBCH78A.m +++ b/r/FEE_BASIS-FB/FBCH78A.m @@ -1,33 +1,28 @@ -FBCH78A ;AISC/DMK-PRINT 7078 CONTINUED FROM FBCHP78 ;06FEB89 - ;;3.5;FEE BASIS;**103**;JAN 30, 1995;Build 19 - ;;Per VHA Directive 2004-038, this routine should not be modified. -HED W:'$G(FBPG) @IOF K:$G(FBPG) FBPG W UL,!,?5,"Department of Veterans Affairs",?58,"AUTHORIZATION AND INVOICE FOR MEDICAL AND HOSPITAL SERVICES",!,UL,! - Q -BOT W !,"SPECIAL PROVISIONS: Acceptance of this authorization to render service is governed by the following:",!! - W "1. ACCEPTANCE OF THIS AUTHORIZATION AND PROVIDING OF SUCH TREATMENT OR SERVICES SUBJECTS YOU, THE PROVIDER OF CARE, TO",!,?3,"THE PROVISIONS OF PUBLIC LAW 93-579, THE PRIVACY ACT OF 1974, TO THE EXTENT OF THE RECORDS " - W "PERTAINING TO THE VA",!,?3,"AUTHORIZED TREATMENT OR SERVICES OF THIS VETERAN.",! - W !,"2. Fees or rates listed represent maximum allowance for services specified. In no event should charges be made to the",!,?3,"VA in excess of usual and customary charges to the general public for similar services.",! - W !,"3. Payment by the VA is payment in full for authorized services rendered.",! - W !,"4. Unless otherwise approved by the VA, services are limited in type and extent to those shown on this authorization.",!,?3,"If services are not initiated for any reason, return a copy of the authorization to the issuing ",! - W ?3,"office with a brief explanation.",! - W !,"5. A copy of the Operative Report will be forwarded to the Authorizing station within one week following any major",!,?3,"surgery.",! - W !,"6. A copy of the hospital summary will be forwarded to the authorizing station within ten work days following the ",!,?3,"release of the patient from the hospital.",! - W !,"7. When submitting claims for payment you must include the NPI and Taxonomy Code of the rendering practitioner," - W !,?3,"and the NPI and Taxonomy Code of your organization. If, under the HIPAA NPI Final Rule" - W !,?3,"[http://www.cms.hhs.gov/NationalProvIdentStand], your organization is an ""atypical"" provider furnishing services such" - W !,?3,"as taxi, home and vehicle modifications, insect control, habilitation, and respite services and is therefore" - W !,?3,"ineligible for an NPI, it is important that you indicate ""Ineligible for NPI"" on your claim form.",! - W UL,!,?16,"All questions relating to this authorization should be referred to the issuing VA Office",!,UL,!,"VA Form 10-7078" Q - ; -FISCAL ;SETS THE FISCAL SYMBOL BLOCK FOR 7078 - S PRC("SITE")=FB("SITE"),PRCS("X")=PRC("SITE")_"-"_$P($P(FB(0),"^"),"."),PRCS("TYPE")="FB" D EN1^PRCS58 - S FB("SYM")=$P(Y,"^",4)_" "_$P(FB(0),"^")_" FCP "_$P(Y,U,3) K PRC("SITE"),PRCSI,Y Q - ; -CONT(X,Y) ;get contract for CNH authorization - ;X=IEN of vendor - ;Y=from date of authorization - I $S('$G(X):1,'$G(Y):1,1:0) Q "" - I '$O(^FBAA(161.21,"ACR",X,-Y+.9)) Q "" - N Z - S Z=$P(^FBAA(161.21,+$O(^(+$O(^FBAA(161.21,"ACR",X,-Y+.9)),0)),0),U,1,3) - Q $S($P(Z,U,3)>Y:$P(Z,U),1:"") +FBCH78A ;AISC/DMK-PRINT 7078 CONTINUED FROM FBCHP78 ;06FEB89 + ;;3.5;FEE BASIS;;JAN 30, 1995 + ;;Per VHA Directive 10-93-142, this routine should not be modified. +HED W:'$G(FBPG) @IOF K:$G(FBPG) FBPG W UL,!,?5,"Department of Veterans Affairs",?58,"AUTHORIZATION AND INVOICE FOR MEDICAL AND HOSPITAL SERVICES",!,UL,! + Q +BOT W !,"SPECIAL PROVISIONS: Acceptance of this authorization to render service is governed by the following:",!! + W "1. ACCEPTANCE OF THIS AUTHORIZATION AND PROVIDING OF SUCH TREATMENT OR SERVICES SUBJECTS YOU, THE PROVIDER OF CARE, TO",!,?3,"THE PROVISIONS OF PUBLIC LAW 93-579, THE PRIVACY ACT OF 1974, TO THE EXTENT OF THE RECORDS " + W "PERTAINING TO THE VA",!,?3,"AUTHORIZED TREATMENT OR SERVICES OF THIS VETERAN.",! + W !,"2. Fees or rates listed represent maximum allowance for services specified. In no event should charges be made to the",!,?3,"VA in excess of usual and customary charges to the general public for similar services.",! + W !,"3. Payment by the VA is payment in full for authorized services rendered.",! + W !,"4. Unless otherwise approved by the VA, services are limited in type and extent to those shown on this authorization.",!,?3,"If services are not initiated for any reason, return a copy of the authorization to the issuing ",! + W ?3,"office with a brief explanation.",! + W !,"5. A copy of the Operative Report will be forwarded to the Authorizing station within one week following any major",!,?3,"surgery.",! + W !,"6. A copy of the hospital summary will be forwarded to the authorizing station within ten work days following the ",!,?3,"release of the patient from the hospital.",! + W UL,!,?16,"All questions relating to this authorization should be referred to the issuing VA Office",!,UL,!,"VA Form 10-7078" Q + ; +FISCAL ;SETS THE FISCAL SYMBOL BLOCK FOR 7078 + S PRC("SITE")=FB("SITE"),PRCS("X")=PRC("SITE")_"-"_$P($P(FB(0),"^"),"."),PRCS("TYPE")="FB" D EN1^PRCS58 + S FB("SYM")=$P(Y,"^",4)_" "_$P(FB(0),"^")_" FCP "_$P(Y,U,3) K PRC("SITE"),PRCSI,Y Q + ; +CONT(X,Y) ;get contract for CNH authorization + ;X=IEN of vendor + ;Y=from date of authorization + I $S('$G(X):1,'$G(Y):1,1:0) Q "" + I '$O(^FBAA(161.21,"ACR",X,-Y+.9)) Q "" + N Z + S Z=$P(^FBAA(161.21,+$O(^(+$O(^FBAA(161.21,"ACR",X,-Y+.9)),0)),0),U,1,3) + Q $S($P(Z,U,3)>Y:$P(Z,U),1:"") diff --git a/r/FEE_BASIS-FB/FBCHP78.m b/r/FEE_BASIS-FB/FBCHP78.m index 1c9b44f3..4d1df376 100644 --- a/r/FEE_BASIS-FB/FBCHP78.m +++ b/r/FEE_BASIS-FB/FBCHP78.m @@ -1,58 +1,55 @@ -FBCHP78 ;AISC/DMK-GENERATE 7078 ;7/NOV/2006 - ;;3.5;FEE BASIS;**12,23,52,101,103**;JAN 30, 1995;Build 19 - ;;Per VHA Directive 2004-038, this routine should not be modified. - I '$D(^FBAA(161.4,1,0)) W !,"Site Parameters must be entered prior",!," to using this option." Q -GET78 S DIC="^FB7078(",DIC(0)="AEQMZ",DIC("A")="Select Veteran: ",D="D",DIC("S")="I $P(^(0),U,9)'=""DC""" D IX^DIC G END:X="^"!(X=""),GET78:Y<0 S FB7078=+Y,FB(0)=Y(0) K DIC,D - S DA=FB7078,DIC="^FB7078(",DR=0 D EN^DIQ -ASK S DIR(0)="Y",DIR("A")="Is this the correct 7078",DIR("B")="YES" D ^DIR K DIR G END:$D(DIRUT),GET78:'Y - D SITEP^FBAAUTL S FBO=$S($D(FBSITE(1)):$P(FBSITE(1),"^",7),1:""),FBNUM=$S($D(FBSITE(1)):$P(FBSITE(1),"^",5),1:"") - S FBT=$S($D(FBSITE(1)):$P(FBSITE(1),"^",8),1:"") - D FBO G END:$D(DIRUT) - S PRCF("X")="S" D ^PRCFSITE S PRC("SITE")=$S($D(PRC("SITE")):PRC("SITE"),1:"") I PRC("SITE")="" W ! G GET78 - S FB("SITE")=PRC("SITE") -QUE S VAR="FB7078^FBNUM^FBO^FBT^FB(""SITE"")",VAL=FB7078_"^"_FBNUM_"^"_FBO_"^"_FBT_"^"_FB("SITE"),PGM="START^FBCHP78" D ZIS^FBAAUTL G:FBPOP END - ; -START S FB(0)=^FB7078(FB7078,0) S:$E(IOST,1,2)'["C-" FBPG=1 F FBM=1:1:FBNUM D 7078 -END K DA,DFN,DIC,DINAME,DIRUT,DIWF,DIWL,DR,FB,FB7078,FBFD,FBID,FBNM,FBNUM,FBO,FBRR,FBSITE,FBTD,FBV,FBVEN,FBT,I,L,FBM,PGM,S,UL,VA,VADM,VAEL,VAERR,VAL,VAPA,VAR,X,Y,Z,PRC,PRCS,^UTILITY($J),PRCSCPAN - D CLOSE^FBAAUTL Q - ; -7078 U IO S UL="",$P(UL,"-",120)="-",L="|" D HED^FBCH78A - S DFN=$P(^FB7078(FB7078,0),"^",3) G END:'$D(DFN)#2!('$D(^DPT(+DFN,0))) - N FBNAME - S FBNAME("FILE")=2,FBNAME("IENS")=DFN_",",FBNAME("FIELD")=.01 - S FBNAME=$$NAMEFMT^XLFNAME(.FBNAME,"F","C") - S VAPA("P")="" D SITEP^FBAAUTL,6^VADPT - N FBCONFAD S FBCONFAD=$$ACTIVECC^FBAACO0() I FBCONFAD,$L($G(VAPA(16))) D - . N FBLEN S FBLEN=$L(VAPA(16))+$L($P($G(VAPA(17)),U,2))+$L($P($G(VAPA(18)),U,2))+3 S:FBLEN>52 FBLEN=$L(VAPA(16))-(FBLEN-52),VAPA(16)=$E(VAPA(16),1,FBLEN) - F FBNM=1:1:7 S FBNM(FBNM)=$P(FBSITE(0),"^",FBNM) - S FBNM(5)=$S($D(^DIC(5,FBNM(5))):$P(^(FBNM(5),0),"^",2),1:"") - S Y=$P(FB(0),"^",10) D DATE S FBID=Y,FBVEN=$P(FB(0),"^",2),(FBVEN,FBV(0))=$P(FBVEN,";",1),FBVEN=$S($D(^FBAAV(FBVEN,0)):$P(^(0),"^",1),1:"Unknown"),FBVEN(1)=$S($D(^FBAAV(FBV(0),0)):$P(^(0),"^",2),1:"") - F I=3:1:6,14 S FBV(I)=$S($D(^FBAAV(FBV(0),0)):$P(^(0),"^",I),1:"") - I FBV(5)]"" S FBV(5)=$S($D(^DIC(5,FBV(5),0)):$P(^(0),"^",2),1:"") - S Y=$P(FB(0),"^",4) D DATE S FBFD=Y,Y=$S($P(FB(0),"^",5)]"":$P(FB(0),"^",5),1:"Disposition") D DATE:Y>0 S FBTD=Y - S FB(6)=$P(FB(0),"^",6) I FB(6)]"" S FB(6)=$S($D(^DIC(43.4,FB(6),0)):$P(^(0),"^",3),1:"") - W "Issuing Office",?66,L,"1. Date of Issue",!,?5,FBNM(1),?66,L,?70,FBID,!,?5,FBNM(2),?66,L,$E(UL,1,52),!,?5,$S(FBNM(3)]"":FBNM(3),1:FBNM(4)_", "_FBNM(5)_" "_FBNM(6)),?66,L,"2. Veteran's Name",! - I FBNM(3)]"" W ?5,FBNM(4)_", "_FBNM(5)_" "_FBNM(6) - W ?66,L,?70,FBNAME,!,UL,!,"Name of Physician or Station",?66,L,"3. Address",!,?5,FBVEN,?66,L,?68,$S(FBCONFAD:VAPA(13),1:VAPA(1)),!,?5,FBV(3),?66,L,?68,$S(FBCONFAD:VAPA(14),1:VAPA(2)),!,?5,FBV(14) - W ?66,L,?68,$S(FBCONFAD:VAPA(15),1:VAPA(3)),!?5,FBV(4)_", "_FBV(5)_" "_FBV(6) - W ?66,L,?68,$S(FBCONFAD:$G(VAPA(16)),1:VAPA(4))_", "_$S(FBCONFAD:$P($G(VAPA(17)),U,2),1:$P(VAPA(5),"^",2))_" "_$S(FBCONFAD:$P($G(VAPA(18)),U,2),'+$G(VAPA(11)):VAPA(6),$P(VAPA(11),U,2)]"":$P(VAPA(11),U,2),1:VAPA(6)),!?5,"ID#: ",FBVEN(1) - W ?66,L,$E(UL,1,53),!,?66,L,?68,"4. Veteran's Claim No.",?93,L,?95,"4A. SSN",!,?66,L,?68,VAEL(7),?93,L,?95,$$SSNL4^FBAAUTL($P(VADM(2),"^",2)),!,?66,L,$E(UL,1,53),!,?66,L,?75,"5. Authorization Valid",!,?66,L,$E(UL,1,53),! - ; next few lines contain changes that display/print the referring provider data FB*3.5*103 - W "Name of VA Referring Provider",?66,L,"From",?93,L,"To",! - W ?5,$$GET1^DIQ(162.4,FB7078_",",15),?50,"NPI: ",$$REFNPI^FBCH78("",FB7078,1) - W ?66,L,?68,FBFD,?93,L,?95,FBTD,!,UL,!,?45,"PART 1. - SERVICES AUTHORIZED",!,UL,!,"6. Services shown below are authorized for the period indicated in Item 5 above.",?104,L,?107,"7. Fee",! - W ?12,"(See Special Provisions below.)",?104,L,"$",! - S DIWL=1,DIWF="WC103" K ^UTILITY($J,"W") - I $D(^FB7078(FB7078,1,0)) F FBRR=0:0 S FBRR=$O(^FB7078(FB7078,1,FBRR)) Q:FBRR'>0 S FBXX=^(FBRR,0),X=FBXX D ^DIWP - D ^DIWW:$D(FBXX) K FBXX - D FISCAL^FBCH78A - W UL,!,"8. Fee Schedule or Contract",?33,L,"9. Authority",?66,L,"9A.",?93,L,"10. Estimated Amount",!?5,$$CONT^FBCH78A(+$P(FB(0),U,2),$P(FB(0),U,4)),?33,L,?35,FB(6),?66,L,?93,L,?95,"$" - K X2 S X=$P(FB(0),"^",7),X3=$L(+X)+2 D COMMA^%DTC K X3 W X,!,UL,! - W "11. Fiscal Symbols",?66,L,"12. Authorized by (Name and Title)",!,?5,FB("SYM"),?66,L,?68,FBO," ",FBT,!,UL - D BOT^FBCH78A - Q -DATE S Y=$$FMTE^XLFDT(Y) Q - ; -FBO S DIR(0)="F^3:45",DIR("A")="Approving Official for 7078",DIR("B")=FBO,DIR("?")="Enter to accept the default or enter a name from 3 to 45 characters in length" D ^DIR K DIR Q:$D(DIRUT) S FBO=X -FBT S DIR(0)="F^3:45",DIR("A")="Title of Approving Official",DIR("B")=FBT,DIR("?")="Enter to accept the default title or enter a title from 3 to 45 characters in length" D ^DIR K DIR Q:$D(DIRUT) S FBT=X -ASKN S DIR(0)="N^1:5",DIR("A")="# of copies of 7078",DIR("B")=FBNUM,DIR("?")="Select a number between 1 and 5. This number represents the number of copies of the 7078 you would like printed" D ^DIR K DIR Q:$D(DIRUT) S FBNUM=X +FBCHP78 ;AISC/DMK-GENERATE 7078 ;7/NOV/2006 + ;;3.5;FEE BASIS;**12,23,52,101**;JAN 30, 1995;Build 2 + ;;Per VHA Directive 2004-038, this routine should not be modified. + I '$D(^FBAA(161.4,1,0)) W !,"Site Parameters must be entered prior",!," to using this option." Q +GET78 S DIC="^FB7078(",DIC(0)="AEQMZ",DIC("A")="Select Veteran: ",D="D",DIC("S")="I $P(^(0),U,9)'=""DC""" D IX^DIC G END:X="^"!(X=""),GET78:Y<0 S FB7078=+Y,FB(0)=Y(0) K DIC,D + S DA=FB7078,DIC="^FB7078(",DR=0 D EN^DIQ +ASK S DIR(0)="Y",DIR("A")="Is this the correct 7078",DIR("B")="YES" D ^DIR K DIR G END:$D(DIRUT),GET78:'Y + D SITEP^FBAAUTL S FBO=$S($D(FBSITE(1)):$P(FBSITE(1),"^",7),1:""),FBNUM=$S($D(FBSITE(1)):$P(FBSITE(1),"^",5),1:"") + S FBT=$S($D(FBSITE(1)):$P(FBSITE(1),"^",8),1:"") + D FBO G END:$D(DIRUT) + S PRCF("X")="S" D ^PRCFSITE S PRC("SITE")=$S($D(PRC("SITE")):PRC("SITE"),1:"") I PRC("SITE")="" W ! G GET78 + S FB("SITE")=PRC("SITE") +QUE S VAR="FB7078^FBNUM^FBO^FBT^FB(""SITE"")",VAL=FB7078_"^"_FBNUM_"^"_FBO_"^"_FBT_"^"_FB("SITE"),PGM="START^FBCHP78" D ZIS^FBAAUTL G:FBPOP END + ; +START S FB(0)=^FB7078(FB7078,0) S:$E(IOST,1,2)'["C-" FBPG=1 F FBM=1:1:FBNUM D 7078 +END K DA,DFN,DIC,DINAME,DIRUT,DIWF,DIWL,DR,FB,FB7078,FBFD,FBID,FBNM,FBNUM,FBO,FBRR,FBSITE,FBTD,FBV,FBVEN,FBT,I,L,FBM,PGM,S,UL,VA,VADM,VAEL,VAERR,VAL,VAPA,VAR,X,Y,Z,PRC,PRCS,^UTILITY($J),PRCSCPAN + D CLOSE^FBAAUTL Q + ; +7078 U IO S UL="",$P(UL,"-",120)="-",L="|" D HED^FBCH78A + S DFN=$P(^FB7078(FB7078,0),"^",3) G END:'$D(DFN)#2!('$D(^DPT(+DFN,0))) + N FBNAME + S FBNAME("FILE")=2,FBNAME("IENS")=DFN_",",FBNAME("FIELD")=.01 + S FBNAME=$$NAMEFMT^XLFNAME(.FBNAME,"F","C") + S VAPA("P")="" D SITEP^FBAAUTL,6^VADPT + N FBCONFAD S FBCONFAD=$$ACTIVECC^FBAACO0() I FBCONFAD,$L($G(VAPA(16))) D + . N FBLEN S FBLEN=$L(VAPA(16))+$L($P($G(VAPA(17)),U,2))+$L($P($G(VAPA(18)),U,2))+3 S:FBLEN>52 FBLEN=$L(VAPA(16))-(FBLEN-52),VAPA(16)=$E(VAPA(16),1,FBLEN) + F FBNM=1:1:7 S FBNM(FBNM)=$P(FBSITE(0),"^",FBNM) + S FBNM(5)=$S($D(^DIC(5,FBNM(5))):$P(^(FBNM(5),0),"^",2),1:"") + S Y=$P(FB(0),"^",10) D DATE S FBID=Y,FBVEN=$P(FB(0),"^",2),(FBVEN,FBV(0))=$P(FBVEN,";",1),FBVEN=$S($D(^FBAAV(FBVEN,0)):$P(^(0),"^",1),1:"Unknown"),FBVEN(1)=$S($D(^FBAAV(FBV(0),0)):$P(^(0),"^",2),1:"") + F I=3:1:6,14 S FBV(I)=$S($D(^FBAAV(FBV(0),0)):$P(^(0),"^",I),1:"") + I FBV(5)]"" S FBV(5)=$S($D(^DIC(5,FBV(5),0)):$P(^(0),"^",2),1:"") + S Y=$P(FB(0),"^",4) D DATE S FBFD=Y,Y=$S($P(FB(0),"^",5)]"":$P(FB(0),"^",5),1:"Disposition") D DATE:Y>0 S FBTD=Y + S FB(6)=$P(FB(0),"^",6) I FB(6)]"" S FB(6)=$S($D(^DIC(43.4,FB(6),0)):$P(^(0),"^",3),1:"") + W "Issuing Office",?66,L,"1. Date of Issue",!,?5,FBNM(1),?66,L,?70,FBID,!,?5,FBNM(2),?66,L,$E(UL,1,52),!,?5,$S(FBNM(3)]"":FBNM(3),1:FBNM(4)_", "_FBNM(5)_" "_FBNM(6)),?66,L,"2. Veteran's Name",! + I FBNM(3)]"" W ?5,FBNM(4)_", "_FBNM(5)_" "_FBNM(6) + W ?66,L,?70,FBNAME,!,UL,!,"Name of Physician or Station",?66,L,"3. Address",!,?5,FBVEN,?66,L,?68,$S(FBCONFAD:VAPA(13),1:VAPA(1)),!,?5,FBV(3),?66,L,?68,$S(FBCONFAD:VAPA(14),1:VAPA(2)),!,?5,FBV(14) + W ?66,L,?68,$S(FBCONFAD:VAPA(15),1:VAPA(3)),!?5,FBV(4)_", "_FBV(5)_" "_FBV(6) + W ?66,L,?68,$S(FBCONFAD:$G(VAPA(16)),1:VAPA(4))_", "_$S(FBCONFAD:$P($G(VAPA(17)),U,2),1:$P(VAPA(5),"^",2))_" "_$S(FBCONFAD:$P($G(VAPA(18)),U,2),'+$G(VAPA(11)):VAPA(6),$P(VAPA(11),U,2)]"":$P(VAPA(11),U,2),1:VAPA(6)),!?5,"ID#: ",FBVEN(1) + W ?66,L,$E(UL,1,53),!,?66,L,?68,"4. Veteran's Claim No.",?93,L,?95,"4A. SSN",!,?66,L,?68,VAEL(7),?93,L,?95,$$SSNL4^FBAAUTL($P(VADM(2),"^",2)),!,?66,L,$E(UL,1,53),!,?66,L,?75,"5. Authorization Valid",!,?66,L,$E(UL,1,53),! + W ?66,L,"From",?93,L,"To",!,?66,L,?68,FBFD,?93,L,?95,FBTD,!,UL,!,?45,"PART 1. - SERVICES AUTHORIZED",!,UL,!,"6. Services shown below are authorized for the period indicated in Item 5 above.",?104,L,?107,"7. Fee",! + W ?12,"(See Special Provisions below.)",?104,L,"$",! + S DIWL=1,DIWF="WC103" K ^UTILITY($J,"W") + I $D(^FB7078(FB7078,1,0)) F FBRR=0:0 S FBRR=$O(^FB7078(FB7078,1,FBRR)) Q:FBRR'>0 S FBXX=^(FBRR,0),X=FBXX D ^DIWP + D ^DIWW:$D(FBXX) K FBXX + D FISCAL^FBCH78A + W UL,!,"8. Fee Schedule or Contract",?33,L,"9. Authority",?66,L,"9A.",?93,L,"10. Estimated Amount",!?5,$$CONT^FBCH78A(+$P(FB(0),U,2),$P(FB(0),U,4)),?33,L,?35,FB(6),?66,L,?93,L,?95,"$" + K X2 S X=$P(FB(0),"^",7),X3=$L(+X)+2 D COMMA^%DTC K X3 W X,!,UL,! + W "11. Fiscal Symbols",?66,L,"12. Authorized by (Name and Title)",!,?5,FB("SYM"),?66,L,?68,FBO," ",FBT,!,UL + D BOT^FBCH78A + Q +DATE S Y=$$FMTE^XLFDT(Y) Q + ; +FBO S DIR(0)="F^3:45",DIR("A")="Approving Official for 7078",DIR("B")=FBO,DIR("?")="Enter to accept the default or enter a name from 3 to 45 characters in length" D ^DIR K DIR Q:$D(DIRUT) S FBO=X +FBT S DIR(0)="F^3:45",DIR("A")="Title of Approving Official",DIR("B")=FBT,DIR("?")="Enter to accept the default title or enter a title from 3 to 45 characters in length" D ^DIR K DIR Q:$D(DIRUT) S FBT=X +ASKN S DIR(0)="N^1:5",DIR("A")="# of copies of 7078",DIR("B")=FBNUM,DIR("?")="Select a number between 1 and 5. This number represents the number of copies of the 7078 you would like printed" D ^DIR K DIR Q:$D(DIRUT) S FBNUM=X diff --git a/r/FEE_BASIS-FB/FBCHREQ1.m b/r/FEE_BASIS-FB/FBCHREQ1.m index 5496e275..3f9e397f 100644 --- a/r/FEE_BASIS-FB/FBCHREQ1.m +++ b/r/FEE_BASIS-FB/FBCHREQ1.m @@ -1,31 +1,30 @@ -FBCHREQ1 ;AISC/DMK-FEE NOTIFICATION CONT ;31AUG90 - ;;3.5;FEE BASIS;**103**;JAN 30, 1995;Build 19 - ;;Per VHA Directive 2004-038, this routine should not be modified. -VENDOR ;ASK VENDOR FOR NOTIFICATION - W ! K FBCHVEN S DIC="^FBAAV(",DIC(0)="AEQLM",DLAYGO=161.2 D ^DIC G END:X=""!(X="^"),VENDOR:Y<0 S (DA,FBCHVEN)=+Y,DIE=DIC I $P(Y,"^",3)=1 S FBVENEW=1 D NEW^FBAAVD K DIC,DIE,DA,DLAYGO Q -ASKVOK I '$D(FBVENEW) D EN1^FBAAVD S DIR(0)="Y",DIR("A")="Is this the correct vendor",DIR("B")="YES" D ^DIR K DIR G VENDOR:$D(DIRUT)!'Y -END K DIC,DIE,DLAYGO - Q -TIMCK ;72 hour time check called from FBAA ENTER REQUEST template - S X1=$P(^FBAA(162.2,DA,0),"^",1),X=$P(^(0),"^",19),HY=Y,FBSW="" - S Y=$E(X1_"000",9,10)-$E(X_"000",9,10)*60+$E(X1_"00000",11,12)-$E(X_"00000",11,12),X2=X,X=$P(X,".",1)'=$P(X1,".",1) D ^%DTC:X S FBX=X*1440+Y -SURE I FBX>4320 W *7,!!,"This Authorization From Date exceeds the 72 hour notification period. ",!,?8,"Do you want to continue ? No// " R X:DTIME S:X="" X="N" G HELP:X["^" D VALCK^FBAAUTL1 G SURE:'VAL I "Nn"[$E(X,1) S FBSW=1,Y=HY Q - S Y=HY Q -HELP W !,"Entering an '^' is not allowed. Please answer 'Yes' or 'No'." G SURE -EN I $D(DA),DA S FBDA(0)=DA,DIE="^FBAA(162.2,",DR=".01////@" D ^DIE - I '$D(DA) W *7,!?3,"...request deleted",! I $D(^FBAA(161.5,FBDA(0),0)) S DA=FBDA(0),DIK="^FBAA(161.5," D ^DIK - K DIC,DIE,DIK,DA,X,FBDA,DR,DLAYGO,FBDATE,FBLG,FBN,FBUP,FBVT,VA D END^FBCHREQ - Q -EDIT ;EDIT A REQUEST THAT'S NOT COMPLETE - S DIC("S")="I $P(^(0),U,15)'=3" D ASKV^FBCHREQ K DIC("S") G Q:X=""!(X="^") S DA=+Y,FB(0)=^FBAA(162.2,DA,0),FBDOA=$P(FB(0),"^",19),FBFRDT=$P(FB(0),"^",5) - ; fb*3.5*103 add REFERRING PROVIDER (162.2,17) to DR string - S DIE="^FBAA(162.2,",DR="1;2;3.5;S:X=FBDOA!(X or = date of admission. - S FBDOA=$P(^FBAA(162.2,DA,0),"^",19) I $G(FBDOA),X4320 W *7,!!,"This Authorization From Date exceeds the 72 hour notification period. ",!,?8,"Do you want to continue ? No// " R X:DTIME S:X="" X="N" G HELP:X["^" D VALCK^FBAAUTL1 G SURE:'VAL I "Nn"[$E(X,1) S FBSW=1,Y=HY Q + S Y=HY Q +HELP W !,"Entering an '^' is not allowed. Please answer 'Yes' or 'No'." G SURE +EN I $D(DA),DA S FBDA(0)=DA,DIE="^FBAA(162.2,",DR=".01////@" D ^DIE + I '$D(DA) W *7,!?3,"...request deleted",! I $D(^FBAA(161.5,FBDA(0),0)) S DA=FBDA(0),DIK="^FBAA(161.5," D ^DIK + K DIC,DIE,DIK,DA,X,FBDA,DR,DLAYGO,FBDATE,FBLG,FBN,FBUP,FBVT,VA D END^FBCHREQ + Q +EDIT ;EDIT A REQUEST THAT'S NOT COMPLETE + S DIC("S")="I $P(^(0),U,15)'=3" D ASKV^FBCHREQ K DIC("S") G Q:X=""!(X="^") S DA=+Y,FB(0)=^FBAA(162.2,DA,0),FBDOA=$P(FB(0),"^",19),FBFRDT=$P(FB(0),"^",5) + S DIE="^FBAA(162.2,",DR="1;2;3.5;S:X=FBDOA!(X or = date of admission. + S FBDOA=$P(^FBAA(162.2,DA,0),"^",19) I $G(FBDOA),X0 S DC=DC_D I $D(^FBAAA(DA,1,+D,0)) S DE(2)=$P(^(0),U,1) diff --git a/r/FEE_BASIS-FB/FBCTAU1.m b/r/FEE_BASIS-FB/FBCTAU1.m index 401b8d09..2cdd9939 100644 --- a/r/FEE_BASIS-FB/FBCTAU1.m +++ b/r/FEE_BASIS-FB/FBCTAU1.m @@ -1,8 +1,7 @@ -FBCTAU1 ; ;11/08/09 +FBCTAU1 ; ;06/28/03 D DE G BEGIN DE S DIE="^FBAAA(D0,1,",DIC=DIE,DP=161.01,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^FBAAA(D0,1,DA,""))="" - I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(4)=%,DE(8)=% S %=$P(%Z,U,2) S:%]"" DE(14)=% S %=$P(%Z,U,3) S:%]"" DE(16)=% S %=$P(%Z,U,5) S:%]"" DE(18)=% S %=$P(%Z,U,7) S:%]"" DE(22)=% S %=$P(%Z,U,13) S:%]"" DE(30)=% - I S %=$P(%Z,U,18) S:%]"" DE(29)=% S %=$P(%Z,U,21) S:%]"" DE(19)=% + I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(4)=%,DE(8)=% S %=$P(%Z,U,2) S:%]"" DE(14)=% S %=$P(%Z,U,3) S:%]"" DE(16)=% S %=$P(%Z,U,5) S:%]"" DE(18)=% S %=$P(%Z,U,7) S:%]"" DE(20)=% K %Z Q ; W W !?DL+DL-2,DLB_": " @@ -170,60 +169,27 @@ X17 S FBTYPE=$S(FBPRG:FBPRG,1:2) S DU="DIC(4," G RE X18 Q -19 S DW="0;21",DV="*P200'",DU="",DLB="REFERRING PROVIDER",DIFLD=104 - S DU="VA(200," - G RE -X19 S DIC("S")="I $$PROVIDER^FBAAAUT(+Y)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X - Q - ; -20 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=20 D X20 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X20 I $G(X) W !,"REFERRING PROVIDER NPI: ",$$REFNPI^FBCH78(X) - Q -21 S DQ=22 ;@4 -22 S DW="0;7",DV="R*P161.82'",DU="",DLB="PURPOSE OF VISIT CODE",DIFLD=.07 +19 S DQ=20 ;@4 +20 S DW="0;7",DV="R*P161.82'",DU="",DLB="PURPOSE OF VISIT CODE",DIFLD=.07 S DU="FBAA(161.82," G RE -X22 S DIC("S")="I $S('$G(^(""I"")):1,DT'>^(""I""):1,1:0),$S('$D(FBTYPE):1,$P(^(0),U,2)=FBTYPE:1,1:0)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X +X20 S DIC("S")="I $S('$G(^(""I"")):1,DT'>^(""I""):1,1:0),$S('$D(FBTYPE):1,$P(^(0),U,2)=FBTYPE:1,1:0)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X Q ; +21 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=21 D X21 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X21 S:$$EXTPV^FBAAUTL5(X)'=55 Y="@5" + Q +22 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=22 D X22 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X22 S:$P($$GETSTAT^DGMSTAPI(DA(1)),U,2)="Y" Y="@5" + Q 23 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=23 D X23 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X23 S:$$EXTPV^FBAAUTL5(X)'=55 Y="@5" +X23 S DIE("NO^")="" Q 24 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=24 D X24 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X24 S:$P($$GETSTAT^DGMSTAPI(DA(1)),U,2)="Y" Y="@5" +X24 W !,$C(7),"MST POV can't be selected because veteran's MST status is not YES." Q 25 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=25 D X25 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X25 S DIE("NO^")="" +X25 S Y="@4" Q -26 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=26 D X26 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X26 W !,$C(7),"MST POV can't be selected because veteran's MST status is not YES." - Q -27 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=27 D X27 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X27 S Y="@4" - Q -28 S DQ=29 ;@5 -29 S DW="0;18",DV="S",DU="",DLB="PATIENT TYPE CODE",DIFLD=.065 - S DU="00:SURGICAL;10:MEDICAL;60:HOME NURSING SERVICE;85:PSYCHIATRIC-CONTRACT;86:PSYCHIATRIC;95:NEUROLOGICAL-CONTRACT;96:NEUROLOGICAL;" - G RE -X29 Q -30 S DW="0;13",DV="R*S",DU="",DLB="TREATMENT TYPE CODE",DIFLD=.095 - S DE(DW)="C30^FBCTAU1" - S DU="1:SHORT TERM FEE STATUS;2:HOME NURSING SERVICES;3:I.D. CARD STATUS;4:STATE HOME;" - G RE -C30 G C30S:$D(DE(30))[0 K DB - S X=DE(30),DIC=DIE - ; -C30S S X="" G:DG(DQ)=X C30F1 K DB - D ^FBCTAU2 -C30F1 Q -X30 Q -31 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=31 D X31 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X31 S FBAATT=X - Q -32 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=32 D X32 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X32 S FBAALT=$S(X=2:"Y",X=3:"Y",1:"") - Q -33 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=33 D X33 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X33 K DIE("NO^") - Q -34 D:$D(DG)>9 F^DIE17 G ^FBCTAU3 +26 S DQ=27 ;@5 +27 D:$D(DG)>9 F^DIE17 G ^FBCTAU2 diff --git a/r/FEE_BASIS-FB/FBCTAU2.m b/r/FEE_BASIS-FB/FBCTAU2.m index b97d9720..3d727d5f 100644 --- a/r/FEE_BASIS-FB/FBCTAU2.m +++ b/r/FEE_BASIS-FB/FBCTAU2.m @@ -1,3 +1,213 @@ -FBCTAU2 ; ;11/08/09 +FBCTAU2 ; ;06/28/03 + D DE G BEGIN +DE S DIE="^FBAAA(D0,1,",DIC=DIE,DP=161.01,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^FBAAA(D0,1,DA,""))="" + I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,4) S:%]"" DE(15)=% S %=$P(%Z,U,8) S:%]"" DE(6)=% S %=$P(%Z,U,13) S:%]"" DE(2)=% S %=$P(%Z,U,14) S:%]"" DE(12)=% S %=$P(%Z,U,18) S:%]"" DE(1)=% S %=$P(%Z,U,19) S:%]"" DE(19)=% S %=$P(%Z,U,20) S:%]"" DE(20)=% + I $D(^(3)) S %Z=^(3) S %=$P(%Z,U,1) S:%]"" DE(8)=% S %=$P(%Z,U,2) S:%]"" DE(10)=% + I $D(^(100)) S %Z=^(100) S %=$P(%Z,U,1) S:%]"" DE(17)=% + I $D(^("C")) S %Z=^("C") S %=$P(%Z,U,1) S:%]"" DE(21)=%,DE(24)=% + K %Z Q + ; +W W !?DL+DL-2,DLB_": " + Q +O D W W Y W:$X>45 !?9 + I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 + W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q +TR R X:DTIME E S (DTOUT,X)=U W $C(7) + Q +A K DQ(DQ) S DQ=DQ+1 +B G @DQ +RE G PR:$D(DE(DQ)) D W,TR +N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A +RD G QS:X?."?" I X["^" D D G ^DIE17 + I X="@" D D G Z^DIE2 + I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X +T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V + K DDER G X +P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 + G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z + I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X +V D @("X"_DQ) K YS +Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A +X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 + S X="?BAD" +QS S DZ=X D D,QQ^DIEQ G B +D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q +Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N +PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP +R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R + I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R + X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% +RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 +I I DV'["I",DV'["#" G RD + D E^DIE0 G RD:$D(X),PR + Q +SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 + I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 + D ^DIR I 'DDER S %=Y(0),X=Y + Q +SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) + I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" + E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") + Q +NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS +KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") +BEGIN S DNM="FBCTAU2",DQ=1 +1 S DW="0;18",DV="S",DU="",DLB="PATIENT TYPE CODE",DIFLD=.065 + S DU="00:SURGICAL;10:MEDICAL;60:HOME NURSING SERVICE;85:PSYCHIATRIC-CONTRACT;86:PSYCHIATRIC;95:NEUROLOGICAL-CONTRACT;96:NEUROLOGICAL;" + G RE +X1 Q +2 S DW="0;13",DV="R*S",DU="",DLB="TREATMENT TYPE CODE",DIFLD=.095 + S DE(DW)="C2^FBCTAU2" + S DU="1:SHORT TERM FEE STATUS;2:HOME NURSING SERVICES;3:I.D. CARD STATUS;4:STATE HOME;" + G RE +C2 G C2S:$D(DE(2))[0 K DB + S X=DE(2),DIC=DIE + ; +C2S S X="" G:DG(DQ)=X C2F1 K DB S X=DG(DQ),DIC=DIE D:'$D(DIU(0)) EVENT^IVMPLOG(DA(1)) +C2F1 Q +X2 Q +3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X3 S FBAATT=X + Q +4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X4 S FBAALT=$S(X=2:"Y",X=3:"Y",1:"") + Q +5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X5 K DIE("NO^") + Q +6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW="0;8",DV="F",DU="",DLB="DX LINE 1",DIFLD=.08 + G RE +X6 K:$L(X)>60!($L(X)<3) X + I $D(X),X'?.ANP K X + Q + ; +7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X7 S:X="" Y=.021 + Q +8 S DW="3;1",DV="F",DU="",DLB="DX LINE 2",DIFLD=.085 + G RE +X8 K:$L(X)>60!($L(X)<2) X + I $D(X),X'?.ANP K X + Q + ; +9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X9 S:X="" Y=.021 + Q +10 S DW="3;2",DV="F",DU="",DLB="DX LINE 3",DIFLD=.086 + G RE +X10 K:$L(X)>60!($L(X)<2) X + I $D(X),X'?.ANP K X + Q + ; +11 S D=0 K DE(1) ;.021 + S Y="AUTHORIZATION REMARKS^W^^0;1^Q",DG="2",DC="^161.06" D DIEN^DIWE K DE(1) G A + ; +12 S DW="0;14",DV="S",DU="",DLB="TYPE OF CARE",DIFLD=2 + S DU="1:C&P;2:OPT NSC;3:OPT SC;" + G RE +X12 Q +13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X13 S:'$D(FBAAASKV) FBAAASKV="N" + Q +14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X14 S:FBAAASKV'="y" Y=100 + Q +15 S DW="0;4",DV="P161.2",DU="",DLB="VENDOR",DIFLD=.04 + S DE(DW)="C15^FBCTAU2" + S DU="FBAAV(" + G RE +C15 G C15S:$D(DE(15))[0 K DB + S X=DE(15),DIC=DIE + K ^FBAAA("ACV",$E(X,1,30),DA(1),DA) +C15S S X="" G:DG(DQ)=X C15F1 K DB + S X=DG(DQ),DIC=DIE + S ^FBAAA("ACV",$E(X,1,30),DA(1),DA)="" +C15F1 Q +X15 Q +16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 G A +17 D:$D(DG)>9 F^DIE17,DE S DQ=17,DW="100;1",DV="P200'",DU="",DLB="CLERK",DIFLD=100 + S DU="VA(200," + S X=DUZ + S Y=X + S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD:X="@",Z +X17 Q +18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X18 W !! + Q +19 S DW="0;19",DV="FXO",DU="",DLB="ACCIDENT RELATED (Y/N)",DIFLD=.096 + S DQ(19,2)="S Y(0)=Y D OUTYN^FBAAUTL3" + S DE(DW)="C19^FBCTAU2" + G RE +C19 G C19S:$D(DE(19))[0 K DB + S X=DE(19),DIC=DIE + K ^FBAAA("AA",X,$P(^FBAAA(DA(1),1,DA,0),U,1),DA(1),DA) +C19S S X="" G:DG(DQ)=X C19F1 K DB + S X=DG(DQ),DIC=DIE + S ^FBAAA("AA",X,$P(^FBAAA(DA(1),1,DA,0),U,1),DA(1),DA)="" +C19F1 Q +X19 I $D(X) D YN^FBAAUTL3 + I $D(X),X'?.ANP K X + Q + ; +20 D:$D(DG)>9 F^DIE17,DE S DQ=20,DW="0;20",DV="RFXO",DU="",DLB="POTENTIAL COST RECOVERY CASE",DIFLD=.097 + S DQ(20,2)="S Y(0)=Y D OUTYN^FBAAUTL3" + S DE(DW)="C20^FBCTAU2" + S X="NO" + S Y=X + G Y +C20 G C20S:$D(DE(20))[0 K DB + S X=DE(20),DIC=DIE + K ^FBAAA("AC",X,$P(^FBAAA(DA(1),1,DA,0),U,1),DA(1),DA) + S X=DE(20),DIC=DIE + K:$P(^FBAAA(DA(1),1,DA,0),U) ^FBAAA("AIC",DA(1),-($P(^FBAAA(DA(1),1,DA,0),U)),X,DA) +C20S S X="" G:DG(DQ)=X C20F1 K DB + S X=DG(DQ),DIC=DIE + S ^FBAAA("AC",X,$P(^FBAAA(DA(1),1,DA,0),U,1),DA(1),DA)="" + S X=DG(DQ),DIC=DIE + S:$P(^FBAAA(DA(1),1,DA,0),U) ^FBAAA("AIC",DA(1),-($P(^FBAAA(DA(1),1,DA,0),U)),X,DA)="" +C20F1 Q +X20 I $D(X) D YN^FBAAUTL3 + I $D(X),X'?.ANP K X + Q + ; +21 D:$D(DG)>9 F^DIE17,DE S DQ=21,DW="C;1",DV="FX",DU="",DLB="PRINT AUTHORIZATION (Y/N)",DIFLD=1 + S DE(DW)="C21^FBCTAU2" + S X="YES" + S Y=X + G Y +C21 G C21S:$D(DE(21))[0 K DB + S X=DE(21),DIC=DIE + D KILL^FBAAUTL2 +C21S S X="" G:DG(DQ)=X C21F1 K DB + S X=DG(DQ),DIC=DIE + D ADD^FBAAUTL2 +C21F1 Q +X21 I $D(X) D YN^FBAAUTL3 + I $D(X),X'?.ANP K X + Q + ; +22 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=22 D X22 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X22 S FBAAP79=$S(X["Y":"Y",1:"") + Q +23 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=23 D X23 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X23 I X["Y" S Y="" + Q +24 D:$D(DG)>9 F^DIE17,DE S DQ=24,DW="C;1",DV="FX",DU="",DLB="PRINT AUTHORIZATION (Y/N)",DIFLD=1 + S DE(DW)="C24^FBCTAU2" + S X="@" + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +C24 G C24S:$D(DE(24))[0 K DB + D ^FBCTAU3 +C24S S X="" G:DG(DQ)=X C24F1 K DB + D ^FBCTAU4 +C24F1 Q +X24 I $D(X) D YN^FBAAUTL3 + I $D(X),X'?.ANP K X + Q + ; +25 G 1^DIE17 diff --git a/r/FEE_BASIS-FB/FBCTAU3.m b/r/FEE_BASIS-FB/FBCTAU3.m index cb272e04..7d313fd0 100644 --- a/r/FEE_BASIS-FB/FBCTAU3.m +++ b/r/FEE_BASIS-FB/FBCTAU3.m @@ -1,190 +1,3 @@ -FBCTAU3 ; ;11/08/09 - D DE G BEGIN -DE S DIE="^FBAAA(D0,1,",DIC=DIE,DP=161.01,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^FBAAA(D0,1,DA,""))="" - I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,4) S:%]"" DE(10)=% S %=$P(%Z,U,8) S:%]"" DE(1)=% S %=$P(%Z,U,14) S:%]"" DE(7)=% S %=$P(%Z,U,19) S:%]"" DE(14)=% S %=$P(%Z,U,20) S:%]"" DE(15)=% - I $D(^(3)) S %Z=^(3) S %=$P(%Z,U,1) S:%]"" DE(3)=% S %=$P(%Z,U,2) S:%]"" DE(5)=% - I $D(^(100)) S %Z=^(100) S %=$P(%Z,U,1) S:%]"" DE(12)=% - I $D(^("C")) S %Z=^("C") S %=$P(%Z,U,1) S:%]"" DE(16)=%,DE(19)=% - K %Z Q - ; -W W !?DL+DL-2,DLB_": " - Q -O D W W Y W:$X>45 !?9 - I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 - W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q -TR R X:DTIME E S (DTOUT,X)=U W $C(7) - Q -A K DQ(DQ) S DQ=DQ+1 -B G @DQ -RE G PR:$D(DE(DQ)) D W,TR -N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A -RD G QS:X?."?" I X["^" D D G ^DIE17 - I X="@" D D G Z^DIE2 - I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X -T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V - K DDER G X -P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 - G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z - I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X -V D @("X"_DQ) K YS -Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A -X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 - S X="?BAD" -QS S DZ=X D D,QQ^DIEQ G B -D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q -Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N -PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP -R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R - I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R - X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% -RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 -I I DV'["I",DV'["#" G RD - D E^DIE0 G RD:$D(X),PR - Q -SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 - I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 - D ^DIR I 'DDER S %=Y(0),X=Y - Q -SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) - I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" - E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") - Q -NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS -KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") -BEGIN S DNM="FBCTAU3",DQ=1 -1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="0;8",DV="F",DU="",DLB="DX LINE 1",DIFLD=.08 - G RE -X1 K:$L(X)>60!($L(X)<3) X - I $D(X),X'?.ANP K X - Q - ; -2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X2 S:X="" Y=.021 - Q -3 S DW="3;1",DV="F",DU="",DLB="DX LINE 2",DIFLD=.085 - G RE -X3 K:$L(X)>60!($L(X)<2) X - I $D(X),X'?.ANP K X - Q - ; -4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X4 S:X="" Y=.021 - Q -5 S DW="3;2",DV="F",DU="",DLB="DX LINE 3",DIFLD=.086 - G RE -X5 K:$L(X)>60!($L(X)<2) X - I $D(X),X'?.ANP K X - Q - ; -6 S D=0 K DE(1) ;.021 - S Y="AUTHORIZATION REMARKS^W^^0;1^Q",DG="2",DC="^161.06" D DIEN^DIWE K DE(1) G A - ; -7 S DW="0;14",DV="S",DU="",DLB="TYPE OF CARE",DIFLD=2 - S DU="1:C&P;2:OPT NSC;3:OPT SC;" - G RE -X7 Q -8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X8 S:'$D(FBAAASKV) FBAAASKV="N" - Q -9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X9 S:FBAAASKV'="y" Y=100 - Q -10 S DW="0;4",DV="P161.2",DU="",DLB="VENDOR",DIFLD=.04 - S DE(DW)="C10^FBCTAU3" - S DU="FBAAV(" - G RE -C10 G C10S:$D(DE(10))[0 K DB - S X=DE(10),DIC=DIE - K ^FBAAA("ACV",$E(X,1,30),DA(1),DA) -C10S S X="" G:DG(DQ)=X C10F1 K DB - S X=DG(DQ),DIC=DIE - S ^FBAAA("ACV",$E(X,1,30),DA(1),DA)="" -C10F1 Q -X10 Q -11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 G A -12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW="100;1",DV="P200'",DU="",DLB="CLERK",DIFLD=100 - S DU="VA(200," - S X=DUZ - S Y=X - S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD:X="@",Z -X12 Q -13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X13 W !! - Q -14 S DW="0;19",DV="FXO",DU="",DLB="ACCIDENT RELATED (Y/N)",DIFLD=.096 - S DQ(14,2)="S Y(0)=Y D OUTYN^FBAAUTL3" - S DE(DW)="C14^FBCTAU3" - G RE -C14 G C14S:$D(DE(14))[0 K DB - S X=DE(14),DIC=DIE - K ^FBAAA("AA",X,$P(^FBAAA(DA(1),1,DA,0),U,1),DA(1),DA) -C14S S X="" G:DG(DQ)=X C14F1 K DB - S X=DG(DQ),DIC=DIE - S ^FBAAA("AA",X,$P(^FBAAA(DA(1),1,DA,0),U,1),DA(1),DA)="" -C14F1 Q -X14 I $D(X) D YN^FBAAUTL3 - I $D(X),X'?.ANP K X - Q - ; -15 D:$D(DG)>9 F^DIE17,DE S DQ=15,DW="0;20",DV="RFXO",DU="",DLB="POTENTIAL COST RECOVERY CASE",DIFLD=.097 - S DQ(15,2)="S Y(0)=Y D OUTYN^FBAAUTL3" - S DE(DW)="C15^FBCTAU3" - S X="NO" - S Y=X - G Y -C15 G C15S:$D(DE(15))[0 K DB - S X=DE(15),DIC=DIE - K ^FBAAA("AC",X,$P(^FBAAA(DA(1),1,DA,0),U,1),DA(1),DA) - S X=DE(15),DIC=DIE - K:$P(^FBAAA(DA(1),1,DA,0),U) ^FBAAA("AIC",DA(1),-($P(^FBAAA(DA(1),1,DA,0),U)),X,DA) -C15S S X="" G:DG(DQ)=X C15F1 K DB - S X=DG(DQ),DIC=DIE - S ^FBAAA("AC",X,$P(^FBAAA(DA(1),1,DA,0),U,1),DA(1),DA)="" - S X=DG(DQ),DIC=DIE - S:$P(^FBAAA(DA(1),1,DA,0),U) ^FBAAA("AIC",DA(1),-($P(^FBAAA(DA(1),1,DA,0),U)),X,DA)="" -C15F1 Q -X15 I $D(X) D YN^FBAAUTL3 - I $D(X),X'?.ANP K X - Q - ; -16 D:$D(DG)>9 F^DIE17,DE S DQ=16,DW="C;1",DV="FX",DU="",DLB="PRINT AUTHORIZATION (Y/N)",DIFLD=1 - S DE(DW)="C16^FBCTAU3" - S X="YES" - S Y=X - G Y -C16 G C16S:$D(DE(16))[0 K DB - S X=DE(16),DIC=DIE +FBCTAU3 ; ;06/28/03 + S X=DE(24),DIC=DIE D KILL^FBAAUTL2 -C16S S X="" G:DG(DQ)=X C16F1 K DB - S X=DG(DQ),DIC=DIE - D ADD^FBAAUTL2 -C16F1 Q -X16 I $D(X) D YN^FBAAUTL3 - I $D(X),X'?.ANP K X - Q - ; -17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X17 S FBAAP79=$S(X["Y":"Y",1:"") - Q -18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X18 I X["Y" S Y="" - Q -19 D:$D(DG)>9 F^DIE17,DE S DQ=19,DW="C;1",DV="FX",DU="",DLB="PRINT AUTHORIZATION (Y/N)",DIFLD=1 - S DE(DW)="C19^FBCTAU3" - S X="@" - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -C19 G C19S:$D(DE(19))[0 K DB - S X=DE(19),DIC=DIE - D KILL^FBAAUTL2 -C19S S X="" G:DG(DQ)=X C19F1 K DB - S X=DG(DQ),DIC=DIE - D ADD^FBAAUTL2 -C19F1 Q -X19 I $D(X) D YN^FBAAUTL3 - I $D(X),X'?.ANP K X - Q - ; -20 G 1^DIE17 diff --git a/r/FEE_BASIS-FB/FBNHEAU1.m b/r/FEE_BASIS-FB/FBNHEAU1.m index 263faa26..d1cf7f97 100644 --- a/r/FEE_BASIS-FB/FBNHEAU1.m +++ b/r/FEE_BASIS-FB/FBNHEAU1.m @@ -1,19 +1,18 @@ -FBNHEAU1 ;AISC/dmk - continue FBNHEAUT cnh authorization ;4/28/93 11:04 - ;;3.5;FEE BASIS;**103**;JAN 30, 1995;Build 19 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -END K DA,DR,F,FBAASKV,FBAADDYS,FBAALT,FBAAP79,FBAATT,FBANEW,FBAOLD,FBCOUNTY,FBDX,FBI,FBRR,FBSITE,FBTYPE,FBXX,I,J,K,PI,S,T,Z,ZZ,FBPROG,PRC,PRCS,PRCSCPAN,DFN,CNT,X1,X2,FBMM - K DIC,DIE,FB7078,FBAA78,FBAADA,FBAAASKV,FBBEGDT,FBCD,FBDAYS,FBDEFP,FBDEV,FBENDDT,FBERR,FBNAME,FBNUM,FBO,FBOBN,FBPAYDT,FBPAYEDT,FBPOSDT,FBPSADF,FBSEQ,FBSSN,FBT,FBVEN,FBVCAR,FTP,IFN,PGM,VAL,VAR,X,Y - K FB("SITE"),FBAAADA,FBABD,FBDD,FBEDT,FBEND,FBFLAG,FBLG,FBMULT,FBONE,FBOUT,FBPOP,FBRIFN,FBTDT,FBTOT,FBTRDYS,FBTWO,FBZZ,FB,FBRIFN,FBRATE,FBC,FBID,FBAAOUT,FBVIEN,FBX,FBATODT,FBCNUM,FBFR - K FBRP - Q - ; -NOGOOD ;ERROR - W !!,"No valid Obligation Number selected" G END - ; -PROB ;ERROR - W !!,"Unable to get Obligation Sequence number from IFCAP!",!,"Check with IFCAP package coordinator!" Q - ; -PROB2 ;ERROR - W !!,"Unable to add an entry in the VA Form 7078 file. Please see Computer Staff!" Q - Q +FBNHEAU1 ;AISC/dmk - continue FBNHEAUT cnh authorization ;4/28/93 11:04 + ;;3.5;FEE BASIS;;JAN 30, 1995 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; +END K DA,DR,F,FBAASKV,FBAADDYS,FBAALT,FBAAP79,FBAATT,FBANEW,FBAOLD,FBCOUNTY,FBDX,FBI,FBRR,FBSITE,FBTYPE,FBXX,I,J,K,PI,S,T,Z,ZZ,FBPROG,PRC,PRCS,PRCSCPAN,DFN,CNT,X1,X2,FBMM + K DIC,DIE,FB7078,FBAA78,FBAADA,FBAAASKV,FBBEGDT,FBCD,FBDAYS,FBDEFP,FBDEV,FBENDDT,FBERR,FBNAME,FBNUM,FBO,FBOBN,FBPAYDT,FBPAYEDT,FBPOSDT,FBPSADF,FBSEQ,FBSSN,FBT,FBVEN,FBVCAR,FTP,IFN,PGM,VAL,VAR,X,Y + K FB("SITE"),FBAAADA,FBABD,FBDD,FBEDT,FBEND,FBFLAG,FBLG,FBMULT,FBONE,FBOUT,FBPOP,FBRIFN,FBTDT,FBTOT,FBTRDYS,FBTWO,FBZZ,FB,FBRIFN,FBRATE,FBC,FBID,FBAAOUT,FBVIEN,FBX,FBATODT,FBCNUM,FBFR + Q + ; +NOGOOD ;ERROR + W !!,"No valid Obligation Number selected" G END + ; +PROB ;ERROR + W !!,"Unable to get Obligation Sequence number from IFCAP!",!,"Check with IFCAP package coordinator!" Q + ; +PROB2 ;ERROR + W !!,"Unable to add an entry in the VA Form 7078 file. Please see Computer Staff!" Q + Q diff --git a/r/FEE_BASIS-FB/FBNHEAUT.m b/r/FEE_BASIS-FB/FBNHEAUT.m index 93f646fa..7c5f9f27 100644 --- a/r/FEE_BASIS-FB/FBNHEAUT.m +++ b/r/FEE_BASIS-FB/FBNHEAUT.m @@ -1,58 +1,55 @@ -FBNHEAUT ;AISC/DMK,GRR-ENTER/EDIT AUTHORIZATION ;08/07/02 - ;;3.5;FEE BASIS;**43,103**;JAN 30, 1995;Build 19 - ;;Per VHA Directive 2004-038, this routine should not be modified. - D SITEP^FBAAUTL Q:FBPOP S FBAADDYS=+$P(FBSITE(0),"^",13),FBAAASKV=$P(FBSITE(1),"^"),FBPROG=$S($P(FBSITE(1),"^",6)="":"I 1",1:"I $P(^(0),U,3)=7") W !! - ; - S PRCS("TYPE")="FB",PRCS("A")="Select Obligation Number: " K PRCS("X") D EN1^PRCS58 G:Y<0 NOGOOD^FBNHEAU1 S FBOBN=$P(Y,"^",2) K PRCS("A") - ; - W !! S DIC="^DPT(",DIC(0)="QEAZM" D ^DIC G END:Y<0 S DFN=+Y - I $P($G(^DPT(DFN,.361)),"^")="" W !!,"ELIGIBILITY HAS NOT BEEN DETERMINED NOR PENDING, CANNOT ENTER AN AUTHORIZATION." G FBNHEAUT - I $P($G(^DPT(DFN,.32)),"^",4)=2 W !!,"VETERAN HAS A DISHONORABLE DISCHARGE, " S X=$P($G(^(.321)),"^") W $S(X="Y":"ONLY ELIGIBLE FOR AGENT ORANGE.",1:"NOT ELIGIBLE FOR BENEFITS.") - I "N"[$E(X) W ! S DIR("A")="Do you want to continue",DIR(0)="Y",DIR("B")="No" D ^DIR K DIR G FBNHEAUT:$S($D(DIRUT):1,'Y:1,1:0) - S DA=DFN I '$D(^FBAAA(DFN,0)) K DD,DO S (X,DINUM)=DFN,DIC="^FBAAA(",DIC(0)="LM",DLAYGO=161 D FILE^DICN K DIC,DLAYGO G:Y<0 END - S:'$D(^FBAAA(DFN,1,0)) ^(0)="^161.01D^^" - D ^FBAADEM ;G FBNHEAUT:FBAAOUT - ; -GETVEN S FBPROG=7 D DATES^FBAAUTL2 G:FBBEGDT="" FBNHEAUT - D GETVEN^FBAAUTL1 G END:X="^"!(X=""),GETVEN:IFN="" S FBVEN=IFN,FBPAYDT=FBBEGDT,X=+FBBEGDT D DAYS^FBAAUTL1 S FBDAYS=$S(X>(FBENDDT-FBBEGDT):(FBENDDT-FBBEGDT),1:X) - D GETRAT^FBNHEAU2 G:FBERR GETVEN - ;CREATE AN ENTRY IN FILE 161 - K DD,DO S DLAYGO=161,DA(1)=DFN,(DIE,DIC)="^FBAAA("_DA(1)_",1,",DIC(0)="LQ",X=FBBEGDT D FILE^DICN K DLAYGO S DA=+Y,FBAAADA=DA - S DIE=DIC,FBPSADF=$S($D(FBSITE(1)):$P(^DIC(4,$P(FBSITE(1),"^",3),0),"^",1),1:"") - ; fb*3.5*103 added REFERRING PROVIDER field (161.01,104) to DR string - S DR=".02////^S X=FBENDDT;.03////^S X=7;S FBTYPE=7;100////^S X=DUZ;1////^S X=""YES"";.04////^S X=FBVEN;.095////1;101T;104;.065;.07;.021;.097;.08;S:X="""" Y="""";.085;S:X="""" Y="""";.086" D ^DIE - I $D(DTOUT)!('$D(Y)=0) S DIC="^FBAAA("_DFN_",1," G DEL - ; fb*3.5*103 assignment of REFERRING PROVIDER (161.01,104) for recording at 162.4,15 via the FBNH ENTER 7078 input template - S FBRP=$$GET1^DIQ(161.01,FBAAADA_","_DFN,104,"I") - S FBVEN=FBVEN_";FBAAV(" - ; - S X=FBPAYDT D DAYS^FBAAUTL1 S FBATODT=$S($E(FBPAYDT,1,5)_"00"+X>FBENDDT:FBENDDT-1,1:$E(FBPAYDT,1,5)_"00"+X) - D EST^FBNHEAU2 - I $G(FBDEFP)'>0 W !,*7,"Unable to determine estimated dollar amount, based on authorization",!,"dates and current vendor contracts.",! S DA=FBAAADA,DA(1)=DFN,DIC="^FBAAA("_DFN_",1," G DEL - ;CHECK 1358 and get next point number. create entry in 162.4 - S X=FBOBN K PRCS("A") S PRCS("TYPE")="FB" D EN1^PRCSUT31 I Y<0 S DIC="^FBAAA("_DFN_",1," D PROB^FBNHEAU1 G DEL - S FB7078=$P(FBOBN,"-",2)_"."_Y,FBSEQ=Y,DIC="^FB7078(",DIC(0)="LQ",DLAYGO=162.4,X=""""_FB7078_"""" D ^DIC K DLAYGO I Y<0 S DIC="^FBAAA("_DFN_",1," D PROB2^FBNHEAU1 G DEL - S (DA,FBAA78)=+Y - S DIE=DIC,DR="[FBNH ENTER 7078]" D ^DIE - I $O(^FBAAA(DFN,1,FBAAADA,2,0))>0 S ^FB7078(FBAA78,1,0)=^FBAAA(DFN,1,FBAAADA,2,0) F Z=0:0 S Z=$O(^FBAAA(DFN,1,FBAAADA,2,Z)) Q:Z'>0 S ^FB7078(FBAA78,1,Z,0)=^FBAAA(DFN,1,FBAAADA,2,Z,0) - S $P(^FBAAA(DFN,1,FBAAADA,0),"^",9)=FBAA78_";FB7078(",^FBAAA("AG",FBAA78_";FB7078(",DFN,FBAAADA)="" - ;call to create entries in file 161.23, time sensitive file - ;that will store patient rates - S FBERR=0 D FILE^FBNHEAU2 I FBERR W !,"Unable to create entry in Authorization Rate file (161.23). Contact IRM.",! G ADM - ;call to create entry in ifcap 424. - S FBMM=$E(FBBEGDT,4,5) - S PRCS("TYPE")="FB" K PRCS("A") S FBNAME=$$NAME^FBCHREQ2(DFN),FBSSN=$$SSN^FBAAUTL(DFN) D NOW^%DTC S FBPOSDT=%,X=FBOBN_"^"_FBPOSDT_"^"_FBDEFP_"^^"_FBSEQ_"^"_FBNAME_" ("_FBSSN_")"_"^"_DFN_";"_FBAA78_";"_$P(FBOBN,"-",2)_";"_FBMM D EN2^PRCS58 - I +Y=0 W !!,"Error trying to Post to 1358, DID NOT POST. Error was:",!,Y,!?7,"Adjust the 1358 for $",$FN(FBDEFP,",",2)," then use the",!?7,"Post Commitments for Obligation option!",!,*7 G ADM - W !!,$J(FBDEFP,7,2)," Posted to 1358" - ; - ; -CHEKP78 S FBNUM=$P(FBSITE(1),"^",5),FBO=$P(FBSITE(1),"^",7),FBT=$P(FBSITE(1),"^",8) D FBO^FBCHP78 G END:$D(DIRUT) S IOP="Q",FB7078=FBAA78 W ! - D IFCAP^FBAAUTL2 - I '$D(FBERR(1)) S VAR="FB7078^FBNUM^FBO^FBT^FB(""SITE"")",VAL=FB7078_"^"_FBNUM_"^"_FBO_"^"_FBT_"^"_FB("SITE"),PGM="START^FBCHP78",%ZIS("B")="" W ! D ZIS^FBAAUTL - ; -ADM S DIR(0)="Y",DIR("A")="Do you want to Admit Patient to CNH now",DIR("B")="YES" D ^DIR K DIR I Y S FBVEN=+FBVEN,FTP=FBAAADA,FBAABDT=FBBEGDT,FBAAEDT=FBENDDT,FBEND=1,FBRCHK=1 D RD2^FBNHEA - ; -END D END^FBNHEAU1 - Q - ; -DEL S DIK=DIC D ^DIK K DIK,DIC D END^FBNHEAU1 G FBNHEAUT +FBNHEAUT ;AISC/DMK,GRR-ENTER/EDIT AUTHORIZATION ;08/07/02 + ;;3.5;FEE BASIS;**43**;JAN 30, 1995 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + D SITEP^FBAAUTL Q:FBPOP S FBAADDYS=+$P(FBSITE(0),"^",13),FBAAASKV=$P(FBSITE(1),"^"),FBPROG=$S($P(FBSITE(1),"^",6)="":"I 1",1:"I $P(^(0),U,3)=7") W !! + ; + S PRCS("TYPE")="FB",PRCS("A")="Select Obligation Number: " K PRCS("X") D EN1^PRCS58 G:Y<0 NOGOOD^FBNHEAU1 S FBOBN=$P(Y,"^",2) K PRCS("A") + ; + W !! S DIC="^DPT(",DIC(0)="QEAZM" D ^DIC G END:Y<0 S DFN=+Y + I $P($G(^DPT(DFN,.361)),"^")="" W !!,"ELIGIBILITY HAS NOT BEEN DETERMINED NOR PENDING, CANNOT ENTER AN AUTHORIZATION." G FBNHEAUT + I $P($G(^DPT(DFN,.32)),"^",4)=2 W !!,"VETERAN HAS A DISHONORABLE DISCHARGE, " S X=$P($G(^(.321)),"^") W $S(X="Y":"ONLY ELIGIBLE FOR AGENT ORANGE.",1:"NOT ELIGIBLE FOR BENEFITS.") + I "N"[$E(X) W ! S DIR("A")="Do you want to continue",DIR(0)="Y",DIR("B")="No" D ^DIR K DIR G FBNHEAUT:$S($D(DIRUT):1,'Y:1,1:0) + S DA=DFN I '$D(^FBAAA(DFN,0)) K DD,DO S (X,DINUM)=DFN,DIC="^FBAAA(",DIC(0)="LM",DLAYGO=161 D FILE^DICN K DIC,DLAYGO G:Y<0 END + S:'$D(^FBAAA(DFN,1,0)) ^(0)="^161.01D^^" + D ^FBAADEM ;G FBNHEAUT:FBAAOUT + ; +GETVEN S FBPROG=7 D DATES^FBAAUTL2 G:FBBEGDT="" FBNHEAUT + D GETVEN^FBAAUTL1 G END:X="^"!(X=""),GETVEN:IFN="" S FBVEN=IFN,FBPAYDT=FBBEGDT,X=+FBBEGDT D DAYS^FBAAUTL1 S FBDAYS=$S(X>(FBENDDT-FBBEGDT):(FBENDDT-FBBEGDT),1:X) + D GETRAT^FBNHEAU2 G:FBERR GETVEN + ;CREATE AN ENTRY IN FILE 161 + K DD,DO S DLAYGO=161,DA(1)=DFN,(DIE,DIC)="^FBAAA("_DA(1)_",1,",DIC(0)="LQ",X=FBBEGDT D FILE^DICN K DLAYGO S DA=+Y,FBAAADA=DA + S DIE=DIC,FBPSADF=$S($D(FBSITE(1)):$P(^DIC(4,$P(FBSITE(1),"^",3),0),"^",1),1:"") + S DR=".02////^S X=FBENDDT;.03////^S X=7;S FBTYPE=7;100////^S X=DUZ;1////^S X=""YES"";.04////^S X=FBVEN;.095////1;101T;.065;.07;.021;.097;.08;S:X="""" Y="""";.085;S:X="""" Y="""";.086" D ^DIE + I $D(DTOUT)!('$D(Y)=0) S DIC="^FBAAA("_DFN_",1," G DEL + S FBVEN=FBVEN_";FBAAV(" + ; + S X=FBPAYDT D DAYS^FBAAUTL1 S FBATODT=$S($E(FBPAYDT,1,5)_"00"+X>FBENDDT:FBENDDT-1,1:$E(FBPAYDT,1,5)_"00"+X) + D EST^FBNHEAU2 + I $G(FBDEFP)'>0 W !,*7,"Unable to determine estimated dollar amount, based on authorization",!,"dates and current vendor contracts.",! S DA=FBAAADA,DA(1)=DFN,DIC="^FBAAA("_DFN_",1," G DEL + ;CHECK 1358 and get next point number. create entry in 162.4 + S X=FBOBN K PRCS("A") S PRCS("TYPE")="FB" D EN1^PRCSUT31 I Y<0 S DIC="^FBAAA("_DFN_",1," D PROB^FBNHEAU1 G DEL + S FB7078=$P(FBOBN,"-",2)_"."_Y,FBSEQ=Y,DIC="^FB7078(",DIC(0)="LQ",DLAYGO=162.4,X=""""_FB7078_"""" D ^DIC K DLAYGO I Y<0 S DIC="^FBAAA("_DFN_",1," D PROB2^FBNHEAU1 G DEL + S (DA,FBAA78)=+Y + S DIE=DIC,DR="[FBNH ENTER 7078]" D ^DIE + I $O(^FBAAA(DFN,1,FBAAADA,2,0))>0 S ^FB7078(FBAA78,1,0)=^FBAAA(DFN,1,FBAAADA,2,0) F Z=0:0 S Z=$O(^FBAAA(DFN,1,FBAAADA,2,Z)) Q:Z'>0 S ^FB7078(FBAA78,1,Z,0)=^FBAAA(DFN,1,FBAAADA,2,Z,0) + S $P(^FBAAA(DFN,1,FBAAADA,0),"^",9)=FBAA78_";FB7078(",^FBAAA("AG",FBAA78_";FB7078(",DFN,FBAAADA)="" + ;call to create entries in file 161.23, time sensitive file + ;that will store patient rates + S FBERR=0 D FILE^FBNHEAU2 I FBERR W !,"Unable to create entry in Authorization Rate file (161.23). Contact IRM.",! G ADM + ;call to create entry in ifcap 424. + S FBMM=$E(FBBEGDT,4,5) + S PRCS("TYPE")="FB" K PRCS("A") S FBNAME=$$NAME^FBCHREQ2(DFN),FBSSN=$$SSN^FBAAUTL(DFN) D NOW^%DTC S FBPOSDT=%,X=FBOBN_"^"_FBPOSDT_"^"_FBDEFP_"^^"_FBSEQ_"^"_FBNAME_" ("_FBSSN_")"_"^"_DFN_";"_FBAA78_";"_$P(FBOBN,"-",2)_";"_FBMM D EN2^PRCS58 + I +Y=0 W !!,"Error trying to Post to 1358, DID NOT POST. Error was:",!,Y,!?7,"Adjust the 1358 for $",$FN(FBDEFP,",",2)," then use the",!?7,"Post Commitments for Obligation option!",!,*7 G ADM + W !!,$J(FBDEFP,7,2)," Posted to 1358" + ; + ; +CHEKP78 S FBNUM=$P(FBSITE(1),"^",5),FBO=$P(FBSITE(1),"^",7),FBT=$P(FBSITE(1),"^",8) D FBO^FBCHP78 G END:$D(DIRUT) S IOP="Q",FB7078=FBAA78 W ! + D IFCAP^FBAAUTL2 + I '$D(FBERR(1)) S VAR="FB7078^FBNUM^FBO^FBT^FB(""SITE"")",VAL=FB7078_"^"_FBNUM_"^"_FBO_"^"_FBT_"^"_FB("SITE"),PGM="START^FBCHP78",%ZIS("B")="" W ! D ZIS^FBAAUTL + ; +ADM S DIR(0)="Y",DIR("A")="Do you want to Admit Patient to CNH now",DIR("B")="YES" D ^DIR K DIR I Y S FBVEN=+FBVEN,FTP=FBAAADA,FBAABDT=FBBEGDT,FBAAEDT=FBENDDT,FBEND=1,FBRCHK=1 D RD2^FBNHEA + ; +END D END^FBNHEAU1 + Q + ; +DEL S DIK=DIC D ^DIK K DIK,DIC D END^FBNHEAU1 G FBNHEAUT diff --git a/r/FEE_BASIS-FB/FBNHEDAT.m b/r/FEE_BASIS-FB/FBNHEDAT.m index 04f32e86..9f52f503 100644 --- a/r/FEE_BASIS-FB/FBNHEDAT.m +++ b/r/FEE_BASIS-FB/FBNHEDAT.m @@ -1,40 +1,39 @@ -FBNHEDAT ;AISC/GRR-ENTER/EDIT AUTHORIZATION ;02:07 PM 11 Apr 1990; - ;;3.5;FEE BASIS;**103**;JAN 30, 1995;Build 19 - ;;Per VHA Directive 2004-038, this routine should not be modified. - D SITEP^FBAAUTL -RD1 S U="^" D GETVET^FBAAUTL1 G:DFN="" END - S FBPROG="I $P(^(0),U,3)=7" D GETAUTH^FBAAUTL1 G RD1:'CNT!(FTP']"")!($D(DIRUT)) S (FBOLD,FBNEW,FBERR)="" - K FBAUT,CNT S (DA(1),D0)=DFN,FBOLD=^FBAAA(DFN,1,FTP,0),DA=FTP,FBAAADA=DA,DIE="^FBAAA("_DFN_",1,",FBO=$P(FBOLD,"^"),(FB1,FBAA(2))=$P(FBOLD,"^",2) - S FBPROG=7 D DATES^FBAAUTL2 S FBAA(1)=$S($G(FBBEGDT):FBBEGDT,1:FBO),FBAA(2)=$S($G(FBENDDT):FBENDDT,1:FB1) -DR S DR=".01////^S X=FBAA(1);.02////^S X=FBAA(2)" - ; fb*3.5*103 add REFERRING PROVIDER (161.01,104) to DR string - S DR(1,161.01,1)="@2;.065;.07;.021;.08;S:X="""" Y=101;.085;S:X="""" Y=101;.086;101;104;.097" D ^DIE - S FBNEW=$S('$D(DA):"",'$D(^FBAAA(DFN,1,DA,0)):"",1:^(0)) K DR - I $D(Y)>0,FBNEW=""!(FBNEW=FBOLD) G RD1 - I FBNEW'=FBOLD,$P(FBNEW,"^")>$P(FBNEW,"^",2) S DR=".01////^S X=FBO;.02////^S X=FB1" D ^DIE K DR D ER G DR - ; - S FBAA78=FB7078 D ^FBNHEDA1 K FBAA78 I FBERR S DA(1)=DFN,DA=FTP,DIE="^FBAAA("_DA(1)_",1,",DR=".01////^S X=FBO;.02////^S X=FB1" D ^DIE G END - ; fb*3.5*103 add the REFERRING PROVIDER (162.4,15) to the DR string; stuff with the value stored at 161.01,104 - S DIE="^FB7078(",DA=FB7078,FBAA78=DA,DR="5;6;15////^S X=$$GET1^DIQ(161.01,FBAAADA_"",""_DFN,104,""I"")" I 'DA W !!,*7,"No 7078 on file!",! G END - D:FBOLD'=FBNEW CHANGED -GO D ^DIE - I $O(^FBAAA(DFN,1,FBAAADA,2,0))>0 K ^FB7078(FBAA78,1) S ^FB7078(FBAA78,1,0)=^FBAAA(DFN,1,FBAAADA,2,0) F Z=0:0 S Z=$O(^FBAAA(DFN,1,FBAAADA,2,Z)) Q:Z'>0 S ^FB7078(FBAA78,1,Z,0)=^FBAAA(DFN,1,FBAAADA,2,Z,0) -RD2 S DIR(0)="Y",DIR("A")="Want to Queue 7078 for printing",DIR("B")=$S(FBOLD=FBNEW:"No",1:"Yes") D ^DIR K DIR G:Y'>0 RD1 -CHEKP78 S FBNUM=$P(FBSITE(1),"^",5),FBO=$P(FBSITE(1),"^",7),FBT=$P(FBSITE(1),"^",8) D FBO^FBCHP78 G END:$D(DIRUT) S IOP="Q",%ZIS("B")="",FB7078=FBAA78,FB("SITE")=$P(FBSITE(1),"^",3) W ! - S VAR="FB7078^FBNUM^FBO^FBT^FB(""SITE"")",VAL=FB7078_"^"_FBNUM_"^"_FBO_"^"_FBT_"^"_FB("SITE"),PGM="START^FBCHP78" W ! D ZIS^FBAAUTL - ; -END K D0,DA,FBAASKV,FBAADDYS,FBAALT,FBAAP79,FBAATT,FBNUM,FBDEV,FBO,FBT,FB7078,FBAA78,FBCOUNTY,FBDX,FBI,FBRR,FBVEN,FBTYPE,FBXX,I,J,K,PI,FBOLD,FBNEW,FBPSADF,FBAADA,FB1,FBERR,FBOUT,FBIFN,FBZ,FBBEGDT,FBENDDT,FBAUT - K DIE,DIR,FBAAADA,FTP,PGM,VAL,VAR,X,Y,Z,DIC,A,FBAABDT,FBAAEDT,FBAAOUT,FBASSOC,FBLOC,FBPOV,FBPROG,FBPSA,FBPT,FBSITE,FBTT,PTYPE,T,ZZ,FB("SITE"),FBPOP,FBAA,FBBDT,FBTDAYS,HOLDX - D END^FBNHEAU1 - D CLOSE^FBAAUTL - Q - ; -CHANGED S:$P(FBOLD,"^",1)'=$P(FBNEW,"^",1) DR="3////^S X=$P(FBNEW,U,1);"_DR - S:$P(FBOLD,"^",2)'=$P(FBNEW,"^",2) DR="4////^S X=$P(FBNEW,U,2);"_DR - Q - ; -ER W !,*7,"From Date cannot be greater than the To Date.",! - Q - ; -ER1 W !,*7,"This patient has movements after the authorization to date. You must",!,"edit the patient's movements first.",! - Q +FBNHEDAT ;AISC/GRR-ENTER/EDIT AUTHORIZATION ;02:07 PM 11 Apr 1990; + ;;3.5;FEE BASIS;;JAN 30, 1995 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + D SITEP^FBAAUTL +RD1 S U="^" D GETVET^FBAAUTL1 G:DFN="" END + S FBPROG="I $P(^(0),U,3)=7" D GETAUTH^FBAAUTL1 G RD1:'CNT!(FTP']"")!($D(DIRUT)) S (FBOLD,FBNEW,FBERR)="" + K FBAUT,CNT S (DA(1),D0)=DFN,FBOLD=^FBAAA(DFN,1,FTP,0),DA=FTP,FBAAADA=DA,DIE="^FBAAA("_DFN_",1,",FBO=$P(FBOLD,"^"),(FB1,FBAA(2))=$P(FBOLD,"^",2) + S FBPROG=7 D DATES^FBAAUTL2 S FBAA(1)=$S($G(FBBEGDT):FBBEGDT,1:FBO),FBAA(2)=$S($G(FBENDDT):FBENDDT,1:FB1) +DR S DR=".01////^S X=FBAA(1);.02////^S X=FBAA(2)" + S DR(1,161.01,1)="@2;.065;.07;.021;.08;S:X="""" Y=101;.085;S:X="""" Y=101;.086;101;.097" D ^DIE + S FBNEW=$S('$D(DA):"",'$D(^FBAAA(DFN,1,DA,0)):"",1:^(0)) K DR + I $D(Y)>0,FBNEW=""!(FBNEW=FBOLD) G RD1 + I FBNEW'=FBOLD,$P(FBNEW,"^")>$P(FBNEW,"^",2) S DR=".01////^S X=FBO;.02////^S X=FB1" D ^DIE K DR D ER G DR + ; + S FBAA78=FB7078 D ^FBNHEDA1 K FBAA78 I FBERR S DA(1)=DFN,DA=FTP,DIE="^FBAAA("_DA(1)_",1,",DR=".01////^S X=FBO;.02////^S X=FB1" D ^DIE G END + ; + S DIE="^FB7078(",DA=FB7078,FBAA78=DA,DR="5;6" I 'DA W !!,*7,"No 7078 on file!",! G END + D:FBOLD'=FBNEW CHANGED +GO D ^DIE + I $O(^FBAAA(DFN,1,FBAAADA,2,0))>0 K ^FB7078(FBAA78,1) S ^FB7078(FBAA78,1,0)=^FBAAA(DFN,1,FBAAADA,2,0) F Z=0:0 S Z=$O(^FBAAA(DFN,1,FBAAADA,2,Z)) Q:Z'>0 S ^FB7078(FBAA78,1,Z,0)=^FBAAA(DFN,1,FBAAADA,2,Z,0) +RD2 S DIR(0)="Y",DIR("A")="Want to Queue 7078 for printing",DIR("B")=$S(FBOLD=FBNEW:"No",1:"Yes") D ^DIR K DIR G:Y'>0 RD1 +CHEKP78 S FBNUM=$P(FBSITE(1),"^",5),FBO=$P(FBSITE(1),"^",7),FBT=$P(FBSITE(1),"^",8) D FBO^FBCHP78 G END:$D(DIRUT) S IOP="Q",%ZIS("B")="",FB7078=FBAA78,FB("SITE")=$P(FBSITE(1),"^",3) W ! + S VAR="FB7078^FBNUM^FBO^FBT^FB(""SITE"")",VAL=FB7078_"^"_FBNUM_"^"_FBO_"^"_FBT_"^"_FB("SITE"),PGM="START^FBCHP78" W ! D ZIS^FBAAUTL + ; +END K D0,DA,FBAASKV,FBAADDYS,FBAALT,FBAAP79,FBAATT,FBNUM,FBDEV,FBO,FBT,FB7078,FBAA78,FBCOUNTY,FBDX,FBI,FBRR,FBVEN,FBTYPE,FBXX,I,J,K,PI,FBOLD,FBNEW,FBPSADF,FBAADA,FB1,FBERR,FBOUT,FBIFN,FBZ,FBBEGDT,FBENDDT,FBAUT + K DIE,DIR,FBAAADA,FTP,PGM,VAL,VAR,X,Y,Z,DIC,A,FBAABDT,FBAAEDT,FBAAOUT,FBASSOC,FBLOC,FBPOV,FBPROG,FBPSA,FBPT,FBSITE,FBTT,PTYPE,T,ZZ,FB("SITE"),FBPOP,FBAA,FBBDT,FBTDAYS,HOLDX + D END^FBNHEAU1 + D CLOSE^FBAAUTL + Q + ; +CHANGED S:$P(FBOLD,"^",1)'=$P(FBNEW,"^",1) DR="3////^S X=$P(FBNEW,U,1);"_DR + S:$P(FBOLD,"^",2)'=$P(FBNEW,"^",2) DR="4////^S X=$P(FBNEW,U,2);"_DR + Q + ; +ER W !,*7,"From Date cannot be greater than the To Date.",! + Q + ; +ER1 W !,*7,"This patient has movements after the authorization to date. You must",!,"edit the patient's movements first.",! + Q diff --git a/r/FEE_BASIS-FB/FBPCR.m b/r/FEE_BASIS-FB/FBPCR.m index 5c147c32..e9092b94 100644 --- a/r/FEE_BASIS-FB/FBPCR.m +++ b/r/FEE_BASIS-FB/FBPCR.m @@ -1,172 +1,171 @@ -FBPCR ;AISC/DMK,GRR,TET-POTENTIAL COST RECOVERY OUTPUT DRIVER ;23 May 2006 10:06 AM - ;;3.5;FEE BASIS;**12,48,76,98,103**;JAN 30, 1995;Build 19 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; DBIA SUPPORTED REF $$NPI^XUSNPI = 4532 -DOC ;Refer to fbdoc, tag fbpcr, for documentation of fbpcr* routines -PSF ;select one/many/all primary service failities - S FBARRLTC="" - W !! S DIC="^DIC(4,",VAUTSTR="Primary Service Facility",VAUTNI=2,VAUTVB="FBPSV" D FIRST^VAUTOMA K DIC I Y=-1 G EXIT -ARRAY ;set fee program array for all programs - S FBPI=0 F S FBPI=$O(^FBAA(161.8,FBPI)) Q:'FBPI S FBPIN=$G(^(FBPI,0)) I $P(FBPIN,U,3) S FBPROG(FBPI)=$P(FBPIN,U) - I '$D(FBPROG) G EXIT - ;prepare array with LTC POV codes - D MKARRLTC^FBPCR4 - ;what party to include - K DIR - S DIR(0)="SO^P:Patient;I:Insurance;B:Both",DIR("A")="Include (P)atient Co-pays / (I)nsurance / (B)oth",DIR("B")="Both" - S DIR("?")=" Select type of recover to include",DIR("?",1)=" P - include only recover from patient copays",DIR("?",2)=" I - include only recover from insurance",DIR("?",3)=" B - include both",DIR("L")="" - D ^DIR S FBPARTY=$S($G(Y(0))="Patient":1,$G(Y(0))="Insurance":2,$G(Y(0))="Both":3,X="Both":3,1:0) - K DIR - G:FBPARTY=0 EXIT - ;what type of copay to include - S FBCOPAY=3 - I FBPARTY'=2 D - . S DIR(0)="SO^M:MeansTest;L:LTC;B:Both",DIR("A")="Include (M)eans Test Co-pays /(L)TC Co-pays /(B)oth",DIR("B")="Both" - . S DIR("?")=" Select services to include",DIR("?",1)=" M - include only Means Test copays",DIR("?",2)=" L - include only LTC copays",DIR("?",3)=" B - include both",DIR("L")="" - . D ^DIR S FBCOPAY=$S($G(Y(0))="LTC":1,$G(Y(0))="MeansTest":2,$G(Y(0))="Both":3,X="Both":3,1:0) - . K DIR - G:FBCOPAY=0 EXIT - ; - ;include patients if their insurance informations is unavailable? - S FBINCUNK=0 - I FBPARTY=2!(FBPARTY=3) D - . S FBINCUNK=1 - . N Y,X - . W !! - . S DIR("A")="Do you want to include patients whose insurance status is unavailable? " - . S DIR("?")="Please answer Yes or No." - . S DIR("B")="YES",DIR(0)="YA^^" - . D ^DIR K DIR - . I $G(DIRUT) S FBINCUNK=-1 Q - . I $G(Y)=0 S FBINCUNK=0 - I FBINCUNK=-1 G EXIT ;uparrow - exit - ; -DATE ;select date range - D DATE^FBAAUTL I FBPOP G PSF - S FBBDATE=BEGDATE,FBEDATE=ENDDATE - S Z=9999999.9999,FBBEG=Z-FBEDATE,FBEND=Z-FBBDATE -Q K ^TMP($J,"FB"),^TMP($J,"FBINSIBAPI"),DIC - ; - S VAR="FBINCUNK^FBARRLTC^FBARRLTC(^FBPARTY^FBCOPAY^FBNAME^FBIEN^FBID^FBBEG^FBEND^FBBDATE^FBEDATE^FBPSV^FBPSV(^FBPROG(",VAL=VAR,PGM="DQ^FBPCR",IOP="Q" D ZIS^FBAAUTL G:FBPOP EXIT -DQ S $P(FBDASH,"=",80)="",$P(FBDASH1,"-",80)="",FBPG=0,FBCRT=$S($E(IOST,1,2)="C-":1,1:0),FBOUT=0,FBBEG=FBBEG-.9 U IO -SORT ;sort driver for payment output(s) - S FBPI=0 F S FBPI=$O(FBPROG(FBPI)) Q:'FBPI S FBXPROG=FBPROG(FBPI) D - .I FBPI=2 D EN^FBPCR2 ;outpatient payments - .I FBPI=3 D EN^FBPCR3 ;pharmacy payments - .I FBPI=6!(FBPI=7) S:FBPI=6&($D(FBPROG(7))) FBPI=67 D EN^FBPCR67 S:FBPI=67 FBPI=7 ;civil hospital/cnh payments -PRINT ;print driver for payment output(s) - I $G(^TMP($J,"FBINSIBAPI"))>0 D HDRUNK - S FBPI=$O(^TMP($J,"FB",0)) I FBPI']"" D WMSG G OUT - S FBSTA=0 - S FBPSF=0 F S FBPSF=$O(^TMP($J,"FB",FBPSF)) Q:'FBPSF!FBOUT D STA S FBPT="" F S FBPT=$O(^TMP($J,"FB",FBPSF,FBPT)) Q:FBPT']""!FBOUT S DFN=$P(FBPT,";",2) D VET S FBPI=0 F S FBPI=$O(FBPROG(FBPI)) Q:'FBPI S FBXPROG=FBPROG(FBPI) D Q:FBOUT - .I FBPSF_FBPT'=FBSTA D HDR Q:FBOUT - .I FBPI=2,$D(^TMP($J,"FB",FBPSF,FBPT,FBPI)) D PRINT^FBPCR2 Q - .I FBPI=3 D:$D(^TMP($J,"FB",FBPSF,FBPT,FBPI)) PRINT^FBPCR3 Q - .I FBPI=6!(FBPI=7) D:$D(^TMP($J,"FB",FBPSF,FBPT,FBPI)) PRINT^FBPCR671 Q -OUT I $G(^TMP($J,"FBINSIBAPI"))>0 D ERRHDL^FBPCR4 - I FBOUT!$D(ZTQUEUED) G EXIT - D EXIT G PSF - Q -EXIT ;kill and quit -KILL ;kill all variables set in the FBPCR* routines, other than fbx - D CLOSE^FBAAUTL K ^TMP($J,"FB") - K A1,A2,A3,BEGDATE,C,D,D2,DFN,DIC,DIR,DTOUT,DUOUT,ENDDATE,FBPDXC,FBPARTY,FBCOPAY,FBARRLTC,FBINCUNK - K FBAAA,FBAACPTC,FBAC,FBAP,FBBATCH,FBBDATE,FBBEG,FBBN,FBCATC,FBCNT,FBCP,FBCRT,FBDA1,FBDASH,FBDASH1,FBDATA,FBDOB,FBDRUG,FBDT,FBDT1,FBDOS,FBDX,FBDX1,FBEDATE,FBEND,FBERR,FBFD,FBFD1,FBHEAD - K FBI,FBID,FBIEN,FBIN,FBINS,FBINVN,FBIX,FBJ,FBLOC,FBM,FBNAME,FBOB,FBOPI,FBOUT,FBOV,FBP,FBPAT,FBPD,FBPDX,FBPG,FBPI,FBPID,FBPIN,FBPNAME,FBPROC,FBPROC1,FBPROG,FBPSF,FBPSFNAM,FBPSFNUM,FBPSV,FBPT,FBPV,FBQTY,FBREIM,FBRX - K FBSC,FBSL,FBSTA,FBSTR,FBSUSP,FBTA,FBTYPE,FBV,FBVCHAIN,FBVEN,FBVENID,FBVNAME,FBVI,FBVID,FBVP,FBXPROG,FBY,FBZ,I,IOP,J,K,L,M,N,PGM,T,V,VA,VAERR,VAL,VAR,VAUTNI,VAUTSTR,VAUTVB,X,Y,Z,FBSTANPI,FBXX - Q -WMSG ;write message if no matches found - D HDR W !!?3,"There are no potential cost recoveries on file" - W !?5,"for specified date range: ",$$DATX^FBAAUTL(FBBDATE)," through ",$$DATX^FBAAUTL(FBEDATE) - I 'FBPSV D - .W ",",!?5,"and selected Primary Service Area(s):" - .S FBPSF=0 F S FBPSF=$O(FBPSV(FBPSF)) Q:'FBPSF W !?31,$G(FBPSV(FBPSF)) - E W !?5,"and ALL Primary Service Areas " - W ".",*7,!! - Q - ; -CATC(DFN,FBDT,FBPOV) ; - ;treats all copays as Means test for date < 3020705 (JULY 5,2002) - ;check if patient is liable for copay - ;INPUT: - ; DFN = IEN of Patient file - ; FBDT= Date - ; FBPOV = POV code (for LTC determination) - ;OUTPUT: - ;0 - the patient is not liable for any co-pay; - ;1 - if Means test catc or pending adjudication and agree to pay deduc - ;2 - the patient is liable for LTC co-pay; - ;3 - no 1010EC on file - ;4 - more analysis is needed to determine the patient liability - N FBLTC,FBISLTC - S FBCATC=$$BIL^DGMTUB(DFN,FBDT) - I '$D(FBPOV)!(FBDT<3020705) Q $S(FBCATC:1,1:0) - S FBISLTC=$$ISLTC^FBPCR4(FBPOV) - I FBISLTC=0 Q $S(FBCATC:1,1:0) ;Means test - I FBISLTC=2 Q 0 ;LTC-service, but LTC-copay is not applicable - S FBLTC=$$LTCST^FBPCR4(DFN,FBDT) - I FBLTC=2 Q 2 ;LTC copay - I FBLTC=0 Q 3 ;no 1010EC on file - I FBLTC=4 Q 4 ;more info needed - Q 0 ;exemption from LTC -copay - ; -VET ;set vet name/ssn/dob info - ;INPUT: DFN = IEN of Patient file - ; FBPI = IEN of fee program (optional) - ;OUTPUT: FBPNAME = Patient's name - ; FBPID = Patient's pid - ; FBDOB = Patient's dob (if pharmacy fee program) - N N - S N=$G(^DPT(DFN,0)),FBPNAME=$P(N,U),FBPID=$$SSN^FBAAUTL(DFN),FBDOB=$$FMTE^XLFDT($P(N,U,3)) - Q -STA ;set station name & number - ;INPUT = FBPSF - IEN to institution file - ;OUTPUT = FBPSFNAM = station name - ; FBPSFNUM = station number - S FBPSFNAM=$P($G(^DIC(4,FBPSF,0)),U),FBPSFNUM=$P($G(^DIC(4,FBPSF,99)),U) - S:FBPSFNAM=+FBPSFNAM FBPSFNAM="UNKNOWN" - S FBSTANPI=$S($G(FBPSFNAM)="":"",FBPSFNAM="UNKNOWN":"",1:$P($$NPI^XUSNPI("Organization_ID",FBPSF),U,1)) - Q -PAGE ;form feed when new station/patient - S FBSTA=$G(FBPSF)_$G(FBPT) - I FBCRT&(FBPG'=0) D CR Q:FBOUT - I FBPG>0!FBCRT W @IOF - S FBPG=FBPG+1 - Q -CR ;read for display - S DIR(0)="E" W ! D ^DIR K DIR S:$D(DUOUT)!($D(DTOUT)) FBOUT=1 - Q -HDR ;general header for potential recoveries - D PAGE Q:FBOUT - W !?(IOM-30/2),"POTENTIAL COST RECOVERY REPORT" - W !?(IOM-(11+$L($G(FBPSFNAM))+$L($G(FBPSFNUM)))/2),"Division: ",$G(FBPSFNUM)," ",$G(FBPSFNAM) - W !?(IOM-14/2),"NPI: ",$S($G(FBSTANPI)="":"",$G(FBSTANPI)<1:"",1:$G(FBSTANPI)) - W !?(IOM-19/2),$$DATX^FBAAUTL(FBBDATE)," - ",$$DATX^FBAAUTL(FBEDATE) - W !?71,"Page: ",FBPG - W !,"Patient: ",$G(FBPNAME),?40,"Pat. ID: ",$G(FBPID),?62,"DOB: ",$G(FBDOB) - W ! - I FBINCUNK=1,$D(^TMP($J,"FBINSIBAPI",+$G(DFN))) W ">> Warning: accurate insurance information for the patient is unavailable" - W !?3,"('*' Represents Reimbursement to Patient",?50,"'#' Represents Voided Payment)" - W !,FBDASH - W ! D:$D(DFN) INS^DGRPDB - Q -HDRUNK ;Warning message if patient's insurance status is unknown - D PAGE Q:FBOUT - W !?(IOM-30/2),"POTENTIAL COST RECOVERY REPORT" - W !?(IOM-(11+$L($G(FBPSFNAM))+$L($G(FBPSFNUM)))/2),"Division: ",$G(FBPSFNUM)," ",$G(FBPSFNAM) - W !?(IOM-19/2),$$DATX^FBAAUTL(FBBDATE)," - ",$$DATX^FBAAUTL(FBEDATE) - W !?71,"Page: ",FBPG - W !,"------------------------------ !!! WARNING !!! --------------------------------" - W !,"This report is incomplete due to problems with obtaining insurance information" - W !,"for those patients listed in a separate section in the end of the report. You" - W !,"may want to rerun the report again to get more accurate results." - W !,FBDASH - I FBINCUNK=1 D - . W !,"Note: You have chosen to include patients with unknown insurance status in" - . W !,"this report. Please be aware that these patients will be treated as if they" - . W !,"have billable insurance and their treatment details will be marked accordingly." - . W !,"The names of these patients will be accompanied with the following message" - . W !,"to order to identify them:" - . W !,">> Warning: accurate insurance information for the patient is unavailable" - . W !,FBDASH - Q +FBPCR ;AISC/DMK,GRR,TET-POTENTIAL COST RECOVERY OUTPUT DRIVER ;23 May 2006 10:06 AM + ;;3.5;FEE BASIS;**12,48,76,98**;JAN 30, 1995;Build 54 + ;;Per VHA Directive 10-93-142, this routine should not be modified. +DOC ;Refer to fbdoc, tag fbpcr, for documentation of fbpcr* routines +PSF ;select one/many/all primary service failities + S FBARRLTC="" + W !! S DIC="^DIC(4,",VAUTSTR="Primary Service Facility",VAUTNI=2,VAUTVB="FBPSV" D FIRST^VAUTOMA K DIC I Y=-1 G EXIT +ARRAY ;set fee program array for all programs + S FBPI=0 F S FBPI=$O(^FBAA(161.8,FBPI)) Q:'FBPI S FBPIN=$G(^(FBPI,0)) I $P(FBPIN,U,3) S FBPROG(FBPI)=$P(FBPIN,U) + I '$D(FBPROG) G EXIT + ;prepare array with LTC POV codes + D MKARRLTC^FBPCR4 + ;what party to include + K DIR + S DIR(0)="SO^P:Patient;I:Insurance;B:Both",DIR("A")="Include (P)atient Co-pays / (I)nsurance / (B)oth",DIR("B")="Both" + S DIR("?")=" Select type of recover to include",DIR("?",1)=" P - include only recover from patient copays",DIR("?",2)=" I - include only recover from insurance",DIR("?",3)=" B - include both",DIR("L")="" + D ^DIR S FBPARTY=$S($G(Y(0))="Patient":1,$G(Y(0))="Insurance":2,$G(Y(0))="Both":3,X="Both":3,1:0) + K DIR + G:FBPARTY=0 EXIT + ;what type of copay to include + S FBCOPAY=3 + I FBPARTY'=2 D + . S DIR(0)="SO^M:MeansTest;L:LTC;B:Both",DIR("A")="Include (M)eans Test Co-pays /(L)TC Co-pays /(B)oth",DIR("B")="Both" + . S DIR("?")=" Select services to include",DIR("?",1)=" M - include only Means Test copays",DIR("?",2)=" L - include only LTC copays",DIR("?",3)=" B - include both",DIR("L")="" + . D ^DIR S FBCOPAY=$S($G(Y(0))="LTC":1,$G(Y(0))="MeansTest":2,$G(Y(0))="Both":3,X="Both":3,1:0) + . K DIR + G:FBCOPAY=0 EXIT + ; + ;include patients if their insurance informations is unavailable? + S FBINCUNK=0 + I FBPARTY=2!(FBPARTY=3) D + . S FBINCUNK=1 + . N Y,X + . W !! + . S DIR("A")="Do you want to include patients whose insurance status is unavailable? " + . S DIR("?")="Please answer Yes or No." + . S DIR("B")="YES",DIR(0)="YA^^" + . D ^DIR K DIR + . I $G(DIRUT) S FBINCUNK=-1 Q + . I $G(Y)=0 S FBINCUNK=0 + I FBINCUNK=-1 G EXIT ;uparrow - exit + ; +DATE ;select date range + D DATE^FBAAUTL I FBPOP G PSF + S FBBDATE=BEGDATE,FBEDATE=ENDDATE + S Z=9999999.9999,FBBEG=Z-FBEDATE,FBEND=Z-FBBDATE +Q K ^TMP($J,"FB"),^TMP($J,"FBINSIBAPI"),DIC + ; + S VAR="FBINCUNK^FBARRLTC^FBARRLTC(^FBPARTY^FBCOPAY^FBNAME^FBIEN^FBID^FBBEG^FBEND^FBBDATE^FBEDATE^FBPSV^FBPSV(^FBPROG(",VAL=VAR,PGM="DQ^FBPCR",IOP="Q" D ZIS^FBAAUTL G:FBPOP EXIT +DQ S $P(FBDASH,"=",80)="",$P(FBDASH1,"-",80)="",FBPG=0,FBCRT=$S($E(IOST,1,2)="C-":1,1:0),FBOUT=0,FBBEG=FBBEG-.9 U IO +SORT ;sort driver for payment output(s) + S FBPI=0 F S FBPI=$O(FBPROG(FBPI)) Q:'FBPI S FBXPROG=FBPROG(FBPI) D + .I FBPI=2 D EN^FBPCR2 ;outpatient payments + .I FBPI=3 D EN^FBPCR3 ;pharmacy payments + .I FBPI=6!(FBPI=7) S:FBPI=6&($D(FBPROG(7))) FBPI=67 D EN^FBPCR67 S:FBPI=67 FBPI=7 ;civil hospital/cnh payments +PRINT ;print driver for payment output(s) + I $G(^TMP($J,"FBINSIBAPI"))>0 D HDRUNK + S FBPI=$O(^TMP($J,"FB",0)) I FBPI']"" D WMSG G OUT + S FBSTA=0 + S FBPSF=0 F S FBPSF=$O(^TMP($J,"FB",FBPSF)) Q:'FBPSF!FBOUT D STA S FBPT="" F S FBPT=$O(^TMP($J,"FB",FBPSF,FBPT)) Q:FBPT']""!FBOUT S DFN=$P(FBPT,";",2) D VET S FBPI=0 F S FBPI=$O(FBPROG(FBPI)) Q:'FBPI S FBXPROG=FBPROG(FBPI) D Q:FBOUT + .I FBPSF_FBPT'=FBSTA D HDR Q:FBOUT + .I FBPI=2,$D(^TMP($J,"FB",FBPSF,FBPT,FBPI)) D PRINT^FBPCR2 Q + .I FBPI=3 D:$D(^TMP($J,"FB",FBPSF,FBPT,FBPI)) PRINT^FBPCR3 Q + .I FBPI=6!(FBPI=7) D:$D(^TMP($J,"FB",FBPSF,FBPT,FBPI)) PRINT^FBPCR671 Q +OUT I $G(^TMP($J,"FBINSIBAPI"))>0 D ERRHDL^FBPCR4 + I FBOUT!$D(ZTQUEUED) G EXIT + D EXIT G PSF + Q +EXIT ;kill and quit +KILL ;kill all variables set in the FBPCR* routines, other than fbx + D CLOSE^FBAAUTL K ^TMP($J,"FB") + K A1,A2,A3,BEGDATE,C,D,D2,DFN,DIC,DIR,DTOUT,DUOUT,ENDDATE,FBPDXC,FBPARTY,FBCOPAY,FBARRLTC,FBINCUNK + K FBAAA,FBAACPTC,FBAC,FBAP,FBBATCH,FBBDATE,FBBEG,FBBN,FBCATC,FBCNT,FBCP,FBCRT,FBDA1,FBDASH,FBDASH1,FBDATA,FBDOB,FBDRUG,FBDT,FBDT1,FBDOS,FBDX,FBDX1,FBEDATE,FBEND,FBERR,FBFD,FBFD1,FBHEAD + K FBI,FBID,FBIEN,FBIN,FBINS,FBINVN,FBIX,FBJ,FBLOC,FBM,FBNAME,FBOB,FBOPI,FBOUT,FBOV,FBP,FBPAT,FBPD,FBPDX,FBPG,FBPI,FBPID,FBPIN,FBPNAME,FBPROC,FBPROC1,FBPROG,FBPSF,FBPSFNAM,FBPSFNUM,FBPSV,FBPT,FBPV,FBQTY,FBREIM,FBRX + K FBSC,FBSL,FBSTA,FBSTR,FBSUSP,FBTA,FBTYPE,FBV,FBVCHAIN,FBVEN,FBVENID,FBVNAME,FBVI,FBVID,FBVP,FBXPROG,FBY,FBZ,I,IOP,J,K,L,M,N,PGM,T,V,VA,VAERR,VAL,VAR,VAUTNI,VAUTSTR,VAUTVB,X,Y,Z,FBSTANPI,FBXX + Q +WMSG ;write message if no matches found + D HDR W !!?3,"There are no potential cost recoveries on file" + W !?5,"for specified date range: ",$$DATX^FBAAUTL(FBBDATE)," through ",$$DATX^FBAAUTL(FBEDATE) + I 'FBPSV D + .W ",",!?5,"and selected Primary Service Area(s):" + .S FBPSF=0 F S FBPSF=$O(FBPSV(FBPSF)) Q:'FBPSF W !?31,$G(FBPSV(FBPSF)) + E W !?5,"and ALL Primary Service Areas " + W ".",*7,!! + Q + ; +CATC(DFN,FBDT,FBPOV) ; + ;treats all copays as Means test for date < 3020705 (JULY 5,2002) + ;check if patient is liable for copay + ;INPUT: + ; DFN = IEN of Patient file + ; FBDT= Date + ; FBPOV = POV code (for LTC determination) + ;OUTPUT: + ;0 - the patient is not liable for any co-pay; + ;1 - if Means test catc or pending adjudication and agree to pay deduc + ;2 - the patient is liable for LTC co-pay; + ;3 - no 1010EC on file + ;4 - more analysis is needed to determine the patient liability + N FBLTC,FBISLTC + S FBCATC=$$BIL^DGMTUB(DFN,FBDT) + I '$D(FBPOV)!(FBDT<3020705) Q $S(FBCATC:1,1:0) + S FBISLTC=$$ISLTC^FBPCR4(FBPOV) + I FBISLTC=0 Q $S(FBCATC:1,1:0) ;Means test + I FBISLTC=2 Q 0 ;LTC-service, but LTC-copay is not applicable + S FBLTC=$$LTCST^FBPCR4(DFN,FBDT) + I FBLTC=2 Q 2 ;LTC copay + I FBLTC=0 Q 3 ;no 1010EC on file + I FBLTC=4 Q 4 ;more info needed + Q 0 ;exemption from LTC -copay + ; +VET ;set vet name/ssn/dob info + ;INPUT: DFN = IEN of Patient file + ; FBPI = IEN of fee program (optional) + ;OUTPUT: FBPNAME = Patient's name + ; FBPID = Patient's pid + ; FBDOB = Patient's dob (if pharmacy fee program) + N N + S N=$G(^DPT(DFN,0)),FBPNAME=$P(N,U),FBPID=$$SSN^FBAAUTL(DFN),FBDOB=$$FMTE^XLFDT($P(N,U,3)) + Q +STA ;set station name & number + ;INPUT = FBPSF - IEN to institution file + ;OUTPUT = FBPSFNAM = station name + ; FBPSFNUM = station number + S FBPSFNAM=$P($G(^DIC(4,FBPSF,0)),U),FBPSFNUM=$P($G(^DIC(4,FBPSF,99)),U) + S:FBPSFNAM=+FBPSFNAM FBPSFNAM="UNKNOWN" + S FBSTANPI=$S($G(FBPSFNAM)="":"",FBPSFNAM="UNKNOWN":"",1:$P($$NPI^XUSNPI("Organization_ID",FBPSF),U,1)) + Q +PAGE ;form feed when new station/patient + S FBSTA=$G(FBPSF)_$G(FBPT) + I FBCRT&(FBPG'=0) D CR Q:FBOUT + I FBPG>0!FBCRT W @IOF + S FBPG=FBPG+1 + Q +CR ;read for display + S DIR(0)="E" W ! D ^DIR K DIR S:$D(DUOUT)!($D(DTOUT)) FBOUT=1 + Q +HDR ;general header for potential recoveries + D PAGE Q:FBOUT + W !?(IOM-30/2),"POTENTIAL COST RECOVERY REPORT" + W !?(IOM-(11+$L($G(FBPSFNAM))+$L($G(FBPSFNUM)))/2),"Division: ",$G(FBPSFNUM)," ",$G(FBPSFNAM) + W !?(IOM-14/2),"NPI: ",$S($G(FBSTANPI)="":"",$G(FBSTANPI)=-1:"",1:$G(FBSTANPI)) + W !?(IOM-19/2),$$DATX^FBAAUTL(FBBDATE)," - ",$$DATX^FBAAUTL(FBEDATE) + W !?71,"Page: ",FBPG + W !,"Patient: ",$G(FBPNAME),?40,"Pat. ID: ",$G(FBPID),?62,"DOB: ",$G(FBDOB) + W ! + I FBINCUNK=1,$D(^TMP($J,"FBINSIBAPI",+$G(DFN))) W ">> Warning: accurate insurance information for the patient is unavailable" + W !?3,"('*' Represents Reimbursement to Patient",?50,"'#' Represents Voided Payment)" + W !,FBDASH + W ! D:$D(DFN) INS^DGRPDB + Q +HDRUNK ;Warning message if patient's insurance status is unknown + D PAGE Q:FBOUT + W !?(IOM-30/2),"POTENTIAL COST RECOVERY REPORT" + W !?(IOM-(11+$L($G(FBPSFNAM))+$L($G(FBPSFNUM)))/2),"Division: ",$G(FBPSFNUM)," ",$G(FBPSFNAM) + W !?(IOM-19/2),$$DATX^FBAAUTL(FBBDATE)," - ",$$DATX^FBAAUTL(FBEDATE) + W !?71,"Page: ",FBPG + W !,"------------------------------ !!! WARNING !!! --------------------------------" + W !,"This report is incomplete due to problems with obtaining insurance information" + W !,"for those patients listed in a separate section in the end of the report. You" + W !,"may want to rerun the report again to get more accurate results." + W !,FBDASH + I FBINCUNK=1 D + . W !,"Note: You have chosen to include patients with unknown insurance status in" + . W !,"this report. Please be aware that these patients will be treated as if they" + . W !,"have billable insurance and their treatment details will be marked accordingly." + . W !,"The names of these patients will be accompanied with the following message" + . W !,"to order to identify them:" + . W !,">> Warning: accurate insurance information for the patient is unavailable" + . W !,FBDASH + Q diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLCS.m b/r/HEALTH_LEVEL_SEVEN-HL/HLCS.m index f7b5a798..fc3354e9 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLCS.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLCS.m @@ -1,203 +1,194 @@ -HLCS ;ALB/RJS,MTC,JRP - COMMUNICATIONS SERVER - ;10/04/2007 14:34 - ;;1.6;HEALTH LEVEL SEVEN;**2,9,14,19,43,57,109,132,122**;Oct 13, 1995;Build 14 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; - ;The SEND function is invoked by the transaction processor. - ;It's function is to $O through the ITEM multiple of the Event Driver - ;Protocol and create child entries in the Message Text file (#772) - ;for the message at HLMTIEN. These child messages point back - ;to the parent message so that message text does not need to - ;be duplicated when a message is sent to multiple applications. - ; - ;The SENDACK function is also invoked by the transaction processor. - ;It's function is to create a child entry in the Message Text file - ;for the message at HLMTIENA and deliver the message to the - ;application the requested/sent information. - ; - ;For DHCP to DHCP messaging (i.e. internal to internal), an incoming - ;message is created in the Message Text file which is a duplication - ;of the outgoing message. The incoming message is then processed by - ;calling the transaction processor. - ; - ;For DHCP to COTS messaging (i.e. internal to external), the message - ;is filed in the Message Text file with the Logical Link defined and - ;a status of PENDING TRANSMISSION. These entries are picked up by - ;the background filer and transmitted to the appropriate COTS system. - ; -SEND(HLMTIEN,HLEID,HLRESULT) ;Send an HL7 message - ;HLMTIEN=The IEN of the parent message in file # 772 - ;HLEID=The IEN of the Event Driver protocol in file #101 - ;HLRESULT=Variable for any error text (pass by reference) - ; - ;Declare variables - N HLARY,HLERROR,HLEIDS,HLCLIENT,HLOGLINK,HLMTIENS,HLMSGPTR - S HLERROR="" - ;Direct connect - I HLPRIO="I" D Q - . D DC^HLMA2 - . S HLRESULT=HLERROR - ;Get all subscribers to the message - D ITEM^HLUTIL2(HLEID,"PTR") - ;Quit if no subscribers (considered successful delivery) - G:($G(HLARY(0))'>0) EXIT - ;Deliver message to each subscriber - S HLEIDS=0 - F S HLEIDS=$O(HLARY(HLEIDS)) Q:(HLEIDS'>0) D - .; - .;**132 excluded subscribers ** - .N I,EXCLUDE - .S (EXCLUDE,I)=0 - . ; - . ; patch HL*1.6*122 - . ; F S I=$O(HLP("EXCLUDE SUBSCRIBER",I)) Q:'I I $G(HLP("EXCLUDE SUBSCRIBER",I))=HLEIDS S EXCLUDE=1 Q - . F S I=$O(HLP("EXCLUDE SUBSCRIBER",I)) Q:'I D Q:EXCLUDE - .. N TEMP - .. S TEMP=HLP("EXCLUDE SUBSCRIBER",I) - .. I 'TEMP,TEMP]"" S TEMP=$O(^ORD(101,"B",TEMP,0)) - .. I TEMP=HLEIDS S EXCLUDE=1 - . ; patch HL*1.6*122 - . ; - .Q:EXCLUDE - .;** 132 end ** - .; - .;Get pointer to receiving application - .S HLCLIENT=+HLARY(HLEIDS),HL("EIDS")=HLEIDS,HLERROR="" - .Q:(HLCLIENT'>0) - .;Check and execute ROUTING LOGIC **CIRN** - .S HLX=$G(^ORD(101,HLEIDS,774)) - .I HLX]"" D Q - ..N HLQUIT,HLNODE,HLNEXT - ..S HLQUIT=0,HLNODE="",HLNEXT="D HLNEXT^HLCSUTL" - ..X HLX I $D(HLL("LINKS")) D FWD^HLCS2 K HLL ;**CIRN** - .;Get pointer to logical link - .S HLOGLINK=$P(HLARY(HLEIDS),"^",2) - .;Determine if receiving application is internal or external - .; Logical link has a value for external applications - .; Logical link is NULL for internal applications - .I (HLOGLINK) D COTS Q - .;Create 'incoming' message based on 'outgoing' message (internal) - .D DHCP(HLMTIEN,HLEIDS,HLCLIENT) - .Q:(HLERROR) - .;Process the 'incoming' message - .S HLERROR="" - .D PROCESS^HLTP0(HLMSGPTR,"DHCP","",.HLERROR) - .;Update Status of 'incoming' message to SUCCESSFULLY COMPLETED - .; or ERROR DURING TRANSMISSION - .D STATUS^HLTF0(HLMSGPTR,$S(HLERROR:4,1:3),$S(HLERROR:+HLERROR,1:""),$S(HLERROR:$P(HLERROR,"^",2),1:""),,$S($G(HLERR("SKIP_EVENT"))=1:1,1:0)) - .I $D(HLL("LINKS")) D FWD^HLCS2 K HLL ;**CIRN** - D ADD^HLCS2 ;**CIRN** -EXIT S HLRESULT=HLERROR - Q -COTS ;Internal to external communication - ;Create child entry in Message Text file - N HLTCP,HLTCPI,HLTCPO - D SEND^HLMA2(HLEIDS,HLMTIEN,HLCLIENT,"D",.HLMTIENS,HLOGLINK) - I ((+HLMTIENS)'>0) S HLERROR=HLMTIENS Q - ;'Pass' message to background filer by setting status of child - ; to PENDING TRANSMISSION - D STATUS^HLTF0(HLMTIENS,1) - Q -DHCP(HLMTIEN,HLEIDS,HLCLIENT) ;Internal to internal communication - ; - ;Input : HLMTIEN - Pointer to parent outgoing message (file #772) - ; HLEIDS - Pointer to subscribing protocol (file #101) - ; HLCLIENT - Pointer to receiving application (file # 771) - ; - ;Output : HLMTIENS - Pointer to child outgoing message (file #772) - ; HLMSGPTR - Pointer to [parent] incoming message (file #772) - ; HLERROR - ErrorCode ^ ErrorText - ; - ;Notes : This module only copies the outgoing message into an incoming - ; message. Delivery of the message (i.e. processing of it) - ; must be done by the calling application. - ; : Message/batch header (MSH/BSH) is built and placed in the - ; incoming message - ; : HLMTIENS, HLMSGPTR, and HLERROR will be initialized - ; : Existance and validity of input is assumed - ; - ;Declare variables - N MSGID,MSGDT,MSGDTH,HDR2BLD,TMP,HLHDR,BHSHDR - S HLERROR="" - S HLMTIENS=0 - S HLMSGPTR=0 - ;Create child entry in Message Text file - D SEND^HLMA2(HLEIDS,HLMTIEN,HLCLIENT,"D",.HLMTIENS) - I ((+HLMTIENS)'>0) S HLERROR=HLMTIENS Q - ;'Receive' message by making an incoming message - ;Determine type of header to build - S TMP=$G(^HL(772,HLMTIEN,0)) - S HDR2BLD=$P(TMP,"^",14) - ;Build message header (MSH) - I (HDR2BLD="M") D Q:(HLERROR) - .S TMP="" - .D HEADER^HLCSHDR(HLMTIENS,.TMP) - .Q:(TMP="") - .;Error building header - .S HLERROR="4^Unable to build message header => "_TMP - .D STATUS^HLTF0(HLMTIENS,4,0,$P(HLERROR,"^",2)) - ;Build batch header (BHS or FHS) - I (HDR2BLD'="M") D Q:(HLERROR) - .S TMP="" - .D BHSHDR^HLCSHDR(HLMTIENS) - .S:($E(HLHDR(1),1)="-") TMP=$P(HLHDR(1),"^",2) - .Q:(TMP="") - .;Error building header - .S HLERROR="4^Unable to build batch header => "_TMP - .D STATUS^HLTF0(HLMTIENS,4,0,$P(HLERROR,"^",2)) - ;Create entry for 'incoming' message - D CREATE^HLTF(.MSGID,.HLMSGPTR,.MSGDT,.MSGDTH) - ;Move header and rest of message into 'incoming' message - I (HDR2BLD="M") D - .;Use MSH as header - .D MRGINT^HLTF1(HLMTIEN,HLMSGPTR,"HLHDR") - I (HDR2BLD'="M") D - .;Use BHS or FHS as header - .D MRGINT^HLTF1(HLMTIEN,HLMSGPTR,"BHSHDR") - ;Set status of outgoing message to AWAITING ACKNOWLEDGEMENT - D STATUS^HLTF0(HLMTIENS,$S($P(^HL(772,HLMTIEN,0),U,7):3,1:2)) - ;Set status of 'incoming' message to AWAITING PROCESSING - D STATUS^HLTF0(HLMSGPTR,9) - Q -SENDACK(HLMTIENA,HLEID,HLEIDS,HLRESULT) ;Send an HL7 acknowledgement/response - ;HLMTIENA=The IEN of the parent acknowledgment/response message in - ; file # 772 - ;HLEIDS=The IEN of the Subscribing protocol in file # 101 - ;HLEID=The IEN of the Event Driver protocol in file #101 - ;HLRESULT=Variable for any error text (pass by reference) - ; - N HLERROR,HLOGLINK,HLCLIENT,HLMTIENS,HLMSGPTR,HLCLNODE - I $G(HLMTIENA)=""!($G(HLEID)="")!($G(HLEIDS)="") S HLERROR="0^7^"_$G(^HL(771.7,7,0))_"at SENDACK^HLCS entry point" G EXIT2 - S HLCLNODE=$G(^ORD(101,HLEID,770)) - ;Get pointers to Logical Link & receiving application - S HLOGLINK=$P($G(^ORD(101,HLEIDS,770)),U,7) - ;Application needed to dynamically address the ACK (tcp/ip) - ;(set HLL("LINKS") array before calling GENACK) - I $D(HLL("LINKS")) D Q:'HLOGLINK - .S HLOGLINK=$P(HLL("LINKS",1),"^",2) Q:HLOGLINK="" - .K HLL("LINKS") - .I +HLOGLINK'=HLOGLINK S HLOGLINK=$O(^HLCS(870,"B",HLOGLINK,0)) - S HLCLIENT=$P(HLCLNODE,U,1) - Q:('HLCLIENT) - ;Determine if receiving application is internal or external - ; Logical link has a value for external applications - ; Logical link is NULL for internal applications - I (HLOGLINK) D COTSACK Q - ;Create 'incoming' message based on 'outgoing' message (internal) - D DHCP(HLMTIENA,HLEID,HLCLIENT) - ;Process the 'incoming' message - I (HLMSGPTR) D - .S HLERROR="" - .D PROCESS^HLTP0(HLMSGPTR,"DHCP","",.HLERROR) - ;Update Status of 'incoming' message to SUCCESSFULLY COMPLETED - ; or ERROR DURING TRANSMISSION - D STATUS^HLTF0(HLMSGPTR,$S(HLERROR:4,1:3),$S(HLERROR:+HLERROR,1:""),$S(HLERROR:$P(HLERROR,"^",2),1:"")) -EXIT2 ; - S HLRESULT=$G(HLERROR) - Q -COTSACK ;Internal to external communication of acknowledgements/responses - ;Create child entry in Message Text file - D SEND^HLMA2(HLEID,HLMTIENA,HLCLIENT,"D",.HLMTIENS,HLOGLINK) - ;'Pass' message to background filer by setting status of child - ; to PENDING TRANSMISSION - D STATUS^HLTF0(HLMTIENS,1) - Q +HLCS ;ALB/RJS,MTC,JRP - COMMUNICATIONS SERVER - ;10/31/2006 + ;;1.6;HEALTH LEVEL SEVEN;**2,9,14,19,43,57,109,132**;Oct 13, 1995;Build 6 + ;Per VHA Directive 2004-038, this routine should not be modified. + ; + ;The SEND function is invoked by the transaction processor. + ;It's function is to $O through the ITEM multiple of the Event Driver + ;Protocol and create child entries in the Message Text file (#772) + ;for the message at HLMTIEN. These child messages point back + ;to the parent message so that message text does not need to + ;be duplicated when a message is sent to multiple applications. + ; + ;The SENDACK function is also invoked by the transaction processor. + ;It's function is to create a child entry in the Message Text file + ;for the message at HLMTIENA and deliver the message to the + ;application the requested/sent information. + ; + ;For DHCP to DHCP messaging (i.e. internal to internal), an incoming + ;message is created in the Message Text file which is a duplication + ;of the outgoing message. The incoming message is then processed by + ;calling the transaction processor. + ; + ;For DHCP to COTS messaging (i.e. internal to external), the message + ;is filed in the Message Text file with the Logical Link defined and + ;a status of PENDING TRANSMISSION. These entries are picked up by + ;the background filer and transmitted to the appropriate COTS system. + ; +SEND(HLMTIEN,HLEID,HLRESULT) ;Send an HL7 message + ;HLMTIEN=The IEN of the parent message in file # 772 + ;HLEID=The IEN of the Event Driver protocol in file #101 + ;HLRESULT=Variable for any error text (pass by reference) + ; + ;Declare variables + N HLARY,HLERROR,HLEIDS,HLCLIENT,HLOGLINK,HLMTIENS,HLMSGPTR + S HLERROR="" + ;Direct connect + I HLPRIO="I" D Q + . D DC^HLMA2 + . S HLRESULT=HLERROR + ;Get all subscribers to the message + D ITEM^HLUTIL2(HLEID,"PTR") + ;Quit if no subscribers (considered successful delivery) + G:($G(HLARY(0))'>0) EXIT + ;Deliver message to each subscriber + S HLEIDS=0 + F S HLEIDS=$O(HLARY(HLEIDS)) Q:(HLEIDS'>0) D + .; + .;**132 excluded subscribers ** + .N I,EXCLUDE + .S (EXCLUDE,I)=0 + .F S I=$O(HLP("EXCLUDE SUBSCRIBER",I)) Q:'I I $G(HLP("EXCLUDE SUBSCRIBER",I))=HLEIDS S EXCLUDE=1 Q + .Q:EXCLUDE + .;** 132 end ** + .; + .;Get pointer to receiving application + .S HLCLIENT=+HLARY(HLEIDS),HL("EIDS")=HLEIDS,HLERROR="" + .Q:(HLCLIENT'>0) + .;Check and execute ROUTING LOGIC **CIRN** + .S HLX=$G(^ORD(101,HLEIDS,774)) + .I HLX]"" D Q + ..N HLQUIT,HLNODE,HLNEXT + ..S HLQUIT=0,HLNODE="",HLNEXT="D HLNEXT^HLCSUTL" + ..X HLX I $D(HLL("LINKS")) D FWD^HLCS2 K HLL ;**CIRN** + .;Get pointer to logical link + .S HLOGLINK=$P(HLARY(HLEIDS),"^",2) + .;Determine if receiving application is internal or external + .; Logical link has a value for external applications + .; Logical link is NULL for internal applications + .I (HLOGLINK) D COTS Q + .;Create 'incoming' message based on 'outgoing' message (internal) + .D DHCP(HLMTIEN,HLEIDS,HLCLIENT) + .Q:(HLERROR) + .;Process the 'incoming' message + .S HLERROR="" + .D PROCESS^HLTP0(HLMSGPTR,"DHCP","",.HLERROR) + .;Update Status of 'incoming' message to SUCCESSFULLY COMPLETED + .; or ERROR DURING TRANSMISSION + .D STATUS^HLTF0(HLMSGPTR,$S(HLERROR:4,1:3),$S(HLERROR:+HLERROR,1:""),$S(HLERROR:$P(HLERROR,"^",2),1:""),,$S($G(HLERR("SKIP_EVENT"))=1:1,1:0)) + .I $D(HLL("LINKS")) D FWD^HLCS2 K HLL ;**CIRN** + D ADD^HLCS2 ;**CIRN** +EXIT S HLRESULT=HLERROR + Q +COTS ;Internal to external communication + ;Create child entry in Message Text file + N HLTCP,HLTCPI,HLTCPO + D SEND^HLMA2(HLEIDS,HLMTIEN,HLCLIENT,"D",.HLMTIENS,HLOGLINK) + I ((+HLMTIENS)'>0) S HLERROR=HLMTIENS Q + ;'Pass' message to background filer by setting status of child + ; to PENDING TRANSMISSION + D STATUS^HLTF0(HLMTIENS,1) + Q +DHCP(HLMTIEN,HLEIDS,HLCLIENT) ;Internal to internal communication + ; + ;Input : HLMTIEN - Pointer to parent outgoing message (file #772) + ; HLEIDS - Pointer to subscribing protocol (file #101) + ; HLCLIENT - Pointer to receiving application (file # 771) + ; + ;Output : HLMTIENS - Pointer to child outgoing message (file #772) + ; HLMSGPTR - Pointer to [parent] incoming message (file #772) + ; HLERROR - ErrorCode ^ ErrorText + ; + ;Notes : This module only copies the outgoing message into an incoming + ; message. Delivery of the message (i.e. processing of it) + ; must be done by the calling application. + ; : Message/batch header (MSH/BSH) is built and placed in the + ; incoming message + ; : HLMTIENS, HLMSGPTR, and HLERROR will be initialized + ; : Existance and validity of input is assumed + ; + ;Declare variables + N MSGID,MSGDT,MSGDTH,HDR2BLD,TMP,HLHDR,BHSHDR + S HLERROR="" + S HLMTIENS=0 + S HLMSGPTR=0 + ;Create child entry in Message Text file + D SEND^HLMA2(HLEIDS,HLMTIEN,HLCLIENT,"D",.HLMTIENS) + I ((+HLMTIENS)'>0) S HLERROR=HLMTIENS Q + ;'Receive' message by making an incoming message + ;Determine type of header to build + S TMP=$G(^HL(772,HLMTIEN,0)) + S HDR2BLD=$P(TMP,"^",14) + ;Build message header (MSH) + I (HDR2BLD="M") D Q:(HLERROR) + .S TMP="" + .D HEADER^HLCSHDR(HLMTIENS,.TMP) + .Q:(TMP="") + .;Error building header + .S HLERROR="4^Unable to build message header => "_TMP + .D STATUS^HLTF0(HLMTIENS,4,0,$P(HLERROR,"^",2)) + ;Build batch header (BHS or FHS) + I (HDR2BLD'="M") D Q:(HLERROR) + .S TMP="" + .D BHSHDR^HLCSHDR(HLMTIENS) + .S:($E(HLHDR(1),1)="-") TMP=$P(HLHDR(1),"^",2) + .Q:(TMP="") + .;Error building header + .S HLERROR="4^Unable to build batch header => "_TMP + .D STATUS^HLTF0(HLMTIENS,4,0,$P(HLERROR,"^",2)) + ;Create entry for 'incoming' message + D CREATE^HLTF(.MSGID,.HLMSGPTR,.MSGDT,.MSGDTH) + ;Move header and rest of message into 'incoming' message + I (HDR2BLD="M") D + .;Use MSH as header + .D MRGINT^HLTF1(HLMTIEN,HLMSGPTR,"HLHDR") + I (HDR2BLD'="M") D + .;Use BHS or FHS as header + .D MRGINT^HLTF1(HLMTIEN,HLMSGPTR,"BHSHDR") + ;Set status of outgoing message to AWAITING ACKNOWLEDGEMENT + D STATUS^HLTF0(HLMTIENS,$S($P(^HL(772,HLMTIEN,0),U,7):3,1:2)) + ;Set status of 'incoming' message to AWAITING PROCESSING + D STATUS^HLTF0(HLMSGPTR,9) + Q +SENDACK(HLMTIENA,HLEID,HLEIDS,HLRESULT) ;Send an HL7 acknowledgement/response + ;HLMTIENA=The IEN of the parent acknowledgment/response message in + ; file # 772 + ;HLEIDS=The IEN of the Subscribing protocol in file # 101 + ;HLEID=The IEN of the Event Driver protocol in file #101 + ;HLRESULT=Variable for any error text (pass by reference) + ; + N HLERROR,HLOGLINK,HLCLIENT,HLMTIENS,HLMSGPTR,HLCLNODE + I $G(HLMTIENA)=""!($G(HLEID)="")!($G(HLEIDS)="") S HLERROR="0^7^"_$G(^HL(771.7,7,0))_"at SENDACK^HLCS entry point" G EXIT2 + S HLCLNODE=$G(^ORD(101,HLEID,770)) + ;Get pointers to Logical Link & receiving application + S HLOGLINK=$P($G(^ORD(101,HLEIDS,770)),U,7) + ;Application needed to dynamically address the ACK (tcp/ip) + ;(set HLL("LINKS") array before calling GENACK) + I $D(HLL("LINKS")) D Q:'HLOGLINK + .S HLOGLINK=$P(HLL("LINKS",1),"^",2) Q:HLOGLINK="" + .K HLL("LINKS") + .I +HLOGLINK'=HLOGLINK S HLOGLINK=$O(^HLCS(870,"B",HLOGLINK,0)) + S HLCLIENT=$P(HLCLNODE,U,1) + Q:('HLCLIENT) + ;Determine if receiving application is internal or external + ; Logical link has a value for external applications + ; Logical link is NULL for internal applications + I (HLOGLINK) D COTSACK Q + ;Create 'incoming' message based on 'outgoing' message (internal) + D DHCP(HLMTIENA,HLEID,HLCLIENT) + ;Process the 'incoming' message + I (HLMSGPTR) D + .S HLERROR="" + .D PROCESS^HLTP0(HLMSGPTR,"DHCP","",.HLERROR) + ;Update Status of 'incoming' message to SUCCESSFULLY COMPLETED + ; or ERROR DURING TRANSMISSION + D STATUS^HLTF0(HLMSGPTR,$S(HLERROR:4,1:3),$S(HLERROR:+HLERROR,1:""),$S(HLERROR:$P(HLERROR,"^",2),1:"")) +EXIT2 ; + S HLRESULT=$G(HLERROR) + Q +COTSACK ;Internal to external communication of acknowledgements/responses + ;Create child entry in Message Text file + D SEND^HLMA2(HLEID,HLMTIENA,HLCLIENT,"D",.HLMTIENS,HLOGLINK) + ;'Pass' message to background filer by setting status of child + ; to PENDING TRANSMISSION + D STATUS^HLTF0(HLMTIENS,1) + Q diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLCS2.m b/r/HEALTH_LEVEL_SEVEN-HL/HLCS2.m index 4020fdee..5d9adb1a 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLCS2.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLCS2.m @@ -1,180 +1,149 @@ -HLCS2 ;SF/JC - More Communication Server utilities ; 10/04/2007 14:31 - ;;1.6;HEALTH LEVEL SEVEN;**14,40,43,49,57,58,82,84,109,122**;Oct 13, 1995;Build 14 - ;Per VHA Directive 2004-038, this routine should not be modified. -FWD ; Add supplemental clients from HLL("LINKS") to HLSUP array - ;This enhancement also supports distribution of a message to - ;the same client over multiple logical links. - Q:'$D(HLL("LINKS")) - N CNT,LNK,CLIAP - S CNT=0,ROUTINE=1 F S CNT=$O(HLL("LINKS",CNT)) Q:CNT<1 D - . S PTR=$P(HLL("LINKS",CNT),"^"),LNK=$P(HLL("LINKS",CNT),"^",2) - . Q:PTR="" I +PTR<1 S PTR=$O(^ORD(101,"B",PTR,0)) Q:PTR<1 - . ; - . ; patch HL*1.6*122: excluding subscribers defined in - . ; HLP("EXCLUDE SUBSCRIBER",I) = ien of subscriber - . N I,EXCLUDE - . S (EXCLUDE,I)=0 - . F S I=$O(HLP("EXCLUDE SUBSCRIBER",I)) Q:'I D Q:EXCLUDE - .. N TEMP - .. S TEMP=HLP("EXCLUDE SUBSCRIBER",I) - .. I 'TEMP,TEMP]"" S TEMP=$O(^ORD(101,"B",TEMP,0)) - .. I TEMP=PTR S EXCLUDE=1 - . Q:EXCLUDE - . ; - . Q:LNK="" I +LNK<1 S LNK=$O(^HLCS(870,"B",LNK,0)) Q:LNK<1 - . Q:'$D(^HLCS(870,LNK)) - . S CLIAP=$$PTR^HLUTIL2(PTR) - . ; patch HL*1.6*122: add the 3rd component as receiving facility - . ; S HLSUP("S",PTR,+LNK)=CLIAP_$S(CLIAP<1:U_HLL("LINKS",CNT),1:"") - . S HLSUP("S",PTR,+LNK)=CLIAP_U_$S(CLIAP<1:HLL("LINKS",CNT),1:$P(HLL("LINKS",CNT),"^",3)) - Q -ADD ;Deliver message to supplemental client list. - ;Invoked by HLTP before and after processing normal clients - ;Only processes remote links. Local clients must be subscribing - ;protocols. - Q:'$D(HLSUP("S")) - N HLTCP,HLTCPI,HLTCPO,ZHLEIDS,ZLCLIENT,ZLOGLINK,ZMTIENS - S ZHLEIDS=0 F S ZHLEIDS=$O(HLSUP("S",ZHLEIDS)) Q:ZHLEIDS<1 D - .S ZLOGLINK=0 F S ZLOGLINK=$O(HLSUP("S",ZHLEIDS,ZLOGLINK)) Q:ZLOGLINK<1 D - ..S ZLCLIENT=+HLSUP("S",ZHLEIDS,ZLOGLINK) - ..I ZLCLIENT<1 S:$G(HLERROR)="" HLERROR="15^Invalid Subscriber Protocol in HLL('LINKS'): "_$P(HLSUP("S",ZHLEIDS,ZLOGLINK),U,2,9) Q - .. ; patch HL*1.6*122 start - .. ; S HLOGLINK=ZLOGLINK D SEND^HLMA2(ZHLEIDS,HLMTIEN,ZLCLIENT,"D",.ZMTIENS,ZLOGLINK),STATUS^HLTF0(+ZMTIENS,1) - .. S HLOGLINK=ZLOGLINK - .. ; 3rd component for receiving facility - .. S ZMTIENS("REC-FACILITY")=$P(HLSUP("S",ZHLEIDS,ZLOGLINK),U,3) - .. D SEND^HLMA2(ZHLEIDS,HLMTIEN,ZLCLIENT,"D",.ZMTIENS,ZLOGLINK) - .. D STATUS^HLTF0(+ZMTIENS,1) - .. ; patch HL*1.6*122 end - .. ; - K HLL("LINKS"),HLSUP - Q -STALL ;STOP ALL LINKS AND FILERS - N DIR,Y - W ! S DIR(0)="Y",DIR("A")="Okay to shut down all Links and Filers" - D ^DIR - I 'Y!($D(DIRUT))!($D(DUOUT)) W !!,"Shutdown Aborted!" Q - W !,"Shutting down all Links and Filers..." - D CLEAR - D LLP(1) - Q -QUE ;Restart Filers and AUTOSTART Logical Links after system re-boot - N DIR,Y - I '$D(ZTQUEUED) D Q:'Y!($D(DIRUT))!($D(DUOUT)) - .W ! S DIR(0)="Y",DIR("A")="Shutdown and restart ALL AUTOSTART links and filers. Okay" - .D ^DIR - .I 'Y!($D(DIRUT))!($D(DUOUT)) W !!,"RESTART Aborted!" Q - .W !,"Restarting all Autostart-Enabled Links and Filers..." - D CLEAR - D STARTF - D LLP(0) - D STRT - Q -CLEAR ;Reset state of 869.3 - S DA(1)=1,DA=0,DIK="^HLCS(869.3,1,2," - F S DA=$O(^HLCS(869.3,DA(1),2,DA)) Q:DA<1 D ^DIK - S DA=0,DIK="^HLCS(869.3,1,3," - F S DA=$O(^HLCS(869.3,DA(1),3,DA)) Q:DA<1 D ^DIK - Q -STARTF ;Start filers - ;Get Defaults - N TMP,PTR,DEFCNT,DA,HLCNT,HLNODE1 - S PTR=+$O(^HLCS(869.3,0)) Q:'PTR - ;default # of incoming filers - S HLNODE1=$G(^HLCS(869.3,PTR,1)),DEFCNT=+$P(HLNODE1,U) S:'DEFCNT DEFCNT=1 - F HLCNT=1:1:DEFCNT S TMP=$$TASKFLR^HLCS1("IN") - ;default # of outgoing filers - S DEFCNT=+$P(HLNODE1,U,2) S:'DEFCNT DEFCNT=1 - F HLCNT=1:1:DEFCNT S TMP=$$TASKFLR^HLCS1("OUT") - Q -LLP(ALL) ;Stop Logical Links - ;ALL=1 OR 0 IF zero, only AUTOSTART LINKS get stopped - N HLDP,HLDP0,HLPARM0,HLPARM4,HLJ,X,Y S HLDP=0 - F S HLDP=$O(^HLCS(870,HLDP)) Q:'HLDP S HLDP0=$G(^(HLDP,0)),X=+$P(HLDP0,U,3) D:X - .;skip this link if not stopping all and Autostart not enabled - . I 'ALL&('$P(HLDP0,U,6)) Q - . S HLPARM4=$G(^HLCS(870,HLDP,400)) - . ; patch HL*1.6*122 - . ; TCP Multi listener: quit if TCP service as GT.M, DSM, - . ; or Cache/VMS - . I $P(HLPARM4,U,3)="M" Q:^%ZOSF("OS")'["OpenM" Q:$$OS^%ZOSV["VMS" - . ; - . ;4=status,10=Time Stopped,9=Time Started,11=Task Number,3=Device Type,14=shutdown? - . S X="HLJ(870,"""_HLDP_","")",@X@(10)=$$NOW^XLFDT,(@X@(11),@X@(9))="@",@X@(14)=1 - . I "Shutdown,SHUTDOWN"'[$P(HLDP0,U,5) S @X@(4)="Halting" - . I $P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4)),'$P(HLDP0,U,12) S @X@(4)="Shutdown" - . D FILE^HLDIE("","HLJ","","LLP","HLCS2") ;HL*1.6*109 - . I ^%ZOSF("OS")["OpenM",($P(HLPARM4,U,3)="M"!($P(HLPARM4,U,3)="S")) D - .. ; pass task number to stop listener - .. S:$P(HLDP0,U,12) X=$$ASKSTOP^%ZTLOAD(+$P(HLDP0,U,12)) - ; patch HL*1.6*122 start - ; .. D CALL^%ZISTCP($P(HLPARM4,U),$P(HLPARM4,U,2),10) - ; .. I POP D HOME^%ZIS Q - ; .. D CLOSE^%ZISTCP - ; patch HL*1.6*122 end - Q -STRT ;Start Links - N HLDP,HLDP0,HLDAPP,HLTYPTR,HLBGR,HLENV,HLPARAM0,HLPARM4,HLQUIT,ZTRTN,ZTDESC,ZTSK,ZTCPU - S HLDP=0 - F S HLDP=$O(^HLCS(870,HLDP)) Q:HLDP<1 S HLDP0=$G(^(HLDP,0)) D - . S HLPARM4=$G(^HLCS(870,HLDP,400)) - . ;quit if no parameters or AUTOSTART is disabled - . Q:'$P(HLDP0,U,6) - . ;HLDAPP=LL name, HLTYPTR=LL type, HLBGR=routine, HLENV=environment check - . S HLDAPP=$P(HLDP0,U),HLTYPTR=+$P(HLDP0,U,3),HLBGR=$G(^HLCS(869.1,HLTYPTR,100)),HLENV=$G(^(200)) - . ;quit if no LL type or no routine - . Q:'HLTYPTR!(HLBGR="") - . I HLENV'="" K HLQUIT X HLENV Q:$D(HLQUIT) - . ; patch HL*1.6*122 - . ; TCP Multi listener: quit if TCP service as GT.M, DSM, - . ; or Cache/VMS - . I $P(HLPARM4,U,3)="M" Q:^%ZOSF("OS")'["OpenM" Q:$$OS^%ZOSV["VMS" - . ; - . I $P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4)) D Q - .. ;4=status 9=Time Started, 10=Time Stopped, 11=Task Number - .. ;14=Shutdown LLP, 3=Device Type, 18=Gross Errors - .. N HLJ,X - .. I $P(HLDP0,U,15)=0 Q - .. L +^HLCS(870,HLDP,0):2 - .. E Q - .. S X="HLJ(870,"""_HLDP_","")" - .. S @X@(4)="Enabled",@X@(9)=$$NOW^XLFDT,@X@(14)=0 - .. D FILE^HLDIE("","HLJ","","STRT","HLCS2") ; HL*1.6*109 - .. L -^HLCS(870,HLDP,0) - .. Q - . S ZTRTN=$P(HLBGR," ",2),ZTIO="",ZTDTH=$H,HLTRACE="" - . S ZTDESC=HLDAPP_" Low Level Protocol",ZTSAVE("HLDP")="" - . ;get startup node - . I $P(HLPARM4,U,6),$D(^%ZIS(14.7,+$P(HLPARM4,U,6),0)) S ZTCPU=$P(^(0),U) - . D ^%ZTLOAD - Q -SITEP ;Edit Site Parameters - S DDSFILE=869.3,DA=1,DR="[HL SITE PARAMETERS]" D ^DDS - Q -PARAM() ;Return HL7 site parameters - ;HLPARAM=domain ien^domain name^production or test^institution ien^ - ;institution name^institution number^mail group ien^mail group name^ - ;purge completed messages^purge awaiting ack messages^purge all msgs^ - ;default retention - N HLX,HLX4,HLX5,HLDOMP,HLDOMN,HLPROD,HLINSP,HLINSN,HLINSNM,HLMAILP,HLMAILN,HLPARAM,HLPRGAA,HLPRGALL,HLPRGCMP,HLDEFRET - S HLX=$G(^HLCS(869.3,1,0)) - S HLX4=$G(^HLCS(869.3,1,4)) - S HLX5=$G(^HLCS(869.3,1,5)) - S HLDOMP=$P(HLX,U,2) I HLDOMP S HLDOMN=$P(^DIC(4.2,HLDOMP,0),U) - S HLPROD=$P(HLX,U,3) - S HLINSP=$P(HLX,U,4) I HLINSP S HLINSN=$P(^DIC(4,HLINSP,0),U),HLINSNM=$P($G(^DIC(4,HLINSP,99)),U) - S HLMAILP=$P(HLX,U,5) I HLMAILP S HLMAILN=$P(^XMB(3.8,HLMAILP,0),U) - S HLPRGCMP=$P(HLX4,U),HLPRGAA=$P(HLX4,U,2),HLPRGALL=$P(HLX4,U,3) - S HLDEFRET=$P(HLX5,U) - S HLPARAM=HLDOMP_U_$G(HLDOMN)_U_$G(HLPROD)_U_HLINSP_U_$G(HLINSN)_U_$G(HLINSNM)_U_HLMAILP_U_$G(HLMAILN)_U_HLPRGCMP_U_HLPRGAA_U_HLPRGALL_U_HLDEFRET - Q HLPARAM - ; -GETAPP(HLAPP) ;Function to Retrieve parameters pertaining to a specific sending or receiving application - ;HLAPP=APPLICATION NAME OR IEN OF FILE 771 - ;Returns MAIL GROUP NAME^'a' or 'i' (active or inactive) - S HLAPP=$G(HLAPP) - I HLAPP]"",'HLAPP S HLAPP=$O(^HL(771,"B",$E(HLAPP,1,30),0)) - I 'HLAPP Q "" - I HLAPP S HLM=$P(^HL(771,HLAPP,0),U,4) - I HLM S HLM=$P($G(^XMB(3.8,HLM,0)),U) - Q $G(HLM)_U_$P(^HL(771,HLAPP,0),U,2) +HLCS2 ;SF/JC - More Communication Server utilities ; 12/31/2003 17:50 + ;;1.6;HEALTH LEVEL SEVEN;**14,40,43,49,57,58,82,84,109**;Oct 13, 1995 +FWD ; Add supplemental clients from HLL("LINKS") to HLSUP array + ;This enhancement also supports distribution of a message to + ;the same client over multiple logical links. + Q:'$D(HLL("LINKS")) + N CNT,LNK,CLIAP + S CNT=0,ROUTINE=1 F S CNT=$O(HLL("LINKS",CNT)) Q:CNT<1 D + . S PTR=$P(HLL("LINKS",CNT),"^"),LNK=$P(HLL("LINKS",CNT),"^",2) + . Q:PTR="" I +PTR<1 S PTR=$O(^ORD(101,"B",PTR,0)) Q:PTR<1 + . Q:LNK="" I +LNK<1 S LNK=$O(^HLCS(870,"B",LNK,0)) Q:LNK<1 + . Q:'$D(^HLCS(870,LNK)) + . S CLIAP=$$PTR^HLUTIL2(PTR) + . S HLSUP("S",PTR,+LNK)=CLIAP_$S(CLIAP<1:U_HLL("LINKS",CNT),1:"") + Q +ADD ;Deliver message to supplemental client list. + ;Invoked by HLTP before and after processing normal clients + ;Only processes remote links. Local clients must be subscribing + ;protocols. + Q:'$D(HLSUP("S")) + N HLTCP,HLTCPI,HLTCPO,ZHLEIDS,ZLCLIENT,ZLOGLINK,ZMTIENS + S ZHLEIDS=0 F S ZHLEIDS=$O(HLSUP("S",ZHLEIDS)) Q:ZHLEIDS<1 D + .S ZLOGLINK=0 F S ZLOGLINK=$O(HLSUP("S",ZHLEIDS,ZLOGLINK)) Q:ZLOGLINK<1 D + ..S ZLCLIENT=+HLSUP("S",ZHLEIDS,ZLOGLINK) + ..I ZLCLIENT<1 S:$G(HLERROR)="" HLERROR="15^Invalid Subscriber Protocol in HLL('LINKS'): "_$P(HLSUP("S",ZHLEIDS,ZLOGLINK),U,2,9) Q + ..S HLOGLINK=ZLOGLINK D SEND^HLMA2(ZHLEIDS,HLMTIEN,ZLCLIENT,"D",.ZMTIENS,ZLOGLINK),STATUS^HLTF0(+ZMTIENS,1) + K HLL("LINKS"),HLSUP + Q +STALL ;STOP ALL LINKS AND FILERS + N DIR,Y + W ! S DIR(0)="Y",DIR("A")="Okay to shut down all Links and Filers" + D ^DIR + I 'Y!($D(DIRUT))!($D(DUOUT)) W !!,"Shutdown Aborted!" Q + W !,"Shutting down all Links and Filers..." + D CLEAR + D LLP(1) + Q +QUE ;Restart Filers and AUTOSTART Logical Links after system re-boot + N DIR,Y + I '$D(ZTQUEUED) D Q:'Y!($D(DIRUT))!($D(DUOUT)) + .W ! S DIR(0)="Y",DIR("A")="Shutdown and restart ALL AUTOSTART links and filers. Okay" + .D ^DIR + .I 'Y!($D(DIRUT))!($D(DUOUT)) W !!,"RESTART Aborted!" Q + .W !,"Restarting all Autostart-Enabled Links and Filers..." + D CLEAR + D STARTF + D LLP(0) + D STRT + Q +CLEAR ;Reset state of 869.3 + S DA(1)=1,DA=0,DIK="^HLCS(869.3,1,2," + F S DA=$O(^HLCS(869.3,DA(1),2,DA)) Q:DA<1 D ^DIK + S DA=0,DIK="^HLCS(869.3,1,3," + F S DA=$O(^HLCS(869.3,DA(1),3,DA)) Q:DA<1 D ^DIK + Q +STARTF ;Start filers + ;Get Defaults + N TMP,PTR,DEFCNT,DA,HLCNT,HLNODE1 + S PTR=+$O(^HLCS(869.3,0)) Q:'PTR + ;default # of incoming filers + S HLNODE1=$G(^HLCS(869.3,PTR,1)),DEFCNT=+$P(HLNODE1,U) S:'DEFCNT DEFCNT=1 + F HLCNT=1:1:DEFCNT S TMP=$$TASKFLR^HLCS1("IN") + ;default # of outgoing filers + S DEFCNT=+$P(HLNODE1,U,2) S:'DEFCNT DEFCNT=1 + F HLCNT=1:1:DEFCNT S TMP=$$TASKFLR^HLCS1("OUT") + Q +LLP(ALL) ;Stop Logical Links + ;ALL=1 OR 0 IF zero, only AUTOSTART LINKS get stopped + N HLDP,HLDP0,HLPARM0,HLPARM4,HLJ,X,Y S HLDP=0 + F S HLDP=$O(^HLCS(870,HLDP)) Q:'HLDP S HLDP0=$G(^(HLDP,0)),X=+$P(HLDP0,U,3) D:X + .;skip this link if not stopping all and Autostart not enabled + . I 'ALL&('$P(HLDP0,U,6)) Q + . S HLPARM4=$G(^HLCS(870,HLDP,400)) + . ;TCP Multi listener for non-Cache uses UCX + . I $P(HLPARM4,U,3)="M" Q:^%ZOSF("OS")'["OpenM" Q:$$OS^%ZOSV["VMS" + . ;4=status,10=Time Stopped,9=Time Started,11=Task Number,3=Device Type,14=shutdown? + . S X="HLJ(870,"""_HLDP_","")",@X@(4)="Halting",@X@(10)=$$NOW^XLFDT,(@X@(11),@X@(9))="@",@X@(14)=1 + . I $P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4)),'$P(HLDP0,U,12) S @X@(4)="Shutdown" + . D FILE^HLDIE("","HLJ","","LLP","HLCS2") ;HL*1.6*109 + . ;Cache system, need to open TCP port to release job + . I ^%ZOSF("OS")["OpenM",($P(HLPARM4,U,3)="M"!($P(HLPARM4,U,3)="S")) D + .. ;pass task number to stop listener + .. S:$P(HLDP0,U,12) X=$$ASKSTOP^%ZTLOAD(+$P(HLDP0,U,12)) + .. D CALL^%ZISTCP($P(HLPARM4,U),$P(HLPARM4,U,2),10) + .. I POP D HOME^%ZIS Q + .. D CLOSE^%ZISTCP + Q +STRT ;Start Links + N HLDP,HLDP0,HLDAPP,HLTYPTR,HLBGR,HLENV,HLPARAM0,HLPARM4,HLQUIT,ZTRTN,ZTDESC,ZTSK,ZTCPU + S HLDP=0 + F S HLDP=$O(^HLCS(870,HLDP)) Q:HLDP<1 S HLDP0=$G(^(HLDP,0)) D + . S HLPARM4=$G(^HLCS(870,HLDP,400)) + . ;quit if no parameters or AUTOSTART is disabled + . Q:'$P(HLDP0,U,6) + . ;HLDAPP=LL name, HLTYPTR=LL type, HLBGR=routine, HLENV=environment check + . S HLDAPP=$P(HLDP0,U),HLTYPTR=+$P(HLDP0,U,3),HLBGR=$G(^HLCS(869.1,HLTYPTR,100)),HLENV=$G(^(200)) + . ;quit if no LL type or no routine + . Q:'HLTYPTR!(HLBGR="") + . I HLENV'="" K HLQUIT X HLENV Q:$D(HLQUIT) + . ;TCP Multi listener for non-Cache uses UCX + . I $P(HLPARM4,U,3)="M" Q:^%ZOSF("OS")'["OpenM" Q:$$OS^%ZOSV["VMS" + . I $P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4)) D Q + .. ;4=status 9=Time Started, 10=Time Stopped, 11=Task Number + .. ;14=Shutdown LLP, 3=Device Type, 18=Gross Errors + .. N HLJ,X + .. I $P(HLDP0,U,15)=0 Q + .. L +^HLCS(870,HLDP,0):2 + .. E Q + .. S X="HLJ(870,"""_HLDP_","")" + .. S @X@(4)="Enabled",@X@(9)=$$NOW^XLFDT,@X@(14)=0 + .. D FILE^HLDIE("","HLJ","","STRT","HLCS2") ; HL*1.6*109 + .. L -^HLCS(870,HLDP,0) + .. Q + . S ZTRTN=$P(HLBGR," ",2),ZTIO="",ZTDTH=$H,HLTRACE="" + . S ZTDESC=HLDAPP_" Low Level Protocol",ZTSAVE("HLDP")="" + . ;get startup node + . I $P(HLPARM4,U,6),$D(^%ZIS(14.7,+$P(HLPARM4,U,6),0)) S ZTCPU=$P(^(0),U) + . D ^%ZTLOAD + Q +SITEP ;Edit Site Parameters + S DDSFILE=869.3,DA=1,DR="[HL SITE PARAMETERS]" D ^DDS + Q +PARAM() ;Return HL7 site parameters + ;HLPARAM=domain ien^domain name^production or test^institution ien^ + ;institution name^institution number^mail group ien^mail group name^ + ;purge completed messages^purge awaiting ack messages^purge all msgs^ + ;default retention + N HLX,HLX4,HLX5,HLDOMP,HLDOMN,HLPROD,HLINSP,HLINSN,HLINSNM,HLMAILP,HLMAILN,HLPARAM,HLPRGAA,HLPRGALL,HLPRGCMP,HLDEFRET + S HLX=$G(^HLCS(869.3,1,0)) + S HLX4=$G(^HLCS(869.3,1,4)) + S HLX5=$G(^HLCS(869.3,1,5)) + S HLDOMP=$P(HLX,U,2) I HLDOMP S HLDOMN=$P(^DIC(4.2,HLDOMP,0),U) + S HLPROD=$P(HLX,U,3) + S HLINSP=$P(HLX,U,4) I HLINSP S HLINSN=$P(^DIC(4,HLINSP,0),U),HLINSNM=$P($G(^DIC(4,HLINSP,99)),U) + S HLMAILP=$P(HLX,U,5) I HLMAILP S HLMAILN=$P(^XMB(3.8,HLMAILP,0),U) + S HLPRGCMP=$P(HLX4,U),HLPRGAA=$P(HLX4,U,2),HLPRGALL=$P(HLX4,U,3) + S HLDEFRET=$P(HLX5,U) + S HLPARAM=HLDOMP_U_$G(HLDOMN)_U_$G(HLPROD)_U_HLINSP_U_$G(HLINSN)_U_$G(HLINSNM)_U_HLMAILP_U_$G(HLMAILN)_U_HLPRGCMP_U_HLPRGAA_U_HLPRGALL_U_HLDEFRET + Q HLPARAM + ; +GETAPP(HLAPP) ;Function to Retrieve parameters pertaining to a specific sending or receiving application + ;HLAPP=APPLICATION NAME OR IEN OF FILE 771 + ;Returns MAIL GROUP NAME^'a' or 'i' (active or inactive) + S HLAPP=$G(HLAPP) + I HLAPP]"",'HLAPP S HLAPP=$O(^HL(771,"B",$E(HLAPP,1,30),0)) + I 'HLAPP Q "" + I HLAPP S HLM=$P(^HL(771,HLAPP,0),U,4) + I HLM S HLM=$P($G(^XMB(3.8,HLM,0)),U) + Q $G(HLM)_U_$P(^HL(771,HLAPP,0),U,2) diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLCSGTM.m b/r/HEALTH_LEVEL_SEVEN-HL/HLCSGTM.m index 465b6fbb..b5ff5457 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLCSGTM.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLCSGTM.m @@ -1,58 +1,75 @@ -HLCSGTM ;OIFO-O/RWF - (TCP/IP) GT.M Linux ;08/13/2007 - ;;1.6;HEALTH LEVEL SEVEN;**122**;Oct 13, 1995;Build 14 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; - ; 1. port number is input from VMS COM file, such as HLSxxxxDSM.COM, - ; HLSxxxxCACHE.COM, or HLSxxxxGTM.COM file, where xxxx is port - ; number. - ; 2. find the ien of #870(logical link file) for the multi-listener - Q - ; -IEN(HLPORT) ; - ; HLIEN870: ien in #870 (logical link file) - ; HLPRTS: port number in entry to be tested - ; - N HLPRTS,HLIEN870 - I '$G(HLPORT) D ^%ZTER Q - S HLIEN870=0 - F S HLIEN870=$O(^HLCS(870,"E","M",HLIEN870)) Q:'HLIEN870 D Q:(HLPRTS=HLPORT) - . S HLPRTS=$P(^HLCS(870,HLIEN870,400),"^",2) - I 'HLIEN870 D ^%ZTER Q - ; - Q HLIEN870 - ; -GTMLNX ; From Linux xinetd script - ;Get port from ZSHOW "D" - S U="^",$ZT="",$ET="D ^%ZTER HALT" ;Setup the error trap - ; GTM specific code - S IO=$P X "U IO:(nowrap:nodelimiter:IOERROR=""TRAP"")" ;Setup device - S @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""") - K ^TMP($J) ZSHOW "D":^TMP($J) - F %=1:1 Q:'$D(^TMP($J,"D",%)) S X=^(%) Q:X["LOCAL" - S IO("IP")=$P($P(X,"REMOTE=",2),"@"),IO("PORT")=+$P($P(X,"LOCAL=",2),"@",2) - S %=$P($ZTRNLNM("SSH_CLIENT")," ") S:%="" %=$ZTRNLNM("REMOTEHOST") - S HLDP=$$IEN(IO("PORT")) - ; - D LISTEN^HLCSTCP - Q - ; - ;Sample Linux script - ;#!/bin/bash - ;#HL7 Listener - ;cd /home/vista/dev/ - ;. ./gtmprofile - ;#env > hl7log.txt - ;$gtm_dist/mumps -r GTMLNX^HLCSGTM - ;exit 0 - ; - ;Sample xinetd config file - ;service hl7tcp - ;{ - ; socket_type = stream - ; user = gtmuser - ; wait = no - ; disable = no - ; server = /bin/bash - ; server_args = -l /home/vista/dev/hl7tcp.sh - ; passenv = REMOTE_HOST - ;} +HLCSGTM ;OIFO-O/RWF - (TCP/IP) GT.M Linux ;08/13/2007 + ;;1.6;HEALTH LEVEL SEVEN;**122**;Oct 13, 1995;Build 4;WorldVistA 30-Jan-08 + ;Per VHA Directive 2004-038, this routine should not be modified. + ; + ; 1. port number is input from VMS COM file, such as HLSxxxxDSM.COM, + ; HLSxxxxCACHE.COM, or HLSxxxxGTM.COM file, where xxxx is port + ; number. + ; 2. find the ien of #870(logical link file) for the multi-listener + ;Modified from FOIA VISTA, + ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;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 Street, Fifth Floor, Boston, MA 02110-1301 USA. + Q + ; +IEN(HLPORT) ; + ; HLIEN870: ien in #870 (logical link file) + ; HLPRTS: port number in entry to be tested + ; + N HLPRTS,HLIEN870 + I '$G(HLPORT) D ^%ZTER Q + S HLIEN870=0 + F S HLIEN870=$O(^HLCS(870,"E","M",HLIEN870)) Q:'HLIEN870 D Q:(HLPRTS=HLPORT) + . S HLPRTS=$P(^HLCS(870,HLIEN870,400),"^",2) + I 'HLIEN870 D ^%ZTER Q + ; + Q HLIEN870 + ; +GTMLNX ; From Linux xinetd script + ;Get port from ZSHOW "D" + S U="^",$ZT="",$ET="D ^%ZTER HALT" ;Setup the error trap + ; GTM specific code + S IO=$P X "U IO:(nowrap:nodelimiter:IOERROR=""TRAP"")" ;Setup device + S @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""") + K ^TMP($J) ZSHOW "D":^TMP($J) + F %=1:1 Q:'$D(^TMP($J,"D",%)) S X=^(%) Q:X["LOCAL" + S IO("IP")=$P($P(X,"REMOTE=",2),"@"),IO("PORT")=+$P($P(X,"LOCAL=",2),"@",2) + S %=$P($ZTRNLNM("SSH_CLIENT")," ") S:%="" %=$ZTRNLNM("REMOTEHOST") + S HLDP=$$IEN(IO("PORT")) + ; + D LISTEN^HLCSTCP + Q + ; + ;Sample Linux script + ;#!/bin/bash + ;#HL7 Listener + ;cd /home/vista/dev/ + ;. ./gtmprofile + ;#env > hl7log.txt + ;$gtm_dist/mumps -r GTMLNX^HLCSGTM + ;exit 0 + ; + ;Sample xinetd config file + ;service hl7tcp + ;{ + ; socket_type = stream + ; user = gtmuser + ; wait = no + ; disable = no + ; server = /bin/bash + ; server_args = -l /home/vista/dev/hl7tcp.sh + ; passenv = REMOTE_HOST + ;} diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLCSHDR1.m b/r/HEALTH_LEVEL_SEVEN-HL/HLCSHDR1.m index d68292d8..44cc8062 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLCSHDR1.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLCSHDR1.m @@ -1,249 +1,242 @@ -HLCSHDR1 ;SFIRMFO/RSD - Make HL7 header for TCP ;04/17/2007 - ;;1.6;HEALTH LEVEL SEVEN;**19,57,59,72,80,93,120,133,122**;Oct 13, 1995;Build 14 - ;Per VHA Directive 2004-038, this routine should not be modified. -HEADER(IEN,CLIENT,HLERROR) ; Create an HL7 MSH segment - ; - ;Input : IEN - Pointer to entry in Message Administration file (#773) - ; that HL7 MSH segment is being built for - ; CLIENT - IEN of the receiving application - ; HLERROR - Variable to return possible error text in - ; (pass by reference - only used when needed) - ; - ;Output : HLHDR(1) - HL7 MSH segment - ; HLHDR(2) - Continuation of HL7 MSH segment (if needed) - ; HLHDR(3) - Continuation of HL7 MSH segment (if needed) - ; - ;Notes : HLERROR will only be defined [on output] if an error occurs - ; : HLHDR() will not be defined [on output] if an error occurs - ; : HLHDR(2) & HLHDR(3) are continuation [or roll-over] nodes - ; and will only be used/defined when needed - ; - N ACKTO,ACCACK,APPACK,CHILD,CLNTAPP,CLNTFAC,CNTRY,EC,EVNTYPE,FS,HLDATE,HLHDRI,HLHDRL,HLID,HLPID,MSGTYPE,PROT,PROTS,SECURITY,SEND,SERAPP,SERFAC,TXTP,TXTP0,X,MSGEVN - N COMFLAG ; patch HL*1.6*120 - S HLERROR="" - S HLPARAM=$$PARAM^HLCS2 - D VAR Q:$G(HLERROR)]"" - ; The following line commented by HL*1.6*72 - ;I $D(^HLMA(IEN)) S $P(^HLMA(IEN,0),U,13)=MSGTYPE,$P(^HLMA(IEN,0),U,14)=$G(EVNTYPE) - ;Append event type - I $G(EVNTYPE)]"" S MSGTYPE=MSGTYPE_$E(EC,1)_EVNTYPE - ;Append message structure component - I $G(EVNTYPE)]"",$G(MSGEVN)]"" S MSGTYPE=MSGTYPE_$E(EC,1)_MSGEVN - ;Build MSH array - D RESET^HLCSHDR3 ;HL*1.6*93 - ; - ; patch HL*1.6*120 start - ; escape delimiters for SERAPP and CLNTAPP - ; escape component separator if the field is not consisted - ; of 3 components - S EC(1)=$E(EC,1) - S EC(2)=$E(EC,2) - S EC(3)=$E(EC,3) - S EC(4)=$E(EC,4) - S COMFLAG=1 - I $L(SERAPP,$E(EC,1))=3 S COMFLAG=0 - I (SERAPP[FS)!(SERAPP[EC(1))!(SERAPP[EC(2))!(SERAPP[EC(3))!(SERAPP[EC(4)) D - . S SERAPP=$$ESCAPE(SERAPP,COMFLAG) - S COMFLAG=1 - I $L(CLNTAPP,$E(EC,1))=3 S COMFLAG=0 - I (CLNTAPP[FS)!(CLNTAPP[EC(1))!(CLNTAPP[EC(2))!(CLNTAPP[EC(3))!(CLNTAPP[EC(4)) D - . S CLNTAPP=$$ESCAPE(CLNTAPP,COMFLAG) - ; patch HL*1.6*120 end - ; - S HLHDRI=1,HLHDR(1)="MSH"_FS_EC_FS_SERAPP,HLHDRL=$L(HLHDR(1)) - F X=SERFAC,CLNTAPP,CLNTFAC,HLDATE,SECURITY,MSGTYPE,HLID,HLPID,$P(PROT,U,9),"",$G(^HL(772,TXTP,1)),ACCACK,APPACK,CNTRY D MSH(X) - ;in preceeding line, "" is for sequence number - not supported - Q - ; -MSH(X) ;add X to HLHDR - S:HLHDRL+$L(X)>245 HLHDRI=HLHDRI+1,HLHDR(HLHDRI)="" - S HLHDR(HLHDRI)=HLHDR(HLHDRI)_FS_X,HLHDRL=$L(HLHDR(HLHDRI)) - Q -BHSHDR(IEN,CLIENT,HLERROR) ; Create Batch Header Segment - ; The BHS has 12 segments, of which 4 are blank. - ; INPUT: IEN - IEN of entry in file #772 - ; OUTPUT: HLHDR(1) and HLHDR(2) - the two lines with the 12 segs. - ; ready for adding to a message directly. - N ACKTO,ACCACK,ACKMID,APPACK,BNAME,BSTATUS,BTACK,CHILD,CLNTAPP ;HL*1.6*80 - N CLNTFAC,CNTRY,EC,EVNTYPE,FS,HLDATE,HLHDRI,HLHDRL,HLID,HLPID ;HL*1.6*80 - added HLPID - N PROT,PROTS,SECURITY,SEND,SERAPP,SERFAC,TXTP,TXTP0,X ;HL*1.6*80 - N COMFLAG ; patch HL*1.6*120 - S HLERROR="" - ; - S HLPARAM=$$PARAM^HLCS2 - D VAR Q:$G(HLERROR)]"" - ; The following line commented by HL*1.6*72 - ;I $D(^HLMA(IEN)) S $P(^HLMA(IEN,0),U,13)=MSGTYPE,$P(^HLMA(IEN,0),U,14)=$G(EVNTYPE) - ; - ;Append event type - I $G(EVNTYPE)]"" S MSGTYPE=MSGTYPE_$E(EC,2)_EVNTYPE,(ACKMID,BTACK)="" - ;batch/name/id/type(#9)=null~process ID~msg type|evnt type~version~CA~AA - S BNAME=$E(EC,1)_HLPID_$E(EC,1)_MSGTYPE_$E(EC,1)_$P(PROT,U,9)_$E(EC,1)_ACCACK_$E(EC,1)_APPACK ;HL*1.6*80 - ;for batch ACK - I ACKTO D S BTACK=X_$E(EC,1)_$P(BSTATUS,U,3) - . ;get msg id and status of message that is being ACKed - . S ACKMID=$P($G(^HLMA(ACKTO,0)),U,2),BSTATUS=$G(^HLMA(ACKTO,"P")) ;HL*1.6*80 - . ;set type of ACK based on status - . S X=$S(ACKMID="":"AR",(BSTATUS>3)&(BSTATUS<8):"AE",1:"AA") - ; - D RESET^HLCSHDR3 ;HL*1.6*93 - ; - ; patch HL*1.6*120 start - ; escape delimiters for SERAPP and CLNTAPP - ; escape component separator if the field is not consisted - ; of 3 components - S EC(1)=$E(EC,1) - S EC(2)=$E(EC,2) - S EC(3)=$E(EC,3) - S EC(4)=$E(EC,4) - S COMFLAG=1 - I $L(SERAPP,$E(EC,1))=3 S COMFLAG=0 - I (SERAPP[FS)!(SERAPP[EC(1))!(SERAPP[EC(2))!(SERAPP[EC(3))!(SERAPP[EC(4)) D - . S SERAPP=$$ESCAPE(SERAPP,COMFLAG) - S COMFLAG=1 - I $L(CLNTAPP,$E(EC,1))=3 S COMFLAG=0 - I (CLNTAPP[FS)!(CLNTAPP[EC(1))!(CLNTAPP[EC(2))!(CLNTAPP[EC(3))!(CLNTAPP[EC(4)) D - . S CLNTAPP=$$ESCAPE(CLNTAPP,COMFLAG) - ; patch HL*1.6*120 end - ; - S HLHDRI=1,HLHDR(1)="BHS"_FS_EC_FS_SERAPP,HLHDRL=$L(HLHDR(1)) - F X=SERFAC,CLNTAPP,CLNTFAC,HLDATE,SECURITY,BNAME,BTACK,HLID,ACKMID D MSH(X) - Q -VAR ;Check input - N APPPRM,HLPROTS,HLPROT - S IEN=+$G(IEN) - I '$G(^HLMA(IEN,0)) S HLERROR="Valid pointer to Message Administration file (#772) not passed" Q - I '$G(CLIENT) S HLERROR="Could not determine receiving application" Q - ;Get child, text pointer,text entry, and sending app. - S CHILD=$G(^HLMA(IEN,0)),SEND=+$P($G(^(0)),U,11),TXTP=+CHILD,TXTP0=$G(^HL(772,TXTP,0)) - I ('SEND) S HLERROR="Could not determine sending application" Q - ;Get info for sending & receiving applications - D APPPRM^HLUTIL2(CLIENT),APPPRM^HLUTIL2(SEND) - ;Get name of sending application, facility, and country - S SERAPP=$P(APPPRM(SEND,0),U),SERFAC=$P(APPPRM(SEND,0),U,2),CNTRY=$P(APPPRM(SEND,0),U,3) - ;Get name of receiving application and facility - S CLNTAPP=$P(APPPRM(CLIENT,0),U),CLNTFAC=$P(APPPRM(CLIENT,0),U,2) - ; - ; patch HL*1.6*120 - ; for dynamic addressing, overide the receiving facility from the - ; 3rd component of HLL("LINKS") array - I $G(HLP("REC-FACILITY"))]"" S CLNTFAC=HLP("REC-FACILITY") - ; - ;Get field separator & encoding characters - S FS=APPPRM(SEND,"FS"),EC=APPPRM(SEND,"EC") - S:(EC="") EC="~|\&" S:(FS="") FS="^" - ;Determine if it's a response/ACK to another message - S ACKTO=+$P(CHILD,U,10) - ;subscriber protocol is from child (file 773) - ;If response, get MType from subscriber - S HLPROTS=+$P(CHILD,U,8) - S PROTS=$$TYPE^HLUTIL2(HLPROTS) - I ACKTO S MSGTYPE=$P(PROTS,U,10),EVNTYPE=$P(PROTS,U,3),MSGEVN=$P(PROTS,U,4) - ;Get accept ack & application ack type (based on server protocol) it - ; is always in file 772, TXPT0 - ;If original message, get MT from Event Driver Protocol - S HLPROT=+$P(TXTP0,U,10) - S PROT=$$TYPE^HLUTIL2(HLPROT) - S:'ACKTO MSGTYPE=$P(PROT,U,2),EVNTYPE=$P(PROT,U,3),MSGEVN=$P(PROT,U,4) - S ACCACK=$P(PROT,U,7),APPACK=$P(PROT,U,8) - ; - ; patch HL*1.6*122 - ; setting the MSH-15 and MSH-16 from subscriber protocol - I HLPROTS,$P($G(^ORD(101,HLPROTS,773)),"^",5) D - . S ACCACK=$P(PROTS,U,7) - . S APPACK=$P(PROTS,U,8) - ; -PID ;Processing ID - ;I PID not 'debug' get from site params - ;If event driver set to 'debug' get from protocol - ;'production' or 'training' comes from site params - S HLPID=$P(PROT,U,5) - I $G(HLPID)'="D" S HLPID=$P(HLPARAM,U,3) - ; - ; patch HL*1.6*120: to include processing mode - I $G(HLP("PMOD"))]"",($G(HLTYPE)="M") D - . S HLPID=HLPID_$E($G(EC),1)_HLP("PMOD") - ; - I $G(HLPID)="" S HLERROR="Missing processing ID Site parameter." - ;acknowledgements have no application ack, link open no commit ack - I ACKTO S:APPACK]"" APPACK="NE" S:ACCACK]""&$G(HLTCPO) ACCACK="NE" - ;Get date/time, Message ID, and security - S HLDATE=+TXTP0,HLDATE=$$FMTHL7^XLFDT(HLDATE),HLID=$P(CHILD,U,2),SECURITY=$P(CHILD,U,9) -HDR23 ;generate extended facility field info based on 'facility required' - ;default format is INSTITUTION_HLCS_DOMAIN_HLCS_'DNS' - ;application parameter entry overrides default - N HLEP773,HLS773 - S SERFAC=$G(SERFAC),CLNTFAC=$G(CLNTFAC) - S HLEP773=+$G(^ORD(101,HLPROTS,773)) - S HLS773=+$P($G(^ORD(101,HLPROTS,773)),U,2) - Q:'HLEP773&('HLS773) - D GEN^HLCSHDR2 - I ACKTO D Q - .;Find original message - .S X=$G(^HLMA(ACKTO,"MSH",1,0)) ;Find header in TCP nodes - .I X["MSH" D - ..; - ..; patch HL*1.6*120 start - .. N HLEC - ..S HLFS=$E(X,4),HLEC=$E(X,5) - ..S SENDFAC=$P(X,HLFS,4),RECFAC=$P(X,HLFS,6) ;from original msg - ..S CLNTFAC=SENDFAC,SERFAC=RECFAC ;reverse facility info - ..S EC("COMPONENT")=$E($G(EC),1) - ..I $L(EC("COMPONENT"))=1,$L(HLEC)=1,EC("COMPONENT")'=HLEC D - ... ; change the the component separator in the sending and - ... ; receiving facilities for the outgoing message - ... S CLNTFAC=$TR(CLNTFAC,HLEC,EC("COMPONENT")) - ... S SERFAC=$TR(SERFAC,HLEC,EC("COMPONENT")) - ; patch HL*1.6*120 end - ; - I HLEP773,SERFAC="" D EP^HLCSHDR2 - I HLS773,CLNTFAC="" D S^HLCSHDR2 - Q - ; -ESCAPE(INPUT,COMPONET) ; - ; patch HL*1.6*120 - escape delimiters: - ; - field separator - ; - component separator - ; - repetition separator - ; - escape character - ; - subcomponent separator - ; - ; input: - ; INPUT - string data to be escaped - ; COMPONET - if 1, escape component separator - ; if 0, do not escape component separator - ; FS - field separator character - ; EC - encoding characters - ; result: return the escaped string - ; - N HLDATA,HLESCAPE,HLI,HLCHAR,HLEN,HLOUT,COMFLAG - S HLDATA=$G(INPUT) - S COMFLAG=$G(COMPONET) - Q:$L($G(FS))'=1 HLDATA - ; - ; patch HL*1.6*133 - ; Q:$L($G(EC))'=4 HLDATA - Q:($L($G(EC))<3) HLDATA - Q:HLDATA']"" HLDATA - ; - S HLESCAPE=FS_EC - S HLESCAPE("F")=FS - S HLESCAPE("S")=$E(EC,1) - S HLESCAPE("R")=$E(EC,2) - S HLESCAPE("E")=$E(EC,3) - S HLESCAPE("T")=$E(EC,4) - S HLEN=$L(HLDATA) - S HLOUT="" - F HLI=1:1:HLEN D - . S HLCHAR=$E(HLDATA,HLI) - . I HLESCAPE[HLCHAR D Q - .. I HLCHAR=HLESCAPE("F") S HLOUT=HLOUT_HLESCAPE("E")_"F"_HLESCAPE("E") Q - .. I HLCHAR=HLESCAPE("S") D Q - ... I COMFLAG=1 S HLOUT=HLOUT_HLESCAPE("E")_"S"_HLESCAPE("E") Q - ... S HLOUT=HLOUT_HLCHAR - .. I HLCHAR=HLESCAPE("R") S HLOUT=HLOUT_HLESCAPE("E")_"R"_HLESCAPE("E") Q - .. I HLCHAR=HLESCAPE("E") S HLOUT=HLOUT_HLESCAPE("E")_"E"_HLESCAPE("E") Q - .. I HLCHAR=HLESCAPE("T") S HLOUT=HLOUT_HLESCAPE("E")_"T"_HLESCAPE("E") Q - . ; - . S HLOUT=HLOUT_HLCHAR - Q HLOUT +HLCSHDR1 ;SFIRMFO/RSD - Make HL7 header for TCP ;09/13/2006 + ;;1.6;HEALTH LEVEL SEVEN;**19,57,59,72,80,93,120,133**;Oct 13, 1995;Build 13 + ;Per VHA Directive 2004-038, this routine should not be modified. +HEADER(IEN,CLIENT,HLERROR) ; Create an HL7 MSH segment + ; + ;Input : IEN - Pointer to entry in Message Administration file (#773) + ; that HL7 MSH segment is being built for + ; CLIENT - IEN of the receiving application + ; HLERROR - Variable to return possible error text in + ; (pass by reference - only used when needed) + ; + ;Output : HLHDR(1) - HL7 MSH segment + ; HLHDR(2) - Continuation of HL7 MSH segment (if needed) + ; HLHDR(3) - Continuation of HL7 MSH segment (if needed) + ; + ;Notes : HLERROR will only be defined [on output] if an error occurs + ; : HLHDR() will not be defined [on output] if an error occurs + ; : HLHDR(2) & HLHDR(3) are continuation [or roll-over] nodes + ; and will only be used/defined when needed + ; + N ACKTO,ACCACK,APPACK,CHILD,CLNTAPP,CLNTFAC,CNTRY,EC,EVNTYPE,FS,HLDATE,HLHDRI,HLHDRL,HLID,HLPID,MSGTYPE,PROT,PROTS,SECURITY,SEND,SERAPP,SERFAC,TXTP,TXTP0,X,MSGEVN + N COMFLAG ; patch HL*1.6*120 + S HLERROR="" + S HLPARAM=$$PARAM^HLCS2 + D VAR Q:$G(HLERROR)]"" + ; The following line commented by HL*1.6*72 + ;I $D(^HLMA(IEN)) S $P(^HLMA(IEN,0),U,13)=MSGTYPE,$P(^HLMA(IEN,0),U,14)=$G(EVNTYPE) + ;Append event type + I $G(EVNTYPE)]"" S MSGTYPE=MSGTYPE_$E(EC,1)_EVNTYPE + ;Append message structure component + I $G(EVNTYPE)]"",$G(MSGEVN)]"" S MSGTYPE=MSGTYPE_$E(EC,1)_MSGEVN + ;Build MSH array + D RESET^HLCSHDR3 ;HL*1.6*93 + ; + ; patch HL*1.6*120 start + ; escape delimiters for SERAPP and CLNTAPP + ; escape component separator if the field is not consisted + ; of 3 components + S EC(1)=$E(EC,1) + S EC(2)=$E(EC,2) + S EC(3)=$E(EC,3) + S EC(4)=$E(EC,4) + S COMFLAG=1 + I $L(SERAPP,$E(EC,1))=3 S COMFLAG=0 + I (SERAPP[FS)!(SERAPP[EC(1))!(SERAPP[EC(2))!(SERAPP[EC(3))!(SERAPP[EC(4)) D + . S SERAPP=$$ESCAPE(SERAPP,COMFLAG) + S COMFLAG=1 + I $L(CLNTAPP,$E(EC,1))=3 S COMFLAG=0 + I (CLNTAPP[FS)!(CLNTAPP[EC(1))!(CLNTAPP[EC(2))!(CLNTAPP[EC(3))!(CLNTAPP[EC(4)) D + . S CLNTAPP=$$ESCAPE(CLNTAPP,COMFLAG) + ; patch HL*1.6*120 end + ; + S HLHDRI=1,HLHDR(1)="MSH"_FS_EC_FS_SERAPP,HLHDRL=$L(HLHDR(1)) + F X=SERFAC,CLNTAPP,CLNTFAC,HLDATE,SECURITY,MSGTYPE,HLID,HLPID,$P(PROT,U,9),"",$G(^HL(772,TXTP,1)),ACCACK,APPACK,CNTRY D MSH(X) + ;in preceeding line, "" is for sequence number - not supported + Q + ; +MSH(X) ;add X to HLHDR + S:HLHDRL+$L(X)>245 HLHDRI=HLHDRI+1,HLHDR(HLHDRI)="" + S HLHDR(HLHDRI)=HLHDR(HLHDRI)_FS_X,HLHDRL=$L(HLHDR(HLHDRI)) + Q +BHSHDR(IEN,CLIENT,HLERROR) ; Create Batch Header Segment + ; The BHS has 12 segments, of which 4 are blank. + ; INPUT: IEN - IEN of entry in file #772 + ; OUTPUT: HLHDR(1) and HLHDR(2) - the two lines with the 12 segs. + ; ready for adding to a message directly. + N ACKTO,ACCACK,ACKMID,APPACK,BNAME,BSTATUS,BTACK,CHILD,CLNTAPP ;HL*1.6*80 + N CLNTFAC,CNTRY,EC,EVNTYPE,FS,HLDATE,HLHDRI,HLHDRL,HLID,HLPID ;HL*1.6*80 - added HLPID + N PROT,PROTS,SECURITY,SEND,SERAPP,SERFAC,TXTP,TXTP0,X ;HL*1.6*80 + N COMFLAG ; patch HL*1.6*120 + S HLERROR="" + ; + S HLPARAM=$$PARAM^HLCS2 + D VAR Q:$G(HLERROR)]"" + ; The following line commented by HL*1.6*72 + ;I $D(^HLMA(IEN)) S $P(^HLMA(IEN,0),U,13)=MSGTYPE,$P(^HLMA(IEN,0),U,14)=$G(EVNTYPE) + ; + ;Append event type + I $G(EVNTYPE)]"" S MSGTYPE=MSGTYPE_$E(EC,2)_EVNTYPE,(ACKMID,BTACK)="" + ;batch/name/id/type(#9)=null~process ID~msg type|evnt type~version~CA~AA + S BNAME=$E(EC,1)_HLPID_$E(EC,1)_MSGTYPE_$E(EC,1)_$P(PROT,U,9)_$E(EC,1)_ACCACK_$E(EC,1)_APPACK ;HL*1.6*80 + ;for batch ACK + I ACKTO D S BTACK=X_$E(EC,1)_$P(BSTATUS,U,3) + . ;get msg id and status of message that is being ACKed + . S ACKMID=$P($G(^HLMA(ACKTO,0)),U,2),BSTATUS=$G(^HLMA(ACKTO,"P")) ;HL*1.6*80 + . ;set type of ACK based on status + . S X=$S(ACKMID="":"AR",(BSTATUS>3)&(BSTATUS<8):"AE",1:"AA") + ; + D RESET^HLCSHDR3 ;HL*1.6*93 + ; + ; patch HL*1.6*120 start + ; escape delimiters for SERAPP and CLNTAPP + ; escape component separator if the field is not consisted + ; of 3 components + S EC(1)=$E(EC,1) + S EC(2)=$E(EC,2) + S EC(3)=$E(EC,3) + S EC(4)=$E(EC,4) + S COMFLAG=1 + I $L(SERAPP,$E(EC,1))=3 S COMFLAG=0 + I (SERAPP[FS)!(SERAPP[EC(1))!(SERAPP[EC(2))!(SERAPP[EC(3))!(SERAPP[EC(4)) D + . S SERAPP=$$ESCAPE(SERAPP,COMFLAG) + S COMFLAG=1 + I $L(CLNTAPP,$E(EC,1))=3 S COMFLAG=0 + I (CLNTAPP[FS)!(CLNTAPP[EC(1))!(CLNTAPP[EC(2))!(CLNTAPP[EC(3))!(CLNTAPP[EC(4)) D + . S CLNTAPP=$$ESCAPE(CLNTAPP,COMFLAG) + ; patch HL*1.6*120 end + ; + S HLHDRI=1,HLHDR(1)="BHS"_FS_EC_FS_SERAPP,HLHDRL=$L(HLHDR(1)) + F X=SERFAC,CLNTAPP,CLNTFAC,HLDATE,SECURITY,BNAME,BTACK,HLID,ACKMID D MSH(X) + Q +VAR ;Check input + N APPPRM,HLPROTS,HLPROT + S IEN=+$G(IEN) + I '$G(^HLMA(IEN,0)) S HLERROR="Valid pointer to Message Administration file (#772) not passed" Q + I '$G(CLIENT) S HLERROR="Could not determine receiving application" Q + ;Get child, text pointer,text entry, and sending app. + S CHILD=$G(^HLMA(IEN,0)),SEND=+$P($G(^(0)),U,11),TXTP=+CHILD,TXTP0=$G(^HL(772,TXTP,0)) + I ('SEND) S HLERROR="Could not determine sending application" Q + ;Get info for sending & receiving applications + D APPPRM^HLUTIL2(CLIENT),APPPRM^HLUTIL2(SEND) + ;Get name of sending application, facility, and country + S SERAPP=$P(APPPRM(SEND,0),U),SERFAC=$P(APPPRM(SEND,0),U,2),CNTRY=$P(APPPRM(SEND,0),U,3) + ;Get name of receiving application and facility + S CLNTAPP=$P(APPPRM(CLIENT,0),U),CLNTFAC=$P(APPPRM(CLIENT,0),U,2) + ; + ; patch HL*1.6*120 + ; for dynamic addressing, overide the receiving facility from the + ; 3rd component of HLL("LINKS") array + I $G(HLP("REC-FACILITY"))]"" S CLNTFAC=HLP("REC-FACILITY") + ; + ;Get field separator & encoding characters + S FS=APPPRM(SEND,"FS"),EC=APPPRM(SEND,"EC") + S:(EC="") EC="~|\&" S:(FS="") FS="^" + ;Determine if it's a response/ACK to another message + S ACKTO=+$P(CHILD,U,10) + ;subscriber protocol is from child (file 773) + ;If response, get MType from subscriber + S HLPROTS=+$P(CHILD,U,8) + S PROTS=$$TYPE^HLUTIL2(HLPROTS) + I ACKTO S MSGTYPE=$P(PROTS,U,10),EVNTYPE=$P(PROTS,U,3),MSGEVN=$P(PROTS,U,4) + ;Get accept ack & application ack type (based on server protocol) it + ; is always in file 772, TXPT0 + ;If original message, get MT from Event Driver Protocol + S HLPROT=+$P(TXTP0,U,10) + S PROT=$$TYPE^HLUTIL2(HLPROT) + S:'ACKTO MSGTYPE=$P(PROT,U,2),EVNTYPE=$P(PROT,U,3),MSGEVN=$P(PROT,U,4) + S ACCACK=$P(PROT,U,7),APPACK=$P(PROT,U,8) +PID ;Processing ID + ;I PID not 'debug' get from site params + ;If event driver set to 'debug' get from protocol + ;'production' or 'training' comes from site params + S HLPID=$P(PROT,U,5) + I $G(HLPID)'="D" S HLPID=$P(HLPARAM,U,3) + ; + ; patch HL*1.6*120: to include processing mode + I $G(HLP("PMOD"))]"",($G(HLTYPE)="M") D + . S HLPID=HLPID_$E($G(EC),1)_HLP("PMOD") + ; + I $G(HLPID)="" S HLERROR="Missing processing ID Site parameter." + ;acknowledgements have no application ack, link open no commit ack + I ACKTO S:APPACK]"" APPACK="NE" S:ACCACK]""&$G(HLTCPO) ACCACK="NE" + ;Get date/time, Message ID, and security + S HLDATE=+TXTP0,HLDATE=$$FMTHL7^XLFDT(HLDATE),HLID=$P(CHILD,U,2),SECURITY=$P(CHILD,U,9) +HDR23 ;generate extended facility field info based on 'facility required' + ;default format is INSTITUTION_HLCS_DOMAIN_HLCS_'DNS' + ;application parameter entry overrides default + N HLEP773,HLS773 + S SERFAC=$G(SERFAC),CLNTFAC=$G(CLNTFAC) + S HLEP773=+$G(^ORD(101,HLPROTS,773)) + S HLS773=+$P($G(^ORD(101,HLPROTS,773)),U,2) + Q:'HLEP773&('HLS773) + D GEN^HLCSHDR2 + I ACKTO D Q + .;Find original message + .S X=$G(^HLMA(ACKTO,"MSH",1,0)) ;Find header in TCP nodes + .I X["MSH" D + ..; + ..; patch HL*1.6*120 start + .. N HLEC + ..S HLFS=$E(X,4),HLEC=$E(X,5) + ..S SENDFAC=$P(X,HLFS,4),RECFAC=$P(X,HLFS,6) ;from original msg + ..S CLNTFAC=SENDFAC,SERFAC=RECFAC ;reverse facility info + ..S EC("COMPONENT")=$E($G(EC),1) + ..I $L(EC("COMPONENT"))=1,$L(HLEC)=1,EC("COMPONENT")'=HLEC D + ... ; change the the component separator in the sending and + ... ; receiving facilities for the outgoing message + ... S CLNTFAC=$TR(CLNTFAC,HLEC,EC("COMPONENT")) + ... S SERFAC=$TR(SERFAC,HLEC,EC("COMPONENT")) + ; patch HL*1.6*120 end + ; + I HLEP773,SERFAC="" D EP^HLCSHDR2 + I HLS773,CLNTFAC="" D S^HLCSHDR2 + Q + ; +ESCAPE(INPUT,COMPONET) ; + ; patch HL*1.6*120 - escape delimiters: + ; - field separator + ; - component separator + ; - repetition separator + ; - escape character + ; - subcomponent separator + ; + ; input: + ; INPUT - string data to be escaped + ; COMPONET - if 1, escape component separator + ; if 0, do not escape component separator + ; FS - field separator character + ; EC - encoding characters + ; result: return the escaped string + ; + N HLDATA,HLESCAPE,HLI,HLCHAR,HLEN,HLOUT,COMFLAG + S HLDATA=$G(INPUT) + S COMFLAG=$G(COMPONET) + Q:$L($G(FS))'=1 HLDATA + ; + ; patch HL*1.6*133 + ; Q:$L($G(EC))'=4 HLDATA + Q:($L($G(EC))<3) HLDATA + Q:HLDATA']"" HLDATA + ; + S HLESCAPE=FS_EC + S HLESCAPE("F")=FS + S HLESCAPE("S")=$E(EC,1) + S HLESCAPE("R")=$E(EC,2) + S HLESCAPE("E")=$E(EC,3) + S HLESCAPE("T")=$E(EC,4) + S HLEN=$L(HLDATA) + S HLOUT="" + F HLI=1:1:HLEN D + . S HLCHAR=$E(HLDATA,HLI) + . I HLESCAPE[HLCHAR D Q + .. I HLCHAR=HLESCAPE("F") S HLOUT=HLOUT_HLESCAPE("E")_"F"_HLESCAPE("E") Q + .. I HLCHAR=HLESCAPE("S") D Q + ... I COMFLAG=1 S HLOUT=HLOUT_HLESCAPE("E")_"S"_HLESCAPE("E") Q + ... S HLOUT=HLOUT_HLCHAR + .. I HLCHAR=HLESCAPE("R") S HLOUT=HLOUT_HLESCAPE("E")_"R"_HLESCAPE("E") Q + .. I HLCHAR=HLESCAPE("E") S HLOUT=HLOUT_HLESCAPE("E")_"E"_HLESCAPE("E") Q + .. I HLCHAR=HLESCAPE("T") S HLOUT=HLOUT_HLESCAPE("E")_"T"_HLESCAPE("E") Q + . ; + . S HLOUT=HLOUT_HLCHAR + Q HLOUT diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLCSHDR4.m b/r/HEALTH_LEVEL_SEVEN-HL/HLCSHDR4.m index 333bbf16..558f70f7 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLCSHDR4.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLCSHDR4.m @@ -1,257 +1,253 @@ -HLCSHDR4 ;SFIRMFO/LJA - Reset MSH Segment Fields ;10/09/2007 15:05 - ;;1.6;HEALTH LEVEL SEVEN;**93,108,122**;Oct 13, 1995;Build 14 - ;Per VHA Directive 2004-038, this routine should not be modified - ; -DEBUG(STORE) ; If HLP set up for debugging, capture VIEW... - ; HLMSH773 -- req - ; - N NOW,NUM,VAR,VARS,X,XTMP - ; - ; 1=some, 2=all - S STORE=$S(STORE=1:1,STORE=2:2,1:0) QUIT:'STORE ;-> - ; - S NOW=$$NOW^XLFDT - ; - S XTMP="HLCSHDR3 "_HLMSH773 - S:'$D(^XTMP(XTMP,0)) ^XTMP(XTMP,0)=$$FMADD^XLFDT(NOW,0,4)_U_NOW_U_"Debug data created by DEBUG~HLCSHDR4" - ; - S NUM=$O(^XTMP(XTMP,":"),-1)+1 - ; - ; Grab only critical (some) variables? - I STORE=1 D - . - . ; Sending information... - . S ^XTMP(XTMP,NUM,"SA")=HLMSHSAO_U_HLSAN_U_HLMSHSAN - . S ^XTMP(XTMP,NUM,"SF")=HLMSHSFO_U_HLSFN_U_HLMSHSFN - . - . ; Receiving information... - . S ^XTMP(XTMP,NUM,"RA")=HLMSHRAO_U_HLRAN_U_HLMSHRAN - . S ^XTMP(XTMP,NUM,"RF")=HLMSHRFO_U_HLRFN_U_HLMSHRFN - . - . ; Other information... (HLMSHPRE and HLMSHPRS hold 2 pieces!) - . S ^XTMP(XTMP,NUM,0)=NOW_U_HLMSH772_U_HLMSHPRE_U_HLMSHPRS - . S ^XTMP(XTMP,NUM,1)=HLMSHPRO - ; - ; Grab all variables? - I STORE=2 D - . S X="^XTMP("""_XTMP_""","_NUM_"," - . D DOLRO^%ZOSV - ; - QUIT - ; -SHOW N I773 - F R !!,"Enter 773 IEN: ",I773:60 Q:I773'>0 D - . D SHOW773(I773) - QUIT - ; -SHOW773(I773) ; Show Dynamic Routing MSH Field Reset Details - N DIV,MSH,N90,N91 - ; - S N90=$G(^HLMA(+I773,90)),N91=$G(^HLMA(+I773,91)) - I (N90_N91)']"" D QUIT ;-> - . W " no debug data found..." - ; - S MSH=$G(^HLMA(+I773,"MSH",1,0)) QUIT:MSH']"" ;-> - S DIV=$E(MSH,4) - ; - W !!,$$CJ^XLFSTR(" 773 # "_I773_" ",IOM,"=") - ; - D HDR(90,N90) - ; - W ! - D HDR(91,N91) - ; - W !!,$E(MSH,1,IOM) - ; - S C1=10,C2=30,C3=50 - W !!,?C1,"Original (91)",?2,"Array (90)",?3,"MSH-Segment" - W !,$$REPEAT^XLFSTR("-",IOM) - D LINE("snd app",1,2,3) - D LINE("snd fac",3,3,4) - D LINE("rec app",5,4,5) - D LINE("rec fac",7,5,6) - ; - QUIT - ; -LINE(HDR,PCE1,PCE2,PCE3) ; Print one comparison line... - N P1,P2,P3,P4 - S P1=$P(N91,U,PCE1),P2=$P(N90,U,PCE2),P3=$P(MSH,DIV,PCE3),P4=$P(N91,U,PCE1+1) - W !,HDR,":",?C1,P1,?2,P2,?3,P3,$S(P4]"":" ["_P4_"]",1:"") - QUIT - ; -HDR(NUM,DATA) N TXT - S TXT=$S(NUM=90:"Array (90)",NUM=91:"Original (91)",1:"") - W !,$$CJ^XLFSTR("---------- "_TXT_" ----------",IOM) - W $$CJ^XLFSTR(DATA,IOM) - QUIT - ; -SET(NEW,VAR,PCE) ; This subroutine performs these actions: - ; (1) Resets variables used in MSH segment - ; (2) Resets SERAPP and CLNTAPP in ^HLMA(#,0) - ; (3) Sets HLMSH91 nodes if overwrite occurs by ARRAY value. - ; If overwrite occurs by M code, the overwrite has already - ; been recorded in HLMSH91. (An overwrite produced by M code - ; is never overwritten by ARRAY data.) - ; - N IEN771N,IEN771O,HLTCP - ; - ; VAR is the name of the variable, and not it's value... - S PRE=@VAR ; PRE is now the value of the VAR (pre-overwrite) variable... - ; - ; Tests whether anything was changed... - QUIT:NEW']"" ;-> No new value exists to change to... - QUIT:NEW=PRE ;-> New value = Original value. Nothing changed... - ; - ; THIS IS THE EPICENTER!! This is where the variables used in - ; the MSH segment is overwritten. - S @VAR=NEW - ; - ; If PRE exists at this point, it was done by M code... - QUIT:$P(HLMSH91,U,PCE)]"" ;-> - ; - ; Change was made, but not by M code. Must be by array... - S $P(HLMSH91,U,PCE)=PRE,$P(HLMSH91,U,PCE+1)="A" - ; - ; patch HL*1.6*122: for "^" as component separater - S $P(HLMSH91,U,PCE+2,999)="" - ; - ; Upgrade ^HLMA(#,0)... - QUIT:PCE'=1&(PCE'=5) ;-> - ; - ; patch HL*1.6*108 start - ;S IEN771O=$O(^HL(771,"B",PRE,0)) QUIT:IEN771O'>0 ;-> Orig IEN - ;S IEN771N=$O(^HL(771,"B",NEW,0)) QUIT:IEN771N'>0 ;-> New IEN - S IEN771O=$O(^HL(771,"B",$E(PRE,1,30),0)) QUIT:IEN771O'>0 ;-> Orig IEN - S IEN771N=$O(^HL(771,"B",$E(NEW,1,30),0)) QUIT:IEN771N'>0 ;-> New IEN - ; patch HL*1.6*108 end - ; - QUIT:'IEN771O!('IEN771N)!(IEN771O=IEN771N) ;-> - S HLTCP=1 ; So 773 is updated... - I PCE=1 D UPDATE^HLTF0(MTIENS,"","O","","",IEN771N) - I PCE=5 D UPDATE^HLTF0(MTIENS,"","O","",IEN771N) - ; - QUIT - ; -FIELDS ; Display the Protocol file fields used by the VistA HL7 package, - ; when messages are received, to find the event and subscriber - ; protocols. - N BY,DIC,DIOEND,L - ; - D HD - ; - W ! - ; - S L="",DIC="^ORD(101,",BY="[HL PROTOCOL MESSAGING FIELDS]" - S DIOEND="D EXPL^HLCSHDR4" - D EN1^DIP - ; - Q - ; -HD W @IOF,$$CJ^XLFSTR("HL7 Protocol Messaging Fields",IOM) - W !,$$REPEAT^XLFSTR("=",IOM) - W !,"This 'HL7 Protocol Messaging Fields' report holds information that will help" - W !,"you determine the effects from changes to routing-related fields in the MSH" - W !,"segment when messages are sent between or within VistA HL7 systems." - W !,"Additional explanation is included at the bottom of the report." - Q - ; -EXPL N I,T QUIT:'$$EXPL1("Press RETURN for 'printout help', or '^' to exit... ") X "F I=1:1 S T=$T(EXPL+I) QUIT:T'["";;"" W !,$P(T,"";;"",2,99)" S I=$$EXPL1("Press RETURN to exit... ",1) - ;; - ;;When messages are received, their SENDING APPLICATION (MSH-3), MESSAGE - ;;TYPE (MSH-9), EVENT TYPE (MSH-9), and HL7 VERSION (MSH-12) fields are used to - ;;find the event driver protocol to be used in processing the just-received - ;;message. After the event protocol is found, that protocol's subscriber - ;;protocols are evaluated. The subscriber protocol with a RECEIVING - ;;APPLICATION value that matches the RECEIVING APPLICATION field in the MSH - ;;segment (MSH-5) is used. - ;; - ;;The first line for every "section" in the printout is the event driver - ;;protocol. Lines preceded by dashes, are related subscriber protocols. An - ;;example is shown below. - ;; - ;;Snd/Rec App's mTYP eTYP Ver Protocol Link - ;;------------------------------------------------------------------------------ - ;;AC-VOICERAD ORU R01 2.3 | AC ORU SERVER - ;;-AC-RADIOLOGY ORU R01 2.3 | AC ORU CLIENT NC TCP - ;; - ;;In this example, the 'AC-VOICERAD' line holds information for the 'AC ORU - ;;SERVER' event protocol. And, the '-AC-RADIOLOGY' line holds information for - ;;the 'AC ORU CLIENT' subscriber protocol. - Q - ; -EXPL1(PMT,FF) ; - N DIR,DIRUT,DTOUT,DUOUT,X,Y - QUIT:$E($G(IOST),1,2)'="C-" 1 ;-> - F X=1:1:$G(FF) W ! - S DIR(0)="EA",DIR("A")=PMT - D ^DIR - QUIT $S(Y=1:1,1:"") - ; -M ; Covered by Integration Agreement #3988 - ; Application developers may call here when creating new messages, - ; when experimenting with M code to evaluate and conditionally change - ; routing-related fields. - ; - ; This API is called immediately before the MSH segment is created. - N IOINHI,IOINORM,MSHOLD,MSHNEW,MSHPRE,X - ; - S X="IOINHI;IOINORM" D ENDR^%ZISS - ; - S MSHOLD=$$MSHBUILD(0),MSHPRE=$$MSHBUILD(1) - W !!,"The original MSH segment is...",!!,IOINHI,MSHOLD,IOINORM - I MSHPRE'=MSHOLD D - . W !!,"The MSH segment, after modification by passed-in data, is..." - . W !!,IOINHI,MSHPRE,IOINORM - ; - D MVAR("SENDING APPLICATION","HLMSHSAN","SERAPP") - D MVAR("SENDING FACILITY","HLMSHSFN","SERFAC") - D MVAR("RECEIVING APPLICATION","HLMSHRAN","CLNTAPP") - D MVAR("RECEIVING FACILITY","HLMSHRFN","CLNTFAC") - ; - S MSHNEW=$$MSHBUILD - I MSHNEW'=MSHPRE D - . W !!,"Before your changes above, the modified MSH segment was..." - . W !!,IOINHI,MSHPRE,IOINORM - . W !!,"After your changes, the MSH segment is..." - . W !!,IOINHI,MSHNEW,IOINORM - W !!,$$REPEAT^XLFSTR("-",IOM) - W !!,"Message being sent..." - W ! - ; - Q - ; -MVAR(FLD,VAR,VARO) ; Generic resetting of variable... - ;IOINHI,IOINORM -- req - N ANS - W !!,?4,"Protocol-derived value of ",FLD,": " - W IOINHI,@VARO,IOINORM - W !,"Passed-in value of ",FLD," (",VAR,"): " - W IOINHI,@VAR,IOINORM - W !,?10,"Enter new value for ",FLD,": " - R ANS:60 Q:'$T ;-> - I ANS[U!(ANS']"") D - . W !!,?10,"No changes will be made..." - I ANS'[U&(ANS]"") D - . S @VAR=ANS - . W !!,?10,"The variable ",IOINHI,VAR,IOINORM - . W " will be changed to '",IOINHI,ANS,IOINORM,"'." - . W !,?10,"This value will be stored in the ",FLD - . W !,?10,"field in the MSH segment..." - . W !!,$$REPEAT^XLFSTR("-",IOM) - Q - ; -MSHBUILD(TYPE) ; Build MSH using current variables... - N MSH,PCE,RAN,RFN,SAN,SFN - S MSH="MSH"_FS_EC - I $G(TYPE)=0 F PCE=SERAPP,SERFAC,CLNTAPP,CLNTFAC,HLDATE,SECURITY,MSGTYPE,HLID,HLPID,$P(PROT,U,9),"",$G(^HL(772,TXTP,1)),ACCACK,APPACK,CNTRY D - . S MSH=MSH_FS_PCE - I $G(TYPE)'=0 D - . S SAN=HLMSHSAN,SAN=$S(SAN]"":SAN,1:SERAPP) - . S SFN=HLMSHSFN,SFN=$S(SFN]"":SFN,1:SERFAC) - . S RAN=HLMSHRAN,RAN=$S(RAN]"":RAN,1:CLNTAPP) - . S RFN=HLMSHRFN,RFN=$S(RFN]"":RFN,1:CLNTFAC) - . F PCE=SAN,SFN,RAN,RFN,HLDATE,SECURITY,MSGTYPE,HLID,HLPID,$P(PROT,U,9),"",$G(^HL(772,TXTP,1)),ACCACK,APPACK,CNTRY D - . . S MSH=MSH_FS_PCE - QUIT MSH - ; -EOR ;HLCSHDR4 - Reset MSH Segment Fields ;9/12/02 11:50 +HLCSHDR4 ;SFIRMFO/LJA - Reset MSH Segment Fields ;3/24/2004 14:27 + ;;1.6;HEALTH LEVEL SEVEN;**93,108**;Oct 13, 1995 + ; +DEBUG(STORE) ; If HLP set up for debugging, capture VIEW... + ; HLMSH773 -- req + ; + N NOW,NUM,VAR,VARS,X,XTMP + ; + ; 1=some, 2=all + S STORE=$S(STORE=1:1,STORE=2:2,1:0) QUIT:'STORE ;-> + ; + S NOW=$$NOW^XLFDT + ; + S XTMP="HLCSHDR3 "_HLMSH773 + S:'$D(^XTMP(XTMP,0)) ^XTMP(XTMP,0)=$$FMADD^XLFDT(NOW,0,4)_U_NOW_U_"Debug data created by DEBUG~HLCSHDR4" + ; + S NUM=$O(^XTMP(XTMP,":"),-1)+1 + ; + ; Grab only critical (some) variables? + I STORE=1 D + . + . ; Sending information... + . S ^XTMP(XTMP,NUM,"SA")=HLMSHSAO_U_HLSAN_U_HLMSHSAN + . S ^XTMP(XTMP,NUM,"SF")=HLMSHSFO_U_HLSFN_U_HLMSHSFN + . + . ; Receiving information... + . S ^XTMP(XTMP,NUM,"RA")=HLMSHRAO_U_HLRAN_U_HLMSHRAN + . S ^XTMP(XTMP,NUM,"RF")=HLMSHRFO_U_HLRFN_U_HLMSHRFN + . + . ; Other information... (HLMSHPRE and HLMSHPRS hold 2 pieces!) + . S ^XTMP(XTMP,NUM,0)=NOW_U_HLMSH772_U_HLMSHPRE_U_HLMSHPRS + . S ^XTMP(XTMP,NUM,1)=HLMSHPRO + ; + ; Grab all variables? + I STORE=2 D + . S X="^XTMP("""_XTMP_""","_NUM_"," + . D DOLRO^%ZOSV + ; + QUIT + ; +SHOW N I773 + F R !!,"Enter 773 IEN: ",I773:60 Q:I773'>0 D + . D SHOW773(I773) + QUIT + ; +SHOW773(I773) ; Show Dynamic Routing MSH Field Reset Details + N DIV,MSH,N90,N91 + ; + S N90=$G(^HLMA(+I773,90)),N91=$G(^HLMA(+I773,91)) + I (N90_N91)']"" D QUIT ;-> + . W " no debug data found..." + ; + S MSH=$G(^HLMA(+I773,"MSH",1,0)) QUIT:MSH']"" ;-> + S DIV=$E(MSH,4) + ; + W !!,$$CJ^XLFSTR(" 773 # "_I773_" ",IOM,"=") + ; + D HDR(90,N90) + ; + W ! + D HDR(91,N91) + ; + W !!,$E(MSH,1,IOM) + ; + S C1=10,C2=30,C3=50 + W !!,?C1,"Original (91)",?2,"Array (90)",?3,"MSH-Segment" + W !,$$REPEAT^XLFSTR("-",IOM) + D LINE("snd app",1,2,3) + D LINE("snd fac",3,3,4) + D LINE("rec app",5,4,5) + D LINE("rec fac",7,5,6) + ; + QUIT + ; +LINE(HDR,PCE1,PCE2,PCE3) ; Print one comparison line... + N P1,P2,P3,P4 + S P1=$P(N91,U,PCE1),P2=$P(N90,U,PCE2),P3=$P(MSH,DIV,PCE3),P4=$P(N91,U,PCE1+1) + W !,HDR,":",?C1,P1,?2,P2,?3,P3,$S(P4]"":" ["_P4_"]",1:"") + QUIT + ; +HDR(NUM,DATA) N TXT + S TXT=$S(NUM=90:"Array (90)",NUM=91:"Original (91)",1:"") + W !,$$CJ^XLFSTR("---------- "_TXT_" ----------",IOM) + W $$CJ^XLFSTR(DATA,IOM) + QUIT + ; +SET(NEW,VAR,PCE) ; This subroutine performs these actions: + ; (1) Resets variables used in MSH segment + ; (2) Resets SERAPP and CLNTAPP in ^HLMA(#,0) + ; (3) Sets HLMSH91 nodes if overwrite occurs by ARRAY value. + ; If overwrite occurs by M code, the overwrite has already + ; been recorded in HLMSH91. (An overwrite produced by M code + ; is never overwritten by ARRAY data.) + ; + N IEN771N,IEN771O,HLTCP + ; + ; VAR is the name of the variable, and not it's value... + S PRE=@VAR ; PRE is now the value of the VAR (pre-overwrite) variable... + ; + ; Tests whether anything was changed... + QUIT:NEW']"" ;-> No new value exists to change to... + QUIT:NEW=PRE ;-> New value = Original value. Nothing changed... + ; + ; THIS IS THE EPICENTER!! This is where the variables used in + ; the MSH segment is overwritten. + S @VAR=NEW + ; + ; If PRE exists at this point, it was done by M code... + QUIT:$P(HLMSH91,U,PCE)]"" ;-> + ; + ; Change was made, but not by M code. Must be by array... + S $P(HLMSH91,U,PCE)=PRE,$P(HLMSH91,U,PCE+1)="A" + ; + ; Upgrade ^HLMA(#,0)... + QUIT:PCE'=1&(PCE'=5) ;-> + ; + ; patch HL*1.6*108 start + ;S IEN771O=$O(^HL(771,"B",PRE,0)) QUIT:IEN771O'>0 ;-> Orig IEN + ;S IEN771N=$O(^HL(771,"B",NEW,0)) QUIT:IEN771N'>0 ;-> New IEN + S IEN771O=$O(^HL(771,"B",$E(PRE,1,30),0)) QUIT:IEN771O'>0 ;-> Orig IEN + S IEN771N=$O(^HL(771,"B",$E(NEW,1,30),0)) QUIT:IEN771N'>0 ;-> New IEN + ; patch HL*1.6*108 end + ; + QUIT:'IEN771O!('IEN771N)!(IEN771O=IEN771N) ;-> + S HLTCP=1 ; So 773 is updated... + I PCE=1 D UPDATE^HLTF0(MTIENS,"","O","","",IEN771N) + I PCE=5 D UPDATE^HLTF0(MTIENS,"","O","",IEN771N) + ; + QUIT + ; +FIELDS ; Display the Protocol file fields used by the VistA HL7 package, + ; when messages are received, to find the event and subscriber + ; protocols. + N BY,DIC,DIOEND,L + ; + D HD + ; + W ! + ; + S L="",DIC="^ORD(101,",BY="[HL PROTOCOL MESSAGING FIELDS]" + S DIOEND="D EXPL^HLCSHDR4" + D EN1^DIP + ; + Q + ; +HD W @IOF,$$CJ^XLFSTR("HL7 Protocol Messaging Fields",IOM) + W !,$$REPEAT^XLFSTR("=",IOM) + W !,"This 'HL7 Protocol Messaging Fields' report holds information that will help" + W !,"you determine the effects from changes to routing-related fields in the MSH" + W !,"segment when messages are sent between or within VistA HL7 systems." + W !,"Additional explanation is included at the bottom of the report." + Q + ; +EXPL N I,T QUIT:'$$EXPL1("Press RETURN for 'printout help', or '^' to exit... ") X "F I=1:1 S T=$T(EXPL+I) QUIT:T'["";;"" W !,$P(T,"";;"",2,99)" S I=$$EXPL1("Press RETURN to exit... ",1) + ;; + ;;When messages are received, their SENDING APPLICATION (MSH-3), MESSAGE + ;;TYPE (MSH-9), EVENT TYPE (MSH-9), and HL7 VERSION (MSH-12) fields are used to + ;;find the event driver protocol to be used in processing the just-received + ;;message. After the event protocol is found, that protocol's subscriber + ;;protocols are evaluated. The subscriber protocol with a RECEIVING + ;;APPLICATION value that matches the RECEIVING APPLICATION field in the MSH + ;;segment (MSH-5) is used. + ;; + ;;The first line for every "section" in the printout is the event driver + ;;protocol. Lines preceded by dashes, are related subscriber protocols. An + ;;example is shown below. + ;; + ;;Snd/Rec App's mTYP eTYP Ver Protocol Link + ;;------------------------------------------------------------------------------ + ;;AC-VOICERAD ORU R01 2.3 | AC ORU SERVER + ;;-AC-RADIOLOGY ORU R01 2.3 | AC ORU CLIENT NC TCP + ;; + ;;In this example, the 'AC-VOICERAD' line holds information for the 'AC ORU + ;;SERVER' event protocol. And, the '-AC-RADIOLOGY' line holds information for + ;;the 'AC ORU CLIENT' subscriber protocol. + Q + ; +EXPL1(PMT,FF) ; + N DIR,DIRUT,DTOUT,DUOUT,X,Y + QUIT:$E($G(IOST),1,2)'="C-" 1 ;-> + F X=1:1:$G(FF) W ! + S DIR(0)="EA",DIR("A")=PMT + D ^DIR + QUIT $S(Y=1:1,1:"") + ; +M ; Covered by Integration Agreement #3988 + ; Application developers may call here when creating new messages, + ; when experimenting with M code to evaluate and conditionally change + ; routing-related fields. + ; + ; This API is called immediately before the MSH segment is created. + N IOINHI,IOINORM,MSHOLD,MSHNEW,MSHPRE,X + ; + S X="IOINHI;IOINORM" D ENDR^%ZISS + ; + S MSHOLD=$$MSHBUILD(0),MSHPRE=$$MSHBUILD(1) + W !!,"The original MSH segment is...",!!,IOINHI,MSHOLD,IOINORM + I MSHPRE'=MSHOLD D + . W !!,"The MSH segment, after modification by passed-in data, is..." + . W !!,IOINHI,MSHPRE,IOINORM + ; + D MVAR("SENDING APPLICATION","HLMSHSAN","SERAPP") + D MVAR("SENDING FACILITY","HLMSHSFN","SERFAC") + D MVAR("RECEIVING APPLICATION","HLMSHRAN","CLNTAPP") + D MVAR("RECEIVING FACILITY","HLMSHRFN","CLNTFAC") + ; + S MSHNEW=$$MSHBUILD + I MSHNEW'=MSHPRE D + . W !!,"Before your changes above, the modified MSH segment was..." + . W !!,IOINHI,MSHPRE,IOINORM + . W !!,"After your changes, the MSH segment is..." + . W !!,IOINHI,MSHNEW,IOINORM + W !!,$$REPEAT^XLFSTR("-",IOM) + W !!,"Message being sent..." + W ! + ; + Q + ; +MVAR(FLD,VAR,VARO) ; Generic resetting of variable... + ;IOINHI,IOINORM -- req + N ANS + W !!,?4,"Protocol-derived value of ",FLD,": " + W IOINHI,@VARO,IOINORM + W !,"Passed-in value of ",FLD," (",VAR,"): " + W IOINHI,@VAR,IOINORM + W !,?10,"Enter new value for ",FLD,": " + R ANS:60 Q:'$T ;-> + I ANS[U!(ANS']"") D + . W !!,?10,"No changes will be made..." + I ANS'[U&(ANS]"") D + . S @VAR=ANS + . W !!,?10,"The variable ",IOINHI,VAR,IOINORM + . W " will be changed to '",IOINHI,ANS,IOINORM,"'." + . W !,?10,"This value will be stored in the ",FLD + . W !,?10,"field in the MSH segment..." + . W !!,$$REPEAT^XLFSTR("-",IOM) + Q + ; +MSHBUILD(TYPE) ; Build MSH using current variables... + N MSH,PCE,RAN,RFN,SAN,SFN + S MSH="MSH"_FS_EC + I $G(TYPE)=0 F PCE=SERAPP,SERFAC,CLNTAPP,CLNTFAC,HLDATE,SECURITY,MSGTYPE,HLID,HLPID,$P(PROT,U,9),"",$G(^HL(772,TXTP,1)),ACCACK,APPACK,CNTRY D + . S MSH=MSH_FS_PCE + I $G(TYPE)'=0 D + . S SAN=HLMSHSAN,SAN=$S(SAN]"":SAN,1:SERAPP) + . S SFN=HLMSHSFN,SFN=$S(SFN]"":SFN,1:SERFAC) + . S RAN=HLMSHRAN,RAN=$S(RAN]"":RAN,1:CLNTAPP) + . S RFN=HLMSHRFN,RFN=$S(RFN]"":RFN,1:CLNTFAC) + . F PCE=SAN,SFN,RAN,RFN,HLDATE,SECURITY,MSGTYPE,HLID,HLPID,$P(PROT,U,9),"",$G(^HL(772,TXTP,1)),ACCACK,APPACK,CNTRY D + . . S MSH=MSH_FS_PCE + QUIT MSH + ; +EOR ;HLCSHDR4 - Reset MSH Segment Fields ;9/12/02 11:50 diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLCSIN.m b/r/HEALTH_LEVEL_SEVEN-HL/HLCSIN.m index 4318d989..55d4a340 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLCSIN.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLCSIN.m @@ -1,155 +1,101 @@ -HLCSIN ;ALB/JRP - INCOMING FILER;01-MAY-95 ;03/17/2008 17:15 - ;;1.6;HEALTH LEVEL SEVEN;**2,30,14,19,62,109,115,122,140**;Oct 13, 1995;Build 5 - ;Per VHA Directive 2004-038, this routine should not be modified. -STARTIN ;Main entry point for incoming background filer - ;Create/find entry denoting this filer in the INCOMING FILER TASK - ; NUMBER multiple (field #20) of the HL COMMUNICATION SERVER PARAMETER - ; file (#869.3) - N HLFLG,HLEXIT,HLPTRFLR - ; - ; patch HL*1.6*122 - ;; N HLDUZ,DUZ ; patch HL*1.6*122 TEST v2: DUZ code removed - N HLDUZ - S HLDUZ=+$G(DUZ) - ; - S HLPTRFLR=+$$CRTFLR^HLCSUTL1(ZTSK,"IN") - ;Loop through Logical Links and check for incoming messages - S HLEXIT=0 - ; patch HL*1.6*122 TEST v2: DUZ code removed - ; patch HL*1.6*122, set DUZ for application proxy user - ;; D PROXY^HLCSTCP4 - S HLPTRFLR("$J")=$J - F D Q:HLEXIT - . S HLFLG=0 - . D DEFACK(.HLPTRFLR,.HLFLG,.HLEXIT) Q:HLEXIT - . D ACKNOW(.HLPTRFLR,.HLFLG,.HLEXIT) Q:HLEXIT - . Q:HLFLG - . I $$HDIFF^XLFDT($H,$G(HLPTRFLR("LASTDEL")),2)>3600 D Q - . . S HLPTRFLR("LASTDEL")=$H ; maintain queue sizes - . . D DELQUE(.HLPTRFLR,.HLEXIT) ; no more than once an hour. - . ; patch HL*1.6*122 - . ; H 5 - . H 1 - . D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT - S ZTSTOP=1 ;Asked to stop - D DELFLR^HLCSUTL1(HLPTRFLR,"IN") ;Delete entry denoting this filer - S ZTREQ="@" - Q -DEFACK(HLPTRFLR,HLFLG,HLEXIT) ; Process TCP links with a deferred response - N HLXX,HLD0,HLPCT - S HLXX=0 - F S HLXX=$O(^HLMA("AC","I",HLXX)) Q:'HLXX D Q:HLEXIT - . ; HL*1.6*122, check the in-queue stop flag - . Q:$P($G(^HLCS(870,HLXX,0)),"^",9) - . D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT - . ; patch HL*1.6*109: Does another filer have this? - . ; L +^HLMA("AC","I",HLXX):0 Q:'$T - . ; patch HL*1.6*140 - change the lock node, it conflicts with - . ; lock defined in routine, HLCSREP. - . ; L +^HLMA("AC","I",HLXX):2 Q:'$T ; patch HL*1.6*122 - . L +^HLMA("IN-FILER","AC","I",HLXX):2 Q:'$T ; patch HL*1.6*122 - . S HLD0=0,HLFLG=1 - . ; HL*1.6*109 changes in for loop below, and post-quit code placed - . ; on following lines. - . S HLPCT=0 ; Counter whether filer should stop every 100th entry. - .;**109 - insure queue last processed at least 2 seconds ago - . ; patch HL*1.6*140 - . ; I ($$HDIFF^XLFDT($H,$G(^XTMP("HL7-AC","I",HLXX)),2)<2) L -^HLMA("AC","I",HLXX) Q - . I ($$HDIFF^XLFDT($H,$G(^XTMP("HL7-AC","I",HLXX)),2)<2) L -^HLMA("IN-FILER","AC","I",HLXX) Q - . F S HLD0=$O(^HLMA("AC","I",HLXX,HLD0)) Q:'HLD0!(HLEXIT) D - .. ; patch HL*1.6*122 start - .. ; patch HL*1.6*122 TEST v2: DUZ code removed - .. ; DUZ comparison/reset for application proxy user - .. ;; D HLDUZ^HLCSTCP4 - .. D HLDUZ2^HLCSTCP4 - .. ; protect HLDUZ - .. N HLDUZ - .. S HLPCT=HLPCT+1 - .. I '(HLPCT#100) D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT - .. ; L +^HLMA(HLD0):0 Q:'$T - .. F L +^HLMA(HLD0):30 Q:$T H 1 - .. I '$$CHECKAC("I",HLXX,HLD0) L -^HLMA(HLD0) Q ;-> Quit if not a valid AC xref - .. D DEFACK^HLTP3(HLXX,HLD0) - .. D DEQUE^HLCSREP(HLXX,"I",HLD0) - .. L -^HLMA(HLD0) - . ; patch HL*1.6*122 end - . ;**109 -add dt/tm stamp to time queue last processed - . S ^XTMP("HL7-AC","I",HLXX)=$H - . ;**109 -unlock the queue - . ; patch HL*1.6*140 - . ; L -^HLMA("AC","I",HLXX) - . L -^HLMA("IN-FILER","AC","I",HLXX) - Q - ; -CHECKAC(WAY,IEN870,IEN773) ; If AC xref shouldn't exist, kill it... - ; - ; Check status and if 3 (processed) kill XREF... - I $P($G(^HLMA(+IEN773,"P")),U)=3 D QUIT "" ;-> - . D DEQUE^HLCSREP(IEN870,WAY,IEN773) - ; - ; Add other checks here in the future... - ; - Q 1 - ; -ACKNOW(HLPTRFLR,HLFLG,HLEXIT) ; Process Logical Link's IN-queue for received message - N HLXX,HLD0,HLD1 - S HLXX=0 - F S HLXX=$O(^HLCS(870,"AISTAT","P",HLXX)) Q:'HLXX D Q:HLEXIT - . ; HL*1.6*122, check the in-queue stop flag - . Q:$P($G(^HLCS(870,HLXX,0)),"^",9) - . D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT - . ; HL*1.6*109: Does another filer have this? - . ; L +^HLCS(870,HLXX,"INFILER"):0 Q:'$T - . L +^HLCS(870,HLXX,"INFILER"):2 Q:'$T ; patch HL*1.6*122 - . F D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT S HLD0=$$DEQUEUE^HLCSQUE(HLXX,"IN") Q:+HLD0<0 D - .. ; - .. ; patch HL*1.6*122 start - .. ; clean variables except Kernel related variables - .. D - ... ; protect variables defined in STARTIN^HLCSIN - ... N HLFLG,HLEXIT,HLPTRFLR - ... N HLDUZ - ... ; protect variables defined in ACKNOW^HLCSIN - ... N HLXX,HLD0,HLD1 - ... D KILL^XUSCLEAN - .. ; - .. ; patch HL*1.6*122 TEST v2: DUZ code removed - .. ; DUZ comparison/reset for application proxy user - .. ;; D HLDUZ^HLCSTCP4 - .. D HLDUZ2^HLCSTCP4 - .. ; protect HLDUZ - .. N HLDUZ - .. ;Make sure message is ready to be received - .. S HLFLG=1 - .. S HLD1=$P(HLD0,"^",2) - .. S HLD0=+HLD0 ; At this point, HLD0=HLXX - .. I $P($G(^HLCS(870,HLD0,1,HLD1,0)),"^",3)'="A" D Q - ... D MONITOR^HLCSDR2("D",2,HLD0,HLD1,"IN") ;Set status to DONE - .. D RECEIVE^HLMA0(HLD0,HLD1) ;Process received message - .. D MONITOR^HLCSDR2("D",2,HLD0,HLD1,"IN") ;Set status to DONE - . ; patch HL*1.6*122 end - . I HLD0<0,$D(^HLCS(870,"AISTAT","P",HLXX)) D - . . S HLD1=0 ; Make sure there aren't any loose xrefs hanging around. - . . F S HLD1=$O(^HLCS(870,"AISTAT","P",HLXX,HLD1)) Q:'HLD1 D - . . . ;I '$D(^HLCS(870,HLXX,1,HLD1,0)) K ^HLCS(870,"AISTAT","P",HLXX,HLD1) - . . . I $P($G(^HLCS(870,HLXX,1,HLD1,0)),U,2)'="P" K ^HLCS(870,"AISTAT","P",HLXX,HLD1) - . L -^HLCS(870,HLXX,"INFILER") - Q -DELQUE(HLPTRFLR,HLEXIT) ; Delete messages outside the 'queue size' window. - N HLDIR,HLXX,HLFRONT - S HLDIR=1,HLXX=0 - F S HLXX=$O(^HLCS(870,HLXX)) Q:'HLXX D Q:HLEXIT - . D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT - . ; patch HL*1.6*122, comment out, no need to lock - . ; L +^HLCS(870,HLXX,"IN QUEUE FRONT POINTER"):0 Q:'$T - . S HLFRONT=$G(^HLCS(870,HLXX,"IN QUEUE FRONT POINTER")) - . ; patch HL*1.6*122, comment out - . ; L -^HLCS(870,HLXX,"IN QUEUE FRONT POINTER") - . D DELETE^HLCSQUE1(HLXX,HLDIR,HLFRONT) - Q -CHKUPD(HLPTRFLR,HLEXIT) ; - Q:$$HDIFF^XLFDT($H,$G(HLPTRFLR("LASTUP")),2)<15 - D SETFLRDH^HLCSUTL1(HLPTRFLR,"IN") ; Update LAST KNOWN $H (field #.03) for filer - S HLPTRFLR("LASTUP")=$H - D CHK4STOP^HLCSUTL2(HLPTRFLR,"IN",.HLEXIT) Q:HLEXIT - Q +HLCSIN ;ALB/JRP - INCOMING FILER;01-MAY-95 ;11/15/2000 09:37 + ;;1.6;HEALTH LEVEL SEVEN;**2,30,14,19,62,109,115**;Oct 13, 1995 +STARTIN ;Main entry point for incoming background filer + ;Create/find entry denoting this filer in the INCOMING FILER TASK + ; NUMBER multiple (field #20) of the HL COMMUNICATION SERVER PARAMETER + ; file (#869.3) + ;N HLOGLINK,HLNODE,HLPARENT,HLST1,TMP ; These vbls aren't used! + N HLFLG,HLEXIT,HLPTRFLR + S HLPTRFLR=+$$CRTFLR^HLCSUTL1(ZTSK,"IN") + ;Loop through Logical Links and check for incoming messages + S HLEXIT=0 + F D Q:HLEXIT + . S HLFLG=0 + . D DEFACK(.HLPTRFLR,.HLFLG,.HLEXIT) Q:HLEXIT + . D ACKNOW(.HLPTRFLR,.HLFLG,.HLEXIT) Q:HLEXIT + . Q:HLFLG + . I $$HDIFF^XLFDT($H,$G(HLPTRFLR("LASTDEL")),2)>3600 D Q + . . S HLPTRFLR("LASTDEL")=$H ; maintain queue sizes + . . D DELQUE(.HLPTRFLR,.HLEXIT) ; no more than once an hour. + . H 5 + . D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT + S ZTSTOP=1 ;Asked to stop + D DELFLR^HLCSUTL1(HLPTRFLR,"IN") ;Delete entry denoting this filer + S ZTREQ="@" + Q +DEFACK(HLPTRFLR,HLFLG,HLEXIT) ; Process TCP links with a deferred response + N HLXX,HLD0,HLPCT + S HLXX=0 + F S HLXX=$O(^HLMA("AC","I",HLXX)) Q:'HLXX D Q:HLEXIT + . D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT + . ; HL*1.6*109 + . L +^HLMA("AC","I",HLXX):0 Q:'$T ;*109*Does another filer have this? + . S HLD0=0,HLFLG=1 + . ; HL*1.6*109 changes in for loop below, and post-quit code placed + . ; on following lines. + . S HLPCT=0 ; Counter whether filer should stop every 100th entry. + .;**109 - insure queue last processed at least 2 seconds ago + . I ($$HDIFF^XLFDT($H,$G(^XTMP("HL7-AC","I",HLXX)),2)<2) L -^HLMA("AC","I",HLXX) Q + . F S HLD0=$O(^HLMA("AC","I",HLXX,HLD0)) Q:'HLD0!(HLEXIT) D + . . S HLPCT=HLPCT+1 + . . I '(HLPCT#100) D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT + . . L +^HLMA(HLD0):0 Q:'$T + . . I '$$CHECKAC("I",HLXX,HLD0) L -^HLMA(HLD0) Q ;-> Quit if not a valid AC xref + . . D DEFACK^HLTP3(HLXX,HLD0) + . . D DEQUE^HLCSREP(HLXX,"I",HLD0) + . . L -^HLMA(HLD0) + . ;**109 -add dt/tm stamp to time queue last processed + . S ^XTMP("HL7-AC","I",HLXX)=$H + . ;**109 -unlock the queue + . L -^HLMA("AC","I",HLXX) + Q + ; +CHECKAC(WAY,IEN870,IEN773) ; If AC xref shouldn't exist, kill it... + ; + ; Check status and if 3 (processed) kill XREF... + I $P($G(^HLMA(+IEN773,"P")),U)=3 D QUIT "" ;-> + . D DEQUE^HLCSREP(IEN870,WAY,IEN773) + ; + ; Add other checks here in the future... + ; + Q 1 + ; +ACKNOW(HLPTRFLR,HLFLG,HLEXIT) ; Process Logical Link's IN-queue for received message + N HLXX,HLD0,HLD1 + S HLXX=0 + F S HLXX=$O(^HLCS(870,"AISTAT","P",HLXX)) Q:'HLXX D Q:HLEXIT + . D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT + .; HL*1.6*109 + . L +^HLCS(870,HLXX,"INFILER"):0 Q:'$T ;Does another filer have this? + . F D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT S HLD0=$$DEQUEUE^HLCSQUE(HLXX,"IN") Q:+HLD0<0 D + . . ;Make sure message is ready to be received + . . S HLFLG=1 + . . S HLD1=$P(HLD0,"^",2) + . . S HLD0=+HLD0 ; At this point, HLD0=HLXX + . . I $P($G(^HLCS(870,HLD0,1,HLD1,0)),"^",3)'="A" D Q + . . . D MONITOR^HLCSDR2("D",2,HLD0,HLD1,"IN") ;Set status to DONE + . . D RECEIVE^HLMA0(HLD0,HLD1) ;Process received message + . . D MONITOR^HLCSDR2("D",2,HLD0,HLD1,"IN") ;Set status to DONE + . I HLD0<0,$D(^HLCS(870,"AISTAT","P",HLXX)) D + . . S HLD1=0 ; Make sure there aren't any loose xrefs hanging around. + . . F S HLD1=$O(^HLCS(870,"AISTAT","P",HLXX,HLD1)) Q:'HLD1 D + . . . ;I '$D(^HLCS(870,HLXX,1,HLD1,0)) K ^HLCS(870,"AISTAT","P",HLXX,HLD1) + . . . I $P($G(^HLCS(870,HLXX,1,HLD1,0)),U,2)'="P" K ^HLCS(870,"AISTAT","P",HLXX,HLD1) + . L -^HLCS(870,HLXX,"INFILER") + Q +DELQUE(HLPTRFLR,HLEXIT) ; Delete messages outside the 'queue size' window. + N HLDIR,HLXX,HLFRONT + S HLDIR=1,HLXX=0 + F S HLXX=$O(^HLCS(870,HLXX)) Q:'HLXX D Q:HLEXIT + . D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT + . L +^HLCS(870,HLXX,"IN QUEUE FRONT POINTER"):0 Q:'$T + . S HLFRONT=$G(^HLCS(870,HLXX,"IN QUEUE FRONT POINTER")) + . L -^HLCS(870,HLXX,"IN QUEUE FRONT POINTER") + . D DELETE^HLCSQUE1(HLXX,HLDIR,HLFRONT) + Q +CHKUPD(HLPTRFLR,HLEXIT) ; + Q:$$HDIFF^XLFDT($H,$G(HLPTRFLR("LASTUP")),2)<15 + D SETFLRDH^HLCSUTL1(HLPTRFLR,"IN") ; Update LAST KNOWN $H (field #.03) for filer + S HLPTRFLR("LASTUP")=$H + D CHK4STOP^HLCSUTL2(HLPTRFLR,"IN",.HLEXIT) Q:HLEXIT + Q diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLCSLM.m b/r/HEALTH_LEVEL_SEVEN-HL/HLCSLM.m index 94ccef26..b767f897 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLCSLM.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLCSLM.m @@ -1,243 +1,240 @@ -HLCSLM ;SFCIOFO/AC - HL7 LINK MANAGER ;03/19/2008 10:01 - ;;1.6;HEALTH LEVEL SEVEN;**49,57,109,123,140**;Oct 13, 1995;Build 5 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; -EN ;Entry point for start up task - N %,HLEVLCHK,HLTSKCNT - F %=1:1:10 L +^HLCS("HLCSLM"):2 Q:$T - E Q - I $G(ZTQUEUED) S Y=$$PSET^%ZTLOAD(ZTQUEUED) - D INIT,SAVDOLRH - D SETNM^%ZOSV($E("HLmgr:"_$G(ZTQUEUED),1,15)) - ; -LOOP ; - D CHKQUE - I $$CKLMSTOP G EXIT - D SAVDOLRH - D CHECKMST^HLEVMST ;HL*1.6*109 - Make sure event monitor current - ; patch HL*1.6*140 - ; H 10 - H 5 - G LOOP - ; -EXIT N HLJ,X - S X=1 - F L +^HLCS(869.3,X,5):2 Q:$T - ;52=Link Manager task number - S HLJ(869.3,X_",",52)="@" - D FILE^HLDIE("","HLJ","","EXIT","HLCSLM") ;HL*1.6*109 - L -^HLCS(869.3,X,5) - L -^HLCS("HLCSLM") - Q - ; -SAVDOLRH ;Save Last Known $H - N HLJ,X - S X=1 - F L +^HLCS(869.3,X,5):2 Q:$T - ;54=LM LAST KNOWN $H - S HLJ(869.3,X_",",54)=$H - D FILE^HLDIE("","HLJ","","SAVDOLRH","HLCSLM") ;HL*1.6*109 - L -^HLCS(869.3,X,5) - Q - ; -CHKQUE ;Check queues for messages to send - ;HLTSKCNT(logical link)=task #^$H - N HLDA,HLDP,HLMSG,HLTSK,Y - S (HLDA,HLMSG)="" - F HLDP=0:0 S HLDP=+$O(^HLMA("AC","O",HLDP)) Q:HLDP'>0 S HLMSG=+$O(^(HLDP,0)) I HLMSG D L -^HLCS("HLCSLSM",HLDP) - .;quit if persistent link - .Q:$P($G(^HLCS(870,HLDP,400)),U,4)="Y" - .L +^HLCS("HLCSLSM",HLDP):0 E K HLTSKCNT(HLDP) Q - .Q:'$$LLOK(+HLDP) - .;get tasknumber from file 870 and HLTSKCNT array - .S Y=$$TASKNUM(HLDP),HLTSK=$G(HLTSKCNT(HLDP)) - . ; - . ;patch HL*1.6*123 start - . S HLDP("TASK-ACTIVE")=0 - . ; - . I Y D - .. N ZTSK - .. S ZTSK=Y - .. ; Check status of task - .. D STAT^%ZTLOAD - .. I "12"[ZTSK(1) S HLDP("TASK-ACTIVE")=1 - . Q:HLDP("TASK-ACTIVE") - . ; - . I HLTSK D - .. N ZTSK - .. S ZTSK=+HLTSK - .. ; Check status of task - .. D STAT^%ZTLOAD - .. I "12"[ZTSK(1) S HLDP("TASK-ACTIVE")=1 - . Q:HLDP("TASK-ACTIVE") - . ; - . ;no tasknumber, link not running nor queued, task it - . I 'HLTSK!'Y D TASKLSUB(HLDP),SAVTSK(HLDP) Q - ; comment out the following lines - ; .;link was tasked, check time - ; .S Y=$P(HLTSK,U,2) - ; .;check that time task is less than 30 minutes - ; .Q:$$HDIFF^XLFDT($H,Y,2)<1800 - ; .;shutdown and send alert - ; .D SDFLD^HLCSTCP,EXITS^HLCSTCP("Shutdown"),SNDALERT - ; loop through links that have been tasked - ; F HLDP=0:0 S HLDP=$O(HLTSKCNT(HLDP)) Q:HLDP'>0 K:'$D(^HLMA("AC","O",HLDP)) HLTSKCNT(HLDP) - F HLDP=0:0 S HLDP=$O(HLTSKCNT(HLDP)) Q:HLDP'>0 D - . N ZTSK - . S ZTSK=+HLTSKCNT(HLDP) - . ; Check status of task - . D STAT^%ZTLOAD - . ; kill HLTSKCNT(HLDP) if process is not active - . I "12"'[ZTSK(1) K HLTSKCNT(HLDP) - ; patch HL*1.6*123 end - Q - ; -INIT ;Create Task number and clear Stop flag. - N HLJ,X - S X=1 - F L +^HLCS(869.3,X,5):2 Q:$T - ;52=Link Manager task number,53=Stop Link Manager - S HLJ(869.3,X_",",52)=$G(ZTQUEUED) - S HLJ(869.3,X_",",53)="@" - D FILE^HLDIE("","HLJ","","INIT","HLCSLM") ;HL*1.6*109 - L -^HLCS(869.3,X,5) - Q -TASKNUM(X) ;Look-up task number - N %,DA,Y - S DA=X - ; - ;**109** - ;F L +^HLCS(870,+DA,0):2 Q:$T - ; - S Y=$$GET1^DIQ(870,DA_",",11) - ; - ;**109 - ;L -^HLCS(870,+DA,0) - ; - Q Y -STATUS(X) ;Status of task - N Y,ZTSK - S ZTSK=X - D STAT^%ZTLOAD - S Y=ZTSK(1) - Q Y - ; -LLOK(X) ;Function to check whether LL ok. - ;return value 1 = ok, 0 = not ok. - Q:'$G(X) - N HLDP,HLDP0,HLPARM4,HLTYPTR - S HLDP=+X,HLDP0=$G(^HLCS(870,HLDP,0)),HLPARM4=$G(^(400)) Q:HLDP0="" 0 - ;must be a client - Q:$P(HLPARM4,U,3)'="C" 0 - ; - ; patch HL*1.6*123 - ;shutdown LLP must be 0 - ; Q:$P(HLDP0,U,15)'=0 0 - ; change to 1, in case the data is empty - Q:$P(HLDP0,U,15)=1 0 - ; - ;must have LLP Type of TCP - S HLTYPTR=+$P(HLDP0,U,3) Q:$P($G(^HLCS(869.1,HLTYPTR,0)),U)'="TCP" 0 - Q 1 - ; -SAVTSK(X) ; - N HLDP,HLJ - S HLDP=X - ; - ;**109** - F L +^HLCS(870,HLDP,0):2 Q:$T - ; - ;4=status,10=Time Stopped,9=Time Started,11=Task Number,3=Online ? - S X=$NA(HLJ(870,HLDP_",")),@X@(11)=$G(ZTSK) - ;S HLJ(870,HLDP_",",11)=$G(ZTSK) - D FILE^HLDIE("","HLJ","","SAVTSK","HLCSLM") ; HL*1.6*109 - S HLTSKCNT(HLDP)=$G(ZTSK)_"^"_$H - ; - ;**109** - L -^HLCS(870,HLDP,0) - ; - Q - ; -STRTSTOP ;ENTRY POINT TO START/STOP TCP LINK MANAGER - N DIR,DIRUT,Y - L +^HLCS("HLCSLM"):3 E D Q - .W !,*7,"Link Manager already running!" - .W ! S DIR(0)="YO",DIR("A")="Would you like to stop the Link Manager now",DIR("B")="NO" D ^DIR K DIR - .I $D(DIRUT)!'Y Q - .D STOPLM - W !,*7,"Link Manager is NOT currently running!" - W ! S DIR(0)="YO",DIR("A")="Would you like to start the Link Manager now",DIR("B")="YES" D ^DIR K DIR - I '$D(DIRUT)&Y D TASKLM - L -^HLCS("HLCSLM") - Q - ; -STOPLM ;ENTRY POINT TO STOP LINK MANAGER - N DIC,X,Y,DTOUT,DUOUT,DLAYGO,DIE,DA,DR - S DIC="^HLCS(869.3," - S X=1 - D ^DIC - S DA=+Y,DIE=DIC - S DR="53////1" - D ^DIE - W !,"Link Manager has been asked to stop" - Q -STAT() ;Status of LINK MANAGER--up, down or unable to determine. - N %,DA,X,Y - S DA=1 - S X=$$GET1^DIQ(869.3,DA_",",52) - Q:X']"" 0 - S X=$$GET1^DIQ(869.3,DA_",",54) - Q:X']"" 0 - I $$HDIFF^XLFDT($H,X,2)>500 Q 0 - Q 1 - ; -TASKLSUB(X) ;Task LINK SUB-MANAGER. - ;This may be a place to log the time which the LINK SUBMANAGER is tasked. - N HLDP,HLDP0,HLDAPP,HLTYPTR,HLBGR,HLENV,HLPARM,HLPARM4,HLQUIT,ZTRTN,ZTDESC,ZTCPU,ZTSAVE - ;ZTSK is not Newed here because it will be needed by SAVTSK. - S HLDP=X,HLDP0=$G(^HLCS(870,HLDP,0)),HLPARM4=$G(^(400)) - ; Q:"N"'[$P(HLPARM4,U,4) ; patch HL*1.6*123: comment out - ;quit if no LLP TYPE - S HLDAPP=$P(HLDP0,U),HLTYPTR=$P(HLDP0,U,3) Q:'HLTYPTR - S HLBGR=$G(^HLCS(869.1,HLTYPTR,100)),HLENV=$G(^(200)) - I HLENV'="" K HLQUIT X HLENV Q:$D(HLQUIT) - S ZTRTN="^HLCSLSM",HLBGR=$P(HLBGR," ",2) - S ZTDESC=HLDAPP_" Low Level Protocol",ZTSAVE("HLDP")="",ZTSAVE("HLBGR")="" - S ZTIO="",ZTDTH=$H - ;get startup node - I $P(HLPARM4,U,6),$D(^%ZIS(14.7,+$P(HLPARM4,U,6),0)) S ZTCPU=$P(^(0),U) - D ^%ZTLOAD - D MON^HLCSTCP("Tasked") ;HL*1.6*123 - Q - ; -TASKLM ;Task Link Manager - ;Declare variables - N ZTRTN,ZTDESC,ZTIO,ZTDTH,ZTSK,TMP - S ZTIO="" - S ZTDTH=$H - ;Task Link Manager - S ZTRTN="EN^HLCSLM" - S ZTDESC="HL7 Link Manager" - ;Call TaskMan - D ^%ZTLOAD - I $G(ZTSK) W !,"Link Manager queued as task number ",ZTSK - E W $C(7),!!,"Unable to start/restart Link Manager" - Q - ; -CKLMSTOP() ;Check whether Link Manager should stop - N PTRMAIN,NODE5,STOP - S PTRMAIN=+$O(^HLCS(869.3,0)) - L +^HLCS(869.3,PTRMAIN,5):1 - I $T L -^HLCS(869.3,PTRMAIN,5) - S NODE5=$G(^HLCS(869.3,PTRMAIN,5)) - S STOP=+$P(NODE5,"^",3) - Q:STOP STOP - S STOP=$$S^%ZTLOAD - Q STOP - ; -SNDALERT ;Send Alert - N XQA,XQAMSG,XQAOPT,XQAROU,XQAID,Z - S Z=$P($$PARAM^HLCS2,U,8) Q:Z="" - S XQA("G."_Z)="",XQAMSG="HL7 Logical Link "_$P(^HLCS(870,HLDP,0),U)_" shutdown due to TaskMan unable to process task request" - D SETUP^XQALERT - Q +HLCSLM ;SFCIOFO/AC - HL7 LINK MANAGER ;06/14/2005 10:29 + ;;1.6;HEALTH LEVEL SEVEN;**49,57,109,123**;Oct 13, 1995 + ; +EN ;Entry point for start up task + N %,HLEVLCHK,HLTSKCNT + F %=1:1:10 L +^HLCS("HLCSLM"):2 Q:$T + E Q + I $G(ZTQUEUED) S Y=$$PSET^%ZTLOAD(ZTQUEUED) + D INIT,SAVDOLRH + D SETNM^%ZOSV($E("HLmgr:"_$G(ZTQUEUED),1,15)) + ; +LOOP ; + D CHKQUE + I $$CKLMSTOP G EXIT + D SAVDOLRH + D CHECKMST^HLEVMST ;HL*1.6*109 - Make sure event monitor current + H 10 + G LOOP + ; +EXIT N HLJ,X + S X=1 + F L +^HLCS(869.3,X,5):2 Q:$T + ;52=Link Manager task number + S HLJ(869.3,X_",",52)="@" + D FILE^HLDIE("","HLJ","","EXIT","HLCSLM") ;HL*1.6*109 + L -^HLCS(869.3,X,5) + L -^HLCS("HLCSLM") + Q + ; +SAVDOLRH ;Save Last Known $H + N HLJ,X + S X=1 + F L +^HLCS(869.3,X,5):2 Q:$T + ;54=LM LAST KNOWN $H + S HLJ(869.3,X_",",54)=$H + D FILE^HLDIE("","HLJ","","SAVDOLRH","HLCSLM") ;HL*1.6*109 + L -^HLCS(869.3,X,5) + Q + ; +CHKQUE ;Check queues for messages to send + ;HLTSKCNT(logical link)=task #^$H + N HLDA,HLDP,HLMSG,HLTSK,Y + S (HLDA,HLMSG)="" + F HLDP=0:0 S HLDP=+$O(^HLMA("AC","O",HLDP)) Q:HLDP'>0 S HLMSG=+$O(^(HLDP,0)) I HLMSG D L -^HLCS("HLCSLSM",HLDP) + .;quit if persistent link + .Q:$P($G(^HLCS(870,HLDP,400)),U,4)="Y" + .L +^HLCS("HLCSLSM",HLDP):0 E K HLTSKCNT(HLDP) Q + .Q:'$$LLOK(+HLDP) + .;get tasknumber from file 870 and HLTSKCNT array + .S Y=$$TASKNUM(HLDP),HLTSK=$G(HLTSKCNT(HLDP)) + . ; + . ;patch HL*1.6*123 start + . S HLDP("TASK-ACTIVE")=0 + . ; + . I Y D + .. N ZTSK + .. S ZTSK=Y + .. ; Check status of task + .. D STAT^%ZTLOAD + .. I "12"[ZTSK(1) S HLDP("TASK-ACTIVE")=1 + . Q:HLDP("TASK-ACTIVE") + . ; + . I HLTSK D + .. N ZTSK + .. S ZTSK=+HLTSK + .. ; Check status of task + .. D STAT^%ZTLOAD + .. I "12"[ZTSK(1) S HLDP("TASK-ACTIVE")=1 + . Q:HLDP("TASK-ACTIVE") + . ; + . ;no tasknumber, link not running nor queued, task it + . I 'HLTSK!'Y D TASKLSUB(HLDP),SAVTSK(HLDP) Q + ; comment out the following lines + ; .;link was tasked, check time + ; .S Y=$P(HLTSK,U,2) + ; .;check that time task is less than 30 minutes + ; .Q:$$HDIFF^XLFDT($H,Y,2)<1800 + ; .;shutdown and send alert + ; .D SDFLD^HLCSTCP,EXITS^HLCSTCP("Shutdown"),SNDALERT + ; loop through links that have been tasked + ; F HLDP=0:0 S HLDP=$O(HLTSKCNT(HLDP)) Q:HLDP'>0 K:'$D(^HLMA("AC","O",HLDP)) HLTSKCNT(HLDP) + F HLDP=0:0 S HLDP=$O(HLTSKCNT(HLDP)) Q:HLDP'>0 D + . N ZTSK + . S ZTSK=+HLTSKCNT(HLDP) + . ; Check status of task + . D STAT^%ZTLOAD + . ; kill HLTSKCNT(HLDP) if process is not active + . I "12"'[ZTSK(1) K HLTSKCNT(HLDP) + ; patch HL*1.6*123 end + Q + ; +INIT ;Create Task number and clear Stop flag. + N HLJ,X + S X=1 + F L +^HLCS(869.3,X,5):2 Q:$T + ;52=Link Manager task number,53=Stop Link Manager + S HLJ(869.3,X_",",52)=$G(ZTQUEUED) + S HLJ(869.3,X_",",53)="@" + D FILE^HLDIE("","HLJ","","INIT","HLCSLM") ;HL*1.6*109 + L -^HLCS(869.3,X,5) + Q +TASKNUM(X) ;Look-up task number + N %,DA,Y + S DA=X + ; + ;**109** + ;F L +^HLCS(870,+DA,0):2 Q:$T + ; + S Y=$$GET1^DIQ(870,DA_",",11) + ; + ;**109 + ;L -^HLCS(870,+DA,0) + ; + Q Y +STATUS(X) ;Status of task + N Y,ZTSK + S ZTSK=X + D STAT^%ZTLOAD + S Y=ZTSK(1) + Q Y + ; +LLOK(X) ;Function to check whether LL ok. + ;return value 1 = ok, 0 = not ok. + Q:'$G(X) + N HLDP,HLDP0,HLPARM4,HLTYPTR + S HLDP=+X,HLDP0=$G(^HLCS(870,HLDP,0)),HLPARM4=$G(^(400)) Q:HLDP0="" 0 + ;must be a client + Q:$P(HLPARM4,U,3)'="C" 0 + ; + ; patch HL*1.6*123 + ;shutdown LLP must be 0 + ; Q:$P(HLDP0,U,15)'=0 0 + ; change to 1, in case the data is empty + Q:$P(HLDP0,U,15)=1 0 + ; + ;must have LLP Type of TCP + S HLTYPTR=+$P(HLDP0,U,3) Q:$P($G(^HLCS(869.1,HLTYPTR,0)),U)'="TCP" 0 + Q 1 + ; +SAVTSK(X) ; + N HLDP,HLJ + S HLDP=X + ; + ;**109** + F L +^HLCS(870,HLDP,0):2 Q:$T + ; + ;4=status,10=Time Stopped,9=Time Started,11=Task Number,3=Online ? + S X=$NA(HLJ(870,HLDP_",")),@X@(11)=$G(ZTSK) + ;S HLJ(870,HLDP_",",11)=$G(ZTSK) + D FILE^HLDIE("","HLJ","","SAVTSK","HLCSLM") ; HL*1.6*109 + S HLTSKCNT(HLDP)=$G(ZTSK)_"^"_$H + ; + ;**109** + L -^HLCS(870,HLDP,0) + ; + Q + ; +STRTSTOP ;ENTRY POINT TO START/STOP TCP LINK MANAGER + N DIR,DIRUT,Y + L +^HLCS("HLCSLM"):3 E D Q + .W !,*7,"Link Manager already running!" + .W ! S DIR(0)="YO",DIR("A")="Would you like to stop the Link Manager now",DIR("B")="NO" D ^DIR K DIR + .I $D(DIRUT)!'Y Q + .D STOPLM + W !,*7,"Link Manager is NOT currently running!" + W ! S DIR(0)="YO",DIR("A")="Would you like to start the Link Manager now",DIR("B")="YES" D ^DIR K DIR + I '$D(DIRUT)&Y D TASKLM + L -^HLCS("HLCSLM") + Q + ; +STOPLM ;ENTRY POINT TO STOP LINK MANAGER + N DIC,X,Y,DTOUT,DUOUT,DLAYGO,DIE,DA,DR + S DIC="^HLCS(869.3," + S X=1 + D ^DIC + S DA=+Y,DIE=DIC + S DR="53////1" + D ^DIE + W !,"Link Manager has been asked to stop" + Q +STAT() ;Status of LINK MANAGER--up, down or unable to determine. + N %,DA,X,Y + S DA=1 + S X=$$GET1^DIQ(869.3,DA_",",52) + Q:X']"" 0 + S X=$$GET1^DIQ(869.3,DA_",",54) + Q:X']"" 0 + I $$HDIFF^XLFDT($H,X,2)>500 Q 0 + Q 1 + ; +TASKLSUB(X) ;Task LINK SUB-MANAGER. + ;This may be a place to log the time which the LINK SUBMANAGER is tasked. + N HLDP,HLDP0,HLDAPP,HLTYPTR,HLBGR,HLENV,HLPARM,HLPARM4,HLQUIT,ZTRTN,ZTDESC,ZTCPU,ZTSAVE + ;ZTSK is not Newed here because it will be needed by SAVTSK. + S HLDP=X,HLDP0=$G(^HLCS(870,HLDP,0)),HLPARM4=$G(^(400)) + ; Q:"N"'[$P(HLPARM4,U,4) ; patch HL*1.6*123: comment out + ;quit if no LLP TYPE + S HLDAPP=$P(HLDP0,U),HLTYPTR=$P(HLDP0,U,3) Q:'HLTYPTR + S HLBGR=$G(^HLCS(869.1,HLTYPTR,100)),HLENV=$G(^(200)) + I HLENV'="" K HLQUIT X HLENV Q:$D(HLQUIT) + S ZTRTN="^HLCSLSM",HLBGR=$P(HLBGR," ",2) + S ZTDESC=HLDAPP_" Low Level Protocol",ZTSAVE("HLDP")="",ZTSAVE("HLBGR")="" + S ZTIO="",ZTDTH=$H + ;get startup node + I $P(HLPARM4,U,6),$D(^%ZIS(14.7,+$P(HLPARM4,U,6),0)) S ZTCPU=$P(^(0),U) + D ^%ZTLOAD + D MON^HLCSTCP("Tasked") ;HL*1.6*123 + Q + ; +TASKLM ;Task Link Manager + ;Declare variables + N ZTRTN,ZTDESC,ZTIO,ZTDTH,ZTSK,TMP + S ZTIO="" + S ZTDTH=$H + ;Task Link Manager + S ZTRTN="EN^HLCSLM" + S ZTDESC="HL7 Link Manager" + ;Call TaskMan + D ^%ZTLOAD + I $G(ZTSK) W !,"Link Manager queued as task number ",ZTSK + E W $C(7),!!,"Unable to start/restart Link Manager" + Q + ; +CKLMSTOP() ;Check whether Link Manager should stop + N PTRMAIN,NODE5,STOP + S PTRMAIN=+$O(^HLCS(869.3,0)) + L +^HLCS(869.3,PTRMAIN,5):1 + I $T L -^HLCS(869.3,PTRMAIN,5) + S NODE5=$G(^HLCS(869.3,PTRMAIN,5)) + S STOP=+$P(NODE5,"^",3) + Q:STOP STOP + S STOP=$$S^%ZTLOAD + Q STOP + ; +SNDALERT ;Send Alert + N XQA,XQAMSG,XQAOPT,XQAROU,XQAID,Z + S Z=$P($$PARAM^HLCS2,U,8) Q:Z="" + S XQA("G."_Z)="",XQAMSG="HL7 Logical Link "_$P(^HLCS(870,HLDP,0),U)_" shutdown due to TaskMan unable to process task request" + D SETUP^XQALERT + Q diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLCSLNCH.m b/r/HEALTH_LEVEL_SEVEN-HL/HLCSLNCH.m index 51870453..789fc79f 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLCSLNCH.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLCSLNCH.m @@ -1,168 +1,127 @@ -HLCSLNCH ;ALB/MTC/JC - START AND STOP THE LLP ;07/26/2007 17:10 - ;;1.6;HEALTH LEVEL SEVEN;**6,19,43,49,57,75,84,109,122**;Oct 13, 1995;Build 14 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; - ;This program is callable from a menu - ;It allows the user to Start and Stop the Lower Layer - ;Protocol in the Background or in the foreground - ; - ;Required or Optional INPUT PARAMETERS - ; None - ; - ; - ;Output variables - ; HLDP=IEN of Logical Link in file #870 - ;(optional)HLTRACE=if SET it launches the LLP in the Foreground - ;(optional) ZTSK=if defined LLP was launched in the - ;background - ; - ; -START ; Start up the lower level protocol - N DIC,DIRUT,DTOUT,DUOUT,HLDP,HLDAPP,HLJ,HLQUIT,HLTRACE - N HLPARM0,HLPARM4,HLTYPTR,HLBGR,X,Y,ZTCPU,ZTSK,ZTRTN,ZTDESC - W !!,"This option is used to launch the lower level protocol for the" - W !,"appropriate device. Please select the node with which you want" - W !,"to communicate",! - ; patch HL*1.6*122 - S POP=0 - S DIC="^HLCS(870,",DIC(0)="QEAMZ" D ^DIC G:Y<0 STARTQ - S HLDP=+Y,HLDAPP=Y(0,0),HLTYPTR=+$P(Y(0),U,3),HLPARM0=Y(0) - ;-- check if parameter have been setup - ;-- check for LLP type - I 'HLTYPTR W !!,$C(7),"A Lower Layer Protocol must be selected before start-up can occur." G STARTQ - ;-- get TCP information - S HLPARM4=$G(^HLCS(870,HLDP,400)) - ;-- get routine (background job for LLP) - S HLBGR=$G(^HLCS(869.1,HLTYPTR,100)) - ;-- get environment check routine (HLQUIT should be defined in fails) - S HLENV=$G(^HLCS(869.1,HLTYPTR,200)) - ; - I HLBGR="" W !!,$C(7),"No routine has been specified for this LLP." G STARTQ - ; - ;-- execute environment check routine if HLQUIT is defined then terminate - I HLENV'="" X HLENV G:$D(HLQUIT) STARTQ - ; patch HL*1.6*122 start - ; Multi-Servers: TCP service (GT.M, DSM, and Cache/VMS) is controlled - ; by the external service - I $P(HLPARM4,U,3)="M",$S(^%ZOSF("OS")'["OpenM":1,1:$$OS^%ZOSV["VMS") D G STARTQ - . W !,$C(7),"This LLP is a multi-threaded server. It is controlled by external service, i.e. TCPIP/UCX. You must use the external service to start this LLP." - . Q - ; patch HL*1.6*122 end - ; - I $P(HLPARM0,U,10) W !,$C(7),"The LLP was last started on ",$$DAT2^HLUTIL1($P(HLPARM0,U,10)),"." G STP1:$P(HLPARM0,U,5)'="Error" - I $P(HLPARM0,U,11) W !,"The LLP was last shutdown on ",$$DAT2^HLUTIL1($P(HLPARM0,U,11)),"." - ; patch HL*1.6*122 start - ; comment out-should be taken care of by the code 2 line above - ; I $P(HLPARM0,U,5)'="Error",'($P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4))),$P(HLPARM0,U,10)]""&($P(HLPARM0,U,11)=""),$P(HLPARM0,U,12) W !,"The LLP appears to be online already !" - ; I $$TASK^HLUTIL1($P(HLPARM0,U,12)) D G STARTQ - ; . W !,$C(7),"NOTE: The lower level protocol for this application is already running." - N HLTEMP - S HLTEMP=0 - I $P(HLPARM0,U,12) D G:HLTEMP STARTQ - . N ZTSK - . S ZTSK=$P(HLPARM0,U,12) - . D STAT^%ZTLOAD - . I "12"[ZTSK(1) D - .. W !,$C(7),"NOTE: The lower level protocol for this application is already running." - .. I '$P(^HLCS(870,HLDP,0),"^",10) S $P(^HLCS(870,HLDP,0),"^",10)=$$NOW^XLFDT - .. S HLTEMP=1 - ; patch HL*1.6*122 end - I $P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4)) D G STARTQ - .;4=status 9=Time Started, 10=Time Stopped, 11=Task Number - .;14=Shutdown LLP, 3=Device Type, 18=Gross Errors - .N HLJ,X - . ; patch HL*1.6*122-comment out - . ; I $P(HLPARM0,U,15)=0 W !,"This LLP is already enabled!" Q - .L +^HLCS(870,HLDP,0):2 - .E W !,$C(7),"Unable to enable this LLP !" Q - .S X="HLJ(870,"""_HLDP_","")" - .S @X@(4)="Enabled",@X@(9)=$$NOW^XLFDT,@X@(14)=0 - .D FILE^HLDIE("","HLJ","","START","HLCSLNCH") ;HL*1.6*109 - .L -^HLCS(870,HLDP,0) - .W !,"This LLP has been enabled!" - .Q - I $P(HLPARM4,U,6),$D(^%ZIS(14.7,+$P(HLPARM4,U,6),0)) S ZTCPU=$P(^(0),U) W !,"This LLP will start on node ",ZTCPU," if it is run in the Background.",! - ; - ; patch HL*1.6*122 start, for tcp link - I HLTYPTR=4 D Q - . S Y="B" - . D STARTJOB - ; patch HL*1.6*122 end - ; - W ! S DIR(0)="SM^F:FOREGROUND;B:BACKGROUND;Q:QUIT" - S DIR("A")="Method for running the receiver" - S DIR("B")="B" - S DIR("?",1)="Enter F for Foreground (and trace)" - S DIR("?",2)=" B for Background (normal) or" - S DIR("?")=" Q to quit without starting the receiver" - D ^DIR K DIR - Q:(Y=U)!(Y="Q") - ; -STARTJOB ; - S HLX=$G(^HLCS(870,HLDP,0)) - ;-- foreground - I Y="F" S HLTRACE=1 D G STARTQ - . S $P(^HLCS(870,HLDP,0),"^",10)=$$NOW^XLFDT - . D MON^HLCSTCP("Start") - . X HLBGR - ;-- background - I Y="B" D G STARTQ - . S ZTRTN=$P(HLBGR," ",2),HLTRACE="",ZTIO="",ZTDTH=$H - . S ZTDESC=HLDAPP_" Low Level Protocol",ZTSAVE("HLDP")="" - . D ^%ZTLOAD - . ; patch HL*1.6*122 start - . I $D(ZTSK) D - .. K HLTRACE - .. D MON^HLCSTCP("Tasked") - .. S $P(^HLCS(870,HLDP,0),"^",10)=$$NOW^XLFDT - . ; patch HL*1.6*122 end - . W !,$S($D(ZTSK):"Job was queued as "_ZTSK_".",1:"Unable to queue job.") - ; - Q - ; -STARTQ ; - I $G(POP) W !,?5,"-Unable to Open the Device !",!,!,?6,"Check that Port is Logged Out, and that the",!,?6,"Lower Level Protocol is not Already Running." - Q - ; -STOP ; Shut down a lower level protocol.. - N DIC,DIRUT,DTOUT,DUOUT,HLDP,HLDAPP,HLJ,HLPARM0,HLPARM4,X,Y - W !!,"This option is used to shut down the lower level protocol for the" - W !,"appropriate device. Please select the link which you would" - W !,"like to shutdown.",! - S DIC="^HLCS(870,",DIC(0)="QEAMZ" D ^DIC K DIC Q:Y<0 - S HLDP=+Y,HLDAPP=Y(0,0),HLPARM0=Y(0),HLPARM4=$G(^HLCS(870,HLDP,400)) - ; patch HL*1.6*122 - ; Multi-Servers: TCP service (GT.M, DSM, and Cache/VMS) is controlled - ; by the external service - I $P(HLPARM4,U,3)="M",$S(^%ZOSF("OS")'["OpenM":1,1:$$OS^%ZOSV["VMS") D Q - . W !,$C(7),"This LLP is a multi-threaded server. It is controlled by external service, i.e. TCPIP/UCX. You must use the external service to disable this LLP." - . Q - ; - I $P(HLPARM0,U,15) W !,$C(7),"The lower level protocol is already ",$P(HLPARM0,U,5),"." Q - I $P(HLPARM0,U,10) W !,$C(7),"The lower level protocol was started on ",$$DAT2^HLUTIL1($P(HLPARM0,U,10)),"." -STP1 ; - W ! S DIR(0)="Y",DIR("A")="Okay to shut down this job" D ^DIR K DIR - I 'Y!($D(DIRUT))!($D(DUOUT)) W !!,"The job will not be shut down." Q -S ; - F L +^HLCS(870,HLDP,0):2 Q:$T - ;4=status,10=Time Stopped,9=Time Started,11=Task Number,3=Device Type,14=shutdown - S X="HLJ(870,"""_HLDP_","")",@X@(4)="Halting",@X@(10)=$$NOW^XLFDT,(@X@(11),@X@(9))="@",@X@(14)=1 - I $P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4)),'$P(HLPARM0,U,12) S @X@(4)="Shutdown" - D FILE^HLDIE("","HLJ","","STOP","HLCSLNCH") ; HL*1.6*109 - ; patch HL*1.6*122 start - ; I ^%ZOSF("OS")["OpenM",(($P(HLPARM4,U,3)="M"&($$OS^%ZOSV'["VMS"))!($P(HLPARM4,U,3)="S")) D - ; I ^%ZOSF("OS")'["DSM",(($P(HLPARM4,U,3)="M"&($$OS^%ZOSV'["VMS"))!($P(HLPARM4,U,3)="S")) D - I ($P(HLPARM4,U,3)="S")!(($P(HLPARM4,U,3)="M")&($S(^%ZOSF("OS")'["OpenM":0,1:$$OS^%ZOSV'["VMS"))) D - . ;pass task number to stop listener - . S:$P(HLPARM0,U,12) X=$$ASKSTOP^%ZTLOAD(+$P(HLPARM0,U,12)) - . ; D CALL^%ZISTCP($P(HLPARM4,U),$P(HLPARM4,U,2),10) - . ; I POP D HOME^%ZIS U IO W !,"Unable to shutdown logical link!!!",$C(7),$C(7) Q - . ; U IO W "**STOP**" - . ; W ! - . ; D CLOSE^%ZISTCP - . ; patch HL*1.6*122 end - L -^HLCS(870,HLDP,0) - W !,"The job for the "_HLDAPP_" Lower Level Protocol will be shut down." - Q - ; -STOPQ Q +HLCSLNCH ;ALB/MTC/JC - START AND STOP THE LLP ;12/31/2003 17:37 + ;;1.6;HEALTH LEVEL SEVEN;**6,19,43,49,57,75,84,109**;Oct 13, 1995 + ; + ;This program is callable from a menu + ;It allows the user to Start and Stop the Lower Layer + ;Protocol in the Background or in the foreground + ; + ;Required or Optional INPUT PARAMETERS + ; None + ; + ; + ;Output variables + ; HLDP=IEN of Logical Link in file #870 + ;(optional)HLTRACE=if SET it launches the LLP in the Foreground + ;(optional) ZTSK=if defined LLP was launched in the + ;background + ; + ; +START ; Start up the lower level protocol + N DIC,DIRUT,DTOUT,DUOUT,HLDP,HLDAPP,HLJ,HLQUIT,HLTRACE + N HLPARM0,HLPARM4,HLTYPTR,HLBGR,X,Y,ZTCPU,ZTSK,ZTRTN,ZTDESC + W !!,"This option is used to launch the lower level protocol for the" + W !,"appropriate device. Please select the node with which you want" + W !,"to communicate",! + S DIC="^HLCS(870,",DIC(0)="QEAMZ" D ^DIC G:Y<0 STARTQ + S HLDP=+Y,HLDAPP=Y(0,0),HLTYPTR=+$P(Y(0),U,3),HLPARM0=Y(0) + ;-- check if parameter have been setup + ;-- check for LLP type + I 'HLTYPTR W !,$C(7),"A Lower Layer Protocol must be selected before start-up can occur." G STARTQ + ;-- get TCP information + S HLPARM4=$G(^HLCS(870,HLDP,400)) + ;-- get routine (background job for LLP) + S HLBGR=$G(^HLCS(869.1,HLTYPTR,100)) + ;-- get environment check routine (HLQUIT should be defined in fails) + S HLENV=$G(^HLCS(869.1,HLTYPTR,200)) + ; + I HLBGR="" W !,$C(7),"No routine has been specified for this LLP." G STARTQ + ; + ;-- execute environment check routine if HLQUIT is defined then terminate + I HLENV'="" X HLENV G:$D(HLQUIT) STARTQ + ;Multi-Servers, only enable the link if not OpenM + I $P(HLPARM4,U,3)="M",$S(^%ZOSF("OS")'["OpenM":1,1:$$OS^%ZOSV["VMS") D G STARTQ + . W !,$C(7),"This LLP is a multi-threaded server. It is controlled by external service, i.e. TCPIP/UCX. You must use the external service to start this LLP." + . Q + ; + I $P(HLPARM0,U,10) W !,$C(7),"The LLP was last started on ",$$DAT2^HLUTIL1($P(HLPARM0,U,10)),"." G STP1:$P(HLPARM0,U,5)'="Error" + I $P(HLPARM0,U,11) W !,"The LLP was last shutdown on ",$$DAT2^HLUTIL1($P(HLPARM0,U,11)),"." + I $P(HLPARM0,U,5)'="Error",'($P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4))),$P(HLPARM0,U,10)]""&($P(HLPARM0,U,11)=""),$P(HLPARM0,U,12) W !,"The LLP appears to be online already !" + I $$TASK^HLUTIL1($P(HLPARM0,U,12)) D G STARTQ + . W !,$C(7),"NOTE: The lower level protocol for this application is already running." + I $P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4)) D G STARTQ + .;4=status 9=Time Started, 10=Time Stopped, 11=Task Number + .;14=Shutdown LLP, 3=Device Type, 18=Gross Errors + .N HLJ,X + .I $P(HLPARM0,U,15)=0 W !,"This LLP is already enabled!" Q + .L +^HLCS(870,HLDP,0):2 + .E W !,$C(7),"Unable to enable this LLP !" Q + .S X="HLJ(870,"""_HLDP_","")" + .S @X@(4)="Enabled",@X@(9)=$$NOW^XLFDT,@X@(14)=0 + .D FILE^HLDIE("","HLJ","","START","HLCSLNCH") ;HL*1.6*109 + .L -^HLCS(870,HLDP,0) + .W !,"This LLP has been enabled!" + .Q + I $P(HLPARM4,U,6),$D(^%ZIS(14.7,+$P(HLPARM4,U,6),0)) S ZTCPU=$P(^(0),U) W !,"This LLP will start on node ",ZTCPU," if it is run in the Background.",! + ; + W ! S DIR(0)="SM^F:FOREGROUND;B:BACKGROUND;Q:QUIT" + S DIR("A")="Method for running the receiver" + S DIR("B")="B" + S DIR("?",1)="Enter F for Foreground (and trace)" + S DIR("?",2)=" B for Background (normal) or" + S DIR("?")=" Q to quit without starting the receiver" + D ^DIR K DIR + Q:(Y=U)!(Y="Q") + ; + S HLX=$G(^HLCS(870,HLDP,0)) + ;-- foreground + I Y="F" S HLTRACE=1 D G STARTQ + . X HLBGR + ;-- background + I Y="B" D G STARTQ + . S ZTRTN=$P(HLBGR," ",2),HLTRACE="",ZTIO="",ZTDTH=$H + . S ZTDESC=HLDAPP_" Low Level Protocol",ZTSAVE("HLDP")="" + . D ^%ZTLOAD + . W !,$S($D(ZTSK):"Job was queued as "_ZTSK_".",1:"Unable to queue job.") + ; + Q + ; + ; +STARTQ ; + I $G(POP) W !,?5,"-Unable to Open the Device !",!,!,?6,"Check that Port is Logged Out, and that the",!,?6,"Lower Level Protocol is not Already Running." + Q + ; +STOP ; Shut down a lower level protocol.. + N DIC,DIRUT,DTOUT,DUOUT,HLDP,HLDAPP,HLJ,HLPARM0,HLPARM4,X,Y + W !!,"This option is used to shut down the lower level protocol for the" + W !,"appropriate device. Please select the link which you would" + W !,"like to shutdown.",! + S DIC="^HLCS(870,",DIC(0)="QEAMZ" D ^DIC K DIC Q:Y<0 + S HLDP=+Y,HLDAPP=Y(0,0),HLPARM0=Y(0),HLPARM4=$G(^HLCS(870,HLDP,400)) + I $P(HLPARM4,U,3)="M",$S(^%ZOSF("OS")'["OpenM":1,1:$$OS^%ZOSV["VMS") D Q + . W !,$C(7),"This LLP is a multi-threaded server. It is controlled by external service, i.e. UCX. You must use the external service to disable this LLP." + . Q + ; + I $P(HLPARM0,U,15) W !,$C(7),"The lower level protocol is already ",$P(HLPARM0,U,5),"." Q + I $P(HLPARM0,U,10) W !,$C(7),"The lower level protocol was started on ",$$DAT2^HLUTIL1($P(HLPARM0,U,10)),"." +STP1 ; + W ! S DIR(0)="Y",DIR("A")="Okay to shut down this job" D ^DIR K DIR + I 'Y!($D(DIRUT))!($D(DUOUT)) W !!,"The job will not be shut down." Q +S ; + F L +^HLCS(870,HLDP,0):2 Q:$T + ;4=status,10=Time Stopped,9=Time Started,11=Task Number,3=Device Type,14=shutdown + S X="HLJ(870,"""_HLDP_","")",@X@(4)="Halting",@X@(10)=$$NOW^XLFDT,(@X@(11),@X@(9))="@",@X@(14)=1 + I $P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4)),'$P(HLPARM0,U,12) S @X@(4)="Shutdown" + D FILE^HLDIE("","HLJ","","STOP","HLCSLNCH") ; HL*1.6*109 + I ^%ZOSF("OS")["OpenM",(($P(HLPARM4,U,3)="M"&($$OS^%ZOSV'["VMS"))!($P(HLPARM4,U,3)="S")) D + . ;pass task number to stop listener + . S:$P(HLPARM0,U,12) X=$$ASKSTOP^%ZTLOAD(+$P(HLPARM0,U,12)) + . D CALL^%ZISTCP($P(HLPARM4,U),$P(HLPARM4,U,2),10) + . I POP D HOME^%ZIS U IO W !,"Unable to shutdown logical link!!!",$C(7),$C(7) Q + . U IO W "**STOP**" + . W ! + . D CLOSE^%ZISTCP + L -^HLCS(870,HLDP,0) + W !,"The job for the "_HLDAPP_" Lower Level Protocol will be shut down." + Q + ; +STOPQ Q diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLCSMON.m b/r/HEALTH_LEVEL_SEVEN-HL/HLCSMON.m index d4bbf434..a49a6c21 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLCSMON.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLCSMON.m @@ -1,245 +1,239 @@ -HLCSMON ;SF-DISPLAY DRIVER PROGRAM ;12/11/2007 17:07 - ;;1.6;HEALTH LEVEL SEVEN;**34,40,48,49,65,66,73,109,122**;Oct 13, 1995;Build 14 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; - ;This Program drives a real-time display monitor for the HL7 - ;Package. All the data used by this display is stored in file - ;# 870. Several callable entry points were broken - ;out of this routine and placed into HLCSMON1 - ; - ;This routine has no required input parameters other than require that - ;U be defined, it does not instantiate any parameters either. - ; - ; - ;HLARY=array of all,HLARYD=array of display,HLARYO=array of old values - ;HLPTR1=top of display,HLPTR2=bottom of display,HLPTR3=last in HLVARY -INIT N HLARY,HLARYD,HLARYO,HLCOFF,HLCON,HLDISP,HLPTR1,HLPTR2,HLPTR3,HLRESP - N HLDEV,HLERR,HLEVL,HLHDR,HLNODE,HLOCK - N HLPARAM,HLPROC,HLPROD,HLSEND,HLSENT,HLSITE - N HLI,HLREC,HLRUNCNT,HLSTAT,HLTMSTAT,HLLMSTAT,HLVIEW,HLXX,HLYY,X,Y,DX,DY - ; - ; patch HL*1.6*122 start - D HOME^%ZIS - W @IOF - ; patch HL*1.6*122 end - ; - D ^HLCSTERM ;Sets up variables to control display attributes -INIT1 ; - ; Next 4 lines copied here from top of START by patch 73... - ;HLRUNCNT=number of in filers^out filers, HLDISP=display mode - S HLRUNCNT="-1^-1",HLPTR1=1 S:'$D(HLDISP) HLDISP="S" - D BUILDARY ;Build an array for display - QUIT:$$LOCKED(.HLOCK) ;-> Anything locked? - ; - W HLCOFF ;Shut Cursor off - D HEADER^HLCSTERM ;Write header - D WDATA^HLCSMON1(5,17,"","","Incoming filers running => ") - D WDATA^HLCSMON1(5,18,"","","Outgoing filers running => ") - D WDATA^HLCSMON1(5,20,"","","Select a Command:") - D WDATA^HLCSMON1(1,21,"","","(N)EXT (B)ACKUP (A)LL LINKS (S)CREENED (V)IEWS (Q)UIT (?) HELP: ") - ;HLRUNCNT=number of in filers^out filers, HLDISP=display mode - S HLRUNCNT="-1^-1",HLPTR1=1 S:'$D(HLDISP) HLDISP="S" -START ; - D BUILDARY ;Build an array for display - D DISPLAY^HLCSMON1 ;Display the array just built - D READ - ;HLRESP=user response - I '$L(HLRESP) G START - G:HLRESP="Q" EXIT - ;any of following commands, kill old values - K HLARYO,HLTMSTAT,HLLMSTAT - I HLRESP="?" D HELP G INIT1 - I HLRESP="V" D VIEW G INIT1 - I "AS"[HLRESP K HLARY,HLEVL S HLDISP=HLRESP G INIT1 - I "NB"[HLRESP D NEXT - G START - ; -READ ;Prompt the user for the next action - D WDATA^HLCSMON1(71,21,"","","",1) - W HLCON - R X#1:3 - W HLCOFF - S HLRESP=$S(X="":X,"Qq^"[X:"Q","Bb"[X:"B","Nn"[X:"N","Aa"[X:"A","Vv"[X:"V",X="?":"?","Ss"[X:"S",1:"") - Q - ; -VIEW ;select new view - W HLCON,!! - N DIC - S DIC="^HLCS(869.3,1,6,",DIC(0)="QEA" - D ^DIC Q:Y<0 - S HLVIEW=+Y,HLDISP="V" - W HLCOFF - Q - ; -NEXT ; - ;Next page - I HLRESP="N" D - . ;no more - . I HLPTR2=HLPTR3 D EOB Q - . S Y=HLPTR2+10,HLEVL(HLPTR1)="" - . ;exceed list, get last 10 - . I Y>HLPTR3 S HLPTR2=HLPTR3,HLPTR1=HLPTR2-9 Q - . S HLPTR1=HLPTR2,HLPTR2=Y - ; - ;Backup a page - I HLRESP="B" D - . ;top of list - . I HLPTR1=1 D EOB Q - . I HLDISP="S" S HLPTR1=$O(HLEVL(HLPTR1),-1) Q - . S Y=HLPTR1-9 - . ;can't go back 10, reset to top - . I Y'>0 S HLPTR1=1,HLPTR2=10 Q - . S HLPTR2=HLPTR1,HLPTR1=Y - ; - ;Erase what might be displayed on line 22 - D WDATA^HLCSMON1(1,22,IOELALL,"","") - Q -EOB D WDATA^HLCSMON1(5,22,IORVON,IORVOFF,"CANNOT "_$S(HLRESP="N":"ADVANCE",1:"BACKUP")_" BEYOND END OF BUFFER") - W $C(7) H 2 - Q - ; -BUILDARY ; - K HLARYD - ; - ;if view is defined, get links - I $G(HLVIEW) D S HLVIEW=0,HLDISP="V" - . N HLTMP - . K HLARY,HLEVL S HLI=0 - . F S HLI=$O(^HLCS(869.3,1,6,HLVIEW,1,HLI)) Q:'HLI S HLYY=+$P($G(^(HLI,0)),U,2) D - .. S Y=$P($G(^HLCS(870,HLI,0)),U) Q:Y="" - .. ;build array by DISPLAY ORDER and then by NAME - .. I HLYY S HLTMP(HLYY,HLI)="" Q - .. S HLTMP(Y,HLI)="" - . S (HLI,HLYY)=0 - . ;rebuild array to put in proper order - . F S HLI=$O(HLTMP(HLI)),HLXX=0 Q:HLI="" D - .. F S HLXX=$O(HLTMP(HLI,HLXX)) Q:'HLXX S HLYY=HLYY+1,HLARY(HLYY,HLXX)="" - . S HLPTR3=HLYY - ; - I '$D(HLARY) S HLYY=0,HLXX="" D - . ;build array in alphabetical order - . F S HLXX=$O(^HLCS(870,"B",HLXX)) Q:HLXX="" S Y=$O(^(HLXX,0)),HLYY=HLYY+1,HLARY(HLYY,Y)="" - . S HLPTR3=HLYY - ; - S HLI=HLPTR1,HLYY=6 ;HLYY=6TH Line of display - ;HLARYD(6) through HLARYD(15) with 6 through 15 also representing line - ;numbers on the display - F HLI=HLI:1 S HLXX=$O(HLARY(HLI,0)) Q:HLYY=16!'HLXX D COPY - S HLPTR2=HLI-1 - ;Set all HLARY elements not defined on this pass to null - F HLYY=HLYY:1:15 S HLARYD(HLYY)="" - Q -COPY ; - Q:'$D(^HLCS(870,HLXX)) - ; - ;These lock tags lock nodes in the global so that the screen is - ;refreshed in real-time. The lock forces the buffer to be refreshed, - ;so that the display is up to date. - ; - ;**109** - ;L +^HLCS(870,HLXX,0):0 L -^HLCS(870,HLXX,0) D CHKLOCK - ; - ; Set, even if not able to lock... - S Y=$G(^HLCS(870,HLXX,0)) - ; - ;name^rec^proc^send^sent^device^state^error - S HLARYD(HLYY)=$P(Y,U)_"^^^^^"_$P(Y,U,4)_"^"_$P(Y,U,5)_"^"_$P(Y,U,19) - ; - ;**109** - ;L +^HLCS(870,HLXX,"IN QUEUE BACK POINTER"):0 D CHKLOCK - ;L -^HLCS(870,HLXX,"IN QUEUE BACK POINTER") - ; - S $P(HLARYD(HLYY),U,2)=$G(^HLCS(870,HLXX,"IN QUEUE BACK POINTER")) - ; - ;**109** - ;L +^HLCS(870,HLXX,"IN QUEUE FRONT POINTER"):0 D CHKLOCK - ;L -^HLCS(870,HLXX,"IN QUEUE FRONT POINTER") - ; - S $P(HLARYD(HLYY),U,3)=$G(^HLCS(870,HLXX,"IN QUEUE FRONT POINTER")) - ; - ;**109** - ;L +^HLCS(870,HLXX,"OUT QUEUE BACK POINTER"):0 D CHKLOCK - ;L -^HLCS(870,HLXX,"OUT QUEUE BACK POINTER") - ; - S $P(HLARYD(HLYY),U,4)=$G(^HLCS(870,HLXX,"OUT QUEUE BACK POINTER")) - ; - ;**109** - ;L +^HLCS(870,HLXX,"OUT QUEUE FRONT POINTER"):0 D CHKLOCK - ;L -^HLCS(870,HLXX,"OUT QUEUE FRONT POINTER") - ; - S $P(HLARYD(HLYY),U,5)=$G(^HLCS(870,HLXX,"OUT QUEUE FRONT POINTER")) - ; - S X=HLARYD(HLYY),Y=$P(X,U,2)+$P(X,U,3)+$P(X,U,4)+$P(X,U,5) - ;if Select and the Y=0, nothing to report - I 'Y,HLDISP="S" S HLARYD(HLYY)="" Q - S HLYY=HLYY+1 - Q - ; -CHKLOCK ; Call here immediately after trying to lock. And, BE SURE that - ; nothing might occur that would change $T after the lock attempt!! - ; $T,HLXX -- req - N NM870 - QUIT:$T ;-> Lock obtained... - S NM870=$P($G(^HLCS(870,+HLXX,0)),U) - S NM870=$S(NM870]"":NM870_" (IEN #"_HLXX_")",1:"IEN #"_HLXX) - S HLOCK(NM870)="" - QUIT - ; -HELP ; - W HLCON,@IOF - W !,"You have the following options when monitoring the Messaging System:" - W !,"Enter the command letter parentheses: N,B,Q,A,S,V or ?" - W !!,"(N) takes you to the next page of the display of Logical Links." - W !!,"(B) takes you back one page." - W !!,"(Q) terminates the monitor." - W !!,"(A) provides a display of all links defined on your system." - W !!,"(S) displays only those links that have had message traffic." - W !!,"(V) prompts for a view name and displays links defined in view." - W !!," Note that (S) is the default display at startup." - W !!,"**PRESS TO CONTINUE**" - R X:DTIME - W @IOF - W !,?25,"Device Types and corresponding prefixes:" - W !!,?30,"PC -- Persistent TCP/IP Client" - W !!,?30,"NC -- Non-Persistent TCP/IP Client" - W !!,?30,"SS -- Single-threaded TCP/IP Server" - W !!,?30,"MS -- Multi-threaded TCP/IP Server" - W !!,?30,"SH -- Serial HLLP" - W !!,?30,"SX -- Serial X3.28" - W !!,?30,"MM -- MailMan" - W !!,"**PRESS TO CONTINUE**" - R X:DTIME - W HLCOFF - Q -EXIT ; - ;Turn Cursor back on - W HLCON - D KVAR^HLCSTERM - Q - ; -LOCKED(HLOCK) ; Anything locked? - ; - ; - ; Nothing locked... - I '$D(HLOCK) QUIT "" ;-> - ; - W !!,"Editing of logical link data is occurring right now. For this reason, some of" - W !,"the information on the 'System Link Monitor' report might not be accurate for" - W !,"the following node(s)..." - W ! - ; - S HLOCK="" - F S HLOCK=$O(HLOCK(HLOCK)) Q:HLOCK']"" D - . W !,?5,HLOCK - ; - S ACTION=$$BTE("Press RETURN to print report or '^' to exit... ",1) - ; - QUIT $S(ACTION=1:1,1:"") - ; -BTE(PMT,FF) ; - N DIR,DIRUT,DTOUT,DUOUT,X,Y - F X=1:1:$G(FF) W ! - S DIR(0)="EA",DIR("A")=PMT - D ^DIR - QUIT $S(Y=1:"",1:1) - ; +HLCSMON ;SF-DISPLAY DRIVER PROGRAM ;07/10/2000 12:18 + ;;1.6;HEALTH LEVEL SEVEN;**34,40,48,49,65,66,73,109**;Oct 13, 1995 + ; + ;This Program drives a real-time display monitor for the HL7 + ;Package. All the data used by this display is stored in file + ;# 870. Several callable entry points were broken + ;out of this routine and placed into HLCSMON1 + ; + ;This routine has no required input parameters other than require that + ;U be defined, it does not instantiate any parameters either. + ; + ; + ;HLARY=array of all,HLARYD=array of display,HLARYO=array of old values + ;HLPTR1=top of display,HLPTR2=bottom of display,HLPTR3=last in HLVARY +INIT N HLARY,HLARYD,HLARYO,HLCOFF,HLCON,HLDISP,HLPTR1,HLPTR2,HLPTR3,HLRESP + N HLDEV,HLERR,HLEVL,HLHDR,HLNODE,HLOCK + N HLPARAM,HLPROC,HLPROD,HLSEND,HLSENT,HLSITE + N HLI,HLREC,HLRUNCNT,HLSTAT,HLTMSTAT,HLLMSTAT,HLVIEW,HLXX,HLYY,X,Y,DX,DY + ; + D ^HLCSTERM ;Sets up variables to control display attributes +INIT1 ; + ; Next 4 lines copied here from top of START by patch 73... + ;HLRUNCNT=number of in filers^out filers, HLDISP=display mode + S HLRUNCNT="-1^-1",HLPTR1=1 S:'$D(HLDISP) HLDISP="S" + D BUILDARY ;Build an array for display + QUIT:$$LOCKED(.HLOCK) ;-> Anything locked? + ; + W HLCOFF ;Shut Cursor off + D HEADER^HLCSTERM ;Write header + D WDATA^HLCSMON1(5,17,"","","Incoming filers running => ") + D WDATA^HLCSMON1(5,18,"","","Outgoing filers running => ") + D WDATA^HLCSMON1(5,20,"","","Select a Command:") + D WDATA^HLCSMON1(1,21,"","","(N)EXT (B)ACKUP (A)LL LINKS (S)CREENED (V)IEWS (Q)UIT (?) HELP: ") + ;HLRUNCNT=number of in filers^out filers, HLDISP=display mode + S HLRUNCNT="-1^-1",HLPTR1=1 S:'$D(HLDISP) HLDISP="S" +START ; + D BUILDARY ;Build an array for display + D DISPLAY^HLCSMON1 ;Display the array just built + D READ + ;HLRESP=user response + I '$L(HLRESP) G START + G:HLRESP="Q" EXIT + ;any of following commands, kill old values + K HLARYO,HLTMSTAT,HLLMSTAT + I HLRESP="?" D HELP G INIT1 + I HLRESP="V" D VIEW G INIT1 + I "AS"[HLRESP K HLARY,HLEVL S HLDISP=HLRESP G INIT1 + I "NB"[HLRESP D NEXT + G START + ; +READ ;Prompt the user for the next action + D WDATA^HLCSMON1(71,21,"","","",1) + W HLCON + R X#1:3 + W HLCOFF + S HLRESP=$S(X="":X,"Qq^"[X:"Q","Bb"[X:"B","Nn"[X:"N","Aa"[X:"A","Vv"[X:"V",X="?":"?","Ss"[X:"S",1:"") + Q + ; +VIEW ;select new view + W HLCON,!! + N DIC + S DIC="^HLCS(869.3,1,6,",DIC(0)="QEA" + D ^DIC Q:Y<0 + S HLVIEW=+Y,HLDISP="V" + W HLCOFF + Q + ; +NEXT ; + ;Next page + I HLRESP="N" D + . ;no more + . I HLPTR2=HLPTR3 D EOB Q + . S Y=HLPTR2+10,HLEVL(HLPTR1)="" + . ;exceed list, get last 10 + . I Y>HLPTR3 S HLPTR2=HLPTR3,HLPTR1=HLPTR2-9 Q + . S HLPTR1=HLPTR2,HLPTR2=Y + ; + ;Backup a page + I HLRESP="B" D + . ;top of list + . I HLPTR1=1 D EOB Q + . I HLDISP="S" S HLPTR1=$O(HLEVL(HLPTR1),-1) Q + . S Y=HLPTR1-9 + . ;can't go back 10, reset to top + . I Y'>0 S HLPTR1=1,HLPTR2=10 Q + . S HLPTR2=HLPTR1,HLPTR1=Y + ; + ;Erase what might be displayed on line 22 + D WDATA^HLCSMON1(1,22,IOELALL,"","") + Q +EOB D WDATA^HLCSMON1(5,22,IORVON,IORVOFF,"CANNOT "_$S(HLRESP="N":"ADVANCE",1:"BACKUP")_" BEYOND END OF BUFFER") + W $C(7) H 2 + Q + ; +BUILDARY ; + K HLARYD + ; + ;if view is defined, get links + I $G(HLVIEW) D S HLVIEW=0,HLDISP="V" + . N HLTMP + . K HLARY,HLEVL S HLI=0 + . F S HLI=$O(^HLCS(869.3,1,6,HLVIEW,1,HLI)) Q:'HLI S HLYY=+$P($G(^(HLI,0)),U,2) D + .. S Y=$P($G(^HLCS(870,HLI,0)),U) Q:Y="" + .. ;build array by DISPLAY ORDER and then by NAME + .. I HLYY S HLTMP(HLYY,HLI)="" Q + .. S HLTMP(Y,HLI)="" + . S (HLI,HLYY)=0 + . ;rebuild array to put in proper order + . F S HLI=$O(HLTMP(HLI)),HLXX=0 Q:HLI="" D + .. F S HLXX=$O(HLTMP(HLI,HLXX)) Q:'HLXX S HLYY=HLYY+1,HLARY(HLYY,HLXX)="" + . S HLPTR3=HLYY + ; + I '$D(HLARY) S HLYY=0,HLXX="" D + . ;build array in alphabetical order + . F S HLXX=$O(^HLCS(870,"B",HLXX)) Q:HLXX="" S Y=$O(^(HLXX,0)),HLYY=HLYY+1,HLARY(HLYY,Y)="" + . S HLPTR3=HLYY + ; + S HLI=HLPTR1,HLYY=6 ;HLYY=6TH Line of display + ;HLARYD(6) through HLARYD(15) with 6 through 15 also representing line + ;numbers on the display + F HLI=HLI:1 S HLXX=$O(HLARY(HLI,0)) Q:HLYY=16!'HLXX D COPY + S HLPTR2=HLI-1 + ;Set all HLARY elements not defined on this pass to null + F HLYY=HLYY:1:15 S HLARYD(HLYY)="" + Q +COPY ; + Q:'$D(^HLCS(870,HLXX)) + ; + ;These lock tags lock nodes in the global so that the screen is + ;refreshed in real-time. The lock forces the buffer to be refreshed, + ;so that the display is up to date. + ; + ;**109** + ;L +^HLCS(870,HLXX,0):0 L -^HLCS(870,HLXX,0) D CHKLOCK + ; + ; Set, even if not able to lock... + S Y=$G(^HLCS(870,HLXX,0)) + ; + ;name^rec^proc^send^sent^device^state^error + S HLARYD(HLYY)=$P(Y,U)_"^^^^^"_$P(Y,U,4)_"^"_$P(Y,U,5)_"^"_$P(Y,U,19) + ; + ;**109** + ;L +^HLCS(870,HLXX,"IN QUEUE BACK POINTER"):0 D CHKLOCK + ;L -^HLCS(870,HLXX,"IN QUEUE BACK POINTER") + ; + S $P(HLARYD(HLYY),U,2)=$G(^HLCS(870,HLXX,"IN QUEUE BACK POINTER")) + ; + ;**109** + ;L +^HLCS(870,HLXX,"IN QUEUE FRONT POINTER"):0 D CHKLOCK + ;L -^HLCS(870,HLXX,"IN QUEUE FRONT POINTER") + ; + S $P(HLARYD(HLYY),U,3)=$G(^HLCS(870,HLXX,"IN QUEUE FRONT POINTER")) + ; + ;**109** + ;L +^HLCS(870,HLXX,"OUT QUEUE BACK POINTER"):0 D CHKLOCK + ;L -^HLCS(870,HLXX,"OUT QUEUE BACK POINTER") + ; + S $P(HLARYD(HLYY),U,4)=$G(^HLCS(870,HLXX,"OUT QUEUE BACK POINTER")) + ; + ;**109** + ;L +^HLCS(870,HLXX,"OUT QUEUE FRONT POINTER"):0 D CHKLOCK + ;L -^HLCS(870,HLXX,"OUT QUEUE FRONT POINTER") + ; + S $P(HLARYD(HLYY),U,5)=$G(^HLCS(870,HLXX,"OUT QUEUE FRONT POINTER")) + ; + S X=HLARYD(HLYY),Y=$P(X,U,2)+$P(X,U,3)+$P(X,U,4)+$P(X,U,5) + ;if Select and the Y=0, nothing to report + I 'Y,HLDISP="S" S HLARYD(HLYY)="" Q + S HLYY=HLYY+1 + Q + ; +CHKLOCK ; Call here immediately after trying to lock. And, BE SURE that + ; nothing might occur that would change $T after the lock attempt!! + ; $T,HLXX -- req + N NM870 + QUIT:$T ;-> Lock obtained... + S NM870=$P($G(^HLCS(870,+HLXX,0)),U) + S NM870=$S(NM870]"":NM870_" (IEN #"_HLXX_")",1:"IEN #"_HLXX) + S HLOCK(NM870)="" + QUIT + ; +HELP ; + W HLCON,@IOF + W !,"You have the following options when monitoring the Messaging System:" + W !,"Enter the command letter parentheses: N,B,Q,A,S,V or ?" + W !!,"(N) takes you to the next page of the display of Logical Links." + W !!,"(B) takes you back one page." + W !!,"(Q) terminates the monitor." + W !!,"(A) provides a display of all links defined on your system." + W !!,"(S) displays only those links that have had message traffic." + W !!,"(V) prompts for a view name and displays links defined in view." + W !!," Note that (S) is the default display at startup." + W !!,"**PRESS TO CONTINUE**" + R X:DTIME + W @IOF + W !,?25,"Device Types and corresponding prefixes:" + W !!,?30,"PC -- Persistent TCP/IP Client" + W !!,?30,"NC -- Non-Persistent TCP/IP Client" + W !!,?30,"SS -- Single-threaded TCP/IP Server" + W !!,?30,"MS -- Multi-threaded TCP/IP Server" + W !!,?30,"SH -- Serial HLLP" + W !!,?30,"SX -- Serial X3.28" + W !!,?30,"MM -- MailMan" + W !!,"**PRESS TO CONTINUE**" + R X:DTIME + W HLCOFF + Q +EXIT ; + ;Turn Cursor back on + W HLCON + D KVAR^HLCSTERM + Q + ; +LOCKED(HLOCK) ; Anything locked? + ; + ; + ; Nothing locked... + I '$D(HLOCK) QUIT "" ;-> + ; + W !!,"Editing of logical link data is occurring right now. For this reason, some of" + W !,"the information on the 'System Link Monitor' report might not be accurate for" + W !,"the following node(s)..." + W ! + ; + S HLOCK="" + F S HLOCK=$O(HLOCK(HLOCK)) Q:HLOCK']"" D + . W !,?5,HLOCK + ; + S ACTION=$$BTE("Press RETURN to print report or '^' to exit... ",1) + ; + QUIT $S(ACTION=1:1,1:"") + ; +BTE(PMT,FF) ; + N DIR,DIRUT,DTOUT,DUOUT,X,Y + F X=1:1:$G(FF) W ! + S DIR(0)="EA",DIR("A")=PMT + D ^DIR + QUIT $S(Y=1:"",1:1) + ; diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLCSMON1.m b/r/HEALTH_LEVEL_SEVEN-HL/HLCSMON1.m index b8ecbd0c..a8005c6d 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLCSMON1.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLCSMON1.m @@ -1,85 +1,69 @@ -HLCSMON1 ;SF-Utilities for Driver Program ;07/17/2007 17:05 - ;;1.6;HEALTH LEVEL SEVEN;**15,40,49,65,109,122**;Oct 13, 1995;Build 14 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; - ;This routine contains several entry points called from HLCSMON - ;no input parameters are required. All variables used which are - ;not newed here are newed in HLCSMON - ; -DISPLAY ;display link info - ;turn of line wrap - S HLXX=0,X=0 X ^%ZOSF("RM") - F S HLXX=$O(HLARYD(HLXX)) Q:(HLXX'>0) D WLINE(HLXX) - ;DISPLAY INCOMING FILER STATUS - ; patch HL*1.6*122 - S HLXX=$P(HLRUNCNT,"^",1) - ; S HLXX=$$CNTFLR^HLCSUTL2("IN") - I (+HLXX)=-1 S HLXX=$$CNTFLR^HLCSUTL2("IN") - ; - ;ONLY UPDATE SCREEN IF COUNT HAS CHANGED - I (HLXX'=+HLRUNCNT) D - .D WDATA(5,17,"","",$J(" ",31)),WDATA^HLCSMON1(5,17,"","","Incoming filers running => ",35) - .I (HLXX) D WDATA(32,17,"","",HLXX) - .I ('HLXX) D WDATA(32,17,IOINHI,IOINORM,"Zero") - .S $P(HLRUNCNT,"^",1)=HLXX - ;DISPLAY OUTGOING FILER STATUS - ; patch HL*1.6*122 - S HLXX=$P(HLRUNCNT,"^",2) - ; S HLXX=$$CNTFLR^HLCSUTL2("OUT") - I (+HLXX)=-1 S HLXX=$$CNTFLR^HLCSUTL2("OUT") - ; - ;ONLY UPDATE SCREEN IF COUNT HAS CHANGED - I (HLXX'=+$P(HLRUNCNT,"^",2)) D - .D WDATA(5,18,"","",$J(" ",31)),WDATA^HLCSMON1(5,18,"","","Outgoing filers running => ",35) - .I (HLXX) D WDATA(32,18,"","",HLXX) - .I ('HLXX) D WDATA(32,18,IOINHI,IOINORM,"Zero") - .S $P(HLRUNCNT,"^",2)=HLXX - S X=$$TM^%ZTLOAD - I X'=$G(HLTMSTAT) D - .S HLTMSTAT=X - .S HLXX=$S('HLTMSTAT:"***TASKMAN NOT RUNNING!!!***",1:"") - .I 'HLTMSTAT D WDATA^HLCSMON1(45,17,IOELEOL_IOBON_IORVON,IOBOFF_IORVOFF,HLXX) I 1 - .E D WDATA(45,17,IOELEOL,"",$J("TaskMan running ",16)) ;D WDATA(5,19,IOELALL,"","") - S X=$$STAT^HLCSLM - I X'=$G(HLLMSTAT) D - .S HLLMSTAT=X Q:HLLMSTAT=3 - .S HLXX=$S('HLLMSTAT:"***LINK MANAGER NOT RUNNING!!!***",1:"") - .I 'HLLMSTAT D WDATA^HLCSMON1(45,18,IOELEOL_IOBON_IORVON,IOBOFF_IORVOFF,HLXX) I 1 - .E D WDATA^HLCSMON1(45,18,IOELEOL,"",$J("Link Manager running",18)) - ;Turn terminal line wrap back on - D WDATA(45,19,IOELEOL,"",$$SLM^HLEVUTIL) ; HL*1.6*109 - S X=IOM X ^%ZOSF("RM") - Q - ; -WLINE(HLXX) ;write line from HLARYD=current values, HLARYO=old values - ;if values haven't changed, don't do anything - I HLARYD(HLXX)]"",HLARYD(HLXX)=$G(HLARYO(HLXX)) Q - S HLARYO(HLXX)=HLARYD(HLXX),HLERR=$P(HLARYD(HLXX),U,8),DX=1 - ; patch HL*1.6*122 - ; F X=1:1:7 S @$P("HLNODE^HLREC^HLPROC^HLSEND^HLSENT^HLDEV^HLSTAT",U,X)=$E($P(HLARYD(HLXX),U,X)_" ",1,8) - F X=1,7 S @$P("HLNODE^HLREC^HLPROC^HLSEND^HLSENT^HLDEV^HLSTAT",U,X)=$E($P(HLARYD(HLXX),U,X)_" ",1,10) - F X=2:1:5 S @$P("HLNODE^HLREC^HLPROC^HLSEND^HLSENT^HLDEV^HLSTAT",U,X)=$E($P(HLARYD(HLXX),U,X)_" ",1,8) - S X=6,@$P("HLNODE^HLREC^HLPROC^HLSEND^HLSENT^HLDEV^HLSTAT",U,X)=$E($P(HLARYD(HLXX),U,X)_" ",1,7) - ; - ;if link is in error, write node in rev. video - I HLERR]"" D WDATA(5,HLXX,IOBON_IORVON,IOBOFF_IORVOFF,HLNODE,8) S DX=14 - ;Turn off terminal line wrap & inform O/S where cursor is located - S DY=HLXX X IOXY,^%ZOSF("XY") - ; patch HL*1.6*122 - W:HLERR="" ?4,HLNODE - W ?16,HLREC,?26,HLPROC,?37,HLSEND,?47,HLSENT,?58,HLDEV,?63,HLSTAT - ; - Q - ; -WDATA(DX,DY,IO1,IO2,HLDATA,HLENGTH) ; - ; - ;First erase the data block then write to it. Attributes are - ;contained in IO1 & IO2 - ; - N X S X=0 X ^%ZOSF("RM") X ^%ZOSF("XY") - ;Turn off terminal line wrap & inform O/S where cursor is located - I '$D(HLENGTH) S HLENGTH=$L(HLDATA) - X IOXY W IOSC,$E($J(" ",79),1,HLENGTH),IORC W IO1,$E(HLDATA,1,HLENGTH),IO2 - S X=IOM X ^%ZOSF("RM") - ;Turn terminal line wrap back on - Q +HLCSMON1 ;SF-Utilities for Driver Program ;02/04/2004 10:25 + ;;1.6;HEALTH LEVEL SEVEN;**15,40,49,65,109**;Oct 13, 1995 + ; + ;This routine contains several entry points called from HLCSMON + ;no input parameters are required. All variables used which are + ;not newed here are newed in HLCSMON + ; +DISPLAY ;display link info + ;turn of line wrap + S HLXX=0,X=0 X ^%ZOSF("RM") + F S HLXX=$O(HLARYD(HLXX)) Q:(HLXX'>0) D WLINE(HLXX) + ;DISPLAY INCOMING FILER STATUS + S HLXX=$$CNTFLR^HLCSUTL2("IN") + ;ONLY UPDATE SCREEN IF COUNT HAS CHANGED + I (HLXX'=+HLRUNCNT) D + .D WDATA(5,17,"","",$J(" ",31)),WDATA^HLCSMON1(5,17,"","","Incoming filers running => ",35) + .I (HLXX) D WDATA(32,17,"","",HLXX) + .I ('HLXX) D WDATA(32,17,IOINHI,IOINORM,"Zero") + .S $P(HLRUNCNT,"^",1)=HLXX + ;DISPLAY OUTGOING FILER STATUS + S HLXX=$$CNTFLR^HLCSUTL2("OUT") + ;ONLY UPDATE SCREEN IF COUNT HAS CHANGED + I (HLXX'=+$P(HLRUNCNT,"^",2)) D + .D WDATA(5,18,"","",$J(" ",31)),WDATA^HLCSMON1(5,18,"","","Outgoing filers running => ",35) + .I (HLXX) D WDATA(32,18,"","",HLXX) + .I ('HLXX) D WDATA(32,18,IOINHI,IOINORM,"Zero") + .S $P(HLRUNCNT,"^",2)=HLXX + S X=$$TM^%ZTLOAD + I X'=$G(HLTMSTAT) D + .S HLTMSTAT=X + .S HLXX=$S('HLTMSTAT:"***TASKMAN NOT RUNNING!!!***",1:"") + .I 'HLTMSTAT D WDATA^HLCSMON1(45,17,IOELEOL_IOBON_IORVON,IOBOFF_IORVOFF,HLXX) I 1 + .E D WDATA(45,17,IOELEOL,"",$J("TaskMan running ",16)) ;D WDATA(5,19,IOELALL,"","") + S X=$$STAT^HLCSLM + I X'=$G(HLLMSTAT) D + .S HLLMSTAT=X Q:HLLMSTAT=3 + .S HLXX=$S('HLLMSTAT:"***LINK MANAGER NOT RUNNING!!!***",1:"") + .I 'HLLMSTAT D WDATA^HLCSMON1(45,18,IOELEOL_IOBON_IORVON,IOBOFF_IORVOFF,HLXX) I 1 + .E D WDATA^HLCSMON1(45,18,IOELEOL,"",$J("Link Manager running",18)) + ;Turn terminal line wrap back on + D WDATA(45,19,IOELEOL,"",$$SLM^HLEVUTIL) ; HL*1.6*109 + S X=IOM X ^%ZOSF("RM") + Q + ; +WLINE(HLXX) ;write line from HLARYD=current values, HLARYO=old values + ;if values haven't changed, don't do anything + I HLARYD(HLXX)]"",HLARYD(HLXX)=$G(HLARYO(HLXX)) Q + S HLARYO(HLXX)=HLARYD(HLXX),HLERR=$P(HLARYD(HLXX),U,8),DX=1 + F X=1:1:7 S @$P("HLNODE^HLREC^HLPROC^HLSEND^HLSENT^HLDEV^HLSTAT",U,X)=$E($P(HLARYD(HLXX),U,X)_" ",1,8) + ;if link is in error, write node in rev. video + I HLERR]"" D WDATA(5,HLXX,IOBON_IORVON,IOBOFF_IORVOFF,HLNODE,8) S DX=14 + ;Turn off terminal line wrap & inform O/S where cursor is located + S DY=HLXX X IOXY,^%ZOSF("XY") + W:HLERR="" ?5,HLNODE + W ?16,HLREC,?26,HLPROC,?37,HLSEND,?47,HLSENT,?58,HLDEV,?64,HLSTAT + Q + ; +WDATA(DX,DY,IO1,IO2,HLDATA,HLENGTH) ; + ; + ;First erase the data block then write to it. Attributes are + ;contained in IO1 & IO2 + ; + N X S X=0 X ^%ZOSF("RM") X ^%ZOSF("XY") + ;Turn off terminal line wrap & inform O/S where cursor is located + I '$D(HLENGTH) S HLENGTH=$L(HLDATA) + X IOXY W IOSC,$E($J(" ",79),1,HLENGTH),IORC W IO1,$E(HLDATA,1,HLENGTH),IO2 + S X=IOM X ^%ZOSF("RM") + ;Turn terminal line wrap back on + Q diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLCSREP.m b/r/HEALTH_LEVEL_SEVEN-HL/HLCSREP.m index 62f67837..6f17cea3 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLCSREP.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLCSREP.m @@ -1,64 +1,52 @@ -HLCSREP ;ALB/MFK - HL7 QUEUE MANAGEMENT ;10/17/2007 08:56 - ;;1.6;HEALTH LEVEL SEVEN;**109,122**;Oct 13, 1995;Build 14 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; -REPMSG ;Duplicate messages on a queue - ; INPUT: MSG - Array which contains the queue and the - ; message numbers for msgs to be re-queued - ; MSG(QUEUE,NUMBER) - ; OUTPUT: NONE - N DIC,LLE,X,Y,DA,ERROR,FROMID,MSGID - N TOID,ENTRY,LLE - Q:('$D(MSG)) - ; create new entries - S (LLE,ERROR)="" - F S LLE=$O(MSG(LLE)) Q:(LLE="")!(ERROR) D - .S ENTRY="" - .F S ENTRY=$O(MSG(LLE,ENTRY)) Q:(ENTRY="")!(ERROR) D - ..S MSGID=$$ENQUEUE^HLCSQUE(LLE,"OUT") - ..I +MSGID'>0 S ERROR=1 Q - ..S TOID=$P(MSGID,"^",2) - ..M ^HLCS(870,LLE,2,TOID)=^HLCS(870,LLE,2,ENTRY) - ..; Change .01 of new record to be IEN - ..S $P(^HLCS(870,LLE,2,TOID,0),"^",1)=TOID - ..S $P(^HLCS(870,LLE,2,TOID,0),"^",2)="P" -EXIT ; - Q - ; -ENQUE(LINK,DIR,IEN773) ; - ;This routine will place the message=IEN773 on the "AC" xref of file 773. - ;Input: - ; DIR = "I" or "O", denoting the direction that the message is going in - ; LINK = the ien of the logical link - ; IEN773 = ien of the message in file 773 - ; - Q:'$G(LINK) - I DIR'="I",DIR'="O" Q - Q:'$G(IEN773) - ; - ; patch HL*1.6*122: MPI-client/server - F L +^HLMA("AC",DIR,LINK,IEN773):10 Q:$T H 1 - S ^HLMA("AC",DIR,LINK,IEN773)="" - L -^HLMA("AC",DIR,LINK,IEN773) - ; - S $P(^HLMA(+IEN773,0),U,17)=+LINK ; HL*1.6*109 - lja - I DIR="O" D LLCNT^HLCSTCP(LINK,3) - Q - ; -DEQUE(LINK,DIR,IEN773) ; - ;This routine will remove the message=IEN773 on the "AC" xref of file 773. - ;Input: - ; DIR = "I" or "O", denoting the direction that the message is going in - ; LINK = the ien of the logical link - ; IEN773 = ien of the message in file 773 - ; - Q:'$G(LINK) - I DIR'="I",DIR'="O" Q - Q:'$G(IEN773) - ; - ; patch HL*1.6*122: MPI-client/server - F L +^HLMA("AC",DIR,LINK,IEN773):10 Q:$T H 1 - K ^HLMA("AC",DIR,LINK,IEN773) - L -^HLMA("AC",DIR,LINK,IEN773) - ; - Q +HLCSREP ;ALB/MFK - HL7 QUEUE MANAGEMENT - 10/4/94 1pm + ;;1.6;HEALTH LEVEL SEVEN;**109**;Oct 13, 1995 +REPMSG ;Duplicate messages on a queue + ; INPUT: MSG - Array which contains the queue and the + ; message numbers for msgs to be re-queued + ; MSG(QUEUE,NUMBER) + ; OUTPUT: NONE + N DIC,LLE,X,Y,DA,ERROR,FROMID,MSGID + N TOID,ENTRY,LLE + Q:('$D(MSG)) + ; create new entries + S (LLE,ERROR)="" + F S LLE=$O(MSG(LLE)) Q:(LLE="")!(ERROR) D + .S ENTRY="" + .F S ENTRY=$O(MSG(LLE,ENTRY)) Q:(ENTRY="")!(ERROR) D + ..S MSGID=$$ENQUEUE^HLCSQUE(LLE,"OUT") + ..I +MSGID'>0 S ERROR=1 Q + ..S TOID=$P(MSGID,"^",2) + ..M ^HLCS(870,LLE,2,TOID)=^HLCS(870,LLE,2,ENTRY) + ..; Change .01 of new record to be IEN + ..S $P(^HLCS(870,LLE,2,TOID,0),"^",1)=TOID + ..S $P(^HLCS(870,LLE,2,TOID,0),"^",2)="P" +EXIT ; + Q + ; +ENQUE(LINK,DIR,IEN773) ; + ;This routine will place the message=IEN773 on the "AC" xref of file 773. + ;Input: + ; DIR = "I" or "O", denoting the direction that the message is going in + ; LINK = the ien of the logical link + ; IEN773 = ien of the message in file 773 + ; + Q:'$G(LINK) + I DIR'="I",DIR'="O" Q + Q:'$G(IEN773) + S ^HLMA("AC",DIR,LINK,IEN773)="" + S $P(^HLMA(+IEN773,0),U,17)=+LINK ; HL*1.6*109 - lja + I DIR="O" D LLCNT^HLCSTCP(LINK,3) + Q + ; +DEQUE(LINK,DIR,IEN773) ; + ;This routine will remove the message=IEN773 on the "AC" xref of file 773. + ;Input: + ; DIR = "I" or "O", denoting the direction that the message is going in + ; LINK = the ien of the logical link + ; IEN773 = ien of the message in file 773 + ; + Q:'$G(LINK) + I DIR'="I",DIR'="O" Q + Q:'$G(IEN773) + K ^HLMA("AC",DIR,LINK,IEN773) + Q diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP.m b/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP.m index 47378be1..04a31ee3 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP.m @@ -1,283 +1,216 @@ -HLCSTCP ;SFIRMFO/TNV-ALB/JFP,PKE - (TCP/IP) MLLP ;04/15/2008 10:58 - ;;1.6;HEALTH LEVEL SEVEN;**19,43,49,57,58,64,84,109,133,122,140**;Oct 13, 1995;Build 5 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; - ; This is an implementation of the HL7 Minimal Lower Layer Protocol - ; taskman entry/startup option, HLDP defined in menu entry. - ; - Q:'$D(HLDP) - ; patch HL*1.6*122 start - L +^HLCS("HLTCPLINK",HLDP):5 I '$T D Q - . D MON^HLCSTCP("TskLcked") - N HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET - N HLZRULE - ;HLCSOUT= 1-error - I '$$INIT D EXITS("Init Error") Q - S HLDP("$J")=$J - S HLDP("$J",0,"LENGTH")=$L(HLDP("$J")) - ; Start the client - I $G(HLTCPCS)="C" D Q - . S HLDP("$J",0,"START")=HLDP("$J",0,"LENGTH")-8+$L(HLTCPORT)+$L(HLDP) - . I HLDP("$J",0,"START")<1 S HLDP("$J",0,"START")=1 - . S HLDP("$J",0)=$E(HLDP("$J"),HLDP("$J",0,"START"),HLDP("$J",0,"LENGTH")) - . ; identify process for ^%SY - . ; D SETNM^%ZOSV($E("HLClnt:"_HLDP,1,15)) - . D SETNM^%ZOSV($E("HLc:"_HLTCPORT_"-"_HLDP_"-"_HLDP("$J",0),1,15)) - . K HLDP("$J",0) - . D ST1 - . F D ^HLCSTCP2 Q:$$STOP!$G(HLCSOUT) - . ; I $G(HLCSOUT)=1 D MON("Error") H 1 Q - . I $G(HLCSOUT)=1 D Q - .. D MON("Error") H 1 - .. L -^HLCS("HLTCPLINK",HLDP) - . I $G(HLCSOUT)=2 D EXITS("Inactive") Q - . D EXITS("Shutdown") - ; - S HLDP("$J",0,"START")=HLDP("$J",0,"LENGTH")-9+$L(HLTCPORT) - I HLDP("$J",0,"START")<1 S HLDP("$J",0,"START")=1 - S HLDP("$J",0)=$E(HLDP("$J"),HLDP("$J",0,"START"),HLDP("$J",0,"LENGTH")) - ; identify process for ^%SY - ; D SETNM^%ZOSV($E("HLSrv:"_HLDP,1,15)) - D SETNM^%ZOSV($E("HLs:"_HLTCPORT_"-"_HLDP("$J",0),1,15)) - K HLDP("$J",0) - ; to stop the listener via updated Kernel API, need to pass the - ; listener logical link (HLDP) - S HLZRULE="S HLDP="_HLDP_" S ZISQUIT=$$STOP^HLCSTCP" - ;single threaded listener - I $G(HLTCPCS)="S" D Q - . D ST1,MON("Listen"),LISTEN^%ZISTCP(HLTCPORT,"SERVER^HLCSTCP("""_HLDP_""")",HLZRULE) - . I $$STOP D EXITS("Shutdown") Q - . D EXITS("Openfail") - ; - ;multi-threaded listener (for OpenM/NT) - I ($G(HLTCPCS)'="M")!(^%ZOSF("OS")'["OpenM") D Q - . L -^HLCS("HLTCPLINK",HLDP) - I $$OS^%ZOSV["VMS" L -^HLCS("HLTCPLINK",HLDP) Q - D ST1,MON("Listen"),LISTEN^%ZISTCPS(HLTCPORT,"SERVERS^HLCSTCP("""_HLDP_""")",HLZRULE) - ; update status of listener - I $$STOP D EXITS("Shutdown") Q - D EXITS("Openfail") - ; HL*1.6*122 end - Q - ; -SERVER(HLDP) ; single server using Taskman - I '$$INIT D EXITS("Init error") Q - D ^HLCSTCP1 - I $$STOP D CLOSE^%ZISTCP,EXITS("Shutdown") S IO("C")="" Q - Q:$G(HLCSOUT)=1 - D MON("Idle") - Q - ; -SERVERS(HLDP) ; Multi-threaded server using Taskman - I '$$INIT D EXITS("Init error") Q - G LISTEN - ; - ;multiple process servers, called from an external utility -MSM ;MSM entry point, called from User-Defined Services - ;HLDP=ien in the HL LOWER LEVEL PROTOCOL PARAMETER file for the - ;HL7 Multi-Threaded SERVER - S (IO,IO(0))=$P - G LISTEN - ; -LISTEN ; - N HLLSTN,HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET - I '$$INIT D ^%ZTER Q - ; patch HL*1.6*122 start - S HLDP("$J")=$J - S HLDP("$J",0,"LENGTH")=$L(HLDP("$J")) - S HLDP("$J",0,"START")=HLDP("$J",0,"LENGTH")-9+$L(HLTCPORT) - I HLDP("$J",0,"START")<1 S HLDP("$J",0,"START")=1 - S HLDP("$J",0)=$E(HLDP("$J"),HLDP("$J",0,"START"),HLDP("$J",0,"LENGTH")) - ; identify process for ^%SY - ; D SETNM^%ZOSV($E("HLSrv:"_HLDP,1,15)) - D SETNM^%ZOSV($E("HLs:"_HLTCPORT_"-"_HLDP("$J",0),1,15)) - K HLDP("$J",0) - ; patch HL*1.6*122 end - ;HLLSTN used to identify a listener to tag MON - S HLLSTN=1 - ;increment job count, run server - D UPDT(1),^HLCSTCP1,EXITM - Q - ; -DCOPEN(HLDP) ;open direct connect - called from HLMA2 - Q:'$$INIT 0 - Q:HLTCPADD=""!(HLTCPORT="") 0 - Q:'$$OPEN^HLCSTCP2 0 - Q 1 - ; -INIT() ; Initialize Variables - ; HLDP should be set to the IEN or name of Logical Link, file 870 - S HLOS=$P($G(^%ZOSF("OS")),"^") - N DA,DIQUIET,DR,TMP,X,Y - ; patch HL*1.6*140 - ; S IOF=$$FLUSHCHR^%ZISTCP ; HL*1.6*122 set device flush character - S HLTCPLNK("IOF")=$$FLUSHCHR^%ZISTCP - S DIQUIET=1 - D DT^DICRW - I 'HLDP S HLDP=$O(^HLCS(870,"B",HLDP,0)) I 'HLDP Q 0 - S DA=HLDP - ; patch HL*1.6*122 for field 400.09 - S DR="200.02;200.021;200.022;200.03;200.04;200.05;200.09;400.01;400.02;400.03;400.04;400.05;400.09" - D GETS^DIQ(870,DA,DR,"IN","TMP","TMP") - ; - I $D(TMP("DIERR")) QUIT 0 - ; -- re-transmit attempts - S HLDRETR=+$G(TMP(870,DA_",",200.02,"I")) - S HLDRETR("CLOSE")=+$G(TMP(870,DA_",",200.022,"I")) - ; -- exceed re-transmit action - S HLRETRA=$G(TMP(870,DA_",",200.021,"I")) - ; -- block size - S HLDBSIZE=+$G(TMP(870,DA_",",200.03,"I")) - ; -- read timeout - S HLDREAD=+$G(TMP(870,DA_",",200.04,"I")) - ; -- ack timeout - S HLDBACK=+$G(TMP(870,DA_",",200.05,"I")) - ; -- uni-directional wait - S HLDWAIT=$G(TMP(870,DA_",",200.09,"I")) - ; -- tcp address - S HLTCPADD=$G(TMP(870,DA_",",400.01,"I")) - ; -- tcp port - S HLTCPORT=$G(TMP(870,DA_",",400.02,"I")) - ; -- tcp/ip service type - S HLTCPCS=$G(TMP(870,DA_",",400.03,"I")) - ; -- link persistence - S HLTCPLNK=$G(TMP(870,DA_",",400.04,"I")) - ; -- retention - S HLTCPRET=$G(TMP(870,DA_",",400.05,"I")) - ; - ; patch HL*1.6*140 - ; patch HL*1.6*122 for field 400.09 - ; -- tcp/ip openfail timeout - ; S HLTCPLNK("TIMEOUT")=$G(TMP(870,DA_",",400.09,"I")) - S HLTCPLNK("TIMEOUT")=+$G(TMP(870,DA_",",400.09,"I")) - ; - ; -- set defaults in case something's not set - S:HLDREAD=0 HLDREAD=10 - S:HLDBACK=0 HLDBACK=60 - ; patch HL*1.6*122 - ; S:HLDBSIZE=0 HLDBSIZE=245 - S:HLDBSIZE<245 HLDBSIZE=245 - S:HLDRETR=0 HLDRETR=5 - S:HLTCPRET="" X=$P($$PARAM^HLCS2,U,12),HLTCPRET=$S(X:X,1:15) - ; - ; patch HL*1.6*140, the defaut is 30 - ; patch HL*1.6*122 for field 400.09 - ; S:HLTCPLNK("TIMEOUT")=0 HLTCPLNK("TIMEOUT")=5 - S:(HLTCPLNK("TIMEOUT")<1) HLTCPLNK("TIMEOUT")=30 - ; - Q 1 - ; -ST1 ;record startup in 870 for single server - ;4=status 9=Time Started, 10=Time Stopped, 11=Task Number - ;14=Shutdown LLP, 3=LLP Online, 18=Gross Errors - N HLJ,X - ; HL*1.6*122 remove unnecessary locks - ;F L +^HLCS(870,HLDP,0):2 Q:$T - S X="HLJ(870,"""_HLDP_","")" - S @X@(4)="Init",(@X@(10),@X@(18))="@",@X@(14)=0 - I HLTCPCS["C" S @X@(3)=$S(HLTCPLNK["Y":"PC",1:"NC") - E S @X@(3)=$S(HLTCPCS["S":"SS",HLTCPCS["M":"MS",1:"") - I @X@(3)'="NC" S @X@(9)=$$NOW^XLFDT - S:$G(ZTSK) @X@(11)=ZTSK - D FILE^HLDIE("","HLJ","","ST1","HLCSTCP") ;HL*1.6*109 - ;L -^HLCS(870,HLDP,0) - Q - ; -MON(Y) ;Display current state & check for shutdown - ;don't display for multiple server - Q:$G(HLLSTN) - ; HL*1.6*122 remove unnecessary locks - ;F L +^HLCS(870,HLDP,0):2 Q:$T - S $P(^HLCS(870,HLDP,0),U,5)=Y - ;L -^HLCS(870,HLDP,0) - Q:'$D(HLTRACE) - N X U IO(0) - W !,"IN State: ",Y - I '$$STOP D - . ; patch HL*1.6*122 - . ; R !,"Type Q to Quit: ",X#1:1 - . R !,"Type Q to Quit: ",X:1 - . ; I $L(X),"Qq"[X S $P(^HLCS(870,HLDP,0),U,15)=1 - . I $L(X),"Qq"[$E(X) S $P(^HLCS(870,HLDP,0),U,15)=1 - . ; patch HL*1.6*122 end - U IO - Q -UPDT(Y) ;update job count for multiple servers,X=1 increment - N HLJ,X - ; - ; HL*1.6*122 start - ; F L +^HLCS(870,HLDP,0):2 Q:$T - Q:'$G(HLDP) - Q:'$D(^HLCS(870,"E","M",HLDP)) - F L +^HLCS(870,HLDP,0):10 Q:$T H 1 - ; S X=+$P(^HLCS(870,HLDP,0),U,5),$P(^(0),U,5)=$S(Y:X+1,1:X-1)_" server" - S X=+$P(^HLCS(870,HLDP,0),U,5) - I X<0 S X=0 - S $P(^HLCS(870,HLDP,0),U,5)=$S(Y:(X+1),X<1:0,1:X-1)_" server" - ;if incrementing, set the Device Type field to Multi-Server - ; I X S HLJ(870,HLDP_",",3)="MS" D FILE^HLDIE("","HLJ","","UPDT","HLCSTCP") - I $P(^HLCS(870,HLDP,0),"^",4)']"" S $P(^HLCS(870,HLDP,0),"^",4)="MS" - ; HL*1.6*122 end - ; - L -^HLCS(870,HLDP,0) - Q -STOP() ;stop flag set - N X - F L +^HLCS(870,HLDP,0):2 Q:$T - S X=+$P(^HLCS(870,HLDP,0),U,15) - L -^HLCS(870,HLDP,0) - Q X - ; -LLCNT(DP,Y,Z) ;update Logical Link counters - ;DP=ien of Logical Link in file 870 - ;Y: 1=msg rec, 2=msg proc, 3=msg to send, 4=msg sent - ;Z: ""=add to counter, 1=subtract from counter - Q:'$D(^HLCS(870,+$G(DP),0))!('$G(Y)) - N P,X - S P=$S(Y<3:"IN",1:"OUT")_" QUEUE "_$S(Y#2:"BACK",1:"FRONT")_" POINTER" - ; patch HL*1.6*122 start - ; F L +^HLCS(870,DP,P):2 Q:$T - ; S X=+$G(^HLCS(870,DP,P)),^(P)=X+$S($G(Z):-1,1:1) - I '$L($G(OS)) N OS S OS=$G(^%ZOSF("OS")) - I OS'["DSM",OS'["OpenM" D - . F L +^HLCS(870,DP,P):10 Q:$T H 1 - . S X=+$G(^HLCS(870,DP,P)),^(P)=X+$S($G(Z):-1,1:1) - . L -^HLCS(870,DP,P) - E D - . S X=$I(^HLCS(870,DP,P),$S($G(Z):-1,1:1)) - ; L -^HLCS(870,DP,P) - ; patch HL*1.6*122 end - Q -SDFLD ; set Shutdown? field to yes - Q:'$G(HLDP) - ; HL*1.6*122 remove unnecessary lock and call to FM - S $P(^HLCS(870,HLDP,0),U,15)=1 - ;N HLJ,X - ;F L +^HLCS(870,HLDP,0):2 Q:$T - ;14=Shutdown LLP? - ;S HLJ(870,HLDP_",",14)=1 - ;D FILE^HLDIE("","HLJ","","SDFLD","HLCSTCP") ;HL*1.6*109 - ;L -^HLCS(870,HLDP,0) - Q - ; -EXITS(Y) ; shutdown and clean up the listener process for either - ; single-threaded or multi-threaded - N HLJ,X - F L +^HLCS(870,HLDP,0):2 Q:$T - ;4=status,10=Time Stopped,9=Time Started,11=Task Number - S X="HLJ(870,"""_HLDP_","")" - S @X@(4)=Y,@X@(11)="@" - S:$G(HLCSOUT)'=2 @X@(10)=$$NOW^XLFDT,@X@(9)="@" - D FILE^HLDIE("","HLJ","","EXITS","HLCSTCP") ; HL*1.6*109 - L -^HLCS(870,HLDP,0) - I $D(ZTQUEUED) S ZTREQ="@" - ; HL*1.6*122 - L -^HLCS("HLTCPLINK",HLDP) - Q - ; -EXITM ;Multiple service shutdown and clean up - ; shutdown and clean up a connection spawned by the listener - ; process for a multi-threaded listener - D UPDT(0) - I $D(ZTQUEUED) S ZTREQ="@" - Q +HLCSTCP ;SFIRMFO/TNV-ALB/JFP,PKE - (TCP/IP) MLLP ;09/13/2006 + ;;1.6;HEALTH LEVEL SEVEN;**19,43,49,57,58,64,84,109,133**;Oct 13, 1995;Build 13 + ;Per VHA Directive 2004-038, this routine should not be modified. + ; + ; This is an implementation of the HL7 Minimal Lower Layer Protocol + ; + ;taskman entry/startup option, HLDP defined in menu entry, + Q:'$D(HLDP) + N HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL + ;HLCSOUT= 1-error + I '$$INIT D EXITS("Init Error") Q + ; Start the client + I $G(HLTCPCS)="C" D Q + . ; identify process for ^%SY + . D SETNM^%ZOSV($E("HLClnt:"_HLDP,1,15)) + . D ST1 + . F D ^HLCSTCP2 Q:$$STOP!$G(HLCSOUT) + . I $G(HLCSOUT)=1 D MON("Error") H 1 Q + . I $G(HLCSOUT)=2 D EXITS("Inactive") Q + . D EXITS("Shutdown") + ; + ; identify process for ^%SY + D SETNM^%ZOSV($E("HLSrv:"_HLDP,1,15)) + ;HLCSFAIL=1 port failed to open + S HLCSFAIL=1 + ;single threaded listener + I $G(HLTCPCS)="S" D Q + . D ST1,MON("Listen"),LISTEN^%ZISTCP(HLTCPORT,"SERVER^HLCSTCP("""_HLDP_""")") + . ;couldn't open listener port + . I HLCSFAIL D EXITS("Openfail") Q + ; + ;multi-threaded listener (OpenM) + I $G(HLTCPCS)="M",^%ZOSF("OS")["OpenM" D Q + . D ST1,MON("Listen"),LISTEN^%ZISTCPS(HLTCPORT,"SERVERS^HLCSTCP("""_HLDP_""")") + Q + ; +SERVER(HLDP) ; single server using Taskman + S HLCSFAIL=0 + I '$$INIT D EXITS("Init error") Q + D ^HLCSTCP1 + I $$STOP D CLOSE^%ZISTCP,EXITS("Shutdown") S IO("C")="" Q + Q:$G(HLCSOUT)=1 + D MON("Idle") + Q + ; +SERVERS(HLDP) ; Multi-threaded server using Taskman + I '$$INIT D EXITS("Init error") Q + G LISTEN + ; + ;multiple process servers, called from an external utility +MSM ;MSM entry point, called from User-Defined Services + ;HLDP=ien in the HL LOWER LEVEL PROTOCOL PARAMETER file for the + ;HL7 Multi-Threaded SERVER + S (IO,IO(0))=$P + G LISTEN + ; +CACHEVMS(%) ;Cache'/VMS tcpip/ucx entry point, called from HLSEVEN.COM file, + ;listener, % = HLDP + I $G(%)="" D ^%ZTER Q + S IO="SYS$NET",HLDP=% + S IO(0)="_NLA0:" O IO(0) ;Setup null device + ; **Cache'/VMS specific code** + O IO::5 E D MON("Openfail") Q + X "U IO:(::""-M"")" ;Packet mode like DSM + D LISTEN C IO Q + ; +EN ;vms ucx entry point, called from HLSEVEN.COM file, + ;listener, % = device^HLDP + I $G(%)="" D ^%ZTER Q + S IO="SYS$NET",U="^",HLDP=$P(%,U,2) + S IO(0)="_NLA0:" O IO(0) ;Setup null device + ; **VMS specific code, need to share device** + O IO:(TCPDEV):60 E D MON("Openfail") Q +LISTEN ; + N HLLSTN,HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL + I '$$INIT D ^%ZTER Q + ; identify process for ^%SY + D SETNM^%ZOSV($E("HLSrv:"_HLDP,1,15)) + ;HLLSTN used to identify a listener to tag MON + S HLLSTN=1 + ;increment job count, run server + D UPDT(1),^HLCSTCP1,EXITM + Q + ; +DCOPEN(HLDP) ;open direct connect - called from HLMA2 + Q:'$$INIT 0 + Q:HLTCPADD=""!(HLTCPORT="") 0 + Q:'$$OPEN^HLCSTCP2 0 + Q 1 + ; +INIT() ; Initialize Variables + ; HLDP should be set to the IEN or name of Logical Link, file 870 + S HLOS=$P($G(^%ZOSF("OS")),"^") + N DA,DIQUIET,DR,TMP,X,Y + S DIQUIET=1 + D DT^DICRW + I 'HLDP S HLDP=$O(^HLCS(870,"B",HLDP,0)) I 'HLDP Q 0 + S DA=HLDP + S DR="200.02;200.021;200.022;200.03;200.04;200.05;200.09;400.01;400.02;400.03;400.04;400.05" + D GETS^DIQ(870,DA,DR,"IN","TMP","TMP") + ; + I $D(TMP("DIERR")) QUIT 0 + ; -- re-transmit attempts + S HLDRETR=+$G(TMP(870,DA_",",200.02,"I")) + S HLDRETR("CLOSE")=+$G(TMP(870,DA_",",200.022,"I")) + ; -- exceed re-transmit action + S HLRETRA=$G(TMP(870,DA_",",200.021,"I")) + ; -- block size + S HLDBSIZE=+$G(TMP(870,DA_",",200.03,"I")) + ; -- read timeout + S HLDREAD=+$G(TMP(870,DA_",",200.04,"I")) + ; -- ack timeout + S HLDBACK=+$G(TMP(870,DA_",",200.05,"I")) + ; -- uni-directional wait + S HLDWAIT=$G(TMP(870,DA_",",200.09,"I")) + ; -- tcp address + S HLTCPADD=$G(TMP(870,DA_",",400.01,"I")) + ; -- tcp port + S HLTCPORT=$G(TMP(870,DA_",",400.02,"I")) + ; -- tcp/ip service type + S HLTCPCS=$G(TMP(870,DA_",",400.03,"I")) + ; -- link persistence + S HLTCPLNK=$G(TMP(870,DA_",",400.04,"I")) + ; -- retention + S HLTCPRET=$G(TMP(870,DA_",",400.05,"I")) + ; + ; -- set defaults in case something's not set + S:HLDREAD=0 HLDREAD=10 + S:HLDBACK=0 HLDBACK=60 + S:HLDBSIZE=0 HLDBSIZE=245 + S:HLDRETR=0 HLDRETR=5 + S:HLTCPRET="" X=$P($$PARAM^HLCS2,U,12),HLTCPRET=$S(X:X,1:15) + ; + Q 1 + ; +ST1 ;record startup in 870 for single server + ;4=status 9=Time Started, 10=Time Stopped, 11=Task Number + ;14=Shutdown LLP, 3=LLP Online, 18=Gross Errors + N HLJ,X + F L +^HLCS(870,HLDP,0):2 Q:$T + S X="HLJ(870,"""_HLDP_","")" + S @X@(4)="Init",(@X@(10),@X@(18))="@",@X@(14)=0 + I HLTCPCS["C" S @X@(3)=$S(HLTCPLNK["Y":"PC",1:"NC") + E S @X@(3)=$S(HLTCPCS["S":"SS",HLTCPCS["M":"MS",1:"") + I @X@(3)'="NC" S @X@(9)=$$NOW^XLFDT + S:$G(ZTSK) @X@(11)=ZTSK + D FILE^HLDIE("","HLJ","","ST1","HLCSTCP") ;HL*1.6*109 + L -^HLCS(870,HLDP,0) + Q + ; +MON(Y) ;Display current state & check for shutdown + ;don't display for multiple server + Q:$G(HLLSTN) + F L +^HLCS(870,HLDP,0):2 Q:$T + S $P(^HLCS(870,HLDP,0),U,5)=Y + L -^HLCS(870,HLDP,0) + Q:'$D(HLTRACE) + N X U IO(0) + W !,"IN State: ",Y + I '$$STOP D + . R !,"Type Q to Quit: ",X#1:1 + . I $L(X),"Qq"[X S $P(^HLCS(870,HLDP,0),U,15)=1 + U IO + Q +UPDT(Y) ;update job count for multiple servers,X=1 increment + N HLJ,X + F L +^HLCS(870,HLDP,0):2 Q:$T + S X=+$P(^HLCS(870,HLDP,0),U,5),$P(^(0),U,5)=$S(Y:X+1,1:X-1)_" server" + ;if incrementing, set the Device Type field to Multi-Server + I X S HLJ(870,HLDP_",",3)="MS" D FILE^HLDIE("","HLJ","","UPDT","HLCSTCP") ;HL*1.6*109 + L -^HLCS(870,HLDP,0) + Q +STOP() ;stop flag set + N X + F L +^HLCS(870,HLDP,0):2 Q:$T + S X=+$P(^HLCS(870,HLDP,0),U,15) + L -^HLCS(870,HLDP,0) + Q X + ; +LLCNT(DP,Y,Z) ;update Logical Link counters + ;DP=ien of Logical Link in file 870 + ;Y: 1=msg rec, 2=msg proc, 3=msg to send, 4=msg sent + ;Z: ""=add to counter, 1=subtract from counter + Q:'$D(^HLCS(870,+$G(DP),0))!('$G(Y)) + N P,X + S P=$S(Y<3:"IN",1:"OUT")_" QUEUE "_$S(Y#2:"BACK",1:"FRONT")_" POINTER" + F L +^HLCS(870,DP,P):2 Q:$T + S X=+$G(^HLCS(870,DP,P)),^(P)=X+$S($G(Z):-1,1:1) + L -^HLCS(870,DP,P) + Q +SDFLD ; set Shutdown? field to yes + Q:'$G(HLDP) + N HLJ,X + F L +^HLCS(870,HLDP,0):2 Q:$T + ;14=Shutdown LLP? + S HLJ(870,HLDP_",",14)=1 + D FILE^HLDIE("","HLJ","","SDFLD","HLCSTCP") ;HL*1.6*109 + L -^HLCS(870,HLDP,0) + Q + ; +EXITS(Y) ; Single service shutdown and cleans up + N HLJ,X + F L +^HLCS(870,HLDP,0):2 Q:$T + ;4=status,10=Time Stopped,9=Time Started,11=Task Number + S X="HLJ(870,"""_HLDP_","")" + S @X@(4)=Y,@X@(11)="@" + S:$G(HLCSOUT)'=2 @X@(10)=$$NOW^XLFDT,@X@(9)="@" + D FILE^HLDIE("","HLJ","","EXITS","HLCSTCP") ; HL*1.6*109 + L -^HLCS(870,HLDP,0) + I $D(ZTQUEUED) S ZTREQ="@" + Q + ; +EXITM ;Multiple service shutdown and clean up + D UPDT(0) + I $D(ZTQUEUED) S ZTREQ="@" + Q diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP1.m b/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP1.m index 3ec317aa..ee783627 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP1.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP1.m @@ -1,302 +1,276 @@ -HLCSTCP1 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;04/15/08 11:11 - ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,64,71,133,132,122,140**;OCT 13,1995;Build 5 - ;Per VHA Directive 2004-038, this routine should not be modified. - ;Receiver - ;connection is initiated by sender and listener accepts connection - ;and calls this routine - ; - N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP1" - N HLMIEN,HLASTMSG - ; - ; patch HL*1.6*140, save IO - S HLTCPORT("IO")=IO ;RWF - ; patch HL*1.6*122 start - ; variable to replace ^TMP - N HLTMBUF - ; - ; for HL7 application proxy user - ;; N HLDUZ,DUZ ; patch HL*1.6*122 TEST v2: DUZ code removed - N HLDUZ - S HLDUZ=+$G(DUZ) - ; - D MON^HLCSTCP("Open") - ; K ^TMP("HLCSTCP",$J,0) - S HLMIEN=0,HLASTMSG="" - ; - ; patch HL*1.6*122 TEST v2: DUZ code removed - ; set DUZ for application proxy user - ;; D PROXY^HLCSTCP4 - ; - F D Q:$$STOP^HLCSTCP I 'HLMIEN D MON^HLCSTCP("Idle") H 3 - . ; clean variables - . D CLEANVAR^HLCSTCP4 - . ; patch HL*1.6*140, restore the saved IO - . S IO=HLTCPORT("IO") ;RWF - . S HLMIEN=$$READ - . Q:'HLMIEN - . ; - . ; patch HL*1.6*122 TEST v2: DUZ code removed - . ; DUZ comparison/reset for application proxy user - . ;; D HLDUZ^HLCSTCP4 - . D HLDUZ2^HLCSTCP4 - . ; protect HLDUZ - . N HLDUZ - . D PROCESS - ; patch HL*1.6*122 end - Q - ; -PROCESS ;check message and reply - ;HLDP=LL in 870 - N HLTCP,HLTCPI,HLTCPO - S HLTCP="",HLTCPO=HLDP,HLTCPI=+HLMIEN - ;update monitor, msg. received - D LLCNT^HLCSTCP(HLDP,1) - D NEW^HLTP3(HLMIEN) - ;I IO'=HLTCPORT("IO") D ^%ZTER ;RWF - ;update monitor, msg. processed - D LLCNT^HLCSTCP(HLDP,2) - Q - ; -READ() ;read 1 message, returns ien in 773^ien in 772 for message - D MON^HLCSTCP("Reading") - N HLDB,HLDT,HLDEND,HLACKWT,HLDSTRT,HLHDR,HLIND1,HLINE,HLMSG,HLRDOUT,HLRS,HLX,X - ;HLDSTRT=start char., HLDEND=end char., HLRS=record separator - S HLDSTRT=$C(11),HLDEND=$C(28),HLRS=$C(13) - ;HLRDOUT=exit read loop, HLINE=line count, HLIND1=ien 773^ien 772 - ;HLHDR=have a header, HLTMBUF()=excess from last read, HLACKWT=wait for ack - ; HL*1.6*122 start - ; S (HLRDOUT,HLINE,HLIND1,HLHDR)=0,HLX=$G(^TMP("HLCSTCP",$J,0)),HLACKWT=HLDBACK - S (HLRDOUT,HLINE,HLIND1,HLHDR)=0,HLX=$G(HLTMBUF(0)),HLACKWT=HLDBACK - N HLBUFF,HLXX,MAXWAIT - ; based on patch 132 for readtime - S MAXWAIT=$S((HLACKWT>HLDREAD):HLACKWT,1:HLDREAD) - S HLRS("START-FLAG")=0 - S HLTMBUF(0)="" - ; variable used to store data in HLBUFF - S HLX(1)=$G(HLTMBUF(1)) - S HLTMBUF(1)="" - S HLBUFF("START")=0 - S HLBUFF("END")=0 - I (HLX]"")!(HLX(1)]"") D - . I (HLX[HLDSTRT)!(HLX(1)[HLDSTRT) D - .. S HLBUFF("START")=1 - . I (HLX[HLDEND)!(HLX(1)[HLDEND) D - .. S HLBUFF("END")=1 - F D RDBLK Q:HLRDOUT - ;**132** - ;switch to null device if opened to prevent 'leakage' - I $G(IO(0))]"",IO(0)'=IO U IO(0) - ; - ;save any excess for next time - S:HLX]"" HLTMBUF(0)=HLX - S:HLX(1)]"" HLTMBUF(1)=HLX(1) - I +HLIND1,'$P(HLIND1,U,3) D DELMSG(HLIND1) S HLIND1=0 - Q HLIND1 - ; -RDBLK ; - ; initialize - S HLBUFF="" - ; - ;S HLDB=HLDBSIZE-$L(HLX) - ; store the total length of HLX and HLX(1) in HLDB(1) - S HLDB(1)=$L(HLX)+$L(HLX(1)) - ; - ;**132 ** - ;U IO R X#HLDB:HLDREAD - ; U IO R X#HLDB:MAXWAIT - ; - ; remove the readcount to speedup GT.M - U IO - R:(HLDB(1), quit - ;I '$T,X="",HLX="" S HLACKWT=HLACKWT-HLDREAD D:HLACKWT<0&'HLHDR CLEAN Q - ;I '$T,X="",HLX="" D:'HLHDR CLEAN Q - ; patch HL*1.6*140 - ; I '$T,HLBUFF="",HLX="",HLX(1)="" D Q - I HLBUFF="",HLX="",HLX(1)="" D Q - . D:('HLHDR)&('HLIND1) CLEAN - ;add incoming line to what wasn't processed in last read - ;S HLX=$G(HLX)_X - ; get block of characters from read buffer HLBUFF - ; every 'for-loop' deal with one read at most, and one message at most - ; if HLX is not empty, loop continues even no data is read - ; quit, if both HLDBUFF and HLX(1) are empty, means one read is done - ; quit, when HLRDOUT is set to 1, means one message is encountered - ; an "end" - ; F D Q:HLXX=""!(HLRDOUT) - F D Q:(HLRDOUT)!(HLBUFF=""&(HLX(1)="")) - . ; - . ; if HLX(1) is not empty - . I HLX(1)]"" D - .. ; hldb(2) is the number of characters extracted from hlx(1) - .. ; to be concatenated with hlx - .. S HLDB(2)=HLDBSIZE-$L(HLX) - .. ; hlx(2) stores the first hldb(2) characters extracted - .. ; from hlx(1) - .. S HLX(2)=$E(HLX(1),1,HLDB(2)) - .. S HLX(1)=$E(HLX(1),HLDB(2)+1,$L(HLX(1))) - .. S HLX=$G(HLX)_HLX(2) - . ; - . ; if HLX(1) is empty, and HLBUFF contains data - . ; all the data in hlx(1) need to be extracted first - . I HLX(1)="",HLBUFF]"" D - .. S HLDB=HLDBSIZE-$L(HLX) - .. S HLXX=$E(HLBUFF,1,HLDB) - .. S HLBUFF=$E(HLBUFF,HLDB+1,$L(HLBUFF)) - .. S HLX=$G(HLX)_HLXX - . ; quit when HLX is empty - . Q:(HLX="") - . ; ** 132 ** - . ; if no segment end, HLX not full, go back for more - . I $L(HLX)dddd - ; HL*1.6*122 end - ; look for segment= - F Q:HLX'[HLRS D Q:HLRDOUT - . ; Get the first piece, save the rest of the line - . S HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLRS),HLX=$P(HLX,HLRS,2,999) - . ; check for start block, Quit if no ien - . I HLMSG(HLINE,0)[HLDSTRT!HLHDR D Q - .. S HLRS("START-FLAG")=1 ; HL*1.6*122 - .. D:HLMSG(HLINE,0)[HLDSTRT - ... S X=$L(HLMSG(HLINE,0),HLDSTRT) - ... S:X>2 HLMSG(HLINE,0)=HLDSTRT_$P(HLMSG(HLINE,0),HLDSTRT,X) - ... S HLMSG(HLINE,0)=$P(HLMSG(HLINE,0),HLDSTRT,2) - ... D RESET:(HLINE>1) - .. ; - .. ; patch HL*1.6*122 - .. ; if the first line less than 10 characters - .. I HLHDR,$L(HLMSG(1,0))<10,$D(HLMSG(2,0)) D - ... S HLMSG(1,0)=HLMSG(1,0)_$E(HLMSG(2,0),1,10) - ... S HLMSG(2,0)=$E(HLMSG(2,0),11,9999999) - .. ; - .. ;ping message - .. I $E(HLMSG(1,0),1,9)="MSH^PING^" D PING Q - .. ; get next ien to store - .. D MIEN^HLCSTCP4 - .. K HLMSG - .. S (HLINE,HLHDR)=0 - . ; check for end block; - . I HLMSG(HLINE,0)[HLDEND D - .. ; patch HL*1.6*122 start - .. ;no msg. ien - .. ; Q:'HLIND1 - .. I 'HLIND1 D CLEAN Q - .. ; Kill just the last line if no data before HLDEND - .. I $P(HLMSG(HLINE,0),HLDEND)']"" D - ... K HLMSG(HLINE,0) S HLINE=HLINE-1 - .. E S HLMSG(HLINE,0)=$P(HLMSG(HLINE,0),HLDEND) - .. ; patch HL*1.6*122 end - .. ; - .. ; move into 772 - .. D SAVE(.HLMSG,"^HL(772,"_+$P(HLIND1,U,2)_",""IN"")") - .. ;mark that end block has been received - .. ;HLIND1=ien in 773^ien in 772^1 if end block was received - .. S $P(HLIND1,U,3)=1 - .. S HLBUFF("HLIND1")=HLIND1 - .. ;reset variables for next message - .. D CLEAN - . ;add blank line for carriage return - . I HLINE'=0,HLMSG(HLINE,0)]"" S HLINE=HLINE+1,HLMSG(HLINE,0)="" - Q:HLRDOUT - ;If the line is long and no move it into the array. - I ($L(HLX)=HLDBSIZE),(HLX'[HLRS),(HLX'[HLDEND),(HLX'[HLDSTRT) D Q - . S HLINE=HLINE+1,HLMSG(HLINE,0)=HLX,HLX="" - ;have start block but no record separator - I HLX[HLDSTRT D Q - . ;check for more than 1 start block - . S X=$L(HLX,HLDSTRT) S:X>2 HLX=HLDSTRT_$P(HLX,HLDSTRT,X) - . ; - . ; patch HL*1.6*122 - . ; S:$L($P(HLX,HLDSTRT,2))>8 HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLDSTRT,2),HLX="",HLHDR=1 - . S HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLDSTRT,2),HLX="",HLHDR=1 - . ; - . D RESET:(HLHDR&(HLINE>1)) - ;if no ien, reset - ; patch HL*1.6*122 - ; I 'HLIND1 D CLEAN Q - I (HLRS("START-FLAG")=1),'HLIND1 D CLEAN Q - ; big message-merge from local to global every 100 lines - I (HLINE-$O(HLMSG(0)))>100 D - . M ^HL(772,+$P(HLIND1,U,2),"IN")=HLMSG - . ; reset working array - . K HLMSG - Q - ; -SAVE(SRC,DEST) ;save into global & set top node - ;SRC=source array (passed by ref.), DEST=destination global - ; - ; patch HL*1.6*122: MPI-client/server - I DEST["HLMA" D - . F L +^HLMA(+HLIND1):10 Q:$T H 1 - E D - . F L +^HL(772,+$P(HLIND1,U,2)):10 Q:$T H 1 - ; - M @DEST=SRC - S @DEST@(0)="^^"_HLINE_"^"_HLINE_"^"_DT_"^" - ; - I DEST["HLMA" L -^HLMA(+HLIND1) - E L -^HL(772,+$P(HLIND1,U,2)) - ; - Q - ; -DELMSG(HLMAMT) ;delete message from Message Administration/Message Text files. - N DIK,DA - S DA=+HLMAMT,DIK="^HLMA(" - D ^DIK - S DA=$P(HLMAMT,U,2),DIK="^HL(772," - D ^DIK - Q -PING ;process PING message - S X=HLMSG(1,0) - ; patch HL*1.6*140, flush character- HLTCPLNK("IOF") - ; I X[HLDEND U IO W X,! D - I X[HLDEND U IO W X,HLTCPLNK("IOF") D - . ; switch to null device if opened to prevent 'leakage' - . I $G(IO(0))]"",$G(IO(0))'=IO U IO(0) -CLEAN ;reset var. for next message - K HLMSG - S HLINE=0,HLRDOUT=1 - Q - ; -ERROR ; Error trap for disconnect error and return back to the read loop. - ; patch HL*1.6*122 - ; move to routine HLCSTCP4 (splitted-size over 10000) - D ERROR1^HLCSTCP4 - Q - ; -CC(X) ;cleanup and close - D MON^HLCSTCP(X) - H 2 - Q -RESET ;reset info as a result of no end block - N % - S HLMSG(1,0)=HLMSG(HLINE,0) - F %=2:1:HLINE K HLMSG(%,0) - S HLINE=1 - Q +HLCSTCP1 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;7/28/07 08:58 + ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,64,71,133,132,122**;OCT 13,1995;Build 4 + ;Per VHA Directive 2004-038, this routine should not be modified. + ;Receiver + ;connection is initiated by sender and listener accepts connection + ;and calls this routine + ; + N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP1" + N HLMIEN,HLASTMSG + ; + ; patch HL*1.6*122 start + ; variable to replace ^TMP + N HLTMBUF + ; for HL7 application proxy user + N HLDUZ,DUZ + D MON^HLCSTCP("Open") + ; K ^TMP("HLCSTCP",$J,0) + S HLMIEN=0,HLASTMSG="" + ; set DUZ for application proxy user + D PROXY^HLCSTCP4 + F D Q:$$STOP^HLCSTCP I 'HLMIEN D MON^HLCSTCP("Idle") H 3 + . ; clean variables + . D CLEANVAR^HLCSTCP4 + . S HLMIEN=$$READ + . Q:'HLMIEN + . ; DUZ comparison/reset for application proxy user + . D HLDUZ^HLCSTCP4 + . ; protect HLDUZ + . N HLDUZ + . D PROCESS + ; patch HL*1.6*122 end + Q + ; +PROCESS ;check message and reply + ;HLDP=LL in 870 + N HLTCP,HLTCPI,HLTCPO + S HLTCP="",HLTCPO=HLDP,HLTCPI=+HLMIEN + ;update monitor, msg. received + D LLCNT^HLCSTCP(HLDP,1) + D NEW^HLTP3(HLMIEN) + ;update monitor, msg. processed + D LLCNT^HLCSTCP(HLDP,2) + Q + ; +READ() ;read 1 message, returns ien in 773^ien in 772 for message + D MON^HLCSTCP("Reading") + N HLDB,HLDT,HLDEND,HLACKWT,HLDSTRT,HLHDR,HLIND1,HLINE,HLMSG,HLRDOUT,HLRS,HLX,X + ;HLDSTRT=start char., HLDEND=end char., HLRS=record seperator + S HLDSTRT=$C(11),HLDEND=$C(28),HLRS=$C(13) + ;HLRDOUT=exit read loop, HLINE=line count, HLIND1=ien 773^ien 772 + ;HLHDR=have a header, HLTMBUF()=excess from last read, HLACKWT=wait for ack + ; HL*1.6*122 start + ; S (HLRDOUT,HLINE,HLIND1,HLHDR)=0,HLX=$G(^TMP("HLCSTCP",$J,0)),HLACKWT=HLDBACK + S (HLRDOUT,HLINE,HLIND1,HLHDR)=0,HLX=$G(HLTMBUF(0)),HLACKWT=HLDBACK + N HLBUFF,HLXX,MAXWAIT + ; based on patch 132 for readtime + S MAXWAIT=$S((HLACKWT>HLDREAD):HLACKWT,1:HLDREAD) + S HLRS("START-FLAG")=0 + S HLTMBUF(0)="" + ; variable used to store data in HLBUFF + S HLX(1)=$G(HLTMBUF(1)) + S HLTMBUF(1)="" + S HLBUFF("START")=0 + S HLBUFF("END")=0 + I (HLX]"")!(HLX(1)]"") D + . I (HLX[HLDSTRT)!(HLX(1)[HLDSTRT) D + .. S HLBUFF("START")=1 + . I (HLX[HLDEND)!(HLX(1)[HLDEND) D + .. S HLBUFF("END")=1 + F D RDBLK Q:HLRDOUT + ;**132** + ;switch to null device if opened to prevent 'leakage' + I $G(IO(0))]"",IO(0)'=IO U IO(0) + ; + ;save any excess for next time + S:HLX]"" HLTMBUF(0)=HLX + S:HLX(1)]"" HLTMBUF(1)=HLX(1) + I +HLIND1,'$P(HLIND1,U,3) D DELMSG(HLIND1) S HLIND1=0 + Q HLIND1 + ; +RDBLK ; + ; initialize + S HLBUFF="" + ; + ;S HLDB=HLDBSIZE-$L(HLX) + ; store the total length of HLX and HLX(1) in HLDB(1) + S HLDB(1)=$L(HLX)+$L(HLX(1)) + ; + ;**132 ** + ;U IO R X#HLDB:HLDREAD + ; U IO R X#HLDB:MAXWAIT + ; + ; remove the readcount to speedup GT.M + U IO + R:(HLDB(1), quit + ;I '$T,X="",HLX="" S HLACKWT=HLACKWT-HLDREAD D:HLACKWT<0&'HLHDR CLEAN Q + ;I '$T,X="",HLX="" D:'HLHDR CLEAN Q + I '$T,HLBUFF="",HLX="",HLX(1)="" D Q + . D:('HLHDR)&('HLIND1) CLEAN + ;add incoming line to what wasn't processed in last read + ;S HLX=$G(HLX)_X + ; + ; get block of characters from read buffer HLBUFF + ; every 'for-loop' deal with one read at most, and one message at most + ; if HLX is not empty, loop continues even no data is read + ; quit, if both HLDBUFF and HLX(1) are empty, means one read is done + ; quit, when HLRDOUT is set to 1, means one message is encountered + ; an "end" + ; F D Q:HLXX=""!(HLRDOUT) + F D Q:(HLRDOUT)!(HLBUFF=""&(HLX(1)="")) + . ; + . ; if HLX(1) is not empty + . I HLX(1)]"" D + .. ; hldb(2) is the number of characters extracted from hlx(1) + .. ; to be concatenated with hlx + .. S HLDB(2)=HLDBSIZE-$L(HLX) + .. ; hlx(2) stores the first hldb(2) characters extracted + .. ; from hlx(1) + .. S HLX(2)=$E(HLX(1),1,HLDB(2)) + .. S HLX(1)=$E(HLX(1),HLDB(2)+1,$L(HLX(1))) + .. S HLX=$G(HLX)_HLX(2) + . ; + . ; if HLX(1) is empty, and HLBUFF contains data + . ; all the data in hlx(1) need to be extracted first + . I HLX(1)="",HLBUFF]"" D + .. S HLDB=HLDBSIZE-$L(HLX) + .. S HLXX=$E(HLBUFF,1,HLDB) + .. S HLBUFF=$E(HLBUFF,HLDB+1,$L(HLBUFF)) + .. S HLX=$G(HLX)_HLXX + . ; quit when HLX is empty + . Q:(HLX="") + . ; ** 132 ** + . ; if no segment end, HLX not full, go back for more + . I $L(HLX)dddd + ; HL*1.6*122 end + ; look for segment= + F Q:HLX'[HLRS D Q:HLRDOUT + . ; Get the first piece, save the rest of the line + . S HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLRS),HLX=$P(HLX,HLRS,2,999) + . ; check for start block, Quit if no ien + . I HLMSG(HLINE,0)[HLDSTRT!HLHDR D Q + .. S HLRS("START-FLAG")=1 ; HL*1.6*122 + .. D:HLMSG(HLINE,0)[HLDSTRT + ... S X=$L(HLMSG(HLINE,0),HLDSTRT) + ... S:X>2 HLMSG(HLINE,0)=HLDSTRT_$P(HLMSG(HLINE,0),HLDSTRT,X) + ... S HLMSG(HLINE,0)=$P(HLMSG(HLINE,0),HLDSTRT,2) + ... D RESET:(HLINE>1) + .. ; + .. ; patch HL*1.6*122 + .. ; if the first line less than 10 characters + .. I HLHDR,$L(HLMSG(1,0))<10,$D(HLMSG(2,0)) D + ... S HLMSG(1,0)=HLMSG(1,0)_$E(HLMSG(2,0),1,10) + ... S HLMSG(2,0)=$E(HLMSG(2,0),11,9999999) + .. ; + .. ;ping message + .. I $E(HLMSG(1,0),1,9)="MSH^PING^" D PING Q + .. ; get next ien to store + .. D MIEN^HLCSTCP4 + .. K HLMSG + .. S (HLINE,HLHDR)=0 + . ; check for end block; + . I HLMSG(HLINE,0)[HLDEND D + .. ; patch HL*1.6*122 start + .. ;no msg. ien + .. ; Q:'HLIND1 + .. I 'HLIND1 D CLEAN Q + .. ; Kill just the last line if no data before HLDEND + .. I $P(HLMSG(HLINE,0),HLDEND)']"" D + ... K HLMSG(HLINE,0) S HLINE=HLINE-1 + .. E S HLMSG(HLINE,0)=$P(HLMSG(HLINE,0),HLDEND) + .. ; patch HL*1.6*122 end + .. ; + .. ; move into 772 + .. D SAVE(.HLMSG,"^HL(772,"_+$P(HLIND1,U,2)_",""IN"")") + .. ;mark that end block has been received + .. ;HLIND1=ien in 773^ien in 772^1 if end block was received + .. S $P(HLIND1,U,3)=1 + .. S HLBUFF("HLIND1")=HLIND1 + .. ;reset variables for next message + .. D CLEAN + . ;add blank line for carriage return + . I HLINE'=0,HLMSG(HLINE,0)]"" S HLINE=HLINE+1,HLMSG(HLINE,0)="" + Q:HLRDOUT + ;If the line is long and no move it into the array. + I ($L(HLX)=HLDBSIZE),(HLX'[HLRS),(HLX'[HLDEND),(HLX'[HLDSTRT) D Q + . S HLINE=HLINE+1,HLMSG(HLINE,0)=HLX,HLX="" + ;have start block but no record seperator + I HLX[HLDSTRT D Q + . ;check for more than 1 start block + . S X=$L(HLX,HLDSTRT) S:X>2 HLX=HLDSTRT_$P(HLX,HLDSTRT,X) + . ; + . ; patch HL*1.6*122 + . ; S:$L($P(HLX,HLDSTRT,2))>8 HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLDSTRT,2),HLX="",HLHDR=1 + . S HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLDSTRT,2),HLX="",HLHDR=1 + . ; + . D RESET:(HLHDR&(HLINE>1)) + ;if no ien, reset + ; patch HL*1.6*122 + ; I 'HLIND1 D CLEAN Q + I (HLRS("START-FLAG")=1),'HLIND1 D CLEAN Q + ; big message-merge from local to global every 100 lines + I (HLINE-$O(HLMSG(0)))>100 D + . M ^HL(772,+$P(HLIND1,U,2),"IN")=HLMSG + . ; reset working array + . K HLMSG + Q + ; +SAVE(SRC,DEST) ;save into global & set top node + ;SRC=source array (passed by ref.), DEST=destination global + M @DEST=SRC + S @DEST@(0)="^^"_HLINE_"^"_HLINE_"^"_DT_"^" + Q + ; +DELMSG(HLMAMT) ;delete message from Message Administration/Message Text files. + N DIK,DA + S DA=+HLMAMT,DIK="^HLMA(" + D ^DIK + S DA=$P(HLMAMT,U,2),DIK="^HL(772," + D ^DIK + Q +PING ;process PING message + S X=HLMSG(1,0) + I X[HLDEND U IO W X,! D + . ; switch to null device if opened to prevent 'leakage' + . I $G(IO(0))]"",$G(IO(0))'=IO U IO(0) +CLEAN ;reset var. for next message + K HLMSG + S HLINE=0,HLRDOUT=1 + Q + ; +ERROR ; Error trap for disconnect error and return back to the read loop. + S $ETRAP="D UNWIND^%ZTER" + I $$EC^%ZOSV["IOEOF" D UNWIND^%ZTER Q ;VOE change for GT.M + I $$EC^%ZOSV["READ"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D UNWIND^%ZTER Q + I $$EC^%ZOSV["WRITE" D CC("Wr-err") D UNWIND^%ZTER Q + I $ECODE["UREAD" D UNWIND^%ZTER Q ; HL*1.6*122 GT.M + S HLCSOUT=1 D ^%ZTER,CC("Error") + D UNWIND^%ZTER + Q + ; +CC(X) ;cleanup and close + D MON^HLCSTCP(X) + H 2 + Q +RESET ;reset info as a result of no end block + N % + S HLMSG(1,0)=HLMSG(HLINE,0) + F %=2:1:HLINE K HLMSG(%,0) + S HLINE=1 + Q diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP2.m b/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP2.m index 2947f313..c7bd0c15 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP2.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP2.m @@ -1,284 +1,265 @@ -HLCSTCP2 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;04/16/2008 16:20 - ;;1.6;HEALTH LEVEL SEVEN;**19,43,49,57,63,64,66,67,76,77,87,109,133,122,140**;Oct 13,1995;Build 5 - ;Per VHA Directive 2004-038, this routine should not be modified. - ;Sender - ;Request connection, send outbound message(s) delimited by MLLP - ;Input : HLDP=Logical Link to use - ; Set up error trap - N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP2" - N HLMSG,HLPORT,HLRETRY,HLRETMG,HLTCPO,POP - ;HLRETRY=number of retranmission for this link,HLRETMG=alert sent - S HLTCPO=HLDP,HLMSG="",(HLRETRY,HLRETMG)=0 - ; - ; patch 122 - ; patch 133 - ; set IO(0) to the null device - I $G(^%ZOSF("OS"))]"",^%ZOSF("OS")'["GT.M" D - . S IO(0)=$S(^%ZOSF("OS")["OpenM":$S($$OS^%ZOSV()["VMS":"_NLA0:",$$OS^%ZOSV()["UNIX":"/dev/null",1:$P),^%ZOSF("OS")["DSM":"_NLA0:",1:$P) - . O IO(0) U IO(0) - ; - ;persistent conection, open connection first, HLPORT=open port - I $G(HLTCPLNK)["Y" F Q:$$OPEN G EXIT:$$STOP^HLCSTCP H 1 - F D QUE Q:$$STOP^HLCSTCP D:'HLMSG Q:$G(HLCSOUT) - . ;no messages to send - . D MON^HLCSTCP("Idle") H 3 - . ;persistent connection, no retention - . Q:$G(HLTCPLNK)["Y" - . D MON^HLCSTCP("Retention") - . N % I 0 - . ;if message comes in or ask to stop - . F %=1:1:HLTCPRET H 1 I $$STOP^HLCSTCP!$O(^HLMA("AC","O",HLDP,0)) Q - . E S HLCSOUT=2 Q - . Q:$$STOP^HLCSTCP - . D MON^HLCSTCP("Idle") - ;Close port - I $D(HLPORT) D CLOSE^%ZISTCP K HLPORT -EXIT Q - ; -QUE ; -- Check "OUT" queue for processing IF there is a message do it - ; and then check the link if it open or not - N HL,HLN,HLARR,HLHDR,HLI,HLJ,HLMSA,HLRESP,HLRESLT,HLRETRM,HLTCP,HLTCPI,X,Z,HLREREAD - N HLTMBUF - D MON^HLCSTCP("CheckOut") - ;HLMSG=next msg, set at tag DONE - I 'HLMSG S HLMSG=+$O(^HLMA("AC","O",HLDP,0)),HLRETRY=0 Q:'HLMSG - ; - S HLI=+$G(^HLMA(HLMSG,0)),HLJ=$O(^("MSH",0)),HLTCP="" - ;don't have message text or MSH, kill x-ref and decrement 'to send' - ; - ; patch HL*1.6*122: MPI-client/server - ; I 'HLI!'HLJ K ^HLMA("AC","O",HLDP,HLMSG) D LLCNT^HLCSTCP(HLDP,3,1) S HLMSG=0 Q - I 'HLI!'HLJ D Q - . F L +^HLMA("AC","O",HLDP,HLMSG):10 Q:$T H 1 - . K ^HLMA("AC","O",HLDP,HLMSG) - . L -^HLMA("AC","O",HLDP,HLMSG) - . D LLCNT^HLCSTCP(HLDP,3,1) - . S HLMSG=0 - ; - ;update msg status to 'being transmitted'; if cancelled decrement link and quit - I '$$CHKMSG(1.5) D LLCNT^HLCSTCP(HLDP,3,1) S HLMSG=0 Q - ;number of retransmissions for message - S HLRETRM=+$P(^HLMA(HLMSG,"P"),U,5) - ;retries exceeded, HLRETRA:action i=ignore, r=restart, s=shutdown - ;quit if restart or shutdown, link is going down - I HLRETRY>HLDRETR D Q:"I"'[HLRETRA - . D MON^HLCSTCP("Error") - . ;only 1 alert per link up time, don't send if restart - . D:'HLRETMG&(HLRETRA'="R") - .. ;send alert - .. N XQA,XQAMSG,XQAOPT,XQAROU,XQAID,Z - .. ;get mailgroup from file 869.3 - .. S HLRETMG=1,Z=$P($$PARAM^HLCS2,U,8) Q:Z="" - .. S XQA("G."_Z)="",XQAMSG=$$HTE^XLFDT($H,2)_" HL7 LL "_$P(^HLCS(870,HLDP,0),U)_" exceeded retries. LL will "_$S(HLRETRA="S":"shutdown.",HLRETRA="R":"restart.",1:"keep trying.") - .. D SETUP^XQALERT - . ;quit if action is ignore - . Q:"I"[HLRETRA - . ;this will shutdown this link - . S HLCSOUT=1 - . ;action is shutdown, set shutdown flag so LM won't restart - . S:HLRETRA="S" $P(^HLCS(870,HLDP,0),U,15)=1 - . D STATUS^HLTF0(HLMSG,4,103,"LLP Exceeded Retry Param") - I '$$OPEN Q - D MON^HLCSTCP("Send") - ; -- data passed in global array, success=1 - I $$WRITE(HLMSG)<0 Q - S (HLTCP,HLTCPI)=HLMSG,HLRETRY=HLRETRY+1,HLRETRM=HLRETRM+1 - ;update status to awaiting response, decrement link if cancelled - I '$$CHKMSG(1.7) D LLCNT^HLCSTCP(HLDP,3,1) S HLMSG=0 Q - ;set transmission count, get ACKTIMEOUT override - S $P(^HLMA(HLMSG,"P"),U,5)=HLRETRM I $P(^("P"),U,7) S HLN("ACKTIME")=+$P(^("P"),U,7) - ;get header of message just sent - K HLJ M HLJ=^HLMA(HLMSG,"MSH") - ;first component of sending app. - S HLN("ECH")=$$P^HLTPCK2(.HLJ,2),HLN("SAN")=$P($$P^HLTPCK2(.HLJ,3),$E(HLN("ECH"))) - ;msg type, msg. id, commit ack, and app. ack parameter - S HLN("TYPE")=$$P^HLTPCK2(.HLJ,1),HLN("MID")=$$P^HLTPCK2(.HLJ,10),HLN("ACAT")=$$P^HLTPCK2(.HLJ,15),HLN("APAT")=$$P^HLTPCK2(.HLJ,16) - ;MSA segment, message is a response, can't have an a. ack. - S Z=$$MSA^HLTP3(+^HLMA(HLMSG,0)) I Z]"" S:HLN("ACAT")="" HLN("ACAT")="NE" S HLN("APAT")="NE" - ;for batch/file with commit ack, reset c. ack and a. ack variables - I "BHS,FHS"[HLN("TYPE") S Z=$E(HLJ(1,0),5),X=$$P^HLTPCK2(.HLJ,9),HLN("ACAT")=$P(X,Z,5),HLN("APAT")=$P(X,Z,6),HLN("MID")=$$P^HLTPCK2(.HLJ,11) - ;get event protocol - S HLN("EID")=+$P(^HLMA(HLMSG,0),U,8),X=$G(^ORD(101,HLN("EID"),770)) - ;set link counter to msg sent - D LLCNT^HLCSTCP(HLDP,4) - ;commit and app. ack is never, update status to complete and hang UNI-DIRECTIONAL WAIT - I HLN("ACAT")="NE",HLN("APAT")="NE" D Q - .D DONE(3) - .; - .; - .H $G(HLDWAIT) - ; - ;do structure is to stack error - D - . N $ETRAP,$ESTACK S $ETRAP="D RDERR^HLCSTCP2" - . ;HL*1.6*87: Read acknowledgement. - . ;Loop to re-read from buffer when receiving incorrect ack. - . F D Q:'+$G(HLREREAD) - .. S HLREREAD=1 - .. ;override ack timeout - .. I $G(HLN("ACKTIME")) N HLDBACK S HLDBACK=HLN("ACKTIME") - .. ;check for response, quit if no-response, msg will be resent - .. ;HLRESP=ien 773^ien 772 for response message - .. S HLRESP=$$READ^HLCSTCP1() - .. ;if no response, decrement counter and quit - .. I 'HLRESP D Q - ...D LLCNT^HLCSTCP(HLDP,4,1) - ...S HLREREAD="0^No Response" - ...;check if the port needs to be closed and re-opened before the next re-transmission attempt - ...I $G(HLDRETRY("CLOSE")) D CLOSE^%ZISTCP K HLPORT - .. ;X 0=re-read msg, 1=commit ack, 3=app ack success, 4=error - .. S X=$$RSP^HLTP31(HLRESP,.HLN) - .. ;X=0, re-read msg. Incorrect ack (bad MSH,MSA,msg id,or sending app) - .. Q:'X - .. ;commit ack - done - .. I X=1 D S HLREREAD="0^Commit Ack" Q - ... ;don't need app. ack, set status to complete - ... I "NE"[HLN("APAT") D Q - ....D DONE(3) - ....; - ... ;response is deferred, set status to awaiting ack - ... D DONE(2) - ...; - .. ;Error, HLRESLT=error number^error message from HLTP3 - .. I X=4 D Q - ... D DONE(4,+$G(HLRESLT),$P($G(HLRESLT),U,2)) - ...; - ... S HLREREAD="0^Error" - .. ;app ack was successful - .. D DONE(3) S HLREREAD="0^App Ack" - ..; - Q - ; -DCSEND ;direct connect - ; Set up error trap - N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP2" - ; patch HL*1.6*122 - N HLTMBUF - ;override ack timeout - I $G(HLP("ACKTIME")) N HLDBACK S HLDBACK=HLP("ACKTIME") - I $$WRITE(HLMSG)<0 D:$G(HLERROR)]"" Q ;HL*1.6*77 - . D STATUS^HLTF0(HLMSG,4,$P(HLERROR,"^"),$P(HLERROR,"^",2),1) ;HL*1.6*77 - . D LLCNT^HLCSTCP(HLDP,3,1) - D LLCNT^HLCSTCP(HLDP,4) - ;do structure is to stack error - D - . N $ETRAP,$ESTACK S $ETRAP="D RDERR^HLCSTCP2" - . ;HLRESP=ien 773^ien 772 for response message - . S HLRESP=$$READ^HLCSTCP1() - ; - D DONE(3):$G(HLRESP),DONE(4,108,$S($G(HLERROR)]"":$P(HLERROR,"^",2),1:"No response")):'$G(HLRESP) - I $G(HLERROR)']"" D - .D MON^HLCSTCP("Idle") - .I '$G(HLRESP) S HLERROR="108^No response" - ;Close port - I $D(HLPORT) D CLOSE^%ZISTCP K HLPORT - Q - ; -DONE(ST,ERR,ERRMSG) ;set status to complete - ;ST=status, ERR=error ien, ERRMSG=error msg - D STATUS^HLTF0(HLMSG,ST,$G(ERR),$G(ERRMSG),1) - ; - D DEQUE^HLCSREP(HLDP,"O",HLMSG) - ; - ;check for more msg. - I $G(HLPRIO)'="I" S HLMSG=+$O(^HLMA("AC","O",HLDP,0)),HLRETRY=0 - Q - ; -CHKMSG(HLI) ;check status of message and update if not cancelled - ;input: HLI=new status, HLMSG=ien of msg in 773 - ;returns 1=msg was updated, 0=msg has been canceled - N X - ; - ; New HL*1.6*77 code starting here... - I '$D(^HLMA(HLMSG,"P")) D Q 0 - . S HLERROR="2^Missing status field" - . D STATUS^HLTF0(HLMSG,4,$P(HLERROR,U),$P(HLERROR,U,2),1) - .; - . D DEQUE^HLCSREP(HLDP,"O",HLMSG) - ; - ; End of HL*1.6*77 - ; - ;get status, quit if msg was cancelled - ; - S X=+^HLMA(HLMSG,"P") Q:X=3 0 - ; - ;update status if it is different - I $G(HLI),HLI'=X D STATUS^HLTF0(HLMSG,HLI) - ; - Q 1 - ; -WRITE(HLDA) ; write message in HL7 format - ; HLDA - ien of message in 773 - ; - start block $C(11) - ; - end block $C(28) - ; - record separator $C(13) - ;Output(s): 1 - Successful - ; -1 - Unsuccessful - ; - N HLDA2,HLAR,HLI,LINENO,X,CRCOUNT - S CRCOUNT=0 - ;set error trap, used when called from HLTP3 - ; - ; New HL*1.6*77 code starts here... - N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP2" - I $G(^HLMA(HLDA,0))'>0 D Q -1 - . S HLERROR="2^Message Text pointer missing" - S HLDA2=+$G(^HLMA(HLDA,0)) - ; End of HL*1.6*77 modifications... - ; - Q:'$G(^HLMA(HLDA,0)) -1 ;HL*1.6*77 - ; header is in ^HLMA(, message is in ^HL(772, - S LINENO=1,HLI=0,HLAR="^HLMA(HLDA,""MSH"")" - U IO - D W $C(13) S HLAR="^HL(772,HLDA2,""IN"")",HLI=0 D - . F S HLI=$O(@HLAR@(HLI)) Q:'HLI S X=$G(^(HLI,0)) D - .. ;first line, need start block char. - .. S:LINENO=1 X=$C(11)_X - .. ; HL*1.6*122 - .. ; I X]"" W X,! - .. N LENGTH - .. S LENGTH=$L(X) - .. ; buffer should be limited to 512 - .. I LENGTH>512 D - ... N X1 - ... F Q:LENGTH<512 D - .... S X1=$E(X,1,512),X=$E(X,513,999999) - .... S LENGTH=$L(X) - .... ; patch HL*1.6*140 - .... ; W X1,@IOF - .... W X1,@HLTCPLNK("IOF") - .. ; - .. ; @HLTCPLNK("IOF") (! or #) for flush character - .. I X]"" W X,@HLTCPLNK("IOF") S CRCOUNT=0 - .. ;send CR - .. I X="" W $C(13) S CRCOUNT=CRCOUNT+1 - .. ; prevent from maxstring error - .. I CRCOUNT>200 W @HLTCPLNK("IOF") S CRCOUNT=0 - .. S LINENO=LINENO+1 - ; Sends end block for this message - S X=$C(28)_$C(13) - ; U IO W X,! - U IO W X,@HLTCPLNK("IOF") - ;switch to null device - I $G(IO(0))'="",$G(IO(0))'=IO U IO(0) - Q 1 - ; -OPEN() ; -- Open TCP/IP device (Client) - ;HLPORT=port, defined only if port is open - ;HLPORTA=number of attempted opens - I $D(HLPORT) S IO=HLPORT D Q 1 - . U IO - . I HLOS["OpenM" X "U IO:(::""-M"")" ;use packet mode on Cache' - N HLDOM,HLI,HLIP,HLPORTA - G OPENA^HLCSTCP3 - ; -RDERR D RDERR^HLCSTCP4 Q -ERROR D ERROR^HLCSTCP4 Q - ; -CC(X) ;cleanup and close - D MON^HLCSTCP(X) - I $D(HLPORT) D CLOSE^%ZISTCP K HLPORT - ; patch HL*1.6*140 - ; H 2 - H 1 - Q +HLCSTCP2 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;09/13/2006 + ;;1.6;HEALTH LEVEL SEVEN;**19,43,49,57,63,64,66,67,76,77,87,109,133**;Oct 13,1995;Build 13 + ;Per VHA Directive 2004-038, this routine should not be modified. + ;Sender + ;Request connection, send outbound message(s) delimited by MLLP + ;Input : HLDP=Logical Link to use + ; Set up error trap + N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP2" + N HLMSG,HLPORT,HLRETRY,HLRETMG,HLTCPO,POP + ;HLRETRY=number of retranmission for this link,HLRETMG=alert sent + S HLTCPO=HLDP,HLMSG="",(HLRETRY,HLRETMG)=0 + ; + ;set IO(0) to the null device + S IO(0)=$S(^%ZOSF("OS")["OpenM":$S($$OS^%ZOSV()["VMS":"_NLA0:",$$OS^%ZOSV()["UNIX":"/dev/null",1:$P),^%ZOSF("OS")["DSM":"_NLA0:",1:$P) + O IO(0) U IO(0) + ; + ;persistent conection, open connection first, HLPORT=open port + I $G(HLTCPLNK)["Y" F Q:$$OPEN G EXIT:$$STOP^HLCSTCP H 1 + F D QUE Q:$$STOP^HLCSTCP D:'HLMSG Q:$G(HLCSOUT) + . ;no messages to send + . D MON^HLCSTCP("Idle") H 3 + . ;persistent connection, no retention + . Q:$G(HLTCPLNK)["Y" + . D MON^HLCSTCP("Retention") + . N % I 0 + . ;if message comes in or ask to stop + . F %=1:1:HLTCPRET H 1 I $$STOP^HLCSTCP!$O(^HLMA("AC","O",HLDP,0)) Q + . E S HLCSOUT=2 Q + . Q:$$STOP^HLCSTCP + . D MON^HLCSTCP("Idle") + ;Close port + I $D(HLPORT) D CLOSE^%ZISTCP K HLPORT +EXIT Q + ; +QUE ; -- Check "OUT" queue for processing IF there is a message do it + ; and then check the link if it open or not + N HL,HLN,HLARR,HLHDR,HLI,HLJ,HLMSA,HLRESP,HLRESLT,HLRETRM,HLTCP,HLTCPI,X,Z,HLREREAD + D MON^HLCSTCP("Check out") + ;HLMSG=next msg, set at tag DONE + I 'HLMSG S HLMSG=+$O(^HLMA("AC","O",HLDP,0)),HLRETRY=0 Q:'HLMSG + ; + ;**109** + ;Temporarily lock ^HLMA to flush buffer and ensure edits are complete + ;L +^HLMA(HLMSG):1 I '$T S HLMSG=0 Q + ;L -^HLMA(HLMSG) + ; + S HLI=+$G(^HLMA(HLMSG,0)),HLJ=$O(^("MSH",0)),HLTCP="" + ;don't have message text or MSH, kill x-ref and decrement 'to send' + I 'HLI!'HLJ K ^HLMA("AC","O",HLDP,HLMSG) D LLCNT^HLCSTCP(HLDP,3,1) S HLMSG=0 Q + ;update msg status to 'being transmitted'; if cancelled decrement link and quit + I '$$CHKMSG(1.5) D LLCNT^HLCSTCP(HLDP,3,1) S HLMSG=0 Q + ;number of retransmissions for message + S HLRETRM=+$P(^HLMA(HLMSG,"P"),U,5) + ;retries exceeded, HLRETRA:action i=ignore, r=restart, s=shutdown + ;quit if restart or shutdown, link is going down + I HLRETRY>HLDRETR D Q:"I"'[HLRETRA + . D MON^HLCSTCP("Error") + . ;only 1 alert per link up time, don't send if restart + . D:'HLRETMG&(HLRETRA'="R") + .. ;send alert + .. N XQA,XQAMSG,XQAOPT,XQAROU,XQAID,Z + .. ;get mailgroup from file 869.3 + .. S HLRETMG=1,Z=$P($$PARAM^HLCS2,U,8) Q:Z="" + .. S XQA("G."_Z)="",XQAMSG=$$HTE^XLFDT($H,2)_" HL7 LL "_$P(^HLCS(870,HLDP,0),U)_" exceeded retries. LL will "_$S(HLRETRA="S":"shutdown.",HLRETRA="R":"restart.",1:"keep trying.") + .. D SETUP^XQALERT + . ;quit if action is ignore + . Q:"I"[HLRETRA + . ;this will shutdown this link + . S HLCSOUT=1 + . ;action is shutdown, set shutdown flag so LM won't restart + . S:HLRETRA="S" $P(^HLCS(870,HLDP,0),U,15)=1 + . D STATUS^HLTF0(HLMSG,4,103,"LLP Exceeded Retry Param") + I '$$OPEN Q + D MON^HLCSTCP("Send") + ; -- data passed in global array, success=1 + I $$WRITE(HLMSG)<0 Q + S (HLTCP,HLTCPI)=HLMSG,HLRETRY=HLRETRY+1,HLRETRM=HLRETRM+1 + ;update status to awaiting response, decrement link if cancelled + I '$$CHKMSG(1.7) D LLCNT^HLCSTCP(HLDP,3,1) S HLMSG=0 Q + ;set transmission count, get ACKTIMEOUT override + S $P(^HLMA(HLMSG,"P"),U,5)=HLRETRM I $P(^("P"),U,7) S HLN("ACKTIME")=+$P(^("P"),U,7) + ;get header of message just sent + K HLJ M HLJ=^HLMA(HLMSG,"MSH") + ;first component of sending app. + S HLN("ECH")=$$P^HLTPCK2(.HLJ,2),HLN("SAN")=$P($$P^HLTPCK2(.HLJ,3),$E(HLN("ECH"))) + ;msg type, msg. id, commit ack, and app. ack parameter + S HLN("TYPE")=$$P^HLTPCK2(.HLJ,1),HLN("MID")=$$P^HLTPCK2(.HLJ,10),HLN("ACAT")=$$P^HLTPCK2(.HLJ,15),HLN("APAT")=$$P^HLTPCK2(.HLJ,16) + ;MSA segment, message is a response, can't have an a. ack. + S Z=$$MSA^HLTP3(+^HLMA(HLMSG,0)) I Z]"" S:HLN("ACAT")="" HLN("ACAT")="NE" S HLN("APAT")="NE" + ;for batch/file with commit ack, reset c. ack and a. ack variables + I "BHS,FHS"[HLN("TYPE") S Z=$E(HLJ(1,0),5),X=$$P^HLTPCK2(.HLJ,9),HLN("ACAT")=$P(X,Z,5),HLN("APAT")=$P(X,Z,6),HLN("MID")=$$P^HLTPCK2(.HLJ,11) + ;get event protocol + S HLN("EID")=+$P(^HLMA(HLMSG,0),U,8),X=$G(^ORD(101,HLN("EID"),770)) + ;set link counter to msg sent + D LLCNT^HLCSTCP(HLDP,4) + ;commit and app. ack is never, update status to complete and hang UNI-DIRECTIONAL WAIT + I HLN("ACAT")="NE",HLN("APAT")="NE" D Q + .D DONE(3) + .; + .; + .H $G(HLDWAIT) + ; + ;do structure is to stack error + D + . N $ETRAP,$ESTACK S $ETRAP="D RDERR^HLCSTCP2" + . ;HL*1.6*87: Read acknowledgement. + . ;Loop to re-read from buffer when receiving incorrect ack. + . F D Q:'+$G(HLREREAD) + .. S HLREREAD=1 + .. ;override ack timeout + .. I $G(HLN("ACKTIME")) N HLDBACK S HLDBACK=HLN("ACKTIME") + .. ;check for response, quit if no-response, msg will be resent + .. ;HLRESP=ien 773^ien 772 for response message + .. S HLRESP=$$READ^HLCSTCP1() + .. ;if no response, decrement counter and quit + .. I 'HLRESP D Q + ...D LLCNT^HLCSTCP(HLDP,4,1) + ...S HLREREAD="0^No Response" + ...;check if the port needs to be closed and re-opened before the next re-transmission attempt + ...I $G(HLDRETRY("CLOSE")) D CLOSE^%ZISTCP K HLPORT + .. ;X 0=re-read msg, 1=commit ack, 3=app ack success, 4=error + .. S X=$$RSP^HLTP31(HLRESP,.HLN) + .. ;X=0, re-read msg. Incorrect ack (bad MSH,MSA,msg id,or sending app) + .. Q:'X + .. ;commit ack - done + .. I X=1 D S HLREREAD="0^Commit Ack" Q + ... ;don't need app. ack, set status to complete + ... I "NE"[HLN("APAT") D Q + ....D DONE(3) + ....; + ... ;response is deferred, set status to awaiting ack + ... D DONE(2) + ...; + .. ;Error, HLRESLT=error number^error message from HLTP3 + .. I X=4 D Q + ... D DONE(4,+$G(HLRESLT),$P($G(HLRESLT),U,2)) + ...; + ... S HLREREAD="0^Error" + .. ;app ack was successful + .. D DONE(3) S HLREREAD="0^App Ack" + ..; + Q + ; +DCSEND ;direct connect + ; Set up error trap + N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP2" + ;override ack timeout + I $G(HLP("ACKTIME")) N HLDBACK S HLDBACK=HLP("ACKTIME") + I $$WRITE(HLMSG)<0 D:$G(HLERROR)]"" Q ;HL*1.6*77 + . D STATUS^HLTF0(HLMSG,4,$P(HLERROR,"^"),$P(HLERROR,"^",2),1) ;HL*1.6*77 + . D LLCNT^HLCSTCP(HLDP,3,1) + D LLCNT^HLCSTCP(HLDP,4) + ;do structure is to stack error + D + . N $ETRAP,$ESTACK S $ETRAP="D RDERR^HLCSTCP2" + . ;HLRESP=ien 773^ien 772 for response message + . S HLRESP=$$READ^HLCSTCP1() + ; + D DONE(3):$G(HLRESP),DONE(4,108,$S($G(HLERROR)]"":$P(HLERROR,"^",2),1:"No response")):'$G(HLRESP) + I $G(HLERROR)']"" D + .D MON^HLCSTCP("Idle") + .I '$G(HLRESP) S HLERROR="108^No response" + ;Close port + I $D(HLPORT) D CLOSE^%ZISTCP K HLPORT + Q + ; +DONE(ST,ERR,ERRMSG) ;set status to complete + ;ST=status, ERR=error ien, ERRMSG=error msg + D STATUS^HLTF0(HLMSG,ST,$G(ERR),$G(ERRMSG),1) + ; + ;**109** + D DEQUE^HLCSREP(HLDP,"O",HLMSG) + ; + ;check for more msg. + I $G(HLPRIO)'="I" S HLMSG=+$O(^HLMA("AC","O",HLDP,0)),HLRETRY=0 + Q + ; +CHKMSG(HLI) ;check status of message and update if not cancelled + ;input: HLI=new status, HLMSG=ien of msg in 773 + ;returns 1=msg was updated, 0=msg has been canceled + N X + ; + ;**109** + ;F L +^HLMA(HLMSG,"P"):1 Q:$T H 1 + ; + ; + ; New HL*1.6*77 code starting here... + I '$D(^HLMA(HLMSG,"P")) D Q 0 + . S HLERROR="2^Missing status field" + . D STATUS^HLTF0(HLMSG,4,$P(HLERROR,U),$P(HLERROR,U,2),1) + .; + .;**109** + . D DEQUE^HLCSREP(HLDP,"O",HLMSG) + .;L -^HLMA(HLMSG,"P") + ;**end 109** + ; + ; End of HL*1.6*77 modifications + ; + ;get status, quit if msg was cancelled + ; + ;**109** + ;S X=+^HLMA(HLMSG,"P") I X=3 L -^HLMA(HLMSG,"P") Q 0 + S X=+^HLMA(HLMSG,"P") Q:X=3 0 + ; + ;update status if it is different + I $G(HLI),HLI'=X D STATUS^HLTF0(HLMSG,HLI) + ; + ;**109** + ;L -^HLMA(HLMSG,"P") + ; + Q 1 + ; +WRITE(HLDA) ; write message in HL7 format + ; HLDA - ien of message in 773 + ; - start block $C(11) + ; - end block $C(28) + ; - record separator $C(13) + ;Output(s): 1 - Successful + ; -1 - Unsuccessful + ; + N HLDA2,HLAR,HLI,LINENO,X + ;set error trap, used when called from HLTP3 + ; + ; New HL*1.6*77 code starts here... + N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP2" + I $G(^HLMA(HLDA,0))'>0 D Q -1 + . S HLERROR="2^Message Text pointer missing" + S HLDA2=+$G(^HLMA(HLDA,0)) + ; End of HL*1.6*77 modifications... + ; + Q:'$G(^HLMA(HLDA,0)) -1 ;HL*1.6*77 + ; header is in ^HLMA(, message is in ^HL(772, + S LINENO=1,HLI=0,HLAR="^HLMA(HLDA,""MSH"")" + U IO + D W $C(13) S HLAR="^HL(772,HLDA2,""IN"")",HLI=0 D + . F S HLI=$O(@HLAR@(HLI)) Q:'HLI S X=$G(^(HLI,0)) D + .. ;first line, need start block char. + .. S:LINENO=1 X=$C(11)_X + .. I X]"" W X,! + .. ;send CR for blank lines + .. I X="" W $C(13) + .. S LINENO=LINENO+1 + ; Sends end block for this message + S X=$C(28)_$C(13) + U IO W X,! + I $G(IO(0))'="",$G(IO(0))'=IO U IO(0) ;switch to null device if opened to prevent 'leakage' + Q 1 + ; +OPEN() ; -- Open TCP/IP device (Client) + ;HLPORT=port, defined only if port is open + ;HLPORTA=number of attempted opens + I $D(HLPORT) S IO=HLPORT D Q 1 + . U IO + . I HLOS["OpenM" X "U IO:(::""-M"")" ;use packet mode on Cache' + N HLDOM,HLI,HLIP,HLPORTA + G OPENA^HLCSTCP3 + ; +RDERR D RDERR^HLCSTCP4 Q ; Exceeded 10,000 bytes, so split on 12/2/03-LJA +ERROR D ERROR^HLCSTCP4 Q ; Exceeded 10,000 bytes, so split on 12/2/03-LJA + ; +CC(X) ;cleanup and close + D MON^HLCSTCP(X) + I $D(HLPORT) D CLOSE^%ZISTCP K HLPORT + H 2 + Q diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP3.m b/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP3.m index 79201192..4a2c1949 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP3.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP3.m @@ -1,118 +1,62 @@ -HLCSTCP3 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ; 09/13/2006 15:36 - ;;1.6;HEALTH LEVEL SEVEN;**76,77,133,122**;OCT 13, 1995;Build 14 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; -OPENA ; - ; called from $$OPEN^HLCSTCP2 and this sub-routine OPENA - ; - I $G(HLMSG),$D(^HLMA(HLMSG,"P")) S HLPORTA=+$P(^("P"),U,6) - S POP=1 - ; - ; patch HL*1.6*122 start - ; variable HLDRETR=re-transmit attemps (#870,200.02) - ; variable HLTCPLNK("TIMEOUT")=timeout for 3rd parameter of CALL^%ZISTCP() - ; defined in HLCSTCP routine - ; - I '$G(HLDRETR("COUNT")) S HLDRETR("COUNT")=1 - I '$G(HLTCPLNK("TIMEOUT")) S HLTCPLNK("TIMEOUT")=5 - S HLDRETR("COUNT-2")=HLDRETR("COUNT")+HLDRETR - ; patch 133 - ; I $G(HLDIRECT("OPEN TIMEOUT")) D - ; .S HLI=1 - ; .D CALL^%ZISTCP(HLTCPADD,HLTCPORT,HLDIRECT("OPEN TIMEOUT")) - ; E D - ; .F HLI=1:1:HLDRETR D CALL^%ZISTCP(HLTCPADD,HLTCPORT) Q:'POP - I $G(HLDIRECT("OPEN TIMEOUT")) D - . D MON^HLCSTCP("Open") - . D CALL^%ZISTCP(HLTCPADD,HLTCPORT,HLDIRECT("OPEN TIMEOUT")) - . ; give site one more chance to override the application setup - . I $G(POP),(HLTCPLNK("TIMEOUT")>HLDIRECT("OPEN TIMEOUT")) D - .. D CALL^%ZISTCP(HLTCPADD,HLTCPORT,HLTCPLNK("TIMEOUT")) - E D - . N COUNT - . ; try to connect HLDRETR times - . F HLDRETR("COUNT")=HLDRETR("COUNT"):1:HLDRETR("COUNT-2") D Q:('POP)!($$STOP^HLCSTCP) - .. D MON^HLCSTCP("Open") - .. ; D CALL^%ZISTCP(HLTCPADD,HLTCPORT) - .. D CALL^%ZISTCP(HLTCPADD,HLTCPORT,HLTCPLNK("TIMEOUT")) - .. ;open error - .. I POP D - ... D CC^HLCSTCP2("Openfail") - ... H $S(HLDRETR("COUNT")=1:0,HLDRETR("COUNT")<10:1,1:8) - ... I '$D(^XTMP("HL7-Openfail",$J)) D - .... S ^XTMP("HL7-Openfail",0)=$$FMADD^XLFDT($$NOW^XLFDT,3)_"^"_$$NOW^XLFDT - .... S ^XTMP("HL7-Openfail",$J,"COUNT","FIRST")=HLDRETR("COUNT")_"^"_$$NOW^XLFDT - ... S COUNT=$P($G(^XTMP("HL7-Openfail",$J,"COUNT","LAST")),"^")+1 - ... S ^XTMP("HL7-Openfail",$J,"COUNT","LAST")=COUNT_"^"_$$NOW^XLFDT - ; - ;set # of opens back in msg - ; I $G(HLMSG),$D(^HLMA(HLMSG,"P")) S $P(^("P"),U,6)=HLPORTA+HLI - I $G(HLMSG),$D(^HLMA(HLMSG,"P")) S $P(^("P"),U,6)=HLDRETR("COUNT") - ; patch HL*1.6*122 end - ; - ;device open - I 'POP S HLPORT=IO D Q $S($G(HLERROR)]"":0,1:1) - . N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP2" ;HL*1.6*77 - . ;if address came from DNS, set back into LL - . I $D(HLIP) S $P(^HLCS(870,HLDP,400),U)=HLTCPADD - . ; write and read to check if still open - . Q:HLOS'["OpenM" X "U IO:(::""-M"")" ; must be Cache/NT + use packet mode - . Q:$P(^HLCS(870,HLDP,400),U,7)'="Y" ; must want to SAY HELO - . U IO W "HELO "_$$KSP^XUPARAM("WHERE"),! R X:1 - ;openfail-try DNS lookup - ; - ; patch HL*1.6*122 start - ;I '$D(HLDOM) S HLDOM=+$P(^HLCS(870,HLDP,0),U,7),HLDOM=$P($G(^DIC(4.2,HLDOM,0)),U) D:HLDOM]"" DNS - I '$D(HLDOM) D - . S HLDOM=+$P(^HLCS(870,HLDP,0),U,7),HLDOM=$P($G(^DIC(4.2,HLDOM,0)),U) - . S HLDOM("DNS")=$P($G(^HLCS(870,+$G(HLDP),0)),"^",8) - . D:HLDOM]""!($L(HLDOM("DNS"),".")>2) DNS - ; - Q:$$STOP^HLCSTCP 0 - ;HLIP=ip add. from DNS call, get first one and try open again - I $D(HLIP) S HLTCPADD=$P(HLIP,","),HLIP=$P(HLIP,",",2,99) G:HLTCPADD OPENA - ; open error - ;cleanup and close - ; patch 133 - I $G(HLDIRECT("OPEN TIMEOUT")) D - . D MON^HLCSTCP("Openfail") - . I $D(HLPORT) D CLOSE^%ZISTCP K HLPORT - E D - . D CC^HLCSTCP2("Openfail") - Q 0 - ; patch HL*1.6*122 end - ; - ; - ;following code was removed, site's complained of to many alerts - ;couldn't open, send 1 alert - ;I '$G(HLPORTA) D - ;. ;send alert - ;. N XQA,XQAMSG,XQAOPT,XQAROU,XQAID,Z - ;. ;get mailgroup from file 869.3 - ;. S Z=$P($$PARAM^HLCS2,U,8),HLPORTA="" Q:Z="" - ;. S XQA("G."_Z)="",XQAMSG=$$HTE^XLFDT($H,2)_" Logical Link "_$P(^HLCS(870,HLDP,0),U)_" exceeded Open Retries." - ;. D SETUP^XQALERT - ;open error - ;D CC("Openfail") H 3 - ;Q 0 - ; - ; -DNS ;VA domains must have "med" inserted. - ;All domains must use port 5000 and are prepended with "HL7" - ;non-VA DNS lookups will succeed if site uses port 5000 and - ;configure their local DNS with "HL7.yourdomain.com" and entries - ;are created in the logical link file and domain file. - D MON^HLCSTCP("DNS Lkup") - I HLDOM["VA.GOV"&(HLDOM'[".MED.") S HLDOM=$P(HLDOM,".VA.GOV")_".MED.VA.GOV" - I HLTCPORT=5000 S HLDOM="HL7."_HLDOM - I HLTCPORT=5500 S HLDOM="MPI."_HLDOM - ; - ; patch HL*1.6*122 start - I $L($G(HLDOM("DNS")),".")>2 D - . S HLDOM=HLDOM("DNS") - ; patch HL*1.6*122 end - ; - S HLIP=$$ADDRESS^XLFNSLK(HLDOM) - K:HLIP="" HLIP - Q - ; +HLCSTCP3 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;09/13/2006 + ;;1.6;HEALTH LEVEL SEVEN;**76,77,133**;OCT 13, 1995;Build 13 + ;Per VHA Directive 2004-038, this routine should not be modified. + ; +OPENA I $G(HLMSG),$D(^HLMA(HLMSG,"P")) S HLPORTA=+$P(^("P"),U,6) + D MON^HLCSTCP("Open") + S POP=1 + I $G(HLDIRECT("OPEN TIMEOUT")) D + .S HLI=1 + .D CALL^%ZISTCP(HLTCPADD,HLTCPORT,HLDIRECT("OPEN TIMEOUT")) + E D + .F HLI=1:1:HLDRETR D CALL^%ZISTCP(HLTCPADD,HLTCPORT) Q:'POP + ;set # of opens back in msg + I $G(HLMSG),$D(^HLMA(HLMSG,"P")) S $P(^("P"),U,6)=HLPORTA+HLI + ;device open + I 'POP S HLPORT=IO D Q $S($G(HLERROR)]"":0,1:1) + . N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP2" ;HL*1.6*77 + . ;if address came from DNS, set back into LL + . I $D(HLIP) S $P(^HLCS(870,HLDP,400),U)=HLTCPADD + . ; write and read to check if still open + . Q:HLOS'["OpenM" X "U IO:(::""-M"")" ; must be Cache/NT + use packet mode + . Q:$P(^HLCS(870,HLDP,400),U,7)'="Y" ; must want to SAY HELO + . U IO W "HELO "_$$KSP^XUPARAM("WHERE"),! R X:1 + ;openfail-try DNS lookup + I '$D(HLDOM) S HLDOM=+$P(^HLCS(870,HLDP,0),U,7),HLDOM=$P($G(^DIC(4.2,HLDOM,0)),U) D:HLDOM]"" DNS + ;HLIP=ip add. from DNS call, get first one and try open again + I $D(HLIP) S HLTCPADD=$P(HLIP,","),HLIP=$P(HLIP,",",2,99) G:HLTCPADD OPENA + ;open error + I $G(HLDIRECT("OPEN TIMEOUT")) D + .D MON^HLCSTCP("Openfail") + .I $D(HLPORT) D CLOSE^%ZISTCP K HLPORT + E D + .D CC^HLCSTCP2("Openfail") H 3 + Q 0 + ; + ;following code was removed, site's complained of to many alerts + ;couldn't open, send 1 alert + ;I '$G(HLPORTA) D + ;. ;send alert + ;. N XQA,XQAMSG,XQAOPT,XQAROU,XQAID,Z + ;. ;get mailgroup from file 869.3 + ;. S Z=$P($$PARAM^HLCS2,U,8),HLPORTA="" Q:Z="" + ;. S XQA("G."_Z)="",XQAMSG=$$HTE^XLFDT($H,2)_" Logical Link "_$P(^HLCS(870,HLDP,0),U)_" exceeded Open Retries." + ;. D SETUP^XQALERT + ;open error + ;D CC("Openfail") H 3 + ;Q 0 + ; + ; +DNS ;VA domains must have "med" inserted. + ;All domains must use port 5000 and are prepended with "HL7" + ;non-VA DNS lookups will succeed if site uses port 5000 and + ;configure their local DNS with "HL7.yourdomain.com" and entries + ;are created in the logical link file and domain file. + D MON^HLCSTCP("DNS Lkup") + I HLDOM["VA.GOV"&(HLDOM'[".MED.") S HLDOM=$P(HLDOM,".VA.GOV")_".MED.VA.GOV" + I HLTCPORT=5000 S HLDOM="HL7."_HLDOM + I HLTCPORT=5500 S HLDOM="MPI."_HLDOM + S HLIP=$$ADDRESS^XLFNSLK(HLDOM) + K:HLIP="" HLIP + Q + ; diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP4.m b/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP4.m index 113065e3..8868ded8 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP4.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP4.m @@ -1,248 +1,117 @@ -HLCSTCP4 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;04/16/08 14:20 - ;;1.6;HEALTH LEVEL SEVEN;**109,122,140**;Oct 13,1995;Build 5 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; - Q - ; RDERR & ERROR moved from HLCSTCP2 on 12/2/2003 - LJA - ; -RDERR ; Error during read process, decrement counter - D LLCNT^HLCSTCP(HLDP,4,1) -ERROR ; Error trap - ; OPEN ERROR-retry. - ; WRITE ERROR (SERVER DISCONNECT)-close channel, retry - ; - ;**109** - ;I $G(HLMSG) L -^HLMA(HLMSG) - ; - ; patch HL*1.6*122 start - N STOP - S STOP=0 - I $G(HLDP) S STOP=$$STOP^HLCSTCP - ; patch HL*1.6*140 - S $ETRAP="D HALT^ZU" ;RWF - S HLTCP("$ZA\8192#2")="" - I (^%ZOSF("OS")["OpenM") D - . S HLTCP("$ZA")=$ZA - . ; For TCP devices $ZA\8192#2: the device is currently in the - . ; Connected state talking to a remote host. - . S HLTCP("$ZA\8192#2")=$ZA\8192#2 - ; - S HLTCPERR("ERR-$ZE")=$$EC^%ZOSV - ; I $$EC^%ZOSV["OPENERR"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D CC^HLCSTCP2("Op-err") S:$G(HLPRIO)="I" HLERROR="15^Open Related Error" D UNWIND^%ZTER Q - I $$EC^%ZOSV["OPENERR"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D G:STOP H2^XUSCLEAN Q - . D CC^HLCSTCP2("Op-err") - . S:$G(HLPRIO)="I" HLERROR="15^Open Related Error" - . I STOP D Q - .. D CC^HLCSTCP2("Shutdown: (with 'Op-err')") - . I 'STOP D UNWIND^%ZTER - ; patch HL*1.6*140 start - ; I $$EC^%ZOSV["WRITE" D G:STOP!(HLTCP("$ZA\8192#2")=0) H2^XUSCLEAN Q - I $$EC^%ZOSV["WRITE" D G:STOP!(HLTCP("$ZA\8192#2")) H2^XUSCLEAN Q - . ; S:$G(HLPRIO)="I" HLERROR="108^Write Error" - . I $G(HLPRIO)="I" D Q - .. S HLERROR="108^Write Error" - .. D CC^HLCSTCP2("Wr-err") - .. D UNWIND^%ZTER - . ; - . I STOP D Q - .. D ^%ZTER,CC^HLCSTCP2("Shutdown: (with 'Wr-err')") - . E D Q - .. I HLTCP("$ZA\8192#2") D ^%ZTER,CC^HLCSTCP2("Wr-err") Q - .. E D Q - ... D CC^HLCSTCP2("Halt (Wr): (Disconnected with 'Wr-err')") - ... D UNWIND^%ZTER - ; - ; I $$EC^%ZOSV["READ" D CC^HLCSTCP2("Rd-err") S:$G(HLPRIO)="I" HLERROR="108^Read Error" D UNWIND^%ZTER Q - ; I $$EC^%ZOSV["READ" D G:STOP!(HLTCP("$ZA\8192#2")=0) H2^XUSCLEAN Q - I $$EC^%ZOSV["READ" D G:STOP!(HLTCP("$ZA\8192#2")) H2^XUSCLEAN Q - . ; S:$G(HLPRIO)="I" HLERROR="108^Read Error" - . I $G(HLPRIO)="I" D Q - .. S HLERROR="108^Read Error" - .. D CC^HLCSTCP2("Rd-err") - .. D UNWIND^%ZTER - . ; - . I STOP D Q - .. D ^%ZTER,CC^HLCSTCP2("Shutdown: (with 'Rd-err')") - . E D Q - .. I HLTCP("$ZA\8192#2") D ^%ZTER,CC^HLCSTCP2("Rd-err") Q - .. E D Q - ... D CC^HLCSTCP2("Halt (Rd): (Disconnected with 'Rd-err')") - ... D UNWIND^%ZTER - ; - ; S HLCSOUT=1 D ^%ZTER,CC^HLCSTCP2("Error"),SDFLD^HLCSTCP - ; S:$G(HLPRIO)="I" HLERROR="9^Error" - D ^%ZTER - I $G(HLPRIO)="I" D Q - . S HLERROR="9^Error" - . D CC^HLCSTCP2("Error") - . D UNWIND^%ZTER - ; - I STOP D Q - . D CC^HLCSTCP2("Shutdown: (with 'Error')") - . D H2^XUSCLEAN - ; - D CC^HLCSTCP2("Error") - ; patch HL*1.6*122 end - D H2^XUSCLEAN - ; patch HL*1.6*140 end - Q - ; -PROXY ; set DUZ for application proxy user - ; - ; removed the execution: patch 122 TEST v2 - Q - ; - ;; S HLDUZ=+$$APFIND^XUSAP("HLSEVEN,APPLICATION PROXY") - ;; S DUZ=HLDUZ - ;; D DUZ^XUP(DUZ) - ;; Q - ; -HLDUZ ; compare DUZ and set DUZ to application proxy user - ; - ; removed the execution: patch 122 TEST v2 - Q - ; - ;; I '$G(HLDUZ) D PROXY - ; -HLDUZ2 ; compare DUZ and HLDUZ - I $G(DUZ)'=HLDUZ D - . S DUZ=HLDUZ - . D DUZ^XUP(DUZ) - Q - ; -CLEANVAR ; clean variables for server, called from HLCSTCP1 - ; - ; clean variables except Kernel related variables - ; protect variables defined in HLCSTCP - N HLDP - N HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS - N HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL,HLZRULE - ; - ; protect variables defined in LISTEN^HLCSTCP - ; N HLLSTN,HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT - ; N HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL - N HLLSTN - ; - ; protect variables defined in CACHEVMS^HLCSTCP and EN^HLCSTCP - N % - ; protect variables defined in this routine HLCSTCP1 - N $ETRAP,$ESTACK - N HLMIEN,HLASTMSG - N HLTMBUF - N HLDUZ,DUZ - ; Kernel variables for single listener - N ZISOS,ZRULE - ; - D KILL^XUSCLEAN - Q -MIEN ; sets HLIND1=ien in 773^ien in 772 for message - N HLMID,X - I HLIND1 D - . S:'$G(^HLMA(+HLIND1,0)) HLIND1=0 - . S:'$G(^HL(772,+$P(HLIND1,U,2),0)) HLIND1=0 - ;msg. id is 10th of MSH & 11th for BSH or FSH - S X=10+($E(HLMSG(1,0),1,3)'="MSH"),HLMID=$$PMSH(.HLMSG,X) - ;if HLIND1 is set, kill old message, use HLIND1 for new - ;message, it means we never got end block for 1st msg. - I HLIND1 D Q - . ;get pointer to 772, kill header - . ; - . ; patch HL*1.6*122: MPI-client/server - . F L +^HLMA(+HLIND1):10 Q:$T H 1 - . K ^HLMA(+HLIND1,"MSH") - . L -^HLMA(+HLIND1) - . ; - . I $D(^HL(772,+$P(HLIND1,U,2),"IN")) K ^("IN") - . S X=$$MAID^HLTF(+HLIND1,HLMID) - . D SAVE^HLCSTCP1(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")") - . S:$P(HLIND1,U,3) $P(HLIND1,U,3)="" - D TCP^HLTF(.HLMID,.X,.HLDT) - S HLBUFF("IEN773")=X - I 'X D Q - . ;error - record and reset array - . ;killing HLLSTN will allow MON^HLCSTCP to work with multi-server - . D CLEAN^HLCSTCP1 K HLLSTN - . ;error 100=LLP could not en-queue the message, reset array - . D MONITOR^HLCSDR2(100,19,HLDP),MON^HLCSTCP("ERROR") H 30 - ;HLIND1=ien in 773^ien in 772 - S HLIND1=X_U_+$G(^HLMA(X,0)) - S HLBUFF("HLIND1")=HLIND1 - ;save MSH into 773 - D SAVE^HLCSTCP1(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")") - Q - ; -PMSH(MSH,P) ;get piece P from MSH array (passed by ref.) - N FS,I,L,L1,L2,X,Y - S FS=$E(MSH(1,0),4),(L2,Y)=0,X="" - F I=1:1 S L1=$L($G(MSH(I,0)),FS),L=L1+Y-1 D Q:$L(X)!'$D(MSH(I,0)) - . S:L1=1 L=L+1 - . S:P'>L X=$P($G(MSH(I-1,0)),FS,P-L2)_$P($G(MSH(I,0)),FS,(P-Y)) - . S L2=Y,Y=L - Q X - ; -ERROR1 ; - ; moved from ERROR^HLCSTCP1 - ; Error trap for disconnect error and return back to the read loop. - ; patch HL*1.6*122 start - ; patch HL*1.6*140 - ; S $ETRAP="D HALT^ZU" ;RWF - S $ETRAP="H 1 D HALT^ZU" ;RWF - I (^%ZOSF("OS")["OpenM") D - . S HLTCP("$ZA")=$ZA - . ; For TCP devices $ZA\8192#2: the device is currently in the - . ; Connected state talking to a remote host. - . S HLTCP("$ZA\8192#2")=$ZA\8192#2 - . I HLTCP("$ZA\8192#2")=0 D - .. ; decrement counter of multi-listener - .. I $D(^HLCS(870,"E","M",+$G(HLDP))) D EXITM^HLCSTCP - .. ; process terminated - .. D H2^XUSCLEAN - ; patch HL*1.6*140 - ;S $ETRAP="D UNWIND^%ZTER" ;RWF - ; I $$EC^%ZOSV["READ"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D UNWIND^%ZTER Q - I ($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D Q - . ; if it is not a multi-listener - . I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Open-err") - . D UNWIND^%ZTER - I $$EC^%ZOSV["READ" D Q - . ; if it is not a multi-listener - . I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Rd-err") - . D UNWIND^%ZTER - ; - ; I $$EC^%ZOSV["WRITE" D CC("Wr-err") D UNWIND^%ZTER Q - I $$EC^%ZOSV["WRITE" D Q - . ; if it is not a multi-listener - . I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Wr-err") - . D UNWIND^%ZTER - ; - ; for GT.M - I $ECODE["UREAD" D Q - . ; if it is not a multi-listener - . I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Rd-err") - . D UNWIND^%ZTER - ; - ; S HLCSOUT=1 D ^%ZTER,CC("Error") - S HLCSOUT=1 - D ^%ZTER - ; if it is not a multi-listener - I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Error") - ; patch HL*1.6*122 end - ; - D UNWIND^%ZTER - Q - ; -CLRMCNTR ; - ; clear the counter to set as "0 server" for multi-listener - ; HL*1.6*122 start - Q:'$G(HLDP) - Q:'$D(^HLCS(870,"E","M",HLDP)) - S $P(^HLCS(870,HLDP,0),"^",4)="MS" - S $P(^HLCS(870,HLDP,0),U,5)="0 server" - Q - ; -CREATUSR ; - ; patch HL*1.6*122 TEST v2: DUZ code removed - ; create application proxy users for listeners and incoming filer - ;; N HLTEMP - ;; S HLTEMP=$$CREATE^XUSAP("HLSEVEN,APPLICATION PROXY","#") - Q +HLCSTCP4 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;11/03/2006 13:31 + ;;1.6;HEALTH LEVEL SEVEN;**109,122**;Oct 13,1995;Build 4 + ;Per VHA Directive 2004-038, this routine should not be modified. + ; + Q + ; RDERR & ERROR moved from HLCSTCP2 on 12/2/2003 - LJA + ; +RDERR ; Error during read process, decrement counter + D LLCNT^HLCSTCP(HLDP,4,1) +ERROR ; Error trap + ; OPEN ERROR-retry. + ; WRITE ERROR (SERVER DISCONNECT)-close channel, retry + ; + ;**109** + ;I $G(HLMSG) L -^HLMA(HLMSG) + ; + S $ETRAP="D UNWIND^%ZTER" + ; patch HL*1.6*122 + S HLTCPERR("$P")=$P + S HLTCPERR("ERR-$ZE")=$$EC^%ZOSV + ; I $$EC^%ZOSV["OPENERR"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D CC^HLCSTCP2("Op-err") S:$G(HLPRIO)="I" HLERROR="15^Open Related Error" D UNWIND^%ZTER Q + I $$EC^%ZOSV["OPENERR"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D Q + . D CC^HLCSTCP2("Op-err") + . S:$G(HLPRIO)="I" HLERROR="15^Open Related Error" + . D UNWIND^%ZTER + I $$EC^%ZOSV["WRITE" D Q ;HL*1.6*77 modifications start here + . D CC^HLCSTCP2("Wr-err") + . S:$G(HLPRIO)="I" HLERROR="108^Write Error" + . D UNWIND^%ZTER ;HL*1.6*77 modifications end here + ; I $$EC^%ZOSV["READ" D CC^HLCSTCP2("Rd-err") S:$G(HLPRIO)="I" HLERROR="108^Read Error" D UNWIND^%ZTER Q + I $$EC^%ZOSV["READ" D Q + . D CC^HLCSTCP2("Rd-err") + . S:$G(HLPRIO)="I" HLERROR="108^Read Error" + . D UNWIND^%ZTER + S HLCSOUT=1 D ^%ZTER,CC^HLCSTCP2("Error"),SDFLD^HLCSTCP + S:$G(HLPRIO)="I" HLERROR="9^Error" + D UNWIND^%ZTER + Q + ; +PROXY ; set DUZ for application proxy user + S HLDUZ=+$$APFIND^XUSAP("HLSEVEN,APPLICATION PROXY") + S DUZ=HLDUZ + D DUZ^XUP(DUZ) + Q + ; +HLDUZ ; compare DUZ and set DUZ to application proxy user + I '$G(HLDUZ) D PROXY + I $G(DUZ)'=HLDUZ D + . S DUZ=HLDUZ + . D DUZ^XUP(DUZ) + Q + ; +CLEANVAR ; clean variables for server, called from HLCSTCP1 + ; + ; clean variables except Kernel related variables + ; protect variables defined in HLCSTCP + N HLDP + N HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS + N HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL,HLZRULE + ; + ; protect variables defined in LISTEN^HLCSTCP + ; N HLLSTN,HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT + ; N HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL + N HLLSTN + ; + ; protect variables defined in CACHEVMS^HLCSTCP and EN^HLCSTCP + N % + ; protect variables defined in this routine HLCSTCP1 + N $ETRAP,$ESTACK + N HLMIEN,HLASTMSG + N HLTMBUF + N HLDUZ,DUZ + ; Kernel variables for single listener + N ZISOS,ZRULE + ; + D KILL^XUSCLEAN + Q +MIEN ; sets HLIND1=ien in 773^ien in 772 for message + N HLMID,X + I HLIND1 D + . S:'$G(^HLMA(+HLIND1,0)) HLIND1=0 + . S:'$G(^HL(772,+$P(HLIND1,U,2),0)) HLIND1=0 + ;msg. id is 10th of MSH & 11th for BSH or FSH + S X=10+($E(HLMSG(1,0),1,3)'="MSH"),HLMID=$$PMSH(.HLMSG,X) + ;if HLIND1 is set, kill old message, use HLIND1 for new + ;message, it means we never got end block for 1st msg. + I HLIND1 D Q + . ;get pointer to 772, kill header + . K ^HLMA(+HLIND1,"MSH") + . I $D(^HL(772,+$P(HLIND1,U,2),"IN")) K ^("IN") + . S X=$$MAID^HLTF(+HLIND1,HLMID) + . D SAVE^HLCSTCP1(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")") + . S:$P(HLIND1,U,3) $P(HLIND1,U,3)="" + D TCP^HLTF(.HLMID,.X,.HLDT) + S HLBUFF("IEN773")=X + I 'X D Q + . ;error - record and reset array + . ;killing HLLSTN will allow MON^HLCSTCP to work with multi-server + . D CLEAN^HLCSTCP1 K HLLSTN + . ;error 100=LLP Could not Enqueue the Message, reset array + . D MONITOR^HLCSDR2(100,19,HLDP),MON^HLCSTCP("ERROR") H 30 + ;HLIND1=ien in 773^ien in 772 + S HLIND1=X_U_+$G(^HLMA(X,0)) + S HLBUFF("HLIND1")=HLIND1 + ;save MSH into 773 + D SAVE^HLCSTCP1(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")") + Q + ; +PMSH(MSH,P) ;get piece P from MSH array (passed by ref.) + N FS,I,L,L1,L2,X,Y + S FS=$E(MSH(1,0),4),(L2,Y)=0,X="" + F I=1:1 S L1=$L($G(MSH(I,0)),FS),L=L1+Y-1 D Q:$L(X)!'$D(MSH(I,0)) + . S:L1=1 L=L+1 + . S:P'>L X=$P($G(MSH(I-1,0)),FS,P-L2)_$P($G(MSH(I,0)),FS,(P-Y)) + . S L2=Y,Y=L + Q X + ; diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCPA.m b/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCPA.m index 8f4b5f01..58597d63 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCPA.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCPA.m @@ -1,113 +1,41 @@ -HLCSTCPA ;OIFO-O/RJH - (TCP/IP) VMS ;07/26/2007 10:29 - ;;1.6;HEALTH LEVEL SEVEN;**84,122**;Oct 13, 1995;Build 14 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; - ; 1. port number is input from VMS COM file, such as HLSxxxxDSM.COM, - ; HLSxxxxCACHE.COM, or HLSxxxxGTM.COM file, where xxxx is port - ; number. - ; 2. find the ien of #870(logical link file) for the multi-listener - Q - ; -GTMPORT(%) ; From tcpip ZFOO for GT.M - ; %: device^port number - N HLPORT - S HLPORT=$P($G(%),"^",2) - I $G(^%ZOSF("OS"))'["GT.M" D ^%ZTER Q - D IEN - Q - ; -PORT ; - ; HLPORT: port number of multi-listener - ; input of DSM: % = device^port number of multi-listener - ; input of Cache: port number of TCPIP - ; - N HLPORT - S HLPORT=0 - I ^%ZOSF("OS")["OpenM" D - . S HLPORT=$ZF("GETSYM","PORT") - I ^%ZOSF("OS")["DSM" D - . S HLPORT=$P(%,"^",2) - ; -IEN ; - ; HLIEN870: ien in #870 (logical link file) - ; HLPRTS: port number in entry to be tested - ; - N HLIEN870 - I 'HLPORT D ^%ZTER Q - S HLIEN870=0 - F S HLIEN870=$O(^HLCS(870,"E","M",HLIEN870)) Q:'HLIEN870 D Q:(HLPRTS=HLPORT) - . S HLPRTS=$P(^HLCS(870,HLIEN870,400),"^",2) - I 'HLIEN870 D ^%ZTER Q - ; - K HLPORT,HLPRTS - ; patch 122 - S U="^" - ; - ;for Cache/VMS - I ^%ZOSF("OS")["OpenM" D Q - . D CACHEVMS(HLIEN870) - ; - ;for DSM - I ^%ZOSF("OS")["DSM" D Q - . S $P(%,"^",2)=HLIEN870 ;set % = device^ien of #870 - . K HLIEN870 - . D EN - ; - ;for GT.M - I ^%ZOSF("OS")["GT.M" D Q - . S HLDP=HLIEN870 ;set HLDP = ien of #870 - . K HLIEN870 - . D GTMUCX - ; - D ^%ZTER - Q -GTMUCX ; GT.M /VMS tcpip - ;listener, % = device^port - S U="^",IO=$P(%,U) - ; S IO(0)=$P O IO(0) ;Setup null device - ; GTM specific code - S @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""") - X "O IO:(RECORDSIZE=512)" - D LISTEN^HLCSTCP - C IO - Q - ; - ; $ x=f$trnlnm("sys$net") !This is our MBX device - ; $! - ; $! for GT.M - ; $ assign 'f$trnlnm("SYS$NET")' SYS$NET - ; $! Depending on how your command files are set up, you may need to - ; $! run the GT.M profile file. - ; $ @gtmprofile.com - ; $ forfoo="$" + f$parse("user$:[gtmmgr.r]ZFOO.exe") - ; $ PORT=5000 - ; $ data="''x'^''PORT'" - ; $ forfoo GTMPORT^HLCSTCPA("''data'") - ; -CACHEVMS(%) ;Cache'/VMS tcpip - ;listener, % = HLDP - I $G(%)="" D ^%ZTER Q - ; patch 133 - S IO="SYS$NET",U="^",HLDP=% - S IO(0)="_NLA0:" O IO(0) ;Setup null device - ; **Cache'/VMS specific code** - O IO::5 E D MON^HLCSTCP("Openfail") Q - X "U IO:(::""-M"")" ;Packet mode like DSM - D LISTEN^HLCSTCP - C IO - Q - ; -EN ; DSM/VMS tcpip - ;listener, % = device^HLDP - I $G(%)="" D ^%ZTER Q - ; patch 122 - ; S IO="SYS$NET",U="^",HLDP=$P(%,U,2) - S U="^",IO=$P(%,U),HLDP=$P(%,U,2) - ; patch 133 - S IO(0)="_NLA0:" O IO(0) ;Setup null device - ; **VMS specific code, need to share device** - O IO:(TCPDEV):60 E D MON^HLCSTCP("Openfail") Q - ; patch 122 - D LISTEN^HLCSTCP - C IO - Q +HLCSTCPA ;OIFO-O/RJH - (TCP/IP) VMS ;07/10/2003 10:12 + ;;1.6;HEALTH LEVEL SEVEN;**84**;Oct 13, 1995 + ; + ; 1. port number is input from VMS HLSxxxxDSM.COM or HLSxxxxCACHE.COM + ; file, where xxxx is port number. + ; 2. find the ien of #870(logical link file) for the HL7 multi-listener + ; 3. call the appropriate entry: + ; for Cache: CACHEVMS^HLCSTCP(ien of #870) + ; for DSM: EN^HLCSTCP + Q +PORT ; + ;HLIEN870: ien in #870 (logical link file) + ;HLPORT: port number of multi-listener + ;HLPRTS: port number in entry to be tested + ;input of DSM: % = device^port number of multi-listener + ;input of Cache: port number of TCPIP + ; + I ^%ZOSF("OS")["OpenM" D + . S HLPORT=$ZF("GETSYM","PORT") + I ^%ZOSF("OS")["DSM" D + . S HLPORT=$P(%,"^",2) + I 'HLPORT D ^%ZTER Q + S HLIEN870=0 + F S HLIEN870=$O(^HLCS(870,"E","M",HLIEN870)) Q:'HLIEN870 D Q:(HLPRTS=HLPORT) + . S HLPRTS=$P(^HLCS(870,HLIEN870,400),"^",2) + I 'HLIEN870 D ^%ZTER Q + ; + K HLPORT,HLPRTS + ; + ;for Cache/VMS + I ^%ZOSF("OS")["OpenM" D Q + .D CACHEVMS^HLCSTCP(HLIEN870) + ; + ;for DSM + I ^%ZOSF("OS")["DSM" D Q + . S $P(%,"^",2)=HLIEN870 ;set % = device^ien of #870 + . K HLIEN870 + . D EN^HLCSTCP + ; + D ^%ZTER + Q diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLCSTERM.m b/r/HEALTH_LEVEL_SEVEN-HL/HLCSTERM.m index 2a91c843..f66ad8c8 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLCSTERM.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLCSTERM.m @@ -1,39 +1,34 @@ -HLCSTERM ;ALB/RJS - SET UP VIDEO ATTRIBUTES ;06/27/2007 17:04 - ;;1.6;HEALTH LEVEL SEVEN;**40,49,122**;Oct 13, 1995;Build 14 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; -TERM ; -- set up term characteristics - N X - I '$D(IOST(0)) D HOME^%ZIS - S X=$$IO D ENDR^%ZISS - S (HLCON,HLCOFF)="" - I $E(IOST,1,4)="C-VT" S HLCOFF=$C(13,27,91)_"?25l"_$C(13),HLCON=$C(27,91)_"?25h" - Q -HEADER ; - ;Write out Header - ; - N HLMIDDLE,HLLNGTH,HLJUST - W @IOF,! - S HLPARAM=$$PARAM^HLCS2 - S HLSITE=$P(HLPARAM,U,5),HLPROD=$P(HLPARAM,U,3) - S HLHDR="SYSTEM LINK MONITOR for "_HLSITE_" ("_HLPROD_" System)" - S HLMIDDLE=IOM\2,HLLNGTH=$L(HLHDR)\2,HLJUST=HLMIDDLE-HLLNGTH - D WDATA^HLCSMON1(HLJUST,1,IORVON,IORVOFF,HLHDR,75) - D WDATA^HLCSMON1(5,4,IOUON,IOUOFF,"NODE",8) - D WDATA^HLCSMON1(16,3,"","","MESSAGES",8),WDATA^HLCSMON1(16,4,IOUON,IOUOFF,"RECEIVED",8) - D WDATA^HLCSMON1(26,3,"","","MESSAGES",8),WDATA^HLCSMON1(26,4,IOUON,IOUOFF,"PROCESSED",9) - D WDATA^HLCSMON1(37,3,"","","MESSAGES",8),WDATA^HLCSMON1(37,4,IOUON,IOUOFF,"TO SEND ",8) - D WDATA^HLCSMON1(47,3,"","","MESSAGES",8),WDATA^HLCSMON1(47,4,IOUON,IOUOFF,"SENT ",8) - ; patch HL*1.6*122 - ; D WDATA^HLCSMON1(57,3,"","","DEVICE",8),WDATA^HLCSMON1(57,4,IOUON,IOUOFF,"TYPE ",8) - D WDATA^HLCSMON1(57,3,"","","DEVICE",8),WDATA^HLCSMON1(57,4,IOUON,IOUOFF,"TYPE ",6) - ; - D WDATA^HLCSMON1(66,4,IOUON,IOUOFF,"STATE",8) - Q -KVAR ; - D KILL^%ZISS - K HLCON,HLCOFF - Q -IO() ; -- what device params - Q "IOELALL;IOELEOL;IORESET;IORVON;IORVOFF;IOIL;IOSTBM;IOSC;IORC;IOEDEOP;IOINHI;IOINORM;IOUON;IOUOFF;IOBOFF;IOBON" - Q +HLCSTERM ;ALB/RJS - SET UP VIDEO ATTRIBUTES - 8/1/94 ;07/28/98 09:43 + ;;1.6;HEALTH LEVEL SEVEN;**40,49**;Oct 13, 1995 +TERM ; -- set up term characteristics + N X + I '$D(IOST(0)) D HOME^%ZIS + S X=$$IO D ENDR^%ZISS + S (HLCON,HLCOFF)="" + I $E(IOST,1,4)="C-VT" S HLCOFF=$C(13,27,91)_"?25l"_$C(13),HLCON=$C(27,91)_"?25h" + Q +HEADER ; + ;Write out Header + ; + N HLMIDDLE,HLLNGTH,HLJUST + W @IOF,! + S HLPARAM=$$PARAM^HLCS2 + S HLSITE=$P(HLPARAM,U,5),HLPROD=$P(HLPARAM,U,3) + S HLHDR="SYSTEM LINK MONITOR for "_HLSITE_" ("_HLPROD_" System)" + S HLMIDDLE=IOM\2,HLLNGTH=$L(HLHDR)\2,HLJUST=HLMIDDLE-HLLNGTH + D WDATA^HLCSMON1(HLJUST,1,IORVON,IORVOFF,HLHDR,75) + D WDATA^HLCSMON1(5,4,IOUON,IOUOFF,"NODE",8) + D WDATA^HLCSMON1(16,3,"","","MESSAGES",8),WDATA^HLCSMON1(16,4,IOUON,IOUOFF,"RECEIVED",8) + D WDATA^HLCSMON1(26,3,"","","MESSAGES",8),WDATA^HLCSMON1(26,4,IOUON,IOUOFF,"PROCESSED",9) + D WDATA^HLCSMON1(37,3,"","","MESSAGES",8),WDATA^HLCSMON1(37,4,IOUON,IOUOFF,"TO SEND ",8) + D WDATA^HLCSMON1(47,3,"","","MESSAGES",8),WDATA^HLCSMON1(47,4,IOUON,IOUOFF,"SENT ",8) + D WDATA^HLCSMON1(57,3,"","","DEVICE",8),WDATA^HLCSMON1(57,4,IOUON,IOUOFF,"TYPE ",8) + D WDATA^HLCSMON1(66,4,IOUON,IOUOFF,"STATE",8) + Q +KVAR ; + D KILL^%ZISS + K HLCON,HLCOFF + Q +IO() ; -- what device params + Q "IOELALL;IOELEOL;IORESET;IORVON;IORVOFF;IOIL;IOSTBM;IOSC;IORC;IOEDEOP;IOINHI;IOINORM;IOUON;IOUOFF;IOBOFF;IOBON" + Q diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLDIE.m b/r/HEALTH_LEVEL_SEVEN-HL/HLDIE.m index 5f4fb846..e62a1cbd 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLDIE.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLDIE.m @@ -1,280 +1,262 @@ -HLDIE ;CIOFO-O/LJA - Direct 772 & 773 Sets ; 10/19/2007 11:15 - ;;1.6;HEALTH LEVEL SEVEN;**109,122**;Oct 13,1995;Build 14 - ;Per VHA Directive 2004-038, this routine should not be modified. - Q - ; - ; Rules: if any of these rules is broken, FILE^DIE is called instead - ; - ; * Can't edit files other than 772,773 - ; * Don't pass IENS value with multiples IENs. You can only - ; edit one IEN at a time! - ; * Only flag "S" is honored. Flag "K" is ignored. Other - ; flags result in FILE^DIE being called. - ; * Can't edit ^HLMA(IEN,90) data. - ; * Can't edit ^HLMA(IEN,91) data. - ; * Can't edit ^HL(772,IEN,"IN") data (field #200, MESSAGE TEXT) - ; * No checking of data performed! (Data format MUST be OK.) - ; * No locking of records in files 772 or 773. (Locks on queues.) - ; -FILE(FLAGS,ROOT,ERR,SUB,RTN) ; FILE^DIE functional equivalent... - ; This call has similar parameters to FILE^DIE, but changes data - ; using hard sets. The first two parameters of this API are the - ; same as FILE^DIE. So, if any file other than 772 or 773 is being - ; edited, this API just passes on the FLAGS,ROOT,ERR parameters to - ; FILE^DIE and quits. If file 772 or 773 is being edited, the hard - ; set code in HLDIE772 and HLDIE773 is called. - ; - N DEBUG,FILE,HLEDITOR,LERR,IEN,X,XECMCODE - ; - S DT=$$NOW^XLFDT\1 - ; - D BEGIN ; Debug call at beginning or process - ; - ; Check FILE, IEN, FIELDs passed, etc... - I '$$CHECKS D QUIT ;-> - . - . S HLEDITOR="FILE^DIE" - . - . ; Call FILEMAN... - . D FILE^DIE($G(FLAGS),$G(ROOT),$G(ERR)) - . - . ; Debug call made even with Fileman... - . D END - ; - S HLEDITOR="FILE^HLDIE" - ; - ; If this point is reached, file 772 or 773 is being edited, data - ; in ROOT() has been checked, and data is being hard set... - ; - ; - ; Make sure ERR is defined... - I $G(ERR)']"" N HLERR S ERR="HLERR" - ; - ; All editing occurs in this call... - D EDITALL(.ROOT,FILE,IEN) - ; - ; Store debug data if XTMP debug string set... - D END - ; - ;check if ROOT needs to be retained - I FLAGS'["S" K @ROOT,FLAGS - ; - Q - ; -EDITALL(ROOT,FILE,IEN) ; Edit 772 or 773 by direct sets... - ; - ; FILE,IEN -- optional (parsed from ROOT()) - ; - N ERRNO,FIELD,GBL,NODE,ROUTINE,TAG,VALUE,XRF - ; - S GBL=$$GBL(FILE,+IEN) - ; - ;check if .01="@" for deletion of record... - I $G(@ROOT@(FILE,IEN,.01))="@" D Q - .I FILE=773 D DEL773^HLUOPT3(+IEN) Q - .I FILE=772 D DEL772^HLUOPT3(+IEN) - ; - ; patch HL*1.6*122: MPI-client/server - ; If no data in record passed in, log an error and quit... - ; I '$D(@GBL) D Q ; Remember. GBL contains IEN... - N HLDGBL - F L +@GBL:10 Q:$T H 1 - S HLDGBL=$D(@GBL) - L -@GBL - I 'HLDGBL D Q ; Remember. GBL contains IEN... - . S ERRNO=$$ERRNO(601,"The entry does not exist.",FILE,2) - . S @ERR@("DIERR",+ERRNO,"PARAM","IENS")=IEN_$S(IEN'[",":",",1:"") - ; - ; - ; What routine holds the file-specific field/xref set code? - S ROUTINE=$S(FILE=772:"HLDIE772",FILE=773:"HLDIE773",1:"") - ; - ; Load NODEs... - D GETNODES(FILE,+IEN,.NODE) - ; - ; When a field is edited, the NODE(1) is changed - ; - ; Edit NODE(1), adding new values, and set XRF(XREF) nodes... - S FIELD=0 - F S FIELD=$O(@ROOT@(FILE,IEN,FIELD)) Q:FIELD'>0 D - . ; VALUE = value passed in by process that is to be stored in file - . S VALUE=$G(@ROOT@(FILE,IEN,FIELD)) - . - . ; If field should be deleted, VALUE will equal @... - . I VALUE="@" S VALUE="" - . - . ; Get and check tag... - . S TAG="F"_(FILE-770)_$TR(FIELD,".","")_U_ROUTINE - . S TAG(1)=$T(@TAG) I TAG(1)']"" D QUIT ;-> - . . S ERRNO=$$ERRNO(501,"No set logic for file #"_FILE_"'s field# "_FIELD,FILE,3) - . . S @ERR@("DIERR",+ERRNO,"PARAM",1)=FIELD - . . S @ERR@("DIERR",+ERRNO,"PARAM","FIELD")=FIELD - . - . ; Call the subroutine below that is for the specific field... - . ; (No editing of xrefs or global data occurs in these calls.) - . D @("F"_(FILE-770)_$TR(FIELD,".","")_U_ROUTINE) - ; - ; If no data actually changed, quit... - QUIT:'$D(NODE("CHG")) ;-> - ; - ; patch HL*1.6*122: MPI-client/server - I FILE=773 D - . F L +^HLMA(IEN):10 Q:$T H 1 - E D - . F L +^HL(772,IEN):10 Q:$T H 1 - ; - ; Store changes in the global now... - D STORE(FILE,IEN,.NODE) - ; - ; Set xrefs to correspond to the just-stored data... - S XRF="" - F S XRF=$O(XRF(XRF)) Q:XRF']"" D - . D @("XRF"_XRF_U_ROUTINE) - ; - ; patch HL*1.6*122: MPI-client/server - I FILE=773 L -^HLMA(IEN) - E L -^HL(772,IEN) - ; - Q - ; -GETNODES(FILE,IEN,NODE) ; Load pre-change data for each node in - ; NODE(node,0), and load node to be changed in NODE(node,1). - ; GBL -- req - F NODE=0,1,2,"P","S" D - . ; After setting, NODE(NODE,0) will equal each other. - . ; However, after each edited field is processed, the pieces of - . ; data in NODE(NODE,1) will be changed. The pre and post nodes - . ; then are of comparison value. - . S NODE(NODE,0)=$G(@GBL@(NODE)) ; Pre-change node - . S NODE(NODE,1)=NODE(NODE,0) ; Node that is changed - Q - ; -STORE(FILE,IEN,NODE) ; Store changes in file... - N DATA,ND - ; - ; Loop thru change nodes, get changed data, and store it... - S ND="" - F S ND=$O(NODE("CHG",ND)) Q:ND']"" D - . S DATA=$G(NODE(ND,1)) - . ; Even if no data no node, store it. (Will be removed by purge.) - . I FILE=772 S ^HL(772,+IEN,ND)=DATA - . I FILE=773 S ^HLMA(+IEN,ND)=DATA - ; - QUIT - ; -GBL(FILE,IEN) QUIT $S(FILE=772:"^HL(772,"_+IEN_")",1:"^HLMA("_+IEN_")") - ; -CHKFLD(FILE,FIELD) ; Does passed-in field exist? - ; Returns -- @ERR@(...) -> - ; - ; Quit if field exists... - QUIT:$D(^DD(+FILE,+FIELD)) 1 ;-> - ; - ; Field doesn't exist. Log error... - S ERRNO=$$ERRNO(501,"File #"_FILE_" does not contain a field "_FIELD_".",FILE,3) - S @ERR@("DIERR",+ERRNO,"PARAM",1)=FIELD - S @ERR@("DIERR",+ERRNO,"PARAM","FIELD")=FIELD - ; - Q "" - ; -ERRNO(NUM,TXT,FILE,PNO) ; Return next ERROR number and create general data... - N NO - S NO=$G(@ERR@("DIERR"))+1,@ERR@("DIERR")=+NO_U_+NO - S @ERR@("DIERR",NO)=NUM - S @ERR@("DIERR",NO,"PARAM",0)=PNO - S @ERR@("DIERR",NO,"PARAM","FILE")=FILE - S @ERR@("DIERR",NO,"TEXT",1)=TXT - S @ERR@("DIERR","E",NUM,NO)="" - Q NO - ; -GENLERR(ETXT) ; Store GENERAL (and fatal) error... - ; ERR -- req - N NO - S NO=$G(@ERR@("DIERR"))+1,@ERR@("DIERR")=+NO_U_+NO - S @ERR@("DIERR",NO)=999_U_ETXT ; Made up error number - Q - ; -CHECKS() ; Check ROOT() for file and validity of data... - ; FLAGS, ROOT() -- req --> FILE,IEN - N I,OK,FIELD - ; - ;check the file & ien - S FILE=$O(@ROOT@(0)) - I FILE'=772,FILE'=773 D QUIT "" ;-> - . S IEN=$S(FILE:$O(@ROOT@(FILE,0)),1:0) ; Set for debugging - ; - ; ;shouldn't be more than 1 file! - QUIT:$O(@ROOT@(FILE)) "" ;-> - ; - ;check the ien structure, and that only ien passed... - S IEN=$O(@ROOT@(FILE,0)) - ; Structure check... - QUIT:$P(IEN,",")'=+IEN_"," "" ;-> - ; Is it numeric? - QUIT:'(+IEN) "" ;-> - ; Has more than one IEN been passed? - QUIT:($O(@ROOT@(FILE,IEN))'="") "" ;-> - ; - ;check the flags. Only K and S flags allowed... - I $L(FLAGS) D QUIT:'OK "" ;-> - . S OK=1 - . F I=0:1:$L(FLAGS) I $E(FLAGS,I)'="K",$E(FLAGS,I)'="S" S OK=0 - ; - ; Check for existence of FIELD in FILE's DD & if an excluded field. - ; (See rules for fields which cannot be updated by FILE^HLDIE.) - S FIELD=0,OK=1 - F S FIELD=$O(@ROOT@(FILE,IEN,FIELD)) Q:FIELD="" D Q:'OK - . I '$$CHKFLD(FILE,FIELD) S OK=0 Q - . I FILE=773,FIELD\1=90 S OK=0 Q - . I FILE=773,FIELD\1=91 S OK=0 Q - . I FILE=772,FIELD=200 S OK=0 Q - ; - ; If not OK to use FILE^HLDIE, skip any further testing... - QUIT:'OK "" ;-> - ; - ; *** WARNING *** - ; The following check **MUST** be removed after FILE^HLDIE is working. - ; - ; Final check for whether FILE^HLDIE should be used... - I $G(^XTMP("HLDIE-DEBUG","CALL"))]"" QUIT "" ;-> - ; If this node exists and follows null, FILE^DIE will be used. - ; Otherwise, execution defaults to using FILE^HLDIE. - ; - Q OK - ; -BEGIN ; Always call here before any ^HLDIE or ^DIE calls... - D DEBUG(1) - Q - ; -END ; Always call here after all ^HLDIE or ^DIE actions... - D DEBUG(2) - Q - ; -DEBUG(LOC) ; Debug presets and setup... - ; Most variables created here should be left around. These variables - ; are newed above. - N STORE - ; - S RTN=$G(RTN),SUB=$G(SUB) - ; - ; First-time (beginning) call setups... - I LOC=1 D - . S RTN=$S(RTN]"":RTN,1:"HLDIE")_"~"_$S(RTN="HLDIE":"FILE",1:SUB) - . S DEBUG=$G(^XTMP("HLDIE-DEBUG","STATUS")) - . S XECMCODE=$P(DEBUG,U,3) - ; DEBUG is always called at beginning (LOC=1) and end (LOC=2) or - ; FILE^HLDIE. So, set up variables only once, at beginning... - ; - ; Setup that is individual to each (1 or 2) call... - S STORE=$P(DEBUG,U,LOC),STORE=$S(STORE=1:1,STORE=2:2,1:"") - ; Some, All, or no data stored? - ; - ; If no STORE instructions, and no M code to specify STORE, quit... - QUIT:'STORE&($G(XECMCODE)'=1) ;-> - ; - ; Call DEBUG to STORE data... - D DEBUG^HLDIEDBG(RTN,LOC,STORE,XECMCODE) - ; - Q - ; -EOR ;HLDIE - Direct 772 & 773 Sets ; 11/18/2003 11:17 +HLDIE ;CIOFO-O/LJA - Direct 772 & 773 Sets ; 11/18/2003 11:17 + ;;1.6;HEALTH LEVEL SEVEN;**109**;Oct 13,1995 + ; + ; Rules: if any of these rules is broken, FILE^DIE is called instead + ; + ; * Can't edit files other than 772,773 + ; * Don't pass IENS value with multiples IENs. You can only + ; edit one IEN at a time! + ; * Only flag "S" is honored. Flag "K" is ignored. Other + ; flags result in FILE^DIE being called. + ; * Can't edit ^HLMA(IEN,90) data. + ; * Can't edit ^HLMA(IEN,91) data. + ; * Can't edit ^HL(772,IEN,"IN") data (field #200, MESSAGE TEXT) + ; * No checking of data performed! (Data format MUST be OK.) + ; * No locking of records in files 772 or 773. (Locks on queues.) + ; +FILE(FLAGS,ROOT,ERR,SUB,RTN) ; FILE^DIE functional equivalent... + ; This call has similar parameters to FILE^DIE, but changes data + ; using hard sets. The first two parameters of this API are the + ; same as FILE^DIE. So, if any file other than 772 or 773 is being + ; edited, this API just passes on the FLAGS,ROOT,ERR parameters to + ; FILE^DIE and quits. If file 772 or 773 is being edited, the hard + ; set code in HLDIE772 and HLDIE773 is called. + ; + N DEBUG,FILE,HLEDITOR,LERR,IEN,X,XECMCODE + ; + S DT=$$NOW^XLFDT\1 + ; + D BEGIN ; Debug call at beginning or process + ; + ; Check FILE, IEN, FIELDs passed, etc... + I '$$CHECKS D QUIT ;-> + . + . S HLEDITOR="FILE^DIE" + . + . ; Call FILEMAN... + . D FILE^DIE($G(FLAGS),$G(ROOT),$G(ERR)) + . + . ; Debug call made even with Fileman... + . D END + ; + S HLEDITOR="FILE^HLDIE" + ; + ; If this point is reached, file 772 or 773 is being edited, data + ; in ROOT() has been checked, and data is being hard set... + ; + ; + ; Make sure ERR is defined... + I $G(ERR)']"" N HLERR S ERR="HLERR" + ; + ; All editing occurs in this call... + D EDITALL(.ROOT,FILE,IEN) + ; + ; Store debug data if XTMP debug string set... + D END + ; + ;check if ROOT needs to be retained + I FLAGS'["S" K @ROOT,FLAGS + ; + Q + ; +EDITALL(ROOT,FILE,IEN) ; Edit 772 or 773 by direct sets... + ; + ; FILE,IEN -- optional (parsed from ROOT()) + ; + N ERRNO,FIELD,GBL,NODE,ROUTINE,TAG,VALUE,XRF + ; + S GBL=$$GBL(FILE,+IEN) + ; + ;check if .01="@" for deletion of record... + I $G(@ROOT@(FILE,IEN,.01))="@" D Q + .I FILE=773 D DEL773^HLUOPT3(+IEN) Q + .I FILE=772 D DEL772^HLUOPT3(+IEN) + ; + ; If no data in record passed in, log an error and quit... + I '$D(@GBL) D Q ; Remember. GBL contains IEN... + . S ERRNO=$$ERRNO(601,"The entry does not exist.",FILE,2) + . S @ERR@("DIERR",+ERRNO,"PARAM","IENS")=IEN_$S(IEN'[",":",",1:"") + ; + ; + ; What routine holds the file-specific field/xref set code? + S ROUTINE=$S(FILE=772:"HLDIE772",FILE=773:"HLDIE773",1:"") + ; + ; Load NODEs... + D GETNODES(FILE,+IEN,.NODE) + ; + ; When a field is edited, the NODE(1) is changed + ; + ; Edit NODE(1), adding new values, and set XRF(XREF) nodes... + S FIELD=0 + F S FIELD=$O(@ROOT@(FILE,IEN,FIELD)) Q:FIELD'>0 D + . ; VALUE = value passed in by process that is to be stored in file + . S VALUE=$G(@ROOT@(FILE,IEN,FIELD)) + . + . ; If field should be deleted, VALUE will equal @... + . I VALUE="@" S VALUE="" + . + . ; Get and check tag... + . S TAG="F"_(FILE-770)_$TR(FIELD,".","")_U_ROUTINE + . S TAG(1)=$T(@TAG) I TAG(1)']"" D QUIT ;-> + . . S ERRNO=$$ERRNO(501,"No set logic for file #"_FILE_"'s field# "_FIELD,FILE,3) + . . S @ERR@("DIERR",+ERRNO,"PARAM",1)=FIELD + . . S @ERR@("DIERR",+ERRNO,"PARAM","FIELD")=FIELD + . + . ; Call the subroutine below that is for the specific field... + . ; (No editing of xrefs or global data occurs in these calls.) + . D @("F"_(FILE-770)_$TR(FIELD,".","")_U_ROUTINE) + ; + ; If no data actually changed, quit... + QUIT:'$D(NODE("CHG")) ;-> + ; + ; Store changes in the global now... + D STORE(FILE,IEN,.NODE) + ; + ; Set xrefs to correspond to the just-stored data... + S XRF="" + F S XRF=$O(XRF(XRF)) Q:XRF']"" D + . D @("XRF"_XRF_U_ROUTINE) + ; + Q + ; +GETNODES(FILE,IEN,NODE) ; Load pre-change data for each node in + ; NODE(node,0), and load node to be changed in NODE(node,1). + ; GBL -- req + F NODE=0,1,2,"P","S" D + . ; After setting, NODE(NODE,0) will equal each other. + . ; However, after each edited field is processed, the pieces of + . ; data in NODE(NODE,1) will be changed. The pre and post nodes + . ; then are of comparison value. + . S NODE(NODE,0)=$G(@GBL@(NODE)) ; Pre-change node + . S NODE(NODE,1)=NODE(NODE,0) ; Node that is changed + Q + ; +STORE(FILE,IEN,NODE) ; Store changes in file... + N DATA,ND + ; + ; Loop thru change nodes, get changed data, and store it... + S ND="" + F S ND=$O(NODE("CHG",ND)) Q:ND']"" D + . S DATA=$G(NODE(ND,1)) + . ; Even if no data no node, store it. (Will be removed by purge.) + . I FILE=772 S ^HL(772,+IEN,ND)=DATA + . I FILE=773 S ^HLMA(+IEN,ND)=DATA + ; + QUIT + ; +GBL(FILE,IEN) QUIT $S(FILE=772:"^HL(772,"_+IEN_")",1:"^HLMA("_+IEN_")") + ; +CHKFLD(FILE,FIELD) ; Does passed-in field exist? + ; Returns -- @ERR@(...) -> + ; + ; Quit if field exists... + QUIT:$D(^DD(+FILE,+FIELD)) 1 ;-> + ; + ; Field doesn't exist. Log error... + S ERRNO=$$ERRNO(501,"File #"_FILE_" does not contain a field "_FIELD_".",FILE,3) + S @ERR@("DIERR",+ERRNO,"PARAM",1)=FIELD + S @ERR@("DIERR",+ERRNO,"PARAM","FIELD")=FIELD + ; + Q "" + ; +ERRNO(NUM,TXT,FILE,PNO) ; Return next ERROR number and create general data... + N NO + S NO=$G(@ERR@("DIERR"))+1,@ERR@("DIERR")=+NO_U_+NO + S @ERR@("DIERR",NO)=NUM + S @ERR@("DIERR",NO,"PARAM",0)=PNO + S @ERR@("DIERR",NO,"PARAM","FILE")=FILE + S @ERR@("DIERR",NO,"TEXT",1)=TXT + S @ERR@("DIERR","E",NUM,NO)="" + Q NO + ; +GENLERR(ETXT) ; Store GENERAL (and fatal) error... + ; ERR -- req + N NO + S NO=$G(@ERR@("DIERR"))+1,@ERR@("DIERR")=+NO_U_+NO + S @ERR@("DIERR",NO)=999_U_ETXT ; Made up error number + Q + ; +CHECKS() ; Check ROOT() for file and validity of data... + ; FLAGS, ROOT() -- req --> FILE,IEN + N I,OK,FIELD + ; + ;check the file & ien + S FILE=$O(@ROOT@(0)) + I FILE'=772,FILE'=773 D QUIT "" ;-> + . S IEN=$S(FILE:$O(@ROOT@(FILE,0)),1:0) ; Set for debugging + ; + ; ;shouldn't be more than 1 file! + QUIT:$O(@ROOT@(FILE)) "" ;-> + ; + ;check the ien structure, and that only ien passed... + S IEN=$O(@ROOT@(FILE,0)) + ; Structure check... + QUIT:$P(IEN,",")'=+IEN_"," "" ;-> + ; Is it numeric? + QUIT:'(+IEN) "" ;-> + ; Has more than one IEN been passed? + QUIT:($O(@ROOT@(FILE,IEN))'="") "" ;-> + ; + ;check the flags. Only K and S flags allowed... + I $L(FLAGS) D QUIT:'OK "" ;-> + . S OK=1 + . F I=0:1:$L(FLAGS) I $E(FLAGS,I)'="K",$E(FLAGS,I)'="S" S OK=0 + ; + ; Check for existence of FIELD in FILE's DD & if an excluded field. + ; (See rules for fields which cannot be updated by FILE^HLDIE.) + S FIELD=0,OK=1 + F S FIELD=$O(@ROOT@(FILE,IEN,FIELD)) Q:FIELD="" D Q:'OK + . I '$$CHKFLD(FILE,FIELD) S OK=0 Q + . I FILE=773,FIELD\1=90 S OK=0 Q + . I FILE=773,FIELD\1=91 S OK=0 Q + . I FILE=772,FIELD=200 S OK=0 Q + ; + ; If not OK to use FILE^HLDIE, skip any further testing... + QUIT:'OK "" ;-> + ; + ; *** WARNING *** + ; The following check **MUST** be removed after FILE^HLDIE is working. + ; + ; Final check for whether FILE^HLDIE should be used... + I $G(^XTMP("HLDIE-DEBUG","CALL"))]"" QUIT "" ;-> + ; If this node exists and follows null, FILE^DIE will be used. + ; Otherwise, execution defaults to using FILE^HLDIE. + ; + Q OK + ; +BEGIN ; Always call here before any ^HLDIE or ^DIE calls... + D DEBUG(1) + Q + ; +END ; Always call here after all ^HLDIE or ^DIE actions... + D DEBUG(2) + Q + ; +DEBUG(LOC) ; Debug presets and setup... + ; Most variables created here should be left around. These variables + ; are newed above. + N STORE + ; + S RTN=$G(RTN),SUB=$G(SUB) + ; + ; First-time (beginning) call setups... + I LOC=1 D + . S RTN=$S(RTN]"":RTN,1:"HLDIE")_"~"_$S(RTN="HLDIE":"FILE",1:SUB) + . S DEBUG=$G(^XTMP("HLDIE-DEBUG","STATUS")) + . S XECMCODE=$P(DEBUG,U,3) + ; DEBUG is always called at beginning (LOC=1) and end (LOC=2) or + ; FILE^HLDIE. So, set up variables only once, at beginning... + ; + ; Setup that is individual to each (1 or 2) call... + S STORE=$P(DEBUG,U,LOC),STORE=$S(STORE=1:1,STORE=2:2,1:"") + ; Some, All, or no data stored? + ; + ; If no STORE instructions, and no M code to specify STORE, quit... + QUIT:'STORE&($G(XECMCODE)'=1) ;-> + ; + ; Call DEBUG to STORE data... + D DEBUG^HLDIEDBG(RTN,LOC,STORE,XECMCODE) + ; + Q + ; +EOR ;HLDIE - Direct 772 & 773 Sets ; 11/18/2003 11:17 diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLFNC.m b/r/HEALTH_LEVEL_SEVEN-HL/HLFNC.m index d4863d8a..47ab93fc 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLFNC.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLFNC.m @@ -1,222 +1,205 @@ -HLFNC ;AISC/SAW/OAK-OIFO/RBN-Routine of Functions and Other Calls Used for HL7 Messages ;03/26/2008 11:34 - ;;1.6;HEALTH LEVEL SEVEN;**38,42,51,66,141**;Oct 13, 1995;Build 11 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; -HLNAME(X,HLECDE) ;Convert a name in DHCP format to HL7 format - ; INPUT: X - Name in DHCP format - ; Optional - HLECDE - HL7 encoding chars - ;**** NOTE: **** - ;If this function is called without HLECDE as parameter than HLECH - ;must be define. - ; - Q:'$D(X) "" Q:X="" "" - I '$D(HLECH),'$D(HLECDE) Q "" - I $D(HLECDE) N HLECH S HLECH=HLECDE - I '$D(HLECH) Q "" - N %,X1,X2,Y - S X1=$P(X,",",2),X2=$L(X1," "),Y=$P(X,",")_$E(HLECH)_$P(X1," ") I X2 F %=2:1:X2 Q:$P(X1," ",%)']"" S Y=Y_$E(HLECH)_$P(X1," ",%) - Q Y - ; -FMNAME(X,HLECDE) ;Convert a name in HL7 format to DHCP format - ; INPUT: X - Name in HL7 format - ; Optional - HLECDE - HL7 encoding chars - ;**** NOTE: **** - ;If this function is called without HLECDE as parameter than HLECH - ;must be define. - ; - Q:'$D(X) "" Q:X="" "" - I '$D(HLECH),'$D(HLECDE) Q "" - I $D(HLECDE) N HLECH S HLECH=HLECDE - I '$D(HLECH) Q "" - N %,X1 S X1=$L(X,$E(HLECH)),Y="" F %=1:1:X1 D - .I $P(X,$E(HLECH),%)]"",$P(X,$E(HLECH),%)'="""""" D - ..;Only last name,first name. - ..I %<3 S Y=Y_$P(X,$E(HLECH),%)_$S(%=1:",",1:"") Q - ..S Y=Y_" "_$P(X,$E(HLECH),%) - Q Y - ; -HLDATE(X,Y) ;Convert date, date/time or time only in FM format to HL7 format - ;Optional Variables: - ;Y = The type of format to be returned if you want to force return of a - ; specific format. Y must be equal to one of the following: - ; DT - Date only - ; TM - Time only - ; TS - Date and time - I X="" Q "" - S Y=$G(Y) - N %,Z - I $L(X)<7 D Q % ;Time input - . S %=$S(X=2400:"0000",$L(X)<4:$E(X_"000",1,4),1:X) S:$L(%)=5 %=%_0 - . Q - I Y="TM" D Q % ;Only time - . S %=$P(X,".",2),%=$S(%="":"",$E(%,1,2)=24:"0000",$L(%)<4:$E(%_"000",1,4),1:%) S:$L(%)=5 %=%_0 - . Q - S %=$$FMTHL7^XLFDT(X) - Q $S(Y="DT":$E(%,1,8),1:%) - ; -FMDATE(X) ; Convert a date, date/time or time only in HL7 format to FM format - I X="" Q "" - N % - S %=$P($TR(X,"+-","^"),"^") - I $L(X)<7 Q % - Q $$HL7TFM^XLFDT(X) - ; -M10(X,HLECDE) ; M10 check digit scheme - ; INPUT : X - ID number - ; Optional HLECDE - Encoding chars - ;**** NOTE: **** - ;If this function is called without HLECDE as parameter then HLECH - ;must be defined. - ;Return X if encoding character is not defined - ;Return X with encoding characters concatenated if X is alphanumeric - ; - N HLCNT,HLODD,HLEVEN,HLX1,HLDIGIT - Q:'$D(X) "" - I $D(HLECDE) N HLECH S HLECH=HLECDE - ;Return X if encoding character is not defined - I '$D(HLECH) Q X - ;Return X with encoding characters concatenated if X is alphanumeric - I '(X?1.N) Q X_$E(HLECH)_$E(HLECH) - ; - S HLX1=+X - S HLODD="" - F HLCNT=$L(HLX1):-2:1 S HLODD=HLODD_$E(HLX1,HLCNT) - S HLODD=HLODD*2 - S HLEVEN="" - F HLCNT=($L(HLX1)-1):-2:1 S HLEVEN=HLEVEN_$E(HLX1,HLCNT) - S HLX1=HLEVEN_HLODD - S HLDIGIT=0 - F HLCNT=1:1:$L(HLX1) S HLDIGIT=HLDIGIT+$E(HLX1,HLCNT) - S HLDIGIT=((HLDIGIT\10+1)*10-HLDIGIT)#10 - Q X_$E(HLECH)_HLDIGIT_$E(HLECH)_"M10" - ; -M11(X,HLECDE) ; M11 check digit scheme - ; INPUT : X - ID number - ; Optional HLECDE - Encoding chars - ;**** NOTE: **** - ;If this function is called without HLECDE as parameter then HLECH - ;must be defined. - ;Return X if encoding character is not defined - ;Return X with encoding characters concatenated if X is alphanumeric - ; - N HLX1,HLCNT,HLWT,HLDIGIT - Q:'$D(X) "" - I $D(HLECDE) N HLECH S HLECH=HLECDE - ;Return X if encoding character is not defined - I '$D(HLECH) Q X - ;Return X with encoding characters concatenated if X is alphanumeric - I '(X?1N.N) Q X_$E(HLECH)_$E(HLECH) - ; - S HLX1=+X - S HLDIGIT=0,HLWT=2 - F HLCNT=$L(HLX1):-1:1 D - . I HLWT>7 S HLWT=2 - . S HLDIGIT=HLDIGIT+($E(HLX1,HLCNT)*HLWT) - . S HLWT=HLWT+1 - S HLDIGIT=HLDIGIT#11 - I HLDIGIT=0 S HLDIGIT=1 - S HLDIGIT=(11-HLDIGIT)#10 - Q X_$E(HLECH)_HLDIGIT_$E(HLECH)_"M11" - ; -OLDM10(X,HLECDE) ;Calculate M10 checksum - ; INPUT : X - String to calc checksum - ; Optional HLECDE - Encoding chars - ;**** NOTE: **** - ;If this function is called without HLECDE as parameter than HLECH - ;must be define. - ; - Q:'$D(X) "" - I '$D(HLECH),'$D(HLECDE) Q "" - I $D(HLECDE) N HLECH S HLECH=HLECDE - I '$D(HLECH) Q "" - N %,Y - S Y=0 F %=1:1:$L(X) S Y=Y+$E(X,%) - Q X_$E(HLECH)_(Y#10)_$E(HLECH)_"M10" - ; -OLDM11(X,HLECDE) ;Calculate M11 checksum - ; INPUT : X - String to calc checksum - ; Optional HLECDE - Encoding chars - ;**** NOTE: **** - ;If this function is called without HLECDE as parameter than HLECH - ;must be define. - ; - Q:'$D(X) "" - I '$D(HLECH),'$D(HLECDE) Q "" - I $D(HLECDE) N HLECH S HLECH=HLECDE - I '$D(HLECH) Q "" - N %,Y S Y=0 F %=1:1:$L(X) S Y=Y+$E(X,%) - Q X_$E(HLECH)_(Y#11)_$E(HLECH)_"M11" -UPPER(X) ;Convert lowercase letters to uppercase - Q:'$D(X) "" - Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") -HLPHONE(X,B,C) ;Convert DHCP Phone Number to HL7 Format - ;Required parameters: - ;X = Seven digit phone number at a minimum. Optionally, in addition, - ; a three digit area code, two digit country code and other - ; formatting characters (e.g., dashes) - ;Optional Variables: - ;B = Beeper number - ;C = Comments - Q:'$D(X) "" Q:$L(X)<7 "" - N I,Y,Y1,Z S B=$S('$D(B):"",1:"B"_B),C=$S('$D(C):"",1:"C"_C) - ; - ; patch HL*1.6*141 start - ; S Y="" F I=1:1:$L(X) S Y=Y_$S($E(X,I)?1N:$E(X,I),"X,x"[$E(X,I)&('$D(Z)):"X",1:"") I "X,x"[$E(X,I) S Z="" - N CH - S Y="" - F I=1:1:$L(X) D - . S CH=$E(X,I) - . ; Next line modified by RBN - . ;S Y=Y_$S(CH?1N:CH,"Xx"[CH&('$D(Z)):"X",1:"") - . S Y=Y_$S(CH?1N:CH,"Xx,*"[CH&('$D(Z)):"X",1:"") - . I "Xx"[CH S Z="" - ; - ; the number, following "X" character, should be greater than 0 - I Y["X",+$P(Y,"X",2)<1 S Y=$P(Y,"X") - ; patch HL*1.6*141 end - ; - I $L(Y)<7 Q "" - S Y1=$S(Y["X":"X"_$P(Y,"X",2),1:""),Y=$P(Y,"X") I $L(Y)<7 Q "" - I $L(Y)=8,189[$E(Y) S Y=$E(Y,2,8) - I $L(Y)=11,189[$E(Y) S Y=$E(Y,2,11) - I $L(Y)=7 Q $E($E(Y,1,3)_"-"_$E(Y,4,7)_Y1_B_C,1,40) - I $L(Y)=10 Q $E("("_$E(Y,1,3)_")"_$E(Y,4,6)_"-"_$E(Y,7,10)_Y1_B_C,1,40) - I $L(Y)=12 Q $E($E(Y,1,2)_" ("_$E(Y,3,5)_")"_$E(Y,6,8)_"-"_$E(Y,9,12)_Y1_B_C,1,40) - Q "" -HLADDR(AD,GL,HLECDE) ;Convert DHCP address fields to HL7 address format - ;Required parameters: - ;AD = One to four street address lines separated by uparrows (^). - ;GL = Three to four geographic location components separated by - ; uparrows (^). City^State or Province^Zip Code^Country Code. - ; If the fourth component is not defined, it will be set to 'USA'. - ; The second component must be null or an IEN in the - ; State file (#5). The third component must be null or pattern - ; match 5N, 9N or 5N1"-"4N. - ; - ; Optional HLECDE - Encoding chars - ;**** NOTE: **** - ;If this function is called without HLECDE as parameter than HLECH - ;must be define. - ; - ; - ;A string will be returned with six components separated by the HL7 - ;component separator. The length of the string (including separators) - ;may exceed 106 characters. - ; - Q:'$D(AD) "" Q:'$D(GL) "" - I '$D(HLECH),'$D(HLECDE) Q "" - I $D(HLECDE) N HLECH S HLECH=HLECDE - I '$D(HLECH) Q "" - I $D(XRTL) D T0^%ZOSV - N I,X,Y - I $P(GL,"^",4)="" S $P(GL,"^",4)="USA" - I $P(GL,"^",4)="USA" S X=$P(GL,"^",3) S:X?9N X=$E(X,1,5)_"-"_$E(X,6,9) S $P(GL,"^",3)=$S(X?5N!(X?5N1"-"4N):X,1:"") - S X=+$P(GL,"^",2) S $P(GL,"^",2)=$S('X:"",$P($G(^DIC(5,X,0)),"^",2)]"":$E($P(^(0),"^",2),1,2),1:"") - S Y=$E(HLECH)_$P(GL,"^")_$E(HLECH)_$P(GL,"^",2)_$E(HLECH)_$P(GL,"^",3)_$E(HLECH)_$P(GL,"^",4) - S X=$P(AD,"^",1,4) F I=1,2 I X["^^" S X=$P(X,"^^")_"^"_$P(X,"^^",2,3) - I $E(X,$L(X))="^" S X=$E(X,1,($L(X)-1)) - I $D(XRT0) S XRTN="HLFNC" D T1^%ZOSV - I $L(X,"^")=1 Q $P(X,"^")_$E(HLECH)_Y - I $L(X,"^")=2 Q $P(X,"^")_$E(HLECH)_$P(X,"^",2)_Y - I $L(X,"^")=3 Q $P(X,"^")_", "_$P(X,"^",2)_$E(HLECH)_$P(X,"^",3)_Y - I $L(X,"^")=4 Q $P(X,"^")_", "_$P(X,"^",2)_$E(HLECH)_$P(X,"^",3)_", "_$P(X,"^",4)_Y +HLFNC ;AISC/SAW-Routine of Functions and Other Calls Used for HL7 Messages ;08/03/2000 15:45 + ;;1.6;HEALTH LEVEL SEVEN;**38,42,51,66**;Oct 13, 1995 +HLNAME(X,HLECDE) ;Convert a name in DHCP format to HL7 format + ; INPUT: X - Name in DHCP format + ; Optional - HLECDE - HL7 encoding chars + ;**** NOTE: **** + ;If this function is called without HLECDE as parameter than HLECH + ;must be define. + ; + Q:'$D(X) "" Q:X="" "" + I '$D(HLECH),'$D(HLECDE) Q "" + I $D(HLECDE) N HLECH S HLECH=HLECDE + I '$D(HLECH) Q "" + N %,X1,X2,Y + S X1=$P(X,",",2),X2=$L(X1," "),Y=$P(X,",")_$E(HLECH)_$P(X1," ") I X2 F %=2:1:X2 Q:$P(X1," ",%)']"" S Y=Y_$E(HLECH)_$P(X1," ",%) + Q Y + ; +FMNAME(X,HLECDE) ;Convert a name in HL7 format to DHCP format + ; INPUT: X - Name in HL7 format + ; Optional - HLECDE - HL7 encoding chars + ;**** NOTE: **** + ;If this function is called without HLECDE as parameter than HLECH + ;must be define. + ; + Q:'$D(X) "" Q:X="" "" + I '$D(HLECH),'$D(HLECDE) Q "" + I $D(HLECDE) N HLECH S HLECH=HLECDE + I '$D(HLECH) Q "" + N %,X1 S X1=$L(X,$E(HLECH)),Y="" F %=1:1:X1 D + .I $P(X,$E(HLECH),%)]"",$P(X,$E(HLECH),%)'="""""" D + ..;Only last name,first name. + ..I %<3 S Y=Y_$P(X,$E(HLECH),%)_$S(%=1:",",1:"") Q + ..S Y=Y_" "_$P(X,$E(HLECH),%) + Q Y + ; +HLDATE(X,Y) ;Convert date, date/time or time only in FM format to HL7 format + ;Optional Variables: + ;Y = The type of format to be returned if you want to force return of a + ; specific format. Y must be equal to one of the following: + ; DT - Date only + ; TM - Time only + ; TS - Date and time + I X="" Q "" + S Y=$G(Y) + N %,Z + I $L(X)<7 D Q % ;Time input + . S %=$S(X=2400:"0000",$L(X)<4:$E(X_"000",1,4),1:X) S:$L(%)=5 %=%_0 + . Q + I Y="TM" D Q % ;Only time + . S %=$P(X,".",2),%=$S(%="":"",$E(%,1,2)=24:"0000",$L(%)<4:$E(%_"000",1,4),1:%) S:$L(%)=5 %=%_0 + . Q + S %=$$FMTHL7^XLFDT(X) + Q $S(Y="DT":$E(%,1,8),1:%) + ; +FMDATE(X) ;Convert a date, date/time or time only in HL7 format to FM format + I X="" Q "" + N % + S %=$P($TR(X,"+-","^"),"^") + I $L(X)<7 Q % + Q $$HL7TFM^XLFDT(X) + ; +M10(X,HLECDE) ; M10 check digit scheme + ; INPUT : X - ID number + ; Optional HLECDE - Encoding chars + ;**** NOTE: **** + ;If this function is called without HLECDE as parameter then HLECH + ;must be defined. + ;Return X if encoding character is not defined + ;Return X with encoding characters concatenated if X is alphanumeric + ; + N HLCNT,HLODD,HLEVEN,HLX1,HLDIGIT + Q:'$D(X) "" + I $D(HLECDE) N HLECH S HLECH=HLECDE + ;Return X if encoding character is not defined + I '$D(HLECH) Q X + ;Return X with encoding characters concatenated if X is alphanumeric + I '(X?1.N) Q X_$E(HLECH)_$E(HLECH) + ; + S HLX1=+X + S HLODD="" + F HLCNT=$L(HLX1):-2:1 S HLODD=HLODD_$E(HLX1,HLCNT) + S HLODD=HLODD*2 + S HLEVEN="" + F HLCNT=($L(HLX1)-1):-2:1 S HLEVEN=HLEVEN_$E(HLX1,HLCNT) + S HLX1=HLEVEN_HLODD + S HLDIGIT=0 + F HLCNT=1:1:$L(HLX1) S HLDIGIT=HLDIGIT+$E(HLX1,HLCNT) + S HLDIGIT=((HLDIGIT\10+1)*10-HLDIGIT)#10 + Q X_$E(HLECH)_HLDIGIT_$E(HLECH)_"M10" + ; +M11(X,HLECDE) ; M11 check digit scheme + ; INPUT : X - ID number + ; Optional HLECDE - Encoding chars + ;**** NOTE: **** + ;If this function is called without HLECDE as parameter then HLECH + ;must be defined. + ;Return X if encoding character is not defined + ;Return X with encoding characters concatenated if X is alphanumeric + ; + N HLX1,HLCNT,HLWT,HLDIGIT + Q:'$D(X) "" + I $D(HLECDE) N HLECH S HLECH=HLECDE + ;Return X if encoding character is not defined + I '$D(HLECH) Q X + ;Return X with encoding characters concatenated if X is alphanumeric + I '(X?1N.N) Q X_$E(HLECH)_$E(HLECH) + ; + S HLX1=+X + S HLDIGIT=0,HLWT=2 + F HLCNT=$L(HLX1):-1:1 D + . I HLWT>7 S HLWT=2 + . S HLDIGIT=HLDIGIT+($E(HLX1,HLCNT)*HLWT) + . S HLWT=HLWT+1 + S HLDIGIT=HLDIGIT#11 + I HLDIGIT=0 S HLDIGIT=1 + S HLDIGIT=(11-HLDIGIT)#10 + Q X_$E(HLECH)_HLDIGIT_$E(HLECH)_"M11" + ; +OLDM10(X,HLECDE) ;Calculate M10 checksum + ; INPUT : X - String to calc checksum + ; Optional HLECDE - Encoding chars + ;**** NOTE: **** + ;If this function is called without HLECDE as parameter than HLECH + ;must be define. + ; + Q:'$D(X) "" + I '$D(HLECH),'$D(HLECDE) Q "" + I $D(HLECDE) N HLECH S HLECH=HLECDE + I '$D(HLECH) Q "" + N %,Y + S Y=0 F %=1:1:$L(X) S Y=Y+$E(X,%) + Q X_$E(HLECH)_(Y#10)_$E(HLECH)_"M10" + ; +OLDM11(X,HLECDE) ;Calculate M11 checksum + ; INPUT : X - String to calc checksum + ; Optional HLECDE - Encoding chars + ;**** NOTE: **** + ;If this function is called without HLECDE as parameter than HLECH + ;must be define. + ; + Q:'$D(X) "" + I '$D(HLECH),'$D(HLECDE) Q "" + I $D(HLECDE) N HLECH S HLECH=HLECDE + I '$D(HLECH) Q "" + N %,Y S Y=0 F %=1:1:$L(X) S Y=Y+$E(X,%) + Q X_$E(HLECH)_(Y#11)_$E(HLECH)_"M11" +UPPER(X) ;Convert lowercase letters to uppercase + Q:'$D(X) "" + Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") +HLPHONE(X,B,C) ;Convert DHCP Phone Number to HL7 Format + ;Required parameters: + ;X = Seven digit phone number at a minimum. Optionally, in addition, + ; a three digit area code, two digit country code and other + ; formatting characters (e.g., dashes) + ;Optional Variables: + ;B = Beeper number + ;C = Comments + Q:'$D(X) "" Q:$L(X)<7 "" + N I,Y,Y1,Z S B=$S('$D(B):"",1:"B"_B),C=$S('$D(C):"",1:"C"_C) + S Y="" F I=1:1:$L(X) S Y=Y_$S($E(X,I)?1N:$E(X,I),"X,x"[$E(X,I)&('$D(Z)):"X",1:"") I "X,x"[$E(X,I) S Z="" + I $L(Y)<7 Q "" + S Y1=$S(Y["X":"X"_$P(Y,"X",2),1:""),Y=$P(Y,"X") I $L(Y)<7 Q "" + I $L(Y)=8,189[$E(Y) S Y=$E(Y,2,8) + I $L(Y)=11,189[$E(Y) S Y=$E(Y,2,11) + I $L(Y)=7 Q $E($E(Y,1,3)_"-"_$E(Y,4,7)_Y1_B_C,1,40) + I $L(Y)=10 Q $E("("_$E(Y,1,3)_")"_$E(Y,4,6)_"-"_$E(Y,7,10)_Y1_B_C,1,40) + I $L(Y)=12 Q $E($E(Y,1,2)_" ("_$E(Y,3,5)_")"_$E(Y,6,8)_"-"_$E(Y,9,12)_Y1_B_C,1,40) + Q "" +HLADDR(AD,GL,HLECDE) ;Convert DHCP address fields to HL7 address format + ;Required parameters: + ;AD = One to four street address lines separated by uparrows (^). + ;GL = Three to four geographic location components separated by + ; uparrows (^). City^State or Province^Zip Code^Country Code. + ; If the fourth component is not defined, it will be set to 'USA'. + ; The second component must be null or an IEN in the + ; State file (#5). The third component must be null or pattern + ; match 5N, 9N or 5N1"-"4N. + ; + ; Optional HLECDE - Encoding chars + ;**** NOTE: **** + ;If this function is called without HLECDE as parameter than HLECH + ;must be define. + ; + ; + ;A string will be returned with six components separated by the HL7 + ;component separator. The length of the string (including separators) + ;may exceed 106 characters. + ; + Q:'$D(AD) "" Q:'$D(GL) "" + I '$D(HLECH),'$D(HLECDE) Q "" + I $D(HLECDE) N HLECH S HLECH=HLECDE + I '$D(HLECH) Q "" + I $D(XRTL) D T0^%ZOSV + N I,X,Y + I $P(GL,"^",4)="" S $P(GL,"^",4)="USA" + I $P(GL,"^",4)="USA" S X=$P(GL,"^",3) S:X?9N X=$E(X,1,5)_"-"_$E(X,6,9) S $P(GL,"^",3)=$S(X?5N!(X?5N1"-"4N):X,1:"") + S X=+$P(GL,"^",2) S $P(GL,"^",2)=$S('X:"",$P($G(^DIC(5,X,0)),"^",2)]"":$E($P(^(0),"^",2),1,2),1:"") + S Y=$E(HLECH)_$P(GL,"^")_$E(HLECH)_$P(GL,"^",2)_$E(HLECH)_$P(GL,"^",3)_$E(HLECH)_$P(GL,"^",4) + S X=$P(AD,"^",1,4) F I=1,2 I X["^^" S X=$P(X,"^^")_"^"_$P(X,"^^",2,3) + I $E(X,$L(X))="^" S X=$E(X,1,($L(X)-1)) + I $D(XRT0) S XRTN="HLFNC" D T1^%ZOSV + I $L(X,"^")=1 Q $P(X,"^")_$E(HLECH)_Y + I $L(X,"^")=2 Q $P(X,"^")_$E(HLECH)_$P(X,"^",2)_Y + I $L(X,"^")=3 Q $P(X,"^")_", "_$P(X,"^",2)_$E(HLECH)_$P(X,"^",3)_Y + I $L(X,"^")=4 Q $P(X,"^")_", "_$P(X,"^",2)_$E(HLECH)_$P(X,"^",3)_", "_$P(X,"^",4)_Y diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLMA.m b/r/HEALTH_LEVEL_SEVEN-HL/HLMA.m index fe43b8fa..f1444954 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLMA.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLMA.m @@ -1,213 +1,180 @@ -HLMA ;AISC/SAW-Message Administration Module ;05/02/2008 10:27 - ;;1.6;HEALTH LEVEL SEVEN;**19,43,58,63,66,82,91,109,115,133,132,122,140**;Oct 13, 1995;Build 5 - ;Per VHA Directive 2004-038, this routine should not be modified. -GENERATE(HLEID,HLARYTYP,HLFORMAT,HLRESLT,HLMTIEN,HLP) ; - ;Entry point to generate a deferred message - ; - ;This is a subroutine call with parameter passing. It returns a - ;value in the variable HLRESLT with 1 to 3 pieces separated by uparrows - ;as follows: 1st message ID^error code^error description - ;If no error occurs, only the first piece is returned equal to a unique - ;ID for the 1st message. If message was sent to more than 1 subscriber - ;than the other message IDs will be in the array HLRESLT(n)=ID - ;Otherwise, three pieces are returned with the - ;first piece equal to the message ID, if one was assigned, otherwise 0 - ; - ;Required Input Parameters - ; HLEID = Name or IEN of event driver protocol in the Protocol file - ; HLARYTYP = Array type. One of the following codes: - ; LM = local array containing a single message - ; LB = local array containig a batch of messages - ; GM = global array containing a single message - ; GB = global array containing a batch of messages - ; HLFORMAT = Format of array, 1 for pre-formatted in HL7 format, - ; otherwise 0 - ;NOTE: The parameter HLRESLT must be passed by reference - ; HLRESLT = The variable that will be returned to the calling - ; application as descibed above - ;Optional Parameters - ; HLMTIEN = IEN of entry in Message Text file where the message - ; being generated is to be stored. This parameter is - ; only passed for a batch type message - ;NOTE: The parameter HLP used for the following parameters must be - ; passed by reference - ; HLP("SECURITY") = A 1 to 40 character string - ; HLP("CONTPTR") = Continuation pointer, a 1 to 180 character string - ; HLP("NAMESPACE") = Passed in by application namespace - HL*1.6*91 - ; HLP("EXCLUDE SUBSCRIBER",)= or - ; - A list of protocols to dynamically - ; drop from the event protocol's subscriber multiple. - ; - ;can't have link open when generating new message - N HLTCP,HLTCPO,HLPRIO,HLMIDAR - S HLPRIO="D" - S HLRESLT="" - ;Check for required parameters -CONT ; - I $G(HLEID)']""!($G(HLARYTYP)']"")!($G(HLFORMAT)']"") D G EXIT - . S HLRESLT="0^7^"_$G(^HL(771.7,7,0))_" at GENERATE^HLMA entry point" - I 'HLEID S HLEID=$O(^ORD(101,"B",HLEID,0)) I 'HLEID S HLRESLT="0^1^"_$G(^HL(771.7,1,0)) G EXIT - N HLRESLT1,HLRESLTA S (HLRESLTA,HLRESLT1)="" - I "GL"'[$E(HLARYTYP) S HLRESLT="0^4^"_$G(^HL(771.7,4,0)) G EXIT - I $L($G(HLP("SECURITY")))>40 S HLRESLT="0^6^"_$G(^HL(771.7,6,0)) G EXIT - I $L($G(HLP("CONTPTR")))>180 S HLRESLT="0^11^"_$G(^HL(771.7,11,0)) G EXIT - I $D(HLL("LINKS")) D G:$G(HLRESLT)]"" EXIT - . N I,HLPNAM,HLPIEN,HLLNAM,HLLIEN - . S I=0 - . F S I=$O(HLL("LINKS",I)) Q:'I D Q:$G(HLRESLT)]"" - . . S HLPNAM=$P(HLL("LINKS",I),U) - . . S HLPIEN=+$O(^ORD(101,"B",HLPNAM,0)) - . . I $P($G(^ORD(101,HLPIEN,0)),U,4)'="S" S HLRESLT="0^15^Invalid Subscriber Protocol in HLL('LINKS'): "_HLL("LINKS",I) Q - . . S HLLNAM=$P(HLL("LINKS",I),U,2) - . . S HLLIEN=+$O(^HLCS(870,"B",HLLNAM,0)) - . . I '$D(^HLCS(870,HLLIEN,0)) S HLRESLT="0^15^Invalid HL Node in HLL('LINKS'): "_HLL("LINKS",I) Q - ;Extract data from Protocol file - D EVENT^HLUTIL1(HLEID,"15,20,771",.HLN) - S HLENROU=$G(HLN(20)),HLEXROU=$G(HLN(15)) - S HLP("GROUTINE")=$G(HLN(771)) K HLN I HLP("GROUTINE")']"",'HLFORMAT S HLRESLT="0^3^"_$G(^HL(771.7,3,0)) G EXIT - ;Create message ID and Message Text IEN if Message Text IEN not - ;previously created ('$G(HLMTIEN)) - I '$G(HLMTIEN) D CREATE^HLTF(.HLMID,.HLMTIEN,.HLDT,.HLDT1) - ;Get message ID if Message Text IEN already created - I '$G(HLMID) D - .S HLDT=$G(^HL(772,HLMTIEN,0)),HLMID=$P(HLDT,"^",6),HLDT=+HLDT - .S HLDT1=$$HLDATE^HLFNC(HLDT) - S HLMIDAR=0,HLRESLT=HLMID,HLP("DT")=HLDT,HLP("DTM")=HLDT1 - ;Execute entry action for event driver protocol - I HLENROU]"" X HLENROU - ;Invoke transaction processor - K HLDT,HLDT1,HLENROU - D GENERATE^HLTP(HLMID,HLMTIEN,HLEID,HLARYTYP,HLFORMAT,.HLRESLT1,.HLP) - ;HLMIDAR is array of message IDs, only set for broadcast messages - I HLMIDAR K HLMIDAR("N") M HLRESLT=HLMIDAR - S HLRESLT=HLRESLT_"^"_HLRESLT1 - ; - ; patch HL*1.6*122 - S HLRESLT("HLMID")=$G(HLMIDAR("HLMID")) - S HLRESLT("IEN773")=$G(HLMIDAR("IEN773")) - ; - ;Execute exit action for event driver protocol - I HLEXROU]"" X HLEXROU -EXIT ;Update status if Message Text file entry has been created - K HLTCP - I $D(HLMTIEN) D STATUS^HLTF0(HLMTIEN,$S($P(HLRESLT,"^",2):4,1:3),$S($P(HLRESLT,"^",2):$P(HLRESLT,"^",2),1:""),$S($P(HLRESLT,"^",2):$P(HLRESLT,"^",3),1:"")) - K HLDT,HLDT1,HLMID,HLRESLT1,HLENROU,HLEXROU - Q -DIRECT(HLEID,HLARYTYP,HLFORMAT,HLRESLT,HLMTIENO,HLP) ; - ;Entry point to generate an immediate message, must be TCP Logical Link - ;Input: - ; The same as GENERATE,with one additional subscript to the HLP input - ; array: - ; - ; HLP("OPEN TIMEOUT") (optional, pass by reference) a number between - ; 1 and 120 that specifies how many seconds the DIRECT CONNECT should - ; try to open a connection before failing. It is killed upon - ; completion. - ; - N HLTCP,HLTCPO,HLPRIO,HLSAN,HLN,HLMIDAR,HLMTIENR,ZMID,HLDIRECT - ; patch HL*1.6*140- to protect application who call this entry - N IO,IOF,ION,IOT,IOST,POP - S HLRESLT="" - ;HLMTIENO=ien passed in, batch message - S HLMTIEN=$G(HLMTIENO) - I $G(HLP("OPEN TIMEOUT")),((HLP("OPEN TIMEOUT")\1)'=+HLP("OPEN TIMEOUT"))!HLP("OPEN TIMEOUT")>120 Q "0^4^INVALID OPEN TIMEOUT PARAMETER" - I $G(HLP("OPEN TIMEOUT")) D - .S HLDIRECT("OPEN TIMEOUT")=HLP("OPEN TIMEOUT") - .K HLP("OPEN TIMEOUT") - K HL,HLMTIENO - D INIT^HLFNC2(HLEID,.HL) - I $G(HL) S HLRESLT="0^"_HL Q - S HLPRIO="I" D CONT - ;HLMTIENO=original msg. ien in file 772, HLMTIENR=response ien set in HLMA2 - S HLMTIENO=HLMTIEN,HLMTIEN=$G(HLMTIENR) - ;Set special HL variables - S HLQUIT=0,HLNODE="",HLNEXT="D HLNEXT^HLCSUTL" - Q - ; -CLOSE(LOGLINK) ;close connection that was open in tag DIRECT - Q -PING ;ping another VAMC to test Link - ;set HLQUIET =1 to skip writes - ;look for HLTPUT to get turnaround time over network. - N DA,DIC,HLDP,HLDPNM,HLDPDM,HLCSOUT,HLDBSIZE,HLDREAD,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL,HLPARAM - N HCS,HCSCMD,HLCS,HCSDAT,HCSER,HCSEXIT,HCSTRACE,HLDT1,HLDRETR,HLRETRA,HLDBACK,HLDWAIT,HLTCPCS,INPUT,OUTPUT,POP,X,Y,HLX1,HLX2 - S HLQUIET=$G(HLQUIET) - S HLCS="",HCSTRACE="C: ",POP=1,INPUT="INPUT",OUTPUT="OUTPUT" - S DIC="^HLCS(870,",DIC(0)="QEAMZ" - D ^DIC Q:Y<0 - S HLDP=+Y,HLDPNM=Y(0,0),HLDPDM=$P($$PARAM^HLCS2,U,2) - ;I $P($G(^HLCS(870,HLDP,400)),U)="" W !,"Missing IP Address" Q - D SETUP^HLCSAC G:HLCS PINGQ - ; patch HL*1.6*122 - G:$$DONTPING^HLMA4 PINGQ - ;PING header=MSH^PING^domain^PING^logical link^datetime - S INPUT(1)="MSH^PING^"_HLDPDM_"^PING^"_HLDPNM_"^"_$$HTE^XLFDT($H) - D OPEN^HLCSAC - I HLCS D DNS G:HLCS PINGQ - D - . N $ETRAP,$ESTACK S $ETRAP="D PINGERR^HLMA" - . ;non-standard HL7 header; start block,header,end block - . S HLX1=$H - . ; - . ; HL*1.6*122 start - . ; replace flush character '!' with @IOF (! or #) - . ; W $C(11)_INPUT(1)_$C(28)_$C(13),! ;HL*1.6*115, restored ! char - . ; patch HL*1.6*140, flush character- HLTCPLNK("IOF") - . ; W $C(11)_INPUT(1)_$C(28)_$C(13),@IOF - . W $C(11)_INPUT(1)_$C(28)_$C(13),@HLTCPLNK("IOF") - . ; HL*1.6*122 end - . ; - . ;read response - . R X:HLDREAD - . S HLX2=$H - . S X=$P(X,$C(28)),HLCS=$S(X=INPUT(1):"PING worked",X="":"No response",1:"Incorrect response") - . ;Get roundtrip time - . K HLTPUT I X]"" S HLTPUT=$$HDIFF^XLFDT(HLX2,HLX1,2) - D CLOSE^%ZISTCP -PINGQ ;write back status and quit - I 'HLQUIET W !,HLCS,! - Q -PINGERR ;process errors from PING - S $ETRAP="G UNWIND^%ZTER",HLCS="-1^Error" - ;I $ZE["READ" S HLCS="-1^Error during read" - ;I $ZE["WRITE" S HLCS="-1^Error during write" - ; HL*1.6*115, SACC compliance - I $$EC^%ZOSV["READ" S HLCS="-1^Error during read" - I $$EC^%ZOSV["WRITE" S HLCS="-1^Error during write" - G UNWIND^%ZTER -DNS ; - ;openfail-try DNS lookup-Link must contain point to Domain Name - S POP=$G(POP) - S HLQUIET=$G(HLQUIET) - I 'HLQUIET W !,"Calling DNS" - N HLDOM,HLIP S HLCS="" - S HLDOM=$P(^HLCS(870,HLDP,0),U,7) - ; patch HL*1.6*122 start - S HLDOM("DNS")=$P($G(^HLCS(870,+$G(HLDP),0)),"^",8) - ; I 'HLDOM,'HLQUIET W !,"Domain Unknown" Q - I 'HLDOM,($L(HLDOM("DNS"),".")<3) D Q - . I 'HLQUIET W !,"Domain Unknown" - . S HLCS="-1^Connection Fail" - ; patch HL*1.6*122 end - I HLDOM S HLDOM=$P(^DIC(4.2,HLDOM,0),U) - ; patch HL*1.6*122 - ; I HLDOM]"" D Q:'POP - I HLDOM]""!($L(HLDOM("DNS"),".")>2) D Q:'POP - . I HLDOM["VA.GOV"&(HLDOM'[".MED.") S HLDOM=$P(HLDOM,".VA.GOV")_".MED.VA.GOV" - . I HLTCPORT=5000 S HLDOM="HL7."_HLDOM - . I HLTCPORT=5500 S HLDOM="MPI."_HLDOM - . ; patch HL*1.6*122 - . I ($L(HLDOM("DNS"),".")>2) S HLDOM=HLDOM("DNS") - . I 'HLQUIET W !,"Domain, "_HLDOM - . I 'HLQUIET W !,"Port: ",HLTCPORT - . S HLIP=$$ADDRESS^XLFNSLK(HLDOM) - . I HLIP]"",'HLQUIET W !,"DNS Returned: ",HLIP - . I HLIP]"" D - . . ;If more than one IP returned, try each, cache successful open - . . N HLI,HLJ,HLIP1 - . . F HLJ=1:1:$L(HLIP,",") D Q:'POP - . . . S HLIP1=$P(HLIP,",",HLJ) - . . . F HLI=1:1:HLDRETR W:'HLQUIET !,"Trying ",HLIP1 D CALL^%ZISTCP(HLIP1,HLTCPORT,1) Q:'POP - . . . I 'POP S $P(^HLCS(870,HLDP,400),U)=HLIP1 - . . . U IO - I POP S HLCS="-1^DNS Lookup Failed" +HLMA ;AISC/SAW-Message Administration Module ;10/25/2006 + ;;1.6;HEALTH LEVEL SEVEN;**19,43,58,63,66,82,91,109,115,133,132**;Oct 13, 1995;Build 6 + ;Per VHA Directive 2004-038, this routine should not be modified. +GENERATE(HLEID,HLARYTYP,HLFORMAT,HLRESLT,HLMTIEN,HLP) ; + ;Entry point to generate a deferred message + ; + ;This is a subroutine call with parameter passing. It returns a + ;value in the variable HLRESLT with 1 to 3 pieces separated by uparrows + ;as follows: 1st message ID^error code^error description + ;If no error occurs, only the first piece is returned equal to a unique + ;ID for the 1st message. If message was sent to more than 1 subscriber + ;than the other message IDs will be in the array HLRESLT(n)=ID + ;Otherwise, three pieces are returned with the + ;first piece equal to the message ID, if one was assigned, otherwise 0 + ; + ;Required Input Parameters + ; HLEID = Name or IEN of event driver protocol in the Protocol file + ; HLARYTYP = Array type. One of the following codes: + ; LM = local array containing a single message + ; LB = local array containig a batch of messages + ; GM = global array containing a single message + ; GB = global array containing a batch of messages + ; HLFORMAT = Format of array, 1 for pre-formatted in HL7 format, + ; otherwise 0 + ;NOTE: The parameter HLRESLT must be passed by reference + ; HLRESLT = The variable that will be returned to the calling + ; application as descibed above + ;Optional Parameters + ; HLMTIEN = IEN of entry in Message Text file where the message + ; being generated is to be stored. This parameter is + ; only passed for a batch type message + ;NOTE: The parameter HLP used for the following parameters must be + ; passed by reference + ; HLP("SECURITY") = A 1 to 40 character string + ; HLP("CONTPTR") = Continuation pointer, a 1 to 180 character string + ; HLP("NAMESPACE") = Passed in by application namespace - HL*1.6*91 + ; HLP("EXLCLUDE SUBSCRIBER",)= - A list of protocols to dynamically drop from the event protocol's subscriber multiple. + ; + ;can't have link open when generating new message + N HLTCP,HLTCPO,HLPRIO,HLMIDAR + S HLPRIO="D" + S HLRESLT="" + ;Check for required parameters +CONT I $G(HLEID)']""!($G(HLARYTYP)']"")!($G(HLFORMAT)']"") S HLRESLT="0^7^"_$G(^HL(771.7,7,0))_" at GENERATE^HLMA entry point" G EXIT + I 'HLEID S HLEID=$O(^ORD(101,"B",HLEID,0)) I 'HLEID S HLRESLT="0^1^"_$G(^HL(771.7,1,0)) G EXIT + N HLRESLT1,HLRESLTA S (HLRESLTA,HLRESLT1)="" + I "GL"'[$E(HLARYTYP) S HLRESLT="0^4^"_$G(^HL(771.7,4,0)) G EXIT + I $L($G(HLP("SECURITY")))>40 S HLRESLT="0^6^"_$G(^HL(771.7,6,0)) G EXIT + I $L($G(HLP("CONTPTR")))>180 S HLRESLT="0^11^"_$G(^HL(771.7,11,0)) G EXIT + I $D(HLL("LINKS")) D G:$G(HLRESLT)]"" EXIT + . N I,HLPNAM,HLPIEN,HLLNAM,HLLIEN + . S I=0 + . F S I=$O(HLL("LINKS",I)) Q:'I D Q:$G(HLRESLT)]"" + . . S HLPNAM=$P(HLL("LINKS",I),U) + . . S HLPIEN=+$O(^ORD(101,"B",HLPNAM,0)) + . . I $P($G(^ORD(101,HLPIEN,0)),U,4)'="S" S HLRESLT="0^15^Invalid Subscriber Protocol in HLL('LINKS'): "_HLL("LINKS",I) Q + . . S HLLNAM=$P(HLL("LINKS",I),U,2) + . . S HLLIEN=+$O(^HLCS(870,"B",HLLNAM,0)) + . . I '$D(^HLCS(870,HLLIEN,0)) S HLRESLT="0^15^Invalid HL Node in HLL('LINKS'): "_HLL("LINKS",I) Q + ;Extract data from Protocol file + D EVENT^HLUTIL1(HLEID,"15,20,771",.HLN) + S HLENROU=$G(HLN(20)),HLEXROU=$G(HLN(15)) + S HLP("GROUTINE")=$G(HLN(771)) K HLN I HLP("GROUTINE")']"",'HLFORMAT S HLRESLT="0^3^"_$G(^HL(771.7,3,0)) G EXIT + ;Create message ID and Message Text IEN if Message Text IEN not + ;previously created ('$G(HLMTIEN)) + I '$G(HLMTIEN) D CREATE^HLTF(.HLMID,.HLMTIEN,.HLDT,.HLDT1) + ;Get message ID if Message Text IEN already created + I '$G(HLMID) D + .S HLDT=$G(^HL(772,HLMTIEN,0)),HLMID=$P(HLDT,"^",6),HLDT=+HLDT + .S HLDT1=$$HLDATE^HLFNC(HLDT) + S HLMIDAR=0,HLRESLT=HLMID,HLP("DT")=HLDT,HLP("DTM")=HLDT1 + ;Execute entry action for event driver protocol + I HLENROU]"" X HLENROU + ;Invoke transaction processor + K HLDT,HLDT1,HLENROU + D GENERATE^HLTP(HLMID,HLMTIEN,HLEID,HLARYTYP,HLFORMAT,.HLRESLT1,.HLP) + ;HLMIDAR is array of message IDs, only set for broadcast messages + I HLMIDAR K HLMIDAR("N") M HLRESLT=HLMIDAR + S HLRESLT=HLRESLT_"^"_HLRESLT1 + ;Execute exit action for event driver protocol + I HLEXROU]"" X HLEXROU +EXIT ;Update status if Message Text file entry has been created + K HLTCP + I $D(HLMTIEN) D STATUS^HLTF0(HLMTIEN,$S($P(HLRESLT,"^",2):4,1:3),$S($P(HLRESLT,"^",2):$P(HLRESLT,"^",2),1:""),$S($P(HLRESLT,"^",2):$P(HLRESLT,"^",3),1:"")) + K HLDT,HLDT1,HLMID,HLRESLT1,HLENROU,HLEXROU + Q +DIRECT(HLEID,HLARYTYP,HLFORMAT,HLRESLT,HLMTIENO,HLP) ; + ;Entry point to generate an immediate message, must be TCP Logical Link + ;Input: + ; The same as GENERATE,with one additional subscript to the HLP input array: + ; + ; HLP("OPEN TIMEOUT") (optional, pass by reference) a number between + ; 1 and 120 that specifies how many seconds the DIRECT CONNECT should + ; try to open a connection before failing. It is killed upon completion. + ; + N HLTCP,HLTCPO,HLPRIO,HLSAN,HLN,HLMIDAR,HLMTIENR,ZMID,HLDIRECT + S HLRESLT="" + ;HLMTIENO=ien passed in, batch message + S HLMTIEN=$G(HLMTIENO) + I $G(HLP("OPEN TIMEOUT")),((HLP("OPEN TIMEOUT")\1)'=+HLP("OPEN TIMEOUT"))!HLP("OPEN TIMEOUT")>120 Q "0^4^INVALID OPEN TIMEOUT PARAMETER" + I $G(HLP("OPEN TIMEOUT")) D + .S HLDIRECT("OPEN TIMEOUT")=HLP("OPEN TIMEOUT") + .K HLP("OPEN TIMEOUT") + K HL,HLMTIENO + D INIT^HLFNC2(HLEID,.HL) + I $G(HL) S HLRESLT="0^"_HL Q + S HLPRIO="I" D CONT + ;HLMTIENO=original msg. ien in file 772, HLMTIENR=response ien set in HLMA2 + S HLMTIENO=HLMTIEN,HLMTIEN=$G(HLMTIENR) + ;Set special HL variables + S HLQUIT=0,HLNODE="",HLNEXT="D HLNEXT^HLCSUTL" + Q + ; +CLOSE(LOGLINK) ;close connection that was open in tag DIRECT + Q +PING ;ping another VAMC to test Link + ;set HLQUIET =1 to skip writes + ;look for HLTPUT to get turnaround time over network. + N DA,DIC,HLDP,HLDPNM,HLDPDM,HLCSOUT,HLDBSIZE,HLDREAD,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL,HLPARAM + N HCS,HCSCMD,HLCS,HCSDAT,HCSER,HCSEXIT,HCSTRACE,HLDT1,HLDRETR,HLRETRA,HLDBACK,HLDWAIT,HLTCPCS,INPUT,OUTPUT,POP,X,Y,HLX1,HLX2 + S HLQUIET=$G(HLQUIET) + S HLCS="",HCSTRACE="C: ",POP=1,INPUT="INPUT",OUTPUT="OUTPUT" + S DIC="^HLCS(870,",DIC(0)="QEAMZ" + D ^DIC Q:Y<0 + S HLDP=+Y,HLDPNM=Y(0,0),HLDPDM=$P($$PARAM^HLCS2,U,2) + ;I $P($G(^HLCS(870,HLDP,400)),U)="" W !,"Missing IP Address" Q + D SETUP^HLCSAC G:HLCS PINGQ + ;PING header=MSH^PING^domain^PING^logical link^datetime + S INPUT(1)="MSH^PING^"_HLDPDM_"^PING^"_HLDPNM_"^"_$$HTE^XLFDT($H) + D OPEN^HLCSAC + I HLCS D DNS G:HLCS PINGQ + D + . N $ETRAP,$ESTACK S $ETRAP="D PINGERR^HLMA" + . ;non-standard HL7 header; start block,header,end block + . S HLX1=$H + . W $C(11)_INPUT(1)_$C(28)_$C(13),! ;HL*1.6*115, restored ! char + . ;read response + . R X:HLDREAD + . S HLX2=$H + . S X=$P(X,$C(28)),HLCS=$S(X=INPUT(1):"PING worked",X="":"No response",1:"Incorrect response") + . ;Get roundtrip time + . K HLTPUT I X]"" S HLTPUT=$$HDIFF^XLFDT(HLX2,HLX1,2) + D CLOSE^%ZISTCP +PINGQ ;write back status and quit + I 'HLQUIET W !,HLCS,! + Q +PINGERR ;process errors from PING + S $ETRAP="G UNWIND^%ZTER",HLCS="-1^Error" + ;I $ZE["READ" S HLCS="-1^Error during read" + ;I $ZE["WRITE" S HLCS="-1^Error during write" + ; HL*1.6*115, SACC compliance + I $$EC^%ZOSV["READ" S HLCS="-1^Error during read" + I $$EC^%ZOSV["WRITE" S HLCS="-1^Error during write" + G UNWIND^%ZTER +DNS ; + ;openfail-try DNS lookup-Link must contain point to Domain Name + S POP=$G(POP) + S HLQUIET=$G(HLQUIET) + I 'HLQUIET W !,"Calling DNS" + N HLDOM,HLIP S HLCS="" + S HLDOM=$P(^HLCS(870,HLDP,0),U,7) + I 'HLDOM,'HLQUIET W !,"Domain Unknown" Q + I HLDOM S HLDOM=$P(^DIC(4.2,HLDOM,0),U) + I HLDOM]"" D Q:'POP + . I HLDOM["VA.GOV"&(HLDOM'[".MED.") S HLDOM=$P(HLDOM,".VA.GOV")_".MED.VA.GOV" + . I HLTCPORT=5000 S HLDOM="HL7."_HLDOM + . I HLTCPORT=5500 S HLDOM="MPI."_HLDOM + . I 'HLQUIET W !,"Domain, "_HLDOM + . I 'HLQUIET W !,"Port: ",HLTCPORT + . S HLIP=$$ADDRESS^XLFNSLK(HLDOM) + . I HLIP]"",'HLQUIET W !,"DNS Returned: ",HLIP + . I HLIP]"" D + . . ;If more than one IP returned, try each, cache successful open + . . N HLI,HLJ,HLIP1 + . . F HLJ=1:1:$L(HLIP,",") D Q:'POP + . . . S HLIP1=$P(HLIP,",",HLJ) + . . . F HLI=1:1:HLDRETR W:'HLQUIET !,"Trying ",HLIP1 D CALL^%ZISTCP(HLIP1,HLTCPORT,1) Q:'POP + . . . I 'POP S $P(^HLCS(870,HLDP,400),U)=HLIP1 + . . . U IO + I POP S HLCS="-1^DNS Lookup Failed" diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLOAPI1.m b/r/HEALTH_LEVEL_SEVEN-HL/HLOAPI1.m index abb1656e..109340d0 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLOAPI1.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLOAPI1.m @@ -1,213 +1,222 @@ -HLOAPI1 ;ALB/CJM-HL7 - Developer API's for sending & receiving messages(continued) ;07/18/2007 - ;;1.6;HEALTH LEVEL SEVEN;**126,132,134,137**;Oct 13, 1995;Build 21 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; -SENDONE(HLMSTATE,PARMS,WHOTO,ERROR) ; - ;Sends the message to a single receiving application. - ; - ;Input: - ;HLMSTATE() - (pass by reference, required) This array is used by the HL7 package to track the progress of the message. The application MUST NOT touch it - ;PARMS( *pass by reference* - ; "APP ACK RESPONSE")= to call when the app ack is received (optional) - ; (NOTE: For batch messages, HLO best supports returning application - ; acknowledgments via a batch response. However, non-VistA systems - ; may return individual messages as application acknowledgments to - ; messages within the original batch message, so for applications - ; sending batch messages might best code the "APP ACK RESPONSE" - ; routine to first check whether the response message is a batch. - ; - ; "ACCEPT ACK RESPONSE")= to call when the commit ack is received (optional) - ; "ACCEPT ACK TYPE") = (optional, defaults to AL) - ; "APP ACK TYPE") = (optional, defaults to NE) - ; "FAILURE RESPONSE" - ^ (optional) The sending application routine to execute when the transmission of the message fails, i.e., the message can not be sent or no commit ack is received. - ; "QUEUE" - (optional) An application can name its own private queue - just a string up to 20 characters, it should be namespaced. - ; "SECURITY")=security information to include in the header segment, SEQ 8 (optional) - ; "SENDING APPLICATION")=name of sending app (required, 60 maximum length) - ; - ; WHOTO (required,pass by reference) an array specifying a single recipient. These subscripts are allowed: - ; - ; "RECEIVING APPLICATION" - (string, 60 char max, required) - ; - ; EXACTLY ONE of these parameters must be provided to identify the Receiving Facility: - ; - ; "FACILITY LINK IEN" - ien of the logical link - ; "FACILITY LINK NAME" - name of the logical link - ; "INSTITUTION IEN" - ptr to the INSTITUTION file - ; "STATION NUMBER" - station # with suffix - ; - ; EXACTLY ONE of these MAY be provided - optionally - to identify the interface engine to route the message through: - ; - ; "IE LINK IEN" - ptr to a logical link for the interface engine - ; "IE LINK NAME" - name of the logical link for the interface engine - ; - ;Output: - ; Function returns the ien of the message in file 778 on success, 0 on failure - ; HLMSTATE() - (pass by reference, required) This array is used by the HL7 package to track the progress of the message. The application MUST NOT touch it! - ; ERROR (pass by reference, optional) - on failure, will contain an error message - ; PARMS - left undefined when the function returns - ; WHOTO - left undefined when the function returns - ; - ; - N SUCCESS,ERR1,ERR2 - S SUCCESS=0 - D - .I '$G(HLMSTATE("BODY")),'$G(HLMSTATE("UNSTORED LINES")) S ERROR="MESSAGE NOT YET CREATED" Q - .; - .I $$CHKPARMS^HLOAPI2(.HLMSTATE,.PARMS,.ERR1)&$$CHKWHO^HLOAPI2(.HLMSTATE,.WHOTO,.ERR2) D - ..I $$SEND(.HLMSTATE,.ERROR) S SUCCESS=1 - .E D - ..S ERROR=$G(ERR1)_": "_$G(ERR2) - ..D DONTSEND(.HLMSTATE,ERROR) - K PARMS,WHOTO - Q $S(SUCCESS:HLMSTATE("IEN"),1:0) - ; -SENDMANY(HLMSTATE,PARMS,WHOTO) ; - ;Sends the message to a list of receiving applications - ; - ;Input: Same as for $$SENDONE, except WHOTO is a list. - ; WHOTO (pass by reference) - ; Specifies a list of recipients. Each recipient should be on the - ; list as WHOTO(i), where i=1,2,3,4, etc. for as many messages as to - ; send. At each subscript WHOTO(i), the same lower level subscripts - ; may be defined as in the $$SENDONE API. For example: - ; - ; WHOTO(1,"LINK NAME")="VAALB" - ; WHOTO(1,"RECEIVING APPLICATION")="MPI" - ; WHOTO(2,"STATION NUMBER")=500 - ; WHOTO(2,"RECEIVING APPLICATION")="MPI" - ; - ; - ;Output: - ; Function returns 1 if a message is queued to be sent to each intended recipient, 0 otherwise - ; PARMS - left undefined when the function returns - ; WHOTO (pass by reference) returns the status of each message to be sent in the format: - ; (,"QUEUED")= <1 if queued to be sent, 0 otherwise) - ; (,"IEN")= - ; (,"ERROR")= error message if an error was encountered (status=0), not defined otherwise - ; - ; - N ERROR,RETURN,WHO,STATE,I - S RETURN=1 - I '$G(HLMSTATE("BODY")),'$G(HLMSTATE("UNSTORED LINES")) D K PARMS Q 0 - .S ERROR="MESSAGE NOT YET CREATED" - .S I=0 F S I=$O(WHOTO(I)) Q:'I S WHOTO(I,"QUEUED")=0,WHOTO(I,"IEN")=0,WHOTO(I,"ERROR")=ERROR - ; - I '$$CHKPARMS^HLOAPI2(.HLMSTATE,.PARMS,.ERROR) D K PARMS Q 0 - .S I=0 F S I=$O(WHOTO(I)) Q:'I D - ..K WHO M WHO=WHOTO(I) - ..K STATE M STATE=HLMSTATE S STATE("IEN")="" - ..S WHOTO(I,"QUEUED")=0 - ..D DONTSEND(.STATE,$G(ERROR)) - ..S WHOTO(I,"IEN")=$G(STATE("IEN")) - ..S WHOTO(I,"ERROR")=ERROR - ; - S I=0 F S I=$O(WHOTO(I)) Q:'I D - .K WHO M WHO=WHOTO(I) - .K STATE M STATE=HLMSTATE S STATE("IEN")="" - .S ERROR="" - .I $$CHKWHO^HLOAPI2(.STATE,.WHO,.ERROR) D - ..I $$SEND(.STATE,.ERROR) D - ...S WHOTO(I,"QUEUED")=1 - ...S WHOTO(I,"IEN")=STATE("IEN") - ...S WHOTO(I,"ERROR")="" - ..E D - ...S WHOTO(I,"QUEUED")=0 - ...S WHOTO(I,"IEN")=$G(STATE("IEN")) - ...S WHOTO(I,"ERROR")=$G(ERROR) - ...S RETURN=0 - .E D ;who not adequately determined - ..S WHOTO(I,"QUEUED")=0,RETURN=0 - ..D DONTSEND(.STATE,$G(ERROR)) - ..S WHOTO(I,"IEN")=$G(STATE("IEN")),WHOTO(I,"ERROR")=$G(ERROR) - K PARMS - Q RETURN - ; -SENDSUB(HLMSTATE,PARMS,MESSAGES) ; - ;Sends the message to a list of receiving applications based on the HL7 Subscription Registry - ; - ;Input: - ; HLMSTATE (pass by reference, required) same as $$SENDMANY - ; PARMS (pass by reference, required) same as $$SENDMANY, with one additional subscript: - ; "SUBSCRIPTION IEN" - the ien of an entry in the HL7 Subscription Registry, defining the intended recipients of this message - ; - ;Output: - ; Function returns 1 if a message is queued to be sent to each intended recipient, 0 otherwise - ; PARMS - left undefined when the function returns - ; MESSAGES (pass by reference) returns the status of each message to be sent in this format, where subien is the ien of the recipient in the RECIPEINTS subfile of the HL7 Subscription Registry - ; (,"QUEUED")= <1 if queued to be sent, 0 otherwise) - ; (,"IEN")= - ; (,"ERROR")= error message if an error was encountered (status=0), not defined otherwise - ; - ; - K MESSAGES - N ERROR,RETURN,STATE,SUBIEN,WHO - ; - S RETURN=1 - ; - ; - I '$G(HLMSTATE("BODY")),'$G(HLMSTATE("UNSTORED LINES")) S ERROR="MESSAGE NOT YET CREATED" K PARMS Q 0 - I '$G(PARMS("SUBSCRIPTION IEN")) S ERROR="SUBSCRIPTION REGISTRY IEN NOT PROVIDED" K PARMS Q 0 - ; - I '$$CHKPARMS^HLOAPI2(.HLMSTATE,.PARMS,.ERROR) D K PARMS Q 0 - .S SUBIEN=0 F S SUBIEN=$$NEXT^HLOASUB(PARMS("SUBSCRIPTION IEN"),.WHO) Q:'SUBIEN D - ..N SARY,HARY - ..S HARY="STATE(""HDR"")" - ..S SARY="STATE(""STATUS"")" - ..K STATE M STATE=HLMSTATE S STATE("IEN")="" - ..;move parameters into HLMSTATE - ..S @SARY@("LINK IEN")=WHO("LINK IEN") - ..S @SARY@("LINK NAME")=WHO("LINK NAME") - ..S @HARY@("RECEIVING APPLICATION")=WHO("RECEIVING APPLICATION") - ..M @HARY@("RECEIVING FACILITY")=WHO("RECEIVING FACILITY") - ..D DONTSEND(.STATE,$G(ERROR)) - ..S MESSAGES(SUBIEN,"QUEUED")=0 - ..S MESSAGES(SUBIEN,"IEN")=$G(STATE("IEN")) - ..S MESSAGES(SUBIEN,"ERROR")=$G(ERROR) - ; - F S SUBIEN=$$NEXT^HLOASUB(PARMS("SUBSCRIPTION IEN"),.WHO) Q:'SUBIEN D - .N SARY,HARY - .S HARY="STATE(""HDR"")" - .S SARY="STATE(""STATUS"")" - .K STATE M STATE=HLMSTATE S STATE("IEN")="" - .;move parameters into HLMSTATE - .S @SARY@("LINK IEN")=WHO("LINK IEN") - .S @SARY@("LINK NAME")=WHO("LINK NAME") - .S @HARY@("RECEIVING APPLICATION")=WHO("RECEIVING APPLICATION") - .M @HARY@("RECEIVING FACILITY")=WHO("RECEIVING FACILITY") - .S ERROR="" - .I $$SEND(.STATE,.ERROR) D - ..S MESSAGES(SUBIEN,"QUEUED")=1 - .E D - ..S MESSAGES(SUBIEN,"QUEUED")=0,RETURN=0 - .S MESSAGES(SUBIEN,"IEN")=$G(STATE("IEN")),MESSAGES(SUBIEN,"ERROR")=$G(ERROR) - K PARMS - Q RETURN - ; -SEND(HLMSTATE,ERROR) ; - ; - K ERROR - I HLMSTATE("UNSTORED LINES"),'$$SAVEMSG^HLOF777(.HLMSTATE) S ERROR="$$SAVE^HLOF777 FAILED!" Q 0 - ; - I '$$SAVEMSG^HLOF778(.HLMSTATE) S ERROR="$$SAVE^HLOF778 FAILED!" Q 0 - I HLMSTATE("BATCH"),$L($G(HLMSTATE("STATUS","SEQUENCE QUEUE"))) S ERROR="SEQUENCE QUEUES NOT SUPPORTED FOR BATCH MESSAGES" Q 0 - I $L($G(HLMSTATE("STATUS","SEQUENCE QUEUE"))) D - .S HLMSTATE("STATUS","MOVED TO OUT QUEUE")=$$SQUE^HLOQUE(HLMSTATE("STATUS","SEQUENCE QUEUE"),HLMSTATE("STATUS","LINK NAME"),$G(HLMSTATE("STATUS","PORT")),HLMSTATE("STATUS","QUEUE"),HLMSTATE("IEN")) D:HLMSTATE("STATUS","MOVED TO OUT QUEUE") - ..S $P(^HLB(HLMSTATE("IEN"),5),"^",2)=1 - E D - .D OUTQUE^HLOQUE(HLMSTATE("STATUS","LINK NAME"),$G(HLMSTATE("STATUS","PORT")),HLMSTATE("STATUS","QUEUE"),HLMSTATE("IEN")) - Q HLMSTATE("IEN") - ; -DONTSEND(HLMSTATE,ERROR) ; - ;This procedure does NOT send a message. Rather, it creates an entry in file 778 with the status ER. - ;Input: - ; HLMSTATE - pass-by-reference - ; ERROR (optional, pass-by-value) error text to store with the message - ;Output: none - ; - I HLMSTATE("UNSTORED LINES"),'$$SAVEMSG^HLOF777(.HLMSTATE) ; just continue - ; - S HLMSTATE("STATUS")="ER" - S HLMSTATE("STATUS","PURGE")=$$FMADD^XLFDT(HLMSTATE("DT/TM CREATED"),HLMSTATE("SYSTEM","ERROR PURGE")) - S HLMSTATE("STATUS","ERROR TEXT")=$G(ERROR) - I '$$SAVEMSG^HLOF778(.HLMSTATE) ;already reported an error to the app - Q +HLOAPI1 ;ALB/CJM-HL7 - Developer API's for sending & receiving messages(continued) ;02/06/2007 + ;;1.6;HEALTH LEVEL SEVEN;**126,132,134**;Oct 13, 1995;Build 30 + ;Per VHA Directive 2004-038, this routine should not be modified. + ; +SENDONE(HLMSTATE,PARMS,WHOTO,ERROR) ; + ;Sends the message to a single receiving application. + ; + ;Input: + ;HLMSTATE() - (pass by reference, required) This array is used by the HL7 package to track the progress of the message. The application MUST NOT touch it + ;PARMS( *pass by reference* + ; "APP ACK RESPONSE")= to call when the app ack is received (optional) + ; (NOTE: For batch messages, HLO best supports returning application + ; acknowledgments via a batch response. However, non-VistA systems + ; may return individual messages as application acknowledgments to + ; messages within the original batch message, so for applications + ; sending batch messages might best code the "APP ACK RESPONSE" + ; routine to first check whether the response message is a batch. + ; + ; "ACCEPT ACK RESPONSE")= to call when the commit ack is received (optional) + ; "ACCEPT ACK TYPE") = (optional, defaults to AL) + ; "APP ACK TYPE") = (optional, defaults to NE) + ; "FAILURE RESPONSE" - ^ (optional) The sending application routine to execute when the transmission of the message fails, i.e., the message can not be sent or no commit ack is received. + ; "QUEUE" - (optional) An application can name its own private queue - just a string up to 20 characters, it should be namespaced. + ; "SECURITY")=security information to include in the header segment, SEQ 8 (optional) + ; "SENDING APPLICATION")=name of sending app (required, 60 maximum length) + ; + ; WHOTO (required,pass by reference) an array specifying a single recipient. These subscripts are allowed: + ; + ; "RECEIVING APPLICATION" - (string, 60 char max, required) + ; + ; EXACTLY ONE of these parameters must be provided to identify the Receiving Facility: + ; + ; "FACILITY LINK IEN" - ien of the logical link + ; "FACILITY LINK NAME" - name of the logical link + ; "INSTITUTION IEN" - ptr to the INSTITUTION file + ; "STATION NUMBER" - station # with suffix + ; + ; EXACTLY ONE of these MAY be provided - optionally - to identify the interface engine to route the message through: + ; + ; "IE LINK IEN" - ptr to a logical link for the interface engine + ; "IE LINK NAME" - name of the logical link for the interface engine + ; + ;Output: + ; Function returns the ien of the message in file 778 on success, 0 on failure + ; HLMSTATE() - (pass by reference, required) This array is used by the HL7 package to track the progress of the message. The application MUST NOT touch it! + ; ERROR (pass by reference, optional) - on failure, will contain an error message + ; PARMS - left undefined when the function returns + ; WHOTO - left undefined when the function returns + ; + ; + N SUCCESS,ERR1,ERR2 + S SUCCESS=0 + D + .I '$G(HLMSTATE("BODY")),'$G(HLMSTATE("UNSTORED LINES")) S ERROR="MESSAGE NOT YET CREATED" Q + .; + .I $$CHKPARMS^HLOAPI2(.HLMSTATE,.PARMS,.ERR1)&$$CHKWHO(.HLMSTATE,.WHOTO,.ERR2) D + ..I $$SEND(.HLMSTATE,.ERROR) S SUCCESS=1 + .E D + .S ERROR=$G(ERR1)_": "_$G(ERR2) + .D DONTSEND(.HLMSTATE,ERROR) + K PARMS,WHOTO + Q $S(SUCCESS:HLMSTATE("IEN"),1:0) + ; +SENDMANY(HLMSTATE,PARMS,WHOTO) ; + ;Sends the message to a list of receiving applications + ; + ;Input: Same as for $$SENDONE, except WHOTO is a list. + ; WHOTO (pass by reference) + ; Specifies a list of recipients. Each recipient should be on the + ; list as WHOTO(i), where i=1,2,3,4, etc. for as many messages as to + ; send. At each subscript WHOTO(i), the same lower level subscripts + ; may be defined as in the $$SENDONE API. For example: + ; + ; WHOTO(1,"LINK NAME")="VAALB" + ; WHOTO(1,"RECEIVING APPLICATION")="MPI" + ; WHOTO(2,"STATION NUMBER")=500 + ; WHOTO(2,"RECEIVING APPLICATION")="MPI" + ; + ; + ;Output: + ; Function returns 1 if a message is queued to be sent to each intended recipient, 0 otherwise + ; PARMS - left undefined when the function returns + ; WHOTO (pass by reference) returns the status of each message to be sent in the format: + ; (,"QUEUED")= <1 if queued to be sent, 0 otherwise) + ; (,"IEN")= + ; (,"ERROR")= error message if an error was encountered (status=0), not defined otherwise + ; + ; + N ERROR,RETURN,WHO,STATE,I + S RETURN=1 + I '$G(HLMSTATE("BODY")),'$G(HLMSTATE("UNSTORED LINES")) D K PARMS Q 0 + .S ERROR="MESSAGE NOT YET CREATED" + .S I=0 F S I=$O(WHOTO(I)) Q:'I S WHOTO(I,"QUEUED")=0,WHOTO(I,"IEN")=0,WHOTO(I,"ERROR")=ERROR + ; + I '$$CHKPARMS^HLOAPI2(.HLMSTATE,.PARMS,.ERROR) D K PARMS Q 0 + .S I=0 F S I=$O(WHOTO(I)) Q:'I D + ..K WHO M WHO=WHOTO(I) + ..K STATE M STATE=HLMSTATE S STATE("IEN")="" + ..S WHOTO(I,"QUEUED")=0 + ..D DONTSEND(.STATE,$G(ERROR)) + ..S WHOTO(I,"IEN")=$G(STATE("IEN")) + ..S WHOTO(I,"ERROR")=ERROR + ; + S I=0 F S I=$O(WHOTO(I)) Q:'I D + .K WHO M WHO=WHOTO(I) + .K STATE M STATE=HLMSTATE S STATE("IEN")="" + .S ERROR="" + .I $$CHKWHO(.STATE,.WHO,.ERROR) D + ..I $$SEND(.STATE,.ERROR) D + ...S WHOTO(I,"QUEUED")=1 + ...S WHOTO(I,"IEN")=STATE("IEN") + ...S WHOTO(I,"ERROR")="" + ..E D + ...S WHOTO(I,"QUEUED")=0 + ...S WHOTO(I,"IEN")=$G(STATE("IEN")) + ...S WHOTO(I,"ERROR")=$G(ERROR) + ...S RETURN=0 + .E D ;who not adequately determined + ..S WHOTO(I,"QUEUED")=0,RETURN=0 + ..D DONTSEND(.STATE,$G(ERROR)) + ..S WHOTO(I,"IEN")=$G(STATE("IEN")),WHOTO(I,"ERROR")=$G(ERROR) + K PARMS + Q RETURN + ; +SENDSUB(HLMSTATE,PARMS,MESSAGES) ; + ;Sends the message to a list of receiving applications based on the HL7 Subscription Registry + ; + ;Input: + ; HLMSTATE (pass by reference, required) same as $$SENDMANY + ; PARMS (pass by reference, required) same as $$SENDMANY, with one additional subscript: + ; "SUBSCRIPTION IEN" - the ien of an entry in the HL7 Subscription Registry, defining the intended recipients of this message + ; + ;Output: + ; Function returns 1 if a message is queued to be sent to each intended recipient, 0 otherwise + ; PARMS - left undefined when the function returns + ; MESSAGES (pass by reference) returns the status of each message to be sent in this format, where subien is the ien of the recipient in the RECIPEINTS subfile of the HL7 Subscription Registry + ; (,"QUEUED")= <1 if queued to be sent, 0 otherwise) + ; (,"IEN")= + ; (,"ERROR")= error message if an error was encountered (status=0), not defined otherwise + ; + ; + K MESSAGES + N ERROR,RETURN,STATE,SUBIEN,WHO + ; + S RETURN=1 + ; + ; + I '$G(HLMSTATE("BODY")),'$G(HLMSTATE("UNSTORED LINES")) S ERROR="MESSAGE NOT YET CREATED" K PARMS Q 0 + I '$G(PARMS("SUBSCRIPTION IEN")) S ERROR="SUBSCRIPTION REGISTRY IEN NOT PROVIDED" K PARMS Q 0 + ; + I '$$CHKPARMS^HLOAPI2(.HLMSTATE,.PARMS,.ERROR) D K PARMS Q 0 + .S SUBIEN=0 F S SUBIEN=$$NEXT^HLOASUB(PARMS("SUBSCRIPTION IEN"),.WHO) Q:'SUBIEN D + ..N SARY,HARY + ..S HARY="STATE(""HDR"")" + ..S SARY="STATE(""STATUS"")" + ..K STATE M STATE=HLMSTATE S STATE("IEN")="" + ..;move parameters into HLMSTATE + ..S @SARY@("LINK IEN")=WHO("LINK IEN") + ..S @SARY@("LINK NAME")=WHO("LINK NAME") + ..S @HARY@("RECEIVING APPLICATION")=WHO("RECEIVING APPLICATION") + ..M @HARY@("RECEIVING FACILITY")=WHO("RECEIVING FACILITY") + ..D DONTSEND(.STATE,$G(ERROR)) + ..S MESSAGES(SUBIEN,"QUEUED")=0 + ..S MESSAGES(SUBIEN,"IEN")=$G(STATE("IEN")) + ..S MESSAGES(SUBIEN,"ERROR")=$G(ERROR) + ; + F S SUBIEN=$$NEXT^HLOASUB(PARMS("SUBSCRIPTION IEN"),.WHO) Q:'SUBIEN D + .N SARY,HARY + .S HARY="STATE(""HDR"")" + .S SARY="STATE(""STATUS"")" + .K STATE M STATE=HLMSTATE S STATE("IEN")="" + .;move parameters into HLMSTATE + .S @SARY@("LINK IEN")=WHO("LINK IEN") + .S @SARY@("LINK NAME")=WHO("LINK NAME") + .S @HARY@("RECEIVING APPLICATION")=WHO("RECEIVING APPLICATION") + .M @HARY@("RECEIVING FACILITY")=WHO("RECEIVING FACILITY") + .S ERROR="" + .I $$SEND(.STATE,.ERROR) D + ..S MESSAGES(SUBIEN,"QUEUED")=1 + .E D + ..S MESSAGES(SUBIEN,"QUEUED")=0,RETURN=0 + .S MESSAGES(SUBIEN,"IEN")=$G(STATE("IEN")),MESSAGES(SUBIEN,"ERROR")=$G(ERROR) + K PARMS + Q RETURN + ; +SEND(HLMSTATE,ERROR) ; + ; + K ERROR + I HLMSTATE("UNSTORED LINES"),'$$SAVEMSG^HLOF777(.HLMSTATE) S ERROR="$$SAVE^HLOF777 FAILED!" Q 0 + ; + I '$$SAVEMSG^HLOF778(.HLMSTATE) S ERROR="$$SAVE^HLOF778 FAILED!" Q 0 + D OUTQUE^HLOQUE(HLMSTATE("STATUS","LINK NAME"),$G(HLMSTATE("STATUS","PORT")),HLMSTATE("STATUS","QUEUE"),HLMSTATE("IEN")) + Q HLMSTATE("IEN") + ; +DONTSEND(HLMSTATE,ERROR) ; + ;This procedure does NOT send a message. Rather, it creates an entry in file 778 with the + ;of "SE". + ;Input: + ; HLMSTATE - pass-by-reference + ; ERROR (optional, pass-by-value) error text to store with the message + ;Output: none + ; + I HLMSTATE("UNSTORED LINES"),'$$SAVEMSG^HLOF777(.HLMSTATE) ; just continue + ; + S HLMSTATE("STATUS")="SE" + S HLMSTATE("STATUS","PURGE")=$$FMADD^XLFDT(HLMSTATE("DT/TM CREATED"),HLMSTATE("SYSTEM","ERROR PURGE")) + S HLMSTATE("STATUS","ERROR TEXT")=$G(ERROR) + I '$$SAVEMSG^HLOF778(.HLMSTATE) ;already reported an error to the app + Q + ; +CHKWHO(HLMSTATE,WHOTO,ERROR) ; + N RETURN,I + S RETURN=1 + I '$$CHECKWHO^HLOASUB1(.WHOTO,.RETURN,.ERROR) S RETURN=0 + ; + ;move parameters into HLMSTATE + S HLMSTATE("STATUS","LINK IEN")=$G(RETURN("LINK IEN")) + S HLMSTATE("STATUS","LINK NAME")=$G(RETURN("LINK NAME")) + S HLMSTATE("STATUS","PORT")=$P($G(RETURN("RECEIVING FACILITY",2)),":",2) + S HLMSTATE("HDR","RECEIVING APPLICATION")=$G(RETURN("RECEIVING APPLICATION")) + F I=1:1:3 S HLMSTATE("HDR","RECEIVING FACILITY",I)=$G(RETURN("RECEIVING FACILITY",I)) + Q RETURN diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLOAPI2.m b/r/HEALTH_LEVEL_SEVEN-HL/HLOAPI2.m index bb3c49c9..3202ab73 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLOAPI2.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLOAPI2.m @@ -1,179 +1,156 @@ -HLOAPI2 ;ALB/CJM-HL7 - Developer API's for sending application acks ;07/30/2007 - ;;1.6;HEALTH LEVEL SEVEN;**126,131,133,134,137**;Oct 13, 1995;Build 21 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; -ACK(HLMSTATE,PARMS,ACK,ERROR) ;Default behavior is to return a general - ;application ack. The application may optionally specify the message - ;type and event or call $$ADDSEG^HLOAPI to add segments. - ;A generic MSA segment (components 1-3) is added automatically IF the - ;application doesn't call $$ADDSEG^HLOAPI to add an MSA segment as the - ;FIRST segment following the header. - ;$$SENDACK must be called when the ack is completed. The return - ;destination is determined automatically from the original message - ; - ;This API should NOT be called for batch messages, use $$BATCHACK instead. - ;Input: - ; HLMSTATE (pass by reference, required) the array obtained by calling $$STARTMSG^HLOPRS when parsing the original message - ; PARMS (pass by reference) These subscripts may be defined: - ; "ACK CODE" (required) MSA1[ {AA,AE,AR} - ; "ERROR MESSAGE" - MSA3, should be used only if AE or AR - ; "ACCEPT ACK RESPONSE" - the to call when the commit ack is received (optional) - ; "ACCEPT ACK TYPE" - {AL,NE} (optional, defaults to AL) - ; "CONTINUATION POINTER" (optional)indicates a fragmented message - ; "COUNTRY" - the 3 character country code (optional) - ; "EVENT" - the 3 character event type (optional, defaults to the event code of the original message) - ; "ENCODING CHARACTERS" - the four HL7 encoding characters (optional,defaults to "^~\&" - ; "FAILURE RESPONSE" (optional) the ^ that the sending application routine should execute if the transmission of the message fails, i.e., the message can not be sent or a requested commit ack is not received. - ; "FIELD SEPARATOR" - field separator (optional, defaults to "|") - ; "MESSAGE TYPE" - if not defined, ACK is used - ; "MESSAGE STRUCTURE" (optional) - ; "QUEUE" - (optional) An application can name its own private queue (a string under 20 characters,namespaced). The default is the name of the queue of the original message - ; "SECURITY" (optional) security information to include in the header segment, SEQ 8 (optional) - ; "VERSION" - the HL7 Version ID (optional, defaults to 2.4) - ;Output: - ; Function returns 1 on success, 0 on failure - ; PARMS - left undefined when the function returns - ; ACK (pass by reference, required) the acknowledgment message being built. - ; ERROR (pass by reference) error msg - N I,SEG,TOLINK,SUCCESS - S SUCCESS=0,ERROR="" - ; - D - .N PORT - .I $G(PARMS("ACK CODE"))'="AA",$G(PARMS("ACK CODE"))'="AE",$G(PARMS("ACK CODE"))'="AR" S ERROR="INVALID ACK CODE" Q - .; - .I '$G(HLMSTATE("IEN")) S ERROR="ORIGINAL MESSAGE TO ACKNOWLEDGE IS NOT IDENTIFIED" Q - .I $G(HLMSTATE("BATCH")) S ERROR="BATCH ACKNOWLEDGMENTS MUST USE $$BATCHACK^HLOAPI3" Q - .; - .I $G(HLMSTATE("HDR","MESSAGE CONTROL ID"))="" S ERROR="MESSAGE CONTROL ID MUST EXIST TO RETURN AN APPLICATION ACK" Q - .S PARMS("MESSAGE TYPE")=$G(PARMS("MESSAGE TYPE"),"ACK") - .S:PARMS("MESSAGE TYPE")="ACK" PARMS("MESSAGE STRUCTURE")="ACK" - .S PARMS("EVENT")=$G(PARMS("EVENT"),$G(HLMSTATE("HDR","EVENT"))) - .I $$NEWMSG^HLOAPI(.PARMS,.ACK) ;can't fail! - .; - .;if the return link can not be determined, the HL Logical Link file has a problem that must be fixed at the site - .S PORT=$P(HLMSTATE("HDR","SENDING FACILITY",2),":",2) - .S TOLINK=$$ACKLINK(.HLMSTATE) - .I TOLINK="" S ERROR="TRANSMISSION LINK FOR APPLICATION ACK CANNOT BE DETERMINED" Q - .I 'PORT S PORT=$$PORT2^HLOTLNK(TOLINK) - .; - .S ACK("HDR","APP ACK TYPE")="NE" - .S ACK("HDR","ACCEPT ACK TYPE")=$G(PARMS("ACCEPT ACK TYPE"),"AL") - .S ACK("STATUS","QUEUE")=$G(PARMS("QUEUE"),$G(HLMSTATE("STATUS","QUEUE"))) - .S ACK("STATUS","PORT")=PORT - .S ACK("HDR","SECURITY")=$G(PARMS("SECURITY")) - .S ACK("HDR","SENDING APPLICATION")=$G(HLMSTATE("HDR","RECEIVING APPLICATION")) - .S ACK("HDR","RECEIVING APPLICATION")=$G(HLMSTATE("HDR","SENDING APPLICATION")) - .F I=1:1:3 S ACK("HDR","RECEIVING FACILITY",I)=$G(HLMSTATE("HDR","SENDING FACILITY",I)) - .S ACK("ACK TO","STATUS")=$S(PARMS("ACK CODE")="AA":"SU",1:"ER") - .S ACK("ACK TO")=$G(HLMSTATE("HDR","MESSAGE CONTROL ID")) - .S ACK("ACK TO","IEN")=HLMSTATE("IEN") - .S ACK("STATUS","LINK NAME")=TOLINK - .S ACK("LINE COUNT")=0 - .S ACK("MSA")="MSA"_ACK("HDR","FIELD SEPARATOR")_PARMS("ACK CODE")_ACK("HDR","FIELD SEPARATOR")_$G(HLMSTATE("HDR","MESSAGE CONTROL ID"))_ACK("HDR","FIELD SEPARATOR")_$G(PARMS("ERROR MESSAGE")) - .S SUCCESS=1 - K PARMS - K:'SUCCESS ACK - Q SUCCESS - ; -SENDACK(ACK,ERROR) ;This is used to signal that an application acknowledgment is complete. - ;Input: - ; ACK (pass by reference,required) An array that contains the acknowledgment msg - ;Output: - ; Function returns 1 on success, 0 on failure - ; ERROR (pass by reference) error msg - ; - N SEG - ;if the application added its own MSA, then the ACK("MSA") node was killed - I $D(ACK("MSA")) S SEG(1)=ACK("MSA") D ADDSEG^HLOMSG(.ACK,.SEG) - ; - I $$SEND^HLOAPI1(.ACK,.ERROR) Q 1 - Q 0 - ; -ACKLINK(HLMSTATE) ; - ;Finds the link to return the application ack to. - N LINK - S LINK=$$RTRNLNK^HLOAPP($G(HLMSTATE("HDR","RECEIVING APPLICATION"))) - Q:LINK]"" LINK - S LINK=$$RTRNLNK^HLOTLNK($G(HLMSTATE("HDR","SENDING FACILITY",1)),$G(HLMSTATE("HDR","SENDING FACILITY",2)),$G(HLMSTATE("HDR","SENDING FACILITY",3))) - Q LINK - ; -CHKPARMS(HLMSTATE,PARMS,ERROR) ; - N LEN,SARY,HARY - ; - ;shortcut to reference the header sub-array - S HARY="HLMSTATE(""HDR"")" - ; - ;shortcut to reference the status sub-array - S SARY="HLMSTATE(""STATUS"")" - ; - S ERROR="" - I $G(PARMS("ACCEPT ACK TYPE"))="" S PARMS("ACCEPT ACK TYPE")="AL" - I $G(PARMS("APP ACK TYPE"))="" S PARMS("APP ACK TYPE")="NE" - I PARMS("ACCEPT ACK TYPE")'="NE",PARMS("ACCEPT ACK TYPE")'="AL" S ERROR="INVALID ACCEPT ACKNOWLEDGMENT TYPE" - I PARMS("APP ACK TYPE")'="NE",PARMS("APP ACK TYPE")'="AL" S ERROR="INVALID APPLICATION ACKNOWLEDGMENT TYPE" - S LEN=$L($G(PARMS("QUEUE"))) - I $G(PARMS("QUEUE"))["^" S ERROR="QUEUE NAME MAY NOT CONTAIN '^'" - I LEN>20 S ERROR="QUEUE PARAMETER IS MAX 20 LENGTH",PARMS("QUEUE")=$E(PARMS("QUEUE"),1,20) - I 'LEN S PARMS("QUEUE")="DEFAULT" - D - .N APPIEN - .I $G(PARMS("SENDING APPLICATION"))="" D Q - ..S ERROR="SENDING APPLICATION IS REQUIRED" - ..S PARMS("SENDING APPLICATION")="" - .E D Q:'APPIEN - ..S APPIEN=$$GETIEN^HLOAPP(PARMS("SENDING APPLICATION")) - ..I 'APPIEN S ERROR="SENDING APPLICATION NOT FOUND IN THE HLO APPLICATION REGISTRY" - .I $L($G(PARMS("SEQUENCE QUEUE"))) D - ..I ($L(PARMS("SEQUENCE QUEUE"))>30) S ERROR="SEQUENCE QUEUE NAME > 30 CHARACTERS" Q - ..I PARMS("SEQUENCE QUEUE")["^" S ERROR="SEQUENCE QUEUE NAME MAY NOT CONTAIN '^'" Q - ..I $G(PARMS("APP ACK TYPE"))'="AL" S ERROR="SEQUENCE QUEUES REQUIRE AN APPLICATION ACKNOWLEDGMENT" Q - ..I $G(PARMS("ACCEPT ACK TYPE"))'="AL" S ERROR="SEQUENCE QUEUES REQUIRE AN ACCEPT ACKNOWLEDGMENT" Q - ; - ;move parameters into HLMSTATE - S @HARY@("ACCEPT ACK TYPE")=PARMS("ACCEPT ACK TYPE") - S @HARY@("APP ACK TYPE")=PARMS("APP ACK TYPE") - S @HARY@("SENDING APPLICATION")=$E(PARMS("SENDING APPLICATION"),1,60) - S @HARY@("SECURITY")=$G(PARMS("SECURITY")) - S @SARY@("APP ACK RESPONSE")=$G(PARMS("APP ACK RESPONSE")) - S @SARY@("ACCEPT ACK RESPONSE")=$G(PARMS("ACCEPT ACK RESPONSE")) - S @SARY@("FAILURE RESPONSE")=$G(PARMS("FAILURE RESPONSE")) - S @SARY@("QUEUE")=PARMS("QUEUE") - S @SARY@("SEQUENCE QUEUE")=$G(PARMS("SEQUENCE QUEUE")) - Q:$L(ERROR) 0 - Q 1 - ; - ; -SETCODE(SEG,VALUE,FIELD,COMP,REP) ; - ;Implements SETCNE and SETCWE - ; - N SUB,VAR - Q:'$G(FIELD) - S:'$G(REP) REP=1 - I '$G(COMP) D - .S VAR="COMP",SUB=1 - E D - .S VAR="SUB" - S @VAR=1,SEG(FIELD,REP,COMP,SUB)=$G(VALUE("ID")) - S @VAR=2,SEG(FIELD,REP,COMP,SUB)=$G(VALUE("TEXT")) - S @VAR=3,SEG(FIELD,REP,COMP,SUB)=$G(VALUE("SYSTEM")) - S @VAR=4,SEG(FIELD,REP,COMP,SUB)=$G(VALUE("ALTERNATE ID")) - S @VAR=5,SEG(FIELD,REP,COMP,SUB)=$G(VALUE("ALTERNATE TEXT")) - S @VAR=6,SEG(FIELD,REP,COMP,SUB)=$G(VALUE("ALTERNATE SYSTEM")) - S @VAR=7,SEG(FIELD,REP,COMP,SUB)=$G(VALUE("SYSTEM VERSION")) - S @VAR=8,SEG(FIELD,REP,COMP,SUB)=$G(VALUE("ALTERNATE SYSTEM VERSION")) - S @VAR=9,SEG(FIELD,REP,COMP,SUB)=$G(VALUE("ORIGINAL TEXT")) - Q - ; -CHKWHO(HLMSTATE,WHOTO,ERROR) ; - N RETURN,I - S RETURN=1 - I '$$CHECKWHO^HLOASUB1(.WHOTO,.RETURN,.ERROR) S RETURN=0 - ; - ;move parameters into HLMSTATE - S HLMSTATE("STATUS","LINK IEN")=$G(RETURN("LINK IEN")) - S HLMSTATE("STATUS","LINK NAME")=$G(RETURN("LINK NAME")) - S HLMSTATE("STATUS","PORT")=$P($G(RETURN("RECEIVING FACILITY",2)),":",2) - S HLMSTATE("HDR","RECEIVING APPLICATION")=$G(RETURN("RECEIVING APPLICATION")) - F I=1:1:3 S HLMSTATE("HDR","RECEIVING FACILITY",I)=$G(RETURN("RECEIVING FACILITY",I)) - Q RETURN +HLOAPI2 ;ALB/CJM-HL7 - Developer API's for sending application acks ;12/11/2006 + ;;1.6;HEALTH LEVEL SEVEN;**126,131,133,134**;Oct 13, 1995;Build 30 + ;Per VHA Directive 2004-038, this routine should not be modified. + ; +ACK(HLMSTATE,PARMS,ACK,ERROR) ;Default behavior is to return a general + ;application ack. The application may optionally specify the message + ;type and event or call $$ADDSEG^HLOAPI to add segments. + ;A generic MSA segment (components 1-3) is added automatically IF the + ;application doesn't call $$ADDSEG^HLOAPI to add an MSA segment as the + ;FIRST segment following the header. + ;$$SENDACK must be called when the ack is completed. The return + ;destination is determined automatically from the original message + ; + ;This API should NOT be called for batch messages, use $$BATCHACK instead. + ;Input: + ; HLMSTATE (pass by reference, required) the array obtained by calling $$STARTMSG^HLOPRS when parsing the original message + ; PARMS (pass by reference) These subscripts may be defined: + ; "ACK CODE" (required) MSA1[ {AA,AE,AR} + ; "ERROR MESSAGE" - MSA3, should be used only if AE or AR + ; "ACCEPT ACK RESPONSE" - the to call when the commit ack is received (optional) + ; "ACCEPT ACK TYPE" - {AL,NE} (optional, defaults to AL) + ; "CONTINUATION POINTER" (optional)indicates a fragmented message + ; "COUNTRY" - the 3 character country code (optional) + ; "EVENT" - the 3 character event type (optional, defaults to the event code of the original message) + ; "ENCODING CHARACTERS" - the four HL7 encoding characters (optional,defaults to "^~\&" + ; "FAILURE RESPONSE" (optional) the ^ that the sending application routine should execute if the transmission of the message fails, i.e., the message can not be sent or a requested commit ack is not received. + ; "FIELD SEPARATOR" - field separator (optional, defaults to "|") + ; "MESSAGE TYPE" - if not defined, ACK is used + ; "MESSAGE STRUCTURE" (optional) + ; "QUEUE" - (optional) An application can name its own private queue (a string under 20 characters,namespaced). The default is the name of the queue of the original message + ; "SECURITY" (optional) security information to include in the header segment, SEQ 8 (optional) + ; "VERSION" - the HL7 Version ID (optional, defaults to 2.4) + ;Output: + ; Function returns 1 on success, 0 on failure + ; PARMS - left undefined when the function returns + ; ACK (pass by reference, required) the acknowledgment message being built. + ; ERROR (pass by reference) error msg + N I,SEG,TOLINK,SUCCESS + S SUCCESS=0,ERROR="" + ; + D + .N PORT + .I $G(PARMS("ACK CODE"))'="AA",$G(PARMS("ACK CODE"))'="AE",$G(PARMS("ACK CODE"))'="AR" S ERROR="INVALID ACK CODE" Q + .; + .I '$G(HLMSTATE("IEN")) S ERROR="ORIGINAL MESSAGE TO ACKNOWLEDGE IS NOT IDENTIFIED" Q + .I $G(HLMSTATE("BATCH")) S ERROR="BATCH ACKNOWLEDGMENTS MUST USE $$BATCHACK^HLOAPI3" Q + .; + .I $G(HLMSTATE("HDR","MESSAGE CONTROL ID"))="" S ERROR="MESSAGE CONTROL ID MUST EXIST TO RETURN AN APPLICATION ACK" Q + .S PARMS("MESSAGE TYPE")=$G(PARMS("MESSAGE TYPE"),"ACK") + .S:PARMS("MESSAGE TYPE")="ACK" PARMS("MESSAGE STRUCTURE")="ACK" + .S PARMS("EVENT")=$G(PARMS("EVENT"),$G(HLMSTATE("HDR","EVENT"))) + .I $$NEWMSG^HLOAPI(.PARMS,.ACK) ;can't fail! + .; + .;if the return link can not be determined, the HL Logical Link file has a problem that must be fixed at the site + .S PORT=$P(HLMSTATE("HDR","SENDING FACILITY",2),":",2) + .S TOLINK=$$ACKLINK(.HLMSTATE) + .I TOLINK="" S ERROR="TRANSMISSION LINK FOR APPLICATION ACK CANNOT BE DETERMINED" Q + .I 'PORT S PORT=$$PORT2^HLOTLNK(TOLINK) + .; + .S ACK("HDR","APP ACK TYPE")="NE" + .S ACK("HDR","ACCEPT ACK TYPE")=$G(PARMS("ACCEPT ACK TYPE"),"AL") + .S ACK("STATUS","QUEUE")=$G(PARMS("QUEUE"),$G(HLMSTATE("STATUS","QUEUE"))) + .S ACK("STATUS","PORT")=PORT + .S ACK("HDR","SECURITY")=$G(PARMS("SECURITY")) + .S ACK("HDR","SENDING APPLICATION")=$G(HLMSTATE("HDR","RECEIVING APPLICATION")) + .S ACK("HDR","RECEIVING APPLICATION")=$G(HLMSTATE("HDR","SENDING APPLICATION")) + .F I=1:1:3 S ACK("HDR","RECEIVING FACILITY",I)=$G(HLMSTATE("HDR","SENDING FACILITY",I)) + .S ACK("ACK TO","STATUS")=$S(PARMS("ACK CODE")="AA":"SU",1:"AE") + .S ACK("ACK TO")=$G(HLMSTATE("HDR","MESSAGE CONTROL ID")) + .S ACK("ACK TO","IEN")=HLMSTATE("IEN") + .S ACK("STATUS","LINK NAME")=TOLINK + .S ACK("LINE COUNT")=0 + .S ACK("MSA")="MSA"_ACK("HDR","FIELD SEPARATOR")_PARMS("ACK CODE")_ACK("HDR","FIELD SEPARATOR")_$G(HLMSTATE("HDR","MESSAGE CONTROL ID"))_ACK("HDR","FIELD SEPARATOR")_$G(PARMS("ERROR MESSAGE")) + .S SUCCESS=1 + K PARMS + K:'SUCCESS ACK + Q SUCCESS + ; +SENDACK(ACK,ERROR) ;This is used to signal that an application acknowledgment is complete. + ;Input: + ; ACK (pass by reference,required) An array that contains the acknowledgment msg + ;Output: + ; Function returns 1 on success, 0 on failure + ; ERROR (pass by reference) error msg + ; + N SEG + ;if the application added its own MSA, then the ACK("MSA") node was killed + I $D(ACK("MSA")) S SEG(1)=ACK("MSA") D ADDSEG^HLOMSG(.ACK,.SEG) + ; + I $$SEND^HLOAPI1(.ACK,.ERROR) Q 1 + Q 0 + ; +ACKLINK(HLMSTATE) ; + ;Finds the link to return the application ack to. + N LINK + S LINK=$$RTRNLNK^HLOAPP($G(HLMSTATE("HDR","RECEIVING APPLICATION"))) + Q:LINK]"" LINK + S LINK=$$RTRNLNK^HLOTLNK($G(HLMSTATE("HDR","SENDING FACILITY",1)),$G(HLMSTATE("HDR","SENDING FACILITY",2)),$G(HLMSTATE("HDR","SENDING FACILITY",3))) + Q LINK + ; +CHKPARMS(HLMSTATE,PARMS,ERROR) ; + N LEN,SARY,HARY + ; + ;shortcut to reference the header sub-array + S HARY="HLMSTATE(""HDR"")" + ; + ;shortcut to reference the status sub-array + S SARY="HLMSTATE(""STATUS"")" + ; + S ERROR="" + I $G(PARMS("ACCEPT ACK TYPE"))="" S PARMS("ACCEPT ACK TYPE")="AL" + I $G(PARMS("APP ACK TYPE"))="" S PARMS("APP ACK TYPE")="NE" + I PARMS("ACCEPT ACK TYPE")'="NE",PARMS("ACCEPT ACK TYPE")'="AL" S ERROR="INVALID ACCEPT ACKNOWLEDGMENT TYPE" + I PARMS("APP ACK TYPE")'="NE",PARMS("APP ACK TYPE")'="AL" S ERROR="INVALID APPLICATION ACKNOWLEDGMENT TYPE" + S LEN=$L($G(PARMS("QUEUE"))) + I $G(PARMS("QUEUE"))["^" S ERROR="QUEUE NAME MAY NOT CONTAIN '^'" + I LEN>20 S ERROR="QUEUE PARAMETER IS MAX 20 LENGTH",PARMS("QUEUE")=$E(PARMS("QUEUE"),1,20) + I 'LEN S PARMS("QUEUE")="DEFAULT" + I $G(PARMS("SENDING APPLICATION"))="" D + .S ERROR="SENDING APPLICATION IS REQUIRED" + .S PARMS("SENDING APPLICATION")="" + E D + .I '$D(^HLD(779.2,"C",PARMS("SENDING APPLICATION"))) S ERROR="SENDING APPLICATION NOT FOUND IN THE HLO APPLICATION REGISTRY" + ; + ;move parameters into HLMSTATE + S @HARY@("ACCEPT ACK TYPE")=PARMS("ACCEPT ACK TYPE") + S @HARY@("APP ACK TYPE")=PARMS("APP ACK TYPE") + S @HARY@("SENDING APPLICATION")=$E(PARMS("SENDING APPLICATION"),1,60) + S @HARY@("SECURITY")=$G(PARMS("SECURITY")) + S @SARY@("APP ACK RESPONSE")=$G(PARMS("APP ACK RESPONSE")) + S @SARY@("ACCEPT ACK RESPONSE")=$G(PARMS("ACCEPT ACK RESPONSE")) + S @SARY@("FAILURE RESPONSE")=$G(PARMS("FAILURE RESPONSE")) + S @SARY@("QUEUE")=PARMS("QUEUE") + Q:$L(ERROR) 0 + Q 1 + ; +SETCODE(SEG,VALUE,FIELD,COMP,REP) ; + ;Implements SETCNE and SETCWE + ; + N SUB,VAR + Q:'$G(FIELD) + S:'$G(REP) REP=1 + I '$G(COMP) D + .S VAR="COMP",SUB=1 + E D + .S VAR="SUB" + S @VAR=1,SEG(FIELD,REP,COMP,SUB)=$G(VALUE("ID")) + S @VAR=2,SEG(FIELD,REP,COMP,SUB)=$G(VALUE("TEXT")) + S @VAR=3,SEG(FIELD,REP,COMP,SUB)=$G(VALUE("SYSTEM")) + S @VAR=4,SEG(FIELD,REP,COMP,SUB)=$G(VALUE("ALTERNATE ID")) + S @VAR=5,SEG(FIELD,REP,COMP,SUB)=$G(VALUE("ALTERNATE TEXT")) + S @VAR=6,SEG(FIELD,REP,COMP,SUB)=$G(VALUE("ALTERNATE SYSTEM")) + S @VAR=7,SEG(FIELD,REP,COMP,SUB)=$G(VALUE("SYSTEM VERSION")) + S @VAR=8,SEG(FIELD,REP,COMP,SUB)=$G(VALUE("ALTERNATE SYSTEM VERSION")) + S @VAR=9,SEG(FIELD,REP,COMP,SUB)=$G(VALUE("ORIGINAL TEXT")) + Q diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLOAPI3.m b/r/HEALTH_LEVEL_SEVEN-HL/HLOAPI3.m index 35749d01..8a2848e8 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLOAPI3.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLOAPI3.m @@ -1,195 +1,195 @@ -HLOAPI3 ;ALB/CJM-HL7 - Developer API's for sending application acks ;07/10/2007 - ;;1.6;HEALTH LEVEL SEVEN;**126,133,134,137**;Oct 13, 1995;Build 21 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; -BATCHACK(HLMSTATE,PARMS,ACK,ERROR) ;Starts a batch message that is the response to a batch message. Individual acks are placed in the batch by calling $$ADDACK. - ;$$SENDACK^HLOAPI2 must be called when the batch of acks is complete. The return destination is determined automatically from the original message. - ; - ;Input: - ; HLMSTATE (pass by reference, required) the array obtained by calling $$STARTMSG^HLOPRS when parsing the original message - ; PARMS (optional, pass by reference) These subscripts may be defined: - ; "ACCEPT ACK RESPONSE")= to call when the commit ack is received (optional) - ; "ACCEPT ACK TYPE") = (optional, defaults to AL) - ; "COUNTRY") - a 3 character country code from the HL7 standard table (optional) - ; "ENCODING CHARACTERS" - the 4 HL7 encoding characters (optional,defaults to "^~\&" - ; "FAILURE RESPONSE" (optional) the ^ that the sending application routine should execute if the transmission of the message fails, i.e., the message can not be sent or a requested commit ack is not received. - ; "FIELD SEPARATOR" - the field separator (optional, defaults to "|") - ; "QUEUE" (optional) An application can name a private queue (a string under 20 characters, namespaced). The default is the name of the queue of the original message - ; "SECURITY" - security information to include in the header segment, SEQ 8 (optional) - ; "VERSION" - the HL7 Version ID (optional, defaults to 2.4) - ;Output: - ; Function returns 1 on success, 0 on failure - ; PARMS - left undefined upon completion - ; ACK (pass by reference, required) the batch acknowledgment message being built. - ; ERROR (pass by reference) error message - N I,TOLINK,SUCCESS - S SUCCESS=0 - ; - D - .N PORT - .I '$G(HLMSTATE("IEN")) S ERROR="ORIGINAL MESSAGE TO ACKNOWLEDGMENT IS NOT IDENTIFIED" Q - .;if the return link can not be determined, the HL Logical Link file has a problem - .S TOLINK=$$ACKLINK^HLOAPI2(.HLMSTATE) - .I TOLINK="" S ERROR="TRANSMISSION LINK FOR APPLICATION ACK CANNOT BE DETERMINED" Q - .S PORT=$P(HLMSTATE("HDR","SENDING FACILITY",2),":",2) - .I 'PORT S PORT=$$PORT2^HLOTLNK(TOLINK) - .; - .I $$NEWBATCH^HLOAPI(.PARMS,.ACK) ;can't fail! - .S ACK("STATUS","QUEUE")=$G(PARMS("QUEUE"),$G(HLMSTATE("STATUS","QUEUE"))) - .S ACK("STATUS","PORT")=PORT - .S ACK("HDR","SECURITY")=$G(PARMS("SECURITY")) - .S ACK("HDR","SENDING APPLICATION")=$G(HLMSTATE("HDR","RECEIVING APPLICATION")) - .S ACK("HDR","RECEIVING APPLICATION")=$G(HLMSTATE("HDR","SENDING APPLICATION")) - .F I=1:1:3 S ACK("HDR","RECEIVING FACILITY",I)=$G(HLMSTATE("HDR","SENDING FACILITY",I)) - .S ACK("HDR","APP ACK TYPE")="NE" - .S ACK("HDR","ACCEPT ACK TYPE")=$G(PARMS("ACCEPT ACK TYPE"),"AL") - .S ACK("ACK TO")=$G(HLMSTATE("HDR","BATCH CONTROL ID")) - .S ACK("ACK TO","IEN")=HLMSTATE("IEN") - .S ACK("ACK TO","BODY")=$G(HLMSTATE("BODY")) - .S ACK("STATUS","LINK NAME")=TOLINK - .S ACK("LINE COUNT")=0 - .S SUCCESS=1 - K PARMS - Q SUCCESS - ; -ADDACK(ACK,PARMS,ERROR) ;This API adds an application acknowledgment to a batch - ;of acknowledgments that was started by calling $$BATCHACK. - ;The Default behavior is to return a general application ack. - ;The application may optionally specify the message - ;type and event and/or call $$ADDSEG^HLOAPI to add segments. - ;A generic MSA segment (components 1-3) will be added automatically - ;if the application doesn't call $$ADDSEG^HLOAPI to add an MSA segment - ;as the FIRST segment following the MSH segment. - ;$$SENDACK^HLOAPI2 must be called when the batch is complete. - ; - ;Input: - ; ACK (pass by reference,required) the batch of acks that is being built - ; PARMS (pass by reference) These subscripts may be defined: - ; "ACK CODE" (required) MSA1[ {AA,AE,AR} - ; "ERROR MESSAGE" (optional) MSA3, should be used only if AE or AR - ; "EVENT" - 3 character event type (optional, defaults to the event code of the original message) - ; "MESSAGE CONTROL ID" (required) this is the message control id of the original individual message within the batch which is being acknowledged - ; "MESSAGE STRUCTURE" (optional) - ; "MESSAGE TYPE" (optional, defaults to ACK) - ; "SECURITY" (optional) security information to include in the header segment SEQ 8 - ;Output: - ; Function returns 1 on success, 0 on failure - ; ACK (pass by reference, required) The batch, updated with another ack - ; PARMS - left undefined when this function returns - ; ERROR (pass by reference) error msg - ; - N SUB,SUCCESS - S SUCCESS=0 - D - .I $G(PARMS("ACK CODE"))'="AA",$G(PARMS("ACK CODE"))'="AE",$G(PARMS("ACK CODE"))'="AR" S ERROR="INVALID ACK CODE" Q - .; - .I $G(PARMS("MESSAGE CONTROL ID"))="" S ERROR="MESSAGE CONTROL ID MUST EXIST TO RETURN AN APPLICATION ACK" Q - .S SUB="" - .F S SUB=$O(^HLB("AE",PARMS("MESSAGE CONTROL ID"),SUB)) Q:SUB="" I $P(SUB,"^")=ACK("ACK TO","IEN"),$P(SUB,"^",2) S PARMS("ACK TO","IEN")=SUB Q - .S PARMS("MESSAGE TYPE")=$G(PARMS("MESSAGE TYPE"),"ACK") - .S:PARMS("MESSAGE TYPE")="ACK" PARMS("MESSAGE STRUCTURE")="ACK" - .S PARMS("EVENT")=$G(PARMS("EVENT")) - .I PARMS("EVENT")="",ACK("ACK TO","BODY"),$P(SUB,"^",2) S PARMS("EVENT")=$P($G(^HLA(ACK("ACK TO","BODY"),2,$P(SUB,"^",2),0)),"^",3) - .S PARMS("ACK TO")=PARMS("MESSAGE CONTROL ID") - .S PARMS("ACK TO","STATUS")=$S(PARMS("ACK CODE")="AA":"SU",1:"ER") - .Q:'$$ADDMSG^HLOAPI(.ACK,.PARMS,.ERROR) - .S ACK("MSA")="MSA|"_PARMS("ACK CODE")_"|"_PARMS("MESSAGE CONTROL ID")_"|"_$G(PARMS("ERROR MESSAGE")) - .S SUCCESS=1 - K PARMS - Q SUCCESS - ; -RESEND(MSGIEN,ERROR) ; - ;This message will re-transmit an out-going message. It copies a copy the message, reusing all the original parameters. Then the message is requeued. - ; - ;Input: - ; MSGIEN - the ien (file #778) of the message that is to be sent - ;Output: - ; Function returns the ien of the message in file 778 on success, 0 on failure - ; ERROR (pass by reference, optional)an error message - ; - N MSG,SUB,HDR - I '$$STARTMSG^HLOPRS(.MSG,MSGIEN) S ERROR="MESSAGE NOT FOUND" Q 0 - I MSG("DIRECTION")'="OUT" S ERROR="MESSAGE IS NOT OUTGOING" Q 0 - I MSG("STATUS","LINK NAME")="" S ERROR="LINK NOT DEFINED" Q 0 - F SUB="ID","IEN","DT/TM","ACK BY","STATUS" S MSG(SUB)="" - F SUB="PURGE" K MSG("STATUS",SUB) - D GETSYS^HLOAPI(.MSG) - I $$SAVEMSG^HLOF778(.MSG) D OUTQUE^HLOQUE(MSG("STATUS","LINK NAME"),$G(MSG("STATUS","PORT")),MSG("STATUS","QUEUE"),MSG("IEN")) Q +MSG("IEN") - Q 0 - ; -SETPURGE(MSGIEN,TIME) ; - ;Resets the purge date/time. - ;Input: - ; MSGIEN (required) ien of the message, file #778 - ; TIME (optional) dt/time to set the purge time to, defaults to NOW - ;Output: - ; Function returns 1 on success, 0 on failure - N NODE,OLDTIME,HLDIR - Q:'$G(MSGIEN) 0 - S NODE=$G(^HLB(MSGIEN,0)) - Q:NODE="" 0 - S OLDTIME=$P(NODE,"^",9) - S:'$G(TIME) TIME=$$NOW^XLFDT - S HLDIR=$S($E($P(NODE,"^",4))="I":"IN",1:"OUT") - K:OLDTIME ^HLB("AD",HLDIR,OLDTIME,MSGIEN) - S $P(^HLB(MSGIEN,0),"^",9)=TIME - S ^HLB("AD",HLDIR,TIME,MSGIEN)="" - Q 1 - ; -REPROC(MSGIEN,ERROR) ; - ;This message will re-process an incoming message by placing it on an incoming queue. If successful the message will be purged. - ; - ;Input: - ; MSGIEN - the ien (file #778) of the message that is to be processed - ;Output: - ; Function returns 1 on success, 0 on failure - ; ERROR (pass by reference, optional) an error message - ; - N MSG,HDR,ACTION,QUEUE,FROM - ; - I '$$STARTMSG^HLOPRS(.MSG,MSGIEN) S ERROR="MESSAGE NOT FOUND" Q 0 - I MSG("DIRECTION")'="IN" S ERROR="MESSAGE IS NOT INCOMING" Q 0 - M HDR=MSG("HDR") - I $G(MSG("ACK TO"))]"" S ACTION=MSG("STATUS","APP ACK RESPONSE") - I ACTION="",'$$ACTION^HLOAPP(.HDR,.ACTION,.QUEUE),$G(MSG("ACK TO"))="" S ERROR="RECEIVING APPLICATION NOT DEFINED" - ;If this message references an earlier message, get the action specified by the original message - I ACTION="",$G(MSG("ACK TO"))]"" D - .N NODE,IEN - .S IEN=$O(^HLB("B",$P(MSG("ACK TO"),"-"),0)) - .S:IEN NODE=$G(^HLB(IEN,0)) - .I ($P(NODE,"^",11)]"") S ACTION=$P(NODE,"^",10,11),QUEUE=$S($P(NODE,"^",6)]"":$P(NODE,"^",6),1:"DEFAULT") - I ACTION="" S ERROR="ORIGINAL MESSAGE NOT FOUND" Q 0 - S FROM=$S(MSG("HDR","SENDING FACILITY",2)]"":MSG("HDR","SENDING FACILITY",2),1:MSG("HDR","SENDING FACILITY",1)) - D INQUE^HLOQUE(FROM,QUEUE,MSGIEN,ACTION,1) - Q 1 - ; -PROCNOW(MSGIEN,PURGE,ERROR) ; - ;This message will re-process an incoming message immediately. - ; - ;Input: - ; MSGIEN - the ien (file #778) of the message that is to be processed - ;Output: - ; Function returns 1 on success, 0 on failure - ; PURGE (optional) a date/time to purge the message - ; ERROR (pass by reference, optional) an error message - ; - N MSG,HDR,ACTION,MCODE,HLMSGIEN - ; - S ERROR="" - I '$$STARTMSG^HLOPRS(.MSG,MSGIEN) S ERROR="MESSAGE NOT FOUND" Q 0 - I MSG("DIRECTION")'="IN" S ERROR="MESSAGE IS NOT INCOMING" Q 0 - M HDR=MSG("HDR") - I $G(MSG("ACK TO"))]"" S ACTION=MSG("STATUS","APP ACK RESPONSE") - I ACTION="",'$$ACTION^HLOAPP(.HDR,.ACTION,.QUEUE),$G(MSG("ACK TO"))="" S ERROR="RECEIVING APPLICATION NOT DEFINED" Q 0 - ;If this message references an earlier message, get the action specified by the original message - I $G(ACTION)="",$G(MSG("ACK TO IEN")) S ACTION=$P($G(^HLB(+MSG("ACK TO IEN"),0)),"^",10,11) I $P(ACTION,"^",2)="" S ERROR="ORIGINAL MESSAGE NOT FOUND" Q 0 - D:$G(PURGE) - .K:MSG("STATUS","PURGE") ^HLB("AD","IN",MSG("STATUS","PURGE"),MSGIEN) - .S $P(^HLB(MSGIEN,0),"^",9)=PURGE - .S ^HLB("AD","IN",PURGE,MSGIEN)="" - .I $G(MSG("ACK TO IEN")),$D(^HLB(MSG("ACK TO IEN"),0)) K ^HLB("AD","OUT",MSG("STATUS","PURGE"),MSG("ACK TO IEN")) S $P(^HLB(MSG("ACK TO IEN"),0),"^",9)=PURGE,^HLB("AD","OUT",PURGE,MSG("ACK TO IEN"))="" - S HLMSGIEN=MSGIEN - S $P(^HLB(MSGIEN,0),"^",19)=1 - S MCODE="D "_ACTION - X MCODE - Q 1 +HLOAPI3 ;ALB/CJM-HL7 - Developer API's for sending application acks ;03/13/2007 + ;;1.6;HEALTH LEVEL SEVEN;**126,133,134**;Oct 13, 1995;Build 30 + ;Per VHA Directive 2004-038, this routine should not be modified. + ; +BATCHACK(HLMSTATE,PARMS,ACK,ERROR) ;Starts a batch message that is the response to a batch message. Individual acks are placed in the batch by calling $$ADDACK. + ;$$SENDACK^HLOAPI2 must be called when the batch of acks is complete. The return destination is determined automatically from the original message. + ; + ;Input: + ; HLMSTATE (pass by reference, required) the array obtained by calling $$STARTMSG^HLOPRS when parsing the original message + ; PARMS (optional, pass by reference) These subscripts may be defined: + ; "ACCEPT ACK RESPONSE")= to call when the commit ack is received (optional) + ; "ACCEPT ACK TYPE") = (optional, defaults to AL) + ; "COUNTRY") - a 3 character country code from the HL7 standard table (optional) + ; "ENCODING CHARACTERS" - the 4 HL7 encoding characters (optional,defaults to "^~\&" + ; "FAILURE RESPONSE" (optional) the ^ that the sending application routine should execute if the transmission of the message fails, i.e., the message can not be sent or a requested commit ack is not received. + ; "FIELD SEPARATOR" - the field separator (optional, defaults to "|") + ; "QUEUE" (optional) An application can name a private queue (a string under 20 characters, namespaced). The default is the name of the queue of the original message + ; "SECURITY" - security information to include in the header segment, SEQ 8 (optional) + ; "VERSION" - the HL7 Version ID (optional, defaults to 2.4) + ;Output: + ; Function returns 1 on success, 0 on failure + ; PARMS - left undefined upon completion + ; ACK (pass by reference, required) the batch acknowledgment message being built. + ; ERROR (pass by reference) error message + N I,TOLINK,SUCCESS + S SUCCESS=0 + ; + D + .N PORT + .I '$G(HLMSTATE("IEN")) S ERROR="ORIGINAL MESSAGE TO ACKNOWLEDGMENT IS NOT IDENTIFIED" Q + .;if the return link can not be determined, the HL Logical Link file has a problem + .S TOLINK=$$ACKLINK^HLOAPI2(.HLMSTATE) + .I TOLINK="" S ERROR="TRANSMISSION LINK FOR APPLICATION ACK CANNOT BE DETERMINED" Q + .S PORT=$P(HLMSTATE("HDR","SENDING FACILITY",2),":",2) + .I 'PORT S PORT=$$PORT2^HLOTLNK(TOLINK) + .; + .I $$NEWBATCH^HLOAPI(.PARMS,.ACK) ;can't fail! + .S ACK("STATUS","QUEUE")=$G(PARMS("QUEUE"),$G(HLMSTATE("STATUS","QUEUE"))) + .S ACK("STATUS","PORT")=PORT + .S ACK("HDR","SECURITY")=$G(PARMS("SECURITY")) + .S ACK("HDR","SENDING APPLICATION")=$G(HLMSTATE("HDR","RECEIVING APPLICATION")) + .S ACK("HDR","RECEIVING APPLICATION")=$G(HLMSTATE("HDR","SENDING APPLICATION")) + .F I=1:1:3 S ACK("HDR","RECEIVING FACILITY",I)=$G(HLMSTATE("HDR","SENDING FACILITY",I)) + .S ACK("HDR","APP ACK TYPE")="NE" + .S ACK("HDR","ACCEPT ACK TYPE")=$G(PARMS("ACCEPT ACK TYPE"),"AL") + .S ACK("ACK TO")=$G(HLMSTATE("HDR","BATCH CONTROL ID")) + .S ACK("ACK TO","IEN")=HLMSTATE("IEN") + .S ACK("ACK TO","BODY")=$G(HLMSTATE("BODY")) + .S ACK("STATUS","LINK NAME")=TOLINK + .S ACK("LINE COUNT")=0 + .S SUCCESS=1 + K PARMS + Q SUCCESS + ; +ADDACK(ACK,PARMS,ERROR) ;This API adds an application acknowledgment to a batch + ;of acknowledgments that was started by calling $$BATCHACK. + ;The Default behavior is to return a general application ack. + ;The application may optionally specify the message + ;type and event and/or call $$ADDSEG^HLOAPI to add segments. + ;A generic MSA segment (components 1-3) will be added automatically + ;if the application doesn't call $$ADDSEG^HLOAPI to add an MSA segment + ;as the FIRST segment following the MSH segment. + ;$$SENDACK^HLOAPI2 must be called when the batch is complete. + ; + ;Input: + ; ACK (pass by reference,required) the batch of acks that is being built + ; PARMS (pass by reference) These subscripts may be defined: + ; "ACK CODE" (required) MSA1[ {AA,AE,AR} + ; "ERROR MESSAGE" (optional) MSA3, should be used only if AE or AR + ; "EVENT" - 3 character event type (optional, defaults to the event code of the original message) + ; "MESSAGE CONTROL ID" (required) this is the message control id of the original individual message within the batch which is being acknowledged + ; "MESSAGE STRUCTURE" (optional) + ; "MESSAGE TYPE" (optional, defaults to ACK) + ; "SECURITY" (optional) security information to include in the header segment SEQ 8 + ;Output: + ; Function returns 1 on success, 0 on failure + ; ACK (pass by reference, required) The batch, updated with another ack + ; PARMS - left undefined when this function returns + ; ERROR (pass by reference) error msg + ; + N SUB,SUCCESS + S SUCCESS=0 + D + .I $G(PARMS("ACK CODE"))'="AA",$G(PARMS("ACK CODE"))'="AE",$G(PARMS("ACK CODE"))'="AR" S ERROR="INVALID ACK CODE" Q + .; + .I $G(PARMS("MESSAGE CONTROL ID"))="" S ERROR="MESSAGE CONTROL ID MUST EXIST TO RETURN AN APPLICATION ACK" Q + .S SUB="" + .F S SUB=$O(^HLB("AE",PARMS("MESSAGE CONTROL ID"),SUB)) Q:SUB="" I $P(SUB,"^")=ACK("ACK TO","IEN"),$P(SUB,"^",2) S PARMS("ACK TO","IEN")=SUB Q + .S PARMS("MESSAGE TYPE")=$G(PARMS("MESSAGE TYPE"),"ACK") + .S:PARMS("MESSAGE TYPE")="ACK" PARMS("MESSAGE STRUCTURE")="ACK" + .S PARMS("EVENT")=$G(PARMS("EVENT")) + .I PARMS("EVENT")="",ACK("ACK TO","BODY"),$P(SUB,"^",2) S PARMS("EVENT")=$P($G(^HLA(ACK("ACK TO","BODY"),2,$P(SUB,"^",2),0)),"^",3) + .S PARMS("ACK TO")=PARMS("MESSAGE CONTROL ID") + .S PARMS("ACK TO","STATUS")=$S(PARMS("ACK CODE")="AA":"SU",1:"AE") + .Q:'$$ADDMSG^HLOAPI(.ACK,.PARMS,.ERROR) + .S ACK("MSA")="MSA|"_PARMS("ACK CODE")_"|"_PARMS("MESSAGE CONTROL ID")_"|"_$G(PARMS("ERROR MESSAGE")) + .S SUCCESS=1 + K PARMS + Q SUCCESS + ; +RESEND(MSGIEN,ERROR) ; + ;This message will re-transmit an out-going message. It copies a copy the message, reusing all the original parameters. Then the message is requeued. + ; + ;Input: + ; MSGIEN - the ien (file #778) of the message that is to be sent + ;Output: + ; Function returns the ien of the message in file 778 on success, 0 on failure + ; ERROR (pass by reference, optional)an error message + ; + N MSG,SUB,HDR + I '$$STARTMSG^HLOPRS(.MSG,MSGIEN) S ERROR="MESSAGE NOT FOUND" Q 0 + I MSG("DIRECTION")'="OUT" S ERROR="MESSAGE IS NOT OUTGOING" Q 0 + I MSG("STATUS","LINK NAME")="" S ERROR="LINK NOT DEFINED" Q 0 + F SUB="ID","IEN","DT/TM","ACK BY","STATUS" S MSG(SUB)="" + F SUB="PURGE" K MSG("STATUS",SUB) + D GETSYS^HLOAPI(.MSG) + I $$SAVEMSG^HLOF778(.MSG) D OUTQUE^HLOQUE(MSG("STATUS","LINK NAME"),$G(MSG("STATUS","PORT")),MSG("STATUS","QUEUE"),MSG("IEN")) Q +MSG("IEN") + Q 0 + ; +SETPURGE(MSGIEN,TIME) ; + ;Resets the purge date/time. + ;Input: + ; MSGIEN (required) ien of the message, file #778 + ; TIME (optional) dt/time to set the purge time to, defaults to NOW + ;Output: + ; Function returns 1 on success, 0 on failure + N NODE,OLDTIME,HLDIR + Q:'$G(MSGIEN) 0 + S NODE=$G(^HLB(MSGIEN,0)) + Q:NODE="" 0 + S OLDTIME=$P(NODE,"^",9) + S:'$G(TIME) TIME=$$NOW^XLFDT + S HLDIR=$S($E($P(NODE,"^",4))="I":"IN",1:"OUT") + K:OLDTIME ^HLB("AD",HLDIR,OLDTIME,MSGIEN) + S $P(^HLB(MSGIEN,0),"^",9)=TIME + S ^HLB("AD",HLDIR,TIME,MSGIEN)="" + Q 1 + ; +REPROC(MSGIEN,ERROR) ; + ;This message will re-process an incoming message by placing it on an incoming queue. If successful the message will be purged. + ; + ;Input: + ; MSGIEN - the ien (file #778) of the message that is to be processed + ;Output: + ; Function returns 1 on success, 0 on failure + ; ERROR (pass by reference, optional) an error message + ; + N MSG,HDR,ACTION,QUEUE,FROM + ; + I '$$STARTMSG^HLOPRS(.MSG,MSGIEN) S ERROR="MESSAGE NOT FOUND" Q 0 + I MSG("DIRECTION")'="IN" S ERROR="MESSAGE IS NOT INCOMING" Q 0 + M HDR=MSG("HDR") + I $G(MSG("ACK TO"))]"" S ACTION=MSG("STATUS","APP ACK RESPONSE") + I ACTION="",'$$ACTION^HLOAPP(.HDR,.ACTION,.QUEUE),$G(MSG("ACK TO"))="" S ERROR="RECEIVING APPLICATION NOT DEFINED" + ;If this message references an earlier message, get the action specified by the original message + I ACTION="",$G(MSG("ACK TO"))]"" D + .N NODE,IEN + .S IEN=$O(^HLB("B",$P(MSG("ACK TO"),"-"),0)) + .S:IEN NODE=$G(^HLB(IEN,0)) + .I ($P(NODE,"^",11)]"") S ACTION=$P(NODE,"^",10,11),QUEUE=$S($P(NODE,"^",6)]"":$P(NODE,"^",6),1:"DEFAULT") + I ACTION="" S ERROR="ORIGINAL MESSAGE NOT FOUND" Q 0 + S FROM=$S(MSG("HDR","SENDING FACILITY",2)]"":MSG("HDR","SENDING FACILITY",2),1:MSG("HDR","SENDING FACILITY",1)) + D INQUE^HLOQUE(FROM,QUEUE,MSGIEN,ACTION,1) + Q 1 + ; +PROCNOW(MSGIEN,PURGE,ERROR) ; + ;This message will re-process an incoming message immediately. + ; + ;Input: + ; MSGIEN - the ien (file #778) of the message that is to be processed + ;Output: + ; Function returns 1 on success, 0 on failure + ; PURGE (optional) a date/time to purge the message + ; ERROR (pass by reference, optional) an error message + ; + N MSG,HDR,ACTION,MCODE,HLMSGIEN + ; + S ERROR="" + I '$$STARTMSG^HLOPRS(.MSG,MSGIEN) S ERROR="MESSAGE NOT FOUND" Q 0 + I MSG("DIRECTION")'="IN" S ERROR="MESSAGE IS NOT INCOMING" Q 0 + M HDR=MSG("HDR") + I $G(MSG("ACK TO"))]"" S ACTION=MSG("STATUS","APP ACK RESPONSE") + I ACTION="",'$$ACTION^HLOAPP(.HDR,.ACTION,.QUEUE),$G(MSG("ACK TO"))="" S ERROR="RECEIVING APPLICATION NOT DEFINED" Q 0 + ;If this message references an earlier message, get the action specified by the original message + I $G(ACTION)="",$G(MSG("ACK TO IEN")) S ACTION=$P($G(^HLB(+MSG("ACK TO IEN"),0)),"^",10,11) I $P(ACTION,"^",2)="" S ERROR="ORIGINAL MESSAGE NOT FOUND" Q 0 + D:$G(PURGE) + .K:MSG("STATUS","PURGE") ^HLB("AD","IN",MSG("STATUS","PURGE"),MSGIEN) + .S $P(^HLB(MSGIEN,0),"^",9)=PURGE + .S ^HLB("AD","IN",PURGE,MSGIEN)="" + .I $G(MSG("ACK TO IEN")),$D(^HLB(MSG("ACK TO IEN"),0)) K ^HLB("AD","OUT",MSG("STATUS","PURGE"),MSG("ACK TO IEN")) S $P(^HLB(MSG("ACK TO IEN"),0),"^",9)=PURGE,^HLB("AD","OUT",PURGE,MSG("ACK TO IEN"))="" + S HLMSGIEN=MSGIEN + S $P(^HLB(MSGIEN,0),"^",19)=1 + S MCODE="D "_ACTION + X MCODE + Q 1 diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLOAPP.m b/r/HEALTH_LEVEL_SEVEN-HL/HLOAPP.m index 94504c23..89e50ffa 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLOAPP.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLOAPP.m @@ -1,116 +1,98 @@ -HLOAPP ;ALB/CJM-HL7 -Application Registry ;07/09/2007 - ;;1.6;HEALTH LEVEL SEVEN;**126,132,137**;Oct 13, 1995;Build 21 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; -GETIEN(NAME) ;given the application name, it finds the ien. Returns 0 on failure - Q:'$L($G(NAME)) 0 - Q +$O(^HLD(779.2,"C",$E(NAME,1,60),0)) - ; -ACTION(HEADER,ACTION,QUEUE) ;Given the parsed header of a message it returns both the action that should be performed in response to the message and the incoming queue that it should be placed on. - ; - ;Input: - ; HEADER() subscripts are used: "RECEIVING APPLICATION","SEGMENT TYPE", "MESSAGE TYPE", "EVENT", "VERSION" - ;Output: - ; Function returns 1 on success, 0 on failure - ; ACTION (pass by reference) ^ - ; QUEUE (pass by reference) returns the named queue if there is one, else "DEFAULT" - ; - N IEN - S (ACTION,QUEUE)="" - S IEN=$$GETIEN(HEADER("RECEIVING APPLICATION")) - Q:'$G(IEN) 0 - I $G(HEADER("SEGMENT TYPE"))="BHS" D - .S NODE=$G(^HLD(779.2,IEN,0)) - .I $P(NODE,"^",5)]"" D - ..S ACTION=$P(NODE,"^",4,5) - .E I $P(NODE,"^",7)]"" S ACTION=$P(NODE,"^",6,7) - .I $P(NODE,"^",8)]"" D - ..S QUEUE=$P(NODE,"^",8) - .E I $P(NODE,"^",3)]"" S QUEUE=$P(NODE,"^",3) - E I HEADER("SEGMENT TYPE")="MSH" D - .I HEADER("MESSAGE TYPE")'="",HEADER("EVENT")'="" D - ..N SUBIEN,NODE - ..;did the application specify an action for the particular version of this message? - ..I HEADER("VERSION")'="" S SUBIEN=$O(^HLD(779.2,IEN,1,"D",HEADER("MESSAGE TYPE"),HEADER("EVENT"),HEADER("VERSION"),0)) - ..;if not, look on the "C" index - ..S:'$G(SUBIEN) SUBIEN=$O(^HLD(779.2,IEN,1,"C",HEADER("MESSAGE TYPE"),HEADER("EVENT"),0)) - ..; - ..I SUBIEN D - ...S NODE=$G(^HLD(779.2,IEN,1,SUBIEN,0)) - ...I $P(NODE,"^",5)]"" S ACTION=$P(NODE,"^",4,5) - ...I $P(NODE,"^",3)]"" S QUEUE=$P(NODE,"^",3) - ..I ACTION="" S NODE=$G(^HLD(779.2,IEN,0)) I $P(NODE,"^",7)]"" S ACTION=$P(NODE,"^",6,7) - ..I QUEUE="" S NODE=$G(^HLD(779.2,IEN,0)) I $P(NODE,"^",3)]"" S QUEUE=$P(NODE,"^",3) - I QUEUE="" S QUEUE="DEFAULT" - I ACTION="" Q 0 - Q 1 - ; -RTRNLNK(APPNAME) ; - ;given the name of a receiving application, this returns the return - ;link for application acks if one is provided. Otherwise, return - ;acks are routed based on the information provide in the message hdr - ; - Q:(APPNAME="") "" - N IEN - S IEN=$$GETIEN(APPNAME) - Q:IEN $P($G(^HLD(779.2,IEN,0)),"^",2) - Q "" - ; -RTRNPORT(APPNAME) ; - ;Given the name of the sending application, IF the application has its - ;own listener, its port # is returned. Application acks should be - ;returned using that port - Q:(APPNAME="") "" - N IEN,LINK - S IEN=$$GETIEN(APPNAME) - Q:'IEN "" - S LINK=$P($G(^HLD(779.2,IEN,0)),"^",9) - Q:'LINK "" - Q $$PORT^HLOTLNK(LINK) - ; -ACTIVE(APP,MSGTYPE,EVENT,VERSION) ; - ;Returns 1 if the message's INACTIVE flag has NOT been set. - ; - ;Input: - ; APP (required) the name of the sending application - ; MSGTYPE (required) 3 character HL7 message type - ; EVENT (required) 3 character HL7 event - ; VERSION (optional) HL7 version ID as it appears in the message header - ;Output: - ; Function returns 1 if the message type specified by the input parameters has not been set to INACTIVE. It returns 0 otherwise. - ; - N IEN,ACTIVE,SUBIEN - S ACTIVE=1 - S IEN=$$GETIEN($G(APP)) - Q:'$G(IEN) ACTIVE - Q:$G(MSGTYPE)="" ACTIVE - Q:$G(EVENT)="" ACTIVE - ;did the application specify an action for the particular version of this message? - I $G(VERSION)'="" S SUBIEN=$O(^HLD(779.2,IEN,1,"D",MSGTYPE,EVENT,VERSION,0)) - ;if not, look on the "C" index - S:'$G(SUBIEN) SUBIEN=$O(^HLD(779.2,IEN,1,"C",MSGTYPE,EVENT,0)) - ; - S:SUBIEN ACTIVE='(+$P($G(^HLD(779.2,IEN,1,SUBIEN,0)),"^",7)) - Q ACTIVE - ; -EXCEPT(APPNAME) ; - ;returns the exception handler (tag^routine) that should be invoked - ;when an applicaiton's messages are being sequenced and an app ack - ;is not timely received - ; - N IEN,RTN - S IEN=$$GETIEN($G(APPNAME)) - I IEN S RTN=$P($G(^HLD(779.2,IEN,0)),"^",10,11) - I $L($G(RTN))>1 Q RTN - Q "DEFAULT^HLOAPP" - ; -DEFAULT ;default exception handler if the app doesn't specify one - S ^TMP("HLO SEQUENCING EXCEPTION",$J,$$NOW^XLFDT,+$G(HLMSGIEN))="" - Q - ; -TIMEOUT(APPNAME) ; - N IEN,TIME - S IEN=$$GETIEN($G(APPNAME)) - I IEN S TIME=$P($G(^HLD(779.2,IEN,0)),"^",12) - Q:'$G(TIME) 10 - Q TIME +HLOAPP ;ALB/CJM-HL7 -Application Registry ;10/31/2006 + ;;1.6;HEALTH LEVEL SEVEN;**126,132**;Oct 13, 1995;Build 6 + ;Per VHA Directive 2004-038, this routine should not be modified. + ; +GETIEN(NAME) ;given the application name, it finds the ien. Returns 0 on failure + Q:'$L($G(NAME)) 0 + N IEN,SUB + S SUB=$E(NAME,1,60) + S IEN=0 + F S IEN=$O(^HLD(779.2,"B",SUB,IEN)) Q:'IEN Q:$P($G(^HLD(779.2,IEN,0)),"^")=NAME + Q +IEN + ; +ACTION(HEADER,ACTION,QUEUE) ;Given the parsed header of a message it returns both the action that should be performed in response to the message and the incoming queue that it should be placed on. + ; + ;Input: + ; HEADER() subscripts are used: "RECEIVING APPLICATION","SEGMENT TYPE", "MESSAGE TYPE", "EVENT", "VERSION" + ;Output: + ; Function returns 1 on success, 0 on failure + ; ACTION (pass by reference) ^ + ; QUEUE (pass by reference) returns the named queue if there is one, else "DEFAULT" + ; + N IEN + S (ACTION,QUEUE)="" + S IEN=$$GETIEN(HEADER("RECEIVING APPLICATION")) + Q:'$G(IEN) 0 + I $G(HEADER("SEGMENT TYPE"))="BHS" D + .S NODE=$G(^HLD(779.2,IEN,0)) + .I $P(NODE,"^",5)]"" D + ..S ACTION=$P(NODE,"^",4,5) + .E I $P(NODE,"^",7)]"" S ACTION=$P(NODE,"^",6,7) + .I $P(NODE,"^",8)]"" D + ..S QUEUE=$P(NODE,"^",8) + .E I $P(NODE,"^",3)]"" S QUEUE=$P(NODE,"^",3) + E I HEADER("SEGMENT TYPE")="MSH" D + .I HEADER("MESSAGE TYPE")'="",HEADER("EVENT")'="" D + ..N SUBIEN,NODE + ..;did the application specify an action for the particular version of this message? + ..I HEADER("VERSION")'="" S SUBIEN=$O(^HLD(779.2,IEN,1,"D",HEADER("MESSAGE TYPE"),HEADER("EVENT"),HEADER("VERSION"),0)) + ..;if not, look on the "C" index + ..S:'$G(SUBIEN) SUBIEN=$O(^HLD(779.2,IEN,1,"C",HEADER("MESSAGE TYPE"),HEADER("EVENT"),0)) + ..; + ..I SUBIEN D + ...S NODE=$G(^HLD(779.2,IEN,1,SUBIEN,0)) + ...I $P(NODE,"^",5)]"" S ACTION=$P(NODE,"^",4,5) + ...I $P(NODE,"^",3)]"" S QUEUE=$P(NODE,"^",3) + ..I ACTION="" S NODE=$G(^HLD(779.2,IEN,0)) I $P(NODE,"^",7)]"" S ACTION=$P(NODE,"^",6,7) + ..I QUEUE="" S NODE=$G(^HLD(779.2,IEN,0)) I $P(NODE,"^",3)]"" S QUEUE=$P(NODE,"^",3) + I QUEUE="" S QUEUE="DEFAULT" + I ACTION="" Q 0 + Q 1 + ; +RTRNLNK(APPNAME) ; + ;given the name of a receiving application, this returns the return + ;link for application acks if one is provided. Otherwise, return + ;acks are routed based on the information provide in the message hdr + ; + Q:(APPNAME="") "" + N IEN + S IEN=$$GETIEN(APPNAME) + Q:IEN $P($G(^HLD(779.2,IEN,0)),"^",2) + Q "" + ; +RTRNPORT(APPNAME) ; + ;Given the name of the sending application, IF the application has its + ;own listener, its port # is returned. Application acks should be + ;returned using that port + Q:(APPNAME="") "" + N IEN,LINK + S IEN=$$GETIEN(APPNAME) + Q:'IEN "" + S LINK=$P($G(^HLD(779.2,IEN,0)),"^",9) + Q:'LINK "" + Q $$PORT^HLOTLNK(LINK) + ; +ACTIVE(APP,MSGTYPE,EVENT,VERSION) ; + ;Returns 1 if the message's INACTIVE flag has NOT been set. + ; + ;Input: + ; APP (required) the name of the sending application + ; MSGTYPE (required) 3 character HL7 message type + ; EVENT (required) 3 character HL7 event + ; VERSION (optional) HL7 version ID as it appears in the message header + ;Output: + ; Function returns 1 if the message type specified by the input parameters has not been set to INACTIVE. It returns 0 otherwise. + ; + N IEN,ACTIVE,SUBIEN + S ACTIVE=1 + S IEN=$$GETIEN($G(APP)) + Q:'$G(IEN) ACTIVE + Q:$G(MSGTYPE)="" ACTIVE + Q:$G(EVENT)="" ACTIVE + ;did the application specify an action for the particular version of this message? + I $G(VERSION)'="" S SUBIEN=$O(^HLD(779.2,IEN,1,"D",MSGTYPE,EVENT,VERSION,0)) + ;if not, look on the "C" index + S:'$G(SUBIEN) SUBIEN=$O(^HLD(779.2,IEN,1,"C",MSGTYPE,EVENT,0)) + ; + S:SUBIEN ACTIVE='(+$P($G(^HLD(779.2,IEN,1,SUBIEN,0)),"^",7)) + Q ACTIVE diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT.m b/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT.m index cd94fb49..c3f9f99e 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT.m @@ -1,199 +1,187 @@ -HLOCLNT ;ALB/CJM- Client for sending messages - 10/4/94 1pm ;08/15/2007 - ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,134,137**;Oct 13, 1995;Build 21 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; - ;GET WORK function for the process running under the Process Manager -GETWORK(QUE) ; - ;Input: - ; QUE - (pass by reference) These subscripts are used: - ; ("LINK") - _":"_ last obtained - ; ("QUEUE") - name of the queue last obtained - ;Output: - ; Function returns 1 if success, 0 if no more work - ; QUE - updated to identify next queue of messages to process. - ; ("LINK") - _":"_ - ; ("QUEUE") - the named queue on the link - ; ("DOWN") - =1 means that the last OPEN attempt failed - ; - N LINK,QUEUE - S LINK=$G(QUE("LINK")),QUEUE=$G(QUE("QUEUE")) - I (LINK]""),(QUEUE]"") D - .L -^HLB("QUEUE","OUT",LINK,QUEUE) - .I '$$CNNCTD(LINK),$$FAILING(.LINK) S QUEUE="" Q - .F S QUEUE=$O(^HLB("QUEUE","OUT",LINK,QUEUE)) Q:(QUEUE="") I '$$STOPPED^HLOQUE("OUT",QUEUE) L +^HLB("QUEUE","OUT",LINK,QUEUE):0 Q:$T - I (LINK]""),(QUEUE="") D - .F S LINK=$O(^HLB("QUEUE","OUT",LINK)) Q:LINK="" D Q:$L(QUEUE) - ..I '$$CNNCTD(LINK),$$FAILING(.LINK) Q - ..S QUEUE="" F S QUEUE=$O(^HLB("QUEUE","OUT",LINK,QUEUE)) Q:(QUEUE="") I '$$STOPPED^HLOQUE("OUT",QUEUE) L +^HLB("QUEUE","OUT",LINK,QUEUE):0 Q:$T - I LINK="" D - .F S LINK=$O(^HLB("QUEUE","OUT",LINK)) Q:LINK="" D Q:$L(QUEUE) - ..I '$$CNNCTD(LINK),$$FAILING(.LINK) Q - ..S QUEUE="" F S QUEUE=$O(^HLB("QUEUE","OUT",LINK,QUEUE)) Q:(QUEUE="") I '$$STOPPED^HLOQUE("OUT",QUEUE) L +^HLB("QUEUE","OUT",LINK,QUEUE):0 Q:$T - S QUE("LINK")=LINK,QUE("QUEUE")=QUEUE,QUE("DOWN")=$G(LINK("DOWN")) - Q:$L(QUEUE) 1 - D:$G(HLCSTATE("CONNECTED")) CLOSE^HLOT(.HLCSTATE) - Q 0 - ; -FAILING(LINK) ; - ;Returns 1 if the link has failed in the last 30 seconds, 0 otherwise - ;Also returns LINK("DOWN")=1 if the link was failing > 30 seconds ago, not yet known if its up - ; - N LASTTIME,SET - S LINK("DOWN")=0 - S LASTTIME=$G(^HLB("QUEUE","OUT",LINK)) - S SET=$S(LASTTIME]"":1,1:0) - I SET D - .I $$HDIFF^XLFDT($H,LASTTIME,2)>30 S ^HLB("QUEUE","OUT",LINK)="",SET=0,LINK("DOWN")=1 - I $D(^HLTMP("FAILING LINKS",LINK)) S LINK("DOWN")=1 - Q SET - ; -LINKDOWN(HLCSTATE) ; - D:$G(HLCSTATE("CONNECTED")) CLOSE^HLOT(.HLCSTATE) - I $D(HLCSTATE("LINK","NAME")),$D(HLCSTATE("LINK","PORT")) D - .S TO=HLCSTATE("LINK","NAME")_":"_HLCSTATE("LINK","PORT") - .S ^HLB("QUEUE","OUT",TO)=$H - .S:'$D(^HLTMP("FAILING LINKS",TO)) ^HLTMP("FAILING LINKS",TO)=$H - Q - ; -ERROR ;error trap - S $ETRAP="Q:$QUIT """" Q" - N HOUR - S HOUR=$E($$NOW^XLFDT,1,10) - S ^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2))=$G(^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2)))+1 - D END - D LINKDOWN(.HLCSTATE) - ; - I ($ECODE["TOOMANYFILES")!($ECODE["EDITED") Q:$QUIT "" Q - ;while debugging quit on all errors - this will return the process to the Process Manager error trap - I $G(^HLTMP("LOG ALL ERRORS")) Q:$QUIT "" Q - ; - ;don't log some common errors - I ($ECODE["READ")!($ECODE["NOTOPEN")!($ECODE["DEVNOTOPN")!($ECODE["WRITE")!($ECODE["OPENERR") D - .; - E D - .;but do log all the others - .D ^%ZTER - ; - ;a lot of errors of the same type may indicate an endless loop - ;return to the Process Manager error trap - I ($G(^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2)))>30) Q:$QUIT "" Q - ; - ;resume execution of the process manager executing the client - D UNWIND^%ZTER - Q - ; -DOWORK(QUEUE) ;sends the messages on the queue - N $ETRAP,$ESTACK S $ETRAP="G ERROR^HLOCLNT" - N MSGIEN,DEQUE,SUCCESS,MSGCOUNT - S DEQUE=0 - S SUCCESS=1 - ; - I '$$CNNCTD(QUEUE("LINK")),'$$CONNECT^HLOCLNT1($P(QUEUE("LINK"),":"),$P(QUEUE("LINK"),":",2),30,.HLCSTATE) Q - ; - S (MSGCOUNT,MSGIEN)=0 - F S MSGIEN=$O(^HLB("QUEUE","OUT",QUEUE("LINK"),QUEUE("QUEUE"),MSGIEN)) Q:'MSGIEN D Q:'SUCCESS Q:MSGCOUNT>1000 - .N UPDATE - .S ^HLB(MSGIEN,"TRIES")=$G(^HLB(MSGIEN,"TRIES"))+1 - .S SUCCESS=0 - .S:$$TRANSMIT(.HLCSTATE,MSGIEN,.UPDATE) SUCCESS=1 - .Q:('SUCCESS)!('$D(UPDATE)) - .D DEQUE(.UPDATE) - .S MSGCOUNT=MSGCOUNT+1 - .D:HLCSTATE("COUNTS")>4 SAVECNTS^HLOSTAT(.HLCSTATE) - .; - .;if the queue was on the down list, and not since shutdown, mark it as up, since a message has been successfully transmitted across it - .I $G(QUEUE("DOWN"))!$$FAILING(QUEUE("LINK")),'$$IFSHUT^HLOTLNK(QUEUE("LINK")) S QUEUE("DOWN")=0,^HLB("QUEUE","OUT",QUEUE("LINK"))="" K ^HLTMP("FAILING LINKS",QUEUE("LINK")) - ; -END D DEQUE() - D SAVECNTS^HLOSTAT(.HLCSTATE) - Q -CNNCTD(LINK) ; - ;Connected to LINK? HLCSTATE must be defined, LINK=: - ; - I ($G(HLCSTATE("LINK","NAME"))=$P(LINK,":")),($G(HLCSTATE("LINK","PORT"))=$P(LINK,":",2)),$G(HLCSTATE("CONNECTED")) Q 1 - Q 0 - ; -DEQUE(UPDATE) ; - I $D(UPDATE) S DEQUE=DEQUE+1,DEQUE(+UPDATE)=$P(UPDATE,"^",2,99) S:$G(UPDATE("MSA"))]"" DEQUE(+UPDATE,"MSA")=UPDATE("MSA") S:$G(UPDATE("ACTION"))]"" DEQUE(+UPDATE,"ACTION")=UPDATE("ACTION") - I '$D(UPDATE)!(DEQUE>15) D - .N MSGIEN S MSGIEN=0 - .F S MSGIEN=$O(DEQUE(MSGIEN)) Q:'MSGIEN D - ..N NODE,TIME - ..D DEQUE^HLOQUE(QUEUE("LINK"),QUEUE("QUEUE"),"OUT",MSGIEN) - ..S TIME=$P(DEQUE(MSGIEN),"^") - ..Q:'TIME - ..S NODE=QUEUE("LINK")_"^"_QUEUE("QUEUE")_"^"_$P(DEQUE(MSGIEN),"^",2,99) - ..S ^HLTMP("CLIENT UPDATES",$J,TIME,MSGIEN)=NODE - ..S:$G(DEQUE(MSGIEN,"MSA"))]"" ^HLTMP("CLIENT UPDATES",$J,TIME,MSGIEN,"MSA")=DEQUE(MSGIEN,"MSA") - ..S:$G(DEQUE(MSGIEN,"ACTION"))]"" ^HLTMP("CLIENT UPDATES",$J,TIME,MSGIEN,"ACTION")=DEQUE(MSGIEN,"ACTION") - .K DEQUE S DEQUE=0 - Q - ; -TRANSMIT(HLCSTATE,MSGIEN,UPDATE) ; - ;Transmits a single message and if a commit ack was requested reads it. Updates file 778 with the result. Queues for the infiler the application accept action if one was requested. - ;Input: - ; HLCSTATE (pass by reference) - ; MSGIEN - ien, file 778, of message to be transmitted - ;Output: - ; Function returns 1 on success, 0 on failure - ; UPDATE - (pass by reference) to contain updates needed for message - ; - N HLMSTATE,MSA,HDR,SUCCESS - ; - S SUCCESS=0 - S HLCSTATE("ATTEMPT")=0 - ; - ;start saving updates needed after the message is transmitted - S UPDATE=MSGIEN - Q:'$$GETMSG^HLOCLNT2(MSGIEN,.HLMSTATE) 1 ;returns 1 so the message will be removed from the queue - I HLMSTATE("DT/TM"),HLMSTATE("STATUS","ACCEPTED")!(HLMSTATE("HDR","ACCEPT ACK TYPE")="NE") Q 1 ;the message was already transmitted - ; - S UPDATE=UPDATE_"^"_$$NOW^XLFDT -RETRY D - .S HLCSTATE("ATTEMPT")=HLCSTATE("ATTEMPT")+1 - .I 'HLCSTATE("CONNECTED") D OPEN^HLOT(.HLCSTATE) Q:'HLCSTATE("CONNECTED") - .; - .;try to send the message - .; - .; - .Q:'$$WRITEMSG^HLOCLNT1(.HLCSTATE,.HLMSTATE) - .;does the message need an accept ack? - .I HLMSTATE("HDR","ACCEPT ACK TYPE")="AL" D - ..N FS - ..Q:'$$READACK^HLOCLNT1(.HLCSTATE,.HDR,.MSA) - ..;does the MSA refer to the correct control id? - ..S FS=$E(HDR(1),4) - ..Q:$P(MSA,FS,3)'=HLMSTATE("ID") - ..N ACKID,ACKCODE - ..S ACKCODE=$P(MSA,FS,2) - ..S ACKID=$S($E(HDR(1),1,3)="MSH":$P(HDR(2),FS,5),1:$P(HDR(2),FS,6)) - ..S $P(UPDATE,"^",5)=1 - ..S UPDATE("MSA")=ACKID_"^"_MSA - ..I '(ACKCODE="CA") S $P(UPDATE,"^",3)="ER",$P(UPDATE,"^",4)=2 - ..I ACKCODE="CA",HLMSTATE("HDR","APP ACK TYPE")="NE" S $P(UPDATE,"^",3)="SU",$P(UPDATE,"^",4)=$S(HLMSTATE("BATCH"):"2",1:1) - ..I ($P(UPDATE,"^",3)="ER") S $P(UPDATE,"^",6)=$P(HLMSTATE("HDR",1),FS,5) ;errors need the application for xref - ..; - ..;if it's from a sequence queue, timestamp the queue - ..I $L($G(HLMSTATE("STATUS","SEQUENCE QUEUE"))) D - ...L +^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE")):200 - ...I $P($G(^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE"))),"^")'=MSGIEN L -^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE")) Q - ...I ACKCODE="CA" S $P(^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE")),"^",2)=$$FMADD^XLFDT($P(UPDATE,"^",2),,,$$TIMEOUT^HLOAPP($$GETSAP^HLOCLNT2(MSGIEN))) L -^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE")) Q - ...;if the message wasn't accepted, need to notify without waiting - ...S $P(^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE")),"^",2)=$P(UPDATE,"^",2) - ...L -^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE")) - ..; - ..;does the app need notification of accept ack? - ..S UPDATE("ACTION")=HLMSTATE("ACCEPT ACK RESPONSE") - ..; - ..S SUCCESS=1 - .E D ;accept ack wasn't requested - ..S SUCCESS=1 - ..I HLMSTATE("HDR","APP ACK TYPE")="NE" S $P(UPDATE,"^",3)="SU",$P(UPDATE,"^",4)=$S(HLMSTATE("BATCH"):2,1:1) - ; - I 'SUCCESS,'HLCSTATE("CONNECTED"),(HLCSTATE("ATTEMPT")<2) G RETRY - I SUCCESS D - .D COUNT^HLOSTAT(.HLCSTATE,HLMSTATE("HDR","RECEIVING APPLICATION"),HLMSTATE("HDR","SENDING APPLICATION"),$S(HLMSTATE("BATCH"):"BATCH",1:HLMSTATE("HDR","MESSAGE TYPE")_"~"_HLMSTATE("HDR","EVENT"))) - .;if this is an ack to a message need to purge the original message, so store its ien with the purge date - .S:$G(HLMSTATE("ACK TO IEN")) $P(UPDATE,"^",4)=$P(UPDATE,"^",4)_"-"_HLMSTATE("ACK TO IEN") - I ('HLCSTATE("CONNECTED"))!('SUCCESS) D LINKDOWN(.HLCSTATE) - Q SUCCESS +HLOCLNT ;ALB/CJM- Client for sending messages - 10/4/94 1pm ;03/22/2007 + ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,134**;Oct 13, 1995;Build 30 + ;Per VHA Directive 2004-038, this routine should not be modified. + ; + ;GET WORK function for the process running under the Process Manager +GETWORK(QUE) ; + ;Input: + ; QUE - (pass by reference) These subscripts are used: + ; ("LINK") - _":"_ last obtained + ; ("QUEUE") - name of the queue last obtained + ;Output: + ; Function returns 1 if success, 0 if no more work + ; QUE - updated to identify next queue of messages to process. + ; ("LINK") - _":"_ + ; ("QUEUE") - the named queue on the link + ; ("DOWN") - =1 means that the last OPEN attempt failed + ; + N LINK,QUEUE + S LINK=$G(QUE("LINK")),QUEUE=$G(QUE("QUEUE")) + I (LINK]""),(QUEUE]"") D + .L -^HLB("QUEUE","OUT",LINK,QUEUE) + .I '$$CNNCTD(LINK),$$FAILING(.LINK) S QUEUE="" Q + .F S QUEUE=$O(^HLB("QUEUE","OUT",LINK,QUEUE)) Q:(QUEUE="") I '$$STOPPED^HLOQUE("OUT",QUEUE) L +^HLB("QUEUE","OUT",LINK,QUEUE):0 Q:$T + I (LINK]""),(QUEUE="") D + .F S LINK=$O(^HLB("QUEUE","OUT",LINK)) Q:LINK="" D Q:$L(QUEUE) + ..I '$$CNNCTD(LINK),$$FAILING(.LINK) Q + ..S QUEUE="" F S QUEUE=$O(^HLB("QUEUE","OUT",LINK,QUEUE)) Q:(QUEUE="") I '$$STOPPED^HLOQUE("OUT",QUEUE) L +^HLB("QUEUE","OUT",LINK,QUEUE):0 Q:$T + I LINK="" D + .F S LINK=$O(^HLB("QUEUE","OUT",LINK)) Q:LINK="" D Q:$L(QUEUE) + ..I '$$CNNCTD(LINK),$$FAILING(.LINK) Q + ..S QUEUE="" F S QUEUE=$O(^HLB("QUEUE","OUT",LINK,QUEUE)) Q:(QUEUE="") I '$$STOPPED^HLOQUE("OUT",QUEUE) L +^HLB("QUEUE","OUT",LINK,QUEUE):0 Q:$T + S QUE("LINK")=LINK,QUE("QUEUE")=QUEUE,QUE("DOWN")=$G(LINK("DOWN")) + Q:$L(QUEUE) 1 + D:$G(HLCSTATE("CONNECTED")) CLOSE^HLOT(.HLCSTATE) + Q 0 + ; +FAILING(LINK) ; + ;Returns 1 if the link has failed in the last 30 seconds, 0 otherwise + ;Also returns LINK("DOWN")=1 if the link was failing > 30 seconds ago, not yet known if its up + ; + N LASTTIME,SET + S LINK("DOWN")=0 + S LASTTIME=$G(^HLB("QUEUE","OUT",LINK)) + S SET=$S(LASTTIME]"":1,1:0) + I SET D + .I $$HDIFF^XLFDT($H,LASTTIME,2)>30 S ^HLB("QUEUE","OUT",LINK)="",SET=0,LINK("DOWN")=1 + I $D(^HLTMP("FAILING LINKS",LINK)) S LINK("DOWN")=1 + Q SET + ; +LINKDOWN(HLCSTATE) ; + D:$G(HLCSTATE("CONNECTED")) CLOSE^HLOT(.HLCSTATE) + I $D(HLCSTATE("LINK","NAME")),$D(HLCSTATE("LINK","PORT")) D + .S TO=HLCSTATE("LINK","NAME")_":"_HLCSTATE("LINK","PORT") + .S ^HLB("QUEUE","OUT",TO)=$H + .S:'$D(^HLTMP("FAILING LINKS",TO)) ^HLTMP("FAILING LINKS",TO)=$H + Q + ; +ERROR ;error trap + S $ETRAP="Q:$QUIT """" Q" + N HOUR + S HOUR=$E($$NOW^XLFDT,1,10) + S ^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2))=$G(^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2)))+1 + D END + D LINKDOWN(.HLCSTATE) + ; + I ($ECODE["TOOMANYFILES")!($ECODE["EDITED") Q:$QUIT "" Q + ;while debugging quit on all errors - this will return the process to the Process Manager error trap + I $G(^HLTMP("LOG ALL ERRORS")) Q:$QUIT "" Q + ; + ;don't log some common errors + I ($ECODE["READ")!($ECODE["NOTOPEN")!($ECODE["DEVNOTOPN")!($ECODE["WRITE")!($ECODE["OPENERR") D + .; + E D + .;but do log all the others + .D ^%ZTER + ; + ;a lot of errors of the same type may indicate an endless loop + ;return to the Process Manager error trap + I ($G(^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2)))>30) Q:$QUIT "" Q + ; + ;resume execution of the process manager executing the client + D UNWIND^%ZTER + Q + ; +DOWORK(QUEUE) ;sends the messages on the queue + N $ETRAP,$ESTACK S $ETRAP="G ERROR^HLOCLNT" + N MSGIEN,DEQUE,SUCCESS,MSGCOUNT + S DEQUE=0 + S SUCCESS=1 + ; + I '$$CNNCTD(QUEUE("LINK")),'$$CONNECT^HLOCLNT1($P(QUEUE("LINK"),":"),$P(QUEUE("LINK"),":",2),30,.HLCSTATE) Q + ; + S (MSGCOUNT,MSGIEN)=0 + F S MSGIEN=$O(^HLB("QUEUE","OUT",QUEUE("LINK"),QUEUE("QUEUE"),MSGIEN)) Q:'MSGIEN D Q:'SUCCESS Q:MSGCOUNT>1000 + .N UPDATE + .S ^HLB(MSGIEN,"TRIES")=$G(^HLB(MSGIEN,"TRIES"))+1 + .S SUCCESS=0 + .S:$$TRANSMIT(.HLCSTATE,MSGIEN,.UPDATE) SUCCESS=1 + .Q:('SUCCESS)!('$D(UPDATE)) + .D DEQUE(.UPDATE) + .S MSGCOUNT=MSGCOUNT+1 + .D:HLCSTATE("COUNTS")>4 SAVECNTS^HLOSTAT(.HLCSTATE) + .; + .;if the queue was on the down list, and not since shutdown, mark it as up, since a message has been successfully transmitted across it + .I $G(QUEUE("DOWN"))!$$FAILING(QUEUE("LINK")),'$$IFSHUT^HLOTLNK(QUEUE("LINK")) S QUEUE("DOWN")=0,^HLB("QUEUE","OUT",QUEUE("LINK"))="" K ^HLTMP("FAILING LINKS",QUEUE("LINK")) + ; +END D DEQUE() + D SAVECNTS^HLOSTAT(.HLCSTATE) + Q +CNNCTD(LINK) ; + ;Connected to LINK? HLCSTATE must be defined, LINK=: + ; + I ($G(HLCSTATE("LINK","NAME"))=$P(LINK,":")),($G(HLCSTATE("LINK","PORT"))=$P(LINK,":",2)),$G(HLCSTATE("CONNECTED")) Q 1 + Q 0 + ; +DEQUE(UPDATE) ; + I $D(UPDATE) S DEQUE=DEQUE+1,DEQUE(+UPDATE)=$P(UPDATE,"^",2,99) S:$G(UPDATE("MSA"))]"" DEQUE(+UPDATE,"MSA")=UPDATE("MSA") S:$G(UPDATE("ACTION"))]"" DEQUE(+UPDATE,"ACTION")=UPDATE("ACTION") + I '$D(UPDATE)!(DEQUE>15) D + .N MSGIEN S MSGIEN=0 + .F S MSGIEN=$O(DEQUE(MSGIEN)) Q:'MSGIEN D + ..N NODE,TIME + ..D DEQUE^HLOQUE(QUEUE("LINK"),QUEUE("QUEUE"),"OUT",MSGIEN) + ..S TIME=$P(DEQUE(MSGIEN),"^") + ..Q:'TIME + ..S NODE=QUEUE("LINK")_"^"_QUEUE("QUEUE")_"^"_$P(DEQUE(MSGIEN),"^",2,99) + ..S ^HLTMP("CLIENT UPDATES",$J,TIME,MSGIEN)=NODE + ..S:$G(DEQUE(MSGIEN,"MSA"))]"" ^HLTMP("CLIENT UPDATES",$J,TIME,MSGIEN,"MSA")=DEQUE(MSGIEN,"MSA") + ..S:$G(DEQUE(MSGIEN,"ACTION"))]"" ^HLTMP("CLIENT UPDATES",$J,TIME,MSGIEN,"ACTION")=DEQUE(MSGIEN,"ACTION") + .K DEQUE S DEQUE=0 + Q + ; +TRANSMIT(HLCSTATE,MSGIEN,UPDATE) ; + ;Transmits a single message and if a commit ack was requested reads it. Updates file 778 with the result. Queues for the infiler the application accept action if one was requested. + ;Input: + ; HLCSTATE (pass by reference) + ; MSGIEN - ien, file 778, of message to be transmitted + ;Output: + ; Function returns 1 on success, 0 on failure + ; UPDATE - (pass by reference) to contain updates needed for message + ; + N HLMSTATE,MSA,HDR,SUCCESS + ; + S SUCCESS=0 + S HLCSTATE("ATTEMPT")=0 + ; + ;start saving updates needed after the message is transmitted + S UPDATE=MSGIEN + Q:'$$GETMSG^HLOCLNT2(MSGIEN,.HLMSTATE) 1 ;returns 1 so the message will be removed from the queue + I HLMSTATE("DT/TM"),HLMSTATE("STATUS","ACCEPTED")!(HLMSTATE("HDR","ACCEPT ACK TYPE")="NE") Q 1 ;the message was already transmitted + ; + S UPDATE=UPDATE_"^"_$$NOW^XLFDT +RETRY D + .S HLCSTATE("ATTEMPT")=HLCSTATE("ATTEMPT")+1 + .I 'HLCSTATE("CONNECTED") D OPEN^HLOT(.HLCSTATE) Q:'HLCSTATE("CONNECTED") + .; + .;try to send the message + .Q:'$$WRITEMSG^HLOCLNT1(.HLCSTATE,.HLMSTATE) + .;does the message need an accept ack? + .I HLMSTATE("HDR","ACCEPT ACK TYPE")="AL" D + ..N FS + ..Q:'$$READACK^HLOCLNT1(.HLCSTATE,.HDR,.MSA) + ..;does the MSA refer to the correct control id? + ..S FS=$E(HDR(1),4) + ..Q:$P(MSA,FS,3)'=HLMSTATE("ID") + ..N ACKID,ACKCODE + ..S ACKCODE=$P(MSA,FS,2) + ..S ACKID=$S($E(HDR(1),1,3)="MSH":$P(HDR(2),FS,5),1:$P(HDR(2),FS,6)) + ..S $P(UPDATE,"^",5)=1 + ..S UPDATE("MSA")=ACKID_"^"_MSA + ..I '(ACKCODE="CA") S $P(UPDATE,"^",3)="SE",$P(UPDATE,"^",4)=2 + ..I ACKCODE="CA",HLMSTATE("HDR","APP ACK TYPE")="NE" S $P(UPDATE,"^",3)="SU",$P(UPDATE,"^",4)=$S(HLMSTATE("BATCH"):"2",1:1) + ..I ($P(UPDATE,"^",3)="SE") S $P(UPDATE,"^",6)=$P(HLMSTATE("HDR",1),FS,5) ;errors need the application for xref + ..; + ..;did the app request notification of accept ack? + ..S UPDATE("ACTION")=HLMSTATE("ACCEPT ACK RESPONSE") + ..S SUCCESS=1 + .E D ;accept ack wasn't requested + ..S SUCCESS=1 + ..I HLMSTATE("HDR","APP ACK TYPE")="NE" S $P(UPDATE,"^",3)="SU",$P(UPDATE,"^",4)=$S(HLMSTATE("BATCH"):2,1:1) + ; + I 'SUCCESS,'HLCSTATE("CONNECTED"),(HLCSTATE("ATTEMPT")<2) G RETRY + I SUCCESS D + .D COUNT^HLOSTAT(.HLCSTATE,HLMSTATE("HDR","RECEIVING APPLICATION"),HLMSTATE("HDR","SENDING APPLICATION"),$S(HLMSTATE("BATCH"):"BATCH",1:HLMSTATE("HDR","MESSAGE TYPE")_"~"_HLMSTATE("HDR","EVENT"))) + .;if this is an ack to a message need to purge the original message, so store its ien with the purge date + .S:$G(HLMSTATE("ACK TO IEN")) $P(UPDATE,"^",4)=$P(UPDATE,"^",4)_"-"_HLMSTATE("ACK TO IEN") + I ('HLCSTATE("CONNECTED"))!('SUCCESS) D LINKDOWN(.HLCSTATE) + Q SUCCESS diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT1.m b/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT1.m index 3ec74af7..8d62ae9f 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT1.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT1.m @@ -1,154 +1,154 @@ -HLOCLNT1 ;IRMFO-ALB/CJM - Writing messages, reading acks;03/24/2004 14:43 ;07/10/2007 - ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,134,137**;Oct 13, 1995;Build 21 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; - ; -WRITEMSG(HLCSTATE,HLMSTATE) ; - ;Description: This function uses the services offered by the transport layer to send a message over an open communication channel. - ; - ;Input: - ; HLCSTATE (pass by reference, required) Defines the LLP & its state - ; HLMSTATE (pass by reference, required) The message - ;Output: - ; Function returns 1 on success, 0 on failure - ; - N SEG,QUIT,HDR - S QUIT=0 - Q:'$G(HLMSTATE("IEN")) 0 - S HDR(1)=HLMSTATE("HDR",1),HDR(2)=HLMSTATE("HDR",2) - Q:'$$WRITEHDR^HLOT(.HLCSTATE,.HDR) 0 - I HLMSTATE("BATCH") D - .N LAST S LAST=0 - .S HLMSTATE("BATCH","CURRENT MESSAGE")=0 - .F Q:'$$NEXTMSG^HLOMSG(.HLMSTATE,.SEG) D Q:QUIT - ..S LAST=HLMSTATE("BATCH","CURRENT MESSAGE") - ..I '$$WRITESEG^HLOT(.HLCSTATE,.SEG) S QUIT=1 Q - ..F Q:'$$HLNEXT^HLOMSG(.HLMSTATE,.SEG) D Q:QUIT - ...I '$$WRITESEG^HLOT(.HLCSTATE,.SEG) S QUIT=1 Q - .K SEG S SEG(1)="BTS"_HLMSTATE("HDR","FIELD SEPARATOR")_LAST - .S:'$$WRITESEG^HLOT(.HLCSTATE,.SEG) QUIT=1 - E D - .F Q:'$$HLNEXT^HLOMSG(.HLMSTATE,.SEG) D Q:QUIT - ..S:'$$WRITESEG^HLOT(.HLCSTATE,.SEG) QUIT=1 - S:'$$ENDMSG^HLOT(.HLCSTATE) QUIT=1 - Q 'QUIT - ; -READACK(HLCSTATE,HDR,MSA) ; - ;Description: This function uses the services offered by the transport layer to read an accept ack. - ; - ;Input: - ; HLCSTATE (pass by reference, required) Defines the communication channel and its state. - ;Output: - ; Function returns 1 on success, 0 on failure - ; HDR (pass by reference) the message header: - ; HDR(1) is components 1-6 - ; HDR(2) is components 7-end - ; MSA (pass by reference) the MSA segment as an unsubscripted variable - ; - N SEG - K HDR,MSA,MAX,I - S MAX=HLCSTATE("SYSTEM","MAXSTRING")-40 ;MAX is the maximum that can be safely stored on a node, leaving room for the other fields stored with MSA seg - Q:'$$READHDR^HLOT(.HLCSTATE,.HDR) 0 - F Q:'$$READSEG^HLOT(.HLCSTATE,.SEG) D - .I $E($E(SEG(1),1,3)_$E($G(SEG(2)),1,3),1,3)="MSA" D - ..S MSA="" - ..F I=1:1 Q:'$D(SEG(I)) S MSA=MSA_$S((MAX-$L(MSA))<1:"",1:$E(SEG(I),1,MAX)) - I $D(MSA),HLCSTATE("MESSAGE ENDED") D Q 1 - .D SPLITHDR^HLOSRVR1(.HDR) - .S HLCSTATE("COUNTS","ACKS")=$G(HLCSTATE("COUNTS","ACKS"))+1 - Q 0 - ; -CONNECT(LINK,PORT,TIMEOUT,HLCSTATE) ; - ;sets up HLCSTATE() and opens a client connection - ;Input: - ; LINK - name of the link to connect to - ; PORT (optional) port # to connect to, defaults to that specified by the link - ; TIMEOUT (optional) specifies the open timeout in seconds, defaults to 30 - ;Output: - ; HLCSTATE - array to hold the connection state - ; - I $G(HLCSTATE("CONNECTED")) D Q:HLCSTATE("CONNECTED") - .I $G(HLCSTATE("LINK","NAME"))]"",($G(HLCSTATE("LINK","NAME"))'=LINK) D CLOSE^HLOT(.HLCSTATE) Q - .I $G(HLCSTATE("LINK","NAME"))]"",$G(PORT),($G(HLCSTATE("LINK","PORT"))'=PORT) D CLOSE^HLOT(.HLCSTATE) Q - .I (HLCSTATE("SYSTEM","OS")="CACHE") D Q - ..U HLCSTATE("DEVICE") S HLCSTATE("CONNECTED")=($ZA\8192#2) - ..I 'HLCSTATE("CONNECTED") D CLOSE^HLOT(.HLCSTATE) - .;D CLOSE^HLOT(.HLCSTATE) - K HLCSTATE - N ARY,NODE - I '$$GETLINK^HLOTLNK(LINK,.ARY) S HLCSTATE("LINK","NAME")=LINK,HLCSTATE("LINK","PORT")=$G(PORT) D LINKDOWN^HLOCLNT(.HLCSTATE) Q 0 - M HLCSTATE("LINK")=ARY - I HLCSTATE("LINK","SHUTDOWN") S HLCSTATE("CONNECTED")=0 D LINKDOWN^HLOCLNT(.HLCSTATE) Q 0 - ;overlay the port if supplied from the queue - S:$G(PORT) HLCSTATE("LINK","PORT")=PORT - S HLCSTATE("READ TIMEOUT")=20 - S HLCSTATE("OPEN TIMEOUT")=$S($G(TIMEOUT):TIMEOUT,1:30) - S HLCSTATE("COUNTS")=0 - S HLCSTATE("READ")="" ;where the reads are stored - ; - ;HLCSTATE("BUFFER",,) serves as a write buffer so that a lot can be written all at once - S HLCSTATE("BUFFER","BYTE COUNT")=0 ;count of BYTES in buffer - S HLCSTATE("BUFFER","SEGMENT COUNT")=0 ;count of segments in buffer - ; - S HLCSTATE("MESSAGE ENDED")=0 ;end of message flag - S NODE=^%ZOSF("OS") - S HLCSTATE("SERVER")=0 - S HLCSTATE("SYSTEM","OS")=$S(NODE["DSM":"DSM",NODE["OpenM":"CACHE",NODE["G.TM":"G.TM",1:"") - I HLCSTATE("SYSTEM","OS")="" D LINKDOWN^HLOCLNT(.HLCSTATE) Q 0 - D - .N SYS - .D SYSPARMS^HLOSITE(.SYS) - .S HLCSTATE("SYSTEM","BUFFER")=SYS("HL7 BUFFER") - .S HLCSTATE("SYSTEM","MAXSTRING")=SYS("MAXSTRING") - .S HLCSTATE("SYSTEM","NORMAL PURGE")=SYS("NORMAL PURGE") - .S HLCSTATE("SYSTEM","ERROR PURGE")=SYS("ERROR PURGE") - I HLCSTATE("LINK","LLP")="TCP" D - .S HLCSTATE("OPEN")="OPEN^HLOTCP" - E ;no other LLP implemented - D OPEN^HLOT(.HLCSTATE) - ; - ;mark the failure time for the link so other processes know not to try for a while - I 'HLCSTATE("CONNECTED") D LINKDOWN^HLOCLNT(.HLCSTATE) - Q HLCSTATE("CONNECTED") - ; -BADMSGS(WORK) ; - ;finds messages that won't transmit after 8 hours of trying and takes them off the outgoing queue - N LINK - S LINK="" - F S LINK=$O(^HLTMP("FAILING LINKS",LINK)) Q:LINK="" D - .N TIME,QUE,COUNT - .S TIME=$G(^HLTMP("FAILING LINKS",LINK)) Q:TIME="" - .Q:$$HDIFF^XLFDT($H,TIME,2)<28800 ;8 hours - .Q:'$$IFOPEN^HLOUSR1(LINK) - .L +^HLB("QUEUE","OUT",LINK):0 - .S QUE="" - .F S QUE=$O(^HLB("QUEUE","OUT",LINK,QUE)) Q:QUE="" D - ..N MSG S MSG=0 - ..S MSG=$O(^HLB("QUEUE","OUT",LINK,QUE,MSG)) - ..Q:'MSG - ..S COUNT=$G(^HLB(MSG,"TRIES")) - ..I COUNT>20 D - ...N NODE0,NODE1,NODE2,TIME,RAPP,SAPP,FS,CS,ACTION,MTYPE,EVENT - ...S NODE0=$G(^HLB(MSG,0)) - ...Q:'$P(NODE0,"^",2) - ...S TIME=$$NOW^XLFDT - ...S NODE1=$G(^HLB(MSG,1)) - ...S NODE2=$G(^HLB(MSG,2)) - ...S FS=$E(NODE1,4) - ...Q:FS="" - ...S CS=$E(NODE1,5) - ...Q:CS="" - ...S SAPP=$P(NODE1,FS,3) - ...S:SAPP="" SAPP="UNKNOWN" - ...S RAPP=$P(NODE1,FS,5) - ...S MTYPE=$P($P(NODE2,FS,4),CS) - ...S EVENT=$P($P(NODE2,FS,4),CS,2) - ...S $P(^HLB(MSG,0),"^",21)=COUNT_" FAILED TRANSMISSIONS" - ...S $P(^HLB(MSG,0),"^",20)="TF" - ...S ^HLB("ERRORS",RAPP,TIME,MSG)="" - ...D COUNT^HLOESTAT("OUT",RAPP,SAPP,MTYPE,EVENT) - ...S ACTION=$P(NODE0,"^",14,15) - ...I ACTION'="^",ACTION]"" D INQUE^HLOQUE(LINK,QUE,MSG,ACTION,1) - ...D DEQUE^HLOQUE(LINK,QUE,"OUT",MSG) - .L -^HLB("QUEUE","OUT",LINK) - Q +HLOCLNT1 ;IRMFO-ALB/CJM - Writing messages, reading acks;03/24/2004 14:43 ;03/19/2007 + ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,134**;Oct 13, 1995;Build 30 + ;Per VHA Directive 2004-038, this routine should not be modified. + ; + ; +WRITEMSG(HLCSTATE,HLMSTATE) ; + ;Description: This function uses the services offered by the transport layer to send a message over an open communication channel. + ; + ;Input: + ; HLCSTATE (pass by reference, required) Defines the LLP & its state + ; HLMSTATE (pass by reference, required) The message + ;Output: + ; Function returns 1 on success, 0 on failure + ; + N SEG,QUIT,HDR + S QUIT=0 + Q:'$G(HLMSTATE("IEN")) 0 + S HDR(1)=HLMSTATE("HDR",1),HDR(2)=HLMSTATE("HDR",2) + Q:'$$WRITEHDR^HLOT(.HLCSTATE,.HDR) 0 + I HLMSTATE("BATCH") D + .N LAST S LAST=0 + .S HLMSTATE("BATCH","CURRENT MESSAGE")=0 + .F Q:'$$NEXTMSG^HLOMSG(.HLMSTATE,.SEG) D Q:QUIT + ..S LAST=HLMSTATE("BATCH","CURRENT MESSAGE") + ..I '$$WRITESEG^HLOT(.HLCSTATE,.SEG) S QUIT=1 Q + ..F Q:'$$HLNEXT^HLOMSG(.HLMSTATE,.SEG) D Q:QUIT + ...I '$$WRITESEG^HLOT(.HLCSTATE,.SEG) S QUIT=1 Q + .K SEG S SEG(1)="BTS"_HLMSTATE("HDR","FIELD SEPARATOR")_LAST + .S:'$$WRITESEG^HLOT(.HLCSTATE,.SEG) QUIT=1 + E D + .F Q:'$$HLNEXT^HLOMSG(.HLMSTATE,.SEG) D Q:QUIT + ..S:'$$WRITESEG^HLOT(.HLCSTATE,.SEG) QUIT=1 + S:'$$ENDMSG^HLOT(.HLCSTATE) QUIT=1 + Q 'QUIT + ; +READACK(HLCSTATE,HDR,MSA) ; + ;Description: This function uses the services offered by the transport layer to read an accept ack. + ; + ;Input: + ; HLCSTATE (pass by reference, required) Defines the communication channel and its state. + ;Output: + ; Function returns 1 on success, 0 on failure + ; HDR (pass by reference) the message header: + ; HDR(1) is components 1-6 + ; HDR(2) is components 7-end + ; MSA (pass by reference) the MSA segment as an unsubscripted variable + ; + N SEG + K HDR,MSA,MAX,I + S MAX=HLCSTATE("SYSTEM","MAXSTRING")-40 ;MAX is the maximum that can be safely stored on a node, leaving room for the other fields stored with MSA seg + Q:'$$READHDR^HLOT(.HLCSTATE,.HDR) 0 + F Q:'$$READSEG^HLOT(.HLCSTATE,.SEG) D + .I $E($E(SEG(1),1,3)_$E($G(SEG(2)),1,3),1,3)="MSA" D + ..S MSA="" + ..F I=1:1 Q:'$D(SEG(I)) S MSA=MSA_$S((MAX-$L(MSA))<1:"",1:$E(SEG(I),1,MAX)) + I $D(MSA),HLCSTATE("MESSAGE ENDED") D Q 1 + .D SPLITHDR^HLOSRVR1(.HDR) + .S HLCSTATE("COUNTS","ACKS")=$G(HLCSTATE("COUNTS","ACKS"))+1 + Q 0 + ; +CONNECT(LINK,PORT,TIMEOUT,HLCSTATE) ; + ;sets up HLCSTATE() and opens a client connection + ;Input: + ; LINK - name of the link to connect to + ; PORT (optional) port # to connect to, defaults to that specified by the link + ; TIMEOUT (optional) specifies the open timeout in seconds, defaults to 30 + ;Output: + ; HLCSTATE - array to hold the connection state + ; + I $G(HLCSTATE("CONNECTED")) D Q:HLCSTATE("CONNECTED") + .I $G(HLCSTATE("LINK","NAME"))]"",($G(HLCSTATE("LINK","NAME"))'=LINK) D CLOSE^HLOT(.HLCSTATE) Q + .I $G(HLCSTATE("LINK","NAME"))]"",$G(PORT),($G(HLCSTATE("LINK","PORT"))'=PORT) D CLOSE^HLOT(.HLCSTATE) Q + .I (HLCSTATE("SYSTEM","OS")="CACHE") D Q + ..U HLCSTATE("DEVICE") S HLCSTATE("CONNECTED")=($ZA\8192#2) + ..I 'HLCSTATE("CONNECTED") D CLOSE^HLOT(.HLCSTATE) + .;D CLOSE^HLOT(.HLCSTATE) + K HLCSTATE + N ARY,NODE + I '$$GETLINK^HLOTLNK(LINK,.ARY) S HLCSTATE("LINK","NAME")=LINK,HLCSTATE("LINK","PORT")=$G(PORT) D LINKDOWN^HLOCLNT(.HLCSTATE) Q 0 + M HLCSTATE("LINK")=ARY + I HLCSTATE("LINK","SHUTDOWN") S HLCSTATE("CONNECTED")=0 D LINKDOWN^HLOCLNT(.HLCSTATE) Q 0 + ;overlay the port if supplied from the queue + S:$G(PORT) HLCSTATE("LINK","PORT")=PORT + S HLCSTATE("READ TIMEOUT")=20 + S HLCSTATE("OPEN TIMEOUT")=$S($G(TIMEOUT):TIMEOUT,1:30) + S HLCSTATE("COUNTS")=0 + S HLCSTATE("READ")="" ;where the reads are stored + ; + ;HLCSTATE("BUFFER",,) serves as a write buffer so that a lot can be written all at once + S HLCSTATE("BUFFER","BYTE COUNT")=0 ;count of BYTES in buffer + S HLCSTATE("BUFFER","SEGMENT COUNT")=0 ;count of segments in buffer + ; + S HLCSTATE("MESSAGE ENDED")=0 ;end of message flag + S NODE=^%ZOSF("OS") + S HLCSTATE("SERVER")=0 + S HLCSTATE("SYSTEM","OS")=$S(NODE["DSM":"DSM",NODE["OpenM":"CACHE",NODE["G.TM":"G.TM",1:"") + I HLCSTATE("SYSTEM","OS")="" D LINKDOWN^HLOCLNT(.HLCSTATE) Q 0 + D + .N SYS + .D SYSPARMS^HLOSITE(.SYS) + .S HLCSTATE("SYSTEM","BUFFER")=SYS("HL7 BUFFER") + .S HLCSTATE("SYSTEM","MAXSTRING")=SYS("MAXSTRING") + .S HLCSTATE("SYSTEM","NORMAL PURGE")=SYS("NORMAL PURGE") + .S HLCSTATE("SYSTEM","ERROR PURGE")=SYS("ERROR PURGE") + I HLCSTATE("LINK","LLP")="TCP" D + .S HLCSTATE("OPEN")="OPEN^HLOTCP" + E ;no other LLP implemented + D OPEN^HLOT(.HLCSTATE) + ; + ;mark the failure time for the link so other processes know not to try for a while + I 'HLCSTATE("CONNECTED") D LINKDOWN^HLOCLNT(.HLCSTATE) + Q HLCSTATE("CONNECTED") + ; +BADMSGS(WORK) ; + ;finds messages that won't transmit after 8 hours of trying and takes them off the outgoing queue + N LINK + S LINK="" + F S LINK=$O(^HLTMP("FAILING LINKS",LINK)) Q:LINK="" D + .N TIME,QUE,COUNT + .S TIME=$G(^HLTMP("FAILING LINKS",LINK)) Q:TIME="" + .Q:$$HDIFF^XLFDT($H,TIME,2)<28800 ;8 hours + .Q:'$$IFOPEN^HLOUSR1(LINK) + .L +^HLB("QUEUE","OUT",LINK):0 + .S QUE="" + .F S QUE=$O(^HLB("QUEUE","OUT",LINK,QUE)) Q:QUE="" D + ..N MSG S MSG=0 + ..S MSG=$O(^HLB("QUEUE","OUT",LINK,QUE,MSG)) + ..Q:'MSG + ..S COUNT=$G(^HLB(MSG,"TRIES")) + ..I COUNT>20 D + ...N NODE0,NODE1,NODE2,TIME,RAPP,SAPP,FS,CS,ACTION,MTYPE,EVENT + ...S NODE0=$G(^HLB(MSG,0)) + ...Q:'$P(NODE0,"^",2) + ...S TIME=$$NOW^XLFDT + ...S NODE1=$G(^HLB(MSG,1)) + ...S NODE2=$G(^HLB(MSG,2)) + ...S FS=$E(NODE1,4) + ...Q:FS="" + ...S CS=$E(NODE1,5) + ...Q:CS="" + ...S SAPP=$P(NODE1,FS,3) + ...S:SAPP="" SAPP="UNKNOWN" + ...S RAPP=$P(NODE1,FS,5) + ...S MTYPE=$P($P(NODE2,FS,4),CS) + ...S EVENT=$P($P(NODE2,FS,4),CS,2) + ...S $P(^HLB(MSG,0),"^",21)=COUNT_" FAILED TRANSMISSIONS" + ...S $P(^HLB(MSG,0),"^",20)="TF" + ...S ^HLB("ERRORS","TF",SAPP,TIME,MSG)="" + ...D COUNT^HLOESTAT("OUT",RAPP,SAPP,MTYPE,EVENT) + ...S ACTION=$P(NODE0,"^",14,15) + ...I ACTION'="^",ACTION]"" D INQUE^HLOQUE(LINK,QUE,MSG,ACTION,1) + ...D DEQUE^HLOQUE(LINK,QUE,"OUT",MSG) + .L -^HLB("QUEUE","OUT",LINK) + Q diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT2.m b/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT2.m index f8bbcb50..8f67d6d1 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT2.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT2.m @@ -1,183 +1,181 @@ -HLOCLNT2 ;ALB/CJM- Performs message updates for the client - 10/4/94 1pm ;07/10/2007 - ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,133,134,137**;Oct 13, 1995;Build 21 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; -GETWORK(WORK) ; - ; - N OLD,DOLLARJ,SUCCESS,NOW - S SUCCESS=0 - S NOW=$$NOW^XLFDT - S (OLD,DOLLARJ)=$G(WORK("DOLLARJ")) - F S DOLLARJ=$O(^HLTMP("CLIENT UPDATES",DOLLARJ)) Q:DOLLARJ="" D Q:SUCCESS - .L +^HLTMP("CLIENT UPDATES",DOLLARJ):0 - .Q:'$T - .N TIME S TIME=$O(^HLTMP("CLIENT UPDATES",DOLLARJ,"")) - .I $$FMDIFF^XLFDT(NOW,TIME,2)<2 L -^HLTMP("CLIENT UPDATES",DOLLARJ) Q - .S SUCCESS=1 - ; - I OLD'="",'SUCCESS F S DOLLARJ=$O(^HLTMP("CLIENT UPDATES",DOLLARJ)) Q:DOLLARJ="" Q:DOLLARJ>OLD D Q:SUCCESS - .L +^HLTMP("CLIENT UPDATES",DOLLARJ):0 - .Q:'$T - .N TIME S TIME=$O(^HLTMP("CLIENT UPDATES",DOLLARJ,"")) - .I $$FMDIFF^XLFDT(NOW,TIME,2)<2 L -^HLTMP("CLIENT UPDATES",DOLLARJ) Q - .S SUCCESS=1 - S WORK("DOLLARJ")=DOLLARJ,WORK("NOW")=NOW - Q $S($L(WORK("DOLLARJ")):1,1:0) - ; -DOWORK(WORK) ; - ; - N DOLLARJ,TIME,IEN,PARMS,SYSTEM - S TIME="" - S DOLLARJ=WORK("DOLLARJ") - D SYSPARMS^HLOSITE(.SYSTEM) - F S TIME=$O(^HLTMP("CLIENT UPDATES",DOLLARJ,TIME)) Q:TIME="" Q:$$FMDIFF^XLFDT(WORK("NOW"),TIME,2)<2 D - .S IEN=0 - .F S IEN=$O(^HLTMP("CLIENT UPDATES",DOLLARJ,TIME,IEN)) Q:'IEN D - ..N NODE - ..S NODE=$G(^HLTMP("CLIENT UPDATES",DOLLARJ,TIME,IEN)) - ..S PARMS("LINK")=$P(NODE,"^") - ..S PARMS("QUEUE")=$P(NODE,"^",2) - ..S PARMS("STATUS")=$P(NODE,"^",3) - ..S PARMS("PURGE TYPE")=$P(NODE,"^",4) - ..S PARMS("ACK TO IEN")=+$P($P(NODE,"^",4),"-",2) - ..S PARMS("ACCEPT ACK")=$P(NODE,"^",5) - ..S PARMS("RECEIVING APP")=$P(NODE,"^",6) - ..S:PARMS("RECEIVING APP")="" PARMS("RECEIVING APP")="UNKNOWN RECEIVING APPLICATION" - ..S PARMS("MSA")=$G(^HLTMP("CLIENT UPDATES",DOLLARJ,TIME,IEN,"MSA")) - ..S PARMS("ACTION")=$G(^HLTMP("CLIENT UPDATES",DOLLARJ,TIME,IEN,"ACTION")) - ..D UPDATE(IEN,TIME,.PARMS) - ..K ^HLTMP("CLIENT UPDATES",DOLLARJ,TIME,IEN) - L -^HLTMP("CLIENT UPDATES",DOLLARJ) - Q - ; -UPDATE(MSGIEN,TIME,PARMS) ; - S:PARMS("STATUS")]"" $P(^HLB(MSGIEN,0),"^",20)=PARMS("STATUS") - I PARMS("STATUS")="ER" D - .S ^HLB("ERRORS",PARMS("RECEIVING APP"),TIME,MSGIEN_"^")="" - .D COUNT^HLOESTAT("OUT",PARMS("RECEIVING APP"),$$GETSAP(MSGIEN),$$GETMTYPE(MSGIEN)) - S:PARMS("ACCEPT ACK") $P(^HLB(MSGIEN,0),"^",17)=PARMS("ACCEPT ACK") - S $P(^HLB(MSGIEN,0),"^",16)=TIME - S:PARMS("MSA")]"" ^HLB(MSGIEN,4)=TIME_"^"_PARMS("MSA") - I PARMS("PURGE TYPE"),PARMS("ACTION")="" D - .;don't set purge if going on the infiler - let infiler do it - .N PTIME - .S:(PARMS("PURGE TYPE")=2) PTIME=$$FMADD^XLFDT(TIME,SYSTEM("ERROR PURGE")) ;error purge is in days - .S:(PARMS("PURGE TYPE")'=2) PTIME=$$FMADD^XLFDT(TIME,,SYSTEM("NORMAL PURGE")) ;normal purge is in hours - .S $P(^HLB(MSGIEN,0),"^",9)=PTIME,^HLB("AD","OUT",PTIME,MSGIEN)="" - .I PARMS("ACK TO IEN"),$D(^HLB(PARMS("ACK TO IEN"),0)) S $P(^HLB(PARMS("ACK TO IEN"),0),"^",9)=PTIME,^HLB("AD","OUT",PTIME,PARMS("ACK TO IEN"))="" - D:PARMS("ACTION")]"" - .N PURGE - .S PURGE=$S(PARMS("PURGE TYPE"):1,1:0) - .S:PARMS("ACK TO IEN") PURGE("ACKTOIEN")=PARMS("ACK TO IEN") - .D INQUE^HLOQUE(PARMS("LINK"),PARMS("QUEUE"),MSGIEN,PARMS("ACTION"),.PURGE) - Q - ; -GETMSG(IEN,MSG) ; - ; - ;Description: given the message ien=MSGIEN (required), it returns the MSG array containing information about the message, defined below. - ;Input: - ; IEN - the ien of the message in file 778 - ;Output: - ; Function returns 1 on success, 0 on failure - ; MSG (pass by reference, required) These are the subscripts returned: - ; "ACCEPT ACK RESPONSE" - if the sending app requested notification of the accept ack, this is the routine to perform - ; "ACKTOIEN" - if this is an app ack to a message not in a batch, this is the ien of the original message - ; "BATCH" = 1 if this is a batch message, 0 if not - ; "CURRENT MESSAGE" - defined only for batch messages - a counterused during building and parsing messages to indicate the current message. It will be set to 0 initially. - ; "BODY" - ptr to file 778 which contains the body of the message. - ; "LINE COUNT" - a counter used during writing of the - ; messages to indicate the current line. For - ; batch messages where each message within the batch is stored - ; separately, this field indicates the position within the current - ; individual message - ; "HDR" at these lower subscripts: - ; 1 - components 1-6 - ; 2 - components 7-end - ; "ACCEPT ACK TYPE" = "AL" or "NE" - ; "APP ACK TYPE" = "AL" or "NE" - ; "MESSAGE CONTROL ID" - defined if NOT batch - ; "BATCH CONTROL ID" - defined if batch - ; - ; "ID" - message id from the header - ; "IEN" - ien, file 778 - ; "STATUS","SEQUENCE QUEUE")=name of the sequence queue (optional) - ; - K MSG - Q:'$G(IEN) 0 - N NODE,FS,CS,REP,SUBCOMP,ESCAPE - S MSG("IEN")=IEN - S NODE=$G(^HLB(IEN,0)) - S MSG("BODY")=$P(NODE,"^",2) - S MSG("ID")=$P(NODE,"^") - Q:'MSG("BODY") 0 - S MSG("STATUS","ACCEPTED")=$P(NODE,"^",17) - S MSG("DT/TM")=$P(NODE,"^",16) - S MSG("STATUS","QUEUE")=$P(NODE,"^",6) - I MSG("STATUS","QUEUE")="" S MSG("STATUS","QUEUE")="DEFAULT" - S MSG("ACCEPT ACK RESPONSE")=$P(NODE,"^",12,13) - I MSG("ACCEPT ACK RESPONSE")="^" S MSG("ACCEPT ACK RESPONSE")="" - ; - S MSG("BATCH")=+$P($G(^HLA(MSG("BODY"),0)),"^",2) - I MSG("BATCH") D - .S MSG("BATCH","CURRENT MESSAGE")=0 - E D - .N ACKTO - .S ACKTO=$P(NODE,"^",3) - .I ACKTO]"" S ACKTO=$$ACKTOIEN^HLOMSG1(MSG("ID"),ACKTO) - .I ACKTO,+ACKTO=ACKTO S MSG("ACK TO IEN")=ACKTO - S MSG("LINE COUNT")=0 - S MSG("HDR",1)=$G(^HLB(IEN,1)) - S MSG("HDR",2)=$G(^HLB(IEN,2)) - S FS=$E(MSG("HDR",1),4) - S CS=$E(MSG("HDR",1),5) - S REP=$E(MSG("HDR",1),6) - S ESCAPE=$E(MSG("HDR",1),7) - S SUBCOMP=$E(MSG("HDR",1),8) - S MSG("HDR","FIELD SEPARATOR")=FS - S MSG("HDR","SENDING APPLICATION")=$$DESCAPE^HLOPRS1($P($P(MSG("HDR",1),FS,3),CS),FS,CS,SUBCOMP,REP,ESCAPE) - S MSG("HDR","RECEIVING APPLICATION")=$$DESCAPE^HLOPRS1($P($P(MSG("HDR",1),FS,5),CS),FS,CS,SUBCOMP,REP,ESCAPE) - I 'MSG("BATCH") D - .S MSG("HDR","MESSAGE TYPE")=$P($P(MSG("HDR",2),FS,4),CS) - .S MSG("HDR","EVENT")=$P($P(MSG("HDR",2),FS,4),CS,2) - .S MSG("HDR","ACCEPT ACK TYPE")=$E($P(MSG("HDR",2),FS,10),1,2) - .S MSG("HDR","APP ACK TYPE")=$E($P(MSG("HDR",2),FS,11),1,2) - .S MSG("HDR","MESSAGE CONTROL ID")=MSG("ID") - E D - .S MSG("HDR","BATCH CONTROL ID")=MSG("ID") - .S MSG("HDR","ACCEPT ACK TYPE")=$E($P($P(MSG("HDR",2),FS,4),"ACCEPT ACK TYPE=",2),1,2) - .S MSG("HDR","APP ACK TYPE")=$E($P($P(MSG("HDR",2),FS,4),"APP ACK TYPE=",2),1,2) - S MSG("STATUS","SEQUENCE QUEUE")=$P($G(^HLB(IEN,5)),"^") - Q 1 - ; -GETMTYPE(MSGIEN) ;returns ~ OR "BATCH" - Q:'$G(MSGIEN) "UNKNOWN" - N FS,CS,HDR1,HDR2 - S HDR1=$G(^HLB(IEN,1)) - I $E(HDR1,1,3)="BHS" Q "BATCH" - S HDR2=$G(^HLB(IEN,2)) - S FS=$E(HDR1,4) - S CS=$E(HDR1,5) - Q $P($P(HDR2,FS,4),CS)_"~"_$P($P(HDR2,FS,4),CS,2) - ; -GETEVENT(MSGIEN) ; returns event if not a batch message - Q:'$G(MSGIEN) "" - N FS,CS,HDR1,HDR2 - S HDR1=$G(^HLB(MSGIEN,1)) - I $E(HDR1,1,3)="BHS" Q "" - S HDR2=$G(^HLB(MSGIEN,2)) - S FS=$E(HDR1,4) - S CS=$E(HDR1,5) - Q $P($P(HDR2,FS,4),CS,2) - ; -GETSAP(MSGIEN) ; - ; - ; - Q:'$G(MSGIEN) "UNKNOWN" - N FS,CS,HDR1,REP,ESCAPE,SUBCOMP - S HDR1=$G(^HLB(MSGIEN,1)) - S FS=$E(HDR1,4) - S CS=$E(HDR1,5) - S REP=$E(HDR1,6) - S ESCAPE=$E(HDR1,7) - S SUBCOMP=$E(HDR1,8) - Q $$DESCAPE^HLOPRS1($P($P(HDR1,FS,3),CS),FS,CS,SUBCOMP,REP,ESCAPE) +HLOCLNT2 ;ALB/CJM- Performs message updates for the client - 10/4/94 1pm ;03/09/2007 + ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,133,134**;Oct 13, 1995;Build 30 + ;Per VHA Directive 2004-038, this routine should not be modified. + ; +GETWORK(WORK) ; + ; + N OLD,DOLLARJ,SUCCESS,NOW + S SUCCESS=0 + S NOW=$$NOW^XLFDT + S (OLD,DOLLARJ)=$G(WORK("DOLLARJ")) + F S DOLLARJ=$O(^HLTMP("CLIENT UPDATES",DOLLARJ)) Q:DOLLARJ="" D Q:SUCCESS + .L +^HLTMP("CLIENT UPDATES",DOLLARJ):0 + .Q:'$T + .N TIME S TIME=$O(^HLTMP("CLIENT UPDATES",DOLLARJ,"")) + .I $$FMDIFF^XLFDT(NOW,TIME,2)<2 L -^HLTMP("CLIENT UPDATES",DOLLARJ) Q + .S SUCCESS=1 + ; + I OLD'="",'SUCCESS F S DOLLARJ=$O(^HLTMP("CLIENT UPDATES",DOLLARJ)) Q:DOLLARJ="" Q:DOLLARJ>OLD D Q:SUCCESS + .L +^HLTMP("CLIENT UPDATES",DOLLARJ):0 + .Q:'$T + .N TIME S TIME=$O(^HLTMP("CLIENT UPDATES",DOLLARJ,"")) + .I $$FMDIFF^XLFDT(NOW,TIME,2)<2 L -^HLTMP("CLIENT UPDATES",DOLLARJ) Q + .S SUCCESS=1 + S WORK("DOLLARJ")=DOLLARJ,WORK("NOW")=NOW + Q $S($L(WORK("DOLLARJ")):1,1:0) + ; +DOWORK(WORK) ; + ; + N DOLLARJ,TIME,IEN,PARMS,SYSTEM + S TIME="" + S DOLLARJ=WORK("DOLLARJ") + D SYSPARMS^HLOSITE(.SYSTEM) + F S TIME=$O(^HLTMP("CLIENT UPDATES",DOLLARJ,TIME)) Q:TIME="" Q:$$FMDIFF^XLFDT(WORK("NOW"),TIME,2)<2 D + .S IEN=0 + .F S IEN=$O(^HLTMP("CLIENT UPDATES",DOLLARJ,TIME,IEN)) Q:'IEN D + ..N NODE + ..S NODE=$G(^HLTMP("CLIENT UPDATES",DOLLARJ,TIME,IEN)) + ..S PARMS("LINK")=$P(NODE,"^") + ..S PARMS("QUEUE")=$P(NODE,"^",2) + ..S PARMS("STATUS")=$P(NODE,"^",3) + ..S PARMS("PURGE TYPE")=$P(NODE,"^",4) + ..S PARMS("ACK TO IEN")=+$P($P(NODE,"^",4),"-",2) + ..S PARMS("ACCEPT ACK")=$P(NODE,"^",5) + ..S PARMS("RECEIVING APP")=$P(NODE,"^",6) + ..S:PARMS("RECEIVING APP")="" PARMS("RECEIVING APP")="UNKNOWN RECEIVING APPLICATION" + ..S PARMS("MSA")=$G(^HLTMP("CLIENT UPDATES",DOLLARJ,TIME,IEN,"MSA")) + ..S PARMS("ACTION")=$G(^HLTMP("CLIENT UPDATES",DOLLARJ,TIME,IEN,"ACTION")) + ..D UPDATE(IEN,TIME,.PARMS) + ..K ^HLTMP("CLIENT UPDATES",DOLLARJ,TIME,IEN) + L -^HLTMP("CLIENT UPDATES",DOLLARJ) + Q + ; +UPDATE(MSGIEN,TIME,PARMS) ; + S:PARMS("STATUS")]"" $P(^HLB(MSGIEN,0),"^",20)=PARMS("STATUS") + S:PARMS("STATUS")="SE" ^HLB("ERRORS","SE",PARMS("RECEIVING APP"),TIME,MSGIEN)="" + S:PARMS("STATUS")="AE" ^HLB("ERRORS","AE",PARMS("RECEIVING APP"),TIME,MSGIEN_"^")="" + I PARMS("STATUS")["E" D COUNT^HLOESTAT("OUT",PARMS("RECEIVING APP"),$$GETSAP(MSGIEN),$$GETMTYPE(MSGIEN)) + S:PARMS("ACCEPT ACK") $P(^HLB(MSGIEN,0),"^",17)=PARMS("ACCEPT ACK") + S $P(^HLB(MSGIEN,0),"^",16)=TIME + S:PARMS("MSA")]"" ^HLB(MSGIEN,4)=TIME_"^"_PARMS("MSA") + I PARMS("PURGE TYPE"),PARMS("ACTION")="" D + .;don't set purge if going on the infiler - let infiler do it + .N PTIME + .S:(PARMS("PURGE TYPE")=2) PTIME=$$FMADD^XLFDT(TIME,SYSTEM("ERROR PURGE")) ;error purge is in days + .S:(PARMS("PURGE TYPE")'=2) PTIME=$$FMADD^XLFDT(TIME,,SYSTEM("NORMAL PURGE")) ;normal purge is in hours + .S $P(^HLB(MSGIEN,0),"^",9)=PTIME,^HLB("AD","OUT",PTIME,MSGIEN)="" + .I PARMS("ACK TO IEN"),$D(^HLB(PARMS("ACK TO IEN"),0)) S $P(^HLB(PARMS("ACK TO IEN"),0),"^",9)=PTIME,^HLB("AD","OUT",PTIME,PARMS("ACK TO IEN"))="" + D:PARMS("ACTION")]"" + .N PURGE + .S PURGE=$S(PARMS("PURGE TYPE"):1,1:0) + .S:PARMS("ACK TO IEN") PURGE("ACKTOIEN")=PARMS("ACK TO IEN") + .D INQUE^HLOQUE(PARMS("LINK"),PARMS("QUEUE"),MSGIEN,PARMS("ACTION"),.PURGE) + Q + ; +GETMSG(IEN,MSG) ; + ; + ;Description: given the message ien=MSGIEN (required), it returns the MSG array containing information about the message, defined below. + ;Input: + ; IEN - the ien of the message in file 778 + ;Output: + ; Function returns 1 on success, 0 on failure + ; MSG (pass by reference, required) These are the subscripts returned: + ; "ACCEPT ACK RESPONSE" - if the sending app requested notification of the accept ack, this is the routine to perform + ; "ACKTOIEN" - if this is an app ack to a message not in a batch, this is the ien of the original message + ; "BATCH" = 1 if this is a batch message, 0 if not + ; "CURRENT MESSAGE" - defined only for batch messages - a counterused during building and parsing messages to indicate the current message. It will be set to 0 initially. + ; "BODY" - ptr to file 778 which contains the body of the message. + ; "LINE COUNT" - a counter used during writing of the + ; messages to indicate the current line. For + ; batch messages where each message within the batch is stored + ; separately, this field indicates the position within the current + ; individual message + ; "HDR" at these lower subscripts: + ; 1 - components 1-6 + ; 2 - components 7-end + ; "ACCEPT ACK TYPE" = "AL" or "NE" + ; "APP ACK TYPE" = "AL" or "NE" + ; "MESSAGE CONTROL ID" - defined if NOT batch + ; "BATCH CONTROL ID" - defined if batch + ; + ; "ID" - message id from the header + ; "IEN" - ien, file 778 + ; + K MSG + Q:'$G(IEN) 0 + N NODE,FS,CS,REP,SUBCOMP,ESCAPE + S MSG("IEN")=IEN + S NODE=$G(^HLB(IEN,0)) + S MSG("BODY")=$P(NODE,"^",2) + S MSG("ID")=$P(NODE,"^") + Q:'MSG("BODY") 0 + S MSG("STATUS","ACCEPTED")=$P(NODE,"^",17) + S MSG("DT/TM")=$P(NODE,"^",16) + S MSG("STATUS","QUEUE")=$P(NODE,"^",6) + I MSG("STATUS","QUEUE")="" S MSG("STATUS","QUEUE")="DEFAULT" + S MSG("ACCEPT ACK RESPONSE")=$P(NODE,"^",12,13) + I MSG("ACCEPT ACK RESPONSE")="^" S MSG("ACCEPT ACK RESPONSE")="" + ; + S MSG("BATCH")=+$P($G(^HLA(MSG("BODY"),0)),"^",2) + I MSG("BATCH") D + .S MSG("BATCH","CURRENT MESSAGE")=0 + E D + .N ACKTO + .S ACKTO=$P(NODE,"^",3) + .I ACKTO]"" S ACKTO=$$ACKTOIEN^HLOMSG1(MSG("ID"),ACKTO) + .I ACKTO,+ACKTO=ACKTO S MSG("ACK TO IEN")=ACKTO + S MSG("LINE COUNT")=0 + S MSG("HDR",1)=$G(^HLB(IEN,1)) + S MSG("HDR",2)=$G(^HLB(IEN,2)) + S FS=$E(MSG("HDR",1),4) + S CS=$E(MSG("HDR",1),5) + S REP=$E(MSG("HDR",1),6) + S ESCAPE=$E(MSG("HDR",1),7) + S SUBCOMP=$E(MSG("HDR",1),8) + S MSG("HDR","FIELD SEPARATOR")=FS + S MSG("HDR","SENDING APPLICATION")=$$DESCAPE^HLOPRS1($P($P(MSG("HDR",1),FS,3),CS),FS,CS,SUBCOMP,REP,ESCAPE) + S MSG("HDR","RECEIVING APPLICATION")=$$DESCAPE^HLOPRS1($P($P(MSG("HDR",1),FS,5),CS),FS,CS,SUBCOMP,REP,ESCAPE) + I 'MSG("BATCH") D + .S MSG("HDR","MESSAGE TYPE")=$P($P(MSG("HDR",2),FS,4),CS) + .S MSG("HDR","EVENT")=$P($P(MSG("HDR",2),FS,4),CS,2) + .S MSG("HDR","ACCEPT ACK TYPE")=$E($P(MSG("HDR",2),FS,10),1,2) + .S MSG("HDR","APP ACK TYPE")=$E($P(MSG("HDR",2),FS,11),1,2) + .S MSG("HDR","MESSAGE CONTROL ID")=MSG("ID") + E D + .S MSG("HDR","BATCH CONTROL ID")=MSG("ID") + .S MSG("HDR","ACCEPT ACK TYPE")=$E($P($P(MSG("HDR",2),FS,4),"ACCEPT ACK TYPE=",2),1,2) + .S MSG("HDR","APP ACK TYPE")=$E($P($P(MSG("HDR",2),FS,4),"APP ACK TYPE=",2),1,2) + Q 1 + ; +GETMTYPE(MSGIEN) ;returns ~ OR "BATCH" + Q:'$G(MSGIEN) "UNKNOWN" + N FS,CS,HDR1,HDR2 + S HDR1=$G(^HLB(IEN,1)) + I $E(HDR1,1,3)="BHS" Q "BATCH" + S HDR2=$G(^HLB(IEN,2)) + S FS=$E(HDR1,4) + S CS=$E(HDR1,5) + Q $P($P(HDR2,FS,4),CS)_"~"_$P($P(HDR2,FS,4),CS,2) + ; +GETEVENT(MSGIEN) ; returns event if not a batch message + Q:'$G(MSGIEN) "" + N FS,CS,HDR1,HDR2 + S HDR1=$G(^HLB(MSGIEN,1)) + I $E(HDR1,1,3)="BHS" Q "" + S HDR2=$G(^HLB(MSGIEN,2)) + S FS=$E(HDR1,4) + S CS=$E(HDR1,5) + Q $P($P(HDR2,FS,4),CS,2) + ; +GETSAP(MSGIEN) ; + ; + ; + Q:'$G(MSGIEN) "UNKNOWN" + N FS,CS,HDR1,REP,ESCAPE,SUBCOMP + S HDR1=$G(^HLB(MSGIEN,1)) + S FS=$E(HDR1,4) + S CS=$E(HDR1,5) + S REP=$E(HDR1,6) + S ESCAPE=$E(HDR1,7) + S SUBCOMP=$E(HDR1,8) + Q $$DESCAPE^HLOPRS1($P($P(HDR1,FS,3),CS),FS,CS,SUBCOMP,REP,ESCAPE) diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT3.m b/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT3.m index 41363bd5..9b7a4762 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT3.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT3.m @@ -1,39 +1,39 @@ -HLOCLNT3 ;ALB/CJM- Updates messages missing application acks - 10/4/94 1pm ;07/10/2007 - ;;1.6;HEALTH LEVEL SEVEN;**126,130,134,137**;Oct 13, 1995;Build 21 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; -DOWORK(WORK) ; - ; - N CUTOFF,MSGIEN,QUIT,NOW,SYSTEM - S NOW=$$NOW^XLFDT - S QUIT=0 - D SYSPARMS^HLOSITE(.SYSTEM) - S PURGE=$$FMADD^XLFDT($$NOW^XLFDT,,24*SYSTEM("ERROR PURGE")) - ; - ;7 day wait for an application ack is more than reasonable - S CUTOFF=$$FMADD^XLFDT(NOW,-3) - ; - S MSGIEN=+$G(^HLTMP("LAST IEN CHECKED FOR MISSING APPLICATION ACK")) - F S MSGIEN=$O(^HLB(MSGIEN)) Q:'MSGIEN Q:MSGIEN>99999999999 D Q:QUIT - .N MSG,HDR - .Q:'$$GETMSG^HLOMSG(MSGIEN,.MSG) - .Q:'MSG("DT/TM") - .Q:'MSG("BODY") - .I MSG("DT/TM")>CUTOFF S:MSG("DT/TM CREATED")>CUTOFF QUIT=1,MSGIEN=MSGIEN-1 Q - .Q:MSG("STATUS")'="" - .Q:MSG("DIRECTION")'="OUT" - .Q:MSG("BATCH") - .Q:MSG("STATUS","APP ACK'D") - .;Q:MSG("STATUS","APP ACK RESPONSE")="" - .;message has been in a non-complete status for a longtime, pending an application ack - set status to error and schedule for purging - .S $P(^HLB(MSGIEN,0),"^",9)=PURGE - .S ^HLB("AD","OUT",PURGE,MSGIEN)="" - .S $P(^HLB(MSGIEN,0),"^",20)="ER" - .S $P(^HLB(MSGIEN,0),"^",21)="MISSING APPLICATION ACKNOWLEDGMENT" - .M HDR=MSG("HDR") - .Q:'$$PARSEHDR^HLOPRS(.HDR) - .S ^HLB("ERRORS",$S($L(HDR("RECEIVING APPLICATION")):HDR("RECEIVING APPLICATION"),1:"UNKNOWN"),NOW,MSGIEN)="" - .D COUNT^HLOESTAT("OUT",HDR("RECEIVING APPLICATION"),HDR("SENDING APPLICATION"),$S(MSG("BATCH"):"BATCH",1:$G(HDR("MESSAGE TYPE"))),$G(HDR("EVENT"))) - S:MSGIEN>99999999999 MSGIEN=0 - S ^HLTMP("LAST IEN CHECKED FOR MISSING APPLICATION ACK")=MSGIEN - Q +HLOCLNT3 ;ALB/CJM- Updates messages missing application acks - 10/4/94 1pm ;03/22/2007 + ;;1.6;HEALTH LEVEL SEVEN;**126,130,134**;Oct 13, 1995;Build 30 + ;Per VHA Directive 2004-038, this routine should not be modified. + ; +DOWORK(WORK) ; + ; + N CUTOFF,MSGIEN,QUIT,NOW,SYSTEM + S NOW=$$NOW^XLFDT + S QUIT=0 + D SYSPARMS^HLOSITE(.SYSTEM) + S PURGE=$$FMADD^XLFDT($$NOW^XLFDT,,24*SYSTEM("ERROR PURGE")) + ; + ;7 day wait for an application ack is more than reasonable + S CUTOFF=$$FMADD^XLFDT(NOW,-3) + ; + S MSGIEN=+$G(^HLTMP("LAST IEN CHECKED FOR MISSING APPLICATION ACK")) + F S MSGIEN=$O(^HLB(MSGIEN)) Q:'MSGIEN Q:MSGIEN>99999999999 D Q:QUIT + .N MSG,HDR + .Q:'$$GETMSG^HLOMSG(MSGIEN,.MSG) + .Q:'MSG("DT/TM") + .Q:'MSG("BODY") + .I MSG("DT/TM")>CUTOFF S:MSG("DT/TM CREATED")>CUTOFF QUIT=1,MSGIEN=MSGIEN-1 Q + .Q:MSG("STATUS")'="" + .Q:MSG("DIRECTION")'="OUT" + .Q:MSG("BATCH") + .Q:MSG("STATUS","APP ACK'D") + .;Q:MSG("STATUS","APP ACK RESPONSE")="" + .;message has been in a non-complete status for a longtime, pending an application ack - set status to error and schedule for purging + .S $P(^HLB(MSGIEN,0),"^",9)=PURGE + .S ^HLB("AD","OUT",PURGE,MSGIEN)="" + .S $P(^HLB(MSGIEN,0),"^",20)="AE" + .S $P(^HLB(MSGIEN,0),"^",21)="MISSING APPLICATION ACKNOWLEDGMENT" + .M HDR=MSG("HDR") + .Q:'$$PARSEHDR^HLOPRS(.HDR) + .S ^HLB("ERRORS","AE",$S($L(HDR("RECEIVING APPLICATION")):HDR("RECEIVING APPLICATION"),1:"UNKNOWN"),NOW,MSGIEN)="" + .D COUNT^HLOESTAT("OUT",HDR("RECEIVING APPLICATION"),HDR("SENDING APPLICATION"),$S(MSG("BATCH"):"BATCH",1:$G(HDR("MESSAGE TYPE"))),$G(HDR("EVENT"))) + S:MSGIEN>99999999999 MSGIEN=0 + S ^HLTMP("LAST IEN CHECKED FOR MISSING APPLICATION ACK")=MSGIEN + Q diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLOCNRT.m b/r/HEALTH_LEVEL_SEVEN-HL/HLOCNRT.m index 05af5958..c1cc60c8 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLOCNRT.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLOCNRT.m @@ -1,82 +1,80 @@ -HLOCNRT ;DAOU/ALA-Generate HL7 Optimized Message ;07/24/2007 - ;;1.6;HEALTH LEVEL SEVEN;**126,132,134,137**;Oct 13, 1995;Build 21 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; - ;**Program Description** - ; This program takes a current HL7 1.6 message and converts - ; it to use the new HL Optimized code if it follows the standard - ; 1.6 methodology of protocols. - ; - ; **If the VistA HL7 Protocol does not exist, calls to HL Optimized - ; will have to be coded separately and this program cannot be used** - Q - ; -EN(HLOPRTCL,ARYTYP,HLP,HLL,RESULT) ;Entry Point - ; Input Parameters - ; HLOPRTCL = Protocol IEN or Protocol Name - ; ARYTYP = The array where HL7 message resides - ; HLP = Additional HL7 message parameters (optional, pass by reference) - ; These optional subscripts to HLP are supported for input: - ; "APP ACK RESPONSE" = to call when the app ack is received - ; "CONTPTR" - ; "SECURITY" - ; "SEQUENCE QUEUE" - queue used to maintain the order of the messages via application acks. If used, the application MUST specify that both an accept ack and application ack be returned. - ; - ; HLL (optional, pass by reference) Additional message recipients being dynamically added - ; - ; Output - ; RESULT (pass-by-reference)=^^^<0 if sucess, error code if failure>^ - ; If the message was sent to more than 1 destination, - ; the addtional mssage ids returned as RESULT(1), RESULT(2), etc. - ; ZTSTOP = Stop processing flag (used by HDR) - ; Function returns 1 on success, else returns an error message - ; - NEW HLORESL,HLMSTATE,APPARMS,WHOTO,ERROR,WHO - S ZTSTOP=0,HLORESL=1,RESULT="" - ; - ; Get IEN of protocol if name is passed - I '$L(HLOPRTCL) S HLORESL="^99^HL7 1.6 Protocol not found",RESULT="^^"_HLORESL,ZTSTOP=1 Q HLORESL - I ('HLOPRTCL)!(HLOPRTCL'=+HLOPRTCL) S HLOPRTCL=+$O(^ORD(101,"B",HLOPRTCL,0)) - I 'HLOPRTCL S HLORESL="^99^HL7 1.6 Protocol not found",RESULT="^^"_HLORESL,ZTSTOP=1 Q HLORESL - I '$D(^ORD(101,HLOPRTCL)) S HLORESL="^99^HL7 1.6 Protocol not found",RESULT="^^"_HLORESL,ZTSTOP=1 Q HLORESL - ; - ; If the VistA HL7 Protocol exists, call the Conversion Utility - ; to set up the APPARMS, WHOTO arrays from protocol logical link, - ; and the optional HLL and HLP arrays - D APAR^HLOCVU(HLOPRTCL,.APPARMS,.WHO,.WHOTO,.HLP,.HLL) - ; - ; If special HLP parameters are defined, convert them - I $D(HLP) D - . I $G(HLP("SECURITY"))'="" S APPARMS("SECURITY")=HLP("SECURITY") - . I $G(HLP("CONTPTR"))'="" S APPARMS("CONTINUATION POINTER")=HLP("CONTPTR") - . I $G(HLP("QUEUE"))'="" S APPARMS("QUEUE")=HLP("QUEUE") - . I $G(HLP("SEQUENCE QUEUE"))'="" S APPARMS("SEQUENCE QUEUE")=HLP("SEQUENCE QUEUE") - . I $G(HLP("APP ACK RESPONSE"))'="" S APPARMS("APP ACK RESPONSE")=HLP("APP ACK RESPONSE") - ; - ; Create HL Optimized message - I '$$NEWMSG^HLOAPI(.APPARMS,.HLMSTATE,.ERROR) S HLORESL="^99^"_ERROR,ZTSTOP=1,RESULT="^^"_HLORESL Q HLORESL - I $E(ARYTYP,1)="G" S HLOMESG="^TMP(""HLS"",$J)" - I $E(ARYTYP,1)="L" S HLOMESG="HLA(""HLS"")" - ; - ; Move the existing message from array into HL Optimized - D MOVEMSG^HLOAPI(.HLMSTATE,HLOMESG) - ; - ; Send message via HL Optimized - I $D(WHOTO) D - .N COUNT - .I '$$SENDMANY^HLOAPI1(.HLMSTATE,.APPARMS,.WHOTO) D - ..S HLORESL="^99^Unable to send message",ZTSTOP=1 - .I $G(WHOTO(1,"IEN")) D - ..S RESULT=WHO(1)_"^"_$P($G(^HLB(WHOTO(1,"IEN"),0)),"^")_"^"_$S($G(WHOTO(1,"QUEUED")):0,1:1)_"^"_$G(WHOTO(1,"ERROR")) - .E D - ..S RESULT=WH0(1)_"^^1^"_$G(WHOTO(1,"ERROR")) - ..S HLORESL="^99^"_$G(WHOTO(1,"ERROR")),ZTSTOP=1 - .S COUNT=1 - .F S COUNT=$O(WHOTO(COUNT)) Q:'COUNT D - ..I $G(WHOTO(COUNT,"IEN")) D - ...S RESULT(COUNT-1)=WHO(COUNT)_"^"_$P($G(^HLB(WHOTO(COUNT,"IEN"),0)),"^")_"^"_$S($G(WHOTO(COUNT,"QUEUED")):0,1:1)_"^"_$G(WHOTO(COUNT,"ERROR")) - ..E D - ...S RESULT(COUNT-1)=WH0(COUNT)_"^^1^"_$G(WHOTO(COUNT,"ERROR")) - ; - E S HLORESL="^99^Unable to send message",ZTSTOP=1,RESULT="^^"_HLORESL - Q HLORESL +HLOCNRT ;DAOU/ALA-Generate HL7 Optimized Message ;03/15/2007 + ;;1.6;HEALTH LEVEL SEVEN;**126,132,134**;Oct 13, 1995;Build 30 + ;Per VHA Directive 2004-038, this routine should not be modified. + ; + ;**Program Description** + ; This program takes a current HL7 1.6 message and converts + ; it to use the new HL Optimized code if it follows the standard + ; 1.6 methodology of protocols. + ; + ; **If the VistA HL7 Protocol does not exist, calls to HL Optimized + ; will have to be coded separately and this program cannot be used** + Q + ; +EN(HLOPRTCL,ARYTYP,HLP,HLL,RESULT) ;Entry Point + ; Input Parameters + ; HLOPRTCL = Protocol IEN or Protocol Name + ; ARYTYP = The array where HL7 message resides + ; HLP = Additional HL7 message parameters (optional, pass by reference) + ; These optional subscripts to HLL are supported for input: + ; "SECURITY" + ; "CONTPTR" + ; "APP ACK RESPONSE" = to call when the app ack is received + ; + ; HLL (optional, pass by reference) Additional message recipients being dynamically added + ; + ; Output + ; RESULT (pass-by-reference)=^^^<0 if sucess, error code if failure>^ + ; If the message was sent to more than 1 destination, + ; the addtional mssage ids returned as RESULT(1), RESULT(2), etc. + ; ZTSTOP = Stop processing flag (used by HDR) + ; Function returns 1 on success, else returns an error message + ; + NEW HLORESL,HLMSTATE,APPARMS,WHOTO,ERROR,WHO + S ZTSTOP=0,HLORESL=1,RESULT="" + ; + ; Get IEN of protocol if name is passed + I '$L(HLOPRTCL) S HLORESL="^99^HL7 1.6 Protocol not found",RESULT="^^"_HLORESL,ZTSTOP=1 Q HLORESL + I ('HLOPRTCL)!(HLOPRTCL'=+HLOPRTCL) S HLOPRTCL=+$O(^ORD(101,"B",HLOPRTCL,0)) + I 'HLOPRTCL S HLORESL="^99^HL7 1.6 Protocol not found",RESULT="^^"_HLORESL,ZTSTOP=1 Q HLORESL + I '$D(^ORD(101,HLOPRTCL)) S HLORESL="^99^HL7 1.6 Protocol not found",RESULT="^^"_HLORESL,ZTSTOP=1 Q HLORESL + ; + ; If the VistA HL7 Protocol exists, call the Conversion Utility + ; to set up the APPARMS, WHOTO arrays from protocol logical link, + ; and the optional HLL and HLP arrays + D APAR^HLOCVU(HLOPRTCL,.APPARMS,.WHO,.WHOTO,.HLP,.HLL) + ; + ; If special HLP parameters are defined, convert them + I $D(HLP) D + . I $G(HLP("SECURITY"))'="" S APPARMS("SECURITY")=HLP("SECURITY") + . I $G(HLP("CONTPTR"))'="" S APPARMS("CONTINUATION POINTER")=HLP("CONTPTR") + . I $G(HLP("QUEUE"))'="" S APPARMS("QUEUE")=HLP("QUEUE") + . I $G(HLP("APP ACK RESPONSE"))'="" S APPARMS("APP ACK RESPONSE")=HLP("APP ACK RESPONSE") + ; + ; Create HL Optimized message + I '$$NEWMSG^HLOAPI(.APPARMS,.HLMSTATE,.ERROR) S HLORESL="^99^"_ERROR,ZTSTOP=1,RESULT="^^"_HLORESL Q HLORESL + I $E(ARYTYP,1)="G" S HLOMESG="^TMP(""HLS"",$J)" + I $E(ARYTYP,1)="L" S HLOMESG="HLA(""HLS"")" + ; + ; Move the existing message from array into HL Optimized + D MOVEMSG^HLOAPI(.HLMSTATE,HLOMESG) + ; + ; Send message via HL Optimized + I $D(WHOTO) D + .N COUNT + .I '$$SENDMANY^HLOAPI1(.HLMSTATE,.APPARMS,.WHOTO) D + ..S HLORESL="^99^Unable to send message",ZTSTOP=1 + .I $G(WHOTO(1,"IEN")) D + ..S RESULT=WHO(1)_"^"_$P($G(^HLB(WHOTO(1,"IEN"),0)),"^")_"^"_$S($G(WHOTO(1,"QUEUED")):0,1:1)_"^"_$G(WHOTO(1,"ERROR")) + .E D + ..S RESULT=WH0(1)_"^^1^"_$G(WHOTO(1,"ERROR")) + ..S HLORESL="^99^"_$G(WHOTO(1,"ERROR")),ZTSTOP=1 + .S COUNT=1 + .F S COUNT=$O(WHOTO(COUNT)) Q:'COUNT D + ..I $G(WHOTO(COUNT,"IEN")) D + ...S RESULT(COUNT-1)=WHO(COUNT)_"^"_$P($G(^HLB(WHOTO(COUNT,"IEN"),0)),"^")_"^"_$S($G(WHOTO(COUNT,"QUEUED")):0,1:1)_"^"_$G(WHOTO(COUNT,"ERROR")) + ..E D + ...S RESULT(COUNT-1)=WH0(COUNT)_"^^1^"_$G(WHOTO(COUNT,"ERROR")) + ; + E S HLORESL="^99^Unable to send message",ZTSTOP=1,RESULT="^^"_HLORESL + Q HLORESL diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLOF778.m b/r/HEALTH_LEVEL_SEVEN-HL/HLOF778.m index b94bc690..10dc520f 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLOF778.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLOF778.m @@ -1,151 +1,151 @@ -HLOF778 ;ALB/CJM-HL7 - Saving messages to file 778 ;07/10/2007 - ;;1.6;HEALTH LEVEL SEVEN;**126,134,137**;Oct 13, 1995;Build 21 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; - ; -SAVEMSG(HLMSTATE) ; - ;If a record has not yet been created in file 778, then it will be created. Will file any segments into 777 not yet stored. For batch messages, will store the MSH segments in 778 as the individual messages are stored in 777. - ;Input: - ; HLMSTATE (pass by reference) - contains information about the message - ; These subscripts must be defined: - ; ("BATCH")=1 if batch, 0 otherwise - ; ("BATCH","BTS")=BTS segment if end of batch reached - ; ("BODY")=ien file 777 if stored - ; ("DIRECTION")=<"IN" or "OUT"> - ; ("IEN")=ien,file 778 if stored - ; ("UNSTORED LINES") - count of lines to be stored. The lines are at the a lower subscript level ,,= - ; ("UNSTORED MSH") For batch messages, set to 1 if there are MSH in cache. Cached MSH at ("UNSTORED MSH",,<1 & 2>) - ; - ;Output: - ; Function - returns the ien of the msg (file 778) - ; HLMSTATE - ; ("BODY") - set to ien, file 777 if newly created - ; ("IEN") - set to ien, file 778 if newly created - ; ("UNSTORED LINES")-set to 0 as this function will store them - ; ("UNSTORED MSH")- set to 0 as this function will store it - ; - ; - I '$D(HLMSTATE("DT/TM")) S HLMSTATE("DT/TM")=$S(HLMSTATE("DIRECTION")="IN":$$NOW^XLFDT,1:"") - ; - ;insure that 777 entry created & all segments stored - I ('HLMSTATE("BODY"))!($G(HLMSTATE("UNSTORED LINES")))!($L($G(HLMSTATE("BATCH","BTS")))),'$$SAVEMSG^HLOF777(.HLMSTATE) Q 0 - ; - ;insure 778 entry created - I 'HLMSTATE("IEN") Q:'$$NEW^HLOF778A(.HLMSTATE) 0 - ; - ;for batch messages, store MSH segments in 778 - I HLMSTATE("BATCH") D - .N IEN S IEN=HLMSTATE("IEN") - .; - .;incoming messages cache the MSH segments in memory - .I HLMSTATE("DIRECTION")="IN",HLMSTATE("UNSTORED MSH") D - ..N ORDER S ORDER=0 - ..F S ORDER=$O(HLMSTATE("UNSTORED MSH",ORDER)) Q:'ORDER D - ...N FS,MSGID - ...S FS=$E(HLMSTATE("UNSTORED MSH",ORDER,1),4) - ...S MSGID=$P(HLMSTATE("UNSTORED MSH",ORDER,2),FS,5) - ...S ^HLB(IEN,3,ORDER,0)=ORDER_"^"_MSGID_"^"_$G(HLMSTATE("BATCH","ACK TO",ORDER)) - ...S ^HLB(IEN,3,ORDER,1)=HLMSTATE("UNSTORED MSH",ORDER,1) - ...S ^HLB(IEN,3,ORDER,2)=HLMSTATE("UNSTORED MSH",ORDER,2) - ...S ^HLB(IEN,3,"B",ORDER,ORDER)="" - ...I MSGID]"" S ^HLB("AE",MSGID,IEN_"^"_ORDER)="" ;whole file index for individual message id - ..K HLMSTATE("UNSTORED MSH") S HLMSTATE("UNSTORED MSH")=0 - .; - .; - .I HLMSTATE("DIRECTION")="OUT" D - ..;must build the MSH segments! - ..N HDR,FS,MSG,CS - ..S FS=HLMSTATE("HDR","FIELD SEPARATOR") - ..S CS=$E(HLMSTATE("HDR","ENCODING CHARACTERS"),1) - ..S HLMSTATE("HDR","MESSAGE TYPE")=" " - ..S HLMSTATE("HDR","EVENT")=" " - ..D BUILDHDR^HLOPBLD1(.HLMSTATE,"MSH",.HDR) - ..S HLMSTATE("BATCH","CURRENT MESSAGE")=$O(^HLB(HLMSTATE("IEN"),3,"B",";"),-1) - ..F Q:'$$NEXTMSG(.HLMSTATE,.MSG) D - ...N MSGID,CUR - ...S CUR=HLMSTATE("BATCH","CURRENT MESSAGE") - ...S MSGID=HLMSTATE("HDR","BATCH CONTROL ID")_"-"_CUR - ...S $P(HDR(2),FS,4)=MSG("MESSAGE TYPE")_CS_MSG("EVENT") - ...S $P(HDR(2),FS,5)=MSGID - ...S ^HLB(IEN,3,CUR,0)=CUR_"^"_MSGID_"^"_$G(HLMSTATE("BATCH","ACK TO",CUR)) - ...S ^HLB(IEN,3,CUR,1)=HDR(1) - ...S ^HLB(IEN,3,CUR,2)=HDR(2) - ...S ^HLB(IEN,3,"B",CUR,CUR)="" - ...S ^HLB("AE",MSGID,IEN_"^"_CUR)="" ;whole file index for individual message id - ..; - .;if the messages are application acks, then update the original message - .N SUBIEN S SUBIEN=0 - .F S SUBIEN=$O(HLMSTATE("BATCH","ACK TO",SUBIEN)) Q:'SUBIEN I $G(HLMSTATE("BATCH","ACK TO",SUBIEN,"IEN"))]"" D - ..N ACKTO - ..M ACKTO=HLMSTATE("BATCH","ACK TO",SUBIEN) - ..; - ..;for outgoing msgs, we just created the msgid, for incoming msgs we already had it - ..S:HLMSTATE("DIRECTION")="OUT" ACKTO("ACK BY")=HLMSTATE("HDR","BATCH CONTROL ID")_"-"_SUBIEN - ..; - ..D ACKTO(.HLMSTATE,.ACKTO) - .K HLMSTATE("BATCH","ACK TO") - ; - ;if the msg is an app ack, update the original if not done already - I $G(HLMSTATE("ACK TO","IEN"))]"",'$G(HLMSTATE("ACK TO","DONE")) D - .N ACKTO - .M ACKTO=HLMSTATE("ACK TO") - .S ACKTO("ACK BY")=$S(HLMSTATE("BATCH"):HLMSTATE("HDR","BATCH CONTROL ID"),1:HLMSTATE("HDR","MESSAGE CONTROL ID")) - .D ACKTO(.HLMSTATE,.ACKTO) - .S HLMSTATE("ACK TO","DONE")=1 ;so the update isn't done again - ; - Q HLMSTATE("IEN") - ; -NEXTMSG(HLMSTATE,MSG) ; - ;Traverses file 777 to return the next message in the batch - as - ;indicated by HLMSTATE("BATCH","CURRENT MESSAGE") Set to 0 to start, - ;returns 0 when there are no more messages - ; - ;Input: HLMSTATE (pass by reference,required) - ;Output: - ; HLMSTATE - ; ("BATCH","CURRENT MESSAGE") - ; MSG -pass by reference: - ; ("EVENT") - ; ("MESSAGE TYPE") - ; - ; - N SUBIEN,NODE - K MSG - Q:'$G(HLMSTATE("BODY")) 0 - S SUBIEN=$O(^HLA(HLMSTATE("BODY"),2,HLMSTATE("BATCH","CURRENT MESSAGE"))) - Q:'SUBIEN 0 - S NODE=$G(^HLA(HLMSTATE("BODY"),2,SUBIEN,0)) - S MSG("MESSAGE TYPE")=$P(NODE,"^",2) - S MSG("EVENT")=$P(NODE,"^",3) - S HLMSTATE("BATCH","CURRENT MESSAGE")=SUBIEN - Q SUBIEN - ; -ACKTO(HLMSTATE,ACKTO) ;if this is an application ack, update the original message - but do not overlay if already valued - ;ACKTO = (msgid of msg being ack'd) - ; uses these subscripts ("IEN"=ien^subien),("ACK BY"=msgid of acking msg),("STATUS"=status for the initial msg determined by the ack) - ; - N STATUS,IEN,SUBIEN,NODE,SKIP - S SKIP=0 - S STATUS=$G(ACKTO("STATUS")) - S IEN=+ACKTO("IEN"),SUBIEN=$P(ACKTO("IEN"),"^",2) - S NODE=$G(^HLB(IEN,0)) - I 'SUBIEN D - .;ack is to a message NOT in a batch - .I $P(NODE,"^",7)'="",$P(NODE,"^",7)'=ACKTO("ACK BY") S SKIP=1 Q - .I STATUS="" S STATUS="SU" - .S $P(NODE,"^",7)=ACKTO("ACK BY") - .S $P(NODE,"^",20)=STATUS - .S $P(NODE,"^",21)=$G(ACKTO("ERROR TEXT")) - .S ^HLB(IEN,0)=NODE - E D - .;ack is to a message that IS in a batch - .S $P(^HLB(IEN,3,SUBIEN,0),"^",4)=$G(ACKTO("ACK BY")) - .S $P(^HLB(IEN,3,SUBIEN,0),"^",5)=STATUS - I (STATUS="ER"),'SKIP D - .N APP - .S APP=HLMSTATE("HDR","RECEIVING APPLICATION") - .I APP="" S APP="UNKNOWN" - .S ^HLB("ERRORS",APP,$$NOW^XLFDT,ACKTO("IEN"))="" - .;don't count the error - the app ack was already counted as an error. - .D COUNT^HLOESTAT("IN",$G(HLMSTATE("HDR","RECEIVING APPLICATION")),$G(HLMSTATE("HDR","SENDING APPLICATION")),$S(HLMSTATE("BATCH"):"BATCH",1:$G(HLMSTATE("HDR","MESSAGE TYPE"))),$G(HLMSTATE("HDR","EVENT"))) - Q +HLOF778 ;ALB/CJM-HL7 - Saving messages to file 778 ;03/15/2007 + ;;1.6;HEALTH LEVEL SEVEN;**126,134**;Oct 13, 1995;Build 30 + ;Per VHA Directive 2004-038, this routine should not be modified. + ; + ; +SAVEMSG(HLMSTATE) ; + ;If a record has not yet been created in file 778, then it will be created. Will file any segments into 777 not yet stored. For batch messages, will store the MSH segments in 778 as the individual messages are stored in 777. + ;Input: + ; HLMSTATE (pass by reference) - contains information about the message + ; These subscripts must be defined: + ; ("BATCH")=1 if batch, 0 otherwise + ; ("BATCH","BTS")=BTS segment if end of batch reached + ; ("BODY")=ien file 777 if stored + ; ("DIRECTION")=<"IN" or "OUT"> + ; ("IEN")=ien,file 778 if stored + ; ("UNSTORED LINES") - count of lines to be stored. The lines are at the a lower subscript level ,,= + ; ("UNSTORED MSH") For batch messages, set to 1 if there are MSH in cache. Cached MSH at ("UNSTORED MSH",,<1 & 2>) + ; + ;Output: + ; Function - returns the ien of the msg (file 778) + ; HLMSTATE + ; ("BODY") - set to ien, file 777 if newly created + ; ("IEN") - set to ien, file 778 if newly created + ; ("UNSTORED LINES")-set to 0 as this function will store them + ; ("UNSTORED MSH")- set to 0 as this function will store it + ; + ; + I '$D(HLMSTATE("DT/TM")) S HLMSTATE("DT/TM")=$S(HLMSTATE("DIRECTION")="IN":$$NOW^XLFDT,1:"") + ; + ;insure that 777 entry created & all segments stored + I ('HLMSTATE("BODY"))!($G(HLMSTATE("UNSTORED LINES")))!($L($G(HLMSTATE("BATCH","BTS")))),'$$SAVEMSG^HLOF777(.HLMSTATE) Q 0 + ; + ;insure 778 entry created + I 'HLMSTATE("IEN") Q:'$$NEW^HLOF778A(.HLMSTATE) 0 + ; + ;for batch messages, store MSH segments in 778 + I HLMSTATE("BATCH") D + .N IEN S IEN=HLMSTATE("IEN") + .; + .;incoming messages cache the MSH segments in memory + .I HLMSTATE("DIRECTION")="IN",HLMSTATE("UNSTORED MSH") D + ..N ORDER S ORDER=0 + ..F S ORDER=$O(HLMSTATE("UNSTORED MSH",ORDER)) Q:'ORDER D + ...N FS,MSGID + ...S FS=$E(HLMSTATE("UNSTORED MSH",ORDER,1),4) + ...S MSGID=$P(HLMSTATE("UNSTORED MSH",ORDER,2),FS,5) + ...S ^HLB(IEN,3,ORDER,0)=ORDER_"^"_MSGID_"^"_$G(HLMSTATE("BATCH","ACK TO",ORDER)) + ...S ^HLB(IEN,3,ORDER,1)=HLMSTATE("UNSTORED MSH",ORDER,1) + ...S ^HLB(IEN,3,ORDER,2)=HLMSTATE("UNSTORED MSH",ORDER,2) + ...S ^HLB(IEN,3,"B",ORDER,ORDER)="" + ...I MSGID]"" S ^HLB("AE",MSGID,IEN_"^"_ORDER)="" ;whole file index for individual message id + ..K HLMSTATE("UNSTORED MSH") S HLMSTATE("UNSTORED MSH")=0 + .; + .; + .I HLMSTATE("DIRECTION")="OUT" D + ..;must build the MSH segments! + ..N HDR,FS,MSG,CS + ..S FS=HLMSTATE("HDR","FIELD SEPARATOR") + ..S CS=$E(HLMSTATE("HDR","ENCODING CHARACTERS"),1) + ..S HLMSTATE("HDR","MESSAGE TYPE")=" " + ..S HLMSTATE("HDR","EVENT")=" " + ..D BUILDHDR^HLOPBLD1(.HLMSTATE,"MSH",.HDR) + ..S HLMSTATE("BATCH","CURRENT MESSAGE")=$O(^HLB(HLMSTATE("IEN"),3,"B",";"),-1) + ..F Q:'$$NEXTMSG(.HLMSTATE,.MSG) D + ...N MSGID,CUR + ...S CUR=HLMSTATE("BATCH","CURRENT MESSAGE") + ...S MSGID=HLMSTATE("HDR","BATCH CONTROL ID")_"-"_CUR + ...S $P(HDR(2),FS,4)=MSG("MESSAGE TYPE")_CS_MSG("EVENT") + ...S $P(HDR(2),FS,5)=MSGID + ...S ^HLB(IEN,3,CUR,0)=CUR_"^"_MSGID_"^"_$G(HLMSTATE("BATCH","ACK TO",CUR)) + ...S ^HLB(IEN,3,CUR,1)=HDR(1) + ...S ^HLB(IEN,3,CUR,2)=HDR(2) + ...S ^HLB(IEN,3,"B",CUR,CUR)="" + ...S ^HLB("AE",MSGID,IEN_"^"_CUR)="" ;whole file index for individual message id + ..; + .;if the messages are application acks, then update the original message + .N SUBIEN S SUBIEN=0 + .F S SUBIEN=$O(HLMSTATE("BATCH","ACK TO",SUBIEN)) Q:'SUBIEN I $G(HLMSTATE("BATCH","ACK TO",SUBIEN,"IEN"))]"" D + ..N ACKTO + ..M ACKTO=HLMSTATE("BATCH","ACK TO",SUBIEN) + ..; + ..;for outgoing msgs, we just created the msgid, for incoming msgs we already had it + ..S:HLMSTATE("DIRECTION")="OUT" ACKTO("ACK BY")=HLMSTATE("HDR","BATCH CONTROL ID")_"-"_SUBIEN + ..; + ..D ACKTO(.HLMSTATE,.ACKTO) + .K HLMSTATE("BATCH","ACK TO") + ; + ;if the msg is an app ack, update the original if not done already + I $G(HLMSTATE("ACK TO","IEN"))]"",'$G(HLMSTATE("ACK TO","DONE")) D + .N ACKTO + .M ACKTO=HLMSTATE("ACK TO") + .S ACKTO("ACK BY")=$S(HLMSTATE("BATCH"):HLMSTATE("HDR","BATCH CONTROL ID"),1:HLMSTATE("HDR","MESSAGE CONTROL ID")) + .D ACKTO(.HLMSTATE,.ACKTO) + .S HLMSTATE("ACK TO","DONE")=1 ;so the update isn't done again + ; + Q HLMSTATE("IEN") + ; +NEXTMSG(HLMSTATE,MSG) ; + ;Traverses file 777 to return the next message in the batch - as + ;indicated by HLMSTATE("BATCH","CURRENT MESSAGE") Set to 0 to start, + ;returns 0 when there are no more messages + ; + ;Input: HLMSTATE (pass by reference,required) + ;Output: + ; HLMSTATE + ; ("BATCH","CURRENT MESSAGE") + ; MSG -pass by reference: + ; ("EVENT") + ; ("MESSAGE TYPE") + ; + ; + N SUBIEN,NODE + K MSG + Q:'$G(HLMSTATE("BODY")) 0 + S SUBIEN=$O(^HLA(HLMSTATE("BODY"),2,HLMSTATE("BATCH","CURRENT MESSAGE"))) + Q:'SUBIEN 0 + S NODE=$G(^HLA(HLMSTATE("BODY"),2,SUBIEN,0)) + S MSG("MESSAGE TYPE")=$P(NODE,"^",2) + S MSG("EVENT")=$P(NODE,"^",3) + S HLMSTATE("BATCH","CURRENT MESSAGE")=SUBIEN + Q SUBIEN + ; +ACKTO(HLMSTATE,ACKTO) ;if this is an application ack, update the original message - but do not overlay if already valued + ;ACKTO = (msgid of msg being ack'd) + ; uses these subscripts ("IEN"=ien^subien),("ACK BY"=msgid of acking msg),("STATUS"=status for the initial msg determined by the ack) + ; + N STATUS,IEN,SUBIEN,NODE,SKIP + S SKIP=0 + S STATUS=$G(ACKTO("STATUS")) + S IEN=+ACKTO("IEN"),SUBIEN=$P(ACKTO("IEN"),"^",2) + S NODE=$G(^HLB(IEN,0)) + I 'SUBIEN D + .;ack is to a message NOT in a batch + .I $P(NODE,"^",7)'="",$P(NODE,"^",7)'=ACKTO("ACK BY") S SKIP=1 Q + .I STATUS="" S STATUS="SU" + .S $P(NODE,"^",7)=ACKTO("ACK BY") + .S $P(NODE,"^",20)=STATUS + .S $P(NODE,"^",21)=$G(ACKTO("ERROR TEXT")) + .S ^HLB(IEN,0)=NODE + E D + .;ack is to a message that IS in a batch + .S $P(^HLB(IEN,3,SUBIEN,0),"^",4)=$G(ACKTO("ACK BY")) + .S $P(^HLB(IEN,3,SUBIEN,0),"^",5)=STATUS + I (STATUS="AE"),'SKIP D + .N APP + .S APP=HLMSTATE("HDR","SENDING APPLICATION") + .I APP="" S APP="UNKNOWN" + .S ^HLB("ERRORS","AE",APP,$$NOW^XLFDT,ACKTO("IEN"))="" + .;don't count the error - the app ack was already counted as an error. + .D COUNT^HLOESTAT("IN",$G(HLMSTATE("HDR","RECEIVING APPLICATION")),$G(HLMSTATE("HDR","SENDING APPLICATION")),$S(HLMSTATE("BATCH"):"BATCH",1:$G(HLMSTATE("HDR","MESSAGE TYPE"))),$G(HLMSTATE("HDR","EVENT"))) + Q diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLOF778A.m b/r/HEALTH_LEVEL_SEVEN-HL/HLOF778A.m index 1d5bc356..f53c7c3a 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLOF778A.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLOF778A.m @@ -1,175 +1,172 @@ -HLOF778A ;ALB/CJM-HL7 - Saving messages to file 778 (continued) ;07/10/2007 - ;;1.6;HEALTH LEVEL SEVEN;**126,134,137**;Oct 13, 1995;Build 21 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; - ; -NEW(HLMSTATE) ; - ;This function creates a new entry in file 778. - ;Input: - ; HLMSTATE (required, pass by reference) These subscripts are expected: - ; - ;Output - the function returns the ien of the newly created record - ; - N IEN,NODE,ID,STAT - S STAT="HLMSTATE(""STATUS"")" - S IEN=$$NEWIEN(HLMSTATE("DIRECTION"),$$TCP) - Q:'IEN 0 - S HLMSTATE("IEN")=IEN - ; - D ;build the message header - .N HDR - .;for incoming messages the header segment should already exist - .;for outgoing messages must build the header segment - .I HLMSTATE("DIRECTION")="OUT" D Q - ..I HLMSTATE("BATCH"),$G(HLMSTATE("ACK TO"))]"" S HLMSTATE("HDR","REFERENCE BATCH CONTROL ID")=HLMSTATE("ACK TO") - ..D BUILDHDR^HLOPBLD1(.HLMSTATE,$S(HLMSTATE("BATCH"):"BHS",1:"MSH"),.HDR) - ..S HLMSTATE("HDR",1)=HDR(1),HLMSTATE("HDR",2)=HDR(2) - ; - K ^HLB(IEN) - S ID=$S(HLMSTATE("BATCH"):HLMSTATE("HDR","BATCH CONTROL ID"),1:HLMSTATE("HDR","MESSAGE CONTROL ID")) - S NODE=ID_"^"_HLMSTATE("BODY")_"^"_$G(HLMSTATE("ACK TO"))_"^"_$S(HLMSTATE("DIRECTION")="IN":"I",1:"O")_"^" - S $P(NODE,"^",5)=$G(@STAT@("LINK NAME")) - S $P(NODE,"^",6)=$G(@STAT@("QUEUE")) - S $P(NODE,"^",8)=$G(@STAT@("PORT")) - S $P(NODE,"^",20)=$G(@STAT) - S $P(NODE,"^",21)=$G(@STAT@("ERROR TEXT")) - S $P(NODE,"^",16)=HLMSTATE("DT/TM") - ; - I HLMSTATE("DIRECTION")="OUT" D - .S $P(NODE,"^",10)=$P($G(@STAT@("APP ACK RESPONSE")),"^") - .S $P(NODE,"^",11)=$P($G(@STAT@("APP ACK RESPONSE")),"^",2) - .S $P(NODE,"^",12)=$P($G(@STAT@("ACCEPT ACK RESPONSE")),"^") - .S $P(NODE,"^",13)=$P($G(@STAT@("ACCEPT ACK RESPONSE")),"^",2) - .S $P(NODE,"^",14)=$P($G(@STAT@("FAILURE RESPONSE")),"^") - .S $P(NODE,"^",15)=$P($G(@STAT@("FAILURE RESPONSE")),"^",2) - .; - .;for outgoing set these x-refs now, for incoming msgs set them later - .S ^HLB("B",ID,IEN)="" - .S ^HLB("C",HLMSTATE("BODY"),IEN)="" - .I ($G(@STAT)="ER") D - ..S ^HLB("ERRORS",$S($L($G(HLMSTATE("HDR","RECEIVING APPLICATION"))):HLMSTATE("HDR","RECEIVING APPLICATION"),1:"UNKNOWN"),HLMSTATE("DT/TM CREATED"),IEN)="" - ..D COUNT^HLOESTAT("OUT",$G(HLMSTATE("HDR","RECEIVING APPLICATION")),$G(HLMSTATE("HDR","SENDING APPLICATION")),$S(HLMSTATE("BATCH"):"BATCH",1:$G(HLMSTATE("HDR","MESSAGE TYPE"))),$G(HLMSTATE("HDR","EVENT"))) - .; - .;save some space for the ack - .S:($G(HLMSTATE("HDR","ACCEPT ACK TYPE"))="AL") ^HLB(IEN,4)="^^^ " - I $G(HLMSTATE("STATUS","PURGE")) S $P(NODE,"^",9)=HLMSTATE("STATUS","PURGE"),^HLB("AD","OUT",HLMSTATE("STATUS","PURGE"),HLMSTATE("IEN"))="" - S ^HLB(IEN,0)=NODE - ; - ;store the message header - S ^HLB(IEN,1)=HLMSTATE("HDR",1) - S ^HLB(IEN,2)=HLMSTATE("HDR",2) - ; - ;if the msg is an app ack, update the original msg - I $G(HLMSTATE("ACK TO","IEN"))]"" D - .N ACKTO - .M ACKTO=HLMSTATE("ACK TO") - .S ACKTO("ACK BY")=$S(HLMSTATE("BATCH"):HLMSTATE("HDR","BATCH CONTROL ID"),1:HLMSTATE("HDR","MESSAGE CONTROL ID")) - .D ACKTO^HLOF778(.HLMSTATE,.ACKTO) - .S HLMSTATE("ACK TO","DONE")=1 ;because the update was already done, otherwise it might be done again - ; - ;The "SEARCH" x-ref will be created asynchronously - S ^HLTMP("PENDING SEARCH X-REF",$J,HLMSTATE("DT/TM CREATED"),IEN)="" - ; - ;sequence q? - I HLMSTATE("DIRECTION")="OUT",$G(@STAT@("SEQUENCE QUEUE"))'="" S ^HLB(IEN,5)=@STAT@("SEQUENCE QUEUE") - ; - Q IEN - ; -NEWIEN(DIR,TCP) ; - ;This function uses a counter to get the next available ien for file 778. There are 4 different counters, each assigned as range of numbers, selected via the input parameters. It does not create a record. - ;Inputs: - ; DIR = "IN" or "OUT" (required) - ; TCP = 1,0 (optional) - ;Output - the function returns the next available ien. Several counters are used: - ; - ; <"OUT","TCP"> - ; <"OUT","NOT TCP"> - ; <"IN","TCP"> - ; <"IN","NOT TCP"> - ; - N IEN,COUNTER,INC - I DIR="OUT" S INC=$S(+$G(TCP):0,1:100000000000) - I DIR="IN" S INC=$S(+$G(TCP):200000000000,1:300000000000) - S COUNTER=$NA(^HLC("FILE778",DIR,$S(+$G(TCP):"TCP",1:"NOT TCP"))) -AGAIN ; - S IEN=$$INC^HLOSITE(COUNTER,1) - I IEN>100000000000 D - .L +@COUNTER:200 - .I $T,@COUNTER>100000000000 S @COUNTER=1,IEN=1 - .L -@COUNTER - I IEN>100000000000 G AGAIN - Q (IEN+INC) - ; -TCP() ;checks the link to see if its TCP, return 1 if yes, 0 if no or not defined - N IEN,TCP - S TCP=1 - S IEN=$G(HLMSTATE("STATUS","LINK IEN")) - I IEN,$P($G(^HLCS(869.1,+$P($G(^HLCS(870,IEN,0)),"^",3),0)),"^")'="TCP" S TCP=0 - Q TCP - ; -GETWORK(WORK) ; Used by the Process Manager. - ;Are there any messages that need the "SEARCH" x-ref set? - ;Inputs: - ; WORK (required, pass-by-reference) - ; ("DOLLARJ") - ; ("NOW") (required by the process manager, pass-by-reference) - ; - L +^HLTMP("PENDING SEARCH X-REF"):0 - Q:'$T 0 - N OLD,DOLLARJ,SUCCESS,NOW - S SUCCESS=0 - S NOW=$$SEC^XLFDT($H) - S (OLD,DOLLARJ)=$G(WORK("DOLLARJ")) - F S DOLLARJ=$O(^HLTMP("PENDING SEARCH X-REF",DOLLARJ)) Q:DOLLARJ="" D Q:SUCCESS - .N TIME S TIME=$O(^HLTMP("PENDING SEARCH X-REF",DOLLARJ,"")) - .S:(NOW-$$SEC^XLFDT(TIME)>100) SUCCESS=1 - ; - I OLD'="",'SUCCESS F S DOLLARJ=$O(^HLTMP("PENDING SEARCH X-REF",DOLLARJ)) Q:DOLLARJ="" Q:DOLLARJ>OLD D Q:SUCCESS - .N TIME S TIME=$O(^HLTMP("PENDING SEARCH X-REF",DOLLARJ,"")) - .S:(NOW-$$SEC^XLFDT(TIME)>100) SUCCESS=1 - S WORK("DOLLARJ")=DOLLARJ,WORK("NOW")=NOW - Q:WORK("DOLLARJ")]"" 1 - L -^HLTMP("PENDING SEARCH X-REF") - Q 0 - ; -DOWORK(WORK) ;Used by the Process Manager - ;Sets the "SEARCH" x-ref, running 100 seconds behind when the message record was created. - ; - N MSGIEN,TIME - S TIME=0 - F S TIME=$O(^HLTMP("PENDING SEARCH X-REF",WORK("DOLLARJ"),TIME)) Q:'TIME Q:((WORK("NOW")-$$SEC^XLFDT(TIME))<100) D - .S MSGIEN=0 - .F S MSGIEN=$O(^HLTMP("PENDING SEARCH X-REF",WORK("DOLLARJ"),TIME,MSGIEN)) Q:'MSGIEN D - ..N MSG - ..I $$GETMSG^HLOMSG(MSGIEN,.MSG) D - ...Q:'MSG("DT/TM CREATED") - ...I MSG("BATCH") D - ....N HDR - ....F Q:'$$NEXTMSG^HLOMSG(.MSG,.HDR) S MSG("HDR",1)=HDR(1),MSG("HDR",2)=HDR(2) D SET(.MSG) - ...E D - ....D SET(.MSG) - ..K ^HLTMP("PENDING SEARCH X-REF",WORK("DOLLARJ"),TIME,MSGIEN) - L -^HLTMP("PENDING SEARCH X-REF") - Q - ; -SET(MSG) ; - ;sets the ^HLB("SEARCH") x-ref - ; - N APP,FS,CS,IEN - I MSG("DIRECTION")'="IN",MSG("DIRECTION")'="OUT" Q - S FS=$E(MSG("HDR",1),4) - Q:FS="" - S CS=$E(MSG("HDR",1),5) - S APP=$S(MSG("DIRECTION")="IN":$P($P(MSG("HDR",1),FS,5),CS),1:$P($P(MSG("HDR",1),FS,3),CS)) - I APP="" S APP="UNKNOWN" - I MSG("BATCH") D - .N VALUE - .S VALUE=$P(MSG("HDR",2),FS,4) - .S MSG("MESSAGE TYPE")=$P(VALUE,CS) - .S MSG("EVENT")=$P(VALUE,CS,2) - S:MSG("MESSAGE TYPE")="" MSG("MESSAGE TYPE")="" - S:MSG("EVENT")="" MSG("EVENT")="" - S IEN=MSG("IEN") - I MSG("BATCH") S IEN=IEN_"^"_MSG("BATCH","CURRENT MESSAGE") - S ^HLB("SEARCH",MSG("DIRECTION"),MSG("DT/TM CREATED"),APP,MSG("MESSAGE TYPE"),MSG("EVENT"),IEN)="" - Q +HLOF778A ;ALB/CJM-HL7 - Saving messages to file 778 (continued) ;03/07/2007 + ;;1.6;HEALTH LEVEL SEVEN;**126,134**;Oct 13, 1995;Build 30 + ;Per VHA Directive 2004-038, this routine should not be modified. + ; + ; +NEW(HLMSTATE) ; + ;This function creates a new entry in file 778. + ;Input: + ; HLMSTATE (required, pass by reference) These subscripts are expected: + ; + ;Output - the function returns the ien of the newly created record + ; + N IEN,NODE,ID,STAT + S STAT="HLMSTATE(""STATUS"")" + S IEN=$$NEWIEN(HLMSTATE("DIRECTION"),$$TCP) + Q:'IEN 0 + S HLMSTATE("IEN")=IEN + ; + D ;build the message header + .N HDR + .;for incoming messages the header segment should already exist + .;for outgoing messages must build the header segment + .I HLMSTATE("DIRECTION")="OUT" D Q + ..I HLMSTATE("BATCH"),$G(HLMSTATE("ACK TO"))]"" S HLMSTATE("HDR","REFERENCE BATCH CONTROL ID")=HLMSTATE("ACK TO") + ..D BUILDHDR^HLOPBLD1(.HLMSTATE,$S(HLMSTATE("BATCH"):"BHS",1:"MSH"),.HDR) + ..S HLMSTATE("HDR",1)=HDR(1),HLMSTATE("HDR",2)=HDR(2) + ; + K ^HLB(IEN) + S ID=$S(HLMSTATE("BATCH"):HLMSTATE("HDR","BATCH CONTROL ID"),1:HLMSTATE("HDR","MESSAGE CONTROL ID")) + S NODE=ID_"^"_HLMSTATE("BODY")_"^"_$G(HLMSTATE("ACK TO"))_"^"_$S(HLMSTATE("DIRECTION")="IN":"I",1:"O")_"^" + S $P(NODE,"^",5)=$G(@STAT@("LINK NAME")) + S $P(NODE,"^",6)=$G(@STAT@("QUEUE")) + S $P(NODE,"^",8)=$G(@STAT@("PORT")) + S $P(NODE,"^",20)=$G(@STAT) + S $P(NODE,"^",21)=$G(@STAT@("ERROR TEXT")) + S $P(NODE,"^",16)=HLMSTATE("DT/TM") + ; + I HLMSTATE("DIRECTION")="OUT" D + .S $P(NODE,"^",10)=$P($G(@STAT@("APP ACK RESPONSE")),"^") + .S $P(NODE,"^",11)=$P($G(@STAT@("APP ACK RESPONSE")),"^",2) + .S $P(NODE,"^",12)=$P($G(@STAT@("ACCEPT ACK RESPONSE")),"^") + .S $P(NODE,"^",13)=$P($G(@STAT@("ACCEPT ACK RESPONSE")),"^",2) + .S $P(NODE,"^",14)=$P($G(@STAT@("FAILURE RESPONSE")),"^") + .S $P(NODE,"^",15)=$P($G(@STAT@("FAILURE RESPONSE")),"^",2) + .; + .;for outgoing set these x-refs now, for incoming msgs set them later + .S ^HLB("B",ID,IEN)="" + .S ^HLB("C",HLMSTATE("BODY"),IEN)="" + .I ($G(@STAT)="SE") D + ..S ^HLB("ERRORS","SE",$S($L($G(HLMSTATE("HDR","RECEIVING APPLICATION"))):HLMSTATE("HDR","RECEIVING APPLICATION"),1:"UNKNOWN"),HLMSTATE("DT/TM CREATED"),IEN)="" + ..D COUNT^HLOESTAT("OUT",$G(HLMSTATE("HDR","RECEIVING APPLICATION")),$G(HLMSTATE("HDR","SENDING APPLICATION")),$S(HLMSTATE("BATCH"):"BATCH",1:$G(HLMSTATE("HDR","MESSAGE TYPE"))),$G(HLMSTATE("HDR","EVENT"))) + .; + .;save some space for the ack + .S:($G(HLMSTATE("HDR","ACCEPT ACK TYPE"))="AL") ^HLB(IEN,4)="^^^ " + I $G(HLMSTATE("STATUS","PURGE")) S $P(NODE,"^",9)=HLMSTATE("STATUS","PURGE"),^HLB("AD","OUT",HLMSTATE("STATUS","PURGE"),HLMSTATE("IEN"))="" + S ^HLB(IEN,0)=NODE + ; + ;store the message header + S ^HLB(IEN,1)=HLMSTATE("HDR",1) + S ^HLB(IEN,2)=HLMSTATE("HDR",2) + ; + ;if the msg is an app ack, update the original msg + I $G(HLMSTATE("ACK TO","IEN"))]"" D + .N ACKTO + .M ACKTO=HLMSTATE("ACK TO") + .S ACKTO("ACK BY")=$S(HLMSTATE("BATCH"):HLMSTATE("HDR","BATCH CONTROL ID"),1:HLMSTATE("HDR","MESSAGE CONTROL ID")) + .D ACKTO^HLOF778(.HLMSTATE,.ACKTO) + .S HLMSTATE("ACK TO","DONE")=1 ;because the update was already done, otherwise it might be done again + ; + ;The "SEARCH" x-ref will be created asynchronously + S ^HLTMP("PENDING SEARCH X-REF",$J,HLMSTATE("DT/TM CREATED"),IEN)="" + ; + Q IEN + ; +NEWIEN(DIR,TCP) ; + ;This function uses a counter to get the next available ien for file 778. There are 4 different counters, each assigned as range of numbers, selected via the input parameters. It does not create a record. + ;Inputs: + ; DIR = "IN" or "OUT" (required) + ; TCP = 1,0 (optional) + ;Output - the function returns the next available ien. Several counters are used: + ; + ; <"OUT","TCP"> + ; <"OUT","NOT TCP"> + ; <"IN","TCP"> + ; <"IN","NOT TCP"> + ; + N IEN,COUNTER,INC + I DIR="OUT" S INC=$S(+$G(TCP):0,1:100000000000) + I DIR="IN" S INC=$S(+$G(TCP):200000000000,1:300000000000) + S COUNTER=$NA(^HLC("FILE778",DIR,$S(+$G(TCP):"TCP",1:"NOT TCP"))) +AGAIN ; + S IEN=$$INC^HLOSITE(COUNTER,1) + I IEN>100000000000 D + .L +@COUNTER:200 + .I $T,@COUNTER>100000000000 S @COUNTER=1,IEN=1 + .L -@COUNTER + I IEN>100000000000 G AGAIN + Q (IEN+INC) + ; +TCP() ;checks the link to see if its TCP, return 1 if yes, 0 if no or not defined + N IEN,TCP + S TCP=1 + S IEN=$G(HLMSTATE("STATUS","LINK IEN")) + I IEN,$P($G(^HLCS(869.1,+$P($G(^HLCS(870,IEN,0)),"^",3),0)),"^")'="TCP" S TCP=0 + Q TCP + ; +GETWORK(WORK) ; Used by the Process Manager. + ;Are there any messages that need the "SEARCH" x-ref set? + ;Inputs: + ; WORK (required, pass-by-reference) + ; ("DOLLARJ") + ; ("NOW") (required by the process manager, pass-by-reference) + ; + L +^HLTMP("PENDING SEARCH X-REF"):0 + Q:'$T 0 + N OLD,DOLLARJ,SUCCESS,NOW + S SUCCESS=0 + S NOW=$$SEC^XLFDT($H) + S (OLD,DOLLARJ)=$G(WORK("DOLLARJ")) + F S DOLLARJ=$O(^HLTMP("PENDING SEARCH X-REF",DOLLARJ)) Q:DOLLARJ="" D Q:SUCCESS + .N TIME S TIME=$O(^HLTMP("PENDING SEARCH X-REF",DOLLARJ,"")) + .S:(NOW-$$SEC^XLFDT(TIME)>100) SUCCESS=1 + ; + I OLD'="",'SUCCESS F S DOLLARJ=$O(^HLTMP("PENDING SEARCH X-REF",DOLLARJ)) Q:DOLLARJ="" Q:DOLLARJ>OLD D Q:SUCCESS + .N TIME S TIME=$O(^HLTMP("PENDING SEARCH X-REF",DOLLARJ,"")) + .S:(NOW-$$SEC^XLFDT(TIME)>100) SUCCESS=1 + S WORK("DOLLARJ")=DOLLARJ,WORK("NOW")=NOW + Q:WORK("DOLLARJ")]"" 1 + L -^HLTMP("PENDING SEARCH X-REF") + Q 0 + ; +DOWORK(WORK) ;Used by the Process Manager + ;Sets the "SEARCH" x-ref, running 100 seconds behind when the message record was created. + ; + N MSGIEN,TIME + S TIME=0 + F S TIME=$O(^HLTMP("PENDING SEARCH X-REF",WORK("DOLLARJ"),TIME)) Q:'TIME Q:((WORK("NOW")-$$SEC^XLFDT(TIME))<100) D + .S MSGIEN=0 + .F S MSGIEN=$O(^HLTMP("PENDING SEARCH X-REF",WORK("DOLLARJ"),TIME,MSGIEN)) Q:'MSGIEN D + ..N MSG + ..I $$GETMSG^HLOMSG(MSGIEN,.MSG) D + ...Q:'MSG("DT/TM CREATED") + ...I MSG("BATCH") D + ....N HDR + ....F Q:'$$NEXTMSG^HLOMSG(.MSG,.HDR) S MSG("HDR",1)=HDR(1),MSG("HDR",2)=HDR(2) D SET(.MSG) + ...E D + ....D SET(.MSG) + ..K ^HLTMP("PENDING SEARCH X-REF",WORK("DOLLARJ"),TIME,MSGIEN) + L -^HLTMP("PENDING SEARCH X-REF") + Q + ; +SET(MSG) ; + ;sets the ^HLB("SEARCH") x-ref + ; + N APP,FS,CS,IEN + I MSG("DIRECTION")'="IN",MSG("DIRECTION")'="OUT" Q + S FS=$E(MSG("HDR",1),4) + Q:FS="" + S CS=$E(MSG("HDR",1),5) + S APP=$S(MSG("DIRECTION")="IN":$P($P(MSG("HDR",1),FS,5),CS),1:$P($P(MSG("HDR",1),FS,3),CS)) + I APP="" S APP="UNKNOWN" + I MSG("BATCH") D + .N VALUE + .S VALUE=$P(MSG("HDR",2),FS,4) + .S MSG("MESSAGE TYPE")=$P(VALUE,CS) + .S MSG("EVENT")=$P(VALUE,CS,2) + S:MSG("MESSAGE TYPE")="" MSG("MESSAGE TYPE")="" + S:MSG("EVENT")="" MSG("EVENT")="" + S IEN=MSG("IEN") + I MSG("BATCH") S IEN=IEN_"^"_MSG("BATCH","CURRENT MESSAGE") + S ^HLB("SEARCH",MSG("DIRECTION"),MSG("DT/TM CREATED"),APP,MSG("MESSAGE TYPE"),MSG("EVENT"),IEN)="" + Q diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLOFILER.m b/r/HEALTH_LEVEL_SEVEN-HL/HLOFILER.m index 6d9f3b28..f56d95e4 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLOFILER.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLOFILER.m @@ -1,165 +1,165 @@ -HLOFILER ;ALB/CJM- Passes messages on the incoming queue to the applications - 10/4/94 1pm ;07/10/2007 - ;;1.6;HEALTH LEVEL SEVEN;**126,131,134,137**;Oct 13, 1995;Build 21 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; - ;GET WORK function for the process running under the Process Manager -GETWORK(QUE) ; - ;Input: - ; QUE - (pass by reference) These subscripts are used: - ; ("FROM") - sending facility last obtained - ; ("QUEUE") - name of the queue last obtained - ;Output: - ; Function returns 1 if success, 0 if no more work - ; QUE- updated to identify next queu of messages to process. - ; - N FROM,QUEUE - I '$D(QUE("SYSTEM")) D - .N SYS - .D SYSPARMS^HLOSITE(.SYS) - .S QUE("SYSTEM","NORMAL PURGE")=SYS("NORMAL PURGE") - .S QUE("SYSTEM","ERROR PURGE")=SYS("ERROR PURGE") - S FROM=$G(QUE("FROM")),QUEUE=$G(QUE("QUEUE")) - I ($G(FROM)]""),($G(QUEUE)]"") D - .L -^HLB("QUEUE","IN",FROM,QUEUE) - .F S QUEUE=$O(^HLB("QUEUE","IN",FROM,QUEUE)) Q:(QUEUE="") I '$$STOPPED^HLOQUE("IN",QUEUE) L +^HLB("QUEUE","IN",FROM,QUEUE):0 Q:$T - I ($G(FROM)]""),($G(QUEUE)="") D - .F S FROM=$O(^HLB("QUEUE","IN",FROM)) Q:FROM="" D Q:($G(QUEUE)]"") - ..S QUEUE="" F S QUEUE=$O(^HLB("QUEUE","IN",FROM,QUEUE)) Q:(QUEUE="") I '$$STOPPED^HLOQUE("IN",QUEUE) L +^HLB("QUEUE","IN",FROM,QUEUE):0 Q:$T - I FROM="" D - .F S FROM=$O(^HLB("QUEUE","IN",FROM)) Q:FROM="" D Q:($G(QUEUE)]"") - ..S QUEUE="" F S QUEUE=$O(^HLB("QUEUE","IN",FROM,QUEUE)) Q:(QUEUE="") I '$$STOPPED^HLOQUE("IN",QUEUE) L +^HLB("QUEUE","IN",FROM,QUEUE):0 Q:$T - S QUE("FROM")=FROM,QUE("QUEUE")=QUEUE - Q:(QUEUE]"") 1 - Q 0 - ; -DOWORK(QUEUE) ;sends the messages on the queue - N $ETRAP,$ESTACK S $ETRAP="G ERROR^HLOFILER" - ; - N MSGIEN,DEQUE,QUE - M QUE=QUEUE - S DEQUE=0 - S MSGIEN=0 - ; - F S MSGIEN=$O(^HLB("QUEUE","IN",QUEUE("FROM"),QUEUE("QUEUE"),MSGIEN)) Q:'MSGIEN D M QUEUE=QUE - .N MCODE,ACTION,QUE,PURGE,ACKTOIEN,NODE - .N $ETRAP,$ESTACK S $ETRAP="G ERROR2^HLOFILER" - .S NODE=$G(^HLB("QUEUE","IN",QUEUE("FROM"),QUEUE("QUEUE"),MSGIEN)) - .S ACTION=$P(NODE,"^",1,2) - .S PURGE=$P(NODE,"^",3) - .S ACKTOIEN=$P(NODE,"^",4) - .D DEQUE(MSGIEN,PURGE,ACKTOIEN) - .I ACTION]"" D - ..N HLMSGIEN,MCODE,DEQUE,DUZ - ..N $ETRAP,$ESTACK S $ETRAP="G ERROR3^HLOFILER" - ..S HLMSGIEN=MSGIEN - ..S MCODE="D "_ACTION - ..N MSGIEN,X - ..D DUZ^XUP(.5) - ..X MCODE - ..;kill the apps variables - ..D - ...N ZTSK - ...D KILL^XUSCLEAN - ; -ENDWORK ;where the execution resumes upon an error - D DEQUE() - Q - ; -DEQUE(MSGIEN,PURGE,ACKTOIEN) ; - ;Dequeues the message. Also sets up the purge dt/tm and the completion status. - S:$G(MSGIEN) DEQUE=$G(DEQUE)+1,DEQUE(MSGIEN)=PURGE_"^"_ACKTOIEN - I '$G(MSGIEN)!($G(DEQUE)>25) S MSGIEN=0 D - .F S MSGIEN=$O(DEQUE(MSGIEN)) Q:'MSGIEN D - ..N NODE,PURGE,ACKTOIEN - ..S NODE=DEQUE(MSGIEN) - ..S PURGE=$P(NODE,"^"),ACKTOIEN=$P(NODE,"^",2) - ..D DEQUE^HLOQUE(QUEUE("FROM"),QUEUE("QUEUE"),"IN",MSGIEN) - ..S NODE=$G(^HLB(MSGIEN,0)) - ..Q:NODE="" - ..S $P(NODE,"^",19)=1 ;sets the flag to show that the app handoff was done - ..D:PURGE - ...N STATUS - ...S STATUS=$P(NODE,"^",20) - ...S:STATUS="" $P(NODE,"^",20)="SU",STATUS="SU" - ...S $P(NODE,"^",9)=$$FMADD^XLFDT($$NOW^XLFDT,,$S(PURGE=2:24*QUEUE("SYSTEM","ERROR PURGE"),$D(^HLB(MSGIEN,3,1,0)):24*QUEUE("SYSTEM","ERROR PURGE"),1:QUEUE("SYSTEM","NORMAL PURGE"))) - ...S ^HLB("AD",$S($E($P(NODE,"^",4))="I":"IN",1:"OUT"),$P(NODE,"^",9),MSGIEN)="" - ...I ACKTOIEN,$D(^HLB(ACKTOIEN,0)) S $P(^HLB(ACKTOIEN,0),"^",9)=$P(NODE,"^",9),^HLB("AD",$S($E($P(NODE,"^",4))="I":"OUT",1:"IN"),$P(NODE,"^",9),ACKTOIEN)="" - ..S ^HLB(MSGIEN,0)=NODE - .K DEQUE S DEQUE=0 - Q - ; -ERROR ;error trap - S $ETRAP="Q:$QUIT """" Q" - N HOUR - S HOUR=$E($$NOW^XLFDT,1,10) - S ^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2))=$G(^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2)))+1 - ; - D DEQUE() - ; - ;a lot of errors of the same type may indicate an endless loop - ;return to the Process Manager error trap - I ($G(^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2)))>30) Q:$QUIT "" Q - ; - ;while debugging quit on all errors - returns to the Process Manager error trap - I $G(^HLTMP("LOG ALL ERRORS")) Q:$QUIT "" Q - I $ECODE["EDITED" Q:$QUIT "" Q - ; - D ^%ZTER - D UNWIND^%ZTER - Q:$QUIT "" - Q - ; -ERROR2 ; - S $ETRAP="Q:$QUIT """" Q" - ; - D DEQUE() - ; - ;may need to change the status to Error - D - .N NODE,RAPP,SAPP,FS,CS,REP,ESCAPE,SUBCOMP,HDR,DIR,NOW - .S NOW=$$NOW^XLFDT - .S NODE=$G(^HLB(MSGIEN,0)) - .Q:NODE="" - .Q:$P(NODE,"^",20)="ER" - .S $P(NODE,"^",20)="ER",$P(NODE,"^",21)="APPLICATION ROUTINE ERROR" - .S DIR=$S($E($P(NODE,"^",4))="I":"IN",1:"OUT") - .I $P(NODE,"^",9) K ^HLB("AD",DIR,$P(NODE,"^",9),MSGIEN) - .S $P(NODE,"^",9)=$$FMADD^XLFDT(NOW,,24*QUEUE("SYSTEM","ERROR PURGE")) - .S ^HLB(MSGIEN,0)=NODE - .S ^HLB("AD",DIR,$P(NODE,"^",9),MSGIEN)="" - .S HDR=$G(^HLB(MSGIEN,1)) - .S FS=$E(HDR,4) - .Q:FS="" - .S CS=$E(HDR,5) - .S REP=$E(HDR,6) - .S ESCAPE=$E(HDR,7) - .S SUBCOMP=$E(HDR,8) - .S RAPP=$$DESCAPE^HLOPRS1($P($P(HDR,FS,5),CS),FS,CS,SUBCOMP,REP,ESCAPE) - .I RAPP="" S RAPP="UNKNOWN" - .S SAPP=$$DESCAPE^HLOPRS1($P($P(HDR,FS,3),CS),FS,CS,SUBCOMP,REP,ESCAPE) - .S ^HLB("ERRORS",RAPP,NOW,MSGIEN)="" - .D COUNT^HLOESTAT(DIR,RAPP,SAPP,"UNKNOWN") - ; - ;kill the apps variables - D - .N ZTSK,MSGIEN,QUEUE - .D KILL^XUSCLEAN - ; - ;release all the locks the app may have set, except Taskman lock - L:$D(ZTSK) ^%ZTSCH("TASK",ZTSK):1 - L:'$D(ZTSK) - ;reset HLO's lock - L +^HLTMP("HL7 RUNNING PROCESSES",$J):0 - ;return to processing the next message on the queue - S $ECODE="" - ; - Q:$QUIT "" - Q -ERROR3 ;error trap for application context - S $ETRAP="Q:$QUIT """" Q" - D ^%ZTER - S $ECODE=",UAPPLICATION ERROR," - ; - ;drop to the ERROR2 error handler - Q:$QUIT "" - Q +HLOFILER ;ALB/CJM- Passes messages on the incoming queue to the applications - 10/4/94 1pm ;03/28/2007 + ;;1.6;HEALTH LEVEL SEVEN;**126,131,134**;Oct 13, 1995;Build 30 + ;Per VHA Directive 2004-038, this routine should not be modified. + ; + ;GET WORK function for the process running under the Process Manager +GETWORK(QUE) ; + ;Input: + ; QUE - (pass by reference) These subscripts are used: + ; ("FROM") - sending facility last obtained + ; ("QUEUE") - name of the queue last obtained + ;Output: + ; Function returns 1 if success, 0 if no more work + ; QUE- updated to identify next queu of messages to process. + ; + N FROM,QUEUE + I '$D(QUE("SYSTEM")) D + .N SYS + .D SYSPARMS^HLOSITE(.SYS) + .S QUE("SYSTEM","NORMAL PURGE")=SYS("NORMAL PURGE") + .S QUE("SYSTEM","ERROR PURGE")=SYS("ERROR PURGE") + S FROM=$G(QUE("FROM")),QUEUE=$G(QUE("QUEUE")) + I ($G(FROM)]""),($G(QUEUE)]"") D + .L -^HLB("QUEUE","IN",FROM,QUEUE) + .F S QUEUE=$O(^HLB("QUEUE","IN",FROM,QUEUE)) Q:(QUEUE="") I '$$STOPPED^HLOQUE("IN",QUEUE) L +^HLB("QUEUE","IN",FROM,QUEUE):0 Q:$T + I ($G(FROM)]""),($G(QUEUE)="") D + .F S FROM=$O(^HLB("QUEUE","IN",FROM)) Q:FROM="" D Q:($G(QUEUE)]"") + ..S QUEUE="" F S QUEUE=$O(^HLB("QUEUE","IN",FROM,QUEUE)) Q:(QUEUE="") I '$$STOPPED^HLOQUE("IN",QUEUE) L +^HLB("QUEUE","IN",FROM,QUEUE):0 Q:$T + I FROM="" D + .F S FROM=$O(^HLB("QUEUE","IN",FROM)) Q:FROM="" D Q:($G(QUEUE)]"") + ..S QUEUE="" F S QUEUE=$O(^HLB("QUEUE","IN",FROM,QUEUE)) Q:(QUEUE="") I '$$STOPPED^HLOQUE("IN",QUEUE) L +^HLB("QUEUE","IN",FROM,QUEUE):0 Q:$T + S QUE("FROM")=FROM,QUE("QUEUE")=QUEUE + Q:(QUEUE]"") 1 + Q 0 + ; +DOWORK(QUEUE) ;sends the messages on the queue + N $ETRAP,$ESTACK S $ETRAP="G ERROR^HLOFILER" + ; + N MSGIEN,DEQUE,QUE + M QUE=QUEUE + S DEQUE=0 + S MSGIEN=0 + ; + F S MSGIEN=$O(^HLB("QUEUE","IN",QUEUE("FROM"),QUEUE("QUEUE"),MSGIEN)) Q:'MSGIEN D M QUEUE=QUE + .N MCODE,ACTION,QUE,PURGE,ACKTOIEN,NODE + .N $ETRAP,$ESTACK S $ETRAP="G ERROR2^HLOFILER" + .S NODE=$G(^HLB("QUEUE","IN",QUEUE("FROM"),QUEUE("QUEUE"),MSGIEN)) + .S ACTION=$P(NODE,"^",1,2) + .S PURGE=$P(NODE,"^",3) + .S ACKTOIEN=$P(NODE,"^",4) + .D DEQUE(MSGIEN,PURGE,ACKTOIEN) + .I ACTION]"" D + ..N HLMSGIEN,MCODE,DEQUE,DUZ + ..N $ETRAP,$ESTACK S $ETRAP="G ERROR3^HLOFILER" + ..S HLMSGIEN=MSGIEN + ..S MCODE="D "_ACTION + ..N MSGIEN,X + ..D DUZ^XUP(.5) + ..X MCODE + ..;kill the apps variables + ..D + ...N ZTSK + ...D KILL^XUSCLEAN + ; +ENDWORK ;where the execution resumes upon an error + D DEQUE() + Q + ; +DEQUE(MSGIEN,PURGE,ACKTOIEN) ; + ;Dequeues the message. Also sets up the purge dt/tm and the completion status. + S:$G(MSGIEN) DEQUE=$G(DEQUE)+1,DEQUE(MSGIEN)=PURGE_"^"_ACKTOIEN + I '$G(MSGIEN)!($G(DEQUE)>25) S MSGIEN=0 D + .F S MSGIEN=$O(DEQUE(MSGIEN)) Q:'MSGIEN D + ..N NODE,PURGE,ACKTOIEN + ..S NODE=DEQUE(MSGIEN) + ..S PURGE=$P(NODE,"^"),ACKTOIEN=$P(NODE,"^",2) + ..D DEQUE^HLOQUE(QUEUE("FROM"),QUEUE("QUEUE"),"IN",MSGIEN) + ..S NODE=$G(^HLB(MSGIEN,0)) + ..Q:NODE="" + ..S $P(NODE,"^",19)=1 ;sets the flag to show that the app handoff was done + ..D:PURGE + ...N STATUS + ...S STATUS=$P(NODE,"^",20) + ...S:STATUS="" $P(NODE,"^",20)="SU",STATUS="SU" + ...S $P(NODE,"^",9)=$$FMADD^XLFDT($$NOW^XLFDT,,$S(PURGE=2:24*QUEUE("SYSTEM","ERROR PURGE"),$D(^HLB(MSGIEN,3,1,0)):24*QUEUE("SYSTEM","ERROR PURGE"),1:QUEUE("SYSTEM","NORMAL PURGE"))) + ...S ^HLB("AD",$S($E($P(NODE,"^",4))="I":"IN",1:"OUT"),$P(NODE,"^",9),MSGIEN)="" + ...I ACKTOIEN,$D(^HLB(ACKTOIEN,0)) S $P(^HLB(ACKTOIEN,0),"^",9)=$P(NODE,"^",9),^HLB("AD",$S($E($P(NODE,"^",4))="I":"OUT",1:"IN"),$P(NODE,"^",9),ACKTOIEN)="" + ..S ^HLB(MSGIEN,0)=NODE + .K DEQUE S DEQUE=0 + Q + ; +ERROR ;error trap + S $ETRAP="Q:$QUIT """" Q" + N HOUR + S HOUR=$E($$NOW^XLFDT,1,10) + S ^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2))=$G(^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2)))+1 + ; + D DEQUE() + ; + ;a lot of errors of the same type may indicate an endless loop + ;return to the Process Manager error trap + I ($G(^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2)))>30) Q:$QUIT "" Q + ; + ;while debugging quit on all errors - returns to the Process Manager error trap + I $G(^HLTMP("LOG ALL ERRORS")) Q:$QUIT "" Q + I $ECODE["EDITED" Q:$QUIT "" Q + ; + D ^%ZTER + D UNWIND^%ZTER + Q:$QUIT "" + Q + ; +ERROR2 ; + S $ETRAP="Q:$QUIT """" Q" + ; + D DEQUE() + ; + ;may need to change the status to Application Error + D + .N NODE,RAPP,SAPP,FS,CS,REP,ESCAPE,SUBCOMP,HDR,DIR,NOW + .S NOW=$$NOW^XLFDT + .S NODE=$G(^HLB(MSGIEN,0)) + .Q:NODE="" + .Q:$P(NODE,"^",20)="AE" + .S $P(NODE,"^",20)="AE",$P(NODE,"^",21)="APPLICATION ROUTINE ERROR" + .S DIR=$S($E($P(NODE,"^",4))="I":"IN",1:"OUT") + .I $P(NODE,"^",9) K ^HLB("AD",DIR,$P(NODE,"^",9),MSGIEN) + .S $P(NODE,"^",9)=$$FMADD^XLFDT(NOW,,24*QUEUE("SYSTEM","ERROR PURGE")) + .S ^HLB(MSGIEN,0)=NODE + .S ^HLB("AD",DIR,$P(NODE,"^",9),MSGIEN)="" + .S HDR=$G(^HLB(MSGIEN,1)) + .S FS=$E(HDR,4) + .Q:FS="" + .S CS=$E(HDR,5) + .S REP=$E(HDR,6) + .S ESCAPE=$E(HDR,7) + .S SUBCOMP=$E(HDR,8) + .S RAPP=$$DESCAPE^HLOPRS1($P($P(HDR,FS,5),CS),FS,CS,SUBCOMP,REP,ESCAPE) + .I RAPP="" S RAPP="UNKNOWN" + .S SAPP=$$DESCAPE^HLOPRS1($P($P(HDR,FS,3),CS),FS,CS,SUBCOMP,REP,ESCAPE) + .S ^HLB("ERRORS","AE",RAPP,NOW,MSGIEN)="" + .D COUNT^HLOESTAT(DIR,RAPP,SAPP,"UNKNOWN") + ; + ;kill the apps variables + D + .N ZTSK,MSGIEN,QUEUE + .D KILL^XUSCLEAN + ; + ;release all the locks the app may have set, except Taskman lock + L:$D(ZTSK) ^%ZTSCH("TASK",ZTSK):1 + L:'$D(ZTSK) + ;reset HLO's lock + L +^HLTMP("HL7 RUNNING PROCESSES",$J):0 + ;return to processing the next message on the queue + S $ECODE="" + ; + Q:$QUIT "" + Q +ERROR3 ;error trap for application context + S $ETRAP="Q:$QUIT """" Q" + D ^%ZTER + S $ECODE=",UAPPLICATION ERROR," + ; + ;drop to the ERROR2 error handler + Q:$QUIT "" + Q diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLOMSG.m b/r/HEALTH_LEVEL_SEVEN-HL/HLOMSG.m index 321cb3fb..46e916ee 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLOMSG.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLOMSG.m @@ -1,223 +1,216 @@ -HLOMSG ;ALB/CJM-HL7 - APIs for files 777/778 ;07/25/2007 - ;;1.6;HEALTH LEVEL SEVEN;**126,134,137**;Oct 13, 1995;Build 21 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; -GETMSG(IEN,MSG) ; - ;Description: given the message ien=MSGIEN (required), it returns the MSG array containing information about the message, defined below. - ;Input: - ; IEN - the ien of the message in file 778 - ;Output: - ; Function returns 1 on success, 0 on failure - ; MSG (pass by reference, required) These are the subscripts returned: - ; - ; "ACK BY" - msg id of msg that acknowledges this one - ; "ACK BY IEN" - msg IEN of msg that acknowledges this one. If the message is in the batch, the value is ^ - ; "ACK TO" - msg id of msg that this msg acknowledges - ; "ACK TO IEN" - msg IEN of msg that this msg acknowledges. If the message is in a batch, the value is ^ - ; "BATCH" = 1 if this is a batch message, 0 if not - ; "CURRENT MESSAGE" - defined only for batch messages - a counter used during building and parsing messages to indicate the current message. It will be set to 0 initially. - ; "BODY" - ptr to file 778 which contains the body of the message. - ; "DIRECTION" - "IN" if incoming, "OUT" if outgoing - ; "DT/TM" - date/time the message was sent or received - ; "DT/TM CREATED" - date/time the record was created (.01 field, file #777) - ; "LINE COUNT" - a counter used during building and parsing of - ; messages to indicate the current line within the message. For - ; batch messages where each message within the batch is stored - ; separately, this field indicates the position within the current - ; individual message - ; "HDR" - the header segment, NOT parsed, as HDR(1) and HDR(2) - ; "ID" - Message Control ID for an individual message, Batch Control ID for a batch message - ; "IEN" - ien, file 778 - ; "EVENT" - HL7 event, only defined if NOT batch - ; "MESSAGE TYPE" - HL7 message type, only defined if NOT batch - ; "STATUS" - the completion status - ; - ; These are lower level subscripts of "STATUS": - ; "ACCEPT ACK RESPONSE" - the application's ^ to Xecute when the accept ack is received - ; "ACCEPT ACK'D" - 1 if an accept ack was sent or received in response to this message - ; "APP ACK RESPONSE" - the application's ^ to Xecute when app ack is received - ; "APP ACK'D" - 1 if an application ack was sent or received in response to this message - ; "ERROR TEXT" - if in error status, a description of the error - ; "LINK NAME" the link the message was transmitted through - ; "PORT" - remote port over which the message was transmitted - ; "PURGE" - scheduled purge dt/tm - ; "QUEUE" - the queue that the message was placed on - ; "SEQUENCE QUEUE" - the sequence queue (optional) - ; - K MSG - Q:'$G(IEN) 0 - N NODE - S MSG("IEN")=IEN - S NODE=$G(^HLB(IEN,0)) - S MSG("ID")=$P(NODE,"^") - S MSG("BODY")=$P(NODE,"^",2) - S MSG("DIRECTION")=$S($E($P(NODE,"^",4))="O":"OUT",$E($P(NODE,"^",4))="I":"IN",1:"") - S MSG("ACK TO")=$P(NODE,"^",3) - S MSG("ACK BY")=$P(NODE,"^",7) - I MSG("ACK TO")]"" S MSG("ACK TO IEN")=$$ACKTOIEN^HLOMSG1($P(NODE,"^"),MSG("ACK TO")) - I MSG("ACK BY")]"" S MSG("ACK BY IEN")=$$ACKBYIEN^HLOMSG1($P(NODE,"^"),MSG("ACK BY")) - S MSG("DT/TM")=$P(NODE,"^",16) - S MSG("STATUS")=$P(NODE,"^",20) - ; - D - .N NODE4 - .S NODE4=$G(^HLB(IEN,4)) - .S MSG("STATUS","QUEUE")=$P(NODE,"^",6) - .S MSG("STATUS","LINK NAME")=$P(NODE,"^",5) - .S MSG("STATUS","PORT")=$P(NODE,"^",8) - .S MSG("STATUS","PURGE")=$P(NODE,"^",9) - .S MSG("STATUS","ERROR TEXT")=$P(NODE,"^",21) - .S MSG("STATUS","APP ACK RESPONSE")=$P(NODE,"^",10,11) - .I MSG("STATUS","APP ACK RESPONSE")="^" S MSG("STATUS","APP ACK RESPONSE")="" - .S MSG("STATUS","ACCEPT ACK RESPONSE")=$P(NODE,"^",12,13) - .I MSG("STATUS","ACCEPT ACK RESPONSE")="^" S MSG("STATUS","ACCEPT ACK RESPONSE")="" - .S MSG("STATUS","ACCEPT ACK'D")=$P(NODE,"^",17) - .S MSG("STATUS","APP ACK'D")=$P(NODE,"^",18) - .S MSG("STATUS")=$P(NODE,"^",20) - .S MSG("STATUS","APP HANDOFF")=$P(NODE,"^",19) - .S MSG("STATUS","ACCEPT ACK DT/TM")=$P(NODE4,"^") - .S MSG("STATUS","ACCEPT ACK ID")=$P(NODE4,"^",2) - .S MSG("STATUS","ACCEPT ACK MSA")=$P(NODE4,"^",3,99) - ; - S MSG("LINE COUNT")=0 - S MSG("HDR",1)=$G(^HLB(IEN,1)) - S MSG("HDR",2)=$G(^HLB(IEN,2)) - I 'MSG("BODY") D Q 0 - .S MSG("DT/TM CREATED")="" - .S MSG("BATCH")="" - .S MSG("MESSAGE TYPE")="" - .S MSG("EVENT")="" - ; - S NODE=$G(^HLA(MSG("BODY"),0)) - S MSG("DT/TM CREATED")=+NODE - S MSG("BATCH")=+$P(NODE,"^",2) - I MSG("BATCH") S MSG("BATCH","CURRENT MESSAGE")=0 - I 'MSG("BATCH") D - .S MSG("MESSAGE TYPE")=$P(NODE,"^",3) - .S MSG("EVENT")=$P(NODE,"^",4) - I MSG("DIRECTION")="OUT" D - .N NODE5 - .S NODE5=$G(^HLB(IEN,5)) - .S MSG("STATUS","SEQUENCE QUEUE")=$P(NODE5,"^") - .S MSG("STATUS","MOVED TO OUT QUEUE")=$P(NODE5,"^",2) - .S MSG("STATUS","SEQUENCE EXCEPTION RAISED")=$P(NODE5,"^",3) - Q 1 - ; -HLNEXT(MSG,SEG) ; - ;Description: Returns the next segment as a set of lines stored in SEG. - ;Input: - ; MSG (pass by reference, required) - ;Output: - ; Function returns 1 on success, 0 on failure (no more segments) - ; SEG (pass by reference, required) - ; - K SEG - Q:MSG("LINE COUNT")=-1 0 - I 'MSG("BATCH") D - .N I,J,NODE,START - .S START=0 - .S J=1,I=MSG("LINE COUNT") - .F S I=$O(^HLA(MSG("BODY"),1,I)) Q:'I S NODE=$G(^HLA(MSG("BODY"),1,I,0)) Q:(START&(NODE="")) I NODE'="" S SEG(J)=NODE,J=J+1,START=1 - .I 'I D - ..S MSG("LINE COUNT")=-1 - .E S MSG("LINE COUNT")=I - I MSG("BATCH") D - .N I,J,NODE,START - .S J=1,I=MSG("LINE COUNT"),START=0 - .F S I=$O(^HLA(MSG("BODY"),2,MSG("BATCH","CURRENT MESSAGE"),1,I)) Q:'I S NODE=$G(^HLA(MSG("BODY"),2,MSG("BATCH","CURRENT MESSAGE"),1,I,0)) Q:(START&(NODE="")) I NODE'="" S SEG(J)=NODE,J=J+1,START=1 - .I 'I D - ..S MSG("LINE COUNT")=-1 - .E S MSG("LINE COUNT")=I - Q $S($D(SEG):1,1:0) - ; -NEXTMSG(MSG,HDR) ; - ;Advances to the next message in the batch - ;Input: - ; MSG (pass by reference, required) - defined by $$GETMSG() - ;Output: - ; Function returns 1 on success, 0 if no more messages - ; MSG - updated with current position in the message - ; HDR (pass by reference, required) returns the header as an array of lines - ; - ; - K HDR - S MSG("LINE COUNT")=0 - N SUBIEN,I - ; - ;if completed parsing, don't start over - I MSG("BATCH","CURRENT MESSAGE")=-1 Q 0 - ; - S I=$O(^HLB(MSG("IEN"),3,"B",MSG("BATCH","CURRENT MESSAGE"))) - I 'I S MSG("BATCH","CURRENT MESSAGE")=-1 Q 0 - S MSG("BATCH","CURRENT MESSAGE")=I - S SUBIEN=$O(^HLB(MSG("IEN"),3,"B",I,0)) - S HDR(1)=$G(^HLB(MSG("IEN"),3,SUBIEN,1)) - S HDR(2)=$G(^HLB(MSG("IEN"),3,SUBIEN,2)) - Q $S($D(HDR):1,1:0) - ; -ADDSEG(HLMSTATE,SEG) ;Adds a segment to the message. - ;Input: - ; HLMSTATE() - (pass by reference, required) - ; SEG() - (pass by reference, required) The segment as lines SEG() - ; - ;Output: - ; HLMSTATE() - ; - N I,J S I=0 - S J=HLMSTATE("LINE COUNT") - ; - ;insure a blank line between segments - I J S J=J+1,HLMSTATE("UNSTORED LINES",$S(HLMSTATE("BATCH"):HLMSTATE("BATCH","CURRENT MESSAGE"),1:1),HLMSTATE("CURRENT SEGMENT"),J)="" - ; - S HLMSTATE("CURRENT SEGMENT")=HLMSTATE("CURRENT SEGMENT")+1 - F S I=$O(SEG(I)) Q:'I D - .S J=J+1 - .S HLMSTATE("UNSTORED LINES",$S(HLMSTATE("BATCH"):HLMSTATE("BATCH","CURRENT MESSAGE"),1:1),HLMSTATE("CURRENT SEGMENT"),J)=SEG(I),HLMSTATE("UNSTORED LINES")=HLMSTATE("UNSTORED LINES")+$L(SEG(I))+50 - .I HLMSTATE("UNSTORED LINES")>HLMSTATE("SYSTEM","BUFFER") D - ..I HLMSTATE("DIRECTION")="IN",$$SAVEMSG^HLOF778(.HLMSTATE) Q - ..I HLMSTATE("DIRECTION")="OUT",$$SAVEMSG^HLOF777(.HLMSTATE) - ; - S HLMSTATE("LINE COUNT")=J - Q - ; -ADDMSG(HLMSTATE,PARMS) ; - ;For outgoing messages, adds a message in the batch. There is no MSH yet, just the message type and event. - ;Input: - ; HLMSTATE() - (pass by reference, required) - ; PARMS("EVENT") - ; PARMS("MESSAGE TYPE") - ; - ;Output: - ; HLMSTATE() - (pass by reference, required) - ; - N I - S I=HLMSTATE("BATCH","CURRENT MESSAGE")+1,HLMSTATE("BATCH","CURRENT MESSAGE")=I - S HLMSTATE("UNSTORED LINES",I)=PARMS("MESSAGE TYPE")_"^"_PARMS("EVENT") - M:$G(PARMS("ACK TO"))]"" HLMSTATE("BATCH","ACK TO",I)=PARMS("ACK TO") - S HLMSTATE("CURRENT SEGMENT")=0 - S HLMSTATE("LINE COUNT")=0 - S HLMSTATE("UNSTORED LINES")=HLMSTATE("UNSTORED LINES")+100 - Q - ; -ADDMSG2(HLMSTATE,MSH) ; - ;For incoming messages adds a message to the batch. This differs from ADDMSG in that the MSH segment is passed in to be stored in file 778. - ;Input: - ; HLMSTATE() - (pass by reference, required) - ; MSH() - the MSH segment as a set of lines - ; - ;Output: - ; HLMSTATE() - (pass by reference, required) - ; - N FS,CS,VALUE - S HLMSTATE("BATCH","CURRENT MESSAGE")=HLMSTATE("BATCH","CURRENT MESSAGE")+1 - S FS=$E(MSH(1),4) - S CS=$E(MSH(1),5) - S VALUE=$P(MSH(2),FS,4) - S HLMSTATE("UNSTORED LINES",HLMSTATE("BATCH","CURRENT MESSAGE"))=$P(VALUE,CS)_"^"_$P(VALUE,CS,2) - S HLMSTATE("UNSTORED MSH")=1 - M HLMSTATE("UNSTORED MSH",HLMSTATE("BATCH","CURRENT MESSAGE"))=MSH - S HLMSTATE("CURRENT SEGMENT")=0 - S HLMSTATE("LINE COUNT")=0 - S HLMSTATE("UNSTORED LINES")=HLMSTATE("UNSTORED LINES")+200 - I HLMSTATE("UNSTORED LINES")>HLMSTATE("SYSTEM","BUFFER"),$$SAVEMSG^HLOF778(.HLMSTATE) ;first stores stuff in 777, then headers in file 778 - Q +HLOMSG ;ALB/CJM-HL7 - APIs for files 777/778 ;02/04/2004 + ;;1.6;HEALTH LEVEL SEVEN;**126,134**;Oct 13, 1995;Build 30 + ;Per VHA Directive 2004-038, this routine should not be modified. + ; +GETMSG(IEN,MSG) ; + ;Description: given the message ien=MSGIEN (required), it returns the MSG array containing information about the message, defined below. + ;Input: + ; IEN - the ien of the message in file 778 + ;Output: + ; Function returns 1 on success, 0 on failure + ; MSG (pass by reference, required) These are the subscripts returned: + ; + ; "ACK BY" - msg id of msg that acknowledges this one + ; "ACK BY IEN" - msg IEN of msg that acknowledges this one. If the message is in the batch, the value is ^ + ; "ACK TO" - msg id of msg that this msg acknowledges + ; "ACK TO IEN" - msg IEN of msg that this msg acknowledges. If the message is in a batch, the value is ^ + ; "BATCH" = 1 if this is a batch message, 0 if not + ; "CURRENT MESSAGE" - defined only for batch messages - a counter used during building and parsing messages to indicate the current message. It will be set to 0 initially. + ; "BODY" - ptr to file 778 which contains the body of the message. + ; "DIRECTION" - "IN" if incoming, "OUT" if outgoing + ; "DT/TM" - date/time the message was sent or received + ; "DT/TM CREATED" - date/time the record was created (.01 field, file #777) + ; "LINE COUNT" - a counter used during building and parsing of + ; messages to indicate the current line within the message. For + ; batch messages where each message within the batch is stored + ; separately, this field indicates the position within the current + ; individual message + ; "HDR" - the header segment, NOT parsed, as HDR(1) and HDR(2) + ; "ID" - Message Control ID for an individual message, Batch Control ID for a batch message + ; "IEN" - ien, file 778 + ; "EVENT" - HL7 event, only defined if NOT batch + ; "MESSAGE TYPE" - HL7 message type, only defined if NOT batch + ; "STATUS" - the completion status + ; + ; These are lower level subscripts of "STATUS": + ; "ACCEPT ACK RESPONSE" - the application's ^ to Xecute when the accept ack is received + ; "ACCEPT ACK'D" - 1 if an accept ack was sent or received in response to this message + ; "APP ACK RESPONSE" - the application's ^ to Xecute when app ack is received + ; "APP ACK'D" - 1 if an application ack was sent or received in response to this message + ; "ERROR TEXT" - if in error status, a description of the error + ; "LINK NAME" the link the message was transmitted through + ; "PORT" - remote port over which the message was transmitted + ; "PURGE" - scheduled purge dt/tm + ; "QUEUE" - the queue that the message was placed on + ; + K MSG + Q:'$G(IEN) 0 + N NODE + S MSG("IEN")=IEN + S NODE=$G(^HLB(IEN,0)) + S MSG("ID")=$P(NODE,"^") + S MSG("BODY")=$P(NODE,"^",2) + S MSG("DIRECTION")=$S($E($P(NODE,"^",4))="O":"OUT",$E($P(NODE,"^",4))="I":"IN",1:"") + S MSG("ACK TO")=$P(NODE,"^",3) + S MSG("ACK BY")=$P(NODE,"^",7) + I MSG("ACK TO")]"" S MSG("ACK TO IEN")=$$ACKTOIEN^HLOMSG1($P(NODE,"^"),MSG("ACK TO")) + I MSG("ACK BY")]"" S MSG("ACK BY IEN")=$$ACKBYIEN^HLOMSG1($P(NODE,"^"),MSG("ACK BY")) + S MSG("DT/TM")=$P(NODE,"^",16) + S MSG("STATUS")=$P(NODE,"^",20) + ; + D + .N NODE4 + .S NODE4=$G(^HLB(IEN,4)) + .S MSG("STATUS","QUEUE")=$P(NODE,"^",6) + .S MSG("STATUS","LINK NAME")=$P(NODE,"^",5) + .S MSG("STATUS","PORT")=$P(NODE,"^",8) + .S MSG("STATUS","PURGE")=$P(NODE,"^",9) + .S MSG("STATUS","ERROR TEXT")=$P(NODE,"^",21) + .S MSG("STATUS","APP ACK RESPONSE")=$P(NODE,"^",10,11) + .I MSG("STATUS","APP ACK RESPONSE")="^" S MSG("STATUS","APP ACK RESPONSE")="" + .S MSG("STATUS","ACCEPT ACK RESPONSE")=$P(NODE,"^",12,13) + .I MSG("STATUS","ACCEPT ACK RESPONSE")="^" S MSG("STATUS","ACCEPT ACK RESPONSE")="" + .S MSG("STATUS","ACCEPT ACK'D")=$P(NODE,"^",17) + .S MSG("STATUS","APP ACK'D")=$P(NODE,"^",18) + .S MSG("STATUS")=$P(NODE,"^",20) + .S MSG("STATUS","APP HANDOFF")=$P(NODE,"^",19) + .S MSG("STATUS","ACCEPT ACK DT/TM")=$P(NODE4,"^") + .S MSG("STATUS","ACCEPT ACK ID")=$P(NODE4,"^",2) + .S MSG("STATUS","ACCEPT ACK MSA")=$P(NODE4,"^",3,99) + ; + S MSG("LINE COUNT")=0 + S MSG("HDR",1)=$G(^HLB(IEN,1)) + S MSG("HDR",2)=$G(^HLB(IEN,2)) + I 'MSG("BODY") D Q 0 + .S MSG("DT/TM CREATED")="" + .S MSG("BATCH")="" + .S MSG("MESSAGE TYPE")="" + .S MSG("EVENT")="" + ; + S NODE=$G(^HLA(MSG("BODY"),0)) + S MSG("DT/TM CREATED")=+NODE + S MSG("BATCH")=+$P(NODE,"^",2) + I MSG("BATCH") S MSG("BATCH","CURRENT MESSAGE")=0 + I 'MSG("BATCH") D + .S MSG("MESSAGE TYPE")=$P(NODE,"^",3) + .S MSG("EVENT")=$P(NODE,"^",4) + Q 1 + ; +HLNEXT(MSG,SEG) ; + ;Description: Returns the next segment as a set of lines stored in SEG. + ;Input: + ; MSG (pass by reference, required) + ;Output: + ; Function returns 1 on success, 0 on failure (no more segments) + ; SEG (pass by reference, required) + ; + K SEG + Q:MSG("LINE COUNT")=-1 0 + I 'MSG("BATCH") D + .N I,J,NODE,START + .S START=0 + .S J=1,I=MSG("LINE COUNT") + .F S I=$O(^HLA(MSG("BODY"),1,I)) Q:'I S NODE=$G(^HLA(MSG("BODY"),1,I,0)) Q:(START&(NODE="")) I NODE'="" S SEG(J)=NODE,J=J+1,START=1 + .I 'I D + ..S MSG("LINE COUNT")=-1 + .E S MSG("LINE COUNT")=I + I MSG("BATCH") D + .N I,J,NODE,START + .S J=1,I=MSG("LINE COUNT"),START=0 + .F S I=$O(^HLA(MSG("BODY"),2,MSG("BATCH","CURRENT MESSAGE"),1,I)) Q:'I S NODE=$G(^HLA(MSG("BODY"),2,MSG("BATCH","CURRENT MESSAGE"),1,I,0)) Q:(START&(NODE="")) I NODE'="" S SEG(J)=NODE,J=J+1,START=1 + .I 'I D + ..S MSG("LINE COUNT")=-1 + .E S MSG("LINE COUNT")=I + Q $S($D(SEG):1,1:0) + ; +NEXTMSG(MSG,HDR) ; + ;Advances to the next message in the batch + ;Input: + ; MSG (pass by reference, required) - defined by $$GETMSG() + ;Output: + ; Function returns 1 on success, 0 if no more messages + ; MSG - updated with current position in the message + ; HDR (pass by reference, required) returns the header as an array of lines + ; + ; + K HDR + S MSG("LINE COUNT")=0 + N SUBIEN,I + ; + ;if completed parsing, don't start over + I MSG("BATCH","CURRENT MESSAGE")=-1 Q 0 + ; + S I=$O(^HLB(MSG("IEN"),3,"B",MSG("BATCH","CURRENT MESSAGE"))) + I 'I S MSG("BATCH","CURRENT MESSAGE")=-1 Q 0 + S MSG("BATCH","CURRENT MESSAGE")=I + S SUBIEN=$O(^HLB(MSG("IEN"),3,"B",I,0)) + S HDR(1)=$G(^HLB(MSG("IEN"),3,SUBIEN,1)) + S HDR(2)=$G(^HLB(MSG("IEN"),3,SUBIEN,2)) + Q $S($D(HDR):1,1:0) + ; +ADDSEG(HLMSTATE,SEG) ;Adds a segment to the message. + ;Input: + ; HLMSTATE() - (pass by reference, required) + ; SEG() - (pass by reference, required) The segment as lines SEG() + ; + ;Output: + ; HLMSTATE() + ; + N I,J S I=0 + S J=HLMSTATE("LINE COUNT") + ; + ;insure a blank line between segments + I J S J=J+1,HLMSTATE("UNSTORED LINES",$S(HLMSTATE("BATCH"):HLMSTATE("BATCH","CURRENT MESSAGE"),1:1),HLMSTATE("CURRENT SEGMENT"),J)="" + ; + S HLMSTATE("CURRENT SEGMENT")=HLMSTATE("CURRENT SEGMENT")+1 + F S I=$O(SEG(I)) Q:'I D + .S J=J+1 + .S HLMSTATE("UNSTORED LINES",$S(HLMSTATE("BATCH"):HLMSTATE("BATCH","CURRENT MESSAGE"),1:1),HLMSTATE("CURRENT SEGMENT"),J)=SEG(I),HLMSTATE("UNSTORED LINES")=HLMSTATE("UNSTORED LINES")+$L(SEG(I))+50 + .I HLMSTATE("UNSTORED LINES")>HLMSTATE("SYSTEM","BUFFER") D + ..I HLMSTATE("DIRECTION")="IN",$$SAVEMSG^HLOF778(.HLMSTATE) Q + ..I HLMSTATE("DIRECTION")="OUT",$$SAVEMSG^HLOF777(.HLMSTATE) + ; + S HLMSTATE("LINE COUNT")=J + Q + ; +ADDMSG(HLMSTATE,PARMS) ; + ;For outgoing messages, adds a message in the batch. There is no MSH yet, just the message type and event. + ;Input: + ; HLMSTATE() - (pass by reference, required) + ; PARMS("EVENT") + ; PARMS("MESSAGE TYPE") + ; + ;Output: + ; HLMSTATE() - (pass by reference, required) + ; + N I + S I=HLMSTATE("BATCH","CURRENT MESSAGE")+1,HLMSTATE("BATCH","CURRENT MESSAGE")=I + S HLMSTATE("UNSTORED LINES",I)=PARMS("MESSAGE TYPE")_"^"_PARMS("EVENT") + M:$G(PARMS("ACK TO"))]"" HLMSTATE("BATCH","ACK TO",I)=PARMS("ACK TO") + S HLMSTATE("CURRENT SEGMENT")=0 + S HLMSTATE("LINE COUNT")=0 + S HLMSTATE("UNSTORED LINES")=HLMSTATE("UNSTORED LINES")+100 + Q + ; +ADDMSG2(HLMSTATE,MSH) ; + ;For incoming messages adds a message to the batch. This differs from ADDMSG in that the MSH segment is passed in to be stored in file 778. + ;Input: + ; HLMSTATE() - (pass by reference, required) + ; MSH() - the MSH segment as a set of lines + ; + ;Output: + ; HLMSTATE() - (pass by reference, required) + ; + N FS,CS,VALUE + S HLMSTATE("BATCH","CURRENT MESSAGE")=HLMSTATE("BATCH","CURRENT MESSAGE")+1 + S FS=$E(MSH(1),4) + S CS=$E(MSH(1),5) + S VALUE=$P(MSH(2),FS,4) + S HLMSTATE("UNSTORED LINES",HLMSTATE("BATCH","CURRENT MESSAGE"))=$P(VALUE,CS)_"^"_$P(VALUE,CS,2) + S HLMSTATE("UNSTORED MSH")=1 + M HLMSTATE("UNSTORED MSH",HLMSTATE("BATCH","CURRENT MESSAGE"))=MSH + S HLMSTATE("CURRENT SEGMENT")=0 + S HLMSTATE("LINE COUNT")=0 + S HLMSTATE("UNSTORED LINES")=HLMSTATE("UNSTORED LINES")+200 + I HLMSTATE("UNSTORED LINES")>HLMSTATE("SYSTEM","BUFFER"),$$SAVEMSG^HLOF778(.HLMSTATE) ;first stores stuff in 777, then headers in file 778 + Q diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLOPOST.m b/r/HEALTH_LEVEL_SEVEN-HL/HLOPOST.m index 5cf62d86..0181c30e 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLOPOST.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLOPOST.m @@ -1,92 +1,80 @@ -HLOPOST ;IRMFO-ALB/CJM -Post-Install routine for HLO;03/24/2004 14:43 ;07/20/2007 - ;;1.6;HEALTH LEVEL SEVEN;**126,134,136,137**;Oct 13, 1995;Build 21 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; - N SYSTEM,DATA,VASITE,OLDSITE - D IDXLINKS - D SYSPARMS^HLOSITE(.SYSTEM) - S VASITE=$$SITE^VASITE - S OLDSITE=$G(^HLCS(869.3,1,0)) - S DATA(.01)=SYSTEM("DOMAIN") - I DATA(.01)="" D - .I $P(OLDSITE,"^",2) S DATA(.01)="HL7."_$P($G(^DIC(4.2,$P(OLDSITE,"^",2),0)),"^") - I DATA(.01)="" D - .N INST,DOMAIN - .S INST=$P(VASITE,"^") - .Q:'INST - .S DOMAIN=$P($G(^DIC(4,INST,6)),"^") - .I DOMAIN S DOMAIN=$P($G(^DIC(4.2,DOMAIN,0)),"^") I DOMAIN'="" S DATA(.01)="HL7."_DOMAIN - I DATA(.01)="" D BMES^XPDUTL("Post-Install failed, system missing INSTITUTION or DOMAIN file entry") Q - S DATA(.02)=SYSTEM("STATION") - I DATA(.02)="",$P(OLDSITE,"^",4) S DATA(.02)=$P($G(^DIC(4,$P(OLDSITE,"^",4),99)),"^") - I DATA(.02)="" S DATA(.02)=$P(VASITE,"^",3) - S DATA(.03)=$P(OLDSITE,"^",3) - S DATA(.04)=SYSTEM("MAXSTRING") - S DATA(.05)=SYSTEM("HL7 BUFFER") - S DATA(.06)=SYSTEM("USER BUFFER") - S DATA(.07)=SYSTEM("NORMAL PURGE") - S DATA(.08)=SYSTEM("ERROR PURGE") - I $D(^HLD(779.1,1,0)) D - .N ERROR - .I '$$UPD^HLOASUB1(779.1,1,.DATA,.ERROR) D BMES^XPDUTL("Post-Install failed -"_$G(ERROR)) - E D - .N ERROR - .I '$$ADD^HLOASUB1(779.1,,.DATA,.ERROR,1) D BMES^XPDUTL("Post-Install failed -"_$G(ERROR)) - Q -IDXLINKS ; - ;set the "AC" and "AD" indicies on the HL Logical Link file - N DIK - S DIK="^HLCS(870," - S DIK(1)=".01^AC^AD^AD1^AD2" - D ENALL^DIK - Q - ; -P134 ; - N DAILY,STARTUP,IEN,DATA - S DAILY=$O(^DIC(19,"B","HLO DAILY STARTUP",0)) - I 'DAILY D BMES^XPDUTL("Failed to schedule the HLO DAILY STARTUP option!") - S STARTUP=$O(^DIC(19,"B","HLO SYSTEM STARTUP",0)) - I 'STARTUP D BMES^XPDUTL("Failed to schedule the HLO SYSTEM STARTUP option!") - I STARTUP D - .S IEN=$O(^DIC(19.2,"B",STARTUP,0)) - .S DATA(.01)=STARTUP - .S DATA(2)="" - .S DATA(6)="" - .S DATA(9)=$S($P($G(^HLD(779.1,1,0)),"^",3)="P":"S",1:"") - .I IEN D - ..I '$$UPD^HLOASUB1(19.2,IEN,.DATA) D BMES^XPDUTL("Failed to schedule the HLO SYSTEM STARTUP option!") - .E D - ..I '$$ADD^HLOASUB1(19.2,,.DATA) D BMES^XPDUTL("Failed to schedule the HLO SYSTEM STARTUP option!") - I DAILY D - .S IEN=$O(^DIC(19.2,"B",DAILY,0)) - .S DATA(.01)=DAILY - .S DATA(2)=$$NOW^XLFDT - .S DATA(6)="1D" - .S DATA(9)="" - .I IEN D - ..I '$$UPD^HLOASUB1(19.2,IEN,.DATA) D BMES^XPDUTL("Failed to schedule the HLO DAILY STARTUP option!") - .E D - ..I '$$ADD^HLOASUB1(19.2,,.DATA) D BMES^XPDUTL("Failed to schedule the HLO DAILY STARTUP option!") - Q - ; -P136 ;post-install routine for HL*1.6*136 - N ERROR,DIFROM,IEN - I $P($G(^HLD(779.1,1,0)),"^",3)="P" D - .D RESCH^XUTMOPT("HLO DAILY STARTUP",$$FMADD^XLFDT($$NOW^XLFDT,,1),,"1D","L",.ERROR) - .I $G(ERROR)<0 D BMES^XPDUTL("Failed to schedule the HLO DAILY STARTUP option! Please do so manually") - ; - S IEN=$O(^HLD(779.3,"B","PURGE OLD MESSAGES",0)) - Q:'IEN - S ^HLD(779.3,IEN,0)="PURGE OLD MESSAGES^1^0^2^20^^5^GETWORK^HLOPURGE^DOWORK^HLOPURGE^1^0" - Q - ; -P137 ; - ;move the existing errros to the new structure - N TYPE - K ^TMP($J,"HLO ERRORS") - F TYPE="TF","SE","AE" D - .M ^TMP($J,"HLO ERRORS",TYPE)=^HLB("ERRORS",TYPE) - .M ^HLB("ERRORS")=^TMP($J,"HLO ERRORS",TYPE) - .K ^TMP($J,"HLO ERRORS",TYPE) - .K ^HLB("ERRORS",TYPE) - Q +HLOPOST ;IRMFO-ALB/CJM -Post-Install routine for HLO;03/24/2004 14:43 ;05/03/2007 + ;;1.6;HEALTH LEVEL SEVEN;**126,134,136**;Oct 13, 1995;Build 9 + ; + N SYSTEM,DATA,VASITE,OLDSITE + D IDXLINKS + D SYSPARMS^HLOSITE(.SYSTEM) + S VASITE=$$SITE^VASITE + S OLDSITE=$G(^HLCS(869.3,1,0)) + S DATA(.01)=SYSTEM("DOMAIN") + I DATA(.01)="" D + .I $P(OLDSITE,"^",2) S DATA(.01)="HL7."_$P($G(^DIC(4.2,$P(OLDSITE,"^",2),0)),"^") + I DATA(.01)="" D + .N INST,DOMAIN + .S INST=$P(VASITE,"^") + .Q:'INST + .S DOMAIN=$P($G(^DIC(4,INST,6)),"^") + .I DOMAIN S DOMAIN=$P($G(^DIC(4.2,DOMAIN,0)),"^") I DOMAIN'="" S DATA(.01)="HL7."_DOMAIN + I DATA(.01)="" D BMES^XPDUTL("Post-Install failed, system missing INSTITUTION or DOMAIN file entry") Q + S DATA(.02)=SYSTEM("STATION") + I DATA(.02)="",$P(OLDSITE,"^",4) S DATA(.02)=$P($G(^DIC(4,$P(OLDSITE,"^",4),99)),"^") + I DATA(.02)="" S DATA(.02)=$P(VASITE,"^",3) + S DATA(.03)=$P(OLDSITE,"^",3) + S DATA(.04)=SYSTEM("MAXSTRING") + S DATA(.05)=SYSTEM("HL7 BUFFER") + S DATA(.06)=SYSTEM("USER BUFFER") + S DATA(.07)=SYSTEM("NORMAL PURGE") + S DATA(.08)=SYSTEM("ERROR PURGE") + I $D(^HLD(779.1,1,0)) D + .N ERROR + .I '$$UPD^HLOASUB1(779.1,1,.DATA,.ERROR) D BMES^XPDUTL("Post-Install failed -"_$G(ERROR)) + E D + .N ERROR + .I '$$ADD^HLOASUB1(779.1,,.DATA,.ERROR,1) D BMES^XPDUTL("Post-Install failed -"_$G(ERROR)) + Q +IDXLINKS ; + ;set the "AC" and "AD" indicies on the HL Logical Link file + N DIK + S DIK="^HLCS(870," + S DIK(1)=".01^AC^AD^AD1^AD2" + D ENALL^DIK + Q + ; +P134 ; + N DAILY,STARTUP,IEN,DATA + S DAILY=$O(^DIC(19,"B","HLO DAILY STARTUP",0)) + I 'DAILY D BMES^XPDUTL("Failed to schedule the HLO DAILY STARTUP option!") + S STARTUP=$O(^DIC(19,"B","HLO SYSTEM STARTUP",0)) + I 'STARTUP D BMES^XPDUTL("Failed to schedule the HLO SYSTEM STARTUP option!") + I STARTUP D + .S IEN=$O(^DIC(19.2,"B",STARTUP,0)) + .S DATA(.01)=STARTUP + .S DATA(2)="" + .S DATA(6)="" + .S DATA(9)=$S($P($G(^HLD(779.1,1,0)),"^",3)="P":"S",1:"") + .I IEN D + ..I '$$UPD^HLOASUB1(19.2,IEN,.DATA) D BMES^XPDUTL("Failed to schedule the HLO SYSTEM STARTUP option!") + .E D + ..I '$$ADD^HLOASUB1(19.2,,.DATA) D BMES^XPDUTL("Failed to schedule the HLO SYSTEM STARTUP option!") + I DAILY D + .S IEN=$O(^DIC(19.2,"B",DAILY,0)) + .S DATA(.01)=DAILY + .S DATA(2)=$$NOW^XLFDT + .S DATA(6)="1D" + .S DATA(9)="" + .I IEN D + ..I '$$UPD^HLOASUB1(19.2,IEN,.DATA) D BMES^XPDUTL("Failed to schedule the HLO DAILY STARTUP option!") + .E D + ..I '$$ADD^HLOASUB1(19.2,,.DATA) D BMES^XPDUTL("Failed to schedule the HLO DAILY STARTUP option!") + Q + ; +P136 ;post-install routine for HL*1.6*136 + N ERROR,DIFROM,IEN + I $P($G(^HLD(779.1,1,0)),"^",3)="P" D + .D RESCH^XUTMOPT("HLO DAILY STARTUP",$$FMADD^XLFDT($$NOW^XLFDT,,1),,"1D","L",.ERROR) + .I $G(ERROR)<0 D BMES^XPDUTL("Failed to schedule the HLO DAILY STARTUP option! Please do so manually") + ; + S IEN=$O(^HLD(779.3,"B","PURGE OLD MESSAGES",0)) + Q:'IEN + S ^HLD(779.3,IEN,0)="PURGE OLD MESSAGES^1^0^2^20^^5^GETWORK^HLOPURGE^DOWORK^HLOPURGE^1^0" + Q diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLOPURGE.m b/r/HEALTH_LEVEL_SEVEN-HL/HLOPURGE.m index 77f84bfb..d6216a49 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLOPURGE.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLOPURGE.m @@ -1,164 +1,165 @@ -HLOPURGE ;IRMFO-ALB/CJM - Purging Old Messages;03/24/2004 14:43 ;07/25/2007 - ;;1.6;HEALTH LEVEL SEVEN;**126,134,136,137**;Oct 13, 1995;Build 21 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; -GETWORK(WORK) ; - ; - N OK - S OK=0 - I $G(WORK)]"" L -HLPURGE(WORK) - F WORK="IN","OUT","OLD778","OLD777" I '$G(WORK("DONE",WORK)) S WORK("DONE",WORK)=1 L +HLPURGE(WORK):0 S OK=$T Q:OK - I 'OK K WORK("DONE") S WORK="" - Q OK - ; -DOWORK(WORK) ; - I WORK="OLD778" D OLD778 - I WORK="OLD777" D OLD777 - I (WORK="IN")!(WORK="OUT") D - .N TIME,NOW - .S NOW=$$NOW^XLFDT - .S TIME=0 - .F S TIME=$O(^HLB("AD",WORK,TIME)) Q:TIME="" Q:TIME>NOW D - ..N MSGIEN - ..S MSGIEN=0 - ..F S MSGIEN=$O(^HLB("AD",WORK,TIME,MSGIEN)) Q:'MSGIEN D - ...K ^HLB("AD",WORK,TIME,MSGIEN) - ...D DELETE(MSGIEN) - L -HLPURGE(WORK) - Q -OLD778 ; - N OLD,START,END,APP,TYPE,TODAY,PARMS - S TODAY=$$DT^XLFDT - S OLD=$$FMADD^XLFDT(TODAY,-45) - F START=0,100000000000,200000000000,300000000000 D - .S END=(START+100000000000)-1 - .N MSGIEN,QUIT - .S QUIT=0 - .S MSGIEN=START - .F S MSGIEN=$O(^HLB(MSGIEN)) Q:'MSGIEN Q:(MSGIEN>END) D Q:QUIT - ..N WHEN,BODY,NODE - ..S NODE=$G(^HLB(MSGIEN,0)) - ..S WHEN=$P(NODE,"^",16) - ..I WHEN,WHENOLD S QUIT=1 - ; - ;also kill old errors left lying around - D SYSPARMS^HLOSITE(.PARMS) - S OLD=$$FMADD^XLFDT($$DT^XLFDT,-PARMS("ERROR PURGE")) - S APP="" - F S APP=$O(^HLB("ERRORS",APP)) Q:APP="" D - .N TIME - .S TIME=0 - .F S TIME=$O(^HLB("ERRORS",APP,TIME)) Q:'TIME Q:TIME>OLD K ^HLB("ERRORS",APP,TIME) - Q -OLD777 ; - N OLD,TIME,TODAY - S TODAY=$$DT^XLFDT - S OLD=$$FMADD^XLFDT(TODAY,-45) - S TIME=0 - F S TIME=$O(^HLA("B",TIME)) Q:'TIME Q:TIME>OLD D - .N MSGIEN - .S MSGIEN=0 - .F S MSGIEN=$O(^HLA("B",TIME,MSGIEN)) Q:'MSGIEN D - ..N IEN778,STOP - ..S (STOP,IEN778)=0 - ..F S IEN778=$O(^HLB("C",MSGIEN,IEN778)) Q:'IEN778 D - ...I $P($G(^HLB(IEN778,0)),"^",9)>TODAY S STOP=1 Q - ...D DELETE(IEN778,1) - ..K:'STOP ^HLB("C",MSGIEN),^HLA("B",TIME,MSGIEN),^HLA(MSGIEN) - Q - ; -DELETE(MSGIEN,FLAG) ; - ;Input: - ; MSGIEN - IEN, file 778 - ; FLAG - if $G(FLAG), will not delete the pointed to record in file 777 - N AC,SUBIEN,RAPP,SAPP,FS,CS,MSG - I '$$GETMSG^HLOMSG(MSGIEN,.MSG) ;MSG is corrupted, but there sill may be nodes to delete - S (RAPP,SAPP)="" - D - .S FS=$E(MSG("HDR",1),4) - .Q:FS="" - .S CS=$E(MSG("HDR",1),5) - .S SAPP=$P($P(MSG("HDR",1),FS,3),CS) - .I SAPP="" S SAPP="UNKNOWN" - .S RAPP=$P($P(MSG("HDR",1),FS,5),CS) - .I RAPP="" S RAPP="UNKNOWN" - ; - I 'MSG("BATCH") D KSEARCH(.MSG,MSG("MESSAGE TYPE"),MSG("EVENT"),SAPP,RAPP,MSGIEN) - ;if an error status,take care of the "ERRORS" x-ref - I MSG("STATUS")'="",MSG("STATUS")'="SU",MSG("BODY") D - .K ^HLB("ERRORS",RAPP,MSG("DT/TM CREATED"),MSGIEN) - .I MSG("STATUS")="ER" D - ..N SUB - ..S SUB=MSGIEN_"^" - ..K ^HLB("ERRORS",RAPP,MSG("DT/TM CREATED"),SUB) - ..F S SUB=$O(^HLB("ERRORS",RAPP,MSG("DT/TM CREATED"),SUB)) Q:SUB="" Q:+SUB'=MSGIEN K ^HLB("ERRORS",RAPP,MSG("DT/TM CREATED"),SUB) - ; - ;kill the whole-file xrefs for the message ien within a batch - S SUBIEN=0 - F S SUBIEN=$O(^HLB(MSGIEN,3,SUBIEN)) Q:'SUBIEN D - .N MSGID - .I FS]"" D - ..N VALUE,HDR2,MSGTYPE,EVENT - ..S HDR2=$G(^HLB(MSGIEN,3,SUBIEN,2)) - ..S VALUE=$P(HDR2,FS,4) - ..S MSGTYPE=$P(VALUE,CS) - ..S EVENT=$P(VALUE,CS,2) - ..D KSEARCH(.MSG,MSGTYPE,EVENT,SAPP,RAPP,MSGIEN_"^"_SUBIEN) - .S MSGID=$P($G(^HLB(MSGIEN,3,SUBIEN,0)),"^",2) - .I MSGID]"" K ^HLB("AE",MSGID,MSGIEN_"^"_SUBIEN) - ; - I MSG("DIRECTION")="IN" D - .Q:FS="" - .N VALUE,HDR - .S HDR("SENDING APPLICATION")=$P(MSG("HDR",1),FS,3) - .S VALUE=$P(MSG("HDR",1),FS,4) - .S HDR("SENDING FACILITY",1)=$P(VALUE,CS) - .S HDR("SENDING FACILITY",2)=$P(VALUE,CS,2) - .S HDR("SENDING FACILITY",3)=$P(VALUE,CS,3) - .S AC=$S(HDR("SENDING FACILITY",2)]"":HDR("SENDING FACILITY",2),1:HDR("SENDING FACILITY",1))_HDR("SENDING APPLICATION")_MSG("ID") - K ^HLB(MSGIEN) - I MSG("STATUS","PURGE"),MSG("DIRECTION")'="" K ^HLB("AD",MSG("DIRECTION"),MSG("STATUS","PURGE"),MSGIEN) - K:(MSG("ID")]"") ^HLB("B",MSG("ID"),MSGIEN) - I MSG("DIRECTION")="IN" D - .K:($G(AC)]"") ^HLB("AC",AC,MSGIEN) - .I MSG("BODY"),'$G(FLAG) D KILL777(MSG("BODY")) - I MSG("DIRECTION")="OUT" D - .K ^HLB("C",+MSG("BODY"),MSGIEN) - .I '$G(FLAG),'$O(^HLB("C",+MSG("BODY"),0)) D KILL777(MSG("BODY")) - Q - ; -KILL777(BODY) ; - Q:'$G(BODY) - N TIME - S TIME=$P($G(^HLA(BODY,0)),"^") - K ^HLA(BODY) - K:(TIME]"") ^HLA("B",TIME,BODY) - Q - ; -KSEARCH(MSG,MSGTYPE,EVENT,SAPP,RAPP,IEN) ; - ;Kills the ^HLB("SEARCH") x-ref - ; - N APP - S:MSGTYPE="" MSGTYPE="" - S:EVENT="" EVENT="" - Q:'MSG("DT/TM CREATED") - I MSG("DIRECTION")'="IN",MSG("DIRECTION")'="OUT" Q - S APP=$S(MSG("DIRECTION")="IN":RAPP,1:SAPP) - Q:APP="" - K ^HLB("SEARCH",MSG("DIRECTION"),MSG("DT/TM CREATED"),APP,MSGTYPE,EVENT,IEN) - Q +HLOPURGE ;IRMFO-ALB/CJM - Purging Old Messages;03/24/2004 14:43 ;04/30/2007 + ;;1.6;HEALTH LEVEL SEVEN;**126,134,136**;Oct 13, 1995;Build 9 + ;Per VHA Directive 2004-038, this routine should not be modified. + ; +GETWORK(WORK) ; + ; + N OK + S OK=0 + I $G(WORK)]"" L -HLPURGE(WORK) + F WORK="IN","OUT","OLD778","OLD777" I '$G(WORK("DONE",WORK)) S WORK("DONE",WORK)=1 L +HLPURGE(WORK):0 S OK=$T Q:OK + I 'OK K WORK("DONE") S WORK="" + Q OK + ; +DOWORK(WORK) ; + I WORK="OLD778" D OLD778 + I WORK="OLD777" D OLD777 + I (WORK="IN")!(WORK="OUT") D + .N TIME,NOW + .S NOW=$$NOW^XLFDT + .S TIME=0 + .F S TIME=$O(^HLB("AD",WORK,TIME)) Q:TIME="" Q:TIME>NOW D + ..N MSGIEN + ..S MSGIEN=0 + ..F S MSGIEN=$O(^HLB("AD",WORK,TIME,MSGIEN)) Q:'MSGIEN D + ...K ^HLB("AD",WORK,TIME,MSGIEN) + ...D DELETE(MSGIEN) + L -HLPURGE(WORK) + Q +OLD778 ; + N OLD,START,END,APP,TYPE,TODAY + S TODAY=$$DT^XLFDT + S OLD=$$FMADD^XLFDT(TODAY,-45) + F START=0,100000000000,200000000000,300000000000 D + .S END=(START+100000000000)-1 + .N MSGIEN,QUIT + .S QUIT=0 + .S MSGIEN=START + .F S MSGIEN=$O(^HLB(MSGIEN)) Q:'MSGIEN Q:(MSGIEN>END) D Q:QUIT + ..N WHEN,BODY,NODE + ..S NODE=$G(^HLB(MSGIEN,0)) + ..S WHEN=$P(NODE,"^",16) + ..I WHEN,WHENOLD S QUIT=1 + ; + ;also kill old errors left lying around + F TYPE="TF","AE","SE" S APP="" F S APP=$O(^HLB("ERRORS",TYPE,APP)) Q:APP="" D + .N TIME,PARMS + .D SYSPARMS^HLOSITE(.PARMS) + .S OLD=$$FMADD^XLFDT($$DT^XLFDT,-PARMS("ERROR PURGE")) + .S TIME=0 + .F S TIME=$O(^HLB("ERRORS",TYPE,APP,TIME)) Q:'TIME Q:TIME>OLD K ^HLB("ERRORS",TYPE,APP,TIME) + Q +OLD777 ; + N OLD,TIME,TODAY + S TODAY=$$DT^XLFDT + S OLD=$$FMADD^XLFDT(TODAY,-45) + S TIME=0 + F S TIME=$O(^HLA("B",TIME)) Q:'TIME Q:TIME>OLD D + .N MSGIEN + .S MSGIEN=0 + .F S MSGIEN=$O(^HLA("B",TIME,MSGIEN)) Q:'MSGIEN D + ..N IEN778,STOP + ..S (STOP,IEN778)=0 + ..F S IEN778=$O(^HLB("C",MSGIEN,IEN778)) Q:'IEN778 D + ...I $P($G(^HLB(IEN778,0)),"^",9)>TODAY S STOP=1 Q + ...D DELETE(IEN778,1) + ..K:'STOP ^HLB("C",MSGIEN),^HLA("B",TIME,MSGIEN),^HLA(MSGIEN) + Q + ; +DELETE(MSGIEN,FLAG) ; + ;Input: + ; MSGIEN - IEN, file 778 + ; FLAG - if $G(FLAG), will not delete the pointed to record in file 777 + N AC,SUBIEN,RAPP,SAPP,FS,CS,MSG + I '$$GETMSG^HLOMSG(MSGIEN,.MSG) ;MSG is corrupted, but there sill may be nodes to delete + S (RAPP,SAPP)="" + D + .S FS=$E(MSG("HDR",1),4) + .Q:FS="" + .S CS=$E(MSG("HDR",1),5) + .S SAPP=$P($P(MSG("HDR",1),FS,3),CS) + .I SAPP="" S SAPP="UNKNOWN" + .S RAPP=$P($P(MSG("HDR",1),FS,5),CS) + .I RAPP="" S RAPP="UNKNOWN" + ; + I 'MSG("BATCH") D KSEARCH(.MSG,MSG("MESSAGE TYPE"),MSG("EVENT"),SAPP,RAPP,MSGIEN) + ;if an error status,take care of the "ERRORS" x-ref + I MSG("STATUS")'="",MSG("STATUS")'="SU",MSG("BODY") D + .N APP + .S APP=$S(MSG("STATUS")="TF":SAPP,1:RAPP) + .K ^HLB("ERRORS",MSG("STATUS"),APP,MSG("DT/TM CREATED"),MSGIEN) + .I MSG("STATUS")="AE" D + ..N SUB + ..S SUB=MSGIEN_"^" + ..K ^HLB("ERRORS","AE",APP,MSG("DT/TM CREATED"),SUB) + ..F S SUB=$O(^HLB("ERRORS","AE",APP,MSG("DT/TM CREATED"),SUB)) Q:SUB="" Q:+SUB'=MSGIEN K ^HLB("ERRORS","AE",APP,MSG("DT/TM CREATED"),SUB) + ; + ;kill the whole-file xrefs for the message ien within a batch + S SUBIEN=0 + F S SUBIEN=$O(^HLB(MSGIEN,3,SUBIEN)) Q:'SUBIEN D + .N MSGID + .I FS]"" D + ..N VALUE,HDR2,MSGTYPE,EVENT + ..S HDR2=$G(^HLB(MSGIEN,3,SUBIEN,2)) + ..S VALUE=$P(HDR2,FS,4) + ..S MSGTYPE=$P(VALUE,CS) + ..S EVENT=$P(VALUE,CS,2) + ..D KSEARCH(.MSG,MSGTYPE,EVENT,SAPP,RAPP,MSGIEN_"^"_SUBIEN) + .S MSGID=$P($G(^HLB(MSGIEN,3,SUBIEN,0)),"^",2) + .I MSGID]"" K ^HLB("AE",MSGID,MSGIEN_"^"_SUBIEN) + ; + I MSG("DIRECTION")="IN" D + .Q:FS="" + .N VALUE,HDR + .S HDR("SENDING APPLICATION")=$P(MSG("HDR",1),FS,3) + .S VALUE=$P(MSG("HDR",1),FS,4) + .S HDR("SENDING FACILITY",1)=$P(VALUE,CS) + .S HDR("SENDING FACILITY",2)=$P(VALUE,CS,2) + .S HDR("SENDING FACILITY",3)=$P(VALUE,CS,3) + .S AC=$S(HDR("SENDING FACILITY",2)]"":HDR("SENDING FACILITY",2),1:HDR("SENDING FACILITY",1))_HDR("SENDING APPLICATION")_MSG("ID") + K ^HLB(MSGIEN) + I MSG("STATUS","PURGE"),MSG("DIRECTION")'="" K ^HLB("AD",MSG("DIRECTION"),MSG("STATUS","PURGE"),MSGIEN) + K:(MSG("ID")]"") ^HLB("B",MSG("ID"),MSGIEN) + I MSG("DIRECTION")="IN" D + .K:($G(AC)]"") ^HLB("AC",AC,MSGIEN) + .I MSG("BODY"),'$G(FLAG) D KILL777(MSG("BODY")) + I MSG("DIRECTION")="OUT" D + .K ^HLB("C",+MSG("BODY"),MSGIEN) + .I '$G(FLAG),'$O(^HLB("C",+MSG("BODY"),0)) D KILL777(MSG("BODY")) + Q + ; +KILL777(BODY) ; + Q:'$G(BODY) + N TIME + S TIME=$P($G(^HLA(BODY,0)),"^") + K ^HLA(BODY) + K:(TIME]"") ^HLA("B",TIME,BODY) + Q + ; +KSEARCH(MSG,MSGTYPE,EVENT,SAPP,RAPP,IEN) ; + ;Kills the ^HLB("SEARCH") x-ref + ; + N APP + S:MSGTYPE="" MSGTYPE="" + S:EVENT="" EVENT="" + Q:'MSG("DT/TM CREATED") + I MSG("DIRECTION")'="IN",MSG("DIRECTION")'="OUT" Q + S APP=$S(MSG("DIRECTION")="IN":RAPP,1:SAPP) + Q:APP="" + K ^HLB("SEARCH",MSG("DIRECTION"),MSG("DT/TM CREATED"),APP,MSGTYPE,EVENT,IEN) + Q diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLOQUE.m b/r/HEALTH_LEVEL_SEVEN-HL/HLOQUE.m index 671ccf97..03c0e1af 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLOQUE.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLOQUE.m @@ -1,220 +1,91 @@ -HLOQUE ;ALB/CJM- HL7 QUEUE MANAGEMENT - 10/4/94 1pm ;07/31/2007 - ;;1.6;HEALTH LEVEL SEVEN;**126,132,134,137**;Oct 13, 1995;Build 21 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; -INQUE(FROM,QNAME,IEN778,ACTION,PURGE) ; - ;Will place the message=IEN778 on the IN queue, incoming - ;Input: - ; FROM - sending facility from message header. - ; For actions other than incoming messages, its the specified link. - ; QNAME - queue named by the application - ; IEN778 = ien of the message in file 778 - ; ACTION - that should be executed for the application - ; PURGE (optional) - PURGE=1 indicates that the purge dt/tm needs to be set by the infiler - ; If PURGE("ACKTOIEN") is set, it indicates that the purge dt/tm of - ; the original message to this application ack also needs to be set. - ;Output: none - ; - I $G(FROM)="" S FROM="UNKNOWN" - I '$L($G(QNAME)) S QNAME="DEFAULT" - S ^HLB("QUEUE","IN",FROM,QNAME,IEN778)=ACTION_"^"_$G(PURGE)_"^"_$G(PURGE("ACKTOIEN")) - I $$INC^HLOSITE($NA(^HLC("QUEUECOUNT","IN",FROM,QNAME))) - Q - ; -OUTQUE(LINKNAME,PORT,QNAME,IEN778) ; - ;Will place the message=IEN778 on the out-going queue - ;Input: - ; LINKNAME = name of (.01) the logical link - ; PORT (optional) the port to connect to - ; QNAME - queue named by the application - ; IEN778 = ien of the message in file 778 - ;Output: none - ; - N SUB - S SUB=LINKNAME - I PORT S SUB=SUB_":"_PORT - I '$L($G(QNAME)) S QNAME="DEFAULT" - S ^HLB("QUEUE","OUT",SUB,QNAME,IEN778)="" - I $$INC^HLOSITE($NA(^HLC("QUEUECOUNT","OUT",SUB,QNAME))) - Q - ; -DEQUE(FROMORTO,QNAME,DIR,IEN778) ; - ;This routine will remove the message=IEN778 from its queue - ;Input: - ; DIR = "IN" or "OUT", denoting the direction that the message is going in - ; FROMORTO = for outgoing: the .01 field of the logical link - ; for incoming: sending facility - ; IEN778 = ien of the message in file 778 - ;Output: none - ; - Q:(FROMORTO="") - I ($G(QNAME)="") S QNAME="DEFAULT" - D - .I $E(DIR)="I" S DIR="IN" Q - .I $E(DIR)="O" S DIR="OUT" Q - I DIR'="IN",DIR'="OUT" Q - Q:'$G(IEN778) - D:$D(^HLB("QUEUE",DIR,FROMORTO,QNAME,IEN778)) - .K ^HLB("QUEUE",DIR,FROMORTO,QNAME,IEN778) - .;don't let the count become negative - .I $$INC^HLOSITE($NA(^HLC("QUEUECOUNT",DIR,FROMORTO,QNAME)),-1)<0,$$INC^HLOSITE($NA(^HLC("QUEUECOUNT",DIR,FROMORTO,QNAME))) - Q - ; -STOPQUE(DIR,QUEUE) ; - ;This API is used to set a stop flag on a named queue. - ;DIR=<"IN" or "OUT"> - ;QUEUE - the name of the queue to be stopped - ; - Q:$G(DIR)="" - Q:$G(QUEUE)="" - S ^HLTMP("STOPPED QUEUES",DIR,QUEUE)=1 - Q -STARTQUE(DIR,QUEUE) ; - ;This API is used to REMOVE the stop flag on a named queue. - ;DIR=<"IN" or "OUT"> - ;QUEUE - the name of the queue to be stopped - ; - Q:$G(DIR)="" - Q:$G(QUEUE)="" - K ^HLTMP("STOPPED QUEUES",DIR,QUEUE) - Q -STOPPED(DIR,QUEUE) ; - ;This API is used to DETERMINE if the stop flag on a named queue is set. - ;Input: - ; DIR=<"IN" or "OUT"> - ; QUEUE - the name of the queue to be checked - ;Output: - ; Function returns 1 if the queue is stopped, 0 otherwise - Q:$G(DIR)="" 0 - Q:$G(QUEUE)="" 0 - I $G(^HLTMP("STOPPED QUEUES",DIR,QUEUE)) Q 1 - Q 0 - ; -SQUE(SQUE,LINKNAME,PORT,QNAME,IEN778) ; - ;Will place the message=IEN778 on the sequencing queue. This is always done in the context of the application calling an HLO API to send a message. - ;Input: - ; SQUE - name of the sequencing queue - ; LINKNAME = name of (.01) the logical link - ; PORT (optional) the port to connect to - ; QNAME (optional) outgoing queue - ; IEN778 = ien of the message in file 778 - ;Output: 1 if placed on the outgoing queue, 0 if placed on the sequence queue - ; - N NEXT,MOVED - S MOVED=0 - ; - ;keep a count of messages pending on sequence queues for the HLO System Monitor - I $$INC^HLOSITE($NA(^HLC("QUEUECOUNT","SEQUENCE"))) - ; - L +^HLB("QUEUE","SEQUENCE",SQUE):200 - ; - S NEXT=+$G(^HLB("QUEUE","SEQUENCE",SQUE)) - Q:NEXT=IEN778 0 ;already queued! - ;if the sequence queue is empty and not waiting on a message, then the message can be put directly on the outgoing queue, bypassing the sequence queue - I '$O(^HLB("QUEUE","SEQUENCE",SQUE,0)),'NEXT D - .S ^HLB("QUEUE","SEQUENCE",SQUE)=IEN778 ;to mean something moved to outgoing but not yet transmitted - .L -^HLB("QUEUE","SEQUENCE",SQUE) - .D OUTQUE(.LINKNAME,.PORT,.QNAME,IEN778) - .S MOVED=1 - E D - .;Put the message on the sequence queue. - .S ^HLB("QUEUE","SEQUENCE",SQUE,IEN778)="" - .L -^HLB("QUEUE","SEQUENCE",SQUE) - Q MOVED - ; -ADVANCE(SQUE,MSGIEN) ; - ;Will move the specified sequencing queue to the next message. - ;Input: - ; SQUE - name of the sequencing queue - ; MSGIEN - the ien of the message upon which the sequence queue was waiting. If it is NOT the correct ien, then the sequence queue will NOT be advance. - ;Output: - ; Function - 1 if advanced, 0 if not - ; - N NODE,IEN778,LINKNAME,PORT,QNAME - Q:'$L($G(SQUE)) 0 - Q:'$G(MSGIEN) 0 - L +^HLB("QUEUE","SEQUENCE",SQUE):200 - ; - ;do not advance if the queue wasn't pending the message=MSGIEN - I (MSGIEN'=$P($G(^HLB("QUEUE","SEQUENCE",SQUE)),"^")) L -^HLB("QUEUE","SEQUENCE",SQUE) Q 0 - ; - I $$INC^HLOSITE($NA(^HLC("QUEUECOUNT","SEQUENCE")),-1)<0,$$INC^HLOSITE($NA(^HLC("QUEUECOUNT","SEQUENCE"))) ;decrement the count of messages pending sequence queues - ; - S IEN778=0 - ;look for the first message on the sequence que. Make sure its valid, if not remove the invalid entry and keep looking. - F S IEN778=$O(^HLB("QUEUE","SEQUENCE",SQUE,0)) Q:'IEN778 S NODE=$G(^HLB(IEN778,0)) Q:$L(NODE) D - .;message does not exist! Remove from queue and try again. - .K ^HLB("QUEUE","SEQUENCE",SQUE,IEN778) - .I $$INC^HLOSITE($NA(^HLC("QUEUECOUNT","SEQUENCE")),-1)<0,$$INC^HLOSITE($NA(^HLC("QUEUECOUNT","SEQUENCE"))) ;decrement the count of messages pending sequence queues - ; - ;IEN778 is the next pending msg on this sequence queue - I IEN778 D - .; - .;parse out info needed to move to outgoing queue - .S LINKNAME=$P(NODE,"^",5),PORT=$P(NODE,"^",8),QNAME=$P(NODE,"^",6) - .; - .S ^HLB("QUEUE","SEQUENCE",SQUE)=IEN778 ;indicates this sequence queue is now waiting for msg=IEN778 before advancing. The second pieces is the timer, but will not be set until the message=IEN778 is actually transmitted. - .K ^HLB("QUEUE","SEQUENCE",SQUE,IEN778) ;remove from sequence queue - .L -^HLB("QUEUE","SEQUENCE",SQUE) - .S $P(^HLB(IEN778,5),"^",2)=1 - .D OUTQUE(.LINKNAME,$G(PORT),$G(QNAME),IEN778) ;move to outgoing queue - E D - .K ^HLB("QUEUE","SEQUENCE",SQUE) ;this sequence queue is currently empty and not needed - .L -^HLB("QUEUE","SEQUENCE",SQUE) - Q 1 - ; -SEQCHK(WORK) ;functions under the HLO Process Manager - ;check sequence queues for timeout - N QUE,NOW - S NOW=$$NOW^XLFDT - S QUE="" - F S QUE=$O(^HLB("QUEUE","SEQUENCE",QUE)) Q:QUE="" D - .N NODE,MSGIEN,ACTION,NODE - .S NODE=$G(^HLB("QUEUE","SEQUENCE",QUE)) - .Q:'$P(NODE,"^",2) - .Q:$P(NODE,"^",2)>NOW - .Q:$P(NODE,"^",3) - .L +^HLB("QUEUE","SEQUENCE",QUE):2 - .;don't report if a lock wasn't obtained - .Q:'$T - .S NODE=$G(^HLB("QUEUE","SEQUENCE",QUE)) - .I '$P(NODE,"^",2) L -^HLB("QUEUE","SEQUENCE",QUE) Q - .I ($P(NODE,"^",2)>NOW) L -^HLB("QUEUE","SEQUENCE",QUE) Q - .I $P(NODE,"^",3) L -^HLB("QUEUE","SEQUENCE",QUE) Q ;exception already raised - .S MSGIEN=$P(NODE,"^") - .I 'MSGIEN L -^HLB("QUEUE","SEQUENCE",QUE) Q - .S ACTION=$$EXCEPT^HLOAPP($$GETSAP^HLOCLNT2(MSGIEN)) - .S $P(^HLB(MSGIEN,5),"^",3)=1 - .S $P(^HLB("QUEUE","SEQUENCE",QUE),"^",3)=1 ;indicates exception raised - .L -^HLB("QUEUE","SEQUENCE",QUE) - .D ;call the application to take action - ..N HLMSGIEN,MCODE,DUZ,QUE,NOW - ..N $ETRAP,$ESTACK S $ETRAP="G ERROR^HLOQUE" - ..S HLMSGIEN=MSGIEN - ..S MCODE="D "_ACTION - ..N MSGIEN,X - ..D DUZ^XUP(.5) - ..X MCODE - ..;kill the apps variables - ..D - ...N ZTSK - ...D KILL^XUSCLEAN - Q -ERROR ;error trap for application context - S $ETRAP="D UNWIND^%ZTER" - D ^%ZTER - S $ECODE=",UAPPLICATION ERROR," - ; - ;kill the apps variables - D - .N ZTSK,MSGIEN,QUEUE - .D KILL^XUSCLEAN - ; - ;release all the locks the app may have set, except Taskman lock - L:$D(ZTSK) ^%ZTSCH("TASK",ZTSK):1 - L:'$D(ZTSK) - ;reset HLO's lock - L +^HLTMP("HL7 RUNNING PROCESSES",$J):0 - ;return to processing the next message on the queue - D UNWIND^%ZTER - Q +HLOQUE ;ALB/CJM- HL7 QUEUE MANAGEMENT - 10/4/94 1pm ;01/05/2007 + ;;1.6;HEALTH LEVEL SEVEN;**126,132,134**;Oct 13, 1995;Build 30 + ;Per VHA Directive 2004-038, this routine should not be modified. + ; +INQUE(FROM,QNAME,IEN778,ACTION,PURGE) ; + ;Will place the message=IEN778 on the IN queue, incoming + ;Input: + ; FROM - sending facility from message header. + ; For actions other than incoming messages, its the specified link. + ; QNAME - queue named by the application + ; IEN778 = ien of the message in file 778 + ; ACTION - that should be executed for the application + ; PURGE (optional) - PURGE=1 indicates that the purge dt/tm needs to be set by the infiler + ; If PURGE("ACKTOIEN") is set, it indicates that the purge dt/tm of + ; the original message to this application ack also needs to be set. + ;Output: none + ; + I $G(FROM)="" S FROM="UNKNOWN" + I '$L($G(QNAME)) S QNAME="DEFAULT" + S ^HLB("QUEUE","IN",FROM,QNAME,IEN778)=ACTION_"^"_$G(PURGE)_"^"_$G(PURGE("ACKTOIEN")) + I $$INC^HLOSITE($NA(^HLC("QUEUECOUNT","IN",FROM,QNAME))) + Q + ; +OUTQUE(LINKNAME,PORT,QNAME,IEN778) ; + ;Will place the message=IEN778 on the out-going queue + ;Input: + ; LINKNAME = name of (.01) the logical link + ; PORT (optional) the port to connect to + ; QNAME - queue named by the application + ; IEN778 = ien of the message in file 778 + ;Output: none + ; + N SUB + S SUB=LINKNAME + I PORT S SUB=SUB_":"_PORT + I '$L($G(QNAME)) S QNAME="DEFAULT" + S ^HLB("QUEUE","OUT",SUB,QNAME,IEN778)="" + I $$INC^HLOSITE($NA(^HLC("QUEUECOUNT","OUT",SUB,QNAME))) + Q + ; +DEQUE(FROMORTO,QNAME,DIR,IEN778) ; + ;This routine will remove the message=IEN778 from its queue + ;Input: + ; DIR = "IN" or "OUT", denoting the direction that the message is going in + ; FROMORTO = for outgoing: the .01 field of the logical link + ; for incoming: sending facility + ; IEN778 = ien of the message in file 778 + ;Output: none + ; + Q:(FROMORTO="") + I ($G(QNAME)="") S QNAME="DEFAULT" + D + .I $E(DIR)="I" S DIR="IN" Q + .I $E(DIR)="O" S DIR="OUT" Q + I DIR'="IN",DIR'="OUT" Q + Q:'$G(IEN778) + D:$D(^HLB("QUEUE",DIR,FROMORTO,QNAME,IEN778)) + .K ^HLB("QUEUE",DIR,FROMORTO,QNAME,IEN778) + .;don't let the count become negative + .I $$INC^HLOSITE($NA(^HLC("QUEUECOUNT",DIR,FROMORTO,QNAME)),-1)<0,$$INC^HLOSITE($NA(^HLC("QUEUECOUNT",DIR,FROMORTO,QNAME))) + Q + ; +STOPQUE(DIR,QUEUE) ; + ;This API is used to set a stop flag on a named queue. + ;DIR=<"IN" or "OUT"> + ;QUEUE - the name of the queue to be stopped + ; + Q:$G(DIR)="" + Q:$G(QUEUE)="" + S ^HLTMP("STOPPED QUEUES",DIR,QUEUE)=1 + Q +STARTQUE(DIR,QUEUE) ; + ;This API is used to REMOVE the stop flag on a named queue. + ;DIR=<"IN" or "OUT"> + ;QUEUE - the name of the queue to be stopped + ; + Q:$G(DIR)="" + Q:$G(QUEUE)="" + K ^HLTMP("STOPPED QUEUES",DIR,QUEUE) + Q +STOPPED(DIR,QUEUE) ; + ;This API is used to DETERMINE if the stop flag on a named queue is set. + ;Input: + ; DIR=<"IN" or "OUT"> + ; QUEUE - the name of the queue to be checked + ;Output: + ; Function returns 1 if the queue is stopped, 0 otherwise + Q:$G(DIR)="" 0 + Q:$G(QUEUE)="" 0 + I $G(^HLTMP("STOPPED QUEUES",DIR,QUEUE)) Q 1 + Q 0 diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLOSRVR.m b/r/HEALTH_LEVEL_SEVEN-HL/HLOSRVR.m index 959e4c7a..acd587a6 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLOSRVR.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLOSRVR.m @@ -1,205 +1,204 @@ -HLOSRVR ;ALB/CJM- Server for receiving messages - 10/4/94 1pm ;07/19/2007 - ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,134,137**;Oct 13, 1995;Build 21 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; -GETWORK(WORK) ; - ;GET WORK function for a single server or a Taskman multi-server - N LINK - I '$$CHKSTOP^HLOPROC,$G(WORK("LINK"))]"",$$GETLINK^HLOTLNK(WORK("LINK"),.LINK),+LINK("SERVER") S WORK("PORT")=LINK("PORT") Q 1 - Q 0 - ; -DOWORKS(WORK) ; - ;DO WORK rtn for a single server (non-concurrent) - D SERVER(WORK("LINK")) - Q -DOWORKM(WORK) ; - ;DO WORK rtn for a Taskman multi-server (Cache systems only) - D LISTEN^%ZISTCPS(WORK("PORT"),"SERVER^HLOSRVR("""_WORK("LINK")_""")") - Q - ; -VMS2(LINKNAME) ;called from a VMS TCP Service once a connection request has been received. This entry point should be used only if an additional VMS TCPIP Services are being created for HLO. - ;Input: - ; LINKNAME - only pass it in if an additional service is being created on a different port - Q:'$L(LINKNAME) - D VMS - Q - ; -VMS ;Called from VMS TCP Service once a connection request has been received. This entry point should be used only by the standard HLO service that runs on the standard HLO port. - Q:$$CHKSTOP^HLOPROC - D - .Q:$L($G(LINKNAME)) - .; - .N PROC,NODE - .S PROC=$O(^HLD(779.3,"B","VMS TCP LISTENER",0)) - .I PROC S LINKNAME=$P($G(^HLD(779.3,PROC,0)),"^",14) Q:$L(LINKNAME) - .S NODE=$G(^HLD(779.1,1,0)) I $P(NODE,"^",10) S LINKNAME=$P($G(^HLCS(870,$P(NODE,"^",10),0)),"^") Q:$L(LINKNAME) - .S LINKNAME="HLO DEFAULT LISTENER" - ; - D SERVER(LINKNAME,"SYS$NET") - Q - ; -SERVER(LINKNAME,LOGICAL) ; LINKNAME identifies the logical link, which describes the communication channel to be used - N $ETRAP,$ESTACK S $ETRAP="G ERROR^HLOSRVR1" - N HLCSTATE,INQUE - S INQUE=0 - Q:'$$CONNECT(.HLCSTATE,LINKNAME,.LOGICAL) - K LINKNAME - F Q:'HLCSTATE("CONNECTED") D Q:$$CHKSTOP^HLOPROC - .N HLMSTATE,SENT - .; - .;read msg and parse the hdr - .;HLMSTATE("MSA",1) is set with type of ack to return - .I $$READMSG^HLOSRVR1(.HLCSTATE,.HLMSTATE) D - ..; - ..;send an ack if required and save the MSA segment - ..I (HLMSTATE("MSA",1)]"") S SENT=$$WRITEACK(.HLCSTATE,.HLMSTATE) D:HLMSTATE("IEN") SAVEACK(.HLMSTATE,SENT) - ..D:HLMSTATE("IEN") UPDATE(.HLMSTATE,.HLCSTATE) - ..D:HLCSTATE("COUNTS")>4 SAVECNTS^HLOSTAT(.HLCSTATE) - ..I $G(HLMSTATE("ACK TO","IEN")),$L($G(HLMSTATE("ACK TO","SEQUENCE QUEUE"))) D ADVANCE^HLOQUE(HLMSTATE("ACK TO","SEQUENCE QUEUE"),+HLMSTATE("ACK TO","IEN")) - .E D INQUE() H:HLCSTATE("CONNECTED") 1 - ; -END D CLOSE^HLOT(.HLCSTATE) - D INQUE() - D SAVECNTS^HLOSTAT(.HLCSTATE) - Q - ; -CONNECT(HLCSTATE,LINKNAME,LOGICAL) ; - ;sets up HLCSTATE() and opens a server connection - ; - N LINK,NODE - S HLCSTATE("CONNECTED")=0 - Q:'$$GETLINK^HLOTLNK(LINKNAME,.LINK) 0 - Q:+LINK("SERVER")'=1 0 - S HLCSTATE("SERVER")=LINK("SERVER") - M HLCSTATE("LINK")=LINK - S HLCSTATE("READ TIMEOUT")=20 - S HLCSTATE("OPEN TIMEOUT")=30 - S HLCSTATE("READ")="" ;buffer for reads - ; - ;HLCSTATE("BUFFER",,) write buffer - S HLCSTATE("BUFFER","BYTE COUNT")=0 ;count of bytes in buffer - S HLCSTATE("BUFFER","SEGMENT COUNT")=0 ;count of segments in buffer - ; - S HLCSTATE("COUNTS")=0 - S HLCSTATE("MESSAGE ENDED")=0 ;end of message flag - S NODE=^%ZOSF("OS") - S HLCSTATE("SYSTEM","OS")=$S(NODE["DSM":"DSM",NODE["OpenM":"CACHE",NODE["G.TM":"G.TM",1:"") - Q:HLCSTATE("SYSTEM","OS")="" 0 - D ;get necessary system parameters - .N SYS,SUB - .D SYSPARMS^HLOSITE(.SYS) - .F SUB="MAXSTRING","DOMAIN","STATION","PROCESSING ID","NORMAL PURGE","ERROR PURGE" S HLCSTATE("SYSTEM",SUB)=SYS(SUB) - .S HLCSTATE("SYSTEM","BUFFER")=SYS("HL7 BUFFER") - I HLCSTATE("LINK","LLP")="TCP" D - .D OPEN^HLOTCP(.HLCSTATE,.LOGICAL) - E ;no other LLP implemented - ; - Q HLCSTATE("CONNECTED") - ; -INQUE(MSGIEN,PARMS) ; - ;puts received messages on the incoming queue and sets the B x-refs - I $G(MSGIEN) S INQUE=INQUE+1 M INQUE(MSGIEN)=PARMS - I ('$G(MSGIEN))!(INQUE>20) S MSGIEN=0 D - .F S MSGIEN=$O(INQUE(MSGIEN)) Q:'MSGIEN D - ..S ^HLB("B",INQUE(MSGIEN,"MSGID"),MSGIEN)="" - ..S ^HLA("B",INQUE(MSGIEN,"DT/TM"),INQUE(MSGIEN,"BODY"))="" - ..D:INQUE(MSGIEN,"PASS") - ...N PURGE - ...S PURGE=+$G(INQUE(MSGIEN,"PURGE")) - ...S PURGE("ACKTOIEN")=$G(INQUE(MSGIEN,"ACKTOIEN")) - ...D INQUE^HLOQUE(INQUE(MSGIEN,"FROM"),INQUE(MSGIEN,"QUEUE"),MSGIEN,INQUE(MSGIEN,"ACTION"),.PURGE) - .K INQUE S INQUE=0 - Q - ; -SAVEACK(HLMSTATE,SENT) ; - ;Input: - ; SENT - flag = 1 if transmission of ack succeeded, 0 otherwise - ; - N NODE,I - S $P(NODE,"^")=HLMSTATE("MSA","DT/TM OF MESSAGE") - S $P(NODE,"^",2)=HLMSTATE("MSA","MESSAGE CONTROL ID") - S $P(NODE,"^",3)="MSA" - F I=1:1:3 S NODE=NODE_"|"_$G(HLMSTATE("MSA",I)) - S ^HLB(HLMSTATE("IEN"),4)=NODE - S:SENT $P(^HLB(HLMSTATE("IEN"),0),"^",$S($E(HLMSTATE("MSA",1))="A":18,1:17))=1 - Q - ; -UPDATE(HLMSTATE,HLCSTATE) ; - ;Updates status and purge date when appropriate - ;Also, sets the "B" xrefs, files 777,778, and places message on the incoming queue - ; - N PARMS,PURGE,WAIT - S PARMS("PASS")=0 - I HLMSTATE("STATUS","ACTION")]"",HLMSTATE("STATUS")'="SE" D - .N IEN - .S IEN=HLMSTATE("IEN") - .S PARMS("PASS")=1,$P(^HLB(IEN,0),"^",6)=HLMSTATE("STATUS","QUEUE"),$P(^HLB(IEN,0),"^",10)=$P(HLMSTATE("STATUS","ACTION"),"^"),$P(^HLB(IEN,0),"^",11)=$P(HLMSTATE("STATUS","ACTION"),"^",2) - D:'PARMS("PASS") ;if not passing to the app, set the purge date - .I HLMSTATE("STATUS")="" S HLMSTATE("STATUS")="SU" - .S:HLMSTATE("BATCH") WAIT=HLCSTATE("SYSTEM","ERROR PURGE") - .S:'HLMSTATE("BATCH") WAIT=$S(($G(HLMSTATE("ACK TO","STATUS"))="ER"):24*HLCSTATE("SYSTEM","ERROR PURGE"),HLMSTATE("STATUS")="ER":24*HLCSTATE("SYSTEM","ERROR PURGE"),1:HLCSTATE("SYSTEM","NORMAL PURGE")) - .S PURGE=$$FMADD^XLFDT($$NOW^XLFDT,,WAIT) - .S $P(^HLB(HLMSTATE("IEN"),0),"^",9)=PURGE - .S ^HLB("AD","IN",PURGE,HLMSTATE("IEN"))="" - .;if this is an app ack, purge the original message at the same time - .I $G(HLMSTATE("ACK TO","IEN")),'HLMSTATE("BATCH") D - ..S $P(^HLB(+HLMSTATE("ACK TO","IEN"),0),"^",9)=PURGE - ..S ^HLB("AD","IN",PURGE,+HLMSTATE("ACK TO","IEN"))="" - ; - ;if not waiting for an application ack, set the status now even if passing to the app - but don't set the purge until the infiler passes the message - I HLMSTATE("STATUS")="",($G(HLMSTATE("ACK TO","IEN"))!HLMSTATE("HDR","APP ACK TYPE")'="AL") S HLMSTATE("STATUS")="SU" - I HLMSTATE("STATUS")'="" S $P(^HLB(HLMSTATE("IEN"),0),"^",20)=HLMSTATE("STATUS") S:$G(HLMSTATE("MSA",3))]"" $P(^HLB(HLMSTATE("IEN"),0),"^",21)=HLMSTATE("MSA",3) D:HLMSTATE("STATUS")="SE" - .N APP - .S APP=HLMSTATE("HDR","RECEIVING APPLICATION") S:APP="" APP="UNKNOWN" S ^HLB("ERRORS",APP,HLMSTATE("DT/TM"),HLMSTATE("IEN"))="" - .D COUNT^HLOESTAT("IN",$G(HLMSTATE("HDR","RECEIVING APPLICATION")),$G(HLMSTATE("HDR","SENDING APPLICATION")),$S(HLMSTATE("BATCH"):"BATCH",1:$G(HLMSTATE("HDR","MESSAGE TYPE"))),$G(HLMSTATE("HDR","EVENT"))) - ; - ;set the necessary parms for passing the msg to the app via the infiler - D:PARMS("PASS") - .N I,FROM - .S FROM=HLMSTATE("HDR","SENDING FACILITY",1) - .I HLMSTATE("HDR","SENDING FACILITY",2)]"" S FROM=FROM_"~"_HLMSTATE("HDR","SENDING FACILITY",2)_"~"_HLMSTATE("HDR","SENDING FACILITY",3) - .I FROM="" S FROM="UNKNOWN SENDING FACILITY" - .S PARMS("FROM")=FROM,PARMS("QUEUE")=HLMSTATE("STATUS","QUEUE"),PARMS("ACTION")=HLMSTATE("STATUS","ACTION") - .I HLMSTATE("STATUS")'="" S PARMS("PURGE")=$S(HLMSTATE("STATUS")="ER":2,$G(HLMSTATE("ACK TO","STATUS"))="ER":2,1:1) - .S:$G(HLMSTATE("ACK TO","IEN")) PARMS("ACKTOIEN")=HLMSTATE("ACK TO","IEN") ;to insure that the infiler will know to set the purge date at the same time as the initial message - ; - S PARMS("BODY")=HLMSTATE("BODY") - S PARMS("DT/TM")=HLMSTATE("DT/TM") - S PARMS("MSGID")=HLMSTATE("ID") - D INQUE(HLMSTATE("IEN"),.PARMS) - Q - ; -WRITEACK(HLCSTATE,HLMSTATE) ; - ;Sends an accept ack - ; - ;Input: - ; HLCSTATE (pass by reference) defines the communication channel - ; HLMSTATE (pass by reference) the message being acked - ; ("MSA",1) - value for MSA-1 - ; ("MSA",2) - value for MSA-2 - ; ("MSA",3) - value for MSA-3 - ; ("HDR") - parsed values for the message being ack'd - ;Output: - ; Function returns 1 if successful, 0 otherwise - ; HLMSTATE("MSA","MESSAGE CONTROL ID") - the msg id of the ack - ; HLMSTATE(,"MSA","DT/TM OF MESSAGE") - from the ack header - ; - N HDR,SUB,FS,CS,MSA,ACKID,TIME - ;Hard-code the delimiters, the standard requires that the receiving system accept the delimiters listed in the header - S FS="|" - S CS="^" - S TIME=$$NOW^XLFDT - S HLMSTATE("MSA","DT/TM OF MESSAGE")=TIME - S ACKID=HLCSTATE("SYSTEM","STATION")_" "_$$NEWIEN^HLOF778A("OUT") - S HLMSTATE("MSA","MESSAGE CONTROL ID")=ACKID - ; - S HDR(1)="MSH"_FS_"^~\&"_FS_HLMSTATE("HDR","RECEIVING APPLICATION")_FS_HLCSTATE("SYSTEM","STATION")_CS_HLCSTATE("SYSTEM","DOMAIN")_CS_"DNS"_FS - S HDR(1)=HDR(1)_HLMSTATE("HDR","SENDING APPLICATION")_FS_HLMSTATE("HDR","SENDING FACILITY",1)_CS_HLMSTATE("HDR","SENDING FACILITY",2)_CS_HLMSTATE("HDR","SENDING FACILITY",3) - ; - S HDR(2)=FS_$$HLDATE^HLFNC(TIME,"TS")_FS_FS_"ACK"_FS_ACKID_FS_HLMSTATE("HDR","PROCESSING ID")_FS_"2.4"_FS_FS_FS_"NE"_FS_"NE" - ; - S MSA(1)="MSA"_FS - F SUB=1:1:3 S MSA(1)=MSA(1)_HLMSTATE("MSA",SUB)_FS - I $$WRITEHDR^HLOT(.HLCSTATE,.HDR),$$WRITESEG^HLOT(.HLCSTATE,.MSA),$$ENDMSG^HLOT(.HLCSTATE) S HLCSTATE("COUNTS","ACKS")=$G(HLCSTATE("COUNTS","ACKS"))+1 Q 1 - S HLMSTATE("MSA","DT/TM OF MESSAGE")="" - Q 0 +HLOSRVR ;ALB/CJM- Server for receiving messages - 10/4/94 1pm ;03/22/2007 + ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,134**;Oct 13, 1995;Build 30 + ;Per VHA Directive 2004-038, this routine should not be modified. + ; +GETWORK(WORK) ; + ;GET WORK function for a single server or a Taskman multi-server + N LINK + I '$$CHKSTOP^HLOPROC,$G(WORK("LINK"))]"",$$GETLINK^HLOTLNK(WORK("LINK"),.LINK),+LINK("SERVER") S WORK("PORT")=LINK("PORT") Q 1 + Q 0 + ; +DOWORKS(WORK) ; + ;DO WORK rtn for a single server (non-concurrent) + D SERVER(WORK("LINK")) + Q +DOWORKM(WORK) ; + ;DO WORK rtn for a Taskman multi-server (Cache systems only) + D LISTEN^%ZISTCPS(WORK("PORT"),"SERVER^HLOSRVR("""_WORK("LINK")_""")") + Q + ; +VMS2(LINKNAME) ;called from a VMS TCP Service once a connection request has been received. This entry point should be used only if an additional VMS TCPIP Services are being created for HLO. + ;Input: + ; LINKNAME - only pass it in if an additional service is being created on a different port + Q:'$L(LINKNAME) + D VMS + Q + ; +VMS ;Called from VMS TCP Service once a connection request has been received. This entry point should be used only by the standard HLO service that runs on the standard HLO port. + Q:$$CHKSTOP^HLOPROC + D + .Q:$L($G(LINKNAME)) + .; + .N PROC,NODE + .S PROC=$O(^HLD(779.3,"B","VMS TCP LISTENER",0)) + .I PROC S LINKNAME=$P($G(^HLD(779.3,PROC,0)),"^",14) Q:$L(LINKNAME) + .S NODE=$G(^HLD(779.1,1,0)) I $P(NODE,"^",10) S LINKNAME=$P($G(^HLCS(870,$P(NODE,"^",10),0)),"^") Q:$L(LINKNAME) + .S LINKNAME="HLO DEFAULT LISTENER" + ; + D SERVER(LINKNAME,"SYS$NET") + Q + ; +SERVER(LINKNAME,LOGICAL) ; LINKNAME identifies the logical link, which describes the communication channel to be used + N $ETRAP,$ESTACK S $ETRAP="G ERROR^HLOSRVR1" + N HLCSTATE,INQUE + S INQUE=0 + Q:'$$CONNECT(.HLCSTATE,LINKNAME,.LOGICAL) + K LINKNAME + F Q:'HLCSTATE("CONNECTED") D Q:$$CHKSTOP^HLOPROC + .N HLMSTATE,SENT + .; + .;read msg and parse the hdr + .;HLMSTATE("MSA",1) is set with type of ack to return + .I $$READMSG^HLOSRVR1(.HLCSTATE,.HLMSTATE) D + ..; + ..;send an ack if required and save the MSA segment + ..I (HLMSTATE("MSA",1)]"") S SENT=$$WRITEACK(.HLCSTATE,.HLMSTATE) D:HLMSTATE("IEN") SAVEACK(.HLMSTATE,SENT) + ..D:HLMSTATE("IEN") UPDATE(.HLMSTATE,.HLCSTATE) + ..D:HLCSTATE("COUNTS")>4 SAVECNTS^HLOSTAT(.HLCSTATE) + .E D INQUE() H:HLCSTATE("CONNECTED") 1 + ; +END D CLOSE^HLOT(.HLCSTATE) + D INQUE() + D SAVECNTS^HLOSTAT(.HLCSTATE) + Q + ; +CONNECT(HLCSTATE,LINKNAME,LOGICAL) ; + ;sets up HLCSTATE() and opens a server connection + ; + N LINK,NODE + S HLCSTATE("CONNECTED")=0 + Q:'$$GETLINK^HLOTLNK(LINKNAME,.LINK) 0 + Q:+LINK("SERVER")'=1 0 + S HLCSTATE("SERVER")=LINK("SERVER") + M HLCSTATE("LINK")=LINK + S HLCSTATE("READ TIMEOUT")=20 + S HLCSTATE("OPEN TIMEOUT")=30 + S HLCSTATE("READ")="" ;buffer for reads + ; + ;HLCSTATE("BUFFER",,) write buffer + S HLCSTATE("BUFFER","BYTE COUNT")=0 ;count of bytes in buffer + S HLCSTATE("BUFFER","SEGMENT COUNT")=0 ;count of segments in buffer + ; + S HLCSTATE("COUNTS")=0 + S HLCSTATE("MESSAGE ENDED")=0 ;end of message flag + S NODE=^%ZOSF("OS") + S HLCSTATE("SYSTEM","OS")=$S(NODE["DSM":"DSM",NODE["OpenM":"CACHE",NODE["G.TM":"G.TM",1:"") + Q:HLCSTATE("SYSTEM","OS")="" 0 + D ;get necessary system parameters + .N SYS,SUB + .D SYSPARMS^HLOSITE(.SYS) + .F SUB="MAXSTRING","DOMAIN","STATION","PROCESSING ID","NORMAL PURGE","ERROR PURGE" S HLCSTATE("SYSTEM",SUB)=SYS(SUB) + .S HLCSTATE("SYSTEM","BUFFER")=SYS("HL7 BUFFER") + I HLCSTATE("LINK","LLP")="TCP" D + .D OPEN^HLOTCP(.HLCSTATE,.LOGICAL) + E ;no other LLP implemented + ; + Q HLCSTATE("CONNECTED") + ; +INQUE(MSGIEN,PARMS) ; + ;puts received messages on the incoming queue and sets the B x-refs + I $G(MSGIEN) S INQUE=INQUE+1 M INQUE(MSGIEN)=PARMS + I ('$G(MSGIEN))!(INQUE>20) S MSGIEN=0 D + .F S MSGIEN=$O(INQUE(MSGIEN)) Q:'MSGIEN D + ..S ^HLB("B",INQUE(MSGIEN,"MSGID"),MSGIEN)="" + ..S ^HLA("B",INQUE(MSGIEN,"DT/TM"),INQUE(MSGIEN,"BODY"))="" + ..D:INQUE(MSGIEN,"PASS") + ...N PURGE + ...S PURGE=+$G(INQUE(MSGIEN,"PURGE")) + ...S PURGE("ACKTOIEN")=$G(INQUE(MSGIEN,"ACKTOIEN")) + ...D INQUE^HLOQUE(INQUE(MSGIEN,"FROM"),INQUE(MSGIEN,"QUEUE"),MSGIEN,INQUE(MSGIEN,"ACTION"),.PURGE) + .K INQUE S INQUE=0 + Q + ; +SAVEACK(HLMSTATE,SENT) ; + ;Input: + ; SENT - flag = 1 if transmission of ack succeeded, 0 otherwise + ; + N NODE,I + S $P(NODE,"^")=HLMSTATE("MSA","DT/TM OF MESSAGE") + S $P(NODE,"^",2)=HLMSTATE("MSA","MESSAGE CONTROL ID") + S $P(NODE,"^",3)="MSA" + F I=1:1:3 S NODE=NODE_"|"_$G(HLMSTATE("MSA",I)) + S ^HLB(HLMSTATE("IEN"),4)=NODE + S:SENT $P(^HLB(HLMSTATE("IEN"),0),"^",$S($E(HLMSTATE("MSA",1))="A":18,1:17))=1 + Q + ; +UPDATE(HLMSTATE,HLCSTATE) ; + ;Updates status and purge date when appropriate + ;Also, sets the "B" xrefs, files 777,778, and places message on the incoming queue + ; + N PARMS,PURGE,WAIT + S PARMS("PASS")=0 + I HLMSTATE("STATUS","ACTION")]"",HLMSTATE("STATUS")'="SE" D + .N IEN + .S IEN=HLMSTATE("IEN") + .S PARMS("PASS")=1,$P(^HLB(IEN,0),"^",6)=HLMSTATE("STATUS","QUEUE"),$P(^HLB(IEN,0),"^",10)=$P(HLMSTATE("STATUS","ACTION"),"^"),$P(^HLB(IEN,0),"^",11)=$P(HLMSTATE("STATUS","ACTION"),"^",2) + D:'PARMS("PASS") ;if not passing to the app, set the purge date + .I HLMSTATE("STATUS")="" S HLMSTATE("STATUS")="SU" + .S:HLMSTATE("BATCH") WAIT=HLCSTATE("SYSTEM","ERROR PURGE") + .S:'HLMSTATE("BATCH") WAIT=$S(($G(HLMSTATE("ACK TO","STATUS"))="AE"):24*HLCSTATE("SYSTEM","ERROR PURGE"),HLMSTATE("STATUS")="SE":24*HLCSTATE("SYSTEM","ERROR PURGE"),1:HLCSTATE("SYSTEM","NORMAL PURGE")) + .S PURGE=$$FMADD^XLFDT($$NOW^XLFDT,,WAIT) + .S $P(^HLB(HLMSTATE("IEN"),0),"^",9)=PURGE + .S ^HLB("AD","IN",PURGE,HLMSTATE("IEN"))="" + .;if this is an app ack, purge the original message at the same time + .I $G(HLMSTATE("ACK TO","IEN")),'HLMSTATE("BATCH") D + ..S $P(^HLB(+HLMSTATE("ACK TO","IEN"),0),"^",9)=PURGE + ..S ^HLB("AD","IN",PURGE,+HLMSTATE("ACK TO","IEN"))="" + ; + ;if not waiting for an application ack, set the status now even if passing to the app - but don't set the purge until the infiler passes the message + I HLMSTATE("STATUS")="",($G(HLMSTATE("ACK TO","IEN"))!HLMSTATE("HDR","APP ACK TYPE")'="AL") S HLMSTATE("STATUS")="SU" + I HLMSTATE("STATUS")'="" S $P(^HLB(HLMSTATE("IEN"),0),"^",20)=HLMSTATE("STATUS") S:$G(HLMSTATE("MSA",3))]"" $P(^HLB(HLMSTATE("IEN"),0),"^",21)=HLMSTATE("MSA",3) D:HLMSTATE("STATUS")="SE" + .N APP + .S APP=HLMSTATE("HDR","RECEIVING APPLICATION") S:APP="" APP="UNKNOWN" S ^HLB("ERRORS","SE",APP,HLMSTATE("DT/TM"),HLMSTATE("IEN"))="" + .D COUNT^HLOESTAT("IN",$G(HLMSTATE("HDR","RECEIVING APPLICATION")),$G(HLMSTATE("HDR","SENDING APPLICATION")),$S(HLMSTATE("BATCH"):"BATCH",1:$G(HLMSTATE("HDR","MESSAGE TYPE"))),$G(HLMSTATE("HDR","EVENT"))) + ; + ;set the necessary parms for passing the msg to the app via the infiler + D:PARMS("PASS") + .N I,FROM + .S FROM=HLMSTATE("HDR","SENDING FACILITY",1) + .I HLMSTATE("HDR","SENDING FACILITY",2)]"" S FROM=FROM_"~"_HLMSTATE("HDR","SENDING FACILITY",2)_"~"_HLMSTATE("HDR","SENDING FACILITY",3) + .I FROM="" S FROM="UNKNOWN SENDING FACILITY" + .S PARMS("FROM")=FROM,PARMS("QUEUE")=HLMSTATE("STATUS","QUEUE"),PARMS("ACTION")=HLMSTATE("STATUS","ACTION") + .I HLMSTATE("STATUS")'="" S PARMS("PURGE")=$S(HLMSTATE("STATUS")'="SU":2,$G(HLMSTATE("ACK TO","STATUS"))="AE":2,1:1) + .S:$G(HLMSTATE("ACK TO","IEN")) PARMS("ACKTOIEN")=HLMSTATE("ACK TO","IEN") ;to insure that the infiler will know to set the purge date at the same time as the initial message + ; + S PARMS("BODY")=HLMSTATE("BODY") + S PARMS("DT/TM")=HLMSTATE("DT/TM") + S PARMS("MSGID")=HLMSTATE("ID") + D INQUE(HLMSTATE("IEN"),.PARMS) + Q + ; +WRITEACK(HLCSTATE,HLMSTATE) ; + ;Sends an accept ack + ; + ;Input: + ; HLCSTATE (pass by reference) defines the communication channel + ; HLMSTATE (pass by reference) the message being acked + ; ("MSA",1) - value for MSA-1 + ; ("MSA",2) - value for MSA-2 + ; ("MSA",3) - value for MSA-3 + ; ("HDR") - parsed values for the message being ack'd + ;Output: + ; Function returns 1 if successful, 0 otherwise + ; HLMSTATE("MSA","MESSAGE CONTROL ID") - the msg id of the ack + ; HLMSTATE(,"MSA","DT/TM OF MESSAGE") - from the ack header + ; + N HDR,SUB,FS,CS,MSA,ACKID,TIME + ;Hard-code the delimiters, the standard requires that the receiving system accept the delimiters listed in the header + S FS="|" + S CS="^" + S TIME=$$NOW^XLFDT + S HLMSTATE("MSA","DT/TM OF MESSAGE")=TIME + S ACKID=HLCSTATE("SYSTEM","STATION")_" "_$$NEWIEN^HLOF778A("OUT") + S HLMSTATE("MSA","MESSAGE CONTROL ID")=ACKID + ; + S HDR(1)="MSH"_FS_"^~\&"_FS_HLMSTATE("HDR","RECEIVING APPLICATION")_FS_HLCSTATE("SYSTEM","STATION")_CS_HLCSTATE("SYSTEM","DOMAIN")_CS_"DNS"_FS + S HDR(1)=HDR(1)_HLMSTATE("HDR","SENDING APPLICATION")_FS_HLMSTATE("HDR","SENDING FACILITY",1)_CS_HLMSTATE("HDR","SENDING FACILITY",2)_CS_HLMSTATE("HDR","SENDING FACILITY",3) + ; + S HDR(2)=FS_$$HLDATE^HLFNC(TIME,"TS")_FS_FS_"ACK"_FS_ACKID_FS_HLMSTATE("HDR","PROCESSING ID")_FS_"2.4"_FS_FS_FS_"NE"_FS_"NE" + ; + S MSA(1)="MSA"_FS + F SUB=1:1:3 S MSA(1)=MSA(1)_HLMSTATE("MSA",SUB)_FS + I $$WRITEHDR^HLOT(.HLCSTATE,.HDR),$$WRITESEG^HLOT(.HLCSTATE,.MSA),$$ENDMSG^HLOT(.HLCSTATE) S HLCSTATE("COUNTS","ACKS")=$G(HLCSTATE("COUNTS","ACKS"))+1 Q 1 + S HLMSTATE("MSA","DT/TM OF MESSAGE")="" + Q 0 diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLOSRVR1.m b/r/HEALTH_LEVEL_SEVEN-HL/HLOSRVR1.m index 2fab73b6..074a1176 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLOSRVR1.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLOSRVR1.m @@ -1,236 +1,235 @@ -HLOSRVR1 ;IRMFO-ALB/CJM - Reading messages, sending acks;03/24/2004 14:43 ;07/17/2007 - ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,133,134,137**;Oct 13, 1995;Build 21 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; -READMSG(HLCSTATE,HLMSTATE) ; - ;Reads a message. The header is parsed. Does these checks: - ; 1) Duplicate? - ; 2) Wrong Receiving Facility? - ; 3) Can the Receiving App accept this message, based message type & event? - ; 4) Processing ID must match the receiving system - ; 5) Must have an ID - ; 6) Header must be BHS or MSH - ; - ;Output: - ; Function returns 1 if the message was read fully, 0 otherwise - ; HLMSTATE (pass by reference) the message. It will include the fields for the return ack in HLMSTATE("MSA") - ; - N ACK,SEG,STORE,I - ; - S STORE=1 - Q:'$$READHDR^HLOT(.HLCSTATE,.SEG) 0 - D SPLITHDR(.SEG) - ; - ;parse the header, stop if unsuccessful because the server cannot know what to do next - I '$$PARSEHDR^HLOPRS(.SEG) D Q 0 - .S HLCSTATE("MESSAGE ENDED")=0 - .D CLOSE^HLOT(.HLCSTATE) - D NEWMSG^HLOSRVR2(.HLCSTATE,.HLMSTATE,.SEG) - I HLMSTATE("ID")="" D - .S STORE=0 - .I HLMSTATE("HDR","ACCEPT ACK TYPE")="AL" S HLMSTATE("MSA",1)="CE",HLMSTATE("MSA",3)="CONTROL ID MISSING" - I STORE,$$DUP(.HLMSTATE) S STORE=0 - ; - ;if the message is not to be stored, just read it and discard the segments - I 'STORE D - .F Q:'$$READSEG^HLOT(.HLCSTATE,.SEG) - ; - E D - .N FS - .S FS=HLMSTATE("HDR","FIELD SEPARATOR") - .F Q:'$$READSEG^HLOT(.HLCSTATE,.SEG) D - ..N MSA,SEGTYPE,OLDMSGID,CODE,IEN,NEWMSGID,TEXT - ..S SEGTYPE=$E($E(SEG(1),1,3)_$E($G(SEG(2)),1,2),1,3) - ..I SEGTYPE="MSA" D - ...S MSA=SEG(1)_$G(SEG(2))_$G(SEG(3)) - ...S OLDMSGID=$P(MSA,FS,3),CODE=$P(MSA,FS,2),TEXT=$E($P(MSA,FS,4),1,30) - ...I $E(CODE,1)'="A" S SEGTYPE="" Q - ...S:$P(OLDMSGID,"-")]"" IEN=$O(^HLB("B",$P(OLDMSGID,"-"),0)) - ...S:$G(IEN) IEN=IEN_"^"_$P(OLDMSGID,"-",2) - ..I 'HLMSTATE("BATCH") D - ...D:SEGTYPE="MSA" - ....S HLMSTATE("ACK TO")=OLDMSGID - ....S HLMSTATE("ACK TO","ACK BY")=HLMSTATE("ID") - ....S HLMSTATE("ACK TO","STATUS")=$S(CODE="AA":"SU",1:"ER") - ....I $G(IEN) D - .....S HLMSTATE("ACK TO","IEN")=IEN - .....S HLMSTATE("ACK TO","SEQUENCE QUEUE")=$P($G(^HLB(+IEN,5)),"^") - ....S HLMSTATE("ACK TO","ERROR TEXT")=TEXT - ...D ADDSEG^HLOMSG(.HLMSTATE,.SEG) - ..E D ;batch - ...I SEGTYPE="MSH" D - ....D SPLITHDR(.SEG) - ....S NEWMSGID=$P(SEG(2),FS,5) - ....D ADDMSG2^HLOMSG(.HLMSTATE,.SEG) - ...E D ;not MSH - ....D:SEGTYPE="MSA" - .....N SUBIEN S SUBIEN=HLMSTATE("BATCH","CURRENT MESSAGE") - .....S HLMSTATE("BATCH","ACK TO",SUBIEN)=OLDMSGID - .....S HLMSTATE("BATCH","ACK TO",SUBIEN,"ACK BY")=NEWMSGID - .....S HLMSTATE("BATCH","ACK TO",SUBIEN,"STATUS")=$S(CODE="AA":"SU",1:"ER") - .....S:$D(IEN) HLMSTATE("BATCH","ACK TO",SUBIEN,"IEN")=IEN - ....D ADDSEG^HLOMSG(.HLMSTATE,.SEG) - .I HLMSTATE("UNSTORED LINES"),HLCSTATE("MESSAGE ENDED"),$$SAVEMSG^HLOF778(.HLMSTATE) - ; - I STORE,'HLCSTATE("MESSAGE ENDED") D - .;reading failed, don't store - .D:HLMSTATE("IEN") DEL778(HLMSTATE("IEN")) D:HLMSTATE("BODY") DEL777(HLMSTATE("BODY")) - .S HLMSTATE("IEN")="",HLMSTATE("BODY")="" - E D:STORE - .D CHECKMSG(.HLMSTATE) - .D ADDAC(.HLMSTATE) ;so future duplicates are detected - .D COUNT^HLOSTAT(.HLCSTATE,HLMSTATE("HDR","RECEIVING APPLICATION"),HLMSTATE("HDR","SENDING APPLICATION"),$S(HLMSTATE("BATCH"):"BATCH",1:HLMSTATE("HDR","MESSAGE TYPE")_"~"_HLMSTATE("HDR","EVENT"))) - ; - D:'HLCSTATE("MESSAGE ENDED") CLOSE^HLOT(.HLCSTATE) - Q HLCSTATE("MESSAGE ENDED") - ; -ADDAC(HLMSTATE) ;adds the AC xref for duplicates detection - ; - N FROM - S FROM=$S(HLMSTATE("HDR","SENDING FACILITY",2)]"":HLMSTATE("HDR","SENDING FACILITY",2),1:HLMSTATE("HDR","SENDING FACILITY",1)) - S ^HLB("AC",FROM_HLMSTATE("HDR","SENDING APPLICATION")_HLMSTATE("ID"),HLMSTATE("IEN"))="" - Q - ; -DUP(HLMSTATE) ; - ;Returns 1 if the message is a duplicate and its ack (if requested) is found, 0 otherwise - ;Input: - ; HLMSTATE (pass by reference) the message being read - ;Output: - ; Function returns 1 if the message is a duplicate, 0 otherwise - ; HLMSTATE (pass by reference) IF the message is a duplicate: - ; returns the prior MSA segment in HLMSTATE("MSA") - ; - N IEN,FROM,DUP - S (IEN,DUP)=0 - ; - ;no way to determine! Bad header will be rejected - Q:(HLMSTATE("ID")="") 0 - ; - S FROM=$S(HLMSTATE("HDR","SENDING FACILITY",2)]"":HLMSTATE("HDR","SENDING FACILITY",2),1:HLMSTATE("HDR","SENDING FACILITY",1)) - F S IEN=$O(^HLB("AC",FROM_HLMSTATE("HDR","SENDING APPLICATION")_HLMSTATE("ID"),IEN)) Q:'IEN D Q:DUP - .I HLMSTATE("HDR","ACCEPT ACK TYPE")="NE" S DUP=1 Q - .;need the MSA to return - .D Q - ..N NODE - ..S NODE=$P($G(^HLB(IEN,4)),"^",3,10) - ..S HLMSTATE("MSA",1)=$P(NODE,"|",2) - ..Q:$L(HLMSTATE("MSA",1))'=2 - ..S HLMSTATE("MSA",2)=$P(NODE,"|",3) - ..S HLMSTATE("MSA",3)=$P(NODE,"|",4,10) - ..S DUP=1 - ; - Q DUP - ; -CHECKMSG(HLMSTATE) ; - ;Checks the header & MSA segment, sets HLMSTATE("STATUS","ACTION") if the message needs to be passed, determines if completion status should be set - ;Input: - ; HLMSTATE("HDR") - the parsed header segment - ;Output: - ; HLMSTATE("STATUS")="ER" if an error is detected - ; HLMSTATE("STATUS","QUEUE") queue to put the message on - ; HLMSTATE("STATUS","ACTION") that is the processing routine for the receiving application - ; HLMSTATE("MSA") - MSA(1)=accept code to be returned, MSA(3)= error txt - ; - N WANTACK,PASS,ACTION,QUEUE,ERROR - M HDR=HLMSTATE("HDR") - S ERROR=0 - I HDR("ACCEPT ACK TYPE")="NE",'HLMSTATE("ORIGINAL MODE") D - .S WANTACK=0 - E D - .S WANTACK=1 - I HLMSTATE("ORIGINAL MODE") S HLMSTATE("MSA",1)="AE",HLMSTATE("MSA",3)="THIS INTERFACE DOES NOT IMPLEMENT ORIGINAL MODE APPLICATION ACKOWLEDGMENTS",HLMSTATE("STATUS")="ER" Q - I $G(HLMSTATE("ACK TO"))="" D Q:ERROR - .I '$$ACTION^HLOAPP(.HDR,.ACTION,.QUEUE) S ERROR=1 S:WANTACK HLMSTATE("MSA",1)="CR" S HLMSTATE("MSA",3)="RECEIVING APPLICATION NOT DEFINED",HLMSTATE("STATUS")="ER" Q - .S HLMSTATE("STATUS","ACTION")=$G(ACTION),HLMSTATE("STATUS","QUEUE")=$G(QUEUE) - E D Q:ERROR ;this is an app ack - .;does the original message exist? - .N NODE - .S:+$G(HLMSTATE("ACK TO","IEN")) NODE=$G(^HLB(+HLMSTATE("ACK TO","IEN"),0)) - .I $G(NODE)="" S ERROR=1,HLMSTATE("STATUS")="ER",HLMSTATE("ACK TO","IEN")="" S:WANTACK HLMSTATE("MSA",1)="CE" S HLMSTATE("MSA",3)="INITIAL MESSAGE TO APPLICATION ACKNOWLEDGMENT NOT FOUND" Q - .I $P(NODE,"^",7)'="",$P(NODE,"^",7)'=HLMSTATE("ID") S ERROR=1,HLMSTATE("STATUS")="ER",HLMSTATE("ACK TO","IEN")="" S:WANTACK HLMSTATE("MSA",1)="CE" S HLMSTATE("MSA",3)="INITIAL MESSAGE WAS ALREADY ACKED" Q - .I ($P(NODE,"^",11)]"") S HLMSTATE("STATUS","ACTION")=$P(NODE,"^",10,11),HLMSTATE("STATUS","QUEUE")=$S($P(NODE,"^",6)]"":$P(NODE,"^",6),1:"DEFAULT") Q - .;processing routine for the app ack wasn't found with the original message, look in the HLO Application Registry - .I HLMSTATE("HDR","MESSAGE TYPE")="ACK",HLMSTATE("HDR","EVENT")="" S HDR("EVENT")=$$GETEVENT^HLOCLNT2(+HLMSTATE("ACK TO","IEN")) - .I $$ACTION^HLOAPP(.HDR,.ACTION,.QUEUE) S HLMSTATE("STATUS","ACTION")=$G(ACTION),HLMSTATE("STATUS","QUEUE")=$G(QUEUE) - ; - I HDR("PROCESSING ID")'=HLCSTATE("SYSTEM","PROCESSING ID") S:WANTACK HLMSTATE("MSA",1)="CR" S HLMSTATE("STATUS")="ER",HLMSTATE("MSA",3)="SYSTEM PROCESSING ID="_HLCSTATE("SYSTEM","PROCESSING ID") Q - ; - ;wrong receiving facility? This is hard to check if the sender is not VistA, because the HL7 standard permits different coding systems to be used. This check is only for DNS or station number. - S PASS=0 - D - .;if its an ack to an existing message, don't check the receiving facility - .I $G(HLMSTATE("ACK TO"))]"" S PASS=1 Q - .I HDR("RECEIVING FACILITY",1)=HLCSTATE("SYSTEM","STATION") S PASS=1 Q - .I HDR("RECEIVING FACILITY",3)'="DNS" S PASS=1 Q - .I HDR("RECEIVING FACILITY",2)="" S PASS=1 Q - .I $P(HDR("RECEIVING FACILITY",2),":")[HLCSTATE("SYSTEM","DOMAIN") S PASS=1 Q - .I HLCSTATE("SYSTEM","DOMAIN")[$P(HDR("RECEIVING FACILITY",2),":") S PASS=1 Q - I 'PASS S HLMSTATE("STATUS")="ER",HLMSTATE("MSA",3)="RECEIVING FACILITY IS "_HLCSTATE("SYSTEM","DOMAIN") S:WANTACK HLMSTATE("MSA",1)="CE" - I PASS,WANTACK S HLMSTATE("MSA",1)="CA" - Q - ; -DEL777(IEN777) ;delete a record from file 777 where the read did not complete - ; - K ^HLA(IEN777,0) - Q -DEL778(IEN778) ;delete a record from file 778 where the read did not complete - ; - K ^HLB(IEN778,0) - Q - ; -SPLITHDR(HDR) ; - ;splits hdr segment into two lines, first being just components 1-6 - ; - N TEMP,FS - D SQUISH(.HDR) - S FS=$E($G(HDR(1)),4) - S TEMP(1)=$P($G(HDR(1)),FS,1,6) - S TEMP(2)="" - I $L(TEMP(1))<$L($G(HDR(1))) S TEMP(2)=FS_$P($G(HDR(1)),FS,7,20) - S HDR(2)=TEMP(2)_$G(HDR(2)) - S HDR(1)=TEMP(1) - Q - ; -SQUISH(SEG) ; - ;reformat the segment array into full lines - ; - ;nothing to do if less than 2 lines - Q:'$O(SEG(1)) - ; - N A,I,J,K,MAX,COUNT,LEN - S MAX=$S($G(HLCSTATE("SYSTEM","MAXSTRING"))>256:HLCSTATE("SYSTEM","MAXSTRING"),1:256) - S (COUNT,I)=0,J=1 - F S I=$O(SEG(I)) Q:'I D - .S LEN=$L(SEG(I)) - .F K=1:1:LEN D - ..S A(J)=$G(A(J))_$E(SEG(I),K) - ..S COUNT=COUNT+1 - ..I (COUNT>(MAX-1)) S COUNT=0,J=J+1 - K SEG - M SEG=A - Q - ; -ERROR ;error trap - S $ETRAP="Q:$QUIT """" Q" - D END^HLOSRVR - ; - ;multi-listener should stop execution, only a single server may continue - I $P($G(HLCSTATE("LINK","SERVER")),"^",2)'="S" D Q:$QUIT "" Q - .;don't log these errors - .I ($ECODE["READ")!($ECODE["NOTOPEN")!($ECODE["DEVNOTOPN")!($ECODE["WRITE")!($ECODE["OPENERR") D - ..; - .E D - ..D ^%ZTER - ; - ;debugging? - I $G(^HLTMP("LOG ALL ERRORS"))!($ECODE["EDITED") Q:$QUIT "" Q - ; - ;possibly an endless loop? - N HOUR - S HOUR=$E($$NOW^XLFDT,1,10) - I ($G(^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2)))>30) Q:$QUIT "" Q - ; - ;resume execution for the single listener - S ^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2))=$G(^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2)))+1 - D UNWIND^%ZTER - Q +HLOSRVR1 ;IRMFO-ALB/CJM - Reading messages, sending acks;03/24/2004 14:43 ;03/26/2007 + ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,133,134**;Oct 13, 1995;Build 30 + ;Per VHA Directive 2004-038, this routine should not be modified. + ; +READMSG(HLCSTATE,HLMSTATE) ; + ;Reads a message. The header is parsed. Does these checks: + ; 1) Duplicate? + ; 2) Wrong Receiving Facility? + ; 3) Can the Receiving App accept this message, based message type & event? + ; 4) Processing ID must match the receiving system + ; 5) Must have an ID + ; 6) Header must be BHS or MSH + ; + ;Output: + ; Function returns 1 if the message was read fully, 0 otherwise + ; HLMSTATE (pass by reference) the message. It will include the fields for the return ack in HLMSTATE("MSA") + ; + N ACK,SEG,STORE,I + ; + S STORE=1 + Q:'$$READHDR^HLOT(.HLCSTATE,.SEG) 0 + D SPLITHDR(.SEG) + ; + ;parse the header, stop if unsuccessful because the server cannot know what to do next + I '$$PARSEHDR^HLOPRS(.SEG) D Q 0 + .S HLCSTATE("MESSAGE ENDED")=0 + .D CLOSE^HLOT(.HLCSTATE) + D NEWMSG^HLOSRVR2(.HLCSTATE,.HLMSTATE,.SEG) + I HLMSTATE("ID")="" D + .S STORE=0 + .I HLMSTATE("HDR","ACCEPT ACK TYPE")="AL" S HLMSTATE("MSA",1)="CE",HLMSTATE("MSA",3)="CONTROL ID MISSING" + I STORE,$$DUP(.HLMSTATE) S STORE=0 + ; + ;if the message is not to be stored, just read it and discard the segments + I 'STORE D + .F Q:'$$READSEG^HLOT(.HLCSTATE,.SEG) + ; + E D + .N FS + .S FS=HLMSTATE("HDR","FIELD SEPARATOR") + .F Q:'$$READSEG^HLOT(.HLCSTATE,.SEG) D + ..N MSA,SEGTYPE,OLDMSGID,CODE,IEN,NEWMSGID,TEXT + ..S SEGTYPE=$E($E(SEG(1),1,3)_$E($G(SEG(2)),1,2),1,3) + ..I SEGTYPE="MSA" D + ...S MSA=SEG(1)_$G(SEG(2))_$G(SEG(3)) + ...S OLDMSGID=$P(MSA,FS,3),CODE=$P(MSA,FS,2),TEXT=$E($P(MSA,FS,4),1,30) + ...I $E(CODE,1)'="A" S SEGTYPE="" Q + ...S:$P(OLDMSGID,"-")]"" IEN=$O(^HLB("B",$P(OLDMSGID,"-"),0)) + ...S:$G(IEN) IEN=IEN_"^"_$P(OLDMSGID,"-",2) + ..I 'HLMSTATE("BATCH") D + ...D:SEGTYPE="MSA" + ....S HLMSTATE("ACK TO")=OLDMSGID + ....S HLMSTATE("ACK TO","ACK BY")=HLMSTATE("ID") + ....S HLMSTATE("ACK TO","STATUS")=$S(CODE="AA":"SU",1:"AE") + ....S:$D(IEN) HLMSTATE("ACK TO","IEN")=IEN + ....S HLMSTATE("ACK TO","ERROR TEXT")=TEXT + ...D ADDSEG^HLOMSG(.HLMSTATE,.SEG) + ..E D ;batch + ...I SEGTYPE="MSH" D + ....D SPLITHDR(.SEG) + ....S NEWMSGID=$P(SEG(2),FS,5) + ....D ADDMSG2^HLOMSG(.HLMSTATE,.SEG) + ...E D ;not MSH + ....D:SEGTYPE="MSA" + .....N SUBIEN S SUBIEN=HLMSTATE("BATCH","CURRENT MESSAGE") + .....S HLMSTATE("BATCH","ACK TO",SUBIEN)=OLDMSGID + .....S HLMSTATE("BATCH","ACK TO",SUBIEN,"ACK BY")=NEWMSGID + .....S HLMSTATE("BATCH","ACK TO",SUBIEN,"STATUS")=$S(CODE="AA":"SU",1:"AE") + .....S:$D(IEN) HLMSTATE("BATCH","ACK TO",SUBIEN,"IEN")=IEN + ....D ADDSEG^HLOMSG(.HLMSTATE,.SEG) + .I HLMSTATE("UNSTORED LINES"),HLCSTATE("MESSAGE ENDED"),$$SAVEMSG^HLOF778(.HLMSTATE) + ; + I STORE,'HLCSTATE("MESSAGE ENDED") D + .;reading failed, don't store + .D:HLMSTATE("IEN") DEL778(HLMSTATE("IEN")) D:HLMSTATE("BODY") DEL777(HLMSTATE("BODY")) + .S HLMSTATE("IEN")="",HLMSTATE("BODY")="" + E D:STORE + .D CHECKMSG(.HLMSTATE) + .D ADDAC(.HLMSTATE) ;so future duplicates are detected + .D COUNT^HLOSTAT(.HLCSTATE,HLMSTATE("HDR","RECEIVING APPLICATION"),HLMSTATE("HDR","SENDING APPLICATION"),$S(HLMSTATE("BATCH"):"BATCH",1:HLMSTATE("HDR","MESSAGE TYPE")_"~"_HLMSTATE("HDR","EVENT"))) + ; + D:'HLCSTATE("MESSAGE ENDED") CLOSE^HLOT(.HLCSTATE) + Q HLCSTATE("MESSAGE ENDED") + ; +ADDAC(HLMSTATE) ;adds the AC xref for duplicates detection + ; + N FROM + S FROM=$S(HLMSTATE("HDR","SENDING FACILITY",2)]"":HLMSTATE("HDR","SENDING FACILITY",2),1:HLMSTATE("HDR","SENDING FACILITY",1)) + S ^HLB("AC",FROM_HLMSTATE("HDR","SENDING APPLICATION")_HLMSTATE("ID"),HLMSTATE("IEN"))="" + Q + ; +DUP(HLMSTATE) ; + ;Returns 1 if the message is a duplicate and its ack (if requested) is found, 0 otherwise + ;Input: + ; HLMSTATE (pass by reference) the message being read + ;Output: + ; Function returns 1 if the message is a duplicate, 0 otherwise + ; HLMSTATE (pass by reference) IF the message is a duplicate: + ; returns the prior MSA segment in HLMSTATE("MSA") + ; + N IEN,FROM,DUP + S (IEN,DUP)=0 + ; + ;no way to determine! Bad header will be rejected + Q:(HLMSTATE("ID")="") 0 + ; + S FROM=$S(HLMSTATE("HDR","SENDING FACILITY",2)]"":HLMSTATE("HDR","SENDING FACILITY",2),1:HLMSTATE("HDR","SENDING FACILITY",1)) + F S IEN=$O(^HLB("AC",FROM_HLMSTATE("HDR","SENDING APPLICATION")_HLMSTATE("ID"),IEN)) Q:'IEN D Q:DUP + .I HLMSTATE("HDR","ACCEPT ACK TYPE")="NE" S DUP=1 Q + .;need the MSA to return + .D Q + ..N NODE + ..S NODE=$P($G(^HLB(IEN,4)),"^",3,10) + ..S HLMSTATE("MSA",1)=$P(NODE,"|",2) + ..Q:$L(HLMSTATE("MSA",1))'=2 + ..S HLMSTATE("MSA",2)=$P(NODE,"|",3) + ..S HLMSTATE("MSA",3)=$P(NODE,"|",4,10) + ..S DUP=1 + ; + Q DUP + ; +CHECKMSG(HLMSTATE) ; + ;Checks the header & MSA segment, sets HLMSTATE("STATUS","ACTION") if the message needs to be passed, determines if completion status should be set + ;Input: + ; HLMSTATE("HDR") - the parsed header segment + ;Output: + ; HLMSTATE("STATUS")="SE" if an error is detected + ; HLMSTATE("STATUS","QUEUE") queue to put the message on + ; HLMSTATE("STATUS","ACTION") that is the processing routine for the receiving application + ; HLMSTATE("MSA") - MSA(1)=accept code to be returned, MSA(3)= error txt + ; + N WANTACK,PASS,ACTION,QUEUE,ERROR + M HDR=HLMSTATE("HDR") + S ERROR=0 + I HDR("ACCEPT ACK TYPE")="NE",'HLMSTATE("ORIGINAL MODE") D + .S WANTACK=0 + E D + .S WANTACK=1 + I HLMSTATE("ORIGINAL MODE") S HLMSTATE("MSA",1)="AE",HLMSTATE("MSA",3)="THIS INTERFACE DOES NOT IMPLEMENT ORIGINAL MODE APPLICATION ACKOWLEDGMENTS",HLMSTATE("STATUS")="SE" Q + I $G(HLMSTATE("ACK TO"))="" D Q:ERROR + .I '$$ACTION^HLOAPP(.HDR,.ACTION,.QUEUE) S ERROR=1 S:WANTACK HLMSTATE("MSA",1)="CR" S HLMSTATE("MSA",3)="RECEIVING APPLICATION NOT DEFINED",HLMSTATE("STATUS")="SE" Q + .S HLMSTATE("STATUS","ACTION")=$G(ACTION),HLMSTATE("STATUS","QUEUE")=$G(QUEUE) + E D Q:ERROR ;this is an app ack + .;does the original message exist? + .N NODE + .S:+$G(HLMSTATE("ACK TO","IEN")) NODE=$G(^HLB(+HLMSTATE("ACK TO","IEN"),0)) + .I $G(NODE)="" S ERROR=1,HLMSTATE("STATUS")="SE",HLMSTATE("ACK TO","IEN")="" S:WANTACK HLMSTATE("MSA",1)="CE" S HLMSTATE("MSA",3)="INITIAL MESSAGE TO APPLICATION ACKNOWLEDGMENT NOT FOUND" Q + .I $P(NODE,"^",7)'="",$P(NODE,"^",7)'=HLMSTATE("ID") S ERROR=1,HLMSTATE("STATUS")="SE",HLMSTATE("ACK TO","IEN")="" S:WANTACK HLMSTATE("MSA",1)="CE" S HLMSTATE("MSA",3)="INITIAL MESSAGE WAS ALREADY ACKED" Q + .I ($P(NODE,"^",11)]"") S HLMSTATE("STATUS","ACTION")=$P(NODE,"^",10,11),HLMSTATE("STATUS","QUEUE")=$S($P(NODE,"^",6)]"":$P(NODE,"^",6),1:"DEFAULT") Q + .;processing routine for the app ack wasn't found with the original message, look in the HLO Application Registry + .I HLMSTATE("HDR","MESSAGE TYPE")="ACK",HLMSTATE("HDR","EVENT")="" S HDR("EVENT")=$$GETEVENT^HLOCLNT2(+HLMSTATE("ACK TO","IEN")) + .I $$ACTION^HLOAPP(.HDR,.ACTION,.QUEUE) S HLMSTATE("STATUS","ACTION")=$G(ACTION),HLMSTATE("STATUS","QUEUE")=$G(QUEUE) + ; + I HDR("PROCESSING ID")'=HLCSTATE("SYSTEM","PROCESSING ID") S:WANTACK HLMSTATE("MSA",1)="CR" S HLMSTATE("STATUS")="SE",HLMSTATE("MSA",3)="SYSTEM PROCESSING ID="_HLCSTATE("SYSTEM","PROCESSING ID") Q + ; + ;wrong receiving facility? This is hard to check if the sender is not VistA, because the HL7 standard permits different coding systems to be used. This check is only for DNS or station number. + S PASS=0 + D + .;if its an ack to an existing message, don't check the receiving facility + .I $G(HLMSTATE("ACK TO"))]"" S PASS=1 Q + .I HDR("RECEIVING FACILITY",1)=HLCSTATE("SYSTEM","STATION") S PASS=1 Q + .I HDR("RECEIVING FACILITY",3)'="DNS" S PASS=1 Q + .I HDR("RECEIVING FACILITY",2)="" S PASS=1 Q + .I $P(HDR("RECEIVING FACILITY",2),":")[HLCSTATE("SYSTEM","DOMAIN") S PASS=1 Q + .I HLCSTATE("SYSTEM","DOMAIN")[$P(HDR("RECEIVING FACILITY",2),":") S PASS=1 Q + I 'PASS S HLMSTATE("STATUS")="SE",HLMSTATE("MSA",3)="RECEIVING FACILITY IS "_HLCSTATE("SYSTEM","DOMAIN") S:WANTACK HLMSTATE("MSA",1)="CE" + I PASS,WANTACK S HLMSTATE("MSA",1)="CA" + Q + ; +DEL777(IEN777) ;delete a record from file 777 where the read did not complete + ; + K ^HLA(IEN777,0) + Q +DEL778(IEN778) ;delete a record from file 778 where the read did not complete + ; + K ^HLB(IEN778,0) + Q + ; +SPLITHDR(HDR) ; + ;splits hdr segment into two lines, first being just components 1-6 + ; + N TEMP,FS + D SQUISH(.HDR) + S FS=$E($G(HDR(1)),4) + S TEMP(1)=$P($G(HDR(1)),FS,1,6) + S TEMP(2)="" + I $L(TEMP(1))<$L($G(HDR(1))) S TEMP(2)=FS_$P($G(HDR(1)),FS,7,20) + S HDR(2)=TEMP(2)_$G(HDR(2)) + S HDR(1)=TEMP(1) + Q + ; +SQUISH(SEG) ; + ;reformat the segment array into full lines + ; + ;nothing to do if less than 2 lines + Q:'$O(SEG(1)) + ; + N A,I,J,K,MAX,COUNT,LEN + S MAX=$S($G(HLCSTATE("SYSTEM","MAXSTRING"))>256:HLCSTATE("SYSTEM","MAXSTRING"),1:256) + S (COUNT,I)=0,J=1 + F S I=$O(SEG(I)) Q:'I D + .S LEN=$L(SEG(I)) + .F K=1:1:LEN D + ..S A(J)=$G(A(J))_$E(SEG(I),K) + ..S COUNT=COUNT+1 + ..I (COUNT>(MAX-1)) S COUNT=0,J=J+1 + K SEG + M SEG=A + Q + ; +ERROR ;error trap + S $ETRAP="Q:$QUIT """" Q" + D END^HLOSRVR + ; + ;concurrent server connections (multi-listener) should stop execution, only a single server may continue + I $P($G(HLCSTATE("LINK","SERVER")),"^",2)'="S" D Q:$QUIT "" Q + .;don't log these common errors + .I ($ECODE["READ")!($ECODE["NOTOPEN")!($ECODE["DEVNOTOPN")!($ECODE["WRITE")!($ECODE["OPENERR") D + ..; + .E D + ..D ^%ZTER + ; + ;while debugging quit on all errors + I $G(^HLTMP("LOG ALL ERRORS"))!($ECODE["EDITED") Q:$QUIT "" Q + ; + ;a lot of errors of the same time may indicate an endless loop, so keep a count and quit if large count + N HOUR + S HOUR=$E($$NOW^XLFDT,1,10) + ; + I ($G(^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2)))>30) Q:$QUIT "" Q + ; + ;resume execution for the single listener + S ^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2))=$G(^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2)))+1 + D UNWIND^%ZTER + Q diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLOSRVR2.m b/r/HEALTH_LEVEL_SEVEN-HL/HLOSRVR2.m index 611706f4..7f937503 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLOSRVR2.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLOSRVR2.m @@ -1,50 +1,93 @@ -HLOSRVR2 ;ALB/CJM-HL7 - HLO Server ;07/20/2007 - ;;1.6;HEALTH LEVEL SEVEN;**131,137**;Oct 13, 1995;Build 21 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; -NEWMSG(HLCSTATE,HLMSTATE,HDR) ; - ;initialize the HLMSTATE array after reading the header - ;Inputs: - ; HLCSTATE (pass by reference) - ; HDR (pass by reference) parsed header - ;Output: - ; HLMSTATE (pass by reference) - ; - K HLMSTATE - S HLMSTATE("IEN")="" - S HLMSTATE("BODY")="" - S HLMSTATE("DIRECTION")="IN" - S HLMSTATE("CURRENT SEGMENT")=0 ;no segments in cache - S HLMSTATE("UNSTORED LINES")=1 ;just the header in cache so far - S HLMSTATE("LINE COUNT")=0 ;no lines within message stored to disk - I HDR("SEGMENT TYPE")="BHS" D - .S HLMSTATE("BATCH")=1 - .S HLMSTATE("ID")=HDR("BATCH CONTROL ID") - .S HLMSTATE("BATCH","CURRENT MESSAGE")=0 ;no messages in batch - .S HLMSTATE("UNSTORED MSH")=0 - E D - .S HLMSTATE("BATCH")=0 - .S HLMSTATE("ID")=HDR("MESSAGE CONTROL ID") - M HLMSTATE("HDR")=HDR - M HLMSTATE("SYSTEM")=HLCSTATE("SYSTEM") - S HLMSTATE("STATUS")="" - S HLMSTATE("STATUS","QUEUE")="" - S HLMSTATE("STATUS","ACTION")="" - S HLMSTATE("STATUS","LINK NAME")=HLCSTATE("LINK","NAME") - S HLMSTATE("STATUS","PORT")=$P(HDR("SENDING FACILITY",2),":",2) - ; - ;if this is a batch, and it references another batch, assume it is a b. - I HLMSTATE("BATCH"),HLMSTATE("ID")]"" D - .N IEN - .S HLMSTATE("ACK TO")=HLMSTATE("ID") - .S HLMSTATE("ACK TO","STATUS")="SU" - .S IEN=$O(^HLB("B",HLMSTATE("ID"),0)) - .I IEN S HLMSTATE("ACK TO","IEN")=IEN_"^" - E S HLMSTATE("ACK TO")="" - I 'HLMSTATE("BATCH"),HDR("ACCEPT ACK TYPE")="",HDR("APP ACK TYPE")="" D - .S HLMSTATE("ORIGINAL MODE")=1 - E D - .S HLMSTATE("ORIGINAL MODE")=0 - N I F I=1,3 S HLMSTATE("MSA",I)="" - S HLMSTATE("MSA",2)=HLMSTATE("ID") - Q +HLOSRVR2 ;ALB/CJM-HL7 - Sends an application ack over an open connection, for original mode ;02/04/2004 + ;;1.6;HEALTH LEVEL SEVEN;**131**;Oct 13, 1995;Build 10 + ; +NEWMSG(HLCSTATE,HLMSTATE,HDR) ; + ;initialize the HLMSTATE array after reading the header + ;Inputs: + ; HLCSTATE (pass by reference) + ; HDR (pass by reference) parsed header + ;Output: + ; HLMSTATE (pass by reference) + ; + K HLMSTATE + S HLMSTATE("IEN")="" + S HLMSTATE("BODY")="" + S HLMSTATE("DIRECTION")="IN" + S HLMSTATE("CURRENT SEGMENT")=0 ;no segments in cache + S HLMSTATE("UNSTORED LINES")=1 ;just the header in cache so far + S HLMSTATE("LINE COUNT")=0 ;no lines within message stored to disk + I HDR("SEGMENT TYPE")="BHS" D + .S HLMSTATE("BATCH")=1 + .S HLMSTATE("ID")=HDR("BATCH CONTROL ID") + .S HLMSTATE("BATCH","CURRENT MESSAGE")=0 ;no messages in batch + .S HLMSTATE("UNSTORED MSH")=0 + E D + .S HLMSTATE("BATCH")=0 + .S HLMSTATE("ID")=HDR("MESSAGE CONTROL ID") + M HLMSTATE("HDR")=HDR + M HLMSTATE("SYSTEM")=HLCSTATE("SYSTEM") + S HLMSTATE("STATUS")="" + S HLMSTATE("STATUS","QUEUE")="" + S HLMSTATE("STATUS","ACTION")="" + S HLMSTATE("STATUS","LINK NAME")=HLCSTATE("LINK","NAME") + S HLMSTATE("STATUS","PORT")=$P(HDR("SENDING FACILITY",2),":",2) + ; + ;if this is a batch, and it references another batch, assume it is a b. + I HLMSTATE("BATCH"),HLMSTATE("ID")]"" D + .N IEN + .S HLMSTATE("ACK TO")=HLMSTATE("ID") + .S HLMSTATE("ACK TO","STATUS")="SU" + .S IEN=$O(^HLB("B",HLMSTATE("ID"),0)) + .I IEN S HLMSTATE("ACK TO","IEN")=IEN_"^" + E S HLMSTATE("ACK TO")="" + I 'HLMSTATE("BATCH"),HDR("ACCEPT ACK TYPE")="",HDR("APP ACK TYPE")="" D + .S HLMSTATE("ORIGINAL MODE")=1 + E D + .S HLMSTATE("ORIGINAL MODE")=0 + N I F I=1,3 S HLMSTATE("MSA",I)="" + S HLMSTATE("MSA",2)=HLMSTATE("ID") + Q + ; +ACKNOW(MSG,ERROR) ; + ;Sends the messge immediately if there is an open connection, otherwise + ;will return an error. + ; + N $ETRAP,$ESTACK S $ETRAP="G ERROR^HLOSRVR2" + N SENT + S SENT=0,ERROR="" + I '$G(HLCSTATE("CONNECTED")) D + .S ERROR="NOT CONNECTED" + .S MSG("STATUS")="TF" + E S MSG("STATUS")="SU" + S:'$G(MSG("DT/TM CREATED")) MSG("DT/TM CREATED")=$$NOW^XLFDT + S MSG("STATUS","PURGE")=$$FMADD^XLFDT(MSG("DT/TM CREATED"),$S($G(HLCSTATE("ERROR PURGE")):HLCSTATE("ERROR PURGE"),1:7)) + D + .I $G(MSG("UNSTORED LINES")),'$$SAVEMSG^HLOF777(.MSG) S ERROR="$$SAVE^HLOF777 FAILED!" Q + .I '$$SAVEMSG^HLOF778(.MSG) S ERROR="$$SAVE^HLOF778 FAILED!" Q + .Q:MSG("STATUS")'="SU" + .I '$$WRITEMSG^HLOCLNT1(.HLCSTATE,.MSG) S ERROR="TRANSMISSION FAILURE" Q + .S SENT=1 + .D COUNT^HLOSTAT(.HLCSTATE,ACK("HDR","RECEIVING APPLICATION"),ACK("HDR","SENDING APPLICATION"),ACK("HDR","MESSAGE TYPE")_"~"_ACK("HDR","EVENT")) + ; +END ; + I 'SENT,MSG("STATUS")="SU",$G(MSG("IEN")) D + .Q:'$D(^HLB(MSG("IEN"),0)) + .S MSG("STATUS")="TF" + .S MSG("STATUS","ERROR TEXT")=ERROR + .S $P(^HLB(MSG("IEN"),0),"^",20)=MSG("STATUS") + .S $P(^HLB(MSG("IEN"),0),"^",21)=MSG("STATUS","ERROR TEXT") + .S ^HLB("ERRORS","TF",$S($L($G(MSG("HDR","RECEIVING APPLICATION"))):MSG("HDR","RECEIVING APPLICATION"),1:"UNKNOWN"),MSG("DT/TM CREATED"),IEN)="" + ; + Q SENT + ; +ERROR ;error trap for ACKNOW + S SENT=0,ERROR="TRANSMISSION FAILURE:"_$P($ECODE,",",1,2) + S $ETRAP="D UNWIND^%ZTER" + ; + ;don't log some common errors + I ($ECODE["READ")!($ECODE["NOTOPEN")!($ECODE["DEVNOTOPN")!($ECODE["WRITE")!($ECODE["OPENERR") D + .;nothing! + E D + .D ^%ZTER + G END^HLOSRVR2 + Q diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLOTCP.m b/r/HEALTH_LEVEL_SEVEN-HL/HLOTCP.m index b2793af5..7837c458 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLOTCP.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLOTCP.m @@ -1,206 +1,206 @@ -HLOTCP ;ALB/CJM- TCP/IP I/O - 10/4/94 1pm ;07/10/2007 - ;;1.6;HEALTH LEVEL SEVEN;**126,131,134,137**;Oct 13, 1995;Build 21 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; -OPEN(HLCSTATE,LOGICAL) ; - ;This may be called either in the context of a client or a server. - ;For the server, there are 3 situations: - ; 1) The server is not concurrent. In this case the TCP device should be opened. - ; 2) The server is concurrent, but this process was spawned by the OS - ; (via a VMS TCP Service) In this case, the device should be opened - ; via the LOGICAL that was passed in. - ; 3) The server is concurrent, but this process was spawned by the - ; TaskMan multi-listener. In this case TaskMan already opened the - ; device. This case can be determined by the absence of the LOGICAL - ; input parameter. - ; - N IP,PORT,DNSFLAG - ; - S DNSFLAG=0 ;DNS has not been contacted for IP - ; - S:'$G(HLCSTATE("SERVER")) IP=HLCSTATE("LINK","IP") - S PORT=HLCSTATE("LINK","PORT") - S HLCSTATE("CONNECTED")=0 - S HLCSTATE("READ HEADER")="READHDR^HLOTCP" - S HLCSTATE("WRITE HEADER")="WRITEHDR^HLOTCP" - S HLCSTATE("READ SEGMENT")="READSEG^HLOTCP" - S HLCSTATE("WRITE SEGMENT")="WRITESEG^HLOTCP" - S HLCSTATE("END MESSAGE")="ENDMSG^HLOTCP" - S HLCSTATE("CLOSE")="CLOSE^HLOTCP" - ; - ;spawned by TaskMan multi-listener? If so, the device has already been opened - I $G(HLCSTATE("SERVER")),$G(HLCSTATE("LINK","SERVER"))="1^M",$G(LOGICAL)="" D Q - .S HLCSTATE("DEVICE")=IO(0),HLCSTATE("FLUSH")="!",HLCSTATE("TCP BUFFER SIZE")=510 - .S HLCSTATE("CONNECTED")=1 - ; - ;if no IP, not a server, give DNS a shot - I '$G(HLCSTATE("SERVER")),IP="" S DNSFLAG=1,IP=$$DNS(HLCSTATE("LINK","DOMAIN")),HLCSTATE("LINK","IP")=IP Q:IP="" - ; -RETRY I HLCSTATE("SYSTEM","OS")="DSM" D - .S HLCSTATE("TCP BUFFER SIZE")=512 - .I $G(LOGICAL)]"" S HLCSTATE("DEVICE")=LOGICAL - .E S HLCSTATE("DEVICE")=PORT - .S HLCSTATE("FLUSH")="!" - .I $G(HLCSTATE("SERVER")) D - ..O:$G(LOGICAL)]"" HLCSTATE("DEVICE"):(TCPDEV,BLOCKSIZE=512):HLCSTATE("OPEN TIMEOUT") - ..O:$G(LOGICAL)="" HLCSTATE("DEVICE"):(TCPCHAN,BLOCKSIZE=512):HLCSTATE("OPEN TIMEOUT") - ..I $T D - ...S HLCSTATE("CONNECTED")=1 - ...U HLCSTATE("DEVICE"):NOECHO - .E D ;client - ..O HLCSTATE("DEVICE"):(TCPCHAN,ADDRESS=IP,BLOCKSIZE=512):HLCSTATE("OPEN TIMEOUT") - ..I $T D - ...S HLCSTATE("CONNECTED")=1 - ...U HLCSTATE("DEVICE"):NOECHO - E I HLCSTATE("SYSTEM","OS")="CACHE" D - .S HLCSTATE("FLUSH")="!" - .I $G(LOGICAL)]"" S HLCSTATE("DEVICE")=LOGICAL - .E S HLCSTATE("DEVICE")="|TCP|"_PORT - .S HLCSTATE("TCP BUFFER SIZE")=510 - .I $G(HLCSTATE("SERVER")) D - ..I HLCSTATE("SERVER")="1^S" D Q - ...;single server (no concurrent connections) - ...O HLCSTATE("DEVICE"):(:PORT:"+A-S":::):HLCSTATE("OPEN TIMEOUT") - ...I $T D - ....N A - ....S HLCSTATE("CONNECTED")=1 - ....U HLCSTATE("DEVICE") - ....F R *A:HLCSTATE("READ TIMEOUT") Q:$T I $$CHKSTOP^HLOPROC S HLCSTATE("CONNECTED")=0 D CLOSE(.HLCSTATE) Q - ..; - ..;multi-server spawned by OS - VMS TCP Services - ..O HLCSTATE("DEVICE")::HLCSTATE("OPEN TIMEOUT") I '$T S HLCSTATE("CONNECTED")=0 Q - ..S HLCSTATE("CONNECTED")=1 - ..U HLCSTATE("DEVICE"):(::"-S") - ..; - .E D ;client - ..S HLCSTATE("TCP BUFFER SIZE")=510 - ..O HLCSTATE("DEVICE"):(IP:PORT:"-S":::):HLCSTATE("OPEN TIMEOUT") - ..I $T D - ...S HLCSTATE("CONNECTED")=1 - E D ;any other system but Cache or DSM - .S HLCSTATE("TCP BUFFER SIZE")=256 - .D CALL^%ZISTCP(IP,PORT,HLCSTATE("OPEN TIMEOUT")) - .S HLCSTATE("CONNECTED")='POP - .I HLCSTATE("CONNECTED") S HLCSTATE("DEVICE")=IO - ; - ;if not connected, not the server, give DNS a shot if not tried already - I '$G(HLCSTATE("SERVER")),'HLCSTATE("CONNECTED"),'DNSFLAG S DNSFLAG=1,IP=$$DNS(HLCSTATE("LINK","DOMAIN")) I IP]"",IP'=HLCSTATE("LINK","IP") S HLCSTATE("LINK","IP")=IP G RETRY - I HLCSTATE("CONNECTED"),DNSFLAG S $P(^HLCS(870,HLCSTATE("LINK","IEN"),400),"^")=IP - Q - ; -DNS(DOMAIN) ; - Q $P($$ADDRESS^XLFNSLK(DOMAIN),",") - ; -WRITEHDR(HLCSTATE,HDR) ; - ; - ;insure that package buffer is empty - K HLCSTATE("BUFFER") - S HLCSTATE("BUFFER","BYTE COUNT")=0 - S HLCSTATE("BUFFER","SEGMENT COUNT")=0 - S HLCSTATE("FIRST WRITE")=1 ;so that FLUSH knows $X should be 0 - ; - ;Start the message with , then write the header - N SEG - S SEG(1)=$C(11)_HDR(1) - S SEG(2)=HDR(2) - Q $$WRITESEG(.HLCSTATE,.SEG) - ; -WRITESEG(HLCSTATE,SEG) ; - N I,LAST - S HLCSTATE("BUFFER","SEGMENT COUNT")=HLCSTATE("BUFFER","SEGMENT COUNT")+1 - S I=0,LAST=$O(SEG(99999),-1) - F S I=$O(SEG(I)) Q:'I D - .I HLCSTATE("BUFFER","BYTE COUNT")>HLCSTATE("SYSTEM","BUFFER") D FLUSH - .I I=LAST S SEG(I)=SEG(I)_$C(13) - .S HLCSTATE("BUFFER",HLCSTATE("BUFFER","SEGMENT COUNT"),I)=SEG(I),HLCSTATE("BUFFER","BYTE COUNT")=HLCSTATE("BUFFER","BYTE COUNT")+$L(SEG(I))+20 - Q HLCSTATE("CONNECTED") - ; -FLUSH ;flushes the HL7 package buffer, and the system TCP buffer when full - N SEGMENT,MAX - S SEGMENT=0 - S MAX=HLCSTATE("TCP BUFFER SIZE") - U HLCSTATE("DEVICE") I (HLCSTATE("SYSTEM","OS")="CACHE") S HLCSTATE("CONNECTED")=($ZA\8192#2) I 'HLCSTATE("CONNECTED") D CLOSE(.HLCSTATE) - F S SEGMENT=$O(HLCSTATE("BUFFER",SEGMENT)) Q:'SEGMENT D - .N I S I=0 - .F S I=$O(HLCSTATE("BUFFER",SEGMENT,I)) Q:'I D - ..N LINE,J - ..S J=$S(HLCSTATE("FIRST WRITE"):0,1:$X) - ..S HLCSTATE("FIRST WRITE")=0 - ..S LINE=HLCSTATE("BUFFER",SEGMENT,I) - ..F Q:'(J+$L(LINE)>MAX) D - ...W $E(LINE,1,MAX-J),@HLCSTATE("FLUSH") S HLCSTATE("FLUSHED")=1 - ...S LINE=$E(LINE,(MAX-J)+1,99999) - ...S J=0 - ..I (LINE]"") W LINE S HLCSTATE("FLUSHED")=0 - K HLCSTATE("BUFFER") - S HLCSTATE("BUFFER","SEGMENT COUNT")=1 - S HLCSTATE("BUFFER","BYTE COUNT")=0 - S HLCSTATE("FIRST WRITE")=0 - Q - ; -READSEG(HLCSTATE,SEG) ; - ; - ;Output: - ; SEG - returns the segment (pass by reference) - ; Function returns 1 on success, 0 on failure - ; - N SUCCESS,COUNT,BUF - S (COUNT,SUCCESS)=0 - K SEG - ; - ;anything left from last read? - S BUF=HLCSTATE("READ") - S HLCSTATE("READ")="" - I BUF]"" D ;something was left! - .S COUNT=1 - .I BUF[$C(13) D Q - ..S SEG(1)=$P(BUF,$C(13)),BUF=$P(BUF,$C(13),2,9999) - ..S SUCCESS=1 - .S SEG(1)=BUF,BUF="" - I 'SUCCESS U HLCSTATE("DEVICE") F R BUF:HLCSTATE("READ TIMEOUT") Q:'$T D Q:SUCCESS - .I BUF[$C(13) S SUCCESS=1,COUNT=COUNT+1,SEG(COUNT)=$P(BUF,$C(13)),BUF=$P(BUF,$C(13),2,9999) Q - .S COUNT=COUNT+1,SEG(COUNT)=BUF - ; - I SUCCESS D - .S HLCSTATE("READ")=BUF ;save the leftover - .I COUNT>1,SEG(COUNT)="" K SEG(COUNT) S COUNT=COUNT-1 - ;Cache can return the connection status - E I (HLCSTATE("SYSTEM","OS")="CACHE") S HLCSTATE("CONNECTED")=($ZA\8192#2) I 'HLCSTATE("CONNECTED") D CLOSE(.HLCSTATE) - ; - ;if the character was encountered, then there are no more segments in the message, set the end of message flag - I SUCCESS,SEG(COUNT)[$C(28) D - .K SEG - .S SUCCESS=0 - .S HLCSTATE("MESSAGE ENDED")=1 - Q SUCCESS - ; -READHDR(HLCSTATE,HDR) ; - ;reads the next header segment in the message stream, discarding everything that comes before it - ; - N SEG,SUCCESS,J,I - S SUCCESS=0 - K HDR - F Q:'$$READSEG(.HLCSTATE,.SEG) D Q:SUCCESS - .S I=0 - .;look for the - .;perhaps the isn't in the first line - .F S I=$O(SEG(I)) Q:'I D Q:SUCCESS - ..I (SEG(I)'[$C(11)) K SEG(I) Q - ..S SEG(I)=$P(SEG(I),$C(11),2) - ..S SUCCESS=1 - ..K:SEG(I)="" SEG(I) - I SUCCESS S (I,J)=0 F S J=$O(SEG(J)) Q:'J S I=I+1,HDR(I)=SEG(J) - Q SUCCESS - ; -CLOSE(HLCSTATE) ; - CLOSE HLCSTATE("DEVICE") - Q - ; -ENDMSG(HLCSTATE) ; - N SEG - S SEG(1)=$C(28) - I $$WRITESEG(.HLCSTATE,.SEG) D Q 1 - .D FLUSH - .U HLCSTATE("DEVICE") - .I ('$G(HLCSTATE("FLUSHED")))!$X W @HLCSTATE("FLUSH") S HLCSTATE("FLUSHED")=1 - Q 0 +HLOTCP ;ALB/CJM- TCP/IP I/O - 10/4/94 1pm ;03/22/2007 + ;;1.6;HEALTH LEVEL SEVEN;**126,131,134**;Oct 13, 1995;Build 30 + ;Per VHA Directive 2004-038, this routine should not be modified. + ; +OPEN(HLCSTATE,LOGICAL) ; + ;This may be called either in the context of a client or a server. + ;For the server, there are 3 situations: + ; 1) The server is not concurrent. In this case the TCP device should be opened. + ; 2) The server is concurrent, but this process was spawned by the OS + ; (via a VMS TCP Service) In this case, the device should be opened + ; via the LOGICAL that was passed in. + ; 3) The server is concurrent, but this process was spawned by the + ; TaskMan multi-listener. In this case TaskMan already opened the + ; device. This case can be determined by the absence of the LOGICAL + ; input parameter. + ; + N IP,PORT,DNSFLAG + ; + S DNSFLAG=0 ;DNS has not been contacted for IP + ; + S:'$G(HLCSTATE("SERVER")) IP=HLCSTATE("LINK","IP") + S PORT=HLCSTATE("LINK","PORT") + S HLCSTATE("CONNECTED")=0 + S HLCSTATE("READ HEADER")="READHDR^HLOTCP" + S HLCSTATE("WRITE HEADER")="WRITEHDR^HLOTCP" + S HLCSTATE("READ SEGMENT")="READSEG^HLOTCP" + S HLCSTATE("WRITE SEGMENT")="WRITESEG^HLOTCP" + S HLCSTATE("END MESSAGE")="ENDMSG^HLOTCP" + S HLCSTATE("CLOSE")="CLOSE^HLOTCP" + ; + ;spawned by TaskMan multi-listener? If so, the device has already been opened + I $G(HLCSTATE("SERVER")),$G(HLCSTATE("LINK","SERVER"))="1^M",$G(LOGICAL)="" D Q + .S HLCSTATE("DEVICE")=IO(0),HLCSTATE("FLUSH")="!",HLCSTATE("TCP BUFFER SIZE")=510 + .S HLCSTATE("CONNECTED")=1 + ; + ;if no IP, not a server, give DNS a shot + I '$G(HLCSTATE("SERVER")),IP="" S DNSFLAG=1,IP=$$DNS(HLCSTATE("LINK","DOMAIN")),HLCSTATE("LINK","IP")=IP Q:IP="" + ; +RETRY I HLCSTATE("SYSTEM","OS")="DSM" D + .S HLCSTATE("TCP BUFFER SIZE")=512 + .I $G(LOGICAL)]"" S HLCSTATE("DEVICE")=LOGICAL + .E S HLCSTATE("DEVICE")=PORT + .S HLCSTATE("FLUSH")="!" + .I $G(HLCSTATE("SERVER")) D + ..O:$G(LOGICAL)]"" HLCSTATE("DEVICE"):(TCPDEV,BLOCKSIZE=512):HLCSTATE("OPEN TIMEOUT") + ..O:$G(LOGICAL)="" HLCSTATE("DEVICE"):(TCPCHAN,BLOCKSIZE=512):HLCSTATE("OPEN TIMEOUT") + ..I $T D + ...S HLCSTATE("CONNECTED")=1 + ...U HLCSTATE("DEVICE"):NOECHO + .E D ;client + ..O HLCSTATE("DEVICE"):(TCPCHAN,ADDRESS=IP,BLOCKSIZE=512):HLCSTATE("OPEN TIMEOUT") + ..I $T D + ...S HLCSTATE("CONNECTED")=1 + ...U HLCSTATE("DEVICE"):NOECHO + E I HLCSTATE("SYSTEM","OS")="CACHE" D + .S HLCSTATE("FLUSH")="!" + .I $G(LOGICAL)]"" S HLCSTATE("DEVICE")=LOGICAL + .E S HLCSTATE("DEVICE")="|TCP|"_PORT + .S HLCSTATE("TCP BUFFER SIZE")=510 + .I $G(HLCSTATE("SERVER")) D + ..I HLCSTATE("SERVER")="1^S" D Q + ...;single server (no concurrent connections) + ...O HLCSTATE("DEVICE"):(:PORT:"+A-S":::):HLCSTATE("OPEN TIMEOUT") + ...I $T D + ....N A + ....S HLCSTATE("CONNECTED")=1 + ....U HLCSTATE("DEVICE") + ....F R *A:HLCSTATE("READ TIMEOUT") Q:$T I $$CHKSTOP^HLOPROC S HLCSTATE("CONNECTED")=0 D CLOSE(.HLCSTATE) Q + ..; + ..;multi-server spawned by OS - VMS TCP Services + ..O HLCSTATE("DEVICE")::HLCSTATE("OPEN TIMEOUT") I '$T S HLCSTATE("CONNECTED")=0 Q + ..S HLCSTATE("CONNECTED")=1 + ..U HLCSTATE("DEVICE"):(::"-S") + ..; + .E D ;client + ..S HLCSTATE("TCP BUFFER SIZE")=510 + ..O HLCSTATE("DEVICE"):(IP:PORT:"-S":::):HLCSTATE("OPEN TIMEOUT") + ..I $T D + ...S HLCSTATE("CONNECTED")=1 + E D ;any other system but Cache or DSM + .S HLCSTATE("TCP BUFFER SIZE")=256 + .D CALL^%ZISTCP(IP,PORT,HLCSTATE("OPEN TIMEOUT")) + .S HLCSTATE("CONNECTED")='POP + .I HLCSTATE("CONNECTED") S HLCSTATE("DEVICE")=IO + ; + ;if not connected, not the server, give DNS a shot if not tried already + I '$G(HLCSTATE("SERVER")),'HLCSTATE("CONNECTED"),'DNSFLAG S DNSFLAG=1,IP=$$DNS(HLCSTATE("LINK","DOMAIN")) I IP]"",IP'=HLCSTATE("LINK","IP") S HLCSTATE("LINK","IP")=IP G RETRY + I HLCSTATE("CONNECTED"),DNSFLAG S $P(^HLCS(870,HLCSTATE("LINK","IEN"),400),"^")=IP + Q + ; +DNS(DOMAIN) ; + Q $P($$ADDRESS^XLFNSLK(DOMAIN),",") + ; +WRITEHDR(HLCSTATE,HDR) ; + ; + ;insure that package buffer is empty + K HLCSTATE("BUFFER") + S HLCSTATE("BUFFER","BYTE COUNT")=0 + S HLCSTATE("BUFFER","SEGMENT COUNT")=0 + S HLCSTATE("FIRST WRITE")=1 ;so that FLUSH knows $X should be 0 + ; + ;Start the message with , then write the header + N SEG + S SEG(1)=$C(11)_HDR(1) + S SEG(2)=HDR(2) + Q $$WRITESEG(.HLCSTATE,.SEG) + ; +WRITESEG(HLCSTATE,SEG) ; + N I,LAST + S HLCSTATE("BUFFER","SEGMENT COUNT")=HLCSTATE("BUFFER","SEGMENT COUNT")+1 + S I=0,LAST=$O(SEG(99999),-1) + F S I=$O(SEG(I)) Q:'I D + .I HLCSTATE("BUFFER","BYTE COUNT")>HLCSTATE("SYSTEM","BUFFER") D FLUSH + .I I=LAST S SEG(I)=SEG(I)_$C(13) + .S HLCSTATE("BUFFER",HLCSTATE("BUFFER","SEGMENT COUNT"),I)=SEG(I),HLCSTATE("BUFFER","BYTE COUNT")=HLCSTATE("BUFFER","BYTE COUNT")+$L(SEG(I))+20 + Q HLCSTATE("CONNECTED") + ; +FLUSH ;flushes the HL7 package buffer, and the system TCP buffer when full + N SEGMENT,MAX + S SEGMENT=0 + S MAX=HLCSTATE("TCP BUFFER SIZE") + U HLCSTATE("DEVICE") I (HLCSTATE("SYSTEM","OS")="CACHE") S HLCSTATE("CONNECTED")=($ZA\8192#2) I 'HLCSTATE("CONNECTED") D CLOSE(.HLCSTATE) + F S SEGMENT=$O(HLCSTATE("BUFFER",SEGMENT)) Q:'SEGMENT D + .N I S I=0 + .F S I=$O(HLCSTATE("BUFFER",SEGMENT,I)) Q:'I D + ..N LINE,J + ..S J=$S(HLCSTATE("FIRST WRITE"):0,1:$X) + ..S HLCSTATE("FIRST WRITE")=0 + ..S LINE=HLCSTATE("BUFFER",SEGMENT,I) + ..F Q:'(J+$L(LINE)>MAX) D + ...W $E(LINE,1,MAX-J),@HLCSTATE("FLUSH") + ...S LINE=$E(LINE,(MAX-J)+1,99999) + ...S J=0 + ..W:(LINE]"") LINE + K HLCSTATE("BUFFER") + S HLCSTATE("BUFFER","SEGMENT COUNT")=1 + S HLCSTATE("BUFFER","BYTE COUNT")=0 + S HLCSTATE("FIRST WRITE")=0 + Q + ; +READSEG(HLCSTATE,SEG) ; + ; + ;Output: + ; SEG - returns the segment (pass by reference) + ; Function returns 1 on success, 0 on failure + ; + N SUCCESS,COUNT,BUF + S (COUNT,SUCCESS)=0 + K SEG + ; + ;anything left from last read? + S BUF=HLCSTATE("READ") + S HLCSTATE("READ")="" + I BUF]"" D ;something was left! + .S COUNT=1 + .I BUF[$C(13) D Q + ..S SEG(1)=$P(BUF,$C(13)),BUF=$P(BUF,$C(13),2,9999) + ..S SUCCESS=1 + .S SEG(1)=BUF,BUF="" + I 'SUCCESS U HLCSTATE("DEVICE") F R BUF:HLCSTATE("READ TIMEOUT") Q:'$T D Q:SUCCESS + .I BUF[$C(13) S SUCCESS=1,COUNT=COUNT+1,SEG(COUNT)=$P(BUF,$C(13)),BUF=$P(BUF,$C(13),2,9999) Q + .S COUNT=COUNT+1,SEG(COUNT)=BUF + ; + I SUCCESS D + .S HLCSTATE("READ")=BUF ;save the leftover + .I COUNT>1,SEG(COUNT)="" K SEG(COUNT) S COUNT=COUNT-1 + ;Cache can return the connection status + E I (HLCSTATE("SYSTEM","OS")="CACHE") S HLCSTATE("CONNECTED")=($ZA\8192#2) I 'HLCSTATE("CONNECTED") D CLOSE(.HLCSTATE) + ; + ;if the character was encountered, then there are no more segments in the message, set the end of message flag + I SUCCESS,SEG(COUNT)[$C(28) D + .K SEG + .S SUCCESS=0 + .S HLCSTATE("MESSAGE ENDED")=1 + Q SUCCESS + ; +READHDR(HLCSTATE,HDR) ; + ;reads the next header segment in the message stream, discarding everything that comes before it + ; + N SEG,SUCCESS,J,I + S SUCCESS=0 + K HDR + F Q:'$$READSEG(.HLCSTATE,.SEG) D Q:SUCCESS + .S I=0 + .;look for the + .;perhaps the isn't in the first line + .F S I=$O(SEG(I)) Q:'I D Q:SUCCESS + ..I (SEG(I)'[$C(11)) K SEG(I) Q + ..S SEG(I)=$P(SEG(I),$C(11),2) + ..S SUCCESS=1 + ..K:SEG(I)="" SEG(I) + I SUCCESS S (I,J)=0 F S J=$O(SEG(J)) Q:'J S I=I+1,HDR(I)=SEG(J) + Q SUCCESS + ; +CLOSE(HLCSTATE) ; + CLOSE HLCSTATE("DEVICE") + Q + ; +ENDMSG(HLCSTATE) ; + N SEG + S SEG(1)=$C(28) + I $$WRITESEG(.HLCSTATE,.SEG) D Q 1 + .D FLUSH + .U HLCSTATE("DEVICE") + .W:$X @HLCSTATE("FLUSH") + Q 0 diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLOUSR.m b/r/HEALTH_LEVEL_SEVEN-HL/HLOUSR.m index d12da032..5d8faed7 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLOUSR.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLOUSR.m @@ -1,287 +1,282 @@ -HLOUSR ;ALB/CJM -ListManager Screen for viewing system status;12 JUN 1997 10:00 am ;07/30/2007 - ;;1.6;HEALTH LEVEL SEVEN;**126,130,134,137**;Oct 13, 1995;Build 21 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; -EN ; - ; - N HLSCREEN,TESTOPEN,HLRFRSH,HLPARMS - D WAIT^DICD - D EN^VALM("HLO SYSTEM MONITOR") - Q - ; -BRIEF ; - N COUNT,LINK,QUE,FROM,TIME,STATUS,TEMP,DIR,TODAY,LIST - S HLRFRSH="BRIEF^HLOUSR" - S (HLSCREEN,VALMSG)="Brief System Status" - S VALMCNT=16 - ;K @VALMAR - D CLEAN^VALM10 - S VALMBG=1 - S VALMBCK="R" - S VALMDDF("COL 1")="COL1^1^80^" - K VALMDDF("COL 2"),VALMDDF("COL 3"),VALMDDF("COL 4"),VALMDDF("COL 5") - D CHGCAP^VALM("COL 1"," Brief Operational Overview") - S @VALMAR@(1,0)="SYSTEM STATUS: "_$S($$CHKSTOP^HLOPROC:"STOPPED",1:"RUNNING") - S @VALMAR@(2,0)="PROCESS MANAGER: "_$S($$RUNNING:"RUNNING",1:"STOPPED") - ; - S TIME=$P($G(TESTOPEN("LISTENER")),"^",2) - I TIME,$$FMDIFF^XLFDT($$NOW^XLFDT,TIME,2)<300 D - .S STATUS=+TESTOPEN("LISTENER") - E D - .S STATUS=0 - .S LINK=$P($G(^HLD(779.1,1,0)),"^",10) - .I LINK S LINK=$P($G(^HLCS(870,LINK,0)),"^") Q:'$L(LINK) S STATUS=$$IFOPEN^HLOUSR1(LINK) - .S TESTOPEN("LISTENER")=STATUS_"^"_$$NOW^XLFDT - ; - S @VALMAR@(3,0)="STANDARD LISTENER: "_$S(STATUS:"OPERATIONAL",1:"NOT OPERATIONAL") - ; - S @VALMAR@(4,0)="TASKMAN: "_$S($$TM^%ZTLOAD:"RUNNING",1:"NOT RUNNING") - ; - S (LIST,LINK)="" - F S LINK=$O(^HLTMP("FAILING LINKS",LINK)) Q:LINK="" D I $L(LIST)>60 S LIST=LIST_",..." Q - .N TIME,QUE,LINKARY - .I $$GETLINK^HLOTLNK($P(LINK,":"),.LINKARY) - .S TIME=$G(^HLTMP("FAILING LINKS",LINK)) Q:TIME="" - .I '$G(LINKARY("SHUTDOWN")),TIME="" Q - .I '$G(LINKARY("SHUTDOWN")),($$HDIFF^XLFDT($H,TIME,2)<300) Q - .S LIST=LIST_$S($L(LIST):", ",1:"")_$P(LINK,":") - S @VALMAR@(5,0)="DOWN LINKS: "_LIST - S @VALMAR@(6,0)="CLIENT LINK PROCESSES: "_+$G(^HLC("HL7 PROCESS COUNTS","RUNNING","OUTGOING CLIENT LINK")) - S @VALMAR@(7,0)="IN-FILER PROCESSES: "_+$G(^HLC("HL7 PROCESS COUNTS","RUNNING","INCOMING QUEUES")) - S COUNT=0,LINK="" - F S LINK=$O(^HLC("QUEUECOUNT","OUT",LINK)) Q:LINK="" D - .S QUE="" - .F S QUE=$O(^HLC("QUEUECOUNT","OUT",LINK,QUE)) Q:QUE="" D - ..S TEMP=$G(^HLC("QUEUECOUNT","OUT",LINK,QUE)) - ..S:TEMP>0 COUNT=COUNT+TEMP - S @VALMAR@(8,0)="MESSAGES PENDING ON OUT QUEUES: "_$$RJ(+COUNT,7)_" ON SEQUENCE QUEUES: "_$$RJ(+$G(^HLC("QUEUECOUNT","SEQUENCE")),7) - S TEMP="STOPPED OUTGOING QUEUES: " - S COUNT=0,QUE="" - F S QUE=$O(^HLTMP("STOPPED QUEUES","OUT",QUE)) Q:QUE="" S COUNT=COUNT+1 Q:COUNT>4 S:COUNT=1 TEMP=TEMP_QUE S:"23"[COUNT TEMP=TEMP_"; "_QUE S:COUNT=4 TEMP=TEMP_" ..." - S @VALMAR@(9,0)=TEMP - S COUNT=0,QUE="" - F S QUE=$O(^HLC("QUEUECOUNT","IN",QUE)) Q:QUE="" D - .S FROM="" - .F S FROM=$O(^HLC("QUEUECOUNT","IN",QUE,FROM)) Q:FROM="" D - ..S TEMP=$G(^HLC("QUEUECOUNT","IN",QUE,FROM)) - ..S:TEMP>0 COUNT=COUNT+TEMP - S @VALMAR@(10,0)="MESSAGES PENDING ON APPLICATIONS: "_$$RJ(+COUNT,7) - S TEMP="STOPPED INCOMING QUEUES: " - S COUNT=0,QUE="" - F S QUE=$O(^HLTMP("STOPPED QUEUES","IN",QUE)) Q:QUE="" S COUNT=COUNT+1 Q:COUNT>4 S:COUNT=1 TEMP=TEMP_QUE S:"23"[COUNT TEMP=TEMP_"; "_QUE S:COUNT=4 TEMP=TEMP_" ..." - S @VALMAR@(11,0)=TEMP - S @VALMAR@(12,0)="FILE 777 RECORD COUNT: "_$$RJ($P($G(^HLTMP("FILE 777 RECORD COUNT")),"^"),10)_" --> as of "_$$FMTE^XLFDT($P($G(^HLTMP("FILE 777 RECORD COUNT")),"^",2)) - S @VALMAR@(13,0)="FILE 778 RECORD COUNT: "_$$RJ($P($G(^HLTMP("FILE 778 RECORD COUNT")),"^"),10)_" --> as of "_$$FMTE^XLFDT($P($G(^HLTMP("FILE 778 RECORD COUNT")),"^",2)) - S TODAY=$$DT^XLFDT - S @VALMAR@(14,0)="MESSAGES SENT TODAY: "_$$RJ($$ADD("OUT"),10) - S @VALMAR@(15,0)="MESSAGES RECEIVED TODAY: "_$$RJ($$ADD("IN"),10) - S @VALMAR@(16,0)="MESSAGE ERRORS TODAY: "_$$RJ($$ADD("EOUT")+$$ADD("EIN"),10) - Q -ADD(DIR) ; - N RAP,SAP,TIME,TOTAL - S TOTAL=0 - S TIME=TODAY-.0001 - F S TIME=$O(^HLSTATS(DIR,"HOURLY",TIME)) Q:'TIME Q:((TIME\1)>TODAY) D - .S SAP="" - .F S SAP=$O(^HLSTATS(DIR,"HOURLY",TIME,SAP)) Q:SAP="" D - ..Q:SAP="ACCEPT ACK" - ..S RAP="" - ..F S RAP=$O(^HLSTATS(DIR,"HOURLY",TIME,SAP,RAP)) Q:RAP="" D - ...S TYPE="" - ...F S TYPE=$O(^HLSTATS(DIR,"HOURLY",TIME,SAP,RAP,TYPE)) Q:TYPE="" D - ....S TOTAL=TOTAL+$G(^HLSTATS(DIR,"HOURLY",TIME,SAP,RAP,TYPE)) - Q TOTAL - ; -HELP ; - S X="?" D DISP^XQORM1 W !! - Q - ; -EXIT ; - D CLEAN^VALM10 - D CLEAR^VALM1 - Q - ; -EXPND ; - Q - ; -PROCS ; - S HLRFRSH="PROCS^HLOUSR" - ;K @VALMAR - D CLEAN^VALM10 - S VALMCNT=0 - S VALMBCK="R" - S VALMDDF("COL 1")="COL1^1^34^" - S VALMDDF("COL 2")="COL 2^35^10^MIN^H" - S VALMDDF("COL 3")="COL 3^47^10^MAX^H" - S VALMDDF("COL 4")="COL 4^59^10^#RUNNING^H" - S VALMDDF("COL 5")="COL 5^71^10^#QUEUED^IOBON" - D CHGCAP^VALM("COL 1","Process Type") - N IEN - S IEN=0 - F S IEN=$O(^HLD(779.3,"C",1,IEN)) Q:'IEN D - .N PROC - .Q:'$$GETPROC^HLOPROC1(IEN,.PROC) - .Q:PROC("NAME")="VMS TCP LISTENER" - .S VALMCNT=VALMCNT+1 - .S @VALMAR@(VALMCNT,0)=$$LJ(PROC("NAME"),30)_$$RJ(PROC("MINIMUM"),6)_$$RJ(PROC("MAXIMUM"),12)_$$RJ(+$G(^HLC("HL7 PROCESS COUNTS","RUNNING",PROC("NAME"))),14)_$$RJ(+$G(^HLC("HL7 PROCESS COUNTS","QUEUED",PROC("NAME"))),12) - S VALMCNT=VALMCNT+1,@VALMAR@(VALMCNT,0)="" - S IEN="" - F S IEN=$O(^HLTMP("HL7 RUNNING PROCESSES",IEN)) Q:IEN="" D - .N NODE - .S NODE=$G(^HLTMP("HL7 RUNNING PROCESSES",IEN)) - .Q:NODE="" - .S VALMCNT=VALMCNT+1 - .S @VALMAR@(VALMCNT,0)="$J: "_$$LJ(IEN,9)_" ->"_$$CJ($P(NODE,"^",3),28)_"<- started at "_$$HTE^XLFDT($P(NODE,"^")) - Q - ; -OUTQUEUE ; - N LINK - D CLEAN^VALM10 - ;K @VALMAR - S HLRFRSH="OUTQUEUE^HLOUSR" - S (HLSCREEN,VALMSG)="Outgoing Queues *down links !stopped queues" - S VALMCNT=0 - S VALMBCK="R" - S VALMDDF("COL 1")="COL 1^2^20^ Link^H" - S VALMDDF("COL 2")="COL 2^28^20^Queue^H" - S VALMDDF("COL 3")="COL 3^50^20^Count^H" - K VALMDDF("COL 4"),VALMDDF("COL 5") - D CHGCAP^VALM("COL 1"," Link") - S LINK="" - F S LINK=$O(^HLC("QUEUECOUNT","OUT",LINK)) Q:LINK="" D - .N COUNT,QUE,SHOW - .S SHOW=LINK - .I $D(^HLTMP("FAILING LINKS",SHOW)) S SHOW="*"_SHOW - .S QUE="" - .F S QUE=$O(^HLC("QUEUECOUNT","OUT",LINK,QUE)) Q:QUE="" D - ..S COUNT=$G(^HLC("QUEUECOUNT","OUT",LINK,QUE)) - ..Q:COUNT<1 - ..S VALMCNT=VALMCNT+1 - ..I $E(SHOW)="*" D - ...S @VALMAR@(VALMCNT,0)=$$LJ(SHOW,20)_$$CJ($S($$STOPPED^HLOQUE("OUT",QUE):"!",1:"")_QUE,21)_" "_$$RJ(COUNT,10),SHOW="" - ...D CNTRL^VALM10(VALMCNT,1,1,IOBON,IOBOFF) - ..E S @VALMAR@(VALMCNT,0)=$$LJ(SHOW,20)_$$CJ($S($$STOPPED^HLOQUE("OUT",QUE):"!",1:"")_QUE,21)_" "_$$RJ(COUNT,10),SHOW="" - Q - ; -INQUEUE ; - N FROM - D CLEAN^VALM10 - ;K @VALMAR - S HLRFRSH="INQUEUE^HLOUSR" - S (HLSCREEN,VALMSG)="Incoming Queues ('!' = stopped queues)" - S VALMCNT=0 - S VALMBCK="R" - S VALMDDF("COL 1")="COL 1^1^40^ From^H" - S VALMDDF("COL 2")="COL 2^45^20^Queue^H" - S VALMDDF("COL 3")="COL 3^70^10^Count^H" - K VALMDDF("COL 4"),VALMDDF("COL 5") - D CHGCAP^VALM("COL 1"," From") - S FROM="" - F S FROM=$O(^HLC("QUEUECOUNT","IN",FROM)) Q:FROM="" D - .N COUNT,QUE,SHOW - .S SHOW=$$LJ(FROM,40)_" " - .S QUE="" - .F S QUE=$O(^HLC("QUEUECOUNT","IN",FROM,QUE)) Q:QUE="" D - ..S COUNT=$G(^HLC("QUEUECOUNT","IN",FROM,QUE)) - ..Q:COUNT<0 - ..S VALMCNT=VALMCNT+1 - ..S @VALMAR@(VALMCNT,0)=SHOW_$$LJ($S($$STOPPED^HLOQUE("IN",QUE):"!",1:"")_QUE,21)_" "_$$RJ(COUNT,10) - ..S SHOW=$$LJ("",40)_" " - Q -VIEWLINK ; - N C,QUIT,LINK,LINKARY,TEMP - S (QUIT,C,LINK)="" - S VALMBCK="R" - ; - ;currently HL7 (Optimized) only does TCP - S LINK=$$ASKLINK - Q:LINK="" - Q:'$$GETLINK^HLOTLNK(LINK,.LINKARY) - S LINK=LINK_":"_LINKARY("PORT") - W !,"Hit any key to stop...",! - F D Q:QUIT - .N COUNT,QUE - .S (COUNT,QUE)="" - .F S QUE=$O(^HLC("QUEUECOUNT","OUT",LINK,QUE)) Q:QUE="" S TEMP=$G(^HLC("QUEUECOUNT","OUT",LINK,QUE)) S:TEMP>0 COUNT=COUNT+TEMP - .W $C(13)," ",$C(13),"MESSAGES PENDING TRANSMISSION: ",IOBON,$$RJ(+COUNT,10),IOBOFF - .R *C:1 I $T S QUIT=1 - Q - ; -CJ(STRING,LEN) ; - Q $$CJ^XLFSTR($E(STRING,1,LEN),LEN) -LJ(STRING,LEN) ; - Q $$LJ^XLFSTR($E(STRING,1,LEN),LEN) -RJ(STRING,LEN) ; - Q $$RJ^XLFSTR($E(STRING,1,LEN),LEN) - ; -RUNNING() ;Process Manager running? - N RUNNING - L +^HLTMP("PROCESS MANAGER"):0 - S RUNNING='$T - I 'RUNNING L -^HLTMP("PROCESS MANAGER") - Q RUNNING - ; -TESTLINK ; - N LINK,LINKNAME,OK - S VALMBCK="R" - S LINKNAME=$$ASKLINK - Q:LINKNAME="" - S OK=$$IFOPEN^HLOUSR1(LINKNAME) - I OK W !,LINKNAME_" IS operational..." - E W !,LINKNAME_" is NOT operational..." - W !,"Hit any key to continue..." - R *C:DTIME - Q - ; -ASKLINK() ; - N DIC,TCP,X,Y,DTOUT,DUOUT - S DIC=870 - S DIC(0)="AENQ" - S TCP=$O(^HLCS(869.1,"B","TCP",0)) - S DIC("A")="Select a TCP link:" - S DIC("S")="I $P(^(0),U,3)=TCP" - D FULL^VALM1 - D ^DIC - I +Y'=-1,'$D(DTOUT),'$D(DUOUT) Q $P(Y,"^",2) - Q "" - ; -STOP ; - I '$$ASKYESNO^HLOUSR2("Are you SURE that you want to stop sending and receiving messages","NO") S VALMBCK="" Q - ; - D STOPHL7^HLOPROC1 - S VALMBCK="R",VALMSG="HL7 (Optimized) has been stopped...." - H 5 - D @HLRFRSH - ;D:HLSCREEN="Brief System Status" BRIEF^HLOUSR - ;D:HLSCREEN="Running Processes" PROCS^HLOUSR - Q - ; -UPDMODE ;realtime - Q:'$L(HLRFRSH) - N TOP,BOTTOM,DX,DY,IOTM,IOBM,LINE,OLD,OLDCNT - S OLDCNT=VALMCNT - W !!!!!,IOINHI,"Hit any key to escape realtime display mode...",IOINORM - S IOTM=20,IOBM=23 W @IOSTBM - S TOP=VALMBG - S BOTTOM=TOP+20 - F LINE=TOP:1:BOTTOM D - .I LINE>VALMCNT S @VALMAR@(LINE,0)=$$LJ(" ",80) Q - .S @VALMAR@(LINE,0)=$$LJ(@VALMAR@(LINE,0),80) - F LINE=TOP:1:BOTTOM D - .S OLD(LINE)=@VALMAR@(LINE,0) - F LINE=17:1:BOTTOM D - .S DX=50,DY=22 X IOXY W ! - .D WRITE^VALM10(LINE) - D F R *C:4 Q:$T D - .D @HLRFRSH - .F LINE=TOP:1:BOTTOM D - ..I LINE>VALMCNT S @VALMAR@(LINE,0)=$$LJ(" ",80) Q - ..S @VALMAR@(LINE,0)=$$LJ(@VALMAR@(LINE,0),80) - .S VALMCNT=BOTTOM - .F LINE=TOP:1:BOTTOM IF OLD(LINE)'=@VALMAR@(LINE,0) D - ..S OLD(LINE)=@VALMAR@(LINE,0) - ..S DX=50,DY=22 X IOXY W ! - ..D WRITE^VALM10(LINE) - S VALMCNT=OLDCNT - S VALMBCK="R" - Q +HLOUSR ;ALB/CJM -ListManager Screen for viewing system status;12 JUN 1997 10:00 am ;02/07/2007 + ;;1.6;HEALTH LEVEL SEVEN;**126,130,134**;Oct 13, 1995;Build 30 + ;Per VHA Directive 2004-038, this routine should not be modified. + ; +EN ; + ; + N HLSCREEN,TESTOPEN,HLRFRSH + D WAIT^DICD + D EN^VALM("HLO SYSTEM MONITOR") + Q + ; +BRIEF ;Init variables and list array + N COUNT,LINK,QUE,FROM,TIME,STATUS,TEMP,DIR,TODAY,LIST + S HLRFRSH="BRIEF^HLOUSR" + S (HLSCREEN,VALMSG)="Brief System Status" + S VALMCNT=8 + ;K @VALMAR + D CLEAN^VALM10 + S VALMBG=1 + S VALMBCK="R" + K VALMDDF("COL 2"),VALMDDF("COL 3"),VALMDDF("COL 4"),VALMDDF("COL 5") + D CHGCAP^VALM("COL 1","Brief Operational Overview") + S @VALMAR@(1,0)="SYSTEM STATUS: "_$S($$CHKSTOP^HLOPROC:"STOPPED",1:"RUNNING") + S @VALMAR@(2,0)="PROCESS MANAGER: "_$S($$RUNNING:"RUNNING",1:"STOPPED") + ; + S TIME=$P($G(TESTOPEN("LISTENER")),"^",2) + I TIME,$$FMDIFF^XLFDT($$NOW^XLFDT,TIME,2)<300 D + .S STATUS=+TESTOPEN("LISTENER") + E D + .S STATUS=0 + .S LINK=$P($G(^HLD(779.1,1,0)),"^",10) + .I LINK S LINK=$P($G(^HLCS(870,LINK,0)),"^") Q:'$L(LINK) S STATUS=$$IFOPEN^HLOUSR1(LINK) + .S TESTOPEN("LISTENER")=STATUS_"^"_$$NOW^XLFDT + ; + S @VALMAR@(3,0)="STANDARD LISTENER: "_$S(STATUS:"OPERATIONAL",1:"NOT OPERATIONAL") + ; + S @VALMAR@(4,0)="TASKMAN: "_$S($$TM^%ZTLOAD:"RUNNING",1:"NOT RUNNING") + ; + S (LIST,LINK)="" + F S LINK=$O(^HLTMP("FAILING LINKS",LINK)) Q:LINK="" D I $L(LIST)>60 S LIST=LIST_",..." Q + .N TIME,QUE,LINKARY + .I $$GETLINK^HLOTLNK($P(LINK,":"),.LINKARY) + .S TIME=$G(^HLTMP("FAILING LINKS",LINK)) Q:TIME="" + .I '$G(LINKARY("SHUTDOWN")),TIME="" Q + .I '$G(LINKARY("SHUTDOWN")),($$HDIFF^XLFDT($H,TIME,2)<300) Q + .S LIST=LIST_$S($L(LIST):", ",1:"")_$P(LINK,":") + S @VALMAR@(5,0)="DOWN LINKS: "_LIST + S @VALMAR@(6,0)="CLIENT LINK PROCESSES: "_+$G(^HLC("HL7 PROCESS COUNTS","RUNNING","OUTGOING CLIENT LINK")) + S @VALMAR@(7,0)="IN-FILER PROCESSES: "_+$G(^HLC("HL7 PROCESS COUNTS","RUNNING","INCOMING QUEUES")) + S COUNT=0,LINK="" + F S LINK=$O(^HLC("QUEUECOUNT","OUT",LINK)) Q:LINK="" D + .S QUE="" + .F S QUE=$O(^HLC("QUEUECOUNT","OUT",LINK,QUE)) Q:QUE="" D + ..S TEMP=$G(^HLC("QUEUECOUNT","OUT",LINK,QUE)) + ..S:TEMP>0 COUNT=COUNT+TEMP + S @VALMAR@(8,0)="MESSAGES PENDING TRANSMISSION: "_+COUNT + S TEMP="STOPPED OUTGOING QUEUES: " + S COUNT=0,QUE="" + F S QUE=$O(^HLTMP("STOPPED QUEUES","OUT",QUE)) Q:QUE="" S COUNT=COUNT+1 Q:COUNT>4 S:COUNT=1 TEMP=TEMP_QUE S:"23"[COUNT TEMP=TEMP_"; "_QUE S:COUNT=4 TEMP=TEMP_" ..." + S @VALMAR@(9,0)=TEMP + S COUNT=0,QUE="" + F S QUE=$O(^HLC("QUEUECOUNT","IN",QUE)) Q:QUE="" D + .S FROM="" + .F S FROM=$O(^HLC("QUEUECOUNT","IN",QUE,FROM)) Q:FROM="" D + ..S TEMP=$G(^HLC("QUEUECOUNT","IN",QUE,FROM)) + ..S:TEMP>0 COUNT=COUNT+TEMP + S @VALMAR@(10,0)="MESSAGES PENDING ON APPLICATIONS: "_+COUNT + S TEMP="STOPPED INCOMING QUEUES: " + S COUNT=0,QUE="" + F S QUE=$O(^HLTMP("STOPPED QUEUES","IN",QUE)) Q:QUE="" S COUNT=COUNT+1 Q:COUNT>4 S:COUNT=1 TEMP=TEMP_QUE S:"23"[COUNT TEMP=TEMP_"; "_QUE S:COUNT=4 TEMP=TEMP_" ..." + S @VALMAR@(11,0)=TEMP + S @VALMAR@(12,0)="FILE 777 RECORD COUNT: "_$$RJ($P($G(^HLTMP("FILE 777 RECORD COUNT")),"^"),10)_" --> as of "_$$FMTE^XLFDT($P($G(^HLTMP("FILE 777 RECORD COUNT")),"^",2)) + S @VALMAR@(13,0)="FILE 778 RECORD COUNT: "_$$RJ($P($G(^HLTMP("FILE 778 RECORD COUNT")),"^"),10)_" --> as of "_$$FMTE^XLFDT($P($G(^HLTMP("FILE 778 RECORD COUNT")),"^",2)) + S TODAY=$$DT^XLFDT + S @VALMAR@(14,0)="MESSAGES SENT TODAY: "_$$RJ($$ADD("OUT"),10) + S @VALMAR@(15,0)="MESSAGES RECEIVED TODAY: "_$$RJ($$ADD("IN"),10) + S @VALMAR@(16,0)="MESSAGE ERRORS TODAY: "_$$RJ($$ADD("EOUT")+$$ADD("EIN"),10) + Q +ADD(DIR) ; + N RAP,SAP,TIME,TOTAL + S TOTAL=0 + S TIME=TODAY-.0001 + F S TIME=$O(^HLSTATS(DIR,"HOURLY",TIME)) Q:'TIME Q:((TIME\1)>TODAY) D + .S SAP="" + .F S SAP=$O(^HLSTATS(DIR,"HOURLY",TIME,SAP)) Q:SAP="" D + ..Q:SAP="ACCEPT ACK" + ..S RAP="" + ..F S RAP=$O(^HLSTATS(DIR,"HOURLY",TIME,SAP,RAP)) Q:RAP="" D + ...S TYPE="" + ...F S TYPE=$O(^HLSTATS(DIR,"HOURLY",TIME,SAP,RAP,TYPE)) Q:TYPE="" D + ....S TOTAL=TOTAL+$G(^HLSTATS(DIR,"HOURLY",TIME,SAP,RAP,TYPE)) + Q TOTAL + ; +HELP ;Help code + S X="?" D DISP^XQORM1 W !! + Q + ; +EXIT ;Exit code + D CLEAN^VALM10 + D CLEAR^VALM1 + ; + Q + ; +EXPND ;Expand code + Q + ; +PROCS ; + S HLRFRSH="PROCS^HLOUSR" + ;K @VALMAR + D CLEAN^VALM10 + S VALMCNT=0 + S VALMBCK="R" + S VALMDDF("COL 2")="COL 2^35^10^MIN^H" + S VALMDDF("COL 3")="COL 3^47^10^MAX^H" + S VALMDDF("COL 4")="COL 4^59^10^#RUNNING^H" + S VALMDDF("COL 5")="COL 5^71^10^#QUEUED^IOBON" + D CHGCAP^VALM("COL 1","Process Type") + N IEN + S IEN=0 + F S IEN=$O(^HLD(779.3,"C",1,IEN)) Q:'IEN D + .N PROC + .Q:'$$GETPROC^HLOPROC1(IEN,.PROC) + .Q:PROC("NAME")="VMS TCP LISTENER" + .S VALMCNT=VALMCNT+1 + .S @VALMAR@(VALMCNT,0)=$$LJ(PROC("NAME"),30)_$$RJ(PROC("MINIMUM"),6)_$$RJ(PROC("MAXIMUM"),12)_$$RJ(+$G(^HLC("HL7 PROCESS COUNTS","RUNNING",PROC("NAME"))),14)_$$RJ(+$G(^HLC("HL7 PROCESS COUNTS","QUEUED",PROC("NAME"))),12) + S VALMCNT=VALMCNT+1,@VALMAR@(VALMCNT,0)="" + S IEN="" + F S IEN=$O(^HLTMP("HL7 RUNNING PROCESSES",IEN)) Q:IEN="" D + .N NODE + .S NODE=$G(^HLTMP("HL7 RUNNING PROCESSES",IEN)) + .Q:NODE="" + .S VALMCNT=VALMCNT+1 + .S @VALMAR@(VALMCNT,0)="$J: "_$$LJ(IEN,9)_" ->"_$$CJ($P(NODE,"^",3),28)_"<- started at "_$$HTE^XLFDT($P(NODE,"^")) + Q + ; +OUTQUEUE ; + N LINK + D CLEAN^VALM10 + ;K @VALMAR + S HLRFRSH="OUTQUEUE^HLOUSR" + S (HLSCREEN,VALMSG)="Outgoing Queues *down links !stopped queues" + S VALMCNT=0 + S VALMBCK="R" + S VALMDDF("COL 1")="COL 1^2^20^ Link^H" + S VALMDDF("COL 2")="COL 2^28^20^Queue^H" + S VALMDDF("COL 3")="COL 3^50^20^Count^H" + K VALMDDF("COL 4"),VALMDDF("COL 5") + D CHGCAP^VALM("COL 1"," Link") + S LINK="" + F S LINK=$O(^HLC("QUEUECOUNT","OUT",LINK)) Q:LINK="" D + .N COUNT,QUE,SHOW + .S SHOW=LINK + .I $D(^HLTMP("FAILING LINKS",SHOW)) S SHOW="*"_SHOW + .S QUE="" + .F S QUE=$O(^HLC("QUEUECOUNT","OUT",LINK,QUE)) Q:QUE="" D + ..S COUNT=$G(^HLC("QUEUECOUNT","OUT",LINK,QUE)) + ..Q:COUNT<1 + ..S VALMCNT=VALMCNT+1 + ..I $E(SHOW)="*" D + ...S @VALMAR@(VALMCNT,0)=$$LJ(SHOW,20)_$$CJ($S($$STOPPED^HLOQUE("OUT",QUE):"!",1:"")_QUE,21)_" "_$$RJ(COUNT,10),SHOW="" + ...D CNTRL^VALM10(VALMCNT,1,1,IOBON,IOBOFF) + ..E S @VALMAR@(VALMCNT,0)=$$LJ(SHOW,20)_$$CJ($S($$STOPPED^HLOQUE("OUT",QUE):"!",1:"")_QUE,21)_" "_$$RJ(COUNT,10),SHOW="" + Q + ; +INQUEUE ; + N FROM + D CLEAN^VALM10 + ;K @VALMAR + S HLRFRSH="INQUEUE^HLOUSR" + S (HLSCREEN,VALMSG)="Incoming Queues ('!' = stopped queues)" + S VALMCNT=0 + S VALMBCK="R" + S VALMDDF("COL 1")="COL 1^1^40^ From^H" + S VALMDDF("COL 2")="COL 2^45^20^Queue^H" + S VALMDDF("COL 3")="COL 3^70^10^Count^H" + K VALMDDF("COL 4"),VALMDDF("COL 5") + D CHGCAP^VALM("COL 1"," From") + S FROM="" + F S FROM=$O(^HLC("QUEUECOUNT","IN",FROM)) Q:FROM="" D + .N COUNT,QUE,SHOW + .S SHOW=$$LJ(FROM,40)_" " + .S QUE="" + .F S QUE=$O(^HLC("QUEUECOUNT","IN",FROM,QUE)) Q:QUE="" D + ..S COUNT=$G(^HLC("QUEUECOUNT","IN",FROM,QUE)) + ..Q:COUNT<0 + ..S VALMCNT=VALMCNT+1 + ..S @VALMAR@(VALMCNT,0)=SHOW_$$LJ($S($$STOPPED^HLOQUE("IN",QUE):"!",1:"")_QUE,21)_" "_$$RJ(COUNT,10) + ..S SHOW=$$LJ("",40)_" " + Q +VIEWLINK ; + N C,QUIT,LINK,LINKARY,TEMP + S (QUIT,C,LINK)="" + S VALMBCK="R" + ; + ;currently HL7 (Optimized) only does TCP, when serial added a change is needed here + S LINK=$$ASKLINK + Q:LINK="" + Q:'$$GETLINK^HLOTLNK(LINK,.LINKARY) + S LINK=LINK_":"_LINKARY("PORT") + W !,"Hit any key to stop...",! + F D Q:QUIT + .N COUNT,QUE + .S (COUNT,QUE)="" + .F S QUE=$O(^HLC("QUEUECOUNT","OUT",LINK,QUE)) Q:QUE="" S TEMP=$G(^HLC("QUEUECOUNT","OUT",LINK,QUE)) S:TEMP>0 COUNT=COUNT+TEMP + .W $C(13)," ",$C(13),"MESSAGES PENDING TRANSMISSION: ",IOBON,$$RJ(+COUNT,10),IOBOFF + .R *C:1 I $T S QUIT=1 + Q + ; +CJ(STRING,LEN) ; + Q $$CJ^XLFSTR($E(STRING,1,LEN),LEN) +LJ(STRING,LEN) ; + Q $$LJ^XLFSTR($E(STRING,1,LEN),LEN) +RJ(STRING,LEN) ; + Q $$RJ^XLFSTR($E(STRING,1,LEN),LEN) + ; +RUNNING() ;Is the Process Manager running? + N RUNNING + L +^HLTMP("PROCESS MANAGER"):0 + S RUNNING='$T + I 'RUNNING L -^HLTMP("PROCESS MANAGER") + Q RUNNING + ; +TESTLINK ; + N LINK,LINKNAME,OK + S VALMBCK="R" + S LINKNAME=$$ASKLINK + Q:LINKNAME="" + S OK=$$IFOPEN^HLOUSR1(LINKNAME) + I OK W !,LINKNAME_" IS operational..." + E W !,LINKNAME_" is NOT operational..." + W !,"Hit any key to continue..." + R *C:DTIME + Q + ; +ASKLINK() ; + N DIC,TCP,X,Y,DTOUT,DUOUT + S DIC=870 + S DIC(0)="AENQ" + S TCP=$O(^HLCS(869.1,"B","TCP",0)) + S DIC("A")="Select a TCP link:" + S DIC("S")="I $P(^(0),U,3)=TCP" + D FULL^VALM1 + D ^DIC + I +Y'=-1,'$D(DTOUT),'$D(DUOUT) Q $P(Y,"^",2) + Q "" + ; +STOP ; + I '$$ASKYESNO^HLOUSR2("Are you SURE that you want to stop sending and receiving messages","NO") S VALMBCK="" Q + ; + D STOPHL7^HLOPROC1 + S VALMBCK="R",VALMSG="HL7 (Optimized) has been stopped...." + H 5 + D @HLRFRSH + ;D:HLSCREEN="Brief System Status" BRIEF^HLOUSR + ;D:HLSCREEN="Running Processes" PROCS^HLOUSR + Q + ; +UPDMODE ;update mode + Q:'$L(HLRFRSH) + N QUIT,NEW,TOP,BOTTOM,DX,DY,IOTM,IOBM,I + W !!,IOINHI,"Hit any key to escape realtime display mode...",IOINORM + S IOTM=3,IOBM=23 + W @IOSTBM + S DX=1,DY=$S(VALMCNT<17:VALMCNT+1,1:17) X IOXY + I VALMCNT>16 F I=17:1:$S(VALMCNT<22:VALMCNT,1:21) W !,@VALMAR@(I,0) + S QUIT=0 + S TOP=VALMBG + S BOTTOM=TOP+23 + S OLD=VALMAR + S VALMAR="NEW" + S VALMCNT=0 + F D Q:QUIT + .N LINE + .R *C:3 I $T S QUIT=1 + .S (VALMCNT,I)=0 + .D @HLRFRSH + .F LINE=TOP:1:BOTTOM IF $G(@OLD@(LINE,0))'=$G(@VALMAR@(LINE,0)) D + ..S:'$D(@VALMAR@(LINE,0)) @VALMAR@(LINE,0)=" " + ..D WRITE^VALM10(LINE) + K @OLD M @OLD=@VALMAR S VALMAR=OLD + S VALMBCK="R" + Q diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLOUSR1.m b/r/HEALTH_LEVEL_SEVEN-HL/HLOUSR1.m index abdb9471..a26006c2 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLOUSR1.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLOUSR1.m @@ -1,266 +1,264 @@ -HLOUSR1 ;ALB/CJM -ListManager Screen for viewing messages;12 JUN 1997 10:00 am ;07/25/2007 - ;;1.6;HEALTH LEVEL SEVEN;**126,134,137**;Oct 13, 1995;Build 21 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; -EN ; - N MSGIEN - S MSGIEN=$$PICKMSG - I 'MSGIEN S VALMBCK="R" Q - D EN^VALM("HLO SINGLE MESSAGE DISPLAY") - Q - ; -HDR ; - Q - ; -BLANK ; - S VALMCNT=0 - D EXIT - Q -DISPLAY ; - K @VALMAR - S VALMBCK="R" - N MSG - S VALMBG=1 - Q:'MSGIEN - D SHOWMSG($P(MSGIEN,"^"),$P(MSGIEN,"^",2)) - Q - ; -PICKMSG() ; - ;ask the user to select a message & return its ien - N MSGIEN,DIR,COUNT,LIST - D FULL^VALM1 - S DIR(0)="F3:30" - S DIR("A")="Message ID" - S DIR("?")="Enter the full Message Control ID or Batch Control ID of the message, or '^' to exit." -PICK D ^DIR - I $D(DIRUT)!(Y="") Q 0 - I $G(@VALMAR@("INDEX",Y)) Q $G(@VALMAR@("INDEX",Y)) - S COUNT=$$FINDMSG^HLOMSG1(Y,.LIST) - I COUNT="0" W !!,"That message can not be found! Try Again",! G PICK - I COUNT=1 Q LIST(1) - I COUNT>1 D - .N ITEM - .W !,"There is more than one message with that ID! You must choose one to display.",1 - .S ITEM=0 - .F S ITEM=$O(LIST(ITEM)) Q:'ITEM D - ..N MSG - ..Q:'$$GETMSG^HLOMSG(+LIST(ITEM),.MSG) - ..W !,"[",ITEM,"]"," DT/TM: ",$$FMTE^XLFDT(MSG("DT/TM CREATED"),2)," STATUS: ",MSG("STATUS") - .S DIR(0)="NO^1:"_COUNT,DIR("A")="Choose",DIR("?")="Choose one message from the list" - .D ^DIR - .I Y S Y=LIST(Y) - Q Y - ; -HELP ;Help code - S X="?" D DISP^XQORM1 W !! - Q - ; -EXIT ;Exit code - D CLEAN^VALM10 - D CLEAR^VALM1 - S VALMBCK="R" - ; - Q - ; -EXPND ;Expand code - Q - ; -CJ(STRING,LEN) ; - Q $$CJ^XLFSTR(STRING,LEN) -LJ(STRING,LEN) ; - Q $$LJ^XLFSTR(STRING,LEN) -SP(LEN,CHAR) ; - ;return padding - " " is the default pad character - N STR - S:$G(CHAR)="" CHAR=" " - S $P(STR,CHAR,LEN)=CHAR - Q STR - ; -SHOWMSG(MSGIEN,SUBIEN) ; - ;Description: - ; - ;Input: - ;Output: - ; - N MSG,I,TEMP,LINE - S VALMCNT=0 - S SUBIEN=+$G(SUBIEN) - I '$$GETMSG^HLOMSG(MSGIEN,.MSG) W !,"UNABLE TO DISPLAY THE MESSAGE",!! Q - I SUBIEN D GETMSGB^HLOMSG1(.MSG,SUBIEN,.MSG) - ; - S I=0 - ;** administrative information ** - S @VALMAR@($$I,0)=$$CJ("Administrative Information",80) - D CNTRL^VALM10(VALMCNT,26,30,IORVON,IORVOFF) - S LINE="MsgID: "_$$LJ(MSG("ID"),18) - S LINE=LINE_"Status: "_$$LJ(MSG("STATUS"),5) - S:MSG("ACK TO")]"" LINE=LINE_$$LJ(" Ack To:",14)_MSG("ACK TO") - S:MSG("ACK BY")]"" LINE=LINE_$$LJ(" Ack'd By:",14)_MSG("ACK BY") - S @VALMAR@($$I,0)=LINE - I MSG("STATUS","ERROR TEXT")]"" S @VALMAR@($$I,0)="Error: "_"** "_MSG("STATUS","ERROR TEXT")_" **" - S @VALMAR@($$I,0)="Dir: "_$$LJ($S(MSG("DIRECTION")="IN":"INCOMING",1:"OUTGOING"),10)_$$LJ(" Trans Dt/Tm: ",12)_$$FMTE^XLFDT(MSG("DT/TM"),2)_$$LJ(" Purge DT/TM: ",8)_$$FMTE^XLFDT(MSG("STATUS","PURGE"),2) - S @VALMAR@($$I,0)="Link: "_$$LJ(MSG("STATUS","LINK NAME"),29)_" "_$$LJ("Queue: ",13)_MSG("STATUS","QUEUE") - I $L($G(MSG("STATUS","SEQUENCE QUEUE"))) D - .S @VALMAR@($$I,0)="Sequence Queue: "_MSG("STATUS","SEQUENCE QUEUE")_" Moved: "_$S(MSG("STATUS","MOVED TO OUT QUEUE"):"YES",1:"NO") - I MSG("STATUS","ACCEPT ACK'D") D - .S @VALMAR@($$I,0)="Accept Ack: "_$$LJ(MSG("STATUS","ACCEPT ACK ID"),26)_$$LJ(" DT/TM Ack'd: ",14)_$$FMTE^XLFDT(MSG("STATUS","ACCEPT ACK DT/TM"),2) - .S @VALMAR@($$I,0)=" "_MSG("STATUS","ACCEPT ACK MSA") - I MSG("DIRECTION")="IN" D - .S LINE="App Response Rtn: " - .I $L($G(MSG("STATUS","APP ACK RESPONSE"))) S LINE=$$LJ(LINE_MSG("STATUS","APP ACK RESPONSE"),38)_" Executed: "_$S(MSG("STATUS","APP HANDOFF"):" YES",1:" NO") - .S @VALMAR@($$I,0)=LINE - I MSG("DIRECTION")="OUT",(MSG("STATUS","APP ACK'D")!MSG("STATUS","ACCEPT ACK'D")) D - .S LINE="" - .I MSG("STATUS","ACCEPT ACK'D") D - ..I MSG("STATUS","ACCEPT ACK RESPONSE")="" S MSG("STATUS","ACCEPT ACK RESPONSE")="n/a" - ..S LINE="Accept Ack Rtn: "_MSG("STATUS","ACCEPT ACK RESPONSE") - .S LINE=$$LJ(LINE,39) - .I MSG("STATUS","APP ACK'D") D - ..I MSG("STATUS","APP ACK RESPONSE")="" S MSG("STATUS","APP ACK RESPONSE")="n/a" - ..S LINE=LINE_"App Ack Rtn: "_MSG("STATUS","APP ACK RESPONSE") - .S @VALMAR@($$I,0)=LINE - ; - ;** the message text ** - S @VALMAR@($$I,0)="" - I '$G(SUBIEN) D - .S @VALMAR@($$I,0)=$$CJ("Message Text",80) - .D CNTRL^VALM10(VALMCNT,33,16,IORVON,IORVOFF) - E D - .S @VALMAR@($$I,0)=$$CJ("Individual Message Text (Batched)",80) - .D CNTRL^VALM10(VALMCNT,23,35,IORVON,IORVOFF) - D SHOWBODY(.MSG,$G(SUBIEN)) - ; - ;** display its application acknowledgment ** - I MSG("ACK BY")]"",$$FINDMSG^HLOMSG1(MSG("ACK BY"),.TEMP)=1 S MSGIEN=TEMP(1) D - .N MSG - .Q:'$$GETMSG^HLOMSG(+MSGIEN,.MSG) - .I $P(MSGIEN,"^",2) D GETMSGB^HLOMSG1(.MSG,$P(MSGIEN,"^",2),.MSG) - .S @VALMAR@($$I,0)="" - .S @VALMAR@($$I,0)=$$CJ("Application Acknowledgment",80) - .D CNTRL^VALM10(VALMCNT,26,30,IORVON,IORVOFF) - .D SHOWBODY(.MSG,$P(MSGIEN,"^",2)) - ; - ;** display the original message ** - I MSG("ACK TO")]"",$$FINDMSG^HLOMSG1(MSG("ACK TO"),.TEMP)=1 S MSGIEN=TEMP(1) D - .N MSG - .Q:'$$GETMSG^HLOMSG(+MSGIEN,.MSG) - .I $P(MSGIEN,"^",2) D GETMSGB^HLOMSG1(.MSG,$P(MSGIEN,"^",2),.MSG) - .S @VALMAR@($$I,0)="" - .S @VALMAR@($$I,0)=$$CJ("Original Message",80) - .D CNTRL^VALM10(VALMCNT,26,30,IORVON,IORVOFF) - .D SHOWBODY(.MSG,$P(MSGIEN,"^",2)) - Q - ; -SHOWBODY(MSG,SUBIEN) ; - N NODE,I,SEG,QUIT - S QUIT=0 - M SEG=MSG("HDR") - D ADD(.SEG) - S MSG("BATCH","CURRENT MESSAGE")=0 - I MSG("BATCH") D - .I $G(SUBIEN) D Q - ..S MSG("BATCH","CURRENT MESSAGE")=SUBIEN - ..F Q:'$$HLNEXT^HLOMSG(.MSG,.SEG) D ADD(.SEG) - .S MSG("BATCH","CURRENT MESSAGE")=0 - .N LAST S LAST=0 - .F Q:'$$NEXTMSG^HLOMSG(.MSG,.SEG) D Q:QUIT - ..D ADD(.SEG) - ..S LAST=MSG("BATCH","CURRENT MESSAGE") - ..F Q:'$$HLNEXT^HLOMSG(.MSG,.SEG) D ADD(.SEG) - .I MSG("DIRECTION")="OUT" K SEG S SEG(1)="BTS"_$E($G(NODE(1)),4)_LAST D ADD(.SEG) - E D - .F Q:'$$HLNEXT^HLOMSG(.MSG,.SEG) D Q:QUIT - ..D ADD(.SEG) - Q -I() ; - S VALMCNT=VALMCNT+1 - Q VALMCNT -ADD(SEG) ; - N QUIT,I,J,LINE - S QUIT=0 - S (I,J)=1 - S LINE(1)=$E(SEG(1),1,80),SEG(1)=$E(SEG(1),81,9999) - I SEG(1)="" K SEG(1) - D SHIFT(.I,.J) - S @VALMAR@($$I,0)=LINE(1) - S I=1 - F S I=$O(LINE(I)) Q:'I D - .S @VALMAR@($$I,0)=LINE(I) - .D CNTRL^VALM10(VALMCNT,1,1,IORVON,IORVOFF) - Q - ; -SHIFT(I,J) ; - I '$D(SEG(I)) S I=$O(SEG(0)) Q:'I - I $L(LINE(J))<80 D - .N LEN - .S LEN=$L(LINE(J)) - .S LINE(J)=LINE(J)_$E(SEG(I),1,80-LEN) - .S SEG(I)=$E(SEG(I),81-LEN,9999) - .I SEG(I)="" K SEG(I) - E D - .S J=J+1 - .S LINE(J)="-" - D SHIFT(.I,.J) - Q - ; -SCRLMODE ;scroll mode - Q:'$L(HLRFRSH) - N QUIT,IOTM,IOBM,DX,DY,LINE,IOTM,IOBM - W !!,IOINHI,"Hit any key to escape scroll mode...",IOINORM - S IOTM=3,IOBM=23 - S QUIT=0 - S LINE=$S(VALMCNT<17:1,1:17) - W @IOSTBM - S DX=1,DY=$S(VALMCNT<17:VALMCNT+1,1:17) X IOXY - F I=1:1 D Q:QUIT - .;every 10 seconds refresh the data - .I I>42 D @HLRFRSH S I=0 - .I LINE+1>VALMCNT D - ..S TEMP=$G(@VALMAR@(LINE,0)) - ..W !,IOUON,TEMP_$$SP(80-$L(TEMP)),IOUOFF - .E W !,$G(@VALMAR@(LINE,0)) - .S LINE=LINE+1 - .I LINE>VALMCNT S LINE=1 - .I (I=22)!(I=43) R *C:5 I $T S QUIT=1 Q - S VALMBG=LINE-23 I VALMBG<0 S VALMBG=1 - S VALMBCK="R" - Q -HLP ; - Q - ; -IFOPEN(LINK) ; - ;returns 1 if the link can be opened, otherwise 0 - ; - ;Inputs: - ; LINK - name of the link (required), optionally post-fixed with ":"_, will default to that defined for link - ; - N LINKNAME,LINKARY,POP,IO,IOF,IOST,OPEN,PORT - S OPEN=0 - S LINKNAME=$P(LINK,":") - S PORT=$P(LINK,":",2) - Q:LINKNAME="" 0 - Q:'$$GETLINK^HLOTLNK(LINKNAME,.LINKARY) 0 - S:PORT LINKARY("PORT")=PORT - Q:'$G(LINKARY("PORT")) 0 - I LINKARY("IP")="",LINKARY("DOMAIN")="",LINKARY("LLP")="TCP",LINKARY("SERVER") D - .N DATA - .S LINKARY("DOMAIN")=$P($G(^HLD(779.1,1,0)),"^") - .Q:LINKARY("DOMAIN")="" - .S DATA(.08)=LINKARY("DOMAIN") - .Q:$$UPD^HLOASUB1(870,LINKARY("IEN"),.DATA) - D:$G(LINKARY("IP"))'="" - .D CALL^%ZISTCP(LINKARY("IP"),LINKARY("PORT"),15) - .S OPEN='POP - I 'OPEN,LINKARY("DOMAIN")'="",$G(^HLTMP("DNS LAST",LINKARY("IEN")))<$$DT^XLFDT D - .N IP - .S ^HLTMP("DNS LAST",LINKARY("IEN"))=$$DT^XLFDT - .S IP=$$DNS^HLOTCP(LINKARY("DOMAIN")) - .I IP'="",IP'=LINKARY("IP") D - ..N DATA - ..S DATA(400.01)=IP,LINKARY("IP")=IP - ..Q:$$UPD^HLOASUB1(870,LINKARY("IEN"),.DATA) - ..D CALL^%ZISTCP(LINKARY("IP"),LINKARY("PORT"),15) - ..S OPEN='POP - C:OPEN IO - ;D CLOSE^%ZISTCP - Q OPEN +HLOUSR1 ;ALB/CJM -ListManager Screen for viewing messages;12 JUN 1997 10:00 am ;03/19/2007 + ;;1.6;HEALTH LEVEL SEVEN;**126,134**;Oct 13, 1995;Build 30 + ;Per VHA Directive 2004-038, this routine should not be modified. + ; +EN ; + N MSGIEN + S MSGIEN=$$PICKMSG + I 'MSGIEN S VALMBCK="R" Q + D EN^VALM("HLO SINGLE MESSAGE DISPLAY") + Q + ; +HDR ; + Q + ; +BLANK ; + S VALMCNT=0 + D EXIT + Q +DISPLAY ; + K @VALMAR + S VALMBCK="R" + N MSG + S VALMBG=1 + Q:'MSGIEN + D SHOWMSG($P(MSGIEN,"^"),$P(MSGIEN,"^",2)) + Q + ; +PICKMSG() ; + ;ask the user to select a message & return its ien + N MSGIEN,DIR,COUNT,LIST + D FULL^VALM1 + S DIR(0)="F3:30" + S DIR("A")="Message ID" + S DIR("?")="Enter the full Message Control ID or Batch Control ID of the message, or '^' to exit." +PICK D ^DIR + I $D(DIRUT)!(Y="") Q 0 + I $G(@VALMAR@("INDEX",Y)) Q $G(@VALMAR@("INDEX",Y)) + S COUNT=$$FINDMSG^HLOMSG1(Y,.LIST) + I COUNT="0" W !!,"That message can not be found! Try Again",! G PICK + I COUNT=1 Q LIST(1) + I COUNT>1 D + .N ITEM + .W !,"There is more than one message with that ID! You must choose one to display.",1 + .S ITEM=0 + .F S ITEM=$O(LIST(ITEM)) Q:'ITEM D + ..N MSG + ..Q:'$$GETMSG^HLOMSG(+LIST(ITEM),.MSG) + ..W !,"[",ITEM,"]"," DT/TM: ",$$FMTE^XLFDT(MSG("DT/TM CREATED"),2)," STATUS: ",MSG("STATUS") + .S DIR(0)="NO^1:"_COUNT,DIR("A")="Choose",DIR("?")="Choose one message from the list" + .D ^DIR + .I Y S Y=LIST(Y) + Q Y + ; +HELP ;Help code + S X="?" D DISP^XQORM1 W !! + Q + ; +EXIT ;Exit code + D CLEAN^VALM10 + D CLEAR^VALM1 + S VALMBCK="R" + ; + Q + ; +EXPND ;Expand code + Q + ; +CJ(STRING,LEN) ; + Q $$CJ^XLFSTR(STRING,LEN) +LJ(STRING,LEN) ; + Q $$LJ^XLFSTR(STRING,LEN) +SP(LEN,CHAR) ; + ;return padding - " " is the default pad character + N STR + S:$G(CHAR)="" CHAR=" " + S $P(STR,CHAR,LEN)=CHAR + Q STR + ; +SHOWMSG(MSGIEN,SUBIEN) ; + ;Description: + ; + ;Input: + ;Output: + ; + N MSG,I,TEMP,LINE + S VALMCNT=0 + S SUBIEN=+$G(SUBIEN) + I '$$GETMSG^HLOMSG(MSGIEN,.MSG) W !,"UNABLE TO DISPLAY THE MESSAGE",!! Q + I SUBIEN D GETMSGB^HLOMSG1(.MSG,SUBIEN,.MSG) + ; + S I=0 + ;** administrative information ** + S @VALMAR@($$I,0)=$$CJ("Administrative Information",80) + D CNTRL^VALM10(VALMCNT,26,30,IORVON,IORVOFF) + S LINE="MsgID: "_$$LJ(MSG("ID"),18) + S LINE=LINE_"Status: "_$$LJ(MSG("STATUS"),5) + S:MSG("ACK TO")]"" LINE=LINE_$$LJ(" Ack To:",14)_MSG("ACK TO") + S:MSG("ACK BY")]"" LINE=LINE_$$LJ(" Ack'd By:",14)_MSG("ACK BY") + S @VALMAR@($$I,0)=LINE + I MSG("STATUS","ERROR TEXT")]"" S @VALMAR@($$I,0)="Error: "_"** "_MSG("STATUS","ERROR TEXT")_" **" + S @VALMAR@($$I,0)="Dir: "_$$LJ($S(MSG("DIRECTION")="IN":"INCOMING",1:"OUTGOING"),10)_$$LJ(" Trans Dt/Tm: ",12)_$$FMTE^XLFDT(MSG("DT/TM"),2)_$$LJ(" Purge DT/TM: ",8)_$$FMTE^XLFDT(MSG("STATUS","PURGE"),2) + S @VALMAR@($$I,0)="Link: "_$$LJ(MSG("STATUS","LINK NAME"),29)_" "_$$LJ("Queue: ",13)_MSG("STATUS","QUEUE") + I MSG("STATUS","ACCEPT ACK'D") D + .S @VALMAR@($$I,0)="Accept Ack: "_$$LJ(MSG("STATUS","ACCEPT ACK ID"),26)_$$LJ(" At: ",14)_$$FMTE^XLFDT(MSG("STATUS","ACCEPT ACK DT/TM"),2) + .S @VALMAR@($$I,0)=" "_MSG("STATUS","ACCEPT ACK MSA") + I MSG("DIRECTION")="IN" D + .S LINE="App Response Rtn: " + .I $L($G(MSG("STATUS","APP ACK RESPONSE"))) S LINE=$$LJ(LINE_MSG("STATUS","APP ACK RESPONSE"),38)_" Executed: "_$S(MSG("STATUS","APP HANDOFF"):" YES",1:" NO") + .S @VALMAR@($$I,0)=LINE + I MSG("DIRECTION")="OUT",(MSG("STATUS","APP ACK'D")!MSG("STATUS","ACCEPT ACK'D")) D + .S LINE="" + .I MSG("STATUS","ACCEPT ACK'D") D + ..I MSG("STATUS","ACCEPT ACK RESPONSE")="" S MSG("STATUS","ACCEPT ACK RESPONSE")="n/a" + ..S LINE="Accept Ack Rtn: "_MSG("STATUS","ACCEPT ACK RESPONSE") + .S LINE=$$LJ(LINE,39) + .I MSG("STATUS","APP ACK'D") D + ..I MSG("STATUS","APP ACK RESPONSE")="" S MSG("STATUS","APP ACK RESPONSE")="n/a" + ..S LINE=LINE_"App Ack Rtn: "_MSG("STATUS","APP ACK RESPONSE") + .S @VALMAR@($$I,0)=LINE + ; + ;** the message text ** + S @VALMAR@($$I,0)="" + I '$G(SUBIEN) D + .S @VALMAR@($$I,0)=$$CJ("Message Text",80) + .D CNTRL^VALM10(VALMCNT,33,16,IORVON,IORVOFF) + E D + .S @VALMAR@($$I,0)=$$CJ("Individual Message Text (Batched)",80) + .D CNTRL^VALM10(VALMCNT,23,35,IORVON,IORVOFF) + D SHOWBODY(.MSG,$G(SUBIEN)) + ; + ;** display its application acknowledgment ** + I MSG("ACK BY")]"",$$FINDMSG^HLOMSG1(MSG("ACK BY"),.TEMP)=1 S MSGIEN=TEMP(1) D + .N MSG + .Q:'$$GETMSG^HLOMSG(+MSGIEN,.MSG) + .I $P(MSGIEN,"^",2) D GETMSGB^HLOMSG1(.MSG,$P(MSGIEN,"^",2),.MSG) + .S @VALMAR@($$I,0)="" + .S @VALMAR@($$I,0)=$$CJ("Application Acknowledgment",80) + .D CNTRL^VALM10(VALMCNT,26,30,IORVON,IORVOFF) + .D SHOWBODY(.MSG,$P(MSGIEN,"^",2)) + ; + ;** display the original message ** + I MSG("ACK TO")]"",$$FINDMSG^HLOMSG1(MSG("ACK TO"),.TEMP)=1 S MSGIEN=TEMP(1) D + .N MSG + .Q:'$$GETMSG^HLOMSG(+MSGIEN,.MSG) + .I $P(MSGIEN,"^",2) D GETMSGB^HLOMSG1(.MSG,$P(MSGIEN,"^",2),.MSG) + .S @VALMAR@($$I,0)="" + .S @VALMAR@($$I,0)=$$CJ("Original Message",80) + .D CNTRL^VALM10(VALMCNT,26,30,IORVON,IORVOFF) + .D SHOWBODY(.MSG,$P(MSGIEN,"^",2)) + Q + ; +SHOWBODY(MSG,SUBIEN) ; + N NODE,I,SEG,QUIT + S QUIT=0 + M SEG=MSG("HDR") + D ADD(.SEG) + S MSG("BATCH","CURRENT MESSAGE")=0 + I MSG("BATCH") D + .I $G(SUBIEN) D Q + ..S MSG("BATCH","CURRENT MESSAGE")=SUBIEN + ..F Q:'$$HLNEXT^HLOMSG(.MSG,.SEG) D ADD(.SEG) + .S MSG("BATCH","CURRENT MESSAGE")=0 + .N LAST S LAST=0 + .F Q:'$$NEXTMSG^HLOMSG(.MSG,.SEG) D Q:QUIT + ..D ADD(.SEG) + ..S LAST=MSG("BATCH","CURRENT MESSAGE") + ..F Q:'$$HLNEXT^HLOMSG(.MSG,.SEG) D ADD(.SEG) + .I MSG("DIRECTION")="OUT" K SEG S SEG(1)="BTS"_$E($G(NODE(1)),4)_LAST D ADD(.SEG) + E D + .F Q:'$$HLNEXT^HLOMSG(.MSG,.SEG) D Q:QUIT + ..D ADD(.SEG) + Q +I() ; + S VALMCNT=VALMCNT+1 + Q VALMCNT +ADD(SEG) ; + N QUIT,I,J,LINE + S QUIT=0 + S (I,J)=1 + S LINE(1)=$E(SEG(1),1,80),SEG(1)=$E(SEG(1),81,9999) + I SEG(1)="" K SEG(1) + D SHIFT(.I,.J) + S @VALMAR@($$I,0)=LINE(1) + S I=1 + F S I=$O(LINE(I)) Q:'I D + .S @VALMAR@($$I,0)=LINE(I) + .D CNTRL^VALM10(VALMCNT,1,1,IORVON,IORVOFF) + Q + ; +SHIFT(I,J) ; + I '$D(SEG(I)) S I=$O(SEG(0)) Q:'I + I $L(LINE(J))<80 D + .N LEN + .S LEN=$L(LINE(J)) + .S LINE(J)=LINE(J)_$E(SEG(I),1,80-LEN) + .S SEG(I)=$E(SEG(I),81-LEN,9999) + .I SEG(I)="" K SEG(I) + E D + .S J=J+1 + .S LINE(J)="-" + D SHIFT(.I,.J) + Q + ; +SCRLMODE ;scroll mode + Q:'$L(HLRFRSH) + N QUIT,IOTM,IOBM,DX,DY,LINE,IOTM,IOBM + W !!,IOINHI,"Hit any key to escape scroll mode...",IOINORM + S IOTM=3,IOBM=23 + S QUIT=0 + S LINE=$S(VALMCNT<17:1,1:17) + W @IOSTBM + S DX=1,DY=$S(VALMCNT<17:VALMCNT+1,1:17) X IOXY + F I=1:1 D Q:QUIT + .;every 10 seconds refresh the data + .I I>42 D @HLRFRSH S I=0 + .I LINE+1>VALMCNT D + ..S TEMP=$G(@VALMAR@(LINE,0)) + ..W !,IOUON,TEMP_$$SP(80-$L(TEMP)),IOUOFF + .E W !,$G(@VALMAR@(LINE,0)) + .S LINE=LINE+1 + .I LINE>VALMCNT S LINE=1 + .I (I=22)!(I=43) R *C:5 I $T S QUIT=1 Q + S VALMBG=LINE-23 I VALMBG<0 S VALMBG=1 + S VALMBCK="R" + Q +HLP ; + Q + ; +IFOPEN(LINK) ; + ;returns 1 if the link can be opened, otherwise 0 + ; + ;Inputs: + ; LINK - name of the link (required), optionally post-fixed with ":"_, will default to that defined for link + ; + N LINKNAME,LINKARY,POP,IO,IOF,IOST,OPEN,PORT + S OPEN=0 + S LINKNAME=$P(LINK,":") + S PORT=$P(LINK,":",2) + Q:LINKNAME="" 0 + Q:'$$GETLINK^HLOTLNK(LINKNAME,.LINKARY) 0 + S:PORT LINKARY("PORT")=PORT + Q:'$G(LINKARY("PORT")) 0 + I LINKARY("IP")="",LINKARY("DOMAIN")="",LINKARY("LLP")="TCP",LINKARY("SERVER") D + .N DATA + .S LINKARY("DOMAIN")=$P($G(^HLD(779.1,1,0)),"^") + .Q:LINKARY("DOMAIN")="" + .S DATA(.08)=LINKARY("DOMAIN") + .Q:$$UPD^HLOASUB1(870,LINKARY("IEN"),.DATA) + D:$G(LINKARY("IP"))'="" + .D CALL^%ZISTCP(LINKARY("IP"),LINKARY("PORT"),15) + .S OPEN='POP + I 'OPEN,LINKARY("DOMAIN")'="",$G(^HLTMP("DNS LAST",LINKARY("IEN")))<$$DT^XLFDT D + .N IP + .S ^HLTMP("DNS LAST",LINKARY("IEN"))=$$DT^XLFDT + .S IP=$$DNS^HLOTCP(LINKARY("DOMAIN")) + .I IP'="",IP'=LINKARY("IP") D + ..N DATA + ..S DATA(400.01)=IP,LINKARY("IP")=IP + ..Q:$$UPD^HLOASUB1(870,LINKARY("IEN"),.DATA) + ..D CALL^%ZISTCP(LINKARY("IP"),LINKARY("PORT"),15) + ..S OPEN='POP + C:OPEN IO + ;D CLOSE^%ZISTCP + Q OPEN diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLOUSR2.m b/r/HEALTH_LEVEL_SEVEN-HL/HLOUSR2.m index cb8be328..b4480549 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLOUSR2.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLOUSR2.m @@ -1,231 +1,236 @@ -HLOUSR2 ;ALB/CJM -ListManager Screen for viewing messages(continued);12 JUN 1997 10:00 am ;07/17/2007 - ;;1.6;HEALTH LEVEL SEVEN;**126,134,137**;Oct 13, 1995;Build 21 - ;Per VHA Directive 2004-038, this routine should not be modified - ; -EN ; - D WAIT^DICD - D EN^VALM("HLO MESSAGE VIEWER") - Q - ; -SHOWLIST ; - N PARMS,I,ERRCOUNT - S (VALMBG,VALMCNT,I,ERRCOUNT)=0 - D CLEAN^VALM10 - S VALMBG=1 - I '$$ASKPARMS(.PARMS) S VALMBCK="" Q - I PARMS("ALL") D - .N APP - .S APP="" - .F S APP=$O(^HLB("ERRORS",APP)) Q:APP="" D Q:ERRCOUNT>PARMS("MAX") - ..N TIME,IEN - ..S TIME=PARMS("START") - ..Q:($O(^HLB("ERRORS",APP,TIME))="") - ..S @VALMAR@($$I,0)="Application: "_APP - ..D CNTRL^VALM10(VALMCNT,14,$L(APP),IOINHI,IOINORM) - ..F S TIME=$O(^HLB("ERRORS",APP,TIME)) Q:'TIME Q:ERRCOUNT>PARMS("MAX") S IEN="" F S IEN=$O(^HLB("ERRORS",APP,TIME,IEN)) Q:IEN="" D ADDTO(IEN,TIME,.ERRCOUNT) Q:ERRCOUNT>PARMS("MAX") - E D - .N APP - .S APP=PARMS("APP") - .N TIME,IEN - .S TIME=PARMS("START") - .Q:$O(^HLB("ERRORS",APP,TIME))="" - .S @VALMAR@($$I,0)="Application: "_APP - .D CNTRL^VALM10(VALMCNT,14,$L(APP),IOINHI,IOINORM) - .F S TIME=$O(^HLB("ERRORS",APP,TIME)) Q:'TIME Q:ERRCOUNT>PARMS("MAX") S IEN="" F S IEN=$O(^HLB("ERRORS",APP,TIME,IEN)) Q:IEN="" D ADDTO(IEN,TIME,.ERRCOUNT) Q:ERRCOUNT>PARMS("MAX") - ; -SHOW S VALMBCK="R" - ; - Q -ADDTO(IEN,TIME,ERRCOUNT) ; - N NODE,MSG - Q:'$$GETMSG^HLOMSG(+IEN,.MSG) - S ERRCOUNT=ERRCOUNT+1 - ;application errors could be an error to a msg within a batch - ;also, need to go to the ack msg to get the error text from the MSA segment - ; - N SUBIEN,MSA,ERRTEXT - S (ERRTEXT,MSA)="" - S SUBIEN=$P(IEN,"^",2) - ;within batch? - D:SUBIEN GETMSGB^HLOMSG1(.MSG,SUBIEN,.MSG) - S ERRTEXT=MSG("STATUS","ERROR TEXT") - I ERRTEXT="",MSG("ACK BY")]"",($$FINDMSG^HLOMSG1(MSG("ACK BY"),.LIST)=1) D - .N MSG,SEG,FS,AIEN - .S AIEN=+LIST(1),SUBIEN=$P(LIST(1),"^",2) - .Q:'$$GETMSG^HLOMSG(AIEN,.MSG) - .I SUBIEN S MSG("BATCH","CURRENT MESSAGE")=SUBIEN,MSG("LINE COUNT")=0 - .F Q:'$$HLNEXT^HLOMSG(.MSG,.SEG) I $E(SEG(1),1,3)="MSA" S MSA=SEG(1),FS=$E(MSA,4),ERRTEXT=$P(MSA,FS,4) Q - I ERRTEXT="",MSG("ACK BY")="" D - .N FS - .S FS=$E(MSG("HDR",1),4) - .I $L(FS) S ERRTEXT=$P($G(MSG("STATUS","ACCEPT ACK MSA")),FS,4) - S @VALMAR@($$I,0)=" "_$$LJ(MSG("ID"),15)_$$LJ(MSG("MESSAGE TYPE")_"~"_MSG("EVENT"),8)_$$LJ($$FMTE^XLFDT(MSG("DT/TM CREATED"),2),20)_$E(ERRTEXT,1,35) - D CNTRL^VALM10(VALMCNT,3,15,IOINHI,IOINORM) - I $L(ERRTEXT)>35 D - .S @VALMAR@($$I,0)=$$RJ(" ",45)_$E(ERRTEXT,36,115) - S:MSG("ID")]"" @VALMAR@("INDEX",MSG("ID"))=IEN - Q - ; -ASKPARMS(PARMS) ; - K PARMS - S PARMS("START")=$$ASKBEGIN("T-1") - I 'PARMS("START") Q 0 - S PARMS("MAX")=$$ASKMAX() - Q:'(PARMS("MAX")>-1) 0 - S PARMS("ALL")=$$ASKYESNO("Include ALL applications","YES") - I PARMS("ALL") Q 1 - I PARMS("ALL")="" Q 0 - S PARMS("APP")=$$ASKAPP - I PARMS("APP")="" Q 0 - Q 1 - ; -ASKMAX() ; - N DIR - S DIR(0)="N^1:30000:0" - S DIR("A")="Maximum List Size" - S DIR("B")=1000 - S DIR("?",1)="In case a large number of errors meet your search criteria, what are the" - S DIR("?")="maximum number of errors to display? (30,000 maximum)" - D ^DIR - Q:$D(DTOUT)!$D(DUOUT) -1 - Q X-1 -ASKAPP() ; - D FULL^VALM1 - S VALMBCK="R" - N DIR - S DIR(0)="F^3:60" - S DIR("A")="Receiving Application" - S DIR("?")="Enter the full name of the application, or '^' to exit." - D ^DIR - I $D(DIRUT)!(Y="") Q "" - Q Y - ; -ASKYESNO(PROMPT,DEFAULT) ; - ;Description: Displays PROMPT, appending '?'. Expects a YES NO response - ;Input: - ; PROMPT - text to display as prompt. Appends '?' - ; DEFAULT - (optional) YES or NO. If not passed, defaults to YES - ;Output: - ; Function value: 1 if yes, 0 if no, "" if '^' entered or timeout - ; - N DIR,Y - S DIR(0)="Y" - S DIR("A")=PROMPT - S DIR("B")=$S($G(DEFAULT)="NO":"NO",1:"YES") - D ^DIR - Q:$D(DIRUT) "" - Q Y - ; -STRTSTPQ ; - ;action to start or stop a queue, either incoming or outgoing - ; - N STOP,INOROUT,QUE - S VALMBCK="R" - D FULL^VALM1 - ;ask if stop or start - D Q:STOP="" - .N DIR - .S DIR(0)="S^1:START;2:STOP" - .S DIR("A")="Do you want to START or STOP a queue" - .S DIR("B")="1" - .D ^DIR - .S STOP=$S(Y=1:0,Y=2:1,1:"") - ;ask if in or out - D Q:INOROUT="" - .N DIR - .S DIR(0)="S^I:INCOMING;O:OUTGOING" - .S DIR("A")="Do you want to "_$S(STOP:"stop",1:"start")_" an incoming queue or an outgoing queue" - .S DIR("B")="I" - .D ^DIR - .S INOROUT=$S(Y="I":"IN",Y="O":"OUT",1:"") - S QUE=$$ASKQUE(INOROUT) - Q:QUE="" - I STOP=$$STOPPED^HLOQUE(INOROUT,QUE) D - .N C - .I STOP D - ..W !,"That queue is already stopped!" - .E W !,"That queue is not stopped!" - .W !,IOINHI,"Hit any key to continue...",IOINORM - .R *C:DTIME - E D - .N C - .D:STOP STOPQUE^HLOQUE(INOROUT,QUE) - .D:'STOP STARTQUE^HLOQUE(INOROUT,QUE) - .W !,"DONE!" - .W !,IOINHI,"Hit any key to continue...",IOINORM - .R *C:DTIME - .D @HLRFRSH - Q - ; -ASKQUE(DIR) ; - N QUEUE -AGAIN W !,"Enter the full, exact name of queue:" - S QUEUE="" - R QUEUE:60 I '$T Q "" - I $E(QUEUE)="?" W !,"Each message is placed on a queue that has an arbitrary name up to 20",!,"characters long." I $$ASKYESNO("Would you like to see a list of the queues that currently exist","NO") D G AGAIN - .N SUB,QUE,QUIT,COUNT - .K ^TMP($J,"HLO QUEUES") - .S SUB="" - .F S SUB=$O(^HLB("QUEUE",DIR,SUB)) Q:SUB="" D - ..S QUE="" - ..F S QUE=$O(^HLB("QUEUE",DIR,SUB,QUE)) Q:QUE="" S ^TMP($J,"HLO QUEUES",QUE)="" - .S QUE="" - .S IOSL=$G(IOSL,20) - .S (COUNT,QUIT)=0 - .W ! - .F S QUE=$O(^TMP($J,"HLO QUEUES",QUE)) Q:QUE="" Q:QUIT D - ..W !,QUE - ..S COUNT=COUNT+1 - ..I COUNT>(IOSL-3) D - ...N Y - ...D PAUSE^VALM1 - ...I 'Y S QUIT=1 - ...S COUNT=0 - .W ! - .K ^TMP($J,"HLO QUEUES") - Q:$E(QUEUE)="?" "" - Q:$E(QUEUE)="^" "" - Q QUEUE - ; -ASKBEGIN(DEFAULT) ; - ;Description: Asks the user to enter a beginning date. - ;Input: DEFAULT - the suggested default dt/time (optional) - ;Output: Returns the date as the function value, or 0 if the user does not select a date - ; - ; - N %DT - S %DT="AEST" - S %DT("A")="Enter the beginning date/time: " - S %DT("B")=$$FMTE^XLFDT($S($L($G(DEFAULT)):DEFAULT,1:$$FMADD^XLFDT(DT,-1))) - S %DT(0)="-NOW" - Q:$D(DTOUT) 0 - D ^%DT - I Y=-1 Q 0 - Q Y - ; -ASKEND(BEGIN) ; - ;Description: Asks the user to enter an ending date/time - ;Input: BEGIN - the earliest date/time allowed - ;Output: Returns the date as the function value, or 0 if the user does not select a date/time - ; - N %DT - S %DT="AEST" - S %DT("A")="Enter the ending date/time: " - S %DT("B")="NOW" - S %DT(0)=BEGIN - Q:$D(DTOUT) 0 - D ^%DT - I Y=-1 Q 0 - Q Y - ; -LJ(STRING,LEN) ; - Q $$LJ^XLFSTR(STRING,LEN) -RJ(STRING,LEN) ; - Q $$RJ^XLFSTR(STRING,LEN) - ; -I() ; - S VALMCNT=VALMCNT+1 - Q VALMCNT - ; -HEADER ; - Q +HLOUSR2 ;ALB/CJM -ListManager Screen for viewing messages(continued);12 JUN 1997 10:00 am ;03/19/2007 + ;;1.6;HEALTH LEVEL SEVEN;**126,134**;Oct 13, 1995;Build 30 + ;Per VHA Directive 2004-038, this routine should not be modified + ; +EN ; + D WAIT^DICD + D EN^VALM("HLO MESSAGE VIEWER") + Q + ; +SHOWLIST(TYPE) ; + ;TYPE= "SE", "AE", "TF" + N PARMS,I,ERRCOUNT + S (VALMBG,VALMCNT,I,ERRCOUNT)=0 + D CLEAN^VALM10 + S VALMBG=1 + I '$$ASKPARMS(.PARMS) S VALMBCK="" Q + I PARMS("ALL") D + .N APP + .S APP="" + .F S APP=$O(^HLB("ERRORS",TYPE,APP)) Q:APP="" D Q:ERRCOUNT>PARMS("MAX") + ..N TIME,IEN + ..S TIME=PARMS("START") + ..Q:($O(^HLB("ERRORS",TYPE,APP,TIME))="") + ..S @VALMAR@($$I,0)="Application: "_APP + ..D CNTRL^VALM10(VALMCNT,14,$L(APP),IOINHI,IOINORM) + ..F S TIME=$O(^HLB("ERRORS",TYPE,APP,TIME)) Q:'TIME Q:ERRCOUNT>PARMS("MAX") S IEN="" F S IEN=$O(^HLB("ERRORS",TYPE,APP,TIME,IEN)) Q:IEN="" D ADDTO(TYPE,IEN,TIME,.ERRCOUNT) Q:ERRCOUNT>PARMS("MAX") + E D + .N APP + .S APP=PARMS("APP") + .N TIME,IEN + .S TIME=PARMS("START") + .Q:$O(^HLB("ERRORS",TYPE,APP,TIME))="" + .S @VALMAR@($$I,0)="Application: "_APP + .D CNTRL^VALM10(VALMCNT,14,$L(APP),IOINHI,IOINORM) + .F S TIME=$O(^HLB("ERRORS",TYPE,APP,TIME)) Q:'TIME Q:ERRCOUNT>PARMS("MAX") S IEN="" F S IEN=$O(^HLB("ERRORS",TYPE,APP,TIME,IEN)) Q:IEN="" D ADDTO(TYPE,IEN,TIME,.ERRCOUNT) Q:ERRCOUNT>PARMS("MAX") + ; +SHOW S VALMBCK="R" + ; + Q +ADDTO(LTYPE,IEN,TIME,ERRCOUNT) ; + N NODE,MSG + Q:'$$GETMSG^HLOMSG(+IEN,.MSG) + S ERRCOUNT=ERRCOUNT+1 + I LTYPE'="AE" D + .N TYPE + .S TYPE=$S(MSG("BATCH"):"BATCH",1:MSG("MESSAGE TYPE")_"~"_MSG("EVENT")) + .S @VALMAR@($$I,0)=" "_$$LJ(MSG("ID"),15)_$$LJ(TYPE,8)_$$LJ($$FMTE^XLFDT(TIME,2),20)_MSG("STATUS","ERROR TEXT") + .D CNTRL^VALM10(VALMCNT,3,15,IOINHI,IOINORM) + .S:MSG("ID")]"" @VALMAR@("INDEX",MSG("ID"))=IEN + E D + .;application errors - could be an error to a msg within a batch + .;also, need to go to the ack msg to get the error text from the MSA segment + .; + .N SUBIEN,MSA,ERRTEXT + .S (ERRTEXT,MSA)="" + .S SUBIEN=$P(IEN,"^",2) + .;within batch? + .D:SUBIEN GETMSGB^HLOMSG1(.MSG,SUBIEN,.MSG) + .S ERRTEXT=MSG("STATUS","ERROR TEXT") + .I ERRTEXT="",MSG("ACK BY")]"",($$FINDMSG^HLOMSG1(MSG("ACK BY"),.LIST)=1) D + ..N MSG,SEG,FS,AIEN + ..S AIEN=+LIST(1),SUBIEN=$P(LIST(1),"^",2) + ..Q:'$$GETMSG^HLOMSG(AIEN,.MSG) + ..I SUBIEN S MSG("BATCH","CURRENT MESSAGE")=SUBIEN,MSG("LINE COUNT")=0 + ..F Q:'$$HLNEXT^HLOMSG(.MSG,.SEG) I $E(SEG(1),1,3)="MSA" S MSA=SEG(1),FS=$E(MSA,4),ERRTEXT=$P(MSA,FS,4) Q + .S @VALMAR@($$I,0)=" "_$$LJ(MSG("ID"),15)_$$LJ(MSG("MESSAGE TYPE")_"~"_MSG("EVENT"),8)_$$LJ($$FMTE^XLFDT(MSG("DT/TM CREATED"),2),20)_$E(ERRTEXT,1,37) + .D CNTRL^VALM10(VALMCNT,3,15,IOINHI,IOINORM) + .I $L(ERRTEXT)>37 D + ..S @VALMAR@($$I,0)="~"_$E(ERRTEXT,38,112) + ..D CNTRL^VALM10(VALMCNT,1,1,IORVON,IORVOFF) + .S:MSG("ID")]"" @VALMAR@("INDEX",MSG("ID"))=IEN + Q + ; +ASKPARMS(PARMS) ; + K PARMS + S PARMS("START")=$$ASKBEGIN("T-1") + I 'PARMS("START") Q 0 + S PARMS("MAX")=$$ASKMAX() + Q:'(PARMS("MAX")>-1) 0 + S PARMS("ALL")=$$ASKYESNO("Include ALL applications","YES") + I PARMS("ALL") Q 1 + I PARMS("ALL")="" Q 0 + S PARMS("APP")=$$ASKAPP + I PARMS("APP")="" Q 0 + Q 1 + ; +ASKMAX() ; + N DIR + S DIR(0)="N^1:30000:0" + S DIR("A")="Maximum List Size" + S DIR("B")=1000 + S DIR("?",1)="In case a large number of errors meet your search criteria, what are the" + S DIR("?")="maximum number of errors to display? (30,000 maximum)" + D ^DIR + Q:$D(DTOUT)!$D(DUOUT) -1 + Q X-1 +ASKAPP() ; + D FULL^VALM1 + S VALMBCK="R" + N DIR + S DIR(0)="F^3:60" + S DIR("A")="Application" + S DIR("?")="Enter the full name of the application, or '^' to exit." + S DIR("?",1)="For transmission failures, enter the sending application. " + S DIR("?",2)="For other errors, enter the name of the receiving application. " + D ^DIR + I $D(DIRUT)!(Y="") Q "" + Q Y + ; +ASKYESNO(PROMPT,DEFAULT) ; + ;Description: Displays PROMPT, appending '?'. Expects a YES NO response + ;Input: + ; PROMPT - text to display as prompt. Appends '?' + ; DEFAULT - (optional) YES or NO. If not passed, defaults to YES + ;Output: + ; Function value: 1 if yes, 0 if no, "" if '^' entered or timeout + ; + N DIR,Y + S DIR(0)="Y" + S DIR("A")=PROMPT + S DIR("B")=$S($G(DEFAULT)="NO":"NO",1:"YES") + D ^DIR + Q:$D(DIRUT) "" + Q Y + ; +STRTSTPQ ; + ;action to start or stop a queue, either incoming or outgoing + ; + N STOP,INOROUT,QUE + S VALMBCK="R" + D FULL^VALM1 + ;ask if stop or start + D Q:STOP="" + .N DIR + .S DIR(0)="S^1:START;2:STOP" + .S DIR("A")="Do you want to START or STOP a queue" + .S DIR("B")="1" + .D ^DIR + .S STOP=$S(Y=1:0,Y=2:1,1:"") + ;ask if in or out + D Q:INOROUT="" + .N DIR + .S DIR(0)="S^I:INCOMING;O:OUTGOING" + .S DIR("A")="Do you want to "_$S(STOP:"stop",1:"start")_" an incoming queue or an outgoing queue" + .S DIR("B")="I" + .D ^DIR + .S INOROUT=$S(Y="I":"IN",Y="O":"OUT",1:"") + S QUE=$$ASKQUE(INOROUT) + Q:QUE="" + I STOP=$$STOPPED^HLOQUE(INOROUT,QUE) D + .N C + .I STOP D + ..W !,"That queue is already stopped!" + .E W !,"That queue is not stopped!" + .W !,IOINHI,"Hit any key to continue...",IOINORM + .R *C:DTIME + E D + .N C + .D:STOP STOPQUE^HLOQUE(INOROUT,QUE) + .D:'STOP STARTQUE^HLOQUE(INOROUT,QUE) + .W !,"DONE!" + .W !,IOINHI,"Hit any key to continue...",IOINORM + .R *C:DTIME + .D @HLRFRSH + Q + ; +ASKQUE(DIR) ; + N QUEUE +AGAIN W !,"Enter the full, exact name of queue:" + S QUEUE="" + R QUEUE:60 I '$T Q "" + I $E(QUEUE)="?" W !,"Each message is placed on a queue that has an arbitrary name up to 20",!,"characters long." I $$ASKYESNO("Would you like to see a list of the queues that currently exist","NO") D G AGAIN + .N SUB,QUE,QUIT,COUNT + .K ^TMP($J,"HLO QUEUES") + .S SUB="" + .F S SUB=$O(^HLB("QUEUE",DIR,SUB)) Q:SUB="" D + ..S QUE="" + ..F S QUE=$O(^HLB("QUEUE",DIR,SUB,QUE)) Q:QUE="" S ^TMP($J,"HLO QUEUES",QUE)="" + .S QUE="" + .S IOSL=$G(IOSL,20) + .S (COUNT,QUIT)=0 + .W ! + .F S QUE=$O(^TMP($J,"HLO QUEUES",QUE)) Q:QUE="" Q:QUIT D + ..W !,QUE + ..S COUNT=COUNT+1 + ..I COUNT>(IOSL-3) D + ...N Y + ...D PAUSE^VALM1 + ...I 'Y S QUIT=1 + ...S COUNT=0 + .W ! + .K ^TMP($J,"HLO QUEUES") + Q:$E(QUEUE)="?" "" + Q:$E(QUEUE)="^" "" + Q QUEUE + ; +ASKBEGIN(DEFAULT) ; + ;Description: Asks the user to enter a beginning date. + ;Input: DEFAULT - the suggested default dt/time (optional) + ;Output: Returns the date as the function value, or 0 if the user does not select a date + ; + ; + N %DT + S %DT="AEST" + S %DT("A")="Enter the beginning date/time: " + S %DT("B")=$$FMTE^XLFDT($S($L($G(DEFAULT)):DEFAULT,1:$$FMADD^XLFDT(DT,-1))) + S %DT(0)="-NOW" + Q:$D(DTOUT) 0 + D ^%DT + I Y=-1 Q 0 + Q Y + ; +ASKEND(BEGIN) ; + ;Description: Asks the user to enter an ending date/time + ;Input: BEGIN - the earliest date/time allowed + ;Output: Returns the date as the function value, or 0 if the user does not select a date/time + ; + N %DT + S %DT="AEST" + S %DT("A")="Enter the ending date/time: " + S %DT("B")="NOW" + S %DT(0)=BEGIN + Q:$D(DTOUT) 0 + D ^%DT + I Y=-1 Q 0 + Q Y + ; +LJ(STRING,LEN) ; + Q $$LJ^XLFSTR(STRING,LEN) + ; +I() ; + S VALMCNT=VALMCNT+1 + Q VALMCNT + ; +HEADER ; + Q diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLTF.m b/r/HEALTH_LEVEL_SEVEN-HL/HLTF.m index 3441a3dc..6b3cbfcb 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLTF.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLTF.m @@ -1,189 +1,231 @@ -HLTF ;AISC/SAW,JRP-Create/Process Message Text File Entries ;10/17/2007 09:41 - ;;1.6;HEALTH LEVEL SEVEN;**1,19,43,55,109,120,122**;Oct 13, 1995;Build 14 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; - Q - ; -FILE ;Create Entries in files 772 and 773 for Version 1.5 Interface Only - D CREATE(,.HLDA,.HLDT,.HLDT1) - Q -CREATE(HLMID,MTIEN,HLDT,HLDT1) ;Create entries in Message Text (#772) - ; - ;Input : HLMID = Variable in which value of message ID will be - ; returned (pass by reference) - ; MTIEN = Variable in which IEN of Message Text file entry - ; will be returned (pass by reference) - ; HLDT = Variable in which current date/time in FM internal - ; format will be returned (pass by reference) - ; HLDT1 = Variable in which current date/time in HL7 format - ; will be returned (pass by reference) - ; - ;Output : See above - ; - ;Notes : If HLDT has a value [upon entry], the created entries will - ; be given that value for their date/time (value of .01) - ; : Current date/time used if HLDT is not passed or invalid - ; - ;Make entry in Message Administration file - N Y - S HLDT=$G(HLDT) - D MT(.HLDT) - S Y=$$CHNGMID(MTIEN,.HLMID),HLDT1=$$HLDATE^HLFNC(HLDT) - Q -TCP(HLMID,MTIEN,HLDT) ;create new message in 772 & 773 entries - ;used for incoming messages and outgoing responses - ;Input : HLMID = Variable in which value of message ID will be - ; returned (pass by reference) - ; MTIEN = Variable in which IEN of file 773 entry - ; will be returned (pass by reference) - ; HLDT = Variable in which current date/time in FM internal - ; format will be returned (pass by reference) - ; - S HLDT=$G(HLDT),HLMID=$G(HLMID) - D MT(.HLDT) - S MTIEN=$$MA(MTIEN,.HLMID) - Q - ; -MT(HLX) ;Create entry in Message Text file (#772) - ; - ;Input : HLX = Date/time entry in file should be given (value of .01) - ; Defaults to current date/time - ; - ;Output : HLDT = Date/time of created entry (value of .01) - ; : HLDT1 = HLDT in HL7 format - ; - ;Notes : HLX must be in FileMan format (default value used if not) - ; : HLDT will be in FileMan format - ; : MTIEN is ien in file 772 - ; - ;Check for input - S HLX=$G(HLX) - ;Declare variables - N DIC,DD,DO,HLCNT,HLJ,X,Y - F HLCNT=0:1 D Q:Y>0 H HLCNT - . I (HLX'?7N.1".".6N) S HLX=$$NOW^XLFDT - . S DIC="^HL(772,",DIC(0)="L",(HLDT,X)=HLX - . S Y=$$STUB772(X) ; This call substituted for D FILE^DICN by HL*1.6*109 - . ;Entry not created - try again - . I Y<0 S HLX="" Q - . S MTIEN=+Y - ;***If we didn't get a record in 772, need to do something - I Y<0 Q - S HLDT1=$$HLDATE^HLFNC(HLDT) - Q - ;add to Message Admin file #773 -MA(X,HLMID) ;X=ien in file 772, HLMID=msg. id (passed by ref.) - ;return ien in file 773 - ; - ; patch HL*1.6*122: MPI-client/server start - F L +^HL(772,+$G(X)):10 Q:$T H 1 - Q:'$G(^HL(772,X,0)) 0 - L -^HL(772,+$G(X)) - ; patch HL*1.6*122: MPI-client/server end - ; - N DA,DD,DO,DIC,DIE,DR,HLDA,HLCNT,HLJ,Y - S DIC="^HLMA(",DIC(0)="L" - F HLCNT=0:1 D Q:Y>0 H HLCNT - . S Y=$$STUB773(X) ; This call substituted for D FILE^DICN by HL*1.6*109 - ;***If we didn't get a record in 773, need to do something - I Y<0 Q 0 - S HLDA=+Y,HLMID=$$MAID(HLDA,$G(HLMID)) - Q HLDA - ; -MAID(Y,HLMID) ;Determine message ID (if needed) & store message ID - ;Y=ien in 773, HLMID=id, Output message id - N HLJ - ;need to have id contain institution number to make unique - S:$G(HLMID)="" HLMID=+$P($$PARAM^HLCS2,U,6)_Y - S HLJ(773,Y_",",2)=HLMID - D FILE^HLDIE("","HLJ","","MAID","HLTF") ;HL*1.6*109 - Q HLMID - ; -CHNGMID(PTRMT,NEWID) ;Change message ID for entry in Message Text file - ;Input : PTRMT - Pointer to entry in Message Text file (#772) - ; NEWID - New message ID - ;Output : 0 = Success - ; -1^ErrorText = Error/Bad input - ; - ;Check input - S PTRMT=+$G(PTRMT) - S NEWID=$G(NEWID) - Q:('$D(^HL(772,PTRMT,0))) "-1^Did not pass valid pointer to Message Text file (#772)" - N HLJ - I $G(NEWID)="" S NEWID=+$P($$PARAM^HLCS2,U,6)_PTRMT - S HLJ(772,PTRMT_",",6)=NEWID - D FILE^HLDIE("","HLJ","","CHNGMID","HLTF") ; HL*1.6*109 - Q 0 - ; -OUT(HLDA,HLMID,HLMTN) ;File Data in Message Text File for Outgoing Message - ;Version 1.5 Interface Only - ; - ; patch HL*1.6*122: HLTF routine splitted, moves sub-routines, - ; OUT, IN, and ACK to HLTF2 routine. - ; - D OUT^HLTF2($G(HLDA),$G(HLMID),$G(HLMTN)) - Q - ; -IN(HLMTN,HLMID,HLTIME) ;File Data in Message Text File for Incoming Message - ;Version 1.5 Interface Only - ; - ; patch HL*1.6*122: HLTF routine splitted, moves sub-routines, - ; OUT, IN, and ACK to HLTF2 routine. - ; - D IN^HLTF2($G(HLMTN),$G(HLMID),$G(HLTIME)) - Q - ; -ACK(HLMSA,HLIO,HLDA) ;Process 'ACK' Message Type - Version 1.5 Interface Only - ; - ; patch HL*1.6*122: HLTF routine splitted, moves sub-routines, - ; OUT, IN, and ACK to HLTF2 routine. - ; - D ACK^HLTF2($G(HLMSA),$G(HLIO),$G(HLDA)) - Q - ; -STUB772(FLD01,OS) ; - ;This function creates a new stub record in file 772. The Stub record may consist of only the 0 node with a value of "^". If a value is passed in for the .01 field it will be included in the 0 node and its "B" x-ref set. - ;Inputs: - ; OS (optional), the value of ^%ZOSF("OS") - ; FLD01 (optional), the value for the .01 field - ;Output - the function returns the ien of the newly created record - ; - N IEN - I '$L($G(OS)) N OS S OS=$G(^%ZOSF("OS")) - ; - I OS'["DSM",OS'["OpenM" D - .F L +^HLCS(869.3,1,772):10 S IEN=+$G(^HLCS(869.3,1,772))+1,^HLCS(869.3,1,772)=IEN S:$D(^HL(772,IEN)) IEN=0,^HLCS(869.3,1,772)=($O(^HL(772,":"),-1)\1) L -^HLCS(869.3,1,772) Q:IEN - E D - .F S IEN=$I(^HLCS(869.3,1,772),1) S:$D(^HL(772,IEN)) IEN=0,^HLCS(869.3,1,772)=($O(^HL(772,":"),-1)\1) Q:IEN - ; - ; patch HL*1.6*122: MPI-client/server start - F L +^HL(772,IEN):10 Q:$T H 1 - S ^HL(772,IEN,0)=$G(FLD01)_"^" - I $L($G(FLD01)) S ^HL(772,"B",FLD01,IEN)="" - L -^HL(772,IEN) - ; patch HL*1.6*122: MPI-client/server end - ; - Q IEN - ; -STUB773(FLD01,OS) ; - ;This function creates a new stub record in file 772. The Stub record may consist of only the 0 node with a value of "^". If a value is passed in for the .01 field it will be included in the 0 node and its "B" x-ref set. - ;Inputs: - ; OS (optional), the value of ^%ZOSF("OS") - ; FLD01 (optional), the value for the .01 field - ;Output - the function returns the ien of the newly created record - ; - N IEN - I '$L($G(OS)) N OS S OS=$G(^%ZOSF("OS")) - ; - I OS'["DSM",OS'["OpenM" D - .F L +^HLCS(869.3,1,773):10 S IEN=+$G(^HLCS(869.3,1,773))+1,^HLCS(869.3,1,773)=IEN S:$D(^HLMA(IEN)) IEN=0,^HLCS(869.3,1,773)=($O(^HLMA(":"),-1)\1) L -^HLCS(869.3,1,773) Q:IEN - E D - .F S IEN=$I(^HLCS(869.3,1,773),1) S:$D(^HLMA(IEN)) IEN=0,^HLCS(869.3,1,773)=($O(^HLMA(":"),-1)\1) Q:IEN - ; - ; patch HL*1.6*122: MPI-client/server - F L +^HLMA(IEN):10 Q:$T H 1 - S ^HLMA(IEN,0)=$G(FLD01)_"^" - I $L($G(FLD01)) S ^HLMA("B",FLD01,IEN)="" - L -^HLMA(IEN) - ; - Q IEN +HLTF ;AISC/SAW,JRP-Create/Process Message Text File Entries ;01/23/06 12:56 + ;;1.6;HEALTH LEVEL SEVEN;**1,19,43,55,109,120**;Oct 13, 1995;Build 12 +FILE ;Create Entries in files 772 and 773 for Version 1.5 Interface Only + D CREATE(,.HLDA,.HLDT,.HLDT1) + Q +CREATE(HLMID,MTIEN,HLDT,HLDT1) ;Create entries in Message Text (#772) + ; + ;Input : HLMID = Variable in which value of message ID will be + ; returned (pass by reference) + ; MTIEN = Variable in which IEN of Message Text file entry + ; will be returned (pass by reference) + ; HLDT = Variable in which current date/time in FM internal + ; format will be returned (pass by reference) + ; HLDT1 = Variable in which current date/time in HL7 format + ; will be returned (pass by reference) + ; + ;Output : See above + ; + ;Notes : If HLDT has a value [upon entry], the created entries will + ; be given that value for their date/time (value of .01) + ; : Current date/time used if HLDT is not passed or invalid + ; + ;Make entry in Message Administration file + N Y + S HLDT=$G(HLDT) + D MT(.HLDT) + S Y=$$CHNGMID(MTIEN,.HLMID),HLDT1=$$HLDATE^HLFNC(HLDT) + Q +TCP(HLMID,MTIEN,HLDT) ;create new message in 772 & 773 entries + ;used for incoming messages and outgoing responses + ;Input : HLMID = Variable in which value of message ID will be + ; returned (pass by reference) + ; MTIEN = Variable in which IEN of file 773 entry + ; will be returned (pass by reference) + ; HLDT = Variable in which current date/time in FM internal + ; format will be returned (pass by reference) + ; + S HLDT=$G(HLDT),HLMID=$G(HLMID) + D MT(.HLDT) + S MTIEN=$$MA(MTIEN,.HLMID) + Q + ; +MT(HLX) ;Create entry in Message Text file (#772) + ; + ;Input : HLX = Date/time entry in file should be given (value of .01) + ; Defaults to current date/time + ; + ;Output : HLDT = Date/time of created entry (value of .01) + ; : HLDT1 = HLDT in HL7 format + ; + ;Notes : HLX must be in FileMan format (default value used if not) + ; : HLDT will be in FileMan format + ; : MTIEN is ien in file 772 + ; + ;Check for input + S HLX=$G(HLX) + ;Declare variables + N DIC,DD,DO,HLCNT,HLJ,X,Y + F HLCNT=0:1 D Q:Y>0 H HLCNT + . I (HLX'?7N.1".".6N) S HLX=$$NOW^XLFDT + . S DIC="^HL(772,",DIC(0)="L",(HLDT,X)=HLX + . S Y=$$STUB772(X) ; This call substituted for D FILE^DICN by HL*1.6*109 + . ;Entry not created - try again + . I Y<0 S HLX="" Q + . S MTIEN=+Y + ;***If we didn't get a record in 772, need to do something + I Y<0 Q + S HLDT1=$$HLDATE^HLFNC(HLDT) + Q + ;add to Message Admin file #773 +MA(X,HLMID) ;X=ien in file 772, HLMID=msg. id (passed by ref.) + ;return ien in file 773 + Q:'$G(^HL(772,X,0)) 0 + N DA,DD,DO,DIC,DIE,DR,HLDA,HLCNT,HLJ,Y + S DIC="^HLMA(",DIC(0)="L" + F HLCNT=0:1 D Q:Y>0 H HLCNT + . S Y=$$STUB773(X) ; This call substituted for D FILE^DICN by HL*1.6*109 + ;***If we didn't get a record in 773, need to do something + I Y<0 Q 0 + S HLDA=+Y,HLMID=$$MAID(HLDA,$G(HLMID)) + Q HLDA + ; +MAID(Y,HLMID) ;Determine message ID (if needed) & store message ID + ;Y=ien in 773, HLMID=id, Output message id + N HLJ + ;need to have id contain institution number to make unique + S:$G(HLMID)="" HLMID=+$P($$PARAM^HLCS2,U,6)_Y + S HLJ(773,Y_",",2)=HLMID + D FILE^HLDIE("","HLJ","","MAID","HLTF") ;HL*1.6*109 + Q HLMID + ; +CHNGMID(PTRMT,NEWID) ;Change message ID for entry in Message Text file + ;Input : PTRMT - Pointer to entry in Message Text file (#772) + ; NEWID - New message ID + ;Output : 0 = Success + ; -1^ErrorText = Error/Bad input + ; + ;Check input + S PTRMT=+$G(PTRMT) + S NEWID=$G(NEWID) + Q:('$D(^HL(772,PTRMT,0))) "-1^Did not pass valid pointer to Message Text file (#772)" + N HLJ + I $G(NEWID)="" S NEWID=+$P($$PARAM^HLCS2,U,6)_PTRMT + S HLJ(772,PTRMT_",",6)=NEWID + D FILE^HLDIE("","HLJ","","CHNGMID","HLTF") ; HL*1.6*109 + Q 0 + ; +OUT(HLDA,HLMID,HLMTN) ;File Data in Message Text File for Outgoing Message + ;Version 1.5 Interface Only + Q:'$D(HLFS) + ; + I HLMTN="ACK"!(HLMTN="MCF")!(HLMTN="ORR") Q:'$D(HLMSA) D ACK(HLMSA,"I") Q + ; + ;-- if message contained MSA find inbound message + I $D(HLMSA),$D(HLNDAP),$P(HLMSA,HLFS,3)]"" D + . N HLDAI + . S HLDAI=0 + . F S HLDAI=$O(^HL(772,"AH",+$P($G(HLNDAP0),U,12),$P(HLMSA,HLFS,3),HLDAI)) Q:'HLDAI!($P($G(^HL(772,+HLDAI,0)),U,4)="I") + . I 'HLDAI K HLDAI + ; + D STUFF^HLTF0("O") + ; + N HLAC S HLAC=$S($D(HLERR):4,'$P(HLNDAP0,"^",10):1,1:2) D STATUS^HLTF0(HLDA,HLAC,$G(HLMSG)) + D:$D(HLCHAR) STATS^HLTF0(HLDA,HLCHAR,$G(HLEVN)) + ; + ;-- update status if MSA and found inbound message + I $D(HLMSA),$D(HLDAI) D + .N HLERR,HLMSG I $P(HLMSA,HLFS,4)]"" S HLERR=$P(HLMSA,HLFS,4) + .S HLAC=$P(HLMSA,HLFS,2) + .I HLAC'="AA" S HLMSG=$S(HLAC="AR":"Application Reject",HLAC="AE":"Application Error",1:"")_" - "_HLERR + .S HLAC=$S(HLAC'="AA":4,1:3) D STATUS^HLTF0(HLDAI,HLAC,$G(HLMSG)) + Q + ; +IN(HLMTN,HLMID,HLTIME) ;File Data in Message Text File for Incoming Message + ;Version 1.5 Interface Only + Q:'$D(HLFS) + I HLMTN="ACK"!(HLMTN="MCF")!(HLMTN="ORR") Q:'$D(HLMSA) D ACK(HLMSA,"O",$G(HLDA)) Q + ; + N HLDAI S HLDA=0 + I $D(HLNDAP),HLMID]"" D + .F S HLDA=+$O(^HL(772,"AH",+$P($G(HLNDAP0),U,12),HLMID,HLDA)) Q:'HLDA!($P($G(^HL(772,+HLDA,0)),U,4)="I") + .I HLDA D + ..S HLDT=+$P($G(^HL(772,HLDA,0)),"^"),HLDT1=$$HLDATE^HLFNC(HLDT) + ..K ^HL(772,HLDA,"IN") + .I $D(HLMSA),$P(HLMSA,HLFS,3)]"" D + ..S HLDAI=0 + ..F S HLDAI=$O(^HL(772,"AH",+$P($G(HLNDAP0),U,12),$P(HLMSA,HLFS,3),HLDAI)) Q:'HLDAI!($P($G(^HL(772,+HLDAI,0)),U,4)="O") + ..I 'HLDAI K HLDAI + ; + I 'HLDA D CREATE(.HLMID,.HLDA,.HLDT,.HLDT1) K HLZ + ; + D STUFF^HLTF0("I") + N HLAC S HLAC=$S($D(HLERR):4,1:1) D STATUS^HLTF0(HLDA,HLAC,$G(HLMSG)) + ; + D MERGE15^HLTF1("G",HLDA,"HLR",HLTIME) + ; + I '$D(HLERR),$D(HLMSA),$D(HLDAI) D + .N HLAC,HLERR,HLMSG I $P(HLMSA,HLFS,4)]"" S HLERR=$P(HLMSA,HLFS,4) + .S HLAC=$P(HLMSA,HLFS,2) I HLAC'="AA" S HLMSG=$S(HLAC="AR":"Application Reject",1:"Application Error")_" - "_HLERR + .S HLAC=$S(HLAC'="AA":4,1:3) D STATUS^HLTF0(HLDAI,HLAC,$G(HLMSG)) + Q + ; +ACK(HLMSA,HLIO,HLDA) ;Process 'ACK' Message Type - Version 1.5 Interface Only + ; To determine the correct message to link the ACK, HLIO is used. + ; For an ack from DHCP (original message from remote system) then + ; HLIO should be "I" so that the correct inbound message is ack-ed. For + ; an inbound ack (original message outbound from DHCP) HLIO should be + ; "O". This distinction must be made due to the possible duplicate + ; message ids from a bi-direction interface. + ; + ; Input : MSA - MSA from ACK message. + ; HLIO - Either "I" or "O" : See note above. + ;Output : None + ; + N HLAC,HLMIDI + ;-- set up required vars + S HLAC=$P(HLMSA,HLFS,2),HLMIDI=$P(HLMSA,HLFS,3) + ;-- quit + Q:HLMIDI']""!(HLAC']"")!('$D(HLNDAP)) + ;-- find message to ack + I '$G(HLDA) S HLDA=0 D + . F S HLDA=+$O(^HL(772,"AH",+$P($G(HLNDAP0),U,12),HLMIDI,HLDA)) Q:'HLDA!($P($G(^HL(772,+HLDA,0)),U,4)=HLIO) + ;-- quit if no message + Q:'$D(^HL(772,+HLDA,0)) + ;-- check for error + I $P(HLMSA,HLFS,4)]"" N HLERR S HLERR=$P(HLMSA,HLFS,4) + I $D(HLERR),'$D(HLMSG) N HLMSG S HLMSG="Error During Receipt of Acknowledgement Message"_$S(HLAC="AR":" - Application Reject",HLAC="AE":" - Application Error",1:"")_" - "_HLERR + ;-- update status + S HLAC=$S(HLMTN="MCF":2,HLAC'="AA":4,1:3) + D STATUS^HLTF0(HLDA,HLAC,$G(HLMSG)) + Q + ; +STUB772(FLD01,OS) ; + ;This function creates a new stub record in file 772. The Stub record may consist of only the 0 node with a value of "^". If a value is passed in for the .01 field it will be included in the 0 node and its "B" x-ref set. + ;Inputs: + ; OS (optional), the value of ^%ZOSF("OS") + ; FLD01 (optional), the value for the .01 field + ;Output - the function returns the ien of the newly created record + ; + N IEN + I '$L($G(OS)) N OS S OS=$G(^%ZOSF("OS")) + ; + ; patch HL*1.6*120, protect Else command + ; I OS'["DSM",OS'["OpenM" D + I OS'["DSM",OS'["OpenM" D I 1 + .F L +^HLCS(869.3,1,772):10 S IEN=+$G(^HLCS(869.3,1,772))+1,^HLCS(869.3,1,772)=IEN S:$D(^HL(772,IEN)) IEN=0,^HLCS(869.3,1,772)=($O(^HL(772,":"),-1)\1) L -^HLCS(869.3,1,772) Q:IEN + E D + .F S IEN=$I(^HLCS(869.3,1,772),1) S:$D(^HL(772,IEN)) IEN=0,^HLCS(869.3,1,772)=($O(^HL(772,":"),-1)\1) Q:IEN + S ^HL(772,IEN,0)=$G(FLD01)_"^" + I $L($G(FLD01)) S ^HL(772,"B",FLD01,IEN)="" + Q IEN + ; +STUB773(FLD01,OS) ; + ;This function creates a new stub record in file 772. The Stub record may consist of only the 0 node with a value of "^". If a value is passed in for the .01 field it will be included in the 0 node and its "B" x-ref set. + ;Inputs: + ; OS (optional), the value of ^%ZOSF("OS") + ; FLD01 (optional), the value for the .01 field + ;Output - the function returns the ien of the newly created record + ; + N IEN + I '$L($G(OS)) N OS S OS=$G(^%ZOSF("OS")) + ; + ; patch HL*1.6*120, protect Else command + ; I OS'["DSM",OS'["OpenM" D + I OS'["DSM",OS'["OpenM" D I 1 + .F L +^HLCS(869.3,1,773):10 S IEN=+$G(^HLCS(869.3,1,773))+1,^HLCS(869.3,1,773)=IEN S:$D(^HLMA(IEN)) IEN=0,^HLCS(869.3,1,773)=($O(^HLMA(":"),-1)\1) L -^HLCS(869.3,1,773) Q:IEN + E D + .F S IEN=$I(^HLCS(869.3,1,773),1) S:$D(^HLMA(IEN)) IEN=0,^HLCS(869.3,1,773)=($O(^HLMA(":"),-1)\1) Q:IEN + S ^HLMA(IEN,0)=$G(FLD01)_"^" + I $L($G(FLD01)) S ^HLMA("B",FLD01,IEN)="" + Q IEN diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLTF1.m b/r/HEALTH_LEVEL_SEVEN-HL/HLTF1.m index b639817e..ec6a22ff 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLTF1.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLTF1.m @@ -1,161 +1,153 @@ -HLTF1 ;AISC/SAW/MTC-Process Message Text File Entries (Cont'd) ;10/17/2007 09:43 - ;;1.6;HEALTH LEVEL SEVEN;**5,8,22,25,19,78,122**;Oct 13, 1995;Build 14 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; -MERGE15(ARAYTYPE,MTIEN,SUB1,SUB2) ;Merge Local/Global Array From Application into - ;Message Text File - ; - ;This is a routine call with parameter passing. There are no output - ;parameters returned by this call. - ; - ;** Merges incoming data for v1.5 applications only ** - ; - ;Required input parameters - ; MTIEN = The IEN from the Message Text file of the entry to be - ; updated - ; ARAYTYPE = Array type, G for global or L for local - ; SUB1 = The first level subscript of the array. Must be - ; either HLS or HLA - ;Optional input parameter - ; SUB2 = A second subscript associated with the array - ; - ;Check for required parameters - I "GL"'[$G(ARAYTYPE)!($G(SUB1)']"")!('$G(MTIEN)) G MRGE15X - ; - N HLCHAR,HLEVN,HLFS,I,X,X1,X2,X3 S (HLCHAR,HLEVN,X)=0 - ; - ;Merge data from a global array with two subscript - I ARAYTYPE="G",$G(SUB2)'="" D - . S X="",I=0 - . F S X=$O(^TMP(SUB1,$J,SUB2,X)) Q:'X S I=I+1,X1=^TMP(SUB1,$J,SUB2,X),HLCHAR=HLCHAR+$L(X1) S:$E(X1,1,3)="MSH" HLFS=$E(X1,4),$P(X1,HLFS,8)="",HLEVN=HLEVN+1 S ^HL(772,MTIEN,"IN",I,0)=X1 - ; - ;Merge data from a global array with one subscripts - I ARAYTYPE="G",$G(SUB2)="" D - . S X="",I=0 - . F S X=$O(^TMP(SUB1,$J,X)) Q:'X S I=I+1,X1=^TMP(SUB1,$J,X),HLCHAR=HLCHAR+$L(X1) S:$E(X1,1,3)="MSH" HLFS=$E(X1,4),$P(X1,HLFS,8)="",HLEVN=HLEVN+1 S ^HL(772,MTIEN,"IN",I,0)=X1 - ; - ;Merge data from a local array with one subscript - I ARAYTYPE="L" D - . S X="",I=0 - . F S X=$O(HLA(SUB1,X)) Q:'X S I=I+1,X1=HLA(SUB1,X),HLCHAR=HLCHAR+$L(X1) S:$E(X1,1,3)="MSH" HLFS=$E(X1,4),$P(X1,HLFS,8)="",HLEVN=HLEVN+1 S ^HL(772,MTIEN,"IN",I,0)=X1 - ; - ;-- update 0 node for message text - S ^HL(772,MTIEN,"IN",0)="^^"_I_"^"_I_"^"_$$DT^XLFDT_"^" - ; - ;File message statistics - D STATS^HLTF0(MTIEN,HLCHAR,HLEVN) - ; -MRGE15X ;-- exit merge - Q - ; -MERGE(ARAYTYPE,MTIEN,SUB1,SUB2) ;Merge Local/Global Array From Application into - ;Message Text File - ; - ;This is a routine call with parameter passing. There are no output - ;parameters returned by this call. - ; - ;Required input parameters - ; MTIEN = The IEN from the Message Text file of the entry to be - ; updated - ; ARAYTYPE = Array type, G for global or L for local - ; SUB1 = The first level subscript of the array. Must be - ; either HLS or HLA - ;Optional input parameter - ; SUB2 = A second subscript associated with the array - ; - ;Check for required parameters - I "GL"'[$G(ARAYTYPE)!($G(SUB1)']"")!('$G(MTIEN)) G MERGEX - ; - N HLCHAR,HLEVN,HLFS,I,X,X1,X2,X3 S (HLCHAR,HLEVN,X)=0 - ; - ; patch HL*1.6*122: MPI-client/server - F L +^HL(772,+$G(MTIEN)):10 Q:$T H 1 - ; - ;Merge data from a global array with two subscript - I ARAYTYPE="G",$G(SUB2)'="" D - . S X="",I=0 - . F S X=$O(^TMP(SUB1,$J,SUB2,X)) Q:'X S I=I+1,X1=^TMP(SUB1,$J,SUB2,X),HLCHAR=HLCHAR+$L(X1) S:$E(X1,1,3)="MSH" HLFS=$E(X1,4),$P(X1,HLFS,8)="",HLEVN=HLEVN+1 S ^HL(772,MTIEN,"IN",I,0)=X1,X2=$D(^TMP(SUB1,$J,SUB2,X)) D - .. I X2=11 S X3="" F S X3=$O(^TMP(SUB1,$J,SUB2,X,X3)) Q:'X3 D - ... S I=I+1,X1=$G(^TMP(SUB1,$J,SUB2,X,X3)),HLCHAR=HLCHAR+$L(X1),^HL(772,MTIEN,"IN",I,0)=X1 - .. S I=I+1,^HL(772,MTIEN,"IN",I,0)="" Q - ; - ;Merge data from a global array with one subscripts - I ARAYTYPE="G",$G(SUB2)="" D - . S X="",I=0 - . F S X=$O(^TMP(SUB1,$J,X)) Q:'X S I=I+1,X1=^TMP(SUB1,$J,X),HLCHAR=HLCHAR+$L(X1) S:$E(X1,1,3)="MSH" HLFS=$E(X1,4),$P(X1,HLFS,8)="",HLEVN=HLEVN+1 S ^HL(772,MTIEN,"IN",I,0)=X1,X2=$D(^TMP(SUB1,$J,X)) D - .. I X2=11 S X3="" F S X3=$O(^TMP(SUB1,$J,X,X3)) Q:'X3 D - ... S I=I+1,X1=$G(^TMP(SUB1,$J,X,X3)),HLCHAR=HLCHAR+$L(X1),^HL(772,MTIEN,"IN",I,0)=X1 - .. S I=I+1,^HL(772,MTIEN,"IN",I,0)="" Q - ; - ;Merge data from a local array with one subscript - I ARAYTYPE="L" D - . S X="",I=0 - . F S X=$O(HLA(SUB1,X)) Q:'X S I=I+1,X1=HLA(SUB1,X),HLCHAR=HLCHAR+$L(X1) S:$E(X1,1,3)="MSH" HLFS=$E(X1,4),$P(X1,HLFS,8)="",HLEVN=HLEVN+1 S ^HL(772,MTIEN,"IN",I,0)=X1,X2=$D(HLA(SUB1,X)) D - .. I X2=11 S X3="" F S X3=$O(HLA(SUB1,X,X3)) Q:'X3 D - ... S I=I+1,X1=$G(HLA(SUB1,X,X3)),HLCHAR=HLCHAR+$L(X1),^HL(772,MTIEN,"IN",I,0)=X1 - .. S I=I+1,^HL(772,MTIEN,"IN",I,0)="" Q - ; - S:HLEVN=0 HLEVN=1 - ;X=ien in file 773 for TCP messages - S X=+$O(^HLMA("B",MTIEN,0)) - ;batch message type - I X,$P($G(^HLMA(X,0)),U,5)="B" D BTS - I 'X,$P(^HL(772,MTIEN,0),U,8),$P(^HL(772,$P(^(0),U,8),0),U,14)="B" D BTS - ; - ;-- update 0 node for message text - S ^HL(772,MTIEN,"IN",0)="^^"_I_"^"_I_"^"_$$DT^XLFDT_"^" - ; - ; patch HL*1.6*122: MPI-client/server - L -^HL(772,+$G(MTIEN)) - ; - ;File message statistics - D STATS^HLTF0(MTIEN,HLCHAR,HLEVN) - ; -MERGEX ;-- exit merge - Q - ; -BTS ; create batch trailer seg (BTS) - ;HL*1.6*78 to obtain and insert FIELD SEPARATOR, HLFS - N HLFS,HLSAN - S HLFS=$G(HL("FS")) ; obtain from HL array - ; or obtain from sending application; default to "^" - I HLFS="" D S:HLFS="" HLFS="^" - . S HLSAN=$P($G(^HL(772,MTIEN,0)),U,2) - . S:HLSAN HLFS=$G(^HL(771,HLSAN,"FS")) - S I=I+1,^HL(772,MTIEN,"IN",I,0)="BTS"_HLFS_HLEVN,I=I+1,^HL(772,MTIEN,"IN",I,0)="" - Q - ; -MRGINT(MTOUT,MTIN,HDR) ;Merge Internal to Internal Message from the - ; Outbound message in 772 (MTOUT) to an Inbound entry (MTIN). The process - ; will involve Moving the Header and Text into 772. - ; - ;Required input parameters - ; MTOUT= Internal entry number of the Outbound message - ; MTIN = Internal entry number of the Inbound message - ; HDR = Name of the array that contains HL7 Header segment - ; format: HLHDR - Used with indirection to build message in out - ; queue - ; This routine will first take the header information in the array - ; specified by HDR and merge into the Message Text field of file 870. - ; Then it will move the message contained in 772 (MTIEN) into 870. - ; - ;Check for required parameters - I '$G(MTOUT)!('$G(MTIN))!(HDR="") Q - ; - ;-- initilize - N I,X - S I=0 - ; - ;-- move header into 772 from HDR array - S X="" F S X=$O(@HDR@(X)) Q:'X D - . S I=I+1,^HL(772,MTIN,"IN",I,0)=@HDR@(X) - S I=I+1,^HL(772,MTIN,"IN",I,0)="" - ; - ;Move data from Message Text (MTOUT) file TO Message Text 772 (MTIN) - S X=0 F S X=$O(^HL(772,MTOUT,"IN",X)) Q:X="" S I=I+1 D - . S ^HL(772,MTIN,"IN",I,0)=$G(^HL(772,MTOUT,"IN",X,0)) - ; - ;-- update 0 node of message and format arrays - S ^HL(772,MTIN,"IN",0)="^^"_I_"^"_I_"^"_$$DT^XLFDT_"^" - ; - Q +HLTF1 ;AISC/SAW/MTC-Process Message Text File Entries (Cont'd) ;09/10/98 11:21 + ;;1.6;HEALTH LEVEL SEVEN;**5,8,22,25,19,78**;Oct 13, 1995 +MERGE15(ARAYTYPE,MTIEN,SUB1,SUB2) ;Merge Local/Global Array From Application into + ;Message Text File + ; + ;This is a routine call with parameter passing. There are no output + ;parameters returned by this call. + ; + ;** Merges incoming data for v1.5 applications only ** + ; + ;Required input parameters + ; MTIEN = The IEN from the Message Text file of the entry to be + ; updated + ; ARAYTYPE = Array type, G for global or L for local + ; SUB1 = The first level subscript of the array. Must be + ; either HLS or HLA + ;Optional input parameter + ; SUB2 = A second subscript associated with the array + ; + ;Check for required parameters + I "GL"'[$G(ARAYTYPE)!($G(SUB1)']"")!('$G(MTIEN)) G MRGE15X + ; + N HLCHAR,HLEVN,HLFS,I,X,X1,X2,X3 S (HLCHAR,HLEVN,X)=0 + ; + ;Merge data from a global array with two subscript + I ARAYTYPE="G",$G(SUB2)'="" D + . S X="",I=0 + . F S X=$O(^TMP(SUB1,$J,SUB2,X)) Q:'X S I=I+1,X1=^TMP(SUB1,$J,SUB2,X),HLCHAR=HLCHAR+$L(X1) S:$E(X1,1,3)="MSH" HLFS=$E(X1,4),$P(X1,HLFS,8)="",HLEVN=HLEVN+1 S ^HL(772,MTIEN,"IN",I,0)=X1 + ; + ;Merge data from a global array with one subscripts + I ARAYTYPE="G",$G(SUB2)="" D + . S X="",I=0 + . F S X=$O(^TMP(SUB1,$J,X)) Q:'X S I=I+1,X1=^TMP(SUB1,$J,X),HLCHAR=HLCHAR+$L(X1) S:$E(X1,1,3)="MSH" HLFS=$E(X1,4),$P(X1,HLFS,8)="",HLEVN=HLEVN+1 S ^HL(772,MTIEN,"IN",I,0)=X1 + ; + ;Merge data from a local array with one subscript + I ARAYTYPE="L" D + . S X="",I=0 + . F S X=$O(HLA(SUB1,X)) Q:'X S I=I+1,X1=HLA(SUB1,X),HLCHAR=HLCHAR+$L(X1) S:$E(X1,1,3)="MSH" HLFS=$E(X1,4),$P(X1,HLFS,8)="",HLEVN=HLEVN+1 S ^HL(772,MTIEN,"IN",I,0)=X1 + ; + ;-- update 0 node for message text + S ^HL(772,MTIEN,"IN",0)="^^"_I_"^"_I_"^"_$$DT^XLFDT_"^" + ; + ;File message statistics + D STATS^HLTF0(MTIEN,HLCHAR,HLEVN) + ; +MRGE15X ;-- exit merge + Q + ; +MERGE(ARAYTYPE,MTIEN,SUB1,SUB2) ;Merge Local/Global Array From Application into + ;Message Text File + ; + ;This is a routine call with parameter passing. There are no output + ;parameters returned by this call. + ; + ;Required input parameters + ; MTIEN = The IEN from the Message Text file of the entry to be + ; updated + ; ARAYTYPE = Array type, G for global or L for local + ; SUB1 = The first level subscript of the array. Must be + ; either HLS or HLA + ;Optional input parameter + ; SUB2 = A second subscript associated with the array + ; + ;Check for required parameters + I "GL"'[$G(ARAYTYPE)!($G(SUB1)']"")!('$G(MTIEN)) G MERGEX + ; + N HLCHAR,HLEVN,HLFS,I,X,X1,X2,X3 S (HLCHAR,HLEVN,X)=0 + ; + ;Merge data from a global array with two subscript + I ARAYTYPE="G",$G(SUB2)'="" D + . S X="",I=0 + . F S X=$O(^TMP(SUB1,$J,SUB2,X)) Q:'X S I=I+1,X1=^TMP(SUB1,$J,SUB2,X),HLCHAR=HLCHAR+$L(X1) S:$E(X1,1,3)="MSH" HLFS=$E(X1,4),$P(X1,HLFS,8)="",HLEVN=HLEVN+1 S ^HL(772,MTIEN,"IN",I,0)=X1,X2=$D(^TMP(SUB1,$J,SUB2,X)) D + .. I X2=11 S X3="" F S X3=$O(^TMP(SUB1,$J,SUB2,X,X3)) Q:'X3 D + ... S I=I+1,X1=$G(^TMP(SUB1,$J,SUB2,X,X3)),HLCHAR=HLCHAR+$L(X1),^HL(772,MTIEN,"IN",I,0)=X1 + .. S I=I+1,^HL(772,MTIEN,"IN",I,0)="" Q + ; + ;Merge data from a global array with one subscripts + I ARAYTYPE="G",$G(SUB2)="" D + . S X="",I=0 + . F S X=$O(^TMP(SUB1,$J,X)) Q:'X S I=I+1,X1=^TMP(SUB1,$J,X),HLCHAR=HLCHAR+$L(X1) S:$E(X1,1,3)="MSH" HLFS=$E(X1,4),$P(X1,HLFS,8)="",HLEVN=HLEVN+1 S ^HL(772,MTIEN,"IN",I,0)=X1,X2=$D(^TMP(SUB1,$J,X)) D + .. I X2=11 S X3="" F S X3=$O(^TMP(SUB1,$J,X,X3)) Q:'X3 D + ... S I=I+1,X1=$G(^TMP(SUB1,$J,X,X3)),HLCHAR=HLCHAR+$L(X1),^HL(772,MTIEN,"IN",I,0)=X1 + .. S I=I+1,^HL(772,MTIEN,"IN",I,0)="" Q + ; + ;Merge data from a local array with one subscript + I ARAYTYPE="L" D + . S X="",I=0 + . F S X=$O(HLA(SUB1,X)) Q:'X S I=I+1,X1=HLA(SUB1,X),HLCHAR=HLCHAR+$L(X1) S:$E(X1,1,3)="MSH" HLFS=$E(X1,4),$P(X1,HLFS,8)="",HLEVN=HLEVN+1 S ^HL(772,MTIEN,"IN",I,0)=X1,X2=$D(HLA(SUB1,X)) D + .. I X2=11 S X3="" F S X3=$O(HLA(SUB1,X,X3)) Q:'X3 D + ... S I=I+1,X1=$G(HLA(SUB1,X,X3)),HLCHAR=HLCHAR+$L(X1),^HL(772,MTIEN,"IN",I,0)=X1 + .. S I=I+1,^HL(772,MTIEN,"IN",I,0)="" Q + ; + S:HLEVN=0 HLEVN=1 + ;X=ien in file 773 for TCP messages + S X=+$O(^HLMA("B",MTIEN,0)) + ;batch message type + I X,$P($G(^HLMA(X,0)),U,5)="B" D BTS + I 'X,$P(^HL(772,MTIEN,0),U,8),$P(^HL(772,$P(^(0),U,8),0),U,14)="B" D BTS + ; + ;-- update 0 node for message text + S ^HL(772,MTIEN,"IN",0)="^^"_I_"^"_I_"^"_$$DT^XLFDT_"^" + ; + ;File message statistics + D STATS^HLTF0(MTIEN,HLCHAR,HLEVN) + ; +MERGEX ;-- exit merge + Q + ; +BTS ; create batch trailer seg (BTS) + ;HL*1.6*78 to obtain and insert FIELD SEPARATOR, HLFS + N HLFS,HLSAN + S HLFS=$G(HL("FS")) ; obtain from HL array + ; or obtain from sending application; default to "^" + I HLFS="" D S:HLFS="" HLFS="^" + . S HLSAN=$P($G(^HL(772,MTIEN,0)),U,2) + . S:HLSAN HLFS=$G(^HL(771,HLSAN,"FS")) + S I=I+1,^HL(772,MTIEN,"IN",I,0)="BTS"_HLFS_HLEVN,I=I+1,^HL(772,MTIEN,"IN",I,0)="" + Q + ; +MRGINT(MTOUT,MTIN,HDR) ;Merge Internal to Internal Message from the + ; Outbound message in 772 (MTOUT) to an Inbound entry (MTIN). The process + ; will involve Moving the Header and Text into 772. + ; + ;Required input parameters + ; MTOUT= Internal entry number of the Outbound message + ; MTIN = Internal entry number of the Inbound message + ; HDR = Name of the array that contains HL7 Header segment + ; format: HLHDR - Used with indirection to build message in out + ; queue + ; This routine will first take the header information in the array + ; specified by HDR and merge into the Message Text field of file 870. + ; Then it will move the message contained in 772 (MTIEN) into 870. + ; + ;Check for required parameters + I '$G(MTOUT)!('$G(MTIN))!(HDR="") Q + ; + ;-- initilize + N I,X + S I=0 + ; + ;-- move header into 772 from HDR array + S X="" F S X=$O(@HDR@(X)) Q:'X D + . S I=I+1,^HL(772,MTIN,"IN",I,0)=@HDR@(X) + S I=I+1,^HL(772,MTIN,"IN",I,0)="" + ; + ;Move data from Message Text (MTOUT) file TO Message Text 772 (MTIN) + S X=0 F S X=$O(^HL(772,MTOUT,"IN",X)) Q:X="" S I=I+1 D + . S ^HL(772,MTIN,"IN",I,0)=$G(^HL(772,MTOUT,"IN",X,0)) + ; + ;-- update 0 node of message and format arrays + S ^HL(772,MTIN,"IN",0)="^^"_I_"^"_I_"^"_$$DT^XLFDT_"^" + ; + Q diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLTF2.m b/r/HEALTH_LEVEL_SEVEN-HL/HLTF2.m index 7501ecc9..b36358ce 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLTF2.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLTF2.m @@ -1,208 +1,94 @@ -HLTF2 ;AISC/SAW/MTC-Process Message Text File Entries (Cont'd) ;10/17/2007 09:44 - ;;1.6;HEALTH LEVEL SEVEN;**25,122**;Oct 13, 1995;Build 14 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; -MERGEIN(LLD0,LLD1,MTIEN,HDR,MSA) ;Merge Data From Communication Server - ;Module Logical Link File into Message Text File - ; - ;This is a subroutine call with parameter passing. The output - ;parameters HDR (and optionally) MSA are returned by this call. - ; - ;Required input parameters - ; LLD0 = Internal entry number where message is stored in Logical Link - ; file or XM if message is stored in MailMan - ; LLD1 = Internal entry number of IN QUEUE multiple entry in Logical - ; Link file (Only required for messages stored in Logical - ; Link file) - ; MTIEN = Internal entry number where message is to be copied to in - ; Message Text file - ; HDR = The variable in which the message header segment will - ; be returned - ; MSA = The variable in which the message acknowledgement segment - ; will be returned, if one exists for this message - ; - ;Check for required parameters - I $G(LLD0)']""!('$G(MTIEN)) Q - I LLD0'="XM",'$G(LLD1) Q - N FLG,HLCHAR,HLEVN,HLFS,I,X,X1,HLDONE - S (FLG,HLCHAR,HLEVN,X)=0 - ; - ; patch HL*1.6*122: MPI-client/server - F L +^HL(772,+$G(MTIEN)):10 Q:$T H 1 - ; - ;Move data from Logical Link file to Message Text file - I LLD0'="XM" D - .S I=0 F S X=$O(^HLCS(870,LLD0,1,LLD1,1,X)) Q:X'>0 S X1=$G(^(X,0)) S:"FHS,BHS,MSH"[$E(X1,1,3) FLG=1 I FLG S HLCHAR=HLCHAR+$L(X1) D - ..;If header segment, process it and set HDR equal to it - ..I X1'="","FHS,BHS,MSH"[$E(X1,1,3) D - ...I '$D(HDR) S HDR=X1,HLFS=$E(X1,4) I $E(HDR,1,3)="BHS" S MSA="MSA"_HLFS_$P($P(HDR,HLFS,10),$E(HDR,5),1)_HLFS_$P(HDR,HLFS,12)_HLFS_$P($P(HDR,HLFS,10),$E(HDR,5),2) - ...S $P(X1,HLFS,8)="" - ...S:$E(X1,1,3)="MSH" HLEVN=HLEVN+1 - ..;If acknowledgement segment, set MSA equal to it - ..I $E(X1,1,3)="MSA",'$D(MSA),$E($G(HDR),1,3)="MSH" S MSA=X1 - ..S I=I+1,^HL(772,MTIEN,"IN",I,0)=X1 - ; - ;Move data from MailMan Message file to Message Text file - I LLD0="XM" D - .S I=0 F X XMREC Q:XMER<0 S:"FHS,BHS,MSH"[$E(XMRG,1,3) FLG=1 I FLG S HLCHAR=HLCHAR+$L(XMRG) D Q:XMER<0 - ..;If header segment, process it and set HDR equal to it - ..I XMRG'="","FHS,BHS,MSH"[$E(XMRG,1,3) D - ...I '$D(HDR) S HDR=XMRG,HLFS=$E(XMRG,4) I $E(HDR,1,3)="BHS" S MSA="MSA"_HLFS_$P($P(HDR,HLFS,10),$E(HDR,5),1)_HLFS_$P(HDR,HLFS,12)_HLFS_$P($P(HDR,HLFS,10),$E(HDR,5),2) - ...S $P(XMRG,HLFS,8)="" - ...S:$E(XMRG,1,3)="MSH" HLEVN=HLEVN+1 - ..;If acknowledgement segment, set MSA equal to it - ..I $E(XMRG,1,3)="MSA",'$D(MSA),$E($G(HDR),1,3)="MSH" S MSA=XMRG - ..S I=I+1,^HL(772,MTIEN,"IN",I,0)=XMRG - S ^HL(772,MTIEN,"IN",0)="^^"_I_"^"_I_"^"_$$DT^XLFDT_"^" - ;Update statistics in Message Text file for this entry - ; - ; patch HL*1.6*122: MPI-client/server - L -^HL(772,+$G(MTIEN)) - ; - D STATS^HLTF0(MTIEN,HLCHAR,HLEVN) - Q -MERGEOUT(MTIEN,LLD0,LLD1,HDR) ;Merge Text in Message Text File into - ;Communication Server Module Logical Link File - ; - ;This is a routine call with parameter passing. There are no output - ;parameters returned by this call. - ; - ;Required input parameters - ; MTIEN = Internal entry number where message is stored in Message - ; Text file - ; LLD0 = Internal entry number where message is to be copied to in - ; Logical Link file - ; LLD1 = Internal entry number of IN QUEUE multiple entry in Logical - ; Link file - ; HDR = Name of the array that contains HL7 Header segment - ; format: HLHDR - Used with indirection to build message in out - ; queue - ; This routine will first take the header information in the array - ; specified by HDR and merge into the Message Text field of file 870. - ; Then it will move the message contained in 772 (MTIEN) into 870. - ; - ;Check for required parameters - I '$G(MTIEN)!('$G(LLD0))!('$G(LLD1))!(HDR="") Q - ; - ;-- initilize - N I,X - S I=0 - ; - ; patch HL*1.6*122: MPI-client/server - F L +^HLCS(870,+$G(LLD0),2,+$G(LLD1)):10 Q:$T H 1 - ; - ;-- move header into 870 from HDR array - S X="" F S X=$O(@HDR@(X)) Q:'X D - . S I=I+1,^HLCS(870,LLD0,2,LLD1,1,I,0)=@HDR@(X) - S I=I+1,^HLCS(870,LLD0,2,LLD1,1,I,0)="" - ; - ;Move data from Message Text file to Logical Link file - S X=0 F S X=$O(^HL(772,MTIEN,"IN",X)) Q:X="" D - . S I=I+1,^HLCS(870,LLD0,2,LLD1,1,I,0)=$G(^HL(772,MTIEN,"IN",X,0)) - ; - ;-- update 0 node of message and format arrays - S ^HLCS(870,LLD0,2,LLD1,1,0)="^^"_I_"^"_I_"^"_$$DT^XLFDT_"^" - ; - ; patch HL*1.6*122: MPI-client/server - L -^HLCS(870,+$G(LLD0),2,+$G(LLD1)) - ; - Q -OUT(HLDA,HLMID,HLMTN) ;File Data in Message Text File for Outgoing Message - ;Version 1.5 Interface Only - ; - ; patch HL*1.6*122: HLTF routine splitted, moves sub-routines, - ; OUT, IN, and ACK to HLTF2 routine. - ; - Q:'$D(HLFS) - ; - I HLMTN="ACK"!(HLMTN="MCF")!(HLMTN="ORR") Q:'$D(HLMSA) D ACK(HLMSA,"I") Q - ; - ;-- if message contained MSA find inbound message - I $D(HLMSA),$D(HLNDAP),$P(HLMSA,HLFS,3)]"" D - . N HLDAI - . S HLDAI=0 - . F S HLDAI=$O(^HL(772,"AH",+$P($G(HLNDAP0),U,12),$P(HLMSA,HLFS,3),HLDAI)) Q:'HLDAI!($P($G(^HL(772,+HLDAI,0)),U,4)="I") - . I 'HLDAI K HLDAI - ; - D STUFF^HLTF0("O") - ; - N HLAC S HLAC=$S($D(HLERR):4,'$P(HLNDAP0,"^",10):1,1:2) D STATUS^HLTF0(HLDA,HLAC,$G(HLMSG)) - D:$D(HLCHAR) STATS^HLTF0(HLDA,HLCHAR,$G(HLEVN)) - ; - ;-- update status if MSA and found inbound message - I $D(HLMSA),$D(HLDAI) D - .N HLERR,HLMSG I $P(HLMSA,HLFS,4)]"" S HLERR=$P(HLMSA,HLFS,4) - .S HLAC=$P(HLMSA,HLFS,2) - .I HLAC'="AA" S HLMSG=$S(HLAC="AR":"Application Reject",HLAC="AE":"Application Error",1:"")_" - "_HLERR - .S HLAC=$S(HLAC'="AA":4,1:3) D STATUS^HLTF0(HLDAI,HLAC,$G(HLMSG)) - Q - ; -IN(HLMTN,HLMID,HLTIME) ;File Data in Message Text File for Incoming Message - ;Version 1.5 Interface Only - ; - ; patch HL*1.6*122: HLTF routine splitted, moves sub-routines, - ; OUT, IN, and ACK to HLTF2 routine. - ; - Q:'$D(HLFS) - I HLMTN="ACK"!(HLMTN="MCF")!(HLMTN="ORR") Q:'$D(HLMSA) D ACK(HLMSA,"O",$G(HLDA)) Q - ; - N HLDAI S HLDA=0 - I $D(HLNDAP),HLMID]"" D - .F S HLDA=+$O(^HL(772,"AH",+$P($G(HLNDAP0),U,12),HLMID,HLDA)) Q:'HLDA!($P($G(^HL(772,+HLDA,0)),U,4)="I") - .I HLDA D - ..S HLDT=+$P($G(^HL(772,HLDA,0)),"^"),HLDT1=$$HLDATE^HLFNC(HLDT) - ..K ^HL(772,HLDA,"IN") - .I $D(HLMSA),$P(HLMSA,HLFS,3)]"" D - ..S HLDAI=0 - ..F S HLDAI=$O(^HL(772,"AH",+$P($G(HLNDAP0),U,12),$P(HLMSA,HLFS,3),HLDAI)) Q:'HLDAI!($P($G(^HL(772,+HLDAI,0)),U,4)="O") - ..I 'HLDAI K HLDAI - ; - ; patch HL*1.6*122: MPI-client/server - ; I 'HLDA D CREATE(.HLMID,.HLDA,.HLDT,.HLDT1) K HLZ - I 'HLDA D CREATE^HLTF(.HLMID,.HLDA,.HLDT,.HLDT1) K HLZ - ; - D STUFF^HLTF0("I") - N HLAC S HLAC=$S($D(HLERR):4,1:1) D STATUS^HLTF0(HLDA,HLAC,$G(HLMSG)) - ; - D MERGE15^HLTF1("G",HLDA,"HLR",HLTIME) - ; - I '$D(HLERR),$D(HLMSA),$D(HLDAI) D - .N HLAC,HLERR,HLMSG I $P(HLMSA,HLFS,4)]"" S HLERR=$P(HLMSA,HLFS,4) - .S HLAC=$P(HLMSA,HLFS,2) I HLAC'="AA" S HLMSG=$S(HLAC="AR":"Application Reject",1:"Application Error")_" - "_HLERR - .S HLAC=$S(HLAC'="AA":4,1:3) D STATUS^HLTF0(HLDAI,HLAC,$G(HLMSG)) - Q - ; -ACK(HLMSA,HLIO,HLDA) ;Process 'ACK' Message Type - Version 1.5 Interface Only - ; - ; patch HL*1.6*122: HLTF routine splitted, moves sub-routines, - ; OUT, IN, and ACK to HLTF2 routine. - ; - ; To determine the correct message to link the ACK, HLIO is used. - ; For an ack from DHCP (original message from remote system) then - ; HLIO should be "I" so that the correct inbound message is ack-ed. For - ; an inbound ack (original message outbound from DHCP) HLIO should be - ; "O". This distinction must be made due to the possible duplicate - ; message ids from a bi-direction interface. - ; - ; Input : MSA - MSA from ACK message. - ; HLIO - Either "I" or "O" : See note above. - ;Output : None - ; - N HLAC,HLMIDI - ;-- set up required vars - S HLAC=$P(HLMSA,HLFS,2),HLMIDI=$P(HLMSA,HLFS,3) - ;-- quit - Q:HLMIDI']""!(HLAC']"")!('$D(HLNDAP)) - ;-- find message to ack - I '$G(HLDA) S HLDA=0 D - . F S HLDA=+$O(^HL(772,"AH",+$P($G(HLNDAP0),U,12),HLMIDI,HLDA)) Q:'HLDA!($P($G(^HL(772,+HLDA,0)),U,4)=HLIO) - ;-- quit if no message - Q:'$D(^HL(772,+HLDA,0)) - ;-- check for error - I $P(HLMSA,HLFS,4)]"" N HLERR S HLERR=$P(HLMSA,HLFS,4) - I $D(HLERR),'$D(HLMSG) N HLMSG S HLMSG="Error During Receipt of Acknowledgement Message"_$S(HLAC="AR":" - Application Reject",HLAC="AE":" - Application Error",1:"")_" - "_HLERR - ;-- update status - S HLAC=$S(HLMTN="MCF":2,HLAC'="AA":4,1:3) - D STATUS^HLTF0(HLDA,HLAC,$G(HLMSG)) - Q - ; +HLTF2 ;AISC/SAW/MTC-Process Message Text File Entries (Cont'd) ;02/24/97 13:56 + ;;1.6;HEALTH LEVEL SEVEN;**25**;Oct 13, 1995 +MERGEIN(LLD0,LLD1,MTIEN,HDR,MSA) ;Merge Data From Communication Server + ;Module Logical Link File into Message Text File + ; + ;This is a subroutine call with parameter passing. The output + ;parameters HDR (and optionally) MSA are returned by this call. + ; + ;Required input parameters + ; LLD0 = Internal entry number where message is stored in Logical Link + ; file or XM if message is stored in MailMan + ; LLD1 = Internal entry number of IN QUEUE multiple entry in Logical + ; Link file (Only required for messages stored in Logical + ; Link file) + ; MTIEN = Internal entry number where message is to be copied to in + ; Message Text file + ; HDR = The variable in which the message header segment will + ; be returned + ; MSA = The variable in which the message acknowledgement segment + ; will be returned, if one exists for this message + ; + ;Check for required parameters + I $G(LLD0)']""!('$G(MTIEN)) Q + I LLD0'="XM",'$G(LLD1) Q + N FLG,HLCHAR,HLEVN,HLFS,I,X,X1,HLDONE + S (FLG,HLCHAR,HLEVN,X)=0 + ; + ;Move data from Logical Link file to Message Text file + I LLD0'="XM" D + .S I=0 F S X=$O(^HLCS(870,LLD0,1,LLD1,1,X)) Q:X'>0 S X1=$G(^(X,0)) S:"FHS,BHS,MSH"[$E(X1,1,3) FLG=1 I FLG S HLCHAR=HLCHAR+$L(X1) D + ..;If header segment, process it and set HDR equal to it + ..I X1'="","FHS,BHS,MSH"[$E(X1,1,3) D + ...I '$D(HDR) S HDR=X1,HLFS=$E(X1,4) I $E(HDR,1,3)="BHS" S MSA="MSA"_HLFS_$P($P(HDR,HLFS,10),$E(HDR,5),1)_HLFS_$P(HDR,HLFS,12)_HLFS_$P($P(HDR,HLFS,10),$E(HDR,5),2) + ...S $P(X1,HLFS,8)="" + ...S:$E(X1,1,3)="MSH" HLEVN=HLEVN+1 + ..;If acknowledgement segment, set MSA equal to it + ..I $E(X1,1,3)="MSA",'$D(MSA),$E($G(HDR),1,3)="MSH" S MSA=X1 + ..S I=I+1,^HL(772,MTIEN,"IN",I,0)=X1 + ; + ;Move data from MailMan Message file to Message Text file + I LLD0="XM" D + .S I=0 F X XMREC Q:XMER<0 S:"FHS,BHS,MSH"[$E(XMRG,1,3) FLG=1 I FLG S HLCHAR=HLCHAR+$L(XMRG) D Q:XMER<0 + ..;If header segment, process it and set HDR equal to it + ..I XMRG'="","FHS,BHS,MSH"[$E(XMRG,1,3) D + ...I '$D(HDR) S HDR=XMRG,HLFS=$E(XMRG,4) I $E(HDR,1,3)="BHS" S MSA="MSA"_HLFS_$P($P(HDR,HLFS,10),$E(HDR,5),1)_HLFS_$P(HDR,HLFS,12)_HLFS_$P($P(HDR,HLFS,10),$E(HDR,5),2) + ...S $P(XMRG,HLFS,8)="" + ...S:$E(XMRG,1,3)="MSH" HLEVN=HLEVN+1 + ..;If acknowledgement segment, set MSA equal to it + ..I $E(XMRG,1,3)="MSA",'$D(MSA),$E($G(HDR),1,3)="MSH" S MSA=XMRG + ..S I=I+1,^HL(772,MTIEN,"IN",I,0)=XMRG + S ^HL(772,MTIEN,"IN",0)="^^"_I_"^"_I_"^"_$$DT^XLFDT_"^" + ;Update statistics in Message Text file for this entry + D STATS^HLTF0(MTIEN,HLCHAR,HLEVN) + Q +MERGEOUT(MTIEN,LLD0,LLD1,HDR) ;Merge Text in Message Text File into + ;Communication Server Module Logical Link File + ; + ;This is a routine call with parameter passing. There are no output + ;parameters returned by this call. + ; + ;Required input parameters + ; MTIEN = Internal entry number where message is stored in Message + ; Text file + ; LLD0 = Internal entry number where message is to be copied to in + ; Logical Link file + ; LLD1 = Internal entry number of IN QUEUE multiple entry in Logical + ; Link file + ; HDR = Name of the array that contains HL7 Header segment + ; format: HLHDR - Used with indirection to build message in out + ; queue + ; This routine will first take the header information in the array + ; specified by HDR and merge into the Message Text field of file 870. + ; Then it will move the message contained in 772 (MTIEN) into 870. + ; + ;Check for required parameters + I '$G(MTIEN)!('$G(LLD0))!('$G(LLD1))!(HDR="") Q + ; + ;-- initilize + N I,X + S I=0 + ; + ;-- move header into 870 from HDR array + S X="" F S X=$O(@HDR@(X)) Q:'X D + . S I=I+1,^HLCS(870,LLD0,2,LLD1,1,I,0)=@HDR@(X) + S I=I+1,^HLCS(870,LLD0,2,LLD1,1,I,0)="" + ; + ;Move data from Message Text file to Logical Link file + S X=0 F S X=$O(^HL(772,MTIEN,"IN",X)) Q:X="" D + . S I=I+1,^HLCS(870,LLD0,2,LLD1,1,I,0)=$G(^HL(772,MTIEN,"IN",X,0)) + ; + ;-- update 0 node of message and format arrays + S ^HLCS(870,LLD0,2,LLD1,1,0)="^^"_I_"^"_I_"^"_$$DT^XLFDT_"^" + ; + Q diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLTP3.m b/r/HEALTH_LEVEL_SEVEN-HL/HLTP3.m index e52ea229..f3333b9a 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLTP3.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLTP3.m @@ -1,257 +1,254 @@ -HLTP3 ;SFIRMFO/RSD - Transaction Processor for TCP ;03/17/2008 11:26 - ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,58,59,66,69,109,115,108,116,117,125,120,133,122,140**;Oct 13, 1995;Build 5 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; - Q -NEW(X) ;process new msg. ien in 773^ien in 772 - ;HLMTIENS=ien in #773; HLMTIEN=ien in #772 - ;HLHDRO=original header; HLHDR=response header - ;set error trap - N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLTP3" - N HL,HLEID,HLEIDS,HLERR,HLHDR,HLHDRO,HLMTIEN,HLMTIENS,HLJ,HLMSA,HLQUIT,HLNODE,HLNEXT,HLRESLTA,HLDONE1,HLASTRSP,HLRESLT - S HLRESLT="" - D INIT^HLTP3A - ;error with header, return commit/app reject - I $G(HLRESLT) D Q - . ;set status & unlock record - . D STATUS^HLTF0(HLMTIENS,4,,,1),EXIT - . ;quit if no commit or app ack - . I $G(HL("ACAT"))="NE",$G(HL("APAT"))="NE" Q - . S X=$S($G(HL("ACAT"))="AL":"CR",1:"AR") - . ;HLTCP=ien of acknowledgment msg. from ACK^HLTP4 - . D ACK^HLTP4(X,$P(HLRESLT,U,2)) Q:'$G(HLTCP) - . ;write ack back - . S X=$$WRITE^HLCSTCP2(HLTCP) - . ;update counter to sent - . D LLCNT^HLCSTCP(HLDP,4) - . ;update status of ack - . D STATUS^HLTF0(HLTCP,3,,,1) - ; - ;check for duplicate msg., use rec. app and msg. id x-ref - ; patch HL*1.6*120 - I $G(HL("MID"))]"",$G(HL("RAP")) S X=$O(^HLMA("AH",HL("RAP"),HL("MID"),0)) D Q:'$D(HLMTIENS) - . ;HLASTMSG=last ien received during this connection - . ;if no duplicate, save msg. ien and quit - . I X=HLMTIENS!'X S HLASTMSG=HLMTIENS Q - . N MSH,OIENS - . S (OIENS,Y)=X D S Y=HLMTIENS D - .. ;combine MSH into single string - .. S MSH(Y)="",I=0 F S I=$O(^HLMA(Y,"MSH",I)) Q:'I S MSH(Y)=MSH(Y)_$G(^(I,0)) - .; patch 117 & 125, check if identical - .I MSH(HLMTIENS)'=MSH(OIENS) S HLASTMSG=HLMTIENS Q - .; - . ;msg is duplicate, set status - . D STATUS^HLTF0(HLMTIENS,4,109,"Duplicate with ien "_OIENS,1),EXIT - . ;msg was resent, ignore it. - . I HLASTMSG=HLMTIENS K HLMTIENS Q - . ;find original response and send back - . S HLASTRSP=$O(^HLMA("AF",OIENS,OIENS)) - ; - ;Quit if this is ack to ack - I $G(HL("ACK")) D Q - . ;Update status of original ack message - . D STATUS^HLTF0(HL("MTIENS"),3,,,1),STATUS^HLTF0(HLMTIENS,3,,,1) - . ;unlock record - . D EXIT - ; - ;enhance ack., send commit, quit if not an ack, msg will be processed by filer - I $G(HL("ACAT"))="AL" D Q:'$G(HL("MTIENS")) - . ;msg is a resend, HLASTRSP=ien of original response - .I $G(HLASTRSP) D - ..S HLTCP=HLASTRSP - ..D LLCNT^HLCSTCP(HLDP,3) - . E D Q:'$G(HLTCP) - ..D ACK^HLTP4("CA") ;**109** LLCNT^HLCSTCP(HLDP,3) called in ACK^HLTP4 - . S X=$$WRITE^HLCSTCP2(HLTCP) - . D LLCNT^HLCSTCP(HLDP,4),STATUS^HLTF0(HLTCP,3,,,1):'$G(HLASTRSP) - . S HLTCP="" - . ;if not an ack, set status to awaiting processing **109** and put on in queue - . I '$G(HL("MTIENS")),'$G(HLASTRSP) D STATUS^HLTF0(HLMTIENS,9),EXIT,SETINQUE^HLTP31 - ; - ;enhance ack., no commit & no app ack - I $G(HL("ACAT"))="NE",$G(HL("APAT"))="NE" D Q - . ;set status to awaiting processing, **109** and put on in queue - . I '$G(HLASTRSP) D STATUS^HLTF0(HLMTIENS,9),EXIT,SETINQUE^HLTP31 - ; - ; patch HL*1.6*120 start - ;resending old response, msg is a resend - ; do not re-send duplicate when $G(HL("ACAT"))="AL" - I $G(HLASTRSP),$G(HL("ACAT"))'="AL" S HLTCP=HLASTRSP G ACK - ; quit if duplicate - Q:$G(HLASTRSP) - ; patch HL*1.6*120 end - ; -CONT ;continue processing an enhance ack msg. called from DEFACK - ;Set special HL variables for processing rtn - S HLQUIT=0,HLNODE="",HLNEXT="D HLNEXT^HLCSUTL" - ; - ; message is an acknowledgement, HLMSA=ack code^id^text - I ($G(HLMSA)]"") D Q - . ;X=1 if ack ok, 0=reject of error - . S X=$E(HLMSA,2)="A" - . ;Update status of original message and remove it from the queue - . D STATUS^HLTF0(HL("MTIENS"),$S(X:3,1:4),"",$S(X:"",1:$P(HLMSA,HL("FS"),3)),1) - . D DEQUE^HLCSREP($P($G(^HLMA(HL("MTIENS"),0)),"^",7),"O",HL("MTIENS")) - . D - .. N HLTCP ;variable to update status in file #772. - ..; - ..;**108** - .. N TEMP - .. S TEMP=HLMTIENS - .. N HLMTIENS - .. S HLMTIENS=TEMP - ..;**END 108** - ..; - .. D PROCACK^HLTP2(HLMTIEN,HL("EID"),.HLRESLT,.HL) - . ;update status of incoming & unlock - . D STATUS^HLTF0(HLMTIENS,$S($G(HLRESLT):4,1:3),$S($G(HLRESLT):+$G(HLRESLT),1:""),$S($G(HLRESLT):$P(HLRESLT,U,2),1:""),1),EXIT - ; - ;get entry action, exit action and processing routine - K HLHDR,HLLD0,HLLD1,HLMSA - I HL("EIDS")="",$G(HLEIDS)]"" S HL("EIDS")=HLEIDS ;**CIRN** - D EVENT^HLUTIL1(HL("EIDS"),"15,20,771",.HLN) - S HLENROU=$G(HLN(20)),HLEXROU=$G(HLN(15)),HLPROU=$G(HLN(771)) - ;quit if no processing routine,update status and quit - I HLPROU']"" S HLRESLT="10^"_$G(^HL(771.7,10,0)) D STATUS^HLTF0(HLMTIENS,3,,,1),EXIT Q - ;HLORNOD=subscriber protocol for Fileman auditing, ien;global ref - N HLORNODD S HLORNOD=HL("EIDS")_";ORD(101," - ;Execute entry action of client protocol - X:HLENROU]"" HLENROU K HLENROU,HLDONE1 - ; - ;Execute processing routine - X HLPROU S HLRESLT=0 S:($D(HLERR)) HLRESLT="9^"_HLERR - ;update status of incoming to complete & unlock - D STATUS^HLTF0(HLMTIENS,$S(HLRESLT:4,1:3),$S(HLRESLT:+HLRESLT,1:""),$S(HLRESLT:$P(HLRESLT,U,2),1:""),1,$S($G(HLERR("SKIP_EVENT"))=1:1,1:0)),EXIT - ;HLTCPO=link open, HLTCP=ien of ack msg. from GENACK -ACK I $G(HLTCPO),$G(HLTCP) D Q - . D LLCNT^HLCSTCP(HLDP,3) - . ;write ack back over open tcp link - . S X=$$WRITE^HLCSTCP2(HLTCP) - . ;update status of ack to complete - . D:'$G(HLASTRSP) STATUS^HLTF0(HLTCP,3,,,1) - . D LLCNT^HLCSTCP(HLDP,4) - Q - ; -DEFACK(HLDP,X) ;process the deferred application ack, called from HLCSIN - ;HLDP=logical link, X=ien in file 773 - ; - ; patch HL*1.6*120 start - ; clean non-Kernel variables - D - . ; protect variables defined in STARTIN^HLCSIN - . N HLFLG,HLEXIT,HLPTRFLR - . ; protect variables defined in DEFACK^HLCSIN - . N HLXX,HLD0,HLPCT - . ; protect input parameters of this sub-routine - . N HLDP,X - . D KILL^XUSCLEAN - ; patch HL*1.6*120 end - ; - ;set error trap - N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLTP3" - N HLERR ;patch HL*1.6*109 - Q:'$G(HLDP)!'$G(X) Q:'$G(^HLMA(X,0)) - Q:'$D(^HLMA("AC","I",HLDP,X)) - ; - N HL,HLA,HLD0,HLEID,HLEIDS,HLHDR,HLHDRO,HLMTIEN,HLMTIENS,HLJ,HLMSA,HLN,HLQUIT,HLNODE,HLNEXT,HLRESLT,HLRESLTA,HLTCP,HLXX,Z,HLDONE1 - S HLMTIENS=X,X=^HLMA(HLMTIENS,0),HLMTIEN=+$P(X,U),HL("MID")=$P(X,U,2),HL("MTIENS")=$P(X,U,10),HL("LL")=$P(X,U,7),HLTCP="",HL("Q")="""""" - S HL("EIDS")=$P(X,U,8),HL("SAP")=$P(X,U,11),HL("RAP")=$P(X,U,12),HL("MTP")=$P(X,U,13),HL("ETP")=$P(X,U,14) - S:$P(X,U,15) HL("MTP_ETP")=$P(X,U,15) - S:HL("SAP") HL("SAN")=$P($G(^HL(771,HL("SAP"),0)),U) S:HL("RAP") HL("RAN")=$P($G(^HL(771,HL("RAP"),0)),U) - S:HL("MTP") HL("MTN")=$P($G(^HL(771.2,HL("MTP"),0)),U) S:HL("ETP") HL("ETN")=$P($G(^HL(779.001,HL("ETP"),0)),U) - S:$G(HL("MTP_ETP")) HL("MTN_ETN")=$P($G(^HL(779.005,HL("MTP_ETP"),0)),U) - S HL("EID")=$P($G(^HL(772,HLMTIEN,0)),U,10) - M HLHDRO=^HLMA(HLMTIENS,"MSH") - ; if no header quit - Q:'$O(HLHDRO(0)) - ; - S HL("FS")=$E(HLHDRO(1,0),4),HL("ECH")=$$P^HLTPCK2(.HLHDRO,2),HL("SFN")=$$P^HLTPCK2(.HLHDRO,4),HL("RFN")=$$P^HLTPCK2(.HLHDRO,6),HL("DTM")=$$P^HLTPCK2(.HLHDRO,7) - ; - ; quit if ien of #772 is not defined - Q:'HLMTIEN - ; quit if field separator is not defined - Q:HL("FS")="" - ; - S X=$$P^HLTPCK2(.HLHDRO,1) - ; - ; patch HL*1.6*120 start - I X="MSH" D - . S HL("PID")=$$P^HLTPCK2(.HLHDRO,11),HL("VER")=$$P^HLTPCK2(.HLHDRO,12),HL("APAT")=$$P^HLTPCK2(.HLHDRO,16),HL("CC")=$$P^HLTPCK2(.HLHDRO,17) - . ; - . ; 2nd component is Processing mode - . S HL("PMOD")=$P(HL("PID"),$E(HL("ECH"),1),2) - . ; first component is Processing id - . S HL("PID")=$P(HL("PID"),$E(HL("ECH"),1)) - ; - I X'="MSH" D - . S X=$$P^HLTPCK2(.HLHDRO,9),Z=$E(HL("ECH")),HL("PID")=$P(X,Z,2),HL("VER")=$P(X,Z,4) - . ; - . ; original code incorrectly treats repetition separator as - . ; subcomponent separator - . I $E(HL("ECH"),2)]"",X[$E(HL("ECH"),2) D - .. S HL("SUB-COMPONENT")=$E(HL("ECH"),2) - . ; if subcomponent separator is correctly applied - . I $E(HL("ECH"),4)]"",X[$E(HL("ECH"),4) D - .. S HL("SUB-COMPONENT")=$E(HL("ECH"),4) - . ; - . I $D(HL("SUB-COMPONENT")),HL("PID")[HL("SUB-COMPONENT") D - .. ; 2nd sub-component is Processing mode - .. S HL("PMOD")=$P(HL("PID"),HL("SUB-COMPONENT"),2) - .. ; first sub-component is Processing id - .. S HL("PID")=$P(HL("PID"),HL("SUB-COMPONENT")) - . ; patch HL*1.6*120 end - . ; - . Q:$$P^HLTPCK2(.HLHDRO,10)="" - . ;HLMSA=ack code^id^text - . S HLMSA=$P($$P^HLTPCK2(.HLHDRO,10),$E(HL("ECH")),1),$P(HLMSA,HL("FS"),2)=$$P^HLTPCK2(.HLHDRO,12),$P(HLMSA,HL("FS"),3)=$P($$P^HLTPCK2(.HLHDRO,10),$E(HL("ECH")),2),HL("MSAID")=$P(HLMSA,HL("FS"),2) - ; - ; quit if this is a commit ack - I $P($G(^HL(772,HLMTIEN,"IN",1,0)),HL("FS"),1)="MSA",$E($P($G(^HL(772,HLMTIEN,"IN",1,0)),HL("FS"),2))="C" Q - ; - ;** HL*1.6*117 ** - K HLL("SET FOR APP ACK"),HLL("LINKS") - ; - D CONT - Q - ; -MSA(Y) ;Y=ien in 772, returns MSA segment - ;ack code^msg being ack id^text - ; patch HL*1.6*122 - ; for HL7 v2.5 and beyond with MSA as 3rd segment - N X,SUBIEN,DATA,DONE - S X=$G(^HL(772,Y,"IN",1,0)),X=$S($E(X,1,3)="MSA":$E(X,5,999),1:"") - Q:X]"" X - ; - S DONE=0 - S SUBIEN=1 - F S SUBIEN=$O(^HL(772,Y,"IN",SUBIEN)) Q:'SUBIEN D Q:DONE - . S DATA=$G(^HL(772,Y,"IN",SUBIEN,0)) I DATA="" D - .. S DONE=1 - .. S SUBIEN=$O(^HL(772,Y,"IN",SUBIEN)) Q:'SUBIEN - .. S X=$G(^HL(772,Y,"IN",SUBIEN,0)),X=$S($E(X,1,3)="MSA":$E(X,5,999),1:"") - ; patch HL*1.6*122 end - ; - Q X - ; -ERROR ;error trap - D ^%ZTER - I $G(HLMTIENS),$D(^HLMA(HLMTIENS,0)) D STATUS^HLTF0(HLMTIENS,4,,,1),EXIT - ; release locks created by inbound filer - ; patch HL*1.6*140 - ; L -^HLMA("AC","I",+$G(HLXX)) - L -^HLMA("IN-FILER","AC","I",+$G(HLXX)) - G UNWIND^%ZTER - ; - ; -EXIT ;unlock - I $G(HLMTIENS) L -^HLMA(HLMTIENS) - Q - ; -ONAC(IEN773) ; - ;Returns 1 if the message is on the "AC","I" xref - ;Returns 0 otherwise - ; - N LINK - S LINK=$P($G(^HLMA(IEN773,0)),"^",17) - Q:'LINK 0 - Q $D(^HLMA("AC","I",LINK,IEN773)) +HLTP3 ;SFIRMFO/RSD - Transaction Processor for TCP ;09/13/2006 + ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,58,59,66,69,109,115,108,116,117,125,120,133**;Oct 13, 1995;Build 13 + ;Per VHA Directive 2004-038, this routine should not be modified. + ; + Q +NEW(X) ;process new msg. ien in 773^msg. ien in 772 + ;HLMTIENS=ien in #773, msg header; HLMTIEN=ien in #772, msg text + ;HLHDRO=original header; HLHDR=response header + ;set error trap + N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLTP3" + N HL,HLEID,HLEIDS,HLERR,HLHDR,HLHDRO,HLMTIEN,HLMTIENS,HLJ,HLMSA,HLQUIT,HLNODE,HLNEXT,HLRESLTA,HLDONE1,HLASTRSP,HLRESLT + S HLRESLT="" + D INIT^HLTP3A + ;error with header, return commit/app reject + I $G(HLRESLT) D Q + . ;set status & unlock record + . D STATUS^HLTF0(HLMTIENS,4,,,1),EXIT + . ;quit if no commit or app ack + . I $G(HL("ACAT"))="NE",$G(HL("APAT"))="NE" Q + . S X=$S($G(HL("ACAT"))="AL":"CR",1:"AR") + . ;HLTCP=ien of acknowledgment msg. from ACK^HLTP4 + . D ACK^HLTP4(X,$P(HLRESLT,U,2)) Q:'$G(HLTCP) + . ;write ack back over connection + . S X=$$WRITE^HLCSTCP2(HLTCP) + . ;update counter to sent + . D LLCNT^HLCSTCP(HLDP,4) + . ;update status of ack to complete + . D STATUS^HLTF0(HLTCP,3,,,1) + ; + ;check for duplicate msg., use rec. app and msg. id x-ref + ; patch HL*1.6*120 + ; I $L($G(HL("MID"))),$G(HL("RAP")) S X=$O(^HLMA("AH",HL("RAP"),HL("MID"),0)) D Q:'$D(HLMTIENS) + I $G(HL("MID"))]"",$G(HL("RAP")) S X=$O(^HLMA("AH",HL("RAP"),HL("MID"),0)) D Q:'$D(HLMTIENS) + . ;HLASTMSG=last ien received during this connection + . ;if no duplicate, save msg. ien and quit + . I X=HLMTIENS!'X S HLASTMSG=HLMTIENS Q + . N MSH,OIENS + . S (OIENS,Y)=X D S Y=HLMTIENS D + .. ;combine MSH into single string + .. S MSH(Y)="",I=0 F S I=$O(^HLMA(Y,"MSH",I)) Q:'I S MSH(Y)=MSH(Y)_$G(^(I,0)) + .; patch 117 & 125, check if identical + .I MSH(HLMTIENS)'=MSH(OIENS) S HLASTMSG=HLMTIENS Q + .; + . ;msg is duplicate, set status as duplicate + . D STATUS^HLTF0(HLMTIENS,4,109,"Duplicate with ien "_OIENS,1),EXIT + . ;msg was resent during this connection, ignore it. + . I HLASTMSG=HLMTIENS K HLMTIENS Q + . ;find original response and send back + . S HLASTRSP=$O(^HLMA("AF",OIENS,OIENS)) + ; + ;Quit if this is acknowledgment to acknowledgement message + I $G(HL("ACK")) D Q + . ;Update status of original acknowledgment message to successfully + . D STATUS^HLTF0(HL("MTIENS"),3,,,1),STATUS^HLTF0(HLMTIENS,3,,,1) + . ;unlock record + . D EXIT + ; + ;enhance ack., send commit, quit if not an ack, msg will be processed by filer + I $G(HL("ACAT"))="AL" D Q:'$G(HL("MTIENS")) + . ;msg is a resend, HLASTRSP=ien of original response + .I $G(HLASTRSP) D + ..S HLTCP=HLASTRSP + ..D LLCNT^HLCSTCP(HLDP,3) + . E D Q:'$G(HLTCP) + ..D ACK^HLTP4("CA") ;**109** LLCNT^HLCSTCP(HLDP,3) called in ACK^HLTP4 + . S X=$$WRITE^HLCSTCP2(HLTCP) + . D LLCNT^HLCSTCP(HLDP,4),STATUS^HLTF0(HLTCP,3,,,1):'$G(HLASTRSP) + . S HLTCP="" + . ;if not an ack, set status to awaiting processing **109** and put on in queue + . I '$G(HL("MTIENS")),'$G(HLASTRSP) D STATUS^HLTF0(HLMTIENS,9),EXIT,SETINQUE^HLTP31 + ; + ;enhance ack., no commit & no app ack + I $G(HL("ACAT"))="NE",$G(HL("APAT"))="NE" D Q + . ;set status to awaiting processing, **109** and put on in queue + . I '$G(HLASTRSP) D STATUS^HLTF0(HLMTIENS,9),EXIT,SETINQUE^HLTP31 + ; + ; patch HL*1.6*120 start + ;resending old response, msg is a resend + ; I $G(HLASTRSP) S HLTCP=HLASTRSP G ACK + ; do not re-send duplicate message when $G(HL("ACAT"))="AL" + I $G(HLASTRSP),$G(HL("ACAT"))'="AL" S HLTCP=HLASTRSP G ACK + ; quit if duplicate + Q:$G(HLASTRSP) + ; patch HL*1.6*120 end + ; +CONT ;continue processing an enhance ack msg. called from DEFACK + ;Set special HL variables for processing rtn + S HLQUIT=0,HLNODE="",HLNEXT="D HLNEXT^HLCSUTL" + ; + ; message is an acknowledgement, HLMSA=ack code^id^text + I ($G(HLMSA)]"") D Q + . ;X=1 if ack ok, 0=reject of error + . S X=$E(HLMSA,2)="A" + . ;Update status of original subscriber message and remove it from the out-going queue + . D STATUS^HLTF0(HL("MTIENS"),$S(X:3,1:4),"",$S(X:"",1:$P(HLMSA,HL("FS"),3)),1) + . D DEQUE^HLCSREP($P($G(^HLMA(HL("MTIENS"),0)),"^",7),"O",HL("MTIENS")) + . D + .. N HLTCP ;New variable to update status in file #772. + ..; + ..;**108** + .. N TEMP + .. S TEMP=HLMTIENS + .. N HLMTIENS + .. S HLMTIENS=TEMP + ..;**END 108** + ..; + .. D PROCACK^HLTP2(HLMTIEN,HL("EID"),.HLRESLT,.HL) + . ;update status of incoming to complete & unlock + . D STATUS^HLTF0(HLMTIENS,$S($G(HLRESLT):4,1:3),$S($G(HLRESLT):+$G(HLRESLT),1:""),$S($G(HLRESLT):$P(HLRESLT,U,2),1:""),1),EXIT + ; + ;get entry action, exit action and processing routine + K HLHDR,HLLD0,HLLD1,HLMSA + I HL("EIDS")="",$G(HLEIDS)]"" S HL("EIDS")=HLEIDS ;**CIRN** + D EVENT^HLUTIL1(HL("EIDS"),"15,20,771",.HLN) + S HLENROU=$G(HLN(20)),HLEXROU=$G(HLN(15)),HLPROU=$G(HLN(771)) + ;quit if no processing routine,update status and quit + I HLPROU']"" S HLRESLT="10^"_$G(^HL(771.7,10,0)) D STATUS^HLTF0(HLMTIENS,3,,,1),EXIT Q + ;HLORNOD=subscriber protocol for Fileman auditing, ien;global ref + N HLORNODD S HLORNOD=HL("EIDS")_";ORD(101," + ;Execute entry action of client protocol + X:HLENROU]"" HLENROU K HLENROU,HLDONE1 + ; + ;Execute processing routine + X HLPROU S HLRESLT=0 S:($D(HLERR)) HLRESLT="9^"_HLERR + ;update status of incoming to complete & unlock + D STATUS^HLTF0(HLMTIENS,$S(HLRESLT:4,1:3),$S(HLRESLT:+HLRESLT,1:""),$S(HLRESLT:$P(HLRESLT,U,2),1:""),1,$S($G(HLERR("SKIP_EVENT"))=1:1,1:0)),EXIT + ;HLTCPO=link open, HLTCP=ien of acknowledgment msg. from GENACK +ACK I $G(HLTCPO),$G(HLTCP) D Q + . D LLCNT^HLCSTCP(HLDP,3) + . ;write ack back over open tcp link + . S X=$$WRITE^HLCSTCP2(HLTCP) + . ;update status of ack to complete + . D:'$G(HLASTRSP) STATUS^HLTF0(HLTCP,3,,,1) + . D LLCNT^HLCSTCP(HLDP,4) + Q + ; +DEFACK(HLDP,X) ;process the deferred application ack, called from HLCSIN + ;HLDP=logical link, X=ien in file 773 + ; + ; patch HL*1.6*120 start + ; clean variables except Kernel related variables + D + . ; protect variables defined in STARTIN^HLCSIN + . N HLFLG,HLEXIT,HLPTRFLR + . ; protect variables defined in DEFACK^HLCSIN + . N HLXX,HLD0,HLPCT + . ; protect input parameters of this sub-routine + . N HLDP,X + . D KILL^XUSCLEAN + ; patch HL*1.6*120 end + ; + ;set error trap + N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLTP3" + N HLERR ;patch HL*1.6*109 + Q:'$G(HLDP)!'$G(X) Q:'$G(^HLMA(X,0)) + ;**109 START** + Q:'$D(^HLMA("AC","I",HLDP,X)) + ;**109 END** + ; + N HL,HLA,HLD0,HLEID,HLEIDS,HLHDR,HLHDRO,HLMTIEN,HLMTIENS,HLJ,HLMSA,HLN,HLQUIT,HLNODE,HLNEXT,HLRESLT,HLRESLTA,HLTCP,HLXX,Z,HLDONE1 + ;setup variables + S HLMTIENS=X,X=^HLMA(HLMTIENS,0),HLMTIEN=+$P(X,U),HL("MID")=$P(X,U,2),HL("MTIENS")=$P(X,U,10),HL("LL")=$P(X,U,7),HLTCP="",HL("Q")="""""" + S HL("EIDS")=$P(X,U,8),HL("SAP")=$P(X,U,11),HL("RAP")=$P(X,U,12),HL("MTP")=$P(X,U,13),HL("ETP")=$P(X,U,14) + S:$P(X,U,15) HL("MTP_ETP")=$P(X,U,15) + S:HL("SAP") HL("SAN")=$P($G(^HL(771,HL("SAP"),0)),U) S:HL("RAP") HL("RAN")=$P($G(^HL(771,HL("RAP"),0)),U) + S:HL("MTP") HL("MTN")=$P($G(^HL(771.2,HL("MTP"),0)),U) S:HL("ETP") HL("ETN")=$P($G(^HL(779.001,HL("ETP"),0)),U) + S:$G(HL("MTP_ETP")) HL("MTN_ETN")=$P($G(^HL(779.005,HL("MTP_ETP"),0)),U) + S HL("EID")=$P($G(^HL(772,HLMTIEN,0)),U,10) + M HLHDRO=^HLMA(HLMTIENS,"MSH") + ; if no header quit + ;**109** + ;I '$O(HLHDRO(0)) L -^HLMA(HLMTIENS) Q + Q:'$O(HLHDRO(0)) + ; + S HL("FS")=$E(HLHDRO(1,0),4),HL("ECH")=$$P^HLTPCK2(.HLHDRO,2),HL("SFN")=$$P^HLTPCK2(.HLHDRO,4),HL("RFN")=$$P^HLTPCK2(.HLHDRO,6),HL("DTM")=$$P^HLTPCK2(.HLHDRO,7) + ; + ; patch HL*1.6*109 start + ; quit if ien of #772 is not defined + Q:'HLMTIEN + ; quit if field separator is not defined + Q:HL("FS")="" + ; patch HL*1.6*109 end + ; + S X=$$P^HLTPCK2(.HLHDRO,1) + ; + ; patch HL*1.6*120 start + I X="MSH" D + . S HL("PID")=$$P^HLTPCK2(.HLHDRO,11),HL("VER")=$$P^HLTPCK2(.HLHDRO,12),HL("APAT")=$$P^HLTPCK2(.HLHDRO,16),HL("CC")=$$P^HLTPCK2(.HLHDRO,17) + . ; + . ; 2nd component is Processing mode + . S HL("PMOD")=$P(HL("PID"),$E(HL("ECH"),1),2) + . ; first component is Processing id + . S HL("PID")=$P(HL("PID"),$E(HL("ECH"),1)) + ; + I X'="MSH" D + . S X=$$P^HLTPCK2(.HLHDRO,9),Z=$E(HL("ECH")),HL("PID")=$P(X,Z,2),HL("VER")=$P(X,Z,4) + . ; + . ; original implementation incorrectly treats repetition separator as + . ; subcomponent separator + . I $E(HL("ECH"),2)]"",X[$E(HL("ECH"),2) D + .. S HL("SUB-COMPONENT")=$E(HL("ECH"),2) + . ; if subcomponent separator is correctly applied + . I $E(HL("ECH"),4)]"",X[$E(HL("ECH"),4) D + .. S HL("SUB-COMPONENT")=$E(HL("ECH"),4) + . ; + . I $D(HL("SUB-COMPONENT")),HL("PID")[HL("SUB-COMPONENT") D + .. ; 2nd sub-component is Processing mode + .. S HL("PMOD")=$P(HL("PID"),HL("SUB-COMPONENT"),2) + .. ; first sub-component is Processing id + .. S HL("PID")=$P(HL("PID"),HL("SUB-COMPONENT")) + . ; patch HL*1.6*120 end + . ; + . Q:$$P^HLTPCK2(.HLHDRO,10)="" + . ;HLMSA=ack code^id^text + . S HLMSA=$P($$P^HLTPCK2(.HLHDRO,10),$E(HL("ECH")),1),$P(HLMSA,HL("FS"),2)=$$P^HLTPCK2(.HLHDRO,12),$P(HLMSA,HL("FS"),3)=$P($$P^HLTPCK2(.HLHDRO,10),$E(HL("ECH")),2),HL("MSAID")=$P(HLMSA,HL("FS"),2) + ; + ; HL*1.6*108 + ; quit if this is a commit ack + I $P($G(^HL(772,HLMTIEN,"IN",1,0)),HL("FS"),1)="MSA",$E($P($G(^HL(772,HLMTIEN,"IN",1,0)),HL("FS"),2))="C" Q + ; ** + ; + ;** HL*1.6*117 ** + K HLL("SET FOR APP ACK"),HLL("LINKS") + ;** END HL*1.6*117 ** + ; + D CONT + Q + ; +MSA(Y) ;Y=ien in 772, returns MSA segment + ;ack code^msg being ack id^text + N X + S X=$G(^HL(772,Y,"IN",1,0)),X=$S($E(X,1,3)="MSA":$E(X,5,999),1:"") + Q X + ; +ERROR ;error trap + D ^%ZTER + I $G(HLMTIENS),$D(^HLMA(HLMTIENS,0)) D STATUS^HLTF0(HLMTIENS,4,,,1),EXIT + ;*109* release all locks created by inbound filer + L -^HLMA("AC","I",+$G(HLXX)) + G UNWIND^%ZTER + ; + ; +EXIT ;unlock + I $G(HLMTIENS) L -^HLMA(HLMTIENS) + Q + ; +ONAC(IEN773) ; + ;Returns 1 if the message is on the "AC","I" xref + ;Returns 0 otherwise + ; + N LINK + S LINK=$P($G(^HLMA(IEN773,0)),"^",17) + Q:'LINK 0 + Q $D(^HLMA("AC","I",LINK,IEN773)) diff --git a/r/HEALTH_LEVEL_SEVEN-HL/HLTPCK2B.m b/r/HEALTH_LEVEL_SEVEN-HL/HLTPCK2B.m index 65c24303..60a25174 100644 --- a/r/HEALTH_LEVEL_SEVEN-HL/HLTPCK2B.m +++ b/r/HEALTH_LEVEL_SEVEN-HL/HLTPCK2B.m @@ -1,207 +1,202 @@ -HLTPCK2B ;OIFO-O/RJH - Message Header Validation (Con't) ;10/04/2007 16:00 - ;;1.6;HEALTH LEVEL SEVEN;**120,133,122**;Oct 13, 1995;Build 14 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; - ; splitted from HLTPCK2A - ; to be called from HLTPCK2A - ; -MS ;Check for Message Structure Code - I $G(ARY("MTN_ETN"))'="" D - . S ARY("MTP_ETP")=0 - . S ARY("MTP_ETP")=+$O(^HL(779.005,"B",ARY("MTN_ETN"),0)) - . I ('ARY("MTP_ETP")) S:(ERR="") ERR="Invalid Message Structure Code" Q - ; - ;Get server and client Protocols -MSA ;if ack, then get information and quit, we don't need to respond - I $G(MSA)]"" D Q - . ;Message is an acknowledgement, find original message - . S ARY("MSAID")=$P(MSA,FS,2),ARY("MTIENS")=0 - . I ARY("MSAID")="" S:(ERR="") ERR="Invalid Message Control ID in MSA Segment - No Message ID" Q - . F S ARY("MTIENS")=+$O(^HLMA("AH",ARY("SAP"),ARY("MSAID"),ARY("MTIENS"))) Q:'ARY("MTIENS")!($P($G(^HLMA(ARY("MTIENS"),0)),U,3)="O") - . I 'ARY("MTIENS") S:(ERR="") ERR="Invalid Message Control ID in MSA Segment - No message IEN in ""AH"" x-ref" Q - . ;get subscriber protocol and ack. to (show if this is an ack to an ack) - . S X=$G(^HLMA(ARY("MTIENS"),0)),ARY("EIDS")=$P(X,U,8),ARY("ACK")=$P(X,U,10) - . ;if no subscriber protocol then response msg. is invalid - . ; - . ; patch HL*1.6*122 start - . ; comment out the following code: for patch 109- dynamic addressing - . ; I ('ARY("EIDS")) S:(ERR="") ERR="Invalid Message Control ID in MSA Segment - No Subscr. IEN in 773" Q - . ;get message text ien in file 772 and server protocol, 'EID' - . S ARY("MTIEN")=+X,X=$G(^HL(772,+X,0)),ARY("EID")=$P(X,U,10) - . I ('ARY("EID")) S:(ERR="") ERR="Event Protocol not found" Q - . ; D EVENT^HLUTIL1(ARY("EIDS"),"770,773",.HLN) - . I ARY("EIDS") D EVENT^HLUTIL1(ARY("EIDS"),"770,773",.HLN) - . ; patch HL*1.6*122 end - ; - ;Find Server Protocol - based on sending application, message type, - ;event type and version ID - I ARY("ETP") S ARY("EID")=+$O(^ORD(101,"AHL1",ARY("SAP"),ARY("MTP"),ARY("ETP"),ARY("VEP"),0)) - ; - ;Find Server Protocol - based on sending application, message type, - ;and version ID - I 'ARY("ETP") S ARY("EID")=+$O(^ORD(101,"AHL21",ARY("SAP"),ARY("MTP"),ARY("VEP"),0)) - ; - I ('ARY("EID")) S:(ERR="") ERR="Event Protocol not found" Q - ;Find Client Protocol - in ITEM multiple of Server Protocol - S ARY("EIDS")=0 - F S ARY("EIDS")=+$O(^ORD(101,ARY("EID"),775,"B",ARY("EIDS"))) Q:'ARY("EIDS")!($P($G(^ORD(101,ARY("EIDS"),770)),U,2)=ARY("RAP")) - I 'ARY("EIDS") S ERR="Invalid Receiving Application for this Event" Q - D EVENT^HLUTIL1(ARY("EIDS"),"770,773",.HLN) - ; -LLP ;Get logical link pointer - S ARY("LL")=$P($G(HLN(770)),"^",7) - ; -FAC ;Get sending/rec facility, validate if necessary - ; - S HLCS=$E(ECH,1) ;Get component separator - S ARY("RAF")=$$P^HLTPCK2(.HDR,6) ;Receiving Facility - S ARY("SAF")=$$P^HLTPCK2(.HDR,4) ;Sending Facility - ;Get sending/receiving facility from Application Parameter file(771) - S HL771SF=$P($G(^HL(771,ARY("SAP"),0)),U,3) - S HL771RF=$P($G(^HL(771,ARY("RAP"),0)),U,3) - ;Sending/Receiving facility required? - S X=$G(^ORD(101,ARY("EIDS"),773)) - S HLSFREQ=+X,HLRFREQ=+$P(X,U,2) -RF ;Validate Receiving Facility - I HLRFREQ D - .I ARY("RAF")="" S:ERR="" ERR="Missing required receiving facility" - .I HL771RF]"" D Q - ..;Facility data in 771 overrides data in site paramter file - ..Q - .;Check against local default value (site parameters) - .Q:ARY("RAF")=(HLINSTN_HLCS_HLDOM_HLCS_"DNS") - .; - .; patch HL*1.6*120 start - .; I $P(ARY("RAF"),HLCS)=HLINSTN,$P(ARY("RAF"),HLCS,3)="DNS" D Q - . I $P(ARY("RAF"),HLCS,3)="DNS" D Q - .. N ERROR,HLDOMP1,HLDOMP2 - .. ; S HLDOMP1=$P(ARY("RAF"),HLCS,2),HLDOMP1=$$FIND1^DIC(4.2,"","BMX",HLDOMP1,"B^C","","ERROR") - .. S HLDOMP1=$P(ARY("RAF"),HLCS,2) - .. ; - .. ; assume the format is : - .. I HLDOMP1[":" S ARY("RAF-PORT")=$P(HLDOMP1,":",2) - .. S HLDOMP1=$P(HLDOMP1,":") - .. S ARY("RAF-DOMAIN")=HLDOMP1 - .. ; - .. ; if first piece of domain is "HL7." or "MPI.", remove it - .. I ($E(HLDOMP1,1,4)="HL7.")!($E(HLDOMP1,1,4)="MPI.") D - ... S HLDOMP1=$P(HLDOMP1,".",2,99) - .. S HLDOMP1=$$FIND1^DIC(4.2,"","BMX",HLDOMP1,"B^C","","ERROR") - .. S HLDOMP2=HLDOM,HLDOMP2=$$FIND1^DIC(4.2,"","BMX",HLDOMP2,"B^C","","ERROR") - .. I HLDOMP1&HLDOMP2&(HLDOMP1=HLDOMP2) Q - .. ; - .. ; check DNS domain and ip address - .. ;initialize variable, HLDOMP("FLAG") - .. S HLDOMP("FLAG")=0 - .. I ARY("RAF-DOMAIN")]"" D - ... ; - ... ; match DNS domain - ... I $D(^HLCS(870,"DNS",ARY("RAF-DOMAIN"))) D Q - .... S HLDOMP("FLAG")=1 - .... S ARY("RAF-LL")=+$O(^HLCS(870,"DNS",ARY("RAF-DOMAIN"),0)) - ... I $D(^HLCS(870,"DNS",$$UP^XLFSTR(ARY("RAF-DOMAIN")))) D Q - .... S HLDOMP("FLAG")=1 - .... S ARY("RAF-LL")=+$O(^HLCS(870,"DNS",$$UP^XLFSTR(ARY("RAF-DOMAIN")),0)) - ... I $D(^HLCS(870,"DNS",$$LOW^XLFSTR(ARY("RAF-DOMAIN")))) D Q - .... S HLDOMP("FLAG")=1 - .... S ARY("RAF-LL")=+$O(^HLCS(870,"DNS",$$LOW^XLFSTR(ARY("RAF-DOMAIN")),0)) - ... ; - ... ; match ip address - ... I $D(^HLCS(870,"IP",ARY("RAF-DOMAIN"))) D Q - .... S HLDOMP("FLAG")=1 - .... S ARY("RAF-LL")=+$O(^HLCS(870,"IP",ARY("RAF-DOMAIN"),0)) - .. Q:HLDOMP("FLAG")=1 - .. I $P(ARY("RAF"),HLCS)=HLINSTN Q - .. ; - .. S:ERR="" ERR="Receiving Facility mismatch." - . I $P(ARY("RAF"),HLCS)=HLINSTN Q - . S:ERR="" ERR="Receiving Facility mismatch." - ; patch HL*1.6*120 end - ; -SF ;Validate Sending Facility - I HLSFREQ D - .I ARY("SAF")="" S:ERR="" ERR="Missing required sending facility" - .I HL771SF]"" D Q - ..;Check for facility data in 771 - ..Q - .;If default value was sent, validate that DOMAIN RESOLVES TO LOGICAL LINK - .;If so, use this instead of Protocol definition for return path - .; - .; patch HL*1.6*120 start - . N HLDOMP - . ; S HLDOMP=$P(ARY("SAF"),HLCS,2),HLDOMP=$$FIND1^DIC(4.2,"","BMX",HLDOMP,"B^C","","ERROR") - . S HLDOMP=$P(ARY("SAF"),HLCS,2) - . ; - . ; assume the format is : - . I HLDOMP[":" S ARY("SAF-PORT")=$P(HLDOMP,":",2) - . S HLDOMP=$P(HLDOMP,":") - . S ARY("SAF-DOMAIN")=HLDOMP - . ; - . ; if first piece of domain is "HL7." or "MPI.", remove it - . I ($E(HLDOMP,1,4)="HL7.")!($E(HLDOMP,1,4)="MPI.") D - .. S HLDOMP=$P(HLDOMP,".",2,99) - . S HLDOMP=$$FIND1^DIC(4.2,"","BMX",HLDOMP,"B^C","","ERROR") - .;Note: This expects a unique domain in domain file. Multiple entries will fail - . ; I 'HLDOMP S:ERR="" ERR="Unrecognized/ambiguous domain in sending facility" - . ; - . ; check DNS domain and ip address - . I 'HLDOMP D - .. ; - .. ;initialize variable, HLDOMP("FLAG") - .. S HLDOMP("FLAG")=0 - .. I ARY("SAF-DOMAIN")]"" D - ... ; - ... ; match DNS domain - ... I $D(^HLCS(870,"DNS",ARY("SAF-DOMAIN"))) D Q - .... S HLDOMP("FLAG")=1 - .... S ARY("SAF-LL")=+$O(^HLCS(870,"DNS",ARY("SAF-DOMAIN"),0)) - ... I $D(^HLCS(870,"DNS",$$UP^XLFSTR(ARY("SAF-DOMAIN")))) D Q - .... S HLDOMP("FLAG")=1 - .... S ARY("SAF-LL")=+$O(^HLCS(870,"DNS",$$UP^XLFSTR(ARY("SAF-DOMAIN")),0)) - ... I $D(^HLCS(870,"DNS",$$LOW^XLFSTR(ARY("SAF-DOMAIN")))) D Q - .... S HLDOMP("FLAG")=1 - .... S ARY("SAF-LL")=+$O(^HLCS(870,"DNS",$$LOW^XLFSTR(ARY("SAF-DOMAIN")),0)) - ... ; - ... ; match ip address - ... I $D(^HLCS(870,"IP",ARY("SAF-DOMAIN"))) D Q - .... S HLDOMP("FLAG")=1 - .... S ARY("SAF-LL")=+$O(^HLCS(870,"IP",ARY("SAF-DOMAIN"),0)) - .. Q:HLDOMP("FLAG")=1 - .. ; quit if 1st component defined - .. S ARY("SAF-COMPONENT1")=$P(ARY("SAF"),HLCS,1) - .. Q:ARY("SAF-COMPONENT1")]"" - .. S:ERR="" ERR="Receiving Facility mismatch." - . ; patch HL*1.6*120 end - . ; - .Q:HLDOMP=$P(HLPARAM,U) ;This is local app to app - .I HLDOMP N HLNK S HLNK=+$O(^HLCS(870,"D",HLDOMP,0)) - .I $G(HLNK) S ARY("LL")=HLNK - ; -PID ;Validate processing ID - I ("DTP"'[ARY("PID")) S:(ERR="") ERR="Invalid HL7 Processing ID" - S HLPID=$P(HLPARAM,U,3) ;site param - S X=$G(^ORD(101,ARY("EID"),770)),X=$P(X,U,6) ;event driver - ;If message is 'debug' then event driver must be 'debug.' - ;If message is 'test' or 'production', then site param must match - I ARY("PID")="D"&(X'="D") S:ERR="" ERR="Processing ID Mismatch with Event Driver" - I ARY("PID")'="D"&(HLPID'=ARY("PID")) S:ERR="" ERR="Processing ID Mismatch with Site Parameters" - ; -SEC ;Validate security field - access code and electronic signature - I ($P($G(HLN(773)),"^",3)) D - .S X=$P($$P^HLTPCK2(.HDR,8),$E(ECH)) - .S X=$$UPPER^HLFNC(X) - .D ^XUSHSH - .I X="",(MSA="") S:(ERR="") ERR="Invalid access code" Q - .S ARY("DUZ")=0 - .S:(X'="") ARY("DUZ")=+$O(^VA(200,"A",X,0)) - .I ('ARY("DUZ")) S:(ERR="") ERR="Invalid access code" Q - .I (($P($G(^VA(200,ARY("DUZ"),.1)),"^")="")&('$D(MSA))) S ARY("DUZ")=0 S:(ERR="") ERR="Invalid access code" Q - .S X=$P($$P^HLTPCK2(.HDR,8),$E(ECH),3) I (X'="") D - ..S X1=$G(^VA(200,ARY("DUZ"),20)) - ..I (X1="") S:(ERR="") ERR="No Signature Code on File" Q - ..S X=$$UPPER^HLFNC(X) - ..D HASH^XUSHSHP - ..I ((X'=$P(X1,"^",4))!($P(X1,"^",2)="")) S:(ERR="") ERR="Invalid Electronic Signature Code" Q - ..S ARY("ESIG")=$P(X1,"^",2) - I $D(ARY) M HLREC=ARY - Q +HLTPCK2B ;OIFO-O/RJH - Message Header Validation (Con't) ;09/13/2006 + ;;1.6;HEALTH LEVEL SEVEN;**120,133**;Oct 13, 1995;Build 13 + ;Per VHA Directive 2004-038, this routine should not be modified. + ; + ; splitted from HLTPCK2A + ; to be called from HLTPCK2A + ; +MS ;Check for Message Structure Code + I $G(ARY("MTN_ETN"))'="" D + . S ARY("MTP_ETP")=0 + . S ARY("MTP_ETP")=+$O(^HL(779.005,"B",ARY("MTN_ETN"),0)) + . I ('ARY("MTP_ETP")) S:(ERR="") ERR="Invalid Message Structure Code" Q + ; + ;Get server and client Protocols +MSA ;if ack, then get information and quit, we don't need to respond + I $G(MSA)]"" D Q + . ;Message is an acknowledgement, find original message + . S ARY("MSAID")=$P(MSA,FS,2),ARY("MTIENS")=0 + . I ARY("MSAID")="" S:(ERR="") ERR="Invalid Message Control ID in MSA Segment - No Message ID" Q + . F S ARY("MTIENS")=+$O(^HLMA("AH",ARY("SAP"),ARY("MSAID"),ARY("MTIENS"))) Q:'ARY("MTIENS")!($P($G(^HLMA(ARY("MTIENS"),0)),U,3)="O") + . I 'ARY("MTIENS") S:(ERR="") ERR="Invalid Message Control ID in MSA Segment - No message IEN in ""AH"" x-ref" Q + . ;get subscriber protocol and ack. to (show if this is an ack to an ack) + . S X=$G(^HLMA(ARY("MTIENS"),0)),ARY("EIDS")=$P(X,U,8),ARY("ACK")=$P(X,U,10) + . ;if no subscriber protocol then response msg. is invalid + . I ('ARY("EIDS")) S:(ERR="") ERR="Invalid Message Control ID in MSA Segment - No Subscr. IEN in 773" Q + . ;get message text ien in file 772 and server protocol, 'EID' + . S ARY("MTIEN")=+X,X=$G(^HL(772,+X,0)),ARY("EID")=$P(X,U,10) + . I ('ARY("EID")) S:(ERR="") ERR="Event Protocol not found" Q + . D EVENT^HLUTIL1(ARY("EIDS"),"770,773",.HLN) + ; + ;Find Server Protocol - based on sending application, message type, + ;event type and version ID + I ARY("ETP") S ARY("EID")=+$O(^ORD(101,"AHL1",ARY("SAP"),ARY("MTP"),ARY("ETP"),ARY("VEP"),0)) + ; + ;Find Server Protocol - based on sending application, message type, + ;and version ID + I 'ARY("ETP") S ARY("EID")=+$O(^ORD(101,"AHL21",ARY("SAP"),ARY("MTP"),ARY("VEP"),0)) + ; + I ('ARY("EID")) S:(ERR="") ERR="Event Protocol not found" Q + ;Find Client Protocol - in ITEM multiple of Server Protocol + S ARY("EIDS")=0 + F S ARY("EIDS")=+$O(^ORD(101,ARY("EID"),775,"B",ARY("EIDS"))) Q:'ARY("EIDS")!($P($G(^ORD(101,ARY("EIDS"),770)),U,2)=ARY("RAP")) + I 'ARY("EIDS") S ERR="Invalid Receiving Application for this Event" Q + D EVENT^HLUTIL1(ARY("EIDS"),"770,773",.HLN) + ; +LLP ;Get logical link pointer + S ARY("LL")=$P($G(HLN(770)),"^",7) + ; +FAC ;Get sending/rec facility, validate if necessary + ; + S HLCS=$E(ECH,1) ;Get component separator + S ARY("RAF")=$$P^HLTPCK2(.HDR,6) ;Receiving Facility + S ARY("SAF")=$$P^HLTPCK2(.HDR,4) ;Sending Facility + ;Get sending/receiving facility from Application Parameter file(771) + S HL771SF=$P($G(^HL(771,ARY("SAP"),0)),U,3) + S HL771RF=$P($G(^HL(771,ARY("RAP"),0)),U,3) + ;Sending/Receiving facility required? + S X=$G(^ORD(101,ARY("EIDS"),773)) + S HLSFREQ=+X,HLRFREQ=+$P(X,U,2) +RF ;Validate Receiving Facility + I HLRFREQ D + .I ARY("RAF")="" S:ERR="" ERR="Missing required receiving facility" + .I HL771RF]"" D Q + ..;Facility data in 771 overrides data in site paramter file + ..Q + .;Check against local default value (site parameters) + .Q:ARY("RAF")=(HLINSTN_HLCS_HLDOM_HLCS_"DNS") + .; + .; patch HL*1.6*120 start + .; I $P(ARY("RAF"),HLCS)=HLINSTN,$P(ARY("RAF"),HLCS,3)="DNS" D Q + . I $P(ARY("RAF"),HLCS,3)="DNS" D Q + .. N ERROR,HLDOMP1,HLDOMP2 + .. ; S HLDOMP1=$P(ARY("RAF"),HLCS,2),HLDOMP1=$$FIND1^DIC(4.2,"","BMX",HLDOMP1,"B^C","","ERROR") + .. S HLDOMP1=$P(ARY("RAF"),HLCS,2) + .. ; + .. ; assume the format is : + .. I HLDOMP1[":" S ARY("RAF-PORT")=$P(HLDOMP1,":",2) + .. S HLDOMP1=$P(HLDOMP1,":") + .. S ARY("RAF-DOMAIN")=HLDOMP1 + .. ; + .. ; if first piece of domain is "HL7." or "MPI.", remove it + .. I ($E(HLDOMP1,1,4)="HL7.")!($E(HLDOMP1,1,4)="MPI.") D + ... S HLDOMP1=$P(HLDOMP1,".",2,99) + .. S HLDOMP1=$$FIND1^DIC(4.2,"","BMX",HLDOMP1,"B^C","","ERROR") + .. S HLDOMP2=HLDOM,HLDOMP2=$$FIND1^DIC(4.2,"","BMX",HLDOMP2,"B^C","","ERROR") + .. I HLDOMP1&HLDOMP2&(HLDOMP1=HLDOMP2) Q + .. ; + .. ; check DNS domain and ip address + .. ;initialize variable, HLDOMP("FLAG") + .. S HLDOMP("FLAG")=0 + .. I ARY("RAF-DOMAIN")]"" D + ... ; + ... ; match DNS domain + ... I $D(^HLCS(870,"DNS",ARY("RAF-DOMAIN"))) D Q + .... S HLDOMP("FLAG")=1 + .... S ARY("RAF-LL")=+$O(^HLCS(870,"DNS",ARY("RAF-DOMAIN"),0)) + ... I $D(^HLCS(870,"DNS",$$UP^XLFSTR(ARY("RAF-DOMAIN")))) D Q + .... S HLDOMP("FLAG")=1 + .... S ARY("RAF-LL")=+$O(^HLCS(870,"DNS",$$UP^XLFSTR(ARY("RAF-DOMAIN")),0)) + ... I $D(^HLCS(870,"DNS",$$LOW^XLFSTR(ARY("RAF-DOMAIN")))) D Q + .... S HLDOMP("FLAG")=1 + .... S ARY("RAF-LL")=+$O(^HLCS(870,"DNS",$$LOW^XLFSTR(ARY("RAF-DOMAIN")),0)) + ... ; + ... ; match ip address + ... I $D(^HLCS(870,"IP",ARY("RAF-DOMAIN"))) D Q + .... S HLDOMP("FLAG")=1 + .... S ARY("RAF-LL")=+$O(^HLCS(870,"IP",ARY("RAF-DOMAIN"),0)) + .. Q:HLDOMP("FLAG")=1 + .. I $P(ARY("RAF"),HLCS)=HLINSTN Q + .. ; + .. S:ERR="" ERR="Receiving Facility mismatch." + . I $P(ARY("RAF"),HLCS)=HLINSTN Q + . S:ERR="" ERR="Receiving Facility mismatch." + ; patch HL*1.6*120 end + ; +SF ;Validate Sending Facility + I HLSFREQ D + .I ARY("SAF")="" S:ERR="" ERR="Missing required sending facility" + .I HL771SF]"" D Q + ..;Check for facility data in 771 + ..Q + .;If default value was sent, validate that DOMAIN RESOLVES TO LOGICAL LINK + .;If so, use this instead of Protocol definition for return path + .; + .; patch HL*1.6*120 start + . N HLDOMP + . ; S HLDOMP=$P(ARY("SAF"),HLCS,2),HLDOMP=$$FIND1^DIC(4.2,"","BMX",HLDOMP,"B^C","","ERROR") + . S HLDOMP=$P(ARY("SAF"),HLCS,2) + . ; + . ; assume the format is : + . I HLDOMP[":" S ARY("SAF-PORT")=$P(HLDOMP,":",2) + . S HLDOMP=$P(HLDOMP,":") + . S ARY("SAF-DOMAIN")=HLDOMP + . ; + . ; if first piece of domain is "HL7." or "MPI.", remove it + . I ($E(HLDOMP,1,4)="HL7.")!($E(HLDOMP,1,4)="MPI.") D + .. S HLDOMP=$P(HLDOMP,".",2,99) + . S HLDOMP=$$FIND1^DIC(4.2,"","BMX",HLDOMP,"B^C","","ERROR") + .;Note: This expects a unique domain in domain file. Multiple entries will fail + . ; I 'HLDOMP S:ERR="" ERR="Unrecognized/ambiguous domain in sending facility" + . ; + . ; check DNS domain and ip address + . I 'HLDOMP D + .. ; + .. ;initialize variable, HLDOMP("FLAG") + .. S HLDOMP("FLAG")=0 + .. I ARY("SAF-DOMAIN")]"" D + ... ; + ... ; match DNS domain + ... I $D(^HLCS(870,"DNS",ARY("SAF-DOMAIN"))) D Q + .... S HLDOMP("FLAG")=1 + .... S ARY("SAF-LL")=+$O(^HLCS(870,"DNS",ARY("SAF-DOMAIN"),0)) + ... I $D(^HLCS(870,"DNS",$$UP^XLFSTR(ARY("SAF-DOMAIN")))) D Q + .... S HLDOMP("FLAG")=1 + .... S ARY("SAF-LL")=+$O(^HLCS(870,"DNS",$$UP^XLFSTR(ARY("SAF-DOMAIN")),0)) + ... I $D(^HLCS(870,"DNS",$$LOW^XLFSTR(ARY("SAF-DOMAIN")))) D Q + .... S HLDOMP("FLAG")=1 + .... S ARY("SAF-LL")=+$O(^HLCS(870,"DNS",$$LOW^XLFSTR(ARY("SAF-DOMAIN")),0)) + ... ; + ... ; match ip address + ... I $D(^HLCS(870,"IP",ARY("SAF-DOMAIN"))) D Q + .... S HLDOMP("FLAG")=1 + .... S ARY("SAF-LL")=+$O(^HLCS(870,"IP",ARY("SAF-DOMAIN"),0)) + .. Q:HLDOMP("FLAG")=1 + .. ; quit if 1st component defined + .. S ARY("SAF-COMPONENT1")=$P(ARY("SAF"),HLCS,1) + .. Q:ARY("SAF-COMPONENT1")]"" + .. S:ERR="" ERR="Receiving Facility mismatch." + . ; patch HL*1.6*120 end + . ; + .Q:HLDOMP=$P(HLPARAM,U) ;This is local app to app + .I HLDOMP N HLNK S HLNK=+$O(^HLCS(870,"D",HLDOMP,0)) + .I $G(HLNK) S ARY("LL")=HLNK + ; +PID ;Validate processing ID + I ("DTP"'[ARY("PID")) S:(ERR="") ERR="Invalid HL7 Processing ID" + S HLPID=$P(HLPARAM,U,3) ;site param + S X=$G(^ORD(101,ARY("EID"),770)),X=$P(X,U,6) ;event driver + ;If message is 'debug' then event driver must be 'debug.' + ;If message is 'test' or 'production', then site param must match + I ARY("PID")="D"&(X'="D") S:ERR="" ERR="Processing ID Mismatch with Event Driver" + I ARY("PID")'="D"&(HLPID'=ARY("PID")) S:ERR="" ERR="Processing ID Mismatch with Site Parameters" + ; +SEC ;Validate security field - access code and electronic signature + I ($P($G(HLN(773)),"^",3)) D + .S X=$P($$P^HLTPCK2(.HDR,8),$E(ECH)) + .S X=$$UPPER^HLFNC(X) + .D ^XUSHSH + .I X="",(MSA="") S:(ERR="") ERR="Invalid access code" Q + .S ARY("DUZ")=0 + .S:(X'="") ARY("DUZ")=+$O(^VA(200,"A",X,0)) + .I ('ARY("DUZ")) S:(ERR="") ERR="Invalid access code" Q + .I (($P($G(^VA(200,ARY("DUZ"),.1)),"^")="")&('$D(MSA))) S ARY("DUZ")=0 S:(ERR="") ERR="Invalid access code" Q + .S X=$P($$P^HLTPCK2(.HDR,8),$E(ECH),3) I (X'="") D + ..S X1=$G(^VA(200,ARY("DUZ"),20)) + ..I (X1="") S:(ERR="") ERR="No Signature Code on File" Q + ..S X=$$UPPER^HLFNC(X) + ..D HASH^XUSHSHP + ..I ((X'=$P(X1,"^",4))!($P(X1,"^",2)="")) S:(ERR="") ERR="Invalid Electronic Signature Code" Q + ..S ARY("ESIG")=$P(X1,"^",2) + I $D(ARY) M HLREC=ARY + Q diff --git a/r/HEALTH_SUMMARY-GMTS/GMTSDA.m b/r/HEALTH_SUMMARY-GMTS/GMTSDA.m index 4b55774b..fb707289 100644 --- a/r/HEALTH_SUMMARY-GMTS/GMTSDA.m +++ b/r/HEALTH_SUMMARY-GMTS/GMTSDA.m @@ -1,44 +1,43 @@ -GMTSDA ; SLC/DLT,KER/NDBI - Appointments ; 5/21/07 11:12am - ;;2.7;Health Summary;**5,19,28,49,70,80**;Oct 20, 1995;Build 9 - ; - ; External Reference - ; DBIA 1024 ^DIC(40.7 - ; DBIA 10040 ^SC( - ; DBIA 2065 ^SCE( - ; DBIA 2065 ^SCE("ADFN" - ; DBIA 2929 CVP^A7RHSM - ; DBIA 10061 SDA^VADPT - ; -PAST ; Gets Patient's Past Appointments for date range - N GMDT,GMIDT,MAX S X=1 - S VASD("F")=$S(GMTSBEG=1:2560101,1:GMTSBEG),VASD("T")=$S(GMTS1=6666666:DT,1:9999999-GMTS1) - S MAX=$S(+($G(GMTSNDM))>0:+($G(GMTSNDM)),1:99999) - S VASD("W")=123456789 D SDA^VADPT - I VAERR=1 D CKP^GMTSUP W "RSA ERROR",! D END Q - I VAERR=2 D CKP^GMTSUP W "DATABASE NOT AVAILABLE",! D END Q - S (YCNT,Y)=0 F S Y=$O(^UTILITY("VASD",$J,Y)) Q:'Y S YCNT=YCNT+1,ADATE=$P(^(Y,"I"),U,1),^UTILITY("GMTSVASD",$J,9999999-ADATE)=ADATE_U_$P(^UTILITY("VASD",$J,Y,"E"),U,2,99) - S GMDT=VASD("F") - F S GMDT=$O(^SCE("ADFN",DFN,GMDT)) Q:GMDT'>0!(GMDT>VASD("T")) D - . S GMI=0 F S GMI=$O(^SCE("ADFN",DFN,GMDT,GMI)) Q:GMI'>0 D - . . S GMIDT=9999999-GMDT - . . I '$D(^UTILITY("GMTSVASD",$J,GMIDT)) D - . . . Q:$P($G(^SCE(GMI,0)),U,6)'="" - . . . I $P($G(^SCE(GMI,0)),U,4) Q:$P($G(^SC($P(^SCE(GMI,0),U,4),"OOS")),U) - . . . S ^UTILITY("GMTSVASD",$J,GMIDT)=GMDT_U_$S(+$P(^SCE(GMI,0),U,4):$P($G(^SC(+$P(^(0),U,4),0)),U),1:$P($G(^DIC(40.7,$P(^SCE(GMI,0),U,3),0)),U))_U_"UNSCHEDULED" - D:$$ROK^GMTSU("A7RHSM")&($$NDBI^GMTSU) CVP^A7RHSM - I '$D(^UTILITY("GMTSVASD",$J)) D END Q - S IDATE="",YCNT=0 - F S IDATE=$O(^UTILITY("GMTSVASD",$J,IDATE)) Q:+IDATE'>0!(YCNT=MAX) D - . S ADATE=+^(IDATE),ADATE(0)=^(IDATE) D PRINT S YCNT=YCNT+1 - D END Q -FUTURE ; Gets Patient's Future Appointments - D SDA^VADPT N MAX S MAX=$S(+($G(GMTSNDM))>0:+($G(GMTSNDM)),1:99999) - I VAERR=2 D CKP^GMTSUP W "DATABASE NOT AVAILABLE",! D END Q - S (YCNT,Y)=0 F S Y=$O(^UTILITY("VASD",$J,Y)) Q:'Y S YCNT=YCNT+1,ADATE=$P(^(Y,"I"),U,1),ADATE(0)=^UTILITY("VASD",$J,Y,"E") D PRINT Q:YCNT=MAX - D END Q -PRINT ; Output - D CKP^GMTSUP Q:$D(GMTSQIT) S X=ADATE D REGDTM4^GMTSU,CKP^GMTSUP - W X,?18,$E($P(ADATE(0),"^",2),1,25),?58,$E($P(ADATE(0),"^",3),1,21) - W ! Q -END ; Clean-up and Quit - K %I,IDATE,IDATES,ADATE,VASD,X,Y,YCNT,Z,^UTILITY("VASD",$J),^UTILITY("GMTSVASD",$J) Q +GMTSDA ; SLC/DLT,KER/NDBI - Appointments ; 02/27/2002 [4/14/04 1:53pm] + ;;2.7;Health Summary;**5,19,28,49,70**;Oct 20, 1995;Build 5 + ; + ; External Reference + ; DBIA 1024 ^DIC(40.7 + ; DBIA 10040 ^SC( + ; DBIA 2065 ^SCE( + ; DBIA 2065 ^SCE("ADFN" + ; DBIA 2929 CVP^A7RHSM + ; DBIA 10061 SDA^VADPT + ; +PAST ; Gets Patient's Past Appointments for date range + N GMDT,GMIDT,MAX S X=1 + S VASD("F")=$S(GMTSBEG=1:2560101,1:GMTSBEG),VASD("T")=$S(GMTS1=6666666:DT,1:9999999-GMTS1) + S MAX=$S(+($G(GMTSNDM))>0:+($G(GMTSNDM)),1:99999) + S VASD("W")=123456789 D SDA^VADPT + I VAERR=2 D CKP^GMTSUP W "DATABASE NOT AVAILABLE",! D END Q + S (YCNT,Y)=0 F S Y=$O(^UTILITY("VASD",$J,Y)) Q:'Y S YCNT=YCNT+1,ADATE=$P(^(Y,"I"),U,1),^UTILITY("GMTSVASD",$J,9999999-ADATE)=ADATE_U_$P(^UTILITY("VASD",$J,Y,"E"),U,2,99) + S GMDT=VASD("F") + F S GMDT=$O(^SCE("ADFN",DFN,GMDT)) Q:GMDT'>0!(GMDT>VASD("T")) D + . S GMI=0 F S GMI=$O(^SCE("ADFN",DFN,GMDT,GMI)) Q:GMI'>0 D + . . S GMIDT=9999999-GMDT + . . I '$D(^UTILITY("GMTSVASD",$J,GMIDT)) D + . . . Q:$P($G(^SCE(GMI,0)),U,6)'="" + . . . I $P($G(^SCE(GMI,0)),U,4) Q:$P($G(^SC($P(^SCE(GMI,0),U,4),"OOS")),U) + . . . S ^UTILITY("GMTSVASD",$J,GMIDT)=GMDT_U_$S(+$P(^SCE(GMI,0),U,4):$P($G(^SC(+$P(^(0),U,4),0)),U),1:$P($G(^DIC(40.7,$P(^SCE(GMI,0),U,3),0)),U))_U_"UNSCHEDULED" + D:$$ROK^GMTSU("A7RHSM")&($$NDBI^GMTSU) CVP^A7RHSM + I '$D(^UTILITY("GMTSVASD",$J)) D END Q + S IDATE="",YCNT=0 + F S IDATE=$O(^UTILITY("GMTSVASD",$J,IDATE)) Q:+IDATE'>0!(YCNT=MAX) D + . S ADATE=+^(IDATE),ADATE(0)=^(IDATE) D PRINT S YCNT=YCNT+1 + D END Q +FUTURE ; Gets Patient's Future Appointments + D SDA^VADPT N MAX S MAX=$S(+($G(GMTSNDM))>0:+($G(GMTSNDM)),1:99999) + I VAERR=2 D CKP^GMTSUP W "DATABASE NOT AVAILABLE",! D END Q + S (YCNT,Y)=0 F S Y=$O(^UTILITY("VASD",$J,Y)) Q:'Y S YCNT=YCNT+1,ADATE=$P(^(Y,"I"),U,1),ADATE(0)=^UTILITY("VASD",$J,Y,"E") D PRINT Q:YCNT=MAX + D END Q +PRINT ; Output + D CKP^GMTSUP Q:$D(GMTSQIT) S X=ADATE D REGDTM4^GMTSU,CKP^GMTSUP + W X,?18,$E($P(ADATE(0),"^",2),1,25),?58,$E($P(ADATE(0),"^",3),1,21) + W ! Q +END ; Clean-up and Quit + K %I,IDATE,IDATES,ADATE,VASD,X,Y,YCNT,Z,^UTILITY("VASD",$J),^UTILITY("GMTSVASD",$J) Q diff --git a/r/HEALTH_SUMMARY-GMTS/GMTSPSO.m b/r/HEALTH_SUMMARY-GMTS/GMTSPSO.m index 3fa3dece..6351373d 100644 --- a/r/HEALTH_SUMMARY-GMTS/GMTSPSO.m +++ b/r/HEALTH_SUMMARY-GMTS/GMTSPSO.m @@ -1,67 +1,62 @@ -GMTSPSO ; SLC/JER,KER/NDBI - OP Rx Summary Component (V6) ; 08/27/2002 - ;;2.7;Health Summary;**15,28,37,56,78,80**;Oct 20, 1995;Build 9 - ; - ; External References - ; DBIA 10141 $$VERSION^XPDUTL - ; DBIA 2931 HS^A7RPSOHS - ; DBIA 2931 HS^A7RPSOHS - ; DBIA 330 ^PSOHCSUM, ACS^PSOHCSUM - ; DBIA 522 ^PS(55, - ; DBIA 10035 ^DPT( file #2 - ; DBIA 3136 ^PS(59.7, - ; -MAIN ; OP Rx HS Comp - ; Check for version 7 (or greater) MAIN^GMTSPSO7 - I $$VERSION^XPDUTL("PSO")'<7 G MAIN^GMTSPSO7 - ; If not version 7 MAIN^GMTSPSO - N ECD,GMR,IX,PSOBEGIN,PSOACT,GMX,GMTOP - S PSOBEGIN=$S(GMTS2'=9999999:(9999999-GMTS2),1:"") - I PSOBEGIN="" S PSOACT=1 K PSOBEGIN - K ^TMP("PSOO",$J),^TMP($J,"GMTSPS") - D PROF^PSO52API(DFN,"GMTSPS",1,9999999) - D:$$ROK^GMTSU("A7RPSOHS")&($$NDBI^GMTSU) HS^A7RPSOHS(DFN) - I +$G(^TMP($J,"GMTSPS",DFN,0))<1,'$D(^TMP($J,"GMTSPS",DFN,"ARC")) Q - I '$G(^TMP($J,"GMTSPS",DFN,0)),$D(^TMP($J,"GMTSPS",DFN,"ARC")) D CKP^GMTSUP Q:$D(GMTSQIT) W "Patient Has Archived OP Prescriptions",! - ;I '$D(^PS(55,DFN,"P")),'$D(^("ARC")),'$D(^TMP("PSOO",$J)) Q - ;I '$O(^PS(55,DFN,"P",0)),$D(^PS(55,DFN,"ARC")) D CKP^GMTSUP Q:$D(GMTSQIT) W "Patient Has Archived OP Prescriptions",! - I $L($T(ACS^PSOHCSUM))>0 D ACS^PSOHCSUM D:$$ROK^GMTSU("A7RPSOHS")&($$NDBI^GMTSU) HS^A7RPSOHS(DFN) I '$D(^TMP("PSOO",$J)) Q - I $L($T(ACS^PSOHCSUM))'>0 D ^PSOHCSUM D:$$ROK^GMTSU("A7RPSOHS")&($$NDBI^GMTSU) HS^A7RPSOHS(DFN) I '$D(^TMP("PSOO",$J)) Q - S GMTSLO=GMTSLO+3 - S (GMX,GMTOP,IX)=0 - F S IX=$O(^TMP("PSOO",$J,IX)) Q:IX'>0 S GMR=$G(^(IX,0)) D WRT - S GMTSLO=GMTSLO-3 - K ^TMP("PSOO",$J) - Q -WRT ; Writes OP Pharmacy Segment Record - N ID,LFD,X,MI,NL,CF,GMD,GMV,GMI,GUI S GUI=$$HF^GMTSU - S ID=$P(GMR,U),LFD=$P(GMR,U,2),ECD=$P(GMR,U,11),CF=$P(GMR,U,10) - ; Don't display when issue date is after To Date - Q:+$G(GMRANGE)&(ID>(9999999-GMTS1)) - F GMV="ID","LFD","ECD" S X=@GMV D REGDT4^GMTSU S @GMV=X K X - S MI=$G(^TMP("PSOO",$J,IX,1)),NL=0 I $L(MI)>73 D PARSE - S GMD=$P($P(GMR,U,4),";",2) - D CKP^GMTSUP Q:$D(GMTSQIT) - D:GMTSNPG!(GMX'>0) HEAD W:'GMTOP ! S GMTOP=0 W $P($P(GMR,U,3),";",2) - W !,?18,$P(GMR,U,6),?31,$S($P($P(GMR,U,5),";")="S":"ACTIVE/SUSP",1:$P($P(GMR,U,5),";",2)),?45,$P(GMR,U,7),?54,ID,?65,LFD,?76,"("_$P(GMR,U,8)_")",! - S GMX=1 I 'NL D CKP^GMTSUP Q:$D(GMTSQIT) D:GMTSNPG HEAD W ?2,"SIG: ",MI,! S GMTOP=0 - F GMI=1:1:NL D CKP^GMTSUP Q:$D(GMTSQIT) D:GMTSNPG HEAD W:GMI=1 ?2,"SIG: " W ?7,MI(GMI),! S GMTOP=0 - D CKP^GMTSUP Q:$D(GMTSQIT) D:GMTSNPG HEAD W ?4,"Provider: ",$E(GMD,1,22) W:CF ?37,"Cost/Fill: $",$J(CF,6,2) - I "EC"[$P($P(GMR,U,5),";"),ECD]"" W ?57,"Exp/Can Dt: "_ECD - W ! S GMTOP=0 - Q -PARSE ; Parses Medication Instructions - N GMI,NW,WPL - S NL=$S(($L(MI)/73)>($L(MI)\73):($L(MI)\73)+1,1:$L(MI)\73) - S NW=$L(MI," "),WPL=$S((NW/NL)>(NW\NL):(NW\NL)+1,1:NW\NL) - F GMI=1:1:NL S MI(GMI)=$P(MI," ",(GMI-1)*WPL+1,GMI*WPL) - Q -HEAD ; Prints Header - S GMTOP=1 - K ^TMP($J,"GMTSPSSYS") D PSS^PSS59P7(1,,"GMTSPSSYS") - I GMX'>0,$D(^DPT(DFN,.1)),^(.1)]"",+$G(^TMP($J,"GMTSPSSYS",1,40.1)) D CKP^GMTSUP Q:$D(GMTSQIT) W "Outpatient prescriptions are cancelled 72 hours after admission",! - ;I GMX'>0,$D(^DPT(DFN,.1)),^(.1)]"",+($P($G(^PS(59.7,1,40.1)),"^")) D CKP^GMTSUP Q:$D(GMTSQIT) W "Outpatient prescriptions are cancelled 72 hours after admission",! - D CKP^GMTSUP Q:$D(GMTSQIT) W !,"Drug....................................",?65,"Last",! - D CKP^GMTSUP Q:$D(GMTSQIT) - W ?18,"Rx #",?31,"Stat",?45,"Qty",?54,"Issued",?65,"Filled",?76,"Rem" - W:$Y'>(IOSL-GMTSLO)!(+($G(GUI))>0) ! - Q +GMTSPSO ; SLC/JER,KER/NDBI - OP Rx Summary Component (V6) ; 08/27/2002 + ;;2.7;Health Summary;**15,28,37,56,78**;Oct 20, 1995 + ; + ; External References + ; DBIA 10141 $$VERSION^XPDUTL + ; DBIA 2931 HS^A7RPSOHS + ; DBIA 2931 HS^A7RPSOHS + ; DBIA 330 ^PSOHCSUM, ACS^PSOHCSUM + ; DBIA 522 ^PS(55, + ; DBIA 10035 ^DPT( file #2 + ; DBIA 3136 ^PS(59.7, + ; +MAIN ; OP Rx HS Comp + ; Check for version 7 (or greater) MAIN^GMTSPSO7 + I $$VERSION^XPDUTL("PSO")'<7 G MAIN^GMTSPSO7 + ; If not version 7 MAIN^GMTSPSO + N ECD,GMR,IX,PSOBEGIN,PSOACT,GMX,GMTOP + S PSOBEGIN=$S(GMTS2'=9999999:(9999999-GMTS2),1:"") + I PSOBEGIN="" S PSOACT=1 K PSOBEGIN + K ^TMP("PSOO",$J) + D:$$ROK^GMTSU("A7RPSOHS")&($$NDBI^GMTSU) HS^A7RPSOHS(DFN) + I '$D(^PS(55,DFN,"P")),'$D(^("ARC")),'$D(^TMP("PSOO",$J)) Q + I '$O(^PS(55,DFN,"P",0)),$D(^PS(55,DFN,"ARC")) D CKP^GMTSUP Q:$D(GMTSQIT) W "Patient Has Archived OP Prescriptions",! + I $L($T(ACS^PSOHCSUM))>0 D ACS^PSOHCSUM D:$$ROK^GMTSU("A7RPSOHS")&($$NDBI^GMTSU) HS^A7RPSOHS(DFN) I '$D(^TMP("PSOO",$J)) Q + I $L($T(ACS^PSOHCSUM))'>0 D ^PSOHCSUM D:$$ROK^GMTSU("A7RPSOHS")&($$NDBI^GMTSU) HS^A7RPSOHS(DFN) I '$D(^TMP("PSOO",$J)) Q + S GMTSLO=GMTSLO+3 + S (GMX,GMTOP,IX)=0 + F S IX=$O(^TMP("PSOO",$J,IX)) Q:IX'>0 S GMR=$G(^(IX,0)) D WRT + S GMTSLO=GMTSLO-3 + K ^TMP("PSOO",$J) + Q +WRT ; Writes OP Pharmacy Segment Record + N ID,LFD,X,MI,NL,CF,GMD,GMV,GMI,GUI S GUI=$$HF^GMTSU + S ID=$P(GMR,U),LFD=$P(GMR,U,2),ECD=$P(GMR,U,11),CF=$P(GMR,U,10) + ; Don't display when issue date is after To Date + Q:+$G(GMRANGE)&(ID>(9999999-GMTS1)) + F GMV="ID","LFD","ECD" S X=@GMV D REGDT4^GMTSU S @GMV=X K X + S MI=$G(^TMP("PSOO",$J,IX,1)),NL=0 I $L(MI)>73 D PARSE + S GMD=$P($P(GMR,U,4),";",2) + D CKP^GMTSUP Q:$D(GMTSQIT) + D:GMTSNPG!(GMX'>0) HEAD W:'GMTOP ! S GMTOP=0 W $P($P(GMR,U,3),";",2) + W !,?18,$P(GMR,U,6),?31,$S($P($P(GMR,U,5),";")="S":"ACTIVE/SUSP",1:$P($P(GMR,U,5),";",2)),?45,$P(GMR,U,7),?54,ID,?65,LFD,?76,"("_$P(GMR,U,8)_")",! + S GMX=1 I 'NL D CKP^GMTSUP Q:$D(GMTSQIT) D:GMTSNPG HEAD W ?2,"SIG: ",MI,! S GMTOP=0 + F GMI=1:1:NL D CKP^GMTSUP Q:$D(GMTSQIT) D:GMTSNPG HEAD W:GMI=1 ?2,"SIG: " W ?7,MI(GMI),! S GMTOP=0 + D CKP^GMTSUP Q:$D(GMTSQIT) D:GMTSNPG HEAD W ?4,"Provider: ",$E(GMD,1,22) W:CF ?37,"Cost/Fill: $",$J(CF,6,2) + I "EC"[$P($P(GMR,U,5),";"),ECD]"" W ?57,"Exp/Can Dt: "_ECD + W ! S GMTOP=0 + Q +PARSE ; Parses Medication Instructions + N GMI,NW,WPL + S NL=$S(($L(MI)/73)>($L(MI)\73):($L(MI)\73)+1,1:$L(MI)\73) + S NW=$L(MI," "),WPL=$S((NW/NL)>(NW\NL):(NW\NL)+1,1:NW\NL) + F GMI=1:1:NL S MI(GMI)=$P(MI," ",(GMI-1)*WPL+1,GMI*WPL) + Q +HEAD ; Prints Header + S GMTOP=1 + I GMX'>0,$D(^DPT(DFN,.1)),^(.1)]"",+($P($G(^PS(59.7,1,40.1)),"^")) D CKP^GMTSUP Q:$D(GMTSQIT) W "Outpatient prescriptions are cancelled 72 hours after admission",! + D CKP^GMTSUP Q:$D(GMTSQIT) W !,"Drug....................................",?65,"Last",! + D CKP^GMTSUP Q:$D(GMTSQIT) + W ?18,"Rx #",?31,"Stat",?45,"Qty",?54,"Issued",?65,"Filled",?76,"Rem" + W:$Y'>(IOSL-GMTSLO)!(+($G(GUI))>0) ! + Q diff --git a/r/HEALTH_SUMMARY-GMTS/GMTSPSO7.m b/r/HEALTH_SUMMARY-GMTS/GMTSPSO7.m index 2fd41fa4..5816cdfe 100644 --- a/r/HEALTH_SUMMARY-GMTS/GMTSPSO7.m +++ b/r/HEALTH_SUMMARY-GMTS/GMTSPSO7.m @@ -1,61 +1,56 @@ -GMTSPSO7 ; SLC/JER/KER - OP Rx Summary Component (V7) ; 08/27/2002 - ;;2.7;Health Summary;**15,28,37,56,78,80**;Oct 20, 1995;Build 9 - ; - ; External References - ; DBIA 330 ^PSOHCSUM, ACS^PSOHCSUM - ; DBIA 522 ^PS(55, - ; DBIA 10035 ^DPT( file #2 - ; DBIA 3136 ^PS(59.7, - ; DBIA 10011 ^DIWP - ; -MAIN ; OP Rx HS Component - N ECD,GMR,IX,PSOBEGIN,PSOACT,GMX,GMTOP - S PSOBEGIN=$S(GMTS2'=9999999:(9999999-GMTS2),1:"") - I PSOBEGIN="" S PSOACT=1 K PSOBEGIN - K ^TMP("PSOO",$J),^TMP($J,"GMTSPS") - D PROF^PSO52API(DFN,"GMTSPS",1,9999999) - I +$G(^TMP($J,"GMTSPS",DFN,0))<1,'$D(^TMP($J,"GMTSPS",DFN,"ARC")) Q - I '$G(^TMP($J,"GMTSPS",DFN,0)),$D(^TMP($J,"GMTSPS",DFN,"ARC")) D CKP^GMTSUP Q:$D(GMTSQIT) W "Patient Has Archived OP Prescriptions",! - ;I '$D(^PS(55,DFN,"P")),'$D(^("ARC")) Q - ;I '$O(^PS(55,DFN,"P",0)),$D(^PS(55,DFN,"ARC")) D CKP^GMTSUP Q:$D(GMTSQIT) W "Patient Has Archived OP Prescriptions",! - I $L($T(ACS^PSOHCSUM))>0 D ACS^PSOHCSUM I '$D(^TMP("PSOO",$J)) Q - I $L($T(ACS^PSOHCSUM))'>0 D ^PSOHCSUM I '$D(^TMP("PSOO",$J)) Q - S GMTSLO=GMTSLO+3 - S (GMTOP,GMX,IX)=0 - F S IX=$O(^TMP("PSOO",$J,IX)) Q:IX'>0 S GMR=$G(^(IX,0)) D WRT - S GMTSLO=GMTSLO-3 - K ^TMP("PSOO",$J),^UTILITY($J,"W") - Q -WRT ; Writes OP Pharmacy Segment Record - N ID,LFD,X,MI,NL,CF,GMD,GMV,GMI,DIWL,DIWR,DIWF,GMSIG,GUI S GUI=$$HF^GMTSU - S ID=$P(GMR,U),LFD=$P(GMR,U,2),ECD=$P(GMR,U,11),CF=$P(GMR,U,10) - ; Don't display when issue date is after To Date - Q:+$G(GMRANGE)&(ID>(9999999-GMTS1)) - F GMV="ID","LFD","ECD" S X=@GMV D REGDT4^GMTSU S @GMV=X K X - S NL=0,DIWL=1,DIWR=73,DIWF="" K ^UTILITY($J,"W") - F S NL=$O(^TMP("PSOO",$J,IX,NL)) Q:NL'>0 D - . S X=$G(^TMP("PSOO",$J,IX,NL,0)) D ^DIWP - S GMD=$P($P(GMR,U,4),";",2) - D CKP^GMTSUP Q:$D(GMTSQIT) - D:GMTSNPG!(GMX'>0) HEAD W:'GMTOP ! S GMTOP=0 W $P($P(GMR,U,3),";",2) - W !,?18,$P(GMR,U,6),?31,$S($G(GMR)["SUSPENDED":"ACTIVE/SUSP",1:$P($P(GMR,U,5),";",2)),?45,$P(GMR,U,7),?54,ID,?65,LFD,?76,"("_$P(GMR,U,8)_")",! - S GMX=1,GMI=0,GMSIG=1 - F S GMI=$O(^UTILITY($J,"W",DIWL,GMI)) Q:GMI'>0!$D(GMTSQIT) D - . D CKP^GMTSUP Q:$D(GMTSQIT) D:GMTSNPG HEAD - . S MI=$G(^UTILITY($J,"W",DIWL,GMI,0)) - . W:GMSIG=1 ?2,"SIG: " S:GMSIG=1 GMSIG=0 W ?7,MI,! S GMTOP=0 - D CKP^GMTSUP Q:$D(GMTSQIT) D:GMTSNPG HEAD W ?4,"Provider: ",$E(GMD,1,22) W:CF ?37,"Cost/Fill: $",$J(CF,6,2) - I "EC"[$P($P(GMR,U,5),";"),ECD]"" W ?57,"Exp/Can Dt: "_ECD - W ! S GMTOP=0 - Q -HEAD ; Prints Header - ; Only write the next line when there is data - S GMTOP=1 - K ^TMP($J,"GMTSPSSYS") D PSS^PSS59P7(1,,"GMTSPSSYS") - I GMX'>0,$D(^DPT(DFN,.1)),^(.1)]"",+$G(^TMP($J,"GMTSPSSYS",1,40.1)) D CKP^GMTSUP Q:$D(GMTSQIT) W "Outpatient prescriptions are cancelled 72 hours after admission",! - ;I GMX'>0,$D(^DPT(DFN,.1)),^(.1)]"",+($P($G(^PS(59.7,1,40.1)),"^")) D CKP^GMTSUP Q:$D(GMTSQIT) W "Outpatient prescriptions are cancelled 72 hours after admission",! - D CKP^GMTSUP Q:$D(GMTSQIT) W !,"Drug....................................",?65,"Last",! - D CKP^GMTSUP Q:$D(GMTSQIT) - W ?18,"Rx #",?31,"Stat",?45,"Qty",?54,"Issued",?65,"Filled",?76,"Rem" - W:$Y'>(IOSL-GMTSLO)!(+($G(GUI))>0) ! - Q +GMTSPSO7 ; SLC/JER/KER - OP Rx Summary Component (V7) ; 08/27/2002 + ;;2.7;Health Summary;**15,28,37,56,78**;Oct 20, 1995 + ; + ; External References + ; DBIA 330 ^PSOHCSUM, ACS^PSOHCSUM + ; DBIA 522 ^PS(55, + ; DBIA 10035 ^DPT( file #2 + ; DBIA 3136 ^PS(59.7, + ; DBIA 10011 ^DIWP + ; +MAIN ; OP Rx HS Component + N ECD,GMR,IX,PSOBEGIN,PSOACT,GMX,GMTOP + S PSOBEGIN=$S(GMTS2'=9999999:(9999999-GMTS2),1:"") + I PSOBEGIN="" S PSOACT=1 K PSOBEGIN + K ^TMP("PSOO",$J) + I '$D(^PS(55,DFN,"P")),'$D(^("ARC")) Q + I '$O(^PS(55,DFN,"P",0)),$D(^PS(55,DFN,"ARC")) D CKP^GMTSUP Q:$D(GMTSQIT) W "Patient Has Archived OP Prescriptions",! + I $L($T(ACS^PSOHCSUM))>0 D ACS^PSOHCSUM I '$D(^TMP("PSOO",$J)) Q + I $L($T(ACS^PSOHCSUM))'>0 D ^PSOHCSUM I '$D(^TMP("PSOO",$J)) Q + S GMTSLO=GMTSLO+3 + S (GMTOP,GMX,IX)=0 + F S IX=$O(^TMP("PSOO",$J,IX)) Q:IX'>0 S GMR=$G(^(IX,0)) D WRT + S GMTSLO=GMTSLO-3 + K ^TMP("PSOO",$J),^UTILITY($J,"W") + Q +WRT ; Writes OP Pharmacy Segment Record + N ID,LFD,X,MI,NL,CF,GMD,GMV,GMI,DIWL,DIWR,DIWF,GMSIG,GUI S GUI=$$HF^GMTSU + S ID=$P(GMR,U),LFD=$P(GMR,U,2),ECD=$P(GMR,U,11),CF=$P(GMR,U,10) + ; Don't display when issue date is after To Date + Q:+$G(GMRANGE)&(ID>(9999999-GMTS1)) + F GMV="ID","LFD","ECD" S X=@GMV D REGDT4^GMTSU S @GMV=X K X + S NL=0,DIWL=1,DIWR=73,DIWF="" K ^UTILITY($J,"W") + F S NL=$O(^TMP("PSOO",$J,IX,NL)) Q:NL'>0 D + . S X=$G(^TMP("PSOO",$J,IX,NL,0)) D ^DIWP + S GMD=$P($P(GMR,U,4),";",2) + D CKP^GMTSUP Q:$D(GMTSQIT) + D:GMTSNPG!(GMX'>0) HEAD W:'GMTOP ! S GMTOP=0 W $P($P(GMR,U,3),";",2) + W !,?18,$P(GMR,U,6),?31,$S($G(GMR)["SUSPENDED":"ACTIVE/SUSP",1:$P($P(GMR,U,5),";",2)),?45,$P(GMR,U,7),?54,ID,?65,LFD,?76,"("_$P(GMR,U,8)_")",! + S GMX=1,GMI=0,GMSIG=1 + F S GMI=$O(^UTILITY($J,"W",DIWL,GMI)) Q:GMI'>0!$D(GMTSQIT) D + . D CKP^GMTSUP Q:$D(GMTSQIT) D:GMTSNPG HEAD + . S MI=$G(^UTILITY($J,"W",DIWL,GMI,0)) + . W:GMSIG=1 ?2,"SIG: " S:GMSIG=1 GMSIG=0 W ?7,MI,! S GMTOP=0 + D CKP^GMTSUP Q:$D(GMTSQIT) D:GMTSNPG HEAD W ?4,"Provider: ",$E(GMD,1,22) W:CF ?37,"Cost/Fill: $",$J(CF,6,2) + I "EC"[$P($P(GMR,U,5),";"),ECD]"" W ?57,"Exp/Can Dt: "_ECD + W ! S GMTOP=0 + Q +HEAD ; Prints Header + ; Only write the next line when there is data + S GMTOP=1 + I GMX'>0,$D(^DPT(DFN,.1)),^(.1)]"",+($P($G(^PS(59.7,1,40.1)),"^")) D CKP^GMTSUP Q:$D(GMTSQIT) W "Outpatient prescriptions are cancelled 72 hours after admission",! + D CKP^GMTSUP Q:$D(GMTSQIT) W !,"Drug....................................",?65,"Last",! + D CKP^GMTSUP Q:$D(GMTSQIT) + W ?18,"Rx #",?31,"Stat",?45,"Qty",?54,"Issued",?65,"Filled",?76,"Rem" + W:$Y'>(IOSL-GMTSLO)!(+($G(GUI))>0) ! + Q diff --git a/r/HEALTH_SUMMARY-GMTS/GMTSPSZO.m b/r/HEALTH_SUMMARY-GMTS/GMTSPSZO.m index 2f5b7899..d14f5970 100644 --- a/r/HEALTH_SUMMARY-GMTS/GMTSPSZO.m +++ b/r/HEALTH_SUMMARY-GMTS/GMTSPSZO.m @@ -1,43 +1,39 @@ -GMTSPSZO ;SLC/JER - OP Rx 5.6 Summary Component ;12/2/91 13:45 ; - ;;2.7;Health Summary;**80**;Oct 20, 1995;Build 9 -GMTSPSO ;SLC/JER - OP Rx Summary Component ;12/2/91 13:45 ; - ;;2.7;Health Summary;;Oct 20, 1995 -MAIN N ECD,GMR,GMW,IX,PSOBEGIN - S PSOBEGIN=$S(GMTS2'=9999999:(9999999-GMTS2),1:"") - I PSOBEGIN="" S PSOACT=1 - K ^UTILITY("PSOO",$J),^TMP($J,"GMTSPS") - D PROF^PSO52API(DFN,"GMTSPS",1,9999999) - I +$G(^TMP($J,"GMTSPS",DFN,0))<1,'$D(^TMP($J,"GMTSPS",DFN,"ARC")) Q - I '$G(^TMP($J,"GMTSPS",DFN,0)),$D(^TMP($J,"GMTSPS",DFN,"ARC")) D CKP^GMTSUP Q:$D(GMTSQIT) W "Patient Has Archived OP Prescriptions",! - ;I '$D(^PS(55,DFN,"P")),'$D(^("ARC")) Q - ;I '$O(^PS(55,DFN,"P",0)),$D(^PS(55,DFN,"ARC")) D CKP^GMTSUP Q:$D(GMTSQIT) W "Patient Has Archived OP Prescriptions",! - D ^PSOHCSUM I '$D(^UTILITY("PSOO",$J)) Q - I $D(^DPT(DFN,.1)),^(.1)]"",$D(^DIC(59,+$O(^DIC(59,0)),1)),$P(^(1),"^",8) D CKP^GMTSUP Q:$D(GMTSQIT) W "Outpatient prescriptions are cancelled 72 hours after admission",! - S GMTSLO=GMTSLO+3 - D HEAD - S IX=0 F S IX=$O(^UTILITY("PSOO",$J,IX)) Q:IX'>0 S GMR=$G(^(IX,0)) D WRT - S GMTSLO=GMTSLO-3 - K ^UTILITY("PSOO",$J) - Q -HEAD ; Prints Header - D CKP^GMTSUP Q:$D(GMTSQIT) W ?67,"Last",! - D CKP^GMTSUP Q:$D(GMTSQIT) - W "Drug",?27,"Rx #",?38,"St (Exp/Can)",?51,"Qty",?58,"Issued",?67,"Filled",?76,"Rem",! W:$Y'>(IOSL-GMTSLO) ! - Q -WRT ; Writes OP Pharmacy Segment Record - N ID,LFD,X,MI,NL,CF,GMD,GMV,GMI - S ID=$P(GMR,U),LFD=$P(GMR,U,2),ECD=$P(GMR,U,11),CF=$P(GMR,U,10) - F GMV="ID","LFD","ECD" S X=@GMV D REGDT^GMTSU S @GMV=X K X - S MI=$G(^UTILITY("PSOO",$J,IX,1)),NL=0 I $L(MI)>73 D PARSE - S GMD=$P($P(GMR,U,4),";",2) - D CKP^GMTSUP Q:$D(GMTSQIT) D:GMTSNPG HEAD W $E($P($P(GMR,U,3),";",2),1,25),?27,$P(GMR,U,6),?38,$P($P(GMR,U,5),";"),?40,$S("EC"[$P($P(GMR,U,5),";"):"("_ECD_")",1:""),?51,$P(GMR,U,7),?57,ID,?67,LFD,?76,"("_$P(GMR,U,8)_")",! - I 'NL D CKP^GMTSUP Q:$D(GMTSQIT) D:GMTSNPG HEAD W ?2,MI,! - F GMI=1:1:NL D CKP^GMTSUP Q:$D(GMTSQIT) D:GMTSNPG HEAD W ?2,MI(GMI),! - D CKP^GMTSUP Q:$D(GMTSQIT) D:GMTSNPG HEAD W ?4,"Provider: ",$E(GMD,1,26) W:CF ?41,"Cost/Fill: $",$J(CF,6,2) W ! - Q -PARSE ; Parses Medication Instructions - N GMI,NW,WPL - S NL=$S(($L(MI)/73)>($L(MI)\73):($L(MI)\73)+1,1:$L(MI)\73) - S NW=$L(MI," "),WPL=$S((NW/NL)>(NW\NL):(NW\NL)+1,1:NW\NL) - F GMI=1:1:NL S MI(GMI)=$P(MI," ",(GMI-1)*WPL+1,GMI*WPL) - Q +GMTSPSZO ;SLC/JER - OP Rx 5.6 Summary Component ;12/2/91 13:45 ; + ;;2.7;Health Summary;;Oct 20, 1995 +GMTSPSO ;SLC/JER - OP Rx Summary Component ;12/2/91 13:45 ; + ;;2.7;Health Summary;;Oct 20, 1995 +MAIN N ECD,GMR,GMW,IX,PSOBEGIN + S PSOBEGIN=$S(GMTS2'=9999999:(9999999-GMTS2),1:"") + I PSOBEGIN="" S PSOACT=1 + K ^UTILITY("PSOO",$J) I '$D(^PS(55,DFN,"P")),'$D(^("ARC")) Q + I '$O(^PS(55,DFN,"P",0)),$D(^PS(55,DFN,"ARC")) D CKP^GMTSUP Q:$D(GMTSQIT) W "Patient Has Archived OP Prescriptions",! + D ^PSOHCSUM I '$D(^UTILITY("PSOO",$J)) Q + I $D(^DPT(DFN,.1)),^(.1)]"",$D(^DIC(59,+$O(^DIC(59,0)),1)),$P(^(1),"^",8) D CKP^GMTSUP Q:$D(GMTSQIT) W "Outpatient prescriptions are cancelled 72 hours after admission",! + S GMTSLO=GMTSLO+3 + D HEAD + S IX=0 F S IX=$O(^UTILITY("PSOO",$J,IX)) Q:IX'>0 S GMR=$G(^(IX,0)) D WRT + S GMTSLO=GMTSLO-3 + K ^UTILITY("PSOO",$J) + Q +HEAD ; Prints Header + D CKP^GMTSUP Q:$D(GMTSQIT) W ?67,"Last",! + D CKP^GMTSUP Q:$D(GMTSQIT) + W "Drug",?27,"Rx #",?38,"St (Exp/Can)",?51,"Qty",?58,"Issued",?67,"Filled",?76,"Rem",! W:$Y'>(IOSL-GMTSLO) ! + Q +WRT ; Writes OP Pharmacy Segment Record + N ID,LFD,X,MI,NL,CF,GMD,GMV,GMI + S ID=$P(GMR,U),LFD=$P(GMR,U,2),ECD=$P(GMR,U,11),CF=$P(GMR,U,10) + F GMV="ID","LFD","ECD" S X=@GMV D REGDT^GMTSU S @GMV=X K X + S MI=$G(^UTILITY("PSOO",$J,IX,1)),NL=0 I $L(MI)>73 D PARSE + S GMD=$P($P(GMR,U,4),";",2) + D CKP^GMTSUP Q:$D(GMTSQIT) D:GMTSNPG HEAD W $E($P($P(GMR,U,3),";",2),1,25),?27,$P(GMR,U,6),?38,$P($P(GMR,U,5),";"),?40,$S("EC"[$P($P(GMR,U,5),";"):"("_ECD_")",1:""),?51,$P(GMR,U,7),?57,ID,?67,LFD,?76,"("_$P(GMR,U,8)_")",! + I 'NL D CKP^GMTSUP Q:$D(GMTSQIT) D:GMTSNPG HEAD W ?2,MI,! + F GMI=1:1:NL D CKP^GMTSUP Q:$D(GMTSQIT) D:GMTSNPG HEAD W ?2,MI(GMI),! + D CKP^GMTSUP Q:$D(GMTSQIT) D:GMTSNPG HEAD W ?4,"Provider: ",$E(GMD,1,26) W:CF ?41,"Cost/Fill: $",$J(CF,6,2) W ! + Q +PARSE ; Parses Medication Instructions + N GMI,NW,WPL + S NL=$S(($L(MI)/73)>($L(MI)\73):($L(MI)\73)+1,1:$L(MI)\73) + S NW=$L(MI," "),WPL=$S((NW/NL)>(NW\NL):(NW\NL)+1,1:NW\NL) + F GMI=1:1:NL S MI(GMI)=$P(MI," ",(GMI-1)*WPL+1,GMI*WPL) + Q diff --git a/r/HEALTH_SUMMARY-GMTS/GMTSRAE.m b/r/HEALTH_SUMMARY-GMTS/GMTSRAE.m index aa92732a..9e016916 100644 --- a/r/HEALTH_SUMMARY-GMTS/GMTSRAE.m +++ b/r/HEALTH_SUMMARY-GMTS/GMTSRAE.m @@ -1,192 +1,195 @@ -GMTSRAE ; SLC/JER,KER HIN/GJC Selected Radiology Extract ; 04/19/2002 - ;;2.7;Health Summary;**14,25,30,37,40,47,49,51,84**;Oct 20, 1995;Build 6 - ; - ; External References - ; DBIA 3125 ^RADPT( file 70 - ; DBIA 501 ^RARPT( file 74, fields 5, 200, 300 and 400 - ; DBIA 3417 ^RA(72, file 72, field 3 pending - ; DBIA 502 ^RAMIS(71, file 71, field 9 - ; DBIA 10015 EN^DIQ1 - ; DBIA 2056 $$GET1^DIQ (files 71, 72, and 74) - ; DBIA 2056 GETS^DIQ (file 70, subfile 70.03) - ; DBIA 1995 $$CPT^ICPTCOD - ; DBIA 10103 $$DT^XLFDT - ; DBIA 10104 $$UP^XLFSTR - ; DBIA 1996 $$MOD^ICPTMOD - ; DBIA 10011 ^DIWP - ; -MAINSEL(MODE,TEST) ; Entry for Selection Items - N GMTSIDT,GMTSIDT2,GMTSCNT,GMTSPN,GMTSMAX K ^TMP("RAE",$J) S GMTSCNT=0,GMTSMAX=$S(+$G(GMTSNDM)>0:GMTSNDM,1:999) - S GMTSIDT=+GMTS1,GMTSIDT2=+($P(+GMTS2,".",1))_".999999" - S:+($G(GMTSPXGO))=0 GMTSIDT=$P(GMTS1,".",1),GMTSIDT2=$P(GMTS2,".",1)_".999999" - F S GMTSIDT=$O(^RADPT(DFN,"DT","AP",TEST,GMTSIDT)) Q:GMTSIDT'>0!(GMTSIDT>GMTSIDT2)!(GMTSCNT=GMTSMAX) D - . Q:'$D(^RADPT(DFN,"DT",GMTSIDT,0)) N GMTS7002,GMTSPSET,GMTSXSET - . S GMTS7002=$G(^RADPT(DFN,"DT",GMTSIDT,0)) - . S GMTSXSET=+$P(GMTS7002,"^",5) - . S GMTSPN=0 F S GMTSPN=$O(^RADPT(DFN,"DT","AP",TEST,GMTSIDT,GMTSPN)) Q:GMTSPN'>0!(GMTSCNT=GMTSMAX) D - . . S GMTSCNT=GMTSCNT+1 D GET - Q -MAIN(MODE) ; Main Entry - N GMTSIDT,GMTSCNT,GMTSPN,GMTSMAX - K ^TMP("RAE",$J) S GMTSCNT=0,GMTSMAX=$S(+$G(GMTSNDM)>0:GMTSNDM,1:999) - S GMTSIDT=+GMTS1,GMTSIDT2=+($P(+GMTS2,".",1))_".999999" - S:+($G(GMTSPXGO))=0 GMTSIDT=$P(GMTS1,".",1),GMTSIDT2=$P(GMTS2,".",1)_".999999" - F S GMTSIDT=$O(^RADPT(DFN,"DT",GMTSIDT)) Q:GMTSIDT'>0!(GMTSIDT>GMTSIDT2)!(GMTSCNT=GMTSMAX) D - . Q:'$D(^RADPT(DFN,"DT",GMTSIDT,0)) N GMTS7002,GMTSPSET,GMTSXSET - . S GMTS7002=$G(^RADPT(DFN,"DT",GMTSIDT,0)) - . S GMTSXSET=+$P(GMTS7002,"^",5) - . S GMTSPN=0 F S GMTSPN=$O(^RADPT(DFN,"DT",GMTSIDT,"P",GMTSPN)) Q:GMTSPN'>0!(+GMTSCNT' ^ - ; ^ ^ ^ - ; ^ ^ - ; ^ ^ ^ - ; < exam status order > - ; - ; ^TMP("RAE",$J,GMTSIDT,"EXAMSET") Indicates if all - ; exams for this date/time are part of an exam set - ; - ; ^TMP("RAE",$J,GMTSIDT,"PRINTSET") Indicates if all - ; exams for this exam set share the same report - ; - ; Only if the report is verified -OR- released will - ; these nodes be set - ; - ; ^TMP("RAE",$J,IDT,PN,"D",seq #) = Dx codes - ; Sequence # = 1 Primary Dx - ; Sequence # > 1 Secondary Dx - ; ^TMP("RAE",$J,IDT,PN,"H",line #)= Clinical History line # - ; ^TMP("RAE",$J,IDT,PN,"S",line #)= Reason for Study line # - ; ^TMP("RAE",$J,IDT,PN,"I",line #)= Impression Text line # - ; ^TMP("RAE",$J,IDT,PN,"R",line #)= Report Text line # - ; - N DA,DIC,DIQ,%,D0,DIW,DIWI,DIWT,DIWTC,DIWX,DIWF,DIWL,DIWR,DN,DR - N I,J,Y,Z,GMTSCPT,GMTSED,GMTSCN,GMTSRP,GMTSRPI,GMTSST,GMTSPTR - N GMTSTA,GMTSTAI,GMTSI,GMTSRAD,GMTSRRAD,GMTSSRAD,GMTSTC,GMTSSTO - N GMTSIMGO,GMTSRA27 S GMTSRA27=$$PROK^GMTSU("RAUTL9",27) - S GMTSED=+$P(GMTS7002,"^") - S:GMTSXSET&('$D(^TMP("RAE",$J,GMTSIDT,"EXAMSET"))) ^TMP("RAE",$J,GMTSIDT,"EXAMSET")="" - ; Get - ; Exam Date $P($G(^RADPT(DFN,"DT",GMTSIDT,0)),"^",1) - ; Exam Set $P($G(^RADPT(DFN,"DT",GMTSIDT,0)),"^",5) - ; Case Number 70.03 .01 GMTSCN - ; Procedure 70.03 2 GMTSRP/GMTSRPI - ; Exam Status 70.03 3 GMTSST - ; Imaging Order 70.03 11 GMTSIMGO - ; Prim Interpret Resident 70.03 12 GMTSRRAD - ; Prim Diagnostic Code 70.03 13 GMTSDX - ; Prim Interpreting Staff 70.03 15 GMTSSRAD - ; Report Text 70.03 17 - ; Member of Set 70.03 25 - ; Exam Status Order 72 3 GMTSSTO - ; - S DIC="^RADPT("_DFN_",""DT"","_GMTSIDT_",""P"",",DA=GMTSPN,DIQ="GMTSRAD(" - S DIQ(0)="IE",DR=".01;2;3;11;12;13;15;17;25" D TECH - D EN^DIQ1 - S GMTSCN=$G(GMTSRAD(70.03,GMTSPN,.01,"E")) - S GMTSRP=$G(GMTSRAD(70.03,GMTSPN,2,"E")) - S GMTSRPI=$G(GMTSRAD(70.03,GMTSPN,2,"I")) - S GMTSST=$G(GMTSRAD(70.03,GMTSPN,3,"E")) - S GMTSSTO=$G(GMTSRAD(70.03,GMTSPN,3,"I")) - S GMTSSTO=$$GET1^DIQ(72,+GMTSSTO,3,"I") - S GMTSIMGO=$G(GMTSRAD(70.03,GMTSPN,11,"I")) ;Img Order # IEN - I GMTSTC S GMTSTC(0)=$E($G(GMTSRAD(70.12,GMTSTC,.01,"E")),1,18) - S GMTSRRAD=$E($G(GMTSRAD(70.03,GMTSPN,12,"E")),1,18) - S GMTSSRAD=$E($G(GMTSRAD(70.03,GMTSPN,15,"E")),1,18) - S GMTSPTR=$G(GMTSRAD(70.03,GMTSPN,17,"I")) - ; Exam Set/Report - ; - ; If GMTSPSET = "" single exam - ; If GMTSPSET = 1 exam set, single report - ; If GMTSPSET = 2 exam set, combined report - ; - S GMTSPSET=$G(GMTSRAD(70.03,GMTSPN,25,"I")) - D PMOD,CMOD I +GMTSPTR>0 S DIC="^RARPT(",DA=GMTSPTR,DIQ="GMTSRAD(",DIQ(0)="IE",DR="5" D EN^DIQ1 - S GMTSTA=$G(GMTSRAD(74,+GMTSPTR,5,"E")) - S GMTSTAI=$G(GMTSRAD(74,+GMTSPTR,5,"I")) - I $L(GMTSTAI),("VR"[$E(GMTSTAI)) D GETDX(GMTSPN_","_GMTSIDT_","_DFN_",") - S GMTSCPT=$$GET1^DIQ(71,+GMTSRPI,9,"I") - S GMTSCPT=$S(+GMTSCPT>0:$P($$CPT^ICPTCOD(+GMTSCPT),"^",2),1:"") - S ^TMP("RAE",$J,GMTSIDT,GMTSPN,0)=GMTSED_U_GMTSRP_U_GMTSST_U_GMTSTA_U_GMTSRRAD_U_GMTSSRAD_U_GMTSCPT_U_$G(GMTSTC(0))_U_GMTSCN_U_$G(GMTSSTO) - S GMTSI=0 F S GMTSI=$O(GMTSRAD(70.1,GMTSI)) Q:+GMTSI'>0 D - . S ^TMP("RAE",$J,GMTSIDT,GMTSPN,"M",GMTSI)=$G(GMTSRAD(70.1,GMTSI,.01,"E")) - S GMTSI=0 F S GMTSI=$O(GMTSRAD(70.1,GMTSI)) Q:+GMTSI'>0 D - . S ^TMP("RAE",$J,GMTSIDT,GMTSPN,"M",GMTSI)=$G(GMTSRAD(70.1,GMTSI,.01,"E")) - S GMTSI=0 F S GMTSI=$O(GMTSRAD(70.3135,GMTSI)) Q:+GMTSI'>0 D - . Q:'$L($G(GMTSRAD(70.3135,GMTSI,.01,"M"))) Q:'$L($G(GMTSRAD(70.3135,GMTSI,.01,"N"))) N I S I=+($G(^TMP("RAE",$J,GMTSIDT,GMTSPN,"CM",0)))+1 - . S ^TMP("RAE",$J,GMTSIDT,GMTSPN,"CM",I)=$G(GMTSRAD(70.3135,GMTSI,.01,"M"))_"^"_$$UP^XLFSTR($G(GMTSRAD(70.3135,GMTSI,.01,"N")))_"^"_$G(GMTSRAD(70.3135,GMTSI,.01,"N")),^TMP("RAE",$J,GMTSIDT,GMTSPN,"CM",0)=I - ; Only verified reports can be printed - I GMTSTAI'="V",($E(IOST)="P") D Q - . S:GMTSPSET=2 ^TMP("RAE",$J,GMTSIDT,"PRINTSET")="" - ; Only verified & Released/Unverified can viewed - I $S(GMTSTAI="V":0,GMTSTAI="R":0,1:1) D Q - . S:GMTSPSET=2 ^TMP("RAE",$J,GMTSIDT,"PRINTSET")="" - Q:$D(^TMP("RAE",$J,GMTSIDT,"PRINTSET")) - D GETIMP D:$G(MODE)=2 GETHIS^GMTSRAE1,GETR4S^GMTSRAE1,GETADD,GETREP - S:GMTSPSET=2 ^TMP("RAE",$J,GMTSIDT,"PRINTSET")="" - Q - ; -GETIMP ; Gets Radiologist's Impression - N X,GMTSLN S X=$$GET1^DIQ(74,GMTSPTR,300,,"GMTST") - K ^UTILITY($J,"W") N X,GMTSI S GMTSI=0 F S GMTSI=$O(GMTST(GMTSI)) Q:+GMTSI=0 S X=$G(GMTST(GMTSI)) D FORMAT - I $D(^UTILITY($J,"W")) F GMTSLN=1:1:^UTILITY($J,"W",3) S ^TMP("RAE",$J,GMTSIDT,GMTSPN,"I",GMTSLN)=^UTILITY($J,"W",3,GMTSLN,0) - K ^UTILITY($J,"W"),GMTST - Q -GETADD ; Gets Additional Clinical History (#74) - Q:+($G(GMTSRA27))'>0 N X,GMTSLN S X=$$GET1^DIQ(74,GMTSPTR,400,,"GMTST") - K ^UTILITY($J,"W") N X,GMTSI S GMTSI=0 F S GMTSI=$O(GMTST(GMTSI)) Q:+GMTSI=0 S X=$G(GMTST(GMTSI)) D FORMAT - I $D(^UTILITY($J,"W")) F GMTSLN=1:1:^UTILITY($J,"W",3) D - . S ^TMP("RAE",$J,GMTSIDT,GMTSPN,"A",GMTSLN)=^UTILITY($J,"W",3,GMTSLN,0) - K ^UTILITY($J,"W"),GMTST - Q -GETREP ; Gets Radiologist's Report - N X,GMTSLN S X=$$GET1^DIQ(74,GMTSPTR,200,,"GMTST") - K ^UTILITY($J,"W") N X,I S GMTSI=0 F S GMTSI=$O(GMTST(GMTSI)) Q:+GMTSI=0 S X=$G(GMTST(GMTSI)) D FORMAT - I $D(^UTILITY($J,"W")) F GMTSLN=1:1:^UTILITY($J,"W",3) S ^TMP("RAE",$J,GMTSIDT,GMTSPN,"R",GMTSLN)=^UTILITY($J,"W",3,GMTSLN,0) - K ^UTILITY($J,"W"),GMTST - Q -PMOD ; Procedure Modifiers - N GMTS,GMTSI S GMTS=$G(DIC) Q:'$L(DIC) S GMTSI=+($G(DA)) Q:+GMTSI=0 - N DIC,DA,DR S DIC=GMTS_GMTSI_",""M""," - S DA=0 F S DA=$O(@(DIC_DA_")")) Q:+DA'>0 S DR=".01" D - . D EN^DIQ1 - Q -CMOD ; CPT Modifiers - N GMTS,GMTSI,GMTSC,GMTSCM,GMTSCN S GMTS=$G(DIC) Q:'$L(DIC) S GMTSI=+($G(DA)) Q:+GMTSI=0 - S DT=$$DT^XLFDT,U="^" N DIC,DA,DR S DIC=GMTS_GMTSI_",""CMOD""," - S DA=0 F S DA=$O(@(DIC_DA_")")) Q:+DA'>0 S DR=".01" D EN^DIQ1 - S GMTSI=0 F S GMTSI=$O(GMTSRAD(70.3135,GMTSI)) Q:+GMTSI=0 D - . S GMTSC=$G(GMTSRAD(70.3135,GMTSI,.01,"I")) Q:+GMTSC=0 - . S GMTSCM=$$MOD^ICPTMOD(GMTSC,"I",) - . S GMTSCN=$P(GMTSCM,"^",3),GMTSCM=$P(GMTSCM,"^",2) - . S GMTSRAD(70.3135,GMTSI,.01,"M")=GMTSCM - . S GMTSRAD(70.3135,GMTSI,.01,"N")=$$EN2^GMTSUMX(GMTSCN) - Q -TECH ; Technician - S GMTSTC=+$O(^RADPT(DFN,"DT",GMTSIDT,"P",GMTSPN,"TC",0)) - I GMTSTC S DR=$G(DR)_";175",DR(70.12)=.01,DA(70.12)=GMTSTC F Q:$E(DR,1)'=";" S DR=$E(DR,2,$L(DR)) - Q -FORMAT ; Calls ^DIWP to format each line of text - N DIWL,DIWR,DIWF S DIWL=3,DIWR=($S(MODE=1:76,1:80)) - D ^DIWP Q - ; -GETDX(GMTSIEN) ; Set the data node with diagnostic code info. - ; - ; Input: GMTSIEN = Case IEN_","_exam date_","_DFN_"," - ; Output: ^TMP("RAE",$J,GMTSIDT,GMTSPN,"D",seq #) = Dx codes - ; - ; Sequence # = 1 Primary Dx - ; Sequence # > 1 Secondary Dx - S ^TMP("RAE",$J,$P(GMTSIEN,",",2),$P(GMTSIEN,","),"D",1)=$G(GMTSRAD(70.03,$P(GMTSIEN,","),13,"E")) - N GMTSI,GMTSII,GMTSDX S GMTSI=1 D GETS^DIQ(70.03,GMTSIEN,"13.1*","E","GMTSDX") - S GMTSII="" F S GMTSII=$O(GMTSDX(70.14,GMTSII)) Q:GMTSII="" D - . S GMTSI=GMTSI+1 S ^TMP("RAE",$J,$P(GMTSIEN,",",2),$P(GMTSIEN,","),"D",GMTSI)=$G(GMTSDX(70.14,GMTSII,.01,"E")) - Q +GMTSRAE ; SLC/JER,KER HIN/GJC Selected Radiology Extract ; 04/19/2002 + ;;2.7;Health Summary;**14,25,30,37,40,47,49,51**;Oct 20, 1995 + ; + ; External References + ; DBIA 3125 ^RADPT( file 70 + ; DBIA 501 ^RARPT( file 74, fields 5, 200, 300 and 400 + ; DBIA 3417 ^RA(72, file 72, field 3 pending + ; DBIA 502 ^RAMIS(71, file 71, field 9 + ; DBIA 10015 EN^DIQ1 + ; DBIA 2056 $$GET1^DIQ (files 71, 72, and 74) + ; DBIA 2056 GETS^DIQ (file 70, subfile 70.03) + ; DBIA 1995 $$CPT^ICPTCOD + ; DBIA 10103 $$DT^XLFDT + ; DBIA 10104 $$UP^XLFSTR + ; DBIA 1996 $$MOD^ICPTMOD + ; DBIA 10011 ^DIWP + ; +MAINSEL(MODE,TEST) ; Entry for Selection Items + N GMTSIDT,GMTSIDT2,GMTSCNT,GMTSPN,GMTSMAX K ^TMP("RAE",$J) S GMTSCNT=0,GMTSMAX=$S(+$G(GMTSNDM)>0:GMTSNDM,1:999) + S GMTSIDT=+GMTS1,GMTSIDT2=+($P(+GMTS2,".",1))_".999999" + S:+($G(GMTSPXGO))=0 GMTSIDT=$P(GMTS1,".",1),GMTSIDT2=$P(GMTS2,".",1)_".999999" + F S GMTSIDT=$O(^RADPT(DFN,"DT","AP",TEST,GMTSIDT)) Q:GMTSIDT'>0!(GMTSIDT>GMTSIDT2)!(GMTSCNT=GMTSMAX) D + . Q:'$D(^RADPT(DFN,"DT",GMTSIDT,0)) N GMTS7002,GMTSPSET,GMTSXSET + . S GMTS7002=$G(^RADPT(DFN,"DT",GMTSIDT,0)) + . S GMTSXSET=+$P(GMTS7002,"^",5) + . S GMTSPN=0 F S GMTSPN=$O(^RADPT(DFN,"DT","AP",TEST,GMTSIDT,GMTSPN)) Q:GMTSPN'>0!(GMTSCNT=GMTSMAX) D + . . S GMTSCNT=GMTSCNT+1 D GET + Q +MAIN(MODE) ; Main Entry + N GMTSIDT,GMTSCNT,GMTSPN,GMTSMAX + K ^TMP("RAE",$J) S GMTSCNT=0,GMTSMAX=$S(+$G(GMTSNDM)>0:GMTSNDM,1:999) + S GMTSIDT=+GMTS1,GMTSIDT2=+($P(+GMTS2,".",1))_".999999" + S:+($G(GMTSPXGO))=0 GMTSIDT=$P(GMTS1,".",1),GMTSIDT2=$P(GMTS2,".",1)_".999999" + F S GMTSIDT=$O(^RADPT(DFN,"DT",GMTSIDT)) Q:GMTSIDT'>0!(GMTSIDT>GMTSIDT2)!(GMTSCNT=GMTSMAX) D + . Q:'$D(^RADPT(DFN,"DT",GMTSIDT,0)) N GMTS7002,GMTSPSET,GMTSXSET + . S GMTS7002=$G(^RADPT(DFN,"DT",GMTSIDT,0)) + . S GMTSXSET=+$P(GMTS7002,"^",5) + . S GMTSPN=0 F S GMTSPN=$O(^RADPT(DFN,"DT",GMTSIDT,"P",GMTSPN)) Q:GMTSPN'>0!(+GMTSCNT' ^ + ; ^ ^ ^ + ; ^ ^ + ; ^ ^ ^ + ; < exam status order > + ; + ; ^TMP("RAE",$J,GMTSIDT,"EXAMSET") Indicates if all + ; exams for this date/time are part of an exam set + ; + ; ^TMP("RAE",$J,GMTSIDT,"PRINTSET") Indicates if all + ; exams for this exam set share the same report + ; + ; Only if the report is verified -OR- released will + ; these nodes be set + ; + ; ^TMP("RAE",$J,IDT,PN,"D",seq #) = Dx codes + ; Sequence # = 1 Primary Dx + ; Sequence # > 1 Secondary Dx + ; ^TMP("RAE",$J,IDT,PN,"H",line #)= Clinical History line # + ; ^TMP("RAE",$J,IDT,PN,"I",line #)= Impression Text line # + ; ^TMP("RAE",$J,IDT,PN,"R",line #)= Report Text line # + ; + N DA,DIC,DIQ,%,D0,DIW,DIWI,DIWT,DIWTC,DIWX,DIWF,DIWL,DIWR,DN,DR + N I,J,Y,Z,GMTSCPT,GMTSED,GMTSCN,GMTSRP,GMTSRPI,GMTSST,GMTSPTR + N GMTSTA,GMTSTAI,GMTSI,GMTSRAD,GMTSRRAD,GMTSSRAD,GMTSTC,GMTSSTO + N GMTSRA27 S GMTSRA27=$$PROK^GMTSU("RAUTL9",27) + S GMTSED=+$P(GMTS7002,"^") + S:GMTSXSET&('$D(^TMP("RAE",$J,GMTSIDT,"EXAMSET"))) ^TMP("RAE",$J,GMTSIDT,"EXAMSET")="" + ; Get + ; Exam Date $P($G(^RADPT(DFN,"DT",GMTSIDT,0)),"^",1) + ; Exam Set $P($G(^RADPT(DFN,"DT",GMTSIDT,0)),"^",5) + ; Case Number 70.03 .01 GMTSCN + ; Procedure 70.03 2 GMTSRP/GMTSRPI + ; Exam Status 70.03 3 GMTSST + ; Prim Interpret Resident 70.03 12 GMTSRRAD + ; Prim Diagnostic Code 70.03 13 GMTSDX + ; Prim Interpreting Staff 70.03 15 GMTSSRAD + ; Report Text 70.03 17 + ; Member of Set 70.03 25 + ; Exam Status Order 72 3 GMTSSTO + ; + S DIC="^RADPT("_DFN_",""DT"","_GMTSIDT_",""P"",",DA=GMTSPN,DIQ="GMTSRAD(" + S DIQ(0)="IE",DR=".01;2;3;12;13;15;17;25" D TECH + D EN^DIQ1 + S GMTSCN=$G(GMTSRAD(70.03,GMTSPN,.01,"E")) + S GMTSRP=$G(GMTSRAD(70.03,GMTSPN,2,"E")) + S GMTSRPI=$G(GMTSRAD(70.03,GMTSPN,2,"I")) + S GMTSST=$G(GMTSRAD(70.03,GMTSPN,3,"E")) + S GMTSSTO=$G(GMTSRAD(70.03,GMTSPN,3,"I")) + S GMTSSTO=$$GET1^DIQ(72,+GMTSSTO,3,"I") + I GMTSTC S GMTSTC(0)=$E($G(GMTSRAD(70.12,GMTSTC,.01,"E")),1,18) + S GMTSRRAD=$E($G(GMTSRAD(70.03,GMTSPN,12,"E")),1,18) + S GMTSSRAD=$E($G(GMTSRAD(70.03,GMTSPN,15,"E")),1,18) + S GMTSPTR=$G(GMTSRAD(70.03,GMTSPN,17,"I")) + ; Exam Set/Report + ; + ; If GMTSPSET = "" single exam + ; If GMTSPSET = 1 exam set, single report + ; If GMTSPSET = 2 exam set, combined report + ; + S GMTSPSET=$G(GMTSRAD(70.03,GMTSPN,25,"I")) + D PMOD,CMOD I +GMTSPTR>0 S DIC="^RARPT(",DA=GMTSPTR,DIQ="GMTSRAD(",DIQ(0)="IE",DR="5" D EN^DIQ1 + S GMTSTA=$G(GMTSRAD(74,+GMTSPTR,5,"E")) + S GMTSTAI=$G(GMTSRAD(74,+GMTSPTR,5,"I")) + I $L(GMTSTAI),("VR"[$E(GMTSTAI)) D GETDX(GMTSPN_","_GMTSIDT_","_DFN_",") + S GMTSCPT=$$GET1^DIQ(71,+GMTSRPI,9,"I") + S GMTSCPT=$S(+GMTSCPT>0:$P($$CPT^ICPTCOD(+GMTSCPT),"^",2),1:"") + S ^TMP("RAE",$J,GMTSIDT,GMTSPN,0)=GMTSED_U_GMTSRP_U_GMTSST_U_GMTSTA_U_GMTSRRAD_U_GMTSSRAD_U_GMTSCPT_U_$G(GMTSTC(0))_U_GMTSCN_U_$G(GMTSSTO) + S GMTSI=0 F S GMTSI=$O(GMTSRAD(70.1,GMTSI)) Q:+GMTSI'>0 D + . S ^TMP("RAE",$J,GMTSIDT,GMTSPN,"M",GMTSI)=$G(GMTSRAD(70.1,GMTSI,.01,"E")) + S GMTSI=0 F S GMTSI=$O(GMTSRAD(70.1,GMTSI)) Q:+GMTSI'>0 D + . S ^TMP("RAE",$J,GMTSIDT,GMTSPN,"M",GMTSI)=$G(GMTSRAD(70.1,GMTSI,.01,"E")) + S GMTSI=0 F S GMTSI=$O(GMTSRAD(70.3135,GMTSI)) Q:+GMTSI'>0 D + . Q:'$L($G(GMTSRAD(70.3135,GMTSI,.01,"M"))) Q:'$L($G(GMTSRAD(70.3135,GMTSI,.01,"N"))) N I S I=+($G(^TMP("RAE",$J,GMTSIDT,GMTSPN,"CM",0)))+1 + . S ^TMP("RAE",$J,GMTSIDT,GMTSPN,"CM",I)=$G(GMTSRAD(70.3135,GMTSI,.01,"M"))_"^"_$$UP^XLFSTR($G(GMTSRAD(70.3135,GMTSI,.01,"N")))_"^"_$G(GMTSRAD(70.3135,GMTSI,.01,"N")),^TMP("RAE",$J,GMTSIDT,GMTSPN,"CM",0)=I + ; Only verified reports can be printed + I GMTSTAI'="V",($E(IOST)="P") D Q + . S:GMTSPSET=2 ^TMP("RAE",$J,GMTSIDT,"PRINTSET")="" + ; Only verified & Released/Unverified can viewed + I $S(GMTSTAI="V":0,GMTSTAI="R":0,1:1) D Q + . S:GMTSPSET=2 ^TMP("RAE",$J,GMTSIDT,"PRINTSET")="" + Q:$D(^TMP("RAE",$J,GMTSIDT,"PRINTSET")) + D GETIMP D:$G(MODE)=2 GETHIS,GETADD,GETREP + S:GMTSPSET=2 ^TMP("RAE",$J,GMTSIDT,"PRINTSET")="" + Q + ; +GETIMP ; Gets Radiologist's Impression + N X,GMTSLN S X=$$GET1^DIQ(74,GMTSPTR,300,,"GMTST") + K ^UTILITY($J,"W") N X,GMTSI S GMTSI=0 F S GMTSI=$O(GMTST(GMTSI)) Q:+GMTSI=0 S X=$G(GMTST(GMTSI)) D FORMAT + I $D(^UTILITY($J,"W")) F GMTSLN=1:1:^UTILITY($J,"W",3) S ^TMP("RAE",$J,GMTSIDT,GMTSPN,"I",GMTSLN)=^UTILITY($J,"W",3,GMTSLN,0) + K ^UTILITY($J,"W"),GMTST Q + ; +GETHIS ; Gets Clinical History (#70/#74) + N X,GMTSLN + I +($G(GMTSRA27))>0 S X=$$GET1^DIQ(70.03,(GMTSPN_","_GMTSIDT_","_DFN_","),400,,"GMTST") + I +($G(GMTSRA27))'>0 S X=$$GET1^DIQ(74,GMTSPTR,400,,"GMTST") + K ^UTILITY($J,"W") N X,GMTSI S GMTSI=0 F S GMTSI=$O(GMTST(GMTSI)) Q:+GMTSI=0 S X=$G(GMTST(GMTSI)) D FORMAT + I $D(^UTILITY($J,"W")) F GMTSLN=1:1:^UTILITY($J,"W",3) S ^TMP("RAE",$J,GMTSIDT,GMTSPN,"H",GMTSLN)=^UTILITY($J,"W",3,GMTSLN,0) + K ^UTILITY($J,"W"),GMTST Q + Q +GETADD ; Gets Additional Clinical History (#74) + Q:+($G(GMTSRA27))'>0 N X,GMTSLN S X=$$GET1^DIQ(74,GMTSPTR,400,,"GMTST") + K ^UTILITY($J,"W") N X,GMTSI S GMTSI=0 F S GMTSI=$O(GMTST(GMTSI)) Q:+GMTSI=0 S X=$G(GMTST(GMTSI)) D FORMAT + I $D(^UTILITY($J,"W")) F GMTSLN=1:1:^UTILITY($J,"W",3) D + . S ^TMP("RAE",$J,GMTSIDT,GMTSPN,"A",GMTSLN)=^UTILITY($J,"W",3,GMTSLN,0) + K ^UTILITY($J,"W"),GMTST Q +GETREP ; Gets Radiologist's Report + N X,GMTSLN S X=$$GET1^DIQ(74,GMTSPTR,200,,"GMTST") + K ^UTILITY($J,"W") N X,I S GMTSI=0 F S GMTSI=$O(GMTST(GMTSI)) Q:+GMTSI=0 S X=$G(GMTST(GMTSI)) D FORMAT + I $D(^UTILITY($J,"W")) F GMTSLN=1:1:^UTILITY($J,"W",3) S ^TMP("RAE",$J,GMTSIDT,GMTSPN,"R",GMTSLN)=^UTILITY($J,"W",3,GMTSLN,0) + K ^UTILITY($J,"W"),GMTST Q +PMOD ; Procedure Modifiers + N GMTS,GMTSI S GMTS=$G(DIC) Q:'$L(DIC) S GMTSI=+($G(DA)) Q:+GMTSI=0 + N DIC,DA,DR S DIC=GMTS_GMTSI_",""M""," + S DA=0 F S DA=$O(@(DIC_DA_")")) Q:+DA'>0 S DR=".01" D + . D EN^DIQ1 + Q +CMOD ; CPT Modifiers + N GMTS,GMTSI,GMTSC,GMTSCM,GMTSCN S GMTS=$G(DIC) Q:'$L(DIC) S GMTSI=+($G(DA)) Q:+GMTSI=0 + S DT=$$DT^XLFDT,U="^" N DIC,DA,DR S DIC=GMTS_GMTSI_",""CMOD""," + S DA=0 F S DA=$O(@(DIC_DA_")")) Q:+DA'>0 S DR=".01" D EN^DIQ1 + S GMTSI=0 F S GMTSI=$O(GMTSRAD(70.3135,GMTSI)) Q:+GMTSI=0 D + . S GMTSC=$G(GMTSRAD(70.3135,GMTSI,.01,"I")) Q:+GMTSC=0 + . S GMTSCM=$$MOD^ICPTMOD(GMTSC,"I",) + . S GMTSCN=$P(GMTSCM,"^",3),GMTSCM=$P(GMTSCM,"^",2) + . S GMTSRAD(70.3135,GMTSI,.01,"M")=GMTSCM + . S GMTSRAD(70.3135,GMTSI,.01,"N")=$$EN2^GMTSUMX(GMTSCN) + Q +TECH ; Technician + S GMTSTC=+$O(^RADPT(DFN,"DT",GMTSIDT,"P",GMTSPN,"TC",0)) + I GMTSTC S DR=$G(DR)_";175",DR(70.12)=.01,DA(70.12)=GMTSTC F Q:$E(DR,1)'=";" S DR=$E(DR,2,$L(DR)) + Q +FORMAT ; Calls ^DIWP to format each line of text + N DIWL,DIWR,DIWF S DIWL=3,DIWR=($S(MODE=1:76,1:80)) + D ^DIWP Q + ; +GETDX(GMTSIEN) ; Set the data node with diagnostic code info. + ; + ; Input: GMTSIEN = Case IEN_","_exam date_","_DFN_"," + ; Output: ^TMP("RAE",$J,GMTSIDT,GMTSPN,"D",seq #) = Dx codes + ; + ; Sequence # = 1 Primary Dx + ; Sequence # > 1 Secondary Dx + S ^TMP("RAE",$J,$P(GMTSIEN,",",2),$P(GMTSIEN,","),"D",1)=$G(GMTSRAD(70.03,$P(GMTSIEN,","),13,"E")) + N GMTSI,GMTSII,GMTSDX S GMTSI=1 D GETS^DIQ(70.03,GMTSIEN,"13.1*","E","GMTSDX") + S GMTSII="" F S GMTSII=$O(GMTSDX(70.14,GMTSII)) Q:GMTSII="" D + . S GMTSI=GMTSI+1 S ^TMP("RAE",$J,$P(GMTSIEN,",",2),$P(GMTSIEN,","),"D",GMTSI)=$G(GMTSDX(70.14,GMTSII,.01,"E")) + Q diff --git a/r/HEALTH_SUMMARY-GMTS/GMTSRAS.m b/r/HEALTH_SUMMARY-GMTS/GMTSRAS.m index 5046bf6e..6619acbb 100644 --- a/r/HEALTH_SUMMARY-GMTS/GMTSRAS.m +++ b/r/HEALTH_SUMMARY-GMTS/GMTSRAS.m @@ -1,159 +1,159 @@ -GMTSRAS ; SLC/JER,KER HIN/GJC - Radiology Profile ; 04/19/2002 - ;;2.7;Health Summary;**14,25,28,37,47,51,84**;Oct 20, 1995;Build 6 - ; - ; External References - ; DBIA 3125 ^RADPT( file 70 - ; DBIA 2056 $$GET1^DIQ (file 70) - ; DBIA 10011 ^DIWP - ; -ENSRA ; Controls branching - Q:+($G(DFN))=0 Q:+($G(DFN))'=+($$RP(+($G(DFN)))) - N GMDATA D MAIN^GMTSRAE(2) Q:'$D(^TMP("RAE",$J)) - D LOOP K ^TMP("RAE",$J) Q -LOOP ; Loops through ^TMP("RAE",$J, - N GMW,GMTSORD,GMTSIDT,GMTSPN,GMLN,GMPSET,GMXSET S GMTSIDT=0 - F S GMTSIDT=$O(^TMP("RAE",$J,GMTSIDT)) Q:GMTSIDT'>0 D Q:$D(GMTSQIT) - . S GMPSET=$S($D(^TMP("RAE",$J,GMTSIDT,"PRINTSET")):1,1:0) - . S GMXSET=$S($D(^TMP("RAE",$J,GMTSIDT,"EXAMSET")):1,1:0) - . S GMTSPN=0 F S GMTSPN=$O(^TMP("RAE",$J,GMTSIDT,GMTSPN)) Q:GMTSPN'>0 D - . . S GMTSORD=+($P($G(^TMP("RAE",$J,GMTSIDT,GMTSPN,0)),"^",10)) - . . D WRT D:+$O(^TMP("RAE",$J,GMTSIDT,GMTSPN)) BL Q:$D(GMTSQIT) - . D:+$O(^TMP("RAE",$J,GMTSIDT)) BL Q:$D(GMTSQIT) - Q -WRT ; Writes component data - Q:$D(GMTSQIT) N X,GMI,GMTMP S GMDATA=1,GMTMP=$G(^TMP("RAE",$J,GMTSIDT,GMTSPN,0)) - D CKP^GMTSUP Q:$D(GMTSQIT) - D DAT,PRO D:'GMPSET SSET D:GMPSET PSET - Q - ; -SSET ; Output for Non-Printsets (single exam) (GMPSET=0) - ; - ; Procedure Modifiers, Procedure Status, - ; CPT Code, CPT Modifiers, Interpreting Staff, - ; Interpreting Resident, Report Status, - ; Technologist, Report Text - ; - D:$D(^TMP("RAE",$J,GMTSIDT,GMTSPN,"M")) PMD D CPT,CMD,INS,INR,CAS,EST,STT,RPT - Q -PSET ; Output for Printsets (GMPSET=1) - ; - ; Procedure Modifiers, Procedure Status, - ; CPT Code, CPT Modifier, Report Status, - ; Technologist - ; - D:$D(^TMP("RAE",$J,GMTSIDT,GMTSPN,"M")) PMD D CPT,CMD - D:'+$O(^TMP("RAE",$J,GMTSIDT,GMTSPN)) LSET - Q -LSET ; Last Set/Case in Printset - ; - ; Interpreting Staff, Interpreting Resident, Report Status, - ; Technologist, Report Text - ; - D BL,INS,INR,CAS,EST,STT N GMTSPN S GMTSPN=$O(^TMP("RAE",$J,GMTSIDT,0)) D:GMTSPN RPT - Q - ; Data Elements -DAT ; Date +1 - Q:'$L($G(GMTMP)) Q:+($G(GMTMP))=0 Q:'$D(GMXSET) Q:'$D(GMTSPN) Q:+($G(GMTSIDT))=0 - N X,GMTSDT S X=+GMTMP D REGDT4^GMTSU S GMTSDT=X - D CKP^GMTSUP Q:$D(GMTSQIT) W:+($G(GMXSET))=0 GMTSDT - W:(+($G(GMXSET))>0)&(GMTSPN=$O(^TMP("RAE",$J,GMTSIDT,0))) GMTSDT - Q -PRO ; Procedure 2 - Q:'$L($G(GMTMP)) N GMTSA,GMTSB S GMTSA=$P($G(GMTMP),"^",2) - S:$L(GMTSA)>65 GMTSA=$$WRAP^GMTSORC(GMTSA,65) - D CKP^GMTSUP Q:$D(GMTSQIT) W ?12,$P(GMTSA,"|"),! - F GMTSB=2:1:$L(GMTSA,"|") D Q:$D(GMTSQIT) - . D CKP^GMTSUP Q:$D(GMTSQIT) - . W:$P(GMTSA,"|",GMTSB)]"" ?23,$P(GMTSA,"|",GMTSB),! - Q -CAS ; Case Number 9 - Q:'$L($G(GMTMP)) N GMTSA S GMTSA=$P(GMTMP,"^",9) Q:GMTSA="" - Q:$D(GMTSQIT) D CKP^GMTSUP Q:$D(GMTSQIT) - W ?12,"Exam Case Number:",?33,GMTSA,! - Q -EST ; Exam Status 3 - Q:'$L($G(GMTMP)) N GMTSA S GMTSA=$P(GMTMP,"^",3) Q:GMTSA="" - Q:$D(GMTSQIT) D CKP^GMTSUP Q:$D(GMTSQIT) - W ?12,"Exam Status:",?33,GMTSA,! - Q -RST ; Report Status 4 - Q:'$L($G(GMTMP)) N GMTSA S GMTSA=$P(GMTMP,"^",4) Q:GMTSA="" - Q:$D(GMTSQIT) D CKP^GMTSUP Q:$D(GMTSQIT) - W ?12,"Rpt Status: ",GMTSA,! - Q -INR ; Interpreting Resident 5 - Q:'$L($G(GMTMP)) N GMTSA S GMTSA=$P(GMTMP,"^",5) Q:GMTSA="" - Q:$D(GMTSQIT) D CKP^GMTSUP Q:$D(GMTSQIT) - W ?12,"Interpreting Res.:",?33,GMTSA,! - Q -INS ; Interpreting Staff 6 - Q:'$L($G(GMTMP)) N GMTSA S GMTSA=$P(GMTMP,"^",6) Q:GMTSA="" - Q:$D(GMTSQIT) D CKP^GMTSUP Q:$D(GMTSQIT) - W ?12,"Interpreting Staff:",?33,GMTSA,! - Q -CPT ; CPT Code 7 - Q:'$L($G(GMTMP)) N GMTSA S GMTSA=$P($G(GMTMP),"^",7) - Q:$D(GMTSQIT) D CKP^GMTSUP Q:$D(GMTSQIT) - W ?12,"CPT Code:",?25,GMTSA,! - Q -TEC ; Technologist 8 - Q:'$L($G(GMTMP)) N GMTSA S GMTSA=$P($G(GMTMP),"^",8) Q:GMTSA="" - Q:$D(GMTSQIT) D CKP^GMTSUP Q:$D(GMTSQIT) - W ?12," Technologist: ",GMTSA,! - Q -STT ; Report Status/Technologist 4/8 - Q:'$L($G(GMTMP)) N GMTSA,GMTSB S GMTSA=$P(GMTMP,"^",4),GMTSB=$P(GMTMP,"^",8) - Q:($G(GMTSA)_$G(GMTSB))="" Q:$D(GMTSQIT) D CKP^GMTSUP Q:$D(GMTSQIT) - W ?12,"Rpt Status: ",$E($G(GMTSA),1,18) W ?45," Technologist: ",$G(GMTSB),! - Q -CMD ; CPT Modifiers - N GMTSCPTM - S GMTSCPTM=+($$CPT^GMTSU(+($G(GMTSEGN)))) S:$G(GMPXCMOD)="N" GMTSCPTM=0 - Q:'GMTSCPTM Q:'$L($G(GMTMP)) N GMTSC,GMTSCM,GMTSCT,GMTSI,GMTSCNT S (GMTSC,GMTSCNT)=0 - F S GMTSC=$O(^TMP("RAE",$J,GMTSIDT,GMTSPN,"CM",GMTSC)) Q:+GMTSC=0 D - . S GMTSCM=$P($G(^TMP("RAE",$J,GMTSIDT,GMTSPN,"CM",GMTSC)),"^",1) Q:'$L(GMTSCM) - . S GMTSCT=$P($G(^TMP("RAE",$J,GMTSIDT,GMTSPN,"CM",GMTSC)),"^",3) Q:'$L(GMTSCT) - . S GMTSCT=GMTSCM_" - "_GMTSCT - . S GMTSCNT=GMTSCNT+1 - . S:$L(GMTSCT)>47 GMTSCT=$$WRAP^GMTSORC(GMTSCT,47) - . D CKP^GMTSUP Q:$D(GMTSQIT) - . W:GMTSCNT=1 ?12,"CPT Modifier:" W ?28,$P(GMTSCT,"|"),! - . F GMTSI=2:1:$L(GMTSCT,"|") D Q:$D(GMTSQIT) - . . D CKP^GMTSUP Q:$D(GMTSQIT) W:$P(GMTSCT,"|",GMTSI)]"" ?33,$P(GMTSCT,"|",GMTSI),! - Q -PMD ; Procedure Modifiers - Q:'$L($G(GMTMP)) D CKP^GMTSUP Q:$D(GMTSQIT) W:+($O(^TMP("RAE",$J,GMTSIDT,GMTSPN,"M",0)))>0 ?12,"Procedure Modifier:" - S GMI=0 F S GMI=$O(^TMP("RAE",$J,GMTSIDT,GMTSPN,"M",GMI)) Q:+GMI'>0 D - . D CKP^GMTSUP Q:$D(GMTSQIT) - . W ?33,^TMP("RAE",$J,GMTSIDT,GMTSPN,"M",GMI),! - Q - ; -RPT ; Report Text - N GMTSL F GMTSL="S","H","A","R","I","D" D TXT(GMTSL) - Q -TXT(X) ; Report Text Lines - N GMTST S GMTST=$E($G(X),1) Q:(GMTST="")!("^S^H^A^R^I^D^"'[GMTST)!(GMTST="^") - Q:GMTST="A"&(+($$PROK^GMTSU("RAUTL9",27))=0) - Q:+($G(GMTSIDT))=0 Q:+($G(GMTSPN))=0 Q:'$D(^TMP("RAE",$J,GMTSIDT,GMTSPN,GMTST)) - K ^UTILITY($J,"W") N GMTSI,GMTSII,GMTSIND,DIWF,DIWL,DIWR S GMTSIND=12,DIWF="C"_(78-(GMTSIND+2)),DIWL=0,DIWR=0,GMTSI=0 - D:$O(^TMP("RAE",$J,GMTSIDT,GMTSPN,GMTST,0))>0 BL - D CKP^GMTSUP Q:$D(GMTSQIT) - W ?GMTSIND,$S(GMTST="S":"Reason for Study: ",GMTST="H":"History: ",GMTST="A":"Additional History: ",GMTST="R":"Report: ",GMTST="I":"Impression: ",GMTST="D":"DX Codes: ",1:"Text:"),! - I GMTST'="D" D - . S GMTSI=0 F S GMTSI=$O(^TMP("RAE",$J,GMTSIDT,GMTSPN,GMTST,GMTSI)) Q:GMTSI'>0 D Q:$D(GMTSQIT) - . . S X=$G(^TMP("RAE",$J,GMTSIDT,GMTSPN,GMTST,GMTSI)) D ^DIWP - I GMTST="D" D - . S GMTSI=0 F S GMTSI=$O(^TMP("RAE",$J,GMTSIDT,GMTSPN,GMTST,GMTSI)) Q:GMTSI'>0 D Q:$D(GMTSQIT) - . . S X=$G(^TMP("RAE",$J,GMTSIDT,GMTSPN,GMTST,GMTSI)) S:$L(X)>(78-(GMTSIND+4)) X=$$WRAP^GMTSORC(X,(78-(GMTSIND+4))) - . . D CKP^GMTSUP Q:$D(GMTSQIT) W ?(GMTSIND+2),$P(X,"|",1),! F GMTSII=2:1:$L(X,"|") D Q:$D(GMTSQIT) - . . . D CKP^GMTSUP Q:$D(GMTSQIT) W:$P(X,"|",GMTSII)]"" ?(GMTSIND+4),$P(X,"|",GMTSII),! - I $D(^UTILITY($J,"W")) D - . S GMTSI=0 F S GMTSI=$O(^UTILITY($J,"W",0,GMTSI)) Q:+GMTSI=0 D Q:$D(GMTSQIT) - . . D CKP^GMTSUP Q:$D(GMTSQIT) W ?(GMTSIND+2),$G(^UTILITY($J,"W",0,GMTSI,0)),! - K ^UTILITY($J,"W") - Q -BL ; Report Blank Lines - D CKP^GMTSUP Q:$D(GMTSQIT) W ! Q - ; -RP(X) ; Radiology Patient - N Y S X=+($G(X)) S Y=$$GET1^DIQ(70,X,.01,"I") S X=Y Q X +GMTSRAS ; SLC/JER,KER HIN/GJC - Radiology Profile ; 04/19/2002 + ;;2.7;Health Summary;**14,25,28,37,47,51**;Oct 20, 1995 + ; + ; External References + ; DBIA 3125 ^RADPT( file 70 + ; DBIA 2056 $$GET1^DIQ (file 70) + ; DBIA 10011 ^DIWP + ; +ENSRA ; Controls branching + Q:+($G(DFN))=0 Q:+($G(DFN))'=+($$RP(+($G(DFN)))) + N GMDATA D MAIN^GMTSRAE(2) Q:'$D(^TMP("RAE",$J)) + D LOOP K ^TMP("RAE",$J) Q +LOOP ; Loops through ^TMP("RAE",$J, + N GMW,GMTSORD,GMTSIDT,GMTSPN,GMLN,GMPSET,GMXSET S GMTSIDT=0 + F S GMTSIDT=$O(^TMP("RAE",$J,GMTSIDT)) Q:GMTSIDT'>0 D Q:$D(GMTSQIT) + . S GMPSET=$S($D(^TMP("RAE",$J,GMTSIDT,"PRINTSET")):1,1:0) + . S GMXSET=$S($D(^TMP("RAE",$J,GMTSIDT,"EXAMSET")):1,1:0) + . S GMTSPN=0 F S GMTSPN=$O(^TMP("RAE",$J,GMTSIDT,GMTSPN)) Q:GMTSPN'>0 D + . . S GMTSORD=+($P($G(^TMP("RAE",$J,GMTSIDT,GMTSPN,0)),"^",10)) + . . D WRT D:+$O(^TMP("RAE",$J,GMTSIDT,GMTSPN)) BL Q:$D(GMTSQIT) + . D:+$O(^TMP("RAE",$J,GMTSIDT)) BL Q:$D(GMTSQIT) + Q +WRT ; Writes component data + Q:$D(GMTSQIT) N X,GMI,GMTMP S GMDATA=1,GMTMP=$G(^TMP("RAE",$J,GMTSIDT,GMTSPN,0)) + D CKP^GMTSUP Q:$D(GMTSQIT) + D DAT,PRO D:'GMPSET SSET D:GMPSET PSET + Q + ; +SSET ; Output for Non-Printsets (single exam) (GMPSET=0) + ; + ; Procedure Modifiers, Procedure Status, + ; CPT Code, CPT Modifiers, Interpreting Staff, + ; Interpreting Resident, Report Status, + ; Technologist, Report Text + ; + D:$D(^TMP("RAE",$J,GMTSIDT,GMTSPN,"M")) PMD D CPT,CMD,INS,INR,CAS,EST,STT,RPT + Q +PSET ; Output for Printsets (GMPSET=1) + ; + ; Procedure Modifiers, Procedure Status, + ; CPT Code, CPT Modifier, Report Status, + ; Technologist + ; + D:$D(^TMP("RAE",$J,GMTSIDT,GMTSPN,"M")) PMD D CPT,CMD + D:'+$O(^TMP("RAE",$J,GMTSIDT,GMTSPN)) LSET + Q +LSET ; Last Set/Case in Printset + ; + ; Interpreting Staff, Interpreting Resident, Report Status, + ; Technologist, Report Text + ; + D BL,INS,INR,CAS,EST,STT N GMTSPN S GMTSPN=$O(^TMP("RAE",$J,GMTSIDT,0)) D:GMTSPN RPT + Q + ; Data Elements +DAT ; Date +1 + Q:'$L($G(GMTMP)) Q:+($G(GMTMP))=0 Q:'$D(GMXSET) Q:'$D(GMTSPN) Q:+($G(GMTSIDT))=0 + N X,GMTSDT S X=+GMTMP D REGDT4^GMTSU S GMTSDT=X + D CKP^GMTSUP Q:$D(GMTSQIT) W:+($G(GMXSET))=0 GMTSDT + W:(+($G(GMXSET))>0)&(GMTSPN=$O(^TMP("RAE",$J,GMTSIDT,0))) GMTSDT + Q +PRO ; Procedure 2 + Q:'$L($G(GMTMP)) N GMTSA,GMTSB S GMTSA=$P($G(GMTMP),"^",2) + S:$L(GMTSA)>65 GMTSA=$$WRAP^GMTSORC(GMTSA,65) + D CKP^GMTSUP Q:$D(GMTSQIT) W ?12,$P(GMTSA,"|"),! + F GMTSB=2:1:$L(GMTSA,"|") D Q:$D(GMTSQIT) + . D CKP^GMTSUP Q:$D(GMTSQIT) + . W:$P(GMTSA,"|",GMTSB)]"" ?23,$P(GMTSA,"|",GMTSB),! + Q +CAS ; Case Number 9 + Q:'$L($G(GMTMP)) N GMTSA S GMTSA=$P(GMTMP,"^",9) Q:GMTSA="" + Q:$D(GMTSQIT) D CKP^GMTSUP Q:$D(GMTSQIT) + W ?12,"Exam Case Number:",?33,GMTSA,! + Q +EST ; Exam Status 3 + Q:'$L($G(GMTMP)) N GMTSA S GMTSA=$P(GMTMP,"^",3) Q:GMTSA="" + Q:$D(GMTSQIT) D CKP^GMTSUP Q:$D(GMTSQIT) + W ?12,"Exam Status:",?33,GMTSA,! + Q +RST ; Report Status 4 + Q:'$L($G(GMTMP)) N GMTSA S GMTSA=$P(GMTMP,"^",4) Q:GMTSA="" + Q:$D(GMTSQIT) D CKP^GMTSUP Q:$D(GMTSQIT) + W ?12,"Rpt Status: ",GMTSA,! + Q +INR ; Interpreting Resident 5 + Q:'$L($G(GMTMP)) N GMTSA S GMTSA=$P(GMTMP,"^",5) Q:GMTSA="" + Q:$D(GMTSQIT) D CKP^GMTSUP Q:$D(GMTSQIT) + W ?12,"Interpreting Res.:",?33,GMTSA,! + Q +INS ; Interpreting Staff 6 + Q:'$L($G(GMTMP)) N GMTSA S GMTSA=$P(GMTMP,"^",6) Q:GMTSA="" + Q:$D(GMTSQIT) D CKP^GMTSUP Q:$D(GMTSQIT) + W ?12,"Interpreting Staff:",?33,GMTSA,! + Q +CPT ; CPT Code 7 + Q:'$L($G(GMTMP)) N GMTSA S GMTSA=$P($G(GMTMP),"^",7) + Q:$D(GMTSQIT) D CKP^GMTSUP Q:$D(GMTSQIT) + W ?12,"CPT Code:",?25,GMTSA,! + Q +TEC ; Technologist 8 + Q:'$L($G(GMTMP)) N GMTSA S GMTSA=$P($G(GMTMP),"^",8) Q:GMTSA="" + Q:$D(GMTSQIT) D CKP^GMTSUP Q:$D(GMTSQIT) + W ?12," Technologist: ",GMTSA,! + Q +STT ; Report Status/Technologist 4/8 + Q:'$L($G(GMTMP)) N GMTSA,GMTSB S GMTSA=$P(GMTMP,"^",4),GMTSB=$P(GMTMP,"^",8) + Q:($G(GMTSA)_$G(GMTSB))="" Q:$D(GMTSQIT) D CKP^GMTSUP Q:$D(GMTSQIT) + W ?12,"Rpt Status: ",$E($G(GMTSA),1,18) W ?45," Technologist: ",$G(GMTSB),! + Q +CMD ; CPT Modifiers + N GMTSCPTM + S GMTSCPTM=+($$CPT^GMTSU(+($G(GMTSEGN)))) S:$G(GMPXCMOD)="N" GMTSCPTM=0 + Q:'GMTSCPTM Q:'$L($G(GMTMP)) N GMTSC,GMTSCM,GMTSCT,GMTSI,GMTSCNT S (GMTSC,GMTSCNT)=0 + F S GMTSC=$O(^TMP("RAE",$J,GMTSIDT,GMTSPN,"CM",GMTSC)) Q:+GMTSC=0 D + . S GMTSCM=$P($G(^TMP("RAE",$J,GMTSIDT,GMTSPN,"CM",GMTSC)),"^",1) Q:'$L(GMTSCM) + . S GMTSCT=$P($G(^TMP("RAE",$J,GMTSIDT,GMTSPN,"CM",GMTSC)),"^",3) Q:'$L(GMTSCT) + . S GMTSCT=GMTSCM_" - "_GMTSCT + . S GMTSCNT=GMTSCNT+1 + . S:$L(GMTSCT)>47 GMTSCT=$$WRAP^GMTSORC(GMTSCT,47) + . D CKP^GMTSUP Q:$D(GMTSQIT) + . W:GMTSCNT=1 ?12,"CPT Modifier:" W ?28,$P(GMTSCT,"|"),! + . F GMTSI=2:1:$L(GMTSCT,"|") D Q:$D(GMTSQIT) + . . D CKP^GMTSUP Q:$D(GMTSQIT) W:$P(GMTSCT,"|",GMTSI)]"" ?33,$P(GMTSCT,"|",GMTSI),! + Q +PMD ; Procedure Modifiers + Q:'$L($G(GMTMP)) D CKP^GMTSUP Q:$D(GMTSQIT) W:+($O(^TMP("RAE",$J,GMTSIDT,GMTSPN,"M",0)))>0 ?12,"Procedure Modifier:" + S GMI=0 F S GMI=$O(^TMP("RAE",$J,GMTSIDT,GMTSPN,"M",GMI)) Q:+GMI'>0 D + . D CKP^GMTSUP Q:$D(GMTSQIT) + . W ?33,^TMP("RAE",$J,GMTSIDT,GMTSPN,"M",GMI),! + Q + ; +RPT ; Report Text + N GMTSL F GMTSL="H","A","R","I","D" D TXT(GMTSL) + Q +TXT(X) ; Report Text Lines + N GMTST S GMTST=$E($G(X),1) Q:(GMTST="")!("^H^A^R^I^D^"'[GMTST)!(GMTST="^") + Q:GMTST="A"&(+($$PROK^GMTSU("RAUTL9",27))=0) + Q:+($G(GMTSIDT))=0 Q:+($G(GMTSPN))=0 Q:'$D(^TMP("RAE",$J,GMTSIDT,GMTSPN,GMTST)) + K ^UTILITY($J,"W") N GMTSI,GMTSII,GMTSIND,DIWF,DIWL,DIWR S GMTSIND=12,DIWF="C"_(78-(GMTSIND+2)),DIWL=0,DIWR=0,GMTSI=0 + D:$O(^TMP("RAE",$J,GMTSIDT,GMTSPN,GMTST,0))>0 BL + D CKP^GMTSUP Q:$D(GMTSQIT) + W ?GMTSIND,$S(GMTST="H":"History: ",GMTST="A":"Additional History: ",GMTST="R":"Report: ",GMTST="I":"Impression: ",GMTST="D":"DX Codes: ",1:"Text:"),! + I GMTST'="D" D + . S GMTSI=0 F S GMTSI=$O(^TMP("RAE",$J,GMTSIDT,GMTSPN,GMTST,GMTSI)) Q:GMTSI'>0 D Q:$D(GMTSQIT) + . . S X=$G(^TMP("RAE",$J,GMTSIDT,GMTSPN,GMTST,GMTSI)) D ^DIWP + I GMTST="D" D + . S GMTSI=0 F S GMTSI=$O(^TMP("RAE",$J,GMTSIDT,GMTSPN,GMTST,GMTSI)) Q:GMTSI'>0 D Q:$D(GMTSQIT) + . . S X=$G(^TMP("RAE",$J,GMTSIDT,GMTSPN,GMTST,GMTSI)) S:$L(X)>(78-(GMTSIND+4)) X=$$WRAP^GMTSORC(X,(78-(GMTSIND+4))) + . . D CKP^GMTSUP Q:$D(GMTSQIT) W ?(GMTSIND+2),$P(X,"|",1),! F GMTSII=2:1:$L(X,"|") D Q:$D(GMTSQIT) + . . . D CKP^GMTSUP Q:$D(GMTSQIT) W:$P(X,"|",GMTSII)]"" ?(GMTSIND+4),$P(X,"|",GMTSII),! + I $D(^UTILITY($J,"W")) D + . S GMTSI=0 F S GMTSI=$O(^UTILITY($J,"W",0,GMTSI)) Q:+GMTSI=0 D Q:$D(GMTSQIT) + . . D CKP^GMTSUP Q:$D(GMTSQIT) W ?(GMTSIND+2),$G(^UTILITY($J,"W",0,GMTSI,0)),! + K ^UTILITY($J,"W") + Q +BL ; Report Blank Lines + D CKP^GMTSUP Q:$D(GMTSQIT) W ! Q + ; +RP(X) ; Radiology Patient + N Y S X=+($G(X)) S Y=$$GET1^DIQ(70,X,.01,"I") S X=Y Q X diff --git a/r/HEALTH_SUMMARY-GMTS/GMTSUP.m b/r/HEALTH_SUMMARY-GMTS/GMTSUP.m index ea475ddd..64032008 100644 --- a/r/HEALTH_SUMMARY-GMTS/GMTSUP.m +++ b/r/HEALTH_SUMMARY-GMTS/GMTSUP.m @@ -1,184 +1,183 @@ -GMTSUP ; SLC/KER - Utilities for Paging HS ; 01/06/2003 - ;;2.7;Health Summary;**2,7,21,27,28,30,35,47,56,58,85**;Oct 20, 1995;Build 24 - ; - ; External References - ; DBIA 10026 ^DIR - ; DBIA 82 EN^XQORM - ; -CKP ; Check page position, pause and prompt - Q:$D(GMTSQIT) S GMTSNPG=0 - K:$L($G(GMTSOBJ("LABEL"))) GMTSOBJ("REPORT HEADER") - I $G(GMTSWRIT)=1 D BREAK S GMTSWRIT=0 - I +($$HF^GMTSU) D BREAK:(GMTSEGN'=$G(GMTSLCMP)) Q - Q:+$G(GMTSLPG)'>0&($Y'>(IOSL-GMTSLO)) - I $E(IOST,1)="C" S:'$D(GMTSTOF) GMTSTOF=1 D CKP1 - I '$D(GMTSQIT) W @IOF D HEADER,BREAK S GMTSNPG=1,GMTSTOF=GMTSEGN - I $D(GMTSQIT),(GMTSQIT]""),($D(GMTSTYP)) W @IOF D HEADER S GMTSTOF=GMTSEGN - Q -CKP1 ; Help Display of Optional Components for Navigation - N DA,I,J,K,L,X,XQORM,Y,GMTSY,TYP,DIC - I $S('$D(GMTSTYP):1,$D(GMTOPT):1,1:0) N DIR S DIR(0)="E" D ^DIR K DIR S:$D(DUOUT)!(GMTSLPG) GMTSQIT="" Q - S TYP=GMTSTYP - S DIC=142,DIC(0)="MZF",X="GMTS HS ADHOC OPTION" S Y=$$TYPE^GMTSULT - S GMTSTYP=+Y K DIC,X,Y - S XQORM=GMTSTYP_";GMT(142,",XQORM(0)="1AF\+",XQORM("A")="Press to continue, ^ to exit, or select component: " - S XQORM("??")="D HELP^GMTSUP1" I GMTSLPG,'$D(GMTSOBJ) W:'$D(GMTSOBJE) "* END * " - S XQORM("S")="I $D(^GMT(142,DA(1),1,DA,0)),($P(^GMT(142.1,$P(^GMT(142,DA(1),1,DA,0),U,2),0),U,6)'=""T"")" - D EN^XQORM W ! D @$S(Y=1:"BRNCH",1:"EVAL") - I $D(GMTSY),(GMTSY=0) K GMTSY G CKP1 - S GMTSTYP=TYP - Q -BREAK ; Writes the Component Header - ; - ; If the variable GMTSOBJ exist, then the - ; Component Headers are suppressed with the - ; following exceptions: - ; - ; If GMTSOBJ("COMPONENT HEADER") exist, - ; then the Component Header will NOT be - ; suppressed - ; - ; If GMTSOBJ("BLANK LINE") exist, a blank - ; line will be written after the Component - ; Header - ; - N GMTSM,GMTSF S GMTSM=$$MUL,GMTSF=$$FST - I +GMTSM=0,$D(GMTSOBJ),'$D(GMTSOBJ("COMPONENT HEADER")),'$D(GMTSOBJ("BLANK LINE")) Q - N GMTS,GMTSUL,GMTSL S:'$D(GMTSLCMP) GMTSLCMP=0 - S GMTSUL="",GMTSNPG=1,GMTS=$$CHDR,GMTSL=+($L($G(GMTS))),$P(GMTSUL,"-",+GMTSL)="-" - I $Y'>(IOSL-GMTSLO)!(+($$HF^GMTSU)) D - . I $D(GMTSOBJ) D Q - . . S GMTSLCMP=GMTSEGN - . . I +($G(GMTSM))>0!($D(GMTSOBJ("COMPONENT HEADER"))) D - . . . W:+GMTSF=0 ! W !,GMTS W:$D(GMTSOBJ("UNDERLINE")) !,GMTSUL - . . . W ! W:$D(GMTSOBJ("BLANK LINE")) ! - . W !,GMTS,! - . W:$Y'>(IOSL-GMTSLO) ?34,$S(GMTSEGN=GMTSLCMP:"(continued)",1:""),! - . S GMTSLCMP=GMTSEGN - Q -OLDB ; - S:'$D(GMTSLCMP) GMTSLCMP=0 - S GMTS="",GMTSNPG=1 - S $P(GMTS,"-",79-$L(GMTSEGH_GMTSEGL)/2)="" - S GMTS=GMTS_" "_GMTSEGH_GMTSEGL_" "_GMTS - I $Y'>(IOSL-GMTSLO)!(+($$HF^GMTSU)) D - . W !,GMTS,! - . W:$Y'>(IOSL-GMTSLO) ?34,$S(GMTSEGN=GMTSLCMP:"(continued)",1:""),! - . S GMTSLCMP=GMTSEGN - Q -HEADER ; Print Running Header - ; - ; If the variable GMTSOBJ exist, then the - ; Report Headers are suppressed with the - ; following exceptions: - ; - ; If GMTSOBJ("DATE LINE") exist, then the - ; Location/Report Date line will NOT be - ; suppressed. - ; - ; If GMTSOBJ("CONFIDENTIAL") exist, then - ; the Confidential Header Name line will - ; NOT be suppressed. - ; - ; If GMTSOBJ("REPORT HEADER") exist, then - ; the Report Header containing the patient's - ; name, SSAN, ward and DOB will NOT be - ; suppressed. - ; - ; If the variable GMTSOBJ("LABEL") contains - ; text, and the variable GMTSOBJ("USE LABEL") - ; exist, then this text will be printed before - ; the object text. - ; - ; If GMTSOBJ("REPORT DECEASED") exist, then - ; the optional line that displays for Deceased - ; patients will NOT be suppressed. - ; - ; Header Lines: - N GMTSVDT,DATA S DATA="" I +$G(GMTSPXD1)&+$G(GMTSPXD2) D - . Q:$G(GMTSOBJ) S:'$D(GMTSOBJE) DATA="Printed for data " S:$D(GMTSOBJE) DATA="Include data " - . I GMTSPXD1=GMTSPXD2 S DATA=DATA_"on "_GMTSPXD1 Q - . S DATA=DATA_"from "_GMTSPXD2_" to "_GMTSPXD1 - I $D(GMTSCDT(0)),'$D(GMTSOBJ) S GMTSVDT=GMTSCDT(0) S:GMTSDTM'["Printed:" GMTSDTM="Printed: "_GMTSDTM - ; Location and Date of Report - I '$D(GMTSOBJ)!($D(GMTSOBJ("DATE LINE"))) D - . N GMTSLOC S GMTSLOC=$S('$D(GMTSOBJ("DATE LINE")):$P($G(GMTSSC),U,2),1:"") - . W !,$S($L(GMTSLOC):"Location: "_GMTSLOC_" ",1:"") - . W $S($D(GMTSVDT):GMTSVDT,1:"") - . W:'$D(GMTSOBJ("DATE LINE")) DATA,?(79-$L(GMTSDTM)),GMTSDTM - . W:$D(GMTSOBJ("DATE LINE")) DATA,?(74-$L(GMTSDTM)),GMTSDTM - ; Confidential Header Name - S:'$D(GMTSPG) GMTSPG=0 - S GMTSPG=GMTSPG+1,GMTSHDR=" CONFIDENTIAL "_GMTSTITL_" SUMMARY " - S GMTSHDR=GMTSHDR_$S($E(IOST,1)="C":"",1:" pg. "_GMTSPG) - S GMTS="" S:'$D(GMTSOBJ) $P(GMTS,"*",(77-$L(GMTSHDR))\2)="*" - S:$D(GMTSOBJ) $P(GMTS,"*",(72-$L(GMTSHDR))\2)="*" - S GMTSHDR=GMTS_" "_GMTSHDR_" "_GMTS - I '$D(GMTSOBJ)!($D(GMTSOBJ("CONFIDENTIAL"))) W !,GMTSHDR,"*" - ; Name, SSAN, Ward, DOB - I '$D(GMTSLFG) D - .I $G(GMTSTITL)'["AD HOC",($G(GMTSTITL)'["PDX"),($G(HSTAG)="") D EN^GMTSHCPR ;GMTS,85 restrict ssn/dob on HS Type hard copies - . I $G(GMTSPHDR("TWO")) D - . . I $D(GMTSOBJ),'$D(GMTSOBJ("REPORT HEADER")),$L($G(GMTSOBJ("LABEL"))) D LABEL - . . I $D(GMTSOBJ),'$D(GMTSOBJ("REPORT HEADER")) Q - . . W !,GMTSPHDR("NMSSN"),?GMTSPHDR("DOBS"),GMTSPHDR("DOB") - . . W !,?GMTSPHDR("WARDRBS"),GMTSPHDR("WARDRB") - . E D - . . I $D(GMTSOBJ),'$D(GMTSOBJ("REPORT HEADER")),$L($G(GMTSOBJ("LABEL"))) D LABEL - . . I $D(GMTSOBJ),'$D(GMTSOBJ("REPORT HEADER")) Q - . . W !,GMTSPHDR("NMSSN"),?GMTSPHDR("WARDRBS") - . . W GMTSPHDR("WARDRB"),?GMTSPHDR("DOBS"),GMTSPHDR("DOB") - ; Deceased - ; - I '$D(GMTSOBJ)!($D(GMTSOBJ("DECEASED"))) D - . W:+$G(VADM(6)) !,?26,"** DECEASED "_$P(VADM(6),U,2)_" **" - W:'$D(GMTSOBJ) ! - Q -BRNCH ; Checks abbreviation to branch to a different component - N GMTINX,LIM,CREC,SBS - I Y,("+-"[X) S:X="-" GMTSEGN=GMTSTOF-1 S (GMTSY,GMTSQIT)=1,GMTSLPG=0 Q - I X="^^" S DIROUT=1,GMTSQIT="" Q - I Y,(X?1"^^".E) Q - S GMTINX=$S($D(^GMT(142,GMTSTYP,1,+Y(1),0)):$P(^(0),U,2),1:"") - I 'GMTINX S GMTSY=0 Q - I '$D(GMTSEGI(GMTINX)) N GMI,GMJ,GMTSDFLT S GMI=1,GMJ=GMTSEGC,GMTSDFLT=1 D LOAD^GMTSADH S GMTSEGC=GMTSEGC+1 - I '$D(GMTSEGI(GMTINX)) S GMTINX="",GMTSY=0 Q - S LIM=$P(Y(1),U,4) I LIM'["=" G NOLIM - S CREC=^GMT(142.1,GMTINX,0),SBS=GMTSEGI(GMTINX) D CMPLIM^GMTSADH2 - I $D(DIROUT) S GMTSQIT="" Q -NOLIM ; No limits - S GMTSEGN=GMTSEGI(GMTINX)-1,(GMTSY,GMTSQIT)=1,GMTSLPG=0 - Q - ; -EVAL ; Evaluate input to determine quit or continue - Q:'$D(X) - S:$D(GMTSEXIT) GMTSEXIT=$G(X) - S:$D(DTOUT) DIROUT=1 I $S(X="^^":1,GMTSLPG:1,$D(DIROUT):1,X="^":1,1:0) S GMTSQIT="" - I +$G(GMPSAP),(X="^") S GMDUOUT=1 - Q -MUL(X) ; Multiple Components in Type - N GMTSF,GMTSL S GMTSF=$O(GMTSEG(0)),GMTSL=$O(GMTSEG(" "),-1) - Q:+GMTSF=+GMTSL 0 Q 1 -FST(X) ; First Component in Type - N GMTSF,GMTSL S GMTSF=$O(GMTSEG(0)),GMTSL=+($G(GMTSEGN)) - Q:+GMTSF=+GMTSL 1 Q 0 -CHDR(X) ; Component Header - N GMTSN,GMTSH,GMTSL,GMTS S GMTSN=$$CNAM,GMTSH=$G(GMTSEGH) - S GMTSL=$G(GMTSEGL),GMTS="",$P(GMTS,"-",79-$L(GMTSH_GMTSL)/2)="" - S X=GMTS_" "_GMTSH_GMTSL_" "_GMTS Q:'$D(GMTSOBJ) X - S:$L(GMTSH)&($D(GMTSOBJ("COMPONENT HEADER"))) GMTSN=GMTSH - S:$L(GMTSL)&($L(GMTSN))&($D(GMTSOBJ("LIMITS"))) GMTSN=GMTSN_" "_GMTSL - S X=GMTSN Q X -CNAM(X) ; Component Name - N GMTSH S GMTSH=+($P($G(GMTSEG(+($G(GMTSEGN)))),"^",2)) - S X=$P($G(^GMT(142.1,+GMTSH,0)),"^",1) Q X -LABEL ; Label - Q:'$D(GMTSOBJ("USE LABEL")) N LABEL S LABEL=$G(GMTSOBJ("LABEL")) - W !,LABEL W:$L(LABEL) ! W:$D(GMTSOBJ("LABEL BLANK LINE")) ! - Q -LABDAT ; Label/Date - Q:'$D(GMTSOBJ("USE LABEL")) N LABEL S LABEL=$G(GMTSOBJ("LABEL")) - I '$D(GMTSOBJ("DATE LINE")),$D(GMTSOBJ("LABEL")),$L(LABEL),$L($G(GMTSDTM)) S LABEL=LABEL_$J("",((79-$L(GMTSDTM))-$L(LABEL)))_GMTSDTM - I '$D(GMTSOBJ("DATE LINE")),$D(GMTSOBJ("LABEL")),'$L(LABEL),$L($G(GMTSDTM)) S LABEL="Information as of "_$G(GMTSDTM) - W !,LABEL W:$L(LABEL) ! W:$D(GMTSOBJ("LABEL BLANK LINE")) ! - Q +GMTSUP ; SLC/KER - Utilities for Paging HS ; 01/06/2003 + ;;2.7;Health Summary;**2,7,21,27,28,30,35,47,56,58**;Oct 20, 1995 + ; + ; External References + ; DBIA 10026 ^DIR + ; DBIA 82 EN^XQORM + ; +CKP ; Check page position, pause and prompt + Q:$D(GMTSQIT) S GMTSNPG=0 + K:$L($G(GMTSOBJ("LABEL"))) GMTSOBJ("REPORT HEADER") + I $G(GMTSWRIT)=1 D BREAK S GMTSWRIT=0 + I +($$HF^GMTSU) D BREAK:(GMTSEGN'=$G(GMTSLCMP)) Q + Q:+$G(GMTSLPG)'>0&($Y'>(IOSL-GMTSLO)) + I $E(IOST,1)="C" S:'$D(GMTSTOF) GMTSTOF=1 D CKP1 + I '$D(GMTSQIT) W @IOF D HEADER,BREAK S GMTSNPG=1,GMTSTOF=GMTSEGN + I $D(GMTSQIT),(GMTSQIT]""),($D(GMTSTYP)) W @IOF D HEADER S GMTSTOF=GMTSEGN + Q +CKP1 ; Help Display of Optional Components for Navigation + N DA,I,J,K,L,X,XQORM,Y,GMTSY,TYP,DIC + I $S('$D(GMTSTYP):1,$D(GMTOPT):1,1:0) N DIR S DIR(0)="E" D ^DIR K DIR S:$D(DUOUT)!(GMTSLPG) GMTSQIT="" Q + S TYP=GMTSTYP + S DIC=142,DIC(0)="MZF",X="GMTS HS ADHOC OPTION" S Y=$$TYPE^GMTSULT + S GMTSTYP=+Y K DIC,X,Y + S XQORM=GMTSTYP_";GMT(142,",XQORM(0)="1AF\+",XQORM("A")="Press to continue, ^ to exit, or select component: " + S XQORM("??")="D HELP^GMTSUP1" I GMTSLPG,'$D(GMTSOBJ) W:'$D(GMTSOBJE) "* END * " + S XQORM("S")="I $D(^GMT(142,DA(1),1,DA,0)),($P(^GMT(142.1,$P(^GMT(142,DA(1),1,DA,0),U,2),0),U,6)'=""T"")" + D EN^XQORM W ! D @$S(Y=1:"BRNCH",1:"EVAL") + I $D(GMTSY),(GMTSY=0) K GMTSY G CKP1 + S GMTSTYP=TYP + Q +BREAK ; Writes the Component Header + ; + ; If the variable GMTSOBJ exist, then the + ; Component Headers are suppressed with the + ; following exceptions: + ; + ; If GMTSOBJ("COMPONENT HEADER") exist, + ; then the Component Header will NOT be + ; suppressed + ; + ; If GMTSOBJ("BLANK LINE") exist, a blank + ; line will be written after the Component + ; Header + ; + N GMTSM,GMTSF S GMTSM=$$MUL,GMTSF=$$FST + I +GMTSM=0,$D(GMTSOBJ),'$D(GMTSOBJ("COMPONENT HEADER")),'$D(GMTSOBJ("BLANK LINE")) Q + N GMTS,GMTSUL,GMTSL S:'$D(GMTSLCMP) GMTSLCMP=0 + S GMTSUL="",GMTSNPG=1,GMTS=$$CHDR,GMTSL=+($L($G(GMTS))),$P(GMTSUL,"-",+GMTSL)="-" + I $Y'>(IOSL-GMTSLO)!(+($$HF^GMTSU)) D + . I $D(GMTSOBJ) D Q + . . S GMTSLCMP=GMTSEGN + . . I +($G(GMTSM))>0!($D(GMTSOBJ("COMPONENT HEADER"))) D + . . . W:+GMTSF=0 ! W !,GMTS W:$D(GMTSOBJ("UNDERLINE")) !,GMTSUL + . . . W ! W:$D(GMTSOBJ("BLANK LINE")) ! + . W !,GMTS,! + . W:$Y'>(IOSL-GMTSLO) ?34,$S(GMTSEGN=GMTSLCMP:"(continued)",1:""),! + . S GMTSLCMP=GMTSEGN + Q +OLDB ; + S:'$D(GMTSLCMP) GMTSLCMP=0 + S GMTS="",GMTSNPG=1 + S $P(GMTS,"-",79-$L(GMTSEGH_GMTSEGL)/2)="" + S GMTS=GMTS_" "_GMTSEGH_GMTSEGL_" "_GMTS + I $Y'>(IOSL-GMTSLO)!(+($$HF^GMTSU)) D + . W !,GMTS,! + . W:$Y'>(IOSL-GMTSLO) ?34,$S(GMTSEGN=GMTSLCMP:"(continued)",1:""),! + . S GMTSLCMP=GMTSEGN + Q +HEADER ; Print Running Header + ; + ; If the variable GMTSOBJ exist, then the + ; Report Headers are suppressed with the + ; following exceptions: + ; + ; If GMTSOBJ("DATE LINE") exist, then the + ; Location/Report Date line will NOT be + ; suppressed. + ; + ; If GMTSOBJ("CONFIDENTIAL") exist, then + ; the Confidential Header Name line will + ; NOT be suppressed. + ; + ; If GMTSOBJ("REPORT HEADER") exist, then + ; the Report Header containing the patient's + ; name, SSAN, ward and DOB will NOT be + ; suppressed. + ; + ; If the variable GMTSOBJ("LABEL") contains + ; text, and the variable GMTSOBJ("USE LABEL") + ; exist, then this text will be printed before + ; the object text. + ; + ; If GMTSOBJ("REPORT DECEASED") exist, then + ; the optional line that displays for Deceased + ; patients will NOT be suppressed. + ; + ; Header Lines: + N GMTSVDT,DATA S DATA="" I +$G(GMTSPXD1)&+$G(GMTSPXD2) D + . Q:$G(GMTSOBJ) S:'$D(GMTSOBJE) DATA="Printed for data " S:$D(GMTSOBJE) DATA="Include data " + . I GMTSPXD1=GMTSPXD2 S DATA=DATA_"on "_GMTSPXD1 Q + . S DATA=DATA_"from "_GMTSPXD2_" to "_GMTSPXD1 + I $D(GMTSCDT(0)),'$D(GMTSOBJ) S GMTSVDT=GMTSCDT(0) S:GMTSDTM'["Printed:" GMTSDTM="Printed: "_GMTSDTM + ; Location and Date of Report + I '$D(GMTSOBJ)!($D(GMTSOBJ("DATE LINE"))) D + . N GMTSLOC S GMTSLOC=$S('$D(GMTSOBJ("DATE LINE")):$P($G(GMTSSC),U,2),1:"") + . W !,$S($L(GMTSLOC):"Location: "_GMTSLOC_" ",1:"") + . W $S($D(GMTSVDT):GMTSVDT,1:"") + . W:'$D(GMTSOBJ("DATE LINE")) DATA,?(79-$L(GMTSDTM)),GMTSDTM + . W:$D(GMTSOBJ("DATE LINE")) DATA,?(74-$L(GMTSDTM)),GMTSDTM + ; Confidential Header Name + S:'$D(GMTSPG) GMTSPG=0 + S GMTSPG=GMTSPG+1,GMTSHDR=" CONFIDENTIAL "_GMTSTITL_" SUMMARY " + S GMTSHDR=GMTSHDR_$S($E(IOST,1)="C":"",1:" pg. "_GMTSPG) + S GMTS="" S:'$D(GMTSOBJ) $P(GMTS,"*",(77-$L(GMTSHDR))\2)="*" + S:$D(GMTSOBJ) $P(GMTS,"*",(72-$L(GMTSHDR))\2)="*" + S GMTSHDR=GMTS_" "_GMTSHDR_" "_GMTS + I '$D(GMTSOBJ)!($D(GMTSOBJ("CONFIDENTIAL"))) W !,GMTSHDR,"*" + ; Name, SSAN, Ward, DOB + I '$D(GMTSLFG) D + . I $G(GMTSPHDR("TWO")) D + . . I $D(GMTSOBJ),'$D(GMTSOBJ("REPORT HEADER")),$L($G(GMTSOBJ("LABEL"))) D LABEL + . . I $D(GMTSOBJ),'$D(GMTSOBJ("REPORT HEADER")) Q + . . W !,GMTSPHDR("NMSSN"),?GMTSPHDR("DOBS"),GMTSPHDR("DOB") + . . W !,?GMTSPHDR("WARDRBS"),GMTSPHDR("WARDRB") + . E D + . . I $D(GMTSOBJ),'$D(GMTSOBJ("REPORT HEADER")),$L($G(GMTSOBJ("LABEL"))) D LABEL + . . I $D(GMTSOBJ),'$D(GMTSOBJ("REPORT HEADER")) Q + . . W !,GMTSPHDR("NMSSN"),?GMTSPHDR("WARDRBS") + . . W GMTSPHDR("WARDRB"),?GMTSPHDR("DOBS"),GMTSPHDR("DOB") + ; Deceased + ; + I '$D(GMTSOBJ)!($D(GMTSOBJ("DECEASED"))) D + . W:+$G(VADM(6)) !,?26,"** DECEASED "_$P(VADM(6),U,2)_" **" + W:'$D(GMTSOBJ) ! + Q +BRNCH ; Checks abbreviation to branch to a different component + N GMTINX,LIM,CREC,SBS + I Y,("+-"[X) S:X="-" GMTSEGN=GMTSTOF-1 S (GMTSY,GMTSQIT)=1,GMTSLPG=0 Q + I X="^^" S DIROUT=1,GMTSQIT="" Q + I Y,(X?1"^^".E) Q + S GMTINX=$S($D(^GMT(142,GMTSTYP,1,+Y(1),0)):$P(^(0),U,2),1:"") + I 'GMTINX S GMTSY=0 Q + I '$D(GMTSEGI(GMTINX)) N GMI,GMJ,GMTSDFLT S GMI=1,GMJ=GMTSEGC,GMTSDFLT=1 D LOAD^GMTSADH S GMTSEGC=GMTSEGC+1 + I '$D(GMTSEGI(GMTINX)) S GMTINX="",GMTSY=0 Q + S LIM=$P(Y(1),U,4) I LIM'["=" G NOLIM + S CREC=^GMT(142.1,GMTINX,0),SBS=GMTSEGI(GMTINX) D CMPLIM^GMTSADH2 + I $D(DIROUT) S GMTSQIT="" Q +NOLIM ; No limits + S GMTSEGN=GMTSEGI(GMTINX)-1,(GMTSY,GMTSQIT)=1,GMTSLPG=0 + Q + ; +EVAL ; Evaluate input to determine quit or continue + Q:'$D(X) + S:$D(GMTSEXIT) GMTSEXIT=$G(X) + S:$D(DTOUT) DIROUT=1 I $S(X="^^":1,GMTSLPG:1,$D(DIROUT):1,X="^":1,1:0) S GMTSQIT="" + I +$G(GMPSAP),(X="^") S GMDUOUT=1 + Q +MUL(X) ; Multiple Components in Type + N GMTSF,GMTSL S GMTSF=$O(GMTSEG(0)),GMTSL=$O(GMTSEG(" "),-1) + Q:+GMTSF=+GMTSL 0 Q 1 +FST(X) ; First Component in Type + N GMTSF,GMTSL S GMTSF=$O(GMTSEG(0)),GMTSL=+($G(GMTSEGN)) + Q:+GMTSF=+GMTSL 1 Q 0 +CHDR(X) ; Component Header + N GMTSN,GMTSH,GMTSL,GMTS S GMTSN=$$CNAM,GMTSH=$G(GMTSEGH) + S GMTSL=$G(GMTSEGL),GMTS="",$P(GMTS,"-",79-$L(GMTSH_GMTSL)/2)="" + S X=GMTS_" "_GMTSH_GMTSL_" "_GMTS Q:'$D(GMTSOBJ) X + S:$L(GMTSH)&($D(GMTSOBJ("COMPONENT HEADER"))) GMTSN=GMTSH + S:$L(GMTSL)&($L(GMTSN))&($D(GMTSOBJ("LIMITS"))) GMTSN=GMTSN_" "_GMTSL + S X=GMTSN Q X +CNAM(X) ; Component Name + N GMTSH S GMTSH=+($P($G(GMTSEG(+($G(GMTSEGN)))),"^",2)) + S X=$P($G(^GMT(142.1,+GMTSH,0)),"^",1) Q X +LABEL ; Label + Q:'$D(GMTSOBJ("USE LABEL")) N LABEL S LABEL=$G(GMTSOBJ("LABEL")) + W !,LABEL W:$L(LABEL) ! W:$D(GMTSOBJ("LABEL BLANK LINE")) ! + Q +LABDAT ; Label/Date + Q:'$D(GMTSOBJ("USE LABEL")) N LABEL S LABEL=$G(GMTSOBJ("LABEL")) + I '$D(GMTSOBJ("DATE LINE")),$D(GMTSOBJ("LABEL")),$L(LABEL),$L($G(GMTSDTM)) S LABEL=LABEL_$J("",((79-$L(GMTSDTM))-$L(LABEL)))_GMTSDTM + I '$D(GMTSOBJ("DATE LINE")),$D(GMTSOBJ("LABEL")),'$L(LABEL),$L($G(GMTSDTM)) S LABEL="Information as of "_$G(GMTSDTM) + W !,LABEL W:$L(LABEL) ! W:$D(GMTSOBJ("LABEL BLANK LINE")) ! + Q diff --git a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE.m b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE.m index 2c4a8d72..4f1736f1 100644 --- a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE.m +++ b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE.m @@ -1,7 +1,7 @@ -DVBHCE ; GENERATED FROM 'DVBHINQ UPDATE' INPUT TEMPLATE(#960), FILE 2;12/13/08 +DVBHCE ; GENERATED FROM 'DVBHINQ UPDATE' INPUT TEMPLATE(#960), FILE 2;12/27/07 D DE G BEGIN DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))="" - I $D(^(.32)) S %Z=^(.32) S %=$P(%Z,U,4) S:%]"" DE(23)=% S %=$P(%Z,U,5) S:%]"" DE(21)=% S %=$P(%Z,U,6) S:%]"" DE(19)=% S %=$P(%Z,U,7) S:%]"" DE(20)=% S %=$P(%Z,U,8) S:%]"" DE(24)=% S %=$P(%Z,U,11) S:%]"" DE(32)=% S %=$P(%Z,U,19) S:%]"" DE(30)=% + I $D(^(.32)) S %Z=^(.32) S %=$P(%Z,U,4) S:%]"" DE(23)=% S %=$P(%Z,U,5) S:%]"" DE(21)=% S %=$P(%Z,U,6) S:%]"" DE(19)=% S %=$P(%Z,U,7) S:%]"" DE(20)=% S %=$P(%Z,U,8) S:%]"" DE(24)=% K %Z Q ; W W !?DL+DL-2,DLB_": " @@ -190,11 +190,9 @@ X23 S DFN=DA I $D(X) D SV^DGLOCK Q S DE(DW)="C24^DVBHCE" G RE C24 G C24S:$D(DE(24))[0 K DB - S X=DE(24),DIC=DIE - D EVENT^IVMPLOG(DA) + D ^DVBHCE1 C24S S X="" G:DG(DQ)=X C24F1 K DB - S X=DG(DQ),DIC=DIE - D EVENT^IVMPLOG(DA) + D ^DVBHCE2 C24F1 Q X24 S DFN=DA D SV^DGLOCK I $D(X) S:X?1"SS".E L=$S($D(^DPT(DA,0)):$P(^(0),U,9),1:X) W:X?1"SS".E " ",L S:X?1"SS".E X=L K:$L(X)>15!($L(X)<1)!'(X?.N) X I $D(X),X'?.ANP K X @@ -213,37 +211,4 @@ X28 I $P(^DPT(D0,.32),U,6)="" W !!,*7,?17,DVBON,"No last episode can't edit NTLa 29 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=29 D X29 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 X29 S DVBSCR=1 D ^DVBHS4 W !,?34,DVBON,"[NTLAST]",DVBOFF X DVBLIT1 Q -30 D:$D(DG)>9 F^DIE17,DE S DQ=30,DW=".32;19",DV="RSX",DU="",DLB="Service NTL Episode",DIFLD=.3285 - S DE(DW)="C30^DVBHCE" - S DU="Y:YES;N:NO;" - G RE -C30 G C30S:$D(DE(30))[0 K DB - S X=DE(30),DIC=DIE - ; - S X=DE(30),DIC=DIE - ; - S X=DE(30),DIC=DIE - X ^DD(2,.3285,1,3,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.32)):^(.32),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X="" S DIH=$G(^DPT(DIV(0),.32)),DIV=X S $P(^(.32),U,10)=DIV,DIH=2,DIG=.3291 D ^DICR -C30S S X="" G:DG(DQ)=X C30F1 K DB - D ^DVBHCE1 -C30F1 Q -X30 S DFN=DA D SV^DGLOCK - Q - ; -31 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=31 D X31 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X31 I $P(^DPT(D0,.32),U,19)'="Y" S Y="@31" - Q -32 D:$D(DG)>9 F^DIE17,DE S DQ=32,DW=".32;11",DV="RDX",DU="",DLB="NTL-EOD",DIFLD=.3292 - S DE(DW)="C32^DVBHCE",DE(DW,"INDEX")=1 - G RE -C32 G C32S:$D(DE(32))[0 K DB - D ^DVBHCE2 -C32S S X="" G:DG(DQ)=X C32F1 K DB - D ^DVBHCE3 -C32F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE))) - F DIXR=649 S DIEZRXR(2,DIXR)="" - Q -X32 S %DT="E",%DT(0)=-DT D ^%DT K %DT S X=Y K:Y<1 X I $D(X) S DFN=DA D SER1^DGLOCK I $D(X) K:'$$VALMSE^DGRPMS(DFN,X,0,"MSNTL") X I $D(X) S DGFRDT=X I $D(^DG(43,1)) S SD1=2 D POS^DGINP - Q - ; -33 D:$D(DG)>9 F^DIE17 G ^DVBHCE4 +30 D:$D(DG)>9 F^DIE17 G ^DVBHCE3 diff --git a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE1.m b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE1.m index 44f73fd2..88fb31cc 100644 --- a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE1.m +++ b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE1.m @@ -1,7 +1,3 @@ -DVBHCE1 ; ;12/13/08 - S X=DG(DQ),DIC=DIE - X "I X'=""Y"" S DGXRF=.3285 D ^DGDDC Q" - S X=DG(DQ),DIC=DIE - X ^DD(2,.3285,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.32)):^(.32),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X=DIV S X="N" X ^DD(2,.3285,1,2,1.4) - S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$C(59)_$P($G(^DD(2,.3285,0)),U,3) S X=$P($P(Y(1),$C(59)_Y(0)_":",2),$C(59))'="YES" I X S X=DIV S Y(1)=$S($D(^DPT(D0,.32)):^(.32),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X="" X ^DD(2,.3285,1,3,1.4) +DVBHCE1 ; ;12/27/07 + S X=DE(24),DIC=DIE + D EVENT^IVMPLOG(DA) diff --git a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE10.m b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE10.m index db82c674..006c21ee 100644 --- a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE10.m +++ b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE10.m @@ -1,14 +1,12 @@ -DVBHCE10 ; ;12/13/08 +DVBHCE10 ; ;12/27/07 S X=DG(DQ),DIC=DIE - S DFN=DA D EN^DGMTCOR K DGMTCOR + X ^DD(2,.301,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.301,1,1,1.4) S X=DG(DQ),DIC=DIE - S DFN=DA D EN^DGRP7CC - S X=DG(DQ),DIC=DIE - X ^DD(2,1901,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV S X="N" X ^DD(2,1901,1,3,1.4) + X ^DD(2,.301,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X="" X ^DD(2,.301,1,2,1.4) S X=DG(DQ),DIC=DIE D AUTOUPD^DGENA2(DA) S X=DG(DQ),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF="1901;" D AVAFC^VAFCDD01(DA) + I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".301;" D AVAFC^VAFCDD01(DA) S X=DG(DQ),DIC=DIE D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) - I $D(DE(21))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET + I $D(DE(13))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET diff --git a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE11.m b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE11.m index acd5cf70..65bac77b 100644 --- a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE11.m +++ b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE11.m @@ -1,12 +1,12 @@ -DVBHCE11 ; ;12/13/08 - S X=DG(DQ),DIC=DIE - X ^DD(2,.301,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.301,1,1,1.4) - S X=DG(DQ),DIC=DIE - X ^DD(2,.301,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X="" X ^DD(2,.301,1,2,1.4) - S X=DG(DQ),DIC=DIE +DVBHCE11 ; ;12/27/07 + S X=DE(16),DIC=DIE + ; + S X=DE(16),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,2.2) I DIV(1)>0 S DIK(0)=DA,DIK="^DPT(DIV(0),""E"",",DA(1)=DIV(0),DA=DIV(1) D ^DIK S DA=DIK(0) K DIK + S X=DE(16),DIC=DIE + X "I $S('$D(^DIC(8,+X,0)):0,$P(^(0),""^"",1)[""DOM"":0,'$D(^DPT(DA,.36)):1,'$D(^DIC(8,+^(.36),0)):1,$P(^(0),""^"",1)'[""DOM"":1,1:0) S DGXRF=.361 D ^DGDDC Q" + S X=DE(16),DIC=DIE + K ^DPT("AEL",DA,+X) + S X=DE(16),DIC=DIE D AUTOUPD^DGENA2(DA) - S X=DG(DQ),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".301;" D AVAFC^VAFCDD01(DA) - S X=DG(DQ),DIC=DIE - D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) - I $D(DE(22))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET + S X=DE(16),DIIX=2_U_DIFLD D AUDIT^DIET diff --git a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE12.m b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE12.m index a2cb0b29..ba830e83 100644 --- a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE12.m +++ b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE12.m @@ -1,12 +1,12 @@ -DVBHCE12 ; ;12/13/08 - S X=DE(25),DIC=DIE +DVBHCE12 ; ;12/27/07 + S X=DG(DQ),DIC=DIE + X "S DFN=DA D EN^DGMTR K DGREQF" + S X=DG(DQ),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,89.4) S Y(102)=$S($D(^DPT(D0,"E",D1,0)):^(0),1:"") S X=$S('$D(^DIC(8,+$P(Y(102),U,1),0)):"",1:$P(^(0),U,1)) S D0=I(0,0) S D1=I(1,0) S DIU=X K Y S X=DIV S X=DIV,X=X X ^DD(2,.361,1,2,1.4) + S X=DG(DQ),DIC=DIE ; - S X=DE(25),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,2.2) I DIV(1)>0 S DIK(0)=DA,DIK="^DPT(DIV(0),""E"",",DA(1)=DIV(0),DA=DIV(1) D ^DIK S DA=DIK(0) K DIK - S X=DE(25),DIC=DIE - X "I $S('$D(^DIC(8,+X,0)):0,$P(^(0),""^"",1)[""DOM"":0,'$D(^DPT(DA,.36)):1,'$D(^DIC(8,+^(.36),0)):1,$P(^(0),""^"",1)'[""DOM"":1,1:0) S DGXRF=.361 D ^DGDDC Q" - S X=DE(25),DIC=DIE - K ^DPT("AEL",DA,+X) - S X=DE(25),DIC=DIE + S X=DG(DQ),DIC=DIE + S ^DPT("AEL",DA,+X)="" + S X=DG(DQ),DIC=DIE D AUTOUPD^DGENA2(DA) - S X=DE(25),DIIX=2_U_DIFLD D AUDIT^DIET + I $D(DE(16))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET diff --git a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE13.m b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE13.m index 39f95058..f17b1089 100644 --- a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE13.m +++ b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE13.m @@ -1,12 +1,178 @@ -DVBHCE13 ; ;12/13/08 +DVBHCE13 ; ;12/27/07 + D DE G BEGIN +DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))="" + I $D(^(.3)) S %Z=^(.3) S %=$P(%Z,U,11) S:%]"" DE(4)=% + I $D(^(.362)) S %Z=^(.362) S %=$P(%Z,U,12) S:%]"" DE(1)=% S %=$P(%Z,U,13) S:%]"" DE(2)=% S %=$P(%Z,U,14) S:%]"" DE(3)=% S %=$P(%Z,U,20) S:%]"" DE(5)=% + K %Z Q + ; +W W !?DL+DL-2,DLB_": " + Q +O D W W Y W:$X>45 !?9 + I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 + W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q +TR R X:DTIME E S (DTOUT,X)=U W $C(7) + Q +A K DQ(DQ) S DQ=DQ+1 +B G @DQ +RE G PR:$D(DE(DQ)) D W,TR +N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A +RD G QS:X?."?" I X["^" D D G ^DIE17 + I X="@" D D G Z^DIE2 + I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X +T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V + K DDER G X +P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 + G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z + I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X +V D @("X"_DQ) K YS +Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A +X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 + S X="?BAD" +QS S DZ=X D D,QQ^DIEQ G B +D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q +Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N +PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP +R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R + I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R + X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% +RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 +I I DV'["I",DV'["#" G RD + D E^DIE0 G RD:$D(X),PR + Q +SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 + I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 + D ^DIR I 'DDER S %=Y(0),X=Y + Q +SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) + I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" + E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") + Q +NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS +KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") +BEGIN S DNM="DVBHCE13",DQ=1 +1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".362;12",DV="SX",DU="",DLB="RECEIVING A&A BENEFITS?",DIFLD=.36205 + S DE(DW)="C1^DVBHCE13" + S DU="Y:YES;N:NO;U:UNKNOWN;" + G RE +C1 G C1S:$D(DE(1))[0 K DB + S X=DE(1),DIC=DIE + X ^DD(2,.36205,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,1,2.4) + S X=DE(1),DIC=DIE + S DFN=DA D EN^DGMTCOR K DGMTCOR + S X=DE(1),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,3,2.4) + S X=DE(1),DIC=DIE + D AUTOUPD^DGENA2(DA) +C1S S X="" G:DG(DQ)=X C1F1 K DB + S X=DG(DQ),DIC=DIE + X ^DD(2,.36205,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,1,1.4) + S X=DG(DQ),DIC=DIE + S DFN=DA D EN^DGMTCOR K DGMTCOR + S X=DG(DQ),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,3,1.4) + S X=DG(DQ),DIC=DIE + D AUTOUPD^DGENA2(DA) +C1F1 Q +X1 S DFN=DA D MV^DGLOCK I $D(X) S DFN=DA D EV^DGLOCK + Q + ; +2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW=".362;13",DV="SX",DU="",DLB="RECEIVING HOUSEBOUND BENEFITS?",DIFLD=.36215 + S DE(DW)="C2^DVBHCE13" + S DU="Y:YES;N:NO;U:UNKNOWN;" + G RE +C2 G C2S:$D(DE(2))[0 K DB + S X=DE(2),DIC=DIE + X ^DD(2,.36215,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,1,2.4) + S X=DE(2),DIC=DIE + S DFN=DA D EN^DGMTCOR K DGMTCOR + S X=DE(2),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,3,2.4) + S X=DE(2),DIC=DIE + D AUTOUPD^DGENA2(DA) +C2S S X="" G:DG(DQ)=X C2F1 K DB + S X=DG(DQ),DIC=DIE + X ^DD(2,.36215,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,1,1.4) + S X=DG(DQ),DIC=DIE + S DFN=DA D EN^DGMTCOR K DGMTCOR + S X=DG(DQ),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,3,1.4) + S X=DG(DQ),DIC=DIE + D AUTOUPD^DGENA2(DA) +C2F1 Q +X2 S DFN=DA D MV^DGLOCK I $D(X) S DFN=DA D EV^DGLOCK + Q + ; +3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW=".362;14",DV="SX",DU="",DLB="RECEIVING A VA PENSION?",DIFLD=.36235 + S DE(DW)="C3^DVBHCE13" + S DU="Y:YES;N:NO;U:UNKNOWN;" + G RE +C3 G C3S:$D(DE(3))[0 K DB + S X=DE(3),DIC=DIE + X ^DD(2,.36235,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,1,2.4) + S X=DE(3),DIC=DIE + S DFN=DA D EN^DGMTCOR K DGMTCOR + S X=DE(3),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,3,2.4) + S X=DE(3),DIC=DIE + D AUTOUPD^DGENA2(DA) +C3S S X="" G:DG(DQ)=X C3F1 K DB + S X=DG(DQ),DIC=DIE + X ^DD(2,.36235,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,1,1.4) + S X=DG(DQ),DIC=DIE + S DFN=DA D EN^DGMTCOR K DGMTCOR + S X=DG(DQ),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,3,1.4) + S X=DG(DQ),DIC=DIE + D AUTOUPD^DGENA2(DA) +C3F1 Q +X3 S DFN=DA D MV^DGLOCK + Q + ; +4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW=".3;11",DV="SX",DU="",DLB="RECEIVING VA DISABILITY?",DIFLD=.3025 + S DE(DW)="C4^DVBHCE13" + S DU="Y:YES;N:NO;U:UNKNOWN;" + G RE +C4 G C4S:$D(DE(4))[0 K DB + S X=DE(4),DIC=DIE + X ^DD(2,.3025,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" X ^DD(2,.3025,1,1,2.4) + S X=DE(4),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.3025,1,2,2.4) + S X=DE(4),DIC=DIE + D EVENT^IVMPLOG(DA) +C4S S X="" G:DG(DQ)=X C4F1 K DB + S X=DG(DQ),DIC=DIE + X ^DD(2,.3025,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" X ^DD(2,.3025,1,1,1.4) + S X=DG(DQ),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.3025,1,2,1.4) + S X=DG(DQ),DIC=DIE + D EVENT^IVMPLOG(DA) +C4F1 Q +X4 S DFN=DA D MV^DGLOCK I $D(X),X="Y" D EC^DGLOCK1 + Q + ; +5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW=".362;20",DV="NJ8,2X",DU="",DLB="TOTAL ANNUAL VA CHECK AMOUNT",DIFLD=.36295 + S DE(DW)="C5^DVBHCE13" + G RE +C5 G C5S:$D(DE(5))[0 K DB + S X=DE(5),DIC=DIE + X "S DFN=DA D EN^DGMTR K DGREQF" + S X=DE(5),DIC=DIE + D AUTOUPD^DGENA2(DA) +C5S S X="" G:DG(DQ)=X C5F1 K DB S X=DG(DQ),DIC=DIE X "S DFN=DA D EN^DGMTR K DGREQF" S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,89.4) S Y(102)=$S($D(^DPT(D0,"E",D1,0)):^(0),1:"") S X=$S('$D(^DIC(8,+$P(Y(102),U,1),0)):"",1:$P(^(0),U,1)) S D0=I(0,0) S D1=I(1,0) S DIU=X K Y S X=DIV S X=DIV,X=X X ^DD(2,.361,1,2,1.4) - S X=DG(DQ),DIC=DIE - ; - S X=DG(DQ),DIC=DIE - S ^DPT("AEL",DA,+X)="" - S X=DG(DQ),DIC=DIE D AUTOUPD^DGENA2(DA) - I $D(DE(25))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET +C5F1 Q +X5 D DOL^DGLOCK2 K:+X'=X&(X'?.N1"."2N)!(X>99999)!(X<0) X I $D(X) S DFN=DA D MV^DGLOCK I $D(X),('$$TOTCHK^DGLOCK2(DFN)) D TOTCKMSG^DGLOCK2 K X + Q + ; +6 S DQ=7 ;@2062 +7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X7 S Y="@104" + Q +8 S DQ=9 ;@11 +9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X9 S DVBJ2=1 + Q +10 D:$D(DG)>9 F^DIE17 G ^DVBHCE14 diff --git a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE14.m b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE14.m index cf4bec1f..3efb0f21 100644 --- a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE14.m +++ b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE14.m @@ -1,9 +1,7 @@ -DVBHCE14 ; ;12/13/08 +DVBHCE14 ; ;12/27/07 D DE G BEGIN DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))="" - I $D(^(.11)) S %Z=^(.11) S %=$P(%Z,U,1) S:%]"" DE(10)=% S %=$P(%Z,U,2) S:%]"" DE(11)=% - I $D(^(.3)) S %Z=^(.3) S %=$P(%Z,U,11) S:%]"" DE(4)=% - I $D(^(.362)) S %Z=^(.362) S %=$P(%Z,U,12) S:%]"" DE(1)=% S %=$P(%Z,U,13) S:%]"" DE(2)=% S %=$P(%Z,U,14) S:%]"" DE(3)=% S %=$P(%Z,U,20) S:%]"" DE(5)=% + I $D(^(.11)) S %Z=^(.11) S %=$P(%Z,U,1) S:%]"" DE(1)=% S %=$P(%Z,U,2) S:%]"" DE(2)=% S %=$P(%Z,U,3) S:%]"" DE(3)=% S %=$P(%Z,U,4) S:%]"" DE(4)=% K %Z Q ; W W !?DL+DL-2,DLB_": " @@ -51,187 +49,160 @@ SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$ NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") BEGIN S DNM="DVBHCE14",DQ=1 -1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".362;12",DV="SX",DU="",DLB="RECEIVING A&A BENEFITS?",DIFLD=.36205 - S DE(DW)="C1^DVBHCE14" - S DU="Y:YES;N:NO;U:UNKNOWN;" +1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".11;1",DV="Fa",DU="",DLB="STREET ADDRESS [LINE 1]",DIFLD=.111 + S DE(DW)="C1^DVBHCE14",DE(DW,"INDEX")=1 G RE C1 G C1S:$D(DE(1))[0 K DB S X=DE(1),DIC=DIE - X ^DD(2,.36205,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,1,2.4) + X "S DGXRF=.111 D ^DGDDC Q" S X=DE(1),DIC=DIE - S DFN=DA D EN^DGMTCOR K DGMTCOR + S A1B2TAG="PAT" D ^A1B2XFR S X=DE(1),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,3,2.4) + D EVENT^IVMPLOG(DA) S X=DE(1),DIC=DIE - D AUTOUPD^DGENA2(DA) + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR + S X=DE(1),DIC=DIE + S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX + S X=DE(1),DIC=DIE + I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".111;" D AVAFC^VAFCDD01(DA) + S X=DE(1),DIC=DIE + D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) + S X=DE(1),DIIX=2_U_DIFLD D AUDIT^DIET C1S S X="" G:DG(DQ)=X C1F1 K DB S X=DG(DQ),DIC=DIE - X ^DD(2,.36205,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,1,1.4) - S X=DG(DQ),DIC=DIE - S DFN=DA D EN^DGMTCOR K DGMTCOR - S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,3,1.4) - S X=DG(DQ),DIC=DIE - D AUTOUPD^DGENA2(DA) -C1F1 Q -X1 S DFN=DA D MV^DGLOCK I $D(X) S DFN=DA D EV^DGLOCK - Q ; -2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW=".362;13",DV="SX",DU="",DLB="RECEIVING HOUSEBOUND BENEFITS?",DIFLD=.36215 - S DE(DW)="C2^DVBHCE14" - S DU="Y:YES;N:NO;U:UNKNOWN;" - G RE -C2 G C2S:$D(DE(2))[0 K DB - S X=DE(2),DIC=DIE - X ^DD(2,.36215,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,1,2.4) - S X=DE(2),DIC=DIE - S DFN=DA D EN^DGMTCOR K DGMTCOR - S X=DE(2),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,3,2.4) - S X=DE(2),DIC=DIE - D AUTOUPD^DGENA2(DA) -C2S S X="" G:DG(DQ)=X C2F1 K DB S X=DG(DQ),DIC=DIE - X ^DD(2,.36215,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,1,1.4) - S X=DG(DQ),DIC=DIE - S DFN=DA D EN^DGMTCOR K DGMTCOR - S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,3,1.4) - S X=DG(DQ),DIC=DIE - D AUTOUPD^DGENA2(DA) -C2F1 Q -X2 S DFN=DA D MV^DGLOCK I $D(X) S DFN=DA D EV^DGLOCK - Q - ; -3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW=".362;14",DV="SX",DU="",DLB="RECEIVING A VA PENSION?",DIFLD=.36235 - S DE(DW)="C3^DVBHCE14" - S DU="Y:YES;N:NO;U:UNKNOWN;" - G RE -C3 G C3S:$D(DE(3))[0 K DB - S X=DE(3),DIC=DIE - X ^DD(2,.36235,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,1,2.4) - S X=DE(3),DIC=DIE - S DFN=DA D EN^DGMTCOR K DGMTCOR - S X=DE(3),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,3,2.4) - S X=DE(3),DIC=DIE - D AUTOUPD^DGENA2(DA) -C3S S X="" G:DG(DQ)=X C3F1 K DB - S X=DG(DQ),DIC=DIE - X ^DD(2,.36235,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,1,1.4) - S X=DG(DQ),DIC=DIE - S DFN=DA D EN^DGMTCOR K DGMTCOR - S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,3,1.4) - S X=DG(DQ),DIC=DIE - D AUTOUPD^DGENA2(DA) -C3F1 Q -X3 S DFN=DA D MV^DGLOCK - Q - ; -4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW=".3;11",DV="SX",DU="",DLB="RECEIVING VA DISABILITY?",DIFLD=.3025 - S DE(DW)="C4^DVBHCE14" - S DU="Y:YES;N:NO;U:UNKNOWN;" - G RE -C4 G C4S:$D(DE(4))[0 K DB - S X=DE(4),DIC=DIE - X ^DD(2,.3025,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" X ^DD(2,.3025,1,1,2.4) - S X=DE(4),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.3025,1,2,2.4) - S X=DE(4),DIC=DIE - D EVENT^IVMPLOG(DA) -C4S S X="" G:DG(DQ)=X C4F1 K DB - S X=DG(DQ),DIC=DIE - X ^DD(2,.3025,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" X ^DD(2,.3025,1,1,1.4) - S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.3025,1,2,1.4) - S X=DG(DQ),DIC=DIE - D EVENT^IVMPLOG(DA) -C4F1 Q -X4 S DFN=DA D MV^DGLOCK I $D(X),X="Y" D EC^DGLOCK1 - Q - ; -5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW=".362;20",DV="NJ8,2X",DU="",DLB="TOTAL ANNUAL VA CHECK AMOUNT",DIFLD=.36295 - S DE(DW)="C5^DVBHCE14" - G RE -C5 G C5S:$D(DE(5))[0 K DB - S X=DE(5),DIC=DIE - X "S DFN=DA D EN^DGMTR K DGREQF" - S X=DE(5),DIC=DIE - D AUTOUPD^DGENA2(DA) -C5S S X="" G:DG(DQ)=X C5F1 K DB - S X=DG(DQ),DIC=DIE - X "S DFN=DA D EN^DGMTR K DGREQF" - S X=DG(DQ),DIC=DIE - D AUTOUPD^DGENA2(DA) -C5F1 Q -X5 D DOL^DGLOCK2 K:+X'=X&(X'?.N1"."2N)!(X>99999)!(X<0) X I $D(X) S DFN=DA D MV^DGLOCK I $D(X),('$$TOTCHK^DGLOCK2(DFN)) D TOTCKMSG^DGLOCK2 K X - Q - ; -6 S DQ=7 ;@2062 -7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X7 S Y="@104" - Q -8 S DQ=9 ;@11 -9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X9 S DVBJ2=1 - Q -10 D:$D(DG)>9 F^DIE17,DE S DQ=10,DW=".11;1",DV="Fa",DU="",DLB="STREET ADDRESS [LINE 1]",DIFLD=.111 - S DE(DW)="C10^DVBHCE14",DE(DW,"INDEX")=1 - G RE -C10 G C10S:$D(DE(10))[0 K DB - S X=DE(10),DIC=DIE - X "S DGXRF=.111 D ^DGDDC Q" - S X=DE(10),DIC=DIE S A1B2TAG="PAT" D ^A1B2XFR - S X=DE(10),DIC=DIE + S X=DG(DQ),DIC=DIE D EVENT^IVMPLOG(DA) - S X=DE(10),DIC=DIE + S X=DG(DQ),DIC=DIE K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR - S X=DE(10),DIC=DIE + S X=DG(DQ),DIC=DIE S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX - S X=DE(10),DIC=DIE + S X=DG(DQ),DIC=DIE I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".111;" D AVAFC^VAFCDD01(DA) - S X=DE(10),DIC=DIE + S X=DG(DQ),DIC=DIE D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) - S X=DE(10),DIIX=2_U_DIFLD D AUDIT^DIET -C10S S X="" G:DG(DQ)=X C10F1 K DB - D ^DVBHCE15 -C10F1 N X,X1,X2 S DIXR=230 D C10X1(U) K X2 M X2=X D C10X1("O") K X1 M X1=X + I $D(DE(1))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET +C1F1 N X,X1,X2 S DIXR=230 D C1X1(U) K X2 M X2=X D C1X1("O") K X1 M X1=X D . D FC^DGFCPROT(.DA,2,.111,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q K X M X=X2 D . D FC^DGFCPROT(.DA,2,.111,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q - G C10F2 -C10X1(DION) K X + G C1F2 +C1X1(DION) K X S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.111,DION),$P($G(^DPT(DA,.11)),U,1)) S X=$G(X(1)) Q -C10F2 Q -X10 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>35!($L(X)<3) X +C1F2 Q +X1 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>35!($L(X)<3) X I $D(X),X'?.ANP K X Q ; -11 D:$D(DG)>9 F^DIE17,DE S DQ=11,DW=".11;2",DV="Fa",DU="",DLB="STREET ADDRESS [LINE 2]",DIFLD=.112 - S DE(DW)="C11^DVBHCE14",DE(DW,"INDEX")=1 +2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW=".11;2",DV="Fa",DU="",DLB="STREET ADDRESS [LINE 2]",DIFLD=.112 + S DE(DW)="C2^DVBHCE14",DE(DW,"INDEX")=1 G RE -C11 G C11S:$D(DE(11))[0 K DB - D ^DVBHCE16 -C11S S X="" G:DG(DQ)=X C11F1 K DB - D ^DVBHCE17 -C11F1 N X,X1,X2 S DIXR=232 D C11X1(U) K X2 M X2=X D C11X1("O") K X1 M X1=X +C2 G C2S:$D(DE(2))[0 K DB + S X=DE(2),DIC=DIE + X "S DGXRF=.112 D ^DGDDC Q" + S X=DE(2),DIC=DIE + S A1B2TAG="PAT" D ^A1B2XFR + S X=DE(2),DIC=DIE + D EVENT^IVMPLOG(DA) + S X=DE(2),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR + S X=DE(2),DIC=DIE + S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX + S X=DE(2),DIC=DIE + I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".112;" D AVAFC^VAFCDD01(DA) + S X=DE(2),DIC=DIE + D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) + S X=DE(2),DIIX=2_U_DIFLD D AUDIT^DIET +C2S S X="" G:DG(DQ)=X C2F1 K DB + S X=DG(DQ),DIC=DIE + ; + S X=DG(DQ),DIC=DIE + S A1B2TAG="PAT" D ^A1B2XFR + S X=DG(DQ),DIC=DIE + D EVENT^IVMPLOG(DA) + S X=DG(DQ),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR + S X=DG(DQ),DIC=DIE + S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX + S X=DG(DQ),DIC=DIE + I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".112;" D AVAFC^VAFCDD01(DA) + S X=DG(DQ),DIC=DIE + D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) + I $D(DE(2))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET +C2F1 N X,X1,X2 S DIXR=232 D C2X1(U) K X2 M X2=X D C2X1("O") K X1 M X1=X D . D FC^DGFCPROT(.DA,2,.112,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q K X M X=X2 D . D FC^DGFCPROT(.DA,2,.112,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q - G C11F2 -C11X1(DION) K X + G C2F2 +C2X1(DION) K X S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.112,DION),$P($G(^DPT(DA,.11)),U,2)) S X=$G(X(1)) Q -C11F2 Q -X11 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3) X D:$D(X) UP^DGHELP +C2F2 Q +X2 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3) X D:$D(X) UP^DGHELP I $D(X),X'?.ANP K X Q ; -12 D:$D(DG)>9 F^DIE17 G ^DVBHCE18 +3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW=".11;3",DV="Fa",DU="",DLB="STREET ADDRESS [LINE 3]",DIFLD=.113 + S DE(DW)="C3^DVBHCE14",DE(DW,"INDEX")=1 + G RE +C3 G C3S:$D(DE(3))[0 K DB + S X=DE(3),DIC=DIE + S A1B2TAG="PAT" D ^A1B2XFR + S X=DE(3),DIC=DIE + D EVENT^IVMPLOG(DA) + S X=DE(3),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR + S X=DE(3),DIC=DIE + S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX + S X=DE(3),DIC=DIE + I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".113;" D AVAFC^VAFCDD01(DA) + S X=DE(3),DIC=DIE + D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) + S X=DE(3),DIIX=2_U_DIFLD D AUDIT^DIET +C3S S X="" G:DG(DQ)=X C3F1 K DB + D ^DVBHCE15 +C3F1 N X,X1,X2 S DIXR=233 D C3X1(U) K X2 M X2=X D C3X1("O") K X1 M X1=X + D + . D FC^DGFCPROT(.DA,2,.113,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q + K X M X=X2 D + . D FC^DGFCPROT(.DA,2,.113,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q + G C3F2 +C3X1(DION) K X + S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.113,DION),$P($G(^DPT(DA,.11)),U,3)) + S X=$G(X(1)) + Q +C3F2 Q +X3 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3) X + I $D(X),X'?.ANP K X + Q + ; +4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW=".11;4",DV="Fa",DU="",DLB="CITY",DIFLD=.114 + S DE(DW)="C4^DVBHCE14",DE(DW,"INDEX")=1 + G RE +C4 G C4S:$D(DE(4))[0 K DB + D ^DVBHCE16 +C4S S X="" G:DG(DQ)=X C4F1 K DB + D ^DVBHCE17 +C4F1 N X,X1,X2 S DIXR=234 D C4X1(U) K X2 M X2=X D C4X1("O") K X1 M X1=X + D + . D FC^DGFCPROT(.DA,2,.114,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q + K X M X=X2 D + . D FC^DGFCPROT(.DA,2,.114,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q + G C4F2 +C4X1(DION) K X + S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.114,DION),$P($G(^DPT(DA,.11)),U,4)) + S X=$G(X(1)) + Q +C4F2 Q +X4 K:$L(X)>15!($L(X)<2) X + I $D(X),X'?.ANP K X + Q + ; +5 D:$D(DG)>9 F^DIE17 G ^DVBHCE18 diff --git a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE15.m b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE15.m index 92460593..eea31e1e 100644 --- a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE15.m +++ b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE15.m @@ -1,6 +1,4 @@ -DVBHCE15 ; ;12/13/08 - S X=DG(DQ),DIC=DIE - ; +DVBHCE15 ; ;12/27/07 S X=DG(DQ),DIC=DIE S A1B2TAG="PAT" D ^A1B2XFR S X=DG(DQ),DIC=DIE @@ -10,7 +8,7 @@ DVBHCE15 ; ;12/13/08 S X=DG(DQ),DIC=DIE S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX S X=DG(DQ),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".111;" D AVAFC^VAFCDD01(DA) + I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".113;" D AVAFC^VAFCDD01(DA) S X=DG(DQ),DIC=DIE D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) - I $D(DE(10))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET + I $D(DE(3))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET diff --git a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE16.m b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE16.m index e1bed0e7..b342103a 100644 --- a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE16.m +++ b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE16.m @@ -1,16 +1,14 @@ -DVBHCE16 ; ;12/13/08 - S X=DE(11),DIC=DIE - X "S DGXRF=.112 D ^DGDDC Q" - S X=DE(11),DIC=DIE +DVBHCE16 ; ;12/27/07 + S X=DE(4),DIC=DIE S A1B2TAG="PAT" D ^A1B2XFR - S X=DE(11),DIC=DIE + S X=DE(4),DIC=DIE D EVENT^IVMPLOG(DA) - S X=DE(11),DIC=DIE + S X=DE(4),DIC=DIE K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR - S X=DE(11),DIC=DIE + S X=DE(4),DIC=DIE S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX - S X=DE(11),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".112;" D AVAFC^VAFCDD01(DA) - S X=DE(11),DIC=DIE + S X=DE(4),DIC=DIE + I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".114;" D AVAFC^VAFCDD01(DA) + S X=DE(4),DIC=DIE D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) - S X=DE(11),DIIX=2_U_DIFLD D AUDIT^DIET + S X=DE(4),DIIX=2_U_DIFLD D AUDIT^DIET diff --git a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE17.m b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE17.m index c4cc66e0..70431f97 100644 --- a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE17.m +++ b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE17.m @@ -1,6 +1,4 @@ -DVBHCE17 ; ;12/13/08 - S X=DG(DQ),DIC=DIE - ; +DVBHCE17 ; ;12/27/07 S X=DG(DQ),DIC=DIE S A1B2TAG="PAT" D ^A1B2XFR S X=DG(DQ),DIC=DIE @@ -10,7 +8,7 @@ DVBHCE17 ; ;12/13/08 S X=DG(DQ),DIC=DIE S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX S X=DG(DQ),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".112;" D AVAFC^VAFCDD01(DA) + I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".114;" D AVAFC^VAFCDD01(DA) S X=DG(DQ),DIC=DIE D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) - I $D(DE(11))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET + I $D(DE(4))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET diff --git a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE18.m b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE18.m index 92d9ad88..12872467 100644 --- a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE18.m +++ b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE18.m @@ -1,7 +1,7 @@ -DVBHCE18 ; ;12/13/08 +DVBHCE18 ; ;12/27/07 D DE G BEGIN DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))="" - I $D(^(.11)) S %Z=^(.11) S %=$P(%Z,U,3) S:%]"" DE(1)=% S %=$P(%Z,U,4) S:%]"" DE(2)=% S %=$P(%Z,U,5) S:%]"" DE(3)=% S %=$P(%Z,U,7) S:%]"" DE(5)=% S %=$P(%Z,U,12) S:%]"" DE(4)=% + I $D(^(.11)) S %Z=^(.11) S %=$P(%Z,U,5) S:%]"" DE(1)=% S %=$P(%Z,U,7) S:%]"" DE(3)=% S %=$P(%Z,U,12) S:%]"" DE(2)=% K %Z Q ; W W !?DL+DL-2,DLB_": " @@ -49,24 +49,29 @@ SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$ NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") BEGIN S DNM="DVBHCE18",DQ=1 -1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".11;3",DV="Fa",DU="",DLB="STREET ADDRESS [LINE 3]",DIFLD=.113 +1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".11;5",DV="P5'a",DU="",DLB="STATE",DIFLD=.115 S DE(DW)="C1^DVBHCE18",DE(DW,"INDEX")=1 + S DU="DIC(5," G RE C1 G C1S:$D(DE(1))[0 K DB + S X=DE(1),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:""),Y=$P(Y(1),U,7) X:$D(^DD(2,.117,2)) ^(2) S X=Y S DIU=X K Y S X=DIV S X="" X ^DD(2,.115,1,1,2.4) S X=DE(1),DIC=DIE S A1B2TAG="PAT" D ^A1B2XFR S X=DE(1),DIC=DIE D EVENT^IVMPLOG(DA) S X=DE(1),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR S X=DE(1),DIC=DIE S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX S X=DE(1),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".113;" D AVAFC^VAFCDD01(DA) + I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".115;" D AVAFC^VAFCDD01(DA) S X=DE(1),DIC=DIE D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) S X=DE(1),DIIX=2_U_DIFLD D AUDIT^DIET C1S S X="" G:DG(DQ)=X C1F1 K DB + S X=DG(DQ),DIC=DIE + ; S X=DG(DQ),DIC=DIE S A1B2TAG="PAT" D ^A1B2XFR S X=DG(DQ),DIC=DIE @@ -76,31 +81,29 @@ C1S S X="" G:DG(DQ)=X C1F1 K DB S X=DG(DQ),DIC=DIE S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX S X=DG(DQ),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".113;" D AVAFC^VAFCDD01(DA) + I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".115;" D AVAFC^VAFCDD01(DA) S X=DG(DQ),DIC=DIE D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) I $D(DE(1))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET -C1F1 N X,X1,X2 S DIXR=233 D C1X1(U) K X2 M X2=X D C1X1("O") K X1 M X1=X +C1F1 N X,X1,X2 S DIXR=235 D C1X1(U) K X2 M X2=X D C1X1("O") K X1 M X1=X D - . D FC^DGFCPROT(.DA,2,.113,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q + . D FC^DGFCPROT(.DA,2,.115,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q K X M X=X2 D - . D FC^DGFCPROT(.DA,2,.113,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q + . D FC^DGFCPROT(.DA,2,.115,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q G C1F2 C1X1(DION) K X - S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.113,DION),$P($G(^DPT(DA,.11)),U,3)) + S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.115,DION),$P($G(^DPT(DA,.11)),U,5)) S X=$G(X(1)) Q C1F2 Q -X1 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3) X - I $D(X),X'?.ANP K X - Q - ; -2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW=".11;4",DV="Fa",DU="",DLB="CITY",DIFLD=.114 +X1 Q +2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW=".11;12",DV="FXOa",DU="",DLB="ZIP+4",DIFLD=.1112 + S DQ(2,2)="S Y(0)=Y D ZIPOUT^VAFADDR" S DE(DW)="C2^DVBHCE18",DE(DW,"INDEX")=1 G RE C2 G C2S:$D(DE(2))[0 K DB S X=DE(2),DIC=DIE - S A1B2TAG="PAT" D ^A1B2XFR + D KILL^DGREGDD1(DA,.116,.11,6,$E(X,1,5)) S X=DE(2),DIC=DIE D EVENT^IVMPLOG(DA) S X=DE(2),DIC=DIE @@ -108,13 +111,13 @@ C2 G C2S:$D(DE(2))[0 K DB S X=DE(2),DIC=DIE S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX S X=DE(2),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".114;" D AVAFC^VAFCDD01(DA) + I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".1112;" D AVAFC^VAFCDD01(DA) S X=DE(2),DIC=DIE D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) S X=DE(2),DIIX=2_U_DIFLD D AUDIT^DIET C2S S X="" G:DG(DQ)=X C2F1 K DB S X=DG(DQ),DIC=DIE - S A1B2TAG="PAT" D ^A1B2XFR + D SET^DGREGDD1(DA,.116,.11,6,$E(X,1,5)) S X=DG(DQ),DIC=DIE D EVENT^IVMPLOG(DA) S X=DG(DQ),DIC=DIE @@ -122,169 +125,94 @@ C2S S X="" G:DG(DQ)=X C2F1 K DB S X=DG(DQ),DIC=DIE S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX S X=DG(DQ),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".114;" D AVAFC^VAFCDD01(DA) + I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".1112;" D AVAFC^VAFCDD01(DA) S X=DG(DQ),DIC=DIE D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) I $D(DE(2))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET -C2F1 N X,X1,X2 S DIXR=234 D C2X1(U) K X2 M X2=X D C2X1("O") K X1 M X1=X - D - . D FC^DGFCPROT(.DA,2,.114,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q - K X M X=X2 D - . D FC^DGFCPROT(.DA,2,.114,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q - G C2F2 -C2X1(DION) K X - S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.114,DION),$P($G(^DPT(DA,.11)),U,4)) - S X=$G(X(1)) - Q -C2F2 Q -X2 K:$L(X)>15!($L(X)<2) X - I $D(X),X'?.ANP K X - Q - ; -3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW=".11;5",DV="P5'a",DU="",DLB="STATE",DIFLD=.115 - S DE(DW)="C3^DVBHCE18",DE(DW,"INDEX")=1 - S DU="DIC(5," - G RE -C3 G C3S:$D(DE(3))[0 K DB - S X=DE(3),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:""),Y=$P(Y(1),U,7) X:$D(^DD(2,.117,2)) ^(2) S X=Y S DIU=X K Y S X=DIV S X="" X ^DD(2,.115,1,1,2.4) - S X=DE(3),DIC=DIE - S A1B2TAG="PAT" D ^A1B2XFR - S X=DE(3),DIC=DIE - D EVENT^IVMPLOG(DA) - S X=DE(3),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR - S X=DE(3),DIC=DIE - S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX - S X=DE(3),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".115;" D AVAFC^VAFCDD01(DA) - S X=DE(3),DIC=DIE - D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) - S X=DE(3),DIIX=2_U_DIFLD D AUDIT^DIET -C3S S X="" G:DG(DQ)=X C3F1 K DB - S X=DG(DQ),DIC=DIE - ; - S X=DG(DQ),DIC=DIE - S A1B2TAG="PAT" D ^A1B2XFR - S X=DG(DQ),DIC=DIE - D EVENT^IVMPLOG(DA) - S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR - S X=DG(DQ),DIC=DIE - S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX - S X=DG(DQ),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".115;" D AVAFC^VAFCDD01(DA) - S X=DG(DQ),DIC=DIE - D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) - I $D(DE(3))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET -C3F1 N X,X1,X2 S DIXR=235 D C3X1(U) K X2 M X2=X D C3X1("O") K X1 M X1=X - D - . D FC^DGFCPROT(.DA,2,.115,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q - K X M X=X2 D - . D FC^DGFCPROT(.DA,2,.115,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q - G C3F2 -C3X1(DION) K X - S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.115,DION),$P($G(^DPT(DA,.11)),U,5)) - S X=$G(X(1)) - Q -C3F2 Q -X3 Q -4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW=".11;12",DV="FXOa",DU="",DLB="ZIP+4",DIFLD=.1112 - S DQ(4,2)="S Y(0)=Y D ZIPOUT^VAFADDR" - S DE(DW)="C4^DVBHCE18",DE(DW,"INDEX")=1 - G RE -C4 G C4S:$D(DE(4))[0 K DB - S X=DE(4),DIC=DIE - D KILL^DGREGDD1(DA,.116,.11,6,$E(X,1,5)) - S X=DE(4),DIC=DIE - D EVENT^IVMPLOG(DA) - S X=DE(4),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR - S X=DE(4),DIC=DIE - S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX - S X=DE(4),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".1112;" D AVAFC^VAFCDD01(DA) - S X=DE(4),DIC=DIE - D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) - S X=DE(4),DIIX=2_U_DIFLD D AUDIT^DIET -C4S S X="" G:DG(DQ)=X C4F1 K DB - D ^DVBHCE19 -C4F1 N X,X1,X2 S DIXR=185 D C4X1(U) K X2 M X2=X D C4X1("O") K X1 M X1=X +C2F1 N X,X1,X2 S DIXR=185 D C2X1(U) K X2 M X2=X D C2X1("O") K X1 M X1=X D . N DIEXARR M DIEXARR=X S DIEZCOND=1 . I X1(1)'=X2(1) . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND . K EASDO2 - G C4F2 -C4X1(DION) K X + G C2F2 +C2X1(DION) K X S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.1112,DION),$P($G(^DPT(DA,.11)),U,12)) S:('$G(EASDO2)&($D(EASZIPLK))) X=$$ZIP^DGREGDD1(DA,X(1)) S:$D(X)#2 X(2)=X S X=$G(X(1)) Q -C4F2 S DIXR=231 D C4X2(U) K X2 M X2=X D C4X2("O") K X1 M X1=X +C2F2 S DIXR=231 D C2X2(U) K X2 M X2=X D C2X2("O") K X1 M X1=X D . D FC^DGFCPROT(.DA,2,.1112,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q K X M X=X2 D . D FC^DGFCPROT(.DA,2,.1112,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q - G C4F3 -C4X2(DION) K X + G C2F3 +C2X2(DION) K X S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.1112,DION),$P($G(^DPT(DA,.11)),U,12)) S X=$G(X(1)) Q -C4F3 Q -X4 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>20!($L(X)<5) X I $D(X) D ZIPIN^VAFADDR +C2F3 Q +X2 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>20!($L(X)<5) X I $D(X) D ZIPIN^VAFADDR I $D(X),X'?.ANP K X Q ; -5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW=".11;7",DV="NJ3,0XOa",DU="",DLB="COUNTY",DIFLD=.117 - S DQ(5,2)="S Y(0)=Y Q:Y']"""" S Z0=$S($D(^DPT(D0,.11)):+$P(^(.11),""^"",5),1:"""") Q:'Z0 S Y=$P($S($D(^DIC(5,Z0,1,Y,0)):^(0),1:""""),""^"",3)" - S DE(DW)="C5^DVBHCE18" +3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW=".11;7",DV="NJ3,0XOa",DU="",DLB="COUNTY",DIFLD=.117 + S DQ(3,2)="S Y(0)=Y Q:Y']"""" S Z0=$S($D(^DPT(D0,.11)):+$P(^(.11),""^"",5),1:"""") Q:'Z0 S Y=$P($S($D(^DIC(5,Z0,1,Y,0)):^(0),1:""""),""^"",3)" + S DE(DW)="C3^DVBHCE18" G RE -C5 G C5S:$D(DE(5))[0 K DB - D ^DVBHCE20 -C5S S X="" G:DG(DQ)=X C5F1 K DB - D ^DVBHCE21 -C5F1 Q -X5 S Z0=$S($D(^DPT(D0,.11)):+$P(^(.11),"^",5),1:0) K:'Z0 X Q:'Z0!'$D(^DIC(5,Z0,1,0)) S DIC="^DIC(5,Z0,1,",DIC(0)="QEM" D ^DIC S X=+Y K:Y'>0 X K Z0,DIC +C3 G C3S:$D(DE(3))[0 K DB + S X=DE(3),DIC=DIE + S A1B2TAG="PAT" D ^A1B2XFR + S X=DE(3),DIC=DIE + D EVENT^IVMPLOG(DA) + S X=DE(3),DIC=DIE + S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX + S X=DE(3),DIC=DIE + I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".117;" D AVAFC^VAFCDD01(DA) + S X=DE(3),DIIX=2_U_DIFLD D AUDIT^DIET +C3S S X="" G:DG(DQ)=X C3F1 K DB + D ^DVBHCE19 +C3F1 Q +X3 S Z0=$S($D(^DPT(D0,.11)):+$P(^(.11),"^",5),1:0) K:'Z0 X Q:'Z0!'$D(^DIC(5,Z0,1,0)) S DIC="^DIC(5,Z0,1,",DIC(0)="QEM" D ^DIC S X=+Y K:Y'>0 X K Z0,DIC Q ; +4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X4 S Y="@1001" + Q +5 S DQ=6 ;@5 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X6 S Y="@1001" +X6 D SCRQ^DVBHUTIL Q -7 S DQ=8 ;@5 +7 S DQ=8 ;@6 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X8 D SCRQ^DVBHUTIL +X8 D B^DVBHQEDT R AA:DTIME K AA S Y=$S(DVBJS=11:"@1001",DVBJS=28:"@1",DVBJS=35:"@2",DVBJS=44:"@3",DVBJS=53:"@104",1:"@10") Q -9 S DQ=10 ;@6 +9 S DQ=10 ;@8 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X10 D B^DVBHQEDT R AA:DTIME K AA S Y=$S(DVBJS=11:"@1001",DVBJS=28:"@1",DVBJS=35:"@2",DVBJS=44:"@3",DVBJS=53:"@104",1:"@10") +X10 S Y=$S(ANS="^0":"@101",ANS="^1":"@1001",ANS="^2":"@1",ANS="^3":"@2",ANS="^4":"@3",ANS="^5":"@104",1:Y) I Y["@" W @$S('$D(IOF):"#",IOF="":"#",1:IOF) Q -11 S DQ=12 ;@8 -12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X12 S Y=$S(ANS="^0":"@101",ANS="^1":"@1001",ANS="^2":"@1",ANS="^3":"@2",ANS="^4":"@3",ANS="^5":"@104",1:Y) I Y["@" W @$S('$D(IOF):"#",IOF="":"#",1:IOF) +11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X11 D A^DVBHQEDT S Z2=Z I ERROR K ERROR S Y=$S(DVBJS=11:"@1001",DVBJS=28:"@1",DVBJS=35:"@2",DVBJS=44:"@3",DVBJS=53:"@104",1:"@10") Q +12 S DQ=13 ;@20 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X13 D A^DVBHQEDT S Z2=Z I ERROR K ERROR S Y=$S(DVBJS=11:"@1001",DVBJS=28:"@1",DVBJS=35:"@2",DVBJS=44:"@3",DVBJS=53:"@104",1:"@10") +X13 S JP=1,Y=$S(DVBJS=11:"@11",DVBJS=35:"@40",DVBJS=44:"@30",DVBJS=53:"@204",1:Y) Q -14 S DQ=15 ;@20 +14 S DQ=15 ;@21 15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X15 S JP=1,Y=$S(DVBJS=11:"@11",DVBJS=35:"@40",DVBJS=44:"@30",DVBJS=53:"@204",1:Y) +X15 I $P(Z2,U,JP)'=1 S Y="@22" + Q +16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X16 I '$D(DVBCN) S Y="@22",JP=JP+1 Q -16 S DQ=17 ;@21 17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X17 I $P(Z2,U,JP)'=1 S Y="@22" +X17 I 'DVBCN S Y="@22",JP=JP+1 Q 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X18 I '$D(DVBCN) S Y="@22",JP=JP+1 +X18 S DVBCN=$TR(DVBCN," ") Q 19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X19 I 'DVBCN S Y="@22",JP=JP+1 +X19 I $L(DVBCN)=9,(DVBCN?9N),(DVBCN'=$P(^DPT(D0,0),U,9)) W !!,*7,"HINQ claim # is a SSN, does not match patient file SSN NO UPDATING claim #" R !,?25,"",DVBQ:DTIME K DVBQ S Y="@22",JP=JP+1 Q -20 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=20 D X20 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X20 S DVBCN=$TR(DVBCN," ") - Q -21 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=21 D X21 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X21 I $L(DVBCN)=9,(DVBCN?9N),(DVBCN'=$P(^DPT(D0,0),U,9)) W !!,*7,"HINQ claim # is a SSN, does not match patient file SSN NO UPDATING claim #" R !,?25,"",DVBQ:DTIME K DVBQ S Y="@22",JP=JP+1 - Q -22 D:$D(DG)>9 F^DIE17 G ^DVBHCE22 +20 D:$D(DG)>9 F^DIE17 G ^DVBHCE20 diff --git a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE19.m b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE19.m index 079e1662..b8421963 100644 --- a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE19.m +++ b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE19.m @@ -1,14 +1,10 @@ -DVBHCE19 ; ;12/13/08 +DVBHCE19 ; ;12/27/07 S X=DG(DQ),DIC=DIE - D SET^DGREGDD1(DA,.116,.11,6,$E(X,1,5)) + S A1B2TAG="PAT" D ^A1B2XFR S X=DG(DQ),DIC=DIE D EVENT^IVMPLOG(DA) S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR - S X=DG(DQ),DIC=DIE S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX S X=DG(DQ),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".1112;" D AVAFC^VAFCDD01(DA) - S X=DG(DQ),DIC=DIE - D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) - I $D(DE(4))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET + I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".117;" D AVAFC^VAFCDD01(DA) + I $D(DE(3))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET diff --git a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE2.m b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE2.m index e5cdd6dc..f2095a2a 100644 --- a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE2.m +++ b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE2.m @@ -1,5 +1,3 @@ -DVBHCE2 ; ;12/13/08 - S X=DE(32),DIC=DIE - ; - S X=DE(32),DIC=DIE +DVBHCE2 ; ;12/27/07 + S X=DG(DQ),DIC=DIE D EVENT^IVMPLOG(DA) diff --git a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE20.m b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE20.m index 48880fcb..382a18fc 100644 --- a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE20.m +++ b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE20.m @@ -1,10 +1,175 @@ -DVBHCE20 ; ;12/13/08 - S X=DE(5),DIC=DIE - S A1B2TAG="PAT" D ^A1B2XFR - S X=DE(5),DIC=DIE +DVBHCE20 ; ;12/27/07 + D DE G BEGIN +DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))="" + I $D(^(.31)) S %Z=^(.31) S %=$P(%Z,U,3) S:%]"" DE(1)=% + I $D(^(.35)) S %Z=^(.35) S %=$P(%Z,U,1) S:%]"" DE(20)=% + K %Z Q + ; +W W !?DL+DL-2,DLB_": " + Q +O D W W Y W:$X>45 !?9 + I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 + W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q +TR R X:DTIME E S (DTOUT,X)=U W $C(7) + Q +A K DQ(DQ) S DQ=DQ+1 +B G @DQ +RE G PR:$D(DE(DQ)) D W,TR +N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A +RD G QS:X?."?" I X["^" D D G ^DIE17 + I X="@" D D G Z^DIE2 + I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X +T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V + K DDER G X +P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 + G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z + I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X +V D @("X"_DQ) K YS +Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A +X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 + S X="?BAD" +QS S DZ=X D D,QQ^DIEQ G B +D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q +Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N +PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP +R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R + I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R + X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% +RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 +I I DV'["I",DV'["#" G RD + D E^DIE0 G RD:$D(X),PR + Q +SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 + I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 + D ^DIR I 'DDER S %=Y(0),X=Y + Q +SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) + I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" + E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") + Q +NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS +KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") +BEGIN S DNM="DVBHCE20",DQ=1 +1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".31;3",DV="FXOa",DU="",DLB="CLAIM NUMBER",DIFLD=.313 + S DQ(1,2)="S Y(0)=Y S Y=$E(Y,1,10)" + S DE(DW)="C1^DVBHCE20" + S X=DVBCN + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +C1 G C1S:$D(DE(1))[0 K DB + S X=DE(1),DIC=DIE + I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".313;" D AVAFC^VAFCDD01(DA) + S X=DE(1),DIC=DIE D EVENT^IVMPLOG(DA) - S X=DE(5),DIC=DIE - S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX - S X=DE(5),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".117;" D AVAFC^VAFCDD01(DA) - S X=DE(5),DIIX=2_U_DIFLD D AUDIT^DIET + S X=DE(1),DIIX=2_U_DIFLD D AUDIT^DIET +C1S S X="" G:DG(DQ)=X C1F1 K DB + S X=DG(DQ),DIC=DIE + I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".313;" D AVAFC^VAFCDD01(DA) + S X=DG(DQ),DIC=DIE + D EVENT^IVMPLOG(DA) + I $D(DE(1))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET +C1F1 Q +X1 S DFN=DA D EV^DGLOCK I $D(X) S L=$S($D(^DPT(DA,0)):$P(^(0),U,9),1:X) W:X?1"SS".E " ",L S:X?1"SS".E X=L K:$L(X)>9 X Q:'$D(X) I X'=L K:$L(X)>8!($L(X)<7)!'(X?.N) X + I $D(X),X'?.ANP K X + Q + ; +2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X2 W "." S JP=JP+1,DVBJ2=1 + Q +3 S DQ=4 ;@22 +4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X4 I $P(Z2,U,JP)'=2 S Y="@225" + Q +5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X5 W !,"Date of Birth cannot be edited with this option." + Q +6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X6 H 1 + Q +7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X7 W "." S JP=JP+1,DVBJ2=1 + Q +8 S DQ=9 ;@225 +9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X9 I $P(Z2,U,JP)'=3 S Y="@23" + Q +10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X10 W !,"Sex cannot be edited with this option." + Q +11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X11 H 1 + Q +12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X12 W "." S JP=JP+1,DVBJ2=1 + Q +13 S DQ=14 ;@23 +14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X14 I $P(Z2,U,JP)'=4 S Y="@24" + Q +15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X15 K Z1 I $D(DVBP(6)),+$P(DVBP(6),U) S Z1=$P(DVBP(6),U),Z1=$E(Z1,1,2)_" "_$E(Z1,3,4)_" "_$E(Z1,5,8) + Q +16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X16 I $D(DVBVET),$P(DVBVET,U,1)="B",+$P(DVBVET,U,12) S Z1=$P(DVBVET,U,12),Z1=$E(Z1,5,6)_" "_$E(Z1,7,8)_" "_$E(Z1,1,4) + Q +17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X17 I '$D(Z1) S Y="@24",JP=JP+1 + Q +18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X18 I 'Z1 S Y="@24",JP=JP+1 + Q +19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X19 I $D(^DPT(D0,.105)) W !!,"Patient is currently in-house." W !,"Discharge patient with a discharge type of DEATH." R !,?25,"",DVBQ:DTIME K DVBQ S Y="@24",JP=JP+1 + Q +20 D:$D(DG)>9 F^DIE17,DE S DQ=20,DW=".35;1",DV="DXa",DU="",DLB="DATE OF DEATH",DIFLD=.351 + S DE(DW)="C20^DVBHCE20",DE(DW,"INDEX")=1 + S X=Z1 + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +C20 G C20S:$D(DE(20))[0 K DB + D ^DVBHCE21 +C20S S X="" G:DG(DQ)=X C20F1 K DB + D ^DVBHCE22 +C20F1 N X,X1,X2 S DIXR=180 D C20X1(U) K X2 M X2=X D C20X1("O") K X1 M X1=X + D + . D FC^DGFCPROT(.DA,2,.351,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q + K X M X=X2 D + . D FC^DGFCPROT(.DA,2,.351,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q + G C20F2 +C20X1(DION) K X + S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.351,DION),$P($G(^DPT(DA,.35)),U,1)) + S X=$G(X(1)) + Q +C20F2 S DIXR=685 D C20X2(U) K X2 M X2=X D C20X2("O") K X1 M X1=X + D + . D FC^DGFCPROT(.DA,2,.351,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q + K X M X=X2 D + . D FC^DGFCPROT(.DA,2,.351,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q + G C20F3 +C20X2(DION) K X + S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.351,DION),$P($G(^DPT(DA,.35)),U,1)) + S X=$G(X(1)) + Q +C20F3 Q +X20 S %DT="PT" D ^%DT S X=Y K:Y<1 X I $D(X) D H^DGUTL K:X>DGTIME X K DGTIME,DGDATE I $D(X),X<$P(^DPT(DA,0),"^",3) K X + Q + ; +21 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=21 D X21 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X21 W "." S JP=JP+1,DVBJ2=1 + Q +22 S DQ=23 ;@24 +23 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=23 D X23 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X23 I $P(Z2,U,JP)'=5 S Y="@25" + Q +24 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=24 D X24 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X24 K DVBSICK I $D(DVBP(6)) S DVBSICK=$P(DVBP(6),U,7) + Q +25 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=25 D X25 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X25 I $D(DVBCI) S DVBSICK=DVBCI + Q +26 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=26 D X26 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X26 I '$D(DVBSICK) S Y="@25",JP=JP+1 + Q +27 D:$D(DG)>9 F^DIE17 G ^DVBHCE23 diff --git a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE21.m b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE21.m index 7b07d3ff..46933f75 100644 --- a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE21.m +++ b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE21.m @@ -1,10 +1,30 @@ -DVBHCE21 ; ;12/13/08 - S X=DG(DQ),DIC=DIE - S A1B2TAG="PAT" D ^A1B2XFR - S X=DG(DQ),DIC=DIE - D EVENT^IVMPLOG(DA) - S X=DG(DQ),DIC=DIE +DVBHCE21 ; ;12/27/07 + S X=DE(20),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,0)):^(0),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y X ^DD(2,.351,1,1,2.1) X ^DD(2,.351,1,1,2.4) + S X=DE(20),DIC=DIE + ; + S X=DE(20),DIC=DIE + D DKBULL^DGDEATH + S X=DE(20),DIC=DIE + K ^DPT("AEXP1",$E(X,1,30),DA) + S X=DE(20),DIC=DIE + ; + S X=DE(20),DIC=DIE + ; + S X=DE(20),DIC=DIE + S RCX=X,X="RCAMDTH" X ^%ZOSF("TEST") S X=RCX K RCX I D ERR^RCAMDTH + S X=DE(20),DIC=DIE + D KILL^DGDEPINA + S X=DE(20),DIC=DIE + D AUTOUPD^DGENA2(DA) + S X=DE(20),DIC=DIE + ; + S X=DE(20),DIC=DIE + I $$VERSION^XPDUTL("PSO")>6 D APSOD^PSOAUTOC(DA) + S X=DE(20),DIC=DIE S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX - S X=DG(DQ),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".117;" D AVAFC^VAFCDD01(DA) - I $D(DE(5))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET + S X=DE(20),DIC=DIE + I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".351;" D AVAFC^VAFCDD01(DA) + S X=DE(20),DIC=DIE + D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) + S X=DE(20),DIIX=2_U_DIFLD D AUDIT^DIET diff --git a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE22.m b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE22.m index 1bff237c..4f64cb7d 100644 --- a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE22.m +++ b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE22.m @@ -1,246 +1,30 @@ -DVBHCE22 ; ;12/13/08 - D DE G BEGIN -DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))="" - I $D(^(.29)) S %Z=^(.29) S %=$P(%Z,U,12) S:%]"" DE(27)=% - I $D(^(.31)) S %Z=^(.31) S %=$P(%Z,U,3) S:%]"" DE(1)=% - I $D(^(.35)) S %Z=^(.35) S %=$P(%Z,U,1) S:%]"" DE(20)=% - K %Z Q - ; -W W !?DL+DL-2,DLB_": " - Q -O D W W Y W:$X>45 !?9 - I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 - W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q -TR R X:DTIME E S (DTOUT,X)=U W $C(7) - Q -A K DQ(DQ) S DQ=DQ+1 -B G @DQ -RE G PR:$D(DE(DQ)) D W,TR -N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A -RD G QS:X?."?" I X["^" D D G ^DIE17 - I X="@" D D G Z^DIE2 - I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X -T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V - K DDER G X -P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 - G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z - I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X -V D @("X"_DQ) K YS -Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A -X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 - S X="?BAD" -QS S DZ=X D D,QQ^DIEQ G B -D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q -Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N -PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP -R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R - I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R - X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% -RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 -I I DV'["I",DV'["#" G RD - D E^DIE0 G RD:$D(X),PR - Q -SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 - I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 - D ^DIR I 'DDER S %=Y(0),X=Y - Q -SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) - I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" - E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") - Q -NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS -KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") -BEGIN S DNM="DVBHCE22",DQ=1 -1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".31;3",DV="FXOa",DU="",DLB="CLAIM NUMBER",DIFLD=.313 - S DQ(1,2)="S Y(0)=Y S Y=$E(Y,1,10)" - S DE(DW)="C1^DVBHCE22" - S X=DVBCN - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -C1 G C1S:$D(DE(1))[0 K DB - S X=DE(1),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".313;" D AVAFC^VAFCDD01(DA) - S X=DE(1),DIC=DIE - D EVENT^IVMPLOG(DA) - S X=DE(1),DIIX=2_U_DIFLD D AUDIT^DIET -C1S S X="" G:DG(DQ)=X C1F1 K DB +DVBHCE22 ; ;12/27/07 S X=DG(DQ),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".313;" D AVAFC^VAFCDD01(DA) + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,0)):^(0),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y X ^DD(2,.351,1,1,1.1) X ^DD(2,.351,1,1,1.4) + S X=DG(DQ),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.35)):^(.35),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y X ^DD(2,.351,1,2,1.1) X ^DD(2,.351,1,2,1.4) + S X=DG(DQ),DIC=DIE + D DSBULL^DGDEATH + S X=DG(DQ),DIC=DIE + S ^DPT("AEXP1",$E(X,1,30),DA)="" + S X=DG(DQ),DIC=DIE + D DEATH^DGOERNOT + S X=DG(DQ),DIC=DIE + S XX=X,X="PSJADT" X ^%ZOSF("TEST") S X=XX K XX I D END^PSJADT + S X=DG(DQ),DIC=DIE + S RCX=X,X="RCAMDTH" X ^%ZOSF("TEST") S X=RCX K RCX I D SET^RCAMDTH + S X=DG(DQ),DIC=DIE + D SET^DGDEPINA S X=DG(DQ),DIC=DIE - D EVENT^IVMPLOG(DA) - I $D(DE(1))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET -C1F1 Q -X1 S DFN=DA D EV^DGLOCK I $D(X) S L=$S($D(^DPT(DA,0)):$P(^(0),U,9),1:X) W:X?1"SS".E " ",L S:X?1"SS".E X=L K:$L(X)>9 X Q:'$D(X) I X'=L K:$L(X)>8!($L(X)<7)!'(X?.N) X - I $D(X),X'?.ANP K X - Q - ; -2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X2 W "." S JP=JP+1,DVBJ2=1 - Q -3 S DQ=4 ;@22 -4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X4 I $P(Z2,U,JP)'=2 S Y="@225" - Q -5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X5 W !,"Date of Birth cannot be edited with this option." - Q -6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X6 H 1 - Q -7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X7 W "." S JP=JP+1,DVBJ2=1 - Q -8 S DQ=9 ;@225 -9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X9 I $P(Z2,U,JP)'=3 S Y="@23" - Q -10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X10 W !,"Sex cannot be edited with this option." - Q -11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X11 H 1 - Q -12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X12 W "." S JP=JP+1,DVBJ2=1 - Q -13 S DQ=14 ;@23 -14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X14 I $P(Z2,U,JP)'=4 S Y="@24" - Q -15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X15 K Z1 I $D(DVBP(6)),+$P(DVBP(6),U) S Z1=$P(DVBP(6),U),Z1=$E(Z1,1,2)_" "_$E(Z1,3,4)_" "_$E(Z1,5,8) - Q -16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X16 I $D(DVBVET),$P(DVBVET,U,1)="B",+$P(DVBVET,U,12) S Z1=$P(DVBVET,U,12),Z1=$E(Z1,5,6)_" "_$E(Z1,7,8)_" "_$E(Z1,1,4) - Q -17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X17 I '$D(Z1) S Y="@24",JP=JP+1 - Q -18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X18 I 'Z1 S Y="@24",JP=JP+1 - Q -19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X19 I $D(^DPT(D0,.105)) W !!,"Patient is currently in-house." W !,"Discharge patient with a discharge type of DEATH." R !,?25,"",DVBQ:DTIME K DVBQ S Y="@24",JP=JP+1 - Q -20 D:$D(DG)>9 F^DIE17,DE S DQ=20,DW=".35;1",DV="DXa",DU="",DLB="DATE OF DEATH",DIFLD=.351 - S DE(DW)="C20^DVBHCE22",DE(DW,"INDEX")=1 - S X=Z1 - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -C20 G C20S:$D(DE(20))[0 K DB - S X=DE(20),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,0)):^(0),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y X ^DD(2,.351,1,1,2.1) X ^DD(2,.351,1,1,2.4) - S X=DE(20),DIC=DIE - ; - S X=DE(20),DIC=DIE - D DKBULL^DGDEATH - S X=DE(20),DIC=DIE - K ^DPT("AEXP1",$E(X,1,30),DA) - S X=DE(20),DIC=DIE - ; - S X=DE(20),DIC=DIE - ; - S X=DE(20),DIC=DIE - S RCX=X,X="RCAMDTH" X ^%ZOSF("TEST") S X=RCX K RCX I D ERR^RCAMDTH - S X=DE(20),DIC=DIE - D KILL^DGDEPINA - S X=DE(20),DIC=DIE D AUTOUPD^DGENA2(DA) - S X=DE(20),DIC=DIE - ; - S X=DE(20),DIC=DIE - I $$VERSION^XPDUTL("PSO")>6 D APSOD^PSOAUTOC(DA) - S X=DE(20),DIC=DIE + S X=DG(DQ),DIC=DIE + D START^DGMTDELS(DA) + S X=DG(DQ),DIC=DIE + I $$VERSION^XPDUTL("PSO")>6 D APSOD^PSOCAN3(DA) + S X=DG(DQ),DIC=DIE S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX - S X=DE(20),DIC=DIE + S X=DG(DQ),DIC=DIE I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".351;" D AVAFC^VAFCDD01(DA) - S X=DE(20),DIC=DIE + S X=DG(DQ),DIC=DIE D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) - S X=DE(20),DIIX=2_U_DIFLD D AUDIT^DIET -C20S S X="" G:DG(DQ)=X C20F1 K DB - D ^DVBHCE23 -C20F1 N X,X1,X2 S DIXR=180 D C20X1(U) K X2 M X2=X D C20X1("O") K X1 M X1=X - D - . D FC^DGFCPROT(.DA,2,.351,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q - K X M X=X2 D - . D FC^DGFCPROT(.DA,2,.351,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q - G C20F2 -C20X1(DION) K X - S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.351,DION),$P($G(^DPT(DA,.35)),U,1)) - S X=$G(X(1)) - Q -C20F2 S DIXR=685 D C20X2(U) K X2 M X2=X D C20X2("O") K X1 M X1=X - D - . D FC^DGFCPROT(.DA,2,.351,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q - K X M X=X2 D - . D FC^DGFCPROT(.DA,2,.351,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q - G C20F3 -C20X2(DION) K X - S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.351,DION),$P($G(^DPT(DA,.35)),U,1)) - S X=$G(X(1)) - Q -C20F3 Q -X20 S %DT="PT" D ^%DT S X=Y K:Y<1 X I $D(X) D H^DGUTL K:X>DGTIME X K DGTIME,DGDATE I $D(X),X<$P(^DPT(DA,0),"^",3) K X - Q - ; -21 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=21 D X21 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X21 W "." S JP=JP+1,DVBJ2=1 - Q -22 S DQ=23 ;@24 -23 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=23 D X23 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X23 I $P(Z2,U,JP)'=5 S Y="@25" - Q -24 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=24 D X24 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X24 K DVBSICK I $D(DVBP(6)) S DVBSICK=$P(DVBP(6),U,7) - Q -25 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=25 D X25 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X25 I $D(DVBCI) S DVBSICK=DVBCI - Q -26 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=26 D X26 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X26 I '$D(DVBSICK) S Y="@25",JP=JP+1 - Q -27 D:$D(DG)>9 F^DIE17,DE S DQ=27,DW=".29;12",DV="S",DU="",DLB="RATED INCOMPETENT?",DIFLD=.293 - S DE(DW)="C27^DVBHCE22" - S DU="0:NO;1:YES;" - S X=$S((DVBSICK="I")!(DVBSICK="Y"):1,1:0) - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -C27 G C27S:$D(DE(27))[0 K DB - S X=DE(27),DIC=DIE - D EVENT^IVMPLOG(DA) -C27S S X="" G:DG(DQ)=X C27F1 K DB - D ^DVBHCE24 -C27F1 Q -X27 Q -28 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=28 D X28 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X28 W "." S JP=JP+1,DVBJ2=1 K DVBSICK - Q -29 S DQ=30 ;@25 -30 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=30 D X30 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X30 I $P(Z2,U,JP)'=6 S Y="@26" - Q -31 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=31 D X31 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X31 I '$D(DVBPOW),'$D(DVBPOWD) S Y="@26",JP=JP+1 - Q -32 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=32 D X32 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X32 I '$D(DVBPOW),$D(DVBPOWD),+DVBPOWD W !!,*7,?17,DVBON,"POW Indicator Discrepancy! ",DVBOFF X DVBLIT1 R DVBZ:DTIME K DVBZ S JP=JP+1,Y="@26" - Q -33 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=33 D X33 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X33 I '$D(DVBPOW),'+DVBPOWD S Y="@26",JP=JP+1 - Q -34 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=34 D X34 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X34 I '$D(DVBPOWD),$D(DVBPOW),DVBPOW>0 W !!,*7,?17,DVBON,"POW Indicator Discrepancy! ",DVBOFF X DVBLIT1 R DVBZ:DTIME K DVBZ S JP=JP+1,Y="@26" - Q -35 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=35 D X35 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X35 I $D(DVBPOWD),$D(DVBPOW),DVBPOWD=0,DVBPOW>0 W !!,*7,?17,DVBON,"POW Indicator Discrepancy! ",DVBOFF X DVBLIT1 R DVBZ:DTIME K DVBZ S JP=JP+1,Y="@26" - Q -36 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=36 D X36 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X36 I $D(DVBPOWD),$D(DVBPOW),+DVBPOW<1,+DVBPOWD W !!,*7,?17,DVBON,"POW Indicator Discrepancy! ",DVBOFF X DVBLIT1 R DVBZ:DTIME K DVBZ S JP=JP+1,Y="@26" - Q -37 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=37 D X37 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X37 D POW^DVBHUTIL - Q -38 D:$D(DG)>9 F^DIE17 G ^DVBHCE25 + I $D(DE(20))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET diff --git a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE23.m b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE23.m index 563e6203..20d197d5 100644 --- a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE23.m +++ b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE23.m @@ -1,30 +1,185 @@ -DVBHCE23 ; ;12/13/08 +DVBHCE23 ; ;12/27/07 + D DE G BEGIN +DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))="" + I $D(^(.29)) S %Z=^(.29) S %=$P(%Z,U,12) S:%]"" DE(1)=% + I $D(^(.31)) S %Z=^(.31) S %=$P(%Z,U,4) S:%]"" DE(19)=% + I $D(^(.52)) S %Z=^(.52) S %=$P(%Z,U,5) S:%]"" DE(12)=% + K %Z Q + ; +W W !?DL+DL-2,DLB_": " + Q +O D W W Y W:$X>45 !?9 + I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 + W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q +TR R X:DTIME E S (DTOUT,X)=U W $C(7) + Q +A K DQ(DQ) S DQ=DQ+1 +B G @DQ +RE G PR:$D(DE(DQ)) D W,TR +N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A +RD G QS:X?."?" I X["^" D D G ^DIE17 + I X="@" D D G Z^DIE2 + I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X +T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V + K DDER G X +P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 + G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z + I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X +V D @("X"_DQ) K YS +Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A +X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 + S X="?BAD" +QS S DZ=X D D,QQ^DIEQ G B +D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q +Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N +PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP +R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R + I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R + X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% +RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 +I I DV'["I",DV'["#" G RD + D E^DIE0 G RD:$D(X),PR + Q +SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 + I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 + D ^DIR I 'DDER S %=Y(0),X=Y + Q +SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) + I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" + E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") + Q +NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS +KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") +BEGIN S DNM="DVBHCE23",DQ=1 +1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".29;12",DV="S",DU="",DLB="RATED INCOMPETENT?",DIFLD=.293 + S DE(DW)="C1^DVBHCE23" + S DU="0:NO;1:YES;" + S X=$S((DVBSICK="I")!(DVBSICK="Y"):1,1:0) + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +C1 G C1S:$D(DE(1))[0 K DB + S X=DE(1),DIC=DIE + D EVENT^IVMPLOG(DA) +C1S S X="" G:DG(DQ)=X C1F1 K DB S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,0)):^(0),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y X ^DD(2,.351,1,1,1.1) X ^DD(2,.351,1,1,1.4) + D EVENT^IVMPLOG(DA) +C1F1 Q +X1 Q +2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X2 W "." S JP=JP+1,DVBJ2=1 K DVBSICK + Q +3 S DQ=4 ;@25 +4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X4 I $P(Z2,U,JP)'=6 S Y="@26" + Q +5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X5 I '$D(DVBPOW),'$D(DVBPOWD) S Y="@26",JP=JP+1 + Q +6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X6 I '$D(DVBPOW),$D(DVBPOWD),+DVBPOWD W !!,*7,?17,DVBON,"POW Indicator Discrepancy! ",DVBOFF X DVBLIT1 R DVBZ:DTIME K DVBZ S JP=JP+1,Y="@26" + Q +7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X7 I '$D(DVBPOW),'+DVBPOWD S Y="@26",JP=JP+1 + Q +8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X8 I '$D(DVBPOWD),$D(DVBPOW),DVBPOW>0 W !!,*7,?17,DVBON,"POW Indicator Discrepancy! ",DVBOFF X DVBLIT1 R DVBZ:DTIME K DVBZ S JP=JP+1,Y="@26" + Q +9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X9 I $D(DVBPOWD),$D(DVBPOW),DVBPOWD=0,DVBPOW>0 W !!,*7,?17,DVBON,"POW Indicator Discrepancy! ",DVBOFF X DVBLIT1 R DVBZ:DTIME K DVBZ S JP=JP+1,Y="@26" + Q +10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X10 I $D(DVBPOWD),$D(DVBPOW),+DVBPOW<1,+DVBPOWD W !!,*7,?17,DVBON,"POW Indicator Discrepancy! ",DVBOFF X DVBLIT1 R DVBZ:DTIME K DVBZ S JP=JP+1,Y="@26" + Q +11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X11 D POW^DVBHUTIL + Q +12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW=".52;5",DV="RSX",DU="",DLB="POW STATUS INDICATED?",DIFLD=.525 + S DE(DW)="C12^DVBHCE23",DE(DW,"INDEX")=1 + S DU="Y:YES;N:NO;U:UNKNOWN;" + S X=DVBPOW1 + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +C12 G C12S:$D(DE(12))[0 K DB + S X=DE(12),DIC=DIE + ; + S X=DE(12),DIC=DIE + ; + S X=DE(12),DIC=DIE + ; + S X=DE(12),DIC=DIE + D AUTOUPD^DGENA2(DA) + S X=DE(12),DIC=DIE + X "S DFN=DA D EN^DGMTR K DGREQF" + S X=DE(12),DIC=DIE + D EVENT^IVMPLOG(DA) +C12S S X="" G:DG(DQ)=X C12F1 K DB S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.35)):^(.35),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y X ^DD(2,.351,1,2,1.1) X ^DD(2,.351,1,2,1.4) + X ^DD(2,.525,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.52)):^(.52),1:"") S X=$S('$D(^DIC(22,+$P(Y(1),U,6),0)):"",1:$P(^(0),U,1)) S DIU=X K Y S X=DIV S X="" X ^DD(2,.525,1,1,1.4) S X=DG(DQ),DIC=DIE - D DSBULL^DGDEATH + X ^DD(2,.525,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.52)):^(.52),1:"") S X=$P(Y(1),U,7) S DIU=X K Y S X=DIV S X="" X ^DD(2,.525,1,2,1.4) S X=DG(DQ),DIC=DIE - S ^DPT("AEXP1",$E(X,1,30),DA)="" - S X=DG(DQ),DIC=DIE - D DEATH^DGOERNOT - S X=DG(DQ),DIC=DIE - S XX=X,X="PSJADT" X ^%ZOSF("TEST") S X=XX K XX I D END^PSJADT - S X=DG(DQ),DIC=DIE - S RCX=X,X="RCAMDTH" X ^%ZOSF("TEST") S X=RCX K RCX I D SET^RCAMDTH - S X=DG(DQ),DIC=DIE - D SET^DGDEPINA + X ^DD(2,.525,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.52)):^(.52),1:"") S X=$P(Y(1),U,8) S DIU=X K Y S X=DIV S X="" X ^DD(2,.525,1,3,1.4) S X=DG(DQ),DIC=DIE D AUTOUPD^DGENA2(DA) S X=DG(DQ),DIC=DIE - D START^DGMTDELS(DA) + X "S DFN=DA D EN^DGMTR K DGREQF" S X=DG(DQ),DIC=DIE - I $$VERSION^XPDUTL("PSO")>6 D APSOD^PSOCAN3(DA) - S X=DG(DQ),DIC=DIE - S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX - S X=DG(DQ),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".351;" D AVAFC^VAFCDD01(DA) - S X=DG(DQ),DIC=DIE - D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) - I $D(DE(20))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET + D EVENT^IVMPLOG(DA) +C12F1 N X,X1,X2 S DIXR=646 D C12X1(U) K X2 M X2=X D C12X1("O") K X1 M X1=X + D + . D FC^DGFCPROT(.DA,2,.525,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q + K X M X=X2 D + . D FC^DGFCPROT(.DA,2,.525,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q + G C12F2 +C12X1(DION) K X + S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.525,DION),$P($G(^DPT(DA,.52)),U,5)) + S X=$G(X(1)) + Q +C12F2 Q +X12 S DFN=DA D SV^DGLOCK + Q + ; +13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X13 K DVBPOW1 W "." S JP=JP+1,DVBJ2=1 + Q +14 S DQ=15 ;@26 +15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X15 I $P(Z2,U,JP)'=7 S Y="@27" + Q +16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X16 I '$D(DVBFL) S Y="@27",JP=JP+1 + Q +17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X17 I DVBFL']"" S Y="@27",JP=JP+1 + Q +18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X18 I DVBFL'?3N1" - "1U.E S Y="@27",JP=JP+1 + Q +19 D:$D(DG)>9 F^DIE17,DE S DQ=19,DW=".31;4",DV="*P4'X",DU="",DLB="CLAIM FOLDER LOCATION",DIFLD=.314 + S DE(DW)="C19^DVBHCE23" + S DU="DIC(4," + S X=+DVBFL + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +C19 G C19S:$D(DE(19))[0 K DB + D ^DVBHCE24 +C19S S X="" G:DG(DQ)=X C19F1 K DB + D ^DVBHCE25 +C19F1 Q +X19 S DIC("S")="I $$CFLTF^DGREGDD(Y)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X + Q + ; +20 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=20 D X20 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X20 W "." S JP=JP+1,DVBJ2=1 + Q +21 S DQ=22 ;@27 +22 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=22 D X22 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X22 I $P(Z2,U,JP)'=8 S Y="@50" + Q +23 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=23 D X23 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X23 I '$D(DVBEI) S Y="@50",JP=JP+1 + Q +24 D:$D(DG)>9 F^DIE17 G ^DVBHCE26 diff --git a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE24.m b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE24.m index b5a9cabd..49a37dd0 100644 --- a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE24.m +++ b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE24.m @@ -1,3 +1,3 @@ -DVBHCE24 ; ;12/13/08 - S X=DG(DQ),DIC=DIE - D EVENT^IVMPLOG(DA) +DVBHCE24 ; ;12/27/07 + S X=DE(19),DIC=DIE + D KILL^DGREGDD(DA) diff --git a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE25.m b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE25.m index f65f5fa7..7070f632 100644 --- a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE25.m +++ b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE25.m @@ -1,251 +1,3 @@ -DVBHCE25 ; ;12/13/08 - D DE G BEGIN -DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))="" - I $D(^(.3)) S %Z=^(.3) S %=$P(%Z,U,5) S:%]"" DE(13)=% - I $D(^(.31)) S %Z=^(.31) S %=$P(%Z,U,4) S:%]"" DE(8)=% - I $D(^(.32)) S %Z=^(.32) S %=$P(%Z,U,2) S:%]"" DE(20)=% - I $D(^(.321)) S %Z=^(.321) S %=$P(%Z,U,1) S:%]"" DE(26)=% - I $D(^(.52)) S %Z=^(.52) S %=$P(%Z,U,5) S:%]"" DE(1)=% - K %Z Q - ; -W W !?DL+DL-2,DLB_": " - Q -O D W W Y W:$X>45 !?9 - I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 - W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q -TR R X:DTIME E S (DTOUT,X)=U W $C(7) - Q -A K DQ(DQ) S DQ=DQ+1 -B G @DQ -RE G PR:$D(DE(DQ)) D W,TR -N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A -RD G QS:X?."?" I X["^" D D G ^DIE17 - I X="@" D D G Z^DIE2 - I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X -T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V - K DDER G X -P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 - G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z - I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X -V D @("X"_DQ) K YS -Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A -X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 - S X="?BAD" -QS S DZ=X D D,QQ^DIEQ G B -D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q -Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N -PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP -R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R - I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R - X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% -RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 -I I DV'["I",DV'["#" G RD - D E^DIE0 G RD:$D(X),PR - Q -SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 - I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 - D ^DIR I 'DDER S %=Y(0),X=Y - Q -SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) - I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" - E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") - Q -NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS -KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") -BEGIN S DNM="DVBHCE25",DQ=1 -1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".52;5",DV="RSX",DU="",DLB="POW STATUS INDICATED?",DIFLD=.525 - S DE(DW)="C1^DVBHCE25",DE(DW,"INDEX")=1 - S DU="Y:YES;N:NO;U:UNKNOWN;" - S X=DVBPOW1 - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -C1 G C1S:$D(DE(1))[0 K DB - S X=DE(1),DIC=DIE - ; - S X=DE(1),DIC=DIE - ; - S X=DE(1),DIC=DIE - ; - S X=DE(1),DIC=DIE - D AUTOUPD^DGENA2(DA) - S X=DE(1),DIC=DIE - X "S DFN=DA D EN^DGMTR K DGREQF" - S X=DE(1),DIC=DIE - D EVENT^IVMPLOG(DA) -C1S S X="" G:DG(DQ)=X C1F1 K DB - S X=DG(DQ),DIC=DIE - X ^DD(2,.525,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.52)):^(.52),1:"") S X=$S('$D(^DIC(22,+$P(Y(1),U,6),0)):"",1:$P(^(0),U,1)) S DIU=X K Y S X=DIV S X="" X ^DD(2,.525,1,1,1.4) - S X=DG(DQ),DIC=DIE - X ^DD(2,.525,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.52)):^(.52),1:"") S X=$P(Y(1),U,7) S DIU=X K Y S X=DIV S X="" X ^DD(2,.525,1,2,1.4) - S X=DG(DQ),DIC=DIE - X ^DD(2,.525,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.52)):^(.52),1:"") S X=$P(Y(1),U,8) S DIU=X K Y S X=DIV S X="" X ^DD(2,.525,1,3,1.4) - S X=DG(DQ),DIC=DIE - D AUTOUPD^DGENA2(DA) - S X=DG(DQ),DIC=DIE - X "S DFN=DA D EN^DGMTR K DGREQF" - S X=DG(DQ),DIC=DIE - D EVENT^IVMPLOG(DA) -C1F1 N X,X1,X2 S DIXR=646 D C1X1(U) K X2 M X2=X D C1X1("O") K X1 M X1=X - D - . D FC^DGFCPROT(.DA,2,.525,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q - K X M X=X2 D - . D FC^DGFCPROT(.DA,2,.525,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q - G C1F2 -C1X1(DION) K X - S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.525,DION),$P($G(^DPT(DA,.52)),U,5)) - S X=$G(X(1)) - Q -C1F2 Q -X1 S DFN=DA D SV^DGLOCK - Q - ; -2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X2 K DVBPOW1 W "." S JP=JP+1,DVBJ2=1 - Q -3 S DQ=4 ;@26 -4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X4 I $P(Z2,U,JP)'=7 S Y="@27" - Q -5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X5 I '$D(DVBFL) S Y="@27",JP=JP+1 - Q -6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X6 I DVBFL']"" S Y="@27",JP=JP+1 - Q -7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X7 I DVBFL'?3N1" - "1U.E S Y="@27",JP=JP+1 - Q -8 D:$D(DG)>9 F^DIE17,DE S DQ=8,DW=".31;4",DV="*P4'X",DU="",DLB="CLAIM FOLDER LOCATION",DIFLD=.314 - S DE(DW)="C8^DVBHCE25" - S DU="DIC(4," - S X=+DVBFL - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -C8 G C8S:$D(DE(8))[0 K DB - S X=DE(8),DIC=DIE - D KILL^DGREGDD(DA) -C8S S X="" G:DG(DQ)=X C8F1 K DB +DVBHCE25 ; ;12/27/07 S X=DG(DQ),DIC=DIE D SET^DGREGDD(DA,X) -C8F1 Q -X8 S DIC("S")="I $$CFLTF^DGREGDD(Y)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X - Q - ; -9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X9 W "." S JP=JP+1,DVBJ2=1 - Q -10 S DQ=11 ;@27 -11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X11 I $P(Z2,U,JP)'=8 S Y="@50" - Q -12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X12 I '$D(DVBEI) S Y="@50",JP=JP+1 - Q -13 D:$D(DG)>9 F^DIE17,DE S DQ=13,DW=".3;5",DV="S",DU="",DLB="UNEMPLOYABLE",DIFLD=.305 - S DE(DW)="C13^DVBHCE25" - S DU="Y:YES;N:NO;" - S X=$S(DVBEI="Y":"Y",1:"N") - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -C13 G C13S:$D(DE(13))[0 K DB - S X=DE(13),DIC=DIE - D AUTOUPD^DGENA2(DA) - S X=DE(13),DIC=DIE - S DFN=DA D EN^DGMTCOR K DGMTCOR -C13S S X="" G:DG(DQ)=X C13F1 K DB - S X=DG(DQ),DIC=DIE - D AUTOUPD^DGENA2(DA) - S X=DG(DQ),DIC=DIE - S DFN=DA D EN^DGMTCOR K DGMTCOR -C13F1 Q -X13 Q -14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X14 W "." S JP=JP+1,DVBJ2=1 - Q -15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X15 S Y="@50" - Q -16 S DQ=17 ;@40 -17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X17 I $P(Z2,U,JP)'=1 S Y="@42" - Q -18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X18 I '$D(DVBP(6)) S Y="@42",JP=JP+1 - Q -19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X19 I $S($P(DVBP(6),U,8)'="Y":1,'$D(^DPT(DFN,.32)):1,+$P(^(0),U,2):1,1:0) S Y="@42",JP=JP+1 - Q -20 D:$D(DG)>9 F^DIE17,DE S DQ=20,DW=".32;2",DV="DX",DU="",DLB="SERVICE VERIFICATION DATE",DIFLD=.322 - S X="T" - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -X20 S %DT="",%DT(0)=-DT D ^%DT K %DT S X=Y K:Y<1 X I $D(X) D EK^DGLOCK - Q - ; -21 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=21 D X21 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X21 W "." S JP=JP+1,DVBJ2=1 - Q -22 S DQ=23 ;@42 -23 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=23 D X23 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X23 I $P(Z2,U,JP)'=2 S Y="@45" - Q -24 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=24 D X24 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X24 I '$D(DVBP(6)) S Y="@45",JP=JP+1 - Q -25 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=25 D X25 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X25 I $P(DVBP(6),U,4)[" " S Y="@45",JP=JP+1 - Q -26 S DW=".321;1",DV="RSX",DU="",DLB="VIETNAM SERVICE INDICATED?",DIFLD=.32101 - S DE(DW)="C26^DVBHCE25" - S DU="Y:YES;N:NO;U:UNKNOWN;" - S X=$P(DVBP(6),U,4) - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -C26 G C26S:$D(DE(26))[0 K DB - S X=DE(26),DIC=DIE - ; - S X=DE(26),DIC=DIE - ; - S X=DE(26),DIC=DIE - D EVENT^IVMPLOG(DA) -C26S S X="" G:DG(DQ)=X C26F1 K DB - D ^DVBHCE26 -C26F1 Q -X26 S DFN=DA D SV^DGLOCK - Q - ; -27 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=27 D X27 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X27 W "." S JP=JP+1,DVBJ2=1 - Q -28 S DQ=29 ;@45 -29 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=29 D X29 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X29 I $P(Z2,U,JP)'=3!('$D(DVBDX(1))) S Y="@50" - Q -30 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=30 D X30 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X30 S:'$D(DVBFL) DVBFL="UNKNOWN" - Q -31 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=31 D X31 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X31 I $D(DVBCAP),DVBCAP["No C&P",$P(DVBBIR,U,5)'="Y" D CHK^DVBHUTIL - Q -32 S DQ=33 ;@47 -33 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=33 D X33 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X33 S DVB4=$S($D(^DPT(DFN,.3))>0:$P(^(.3),U),1:0),DVB5=$S($D(^DPT(DFN,.36))>0:$P(^(.36),U),1:0),DVB6=$S($D(^DPT(DFN,"VET"))>0:^("VET"),1:0),DVB7=$S($D(^DPT(DFN,"TYPE"))>0:^("TYPE"),1:0) - Q -34 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=34 D X34 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X34 S DVB8=$O(^DIC(8,"B","SERVICE CONNECTED 50% to 100%",0)),DVB9=$O(^DIC(8,"B","SC LESS THAN 50%",0)) - Q -35 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=35 D X35 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X35 I DVBDXNO I ((DVB8'=DVB5&(DVB9'=DVB5))!(DVB4'="Y")!(DVB6'="Y")!(DVB7'=1)) S Y="@70" - Q -36 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=36 D X36 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X36 W ! K ^DPT(DFN,.372),JP4,JP6 S ^DPT(DFN,.372,0)="^2.04P^^0",JP=0 - Q -37 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=37 D X37 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X37 S $P(^DPT(DFN,.3),U,2)="",$P(^DPT(DFN,.3),U,14)="" - Q -38 D:$D(DG)>9 F^DIE17 G ^DVBHCE27 diff --git a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE26.m b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE26.m index 081ff68a..3ab06def 100644 --- a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE26.m +++ b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE26.m @@ -1,7 +1,178 @@ -DVBHCE26 ; ;12/13/08 +DVBHCE26 ; ;12/27/07 + D DE G BEGIN +DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))="" + I $D(^(.3)) S %Z=^(.3) S %=$P(%Z,U,2) S:%]"" DE(26)=% S %=$P(%Z,U,5) S:%]"" DE(1)=% + I $D(^(.32)) S %Z=^(.32) S %=$P(%Z,U,2) S:%]"" DE(8)=% + I $D(^(.321)) S %Z=^(.321) S %=$P(%Z,U,1) S:%]"" DE(14)=% + K %Z Q + ; +W W !?DL+DL-2,DLB_": " + Q +O D W W Y W:$X>45 !?9 + I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 + W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q +TR R X:DTIME E S (DTOUT,X)=U W $C(7) + Q +A K DQ(DQ) S DQ=DQ+1 +B G @DQ +RE G PR:$D(DE(DQ)) D W,TR +N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A +RD G QS:X?."?" I X["^" D D G ^DIE17 + I X="@" D D G Z^DIE2 + I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X +T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V + K DDER G X +P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 + G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z + I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X +V D @("X"_DQ) K YS +Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A +X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 + S X="?BAD" +QS S DZ=X D D,QQ^DIEQ G B +D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q +Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N +PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP +R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R + I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R + X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% +RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 +I I DV'["I",DV'["#" G RD + D E^DIE0 G RD:$D(X),PR + Q +SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 + I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 + D ^DIR I 'DDER S %=Y(0),X=Y + Q +SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) + I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" + E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") + Q +NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS +KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") +BEGIN S DNM="DVBHCE26",DQ=1 +1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".3;5",DV="S",DU="",DLB="UNEMPLOYABLE",DIFLD=.305 + S DE(DW)="C1^DVBHCE26" + S DU="Y:YES;N:NO;" + S X=$S(DVBEI="Y":"Y",1:"N") + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +C1 G C1S:$D(DE(1))[0 K DB + S X=DE(1),DIC=DIE + D AUTOUPD^DGENA2(DA) + S X=DE(1),DIC=DIE + S DFN=DA D EN^DGMTCOR K DGMTCOR +C1S S X="" G:DG(DQ)=X C1F1 K DB + S X=DG(DQ),DIC=DIE + D AUTOUPD^DGENA2(DA) + S X=DG(DQ),DIC=DIE + S DFN=DA D EN^DGMTCOR K DGMTCOR +C1F1 Q +X1 Q +2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X2 W "." S JP=JP+1,DVBJ2=1 + Q +3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X3 S Y="@50" + Q +4 S DQ=5 ;@40 +5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X5 I $P(Z2,U,JP)'=1 S Y="@42" + Q +6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X6 I '$D(DVBP(6)) S Y="@42",JP=JP+1 + Q +7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X7 I $S($P(DVBP(6),U,8)'="Y":1,'$D(^DPT(DFN,.32)):1,+$P(^(0),U,2):1,1:0) S Y="@42",JP=JP+1 + Q +8 D:$D(DG)>9 F^DIE17,DE S DQ=8,DW=".32;2",DV="DX",DU="",DLB="SERVICE VERIFICATION DATE",DIFLD=.322 + S X="T" + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +X8 S %DT="",%DT(0)=-DT D ^%DT K %DT S X=Y K:Y<1 X I $D(X) D EK^DGLOCK + Q + ; +9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X9 W "." S JP=JP+1,DVBJ2=1 + Q +10 S DQ=11 ;@42 +11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X11 I $P(Z2,U,JP)'=2 S Y="@45" + Q +12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X12 I '$D(DVBP(6)) S Y="@45",JP=JP+1 + Q +13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X13 I $P(DVBP(6),U,4)[" " S Y="@45",JP=JP+1 + Q +14 S DW=".321;1",DV="RSX",DU="",DLB="VIETNAM SERVICE INDICATED?",DIFLD=.32101 + S DE(DW)="C14^DVBHCE26" + S DU="Y:YES;N:NO;U:UNKNOWN;" + S X=$P(DVBP(6),U,4) + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +C14 G C14S:$D(DE(14))[0 K DB + S X=DE(14),DIC=DIE + ; + S X=DE(14),DIC=DIE + ; + S X=DE(14),DIC=DIE + D EVENT^IVMPLOG(DA) +C14S S X="" G:DG(DQ)=X C14F1 K DB S X=DG(DQ),DIC=DIE X ^DD(2,.32101,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.321)):^(.321),1:"") S X=$P(Y(1),U,4) S DIU=X K Y S X=DIV S X="" X ^DD(2,.32101,1,1,1.4) S X=DG(DQ),DIC=DIE X ^DD(2,.32101,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.321)):^(.321),1:"") S X=$P(Y(1),U,5) S DIU=X K Y S X=DIV S X="" X ^DD(2,.32101,1,2,1.4) S X=DG(DQ),DIC=DIE D EVENT^IVMPLOG(DA) +C14F1 Q +X14 S DFN=DA D SV^DGLOCK + Q + ; +15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X15 W "." S JP=JP+1,DVBJ2=1 + Q +16 S DQ=17 ;@45 +17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X17 I $P(Z2,U,JP)'=3!('$D(DVBDX(1))) S Y="@50" + Q +18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X18 S:'$D(DVBFL) DVBFL="UNKNOWN" + Q +19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X19 I $D(DVBCAP),DVBCAP["No C&P",$P(DVBBIR,U,5)'="Y" D CHK^DVBHUTIL + Q +20 S DQ=21 ;@47 +21 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=21 D X21 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X21 S DVB4=$S($D(^DPT(DFN,.3))>0:$P(^(.3),U),1:0),DVB5=$S($D(^DPT(DFN,.36))>0:$P(^(.36),U),1:0),DVB6=$S($D(^DPT(DFN,"VET"))>0:^("VET"),1:0),DVB7=$S($D(^DPT(DFN,"TYPE"))>0:^("TYPE"),1:0) + Q +22 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=22 D X22 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X22 S DVB8=$O(^DIC(8,"B","SERVICE CONNECTED 50% to 100%",0)),DVB9=$O(^DIC(8,"B","SC LESS THAN 50%",0)) + Q +23 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=23 D X23 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X23 I DVBDXNO I ((DVB8'=DVB5&(DVB9'=DVB5))!(DVB4'="Y")!(DVB6'="Y")!(DVB7'=1)) S Y="@70" + Q +24 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=24 D X24 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X24 W ! K ^DPT(DFN,.372),JP4,JP6 S ^DPT(DFN,.372,0)="^2.04P^^0",JP=0 + Q +25 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=25 D X25 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X25 S $P(^DPT(DFN,.3),U,2)="",$P(^DPT(DFN,.3),U,14)="" + Q +26 D:$D(DG)>9 F^DIE17,DE S DQ=26,DW=".3;2",DV="NJ3,0Xa",DU="",DLB="SERVICE CONNECTED PERCENTAGE",DIFLD=.302 + S DE(DW)="C26^DVBHCE26" + S X=+$G(DVBDXPCT) + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +C26 G C26S:$D(DE(26))[0 K DB + D ^DVBHCE27 +C26S S X="" G:DG(DQ)=X C26F1 K DB + D ^DVBHCE28 +C26F1 Q +X26 S DFN=DA D EV^DGLOCK Q:'$D(X) K:+X'=X!(X>100)!(X<0)!(X?.E1"."1N.N) X I $D(X),$D(^DPT(DA,.3)),$P(^(.3),U,1)'="Y" W !?4,*7,"Only applies to service-connected applicants." K X + Q + ; +27 D:$D(DG)>9 F^DIE17 G ^DVBHCE29 diff --git a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE27.m b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE27.m index 2098ca87..a2038cad 100644 --- a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE27.m +++ b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE27.m @@ -1,246 +1,12 @@ -DVBHCE27 ; ;12/13/08 - D DE G BEGIN -DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))="" - I $D(^(.3)) S %Z=^(.3) S %=$P(%Z,U,2) S:%]"" DE(1)=% S %=$P(%Z,U,14) S:%]"" DE(2)=% - I $D(^(.362)) S %Z=^(.362) S %=$P(%Z,U,8) S:%]"" DE(28)=% S %=$P(%Z,U,9) S:%]"" DE(34)=% S %=$P(%Z,U,15) S:%]"" DE(16)=% S %=$P(%Z,U,18) S:%]"" DE(22)=% - K %Z Q +DVBHCE27 ; ;12/27/07 + S X=DE(26),DIC=DIE ; -W W !?DL+DL-2,DLB_": " - Q -O D W W Y W:$X>45 !?9 - I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 - W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q -TR R X:DTIME E S (DTOUT,X)=U W $C(7) - Q -A K DQ(DQ) S DQ=DQ+1 -B G @DQ -RE G PR:$D(DE(DQ)) D W,TR -N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A -RD G QS:X?."?" I X["^" D D G ^DIE17 - I X="@" D D G Z^DIE2 - I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X -T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V - K DDER G X -P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 - G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z - I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X -V D @("X"_DQ) K YS -Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A -X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 - S X="?BAD" -QS S DZ=X D D,QQ^DIEQ G B -D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q -Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N -PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP -R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R - I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R - X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% -RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 -I I DV'["I",DV'["#" G RD - D E^DIE0 G RD:$D(X),PR - Q -SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 - I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 - D ^DIR I 'DDER S %=Y(0),X=Y - Q -SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) - I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" - E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") - Q -NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS -KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") -BEGIN S DNM="DVBHCE27",DQ=1 -1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".3;2",DV="NJ3,0Xa",DU="",DLB="SERVICE CONNECTED PERCENTAGE",DIFLD=.302 - S DE(DW)="C1^DVBHCE27" - S X=+$G(DVBDXPCT) - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -C1 G C1S:$D(DE(1))[0 K DB - S X=DE(1),DIC=DIE - ; - S X=DE(1),DIC=DIE + S X=DE(26),DIC=DIE D AUTOUPD^DGENA2(DA) - S X=DE(1),DIC=DIE + S X=DE(26),DIC=DIE ; - S X=DE(1),DIC=DIE + S X=DE(26),DIC=DIE I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".302;" D AVAFC^VAFCDD01(DA) - S X=DE(1),DIC=DIE + S X=DE(26),DIC=DIE D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) - S X=DE(1),DIIX=2_U_DIFLD D AUDIT^DIET -C1S S X="" G:DG(DQ)=X C1F1 K DB - S X=DG(DQ),DIC=DIE - ; - S X=DG(DQ),DIC=DIE - D AUTOUPD^DGENA2(DA) - S X=DG(DQ),DIC=DIE - X "S DFN=DA D EN^DGMTR K DGREQF" - S X=DG(DQ),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".302;" D AVAFC^VAFCDD01(DA) - S X=DG(DQ),DIC=DIE - D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) - I $D(DE(1))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET -C1F1 Q -X1 S DFN=DA D EV^DGLOCK Q:'$D(X) K:+X'=X!(X>100)!(X<0)!(X?.E1"."1N.N) X I $D(X),$D(^DPT(DA,.3)),$P(^(.3),U,1)'="Y" W !?4,*7,"Only applies to service-connected applicants." K X - Q - ; -2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW=".3;14",DV="DX",DU="",DLB="EFF. DATE COMBINED SC% EVAL.",DIFLD=.3014 - S X=$G(DVBEFF) - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -X2 S %DT="P" D ^%DT S X=Y K:Y<1!(Y>DT) X - Q - ; -3 S DQ=4 ;@46 -4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X4 S JP=$O(DVBDX(JP)) I 'JP S Y="@50" - Q -5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X5 S JPP=+$P(DVBDX(JP),U,2) I JPP'>0 S Y="@46" - Q -6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X6 I '$D(^DIC(31,JPP)) D CHKDIS^DVBHS3 S Y="@46" - Q -7 S D=0 K DE(1) ;.3721 - S DIFLD=.3721,DGO="^DVBHCE28",DC="6^2.04P^.372^",DV="2.04MP31'X",DW="0;1",DOW="RATED DISABILITIES (VA)",DLB="Select "_DOW S:D DC=DC_D - S DU="DIC(31," - G RE:D I $D(DSC(2.04))#2,$P(DSC(2.04),"I $D(^UTILITY(",1)="" X DSC(2.04) S D=$O(^(0)) S:D="" D=-1 G M7 - S D=$S($D(^DPT(DA,.372,0)):$P(^(0),U,3,4),$O(^(0))'="":$O(^(0)),1:-1) -M7 I D>0 S DC=DC_D I $D(^DPT(DA,.372,+D,0)) S DE(7)=$P(^(0),U,1) - S X="""`"_$P(DVBDX(JP),U,2)_"""" - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -R7 D DE - G A - ; -8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X8 W "." S DVBJ2=1 - Q -9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X9 S Y="@46" - Q -10 S DQ=11 ;@61 -11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X11 S Y="@4" - Q -12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X12 I Z2'[1 S Y="@62" - Q -13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X13 I '$D(DVBSSA) S Y="@62",JP=JP+1 - Q -14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X14 I DVBSSA S DVBYN="Y",DVBXYN=DVBSSA - Q -15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X15 I 'DVBSSA S DVBYN="N",DVBXYN="" - Q -16 S DW=".362;15",DV="SX",DU="",DLB="RECEIVING SOCIAL SECURITY?",DIFLD=.36225 - S DE(DW)="C16^DVBHCE27" - S DU="Y:YES;N:NO;U:UNKNOWN;" - S X=DVBYN - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -C16 G C16S:$D(DE(16))[0 K DB - S X=DE(16),DIC=DIE - X ^DD(2,.36225,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" X ^DD(2,.36225,1,1,2.4) -C16S S X="" G:DG(DQ)=X C16F1 K DB - S X=DG(DQ),DIC=DIE - X ^DD(2,.36225,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" X ^DD(2,.36225,1,1,1.4) -C16F1 Q -X16 S DFN=DA D MV^DGLOCK Q - Q - ; -17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X17 W "." S JP=JP+1,DVBJ2=1 K DVBYN,DVBXYN - Q -18 S DQ=19 ;@62 -19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X19 I Z2'[2 S Y="@63" - Q -20 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=20 D X20 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X20 I '$D(DVBRETT) S Y="@63",JP=JP+1 - Q -21 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=21 D X21 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X21 I DVBRETT=""!("BMCROX"'[DVBRETT) S Y="@63",JP=JP+1 - Q -22 D:$D(DG)>9 F^DIE17,DE S DQ=22,DW=".362;18",DV="SX",DU="",DLB="TYPE OF OTHER RETIREMENT",DIFLD=.36285 - S DU="B:BLACK LUNG;M:MILITARY;C:CIVIL;R:RAILROAD;O:OTHER;X:COMBINATIONS OF TYPES;" - S X=DVBRETT - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -X22 S DFN=DA D MV^DGLOCK Q - Q - ; -23 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=23 D X23 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X23 W "." S JP=JP+1,DVBJ2=1 - Q -24 S DQ=25 ;@63 -25 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=25 D X25 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X25 I Z2'[3 S Y="@64" - Q -26 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=26 D X26 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X26 I '$D(DVBRETO) S Y="@64",JP=JP+1 - Q -27 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=27 D X27 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X27 S X=DVBRETO I X=""!(X=0) S X="@" - Q -28 S DW=".362;8",DV="NJ8,2X",DU="",DLB="AMOUNT OF OTHER RETIREMENT",DIFLD=.3628 - S X=X - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -X28 D DOL^DGLOCK2 K:+X'=X&(X'?.N1"."2N)!(X>99999)!(X<1) X I $D(X) S DFN=DA D MV^DGLOCK - Q - ; -29 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=29 D X29 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X29 W "." S JP=JP+1,DVBJ2=1 - Q -30 S DQ=31 ;@64 -31 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=31 D X31 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X31 I Z2'[4 S Y="@1006" - Q -32 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=32 D X32 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X32 I '$D(DVBOINC) S Y="@1006",JP=JP+1 - Q -33 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=33 D X33 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X33 S X=DVBOINC I X=""!(X=0) S X="@" - Q -34 S DW=".362;9",DV="NJ8,2X",DU="",DLB="AMOUNT OF OTHER INCOME",DIFLD=.3629 - S X=X - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -X34 D DOL^DGLOCK2 K:+X'=X&(X'?.N1"."2N)!(X>999999)!(X<1) X - Q - ; -35 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=35 D X35 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X35 W "." S JP=JP+1,DVBJ2=1,Y="@1006" - Q -36 S DQ=37 ;@4 -37 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=37 D X37 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X37 S Y=$S(DVBJS=11:"@1",DVBJS=28:"@2",DVBJS=35:"@3",DVBJS=44:"@104",1:"@10") - Q -38 S DQ=39 ;@70 -39 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=39 D X39 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X39 W !!,*7,"HINQ contains SC disabilities, Patient is NSC no updating allowed. Check patient's SERVICE CONNECTION, ELIGIBILITY CODE, VET STATUS, or PATIENT TYPE. Screen 5 contains this." - Q -40 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=40 D X40 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X40 R !!,?25," to continue.",ZZ:DTIME K ZZ,JP3,JP4 - Q -41 S DQ=42 ;@50 -42 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=42 D X42 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X42 K DVBJX,JP,JPP S Y=$S(DVBJS=28:"@1",DVBJS=35:"@2",1:"@10") - Q -43 S DQ=44 ;@10 -44 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=44 D X44 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X44 I $G(DVBRADL)]"" D DX^DVBHQEDT(DVBRADL) - Q -45 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=45 D X45 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X45 K DVBRADL - Q -46 G 0^DIE17 + S X=DE(26),DIIX=2_U_DIFLD D AUDIT^DIET diff --git a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE28.m b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE28.m index beec25d8..d940e91f 100644 --- a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE28.m +++ b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE28.m @@ -1,144 +1,12 @@ -DVBHCE28 ; ;12/13/08 - D DE G BEGIN -DE S DIE="^DPT(D0,.372,",DIC=DIE,DP=2.04,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DPT(D0,.372,DA,""))="" - I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,2) S:%]"" DE(1)=% S %=$P(%Z,U,3) S:%]"" DE(2)=% S %=$P(%Z,U,4) S:%]"" DE(3)=% S %=$P(%Z,U,5) S:%]"" DE(4)=% S %=$P(%Z,U,6) S:%]"" DE(5)=% - K %Z Q - ; -W W !?DL+DL-2,DLB_": " - Q -O D W W Y W:$X>45 !?9 - I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 - W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q -TR R X:DTIME E S (DTOUT,X)=U W $C(7) - Q -A K DQ(DQ) S DQ=DQ+1 -B G @DQ -RE G PR:$D(DE(DQ)) D W,TR -N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A -RD G QS:X?."?" I X["^" D D G ^DIE17 - I X="@" D D G Z^DIE2 - I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X -T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V - K DDER G X -P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 - G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z - I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X -V D @("X"_DQ) K YS -Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A -X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 - S X="?BAD" -QS S DZ=X D D,QQ^DIEQ G B -D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q -Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N -PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP -R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R - I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R - X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% -RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 -I I DV'["I",DV'["#" G RD - D E^DIE0 G RD:$D(X),PR - Q -SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 - I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 - D ^DIR I 'DDER S %=Y(0),X=Y - Q -SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) - I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" - E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") - Q -NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS -KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") -BEGIN S DNM="DVBHCE28",DQ=1 -1 S DW="0;2",DV="RNJ3,0X",DU="",DLB="DISABILITY %",DIFLD=2 - S DE(DW)="C1^DVBHCE28",DE(DW,"INDEX")=1 - S X=$S($P(DVBDX(JP),U,3)="X0":100,1:+$P(DVBDX(JP),U,3)) - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -C1 G C1S:$D(DE(1))[0 K DB - S X=DE(1),DIC=DIE - D EVENT^IVMPLOG($G(DA(1))) -C1S S X="" G:DG(DQ)=X C1F1 K DB +DVBHCE28 ; ;12/27/07 S X=DG(DQ),DIC=DIE - D EVENT^IVMPLOG($G(DA(1))) -C1F1 N X,X1,X2 S DIXR=411 D C1X1(U) K X2 M X2=X D C1X1("O") K X1 M X1=X - D - . N DIEXARR M DIEXARR=X S DIEZCOND=1 - . I (X1(1)'=X2(1))!(X1(2)'=X2(2))!(X1(3)'=X2(3)) - . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND - . S DGRDCHG=1 - K X M X=X2 D - . N DIEXARR M DIEXARR=X S DIEZCOND=1 - . I (X1(1)'=X2(1))!(X1(2)'=X2(2))!(X1(3)'=X2(3)) - . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND - . S DGRDCHG=1 - G C1F2 -C1X1(DION) K X - S X(1)=$G(@DIEZTMP@("V",2.04,DIIENS,.01,DION),$P($G(^DPT(DA(1),.372,DA,0)),U,1)) - S X(2)=$G(@DIEZTMP@("V",2.04,DIIENS,2,DION),$P($G(^DPT(DA(1),.372,DA,0)),U,2)) - S X(3)=$G(@DIEZTMP@("V",2.04,DIIENS,3,DION),$P($G(^DPT(DA(1),.372,DA,0)),U,3)) - S X=$G(X(1)) - Q -C1F2 Q -X1 K:+X'=X!(X>100)!(X<0)!(X?.E1"."1N.N) X I $D(X) D EK^DGLOCK - Q ; -2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW="0;3",DV="SX",DU="",DLB="SERVICE CONNECTED",DIFLD=3 - S DE(DW)="C2^DVBHCE28",DE(DW,"INDEX")=1 - S DU="0:NO;1:YES;" - S X=1 - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -C2 G C2S:$D(DE(2))[0 K DB - S X=DE(2),DIC=DIE - D EVENT^IVMPLOG($G(DA(1))) -C2S S X="" G:DG(DQ)=X C2F1 K DB S X=DG(DQ),DIC=DIE - D EVENT^IVMPLOG($G(DA(1))) -C2F1 N X,X1,X2 S DIXR=411 D C2X1(U) K X2 M X2=X D C2X1("O") K X1 M X1=X - D - . N DIEXARR M DIEXARR=X S DIEZCOND=1 - . I (X1(1)'=X2(1))!(X1(2)'=X2(2))!(X1(3)'=X2(3)) - . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND - . S DGRDCHG=1 - K X M X=X2 D - . N DIEXARR M DIEXARR=X S DIEZCOND=1 - . I (X1(1)'=X2(1))!(X1(2)'=X2(2))!(X1(3)'=X2(3)) - . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND - . S DGRDCHG=1 - G C2F2 -C2X1(DION) K X - S X(1)=$G(@DIEZTMP@("V",2.04,DIIENS,.01,DION),$P($G(^DPT(DA(1),.372,DA,0)),U,1)) - S X(2)=$G(@DIEZTMP@("V",2.04,DIIENS,2,DION),$P($G(^DPT(DA(1),.372,DA,0)),U,2)) - S X(3)=$G(@DIEZTMP@("V",2.04,DIIENS,3,DION),$P($G(^DPT(DA(1),.372,DA,0)),U,3)) - S X=$G(X(1)) - Q -C2F2 Q -X2 S DFN=DA(1) D:X SC^DGLOCK1 I $D(X) D EK^DGLOCK - Q - ; -3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW="0;4",DV="S",DU="",DLB="EXTREMITY AFFECTED",DIFLD=4 - S DU="BL:BOTH LOWER;BU:BOTH UPPER;RL:RIGHT LOWER;RU:RIGHT UPPER;LL:LEFT LOWER;LU:LEFT UPPER;" - S X=$P($G(DVBDX(JP)),U,4) - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -X3 Q -4 S DW="0;5",DV="DX",DU="",DLB="ORIGINAL EFFECTIVE DATE",DIFLD=5 - S X=$P($G(DVBDX(JP)),U,5) - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -X4 S %DT="" D ^%DT S X=Y K:Y<1!(Y>DT) X - Q - ; -5 S DW="0;6",DV="DX",DU="",DLB="CURRENT EFFECTIVE DATE",DIFLD=6 - S X=$P($G(DVBDX(JP)),U,6) - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -X5 S %DT="" D ^%DT S X=Y K:Y<1!(Y>DT) X - Q - ; -6 G 1^DIE17 + D AUTOUPD^DGENA2(DA) + S X=DG(DQ),DIC=DIE + X "S DFN=DA D EN^DGMTR K DGREQF" + S X=DG(DQ),DIC=DIE + I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".302;" D AVAFC^VAFCDD01(DA) + S X=DG(DQ),DIC=DIE + D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) + I $D(DE(26))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET diff --git a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE29.m b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE29.m index 7f65e011..25251fb4 100644 --- a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE29.m +++ b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE29.m @@ -1,54 +1,179 @@ -DVBHCE29 ; ;12/13/08 - ;; -1 N X,X1,X2 S DIXR=303 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X - K X M X=X2 D - . N DIEZCOND,DIEXARR M DIEXARR=X S DIEZCOND=1 - . I '$P($G(^DPT(DA,.52)),"^",15) S X=$$CVELIG^DGCV(DA) - . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND - . D SETCV^DGCV(DA,X2(1)) +DVBHCE29 ; ;12/27/07 + D DE G BEGIN +DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))="" + I $D(^(.3)) S %Z=^(.3) S %=$P(%Z,U,14) S:%]"" DE(1)=% + I $D(^(.362)) S %Z=^(.362) S %=$P(%Z,U,8) S:%]"" DE(27)=% S %=$P(%Z,U,15) S:%]"" DE(15)=% S %=$P(%Z,U,18) S:%]"" DE(21)=% + K %Z Q + ; +W W !?DL+DL-2,DLB_": " Q -X1(DION) K X - S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.327,DION),$P($G(^DPT(DA,.32)),U,7)) - S X(2)=$G(@DIEZTMP@("V",2,DIIENS,.5294,DION),$P($G(^DPT(DA,.52)),U,14)) - S X(3)=$G(@DIEZTMP@("V",2,DIIENS,.322021,DION),$P($G(^DPT(DA,.322)),U,21)) - S X(4)=$G(@DIEZTMP@("V",2,DIIENS,.322018,DION),$P($G(^DPT(DA,.322)),U,18)) - S X(5)=$G(@DIEZTMP@("V",2,DIIENS,.322012,DION),$P($G(^DPT(DA,.322)),U,12)) - S X(6)=$G(@DIEZTMP@("V",2,DIIENS,.5291,DION),$P($G(^DPT(DA,.52)),U,11)) - S X(7)=$G(@DIEZTMP@("V",2,DIIENS,.322019,DION),$P($G(^DPT(DA,.322)),U,19)) - S X(8)=$G(@DIEZTMP@("V",2,DIIENS,.322016,DION),$P($G(^DPT(DA,.322)),U,16)) - S X(9)=$G(@DIEZTMP@("V",2,DIIENS,.32201,DION),$P($G(^DPT(DA,.322)),U,10)) - S X=$G(X(1)) +O D W W Y W:$X>45 !?9 + I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 + W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q +TR R X:DTIME E S (DTOUT,X)=U W $C(7) Q -2 N X,X1,X2 S DIXR=648 D X2(U) K X2 M X2=X D X2("F") K X1 M X1=X - D - . D KSERV^DGSRVICE(.X,.DA,"LAST") - K X M X=X2 D - . D SSERV^DGSRVICE(.X,.DA,"LAST") +A K DQ(DQ) S DQ=DQ+1 +B G @DQ +RE G PR:$D(DE(DQ)) D W,TR +N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A +RD G QS:X?."?" I X["^" D D G ^DIE17 + I X="@" D D G Z^DIE2 + I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X +T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V + K DDER G X +P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 + G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z + I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X +V D @("X"_DQ) K YS +Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A +X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 + S X="?BAD" +QS S DZ=X D D,QQ^DIEQ G B +D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q +Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N +PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP +R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R + I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R + X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% +RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 +I I DV'["I",DV'["#" G RD + D E^DIE0 G RD:$D(X),PR Q -X2(DION) K X - S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.326,DION),$P($G(^DPT(DA,.32)),U,6)) - S X(2)=$G(@DIEZTMP@("V",2,DIIENS,.327,DION),$P($G(^DPT(DA,.32)),U,7)) - S X=$G(X(1)) +SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 + I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 + D ^DIR I 'DDER S %=Y(0),X=Y Q -3 N X,X1,X2 S DIXR=649 D X3(U) K X2 M X2=X D X3("F") K X1 M X1=X - D - . D KSERV^DGSRVICE(.X,.DA,"NTL") - K X M X=X2 D - . D SSERV^DGSRVICE(.X,.DA,"NTL") +SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) + I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" + E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") Q -X3(DION) K X - S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.3292,DION),$P($G(^DPT(DA,.32)),U,11)) - S X(2)=$G(@DIEZTMP@("V",2,DIIENS,.3293,DION),$P($G(^DPT(DA,.32)),U,12)) - S X=$G(X(1)) +NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS +KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") +BEGIN S DNM="DVBHCE29",DQ=1 +1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".3;14",DV="DX",DU="",DLB="EFF. DATE COMBINED SC% EVAL.",DIFLD=.3014 + S X=$G(DVBEFF) + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +X1 S %DT="P" D ^%DT S X=Y K:Y<1!(Y>DT) X Q -4 N X,X1,X2 S DIXR=663 D X4(U) K X2 M X2=X D X4("F") K X1 M X1=X - D - . D KSERV^DGSRVICE(.X,.DA,"NNTL") - K X M X=X2 D - . D SSERV^DGSRVICE(.X,.DA,"NNTL") + ; +2 S DQ=3 ;@46 +3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X3 S JP=$O(DVBDX(JP)) I 'JP S Y="@50" Q -X4(DION) K X - S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.3297,DION),$P($G(^DPT(DA,.32)),U,16)) - S X(2)=$G(@DIEZTMP@("V",2,DIIENS,.3298,DION),$P($G(^DPT(DA,.32)),U,17)) - S X=$G(X(1)) +4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X4 S JPP=+$P(DVBDX(JP),U,2) I JPP'>0 S Y="@46" Q +5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X5 I '$D(^DIC(31,JPP)) D CHKDIS^DVBHS3 S Y="@46" + Q +6 S D=0 K DE(1) ;.3721 + S DIFLD=.3721,DGO="^DVBHCE30",DC="6^2.04P^.372^",DV="2.04MP31'X",DW="0;1",DOW="RATED DISABILITIES (VA)",DLB="Select "_DOW S:D DC=DC_D + S DU="DIC(31," + G RE:D I $D(DSC(2.04))#2,$P(DSC(2.04),"I $D(^UTILITY(",1)="" X DSC(2.04) S D=$O(^(0)) S:D="" D=-1 G M6 + S D=$S($D(^DPT(DA,.372,0)):$P(^(0),U,3,4),$O(^(0))'="":$O(^(0)),1:-1) +M6 I D>0 S DC=DC_D I $D(^DPT(DA,.372,+D,0)) S DE(6)=$P(^(0),U,1) + S X="""`"_$P(DVBDX(JP),U,2)_"""" + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +R6 D DE + G A + ; +7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X7 W "." S DVBJ2=1 + Q +8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X8 S Y="@46" + Q +9 S DQ=10 ;@61 +10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X10 S Y="@4" + Q +11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X11 I Z2'[1 S Y="@62" + Q +12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X12 I '$D(DVBSSA) S Y="@62",JP=JP+1 + Q +13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X13 I DVBSSA S DVBYN="Y",DVBXYN=DVBSSA + Q +14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X14 I 'DVBSSA S DVBYN="N",DVBXYN="" + Q +15 S DW=".362;15",DV="SX",DU="",DLB="RECEIVING SOCIAL SECURITY?",DIFLD=.36225 + S DE(DW)="C15^DVBHCE29" + S DU="Y:YES;N:NO;U:UNKNOWN;" + S X=DVBYN + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +C15 G C15S:$D(DE(15))[0 K DB + S X=DE(15),DIC=DIE + X ^DD(2,.36225,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" X ^DD(2,.36225,1,1,2.4) +C15S S X="" G:DG(DQ)=X C15F1 K DB + S X=DG(DQ),DIC=DIE + X ^DD(2,.36225,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" X ^DD(2,.36225,1,1,1.4) +C15F1 Q +X15 S DFN=DA D MV^DGLOCK Q + Q + ; +16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X16 W "." S JP=JP+1,DVBJ2=1 K DVBYN,DVBXYN + Q +17 S DQ=18 ;@62 +18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X18 I Z2'[2 S Y="@63" + Q +19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X19 I '$D(DVBRETT) S Y="@63",JP=JP+1 + Q +20 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=20 D X20 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X20 I DVBRETT=""!("BMCROX"'[DVBRETT) S Y="@63",JP=JP+1 + Q +21 D:$D(DG)>9 F^DIE17,DE S DQ=21,DW=".362;18",DV="SX",DU="",DLB="TYPE OF OTHER RETIREMENT",DIFLD=.36285 + S DU="B:BLACK LUNG;M:MILITARY;C:CIVIL;R:RAILROAD;O:OTHER;X:COMBINATIONS OF TYPES;" + S X=DVBRETT + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +X21 S DFN=DA D MV^DGLOCK Q + Q + ; +22 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=22 D X22 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X22 W "." S JP=JP+1,DVBJ2=1 + Q +23 S DQ=24 ;@63 +24 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=24 D X24 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X24 I Z2'[3 S Y="@64" + Q +25 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=25 D X25 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X25 I '$D(DVBRETO) S Y="@64",JP=JP+1 + Q +26 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=26 D X26 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X26 S X=DVBRETO I X=""!(X=0) S X="@" + Q +27 S DW=".362;8",DV="NJ8,2X",DU="",DLB="AMOUNT OF OTHER RETIREMENT",DIFLD=.3628 + S X=X + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +X27 D DOL^DGLOCK2 K:+X'=X&(X'?.N1"."2N)!(X>99999)!(X<1) X I $D(X) S DFN=DA D MV^DGLOCK + Q + ; +28 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=28 D X28 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X28 W "." S JP=JP+1,DVBJ2=1 + Q +29 S DQ=30 ;@64 +30 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=30 D X30 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X30 I Z2'[4 S Y="@1006" + Q +31 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=31 D X31 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X31 I '$D(DVBOINC) S Y="@1006",JP=JP+1 + Q +32 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=32 D X32 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X32 S X=DVBOINC I X=""!(X=0) S X="@" + Q +33 D:$D(DG)>9 F^DIE17 G ^DVBHCE31 diff --git a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE3.m b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE3.m index 6eb1feac..19d32eaf 100644 --- a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE3.m +++ b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE3.m @@ -1,5 +1,200 @@ -DVBHCE3 ; ;12/13/08 +DVBHCE3 ; ;12/27/07 + D DE G BEGIN +DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))="" + I $D(^(.32)) S %Z=^(.32) S %=$P(%Z,U,9) S:%]"" DE(6)=% S %=$P(%Z,U,10) S:%]"" DE(5)=% S %=$P(%Z,U,11) S:%]"" DE(3)=% S %=$P(%Z,U,12) S:%]"" DE(4)=% S %=$P(%Z,U,13) S:%]"" DE(7)=% S %=$P(%Z,U,19) S:%]"" DE(1)=% S %=$P(%Z,U,20) S:%]"" DE(13)=% + K %Z Q + ; +W W !?DL+DL-2,DLB_": " + Q +O D W W Y W:$X>45 !?9 + I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 + W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q +TR R X:DTIME E S (DTOUT,X)=U W $C(7) + Q +A K DQ(DQ) S DQ=DQ+1 +B G @DQ +RE G PR:$D(DE(DQ)) D W,TR +N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A +RD G QS:X?."?" I X["^" D D G ^DIE17 + I X="@" D D G Z^DIE2 + I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X +T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V + K DDER G X +P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 + G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z + I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X +V D @("X"_DQ) K YS +Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A +X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 + S X="?BAD" +QS S DZ=X D D,QQ^DIEQ G B +D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q +Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N +PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP +R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R + I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R + X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% +RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 +I I DV'["I",DV'["#" G RD + D E^DIE0 G RD:$D(X),PR + Q +SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 + I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 + D ^DIR I 'DDER S %=Y(0),X=Y + Q +SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) + I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" + E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") + Q +NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS +KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") +BEGIN S DNM="DVBHCE3",DQ=1 +1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".32;19",DV="RSX",DU="",DLB="Service NTL Episode",DIFLD=.3285 + S DE(DW)="C1^DVBHCE3" + S DU="Y:YES;N:NO;" + G RE +C1 G C1S:$D(DE(1))[0 K DB + S X=DE(1),DIC=DIE + ; + S X=DE(1),DIC=DIE + ; + S X=DE(1),DIC=DIE + X ^DD(2,.3285,1,3,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.32)):^(.32),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X="" S DIH=$G(^DPT(DIV(0),.32)),DIV=X S $P(^(.32),U,10)=DIV,DIH=2,DIG=.3291 D ^DICR +C1S S X="" G:DG(DQ)=X C1F1 K DB + S X=DG(DQ),DIC=DIE + X "I X'=""Y"" S DGXRF=.3285 D ^DGDDC Q" + S X=DG(DQ),DIC=DIE + X ^DD(2,.3285,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.32)):^(.32),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X=DIV S X="N" X ^DD(2,.3285,1,2,1.4) + S X=DG(DQ),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$C(59)_$P($G(^DD(2,.3285,0)),U,3) S X=$P($P(Y(1),$C(59)_Y(0)_":",2),$C(59))'="YES" I X S X=DIV S Y(1)=$S($D(^DPT(D0,.32)):^(.32),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X="" X ^DD(2,.3285,1,3,1.4) +C1F1 Q +X1 S DFN=DA D SV^DGLOCK + Q + ; +2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X2 I $P(^DPT(D0,.32),U,19)'="Y" S Y="@31" + Q +3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW=".32;11",DV="RDX",DU="",DLB="NTL-EOD",DIFLD=.3292 + S DE(DW)="C3^DVBHCE3",DE(DW,"INDEX")=1 + G RE +C3 G C3S:$D(DE(3))[0 K DB + S X=DE(3),DIC=DIE + ; + S X=DE(3),DIC=DIE + D EVENT^IVMPLOG(DA) +C3S S X="" G:DG(DQ)=X C3F1 K DB S X=DG(DQ),DIC=DIE ; S X=DG(DQ),DIC=DIE D EVENT^IVMPLOG(DA) +C3F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE))) + F DIXR=649 S DIEZRXR(2,DIXR)="" + Q +X3 S %DT="E",%DT(0)=-DT D ^%DT K %DT S X=Y K:Y<1 X I $D(X) S DFN=DA D SER1^DGLOCK I $D(X) K:'$$VALMSE^DGRPMS(DFN,X,0,"MSNTL") X I $D(X) S DGFRDT=X I $D(^DG(43,1)) S SD1=2 D POS^DGINP + Q + ; +4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW=".32;12",DV="RDX",DU="",DLB="NTL-RAD",DIFLD=.3293 + S DE(DW)="C4^DVBHCE3",DE(DW,"INDEX")=1 + G RE +C4 G C4S:$D(DE(4))[0 K DB + S X=DE(4),DIC=DIE + D EVENT^IVMPLOG(DA) +C4S S X="" G:DG(DQ)=X C4F1 K DB + S X=DG(DQ),DIC=DIE + D EVENT^IVMPLOG(DA) +C4F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE))) + F DIXR=649 S DIEZRXR(2,DIXR)="" + Q +X4 S %DT="E",%DT(0)=-DT D ^%DT K %DT S X=Y K:Y<1 X I $D(X) S DFN=DA D SER1^DGLOCK I $D(X) K:'$$VALMSE^DGRPMS(DFN,X,1,"MSNTL") X I $D(X),$D(^DG(43,1)) S SD1=2 D PS^DGINP + Q + ; +5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW=".32;10",DV="P23'X",DU="",DLB="NTL-Bran. Ser.",DIFLD=.3291 + S DE(DW)="C5^DVBHCE3",DE(DW,"INDEX")=1 + S DU="DIC(23," + G RE +C5 G C5S:$D(DE(5))[0 K DB + S X=DE(5),DIC=DIE + I $P($G(^DPT(DA,.321)),U,14)]"" D FVP^DGRPMS + S X=DE(5),DIC=DIE + D EVENT^IVMPLOG(DA) + S X=DE(5),DIC=DIE + X "S DGXRF=.3291 D ^DGDDC Q" +C5S S X="" G:DG(DQ)=X C5F1 K DB + S X=DG(DQ),DIC=DIE + ; + S X=DG(DQ),DIC=DIE + D EVENT^IVMPLOG(DA) + S X=DG(DQ),DIC=DIE + ; +C5F1 N X,X1,X2 S DIXR=409 D C5X1(U) K X2 M X2=X D C5X1("O") K X1 M X1=X + D + . N DIEXARR M DIEXARR=X S DIEZCOND=1 + . S X=X2(1)="" + . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND + . D DELMSE^DGRPMS(DA,2) + G C5F2 +C5X1(DION) K X + S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.3291,DION),$P($G(^DPT(DA,.32)),U,10)) + S X=$G(X(1)) + Q +C5F2 Q +X5 S DFN=DA K:X=$O(^DIC(23,"B","B.E.C.","")) X I $D(X) D SER1^DGLOCK S DGCOMBR=$G(Y) Q + Q + ; +6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW=".32;9",DV="RP25'X",DU="",DLB="NTL-Char. Ser.",DIFLD=.329 + S DE(DW)="C6^DVBHCE3" + S DU="DIC(25," + G RE +C6 G C6S:$D(DE(6))[0 K DB + S X=DE(6),DIC=DIE + D EVENT^IVMPLOG(DA) +C6S S X="" G:DG(DQ)=X C6F1 K DB + S X=DG(DQ),DIC=DIE + D EVENT^IVMPLOG(DA) +C6F1 Q +X6 S DFN=DA D SER1^DGLOCK + Q + ; +7 D:$D(DG)>9 F^DIE17,DE S DQ=7,DW=".32;13",DV="FX",DU="",DLB="NTL-Ser. Num.",DIFLD=.3294 + S DE(DW)="C7^DVBHCE3" + G RE +C7 G C7S:$D(DE(7))[0 K DB + S X=DE(7),DIC=DIE + D EVENT^IVMPLOG(DA) +C7S S X="" G:DG(DQ)=X C7F1 K DB + S X=DG(DQ),DIC=DIE + D EVENT^IVMPLOG(DA) +C7F1 Q +X7 S DFN=DA D SER1^DGLOCK I $D(X) S:X?1"SS".E L=$S($D(^DPT(DA,0)):$P(^(0),U,9),1:X) W:X?1"SS".E " ",L S:X?1"SS".E X=L K:$L(X)>15!($L(X)<1)!'(X?.N) X + I $D(X),X'?.ANP K X + Q + ; +8 S DQ=9 ;@31 +9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X9 I Z2'[3 S Y="@33" + Q +10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X10 I '$D(^DPT(D0,.32)) W !!,*7,?17,DVBON,"No NTLast episode can't edit NNTLast ",DVBOFF X DVBLIT1 R DVBZ:DTIME K DVBZ S Y="@33" + Q +11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X11 I $P(^DPT(D0,.32),U,19)'="Y" W !!,*7,?17,DVBON,"No NTLast episode can't edit NNTLast .",DVBOFF X DVBLIT1 R DVBZ:DTIME K DVBZ S Y="@33" + Q +12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X12 S DVBSCR=1 D ^DVBHS4 W !,?34,DVBON,"[NNTLAST]",DVBOFF X DVBLIT1 + Q +13 D:$D(DG)>9 F^DIE17,DE S DQ=13,DW=".32;20",DV="RSX",DU="",DLB="Service NNTL Episode",DIFLD=.32945 + S DE(DW)="C13^DVBHCE3" + S DU="Y:YES;N:NO;" + G RE +C13 G C13S:$D(DE(13))[0 K DB + D ^DVBHCE4 +C13S S X="" G:DG(DQ)=X C13F1 K DB + D ^DVBHCE5 +C13F1 Q +X13 S DFN=DA D SV^DGLOCK I "N"'[$G(X),$D(^DPT(DFN,.32)),$P(^(.32),U,19)'="Y" W !?4,*7,"Other Periods of service are not indicated...NO EDITING!" K X + Q + ; +14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X14 I $P(^DPT(D0,.32),U,20)'="Y" S Y="@33" + Q +15 D:$D(DG)>9 F^DIE17 G ^DVBHCE6 diff --git a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE4.m b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE4.m index fdbae264..90715190 100644 --- a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE4.m +++ b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE4.m @@ -1,265 +1,5 @@ -DVBHCE4 ; ;12/13/08 - D DE G BEGIN -DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))="" - I $D(^(.32)) S %Z=^(.32) S %=$P(%Z,U,9) S:%]"" DE(3)=% S %=$P(%Z,U,10) S:%]"" DE(2)=% S %=$P(%Z,U,12) S:%]"" DE(1)=% S %=$P(%Z,U,13) S:%]"" DE(4)=% S %=$P(%Z,U,14) S:%]"" DE(15)=% S %=$P(%Z,U,15) S:%]"" DE(14)=% S %=$P(%Z,U,16) S:%]"" DE(12)=% - I S %=$P(%Z,U,17) S:%]"" DE(13)=% S %=$P(%Z,U,18) S:%]"" DE(16)=% S %=$P(%Z,U,20) S:%]"" DE(10)=% - K %Z Q - ; -W W !?DL+DL-2,DLB_": " - Q -O D W W Y W:$X>45 !?9 - I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 - W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q -TR R X:DTIME E S (DTOUT,X)=U W $C(7) - Q -A K DQ(DQ) S DQ=DQ+1 -B G @DQ -RE G PR:$D(DE(DQ)) D W,TR -N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A -RD G QS:X?."?" I X["^" D D G ^DIE17 - I X="@" D D G Z^DIE2 - I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X -T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V - K DDER G X -P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 - G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z - I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X -V D @("X"_DQ) K YS -Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A -X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 - S X="?BAD" -QS S DZ=X D D,QQ^DIEQ G B -D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q -Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N -PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP -R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R - I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R - X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% -RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 -I I DV'["I",DV'["#" G RD - D E^DIE0 G RD:$D(X),PR - Q -SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 - I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 - D ^DIR I 'DDER S %=Y(0),X=Y - Q -SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) - I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" - E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") - Q -NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS -KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") -BEGIN S DNM="DVBHCE4",DQ=1 -1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".32;12",DV="RDX",DU="",DLB="NTL-RAD",DIFLD=.3293 - S DE(DW)="C1^DVBHCE4",DE(DW,"INDEX")=1 - G RE -C1 G C1S:$D(DE(1))[0 K DB - S X=DE(1),DIC=DIE - D EVENT^IVMPLOG(DA) -C1S S X="" G:DG(DQ)=X C1F1 K DB - S X=DG(DQ),DIC=DIE - D EVENT^IVMPLOG(DA) -C1F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE))) - F DIXR=649 S DIEZRXR(2,DIXR)="" - Q -X1 S %DT="E",%DT(0)=-DT D ^%DT K %DT S X=Y K:Y<1 X I $D(X) S DFN=DA D SER1^DGLOCK I $D(X) K:'$$VALMSE^DGRPMS(DFN,X,1,"MSNTL") X I $D(X),$D(^DG(43,1)) S SD1=2 D PS^DGINP - Q - ; -2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW=".32;10",DV="P23'X",DU="",DLB="NTL-Bran. Ser.",DIFLD=.3291 - S DE(DW)="C2^DVBHCE4",DE(DW,"INDEX")=1 - S DU="DIC(23," - G RE -C2 G C2S:$D(DE(2))[0 K DB - S X=DE(2),DIC=DIE - I $P($G(^DPT(DA,.321)),U,14)]"" D FVP^DGRPMS - S X=DE(2),DIC=DIE - D EVENT^IVMPLOG(DA) - S X=DE(2),DIC=DIE - X "S DGXRF=.3291 D ^DGDDC Q" -C2S S X="" G:DG(DQ)=X C2F1 K DB - S X=DG(DQ),DIC=DIE - ; - S X=DG(DQ),DIC=DIE - D EVENT^IVMPLOG(DA) - S X=DG(DQ),DIC=DIE - ; -C2F1 N X,X1,X2 S DIXR=409 D C2X1(U) K X2 M X2=X D C2X1("O") K X1 M X1=X - D - . N DIEXARR M DIEXARR=X S DIEZCOND=1 - . S X=X2(1)="" - . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND - . D DELMSE^DGRPMS(DA,2) - G C2F2 -C2X1(DION) K X - S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.3291,DION),$P($G(^DPT(DA,.32)),U,10)) - S X=$G(X(1)) - Q -C2F2 Q -X2 S DFN=DA K:X=$O(^DIC(23,"B","B.E.C.","")) X I $D(X) D SER1^DGLOCK S DGCOMBR=$G(Y) Q - Q - ; -3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW=".32;9",DV="RP25'X",DU="",DLB="NTL-Char. Ser.",DIFLD=.329 - S DE(DW)="C3^DVBHCE4" - S DU="DIC(25," - G RE -C3 G C3S:$D(DE(3))[0 K DB - S X=DE(3),DIC=DIE - D EVENT^IVMPLOG(DA) -C3S S X="" G:DG(DQ)=X C3F1 K DB - S X=DG(DQ),DIC=DIE - D EVENT^IVMPLOG(DA) -C3F1 Q -X3 S DFN=DA D SER1^DGLOCK - Q - ; -4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW=".32;13",DV="FX",DU="",DLB="NTL-Ser. Num.",DIFLD=.3294 - S DE(DW)="C4^DVBHCE4" - G RE -C4 G C4S:$D(DE(4))[0 K DB - S X=DE(4),DIC=DIE - D EVENT^IVMPLOG(DA) -C4S S X="" G:DG(DQ)=X C4F1 K DB - S X=DG(DQ),DIC=DIE - D EVENT^IVMPLOG(DA) -C4F1 Q -X4 S DFN=DA D SER1^DGLOCK I $D(X) S:X?1"SS".E L=$S($D(^DPT(DA,0)):$P(^(0),U,9),1:X) W:X?1"SS".E " ",L S:X?1"SS".E X=L K:$L(X)>15!($L(X)<1)!'(X?.N) X - I $D(X),X'?.ANP K X - Q - ; -5 S DQ=6 ;@31 -6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X6 I Z2'[3 S Y="@33" - Q -7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X7 I '$D(^DPT(D0,.32)) W !!,*7,?17,DVBON,"No NTLast episode can't edit NNTLast ",DVBOFF X DVBLIT1 R DVBZ:DTIME K DVBZ S Y="@33" - Q -8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X8 I $P(^DPT(D0,.32),U,19)'="Y" W !!,*7,?17,DVBON,"No NTLast episode can't edit NNTLast .",DVBOFF X DVBLIT1 R DVBZ:DTIME K DVBZ S Y="@33" - Q -9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X9 S DVBSCR=1 D ^DVBHS4 W !,?34,DVBON,"[NNTLAST]",DVBOFF X DVBLIT1 - Q -10 D:$D(DG)>9 F^DIE17,DE S DQ=10,DW=".32;20",DV="RSX",DU="",DLB="Service NNTL Episode",DIFLD=.32945 - S DE(DW)="C10^DVBHCE4" - S DU="Y:YES;N:NO;" - G RE -C10 G C10S:$D(DE(10))[0 K DB - S X=DE(10),DIC=DIE - ; - S X=DE(10),DIC=DIE - X ^DD(2,.32945,1,2,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.32)):^(.32),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X="" S DIH=$G(^DPT(DIV(0),.32)),DIV=X S $P(^(.32),U,15)=DIV,DIH=2,DIG=.3296 D ^DICR -C10S S X="" G:DG(DQ)=X C10F1 K DB - S X=DG(DQ),DIC=DIE - X "I X'=""Y"" S DGXRF=.32945 D ^DGDDC Q" - S X=DG(DQ),DIC=DIE - X ^DD(2,.32945,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.32)):^(.32),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X="" S DIH=$G(^DPT(DIV(0),.32)),DIV=X S $P(^(.32),U,15)=DIV,DIH=2,DIG=.3296 D ^DICR -C10F1 Q -X10 S DFN=DA D SV^DGLOCK I "N"'[$G(X),$D(^DPT(DFN,.32)),$P(^(.32),U,19)'="Y" W !?4,*7,"Other Periods of service are not indicated...NO EDITING!" K X - Q - ; -11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X11 I $P(^DPT(D0,.32),U,20)'="Y" S Y="@33" - Q -12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW=".32;16",DV="RDX",DU="",DLB="NNTL-EOD",DIFLD=.3297 - S DE(DW)="C12^DVBHCE4",DE(DW,"INDEX")=1 - G RE -C12 G C12S:$D(DE(12))[0 K DB - S X=DE(12),DIC=DIE - D EVENT^IVMPLOG(DA) -C12S S X="" G:DG(DQ)=X C12F1 K DB - S X=DG(DQ),DIC=DIE - D EVENT^IVMPLOG(DA) -C12F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE))) - F DIXR=663 S DIEZRXR(2,DIXR)="" - Q -X12 S %DT="E",%DT(0)=-DT D ^%DT K %DT S X=Y K:Y<1 X I $D(X) S DFN=DA D SER2^DGLOCK I $D(X) K:'$$VALMSE^DGRPMS(DFN,X,0,"MSNNTL") X I $D(X) S DGFRDT=X I $D(^DG(43,1)) S SD1=3 D POS^DGINP - Q - ; -13 D:$D(DG)>9 F^DIE17,DE S DQ=13,DW=".32;17",DV="RDX",DU="",DLB="NNTL-RAD",DIFLD=.3298 - S DE(DW)="C13^DVBHCE4",DE(DW,"INDEX")=1 - G RE -C13 G C13S:$D(DE(13))[0 K DB +DVBHCE4 ; ;12/27/07 S X=DE(13),DIC=DIE - D EVENT^IVMPLOG(DA) -C13S S X="" G:DG(DQ)=X C13F1 K DB - S X=DG(DQ),DIC=DIE - D EVENT^IVMPLOG(DA) -C13F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE))) - F DIXR=663 S DIEZRXR(2,DIXR)="" - Q -X13 S %DT="E",%DT(0)=-DT D ^%DT K %DT S X=Y K:Y<1 X I $D(X) S DFN=DA D SER2^DGLOCK I $D(X) K:'$$VALMSE^DGRPMS(DFN,X,1,"MSNNTL") X I $D(X),$D(^DG(43,1)) S SD1=3 D PS^DGINP - Q ; -14 D:$D(DG)>9 F^DIE17,DE S DQ=14,DW=".32;15",DV="P23'X",DU="",DLB="NNTL-Bran. Ser.",DIFLD=.3296 - S DE(DW)="C14^DVBHCE4",DE(DW,"INDEX")=1 - S DU="DIC(23," - G RE -C14 G C14S:$D(DE(14))[0 K DB - S X=DE(14),DIC=DIE - I $P($G(^DPT(DA,.321)),U,14)]"" D FVP^DGRPMS - S X=DE(14),DIC=DIE - D EVENT^IVMPLOG(DA) - S X=DE(14),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.3291)):^(.3291),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" S DIH=$G(^DPT(DIV(0),.3291)),DIV=X S $P(^(.3291),U,3)=DIV,DIH=2,DIG=.32913 D ^DICR - S X=DE(14),DIC=DIE - X "S DGXRF=.3296 D ^DGDDC Q" -C14S S X="" G:DG(DQ)=X C14F1 K DB - S X=DG(DQ),DIC=DIE - ; - S X=DG(DQ),DIC=DIE - D EVENT^IVMPLOG(DA) - S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.3291)):^(.3291),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" S DIH=$G(^DPT(DIV(0),.3291)),DIV=X S $P(^(.3291),U,3)=DIV,DIH=2,DIG=.32913 D ^DICR - S X=DG(DQ),DIC=DIE - ; -C14F1 N X,X1,X2 S DIXR=410 D C14X1(U) K X2 M X2=X D C14X1("O") K X1 M X1=X - D - . N DIEXARR M DIEXARR=X S DIEZCOND=1 - . S X=X2(1)="" - . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND - . D DELMSE^DGRPMS(DA,3) - G C14F2 -C14X1(DION) K X - S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.3296,DION),$P($G(^DPT(DA,.32)),U,15)) - S X=$G(X(1)) - Q -C14F2 Q -X14 S DFN=DA K:X=$O(^DIC(23,"B","B.E.C.","")) X I $D(X) D SER2^DGLOCK S DGCOMBR=$G(Y) Q - Q - ; -15 D:$D(DG)>9 F^DIE17,DE S DQ=15,DW=".32;14",DV="RP25'X",DU="",DLB="NNTL-Char. Ser.",DIFLD=.3295 - S DE(DW)="C15^DVBHCE4" - S DU="DIC(25," - G RE -C15 G C15S:$D(DE(15))[0 K DB - S X=DE(15),DIC=DIE - D EVENT^IVMPLOG(DA) -C15S S X="" G:DG(DQ)=X C15F1 K DB - D ^DVBHCE5 -C15F1 Q -X15 S DFN=DA D SER2^DGLOCK - Q - ; -16 D:$D(DG)>9 F^DIE17,DE S DQ=16,DW=".32;18",DV="FX",DU="",DLB="NNTL-Ser. Num.",DIFLD=.3299 - S DE(DW)="C16^DVBHCE4" - G RE -C16 G C16S:$D(DE(16))[0 K DB - D ^DVBHCE6 -C16S S X="" G:DG(DQ)=X C16F1 K DB - D ^DVBHCE7 -C16F1 Q -X16 S DFN=DA D SER2^DGLOCK I $D(X) S:X?1"SS".E L=$S($D(^DPT(DA,0)):$P(^(0),U,9),1:X) W:X?1"SS".E " ",L S:X?1"SS".E X=L K:$L(X)>15!($L(X)<1)!'(X?.N) X - I $D(X),X'?.ANP K X - Q - ; -17 S DQ=18 ;@33 -18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X18 I Z2'[4 S Y="@3" - Q -19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X19 S DVBSCR=1 D ^DVBHS4 - Q -20 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=20 D X20 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X20 S DVBJC2=$S($D(^DPT(D0,.32)):$P(^(.32),U,3),1:"") - Q -21 D:$D(DG)>9 F^DIE17 G ^DVBHCE8 + S X=DE(13),DIC=DIE + X ^DD(2,.32945,1,2,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.32)):^(.32),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X="" S DIH=$G(^DPT(DIV(0),.32)),DIV=X S $P(^(.32),U,15)=DIV,DIH=2,DIG=.3296 D ^DICR diff --git a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE5.m b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE5.m index 9172a6ce..368c9de2 100644 --- a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE5.m +++ b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE5.m @@ -1,3 +1,5 @@ -DVBHCE5 ; ;12/13/08 +DVBHCE5 ; ;12/27/07 S X=DG(DQ),DIC=DIE - D EVENT^IVMPLOG(DA) + X "I X'=""Y"" S DGXRF=.32945 D ^DGDDC Q" + S X=DG(DQ),DIC=DIE + X ^DD(2,.32945,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.32)):^(.32),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X="" S DIH=$G(^DPT(DIV(0),.32)),DIV=X S $P(^(.32),U,15)=DIV,DIH=2,DIG=.3296 D ^DICR diff --git a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE6.m b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE6.m index 80f32fe1..39193572 100644 --- a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE6.m +++ b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE6.m @@ -1,3 +1,205 @@ -DVBHCE6 ; ;12/13/08 - S X=DE(16),DIC=DIE +DVBHCE6 ; ;12/27/07 + D DE G BEGIN +DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))="" + I $D(^(.32)) S %Z=^(.32) S %=$P(%Z,U,3) S:%]"" DE(10)=% S %=$P(%Z,U,14) S:%]"" DE(4)=% S %=$P(%Z,U,15) S:%]"" DE(3)=% S %=$P(%Z,U,16) S:%]"" DE(1)=% S %=$P(%Z,U,17) S:%]"" DE(2)=% S %=$P(%Z,U,18) S:%]"" DE(5)=% + K %Z Q + ; +W W !?DL+DL-2,DLB_": " + Q +O D W W Y W:$X>45 !?9 + I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 + W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q +TR R X:DTIME E S (DTOUT,X)=U W $C(7) + Q +A K DQ(DQ) S DQ=DQ+1 +B G @DQ +RE G PR:$D(DE(DQ)) D W,TR +N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A +RD G QS:X?."?" I X["^" D D G ^DIE17 + I X="@" D D G Z^DIE2 + I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X +T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V + K DDER G X +P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 + G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z + I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X +V D @("X"_DQ) K YS +Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A +X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 + S X="?BAD" +QS S DZ=X D D,QQ^DIEQ G B +D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q +Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N +PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP +R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R + I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R + X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% +RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 +I I DV'["I",DV'["#" G RD + D E^DIE0 G RD:$D(X),PR + Q +SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 + I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 + D ^DIR I 'DDER S %=Y(0),X=Y + Q +SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) + I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" + E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") + Q +NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS +KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") +BEGIN S DNM="DVBHCE6",DQ=1 +1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".32;16",DV="RDX",DU="",DLB="NNTL-EOD",DIFLD=.3297 + S DE(DW)="C1^DVBHCE6",DE(DW,"INDEX")=1 + G RE +C1 G C1S:$D(DE(1))[0 K DB + S X=DE(1),DIC=DIE D EVENT^IVMPLOG(DA) +C1S S X="" G:DG(DQ)=X C1F1 K DB + S X=DG(DQ),DIC=DIE + D EVENT^IVMPLOG(DA) +C1F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE))) + F DIXR=663 S DIEZRXR(2,DIXR)="" + Q +X1 S %DT="E",%DT(0)=-DT D ^%DT K %DT S X=Y K:Y<1 X I $D(X) S DFN=DA D SER2^DGLOCK I $D(X) K:'$$VALMSE^DGRPMS(DFN,X,0,"MSNNTL") X I $D(X) S DGFRDT=X I $D(^DG(43,1)) S SD1=3 D POS^DGINP + Q + ; +2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW=".32;17",DV="RDX",DU="",DLB="NNTL-RAD",DIFLD=.3298 + S DE(DW)="C2^DVBHCE6",DE(DW,"INDEX")=1 + G RE +C2 G C2S:$D(DE(2))[0 K DB + S X=DE(2),DIC=DIE + D EVENT^IVMPLOG(DA) +C2S S X="" G:DG(DQ)=X C2F1 K DB + S X=DG(DQ),DIC=DIE + D EVENT^IVMPLOG(DA) +C2F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE))) + F DIXR=663 S DIEZRXR(2,DIXR)="" + Q +X2 S %DT="E",%DT(0)=-DT D ^%DT K %DT S X=Y K:Y<1 X I $D(X) S DFN=DA D SER2^DGLOCK I $D(X) K:'$$VALMSE^DGRPMS(DFN,X,1,"MSNNTL") X I $D(X),$D(^DG(43,1)) S SD1=3 D PS^DGINP + Q + ; +3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW=".32;15",DV="P23'X",DU="",DLB="NNTL-Bran. Ser.",DIFLD=.3296 + S DE(DW)="C3^DVBHCE6",DE(DW,"INDEX")=1 + S DU="DIC(23," + G RE +C3 G C3S:$D(DE(3))[0 K DB + S X=DE(3),DIC=DIE + I $P($G(^DPT(DA,.321)),U,14)]"" D FVP^DGRPMS + S X=DE(3),DIC=DIE + D EVENT^IVMPLOG(DA) + S X=DE(3),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.3291)):^(.3291),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" S DIH=$G(^DPT(DIV(0),.3291)),DIV=X S $P(^(.3291),U,3)=DIV,DIH=2,DIG=.32913 D ^DICR + S X=DE(3),DIC=DIE + X "S DGXRF=.3296 D ^DGDDC Q" +C3S S X="" G:DG(DQ)=X C3F1 K DB + S X=DG(DQ),DIC=DIE + ; + S X=DG(DQ),DIC=DIE + D EVENT^IVMPLOG(DA) + S X=DG(DQ),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.3291)):^(.3291),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" S DIH=$G(^DPT(DIV(0),.3291)),DIV=X S $P(^(.3291),U,3)=DIV,DIH=2,DIG=.32913 D ^DICR + S X=DG(DQ),DIC=DIE + ; +C3F1 N X,X1,X2 S DIXR=410 D C3X1(U) K X2 M X2=X D C3X1("O") K X1 M X1=X + D + . N DIEXARR M DIEXARR=X S DIEZCOND=1 + . S X=X2(1)="" + . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND + . D DELMSE^DGRPMS(DA,3) + G C3F2 +C3X1(DION) K X + S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.3296,DION),$P($G(^DPT(DA,.32)),U,15)) + S X=$G(X(1)) + Q +C3F2 Q +X3 S DFN=DA K:X=$O(^DIC(23,"B","B.E.C.","")) X I $D(X) D SER2^DGLOCK S DGCOMBR=$G(Y) Q + Q + ; +4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW=".32;14",DV="RP25'X",DU="",DLB="NNTL-Char. Ser.",DIFLD=.3295 + S DE(DW)="C4^DVBHCE6" + S DU="DIC(25," + G RE +C4 G C4S:$D(DE(4))[0 K DB + S X=DE(4),DIC=DIE + D EVENT^IVMPLOG(DA) +C4S S X="" G:DG(DQ)=X C4F1 K DB + S X=DG(DQ),DIC=DIE + D EVENT^IVMPLOG(DA) +C4F1 Q +X4 S DFN=DA D SER2^DGLOCK + Q + ; +5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW=".32;18",DV="FX",DU="",DLB="NNTL-Ser. Num.",DIFLD=.3299 + S DE(DW)="C5^DVBHCE6" + G RE +C5 G C5S:$D(DE(5))[0 K DB + S X=DE(5),DIC=DIE + D EVENT^IVMPLOG(DA) +C5S S X="" G:DG(DQ)=X C5F1 K DB + S X=DG(DQ),DIC=DIE + D EVENT^IVMPLOG(DA) +C5F1 Q +X5 S DFN=DA D SER2^DGLOCK I $D(X) S:X?1"SS".E L=$S($D(^DPT(DA,0)):$P(^(0),U,9),1:X) W:X?1"SS".E " ",L S:X?1"SS".E X=L K:$L(X)>15!($L(X)<1)!'(X?.N) X + I $D(X),X'?.ANP K X + Q + ; +6 S DQ=7 ;@33 +7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X7 I Z2'[4 S Y="@3" + Q +8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X8 S DVBSCR=1 D ^DVBHS4 + Q +9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X9 S DVBJC2=$S($D(^DPT(D0,.32)):$P(^(.32),U,3),1:"") + Q +10 D:$D(DG)>9 F^DIE17,DE S DQ=10,DW=".32;3",DV="*P21'Xa",DU="",DLB="PERIOD OF SERVICE",DIFLD=.323 + S DE(DW)="C10^DVBHCE6" + S DU="DIC(21," + G RE +C10 G C10S:$D(DE(10))[0 K DB + S X=DE(10),DIC=DIE + K ^DPT("APOS",$E(X,1,30),DA) + S X=DE(10),DIC=DIE + ; + S X=DE(10),DIC=DIE + I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".323;" D AVAFC^VAFCDD01(DA) + S X=DE(10),DIC=DIE + D EVENT^IVMPLOG(DA) + S X=DE(10),DIIX=2_U_DIFLD D AUDIT^DIET +C10S S X="" G:DG(DQ)=X C10F1 K DB + S X=DG(DQ),DIC=DIE + S ^DPT("APOS",$E(X,1,30),DA)="" + S X=DG(DQ),DIC=DIE + X ^DD(2,.323,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,"ODS")):^("ODS"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y X ^DD(2,.323,1,2,1.1) X ^DD(2,.323,1,2,1.4) + S X=DG(DQ),DIC=DIE + I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".323;" D AVAFC^VAFCDD01(DA) + S X=DG(DQ),DIC=DIE + D EVENT^IVMPLOG(DA) + I $D(DE(10))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET +C10F1 Q +X10 S DFN=DA D POS^DGLOCK1 + Q + ; +11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X11 I X'=DVBJC2 S DVBJ2=1 + Q +12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X12 K DVBJC2 + Q +13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X13 S Y="@3" + Q +14 S DQ=15 ;@104 +15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X15 D ^DVBHS5 S Y="@5" K DXS + Q +16 S DQ=17 ;@204 +17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X17 I Z2'[1 S Y="@205" + Q +18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X18 S DVBSCR=1 D ^DVBHS5 S DVBJ2=1 + Q +19 D:$D(DG)>9 F^DIE17 G ^DVBHCE7 diff --git a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE7.m b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE7.m index bb5b5c2e..f647b189 100644 --- a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE7.m +++ b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE7.m @@ -1,3 +1,232 @@ -DVBHCE7 ; ;12/13/08 +DVBHCE7 ; ;12/27/07 + D DE G BEGIN +DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))="" + I $D(^(.3)) S %Z=^(.3) S %=$P(%Z,U,1) S:%]"" DE(13)=% S %=$P(%Z,U,6) S:%]"" DE(6)=% + I $D(^(.36)) S %Z=^(.36) S %=$P(%Z,U,1) S:%]"" DE(16)=% + I $D(^(.361)) S %Z=^(.361) S %=$P(%Z,U,1) S:%]"" DE(1)=% S %=$P(%Z,U,2) S:%]"" DE(3)=% S %=$P(%Z,U,5) S:%]"" DE(4)=% + I $D(^("TYPE")) S %Z=^("TYPE") S %=$P(%Z,U,1) S:%]"" DE(11)=% + I $D(^("VET")) S %Z=^("VET") S %=$P(%Z,U,1) S:%]"" DE(12)=% + K %Z Q + ; +W W !?DL+DL-2,DLB_": " + Q +O D W W Y W:$X>45 !?9 + I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 + W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q +TR R X:DTIME E S (DTOUT,X)=U W $C(7) + Q +A K DQ(DQ) S DQ=DQ+1 +B G @DQ +RE G PR:$D(DE(DQ)) D W,TR +N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A +RD G QS:X?."?" I X["^" D D G ^DIE17 + I X="@" D D G Z^DIE2 + I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X +T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V + K DDER G X +P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 + G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z + I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X +V D @("X"_DQ) K YS +Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A +X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 + S X="?BAD" +QS S DZ=X D D,QQ^DIEQ G B +D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q +Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N +PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP +R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R + I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R + X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% +RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 +I I DV'["I",DV'["#" G RD + D E^DIE0 G RD:$D(X),PR + Q +SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 + I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 + D ^DIR I 'DDER S %=Y(0),X=Y + Q +SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) + I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" + E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") + Q +NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS +KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") +BEGIN S DNM="DVBHCE7",DQ=1 +1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".361;1",DV="SX",DU="",DLB="ELIGIBILITY STATUS",DIFLD=.3611 + S DE(DW)="C1^DVBHCE7" + S DU="P:PENDING VERIFICATION;R:PENDING RE-VERIFICATION;V:VERIFIED;" + G RE +C1 G C1S:$D(DE(1))[0 K DB + S X=DE(1),DIC=DIE + ; + S X=DE(1),DIC=DIE + ; + S X=DE(1),DIC=DIE + D EVENT^IVMPLOG(DA) +C1S S X="" G:DG(DQ)=X C1F1 K DB + S X=DG(DQ),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.361)):^(.361),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y X ^DD(2,.3611,1,1,1.1) X ^DD(2,.3611,1,1,1.4) + S X=DG(DQ),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.361)):^(.361),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(2,.3611,1,2,1.4) S X=DG(DQ),DIC=DIE D EVENT^IVMPLOG(DA) +C1F1 Q +X1 D EK^DGLOCK Q:'$D(X) + Q + ; +2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 G A +3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW=".361;2",DV="DX",DU="",DLB="ELIGIBILITY STATUS DATE",DIFLD=.3612 + S DE(DW)="C3^DVBHCE7" + S X="TODAY" + S Y=X + G Y +C3 G C3S:$D(DE(3))[0 K DB + S X=DE(3),DIC=DIE + ; + S X=DE(3),DIC=DIE + D EVENT^IVMPLOG(DA) +C3S S X="" G:DG(DQ)=X C3F1 K DB + S X=DG(DQ),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.361)):^(.361),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X=DIV S X=$S(($D(DUZ)#2):DUZ,1:"") X ^DD(2,.3612,1,1,1.4) + S X=DG(DQ),DIC=DIE + D EVENT^IVMPLOG(DA) +C3F1 Q +X3 S %DT="E",%DT(0)=-DT D ^%DT K %DT S X=Y K:Y<1 X I $D(X) D EK^DGLOCK + Q + ; +4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW=".361;5",DV="FX",DU="",DLB="ELIGIBILITY VERIF. METHOD",DIFLD=.3615 + S DE(DW)="C4^DVBHCE7" + S X="HINQ" + S Y=X + G Y +C4 G C4S:$D(DE(4))[0 K DB + S X=DE(4),DIC=DIE + D EVENT^IVMPLOG(DA) +C4S S X="" G:DG(DQ)=X C4F1 K DB + S X=DG(DQ),DIC=DIE + D EVENT^IVMPLOG(DA) +C4F1 Q +X4 K:$L(X)>50!($L(X)<2) X I $D(X) D EK^DGLOCK + I $D(X),X'?.ANP K X + Q + ; +5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 G A +6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW=".3;6",DV="DX",DU="",DLB="MONETARY BEN. VERIFY DATE",DIFLD=.306 + S X="TODAY" + S Y=X + G Y +X6 S %DT="E",%DT(0)=-DT D ^%DT K %DT S X=Y K:Y<1 X I $D(X) D EK^DGLOCK + Q + ; +7 S D=0 K DE(1) ;361 + S DIFLD=361,DGO="^DVBHCE8",DC="3^2.0361IP^E^",DV="2.0361M*P8'X",DW="0;1",DOW="ELIGIBILITY",DLB="Select "_DOW S:D DC=DC_D + S DU="DIC(8," + G RE:D I $D(DSC(2.0361))#2,$P(DSC(2.0361),"I $D(^UTILITY(",1)="" X DSC(2.0361) S D=$O(^(0)) S:D="" D=-1 G M7 + S D=$S($D(^DPT(DA,"E",0)):$P(^(0),U,3,4),$O(^(0))'="":$O(^(0)),1:-1) +M7 I D>0 S DC=DC_D I $D(^DPT(DA,"E",+D,0)) S DE(7)=$P(^(0),U,1) + G RE +R7 D DE + S D=$S($D(^DPT(DA,"E",0)):$P(^(0),U,3,4),1:1) G 7+1 + ; +8 S DQ=9 ;@205 +9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X9 I Z2'[2 S Y="@206" + Q +10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X10 S DVBSCR=1 D ^DVBHS5 S DVBJ2=1 + Q +11 S DW="TYPE;1",DV="RP391'a",DU="",DLB="TYPE",DIFLD=391 + S DE(DW)="C11^DVBHCE7",DE(DW,"INDEX")=1 + S DU="DG(391," + G RE +C11 G C11S:$D(DE(11))[0 K DB + S X=DE(11),DIC=DIE + I ($T(AVAFC^VAFCDD01)'="") S VAFCF="391;" D AVAFC^VAFCDD01(DA) + S X=DE(11),DIIX=2_U_DIFLD D AUDIT^DIET +C11S S X="" G:DG(DQ)=X C11F1 K DB + S X=DG(DQ),DIC=DIE + I ($T(AVAFC^VAFCDD01)'="") S VAFCF="391;" D AVAFC^VAFCDD01(DA) + I $D(DE(11))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET +C11F1 N X,X1,X2 S DIXR=664 D C11X1(U) K X2 M X2=X D C11X1("O") K X1 M X1=X + I $G(X(1))]"" D + . K ^DPT("APTYPE",X,DA) + K X M X=X2 I $G(X(1))]"" D + . S ^DPT("APTYPE",X,DA)="" + G C11F2 +C11X1(DION) K X + S X(1)=$G(@DIEZTMP@("V",2,DIIENS,391,DION),$P($G(^DPT(DA,"TYPE")),U,1)) + S X=$G(X(1)) + Q +C11F2 Q +X11 Q +12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW="VET;1",DV="RSXa",DU="",DLB="VETERAN (Y/N)?",DIFLD=1901 + S DE(DW)="C12^DVBHCE7" + S DU="Y:YES;N:NO;" + G RE +C12 G C12S:$D(DE(12))[0 K DB + S X=DE(12),DIC=DIE + S DFN=DA D EN^DGMTCOR K DGMTCOR + S X=DE(12),DIC=DIE + S DFN=DA D EN^DGRP7CC + S X=DE(12),DIC=DIE + ; + S X=DE(12),DIC=DIE + D AUTOUPD^DGENA2(DA) + S X=DE(12),DIC=DIE + I ($T(AVAFC^VAFCDD01)'="") S VAFCF="1901;" D AVAFC^VAFCDD01(DA) + S X=DE(12),DIC=DIE + D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) + S X=DE(12),DIIX=2_U_DIFLD D AUDIT^DIET +C12S S X="" G:DG(DQ)=X C12F1 K DB + D ^DVBHCE9 +C12F1 Q +X12 I $D(X) S:'$D(DPTX) DFN=DA D:'$D(^XUSEC("DG ELIGIBILITY",DUZ)) VAGE^DGLOCK:X="Y" I $D(X) D:$D(DFN) EV^DGLOCK + Q + ; +13 D:$D(DG)>9 F^DIE17,DE S DQ=13,DW=".3;1",DV="RSXa",DU="",DLB="SERVICE CONNECTED?",DIFLD=.301 + S DE(DW)="C13^DVBHCE7" + S DU="Y:YES;N:NO;" + G RE +C13 G C13S:$D(DE(13))[0 K DB + S X=DE(13),DIC=DIE + ; + S X=DE(13),DIC=DIE + ; + S X=DE(13),DIC=DIE + D AUTOUPD^DGENA2(DA) + S X=DE(13),DIC=DIE + I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".301;" D AVAFC^VAFCDD01(DA) + S X=DE(13),DIC=DIE + D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) + S X=DE(13),DIIX=2_U_DIFLD D AUDIT^DIET +C13S S X="" G:DG(DQ)=X C13F1 K DB + D ^DVBHCE10 +C13F1 Q +X13 S DFN=DA D EV^DGLOCK I $D(X),X="Y" D VET^DGLOCK + Q + ; +14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X14 I X="N" S Y="@2063" + Q +15 S DQ=16 ;@2063 +16 D:$D(DG)>9 F^DIE17,DE S DQ=16,DW=".36;1",DV="*P8'Xa",DU="",DLB="PRIMARY ELIGIBILITY CODE",DIFLD=.361 + S DE(DW)="C16^DVBHCE7" + S DU="DIC(8," + G RE +C16 G C16S:$D(DE(16))[0 K DB + D ^DVBHCE11 +C16S S X="" G:DG(DQ)=X C16F1 K DB + D ^DVBHCE12 +C16F1 Q +X16 S DFN=DA D EV^DGLOCK I $D(X) D ECD^DGLOCK1 + Q + ; +17 S DQ=18 ;@206 +18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X18 I Z2'[3 S Y="@104" + Q +19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X19 S DVBSCR=1 D ^DVBHS5 S DVBJ2=1 + Q +20 D:$D(DG)>9 F^DIE17 G ^DVBHCE13 diff --git a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE8.m b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE8.m index d8ef577f..cff1f776 100644 --- a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE8.m +++ b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE8.m @@ -1,12 +1,7 @@ -DVBHCE8 ; ;12/13/08 +DVBHCE8 ; ;12/27/07 D DE G BEGIN -DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))="" - I $D(^(.3)) S %Z=^(.3) S %=$P(%Z,U,1) S:%]"" DE(22)=% S %=$P(%Z,U,6) S:%]"" DE(15)=% - I $D(^(.32)) S %Z=^(.32) S %=$P(%Z,U,3) S:%]"" DE(1)=% - I $D(^(.36)) S %Z=^(.36) S %=$P(%Z,U,1) S:%]"" DE(25)=% - I $D(^(.361)) S %Z=^(.361) S %=$P(%Z,U,1) S:%]"" DE(10)=% S %=$P(%Z,U,2) S:%]"" DE(12)=% S %=$P(%Z,U,5) S:%]"" DE(13)=% - I $D(^("TYPE")) S %Z=^("TYPE") S %=$P(%Z,U,1) S:%]"" DE(20)=% - I $D(^("VET")) S %Z=^("VET") S %=$P(%Z,U,1) S:%]"" DE(21)=% +DE S DIE="^DPT(D0,""E"",",DIC=DIE,DP=2.0361,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DPT(D0,"E",DA,""))="" + I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% K %Z Q ; W W !?DL+DL-2,DLB_": " @@ -53,229 +48,35 @@ SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$ Q NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") -BEGIN S DNM="DVBHCE8",DQ=1 -1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".32;3",DV="*P21'Xa",DU="",DLB="PERIOD OF SERVICE",DIFLD=.323 +BEGIN S DNM="DVBHCE8",DQ=1+D G B +1 S DW="0;1",DV="M*P8'X#",DU="",DLB="ELIGIBILITY",DIFLD=.01 S DE(DW)="C1^DVBHCE8" - S DU="DIC(21," - G RE + S DU="DIC(8," + G RE:'D S DQ=2 G 2 C1 G C1S:$D(DE(1))[0 K DB S X=DE(1),DIC=DIE - K ^DPT("APOS",$E(X,1,30),DA) + K ^DPT(DA(1),"E","B",$E(X,1,30),DA) S X=DE(1),DIC=DIE - ; + K ^DPT("AEL",DA(1),+X) S X=DE(1),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".323;" D AVAFC^VAFCDD01(DA) + D E32^VADPT62 S X=DE(1),DIC=DIE - D EVENT^IVMPLOG(DA) - S X=DE(1),DIIX=2_U_DIFLD D AUDIT^DIET + X "S DFN=DA(1) D EN^DGMTR K DGREQF" + S X=DE(1),DIC=DIE + D AUTOUPD^DGENA2(DA(1)) C1S S X="" G:DG(DQ)=X C1F1 K DB S X=DG(DQ),DIC=DIE - S ^DPT("APOS",$E(X,1,30),DA)="" + S ^DPT(DA(1),"E","B",$E(X,1,30),DA)="" S X=DG(DQ),DIC=DIE - X ^DD(2,.323,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,"ODS")):^("ODS"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y X ^DD(2,.323,1,2,1.1) X ^DD(2,.323,1,2,1.4) + S ^DPT("AEL",DA(1),+X)="" S X=DG(DQ),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".323;" D AVAFC^VAFCDD01(DA) + D E31^VADPT62 S X=DG(DQ),DIC=DIE - D EVENT^IVMPLOG(DA) - I $D(DE(1))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET + X "S DFN=DA(1) D EN^DGMTR K DGREQF" + S X=DG(DQ),DIC=DIE + D AUTOUPD^DGENA2(DA(1)) C1F1 Q -X1 S DFN=DA D POS^DGLOCK1 +X1 S DIC("S")="I '$P(^(0),U,7),$S($P(^(0),U,8):1,'$D(^DPT(D0,.36)):0,1:Y=+^(.36)),$$ELGCHK^DGRPTU(D0)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X I $D(X) S DINUM=X Q ; -2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X2 I X'=DVBJC2 S DVBJ2=1 - Q -3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X3 K DVBJC2 - Q -4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X4 S Y="@3" - Q -5 S DQ=6 ;@104 -6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X6 D ^DVBHS5 S Y="@5" K DXS - Q -7 S DQ=8 ;@204 -8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X8 I Z2'[1 S Y="@205" - Q -9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X9 S DVBSCR=1 D ^DVBHS5 S DVBJ2=1 - Q -10 D:$D(DG)>9 F^DIE17,DE S DQ=10,DW=".361;1",DV="SX",DU="",DLB="ELIGIBILITY STATUS",DIFLD=.3611 - S DE(DW)="C10^DVBHCE8" - S DU="P:PENDING VERIFICATION;R:PENDING RE-VERIFICATION;V:VERIFIED;" - G RE -C10 G C10S:$D(DE(10))[0 K DB - S X=DE(10),DIC=DIE - ; - S X=DE(10),DIC=DIE - ; - S X=DE(10),DIC=DIE - D EVENT^IVMPLOG(DA) -C10S S X="" G:DG(DQ)=X C10F1 K DB - S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.361)):^(.361),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y X ^DD(2,.3611,1,1,1.1) X ^DD(2,.3611,1,1,1.4) - S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.361)):^(.361),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(2,.3611,1,2,1.4) - S X=DG(DQ),DIC=DIE - D EVENT^IVMPLOG(DA) -C10F1 Q -X10 D EK^DGLOCK Q:'$D(X) - Q - ; -11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 G A -12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW=".361;2",DV="DX",DU="",DLB="ELIGIBILITY STATUS DATE",DIFLD=.3612 - S DE(DW)="C12^DVBHCE8" - S X="TODAY" - S Y=X - G Y -C12 G C12S:$D(DE(12))[0 K DB - S X=DE(12),DIC=DIE - ; - S X=DE(12),DIC=DIE - D EVENT^IVMPLOG(DA) -C12S S X="" G:DG(DQ)=X C12F1 K DB - S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.361)):^(.361),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X=DIV S X=$S(($D(DUZ)#2):DUZ,1:"") X ^DD(2,.3612,1,1,1.4) - S X=DG(DQ),DIC=DIE - D EVENT^IVMPLOG(DA) -C12F1 Q -X12 S %DT="E",%DT(0)=-DT D ^%DT K %DT S X=Y K:Y<1 X I $D(X) D EK^DGLOCK - Q - ; -13 D:$D(DG)>9 F^DIE17,DE S DQ=13,DW=".361;5",DV="FX",DU="",DLB="ELIGIBILITY VERIF. METHOD",DIFLD=.3615 - S DE(DW)="C13^DVBHCE8" - S X="HINQ" - S Y=X - G Y -C13 G C13S:$D(DE(13))[0 K DB - S X=DE(13),DIC=DIE - D EVENT^IVMPLOG(DA) -C13S S X="" G:DG(DQ)=X C13F1 K DB - S X=DG(DQ),DIC=DIE - D EVENT^IVMPLOG(DA) -C13F1 Q -X13 K:$L(X)>50!($L(X)<2) X I $D(X) D EK^DGLOCK - I $D(X),X'?.ANP K X - Q - ; -14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 G A -15 D:$D(DG)>9 F^DIE17,DE S DQ=15,DW=".3;6",DV="DX",DU="",DLB="MONETARY BEN. VERIFY DATE",DIFLD=.306 - S X="TODAY" - S Y=X - G Y -X15 S %DT="E",%DT(0)=-DT D ^%DT K %DT S X=Y K:Y<1 X I $D(X) D EK^DGLOCK - Q - ; -16 S D=0 K DE(1) ;361 - S DIFLD=361,DGO="^DVBHCE9",DC="3^2.0361IP^E^",DV="2.0361M*P8'X",DW="0;1",DOW="ELIGIBILITY",DLB="Select "_DOW S:D DC=DC_D - S DU="DIC(8," - G RE:D I $D(DSC(2.0361))#2,$P(DSC(2.0361),"I $D(^UTILITY(",1)="" X DSC(2.0361) S D=$O(^(0)) S:D="" D=-1 G M16 - S D=$S($D(^DPT(DA,"E",0)):$P(^(0),U,3,4),$O(^(0))'="":$O(^(0)),1:-1) -M16 I D>0 S DC=DC_D I $D(^DPT(DA,"E",+D,0)) S DE(16)=$P(^(0),U,1) - G RE -R16 D DE - S D=$S($D(^DPT(DA,"E",0)):$P(^(0),U,3,4),1:1) G 16+1 - ; -17 S DQ=18 ;@205 -18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X18 I Z2'[2 S Y="@206" - Q -19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X19 S DVBSCR=1 D ^DVBHS5 S DVBJ2=1 - Q -20 S DW="TYPE;1",DV="P391'a",DU="",DLB="TYPE",DIFLD=391 - S DE(DW)="C20^DVBHCE8",DE(DW,"INDEX")=1 - S DU="DG(391," - G RE -C20 G C20S:$D(DE(20))[0 K DB - S X=DE(20),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF="391;" D AVAFC^VAFCDD01(DA) - S X=DE(20),DIIX=2_U_DIFLD D AUDIT^DIET -C20S S X="" G:DG(DQ)=X C20F1 K DB - S X=DG(DQ),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF="391;" D AVAFC^VAFCDD01(DA) - I $D(DE(20))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET -C20F1 N X,X1,X2 S DIXR=664 D C20X1(U) K X2 M X2=X D C20X1("O") K X1 M X1=X - I $G(X(1))]"" D - . K ^DPT("APTYPE",X,DA) - K X M X=X2 I $G(X(1))]"" D - . S ^DPT("APTYPE",X,DA)="" - G C20F2 -C20X1(DION) K X - S X(1)=$G(@DIEZTMP@("V",2,DIIENS,391,DION),$P($G(^DPT(DA,"TYPE")),U,1)) - S X=$G(X(1)) - Q -C20F2 Q -X20 Q -21 D:$D(DG)>9 F^DIE17,DE S DQ=21,DW="VET;1",DV="SXa",DU="",DLB="VETERAN (Y/N)?",DIFLD=1901 - S DE(DW)="C21^DVBHCE8" - S DU="Y:YES;N:NO;" - G RE -C21 G C21S:$D(DE(21))[0 K DB - S X=DE(21),DIC=DIE - S DFN=DA D EN^DGMTCOR K DGMTCOR - S X=DE(21),DIC=DIE - S DFN=DA D EN^DGRP7CC - S X=DE(21),DIC=DIE - ; - S X=DE(21),DIC=DIE - D AUTOUPD^DGENA2(DA) - S X=DE(21),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF="1901;" D AVAFC^VAFCDD01(DA) - S X=DE(21),DIC=DIE - D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) - S X=DE(21),DIIX=2_U_DIFLD D AUDIT^DIET -C21S S X="" G:DG(DQ)=X C21F1 K DB - D ^DVBHCE10 -C21F1 Q -X21 I $D(X) S:'$D(DPTX) DFN=DA D:'$D(^XUSEC("DG ELIGIBILITY",DUZ)) VAGE^DGLOCK:X="Y" I $D(X) D:$D(DFN) EV^DGLOCK - Q - ; -22 D:$D(DG)>9 F^DIE17,DE S DQ=22,DW=".3;1",DV="SXa",DU="",DLB="SERVICE CONNECTED?",DIFLD=.301 - S DE(DW)="C22^DVBHCE8" - S DU="Y:YES;N:NO;" - G RE -C22 G C22S:$D(DE(22))[0 K DB - S X=DE(22),DIC=DIE - ; - S X=DE(22),DIC=DIE - ; - S X=DE(22),DIC=DIE - D AUTOUPD^DGENA2(DA) - S X=DE(22),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".301;" D AVAFC^VAFCDD01(DA) - S X=DE(22),DIC=DIE - D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) - S X=DE(22),DIIX=2_U_DIFLD D AUDIT^DIET -C22S S X="" G:DG(DQ)=X C22F1 K DB - D ^DVBHCE11 -C22F1 Q -X22 S DFN=DA D EV^DGLOCK I $D(X),X="Y" D VET^DGLOCK - Q - ; -23 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=23 D X23 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X23 I X="N" S Y="@2063" - Q -24 S DQ=25 ;@2063 -25 D:$D(DG)>9 F^DIE17,DE S DQ=25,DW=".36;1",DV="*P8'Xa",DU="",DLB="PRIMARY ELIGIBILITY CODE",DIFLD=.361 - S DE(DW)="C25^DVBHCE8" - S DU="DIC(8," - G RE -C25 G C25S:$D(DE(25))[0 K DB - D ^DVBHCE12 -C25S S X="" G:DG(DQ)=X C25F1 K DB - D ^DVBHCE13 -C25F1 Q -X25 S DFN=DA D EV^DGLOCK I $D(X) D ECD^DGLOCK1 - Q - ; -26 S DQ=27 ;@206 -27 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=27 D X27 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X27 I Z2'[3 S Y="@104" - Q -28 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=28 D X28 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X28 S DVBSCR=1 D ^DVBHS5 S DVBJ2=1 - Q -29 D:$D(DG)>9 F^DIE17 G ^DVBHCE14 +2 G 1^DIE17 diff --git a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE9.m b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE9.m index db2a0f77..d9e55c96 100644 --- a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE9.m +++ b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE9.m @@ -1,82 +1,14 @@ -DVBHCE9 ; ;12/13/08 - D DE G BEGIN -DE S DIE="^DPT(D0,""E"",",DIC=DIE,DP=2.0361,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DPT(D0,"E",DA,""))="" - I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% - K %Z Q - ; -W W !?DL+DL-2,DLB_": " - Q -O D W W Y W:$X>45 !?9 - I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 - W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q -TR R X:DTIME E S (DTOUT,X)=U W $C(7) - Q -A K DQ(DQ) S DQ=DQ+1 -B G @DQ -RE G PR:$D(DE(DQ)) D W,TR -N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A -RD G QS:X?."?" I X["^" D D G ^DIE17 - I X="@" D D G Z^DIE2 - I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X -T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V - K DDER G X -P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 - G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z - I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X -V D @("X"_DQ) K YS -Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A -X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 - S X="?BAD" -QS S DZ=X D D,QQ^DIEQ G B -D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q -Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N -PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP -R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R - I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R - X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% -RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 -I I DV'["I",DV'["#" G RD - D E^DIE0 G RD:$D(X),PR - Q -SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 - I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 - D ^DIR I 'DDER S %=Y(0),X=Y - Q -SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) - I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" - E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") - Q -NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS -KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") -BEGIN S DNM="DVBHCE9",DQ=1+D G B -1 S DW="0;1",DV="M*P8'X#",DU="",DLB="ELIGIBILITY",DIFLD=.01 - S DE(DW)="C1^DVBHCE9" - S DU="DIC(8," - G RE:'D S DQ=2 G 2 -C1 G C1S:$D(DE(1))[0 K DB - S X=DE(1),DIC=DIE - K ^DPT(DA(1),"E","B",$E(X,1,30),DA) - S X=DE(1),DIC=DIE - K ^DPT("AEL",DA(1),+X) - S X=DE(1),DIC=DIE - D E32^VADPT62 - S X=DE(1),DIC=DIE - X "S DFN=DA(1) D EN^DGMTR K DGREQF" - S X=DE(1),DIC=DIE - D AUTOUPD^DGENA2(DA(1)) -C1S S X="" G:DG(DQ)=X C1F1 K DB +DVBHCE9 ; ;12/27/07 S X=DG(DQ),DIC=DIE - S ^DPT(DA(1),"E","B",$E(X,1,30),DA)="" + S DFN=DA D EN^DGMTCOR K DGMTCOR S X=DG(DQ),DIC=DIE - S ^DPT("AEL",DA(1),+X)="" + S DFN=DA D EN^DGRP7CC S X=DG(DQ),DIC=DIE - D E31^VADPT62 + X ^DD(2,1901,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV S X="N" X ^DD(2,1901,1,3,1.4) S X=DG(DQ),DIC=DIE - X "S DFN=DA(1) D EN^DGMTR K DGREQF" + D AUTOUPD^DGENA2(DA) S X=DG(DQ),DIC=DIE - D AUTOUPD^DGENA2(DA(1)) -C1F1 Q -X1 S DIC("S")="I '$P(^(0),U,7),$S($P(^(0),U,8):1,'$D(^DPT(D0,.36)):0,1:Y=+^(.36)),$$ELGCHK^DGRPTU(D0)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X I $D(X) S DINUM=X - Q - ; -2 G 1^DIE17 + I ($T(AVAFC^VAFCDD01)'="") S VAFCF="1901;" D AVAFC^VAFCDD01(DA) + S X=DG(DQ),DIC=DIE + D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) + I $D(DE(12))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET diff --git a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCG.m b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCG.m index 66e3ebff..b40fbae9 100644 --- a/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCG.m +++ b/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCG.m @@ -1,4 +1,4 @@ -DVBHCG ; GENERATED FROM 'DVBHINQ PAT-HINQ COMP' PRINT TEMPLATE (#513) ; 12/13/08 ; (FILE 2, MARGIN=80) +DVBHCG ; GENERATED FROM 'DVBHINQ PAT-HINQ COMP' PRINT TEMPLATE (#513) ; 04/03/06 ; (FILE 2, MARGIN=80) G BEGIN N W ! T W:$X ! I '$D(DIOT(2)),DN,$D(IOSL),$S('$D(DIWF):1,$P(DIWF,"B",2):$P(DIWF,"B",2),1:1)+$Y'0!(PRCFASYS[$P(X,"-",2)),$P(X,"^",10)PRCFA("KDATE")!(+$P(TRANS,U,9)>PRCFA("KDATE")) Q - S J=J+1 W:J#50=0 "." - I $P(ZERO,U,6)'="" K ^PRCF(423,"C",$P(ZERO,U,6),DA) - K:$P(ZERO,U,1)'="" ^PRCF(423,"B",$P(ZERO,U),DA) - K:$P(TRANS,U,5)'="" ^PRCF(423,"AD",$P(TRANS,U,5),DA) - K:$P(TRANS,U,6)]"" ^PRCF(423,"AE",$P(TRANS,U,6),DA) - K:$P(ZLOG,U,24)]"" ^PRCF(423,"D",$P(ZLOG,U,24),DA) - K:$P(ZLOG,U,25)]"" ^PRCF(423,"AN",$P(ZLOG,U,25),DA) - K:$P(ONE,U,29)]"" ^PRCF(423,"AI",$P(ONE,U,29),DA) -K K ONE,ZERO,TRANS,ZLOG,^PRCF(423,"AC","N",DA) - F ZX="AJ","AK","AL","AM" K ^PRCF(423,ZX,"Y",DA) - K ^PRCF(423,DA),ZX S:$P(^PRCF(423,0),"^",4)>0 $P(^(0),U,4)=$P(^(0),U,4)-1 Q - Q +PRCFACPS ;WISC@ALTOONA/CTB/DL-PURGE CODE SHEET CONTINUATION ;1/29/98 1300 +V ;;5.1;IFCAP;;Oct 20, 2000 + ;Per VHA Directive 10-93-142, this routine should not be modified. +DQ ;;PURGE CODE SHEETS AND TRANSMISSION RECORDS + D:$D(ZTQUEUED) KILL^%ZTLOAD + S PRCFNAME=$S(PRCFASYS["CLM":"FEE/FEN",PRCFASYS["ISM":"ISM",PRCFASYS["IRS":"IRS",1:"LOG") + L +^PRCF(423,0):5 I '$T S X="Code Sheet file unavailable - File lock timeout.*" D MSG^PRCFQ Q + W:$D(IOF) @IOF W PRCFNAME_" CODE SHEET & TRANSMISSION RECORD DELETION TRANSCRIPT" D NOW^PRCFQ W ?IOM-$L(%X),%X + S $P(LINE,"-",IOM-2)="" W !,LINE,!!,"Option queued by: ",$S($D(DUZ):$P(^VA(200,DUZ,0),"^"),1:"Menu Manager"),!,"Date/Time queued: ",PRCFA("QTIME"),!,"From Device: ",PRCFA("QION") + W !!!,PRCFNAME_" code sheet deletion has begun for station ",PRC("SITE"),!,"I am deleting all "_PRCFNAME_" code sheets created or transmitted on or before ",PRCFA("DATE"),".",! + S (DA,J)=0,U="^" F K=1:1 S DA=$O(^PRCF(423,DA)) Q:'DA D KILLCS + W !!,"Done - deleted ",J," ",PRCFNAME," code sheets. ",$P(^PRCF(423,0),"^",4)," code sheets remaining." + W !!,"I will now begin cleaning up the Log Transmission Record file.",!,"I will delete all "_PRCFNAME_" batches and transmission records created on or before ",PRCFA("DATE"),! + S (DA,JX)=0,DIK="^PRCF(421.2," F K=1:1 S DA=$O(^PRCF(421.2,DA)) Q:'DA I $D(^(DA,0)) S X=^(0) I +$P(X,"-",2)>0!(PRCFASYS[$P(X,"-",2)),$P(X,"^",10)PRCFA("KDATE")!(+$P(TRANS,U,9)>PRCFA("KDATE")) Q + S J=J+1 W:J#50=0 "." + I $P(ZERO,U,6)'="" K ^PRCF(423,"C",$P(ZERO,U,6),DA) + K:$P(ZERO,U,1)'="" ^PRCF(423,"B",$P(ZERO,U),DA) + K:$P(TRANS,U,5)'="" ^PRCF(423,"AD",$P(TRANS,U,5),DA) + K:$P(TRANS,U,6)]"" ^PRCF(423,"AE",$P(TRANS,U,6),DA) + K:$P(ZLOG,U,24)]"" ^PRCF(423,"D",$P(ZLOG,U,24),DA) + K:$P(ZLOG,U,25)]"" ^PRCF(423,"AN",$P(ZLOG,U,25),DA) + K:$P(ONE,U,29)]"" ^PRCF(423,"AI",$P(ONE,U,29),DA) +K K ONE,ZERO,TRANS,ZLOG,^PRCF(423,"AC","N",DA) + F ZX="AJ","AK","AL","AM" K ^PRCF(423,ZX,"Y",DA) + K ^PRCF(423,DA),ZX S:$P(^PRCF(423,0),"^",4)>0 $P(^(0),U,4)=$P(^(0),U,4)-1 Q + Q diff --git a/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFALOG.m b/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFALOG.m index 52c460c6..c25bc11c 100644 --- a/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFALOG.m +++ b/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFALOG.m @@ -1,40 +1,35 @@ -PRCFALOG ;WISC/CTB-LOG CODE SHEETS ;11-27-92/08:20 -V ;;5.1;IFCAP;**114**;Oct 20, 2000;Build 4 - ;Per VHA Directive 2004-038, this routine should not be modified. -A S PRCHLOG="",PRCFASYS="LOGDLA" Q -B K PRCHLOG,PRCFASYS Q -CCS ;CREATE A CODE SHEET - D A,EN1^PRCFAC,B Q -DCS ;DELETE A CODE SHEET - D A,EN9^PRCFAC2,B Q -ECS ;EDIT A CODE SHEET - D A,EN2^PRCFAC,B Q -EKCS ;EDIT A KEY PUNCHED CODE SHEET - D A,EDIT^PRCFACR4,B Q -KCS ;KEY PUNCH A CODE SHEET - D A,^PRCFACR3,B Q -GRAB ;GRAB A BATCH NUMBER - D A,^PRCFACG,B Q -MBP ;MODIFY PRIORITY OF CODE SHEET WITHIN ITS BATCH - D A,EN1^PRCFAC2,B Q -BATCH ;BATCH AND PRINT CODE SHEETS - D A,EN^PRCFACP,B Q -REPRINT ;REPRINT A BATCH - D A,EN^PRCFAC5,B Q -PURGE ;PURGE CODE SHEETS - D A S PRCFASYS=PRCFASYS_"PHA" D EN^PRCFACPR,B Q -PURGE2 ;PURGE ALL CODE SHEETS - W !!,"** YOU MUST SELECT A DESIGNATED PRINTER FOR PURGE TO FUNCTION PROPERLY." - W !,"** DEFAULTING TO HOME DEVICE (0) WILL NOT PURGE DATA SINCE THE OPTION WILL BE " - W !,"** TASKED.",! - S PRCFASYS="CLMCLIRRLOGDLAPHAGSA" D EN^PRCFACPR,B Q -ADD ;ADD CODE SHEET TO PRINTED BATCH - D A,ADD^PRCFACR2,B Q -DELETE ;DELETE CODE SHEET FROM PRINTED BATCH - D A,REMOV^PRCFACR2,B Q -TRANSMIT ;TRANSMIT CODE SHEETS - D A,SE^PRCFACR,B Q -RETRANS ;RETRANSMIT CODE SHEET BATCH - D A,RT^PRCFACR5,B Q -INQUIRY ;BATCH/TRANSMISSION/RECEIVING REPORT INQUIRY - D A,E14^PRCFAC3,B Q +PRCFALOG ;WISC/CTB-LOG CODE SHEETS ;11-27-92/08:20 +V ;;5.1;IFCAP;;Oct 20, 2000 + ;Per VHA Directive 10-93-142, this routine should not be modified. +A S PRCHLOG="",PRCFASYS="LOGDLA" Q +B K PRCHLOG,PRCFASYS Q +CCS ;CREATE A CODE SHEET + D A,EN1^PRCFAC,B Q +DCS ;DELETE A CODE SHEET + D A,EN9^PRCFAC2,B Q +ECS ;EDIT A CODE SHEET + D A,EN2^PRCFAC,B Q +EKCS ;EDIT A KEY PUNCHED CODE SHEET + D A,EDIT^PRCFACR4,B Q +KCS ;KEY PUNCH A CODE SHEET + D A,^PRCFACR3,B Q +GRAB ;GRAB A BATCH NUMBER + D A,^PRCFACG,B Q +MBP ;MODIFY PRIORITY OF CODE SHEET WITHIN ITS BATCH + D A,EN1^PRCFAC2,B Q +BATCH ;BATCH AND PRINT CODE SHEETS + D A,EN^PRCFACP,B Q +REPRINT ;REPRINT A BATCH + D A,EN^PRCFAC5,B Q +PURGE ;PURGE CODE SHEETS + D A S PRCFASYS=PRCFASYS_"PHA" D EN^PRCFACPR,B Q +ADD ;ADD CODE SHEET TO PRINTED BATCH + D A,ADD^PRCFACR2,B Q +DELETE ;DELETE CODE SHEET FROM PRINTED BATCH + D A,REMOV^PRCFACR2,B Q +TRANSMIT ;TRANSMIT CODE SHEETS + D A,SE^PRCFACR,B Q +RETRANS ;RETRANSMIT CODE SHEET BATCH + D A,RT^PRCFACR5,B Q +INQUIRY ;BATCH/TRANSMISSION/RECEIVING REPORT INQUIRY + D A,E14^PRCFAC3,B Q diff --git a/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHEF.m b/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHEF.m index c74f48d1..2fd64677 100644 --- a/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHEF.m +++ b/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHEF.m @@ -1,25 +1,25 @@ -PRCHEF ;ID/RSD,SF-ISC/TKW-EDIT ROUTINES FOR SUPPLY SYSTEM ;6/10/97 9:34 -V ;;5.1;IFCAP;**107**;Oct 20, 2000;Build 13 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; -EN80 ;DELETE A RECEIVING REPORT (CONT.FROM PRCHE) - K PRCHNRQ D PO^PRCHE G:'$D(PRCHPO) Q^PRCHE - I $P($G(^PRC(442,PRCHPO,23)),U,11)="S"!($P($G(^(23)),U,11)="P") W !!,?5,"Please create an adjustment voucher to delete",!,?5,"receiving reports for purchase card orders.",! G EN80 - I $P($G(^PRC(442,PRCHPO,23)),U,11)="D" W !!,?5,"Please create an adjustment voucher to delete",!,?5,"receiving reports for delivery orders.",! G EN80 - I X<25!(X>33) W $C(7)," Receiving Report cannot be deleted, please create an adjustment voucher." G EN80 - I '$O(^PRC(442,PRCHPO,11,0)) W !?3,"Order has no Receiving Reports !",$C(7) G EN80 - D LCK1^PRCHE G:'$D(DA) EN80 S:$P(^PRC(442,PRCHPO,0),U,2)=8 PRCHNRQ=1 - S DIC="^PRC(442,PRCHPO,11,",DIC(0)="QEANZ" D ^DIC I Y<0 L G EN80 - I $P(Y(0),U,6)="Y" W !?3,"Receiving Report has already been processed by Fiscal.",!?3,"You must create an Adjustment Voucher to edit this Receiving Report.",! L G EN80 - S (PRCHRPT,PRCHDPT)=+Y,(PRCHRD,PRCHDRD)=$P(Y(0),U,1),(PRCHRDEL,PRCHDTP)=1,PRCHEX=$P(Y(0),U,3)+$P(Y(0),U,5) - D ^PRCHDP3,DEL^PRCHREC2 K PRCHRDEL I $D(PRCHRD) L D Q^PRCHE G EN80 - ;S PRCHREC=$S($O(^PRC(442,PRCHPO,11,0)):1,1:0),X=$S($D(^PRC(442,PRCHPO,7)):$P(^(7),U,2),1:"") - S PRCHREC=$S($O(^PRC(442,PRCHPO,11,0)):1,1:0),X=$P($G(^PRC(442,PRCHPO,7)),U,2) - I PRCHREC S Y=$S(X=30:"25,30",X=31:"26,31",X=33:"28,33",1:X) - I 'PRCHREC S Y=$S(X=25:"22,20",X=27:22,X=30:"20,22",X=26:"23,21",X=31:"23,21",X=28:10,X=33:10,1:X) - W !! - K DIC S DIC("S")="I "_""""_Y_""""_"[($P(^(0),U,2)),$L($P(^(0),U,2))=""2""" - ;S DIC="^PRCD(442.3,",DIC(0)="AEQMZ",DIC("B")=$S($D(^PRC(442,PRCHPO,7)):$P(^(7),U,1),1:""),DIC("A")="Update SUPPLY STATUS: " D ^DIC K DIC S PRCHX=+Y I PRCHX'>0 S PRCHX=$S($D(^PRC(442,PRCHPO,7)):$P(^(7),U,1),1:"") - S DIC="^PRCD(442.3,",DIC(0)="AEQMZ",DIC("B")=$P($G(^PRC(442,PRCHPO,7)),U,1),DIC("A")="Update SUPPLY STATUS: " D ^DIC K DIC S PRCHX=+Y I PRCHX'>0 S PRCHX=$P($G(^PRC(442,PRCHPO,7)),U,1) - S X=$P(^PRC(442,PRCHPO,0),U,17),X=X-PRCHEX,$P(^(0),U,17)=X,DR=".5////"_PRCHX,DIE="^PRC(442,",DA=PRCHPO K PRCHX D ^DIE,Q^PRCHE - G EN80 +PRCHEF ;ID/RSD,SF-ISC/TKW-EDIT ROUTINES FOR SUPPLY SYSTEM ;6/10/97 9:34 +V ;;5.1;IFCAP;;Oct 20, 2000 + ;Per VHA Directive 10-93-142, this routine should not be modified. + ; +EN80 ;DELETE A RECEIVING REPORT (CONT.FROM PRCHE) + K PRCHNRQ D PO^PRCHE G:'$D(PRCHPO) Q^PRCHE + I $P($G(^PRC(442,PRCHPO,23)),U,11)="S"!($P($G(^(23)),U,11)="P") W !!,?5,"Please create an adjustment voucher to delete",!,?5,"receiving reports for purchase card orders.",! G EN80 + I $P($G(^PRC(442,PRCHPO,23)),U,11)="D" W !!,?5,"Please create an adjustment voucher to delete",!,?5,"receiving reports for delivery orders.",! G EN80 + I X<25!(X>33) W $C(7)," ??" G EN80 + I '$O(^PRC(442,PRCHPO,11,0)) W !?3,"Order has no Receiving Reports !",$C(7) G EN80 + D LCK1^PRCHE G:'$D(DA) EN80 S:$P(^PRC(442,PRCHPO,0),U,2)=8 PRCHNRQ=1 + S DIC="^PRC(442,PRCHPO,11,",DIC(0)="QEANZ" D ^DIC I Y<0 L G EN80 + I $P(Y(0),U,6)="Y" W !?3,"Receiving Report has already been processed by Fiscal.",!?3,"You must create an Adjustment Voucher to edit this Receiving Report.",! L G EN80 + S (PRCHRPT,PRCHDPT)=+Y,(PRCHRD,PRCHDRD)=$P(Y(0),U,1),(PRCHRDEL,PRCHDTP)=1,PRCHEX=$P(Y(0),U,3)+$P(Y(0),U,5) + D ^PRCHDP3,DEL^PRCHREC2 K PRCHRDEL I $D(PRCHRD) L D Q^PRCHE G EN80 + ;S PRCHREC=$S($O(^PRC(442,PRCHPO,11,0)):1,1:0),X=$S($D(^PRC(442,PRCHPO,7)):$P(^(7),U,2),1:"") + S PRCHREC=$S($O(^PRC(442,PRCHPO,11,0)):1,1:0),X=$P($G(^PRC(442,PRCHPO,7)),U,2) + I PRCHREC S Y=$S(X=30:"25,30",X=31:"26,31",X=33:"28,33",1:X) + I 'PRCHREC S Y=$S(X=25:"22,20",X=27:22,X=30:"20,22",X=26:"23,21",X=31:"23,21",X=28:10,X=33:10,1:X) + W !! + K DIC S DIC("S")="I "_""""_Y_""""_"[($P(^(0),U,2)),$L($P(^(0),U,2))=""2""" + ;S DIC="^PRCD(442.3,",DIC(0)="AEQMZ",DIC("B")=$S($D(^PRC(442,PRCHPO,7)):$P(^(7),U,1),1:""),DIC("A")="Update SUPPLY STATUS: " D ^DIC K DIC S PRCHX=+Y I PRCHX'>0 S PRCHX=$S($D(^PRC(442,PRCHPO,7)):$P(^(7),U,1),1:"") + S DIC="^PRCD(442.3,",DIC(0)="AEQMZ",DIC("B")=$P($G(^PRC(442,PRCHPO,7)),U,1),DIC("A")="Update SUPPLY STATUS: " D ^DIC K DIC S PRCHX=+Y I PRCHX'>0 S PRCHX=$P($G(^PRC(442,PRCHPO,7)),U,1) + S X=$P(^PRC(442,PRCHPO,0),U,17),X=X-PRCHEX,$P(^(0),U,17)=X,DR=".5////"_PRCHX,DIE="^PRC(442,",DA=PRCHPO K PRCHX D ^DIE,Q^PRCHE + G EN80 diff --git a/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHMA.m b/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHMA.m index bf553096..0cfaea63 100644 --- a/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHMA.m +++ b/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHMA.m @@ -1,172 +1,193 @@ -PRCHMA ;WISC/AKS-Amend to PO, req ;6/10/96 14:07 - ;;5.1;IFCAP;**21,79,100,113**;Oct 20, 2000;Build 4 - ;Per VHA Directive 2004-038, this routine should not be modified. -REQ N PRCHREQ - S PRCHREQ=1 -PO N PRCF,RETURN,PRCHAM,PRCHPO,PRCHNEW,OUT,CAN,PRCHAU,PRCHER,PRCHON,A,B,ER,FL,FIS,DELIVER,PRCHAMDA,PRCHAV,PRCHL1,PRCHLN,PRCHRET,LCNT - N PRCHL2,ROU,DIC,I,PRCHAMT,PRCHAREC,PRCHEDI,X,Y,PRCHN,PRCHO,SFUND,PRCHX,PRCHIMP,PRCHNRQ,PRCHP,REPO,PRCHNORE,%,%A,%B,D0,D1,J - N PRCFL,MSG -LOOP D KILL^PRCHMA1 S PRCHNEW="",PRCHNORE=1,CAN=0 - ; See routine PRCHAMXA for information on variable PRCHNORE and undefined DIK, var PRCHPO is the basic premise of locks applied to amendments - S PRCF("X")="S" D ^PRCFSITE Q:'$D(PRC("SITE")) - ; Lock simultaneous entry of users in amend. module for the same record. Var Y is saved in PRCHPO at the end of GETPO subrtn, when we start - ; the process(AMENDNO) of amending the record we must have var PRCHPO. - S PRCFL=0 - W !! D GETPO^PRCHAMU - ; If no record is selected or time-out or up-arrow out then exit without unlocking a record. - I $D(DTOUT)!$D(DUOUT)!$G(OUT)=1 G EXIT1 - I PRCFL=1 G LOOP - I '$G(PRCHPO)!$D(FIS) G EXIT - I '$$VERIFY^PRCHES5(PRCHPO) W !!,?5,"This purchase order has been tampered with.",!,?5,"Please notify IFCAP APPLICATION COORDINATOR.",! G EXIT - D AMENDNO^PRCHAMU G:'$G(PRCHAM) EXIT - S PRCHAMT=0,FL=0 - D INFO^PRCHAMU G:$D(PRCHAV)!ER EXIT - S X=$P($G(^PRC(443.6,PRCHPO,0)),U,16) D EN2^PRCHAMXB - I PRCHNEW="" S DA(1)=PRCHPO,DA=PRCHAM,PRCHX=X,X=0,PRCHAMDA=34 D EN8^PRCHAMXB S X=PRCHX - I $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=5!($P(^(0),U,4)=15) S CAN=1 - I PRCHNEW=111&($G(CAN)=0) D REV - I $G(CAN)>0 D ENC G:ER EXIT I $G(NOCAN)=0 S DA(1)=PRCHPO,DA=PRCHAM,PRCHAMDA=34,PRCHX=X,X=0 D EN8^PRCHAMXB S X=PRCHX G CAN1 -ASK K NOCAN,DTOUT,DUOUT,REPONUM D ASK^PRCHAMU - G:$D(REPONUM)=1 CAN1 - I ER=0 D G:'$D(REPO)&($G(CAN)=0) ASK - . D @ROU - . I $G(PRCHAMDA)=31 D MSG^PRCHAMU Q - . I $G(PRCHAMDA)=24,$G(X)=2 D MSG1^PRCHAMU S SCE=1 Q - I $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=5!($P(^(0),U,4)=15) S CAN=1 - I $D(DTOUT)!($D(DUOUT)) G EXIT - I $G(NOCAN)=1 G ASK - G:$P($G(^PRC(443.6,PRCHPO,6,PRCHAM,3,0)),U,4)'>1 EXIT -CAN1 S BFLAG=0 - S:$P($G(^PRC(443.6,PRCHPO,1)),U,7)'=6 BFLAG=1 - I $P($G(^PRC(443.6,PRCHPO,1)),U,7)=6 D - .S THISHLD=0 - .F S THISHLD=$O(^PRC(443.6,PRCHPO,2,THISHLD)) Q:'THISHLD!(BFLAG=1) D - ..S:$P($G(^PRC(443.6,PRCHPO,2,THISHLD,2)),U,2)'="" BFLAG=1 - .Q:BFLAG=1 - .S THISHLD=0 - .F S THISHLD=$O(^PRC(442,PRCHPO,2,THISHLD)) Q:'THISHLD!(BFLAG=1) D - ..S:$P($G(^PRC(442,PRCHPO,2,THISHLD,2)),U,2)'="" BFLAG=1 - W:BFLAG=0 !,"This is now a contract order. You must add a contract to this orders item(s)",!,"before approving the amendment.",! - G:BFLAG=0 EXIT - D:BFLAG=1 UPDATE^PRCHAMU G:$D(Y) EXIT -CHK I '$$VERIFY^PRCHES5(PRCHPO) W !!,?5,"This purchase order has been tampered with.",!,?5,"Please notify IFCAP APPLICATION COORDINATOR." G EXIT - I $P($G(^PRC(443.6,PRCHPO,6,PRCHAM,1)),U,4)']"" W !!,?5,"There is no Amendment Status." D - .S POSTAT=+$G(^PRC(443.6,PRCHPO,7)) - .S AMSTAT=$S(POSTAT=25:26,POSTAT=30:31,POSTAT=40:71,POSTAT=6:83,POSTAT=84:85,POSTAT=86:87,POSTAT=90:91,POSTAT=92:93,POSTAT=94:95,POSTAT=96:97,POSTAT=45:45,1:POSTAT) - .S AMSTAT=$P(^PRCD(442.3,AMSTAT,0),U) - .S DIE="^PRC(443.6,PRCHPO,6,",DA(1)=PRCHPO,DA=PRCHAM,DR="9//^S X=AMSTAT" - .D ^DIE K DIE,AMSTAT,POSTAT - K PRCHER S LCNT=1 I $P($G(^PRC(443.6,PRCHPO,6,PRCHAM,1)),U,4)']"" W !!,?5,"There is no Amendment Status.",! S PRCHER="" - I $P($G(^PRC(443.6,PRCHPO,2,0)),U,4)>0 D G:$D(PRCHER) ERR - .N END S END=IOSL-3 - .S PRCH=0 F S PRCH=$O(^PRC(443.6,PRCHPO,2,PRCH)) Q:PRCH=""!(PRCH'>0) D - ..S PRCHLN=$G(^PRC(443.6,PRCHPO,2,PRCH,0)) D Q - ...I $P(PRCHLN,U,4)="" D:LCNT>END TOP W !!,?5,"Line item ",+$P(PRCHLN,U)," is missing BOC !",$C(7) S PRCHER="",LCNT=LCNT+2 - ...I $G(PRCHAUTH)'=1,$G(PRCHREQ) I $P(PRCHLN,U,13)="" D:LCNT>END TOP W !!,?5,"Line item ",+$P(PRCHLN,U)," is missing NSN!",$C(7) S PRCHER="",LCNT=LCNT+2 - ...S J=0 S J=$O(^PRC(443.6,PRCHPO,2,PRCH,1,J)) I J'>0 D:LCNT>END TOP W !!,?5,"Line item ",+$P(PRCHLN,U)," is missing its description!",$C(7) S PRCHER="",LCNT=LCNT+2 - ...I $P($G(^PRC(442,PRCHPO,23)),U,11)="D",$P($G(^PRC(443.6,PRCHPO,2,PRCH,2)),U,2)="" D:LCNT>END TOP W !!,?5,"Line item ",+$P(PRCHLN,U)," is missing contract number.",$C(7) S PRCHER="",LCNT=LCNT+2 - ...; PRC*5.1*79 - Check line items of PC orders with source code=6 to make sure that a contract number is entered - ...D PCD^PRCHMA1 - ...Q - ..Q - .I $D(PRCHER) I LCNT>END N DIR S DIR(0)="E" D ^DIR S LCNT=1 - .Q - D EN106^PRCHNPO7 I $G(ERROR)=1 G EXIT - I $P($G(^PRC(443.6,PRCHPO,0)),U,13)>0 I $P($G(^PRC(443.6,PRCHPO,23)),U)="" W !!,?5,"This amendment has Est. Shipping and/or Handling charges without any",!,?5,"Est. Shipping BOC." S PRCHER="" - I $P($G(^PRC(443.6,PRCHPO,6,PRCHAM,0)),U,4)=5!($P($G(^(0)),U,4)=15) S CAN=1 - I $G(CAN)'=1 D CHECK^PRCHAMDF(PRCHPO,PRCHAM,.PRCHER) - I $G(PRCHAUTH)=1!($P($G(^PRC(443.6,PRCHPO,0)),U,2)=25) S FILE=443.6 D I $G(ERROR) S PRCHER="" K ERROR,FILE - .D ^PRCHSF3 - .D ADJ1^PRCHCD0 - .D LIMIT^PRCHCD0 - ; -ERR I $D(PRCHER) W !!,?5,"This amendment needs to be re-edited before it can be signed.",!,"**REMINDER** Unsigned amendments are deleted from the system after 7 days." D:LCNT>20 G EXIT - .N DIR S DIR(0)="E" D ^DIR - .Q - D REV:'$G(PRCPROST),APP G:%'=1 EXIT - S PRCHRET=$$ASK^PRCHAM8(PRCHPO,PRCHAM) G:PRCHRET'=1 EXIT - S RETURN="" D COMMIT^PRCHAM8(PRCHPO,PRCHAM,.RETURN) - G:RETURN'=1 EXIT - S DIE="^PRC(443.6,"_PRCHPO_",6,",DA=PRCHAM,DR="15///TODAY+4" D ^DIE - D ^PRCHSF3 - I $P(^PRC(443.6,PRCHPO,0),U,2)'=25 S PRCHQ="^PRCHPAM8",PRCHQ("DEST")="F",D0=PRCHPO,D1=PRCHAM D ^PRCHQUE - I '($P(^PRC(443.6,PRCHPO,0),U,2)=25!($P(^PRC(443.6,PRCHPO,0),U,19)=2)) D - . W !?3,"SEND TO SUPPLY " S PRCHQ="^PRCHPAM8",D0=PRCHPO,D1=PRCHAM D ^PRCHQUE - . S FILE=443.6 D:$D(PRCHPO) CHECK^PRCHSWCH - . I $G(PRCHOBL)=1 D SUPP^PRCFFM2M K FILE Q - . I $G(PRCHOBL)=2 S PRCOPODA=PRCHPO D ^PRCOEDI K FILE,PRCOPODA Q - I $P($G(^PRC(443.6,PRCHPO,0)),U,2)=25 D S:$G(PRCPROST) PRCPROST=PRCPROST+0.9 G EXIT - .S MTOPDA=1 - .D SUPP^PRCFFM2M ;I $P($G(^PRC(442,PRCHPO,23)),"^",11)="P" W !!,"...now generating the PHA transaction..." S PRCOPODA=PRCHPO D NEW^PRCOEDI K PRCOPODA W !! - .S PPTEMP=0,PP410=$P($G(^PRC(442,PRCHPO,0)),"^",12),PPAMT=$P($G(^PRC(442,PRCHPO,0)),"^",16) I PP410'="" S PPTEMP=$P($G(^PRCS(410,PP410,4)),"^",8),PPTEMP=-(PPAMT-PPTEMP) - .I $P($G(^PRC(442,PRCHPO,7)),"^",2)=45 S PPTEMP=PPAMT,PPAMT=0 - .I PP410'="" S $P(^PRCS(410,PP410,4),"^",3)=0 - .I PP410'="" S $P(^PRCS(410,PP410,4),"^",8)=PPAMT - .S A=$$DATE^PRC0C($P(PRCOAMT,"^",3),"I"),$P(PRCOAMT,"^",3,4)=$E(A,3,4)_"^"_$P(A,"^",2),$P(PRCOAMT,"^",5)=PPTEMP D EBAL^PRCSEZ(PRCOAMT,"O") - .I PP410'="",$P($G(^PRC(442,PRCHPO,7)),"^",2)=45 S $P(^PRCS(410,PP410,0),"^",2)="CA" D ERS410^PRC0G(PP410_"^C") - .D REMOVE^PRCSC2(PP410),ENCODE^PRCSC2(PP410,DUZ,.MESSAGE) K MESSAGE - .I '$G(PRCPROST) W !?3,"SEND TO SUPPLY " S PRCHQ="^PRCHPAM",D0=PRCHPO,D1=PRCHAM D ^PRCHQUE - .; Update file #440.5 after amendment has been approved. Consider orders created and amended in the same month and year and the user either - .; cancels the order or enters other type of amendment that changes the final amount of the order. No credit is given for orders from a - .; previous month and year. DT is the current date, system-supplied. - .S PRCHCD=$P($G(^PRC(442,PRCHPO,23)),U,8) - .S PRCNODE=$G(^PRC(442,PRCHPO,6,0)),PRCAMD=$P(PRCNODE,U,3) - .S PRCCHG=$P($G(^PRC(442,PRCHPO,6,PRCAMD,0)),U,3) - .S POSTAT=$P($G(^PRC(442,PRCHPO,7)),"^",2) - .I $E($P(^PRC(442,PRCHPO,1),U,15),1,5)=$E(DT,1,5),POSTAT'=45 D - ..I $G(PPAMT)<0 Q - ..S $P(^PRC(440.5,PRCHCD,2),U)=$P($G(^PRC(440.5,PRCHCD,2)),U)+$G(PRCCHG) - ..I $P($G(^PRC(440.5,PRCHCD,2)),U)<0 S $P(^PRC(440.5,PRCHCD,2),U)=0 - .; - .I $E($P(^PRC(442,PRCHPO,1),U,15),1,5)=$E(DT,1,5),POSTAT=45 D - ..I $G(PPTEMP)<0 Q - ..S $P(^PRC(440.5,PRCHCD,2),U)=$P($G(^PRC(440.5,PRCHCD,2)),U)-$G(PPTEMP) - ..I $P($G(^PRC(440.5,PRCHCD,2)),U)<0 S $P(^PRC(440.5,PRCHCD,2),U)=0 - .; - .; Update file #440.5 only if the amendment is for non-cancellation - .; of an order from a previous month regardless of the year. - .I $E($P(^PRC(442,PRCHPO,1),U,15),1,5)'=$E(DT,1,5),POSTAT'=45 D - ..I $G(PPAMT)<0 Q - ..S $P(^PRC(440.5,PRCHCD,2),U)=$P($G(^PRC(440.5,PRCHCD,2)),U)+$G(PPAMT) - .K DA,MTOPDA,PRCAMD,PRCHCD,PRCCHG,PRCNODE,POSTAT,PPTEMP,PPAMT,PP410 - S SFUND="" I $P($G(^PRC(443.6,PRCHPO,0)),U,19)=2 D SUPP^PRCFFM2M S SFUND=1 - I SFUND=1 W !?3,"SEND TO SUPPLY " S PRCHQ="^PRCHPAM",D0=PRCHPO,D1=PRCHAM D ^PRCHQUE - D SOURCE^PRCHAMU:$G(SCE) - G EXIT -ENC S ER=0 - D CAN^PRCHMA3 - I $G(NOCAN)=1 W !?5,$S($D(PRCHREQ):"REQUISITION",1:"PURCHASE ORDER")_" HAS BEEN RECEIVED, CANNOT CANCEL !",$C(7) S ER=1 Q - I $G(PRCHAUTH)=1 D PAID^PRCHINQ I $G(PAID)=1 D S ER=1 Q - . W !,?5,"THERE HAS BEEN PAYMENT MADE FOR THIS PURCHASE CARD ORDER, CANNOT CANCEL !",$C(7) - S %="",%A=" SURE YOU WANT TO CANCEL THIS ORDER ",%B="" D ^PRCFYN - I %'=1 W ?40," " D Q - .I $D(PRCHAU) D - ..S $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=PRCHAU - ..S $P(^PRC(443.6,PRCHPO,6,PRCHAM,1),U,4)="" - .S NOCAN=1 - S DA(1)=PRCHPO,DIE="^PRC(443.6,"_DA(1)_",6,",DA=PRCHAM,DR="9////^S X=$O(^PRCD(442.3,""C"",45,0))" - D ^DIE K DIE,DA,DR S CAN=1 - S PRCHAMT=-$P(^PRC(443.6,PRCHPO,0),U,15) W ! - QUIT -APP S %A=" Approve Amendment number "_PRCHAM_": ",%B="",%=$S($G(PRCPROST):1,1:2) D ^PRCFYN - Q -REV N PRCH - S %=1,%B="",%A=" Review Amendment " D ^PRCHSF3 W ! D ^PRCFYN - I %=1 S D0=PRCHPO,D1=PRCHAM,PRCH="^PRC(443.6," D ^PRCHDAM - Q -EXIT L -^PRC(442,PRCENTRY) -EXIT1 K ERROR,FIS,REPO,DEL - QUIT:$G(PRCPROST) - I $G(OUT)'=1 G LOOP - QUIT -FLAG I $G(FLAG)=1 K FLAG Q - Q -NOSIGN S $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=PRCHAU -NOSIGN1 S DA(1)=PRCHPO,DIE="^PRC(443.6,"_DA(1)_",6,",DA=PRCHAM,DR="9///@" - D ^DIE K DIE,DA,DR - Q -TOP ;PAUSE AT BOTTOM OF SCREEN - N DIR S DIR(0)="E" - D ^DIR - S LCNT=1 - Q +PRCHMA ;WISC/AKS-Amend to PO, req ;6/10/96 14:07 + ;;5.1;IFCAP;**21,79,100**;Oct 20, 2000 + ;Per VHA Directive 10-93-142, this routine should not be modified. +REQ ;Req. + N PRCHREQ + S PRCHREQ=1 +PO ;PO + N PRCF,RETURN,PRCHAM,PRCHPO,PRCHNEW,OUT,CAN,PRCHAU,PRCHER,PRCHON + N A,B,ER,FL,FIS,DELIVER,PRCHAMDA,PRCHAV,PRCHL1,PRCHLN,PRCHRET,LCNT + N PRCHL2,ROU,DIC,I,PRCHAMT,PRCHAREC,PRCHEDI,X,Y,PRCHN,PRCHO,SFUND + N PRCHX,PRCHIMP,PRCHNRQ,PRCHP,REPO,PRCHNORE,%,%A,%B,D0,D1,J + N PRCFL,MSG +LOOP D KILL^PRCHMA1 S PRCHNEW="",PRCHNORE=1,CAN=0 + ; + ; See routine PRCHAMXA for information on variable PRCHNORE and for + ; incidence of undefined DIK variable errors. + ; The var PRCHPO is the basic premise of locks applied to amendments. + ; Anytime amend module is accessed add +lock & save po# in PRCENTRY. + ; + S PRCF("X")="S" D ^PRCFSITE Q:'$D(PRC("SITE")) + ; + ; Lock simultaneous entry of users in amend. module for the same record. + ; Var Y is saved in PRCHPO at the end of GETPO subrtn, when we start + ; the process(AMENDNO) of amending the record we must have var PRCHPO. + ; + S PRCFL=0 + W !! D GETPO^PRCHAMU + ; If no record is selected or time-out or up-arrow out then exit + ; without unlocking a record. + I $D(DTOUT)!$D(DUOUT)!$G(OUT)=1 G EXIT1 + I PRCFL=1 G LOOP + I '$G(PRCHPO)!$D(FIS) G EXIT + I '$$VERIFY^PRCHES5(PRCHPO) W !!,?5,"This purchase order has been tampered with.",!,?5,"Please notify IFCAP APPLICATION COORDINATOR.",! G EXIT + D AMENDNO^PRCHAMU G:'$G(PRCHAM) EXIT + S PRCHAMT=0,FL=0 + D INFO^PRCHAMU G:$D(PRCHAV)!ER EXIT + S X=$P($G(^PRC(443.6,PRCHPO,0)),U,16) D EN2^PRCHAMXB + I PRCHNEW="" S DA(1)=PRCHPO,DA=PRCHAM,PRCHX=X,X=0,PRCHAMDA=34 D EN8^PRCHAMXB S X=PRCHX + I $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=5!($P(^(0),U,4)=15) S CAN=1 + I PRCHNEW=111&($G(CAN)=0) D REV + I $G(CAN)>0 D ENC G:ER EXIT I $G(NOCAN)=0 S DA(1)=PRCHPO,DA=PRCHAM,PRCHAMDA=34,PRCHX=X,X=0 D EN8^PRCHAMXB S X=PRCHX G CAN1 +ASK K NOCAN,DTOUT,DUOUT,REPONUM D ASK^PRCHAMU + G:$D(REPONUM)=1 CAN1 + I ER=0 D G:'$D(REPO)&($G(CAN)=0) ASK + . D @ROU + . I $G(PRCHAMDA)=31 D MSG^PRCHAMU Q + . I $G(PRCHAMDA)=24,$G(X)=2 D MSG1^PRCHAMU S SCE=1 Q + ; + I $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=5!($P(^(0),U,4)=15) S CAN=1 + I $D(DTOUT)!($D(DUOUT)) G EXIT + I $G(NOCAN)=1 G ASK + G:$P($G(^PRC(443.6,PRCHPO,6,PRCHAM,3,0)),U,4)'>1 EXIT +CAN1 D UPDATE^PRCHAMU G:$D(Y) EXIT +CHK I '$$VERIFY^PRCHES5(PRCHPO) W !!,?5,"This purchase order has been tampered with.",!,?5,"Please notify IFCAP APPLICATION COORDINATOR." G EXIT + I $P($G(^PRC(443.6,PRCHPO,6,PRCHAM,1)),U,4)']"" W !!,?5,"There is no Amendment Status." D + .S POSTAT=+$G(^PRC(443.6,PRCHPO,7)) + .S AMSTAT=$S(POSTAT=25:26,POSTAT=30:31,POSTAT=40:71,POSTAT=6:83,POSTAT=84:85,POSTAT=86:87,POSTAT=90:91,POSTAT=92:93,POSTAT=94:95,POSTAT=96:97,POSTAT=45:45,1:POSTAT) + .S AMSTAT=$P(^PRCD(442.3,AMSTAT,0),U) + .S DIE="^PRC(443.6,PRCHPO,6,",DA(1)=PRCHPO,DA=PRCHAM,DR="9//^S X=AMSTAT" + .D ^DIE K DIE,AMSTAT,POSTAT + K PRCHER S LCNT=1 I $P($G(^PRC(443.6,PRCHPO,6,PRCHAM,1)),U,4)']"" W !!,?5,"There is no Amendment Status.",! S PRCHER="" + I $P($G(^PRC(443.6,PRCHPO,2,0)),U,4)>0 D G:$D(PRCHER) ERR + .N END S END=IOSL-3 + .S PRCH=0 F S PRCH=$O(^PRC(443.6,PRCHPO,2,PRCH)) Q:PRCH=""!(PRCH'>0) D + ..S PRCHLN=$G(^PRC(443.6,PRCHPO,2,PRCH,0)) D Q + ...I $P(PRCHLN,U,4)="" D:LCNT>END TOP W !!,?5,"Line item ",+$P(PRCHLN,U)," is missing BOC !",$C(7) S PRCHER="",LCNT=LCNT+2 + ...I $G(PRCHAUTH)'=1,$G(PRCHREQ) I $P(PRCHLN,U,13)="" D:LCNT>END TOP W !!,?5,"Line item ",+$P(PRCHLN,U)," is missing NSN!",$C(7) S PRCHER="",LCNT=LCNT+2 + ...S J=0 S J=$O(^PRC(443.6,PRCHPO,2,PRCH,1,J)) I J'>0 D:LCNT>END TOP W !!,?5,"Line item ",+$P(PRCHLN,U)," is missing its description!",$C(7) S PRCHER="",LCNT=LCNT+2 + ...I $P($G(^PRC(442,PRCHPO,23)),U,11)="D",$P($G(^PRC(443.6,PRCHPO,2,PRCH,2)),U,2)="" D:LCNT>END TOP W !!,?5,"Line item ",+$P(PRCHLN,U)," is missing contract number.",$C(7) S PRCHER="",LCNT=LCNT+2 + ...; PRC*5.1*79 - Check line items of PC orders with source code=6 to + ...; make sure that a contract number is entered + ...D PCD^PRCHMA1 + ...Q + ..Q + .I $D(PRCHER) I LCNT>END N DIR S DIR(0)="E" D ^DIR S LCNT=1 + .Q + ;PRC*5.1*100: check line items without an FSC or PSC + D EN106^PRCHNPO7 I $G(ERROR)=1 G EXIT + I $P($G(^PRC(443.6,PRCHPO,0)),U,13)>0 I $P($G(^PRC(443.6,PRCHPO,23)),U)="" W !!,?5,"This amendment has Est. Shipping and/or Handling charges without any",!,?5,"Est. Shipping BOC." S PRCHER="" + I $P($G(^PRC(443.6,PRCHPO,6,PRCHAM,0)),U,4)=5!($P($G(^(0)),U,4)=15) S CAN=1 + I $G(CAN)'=1 D CHECK^PRCHAMDF(PRCHPO,PRCHAM,.PRCHER) + ; + ; Change below to allow checks for monthly limits in file #440.5 before + ; completion of the amendment. + ; + I $G(PRCHAUTH)=1!($P($G(^PRC(443.6,PRCHPO,0)),U,2)=25) S FILE=443.6 D I $G(ERROR) S PRCHER="" K ERROR,FILE + .D ^PRCHSF3 + .D ADJ1^PRCHCD0 + .D LIMIT^PRCHCD0 + ; +ERR I $D(PRCHER) W !!,?5,"This amendment needs to be re-edited before it can be signed.",!,"**REMINDER** Unsigned amendments are deleted from the system after 7 days." D:LCNT>20 G EXIT + .N DIR S DIR(0)="E" D ^DIR + .Q + D REV:'$G(PRCPROST),APP G:%'=1 EXIT + S PRCHRET=$$ASK^PRCHAM8(PRCHPO,PRCHAM) G:PRCHRET'=1 EXIT + S RETURN="" D COMMIT^PRCHAM8(PRCHPO,PRCHAM,.RETURN) + G:RETURN'=1 EXIT + S DIE="^PRC(443.6,"_PRCHPO_",6,",DA=PRCHAM,DR="15///TODAY+4" D ^DIE + D ^PRCHSF3 + I $P(^PRC(443.6,PRCHPO,0),U,2)'=25 S PRCHQ="^PRCHPAM8",PRCHQ("DEST")="F",D0=PRCHPO,D1=PRCHAM D ^PRCHQUE + I '($P(^PRC(443.6,PRCHPO,0),U,2)=25!($P(^PRC(443.6,PRCHPO,0),U,19)=2)) D + . W !?3,"SEND TO SUPPLY " S PRCHQ="^PRCHPAM8",D0=PRCHPO,D1=PRCHAM D ^PRCHQUE + . S FILE=443.6 D:$D(PRCHPO) CHECK^PRCHSWCH + . I $G(PRCHOBL)=1 D SUPP^PRCFFM2M K FILE Q + . I $G(PRCHOBL)=2 S PRCOPODA=PRCHPO D ^PRCOEDI K FILE,PRCOPODA Q + I $P($G(^PRC(443.6,PRCHPO,0)),U,2)=25 D S:$G(PRCPROST) PRCPROST=PRCPROST+0.9 G EXIT + .S MTOPDA=1 + .D SUPP^PRCFFM2M ;I $P($G(^PRC(442,PRCHPO,23)),"^",11)="P" W !!,"...now generating the PHA transaction..." S PRCOPODA=PRCHPO D NEW^PRCOEDI K PRCOPODA W !! + .S PPTEMP=0,PP410=$P($G(^PRC(442,PRCHPO,0)),"^",12),PPAMT=$P($G(^PRC(442,PRCHPO,0)),"^",16) I PP410'="" S PPTEMP=$P($G(^PRCS(410,PP410,4)),"^",8),PPTEMP=-(PPAMT-PPTEMP) + .I $P($G(^PRC(442,PRCHPO,7)),"^",2)=45 S PPTEMP=PPAMT,PPAMT=0 + .I PP410'="" S $P(^PRCS(410,PP410,4),"^",3)=0 + .I PP410'="" S $P(^PRCS(410,PP410,4),"^",8)=PPAMT + .S A=$$DATE^PRC0C($P(PRCOAMT,"^",3),"I"),$P(PRCOAMT,"^",3,4)=$E(A,3,4)_"^"_$P(A,"^",2),$P(PRCOAMT,"^",5)=PPTEMP D EBAL^PRCSEZ(PRCOAMT,"O") + .I PP410'="",$P($G(^PRC(442,PRCHPO,7)),"^",2)=45 S $P(^PRCS(410,PP410,0),"^",2)="CA" D ERS410^PRC0G(PP410_"^C") + .D REMOVE^PRCSC2(PP410),ENCODE^PRCSC2(PP410,DUZ,.MESSAGE) K MESSAGE + .I '$G(PRCPROST) W !?3,"SEND TO SUPPLY " S PRCHQ="^PRCHPAM",D0=PRCHPO,D1=PRCHAM D ^PRCHQUE + .; + .; Update file #440.5 after amendment has been approved. Consider orders + .; created and amended in the same month and year and the user either + .; cancels the order or enters other type of amendment that changes the + .; final amount of the order. No credit is given for orders from a + .; previous month and year. DT is the current date, system-supplied. + .; + .S PRCHCD=$P($G(^PRC(442,PRCHPO,23)),U,8) + .S PRCNODE=$G(^PRC(442,PRCHPO,6,0)),PRCAMD=$P(PRCNODE,U,3) + .S PRCCHG=$P($G(^PRC(442,PRCHPO,6,PRCAMD,0)),U,3) + .S POSTAT=$P($G(^PRC(442,PRCHPO,7)),"^",2) + .I $E($P(^PRC(442,PRCHPO,1),U,15),1,5)=$E(DT,1,5),POSTAT'=45 D + ..I $G(PPAMT)<0 Q + ..S $P(^PRC(440.5,PRCHCD,2),U)=$P($G(^PRC(440.5,PRCHCD,2)),U)+$G(PRCCHG) + ..I $P($G(^PRC(440.5,PRCHCD,2)),U)<0 S $P(^PRC(440.5,PRCHCD,2),U)=0 + .; + .I $E($P(^PRC(442,PRCHPO,1),U,15),1,5)=$E(DT,1,5),POSTAT=45 D + ..I $G(PPTEMP)<0 Q + ..S $P(^PRC(440.5,PRCHCD,2),U)=$P($G(^PRC(440.5,PRCHCD,2)),U)-$G(PPTEMP) + ..I $P($G(^PRC(440.5,PRCHCD,2)),U)<0 S $P(^PRC(440.5,PRCHCD,2),U)=0 + .; + .; Update file #440.5 only if the amendment is for non-cancellation + .; of an order from a previous month regardless of the year. + .I $E($P(^PRC(442,PRCHPO,1),U,15),1,5)'=$E(DT,1,5),POSTAT'=45 D + ..I $G(PPAMT)<0 Q + ..S $P(^PRC(440.5,PRCHCD,2),U)=$P($G(^PRC(440.5,PRCHCD,2)),U)+$G(PPAMT) + .K DA,MTOPDA,PRCAMD,PRCHCD,PRCCHG,PRCNODE,POSTAT,PPTEMP,PPAMT,PP410 + S SFUND="" I $P($G(^PRC(443.6,PRCHPO,0)),U,19)=2 D SUPP^PRCFFM2M S SFUND=1 + I SFUND=1 W !?3,"SEND TO SUPPLY " S PRCHQ="^PRCHPAM",D0=PRCHPO,D1=PRCHAM D ^PRCHQUE + ; + D SOURCE^PRCHAMU:$G(SCE) + G EXIT + ; +ENC ;Can + S ER=0 + D CAN^PRCHMA3 + I $G(NOCAN)=1 W !?5,$S($D(PRCHREQ):"REQUISITION",1:"PURCHASE ORDER")_" HAS BEEN RECEIVED, CANNOT CANCEL !",$C(7) S ER=1 Q + I $G(PRCHAUTH)=1 D PAID^PRCHINQ I $G(PAID)=1 D S ER=1 Q + . W !,?5,"THERE HAS BEEN PAYMENT MADE FOR THIS PURCHASE CARD ORDER, CANNOT CANCEL !",$C(7) + S %="",%A=" SURE YOU WANT TO CANCEL THIS ORDER ",%B="" D ^PRCFYN + I %'=1 W ?40," " D Q + .I $D(PRCHAU) D + ..S $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=PRCHAU + ..S $P(^PRC(443.6,PRCHPO,6,PRCHAM,1),U,4)="" + .S NOCAN=1 + S DA(1)=PRCHPO,DIE="^PRC(443.6,"_DA(1)_",6,",DA=PRCHAM,DR="9////^S X=$O(^PRCD(442.3,""C"",45,0))" + D ^DIE K DIE,DA,DR S CAN=1 + S PRCHAMT=-$P(^PRC(443.6,PRCHPO,0),U,15) W ! + QUIT +APP ;App,pr + S %A=" Approve Amendment number "_PRCHAM_": ",%B="",%=$S($G(PRCPROST):1,1:2) D ^PRCFYN + Q +REV ;Rev + N PRCH + S %=1,%B="",%A=" Review Amendment " D ^PRCHSF3 W ! D ^PRCFYN + I %=1 S D0=PRCHPO,D1=PRCHAM,PRCH="^PRC(443.6," D ^PRCHDAM + Q +EXIT ;Ex + L -^PRC(442,PRCENTRY) +EXIT1 K ERROR,FIS,REPO,DEL + QUIT:$G(PRCPROST) + I $G(OUT)'=1 G LOOP + QUIT + ; +FLAG ; + I $G(FLAG)=1 K FLAG Q + Q +NOSIGN ; + S $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=PRCHAU +NOSIGN1 S DA(1)=PRCHPO,DIE="^PRC(443.6,"_DA(1)_",6,",DA=PRCHAM,DR="9///@" + D ^DIE K DIE,DA,DR + Q +TOP ;PAUSE AT BOTTOM OF SCREEN + N DIR S DIR(0)="E" + D ^DIR + S LCNT=1 + Q diff --git a/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHNPO3.m b/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHNPO3.m index c738e745..7b694c60 100644 --- a/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHNPO3.m +++ b/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHNPO3.m @@ -1,96 +1,92 @@ -PRCHNPO3 ;WISC/RSD/RHD/SC-CONT. OF NEW PO ; 4/23/99 1:39pm -V ;;5.1;IFCAP;*112*;Oct 20, 2000;Build 2 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; - S PRCHSZ=1 - ; -EN0 W !,"Enter a 2237 reference number. The FCP,Cost Center,Service,Delivery",!?3,"Location" W:PRCHSZ " and Line Items" W " will be transferred into this Purchase Order." - W !!,?10,"The 2237 Fiscal Year and Quarter must be earlier or same",!,?10,"as the P.O. Date Fiscal Year and Quarter.",! - I $O(^PRC(442,PRCHPO,13,0)) W !?3,"This Purchase Order already contains:" F I=0:0 S I=$O(^PRC(442,PRCHPO,13,I)) Q:'I I $D(^PRCS(410,I,0)) W !?3,$P(^(0),U,1) - I '$D(^PRC(442,PRCHPO,1)),$P(^(1),U,15)="" W !!,"Cannot precede without a P.O. DATE" G Q - ; -EN K PRCHSY S PRCHD=$P(^PRC(442,PRCHPO,1),U,15),PRCHSP=$P(^(0),U,12) - ;screen-out the Issue Book order if status is 65--Assigned to PPM Clerk, for nois MWV-0293-20011 - S DIC="^PRC(443," - S DIC(0)="AQEMZ" - I $G(PRCHZZZ9)'=1 S DIC("S")="I $P(^(0),U,3)]"""",""65,72""'[$P(^(0),U,7),$D(^PRCS(410,+Y,0)),+^(0)=PRC(""SITE""),$P(^(0),U,2)=""O"",$P(^(0),U,4)'=5,$D(^(""IT"",""AB"")) D EN3^PRCHNPO6" - I $G(PRCHZZZ9)=1 S DIC("S")="I $P(^(0),U,3)]"""",$P(^(0),U,7)=65,$D(^PRCS(410,+Y,0)),+^(0)=PRC(""SITE""),$P(^(0),U,2)=""O"",$P(^(0),U,4)'=5,$D(^(""IT"",""AB"")) D EN3^PRCHNPO6" - D ^DIC K DIC G:Y<0 Q S PRCHSY=+Y,PRCHSY(0)=Y(0),Y(0)=^PRCS(410,+Y,0),PRCHSX=$P(Y(0),U,1) I $D(^(1)),$P(^(1),U,3)="EM" W $C(7),!,"*** EMERGENCY ***" - ;I $D(^PRCS(410,+Y,0)),$P(^(0),U,4)=5 W !?3,"This is an Issue Book Order, and it can't be processed into a Purchase Order." Q - ; -EN1 S PRCHRFQT=$$DATE^PRC0C($P(Y(0),"^",11),"I"),PRCHRFQT=$P(PRCHRFQT,U,1,2) - S PRC("BBFY")=+$$DATE^PRC0C($P(^PRCS(410,+Y,3),"^",11),"I") - ;S PRCHCFQT=$$DATE^PRC0C($P(^PRC(420,PRC("SITE"),0),U,9),"I"),PRCHCFQT=$P(PRCHCFQT,U,1,2) - S PRCHPFQT=$$DATE^PRC0C($P(^PRC(442,PRCHPO,1),"^",15),"I"),PRCHPFQT=$P(PRCHPFQT,U,1,2) - I PRCHRFQT'=PRCHPFQT W !,?10,"The Fiscal Year and Quarter on this 2237 is not",!,?10,"compatible with the PO Date.",!,$C(7) K PRCHRFQT,PRCHPFQT G EN - K PRCHRFQT,PRCHPFQT - I $P(^PRC(442,PRCHPO,0),U,3)]"",+$P(^PRC(442,PRCHPO,0),U,3)'=+$P(^PRCS(410,PRCHSY,3),U,1) W !?3,"Fund Control Point for this 2237 doesn't match the existing FCP in P.O.",$C(7) G EN - I $P(^PRC(442,PRCHPO,0),U,5)]"",+$P(^PRC(442,PRCHPO,0),U,5)'=+$P(^PRCS(410,PRCHSY,3),U,3) W !?3,"Cost Center for this 2237 doesn't match the Cost Center in P.O.",$C(7) G EN - S X="",Z="" I $D(^PRC(420,PRC("SITE"),1,+^PRCS(410,PRCHSY,3),0)) S X=$P(^(0),U,12),Z=$P(^(0),U,18) - I X'=2 S:Z'="" $P(^PRC(442,PRCHPO,17),U,1)=$E(Z,1,3) I Z="" W $C(7),!?3,"Fund Control point is missing LOG Department Number!!" G EN - I X I PRCHN("MP")=4!((X=3)&(PRCHN("MP")=3)) S Y=$P(^PRCD(442.5,PRCHN("MP"),0),U,1) W $C(7),!?3,"This Fund Control Point is not valid for a "_Y_" order." G EN - S EN=0 I $D(^PRC(411,"UP",PRC("SITE"))) D G EN:EN=1 - .I $P($G(^PRCS(410,+Y,0)),U,10)="" W $C(7),!!?3,"This 2237 does not have a substation.",! S EN=1 Q - .I $P($G(^PRCS(410,+Y,0)),U,10)'=$P($G(^PRC(442,PRCHPO,23)),U,7) W $C(7),!!?3,"The substation on this 2237 does not match the substation entered",!?3,"on this "_$S($D(PRCHNRQ):"requisition.",1:"purchase order."),! S EN=1 - D SPRMK^PRCHNPO6 - ; -N Q:'PRCHSZ K ^TMP($J,"PRCHS"),PRCHSIT S J=0,K=1,PRCHSIT(K)="" G:$D(PRCHPOST) 1 - W !?3,"Line Items: " R PRCHX:DTIME G Q:PRCHX["^"!(PRCHX=""),HLP:$E(PRCHX)="?",1:"Aa"[$E(PRCHX) - F Q:'$F(PRCHX,",,") S PRCHX=$P(PRCHX,",,",1)_","_$P(PRCHX,",,",2,99) ; *112 remove consecutive commas - S:$E(PRCHX)="," PRCHX=$E(PRCHX,2,$L(PRCHX)) ; *112 remove leading comma - S:$E(PRCHX,$L(PRCHX))="," PRCHX=$E(PRCHX,1,$L(PRCHX)-1) ; *112 remove trailing comma - F I=1:1 S X=$P(PRCHX,",",I) Q:X="" I +X'=X S X(1)=$P(X,":",1),X(2)=$P(X,":",2) K:+X(1)'=X(1)!(+X(2)'=X(2))!'(X(1)72 K=K+1,PRCHSIT(K)="" S PRCHSIT(K)=PRCHSIT(K)_I_"," Q - W !?5,"** ",I," IS AN INVALID LINE ITEM NUMBER",$C(7) K ^TMP($J,"PRCHS") - Q - ; -HLP W !?3,"ENTER A LINE ITEM NUMBER IN THE FOLLOWING FORMAT: 1,2,3,4 OR 1:4 ",!?5," OR ENTER 'A' FOR ALL LINE ITEMS " S DIC="^PRCS(410,+PRCHSY,""IT"",",DIC(0)="E",X="??",D="AB" D IX^DIC K DIC G N - Q - ; -Q S (DA,D0)=PRCHPO K C,DIC,X,PRCH,PRCHD,PRCHS,PRCHSP,PRCHSIT,PRCHJ,PRCHK,PRCHSLI,PRCHSX,PRCHSY,PRCHSZ,PRCHX,^TMP($J,"PRCHS"),EN,Y - S:0 Y="@1" ;<<< Removed the SET Y="@1" from this routine and put it into the template PRCH2138. <<< - Q - ; -DT S X="T" D ^%DT S DT=Y - Q - ; -EN2 ;CHECKS FCP PARAMETERS & SET Y, CALLED FROM PRCH2138,PRCHIFREG - S PRCHN("SFC")=+$P(^PRC(442,DA,0),"^",19) - S $P(^PRC(442,DA,18),U,2)=$S((PRCHN("SFC")=2)&(PRCHN("MP")=12):"B",PRCHN("SFC")=2:"A",PRCHN("SFC")=3:"J",1:"") - Q - ; -ERR W !,$C(7),"Cannot get a transaction number at this time for the new transaction being split",!,"out. Try again later!" - Q - ; -ERR1 W !,$C(7),"Cannot find the 2237 you selected in file 410." - Q - ; -ERR2 W !,$C(7),"Not continuing with this 2237." - Q - ; -VENMSG ;message to alert users that vendors don't match and that IMF will - ;be updated. - W !!,"NOTE-Vendors on PO and 2237 don't match. If you proceed IMF info"," will be used. If there is no IMF entry for the item for this vendor one will ","be created." - N % S %=0 - W !,"Would you like to proceed" D YN^DICN W !! I %'=1 S PRCHFLG=1 - Q +PRCHNPO3 ;WISC/RSD/RHD/SC-CONT. OF NEW PO ; 4/23/99 1:39pm +V ;;5.1;IFCAP;;Oct 20, 2000 + ;Per VHA Directive 10-93-142, this routine should not be modified. + ; + S PRCHSZ=1 + ; +EN0 W !,"Enter a 2237 reference number. The FCP,Cost Center,Service,Delivery",!?3,"Location" W:PRCHSZ " and Line Items" W " will be transferred into this Purchase Order." + W !!,?10,"The 2237 Fiscal Year and Quarter must be earlier or same",!,?10,"as the P.O. Date Fiscal Year and Quarter.",! + I $O(^PRC(442,PRCHPO,13,0)) W !?3,"This Purchase Order already contains:" F I=0:0 S I=$O(^PRC(442,PRCHPO,13,I)) Q:'I I $D(^PRCS(410,I,0)) W !?3,$P(^(0),U,1) + I '$D(^PRC(442,PRCHPO,1)),$P(^(1),U,15)="" W !!,"Cannot precede without a P.O. DATE" G Q + ; +EN K PRCHSY S PRCHD=$P(^PRC(442,PRCHPO,1),U,15),PRCHSP=$P(^(0),U,12) + ;screen-out the Issue Book order if status is 65--Assigned to PPM Clerk, for nois MWV-0293-20011 + S DIC="^PRC(443," + S DIC(0)="AQEMZ" + I $G(PRCHZZZ9)'=1 S DIC("S")="I $P(^(0),U,3)]"""",""65,72""'[$P(^(0),U,7),$D(^PRCS(410,+Y,0)),+^(0)=PRC(""SITE""),$P(^(0),U,2)=""O"",$P(^(0),U,4)'=5,$D(^(""IT"",""AB"")) D EN3^PRCHNPO6" + I $G(PRCHZZZ9)=1 S DIC("S")="I $P(^(0),U,3)]"""",$P(^(0),U,7)=65,$D(^PRCS(410,+Y,0)),+^(0)=PRC(""SITE""),$P(^(0),U,2)=""O"",$P(^(0),U,4)'=5,$D(^(""IT"",""AB"")) D EN3^PRCHNPO6" + D ^DIC K DIC G:Y<0 Q S PRCHSY=+Y,PRCHSY(0)=Y(0),Y(0)=^PRCS(410,+Y,0),PRCHSX=$P(Y(0),U,1) I $D(^(1)),$P(^(1),U,3)="EM" W $C(7),!,"*** EMERGENCY ***" + ;I $D(^PRCS(410,+Y,0)),$P(^(0),U,4)=5 W !?3,"This is an Issue Book Order, and it can't be processed into a Purchase Order." Q + ; +EN1 S PRCHRFQT=$$DATE^PRC0C($P(Y(0),"^",11),"I"),PRCHRFQT=$P(PRCHRFQT,U,1,2) + S PRC("BBFY")=+$$DATE^PRC0C($P(^PRCS(410,+Y,3),"^",11),"I") + ;S PRCHCFQT=$$DATE^PRC0C($P(^PRC(420,PRC("SITE"),0),U,9),"I"),PRCHCFQT=$P(PRCHCFQT,U,1,2) + S PRCHPFQT=$$DATE^PRC0C($P(^PRC(442,PRCHPO,1),"^",15),"I"),PRCHPFQT=$P(PRCHPFQT,U,1,2) + I PRCHRFQT'=PRCHPFQT W !,?10,"The Fiscal Year and Quarter on this 2237 is not",!,?10,"compatible with the PO Date.",!,$C(7) K PRCHRFQT,PRCHPFQT G EN + K PRCHRFQT,PRCHPFQT + I $P(^PRC(442,PRCHPO,0),U,3)]"",+$P(^PRC(442,PRCHPO,0),U,3)'=+$P(^PRCS(410,PRCHSY,3),U,1) W !?3,"Fund Control Point for this 2237 doesn't match the existing FCP in P.O.",$C(7) G EN + I $P(^PRC(442,PRCHPO,0),U,5)]"",+$P(^PRC(442,PRCHPO,0),U,5)'=+$P(^PRCS(410,PRCHSY,3),U,3) W !?3,"Cost Center for this 2237 doesn't match the Cost Center in P.O.",$C(7) G EN + S X="",Z="" I $D(^PRC(420,PRC("SITE"),1,+^PRCS(410,PRCHSY,3),0)) S X=$P(^(0),U,12),Z=$P(^(0),U,18) + I X'=2 S:Z'="" $P(^PRC(442,PRCHPO,17),U,1)=$E(Z,1,3) I Z="" W $C(7),!?3,"Fund Control point is missing LOG Department Number!!" G EN + I X I PRCHN("MP")=4!((X=3)&(PRCHN("MP")=3)) S Y=$P(^PRCD(442.5,PRCHN("MP"),0),U,1) W $C(7),!?3,"This Fund Control Point is not valid for a "_Y_" order." G EN + S EN=0 I $D(^PRC(411,"UP",PRC("SITE"))) D G EN:EN=1 + .I $P($G(^PRCS(410,+Y,0)),U,10)="" W $C(7),!!?3,"This 2237 does not have a substation.",! S EN=1 Q + .I $P($G(^PRCS(410,+Y,0)),U,10)'=$P($G(^PRC(442,PRCHPO,23)),U,7) W $C(7),!!?3,"The substation on this 2237 does not match the substation entered",!?3,"on this "_$S($D(PRCHNRQ):"requisition.",1:"purchase order."),! S EN=1 + D SPRMK^PRCHNPO6 + ; +N Q:'PRCHSZ K ^TMP($J,"PRCHS"),PRCHSIT S J=0,K=1,PRCHSIT(K)="" G:$D(PRCHPOST) 1 W !?3,"Line Items: " R PRCHX:DTIME G Q:PRCHX["^"!(PRCHX=""),HLP:$E(PRCHX)="?",1:"Aa"[$E(PRCHX) + F I=1:1 S X=$P(PRCHX,",",I) Q:X="" I +X'=X S X(1)=$P(X,":",1),X(2)=$P(X,":",2) K:+X(1)'=X(1)!(+X(2)'=X(2))!'(X(1)72 K=K+1,PRCHSIT(K)="" S PRCHSIT(K)=PRCHSIT(K)_I_"," Q + W !?5,"** ",I," IS AN INVALID LINE ITEM NUMBER",$C(7) K ^TMP($J,"PRCHS") + Q + ; +HLP W !?3,"ENTER A LINE ITEM NUMBER IN THE FOLLOWING FORMAT: 1,2,3,4 OR 1:4 ",!?5," OR ENTER 'A' FOR ALL LINE ITEMS " S DIC="^PRCS(410,+PRCHSY,""IT"",",DIC(0)="E",X="??",D="AB" D IX^DIC K DIC G N + Q + ; +Q S (DA,D0)=PRCHPO K C,DIC,X,PRCH,PRCHD,PRCHS,PRCHSP,PRCHSIT,PRCHJ,PRCHK,PRCHSLI,PRCHSX,PRCHSY,PRCHSZ,PRCHX,^TMP($J,"PRCHS"),EN,Y + S:0 Y="@1" ;<<< Removed the SET Y="@1" from this routine and put it into the template PRCH2138. <<< + Q + ; +DT S X="T" D ^%DT S DT=Y + Q + ; +EN2 ;CHECKS FCP PARAMETERS & SET Y, CALLED FROM PRCH2138,PRCHIFREG + S PRCHN("SFC")=+$P(^PRC(442,DA,0),"^",19) + S $P(^PRC(442,DA,18),U,2)=$S((PRCHN("SFC")=2)&(PRCHN("MP")=12):"B",PRCHN("SFC")=2:"A",PRCHN("SFC")=3:"J",1:"") + Q + ; +ERR W !,$C(7),"Cannot get a transaction number at this time for the new transaction being split",!,"out. Try again later!" + Q + ; +ERR1 W !,$C(7),"Cannot find the 2237 you selected in file 410." + Q + ; +ERR2 W !,$C(7),"Not continuing with this 2237." + Q + ; +VENMSG ;mesasge to alert users that vendors don't match and that IMF will + ;be updated. + W !!,"NOTE-Vendors on PO and 2237 don't match. If you proceed IMF info"," will be used. If there is no IMF entry for the item for this vendor one will ","be created." + N % S %=0 + W !,"Would you like to proceed" D YN^DICN W !! I %'=1 S PRCHFLG=1 + Q diff --git a/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHNPO5.m b/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHNPO5.m index 07efcb28..a0d0bfac 100644 --- a/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHNPO5.m +++ b/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHNPO5.m @@ -1,135 +1,134 @@ -PRCHNPO5 ;WISC/RSD,RHD/DL-INPUT TRANSFORM FOR FILE 440,441,442 ;9/5/00 10:59 -V ;;5.1;IFCAP;**113**;Oct 20, 2000;Build 4 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; -EN1 ;FILE 442, FCP #1 - I '$D(PRCHAMND),$D(^PRCS(410,+$P(^PRC(442,DA,0),U,12),0)),+$P(^(0),"-",4)'=+X W !,"Fund Control Point cannot be changed since 2237 has been selected." K X Q - S Z0=$E($P(^PRC(442,DA,0),"-",2),1,2),Z1=+X D EN4^PRCHNPO6 I '$T K X,Z0,Z1 Q - S DIC="^PRC(420,PRC(""SITE""),1,",DIC(0)="QEMNZ" - S:$D(PRCHPUSH) DIC("S")="I $P(^(0),U,12)=2" - I $G(PRCHPC)!$G(PRCHDELV) S DIC("S")="I $D(^PRC(420,""C"",DUZ,PRC(""SITE""),+Y))" - S D="B^C" D MIX^DIC1 K:Y<0!('$D(PRC("FY"))) X K DIC,PRCHCPO,Z0,Z1 Q:'$D(X) - N CCNODE S CCNODE=$G(^PRC(420,PRC("SITE"),1,+Y,2,0)) I $P(CCNODE,U,4)'>0!(CCNODE="") W !,"The Fund Control Point selected by you, does not have any",!,"Cost Centers listed under it.",!,$P(Y,U,2) K X Q - I $P(Y(0),U,12)'=2,$P(Y(0),U,18)="" W $C(7),!,"LOG Department Number is missing!!" K X Q - S Z0=$P(^PRC(442,DA,0),U,2),Z1=$P(Y(0),U,12) I Z1 I ((Z0=3)&(Z1=3)) S Z0=$P(^PRCD(442.5,Z0,0),U,1) W $C(7),!,"Fund Control Point not valid for a "_Z0_" order." K Z0,Z1,X Q - S Z0=$P(Y(0),U,1),PRC("FY")=$E(100+$E(PRC("FY"),2,3)+$E(PRC("FY"),4),2,3) S:$P(Y(0),U,10)]"" PRCHN("SVC")=$P($G(^DIC(49,+$P(Y(0),U,10),0)),U,1) - I $D(^PRC(420,PRC("SITE"),1,+Y,2,0)),$P(^(0),U,4)=1,$D(^($P(^(0),U,3),0)),$D(^PRCD(420.1,+^(0),0)) S PRCHN("CC")=$P(^(0)," ",1) - S PRC("APP")="",X=Z0,PRC("BBFY")=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),+X) I PRC("BBFY")="" Q - S PRC("APP")=$P($$ACC^PRC0C(PRC("SITE"),+X_"^"_PRC("FY")_"^"_PRC("BBFY")),U,11) K Z0,Z1 - I $P($G(^PRC(420,PRC("SITE"),1,+X,0)),U,19)=1 W !,"Sorry, this FCP is inactive!",! K X Q - Q - ; -EN2 ;FILE 442, COST CENTER #2 - S PRCFA("ALL")=1,DIC="^PRCD(420.1,",DIC(0)="QEMZ" D ^DIC K DIC,PRCFA("ALL") I Y'>0 W !,"The Cost Center entered by you is not in the COST CENTER FILE.",! K X,Y,Z0 Q - I $P(Y(0),U,2)=1 W !,"The Cost Center entered by you has been DEACTIVATED.",! K X,Y,Z0 Q - S X=+Y(0) - S Z1=$G(^PRC(420,PRC("SITE"),1,Z0,2,+Y(0),0)) I Z1'>0!(Z1="") W !,"This Cost Center isn't found in FCP "_$P(^PRC(420,PRC("SITE"),1,Z0,0),U,1)_".",! K X,Y,Z0,Z1 Q - N BOCNOD S BOCNOD=$G(^PRCD(420.1,+Y,1,0)) I $P(BOCNOD,U,4)'>0!(BOCNOD="") W !,"The Cost Center selected by you, does not have any BOCs listed",!,"under it.",! K X - K Y,Z0,Z1 Q - ; -EN3 ;FILE 442, VENDOR #5 - N REP,REP1 - I DIE["PRC(442,",$D(DA),$D(^PRC(442,DA,2,"AE")) K X - Q:'$D(X)!$G(PRCHPC) - I '$G(PRCHDELV) D Q:'$G(X) - . S DIC("S")="S Z0=+$P($G(^(2)),U,2) I "_$E("'",'$D(PRCHNRQ))_"Z0,'$D(^PRC(440,""AC"",""S"",Y))" I $D(PRCHPUSH) S DIC("S")=DIC("S")_",(Z0=1!(Z0=3))" - . D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X Q:'$D(X) S PRCHNVF=Y - Q:'$D(^PRC(440,X,2)) S Z0=^(2) I $P(^PRC(442,DA,0),U,2)=4,$P(Z0,U,11)'="Y" W $C(7),!,"This Vendor is not set up as a GUARANTEED DELIVERY Vendor!." K X,Z0 Q - ; - ; SEE IF VENDOR IS INACTIVE. - ; - I $P($G(^PRC(440,X,10)),U,5)=1 K X Q - ; - ; - ; - K PRCHEDI I $P($G(^PRC(440,X,3)),U,2)="Y" S PRCHEDI="" ;CHECK FOR EDI VENDOR - I $D(^PRCD(420.8,+$P(Z0,U,2),0)) S PRCHN("SC")=$P(^(0),U,1) - K Z0 - Q - ; -EN4 ;FILE 442, EST. SHIPPING AND/OR HANDLING #13 - S %A=" FOB is Destination, Are you sure you want Handling Charges ",%B="",%=1 D ^PRCFYN I %'=1 K X W !?3,"",$C(7) - Q - ; -EN5 ;FILE 442, REPETITIVE (PR CARD) NO. #1.5 - I $P(^PRC(442,DA(1),0),U,3)=""!($P(^(1),U,1)="") W !!,"Fund Control Point and Vendor must be entered before items !",$C(7) K X Q - S:'$D(PRC("SITE")) PRC("SITE")=+^PRC(442,DA(1),0) D LCK^PRCHCRD - Q - ; -EN6 ;FILE 442, UNIT OF PURCHASE #3 - D VEN Q:'$D(X)!($P(^PRC(442,DA(1),2,DA,0),U,5)="") - S:'$D(PRC("SITE")) PRC("SITE")=$P($P(^PRC(442,DA(1),0),U,1),"-",1) S PRCHCV=$P(^PRC(442,DA(1),1),U,1),PRCHCI=$P(^(2,DA,0),U,5),PRCHCPO=DA(1) D EN0^PRCHCRD - Q - ; -EN8 ;FILE 442, CONTRACT FIELD #4 - D VEN Q:'$D(X) K DIC("S") - S Z0=$P(^PRC(442,DA(1),1),U,1),ZA=DA,ZA(1)=DA(1) - S DA(1)=Z0,DIC="^PRC(440,Z0,4,",DIC(0)="QELMZ",DLAYGO=440 - I $G(PRCHPC)!$G(PRCHDELV) S DIC(0)="QEMZ" - D EN10,^DIC S X=$P(Y,U,2),DA=ZA,DA(1)=ZA(1) K ZA K:Y'>0 X - I $D(X),$D(DT),$P(Y(0),U,2)-DT<0 W !?10,"**CONTRACT HAS EXPIRED**",$C(7),$C(7) K X,DLAYGO Q - S:'$D(PRC("SITE")) PRC("SITE")=$P($P(^PRC(442,DA(1),0),U,1),"-",1) I $P(^PRC(442,DA(1),2,DA,0),U,5)]"" S PRCHCI=$P(^(0),U,5),PRCHCV=Z0,PRCHCPO=DA(1) D EN2^PRCHCRD - K DLAYGO - Q - ; -EN9 ;FILE 442, ACTUAL UNIT COST #5 - D VEN Q:'$D(X)!($P(^PRC(442,DA(1),2,DA,0),U,5)="") - S:'$D(PRC("SITE")) PRC("SITE")=$P($P(^PRC(442,DA(1),0),U,1),"-",1) S PRCHCV=$P(^PRC(442,DA(1),1),U,1),PRCHCI=$P(^(2,DA,0),U,5),PRCHCPO=DA(1) D EN1^PRCHCRD - Q - ; -EN10 ;FILE 440 CONTRACT NUMBER - I $D(Z0) S:'$D(^PRC(440,Z0,4,0)) ^PRC(440,Z0,4,0)="^440.03I^^" - Q - ; -EN11 ;FILE 441 CONTRACT - D EN10 S DIC="^PRC(440,Z0,4,",DIC(0)="QEMLZ",DLAYGO=440,ZD=DA(1),DA(1)=Z0 D ^DIC S X=+Y K:Y'>0 X S DA(1)=ZD K ZD,Z0,DIC - I $D(X),$D(DT),$P(Y(0),U,2)-DT<0 W !?10,"**CONTRACT HAS EXPIRED**",$C(7),$C(7) K X - K DLAYGO - Q - ; -EN12 ;FILE 442, VENDOR STOCK NO.#9 - D VEN Q:'$D(X)!($P(^PRC(442,DA(1),2,DA,0),U,5)="") - S:'$D(PRC("SITE")) PRC("SITE")=+^PRC(442,DA(1),0) S PRCHCV=+$P(^PRC(442,DA(1),1),U,1),PRCHCI=+$P(^(2,DA,0),U,5),PRCHCPO=DA(1) D EN6^PRCHCRD - Q - ; -EN13 ;DIC("S") for a look-up in CONTRACT field (File 442.01,4) - S PRCHSCOD=$P($G(^PRC(442,D0,1)),U,7) - I $E(X)="?" S DIC("S")=$S(PRCHSCOD=2:"I $P(^PRC(440,Z0,4,+Y,0),U,6)'=""B""",1:"I 1") - Q - ; -EN14 ;input transform of Contract Flag field 5, file 440 - ;If PO exists, if source code=2 & contract flag is not 'C' set it 'C' - I $G(PRCHPO)>0 D - . S PRCHNOD1=$G(^PRC(442,PRCHPO,1)) - . S PRCHSOCO=$P(PRCHNOD1,U,7) - . I PRCHSOCO=2 Q:X="C" D Q - . . S X="C" - . . S ARR(1)="" - . . S ARR(2)=" Note: " - . . S ARR(3)=" This PO's Source Code is Open Market, only Contract # is a valid entry." - . . S ARR(4)=" 'C' has been entered for the Contract Flag prompt." - . . S ARR(5)=" 'B' is not allowed, system allows only 'C'." - . . S ARR(6)="" - . . D EN^DDIOL(.ARR) - . . S XQH="PRCH CONTRACT FLAG HELP" D:$E(X)="??" EN^XQH - . . Q - . Q - ; If Source code is not equal to 2, C or B is ok for contr. flag - S MSG(1)="" - S MSG(2)="Enter 'C' if the Contract Number field is a Contract #." - S MSG(2,"F")="!,?5" - S MSG(3)="Otherwise enter 'B' if it is a Basic Ordering Agreement(BOA) #." - S MSG(3,"F")="!,?5" - S MSG(4)="" - ;I PRCHSOCO'=2 D EN^DDIOL(.MSG) H 2 - ;any other route than via po - I X="B" D - . S Z=$P(^PRC(440,DA(1),4,DA,0),U) - . K:'(Z?.UN) X - . I '$D(X) S XQH="PRCH BOA" D EN^XQH - . K Z,XQH - . Q - Q - ; -VEN I $S('$D(^PRC(442,DA(1),1)):1,$P(^(1),U,1)="":1,1:0) W !!,"Vendor must be entered before items ! ",$C(7) K X - Q +PRCHNPO5 ;WISC/RSD,RHD/DL-INPUT TRANSFORM FOR FILE 440,441,442 ;9/5/00 10:59 +V ;;5.1;IFCAP;;Oct 20, 2000 + ;Per VHA Directive 10-93-142, this routine should not be modified. + ; +EN1 ;FILE 442, FCP #1 + I '$D(PRCHAMND),$D(^PRCS(410,+$P(^PRC(442,DA,0),U,12),0)),+$P(^(0),"-",4)'=+X W !,"Fund Control Point cannot be changed since 2237 has been selected." K X Q + S Z0=$E($P(^PRC(442,DA,0),"-",2),1,2),Z1=+X D EN4^PRCHNPO6 I '$T K X,Z0,Z1 Q + S DIC="^PRC(420,PRC(""SITE""),1,",DIC(0)="QEMNZ" + S:$D(PRCHPUSH) DIC("S")="I $P(^(0),U,12)=2" + I $G(PRCHPC)!$G(PRCHDELV) S DIC("S")="I $D(^PRC(420,""C"",DUZ,PRC(""SITE""),+Y))" + S D="B^C" D MIX^DIC1 K:Y<0!('$D(PRC("FY"))) X K DIC,PRCHCPO,Z0,Z1 Q:'$D(X) + N CCNODE S CCNODE=$G(^PRC(420,PRC("SITE"),1,+Y,2,0)) I $P(CCNODE,U,4)'>0!(CCNODE="") W !,"The Fund Control Point selected by you, does not have any",!,"Cost Centers listed under it.",!,$P(Y,U,2) K X Q + I $P(Y(0),U,12)'=2,$P(Y(0),U,18)="" W $C(7),!,"LOG Department Number is missing!!" K X Q + S Z0=$P(^PRC(442,DA,0),U,2),Z1=$P(Y(0),U,12) I Z1 I ((Z0=3)&(Z1=3)) S Z0=$P(^PRCD(442.5,Z0,0),U,1) W $C(7),!,"Fund Control Point not valid for a "_Z0_" order." K Z0,Z1,X Q + S Z0=$P(Y(0),U,1),PRC("FY")=$E(100+$E(PRC("FY"),2,3)+$E(PRC("FY"),4),2,3) S:$P(Y(0),U,10)]"" PRCHN("SVC")=$P($G(^DIC(49,+$P(Y(0),U,10),0)),U,1) + I $D(^PRC(420,PRC("SITE"),1,+Y,2,0)),$P(^(0),U,4)=1,$D(^($P(^(0),U,3),0)),$D(^PRCD(420.1,+^(0),0)) S PRCHN("CC")=$P(^(0)," ",1) + S PRC("APP")="",X=Z0,PRC("BBFY")=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),+X) I PRC("BBFY")="" Q + S PRC("APP")=$P($$ACC^PRC0C(PRC("SITE"),+X_"^"_PRC("FY")_"^"_PRC("BBFY")),U,11) K Z0,Z1 + Q + ; +EN2 ;FILE 442, COST CENTER #2 + S PRCFA("ALL")=1,DIC="^PRCD(420.1,",DIC(0)="QEMZ" D ^DIC K DIC,PRCFA("ALL") I Y'>0 W !,"The Cost Center entered by you is not in the COST CENTER FILE.",! K X,Y,Z0 Q + I $P(Y(0),U,2)=1 W !,"The Cost Center entered by you has been DEACTIVATED.",! K X,Y,Z0 Q + S X=+Y(0) + S Z1=$G(^PRC(420,PRC("SITE"),1,Z0,2,+Y(0),0)) I Z1'>0!(Z1="") W !,"This Cost Center isn't found in FCP "_$P(^PRC(420,PRC("SITE"),1,Z0,0),U,1)_".",! K X,Y,Z0,Z1 Q + N BOCNOD S BOCNOD=$G(^PRCD(420.1,+Y,1,0)) I $P(BOCNOD,U,4)'>0!(BOCNOD="") W !,"The Cost Center selected by you, does not have any BOCs listed",!,"under it.",! K X + K Y,Z0,Z1 Q + ; +EN3 ;FILE 442, VENDOR #5 + N REP,REP1 + I DIE["PRC(442,",$D(DA),$D(^PRC(442,DA,2,"AE")) K X + Q:'$D(X)!$G(PRCHPC) + I '$G(PRCHDELV) D Q:'$G(X) + . S DIC("S")="S Z0=+$P($G(^(2)),U,2) I "_$E("'",'$D(PRCHNRQ))_"Z0,'$D(^PRC(440,""AC"",""S"",Y))" I $D(PRCHPUSH) S DIC("S")=DIC("S")_",(Z0=1!(Z0=3))" + . D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X Q:'$D(X) S PRCHNVF=Y + Q:'$D(^PRC(440,X,2)) S Z0=^(2) I $P(^PRC(442,DA,0),U,2)=4,$P(Z0,U,11)'="Y" W $C(7),!,"This Vendor is not set up as a GUARANTEED DELIVERY Vendor!." K X,Z0 Q + ; + ; SEE IF VENDOR IS INACTIVE. + ; + I $P($G(^PRC(440,X,10)),U,5)=1 K X Q + ; + ; + ; + K PRCHEDI I $P($G(^PRC(440,X,3)),U,2)="Y" S PRCHEDI="" ;CHECK FOR EDI VENDOR + I $D(^PRCD(420.8,+$P(Z0,U,2),0)) S PRCHN("SC")=$P(^(0),U,1) + K Z0 + Q + ; +EN4 ;FILE 442, EST. SHIPPING AND/OR HANDLING #13 + S %A=" FOB is Destination, Are you sure you want Handling Charges ",%B="",%=1 D ^PRCFYN I %'=1 K X W !?3,"",$C(7) + Q + ; +EN5 ;FILE 442, REPETITIVE (PR CARD) NO. #1.5 + I $P(^PRC(442,DA(1),0),U,3)=""!($P(^(1),U,1)="") W !!,"Fund Control Point and Vendor must be entered before items !",$C(7) K X Q + S:'$D(PRC("SITE")) PRC("SITE")=+^PRC(442,DA(1),0) D LCK^PRCHCRD + Q + ; +EN6 ;FILE 442, UNIT OF PURCHASE #3 + D VEN Q:'$D(X)!($P(^PRC(442,DA(1),2,DA,0),U,5)="") + S:'$D(PRC("SITE")) PRC("SITE")=$P($P(^PRC(442,DA(1),0),U,1),"-",1) S PRCHCV=$P(^PRC(442,DA(1),1),U,1),PRCHCI=$P(^(2,DA,0),U,5),PRCHCPO=DA(1) D EN0^PRCHCRD + Q + ; +EN8 ;FILE 442, CONTRACT FIELD #4 + D VEN Q:'$D(X) K DIC("S") + S Z0=$P(^PRC(442,DA(1),1),U,1),ZA=DA,ZA(1)=DA(1) + S DA(1)=Z0,DIC="^PRC(440,Z0,4,",DIC(0)="QELMZ",DLAYGO=440 + I $G(PRCHPC)!$G(PRCHDELV) S DIC(0)="QEMZ" + D EN10,^DIC S X=$P(Y,U,2),DA=ZA,DA(1)=ZA(1) K ZA K:Y'>0 X + I $D(X),$D(DT),$P(Y(0),U,2)-DT<0 W !?10,"**CONTRACT HAS EXPIRED**",$C(7),$C(7) K X,DLAYGO Q + S:'$D(PRC("SITE")) PRC("SITE")=$P($P(^PRC(442,DA(1),0),U,1),"-",1) I $P(^PRC(442,DA(1),2,DA,0),U,5)]"" S PRCHCI=$P(^(0),U,5),PRCHCV=Z0,PRCHCPO=DA(1) D EN2^PRCHCRD + K DLAYGO + Q + ; +EN9 ;FILE 442, ACTUAL UNIT COST #5 + D VEN Q:'$D(X)!($P(^PRC(442,DA(1),2,DA,0),U,5)="") + S:'$D(PRC("SITE")) PRC("SITE")=$P($P(^PRC(442,DA(1),0),U,1),"-",1) S PRCHCV=$P(^PRC(442,DA(1),1),U,1),PRCHCI=$P(^(2,DA,0),U,5),PRCHCPO=DA(1) D EN1^PRCHCRD + Q + ; +EN10 ;FILE 440 CONTRACT NUMBER + I $D(Z0) S:'$D(^PRC(440,Z0,4,0)) ^PRC(440,Z0,4,0)="^440.03I^^" + Q + ; +EN11 ;FILE 441 CONTRACT + D EN10 S DIC="^PRC(440,Z0,4,",DIC(0)="QEMLZ",DLAYGO=440,ZD=DA(1),DA(1)=Z0 D ^DIC S X=+Y K:Y'>0 X S DA(1)=ZD K ZD,Z0,DIC + I $D(X),$D(DT),$P(Y(0),U,2)-DT<0 W !?10,"**CONTRACT HAS EXPIRED**",$C(7),$C(7) K X + K DLAYGO + Q + ; +EN12 ;FILE 442, VENDOR STOCK NO.#9 + D VEN Q:'$D(X)!($P(^PRC(442,DA(1),2,DA,0),U,5)="") + S:'$D(PRC("SITE")) PRC("SITE")=+^PRC(442,DA(1),0) S PRCHCV=+$P(^PRC(442,DA(1),1),U,1),PRCHCI=+$P(^(2,DA,0),U,5),PRCHCPO=DA(1) D EN6^PRCHCRD + Q + ; +EN13 ;DIC("S") for a look-up in CONTRACT field (File 442.01,4) + S PRCHSCOD=$P($G(^PRC(442,D0,1)),U,7) + I $E(X)="?" S DIC("S")=$S(PRCHSCOD=2:"I $P(^PRC(440,Z0,4,+Y,0),U,6)'=""B""",1:"I 1") + Q + ; +EN14 ;input transform of Contract Flag field 5, file 440 + ;If PO exists, if source code=2 & contract flag is not 'C' set it 'C' + I $G(PRCHPO)>0 D + . S PRCHNOD1=$G(^PRC(442,PRCHPO,1)) + . S PRCHSOCO=$P(PRCHNOD1,U,7) + . I PRCHSOCO=2 Q:X="C" D Q + . . S X="C" + . . S ARR(1)="" + . . S ARR(2)=" Note: " + . . S ARR(3)=" This PO's Source Code is Open Market, only Contract # is a valid entry." + . . S ARR(4)=" 'C' has been entered for the Contract Flag prompt." + . . S ARR(5)=" 'B' is not allowed, system allows only 'C'." + . . S ARR(6)="" + . . D EN^DDIOL(.ARR) + . . S XQH="PRCH CONTRACT FLAG HELP" D:$E(X)="??" EN^XQH + . . Q + . Q + ; If Source code is not equal to 2, C or B is ok for contr. flag + S MSG(1)="" + S MSG(2)="Enter 'C' if the Contract Number field is a Contract #." + S MSG(2,"F")="!,?5" + S MSG(3)="Otherwise enter 'B' if it is a Basic Ordering Agreement(BOA) #." + S MSG(3,"F")="!,?5" + S MSG(4)="" + ;I PRCHSOCO'=2 D EN^DDIOL(.MSG) H 2 + ;any other route than via po + I X="B" D + . S Z=$P(^PRC(440,DA(1),4,DA,0),U) + . K:'(Z?.UN) X + . I '$D(X) S XQH="PRCH BOA" D EN^XQH + . K Z,XQH + . Q + Q + ; +VEN I $S('$D(^PRC(442,DA(1),1)):1,$P(^(1),U,1)="":1,1:0) W !!,"Vendor must be entered before items ! ",$C(7) K X + Q diff --git a/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHNPO8.m b/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHNPO8.m index 50483004..6edf92c8 100644 --- a/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHNPO8.m +++ b/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHNPO8.m @@ -1,48 +1,47 @@ -PRCHNPO8 ;WISC/RHD/DL-MISCELLANEOUS ROUTINES FROM P.O.ADD/EDIT 443.6 ;9/5/00 12:30 -V ;;5.1;IFCAP;**113**;Oct 20, 2000;Build 4 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; -EN1 ;FILE 443.6, FCP #1 - N Y - S Z0=$E($P(^PRC(443.6,DA,0),"-",2),1,2),Z1=+X D EN4^PRCHNPO6 I '$T K X,Z0,Z1 Q - S DIC="^PRC(420,PRC(""SITE""),1,",DIC(0)="QEMNZ",D="B^C" D MIX^DIC1 K:Y<0!('$D(PRC("FY"))) X K DIC,Z0,Z1 Q:'$D(X) - N CCNODE S CCNODE=$G(^PRC(420,PRC("SITE"),1,+Y,2,0)) I $P(CCNODE,U,4)'>0!(CCNODE="") W !,"The Fund Control Point selected by you, does not have any",!,"Cost Centers listed under it.",! K X Q - I $P(Y(0),U,12)'=2,$P(Y(0),U,18)="" W $C(7),!,"LOG Department Number is missing!!" K X Q - S Z0=$P(^PRC(443.6,DA,0),U,2),Z1=$P(Y(0),U,12) I Z1 I Z0=4!((Z0=3)&(Z1=3)) S Z0=$P(^PRCD(442.5,Z0,0),U,1) W $C(7),!,"Fund Control Point not valid for a "_Z0_" order." K Z0,Z1,X Q - S Z0=$P(Y(0),U,1) S:$P(Y(0),U,10)]"" PRCHN("SVC")=$P($G(^DIC(49,+$P(Y(0),U,10),0)),U,1) - S PRC("FY")=$E(100+$E(PRC("FY"),2,3)+$E(PRC("FY"),4),2,3) - I $D(^PRC(420,PRC("SITE"),1,+Y,2,0)),$P(^(0),U,4)=1,$D(^($P(^(0),U,3),0)),$D(^PRCD(420.1,+^(0),0)) S PRCHN("CC")=$P(^(0)," ",1) - S PRC("APP")="",X=Z0,PRC("BBFY")=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),+X) I PRC("BBFY")="" Q - S PRC("APP")=$P($$ACC^PRC0C(PRC("SITE"),+X_"^"_PRC("FY")_"^"_PRC("BBFY")),U,11) K Z0,Z1 - I $P($G(^PRC(420,PRC("SITE"),1,+X,0)),U,19)=1 W !,"Sorry, this FCP is inactive!",! K X Q - Q - ; -EN2 ;UPDATE BOC #3.5 - D VEN^PRCHNPO7 Q:'$D(X)!($P(^PRC(442,DA(1),2,DA,0),U,5)="") - S:'$D(PRC("SITE")) PRC("SITE")=$P($P(^PRC(442,DA(1),0),U,1),"-",1) - S PRCHCV=$P(^PRC(442,DA(1),1),U),PRCHCI=$P(^(2,DA,0),U,5) - D EN13^PRCHCRD1 - Q - ; -BBFY(PO) ;BEGINING BUDGET FISCAL YEAR CHECK/UPDATE - ; ENTERED: - ; PO = FILE 442 INTERNAL RECORD NUMBER - ; - ; RETURNED: - ; PRC("BBFY") = FOUR DIGIT YEAR (1995) - ; - ; PO IS UNCHANGED BY THIS CALL - ; - N BBFY,N0,N1,FY,P2237,SFCP,DIE,DA,DR,X,FLAG - S N0=$G(^PRC(442,PO,0)),N1=$G(^PRC(442,PO,1)) - S FY=$P(N1,U,15),FY=$E(100+$E(FY,2,3)+$E(FY,4),2,3) - S FLAG="",P2237=$P(N0,U,12) I P2237>0 D G:FLAG=1 T1 - .S FY=$$NP^PRC0B("^PRCS(410,"_P2237_",",3,11) - .I FY?2N S FY=1700+$E(FY,1,3),PRC("BBFY")=FY,FLAG=1 Q - .S FY=$$NP^PRC0B("^PRCS(410,"_P2237_",",0,1) - .S FY=$P(FY,"-",2) - .Q - S FY=$$BBFY^PRCSUT(+N0,FY,+$P(N0,U,3),1) -T1 S SFCP=$P(N0,U,19) I SFCP=1!(SFCP=2) S (PRC("BBFY"),FY)=1994 - I FY?2N S DIE="^PRC(442,",DA=PO,DR="26///^S X=FY" D ^DIE - Q +PRCHNPO8 ;WISC/RHD/DL-MISCELLANEOUS ROUTINES FROM P.O.ADD/EDIT 443.6 ;9/5/00 12:30 +V ;;5.1;IFCAP;;Oct 20, 2000 + ;Per VHA Directive 10-93-142, this routine should not be modified. + ; +EN1 ;FILE 443.6, FCP #1 + N Y + S Z0=$E($P(^PRC(443.6,DA,0),"-",2),1,2),Z1=+X D EN4^PRCHNPO6 I '$T K X,Z0,Z1 Q + S DIC="^PRC(420,PRC(""SITE""),1,",DIC(0)="QEMNZ",D="B^C" D MIX^DIC1 K:Y<0!('$D(PRC("FY"))) X K DIC,Z0,Z1 Q:'$D(X) + N CCNODE S CCNODE=$G(^PRC(420,PRC("SITE"),1,+Y,2,0)) I $P(CCNODE,U,4)'>0!(CCNODE="") W !,"The Fund Control Point selected by you, does not have any",!,"Cost Centers listed under it.",! K X Q + I $P(Y(0),U,12)'=2,$P(Y(0),U,18)="" W $C(7),!,"LOG Department Number is missing!!" K X Q + S Z0=$P(^PRC(443.6,DA,0),U,2),Z1=$P(Y(0),U,12) I Z1 I Z0=4!((Z0=3)&(Z1=3)) S Z0=$P(^PRCD(442.5,Z0,0),U,1) W $C(7),!,"Fund Control Point not valid for a "_Z0_" order." K Z0,Z1,X Q + S Z0=$P(Y(0),U,1) S:$P(Y(0),U,10)]"" PRCHN("SVC")=$P($G(^DIC(49,+$P(Y(0),U,10),0)),U,1) + S PRC("FY")=$E(100+$E(PRC("FY"),2,3)+$E(PRC("FY"),4),2,3) + I $D(^PRC(420,PRC("SITE"),1,+Y,2,0)),$P(^(0),U,4)=1,$D(^($P(^(0),U,3),0)),$D(^PRCD(420.1,+^(0),0)) S PRCHN("CC")=$P(^(0)," ",1) + S PRC("APP")="",X=Z0,PRC("BBFY")=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),+X) I PRC("BBFY")="" Q + S PRC("APP")=$P($$ACC^PRC0C(PRC("SITE"),+X_"^"_PRC("FY")_"^"_PRC("BBFY")),U,11) K Z0,Z1 + Q + ; +EN2 ;UPDATE BOC #3.5 + D VEN^PRCHNPO7 Q:'$D(X)!($P(^PRC(442,DA(1),2,DA,0),U,5)="") + S:'$D(PRC("SITE")) PRC("SITE")=$P($P(^PRC(442,DA(1),0),U,1),"-",1) + S PRCHCV=$P(^PRC(442,DA(1),1),U),PRCHCI=$P(^(2,DA,0),U,5) + D EN13^PRCHCRD1 + Q + ; +BBFY(PO) ;BEGINING BUDGET FISCAL YEAR CHECK/UPDATE + ; ENTERED: + ; PO = FILE 442 INTERNAL RECORD NUMBER + ; + ; RETURNED: + ; PRC("BBFY") = FOUR DIGIT YEAR (1995) + ; + ; PO IS UNCHANGED BY THIS CALL + ; + N BBFY,N0,N1,FY,P2237,SFCP,DIE,DA,DR,X,FLAG + S N0=$G(^PRC(442,PO,0)),N1=$G(^PRC(442,PO,1)) + S FY=$P(N1,U,15),FY=$E(100+$E(FY,2,3)+$E(FY,4),2,3) + S FLAG="",P2237=$P(N0,U,12) I P2237>0 D G:FLAG=1 T1 + .S FY=$$NP^PRC0B("^PRCS(410,"_P2237_",",3,11) + .I FY?2N S FY=1700+$E(FY,1,3),PRC("BBFY")=FY,FLAG=1 Q + .S FY=$$NP^PRC0B("^PRCS(410,"_P2237_",",0,1) + .S FY=$P(FY,"-",2) + .Q + S FY=$$BBFY^PRCSUT(+N0,FY,+$P(N0,U,3),1) +T1 S SFCP=$P(N0,U,19) I SFCP=1!(SFCP=2) S (PRC("BBFY"),FY)=1994 + I FY?2N S DIE="^PRC(442,",DA=PO,DR="26///^S X=FY" D ^DIE + Q diff --git a/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHPCAR.m b/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHPCAR.m index 0b1e163e..fa6fec20 100644 --- a/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHPCAR.m +++ b/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHPCAR.m @@ -1,96 +1,84 @@ -PRCHPCAR ;WISC/AKS-Front End questions for Purchase Card processes ;6/9/96 21:40 - ;;5.1;IFCAP;**113**;Oct 20, 2000;Build 4 - ;Per VHA Directive 2004-038, this routine should not be modified. -ASKPO ;Ask If they are processing a purchase or a requisition - N DIR,Y,PRCHPR,PRCHNE - S DIR(0)="SO^P:PURCHASE ORDER;R:REQUISITION" - S DIR("A")="Select THE TYPE OF ORDER" - D ^DIR Q:Y']""!(Y["^") S PRCHPR=Y -ENTED ;Ask if they are entering or editting - S DIR(0)="SO^N:NEW;E:EDIT AN EXISTING ORDER" - S DIR("A")="Select TYPE OF PROCESSING" - D ^DIR G:Y']"" ASKPO Q:Y["^" S PRCHNE=Y - I $G(PRCHPR)="P"&(PRCHNE="N") D EN5^PRCHE Q - I $G(PRCHPR)="P"&(PRCHNE="E") D EN6^PRCHE Q - I $G(PRCHPR)="R"&(PRCHNE="N") D EN3^PRCHEA Q - I $G(PRCHPR)="R"&(PRCHNE="E") D EN4^PRCHEA Q - I '$D(PRCHPR)&(PRCHNE="N") D EN5^PRCHE Q - I '$D(PRCHPR)&(PRCHNE="E") D EN6^PRCHE Q - QUIT -AMPO ;ask if they are amending a po or a requisition - N DIR,Y - S DIR(0)="SO^P:AMEND A PURCHASE ORDER;R:AMEND A REQUISITION" - S DIR("A")="Select THE TYPE OF ORDER" - D ^DIR - I Y="P" D PO^PRCHMA Q - I Y="R" D REQ^PRCHMA Q - QUIT -ADJPO ;ask if they are adjusting a po or requisition - N DIR,Y - S DIR(0)="SO^P:Adjustment Voucher to a PO;R:Adjustment Voucher to a Requisition" - S DIR("A")="Select THE TYPE OF ORDER" - D ^DIR - I Y="P" D EN14^PRCHE Q - I Y="R" D EN2^PRCHEB Q - QUIT -DIRPO ;Ask type of amendments for purchase card and delivery orders - ; - N PRCHTYPE,DIR - S PRCHTYPE=$P($G(^PRC(442,PRCHPO,23)),U,11) - Q:PRCHTYPE="" - S:PRCHTYPE="S" DIR(0)="SO^1:F.C.P. Edit;2:Change VENDOR;3:AUTHORITY Edit;4:LINE ITEM Edit" - S:PRCHTYPE="P" DIR(0)="SO^1:F.C.P. Edit;2:Change VENDOR;3:AUTHORITY Edit;4:LINE ITEM Add;5:LINE ITEM Delete;6:LINE ITEM Edit;7:F.O.B. Point" - S:PRCHTYPE="D" DIR(0)="SO^1:Change VENDOR;2:AUTHORITY Edit;3:LINE ITEM Add;4:LINE ITEM Delete;5:LINE ITEM Edit;6:F.O.B. Point;7:SHIP TO Edit;8:Edit MAIL INVOICE TO;9:EST. SHIPPING Edit;10:PROMPT PAYMENT Edit" - S DIR("A")="Select TYPE OF AMENDMENT NUMBER" - D ^DIR - I PRCHTYPE="S" S:$G(Y)=4 Y=6 - I PRCHTYPE="D",$G(Y) S Y=Y+1 - S Y=$S(Y=1:30,Y=2:31,Y=3:34,Y=4:21,Y=5:22,Y=6:23,Y=7:35,Y=8:20,Y=9:25,Y=10:29,Y=11:33,1:-1) - QUIT -DIRREQ ;Ask type of amendments for purchase card and delivery orders - ; - N PRCHTYPE,DIR - S PRCHTYPE=$P($G(^PRC(442,PRCHPO,23)),U,11) - Q:PRCHTYPE="" - S:PRCHTYPE="S" DIR(0)="SO^1:F.C.P. Edit;2:Change FEDERAL VENDOR" - S:PRCHTYPE="P" DIR(0)="SO^1:F.C.P. Edit;2:Change FEDERAL VENDOR;3:LINE ITEM Add;4:LINE ITEM Delete;5:LINE ITEM Edit" - S:PRCHTYPE="D" DIR(0)="SO^1:Change FEDERAL VENDOR;2:LINE ITEM Add;3:LINE ITEM Delete;4:LINE ITEM Edit;5:SHIP TO Edit;6:Edit MAIL INVOICE TO;7:EST. SHIPPING Edit" - S DIR("A")="Select TYPE OF AMENDMENT NUMBER" - D ^DIR - I PRCHTYPE="D",$G(Y) S Y=Y+1 - S Y=$S(Y=1:30,Y=2:31,Y=3:21,Y=4:22,Y=5:23,Y=6:20,Y=7:25,Y=8:29,1:-1) - QUIT -CANPC ;Cancel a purchase card order - W ! S DIC="^PRC(442,",DIC(0)="AEQM" - S DIC("A")="Select PURCHASE CARD ORDER NUMBER: " - S DIC("S")="I $P($G(^(7)),U,2)<9,$P($G(^(1)),U,10)=DUZ,$P($G(^(0)),U,2)=25,($P($G(^(23)),U,11)=""P""!($P($G(^(23)),U,11)=""S""))" - D ^DIC Q:+Y<0 K DIC - S %A="Are sure you want to cancel this order",%B="",%=2 - D ^PRCFYN I %<1!(%=2) K %A,%B,% Q - S DA=+Y,DIE="^PRC(442,",DR=".5///^S X=45" D ^DIE K DIE,DR - D C2237^PRCH442A - K DA,%A,%B,% - QUIT -CANDO ;Cancel a delivery order - W ! S DIC="^PRC(442,",DIC(0)="AEQM" - S DIC("A")="Select DELIVERY ORDER NUMBER: " - S DIC("S")="I $P($G(^(7)),U,2)<9,$P($G(^(23)),U,11)=""D""" - D ^DIC Q:+Y<0 K DIC - S %A="Are sure you want to cancel this order",%B="",%=2 - D ^PRCFYN I %<1!(%=2) K %A,%B,% Q - S DA=+Y,DIE="^PRC(442,",DR=".5///^S X=45" D ^DIE K DIE,DR - D C2237^PRCH442A - K DA,%A,%B,% - QUIT -AOCANPC ;Approving Official Cancel a purchase card order - N DIC,Y,NREC,X - W ! S DIC="^PRC(442,",DIC(0)="AEQM" - S DIC("A")="Select PURCHASE CARD ORDER NUMBER: " - S DIC("S")="I $P($G(^(7)),U,2)<9,$P($G(^(0)),U,2)=25,($P($G(^(23)),U,11)=""P""!($P($G(^(23)),U,11)=""S""))" - D ^DIC Q:+Y<0 K DIC - S %A="Are sure you want to cancel this order",%B="",%=2 - D ^PRCFYN I %<1!(%=2) K %A,%B,% Q - S DA=+Y,DIE="^PRC(442,",DR=".5///^S X=45" D ^DIE K DIE,DR - D C2237^PRCH442A - K DA,%A,%B,% - QUIT +PRCHPCAR ;WISC/AKS-Front End questions for Purchase Card processes ;6/9/96 21:40 + ;;5.1;IFCAP;;Oct 20, 2000 + ;Per VHA Directive 10-93-142, this routine should not be modified. +ASKPO ;Ask If they are processing a purchase or a requisition + N DIR,Y,PRCHPR,PRCHNE + S DIR(0)="SO^P:PURCHASE ORDER;R:REQUISITION" + S DIR("A")="Select THE TYPE OF ORDER" + D ^DIR Q:Y']""!(Y["^") S PRCHPR=Y +ENTED ;Ask if they are entering or editting + S DIR(0)="SO^N:NEW;E:EDIT AN EXISTING ORDER" + S DIR("A")="Select TYPE OF PROCESSING" + D ^DIR G:Y']"" ASKPO Q:Y["^" S PRCHNE=Y + I $G(PRCHPR)="P"&(PRCHNE="N") D EN5^PRCHE Q + I $G(PRCHPR)="P"&(PRCHNE="E") D EN6^PRCHE Q + I $G(PRCHPR)="R"&(PRCHNE="N") D EN3^PRCHEA Q + I $G(PRCHPR)="R"&(PRCHNE="E") D EN4^PRCHEA Q + I '$D(PRCHPR)&(PRCHNE="N") D EN5^PRCHE Q + I '$D(PRCHPR)&(PRCHNE="E") D EN6^PRCHE Q + QUIT +AMPO ;ask if they are amending a po or a requisition + N DIR,Y + S DIR(0)="SO^P:AMEND A PURCHASE ORDER;R:AMEND A REQUISITION" + S DIR("A")="Select THE TYPE OF ORDER" + D ^DIR + I Y="P" D PO^PRCHMA Q + I Y="R" D REQ^PRCHMA Q + QUIT +ADJPO ;ask if they are adjusting a po or requisition + N DIR,Y + S DIR(0)="SO^P:Adjustment Voucher to a PO;R:Adjustment Voucher to a Requisition" + S DIR("A")="Select THE TYPE OF ORDER" + D ^DIR + I Y="P" D EN14^PRCHE Q + I Y="R" D EN2^PRCHEB Q + QUIT +DIRPO ;Ask type of amendments for purchase card and delivery orders + ; + N PRCHTYPE,DIR + S PRCHTYPE=$P($G(^PRC(442,PRCHPO,23)),U,11) + Q:PRCHTYPE="" + S:PRCHTYPE="S" DIR(0)="SO^1:F.C.P. Edit;2:Change VENDOR;3:AUTHORITY Edit;4:LINE ITEM Edit" + S:PRCHTYPE="P" DIR(0)="SO^1:F.C.P. Edit;2:Change VENDOR;3:AUTHORITY Edit;4:LINE ITEM Add;5:LINE ITEM Delete;6:LINE ITEM Edit;7:F.O.B. Point" + S:PRCHTYPE="D" DIR(0)="SO^1:Change VENDOR;2:AUTHORITY Edit;3:LINE ITEM Add;4:LINE ITEM Delete;5:LINE ITEM Edit;6:F.O.B. Point;7:SHIP TO Edit;8:Edit MAIL INVOICE TO;9:EST. SHIPPING Edit;10:PROMPT PAYMENT Edit" + S DIR("A")="Select TYPE OF AMENDMENT NUMBER" + D ^DIR + I PRCHTYPE="S" S:$G(Y)=4 Y=6 + I PRCHTYPE="D",$G(Y) S Y=Y+1 + S Y=$S(Y=1:30,Y=2:31,Y=3:34,Y=4:21,Y=5:22,Y=6:23,Y=7:35,Y=8:20,Y=9:25,Y=10:29,Y=11:33,1:-1) + QUIT +DIRREQ ;Ask type of amendments for purchase card and delivery orders + ; + N PRCHTYPE,DIR + S PRCHTYPE=$P($G(^PRC(442,PRCHPO,23)),U,11) + Q:PRCHTYPE="" + S:PRCHTYPE="S" DIR(0)="SO^1:F.C.P. Edit;2:Change FEDERAL VENDOR" + S:PRCHTYPE="P" DIR(0)="SO^1:F.C.P. Edit;2:Change FEDERAL VENDOR;3:LINE ITEM Add;4:LINE ITEM Delete;5:LINE ITEM Edit" + S:PRCHTYPE="D" DIR(0)="SO^1:Change FEDERAL VENDOR;2:LINE ITEM Add;3:LINE ITEM Delete;4:LINE ITEM Edit;5:SHIP TO Edit;6:Edit MAIL INVOICE TO;7:EST. SHIPPING Edit" + S DIR("A")="Select TYPE OF AMENDMENT NUMBER" + D ^DIR + I PRCHTYPE="D",$G(Y) S Y=Y+1 + S Y=$S(Y=1:30,Y=2:31,Y=3:21,Y=4:22,Y=5:23,Y=6:20,Y=7:25,Y=8:29,1:-1) + QUIT +CANPC ;Cancel a purchase card order + W ! S DIC="^PRC(442,",DIC(0)="AEQM" + S DIC("A")="Select PURCHASE CARD ORDER NUMBER: " + S DIC("S")="I $P($G(^(7)),U,2)<9,$P($G(^(1)),U,10)=DUZ,$P($G(^(0)),U,2)=25,($P($G(^(23)),U,11)=""P""!($P($G(^(23)),U,11)=""S""))" + D ^DIC Q:+Y<0 K DIC + S %A="Are sure you want to cancel this order",%B="",%=2 + D ^PRCFYN I %<1!(%=2) K %A,%B,% Q + S DA=+Y,DIE="^PRC(442,",DR=".5///^S X=45" D ^DIE K DIE,DR + D C2237^PRCH442A + K DA,%A,%B,% + QUIT +CANDO ;Cancel a delivery order + W ! S DIC="^PRC(442,",DIC(0)="AEQM" + S DIC("A")="Select DELIVERY ORDER NUMBER: " + S DIC("S")="I $P($G(^(7)),U,2)<9,$P($G(^(23)),U,11)=""D""" + D ^DIC Q:+Y<0 K DIC + S %A="Are sure you want to cancel this order",%B="",%=2 + D ^PRCFYN I %<1!(%=2) K %A,%B,% Q + S DA=+Y,DIE="^PRC(442,",DR=".5///^S X=45" D ^DIE K DIE,DR + D C2237^PRCH442A + K DA,%A,%B,% + QUIT diff --git a/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHQ4.m b/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHQ4.m index 7b0e0810..4249b20c 100644 --- a/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHQ4.m +++ b/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHQ4.m @@ -1,143 +1,143 @@ -PRCHQ4 ;WOIFO/LKG-RFQ Set up Transmission Records ;7/25/05 15:27 - ;;5.1;IFCAP;**63,114**;Oct 20, 2000;Build 4 - ;Per VHA Directive 2004-038, this routine should not be modified. -HE ;Set up Heading segment - N PRCN0,PRCN1,PRCA,PRCB,PRCZ,DA,DIC,DR,DIQ,X,Y - S PRCN0=$G(^PRC(444,PRCDA,0)),PRCN1=$G(^PRC(444,PRCDA,1)) - S X=$P(PRCN0,U,2) D JDN^PRCUTL S PRCA="HE^^"_Y_"^^" - S X=$P(PRCN1,U,2) D JDN^PRCUTL S PRCA=PRCA_Y_"^" - S PRCB=$P(PRCN0,U,3),X=$P(PRCB,".") D JDN^PRCUTL S X=$P(PRCB,".",2) - S X=X_$E("000000",$L(X)+1,6),PRCA=PRCA_Y_"^"_X_"^^^^^0^0^0^^^^^|" - K DA S DA=$P(PRCN0,U,4) I DA?1.N D - . K ^UTILITY("DIQ1",$J) - . S DIC=200,DR=".01;.135",DIQ(0)="I" D EN^DIQ1 K DIC,DIQ,DR - . S $P(PRCA,"^",8,9)=^UTILITY("DIQ1",$J,200,DA,.01,"I")_"^"_^UTILITY("DIQ1",$J,200,DA,.135,"I") - . K ^UTILITY("DIQ1",$J) - S ^TMP($J,"STRING",1)=PRCA - I $P(PRCA,U,3)'?7N S PRCZ(1)="Invalid RFQ Reference Date" - I $P(PRCA,U,5)'?7N S PRCZ(2)="Invalid Requested Delivery Date" - I $P(PRCA,U,6)'?7N S PRCZ(3)="Invalid RFQ Bids Due Date" - I $P(PRCA,U,7)'?6N S PRCZ(4)="Invalid RFQ Bids Due Time" - I $P(PRCA,U,8)="" S PRCZ(5)="Contracting Officer's Name is missing" - I $P(PRCA,U,9)="" S PRCZ(6)="Contracting Officer's Commercial Phone # is missing" - I $D(PRCZ) S PRCERR=3 D EN^DDIOL(.PRCZ) - Q -VELST(PRCN) ;Gets list of solicited vendors from RFQ and invokes 'VE' setup - N PRCX,PRCY,X,PRCW S PRCX=0,PRCW=0 - F S PRCX=$O(^PRC(444,PRCDA,5,PRCX)) Q:PRCX'?1.N D - . S PRCY=$G(^PRC(444,PRCDA,5,PRCX,0)) Q:PRCY="" - . S:$P(PRCY,U,2)="" $P(PRCY,U,2)=$P(^PRC(444,PRCDA,0),U,7),$P(^PRC(444,PRCDA,5,PRCX,0),U,2)=$P(PRCY,U,2) - . Q:";b;e;"'[(";"_$P(PRCY,U,2)_";") - . S PRCY=$P(PRCY,U) - . S X=$S(PRCY["PRC(440,":$P($G(^PRC(440,$P(PRCY,";"),7)),U,12),1:$P($G(^PRC(444.1,$P(PRCY,";"),0)),U,2)) - . I X="" D DUNERR(PRCY) Q - . D VE(X,.PRCN) S PRCW=PRCW+1 - I $P($G(^PRC(444,PRCDA,1)),U,8)="y" D VE("PUBLIC",.PRCN) S PRCW=PRCW+1 - Q PRCW -VE(PRCD,PRCC) ;Set up Vendor segment - S PRCC=PRCC+1 - S ^TMP($J,"STRING",PRCC)="VE^"_PRCD_"^^^^^^^^^^^^^^^^^^|" - S ^TMP($J,"VE",PRCD)="" - Q -ST(PRCC) ;Setting up Ship to segment - N PRCX,PRCY,DA,DIC,DR - S PRCY=$G(^PRC(444,PRCDA,0)),PRCX=$P(PRCY,U,10) - S:PRCX="" PRCX=$E($P(PRCY,U),1,3) - S PRCY=$P($G(^PRC(444,PRCDA,1)),U,3) Q:PRCY'?1.N - S PRCX=$G(^PRC(411,PRCX,1,PRCY,0)) Q:PRCX="" - S PRCC=PRCC+1 - I $P(PRCX,U,9)]"" S ^TMP($J,"STRING",PRCC)="ST^"_$P(PRCX,U,9)_"^^^^^^^^^|" G STX - S PRCY="ST^^"_$P(PRCX,U)_"^"_$P(PRCX,U,2)_"^"_$P(PRCX,U,3)_"^"_$P(PRCX,U,4) - S PRCY=PRCY_"^^"_$P(PRCX,U,5)_"^^"_$TR($P(PRCX,U,7),"-")_"^|" - S DA=$P(PRCX,U,6) I DA?1.N D - . K ^UTILITY("DIQ1",$J) S DIC=5,DR=1 D EN^DIQ1 - . S $P(PRCY,U,9)=$E(^UTILITY("DIQ1",$J,5,DA,1),1,2) K ^UTILITY("DIQ1",$J) - S ^TMP($J,"STRING",PRCC)=PRCY -STX Q -MI(PRCRFQ,PRCC) ;Set up Miscellaneous Information segment - N PRCY - S PRCY="MI^^^^"_PRCRFQ_"^^^^^^|",PRCC=PRCC+1 - S ^TMP($J,"STRING",PRCC)=PRCY - Q -AC(PRCC) ;Set up Accounting Information segment - N PRCY - S PRCY="AC^^"_$P($G(^PRC(444,PRCDA,1)),U)_"^^^^^^^^^^^^^^^^|",PRCC=PRCC+1 - S ^TMP($J,"STRING",PRCC)=PRCY - Q -TX(PRCN,PRCC) ;Set up Text segment (i.e. Administrative Certification - ;;or 864 text) - ;;Syntax of call: S X=$$TX^PRCHQ4(ARG1,.ARG2) - ;; Returns number of lines in reformatted Word Processing field - ;;ARG1: CLOSED GLOBAL ROOT - ;;ARG2: CURRENT MESSAGE LINE COUNT - N PRCI,PRCT,PRCX,X,DIWL,DIWR,DIWF - S PRCX=0,DIWL=1,DIWR=70,DIWF="" K ^UTILITY($J,"W") - F S PRCX=$O(@PRCN@(PRCX)) Q:PRCX="" D - . Q:'$D(@PRCN@(PRCX,0)) S X=@PRCN@(PRCX,0) D ^DIWP - ;I PRCN="^PRC(444,PRCDA,4)",$G(PRCTYPE)="00",$P($G(^PRC(444,PRCDA,1)),U,8)="y" D - ;. S X="If you are not an electronic trading partner with VA, you may submit" D ^DIWP - ;. S X="your bid by mail or FAX to the Contracting Office. If you would" D ^DIWP - ;. S X="like to register as a VA Electronic Trading Partner, please contact" D ^DIWP - ;. S X="your Software Provider or VA EDI Staff at 512-326-6463." D ^DIWP - S PRCT=$G(^UTILITY($J,"W",1))+0 - F PRCI=1:1:PRCT D - . S PRCC=PRCC+1,X=$G(^UTILITY($J,"W",1,PRCI,0)) S:$L(X)=0 X=" " S X=$TR(X,"^") - . S ^TMP($J,"STRING",PRCC)="TX^"_PRCI_"^"_X_"^|" - K ^UTILITY($J,"W") - Q PRCT -IT(PRCC) ;Set up Item segment (Also calls SC and DE to set up Delivery - ;;Schedule and Description segments for item.) - N PRCA,PRCB,PRCD,PRCE,PRCF,PRCG,PRCH,PRCK,PRCL,PRCY,PRCCNT - S PRCA=0,PRCCNT=0 - F S PRCA=$O(^PRC(444,PRCDA,2,PRCA)) Q:PRCA'?1.N D - . S PRCL=0 - . S PRCB=$G(^PRC(444,PRCDA,2,PRCA,0)) Q:PRCB="" - . S PRCD=$G(^PRC(444,PRCDA,2,PRCA,1)),PRCG=$P(PRCB,U) - . S PRCY="IT^"_PRCG_"^"_$S($P(PRCB,U,6)]"":$P(PRCB,U,6),$P(PRCB,U,5)>0:$P($G(^PRC(441.2,$P(PRCB,U,5),0)),U),1:"")_"^^^",PRCCNT=PRCCNT+1 - . I $P($G(^PRC(444,PRCDA,5,0)),U,4)=1,$P($G(^PRC(444,PRCDA,1)),U,8)'="y" S $P(PRCY,U,5)=$P($G(^PRC(444,PRCDA,2,PRCA,5)),U,2) - . S PRCY=PRCY_$P(PRCB,U,9)_"^"_$P(PRCB,U,8)_"^"_($P(PRCB,U,2)*100)_"^^" - . S PRCE=$P(PRCB,U,3) S:PRCE?1.N PRCH=$P($G(^PRCD(420.5,PRCE,0)),U),$P(PRCY,U,9)=PRCH - . S PRCY=PRCY_"^^^^^^^^^^^^^" - . S PRCE=$P(PRCB,U,7) S:PRCE?1.N PRCE=$P($P($G(^PRC(444.2,PRCE,0)),U)," "),$P(PRCY,U,22)=PRCE - . S $P(PRCY,U,23,29)=$P(PRCD,U)_"^"_$P(PRCD,U,2)_"^"_$P(PRCB,U,11)_"^"_$P($G(^PRC(444,PRCDA,1)),U)_"^^^|" - . S PRCC=PRCC+1,^TMP($J,"STRING",PRCC)=PRCY - . S PRCF=PRCC - . S $P(^TMP($J,"STRING",PRCF),U,21)=$$DE("^PRC(444,PRCDA,2,PRCA,2)",PRCG,.PRCC) - . S $P(^TMP($J,"STRING",PRCF),U,27)=$$SC("^PRC(444,PRCDA,2,PRCA,4)",PRCG,PRCH,.PRCC,.PRCL) - . I $P(^TMP($J,"STRING",PRCF),U,3)="" S PRCK(1)="Item #"_$P(PRCB,U)_": FSC and NSN missing" - . I $P(^TMP($J,"STRING",PRCF),U,8)'>0 S PRCK(2)="Item #"_$P(PRCB,U)_": Quantity not greater than zero" - . I $P(^TMP($J,"STRING",PRCF),U,9)="" S PRCK(3)="Item #"_$P(PRCB,U)_": Unit of Purchase missing" - . I $P(^TMP($J,"STRING",PRCF),U,22)="" S PRCK(4)="Item #"_$P(PRCB,U)_": SIC Code missing" - . I $P(^TMP($J,"STRING",PRCF),U,21)'>0 S PRCK(5)="Item #"_$P(PRCB,U)_": Item Description missing" - . I $P(^TMP($J,"STRING",PRCF),U,27)>0,$P(^(PRCF),U,8)'=PRCL S PRCK(6)="Item #"_$P(PRCB,U)_": Total of Delivery Schedule NOT EQUAL to Line Quantity" - S:PRCCNT>0 $P(^TMP($J,"STRING",1),U,12)=PRCCNT - I PRCCNT'>0 S PRCK(7)="No Items in RFQ" - I $D(PRCK) S PRCERR=2 D EN^DDIOL(.PRCK) - Q -SC(PRCN,PRCIT,PRCU,PRCC,PRCJ) ;Set up Delivery Schedule for item - N PRCW,PRCX,PRCY,PRCZ,X,Y - S PRCX=0,PRCW=0 - F S PRCX=$O(@PRCN@(PRCX)) Q:PRCX'?1.N D - . S PRCZ=$G(@PRCN@(PRCX,0)) Q:PRCZ="" - . S X=$P(PRCZ,U,2) D JDN^PRCUTL - . S PRCY="SC^"_PRCIT_"^"_$P(PRCZ,U)_"^"_($P(PRCZ,U,3)*100)_"^"_PRCU - . S PRCY=PRCY_"^"_Y_"^|",PRCC=PRCC+1,PRCJ=PRCJ+$P(PRCY,U,4) - . S ^TMP($J,"STRING",PRCC)=PRCY,PRCW=PRCW+1 - Q PRCW -DE(PRCN,PRCIT,PRCC) ;Set up Item Description segments - N PRCI,PRCT,PRCX,X,DIWL,DIWR,DIWF - S PRCX=0,DIWL=1,DIWR=70,DIWF="" K ^UTILITY($J,"W") - F S PRCX=$O(@PRCN@(PRCX)) Q:PRCX="" D - . Q:'$D(@PRCN@(PRCX,0)) S X=@PRCN@(PRCX,0) D ^DIWP - S PRCT=$G(^UTILITY($J,"W",1)) - F PRCI=1:1:PRCT D - . S PRCC=PRCC+1,X=$G(^UTILITY($J,"W",1,PRCI,0)) S:$L(X)=0 X=" " S X=$TR(X,"^") - . S ^TMP($J,"STRING",PRCC)="DE^"_PRCIT_"^"_PRCI_"^"_X_"^|" - K ^UTILITY($J,"W") - Q PRCT -DUNERR(PRCA) ;Displays the Error Message for Vendor Lacking Dun # - Q:$D(ZTQUEUED) - N PRCB S PRCB="^"_$P(PRCA,";",2)_$P(PRCA,";")_",0)" - S PRCB=$P(@PRCB,U)_" lacks a Dun # so NOT a recipient" - D EN^DDIOL(PRCB) - Q +PRCHQ4 ;WOIFO/LKG-RFQ Set up Transmission Records ;7/25/05 15:27 + ;;5.1;IFCAP;**63**;Oct 20, 2000 + ;Per VHA Directive 10-93-142, this routine should not be modified. +HE ;Set up Heading segment + N PRCN0,PRCN1,PRCA,PRCB,PRCZ,DA,DIC,DR,DIQ,X,Y + S PRCN0=$G(^PRC(444,PRCDA,0)),PRCN1=$G(^PRC(444,PRCDA,1)) + S X=$P(PRCN0,U,2) D JDN^PRCUTL S PRCA="HE^^"_Y_"^^" + S X=$P(PRCN1,U,2) D JDN^PRCUTL S PRCA=PRCA_Y_"^" + S PRCB=$P(PRCN0,U,3),X=$P(PRCB,".") D JDN^PRCUTL S X=$P(PRCB,".",2) + S X=X_$E("000000",$L(X)+1,6),PRCA=PRCA_Y_"^"_X_"^^^^^0^0^0^^^^^|" + K DA S DA=$P(PRCN0,U,4) I DA?1.N D + . K ^UTILITY("DIQ1",$J) + . S DIC=200,DR=".01;.135",DIQ(0)="I" D EN^DIQ1 K DIC,DIQ,DR + . S $P(PRCA,"^",8,9)=^UTILITY("DIQ1",$J,200,DA,.01,"I")_"^"_^UTILITY("DIQ1",$J,200,DA,.135,"I") + . K ^UTILITY("DIQ1",$J) + S ^TMP($J,"STRING",1)=PRCA + I $P(PRCA,U,3)'?7N S PRCZ(1)="Invalid RFQ Reference Date" + I $P(PRCA,U,5)'?7N S PRCZ(2)="Invalid Requested Delivery Date" + I $P(PRCA,U,6)'?7N S PRCZ(3)="Invalid RFQ Bids Due Date" + I $P(PRCA,U,7)'?6N S PRCZ(4)="Invalid RFQ Bids Due Time" + I $P(PRCA,U,8)="" S PRCZ(5)="Contracting Officer's Name is missing" + I $P(PRCA,U,9)="" S PRCZ(6)="Contracting Officer's Commercial Phone # is missing" + I $D(PRCZ) S PRCERR=3 D EN^DDIOL(.PRCZ) + Q +VELST(PRCN) ;Gets list of solicited vendors from RFQ and invokes 'VE' setup + N PRCX,PRCY,X,PRCW S PRCX=0,PRCW=0 + F S PRCX=$O(^PRC(444,PRCDA,5,PRCX)) Q:PRCX'?1.N D + . S PRCY=$G(^PRC(444,PRCDA,5,PRCX,0)) Q:PRCY="" + . S:$P(PRCY,U,2)="" $P(PRCY,U,2)=$P(^PRC(444,PRCDA,0),U,7),$P(^PRC(444,PRCDA,5,PRCX,0),U,2)=$P(PRCY,U,2) + . Q:";b;e;"'[(";"_$P(PRCY,U,2)_";") + . S PRCY=$P(PRCY,U) + . S X=$S(PRCY["PRC(440,":$P($G(^PRC(440,$P(PRCY,";"),7)),U,12),1:$P($G(^PRC(444.1,$P(PRCY,";"),0)),U,2)) + . I X="" D DUNERR(PRCY) Q + . D VE(X,.PRCN) S PRCW=PRCW+1 + I $P($G(^PRC(444,PRCDA,1)),U,8)="y" D VE("PUBLIC",.PRCN) S PRCW=PRCW+1 + Q PRCW +VE(PRCD,PRCC) ;Set up Vendor segment + S PRCC=PRCC+1 + S ^TMP($J,"STRING",PRCC)="VE^"_PRCD_"^^^^^^^^^^^^^^^^^^|" + S ^TMP($J,"VE",PRCD)="" + Q +ST(PRCC) ;Setting up Ship to segment + N PRCX,PRCY,DA,DIC,DR + S PRCY=$G(^PRC(444,PRCDA,0)),PRCX=$P(PRCY,U,10) + S:PRCX="" PRCX=$E($P(PRCY,U),1,3) + S PRCY=$P($G(^PRC(444,PRCDA,1)),U,3) Q:PRCY'?1.N + S PRCX=$G(^PRC(411,PRCX,1,PRCY,0)) Q:PRCX="" + S PRCC=PRCC+1 + I $P(PRCX,U,9)]"" S ^TMP($J,"STRING",PRCC)="ST^"_$P(PRCX,U,9)_"^^^^^^^^^|" G STX + S PRCY="ST^^"_$P(PRCX,U)_"^"_$P(PRCX,U,2)_"^"_$P(PRCX,U,3)_"^"_$P(PRCX,U,4) + S PRCY=PRCY_"^^"_$P(PRCX,U,5)_"^^"_$TR($P(PRCX,U,7),"-")_"^|" + S DA=$P(PRCX,U,6) I DA?1.N D + . K ^UTILITY("DIQ1",$J) S DIC=5,DR=1 D EN^DIQ1 + . S $P(PRCY,U,9)=$E(^UTILITY("DIQ1",$J,5,DA,1),1,2) K ^UTILITY("DIQ1",$J) + S ^TMP($J,"STRING",PRCC)=PRCY +STX Q +MI(PRCRFQ,PRCC) ;Set up Miscellaneous Information segment + N PRCY + S PRCY="MI^^^^"_PRCRFQ_"^^^^^^|",PRCC=PRCC+1 + S ^TMP($J,"STRING",PRCC)=PRCY + Q +AC(PRCC) ;Set up Accounting Information segment + N PRCY + S PRCY="AC^^"_$P($G(^PRC(444,PRCDA,1)),U)_"^^^^^^^^^^^^^^^^|",PRCC=PRCC+1 + S ^TMP($J,"STRING",PRCC)=PRCY + Q +TX(PRCN,PRCC) ;Set up Text segment (i.e. Administrative Certification + ;;or 864 text) + ;;Syntax of call: S X=$$TX^PRCHQ4(ARG1,.ARG2) + ;; Returns number of lines in reformatted Word Processing field + ;;ARG1: CLOSED GLOBAL ROOT + ;;ARG2: CURRENT MESSAGE LINE COUNT + N PRCI,PRCT,PRCX,X,DIWL,DIWR,DIWF + S PRCX=0,DIWL=1,DIWR=70,DIWF="" K ^UTILITY($J,"W") + F S PRCX=$O(@PRCN@(PRCX)) Q:PRCX="" D + . Q:'$D(@PRCN@(PRCX,0)) S X=@PRCN@(PRCX,0) D ^DIWP + ;I PRCN="^PRC(444,PRCDA,4)",$G(PRCTYPE)="00",$P($G(^PRC(444,PRCDA,1)),U,8)="y" D + ;. S X="If you are not an electronic trading partner with VA, you may submit" D ^DIWP + ;. S X="your bid by mail or FAX to the Contracting Office. If you would" D ^DIWP + ;. S X="like to register as a VA Electronic Trading Partner, please contact" D ^DIWP + ;. S X="your Software Provider or VA EDI Staff at 512-326-6463." D ^DIWP + S PRCT=$G(^UTILITY($J,"W",1))+0 + F PRCI=1:1:PRCT D + . S PRCC=PRCC+1,X=$G(^UTILITY($J,"W",1,PRCI,0)) S:$L(X)=0 X=" " S X=$TR(X,"^") + . S ^TMP($J,"STRING",PRCC)="TX^"_PRCI_"^"_X_"^|" + K ^UTILITY($J,"W") + Q PRCT +IT(PRCC) ;Set up Item segment (Also calls SC and DE to set up Delivery + ;;Schedule and Description segments for item.) + N PRCA,PRCB,PRCD,PRCE,PRCF,PRCG,PRCH,PRCK,PRCL,PRCY,PRCCNT + S PRCA=0,PRCCNT=0 + F S PRCA=$O(^PRC(444,PRCDA,2,PRCA)) Q:PRCA'?1.N D + . S PRCL=0 + . S PRCB=$G(^PRC(444,PRCDA,2,PRCA,0)) Q:PRCB="" + . S PRCD=$G(^PRC(444,PRCDA,2,PRCA,1)),PRCG=$P(PRCB,U) + . S PRCY="IT^"_PRCG_"^"_$S($P(PRCB,U,6)]"":$P(PRCB,U,6),$P(PRCB,U,5)>0:$P($G(^PRC(441.2,$P(PRCB,U,5),0)),U),1:"")_"^^^",PRCCNT=PRCCNT+1 + . I $P($G(^PRC(444,PRCDA,5,0)),U,4)=1,$P($G(^PRC(444,PRCDA,1)),U,8)'="y" S $P(PRCY,U,5)=$P($G(^PRC(444,PRCDA,5)),U,2) + . S PRCY=PRCY_$P(PRCB,U,9)_"^"_$P(PRCB,U,8)_"^"_($P(PRCB,U,2)*100)_"^^" + . S PRCE=$P(PRCB,U,3) S:PRCE?1.N PRCH=$P($G(^PRCD(420.5,PRCE,0)),U),$P(PRCY,U,9)=PRCH + . S PRCY=PRCY_"^^^^^^^^^^^^^" + . S PRCE=$P(PRCB,U,7) S:PRCE?1.N PRCE=$P($P($G(^PRC(444.2,PRCE,0)),U)," "),$P(PRCY,U,22)=PRCE + . S $P(PRCY,U,23,29)=$P(PRCD,U)_"^"_$P(PRCD,U,2)_"^"_$P(PRCB,U,11)_"^"_$P($G(^PRC(444,PRCDA,1)),U)_"^^^|" + . S PRCC=PRCC+1,^TMP($J,"STRING",PRCC)=PRCY + . S PRCF=PRCC + . S $P(^TMP($J,"STRING",PRCF),U,21)=$$DE("^PRC(444,PRCDA,2,PRCA,2)",PRCG,.PRCC) + . S $P(^TMP($J,"STRING",PRCF),U,27)=$$SC("^PRC(444,PRCDA,2,PRCA,4)",PRCG,PRCH,.PRCC,.PRCL) + . I $P(^TMP($J,"STRING",PRCF),U,3)="" S PRCK(1)="Item #"_$P(PRCB,U)_": FSC and NSN missing" + . I $P(^TMP($J,"STRING",PRCF),U,8)'>0 S PRCK(2)="Item #"_$P(PRCB,U)_": Quantity not greater than zero" + . I $P(^TMP($J,"STRING",PRCF),U,9)="" S PRCK(3)="Item #"_$P(PRCB,U)_": Unit of Purchase missing" + . I $P(^TMP($J,"STRING",PRCF),U,22)="" S PRCK(4)="Item #"_$P(PRCB,U)_": SIC Code missing" + . I $P(^TMP($J,"STRING",PRCF),U,21)'>0 S PRCK(5)="Item #"_$P(PRCB,U)_": Item Description missing" + . I $P(^TMP($J,"STRING",PRCF),U,27)>0,$P(^(PRCF),U,8)'=PRCL S PRCK(6)="Item #"_$P(PRCB,U)_": Total of Delivery Schedule NOT EQUAL to Line Quantity" + S:PRCCNT>0 $P(^TMP($J,"STRING",1),U,12)=PRCCNT + I PRCCNT'>0 S PRCK(7)="No Items in RFQ" + I $D(PRCK) S PRCERR=2 D EN^DDIOL(.PRCK) + Q +SC(PRCN,PRCIT,PRCU,PRCC,PRCJ) ;Set up Delivery Schedule for item + N PRCW,PRCX,PRCY,PRCZ,X,Y + S PRCX=0,PRCW=0 + F S PRCX=$O(@PRCN@(PRCX)) Q:PRCX'?1.N D + . S PRCZ=$G(@PRCN@(PRCX,0)) Q:PRCZ="" + . S X=$P(PRCZ,U,2) D JDN^PRCUTL + . S PRCY="SC^"_PRCIT_"^"_$P(PRCZ,U)_"^"_($P(PRCZ,U,3)*100)_"^"_PRCU + . S PRCY=PRCY_"^"_Y_"^|",PRCC=PRCC+1,PRCJ=PRCJ+$P(PRCY,U,4) + . S ^TMP($J,"STRING",PRCC)=PRCY,PRCW=PRCW+1 + Q PRCW +DE(PRCN,PRCIT,PRCC) ;Set up Item Description segments + N PRCI,PRCT,PRCX,X,DIWL,DIWR,DIWF + S PRCX=0,DIWL=1,DIWR=70,DIWF="" K ^UTILITY($J,"W") + F S PRCX=$O(@PRCN@(PRCX)) Q:PRCX="" D + . Q:'$D(@PRCN@(PRCX,0)) S X=@PRCN@(PRCX,0) D ^DIWP + S PRCT=$G(^UTILITY($J,"W",1)) + F PRCI=1:1:PRCT D + . S PRCC=PRCC+1,X=$G(^UTILITY($J,"W",1,PRCI,0)) S:$L(X)=0 X=" " S X=$TR(X,"^") + . S ^TMP($J,"STRING",PRCC)="DE^"_PRCIT_"^"_PRCI_"^"_X_"^|" + K ^UTILITY($J,"W") + Q PRCT +DUNERR(PRCA) ;Displays the Error Message for Vendor Lacking Dun # + Q:$D(ZTQUEUED) + N PRCB S PRCB="^"_$P(PRCA,";",2)_$P(PRCA,";")_",0)" + S PRCB=$P(@PRCB,U)_" lacks a Dun # so NOT a recipient" + D EN^DDIOL(PRCB) + Q diff --git a/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPLO2A.m b/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPLO2A.m index 7ef2f50d..76823818 100644 --- a/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPLO2A.m +++ b/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPLO2A.m @@ -1,204 +1,211 @@ -PRCPLO2A ;WOIFO/DAP-stock status report (cont) ; 1/26/06 12:00pm -V ;;5.1;IFCAP;**83,98,112**;Oct 20, 2000;Build 2 - ;Per VHA Directive 2004-038, this routine should not be modified. - ;External reference to $$GET1^DIQ(4, is supported by ICR# 10090 - ; *112 changes by: VMP, Holloway,T. - ; -ENT ;*83 Building ^TMP with total result data, totaling logic pulled from PRCPRSS0 - N PRCPIN,PRCPIN1,PRCPIN2,PRCPIN3,TOTVAL,TOTCLOS,TOTCLO1,TOTCLO2,SSRIEN - S U="^",STA=PRC("SITE"),INV=PRCP("I") - ; -SSR1 ;*98 First Stock Status Report data field set - ; - S $P(^TMP($J,"PRCPSSR1",STA,INV),U,1)=STA ;Station # - S DATRN=$$FMTE^XLFDT(DATESTRT) - S DATRN1=$P(DATRN," ",1)_","_$P(DATRN," ",2) - S $P(^TMP($J,"PRCPSSR1",STA,INV),U,2)=DATRN1 ;Date Range - S $P(^TMP($J,"PRCPSSR1",STA,INV),U,3)=INARNG ;Inactivity Range - S $P(^TMP($J,"PRCPSSR1",STA,INV),U,4)=INV ;Inventory Point # - ;*83 Retrieve external inventory point name and primary/secondary/ - ;warehouse indicator - S PRCPIN=$G(^PRCP(445,INV,0)) - I PRCPIN'="" S PRCPIN1=$P(PRCPIN,"^",1),PRCPIN2=$P(PRCPIN1,"-",2,99) - I PRCPIN'="" S PRCPIN3=$P(PRCPIN,"^",3) - I PRCPIN="" S PRCPIN2="",PRCPIN3="" - S PRCPIN2=$TR(PRCPIN2,"*","|") ; Needed due to "*" delimiter - S $P(^TMP($J,"PRCPSSR1",STA,INV),U,5)=PRCPIN2 ;Inventory Point Name - S $P(^TMP($J,"PRCPSSR1",STA,INV),U,6)=PRCPIN3 ;P/S/W Indicator - ; - S PRCPDX=$TR(^TMP($J,"PRCPSSR1",STA,INV),"^","*"),DR="3///"_PRCPDX - D FILE - ; -SSR2 ;*98 Second Stock Status Report data field set - ; - S TOTOPEN=0 F ACCT=1,2,3,6,8 S %=$P($G(^TMP($J,1,"OPEN",ACCT)),U,2),TOTOPEN=TOTOPEN+% - S $P(^TMP($J,"PRCPSSR2",STA,INV),U,1)=TOTOPEN ;Std. Open Balance Total $ - S TOTOPEN=0 F ACCT=1,2,3,6,8 S %=$P($G(^TMP($J,2,"OPEN",ACCT)),U,2),TOTOPEN=TOTOPEN+% - S $P(^TMP($J,"PRCPSSR2",STA,INV),U,2)=TOTOPEN ;ODI Open Balance Total $ - S TOTOPEN=0 F ACCT=1,2,3,6,8 S %=$P($G(^TMP($J,3,"OPEN",ACCT)),U,2),TOTOPEN=TOTOPEN+% - S $P(^TMP($J,"PRCPSSR2",STA,INV),U,3)=TOTOPEN ;All Open Balance Total $ - ; - S $P(^TMP($J,"PRCPSSR2",STA,INV),U,4)=+$G(^TMP($J,1,"REC","TOTAL")) - ;Std. Receipts Total $ - S $P(^TMP($J,"PRCPSSR2",STA,INV),U,5)=+$G(^TMP($J,2,"REC","TOTAL")) - ;ODI Receipts Total $ - S $P(^TMP($J,"PRCPSSR2",STA,INV),U,6)=+$G(^TMP($J,3,"REC","TOTAL")) - ;All Receipts Total $ - S $P(^TMP($J,"PRCPSSR2",STA,INV),U,7)=+$G(^TMP($J,1,"ISS","TOTAL")) - ;Std. Usages Total $ - S $P(^TMP($J,"PRCPSSR2",STA,INV),U,8)=+$G(^TMP($J,2,"ISS","TOTAL")) - ;ODI Usages Total $ - S $P(^TMP($J,"PRCPSSR2",STA,INV),U,9)=+$G(^TMP($J,3,"ISS","TOTAL")) - ;All Usages Total $ - S $P(^TMP($J,"PRCPSSR2",STA,INV),U,10)=+$G(^TMP($J,1,"ADJ","TOTAL")) - ;Std. Adjustments Total $ - S $P(^TMP($J,"PRCPSSR2",STA,INV),U,11)=+$G(^TMP($J,2,"ADJ","TOTAL")) - ;ODI Adjustments Total $ - S $P(^TMP($J,"PRCPSSR2",STA,INV),U,12)=+$G(^TMP($J,3,"ADJ","TOTAL")) - ;All Adjustments Total $ - ; - S PRCPDX=$TR(^TMP($J,"PRCPSSR2",STA,INV),"^","*"),DR="4///"_PRCPDX - D FILE - ; -SSR3 ;*98 Third Stock Status Report data field set - ; - S TOTCLOS=0 - S TOTCLOS=$P($G(^TMP($J,"PRCPSSR2",STA,INV)),U,1)+$G(^TMP($J,1,"REC","TOTAL")) - S TOTCLOS=TOTCLOS+$G(^TMP($J,1,"ISS","TOTAL"))+$G(^TMP($J,1,"ADJ","TOTAL")) - S $P(^TMP($J,"PRCPSSR3",STA,INV),U,1)=TOTCLOS ;Std. Closing Bal Total $ - S TOTCLO1=0 - S TOTCLO1=$P($G(^TMP($J,"PRCPSSR2",STA,INV)),U,2)+$G(^TMP($J,2,"REC","TOTAL")) - S TOTCLO1=TOTCLO1+$G(^TMP($J,2,"ISS","TOTAL"))+$G(^TMP($J,2,"ADJ","TOTAL")) - S $P(^TMP($J,"PRCPSSR3",STA,INV),U,2)=TOTCLO1 ;ODI Closing Bal Total $ - S TOTCLO2=0 - S TOTCLO2=$P($G(^TMP($J,"PRCPSSR2",STA,INV)),U,3)+$G(^TMP($J,3,"REC","TOTAL")) - S TOTCLO2=TOTCLO2+$G(^TMP($J,3,"ISS","TOTAL"))+$G(^TMP($J,3,"ADJ","TOTAL")) - S $P(^TMP($J,"PRCPSSR3",STA,INV),U,3)=TOTCLO2 ;All Closing Bal Total $ - ; - S $P(^TMP($J,"PRCPSSR3",STA,INV),U,4)=+$G(^TMP($J,1,"RECN","TOTAL")) - ;# Std. Receipts - S $P(^TMP($J,"PRCPSSR3",STA,INV),U,5)=+$G(^TMP($J,2,"RECN","TOTAL")) - ;# ODI Receipts - S $P(^TMP($J,"PRCPSSR3",STA,INV),U,6)=+$G(^TMP($J,3,"RECN","TOTAL")) - ;# All Receipts - S $P(^TMP($J,"PRCPSSR3",STA,INV),U,7)=+$G(^TMP($J,1,"ISSN","TOTAL")) - ;# Std. Issues - S $P(^TMP($J,"PRCPSSR3",STA,INV),U,8)=+$G(^TMP($J,2,"ISSN","TOTAL")) - ;# ODI Issues - S $P(^TMP($J,"PRCPSSR3",STA,INV),U,9)=+$G(^TMP($J,3,"ISSN","TOTAL")) - ;# All Issues - S $P(^TMP($J,"PRCPSSR3",STA,INV),U,10)=+$G(^TMP($J,1,"ADJN","TOTAL")) - ;# Std. Adjustments - S $P(^TMP($J,"PRCPSSR3",STA,INV),U,11)=+$G(^TMP($J,2,"ADJN","TOTAL")) - ;# ODI Adjustments - S $P(^TMP($J,"PRCPSSR3",STA,INV),U,12)=+$G(^TMP($J,3,"ADJN","TOTAL")) - ;# All Adjustments - ; - S PRCPDX=$TR(^TMP($J,"PRCPSSR3",STA,INV),"^","*"),DR="5///"_PRCPDX - D FILE - ; -SSR4 ;*98 Fourth Stock Status Report data field set - ; - ;*83 Turnover computation logic also pulled from PRCPRSS0 - S DAYS=$P("31^28^31^30^31^30^31^31^30^31^30^31",U,+$E(DATESTRT,4,5)) - I DAYS=28 S %=(17+$E(DATESTRT))_$E(DATESTRT,2,3),DAYS=$S(%#400=0:29,(%#4=0&(%#100'=0)):29,1:28) - ; - S %=($G(^TMP($J,1,"ISS","TOTAL"))*365)/DAYS,%=$S('TOTCLOS:0,1:-%/TOTCLOS) - S $P(^TMP($J,"PRCPSSR4",STA,INV),U,1)=$J(%,0,2) - ;Std. Turnover - S %=($G(^TMP($J,2,"ISS","TOTAL"))*365)/DAYS,%=$S('TOTCLO1:0,1:-%/TOTCLO1) - S $P(^TMP($J,"PRCPSSR4",STA,INV),U,2)=$J(%,0,2) - ;ODI Turnover - S %=($G(^TMP($J,3,"ISS","TOTAL"))*365)/DAYS,%=$S('TOTCLO2:0,1:-%/TOTCLO2) - S $P(^TMP($J,"PRCPSSR4",STA,INV),U,3)=$J(%,0,2) - ;All Turnover - S $P(^TMP($J,"PRCPSSR4",STA,INV),U,4)=+$G(^TMP($J,1,"INACTN","TOTAL")) - ;# Std. Inactive - S $P(^TMP($J,"PRCPSSR4",STA,INV),U,5)=+$G(^TMP($J,2,"INACTN","TOTAL")) - ;# ODI Inactive - S $P(^TMP($J,"PRCPSSR4",STA,INV),U,6)=+$G(^TMP($J,3,"INACTN","TOTAL")) - ;# All Inactive - S $P(^TMP($J,"PRCPSSR4",STA,INV),U,7)=+$G(^TMP($J,1,"INACT","TOTAL")) - ;Std Inactive Total $ - S $P(^TMP($J,"PRCPSSR4",STA,INV),U,8)=+$G(^TMP($J,2,"INACT","TOTAL")) - ;ODI Inactive Total $ - S $P(^TMP($J,"PRCPSSR4",STA,INV),U,9)=+$G(^TMP($J,3,"INACT","TOTAL")) - ;All Inactive Total $ - ; - S %=$S('$G(^TMP($J,1,"VALUE","TOTAL")):0,1:$G(^TMP($J,1,"INACT","TOTAL"))/$G(^TMP($J,1,"VALUE","TOTAL"))) - I %="" S %=0 - S $P(^TMP($J,"PRCPSSR4",STA,INV),U,10)=$J(%,0,2) - ;Std. Inactive % - S %=$S('$G(^TMP($J,2,"VALUE","TOTAL")):0,1:$G(^TMP($J,2,"INACT","TOTAL"))/$G(^TMP($J,2,"VALUE","TOTAL"))) - I %="" S %=0 - S $P(^TMP($J,"PRCPSSR4",STA,INV),U,11)=$J(%,0,2) - ;ODI Inactive % - S %=$S('$G(^TMP($J,3,"VALUE","TOTAL")):0,1:$G(^TMP($J,3,"INACT","TOTAL"))/$G(^TMP($J,3,"VALUE","TOTAL"))) - I %="" S %=0 - S $P(^TMP($J,"PRCPSSR4",STA,INV),U,12)=$J(%,0,2) - ;All Inactive % - ; - S PRCPDX=$TR(^TMP($J,"PRCPSSR4",STA,INV),"^","*"),DR="6///"_PRCPDX - D FILE - ; -SSR5 ;*98 Fifth Stock Status Report data field set - ; - S $P(^TMP($J,"PRCPSSR5",STA,INV),U,1)=+$G(^TMP($J,1,"LONGN","TOTAL")) - ;# Std. Long Supply - S $P(^TMP($J,"PRCPSSR5",STA,INV),U,2)=+$G(^TMP($J,2,"LONGN","TOTAL")) - ;# ODI Long Supply - S $P(^TMP($J,"PRCPSSR5",STA,INV),U,3)=+$G(^TMP($J,3,"LONGN","TOTAL")) - ;# All Long Supply - S $P(^TMP($J,"PRCPSSR5",STA,INV),U,4)=+$G(^TMP($J,1,"LONG","TOTAL")) - ;Std. Long Supply Total $ - S $P(^TMP($J,"PRCPSSR5",STA,INV),U,5)=+$G(^TMP($J,2,"LONG","TOTAL")) - ;ODI Long Supply Total $ - S $P(^TMP($J,"PRCPSSR5",STA,INV),U,6)=+$G(^TMP($J,3,"LONG","TOTAL")) - ;All Long Supply Total $ - ; - S %=$S('$G(^TMP($J,1,"VALUE","TOTAL")):0,1:$G(^TMP($J,1,"LONG","TOTAL"))/$G(^TMP($J,1,"VALUE","TOTAL"))) - I %="" S %=0 - S $P(^TMP($J,"PRCPSSR5",STA,INV),U,7)=$J(%,0,2) - ;Std. Long Supply % - S %=$S('$G(^TMP($J,2,"VALUE","TOTAL")):0,1:$G(^TMP($J,2,"LONG","TOTAL"))/$G(^TMP($J,2,"VALUE","TOTAL"))) - I %="" S %=0 - S $P(^TMP($J,"PRCPSSR5",STA,INV),U,8)=$J(%,0,2) - ;ODI Long Supply % - S %=$S('$G(^TMP($J,3,"VALUE","TOTAL")):0,1:$G(^TMP($J,3,"LONG","TOTAL"))/$G(^TMP($J,3,"VALUE","TOTAL"))) - I %="" S %=0 - S $P(^TMP($J,"PRCPSSR5",STA,INV),U,9)=$J(%,0,2) - ;All Long Supply % - S $P(^TMP($J,"PRCPSSR5",STA,INV),U,10)=+$G(^TMP($J,1,"CNT","TOTAL")) - ;# Std. Items - S $P(^TMP($J,"PRCPSSR5",STA,INV),U,11)=+$G(^TMP($J,2,"CNT","TOTAL")) - ;# On-Demand Items - S $P(^TMP($J,"PRCPSSR5",STA,INV),U,12)=+$G(^TMP($J,3,"CNT","TOTAL")) - ;# All Items - ; - S PRCPDX=$TR(^TMP($J,"PRCPSSR5",STA,INV),"^","*"),DR="7///"_PRCPDX - D FILE - K Y - ; - Q - ; - ;*98 Created filing subroutine -FILE ; Subroutine that creates entries in File #446.7 fields as they - ; are created - ; - N PRCPDR,PRCPSNM,PRCPDA,PRCPDX,X,Y - S PRCPDR=DR - S SSRIEN=STA_INV - S DIC="^PRCP(446.7,",DIC(0)="L",DLAYGO=446.7,X=SSRIEN D ^DIC K DIC,DLAYGO - S PRCPDA=Y+0 - ;*98 Send enhanced mail message if exception occurs during FileMan set - I Y=-1 N PRCPMSG D Q - . S PRCPMSG(1)="Error saving to File #446.7 for Stock Status Report, related data: " - . S PRCPSNM=$$GET1^DIQ(4,STA_",",.01) - . S PRCPMSG(2)="",PRCPMSG(3)="Station: "_STA_" "_PRCPSNM - . S PRCPMSG(4)="Inventory Point: "_$P(^TMP($J,"PRCPSSR1",STA,INV),U,4)_" "_$P(^TMP($J,"PRCPSSR1",STA,INV),U,5) - . S PRCPMSG(5)="File #446.7 Field Set Attempted: "_PRCPDR - . D MAIL^PRCPLO3 Q - ; - S DIE="^PRCP(446.7,",DA=PRCPDA D ^DIE K DIE,DR,DA - ; - Q +PRCPLO2A ;WOIFO/DAP-stock status report (cont) ; 1/26/06 12:00pm +V ;;5.1;IFCAP;**83,98**;Oct 20, 2000;Build 37 + ;Per VHA Directive 2004-038, this routine should not be modified. + ; +ENT ;*83 Building ^TMP with total result data, totaling logic pulled from PRCPRSS0 + N PRCPIN,PRCPIN1,PRCPIN2,PRCPIN3,TOTVAL,TOTCLOS,TOTCLO1,TOTCLO2,SSRIEN + S U="^",STA=PRC("SITE"),INV=PRCP("I") + ; +SSR1 ;*98 First Stock Status Report data field set + ; + S $P(^TMP($J,"PRCPSSR1",STA,INV),U,1)=STA ;Station # + S DATRN=$$FMTE^XLFDT(DATESTRT) + S DATRN1=$P(DATRN," ",1)_","_$P(DATRN," ",2) + S $P(^TMP($J,"PRCPSSR1",STA,INV),U,2)=DATRN1 ;Date Range + S $P(^TMP($J,"PRCPSSR1",STA,INV),U,3)=INARNG ;Inactivity Range + S $P(^TMP($J,"PRCPSSR1",STA,INV),U,4)=INV ;Inventory Point # + ;*83 Retrieve external inventory point name and primary/secondary/ + ;warehouse indicator + S PRCPIN=$G(^PRCP(445,INV,0)) + I PRCPIN'="" S PRCPIN1=$P(PRCPIN,"^",1),PRCPIN2=$P(PRCPIN1,"-",2,99) + I PRCPIN'="" S PRCPIN3=$P(PRCPIN,"^",3) + I PRCPIN="" S PRCPIN2="",PRCPIN3="" + S PRCPIN2=$TR(PRCPIN2,"*","|") ; Needed due to "*" delimiter + S $P(^TMP($J,"PRCPSSR1",STA,INV),U,5)=PRCPIN2 ;Inventory Point Name + S $P(^TMP($J,"PRCPSSR1",STA,INV),U,6)=PRCPIN3 ;P/S/W Indicator + ; + S PRCPDX=$TR(^TMP($J,"PRCPSSR1",STA,INV),"^","*"),DR="3///"_PRCPDX + D FILE + ; +SSR2 ;*98 Second Stock Status Report data field set + ; + S TOTOPEN=0 F ACCT=1,2,3,6,8 S %=$P($G(^TMP($J,1,"OPEN",ACCT)),U,2),TOTOPEN=TOTOPEN+% + S $P(^TMP($J,"PRCPSSR2",STA,INV),U,1)=TOTOPEN ;Std. Open Balance Total $ + S TOTOPEN=0 F ACCT=1,2,3,6,8 S %=$P($G(^TMP($J,2,"OPEN",ACCT)),U,2),TOTOPEN=TOTOPEN+% + S $P(^TMP($J,"PRCPSSR2",STA,INV),U,2)=TOTOPEN ;ODI Open Balance Total $ + S TOTOPEN=0 F ACCT=1,2,3,6,8 S %=$P($G(^TMP($J,3,"OPEN",ACCT)),U,2),TOTOPEN=TOTOPEN+% + S $P(^TMP($J,"PRCPSSR2",STA,INV),U,3)=TOTOPEN ;All Open Balance Total $ + ; + S $P(^TMP($J,"PRCPSSR2",STA,INV),U,4)=+$G(^TMP($J,1,"REC","TOTAL")) + ;Std. Receipts Total $ + S $P(^TMP($J,"PRCPSSR2",STA,INV),U,5)=+$G(^TMP($J,2,"REC","TOTAL")) + ;ODI Receipts Total $ + S $P(^TMP($J,"PRCPSSR2",STA,INV),U,6)=+$G(^TMP($J,3,"REC","TOTAL")) + ;All Receipts Total $ + S $P(^TMP($J,"PRCPSSR2",STA,INV),U,7)=+$G(^TMP($J,1,"ISS","TOTAL")) + ;Std. Usages Total $ + S $P(^TMP($J,"PRCPSSR2",STA,INV),U,8)=+$G(^TMP($J,2,"ISS","TOTAL")) + ;ODI Usages Total $ + S $P(^TMP($J,"PRCPSSR2",STA,INV),U,9)=+$G(^TMP($J,3,"ISS","TOTAL")) + ;All Usages Total $ + S $P(^TMP($J,"PRCPSSR2",STA,INV),U,10)=+$G(^TMP($J,1,"ADJ","TOTAL")) + ;Std. Adjustments Total $ + S $P(^TMP($J,"PRCPSSR2",STA,INV),U,11)=+$G(^TMP($J,2,"ADJ","TOTAL")) + ;ODI Adjustments Total $ + S $P(^TMP($J,"PRCPSSR2",STA,INV),U,12)=+$G(^TMP($J,3,"ADJ","TOTAL")) + ;All Adjustments Total $ + ; + S PRCPDX=$TR(^TMP($J,"PRCPSSR2",STA,INV),"^","*"),DR="4///"_PRCPDX + D FILE + ; +SSR3 ;*98 Third Stock Status Report data field set + ; + S TOTCLOS=0 + S TOTCLOS=$P($G(^TMP($J,"PRCPSSR2",STA,INV)),U,1)+$G(^TMP($J,1,"REC","TOTAL")) + S TOTCLOS=TOTCLOS+$G(^TMP($J,1,"ISS","TOTAL"))+$G(^TMP($J,1,"ADJ","TOTAL")) + S $P(^TMP($J,"PRCPSSR3",STA,INV),U,1)=TOTCLOS ;Std. Closing Bal Total $ + S TOTCLO1=0 + S TOTCLO1=$P($G(^TMP($J,"PRCPSSR2",STA,INV)),U,2)+$G(^TMP($J,2,"REC","TOTAL")) + S TOTCLO1=TOTCLO1+$G(^TMP($J,2,"ISS","TOTAL"))+$G(^TMP($J,2,"ADJ","TOTAL")) + S $P(^TMP($J,"PRCPSSR3",STA,INV),U,2)=TOTCLO1 ;ODI Closing Bal Total $ + S TOTCLO2=0 + S TOTCLO2=$P($G(^TMP($J,"PRCPSSR2",STA,INV)),U,3)+$G(^TMP($J,3,"REC","TOTAL")) + S TOTCLO2=TOTCLO2+$G(^TMP($J,3,"ISS","TOTAL"))+$G(^TMP($J,3,"ADJ","TOTAL")) + S $P(^TMP($J,"PRCPSSR3",STA,INV),U,3)=TOTCLO2 ;All Closing Bal Total $ + ; + S $P(^TMP($J,"PRCPSSR3",STA,INV),U,4)=+$G(^TMP($J,1,"RECN","TOTAL")) + ;# Std. Receipts + S $P(^TMP($J,"PRCPSSR3",STA,INV),U,5)=+$G(^TMP($J,2,"RECN","TOTAL")) + ;# ODI Receipts + S $P(^TMP($J,"PRCPSSR3",STA,INV),U,6)=+$G(^TMP($J,3,"RECN","TOTAL")) + ;# All Receipts + S $P(^TMP($J,"PRCPSSR3",STA,INV),U,7)=+$G(^TMP($J,1,"ISSN","TOTAL")) + ;# Std. Issues + S $P(^TMP($J,"PRCPSSR3",STA,INV),U,8)=+$G(^TMP($J,2,"ISSN","TOTAL")) + ;# ODI Issues + S $P(^TMP($J,"PRCPSSR3",STA,INV),U,9)=+$G(^TMP($J,3,"ISSN","TOTAL")) + ;# All Issues + S $P(^TMP($J,"PRCPSSR3",STA,INV),U,10)=+$G(^TMP($J,1,"ADJN","TOTAL")) + ;# Std. Adjustments + S $P(^TMP($J,"PRCPSSR3",STA,INV),U,11)=+$G(^TMP($J,2,"ADJN","TOTAL")) + ;# ODI Adjustments + S $P(^TMP($J,"PRCPSSR3",STA,INV),U,12)=+$G(^TMP($J,3,"ADJN","TOTAL")) + ;# All Adjustments + ; + S PRCPDX=$TR(^TMP($J,"PRCPSSR3",STA,INV),"^","*"),DR="5///"_PRCPDX + D FILE + ; +SSR4 ;*98 Fourth Stock Status Report data field set + ; + ;*83 Turnover computation logic also pulled from PRCPRSS0 + S DAYS=$P("31^28^31^30^31^30^31^31^30^31^30^31",U,+$E(DATESTRT,4,5)) + I DAYS=28 S %=(17+$E(DATESTRT))_$E(DATESTRT,2,3),DAYS=$S(%#400=0:29,(%#4=0&(%#100'=0)):29,1:28) + ; + S %=($G(^TMP($J,1,"ISS","TOTAL"))*365)/DAYS,%=$S('TOTCLOS:0,1:-%/TOTCLOS) + I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2) + S $P(^TMP($J,"PRCPSSR4",STA,INV),U,1)=% + ;Std. Turnover + S %=($G(^TMP($J,2,"ISS","TOTAL"))*365)/DAYS,%=$S('TOTCLO1:0,1:-%/TOTCLO1) + I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2) + S $P(^TMP($J,"PRCPSSR4",STA,INV),U,2)=% + ;ODI Turnover + S %=($G(^TMP($J,3,"ISS","TOTAL"))*365)/DAYS,%=$S('TOTCLO2:0,1:-%/TOTCLO2) + I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2) + S $P(^TMP($J,"PRCPSSR4",STA,INV),U,3)=% + ;All Turnover + S $P(^TMP($J,"PRCPSSR4",STA,INV),U,4)=+$G(^TMP($J,1,"INACTN","TOTAL")) + ;# Std. Inactive + S $P(^TMP($J,"PRCPSSR4",STA,INV),U,5)=+$G(^TMP($J,2,"INACTN","TOTAL")) + ;# ODI Inactive + S $P(^TMP($J,"PRCPSSR4",STA,INV),U,6)=+$G(^TMP($J,3,"INACTN","TOTAL")) + ;# All Inactive + S $P(^TMP($J,"PRCPSSR4",STA,INV),U,7)=+$G(^TMP($J,1,"INACT","TOTAL")) + ;Std Inactive Total $ + S $P(^TMP($J,"PRCPSSR4",STA,INV),U,8)=+$G(^TMP($J,2,"INACT","TOTAL")) + ;ODI Inactive Total $ + S $P(^TMP($J,"PRCPSSR4",STA,INV),U,9)=+$G(^TMP($J,3,"INACT","TOTAL")) + ;All Inactive Total $ + ; + S %=$S('$G(^TMP($J,1,"VALUE","TOTAL")):0,1:$G(^TMP($J,1,"INACT","TOTAL"))/$G(^TMP($J,1,"VALUE","TOTAL"))) + I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2) + I %="" S %=0 + S $P(^TMP($J,"PRCPSSR4",STA,INV),U,10)=% + ;Std. Inactive % + S %=$S('$G(^TMP($J,2,"VALUE","TOTAL")):0,1:$G(^TMP($J,2,"INACT","TOTAL"))/$G(^TMP($J,2,"VALUE","TOTAL"))) + I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2) + I %="" S %=0 + S $P(^TMP($J,"PRCPSSR4",STA,INV),U,11)=% + ;ODI Inactive % + S %=$S('$G(^TMP($J,3,"VALUE","TOTAL")):0,1:$G(^TMP($J,3,"INACT","TOTAL"))/$G(^TMP($J,3,"VALUE","TOTAL"))) + I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2) + I %="" S %=0 + S $P(^TMP($J,"PRCPSSR4",STA,INV),U,12)=% + ;All Inactive % + ; + S PRCPDX=$TR(^TMP($J,"PRCPSSR4",STA,INV),"^","*"),DR="6///"_PRCPDX + D FILE + ; +SSR5 ;*98 Fifth Stock Status Report data field set + ; + S $P(^TMP($J,"PRCPSSR5",STA,INV),U,1)=+$G(^TMP($J,1,"LONGN","TOTAL")) + ;# Std. Long Supply + S $P(^TMP($J,"PRCPSSR5",STA,INV),U,2)=+$G(^TMP($J,2,"LONGN","TOTAL")) + ;# ODI Long Supply + S $P(^TMP($J,"PRCPSSR5",STA,INV),U,3)=+$G(^TMP($J,3,"LONGN","TOTAL")) + ;# All Long Supply + S $P(^TMP($J,"PRCPSSR5",STA,INV),U,4)=+$G(^TMP($J,1,"LONG","TOTAL")) + ;Std. Long Supply Total $ + S $P(^TMP($J,"PRCPSSR5",STA,INV),U,5)=+$G(^TMP($J,2,"LONG","TOTAL")) + ;ODI Long Supply Total $ + S $P(^TMP($J,"PRCPSSR5",STA,INV),U,6)=+$G(^TMP($J,3,"LONG","TOTAL")) + ;All Long Supply Total $ + ; + S %=$S('$G(^TMP($J,1,"VALUE","TOTAL")):0,1:$G(^TMP($J,1,"LONG","TOTAL"))/$G(^TMP($J,1,"VALUE","TOTAL"))) + I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2) + I %="" S %=0 + S $P(^TMP($J,"PRCPSSR5",STA,INV),U,7)=% + ;Std. Long Supply % + S %=$S('$G(^TMP($J,2,"VALUE","TOTAL")):0,1:$G(^TMP($J,2,"LONG","TOTAL"))/$G(^TMP($J,2,"VALUE","TOTAL"))) + I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2) + I %="" S %=0 + S $P(^TMP($J,"PRCPSSR5",STA,INV),U,8)=% + ;ODI Long Supply % + S %=$S('$G(^TMP($J,3,"VALUE","TOTAL")):0,1:$G(^TMP($J,3,"LONG","TOTAL"))/$G(^TMP($J,3,"VALUE","TOTAL"))) + I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2) + I %="" S %=0 + S $P(^TMP($J,"PRCPSSR5",STA,INV),U,9)=% + ;All Long Supply % + S $P(^TMP($J,"PRCPSSR5",STA,INV),U,10)=+$G(^TMP($J,1,"CNT","TOTAL")) + ;# Std. Items + S $P(^TMP($J,"PRCPSSR5",STA,INV),U,11)=+$G(^TMP($J,2,"CNT","TOTAL")) + ;# On-Demand Items + S $P(^TMP($J,"PRCPSSR5",STA,INV),U,12)=+$G(^TMP($J,3,"CNT","TOTAL")) + ;# All Items + ; + S PRCPDX=$TR(^TMP($J,"PRCPSSR5",STA,INV),"^","*"),DR="7///"_PRCPDX + D FILE + K Y + ; + Q + ; + ;*98 Created filing subroutine +FILE ; Subroutine that creates entries in File #446.7 fields as they + ; are created + ; + N PRCPDR,PRCPSNM,PRCPDA,PRCPDX,X,Y + S PRCPDR=DR + S SSRIEN=STA_INV + S DIC="^PRCP(446.7,",DIC(0)="L",DLAYGO=446.7,X=SSRIEN D ^DIC K DIC,DLAYGO + S PRCPDA=Y+0 + ;*98 Send enhanced mail message if exception occurs during FileMan set + I Y=-1 N PRCPMSG D Q + . S PRCPMSG(1)="Error saving to File #446.7 for Stock Status Report, related data: " + . S PRCPSNM=$$GET1^DIQ(4,STA_",",.01) + . S PRCPMSG(2)="",PRCPMSG(3)="Station: "_STA_" "_PRCPSNM + . S PRCPMSG(4)="Inventory Point: "_$P(^TMP($J,"PRCPSSR1",STA,INV),U,4)_" "_$P(^TMP($J,"PRCPSSR1",STA,INV),U,5) + . S PRCPMSG(5)="File #446.7 Field Set Attempted: "_PRCPDR + . D MAIL^PRCPLO3 Q + ; + S DIE="^PRCP(446.7,",DA=PRCPDA D ^DIE K DIE,DR,DA + ; + Q diff --git a/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPUSEL.m b/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPUSEL.m index c96f810b..002c6de0 100644 --- a/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPUSEL.m +++ b/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPUSEL.m @@ -1,131 +1,131 @@ -PRCPUSEL ;WISC/RFJ/DAP-utilities: setup inventory variables ;14 Feb 91 -V ;;5.1;IFCAP;**1,83,110**;Oct 20, 2000;Build 7 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; enter distribution point--input variables: - ; prcp("dptype")=distribution point type code [W,P,S] - ; returns the following variables: - ; prcp("in")=name of inv pt (no station #), - ; prcp("inv")=keep perpetual inventory flag - ; prcp("his")=keep detailed history flag, - ; prcp("i")=da of inv pt - ; - ;*83 Routine PRCPLO1 associated with PRC*5.1*83 is a modified copy of - ;this routine and any changes made to this routine should also be - ;considered for that routine as well. - ; - N %,C,DISYS,I,J,PRCF,PRCPFLAG,X,Y - I +$G(DUZ)<1 W !,"YOU ARE NOT SETUP AS A USER!" K PRC,PRCP Q - ; - S %=0 F I="FY","PARAM","PER","QTR","SITE" I '+$G(PRC(I)) S %=1 Q - I % S PRCF("X")="S" D ^PRCFSITE I '+$G(PRC("SITE")) K PRC,PRCP Q - ; - S %=0 F I="DPTYPE","HIS","I","IN","INV" I '$G(PRCP(I)) S %=1 Q - I '% D DISPLAY Q - ; - ; allow adding new whse if not one for station - I $G(PRCP("DPTYPE"))="W" D Q:$G(PRCPFLAG) - . K PRCPFLAG - . S %=0 F S %=$O(^PRCP(445,"AC","W",%)) Q:'% I $P($P($G(^PRCP(445,%,0)),"^"),"-")=PRC("SITE") S PRCPFLAG=1 Q - . I $G(PRCPFLAG) K PRCPFLAG Q - . S PRCP("I")=$$INVPT^PRCPUINV(PRC("SITE"),"W",1,1,"") - . I 'PRCP("I") S PRCPFLAG=1 K PRC,PRCP - ; - S %=$S($D(PRCP("DPTYPE")):PRCP("DPTYPE"),1:"^") - S (I,J)=0 - F S I=$O(^PRCP(445,"AD",DUZ,I)) Q:'I I $D(^PRCP(445,I,0)) D I J>1 Q - . S:%="^"!(%[$P(^PRCP(445,I,0),"^",3)) Y(0)=^(0),J=J+1,Y=I - I J=1 D Q:$G(PRCPFLAG) S PRC("SITE")=+Y(0) D V1 Q - . I '$D(^PRC(411,+Y(0),0)) D K PRC,PRCP S PRCPFLAG=1 - . . W !,"ERROR - SITE PARAMETERS IN FILE 411 FOR SITE " - . . W +Y(0)," ARE MISSING." - I $G(PRCHAUTH) Q:'$G(PRCP("I")) D G V1 - . S Y=PRCP("I")_"^"_$P($G(^PRCP(445,PRCP("I"),0)),U) - ; - S DIC="^PRCP(445,",DIC(0)="AEQMOZ" - S DIC("S")="I +^(0)=PRC(""SITE""),$P(^(0),U,2)=""Y"",$D(^PRCP(445,+Y,4,DUZ,0))" - I $D(PRCP("DPTYPE")) S DIC("S")=DIC("S")_",PRCP(""DPTYPE"")[$P(^PRCP(445,+Y,0),U,3)" - S DIC("A")="Select "_$S('$D(PRCP("DPTYPE")):"",PRCP("DPTYPE")="W":"Supply Warehouse ",PRCP("DPTYPE")="P":"Primary ",PRCP("DPTYPE")="S":"Secondary ",1:"")_"Inventory Point: " - S D="C",PRCPPRIV=1 - D IX^DIC - K PRCPPRIV,DIC - I Y<0 K PRC,PRCP Q - ; -V1 ; internal program jump - D PARAM(+Y) - ; -DISPLAY ; display top of page header - I '$G(PRCP("I")) G PRCPUSEL - S %=0 F I="RV1","RV0","XY" I '$D(PRCP(I)) S %=1 Q - I % D TERM - ; - S %="",$P(%," ",81)="" - S X="I N V E N T O R Y version "_$P($T(PRCPUSEL+1),";",3) - S Y=80-$L(X)\2 - S X=$E(%,1,Y)_X_% - W @IOF,PRCP("RV1"),$E(X,1,40) - X PRCP("XY") - W $E(X,41,80),PRCP("RV0") - S PRCP("PAR")=^PRCP(445,PRCP("I"),0) - S X=$S(+$G(PRC("SITE")):"("_PRC("SITE")_") ",1:"") - S X=X_$S(PRCP("DPTYPE")="W":"Warehouse ",PRCP("DPTYPE")="P":"Primary ",PRCP("DPTYPE")="S":"Secondary ",1:"") - S X=X_"Inventory Point: "_PRCP("IN") - W !,X,?(80-$L($P($G(PRC("PER")),"^",2))),$P($G(PRC("PER")),"^",2) - I PRCP("DPTYPE")="P" S Y=$P(PRCP("PAR"),"^",12) I Y,Y'>DT D - . D DD^%DT - . W !,?6,"--> NEXT REQUEST FOR WAREHOUSE ISSUES IS DUE IN SUPPLY ON ",Y,"." - I $P(PRCP("PAR"),"^",9)="Y" D - . W !?6,"--> THERE ARE ITEMS AT OR BELOW THE EMERGENCY STOCK LEVEL." - I $E($P(PRCP("PAR"),"^",14),1,5)'=$E(DT,1,5) D - . W !?6,"--> USAGE/DISTRIBUTION TOTALS NEEDS TO BE PURGED." - I $E($P(PRCP("PAR"),"^",17),1,5)'=$E(DT,1,5) D - . W !?6,"--> RECEIPTS HISTORY BY ITEM NEEDS TO BE PURGED." - I PRCP("DPTYPE")'="S",$E($P(PRCP("PAR"),"^",19),1,5)'=$E(DT,1,5) D - . W !?6,"--> DISTRIBUTION HISTORY NEEDS TO BE PURGED." - I $E($P(PRCP("PAR"),"^",18),1,5)'=$E(DT,1,5) D - . W !?6,"--> TRANSACTION REGISTER NEEDS TO BE PURGED." - I $P(PRCP("PAR"),"^",6)="Y",$E($P(PRCP("PAR"),"^",22),1,5)'=$E(DT,1,5) D - . W !?6,"--> OPENING MONTHLY INVENTORY BALANCES NEED TO BE SET." - I PRCP("DPTYPE")="S",$P($G(^PRCP(445,PRCP("I"),5)),"^",1)]"" D SSMSG - I $O(^PRCP(447.1,"C",+PRCP("PAR"),PRCP("I"),"")) D - . W !?6,"--> THERE ARE UNPROCESSED SUPPLY STATION TRANSACTIONS." - ; - W !,PRCP("RV1"),$E(%,1,40) X PRCP("XY") W $E(%,41,80),PRCP("RV0") - Q - ; - ; -NOMENU ; user did not select a valid inventory point, do not allow access - ; to the menu (called from option file) - N X - S X(1)="YOU MUST SELECT A VALID INVENTORY POINT BEFORE ACCESSING THIS MENU" D DISPLAY^PRCPUX2(1,79,.X) - Q - ; - ; -PARAM(INVPT) ; set up parameters for inventory point - K PRCP - N DATA - S DATA=$G(^PRCP(445,INVPT,0)) I DATA="" Q - S PRCP("I")=INVPT,PRCP("IN")=$P($P(DATA,"^"),"-",2,99),PRCP("INV")=$P(DATA,"^",2),PRCP("HIS")=$P(DATA,"^",6),PRCP("DPTYPE")=$P(DATA,"^",3) - D TERM - Q - ; - ; -TERM ; get terminal attributes - N X - I '$D(IOF)!('$G(IOST(0))) S IOP="HOME" D ^%ZIS K IOP - S X="IORVON;IORVOFF" D ENDR^%ZISS - S PRCP("RV1")=$G(IORVON),PRCP("RV0")=$G(IORVOFF) - S PRCP("XY")="N DX,DY S (DX,DY)=0 "_$G(^%ZOSF("XY")) - Q - ; -SSMSG ; check supply station secondaries, give message of qty mismatch - N GIPCNT,INVPT,ITEM,PRCPFLAG,SSCNT - S INVPT=PRCP("I") - S ITEM=0 - F S ITEM=$O(^PRCP(445,INVPT,1,ITEM)) Q:'+ITEM D I $D(PRCPFLAG) Q - . I $P($G(^PRCP(445,INVPT,1,ITEM,0)),"^",9)<1 Q ; not a SS item - . S GIPCNT=$P($G(^PRCP(445,INVPT,1,ITEM,0)),"^",7) - . S SSCNT=$P($G(^PRCP(445,INVPT,1,ITEM,9)),"^",1) - . I 'GIPCNT,'SSCNT Q - . I GIPCNT=SSCNT Q - . W !,?6,"--> QUANTITY DISCREPANCIES EXIST WITH THE SUPPLY STATION." - . S PRCPFLAG=1 +PRCPUSEL ;WISC/RFJ/DAP-utilities: setup inventory variables ;14 Feb 91 +V ;;5.1;IFCAP;**1,83**;Oct 20, 2000 + ;Per VHA Directive 10-93-142, this routine should not be modified. + ; enter distribution point--input variables: + ; prcp("dptype")=distribution point type code [W,P,S] + ; returns the following variables: + ; prcp("in")=name of inv pt (no station #), + ; prcp("inv")=keep perpetual inventory flag + ; prcp("his")=keep detailed history flag, + ; prcp("i")=da of inv pt + ; + ;*83 Routine PRCPLO1 associated with PRC*5.1*83 is a modified copy of + ;this routine and any changes made to this routine should also be + ;considered for that routine as well. + ; + N %,C,DISYS,I,J,PRCF,PRCPFLAG,X,Y + I +$G(DUZ)<1 W !,"YOU ARE NOT SETUP AS A USER!" K PRC,PRCP Q + ; + S %=0 F I="FY","PARAM","PER","QTR","SITE" I '+$G(PRC(I)) S %=1 Q + I % S PRCF("X")="S" D ^PRCFSITE I '+$G(PRC("SITE")) K PRC,PRCP Q + ; + S %=0 F I="DPTYPE","HIS","I","IN","INV" I '$D(PRCP(I)) S %=1 Q + I '% D DISPLAY Q + ; + ; allow adding new whse if not one for station + I $G(PRCP("DPTYPE"))="W" D Q:$G(PRCPFLAG) + . K PRCPFLAG + . S %=0 F S %=$O(^PRCP(445,"AC","W",%)) Q:'% I $P($P($G(^PRCP(445,%,0)),"^"),"-")=PRC("SITE") S PRCPFLAG=1 Q + . I $G(PRCPFLAG) K PRCPFLAG Q + . S PRCP("I")=$$INVPT^PRCPUINV(PRC("SITE"),"W",1,1,"") + . I 'PRCP("I") S PRCPFLAG=1 K PRC,PRCP + ; + S %=$S($D(PRCP("DPTYPE")):PRCP("DPTYPE"),1:"^") + S (I,J)=0 + F S I=$O(^PRCP(445,"AD",DUZ,I)) Q:'I I $D(^PRCP(445,I,0)) D I J>1 Q + . S:%="^"!(%[$P(^PRCP(445,I,0),"^",3)) Y(0)=^(0),J=J+1,Y=I + I J=1 D Q:$G(PRCPFLAG) S PRC("SITE")=+Y(0) D V1 Q + . I '$D(^PRC(411,+Y(0),0)) D K PRC,PRCP S PRCPFLAG=1 + . . W !,"ERROR - SITE PARAMETERS IN FILE 411 FOR SITE " + . . W +Y(0)," ARE MISSING." + I $G(PRCHAUTH) Q:'$G(PRCP("I")) D G V1 + . S Y=PRCP("I")_"^"_$P($G(^PRCP(445,PRCP("I"),0)),U) + ; + S DIC="^PRCP(445,",DIC(0)="AEQMOZ" + S DIC("S")="I +^(0)=PRC(""SITE""),$P(^(0),U,2)=""Y"",$D(^PRCP(445,+Y,4,DUZ,0))" + I $D(PRCP("DPTYPE")) S DIC("S")=DIC("S")_",PRCP(""DPTYPE"")[$P(^PRCP(445,+Y,0),U,3)" + S DIC("A")="Select "_$S('$D(PRCP("DPTYPE")):"",PRCP("DPTYPE")="W":"Supply Warehouse ",PRCP("DPTYPE")="P":"Primary ",PRCP("DPTYPE")="S":"Secondary ",1:"")_"Inventory Point: " + S D="C",PRCPPRIV=1 + D IX^DIC + K PRCPPRIV,DIC + I Y<0 K PRC,PRCP Q + ; +V1 ; internal program jump + D PARAM(+Y) + ; +DISPLAY ; display top of page header + I '$G(PRCP("I")) G PRCPUSEL + S %=0 F I="RV1","RV0","XY" I '$D(PRCP(I)) S %=1 Q + I % D TERM + ; + S %="",$P(%," ",81)="" + S X="I N V E N T O R Y version "_$P($T(PRCPUSEL+1),";",3) + S Y=80-$L(X)\2 + S X=$E(%,1,Y)_X_% + W @IOF,PRCP("RV1"),$E(X,1,40) + X PRCP("XY") + W $E(X,41,80),PRCP("RV0") + S PRCP("PAR")=^PRCP(445,PRCP("I"),0) + S X=$S(+$G(PRC("SITE")):"("_PRC("SITE")_") ",1:"") + S X=X_$S(PRCP("DPTYPE")="W":"Warehouse ",PRCP("DPTYPE")="P":"Primary ",PRCP("DPTYPE")="S":"Secondary ",1:"") + S X=X_"Inventory Point: "_PRCP("IN") + W !,X,?(80-$L($P($G(PRC("PER")),"^",2))),$P($G(PRC("PER")),"^",2) + I PRCP("DPTYPE")="P" S Y=$P(PRCP("PAR"),"^",12) I Y,Y'>DT D + . D DD^%DT + . W !,?6,"--> NEXT REQUEST FOR WAREHOUSE ISSUES IS DUE IN SUPPLY ON ",Y,"." + I $P(PRCP("PAR"),"^",9)="Y" D + . W !?6,"--> THERE ARE ITEMS AT OR BELOW THE EMERGENCY STOCK LEVEL." + I $E($P(PRCP("PAR"),"^",14),1,5)'=$E(DT,1,5) D + . W !?6,"--> USAGE/DISTRIBUTION TOTALS NEEDS TO BE PURGED." + I $E($P(PRCP("PAR"),"^",17),1,5)'=$E(DT,1,5) D + . W !?6,"--> RECEIPTS HISTORY BY ITEM NEEDS TO BE PURGED." + I PRCP("DPTYPE")'="S",$E($P(PRCP("PAR"),"^",19),1,5)'=$E(DT,1,5) D + . W !?6,"--> DISTRIBUTION HISTORY NEEDS TO BE PURGED." + I $E($P(PRCP("PAR"),"^",18),1,5)'=$E(DT,1,5) D + . W !?6,"--> TRANSACTION REGISTER NEEDS TO BE PURGED." + I $P(PRCP("PAR"),"^",6)="Y",$E($P(PRCP("PAR"),"^",22),1,5)'=$E(DT,1,5) D + . W !?6,"--> OPENING MONTHLY INVENTORY BALANCES NEED TO BE SET." + I PRCP("DPTYPE")="S",$P($G(^PRCP(445,PRCP("I"),5)),"^",1)]"" D SSMSG + I $O(^PRCP(447.1,"C",+PRCP("PAR"),PRCP("I"),"")) D + . W !?6,"--> THERE ARE UNPROCESSED SUPPLY STATION TRANSACTIONS." + ; + W !,PRCP("RV1"),$E(%,1,40) X PRCP("XY") W $E(%,41,80),PRCP("RV0") + Q + ; + ; +NOMENU ; user did not select a valid inventory point, do not allow access + ; to the menu (called from option file) + N X + S X(1)="YOU MUST SELECT A VALID INVENTORY POINT BEFORE ACCESSING THIS MENU" D DISPLAY^PRCPUX2(1,79,.X) + Q + ; + ; +PARAM(INVPT) ; set up parameters for inventory point + K PRCP + N DATA + S DATA=$G(^PRCP(445,INVPT,0)) I DATA="" Q + S PRCP("I")=INVPT,PRCP("IN")=$P($P(DATA,"^"),"-",2,99),PRCP("INV")=$P(DATA,"^",2),PRCP("HIS")=$P(DATA,"^",6),PRCP("DPTYPE")=$P(DATA,"^",3) + D TERM + Q + ; + ; +TERM ; get terminal attributes + N X + I '$D(IOF)!('$G(IOST(0))) S IOP="HOME" D ^%ZIS K IOP + S X="IORVON;IORVOFF" D ENDR^%ZISS + S PRCP("RV1")=$G(IORVON),PRCP("RV0")=$G(IORVOFF) + S PRCP("XY")="N DX,DY S (DX,DY)=0 "_$G(^%ZOSF("XY")) + Q + ; +SSMSG ; check supply station secondaries, give message of qty mismatch + N GIPCNT,INVPT,ITEM,PRCPFLAG,SSCNT + S INVPT=PRCP("I") + S ITEM=0 + F S ITEM=$O(^PRCP(445,INVPT,1,ITEM)) Q:'+ITEM D I $D(PRCPFLAG) Q + . I $P($G(^PRCP(445,INVPT,1,ITEM,0)),"^",9)<1 Q ; not a SS item + . S GIPCNT=$P($G(^PRCP(445,INVPT,1,ITEM,0)),"^",7) + . S SSCNT=$P($G(^PRCP(445,INVPT,1,ITEM,9)),"^",1) + . I 'GIPCNT,'SSCNT Q + . I GIPCNT=SSCNT Q + . W !,?6,"--> QUANTITY DISCREPANCIES EXIST WITH THE SUPPLY STATION." + . S PRCPFLAG=1 diff --git a/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSD122.m b/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSD122.m index 4f2db467..07760563 100644 --- a/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSD122.m +++ b/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSD122.m @@ -1,29 +1,29 @@ -PRCSD122 ;WISC/SAW-CONTROL POINT ACT. 2237 TERM. DISP. CON'T ;4/21/93 08:46 -V ;;5.1;IFCAP;**107**;Oct 20, 2000;Build 13 - ;Per VHA Directive 2004-038, this routine should not be modified. - I IOSL-$Y<5 D NEWP^PRCSD121 Q:Z1=U - W !,"JUSTIFICATION OF NEED OR TURN-IN" - I '$D(^PRCS(410,DA,8,0)) G SIG - S DIWL=1,DIWR=80,DIWF="" K ^UTILITY($J,"W") S X1=0 F I=1:1 S X1=$O(^PRCS(410,DA,8,X1)) Q:X1="" S X=^(X1,0) D DIWP^PRCUTL($G(DA)) - S Z=^UTILITY($J,"W",DIWL) F K=1:1:Z D:IOSL-$Y<2 NEWP^PRCSD121 Q:Z1=U W !,^UTILITY($J,"W",DIWL,K,0) -SIG ;PRINT SIGNATURE BLOCKS - I IOSL-$Y<5 D NEWP^PRCSD121 Q:Z1=U - W !,L - W !,"Originator of Request: " S XNAME=$P($G(^PRCS(410,DA,14)),"^") I XNAME'="" W $P($G(^VA(200,XNAME,0)),"^") - W !,"Signature of Initiator",?37,"Signature of Approving Official Date" - I '$D(^PRCS(410,DA,7)) W ! G SIG1 - W !,?37 K P1 S:$P(^PRCS(410,DA,7),U,3)'="" (P,P1)=$P(^(7),U,3) I $D(P1),$P(^(7),U,6)'="" W "/ES/",$$DECODE^PRCSC1(DA) - N PRSHLB S PRSHLB=^DD(410,40,0) W ?69,! I $P(^PRCS(410,DA,7),U)'="" S (P,P2)=$P(^(7),U) I $P(PRSHLB,"^",2)[200,$D(^VA(200,P,20)),$P(^(20),U,2)]"" W $E($P(^(20),U,2),1,28) - I $D(P2),$P(PRSHLB,"^",2)[200,$D(^VA(200,+P2,.13)),$L($P(^(.13),U,2))'>5 W " (",$P(^(.13),U,2),")" - N PRSHLC S PRSHLC=^DD(410,42,0) K P2 W ?37 I $D(P1),$P(PRSHLC,"^",2)[200,$D(^VA(200,P1,20)),$P(^(20),U,2)]"" W $E($P(^(20),U,2),1,30) - W ?69,! W:$P(^PRCS(410,DA,7),U,2)'="" $P(^(7),U,2) W ?37 W:$P(^(7),U,4)'="" $P(^(7),U,4) W ?69 I $P(^(7),U,5)'="" S Y=$P(^(7),U,5) D DD^%DT W Y -SIG1 W !,$E(L,1,36) - W " ",$E(L,38,68) - W "------------" I IOSL-$Y<5 D NEWP^PRCSD121 Q:Z1=U - W !,"Appropriation and Accounting Symbols" - S P=$P(^PRCS(410,DA,0),U,5) I $D(^(3)) S X=^(3) S:$P(X,U,2)'="" P=P_"-"_$P(X,U,2) S:$P(X,U)'="" P=P_"-"_$P($P(X,U)," ") S:$P(X,U,3)'="" P=P_"-"_$P($P(X,U,3)," ") - S:$D(PRCS("SUB")) P=P_"-"_PRCS("SUB") - I $D(^PRCS(410,DA,4)),$P(^(4),U,5)'="" S P=P_"-"_$P(^(4),U,5) - S FPROJ=$P($G(^PRCS(410,DA,3)),"^",12) S P=P_" "_FPROJ - W !,P,!,L - Q +PRCSD122 ;WISC/SAW-CONTROL POINT ACT. 2237 TERM. DISP. CON'T ;4/21/93 08:46 +V ;;5.1;IFCAP;;Oct 20, 2000 + ;Per VHA Directive 10-93-142, this routine should not be modified. + I IOSL-$Y<5 D NEWP^PRCSD121 Q:Z1=U + W !,"JUSTIFICATION OF NEED OR TURN-IN" + I '$D(^PRCS(410,DA,8,0)) G SIG + S DIWL=1,DIWR=80,DIWF="" K ^UTILITY($J,"W") S X1=0 F I=1:1 S X1=$O(^PRCS(410,DA,8,X1)) Q:X1="" S X=^(X1,0) D DIWP^PRCUTL($G(DA)) + S Z=^UTILITY($J,"W",DIWL) F K=1:1:Z D:IOSL-$Y<2 NEWP^PRCSD121 Q:Z1=U W !,^UTILITY($J,"W",DIWL,K,0) +SIG ;PRINT SIGNATURE BLOCKS + I IOSL-$Y<5 D NEWP^PRCSD121 Q:Z1=U + W !,L + W !,"Originator of Request: " S XNAME=$P($G(^PRCS(410,DA,14)),"^") I XNAME'="" W $P($G(^VA(200,XNAME,0)),"^") + W !,"Signature of Initiator",?37,"Signature of Approving Official Date" + I '$D(^PRCS(410,DA,7)) W ! G SIG1 + W !,?37 K P1 S:$P(^PRCS(410,DA,7),U,3)'="" (P,P1)=$P(^(7),U,3) I $D(P1),$P(^(7),U,6)'="" W "/ES/",$$DECODE^PRCSC1(DA) + N PRSHLB S PRSHLB=^DD(410,40,0) W ?69,! I $P(^PRCS(410,DA,7),U)'="" S (P,P2)=$P(^(7),U) I $P(PRSHLB,"^",2)[200,$D(^VA(200,P,20)),$P(^(20),U,2)]"" W $E($P(^(20),U,2),1,28) + I $D(P2),$P(PRSHLB,"^",2)[200,$D(^VA(200,+P2,.13)),$L($P(^(.13),U,2))'>4 W " (",$P(^(.13),U,2),")" + N PRSHLC S PRSHLC=^DD(410,42,0) K P2 W ?37 I $D(P1),$P(PRSHLC,"^",2)[200,$D(^VA(200,P1,20)),$P(^(20),U,2)]"" W $E($P(^(20),U,2),1,30) + W ?69,! W:$P(^PRCS(410,DA,7),U,2)'="" $P(^(7),U,2) W ?37 W:$P(^(7),U,4)'="" $P(^(7),U,4) W ?69 I $P(^(7),U,5)'="" S Y=$P(^(7),U,5) D DD^%DT W Y +SIG1 W !,$E(L,1,36) + W " ",$E(L,38,68) + W "------------" I IOSL-$Y<5 D NEWP^PRCSD121 Q:Z1=U + W !,"Appropriation and Accounting Symbols" + S P=$P(^PRCS(410,DA,0),U,5) I $D(^(3)) S X=^(3) S:$P(X,U,2)'="" P=P_"-"_$P(X,U,2) S:$P(X,U)'="" P=P_"-"_$P($P(X,U)," ") S:$P(X,U,3)'="" P=P_"-"_$P($P(X,U,3)," ") + S:$D(PRCS("SUB")) P=P_"-"_PRCS("SUB") + I $D(^PRCS(410,DA,4)),$P(^(4),U,5)'="" S P=P_"-"_$P(^(4),U,5) + S FPROJ=$P($G(^PRCS(410,DA,3)),"^",12) S P=P_" "_FPROJ + W !,P,!,L + Q diff --git a/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSP122.m b/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSP122.m index 284493ff..cd55b23b 100644 --- a/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSP122.m +++ b/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSP122.m @@ -1,32 +1,32 @@ -PRCSP122 ;WISC/SAW-CONTROL POINT ACTIVITY 2237 PRINTOUT CON'T ;4/21/93 08:53 -V ;;5.1;IFCAP;**95,107**;Oct 20, 2000;Build 13 - ;Per VHA Directive 2004-038, this routine should not be modified. - I '$D(^PRCS(410,DA,"RM",0)) G DEL - I $D(^PRCS(410,DA,"RM",0)) W ! S P(1)=0,DIWL=6,DIWR=96,DIWF="" K ^UTILITY($J,"W") S X="SPECIAL REMARKS:" D DIWP^PRCUTL($G(DA)) F J=1:1 S P(1)=$O(^PRCS(410,DA,"RM",P(1))) Q:P(1)="" S X=^(P(1),0) D DIWP^PRCUTL($G(DA)) - S Z=^UTILITY($J,"W",DIWL) F K=1:1:Z D:$Y>62 NEWP^PRCSP121 W !,^UTILITY($J,"W",DIWL,K,0) -DEL I $D(^PRCS(410,DA,9)),$P(^(9),U)'="" W !,"DELIVER TO: ",$P(^(9),U) - W !,L,!,"FOB",?24,"|TERMS",?48,"|DELIVERY DATE",?63,"|QUOTE DATE",?77,"|BY(Initials)",!,?24,"|",?48,"|",?63,"|",?77,"|" - W !,$E(L,1,24),"|",$E(L,1,23),"|",$E(L,1,14),"|",$E(L,1,13),"|",$E(L,1,12) - I $Y>58 D NEWP^PRCSP121 - W !,"JUSTIFICATION OF NEED OR TURN-IN (If recurring need, indicate 30-day estimate. If turn-in,",!,"do not use this form if circumstances require use of VA Form 90-1217, Report of Survey)" - I '$D(^PRCS(410,DA,8,0)) G SIG - S (MYTEMP,BFLAG)=0 - F I=1:1 S MYTEMP=$O(^PRCS(410,DA,8,MYTEMP)) Q:MYTEMP="" S BFLAG=1 - I BFLAG=0 G SIG - S DIWL=6,DIWR=96,DIWF="" K ^UTILITY($J,"W") S X1=0 F I=1:1 S X1=$O(^PRCS(410,DA,8,X1)) Q:X1="" S X=^(X1,0) D DIWP^PRCUTL($G(DA)) - S Z=^UTILITY($J,"W",DIWL) F K=1:1:Z D:$Y>62 NEWP^PRCSP121 W !,^UTILITY($J,"W",DIWL,K,0) -SIG ;PRINT SIGNATURE BLOCKS - I $Y>58 D NEWP^PRCSP121 - W !,L - W !,"Originator of Request: " S XNAME=$P($G(^PRCS(410,DA,14)),"^") I XNAME'="" W $P($G(^VA(200,XNAME,0)),"^") - W !,"Signature of Initiator",?39,"|Signature of Approving Official |Date" - I '$D(^PRCS(410,DA,7)) W !,?39,"|",?72,"|",!,?39,"|",?72,"|" G SIG1 - K P1 W !,?39,"|" S:$P(^PRCS(410,DA,7),U,3)'="" (P,P1)=$P(^(7),U,3) I $D(P1) W "/ES/",$$DECODE^PRCSC1(DA) - N PRSHLE S PRSHLE=^DD(410,40,0) W ?72,"|",! I $P(^PRCS(410,DA,7),U)'="" S (P,P2)=$P(^(7),U) I $P(PRSHLE,"^",2)[200,$D(^VA(200,P,20)),$P(^(20),U,2)]"" W $E($P(^(20),U,2),1,31) - I $D(P2),$P(^DD(410,40,0),"^",2)[200,$D(^VA(200,+P2,.13)),$L($P(^(.13),U,2))'>5 W " (",$P(^(.13),U,2),")" - K P2 W ?39,"|" I $D(P1),$P(^DD(410,42,0),"^",2)[200,$D(^VA(200,P1,20)),$P(^(20),U,2)]"" W $E($P(^(20),U,2),1,33) - W ?72,"|",! W:$P(^PRCS(410,DA,7),U,2)'="" $P(^(7),U,2) W ?39,"|" W:$P(^(7),U,4)'="" $P(^(7),U,4) W ?72,"|" S Y=$S($P(^(7),U,7):$P(^(7),U,7),1:$P(^(7),U,5)) I Y D DD^%DT W Y -SIG1 W !,$E(L,1,39) - W "|",$E(L,1,32) - W "|",$E(L,1,17) Q:PRNTALL=0 I $Y>41 D NEWP^PRCSP121 - Q +PRCSP122 ;WISC/SAW-CONTROL POINT ACTIVITY 2237 PRINTOUT CON'T ;4/21/93 08:53 +V ;;5.1;IFCAP;**95**;Oct 20, 2000 + ;Per VHA Directive 2004-038, this routine should not be modified. + I '$D(^PRCS(410,DA,"RM",0)) G DEL + I $D(^PRCS(410,DA,"RM",0)) W ! S P(1)=0,DIWL=6,DIWR=96,DIWF="" K ^UTILITY($J,"W") S X="SPECIAL REMARKS:" D DIWP^PRCUTL($G(DA)) F J=1:1 S P(1)=$O(^PRCS(410,DA,"RM",P(1))) Q:P(1)="" S X=^(P(1),0) D DIWP^PRCUTL($G(DA)) + S Z=^UTILITY($J,"W",DIWL) F K=1:1:Z D:$Y>62 NEWP^PRCSP121 W !,^UTILITY($J,"W",DIWL,K,0) +DEL I $D(^PRCS(410,DA,9)),$P(^(9),U)'="" W !,"DELIVER TO: ",$P(^(9),U) + W !,L,!,"FOB",?24,"|TERMS",?48,"|DELIVERY DATE",?63,"|QUOTE DATE",?77,"|BY(Initials)",!,?24,"|",?48,"|",?63,"|",?77,"|" + W !,$E(L,1,24),"|",$E(L,1,23),"|",$E(L,1,14),"|",$E(L,1,13),"|",$E(L,1,12) + I $Y>58 D NEWP^PRCSP121 + W !,"JUSTIFICATION OF NEED OR TURN-IN (If recurring need, indicate 30-day estimate. If turn-in,",!,"do not use this form if circumstances require use of VA Form 90-1217, Report of Survey)" + I '$D(^PRCS(410,DA,8,0)) G SIG + S (MYTEMP,BFLAG)=0 + F I=1:1 S MYTEMP=$O(^PRCS(410,DA,8,MYTEMP)) Q:MYTEMP="" S BFLAG=1 + I BFLAG=0 G SIG + S DIWL=6,DIWR=96,DIWF="" K ^UTILITY($J,"W") S X1=0 F I=1:1 S X1=$O(^PRCS(410,DA,8,X1)) Q:X1="" S X=^(X1,0) D DIWP^PRCUTL($G(DA)) + S Z=^UTILITY($J,"W",DIWL) F K=1:1:Z D:$Y>62 NEWP^PRCSP121 W !,^UTILITY($J,"W",DIWL,K,0) +SIG ;PRINT SIGNATURE BLOCKS + I $Y>58 D NEWP^PRCSP121 + W !,L + W !,"Originator of Request: " S XNAME=$P($G(^PRCS(410,DA,14)),"^") I XNAME'="" W $P($G(^VA(200,XNAME,0)),"^") + W !,"Signature of Initiator",?39,"|Signature of Approving Official |Date" + I '$D(^PRCS(410,DA,7)) W !,?39,"|",?72,"|",!,?39,"|",?72,"|" G SIG1 + K P1 W !,?39,"|" S:$P(^PRCS(410,DA,7),U,3)'="" (P,P1)=$P(^(7),U,3) I $D(P1) W "/ES/",$$DECODE^PRCSC1(DA) + N PRSHLE S PRSHLE=^DD(410,40,0) W ?72,"|",! I $P(^PRCS(410,DA,7),U)'="" S (P,P2)=$P(^(7),U) I $P(PRSHLE,"^",2)[200,$D(^VA(200,P,20)),$P(^(20),U,2)]"" W $E($P(^(20),U,2),1,31) + I $D(P2),$P(^DD(410,40,0),"^",2)[200,$D(^VA(200,+P2,.13)),$L($P(^(.13),U,2))'>4 W " (",$P(^(.13),U,2),")" + K P2 W ?39,"|" I $D(P1),$P(^DD(410,42,0),"^",2)[200,$D(^VA(200,P1,20)),$P(^(20),U,2)]"" W $E($P(^(20),U,2),1,33) + W ?72,"|",! W:$P(^PRCS(410,DA,7),U,2)'="" $P(^(7),U,2) W ?39,"|" W:$P(^(7),U,4)'="" $P(^(7),U,4) W ?72,"|" S Y=$S($P(^(7),U,7):$P(^(7),U,7),1:$P(^(7),U,5)) I Y D DD^%DT W Y +SIG1 W !,$E(L,1,39) + W "|",$E(L,1,32) + W "|",$E(L,1,17) Q:PRNTALL=0 I $Y>41 D NEWP^PRCSP121 + Q diff --git a/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSRIG1.m b/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSRIG1.m index dbe20950..4a9cf17d 100644 --- a/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSRIG1.m +++ b/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSRIG1.m @@ -1,83 +1,83 @@ -PRCSRIG1 ;WISC/SAW/KMB/LJP/SC-GENERATE REQUESTS FROM REPETITIVE ITEM LIST FILE (CON'T) ;3-3-93/14:30 ; 3/31/05 3:48pm -V ;;5.1;IFCAP;**13,81,101,110**;Oct 20, 2000;Build 7 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; - ;PRC*5.1*81, RIL that originated thru DynaMed is NOT allowed to be - ;RE-USED for generating 2237(s),hence removed this prompt for DM - ;trxs. only. - ; - U IO S PRCSNO=$P(^PRCS(410.3,PRCSRID0,0),"^"),PRC("SITE")=+PRCSNO,PRC("CP")=$S($D(^PRC(420,PRC("SITE"),1,+$P(PRCSNO,"-",4),0)):$P(^(0),"^"),1:"") - I PRC("CP")="" W !!,"Control Point ",$P(PRCSNO,"-",4),"no longer exists. You will have to transfer",!,"this repetitive item list to an existing control point before you can continue." K PRC("CP") G EXIT - ;Create transaction number - D:'$D(DT) DT^DICRW S PRCSTIME=$E(DT,4,5),PRCSQUAR=$P("2^2^2^3^3^3^4^4^4^1^1^1","^",PRCSTIME) - S:PQTR=1 PRCSQUAR=$P(PRCSNO,"-",3) - S Z1=$P(PRCSNO,"-")_"-"_PRC("FY")_"-"_PRCSQUAR_"-"_$P(PRCSNO,"-",4) - S Z2=$P(Z1,"-",1,2)_"-"_$P(Z1,"-",4) - S PRCSCC=$P(PRCSNO,"-",5),PRCSCC=$S($D(^PRCD(420.1,+PRCSCC,0)):$E($P(^(0),"^"),1,30),1:PRCSCC) S:PRCSCC="NONE" PRCSCC="" S X="N",%DT="T" D ^%DT S PRCSD1=$P(Y,".") X ^DD("DD") S PRCSD=Y,X="T+30" D ^%DT S PRCSD(1)=Y - ; - ;See NOIS MON-0399-51726 - KILL ^TMP($J) - S IB=0 - F S IB=$O(^PRCS(410.3,PRCSRID0,1,IB)) Q:'IB D ; - . S FF=$G(^PRCS(410.3,PRCSRID0,1,IB,0)) - . S ^TMP($J,410.3,PRCSRID0,1,"AC",$P(FF,"^",3)_";"_$P(FF,"^",5),IB)="" - ; - ; Loop thru RIL entry numbers. PRCSV1 is the vendor for - ;the item, from the Rep. Item List. Starting here, loop - ;thru the vendor to get the items ordered from that vendor, - ;using PRCSRI for the item. - S (PRCSV1,PRCSTC)="",(PRCSCT,PRCSCT(1),PRCSIT,BFLAG)=0 - F PRCSRIJ=0:1 S PRCSV1=$O(^TMP($J,410.3,PRCSRID0,1,"AC",PRCSV1)) Q:PRCSV1=""!(BFLAG=1) S PRCSCT=PRCSCT+1,PRCSCT(1)=PRCSCT(1)+1 D:'PRCSRIJ HDRG D ITEMG^PRCSRIG2 - I 'PRCSRIJ W !,"Items have not yet been entered for Repetitive Item List # ",PRCSNO G CLS - D:IOSL-$Y<3 HOLD,HDRG W !!,"Total no. of requests generated: ",PRCSCT," Total no. of items (all requests): ",PRCSIT,!,"Total committed (estimated) cost (all requests) : ","$"_$J(PRCSTC,0,2) -SV ; - I (IO'=IO(0))!($D(ZTQUEUED)) D ^%ZISC - ;patch *81 -DynaMed trx. is not allowed to be re-used - N PRCVSY,PRCVID - S PRCVSY=$$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q") - I PRCVSY=1 S PRCVID=$$ITDMID(PRCSRID0) - I PRCVSY=1,PRCVID=1 G CHK1 - G EXIT:$D(ZTQUEUED) - U IO(0) S %=2 W !,"Do you wish to re-use this list " D YN^DICN G:%=1 JMP G:%=0 SV -CHK1 I PRCSCT=PRCSCT(1) S DIK="^PRCS(410.3,",DA=PRCSRID0 D ^DIK G CLS -JMP D RLR^PRCSUT1 - S $P(^PRCS(410.3,PRCSRID0,0),U,5)="",DIK="^PRCS(410.3,",DA=PRCSRID0 D IX^DIK -CLS ; - D:$D(ZTSK) KILL^%ZTLOAD G EXIT - ; -HDRG W @IOF,"GENERATE REQUESTS FROM REPETITIVE ITEM LIST FILE",?55,"DATE: ",PRCSD,!,"Requests Generated From Repetitive Item List Entry # ",PRCSNO,! S L="",$P(L,"-",IOM)="-" W L S L="" - Q - ; -HOLD Q:IO'=IO(0)!($D(ZTQUEUED)) W !,"Press return to continue: " R Z(1):DTIME Q -ASK S %=2 W !,"Do you wish to edit this request" D YN^DICN D ASK:%=0 G:%=2 EN1 Q:%'=1 -EN W ! K DTOUT,DUOUT,Y S DIE="^PRCS(410,",(PRCSDR,DR)="[PRCSENPR]",T1=DA D ^DIE I $D(Y)!($D(DTOUT)) S DA=T1 Q - S DA=T1 D RL^PRCSUT1,^PRCSCK I $D(PRCSERR),PRCSERR G EN -EN1 W ! D W6^PRCSEB Q - ;***************************************************************** - ; PRCSRID0 represents the ien of the record in file 410.3 - ; patch *81 --itdmid removes Re-use Ques for DM related RIL - ;***************************************************************** -ITDMID(PRCSRID0) ; check DynaMed DOC ID existence for an item - ;N PRCVA,PRCVB,PRCVFLG - ;S PRCVA=0 - ;S PRCVFLG=0 ; 0 means that there is no DM ID on a item - ;S PRCVA=$O(^PRCS(410.3,PRCSRID0,1,PRCVA)) D - ;.Q:+$G(PRCVA)'>0 - ;.S PRCVB=$$GET1^DIQ(410.31,PRCVA_","_PRCSRID0_",",6) ; DM doc id - ;.I PRCVB'="" S PRCVFLG=1 Q - ;Q PRCVFLG - ; - ;Remove the prompt if entry is set in 414.02 Audit File 'C' x-ref - N PRCVFLG,PRCVL,PRCVM - S PRCVM=$$GET1^DIQ(410.3,PRCSRID0_",",.01) ; ext value of RIL trx - S PRCVL="" - S PRCVFLG=0 - S PRCVL=$O(^PRCV(414.02,"C",PRCVM,PRCVL)) - I PRCVL'="" S PRCVFLG=1 Q 1 - Q PRCVFLG - ; - ; -EXIT K %,%DT,%ZIS,PRCSRID0,DA,DIC,DIE,DIK,PRCSRIJ,K,L,PRCSRIM,PRCS,PRCSCS - K PRCSCT,PRCSCC,PRCSD,PRCSD1,PRCSRI,PRCSIT,PRCSL,PRCSNO,PRCSS,PRCSTC - K PRCSV1,PX,T1,X,X1,X2,Y,Z,Z1,Z2 - K PRCSTIME,PRCSQUAR,^TMP($J) Q +PRCSRIG1 ;WISC/SAW/KMB/LJP/SC-GENERATE REQUESTS FROM REPETITIVE ITEM LIST FILE (CON'T) ;3-3-93/14:30 ; 3/31/05 3:48pm +V ;;5.1;IFCAP;**13,81,101**;Oct 20, 2000 + ;Per VHA Directive 10-93-142, this routine should not be modified. + ; + ;PRC*5.1*81, RIL that originated thru DynaMed is NOT allowed to be + ;RE-USED for generating 2237(s),hence removed this prompt for DM + ;trxs. only. + ; + U IO S PRCSNO=$P(^PRCS(410.3,PRCSRID0,0),"^"),PRC("SITE")=+PRCSNO,PRC("CP")=$S($D(^PRC(420,PRC("SITE"),1,+$P(PRCSNO,"-",4),0)):$P(^(0),"^"),1:"") + I PRC("CP")="" W !!,"Control Point ",$P(PRCSNO,"-",4),"no longer exists. You will have to transfer",!,"this repetitive item list to an existing control point before you can continue." K PRC("CP") G EXIT + ;Create transaction number + D:'$D(DT) DT^DICRW S PRCSTIME=$E(DT,4,5),PRCSQUAR=$P("2^2^2^3^3^3^4^4^4^1^1^1","^",PRCSTIME) + S:PQTR=1 PRCSQUAR=$P(PRCSNO,"-",3) + S Z1=$P(PRCSNO,"-")_"-"_PRC("FY")_"-"_PRCSQUAR_"-"_$P(PRCSNO,"-",4) + S Z2=$P(Z1,"-",1,2)_"-"_$P(Z1,"-",4) + S PRCSCC=$P(PRCSNO,"-",5),PRCSCC=$S($D(^PRCD(420.1,+PRCSCC,0)):$E($P(^(0),"^"),1,30),1:PRCSCC) S:PRCSCC="NONE" PRCSCC="" S X="N",%DT="T" D ^%DT S PRCSD1=$P(Y,".") X ^DD("DD") S PRCSD=Y,X="T+30" D ^%DT S PRCSD(1)=Y + ; + ;See NOIS MON-0399-51726 + KILL ^TMP($J) + S IB=0 + F S IB=$O(^PRCS(410.3,PRCSRID0,1,IB)) Q:'IB D ; + . S FF=$G(^PRCS(410.3,PRCSRID0,1,IB,0)) + . S ^TMP($J,410.3,PRCSRID0,1,"AC",$P(FF,"^",3)_";"_$P(FF,"^",5),IB)="" + ; + ; Loop thru RIL entry numbers. PRCSV1 is the vendor for + ;the item, from the Rep. Item List. Starting here, loop + ;thru the vendor to get the items ordered from that vendor, + ;using PRCSRI for the item. + S (PRCSV1,PRCSTC)="",(PRCSCT,PRCSCT(1),PRCSIT,BFLAG)=0 + F PRCSRIJ=0:1 S PRCSV1=$O(^TMP($J,410.3,PRCSRID0,1,"AC",PRCSV1)) Q:PRCSV1=""!(BFLAG=1) S PRCSCT=PRCSCT+1,PRCSCT(1)=PRCSCT(1)+1 D:'PRCSRIJ HDRG D ITEMG^PRCSRIG2 + I 'PRCSRIJ W !,"Items have not yet been entered for Repetitive Item List # ",PRCSNO G CLS + D:IOSL-$Y<3 HOLD,HDRG W !!,"Total no. of requests generated: ",PRCSCT," Total no. of items (all requests): ",PRCSIT,!,"Total committed (estimated) cost (all requests) : ","$"_$J(PRCSTC,0,2) +SV ; + I (IO'=IO(0))!($D(ZTQUEUED)) D ^%ZISC + G EXIT:$D(ZTQUEUED) + ;patch *81 -DynaMed trx. is not allowed to be re-used + N PRCVSY,PRCVID + S PRCVSY=$$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q") + I PRCVSY=1 S PRCVID=$$ITDMID(PRCSRID0) + I PRCVSY=1,PRCVID=1 G CHK1 + U IO(0) S %=2 W !,"Do you wish to re-use this list " D YN^DICN G:%=1 JMP G:%=0 SV +CHK1 I PRCSCT=PRCSCT(1) S DIK="^PRCS(410.3,",DA=PRCSRID0 D ^DIK G CLS +JMP D RLR^PRCSUT1 + S $P(^PRCS(410.3,PRCSRID0,0),U,5)="",DIK="^PRCS(410.3,",DA=PRCSRID0 D IX^DIK +CLS ; + D:$D(ZTSK) KILL^%ZTLOAD G EXIT + ; +HDRG W @IOF,"GENERATE REQUESTS FROM REPETITIVE ITEM LIST FILE",?55,"DATE: ",PRCSD,!,"Requests Generated From Repetitive Item List Entry # ",PRCSNO,! S L="",$P(L,"-",IOM)="-" W L S L="" + Q + ; +HOLD Q:IO'=IO(0)!($D(ZTQUEUED)) W !,"Press return to continue: " R Z(1):DTIME Q +ASK S %=2 W !,"Do you wish to edit this request" D YN^DICN D ASK:%=0 G:%=2 EN1 Q:%'=1 +EN W ! K DTOUT,DUOUT,Y S DIE="^PRCS(410,",(PRCSDR,DR)="[PRCSENPR]",T1=DA D ^DIE I $D(Y)!($D(DTOUT)) S DA=T1 Q + S DA=T1 D RL^PRCSUT1,^PRCSCK I $D(PRCSERR),PRCSERR G EN +EN1 W ! D W6^PRCSEB Q + ;***************************************************************** + ; PRCSRID0 represents the ien of the record in file 410.3 + ; patch *81 --itdmid removes Re-use Ques for DM related RIL + ;***************************************************************** +ITDMID(PRCSRID0) ; check DynaMed DOC ID existence for an item + ;N PRCVA,PRCVB,PRCVFLG + ;S PRCVA=0 + ;S PRCVFLG=0 ; 0 means that there is no DM ID on a item + ;S PRCVA=$O(^PRCS(410.3,PRCSRID0,1,PRCVA)) D + ;.Q:+$G(PRCVA)'>0 + ;.S PRCVB=$$GET1^DIQ(410.31,PRCVA_","_PRCSRID0_",",6) ; DM doc id + ;.I PRCVB'="" S PRCVFLG=1 Q + ;Q PRCVFLG + ; + ;Remove the prompt if entry is set in 414.02 Audit File 'C' x-ref + N PRCVFLG,PRCVL,PRCVM + S PRCVM=$$GET1^DIQ(410.3,PRCSRID0_",",.01) ; ext value of RIL trx + S PRCVL="" + S PRCVFLG=0 + S PRCVL=$O(^PRCV(414.02,"C",PRCVM,PRCVL)) + I PRCVL'="" S PRCVFLG=1 Q 1 + Q PRCVFLG + ; + ; +EXIT K %,%DT,%ZIS,PRCSRID0,DA,DIC,DIE,DIK,PRCSRIJ,K,L,PRCSRIM,PRCS,PRCSCS + K PRCSCT,PRCSCC,PRCSD,PRCSD1,PRCSRI,PRCSIT,PRCSL,PRCSNO,PRCSS,PRCSTC + K PRCSV1,PX,T1,X,X1,X2,Y,Z,Z1,Z2 + K PRCSTIME,PRCSQUAR,^TMP($J) Q diff --git a/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCVRC2.m b/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCVRC2.m index 61eae7ae..2082b523 100644 --- a/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCVRC2.m +++ b/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCVRC2.m @@ -1,227 +1,220 @@ -PRCVRC2 ;WOIFO/BMM/VAC - silently build RIL for DynaMed ; 12/3/07 10:32am -V ;;5.1;IFCAP;**81,119**;Oct 20, 2000;Build 8 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; - ;12/07 Code modified to fix error in GETTXN due to logic error. - ; Added KILL statements to eliminate finding random ^TMP global data - ; from other routines and to clean up ^DIC calls. - ; - ;validation, error code for PRCVRC1 - ; - Q - ; -GETFY(PRCVDT) ;return the fiscal year, PRCVDT is date/time the DM - ;message was created (thus the date/time for RIL) - ; - Q $E(100+$E(PRCVDT,2,3)+$E(PRCVDT,4),2,3) - ; -GETQTR(PRCVDT) ;return the fiscal quarter, PRCVDT is date/time the DM - ;message was created (thus the date/time for RIL) - ; - N QTR S QTR=+$E(PRCVDT,4,5) - Q $P("2^2^2^3^3^3^4^4^4^1^1^1","^",+QTR) - ; -GETTXN(PRCVSTR) ;obtain current transaction number (if exists) from - ;Transaction Number file (#410.1) - ;increment transaction for current use, update 410.1 entry - ;return new transaction number for this RIL - ;PRCVSTR is Entry Number, comes in as "station-fy-qtr-fcp-cc" - ;TXN is transaction #, PRCVRN is IEN for 410.1 entry - ;NOTE: CHECK 410 too, look in EN1^PRCSUT3, lines 8-10 etc. - ; - Q:$G(PRCVSTR)="" 0 - N TXN,PRCVE,PRCVRN S TXN="",(PRCVRN,PRCVE)=0 - ;check if Entry Number def in 410.1 - K ATXN,^TMP("DIERR",$J),^TMP("DILIST",$J) - D FIND^DIC(410.1,,"1","BX",PRCVSTR,,,,,"ATXN") - ; - S TXN=+$G(ATXN("DILIST","ID",1,1)) - S PRCVRN=$G(ATXN("DILIST",2,1)) - I TXN<1 D Q:PRCVE=1 0 - . ;TXN=0 so Entry Number not def, create new - . K PRCVAT S PRCVAT(410.1,"+1,",.01)=PRCVSTR - . S PRCVAT(410.1,"+1,",2)=DT - . S PRCVAT(410.1,"+1,",1)=1 - . K ^TMP("DIERR",$J),^TMP("DILIST",$J) - . D UPDATE^DIE("","PRCVAT","PRCVRN") - . ;don't send msg here - . ;I $D(^TMP("DIERR",$J)) D SENDMSG(7,PRCVGL,0,1) S PRCVE=1 Q - . I $D(^TMP("DIERR",$J))>0 K ^TMP("DIERR",$J),^TMP("DILIST",$J) S PRCVE=1 Q - . S PRCVRN=PRCVRN(1) - S TXN=TXN+1 - K PRCVSA S PRCVSA(410.1,PRCVRN_",",1)=TXN - K ^TMP("DIERR",$J),^TMP("DILIST",$J) - D FILE^DIE("","PRCVSA") - ;don't send msg here - ;I $D(^TMP("DILIST",$J)) D SENDMSG(7,PRCVGL,0,1) Q 0 - I $D(^TMP("DIERR",$J))>0 K ^TMP("DIERR",$J),^TMP("DILIST",$J) Q 0 - K ^TMP("DIERR",$J),^TMP("DILIST",$J) - S TXN="000"_TXN,TXN=$E(TXN,$L(TXN)-3,$L(TXN)) - Q TXN - ; -CHKDT(INDT) ;check the incoming date (date/time message created) against - ;the present date. date/time message created must be today or in - ;the past. if INDT is today or before today then return 1, else - ;return 0 - ;both dates are in Fileman format ex. 3050503.12446 - ; - Q:$G(INDT)="" 0 - N %,PRESENT,PRCVDIFF - D NOW^%DTC S PRESENT=% - S PRCVDIFF=$$FMDIFF^XLFDT(PRESENT,INDT,1) - I PRCVDIFF'<0 Q 1 - Q 0 - ; -CHKDTN(INDT) ;check the incoming date (Date Needed By from DynaMed) - ;against the present date. Date Needed By must be today or in the - ;future. if INDT is today or after today then return 1, else return 0 - ;both dates are in FileMan format ex. 3050503.12446 - ; - Q:$G(INDT)="" 0 - N %,PRESENT,PRCVDIFF - D NOW^%DTC S PRESENT=% - S PRCVDIFF=$$FMDIFF^XLFDT(PRESENT,INDT,1) - I PRCVDIFF'>0 Q 1 - Q 0 - ; -CHKBOC(ITEM,BOC) ;test BOC from passed-in detail record - ; - Q:$G(ITEM)="" 0 - N PRCVIBOC - S PRCVIBOC=$$GET1^DIQ(441,ITEM_",",12,"I") - I PRCVIBOC'=BOC Q 0 - Q 1 - ; -CHKFCP(PRCVFCP,PRCVST) ;validate that FCP is in 420 - ; - Q:$G(PRCVFCP)=""!($G(PRCVST)="") 0 - N PRCVE,PRCVN,PRCVVAL - S PRCVVAL=1,PRCVN=0 - S PRCVN=$$FIND1^DIC(420.01,","_PRCVST_",","",PRCVFCP_" ","B","","PRCVE") - I +PRCVN'>0 S PRCVVAL=0 - Q PRCVVAL - ; -CHKITM(PRCVITM) ;check extracted item number: - ;1. must be greater than 100000 - ;2. must be defined in Item Master (#441) file - ;3. must not be inactive (441 field 16 '=1) - ; - Q:$G(PRCVITM)="" 0 - N CITM S CITM=0 - ;N NITM - ;S NITM=$$FIND1^DIC(441,"","X",PRCVITM,"","","ATXN") - ;I '$D(ATXN) Q 1 - I PRCVITM'<100000,$D(^PRC(441,"B",PRCVITM)) D - . I +$$GET1^DIQ(441,PRCVITM_",",16,"I")=0 S CITM=1 - Q CITM - ; -CHKVEND(VENDN) ;check that vendor in Vendor file is active. - ;VENDN is Vendor number - ; - Q:+VENDN=0 0 - N NVNDP,CHKFLG - S CHKFLG=0 - I $D(^PRC(440,VENDN,0)),$$GET1^DIQ(440,VENDN_",",32,"I")="" S CHKFLG=1 - Q CHKFLG - ; -CHKVI(VENDN,ITMN) ;check that vendor VENDN sells item ITMN - ;can't use $$FIND1^DIC since could be >1 cross-ref and >1 node - ; - N ITMNN,VENDP,CHKFLG - S (VENDP,ITMNN,CHKFLG)=0 - Q:+VENDN=0!(+ITMN=0) CHKFLG - ;get item ien, quit if undef - S ITMNN=$O(^PRC(441,"B",ITMN,0)) - Q:ITMNN="" CHKFLG - ;get pointer to vendor ien - S VENDP=$O(^PRC(441,ITMNN,2,"B",VENDN,0)) - ;check that vendor is defined - I VENDP>0,$D(^PRC(440,VENDP,0)) S CHKFLG=1 - ;if item file defined and vendor for item defined, good - Q CHKFLG - ; -CHKDUZ(INDUZ) ;validate that DUZ against New Person (#200) - ; - N DUZFLG S DUZFLG=0 - Q:$G(INDUZ)="" DUZFLG - I $D(^VA(200,INDUZ,0)) S DUZFLG=1 - Q DUZFLG - ; -CHKNIF(ITEM,NIF) ;use the passed-in item to check that the passed-in - ;NIF# is correct. return 1 if valid, 0 if not valid - ; - N PRCVINIF - S PRCVINIF=$$GET1^DIQ(441,ITEM_",",51) - I PRCVINIF=NIF Q 1 - Q 0 - ; -MAKECAP(INSTR) ;take INSTR and return an all-caps version of it - ; - Q:$G(INSTR)="" "" - N X,Y - S X=INSTR X ^%ZOSF("UPPERCASE") - Q Y - ; -SENDMSG(EC,PRCVGL,CTR,ERPC) ;send an alert or error message back to - ;DynaMed via VIE by posting "ERR" node to appropriate ^XTMP node - ; - ;the error text is currently stored in the routine PRCVRC3 - ; - ;EC is the error code - ;use EC to get the description and severity - ;the message is built in ECSTR and the "ERR" node in ^XTMP is - ; created using passed-in message id in MID. the error message - ; is appended to "ERR" and is separated by other error messages - ; already there with a carat ("^") - ;PRCVGL is the ^XTMP subscript and CTR is the detail counter # - ;ERPC is the data piece in the line item node or header node to - ; which the error pertains - ; - N X S X="PRCVRC3" - X ^%ZOSF("TEST") I '$T Q - N ECSTR,OVERSTR,ERRCTR - S ERPC=$G(ERPC) - S ECSTR=ERPC_"^"_$P($T(ET+EC^PRCVRC3),";;",2),CTR=+CTR - I CTR'=0 D - . S ERRCTR=+$O(^XTMP(PRCVGL,2,CTR,"ERR",""),-1) - . S ERRCTR=ERRCTR+1,^XTMP(PRCVGL,2,CTR,"ERR",ERRCTR)=ECSTR - I CTR=0 D - . S ERRCTR=+$O(^XTMP(PRCVGL,1,"ERR",""),-1) - . S ERRCTR=ERRCTR+1,^XTMP(PRCVGL,1,"ERR",ERRCTR)=ECSTR - Q - ; -ADDAUD(ADDSTR) ;add "^"-pieces from ADDSTR as fields to a new record in - ;the Audit file #410.02 - ; - ;ADDSTR pieces: DynaMed Doc ID ^ Item # ^ Vendor ^ User DUZ ^ - ; Last name,First name ^ RIL# ^ date/time RIL created ^ - ; date/time message created (DynaMed requisition) ^ date needed - ; - Q:$G(ADDSTR)="" - ; - ;set up entry - N PRCVA,PRCVI,PRCVP,PRCVRIL,PRCVTMP S PRCVA="",PRCVP=0 - F PRCVI=.01,1,2,3,13,4,5,6,12 S PRCVP=PRCVP+1 D - . S PRCVA(414.02,"+1,",PRCVI)=$P(ADDSTR,U,PRCVP) - ;add record to Audit File - D UPDATE^DIE("","PRCVA") - ;if error, send bulletin - I $D(^TMP("DIERR",$J)) D Q - . S PRCVTMP="PRCVRC2",PRCVRIL=$P(ADDSTR,U,5) - . S XMB(1)="creating an entry in the DynaMed Audit File (#414.02)" - . S XMB(2)=$P(ADDSTR,U) - . S XMB(3)="unable to create Audit File entry" - . S ^TMP($J,"PRCVRC2",1,0)="",PRCVP=1 - . S ^TMP($J,"PRCVRC2",2,0)="DynaMed Doc ID: "_$P(ADDSTR,U) - . S ^TMP($J,"PRCVRC2",3,0)="Item #: "_$P(ADDSTR,U,2) - . S ^TMP($J,"PRCVRC2",4,0)="Vendor #: "_$P(ADDSTR,U,3) - . S ^TMP($J,"PRCVRC2",5,0)="User DUZ: "_$P(ADDSTR,U,4) - . S ^TMP($J,"PRCVRC2",6,0)="RIL #: "_$P(ADDSTR,U,5) - . S ^TMP($J,"PRCVRC2",7,0)="Message date/time: "_$P(ADDSTR,U,6) - . S ^TMP($J,"PRCVRC2",8,0)="RIL create date: "_PRCVRIL - . S ^TMP($J,"PRCVRC2",9,0)="Date Needed: "_$P(ADDSTR,U,8) - . S ^TMP($J,"PRCVRC2",10,0)="Error: "_$G(^TMP("DIERR",$J,1,"TEXT",1)) - . S PRCVST=$P(PRCVRIL,"-"),PRCVFCP=$P(PRCVRIL,"-",4) - . D DMERXMB^PRCVLIC(PRCVTMP,PRCVST,PRCVFCP) - Q - ; +PRCVRC2 ;WOIFO/BMM - silently build RIL for DynaMed ; 12/16/04 +V ;;5.1;IFCAP;**81**;Oct 20, 2000 + ;Per VHA Directive 10-93-142, this routine should not be modified. + ; + ;validation, error code for PRCVRC1 + ; + Q + ; +GETFY(PRCVDT) ;return the fiscal year, PRCVDT is date/time the DM + ;message was created (thus the date/time for RIL) + ; + Q $E(100+$E(PRCVDT,2,3)+$E(PRCVDT,4),2,3) + ; +GETQTR(PRCVDT) ;return the fiscal quarter, PRCVDT is date/time the DM + ;message was created (thus the date/time for RIL) + ; + N QTR S QTR=+$E(PRCVDT,4,5) + Q $P("2^2^2^3^3^3^4^4^4^1^1^1","^",+QTR) + ; +GETTXN(PRCVSTR) ;obtain current transaction number (if exists) from + ;Transaction Number file (#410.1) + ;increment transaction for current use, update 410.1 entry + ;return new transaction number for this RIL + ;PRCVSTR is Entry Number, comes in as "station-fy-qtr-fcp-cc" + ;TXN is transaction #, PRCVRN is IEN for 410.1 entry + ;NOTE: CHECK 410 too, look in EN1^PRCSUT3, lines 8-10 etc. + ; + Q:$G(PRCVSTR)="" 0 + N TXN,PRCVE,PRCVRN S TXN="",(PRCVRN,PRCVE)=0 + ;check if Entry Number def in 410.1 + K ATXN + D FIND^DIC(410.1,,"1","BX",PRCVSTR,,,,,"ATXN") + ; + S TXN=+$G(ATXN("DILIST","ID",1,1)) + S PRCVRN=$G(ATXN("DILIST",2,1)) + I TXN<1 D Q:PRCVE=1 0 + . ;TXN=0 so Entry Number not def, create new + . K PRCVAT S PRCVAT(410.1,"+1,",.01)=PRCVSTR + . S PRCVAT(410.1,"+1,",2)=DT + . S PRCVAT(410.1,"+1,",1)=1 + . D UPDATE^DIE("","PRCVAT","PRCVRN") + . ;don't send msg here + . ;I $D(^TMP("DIERR",$J)) D SENDMSG(7,PRCVGL,0,1) S PRCVE=1 Q + . I $D(^TMP("DIERR",$J)) S PRCVE=1 Q + . S PRCVRN=PRCVRN(1) + S TXN=TXN+1 + K PRCVSA S PRCVSA(410.1,PRCVRN_",",1)=TXN + D FILE^DIE("","PRCVSA") + ;don't send msg here + ;I $D(^TMP("DILIST",$J)) D SENDMSG(7,PRCVGL,0,1) Q 0 + I $D(^TMP("DILIST",$J)) Q 0 + S TXN="000"_TXN,TXN=$E(TXN,$L(TXN)-3,$L(TXN)) + Q TXN + ; +CHKDT(INDT) ;check the incoming date (date/time message created) against + ;the present date. date/time message created must be today or in + ;the past. if INDT is today or before today then return 1, else + ;return 0 + ;both dates are in Fileman format ex. 3050503.12446 + ; + Q:$G(INDT)="" 0 + N %,PRESENT,PRCVDIFF + D NOW^%DTC S PRESENT=% + S PRCVDIFF=$$FMDIFF^XLFDT(PRESENT,INDT,1) + I PRCVDIFF'<0 Q 1 + Q 0 + ; +CHKDTN(INDT) ;check the incoming date (Date Needed By from DynaMed) + ;against the present date. Date Needed By must be today or in the + ;future. if INDT is today or after today then return 1, else return 0 + ;both dates are in FileMan format ex. 3050503.12446 + ; + Q:$G(INDT)="" 0 + N %,PRESENT,PRCVDIFF + D NOW^%DTC S PRESENT=% + S PRCVDIFF=$$FMDIFF^XLFDT(PRESENT,INDT,1) + I PRCVDIFF'>0 Q 1 + Q 0 + ; +CHKBOC(ITEM,BOC) ;test BOC from passed-in detail record + ; + Q:$G(ITEM)="" 0 + N PRCVIBOC + S PRCVIBOC=$$GET1^DIQ(441,ITEM_",",12,"I") + I PRCVIBOC'=BOC Q 0 + Q 1 + ; +CHKFCP(PRCVFCP,PRCVST) ;validate that FCP is in 420 + ; + Q:$G(PRCVFCP)=""!($G(PRCVST)="") 0 + N PRCVE,PRCVN,PRCVVAL + S PRCVVAL=1,PRCVN=0 + S PRCVN=$$FIND1^DIC(420.01,","_PRCVST_",","",PRCVFCP_" ","B","","PRCVE") + I +PRCVN'>0 S PRCVVAL=0 + Q PRCVVAL + ; +CHKITM(PRCVITM) ;check extracted item number: + ;1. must be greater than 100000 + ;2. must be defined in Item Master (#441) file + ;3. must not be inactive (441 field 16 '=1) + ; + Q:$G(PRCVITM)="" 0 + N CITM S CITM=0 + ;N NITM + ;S NITM=$$FIND1^DIC(441,"","X",PRCVITM,"","","ATXN") + ;I '$D(ATXN) Q 1 + I PRCVITM'<100000,$D(^PRC(441,"B",PRCVITM)) D + . I +$$GET1^DIQ(441,PRCVITM_",",16,"I")=0 S CITM=1 + Q CITM + ; +CHKVEND(VENDN) ;check that vendor in Vendor file is active. + ;VENDN is Vendor number + ; + Q:+VENDN=0 0 + N NVNDP,CHKFLG + S CHKFLG=0 + I $D(^PRC(440,VENDN,0)),$$GET1^DIQ(440,VENDN_",",32,"I")="" S CHKFLG=1 + Q CHKFLG + ; +CHKVI(VENDN,ITMN) ;check that vendor VENDN sells item ITMN + ;can't use $$FIND1^DIC since could be >1 cross-ref and >1 node + ; + N ITMNN,VENDP,CHKFLG + S (VENDP,ITMNN,CHKFLG)=0 + Q:+VENDN=0!(+ITMN=0) CHKFLG + ;get item ien, quit if undef + S ITMNN=$O(^PRC(441,"B",ITMN,0)) + Q:ITMNN="" CHKFLG + ;get pointer to vendor ien + S VENDP=$O(^PRC(441,ITMNN,2,"B",VENDN,0)) + ;check that vendor is defined + I VENDP>0,$D(^PRC(440,VENDP,0)) S CHKFLG=1 + ;if item file defined and vendor for item defined, good + Q CHKFLG + ; +CHKDUZ(INDUZ) ;validate that DUZ against New Person (#200) + ; + N DUZFLG S DUZFLG=0 + Q:$G(INDUZ)="" DUZFLG + I $D(^VA(200,INDUZ,0)) S DUZFLG=1 + Q DUZFLG + ; +CHKNIF(ITEM,NIF) ;use the passed-in item to check that the passed-in + ;NIF# is correct. return 1 if valid, 0 if not valid + ; + N PRCVINIF + S PRCVINIF=$$GET1^DIQ(441,ITEM_",",51) + I PRCVINIF=NIF Q 1 + Q 0 + ; +MAKECAP(INSTR) ;take INSTR and return an all-caps version of it + ; + Q:$G(INSTR)="" "" + N X,Y + S X=INSTR X ^%ZOSF("UPPERCASE") + Q Y + ; +SENDMSG(EC,PRCVGL,CTR,ERPC) ;send an alert or error message back to + ;DynaMed via VIE by posting "ERR" node to appropriate ^XTMP node + ; + ;the error text is currently stored in the routine PRCVRC3 + ; + ;EC is the error code + ;use EC to get the description and severity + ;the message is built in ECSTR and the "ERR" node in ^XTMP is + ; created using passed-in message id in MID. the error message + ; is appended to "ERR" and is separated by other error messages + ; already there with a carat ("^") + ;PRCVGL is the ^XTMP subscript and CTR is the detail counter # + ;ERPC is the data piece in the line item node or header node to + ; which the error pertains + ; + N X S X="PRCVRC3" + X ^%ZOSF("TEST") I '$T Q + N ECSTR,OVERSTR,ERRCTR + S ERPC=$G(ERPC) + S ECSTR=ERPC_"^"_$P($T(ET+EC^PRCVRC3),";;",2),CTR=+CTR + I CTR'=0 D + . S ERRCTR=+$O(^XTMP(PRCVGL,2,CTR,"ERR",""),-1) + . S ERRCTR=ERRCTR+1,^XTMP(PRCVGL,2,CTR,"ERR",ERRCTR)=ECSTR + I CTR=0 D + . S ERRCTR=+$O(^XTMP(PRCVGL,1,"ERR",""),-1) + . S ERRCTR=ERRCTR+1,^XTMP(PRCVGL,1,"ERR",ERRCTR)=ECSTR + Q + ; +ADDAUD(ADDSTR) ;add "^"-pieces from ADDSTR as fields to a new record in + ;the Audit file #410.02 + ; + ;ADDSTR pieces: DynaMed Doc ID ^ Item # ^ Vendor ^ User DUZ ^ + ; Last name,First name ^ RIL# ^ date/time RIL created ^ + ; date/time message created (DynaMed requisition) ^ date needed + ; + Q:$G(ADDSTR)="" + ; + ;set up entry + N PRCVA,PRCVI,PRCVP,PRCVRIL,PRCVTMP S PRCVA="",PRCVP=0 + F PRCVI=.01,1,2,3,13,4,5,6,12 S PRCVP=PRCVP+1 D + . S PRCVA(414.02,"+1,",PRCVI)=$P(ADDSTR,U,PRCVP) + ;add record to Audit File + D UPDATE^DIE("","PRCVA") + ;if error, send bulletin + I $D(^TMP("DIERR",$J)) D Q + . S PRCVTMP="PRCVRC2",PRCVRIL=$P(ADDSTR,U,5) + . S XMB(1)="creating an entry in the DynaMed Audit File (#414.02)" + . S XMB(2)=$P(ADDSTR,U) + . S XMB(3)="unable to create Audit File entry" + . S ^TMP($J,"PRCVRC2",1,0)="",PRCVP=1 + . S ^TMP($J,"PRCVRC2",2,0)="DynaMed Doc ID: "_$P(ADDSTR,U) + . S ^TMP($J,"PRCVRC2",3,0)="Item #: "_$P(ADDSTR,U,2) + . S ^TMP($J,"PRCVRC2",4,0)="Vendor #: "_$P(ADDSTR,U,3) + . S ^TMP($J,"PRCVRC2",5,0)="User DUZ: "_$P(ADDSTR,U,4) + . S ^TMP($J,"PRCVRC2",6,0)="RIL #: "_$P(ADDSTR,U,5) + . S ^TMP($J,"PRCVRC2",7,0)="Message date/time: "_$P(ADDSTR,U,6) + . S ^TMP($J,"PRCVRC2",8,0)="RIL create date: "_PRCVRIL + . S ^TMP($J,"PRCVRC2",9,0)="Date Needed: "_$P(ADDSTR,U,8) + . S ^TMP($J,"PRCVRC2",10,0)="Error: "_$G(^TMP("DIERR",$J,1,"TEXT",1)) + . S PRCVST=$P(PRCVRIL,"-"),PRCVFCP=$P(PRCVRIL,"-",4) + . D DMERXMB^PRCVLIC(PRCVTMP,PRCVST,PRCVFCP) + Q + ; diff --git a/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCVRE1.m b/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCVRE1.m index 6ebd5256..ad13cec0 100644 --- a/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCVRE1.m +++ b/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCVRE1.m @@ -1,224 +1,222 @@ -PRCVRE1 ;WOIFO/VC-Transmit HL7 message to IFCAP for requisition received from DynaMed ; 11/3/04 3:13pm ; 5/6/05 3:43pm - ;;5.1;IFCAP;**81,119**;Oct 20, 2000;Build 8 - ;Per VHA Directive 2004-038, this routine should not be modified - ; - ;An exemption from the 245 character length standard for a variable - ; has been requested from the SACC for reading HL7 segments into - ; a single variable. The limit is request to be 1K and if longer - ; than that the system will exit with an Application ACK reject. - ; Submitted 4/14/05. - ; - ;This routine processes messages from DynaMed to IFCAP to build a RIL - ; - ;HL("MID") - Message Control ID - ;HL7DT - Today's date in HL7 format - ;PRCDT - Date value - ;ORC Segment will repeat for each item - ; PRCORD - Order control should be NW for new order - ORC-1 - ; PRCFCP - Fund control Point - ORC-3 - ; PRCDATE - Date and time item entered - ORC-9 - ; PRCEMP - Enter by - ORC-10 DUZ^Lname^Fname^Approving Authority - ; PRCCC - Cost Center - ORC-17 - ; PRCSITE - Site Code should be 516 - ORC-21 - ;RQD Segment will repeat for each item - ; PRCCTR - Item counter - RQD-1 - ; PRCDOC - DynaMed Document number - unique per item - RQD-2 - ; PRCITM - Item number $p1 of RQD-3 - ; PRCQTY - Item quantity - RQD-5 - ; PRCNEED - Date Needed - RQD-10 - ;RQ1 Segment one segment for each RQD segment - ; PRCCOST - Estimated Unit Cost - RQ1-1 - ; PRCBOC - BOC Number - RQ1-3 - ; PRCVND - Vendor number - pointer to file 440 - RQ1-4 - ; PRCNIF - National Item File number - RQ1-5 - ;PRCTYP - Repetitive Item List type - default to blank - ;Message builds an ^XTMP to pass data to IFCAP RIL build routine. - ; The first node is "PRCVRE*"+the Message Control ID. The next nodes - ; are 0,1, and 2. The 0 node is the standard ^XTMP structure plus - ; $H. The $H is used to measure transmission timing. The 1 node holds - ; header data common to all detail items being transmitted. The 2 - ; node holds detail information about each item ordered in a counter - ; sub-node. - ; Under the 1 and 2 nodes are "ERR" subnodes that hold error - ; information about each item. There can be multiple errors - ; associated with each item, therefore there are multiple sub-nodes - ; possible under each "ERR" node. - ;Counters - ; PRCCNT, ACKCNT,PRCCC1,PRCFCP1,X,X1,X2,X8,X9,I,II,LL,ERRCNT - ;ERRCOD - Error code from IFCAP - ;ERRDAT - Error data from IFCAP - ;ERRSTR - Error text from IFCAP - ;ERRSUB - A substring of ERRSTR - ;ERRS - Error substring from IFCAP - ;SEVER - Error severity value - W or E - ;TOT,TOTERR,TOTGOOD,TOTREC - Counters of errors returned to DM - ;FLDNO - Field identified in an error message - ;ERRVAL - ERROR FLAG - ;ERRARY - Message Error array sent to Prosthetics - ;ERRLOC - Location of error sent in ACK - ;PRCCS, PRCFS, PRCRS - Field delimiters - ;PRCNODE - Message segment identifier - ;Temporary Globals - ; ^TMP("PRCVRIL",$J,"ACK") - Acknowledgement is ok - ; ^TMP("PRCVRIL",$J,"NAK") - Acknowledgement is not ok - ; ^TMP("HLA",$J) - Message array sent to DynaMed - ; ^XTMP("PRCVRE*"_Message Control ID,) - Data sent to IFCAP - ;Temporary variables - ; TMP,MSGFLG,X, X1 - ;PRCHD - Array to hold map between HL7 and XTMP for Header info - ;PRCDET - Array to hold map between HL7 and XTMP for Detail info - ;PRCVERR - Array to hold error messages for MailMan - ;PRCSUB - XTMP first node - ;PRCSUB2 - Second $p of PRCSUB equal to Message Control ID - ;PRCVRES - Return variable from GENACK - Note:this doesn't work. - ;PRCVINDX - Index number into XTMP to keep track of number of items - ; - Q - ; -BEGIN N PRCORD,DYNADATE,PRCDATE,PRCEMP,PRCSITE - N PRCDOC,PRCITM,PRCQTY,PRCFCP,PRCCC - N PRCCOST,PRCVND,PRCBOC,PRCNEED,PRCNIF - N PRCSUB,PRCSUB2,PRCDT,PRCVINDX - N ERRARY,PRCCS,PRCFS,PRCRS,PRCNODE,PRCNODE2 - N ACKCNT,NODE1,NODE2,PRCCTR,PRCCNT,PRCI,PRCJ,MID - N X,X1,X2,X8,X9,XX,TMP,PRCCC1,PRCFCP1,LENVAL - ; Fields used in PRCVREA are NEWed and KILLed here - N MSG,MSGFLG,DOCID,ERRCNT,ERRCOD,ERRDAT,ERRS,ERRSTR,ERRSUB,FLDNO - N I,IL,ERRTXT,I,II,III,J,SEVER,TOT,TOTERR,TOTGOOD,TOTREC - N PRCDET,PRCHD,PRCVERR,MYRESULT,ERRLOC,PRCVRES - D:'$D(U) DT^DICRW - S PRCDT=$$NOW^XLFDT - S HL7DT=$$FMTHL7^XLFDT(PRCDT),PRCDT=HL7DT - S PRCSUB="PRCVRE*"_HL("MID") K ^XTMP(PRCSUB) - D BUILD - S PRCCNT=0 - S PRCFS=$G(HL("FS")),PRCCS=$E($G(HL("ECH"))),PRCRS=$E($G(HL("ECH")),2) - D START - D CLEANUP - Q - ; -START ;This will read the incoming message from DynaMed and build ^TMP - ; -SETACK ; Set up information for the ACK or NAK - ; - K ^TMP("PRCVRIL",$J) - S ^TMP("PRCVRIL",$J,"ACK",1)="MSA"_PRCFS_"AA"_PRCFS_HL("MID") - S ^TMP("PRCVRIL",$J,"NAK",1)="MSA"_PRCFS_"AE"_PRCFS_HL("MID") - S ^TMP("PRCVRIL",$J,"NAK",2)="ERR"_PRCFS - S ACKCNT=2 - ; - ;If this is not the right message quit - ; - I HL("MTN")'="OMN" D Q - .S $P(^TMP("PRCVRIL",$J,"NAK",ACKCNT),PRCFS,2)="Wrong Message Type: "_HL("MTN") - .D NAKIT^PRCVREA - I HL("ETN")'="O07" D Q - .S $P(^TMP("PRCVRIL",$J,"NAK",ACKCNT),PRCFS,2)="Wrong Event Type: "_HL("ETN") - .D NAKIT^PRCVREA - ; - S ERRARY(1)="OK" - ; - ;Read the message and build the ^TMP global - ; - K ^TMP("PRCVRE",$J) - S PRCI="" - F PRCI=1:1 X HLNEXT Q:HLQUIT'>0 D - .S ^TMP("PRCVRE",$J,PRCSUB,PRCI)=HLNODE,PRCJ=0 - .F S PRCJ=$O(HLNODE(PRCJ)) Q:'PRCJ S ^TMP("PRCVRE",$J,PRCSUB,PRCI,PRCJ)=HLNODE(PRCJ) - .I $E(HLNODE,1,3)="ORC" D - ..S PRCFCP=$P(HLNODE,PRCFS,4),PRCCC=$P(HLNODE,PRCFS,18) - ..S TMP($J,PRCFCP,PRCCC)="" - ; - ;Validate that there is only one FCP and CC - S PRCFCP="",PRCFCP1="" - ; Prevent PRCCC1 undefined PRC*5.1*119 - S PRCCC1="" - F X8=1:1 S PRCFCP=$O(TMP($J,PRCFCP)) Q:PRCFCP="" D - .S PRCFCP1=X8 - .S PRCCC="" - .F X9=1:1 S PRCCC=$O(TMP($J,PRCFCP,PRCCC)) Q:PRCCC="" D - ..S PRCCC1=X9 - I (PRCFCP1>1)!(PRCCC1>1) D Q - .S $P(^TMP("PRCVRIL",$J,"NAK",2),PRCFS,2)="Message contains multiple FCP's or CC's: "_HL("ETN") D NAKIT^PRCVREA - ; -PARSIT ;Read the ^TMP global and build the ^XTMP global to pass to IFCAP - ; - S PRCI=0,PRCJ=0,LENVAL="OK" - F S PRCI=$O(^TMP("PRCVRE",$J,PRCSUB,PRCI)) Q:PRCI="" Q:LENVAL="NOTOK" D - .S NODE1=$G(^TMP("PRCVRE",$J,PRCSUB,PRCI)) Q:NODE1="" - .F PRCJ=1:1 D Q:$G(^TMP("PRCVRE",$J,PRCSUB,PRCI,PRCJ))="" - ..S NODE2=$G(^TMP("PRCVRE",$J,PRCSUB,PRCI,PRCJ)) - ..I $L(NODE1)+$L(NODE2)>1024 S LENVAL="NOTOK" Q - ..S NODE1=NODE1_NODE2 - .Q:LENVAL="NOTOK" - .S PRCNODE=$E(NODE1,1,3) - .; - .; IF MSH segment ignore the record - .; - .I PRCNODE="MSH" Q - .S PRCNODE2=$E(NODE1,5,$L(NODE1)) - .; - .; If ORC segment process the record - .; - .I PRCNODE="ORC" D Q - ..I $D(^XTMP(PRCSUB,1))'=0 Q - ..S PRCORD=$P(PRCNODE2,PRCFS,1),DYNADATE=$P(PRCNODE2,PRCFS,9),PRCEMP=$P($P(PRCNODE2,PRCFS,10),PRCCS,1,3),PRCSITE=$P(PRCNODE2,PRCFS,21) - ..S PRCFCP=$P(PRCNODE2,PRCFS,3),PRCCC=$P(PRCNODE2,PRCFS,17) - ..S PRCDATE=$$HL7TFM^XLFDT(DYNADATE) - ..S $P(^XTMP(PRCSUB,1),U,1)=0 - ..S $P(^XTMP(PRCSUB,1),U,4)=PRCORD,$P(^XTMP(PRCSUB,1),U,5)=PRCSITE - ..S $P(^XTMP(PRCSUB,1),U,6)=PRCDATE,$P(^XTMP(PRCSUB,1),U,7)=PRCEMP - .; - .; If RQD segment process the record - .; - .I PRCNODE="RQD" D Q - ..S PRCCTR=$P(PRCNODE2,PRCFS,1) - ..S PRCDOC=$P(PRCNODE2,PRCFS,2),PRCITM=$P(PRCNODE2,PRCFS,3) - ..S PRCQTY=$P(PRCNODE2,PRCFS,5),DYNADATE=$P(PRCNODE2,PRCFS,10) - ..S PRCNEED=$$HL7TFM^XLFDT(DYNADATE) - .; - .;If RQ1 segment process the record and build the XTMP global record - .; - .I PRCNODE="RQ1" D Q - ..S PRCCOST=$P(PRCNODE2,PRCFS,1),PRCBOC=$P(PRCNODE2,PRCFS,3),PRCVND=$P(PRCNODE2,PRCFS,4),PRCNIF=$P(PRCNODE2,PRCFS,5) - ..; - ..; Now build the XTMP record - ..; - ..S PRCVINDX=$P($G(^XTMP(PRCSUB,1)),U,1) - ..I PRCCTR>PRCVINDX S $P(^XTMP(PRCSUB,1),U,1)=PRCCTR - ..S $P(^XTMP(PRCSUB,1),U,2)=PRCFCP - ..S $P(^XTMP(PRCSUB,1),U,3)=PRCCC - ..S ^XTMP(PRCSUB,2,PRCCTR)=PRCITM_U_PRCQTY_U_PRCVND_U_PRCCOST_U_PRCNEED_U_PRCDOC_U_PRCNIF_U_PRCBOC - ; - I LENVAL="NOTOK" D Q - .S $P(^TMP("PRCVRIL",$J,"NAK",2),PRCFS,2)="HL7 Segment length greater than 1K" - .D NAKIT^PRCVREA - .K ^XTMP(PRCSUB) - D CALLIT^PRCVREA - Q - ; -BUILD ;Build the ^XTMP global zero node record. - ; - S XX=$$HTFM^XLFDT($H,1) - S X1=$$FMADD^XLFDT(XX,5) - S ^XTMP(PRCSUB,0)=X1_U_XX_"^Transmit message to IFCAP to build the RIL"_U_$H - Q - ; -CLEANUP ;This area will kill all temporary globals and variables - ; - K ^TMP("PRCVRE",$J),TMP($J) - K ^TMP("HLA",$J) - K ^TMP("PRCVRIL",$J) - K PRCCTR,PRCCNT,PRCORD,DYNADATE,PRCDATE,PRCEMP,PRCSITE,PRCDOC - K PRCITM,PRCQTY,PRCFCP,PRCCC,PRCNIF,PRCBOC - K PRCCOST,PRCVND,PRCSUB,PRCSUB2,PRCDT,PRCNEED - K PRCFS,PRCCS,PRCRS,PRCVINDX - K ERRARY - K PRCFS,PRCRS,PRCNODE,PRCNODE2,PRCI,PRCJ - K ACKCNT,NODE1,NODE2,LENVAL - K X,X1,X2,X8,X9,XX,TMP,PRCCC1,PRCFCP1 - ;Fields killed here are used in PRCVREA - K MID,MSG,MSGFLG,MYRESULT,PRCDET,PRCHD,ERRLOC,ERRSUB - K DOCID,ERRCNT,ERRCOD,ERRDAT,ERRS,ERRSTR,I,II,III,IL,J,ERRTXT,SEVER - K TOT,TOTERR,TOTGOOD,TOTREC,FLDNO,PRCVERR,PRCVRES - Q +PRCVRE1 ;WOIFO/VC-Transmit HL7 message to IFCAP for requisition received from DynaMed ; 11/3/04 3:13pm ; 5/6/05 3:43pm + ;;5.1;IFCAP;**81**;Oct 20, 2000 + ;Per VHA Directive 10-93-142, this routine should not be modified + ; + ;An exemption from the 245 character length standard for a variable + ; has been requested from the SACC for reading HL7 segments into + ; a single variable. The limit is request to be 1K and if longer + ; than that the system will exit with an Application ACK reject. + ; Submitted 4/14/05. + ; + ;This routine processes messages from DynaMed to IFCAP to build a RIL + ; + ;HL("MID") - Message Control ID + ;HL7DT - Today's date in HL7 format + ;PRCDT - Date value + ;ORC Segment will repeat for each item + ; PRCORD - Order control should be NW for new order - ORC-1 + ; PRCFCP - Fund control Point - ORC-3 + ; PRCDATE - Date and time item entered - ORC-9 + ; PRCEMP - Enter by - ORC-10 DUZ^Lname^Fname^Approving Authority + ; PRCCC - Cost Center - ORC-17 + ; PRCSITE - Site Code should be 516 - ORC-21 + ;RQD Segment will repeat for each item + ; PRCCTR - Item counter - RQD-1 + ; PRCDOC - DynaMed Document number - unique per item - RQD-2 + ; PRCITM - Item number $p1 of RQD-3 + ; PRCQTY - Item quantity - RQD-5 + ; PRCNEED - Date Needed - RQD-10 + ;RQ1 Segment one segment for each RQD segment + ; PRCCOST - Estimated Unit Cost - RQ1-1 + ; PRCBOC - BOC Number - RQ1-3 + ; PRCVND - Vendor number - pointer to file 440 - RQ1-4 + ; PRCNIF - National Item File number - RQ1-5 + ;PRCTYP - Repetitive Item List type - default to blank + ;Message builds an ^XTMP to pass data to IFCAP RIL build routine. + ; The first node is "PRCVRE*"+the Message Control ID. The next nodes + ; are 0,1, and 2. The 0 node is the standard ^XTMP structure plus + ; $H. The $H is used to measure transmission timing. The 1 node holds + ; header data common to all detail items being transmitted. The 2 + ; node holds detail information about each item ordered in a counter + ; sub-node. + ; Under the 1 and 2 nodes are "ERR" subnodes that hold error + ; information about each item. There can be multiple errors + ; associated with each item, therefore there are multiple sub-nodes + ; possible under each "ERR" node. + ;Counters + ; PRCCNT, ACKCNT,PRCCC1,PRCFCP1,X,X1,X2,X8,X9,I,II,LL,ERRCNT + ;ERRCOD - Error code from IFCAP + ;ERRDAT - Error data from IFCAP + ;ERRSTR - Error text from IFCAP + ;ERRSUB - A substring of ERRSTR + ;ERRS - Error substring from IFCAP + ;SEVER - Error severity value - W or E + ;TOT,TOTERR,TOTGOOD,TOTREC - Counters of errors returned to DM + ;FLDNO - Field identified in an error message + ;ERRVAL - ERROR FLAG + ;ERRARY - Message Error array sent to Prosthetics + ;ERRLOC - Location of error sent in ACK + ;PRCCS, PRCFS, PRCRS - Field delimiters + ;PRCNODE - Message segment identifier + ;Temporary Globals + ; ^TMP("PRCVRIL",$J,"ACK") - Acknowledgement is ok + ; ^TMP("PRCVRIL",$J,"NAK") - Acknowledgement is not ok + ; ^TMP("HLA",$J) - Message array sent to DynaMed + ; ^XTMP("PRCVRE*"_Message Control ID,) - Data sent to IFCAP + ;Temporary variables + ; TMP,MSGFLG,X, X1 + ;PRCHD - Array to hold map between HL7 and XTMP for Header info + ;PRCDET - Array to hold map between HL7 and XTMP for Detail info + ;PRCVERR - Array to hold error messages for MailMan + ;PRCSUB - XTMP first node + ;PRCSUB2 - Second $p of PRCSUB equal to Message Control ID + ;PRCVRES - Return variable from GENACK - Note:this doesn't work. + ;PRCVINDX - Index number into XTMP to keep track of number of items + ; + Q + ; +BEGIN N PRCORD,DYNADATE,PRCDATE,PRCEMP,PRCSITE + N PRCDOC,PRCITM,PRCQTY,PRCFCP,PRCCC + N PRCCOST,PRCVND,PRCBOC,PRCNEED,PRCNIF + N PRCSUB,PRCSUB2,PRCDT,PRCVINDX + N ERRARY,PRCCS,PRCFS,PRCRS,PRCNODE,PRCNODE2 + N ACKCNT,NODE1,NODE2,PRCCTR,PRCCNT,PRCI,PRCJ,MID + N X,X1,X2,X8,X9,XX,TMP,PRCCC1,PRCFCP1,LENVAL + ; Fields used in PRCVREA are NEWed and KILLed here + N MSG,MSGFLG,DOCID,ERRCNT,ERRCOD,ERRDAT,ERRS,ERRSTR,ERRSUB,FLDNO + N I,IL,ERRTXT,I,II,III,J,SEVER,TOT,TOTERR,TOTGOOD,TOTREC + N PRCDET,PRCHD,PRCVERR,MYRESULT,ERRLOC,PRCVRES + D:'$D(U) DT^DICRW + S PRCDT=$$NOW^XLFDT + S HL7DT=$$FMTHL7^XLFDT(PRCDT),PRCDT=HL7DT + S PRCSUB="PRCVRE*"_HL("MID") K ^XTMP(PRCSUB) + D BUILD + S PRCCNT=0 + S PRCFS=$G(HL("FS")),PRCCS=$E($G(HL("ECH"))),PRCRS=$E($G(HL("ECH")),2) + D START + D CLEANUP + Q + ; +START ;This will read the incoming message from DynaMed and build ^TMP + ; +SETACK ; Set up information for the ACK or NAK + ; + K ^TMP("PRCVRIL",$J) + S ^TMP("PRCVRIL",$J,"ACK",1)="MSA"_PRCFS_"AA"_PRCFS_HL("MID") + S ^TMP("PRCVRIL",$J,"NAK",1)="MSA"_PRCFS_"AE"_PRCFS_HL("MID") + S ^TMP("PRCVRIL",$J,"NAK",2)="ERR"_PRCFS + S ACKCNT=2 + ; + ;If this is not the right message quit + ; + I HL("MTN")'="OMN" D Q + .S $P(^TMP("PRCVRIL",$J,"NAK",ACKCNT),PRCFS,2)="Wrong Message Type: "_HL("MTN") + .D NAKIT^PRCVREA + I HL("ETN")'="O07" D Q + .S $P(^TMP("PRCVRIL",$J,"NAK",ACKCNT),PRCFS,2)="Wrong Event Type: "_HL("ETN") + .D NAKIT^PRCVREA + ; + S ERRARY(1)="OK" + ; + ;Read the message and build the ^TMP global + ; + K ^TMP("PRCVRE",$J) + S PRCI="" + F PRCI=1:1 X HLNEXT Q:HLQUIT'>0 D + .S ^TMP("PRCVRE",$J,PRCSUB,PRCI)=HLNODE,PRCJ=0 + .F S PRCJ=$O(HLNODE(PRCJ)) Q:'PRCJ S ^TMP("PRCVRE",$J,PRCSUB,PRCI,PRCJ)=HLNODE(PRCJ) + .I $E(HLNODE,1,3)="ORC" D + ..S PRCFCP=$P(HLNODE,PRCFS,4),PRCCC=$P(HLNODE,PRCFS,18) + ..S TMP($J,PRCFCP,PRCCC)="" + ; + ;Validate that there is only one FCP and CC + S PRCFCP="",PRCFCP1="" + F X8=1:1 S PRCFCP=$O(TMP($J,PRCFCP)) Q:PRCFCP="" D + .S PRCFCP1=X8 + .S PRCCC="" + .F X9=1:1 S PRCCC=$O(TMP($J,PRCFCP,PRCCC)) Q:PRCCC="" D + ..S PRCCC1=X9 + I (PRCFCP1>1)!(PRCCC1>1) D Q + .S $P(^TMP("PRCVRIL",$J,"NAK",2),PRCFS,2)="Message contains multiple FCP's or CC's: "_HL("ETN") D NAKIT^PRCVREA + ; +PARSIT ;Read the ^TMP global and build the ^XTMP global to pass to IFCAP + ; + S PRCI=0,PRCJ=0,LENVAL="OK" + F S PRCI=$O(^TMP("PRCVRE",$J,PRCSUB,PRCI)) Q:PRCI="" Q:LENVAL="NOTOK" D + .S NODE1=$G(^TMP("PRCVRE",$J,PRCSUB,PRCI)) Q:NODE1="" + .F PRCJ=1:1 D Q:$G(^TMP("PRCVRE",$J,PRCSUB,PRCI,PRCJ))="" + ..S NODE2=$G(^TMP("PRCVRE",$J,PRCSUB,PRCI,PRCJ)) + ..I $L(NODE1)+$L(NODE2)>1024 S LENVAL="NOTOK" Q + ..S NODE1=NODE1_NODE2 + .Q:LENVAL="NOTOK" + .S PRCNODE=$E(NODE1,1,3) + .; + .; IF MSH segment ignore the record + .; + .I PRCNODE="MSH" Q + .S PRCNODE2=$E(NODE1,5,$L(NODE1)) + .; + .; If ORC segment process the record + .; + .I PRCNODE="ORC" D Q + ..I $D(^XTMP(PRCSUB,1))'=0 Q + ..S PRCORD=$P(PRCNODE2,PRCFS,1),DYNADATE=$P(PRCNODE2,PRCFS,9),PRCEMP=$P($P(PRCNODE2,PRCFS,10),PRCCS,1,3),PRCSITE=$P(PRCNODE2,PRCFS,21) + ..S PRCFCP=$P(PRCNODE2,PRCFS,3),PRCCC=$P(PRCNODE2,PRCFS,17) + ..S PRCDATE=$$HL7TFM^XLFDT(DYNADATE) + ..S $P(^XTMP(PRCSUB,1),U,1)=0 + ..S $P(^XTMP(PRCSUB,1),U,4)=PRCORD,$P(^XTMP(PRCSUB,1),U,5)=PRCSITE + ..S $P(^XTMP(PRCSUB,1),U,6)=PRCDATE,$P(^XTMP(PRCSUB,1),U,7)=PRCEMP + .; + .; If RQD segment process the record + .; + .I PRCNODE="RQD" D Q + ..S PRCCTR=$P(PRCNODE2,PRCFS,1) + ..S PRCDOC=$P(PRCNODE2,PRCFS,2),PRCITM=$P(PRCNODE2,PRCFS,3) + ..S PRCQTY=$P(PRCNODE2,PRCFS,5),DYNADATE=$P(PRCNODE2,PRCFS,10) + ..S PRCNEED=$$HL7TFM^XLFDT(DYNADATE) + .; + .;If RQ1 segment process the record and build the XTMP global record + .; + .I PRCNODE="RQ1" D Q + ..S PRCCOST=$P(PRCNODE2,PRCFS,1),PRCBOC=$P(PRCNODE2,PRCFS,3),PRCVND=$P(PRCNODE2,PRCFS,4),PRCNIF=$P(PRCNODE2,PRCFS,5) + ..; + ..; Now build the XTMP record + ..; + ..S PRCVINDX=$P($G(^XTMP(PRCSUB,1)),U,1) + ..I PRCCTR>PRCVINDX S $P(^XTMP(PRCSUB,1),U,1)=PRCCTR + ..S $P(^XTMP(PRCSUB,1),U,2)=PRCFCP + ..S $P(^XTMP(PRCSUB,1),U,3)=PRCCC + ..S ^XTMP(PRCSUB,2,PRCCTR)=PRCITM_U_PRCQTY_U_PRCVND_U_PRCCOST_U_PRCNEED_U_PRCDOC_U_PRCNIF_U_PRCBOC + ; + I LENVAL="NOTOK" D Q + .S $P(^TMP("PRCVRIL",$J,"NAK",2),PRCFS,2)="HL7 Segment length greater than 1K" + .D NAKIT^PRCVREA + .K ^XTMP(PRCSUB) + D CALLIT^PRCVREA + Q + ; +BUILD ;Build the ^XTMP global zero node record. + ; + S XX=$$HTFM^XLFDT($H,1) + S X1=$$FMADD^XLFDT(XX,5) + S ^XTMP(PRCSUB,0)=X1_U_XX_"^Transmit message to IFCAP to build the RIL"_U_$H + Q + ; +CLEANUP ;This area will kill all temporary globals and variables + ; + K ^TMP("PRCVRE",$J),TMP($J) + K ^TMP("HLA",$J) + K ^TMP("PRCVRIL",$J) + K PRCCTR,PRCCNT,PRCORD,DYNADATE,PRCDATE,PRCEMP,PRCSITE,PRCDOC + K PRCITM,PRCQTY,PRCFCP,PRCCC,PRCNIF,PRCBOC + K PRCCOST,PRCVND,PRCSUB,PRCSUB2,PRCDT,PRCNEED + K PRCFS,PRCCS,PRCRS,PRCVINDX + K ERRARY + K PRCFS,PRCRS,PRCNODE,PRCNODE2,PRCI,PRCJ + K ACKCNT,NODE1,NODE2,LENVAL + K X,X1,X2,X8,X9,XX,TMP,PRCCC1,PRCFCP1 + ;Fields killed here are used in PRCVREA + K MID,MSG,MSGFLG,MYRESULT,PRCDET,PRCHD,ERRLOC,ERRSUB + K DOCID,ERRCNT,ERRCOD,ERRDAT,ERRS,ERRSTR,I,II,III,IL,J,ERRTXT,SEVER + K TOT,TOTERR,TOTGOOD,TOTREC,FLDNO,PRCVERR,PRCVRES + Q diff --git a/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCVREA.m b/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCVREA.m index 50d43c76..b50815f9 100644 --- a/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCVREA.m +++ b/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCVREA.m @@ -1,131 +1,129 @@ -PRCVREA ;WOIFO/VC-Transmit HL7 message to IFCAP for RIL(cont);11/24/03 ; 2/29/08 1:54pm - ;;5.1;IFCAP;**81,119**;Oct 20, 2000;Build 8 - ;Per VHA Directive 2004-038, this routine should not be modified - ; -CALLIT ;Call the IFCAP RIL build Routine - ; - D EN^PRCVRC1(PRCSUB) - ; -SETUP S PRCHD(1)="" - ;Added 1,"T" node to stop crash - S PRCHD(1,"T")="ORDER HEADER INFO" - S PRCHD(2)="ORC"_PRCCS_PRCCS_3 - S PRCHD(2,"T")="FUND CONTROL POINT" - S PRCHD(3)="ORC"_PRCCS_PRCCS_17 - S PRCHD(3,"T")="COST CENTER" - S PRCHD(4)="" - S PRCHD(5)="ORC"_PRCCS_PRCCS_21 - S PRCHD(5,"T")="SITE NUMBER" - S PRCHD(6)="" - S PRCHD(7)="ORC"_PRCCS_PRCCS_10 - S PRCHD(7,"T")="DUZ" - S PRCHD(8)="ORC"_PRCCS_PRCCS_10 - S PRCHD(8,"T")="LAST NAME" - S PRCHD(9)="ORC"_PRCCS_PRCCS_11 - S PRCHD(9,"T")="FIRST NAME" - S PRCDET(1)="RQD"_PRCCS_PRCCS_3 - S PRCDET(1,"T")="ITEM NUMBER" - S PRCDET(2)="RQD"_PRCCS_PRCCS_5 - S PRCDET(2,"T")="QUANTITY" - S PRCDET(3)="RQ1"_PRCCS_PRCCS_4 - S PRCDET(3,"T")="VENDOR ID" - S PRCDET(4)="RQ1"_PRCCS_PRCCS_1 - S PRCDET(4,"T")="UNIT COST" - S PRCDET(5)="RQD"_PRCCS_PRCCS_10 - S PRCDET(5,"T")="DATE NEEDED" - S PRCDET(6)="RQD"_PRCCS_PRCCS_2 - S PRCDET(6,"T")="DYNAMED DOCUMENT ID" - S PRCDET(7)="RQ1"_PRCCS_PRCCS_5 - S PRCDET(7,"T")="NIF NUMBER" - S PRCDET(8)="RQ1"_PRCCS_PRCCS_3 - S PRCDET(8,"T")="BOC" - ;Check if IFCAP has returned any errors - ; - S ERRCNT=1 - S PRCVERR(0)="0" -HEAD ;If there are errors in the "1" sub-segment, add all errors to all - ; line items - S ERRCNT=1,MSGFLG=0,PRCSUB2=$P(PRCSUB,"*",2) - I $D(^XTMP(PRCSUB,1,"ERR"))>0 D - .S II=0 - .F I=1:1 S II=$O(^XTMP(PRCSUB,1,"ERR",II)) Q:II="" D - ..S ERRDAT=$G(^XTMP(PRCSUB,1,"ERR",II)) - ..Q:ERRDAT="" - ..S MSGFLG=1 - ..S FLDNO=$P(ERRDAT,U,1),ERRCOD="PRCV"_$P(ERRDAT,U,2),ERRTXT=$P(ERRDAT,U,3) - ..S SEVER=$P(ERRDAT,U,4) - ..S ERRSTR="ERR"_PRCFS_PRCFS_PRCHD(FLDNO)_PRCFS_"207"_PRCCS_"Application internal error"_PRCCS_"HL70357"_PRCFS_SEVER_PRCFS_ERRCOD_PRCCS_ERRTXT_PRCFS - ..S PRCVERR(ERRCNT)="Error in Requisition Header for "_PRCHD(FLDNO,"T")_" from HL7 MESSAGE "_PRCSUB2_" "_ERRCOD_" "_ERRTXT,ERRCNT=ERRCNT+1 - ..S J=0 - ..F IL=1:1 S J=$O(^XTMP(PRCSUB,2,J)) Q:J="" D - ...S ERRSUB=$P(ERRSTR,PRCFS,3) - ...S $P(ERRSUB,U,2)=J - ...S $P(ERRSTR,PRCFS,3)=ERRSUB - ...;S $P($P(ERRSTR,PRCFS,3),U,2)=J - ...S $P(ERRSTR,PRCFS,7)=$P($G(^XTMP(PRCSUB,2,J)),U,6) - ...S ^TMP("PRCVRIL",$J,"NAK",ACKCNT)=ERRSTR,ACKCNT=ACKCNT+1 -DETAIL ;If there are errors in the detail lines, add them - S II=0 - F I=1:1 S II=$O(^XTMP(PRCSUB,2,II)) Q:II="" D - .S DOCID=$P(^XTMP(PRCSUB,2,II),U,6) - .S III=0 - .F J=1:1 S III=$O(^XTMP(PRCSUB,2,II,"ERR",III)) Q:III="" D - ..S ERRDAT=$G(^XTMP(PRCSUB,2,II,"ERR",III)) - ..Q:ERRDAT="" - ..S MSGFLG=1 - ..S FLDNO=$P(ERRDAT,U,1),ERRCOD="PRCV"_$P(ERRDAT,U,2),ERRTXT=$P(ERRDAT,U,3) - ..S ERRLOC=PRCDET(FLDNO),$P(ERRLOC,U,2)=II - ..S SEVER=$P(ERRDAT,U,4) - ..S ERRSTR="ERR"_PRCFS_PRCFS_ERRLOC_PRCFS_"207"_PRCCS_"Application internal error"_PRCCS_"HL70357"_PRCFS_SEVER_PRCFS_ERRCOD_PRCCS_ERRTXT_PRCFS_DOCID - ..S ^TMP("PRCVRIL",$J,"NAK",ACKCNT)=ERRSTR,ACKCNT=ACKCNT+1 - ..S PRCVERR(ERRCNT)="Error in detail for Message Control ID "_PRCSUB2_". Field in error - "_PRCDET(FLDNO,"T")_". "_ERRTXT_" DynaMed Doc ID "_DOCID - ..S ERRCNT=ERRCNT+1 - ; - I MSGFLG=0 D ACKIT,CLEANUP^PRCVRE1 Q -SETNTE ; If there are errors set an NTE segment - ; - S TOT=0,TOTREC=0,TOTERR=0 - F I=1:1 S TOT=$O(^XTMP(PRCSUB,2,TOT)) Q:TOT="" D - .S TOTREC=TOT - .I $D(^XTMP(PRCSUB,2,TOT,"ERR"))>0 D - ..S ERRS=0 - ..F J=1:1 S ERRS=$O(^XTMP(PRCSUB,2,TOT,"ERR",ERRS)) Q:ERRS="" D - ...S SEVER=$P($G(^XTMP(PRCSUB,2,TOT,"ERR",ERRS)),U,4) - ...I SEVER'="W" S TOTERR=TOTERR+1,ERRS=99 - I $D(^XTMP(PRCSUB,2,"ERR",1))>1 S TOTERR=TOTREC - S TOTGOOD=TOTREC-TOTERR - S ^TMP("PRCVRIL",$J,"NAK",ACKCNT)="NTE"_PRCFS_PRCFS_PRCFS_TOTREC_"-"_TOTERR_"-"_TOTGOOD,ACKCNT=ACKCNT+1 - D NAKIT,CLEANUP^PRCVRE1 Q - ; -NAKIT ;Send an acknowledgement that the message is rejected - ; - I HL("APAT")'="AL" Q - S MSG="" - F I=1:1 S MSG=$O(^TMP("PRCVRIL",$J,"NAK",MSG)) Q:MSG="" D - .S ^TMP("HLA",$J,I)=^TMP("PRCVRIL",$J,"NAK",MSG) - S PRCVRES="" - D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"GM",1,.PRCVRES) - ;I +$P(PRCVRES,U,2) D - ;.S PRCVERR(ERRCNT)="Application ACK not processed. Contact EVS." -MAIL ;Send MailMan message with error - Q:LENVAL="NOTOK" - N XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ - S XMSUB="RIL build errors in HL7 message "_HL("MID")_" " - S XMDUZ="IFCAP/DynaMed Interface" - S XMTEXT="PRCVERR(" - D GETFCPU^PRCVLIC(.XMY,PRCSITE,PRCFCP) - D ^XMD - K XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ - Q - ; -ACKIT ;Send an acknowledgement that everything went fine - ; - I HL("APAT")'="AL" Q - F I=1:1:1 S ^TMP("HLA",$J,I)=$G(^TMP("PRCVRIL",$J,"ACK",I)) - ; - D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"GM",1,.PRCVRES) - ;I +P(PRCVRES,U,2) D - ;.I $D(ERRCNT)=0 S ERRCNT=1 - ;.S PRCVERR(ERRCNT)="Application ACK not processed. Contact EVS." - ;.D MAIL - Q +PRCVREA ;WOIFO/VC-Transmit HL7 message to IFCAP for RIL(cont);11/24/03 ; 4/26/05 2:42pm + ;;5.1;IFCAP;**81**;Oct 20, 2000 + ;Per VHA Directive 10-93-142, this routine should not be modified + ; +CALLIT ;Call the IFCAP RIL build Routine + ; + D EN^PRCVRC1(PRCSUB) + ; +SETUP S PRCHD(1)="" + S PRCHD(2)="ORC"_PRCCS_PRCCS_3 + S PRCHD(2,"T")="FUND CONTROL POINT" + S PRCHD(3)="ORC"_PRCCS_PRCCS_17 + S PRCHD(3,"T")="COST CENTER" + S PRCHD(4)="" + S PRCHD(5)="ORC"_PRCCS_PRCCS_21 + S PRCHD(5,"T")="SITE NUMBER" + S PRCHD(6)="" + S PRCHD(7)="ORC"_PRCCS_PRCCS_10 + S PRCHD(7,"T")="DUZ" + S PRCHD(8)="ORC"_PRCCS_PRCCS_10 + S PRCHD(8,"T")="LAST NAME" + S PRCHD(9)="ORC"_PRCCS_PRCCS_11 + S PRCHD(9,"T")="FIRST NAME" + S PRCDET(1)="RQD"_PRCCS_PRCCS_3 + S PRCDET(1,"T")="ITEM NUMBER" + S PRCDET(2)="RQD"_PRCCS_PRCCS_5 + S PRCDET(2,"T")="QUANTITY" + S PRCDET(3)="RQ1"_PRCCS_PRCCS_4 + S PRCDET(3,"T")="VENDOR ID" + S PRCDET(4)="RQ1"_PRCCS_PRCCS_1 + S PRCDET(4,"T")="UNIT COST" + S PRCDET(5)="RQD"_PRCCS_PRCCS_10 + S PRCDET(5,"T")="DATE NEEDED" + S PRCDET(6)="RQD"_PRCCS_PRCCS_2 + S PRCDET(6,"T")="DYNAMED DOCUMENT ID" + S PRCDET(7)="RQ1"_PRCCS_PRCCS_5 + S PRCDET(7,"T")="NIF NUMBER" + S PRCDET(8)="RQ1"_PRCCS_PRCCS_3 + S PRCDET(8,"T")="BOC" + ;Check if IFCAP has returned any errors + ; + S ERRCNT=1 + S PRCVERR(0)="0" +HEAD ;If there are errors in the "1" sub-segment, add all errors to all + ; line items + S ERRCNT=1,MSGFLG=0,PRCSUB2=$P(PRCSUB,"*",2) + I $D(^XTMP(PRCSUB,1,"ERR"))>0 D + .S II=0 + .F I=1:1 S II=$O(^XTMP(PRCSUB,1,"ERR",II)) Q:II="" D + ..S ERRDAT=$G(^XTMP(PRCSUB,1,"ERR",II)) + ..Q:ERRDAT="" + ..S MSGFLG=1 + ..S FLDNO=$P(ERRDAT,U,1),ERRCOD="PRCV"_$P(ERRDAT,U,2),ERRTXT=$P(ERRDAT,U,3) + ..S SEVER=$P(ERRDAT,U,4) + ..S ERRSTR="ERR"_PRCFS_PRCFS_PRCHD(FLDNO)_PRCFS_"207"_PRCCS_"Application internal error"_PRCCS_"HL70357"_PRCFS_SEVER_PRCFS_ERRCOD_PRCCS_ERRTXT_PRCFS + ..S PRCVERR(ERRCNT)="Error in Requisition Header for "_PRCHD(FLDNO,"T")_" from HL7 MESSAGE "_PRCSUB2_" "_ERRCOD_" "_ERRTXT,ERRCNT=ERRCNT+1 + ..S J=0 + ..F IL=1:1 S J=$O(^XTMP(PRCSUB,2,J)) Q:J="" D + ...S ERRSUB=$P(ERRSTR,PRCFS,3) + ...S $P(ERRSUB,U,2)=J + ...S $P(ERRSTR,PRCFS,3)=ERRSUB + ...;S $P($P(ERRSTR,PRCFS,3),U,2)=J + ...S $P(ERRSTR,PRCFS,7)=$P($G(^XTMP(PRCSUB,2,J)),U,6) + ...S ^TMP("PRCVRIL",$J,"NAK",ACKCNT)=ERRSTR,ACKCNT=ACKCNT+1 +DETAIL ;If there are errors in the detail lines, add them + S II=0 + F I=1:1 S II=$O(^XTMP(PRCSUB,2,II)) Q:II="" D + .S DOCID=$P(^XTMP(PRCSUB,2,II),U,6) + .S III=0 + .F J=1:1 S III=$O(^XTMP(PRCSUB,2,II,"ERR",III)) Q:III="" D + ..S ERRDAT=$G(^XTMP(PRCSUB,2,II,"ERR",III)) + ..Q:ERRDAT="" + ..S MSGFLG=1 + ..S FLDNO=$P(ERRDAT,U,1),ERRCOD="PRCV"_$P(ERRDAT,U,2),ERRTXT=$P(ERRDAT,U,3) + ..S ERRLOC=PRCDET(FLDNO),$P(ERRLOC,U,2)=II + ..S SEVER=$P(ERRDAT,U,4) + ..S ERRSTR="ERR"_PRCFS_PRCFS_ERRLOC_PRCFS_"207"_PRCCS_"Application internal error"_PRCCS_"HL70357"_PRCFS_SEVER_PRCFS_ERRCOD_PRCCS_ERRTXT_PRCFS_DOCID + ..S ^TMP("PRCVRIL",$J,"NAK",ACKCNT)=ERRSTR,ACKCNT=ACKCNT+1 + ..S PRCVERR(ERRCNT)="Error in detail for Message Control ID "_PRCSUB2_". Field in error - "_PRCDET(FLDNO,"T")_". "_ERRTXT_" DynaMed Doc ID "_DOCID + ..S ERRCNT=ERRCNT+1 + ; + I MSGFLG=0 D ACKIT,CLEANUP^PRCVRE1 Q +SETNTE ; If there are errors set an NTE segment + ; + S TOT=0,TOTREC=0,TOTERR=0 + F I=1:1 S TOT=$O(^XTMP(PRCSUB,2,TOT)) Q:TOT="" D + .S TOTREC=TOT + .I $D(^XTMP(PRCSUB,2,TOT,"ERR"))>0 D + ..S ERRS=0 + ..F J=1:1 S ERRS=$O(^XTMP(PRCSUB,2,TOT,"ERR",ERRS)) Q:ERRS="" D + ...S SEVER=$P($G(^XTMP(PRCSUB,2,TOT,"ERR",ERRS)),U,4) + ...I SEVER'="W" S TOTERR=TOTERR+1,ERRS=99 + I $D(^XTMP(PRCSUB,2,"ERR",1))>1 S TOTERR=TOTREC + S TOTGOOD=TOTREC-TOTERR + S ^TMP("PRCVRIL",$J,"NAK",ACKCNT)="NTE"_PRCFS_PRCFS_PRCFS_TOTREC_"-"_TOTERR_"-"_TOTGOOD,ACKCNT=ACKCNT+1 + D NAKIT,CLEANUP^PRCVRE1 Q + ; +NAKIT ;Send an acknowledgement that the message is rejected + ; + I HL("APAT")'="AL" Q + S MSG="" + F I=1:1 S MSG=$O(^TMP("PRCVRIL",$J,"NAK",MSG)) Q:MSG="" D + .S ^TMP("HLA",$J,I)=^TMP("PRCVRIL",$J,"NAK",MSG) + S PRCVRES="" + D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"GM",1,.PRCVRES) + ;I +$P(PRCVRES,U,2) D + ;.S PRCVERR(ERRCNT)="Application ACK not processed. Contact EVS." +MAIL ;Send MailMan message with error + Q:LENVAL="NOTOK" + N XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ + S XMSUB="RIL build errors in HL7 message "_HL("MID")_" " + S XMDUZ="IFCAP/DynaMed Interface" + S XMTEXT="PRCVERR(" + D GETFCPU^PRCVLIC(.XMY,PRCSITE,PRCFCP) + D ^XMD + K XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ + Q + ; +ACKIT ;Send an acknowledgement that everything went fine + ; + I HL("APAT")'="AL" Q + F I=1:1:1 S ^TMP("HLA",$J,I)=$G(^TMP("PRCVRIL",$J,"ACK",I)) + ; + D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"GM",1,.PRCVRES) + ;I +P(PRCVRES,U,2) D + ;.I $D(ERRCNT)=0 S ERRCNT=1 + ;.S PRCVERR(ERRCNT)="Application ACK not processed. Contact EVS." + ;.D MAIL + Q diff --git a/r/IHS_ROUTINES-AUP/AUPNSICD.m b/r/IHS_ROUTINES-AUP/AUPNSICD.m index fea38d31..da7f3892 100644 --- a/r/IHS_ROUTINES-AUP/AUPNSICD.m +++ b/r/IHS_ROUTINES-AUP/AUPNSICD.m @@ -1,37 +1,34 @@ -AUPNSICD ;OHPRD/LAB - Screen Purpose of Visit/ICD9 codes ; 5/1/03 11:52am - ;;1.0;PCE PATIENT CARE ENCOUNTER;**121,149,190**;Aug 12, 1996;Build 9 - ;;93.2;IHS PATIENT DICTIONARIES.;;JUL 01, 1993 - ; - N ICDSTR,ICDVDT - ; Define variable PXCEVIEN - PX*1*190 - I '$D(PXCEVIEN) I DA I $G(^AUPNVPOV(DA,0)) S PXCEVIEN=$P(^AUPNVPOV(DA,0),U,3) - ;S ICDSTR=$$ICDDX^ICDCODE(Y,$P(^AUPNVSIT(PXCEVIEN,0),"^",2)) - S ICDSTR=$$ICDDX^ICDCODE(Y,+^AUPNVSIT(PXCEVIEN,0)),ICDVDT=+^AUPNVSIT(PXCEVIEN,0) - G:$G(DUZ("AG"))="V" VAIN - ; - ;I 1 Q:$G(DUZ("AG"))'="I" -EIN ; SCREEN OUT E CODES AND INACTIVE CODES - ;I $E(^ICD9(Y,0),U,1)'="E",$P(^(0),U,9)="" - ;I $P(^ICD9(Y,0),U,1)'="E",$P(^(0),U,9)="" - I $P(ICDSTR,U,2)'="E",$P(ICDSTR,U,10)=1 - G:'$T XIT -SEX ; IF 'USE WITH SEX' FIELD HAS A VALUE CHECK THAT VALUE AGAINST AUPNSEX - G:'$D(AUPNSEX) AGE - I $P(^ICD9(Y,0),U,10)=""!($P(^ICD9(Y,0),U,10)=AUPNSEX) - G:'$T XIT -AGE ; IF THERE IS AGE CRITERIA DATA AVAILABLE CHECK TO SEE THAT IT FITS THE CRITERIA - ;G:'$D(AUPNDAYS) XIT - ;G:'$D(^ICD9(Y,9999999)) XIT - ;I $P(^(9999999),U,1)=""!($P(^(9999999),U,1)AUPNDAYS) -XIT ; - K DA,PXCEVIEN - Q - ; -VAIN ;SCREEN OUT INACTIVE CODES - ; E codes are ok in the VA - ;I $P(^ICD9(Y,0),U,9)'=1 - I $P(ICDSTR,U,10)=1 - Q - ; +AUPNSICD ;OHPRD/LAB - Screen Purpose of Visit/ICD9 codes ; 5/1/03 11:52am + ;;1.0;PCE PATIENT CARE ENCOUNTER;**121,149**;Aug 12, 1996 + ;;93.2;IHS PATIENT DICTIONARIES.;;JUL 01, 1993 + ; + N ICDSTR,ICDVDT + ;S ICDSTR=$$ICDDX^ICDCODE(Y,$P(^AUPNVSIT(PXCEVIEN,0),"^",2)) + S ICDSTR=$$ICDDX^ICDCODE(Y,+^AUPNVSIT(PXCEVIEN,0)),ICDVDT=+^AUPNVSIT(PXCEVIEN,0) + G:$G(DUZ("AG"))="V" VAIN + ; + ;I 1 Q:$G(DUZ("AG"))'="I" +EIN ; SCREEN OUT E CODES AND INACTIVE CODES + ;I $E(^ICD9(Y,0),U,1)'="E",$P(^(0),U,9)="" + ;I $P(^ICD9(Y,0),U,1)'="E",$P(^(0),U,9)="" + I $P(ICDSTR,U,2)'="E",$P(ICDSTR,U,10)=1 + G:'$T XIT +SEX ; IF 'USE WITH SEX' FIELD HAS A VALUE CHECK THAT VALUE AGAINST AUPNSEX + G:'$D(AUPNSEX) AGE + I $P(^ICD9(Y,0),U,10)=""!($P(^ICD9(Y,0),U,10)=AUPNSEX) + G:'$T XIT +AGE ; IF THERE IS AGE CRITERIA DATA AVAILABLE CHECK TO SEE THAT IT FITS THE CRITERIA + ;G:'$D(AUPNDAYS) XIT + ;G:'$D(^ICD9(Y,9999999)) XIT + ;I $P(^(9999999),U,1)=""!($P(^(9999999),U,1)AUPNDAYS) +XIT ; + Q + ; +VAIN ;SCREEN OUT INACTIVE CODES + ; E codes are ok in the VA + ;I $P(^ICD9(Y,0),U,9)'=1 + I $P(ICDSTR,U,10)=1 + Q + ; diff --git a/r/IMAGING-MAG-ZMAG/MAGBAPIP.m b/r/IMAGING-MAG-ZMAG/MAGBAPIP.m index bded6e2c..e63d42fa 100644 --- a/r/IMAGING-MAG-ZMAG/MAGBAPIP.m +++ b/r/IMAGING-MAG-ZMAG/MAGBAPIP.m @@ -1,64 +1,63 @@ -MAGBAPIP ;WOIFO/MLH - Background Processor API to build queues - Modules for place - ;;3.0;IMAGING;**1,7,8,20,59**;Nov 27, 2007;Build 20 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; -DUZ2PLC(WARN) ;Convert DUZ to a PLACE. File 2006.1 entry (PLACE) - ; Extrinsic : Always returns a PLACE - ; WARN : message about where the PLACE was derived from. - ; Compute the Users Institution for older versions of Imaging Display workstation. - ; This is called when DUZ(2) doesn't exist Or Can't resolve DUZ(2) - ; into site param entry. This solved a GateWay Problem where DUZ(2) didn't - ; exist. - Shouldn't get here anymore, that was fixed. - N MAGINST,DIVDTA,PLACE - S MAGINST=0 - D GETS^DIQ(200,DUZ,"16*","I","DIVDTA") ; look up Division field - ; ? Any division data on file for this user - I $D(DIVDTA) D ; yes, use it - . S MAGINST=@$Q(DIVDTA),WARN="Using first Division of New Person File." - . Q - E D ; no, use default site param? - . S MAGINST=$$KSP^XUPARAM("INST"),WARN="Using Kernel Site Param default entry." Q - . Q - S PLACE=$$GETPLACE^MAGBAPI(+$$PLACE^MAGBAPI(MAGINST)) - I 'PLACE S PLACE=$O(^MAG(2006.1,0)),WARN="Using First Site Param entry." - Q PLACE - ; -DA2PLC(MAGDA,TYPE) ; Get Place from Image File IEN - ; TYPE : Possible values "A" Abstract, "F" Full Res or "B" Big File - ; (defaults to "F" if null) - ; Resolve Place (PLC) using the Acquisition Site field (ACQS) - ; IF ACQS is null or not doesn't exist in the site parameter file - ; THEN Resolve PLC using NetWork Location pointer - ; - N MAGREF,MAG0,FBIG,SITE,PLC,MAGJB - I '$G(MAGDA) Q 0 - S SITE=$P($G(^MAG(2005,MAGDA,100)),U,3) - I SITE S PLC=$$PLACE^MAGBAPI(SITE) Q:PLC PLC - ; p59 Stop the error when an Image is Deleted. - S MAG0=$G(^MAG(2005,MAGDA,0)) Q:MAG0="" 0 - ; - S TYPE=$E($G(TYPE)_"F",1) - I "AF"[TYPE D - . S MAGREF=$S(TYPE="A":+$P(MAG0,"^",4),1:+$P(MAG0,"^",3)) - . I MAGREF=0 S MAGJB=1,MAGREF=+$P(MAG0,"^",5) ; get file from jukebox - I "B"[TYPE D - . S FBIG=$G(^MAG(2005,MAGDA,"FBIG")) - . S MAGREF=+$P(FBIG,"^") ; get file from magnetic disk, if possible - . I MAGREF=0 S MAGREF=+$P(FBIG,"^",2) ; get file from jukebox - I 'MAGREF Q 0 - I '$D(^MAG(2005.2,MAGREF,0)) Q 0 - Q $$GETPLACE^MAGBAPI(+$$GET1^DIQ(2005.2,MAGREF,.04,"I")) +MAGBAPIP ;WOIFO/MLH - Background Processor API to build queues - Modules for place + ;;3.0;IMAGING;**1,7,8,20**;Apr 12, 2006 + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; +DUZ2PLC(WARN) ; Moved from MAGGTU3 v2.5 - DBI - SEB Patch 4 + ; Extrinsic : Always returns a PLACE /gek 8/2003 + ; WARN : message about where the PLACE was derived from. /gek 8/2003 + ; Compute the Users Institution for older versions of Imaging Display workstation. + ; This is called when : + ; DUZ(2) doesn't exist, + ; Or Can't resolve DUZ(2) into site param entry + N MAGINST,DIVDTA,PLACE + S MAGINST=0 + D GETS^DIQ(200,DUZ,"16*","I","DIVDTA") ; look up Division field + ; ? Any division data on file for this user + I $D(DIVDTA) D ; yes, use it + . S MAGINST=@$Q(DIVDTA),WARN="Using first Division of New Person File." + . Q + E D ; no, use default site param? + . S MAGINST=$$KSP^XUPARAM("INST"),WARN="Using Kernel Site Param default entry." Q + . Q + S PLACE=$$GETPLACE^MAGBAPI(+$$PLACE^MAGBAPI(MAGINST)) + I 'PLACE S PLACE=$O(^MAG(2006.1,0)),WARN="Using First Site Param entry." + Q PLACE + ; +DA2PLC(MAGDA,TYPE) ; Moved from MAGGTU7 v2.5 - DBI - SEB Patch 4 + ; TYPE : Possible values "A" Abstract, "F" Full Res or "B" Big File + ; (defaults to "F" if null) + ; Resolve current place of image using the Acquisition Site field, then + ; resolve current place of image using NetWork Location pointer + ; if the Acquisition Site field is null or not related to the site + ; parameter file. + ; + N MAGREF,MAG0,FBIG,SITE,PLC,MAGJB + I '$G(MAGDA) Q 0 + S SITE=$P($G(^MAG(2005,MAGDA,100)),U,3) + I SITE S PLC=$$PLACE^MAGBAPI(SITE) Q:PLC PLC + S MAG0=^MAG(2005,MAGDA,0) + ;I '$D(TYPE) S TYPE="F" /gek 8/2003 mod for efficiency (from ed) + S TYPE=$E($G(TYPE)_"F",1) + I "AF"[TYPE D + . S MAGREF=$S(TYPE="A":+$P(MAG0,"^",4),1:+$P(MAG0,"^",3)) + . I MAGREF=0 S MAGJB=1,MAGREF=+$P(MAG0,"^",5) ; get file from jukebox + I "B"[TYPE D + . S FBIG=$G(^MAG(2005,MAGDA,"FBIG")) + . S MAGREF=+$P(FBIG,"^") ; get file from magnetic disk, if possible + . I MAGREF=0 S MAGREF=+$P(FBIG,"^",2) ; get file from jukebox + I 'MAGREF Q 0 + I '$D(^MAG(2005.2,MAGREF,0)) Q 0 + Q $$GETPLACE^MAGBAPI(+$$GET1^DIQ(2005.2,MAGREF,.04,"I")) diff --git a/r/IMAGING-MAG-ZMAG/MAGGNLKP.m b/r/IMAGING-MAG-ZMAG/MAGGNLKP.m index 3b7302ac..28c5a66a 100644 --- a/r/IMAGING-MAG-ZMAG/MAGGNLKP.m +++ b/r/IMAGING-MAG-ZMAG/MAGGNLKP.m @@ -1,96 +1,97 @@ -MAGGNLKP ;WOIFO/GEK - Lookup from delphi into any file ; [ 06/20/2001 08:56 ] - ;;3.0;IMAGING;**8,92,46,59**;Nov 27, 2007;Build 20 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q - ; -LKP(MAGRY,MAGIN,DATA) ;RPC [MAG3 LOOKUP ANY] - ; Generic lookup using FIND^DIC - ; MAGRY is the Array to return. - ; MAGIN is parameter sent by calling app (Delphi) - ; FILE NUM ^ NUM TO RETURN ^ TEXT TO MATCH ^ FIELDS ^ SCREEN ($P 5-99) - ; - ; DATA : - ; LVIEW =Piece 1 - ; +LVIEW = 1 : - ; result array is formatted for a magListView control - ; i.e. ^ delimiter for data and "|" delimiter for IEN - ; +LVIEW = 0 : - ; old way, " " delim for data and '^' delim for IEN - ; INDX = Piece 2 - ; This is the index to search - ; Defaults to "B" - ; - N $ETRAP,$ESTACK S $ETRAP="D ERRA^MAGGTERR" - ; - N Y,XI,Z,FI,MAGIEN,INFO,LVIEW,INDX - N FILE,IENS,FLDS,FLAGS,VAL,NUM,INDEX,SCR,IDENT,TROOT - S (FILE,IENS,FLDS,FLAGS,VAL,NUM,INDEX,SCR,IDENT,TROOT)="" - S MAGIN=$G(MAGIN) - S DATA=$G(DATA) - ; - S FILE=+$P(MAGIN,U,1) - S NUM=$S(+$P(MAGIN,U,2):+$P(MAGIN,U,2),1:200) - S VAL=$P(MAGIN,U,3) - S FLDS=$P(MAGIN,U,4) - S SCR=$P(MAGIN,U,5,99) - ; - S LVIEW=+$P(DATA,"^",1) - S INDX=$S($L($P(DATA,"^",2)):$P(DATA,"^",2),1:"B") - ; - I 'FILE S MAGRY(1)="0^ERROR - Invalid Parameter: File Number ? " Q - I '$$VFILE^DILFD(FILE) S MAGRY(1)="0^ERROR - Invalid File # - "_FILE Q - ; Number of entries to return, If 0 we'll stop at 200 - ; - K ^TMP("DILIST",$J) - K ^TMP("DIERR",$J) - ; VAL is the initial value to search for. i.e. the user input. - ; Next line is to stop the FM Infinite Error Trap problem. - I $L(VAL)>30 S MAGRY(0)="0^Invalid Input: '"_$E(VAL,1,40)_"...' is too long. "_$L(VAL)_" characters." Q - D FIND^DIC(FILE,IENS,FLDS,FLAGS,VAL,NUM,INDEX,SCR,IDENT,TROOT) - ; - I '$D(^TMP("DILIST",$J,1)) S XI=1 D Q - . I $D(^TMP("DIERR",$J)) D FINDERR(XI) Q - . S MAGRY(XI)="0^NO MATCH for lookup on """_$P(MAGIN,"^",3)_"""" - ; so we have some matches, (BUT we could still have an error) - ; so first list all matches, then the ERROR - ; Next lines were Q&D but old .EXE's expect return string with - ; this syntax, when all T11 code is gone, this can be rewritten - I LVIEW S XI="" F S XI=$O(^TMP("DILIST",$J,1,XI)) Q:XI="" S X=^(XI) D - . S MAGIEN=^TMP("DILIST",$J,2,XI) - . S Z=".01",FLD="NAME" - . F S Z=$O(^TMP("DILIST",$J,"ID",XI,Z)) Q:Z="" S X=X_"^"_^(Z),FLD=FLD_"^"_$$GET1^DID(FILE,Z,"","LABEL","MAGFLD") - . S MAGRY(.05)=FLD - . S MAGRY(XI)=X_"^|"_MAGIEN - . Q - I 'LVIEW S XI="" F S XI=$O(^TMP("DILIST",$J,1,XI)) Q:XI="" S X=^(XI) D - . S MAGIEN=^TMP("DILIST",$J,2,XI) - . S Z="" - . F S Z=$O(^TMP("DILIST",$J,"ID",XI,Z)) Q:Z="" S X=X_" "_^(Z) - . S MAGRY(XI)=X_"^"_MAGIEN - . Q - I $D(^TMP("DIERR",$J)) D FINDERR() Q - I $D(^TMP("DILIST",$J,0)) S INFO=^(0) D - . S MAGRY(0)=$P(INFO,"^")_U_"Found "_$P(INFO,"^")_" entr"_$S((+INFO=1):"y",1:"ies")_" matching """_$P(MAGIN,"^",3)_"""" - . I $P(INFO,"^",3)>0 S MAGRY(0)=MAGRY(0)_" there are more" - . Q - Q -FINDERR(XI) ; - ; - I '+$G(XI) S XI=$O(MAGRY(""),-1)+1 - S MAGRY(XI)="ERROR^"_^TMP("DIERR",$J,1,"TEXT",1) - Q +MAGGNLKP ;WOIFO/GEK - Lookup from delphi into any file ; [ 06/20/2001 08:56 ] + ;;3.0;IMAGING;**8,92**;Jan 10, 2007;Build 1 + ;; Per VHA Directive 2004-038, this routine should not be modified. + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q + ; +LKP(MAGRY,MAGIN,DATA) ;RPC [MAG3 LOOKUP ANY] + ; Generic lookup using FIND^DIC + ; MAGRY is the Array to return. + ; MAGIN is parameter sent by calling app (Delphi) + ; FILE NUM ^ NUM TO RETURN ^ TEXT TO MATCH ^ FIELDS ^ SCREEN ($P 5-99) + ; + ; DATA : + ; LVIEW =Piece 1 + ; +LVIEW = 1 : + ; result array is formatted for a magListView control + ; i.e. ^ delimiter for data and "|" delimiter for IEN + ; +LVIEW = 0 : + ; old way, " " delim for data and '^' delim for IEN + ; INDX = Piece 2 + ; This is the index to search + ; Defaults to "B" + ; + ; + N $ETRAP,$ESTACK S $ETRAP="D ERRA^MAGGTERR" + ; + N Y,XI,Z,FI,MAGIEN,INFO,LVIEW,INDX + N FILE,IENS,FLDS,FLAGS,VAL,NUM,INDEX,SCR,IDENT,TROOT + S (FILE,IENS,FLDS,FLAGS,VAL,NUM,INDEX,SCR,IDENT,TROOT)="" + S MAGIN=$G(MAGIN) + S DATA=$G(DATA) + ; + S FILE=+$P(MAGIN,U,1) + S NUM=$S(+$P(MAGIN,U,2):+$P(MAGIN,U,2),1:200) + S VAL=$P(MAGIN,U,3) + S FLDS=$P(MAGIN,U,4) + S SCR=$P(MAGIN,U,5,99) + ; + S LVIEW=+$P(DATA,"^",1) + S INDX=$S($L($P(DATA,"^",2)):$P(DATA,"^",2),1:"B") + ; + I 'FILE S MAGRY(1)="0^ERROR - Invalid Parameter: File Number ? " Q + I '$$VFILE^DILFD(FILE) S MAGRY(1)="0^ERROR - Invalid File # - "_FILE Q + ; Number of entries to return, If 0 we'll stop at 200 + ; + K ^TMP("DILIST",$J) + K ^TMP("DIERR",$J) + ; VAL is the initial value to search for. i.e. the user input. + ; Next line is to stop the FM Infinite Error Trap problem. + I $L(VAL)>30 S MAGRY(0)="0^Invalid Input: '"_$E(VAL,1,40)_"...' is too long. "_$L(VAL)_" characters." Q + D FIND^DIC(FILE,IENS,FLDS,FLAGS,VAL,NUM,INDEX,SCR,IDENT,TROOT) + ; + I '$D(^TMP("DILIST",$J,1)) S XI=1 D Q + . I $D(^TMP("DIERR",$J)) D FINDERR(XI) Q + . S MAGRY(XI)="0^NO MATCH for lookup on """_$P(MAGIN,"^",3)_"""" + ; so we have some matches, (BUT we could still have an error) + ; so first list all matches, then the ERROR + ; Next lines were Q&D but old .EXE's expect return string with + ; this syntax, when all T11 code is gone, this can be rewritten + I LVIEW S XI="" F S XI=$O(^TMP("DILIST",$J,1,XI)) Q:XI="" S X=^(XI) D + . S MAGIEN=^TMP("DILIST",$J,2,XI) + . S Z=".01",FLD="NAME" + . F S Z=$O(^TMP("DILIST",$J,"ID",XI,Z)) Q:Z="" S X=X_"^"_^(Z),FLD=FLD_"^"_$$GET1^DID(FILE,Z,"","LABEL","MAGFLD") + . S MAGRY(.05)=FLD + . S MAGRY(XI)=X_"^|"_MAGIEN + . Q + I 'LVIEW S XI="" F S XI=$O(^TMP("DILIST",$J,1,XI)) Q:XI="" S X=^(XI) D + . S MAGIEN=^TMP("DILIST",$J,2,XI) + . S Z="" + . F S Z=$O(^TMP("DILIST",$J,"ID",XI,Z)) Q:Z="" S X=X_" "_^(Z) + . S MAGRY(XI)=X_"^"_MAGIEN + . Q + I $D(^TMP("DIERR",$J)) D FINDERR() Q + I $D(^TMP("DILIST",$J,0)) S INFO=^(0) D + . S MAGRY(0)=$P(INFO,"^")_U_"Found "_$P(INFO,"^")_" entr"_$S((+INFO=1):"y",1:"ies")_" matching """_$P(MAGIN,"^",3)_"""" + . I $P(INFO,"^",3)>0 S MAGRY(0)=MAGRY(0)_" there are more" + . Q + Q +FINDERR(XI) ; + ; + I '+$G(XI) S XI=$O(MAGRY(""),-1)+1 + S MAGRY(XI)="ERROR^"_^TMP("DIERR",$J,1,"TEXT",1) + Q diff --git a/r/IMAGING-MAG-ZMAG/MAGGNTI.m b/r/IMAGING-MAG-ZMAG/MAGGNTI.m index 6194440e..b955e14f 100644 --- a/r/IMAGING-MAG-ZMAG/MAGGNTI.m +++ b/r/IMAGING-MAG-ZMAG/MAGGNTI.m @@ -1,160 +1,121 @@ -MAGGNTI ;WOIFO/GEK - Imaging interface to TIU RPC Calls etc. ; 04 Apr 2002 2:37 PM - ;;3.0;IMAGING;**10,8,59**;Nov 27, 2007;Build 20 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q -FILE(MAGRY,MAGDA,TIUDA) ;RPC [MAG3 TIU IMAGE] - ; Call to file TIU and Imaging Pointers - ; TIU API to add image to TIU - N X - I $P(^TIU(8925,TIUDA,0),U,2)'=$P(^MAG(2005,MAGDA,0),U,7) S MAGRY="0^Patient Mismatch." Q - D PUTIMAGE^TIUSRVPL(.MAGRY,TIUDA,MAGDA) ; - I 'MAGRY Q - ; Now SET the Parent fields in the Image File - S $P(^MAG(2005,MAGDA,2),U,6,8)=8925_U_TIUDA_U_+MAGRY - ; DONE. - S MAGRY="1^Image pointer filed successfully" - ; Now we save the PARENT ASSOCIATION Date/Time - D LINKDT^MAGGTU6(.X,MAGDA) - Q -DATA(MAGRY,TIUDA) ;RPC [MAG3 TIU DATA FROM DA] - ; Call to get TIU data from the TIUDA - ; Return = TIUDA^Document Type ^Document Date^DFN^Author DUZ - ; - S MAGRY=TIUDA_U_$$GET1^DIQ(8925,TIUDA,".01","E")_U_$$GET1^DIQ(8925,TIUDA,"1201","I")_U_$$GET1^DIQ(8925,TIUDA,".02","I")_U_$$GET1^DIQ(8925,TIUDA,"1202","I")_U - Q -IMAGES(MAGRY,TIUDA) ;RPC [MAG3 CPRS TIU NOTE] - ; Call to get all images for a given TIU DA - ; We first get all Image IEN's breaking groups into separate images - ; Then get Image Info for each one. - ; MAGRY - Return array of Image Data entries - ; MAGRY(0) is 1 ^ message if successful - ; 0 ^ Error message if error; - ; TIUDA is IEN in ^TIU(8925 - ; - ; Call TIU API to get list of Image IEN's - N MAGARR,CT,TCT,I,J,Z K ^TMP($J,"MAGGX") - N DA,MAGQI,MAGNCHK,MAGXX,MAGRSLT - N TIUDFN,MAGQUIT ; MAGQI 8/22/01 - ; MAGFILE is returned from MAGGTII - ; - S MAGQUIT=0 ; MAGQI 8/22/01 - S TIUDFN=$P($G(^TIU(8925,TIUDA,0)),U,2) ;MAGQI 8/22/01 - I 'TIUDFN S MAGRY(0)="0^Invalid Patient DFN for Note ID: '"_TIUDA_"'" - D GETILST^TIUSRVPL(.MAGARR,TIUDA) - S CT=0,TCT=0 - ; Now get all images for all groups and single images. - S I="" F S I=$O(MAGARR(I)) Q:'I S DA=MAGARR(I) D ;Q:MAGQUIT - . S Z=$$ISDELIMG(DA) I Z S TCT=TCT+1,MAGRY(TCT)="B2^"_Z Q - . ; Check that array of images from selected TIUDA have - . ; same patient's and valid backward pointers - . I $P($G(^MAG(2005,DA,0)),U,7)'=TIUDFN S MAGQUIT=1,MAGNCHK="Patient Mismatch. TIU: "_TIUDA - . I $P($G(^MAG(2005,DA,2)),U,7)'=TIUDA S MAGQUIT=1,MAGNCHK="Pointer Mismatch. TIU: "_TIUDA - . I MAGQUIT S MAGXX=DA D INFO^MAGGTII D Q - . . ; remove the Abstract and Image File Names ; 2/14/03 p8t14 remove c:\program files. with .\bmp\ - . . S $P(MAGFILE,U,2,3)="-1~Questionable Data Integrity^.\bmp\imageQA.bmp" - . . ;this stops Delphi App from changing Abstract BMP to OFFLINE IMAGE - . . S $P(MAGFILE,U,6)=$S(($P(MAGFILE,U,6)'=11):"99",1:11) - . . S $P(MAGFILE,U,10)="M" - . . ;Send the error message - . . S $P(MAGFILE,U,17)=MAGNCHK - . . S TCT=TCT+1,MAGRY(TCT)="B2^"_MAGFILE - . ; - . I $O(^MAG(2005,DA,1,0)) D Q - . . ; Integrity check, if group is questionable, add it's ien to list, not it's - . . ; children. Later when list is looped through, it's INFO^MAGGTII will be in - . . ; list. Have to do this to allow other images in list from TIU to be processed. - . . D CHK^MAGGSQI(.MAGQI,DA) I 'MAGQI(0) S CT=CT+1,^TMP($J,"MAGGX",CT)=DA Q - . . S J=0 ; the following line needs to take only the first piece of the node - PMK 4/4/02 - . . F S J=$O(^MAG(2005,DA,1,J)) Q:'J S CT=CT+1,^TMP($J,"MAGGX",CT)=$P(^(J,0),"^") - . S CT=CT+1 - . S ^TMP($J,"MAGGX",CT)=DA - ; Now get image info for each image - ; - S Z="" - S MAGQUIET=1 - F S Z=$O(^TMP($J,"MAGGX",Z)) Q:Z="" D - . S TCT=TCT+1,MAGXX=^TMP($J,"MAGGX",Z) - . ;GEK 8/24/00 Stopping the Invalid Image IEN's and Deleted Images - . I '$D(^MAG(2005,MAGXX)) D Q - . . D INVALID^MAGGTIG(MAGXX,.MAGRSLT) S MAGRY(CT)=MAGRSLT - . D INFO^MAGGTII - . S MAGRY(TCT)="B2^"_MAGFILE - K MAGQUIET - S MAGRY(0)=TCT_"^"_TCT_" Images for the selected TIU NOTE" - ; Put the Image IEN of the last image into the group IEN field. - Q:'TCT - S $P(MAGRY(0),U,3)=TIUDA - K MAGRSLT - D DATA(.MAGRSLT,TIUDA) - S $P(MAGRY(0),U,4)=$$GET1^DIQ(8925,TIUDA,".02","E")_" "_$P(MAGRSLT,U,2)_" "_$$FMTE^XLFDT($P(MAGRSLT,U,3),"8") - ; - S $P(MAGRY(0),U,5)=$S($P($G(MAGFILE),U):$P(MAGFILE,U),$G(MAGXX):MAGXX,1:0) - Q - ;. S Z=ISDELIMG(DA) I Z S TCT=TCT+1,MAGRY(TCT)="B2^"_$P(Z,U,2) Q -ISDELIMG(MAGIEN) ; Is this a deleted Image. - N MAGDEL,MAGIMG,MAGR,Z,MAGT - S MAGDEL=$D(^MAG(2005.1,MAGIEN)) - S MAGIMG=$D(^MAG(2005,MAGIEN)) - I MAGIMG,'MAGDEL S MAGR="0^Valid Image" - I 'MAGIMG,MAGDEL S MAGR="1^Deleted Image",MAGT=66 - I 'MAGIMG,'MAGDEL S MAGR="1^Invalid Image pointer",MAGT=67 - I MAGIMG,MAGDEL S MAGR="0^Image IEN exists, and is Deleted !" - I 'MAGR Q MAGR - S MAGR=$P(MAGR,U,2) - S $P(Z,U,1,4)=MAGIEN_"^-1~"_MAGR_"^-1~"_MAGR_"^"_MAGR - S $P(Z,U,6)=MAGT - ;this stops Delphi App from changing Abstract BMP to OFFLINE IMAGE - S $P(Z,U,10)="M" - ;Send the error message - S $P(Z,U,17)=$P(MAGR,U,2) - Q Z -ISDOCCL(MAGRY,IEN,TIUFILE,CLASS) ;RPC [MAGG IS DOC CLASS] - ;Checks to see if IEN of TIU Files 8925 or 8925.1 is of a certain Doc Class - ;MAGRY = Return String - ; for Success "1^message" - ; for Failure "0^message" - ;IEN = Internal Entry Number in the TIUFILE - ;TIUFILE = either 8925 if we need to see if a Note is of a Document Class - ; or 8925.1 if we need to see if a Title is of a Document Class - ;CLASS = Text Name of the Document Class example: "ADVANCE DIRECTIVE" - ; - S MAGRY="0^Unknown Error checking TIU Document Class" - K MAGTRGT,DEFIEN,DOCCL,RES,DONE,NTTL - S DONE=0 - ; If we're resolving a Title - I TIUFILE="8925.1" D Q:DONE - . S DEFIEN=IEN,NTTL="Title" - . I '$D(^TIU(8925.1,DEFIEN,0)) S MAGRY="0^Invalid Title IEN",DONE=1 Q - . Q - ; If we're resolving a Note - I TIUFILE="8925" D Q:DONE - . S NTTL="Note" - . I '$D(^TIU(8925,IEN)) S MAGRY="0^Invalid Note IEN",DONE=1 Q - . ; Get Title IEN from Note IEN - . S DEFIEN=$$GET1^DIQ(8925,IEN_",",.01,"I") - . I DEFIEN="" S MAGRY="0^Error resolving Document Class from Note IEN" S DONE=1 Q - . Q - ; - ; Find the IEN in 8925.1 for Document Class (CLASS) - D FIND^DIC(8925.1,"","@;.001","X",CLASS,"","","I $P(^(0),U,4)=""DC""","","MAGTRGT") - S DOCCL=$G(MAGTRGT("DILIST",2,1)) - ; - ; See if ^TIU(8925.1,DEFIEN is of Document Class DOCCL - S RES=$$ISA^TIULX(DEFIEN,DOCCL) - I RES S MAGRY="1^The "_NTTL_" is of Document Class "_CLASS Q - S MAGRY="0^The "_NTTL_" is Not of Document Class "_CLASS - Q +MAGGNTI ;WOIFO/GEK - Imaging interface to TIU RPC Calls etc. ; 04 Apr 2002 2:37 PM + ;;3.0;IMAGING;**10,8**;Sep 15, 2004 + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q +FILE(MAGRY,MAGDA,TIUDA) ;RPC [MAG3 TIU IMAGE] + ; Call to file TIU and Imaging Pointers + ; TIU API to add image to TIU + I $P(^TIU(8925,TIUDA,0),U,2)'=$P(^MAG(2005,MAGDA,0),U,7) S MAGRY="0^Patient Mismatch." Q + D PUTIMAGE^TIUSRVPL(.MAGRY,TIUDA,MAGDA) ; + I 'MAGRY Q + ; Now SET the Parent fields in the Image File + S $P(^MAG(2005,MAGDA,2),U,6,8)=8925_U_TIUDA_U_+MAGRY + ; DONE. + S MAGRY="1^Image pointer filed successfully" + Q +DATA(MAGRY,TIUDA) ;RPC [MAG3 TIU DATA FROM DA] + ; Call to get TIU data from the TIUDA + ; Return = TIUDA^Document Type ^Document Date^DFN + ; + S MAGRY=TIUDA_U_$$GET1^DIQ(8925,TIUDA,".01","E")_U_$$GET1^DIQ(8925,TIUDA,"1201","I")_U_$$GET1^DIQ(8925,TIUDA,".02","I") + Q +IMAGES(MAGRY,TIUDA) ;RPC [MAG3 CPRS TIU NOTE] + ; Call to get all images for a given TIU DA + ; We first get all Image IEN's breaking groups into seperate images + ; Then get Image Info for each one. + ; MAGRY - Return array of Image Data entries + ; MAGRY(0) is 1 ^ message if successful + ; 0 ^ Error message if error; + ; TIUDA is IEN in ^TIU(8925 + ; + ; Call TIU API to get list of Image IEN's + N MAGARR,CT,TCT K ^TMP("MAGGX",$J) + N DA,MAGQI,MAGNCHK,MAGXX,MAGRSLT + N TIUDFN,MAGQUIT ; MAGQI 8/22/01 + ; MAGFILE is returned from MAGGTII + ; + S MAGQUIT=0 ; MAGQI 8/22/01 + S TIUDFN=$P($G(^TIU(8925,TIUDA,0)),U,2) ;MAGQI 8/22/01 + I 'TIUDFN S MAGRY(0)="0^Invalid Patient DFN for Note ID: '"_TIUDA_"'" + D GETILST^TIUSRVPL(.MAGARR,TIUDA) + S CT=0,TCT=0 + ; Now get all images for all groups and single images. + S I="" F S I=$O(MAGARR(I)) Q:'I S DA=MAGARR(I) D ;Q:MAGQUIT + . S Z=$$ISDELIMG(DA) I Z S TCT=TCT+1,MAGRY(TCT)="B2^"_Z Q + . ; Check that array of images from selected TIUDA have + . ; same patient's and valid backward pointers + . I $P($G(^MAG(2005,DA,0)),U,7)'=TIUDFN S MAGQUIT=1,MAGNCHK="Patient Mismatch. TIU: "_TIUDA + . I $P($G(^MAG(2005,DA,2)),U,7)'=TIUDA S MAGQUIT=1,MAGNCHK="Pointer Mismatch. TIU: "_TIUDA + . I MAGQUIT S MAGXX=DA D INFO^MAGGTII D Q + . . ; remove the Abstract and Image File Names ; 2/14/03 p8t14 remove c:\program files. with .\bmp\ + . . S $P(MAGFILE,U,2,3)="-1~Questionable Data Integrity^.\bmp\imageQA.bmp" + . . ;this stops Delphi App from changing Abstract BMP to OFFLINE IMAGE + . . S $P(MAGFILE,U,6)=$S(($P(MAGFILE,U,6)'=11):"99",1:11) + . . S $P(MAGFILE,U,10)="M" + . . ;Send the error message + . . S $P(MAGFILE,U,17)=MAGNCHK + . . S TCT=TCT+1,MAGRY(TCT)="B2^"_MAGFILE + . ; + . I $O(^MAG(2005,DA,1,0)) D Q + . . ; Integrity check, if group is questionable, add it's ien to list, not it's + . . ; children. Later when list is looped through, it's INFO^MAGGTII will be in + . . ; list. Have to do this to allow other images in list from TIU to be processed. + . . D CHK^MAGGSQI(.MAGQI,DA) I 'MAGQI(0) S CT=CT+1,^TMP("MAGGX",$J,CT)=DA Q + . . S J=0 ; the following line needs to take only the first piece of the node - PMK 4/4/02 + . . F S J=$O(^MAG(2005,DA,1,J)) Q:'J S CT=CT+1,^TMP("MAGGX",$J,CT)=$P(^(J,0),"^") + . S CT=CT+1 + . S ^TMP("MAGGX",$J,CT)=DA + ; Now get image info for each image + ; + S Z="" + S MAGQUIET=1 + F S Z=$O(^TMP("MAGGX",$J,Z)) Q:Z="" D + . S TCT=TCT+1,MAGXX=^TMP("MAGGX",$J,Z) + . ;GEK 8/24/00 Stoping the Invalid Image IEN's and Deleted Images + . I '$D(^MAG(2005,MAGXX)) D Q + . . D INVALID^MAGGTIG(MAGXX,.MAGRSLT) S MAGRY(CT)=MAGRSLT + . D INFO^MAGGTII + . S MAGRY(TCT)="B2^"_MAGFILE + K MAGQUIET + S MAGRY(0)=TCT_"^"_TCT_" Images for the selected TIU NOTE" + ; PUT THE Image IEN of the last image into the group ien field. + Q:'TCT + S $P(MAGRY(0),U,3)=TIUDA + K MAGRSLT + D DATA(.MAGRSLT,TIUDA) + S $P(MAGRY(0),U,4)=$$GET1^DIQ(8925,TIUDA,".02","E")_" "_$P(MAGRSLT,U,2)_" "_$$FMTE^XLFDT($P(MAGRSLT,U,3),"8") + ; + S $P(MAGRY(0),U,5)=$S($P($G(MAGFILE),U):$P(MAGFILE,U),1:MAGXX) + Q + ;. S Z=ISDELIMG(DA) I Z S TCT=TCT+1,MAGRY(TCT)="B2^"_$P(Z,U,2) Q +ISDELIMG(MAGIEN) ; Is this a deleted Image. + N MAGDEL,MAGIMG,MAGR,Z,MAGT + S MAGDEL=$D(^MAG(2005.1,MAGIEN)) + S MAGIMG=$D(^MAG(2005,MAGIEN)) + I MAGIMG,'MAGDEL S MAGR="0^Valid Image" + I 'MAGIMG,MAGDEL S MAGR="1^Deleted Image",MAGT=66 + I 'MAGIMG,'MAGDEL S MAGR="1^Invalid Image pointer",MAGT=67 + I MAGIMG,MAGDEL S MAGR="0^Image IEN exists, and is Deleted !" + I 'MAGR Q MAGR + S MAGR=$P(MAGR,U,2) + S $P(Z,U,1,4)=MAGIEN_"^-1~"_MAGR_"^-1~"_MAGR_"^"_MAGR + S $P(Z,U,6)=MAGT + ;this stops Delphi App from changing Abstract BMP to OFFLINE IMAGE + S $P(Z,U,10)="M" + ;Send the error message + S $P(Z,U,17)=$P(MAGR,U,2) + Q Z diff --git a/r/IMAGING-MAG-ZMAG/MAGGNTI1.m b/r/IMAGING-MAG-ZMAG/MAGGNTI1.m index 36469458..fc1bd34a 100644 --- a/r/IMAGING-MAG-ZMAG/MAGGNTI1.m +++ b/r/IMAGING-MAG-ZMAG/MAGGNTI1.m @@ -1,205 +1,198 @@ -MAGGNTI1 ;WOIFO/GEK - Imaging interface to TIU. RPC Calls etc. ; 04 Apr 2002 2:37 PM - ;;3.0;IMAGING;**46,59**;Nov 27, 2007;Build 20 - ;; Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q -NEW(MAGRY,MAGDFN,MAGTITLE,MAGADCL,MAGMODE,MAGES,MAGESBY,MAGLOC,MAGDATE,MAGCNSLT,MAGTEXT) ;RPC [MAG3 TIU NEW] - ; - ; RPC call to create a New Note - ; and Optionally : - ; Electronically Sign, - ; Administratively Close - ; or Add Text to the Note. - ; - ; - - - Required - - - - ; MAGDFN - Patient DFN - ; MAGTITLE - IEN of TIU Document Title in file 8925.1 - ; - - - Optional - - - - ; Use DUZ for TIUAUTH - ; Use NOW for TIURDT - ; MAGTEXT - Array of Text to add to the New Note. - ; MAGLOC - IEN in Hospital Location File 44 - ; MAGES - The encrypted Electronic Signature - ; MAGESBY - The DUZ of the Signer (Defaults to DUZ) - ; MAGADCL - 1 = Mark this Note as Administratively Closed - ; MAGMODE - Mode of Admin Closure: "S" = Scanned Document - ; "M" = Manual closure, "E" = Electronically Filed - ; MAGDATE - Date of the Note. For New Notes. - ; MAGCNSLT - DA of Consult to Link to. - ; - N $ETRAP,$ESTACK S $ETRAP="D ERR^"_$T(+0) - S MAGDFN=$G(MAGDFN),MAGTITLE=$G(MAGTITLE),MAGLOC=$G(MAGLOC) - S MAGES=$G(MAGES),MAGADCL=$G(MAGADCL) - S MAGESBY=$S($G(MAGESBY):MAGESBY,1:DUZ) - S MAGMODE=$S($L($G(MAGMODE)):MAGMODE,1:"S") - S MAGDATE=$G(MAGDATE),MAGCNSLT=$G(MAGCNSLT) - N MAGTIUDA,I,NODE,MAGTY,ISVAL,MAGISC,MTXT,MUPD,MAGX,MAGVSTR,MAGTIUX - ; - ; MAGMODE is only sent if Admin Closure is wanted. - I (MAGMODE="S") S MAGTEXT(.1)=" VistA Imaging - Scanned Document" - I (MAGMODE="M") S MAGTEXT(.1)=" VistA Imaging - Manual Closure" - I "MSE"'[MAGMODE S MAGRY="0^Invalid Mode of Closure: """_MAGMODE_"""" Q - ; - ; Here if we have no Text, we'll add at least a line. - I $O(MAGTEXT(""))="" S MAGTEXT(.1)=" VistA Imaging - - Scanned Document" - ; Reformat Text - "TEXT",i,0)" for TIU Call. - S I="",NODE=0 - F S I=$O(MAGTEXT(I)) Q:I="" D - . S NODE=NODE+1 S MAGTIUX("TEXT",NODE,0)=MAGTEXT(I) - . Q - ; validate the DFN - I '$D(^DPT(+MAGDFN,0)) S MAGRY="0^Invalid data: Patient DFN is invalid" Q - ; validate the User - I '$D(^VA(200,MAGESBY,0)) S MAGRY="0^Invalid data: Author DUZ is invalid" Q - ; validate the TIU TITLE - I '$D(^TIU(8925.1,MAGTITLE,0)) S MAGRY="0^Invalid data: Note TITLE is invalid" Q - ; validate Esig first, if caller wants to also mark this Note as Signed - I +$G(MAGES) I '$$VALES^MAGGNTI2(MAGES) S MAGRY="0^Invalid data: E-sign is invalid" Q - ; validate the Date MAGDATE is changed to INternal if it is valid. - I +$L(MAGDATE) I '$$VALID^MAGGSIV1(8925,1301,.MAGDATE,.MAGX) S MAGRY="0^"_MAGX Q - I '$L(MAGDATE) S MAGDATE=$$NOW^XLFDT - ; LINK TO CONSULT - ; can user create Notes with This Title - I '$$CANENTR^TIULP(MAGTITLE) S MAGRY="0^You need privileges to enter notes of that Title" Q - ; - D ISCNSLT^TIUCNSLT(.MAGISC,MAGTITLE) - I MAGISC D I 'MAGISC S MAGRY=MAGISC Q - . ; See if a Consult DA was sent. - . IF 'MAGCNSLT S MAGISC="0^A Consult is needed to link to this note title" - . Q - I ('MAGISC)&(MAGCNSLT) S MAGRY="0^Cannot Link Consult with a Non Consult Title" Q - ; - ; make a VSTR for TIU Call. - S MAGVSTR=MAGLOC_";"_MAGDATE_";E" - ; - ; Call to NEW^TIUPNAPI wasn't doing what we needed. Now call TIU CREATE RECORD - ; MAKE(SUCCESS,DFN,TITLE,VDT,VLOC,VSIT,TIUX,VSTR,SUPPRESS,NOASF) - D MAKE^TIUSRVP(.MAGTIUDA,MAGDFN,MAGTITLE,"",MAGLOC,"",.MAGTIUX,MAGVSTR) - I 'MAGTIUDA!(MAGTIUDA=-1) S MAGRY="0^Error creating Note"_$G(MAGTIUDA) Q - S MAGRY=MAGTIUDA_"^Note was created." - S MAGTY=MAGRY - ; - ; ;Put in the Date that was sent. - I '$$VALID^MAGGSIV1(8925,1301,.MAGDATE,.MAGRES) S MAGRY=MAGRY_" "_MAGRES - E S MTXT(1301)=MAGDATE - ; - Fix in T30, if DUZ isn't MAGESBY, we have Author different than User. - I MAGESBY'=DUZ S MTXT("1202")=MAGESBY - ; Update and LINK TO CONSULT if needed. - I MAGISC S MTXT("1405")=MAGCNSLT_";GMR(123," - I $D(MTXT) D I 'MUPD S MAGRY=MUPD Q - . D UPDATE^TIUSRVP(.MUPD,MAGTIUDA,.MTXT) - . Q - ; - ; If Admin Close, then We quit. - I MAGADCL="1" D Q - . D ADMNCLOS^MAGGNTI2(.MAGTY,MAGDFN,MAGTIUDA,MAGMODE) - . S MAGRY=$S('MAGTY:MAGTY,1:MAGRY_" Administrative Closure.") - . Q - ; - ; if caller sent esignature to Sign this Note. - I $L(MAGES) D - . D SIGN^MAGGNTI3(.MAGTY,MAGDFN,MAGTIUDA,MAGES,MAGESBY) - . S MAGRY=$S('MAGTY:MAGTY,1:MAGRY_" Signed.") - . Q - Q - ; - ;(MAGRY,MAGDFN,MAGTITLE,MAGADCL,MAGMODE,MAGES,MAGESBY,MAGLOC,MAGTEXT) -NEWADD(MAGRY,MAGDFN,MAGTIUDA,MAGADCL,MAGMODE,MAGES,MAGESBY,MAGDATE,MAGTEXT) ; RPC [MAG3 TIU CREATE ADDENDUM] - ; RPC call to create an Addendum to a Note - ; and Optionally : - ; Electronically Sign, - ; Administratively Close, - ; or Add Text to the Addendum - ; - ; - - - Required - - - - ; MAGDFN - Patient DFN - ; MAGTIUDA - IEN of TIU NOTE in file 8925 - ; - - - Optional - - - - ; MAGTEXT - Array of Text to add to the New Note. - ; MAGES - The encrypted Electronic Signature - ; MAGESBY - The DUZ of the Signer (Defaults to DUZ) - ; MAGADCL - 1 = Mark this Note as Administratively Closed - ; MAGMODE - Mode of Admin Closure: "S" = Scanned Document "M" = Manual closure "E" = Electronically Filed - ; MAGDATE - Date of the Addendum. - ; - N $ETRAP,$ESTACK S $ETRAP="D ERR^"_$T(+0) - S MAGDFN=$G(MAGDFN),MAGTIUDA=$G(MAGTIUDA),MAGES=$G(MAGES),MAGADCL=$G(MAGADCL) - S MAGESBY=$S($G(MAGESBY):MAGESBY,1:DUZ),MAGMODE=$S($L($G(MAGMODE)):MAGMODE,1:"S") - S MAGDATE=$G(MAGDATE) - ; - I '$$VALDATA^MAGGNTI2(.MAGRY,MAGDFN,MAGTIUDA) Q - N MAGXT,I,CT,NEWTIUDA,MAGY,MAGRES,MAGUPD - S CT=1,I="" - S MAGXT("TEXT",1,0)="VistA Imaging Scanned Document - Addendum." - I $D(MAGTEXT) F S I=$O(MAGTEXT(I)) Q:I="" D - . S CT=CT+1,MAGXT("TEXT",CT,0)=MAGTEXT(I) - . Q - ; - ; Calling TIU CREATE ADDENDUM RECORD - D MAKEADD^TIUSRVP(.MAGRY,MAGTIUDA,.MAGXT) - ; MAGRY could be 0^error message - ; -1^message - ; TIUDA - I $P(MAGRY,"^")<0 S $P(MAGRY,"^")=0 Q - S NEWTIUDA=+MAGRY - S MAGRY=MAGRY_"^Addendum was created." - ; - ;Put in the Date that was sent. - K MAGUPD - I '$$VALID^MAGGSIV1(8925,1301,.MAGDATE,.MAGRES) S MAGRY=MAGRY_" "_MAGRES - E D - . S MAGUPD(1301)=MAGDATE - . S MAGUPD(1211)=$$GET1^DIQ(8925,1211,MAGTIUDA,"I") - ; - Fix in T30, if DUZ isn't MAGESBY, we have Author different than User. - I MAGESBY'=DUZ S MAGUPD("1202")=MAGESBY - I $D(MAGUPD) D - . D UPDATE^TIUSRVP(.MAGY,NEWTIUDA,.MAGUPD) - . I 'MAGY S MAGRY=MAGRY_" TIU Data was Not Correctly Filed." - . Q - ; - ; if caller sent esignature to Sign this Addendum. - I $L(MAGES) D Q - . D SIGN^MAGGNTI3(.MAGTY,MAGDFN,NEWTIUDA,MAGES,MAGESBY) - . S MAGRY=$S('MAGTY:MAGTY,1:MAGRY_" Signed.") - . Q - ; - ; if caller wants to Admin Close this Addendum. - I MAGADCL="1" D Q - . D ADMNCLOS^MAGGNTI2(.MAGTY,MAGDFN,NEWTIUDA,MAGMODE) - . S MAGRY=$S('MAGTY:MAGTY,1:MAGRY_" Administrative Closure.") - . Q - Q -MOD(MAGRY,MAGDFN,MAGTIUDA,MAGADCL,MAGMODE,MAGES,MAGESBY,MAGTEXT) ; RPC [MAG3 TIU MODIFY NOTE] - ; After a Note is filed, we call this to Modify the Note. We do this to sign it. - ; That way the Signed Date is After the Image Association Date/Time. - N $ETRAP,$ESTACK S $ETRAP="D ERR^"_$T(+0) - S MAGDFN=$G(MAGDFN),MAGTIUDA=$G(MAGTIUDA) - S MAGADCL=$G(MAGADCL) - S MAGMODE=$S($L($G(MAGMODE)):MAGMODE,1:"S") - S MAGES=$G(MAGES) - S MAGESBY=$S($G(MAGESBY):MAGESBY,1:DUZ) - D MOD^MAGGNTI3(.MAGRY,MAGDFN,MAGTIUDA,MAGADCL,MAGMODE,MAGES,MAGESBY) - Q -ERR ; ERROR TRAP - N ERR S ERR=$$EC^%ZOSV - S MAGRY="0^ETRAP: "_ERR - D @^%ZOSF("ERRTN") - Q -SIGN(MAGRY,MAGDFN,MAGTIUDA,MAGES,MAGESBY) ;RPC [MAG3 TIU SIGN RECORD] - ; RPC Call to 'Sign' a Note. - D SIGN^MAGGNTI3(.MAGRY,$G(MAGDFN),$G(MAGTIUDA),$G(MAGES),$G(MAGESBY)) - Q +MAGGNTI1 ;WOIFO/GEK - Imaging interface to TIU RPC Calls etc. ; 20 Nov 2006 12:42 PM + ;;3.0;IMAGING;**46**;16-February-2007;;Build 1023 + ;; Per VHA Directive 2004-038, this routine should not be modified. + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q +NEW(MAGRY,MAGDFN,MAGTITLE,MAGADCL,MAGMODE,MAGES,MAGESBY,MAGLOC,MAGDATE,MAGCNSLT,MAGTEXT) ;RPC [MAG3 TIU NEW] + ; + ; RPC call to create a New Note + ; and Optionally : + ; Electronically Sign, + ; Administratively Close + ; or Add Text to the Note. + ; + ; - - - Required - - - + ; MAGDFN - Patient DFN + ; MAGTITLE - IEN of TIU Document Title in file 8925.1 + ; - - - Optional - - - + ; Use DUZ for TIUAUTH + ; Use NOW for TIURDT + ; MAGTEXT - Array of Text to add to the New Note. + ; MAGLOC - IEN in Hospital Location File 44 + ; MAGES - The encrypted Electronic Signature + ; MAGESBY - The DUZ of the Signer (Defaults to DUZ) + ; MAGADCL - 1 = Mark this Note as Administratively Closed + ; MAGMODE - Mode of Admin Closure: "S" = Scanned Document + ; "M" = Manual closure, "E" = Electronically Filed + ; MAGDATE - Date of the Note. For New Notes. + ; MAGCNSLT - DA of Consult to Link to. + ; + N $ETRAP,$ESTACK S $ETRAP="D ERR^"_$T(+0) + S MAGDFN=$G(MAGDFN),MAGTITLE=$G(MAGTITLE),MAGLOC=$G(MAGLOC) + S MAGES=$G(MAGES),MAGADCL=$G(MAGADCL) + S MAGESBY=$S($G(MAGESBY):MAGESBY,1:DUZ) + S MAGMODE=$S($L($G(MAGMODE)):MAGMODE,1:"S") + S MAGDATE=$G(MAGDATE),MAGCNSLT=$G(MAGCNSLT) + N MAGTIUDA,I,NODE,MAGTY,ISVAL,MAGISC,MTXT,MUPD,MAGX,MAGVSTR,MAGTIUX + ; + ; MAGMODE is only sent if Admin Closure is wanted. + I (MAGMODE="S") S MAGTEXT(.1)=" VistA Imaging - Scanned Document" + I (MAGMODE="M") S MAGTEXT(.1)=" VistA Imaging - Manual Closure" + I "MSE"'[MAGMODE S MAGRY="0^Invalid Mode of Closure: """_MAGMODE_"""" Q + ; + ; Here if we have no Text, we'll add at least a line. + I $O(MAGTEXT(""))="" S MAGTEXT(.1)=" VistA Imaging - - Scanned Document" + ; Reformat Text - "TEXT",i,0)" for TIU Call. + S I="",NODE=0 + F S I=$O(MAGTEXT(I)) Q:I="" D + . S NODE=NODE+1 S MAGTIUX("TEXT",NODE,0)=MAGTEXT(I) + . Q + ; validate the DFN + I '$D(^DPT(+MAGDFN,0)) S MAGRY="0^Invalid data: Patient DFN is invalid" Q + ; validate the User + I '$D(^VA(200,MAGESBY,0)) S MAGRY="0^Invalid data: Author DUZ is invalid" Q + ; validate the TIU TITLE + I '$D(^TIU(8925.1,MAGTITLE,0)) S MAGRY="0^Invalid data: Note TITLE is invalid" Q + ; validate Esig first, if caller wants to also mark this Note as Signed + I +$G(MAGES) I '$$VALES^MAGGNTI2(MAGES) S MAGRY="0^Invalid data: E-sign is invalid" Q + ; validate the Date MAGDATE is changed to INternal if it is valid. + I +$L(MAGDATE) I '$$VALID^MAGGSIV1(8925,1301,.MAGDATE,.MAGX) S MAGRY="0^"_MAGX Q + I '$L(MAGDATE) S MAGDATE=$$NOW^XLFDT + ; LINK TO CONSULT + ; can user create Notes with This Title + I '$$CANENTR^TIULP(MAGTITLE) S MAGRY="0^You need privileges to enter notes of that Title" Q + ; + D ISCNSLT^TIUCNSLT(.MAGISC,MAGTITLE) + I MAGISC D I 'MAGISC S MAGRY=MAGISC Q + . ; See if a Consult DA was sent. + . IF 'MAGCNSLT S MAGISC="0^A Consult is needed to link to this note title" + . Q + I ('MAGISC)&(MAGCNSLT) S MAGRY="0^Cannot Link Consult with a Non Consult Title" Q + ; + ; make a VSTR for TIU Call. + S MAGVSTR=MAGLOC_";"_MAGDATE_";E" + ; + ; Call to NEW^TIUPNAPI wasn't doing what we needed. Now call TIU CREATE RECORD + ; MAKE(SUCCESS,DFN,TITLE,VDT,VLOC,VSIT,TIUX,VSTR,SUPPRESS,NOASF) + D MAKE^TIUSRVP(.MAGTIUDA,MAGDFN,MAGTITLE,"",MAGLOC,"",.MAGTIUX,MAGVSTR) + I 'MAGTIUDA!(MAGTIUDA=-1) S MAGRY="0^Error creating Note"_$G(MAGTIUDA) Q + S MAGRY=MAGTIUDA_"^Note was created." + S MAGTY=MAGRY + ; + ; ;Put in the Date that was sent. + I '$$VALID^MAGGSIV1(8925,1301,.MAGDATE,.MAGRES) S MAGRY=MAGRY_" "_MAGRES + E S MTXT(1301)=MAGDATE + ; + ; Update and LINK TO CONSULT if needed. + I MAGISC S MTXT("1405")=MAGCNSLT_";GMR(123," + I $D(MTXT) D I 'MUPD S MAGRY=MUPD Q + . D UPDATE^TIUSRVP(.MUPD,MAGTIUDA,.MTXT) + . Q + ; + ; If Admin Close, then We quit. + I MAGADCL="1" D Q + . D ADMNCLOS^MAGGNTI2(.MAGTY,MAGDFN,MAGTIUDA,MAGMODE) + . S MAGRY=$S('MAGTY:MAGTY,1:MAGRY_" Administrative Closure.") + . Q + ; + ; if caller sent esignature to Sign this Note. + I $L(MAGES) D + . D SIGN^MAGGNTI3(.MAGTY,MAGDFN,MAGTIUDA,MAGES,MAGESBY) + . S MAGRY=$S('MAGTY:MAGTY,1:MAGRY_" Signed.") + . Q + Q + ; + ;(MAGRY,MAGDFN,MAGTITLE,MAGADCL,MAGMODE,MAGES,MAGESBY,MAGLOC,MAGTEXT) +NEWADD(MAGRY,MAGDFN,MAGTIUDA,MAGADCL,MAGMODE,MAGES,MAGESBY,MAGDATE,MAGTEXT) ; RPC [MAG3 TIU CREATE ADDENDUM] + ; RPC call to create an Addendum to a Note + ; and Optionally : + ; Electronically Sign, + ; Administratively Close, + ; or Add Text to the Addendum + ; + ; - - - Required - - - + ; MAGDFN - Patient DFN + ; MAGTIUDA - IEN of TIU NOTE in file 8925 + ; - - - Optional - - - + ; MAGTEXT - Array of Text to add to the New Note. + ; MAGES - The encrypted Electronic Signature + ; MAGESBY - The DUZ of the Signer (Defaults to DUZ) + ; MAGADCL - 1 = Mark this Note as Administratively Closed + ; MAGMODE - Mode of Admin Closure: "S" = Scanned Document "M" = Manual closure "E" = Electronically Filed + ; MAGDATE - Date of the Addendum. + ; + N $ETRAP,$ESTACK S $ETRAP="D ERR^"_$T(+0) + S MAGDFN=$G(MAGDFN),MAGTIUDA=$G(MAGTIUDA),MAGES=$G(MAGES),MAGADCL=$G(MAGADCL) + S MAGESBY=$S($G(MAGESBY):MAGESBY,1:DUZ),MAGMODE=$S($L($G(MAGMODE)):MAGMODE,1:"S") + S MAGDATE=$G(MAGDATE) + ; + I '$$VALDATA^MAGGNTI2(.MAGRY,MAGDFN,MAGTIUDA) Q + N MAGXT,I,CT,NEWTIUDA,MAGY,MAGRES + S CT=1,I="" + S MAGXT("TEXT",1,0)="VistA Imaging Scanned Document - Addendum." + I $D(MAGTEXT) F S I=$O(MAGTEXT(I)) Q:I="" D + . S CT=CT+1,MAGXT("TEXT",CT,0)=MAGTEXT(I) + . Q + ; + ; Calling TIU CREATE ADDENDUM RECORD + D MAKEADD^TIUSRVP(.MAGRY,MAGTIUDA,.MAGXT) + ; MAGRY could be 0^error message + ; -1^message + ; TIUDA + I $P(MAGRY,"^")<0 S $P(MAGRY,"^")=0 Q + S NEWTIUDA=+MAGRY + S MAGRY=MAGRY_"^Addendum was created." + ; + ;Put in the Date that was sent. + I '$$VALID^MAGGSIV1(8925,1301,.MAGDATE,.MAGRES) S MAGRY=MAGRY_" "_MAGRES + E D + . K X + . S X(1301)=MAGDATE + . S X(1211)=$$GET1^DIQ(8925,1211,MAGTIUDA,"I") + . D UPDATE^TIUSRVP(.MAGY,NEWTIUDA,.X) + . I 'MAGY S MAGRY=MAGRY_" TIU Data was Not Correctly Filed." + . Q + ; + ; if caller sent esignature to Sign this Addendum. + I $L(MAGES) D Q + . D SIGN^MAGGNTI3(.MAGTY,MAGDFN,NEWTIUDA,MAGES,MAGESBY) + . S MAGRY=$S('MAGTY:MAGTY,1:MAGRY_" Signed.") + . Q + ; + ; if caller wants to Admin Close this Addendum. + I MAGADCL="1" D Q + . D ADMNCLOS^MAGGNTI2(.MAGTY,MAGDFN,NEWTIUDA,MAGMODE) + . S MAGRY=$S('MAGTY:MAGTY,1:MAGRY_" Administrative Closure.") + . Q + Q +MOD(MAGRY,MAGDFN,MAGTIUDA,MAGADCL,MAGMODE,MAGES,MAGESBY,MAGTEXT) ; RPC [MAG3 TIU MODIFY NOTE] + N $ETRAP,$ESTACK S $ETRAP="D ERR^"_$T(+0) + S MAGDFN=$G(MAGDFN),MAGTIUDA=$G(MAGTIUDA) + S MAGADCL=$G(MAGADCL) + S MAGMODE=$S($L($G(MAGMODE)):MAGMODE,1:"S") + S MAGES=$G(MAGES) + S MAGESBY=$S($G(MAGESBY):MAGESBY,1:DUZ) + D MOD^MAGGNTI3(.MAGRY,MAGDFN,MAGTIUDA,MAGADCL,MAGMODE,MAGES,MAGESBY) + Q +ERR ; ERROR TRAP + N ERR S ERR=$$EC^%ZOSV + S MAGRY="0^ETRAP: "_ERR + D @^%ZOSF("ERRTN") + Q +SIGN(MAGRY,MAGDFN,MAGTIUDA,MAGES,MAGESBY) ;RPC [MAG3 TIU SIGN RECORD] + ; RPC Call to 'Sign' a Note. + D SIGN^MAGGNTI3(.MAGRY,$G(MAGDFN),$G(MAGTIUDA),$G(MAGES),$G(MAGESBY)) + Q diff --git a/r/IMAGING-MAG-ZMAG/MAGGNTI2.m b/r/IMAGING-MAG-ZMAG/MAGGNTI2.m index 570f9eb7..2037bea6 100644 --- a/r/IMAGING-MAG-ZMAG/MAGGNTI2.m +++ b/r/IMAGING-MAG-ZMAG/MAGGNTI2.m @@ -1,118 +1,118 @@ -MAGGNTI2 ;WOIFO/GEK - Imaging interface to TIU. RPC Calls etc. ; 04 Apr 2002 2:37 PM - ;;3.0;IMAGING;**46,59**;Nov 27, 2007;Build 20 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q -LIST(MAGRY,CLASS,MYLIST) ; RPC [MAG3 TIU LONG LIST OF TITLES] - ; Get a list of Document Titles - ; CLASS = ("," delimited string of one or More of) "NOTE,DS,CONS,CP,SUR," - ; CLASS IEN is any IEN of TIU 8925.1 that is a Class - ; "|" delimited string of Class| text | Direction - ; MYLIST = [1|""] optional - ; If MYLIST=1 then return - ; TIU PERSONAL TITLE LIST PERSLIST^TIUSRVD - ; - ; Note : sending CLASS IEN isn't used in p59. - ; - K MAGRY - ; was a Global, now leave it an Array, only getting 44 - N I,T,CL,CLN,CLNOTE,CLDS,CLCP,CLCONS,CLSUR,IL,J,TX,TXC,TX2,TX1,DFLT - N INTXT,UPDN,TARR - S MYLIST=$G(MYLIST) - S INTXT=$P(CLASS,"|",2) - S UPDN=$S(+$P(CLASS,"|",3):+$P(CLASS,"|",3),1:1) - S CLASS=$P(CLASS,"|",1) - I $L(CLASS)=0 S MAGRY(0)="0^Invalid Selection Class." Q - S CLNOTE=3 ; It is hard coded in TIU code. Note Class - S CLDS=244 ; It is hard coded in TIU code. Discharge Summary Class - D CPCLASS^TIUCP(.CLCP) - D CNSLCLAS^TIUSRVD(.CLCONS) - D SURGCLAS^TIUSRVD(.CLSUR) - S MAGRY(0)="0^Error: While accessing a list of Note Titles." - S MAGRY(1)="key word^TITLE^CLASS" - S I="" - F I=1:1:$L(CLASS,",") D - . S CL=$P(CLASS,",",I) - . S CLN=$S(+CL:+CL,CL="NOTE":3,CL="DS":CLDS,CL="CP":CLCP,CL="CONS":CLCONS,CL="SUR":CLSUR,1:-1) - . I MYLIST D Q - . . D MYLIST(CLN,.TARR) - . . I $O(TARR(""))'="" S MAGRY(0)="1^Personal List" - . . S J="" F S J=$O(TARR(J)) Q:J="" D - . . . S TX1=$P(TARR(J),"^",1) - . . . ; output has 'd' or 'i' as first character, we need to get rid of it. - . . . I $E(TX1)="d" S DFLT=$E(TX1,2,999),MAGRY(0)=DFLT_"^Personal list" - . . . S TX1=$E(TX1,2,999) - . . . S TX=$P(TARR(J),"^",2),TX2=$P(TX,"<",2) S:$L(TX2) TX=$P(TX,"<",1) S:$L(TX2) TX2="<"_TX2 - . . . S MAGRY($O(MAGRY(""),-1)+1)=TX_"^"_TX2_"^"_CL_"|"_TX1 - . . . Q - . . Q - . ; here add line as a break between Personal List and Start of Total List - . K TARR - . D BLDLIST(CLN,.TARR,INTXT,UPDN) - . S J="" F S J=$O(TARR(J)) Q:J="" D - . . S TX=$P(TARR(J),"^",2),TX2=$P(TX,"<",2) S:$L(TX2) TX=$P(TX,"<",1) S:$L(TX2) TX2="<"_TX2 - . . S TX1=$P(TARR(J),"^",1) - . . S MAGRY($O(MAGRY(""),-1)+1)=TX_"^"_TX2_"^"_CL_"|"_TX1 - . . Q - . Q - I '$D(MAGRY(2)) K MAGRY(1) S MAGRY(0)="0^0 Items match input: "_INTXT - E S MAGRY(0)="1^Success"_"^"_$G(DFLT)_"^" - Q - ; -MYLIST(CLN,TARR) ; - ; if not short list, default is listed twice, (This is how CPRS displays it) - K TARR - D PERSLIST^TIUSRVD(.TARR,DUZ,CLN) - Q -BLDLIST(CLN,TARR,STC,UPDN) ; - ; - S UPDN=$S(+$G(UPDN):+$G(UPDN),1:1) - K TARR - D LONGLIST^TIUSRVD(.TARR,CLN,STC,UPDN) - Q -ADMNCLOS(MAGRY,MAGDFN,MAGTIUDA,MAGMODE) ; calls TIU API to set as Admin Closed. - ; RPC Call to Administratively Close a TIU Note. - ; - - - Required - - - - ; MAGDFN - Patient DFN - ; MAGTIUDA - Note IEN in File 8925 - ; - - - Optional - - - - ; MAGMODE - "S" Scanned Document "M" - Manual closure "E" - Electronically Filed. - ; - S MAGDFN=$G(MAGDFN),MAGTIUDA=$G(MAGTIUDA),MAGMODE=$G(MAGMODE,"S") - I '$$VALDATA(.MAGRY,MAGDFN,MAGTIUDA) Q - ; Calling TIU SET ADMINISTRATIVE CLOSURE - ; MAGMODE can be "S" for SCANNED DOCUMENT <- HIMS may get this changed - ; to Electronically Filed. - ; or "M" for MANUAL CLOSURE or "E" for ELECTONICALL FILE - D ADMNCLOS^TIUSRVPT(.MAGRY,MAGTIUDA,MAGMODE) - ; on success MAGRY = MAGTIUDA - ; on error MAGRY = 0^ - I MAGRY S MAGRY=MAGRY_"^Success: Administrative Closure." - Q -VALES(X) ; Validate the esig - N MAGY S MAGY=0 - D HASH^XUSHSHP - I X]"",(X=$P($G(^VA(200,+DUZ,20)),U,4)) S MAGY=1 - Q MAGY -VALDATA(RY,MAGDFN,MAGTIUDA) ; Validate the TIUDA and the DFN - S MAGTIUDA=$G(MAGTIUDA),MAGDFN=$G(MAGDFN) - I 'MAGDFN S RY="0^Invalid data: Patient DFN invalid: "_MAGDFN Q 0 - I '$D(^DPT(+MAGDFN,0)) S RY="0^Invalid data: Patient DFN invalid: "_MAGDFN Q 0 - I 'MAGTIUDA S RY="0^Invalid Note IEN: "_MAGTIUDA Q 0 - I '$D(^TIU(8925,MAGTIUDA,0)) S RY="0^Invalid Note IEN: "_MAGTIUDA Q 0 - I $P(^TIU(8925,MAGTIUDA,0),"^",2)'=MAGDFN S RY="0^Invalid Patient DFN: "_MAGDFN_" for Note: "_MAGTIUDA Q 0 - S RY="1^Validated OK." - Q 1 +MAGGNTI2 ;WOIFO/GEK - Imaging interface to TIU RPC Calls etc. ; 20 Nov 2006 12:18 PM + ;;3.0;IMAGING;**46**;16-February-2007;;Build 1023 + ;; Per VHA Directive 2004-038, this routine should not be modified. + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q +LIST(MAGRY,CLASS,MYLIST) ; RPC [MAG3 TIU LONG LIST OF TITLES] + ; Get a list of Document Titles + ; CLASS = ("," delimited string of one or More of) "NOTE,DS,CONS,CP,SUR," + ; CLASS IEN is any IEN of TIU 8925.1 that is a Class + ; "|" delimited string of Class| text | Direction + ; MYLIST = [1|""] optional + ; If MYLIST=1 then return + ; TIU PERSONAL TITLE LIST PERSLIST^TIUSRVD + ; + ; Note : sending CLASS IEN isn't tested. + ; + K MAGRY + ; was a Global, now leave it an Array, only getting 44 + N I,T,CL,CLN,CLNOTE,CLDS,CLCP,CLCONS,CLSUR,IL,J,TX,TXC,TX2,TX1,DFLT + N INTXT,UPDN,TARR + S MYLIST=$G(MYLIST) + S INTXT=$P(CLASS,"|",2) + S UPDN=$S(+$P(CLASS,"|",3):+$P(CLASS,"|",3),1:1) + S CLASS=$P(CLASS,"|",1) + I $L(CLASS)=0 S MAGRY(0)="0^Invalid Selection Class." Q + S CLNOTE=3 ; It is hard coded in TIU code. Note Class + S CLDS=244 ; It is hard coded in TIU code. Discharge Summary Class + D CPCLASS^TIUCP(.CLCP) + D CNSLCLAS^TIUSRVD(.CLCONS) + D SURGCLAS^TIUSRVD(.CLSUR) + S MAGRY(0)="0^Error: While accessing a list of Note Titles." + S MAGRY(1)="key word^TITLE^CLASS" + S I="" + F I=1:1:$L(CLASS,",") D + . S CL=$P(CLASS,",",I) + . S CLN=$S(+CL:+CL,CL="NOTE":3,CL="DS":CLDS,CL="CP":CLCP,CL="CONS":CLCONS,CL="SUR":CLSUR,1:-1) + . I MYLIST D Q + . . D MYLIST(CLN,.TARR) + . . I $O(TARR(""))'="" S MAGRY(0)="1^Personal List" + . . S J="" F S J=$O(TARR(J)) Q:J="" D + . . . S TX1=$P(TARR(J),"^",1) + . . . ; output has 'd' or 'i' as first character, we need to get rid of it. + . . . I $E(TX1)="d" S DFLT=$E(TX1,2,999),MAGRY(0)=DFLT_"^Personal list" + . . . S TX1=$E(TX1,2,999) + . . . S TX=$P(TARR(J),"^",2),TX2=$P(TX,"<",2) S:$L(TX2) TX=$P(TX,"<",1) S:$L(TX2) TX2="<"_TX2 + . . . S MAGRY($O(MAGRY(""),-1)+1)=TX_"^"_TX2_"^"_CL_"|"_TX1 + . . . Q + . . Q + . ; here add line as a break between Personal List and Start of Total List + . K TARR + . D BLDLIST(CLN,.TARR,INTXT,UPDN) + . S J="" F S J=$O(TARR(J)) Q:J="" D + . . S TX=$P(TARR(J),"^",2),TX2=$P(TX,"<",2) S:$L(TX2) TX=$P(TX,"<",1) S:$L(TX2) TX2="<"_TX2 + . . S TX1=$P(TARR(J),"^",1) + . . S MAGRY($O(MAGRY(""),-1)+1)=TX_"^"_TX2_"^"_CL_"|"_TX1 + . . Q + . Q + I '$D(MAGRY(2)) K MAGRY(1) S MAGRY(0)="0^0 Items match input: "_INTXT + E S MAGRY(0)="1^Success"_"^"_$G(DFLT)_"^" + Q + ; +MYLIST(CLN,TARR) ; + ; if not short list, default is listed twice, (This is how CPRS displays it) + K TARR + D PERSLIST^TIUSRVD(.TARR,DUZ,CLN) + Q +BLDLIST(CLN,TARR,STC,UPDN) ; + ; + S UPDN=$S(+$G(UPDN):+$G(UPDN),1:1) + K TARR + D LONGLIST^TIUSRVD(.TARR,CLN,STC,UPDN) + Q +ADMNCLOS(MAGRY,MAGDFN,MAGTIUDA,MAGMODE) ; calls TIU API to set as Admin Closed. + ; RPC Call to Administratively Close a TIU Note. + ; - - - Required - - - + ; MAGDFN - Patient DFN + ; MAGTIUDA - Note IEN in File 8925 + ; - - - Optional - - - + ; MAGMODE - "S" Scanned Document "M" - Manual closure "E" - Electronically Filed. + ; + S MAGDFN=$G(MAGDFN),MAGTIUDA=$G(MAGTIUDA),MAGMODE=$G(MAGMODE,"S") + I '$$VALDATA(.MAGRY,MAGDFN,MAGTIUDA) Q + ; Calling TIU SET ADMINISTRATIVE CLOSURE + ; MAGMODE can be "S" for SCANNED DOCUMENT <- HIMS may get this changed + ; to Electronically Filed. + ; or "M" for MANUAL CLOSURE or "E" for ELECTONICALL FILE + D ADMNCLOS^TIUSRVPT(.MAGRY,MAGTIUDA,MAGMODE) + ; on success MAGRY = MAGTIUDA + ; on error MAGRY = 0^ + I MAGRY S MAGRY=MAGRY_"^Success: Administrative Closure." + Q +VALES(X) ; Validate the esig + N MAGY S MAGY=0 + D HASH^XUSHSHP + I X]"",(X=$P($G(^VA(200,+DUZ,20)),U,4)) S MAGY=1 + Q MAGY +VALDATA(RY,MAGDFN,MAGTIUDA) ; Validate the TIUDA and the DFN + S MAGTIUDA=$G(MAGTIUDA),MAGDFN=$G(MAGDFN) + I 'MAGDFN S RY="0^Invalid data: Patient DFN invalid: "_MAGDFN Q 0 + I '$D(^DPT(+MAGDFN,0)) S RY="0^Invalid data: Patient DFN invalid: "_MAGDFN Q 0 + I 'MAGTIUDA S RY="0^Invalid Note IEN: "_MAGTIUDA Q 0 + I '$D(^TIU(8925,MAGTIUDA,0)) S RY="0^Invalid Note IEN: "_MAGTIUDA Q 0 + I $P(^TIU(8925,MAGTIUDA,0),"^",2)'=MAGDFN S RY="0^Invalid Patient DFN: "_MAGDFN_" for Note: "_MAGTIUDA Q 0 + S RY="1^Validated OK." + Q 1 diff --git a/r/IMAGING-MAG-ZMAG/MAGGNTI3.m b/r/IMAGING-MAG-ZMAG/MAGGNTI3.m index 8e721173..6aab26b6 100644 --- a/r/IMAGING-MAG-ZMAG/MAGGNTI3.m +++ b/r/IMAGING-MAG-ZMAG/MAGGNTI3.m @@ -1,89 +1,89 @@ -MAGGNTI3 ;WOIFO/GEK - Imaging interface to TIU. RPC Calls etc. ; 04 Apr 2002 2:37 PM - ;;3.0;IMAGING;**46,59**;Nov 27, 2007;Build 20 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q -MOD(MAGRY,MAGDFN,MAGTIUDA,MAGADCL,MAGMODE,MAGES,MAGESBY,MAGTEXT) ; RPC [MAG3 TIU MODIFY NOTE] - ; RPC call to Modify an Existing Note by: - ; Electronically Signing or - ; Administratively Closing the Note - ; - ; - - - Required - - - - ; MAGDFN - Patient DFN - ; MAGTIUDA - IEN of TIU NOTE in file 8925 - ; - - - Optional - - - - ; MAGADCL - 1 = Mark this Note as Administratively Closed - ; MAGMODE - Mode of Admin Closure: "S" = Scanned Document "M" = Manual closure - ; MAGES - The encrypted Electronic Signature - ; MAGESBY - The DUZ of the Signer (Defaults to DUZ) - ; MAGTEXT - Array of Text to add to the New Note. // NOT USED IN 3.0.59 - ; - N $ETRAP,$ESTACK S $ETRAP="D ERR^"_$T(+0) - S MAGDFN=$G(MAGDFN),MAGTIUDA=$G(MAGTIUDA) - S MAGES=$G(MAGES),MAGADCL=$G(MAGADCL) - S MAGESBY=$S($G(MAGESBY):MAGESBY,1:DUZ) - S MAGMODE=$S($L($G(MAGMODE)):MAGMODE,1:"S") - I '$$VALDATA^MAGGNTI2(.MAGRY,MAGDFN,MAGTIUDA) Q - N MAGXT,I,CT,MAGMRC,X - S CT=1,I="" - ; We don't allow Editing/Adding of Text to an existing document. - ; If Change Status to Admin Close. Then we Quit - S MAGRY="1^" - I MAGADCL="1" D Q:'MAGRY - . D ADMNCLOS^MAGGNTI2(.MAGTY,MAGDFN,MAGTIUDA,MAGMODE) - . S MAGRY=$S('MAGTY:MAGTY,1:MAGRY_"Note is Administratively Closed.") - . S ^TMP($J,"MAGGNTI1","MOD AFTER ADMNCLOS ")=MAGRY - . Q:'MAGRY - . ; Note has been E-Filed Complete the Consult if one is attached. - . D GET1405^TIUSRVR(.MAGMRC,MAGTIUDA) - . S ^TMP($J,"MAGGNTI1","MOD MAGMRC")=$G(MAGMRC) - . I (+MAGMRC>0)&(MAGMRC["GMR(123") D - . . ;Use GRMC Call to 'Close' the consult. For AdminClos the Consult Status - . . ;went from 'p' to 'pr' this will change it to 'c' (complete). - . . S X=$$SFILE^GMRCGUIB(+MAGMRC,10) - . . Q - . Q - ; - ; if caller sent esignature to Sign this Addendum. - I $L(MAGES) D Q:'MAGRY - . D SIGN(.MAGTY,MAGDFN,MAGTIUDA,MAGES,MAGESBY) - . S MAGRY=$S('MAGTY:MAGTY,1:MAGRY_"Note is Signed.") - . Q - Q -SIGN(MAGRY,MAGDFN,MAGTIUDA,MAGES,MAGESBY) ;RPC [MAG3 TIU SIGN RECORD] - ; RPC Call to 'Sign' a Note. - ; - - - Required - - - - ; MAGDFN - DFN of Patient. - ; MAGTIUDA - TIUDA - IEN of TIU Note file 8925 - ; MAGES - The encrypted Electronic Signature - ; MAGESBY - The DUZ of the Signer (Defaults to DUZ) - ; - N RY - S MAGDFN=$G(MAGDFN),MAGTIUDA=$G(MAGTIUDA),MAGES=$G(MAGES),MAGESBY=$G(MAGESBY,DUZ) - I '$$VALDATA^MAGGNTI2(.MAGRY,MAGDFN,MAGTIUDA) Q - ; - ; Calling TIU SIGN RECORD - D SIGN^TIUSRVP(.RY,MAGTIUDA,MAGES) - ; on success RY = 0 - ; on error RY = error code ^ < message > - I +RY S MAGRY="0^"_$TR(RY,"^","~") - E S MAGRY="1^Success: Note has been Signed." - Q -ERR ; ERROR TRAP - N ERR S ERR=$$EC^%ZOSV - S MAGRY="0^ETRAP: "_ERR - D @^%ZOSF("ERRTN") - Q +MAGGNTI3 ;WOIFO/GEK - Imaging interface to TIU RPC Calls etc. ; 04 Apr 2002 2:37 PM + ;;3.0;IMAGING;**46**;16-February-2007;;Build 1023 + ;; Per VHA Directive 2004-038, this routine should not be modified. + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q +MOD(MAGRY,MAGDFN,MAGTIUDA,MAGADCL,MAGMODE,MAGES,MAGESBY,MAGTEXT) ; RPC [MAG3 TIU MODIFY NOTE] + ; RPC call to Modify an Existing Note by: + ; Electronically Signing or + ; Administratively Closing the Note + ; + ; - - - Required - - - + ; MAGDFN - Patient DFN + ; MAGTIUDA - IEN of TIU NOTE in file 8925 + ; - - - Optional - - - + ; MAGADCL - 1 = Mark this Note as Administratively Closed + ; MAGMODE - Mode of Admin Closure: "S" = Scanned Document "M" = Manual closure + ; MAGES - The encrypted Electronic Signature + ; MAGESBY - The DUZ of the Signer (Defaults to DUZ) + ; MAGTEXT - Array of Text to add to the New Note. // NOT USED IN 3.0.59 + ; + N $ETRAP,$ESTACK S $ETRAP="D ERR^"_$T(+0) + S MAGDFN=$G(MAGDFN),MAGTIUDA=$G(MAGTIUDA) + S MAGES=$G(MAGES),MAGADCL=$G(MAGADCL) + S MAGESBY=$S($G(MAGESBY):MAGESBY,1:DUZ) + S MAGMODE=$S($L($G(MAGMODE)):MAGMODE,1:"S") + I '$$VALDATA^MAGGNTI2(.MAGRY,MAGDFN,MAGTIUDA) Q + N MAGXT,I,CT,MAGMRC,X + S CT=1,I="" + ; We don't allow Editing/Adding of Text to an existing document. + ; If Change Status to Admin Close. Then we Quit + S MAGRY="1^" + I MAGADCL="1" D Q:'MAGRY + . D ADMNCLOS^MAGGNTI2(.MAGTY,MAGDFN,MAGTIUDA,MAGMODE) + . S MAGRY=$S('MAGTY:MAGTY,1:MAGRY_"Note is Administratively Closed.") + . S ^TMP($J,"MAGGNTI1","MOD AFTER ADMNCLOS ")=MAGRY + . Q:'MAGRY + . ; Note has been E-Filed Complete the Consult if one is attached. + . D GET1405^TIUSRVR(.MAGMRC,MAGTIUDA) + . S ^TMP($J,"MAGGNTI1","MOD MAGMRC")=$G(MAGMRC) + . I (+MAGMRC>0)&(MAGMRC["GMR(123") D + . . ;Use GRMC Call to 'Close' the consult. For AdminClos the Consult Status + . . ;went from 'p' to 'pr' this will change it to 'c' (complete). + . . S X=$$SFILE^GMRCGUIB(+MAGMRC,10) + . . Q + . Q + ; + ; if caller sent esignature to Sign this Addendum. + I $L(MAGES) D Q:'MAGRY + . D SIGN(.MAGTY,MAGDFN,MAGTIUDA,MAGES,MAGESBY) + . S MAGRY=$S('MAGTY:MAGTY,1:MAGRY_"Note is Signed.") + . Q + Q +SIGN(MAGRY,MAGDFN,MAGTIUDA,MAGES,MAGESBY) ;RPC [MAG3 TIU SIGN RECORD] + ; RPC Call to 'Sign' a Note. + ; - - - Required - - - + ; MAGDFN - DFN of Patient. + ; MAGTIUDA - TIUDA - IEN of TIU Note file 8925 + ; MAGES - The encrypted Electronic Signature + ; MAGESBY - The DUZ of the Signer (Defaults to DUZ) + ; + N RY + S MAGDFN=$G(MAGDFN),MAGTIUDA=$G(MAGTIUDA),MAGES=$G(MAGES),MAGESBY=$G(MAGESBY,DUZ) + I '$$VALDATA^MAGGNTI2(.MAGRY,MAGDFN,MAGTIUDA) Q + ; + ; Calling TIU SIGN RECORD + D SIGN^TIUSRVP(.RY,MAGTIUDA,MAGES) + ; on success RY = 0 + ; on error RY = error code ^ < message > + I +RY S MAGRY="0^"_$TR(RY,"^","~") + E S MAGRY="1^Success: Note has been Signed." + Q +ERR ; ERROR TRAP + N ERR S ERR=$$EC^%ZOSV + S MAGRY="0^ETRAP: "_ERR + D @^%ZOSF("ERRTN") + Q diff --git a/r/IMAGING-MAG-ZMAG/MAGGSIA.m b/r/IMAGING-MAG-ZMAG/MAGGSIA.m index cd7699ae..776a47e5 100644 --- a/r/IMAGING-MAG-ZMAG/MAGGSIA.m +++ b/r/IMAGING-MAG-ZMAG/MAGGSIA.m @@ -1,174 +1,149 @@ -MAGGSIA ;WOIFO/GEK - Imaging RPC Broker calls. Add/Modify Image entry ; [ 12/27/2000 10:49 ] - ;;3.0;IMAGING;**7,21,8,59**;Nov 27, 2007;Build 20 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q - ; - ;**** CALLING ROUTINE is responsible for RENAMING THE IMAGE FILE - ;**** on DISK TO THE NEW FILE NAME RETURNED BY THIS CALL. - ; -ADD(MAGRY,MAGARRAY) ; RPC [MAG4 ADD IMAGE] - ; Calls UPDATE^DIE to Add an Image File entry - ; Called from Import API Delphi component and ImportX (Active X) control. - ; Parameters : - ; MAGARRAY - array of field numbers and their entries - ; i.e. MAGARRAY(1)=".5^38" field# .5 data is 38 - ; If Long Description is included in array (field 11), we create a new - ; array to hold the text, and pass that to UPDATE^DIE - ; If this entry is an Image Group - ; i.e. MAGARRAY(n)="2005.04^344" - ; (the field 2005.04 is the OBJECT GROUP MULTIPLE) - ; ( 344 is the pointer to the Image File Entry that will be added - ; ( as a member of this new/existing Group) - ; - ; Return Variable - ; - ; MAGRY(0) - Array - ; Successful MAGRY(0) = IEN^FILE NAME (with full path) - ; UNsuccessful MAGRY(0) = 0^Error desc - ; MAGRY(0)(1..n) = Errors and warnings. - ; - ; CALLING ROUTINE is responsible for RENAMING THE IMAGE FILE on DISK - ; TO THE NEW FILE NAME RETURNED BY THIS CALL. - ; Changed to include hierarchical directory hash - PMK 04/23/98 - ;---------------------------------------------------------------- - N MAGGFDA,MAGGDRV,MAGGRP,MAGCHLD,GRPCT,MAGGDA,MAGGFNM - N MAGGWP,MAGERR,MAGREF,MAGDHASH,MAGTEMP,MAGACT,MAGGIEN,MAGGXE - N GIEN,DIEN,NEWIEN ;3.0 - N I,J,X,Y,Z,WPCT - ; - N $ETRAP,$ESTACK S $ETRAP="D ERRA^MAGGSERR" - I ($D(MAGARRAY)<10) S MAGRY(0)="0^No input data, Operation CANCELED" Q - ; - S MAGRY(0)="0^Creating VistA Image Entry..." - S MAGERR="",MAGGRP=0,GRPCT=1,WPCT=0 - ; Validate the Data, and Action codes in the Input Array - D VAL^MAGGSIV(.MAGRY,.MAGARRAY) I 'MAGRY(0) Q - ; - ; Make the FileMan FDA array and the Imaging Action array. - D MAKEFDA^MAGGSIU2(.MAGGFDA,.MAGARRAY,.MAGACT,.MAGCHLD,.MAGGRP,.MAGGWP) - I '$D(MAGGFDA(2005,"+1,")) S MAGRY(0)="0^No data to file. Operation CANCELED." Q - ; - ;Q:'$$VALINDEX^MAGGSIV1(.MAGRY,$G(MAGGFDA(2005,"+1,",42)),$G(MAGGFDA(2005,"+1,",44)),$G(MAGGFDA(2005,"+1,",43))) - ; Check on some possible problems: required fields, create default values etc. - D PRE^MAGGSIA1(.MAGERR,.MAGGFDA,MAGGRP,.MAGGDRV,.MAGREF) I $L(MAGERR) S MAGRY(0)=MAGERR Q - ; Locking Patch 8. Get latest Image IEN and Deleted IEN take the greater of the two. - S GIEN=$O(^MAG(2005," "),-1)+1 - S DIEN=$O(^MAG(2005.1," "),-1)+1 - S NEWIEN=$S(GIEN>DIEN:GIEN,1:DIEN) -LOCK L +^MAG(2005,NEWIEN):0 E S NEWIEN=NEWIEN+1 G LOCK ; lock it, or get next - I $D(^MAG(2005,NEWIEN)) L -^MAG(2005,NEWIEN) S NEWIEN=NEWIEN+1 G LOCK ; if it exists, get next - S MAGGIEN(1)=NEWIEN - D UPDATE^DIE("S","MAGGFDA","MAGGIEN","MAGGXE") - ; - ; ERROR: QUIT - I '$G(MAGGIEN(1)) D S MAGRY(0)=MAGERR Q - . S MAGERR="0^ERROR Creating new Image File Entry " - . I $D(DIERR) D RTRNERR^MAGGSIU1(.MAGERR) - . D CLEAN - ; - S MAGGDA=MAGGIEN(1) - ; - D ACTION^MAGGTAU("CAP^"_MAGGFDA(2005,"+1,",5)_"^"_MAGGDA) - ; - ; IF a group, UpDate the GROUP PARENT in each Group Object and QUIT - ; The Return (MAGRY(0)) will be IEN with NO Filename. Groups don't get Filename - I MAGGRP D G C1 - . D UPDCHLD^MAGGSIM(.MAGCHLD,MAGGDA) - . S MAGRY(0)=MAGGDA_U - . D CLEAN - . Q - ; ENTRY in Image File has been made, if any errors from here on - ; then we have to delete the image entry. - ; IF This image is a member of a Group, Update the Group Entry with new child. - S X=$G(MAGGFDA(2005,"+1,",14)) I +X D I $L(MAGERR) Q - . D UPDPAR^MAGGSIM(.MAGERR,X,.MAGACT,MAGGDA) - . I $L(MAGERR) S MAGRY(0)=MAGERR D CLEAN - ; - ; Now generate the Image FileName. This is passed back to the calling app, - ; and the calling app is responsible for renaming/copying the Image File to - ; this new name. - I $D(MAGGFDA(2005,"+1,",1)) S MAGGFNM=MAGGFDA(2005,"+1,",1) - E D I $L(MAGERR) S MAGRY(0)=MAGERR Q - . N MAGXFDA - . S X=$$DA2NAME^MAGGTU1(MAGGDA,$G(MAGACT("EXT"))) I 'X D Q - . . S MAGERR=X - . . D KILLENT^MAGGSIU1(MAGGDA) - . . D CLEAN - . ; - . S MAGGFNM=$P(X,U,2),Y=MAGGDA_"," - . S MAGXFDA(2005,Y,1)=MAGGFNM - . D UPDATE^DIE("","MAGXFDA","","MAGGXE") - . ; in case of an error - . I $D(DIERR) D Q - . . D RTRNERR^MAGGSIU1(.MAGERR,.MAGGXE) - . . D KILLENT^MAGGSIU1(MAGGDA) - . . D CLEAN - ; -C1 ; 59 - K MAGGFDA ; P59. - ;P59 Now we Auto-Generate the Index Fields, if they don't exist for this entry - I '$D(^MAG(2005,MAGGDA,40)) D - . N INDXD - . D GENIEN^MAGXCVI(MAGGDA,.INDXD) - . D COMIEN^MAGXCVC(MAGGDA,.INDXD) - . S ^MAGIXCVT(2006.96,MAGGDA)=1 ; Flag. Says fields were converted by index generation - . ; TRKING ID TRKID = MAGGFDA(2005,"+1,",108) - . ;;D ACTION^MAGGTAU("GENINDX^"_MAGGFDA(2005,"+1,",5)_"^"_MAGGDA_"$$"_MAGGFDA(2005,"+1,",108)) - . D ACTION^MAGGTAU("INDEX-ALL^"_$P(^MAG(2005,MAGGDA,0),"^",7)_"^"_MAGGDA_"$$"_$P(^MAG(2005,MAGGDA,100),"^",5)) - . Q - ; - ;P59 If TYPE INDEX is missing we Auto-Generate Index Type and other missing Index Term values. - I '$P(^MAG(2005,MAGGDA,40),"^",3) D - . N INDXD,OLD40,N40 - . S (N40,OLD40)=^MAG(2005,MAGGDA,40) - . D GENIEN^MAGXCVI(MAGGDA,.INDXD) - . ; If Origin doesn't exist in existing, this will put V in. - . I $P(INDXD,"^",6)="" S $P(INDXD,"^",6)="V" - . ; We're not changing existing values of Spec,Proc or Origin - . F J=1:1:6 I '$L($P(N40,"^",J)) S $P(N40,"^",J)=$P(INDXD,"^",J) - . ;Validate the merged Spec and Proc, if not valid, revert back to old Spec and Proc - . I '$$VALINDEX^MAGGSIV1(.X,$P(N40,"^",3),$P(N40,"^",5),$P(N40,"^",4)) S $P(N40,"^",4,5)=$P(OLD40,"^",4,5) - . S ^MAG(2005,MAGGDA,40)=N40 - . ;;D ACTION^MAGGTAU("INDEX-42^"_$P(^MAG(2005,MAGGDA,0),"^",7)_"^"_MAGGDA) ;_"$$"_MAGGFDA(2005,"+1,",108)) - . D ACTION^MAGGTAU("INDEX-42^"_$P(^MAG(2005,MAGGDA,0),"^",7)_"^"_MAGGDA_"$$"_$P(^MAG(2005,MAGGDA,100),"^",5)) - . D ENTRY^MAGLOG("INDEX-42",DUZ,MAGGDA,"P59",$P(^MAG(2005,MAGGDA,0),"^",7),1) - . Q - ;** ABS and JB image queues AREN'T SET WHEN ADDING AN IMAGE. - ;** RPC =-> 'MAG ABSJB' after abstract is/isn't created on the workstation - ; - ; The Return is: IEN ^ DRIVE:DIR ^ FILE.EXT [^ DRIVE:DIR ^ FILE.BIG] - ; example: 487^C:\IMAGE\^DC000487.TIF - ; The calling routine is responsible for renaming/naming the file - ; to the returned DRIVE:\DIR\FILENAME.EXT - ; - ; Modified 4/23/98 to include hierarchical directory structure -- PMK - I 'MAGGRP D - . S MAGDHASH=$$DIRHASH^MAGFILEB(MAGGFNM,MAGREF) - . ; For now, BIG files are in same directory as FullRes (or PACS) file - . S MAGRY(0)=MAGGDA_U_MAGGDRV_MAGDHASH_U_MAGGFNM - . ; If BIG file also, add it's Drive, Hash, Filename to end of Return string. - . I $G(MAGACT("BIG")) D - . . S X=$P(MAGGFNM,".",1)_".BIG" - . . S MAGRY(0)=MAGRY(0)_U_MAGGDRV_MAGDHASH_U_X - . . Q - . Q - ; -CLEAN ; Called as tag - D CLEAN^DILF - L -^MAG(2005,NEWIEN) - Q +MAGGSIA ;WOIFO/GEK - Imaging RPC Broker calls. Add/Modify Image entry ; [ 12/27/2000 10:49 ] + ;;3.0;IMAGING;**7,21,8**;Sep 15, 2004 + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q + ; + ;**** CALLING ROUTINE is responsible for RENAMING THE IMAGE FILE + ;**** on DISK TO THE NEW FILE NAME RETURNED BY THIS CALL. + ; +ADD(MAGRY,MAGARRAY) ; RPC [MAG4 ADD IMAGE] + ; Calls UPDATE^DIE to Add an Image File entry + ; Called from Import API Delphi component and ImportX (Active X) control. + ; Parameters : + ; MAGARRAY - array of field numbers and their entries + ; i.e. MAGARRAY(1)=".5^38" field# .5 data is 38 + ; If Long Description is included in array (field 11), we create a new + ; array to hold the text, and pass that to UPDATE^DIE + ; If this entry is an Image Group + ; i.e. MAGARRAY(n)="2005.04^344" + ; (the field 2005.04 is the OBJECT GROUP MULTIPLE) + ; ( 344 is the pointer to the Image File Entry that will be added + ; ( as a member of this new/existing Group) + ; + ; Return Variable + ; + ; MAGRY(0) - Array + ; Successful MAGRY(0) = IEN^FILE NAME (with full path) + ; UNsuccessful MAGRY(0) = 0^Error desc + ; MAGRY(0)(1..n) = Errors and warnings. + ; + ; CALLING ROUTINE is responsible for RENAMING THE IMAGE FILE on DISK + ; TO THE NEW FILE NAME RETURNED BY THIS CALL. + ; Changed to include hierarchial directory hash - PMK 04/23/98 + ;---------------------------------------------------------------- + N MAGGFDA,MAGGDRV,MAGGRP,MAGCHLD,GRPCT,MAGGDA,MAGGFNM + N MAGGWP,MAGERR,MAGREF,MAGDHASH,MAGTEMP,MAGACT,MAGGIEN,MAGGXE + N GIEN,DIEN,NEWIEN ;3.0 + N I,J,X,Y,Z,WPCT + ; + N $ETRAP,$ESTACK S $ETRAP="D ERRA^MAGGSERR" + I ($D(MAGARRAY)<10) S MAGRY(0)="0^No input data, Operation CANCELED" Q + ; + S MAGRY(0)="0^Creating VistA Image Entry..." + S MAGERR="",MAGGRP=0,GRPCT=1,WPCT=0 + ; Validate the Data, and Action codes in the Input Array + D VAL^MAGGSIV(.MAGRY,.MAGARRAY) I 'MAGRY(0) Q + ; + ; Make the FileMan FDA array and the Imaging Action array. + D MAKEFDA^MAGGSIU2(.MAGGFDA,.MAGARRAY,.MAGACT,.MAGCHLD,.MAGGRP,.MAGGWP) + I '$D(MAGGFDA(2005,"+1,")) S MAGRY(0)="0^No data to file. Operation CANCELED." Q + ; + ; Check on some possible problems: required fields, create default values etc. + D PRE^MAGGSIA1(.MAGERR,.MAGGFDA,MAGGRP,.MAGGDRV,.MAGREF) I $L(MAGERR) S MAGRY(0)=MAGERR Q + ; Locking Patch 8. Get latest Image IEN and Deleted IEN take the greater of the two. + S GIEN=$O(^MAG(2005," "),-1)+1 + S DIEN=$O(^MAG(2005.1," "),-1)+1 + S NEWIEN=$S(GIEN>DIEN:GIEN,1:DIEN) +LOCK L +^MAG(2005,NEWIEN):0 E S NEWIEN=NEWIEN+1 G LOCK ; lock it, or get next + I $D(^MAG(2005,NEWIEN)) L -^MAG(2005,NEWIEN) S NEWIEN=NEWIEN+1 G LOCK ; if it exists, get next + S MAGGIEN(1)=NEWIEN + D UPDATE^DIE("S","MAGGFDA","MAGGIEN","MAGGXE") + ; + ; ERROR: QUIT + I '$G(MAGGIEN(1)) D S MAGRY(0)=MAGERR Q + . S MAGERR="0^ERROR Creating new Image File Entry " + . I $D(DIERR) D RTRNERR^MAGGSIU1(.MAGERR) + . D CLEAN + ; + S MAGGDA=MAGGIEN(1) + ; + D ACTION^MAGGTAU("CAP^"_MAGGFDA(2005,"+1,",5)_"^"_MAGGDA) + ; + ; IF a group, UpDate the GROUP PARENT in each Group Object and QUIT + ; The Return (MAGRY(0)) will be IEN with NO Filename. Groups don't get Filename + I MAGGRP D Q + . D UPDCHLD^MAGGSIM(.MAGCHLD,MAGGDA) + . S MAGRY(0)=MAGGDA_U + . D CLEAN + . Q + ; ENTRY in Image File has been made, if any errors from here on + ; then we have to delete the image entry. + ; New Index Field Check. If this entry doesn't have the Index fields introduced + ; in 3.0.8 then we use the Patch 17 conversion API call to generate default values. + ;-This is being deferred to a later patch. + ;-I '$D(^MAG(2005,MAGGDA,40)) D + ;-. D ONE^MAGSCNVI(MAGGDA) + ;-. D ACTION^MAGGTAU("DFTINDX^"_MAGGFDA(2005,"+1,",5)_"^"_MAGGDA) + ; + ; Now generate the Image FileName. This is passed back to the calling app, + ; and the calling app is responsible for renaming/copying the Image File to + ; this new name. + I $D(MAGGFDA(2005,"+1,",1)) S MAGGFNM=MAGGFDA(2005,"+1,",1) + E D I $L(MAGERR) S MAGRY(0)=MAGERR Q + . N MAGXFDA + . S X=$$DA2NAME^MAGGTU1(MAGGDA,$G(MAGACT("EXT"))) I 'X D Q + . . S MAGERR=X + . . D KILLENT^MAGGSIU1(MAGGDA) + . . D CLEAN + . ; + . S MAGGFNM=$P(X,U,2),Y=MAGGDA_"," + . S MAGXFDA(2005,Y,1)=MAGGFNM + . D UPDATE^DIE("","MAGXFDA","","MAGGXE") + . ; in case of an error + . I $D(DIERR) D Q + . . D RTRNERR^MAGGSIU1(.MAGERR,.MAGGXE) + . . D KILLENT^MAGGSIU1(MAGGDA) + . . D CLEAN + ; + ; + ; + ; IF This image is a member of a Group, Update the Group Entry with new child. + S X=$G(MAGGFDA(2005,"+1,",14)) I +X D I $L(MAGERR) Q + . D UPDPAR^MAGGSIM(.MAGERR,X,.MAGACT,MAGGDA) + . I $L(MAGERR) S MAGRY(0)=MAGERR D CLEAN + ; + ;** ABS and JB image queues AREN'T SET WHEN ADDING AN IMAGE. + ;** RPC =-> 'MAG ABSJB' after abstract is/isn't created on the workstation + ; + ; The Return is: IEN ^ DRIVE:DIR ^ FILE.EXT [^ DRIVE:DIR ^ FILE.BIG] + ; i.e 487^C:\IMAGE\^DC000487.TIF + ; The calling routine is responsible for renaming/naming the file + ; to the returned DRIVE:\DIR\FILENAME.EXT + ; + ; Modified 4/23/98 to include hierarchial directory structure -- PMK + S MAGDHASH=$$DIRHASH^MAGFILEB(MAGGFNM,MAGREF) + ; For now, BIG files are in same directory as FullRes (or PACS) file + S MAGRY(0)=MAGGDA_U_MAGGDRV_MAGDHASH_U_MAGGFNM + ; If BIG file also, add it's Drive, Hash, Filename to end of Return string. + I $G(MAGACT("BIG")) D + . S X=$P(MAGGFNM,".",1)_".BIG" + . S MAGRY(0)=MAGRY(0)_U_MAGGDRV_MAGDHASH_U_X + ; +CLEAN ; Called as tag + D CLEAN^DILF + L -^MAG(2005,NEWIEN) + Q diff --git a/r/IMAGING-MAG-ZMAG/MAGGSIA1.m b/r/IMAGING-MAG-ZMAG/MAGGSIA1.m index b39d9abd..5cb19540 100644 --- a/r/IMAGING-MAG-ZMAG/MAGGSIA1.m +++ b/r/IMAGING-MAG-ZMAG/MAGGSIA1.m @@ -1,160 +1,159 @@ -MAGGSIA1 ;WOIFO/GEK - RPC Call to Add Image File entry ; [ 12/27/2000 10:49 ] - ;;3.0;IMAGING;**7,8,85,59**;Nov 27, 2007;Build 20 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q -PRE(MAGERR,MAGGFDA,MAGGRP,MAGGDRV,MAGREF) ; - ; Check on some possible problems: required fields etc. - ; Object Type and (Patient, or Short Desc) Required. - N MAGRSLT,X,Z - I '$D(MAGGFDA(2005,"+1,",3)) D OBJTYPE - I '$D(MAGGFDA(2005,"+1,",3)) S MAGERR="0^Need an Object Type " Q - I '$D(MAGGFDA(2005,"+1,",5)),'$D(MAGGFDA(2005,"+1,",10)) D Q - . S MAGERR="0^Need Patient or Short Desc. Operation CANCELED " - ; IF no Procedure text we'll give it some so crossref will set. - D PATCHK(.MAGRSLT) I 'MAGRSLT S MAGERR=MAGRSLT Q - ; Patch 8 IAPI We Create IXCLS (#41 CLASS) and IXPKG (#40 Package) if TYPE is in Data. - ; But we are not making TYPE required yet for backward compatibality. - I $D(MAGGFDA(2005,"+1,",42)) D - . I $$GET1^DIQ(2005.83,MAGGFDA(2005,"+1,",42),2,"E")="INACTIVE" D S MAGRY=MAGERR Q - . . S MAGERR="0^Index Type: "_$$GET1^DIQ(2005.83,MAGGFDA(2005,"+1,",42),.01,"E")_"is INACTIVE" - . I '$D(MAGGFDA(2005,"+1,",41)) D MAKECLAS^MAGGSIU1 I $L(MAGERR) S MAGRY=MAGERR Q - . I ($D(MAGGFDA(2005,"+1,",16)))&($$ISTYPADM(MAGGFDA(2005,"+1,",42))) D S MAGRY=MAGERR Q - . . S MAGERR="0^Can't have an ADMIN TYPE with Clinical Image." - . I '$D(MAGGFDA(2005,"+1,",40)) D MAKEPKG^MAGGSIU1 I $L(MAGERR) S MAGRY=MAGERR Q - . I '$D(MAGGFDA(2005,"+1,",6)) D MAKEPROC^MAGGSIU1 I $L(MAGERR) S MAGRY=MAGERR Q - . I '$D(MAGGFDA(2005,"+1,",45)) D MAKEORIG^MAGGSIU1 I $L(MAGERR) S MAGRY=MAGERR Q - . Q - ; - I '$D(MAGGFDA(2005,"+1,",6)) D PROCTEXT - ; - ; If no Procedure/Exam Date/Time we'll give it DocDT, or NOW - I '$D(MAGGFDA(2005,"+1,",15)) D - . I $D(MAGGFDA(2005,"+1,",110)) S MAGGFDA(2005,"+1,",15)=MAGGFDA(2005,"+1,",110) Q - . S MAGGFDA(2005,"+1,",15)=$E($$NOW^XLFDT,1,12) - ; DateTime image saved. - I '$D(MAGGFDA(2005,"+1,",7)) S MAGGFDA(2005,"+1,",7)=$E($$NOW^XLFDT,1,12) - ; Short Description - ;I '$D(MAGGFDA(2005,"+1,",10)) S MAGGFDA(2005,"+1,",10)=$$MAKENAME^MAGGSIU1(.MAGGFDA) - I '$D(MAGGFDA(2005,"+1,",10)) S MAGGFDA(2005,"+1,",10)=$G(MAGGFDA(2005,"+1,",6)) - ; Name (.01) - I '$D(MAGGFDA(2005,"+1,",.01)) S MAGGFDA(2005,"+1,",.01)=$$MAKENAME^MAGGSIU1(.MAGGFDA) - I '$D(MAGGFDA(2005,"+1,",8)) S MAGGFDA(2005,"+1,",8)=$G(DUZ) - ; Acquisition Site, Use it to tell where to save the file. - I $D(MAGACT("ACQS")) D - . ; Patch 8 Have to modify: Field 105 (Acquisition Site) is NOW Field .05 - . I $P(MAGACT("ACQS"),";")]"" S MAGGFDA(2005,"+1,",.05)=$P(MAGACT("ACQS"),";") - ; Only get drive:dir if not a group - I 'MAGGRP D I $L(MAGERR) Q - . ; The value of the Action Code "WRITE^value" OVERRIDES any Write Location - . ; sent as field # 2 in the input array. (The only value we check for is "PACS" from peter's code) - . S X=$S($D(MAGACT("WRITE")):MAGACT("WRITE"),$D(MAGGFDA(2005,"+1,",2)):MAGGFDA(2005,"+1,",2),1:"") - . ;P85 Send ACQS as second Param. $$DRIVE will use ACQS If X = "" - . ; - . S Z=$$DRIVE^MAGGTU1(X,$G(MAGGFDA(2005,"+1,",.05))) ;Drv:Dir to Write - . I 'Z S MAGERR=Z Q - . S MAGGDRV=$P(Z,U,2) - . S MAGGFDA(2005,"+1,",2)=+Z ;Disk & Vol magnetic - . ; if a big file is being made on workstation, put NetWork Location - . ; pointer in the BIG NETWORK LOCATION field. - . ; (BIG files default to same Network Location as FullRes (or PACS)) - . I $G(MAGACT("BIG"))=1 S MAGGFDA(2005,"+1,",102)=+Z - . S MAGREF=+Z ; save network location ien for $$DIRHASH in ^MAGGSIA1 - . I $G(MAGACT("ABS"))="STUFFONLY" S MAGGFDA(2005,"+1,",2.1)=+Z - ; - I $D(MAGACT("ACQL")) S MAGGFDA(2005,"+1,",101)=MAGACT("ACQL") - ; HERE we are putting PRE Processing for the Import API action codes. - ; "ACQD,ACQS" If Acquisition device entry doesn't exist, create it. - I $D(MAGACT("ACQD")) D - . ; IF Value is a pointer to the ACQ DEVICE File Quit. If it's invalid then UPDATE will catch it. - . I (+MAGACT("ACQD")=MAGACT("ACQD")) S MAGGFDA(2005,"+1,",107)=MAGACT("ACQD") Q - . I $D(^MAG(2006.04,"B",MAGACT("ACQD"))) D Q - . . ; IF Already exists, add it to the FDA - . . S MAGGFDA(2005,"+1,",107)=$O(^MAG(2006.04,"B",MAGACT("ACQD"),"")) - . . ; What do we do with the Acquisition Site. IF Acq Dev already exists. ? - . . ; ?? - . ; IF it doesn't exist, create it, and add it's ien to the image entry - . N MAGDFDA,MAGDIEN,MAGDXE - . S MAGDFDA(2006.04,"+1,",.01)=MAGACT("ACQD") - . S MAGDFDA(2006.04,"+1,",1)=$S($D(MAGACT("ACQS")):$P(MAGACT("ACQS"),";"),1:$G(MAGGFDA(2005,"+1,",.05))) - . S MAGDFDA(2006.04,"+1,",2)=$S($D(MAGACT("ACQL")):MAGACT("ACQL"),$D(MAGGFDA(2005,"+1,",101)):MAGGFDA(2005,"+1,",101),1:$P($G(MAGACT("ACQS")),";",2)) - . ; ACQS was a 2 ';' piece value with Acq Location (HOSPITAL LOCATION) as 2nd piece - . ; now it is sent as it's own value in ACQL - . D UPDATE^DIE("","MAGDFDA","MAGDIEN","MAGDXE") - . S MAGGFDA(2005,"+1,",107)=MAGDIEN(1) - ; - ; Check the last entry in Audit File to see if it is greater than - ; last image in Image File. IF yes, change Image File (0) node entry. - I ($O(^MAG(2005,"A"),-1)<$O(^MAG(2005.1,"A"),-1)) S $P(^MAG(2005,0),U,3)=$O(^MAG(2005.1,"A"),-1) - ; - Q -PATCHK(MAGR) ; This uses the FDA Array and checks the Imaging Patient against the Procedure patient - ; - N MAGDFN,PX,PXDA,MAGY - S PX=$G(MAGGFDA(2005,"+1,",16)) - S PXDA=$G(MAGGFDA(2005,"+1,",17)) - I 'PX S MAGR=1 Q ; This is a category, or an Image of a group (no parent pointer) - S MAGDFN=MAGGFDA(2005,"+1,",5) - I (PX=8925) D Q - . I '$D(^TIU(8925,PXDA)) S MAGR="0^Invalid TIU Entry Number: "_PXDA Q - . D DATA^MAGGNTI(.MAGY,PXDA) - . I '(MAGDFN=$P(MAGY,U,4)) S MAGR="0^Procedure and Imaging patients don't match." Q - . S MAGR=1 - Q -OBJTYPE ; This call uses the EXT and computes an Object Type - N MTYPE - I '$L($G(MAGACT("EXT"))) Q - S MTYPE=$O(^MAG(2005.02,"AD",MAGACT("EXT"),"")) - ;I 'MTYPE Q - ;TODO : Answer question, do we want to have a default Image type ? - I 'MTYPE S MTYPE=1 - S MAGGFDA(2005,"+1,",3)=MTYPE - Q -ISTYPADM(TYPE) ; Returns 1 if this is an Admin Type - N CL - I '$G(TYPE) Q 0 - S CL=$$GET1^DIQ(2005.83,TYPE,1,"E") - Q $S($E(CL,1,5)="ADMIN":1,1:0) -PROCTEXT ;This call uses flds 16 and 17 to compute fld #6 PROCEDURE TEXT [8F] - ; We are here because fld #6 PROCEDURE [8F] is null. - ; If a pointer to a package is in the data, (flds 16 and 17) - ; get fld #6 from that , if not then treat it as an UNASSIGNED image - ; i.e. Category UNASSIGNED. - N MAGYPX,PARENT,PARIEN,PXDESC - S PARENT=$G(MAGGFDA(2005,"+1,",16)) - S PARIEN=$G(MAGGFDA(2005,"+1,",17)) - ; - I (PARENT=8925),(PARIEN]"") D Q - . D DATA^MAGGNTI(.MAGYPX,PARIEN) - . S MAGGFDA(2005,"+1,",6)=$P(MAGYPX,U,2) - ;TODO; create calls to get default procedure desc for all specialties - ; AND default to NONE if a TYPE and no PARENT data File (fld 16) - ; If a Parent pointer exists, and it isn't TIU, for now set "NO Description" - I PARENT]"" S MAGGFDA(2005,"+1,",6)="No Description" Q - ; - ; Do we have a pointer to a MAG DESCRIPTIVE CATEGORY - I ($G(MAGGFDA(2005,"+1,",100))]"") D Q - . S MAGGFDA(2005,"+1,",6)=$P(^MAG(2005.81,MAGGFDA(2005,"+1,",100),0),U,1) - ; - ; If a new child of a Group, use that Proc Desc - I $G(MAGGFDA(2005,"+1,",14))]"" D Q - . S MAGGFDA(2005,"+1,",6)=$P(^MAG(2005,MAGGFDA(2005,"+1,",14),0),U,8) - ; - ; Parent="", and no Category pointer, then we Call it UNASSIGNED - S MAGGFDA(2005,"+1,",100)=$O(^MAG(2005.81,"B","UNASSIGNED","")) - S MAGGFDA(2005,"+1,",6)="UNASSIGNED" - Q +MAGGSIA1 ;WOIFO/GEK - RPC Call to Add Image File entry ; [ 12/27/2000 10:49 ] + ;;3.0;IMAGING;**7,8,85**;16-March-2007;;Build 1039 + ;; Per VHA Directive 2004-038, this routine should not be modified. + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q +PRE(MAGERR,MAGGFDA,MAGGRP,MAGGDRV,MAGREF) ; + ; Check on some possible problems: required fields etc. + ; Object Type and (Patient, or Short Desc) Required. + N MAGRSLT,X,Z + I '$D(MAGGFDA(2005,"+1,",3)) D OBJTYPE + I '$D(MAGGFDA(2005,"+1,",3)) S MAGERR="0^Need an Object Type " Q + I '$D(MAGGFDA(2005,"+1,",5)),'$D(MAGGFDA(2005,"+1,",10)) D Q + . S MAGERR="0^Need Patient or Short Desc. Operation CANCELED " + ; IF no Procedure text we'll give it some so crossref will set. + D PATCHK(.MAGRSLT) I 'MAGRSLT S MAGERR=MAGRSLT Q + ; Patch 8 IAPI We Create IXCLS (#41 CLASS) and IXPKG (#40 Package) if TYPE is in Data. + ; But we are not making TYPE required yet for backward compatibality. + I $D(MAGGFDA(2005,"+1,",42)) D + . I $$GET1^DIQ(2005.83,MAGGFDA(2005,"+1,",42),2,"E")="INACTIVE" D S MAGRY=MAGERR Q + . . S MAGERR="0^Index Type: "_$$GET1^DIQ(2005.83,MAGGFDA(2005,"+1,",42),.01,"E")_"is INACTIVE" + . I '$D(MAGGFDA(2005,"+1,",41)) D MAKECLAS^MAGGSIU1 I $L(MAGERR) S MAGRY=MAGERR Q + . I ($D(MAGGFDA(2005,"+1,",16)))&($$ISTYPADM(MAGGFDA(2005,"+1,",42))) D S MAGRY=MAGERR Q + . . S MAGERR="0^Can't have an ADMIN TYPE with Clinical Image." + . I '$D(MAGGFDA(2005,"+1,",40)) D MAKEPKG^MAGGSIU1 I $L(MAGERR) S MAGRY=MAGERR Q + . I '$D(MAGGFDA(2005,"+1,",6)) D MAKEPROC^MAGGSIU1 I $L(MAGERR) S MAGRY=MAGERR Q + . I '$D(MAGGFDA(2005,"+1,",45)) D MAKEORIG^MAGGSIU1 I $L(MAGERR) S MAGRY=MAGERR Q + . Q + ; + I '$D(MAGGFDA(2005,"+1,",6)) D PROCTEXT + ; + ; If no Procedure/Exam Date/Time we'll give it DocDT, or NOW + I '$D(MAGGFDA(2005,"+1,",15)) D + . I $D(MAGGFDA(2005,"+1,",110)) S MAGGFDA(2005,"+1,",15)=MAGGFDA(2005,"+1,",110) Q + . S MAGGFDA(2005,"+1,",15)=$E($$NOW^XLFDT,1,12) + ; DateTime image saved. + I '$D(MAGGFDA(2005,"+1,",7)) S MAGGFDA(2005,"+1,",7)=$E($$NOW^XLFDT,1,12) + ; Short Description + ;I '$D(MAGGFDA(2005,"+1,",10)) S MAGGFDA(2005,"+1,",10)=$$MAKENAME^MAGGSIU1(.MAGGFDA) + I '$D(MAGGFDA(2005,"+1,",10)) S MAGGFDA(2005,"+1,",10)=$G(MAGGFDA(2005,"+1,",6)) + ; Name (.01) + I '$D(MAGGFDA(2005,"+1,",.01)) S MAGGFDA(2005,"+1,",.01)=$$MAKENAME^MAGGSIU1(.MAGGFDA) + I '$D(MAGGFDA(2005,"+1,",8)) S MAGGFDA(2005,"+1,",8)=$G(DUZ) + ; Acquisition Site, Use it to tell where to save the file. + I $D(MAGACT("ACQS")) D + . ; Patch 8 Have to modify: Field 105 (Acquisition Site) is NOW Field .05 + . I $P(MAGACT("ACQS"),";")]"" S MAGGFDA(2005,"+1,",.05)=$P(MAGACT("ACQS"),";") + ; Only get drive:dir if not a group + I 'MAGGRP D I $L(MAGERR) Q + . ; The value of the Action Code "WRITE^value" OVERRIDES any Write Location + . ; sent as field # 2 in the input array. (The only value we check for is "PACS" from peter's code) + . S X=$S($D(MAGACT("WRITE")):MAGACT("WRITE"),$D(MAGGFDA(2005,"+1,",2)):MAGGFDA(2005,"+1,",2),1:"") + . ;P85 Send ACQS as second Param. $$DRIVE will use ACQS If X = "" + . ; + . S Z=$$DRIVE^MAGGTU1(X,$G(MAGGFDA(2005,"+1,",.05))) ;Drv:Dir to Write + . I 'Z S MAGERR=Z Q + . S MAGGDRV=$P(Z,U,2) + . S MAGGFDA(2005,"+1,",2)=+Z ;Disk & Vol magnetic + . ; if a big file is being made on workstation, put NetWork Location + . ; pointer in the BIG NETWORK LOCATION field. + . ; (BIG files default to same Network Location as FullRes (or PACS)) + . I $G(MAGACT("BIG"))=1 S MAGGFDA(2005,"+1,",102)=+Z + . S MAGREF=+Z ; save network location ien for $$DIRHASH in ^MAGGSIA1 + . I $G(MAGACT("ABS"))="STUFFONLY" S MAGGFDA(2005,"+1,",2.1)=+Z + ; + I $D(MAGACT("ACQL")) S MAGGFDA(2005,"+1,",101)=MAGACT("ACQL") + ; HERE we are putting PRE Processing for the Import API action codes. + ; "ACQD,ACQS" If Acquisition device entry doesn't exist, create it. + I $D(MAGACT("ACQD")) D + . ; IF Value is a pointer to the ACQ DEVICE File Quit. If it's invalid then UPDATE will catch it. + . I (+MAGACT("ACQD")=MAGACT("ACQD")) S MAGGFDA(2005,"+1,",107)=MAGACT("ACQD") Q + . I $D(^MAG(2006.04,"B",MAGACT("ACQD"))) D Q + . . ; IF Already exists, add it to the FDA + . . S MAGGFDA(2005,"+1,",107)=$O(^MAG(2006.04,"B",MAGACT("ACQD"),"")) + . . ; What do we do with the Acquisition Site. IF Acq Dev already exists. ? + . . ; ?? + . ; IF it doesn't exist, create it, and add it's ien to the image entry + . N MAGDFDA,MAGDIEN,MAGDXE + . S MAGDFDA(2006.04,"+1,",.01)=MAGACT("ACQD") + . S MAGDFDA(2006.04,"+1,",1)=$S($D(MAGACT("ACQS")):$P(MAGACT("ACQS"),";"),1:$G(MAGGFDA(2005,"+1,",.05))) + . S MAGDFDA(2006.04,"+1,",2)=$S($D(MAGACT("ACQL")):MAGACT("ACQL"),$D(MAGGFDA(2005,"+1,",101)):MAGGFDA(2005,"+1,",101),1:$P($G(MAGACT("ACQS")),";",2)) + . ; ACQS was a 2 ';' piece value with Acq Location (HOSPITAL LOCATION) as 2nd piece + . ; now it is sent as it's own value in ACQL + . D UPDATE^DIE("","MAGDFDA","MAGDIEN","MAGDXE") + . S MAGGFDA(2005,"+1,",107)=MAGDIEN(1) + ; + ; Check the last entry in Audit File to see if it is greater than + ; last image in Image File. IF yes, change Image File (0) node entry. + I ($O(^MAG(2005,"A"),-1)<$O(^MAG(2005.1,"A"),-1)) S $P(^MAG(2005,0),U,3)=$O(^MAG(2005.1,"A"),-1) + ; + Q +PATCHK(MAGR) ; This uses the FDA Array and checks the Imaging Patient against the Procedure patient + ; + N MAGDFN,PX,PXDA,MAGY + S PX=$G(MAGGFDA(2005,"+1,",16)) + S PXDA=$G(MAGGFDA(2005,"+1,",17)) + I 'PX S MAGR=1 Q ; This is a category, or an Image of a group (no parent pointer) + S MAGDFN=MAGGFDA(2005,"+1,",5) + I (PX=8925) D Q + . I '$D(^TIU(8925,PXDA)) S MAGR="0^Invalid TIU Entry Number: "_PXDA Q + . D DATA^MAGGNTI(.MAGY,PXDA) + . I '(MAGDFN=$P(MAGY,U,4)) S MAGR="0^Procedure and Imaging patients don't match." Q + . S MAGR=1 + Q +OBJTYPE ; This call uses the EXT and computes an Object Type + N MTYPE + I '$L($G(MAGACT("EXT"))) Q + S MTYPE=$O(^MAG(2005.02,"AD",MAGACT("EXT"),"")) + ;I 'MTYPE Q + ;TODO : Answer question, do we want to have a default Image type ? + I 'MTYPE S MTYPE=1 + S MAGGFDA(2005,"+1,",3)=MTYPE + Q +ISTYPADM(TYPE) ; Returns 1 if this is an Admin Type + N CL + I '$G(TYPE) Q 0 + S CL=$$GET1^DIQ(2005.83,TYPE,1,"E") + Q $S($E(CL,1,5)="ADMIN":1,1:0) +PROCTEXT ;This call uses flds 16 and 17 to compute fld #6 PROCEDURE TEXT [8F] + ; We are here because fld #6 PROCEDURE [8F] is null. + ; If a pointer to a package is in the data, (flds 16 and 17) + ; get fld #6 from that , if not then treat it as an UNASSIGNED image + ; i.e. Category UNASSIGNED. + N MAGYPX,PARENT,PARIEN,PXDESC + S PARENT=$G(MAGGFDA(2005,"+1,",16)) + S PARIEN=$G(MAGGFDA(2005,"+1,",17)) + ; + I (PARENT=8925),(PARIEN]"") D Q + . D DATA^MAGGNTI(.MAGYPX,PARIEN) + . S MAGGFDA(2005,"+1,",6)=$P(MAGYPX,U,2) + ;TODO; create calls to get default procedure desc for all specialties + ; AND default to NONE if a TYPE and no PARENT data File (fld 16) + ; If a Parent pointer exists, and it isn't TIU, for now set "NO Description" + I PARENT]"" S MAGGFDA(2005,"+1,",6)="No Description" Q + ; + ; Do we have a pointer to a MAG DESCRIPTIVE CATEGORY + I ($G(MAGGFDA(2005,"+1,",100))]"") D Q + . S MAGGFDA(2005,"+1,",6)=$P(^MAG(2005.81,MAGGFDA(2005,"+1,",100),0),U,1) + ; + ; If a new child of a Group, use that Proc Desc + I $G(MAGGFDA(2005,"+1,",14))]"" D Q + . S MAGGFDA(2005,"+1,",6)=$P(^MAG(2005,MAGGFDA(2005,"+1,",14),0),U,8) + ; + ; Parent="", and no Category pointer, then we Call it UNASSIGNED + S MAGGFDA(2005,"+1,",100)=$O(^MAG(2005.81,"B","UNASSIGNED","")) + S MAGGFDA(2005,"+1,",6)="UNASSIGNED" + Q diff --git a/r/IMAGING-MAG-ZMAG/MAGGSIU2.m b/r/IMAGING-MAG-ZMAG/MAGGSIU2.m index be89ae08..f05f5c9f 100644 --- a/r/IMAGING-MAG-ZMAG/MAGGSIU2.m +++ b/r/IMAGING-MAG-ZMAG/MAGGSIU2.m @@ -1,87 +1,86 @@ -MAGGSIU2 ;WOIFO/GEK - Utilities for Image Add/Modify ; [ 12/27/2000 10:49 ] - ;;3.0;IMAGING;**7,8,85,59**;Nov 27, 2007;Build 20 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q -MAKEFDA(MAGGFDA,MAGARRAY,MAGACT,MAGCHLD,MAGGRP,MAGGWP) ; - ; Create the FileMan FDA Array - ; Create Imaging Action Codes Array (for Pre and Post processing) - N MAGGFLD,MAGGDAT,GRPCT,WPCT,Z - S Z="" F S Z=$O(MAGARRAY(Z)) Q:Z="" D I $L(MAGERR) Q - . S MAGGFLD=$P(MAGARRAY(Z),U,1),MAGGDAT=$P(MAGARRAY(Z),U,2,99) - . ; If this entry is one of the action codes, store it in the action array. - . I $$ACTCODE^MAGGSIV(MAGGFLD) S MAGACT(MAGGFLD)=MAGGDAT Q - . ; - . ; If we are Creating a Group Entry, add any Images that are to be members of this group. - . I MAGGFLD=2005.04 D Q - . . S MAGGRP=1 - . . I '+MAGGDAT Q ; making a group entry, with no group entries yet. This is OK. - . . S MAGCHLD(MAGGDAT)="" - . . S GRPCT=GRPCT+1 - . . S MAGGFDA(2005.04,"+"_GRPCT_",+1,",.01)=MAGGDAT - . ; - . ; if we are getting a WP for Long Desc, set array to pass. - . I MAGGFLD=11 D ; this is one line of the WP Long Desc field. - . . S WPCT=WPCT+1,MAGGWP(WPCT)=MAGGDAT - . . S MAGGFDA(2005,"+1,",11)="MAGGWP" - . ; Set the Node for the UPDATE^DIC Call. - . S MAGGFDA(2005,"+1,",MAGGFLD)=MAGGDAT - . Q - ; Patch 8. Special processing for field 107 (ACQUISITION DEVICE) - ; We'll change any MAGGFDA(2005,"+1,",107) to MAGACT("ACQD") - ; This way the PRE processing of the array will check and create a new - ; ACQUISITION DEVICE file entry, if needed. - I $D(MAGACT("107")) S MAGACT("ACQD")=MAGACT("107") K MAGACT("107") - I $D(MAGGFDA(2005,"+1,",107)) S MAGACT("ACQD")=MAGGFDA(2005,"+1,",107) K MAGGFDA(2005,"+1,",107) - Q -REQPARAM() ;Do required parameters have values. Called from MAGGSIUI - ; VARIABLES ARE SET AND KILLED IN THAT ROUTINE. - N CT - S CT=0 - S MAGRY(0)="1^Checking for Required parameter values..." - I IDFN="" S CT=CT+1,MAGRY(CT)="DFN is Required. !" - I '$D(IMAGES),'CMTH S CT=CT+1,MAGRY(CT)="List of Images is Required. !" - ; - I (PXPKG=""),(DOCCTG=""),(IXTYPE="") S CT=CT+1,MAGRY(CT)="Procedure or Category or Index Type is Required. !" - I (PXPKG'=""),(DOCCTG'="") S CT=CT+1,MAGRY(CT)="Procedure OR Document Category. Not BOTH. !" - ; - I (PXPKG'=""),(PXIEN="") S CT=CT+1,MAGRY(CT)="Procedure IEN is Required. !" - I (PXPKG=""),(PXIEN'="") S CT=CT+1,MAGRY(CT)="Procedure Package is Required. !" - I (PXPKG'=""),(PXDT="") S CT=CT+1,MAGRY(CT)="Procedure Date is Required. !" - ; - ;Patch 8 index field check... could be using Patch 7 or Patch 8. - ; We're this far, so either PXIEN or DOCCTG is defined - I (IXTYPE'=""),(DOCCTG'="") S CT=CT+1,MAGRY(CT)="Image Type OR Document Category. Not BOTH. !" - ; MAGGSIA computes PACKAGE #40 and CLASS #41 when adding an Image (2005) entry. - ; - I TRKID="" S CT=CT+1,MAGRY(CT)="Tracking ID is Required. !" - I ACQD="" S CT=CT+1,MAGRY(CT)="Acquisition Device is Required. !" - ; ACQS ( could ? ) default to users institution i.e. DUZ(2) - I (ACQS="")&(ACQN="") S CT=CT+1,MAGRY(CT)="Acquisition Site IEN or Station Number is Required. !" - I (ACQS]"")&(ACQN]"") S CT=CT+1,MAGRY(CT)="Station IEN or Station Number, Not BOTH. !" - ; - I STSCB="" S CT=CT+1,MAGRY(CT)="Status Handler (TAG^ROUTINE) is Required. !" - ; - I (DOCCTG'=""),(DOCDT="") S CT=CT+1,MAGRY(CT)="Document Date is Required. !" - ; - I (CT>0) S MAGRY(0)="0^Required parameter is null" Q MAGRY(0) - ;Checks to stop Duplicate or incorrect Tracking ID's - ; //TODO: ?? check the Queue File, is this Tracking ID already Queued. - I (TRKID'="") I $D(^MAG(2005,"ATRKID",TRKID)) S MAGRY(0)="0^Tracking ID Must be Unique !" - I (TRKID'="") I ($L(TRKID,";")<2) S MAGRY(0)="0^Tracking ID Must have "";"" Delimiter" - ; - Q MAGRY(0) +MAGGSIU2 ;WOIFO/GEK - Utilities for Image Add/Modify ; [ 12/27/2000 10:49 ] + ;;3.0;IMAGING;**7,8,85**;16-March-2007;;Build 1039 + ;; Per VHA Directive 2004-038, this routine should not be modified. + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q +MAKEFDA(MAGGFDA,MAGARRAY,MAGACT,MAGCHLD,MAGGRP,MAGGWP) ; + ; Create the FileMan FDA Array + ; Create Imaging Action Codes Array (for Pre and Post processing) + N MAGGFLD,MAGGDAT,GRPCT,WPCT,Z + S Z="" F S Z=$O(MAGARRAY(Z)) Q:Z="" D I $L(MAGERR) Q + . S MAGGFLD=$P(MAGARRAY(Z),U,1),MAGGDAT=$P(MAGARRAY(Z),U,2,99) + . ; If this entry is one of the action codes, store it in the action array. + . I $$ACTCODE^MAGGSIV(MAGGFLD) S MAGACT(MAGGFLD)=MAGGDAT Q + . ; + . ; If we are Creating a Group Entry, add any Images that are to be members of this group. + . I MAGGFLD=2005.04 D Q + . . S MAGGRP=1 + . . I '+MAGGDAT Q ; making a group entry, with no group entries yet. This is OK. + . . S MAGCHLD(MAGGDAT)="" + . . S GRPCT=GRPCT+1 + . . S MAGGFDA(2005.04,"+"_GRPCT_",+1,",.01)=MAGGDAT + . ; + . ; if we are getting a WP for Long Desc, set array to pass. + . I MAGGFLD=11 D ; this is one line of the WP Long Desc field. + . . S WPCT=WPCT+1,MAGGWP(WPCT)=MAGGDAT + . . S MAGGFDA(2005,"+1,",11)="MAGGWP" + . ; Set the Node for the UPDATE^DIC Call. + . S MAGGFDA(2005,"+1,",MAGGFLD)=MAGGDAT + . Q + ; Patch 8. Special processing for field 107 (ACQUISITION DEVICE) + ; We'll change any MAGGFDA(2005,"+1,",107) to MAGACT("ACQD") + ; This way the PRE processing of the array will check and create a new + ; ACQUISITION DEVICE file entry, if needed. + I $D(MAGACT("107")) S MAGACT("ACQD")=MAGACT("107") K MAGACT("107") + I $D(MAGGFDA(2005,"+1,",107)) S MAGACT("ACQD")=MAGGFDA(2005,"+1,",107) K MAGGFDA(2005,"+1,",107) + Q +REQPARAM() ;Do required parameters have values. Called from MAGGSIUI + ; VARIABLES ARE SET AND KILLED IN THAT ROUTINE. + N CT + S CT=0 + S MAGRY(0)="1^Checking for Required parameter values..." + I IDFN="" S CT=CT+1,MAGRY(CT)="DFN is Required. !" + I '$D(IMAGES),'CMTH S CT=CT+1,MAGRY(CT)="List of Images is Required. !" + ; + I (PXPKG=""),(DOCCTG=""),(IXTYPE="") S CT=CT+1,MAGRY(CT)="Procedure or Category or Index Type is Required. !" + I (PXPKG'=""),(DOCCTG'="") S CT=CT+1,MAGRY(CT)="Procedure OR Document Category. Not BOTH. !" + ; + I (PXPKG'=""),(PXIEN="") S CT=CT+1,MAGRY(CT)="Procedure IEN is Required. !" + I (PXPKG=""),(PXIEN'="") S CT=CT+1,MAGRY(CT)="Procedure Package is Required. !" + I (PXPKG'=""),(PXDT="") S CT=CT+1,MAGRY(CT)="Procedure Date is Required. !" + ; + ;Patch 8 index field check... could be using Patch 7 or Patch 8. + ; We're this far, so either PXIEN or DOCCTG is defined + I (IXTYPE'=""),(DOCCTG'="") S CT=CT+1,MAGRY(CT)="Image Type OR Document Category. Not BOTH. !" + ; MAGGSIA computes PACKAGE #40 and CLASS #41 when adding an Image (2005) entry. + ; + I TRKID="" S CT=CT+1,MAGRY(CT)="Tracking ID is Required. !" + I ACQD="" S CT=CT+1,MAGRY(CT)="Acquisition Device is Required. !" + ; ACQS ( could ? ) default to users institution i.e. DUZ(2) + I (ACQS="")&(ACQN="") S CT=CT+1,MAGRY(CT)="Acquisition Site IEN or Station Number is Required. !" + I (ACQS]"")&(ACQN]"") S CT=CT+1,MAGRY(CT)="Station IEN or Station Number, Not BOTH. !" + ; + I STSCB="" S CT=CT+1,MAGRY(CT)="Status Handler (TAG^ROUTINE) is Required. !" + ; + I (DOCCTG'=""),(DOCDT="") S CT=CT+1,MAGRY(CT)="Document Date is Required. !" + ; + I (CT>0) S MAGRY(0)="0^Required parameter is null" Q MAGRY(0) + ;Checks to stop Duplicate or incorrect Tracking ID's + ; //TODO: ?? check the Queue File, is this Tracking ID already Queued. + I (TRKID'="") I $D(^MAG(2005,"ATRKID",TRKID)) S MAGRY(0)="0^Tracking ID Must be Unique !" + I (TRKID'="") I ($L(TRKID,";")<2) S MAGRY(0)="0^Tracking ID Must have "";"" Delimiter" + ; + Q MAGRY(0) diff --git a/r/IMAGING-MAG-ZMAG/MAGGSIUI.m b/r/IMAGING-MAG-ZMAG/MAGGSIUI.m index 3c8a0104..d1a84adc 100644 --- a/r/IMAGING-MAG-ZMAG/MAGGSIUI.m +++ b/r/IMAGING-MAG-ZMAG/MAGGSIUI.m @@ -1,196 +1,195 @@ -MAGGSIUI ;WOIFO/GEK - Utilities for Image Import API - ;;3.0;IMAGING;**7,8,48,20,85,59**;Nov 27, 2007;Build 20 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q -REMOTE(MAGRY,MAGDATA) ;RPC [MAG4 REMOTE IMPORT] - ; Import Images from a Windows App, by sending an array. - I ($D(MAGDATA)<10) S MAGRY(0)="0^Missing Data Array !." Q - N I,J,ICT,DCT,MAGIX,IMAGES,ERR,X,Z - S (ERR,ICT,DCT)=0 - S I="" F S I=$O(MAGDATA(I)) Q:I="" S X=MAGDATA(I) D Q:ERR - . S Z=$P(X,U) - . I (X="")!(Z="") S MAGRY(0)="0^INVALID Data in Input Array: Node "_I_"="""_X_"",ERR=1 Q - . I Z="IMAGE" S ICT=ICT+1,IMAGES(ICT)=$P(X,U,2,99) Q - . S DCT=DCT+1,MAGIX(Z)=$P(X,U,2,99) - I 'ERR D IMPORT(.MAGRY,.IMAGES,.MAGIX) - Q - ; -IMPORT(MAGRY,IMAGES,MAGIX) ; - ; "IDFN","PXPKG","PXIEN","PXDT","TRKID","ACQD","ACQS","ACQL","STSCB","ITYPE", - ; "CMTH","CDUZ","USERNAME","PASSWORD","GDESC","DFLG","TRTYPE","DOCCTG","DOCDT", - ; "IXTYPE","IXSPEC","IXPROC","IXORIGIN ;Patch 8: Added Index fields - ; - ;Index fields Package, Class ("IXPKG" and "IXCLS") aren't accepted - ; they are computed values. - ; - Convert field codes into an Input Data Array, - ; validate, then set the Import Queue - ; - N $ETRAP,$ESTACK S $ETRAP="D ERR^"_$T(+0) - K MAGRY S MAGRY(0)="0^Importing data..." - N APISESS,MWIN - S MWIN=$$BROKER^XWBLIB - N PRM,CT,MAGA,MAGY,MAGTN,TNODE - N IDFN,PXPKG,PXIEN,PXDT,TRKID,ACQD,ACQS,ACQN,ACQL,STSCB,ITYPE,CMTH,CDUZ,USERNAME,PASSWORD - N GDESC,DFLG,TRTYPE,DOCCTG,DOCDT,IXPKG,IXCLS,IXTYPE,IXSPEC,IXPROC,IXORIGIN,MAX,SITEPLC - N ERR,MAGTM,QTIME,MAGIXZ - S CT=0,ERR=0 - M MAGIXZ=MAGIX - ; DON'T CONVERT ACQS(really a ACQN) to a REAL ACQS, leave it ACQS to be converted by MAGGSIV - ; - F PRM="IDFN","PXPKG","PXIEN","PXDT","TRKID","ACQD","ACQS","ACQN","ACQL","STSCB","ITYPE","CMTH","CDUZ","USERNAME","PASSWORD","GDESC","DFLG","TRTYPE","DOCCTG","DOCDT","IXTYPE","IXSPEC","IXPROC","IXORIGIN" D - . S @PRM=$G(MAGIX(PRM)) K MAGIX(PRM) ; P8T14 added K.. and next line to account for field numbers later. - . Q - S PRM="" F S PRM=$O(MAGIX(PRM)) Q:PRM="" D SA(PRM,$G(MAGIX(PRM))) - ; - S MAGTM=$$NOW^XLFDT - I '$G(DUZ) S MAGRY(0)="0^DUZ is undefined." Q ;D ERRTRK Q - ; DATATRK sets Global var. APISESS = IEN of Session File. - D DATATRK - I '$$REQPARAM^MAGGSIU2() D ERRTRK Q - S MAX=$P(TRKID,";",1)="MAX" - ;I 'MWIN W !,"----------------" ZW W !,"---------------------" - ; Workaround VIC (Maximus) is sending Station Number - ; we'll convert to Institution IEN - I MAX&(ACQS]"") D Q:ERR - . S X=$O(^DIC(4,"D",ACQS,"")) - . I X="" S MAGRY(0)="0^Invalid Station Number:(Maximus ACQS): "_ACQS,ERR=1 Q - . S SITEPLC=X ; We need the Place for the Queue - . ;S ACQS=X Out in 85. Don't change to ACQS, that's done in VAL^MAGGSIV - . Q - ; Change to Allow ACQN - STATION NUMBER from INSTITUTION File. - I $L(ACQN) D Q:ERR - . S ACQS=$O(^DIC(4,"D",ACQN,"")) - . I ACQS="" S MAGRY(0)="0^Invalid STATION NUMBER: (ACQN): "_ACQN,ERR=1 Q - . ; VAL^MAGGSIV Will fail if ACQS is real and this is Maximus - . I MAX S ACQS=ACQN K ACQN Q - . S ACQN="" ;We converted to ACQS, lets make "" so no confusion later. - . Q - ; - ; Set the input data array - D SA(5,IDFN) ;PATIENT - D SA(16,PXPKG) ;PARENT DATA FILE - D SA(17,PXIEN) ;PARENT GLOBAL ROOT - D SA(15,PXDT) ; PROCEDURE/EXAM DATE/TIME - D SA(108,TRKID) ; TRACKING ID (new) - D SA("ACQD",ACQD) ; ACQUISTION DEVICE ( new ) - I 'MAX S SITEPLC=ACQS D SA(.05,ACQS) ; this used to be fld 105 - D SA(101,ACQL) - D SA("STATUSCB",STSCB) ; STATUS CALLBACK (was referred to as ExceptionHandler) - D SA(3,ITYPE) ; OBJECT TYPE - D SA("CALLMTH",CMTH) ; CALL METHOD - D SA(8,CDUZ) ; IMAGE SAVE BY - D SA("USERNAME",USERNAME) - D SA("PASSWORD",PASSWORD) - D SA(10,GDESC) ; SHORT DESCRIPTION - D SA("DELFLAG",DFLG) ; DELETE FLAG - D SA("TRNSTYP",TRTYPE) ; TRANSACTION TYPE - D SA(100,DOCCTG) ; document Main category - D SA(110,DOCDT) ; document date - ; Patch 8 allows Index fields to be imported. - ;"IXTYPE","IXSPEC","IXPROC","IXORIGIN" - D SA(42,IXTYPE) ; Index Type - D SA(43,IXPROC) ; Index Proc/Event - D SA(44,IXSPEC) ; Index Spec/SubSpec - D SA(45,IXORIGIN) ; Index Origin - ; - D VAL^MAGGSIV(.MAGRY,.MAGA,1) I 'MAGRY(0) D ERRTRK Q - I MAX D SA(.05,ACQS) ; this used to be fld 105 - ; Also Done in MAGGSIA when image is being Saved. - I '$$VALINDEX^MAGGSIV1(.MAGRY,IXTYPE,IXSPEC,IXPROC) D ERRTRK Q - ; Array of Images to Import - D SI("IMAGES",.IMAGES) I 'MAGRY(0) D ERRTRK Q - K MAGRY - ; - I TRTYPE="NOQUEUE" M MAGRY=MAGA S MAGRY(0)="1^" Q - ; This call is for BP - S QTIME=$$NOW^XLFDT - ; p85 use ACQS instead of DUZ(2) - S MAGY=$$IMPORT^MAGBAPI(.MAGA,STSCB,TRKID,$$PLACE^MAGBAPI(SITEPLC)) - ; Return Queue Number - I 'MAGY S MAGRY(0)="0^Error Setting Queue: "_$P(MAGY,U,2),MAGY=TRKID - E S MAGRY(0)=MAGY_"^Data has been Queued.",MAGY=+MAGY - ; for Testing, we'll track input array, and results array by Queue number. - I 'MAGRY(0) D ERRTRK Q - D LOGRES^MAGGSIU3(.MAGRY,0,APISESS) - ; - Q - ; -SA(FLD,VAL) ;Set the data array with Fld,Value - Q:VAL="" - S CT=CT+1,MAGA(CT)=FLD_U_VAL - Q -SI(FLD,ARR) ;Set the images into the data array - ; 'CT' is a global variable. - S MAGRY(0)="1^Valid Image file Extensions." - N I,MAGEXT,MAGFN - S I="" F S I=$O(ARR(I)) Q:I="" D Q:'MAGRY(0) - . S CT=CT+1 - . I ($L($P(ARR(I),U),".")<2) S MAGRY(0)="0^Invalid file name: "_ARR(I) Q - . S MAGFN=$P(ARR(I),"^") - . S MAGEXT=$$UP^XLFSTR($P(MAGFN,".",$L(MAGFN,"."))) - . I '$D(^MAG(2005.021,"B",MAGEXT)) S MAGRY(0)="0^Unsupported File Type:'."_MAGEXT Q - . S MAGA(CT)="IMAGE"_U_ARR(I) - Q -GETARR(ARR,QNUM) ;RPC [MAG4 DATA FROM IMPORT QUEUE] - ; Get the Input Array from Queue Number - I '$G(QNUM) S ARR(0)="0^INVALID QUEUE Number: "_$G(QNUM) Q - D IMPAR^MAGQBUT2(.ARR,QNUM) - Q -STATUSCB(MAGRY,STAT,TAGRTN,DOCB) ;RPC [MAG4 STATUS CALLBACK] - ; Report Status to calling application - ; Now the IAPI and OCX make this call. Not BP - ; STAT(0)= "0^message" or "1^message" - ; STAT(1)=TRKID, - ; (2)=QNUM - ; (3..N)=warnings - ;TAGRTN : The TAG^RTN to call with Status Array - ;DOCB : (1|0) to suppress execution of Status Callback - ; - N APISESS,TRKID,CBMSG - S DOCB=$S($G(DOCB)="":1,1:+$G(DOCB)) ; Default to TRUE - ; Old Import API and BP that made this call, will work : DOCB defaults to 1 - S CBMSG=$S(DOCB:"Status Callback was called",1:"Status Callback was NOT called") - I DOCB D @(TAGRTN_"(.STAT)") - S MAGRY="1^"_CBMSG - S STAT($O(STAT(""),-1)+1)=MAGRY - S TRKID=$G(STAT(1)) - ; Log Results. Always. - I $L(TRKID) D - . S APISESS=$$SES4TRK^MAGGSIU3(TRKID) ; - . I APISESS D LOGRES^MAGGSIU3(.STAT,0,APISESS) ;gek/send Tracking ID to log status - Q -TESTCB(STATARR) ;TESTING. This is the Status Callback for testing. - ; the STATUSCB property must have a Valid "M" TAG^ROUTINE - ; TAG TESTCB exists so that STATUSCB validates successfully - Q -ERRTRK ;Track bad data and Quit - N I - D LOGERR^MAGGSERR("---- New Error ----",APISESS) - S I="" F S I=$O(MAGRY(I)) Q:I="" D LOGERR^MAGGSERR(MAGRY(I),APISESS) - Q -DATATRK ; Track the raw data being sent to the Import API. - ; Log the data being imported. Results are logged later. - N XY - S APISESS=$$LOG^MAGGSIU3(.XY,.MAGIXZ,.IMAGES,IDFN,ACQD,TRKID) - Q -ERR ; ERROR TRAP FOR Import API - N ERR S ERR=$$EC^%ZOSV - S MAGRY(0)="0^ETRAP: "_ERR - D @^%ZOSF("ERRTN") - I $G(APISESS) D ERRTRK - Q +MAGGSIUI ;WOIFO/GEK - Utilities for Image Import API + ;;3.0;IMAGING;**7,8,48,20,85**;16-March-2007;;Build 1039 + ;; Per VHA Directive 2004-038, this routine should not be modified. + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q +REMOTE(MAGRY,MAGDATA) ;RPC [MAG4 REMOTE IMPORT] + ; Import Images from a Windows App, by sending an array. + I ($D(MAGDATA)<10) S MAGRY(0)="0^Missing Data Array !." Q + N I,J,ICT,DCT,MAGIX,IMAGES,ERR,X,Z + S (ERR,ICT,DCT)=0 + S I="" F S I=$O(MAGDATA(I)) Q:I="" S X=MAGDATA(I) D Q:ERR + . S Z=$P(X,U) + . I (X="")!(Z="") S MAGRY(0)="0^INVALID Data in Input Array: Node "_I_"="""_X_"",ERR=1 Q + . I Z="IMAGE" S ICT=ICT+1,IMAGES(ICT)=$P(X,U,2,99) Q + . S DCT=DCT+1,MAGIX(Z)=$P(X,U,2,99) + I 'ERR D IMPORT(.MAGRY,.IMAGES,.MAGIX) + Q + ; +IMPORT(MAGRY,IMAGES,MAGIX) ; + ; "IDFN","PXPKG","PXIEN","PXDT","TRKID","ACQD","ACQS","ACQL","STSCB","ITYPE", + ; "CMTH","CDUZ","USERNAME","PASSWORD","GDESC","DFLG","TRTYPE","DOCCTG","DOCDT", + ; "IXTYPE","IXSPEC","IXPROC","IXORIGIN ;Patch 8: Added Index fields + ; + ;Index fields Package, Class ("IXPKG" and "IXCLS") aren't accepted + ; they are computed values. + ; - Convert field codes into an Input Data Array, + ; validate, then set the Import Queue + ; + N $ETRAP,$ESTACK S $ETRAP="D ERR^"_$T(+0) + K MAGRY S MAGRY(0)="0^Importing data..." + N APISESS,MWIN + S MWIN=$$BROKER^XWBLIB + N PRM,CT,MAGA,MAGY,MAGTN,TNODE + N IDFN,PXPKG,PXIEN,PXDT,TRKID,ACQD,ACQS,ACQN,ACQL,STSCB,ITYPE,CMTH,CDUZ,USERNAME,PASSWORD + N GDESC,DFLG,TRTYPE,DOCCTG,DOCDT,IXPKG,IXCLS,IXTYPE,IXSPEC,IXPROC,IXORIGIN,MAX,SITEPLC + N ERR,MAGTM,QTIME,MAGIXZ + S CT=0,ERR=0 + M MAGIXZ=MAGIX + ; DON'T CONVERT ACQS(really a ACQN) to a REAL ACQS, leave it ACQS to be converted by MAGGSIV + ; + F PRM="IDFN","PXPKG","PXIEN","PXDT","TRKID","ACQD","ACQS","ACQN","ACQL","STSCB","ITYPE","CMTH","CDUZ","USERNAME","PASSWORD","GDESC","DFLG","TRTYPE","DOCCTG","DOCDT","IXTYPE","IXSPEC","IXPROC","IXORIGIN" D + . S @PRM=$G(MAGIX(PRM)) K MAGIX(PRM) ; P8T14 added K.. and next line to account for field numbers later. + . Q + S PRM="" F S PRM=$O(MAGIX(PRM)) Q:PRM="" D SA(PRM,$G(MAGIX(PRM))) + ; + S MAGTM=$$NOW^XLFDT + I '$G(DUZ) S MAGRY(0)="0^DUZ is undefined." Q ;D ERRTRK Q + ; DATATRK sets Global var. APISESS = IEN of Session File. + D DATATRK + I '$$REQPARAM^MAGGSIU2() D ERRTRK Q + S MAX=$P(TRKID,";",1)="MAX" + ;I 'MWIN W !,"----------------" ZW W !,"---------------------" + ; Workaround VIC (Maximus) is sending Station Number + ; we'll convert to Institution IEN + I MAX&(ACQS]"") D Q:ERR + . S X=$O(^DIC(4,"D",ACQS,"")) + . I X="" S MAGRY(0)="0^Invalid Station Number:(Maximus ACQS): "_ACQS,ERR=1 Q + . S SITEPLC=X ; We need the Place for the Queue + . ;S ACQS=X Out in 85. Don't change to ACQS, that's done in VAL^MAGGSIV + . Q + ; Change to Allow ACQN - STATION NUMBER from INSTITUTION File. + I $L(ACQN) D Q:ERR + . S ACQS=$O(^DIC(4,"D",ACQN,"")) + . I ACQS="" S MAGRY(0)="0^Invalid STATION NUMBER: (ACQN): "_ACQN,ERR=1 Q + . ; VAL^MAGGSIV Will fail if ACQS is real and this is Maximus + . I MAX S ACQS=ACQN K ACQN Q + . S ACQN="" ;We converted to ACQS, lets make "" so no confusion later. + . Q + ; + ; Set the input data array + D SA(5,IDFN) ;PATIENT + D SA(16,PXPKG) ;PARENT DATA FILE + D SA(17,PXIEN) ;PARENT GLOBAL ROOT + D SA(15,PXDT) ; PROCEDURE/EXAM DATE/TIME + D SA(108,TRKID) ; TRACKING ID (new) + D SA("ACQD",ACQD) ; ACQUISTION DEVICE ( new ) + I 'MAX S SITEPLC=ACQS D SA(.05,ACQS) ; this used to be fld 105 + D SA(101,ACQL) + D SA("STATUSCB",STSCB) ; STATUS CALLBACK (was referred to as ExceptionHandler) + D SA(3,ITYPE) ; OBJECT TYPE + D SA("CALLMTH",CMTH) ; CALL METHOD + D SA(8,CDUZ) ; IMAGE SAVE BY + D SA("USERNAME",USERNAME) + D SA("PASSWORD",PASSWORD) + D SA(10,GDESC) ; SHORT DESCRIPTION + D SA("DELFLAG",DFLG) ; DELETE FLAG + D SA("TRNSTYP",TRTYPE) ; TRANSACTION TYPE + D SA(100,DOCCTG) ; document Main category + D SA(110,DOCDT) ; document date + ; Patch 8 allows Index fields to be imported. + ;"IXTYPE","IXSPEC","IXPROC","IXORIGIN" + D SA(42,IXTYPE) ; Index Type + D SA(43,IXPROC) ; Index Proc/Event + D SA(44,IXSPEC) ; Index Spec/SubSpec + D SA(45,IXORIGIN) ; Index Origin + ; + D VAL^MAGGSIV(.MAGRY,.MAGA,1) I 'MAGRY(0) D ERRTRK Q + I MAX D SA(.05,ACQS) ; this used to be fld 105 + ; Also Done in MAGGSIA when image is being Saved. + I '$$VALINDEX^MAGGSIV1(.MAGRY,IXTYPE,IXSPEC,IXPROC) D ERRTRK Q + ; Array of Images to Import + D SI("IMAGES",.IMAGES) I 'MAGRY(0) D ERRTRK Q + K MAGRY + ; + I TRTYPE="NOQUEUE" M MAGRY=MAGA S MAGRY(0)="1^" Q + ; This call is for BP + S QTIME=$$NOW^XLFDT + ; p85 use ACQS instead of DUZ(2) + S MAGY=$$IMPORT^MAGBAPI(.MAGA,STSCB,TRKID,$$PLACE^MAGBAPI(SITEPLC)) + ; Return Queue Number + I 'MAGY S MAGRY(0)="0^Error Setting Queue: "_$P(MAGY,U,2),MAGY=TRKID + E S MAGRY(0)=MAGY_"^Data has been Queued.",MAGY=+MAGY + ; for Testing, we'll track input array, and results array by Queue number. + I 'MAGRY(0) D ERRTRK Q + D LOGRES^MAGGSIU3(.MAGRY,0,APISESS) + ; + Q + ; +SA(FLD,VAL) ;Set the data array with Fld,Value + Q:VAL="" + S CT=CT+1,MAGA(CT)=FLD_U_VAL + Q +SI(FLD,ARR) ;Set the images into the data array + ; 'CT' is a global variable. + S MAGRY(0)="1^Valid Image file Extensions." + N I,MAGEXT,MAGFN + S I="" F S I=$O(ARR(I)) Q:I="" D Q:'MAGRY(0) + . S CT=CT+1 + . I ($L($P(ARR(I),U),".")<2) S MAGRY(0)="0^Invalid file name: "_ARR(I) Q + . S MAGFN=$P(ARR(I),"^") + . S MAGEXT=$$UP^XLFSTR($P(MAGFN,".",$L(MAGFN,"."))) + . I '$D(^MAG(2005.021,"B",MAGEXT)) S MAGRY(0)="0^Unsupported File Type:'."_MAGEXT Q + . S MAGA(CT)="IMAGE"_U_ARR(I) + Q +GETARR(ARR,QNUM) ;RPC [MAG4 DATA FROM IMPORT QUEUE] + ; Get the Input Array from Queue Number + I '$G(QNUM) S ARR(0)="0^INVALID QUEUE Number: "_$G(QNUM) Q + D IMPAR^MAGQBUT2(.ARR,QNUM) + Q +STATUSCB(MAGRY,STAT,TAGRTN,DOCB) ;RPC [MAG4 STATUS CALLBACK] + ; Report Status to calling application + ; Now the IAPI and OCX make this call. Not BP + ; STAT(0)= "0^message" or "1^message" + ; STAT(1)=TRKID, + ; (2)=QNUM + ; (3..N)=warnings + ;TAGRTN : The TAG^RTN to call with Status Array + ;DOCB : (1|0) to suppress execution of Status Callback + ; + N APISESS,TRKID,CBMSG + S DOCB=$S($G(DOCB)="":1,1:+$G(DOCB)) ; Default to TRUE + ; Old Import API and BP that made this call, will work : DOCB defaults to 1 + S CBMSG=$S(DOCB:"Status Callback was called",1:"Status Callback was NOT called") + I DOCB D @(TAGRTN_"(.STAT)") + S MAGRY="1^"_CBMSG + S STAT($O(STAT(""),-1)+1)=MAGRY + S TRKID=$G(STAT(1)) + ; Log Results. Always. + I $L(TRKID) D + . S APISESS=$$SES4TRK^MAGGSIU3(TRKID) ; + . I APISESS D LOGRES^MAGGSIU3(.STAT,0,APISESS) ;gek/send Tracking ID to log status + Q +TESTCB(STATARR) ;TESTING. This is the Status Callback for testing. + ; the STATUSCB property must have a Valid "M" TAG^ROUTINE + ; TAG TESTCB exists so that STATUSCB validates successfully + Q +ERRTRK ;Track bad data and Quit + N I + D LOGERR^MAGGSERR("---- New Error ----",APISESS) + S I="" F S I=$O(MAGRY(I)) Q:I="" D LOGERR^MAGGSERR(MAGRY(I),APISESS) + Q +DATATRK ; Track the raw data being sent to the Import API. + ; Log the data being imported. Results are logged later. + N XY + S APISESS=$$LOG^MAGGSIU3(.XY,.MAGIXZ,.IMAGES,IDFN,ACQD,TRKID) + Q +ERR ; ERROR TRAP FOR Import API + N ERR S ERR=$$EC^%ZOSV + S MAGRY(0)="0^ETRAP: "_ERR + D @^%ZOSF("ERRTN") + I $G(APISESS) D ERRTRK + Q diff --git a/r/IMAGING-MAG-ZMAG/MAGGSIV.m b/r/IMAGING-MAG-ZMAG/MAGGSIV.m index bed75a31..c09b1ebd 100644 --- a/r/IMAGING-MAG-ZMAG/MAGGSIV.m +++ b/r/IMAGING-MAG-ZMAG/MAGGSIV.m @@ -1,174 +1,173 @@ -MAGGSIV ;WOIFO/GEK - Imaging RPC Broker calls. Validate Image data array ; [ 12/27/2000 10:49 ] - ;;3.0;IMAGING;**7,8,20,59**;Nov 27, 2007;Build 20 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q -VAL(MAGRY,MAGARRAY,ALL) ;RPC [MAG4 VALIDATE DATA] - ;Call to Validate the Image Data Array before a new image/modified entry is attempted. - ; Called from MAGGSIA, MAGGSIUI and Capture GUI. - ; Parameters : - ; MAGARRAY - array of 'Field numbers'|'Action codes' and their Values - ; MAGARRAY(1)="5^38" Field#: 5 Value: 38 - ; an example of an action code is the Code for File Extension - ; MAGARRAY(2)="EXT^JPG" Action: EXT Value: JPG - ; ALL - "1" = Validate ALL fields, returning an array of error messages. - ; "0" = Stop validating if an error occurs, return - ; the error message in (0) node. - ; Return Variable - ; MAGRY() - Array - ; Successful MAGRY(0) = 1^Image Data is Valid. - ; UNsuccessful MAGRY(0) = 0^Error desc - ; IF ALL then MAGRY(1..N) =0^Error desc of all errors - N MAGGFLD,MAGGDAT,MAGFSPEC,CHKOK,MAGETXT,MAGRET,MAGRES - N Y,AITEM,CT,MAGERR,DFNFLAG,DAT1,X,MAX - N $ETRAP,$ESTACK S $ETRAP="D ERR^"_$T(+0) - S ALL=$G(ALL) - S MAGRY(0)="0^Validating the Data Array..." - S MAGERR="",DFNFLAG=0,CT=0 - ; Do we have any data ? - I ($D(MAGARRAY)<10) S MAGRY(0)="0^No input data, Operation CANCELED" Q - ; Flag if from Maximus - S MAX=0 - S X="" F S X=$O(MAGARRAY(X)) Q:X="" I $P(MAGARRAY(X),U,1)="TRKID"!($P(MAGARRAY(X),U,1)="108") I $P($P(MAGARRAY(X),U,2),";",1)="MAX" S MAX=1 - ; Loop through Input Array - S AITEM="" F S AITEM=$O(MAGARRAY(AITEM)) Q:AITEM="" D I $L(MAGERR) Q:'ALL S CT=CT+1,MAGRY(CT)=MAGERR,MAGERR="" - . S MAGERR="" - . S MAGGFLD=$P(MAGARRAY(AITEM),U,1),MAGGDAT=$P(MAGARRAY(AITEM),U,2,99) - . I MAGGFLD="" S MAGERR="0^A Field Number/Action Code is required: "_" Item: "_MAGARRAY(AITEM) Q - . I MAGGDAT="" S MAGERR="0^A Value is required."_" Item: "_MAGARRAY(AITEM) Q - . I MAGGFLD=5 S DFNFLAG=1 - . ; This inadvertently disallowed Tracking ID's on Group Images. - . ;I MAGGFLD=108 I $D(^MAG(2005,"ATRKID",MAGGDAT)) S MAGERR="0^Tracking ID Must be Unique !" Q - . I MAGGFLD=108 I ($L(MAGGDAT,";")<2) S MAGRY(0)="0^Tracking ID Must have "";"" Delimiter" Q - . ; Check for possible action codes that could be in the array. - . I $$ACTCODE(MAGGFLD) D Q - . . S DAT1=MAGGDAT - . . S Y=$$VALCODE(MAGGFLD,.MAGGDAT) S:'Y MAGERR=Y_" Item: "_MAGARRAY(AITEM) - . . I DAT1'=MAGGDAT S MAGARRAY(AITEM)=MAGGFLD_"^"_MAGGDAT - . ; If we are adding Multiple Images to a Group, they must be Validated. - . ; we could have multiple "2005.04^IENs" in this array. Which means we are - . ; adding existing Images to a New/Existing Group. - . I MAGGFLD=2005.04 D Q ; 2005.04 isn't the field number, #4 is the field number - . . I $G(MAGGDAT,0)=0 Q ;Creating a new Group, with no group entries is the usual way - . . ; to do it. Then make successive calls to ADD, Adding each Image to the - . . ; Object Group multiple of the Group Parent (fld#14) as it is created. - . . I '$D(^MAG(2005,MAGGDAT,0)) S MAGERR="0^Group Object "_MAGGDAT_" doesn't exist"_" Item: "_MAGARRAY(AITEM) - . . ; We can't allow adding an image if it already has a group parent. - . . I $P(^MAG(2005,MAGGDAT,0),U,10) S MAGERR="0^The Image to be added to the Group, already has a Group Parent"_" Item: "_MAGARRAY(AITEM) - . ; if we are getting a WP line of text for Long Desc Field. Can't validate it. - . I MAGGFLD=11 Q ; this is a line of the WP Long Desc field. - . ; NEW CALL TO VALIDATE FILE,FIELD,DATA - . S DAT1=MAGGDAT - . I '$$VALID^MAGGSIV1(2005,MAGGFLD,.MAGGDAT,.MAGRES) S MAGERR="0^"_MAGRES Q - . I DAT1'=MAGGDAT S MAGARRAY(AITEM)=MAGGFLD_"^"_MAGGDAT - . Q - ; - ; if there was an Error in data we'll quit now. - ; If ALL is true, then MAGRY(1...N) will exist if there were errors. - I $O(MAGRY(0)) S MAGRY(0)="0^Errors were found in data." Q - ; If ALL is false, then MAGERR will exist if there was an error. - I $L(MAGERR) S MAGRY(0)=MAGERR Q - ; - ; If all data is valid we get here. - ; Last Test, see if a Patient was in array, - ; (Patient is the only Required field check done in this routine). - I 'DFNFLAG S MAGRY(0)="0^A Patient DFN is required. " Q - S MAGRY(0)="1^Data is Valid." - Q -ACTCODE(CODE) ;Function that returns True (1) if this code is a valid Import API Action Code - ; Patch 8. We're adding 107 as an action code, so it will pass validation even if the entry - ; in the Acquisition Device File doesn't exist; - ; it will be validated in PRE^MAGGSIA1 and a new Acquisition Device entry made if needed. - I ",107,ACQD,IEN,EXT,ABS,JB,WRITE,BIG,DICOMSN,DICOMIN,ACQS,ACQL,STATUSCB,CALLMTH,USERNAME,PASSWORD,DELFLAG,TRNSTYP,"[(","_CODE_",") Q 1 - Q 0 -VALCODE(CODE,VALUE) ; We validate the values for the possible action codes - N MAGY - I VALUE="" Q "0^NO VALUE in Action Code string: """_X_"" - ; Patch 8, added 107 - I ",ACQL,CALLMTH,USERNAME,PASSWORD,"[(","_CODE_",") Q 1 ; NO VALIDATION FOR THESE CODES - D @CODE - Q MAGY - ; Each Tag is a valid Action code -IEN I $D(^MAG(2005,VALUE)) S MAGY=1 - E S MAGY="0^INVALID IMAGE IEN." - Q -EXT ; code will go here to validate the extension type. i.e. we won't let types .exe .bat .com .zip ... etc. - ; Maybe a modification to Object Type file, to have allowable extensions in the file, and a - ; cross reference on a new field EXTENSION. The capture workstation wouldn't have to ask the - ; user for the file type of each file, and we wouldn't get WORD .DOC files that the user called Color Images -ABS ; Meaning: Have the BP create the abstract -JB ; Meaning: Have the BP copy the image to the JukeBox -BIG ; Meaning: There is a big file also, set the Image File field ? to indicate there is a BIG File. - S MAGY=1 - Q -WRITE ; Meaning: This is the Internal Entry (or "PACS") of the WRITE Directory. Images will be written - ; here instead of the default WRITE Directory. - S MAGY=$$DRIVE^MAGGTU1(VALUE) - Q -DICOMSN ;Meaning: DICOM Series Number. This will be entered in the Group Object multiple, field #1 - ;We were validating this as an integer, but it can be anything, no way to validate. - S MAGY=1 - Q -DICOMIN ;Meaning: DICOM Image Number. This will be entered in the Group Object multiple, field #2 - ; We were validating this as an integer, but it can be anything, no way to validate. - S MAGY=1 - Q -DELFLAG ;Meaning: This flag tells the Delphi Import Component to Delete the Image files after successful processing - I ",TRUE,FALSE,0,1,"[(","_$$UPPER(VALUE)_",") S MAGY=1 - E S MAGY="0^INVALID Value " - I VALUE="1" S VALUE="TRUE" - I VALUE="0" S VALUE="FALSE" - Q -TRNSTYP ;Meaning: This flag is for future use, for now it is ignored, defaults to "NEW" - S MAGY=1 - Q -STATUSCB ; Meaning: This is the TAG^RTN that Imaging calls to report the - ; status of the Import. - S MAGY="0^Error validating TAG^RTN: "_VALUE - I '$L($T(@VALUE)) S MAGY="0^Invalid Status CallBack "_VALUE - E S MAGY=1 - Q -ACQS ; We need to make sure the ACQS (Acquisition Site) is a Valid entry in Imaging Site Params. - S VALUE=$P(VALUE,";") ; Stop error, when old OCX sends data. - ; Next Block is for VIC (Maximus) that sends Station Number. - N ERR S ERR=0 - I MAX D Q:ERR - . S X=$O(^DIC(4,"D",VALUE,"")) - . I X="" S MAGY="0^Invalid STATION NUMBER: (ACQS): "_VALUE,ERR=1 Q - . S VALUE=X - . Q - I '$$CONSOLID^MAGBAPI S MAGY=1 Q - ;Patch 20 will have this. - I '$D(^MAG(2006.1,"B",VALUE)) S MAGY="0^Acquisition Site ("_VALUE_") is Not in Site Param File." Q - S MAGY=1 - Q -107 ; 107 and ACQD are the same. Calling 107 falls into validation for ACQD. -ACQD ; 107 and ACQD are ACQUISITION DEVICE FILE (2006.04) pointers or Values. - ; If it is an integer, We assume the value is an IEN and validate it here. - I ((+VALUE)=VALUE),'$D(^MAG(2006.04,VALUE)) S MAGY="0^Invalid IEN ("_VALUE_") for ACQUISITION DEVICE File." Q - ; if it is not an integer, it is either a new/existing entry for 2006.04 Result is Success, - ; and it will be validated in PRE^MAGGSIA1 and added to File 2006.04 if needed. - S MAGY=1 - Q -UPPER(X) ; - Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") - ; -ERR ; ERROR TRAP FOR Import API - N ERR S ERR=$$EC^%ZOSV - S MAGRY(0)="0^ETRAP: "_ERR - D @^%ZOSF("ERRTN") - Q +MAGGSIV ;WOIFO/GEK - Imaging RPC Broker calls. Validate Image data array ; [ 12/27/2000 10:49 ] + ;;3.0;IMAGING;**7,8,20**;Apr 12, 2006 + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q +VAL(MAGRY,MAGARRAY,ALL) ;RPC [MAG4 VALIDATE DATA] + ;Call to Validate the Image Data Array before a new image/modified entry is attempted. + ; Called from MAGGSIA, MAGGSIUI and Capture GUI. + ; Parameters : + ; MAGARRAY - array of 'Field numbers'|'Action codes' and their Values + ; MAGARRAY(1)="5^38" Field#: 5 Value: 38 + ; an example of an action code is the Code for File Extension + ; MAGARRAY(2)="EXT^JPG" Action: EXT Value: JPG + ; ALL - "1" = Validate ALL fields, returning an array of error messages. + ; "0" = Stop validating if an error occurs, return + ; the error message in (0) node. + ; Return Variable + ; MAGRY() - Array + ; Successful MAGRY(0) = 1^Image Data is Valid. + ; UNsuccessful MAGRY(0) = 0^Error desc + ; IF ALL then MAGRY(1..N) =0^Error desc of all errors + N MAGGFLD,MAGGDAT,MAGFSPEC,CHKOK,MAGETXT,MAGRET,MAGRES + N Y,AITEM,CT,MAGERR,DFNFLAG,DAT1,X,MAX + N $ETRAP,$ESTACK S $ETRAP="D ERR^"_$T(+0) + S ALL=$G(ALL) + S MAGRY(0)="0^Validating the Data Array..." + S MAGERR="",DFNFLAG=0,CT=0 + ; Do we have any data ? + I ($D(MAGARRAY)<10) S MAGRY(0)="0^No input data, Operation CANCELED" Q + ; Flag if from Maximus + S MAX=0 + S X="" F S X=$O(MAGARRAY(X)) Q:X="" I $P(MAGARRAY(X),U,1)="TRKID"!($P(MAGARRAY(X),U,1)="108") I $P($P(MAGARRAY(X),U,2),";",1)="MAX" S MAX=1 + ; Loop through Input Array + S AITEM="" F S AITEM=$O(MAGARRAY(AITEM)) Q:AITEM="" D I $L(MAGERR) Q:'ALL S CT=CT+1,MAGRY(CT)=MAGERR,MAGERR="" + . S MAGERR="" + . S MAGGFLD=$P(MAGARRAY(AITEM),U,1),MAGGDAT=$P(MAGARRAY(AITEM),U,2,99) + . I MAGGFLD="" S MAGERR="0^A Field Number/Action Code is required: "_" Item: "_MAGARRAY(AITEM) Q + . I MAGGDAT="" S MAGERR="0^A Value is required."_" Item: "_MAGARRAY(AITEM) Q + . I MAGGFLD=5 S DFNFLAG=1 + . ; This inadvertently disallowed Tracking ID's on Group Images. + . ;I MAGGFLD=108 I $D(^MAG(2005,"ATRKID",MAGGDAT)) S MAGERR="0^Tracking ID Must be Unique !" Q + . I MAGGFLD=108 I ($L(MAGGDAT,";")<2) S MAGRY(0)="0^Tracking ID Must have "";"" Delimiter" Q + . ; Check for possible action codes that could be in the array. + . I $$ACTCODE(MAGGFLD) D Q + . . S DAT1=MAGGDAT + . . S Y=$$VALCODE(MAGGFLD,.MAGGDAT) S:'Y MAGERR=Y_" Item: "_MAGARRAY(AITEM) + . . I DAT1'=MAGGDAT S MAGARRAY(AITEM)=MAGGFLD_"^"_MAGGDAT + . ; If we are adding Multiple Images to a Group, they must be Validated. + . ; we could have multiple "2005.04^IENs" in this array. Which means we are + . ; adding existing Images to a New/Existing Group. + . I MAGGFLD=2005.04 D Q ; 2005.04 isn't the field number, #4 is the field number + . . I $G(MAGGDAT,0)=0 Q ;Creating a new Group, with no group entries is the usual way + . . ; to do it. Then make successive calls to ADD, Adding each Image to the + . . ; Object Group multiple of the Group Parent (fld#14) as it is created. + . . I '$D(^MAG(2005,MAGGDAT,0)) S MAGERR="0^Group Object "_MAGGDAT_" doesn't exist"_" Item: "_MAGARRAY(AITEM) + . . ; We can't allow adding an image if it already has a group parent. + . . I $P(^MAG(2005,MAGGDAT,0),U,10) S MAGERR="0^The Image to be added to the Group, already has a Group Parent"_" Item: "_MAGARRAY(AITEM) + . ; if we are getting a WP line of text for Long Desc Field. Can't validate it. + . I MAGGFLD=11 Q ; this is a line of the WP Long Desc field. + . ; NEW CALL TO VALIDATE FILE,FIELD,DATA + . S DAT1=MAGGDAT + . I '$$VALID^MAGGSIV1(2005,MAGGFLD,.MAGGDAT,.MAGRES) S MAGERR="0^"_MAGRES Q + . I DAT1'=MAGGDAT S MAGARRAY(AITEM)=MAGGFLD_"^"_MAGGDAT + . Q + ; + ; if there was an Error in data we'll quit now. + ; If ALL is true, then MAGRY(1...N) will exist if there were errors. + I $O(MAGRY(0)) S MAGRY(0)="0^Errors were found in data." Q + ; If ALL is false, then MAGERR will exist if there was an error. + I $L(MAGERR) S MAGRY(0)=MAGERR Q + ; + ; If all data is valid we get here. + ; Last Test, see if a Patient was in array, + ; (Patient is the only Required field check done in this routine). + I 'DFNFLAG S MAGRY(0)="0^A Patient DFN is required. " Q + S MAGRY(0)="1^Data is Valid." + Q +ACTCODE(CODE) ;Function that returns True (1) if this code is a valid Import API Action Code + ; Patch 8. We're adding 107 as an action code, so it will pass validation even if the entry + ; in the Acquisition Device File doesn't exist; + ; it will be validated in PRE^MAGGSIA1 and a new Acquisition Device entry made if needed. + I ",107,ACQD,IEN,EXT,ABS,JB,WRITE,BIG,DICOMSN,DICOMIN,ACQS,ACQL,STATUSCB,CALLMTH,USERNAME,PASSWORD,DELFLAG,TRNSTYP,"[(","_CODE_",") Q 1 + Q 0 +VALCODE(CODE,VALUE) ; We validate the values for the possible action codes + N MAGY + I VALUE="" Q "0^NO VALUE in Action Code string: """_X_"" + ; Patch 8, added 107 + I ",ACQL,CALLMTH,USERNAME,PASSWORD,"[(","_CODE_",") Q 1 ; NO VALIDATION FOR THESE CODES + D @CODE + Q MAGY + ; Each Tag is a valid Action code +IEN I $D(^MAG(2005,VALUE)) S MAGY=1 + E S MAGY="0^INVALID IMAGE IEN." + Q +EXT ; code will go here to validate the extension type. i.e. we won't let types .exe .bat .com .zip ... etc. + ; Maybe a modification to Object Type file, to have allowable extensions in the file, and a + ; cross reference on a new field EXTENSION. The capture workstation wouldn't have to ask the + ; user for the file type of each file, and we wouldn't get WORD .DOC files that the user called Color Images +ABS ; Meaning: Have the BP create the abstract +JB ; Meaning: Have the BP copy the image to the JukeBox +BIG ; Meaning: There is a big file also, set the Image File field ? to indicate there is a BIG File. + S MAGY=1 + Q +WRITE ; Meaning: This is the Internal Entry (or "PACS") of the WRITE Directory. Images will be written + ; here instead of the default WRITE Directory. + S MAGY=$$DRIVE^MAGGTU1(VALUE) + Q +DICOMSN ;Meaning: DICOM Series Number. This will be entered in the Group Object multiple, field #1 + ;We were validating this as an integer, but it can be anything, no way to validate. + S MAGY=1 + Q +DICOMIN ;Meaning: DICOM Image Number. This will be entered in the Group Object multiple, field #2 + ; We were validating this as an integer, but it can be anything, no way to validate. + S MAGY=1 + Q +DELFLAG ;Meaning: This flag tells the Delphi Import Component to Delete the Image files after successful processing + I ",TRUE,FALSE,0,1,"[(","_$$UPPER(VALUE)_",") S MAGY=1 + E S MAGY="0^INVALID Value " + I VALUE="1" S VALUE="TRUE" + I VALUE="0" S VALUE="FALSE" + Q +TRNSTYP ;Meaning: This flag is for future use, for now it is ignored, defaults to "NEW" + S MAGY=1 + Q +STATUSCB ; Meaning: This is the TAG^RTN that Imaging calls to report the + ; status of the Import. + S MAGY="0^Error validating TAG^RTN: "_VALUE + I '$L($T(@VALUE)) S MAGY="0^Invalid Status CallBack "_VALUE + E S MAGY=1 + Q +ACQS ; We need to make sure the ACQS (Acquisition Site) is a Valid entry in Imaging Site Params. + S VALUE=$P(VALUE,";") ; Stop error, when old OCX sends data. + ; Next Block is for VIC (Maximus) that sends Station Number. + N ERR S ERR=0 + I MAX D Q:ERR + . S X=$O(^DIC(4,"D",VALUE,"")) + . I X="" S MAGY="0^Invalid STATION NUMBER: (ACQS): "_VALUE,ERR=1 Q + . S VALUE=X + . Q + I '$$CONSOLID^MAGBAPI S MAGY=1 Q + ;Patch 20 will have this. + I '$D(^MAG(2006.1,"B",VALUE)) S MAGY="0^Acquisition Site ("_VALUE_") is Not in Site Param File." Q + S MAGY=1 + Q +107 ; 107 and ACQD are the same. Calling 107 falls into validation for ACQD. +ACQD ; 107 and ACQD are ACQUISITION DEVICE FILE (2006.04) pointers or Values. + ; If it is an integer, We assume the value is an IEN and validate it here. + I ((+VALUE)=VALUE),'$D(^MAG(2006.04,VALUE)) S MAGY="0^Invalid IEN ("_VALUE_") for ACQUISITION DEVICE File." Q + ; if it is not an integer, it is either a new/existing entry for 2006.04 Result is Success, + ; and it will be validated in PRE^MAGGSIA1 and added to File 2006.04 if needed. + S MAGY=1 + Q +UPPER(X) ; + Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") + ; +ERR ; ERROR TRAP FOR Import API + N ERR S ERR=$$EC^%ZOSV + S MAGRY(0)="0^ETRAP: "_ERR + D @^%ZOSF("ERRTN") + Q diff --git a/r/IMAGING-MAG-ZMAG/MAGGSIV1.m b/r/IMAGING-MAG-ZMAG/MAGGSIV1.m index f2a538c0..03d42008 100644 --- a/r/IMAGING-MAG-ZMAG/MAGGSIV1.m +++ b/r/IMAGING-MAG-ZMAG/MAGGSIV1.m @@ -1,122 +1,121 @@ -MAGGSIV1 ;WOIFO/GEK - Imaging Validate Data ; [ 08/15/2004 08:57 ] - ;;3.0;IMAGING;**8,20,59**;Nov 27, 2007;Build 20 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q -VALID(MAGF,MAGL,MAGD,MAGRES) ; call to validate value for field in a FM file. - ; Function is boolean. Returns: - ; 0 - Invalid - ; 1 - Valid - ; "" - Error - ; Call this function before you set the FDA Array. - ; MAGD - sent by reference because it could be Internal or External - ; and if it is external and valid, it is changed to Internal. - ; - ; MAGF : File Number - ; MAGL : Field Number - ; MAGD : (sent by reference) data value of field - ; MAGRES: (sent by reference) Result message - ; - N $ETRAP,$ESTACK S $ETRAP="D ERR^"_$T(+0) - N MAGR,MAGMSG,MAGSP,MAGRESA,MAGE,MAGPT - ;if a BAD field number - I '$$VFIELD^DILFD(MAGF,MAGL) D Q 0 - . S MAGRES="The field number: "_MAGL_", in File: "_MAGF_", is invalid." - D FIELD^DID(MAGF,MAGL,"","SPECIFIER","MAGSP") - ; If it is a pointer field - ; If an integer - We assume it is a pointer and validate that and Quit. - ; If not integer - We assume it is external value, proceed to let CHK do validate - I (MAGSP("SPECIFIER")["P"),(+MAGD=MAGD) D Q MAGPT - . I $$EXTERNAL^DILFD(MAGF,MAGL,"",MAGD)'="" S MAGPT=1,MAGRES="Valid pointer" Q - . S MAGPT=0,MAGRES="The value: "_MAGD_" for field: "_MAGL_" in File: "_MAGF_" is an invalid Pointer." - . Q - ; - D CHK^DIE(MAGF,MAGL,"E",MAGD,.MAGR,"MAGMSG") - ; If success, Quit. We changed External to Internal. Internal is in MAGR - I MAGR'="^" S MAGD=MAGR Q 1 - ; If not success Get the error text and Quit 0 - D MSG^DIALOG("A",.MAGRESA,245,5,"MAGMSG") - S MAGRES=MAGRESA(1) - Q 0 -VALINDEX(MAGRY,TYPE,SPEC,PROC) ; Validate the interdependency of Index Terms. - ; MAGRY is the return array - ; MAGRY(0)="1^Okay" or "0^error message" - ; MAGRY(1..n) Information about the Type,Spec and Proc - ; - ; Validate the Procedure/Event <-> Specialty/SubSpecialty interdependency - ; Assure the TYPE is a Clinical TYPE. - ; Assure all are Active. - N CLS,RES,ARR,TYX,PRX,SPX,OK - K MAGRY - S TYPE=$G(TYPE),PROC=$G(PROC),SPEC=$G(SPEC) - I TYPE=0 S TYPE="" - I PROC=0 S PROC="" - I SPEC=0 S SPEC="" - I ((PROC]"")!(SPEC]"")) I TYPE="" S MAGRY(0)="0^Type is required." Q 0 - ; TYPE is required, but not enforcing yet. All vendors are not sending - ; index values. - ; VALID will accept External or Internal and return Internal if Valid - I $L(TYPE) I '$$VALID(2005,42,.TYPE,.RES) S MAGRY(0)="0^"_RES Q 0 - I $L(PROC) I '$$VALID(2005,43,.PROC,.RES) S MAGRY(0)="0^"_RES Q 0 - I $L(SPEC) I '$$VALID(2005,44,.SPEC,.RES) S MAGRY(0)="0^"_RES Q 0 - ; - I TYPE D I 'OK S MAGRY(0)=OK Q 0 - . S OK=1,TYX=TYPE_"," - . K ARR D GETS^DIQ(2005.83,TYX,".01;1;2","EI","ARR") - . S MAGRY(1)="Type - Class : "_ARR(2005.83,TYX,.01,"E")_" - "_ARR(2005.83,TYX,1,"E") - . I $L(ARR(2005.83,TYX,2,"E")) S MAGRY(1)=MAGRY(1)_" - "_ARR(2005.83,TYX,2,"E") - . I ARR(2005.83,TYX,2,"I")="I" S OK="0^Type is Inactive" - . Q - ; - I SPEC D I 'OK S MAGRY(0)=OK Q 0 - . S OK=1,SPX=SPEC_"," - . K ARR D GETS^DIQ(2005.84,SPX,".01;2;4","EI","ARR") - . S MAGRY(2)="Specialty/SubSpecialty: "_ARR(2005.84,SPX,.01,"E") - . I $L(ARR(2005.84,SPX,4,"E")) S MAGRY(2)=MAGRY(2)_" - "_ARR(2005.84,SPX,4,"E") - . I $L(ARR(2005.84,SPX,2,"E")) S MAGRY(2)=MAGRY(2)_" <"_ARR(2005.84,SPX,2,"E")_">" - . I ARR(2005.84,SPX,4,"I")="I" S OK="0^Specialty is Inactive" - . Q - ; - I PROC D I 'OK S MAGRY(0)=OK Q 0 - . S OK=1,PRX=PROC_"," - . K ARR D GETS^DIQ(2005.85,PRX,".01;4","EI","ARR") - . S MAGRY(4)="Procedure/Event : "_$$GET1^DIQ(2005.85,PROC,.01) - . I $L(ARR(2005.85,PRX,4,"E")) S MAGRY(4)=MAGRY(4)_" - "_ARR(2005.85,PRX,4,"E") - . I ARR(2005.85,PRX,4,"I")="I" S OK="0^Procedure is Inactive" - . Q - ; - ; If PROC and SPEC are "", then Quit, any TYPE by itself is valid - I (PROC=""),(SPEC="") S MAGRY(0)="1^Okay" Q 1 - ; Here, TYPE has to be Clin. - S CLS=$$GET1^DIQ(2005.83,TYPE,1,"","MAGTAR") I $E(CLS,1,5)="ADMIN" D Q 0 - . S MAGRY(0)="0^The Type Index is Administrative, it has to be Clinical." - I (PROC="")!(SPEC="") S MAGRY(0)="1^Okay" Q 1 - ; we get here, we have to validate the interdependency of SPEC <-> PROC. - I '$O(^MAG(2005.85,PROC,1,0)) S MAGRY(0)="1^Okay" Q 1 - I '$D(^MAG(2005.85,PROC,1,"B",SPEC)) D Q 0 - . S MAGRY(0)="0^Invalid Association between Spec/SubSpec and Proc/Event" - . Q - S MAGRY(0)="1^Okay" - Q 1 -ERR ; - N ERR - S ERR=$$EC^%ZOSV - S MAGRES="0^Error during data validation: "_ERR - D LOGERR^MAGGTERR(ERR) - D @^%ZOSF("ERRTN") - D CLEAN^DILF - Q +MAGGSIV1 ;WOIFO/GEK - Imaging Validate Data ; [ 08/15/2004 08:57 ] + ;;3.0;IMAGING;**8,20**;Apr 12, 2006 + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q +VALID(MAGF,MAGL,MAGD,MAGRES) ; call to validate value for field in a FM file. + ; Function is boolean. Returns: + ; 0 - Invalid + ; 1 - Valid + ; "" - Error + ; Call this function before you set the FDA Array. + ; MAGD - sent by reference because it could be Internal or External + ; and if it is external and valid, it is changed to Internal. + ; + ; MAGF : File Number + ; MAGL : Field Number + ; MAGD : (sent by reference) data value of field + ; MAGRES: (sent by reference) Result message + ; + N $ETRAP,$ESTACK S $ETRAP="D ERR^"_$T(+0) + N MAGR,MAGMSG,MAGSP,MAGRESA,MAGE,MAGPT + ;if a BAD field number + I '$$VFIELD^DILFD(MAGF,MAGL) D Q 0 + . S MAGRES="The field number: "_MAGL_", in File: "_MAGF_", is invalid." + D FIELD^DID(MAGF,MAGL,"","SPECIFIER","MAGSP") + ; If it is a pointer field + ; If an integer - We assume it is a pointer and validate that and Quit. + ; If not integer - We assume it is external value, proceed to let CHK do validate + I (MAGSP("SPECIFIER")["P"),(+MAGD=MAGD) D Q MAGPT + . I $$EXTERNAL^DILFD(MAGF,MAGL,"",MAGD)'="" S MAGPT=1,MAGRES="Valid pointer" Q + . S MAGPT=0,MAGRES="The value: "_MAGD_" for field: "_MAGL_" in File: "_MAGF_" is an invalid Pointer." + . Q + ; + D CHK^DIE(MAGF,MAGL,"E",MAGD,.MAGR,"MAGMSG") + ; If success, Quit. We changed External to Internal. Internal is in MAGR + I MAGR'="^" S MAGD=MAGR Q 1 + ; If not success Get the error text and Quit 0 + D MSG^DIALOG("A",.MAGRESA,245,5,"MAGMSG") + S MAGRES=MAGRESA(1) + Q 0 +VALINDEX(MAGRY,TYPE,SPEC,PROC) ; Validate the interdependency of Index Terms. + ; MAGRY is the return array + ; MAGRY(0)="1^Okay" or "0^error message" + ; MAGRY(1..n) Information about the Type,Spec and Proc + ; + ; Validate the Procedure/Event <-> Specialty/SubSpecialty interdependency + ; Assure the TYPE is a Clinical TYPE. + ; Assure all are Active. + N CLS,RES,ARR,TYX,PRX,SPX,OK + K MAGRY + S TYPE=$G(TYPE),PROC=$G(PROC),SPEC=$G(SPEC) + I TYPE=0 S TYPE="" + I PROC=0 S PROC="" + I SPEC=0 S SPEC="" + I ((PROC]"")!(SPEC]"")) I TYPE="" S MAGRY(0)="0^Type is required." Q 0 + ; TYPE is required, but not enforcing yet. All vendors are not sending + ; index values. + ; VALID will accept External or Internal and return Internal if Valid + I $L(TYPE) I '$$VALID(2005,42,.TYPE,.RES) S MAGRY(0)="0^"_RES Q 0 + I $L(PROC) I '$$VALID(2005,43,.PROC,.RES) S MAGRY(0)="0^"_RES Q 0 + I $L(SPEC) I '$$VALID(2005,44,.SPEC,.RES) S MAGRY(0)="0^"_RES Q 0 + ; + I TYPE D I 'OK S MAGRY(0)=OK Q 0 + . S OK=1,TYX=TYPE_"," + . K ARR D GETS^DIQ(2005.83,TYX,".01;1;2","EI","ARR") + . S MAGRY(1)="Type - Class : "_ARR(2005.83,TYX,.01,"E")_" - "_ARR(2005.83,TYX,1,"E") + . I $L(ARR(2005.83,TYX,2,"E")) S MAGRY(1)=MAGRY(1)_" - "_ARR(2005.83,TYX,2,"E") + . I ARR(2005.83,TYX,2,"I")="I" S OK="0^Type is Inactive" + . Q + ; + I SPEC D I 'OK S MAGRY(0)=OK Q 0 + . S OK=1,SPX=SPEC_"," + . K ARR D GETS^DIQ(2005.84,SPX,".01;2;4","EI","ARR") + . S MAGRY(2)="Specialty/SubSpecialty: "_ARR(2005.84,SPX,.01,"E") + . I $L(ARR(2005.84,SPX,4,"E")) S MAGRY(2)=MAGRY(2)_" - "_ARR(2005.84,SPX,4,"E") + . I $L(ARR(2005.84,SPX,2,"E")) S MAGRY(2)=MAGRY(2)_" <"_ARR(2005.84,SPX,2,"E")_">" + . I ARR(2005.84,SPX,4,"I")="I" S OK="0^Specialty is Inactive" + . Q + ; + I PROC D I 'OK S MAGRY(0)=OK Q 0 + . S OK=1,PRX=PROC_"," + . K ARR D GETS^DIQ(2005.85,PRX,".01;4","EI","ARR") + . S MAGRY(4)="Procedure/Event : "_$$GET1^DIQ(2005.85,PROC,.01) + . I $L(ARR(2005.85,PRX,4,"E")) S MAGRY(4)=MAGRY(4)_" - "_ARR(2005.85,PRX,4,"E") + . I ARR(2005.85,PRX,4,"I")="I" S OK="0^Procedure is Inactive" + . Q + ; + ; If PROC and SPEC are "", then Quit, any TYPE by itself is valid + I (PROC=""),(SPEC="") S MAGRY(0)="1^Okay" Q 1 + ; Here, TYPE has to be Clin. + S CLS=$$GET1^DIQ(2005.83,TYPE,1,"","MAGTAR") I $E(CLS,1,5)="ADMIN" D Q 0 + . S MAGRY(0)="0^The Type Index is Administrative, it has to be Clinical." + I (PROC="")!(SPEC="") S MAGRY(0)="1^Okay" Q 1 + ; we get here, we have to validate the interdependency of SPEC <-> PROC. + I '$O(^MAG(2005.85,PROC,1,0)) S MAGRY(0)="1^Okay" Q 1 + I '$D(^MAG(2005.85,PROC,1,"B",SPEC)) D Q 0 + . S MAGRY(0)="0^Invalid Association between Spec/SubSpec and Proc/Event" + . Q + S MAGRY(0)="1^Okay" + Q 1 +ERR ; + N ERR + S ERR=$$EC^%ZOSV + S MAGRES="0^Error during data validation: "_ERR + D LOGERR^MAGGTERR(ERR) + D @^%ZOSF("ERRTN") + D CLEAN^DILF + Q diff --git a/r/IMAGING-MAG-ZMAG/MAGGTAU.m b/r/IMAGING-MAG-ZMAG/MAGGTAU.m index 10faf34f..9ca116ef 100644 --- a/r/IMAGING-MAG-ZMAG/MAGGTAU.m +++ b/r/IMAGING-MAG-ZMAG/MAGGTAU.m @@ -1,230 +1,227 @@ -MAGGTAU ;WOIFO/GEK - RPC Calls to Update the Imaging Windows Workstation file ; [ 03/25/2001 11:20 ] - ;;3.0;IMAGING;**7,16,8,59**;Nov 27, 2007;Build 20 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed | - ;; | in any way. Modifications to this software may result in an | - ;; | adulterated medical device under 21CFR820, the use of which | - ;; | is considered to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q -UPD(MAGRY,DATA) ;RPC [MAGG WRKS UPDATES] - ; Called after User login. Local and RIV. - ; Updates information in the IMAGING WINDOWS WORKSTATION - ; - ; DATA is '^' delimited piece - ; 1 Workstation name 2 Date/Time of capture app. - ; 3 Date/Time of Display App. - ; 4 Location of workstation 5 Date/Time of MAGSETUP - ; 6 Version of Display 7 Version of Capture - ; 8 1=Normal startup 2=Started by CPRS 3=Import API - ; 9 OS Version 10 VistaRad Version - ; 11 RPCBroker Server 12 RPCBroker Port - N X,Y,Z - N MAGNAME,MAGCDT,MAGDDT,MAG0,MAGLOC,MAGIEN,MAGSETUP,MAGSTART,MAGSRV - N MAGVERSD,MAGVERSC,MAGMODE,MAGOSVER,MAGVERVR,MAGPL,MAGVERX - K MAGGFDA,MAGXERR,MAGXIEN - S MAGNAME=$P(DATA,U,1) - S MAGCDT=$P(DATA,U,2) - S MAGDDT=$P(DATA,U,3) - S MAGLOC=$P(DATA,U,4) - S MAGSETUP=$P(DATA,U,5) - S MAGVERSD=$P(DATA,U,6) - I MAGVERSD S MAGJOB("DISPLAY")="" - S MAGVERSC=$P(DATA,U,7) - I MAGVERSC S MAGJOB("CAPTURE")="" - S MAGMODE=$P(DATA,U,8) - S MAGOSVER=$P(DATA,U,9) - S MAGVERVR=$P(DATA,U,10) - I $P(DATA,U,11)]"" S MAGJOB("RPCSERVER")=$P(DATA,U,11) - I $P(DATA,U,12)]"" S MAGJOB("RPCPORT")=$P(DATA,U,12) - S MAGIEN=0 - I $L(MAGNAME) S MAGIEN=$O(^MAG(2006.81,"B",MAGNAME,"")) - I 'MAGIEN D NEWWRKS(MAGNAME,MAGLOC,.MAGIEN) - I MAGIEN<1 S MAGRY="0^Workstation Not on file" Q - ; - S %DT="T",X=MAGCDT D ^%DT S MAGCDT=Y - S %DT="T",X=MAGDDT D ^%DT S MAGDDT=Y - S %DT="T",X=MAGSETUP D ^%DT S MAGSETUP=Y - S MAG0=^MAG(2006.81,MAGIEN,0) ; '0' node for use later. - L +^MAG(2006.81,"LOCK",MAGIEN):0 - S MAGIEN=+MAGIEN_"," - S MAGGFDA(2006.81,MAGIEN,.01)=MAGNAME ; Computer Name - I MAGCDT>-1 S MAGGFDA(2006.81,MAGIEN,4)=MAGCDT ;TELE19N.EXE dttm - I MAGDDT>-1 S MAGGFDA(2006.81,MAGIEN,5)=MAGDDT ;IMGVWP10.EXE dttm - I MAGSETUP>-1 S MAGGFDA(2006.81,MAGIEN,7)=MAGSETUP ; MAGSETUP.EXE dttm - S MAGGFDA(2006.81,MAGIEN,8)=1 ; Active or not. - S MAGGFDA(2006.81,MAGIEN,6)=MAGLOC ; location free text from .INI - S MAGGFDA(2006.81,MAGIEN,3)="@" ; delete logoff time for this job. - S MAGGFDA(2006.81,MAGIEN,10)="@" ; delete session pointer - S MAGGFDA(2006.81,MAGIEN,11)="@" ; reset the session error count. - S MAGGFDA(2006.81,MAGIEN,9)=MAGVERSD ; IMGVWP10.EXE Version Info - S MAGGFDA(2006.81,MAGIEN,9.5)=MAGVERSC ; TELE19N.EXE Version Info - S MAGGFDA(2006.81,MAGIEN,9.7)=MAGVERVR ; VistARad.EXE Version Info - S MAGGFDA(2006.81,MAGIEN,13)=MAGOSVER ; Operating System Version. - ; - S X=$P(MAG0,U,12) - S MAGGFDA(2006.81,MAGIEN,12)=X+1 ; Sess count for wrks. - ; Keep PLACE that this wrks logged in. - S MAGPL=0 I $D(DUZ(2)) S MAGPL=+$$PLACE^MAGBAPI(DUZ(2)) ; DBI - I MAGPL S MAGGFDA(2006.81,MAGIEN,.04)=MAGPL ; DBI - ; - S X=$$NOW^XLFDT - S MAGSTART=$E(X,1,12) - I $G(DUZ) D - . S MAGGFDA(2006.81,MAGIEN,1)=DUZ - . S MAGGFDA(2006.81,MAGIEN,2)=MAGSTART - ; - D UPDATE^DIE("S","MAGGFDA","MAGXIEN","MAGXERR") - I $D(DIERR) D RTRNERR(.MAGRY) Q - ; The MAGJOB( array is used by Imaging routines that are - ; called from the Delphi App. - ; - ; 3.0.8 Whatever App calls this, we'll use that Version number. - S MAGVERX=$S(MAGVERSD]"":MAGVERSD,MAGVERSC]"":MAGVERSC,MAGVERVR]"":MAGVERVR,1:0) - S MAGJOB("WRKSIEN")=+MAGIEN - S MAGJOB("VERSION")=MAGVERX - S MAGRY="1^" - ; - ; SESSION : Create new session entry - D GETS^DIQ(200,DUZ_",","29","I","Z","") ; service/section - S MAGSRV=$G(Z(200,DUZ_",",29,"I")) - ; - K MAGGFDA,MAGXERR,MAGXIEN - S MAGGFDA(2006.82,"+1,",.01)=$P(^VA(200,DUZ,0),U,1) ; User - S MAGGFDA(2006.82,"+1,",1)=DUZ ; USER - S MAGGFDA(2006.82,"+1,",2)=MAGSTART ; Sess Start Time - S MAGGFDA(2006.82,"+1,",4)=+MAGIEN ; Wrks - S MAGGFDA(2006.82,"+1,",7)=+MAGSRV ; User's Service/Section - S MAGGFDA(2006.82,"+1,",13)=MAGMODE ; 1=normal 2= started by CPRS - ; DBI - save the logon PLACE in the Session file. - I MAGPL S MAGGFDA(2006.82,"+1,",.04)=MAGPL ; User's Institution (Imaging site param entry) - ; - ;3.0.8 new fields 9 Client Ver, 9.2 Host Version, 9.4 OS Version - S MAGGFDA(2006.82,"+1,",9)=MAGVERX ; - S MAGGFDA(2006.82,"+1,",9.2)=$$VERSION^XPDUTL("IMAGING") ; - S MAGGFDA(2006.82,"+1,",9.4)=MAGOSVER ; - ; - D UPDATE^DIE("","MAGGFDA","MAGXIEN","MAGXERR") - I $D(DIERR) D RTRNERR(.MAGRY) Q - S MAGRY="1^" - I '+MAGXIEN(1) S MAGRY="0^" Q - S MAGJOB("SESSION")=+MAGXIEN(1) - S MAGRY=MAGJOB("SESSION")_"^Session # "_MAGJOB("SESSION")_" Started." - S MAGGFDA(2006.81,+MAGIEN_",",10)=+MAGXIEN(1) - D UPDATE^DIE("","MAGGFDA","MAGXIEN","MAGXERR") - D ACTION("LOGON^") - Q -LOGACT(MAGRY,ACTION) ;RPC [MAG3 LOGACTION] - ; Call to log actions for Imaging Session from - ; Delphi interface - D ACTION(ACTION) - S MAGRY="1^Action Logged" - Q -ACTION(TXT,LOGTM,MAGSESS) ;Call to log actions for Imaging Workstation Session from other M routines - ; ACTIONS LOGGED - ; LOGON - Session StartTime LOGOFF - Session End Time - ; IMG - Image accessed PAT - Patient Accessed - ; CAP - Image Captured - ; DEL - Image Deleted MOD - Image entry modified - ; IMPORT - Import API has been called - ; Data - a node of data passed to Import API - ; Result - a node of the Result Array from Import API Processing. - ; Image - one of the Images (full path of import directory) that was imported. - ; PPACT - A Post processing Action has been processed. - ; VR-VW - VistaRad Exam displayed - ; VR-INT - VistaRad Exam interpreted - ; API - parameters sent to CP API, and the API Call i.e. ITIU-MDAPI - ; DFTINDX- If the index fields have no values, call to Patch 17 code to - ; generate the values for the fields. - ; MOD - This was intended to log Modifications to Image Entries, it is - ; (for now) only called when a group entry has an image added to its multiple. - ; - ; TXT is "^" delimited string - ; $P(1) is code ( see above ) $P(2) is DFN - ; $P(3) is Image IEN $P(4) reserved for procedure - ; $P(5) reserved for time-stamp $P(6) is Vrad Image Count - ; $P(7) is Vrad Patient Count - ; $P(8) is Vrad User Type (1/0 = Rad/Non-Rad) - ; $P(9) is Vrad REMOTE Read flag (1/0; 1=REMOTE) - ; $P(TXT,"$$",2) is Tracking ID from an Imported Image. From this we compute Session #, to log actions. - ; LOGTM - [1|0] Flag to indicate whether or not to log the time of the Action. Default = 0 - ; MAGSESS - Session IEN where the action should be logged. Default to MAGJOB("SESSION") - ; - N NODE,SESSIEN,MAGGFDA,MAGXERR,MAGXIEN,MAGPROC,LOGX,TRKID - S LOGTM=$G(LOGTM) - I TXT["$$" S TRKID=$P(TXT,"$$",2),TXT=$P(TXT,"$$",1) - S SESSIEN=$S($G(MAGSESS):MAGSESS,$D(MAGJOB("SESSION")):MAGJOB("SESSION"),$G(TRKID)'="":$O(^MAG(2006.82,"E",TRKID,""),-1),1:0) - I 'SESSIEN Q - S NODE="+1,"_SESSIEN_"," - I $P(TXT,U,3) S MAGPROC=$P($G(^MAG(2005,$P(TXT,U,3),0)),U,8) - ; - I $P(TXT,U)="PAT" D - . S Z=+$G(^MAG(2006.82,SESSIEN,1))+1 - . S MAGGFDA(2006.82,SESSIEN_",",10)=Z - I $P(TXT,U)="IMG" D - . S Z=+$P($G(^MAG(2006.82,SESSIEN,1)),U,2)+1 - . S MAGGFDA(2006.82,SESSIEN_",",11)=Z - . D ENTRY^MAGLOG("IMGVW",DUZ,$P(TXT,"^",3),"Wrks",$P(TXT,"^",2),"1") - . D ACCESS^MAGLOG($P(TXT,"^",3)) - I $E(TXT,1,3)="CAP" D - . S Z=+$P($G(^MAG(2006.82,SESSIEN,1)),U,3)+1 - . S MAGGFDA(2006.82,SESSIEN_",",12)=Z - . D ENTRY^MAGLOG("CAP",DUZ,$P(TXT,"^",3),"Wrks",$P(TXT,"^",2),"1") - I $P(TXT,U,2) D - . S MAGGFDA(2006.82,SESSIEN_",",5)=$P(TXT,U,2) - I LOGTM D - . S X=$$NOW^XLFDT - . S $P(TXT,U,4)=$G(MAGPROC),$P(TXT,U,5)=$E(X,1,12) - S MAGGFDA(2006.821,NODE,.01)=$P(TXT,"|",1) - I $L(TXT,"|")>1 S MAGGFDA(2006.821,NODE,13)=$P(TXT,"|",2,99) - D UPDATE^DIE("S","MAGGFDA","MAGXIEN","MAGXERR") - Q -NEWWRKS(MAGNAME,MAGLOC,MAGIEN) ; - I $G(MAGNAME)="" Q - N Y,MAGNFDA,MAGNIEN - S MAGNFDA(2006.81,"+1,",.01)=MAGNAME - S MAGNFDA(2006.81,"+1,",6)=$G(MAGLOC) - D UPDATE^DIE("","MAGNFDA","MAGNIEN") - S MAGIEN=MAGNIEN(1) - Q -LOGOFF(MAGRY) ;RPC [MAGG LOGOFF] Call when session is over. - ; This updates session file with logoff time - ; and marks the session closed. - ; - S MAGRY=1 - N MAGGFDA,MAGXERR,MAGXIEN,MAGIEN,MAGSESS,MAGEND,MAGCON - ; The Imaging Workstation file keeps time of login - ; We'll enter the logoff time ($$now^xlfdt) here. - S X=$$NOW^XLFDT - S MAGEND=$E(X,1,12) - Q:'+$G(MAGJOB("WRKSIEN")) - L -^MAG(2006.81,"LOCK",MAGJOB("WRKSIEN")) - S MAGIEN=+MAGJOB("WRKSIEN")_"," - S MAGGFDA(2006.81,MAGIEN,3)=MAGEND ; logoff dttm - S MAGGFDA(2006.81,MAGIEN,8)=0 ; Set job number to 0 - D UPDATE^DIE("S","MAGGFDA","MAGXIEN","MAGXERR") - ;MAGJOB("WRKSIEN") - Q:(+$G(MAGJOB("SESSION"))=0) - S MAGSESS=+MAGJOB("SESSION")_"," - K MAGGFDA,MAGXERR,MAGXIEN - S MAGGFDA(2006.82,MAGSESS,3)=MAGEND - ; calculate the length of the session - S MAGCON="" - S MAGGFDA(2006.82,MAGSESS,14)=MAGCON - D UPDATE^DIE("S","MAGGFDA","MAGXIEN","MAGXERR") - D ACTION("LOGOFF^") - ; - Q -RTRNERR(ETXT) ; There was error from UPDATE^DIE quit with error text - S ETXT="0^ERROR "_MAGXERR("DIERR",1,"TEXT",1) - Q +MAGGTAU ;WOIFO/GEK - RPC Calls to Update the Imaging Windows Workstation file ; [ 03/25/2001 11:20 ] + ;;3.0;IMAGING;**7,16,8**;Sep 15, 2004 + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed | + ;; | in any way. Modifications to this software may result in an | + ;; | adulterated medical device under 21CFR820, the use of which | + ;; | is considered to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q +UPD(MAGRY,DATA) ;RPC [MAGG WRKS UPDATES] + ; Call from workstation updating it's exe's Date/Time + ; and other Workstation information into IMAGING WINDOWS WORKSTATION + ; at logon of user. + ; + ; DATA is '^' delimited piece + ; 1 Workstation name 2 Date/Time of capture app. + ; 3 Date/Time of Display App. + ; 4 Location of worksation 5 Date/Time of MAGSETUP + ; 6 Version of Display 7 Version of Capture + ; 8 1=Normal startup 2=Started by CPRS 3=Import API + ; 9 OS Version 10 VistaRad Version + N X,Y,Z + N MAGNAME,MAGCDT,MAGDDT,MAG0,MAGLOC,MAGIEN,MAGSETUP,MAGSTART,MAGSRV + N MAGVERSD,MAGVERSC,MAGMODE,MAGOSVER,MAGVERVR,MAGPL,MAGVERX + K MAGGFDA,MAGXERR,MAGXIEN + S MAGNAME=$P(DATA,U,1) + S MAGCDT=$P(DATA,U,2) + S MAGDDT=$P(DATA,U,3) + S MAGLOC=$P(DATA,U,4) + S MAGSETUP=$P(DATA,U,5) + S MAGVERSD=$P(DATA,U,6) + S MAGVERSC=$P(DATA,U,7) + S MAGMODE=$P(DATA,U,8) + S MAGOSVER=$P(DATA,U,9) + S MAGVERVR=$P(DATA,U,10) + S MAGIEN=0 + I $L(MAGNAME) S MAGIEN=$O(^MAG(2006.81,"B",MAGNAME,"")) + I 'MAGIEN D NEWWRKS(MAGNAME,MAGLOC,.MAGIEN) + I MAGIEN<1 S MAGRY="0^Workstation Not on file" Q + ; + S %DT="T",X=MAGCDT D ^%DT S MAGCDT=Y + S %DT="T",X=MAGDDT D ^%DT S MAGDDT=Y + S %DT="T",X=MAGSETUP D ^%DT S MAGSETUP=Y + S MAG0=^MAG(2006.81,MAGIEN,0) ; '0' node for use later. + L +^MAG(2006.81,"LOCK",MAGIEN):0 + S MAGIEN=+MAGIEN_"," + S MAGGFDA(2006.81,MAGIEN,.01)=MAGNAME ; Compter Name + I MAGCDT>-1 S MAGGFDA(2006.81,MAGIEN,4)=MAGCDT ;TELE19N.EXE dttm + I MAGDDT>-1 S MAGGFDA(2006.81,MAGIEN,5)=MAGDDT ;IMGVWP10.EXE dttm + I MAGSETUP>-1 S MAGGFDA(2006.81,MAGIEN,7)=MAGSETUP ; MAGSETUP.EXE dttm + S MAGGFDA(2006.81,MAGIEN,8)=1 ; Active or not. + S MAGGFDA(2006.81,MAGIEN,6)=MAGLOC ; location free text from .INI + S MAGGFDA(2006.81,MAGIEN,3)="@" ; delete logff time for this job. + S MAGGFDA(2006.81,MAGIEN,10)="@" ; delete session pointer + S MAGGFDA(2006.81,MAGIEN,11)="@" ; reset the session error count. + S MAGGFDA(2006.81,MAGIEN,9)=MAGVERSD ; IMGVWP10.EXE Version Info + S MAGGFDA(2006.81,MAGIEN,9.5)=MAGVERSC ; TELE19N.EXE Version Info + S MAGGFDA(2006.81,MAGIEN,9.7)=MAGVERVR ; VistARad.EXE Version Info + S MAGGFDA(2006.81,MAGIEN,13)=MAGOSVER ; Operating System Version. + ; + S X=$P(MAG0,U,12) + S MAGGFDA(2006.81,MAGIEN,12)=X+1 ; Sess count for wrks. + ; Keep the last PLACE that this wrks logged in. + S MAGPL=0 I $D(DUZ(2)) S MAGPL=+$$PLACE^MAGBAPI(DUZ(2)) ; DBI + I MAGPL S MAGGFDA(2006.81,MAGIEN,.04)=MAGPL ; DBI + ; + S X=$$NOW^XLFDT + S MAGSTART=$E(X,1,12) + I $G(DUZ) D + . S MAGGFDA(2006.81,MAGIEN,1)=DUZ + . S MAGGFDA(2006.81,MAGIEN,2)=MAGSTART + ; + D UPDATE^DIE("S","MAGGFDA","MAGXIEN","MAGXERR") + I $D(DIERR) D RTRNERR(.MAGRY) Q + ; The " MAGJOB(" array is used by Imaging routines that are + ; called from the Delphi App. + ; We use nodes of the Array MAGJ0B to organize the shared partition variables. + ; + ; 3.O.8 Whatever App calls this, we'll use that Version number. + S MAGVERX=$S(MAGVERSD]"":MAGVERSD,MAGVERSC]"":MAGVERSC,MAGVERVR]"":MAGVERVR,1:0) + S MAGJOB("WRKSIEN")=+MAGIEN + S MAGJOB("VERSION")=MAGVERX + S MAGRY="1^" + ; + ; SESSION : Now we create new session entry + D GETS^DIQ(200,DUZ_",","29","I","Z","") ; service/section + S MAGSRV=$G(Z(200,DUZ_",",29,"I")) + ; + K MAGGFDA,MAGXERR,MAGXIEN + S MAGGFDA(2006.82,"+1,",.01)=$P(^VA(200,DUZ,0),U,1) ; User + S MAGGFDA(2006.82,"+1,",1)=DUZ ; USER + S MAGGFDA(2006.82,"+1,",2)=MAGSTART ; Sess Start Time + S MAGGFDA(2006.82,"+1,",4)=+MAGIEN ; Wrks + S MAGGFDA(2006.82,"+1,",7)=+MAGSRV ; User's Service/Section + S MAGGFDA(2006.82,"+1,",13)=MAGMODE ; 1=normal 2= started by CPRS + ; DBI - save the logon PLACE in the Session file. + I MAGPL S MAGGFDA(2006.82,"+1,",.04)=MAGPL ; User's Institution (Imaging site param entry) + ; + ;3.0.8 new fields 9 Client Ver, 9.2 Host Version, 9.4 OS Version + S MAGGFDA(2006.82,"+1,",9)=MAGVERX ; + S MAGGFDA(2006.82,"+1,",9.2)=$$VERSION^XPDUTL("IMAGING") ; + S MAGGFDA(2006.82,"+1,",9.4)=MAGOSVER ; + ; + D UPDATE^DIE("","MAGGFDA","MAGXIEN","MAGXERR") + I $D(DIERR) D RTRNERR(.MAGRY) Q + S MAGRY="1^" + I '+MAGXIEN(1) S MAGRY="0^" Q + S MAGJOB("SESSION")=+MAGXIEN(1) + S MAGRY=MAGJOB("SESSION")_"^Session # "_MAGJOB("SESSION")_" Started." + S MAGGFDA(2006.81,+MAGIEN_",",10)=+MAGXIEN(1) + D UPDATE^DIE("","MAGGFDA","MAGXIEN","MAGXERR") + D ACTION("LOGON^") + Q +LOGACT(MAGRY,ACTION) ;RPC [MAG3 LOGACTION] + ; Call to log actions for Imaging Session from + ; Delphi interface + D ACTION(ACTION) + S MAGRY="1^Action Logged" + Q +ACTION(TXT,LOGTM,MAGSESS) ;Call to log actions for Imaging Workstation Session from other M routines + ; ACTIONS LOGGED + ; LOGON - Session StartTime LOGOFF - Session End Time + ; IMG - Image accessed PAT - Patient Accessed + ; CAP - Image Captured + ; DEL - Image Deleted MOD - Image entry modified + ; IMPORT - Import API has been called + ; Data - a node of data passed to Import API + ; Result - a node of the Result Array from Import API Processing. + ; Image - one of the Images (full path of import directory) that was imported. + ; PPACT - A Post processing Action has been processed. + ; VR-VW - VistaRad Exam displayed + ; VR-INT - VistaRad Exam interpreted + ; API - parameters sent to CP API, and the API Call i.e. ITIU-MDAPI + ; DFTINDX- If the index fields have no values, call to Patch 17 code to + ; generate the values for the fields. + ; MOD - This was intended to log Modifications to Image Entries, it is + ; (for now) only called when a group entry has an image added to its multiple. + ; + ; TXT is "^" delimited string + ; $P(1) is code ( see above ) $P(2) is DFN + ; $P(3) is Image IEN $P(4) reserved for procedure + ; $P(5) reserved for time-stamp $P(6) is Vrad Image Count + ; $P(7) is Vrad Patient Count + ; $P(8) is Vrad User Type (1/0 = Rad/Non-Rad) + ; $P(9) is Vrad REMOTE Read flag (1/0; 1=REMOTE) + ; $P(TXT,"$$",2) is Tracking ID from an Imported Image. From this we compute Session #, to log actions. + ; LOGTM - [1|0] Flag to indicate wheter or not to log the time of the Action. Default = 0 + ; MAGSESS - Session IEN where the action should be logged. Default to MAGJOB("SESSION") + ; + N NODE,SESSIEN,MAGGFDA,MAGXERR,MAGXIEN,MAGPROC,LOGX,TRKID + S LOGTM=$G(LOGTM) + I TXT["$$" S TRKID=$P(TXT,"$$",2),TXT=$P(TXT,"$$",1) + S SESSIEN=$S($G(MAGSESS):MAGSESS,$D(MAGJOB("SESSION")):MAGJOB("SESSION"),$G(TRKID)'="":$O(^MAG(2006.82,"E",TRKID,""),-1),1:0) + I 'SESSIEN Q + S NODE="+1,"_SESSIEN_"," + I $P(TXT,U,3) S MAGPROC=$P($G(^MAG(2005,$P(TXT,U,3),0)),U,8) + ; + I $P(TXT,U)="PAT" D + . S Z=+$G(^MAG(2006.82,SESSIEN,1))+1 + . S MAGGFDA(2006.82,SESSIEN_",",10)=Z + I $P(TXT,U)="IMG" D + . S Z=+$P($G(^MAG(2006.82,SESSIEN,1)),U,2)+1 + . S MAGGFDA(2006.82,SESSIEN_",",11)=Z + . D ENTRY^MAGLOG("IMGVW",DUZ,$P(TXT,"^",3),"Wrks",$P(TXT,"^",2),"1") + . D ACCESS^MAGLOG($P(TXT,"^",3)) + I $E(TXT,1,3)="CAP" D + . S Z=+$P($G(^MAG(2006.82,SESSIEN,1)),U,3)+1 + . S MAGGFDA(2006.82,SESSIEN_",",12)=Z + . D ENTRY^MAGLOG("CAP",DUZ,$P(TXT,"^",3),"Wrks",$P(TXT,"^",2),"1") + I $P(TXT,U,2) D + . S MAGGFDA(2006.82,SESSIEN_",",5)=$P(TXT,U,2) + I LOGTM D + . S X=$$NOW^XLFDT + . S $P(TXT,U,4)=$G(MAGPROC),$P(TXT,U,5)=$E(X,1,12) + S MAGGFDA(2006.821,NODE,.01)=$P(TXT,"|",1) + I $L(TXT,"|")>1 S MAGGFDA(2006.821,NODE,13)=$P(TXT,"|",2,99) + D UPDATE^DIE("S","MAGGFDA","MAGXIEN","MAGXERR") + Q +NEWWRKS(MAGNAME,MAGLOC,MAGIEN) ; + I $G(MAGNAME)="" Q + N Y,MAGNFDA,MAGNIEN + S MAGNFDA(2006.81,"+1,",.01)=MAGNAME + S MAGNFDA(2006.81,"+1,",6)=$G(MAGLOC) + D UPDATE^DIE("","MAGNFDA","MAGNIEN") + S MAGIEN=MAGNIEN(1) + Q +LOGOFF(MAGRY) ;RPC [MAGG LOGOFF] Call when session is over. + ; This updates session file with logoff time + ; and marks the session closed. + ; + K ^TMP("MAGGTAU","LOGOFF",$J) + S MAGRY=1 + N MAGGFDA,MAGXERR,MAGXIEN,MAGIEN,MAGSESS,MAGEND,MAGCON + ; The Imaging Workstation file keeps time of login + ; We'll enter the logoff time ($$now^xlfdt) here. + S X=$$NOW^XLFDT + S MAGEND=$E(X,1,12) + Q:'+$G(MAGJOB("WRKSIEN")) + L -^MAG(2006.81,"LOCK",MAGJOB("WRKSIEN")) + S MAGIEN=+MAGJOB("WRKSIEN")_"," + S MAGGFDA(2006.81,MAGIEN,3)=MAGEND ; logoff dttm + S MAGGFDA(2006.81,MAGIEN,8)=0 ; Set job number to 0 + D UPDATE^DIE("S","MAGGFDA","MAGXIEN","MAGXERR") + ;MAGJOB("WRKSIEN") + Q:(+$G(MAGJOB("SESSION"))=0) + S MAGSESS=+MAGJOB("SESSION")_"," + K MAGGFDA,MAGXERR,MAGXIEN + S MAGGFDA(2006.82,MAGSESS,3)=MAGEND + ; calculate the length of the session + S MAGCON="" + S MAGGFDA(2006.82,MAGSESS,14)=MAGCON + D UPDATE^DIE("S","MAGGFDA","MAGXIEN","MAGXERR") + D ACTION("LOGOFF^") + ; + Q +RTRNERR(ETXT) ; There was error from UPDATE^DIE quit with error text + S ETXT="0^ERROR "_MAGXERR("DIERR",1,"TEXT",1) + Q diff --git a/r/IMAGING-MAG-ZMAG/MAGGTERR.m b/r/IMAGING-MAG-ZMAG/MAGGTERR.m index 7d7af57d..c7a5371e 100644 --- a/r/IMAGING-MAG-ZMAG/MAGGTERR.m +++ b/r/IMAGING-MAG-ZMAG/MAGGTERR.m @@ -1,62 +1,57 @@ -MAGGTERR ;WOIFO/GEK - IMAGING ERROR TRAP, AND ERROR LOG ; [ 06/20/2001 08:56 ] - ;;3.0;IMAGING;**8,59**;Nov 27, 2007;Build 20 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q - ; Imaging routines should have this code for setting error trap - ; This will enable logging Imaging errors and Sending messages for - ; certain errors etc. later - ;N $ETRAP,$ESTACK S $ETRAP="D ERRA^MAGGTERR" - ; - ; This assumes the Return variable or array is MAGRY or MAGRY() - Q -ERRA ; ERROR TRAP FOR Array Return variables - N ERR S ERR=$$EC^%ZOSV - S MAGRY(0)="0^"_ERR - D LOGERR(ERR) - D @^%ZOSF("ERRTN") - Q - ; -AERRA ; ERROR TRAP FOR Global Return Variables - N ERR S ERR=$$EC^%ZOSV - S @MAGRY@(0)="0^ERROR "_ERR - D LOGERR(ERR) - D @^%ZOSF("ERRTN") - Q -ERR ; ERROR TRAP FOR String Return variables - N ERR S ERR=$$EC^%ZOSV - S MAGRY="0^ERROR "_ERR - D LOGERR(ERR) - D @^%ZOSF("ERRTN") - Q -LOGERR(ERROR) ; - Q:'$G(MAGJOB("SESSION")) - N SESS,WRKS,ERR - S SESS=$G(MAGJOB("SESSION")) - ; Quit if No entry in Session File. - Q:'$D(^MAG(2006.82,SESS,0)) - I '$D(^MAG(2006.82,SESS,"ERR",0)) S ^MAG(2006.82,SESS,"ERR",0)="^2006.823A^0^0" - S ERR=$O(^MAG(2006.82,SESS,"ERR"," "),-1)+1 - S ^MAG(2006.82,SESS,"ERR",ERR,0)=ERROR - S $P(^MAG(2006.82,SESS,"ERR",0),"^",3,4)=ERR_"^"_ERR - ; - Q:'$G(MAGJOB("WRKSIEN")) - S WRKS=$G(MAGJOB("WRKSIEN")) - ; Quit if No entry in Workstation File. - Q:'$D(^MAG(2006.81,WRKS,0)) - S $P(^MAG(2006.81,WRKS,0),"^",11)=ERR - Q +MAGGTERR ;WOIFO/GEK - IMAGING ERROR TRAP, AND ERROR LOG ; [ 06/20/2001 08:56 ] + ;;3.0;IMAGING;**8**;Sep 15, 2004 + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q + ; Imaging routines should have this code for setting error trap + ; This will enable logging Imaging errors and Sending messages for + ; certain errors etc. later + ;IF $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERRA^MAGGTERR" + ;E S X="ERRA^MAGGTERR",@^%ZOSF("TRAP") + ; + ; This assumes the Return variable or array is MAGRY or MAGRY() + Q +ERRA ; ERROR TRAP FOR Array Return variables + N ERR S ERR=$$EC^%ZOSV + S MAGRY(0)="0^"_ERR + D LOGERR(ERR) + D @^%ZOSF("ERRTN") + Q + ; +AERRA ; ERROR TRAP FOR Global Return Variables + N ERR S ERR=$$EC^%ZOSV + S @MAGRY@(0)="0^ERROR "_ERR + D LOGERR(ERR) + D @^%ZOSF("ERRTN") + Q +ERR ; ERROR TRAP FOR String Return variables + N ERR S ERR=$$EC^%ZOSV + S MAGRY="0^ERROR "_ERR + D LOGERR(ERR) + D @^%ZOSF("ERRTN") + Q +LOGERR(ERROR) ; + Q:'$G(MAGJOB("SESSION")) + N MAGGFDA,MAGXERR,MAGXIEN,MAGNODE + S MAGNODE="+1,"_+MAGJOB("SESSION")_"," + ;S MAGNODE="+1,10," + S MAGGFDA(2006.823,MAGNODE,.01)=ERROR + D UPDATE^DIE("","MAGGFDA","MAGXIEN","MAGXERR") + ; error flag for this session in workstation file + S MAGNODE=+MAGJOB("WRKSIEN")_"," + S MAGGFDA(2006.81,MAGNODE,11)=+MAGXIEN(1) ; + D UPDATE^DIE("","MAGGFDA","MAGXIEN","MAGXERR") + Q diff --git a/r/IMAGING-MAG-ZMAG/MAGGTIA1.m b/r/IMAGING-MAG-ZMAG/MAGGTIA1.m index d1c55428..eb0e13fb 100644 --- a/r/IMAGING-MAG-ZMAG/MAGGTIA1.m +++ b/r/IMAGING-MAG-ZMAG/MAGGTIA1.m @@ -1,182 +1,163 @@ -MAGGTIA1 ;WOIFO/GEK - RPC Call to Add Image File entry ; [ 06/20/2001 08:56 ] - ;;3.0;IMAGING;**21,8,59**;Nov 27, 2007;Build 20 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q -ADD ;Now call Fileman to file the data - N GIEN,DIEN,NEWIEN,MAGGDA,X,Y - ;Because we delete the Image node on image deletion, we have to - ; check the last entry in Audit File, to see if it is greater than - ; last image in Image File. - I ($O(^MAG(2005,"A"),-1)<$O(^MAG(2005.1,"A"),-1)) S $P(^MAG(2005,0),U,3)=$O(^MAG(2005.1,"A"),-1) - ; we know that MAGGIEN WILL contain the internal number. - ; after the call. - ; - I $G(MAGMOD) D Q ; WE'LL QUIT AFTER MODIFICATION - . D UPDATE^DIE("S","MAGGFDA","MAGGIEN","MAGGXE") - . S MAGRY="1^OK" - . ; Now, after UPDATE^DIE, we aren't getting the MAGGIEN array., We'll use MAGMOD - . D ACTION^MAGGTAU("MOD^"_$P(^MAG(2005,+MAGMOD,0),U,7)_"^"_+$G(MAGMOD)) ; This is the Image IEN - ; - ; There are incidents of using an IEN from a deleted image - ; these next lines are to stop the problem. - S GIEN=$O(^MAG(2005," "),-1)+1 - S DIEN=$O(^MAG(2005.1," "),-1)+1 - S NEWIEN=$S(GIEN>DIEN:GIEN,1:DIEN) -LOCK L +^MAG(2005,NEWIEN):0 E S NEWIEN=NEWIEN+1 G LOCK - I $D(^MAG(2005,NEWIEN)) L -^MAG(2005,NEWIEN) S NEWIEN=NEWIEN+1 G LOCK - S MAGGIEN(1)=NEWIEN - D UPDATE^DIE("S","MAGGFDA","MAGGIEN","MAGGXE") - ; - I '$G(MAGGIEN(1)) D S MAGRY=MAGERR Q - . S MAGERR="0^ERROR Creating new Image File Entry " - . I $D(DIERR) D RTRNERR(.MAGERR) - . D CLEAN - ; - S MAGGDA=MAGGIEN(1) - ; - D ACTION^MAGGTAU("CAP^"_MAGGFDA(2005,"+1,",5)_"^"_MAGGDA) - ; - ; IF a group, Modify GROUP PARENT in each Group Object and QUIT - ; we'll do this by hand, Else it'll take forever. - ; we Return the IEN with NO Filename. Groups don't get Filename - ; - I MAGGR S MAGRY=MAGGDA_U,Z="" D G C1 - . F S Z=$O(MAGGR(Z)) Q:Z="" S $P(^MAG(2005,Z,0),U,10)=MAGGDA - . D CLEAN - ; - S X=$G(MAGGFDA(2005,"+1,",14)) I +X D - . ; If here: This image is a member of a Group - . ; -Modify the Group Parent, add DA to it's group - . ; -Also set 'Series Number' and 'Image Number' if they exist; - . K MAGGFDA - . S Y="+2,"_X_"," - . S MAGGFDA(2005.04,Y,.01)=MAGGDA - . ; GEK 4/4/00 ADDED $L( we were dying on "0" - . I $L($G(MAGDCMSN)) S MAGGFDA(2005.04,Y,1)=MAGDCMSN - . I $L($G(MAGDCMIN)) S MAGGFDA(2005.04,Y,2)=MAGDCMIN - . D UPDATE^DIE("S","MAGGFDA","MAGGIEN","MAGGXE") - ; - ; Now get the Image file name. DOS FILE name - ; The ENTRY in Image File has been made, if any errors from here on - ; then we have to delete the image entry. - I $D(MAGGFDA(2005,"+1,",1)) S MAGGFNM=MAGGFDA(2005,"+1,",1) G C1 - K MAGGFDA - S X=$$DA2NAME^MAGGTU1(MAGGDA,$G(MAGGEXT)) I 'X D S MAGRY=MAGERR Q - . S MAGERR=X - . S DA=MAGGDA,DIK="^MAG(2005," D ^DIK - . K DA,DIC,DIK - . D CLEAN - S MAGGFNM=$P(X,U,2),Y=MAGGDA_"," - S MAGGFDA(2005,Y,1)=MAGGFNM - D UPDATE^DIE("","MAGGFDA","","MAGGXE") - ; shouldn't have an error just editing one entry, but just in case. - I $D(DIERR) D S MAGRY=MAGERR Q - . D RTRNERR(.MAGERR) - . S DA=MAGGDA,DIK="^MAG(2005," D ^DIK - . K DA,DIC,DIK - . D CLEAN - ; -C1 ; we jump here if we already had a Filename sent - K MAGGFDA - ; New Index Field Check. If this entry doesn't have the Index fields introduced - ; in 3.0.8 then we use the Patch 17 conversion API call to generate default values. - ; - ;P59 Now we Auto-Generate the Index Fields, if they don't exist for this entry. - I '$D(^MAG(2005,MAGGDA,40)) D - . N INDXD - . D GENIEN^MAGXCVI(MAGGDA,.INDXD) - . S ^MAG(2005,MAGGDA,40)=INDXD - . S ^MAGIXCVT(2006.96,MAGGDA)=2 ; Flag. Says fields were converted Patch 59 - . ; TRKING ID TRKID = MAGGFDA(2005,"+1,",108) - . D ACTION^MAGGTAU("INDEX-ALL^"_$P(^MAG(2005,MAGGDA,0),"^",7)_"^"_MAGGDA) ;_"$$"_MAGGFDA(2005,"+1,",108)) - . D ENTRY^MAGLOG("INDEX-ALL",DUZ,MAGGDA,"P59",$P(^MAG(2005,MAGGDA,0),"^",7),1) - . Q - ;P59 If TYPE INDEX is missing we Auto-Generate Index Type and other missing Index Term values. - I '$P(^MAG(2005,MAGGDA,40),"^",3) D - . N INDXD,OLD40,N40 - . S (N40,OLD40)=^MAG(2005,MAGGDA,40) - . D GENIEN^MAGXCVI(MAGGDA,.INDXD) - . ; If Origin doesn't exist in existing, this will put V in. - . I $P(INDXD,"^",6)="" S $P(INDXD,"^",6)="V" - . ; We're not changing existing values of Spec,Proc or Origin - . F J=1:1:6 I '$L($P(N40,"^",J)) S $P(N40,"^",J)=$P(INDXD,"^",J) - . ;Validate the merged Spec and Proc, if not valid, revert back to old Spec and Proc - . I '$$VALINDEX^MAGGSIV1(.X,$P(N40,"^",3),$P(N40,"^",5),$P(N40,"^",4)) S $P(N40,"^",4,5)=$P(OLD40,"^",4,5) - . S ^MAG(2005,MAGGDA,40)=N40 - . D ACTION^MAGGTAU("INDEX-42^"_$P(^MAG(2005,MAGGDA,0),"^",7)_"^"_MAGGDA) ;_"$$"_MAGGFDA(2005,"+1,",108)) - . D ENTRY^MAGLOG("INDEX-42",DUZ,MAGGDA,"P59",$P(^MAG(2005,MAGGDA,0),"^",7),1) - . Q - ;** ABS and JB image queues AREN'T SET WHEN ADDING AN IMAGE. - ;** IT IS DONE IN A SEPERATE CALL - ;** RPC =-> 'MAG ABSJB' after abstract is/isn't created on - ;** the workstation - ; - ; Queue it to be copied to Jukebox. - ; CREATE ABSTRACT - ; visn15 ADDED $$DA2PLCA to resolve the Image's current PLACE - I $G(MAGGABS)="YES" S X=$$ABSTRACT^MAGBAPI(MAGGDA,$$DA2PLC^MAGBAPIP(MAGGDA,"A")) - ; RESTORE AFTER GLOBAL SETUP - I $G(MAGGJB)="YES" S X=$$JUKEBOX^MAGBAPI(MAGGDA,$$DA2PLC^MAGBAPIP(MAGGDA,"F")) - ; Code for setting a Queue to Copy BIG to JUKEBOX - ; - ; We return the IEN ^ DRIVE:DIR ^ FILE.EXT - ; example: 487^C:\IMAGE\^DC000487.TIF - ; The calling routine is responsible for renaming/naming the file - ; to the returned DRIVE:\DIR\FILENAME.EXT - ; 4/23/98 to include hierarchical directory structure -- PMK - ; - I 'MAGGR D - . S MAGDHASH=$$DIRHASH^MAGFILEB(MAGGFNM,MAGREF) - . S MAGRY=MAGGDA_U_MAGGDRV_MAGDHASH_U_MAGGFNM - . ; For now, BIG files are in same directory as FullRes (or PACS) file - . I $G(MAGBIG) D - . . S X=$P(MAGGFNM,".",1)_".BIG" - . . S MAGRY=MAGRY_U_MAGGDRV_MAGDHASH_U_X - . . Q - . Q - ; -CLEAN ; - D CLEAN^DILF - L -^MAG(2005,NEWIEN) - Q -RTRNERR(ETXT) ; There was error from UPDATE^DIE quit with error text - S ETXT="0^ERROR "_MAGGXE("DIERR",1,"TEXT",1) - Q -ERR ; Error trap - S MAGRY="0^ERROR "_$$EC^%ZOSV - D @^%ZOSF("ERRTN") - Q -MAKENAME() ; MAGGFDA exists so get info from that. - ; We'll make NAME (.01) with PATIENT NAME SSN - ; DOCUMENT Imaging was making name of - ; $E(PATENT NAME,1,10)' '$E(DESC CATEG,1,9)' 'MM/DD/YY (DOC DATE) - N Z,ZT,ZNAME,ZSSN,ZDESC - ; GEK 10/10/2000 - ; Modifying this procedure to make same name for all Image types - ; The name will be (first 18 chars of patient Name) _ SSN - I $D(MAGGFDA(2005,"+1,",10)) S ZDESC=$E(MAGGFDA(2005,"+1,",10),1,30) - I $D(MAGGFDA(2005,"+1,",5)) D - . S X=MAGGFDA(2005,"+1,",5) - . S ZNAME=$P(^DPT(X,0),U),ZSSN=$P(^DPT(X,0),U,9) - ; - ; For all Images the name is first 18 characters of patient name - ; concatenated with SSN. If No patient name is sent, well make - ; the name from the short desc. - I $D(ZNAME) S Z=$E(ZNAME,1,18)_" "_ZSSN - E S Z=ZDESC - Q Z +MAGGTIA1 ;WOIFO/GEK - RPC Call to Add Image File entry ; [ 06/20/2001 08:56 ] + ;;3.0;IMAGING;**21,8**;Sep 15, 2004 + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q +ADD ;Now call Fileman to file the data + N GIEN,DIEN,NEWIEN,MAGGDA,X,Y + ;Because we delete the Image node on image deletion, we have to + ; check the last entry in Audit File, to see if it is greater than + ; last image in Image File. + I ($O(^MAG(2005,"A"),-1)<$O(^MAG(2005.1,"A"),-1)) S $P(^MAG(2005,0),U,3)=$O(^MAG(2005.1,"A"),-1) + ; we know that MAGGIEN WILL contain the internal number. + ; after the call. + ; + I $G(MAGMOD) D Q ; WE'LL QUIT AFTER MODIFICATION + . D UPDATE^DIE("S","MAGGFDA","MAGGIEN","MAGGXE") + . S MAGRY="1^OK" + . ; Now, after UPDATE^DIE, we aren't getting the MAGGIEN array., We'll use MAGMOD + . D ACTION^MAGGTAU("MOD^"_$P(^MAG(2005,+MAGMOD,0),U,7)_"^"_+$G(MAGMOD)) ; This is the Image IEN + ; + ; There are incidents of using an IEN from a deleted image (still) + ; these next lines are TESTING for now. To stop the problem. + S GIEN=$O(^MAG(2005," "),-1)+1 + S DIEN=$O(^MAG(2005.1," "),-1)+1 + S NEWIEN=$S(GIEN>DIEN:GIEN,1:DIEN) +LOCK L +^MAG(2005,NEWIEN):0 E S NEWIEN=NEWIEN+1 G LOCK + I $D(^MAG(2005,NEWIEN)) L -^MAG(2005,NEWIEN) S NEWIEN=NEWIEN+1 G LOCK + S MAGGIEN(1)=NEWIEN + D UPDATE^DIE("S","MAGGFDA","MAGGIEN","MAGGXE") + ; + I '$G(MAGGIEN(1)) D S MAGRY=MAGERR Q + . S MAGERR="0^ERROR Creating new Image File Entry " + . I $D(DIERR) D RTRNERR(.MAGERR) + . D CLEAN + ; + S MAGGDA=MAGGIEN(1) + ; + D ACTION^MAGGTAU("CAP^"_MAGGFDA(2005,"+1,",5)_"^"_MAGGDA) + ; + ; IF a group, Modify GROUP PARENT in each Group Object and QUIT + ; we'll do this by hand, Else it'll take forever. + ; we Return the IEN with NO Filename. Groups don't get Filename + ; + I MAGGR S MAGRY=MAGGDA_U,Z="" D Q + . F S Z=$O(MAGGR(Z)) Q:Z="" S $P(^MAG(2005,Z,0),U,10)=MAGGDA + . D CLEAN + ; + S X=$G(MAGGFDA(2005,"+1,",14)) I +X D + . ; We're here beceause this image is a member of a Group + . ; so we will modify the Group Parent, adding this to it's group + . ; HERE we will also send the 'Series Number' and 'Image Number' if + . ; they exist; + . K MAGGFDA + . S Y="+2,"_X_"," + . S MAGGFDA(2005.04,Y,.01)=MAGGDA + . ; GEK 4/4/00 ADDED $L( we were dying on "0" + . I $L($G(MAGDCMSN)) S MAGGFDA(2005.04,Y,1)=MAGDCMSN + . I $L($G(MAGDCMIN)) S MAGGFDA(2005.04,Y,2)=MAGDCMIN + . D UPDATE^DIE("S","MAGGFDA","MAGGIEN","MAGGXE") + ; + ; + ; + ; now get the Image file name. DOS FILE name + ; ENTRY in Image File has been made, if any errors from here on + ; then we have to delete the image entry. + I $D(MAGGFDA(2005,"+1,",1)) S MAGGFNM=MAGGFDA(2005,"+1,",1) G C1 + K MAGGFDA + S X=$$DA2NAME^MAGGTU1(MAGGDA,$G(MAGGEXT)) I 'X D S MAGRY=MAGERR Q + . S MAGERR=X + . S DA=MAGGDA,DIK="^MAG(2005," D ^DIK + . K DA,DIC,DIK + . D CLEAN + S MAGGFNM=$P(X,U,2),Y=MAGGDA_"," + S MAGGFDA(2005,Y,1)=MAGGFNM + D UPDATE^DIE("","MAGGFDA","","MAGGXE") + ; shouldn't have an error just editing one entry, but just in case. + I $D(DIERR) D S MAGRY=MAGERR Q + . D RTRNERR(.MAGERR) + . S DA=MAGGDA,DIK="^MAG(2005," D ^DIK + . K DA,DIC,DIK + . D CLEAN + ; +C1 ; we jump here if we already had a Filename sent + ; + K MAGGFDA + ; New Index Field Check. If this entry doesn't have the Index fields introduced + ; in 3.0.8 then we use the Patch 17 conversion API call to generate default values. + ; + ;-This is being deferred to a later patch. + ;-I '$D(^MAG(2005,MAGGDA,40)) D + ;-. D ONE^MAGSCNVI(MAGGDA) + ;-. D ACTION^MAGGTAU("DFTINDX^^"_MAGGDA) + ; + ;** ABS and JB image queues AREN'T SET WHEN ADDING AN IMAGE. + ;** IT IS DONE IN A SEPERATE CALL + ;** RPC =-> 'MAG ABSJB' after abstract is/isn't created on + ;** the workstation + ; + ; Queue it to be copied to Jukebox. + ; CREATE ABSTRACT + ; visn15 ADDED $$DA2PLCA to resolve the Image's current PLACE + I $G(MAGGABS)="YES" S X=$$ABSTRACT^MAGBAPI(MAGGDA,$$DA2PLC^MAGBAPIP(MAGGDA,"A")) + ; RESTORE AFTER GLOBAL SETUP + I $G(MAGGJB)="YES" S X=$$JUKEBOX^MAGBAPI(MAGGDA,$$DA2PLC^MAGBAPIP(MAGGDA,"F")) + ; Code for setting a Queue to Copy BIG to JUKEBOX + ; + ; We return the IEN ^ DRIVE:DIR ^ FILE.EXT + ; i.e 487^C:\IMAGE\^DC000487.TIF + ; The calling routine is responsible for renaming/naming the file + ; to the returned DRIVE:\DIR\FILENAME.EXT + ; Modified 4/23/98 to include hierarchial directory structure -- PMK + ; + S MAGDHASH=$$DIRHASH^MAGFILEB(MAGGFNM,MAGREF) + S MAGRY=MAGGDA_U_MAGGDRV_MAGDHASH_U_MAGGFNM + ; For now, BIG files are in same directory as FullRes (or PACS) file + I $G(MAGBIG) D + . S X=$P(MAGGFNM,".",1)_".BIG" + . S MAGRY=MAGRY_U_MAGGDRV_MAGDHASH_U_X + . Q + ; +CLEAN ; + D CLEAN^DILF + L -^MAG(2005,NEWIEN) + Q +RTRNERR(ETXT) ; There was error from UPDATE^DIE quit with error text + S ETXT="0^ERROR "_MAGGXE("DIERR",1,"TEXT",1) + Q +ERR ; Error trap + S MAGRY="0^ERROR "_$$EC^%ZOSV + D @^%ZOSF("ERRTN") + Q +MAKENAME() ; MAGGFDA exists so get info from that. + ; We'll make NAME (.01) with PATIENT NAME SSN + ; DOCUMENT Imaging was making name of + ; $E(PATENT NAME,1,10)' '$E(DESC CATEG,1,9)' 'MM/DD/YY (DOC DATE) + N Z,ZT,ZNAME,ZSSN,ZDESC + ; GEK 10/10/2000 + ; Modifying this procedure to make same name for all Image types + ; The name will be (first 18 chars of patient Name) _ SSN + I $D(MAGGFDA(2005,"+1,",10)) S ZDESC=$E(MAGGFDA(2005,"+1,",10),1,30) + I $D(MAGGFDA(2005,"+1,",5)) D + . S X=MAGGFDA(2005,"+1,",5) + . S ZNAME=$P(^DPT(X,0),U),ZSSN=$P(^DPT(X,0),U,9) + ; + ; For all Images the name is first 18 characters of patient name + ; concatenated with SSN. If No patient name is sent, well make + ; the name from the short desc. + I $D(ZNAME) S Z=$E(ZNAME,1,18)_" "_ZSSN + E S Z=ZDESC + Q Z diff --git a/r/IMAGING-MAG-ZMAG/MAGGTID.m b/r/IMAGING-MAG-ZMAG/MAGGTID.m index 80177062..5ab2676c 100644 --- a/r/IMAGING-MAG-ZMAG/MAGGTID.m +++ b/r/IMAGING-MAG-ZMAG/MAGGTID.m @@ -1,197 +1,192 @@ -MAGGTID ;WOIFO/SRR/RED/SAF/GEK - Deletion of Images and Pointers ; [ 06/20/2001 08:56 ] - ;;3.0;IMAGING;**8,59**;Nov 27, 2007;Build 20 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q - ; -IMAGEDEL(MAGGRY,MAGIEN,MAGGRPDF,REASON) ;RPC [MAGG IMAGE DELETE] - ; Call to Delete Image entry from Image file ^MAG(2005 - ; MAGIEN Image IEN ^ SYSDEL flag - ; MAGGRPDF group delete flag 1 = group delete allowed - ; SYSDEL Flag that forces delete, even if no KEY - ; - N Y,RY - ; 1 in 3rd piece means : DELETE the Image File Also. - S MAGGRPDF=+$G(MAGGRPDF),REASON=$G(REASON) - L +^MAG(2005,MAGIEN):4 - E S MAGGRY(0)="Image ID# "_MAGIEN_" is Locked. Delete is Canceled" Q - D DELETE(.MAGGRY,MAGIEN,1,MAGGRPDF,REASON) - L -^MAG(2005,MAGIEN) - Q -DELETE(RY,MAGIEN,DF,GRPDF,REASON) ;RPC [MAGQ DIK] Entry point for silent call - ;RY=Return Array RY(0)="1^SUCCESS" - ; RY(0)="0^reason for failure" - ; ;NOT RETURNING LIST AT THIS TIME - ; ( RY(1)..RY(n)= IEN's of deleted images.) - ;MAGIEN=Image entry number to be deleted - ; if MAGIEN has a 2nd piece = 1 then we force delete, don't test - ; for MAG DELETE KEY - ;DF=Delete file flag - 1=delete the Image file - ; - 0=don't delete the image file - ; - S REASON=$G(REASON) I REASON="" S REASON="Unknown reason" - S RY(0)="0^Image Delete Failed, reason unknown." - S:'$D(MAGSYS) MAGSYS=^%ZOSF("VOL") - N MAGERR,SYSDEL,Z - S SYSDEL=+$P(MAGIEN,U,2) - ; Check the business rules for deleting an image - D DELETE^MAGSIMBR(.RY,MAGIEN,SYSDEL) I +RY(0)=0 Q - S MAGIEN=+MAGIEN - ; a couple tests of privilage and valid IEN - I '$D(^MAG(2005,MAGIEN,0)) D Q - . S RY(0)="0^Image entry doesn't exist in image file" - I +$O(^MAG(2005,MAGIEN,1,0)),+$G(GRPDF)=0 D Q - . S RY(0)="0^Deleting a Group is not allowed." - I +$O(^MAG(2005,MAGIEN,1,0)),+$G(GRPDF)'=0 D Q - . N MAGGRP S MAGGRP=MAGIEN N MAGIEN,MAGX,MAGOK,MAGFAIL - . S MAGX=0,MAGOK=0,MAGFAIL=0 - . F S MAGX=$O(^MAG(2005,MAGGRP,1,MAGX)) Q:'MAGX D - . . S MAGIEN=$P($G(^MAG(2005,MAGGRP,1,MAGX,0)),"^") D DEL1IMG - . . I +RY(0) S Z=+$O(RY(""),-1),RY(Z)=RY(Z)_"^"_RY(0),MAGOK=MAGOK+1 - . . E S Z=+$O(RY(""),-1)+1,RY(Z)=MAGIEN_"^"_RY(0),MAGFAIL=MAGFAIL+1 - . . Q - . I +MAGFAIL=0 S RY(0)="1^Deletion of Group #"_MAGGRP_" was successful.^"_MAGOK_"^0" - . E S RY(0)="0^Error deleting child image(s). Group Not Deleted.^"_MAGOK_"^"_MAGFAIL - . Q - ; - ; Ok lets start - ; lets delete the parent pointers first. -DEL1IMG ; - N DELMSG,Z - D DELPAR^MAGSDEL2 - I $G(MAGERR) S RY(0)="0^Error: Deleting Specialty Pointers. Image Not Deleted. "_DELMSG Q - ; - ; Now delete image record & xref's - ; if this Image is member of group DELGRP will delete those pointers - ; and delete the Group, if this is only image in it. - S MAGDFN=$P($G(^MAG(2005,MAGIEN,0)),"^",7) ; Moved here from below. DELGRP needs MAGDFN now. - D DELGRP - I $G(MAGERR) S RY(0)="0^Error deleting Group Pointers." Q - ; - ; write the deleted by, delete reason, and delete date to the file. - D SETDEL(MAGIEN,REASON) - ; - ; save the Image record to the archive before we delete it. - D ARCHIVE(MAGIEN) - ; - ; Now let's set the Queue to delete the Image File, if Flag is set - I $G(DF) D DELFILE - ; - ; we're having "APPXDT" crossref left around, lets delete it first. - S X=MAGDFN,DA=MAGIEN D KILPPXD^MAGUXRF - ; - ; now lets delete the image. - K DIK,DA,DA(1),DA(2),DIC,DR,DIE,DIR S DIK="^MAG(2005,",DA=MAGIEN - D ^DIK - S Z=+$O(RY(""),-1)+1,RY(Z)=MAGIEN - ; we were having problems with "AC" so lets check to make sure. - I $D(^MAG(2005,"AC",MAGDFN,MAGIEN)) K ^MAG(2005,"AC",MAGDFN,MAGIEN) - ; log it. - D ENTRY^MAGLOG("DELETE",$G(DUZ),$G(MAGIEN),"PARENT:"_$G(MAGSTORE),$G(MAGDFN),1) - S X="DEL^"_$G(MAGDFN)_"^"_$G(MAGIEN) - D ACTION^MAGGTAU(X,"1") - S RY(0)="1^Deletion of Image was Successful." - Q -DELGRP ;del grp ptrs and check to see if this is the last image in the group - N MAGGRP,MAGX,MAGQUIT,MAGIFNS,Z - S MAGGRP=$P($G(^MAG(2005,MAGIEN,0)),"^",10) - Q:'$G(MAGGRP) - K DIK,DA,DA(1),DA(2),DIC,DR,DIE,DIR - S MAGX=0,MAGQUIT=0 - F S MAGX=$O(^MAG(2005,MAGGRP,1,MAGX)) Q:'MAGX D Q:MAGQUIT - . I +^MAG(2005,MAGGRP,1,MAGX,0)=MAGIEN D - . . S DIK="^MAG(2005,MAGGRP,1,",DA(1)=MAGGRP,DA=MAGX D ^DIK S MAGQUIT=1 - . . ;added DA(1) needed for xref deletion of dicom series - . I $O(^MAG(2005,MAGGRP,1,0))="" D - . . I $P($G(^MAG(2005,MAGGRP,2)),"^",6) D - . . . ;report is on group - need to delete it - . . . S MAGIFNS=MAGIEN,MAGIEN=MAGGRP - . . . D DELPAR^MAGSDEL2 - . . . S MAGIEN=MAGIFNS - . . I '$D(MAGERR) D - . . . D SETDEL(MAGGRP,REASON),ARCHIVE(MAGGRP) S DIK="^MAG(2005,",DA=MAGGRP D ^DIK - . . . ; Log the Deletion of The Group Header to ^MAG(2006.95, and ^MAG(2006.82 - . . . D ENTRY^MAGLOG("DELETE",$G(DUZ),$G(MAGGRP),"PARENT:"_$G(MAGSTORE),$G(MAGDFN),1,"Group Header deleted") - . . . S X="DEL^"_$G(MAGDFN)_"^"_$G(MAGGRP) - . . . D ACTION^MAGGTAU(X,"1") - . . . S Z=+$O(RY(""),-1)+1,RY(Z)=MAGGRP_"^1^Deletion of Group was Successful." - . . . Q - . . Q - . Q - Q -SETDEL(MAGIEN,REASON) ; set deletion fields - N DA,DR,DIE,X - ;N %H - ;S %H=$H D YMD^%DTC - S X=$$NOW^XLFDT - ; gek - changed 3 slash to 4 slash. to stop FM question marks. ?? - S DR="30////"_DUZ_";30.1////"_X_";30.2////"_REASON - S DIE="2005",DA=MAGIEN D ^DIE - Q - ; -ARCHIVE(MAGARCIE) ;save image data before deletion - N MAGCNT,MAGLAST,%X,%Y - S MAGCNT=$P(^MAG(2005.1,0),U,4)+1 - S %X="^MAG(2005,"_MAGARCIE_",",%Y="^MAG(2005.1,"_MAGARCIE_"," - D %XY^%RCR - ; GEK 9/29/00 Fix the 3rd piece to be last ien in file. - S MAGLAST=$O(^MAG(2005.1,"A"),-1) - S $P(^MAG(2005.1,0),U,4)=MAGCNT - I '($P(^MAG(2005.1,0),U,3)=MAGLAST) S $P(^MAG(2005.1,0),U,3)=MAGLAST - S DA=MAGARCIE - S DIK="^MAG(2005.1," D IX1^DIK - Q -DELFILE ;Delete image file on server if exists - ;gek 3/21/2003 Changed to stop using FullRes Path for Abs,Big - ; and only Delete .TXT and Alternates if Full is being deleted. - N X0,X1,X2,ALTEXT,ALTPATH,MAGXX,XBIG - N MAGPLC ; DBI - SEB 9/20/2002 - ; MAGIEN IS ASSUMED TO BE DEFINED. - ; MAGXX - This is IEN in ^MAG(2005, MAGFILEB Expects this to be defined. - ; MAGPLC - "Place" of Full Res Image. - ; ALTEXT - Extension of the Alternate image file. - ; ALTPATH - Full path of Alternate image file. - S X0=^MAG(2005,MAGIEN,0) - ;delete Full Res if one exists on Magnetic - I $P(X0,U,3) D - . S MAGXX=MAGIEN - . S MAGPLC=$$DA2PLC^MAGBAPIP(MAGIEN,"F") - . D VSTNOCP^MAGFILEB - . S X=$$DELETE^MAGBAPI(MAGFILE2,MAGPLC) - . ;Delete any other ALTernate files. ( TXT) - . ;gek 3/31/03 Since ALT files are (for now) always on same server as Full - . ; We only attempt to delete them here (If we have a path to FullRes on Magnetic) - . S X2=0 - . F S X2=$O(^MAG(2006.1,MAGPLC,2,X2)) Q:'X2 D - . . S ALTEXT=^MAG(2006.1,MAGPLC,2,X2,0) - . . S ALTPATH=$P(MAGFILE2,".")_"."_ALTEXT - . . S X=$$DELETE^MAGBAPI(ALTPATH,MAGPLC) - . Q - ; - ;delete image abstract if one exists on Magnetic - I $P(X0,U,4) D - . S MAGXX=MAGIEN - . D ABSNOCP^MAGFILEB - . S X=$$DELETE^MAGBAPI(MAGFILE2,$$DA2PLC^MAGBAPIP(MAGIEN,"A")) ; DBI - SEB 9/20/2002 - ; - ;delete the big file if one exists on Magnetic - S XBIG=$G(^MAG(2005,MAGIEN,"FBIG")) - I $P(XBIG,U) D - . S MAGXX=MAGIEN - . D BIGNOCP^MAGFILEB - . S X=$$DELETE^MAGBAPI(MAGFILE2,$$DA2PLC^MAGBAPIP(MAGIEN,"B")) ; DBI - SEB 9/20/2002 - Q +MAGGTID ;WOIFO/SRR/RED/SAF/GEK - Deletion of Images and Pointers ; [ 06/20/2001 08:56 ] + ;;3.0;IMAGING;**8**;Sep 15, 2004 + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q + ; +IMAGEDEL(MAGGRY,MAGIEN,MAGGRPDF,REASON) ;RPC [MAGG IMAGE DELETE] + ; Call to Delete Image entry + ; SEB 6/6/2002 - added MAGGRPDF - group delete flag = 1 if group delete allowed + ; from Image file ^MAG(2005 + N Y,RY + ; 1 in 3rd piece means : DELETE the Image File Also. + S MAGGRPDF=+$G(MAGGRPDF),REASON=$G(REASON) + L +^MAG(2005,MAGIEN):4 + E S MAGGRY(0)="Image ID# "_MAGIEN_" is Locked. Delete is Canceled" Q + D DELETE(.MAGGRY,MAGIEN,1,MAGGRPDF,REASON) + L -^MAG(2005,MAGIEN) + Q +DELETE(RY,MAGIEN,DF,GRPDF,REASON) ;RPC [MAGQ DIK] Entry point for silent call + ;RY=Return Array RY(0)="1^SUCCESS" + ; RY(0)="0^reason for failure" + ; ;NOT RETURNING LIST AT THIS TIME + ; ( RY(1)..RY(n)= IEN's of deleted images.) + ;MAGIEN=Image entry number to be deleted + ; if MAGIEN has a 2nd piece = 1 then we force delete, don't test + ; for MAG DELETE KEY + ;DF=Delete file flag - 1=delete the Image file + ; - 0=don't delete the image file + ; + S REASON=$G(REASON) I REASON="" S REASON="Unknown reason" + S RY(0)="0^Image Delete Failed, reason unknown." + S:'$D(MAGSYS) MAGSYS=^%ZOSF("VOL") + N MAGERR,SYSDEL,Z + S SYSDEL=+$P(MAGIEN,U,2) + ; Check the business rules for deleting an image + D DELETE^MAGSIMBR(.RY,MAGIEN,SYSDEL) I +RY(0)=0 Q + S MAGIEN=+MAGIEN + ; a couple tests of privilage and valid IEN + I '$D(^MAG(2005,MAGIEN,0)) D Q + . S RY(0)="0^Image entry doesn't exist in image file" + I +$O(^MAG(2005,MAGIEN,1,0)),+$G(GRPDF)=0 D Q + . S RY(0)="0^Deleting a Group is not allowed." + I +$O(^MAG(2005,MAGIEN,1,0)),+$G(GRPDF)'=0 D Q + . N MAGGRP S MAGGRP=MAGIEN N MAGIEN,MAGX,MAGOK,MAGFAIL + . S MAGX=0,MAGOK=0,MAGFAIL=0 + . F S MAGX=$O(^MAG(2005,MAGGRP,1,MAGX)) Q:'MAGX D + . . S MAGIEN=$P($G(^MAG(2005,MAGGRP,1,MAGX,0)),"^") D DEL1IMG + . . I +RY(0) S Z=+$O(RY(""),-1),RY(Z)=RY(Z)_"^"_RY(0),MAGOK=MAGOK+1 + . . E S Z=+$O(RY(""),-1)+1,RY(Z)=MAGIEN_"^"_RY(0),MAGFAIL=MAGFAIL+1 + . . Q + . I +MAGFAIL=0 S RY(0)="1^Deletion of Group #"_MAGGRP_" was successful.^"_MAGOK_"^0" + . E S RY(0)="0^Error deleting child image(s). Group Not Deleted.^"_MAGOK_"^"_MAGFAIL + . Q + ; + ; Ok lets start + ; lets delete the parent pointers first. +DEL1IMG ; + N DELMSG,Z + D DELPAR^MAGSDEL2 + I $G(MAGERR) S RY(0)="0^Error: Deleting Specialty Pointers. Image Not Deleted. "_DELMSG Q + ; + ; Now delete image record & xref's + ; if this Image is member of group DELGRP will delete those pointers + ; and delete the Group, if this is only image in it. + S MAGDFN=$P($G(^MAG(2005,MAGIEN,0)),"^",7) ; Moved here from below. DELGRP needs MAGDFN now. + D DELGRP + I $G(MAGERR) S RY(0)="0^Error deleting Group Pointers." Q + ; + ; write the deleted by, delete reason, and delete date to the file. + D SETDEL(MAGIEN,REASON) + ; + ; save the Image record to the archive before we delete it. + D ARCHIVE(MAGIEN) + ; + ; Now let's set the Queue to delete the Image File, if Flag is set + I $G(DF) D DELFILE + ; + ; we're having "APPXDT" crossref left around, lets delete it first. + S X=MAGDFN,DA=MAGIEN D KILPPXD^MAGUXRF + ; + ; now lets delete the image. + K DIK,DA,DA(1),DA(2),DIC,DR,DIE,DIR S DIK="^MAG(2005,",DA=MAGIEN + D ^DIK + S Z=+$O(RY(""),-1)+1,RY(Z)=MAGIEN + ; we were having problems with "AC" so lets check to make sure. + I $D(^MAG(2005,"AC",MAGDFN,MAGIEN)) K ^MAG(2005,"AC",MAGDFN,MAGIEN) + ; log it. + D ENTRY^MAGLOG("DELETE",$G(DUZ),$G(MAGIEN),"PARENT:"_$G(MAGSTORE),$G(MAGDFN),1) + S X="DEL^"_$G(MAGDFN)_"^"_$G(MAGIEN) + D ACTION^MAGGTAU(X,"1") + S RY(0)="1^Deletion of Image was Successful." + Q +DELGRP ;del grp ptrs and check to see if this is the last image in the group + N MAGGRP,MAGX,MAGQUIT,MAGIFNS,Z + S MAGGRP=$P($G(^MAG(2005,MAGIEN,0)),"^",10) + Q:'$G(MAGGRP) + K DIK,DA,DA(1),DA(2),DIC,DR,DIE,DIR + S MAGX=0,MAGQUIT=0 + F S MAGX=$O(^MAG(2005,MAGGRP,1,MAGX)) Q:'MAGX D Q:MAGQUIT + . I +^MAG(2005,MAGGRP,1,MAGX,0)=MAGIEN D + . . S DIK="^MAG(2005,MAGGRP,1,",DA(1)=MAGGRP,DA=MAGX D ^DIK S MAGQUIT=1 + . . ;added DA(1) needed for xref deletion of dicom series + . I $O(^MAG(2005,MAGGRP,1,0))="" D + . . I $P($G(^MAG(2005,MAGGRP,2)),"^",6) D + . . . ;report is on group - need to delete it + . . . S MAGIFNS=MAGIEN,MAGIEN=MAGGRP + . . . D DELPAR^MAGSDEL2 + . . . S MAGIEN=MAGIFNS + . . I '$D(MAGERR) D + . . . D SETDEL(MAGGRP,REASON),ARCHIVE(MAGGRP) S DIK="^MAG(2005,",DA=MAGGRP D ^DIK + . . . ; Log the Deletion of The Group Header to ^MAG(2006.95, and ^MAG(2006.82 + . . . D ENTRY^MAGLOG("DELETE",$G(DUZ),$G(MAGGRP),"PARENT:"_$G(MAGSTORE),$G(MAGDFN),1,"Group Header deleted") + . . . S X="DEL^"_$G(MAGDFN)_"^"_$G(MAGGRP) + . . . D ACTION^MAGGTAU(X,"1") + . . . S Z=+$O(RY(""),-1)+1,RY(Z)=MAGGRP_"^1^Deletion of Group was Successful." + . . . Q + . . Q + . Q + Q +SETDEL(MAGIEN,REASON) ; set deletion fields + N DA,DR,DIE,%H,X + S %H=$H D YMD^%DTC + ; gek - changed 3 slash to 4 slash. to stop FM question marks. ?? + S DR="30////"_DUZ_";30.1////"_X_";30.2////"_REASON + S DIE="2005",DA=MAGIEN D ^DIE + Q + ; +ARCHIVE(MAGARCIE) ;save image data before deletion + N MAGCNT,MAGLAST + S MAGCNT=$P(^MAG(2005.1,0),U,4)+1 + S %X="^MAG(2005,"_MAGARCIE_",",%Y="^MAG(2005.1,"_MAGARCIE_"," + D %XY^%RCR + ; GEK 9/29/00 Fix the 3rd piece to be last ien in file. + S MAGLAST=$O(^MAG(2005.1,"A"),-1) + S $P(^MAG(2005.1,0),U,4)=MAGCNT + I '($P(^MAG(2005.1,0),U,3)=MAGLAST) S $P(^MAG(2005.1,0),U,3)=MAGLAST + S DA=MAGARCIE + S DIK="^MAG(2005.1," D IX1^DIK + Q +DELFILE ;Delete image file on server if exists + ;gek 3/21/2003 Changed to stop using FullRes Path for Abs,Big + ; and only Delete .TXT and Alternates if Full is being deleted. + N X0,X1,X2,ALTEXT,ALTPATH,MAGXX,XBIG + N MAGPLC ; DBI - SEB 9/20/2002 + ; MAGIEN IS ASSUMED TO BE DEFINED. + ; MAGXX - This is IEN in ^MAG(2005, MAGFILEB Expects this to be defined. + ; MAGPLC - "Place" of Full Res Image. + ; ALTEXT - Extension of the Alternate image file. + ; ALTPATH - Full path of Alternate image file. + S X0=^MAG(2005,MAGIEN,0) + ;delete Full Res if one exists on Magnetic + I $P(X0,U,3) D + . S MAGXX=MAGIEN + . S MAGPLC=$$DA2PLC^MAGBAPIP(MAGIEN,"F") + . D VSTNOCP^MAGFILEB + . S X=$$DELETE^MAGBAPI(MAGFILE2,MAGPLC) + . ;Delete any other ALTernate files. ( TXT) + . ;gek 3/31/03 Since ALT files are (for now) always on same server as Full + . ; We only attempt to delete them here (If we have a path to FullRes on Magnetic) + . S X2=0 + . F S X2=$O(^MAG(2006.1,MAGPLC,2,X2)) Q:'X2 D + . . S ALTEXT=^MAG(2006.1,MAGPLC,2,X2,0) + . . S ALTPATH=$P(MAGFILE2,".")_"."_ALTEXT + . . S X=$$DELETE^MAGBAPI(ALTPATH,MAGPLC) + . Q + ; + ;delete image abstract if one exists on Magnetic + I $P(X0,U,4) D + . S MAGXX=MAGIEN + . D ABSNOCP^MAGFILEB + . S X=$$DELETE^MAGBAPI(MAGFILE2,$$DA2PLC^MAGBAPIP(MAGIEN,"A")) ; DBI - SEB 9/20/2002 + ; + ;delete the big file if one exists on Magnetic + S XBIG=$G(^MAG(2005,MAGIEN,"FBIG")) + I $P(XBIG,U) D + . S MAGXX=MAGIEN + . D BIGNOCP^MAGFILEB + . S X=$$DELETE^MAGBAPI(MAGFILE2,$$DA2PLC^MAGBAPIP(MAGIEN,"B")) ; DBI - SEB 9/20/2002 + Q diff --git a/r/IMAGING-MAG-ZMAG/MAGGTII.m b/r/IMAGING-MAG-ZMAG/MAGGTII.m index 473a4cf8..4827d412 100644 --- a/r/IMAGING-MAG-ZMAG/MAGGTII.m +++ b/r/IMAGING-MAG-ZMAG/MAGGTII.m @@ -1,220 +1,204 @@ -MAGGTII ;WOIFO/GEK - RETURN IMAGE INFO ; [ 11/08/2001 17:18 ] - ;;3.0;IMAGING;**8,48,63,59**;Nov 27, 2007;Build 20 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - ; CALL WITH MAGXX=IEN of IMAGE FILE (2005) - ; RETURNS MAGFILE='^' delimited string of Image information. - ; - ; -INFO ;Get info for an Image File entry - ; We assume that MAGXX exists and is the Image File entry - ; We return a '^' delimited string for the Image entry. - ; $P(1^2^3) IEN^Image FullPath and name^Abstract FullPath and Name - ; $P(4) SHORT DESCRIPTION field and desc of offline JukeBox - ; $P(5) PROCEDURE/ EXAM DATE/TIME field - ; $P(6) OBJECT TYPE - ; $P(7) PROCEDURE field - ; $P(8) display date - ; $P(9) to return the PARENT DATA FILE image pointer - ; $p(10) return the ABSTYPE 'M' magnetic 'W' worm 'O' offline - ; $p(11) is 'A' accessible 'O' offline - ; $p(12^13) Dicom Series Number $p(12) and Image Number $p(13) - ; $p(14) is count of images in group, 1 if single image. - ; VISN15 - ; $p(15^16) SiteParameter IEN ^ SiteParameter CODE - ; $P(17) is err description of Integrity Check - ; $P(18) Image BIGPath and name //Patch 5 - ; $P(19^20) Patient DFN ^ Patient Name; // Patch 3.8 - ; $P(21) Image Class: Clin,Admin,Clin/Admin,Admin/Clin - ; $p(22) Date Time Image Saved(FLD 7) - ; $p(23) Document Date (FLD 110) - ; - N FILETYPE,MAGPREF,MAGJBCP,GRPTYPE,GRPIEN,ABSTYPE,MAGTYPE,MAGJBOL - N MAGOFFLN,FULLTYPE,MAGOBJT,MAGQI,X - N ABSFILE,FULLFILE,BIGFILE,PATCH,MDFN,FNL,PLC,PLCODE - N MAGN0,MAGN2,MAGN40,MAGN100 - ; set the Variables for the Global Nodes of the Image Entry - S MAGN0=$G(^MAG(2005,MAGXX,0)) - S MDFN=$P(MAGN0,"^",7) - S MAGN2=$G(^MAG(2005,MAGXX,2)) - S MAGN40=$G(^MAG(2005,MAGXX,40)) - S MAGN100=$G(^MAG(2005,MAGXX,100)) - ; Set Name in Variable, Call $$GET 1 time not 2000 - I MDFN I '$D(MAGJOB("PTNM",MDFN)) S MAGJOB("PTNM",MDFN)=$$GET1^DIQ(2,MDFN_",",.01) - I '$D(MAGJOB("NETPLC")) D NETPLCS^MAGGTU6 - ; Object Type - S MAGOBJT=$P(MAGN0,"^",6) - ; if this is a group, change MAGXX to first image in group to get - ; that abstract to use for the group abstract - I MAGOBJT=11!(MAGOBJT=16) S GRPTYPE=MAGOBJT D - . S X=$O(^MAG(2005,MAGXX,1,0)) - . ; next line to account for group of NO images for whatever reason. - . ; we change Object Type to XRAY (3) or STILL IMAGE (1) - . I 'X S MAGOBJT=$S(MAGOBJT=11:3,MAGOBJT=16:1,1:1) K GRPTYPE Q - . S X=^MAG(2005,MAGXX,1,X,0) - . ; keep the Real IEN, so we can change back later - . S GRPIEN=MAGXX,MAGXX=+X - . Q - S MAGJBCP=0 ; Don't Queue a copy from JukeBox. - ; The call to FINDFILE returns: - ; MAGFILE1=LA100066.ABS filename - ; if no Network Location pointer or INVALID Pointer - ; then MAGFILE1=-1~NO NETWORK LOCATION POINTER - ; or -1~INVALID NETWORK LOCATION POINTER - ; MAGFILE1(.01)=ONE,PATIENT 111223333 image desc - ; MAGJBOL= desc of Offline server - ; MAGOFFLN= if JB is offline - ; MAGPREF=C:\TEMP\LA\10\00\ path - ; MAGTYPE=MAG MAG or WORM - ; - ; first get Full Path and File Name of the Abstract - S FILETYPE="ABSTRACT" K MAGFILE1("ERROR") - S MAGPREF="" D FINDFILE^MAGFILEB - S MAGFILE1=$TR(MAGFILE1,"^","~") ; MAGFILE1 has '^' in it if errors - I $D(MAGFILE1("ERROR")) S MAGFILE1=MAGFILE1("ERROR") - S ABSTYPE=$E(MAGTYPE,1) I MAGOFFLN S ABSTYPE="O" - ; Here we must test for +MAGFILE1 = -1 which means we don't have - ; any entry in the Image File for the Abstract Network Location - ; pointer. - S MAGPREF=$G(MAGPREF) - S ABSFILE=MAGPREF_MAGFILE1 - ; - ; now lets get the Full Path and file name FULL RES image. - S FULLTYPE="A" ; Accessible - S FILETYPE="FULL" K MAGFILE1("ERROR") - S MAGPREF="" D FINDFILE^MAGFILEB - S MAGFILE1=$TR(MAGFILE1,"^","~") ; MAGFILE1 has '^' in it if errors - I $D(MAGFILE1("ERROR")) S MAGFILE1=MAGFILE1("ERROR") - I MAGOFFLN S FULLTYPE="O" ; Offline - ; here we have to do the same test as above. for bad data. - S MAGPREF=$G(MAGPREF) - S FULLFILE=MAGPREF_MAGFILE1 - ; - ; now lets get the Full Path and file name for BIG image. - S FILETYPE="BIG" K MAGFILE1("ERROR") - S MAGPREF="" D FINDFILE^MAGFILEB - S MAGFILE1=$TR(MAGFILE1,"^","~") ; MAGFILE1 has '^' in it if errors - I $D(MAGFILE1("ERROR")) S MAGFILE1=MAGFILE1("ERROR") - S MAGPREF=$G(MAGPREF) - S BIGFILE=$S($E(MAGFILE1,1,2)="-1":"",1:MAGPREF_MAGFILE1) - ; - K MAGFILE1 ; Cleanup - ; Site and Site Code are in Entry of first Image in Group - ; so we need to set here, before MAGXX is changed back. - S X=$G(^MAG(2005,MAGXX,0)) - S FNL=$S(+$P(X,"^",3):$P(X,"^",3),1:+$P(X,"^",5)) - S PLC=$P($G(MAGJOB("NETPLC",FNL)),"^",1) - S PLCODE=$P($G(MAGJOB("NETPLC",FNL)),"^",2) - I PLC="" S PLC=$G(MAGJOB("PLC")),PLCODE=$G(MAGJOB("PLCODE")) ; Group of 0 need this. - ; if we were using first image of a group, reset the Real IEN - I $G(GRPIEN) S MAGXX=GRPIEN - ; - ; we have to change the OBJECT TYPE variable back to real value - ; MAGOBJT might have been changed if we had Group of no images. - ; but we need to keep it changed, because Delphi window checks this - ; entry to determine which window to open. - ; i.e. Group window, Single image window, - S MAGOBJT=$P(MAGN0,U,6) - ; - ; now start building the return string - ; - S PATCH=$P($G(MAGJOB("VERSION")),".",3) ; //'="3.0.8") - K MAGFILE - S $P(MAGFILE,U,25)="" ; We put extra '^^^' on end of String to stop error in Delphi. - ; Pieces 26 BrokerServer and 27 Broker Port are set if this is P59 Client. - ; Clients Prior to Patch 59, the String must only be 25 pieces. - Patch 45 snafu - ; - ; $P(1^2^3) IEN^Image FullPath and name^Abstract FullPath and Name - S $P(MAGFILE,U,1,3)=MAGXX_U_FULLFILE_U_ABSFILE - ; - ; now set $P(4) SHORT DESCRIPTION field and desc of offline JukeBox - S $P(MAGFILE,U,4)=$P(MAGN2,U,4)_$G(MAGJBOL) - ; - ; now set $P(5)PROCEDURE/ EXAM DATE/TIME field - S $P(MAGFILE,U,5)=$P(MAGN2,U,5) - ; - ; now set $P(6) OBJECT TYPE - S $P(MAGFILE,U,6)=MAGOBJT - ; - ; now set $P(7) PROCEDURE field - S $P(MAGFILE,U,7)=$P(MAGN0,U,8) - ; - ; now we're making a DATE to display and will use it for a sort in - ; the delphi TStringGrid so we display mm/dd/yyyy - ; now set $P(8) display date - S X=$$FMTE^XLFDT($P(MAGN2,U,5),"5Z") - S X=$TR(X,"@"," ") - S $P(MAGFILE,U,8)=X - ; - ; now return the PARENT DATA FILE image pointer - S $P(MAGFILE,U,9)=$P(MAGN2,U,8) - ; - ; now return the ABSTYPE ( this is 'M' or 'W' or 'O' ) - ; 'M' magnetic 'W' worm 'O' offline - S $P(MAGFILE,U,10)=ABSTYPE - ; - ; now return the code to show if full res image is offline 'A' or 'O' - ; 'A' accessible 'O' offline - S $P(MAGFILE,U,11)=FULLTYPE - ; - ; 2/1/99 Dicom Series number and Dicom Image Number - ; $p(12) and $p(13) - ; - ; 14 - count of images , if this is a group - S X=+$P($G(^MAG(2005,MAGXX,1,0)),U,4),$P(MAGFILE,U,14)=$S(X:X,1:1) - ; - ; $p(15^16 ) are SiteIEN and SiteCode Consolidation - DBI - ; We use SiteIEN and SiteCODE from above - S $P(MAGFILE,"^",15)=PLC - S $P(MAGFILE,"^",16)=PLCODE - ; - ; $p(17) 8/22/01 GEK Mod for integrity check. - I '$G(MAGNOCHK) D CHK^MAGGSQI(.MAGQI,MAGXX) I 'MAGQI(0) D - . ; remove the Abstract and Image File Names ; 2/14/03 remove c:\program files... with .\bmp\ - . S $P(MAGFILE,U,2,3)="-1~Questionable Data Integrity^.\bmp\imageQA.bmp" - . ;this stops Delphi App from changing Abstract BMP to OFFLINE IMAGE - . S $P(MAGFILE,U,6)=$S(($P(MAGFILE,U,6)'=11):"99",1:11) - . S $P(MAGFILE,U,10)="M" - . ;Send the error message - . S $P(MAGFILE,U,17)=$P(MAGQI(0),U,2) - ; $p(18) is BIGFile Full name and path. - S $P(MAGFILE,U,18)=BIGFILE - ; DFN - S $P(MAGFILE,U,19)=$P(MAGN0,U,7) - ; Patient Name - S $P(MAGFILE,U,20)=$S(MDFN:MAGJOB("PTNM",MDFN),1:MDFN) - S $P(MAGFILE,U,21)=$S(+$P(MAGN40,U,2):$P(^MAG(2005.82,$P(MAGN40,U,2),0),U),1:"") - S X=$$FMTE^XLFDT($P(MAGN2,U,1),"5Z") ; Date/Time Image Saved #7 - S X=$TR(X,"@"," ") - S $P(MAGFILE,U,22)=X - S X=$$FMTE^XLFDT($P(MAGN100,U,6),"5Z") ; DocumentDate #110 - S X=$TR(X,"@"," ") - S $P(MAGFILE,U,23)=X - ; If Patch 59 Client - we can set beyond 25 pieces. - I $D(MAGJOB("RPCSERVER"))&$D(MAGJOB("RPCPORT")) D - . S $P(MAGFILE,U,26)=MAGJOB("RPCSERVER") - . S $P(MAGFILE,U,27)=MAGJOB("RPCPORT") - . S $P(MAGFILE,U,28)="" ; "^" at end, stops problems in delphi - . Q - ; Stop displaying a Group of 1 as a Group, so here we'll change Object type - ; to that of the '1ST' image in the group of 1. - I $P($G(^MAG(2005,MAGXX,1,0)),U,4)=1 D - . S X=$O(^MAG(2005,MAGXX,1,0)) - . S X=+^MAG(2005,MAGXX,1,X,0) - . S $P(MAGFILE,U,6)=$P(^MAG(2005,X,0),U,6) ; OBJECT TYPE OF 1ST IMAGE IN GROUP - . S $P(MAGFILE,U,1)=X - . Q - Q +MAGGTII ;WOIFO/GEK - RETURN IMAGE INFO ; [ 11/08/2001 17:18 ] + ;;3.0;IMAGING;**8,48,63**;Apr 11, 2005 + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + ; CALL WITH MAGXX=IEN of IMAGE FILE (2005) + ; RETURNS MAGFILE='^' delimited string of Image information. + ; + ; +INFO ;Get info for an Image File entry + ; We assume that MAGXX exists and is the Image File entry + ; We return a '^' delimited string for the Image entry. + ; $P(1^2^3) IEN^Image FullPath and name^Abstract FullPath and Name + ; $P(4) SHORT DESCRIPTION field and desc of offline JukeBox + ; $P(5) PROCEDURE/ EXAM DATE/TIME field + ; $P(6) OBJECT TYPE + ; $P(7) PROCEDURE field + ; $P(8) display date + ; $P(9) to return the PARENT DATA FILE image pointer + ; $p(10) return the ABSTYPE 'M' magnetic 'W' worm 'O' offline + ; $p(11) is 'A' accessible 'O' offline + ; $p(12^13) Dicom Series Number $p(12) and Image Number $p(13) + ; $p(14) is count of images in group, 1 if single image. + ; VISN15 + ; $p(15^16) SiteParameter IEN ^ SiteParameter CODE + ; $P(17) is err description of Integrity Check + ; $P(18) Image BIGPath and name //Patch 5 + ; $P(19^20) Patient DFN ^ Patient Name; // Patch 3.8 + ; $P(21) Image Class: Clin,Admin,Clin/Admin,Admin/Clin + ; + N FILETYPE,MAGPREF,MAGJBCP,GRPTYPE,GRPIEN,ABSTYPE,MAGTYPE,MAGJBOL + N MAGOFFLN,FULLTYPE,MAGOBJT,MAGQI,X + N ABSFILE,FULLFILE,BIGFILE,PATCH,MDFN,FNL,PLC,PLCODE + N MAGN0,MAGN2,MAGN40 + ; set the Variables for the Global Nodes of the Image Entry + S MAGN0=$G(^MAG(2005,MAGXX,0)),MDFN=$P(MAGN0,"^",7) ; P48T1 MDFN + S MAGN2=$G(^MAG(2005,MAGXX,2)) + S MAGN40=$G(^MAG(2005,MAGXX,40)) + ; P48T1 Set Name in Variable, Call $$GET 1 time not 2000 + I '$D(MAGJOB("PTNM",MDFN)) S MAGJOB("PTNM",MDFN)=$$GET1^DIQ(2,MDFN_",",.01) + I '$D(MAGJOB("NETPLC")) D NETPLCS^MAGGTU6 + ; Object Type + S MAGOBJT=$P(MAGN0,"^",6) + ; if this is a group, change MAGXX to first image in group to get + ; that abstract to use for the group abstract + I MAGOBJT=11!(MAGOBJT=16) S GRPTYPE=MAGOBJT D + . S X=$O(^MAG(2005,MAGXX,1,0)) + . ; next line to account for group of NO images for whatever reason. + . ; we change Object Type to XRAY (3) or STILL IMAGE (1) + . I 'X S MAGOBJT=$S(MAGOBJT=11:3,MAGOBJT=16:1,1:1) K GRPTYPE Q + . S X=^MAG(2005,MAGXX,1,X,0) + . ; keep the Real IEN, so we can change back later + . S GRPIEN=MAGXX,MAGXX=+X + . Q + S MAGJBCP=0 ; Don't Queue a copy from JukeBox. + ; The call to FINDFILE returns: + ; MAGFILE1=LA100066.ABS filename + ; if no Network Location pointer or INVALID Pointer + ; then MAGFILE1=-1~NO NETWORK LOCATION POINTER + ; or -1~INVALID NETWORK LOCATION POINTER + ; MAGFILE1(.01)=ONE,PATIENT 111223333 image desc + ; MAGJBOL= desc of Offline server + ; MAGOFFLN= if JB is offline + ; MAGPREF=C:\TEMP\LA\10\00\ path + ; MAGTYPE=MAG MAG or WORM + ; + ; first get Full Path and File Name of the Abstract + S FILETYPE="ABSTRACT" K MAGFILE1("ERROR") + S MAGPREF="" D FINDFILE^MAGFILEB + S MAGFILE1=$TR(MAGFILE1,"^","~") ; MAGFILE1 has '^' in it if errors + I $D(MAGFILE1("ERROR")) S MAGFILE1=MAGFILE1("ERROR") + S ABSTYPE=$E(MAGTYPE,1) I MAGOFFLN S ABSTYPE="O" + ; Here we must test for +MAGFILE1 = -1 which means we don't have + ; any entry in the Image File for the Abstract Network Location + ; pointer. + S MAGPREF=$G(MAGPREF) + S ABSFILE=MAGPREF_MAGFILE1 + ; + ; now lets get the Full Path and file name FULL RES image. + S FULLTYPE="A" ; Accessible + S FILETYPE="FULL" K MAGFILE1("ERROR") + S MAGPREF="" D FINDFILE^MAGFILEB + S MAGFILE1=$TR(MAGFILE1,"^","~") ; MAGFILE1 has '^' in it if errors + I $D(MAGFILE1("ERROR")) S MAGFILE1=MAGFILE1("ERROR") + I MAGOFFLN S FULLTYPE="O" ; Offline + ; here we have to do the same test as above. for bad data. + S MAGPREF=$G(MAGPREF) + S FULLFILE=MAGPREF_MAGFILE1 + ; + ; now lets get the Full Path and file name for BIG image. + S FILETYPE="BIG" K MAGFILE1("ERROR") + S MAGPREF="" D FINDFILE^MAGFILEB + S MAGFILE1=$TR(MAGFILE1,"^","~") ; MAGFILE1 has '^' in it if errors + I $D(MAGFILE1("ERROR")) S MAGFILE1=MAGFILE1("ERROR") + S MAGPREF=$G(MAGPREF) + S BIGFILE=$S($E(MAGFILE1,1,2)="-1":"",1:MAGPREF_MAGFILE1) + ; + K MAGFILE1 ; Cleanup + ; Site and Site Code are in Entry of first Image in Group + ; so we need to set here, before MAGXX is changed back. + S X=$G(^MAG(2005,MAGXX,0)) + S FNL=$S(+$P(X,"^",3):$P(X,"^",3),1:+$P(X,"^",5)) + S PLC=$P($G(MAGJOB("NETPLC",FNL)),"^",1) + S PLCODE=$P($G(MAGJOB("NETPLC",FNL)),"^",2) + ; if we were using first image of a group, reset the Real IEN + I $G(GRPIEN) S MAGXX=GRPIEN + ; + ; we have to change the OBJECT TYPE variable back to real value + ; MAGOBJT might have been changed if we had Group of no images. + ; but we need to keep it changed, because Delphi window checks this + ; entry to determine which window to open. + ; i.e. Group window, Single image window, + S MAGOBJT=$P(MAGN0,U,6) + ; + ; now start building the return string + ; + S PATCH=$P($G(MAGJOB("VERSION")),".",3) ; //'="3.0.8") + K MAGFILE + S $P(MAGFILE,U,25)="" ; We put extra '^^^' on end of String to stop error in Delphi. + ; + ; $P(1^2^3) IEN^Image FullPath and name^Abstract FullPath and Name + S $P(MAGFILE,U,1,3)=MAGXX_U_FULLFILE_U_ABSFILE + S $P(MAGFILE,U,18)=BIGFILE + ; + ; now set $P(4) SHORT DESCRIPTION field and desc of offline JukeBox + S $P(MAGFILE,U,4)=$P(MAGN2,U,4)_$G(MAGJBOL) + ; + ; now set $P(5)PROCEDURE/ EXAM DATE/TIME field + S $P(MAGFILE,U,5)=$P(MAGN2,U,5) + ; + ; now set $P(6) OBJECT TYPE + S $P(MAGFILE,U,6)=MAGOBJT + ; + ; now set $P(7) PROCEDURE field + S $P(MAGFILE,U,7)=$P(MAGN0,U,8) + ; + ; now we're making a DATE to display and will use it for a sort in + ; the delphi TStringGrid so we display mm/dd/yyyy + ; now set $P(8) display date + S X=$P($P(MAGN2,"^",5),".",1) + I X'="" S X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_($E(X,1,3)+1700) + S $P(MAGFILE,U,8)=X + ; + ; now return the PARENT DATA FILE image pointer + S $P(MAGFILE,U,9)=$P(MAGN2,U,8) + ; + ; now return the ABSTYPE ( this is 'M' or 'W' or 'O' ) + ; 'M' magnetic 'W' worm 'O' offline + S $P(MAGFILE,U,10)=ABSTYPE + ; + ; now return the code to show if full res image is offline 'A' or 'O' + ; 'A' accessible 'O' offline + S $P(MAGFILE,U,11)=FULLTYPE + ; + ; 2/1/99 Dicom Series number and Dicom Image Number + ; $p(12) and $p(13) + ; + ; lets add the count of images , if this is a group + S X=+$P($G(^MAG(2005,MAGXX,1,0)),U,4),$P(MAGFILE,U,14)=$S(X:X,1:1) + ; + ; $p(15^16 ) are SiteIEN and SiteCode Consolidation - DBI + ; We use SiteIEN and SiteCODE from above + S $P(MAGFILE,"^",15)=PLC + S $P(MAGFILE,"^",16)=PLCODE + ; + ; $p(17) 8/22/01 GEK Mod for integrity check. + I '$G(MAGNOCHK) D CHK^MAGGSQI(.MAGQI,MAGXX) I 'MAGQI(0) D + . ; remove the Abstract and Image File Names ; 2/14/03 remove c:\program files... with .\bmp\ + . S $P(MAGFILE,U,2,3)="-1~Questionable Data Integrity^.\bmp\imageQA.bmp" + . ;this stops Delphi App from changing Abstract BMP to OFFLINE IMAGE + . S $P(MAGFILE,U,6)=$S(($P(MAGFILE,U,6)'=11):"99",1:11) + . S $P(MAGFILE,U,10)="M" + . ;Send the error message + . S $P(MAGFILE,U,17)=$P(MAGQI(0),U,2) + ; $p(18) is BIGFile Full name and path. ( set above) + ; Patches prior to 8, only had 17 pieces of data. this will speed up their listings. + ; Patch 8 had New M rtn MAGSIXG1, if it doesn't exist, this is PRE - 8. + I '$L($T(PGI^MAGSIXG1)) Q + S $P(MAGFILE,U,19)=$P(MAGN0,U,7) ; DFN + ; P48T1 The change to speed up access to large groups left out patient name. + ;S $P(MAGFILE,U,20)=$$GET1^DIQ(2,$P(MAGN0,U,7)_",",.01) ; Patient Name + S $P(MAGFILE,U,20)=MAGJOB("PTNM",MDFN) + S $P(MAGFILE,U,21)=$S(+$P(MAGN40,U,2):$P(^MAG(2005.82,$P(MAGN40,U,2),0),U),1:"") + ; Stop displaying a Group of 1 as a Group, so here we'll change Object type + ; to that of the '1ST' image in the group of 1. + I $P($G(^MAG(2005,MAGXX,1,0)),U,4)=1 D + . S X=$O(^MAG(2005,MAGXX,1,0)) + . S X=+^MAG(2005,MAGXX,1,X,0) + . S $P(MAGFILE,U,6)=$P(^MAG(2005,X,0),U,6) ; OBJECT TYPE OF 1ST IMAGE IN GROUP + . S $P(MAGFILE,U,1)=X + . ; Need Site and Site code of + Q diff --git a/r/IMAGING-MAG-ZMAG/MAGGTLB1.m b/r/IMAGING-MAG-ZMAG/MAGGTLB1.m index ef06fc26..db82f0b1 100644 --- a/r/IMAGING-MAG-ZMAG/MAGGTLB1.m +++ b/r/IMAGING-MAG-ZMAG/MAGGTLB1.m @@ -1,121 +1,120 @@ -MAGGTLB1 ;WOIFO/LB - RPC routine for Imaging Lab Interface ; [ 06/20/2001 08:56 ] - ;;3.0;IMAGING;**59**;Nov 27, 2007;Build 20 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q - ;This routine is called from the Laboratory Image capture window. - ;After an image is captured and an entry is created in file 2005, - ;this routine will be called to set the imaging pointers in the - ;corresponding Lab subfile (Autopsy/ Organism, Surgical Path, EM, - ;or Cytology) and update the imaging file with the corresponding - ;Lab pointers. -FILE(MAGRY,IMIEN,DATA) ;RPC Call to file pointers in Lab and Image files. - ;IMIEN - ^MAG(2005,IMIEN image captured. - ;DATA - piece 1 = stain piece 2 = micro obj - ; 3 = Pt name 4 = ssn - ; 5 = date/time 6 = acc# - ; 7 = Pathologist 8 = specimen desc. - ; 9 = lab section 10 = dfn - ; 11 = lrdfn 12 = lri - ; 13 = spec ien 14 = field# - ; 15 = global root e.g. ^LR(1,"SP",7069758,1,1 - ;DATA is the result of START^MAGGTLB (the specimen variable during the - ;image capture window). - ;Will return a single value on filing success. - ; - IF $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGGTERR" - E S X="ERR^MAGGTERR",@^%ZOSF("TRAP") - ; - N ANUM,DA,DA1,DAS,DFN,DIERR,FIELD,I,IMOBJ,LABD,LABFDA,LABIEN,LABIENS - N LRDFN,LRI,MAGFDA,MAGIEN,MAGNODE,OUT,SECT,SECTLTR,SPEC,SPECD - N SSUBFILE,SSUBFL,STAIN,SUBFILE,X,Y - S MAGRY="0^Started filing",MAGIEN=IMIEN - S SECT=$P(DATA,"^",9),DFN=$P(DATA,"^",10),LRDFN=$P(DATA,"^",11) - S LRI=$P(DATA,"^",12) - S SPEC=$P(DATA,"^",13),FIELD=$P(DATA,"^",14) - S MAGNODE="^"_$P(DATA,"^",15,99),ANUM=$P(DATA,"^",6) - S SPECD=$P(DATA,"^",8),STAIN=$P(DATA,"^",1),IMOBJ=$P(DATA,"^",2) - I SECT["~" S SECT=$P(SECT,"~",1) - ;Check for valid image - I '$D(^MAG(2005,MAGIEN,0)) D Q - . S Y(0)="0^Image entry does not exist." - ;Check for valid image patient entry. - I $P(^MAG(2005,MAGIEN,0),"^",7)'=DFN D Q - . S MAGRY="0^Image patient does not match Lab patient." - ;Check if parent file and corresponding fields are filed in file 2005. - I $D(^MAG(2005,MAGIEN,2)) S X=^MAG(2005,MAGIEN,2) D Q:OUT - . S OUT=0 - . I $P(X,"^",6),$P(X,"^",7),$P(X,"^",8) S OUT=1 - . I OUT S MAGRY="0^Report already exist for this image." - ;Check the Lab entries...do they still exists. - S MAGNODE=MAGNODE_",0)" - I '$D(@MAGNODE) S MAGRY="0^Specimen no longer in Lab file." Q - ;Everything seem okay lets file image pointer in lab file. - S SECTLTR=$S(SECT=63:"AY",SECT=63.2:"AY",1:$P(^MAG(2005.03,SECT,0),"^",2)) - ;Lab nodes; AY, SP, EM or CY. - ; -LAB2 ;updating files using silent Fileman DB calls. - N MAGERR,MAGLVL - S SUBFILE=$S(SECT=63:63.2,1:SECT) - S MAGRY="0^Lab's Imaging subfile doesn't exisit." ;default - ;Laboratory's Autopsy subfile has two imaging fields (2005 & 2005.1) - ; and file 2005.03 does not reflect this. - D FIELD^DID(SUBFILE,FIELD,"","SPECIFIER","MAGLVL","MAGERR") - I $D(MAGERR("DIERR")) Q - I '$D(MAGLVL("SPECIFIER")) Q - S SSUBFL=$G(MAGLVL("SPECIFIER")) ;Lab's Imaging subfile - I SSUBFL="" Q - ;Image sub-subfile. - S SSUBFILE="" F I=1:1:$L(SSUBFL) D - . I $E(SSUBFL,I)?1N!($E(SSUBFL,I)?1".") S SSUBFILE=SSUBFILE_$E(SSUBFL,I) - . ;Leave off the alpha characters - S DA1=$S(SECTLTR="AY":SPEC,1:LRI) ;Autopsy is by specimen not date/time - S DAS="+3,"_DA1_","_LRDFN_"," - ;Sets the iens e.g. da,da(1),da(2). The +3 can be any #; it is the - ;subscript of the return variable LABIENS. - ;Returns IEN for that subfile & use of +3 is because it's 2 levels down. - S LABFDA(SSUBFILE,DAS,.01)=MAGIEN,LABIENS="" - D UPDATE^DIE("S","LABFDA","LABIENS") - I $D(DIERR) S MAGRY="O^Unsuccessful Lab updating." Q - I '$D(LABIENS(3)) S MAGRY="0^Unsuccessful Lab updating" Q - S DA=$G(LABIENS(3)) - I 'DA!('$D(^LR(LRDFN,SECTLTR,DA1,FIELD,DA,0))) D Q - . S MAGRY="0^Unsuccessful Lab updating" -IMAGE2 ; - S MAGIEN=MAGIEN_",",LABIEN=DA,LABD=DA1 K DA,DA1 - ; The following fields are saved in the ADDIMAGE Call. - ; 50 =ANUM ;ACCESSION NUMBER FIELD - ; 51 =SPECD ;SPECIMEN DESCRIPTION FIELD - ; 52 =SPEC ;SPECIMEN DO - ; 53 =STAIN ;Histology stain - ; 54 =IMOBJ ;MICROSCOPE OBJECTIVE - N DIK - S MAGFDA(2005,MAGIEN,16)=SECT ;LAB SECTION - S MAGFDA(2005,MAGIEN,17)=LRDFN ;PARENT FILE DO VALUE - S MAGFDA(2005,MAGIEN,18)=LABIEN ;LAB BACKWARD IMAGE POINTER - S MAGFDA(2005,MAGIEN,63)=LABD ;If AUTOPSY, it's specimen else date/time - S I=0 F I=$O(MAGFDA(2005,MAGIEN,I)) Q:'I D - . D UPDATE^DIE("S","MAGFDA","") - I $D(DIERR) S I=0 F S I=$O(MAGFDA(2005,MAGIEN,I)) Q:'I D - . S MAGFDA(2005,MAGIEN,I)="" D UPDATE^DIE("","MAGFDA","") - I $D(DIERR),$D(^LR(LRDFN,SECTLTR,DA1,FIELD,LABIEN,0)),$G(^LR(LRDFN,SECTLTR,DA1,FIELD,LABIEN,0))=MAGIEN D - . S DA(2)=LRDFN,DA(1)=DA1,DA=LABIEN - . S DIK="^LR("_LRDFN_","""_SECTLTR_""","_DA1_","_FIELD_"," - . D ^DIK ;Remove imaging pointers from lab subfile. - I $D(DIERR) S MAGRY="0^Unsuccessful both files not updated." K DIERR Q - S MAGRY="1^Success in filing both parent & image files." K DIERR - D LINKDT^MAGGTU6(.X,+MAGIEN) - Q +MAGGTLB1 ;WOIFO/LB - RPC routine for Imaging Lab Interface ; [ 06/20/2001 08:56 ] + ;;3.0;IMAGING;;Mar 01, 2002 + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q + ;This routine is called from the Laboratory Image capture window. + ;After an image is captured and an entry is created in file 2005, + ;this routine will be called to set the imaging pointers in the + ;corresponding Lab subfile (Autopsy/ Organism, Surgical Path, EM, + ;or Cytology) and update the imaging file with the corresponding + ;Lab pointers. +FILE(MAGRY,IMIEN,DATA) ;RPC Call to file pointers in Lab and Image files. + ;IMIEN - ^MAG(2005,IMIEN image captured. + ;DATA - piece 1 = stain piece 2 = micro obj + ; 3 = Pt name 4 = ssn + ; 5 = date/time 6 = acc# + ; 7 = Pathologist 8 = specimen desc. + ; 9 = lab section 10 = dfn + ; 11 = lrdfn 12 = lri + ; 13 = spec ien 14 = field# + ; 15 = global root e.g. ^LR(1,"SP",7069758,1,1 + ;DATA is the result of START^MAGGTLB (the specimen variable during the + ;image capture window). + ;Will return a single value on filing success. + ; + IF $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGGTERR" + E S X="ERR^MAGGTERR",@^%ZOSF("TRAP") + ; + N ANUM,DA,DA1,DAS,DFN,DIERR,FIELD,I,IMOBJ,LABD,LABFDA,LABIEN,LABIENS + N LRDFN,LRI,MAGFDA,MAGIEN,MAGNODE,OUT,SECT,SECTLTR,SPEC,SPECD + N SSUBFILE,SSUBFL,STAIN,SUBFILE,X,Y + S MAGRY="0^Started filing",MAGIEN=IMIEN + S SECT=$P(DATA,"^",9),DFN=$P(DATA,"^",10),LRDFN=$P(DATA,"^",11) + S LRI=$P(DATA,"^",12) + S SPEC=$P(DATA,"^",13),FIELD=$P(DATA,"^",14) + S MAGNODE="^"_$P(DATA,"^",15,99),ANUM=$P(DATA,"^",6) + S SPECD=$P(DATA,"^",8),STAIN=$P(DATA,"^",1),IMOBJ=$P(DATA,"^",2) + I SECT["~" S SECT=$P(SECT,"~",1) + ;Check for valid image + I '$D(^MAG(2005,MAGIEN,0)) D Q + . S Y(0)="0^Image entry does not exist." + ;Check for valid image patient entry. + I $P(^MAG(2005,MAGIEN,0),"^",7)'=DFN D Q + . S MAGRY="0^Image patient does not match Lab patient." + ;Check if parent file and corresponding fields are filed in file 2005. + I $D(^MAG(2005,MAGIEN,2)) S X=^MAG(2005,MAGIEN,2) D Q:OUT + . S OUT=0 + . I $P(X,"^",6),$P(X,"^",7),$P(X,"^",8) S OUT=1 + . I OUT S MAGRY="0^Report already exist for this image." + ;Check the Lab entries...do they still exists. + S MAGNODE=MAGNODE_",0)" + I '$D(@MAGNODE) S MAGRY="0^Specimen no longer in Lab file." Q + ;Everything seem okay lets file image pointer in lab file. + S SECTLTR=$S(SECT=63:"AY",SECT=63.2:"AY",1:$P(^MAG(2005.03,SECT,0),"^",2)) + ;Lab nodes; AY, SP, EM or CY. + ; +LAB2 ;updating files using silent Fileman DB calls. + N MAGERR,MAGLVL + S SUBFILE=$S(SECT=63:63.2,1:SECT) + S MAGRY="0^Lab's Imaging subfile doesn't exisit." ;default + ;Laboratory's Autopsy subfile has two imaging fields (2005 & 2005.1) + ; and file 2005.03 does not reflect this. + D FIELD^DID(SUBFILE,FIELD,"","SPECIFIER","MAGLVL","MAGERR") + I $D(MAGERR("DIERR")) Q + I '$D(MAGLVL("SPECIFIER")) Q + S SSUBFL=$G(MAGLVL("SPECIFIER")) ;Lab's Imaging subfile + I SSUBFL="" Q + ;Image sub-subfile. + S SSUBFILE="" F I=1:1:$L(SSUBFL) D + . I $E(SSUBFL,I)?1N!($E(SSUBFL,I)?1".") S SSUBFILE=SSUBFILE_$E(SSUBFL,I) + . ;Leave off the alpha characters + S DA1=$S(SECTLTR="AY":SPEC,1:LRI) ;Autopsy is by specimen not date/time + S DAS="+3,"_DA1_","_LRDFN_"," + ;Sets the iens e.g. da,da(1),da(2). The +3 can be any #; it is the + ;subscript of the return variable LABIENS. + ;Returns IEN for that subfile & use of +3 is because it's 2 levels down. + S LABFDA(SSUBFILE,DAS,.01)=MAGIEN,LABIENS="" + D UPDATE^DIE("S","LABFDA","LABIENS") + I $D(DIERR) S MAGRY="O^Unsuccessful Lab updating." Q + I '$D(LABIENS(3)) S MAGRY="0^Unsuccessful Lab updating" Q + S DA=$G(LABIENS(3)) + I 'DA!('$D(^LR(LRDFN,SECTLTR,DA1,FIELD,DA,0))) D Q + . S MAGRY="0^Unsuccessful Lab updating" +IMAGE2 ; + S MAGIEN=MAGIEN_",",LABIEN=DA,LABD=DA1 K DA,DA1 + ; The following fields are saved in the ADDIMAGE Call. + ; 50 =ANUM ;ACCESSION NUMBER FIELD + ; 51 =SPECD ;SPECIMEN DESCRIPTION FIELD + ; 52 =SPEC ;SPECIMEN DO + ; 53 =STAIN ;Histology stain + ; 54 =IMOBJ ;MICROSCOPE OBJECTIVE + N DIK + S MAGFDA(2005,MAGIEN,16)=SECT ;LAB SECTION + S MAGFDA(2005,MAGIEN,17)=LRDFN ;PARENT FILE DO VALUE + S MAGFDA(2005,MAGIEN,18)=LABIEN ;LAB BACKWARD IMAGE POINTER + S MAGFDA(2005,MAGIEN,63)=LABD ;If AUTOPSY, it's specimen else date/time + S I=0 F I=$O(MAGFDA(2005,MAGIEN,I)) Q:'I D + . D UPDATE^DIE("S","MAGFDA","") + I $D(DIERR) S I=0 F S I=$O(MAGFDA(2005,MAGIEN,I)) Q:'I D + . S MAGFDA(2005,MAGIEN,I)="" D UPDATE^DIE("","MAGFDA","") + I $D(DIERR),$D(^LR(LRDFN,SECTLTR,DA1,FIELD,LABIEN,0)),$G(^LR(LRDFN,SECTLTR,DA1,FIELD,LABIEN,0))=MAGIEN D + . S DA(2)=LRDFN,DA(1)=DA1,DA=LABIEN + . S DIK="^LR("_LRDFN_","""_SECTLTR_""","_DA1_","_FIELD_"," + . D ^DIK ;Remove imaging pointers from lab subfile. + I $D(DIERR) S MAGRY="0^Unsuccessful both files not updated." K DIERR Q + S MAGRY="1^Success in filing both parent & image files." K DIERR + Q diff --git a/r/IMAGING-MAG-ZMAG/MAGGTMC1.m b/r/IMAGING-MAG-ZMAG/MAGGTMC1.m index ec5157e9..04c0ae57 100644 --- a/r/IMAGING-MAG-ZMAG/MAGGTMC1.m +++ b/r/IMAGING-MAG-ZMAG/MAGGTMC1.m @@ -1,82 +1,80 @@ -MAGGTMC1 ;WOIFO/GEK - RPC Calls for Imaging/Medicine procedures ; [ 06/20/2001 08:57 ] - ;;3.0;IMAGING;**59**;Nov 27, 2007;Build 20 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q -FILE(MAGRY,DATA,MAGARR) ;RPC Call to File the Image pointer into - ; the Procedure/Subspecialty and Proc/Subspec into Image file. - ; - ; DATA = DATETIME^PSIEN^DFN^MCIEN^PROCSTUB ; 6/19/97 - ; If MCIEN isn't sent, this will be added as new procedure - ; MAGARR is array of image pointers - ; IF PROCSTUB is 1 we JUST want New Medicine procedure stub IEN 6/19/97 - ; as the success i.e. MAGRY="IEN^Procdure Stub created" 6/19/97 - IF $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGGTERR" - E S X="ERR^MAGGTERR",@^%ZOSF("TRAP") - N I,J,K,X,Y,Z,TIME,PSIEN,DFN,MAGPTR,MAGMCIEN,MCFILE,MAGOK,MAGERR,PROCSTUB - ; - S X=$P(DATA,U,1),%DT="TS" D ^%DT S TIME=Y - S PSIEN=+$P(DATA,U,2) - S DFN=+$P(DATA,U,3) - S MAGMCIEN=+$P(DATA,U,4) - S PROCSTUB=+$P(DATA,U,5) ; NEW 6/19/97 GEK - S MCFILE=$P($P(^MCAR(697.2,PSIEN,0),U,2),"(",2) - I '$D(^MAG(2005.03,MCFILE)) S MAGRY="0^Procedure file is Invalid in Imaging Parent Data File " Q - S MAGOK="" - S I="" F S I=$O(MAGARR(I)) Q:I="" D - . S MAGPTR(I)="" - . I '$D(^MAG(2005,I)) S MAGERR="0^INVALID Image entry "_I - I $D(MAGERR) S MAGRY=MAGERR Q - ; 6/19/97 New Note .MAGMCIEN - D UPDATE^MCUIMAG0(TIME,PSIEN,DFN,.MAGPTR,.MAGMCIEN,.MAGOK) - ; - I 'MAGOK S MAGRY=MAGOK Q - ; Next if we're getting a stub, Quit with the stub if it was created - I MAGOK,PROCSTUB D Q - . I MAGMCIEN<1 S MAGRY="0^FAILED Creating New Procedure stub"_MAGOK Q - . S MAGRY=$P(MAGMCIEN,U,1)_"^Procedure Stub created" - ; - ; now enter the pointers to procedures, in the image file. - ; we get back MAGPTR(I)= MCFILE^PSIEN^MULTIPLE ENTRY IEN - S I="" F S I=$O(MAGPTR(I)) Q:I="" D - . S $P(^MAG(2005,I,2),U,6,8)=MAGPTR(I) - . D LINKDT^MAGGTU6(.X,I) - S MAGRY=MAGOK - Q - ;/GEK/ 4/29/98 put in modification to return DICOM ID for MED proc. -DICOMID(MAGRY,DATA) ;RPC Call to return a Dicom ID for medicine procedure. - ; This is displayed on workstation, and used to link Dicom images - ; to a medicine procedure. - ; DATA is null ^ PSIEN ^ DFN ^ MCIEN ^ null - ; - N TMCFILE,TPSIEN,TDFN,TMCIEN,RETX - S TPSIEN=+$P(DATA,U,2) - S TDFN=+$P(DATA,U,3) - S TMCIEN=+$P(DATA,U,4) - S TMCFILE=$P($P($G(^MCAR(697.2,TPSIEN,0)),U,2),"(",2) - I 'TMCFILE S MAGRY="0^InValid data input PSIEN="_TPSIEN Q - D DICOMID^MAGDMEDI(.RETX,TMCFILE,TMCIEN,TPSIEN,TDFN) - S MAGRY=RETX - Q -NEW(MAGRY,DATA) ;RPC call to Create NEW Procedure stub - ; for a medicine procedure - ; - ; DATA = DATETIME^PSIEN^DFN ; same as old call - S $P(DATA,"^",4)="^1" ; the 1 means we want a new procedure stub - K MAGARR ; we are not passing any images. - D FILE(.MAGRY,DATA,.MAGARR) - Q +MAGGTMC1 ;WOIFO/GEK - RPC Calls for Imaging/Medicine procedures ; [ 06/20/2001 08:57 ] + ;;3.0;IMAGING;;Mar 01, 2002 + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q +FILE(MAGRY,DATA,MAGARR) ;RPC Call to File the Image pointer into + ; the Procedure/Subspecialty and Proc/Subspec into Image file. + ; + ; DATA = DATETIME^PSIEN^DFN^MCIEN^PROCSTUB ; 6/19/97 + ; If MCIEN isn't sent, this will be added as new procedure + ; MAGARR is array of image pointers + ; IF PROCSTUB is 1 we JUST want New Medicine procedure stub IEN 6/19/97 + ; as the success i.e. MAGRY="IEN^Procdure Stub created" 6/19/97 + IF $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGGTERR" + E S X="ERR^MAGGTERR",@^%ZOSF("TRAP") + N I,J,K,X,Y,Z,TIME,PSIEN,DFN,MAGPTR,MAGMCIEN,MCFILE,MAGOK,MAGERR + ; + S X=$P(DATA,U,1),%DT="TS" D ^%DT S TIME=Y + S PSIEN=+$P(DATA,U,2) + S DFN=+$P(DATA,U,3) + S MAGMCIEN=+$P(DATA,U,4) + S PROCSTUB=+$P(DATA,U,5) ; NEW 6/19/97 GEK + S MCFILE=$P($P(^MCAR(697.2,PSIEN,0),U,2),"(",2) + I '$D(^MAG(2005.03,MCFILE)) S MAGRY="0^Procedure file is Invalid in Imaging Parent Data File " Q + S MAGOK="" + S I="" F S I=$O(MAGARR(I)) Q:I="" D + . S MAGPTR(I)="" + . I '$D(^MAG(2005,I)) S MAGERR="0^INVALID Image entry "_I + I $D(MAGERR) S MAGRY=MAGERR Q + ; 6/19/97 New Note .MAGMCIEN + D UPDATE^MCUIMAG0(TIME,PSIEN,DFN,.MAGPTR,.MAGMCIEN,.MAGOK) + ; + I 'MAGOK S MAGRY=MAGOK Q + ; Next if we're getting a stub, Quit with the stub if it was created + I MAGOK,PROCSTUB D Q + . I MAGMCIEN<1 S MAGRY="0^FAILED Creating New Procedure stub"_MAGOK Q + . S MAGRY=$P(MAGMCIEN,U,1)_"^Procedure Stub created" + ; + ; now enter the pointers to procedures, in the image file. + ; we get back MAGPTR(I)= MCFILE^PSIEN^MULTIPLE ENTRY IEN + S I="" F S I=$O(MAGPTR(I)) Q:I="" D + . S $P(^MAG(2005,I,2),U,6,8)=MAGPTR(I) + S MAGRY=MAGOK + Q + ;/GEK/ 4/29/98 put in modification to return DICOM ID for MED proc. +DICOMID(MAGRY,DATA) ;RPC Call to return a Dicom ID for medicine procedure. + ; This is displayed on workstation, and used to link Dicom images + ; to a medicine procedure. + ; DATA is null ^ PSIEN ^ DFN ^ MCIEN ^ null + ; + N TMCFILE,TPSIEN,TDFN,TMCIEN + S TPSIEN=+$P(DATA,U,2) + S TDFN=+$P(DATA,U,3) + S TMCIEN=+$P(DATA,U,4) + S TMCFILE=$P($P($G(^MCAR(697.2,TPSIEN,0)),U,2),"(",2) + I 'TMCFILE S MAGRY="0^InValid data input PSIEN="_TPSIEN Q + D DICOMID^MAGDMEDI(.RETX,TMCFILE,TMCIEN,TPSIEN,TDFN) + S MAGRY=RETX + Q +NEW(MAGRY,DATA) ;RPC call to Create NEW Procedure stub + ; for a medicine procedure + ; + ; DATA = DATETIME^PSIEN^DFN ; same as old call + S $P(DATA,"^",4)="^1" ; the 1 means we want a new procedure stub + K MAGARR ; we are not passing any images. + D FILE(.MAGRY,DATA,.MAGARR) + Q diff --git a/r/IMAGING-MAG-ZMAG/MAGGTPT1.m b/r/IMAGING-MAG-ZMAG/MAGGTPT1.m index e1845339..53cd146a 100644 --- a/r/IMAGING-MAG-ZMAG/MAGGTPT1.m +++ b/r/IMAGING-MAG-ZMAG/MAGGTPT1.m @@ -1,171 +1,171 @@ -MAGGTPT1 ;WOIFO/GEK - Delphi-Broker calls for patient lookup and information ; [ 06/20/2001 08:57 ] - ;;3.0;IMAGING;**16,8,92,46,59**;Nov 27, 2007;Build 20 - ;; Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q - ; -FIND(MAGRY,ZY) ;RPC [MAGG PAT FIND] - ; Call to Do a lookup using FIND^DIC - ; MAGRY is the Array to return. - ; ZY is parameter sent by calling app (Delphi) - ; FILE NUM ^ NUM TO RETURN ^ TEXT TO MATCH ^ ^ SCREEN ($P 5-99) - N $ETRAP,$ESTACK S $ETRAP="D ERRA^MAGGTERR" - ; - N X,Y,I,Z,MAGDFN,WARD - N FILE,IENS,FLDS,FLAGS,VAL,NUM,INDEX,SCR,IDENT,TROOT - S (FILE,IENS,FLDS,FLAGS,VAL,NUM,INDEX,SCR,IDENT,TROOT)="" - ; - S FILE=2 ; Patient File - ; Number of entries to return, If 0 we'll stop at 100 - S NUM=$S(+$P(ZY,U,1):+$P(ZY,U,1),1:100) - S VAL=$P(ZY,U,2) ; this is the starting value i.e. 'Smi' - S SCR=$P(ZY,U,5,99) - S FLDS=$P(ZY,U,3) - ; $P(ZU,U,4) isn't used. - ; If specific fields aren't requested, - ; Get Identifiers, and ward as FLDS - ;I '$L(FLDS) S FLDS=FLDS_";.1;.03;.09;.301;391" - I '$L(FLDS) S FLDS=FLDS_";.1;.301;391" - ; we'll add ACN to the index to search, for ward - ; for speed we'll decide which xref to use - S INDEX=$S(VAL?9N:"SSN^ACN",VAL?1U1.N:"BS5^ACN",1:"B^ACN") - ; - K ^TMP("DILIST",$J) - K ^TMP("DIERR",$J) - ; VAL is the initial value to search for. i.e. the user input. - ; Next line is to stop the FM Infinite Error Trap problem. - I $L(VAL)>30 S MAGRY(0)="0^Invalid: Input '"_$E(VAL,1,40)_"...' is too long. "_$L(VAL)_" characters." Q - D FIND^DIC(FILE,IENS,FLDS,FLAGS,VAL,NUM,INDEX,SCR,IDENT,TROOT) - ; - ; if no Match or ERROR we return 0 as 1st '^' piece. - ; - I '$D(^TMP("DILIST",$J,1)) S I=1 D Q - . I $D(^TMP("DIERR",$J)) D FINDERR(I) Q - . S MAGRY(I)="NO MATCH for lookup on """_$P(ZY,"^",2)_"""" - ; - ; so we have some matches, (BUT we could still have an error) - ; so first list all matches, then the Errors, if any. - S I="" F S I=$O(^TMP("DILIST",$J,1,I)) Q:I="" D - . S X=^TMP("DILIST",$J,1,I) ; Name - . S MAGDFN=^TMP("DILIST",$J,2,I) ; DFN - . ; - . S WARD=^TMP("DILIST",$J,"ID",I,.1) - . K ^TMP("DILIST",$J,"ID",I,.1) - . I $E(WARD,1,$L(VAL))=VAL S X=WARD_" "_X - . ; - . S X=X_" "_$$DOB^DPTLK1(MAGDFN)_" "_$$SSN^DPTLK1(MAGDFN) - . S Z=0 - . ; We are displaying other identifiers with each patient. - . F S Z=$O(^TMP("DILIST",$J,"ID",I,Z)) Q:Z="" S X=X_" "_^(Z) - . S MAGRY(I)=X_"^"_+MAGDFN - ; - I $D(^TMP("DIERR",$J)) D FINDERR() Q - I '$D(^TMP("DILIST",$J,0)) Q - S X=^TMP("DILIST",$J,0) - S I=$O(MAGRY(""),-1)+1 - S MAGRY(0)="Found "_$P(X,"^")_" entr"_$S((+X=1):"y",1:"ies")_" matching """_$P(ZY,"^",3)_"""" - I $P(X,"^",3)>0 S MAGRY(0)=MAGRY(0)_" there are more" - Q -FINDERR(XI) ; - I '+$G(XI) S XI=$O(MAGRY(""),-1)+1 - S MAGRY(XI)="ERROR^"_^TMP("DIERR",$J,1,"TEXT",1) - Q -INFO(MAGRY,DATA) ;RPC [MAGG PAT INFO] Call to Return patient info. - ; Input parameters - ; DATA: MAGDFN ^ NOLOG ^ ISICN - ; MAGDFN -- Patient DFN - ; NOLOG -- 0/1; if 1, then do NOT update the Session log - ; ISICN -- 0/1 if 1, then this is an ICN, if 0 (default) this is a DFN ; Patch 41 - ; MAGRY is a string, we return the following : - ; //$P 1 2 3 4 5 6 7 8 9 10 - ; // status ^ DFN ^ name ^ sex ^ DOB ^ SSN ^ S/C ^ TYPE ^ Veteran(y/n) ^ Patient Image Count - ; //$P 11 12 13 - ; ICN SITE Number ^ Production Account 1/0 - ; VADM(1)=Patient's name - ; VADM(5)=Patient's sex (M^MALE) - ; VADM(3)=Patient's DOB (internal^external) - ; VADM(2)=Patient's SSN (internal^external) - ; VAEL(3)=Patient's Service Connected? (#.301) (1=yes) - ; VAEL(4)=Patient's Veteran Y/N (#1901) (1=yes) - ; VAEL(6)=Patient's Type (#391) (internal^external) - ; - N MAGDFN,DFN,X,NOLOG,VADM,VAEL,VAERR,ISICN - S MAGDFN=$P(DATA,U),NOLOG=+$P(DATA,U,2),ISICN=+$P(DATA,U,3) - I ISICN D GETDFN^VAFCTFU1(.DFN,MAGDFN) - E S DFN=+MAGDFN - D DEM^VADPT,ELIG^VADPT - I VAERR S MAGRY="0^"_"Entry not found in Patient file." Q - S X=$TR($$FMTE^XLFDT($P(VADM(3),"^"),"2FD")," ",0) - ; // status ^ DFN ^ name ^ sex ^ DOB ^ SSN ^ S/C ^ TYPE ^ Veteran(y/n) ^ Patient Image Count - S $P(MAGRY,"^",1,2)="1^"_DFN - ; Fields: NAME, SEX, DATE OF BIRTH, SSN - S $P(MAGRY,"^",3,6)=$G(VADM(1))_"^"_$P(VADM(5),"^",2)_"^"_X_"^"_$P(VADM(2),"^") - ; Fields: Service Connected?, Type, Veteran Y/N? - S $P(MAGRY,"^",7,9)=$S(+VAEL(3):"YES",1:"")_"^"_$P(VAEL(6),"^",2)_"^"_$S(+VAEL(4):"YES",1:"") - ; Fields: Patient Image Count - S $P(MAGRY,"^",10)=$$IMGCT(DFN)_"^" - ; Additions. for Patch 41 - ; Fields : Patient ICN - S $P(MAGRY,"^",11)=$$GETICN^MPIF001(DFN) - S X=$$SITE^VASITE - ; Fields: Site Number Prod Acct - S $P(MAGRY,"^",12)=$P($G(X),"^",3)_"^"_"1" ; We'll default to Production Account = Yes. - ; NEED KERNEL PATCH XU*8.0*284 FOR PROD^XUPROD - ; Fields : the Actual value for Prod Acct - I $L($T(PROD^XUPROD)) S $P(MAGRY,"^",13)=+$$PROD^XUPROD - S $P(MAGRY,"^",14)="^" - ; AGE - S $P(MAGRY,"^",15)=VADM(4)_"^" - D KVAR^VADPT,KVA^VADPT - I NOLOG ; Don't update session log - ; We'll track DFN:ICN - E D ACTION^MAGGTAU("PAT^"_DFN_$S(ISICN:"-"_MAGDFN,1:"")) - Q -IMGCT(DFN) ; RETURN TOTAL NUMBER OF IMAGES FOR A PATIENT; - ; - N I,CT,RDT,PRX,IEN - S CT=0 - S RDT="" F S RDT=$O(^MAG(2005,"APDTPX",DFN,RDT)) Q:RDT="" D - . S PRX="" F S PRX=$O(^MAG(2005,"APDTPX",DFN,RDT,PRX)) Q:PRX="" D - . . S IEN="" F S IEN=$O(^MAG(2005,"APDTPX",DFN,RDT,PRX,IEN)) Q:IEN="" S CT=CT+1 - Q CT -BS5CHK(MAGRY,MAGDFN) ;RPC [MAGG PAT BS5 CHECK] - ; Call to check the BS5 cross ref - ; and see if any similar patients exist. - ; If yes, all matching patients will be listed and shown to the user. - ; - N MAGX,MAGDPT,XDFN,XSSN,CT,LNTH - S LNTH=0 - S MAGRY(1)="-1^Error checking cross reference" - D GUIBS5A^DPTLK6(.MAGRY,MAGDFN) - I MAGRY(1)=0 Q - S CT=$O(MAGRY(""),-1)+1 - S MAGRY(CT)=MAGRY(CT-1),MAGRY(CT-1)="0^ " - S I="" F S I=$O(MAGRY(I)) Q:'I D - . I $P(MAGRY(I),U)=0 Q - . I $L($P(MAGRY(I),U,3))>LNTH S LNTH=$L($P(MAGRY(I),U,3)) - S LNTH=LNTH+1 - S I=1 F S I=$O(MAGRY(I)) Q:'I D - . I $P(MAGRY(I),U)="0" S MAGRY(I)=$P(MAGRY(I),U,2) Q - . S XDFN=$P(MAGRY(I),U,2) - . I +XDFN=+MAGDFN S MAGX=" >>>>>> " - . E S MAGX=" " - . S XSSN=$$SSN^DPTLK1(XDFN) I XSSN?9N S XSSN=$E(XSSN,1,3)_"-"_$E(XSSN,4,5)_"-"_$E(XSSN,6,9) - . S MAGDPT=$P(MAGRY(I),U,3),$E(MAGDPT,LNTH)=" " - . S MAGX=MAGX_MAGDPT_" "_$$DOB^DPTLK1(XDFN)_" "_XSSN - . S MAGRY(I)=MAGX - Q +MAGGTPT1 ;WOIFO/GEK - Delphi-Broker calls for patient lookup and information ; [ 06/20/2001 08:57 ] + ;;3.0;IMAGING;**16,8,92**;Jan 10, 2007;Build 1 + ;; Per VHA Directive 2004-038, this routine should not be modified. + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q + ; +FIND(MAGRY,ZY) ;RPC [MAGG PAT FIND] + ; Call to Do a lookup using FIND^DIC + ; MAGRY is the Array to return. + ; ZY is parameter sent by calling app (Delphi) + ; NUM TO RETURN ^ TEXT TO MATCH ^ ^ ^ SCREEN ($P 5-99) + N $ETRAP,$ESTACK S $ETRAP="D ERRA^MAGGTERR" + ; + N X,Y,I,Z,MAGDFN,WARD + N FILE,IENS,FLDS,FLAGS,VAL,NUM,INDEX,SCR,IDENT,TROOT + S (FILE,IENS,FLDS,FLAGS,VAL,NUM,INDEX,SCR,IDENT,TROOT)="" + ; + S FILE=2 ; Patient File + ; Number of entries to return, If 0 we'll stop at 100 + S NUM=$S(+$P(ZY,U,1):+$P(ZY,U,1),1:100) + S VAL=$P(ZY,U,2) ; this is the starting value i.e. 'Smi' + S SCR=$P(ZY,U,5,99) + S FLDS=$P(ZY,U,3) + ; $P(ZU,U,4) isn't used. + ; If specific fields aren't requested, + ; Get Identifiers, and ward as FLDS + ;I '$L(FLDS) S FLDS=FLDS_";.1;.03;.09;.301;391" + I '$L(FLDS) S FLDS=FLDS_";.1;.301;391" + ; we'll add ACN to the index to search, for ward + ; for speed we'll decide which xref to use + S INDEX=$S(VAL?9N:"SSN^ACN",VAL?1U1.N:"BS5^ACN",1:"B^ACN") + ; + K ^TMP("DILIST",$J) + K ^TMP("DIERR",$J) + ; VAL is the initial value to search for. i.e. the user input. + ; Next line is to stop the FM Infinite Error Trap problem. + I $L(VAL)>30 S MAGRY(0)="0^Invalid: Input '"_$E(VAL,1,40)_"...' is too long. "_$L(VAL)_" characters." Q + D FIND^DIC(FILE,IENS,FLDS,FLAGS,VAL,NUM,INDEX,SCR,IDENT,TROOT) + ; + ; if no Match or ERROR we return 0 as 1st '^' piece. + ; + I '$D(^TMP("DILIST",$J,1)) S I=1 D Q + . I $D(^TMP("DIERR",$J)) D FINDERR(I) Q + . S MAGRY(I)="NO MATCH for lookup on """_$P(ZY,"^",2)_"""" + ; + ; so we have some matches, (BUT we could still have an error) + ; so first list all matches, then the Errors, if any. + S I="" F S I=$O(^TMP("DILIST",$J,1,I)) Q:I="" D + . S X=^TMP("DILIST",$J,1,I) ; Name + . S MAGDFN=^TMP("DILIST",$J,2,I) ; DFN + . ; + . S WARD=^TMP("DILIST",$J,"ID",I,.1) + . K ^TMP("DILIST",$J,"ID",I,.1) + . I $E(WARD,1,$L(VAL))=VAL S X=WARD_" "_X + . ; + . S X=X_" "_$$DOB^DPTLK1(MAGDFN)_" "_$$SSN^DPTLK1(MAGDFN) + . S Z=0 + . ; We are displaying other identifiers with each patient. + . F S Z=$O(^TMP("DILIST",$J,"ID",I,Z)) Q:Z="" S X=X_" "_^(Z) + . S MAGRY(I)=X_"^"_+MAGDFN + ; + I $D(^TMP("DIERR",$J)) D FINDERR() Q + I '$D(^TMP("DILIST",$J,0)) Q + S X=^TMP("DILIST",$J,0) + S I=$O(MAGRY(""),-1)+1 + S MAGRY(0)="Found "_$P(X,"^")_" entr"_$S((+X=1):"y",1:"ies")_" matching """_$P(ZY,"^",3)_"""" + I $P(X,"^",3)>0 S MAGRY(0)=MAGRY(0)_" there are more" + Q +FINDERR(XI) ; + I '+$G(XI) S XI=$O(MAGRY(""),-1)+1 + S MAGRY(XI)="ERROR^"_^TMP("DIERR",$J,1,"TEXT",1) + Q +INFO(MAGRY,DATA) ;RPC [MAGG PAT INFO] Call to Return patient info. + ; Input parameters + ; DATA: MAGDFN ^ NOLOG ^ ISICN + ; MAGDFN -- Patient DFN + ; NOLOG -- 0/1; if 1, then do NOT update the Session log + ; ISICN -- 0/1 if 1, then this is an ICN, if 0 (default) this is a DFN ; Patch 41 + ; MAGRY is a string, we return the following : + ; //$P 1 2 3 4 5 6 7 8 9 10 + ; // status ^ DFN ^ name ^ sex ^ DOB ^ SSN ^ S/C ^ TYPE ^ Veteran(y/n) ^ Patient Image Count + ; //$P 11 12 13 + ; ICN SITE Number ^ Production Account 1/0 + ; VADM(1)=Patient's name + ; VADM(5)=Patient's sex (M^MALE) + ; VADM(3)=Patient's DOB (internal^external) + ; VADM(2)=Patient's SSN (internal^external) + ; VAEL(3)=Patient's Service Connected? (#.301) (1=yes) + ; VAEL(4)=Patient's Veteran Y/N (#1901) (1=yes) + ; VAEL(6)=Patient's Type (#391) (internal^external) + ; + N MAGDFN,DFN,X,NOLOG,VADM,VAEL,VAERR,ISICN + S MAGDFN=$P(DATA,U),NOLOG=+$P(DATA,U,2),ISICN=+$P(DATA,U,3) + I ISICN D GETDFN^VAFCTFU1(.DFN,MAGDFN) + E S DFN=+MAGDFN + D DEM^VADPT,ELIG^VADPT + I VAERR S MAGRY="0^"_"Entry not found in Patient file." Q + S X=$TR($$FMTE^XLFDT($P(VADM(3),"^"),"2FD")," ",0) + ; // status ^ DFN ^ name ^ sex ^ DOB ^ SSN ^ S/C ^ TYPE ^ Veteran(y/n) ^ Patient Image Count + S $P(MAGRY,"^",1,2)="1^"_DFN + ; Fields: NAME, SEX, DATE OF BIRTH, SSN + S $P(MAGRY,"^",3,6)=$G(VADM(1))_"^"_$P(VADM(5),"^",2)_"^"_X_"^"_$P(VADM(2),"^") + ; Fields: Service Connected?, Type, Veteran Y/N? + S $P(MAGRY,"^",7,9)=$S(+VAEL(3):"YES",1:"")_"^"_$P(VAEL(6),"^",2)_"^"_$S(+VAEL(4):"YES",1:"") + ; Fields: Patient Image Count + S $P(MAGRY,"^",10)=$$IMGCT(DFN)_"^" + ; Additions. for Patch 41 + ; Fields : Patient ICN + S $P(MAGRY,"^",11)=$$GETICN^MPIF001(DFN) + S X=$$SITE^VASITE + ; Fields: Site Number Prod Acct + S $P(MAGRY,"^",12)=$P($G(X),"^",3)_"^"_"1" ; We'll default to Production Account = Yes. + ; NEED KERNEL PATCH XU*8.0*284 FOR PROD^XUPROD + ; Fields : the Actual value for Prod Acct + I $L($T(PROD^XUPROD)) S $P(MAGRY,"^",13)=+$$PROD^XUPROD + S $P(MAGRY,"^",14)="^" + ; AGE + S $P(MAGRY,"^",15)=VADM(4)_"^" + D KVAR^VADPT,KVA^VADPT + I NOLOG ; Don't update session log + ; We'll track DFN:ICN + E D ACTION^MAGGTAU("PAT^"_DFN_$S(ISICN:"-"_MAGDFN,1:"")) + Q +IMGCT(DFN) ; RETURN TOTAL NUMBER OF IMAGES FOR A PATIENT; + ; + N I,CT,RDT,PRX,IEN + S CT=0 + S RDT="" F S RDT=$O(^MAG(2005,"APDTPX",DFN,RDT)) Q:RDT="" D + . S PRX="" F S PRX=$O(^MAG(2005,"APDTPX",DFN,RDT,PRX)) Q:PRX="" D + . . S IEN="" F S IEN=$O(^MAG(2005,"APDTPX",DFN,RDT,PRX,IEN)) Q:IEN="" S CT=CT+1 + Q CT +BS5CHK(MAGRY,MAGDFN) ;RPC [MAGG PAT BS5 CHECK] + ; Call to check the BS5 cross ref + ; and see if any similar patients exist. + ; If yes, all matching patients will be listed and shown to the user. + ; + N MAGX,MAGDPT,XDFN,XSSN,CT,LNTH + S LNTH=0 + S MAGRY(1)="-1^Error checking cross reference" + D GUIBS5A^DPTLK6(.MAGRY,MAGDFN) + I MAGRY(1)=0 Q + S CT=$O(MAGRY(""),-1)+1 + S MAGRY(CT)=MAGRY(CT-1),MAGRY(CT-1)="0^ " + S I="" F S I=$O(MAGRY(I)) Q:'I D + . I $P(MAGRY(I),U)=0 Q + . I $L($P(MAGRY(I),U,3))>LNTH S LNTH=$L($P(MAGRY(I),U,3)) + S LNTH=LNTH+1 + S I=1 F S I=$O(MAGRY(I)) Q:'I D + . I $P(MAGRY(I),U)="0" S MAGRY(I)=$P(MAGRY(I),U,2) Q + . S XDFN=$P(MAGRY(I),U,2) + . I +XDFN=+MAGDFN S MAGX=" >>>>>> " + . E S MAGX=" " + . S XSSN=$$SSN^DPTLK1(XDFN) I XSSN?9N S XSSN=$E(XSSN,1,3)_"-"_$E(XSSN,4,5)_"-"_$E(XSSN,6,9) + . S MAGDPT=$P(MAGRY(I),U,3),$E(MAGDPT,LNTH)=" " + . S MAGX=MAGX_MAGDPT_" "_$$DOB^DPTLK1(XDFN)_" "_XSSN + . S MAGRY(I)=MAGX + Q diff --git a/r/IMAGING-MAG-ZMAG/MAGGTRA.m b/r/IMAGING-MAG-ZMAG/MAGGTRA.m index ace9c9ac..c7e4e8c3 100644 --- a/r/IMAGING-MAG-ZMAG/MAGGTRA.m +++ b/r/IMAGING-MAG-ZMAG/MAGGTRA.m @@ -1,75 +1,74 @@ -MAGGTRA ;WOIFO/GEK - RPC Call to list Patient's Rad/Nuc Exams, Reports ; [ 06/20/2001 08:57 ] - ;;3.0;IMAGING;**59**;Nov 27, 2007;Build 20 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q -LIST(MAGRY,DATA) ; - ; SOME OLD IMAGING EXECUTABLES (IMGVWP10) STILL CALL HERE - ; THIS HAS BEEN SWITCHED TO LIST^MAGGTRA1 - ; - ;MAGRY - return array of patient's exams. - ;DATA - RADFN - Radiology Patient's DFN ^RADPT( - ; - D LIST^MAGGTRA1(.MAGRY,.DATA) - Q -MAGPTR(MAGRY,XDUZ,MAGIEN,DATA) ;RPC Call to file Image pointer into Radiology - ; File and Radiology pointer into Image File. - ; - ; MAGRY is the return string = 1^success if things work okay. - ; 0^message if things not okay. - ; DATA is The data that was sent in LIST^MAGGTRA - ; it is the display data _ to ^TMP($J,"RAEX",RACNT - ; the ^TMP is setup by RAPTLU, (and MAGGTRA) in the lookup - ; of patient exams, we keep it, and send it back in case - ; we need to create a new report. - ; - ; XDUZ is not used from parameter list anymore. - ; MAGIEN is Image File IEN ^MAG(2005,IEN - ; - N Y,I,CT,MAGERR,DIQUIET - N RADFN,RADTI,RACNI,RANME,RASSN,RADATE,RADTE,RACN,RAPRC,RARPT,RAST,MAGGP - IF $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGGTERR" - E S X="ERR^MAGGTERR",@^%ZOSF("TRAP") - S DIQUIET=1,MAGERR=0,CT=0 - D DT^DICRW - ; The list entry selected has the following data associated with it - ; it was created using parts of RAPTLU routine to list rad exams - ;^TMP($J,"RAEX",RACNT)=RADFN_"^"_RADTI_"^"_RACNI_"^"_RANME_"^"_RASSN_"^"_RADATE_"^"_RADTE_"^"_RACN_"^"_RAPRC_"^"_RARPT_"^"_RAST - ; - S DATA=$P(DATA,"^",7,99) - F I="RADFN","RADTI","RACNI","RANME","RASSN","RADATE","RADTE","RACN","RAPRC","RARPT","RAST" S CT=CT+1,@I=$P(DATA,"^",CT) - ; - ; let us check a few things first - ; Do we have a valid IMAGE IEN ^MAG(2005, - I '$D(^MAG(2005,MAGIEN,0)) S MAGRY="0^OPERATION CANCEDED: INVALID Imaging (2005) entry" Q - ; Does this Imaging entry already point to a Report. - I $D(^MAG(2005,MAGIEN,2)) S Z=^(2) D - . F I=6,7,8 S X=$P(Z,U,I) I $L(X) S MAGERR=1 Q - I MAGERR S MAGRY="0^OPERATION CANCELED: Imaging File entry already has an associated Report" Q - ; Does the Imaging entry patient, match the Rad Exam entry patient - I $P(^MAG(2005,MAGIEN,0),U,7)'=RADFN S MAGRY="0^OPERATION CANCELED: Imaging Patient doesn't match Radiology Patient" Q - I RARPT,'$D(^RARPT(RARPT,0)) S MAGRY="0^OPERATION CANCELED: INVALID Radiology Report Number" Q - I '$G(RARPT) D CREATE^RARIC I '$G(RARPT) S MAGRY="0^OPERATION FAILED creating new Radiology Report entry" Q - ; Now lets file the Image pointer in the ^RARPT( file. - S MAGGP=MAGIEN - D PTR^RARIC - I Y<1 S MAGRY="0^OPERATION FAILED Creating Image pointer in Report File" Q - ; Now SET the Parent fields in the Image File - S $P(^MAG(2005,MAGIEN,2),U,6,8)=74_U_RARPT_U_+Y - ; DONE. - S MAGRY="1^Image pointer filed successfully" - D LINKDT^MAGGTU6(.X,MAGIEN) - Q +MAGGTRA ;WOIFO/GEK - RPC Call to list Patient's Rad/Nuc Exams, Reports ; [ 06/20/2001 08:57 ] + ;;3.0;IMAGING;;Mar 01, 2002 + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q +LIST(MAGRY,DATA) ; + ; SOME OLD IMAGING EXECUTABLES (IMGVWP10) STILL CALL HERE + ; THIS HAS BEEN SWITCHED TO LIST^MAGGTRA1 + ; + ;MAGRY - return array of patient's exams. + ;DATA - RADFN - Radiology Patient's DFN ^RADPT( + ; + D LIST^MAGGTRA1(.MAGRY,.DATA) + Q +MAGPTR(MAGRY,XDUZ,MAGIEN,DATA) ;RPC Call to file Image pointer into Radiology + ; File and Radiology pointer into Image File. + ; + ; MAGRY is the return string = 1^success if things work okay. + ; 0^message if things not okay. + ; DATA is The data that was sent in LIST^MAGGTRA + ; it is the display data _ to ^TMP($J,"RAEX",RACNT + ; the ^TMP is setup by RAPTLU, (and MAGGTRA) in the lookup + ; of patient exams, we keep it, and send it back in case + ; we need to create a new report. + ; + ; XDUZ is not used from parameter list anymore. + ; MAGIEN is Image File IEN ^MAG(2005,IEN + ; + N Y,I,CT,MAGERR + N RADFN,RADTI,RACNI,RANME,RASSN,RADATE,RADTE,RACN,RAPRC,RARPT,RAST + IF $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGGTERR" + E S X="ERR^MAGGTERR",@^%ZOSF("TRAP") + S DIQUIET=1,MAGERR=0,CT=0 + D DT^DICRW + ; The list entry selected has the following data associated with it + ; it was created using parts of RAPTLU routine to list rad exams + ;^TMP($J,"RAEX",RACNT)=RADFN_"^"_RADTI_"^"_RACNI_"^"_RANME_"^"_RASSN_"^"_RADATE_"^"_RADTE_"^"_RACN_"^"_RAPRC_"^"_RARPT_"^"_RAST + ; + S DATA=$P(DATA,"^",7,99) + F I="RADFN","RADTI","RACNI","RANME","RASSN","RADATE","RADTE","RACN","RAPRC","RARPT","RAST" S CT=CT+1,@I=$P(DATA,"^",CT) + ; + ; let us check a few things first + ; Do we have a valid IMAGE IEN ^MAG(2005, + I '$D(^MAG(2005,MAGIEN,0)) S MAGRY="0^OPERATION CANCEDED: INVALID Imaging (2005) entry" Q + ; Does this Imaging entry already point to a Report. + I $D(^MAG(2005,MAGIEN,2)) S Z=^(2) D + . F I=6,7,8 S X=$P(Z,U,I) I $L(X) S MAGERR=1 Q + I MAGERR S MAGRY="0^OPERATION CANCELED: Imaging File entry already has an associated Report" Q + ; Does the Imaging entry patient, match the Rad Exam entry patient + I $P(^MAG(2005,MAGIEN,0),U,7)'=RADFN S MAGRY="0^OPERATION CANCELED: Imaging Patient doesn't match Radiology Patient" Q + I RARPT,'$D(^RARPT(RARPT,0)) S MAGRY="0^OPERATION CANCELED: INVALID Radiology Report Number" Q + I '$G(RARPT) D CREATE^RARIC I '$G(RARPT) S MAGRY="0^OPERATION FAILED creating new Radiology Report entry" Q + ; Now lets file the Image pointer in the ^RARPT( file. + S MAGGP=MAGIEN + D PTR^RARIC + I Y<1 S MAGRY="0^OPERATION FAILED Creating Image pointer in Report File" Q + ; Now SET the Parent fields in the Image File + S $P(^MAG(2005,MAGIEN,2),U,6,8)=74_U_RARPT_U_+Y + ; DONE. + S MAGRY="1^Image pointer filed successfully" + Q diff --git a/r/IMAGING-MAG-ZMAG/MAGGTSR.m b/r/IMAGING-MAG-ZMAG/MAGGTSR.m index a3c331d7..031f3cfa 100644 --- a/r/IMAGING-MAG-ZMAG/MAGGTSR.m +++ b/r/IMAGING-MAG-ZMAG/MAGGTSR.m @@ -1,104 +1,68 @@ -MAGGTSR ;WOIFO/GEK - SURGERY CASE LIST ; [ 06/20/2001 08:57 ] - ;;3.0;IMAGING;**8,59**;Nov 27, 2007;Build 20 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q -GET(MAGRY,MAGDFN,DATA) ;RPC [MAGGSUR GET] - ; Call to get list of Patient Surgery procedures - ; MAGDFN = Patient DFN - ; DATA = For Future Use. - N $ETRAP,$ESTACK S $ETRAP="D ERRA^MAGGTERR" - N Y,NAME,AI,CASES,SDAT,DTX,SRFDA - K ^TMP($J,"MAGGTSR") - S NAME=$P($G(^DPT(MAGDFN,0)),U) I NAME="" S MAGRY(0)="0^INVALID Patient ID" Q - ; This is the Old Call we have always made. Doesn't have Non-OR - D GET^SROGTSR(.MAGRY,MAGDFN) - I 'MAGRY(0) S MAGRY(0)=MAGRY(0)_" for "_NAME G C1 - ; Image count is for future use by Display - S MAGRY(1)="#^Date^Case description^Case #^Images" - S I=1 F S I=$O(MAGRY(I)) Q:'I D - . S DTX=$$FMTE^XLFDT($P(MAGRY(I),U,5),"5MZ") - . S ^TMP($J,"MAGGTSR",$P(MAGRY(I),U,5),$P(MAGRY(I),U,4))=DTX_"^"_$P(MAGRY(I),U,3)_"^"_$P(MAGRY(I),"^",4)_"^"_$P(MAGRY(I),U,6)_U_"|"_$P(MAGRY(I),U,4,5)_U - ; - ;This is the New Call, which has Non-OR, but doesn't have (Scheduled) so we merge the two calls. -C1 D LIST^SROESTV(.CASES,MAGDFN) - I '$D(@CASES) G E1 - S MAGRY(0)="1^" - S MAGRY(1)="#^Date^Case description^Case #^Images" - S I=0 F S I=$O(@CASES@(I)) Q:'I D - . S SDAT=@CASES@(I) - . ; SDAT = SURIEN ^ SURDESC ^ SURDT ^ DFN;NAME ^ - . I $D(^TMP($J,"MAGGTSR",$P(SDAT,U,3),$P(SDAT,U,1))) Q - . S ^TMP($J,"MAGGTSR",$P(SDAT,U,3),$P(SDAT,U,1))=$$FMTE^XLFDT($P(SDAT,U,3),"5MZ")_U_$P(SDAT,U,2)_U_$P(SDAT,U,1)_U_$$IMGCT($P(SDAT,U,1))_U_"|"_$P(SDAT,U,1)_U_$P(SDAT,U,3)_U - . Q - ; - ; Now Returned the Merged List of the results of Old Call, with Results of New Call. -E1 ; - I '$D(^TMP($J,"MAGGTSR")) S MAGRY(0)="0^No Cases for "_$G(NAME) Q - S I=1,DTX=0,SRFDA=0 - F S DTX=$O(^TMP($J,"MAGGTSR",DTX)) Q:'DTX D - . S SRFDA="" F S SRFDA=$O(^TMP($J,"MAGGTSR",DTX,SRFDA),-1) Q:'SRFDA D - . . S I=I+1,MAGRY(I)=I-1_"^"_^TMP($J,"MAGGTSR",DTX,SRFDA) - . . Q - . Q - S $P(MAGRY(0),"^",1)=I-1 - Q -IMGCT(SRFIEN) ; - ; Count of images for this Surgery Case - ; If more than one group (or image) - ; then return "Group count : total images" i.e. "3:134" - ; else return count of Images i.e. "4" - ; - N CT,GCT,ICT,J - S J=0,CT=0,GCT=0 - F S J=$O(^SRF(SRFIEN,2005,"B",J)) Q:'J D - . S ICT=+$P($G(^MAG(2005,J,1,0)),U,4) - . S ICT=$S(ICT:ICT,1:1) ;If no group images, set count =1 (single image) - . S GCT=GCT+1 - . S CT=CT+ICT - I (GCT>1) Q GCT_":"_CT - Q CT - ; -IMAGE(MAGRY,DATA) ; - ; Called with the IEN of the Surgery package ^SRF(170,x - ; We'll return a list of images. - N SRFIEN,MAGIEN - S SRFIEN=+DATA - I '$D(^SRF(SRFIEN)) S MAGRY(0)="0^INVALID Surgery File entry" Q - I '$O(^SRF(SRFIEN,2005,0)) S MAGRY(0)="0^No Images for this Operation." Q - D GETLIST - Q -GETLIST ; called from other points in this routine, when SRFIEN is defined - ; and returns a list in MAGRY(1..n) - ; We'll make a tmp list of just the image IEN's - ; splitting groups into individual image entries. - K ^TMP($J,"MAGGX") - S I=0,CT=1 F S I=$O(^SRF(SRFIEN,2005,I)) Q:'I D - . S MAGIEN=$P(^SRF(SRFIEN,2005,I,0),U,1) - . Q:'$D(^MAG(2005,MAGIEN,0)) - . I '$O(^MAG(2005,MAGIEN,1,0)) S ^TMP($J,"MAGGX",MAGIEN)="" - . E S Z=0 F S Z=$O(^MAG(2005,MAGIEN,1,Z)) Q:Z="" S ^TMP($J,"MAGGX",$P(^MAG(2005,MAGIEN,1,Z,0),U,1))="" - I '$D(^TMP($J,"MAGGX")) S MAGRY(0)="0^Surgery File Entry "_SRFIEN_": has INVALID Image Pointers" Q - S Z="",CT=0 - S MAGQUIET=1 - F S Z=$O(^TMP($J,"MAGGX",Z)) Q:Z="" D - . S CT=CT+1,MAGXX=Z D INFO^MAGGTII - . S MAGRY(CT)="B2^"_MAGFILE - K MAGQUIET - S MAGRY(0)=CT_"^Images for the selected Surgery File entry" - K ^TMP("MAGGX") - Q +MAGGTSR ;WOIFO/GEK - SURGERY CASE LIST ; [ 06/20/2001 08:57 ] + ;;3.0;IMAGING;**8**;Sep 15, 2004 + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q +GET(MAGRY,MAGDFN) ;RPC [MAGGSUR GET] + ; Call to get list of Patient Surgery procedures + ; MAGDFN is Patient DFN + ; + IF $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERRA^MAGGTERR" + E S X="ERRA^MAGGTERR",@^%ZOSF("TRAP") + N Y,DFN,MAGNAME + S MAGNAME=$P($G(^DPT(MAGDFN,0)),U) + I MAGNAME="" S MAGGRY(0)="0^INVALID Patient ID" Q + D GET^SROGTSR(.MAGRY,MAGDFN) + I 'MAGRY(0) S MAGRY(0)=MAGRY(0)_" for "_MAGNAME Q + ; Here we are changing the data returned in the array, from SROGTSR + ; , it will now also return the count of images associated with the + ; surgery report. This is in advance of the change for Display, to + ; list the patient's surgery reports, like we list radiology reports. + ; + I (+$G(MAGJOB("VERSION"))<2.5) Q + S MAGRY(1)=$P(MAGRY(1),U,1,3)_"^Images" + S I=1 F S I=$O(MAGRY(I)) Q:'I D + . S MAGRY(I)=$P(MAGRY(I),U,1,3)_U_$P(MAGRY(I),U,6)_U_$C(124)_$P(MAGRY(I),U,4,5)_U + Q +IMAGE(MAGRY,DATA) ; + ; Called with the IEN of the Surgery package ^SRF(170,x + ; We'll return a list of images. + N SRFIEN,MAGIEN + S SRFIEN=+DATA + I '$D(^SRF(SRFIEN)) S MAGRY(0)="0^INVALID Surgery File entry" Q + I '$O(^SRF(SRFIEN,2005,0)) S MAGRY(0)="0^No Images for this Operation." Q + D GETLIST + Q +GETLIST ; called from other points in this routine, when SRFIEN is defined + ; and returns a list in MAGRY(1..n) + ; We'll make a tmp list of just the image IEN's + ; splitting groups into individual image entries. + K ^TMP("MAGGX",$J) + S I=0,CT=1 F S I=$O(^SRF(SRFIEN,2005,I)) Q:'I D + . S MAGIEN=$P(^SRF(SRFIEN,2005,I,0),U,1) + . Q:'$D(^MAG(2005,MAGIEN,0)) + . I '$O(^MAG(2005,MAGIEN,1,0)) S ^TMP("MAGGX",$J,MAGIEN)="" + . E S Z=0 F S Z=$O(^MAG(2005,MAGIEN,1,Z)) Q:Z="" S ^TMP("MAGGX",$J,$P(^MAG(2005,MAGIEN,1,Z,0),U,1))="" + I '$D(^TMP("MAGGX",$J)) S MAGRY(0)="0^Surgery File Entry "_SRFIEN_": has INVALID Image Pointers" Q + S Z="",CT=0 + S MAGQUIET=1 + F S Z=$O(^TMP("MAGGX",$J,Z)) Q:Z="" D + . S CT=CT+1,MAGXX=Z D INFO^MAGGTII + . S MAGRY(CT)="B2^"_MAGFILE + K MAGQUIET + S MAGRY(0)=CT_"^Images for the selected Surgery File entry" + K ^TMP("MAGGX") + Q diff --git a/r/IMAGING-MAG-ZMAG/MAGGTSR1.m b/r/IMAGING-MAG-ZMAG/MAGGTSR1.m index 91027854..c02a9b06 100644 --- a/r/IMAGING-MAG-ZMAG/MAGGTSR1.m +++ b/r/IMAGING-MAG-ZMAG/MAGGTSR1.m @@ -1,54 +1,52 @@ -MAGGTSR1 ;WOIFO/GEK - ADD IMAGES TO SURGERY FILE ; [ 06/20/2001 08:57 ] - ;;3.0;IMAGING;**59**;Nov 27, 2007;Build 20 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q -FILE(MAGRY,MAGIEN,DATA) ;RPC Call to file Image pointers in Surgery package - ; and Surgery pointers in Image File. - ; - ; DATA is same data that we listed in the GET^MAGGTSR call - ; MAGIEN is the Imaging internal number. - ; example - ; for Imaging Versions < 2.5 the data is - ; # DATE DESC SRF(IEN FM DATE - ;CNT_U_(READABLE DATE)_U_SROPS(1)_U_SROP_U_SRSDATE - ; - ; for Imaging Versions > 2.4, the data is different - ;CNT_U_(READABLE DATE)_U_SROPS(1)_U_IMAGECT_U_"|"_SROP_U_SRSDATE - ; example - ; 1^05-06-1997^REMOVE TONSILS (REQUESTED)^8^|9853^2970506^ - ; - IF $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGGTERR" - E S X="ERR^MAGGTERR",@^%ZOSF("TRAP") - N Y,MAGSIEN,MAGPDT,MAGFDA,MAGERR,MAGIENS - ; - I (+$G(MAGJOB("VERSION"))>2.4) D - . S MAGSIEN=$P($P(DATA,$C(124),2),U,1) - . S MAGPDT=$P($P(DATA,$C(124),2),U,2) - E S MAGSIEN=$P(DATA,U,4),MAGPDT=$P(DATA,U,5) - S MAGFDA(130.02005,"+1,"_MAGSIEN_",",.01)=MAGIEN - D UPDATE^DIE("S","MAGFDA","MAGIENS","MAGERR") - I '$G(MAGIENS(1)) D D CLEAN^DILF S MAGRY=MAGERR Q - . S MAGERR="0^ERROR Adding Image to Surgery Package " - . I $D(DIERR) D RTRNERR(.MAGERR) - S MAGRY="1^Image added to Surgery Package" - S $P(^MAG(2005,MAGIEN,2),U,6,8)="130^"_MAGSIEN_U_MAGIENS(1) - D LINKDT^MAGGTU6(.X,MAGIEN) - Q -RTRNERR(ETXT) ; There was error from UPDATE^DIE quit with error text - S ETXT="0^ERROR "_MAGERR("DIERR",1,"TEXT",1) - Q +MAGGTSR1 ;WOIFO/GEK - ADD IMAGES TO SURGERY FILE ; [ 06/20/2001 08:57 ] + ;;3.0;IMAGING;;Mar 01, 2002 + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q +FILE(MAGRY,MAGIEN,DATA) ;RPC Call to file Image pointers in Surgery package + ; and Surgery pointers in Image File. + ; + ; DATA is same data that we listed in the GET^MAGGTSR call + ; MAGIEN is the Imaging internal number. + ; example + ; for Imaging Versions < 2.5 the data is + ; # DATE DESC SRF(IEN FM DATE + ;CNT_U_(READABLE DATE)_U_SROPS(1)_U_SROP_U_SRSDATE + ; + ; for Imaging Versions > 2.4, the data is different + ;CNT_U_(READABLE DATE)_U_SROPS(1)_U_IMAGECT_U_"|"_SROP_U_SRSDATE + ; example + ; 1^05-06-1997^REMOVE TONSILS (REQUESTED)^8^|9853^2970506^ + ; + IF $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGGTERR" + E S X="ERR^MAGGTERR",@^%ZOSF("TRAP") + N Y,MAGSIEN,MAGPDT,MAGFDA,MAGERR,MAGIENS + ; + I (+$G(MAGJOB("VERSION"))>2.4) D + . S MAGSIEN=$P($P(DATA,$C(124),2),U,1) + . S MAGPDT=$P($P(DATA,$C(124),2),U,2) + E S MAGSIEN=$P(DATA,U,4),MAGPDT=$P(DATA,U,5) + S MAGFDA(130.02005,"+1,"_MAGSIEN_",",.01)=MAGIEN + D UPDATE^DIE("S","MAGFDA","MAGIENS","MAGERR") + I '$G(MAGIENS(1)) D D CLEAN^DILF S MAGRY=MAGERR Q + . S MAGERR="0^ERROR Adding Image to Surgery Package " + . I $D(DIERR) D RTRNERR(.MAGERR) + S MAGRY="1^Image added to Surgery Package" + S $P(^MAG(2005,MAGIEN,2),U,6,8)="130^"_MAGSIEN_U_MAGIENS(1) + Q +RTRNERR(ETXT) ; There was error from UPDATE^DIE quit with error text + S ETXT="0^ERROR "_MAGERR("DIERR",1,"TEXT",1) + Q diff --git a/r/IMAGING-MAG-ZMAG/MAGGTSY2.m b/r/IMAGING-MAG-ZMAG/MAGGTSY2.m index 6016bf1b..72720d04 100644 --- a/r/IMAGING-MAG-ZMAG/MAGGTSY2.m +++ b/r/IMAGING-MAG-ZMAG/MAGGTSY2.m @@ -1,50 +1,30 @@ -MAGGTSY2 ;WOIFO/GEK - Calls from Imaging windows for System Manager ; [ 06/20/2001 08:57 ] - ;;3.0;IMAGING;**59**;Nov 27, 2007;Build 20 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q -MAG(MAGRY,NODE) ;RPC Call to show node of Image File - ; NODE is the IEN of Image File : ^MAG(2005,NODE - N Y,I,CT,X,TNODE - S MAGRY=$NA(^TMP("MAGNODE",$J)) - S NODE=$G(NODE) - N I,CT,X - K @MAGRY - S @MAGRY@(0)="Display NODE: "_$S($L(NODE):NODE,1:"LAST") - S I=0,CT=0 - I $E(NODE)="^" G OTH - I 'NODE S NODE=$P(^MAG(2005,0),U,3) - S I="^MAG(2005,"_NODE_","""")" - F S X=$Q(@I) S I=X Q:$P(X,",",2)'=NODE D - . S CT=CT+1,@MAGRY@(CT)=X_" "_@X - . Q - I $P($G(^MAG(2005,NODE,2)),"^",6)="8925" D - . S CT=CT+1,@MAGRY@(CT)=" ******* TIU ******* " - . S TNODE=$P(^MAG(2005,NODE,2),"^",7) - . S I="^TIU(8925,"_TNODE_","""")" - . F S X=$Q(@I) S I=X Q:$P(X,",",2)'=TNODE D - . . S CT=CT+1,@MAGRY@(CT)=X_" "_@X - . . Q - Q -OTH ; - N OTHDA - S OTHDA=$P(NODE,",",2) - I OTHDA=0 S NODE=NODE_")" Q:'$D(@NODE) S CT=$O(@MAGRY@(""),-1)+1,@MAGRY@(CT)=$G(@(NODE)) Q - S I=NODE_","""")" - F S X=$Q(@I) S I=X Q:$P(X,",",2)'=OTHDA D - . S CT=$O(@MAGRY@(""),-1)+1,@MAGRY@(CT)=X_" "_@X - . Q - Q +MAGGTSY2 ;WOIFO/GEK - Calls from Imaging windows for System Manager ; [ 06/20/2001 08:57 ] + ;;3.0;IMAGING;;Mar 01, 2002 + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q +MAG(MAGRY,NODE) ; RPC Call for MAGSYS utility. Returns Global Node. + N CT,I,X,Y + S MAGRY=$NA(^TMP("MAGNODE",$J)) + S NODE=+$G(NODE) + I 'NODE S NODE=$P(^MAG(2005,0),U,3) + K @MAGRY + ;S @MAGRY@(0)="Display Imaging File NODE "_$S(NODE:NODE,1:"LAST") + S I=0,CT=0 + S I="^MAG(2005,"_NODE_","""")" + F S X=$Q(@I) S I=X Q:$P(X,",",2)'=NODE D + . S CT=CT+1,@MAGRY@(CT)=X_" "_@X + Q diff --git a/r/IMAGING-MAG-ZMAG/MAGGTSYS.m b/r/IMAGING-MAG-ZMAG/MAGGTSYS.m index 4ffbca10..b26f4be6 100644 --- a/r/IMAGING-MAG-ZMAG/MAGGTSYS.m +++ b/r/IMAGING-MAG-ZMAG/MAGGTSYS.m @@ -1,66 +1,57 @@ -MAGGTSYS ;WOIFO/GEK - Calls from Imaging windows for System Manager ; [ 06/20/2001 08:57 ] - ;;3.0;IMAGING;**59**;Nov 27, 2007;Build 20 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q -GETS(MAGRY,NODE,FLAGS) ; USE GETS^DIQ TO GET FIELD VALUES. - K MAGWIN,I,CT,Y,NC,MAGOUT,MAGERR,TNC,ZZ - S MAGRY=$NA(^TMP("MAGNODE",$J)) - S NODE=+$G(NODE) - I 'NODE S NODE=$P(^MAG(2005,0),U,3) - S MAGWIN=$$BROKER^XWBLIB - I 'MAGWIN W !,"NODE"," ",NODE - K @MAGRY - S @MAGRY@(0)="****** Fields for Image IEN: "_NODE_" ******" - S I=0,CT=0 - S FLAGS=$S($L($G(FLAGS)):FLAGS,1:"IERN") - D GETS^DIQ(2005,NODE,"*",FLAGS,"MAGOUT","MAGERR") - ;D GETS^DIQ(2005,NODE,".01;1;2;2.1;2.2;3;5;6;12","R","MAGOUT","MAGERR") - S NC=NODE_"," - S I="" F S I=$O(MAGOUT(2005,NC,I)) Q:I="" D - . S CT=CT+1 - . I $G(MAGOUT(2005,NC,I,"I"))=$G(MAGOUT(2005,NC,I,"E")) D Q - . . S ZZ=I,$E(ZZ,45,999)=" = "_$G(MAGOUT(2005,NC,I,"E")) - . . S @MAGRY@(CT)=ZZ - . . ;S @MAGRY@(CT)=I_" = "_MAGOUT(2005,NC,I,"E") Q - . . Q - . ; - . S ZZ=I,$E(ZZ,25,999)=" = ("_$G(MAGOUT(2005,NC,I,"I"))_") " - . I ($L(ZZ)>44) S ZZ=ZZ_" = "_$G(MAGOUT(2005,NC,I,"E")) S @MAGRY@(CT)=ZZ Q - . I ($L(ZZ)<45) S $E(ZZ,45,999)=" = "_$G(MAGOUT(2005,NC,I,"E")) S @MAGRY@(CT)=ZZ Q - . ;S @MAGRY@(CT)=I_" = ("_$G(MAGOUT(2005,NC,I,"I"))_") = "_$G(MAGOUT(2005,NC,I,"E")) - . Q - I $P($G(^MAG(2005,NODE,2)),"^",6)=8925 D - . K MAGOUT,MAGERR - . S CT=CT+1,@MAGRY@(CT)=" *************** TIU *************** " - . S CT=CT+1,@MAGRY@(CT)=" **** Field Values for TIUDA: "_$P(^MAG(2005,NODE,2),"^",7)_" ****" - . D GETS^DIQ(8925,$P(^MAG(2005,NODE,2),"^",7),"*",FLAGS,"MAGOUT","MAGERR") - . S NC=$P(^MAG(2005,NODE,2),"^",7)_"," - . S I="" F S I=$O(MAGOUT(8925,NC,I)) Q:I="" D - . . S CT=CT+1 - . . I $G(MAGOUT(8925,NC,I,"I"))=$G(MAGOUT(8925,NC,I,"E")) D Q - . . . S ZZ=I,$E(ZZ,45,999)=" = "_$G(MAGOUT(8925,NC,I,"E")) - . . . S @MAGRY@(CT)=ZZ - . . . ;S @MAGRY@(CT)=I_" = "_MAGOUT(2005,NC,I,"E") Q - . . . Q - . . ; - . . S ZZ=I,$E(ZZ,25,999)=" = ("_$G(MAGOUT(8925,NC,I,"I"))_") " - . . I ($L(ZZ)>44) S ZZ=ZZ_" = "_$G(MAGOUT(8925,NC,I,"E")) S @MAGRY@(CT)=ZZ Q - . . I ($L(ZZ)<45) S $E(ZZ,45,999)=" = "_$G(MAGOUT(8925,NC,I,"E")) S @MAGRY@(CT)=ZZ Q - . . ;S @MAGRY@(CT)=I_" = ("_$G(MAGOUT(2005,NC,I,"I"))_") = "_$G(MAGOUT(2005,NC,I,"E")) - . . Q - . Q - Q +MAGGTSYS ;WOIFO/GEK - Calls from Imaging windows for System Manager ; [ 06/20/2001 08:57 ] + ;;3.0;IMAGING;;Mar 01, 2002 + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q +MAG(MAGRY,NODE) ;RPC Call to show node of Image File + ; NODE is the IEN of Image File : ^MAG(2005,NODE + N Y + S MAGRY=$NA(^TMP("MAGNODE",$J)) + S NODE=+$G(NODE) + I 'NODE S NODE=$P(^MAG(2005,0),U,3) + N MAGWIN,I,CT,X + S MAGWIN=$$BROKER^XWBLIB + K @MAGRY + ;S @MAGRY@(0)="Display Imaging File NODE "_$S(NODE:NODE,1:"LAST") + S I=0,CT=0 + I 'MAGWIN W !,"NODE"," ",NODE + S I="^MAG(2005,"_NODE_","""")" + F S X=$Q(@I) S I=X Q:$P(X,",",2)'=NODE D + . S CT=CT+1,@MAGRY@(CT)=X_" "_@X + . I 'MAGWIN W !,X," ",@X + ; + Q +GETS(MAGRY,NODE,FLAGS) ; USE GETS^DIQ TO GET FIELD VALUES. + N Y + S MAGRY=$NA(^TMP("MAGNODE",$J)) + S NODE=+$G(NODE) + I 'NODE S NODE=$P(^MAG(2005,0),U,3) + N MAGWIN,I,CT + S MAGWIN=$$BROKER^XWBLIB + K @MAGRY + S @MAGRY@(0)="Fields for Image IEN: "_NODE + S I=0,CT=0 + I 'MAGWIN W !,"NODE"," ",NODE + N MAGOUT,MAGERR + S FLAGS=$S($L($G(FLAGS)):FLAGS,1:"IERN") + D GETS^DIQ(2005,NODE,"*",FLAGS,"MAGOUT","MAGERR") + ;D GETS^DIQ(2005,NODE,".01;1;2;2.1;2.2;3;5;6;12","R","MAGOUT","MAGERR") + S NNODE=NODE_"," + S I="" F S I=$O(MAGOUT(2005,NNODE,I)) Q:I="" D + . S CT=CT+1 + . I $G(MAGOUT(2005,NNODE,I,"I"))=$G(MAGOUT(2005,NNODE,I,"E")) S @MAGRY@(CT)=I_" = "_MAGOUT(2005,NNODE,I,"E") Q + . S @MAGRY@(CT)=I_" = ("_$G(MAGOUT(2005,NNODE,I,"I"))_") = "_$G(MAGOUT(2005,NNODE,I,"E")) + Q diff --git a/r/IMAGING-MAG-ZMAG/MAGGTU1.m b/r/IMAGING-MAG-ZMAG/MAGGTU1.m index 476840c4..ec43cfc0 100644 --- a/r/IMAGING-MAG-ZMAG/MAGGTU1.m +++ b/r/IMAGING-MAG-ZMAG/MAGGTU1.m @@ -1,56 +1,55 @@ -MAGGTU1 ;WOIFO/GEK - Silent Utilities ; [ 06/20/2001 08:57 ] - ;;3.0;IMAGING;**3,8,85,59**;Nov 27, 2007;Build 20 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q -DRIVE(X,SITE) ; Get the current drive for writing an image - ; Copied from MAGFILE and edited for silent running, made extrinsic. - ; X : The Network Location to Write to. Dicom Gateway sends this. - ; IF 'X then use DUZ(2) to find IMAGE NETWORK WRITE LOCATION. - ; P 85, Enable writing to any valid site. Not Just Duz(2) - ; SITE : The Site to Write to. Import API now sends this. - ; - ; - N Z,MAGREF,MAGREFNM,MAGDRIVE,MAGPLC - S SITE=$S($G(SITE):SITE,1:$G(DUZ(2))) - S MAGPLC=$$PLACE^MAGBAPI(SITE) ;pre-patch 85 was DUZ(2) - S MAGREF=$G(X) - I $G(MAGWRITE)="PACS" S MAGREF=$$GET1^DIQ(2006.1,MAGPLC,1.03,"I") ; DBI 9/20/02 - SEB - I 'MAGREF S MAGREF=$$GET1^DIQ(2006.1,MAGPLC,.03,"I") ; DBI 9/20/02 - SEB - I MAGREF="" D Q Z - . S Z="0^NEED WRITE LOCATION in SITE Parameters file!!! Call IRM" - ; - I '$P(^MAG(2005.2,MAGREF,0),"^",6) D Q Z - . S Z="0^The Server that you are writing to is off-line. Call IRM" - ; - S MAGREFNM=$P(^MAG(2005.2,MAGREF,0),"^",1),MAGDRIVE=$P(^(0),"^",2) - Q MAGREF_U_MAGDRIVE - ; -DA2NAME(IEN,SUF) ; Return file name with extension - ; SUF should always be defined, but default to .TIF if not. - N PRE,FILE,CMPF,MAGPLC - S MAGPLC=$$DA2PLC^MAGBAPIP(IEN,"F") - S SUF=$S($L($G(SUF)):SUF,1:"TIF") - S PRE=$$GET1^DIQ(2006.1,MAGPLC,.02,"E") ; gek DBI - ;S PRE=$G(^MAG(2006.1,"ALTR")) - I '$L(PRE) Q "0^Need Site Specific LETTERS in Site Parameters File" - ; - S FILE=PRE_IEN - ; Design of Patch 3 was changed to only return 14 digit file names. - ; 08/02/2002 Patch 3,8 force 14.3 file name convention - I ($L(FILE)<14) S FILE=PRE_$E(10000000000000+IEN,$L(PRE)+1,14) - Q "1^"_FILE_"."_SUF +MAGGTU1 ;WOIFO/GEK - Silent Utilities ; [ 06/20/2001 08:57 ] + ;;3.0;IMAGING;**3,8,85**;16-March-2007;;Build 1039 + ;; Per VHA Directive 2004-038, this routine should not be modified. + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q +DRIVE(X,SITE) ; Get the current drive for writing an image + ; Copied from MAGFILE and edited for silent running, made extrinsic. + ; X : The Network Location to Write to. Dicom Gateway sends this. + ; IF 'X then use DUZ(2) to find IMAGE NETWORK WRITE LOCATION. + ; P 85, Enable writing to any valid site. Not Just Duz(2) + ; SITE : The Site to Write to. Import API now sends this. + ; + ; + N Z,MAGREF,MAGREFNM,MAGDRIVE,MAGPLC + S SITE=$S($G(SITE):SITE,1:$G(DUZ(2))) + S MAGPLC=$$PLACE^MAGBAPI(SITE) ;pre-patch 85 was DUZ(2) + S MAGREF=$G(X) + I $G(MAGWRITE)="PACS" S MAGREF=$$GET1^DIQ(2006.1,MAGPLC,1.03,"I") ; DBI 9/20/02 - SEB + I 'MAGREF S MAGREF=$$GET1^DIQ(2006.1,MAGPLC,.03,"I") ; DBI 9/20/02 - SEB + I MAGREF="" D Q Z + . S Z="0^NEED WRITE LOCATION in SITE Parameters file!!! Call IRM" + ; + I '$P(^MAG(2005.2,MAGREF,0),"^",6) D Q Z + . S Z="0^The Server that you are writing to is off-line. Call IRM" + ; + S MAGREFNM=$P(^MAG(2005.2,MAGREF,0),"^",1),MAGDRIVE=$P(^(0),"^",2) + Q MAGREF_U_MAGDRIVE + ; +DA2NAME(IEN,SUF) ; Return file name with extension + ; SUF should always be defined, but default to .TIF if not. + N PRE,FILE,CMPF,MAGPLC + S MAGPLC=$$DA2PLC^MAGBAPIP(IEN,"F") + S SUF=$S($L($G(SUF)):SUF,1:"TIF") + S PRE=$$GET1^DIQ(2006.1,MAGPLC,.02,"E") ; gek DBI + ;S PRE=$G(^MAG(2006.1,"ALTR")) + I '$L(PRE) Q "0^Need Site Specific LETTERS in Site Parameters File" + ; + S FILE=PRE_IEN + ; Design of Patch 3 was changed to only return 14 digit file names. + ; 08/02/2002 Patch 3,8 force 14.3 file name convention + I ($L(FILE)<14) S FILE=PRE_$E(10000000000000+IEN,$L(PRE)+1,14) + Q "1^"_FILE_"."_SUF diff --git a/r/IMAGING-MAG-ZMAG/MAGGTU3.m b/r/IMAGING-MAG-ZMAG/MAGGTU3.m index 0230e192..7990290f 100644 --- a/r/IMAGING-MAG-ZMAG/MAGGTU3.m +++ b/r/IMAGING-MAG-ZMAG/MAGGTU3.m @@ -1,163 +1,220 @@ -MAGGTU3 ;WOIFO/GEK - Silent calls for Imaging ; [ 06/20/2001 08:57 ] - ;;3.0;IMAGING;**7,8,48,45,20,46,59**;Nov 27, 2007;Build 20 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q -IMAGEINF(MAGRY,IEN,NOCHK) ;RPC [MAGG IMAGE INFO] Call to return information for 1 image; - ; IEN = Image IEN ^MAG(2005,IEN - ; NOCHK = 1|"" if 1 then do not run QA check on this image. - ; - N MAGFILE,Y,Z,MAGNOCHK - I '$D(^MAG(2005,IEN)) D Q - . I $D(^MAG(2005.1,IEN)) S MAGRY(0)="0^Image : """_$P($G(^MAG(2005.1,IEN,2)),U,4)_""" has been deleted." Q - . S MAGRY(0)="0^INVALID Image number "_IEN - . Q - ; MAGGTII queries the variable MAGNOCHK to run QA check or not. - S MAGNOCHK=+$G(NOCHK) - S MAGXX=IEN D INFO^MAGGTII ; this'll give us the MAGFILE variable - S Z=$P(^MAG(2005,IEN,0),U,7) - I '$D(^DPT(Z)) S Z="1^Invalid patient pointer" - E S Z=Z_U_$P(^DPT(Z,0),U) - S MAGRY(0)="1^"_MAGFILE - S MAGRY(1)=Z ; dfn^name - Q -USERINF2(MAGRY,MAGWRKID) ;RPC [MAGGUSER2] Return user info. - ; MAGRY(1) = DUZ ^ FULL NAME ^ INITIALS - ; MAGRY(2) = Network UserName ^ PassWord. - ; MAGRY(3) = MUSE Site number. ( default = 1) - ; Node 4 is data from IMAGING SITE PARAMATERS File #2006.1 and INSTITUTION File #4 - ; MAGRY(4)= PLACE IEN ^ SITE CODE ^ DUZ(2) ^ INSTITUTION NAME (.01) ^ $$CONSOLID ^ User's local STATION NUMBER (99) - ; MAGRY(5) = +|0 ^ Version of CP installed on Server - ; MAGRY(6) = Warning message if we can't resolve which Site Parameter entry to use. - ; MAGRY(7) = Warning message - ; MAGRY(8) = 1|0 1 = Production account 0 = Test Account (or couldn't determine) ;Patch 41 - ; MAGRY(9) = Vista Site Service PHYSICAL REFERENCE from Network Location File. - ; MAGRY(10)=Domain Name - ; MAGRY(11)=Primary Division IEN - ; MAGRY(12)=Primary Division STATION NUMBER - ; - N J,K,Y,MAGPLC,MAGWARN,MAGWARN1,VSRV,PHYREF ; DBI - SEB 9/20/2002 - S MAGPLC=0 - I $D(DUZ(2)) S MAGPLC=+$$PLACE^MAGBAPI(DUZ(2)) ; DBI - SEB 9/20/2002 - ; - ; SET THE PARTITION VARIABLE MAGSYS i.e.'IGK_Garrett's Desk' - S MAGSYS=$G(MAGWRKID,"") - I +$G(DUZ)=0 S MAGRY(0)="0^DUZ Undefined, Null or Zero" Q - I 'MAGPLC D - . S MAGWARN="Can't resolve Site Param, DUZ(2): "_$S($D(DUZ(2)):DUZ(2),1:"NULL")_" DUZ: "_DUZ - . S MAGPLC=$$DUZ2PLC^MAGBAPIP(.MAGWARN1) ; DBI - SEB 9/20/2002 - . Q - S MAGRY(0)="1^" - ; DUZ FULL NAME INITIALS - S MAGRY(1)=DUZ_U_$$GET1^DIQ(200,DUZ_",",.01)_U_$$GET1^DIQ(200,DUZ_",",1) - ; NOW NET STUFF - I 'MAGPLC Q - ; From IMAGING SITE PARAMETERS File - ; get the Network UserName and PassWord. - S MAGRY(2)=$P($G(^MAG(2006.1,MAGPLC,"NET")),U,1,2) - ; get the default MUSE Site number. - S MAGRY(3)=+$P($G(^MAG(2006.1,MAGPLC,"USERPREF")),U,2) - ; default to 1 if nothing is entered in Site Parameters File - I MAGRY(3)=0 S MAGRY(3)=1 - ; This SITEIEN^SITECODE^USER INSTITUTION IEN^INSTITUTION NAME^CONSOLIDATED^User's local STATION NUMBER - ; is used by Display to determine location of Workstation - ; and used by Capture to determine the Write Location. - S MAGRY(4)=MAGPLC_U_$$GET1^DIQ(2006.1,MAGPLC,.09)_U_$G(DUZ(2))_U_$$GET1^DIQ(2006.1,MAGPLC,.01,"E") - S MAGJOB("PLC")=MAGPLC - S MAGJOB("PLCODE")=$$GET1^DIQ(2006.1,MAGPLC,.09) - S MAGRY(4)=MAGRY(4)_U_$$CONSOLID^MAGBAPI_U_$$GET1^DIQ(4,DUZ(2),99,"E") - ; is CP not installed at this site, the Client will hide options - ; related to CP. - S X=$$VERSION^XPDUTL("CLINICAL PROCEDURES") - S MAGRY(5)=+X_U_X - S MAGRY(6)=$G(MAGWARN) - S MAGRY(7)=$G(MAGWARN1) - S MAGRY(8)=$S($L($T(PROD^XUPROD)):+$$PROD^XUPROD,1:0) - S VSRV=$P($G(^MAG(2006.1,MAGPLC,"NET")),"^",5) - I VSRV I +$P($G(^MAG(2005.2,VSRV,0)),"^",6) S PHYREF=$P($G(^MAG(2005.2,VSRV,0)),"^",2) - S MAGRY(9)=$G(PHYREF) - S MAGRY(10)=$$KSP^XUPARAM("WHERE") - S MAGRY(11)=$P($$SITE^VASITE(),"^") - S MAGRY(12)=$P($$SITE^VASITE(),"^",3) - Q - ; -CATEGORY(MAGRY) ; RPC [MAGGDESCCAT] Call to return Mag Descriptive Categories in array - ; for listing in a list box. - N I,K,CT,Y - S I=0,CT=0 - I '$D(^MAG(2005.81)) D Q - . S MAGRY(0)="0^ERROR Mag Descriptive Category File doesn't exist" - F S I=$O(^MAG(2005.81,"B",I)) Q:I="" D - . ;Next line adds ADMIN, CLIN 3rd piece of the data returned - . S K=$O(^MAG(2005.81,"B",I,"")),CT=CT+1 - . S MAGRY(CT)=I_U_K_U_$P(^MAG(2005.81,K,0),U,2) - S MAGRY(0)=CT_"^Categories on file" - Q -USERKEYS(MAGKEY) ; RPC [MAGGUSERKEYS] - ; Call to return an array of IMAGING Security Keys - D USERKEYS^MAGGTU31(.MAGKEY) - Q -MAIL(MAGRY,MAGFILE,MAGIEN) ;RPC [MAGG OFFLINE IMAGE ACCESSED] - ; Called to log an Offline Image accessed. - ; ^MAGQUEUE(2006.033,0) = OFFLINE IMAGES - ; User must edit 2006.033 by hand to mark images as OFFLINE. - ; - N FILEREF,PLATTER,A - S MAGRY="0^Error : logging access to Off-Line Image" - N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGGTERR" - S FILEREF=$$UP^XLFSTR($P(MAGFILE,"\",$L(MAGFILE,"\"))) - S PLATTER=$O(^MAGQUEUE(2006.033,"B",FILEREF,"")) - S PLATTER=$P(^MAGQUEUE(2006.033,PLATTER,0),U,2) - I MAGFILE[".ABS" Q - N XMDUZ,XMSUB,XMTEXT,XMY - S XMDUZ=$S($D(DUZ):DUZ,1:.5) - S XMSUB="Offline Image Request" - S XMTEXT="A(" - S A(1)="Patient : "_$P(^DPT($P($G(^MAG(2005,+MAGIEN,0)),U,7),0),U,1) - S A(2)="FileName : "_MAGFILE_" "_MAGIEN - S A(3)="Desc : "_$P($G(^MAG(2005,MAGIEN,2)),U,4) - S A(4)="Procedure : "_$P($G(^MAG(2005,MAGIEN,0)),U,8) - S A(5)="Platter : "_PLATTER - S A(6)="User : "_$$GET1^DIQ(200,DUZ_",",.01)_"("_$G(DUZ)_")" - S XMY("G.OFFLINE IMAGE TRACKERS")="" D ^XMD - S MAGRY="1^Message sent : Offline Image Accessed" - Q -LOGERROR(MAGRY,TEXT) ;RPC [MAGG LOG ERROR TEXT] - ; Call to stuff error information from Delphi app into the Session file. - Q:($P($G(MAGJOB("VERSION")),".",1,2))<"3.0" - D LOGERR^MAGGTERR("---- New Error ----") - S I="" F S I=$O(TEXT(I)) Q:I="" D LOGERR^MAGGTERR(TEXT(I)) - S MAGRY="1^Error text saved to Session file" - Q -RSLVABS(MAGIEN,FILENAME) ;Resolve Abstract into the Default Bitmap - ; Return the default bitmap, If the image file extension resolves into a default bitmap - ; MAGIEN : Image internal entry number - ; FILENAME : "" or Relative Path and Default Bitmap. ie ('.\BMP\magavi.bmp') - N FTIEN,EXT ; - S FILENAME="" - I '$D(^MAG(2005.021)) Q ; IMAGE FILE TYPES doesn't exist on this system. - S EXT=$P($P(^MAG(2005,MAGIEN,0),"^",2),".",2) ; image file extension JPG, TGA, etc. - Q:EXT="" ; - S FTIEN=$O(^MAG(2005.021,"B",EXT,"")) - Q:'FTIEN ; No extension in IMAGE FILE TYPES file. - ; stop dependency on "c:\program files" - I '+$P(^MAG(2005.021,FTIEN,0),"^",5) S FILENAME=".\BMP\"_$P(^MAG(2005.021,FTIEN,0),"^",4) - Q -GETINFO(MAGRY,IEN) ; RPC [MAG4 GET IMAGE INFO] - ; Call (3.0p8) to get information on 1 image - ; and Display in the Image Information Window - D GETINFO^MAGGTU31(.MAGRY,IEN) - Q +MAGGTU3 ;WOIFO/GEK - Silent calls for Imaging ; [ 06/20/2001 08:57 ] + ;;3.0;IMAGING;**7,8,48,45,20,46**;16-February-2007;;Build 1023 + ;; Per VHA Directive 2004-038, this routine should not be modified. + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q +IMAGEINF(MAGRY,IEN,NOCHK) ;RPC [MAGG IMAGE INFO] Call to return information for 1 image; + ; IEN = Image IEN ^MAG(2005,IEN + ; NOCHK = If Flag = 1, then do not run QA check on this image. + ; + N MAGFILE,Y,Z,MAGNOCHK + I '$D(^MAG(2005,IEN)) D Q + . I $D(^MAG(2005.1,IEN)) S MAGRY(0)="0^Image : """_$P($G(^MAG(2005.1,IEN,2)),U,4)_""" has been deleted." Q + . S MAGRY(0)="0^INVALID Image number "_IEN + . Q + ; MAGGTII queries the variable MAGNOCHK to run QA check or not. + S MAGNOCHK=+$G(NOCHK) + S MAGXX=IEN D INFO^MAGGTII ; this'll give us the MAGFILE variable + S Z=$P(^MAG(2005,IEN,0),U,7) + I '$D(^DPT(Z)) S Z="1^Invalid patient pointer" + E S Z=Z_U_$P(^DPT(Z,0),U) + S MAGRY(0)="1^"_MAGFILE + S MAGRY(1)=Z ; dfn^name + Q +USERINF2(MAGRY,MAGWRKID) ;RPC [MAGGUSER2] Return user info. + ; MAGRY(1) = DUZ ^ FULL NAME ^ INITIALS + ; MAGRY(2) = Network UserName ^ PassWord. + ; MAGRY(3) = MUSE Site number. ( default = 1) + ; Node 4 is data from IMAGING SITE PARAMATERS File #2006.1 and INSTITUTION File #4 + ; MAGRY(4)= PLACE IEN ^ SITE CODE ^ DUZ(2) ^ INSTITUTION NAME (.01) ^ $$CONSOLID ^ User's local STATION NUMBER (99) + ; MAGRY(5) = +|0 ^ Version of CP installed on Server + ; MAGRY(6) = Warning message if we can't resolve which Site Parameter entry to use. + ; MAGRY(7) = Warning message + ; MAGRY(8) = 1|0 1 = Production account 0 = Test Account (or couldn't determine) ;Patch 41 + ; MAGRY(9) = Vista Site Service PHYSICAL REFERENCE from Network Location File. + ; MAGRY(10)=Domain Name + ; MAGRY(11)=Primary Division IEN + ; MAGRY(12)=Primary Division STATION NUMBER + ; + N J,K,Y,MAGPLC,MAGWARN,MAGWARN1,VSRV,PHYREF ; DBI - SEB 9/20/2002 + S MAGPLC=0 + I $D(DUZ(2)) S MAGPLC=+$$PLACE^MAGBAPI(DUZ(2)) ; DBI - SEB 9/20/2002 + ; + ; SET THE PARTITION VARIABLE MAGSYS i.e.'IGK_Garrett's Desk' + S MAGSYS=$G(MAGWRKID,"") + I +$G(DUZ)=0 S MAGRY(0)="0^DUZ Undefined, Null or Zero" Q + I 'MAGPLC D + . S MAGWARN="Can't resolve Site Param, DUZ(2): "_$S($D(DUZ(2)):DUZ(2),1:"NULL")_" DUZ: "_DUZ + . S MAGPLC=$$DUZ2PLC^MAGBAPIP(.MAGWARN1) ; DBI - SEB 9/20/2002 + . Q + S MAGRY(0)="1^" + ; DUZ FULL NAME INITIALS + S MAGRY(1)=DUZ_U_$$GET1^DIQ(200,DUZ_",",.01)_U_$$GET1^DIQ(200,DUZ_",",1) + ; NOW NET STUFF + I 'MAGPLC Q + ; Get info from IMAGING SITE PARAMETERS File + ; get the Network UserName and PassWord. + S MAGRY(2)=$P($G(^MAG(2006.1,MAGPLC,"NET")),U,1,2) + ; get the default MUSE Site number. + S MAGRY(3)=+$P($G(^MAG(2006.1,MAGPLC,"USERPREF")),U,2) + ; default to 1 if nothing is entered in Site Parameters File + I MAGRY(3)=0 S MAGRY(3)=1 + ; This SITEIEN^SITECODE^USER INSTITUTION IEN^INSTITUTION NAME^CONSOLIDATED^User's local STATION NUMBER + ; is used by Display to determine location of Workstation + ; and used by Capture to determine the Write Location. + S MAGRY(4)=MAGPLC_U_$$GET1^DIQ(2006.1,MAGPLC,.09)_U_$G(DUZ(2))_U_$$GET1^DIQ(2006.1,MAGPLC,.01,"E") + S MAGJOB("PLC")=MAGPLC + S MAGJOB("PLCODE")=$$GET1^DIQ(2006.1,MAGPLC,.09) + S MAGRY(4)=MAGRY(4)_U_$$CONSOLID^MAGBAPI_U_$$GET1^DIQ(4,DUZ(2),99,"E") + ; is CP installed at this site, the Front End will hide options + ; related to CP if not installed. + S X=$$VERSION^XPDUTL("CLINICAL PROCEDURES") + S MAGRY(5)=+X_U_X + S MAGRY(6)=$G(MAGWARN) + S MAGRY(7)=$G(MAGWARN1) + S MAGRY(8)=$S($L($T(PROD^XUPROD)):+$$PROD^XUPROD,1:0) + S VSRV=$P($G(^MAG(2006.1,MAGPLC,"NET")),"^",5) + I VSRV I +$P($G(^MAG(2005.2,VSRV,0)),"^",6) S PHYREF=$P($G(^MAG(2005.2,VSRV,0)),"^",2) + S MAGRY(9)=$G(PHYREF) + S MAGRY(10)=$$KSP^XUPARAM("WHERE") + S MAGRY(11)=$P($$SITE^VASITE(),"^") + S MAGRY(12)=$P($$SITE^VASITE(),"^",3) + Q + ; +CATEGORY(MAGRY) ; RPC [MAGGDESCCAT] Call to return Mag Descriptive Categories in array + ; for listing in a list box. + N I,K,CT,Y + S I=0,CT=0 + I '$D(^MAG(2005.81)) D Q + . S MAGRY(0)="0^ERROR Mag Descriptive Category File doesn't exist" + F S I=$O(^MAG(2005.81,"B",I)) Q:I="" D + . ;Next line adds ADMIN, CLIN 3rd piece of the data returned + . S K=$O(^MAG(2005.81,"B",I,"")),CT=CT+1 + . S MAGRY(CT)=I_U_K_U_$P(^MAG(2005.81,K,0),U,2) + S MAGRY(0)=CT_"^Categories on file" + Q +USERKEYS(MAGKEY) ; RPC [MAGGUSERKEYS] + ; Call to return an array of IMAGING Security Keys + D USERKEYS^MAGGTU31(.MAGKEY) + Q +MAIL(MAGRY,MAGFILE,MAGIEN) ;RPC [MAGG OFFLINE IMAGE ACCESSED] + ; Called to log an Offline Image accessed. + ; ^MAGQUEUE(2006.033,0) = OFFLINE IMAGES + ; User must edit 2006.033 by hand to mark images as OFFLINE. + ; + N FILEREF,PLATTER,A + S MAGRY="0^Error : logging access to Off-Line Image" + N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGGTERR" + S FILEREF=$$UP^XLFSTR($P(MAGFILE,"\",$L(MAGFILE,"\"))) + S PLATTER=$O(^MAGQUEUE(2006.033,"B",FILEREF,"")) + S PLATTER=$P(^MAGQUEUE(2006.033,PLATTER,0),U,2) + I MAGFILE[".ABS" Q + N XMDUZ,XMSUB,XMTEXT,XMY + S XMDUZ=$S($D(DUZ):DUZ,1:.5) + S XMSUB="Offline Image Request" + S XMTEXT="A(" + S A(1)="Patient : "_$P(^DPT($P($G(^MAG(2005,+MAGIEN,0)),U,7),0),U,1) + S A(2)="FileName : "_MAGFILE_" "_MAGIEN + S A(3)="Desc : "_$P($G(^MAG(2005,MAGIEN,2)),U,4) + S A(4)="Procedure : "_$P($G(^MAG(2005,MAGIEN,0)),U,8) + S A(5)="Platter : "_PLATTER + S A(6)="User : "_$$GET1^DIQ(200,DUZ_",",.01)_"("_$G(DUZ)_")" + S XMY("G.OFFLINE IMAGE TRACKERS")="" D ^XMD + S MAGRY="1^Message sent : Offline Image Accessed" + Q +LOGERROR(MAGRY,TEXT) ;RPC [MAGG LOG ERROR TEXT] + ; Call to stuff error information from Delphi app into the Session file. + Q:($P($G(MAGJOB("VERSION")),".",1,2))<"3.0" + D LOGERR^MAGGTERR("---- New Error ----") + S I="" F S I=$O(TEXT(I)) Q:I="" D LOGERR^MAGGTERR(TEXT(I)) + S MAGRY="1^Error text saved to Session file" + Q +RSLVABS(MAGIEN,FILENAME) ;Resolve Abstract into the Default Bitmap + ; Return the default bitmap, If the image file extension resolves into a default bitmap + ; MAGIEN : Image internal entry number + ; FILENAME : "" or Relative Path and Default Bitmap. ie ('.\BMP\magavi.bmp') + N FTIEN,EXT ; + S FILENAME="" + I '$D(^MAG(2005.021)) Q ; IMAGE FILE TYPES doesn't exist on this system. + S EXT=$P($P(^MAG(2005,MAGIEN,0),"^",2),".",2) ; image file extension JPG, TGA, etc. + Q:EXT="" ; + S FTIEN=$O(^MAG(2005.021,"B",EXT,"")) + Q:'FTIEN ; No extension in IMAGE FILE TYPES file. + ; stop dependency on "c:\program files" + I '+$P(^MAG(2005.021,FTIEN,0),"^",5) S FILENAME=".\BMP\"_$P(^MAG(2005.021,FTIEN,0),"^",4) + Q +GETINFO(MAGRY,IEN) ; RPC [MAG4 GET IMAGE INFO] + ; Call (3.0p8) to get information on 1 image + N Y,J,JI,I,CT,IENC,FLAGS,SNGRP,Z,M40,T,QACHK + S I=0,CT=0 + S MAGRY(CT)="Image ID#: "_IEN + I $D(^MAG(2005.1,IEN)) D Q + . S CT=CT+1,MAGRY(CT)=" STATUS: "_"HAS BEEN DELETED. !!" + . S CT=CT+1,MAGRY(CT)="Deleted By: "_$$GET1^DIQ(2005.1,IEN,30,"E") + . S CT=CT+1,MAGRY(CT)=" Reason: "_$$GET1^DIQ(2005.1,IEN,30.2,"E") + . S CT=CT+1,MAGRY(CT)=" Date: "_$$GET1^DIQ(2005.1,IEN,30.1,"E") + . Q + S M40=$G(^MAG(2005,IEN,40)),T=$P(M40,"^",3) + S Z=$P($G(^MAG(2005,IEN,0)),"^",10) I Z D + . S CT=CT+1,MAGRY(CT)=" is in Group#: "_Z_" ("_+$P(^MAG(2005,Z,1,0),"^",4)_" images)" + . D CHK^MAGGSQI(.QACHK,Z) Q:QACHK(0) + . S CT=CT+1,MAGRY(CT)=" QA Warning - Group#: "_Z_" "_$P(QACHK(0),"^",2) + . Q + S SNGRP="FLDS" + I (+$O(^MAG(2005,IEN,1,0)))!($P(^MAG(2005,IEN,0),"^",6)=11)!($P(^MAG(2005,IEN,0),"^",6)=16) D + . S CT=CT+1,MAGRY(CT)=$P(^MAG(2005,IEN,0),"^",8)_" Group of "_+$P($G(^MAG(2005,IEN,1,0)),U,4) + . S SNGRP="FLDG" + . Q + K QACHK + D CHK^MAGGSQI(.QACHK,IEN) I 'QACHK(0) D + . S CT=CT+1,MAGRY(CT)=" QA Warning - Image#: "_IEN_" "_$P(QACHK(0),"^",2) + N MAGOUT,MAGERR,MAGVAL + S IENC=IEN_"," + S FLAGS="EN" + S I=-1 + F S I=I+1,Z=$T(@SNGRP+I) Q:$P(Z,";",3)="end" D + . S J=$P(Z,";",4),JI=J_";" + . K MAGOUT + . S CT=CT+1,MAGRY(CT)=$P(Z,";",3) + . I J=41 D Q ; Need to compute the Class. Class field in Image File is wrong. + . . S MAGVAL=$S('T:"",'$D(^MAG(2005.83,T,0)):"",1:$P(^MAG(2005.82,$P(^MAG(2005.83,T,0),"^",2),0),"^",1)) + . . S MAGRY(CT)=MAGRY(CT)_" "_MAGVAL + . . Q + . D GETS^DIQ(2005,IEN,JI,FLAGS,"MAGOUT","MAGERR") + . ; Get Extension from FileRef + . I J=1 S MAGVAL=$P($G(MAGOUT(2005,IENC,J,"E")),".",2) + . E S MAGVAL=$G(MAGOUT(2005,IENC,J,"E")) + . S MAGRY(CT)=MAGRY(CT)_" "_MAGVAL + ; Compare Parent Association Date with Date/Time Note Signed. + I $P(^MAG(2005,IEN,0),"^",10) S IEN=$P(^MAG(2005,IEN,0),"^",10) + I $P(^MAG(2005,IEN,2),"^",6)=8925 S CT=CT+1,MAGRY(CT)=$$ATTSTAT^MAGGTU31(IEN) + Q + ; +FLDS ;;Format: ;3;; + ;;Extension: ;1;; +FLDG ;;Patient: ;5;; + ;;Desc: ;10;; + ;;Procedure: ;6;; + ;; Date: ;15;; + ;;Class: ;41;; + ;;Package: ;40;; + ;;Type: ;42;; + ;;Proc/Event: ;43;; + ;;Spec/SubSpec: ;44;; + ;;Origin: ;45;; + ;;Captured on: ;7;; + ;; by: ;8;; + ;;end;; diff --git a/r/IMAGING-MAG-ZMAG/MAGGTU31.m b/r/IMAGING-MAG-ZMAG/MAGGTU31.m index e2009cc3..a9aef0be 100644 --- a/r/IMAGING-MAG-ZMAG/MAGGTU31.m +++ b/r/IMAGING-MAG-ZMAG/MAGGTU31.m @@ -1,159 +1,62 @@ -MAGGTU31 ;WOIFO/GEK - Silent calls for Imaging ; [ 06/20/2001 08:57 ] - ;;3.0;IMAGING;**46,59**;Nov 27, 2007;Build 20 - ;; Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q -ATTSTAT(IEN) ; Return a sentence saying if the Image was attached - ; to the TIU NOte before or after the Note was signed. - ; was signed. - N SIGNDT,NOTE,MARR,AMMEND,N2,MAGDT,NC,CLOSDT,X - S N2=$G(^MAG(2005,IEN,2)) - I $P(N2,"^",6)'=8925 Q "" - S MAGDT=$S($P(N2,"^",11):$P(N2,"^",11),1:$P(N2,"^",1)) - S NOTE=$P(N2,"^",7) - S NC=NOTE_"," - D GETS^DIQ(8925,NOTE,".01;.06;1501;1606","I","MARR") - I $D(DIERR) Q "Error: Note-"_NOTE_" : "_$G(^TMP("DIERR",$J,1,"TEXT",1)) - I (MARR(8925,NC,".01","I")=81)!(MARR(8925,NC,".06","I")>0) Q "Image is attached to an Addendum" - S SIGNDT=MARR(8925,NC,"1501","I") - S CLOSDT=MARR(8925,NC,"1606","I") - I CLOSDT]"" D Q X - . I $P(CLOSDT,".",2)="" S MAGDT=$P(MAGDT,".",1) I MAGDT=CLOSDT S X="Image was attached Same Day as Note was Electronically Filed." Q - . I MAGDT>CLOSDT S X="Image was attached After Note was Electronically Filed." Q - . S X="Image was attached Before Note was Electronically Filed." Q - . Q - I SIGNDT="" Q "Image is attached to an UnSigned Note." - I $P(SIGNDT,".",2)="" S MAGDT=$P(MAGDT,".",1) I MAGDT=SIGNDT Q "Image was attached Same Day as Note was Signed." - I MAGDT>SIGNDT Q "Image was attached After the Note was Signed." - Q "Image was attached Before the Note was Signed." -USERKEYS(MAGK) ; RPC [MAGGUSERKEYS] (called from MAGGTU3) - N Y - N MAGKS ; list of keys to send to XUS KEY CHECK - N MAGKG ; list returned from XUS KEY CHECK - N I,J,MAGMED,MAGKEY,MAGPLC - K MAGK - S MAGPLC=+$$PLACE^MAGBAPI(DUZ(2)) ; DBI - SEB 9/20/2002 - S MAGKEY=+$P($G(^MAG(2006.1,MAGPLC,"KEYS")),U) - I 'MAGKEY S MAGK(0)="CAPTURE KEYS OFF" - E S MAGK(0)="CAPTURE KEYS ON" - N X S X="MAG",I=0 - F S X=$O(^XUSEC(X)) Q:$E(X,1,3)'="MAG" D - . S I=I+1,MAGKS(I)=X - D OWNSKEY^XUSRB(.MAGKG,.MAGKS) - S I=0,J=0,MAGMED=0 - F S I=$O(MAGKG(I)) Q:I="" D - . Q:MAGKG(I)=0 - . S J=J+1,MAGK(J)=MAGKS(I) - . I MAGKS(I)["MAGCAP MED" S MAGMED=1 - I MAGMED S J=J+1,MAGK(J)="MAGCAP MED" - Q -GETINFO(MAGRY,IEN) ; RPC [MAG4 GET IMAGE INFO]Called from MAGGTU3 - ; Call (3.0p8) to get information on 1 image - ; and Display in the Image Information Window - N Y,J,JI,I,CT,IENC,FLAGS,SNGRP,Z,M40,T,QACHK,OBJTYP,VAL,LBL - S I=0,CT=0 - S MAGRY(CT)="Image ID#: "_IEN - I $D(^MAG(2005.1,IEN)) D Q - . S CT=CT+1,MAGRY(CT)=" STATUS: "_"HAS BEEN DELETED. !!" - . S CT=CT+1,MAGRY(CT)="Deleted By: "_$$GET1^DIQ(2005.1,IEN,30,"E") - . S CT=CT+1,MAGRY(CT)=" Reason: "_$$GET1^DIQ(2005.1,IEN,30.2,"E") - . S CT=CT+1,MAGRY(CT)=" Date: "_$$GET1^DIQ(2005.1,IEN,30.1,"E") - . Q - S M40=$G(^MAG(2005,IEN,40)),T=$P(M40,"^",3) - S Z=$P($G(^MAG(2005,IEN,0)),"^",10) I Z D - . S CT=CT+1,MAGRY(CT)=" is in Group#: "_Z_" ("_+$P(^MAG(2005,Z,1,0),"^",4)_" images)" - . D CHK^MAGGSQI(.QACHK,Z) Q:QACHK(0) - . S CT=CT+1,MAGRY(CT)=" QA Warning - Group#: "_Z_" "_$P(QACHK(0),"^",2) - . Q - S OBJTYP=$P(^MAG(2005,IEN,0),"^",6) - S SNGRP="FLDS" - I (+$O(^MAG(2005,IEN,1,0)))!(OBJTYP=11)!(OBJTYP=16) D - . S CT=CT+1,MAGRY(CT)=$P($G(^MAG(2005,IEN,40)),"^",1)_" Group of "_+$P($G(^MAG(2005,IEN,1,0)),U,4) - . S SNGRP="FLDG" - . Q - K QACHK - D CHK^MAGGSQI(.QACHK,IEN) I 'QACHK(0) D - . S CT=CT+1,MAGRY(CT)=" QA Warning - Image#: "_IEN_" "_$P(QACHK(0),"^",2) - N MAGOUT,MAGERR,MAGVAL,PKG - S IENC=IEN_"," - S FLAGS="EN" - S I=-1 - S PKG="" - F S I=I+1,Z=$T(@SNGRP+I) Q:$P(Z,";",3)="end" D - . S J=$P(Z,";",4),JI=J_";" - . K MAGOUT - . S CT=CT+1,MAGRY(CT)=$P(Z,";",3) - . I J=41 D Q ; Need to compute the Class. Class field in Image File is wrong. - . . S MAGVAL=$S('T:"",'$D(^MAG(2005.83,T,0)):"",1:$P(^MAG(2005.82,$P(^MAG(2005.83,T,0),"^",2),0),"^",1)) - . . S MAGRY(CT)=MAGRY(CT)_" "_MAGVAL - . . Q - . D GETS^DIQ(2005,IEN,JI,FLAGS,"MAGOUT","MAGERR") - . ; Get Extension from FileRef - . I J=1 S MAGVAL=$P($G(MAGOUT(2005,IENC,J,"E")),".",2) - . E S MAGVAL=$G(MAGOUT(2005,IENC,J,"E")) - . S MAGVAL=$TR(MAGVAL,"&","+") - . I J=40 S PKG=MAGVAL - . I ((J>=50)&(J<=54)) D Q - . . I PKG'="LAB" K MAGRY(CT) Q - . . S MAGRY(CT)=MAGRY(CT)_" "_MAGVAL - . . Q - . S MAGRY(CT)=MAGRY(CT)_" "_MAGVAL - ; Compare Parent Association Date with Date/Time Note Signed. - I $P(^MAG(2005,IEN,0),"^",10) S IEN=$P(^MAG(2005,IEN,0),"^",10) - I $P(^MAG(2005,IEN,2),"^",6)=8925 S CT=CT+1,MAGRY(CT)=$$ATTSTAT^MAGGTU31(IEN) - ; - I (OBJTYP=11),($P($G(^MAG(2005,IEN,100)),"^",6)="") D - . S X=$O(^MAG(2005,IEN,1,0)) - . S IEN=+$G(^MAG(2005,IEN,1,X,0)) - . Q - I $P($G(^MAG(2005,IEN,100)),"^",6)]"" D - . I OBJTYP=11 D ; If a Group, get Object Type of First Child - . . S Z=$O(^MAG(2005,IEN,1,0)) - . . I 'Z Q - . . S Z=+$G(^MAG(2005,IEN,1,Z,0)) - . . S OBJTYP=+$P($G(^MAG(2005,Z,0)),"^",6) ; Object of First Child - . . Q - . S OBJTYP=","_OBJTYP_"," - . S LBL="",VAL="" - . I ",3,9,10,12,100,"[OBJTYP S LBL="Image Creation Date: " ; "Acquisition Date"; - . I ",15,101,102,103,104,105,"[OBJTYP S LBL="Document Creation Date: " - . I LBL="" S LBL="Image Creation Date: " - . S VAL=$$GET1^DIQ(2005,IEN,110,"E") S:(VAL="") VAL="N/A" - . S CT=CT+1,MAGRY(CT)=LBL_VAL - . Q - Q - ; -FLDS ;;Format: ;3;; - ;;Extension: ;1;; -FLDG ;;Patient: ;5;; - ;;Desc: ;10;; - ;;Procedure: ;6;; - ;; Date: ;15;; - ;;Class: ;41;; - ;;Package: ;40;; - ;;Type: ;42;; - ;;Proc/Event: ;43;; - ;;Spec/SubSpec: ;44;; - ;;Origin: ;45;; - ;;Accession # ;50;; - ;;Specimen Desc ;51;; - ;;Specimen# ;52;; - ;;Stain ;53;; - ;;Objective ;54;; - ;;Captured on: ;7;; - ;; by: ;8;; - ;;end;; +MAGGTU31 ;WOIFO/GEK - Silent calls for Imaging ; [ 06/20/2001 08:57 ] + ;;3.0;IMAGING;**46**;16-February-2007;;Build 1023 + ;; Per VHA Directive 2004-038, this routine should not be modified. + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q +ATTSTAT(IEN) ; Return a sentence saying if the Image was attached + ; to the TIU NOte before or after the Note was signed. + ; was signed. + N SIGNDT,NOTE,MARR,AMMEND,N2,MAGDT,NC,CLOSDT,X + S N2=$G(^MAG(2005,IEN,2)) + I $P(N2,"^",6)'=8925 Q "" + S MAGDT=$S($P(N2,"^",11):$P(N2,"^",11),1:$P(N2,"^",1)) + S NOTE=$P(N2,"^",7) + S NC=NOTE_"," + D GETS^DIQ(8925,NOTE,".01;.06;1501;1606","I","MARR") + I $D(DIERR) Q "Error: Note-"_NOTE_" : "_$G(^TMP("DIERR",$J,1,"TEXT",1)) + I (MARR(8925,NC,".01","I")=81)!(MARR(8925,NC,".06","I")>0) Q "Image is attached to an Addendum" + S SIGNDT=MARR(8925,NC,"1501","I") + S CLOSDT=MARR(8925,NC,"1606","I") + I CLOSDT]"" D Q X + . I $P(CLOSDT,".",2)="" S MAGDT=$P(MAGDT,".",1) I MAGDT=CLOSDT S X="Image was attached Same Day as Note was Electronically Filed." Q + . I MAGDT>CLOSDT S X="Image was attached After Note was Electronically Filed." Q + . S X="Image was attached Before Note was Electronically Filed." Q + . Q + I SIGNDT="" Q "Image is attached to an UnSigned Note." + I $P(SIGNDT,".",2)="" S MAGDT=$P(MAGDT,".",1) I MAGDT=SIGNDT Q "Image was attached Same Day as Note was Signed." + I MAGDT>SIGNDT Q "Image was attached After the Note was Signed." + Q "Image was attached Before the Note was Signed." +USERKEYS(MAGK) ; RPC [MAGGUSERKEYS] (called from MAGGTU3) + N Y + N MAGKS ; list of keys to send to XUS KEY CHECK + N MAGKG ; list returned from XUS KEY CHECK + N I,J,MAGMED,MAGKEY,MAGPLC + K MAGK + S MAGPLC=+$$PLACE^MAGBAPI(DUZ(2)) ; DBI - SEB 9/20/2002 + S MAGKEY=+$P($G(^MAG(2006.1,MAGPLC,"KEYS")),U) + I 'MAGKEY S MAGK(0)="CAPTURE KEYS OFF" + E S MAGK(0)="CAPTURE KEYS ON" + N X S X="MAG",I=0 + F S X=$O(^XUSEC(X)) Q:$E(X,1,3)'="MAG" D + . S I=I+1,MAGKS(I)=X + D OWNSKEY^XUSRB(.MAGKG,.MAGKS) + S I=0,J=0,MAGMED=0 + F S I=$O(MAGKG(I)) Q:I="" D + . Q:MAGKG(I)=0 + . S J=J+1,MAGK(J)=MAGKS(I) + . I MAGKS(I)["MAGCAP MED" S MAGMED=1 + I MAGMED S J=J+1,MAGK(J)="MAGCAP MED" + Q diff --git a/r/IMAGING-MAG-ZMAG/MAGGTU4.m b/r/IMAGING-MAG-ZMAG/MAGGTU4.m index 41d9c4fb..6026a3a6 100644 --- a/r/IMAGING-MAG-ZMAG/MAGGTU4.m +++ b/r/IMAGING-MAG-ZMAG/MAGGTU4.m @@ -1,184 +1,177 @@ -MAGGTU4 ;WOIFO/GEK - Imaging Client- Version checking routine; [ 06/20/2001 08:57 ] - ;;3.0;IMAGING;**8,48,63,45,46,59,96**;April 29, 2008;Build 9 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q -GETVER(SVRVER,SVRTVER,A) ; - ; We Can't compute the Server's current version - ; KIDS installs aren't all related to the Delphi Client. - ; The Server Version SVRVER needs hardcoded to match the Delphi Client. - ; and This Routine must be distributed whenever a new Client is - S SVRVER="3.0.96" - S SVRTVER="4" ; This is the T version that the server expects - ; released Client will have the T version that the server expects - S A("3.0.24")=5 ;Sept 2003 - S A("3.0.33")=11 ;June 2004 - S A("3.0.8")=49 ;Sept 2004 - S A("3.0.42")=1 ;n/a - S A("3.0.48")=6 ;Mar 2005 - S A("3.0.63")=4 ;June 2005 - S A("3.0.45")=8 ;Sept 2005 - S A("3.0.46")=28 ;Mar 2007 - S A("3.0.59")=31 ;Jul 2007 - S A("3.0.72")=21 ;Jan 2008 - S A("3.0.83")=24 ;Mar 2008 - S A("3.0.95")=5 ;Mar 2008 - S A("3.0.96")=4 ;Apr 2008 - Q - ; -CHKVER(MAGRY,CLVER) ;RPC [MAG4 VERSION CHECK] - ; CLVER is the version of the Delphi Client. - ; CLVER format = Major.Minor.Patch.T-version - ; example : for Version 3.0 Patch 8 T 21 --> CLVER=3.0.8.21 - ; Ver 2.5P9 (2.5.24.1) is first Delphi Ver that makes this call. - ; CLVER may have Parameters attached to it in '|' pieces. - ; "CLVER|RIV" this is a remote image view client - ; "CLVER|CAPTURE" this is a Capture Client - ; "CLVER|DISPLAY" this is a Display Client - ; 3 possible return codes in 1st '^' piece of MAGRY(0). - ; 0^message : The Client will display the message and continue. - ; 1^message : The Client will continue without displaying any message. - ; 2^message : The Client will display the message and then Abort. (Terminate) - ; The message displayed is the 2nd '^' piece of (0) node - ; and all text of any other nodes. i.e. MAGRY(1..n) - ; - S CLVER=$G(CLVER) - ; Bug in 42. the Version comes in as 30.5.42.x (42 wasn't released) - I $P(CLVER,".",1)="30" S CLVER="3.0."_$P(CLVER,".",3,99) - ; - N PLC,SV,ST,SVSTAT,CV,CP,CT,OKVER,WARN,I,BETA - ; PLC = Entry in 2006.1 - ; SV = Server Version -> (3.0.8) from (3.0.8.43) Hard coded to Sync with Delphi Clients - ; ST = Server T Version -> 43 from full version (3.0.8.43) - ; CV = Client Version sent from Client 3.0.8 same format as SV - ; CT = Client T Version sent from Client i.e. 43 same format as ST - ; OKVER = Array of Supported Versions, and Released T Version OKVER(3.0.48)=6 - ; WARN = 1|0 Boolean value determines if client needs EKG Warning. - ; - S PLC=$$PLACE^MAGBAPI($G(DUZ(2))) - ; Quit if we don't have a valid DUZ(2) or valid PLACE: ^MAG(2006.1,PLC) - I 'PLC D BADPLC^MAGGTU41(.MAGRY) Q - ; - ; Set up local variables. - D GETVER(.SV,.ST,.OKVER) - F I=2:1:$L(CLVER,"|") I $P(CLVER,"|",I)]"" S MAGJOB($P(CLVER,"|",I))=1 - S CLVER=$P(CLVER,"|",1) - S CV=$P(CLVER,".",1,3),CP=$P(CLVER,".",3),CT=$P(CLVER,".",4) - I CT="" S $P(CLVER,".",4)=0,CT=0 - ; set WARN to indicate if Warning is needed or not. - ; - D NEEDWARN(.WARN) - ; Quit if site has VERSION CHECKING=0 (OFF) in Imaging Site Params File. - I '$$VERCHKON(PLC) D Q - . S MAGRY(0)="1^Version Checking is OFF. Allowing All Versions" - . ; But, need to Display the warning, even if Version Checking is OFF - . I WARN S MAGRY(0)="0^ =========== WARNING ===============" D WARNING - . Q - ; If Remote Connection , allow it. - I $D(MAGJOB("RIV")) S MAGRY(0)="1^Allowing Remote Image Connection" Q - ; Is this Server Version Alpha/Beta or Released. - D VERSTAT(.SVSTAT,SV) - I 'SVSTAT S MAGRY(0)="2^"_$P(SVSTAT,"^",2) Q ; There is not record of a KIDS for this Server. - ; Set Alpha Beta Flag - S BETA=(+SVSTAT=2) - ; If Client isn't one of the Supported Clients. - I (CV'=SV),'$D(OKVER(CV)) D Q - . I BETA D NOTOKB^MAGGTU41(.MAGRY) Q - . D NOTOK^MAGGTU41(.MAGRY) Q - . Q - ; - ; Client is Supported. Only Warn if we are Not In ALPHA/BETA Testing. - I (CV'=SV) D Q - . I CT<$G(OKVER(CV)) D Q - . . I BETA DO OKBADTB^MAGGTU41(.MAGRY) Q - . . DO OKBADT^MAGGTU41(.MAGRY) Q - . . Q - . I BETA D OKB^MAGGTU41(.MAGRY) - . E D OK^MAGGTU41(.MAGRY) - . I WARN D WARNING - . Q - ; - ; At this point, Versions are the Same: If T versions are not, warn the Client. - I CT,(CT'=ST) D Q - . I BETA D TNOTOKB^MAGGTU41(.MAGRY) Q - . D TNOTOK^MAGGTU41(.MAGRY) Q - . Q - ; Client and Server Versions are the same, to the T. (Ha, get it) - S MAGRY(0)="1^Version Check OK. Server: "_SV_" Client: "_CV Q - Q - ; -VERCHKON(PLC) ; Is Version checking on for the site (Place) - Q +$P(^MAG(2006.1,PLC,"KEYS"),"^",5) - ; -NEEDWARN(WARN) ; This call determines if Client needs the warning. - S WARN=0 Q ; we don't need warning anymore. - I $P($G(^MAG(2006.1,PLC,"USERPREF")),U,2)="" S WARN=0 Q ; Not a MUSE Site. - I $D(MAGJOB("CAPTURE")) S WARN=0 Q ;Not needed for Capture Clients - I CV="3.0.59" S WARN=0 Q ; Client 59 has 63. - I CV="3.0.45" S WARN=0 Q ; Client 45 has 63. - I CV="3.0.41" S WARN=0 Q ; It is fixed in 41 - I CV="3.0.63" S WARN=0 Q ; It is fixed in 63 - I $P(CV,".",1)=2 S WARN=0 Q ;Older Clients don't have the EKG Problem. - I '$D(OKVER(CV)) S WARN=0 Q ; Patch 3.0.7, 3.0.2 don't have EKG problem. - S WARN=1 ; This means to Show the EKG Warning. - Q - ; -WARNING ; This is hard coded for the EKG Warning. - ; Put Warning at the End of any Return Message. - S MAGRY(1000)=" " - S MAGRY(1010)="!*************************************************!" - S MAGRY(1015)=" " - S MAGRY(1020)=" PATIENT SAFETY NOTIFICATION" - S MAGRY(1025)=" " - S MAGRY(1030)=" Under certain circumstances, the EKG window will not" - S MAGRY(1040)="refresh properly when you select a new patient in CPRS; " - S MAGRY(1050)="instead of showing the new patient, the EKG window will " - S MAGRY(1060)="continue to show the previous patient. " - S MAGRY(1065)=" " - S MAGRY(1070)="To prevent this problem:" - S MAGRY(1075)=" " - S MAGRY(1080)=" Verify that the 'Show MUSE EKGs' option under" - S MAGRY(1085)=" Options > View Preferences is checked;" - S MAGRY(1090)=" OR" - S MAGRY(1100)=" Do not minimize the Imaging Display window while viewing EKGs." - S MAGRY(1110)=" " - S MAGRY(1115)="This problem will be corrected shortly by Imaging Patch 63." - S MAGRY(1120)="!*************************************************!" - Q -VERSTAT(MAGRY,MAGVER) ;RPC - [MAG4 VERSION STATUS] - ; Returns the status of an Imaging Version - ; Input : - ; MAGVER - Version number - ; in the format MAG*3.0*59 - ; or the format 3.0.59 - ; Return: - ; MAGRY = 0^There is No KIDs Install record - ; 1^Unknown Release Status - ; 2^Alpha/Beta Version - ; 3^Released Version - ; - N VERI,TVER,MAGERR - I +MAGVER S MAGVER="MAG*"_$P(MAGVER,".",1,2)_"*"_$P(MAGVER,".",3) - S VERI=$$FIND1^DIC(9.6,"","MO",MAGVER,"","","MAGERR") - I 'VERI S MAGRY="0^There is No KIDs Install record for """_MAGVER_"""." Q - S TVER=$$GET1^DIQ(9.6,VERI_",","ALPHA/BETA TESTING") - I TVER="YES" S MAGRY="2^Alpha/Beta Version." Q - I TVER="NO" S MAGRY="3^Released Version." Q - S MAGRY="1^Unknown Release Status." - Q -ABSJB(MAGRY,MAGIN) ;RPC [MAG ABSJB] SET ABSTRACT AND/OR JUKEBOX QUEUES - D ABSJB^MAGGTU71(.MAGRY,.MAGIN) - Q +MAGGTU4 ;WOIFO/GEK - Testing callbacks for Delphi Doc Image Prototype ; 02/16/2007 13:37 + ;;3.0;IMAGING;**8,48,63,45,46**;16-February-2007;;Build 1023 + ;; Per VHA Directive 2004-038, this routine should not be modified. + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q +GETVER(SVRVER,SVRTVER,A) ; + ; We Can't compute the Server's current version + ; KIDS installs aren't all related to the Delphi Client. + ; The Server Version SVRVER needs hardcoded to match the Delphi Client. + ; and This Routine must be distributed whenever a new Client is + S SVRVER="3.0.46" + S SVRTVER=28 ; This is the T version that the server expects + ; released Client will have the T version that the server expects + S A("3.0.24")=5 ;Sept 2003 + S A("3.0.33")=11 ;June 2004 + S A("3.0.8")=49 ;Sept 2004 + S A("3.0.42")=1 ;n/a + S A("3.0.48")=6 ;Mar 2005 + S A("3.0.63")=4 ;June 2005 + S A("3.0.45")=8 ;Sept 2005 + S A("3.0.59")=20 ;July 2006 + Q + ; +CHKVER(MAGRY,CLVER) ;RPC [MAG4 VERSION CHECK] + ; CLVER is the version of the Delphi Client. + ; CLVER format = Major,Minor,Patch,T Version + ; example : for Version 3.0 Patch 8 T 21 --> CLVER=3.0.8.21 + ; Ver 2.5P9 (2.5.24.1) is first Delphi Ver that makes this call. + ; CLVER may have Parameters attached to it in '|' pieces. + ; "CLVER|RIV" this is a remote image view client + ; "CLVER|CAPTURE" this is a Capture Client + ; "CLVER|DISPLAY" this is a Display Client + ; 3 possible return codes in 1st '^' piece of MAGRY(0). + ; 0^message : The Client will display the message and continue. + ; 1^message : The Client will continue without displaying any message. + ; 2^message : The Client will display the message and then Abort. (Terminate) + ; The message displayed is the 2nd '^' piece of (0) node + ; and all text of any other nodes. i.e. MAGRY(1..n) + ; + S CLVER=$G(CLVER) + ; Bug in 42. the Version comes in as 30.5.42.x (42 wasn't released) + I $P(CLVER,".",1)="30" S CLVER="3.0."_$P(CLVER,".",3,99) + ; + N PLC,SV,ST,SVSTAT,CV,CP,CT,OKVER,WARN,I + ; PLC = Entry in 2006.1 + ; SV = Server Version -> (3.0.8) from (3.0.8.43) Hard coded to Sync with Delphi Clients + ; ST = Server T Version -> 43 from full version (3.0.8.43) + ; CV = Client Version sent from Client 3.0.8 same format as SV + ; CT = Client T Version sent from Client i.e. 43 same format as ST + ; OKVER = Array of Supported Versions, and Released T Version OKVER(3.0.48)=6 + ; WARN = 1|0 Boolean value determines if client needs EKG Warning. + ; + S PLC=$$PLACE^MAGBAPI($G(DUZ(2))) + ; Quit if we don't have a valid DUZ(2) or valid PLACE: ^MAG(2006.1,PLC) + I 'PLC D BADPLC^MAGGTU41(.MAGRY) Q + ; + ; Set up local variables. + D GETVER(.SV,.ST,.OKVER) + F I=2:1:$L(CLVER,"|") I $P(CLVER,"|",I)]"" S MAGJOB($P(CLVER,"|",I))=1 + S CLVER=$P(CLVER,"|",1) + S CV=$P(CLVER,".",1,3),CP=$P(CLVER,".",3),CT=$P(CLVER,".",4) + I CT="" S $P(CLVER,".",4)=0,CT=0 + ; set WARN to indicate if Warning is needed or not. + ; + D NEEDWARN(.WARN) + ; Quit if site has VERSION CHECKING=0 (OFF) in Imaging Site Params File. + I '$$VERCHKON(PLC) D Q + . S MAGRY(0)="1^Version Checking is OFF. Allowing All Versions" + . ; But, need to Display the warning, even if Version Checking is OFF + . I WARN S MAGRY(0)="0^ =========== WARNING ===============" D WARNING + . Q + ; If Remote Connection , allow it. + I $D(MAGJOB("RIV")) S MAGRY(0)="1^Allowing Remote Image Connection" Q + ; Is this Server Version Alpha/Beta or Released. + D VERSTAT(.SVSTAT,SV) + I 'SVSTAT S MAGRY(0)="2^"_$P(SVSTAT,"^",2) Q ; There is not record of a KIDS for this Server. + ; + ; If Client isn't one of the Supported Clients. + I (CV'=SV),'$D(OKVER(CV)) D Q + . I +SVSTAT=2 D NOTOKB^MAGGTU41(.MAGRY) Q + . D NOTOK^MAGGTU41(.MAGRY) Q + . Q + ; + ; Client is Supported. Only Warn if we are Not In ALPHA/BETA Testing. + I (CV'=SV) D Q + . I CT<$G(OKVER(CV)) D Q + . . I +SVSTAT=2 DO OKBADTB^MAGGTU41(.MAGRY) Q + . . DO OKBADT^MAGGTU41(.MAGRY) Q + . . Q + . I +SVSTAT=2 D OKB^MAGGTU41(.MAGRY) + . E D OK^MAGGTU41(.MAGRY) + . I WARN D WARNING + . Q + ; + ; At this point, Versions are the Same: If T versions are not, warn the Client. + I CT,(CT'=ST) D Q + . I +SVSTAT=2 D TNOTOKB^MAGGTU41(.MAGRY) Q + . D TNOTOK^MAGGTU41(.MAGRY) Q + . Q + ; Client and Server Versions are the same, to the T. (Ha, get it) + S MAGRY(0)="1^Version Check OK. Server: "_SV_" Client: "_CV Q + Q + ; +VERCHKON(PLC) ; Is Version checking on for the site (Place) + Q +$P(^MAG(2006.1,PLC,"KEYS"),"^",5) + ; +NEEDWARN(WARN) ; This call determines if Client needs the warning. + I $P($G(^MAG(2006.1,PLC,"USERPREF")),U,2)="" S WARN=0 Q ; Not a MUSE Site. + I $D(MAGJOB("CAPTURE")) S WARN=0 Q ;Not needed for Capture Clients + I CV="3.0.59" S WARN=0 Q ; Client 59 has 63. + I CV="3.0.45" S WARN=0 Q ; Client 45 has 63. + I CV="3.0.41" S WARN=0 Q ; It is fixed in 41 + I CV="3.0.63" S WARN=0 Q ; It is fixed in 63 + I $P(CV,".",1)=2 S WARN=0 Q ;Older Clients don't have the EKG Problem. + I '$D(OKVER(CV)) S WARN=0 Q ; Patch 3.0.7, 3.0.2 don't have EKG problem. + S WARN=1 ; This means to Show the EKG Warning. + Q + ; +WARNING ; This is hard coded for the EKG Warning. + ; Put Warning at the End of any Return Message. + S MAGRY(1000)=" " + S MAGRY(1010)="!*************************************************!" + S MAGRY(1015)=" " + S MAGRY(1020)=" PATIENT SAFETY NOTIFICATION" + S MAGRY(1025)=" " + S MAGRY(1030)=" Under certain circumstances, the EKG window will not" + S MAGRY(1040)="refresh properly when you select a new patient in CPRS; " + S MAGRY(1050)="instead of showing the new patient, the EKG window will " + S MAGRY(1060)="continue to show the previous patient. " + S MAGRY(1065)=" " + S MAGRY(1070)="To prevent this problem:" + S MAGRY(1075)=" " + S MAGRY(1080)=" Verify that the 'Show MUSE EKGs' option under" + S MAGRY(1085)=" Options > View Preferences is checked;" + S MAGRY(1090)=" OR" + S MAGRY(1100)=" Do not minimize the Imaging Display window while viewing EKGs." + S MAGRY(1110)=" " + S MAGRY(1115)="This problem will be corrected shortly by Imaging Patch 63." + S MAGRY(1120)="!*************************************************!" + Q +VERSTAT(MAGRY,MAGVER) ;RPC - [MAG4 VERSION STATUS] + ; Returns the status of an Imaging Version + ; Input : + ; MAGVER - Version number + ; in the format MAG*3.0*59 + ; or the format 3.0.59 + ; Return: + ; MAGRY = 0^There is No KIDs Install record + ; 1^Unknown Release Status + ; 2^Alpha/Beta Version + ; 3^Released Version + ; + N VERI,TVER,MAGERR + I +MAGVER S MAGVER="MAG*"_$P(MAGVER,".",1,2)_"*"_$P(MAGVER,".",3) + S VERI=$$FIND1^DIC(9.6,"","M",MAGVER,"","","MAGERR") + I 'VERI S MAGRY="0^There is No KIDs Install record." Q + S TVER=$$GET1^DIQ(9.6,VERI_",","ALPHA/BETA TESTING") + I TVER="YES" S MAGRY="2^Alpha/Beta Version." Q + I TVER="NO" S MAGRY="3^Released Version." Q + S MAGRY="1^Unknown Release Status." + Q +ABSJB(MAGRY,MAGIN) ;RPC [MAG ABSJB] SET ABSTRACT AND/OR JUKEBOX QUEUES + D ABSJB^MAGGTU71(.MAGRY,.MAGIN) + Q diff --git a/r/IMAGING-MAG-ZMAG/MAGGTU41.m b/r/IMAGING-MAG-ZMAG/MAGGTU41.m index e64a534b..f3531d22 100644 --- a/r/IMAGING-MAG-ZMAG/MAGGTU41.m +++ b/r/IMAGING-MAG-ZMAG/MAGGTU41.m @@ -1,125 +1,124 @@ -MAGGTU41 ;WOIFO/GEK - Version Control utilities ; [ 06/20/2001 08:57 ] - ;;3.0;IMAGING;**46,59**;Nov 27, 2007;Build 20 - ;; Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q -NOTOKB(X) ; Client Not Supported. Server is Beta - ; Client will not be supported when this version is Released. Warn Client. - S X(0)="0^ This site is a test site for Version: "_SV_"." - S X(5)=" Client is running Version: "_CV - S X(7)=" " - S X(10)=" When Version : "_SV_" is Released, " - S X(15)=" Client Version: "_CV_" will no longer be supported." - S X(17)=" " - S X(18)=" This Client Application will not work correctly." - S X(19)=" " - S X(20)=" Contact the Imaging System Manager to update this workstation." - S X(30)=" " - S X(40)=" APPLICATION Will Continue" - Q -NOTOK(X) ; Client Not Supported. - S X(0)="2^ Server is running Imaging V. "_SV_" "_$P(SVSTAT,"^",2) - S X(1)=" " - S X(5)=" Client is running Imaging V. "_CV - S X(7)=" " - S X(10)=" Version "_CV_" is no longer supported." - S X(15)=" " - S X(20)=" Contact the Imaging System Manager to update this workstation." - S X(30)=" " - S X(40)=" APPLICATION WILL ABORT !" - ; Clients prior to 8, have a 'Cancel' button on Message Dialog (oversight) - I $P(CV,".",1)=2 S X(50)="(clicking 'Cancel' will not stop the Abort.)" - Q -OKBADTB(X) ; Client not Equal, Is supported. Previous Supported Version. Beta - ; But it's T isn't the T of it's Released Patch - S X(0)="0^ Server is running Imaging V. "_SV_" "_$P(SVSTAT,"^",2) - S X(3)=" " - S X(5)=" Client is running Imaging V. "_CLVER - S X(10)=" The Released Version of Patch "_CP_" is V. "_CV_"."_$G(OKVER(CV)) - S X(12)=" " - S X(18)=" This Client Application will not work correctly. You should" - S X(20)=" update this workstation with the Released Version of Patch "_CP - S X(21)=" " - S X(22)=" Contact the Imaging System Manager to update this workstation." - S X(27)=" " - S X(30)=" APPLICATION will Continue " - Q -OKBADT(X) ; Client not Equal, but it is supported. Previous Supported Version - ; But it's T isn't the T of it's Released Patch - S X(0)="2^ Server is running Imaging V. "_SV_" "_$P(SVSTAT,"^",2) - S X(3)=" " - S X(5)=" Client is running Imaging V. "_CLVER - S X(10)=" The Released Version of Patch "_CP_" is V. "_CV_"."_$G(OKVER(CV)) - S X(15)=" " - S X(18)=" Version "_CLVER_" is not supported." - S X(19)=" " - S X(20)=" You must update this workstation." - S X(22)=" " - S X(25)=" Contact the Imaging System Manager to update this workstation." - S X(27)=" " - S X(40)=" APPLICATION WILL ABORT !" - Q -OKB(X) ; Client is Not Equal to server. Server Version / Beta - ; Alpha/Beta Version so allow to continue. no message - S X(0)="1^ Alpha/Beta testing in progress for: "_SV - Q -OK(X) ; Client is Not Equal to the server. Warn - S X(0)="0^ Server is running Imaging V. "_SV_" "_$P(SVSTAT,"^",2) - S X(5)=" Client is running Imaging V. "_CV - S X(7)=" " - S X(10)=" The Client application should be updated " - S X(15)=" " - S X(20)=" Contact the Imaging System Manager to update this workstation." - S X(30)=" " - S X(40)=" APPLICATION Will Continue" - ; Clients prior to 8, have a 'Cancel' button on Message Dialog (oversight) - I $P(CV,".",1)=2 S X(50)="(clicking 'Cancel' will not stop the Client.)" - Q - ; - ; Versions are the Same: If T versions are not, warn the Client. - ; Released Client (of any version) will have the T version that the server expects, and - ; no warning will be displayed. -TNOTOKB(X) ; Client T is Not Equal to Server T, Beta Site. - ;I CT,(CT'=ST) D Q - S X(0)="0^ Server is running Imaging V. "_SV_"."_ST_" "_$P(SVSTAT,"^",2) - S X(5)=" Client is running Imaging V. "_CLVER - S X(10)=" " - S X(20)=" Test Versions of Patch "_SV_" other than T"_ST_" may not work correctly." - S X(25)=" " - S X(30)=" APPLICATION will Continue " - Q -TNOTOK(X) ; Client T is Not Equal to Server T. - ;I CT,(CT'=ST) D Q - S X(0)="0^ Server is running Imaging V. "_SV_"."_ST_" "_$P(SVSTAT,"^",2) - S X(5)=" Client is running Imaging V. "_CLVER - S X(10)=" " - S X(12)=" For Patch "_CP_" the released T version is: "_ST - S X(20)=" You must update this workstation with the Released Version." - S X(22)=" " - S X(25)=" Contact the Imaging System Manager to update this workstation." - S X(27)=" " - S X(30)=" APPLICATION will Continue " - Q -BADPLC(X) ; The call to $$PLACE^MAGBAPI($G(DUZ(2))) Failed, return a message. - ; - I '$G(DUZ(2)) S X(0)="2^ Error: Undefined DUZ(2)" - E D - . S X(0)="2^ Error: Division "_$P($G(^DIC(4,DUZ(2),0)),"^",1)_" ["_DUZ(2)_"]" - . S X(2)=" is not an Imaging Site Parameter." - . Q - S X(5)=" Contact IRM. Application will abort" - Q +MAGGTU41 ;WOIFO/GEK - Version Control utilities ; [ 06/20/2001 08:57 ] + ;;3.0;IMAGING;**46**;16-February-2007;;Build 1023 + ;; Per VHA Directive 2004-038, this routine should not be modified. + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q +NOTOKB(X) ; Client Not Supported. Server is Beta + ; Client will not be supported when this version is Released. Warn Client. + S X(0)="0^ This site is a test site for Version: "_SV_"." + S X(5)=" Client is running Version: "_CV + S X(7)=" " + S X(10)=" When Version : "_SV_" is Released, " + S X(15)=" Client Version: "_CV_" will no longer be supported." + S X(17)=" " + S X(18)=" This Client Application will not work correctly." + S X(19)=" " + S X(20)=" Contact the Imaging System Manager to update this workstation." + S X(30)=" " + S X(40)=" APPLICATION Will Continue" + Q +NOTOK(X) ; Client Not Supported. + S X(0)="2^ Server is running Imaging V. "_SV_" "_$P(SVSTAT,"^",2) + S X(1)=" " + S X(5)=" Client is running Imaging V. "_CV + S X(7)=" " + S X(10)=" Version "_CV_" is no longer supported." + S X(15)=" " + S X(20)=" Contact the Imaging System Manager to update this workstation." + S X(30)=" " + S X(40)=" APPLICATION WILL ABORT !" + ; Clients prior to 8, have a 'Cancel' button on Message Dialog (oversight) + I $P(CV,".",1)=2 S X(50)="(clicking 'Cancel' will not stop the Abort.)" + Q +OKBADTB(X) ; Client not Equal, but it is supported. + ; But it's T isn't the T of it's Released Patch + S X(0)="0^ Server is running Imaging V. "_SV_" "_$P(SVSTAT,"^",2) + S X(3)=" " + S X(5)=" Client is running Imaging V. "_CLVER + S X(10)=" The Released Version of Patch "_CP_" is V. "_CV_"."_$G(OKVER(CV)) + S X(12)=" " + S X(18)=" This Client Application will not work correctly. You should" + S X(20)=" update this workstation with the Released Version of Patch "_CP + S X(21)=" " + S X(22)=" Contact the Imaging System Manager to update this workstation." + S X(27)=" " + S X(30)=" APPLICATION will Continue " + Q +OKBADT(X) ; Client not Equal, but it is supported. + ; But it's T isn't the T of it's Released Patch + S X(0)="2^ Server is running Imaging V. "_SV_" "_$P(SVSTAT,"^",2) + S X(3)=" " + S X(5)=" Client is running Imaging V. "_CLVER + S X(10)=" The Released Version of Patch "_CP_" is V. "_CV_"."_$G(OKVER(CV)) + S X(15)=" " + S X(18)=" Version "_CLVER_" is not supported." + S X(19)=" " + S X(20)=" You must update this workstation." + S X(22)=" " + S X(25)=" Contact the Imaging System Manager to update this workstation." + S X(27)=" " + S X(40)=" APPLICATION WILL ABORT !" + Q +OKB(X) ; Client is Not Equal to server. Server Version / Beta + ; Alpha/Beta Version so allow to continue. no message + S X(0)="1^ Alpha/Beta testing in progress for: "_SV + Q +OK(X) ; Client is Not Equal to the server. Warn + S X(0)="0^ Server is running Imaging V. "_SV_" "_$P(SVSTAT,"^",2) + S X(5)=" Client is running Imaging V. "_CV + S X(7)=" " + S X(10)=" The Client application should be updated " + S X(15)=" " + S X(20)=" Contact the Imaging System Manager to update this workstation." + S X(30)=" " + S X(40)=" APPLICATION Will Continue" + ; Clients prior to 8, have a 'Cancel' button on Message Dialog (oversight) + I $P(CV,".",1)=2 S X(50)="(clicking 'Cancel' will not stop the Client.)" + Q + ; + ; Versions are the Same: If T versions are not, warn the Client. + ; Released Client (of any version) will have the T version that the server expects, and + ; no warning will be displayed. +TNOTOKB(X) ; Client T is Not Equal to Server T, Beta Site. + ;I CT,(CT'=ST) D Q + S X(0)="0^ Server is running Imaging V. "_SV_"."_ST_" "_$P(SVSTAT,"^",2) + S X(5)=" Client is running Imaging V. "_CLVER + S X(10)=" " + S X(20)=" Test Versions of Patch "_SV_" other than T"_ST_" may not work correctly." + S X(25)=" " + S X(30)=" APPLICATION will Continue " + Q +TNOTOK(X) ; Client T is Not Equal to Server T. + ;I CT,(CT'=ST) D Q + S X(0)="0^ Server is running Imaging V. "_SV_"."_ST_" "_$P(SVSTAT,"^",2) + S X(5)=" Client is running Imaging V. "_CLVER + S X(10)=" " + S X(12)=" For Patch "_CP_" the released T version is: "_ST + S X(20)=" You must update this workstation with the Released Version." + S X(22)=" " + S X(25)=" Contact the Imaging System Manager to update this workstation." + S X(27)=" " + S X(30)=" APPLICATION will Continue " + Q +BADPLC(X) ; The call to $$PLACE^MAGBAPI($G(DUZ(2))) Failed, return a message. + ; + I '$G(DUZ(2)) S X(0)="2^ Error: Undefined DUZ(2)" + E D + . S X(0)="2^ Error: Division "_$P($G(^DIC(4,DUZ(2),0)),"^",1)_" ["_DUZ(2)_"]" + . S X(2)=" is not an Imaging Site Parameter." + . Q + S X(5)=" Contact IRM. Application will abort" + Q diff --git a/r/IMAGING-MAG-ZMAG/MAGGTU6.m b/r/IMAGING-MAG-ZMAG/MAGGTU6.m index 9a50bc48..92340d4c 100644 --- a/r/IMAGING-MAG-ZMAG/MAGGTU6.m +++ b/r/IMAGING-MAG-ZMAG/MAGGTU6.m @@ -1,191 +1,190 @@ -MAGGTU6 ;WOIFO/GEK - Silent Utilities ; [ 06/20/2001 08:57 ] - ;;3.0;IMAGING;**24,8,48,45,20,46,59**;Nov 27, 2007;Build 20 - ;; Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q - ; -LOGACT(MAGRY,ZY) ;RPC [MAGGACTION LOG] - ; Call to LogAction from Delphi Window - ; - ; ZY is input variable it is '^' delimited string - ; 'A|B|C|D|E' ^^ MAGIEN ^ 'Copy/Download' ^ DFN ^ '1'; - ; DUZ is inserted as 2nd piece below. - ; I.E. zy = "C^^103660^Copy To Clipboard^1033^1" - N Y - S MAGRY="0^Logging access..." - ; - N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGGTERR" - ; C DUZ MAGIEN ACTION DFN 1 - D ENTRY^MAGLOG($P(ZY,U),+$G(DUZ),$P(ZY,U,3),$P(ZY,U,4),$P(ZY,U,5),$P(ZY,U,6)) - S MAGRY="1^Action was Logged." - Q -LINKDT(MAGRY,MAGDA,DTTM) ; This is called when an Image is successfully - ; linked (Associated) with a Report/Procedure/Note etc. - ; MAGDA = Image IEN - ; DTTM = "" No date sent, so use NOW - ; DTTM = 1 No Date Sent, but use Image capture Date. - ; DTTM = Valid FM Date/Time , Use it. - N MSG - S DTTM=$G(DTTM) - I 'DTTM S DTTM=$$NOW^XLFDT ; Using NOW - I '$D(^MAG(2005,MAGDA)) Q - I DTTM=1 S DTTM=$P(^MAG(2005,MAGDA,2),"^",1) ; Using Date Image Captured. - I '$$VALID^MAGGSIV1(2005,64,.DTTM,.MSG) S MAGRY="0^"_MSG Q - S $P(^MAG(2005,MAGDA,2),"^",11)=DTTM - S MAGRY="1^Okay" - Q -TIMEOUT(MAGRY,APP) ;RPC [MAGG GET TIMEOUT] - ; Call Returns the timeout for the APP from IMAGING SITE PARAMETERS File - ; APP is either 'DISPLAY' 'CAPTURE' or 'VISTARAD' - N I,MAGTIMES,MAGPLC - S MAGRY="" - S MAGPLC=$$PLACE^MAGBAPI(DUZ(2)) I 'MAGPLC Q ; DBI - SEB 9/20/2002 - S MAGTIMES=$G(^MAG(2006.1,MAGPLC,"KEYS")) - I APP="DISPLAY" S MAGRY=$P(MAGTIMES,U,2) - I APP="CAPTURE" S MAGRY=$P(MAGTIMES,U,3) - I APP="VISTARAD" S MAGRY=$P(MAGTIMES,U,4) - I APP="TELEREADER" S MAGRY=$P(MAGTIMES,U,6) ; MJK - 2006.01.25 - TeleReader - Q -EXIST(EKGPLACE) ;Does an ekg server exist in 2005.2 - I $$CONSOLID^MAGBAPI()=0 Q $O(^MAG(2005.2,"E","EKG","")) ; DBI - SEB 9/20/2002 - Q $O(^MAG(2005.2,"F",EKGPLACE,"EKG","")) - ; -ONLINE(MAGR) ;RPC [MAG EKG ONLINE] EKG network location status - ;returns the status of the first EKG network location type - ;O if offline or a network location doesn't exist - ;1 if online - ; - N EKG1,EKGPLACE - S EKGPLACE=$$PLACE^MAGBAPI(DUZ(2)) ; DBI - SEB 9/20/2002 - I EKGPLACE=0 S EKGPLACE=$$PLACE^MAGBAPI(DUZ(2)) ;Convert to extrinsic /gek 8/2003 - I $$EXIST(EKGPLACE) D - . I $$CONSOLID^MAGBAPI() S EKG1=$O(^MAG(2005.2,"F",EKGPLACE,"EKG","")) ; DBI - SEB 9/20/2002 - . E S EKG1=$O(^MAG(2005.2,"E","EKG","")) - . S MAGR=$P(^MAG(2005.2,EKG1,0),U,6) - E S MAGR=0 - Q -SHARE(MAGRY,TYPE) ;RPC [MAG GET NETLOC] - ; Get list of image shares - ;TYPE = One of the STORAGE TYPE codes : MAG, EKG, WORM, URL or ALL - N TMP,I,DATA0,DATA2,DATA3,DATA6,INFO,VALUE,STYP,PHYREF - N $ETRAP,$ESTACK S $ETRAP="D ERRA^MAGGTERR" - S I=0 - I TYPE="" S TYPE="ALL" - S MAGRY(0)="1^SUCCESS" - F S I=$O(^MAG(2005.2,I)) Q:'I D - . Q:$$LOCDRIVE(I) - . S DATA0=$G(^MAG(2005.2,I,0)) - . S DATA2=$G(^MAG(2005.2,I,2)) - . S DATA3=$G(^MAG(2005.2,I,3)) - . S DATA6=$G(^MAG(2005.2,I,6)) - . ; - . S PHYREF=$P(DATA0,"^",2) ; PHYSICAL REFERENCE - . S STYP=$P(DATA0,"^",7) ; STORAGE TYPE - . ; - . I TYPE'="ALL" Q:STYP'[TYPE - . Q:$P(DATA0,"^",6)=0 ;SHARE IS OFFLINE (don't return offline shares) - . I STYP'="URL" Q:(PHYREF[".") ; pre 45, quit if '.' in phyref - . I STYP'="URL" Q:($E(PHYREF,1,2)'="\\") ; pre 45 quit if doesn't start with '\\' - . ; - . S INFO=$S($E(PHYREF,$L(PHYREF))="\":$E(PHYREF,1,$L(PHYREF)-1),1:PHYREF) - . S $P(INFO,"^",2)=$P($G(DATA0),"^",7) ;Physical reference (path) - . S $P(INFO,"^",3)=$P($G(DATA0),"^",6) ;Operational Status 0=OFFLINE 1=ONLINE - . S $P(INFO,"^",4)=$P($G(DATA2),"^",1) ;Username - . S $P(INFO,"^",5)=$P($G(DATA2),"^",2) ;Password - . S $P(INFO,"^",6)=$P($G(DATA6),"^",1) ;MUSE Site # - . I $P($G(DATA6),"^",2)'="" S $P(INFO,"^",7)=^MAG(2006.17,$P(DATA6,"^",2),0) ;MUSE version # - . S $P(INFO,"^",8)=$P($G(DATA3),"^",5) ;Network location SITE - . Q:$D(TMP(INFO)) - . S TMP(INFO)=I - S INFO="" - F S INFO=$O(TMP(INFO)) Q:INFO="" D - . S MAGRY($O(MAGRY(""),-1)+1)=TMP(INFO)_"^"_INFO - K TMP - Q -LOCDRIVE(I) ; Returns 1 if this is a local drive, else 0 - ; Local Drive is determined by the DIR not being Type : URL and having a ":" - I $P(^MAG(2005.2,I,0),"^",7)'="URL" I $P(^MAG(2005.2,I,0),"^",2)[":" Q 1 - Q 0 -GETENV(MAGRY) ;RPC [MAG GET ENV] - ; Get some environment variables (used by annotation control) - S MAGRY=DUZ(2)_"^"_$$NOW^XLFDT - Q -ANNCB(STATARR) ;Status Callback (called by the import API) - ; - N I,CDUZ,QINDEX,A,COUNT - N XMDUZ,XMSUB,XMTEXT,XMY - ; 0 = error, all others are success. - I $P(STATARR(0),"^",1)'=0 D - . ; Import was successful - E D - . ; Import failed - send mail to MAG SERVER group and person who queued the import - . S XMDUZ=DUZ - . S XMSUB="Import Error Report" - . ; get text of message from status array - . S XMTEXT="A(" - . ; XMD needs array to start with 1, not 0 - . S COUNT=1,I="" - . F S I=$O(STATARR(I)) Q:I="" D - . . S A(COUNT)=I_") "_STATARR(I) - . . S COUNT=COUNT+1 - . . Q - . S A(COUNT+1)=" " - . S A(COUNT+2)=" " - . S A(COUNT+3)=" The errors listed above were generated by" - . S A(COUNT+4)=" the VistA Imaging Annotation Editor while" - . S A(COUNT+5)=" trying to import your diagram. Please" - . S A(COUNT+6)=" report these errors to your VistA Imaging" - . S A(COUNT+7)=" support personnel." - . ;Get person who did the import - . S QINDEX=STATARR(2) - . S I=-1 F S I=$O(^MAG(2006.034,QINDEX,1,I)) Q:I="" D - . . I $P($G(^MAG(2006.034,QINDEX,1,I,0)),"^",1)=8 S CDUZ=$P(^MAG(2006.034,QINDEX,1,I,0),"^",2) - . ;Set recipients of message - . S XMY("G.MAG SERVER")="" - . I $G(CDUZ) S XMY(CDUZ)="" - . D ^XMD - . Q - Q -GETCTP(MAGRY) ;RPC [MAG4 CT PRESETS GET] - N MAGPLC - S MAGPLC=$$PLACE^MAGBAPI(DUZ(2)) - I 'MAGPLC S MAGRY="0^Error resolving Users Division" Q - S MAGRY=$G(^MAG(2006.1,MAGPLC,"CT")) - I MAGRY="" S MAGRY="0^Site doesn't have CT Presets defined." Q - S MAGRY="1^"_MAGRY - Q -SAVECTP(MAGRY,VALUE) ;RPC [MAG4 CT PRESETS SAVE] - N MAGPLC - S MAGPLC=$$PLACE^MAGBAPI(DUZ(2)) - I 'MAGPLC S MAGRY="0^Error resolving Users Division" Q - S ^MAG(2006.1,MAGPLC,"CT")=VALUE - S MAGRY="1^CT Presets saved." - Q -NETPLCS ; Create an array of Place, SiteCodes for all entries of - ; Network Location entries. - N I,PLC,PLCODE,CONS - S CONS=$$CONSOLID^MAGBAPI - I 'CONS S PLC=$O(^MAG(2006.1,0)),PLCODE=$P(^MAG(2006.1,PLC,0),"^",9) - ; - K MAGJOB("NETPLC") - S I=0 F S I=$O(^MAG(2005.2,I)) Q:'I D - . I 'CONS S MAGJOB("NETPLC",I)=PLC_"^"_PLCODE Q - . ; Here, for consolidated sites we get the real Site IEN, and Site Code. - . I CONS S PLC=$P($G(^MAG(2005.2,I,0)),"^",10),PLCODE=$S(PLC:$P($G(^MAG(2006.1,PLC,0)),"^",9),1:"n/a") - . S MAGJOB("NETPLC",I)=PLC_"^"_PLCODE - . Q - Q +MAGGTU6 ;WOIFO/GEK - Silent Utilities ; 25 Jan 2006 12:14 PM + ;;3.0;IMAGING;**24,8,48,45,20,46**;16-February-2007;;Build 1023 + ;; Per VHA Directive 2004-038, this routine should not be modified. + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q + ; +LOGACT(MAGRY,ZY) ;RPC [MAGGACTION LOG] + ; Call to LogAction from Delphi Window + ; + ; ZY is input variable it is '^' delimited string + ; 'A|B|C|D|E' ^^ MAGIEN ^ 'Copy/Download' ^ DFN ^ '1'; + ; DUZ is inserted as 2nd piece below. + ; I.E. zy = "C^^103660^Copy To Clipboard^1033^1" + N Y + S MAGRY="0^Logging access..." + ; + N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGGTERR" + ; C DUZ MAGIEN ACTION DFN 1 + D ENTRY^MAGLOG($P(ZY,U),+$G(DUZ),$P(ZY,U,3),$P(ZY,U,4),$P(ZY,U,5),$P(ZY,U,6)) + S MAGRY="1^Action was Logged." + Q +LINKDT(MAGRY,MAGDA,DTTM) ; This is called when an Image is successfully + ; linked (Associated) with a Report/Procedure/Note etc. + ; MAGDA = Image IEN + ; DTTM = "" No date sent, so use NOW + ; DTTM = 1 No Date Sent, but use Image capture Date. + ; DTTM = Valid FM Date/Time , Use it. + N MSG + S DTTM=$G(DTTM) + I 'DTTM S DTTM=$$NOW^XLFDT ; Using NOW + I '$D(^MAG(2005,MAGDA)) Q + I DTTM=1 S DTTM=$P(^MAG(2005,MAGDA,2),"^",1) ; Using Date Image Captured. + I '$$VALID^MAGGSIV1(2005,64,.DTTM,.MSG) S MAGRY="0^"_MSG Q + S $P(^MAG(2005,MAGDA,2),"^",11)=DTTM + S MAGRY="1^Okay" + Q +TIMEOUT(MAGRY,APP) ;RPC [MAGG GET TIMEOUT] + ; Call Returns the timeout for the APP from IMAGING SITE PARAMETERS File + ; APP is either 'DISPLAY' 'CAPTURE' or 'VISTARAD' + N I,MAGTIMES,MAGPLC + S MAGRY="" + S MAGPLC=$$PLACE^MAGBAPI(DUZ(2)) I 'MAGPLC Q ; DBI - SEB 9/20/2002 + S MAGTIMES=$G(^MAG(2006.1,MAGPLC,"KEYS")) + I APP="DISPLAY" S MAGRY=$P(MAGTIMES,U,2) + I APP="CAPTURE" S MAGRY=$P(MAGTIMES,U,3) + I APP="VISTARAD" S MAGRY=$P(MAGTIMES,U,4) + I APP="TELEREADER" S MAGRY=$P(MAGTIMES,U,6) ; MJK - 2006.01.25 - TeleReader + Q +EXIST(EKGPLACE) ;Does an ekg server exist in 2005.2 + I $$CONSOLID^MAGBAPI()=0 Q $O(^MAG(2005.2,"E","EKG","")) ; DBI - SEB 9/20/2002 + Q $O(^MAG(2005.2,"F",EKGPLACE,"EKG","")) + ; +ONLINE(MAGR) ;RPC [MAG EKG ONLINE] EKG network location status + ;returns the status of the first EKG network location type + ;O if offline or a network location doesn't exist + ;1 if online + ; + N EKG1,EKGPLACE + S EKGPLACE=$$PLACE^MAGBAPI(DUZ(2)) ; DBI - SEB 9/20/2002 + I EKGPLACE=0 S EKGPLACE=$$PLACE^MAGBAPI(DUZ(2)) ;Convert to extrinsic /gek 8/2003 + I $$EXIST(EKGPLACE) D + . I $$CONSOLID^MAGBAPI() S EKG1=$O(^MAG(2005.2,"F",EKGPLACE,"EKG","")) ; DBI - SEB 9/20/2002 + . E S EKG1=$O(^MAG(2005.2,"E","EKG","")) + . S MAGR=$P(^MAG(2005.2,EKG1,0),U,6) + E S MAGR=0 + Q +SHARE(MAGRY,TYPE) ;RPC [MAG GET NETLOC] + ; Get list of image shares + ;TYPE = One of the STORAGE TYPE codes : MAG, EKG, WORM, URL or ALL + N TMP,I,DATA0,DATA2,DATA3,DATA6,INFO,VALUE,STYP,PHYREF + N $ETRAP,$ESTACK S $ETRAP="D ERRA^MAGGTERR" + S I=0 + I TYPE="" S TYPE="ALL" + S MAGRY(0)="1^SUCCESS" + F S I=$O(^MAG(2005.2,I)) Q:'I D + . Q:$$LOCDRIVE(I) + . S DATA0=$G(^MAG(2005.2,I,0)) + . S DATA2=$G(^MAG(2005.2,I,2)) + . S DATA3=$G(^MAG(2005.2,I,3)) + . S DATA6=$G(^MAG(2005.2,I,6)) + . ; + . S PHYREF=$P(DATA0,"^",2) ; PHYSICAL REFERENCE + . S STYP=$P(DATA0,"^",7) ; STORAGE TYPE + . ; + . I TYPE'="ALL" Q:STYP'[TYPE + . Q:$P(DATA0,"^",6)=0 ;SHARE IS OFFLINE (don't return offline shares) + . I STYP'="URL" Q:(PHYREF[".") ; pre 45, quit if '.' in phyref + . I STYP'="URL" Q:($E(PHYREF,1,2)'="\\") ; pre 45 quit if doesn't start with '\\' + . ; + . S INFO=$S($E(PHYREF,$L(PHYREF))="\":$E(PHYREF,1,$L(PHYREF)-1),1:PHYREF) + . S $P(INFO,"^",2)=$P($G(DATA0),"^",7) ;Physical reference (path) + . S $P(INFO,"^",3)=$P($G(DATA0),"^",6) ;Operational Status 0=OFFLINE 1=ONLINE + . S $P(INFO,"^",4)=$P($G(DATA2),"^",1) ;Username + . S $P(INFO,"^",5)=$P($G(DATA2),"^",2) ;Password + . S $P(INFO,"^",6)=$P($G(DATA6),"^",1) ;MUSE Site # + . I $P($G(DATA6),"^",2)'="" S $P(INFO,"^",7)=^MAG(2006.17,$P(DATA6,"^",2),0) ;MUSE version # + . S $P(INFO,"^",8)=$P($G(DATA3),"^",5) ;Network location SITE + . Q:$D(TMP(INFO)) + . S TMP(INFO)=I + S INFO="" + F S INFO=$O(TMP(INFO)) Q:INFO="" D + . S MAGRY($O(MAGRY(""),-1)+1)=TMP(INFO)_"^"_INFO + K TMP + Q +LOCDRIVE(I) ; Returns 1 if this is a local drive, else 0 + ; Local Drive is determined by the DIR not being Type : URL and having a ":" + I $P(^MAG(2005.2,I,0),"^",7)'="URL" I $P(^MAG(2005.2,I,0),"^",2)[":" Q 1 + Q 0 +GETENV(MAGRY) ;RPC [MAG GET ENV] + ; Get some environment variables (used by annotation control) + S MAGRY=DUZ(2)_"^"_$$NOW^XLFDT + Q +ANNCB(STATARR) ;Status Callback (called by the import API) + ; + N I,CDUZ,QINDEX,A,COUNT + N XMDUZ,XMSUB,XMTEXT,XMY + ; 0 = error, all others are success. + I $P(STATARR(0),"^",1)'=0 D + . ; Import was successful + E D + . ; Import failed - send mail to MAG SERVER group and person who queued the import + . S XMDUZ=DUZ + . S XMSUB="Import Error Report" + . ; get text of message from status array + . S XMTEXT="A(" + . ; XMD needs array to start with 1, not 0 + . S COUNT=1,I="" + . F S I=$O(STATARR(I)) Q:I="" D + . . S A(COUNT)=I_") "_STATARR(I) + . . S COUNT=COUNT+1 + . . Q + . S A(COUNT+1)=" " + . S A(COUNT+2)=" " + . S A(COUNT+3)=" The errors listed above were generated by" + . S A(COUNT+4)=" the VistA Imaging Annotation Editor while" + . S A(COUNT+5)=" trying to import your diagram. Please" + . S A(COUNT+6)=" report these errors to your VistA Imaging" + . S A(COUNT+7)=" support personnel." + . ;Get person who did the import + . S QINDEX=STATARR(2) + . S I=-1 F S I=$O(^MAG(2006.034,QINDEX,1,I)) Q:I="" D + . . I $P($G(^MAG(2006.034,QINDEX,1,I,0)),"^",1)=8 S CDUZ=$P(^MAG(2006.034,QINDEX,1,I,0),"^",2) + . ;Set recipients of message + . S XMY("G.MAG SERVER")="" + . I $G(CDUZ) S XMY(CDUZ)="" + . D ^XMD + . Q + Q +GETCTP(MAGRY) ;RPC [MAG4 CT PRESETS GET] + N MAGPLC + S MAGPLC=$$PLACE^MAGBAPI(DUZ(2)) + I 'MAGPLC S MAGRY="0^Error resolving Users Division" Q + S MAGRY=$G(^MAG(2006.1,MAGPLC,"CT")) + I MAGRY="" S MAGRY="0^Site doesn't have CT Presets defined." Q + S MAGRY="1^"_MAGRY + Q +SAVECTP(MAGRY,VALUE) ;RPC [MAG4 CT PRESETS SAVE] + N MAGPLC + S MAGPLC=$$PLACE^MAGBAPI(DUZ(2)) + I 'MAGPLC S MAGRY="0^Error resolving Users Division" Q + S ^MAG(2006.1,MAGPLC,"CT")=VALUE + S MAGRY="1^CT Presets saved." + Q +NETPLCS ; Create an array of Place, SiteCodes for all entries of + ; Network Location entries. + N I,PLC,PLCODE,CONS + S CONS=$$CONSOLID^MAGBAPI + I 'CONS S PLC=$O(^MAG(2006.1,0)),PLCODE=$P(^MAG(2006.1,PLC,0),"^",9) + ; + K MAGJOB("NETPLC") + S I=0 F S I=$O(^MAG(2005.2,I)) Q:'I D + . I 'CONS S MAGJOB("NETPLC",I)=PLC_"^"_PLCODE Q + . ; Here, for consolidated sites we get the real Site IEN, and Site Code. + . I CONS S PLC=$P($G(^MAG(2005.2,I,0)),"^",10),PLCODE=$S(PLC:$P($G(^MAG(2006.1,PLC,0)),"^",9),1:"n/a") + . S MAGJOB("NETPLC",I)=PLC_"^"_PLCODE + . Q + Q diff --git a/r/IMAGING-MAG-ZMAG/MAGGTU71.m b/r/IMAGING-MAG-ZMAG/MAGGTU71.m index 231cfe7c..02a4ac17 100644 --- a/r/IMAGING-MAG-ZMAG/MAGGTU71.m +++ b/r/IMAGING-MAG-ZMAG/MAGGTU71.m @@ -1,72 +1,72 @@ -MAGGTU71 ;WOIFO/GEK - Silent calls for Queing functions from GUI, cont ; [ 06/20/2001 08:57 ] - ;;3.0;IMAGING;**46,59**;Nov 27, 2007;Build 20 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q -ABSJB(MAGRY,DATA) ;RPC [MAG ABSJB] SET ABSTRACT AND/OR JUKEBOX QUEUES - ; - ; DATA - ; DESCRIPTION: '^' delimited String: - ; Piece 1 = the IEN of the image that needs an abstract created. - ; Piece 2 = the IEN of the image that needs copied to the jukebox - ; - ; MAGRY = "1^Successful" - ; = "0^error message" - ; - N MAGIENAB,MAGIENJB,MAGERR,X,QMSG - S MAGERR=0 - N $ETRAP,$ESTACK S $ETRAP="D ERR^"_$T(+0) - S MAGRY="0^ERROR: Setting Queue for Abstract or JukeBox copy" - S MAGIENAB=+$P(DATA,"^",1),MAGIENJB=+$P(DATA,"^",2) - I MAGIENAB Q:((+$P($G(^MAG(2005,MAGIENAB,0)),U,11))!(+$P($G(^MAG(2005,MAGIENAB,0)),U,12))) "0^Image integrity" - I MAGIENJB Q:((+$P($G(^MAG(2005,MAGIENJB,0)),U,11))!(+$P($G(^MAG(2005,MAGIENJB,0)),U,12))) "0^Image integrity" - S QMSG=$S(MAGIENAB:"Setting Abstract Queue",1:"") - I MAGIENJB S QMSG=$S(QMSG="":"Setting JukeBox Queue",1:" and JukeBox Queue") - L +(^MAGQUEUE(2006.03,0),^MAGQUEUE(2006.031)):10 E D QERR Q - I MAGIENAB S X=$$ABSTRACT^MAGBAPI(MAGIENAB,$$DA2PLC^MAGBAPIP(MAGIENAB,"F")) - I MAGIENJB S X=$$JUKEBOX^MAGBAPI(MAGIENJB,$$DA2PLC^MAGBAPIP(MAGIENJB,"F")) - L -(^MAGQUEUE(2006.03,0),^MAGQUEUE(2006.031)) - S MAGRY="1^SUCCESSFUL" - Q -ERR ; - L -(^MAGQUEUE(2006.03,0),^MAGQUEUE(2006.031)) - N ERR S ERR=$$EC^%ZOSV - S MAGRY="0^Timed out trying to set JukeBox/Abstract Queue. Not Fatal. 'Save' will continue..." - D LOGERR^MAGGTERR(ERR) - D @^%ZOSF("ERRTN") - Q -QERR ; - N MAGTXT,EMSG - S MAGTXT="Failed "_QMSG - ;ENTRY(MAGIMT,MAGDUZ,MAGO,MAGPACK,MAGDFN,MAGCT,MAGAD) - D ENTRY^MAGLOG("QFAIL",$G(DUZ),MAGIENJB,"","","",MAGTXT) - D ACTION^MAGGTAU(MAGTXT,1) - S EMSG="Timed out trying to Lock Queue File" - D ACTION^MAGGTAU(EMSG,1) - S MAGRY="1^"_MAGTXT_" Message was sent to IRM. Not Fatal. 'Save' will continue..." - N XMSUB,XMY,XMTEXT,XMK,XMDUZ - S XMTEXT="^TMP($J,""MAGQ""," - S XMSUB=MAGTXT - K ^TMP($J,"MAGQ") - S ^TMP($J,"MAGQ",1)=MAGTXT - S ^TMP($J,"MAGQ",2)=EMSG - S ^TMP($J,"MAGQ",3)=" for Image IEN: "_MAGIENJB - S ^TMP($J,"MAGQ",4)="You need to run the Verifier for this Image IEN" - S XMY("G.IMAGING DEVELOPMENT@FORUM.VA.GOV")="" - D ^XMD - S XMDUZ=DUZ D KLQ^XMA1B - K ^TMP($J,"MAGQ") - Q +MAGGTU71 ;WOIFO/GEK - Silent calls for Queing functions from GUI, cont ; [ 06/20/2001 08:57 ] + ;;3.0;IMAGING;**46**;16-February-2007;;Build 1023 + ;; Per VHA Directive 2004-038, this routine should not be modified. + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q +ABSJB(MAGRY,MAGIN) ;RPC [MAG ABSJB] SET ABSTRACT AND/OR JUKEBOX QUEUES + ; + ; MAGIN + ; DESCRIPTION: '^' delimited String: + ; Piece 1 = the IEN of the image that needs an abstract created. + ; Piece 2 = the IEN of the image that needs copied to the jukebox + ; + ; MAGRY = "1^Successful" + ; = "0^error message" + ; + N MAGIENAB,MAGIENJB,MAGERR,X,QMSG + S MAGERR=0 + N $ETRAP,$ESTACK S $ETRAP="D ERR^"_$T(+0) + S MAGRY="0^ERROR: Setting Queue for Abstract or JukeBox copy" + S MAGIENAB=+$P(MAGIN,"^",1),MAGIENJB=+$P(MAGIN,"^",2) + I MAGIENAB Q:((+$P($G(^MAG(2005,MAGIENAB,0)),U,11))!(+$P($G(^MAG(2005,MAGIENAB,0)),U,12))) "0^Image integrity" + I MAGIENJB Q:((+$P($G(^MAG(2005,MAGIENJB,0)),U,11))!(+$P($G(^MAG(2005,MAGIENJB,0)),U,12))) "0^Image integrity" + S QMSG=$S(MAGIENAB:"Setting Abstract Queue",1:"") + I MAGIENJB S QMSG=$S(QMSG="":"Setting JukeBox Queue",1:" and JukeBox Queue") + L +(^MAGQUEUE(2006.03,0),^MAGQUEUE(2006.031)):10 E D QERR Q + I MAGIENAB S X=$$ABSTRACT^MAGBAPI(MAGIENAB,$$DA2PLC^MAGBAPIP(MAGIENAB,"F")) + I MAGIENJB S X=$$JUKEBOX^MAGBAPI(MAGIENJB,$$DA2PLC^MAGBAPIP(MAGIENJB,"F")) + L -(^MAGQUEUE(2006.03,0),^MAGQUEUE(2006.031)) + S MAGRY="1^SUCCESSFUL" + Q +ERR ; + L -(^MAGQUEUE(2006.03,0),^MAGQUEUE(2006.031)) + N ERR S ERR=$$EC^%ZOSV + S MAGRY="0^Timed out trying to set JukeBox/Abstract Queue. Not Fatal. 'Save' will continue..." + D LOGERR^MAGGTERR(ERR) + D @^%ZOSF("ERRTN") + Q +QERR ; + N MAGTXT,EMSG + S MAGTXT="Failed "_QMSG + ;ENTRY(MAGIMT,MAGDUZ,MAGO,MAGPACK,MAGDFN,MAGCT,MAGAD) + D ENTRY^MAGLOG("QFAIL",$G(DUZ),MAGIENJB,"","","",MAGTXT) + D ACTION^MAGGTAU(MAGTXT,1) + S EMSG="Timed out trying to Lock Queue File" + D ACTION^MAGGTAU(EMSG,1) + S MAGRY="1^"_MAGTXT_" Message was sent to IRM. Not Fatal. 'Save' will continue..." + N XMSUB,XMY,XMTEXT,XMK,XMDUZ + S XMTEXT="^TMP($J,""MAGQ""," + S XMSUB=MAGTXT + K ^TMP($J,"MAGQ") + S ^TMP($J,"MAGQ",1)=MAGTXT + S ^TMP($J,"MAGQ",2)=EMSG + S ^TMP($J,"MAGQ",3)=" for Image IEN: "_MAGIENJB + S ^TMP($J,"MAGQ",4)="You need to run the Verifier for this Image IEN" + S XMY("G.IMAGING DEVELOPMENT@FORUM.VA.GOV")="" + D ^XMD + S XMDUZ=DUZ D KLQ^XMA1B + K ^TMP($J,"MAGQ") + Q diff --git a/r/IMAGING-MAG-ZMAG/MAGGTU9.m b/r/IMAGING-MAG-ZMAG/MAGGTU9.m index f9097153..41c45021 100644 --- a/r/IMAGING-MAG-ZMAG/MAGGTU9.m +++ b/r/IMAGING-MAG-ZMAG/MAGGTU9.m @@ -1,151 +1,103 @@ -MAGGTU9 ;WOIFO/LB/GEK - Imaging utilities assign key - ;;3.0;IMAGING;**8,59**;Nov 27, 2007;Build 20 - ;; Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q -CHKKEY ; - N NOGIVE - S NOGIVE=1 -GIVEKEY ;Give MAGDISP CLIN key to all MAG WINDOWS option holders - ; that have neither MAGDISP CLIN nor MAGDISP ADMIN - ; Find the menu option's IEN - N MKEYC,MKEYA,ERR,OPT,MAGUSER,I,KEYCLIN,KEYADMIN,KEYCT,KEYECT,XCT - N KEYHASC,KEYHASA,KEYHASB,KEYNONE,SP,LSP - N UCT,UTOT,OPTACC,MDOT,UDISCT - ; This could be made Generic if ever a need, to search for users - ; withour either key, and assigned those users the first (KEYCLIN) - S KEYCLIN="MAGDISP CLIN" - S KEYADMIN="MAGDISP ADMIN" - S KEYCT=0 ; count of number of users that were assigned the key. - S KEYECT=0 ; count of number of errors during the assignment. - S KEYHASC=0 ; count of number of users that already have key Clin - S KEYHASA=0 ; count of number of users that already have key Admin - S KEYHASB=0 ; count of number of users that Have Both keys - S KEYNONE=0 ; count of Users that have Neither Key. - S OPTACC=0 ; count of users with access to MAG WINDOWS. - S UDISCT=0 ; count of Disabled Users Skipped. - S MDOT=10000 ; print '.' to screen to show progress. - S UCT=0 ; user count. for progress - S UTOT=$P(^VA(200,0),"^",4) - ; - I $G(NOGIVE) D - . D MES^XPDUTL("Checking for users that have access to Option : "_"MAG WINDOWS") - . D MES^XPDUTL(" but do not have either '"_KEYCLIN_"' or '"_KEYADMIN_"' Keys") - . D MES^XPDUTL(" Disabled users (DISUSER=1) are skipped, they are not checked.") - . Q - E D MES^XPDUTL("Assigning "_KEYCLIN_" to all users with access to Option : "_"MAG WINDOWS") - D MES^XPDUTL(" ") - S OPT=$$FIND1^DIC(19,"","X","MAG WINDOWS","","","ERR") - I OPT="" D MES^XPDUTL("ERROR ",$G(ERR("DIERR",1,"TEXT",1))) Q - I OPT=0 D MES^XPDUTL("MAG WINDOWS wasn't found in Option File") Q - ; Lookup the security key - S MKEYC=$$LKUP^XPDKEY(KEYCLIN) - S MKEYA=$$LKUP^XPDKEY(KEYADMIN) - I ('MKEYC)!('MKEYA) D MES^XPDUTL("ERROR: Imaging Display Keys are not defined at this site") Q - ; Check all Users at site to see if they don't have either Clin or Admin - D MES^XPDUTL("Checking users...") - D MES^XPDUTL(" ") - S I=0 F S I=$O(^VA(200,I)) Q:'I D - . I $$GET1^DIQ(200,I,7,"E")]"" S UDISCT=UDISCT+1 Q - . S UCT=UCT+1 I UCT>MDOT S MDOT=MDOT+10000 D MES^XPDUTL(UCT_" of "_UTOT_" users checked...") - . I (($$ACCESS^XQCHK(I,OPT))>0) S OPTACC=OPTACC+1 D C(I) - . Q - S SP=" " - S LSP=$L(UTOT)+3 - D MES^XPDUTL(" ") - I $G(NOGIVE) D - . D MES^XPDUTL($E(SP,1,LSP-$L(OPTACC))_OPTACC_" of "_UTOT_" Users have access to option MAG WINDOWS.") - . D MES^XPDUTL($E(SP,1,LSP-$L(KEYHASB))_KEYHASB_" Users have Both Keys ") - . D MES^XPDUTL($E(SP,1,LSP-$L(KEYHASC))_KEYHASC_" Users only have "_KEYCLIN_" key") - . D MES^XPDUTL($E(SP,1,LSP-$L(KEYHASA))_KEYHASA_" Users only have "_KEYADMIN_" key") - . D MES^XPDUTL($E(SP,1,LSP-$L(KEYNONE))_KEYNONE_" Users have neither Key") - . I KEYECT>0 D MES^XPDUTL(KEYECT_" Errors during Key Assignment. See install log for details") - . Q - I '$G(NOGIVE) D - . D MES^XPDUTL($E(SP,1,LSP-$L(OPTACC))_OPTACC_" of "_UTOT_" Users have access to option MAG WINDOWS.") - . D MES^XPDUTL($E(SP,1,LSP-$L(KEYHASB))_KEYHASB_" Users already have Both Keys ") - . D MES^XPDUTL($E(SP,1,LSP-$L(KEYHASC))_KEYHASC_" Users have Only Key "_KEYCLIN) - . D MES^XPDUTL($E(SP,1,LSP-$L(KEYHASA))_KEYHASA_" Users have Only Key "_KEYADMIN) - . D MES^XPDUTL($E(SP,1,LSP-$L(KEYCT))_KEYCT_" Users were assigned key: "_KEYCLIN) - . D MES^XPDUTL("Assignment Complete.") - . I KEYECT>0 D MES^XPDUTL(KEYECT_" Errors during Key Assignment. See install log for details") - . Q - Q -C(USER) ; - ; check KEY for USER - N DO,D1,MFDA,ZC,ZA,MIEN - ; check to see if they have the Clin key - S ZC=$$FIND1^DIC(200.051,","_USER_",","",KEYCLIN) - I ZC="" D Q - . D MES^XPDUTL("ERROR Validating that user ("_USER_") has Key "_KEYCLIN) - . S KEYECT=KEYECT+1 - . Q - ; check to see if they have the Admin key - S ZA=$$FIND1^DIC(200.051,","_USER_",","",KEYADMIN) - I ZA="" D Q - . D MES^XPDUTL("ERROR Validating that user ("_USER_") has Key "_KEYADMIN) - . S KEYECT=KEYECT+1 - . Q - I ((+ZC)&(+ZA)) S KEYHASB=KEYHASB+1 Q - I +ZC S KEYHASC=KEYHASC+1 Q - I +ZA S KEYHASA=KEYHASA+1 Q - S KEYNONE=KEYNONE+1 - I $G(NOGIVE) D Q - . D MES^XPDUTL("User: "_$P($G(^VA(200,USER,0)),"^")_" has neither Key") - . Q - S MFDA(200.051,"+1,"_USER_",",.01)=MKEYC - S MFDA(200.051,"+1,"_USER_",",1)=DUZ - S MFDA(200.051,"+1,"_USER_",",2)=DT - S MIEN(1)=MKEYC_"," - D UPDATE^DIE("","MFDA","MIEN") - I $D(DIERR) D Q - . D MES^XPDUTL("ERROR Assigning Key ("_KEYCLIN_") to user ("_USER_")") - . S KEYECT=KEYECT+1 - . D CLEAN^DILF - . Q - S KEYCT=KEYCT+1 - D CLEAN^DILF - Q -FLT ; Create a Few Public Filters as a default for sites. - ; Only create new public filters if file is empty. - N DIK - I +$P(^MAG(2005.87,0),"^",3) D Q - . D MES^XPDUTL("The IMAGE LIST FILTERS File is not empty,") - . D MES^XPDUTL(" Default Public Filters were not installed.") - . Q - S ^MAG(2005.87,1,0)="Rad All^RAD^CLIN^^^^^^0" - S ^MAG(2005.87,1,1)="^1^.05" - S ^MAG(2005.87,2,0)="Clin All^^CLIN^^^^^^0" - S ^MAG(2005.87,2,1)="^1^.05" - S ^MAG(2005.87,3,0)="Admin All^^ADMIN^^^^^^0" - S ^MAG(2005.87,3,1)="^1^.05" - S ^MAG(2005.87,4,0)="Clin 2 yr^^CLIN^^^^^^-24" - S ^MAG(2005.87,4,1)="^1^.05" - S ^MAG(2005.87,5,0)="Admin 10-10EZ All^^ADMIN^46,^^^^^0" - S ^MAG(2005.87,5,1)="^1^.05" - S ^MAG(2005.87,6,0)="Adv Directives^^CLIN^67^^^^^0" - S ^MAG(2005.87,6,1)="^1^.05" - S ^MAG(2005.87,7,0)="All^^^^^^^^0" - S ^MAG(2005.87,7,1)="^1^.05" - S ^MAG(2005.87,8,0)="All 2 yr^^^^^^^^-24" - S ^MAG(2005.87,8,1)="^1^.05" - S ^MAG(2005.87,9,0)="All 6 mth^^^^^^^^-6" - S ^MAG(2005.87,9,1)="^1^.05" - ;All Advance Directives^^CLIN^67^^^^^0 - S DIK="^MAG(2005.87," D IXALL^DIK - D MES^XPDUTL("Default Public Filters added to IMAGE LIST FILTERS File.") - Q +MAGGTU9 ;WOIFO/LB/GEK - Imaging utilities assign key + ;;3.0;IMAGING;**8**;Sep 15, 2004 + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q +EN ;Give MAGDISP CLIN key to all MAG WINDOWS option holders. + ; Find the menu option's IEN + N MKEY,ERR,OPT,MAGUSER,I,KEYNM,KEYCT,KEYECT,XCT,KEYHAS + N UCT,UTOT,OPTACC,MDOT + S KEYNM="MAGDISP CLIN" + S KEYCT=0 ; count of number of users that were assigned the key. + S KEYECT=0 ; count of number of errors during the assignment. + S KEYHAS=0 ; count of number of users that already have key. + S OPTACC=0 ; count of users with access to MAG WINDOWS. + S MDOT=10000 ; print '.' to screen to show progress. + S UCT=0 ; user count. for progress + S UTOT=$P(^VA(200,0),"^",4) + ; + D MES^XPDUTL("Assigning "_KEYNM_" to all users with access to Option : "_"MAG WINDOWS") + S OPT=$$FIND1^DIC(19,"","X","MAG WINDOWS","","","ERR") + I OPT="" D MES^XPDUTL("ERROR ",$G(ERR("DIERR",1,"TEXT",1))) Q + I OPT=0 D MES^XPDUTL("MAG WINDOWS wasn't found in Option File") Q + ; Lookup the security key + S MKEY=$$LKUP^XPDKEY(KEYNM) + I 'MKEY D MES^XPDUTL("ERROR "_KEYNM_" Key wasn't found") Q + ; Give users the Key, if they don't have it already + D MES^XPDUTL("Checking users...") + S I=0 F S I=$O(^VA(200,I)) Q:'I D + . S UCT=UCT+1 I UCT>MDOT S MDOT=MDOT+10000 D MES^XPDUTL(UCT_" of "_UTOT_" users checked...") + . I (($$ACCESS^XQCHK(I,OPT))>0) S OPTACC=OPTACC+1 D GIVEKEY(MKEY,KEYNM,I) + . Q + D MES^XPDUTL(OPTACC_" of "_UTOT_" Users have access to option MAG WINDOWS.") + D MES^XPDUTL(KEYHAS_" Users already have Key "_KEYNM) + D MES^XPDUTL(KEYCT_" Users were assigned key: "_KEYNM) + D MES^XPDUTL("Assignment Complete.") + I KEYECT>0 D MES^XPDUTL(KEYECT_" Errors during Key Assignment. See install log for details") + Q +GIVEKEY(KEY,KEYNM,USER) ; + ; Give KEY to USER + N DO,D1,MFDA,Z,MIEN + ; Quit if they already have the key + S Z=$$FIND1^DIC(200.051,","_USER_",","",KEYNM) + I +Z S KEYHAS=KEYHAS+1 + Q:Z ; Already have key + I Z="" D Q + . D MES^XPDUTL("ERROR Validating that user ("_USER_") has key ("_KEYNM_")") + . S KEYECT=KEYECT+1 + ; + S MFDA(200.051,"+1,"_USER_",",.01)=KEY + S MFDA(200.051,"+1,"_USER_",",1)=DUZ + S MFDA(200.051,"+1,"_USER_",",2)=DT + S MIEN(1)=KEY_"," + D UPDATE^DIE("","MFDA","MIEN") + I $D(DIERR) D Q + . D MES^XPDUTL("ERROR Assigning key ("_KEYNM_") to user ("_USER_")") + . S KEYECT=KEYECT+1 + . D CLEAN^DILF + . Q + S KEYCT=KEYCT+1 + D CLEAN^DILF + Q +FLT ; Create a Few Public Filters as a default for sites. + ; Only create new public filters if file is empty. + N DIK + I +$P(^MAG(2005.87,0),"^",3) D Q + . D MES^XPDUTL("The IMAGE LIST FILTERS File is not empty,") + . D MES^XPDUTL(" Default Public Filters were not installed.") + . Q + S ^MAG(2005.87,1,0)="Rad All^RAD^CLIN^^^^^^0" + S ^MAG(2005.87,1,1)="^1^.05" + S ^MAG(2005.87,2,0)="Clin All^^CLIN^^^^^^0" + S ^MAG(2005.87,2,1)="^1^.05" + S ^MAG(2005.87,3,0)="Admin All^^ADMIN^^^^^^0" + S ^MAG(2005.87,3,1)="^1^.05" + S ^MAG(2005.87,4,0)="Clin 2 yr^^CLIN^^^^^^-24" + S ^MAG(2005.87,4,1)="^1^.05" + S ^MAG(2005.87,5,0)="Admin 10-10EZ All^^ADMIN^46,^^^^^0" + S ^MAG(2005.87,5,1)="^1^.05" + S ^MAG(2005.87,6,0)="Adv Directives^^CLIN^67^^^^^0" + S ^MAG(2005.87,6,1)="^1^.05" + S ^MAG(2005.87,7,0)="All^^^^^^^^0" + S ^MAG(2005.87,7,1)="^1^.05" + S ^MAG(2005.87,8,0)="All 2 yr^^^^^^^^-24" + S ^MAG(2005.87,8,1)="^1^.05" + S ^MAG(2005.87,9,0)="All 6 mth^^^^^^^^-6" + S ^MAG(2005.87,9,1)="^1^.05" + ;All Advance Directives^^CLIN^67^^^^^0 + S DIK="^MAG(2005.87," D IXALL^DIK + D MES^XPDUTL("Default Public Filters added to IMAGE LIST FILTERS File.") + Q diff --git a/r/IMAGING-MAG-ZMAG/MAGGTUP.m b/r/IMAGING-MAG-ZMAG/MAGGTUP.m index 445704d7..5ca5e0b2 100644 --- a/r/IMAGING-MAG-ZMAG/MAGGTUP.m +++ b/r/IMAGING-MAG-ZMAG/MAGGTUP.m @@ -1,125 +1,122 @@ -MAGGTUP ;WOIFO/GEK - Imaging System User preferences ; [ 06/20/2001 08:57 ] - ;;3.0;IMAGING;**7,8,48,45,59**;Nov 27, 2007;Build 20 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q -GET(MAGRY,CODE) ;RPC [MAGGUPREFGET] Call to Get user preferences. - ; - N Y,PRFIEN,J,X,Z,NODE,MAGPREF - N $ETRAP,$ESTACK S $ETRAP="D ERRA^MAGGTERR" - K MAGRY - S MAGRY(0)="0^Error: Attempting to access user preference" - S PRFIEN=$O(^MAG(2006.18,"AC",DUZ,"")) - ; if first time user - I 'PRFIEN S PRFIEN=$$NEWUSER(DUZ) Q:PRFIEN=-1 - ; merge default settings into User's Preferences - D MERGE(PRFIEN) - ; This returns the users default Filter, and creates filters if needed. - S $P(^MAG(2006.18,PRFIEN,"LISTWIN1"),"^",3)=$$DFTFLT^MAGGSFLT(DUZ) - S MAGRY(0)="1^User Preferences returned." - ; - ; At This point. Then entry in 2006.18 for User DUZ in complete - ; it has been merged with defaults, and has a valid Default Filter. - ; - ; if caller only wants one node, get it then quit. - I $L($G(CODE)) S MAGRY($O(MAGRY(""),-1)+1)=CODE_"^"_$G(^MAG(2006.18,PRFIEN,CODE)) Q - ; - ; loop through User Pref file, returning all nodes. - ; Next line was Un-Commented out. BUT Clients before Patch 8 need it. - S MAGRY($O(MAGRY(""),-1)+1)="SYS^"_^MAG(2006.18,PRFIEN,0) - S NODE="" - F S NODE=$O(^MAG(2006.18,PRFIEN,NODE)) Q:(NODE="") D - . S MAGRY($O(MAGRY(""),-1)+1)=NODE_"^"_^MAG(2006.18,PRFIEN,NODE) - Q -MERGE(PRFIEN) ; Merge default settings into User Prefs returned. - ; This will assure the User Prefs returned have values for New fields. - ; PRFIEN = IEN in IMAGING USER PREFERENCES File. - N NODE,DARR,MN,YN - D DFLTARR(.DARR) - S NODE="" F S NODE=$O(DARR($J,NODE)) Q:(NODE="") D - . S YN=DARR($J,NODE) - . S MN=$G(^MAG(2006.18,PRFIEN,NODE)) - . F J=1:1:$L(YN,"^") I ($P(YN,"^",J)'=""),($P(MN,"^",J)="") S $P(MN,"^",J)=$P(YN,"^",J) - . S ^MAG(2006.18,PRFIEN,NODE)=MN - ; - Q -SAVE(MAGRY,DATA) ;RPC [MAGGUPREFSAVE] Call to save User Preferences - ; - S MAGRY="0^Error: Saving user preferences." - N X,Y,NODE,PRFIEN,J - N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGGTERR" - S PRFIEN=$O(^MAG(2006.18,"AC",DUZ,"")) I 'PRFIEN S PRFIEN=$$NEWUSER(DUZ) Q:PRFIEN=-1 - S NODE="" F S NODE=$O(DATA(NODE)) Q:NODE="" D - . S X=$G(^MAG(2006.18,PRFIEN,NODE)) - . S Y=DATA(NODE) - . F J=1:1:$L(Y,"^") I $L($P(Y,"^",J)) S $P(X,"^",J)=$P(Y,"^",J) - . S ^MAG(2006.18,PRFIEN,NODE)=X - S MAGRY="1^User Preferences saved." - Q -NEWUSER(USER) ;Returns IEN of New entry in IMAGING USER PREFERENCES File. - K DD,DO - N DIC - S X=$E($$GET1^DIQ(200,USER_",",.01),1,15)_" (SETTING 1)" - S DIC="^MAG(2006.18,",DIC(0)="L" - S DIC("DR")="1////"_USER_";2////12;3////12;" D FILE^DICN - I Y=-1 Q Y - D DEFAULT(+Y) - Q +Y -DEFAULT(NEWPREF) ;Setup a new IMAGING USER PREFERENCES entry, with System defaults. - ; NEWPREF = IEN in IMAGING USER PREFERENCES File - N DFTPREF,N0,DFTSET - S DFTPREF=+$$GET1^DIQ(2006.1,$$PLACE^MAGBAPI(DUZ(2)),100,"I") ; DBI - SEB 9/20/2002 - I DFTPREF,$D(^MAG(2006.18,DFTPREF)) D DEFUSER(NEWPREF,DFTPREF) Q - ; save the User name, Setting Name - S N0=$P(^MAG(2006.18,NEWPREF,0),U,1,4) - D DFLTARR(.DFTSET) - M ^MAG(2006.18,NEWPREF)=DFTSET($J) - ; reset User name, Setting name. - S $P(^MAG(2006.18,NEWPREF,0),U,1,4)=N0 - Q -DEFUSER(NEWPREF,DFTPREF) ;Merge New User preference with the Default User as defined - ; in the Imaging Site Parameters file - ; NEWPREF = new IMAGING USER PREFERENCE (IEN) - ; DFLTPREF = DEFAULT USER PREFERENCE in the IMAGING SITE PARAMETERS File - ; - N X0 - S X0=$P(^MAG(2006.18,NEWPREF,0),"^",1,4) - M ^MAG(2006.18,NEWPREF)=^MAG(2006.18,DFTPREF) - S $P(^MAG(2006.18,NEWPREF,0),"^",1,4)=X0 - ; remove default user's default Filter from new user's preferences. - S $P(^MAG(2006.18,NEWPREF,"LISTWIN1"),"^",3)="" - Q -DFLTARR(ARR) ; Return an Array of All Default settings - K ARR($J) - S ARR($J,0)="^^^^0^1^1^" - S ARR($J,"DICOMWIN")="2^320^292^724^487" - S ARR($J,"IMAGEGRID")="2^487^2^786^426^1^35,73,67,34,110,46,69,96,76,79,25,0,0^1^" - S ARR($J,"REPORT")="2^2^333^722^437^Courier^^10" - S ARR($J,"RADLISTWIN")="2^487^10^433^172^0" - S ARR($J,"MAIN")="2^1^1^487^172^1" - S ARR($J,"ABS")="2^1^160^486^326^134^113^1^1^3^24^2^1^0" - S ARR($J,"FULL")="2^310^282^714^487^674^447^^1^1^4^1^0^1" - S ARR($J,"GROUP")="2^24^231^427^457^110^70^^1^2^24^2^1^0" - S ARR($J,"DOC")="2^298^24^729^429^0^0^3^1^2^4^2^0" - S ARR($J,"CAPCONFIG")="1^1^1^0^0^0^0^1^0^1^0^0^1^1^0^0^1^1^1^1^1^1^200^400^300^100^500^0^0^1^0^1" - ; 1 2 3 4 5 6 7 8 9 0 1 2 3 456 7 8 - S ARR($J,"CAPTIU")="261^414^455^654^66^67^280^1^1^~^1^100^-12^^^1^1^^" - S ARR($J,"RIVER")="1^0^0^0^" - S ARR($J,"APPMSG")="0^0^" - S ARR($J,"APPPREFS")="1^7^7^10" - S ARR($J,"LISTWIN1")="1^1^^1^1" - Q +MAGGTUP ;WOIFO/GEK - Imaging System User preferences ; [ 06/20/2001 08:57 ] + ;;3.0;IMAGING;**7,8,48,45**;Sep 12, 2005 + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q +GET(MAGRY,CODE) ;RPC [MAGGUPREFGET] Call to Get user preferences. + ; + N Y,PRFIEN,J,X,Z,NODE,MAGPREF + N $ETRAP,$ESTACK S $ETRAP="D ERRA^MAGGTERR" + K MAGRY + S MAGRY(0)="0^Error: Attempting to access user preference" + S PRFIEN=$O(^MAG(2006.18,"AC",DUZ,"")) + ; if first time user + I 'PRFIEN S PRFIEN=$$NEWUSER(DUZ) Q:PRFIEN=-1 + ; merge default settings into User's Preferences + D MERGE(PRFIEN) + ; This returns the users default Filter, and creates filters if needed. + S $P(^MAG(2006.18,PRFIEN,"LISTWIN1"),"^",3)=$$DFTFLT^MAGGSFLT(DUZ) + S MAGRY(0)="1^User Preferences returned." + ; + ; At This point. Then entry in 2006.18 for User DUZ in complete + ; it has been merged with defaults, and has a valid Default Filter. + ; + ; if caller only wants one node, get it then quit. + I $L($G(CODE)) S MAGRY($O(MAGRY(""),-1)+1)=CODE_"^"_$G(^MAG(2006.18,PRFIEN,CODE)) Q + ; + ; loop through User Pref file, returning all nodes. + ; Next line was Un-Commented out. BUT Clients before Patch 8 need it. + S MAGRY($O(MAGRY(""),-1)+1)="SYS^"_^MAG(2006.18,PRFIEN,0) + S NODE="" + F S NODE=$O(^MAG(2006.18,PRFIEN,NODE)) Q:(NODE="") D + . S MAGRY($O(MAGRY(""),-1)+1)=NODE_"^"_^MAG(2006.18,PRFIEN,NODE) + Q +MERGE(PRFIEN) ; Merge default settings into User Prefs returned. + ; This will assure the User Prefs returned have values for New fields. + ; PRFIEN = IEN in IMAGING USER PREFERENCES File. + N NODE,DARR,MN,YN + D DFLTARR(.DARR) + S NODE="" F S NODE=$O(DARR($J,NODE)) Q:(NODE="") D + . S YN=DARR($J,NODE) + . S MN=$G(^MAG(2006.18,PRFIEN,NODE)) + . F J=1:1:$L(YN,"^") I ($P(YN,"^",J)'=""),($P(MN,"^",J)="") S $P(MN,"^",J)=$P(YN,"^",J) + . S ^MAG(2006.18,PRFIEN,NODE)=MN + ; + Q +SAVE(MAGRY,DATA) ;RPC [MAGGUPREFSAVE] Call to save User Preferences + ; + S MAGRY="0^Error: Saving user preferences." + N X,Y,NODE,PRFIEN,J + N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGGTERR" + S PRFIEN=$O(^MAG(2006.18,"AC",DUZ,"")) I 'PRFIEN S PRFIEN=$$NEWUSER(DUZ) Q:PRFIEN=-1 + S NODE="" F S NODE=$O(DATA(NODE)) Q:NODE="" D + . S X=$G(^MAG(2006.18,PRFIEN,NODE)) + . S Y=DATA(NODE) + . F J=1:1:$L(Y,"^") I $L($P(Y,"^",J)) S $P(X,"^",J)=$P(Y,"^",J) + . S ^MAG(2006.18,PRFIEN,NODE)=X + S MAGRY="1^User Preferences saved." + Q +NEWUSER(USER) ;Returns IEN of New entry in IMAGING USER PREFERENCES File. + K DD,DO + N DIC + S X=$E($$GET1^DIQ(200,USER_",",.01),1,15)_" (SETTING 1)" + S DIC="^MAG(2006.18,",DIC(0)="L" + S DIC("DR")="1////"_USER_";2////12;3////12;" D FILE^DICN + I Y=-1 Q Y + D DEFAULT(+Y) + Q +Y +DEFAULT(NEWPREF) ;Setup a new IMAGING USER PREFERENCES entry, with System defaults. + ; NEWPREF = IEN in IMAGING USER PREFERENCES File + N DFTPREF,N0,DFTSET + S DFTPREF=+$$GET1^DIQ(2006.1,$$PLACE^MAGBAPI(DUZ(2)),100,"I") ; DBI - SEB 9/20/2002 + I DFTPREF,$D(^MAG(2006.18,DFTPREF)) D DEFUSER(NEWPREF,DFTPREF) Q + ; save the User name, Setting Name + S N0=$P(^MAG(2006.18,NEWPREF,0),U,1,4) + D DFLTARR(.DFTSET) + M ^MAG(2006.18,NEWPREF)=DFTSET($J) + ; reset User name, Setting name. + S $P(^MAG(2006.18,NEWPREF,0),U,1,4)=N0 + Q +DEFUSER(NEWPREF,DFTPREF) ;Merge New User preference with the Default User as defined + ; in the Imaging Site Parameters file + ; NEWPREF = new IMAGING USER PREFERENCE (IEN) + ; DFLTPREF = DEFAULT USER PREFERENCE in the IMAGING SITE PARAMETERS File + ; + N X0 + S X0=$P(^MAG(2006.18,NEWPREF,0),"^",1,4) + M ^MAG(2006.18,NEWPREF)=^MAG(2006.18,DFTPREF) + S $P(^MAG(2006.18,NEWPREF,0),"^",1,4)=X0 + ; remove default user's default Filter from new user's preferences. + S $P(^MAG(2006.18,NEWPREF,"LISTWIN1"),"^",3)="" + Q +DFLTARR(ARR) ; Return an Array of All Default settings + K ARR($J) + S ARR($J,0)="^^^^0^1^1^" + S ARR($J,"DICOMWIN")="2^320^292^724^487" + S ARR($J,"IMAGEGRID")="2^487^2^786^426^1^35,73,67,34,110,46,69,96,76,79,25,0,0^1^" + S ARR($J,"REPORT")="2^2^333^722^437^Courier^^10" + S ARR($J,"RADLISTWIN")="2^487^10^433^172^0" + S ARR($J,"MAIN")="2^1^1^487^172^1" + S ARR($J,"ABS")="2^1^160^486^326^134^113^1^1^3^24^2^1^0" + S ARR($J,"FULL")="2^310^282^714^487^674^447^^1^1^4^1^0^1" + S ARR($J,"GROUP")="2^24^231^427^457^110^70^^1^2^24^2^1^0" + S ARR($J,"DOC")="2^298^24^729^429^0^0^3^1^2^4^2^0" + S ARR($J,"CAPCONFIG")="1^1^1^0^0^0^0^1^0^1^0^0^1^1^0^0^1^1^1^1^1^1^200^400^300^100^500^0^0^1^" + S ARR($J,"CAPTIU")="5^369^760^654^289^67^170^1^1^" + S ARR($J,"RIVER")="1^0^0^0^" + S ARR($J,"APPPREFS")="1^7^7^10" + S ARR($J,"LISTWIN1")="1^1^^1^1" + Q diff --git a/r/IMAGING-MAG-ZMAG/MAGJEX1B.m b/r/IMAGING-MAG-ZMAG/MAGJEX1B.m index c5afa418..1d37da16 100644 --- a/r/IMAGING-MAG-ZMAG/MAGJEX1B.m +++ b/r/IMAGING-MAG-ZMAG/MAGJEX1B.m @@ -1,122 +1,122 @@ -MAGJEX1B ;WIRMFO/JHC Rad. Workstation RPC calls ; 29 Jul 2003 9:58 AM - ;;3.0;IMAGING;**16,22,18,65,76**;Jun 22, 2007;Build 19 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q - ; Subroutines for fetch exam images, exam lock/reserve, remove dangling locks - ; -IMGLOOP ; get data for all the images - ; This subroutine is called from MAGJEX1 - ; MAGGRY holds $NA reference to ^TMP where Broker return message is assembled; - ; all references to MAGGRY use subscript indirection - N DFN,IMGREC,P18ALTP - I '$D(MAGJOB("ALTPATH")) S MAGJOB("ALTPATH")=0 ; facilitates testing - F IMAG=MAGSTRT:1:MAGEND S MAGIEN=$P(MAGS(IMAG),U,4) D - . S DFN=$P(MAGS(IMAG),U,8) - . I DFN=RADFN S MIXEDUP(RADFN)="" ;ok - . E S:'DFN DFN=0 S MIXEDUP=MIXEDUP+2,MIXEDUP(DFN)="" ; database corruption - . S MDL=$P(MAGS(IMAG),U,3) - . I MDL="DR" S MDL="CR" ; for now, hard code cx of non-standard code - . I $G(SERBRK),(SERLBL]"") D ; mark Begin of series - . . S CT=CT+1,@MAGGRY@(CT+STARTNOD)=SERLBL,SERLBL="" - . S MAGXX=MAGIEN D - . . I 'USETGA,($P(MAGS(IMAG),U,2)["BIG") D BIG^MAGFILEB Q - . . E D VST^MAGFILEB - . I MAGJOB("ALTPATH") S X=$P(MAGS(IMAG),U,6),P18ALTP="" I X]"" D - . . F I=1:1:$L(X,",") S T=$P(X,",",I) I T S CURPATHS(T)="" I 'MAGJOB("P32"),$D(MAGJOB("LOC",T)) S P18ALTP=P18ALTP_$S(P18ALTP="":"",1:",")_T - . S IMGREC="B2^"_MAGIEN_U_MAGFILE2 - . I 'MAGJOB("P32") D - . . S T="",X=$P(MAGS(IMAG),U,11) I X]"" F I="K","I","U" I X[I,$D(PSIND(I)) S T=T_$S(T="":"",1:",")_I ; PS_Indicators - . . S IMGREC=IMGREC_U_T_U_$S(MAGJOB("ALTPATH"):P18ALTP,1:"") ; AltPaths for this img - . . I '(PROCDT]"") D ; Img Process Date - . . . S X=$P(MAGS(IMAG),U,12) I X]"" S T=$S($E(X)=3:20,$E(X)=2:19,1:"") I T S PROCDT=T_$E(X,2,7) - . . I '(ACQSITE]"") D ; Acq Site - . . . S X=$P(MAGS(IMAG),U,13) I X]"" S ACQSITE=X - . S CT=CT+1,@MAGGRY@(CT+STARTNOD)=IMGREC - . I MODALITY="" D - . . I 'MAGJOB("P32") S MODALITY=MDL Q - . . N T S T=$P("1dummy1^CT^CR^MR^US^AS^CD^CS^DG^EC^FA^LP^MA^PT^ST^XA^NM^OT^BI^CP^DD^DM^ES^FS^LS^MS^RG^TG^RF^RTIMAGE^RTSTRUCT^HC^RTDOSE^RTPLAN^RTRECORD^DX^MG^IO^PX",U_MDL_U,1) - . . S MODALITY=$L(T,U) - . . I MODALITY>38 S MODALITY=9999 ; 38=TOTAL # modalities defined; else 9999 - . . I STKLAY S OPENCNT=0 ; no limit on WS for # of exams open in StackVwr - ; - I 'MAGJOB("ALTPATH") S ALTPATH=-1 - E D - . S T=0 F S T=$O(CURPATHS(T)) Q:'T I $D(MAGJOB("LOC",T)) Q - . S ALTPATH=$S('T:0,1:1) - . I ALTPATH=$P(MAGJOB("ALTPATH"),U,2) S ALTPATH=-1 - . E S $P(MAGJOB("ALTPATH"),U,2)=ALTPATH -IMGLOOPZ Q - ; - ; -LOCKIN(RARPT,LOCKLEV,MYLOCK,LOCKCHK) ; init lock-related info B4 do any lock actions - ; called from UTL3 & EX1A - ; if LOCKCHK="STATUS", only return current status - ; Input RARPT (required) and LOCKCHK (opt) - ; Output: LOCKLEV & MYLOCK array; successful LOCKS left intact, unless LOCKCHK="STATUS" - ; M LOCKS det. what Actions are possible by calling program modules - ; MYLOCK(1/2)= Lock_is_Mine ^ DUZ ^ $J ^ User Name ^ User Init ^ Case # - ; LOCKLEV=0:3--is/not 1-Lockable/2-Reservable/3-Both to user - ; MYLOCK=0:3--is/not already 1-Locked/2-Reserved/3-Both by user - ; - N CKMINE,CASENO,XX,XY,ILOCK - S LOCKCHK=$G(LOCKCHK)="STATUS" - S LOCKLEV=0 K MYLOCK S MYLOCK=0 - L +^XTMP("MAGJ","LOCK",RARPT):0 - I S LOCKLEV=3 - L +^XTMP("MAGJ","LOCK",RARPT,1):0 ; "1" for Exam "LOCK" - I S:'LOCKLEV LOCKLEV=1 - L +^XTMP("MAGJ","LOCK",RARPT,2):0 ; "2" for Exam "RESERVE" - I S LOCKLEV=$S('LOCKLEV:2,1:3) - L -^XTMP("MAGJ","LOCK",RARPT) - S CKMINE=DUZ_U_$J - F ILOCK=1,2 D - . S XX="",XY="",CASENO=$G(^XTMP("MAGJ","LOCK",RARPT,ILOCK)) - . I CASENO]"" S XX=$G(^XTMP("MAGJ","LOCK",RARPT,ILOCK,CASENO)),XY=$P(XX,"|",2),XX=$P(XX,"|") - . S X=$P(XX,U,1,2),MYLOCK(ILOCK)=(X=CKMINE) - . S X=$P(XX,U)_U_$P(XX,U,2)_U_$P(XX,U,4)_U_$P(XX,U,5)_U_CASENO_U_"|"_XY - . S MYLOCK(ILOCK)=MYLOCK(ILOCK)_U_X - . I MYLOCK(ILOCK) S MYLOCK=MYLOCK+ILOCK - I LOCKCHK,LOCKLEV D ; reset locks for Lock check - . I LOCKLEV=1!(LOCKLEV=3) L -^XTMP("MAGJ","LOCK",RARPT,1) - . I LOCKLEV=2!(LOCKLEV=3) L -^XTMP("MAGJ","LOCK",RARPT,2) - Q - ; -REMLOCK ; Remove dangling exam locks; this is run only at Logon - ; If a recorded lock is found that a new job (logon) can M-Lock - ; then that is a dangling lock that must be removed - N RARPT,TS,LOCKLEV,MYLOCK,ACTION,DAYCASE,ILOCK,RESULT - S RARPT="" - F S RARPT=$O(^XTMP("MAGJ","LOCK",RARPT)) Q:'RARPT D ; loop thru recorded locks - . D LOCKIN(RARPT,.LOCKLEV,.MYLOCK) - . I 'LOCKLEV Q ;unable to lock--is ok - . S ACTION="",DAYCASE="" - . F ILOCK=1,2 I $D(^XTMP("MAGJ","LOCK",RARPT,ILOCK)) S XX=^(ILOCK) D - . . I DAYCASE="" S DAYCASE=$P(XX,U) - . . I ILOCK=1,(LOCKLEV=1!(LOCKLEV=3)) S $P(ACTION,U,1)=1 - . . I ILOCK=2,(LOCKLEV=2!(LOCKLEV=3)) S $P(ACTION,U,2)=1 - . I 'ACTION,'+$P(ACTION,U,2),(DAYCASE="") D Q ; should never occur, but - . . I LOCKLEV=1!(LOCKLEV=3) L -^XTMP("MAGJ","LOCK",RARPT,1) - . . I LOCKLEV=2!(LOCKLEV=3) L -^XTMP("MAGJ","LOCK",RARPT,2) - . D LOCKOUT^MAGJEX1A(RARPT,DAYCASE,.LOCKLEV,.MYLOCK,ACTION,.RESULT) ; 1st, lock to me - . K LOCKLEV,MYLOCK D LOCKACT^MAGJEX1A(RARPT,DAYCASE,101,.RESULT) ; then, clear the lock - S TS="" F I=2,0 S TS=TS_$S(TS="":"",1:U)_$$HTFM^XLFDT($H+I,0) - S ^XTMP("MAGJ",0)=TS_U_"VistaRad Locks" - Q - ; - ; -END ; +MAGJEX1B ;WIRMFO/JHC Rad. Workstation RPC calls ; 29 Jul 2003 9:58 AM + ;;3.0;IMAGING;**16,22,18,65**;Jul 27, 2006;Build 28 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q + ; Subroutines for fetch exam images, exam lock/reserve, remove dangling locks + ; +IMGLOOP ; get data for all the images + ; This subroutine is called from MAGJEX1 + ; MAGGRY holds $NA reference to ^TMP where Broker return message is assembled; + ; all references to MAGGRY use subscript indirection + N DFN,IMGREC,P18ALTP + I '$D(MAGJOB("ALTPATH")) S MAGJOB("ALTPATH")=0 ; facilitates testing + F IMAG=MAGSTRT:1:MAGEND S MAGIEN=$P(MAGS(IMAG),U,4) D + . S DFN=$P(MAGS(IMAG),U,8) + . I DFN=RADFN S MIXEDUP(RADFN)="" ;ok + . E S:'DFN DFN=0 S MIXEDUP=MIXEDUP+2,MIXEDUP(DFN)="" ; database corruption + . S MDL=$P(MAGS(IMAG),U,3) + . I MDL="DR" S MDL="CR" ; for now, hard code cx of non-standard code + . I $G(SERBRK),(SERLBL]"") D ; mark Begin of series + . . S CT=CT+1,@MAGGRY@(CT+STARTNOD)=SERLBL,SERLBL="" + . S MAGXX=MAGIEN D + . . I 'USETGA,($P(MAGS(IMAG),U,2)["BIG") D BIG^MAGFILEB Q + . . E D VST^MAGFILEB + . I MAGJOB("ALTPATH") S X=$P(MAGS(IMAG),U,6),P18ALTP="" I X]"" D + . . F I=1:1:$L(X,",") S T=$P(X,",",I) I T S CURPATHS(T)="" I 'MAGJOB("P32"),$D(MAGJOB("LOC",T)) S P18ALTP=P18ALTP_$S(P18ALTP="":"",1:",")_T + . S IMGREC="B2^"_MAGIEN_U_MAGFILE2 + . I 'MAGJOB("P32") D + . . S T="",X=$P(MAGS(IMAG),U,11) I X]"" F I="K","I","U" I X[I,$D(PSIND(I)) S T=T_$S(T="":"",1:",")_I ; PS_Indicators + . . S IMGREC=IMGREC_U_T_U_$S(MAGJOB("ALTPATH"):P18ALTP,1:"") ; AltPaths for this img + . . I '(PROCDT]"") D ; Img Process Date + . . . S X=$P(MAGS(IMAG),U,12) I X]"" S T=$S($E(X)=3:20,$E(X)=2:19,1:"") I T S PROCDT=T_$E(X,2,7) + . . I '(ACQSITE]"") D ; Acq Site + . . . S X=$P(MAGS(IMAG),U,13) I X]"" S ACQSITE=X + . S CT=CT+1,@MAGGRY@(CT+STARTNOD)=IMGREC + . I MODALITY="" D + . . I 'MAGJOB("P32") S MODALITY=MDL Q + . . N T S T=$P("1dummy1^CT^CR^MR^US^AS^CD^CS^DG^EC^FA^LP^MA^PT^ST^XA^NM^OT^BI^CP^DD^DM^ES^FS^LS^MS^RG^TG^RF^RTIMAGE^RTSTRUCT^HC^RTDOSE^RTPLAN^RTRECORD^DX^MG^IO^PX",U_MDL_U,1) + . . S MODALITY=$L(T,U) + . . I MODALITY>38 S MODALITY=9999 ; 38=TOTAL # modalities defined; else 9999 + . . I STKLAY S OPENCNT=0 ; no limit on WS for # of exams open in StackVwr + ; + I 'MAGJOB("ALTPATH") S ALTPATH=-1 + E D + . S T=0 F S T=$O(CURPATHS(T)) Q:'T I $D(MAGJOB("LOC",T)) Q + . S ALTPATH=$S('T:0,1:1) + . I ALTPATH=$P(MAGJOB("ALTPATH"),U,2) S ALTPATH=-1 + . E S $P(MAGJOB("ALTPATH"),U,2)=ALTPATH +IMGLOOPZ Q + ; + ; +LOCKIN(RARPT,LOCKLEV,MYLOCK,LOCKCHK) ; init lock-related info B4 do any lock actions + ; called from UTL3 & EX1A + ; if LOCKCHK="STATUS", only return current status + ; Input RARPT (required) and LOCKCHK (opt) + ; Output: LOCKLEV & MYLOCK array; successful LOCKS left intact, unless LOCKCHK="STATUS" + ; M LOCKS det. what Actions are possible by calling program modules + ; MYLOCK(1/2)= Lock_is_Mine ^ DUZ ^ $J ^ User Name ^ User Init ^ Case # + ; LOCKLEV=0:3--is/not 1-Lockable/2-Reservable/3-Both to user + ; MYLOCK=0:3--is/not already 1-Locked/2-Reserved/3-Both by user + ; + N CKMINE,CASENO,XX,XY,ILOCK + S LOCKCHK=$G(LOCKCHK)="STATUS" + S LOCKLEV=0 K MYLOCK S MYLOCK=0 + L +^XTMP("MAGJ","LOCK",RARPT):0 + I S LOCKLEV=3 + L +^XTMP("MAGJ","LOCK",RARPT,1):0 ; "1" for Exam "LOCK" + I S:'LOCKLEV LOCKLEV=1 + L +^XTMP("MAGJ","LOCK",RARPT,2):0 ; "2" for Exam "RESERVE" + I S LOCKLEV=$S('LOCKLEV:2,1:3) + L -^XTMP("MAGJ","LOCK",RARPT) + S CKMINE=DUZ_U_$J + F ILOCK=1,2 D + . S XX="",XY="",CASENO=$G(^XTMP("MAGJ","LOCK",RARPT,ILOCK)) + . I CASENO]"" S XX=$G(^XTMP("MAGJ","LOCK",RARPT,ILOCK,CASENO)),XY=$P(XX,"|",2),XX=$P(XX,"|") + . S X=$P(XX,U,1,2),MYLOCK(ILOCK)=(X=CKMINE) + . S X=$P(XX,U)_U_$P(XX,U,2)_U_$P(XX,U,4)_U_$P(XX,U,5)_U_CASENO_U_"|"_XY + . S MYLOCK(ILOCK)=MYLOCK(ILOCK)_U_X + . I MYLOCK(ILOCK) S MYLOCK=MYLOCK+ILOCK + I LOCKCHK,LOCKLEV D ; reset locks for Lock check + . I LOCKLEV=1!(LOCKLEV=3) L -^XTMP("MAGJ","LOCK",RARPT,1) + . I LOCKLEV=2!(LOCKLEV=3) L -^XTMP("MAGJ","LOCK",RARPT,2) + Q + ; +REMLOCK ; Remove dangling exam locks; this is run only at Logon + ; If a recorded lock is found that a new job (logon) can M-Lock + ; then that is a dangling lock that must be removed + N RARPT,TS,LOCKLEV,MYLOCK,ACTION,DAYCASE,ILOCK,RESULT + S RARPT="" + F S RARPT=$O(^XTMP("MAGJ","LOCK",RARPT)) Q:'RARPT D ; loop thru recorded locks + . D LOCKIN(RARPT,.LOCKLEV,.MYLOCK) + . I 'LOCKLEV Q ;unable to lock--is ok + . S ACTION="",DAYCASE="" + . F ILOCK=1,2 I $D(^XTMP("MAGJ","LOCK",RARPT,ILOCK)) S XX=^(ILOCK) D + . . I DAYCASE="" S DAYCASE=$P(XX,U) + . . I ILOCK=1,(LOCKLEV=1!(LOCKLEV=3)) S $P(ACTION,U,1)=1 + . . I ILOCK=2,(LOCKLEV=2!(LOCKLEV=3)) S $P(ACTION,U,2)=1 + . I 'ACTION,'+$P(ACTION,U,2),(DAYCASE="") D Q ; should never occur, but + . . I LOCKLEV=1!(LOCKLEV=3) L -^XTMP("MAGJ","LOCK",RARPT,1) + . . I LOCKLEV=2!(LOCKLEV=3) L -^XTMP("MAGJ","LOCK",RARPT,2) + . D LOCKOUT^MAGJEX1A(RARPT,DAYCASE,.LOCKLEV,.MYLOCK,ACTION,.RESULT) ; 1st, lock to me + . K LOCKLEV,MYLOCK D LOCKACT^MAGJEX1A(RARPT,DAYCASE,101,.RESULT) ; then, clear the lock + S TS="" F I=2,0 S %H=$H+I D YMD^%DTC S TS=TS_$S(TS="":"",1:U)_X + S ^XTMP("MAGJ",0)=TS_U_"VistaRad Locks" + Q + ; + ; +END ; diff --git a/r/IMAGING-MAG-ZMAG/MAGJEX2.m b/r/IMAGING-MAG-ZMAG/MAGJEX2.m index ab827d20..71f23e75 100644 --- a/r/IMAGING-MAG-ZMAG/MAGJEX2.m +++ b/r/IMAGING-MAG-ZMAG/MAGJEX2.m @@ -1,169 +1,168 @@ -MAGJEX2 ;;WIRMFO/JHC Rad. Workstation RPC calls;[ 02/25/2000 4:40 PM ] ; 09 Jun 2003 2:58 PM - ;;3.0;IMAGING;**51,18,76**;Jun 22, 2007;Build 19 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q - ; Subroutines for pre-fetch/ auto-display prior exams' images - ; Entry Points: - ; PRIOR1 -- Pre-Fetch/Auto-Display images for other related cases; - ; RPC Call: MAGJ PRIOREXAMS - ; PREFETCH -- Pre-Fetch initiated from - ; - Q -ERR N ERR S ERR=$$EC^%ZOSV S MAGGRY(0)="0^Server Program Error: "_ERR - D @^%ZOSF("ERRTN") - Q:$Q 1 Q -PREFETCH ; Entry point from HL7 processing, to initiate prefetch at - ; time of radiology "Register Patient for Exam" function - ; Do not process if the exam is being Canceled (RACANC true) - ; - N RET S RET="" - I '$P($G(^MAG(2006.69,1,0)),U,5) G PREFQ ; Prefetch disabled - I '($G(RADFN)&$G(RADTI)&$G(RACNI)&'$G(RACANC)) G PREFQ ; Required vars - D PRIOR1(.RET,"P"_U_RADFN_U_RADTI_U_RACNI) -PREFQ ; W !,"End PRE-FETCH RET=" N JHC R JHC ZW RET - Q - ; -PRIOR1(MAGGRY,DATA) ; review all exams for a patient to find "related" exams - ; This ep also called as subroutine from routing software (P51) - ; MAGGRY - return array of exams to PreFetch, or Auto-send to RAD W/S - ; DATA: - input params for the Current Exam - ; 1) ACTION = P -- Pre-fetch Exams (from Jukebox to Magnetic Disk) - ; = A -- Auto-route priors - ; 2) RADFN = Case pointers to Rad/Nuc Med Patient file - ; 3) RADTI = "" "" "" "" - ; 4) RACNI = "" "" "" "" - ; 5) RARPT - Case pointer to ^RARPT global - ; - N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGJEX2" - K MAGGRY - N RADFN,RADTI,RACNI,RARPT,RADATA - N DAYCASE,DIQUIET,ACTION,CPT,HDR,MAGDFN,MAGDTI,MAGCNI,MAGRET,MAGRACNT - S ACTION=$P(DATA,U) - I ACTION="P"!(ACTION="A") - E S MAGGRY(0)="0^Invalid Request (Action code="_ACTION_")" G PRIOR1Z - S MAGDFN=$P(DATA,U,2),MAGDTI=$P(DATA,U,3),MAGCNI=$P(DATA,U,4) - I MAGDFN,MAGDTI,MAGCNI - E S MAGGRY(0)="0^Request Contains Invalid Case Pointer ("_DATA_")" G PRIOR1Z - S DIQUIET=1 D DT^DICRW - N MAGJOB D MAGJOBNC^MAGJUTL3 - S HDR=$S(ACTION="P":"Pre-fetch",ACTION="A":"Auto-Display",1:"???")_" Prior Exams for CASE: " - I '$D(^DPT(MAGDFN,0)) S MAGGRY(0)="0^Request Contains Invalid Patient Pointer ("_MAGDFN_")" G PRIOR1Z - I $D(^RADPT(MAGDFN,"DT",MAGDTI,"P",MAGCNI)) - E S MAGGRY(0)="0^Request Contains Invalid Case Pointer ("_MAGCNI_")" G PRIOR1Z - S MAGRACNT=0 - S MAGGRY(0)="0^Compiling Prior Radiology Exams" - D GETEXAM2^MAGJUTL1(MAGDFN,MAGDTI,MAGCNI,"",.MAGRET) ; Current Exam only - S RADFN=MAGDFN,RADTI=MAGDTI,RACNI=MAGCNI - I 'MAGRET S MAGGRY(0)="0^Current Case is Not Accessible" G PRIOR1Z - S RADATA=$G(^TMP($J,"MAGRAEX",1,1)) S DAYCASE=$P(RADATA,U,12) D SVMAG2A - I 'MAGGRY(0) S MAGGRY(0)="0^Current Case either has no CPT code, or has no rules defined for its CPT code." G PRIOR1Z - S HDR=HDR_DAYCASE - D SRCH(MAGDFN) ; Search prior exams for this patient -PRIOR1Z ; - I 'MAGGRY(0) S:(MAGGRY(0)["Compiling") MAGGRY(0)="0^No Exams Found" - E I +MAGGRY(0)=1 S MAGGRY(0)="0^No Prior Exams Found" K MAGGRY(1) - E D SVMAG2B - K ^TMP($J,"MAGRAEX"),^("RAE1") - Q - ; -SRCH(RADFN) ; Traverse all exams for a patient, up to limits of age & total - ; numbers of exams to consider - N BEGDT,LIMYRS,LIMEXAMS,X - S X=$G(^MAG(2006.69,1,0)) - S LIMYRS=+$P(X,U,14),LIMEXAMS=+$P(X,U,15) - S:'LIMYRS LIMYRS=7 S:'LIMEXAMS LIMEXAMS=50 ; default limit # Exams - S BEGDT=($E(DT,1,3)-LIMYRS)_$E(DT,4,7) - I BEGDT<2950101 S BEGDT=2950101 ; 2 yrs prior to earliest VistaPACS - S MAGRACNT=1 D GETEXAM3^MAGJUTL1(RADFN,BEGDT,"",.MAGRACNT,.MAGRET,"",LIMEXAMS) - I MAGRET N IDAT S IDAT=1 D - . F S IDAT=$O(^TMP($J,"MAGRAEX",IDAT)) Q:'IDAT S RADATA=^(IDAT,1) D - .. S RADTI=$P(RADATA,U,2),RACNI=$P(RADATA,U,3) - .. I RADTI=MAGDTI&(RACNI=MAGCNI) Q ; skip current case - .. D SVMAG2A - Q - ; -SVMAG2A ; 2A and 2B used by subroutine at tag PRIOR1 - ; Find all the patient's exams whose CPT codes are related to the - ; Current exam's CPT code, according to dictionary 2006.65 - N RAIMGTYP - N CPT,CPT3,CPT4,CPT5,CURCPTX,CURCPTS,HIT,MAGMATCH,MAGDTH - S RARPT=+$P(RADATA,U,10) - I MAGGRY(0) Q:'$P(MAGGRY(1),U) ; Cur Case CPT not in map file - I Q:(ACTION="P")&'$D(^RARPT(RARPT,2005)) ; nothing to pre-fetch - I Q:$P(RADATA,U,15)<2 ; Cancel or Waiting - ; Note: if no images, may still want to do Auto-Disp to get Report; - ; also, Current Case should still proceed - S CPT=$P(RADATA,U,17) - Q:'CPT ; algorithm REQUIRES CPT codes be used - S CPT5=CPT,CPT4=$E(CPT,1,4),CPT3=$E(CPT,1,3) - S MAGMATCH="^^" - I 'MAGGRY(0) D Q:'MAGMATCH ; No rules defined for Cur. Case's CPT - . S Y="" - . ; Order of CPT5/4/3 is important for the algorithm, which - . ; uses the 1st rule found at the LOWEST level of detail defined - . F X=CPT5,CPT4,CPT3 I $D(^MAG(2006.65,"B",X)) S Y=Y_$S(Y:",",1:"")_X S $P(MAGMATCH,U)=Y - I CPT,MAGGRY(0) D - . ; curcpts has the cpt5/4/3 list generated above for Cur. Case CPT's - . S HIT=0,CURCPTS=$P(MAGGRY(1),U) - . F Q:CURCPTS="" S CURCPTX=$O(^MAG(2006.65,"B",$P(CURCPTS,","),"")) S CURCPTS=$P(CURCPTS,",",2,9) I CURCPTX]"" D Q:HIT ; 1st hit only - .. ; This algorithm checks from lowest detail to most general, and acts - .. ; on the information found at the FIRST Hit only - .. F CPT="CPT5","CPT4","CPT3" S CPT=@CPT I CPT]"",$D(^MAG(2006.65,CURCPTX,1,"B",CPT)) S X=$O(^(CPT,"")) D S HIT=1 Q ;1st hit only - ... S X=^MAG(2006.65,CURCPTX,1,X,0) S Y=$S(ACTION="A":2,1:5),X=$P(X,U,Y,Y+2) - ... I +X S MAGMATCH=CPT F I=2,3 S $P(MAGMATCH,U,I)=$P(X,U,I) - ; sample of logic file: - ; ^MAG(2006.65,1,0) = 730 - ; ^MAG(2006.65,1,1,0) = ^12000011.01^2^2 - ; ^MAG(2006.65,1,1,1,0) = 730^1^40^6^1^120^10 - ; ^MAG(2006.65,1,1,2,0) = 732^1^40^2^1^120^4 - ; ^MAG(2006.65,1,1,"B",730,1) = - ; ^MAG(2006.65,1,1,"B",732,2) = - ; ^MAG(2006.65,"B",730,1) = - ; - Q:'MAGMATCH - ; 1 RADFN RADTI RACNI RANME RASSN <-- from GETEXAM - ; 6 RADATE RADTE RACN RAPRC RARPT - ; 11 RAST DAYCASE RAELOC RASTP RASTORD - ; 16 RADTPRT RACPT RAIMGTYP - S MAGDTH=$$FMTH^XLFDT($P(RADATA,U,7),1) - S X=$P(RADATA,U,18) - S RAIMGTYP=$S(X]"":$O(^RA(79.2,"C",X,"")),1:X) - S Y=MAGGRY(0)+1,$P(MAGGRY(0),U)=Y,MAGGRY(Y)=MAGMATCH_U_MAGDTH_U_U_$P(RADATA,U,9)_U_RAIMGTYP_U_RADFN_U_RADTI_U_RACNI_U_RARPT_U_$P(RADATA,U,12)_U_$P(RADATA,U,11) - Q - ; -SVMAG2B ; For exams whose CPTs match, select a subset that are within defined - ; limits with respect to time interval & maximum # exams to retrieve - ; Return MAGGRY(0) = count ^ message - ; MAGGRY(1:N) = "M08" | RADFN ^ RADTI ^ RACNI ^ RARPT - N CPT,CT,CURDAT,ICPT,IREC,GO - S CURDAT=$P(MAGGRY(1),U,4) - F IREC=2:1:MAGGRY(0) S X=MAGGRY(IREC),CPT=+X D K MAGGRY(IREC) - . I $P(X,U,2) S Y=CURDAT-$P(X,U,4) S:Y<0 Y=-Y I Y>$P(X,U,2) Q ;too old - . S Y=$G(GO(CPT))+1 I CPT,(Y>$P(X,U,3)) Q ; already have enough cases - . S GO(CPT)=Y,GO(CPT,Y)=X - K MAGGRY - I $D(GO) S CT=0,CPT="" D - . F S CPT=$O(GO(CPT)) Q:CPT="" F ICPT=1:1:GO(CPT) D - .. S CT=CT+1,X=GO(CPT,ICPT),RARPT=$P(X,U,11) - .. S MAGGRY(CT)="M08^"_CPT_"|"_$P(X,U,8,11) - .. I ACTION="P"!(ACTION="A") S Y=$$JBFETCH^MAGJUTL2(RARPT) ; fetch from jukebox - . S MAGGRY(0)=CT_"^"_HDR - E S MAGGRY(0)="0^No Exams Found for "_HDR - Q - ; -END ; +MAGJEX2 ;;WIRMFO/JHC Rad. Workstation RPC calls;[ 02/25/2000 4:40 PM ] ; 09 Jun 2003 2:58 PM + ;;3.0;IMAGING;**51,18**;Mar 07, 2006 + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q + ; Subroutines for pre-fetch/ auto-display prior exams' images + ; Entry Points: + ; PRIOR1 -- Pre-Fetch/Auto-Display images for other related cases; + ; RPC Call: MAGJ PRIOREXAMS + ; PREFETCH -- Pre-Fetch initiated from + ; + Q +ERR N ERR S ERR=$$EC^%ZOSV S MAGGRY(0)="0^Server Program Error: "_ERR + D @^%ZOSF("ERRTN") + Q:$Q 1 Q +PREFETCH ; Entry point from HL7 processing, to initiate prefetch at + ; time of radiology "Register Patient for Exam" function + ; Do not process if the exam is being Canceled (RACANC true) + ; + N RET S RET="" + I '$P($G(^MAG(2006.69,1,0)),U,5) G PREFQ ; Prefetch disabled + I '($G(RADFN)&$G(RADTI)&$G(RACNI)&'$G(RACANC)) G PREFQ ; Required vars + D PRIOR1(.RET,"P"_U_RADFN_U_RADTI_U_RACNI) +PREFQ ; W !,"End PRE-FETCH RET=" N JHC R JHC ZW RET + Q + ; +PRIOR1(MAGGRY,DATA) ; review all exams for a patient to find "related" exams + ; This ep also called as subroutine from routing software (P51) + ; MAGGRY - return array of exams to PreFetch, or Auto-send to RAD W/S + ; DATA: - input params for the Current Exam + ; 1) ACTION = P -- Pre-fetch Exams (from Jukebox to Magnetic Disk) + ; = A -- Auto-route priors + ; 2) RADFN = Case pointers to Rad/Nuc Med Patient file + ; 3) RADTI = "" "" "" "" + ; 4) RACNI = "" "" "" "" + ; 5) RARPT - Case pointer to ^RARPT global + ; + N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGJEX2" + K MAGGRY + N RADFN,RADTI,RACNI,RARPT,RADATA + N DAYCASE,DIQUIET,ACTION,CPT,HDR,MAGDFN,MAGDTI,MAGCNI,MAGRET,MAGRACNT + S ACTION=$P(DATA,U) + I ACTION="P"!(ACTION="A") + E S MAGGRY(0)="0^Invalid Request (Action code="_ACTION_")" G PRIOR1Z + S MAGDFN=$P(DATA,U,2),MAGDTI=$P(DATA,U,3),MAGCNI=$P(DATA,U,4) + I MAGDFN,MAGDTI,MAGCNI + E S MAGGRY(0)="0^Request Contains Invalid Case Pointer ("_DATA_")" G PRIOR1Z + S DIQUIET=1 D DT^DICRW + N MAGJOB D MAGJOBNC^MAGJUTL3 + S HDR=$S(ACTION="P":"Pre-fetch",ACTION="A":"Auto-Display",1:"???")_" Prior Exams for CASE: " + I '$D(^DPT(MAGDFN,0)) S MAGGRY(0)="0^Request Contains Invalid Patient Pointer ("_MAGDFN_")" G PRIOR1Z + I $D(^RADPT(MAGDFN,"DT",MAGDTI,"P",MAGCNI)) + E S MAGGRY(0)="0^Request Contains Invalid Case Pointer ("_MAGCNI_")" G PRIOR1Z + S MAGRACNT=0 + S MAGGRY(0)="0^Compiling Prior Radiology Exams" + D GETEXAM2^MAGJUTL1(MAGDFN,MAGDTI,MAGCNI,"",.MAGRET) ; Current Exam only + S RADFN=MAGDFN,RADTI=MAGDTI,RACNI=MAGCNI + I 'MAGRET S MAGGRY(0)="0^Current Case is Not Accessible" G PRIOR1Z + S RADATA=$G(^TMP($J,"MAGRAEX",1,1)) S DAYCASE=$P(RADATA,U,12) D SVMAG2A + I 'MAGGRY(0) S MAGGRY(0)="0^Current Case either has no CPT code, or has no rules defined for its CPT code." G PRIOR1Z + S HDR=HDR_DAYCASE + D SRCH(MAGDFN) ; Search prior exams for this patient +PRIOR1Z ; + I 'MAGGRY(0) S:(MAGGRY(0)["Compiling") MAGGRY(0)="0^No Exams Found" + E I +MAGGRY(0)=1 S MAGGRY(0)="0^No Prior Exams Found" K MAGGRY(1) + E D SVMAG2B + K ^TMP($J,"MAGRAEX"),^("RAE1") + Q + ; +SRCH(RADFN) ; Traverse all exams for a patient, up to limits of age & total + ; numbers of exams to consider + N BEGDT,LIMYRS,LIMEXAMS,X + S X=$G(^MAG(2006.69,1,0)) + S LIMYRS=+$P(X,U,14),LIMEXAMS=+$P(X,U,15) + S:'LIMYRS LIMYRS=10 S:'LIMEXAMS LIMEXAMS=100 ; default limit # Exams + S BEGDT=($E(DT,1,3)-LIMYRS)_$E(DT,4,7) + I BEGDT<2950101 S BEGDT=2950101 ; 2 yrs prior to earliest VistaPACS + S MAGRACNT=1 D GETEXAM3^MAGJUTL1(RADFN,BEGDT,"",.MAGRACNT,.MAGRET,"",LIMEXAMS) + I MAGRET N IDAT S IDAT=1 D + . F S IDAT=$O(^TMP($J,"MAGRAEX",IDAT)) Q:'IDAT S RADATA=^(IDAT,1) D + .. S RADTI=$P(RADATA,U,2),RACNI=$P(RADATA,U,3) + .. I RADTI=MAGDTI&(RACNI=MAGCNI) Q ; skip current case + .. D SVMAG2A + Q + ; +SVMAG2A ; 2A and 2B used by subroutine at tag PRIOR1 + ; Find all the patient's exams whose CPT codes are related to the + ; Current exam's CPT code, according to dictionary 2006.65 + N RAIMGTYP + N CPT,CPT3,CPT4,CPT5,CURCPTX,CURCPTS,HIT,MAGMATCH,MAGDTH + S RARPT=+$P(RADATA,U,10) + I MAGGRY(0) Q:'$P(MAGGRY(1),U) ; Cur Case CPT not in map file + I Q:(ACTION="P")&'$D(^RARPT(RARPT,2005)) ; nothing to pre-fetch + I Q:$P(RADATA,U,15)<2 ; Cancel or Waiting + ; Note: if no images, may still want to do Auto-Disp to get Report; + ; also, Current Case should still proceed + S CPT=$P(RADATA,U,17) + Q:'CPT ; algorithm REQUIRES CPT codes be used + S CPT5=CPT,CPT4=$E(CPT,1,4),CPT3=$E(CPT,1,3) + S MAGMATCH="^^" + I 'MAGGRY(0) D Q:'MAGMATCH ; No rules defined for Cur. Case's CPT + . S Y="" + . ; Order of CPT5/4/3 is important for the algorithm, which + . ; uses the 1st rule found at the LOWEST level of detail defined + . F X=CPT5,CPT4,CPT3 I $D(^MAG(2006.65,"B",X)) S Y=Y_$S(Y:",",1:"")_X S $P(MAGMATCH,U)=Y + I CPT,MAGGRY(0) D + . ; curcpts has the cpt5/4/3 list generated above for Cur. Case CPT's + . S HIT=0,CURCPTS=$P(MAGGRY(1),U) + . F Q:CURCPTS="" S CURCPTX=$O(^MAG(2006.65,"B",$P(CURCPTS,","),"")) S CURCPTS=$P(CURCPTS,",",2,9) I CURCPTX]"" D Q:HIT ; 1st hit only + .. ; This algorithm checks from lowest detail to most general, and acts + .. ; on the information found at the FIRST Hit only + .. F CPT="CPT5","CPT4","CPT3" S CPT=@CPT I CPT]"",$D(^MAG(2006.65,CURCPTX,1,"B",CPT)) S X=$O(^(CPT,"")) D S HIT=1 Q ;1st hit only + ... S X=^MAG(2006.65,CURCPTX,1,X,0) S Y=$S(ACTION="A":2,1:5),X=$P(X,U,Y,Y+2) + ... I +X S MAGMATCH=CPT F I=2,3 S $P(MAGMATCH,U,I)=$P(X,U,I) + ; sample of logic file: + ; ^MAG(2006.65,1,0) = 730 + ; ^MAG(2006.65,1,1,0) = ^12000011.01^2^2 + ; ^MAG(2006.65,1,1,1,0) = 730^1^40^6^1^120^10 + ; ^MAG(2006.65,1,1,2,0) = 732^1^40^2^1^120^4 + ; ^MAG(2006.65,1,1,"B",730,1) = + ; ^MAG(2006.65,1,1,"B",732,2) = + ; ^MAG(2006.65,"B",730,1) = + ; + Q:'MAGMATCH + ; 1 RADFN RADTI RACNI RANME RASSN <-- from GETEXAM + ; 6 RADATE RADTE RACN RAPRC RARPT + ; 11 RAST DAYCASE RAELOC RASTP RASTORD + ; 16 RADTPRT RACPT RAIMGTYP + S X=$P(RADATA,U,7) D H^%DTC S MAGDTH=+%H + S X=$P(RADATA,U,18) + S RAIMGTYP=$S(X]"":$O(^RA(79.2,"C",X,"")),1:X) + S Y=MAGGRY(0)+1,$P(MAGGRY(0),U)=Y,MAGGRY(Y)=MAGMATCH_U_MAGDTH_U_U_$P(RADATA,U,9)_U_RAIMGTYP_U_RADFN_U_RADTI_U_RACNI_U_RARPT_U_$P(RADATA,U,12)_U_$P(RADATA,U,11) + Q + ; +SVMAG2B ; For exams whose CPTs match, select a subset that are within defined + ; limits with respect to time interval & maximum # exams to retrieve + ; Return MAGGRY(0) = count ^ message + ; MAGGRY(1:N) = "M08" | RADFN ^ RADTI ^ RACNI ^ RARPT + N CPT,CT,CURDAT,ICPT,IREC,GO + S CURDAT=$P(MAGGRY(1),U,4) + F IREC=2:1:MAGGRY(0) S X=MAGGRY(IREC),CPT=+X D K MAGGRY(IREC) + . I $P(X,U,2) S Y=CURDAT-$P(X,U,4) S:Y<0 Y=-Y I Y>$P(X,U,2) Q ;too old + . S Y=$G(GO(CPT))+1 I CPT,(Y>$P(X,U,3)) Q ; already have enough cases + . S GO(CPT)=Y,GO(CPT,Y)=X + K MAGGRY + I $D(GO) S CT=0,CPT="" D + . F S CPT=$O(GO(CPT)) Q:CPT="" F ICPT=1:1:GO(CPT) D + .. S CT=CT+1,X=GO(CPT,ICPT),RARPT=$P(X,U,11) + .. S MAGGRY(CT)="M08^"_CPT_"|"_$P(X,U,8,11) + .. I ACTION="P"!(ACTION="A") S Y=$$JBFETCH^MAGJUTL2(RARPT) ; fetch from jukebox + . S MAGGRY(0)=CT_"^"_HDR + E S MAGGRY(0)="0^No Exams Found for "_HDR + Q + ; +END ; diff --git a/r/IMAGING-MAG-ZMAG/MAGJLS2.m b/r/IMAGING-MAG-ZMAG/MAGJLS2.m index 8a44f9b7..f0c3dcce 100644 --- a/r/IMAGING-MAG-ZMAG/MAGJLS2.m +++ b/r/IMAGING-MAG-ZMAG/MAGJLS2.m @@ -1,215 +1,220 @@ -MAGJLS2 ;WIRMFO/JHC Rad. Workstation RPC calls ; 29 Jul 2003 9:58 AM - ;;3.0;IMAGING;**22,18,76**;Jun 22, 2007;Build 19 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q - ; ACTIVE -- list exams (Unread, Recent, &/or Pending) for input Imaging Type(s) - ; RPC Call: MAGJ RADACTIVEEXAMS - ; BKGND -- EP for Bkgnd Compile of UNREAD list - ; BKGND2 -- EP for Bkgnd Compile of RECENT list - Q -BKGERR S ERRCOUNT=$G(ERRCOUNT)+1 H 3 I ERRCOUNT>2 K ZTQUEUED G ^XUSCLEAN ; prevent bkgnd loop -ERR1 I $G(LSTNAM)]"" L -^XTMP("MAGJ2","BKGND",LSTNAM,"COMPILE") - L -^XTMP("MAGJ2","BKGND2","RUN") -ERR N ERR S ERR=$$EC^%ZOSV S ^TMP($J,"RET",0)="0^4~"_ERR - S MAGGRY=$NA(^TMP($J,"RET")) - D @^%ZOSF("ERRTN") - Q:$Q 1 Q -ACTIVE(MAGGRY,DATA) ; EP--get Active (Unread/Recent/Pend) Exam Lists - ; MAGGRY holds $NA ref to ^TMP where return msg is assembled - ; all refs to MAGGRY use SS indirection - ; If not use bkgnd, compile in foregnd - ; - N BKGND,COMPFAIL,MAGLST,LSTPARAM,LSTREQ,LSTID,LSTNUM,LSTNAM,NEWLIST - N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGJLS2" - S X=$P(DATA,U) D PARAMS^MAGJLS2B(X) - I 'LSTID S MAGGRY=$NA(^TMP($J,"RET")),@MAGGRY@(0)="0^4~Problem with Exams List Compile--"_DATA_"." Q - I MAGJOB("P32"),+$G(MAGJOB("P32STOP")) S MAGGRY=$NA(^TMP($J,"RET")),@MAGGRY@(0)="0^4~VistARad Patch 32 is no longer supported. Contact Imaging support for the current version of the VistARad client software." Q ; <*> - I BKGND,LSTREQ="U" D BKREQU Q ; UNREAD in bkgnd - I BKGND,LSTREQ="R" D BKREQR Q ; RECENT in bkgnd - I BKGND,LSTREQ="A" D BKREQA(DATA) Q ; ALL Active Exams - D FOREGND ; other list types, or bkgnd compile not enabled -ACTIVEZ Q - ; -FOREGND ; compile in foregnd - I LSTREQ="H" G HISTORY - D BLDACTV^MAGJLS3(.MAGLST,LSTPARAM) - D LSTOUT^MAGJLS2B(.MAGGRY,LSTID,MAGLST) K @MAGLST - Q - ; -HISTORY ; compile History list - D BLDACTV^MAGJLS3(.MAGLST,LSTPARAM) - D LSTOUT^MAGJLS2B(.MAGGRY,LSTID,MAGLST) - ; copy data from above compile into History file - N EXID,HISTIEN,IEN,REC1,REC2,CDAT,TMP,PC - I +$G(@MAGLST@(0,1)) D - . S IEN="" F S IEN=$O(@MAGLST@(IEN)) Q:(IEN="") S REC1=^(IEN,1),REC2=^(2) D - . . I IEN=0 S ^XTMP("MAGJ2","HISTORY",DUZ,DUZ(2),IEN,1)=REC1,^(2)=REC2 Q ; header string - . . S HISTIEN=+$P(REC2,"|",3) Q:'HISTIEN S EXID=$P(REC2,"|",2) - . . S X=$G(^XTMP("MAGJ2","HISTORY",DUZ,DUZ(2),0,"ADD",HISTIEN)) - . . I X]"" D - . . . I EXID'=$P(X,"|",2) Q - . . . ; copy Client data into list column fields 12-15 in node 2 - . . . S CDAT=$P(REC2,"|",3),TMP=$P(REC2,"|") - . . . F I=1:1:4 S PC=11+I,$P(TMP,U,PC)=$P(CDAT,U,I) - . . . S TMP=TMP_U ; pad extra nil piece - . . . S $P(REC2,"|")=TMP,$P(REC2,"|",3)=HISTIEN ; preserve IEN in PP3 - . . . S ^XTMP("MAGJ2","HISTORY",DUZ,DUZ(2),HISTIEN,1)=REC1,^(2)=REC2 - . . . K ^XTMP("MAGJ2","HISTORY",DUZ,DUZ(2),0,"ADD",HISTIEN) ; Kill input node - K @MAGLST - Q - ; -BKREQU ; UNREAD exams from bkgnd - L +^XTMP("MAGJ2","BKGND2","RUN"):0 - E D BKOUT("UNREAD") Q ; bkgnd process IS running - ; NOT running, so start it! - ; 2nd errtrap is to deal with locks if error occurs - N $ETRAP,$ESTACK S $ETRAP="D ERR1^MAGJLS2" - N ZTDESC,ZTDTH,ZTIO,ZTRTN - S ZTRTN="BKGND^MAGJLS2",ZTDESC="IMAGING VistaRad UNREAD List Compile" - S ZTDTH=$H,ZTIO="" D ^%ZTLOAD - S X=$$CURLIST(LSTNAM),LSTAGE=$P(X,U,2),LSTNUM=+X - I LSTAGE>(DELTA+300) S BKGPROC=2 D ; Foregnd compile if need fresh list - . D LSTCOMP(.COMPFAIL) K BKGPROC S X=$$CURLIST(LSTNAM),LSTAGE=$P(X,U,2),LSTNUM=+X - L -^XTMP("MAGJ2","BKGND2","RUN") - I +$G(COMPFAIL) S MAGGRY=$NA(^TMP($J,"RET")),@MAGGRY@(0)="0^4~Unable to Compile Unread Exams list" - E D LSTOUT^MAGJLS2B(.MAGGRY,LSTID,$NA(^XTMP("MAGJ2",LSTNAM,LSTNUM)),LSTAGE) - K LSTAGE - Q - ; -BKREQR ; Recent Exams from bkgnd - D BKOUT("RECENT") - Q - ; -BKOUT(LSTNM) ; output list from the bkgnd process - S X=$$CURLIST(LSTNAM),LSTAGE=$P(X,U,2),LSTNUM=+X - I 'LSTNUM S MAGGRY=$NA(^TMP($J,"RET")),@MAGGRY@(0)="0^4~Problem with "_LSTNM_" List Compile program (age="_LSTAGE_" for "_LSTNAM_")"_$S(LSTNAM["9992":"--May need to Schedule RECENT List Compile in TaskMan.",1:"") - E D LSTOUT^MAGJLS2B(.MAGGRY,LSTID,$NA(^XTMP("MAGJ2",LSTNAM,LSTNUM)),LSTAGE) - K LSTAGE - Q - ; -BKREQA(DATA) ; ALL Active from Bkgnd - ; Copy compiles of Unread & Recent to a scratch global, & call lstout - N ALLGO,CNT,GETLST,ICNT,REPLY - S ALLGO=1,CNT=0 - F GETLST=9991,9992 D I 'ALLGO S REPLY="Component List "_GETLST_ALLGO Q - . D PARAMS^MAGJLS2B(GETLST) I 'LSTID S ALLGO=" not properly defined." Q - . S X=$$CURLIST(LSTNAM),LSTAGE=$P(X,U,2),LSTNUM=+X - . I 'LSTNUM S ALLGO=" needs more time to compile." Q - . F ICNT=1:1:$G(^XTMP("MAGJ2",LSTNAM,LSTNUM,0,1)) S X=^XTMP("MAGJ2",LSTNAM,LSTNUM,ICNT,1),Y=^(2),CNT=CNT+1,^TMP($J,"MAGJ",CNT,1)=X,^(2)=Y - I ALLGO D - . S ^TMP($J,"MAGJ",0,1)=CNT_U_"1~ALL Active Exams",^(2)="" - . D PARAMS^MAGJLS2B($P(DATA,U)) - . D LSTOUT^MAGJLS2B(.MAGGRY,LSTID,$NA(^TMP($J,"MAGJ"))) - I 'ALLGO S MAGGRY=$NA(^TMP($J,"RET")),@MAGGRY@(0)="0^4~Problem with ALL Exams List Compile "_DATA_". "_REPLY - K LSTAGE - Q - ; -BKGND ; EP for background compile of UNREAD exams - L +^XTMP("MAGJ2","BKGND2","RUN"):600 ; allow fgnd job to finish compile - E Q ; I must already be running! - N BKGLSTID S BKGLSTID=9991 G BKGNDA - Q -BKGND2 ; EP--bkgnd compile RECENT - N BKGLSTID S BKGLSTID=9992 G BKGNDA - Q -BKGNDA S BKGPROC=1,U="^" - N $ETRAP,$ESTACK S $ETRAP="D BKGERR^MAGJLS2" - D MAGJOBNC^MAGJUTL3 - D PARAMS^MAGJLS2B(BKGLSTID) -BKLOOP ; Loop & compile "master" UNREAD List only - S BKLOOP=$G(BKLOOP)+1 - I BKLOOP>1 D PARAMS^MAGJLS2B(9991) - I 'LSTID D G BKGNDZ - . S X="0^4~Problem with BACKGROUND Compile of Exams List" - . F I=1,2 K ^XTMP("MAGJ2",LSTNAM,I) - . F I=1,2 S ^XTMP("MAGJ2",LSTNAM,I,0,1)=X,^(2)="" ; get msg to WS user - I 'BKGND G BKGNDZ ; need this to cover for excessive time to compile - S X=$$CURLIST(LSTNAM),LSTAGE=$P(X,U,2),LSTNUM=+X - I LSTREQ="U",(LSTAGE(DELTA+EXTRATIM) S $P(RET,U)="" ; Something's wrong w/ compile; force error message -CURLISZ Q RET - ; -DELTA(X,Y) ; calc # secs bet 2 $h values; dflt 2nd value = now - ; useful limit is one day - I $G(Y)="" S Y=$H - I +Y=+X - E D - . I Y-X=1 S $P(Y,",",2)=86400+$P(Y,",",2) ; midnight boundary - . E S $P(X,",",2)=0,$P(Y,",",2)=86400 ; > one day - Q ($P(Y,",",2)-$P(X,",",2)) - ; -END ; +MAGJLS2 ;WIRMFO/JHC Rad. Workstation RPC calls ; 29 Jul 2003 9:58 AM + ;;3.0;IMAGING;**22,18**;Mar 07, 2006 + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q + ; ACTIVE -- list exams (Unread, Recent, &/or Pending) for input Imaging Type(s) + ; RPC Call: MAGJ RADACTIVEEXAMS + ; BKGND -- EP for Bkgnd Compile of UNREAD list + ; BKGND2 -- EP for Bkgnd Compile of RECENT list + Q +BKGERR S ERRCOUNT=$G(ERRCOUNT)+1 H 3 I ERRCOUNT>2 K ZTQUEUED G ^XUSCLEAN ; prevent bkgnd loop +ERR1 I $G(LSTNAM)]"" L -^XTMP("MAGJ2","BKGND",LSTNAM,"COMPILE") + L -^XTMP("MAGJ2","BKGND2","RUN") +ERR N ERR S ERR=$$EC^%ZOSV S ^TMP($J,"RET",0)="0^4~"_ERR + S MAGGRY=$NA(^TMP($J,"RET")) + D @^%ZOSF("ERRTN") + Q:$Q 1 Q +ACTIVE(MAGGRY,DATA) ; EP--get Active (Unread/Recent/Pend) Exam Lists + ; MAGGRY holds $NA ref to ^TMP where return msg is assembled + ; all refs to MAGGRY use SS indirection + ; If not use bkgnd, compile in foregnd + ; + N BKGND,COMPFAIL,MAGLST,LSTPARAM,LSTREQ,LSTID,LSTNUM,LSTNAM,NEWLIST + N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGJLS2" + S X=$P(DATA,U) D PARAMS^MAGJLS2B(X) + I 'LSTID S MAGGRY=$NA(^TMP($J,"RET")),@MAGGRY@(0)="0^4~Problem with Exams List Compile--"_DATA_"." Q + I BKGND,LSTREQ="U" D BKREQU Q ; UNREAD in bkgnd + I BKGND,LSTREQ="R" D BKREQR Q ; RECENT in bkgnd + I BKGND,LSTREQ="A" D BKREQA(DATA) Q ; ALL Active Exams + D FOREGND ; other list types, or bkgnd compile not enabled +ACTIVEZ Q + ; +FOREGND ; compile in foregnd + I LSTREQ="H" G HISTORY + D BLDACTV^MAGJLS3(.MAGLST,LSTPARAM) + D LSTOUT^MAGJLS2B(.MAGGRY,LSTID,MAGLST) K @MAGLST + Q + ; +HISTORY ; compile History list + D BLDACTV^MAGJLS3(.MAGLST,LSTPARAM) + D LSTOUT^MAGJLS2B(.MAGGRY,LSTID,MAGLST) + ; copy data from above compile into History file + N EXID,HISTIEN,IEN,REC1,REC2,CDAT,TMP,PC + I +$G(@MAGLST@(0,1)) D + . S IEN="" F S IEN=$O(@MAGLST@(IEN)) Q:(IEN="") S REC1=^(IEN,1),REC2=^(2) D + . . I IEN=0 S ^XTMP("MAGJ2","HISTORY",DUZ,DUZ(2),IEN,1)=REC1,^(2)=REC2 Q ; header string + . . S HISTIEN=+$P(REC2,"|",3) Q:'HISTIEN S EXID=$P(REC2,"|",2) + . . S X=$G(^XTMP("MAGJ2","HISTORY",DUZ,DUZ(2),0,"ADD",HISTIEN)) + . . I X]"" D + . . . I EXID'=$P(X,"|",2) Q + . . . ; copy Client data into list column fields 12-15 in node 2 + . . . S CDAT=$P(REC2,"|",3),TMP=$P(REC2,"|") + . . . F I=1:1:4 S PC=11+I,$P(TMP,U,PC)=$P(CDAT,U,I) + . . . S TMP=TMP_U ; pad extra nil piece + . . . S $P(REC2,"|")=TMP,$P(REC2,"|",3)=HISTIEN ; preserve IEN in PP3 + . . . S ^XTMP("MAGJ2","HISTORY",DUZ,DUZ(2),HISTIEN,1)=REC1,^(2)=REC2 + . . . K ^XTMP("MAGJ2","HISTORY",DUZ,DUZ(2),0,"ADD",HISTIEN) ; Kill input node + K @MAGLST + Q + ; +BKREQU ; UNREAD exams from bkgnd + L +^XTMP("MAGJ2","BKGND2","RUN"):0 + E D BKOUT("UNREAD") Q ; bkgnd process IS running + ; NOT running, so start it! + ; 2nd errtrap is to deal with locks if error occurs + N $ETRAP,$ESTACK S $ETRAP="D ERR1^MAGJLS2" + N ZTDESC,ZTDTH,ZTIO,ZTRTN + S ZTRTN="BKGND^MAGJLS2",ZTDESC="IMAGING VistaRad UNREAD List Compile" + S ZTDTH=$H,ZTIO="" D ^%ZTLOAD + S X=$$CURLIST(LSTNAM),LSTAGE=$P(X,U,2),LSTNUM=+X + I LSTAGE>(DELTA+300) S BKGPROC=2 D ; Foregnd compile if need fresh list + . D LSTCOMP(.COMPFAIL) K BKGPROC S X=$$CURLIST(LSTNAM),LSTAGE=$P(X,U,2),LSTNUM=+X + L -^XTMP("MAGJ2","BKGND2","RUN") + I +$G(COMPFAIL) S MAGGRY=$NA(^TMP($J,"RET")),@MAGGRY@(0)="0^4~Unable to Compile Unread Exams list" + E D LSTOUT^MAGJLS2B(.MAGGRY,LSTID,$NA(^XTMP("MAGJ2",LSTNAM,LSTNUM)),LSTAGE) + Q + ; +BKREQR ; Recent Exams from bkgnd + D BKOUT("RECENT") + Q + ; +BKOUT(LSTNM) ; output list from the bkgnd process + S X=$$CURLIST(LSTNAM),LSTAGE=$P(X,U,2),LSTNUM=+X + I 'LSTNUM S MAGGRY=$NA(^TMP($J,"RET")),@MAGGRY@(0)="0^4~Problem with "_LSTNM_" List Compile program (age="_LSTAGE_" for "_LSTNAM_")"_$S(LSTNAM["9992":"--May need to Schedule RECENT List Compile in TaskMan.",1:"") + E D LSTOUT^MAGJLS2B(.MAGGRY,LSTID,$NA(^XTMP("MAGJ2",LSTNAM,LSTNUM)),LSTAGE) + Q + ; +BKREQA(DATA) ; ALL Active from Bkgnd + ; Copy compiles of Unread & Recent to a scratch global, & call lstout + N ALLGO,CNT,GETLST,ICNT,REPLY + S ALLGO=1,CNT=0 + F GETLST=9991,9992 D I 'ALLGO S REPLY="Component List "_GETLST_ALLGO Q + . D PARAMS^MAGJLS2B(GETLST) I 'LSTID S ALLGO=" not properly defined." Q + . S X=$$CURLIST(LSTNAM),LSTAGE=$P(X,U,2),LSTNUM=+X + . I 'LSTNUM S ALLGO=" needs more time to compile." Q + . F ICNT=1:1:$G(^XTMP("MAGJ2",LSTNAM,LSTNUM,0,1)) S X=^XTMP("MAGJ2",LSTNAM,LSTNUM,ICNT,1),Y=^(2),CNT=CNT+1,^TMP($J,"MAGJ",CNT,1)=X,^(2)=Y + I ALLGO D + . S ^TMP($J,"MAGJ",0,1)=CNT_U_"1~ALL Active Exams",^(2)="" + . D PARAMS^MAGJLS2B($P(DATA,U)) + . D LSTOUT^MAGJLS2B(.MAGGRY,LSTID,$NA(^TMP($J,"MAGJ"))) + I 'ALLGO S MAGGRY=$NA(^TMP($J,"RET")),@MAGGRY@(0)="0^4~Problem with ALL Exams List Compile "_DATA_". "_REPLY + Q + ; +BKGND ; EP for background compile of UNREAD exams + L +^XTMP("MAGJ2","BKGND2","RUN"):600 ; allow fgnd job to finish compile + E Q ; I must already be running! + N BKGLSTID S BKGLSTID=9991 G BKGNDA + Q +BKGND2 ; EP--bkgnd compile RECENT + N BKGLSTID S BKGLSTID=9992 G BKGNDA + Q +BKGNDA S BKGPROC=1,U="^" + N $ETRAP,$ESTACK S $ETRAP="D BKGERR^MAGJLS2" + D MAGJOBNC^MAGJUTL3 + D PARAMS^MAGJLS2B(BKGLSTID) +BKLOOP ; Loop & compile "master" UNREAD List only + S BKLOOP=$G(BKLOOP)+1 + I BKLOOP>1 D PARAMS^MAGJLS2B(9991) + I 'LSTID D G BKGNDZ + . S X="0^4~Problem with BACKGROUND Compile of Exams List" + . F I=1,2 K ^XTMP("MAGJ2",LSTNAM,I) + . F I=1,2 S ^XTMP("MAGJ2",LSTNAM,I,0,1)=X,^(2)="" ; get msg to WS user + I 'BKGND G BKGNDZ ; need this to cover for excessive time to compile + S X=$$CURLIST(LSTNAM),LSTAGE=$P(X,U,2),LSTNUM=+X + I LSTREQ="U",(LSTAGE(DELTA+EXTRATIM) S $P(RET,U)="" ; Something's wrong w/ compile; force error message +CURLISZ Q RET + ; +DELTA(X,Y) ; calc # seconds between 2 $h values; default 2nd value = now + ; useful limit is one day + I $G(Y)="" S Y=$H + I +Y=+X + E D + . I Y-X=1 S $P(Y,",",2)=86400+$P(Y,",",2) ; cross midnight boundary + . E S $P(X,",",2)=0,$P(Y,",",2)=86400 ; more than one day + Q ($P(Y,",",2)-$P(X,",",2)) + ; +END ; diff --git a/r/IMAGING-MAG-ZMAG/MAGJLS2B.m b/r/IMAGING-MAG-ZMAG/MAGJLS2B.m index 36ed4558..4e459076 100644 --- a/r/IMAGING-MAG-ZMAG/MAGJLS2B.m +++ b/r/IMAGING-MAG-ZMAG/MAGJLS2B.m @@ -1,197 +1,190 @@ -MAGJLS2B ;WIRMFO/JHC VistARad RPC calls ; 29 Jul 2003 9:59 AM - ;;3.0;IMAGING;**16,22,18,76**;Jun 22, 2007;Build 19 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q - ; -PARAMS(X) ; Init some vars used for Exam Lists - N LASTEDIT - S LSTID=+$O(^MAG(2006.631,"C",X,"")) - I 'LSTID S LSTID="Invalid List ID" Q ; - S X=^MAG(2006.631,LSTID,0) - I '$P(X,U,6) S LSTID="LIST NOT ENABLED" Q ; - S LSTTL=$P(X,U),LSTREQ=$P(X,U,3),LSTPARAM=LSTREQ_U_$P(X,U,4),LASTEDIT=$P(X,U,5) - S LSTTL=$S(LSTREQ="U":"UNREAD",LSTREQ="R":"RECENT",LSTREQ="A":"ACTIVE",LSTREQ="P":"PENDING",LSTREQ="N":"NEWLY INTERP",LSTREQ="H":"HISTORY",1:"")_" EXAMS: "_LSTTL - I $P(LSTPARAM,U,2)="" S $P(LSTPARAM,U,2)="ALL" ; dflt All ImagingTypes - S X=$G(^MAG(2006.69,1,0)),BKGND=+$P(X,U,8),DELTA=+$P(X,U,$S(LSTREQ="U":9,1:13))*60 - I BKGND,'DELTA S DELTA=360 ;dflt Unread List compile cycle time secs - S LSTNAM="LS"_LSTID - I BKGND S LSTNAM=$S(LSTREQ="U":"LS9991",LSTREQ="R":"LS9992",LSTREQ="N":"LS9995",LSTREQ="H":"LS9996",1:LSTNAM) ; hard-code for "Master" list Bkgnd compile - Q - ; -SETVARS(LSTID) ;output control variables - D LSTVAR(LSTID),SRTVAR(LSTID),SELVAR(LSTID) - Q - ; -LSTVAR(LSTID) ; build output columns string - S MDLVAR=^MAG(2006.631,LSTID,"DEF",1),LSTHDR=^(.5) - N I,XX,SC,XOUT,XOUT2 - S SC=";",XOUT="",XOUT2="" - F I=1:1:$L(MDLVAR,U) S XX=$P(MDLVAR,U,I) D - . I +XX=12 I '$G(SNDREMOT) Q ; exclude RC ind - . I +XX=23 I '$G(SHOWPLAC) Q ; exclude PLACE - . S XOUT=XOUT_$S(XOUT="":"",1:U)_XX - . S XOUT2=XOUT2_$S(XOUT2="":"",1:U)_$P(LSTHDR,U,I) - S MDLVAR=XOUT,LSTHDR=XOUT2 - Q -SRTVAR(LSTID) ; build sort-vars string in SORTSS - ; indirection used to ref string at list output (see LSTOUT) - S MDSVAR=^MAG(2006.631,LSTID,"DEF",2) - N I,XX,XOUT,HAVEONE - S SORTSS="",XOUT="",HAVEONE=0 - F I=1:1:$L(MDSVAR,U) S XX=$P(MDSVAR,U,I) D - . I +XX=12 Q:'$G(SNDREMOT) ; exclude RC ind - . I +XX=23 I '$G(SHOWPLAC) Q ; exclude PLACE - . I 'HAVEONE S HAVEONE=(+XX=1) ; 1 = Case # - . S XOUT=XOUT_$S(XOUT="":"",1:U)_XX - . S XX=$S(XX?1N.N1"-":"-",1:"")_"MD("_+XX_")" - . S SORTSS=SORTSS_","_XX - I 'HAVEONE S SORTSS=SORTSS_",MD(1)",XOUT=XOUT_U_1 ; force unique entry each exam - I $E(SORTSS)="," S SORTSS=$E(SORTSS,2,999) - S MDSVAR=XOUT - Q - ; -SELVAR(LSTID) ; build selection logic executes in DIS array - N CX,DC,DCX,DL,DLX,EXP,I,IDL,SELVAR,SELVAR2,SS - S SS=0 F S SS=$O(^MAG(2006.631,LSTID,"DEF",3,SS)) Q:'SS S DC(SS)=^(SS) - S SS=0 F I=1:1 S SS=$O(^MAG(2006.631,LSTID,"DEF",4,SS)) Q:'SS S DL(I)=^(SS) - ; DL(5)="^2^3'^" 1 D - . . . S X=RESULT(1),WHO=$P(X,U,5) - . . . I WHO]"" S MYLOCK=+X - . . . E D - . . . . S X=RESULT(2),WHO=$P(X,U,5) - . . . . I WHO]"" S WHO=WHO_":R",MYLOCK=+X I MYLOCK S MYLOCK=2 - S XX=WHO_U_MYLOCK - Q:$Q XX Q - ; -SHOWPLAC(X) ; return list of places to show: all defined places NOT equal to user's logon place - N IEN,SHOWPLAC S SHOWPLAC="" - S IEN=0 F S IEN=$O(^MAG(2006.1,IEN)) Q:'IEN I IEN'=+MAGJOB("SITEP") S X=$P(^(IEN,0),U,9) I X]"" S SHOWPLAC=SHOWPLAC_","_X - I SHOWPLAC]"" S SHOWPLAC=1_U_SHOWPLAC_"," ; 1 for true - Q SHOWPLAC - ; -LSTOUT(MAGGRY,LSTID,MAGLST,LSTAGE) ; Build output list, w/ sort & selection - ; Input: LSTID=List def'n - ; MAGLST=Indirect global ref for input records; all reads use subscript indirection - ; the nodes in @MAGLST contain: - ; - ; Node 1 corresponds to IENs 1:17 from Data Elements dic: - ; Acn# ^ Ex LOCK ^ PtName ^ Pt_ID ^ Priority ^ Proc ^ Img Date/Time ^ Status ^ # Images ^ Online? - ; Img Loc'n ^ Remote Ind. ^ Images Exist? ^ Img Date/Time-sortable ^ Mdl ^ Status/Internal ^ ImgTypABB - ; Node 2-- IEN's 18:28 from Data Elements dic: - ; REQLOCAbb ^ REQLOCNm ^ Interp Rad'ists ^ Last4 SSN ^ Division ^ Site ^ Rist Is Me? ^ ProcMod ^ REQLOCTyp ^ CPT - ; WARD - ; Node 2 then appends 3 pipe-delim pieces that are passed through from list compiler (See svmag2a^magjls3) - ; - ; Output: MAGGRY=Indirect ref to output file - ; - N DIS,MDCVAR,SNDREMOT,ILST,IMD,MAGRACNT - N RARPT,RAST,RADFN,RACNI,RADTI,T,WHOLOCK,XX,MYLOCK,DAYCASE,MODALITY - N OUT,QX,SORT,SORTSS,LSTHDR,MD,MDLVAR,MDSVAR,REMONLY,REMOTCAS,SHOWPLAC,SORTLEN - S LSTAGE=$G(LSTAGE) - S SHOWPLAC=$$SHOWPLAC("") ; Show any Place (Site Code) that is NOT the Login Place - S REMONLY=0 - S XX=$G(^MAG(2006.69,1,0)),SNDREMOT=+$P(XX,U,11) - I $G(MAGJOB("REMOTE")) D ; show remote cache only? - . I MAGJOB("P32") S REMONLY=+$P(XX,U,10) - . E Q:(LSTREQ="H") S REMONLY=+$G(MAGJOB("REMOTESCREEN")) ; Hist list - D SETVARS(LSTID) - S MAGRACNT=0 - S SORT="^TMP("_$J_",""MAGJSORT""",SORTLEN=$L(SORT) K ^TMP($J,"MAGJSORT") - K ^TMP($J,"RET") S ^TMP($J,"RET",0)="0^4~Getting Exam List" - S X=$G(@MAGLST@(0,1)) I +X<1 D G LSTOUTZ ; No exams to list! - . I X="" S ^TMP($J,"RET",0)="0^4~Problem with Exams List Compile" - . E S ^TMP($J,"RET",0)=X - S ILST=0 - F S ILST=$O(@MAGLST@(ILST)) Q:'ILST S XX=^(ILST,1),XX2=^(2) K MD D ; contents described above - . S XX=XX_U_$P(XX2,"|"),$P(XX2,"|")="" - . ; Execute Selection logic - . S X=0 F S X=$O(MDCVAR(X)) Q:'X S MD(X)=$P(XX,U,X) ; load needed data - . I 1 F I=1:1:$G(DIS(0)) X DIS(I) I Q ; quit if search logic True - . E Q ; failed selection criteria--skip - . S RAST=$P(XX,U,16) - . S T=$P(XX2,"|",2),RADFN=$P(T,U),RADTI=$P(T,U,2),RACNI=$P(T,U,3),RARPT=$P(T,U,4) - . I LSTREQ="U",'$D(^RADPT("AS",RAST,RADFN,RADTI,RACNI)) Q ; No longer Unread! - . I LSTREQ="U",$G(MAGJOB("CONSOLIDATED")) S RADIV=$P(XX,U,22) I RADIV]"",'$D(MAGJOB("DIVSCRN",RADIV)) Q ; Screen Unread exams for DIVision - . S REMOTCAS=$P(XX,U,12) - . I REMONLY,'REMOTCAS Q ; don't show if not routed - . I REMONLY,REMOTCAS D I 'T Q ; don't show if not the remote reading site - . . F I=1:1:$L(REMOTCAS,",")+1 S T=$P(REMOTCAS,",",I) I T,$D(MAGJOB("LOC",T)) Q - . ; set up sort values, creating sort index w/ indirect reference to sort global - . F I=1:1:$L(MDSVAR,U) S X=+$P(MDSVAR,U,I) S MD(X)=$P(XX,U,X) I MD(X)="" S MD(X)="~" - . I LSTREQ="H" S @(SORT_",ILST,"_SORTSS_")")=ILST_U_RARPT ; P18 adds ILST so History List can allow mult entries of same exam, in fifo order - . E S @(SORT_","_SORTSS_")")=ILST_U_RARPT - . S MAGRACNT=MAGRACNT+1 - I 'MAGRACNT S ^TMP($J,"RET",0)="0^2~No Exams Found" - E D ; generate output file - . S @(SORT_","_-9999999999_")")=0,QX=SORT_")" ; define $Query var.; init beginning w/ dummy entry - . ; proceed thru sort index until the string contained in SORT is not present - . ; get data w/ indirect refs to the stored data - . F ILST=0:1 S QX=$Q(@QX) Q:($E(QX,1,SORTLEN))'=SORT S XX=@MAGLST@(+(@QX),1),XX2=^(2),OUT="" D - .. I 'ILST D Q ; Header string - ... S T="" I LSTAGE?1N.N S T=LSTAGE\60 S T=" (List age: "_$S(T:T_" min, ",1:"")_(LSTAGE#60)_" sec)" - ... I +$P(XX,U,2)=1 S $P(XX,"~",2)=LSTTL_T ; List Title - ... S ^TMP($J,"RET",0)=XX - .. S XX=XX_U_$P(XX2,"|"),$P(XX2,"|")="" - .. S RARPT=$P(@QX,U,2),DAYCASE=$P(XX,U) - .. S T=$$CHKLOCK(RARPT,DAYCASE),WHOLOCK=$P(T,U),MYLOCK=$P(T,U,2) - .. S $P(XX,U,2)=WHOLOCK - .. S MODALITY=$P(XX,U,15) - .. F IMD=1:1:$L(MDLVAR,U) S X=$P(MDLVAR,U,IMD),MD=$P(XX,U,+X) D - ... I +X=12,(MD]""),SNDREMOT D - .... ; if site routes images, disp Remote Cache ind. - .... N I,T S T="" F I=1:1:$L(MD,",") S T=T_$S(T="":"",1:",")_$P($G(^MAG(2005.2,$P(MD,",",I),3)),U,5) - .... S MD=T - ... I +X=23,(MD]""),SHOWPLAC D - .... I SHOWPLAC'[(","_MD_",") S MD="" ; Don't show user's local place - ... I +X=22,(MD]""),$G(MAGJOB("CONSOLIDATED")) D - .... I '$D(MAGJOB("DIVSCRN",MD)) S MD="" ; Don't show user's local Div - ... I X[";" S T=+$P(X,";",2) I T S MD=$E(MD,1,T) ; truncate output col - ... S $P(OUT,U,IMD)=MD - .. S $P(OUT,U,IMD+1)="",OUT=U_OUT,OUT=OUT_"|"_$P(XX2,"|",2,9) - .. I WHOLOCK]"" S T=$P(OUT,"|",4),$P(T,U,2)=WHOLOCK,$P(T,U,3)=MYLOCK,$P(OUT,"|",4)=T ; pass lock info to Client - .. ; * Note: Keep Pipe piece 4, above, in sync with svmag2a^magjls3 * - .. S ^TMP($J,"RET",ILST+1)=OUT - . S ^TMP($J,"RET",1)=U_LSTHDR - . S $P(^TMP($J,"RET",0),U)=MAGRACNT -LSTOUTZ K MAGGRY,^TMP($J,"MAGJSORT") S MAGGRY=$NA(^TMP($J,"RET")) - Q - ; -UPDR ; Add Newly Interp exams to Recent; called from magjls2 - D PARAMS(9995) - I LSTID D - . S X=$$CURLIST^MAGJLS2(LSTNAM),LSTAGE=$P(X,U,2),LSTNUM=+X - . D LSTCOMP^MAGJLS2() -UPDRZ Q - ; -END ; +MAGJLS2B ;WIRMFO/JHC VistARad RPC calls ; 29 Jul 2003 9:59 AM + ;;3.0;IMAGING;**16,22,18**;Mar 07, 2006 + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q + ; +PARAMS(X) ; Init some vars used for Exam Lists + N LASTEDIT + S LSTID=+$O(^MAG(2006.631,"C",X,"")) + I 'LSTID S LSTID="Invalid List ID" Q ; + S X=^MAG(2006.631,LSTID,0) + I '$P(X,U,6) S LSTID="LIST NOT ENABLED" Q ; + S LSTTL=$P(X,U),LSTREQ=$P(X,U,3),LSTPARAM=LSTREQ_U_$P(X,U,4),LASTEDIT=$P(X,U,5) + S LSTTL=$S(LSTREQ="U":"UNREAD",LSTREQ="R":"RECENT",LSTREQ="A":"ACTIVE",LSTREQ="P":"PENDING",LSTREQ="N":"NEWLY INTERP",LSTREQ="H":"HISTORY",1:"")_" EXAMS: "_LSTTL + I $P(LSTPARAM,U,2)="" S $P(LSTPARAM,U,2)="ALL" ; dflt All ImagingTypes + S X=$G(^MAG(2006.69,1,0)),BKGND=+$P(X,U,8),DELTA=+$P(X,U,$S(LSTREQ="U":9,1:13))*60 + I BKGND,'DELTA S DELTA=360 ;dflt Unread List compile cycle time secs + S LSTNAM="LS"_LSTID + I BKGND S LSTNAM=$S(LSTREQ="U":"LS9991",LSTREQ="R":"LS9992",LSTREQ="N":"LS9995",LSTREQ="H":"LS9996",1:LSTNAM) ; hard-code for "Master" list Bkgnd compile + Q + ; +SETVARS(LSTID) ;output control variables + D LSTVAR(LSTID),SRTVAR(LSTID),SELVAR(LSTID) + Q + ; +LSTVAR(LSTID) ; build output columns string + S MDLVAR=^MAG(2006.631,LSTID,"DEF",1),LSTHDR=^(.5) + N I,XX,SC,XOUT,XOUT2 + S SC=";",XOUT="",XOUT2="" + F I=1:1:$L(MDLVAR,U) S XX=$P(MDLVAR,U,I) D + . I +XX=12 I '$G(SNDREMOT) Q ; exclude RC ind + . I +XX=23 I '$G(SHOWPLAC) Q ; exclude PLACE + . S XOUT=XOUT_$S(XOUT="":"",1:U)_XX + . S XOUT2=XOUT2_$S(XOUT2="":"",1:U)_$P(LSTHDR,U,I) + S MDLVAR=XOUT,LSTHDR=XOUT2 + Q +SRTVAR(LSTID) ; build sort-vars string in SORTSS + ; indirection used to ref string at list output (see LSTOUT) + S MDSVAR=^MAG(2006.631,LSTID,"DEF",2) + N I,XX,XOUT,HAVEONE + S SORTSS="",XOUT="",HAVEONE=0 + F I=1:1:$L(MDSVAR,U) S XX=$P(MDSVAR,U,I) D + . I +XX=12 Q:'$G(SNDREMOT) ; exclude RC ind + . I +XX=23 I '$G(SHOWPLAC) Q ; exclude PLACE + . I 'HAVEONE S HAVEONE=(+XX=1) ; 1 = Case # + . S XOUT=XOUT_$S(XOUT="":"",1:U)_XX + . S XX=$S(XX?1N.N1"-":"-",1:"")_"MD("_+XX_")" + . S SORTSS=SORTSS_","_XX + I 'HAVEONE S SORTSS=SORTSS_",MD(1)",XOUT=XOUT_U_1 ; force unique entry each exam + I $E(SORTSS)="," S SORTSS=$E(SORTSS,2,999) + S MDSVAR=XOUT + Q + ; +SELVAR(LSTID) ; build selection logic executes in DIS array + N CX,DC,DCX,DL,DLX,EXP,I,IDL,SELVAR,SELVAR2,SS + S SS=0 F S SS=$O(^MAG(2006.631,LSTID,"DEF",3,SS)) Q:'SS S DC(SS)=^(SS) + S SS=0 F I=1:1 S SS=$O(^MAG(2006.631,LSTID,"DEF",4,SS)) Q:'SS S DL(I)=^(SS) + ; DL(5)="^2^3'^" 1 D + . . . S X=RESULT(1),WHO=$P(X,U,5) + . . . I WHO]"" S MYLOCK=+X + . . . E D + . . . . S X=RESULT(2),WHO=$P(X,U,5) + . . . . I WHO]"" S WHO=WHO_":R",MYLOCK=+X I MYLOCK S MYLOCK=2 + S XX=WHO_U_MYLOCK + Q:$Q XX Q + ; +SHOWPLAC(X) ; return list of places to show: all defined places NOT equal to user's logon place + N IEN,SHOWPLAC S SHOWPLAC="" + S IEN=0 F S IEN=$O(^MAG(2006.1,IEN)) Q:'IEN I IEN'=+MAGJOB("SITEP") S X=$P(^(IEN,0),U,9) I X]"" S SHOWPLAC=SHOWPLAC_","_X + I SHOWPLAC]"" S SHOWPLAC=1_U_SHOWPLAC_"," ; 1 for true + Q SHOWPLAC + ; +LSTOUT(MAGGRY,LSTID,MAGLST,LSTAGE) ; Build output list, w/ sort & selection + ; Input: LSTID=List def'n + ; MAGLST=Indirect global ref for input records; all reads use subscript indirection + ; the nodes in @MAGLST contain: + ; + ; Node 1 corresponds to IENs 1:17 from Data Elements dic: + ; Acn# ^ Ex LOCK ^ PtName ^ Pt_ID ^ Priority ^ Proc ^ Img Date/Time ^ Status ^ # Images ^ Online? + ; Img Loc'n ^ Remote Ind. ^ Images Exist? ^ Img Date/Time-sortable ^ Mdl ^ Status/Internal ^ ImgTypABB + ; Node 2-- IEN's 18:28 from Data Elements dic: + ; REQLOCAbb ^ REQLOCNm ^ Interp Rad'ists ^ Last4 SSN ^ Division ^ Site ^ Rist Is Me? ^ ProcMod ^ REQLOCTyp ^ CPT + ; WARD + ; Node 2 then appends 3 pipe-delim pieces that are passed through from list compiler (See svmag2a^magjls3) + ; + ; Output: MAGGRY=Indirect ref to output file + ; + N DIS,MDCVAR,SNDREMOT,ILST,IMD,MAGRACNT + N RARPT,RAST,RADFN,RACNI,RADTI,T,WHOLOCK,XX,MYLOCK,DAYCASE,MODALITY + N OUT,QX,SORT,SORTSS,LSTHDR,MD,MDLVAR,MDSVAR,REMONLY,REMOTCAS,SHOWPLAC,SORTLEN + S LSTAGE=$G(LSTAGE) + S SHOWPLAC=$$SHOWPLAC("") ; Show any Place (Site Code) that is NOT the Login Place + S REMONLY=0 + S XX=$G(^MAG(2006.69,1,0)),SNDREMOT=+$P(XX,U,11) + I $G(MAGJOB("REMOTE")) D ; show remote cache only? + . I MAGJOB("P32") S REMONLY=+$P(XX,U,10) + . E Q:(LSTREQ="H") S REMONLY=+$G(MAGJOB("REMOTESCREEN")) ; Hist list + D SETVARS(LSTID) + S MAGRACNT=0 + S SORT="^TMP("_$J_",""MAGJSORT""",SORTLEN=$L(SORT) K ^TMP($J,"MAGJSORT") + K ^TMP($J,"RET") S ^TMP($J,"RET",0)="0^4~Getting Exam List" + S X=$G(@MAGLST@(0,1)) I +X<1 D G LSTOUTZ ; No exams to list! + . I X="" S ^TMP($J,"RET",0)="0^4~Problem with Exams List Compile" + . E S ^TMP($J,"RET",0)=X + S ILST=0 + F S ILST=$O(@MAGLST@(ILST)) Q:'ILST S XX=^(ILST,1),XX2=^(2) K MD D ; contents described above + . S XX=XX_U_$P(XX2,"|"),$P(XX2,"|")="" + . ; Execute Selection logic + . S X=0 F S X=$O(MDCVAR(X)) Q:'X S MD(X)=$P(XX,U,X) ; load needed data + . I 1 F I=1:1:$G(DIS(0)) X DIS(I) I Q ; quit if search logic True + . E Q ; failed selection criteria--skip + . S RAST=$P(XX,U,16) + . S T=$P(XX2,"|",2),RADFN=$P(T,U),RADTI=$P(T,U,2),RACNI=$P(T,U,3),RARPT=$P(T,U,4) + . I LSTREQ="U",'$D(^RADPT("AS",RAST,RADFN,RADTI,RACNI)) Q ; No longer Unread! + . I LSTREQ="U",$G(MAGJOB("CONSOLIDATED")) S RADIV=$P(XX,U,22) I RADIV]"",'$D(MAGJOB("DIVSCRN",RADIV)) Q ; Screen Unread exams for DIVision + . S REMOTCAS=$P(XX,U,12) + . I REMONLY,'REMOTCAS Q ; don't show if not routed + . I REMONLY,REMOTCAS D I 'T Q ; don't show if not the remote reading site + . . F I=1:1:$L(REMOTCAS,",")+1 S T=$P(REMOTCAS,",",I) I T,$D(MAGJOB("LOC",T)) Q + . ; set up sort values, creating sort index w/ indirect reference to sort global + . F I=1:1:$L(MDSVAR,U) S X=+$P(MDSVAR,U,I) S MD(X)=$P(XX,U,X) I MD(X)="" S MD(X)="~" + . I LSTREQ="H" S @(SORT_",ILST,"_SORTSS_")")=ILST_U_RARPT ; P18 adds ILST so History List can allow mult entries of same exam, in fifo order + . E S @(SORT_","_SORTSS_")")=ILST_U_RARPT + . S MAGRACNT=MAGRACNT+1 + I 'MAGRACNT S ^TMP($J,"RET",0)="0^2~No Exams Found" + E D ; generate output file + . S @(SORT_","_-9999999999_")")=0,QX=SORT_")" ; define $Query var.; init beginning w/ dummy entry + . ; proceed thru sort index until the string contained in SORT is not present + . ; get data w/ indirect refs to the stored data + . F ILST=0:1 S QX=$Q(@QX) Q:($E(QX,1,SORTLEN))'=SORT S XX=@MAGLST@(+(@QX),1),XX2=^(2),OUT="" D + .. I 'ILST D Q ; Header string + ... S T="" I LSTAGE?1N.N S T=LSTAGE\60 S T=" (List age: "_$S(T:T_" min, ",1:"")_(LSTAGE#60)_" sec)" + ... I +$P(XX,U,2)=1 S $P(XX,"~",2)=LSTTL_T ; List Title + ... S ^TMP($J,"RET",0)=XX + .. S XX=XX_U_$P(XX2,"|"),$P(XX2,"|")="" + .. S RARPT=$P(@QX,U,2),DAYCASE=$P(XX,U) + .. S T=$$CHKLOCK(RARPT,DAYCASE),WHOLOCK=$P(T,U),MYLOCK=$P(T,U,2) + .. S $P(XX,U,2)=WHOLOCK + .. S MODALITY=$P(XX,U,15) + .. F IMD=1:1:$L(MDLVAR,U) S X=$P(MDLVAR,U,IMD),MD=$P(XX,U,+X) D + ... I +X=12,(MD]""),SNDREMOT D + .... ; if site routes images, disp Remote Cache ind. + .... N I,T S T="" F I=1:1:$L(MD,",") S T=T_$S(T="":"",1:",")_$P($G(^MAG(2005.2,$P(MD,",",I),3)),U,5) + .... S MD=T + ... I +X=23,(MD]""),SHOWPLAC D + .... I SHOWPLAC'[(","_MD_",") S MD="" ; Don't show user's local place + ... I +X=22,(MD]""),$G(MAGJOB("CONSOLIDATED")) D + .... I '$D(MAGJOB("DIVSCRN",MD)) S MD="" ; Don't show user's local Div + ... I X[";" S T=+$P(X,";",2) I T S MD=$E(MD,1,T) ; truncate output col + ... S $P(OUT,U,IMD)=MD + .. S $P(OUT,U,IMD+1)="",OUT=U_OUT,OUT=OUT_"|"_$P(XX2,"|",2,9) + .. I WHOLOCK]"" S T=$P(OUT,"|",4),$P(T,U,2)=WHOLOCK,$P(T,U,3)=MYLOCK,$P(OUT,"|",4)=T ; pass lock info to Client + .. ; * Note: Keep Pipe piece 4, above, in sync with svmag2a^magjls3 * + .. S ^TMP($J,"RET",ILST+1)=OUT + . S ^TMP($J,"RET",1)=U_LSTHDR + . S $P(^TMP($J,"RET",0),U)=MAGRACNT +LSTOUTZ K MAGGRY,^TMP($J,"MAGJSORT") S MAGGRY=$NA(^TMP($J,"RET")) + Q + ; +END Q ; + ; diff --git a/r/IMAGING-MAG-ZMAG/MAGJLS4.m b/r/IMAGING-MAG-ZMAG/MAGJLS4.m index dbdc5c90..96da64fc 100644 --- a/r/IMAGING-MAG-ZMAG/MAGJLS4.m +++ b/r/IMAGING-MAG-ZMAG/MAGJLS4.m @@ -1,158 +1,157 @@ -MAGJLS4 ;WIRMFO/JHC VistARad RPCs--History List ; 29 Jul 2003 10:00 AM - ;;3.0;IMAGING;**18,76**;Jun 22, 2007;Build 19 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q -ERR N ERR S ERR=$$EC^%ZOSV S ^TMP($J,"RET",0)="0^4~"_ERR - S MAGGRY=$NA(^TMP($J,"RET")) - D @^%ZOSF("ERRTN") - Q:$Q 1 Q - ; - ; Subroutines for Vistarad History List functions - ; Entry Points: - ; HIST -- All History List rpcs go here - ; -HIST(MAGGRY,PARAMS,DATA) ; History List RPC: MAGJ HISTORYLIST - ; PARAMS--TXID ^ TXDUZ ^ TXDIV - ; TXID: Required; designates action to take; see below - ; TXDUZ: Optional; if supplied, get data for another user (Read Only) - ; TXDIV: Optional; if supplied, get data for another division (Read Only) - ; Note: for now, TXDIV is forced to the Logon Division - ; DATA--(optional) array of input data; depends on TXID; see subroutines by TXID - ; - N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGJLS4" - N TXID,TXDUZ,TXDIV,UPDATEOK,DIQUIET,REPLY - K ^TMP($J,"RET") - S TXID=+PARAMS,TXDUZ=+$P(PARAMS,U,2),TXDIV=+$P(PARAMS,U,3) - I 'TXDUZ S TXDUZ=DUZ - S UPDATEOK=TXDUZ=DUZ - S TXDIV=DUZ(2) ; Force to Logon Division for now - S REPLY="0^1~Performing History List operation." - I 'TXID!'("1,2,3"[TXID) S REPLY="0^4~Invalid History List operation requested." G HISTZ - I '$D(DATA)&(TXID=1!TXID=3) S REPLY="0^4~No data supplied for History List update/delete." G HISTZ - I 'UPDATEOK&("1,3"[TXID) S REPLY="0^4~The current History List may not be updated by the current user." G HISTZ - S DIQUIET=1 D DT^DICRW - I TXID=1 D HISTADD(.DATA,TXDUZ,TXDIV) G HISTZ - I TXID=2 D HISTUPD(TXDUZ,TXDIV) D HISTGET(TXDUZ,TXDIV) G HISTZ - I TXID=3 D HISTDEL(.DATA,TXDUZ,TXDIV) G HISTZ - ; I TXID=4 D HISTUPD(TXDUZ,TXDIV) G HISTZ ; for now, do this function with txid 2 -HISTZ ; - I 'REPLY S MAGGRY=$NA(^TMP($J,"RET")),@MAGGRY@(0)=REPLY - E ; maggry otherwise has been set by called subroutine - Q - ; -HISTADD(DATA,TXDUZ,TXDIV) ; add records - N IDATA,ILOOP,CT,NOGO,EXID,HISDAT,HISTIEN,MAGRACNT,TS - S IDATA="",CT=0,NOGO=0 - F ILOOP=0:1 S IDATA=$O(DATA(IDATA)) Q:IDATA="" D - . S EXID=$P(DATA(IDATA),"|"),HISDAT=$P(DATA(IDATA),"|",2) - . F I=1:1:4 I '+$P(EXID,U,I) S NOGO=1 Q - . I NOGO Q - . L +^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV):2 - . E Q - . S X=$G(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,0)),HISTIEN=+$P(X,U)+1,$P(^(0),U)=HISTIEN - . L -^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV) - . S ^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,0,"ADD",HISTIEN)="|"_EXID_"|"_HISTIEN_U_HISDAT_"|" - . S CT=CT+1 - I 'CT S REPLY="0^3~"_$S(ILOOP:"Unable to add records",1:"No records to add")_" to History List." Q - S MAGRACNT=0 D ACTIVE^MAGJLS2(.MAGGRY,9996) - S X=@MAGGRY@(0),X=+X_U_"1~"_$$HISTTL(TXDUZ,TXDIV),@MAGGRY@(0)=X - S TS="" F I=2,0 S TS=TS_$S(TS="":"",1:U)_$$HTFM^XLFDT($H+I,0) - S ^XTMP("MAGJ2",0)=TS_U_"VistaRad List Compile" - S REPLY=1 - Q - ; -HISTTL(TXDUZ,TXDIV) ; Build list title string - N LSTTL - S LSTTL="HISTORY LIST for "_$$USERINF^MAGJUTL3(TXDUZ,.01)_" at "_"Station #"_$$STATN^MAGJEX1(TXDIV) - S LSTTL=LSTTL_"|"_TXDUZ ; provide report's DUZ to client - Q LSTTL - ; -HISTGET(TXDUZ,TXDIV) ; Get full History List for input user for division txdiv - N MAGLST,LSTTL,LSTID,MAGLST - S TXDUZ=$G(TXDUZ,DUZ) - S TXDIV=$G(TXDIV,DUZ(2)) - D PARAMS^MAGJLS2B(9996) - I 'LSTID S REPLY="0^4~Problem with History List Compile." Q - S LSTTL=$$HISTTL(TXDUZ,DUZ(2)) - S X=$O(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,0)) - I 'X S REPLY="0^1~No exams found for: "_LSTTL Q - S MAGLST=$NA(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV)) - D LSTOUT^MAGJLS2B(.MAGGRY,LSTID,MAGLST) - S REPLY=1 - Q - ; -HISTDEL(DATA,TXDUZ,TXDIV) ; delete records - N IDATA,CT,HISTIEN,ALLDONE,LAST - S IDATA="",CT=0,ALLDONE=0 - L +^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV):2 - E S REPLY="0^2~Unable to access HISTORY File for deleting records; try again later." Q - S MAGGRY=$NA(^TMP($J,"RET")) - F S IDATA=$O(DATA(IDATA)) Q:IDATA=""!ALLDONE D - . S HISTIEN=$P(DATA(IDATA),U) - . I HISTIEN,$D(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,HISTIEN)) K ^(HISTIEN) S CT=CT+1,@MAGGRY@(CT)=HISTIEN Q - . E I HISTIEN="ALL" S HISTIEN=0 D S ALLDONE=1 - . . F S HISTIEN=$O(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,HISTIEN)) Q:'HISTIEN K ^(HISTIEN) S CT=CT+1,@MAGGRY@(CT)=HISTIEN - I '$D(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,0,"ADD")) S X=$O(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,""),-1),^(0)=X_U_X - L -^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV) - I 'CT S REPLY="0^3~No HISTORY List records found to delete." - E S REPLY=CT_"^1~"_CT_" HISTORY List records deleted." - S @MAGGRY@(0)=REPLY - S REPLY=1 - Q - ; -HISTUPD(TXDUZ,TXDIV) ; Update selected fields in History List - N LSTTL,CT,NOHIT,RAST,STATUS,REMOTE,RIST1,RIST2,RIST,RISTISME - N EXID,HISTIEN,RARPT,RADFN,RADTI,RACNI,XX1,XX2,T,X,DELETED,HDATE - S CT=0,NOHIT=0 - S TXDUZ=$G(TXDUZ,DUZ) - S TXDIV=$G(TXDIV,DUZ(2)) - S LSTTL=$$HISTTL(TXDUZ,DUZ(2)) - S X=$O(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,0)) - I 'X S REPLY="0^1~No exams found for: "_LSTTL Q - L +^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV):2 - E S REPLY="0^2~Unable to access HISTORY File for updating records; try again later." Q - S HISTIEN=0 - F S HISTIEN=$O(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,HISTIEN)) Q:'HISTIEN S XX1=$G(^(HISTIEN,1)),XX2=$G(^(2)) D - . S EXID=$P(XX2,"|",2),RARPT=+$P(EXID,U,4),RADFN=+$P(EXID,U),RADTI=+$P(EXID,U,2),RACNI=+$P(EXID,U,3) - . ; <*> Below is for phase 1 Alpha, til have final user setting for this <*> to be removed - . ; Age limit parameter to be passed in with txid 2 rpc call; setting is on client <*> - . S HDATE=$P(XX2,U,13) D Q:DELETED - . . S DELETED=0,HDATE=$P(HDATE,"@") - . . S X=HDATE,%DT="" D ^%DT K %DT - . . I $$FMTH^XLFDT(Y,1)<($H-3) K ^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,HISTIEN) S DELETED=1 Q - . ; <*> End of temp change - . I RARPT,RADFN,RADTI,RACNI - . E S NOHIT=NOHIT+1 Q - . D IMGINFO^MAGJUTL2(RARPT,.X) S REMOTE=$P(X,U,4) - . S X=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) - . I X="" Q ; rad exam deleted - . S RAST=$P(X,U,3),RIST1=$P(X,U,12),RIST2=$P(X,U,15) - . S STATUS=$S(RAST:$P(^RA(72,RAST,0),U),1:"") - . S (RIST,RISTISME)="" - . I RIST1!RIST2 S X=$$RIST^MAGJUTL1(RIST1,RIST2),RIST=$P(X,U),RISTISME=$P(X,U,2) - . S RISTISME=$S(RISTISME:"Y",1:"N") - . S $P(XX1,U,16)=RAST,$P(XX1,U,8)=STATUS,$P(XX1,U,12)=REMOTE - . S T=$P(XX2,"|"),$P(T,U,3)=RIST,$P(T,U,7)=RISTISME,$P(XX2,"|")=T - . S ^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,HISTIEN,1)=XX1,^(2)=XX2 - . S CT=CT+1 - S X=$O(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,""),-1),^(0)=X_U_X ; <*> for phase 1 alpha only? - L -^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV) - S REPLY="0^1~HISTORY File records updated." Q - Q - ; -END Q ; +MAGJLS4 ;WIRMFO/JHC VistARad RPCs--History List ; 29 Jul 2003 10:00 AM + ;;3.0;IMAGING;**18**;Mar 07, 2006 + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q +ERR N ERR S ERR=$$EC^%ZOSV S ^TMP($J,"RET",0)="0^4~"_ERR + S MAGGRY=$NA(^TMP($J,"RET")) + D @^%ZOSF("ERRTN") + Q:$Q 1 Q + ; + ; Subroutines for Vistarad History List functions + ; Entry Points: + ; HIST -- All History List rpcs go here + ; +HIST(MAGGRY,PARAMS,DATA) ; History List RPC: MAGJ HISTORYLIST + ; PARAMS--TXID ^ TXDUZ ^ TXDIV + ; TXID: Required; designates action to take; see below + ; TXDUZ: Optional; if supplied, get data for another user (Read Only) + ; TXDIV: Optional; if supplied, get data for another division (Read Only) + ; Note: for now, TXDIV is forced to the Logon Division + ; DATA--(optional) array of input data; depends on TXID; see subroutines by TXID + ; + N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGJLS4" + N TXID,TXDUZ,TXDIV,UPDATEOK,DIQUIET,REPLY + K ^TMP($J,"RET") + S TXID=+PARAMS,TXDUZ=+$P(PARAMS,U,2),TXDIV=+$P(PARAMS,U,3) + I 'TXDUZ S TXDUZ=DUZ + S UPDATEOK=TXDUZ=DUZ + S TXDIV=DUZ(2) ; Force to Logon Division for now + S REPLY="0^1~Performing History List operation." + I 'TXID!'("1,2,3"[TXID) S REPLY="0^4~Invalid History List operation requested." G HISTZ + I '$D(DATA)&(TXID=1!TXID=3) S REPLY="0^4~No data supplied for History List update/delete." G HISTZ + I 'UPDATEOK&("1,3"[TXID) S REPLY="0^4~The current History List may not be updated by the current user." G HISTZ + S DIQUIET=1 D DT^DICRW + I TXID=1 D HISTADD(.DATA,TXDUZ,TXDIV) G HISTZ + I TXID=2 D HISTUPD(TXDUZ,TXDIV) D HISTGET(TXDUZ,TXDIV) G HISTZ + I TXID=3 D HISTDEL(.DATA,TXDUZ,TXDIV) G HISTZ + ; I TXID=4 D HISTUPD(TXDUZ,TXDIV) G HISTZ ; for now, do this function with txid 2 +HISTZ ; + I 'REPLY S MAGGRY=$NA(^TMP($J,"RET")),@MAGGRY@(0)=REPLY + E ; maggry otherwise has been set by called subroutine + Q + ; +HISTADD(DATA,TXDUZ,TXDIV) ; add records + N IDATA,ILOOP,CT,NOGO,EXID,HISDAT,HISTIEN,MAGRACNT + S IDATA="",CT=0,NOGO=0 + F ILOOP=0:1 S IDATA=$O(DATA(IDATA)) Q:IDATA="" D + . S EXID=$P(DATA(IDATA),"|"),HISDAT=$P(DATA(IDATA),"|",2) + . F I=1:1:4 I '+$P(EXID,U,I) S NOGO=1 Q + . I NOGO Q + . L +^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV):2 + . E Q + . S X=$G(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,0)),HISTIEN=+$P(X,U)+1,$P(^(0),U)=HISTIEN + . L -^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV) + . S ^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,0,"ADD",HISTIEN)="|"_EXID_"|"_HISTIEN_U_HISDAT_"|" + . S CT=CT+1 + I 'CT S REPLY="0^3~"_$S(ILOOP:"Unable to add records",1:"No records to add")_" to History List." Q + S MAGRACNT=0 D ACTIVE^MAGJLS2(.MAGGRY,9996) + S X=@MAGGRY@(0),X=+X_U_"1~"_$$HISTTL(TXDUZ,TXDIV),@MAGGRY@(0)=X + N TS S TS="" F I=2,0 S %H=$H+I D YMD^%DTC S TS=TS_$S(TS="":"",1:U)_X + S ^XTMP("MAGJ2",0)=TS_U_"VistaRad List Compile" + S REPLY=1 + Q + ; +HISTTL(TXDUZ,TXDIV) ; Build list title string + N LSTTL + S LSTTL="HISTORY LIST for "_$$USERINF^MAGJUTL3(TXDUZ,.01)_" at "_"Station #"_$$STATN^MAGJEX1(TXDIV) + S LSTTL=LSTTL_"|"_TXDUZ ; provide report's DUZ to client + Q LSTTL + ; +HISTGET(TXDUZ,TXDIV) ; Get full History List for input user for division txdiv + N MAGLST,LSTTL,LSTID,MAGLST + S TXDUZ=$G(TXDUZ,DUZ) + S TXDIV=$G(TXDIV,DUZ(2)) + D PARAMS^MAGJLS2B(9996) + I 'LSTID S REPLY="0^4~Problem with History List Compile." Q + S LSTTL=$$HISTTL(TXDUZ,DUZ(2)) + S X=$O(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,0)) + I 'X S REPLY="0^1~No exams found for: "_LSTTL Q + S MAGLST=$NA(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV)) + D LSTOUT^MAGJLS2B(.MAGGRY,LSTID,MAGLST) + S REPLY=1 + Q + ; +HISTDEL(DATA,TXDUZ,TXDIV) ; delete records + N IDATA,CT,HISTIEN,ALLDONE,LAST + S IDATA="",CT=0,ALLDONE=0 + L +^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV):2 + E S REPLY="0^2~Unable to access HISTORY File for deleting records; try again later." Q + S MAGGRY=$NA(^TMP($J,"RET")) + F S IDATA=$O(DATA(IDATA)) Q:IDATA=""!ALLDONE D + . S HISTIEN=$P(DATA(IDATA),U) + . I HISTIEN,$D(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,HISTIEN)) K ^(HISTIEN) S CT=CT+1,@MAGGRY@(CT)=HISTIEN Q + . E I HISTIEN="ALL" S HISTIEN=0 D S ALLDONE=1 + . . F S HISTIEN=$O(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,HISTIEN)) Q:'HISTIEN K ^(HISTIEN) S CT=CT+1,@MAGGRY@(CT)=HISTIEN + I '$D(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,0,"ADD")) S X=$O(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,""),-1),^(0)=X_U_X + L -^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV) + I 'CT S REPLY="0^3~No HISTORY List records found to delete." + E S REPLY=CT_"^1~"_CT_" HISTORY List records deleted." + S @MAGGRY@(0)=REPLY + S REPLY=1 + Q + ; +HISTUPD(TXDUZ,TXDIV) ; Update selected fields in History List + N LSTTL,CT,NOHIT,RAST,STATUS,REMOTE,RIST1,RIST2,RIST,RISTISME + N EXID,HISTIEN,RARPT,RADFN,RADTI,RACNI,XX1,XX2,T,X,DELETED,HDATE + S CT=0,NOHIT=0 + S TXDUZ=$G(TXDUZ,DUZ) + S TXDIV=$G(TXDIV,DUZ(2)) + S LSTTL=$$HISTTL(TXDUZ,DUZ(2)) + S X=$O(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,0)) + I 'X S REPLY="0^1~No exams found for: "_LSTTL Q + L +^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV):2 + E S REPLY="0^2~Unable to access HISTORY File for updating records; try again later." Q + S HISTIEN=0 + F S HISTIEN=$O(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,HISTIEN)) Q:'HISTIEN S XX1=$G(^(HISTIEN,1)),XX2=$G(^(2)) D + . S EXID=$P(XX2,"|",2),RARPT=+$P(EXID,U,4),RADFN=+$P(EXID,U),RADTI=+$P(EXID,U,2),RACNI=+$P(EXID,U,3) + . ; <*> Below is for phase 1 Alpha, til have final user setting for this <*> to be removed + . ; Age limit parameter to be passed in with txid 2 rpc call; setting is on client <*> + . S HDATE=$P(XX2,U,13) D Q:DELETED + . . S DELETED=0,HDATE=$P(HDATE,"@") + . . S X=HDATE,%DT="" D ^%DT S X=Y D H^%DTC K %DT + . . I %H<($H-3) K ^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,HISTIEN) S DELETED=1 Q + . ; <*> End of temp change + . I RARPT,RADFN,RADTI,RACNI + . E S NOHIT=NOHIT+1 Q + . D IMGINFO^MAGJUTL2(RARPT,.X) S REMOTE=$P(X,U,4) + . S X=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) + . I X="" Q ; rad exam deleted + . S RAST=$P(X,U,3),RIST1=$P(X,U,12),RIST2=$P(X,U,15) + . S STATUS=$S(RAST:$P(^RA(72,RAST,0),U),1:"") + . S (RIST,RISTISME)="" + . I RIST1!RIST2 S X=$$RIST^MAGJUTL1(RIST1,RIST2),RIST=$P(X,U),RISTISME=$P(X,U,2) + . S RISTISME=$S(RISTISME:"Y",1:"N") + . S $P(XX1,U,16)=RAST,$P(XX1,U,8)=STATUS,$P(XX1,U,12)=REMOTE + . S T=$P(XX2,"|"),$P(T,U,3)=RIST,$P(T,U,7)=RISTISME,$P(XX2,"|")=T + . S ^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,HISTIEN,1)=XX1,^(2)=XX2 + . S CT=CT+1 + S X=$O(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,""),-1),^(0)=X_U_X ; <*> for phase 1 alpha only? + L -^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV) + S REPLY="0^1~HISTORY File records updated." Q + Q + ; +END Q ; diff --git a/r/IMAGING-MAG-ZMAG/MAGJLST1.m b/r/IMAGING-MAG-ZMAG/MAGJLST1.m index b5cbaeff..fcefd765 100644 --- a/r/IMAGING-MAG-ZMAG/MAGJLST1.m +++ b/r/IMAGING-MAG-ZMAG/MAGJLST1.m @@ -1,159 +1,158 @@ -MAGJLST1 ;WIRMFO/JHC VistARad RPC calls ; 29 Jul 2003 10:01 AM - ;;3.0;IMAGING;**16,22,18,65,76**;Jun 22, 2007;Build 19 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q - ; - ; Subroutines for fetching Exam Info for Radiology Workstation - ; Exam listings: - ; PTLIST -- list subset of all exams for a patient - ; RPC Call: MAGJ PTRADEXAMS - ; PTLSTALL -- list ALL exams for a patient - ; RPC Call: MAGJ PT ALL EXAMS - ; - Q -ERR N ERR S ERR=$$EC^%ZOSV S ^TMP($J,"RET",0)="0^4~"_ERR - S MAGGRY=$NA(^TMP($J,"RET")) - D @^%ZOSF("ERRTN") - Q:$Q 1 Q - ; -PTLSTALL(MAGGRY,DATA) ; List ALL exams for a patient - ; RPC is MAGJ PT ALL EXAMS - N PARAM - I MAGJOB("P32") S PARAM="^99^999" - E S PARAM="^^^"_$P(DATA,U,2,3) - D PTLIST(.MAGGRY,$P(DATA,U)_PARAM) - Q - ; -PTLIST(MAGGRY,DATA) ; get list of exams for a patient - ; - ; MAGGRY - indirect reference to return array of exams for a patient - ; DATA - DFN ^ LIMYEARS ^ LIMEXAMS ^ BEGDT ^ ONESHOT - ; DFN--Patient's DFN - ; LIMYRS--Restrict exams up to # Years back (defunct) - ; LIMEXAMS--Restrict exams up to # of exams - ; BEGDT--Begin date for exam fetch (Patch 18 addition--see below) - ; ONESHOT--Number days back to search, in one fell swoop - ; Returns data in ^TMP($J,"MAGRAEX",0:n) - ; RPC Call: MAGJ PTRADEXAMS - ; - ; Patch 18 eliminates "Patient Exams" / "All Patient Exams" distinction. - ; It always retrieves ALL exams, but uses multiple RPC calls, so the client - ; incrementally builds the list; this is to provide all the data, but without - ; incurring any long pauses to provide the info to the user. - ; Below, the P18 code fetches RAD data in one-year chunks, and repeats - ; until over 20 exams have been processed, at which point the RPC reply - ; is posted, along with the last date processed; this value is then used for - ; a subsequent RPC call to get the next chunk of the record; etc. till all done. - ; The P32 code is re-organized, and now exits only for LIMEXAMS (ignore LimYears) - ; - N CNT,DFN,ISS,PATNAME,DIQUIET,MAGRACNT,MAGRET,REPLY,REMOTE,SNDREMOT - N DAYCASE,DIV,EXCAT,MAGDT,XX,XX2,WHOLOCK,MODALITY,MYLOCK,PLACE,ENDLOOP - N LIMEXAMS,BEGDT,SAVBEGDT,ENDDT,MORE,SHOWPLAC,RDRIST,PSSN,CPT,PARAM - N CURPRIO,STATUS,RARPT,KEY,X2,REMOTE2,ONESHOT,LIMDAYS - N IMGCNT,LRFLAG,MSG,ONL,PROCMOD,RASTCAT,RASTORD - N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGJLST1" - S DIQUIET=1 D DT^DICRW - S PARAM=$G(^MAG(2006.69,1,0)) - S SNDREMOT=+$P(PARAM,U,11) ; Site routes images remotely? - I MAGJOB("P32") D - . S LIMEXAMS=+$P(PARAM,U,15) - . S:'LIMEXAMS LIMEXAMS=999 ; default to show ALL Exams - . I $P(DATA,U,3) S LIMEXAMS=+$P(DATA,U,3) - . I LIMEXAMS<20 S LIMEXAMS=20 - . S BEGDT="" - E S BEGDT=$P(DATA,U,4),ONESHOT=$P(DATA,U,5) ; P65 chg - K MAGGRY S DFN=+DATA - S SHOWPLAC=$$SHOWPLAC^MAGJLS2B("") - S MAGRACNT=1,CNT=0 K ^TMP($J,"MAGRAEX"),^("MAGRAEX2") - S REPLY="0^4~Compiling list of Radiology Exams." - I DFN,$D(^DPT(DFN,0)) S PATNAME=$P(^(0),U),PSSN=$P(^(0),U,9) D - . S ENDLOOP=0,BEGDT=$S(+BEGDT:BEGDT,1:"") - . I MAGJOB("P32"),+$G(MAGJOB("P32STOP")) S REPLY="0^4~VistARad Patch 32 is no longer supported; contact Imaging Support for the current version of the VistARad client software." Q ; <*> - . F D Q:'MORE Q:ENDLOOP S BEGDT=MORE+1 - . . I 'BEGDT S BEGDT=DT,X2=0 - . . E S X2=-1 - . . S LIMDAYS=365,MORE=1 - . . I 'MAGJOB("P32") I ONESHOT,(ONESHOT>0) S LIMDAYS=+ONESHOT - . . S ENDDT=$$FMADD^XLFDT(BEGDT,X2) - . . S BEGDT=$$FMADD^XLFDT(ENDDT,-LIMDAYS) - . . D GETEXAM3^MAGJUTL1(DFN,BEGDT,ENDDT,.MAGRACNT,.MAGRET,.MORE) - . . I MAGJOB("P32") S ENDLOOP=(MAGRACNT>LIMEXAMS) - . . E S ENDLOOP=(MAGRACNT>20)!+ONESHOT ; For testing only, use >8 - . I 'MORE S SAVBEGDT=0 - . E S SAVBEGDT=MORE+1 ; adding 1 correctly inits value for subseqent call - . I MAGRACNT>1 D PTLOOP - E S REPLY="0^4~Invalid Radiology Patient" - I MAGRACNT<2 S:(REPLY["Compiling") REPLY="0^2~No Exams Found for "_PATNAME - I CNT!(REPLY["No Exams Found") D - . I 'MORE S MSG="ALL exams are listed." - . E S MORE=$$FMTE^XLFDT(MORE) S MSG="Patient has more exams on file." - . ; show SSN only if the user is a radiologist - . S X=+MAGJOB("USER",1) I '(X=12!(X=15)) S PSSN="" - . E S PSSN=" ("_$E(PSSN,1,3)_"-"_$E(PSSN,4,5)_"-"_$E(PSSN,6,9)_")" - . I CNT S REPLY=CNT_"^1~Radiology Exams for: "_PATNAME_PSSN_" -- "_MSG - . E S REPLY=REPLY_" -- "_MSG - . S ^TMP($J,"MAGRAEX2",1)="^Day/Case~S3~1^Lock~~2^Procedure~~6^Modifier~~25^Image Date/Time~S1~7^Status~~8^# Img~S2~9^Onl~~10"_$S($G(SNDREMOT):"^RC~~12",1:"")_$S(SHOWPLAC:"^Site~~23",1:"")_"^Mod~~15^Interp By~~20^Imaging Loc~~11^CPT~~27" - I MAGJOB("P32"),+$G(MAGJOB("P32STOP")) S ^TMP($J,"MAGRAEX2",1)="^^" - I 'MAGJOB("P32") S $P(REPLY,"|",2)=SAVBEGDT - S ^TMP($J,"MAGRAEX2",0)=REPLY - S MAGGRY=$NA(^TMP($J,"MAGRAEX2")) - K ^TMP($J,"RAE1"),^("MAGRAEX") - Q - ; -PTLOOP ; loop through exam data & package it for VRAD use - S ISS=0 - F S ISS=$O(^TMP($J,"MAGRAEX",ISS)) Q:'ISS S XX=^(ISS,1),XX2=^(2) D - . S CNT=CNT+1,RARPT=$P(XX,U,10) - . D IMGINFO^MAGJUTL2(RARPT,.Y) - . S IMGCNT=$P(Y,U),ONL=$P(Y,U,2),MAGDT=$P(Y,U,3),REMOTE=$P(Y,U,4),MODALITY=$P(Y,U,5),PLACE=$P(Y,U,6),KEY=$P(Y,U,7) - . S REMOTE2=REMOTE - . S:PLACE PLACE=$P($G(^MAG(2006.1,PLACE,0)),U,9) - . I PLACE]"",SHOWPLAC D - .. I SHOWPLAC'[(","_PLACE_",") S PLACE="" ; don't show user's logon pl ; <*> chg for p18? - . I SNDREMOT,REMOTE D - .. S T="" F I=1:1:$L(REMOTE,",") S T=T_$S(T="":"",1:",")_$P($G(^MAG(2005.2,$P(REMOTE,",",I),3)),U,5) - .. S REMOTE=T - . S DIV="",X=$P(XX2,U,5) I X'=DUZ(2) S DIV=$$STATN(X) - . I MAGDT="" S MAGDT=$P(XX,U,7) - . S MAGDT=$$FMTE^XLFDT(MAGDT,"5Z") - . S WHOLOCK=RARPT,MYLOCK="",DAYCASE=$P(XX,U,12) - . I WHOLOCK]"" S T=$$CHKLOCK^MAGJLS2B(WHOLOCK,DAYCASE),WHOLOCK=$P(T,U),MYLOCK=$P(T,U,2) - . S RDRIST=$P(XX2,U,3),PROCMOD=$P(XX2,U,8),CPT=$P(XX,U,17),RASTORD=$P(XX,U,15) - . S Y=U_DAYCASE_U_WHOLOCK_U_$E($P(XX,U,9),1,26)_U_PROCMOD_U_MAGDT_U_$E($P(XX,U,14),1,16)_U_IMGCNT_U_ONL - . I $G(SNDREMOT) S Y=Y_U_REMOTE - . S Y=Y_$S(SHOWPLAC:U_PLACE,1:"")_U_MODALITY_U_RDRIST_U_$E($P(XX,U,13),1,11)_U_CPT - . S STATUS=$P(XX,U,11),EXCAT="",CURPRIO=0,RASTCAT=$P(XX2,U,11),LRFLAG=$P(XX2,U,12) - . I STATUS]"" D - . . S EXCAT=RASTCAT - . . I RASTORD<2!(EXCAT="W")!('IMGCNT) S CURPRIO=0 ; Cancelled/Waiting/No images: Ignore exam - . . E I EXCAT="E" S CURPRIO=1 ; Examined="Current" exam - . . E S CURPRIO=2 ; must be a "prior" exam - . . I CURPRIO,'(ONL="Y") S CURPRIO=3 ; images on jukebox - . . I MAGJOB("P32"),'(EXCAT="E") S EXCAT="" Q ; P32 compat. - . . I RASTORD=9 S EXCAT="C" ; Complete - . . E I EXCAT="D"!(EXCAT="T") S EXCAT="I" ; just display one value meaning Interpreted - . S ^TMP($J,"MAGRAEX2",ISS)=Y_"^|"_$P(XX,U,1,3)_U_RARPT_"||"_EXCAT_U_WHOLOCK_U_MYLOCK_U_MODALITY_U_CPT_U_CURPRIO_U_RARPT_U_KEY_U_REMOTE2_U_LRFLAG - . ; * Note: Keep Pipe-pieces in sync with svmag2a^magjls3 & lstout^magjls2b * - Q - ; -STATN(X) ; get station #, else return input value - N T - I X]"" D GETS^DIQ(4,X,99,"E","T") S T=$G(T(4,X_",",99,"E")) I T]"" S X=T - Q X - ; -END Q ; +MAGJLST1 ;WIRMFO/JHC VistARad RPC calls ; 29 Jul 2003 10:01 AM + ;;3.0;IMAGING;**16,22,18,65**;Jul 27, 2006;Build 28 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q + ; + ; Subroutines for fetching Exam Info for Radiology Workstation + ; Exam listings: + ; PTLIST -- list subset of all exams for a patient + ; RPC Call: MAGJ PTRADEXAMS + ; PTLSTALL -- list ALL exams for a patient + ; RPC Call: MAGJ PT ALL EXAMS + ; + Q +ERR N ERR S ERR=$$EC^%ZOSV S ^TMP($J,"RET",0)="0^4~"_ERR + S MAGGRY=$NA(^TMP($J,"RET")) + D @^%ZOSF("ERRTN") + Q:$Q 1 Q + ; +PTLSTALL(MAGGRY,DATA) ; List ALL exams for a patient + ; RPC is MAGJ PT ALL EXAMS + N PARAM + I MAGJOB("P32") S PARAM="^99^999" + E S PARAM="^^^"_$P(DATA,U,2,3) + D PTLIST(.MAGGRY,$P(DATA,U)_PARAM) + Q + ; +PTLIST(MAGGRY,DATA) ; get list of exams for a patient + ; + ; MAGGRY - indirect reference to return array of exams for a patient + ; DATA - DFN ^ LIMYEARS ^ LIMEXAMS ^ BEGDT + ; DFN--Patient's DFN + ; LIMYRS--Restrict exams up to # Years back + ; LIMEXAMS--Restrict exams up to # of exams + ; BEGDT--Begin date for exam fetch (Patch 18 addition--see below) + ; Returns data in ^TMP($J,"MAGRAEX",0:n) + ; RPC Call: MAGJ PTRADEXAMS + ; + ; Patch 18 eliminates "Patient Exams" / "All Patient Exams" distinction. + ; It always retrieves ALL exams, but uses multiple RPC calls, so the client + ; incrementally builds the list; this is to provide all the data, but without + ; incurring any long pauses to provide the info to the user. + ; Below, the P18 code fetches RAD data in one-year chunks, and repeats + ; until over 20 exams have been processed, at which point the RPC reply + ; is posted, along with the last date processed; this value is then used for + ; a subsequent RPC call to get the next chunk of the record; etc. till all done. + ; The P32 code is re-organized, and now exits only for LIMEXAMS (ignore LimYears) + ; + N CNT,DFN,ISS,PATNAME,DIQUIET,MAGRACNT,MAGRET,REPLY,REMOTE,SNDREMOT + N DAYCASE,DIV,EXCAT,MAGDT,XX,XX2,WHOLOCK,MODALITY,MYLOCK,PLACE,ENDLOOP + N LIMYRS,LIMEXAMS,BEGDT,SAVBEGDT,ENDDT,MORE,SHOWPLAC,RDRIST,PSSN,CPT,PARAM + N CURPRIO,STATUS,RARPT,KEY,X1,X2,REMOTE2,ONESHOT,LIMDAYS + N IMGCNT,LRFLAG,MSG,ONL,PROCMOD,RASTCAT,RASTORD + N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGJLST1" + S DIQUIET=1 D DT^DICRW + S PARAM=$G(^MAG(2006.69,1,0)) + S SNDREMOT=+$P(PARAM,U,11) ; Site routes images remotely? + I MAGJOB("P32") D + . S LIMEXAMS=+$P(PARAM,U,15) + . S:'LIMEXAMS LIMEXAMS=999 ; default to show ALL Exams + . I $P(DATA,U,3) S LIMEXAMS=+$P(DATA,U,3) + . I LIMEXAMS<20 S LIMEXAMS=20 + . S BEGDT="" + E S BEGDT=$P(DATA,U,4),ONESHOT=$P(DATA,U,5) ; P65 chg + K MAGGRY S DFN=+DATA + ;<*> + ; I DUZ=131 G MANYTST^ZMAGJTST ; <*> TEST ONLY !!! 37=RadRes + ;<*> + S SHOWPLAC=$$SHOWPLAC^MAGJLS2B("") + S MAGRACNT=1,CNT=0 K ^TMP($J,"MAGRAEX"),^("MAGRAEX2") + S REPLY="0^4~Compiling list of Radiology Exams." + I DFN,$D(^DPT(DFN,0)) S PATNAME=$P(^(0),U),PSSN=$P(^(0),U,9) D + . S ENDLOOP=0,BEGDT=$S(+BEGDT:BEGDT,1:"") + . F D Q:'MORE Q:ENDLOOP + . . I 'BEGDT S BEGDT=DT,X2=0 + . . E S X2=-1 + . . S LIMDAYS=365 + . . I 'MAGJOB("P32"),ONESHOT,(ONESHOT>0) S LIMDAYS=+ONESHOT + . . S X1=BEGDT D C^%DTC S (ENDDT,X1)=X,X2=-LIMDAYS D C^%DTC S BEGDT=X K %,%H,%T + . . D GETEXAM3^MAGJUTL1(DFN,BEGDT,ENDDT,.MAGRACNT,.MAGRET,.MORE) + . . I MAGJOB("P32") S ENDLOOP=(MAGRACNT>LIMEXAMS) + . . E S ENDLOOP=(MAGRACNT>20)!+ONESHOT ; For testing only, use >8 + . I 'MORE S SAVBEGDT=0 + . E S SAVBEGDT=MORE+1 ; adding 1 correctly inits value for subseqent call + . I MAGRACNT>1 D PTLOOP + E S REPLY="0^4~Invalid Radiology Patient" + I MAGRACNT<2 S:(REPLY["Compiling") REPLY="0^2~No Exams Found for "_PATNAME + I CNT!(REPLY["No Exams Found") D + . I 'MORE S MSG="ALL exams are listed." + . E S MORE=$$FMTE^XLFDT(MORE) S MSG="Patient has more exams on file." + . ; show SSN only if the user is a radiologist + . S X=+MAGJOB("USER",1) I '(X=12!(X=15)) S PSSN="" + . E S PSSN=" ("_$E(PSSN,1,3)_"-"_$E(PSSN,4,5)_"-"_$E(PSSN,6,9)_")" + . I CNT S REPLY=CNT_"^1~Radiology Exams for: "_PATNAME_PSSN_" -- "_MSG + . E S REPLY=REPLY_" -- "_MSG + . S ^TMP($J,"MAGRAEX2",1)="^Day/Case~S3~1^Lock~~2^Procedure~~6^Modifier~~25^Image Date/Time~S1~7^Status~~8^# Img~S2~9^Onl~~10"_$S($G(SNDREMOT):"^RC~~12",1:"")_$S(SHOWPLAC:"^Site~~23",1:"")_"^Mod~~15^Interp By~~20^Imaging Loc~~11^CPT~~27" + I 'MAGJOB("P32") S $P(REPLY,"|",2)=SAVBEGDT + S ^TMP($J,"MAGRAEX2",0)=REPLY + S MAGGRY=$NA(^TMP($J,"MAGRAEX2")) + K ^TMP($J,"RAE1"),^("MAGRAEX") + Q + ; +PTLOOP ; loop through exam data & package it for VRAD use + S ISS=0 + F S ISS=$O(^TMP($J,"MAGRAEX",ISS)) Q:'ISS S XX=^(ISS,1),XX2=^(2) D + . S CNT=CNT+1,RARPT=$P(XX,U,10) + . D IMGINFO^MAGJUTL2(RARPT,.Y) + . S IMGCNT=$P(Y,U),ONL=$P(Y,U,2),MAGDT=$P(Y,U,3),REMOTE=$P(Y,U,4),MODALITY=$P(Y,U,5),PLACE=$P(Y,U,6),KEY=$P(Y,U,7) + . S REMOTE2=REMOTE + . S:PLACE PLACE=$P($G(^MAG(2006.1,PLACE,0)),U,9) + . I PLACE]"",SHOWPLAC D + .. I SHOWPLAC'[(","_PLACE_",") S PLACE="" ; don't show user's logon pl ; <*> chg for p18? + . I SNDREMOT,REMOTE D + .. S T="" F I=1:1:$L(REMOTE,",") S T=T_$S(T="":"",1:",")_$P($G(^MAG(2005.2,$P(REMOTE,",",I),3)),U,5) + .. S REMOTE=T + . S DIV="",X=$P(XX2,U,5) I X'=DUZ(2) S DIV=$$STATN(X) + . I MAGDT="" S MAGDT=$P(XX,U,7) + . S MAGDT=$$FMTE^XLFDT(MAGDT,"5Z") + . S WHOLOCK=RARPT,MYLOCK="",DAYCASE=$P(XX,U,12) + . I WHOLOCK]"" S T=$$CHKLOCK^MAGJLS2B(WHOLOCK,DAYCASE),WHOLOCK=$P(T,U),MYLOCK=$P(T,U,2) + . S RDRIST=$P(XX2,U,3),PROCMOD=$P(XX2,U,8),CPT=$P(XX,U,17),RASTORD=$P(XX,U,15) + . S Y=U_DAYCASE_U_WHOLOCK_U_$E($P(XX,U,9),1,26)_U_PROCMOD_U_MAGDT_U_$E($P(XX,U,14),1,16)_U_IMGCNT_U_ONL + . I $G(SNDREMOT) S Y=Y_U_REMOTE + . S Y=Y_$S(SHOWPLAC:U_PLACE,1:"")_U_MODALITY_U_RDRIST_U_$E($P(XX,U,13),1,11)_U_CPT + . S STATUS=$P(XX,U,11),EXCAT="",CURPRIO=0,RASTCAT=$P(XX2,U,11),LRFLAG=$P(XX2,U,12) + . I STATUS]"" D + . . S EXCAT=RASTCAT + . . I RASTORD<2!(EXCAT="W")!('IMGCNT) S CURPRIO=0 ; Cancelled/Waiting/No images: Ignore exam + . . E I EXCAT="E" S CURPRIO=1 ; Examined="Current" exam + . . E S CURPRIO=2 ; must be a "prior" exam + . . I CURPRIO,'(ONL="Y") S CURPRIO=3 ; images on jukebox + . . I MAGJOB("P32"),'(EXCAT="E") S EXCAT="" Q ; P32 compat. + . . I RASTORD=9 S EXCAT="C" ; Complete + . . E I EXCAT="D"!(EXCAT="T") S EXCAT="I" ; just display one value meaning Interpreted + . S ^TMP($J,"MAGRAEX2",ISS)=Y_"^|"_$P(XX,U,1,3)_U_RARPT_"||"_EXCAT_U_WHOLOCK_U_MYLOCK_U_MODALITY_U_CPT_U_CURPRIO_U_RARPT_U_KEY_U_REMOTE2_U_LRFLAG + . ; * Note: Keep Pipe-pieces in sync with svmag2a^magjls3 & lstout^magjls2b * + Q + ; +STATN(X) ; get station #, else return input value + N T + I X]"" D GETS^DIQ(4,X,99,"E","T") S T=$G(T(4,X_",",99,"E")) I T]"" S X=T + Q X + ; +END Q ; diff --git a/r/IMAGING-MAG-ZMAG/MAGJMN1.m b/r/IMAGING-MAG-ZMAG/MAGJMN1.m index ae2f5362..77d856a2 100644 --- a/r/IMAGING-MAG-ZMAG/MAGJMN1.m +++ b/r/IMAGING-MAG-ZMAG/MAGJMN1.m @@ -1,230 +1,230 @@ -MAGJMN1 ;WIRMFO/JHC VRad Maint functions ; 29 Jul 2003 4:02 PM - ;;3.0;IMAGING;**16,9,22,18,65,76**;Jun 22, 2007;Build 19 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q - ; -SVRLIST ; - W @IOF,!!?10,"Enter/Edit VistARad Exams List Definition",!! - N MAGIEN - K DIC S (DIC,DLAYGO)=2006.631,DIC(0)="ALMEQ" - D ^DIC I Y=-1 K DIC,DA,DR,DIE,DLAYGO Q - S X=$P(@(DIC_+Y_",0)"),U,2) - I X>9000 W !!,$C(7),"You may not edit System-Supplied files!" H 3 G SVRLIST - S DIE=2006.631,DA=+Y,DR="[MAGJ LIST EDIT]" - S MAGIEN=DA - D ^DIE I '$D(DA) G SVRLIST - D ENSRCH - D BLDDEF(MAGIEN) - S $P(^MAG(2006.631,MAGIEN,0),U,5)=$$NOW^XLFDT() - W !!,"List Definition complete!" R X:2 - G SVRLIST - Q -ENSRCH ; Invoke Search for 2006.631 def'n - N GREF,GLIN,GO,CT,DIARI,DIC,FNOD,TNOD,NCOND,NODE0 - ; GREF holds indirect ref to store search logic data: - ; @GREF@(3, ff -- conditional elements (fields/logic) - ; @GREF@(4, ff -- composite elements (ANDed conditions) - ; @GREF@(5, ff -- Human-readable search text - ; GLIN holds indirect ref to retrieve search logic data from ^DIBT - ; @GLIN@("DC", ff -- conditional elements - ; @GLIN@("DL", ff -- composite elements - ; @GLIN@("O", ff -- readable text - S GREF=$NA(^MAG(2006.631,MAGIEN,"DEF")) - S GO=1 I $D(@GREF@(5,1)) D ; show current logic - . W ! D DISPSRCH(GREF) - . S X=$$YN("Do you want to delete or re-enter the search logic?","NO") - . I X'="Y" S GO=0 Q - . W !!?7,"Re-entering the search logic requires first deleting the current",!?7,"definition, then entering the new definition from scratch." - . S X=$$YN("Are you sure you want to continue?","NO") - . I X'="Y" S GO=0 Q - I 'GO Q - W !!?7,"Now enter search logic for this List. To do this, the program" - W !?7,"will prompt you just as if you were going to run a Fileman Search." - W !?7,"When prompted STORE RESULTS OF SEARCH IN TEMPLATE:, answer with 'TEMP'" - W !?7,"If prompted ... OK TO PURGE? NO// answer 'YES'; don't bother specifying" - W !?7,"output print fields, but just RETURN through all the prompts to" - W !?7,"complete the process. The search definition will be saved as part" - W !?7,"of this List definition; you will test it out by running it from " - W !?7,"the workstation. If you need to modify the search logic, you will" - W !?7,"have to re-enter it in its entirety." - W !!?7,"NOTES: EXAM LOCK INDICATOR will not work for search logic;" - W !?14,"REMOTE CACHE INDICATOR only works for Null/Not Null logic." - S DIC=2006.634 D EN^DIS ; call Fman Search Logic routine. It will store search logic in ^DIBT - ; 2006.634 is intentional--don't change this! - I '$G(DIARI) W !!," Search logic NOT updated" D Q - . Q:'$D(@GREF@(5,1)) ; if no logic had existed, quit - . S X=$$YN("Do you want to DELETE the search logic?","NO") - . I X="Y" K @GREF@(3) K ^(4),^(5) W " -- Deleted!" - K @GREF@(3) K ^(4),^(5) - S GLIN=$NA(^DIBT(DIARI)) ; Copy logic to 2006.631 DEF nodes - S FNOD="DC",TNOD=3,CT=0 ; "DC" data--straight copy - S T=0 F S T=$O(@GLIN@(FNOD,T)) Q:T="" S X=^(T),CT=CT+1,@GREF@(TNOD,T)=X - S @GREF@(TNOD,0)=CT - S FNOD="DL",TNOD=4,CT=0 ; "DL" data--copy depends on storage scheme in DIBT: - ;Zero node null -- straight copy - ; Else 1) either only one condition is defined; - ; or, 2) the zero-node condition is ANDed with all defined conditions - ; Case 2: Var A -- Pre-pend zero node, then dup zero node - ; Var B -- Pre-pend zero node - S NCOND=+$G(@GLIN@(FNOD)) - I $G(@GLIN@(FNOD,0))]"" S NODE0=^(0) D - . S T=0 F S T=$O(@GLIN@(FNOD,T)) Q:T="" S X=^(T) I X]"" S CT=CT+1,@GREF@(TNOD,CT)=NODE0_X - . I CT'=NCOND S CT=CT+1,@GREF@(TNOD,CT)=NODE0_$S(CT=1:"",1:"^") - E D - . S T=0 F S T=$O(@GLIN@(FNOD,T)) Q:T="" S X=^(T) I X]"" S CT=CT+1,@GREF@(TNOD,CT)=X - S @GREF@(TNOD,0)=CT - ; readable text--straight copy - S TNOD=5,T=0 F S T=$O(@GLIN@("O",T)) Q:T="" S @GREF@(TNOD,T)=^(T,0) - Q - ; -BLDDEF(LSTID) ; build DEF nodes for Column/Sort defs - N QX,SS,STR,LSTHDR,T,T0,T8,T6,HASCASE,XT,HASDATE - S SS=0,HASCASE=0,HASDATE=0 - ; columns/hdrs: Order in T array by the Relative Column Order - F S SS=$O(^MAG(2006.631,LSTID,1,SS)) D Q:'SS - . I 'SS D Q - . . I 'HASCASE S X=1 D BLDDEF2(X) ; FORCE CASE# - . . I 'HASDATE S X=7 D BLDDEF2(X) ; DATE/TIME - . E S X=^MAG(2006.631,LSTID,1,SS,0) - . D BLDDEF2(X) - ; go thru T to build ordered field sequence for output columns - S QX="T",STR="",LSTHDR="" - F S QX=$Q(@QX) Q:QX="" S X=@QX D - . S STR=STR_$S(STR="":"",1:U)_$P(X,U) - . S LSTHDR=LSTHDR_$S(LSTHDR="":"",1:U)_$P(X,U,2) - S ^MAG(2006.631,LSTID,"DEF",.5)=LSTHDR,^(1)=STR - ; Sort values: - S SS=0,STR="" - F S SS=$O(^MAG(2006.631,LSTID,2,SS)) Q:'SS S X=^(SS,0) D - . S X=+X_$S($P(X,U,2):"-",1:"") - . S STR=STR_$S(STR="":"",1:U)_X - S ^MAG(2006.631,LSTID,"DEF",2)=STR - S $P(^MAG(2006.631,LSTID,"DEF",0),U)=$$NOW^XLFDT() - Q - ; -BLDDEF2(X) ; - S X=+X_$S($P(X,U,2):";"_+$P(X,U,2),1:"") - I 'HASCASE S HASCASE=(+X=1) - I 'HASDATE S HASDATE=(+X=7) - S T0=^MAG(2006.63,+X,0),T6=+$P(T0,U,6) S:'T6 T6=99 - S T8=$P(T0,U,8) I T8]"" S T8="~"_T8 - S XT=$S($P(T0,U,3)]"":$P(T0,U,3),1:$P(T0,U,2))_T8 - S $P(XT,"~",3)=+X - S T(T6,+X)=X_U_XT - Q - ; -PRE ; init 2006.63 prior to KIDS install - N DIK,DA S DIK="^MAG(2006.63,",DA=0 F S DA=$O(@(DIK_DA_")")) Q:'DA D ^DIK - Q - ; -P18 ; Patch 18 inits - D BLDALL - D POST - Q - ; -BLDALL ; Create "DEF" nodes, Button labels List Def'ns - ; Updates all lists after s/w update list defs are installed - N SS,LSTDAT,LSTNUM,BUTTON,LSTTYP - S SS=0 - F S SS=$O(^MAG(2006.631,SS)) Q:'SS S LSTDAT=$G(^(SS,0)) I LSTDAT]"" D - . S LSTNUM=$P(LSTDAT,U,2),BUTTON=$P(LSTDAT,U,7),LSTTYP=$P(LSTDAT,U,3) - . I LSTNUM>9900!$P(LSTDAT,U,6) D BLDDEF(SS) ; build DEF nodes for System Lists & any Enabled lists - . I BUTTON="",(LSTTYP]"") D ; Create Button Labels if needed - . . S BUTTON=$S(LSTTYP="U":"Unread #",LSTTYP="R":"Recent #",LSTTYP="A":"All Active #",LSTTYP="P":"Pending #",1:"List #")_LSTNUM - . . S $P(^MAG(2006.631,SS,0),U,7)=BUTTON - Q - ; -POST ; Install msg - D INS^MAGQBUT4(XPDNM,DUZ,$$NOW^XLFDT,XPDA) - Q - ; -YN(MSG,DFLT) ; get Yes/No reply - N X I $G(DFLT)="" S DFLT="N" - W ! - S DFLT=$E(DFLT),DFLT=$S(DFLT="N":"NO",1:"YES") -YN1 W !,MSG_" "_DFLT_"// " - R X:DTIME S:X="" X=DFLT S X=$E(X),X=$TR(X,"ynYN","YNYN") - I "YN"'[X W " ??? Enter YES or NO",! G YN1 - Q X - ; -LSTINQ ; Inq/Disp list def'n - N GREF,MAGIEN - W !!?15,"Display VistARad Exams List Definition",!! - N MAGIEN - S DIC=2006.631,DIC(0)="AMEQ" - D ^DIC I Y=-1 K DIC,DA,DR Q - K DR S DA=+Y,MAGIEN=DA - S GREF=$NA(^MAG(2006.631,MAGIEN,"DEF")) - W ! D EN^DIQ - R !,"Enter RETURN to display the Search Logic: ",X:DTIME W ! - D DISPSRCH(GREF) - G LSTINQ - Q - ; -DISPSRCH(GREF) ; GREF holds indirect ref for global holding search logic data - I $D(@GREF@(5,1)) W !,"List Exams where:",! D - . F I=1:1 Q:'$D(@GREF@(5,I)) W !?3,^(I) - E W !?3,"NO Search Logic defined!" - Q - ; -VRSIT ; - W @IOF,!!?10,"Enter/Edit VistARad Site Parameters",!! - S DIC=2006.69,DIC(0)="ALMEQ" - I '$D(^MAG(DIC,1)) S DLAYGO=DIC - D ^DIC I Y=-1 K DIC,DA,DR,DIE,DLAYGO Q - S DIE=2006.69,DA=+Y,DR=".01:3.99;4.1:20" - D ^DIE - K DIC,DA,DR,DIE,DLAYGO - N PLACE S DA="" - S PLACE=$$PLACE^MAGBAPI(+$G(DUZ(2))) - S:PLACE DA=PLACE - I DA D - . W !!,"Editing VistARad Timeout for division #",DUZ(2),! - . S DIE=2006.1,DR="123" D ^DIE - K DA,DR,DIE - Q - ; -EEPREF ; - W @IOF,!!?10,"Enter/Edit VistARad Prefetch Logic",!! - N MAGIEN - K DIC S (DIC,DLAYGO)=2006.65,DIC(0)="ALMEQ" - D ^DIC I Y=-1 K DIC,DIE,DR,DLAYGO Q - S DIE=2006.65,DA=+Y,DR="[MAGJ PRIOR EDIT]" - S MAGIEN=DA - D ^DIE I '$D(DA) G EEPREF - G EEPREF - Q -INPREF ; Inquire VRad PreFetch - W @IOF,!!?10,"Inquire VistARad Prefetch Logic",!! - N MAGIEN,BY,FR,TO - S DIC=2006.65,DIC(0)="AMEQ" - D ^DIC I Y=-1 K DIC Q - S DA=+Y,(FR,TO)=$P(Y,U,2),MAGIEN=DA,L=0 - S BY="[MAGJ PRIOR SORT]",DIS(0)="I D0=MAGIEN" - D EN^DIP - R !,"Enter RETURN to continue: ",X:DTIME W ! - G INPREF - Q -PRPREF ;Print VRad Prefetch - N BY - W !! S DIC=2006.65,L=0,BY="[MAGJ PRIOR SORT]" - D EN1^DIP - R !,"Enter RETURN to continue: ",X:DTIME W ! - Q - ; -END ; +MAGJMN1 ;WIRMFO/JHC VRad Maint functions ; 29 Jul 2003 4:02 PM + ;;3.0;IMAGING;**16,9,22,18,65**;Jul 27, 2006;Build 28 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q + ; +SVRLIST ; + W @IOF,!!?10,"Enter/Edit VistARad Exams List Definition",!! + N MAGIEN + K DIC S (DIC,DLAYGO)=2006.631,DIC(0)="ALMEQ" + D ^DIC I Y=-1 K DIC,DA,DR,DIE,DLAYGO Q + S X=$P(@(DIC_+Y_",0)"),U,2) + I X>9000 W !!,$C(7),"You may not edit System-Supplied files!" H 3 G SVRLIST + S DIE=2006.631,DA=+Y,DR="[MAGJ LIST EDIT]" + S MAGIEN=DA + D ^DIE I '$D(DA) G SVRLIST + D ENSRCH + D BLDDEF(MAGIEN) + D NOW^%DTC S $P(^MAG(2006.631,MAGIEN,0),U,5)=% + W !!,"List Definition complete!" R X:2 + G SVRLIST + Q +ENSRCH ; Invoke Search for 2006.631 def'n + N GREF,GLIN,GO,CT,DIARI,DIC,FNOD,TNOD,NCOND,NODE0 + ; GREF holds indirect ref to store search logic data: + ; @GREF@(3, ff -- conditional elements (fields/logic) + ; @GREF@(4, ff -- composite elements (ANDed conditions) + ; @GREF@(5, ff -- Human-readable search text + ; GLIN holds indirect ref to retrieve search logic data from ^DIBT + ; @GLIN@("DC", ff -- conditional elements + ; @GLIN@("DL", ff -- composite elements + ; @GLIN@("O", ff -- readable text + S GREF=$NA(^MAG(2006.631,MAGIEN,"DEF")) + S GO=1 I $D(@GREF@(5,1)) D ; show current logic + . W ! D DISPSRCH(GREF) + . S X=$$YN("Do you want to delete or re-enter the search logic?","NO") + . I X'="Y" S GO=0 Q + . W !!?7,"Re-entering the search logic requires first deleting the current",!?7,"definition, then entering the new definition from scratch." + . S X=$$YN("Are you sure you want to continue?","NO") + . I X'="Y" S GO=0 Q + I 'GO Q + W !!?7,"Now enter search logic for this List. To do this, the program" + W !?7,"will prompt you just as if you were going to run a Fileman Search." + W !?7,"When prompted STORE RESULTS OF SEARCH IN TEMPLATE:, answer with 'TEMP'" + W !?7,"If prompted ... OK TO PURGE? NO// answer 'YES'; don't bother specifying" + W !?7,"output print fields, but just RETURN through all the prompts to" + W !?7,"complete the process. The search definition will be saved as part" + W !?7,"of this List definition; you will test it out by running it from " + W !?7,"the workstation. If you need to modify the search logic, you will" + W !?7,"have to re-enter it in its entirety." + W !!?7,"NOTES: EXAM LOCK INDICATOR will not work for search logic;" + W !?14,"REMOTE CACHE INDICATOR only works for Null/Not Null logic." + S DIC=2006.634 D EN^DIS ; call Fman Search Logic routine. It will store search logic in ^DIBT + ; 2006.634 is intentional--don't change this! + I '$G(DIARI) W !!," Search logic NOT updated" D Q + . Q:'$D(@GREF@(5,1)) ; if no logic had existed, quit + . S X=$$YN("Do you want to DELETE the search logic?","NO") + . I X="Y" K @GREF@(3) K ^(4),^(5) W " -- Deleted!" + K @GREF@(3) K ^(4),^(5) + S GLIN=$NA(^DIBT(DIARI)) ; Copy logic to 2006.631 DEF nodes + S FNOD="DC",TNOD=3,CT=0 ; "DC" data--straight copy + S T=0 F S T=$O(@GLIN@(FNOD,T)) Q:T="" S X=^(T),CT=CT+1,@GREF@(TNOD,T)=X + S @GREF@(TNOD,0)=CT + S FNOD="DL",TNOD=4,CT=0 ; "DL" data--copy depends on storage scheme in DIBT: + ;Zero node null -- straight copy + ; Else 1) either only one condition is defined; + ; or, 2) the zero-node condition is ANDed with all defined conditions + ; Case 2: Var A -- Pre-pend zero node, then dup zero node + ; Var B -- Pre-pend zero node + S NCOND=+$G(@GLIN@(FNOD)) + I $G(@GLIN@(FNOD,0))]"" S NODE0=^(0) D + . S T=0 F S T=$O(@GLIN@(FNOD,T)) Q:T="" S X=^(T) I X]"" S CT=CT+1,@GREF@(TNOD,CT)=NODE0_X + . I CT'=NCOND S CT=CT+1,@GREF@(TNOD,CT)=NODE0_$S(CT=1:"",1:"^") + E D + . S T=0 F S T=$O(@GLIN@(FNOD,T)) Q:T="" S X=^(T) I X]"" S CT=CT+1,@GREF@(TNOD,CT)=X + S @GREF@(TNOD,0)=CT + ; readable text--straight copy + S TNOD=5,T=0 F S T=$O(@GLIN@("O",T)) Q:T="" S @GREF@(TNOD,T)=^(T,0) + Q + ; +BLDDEF(LSTID) ; build DEF nodes for Column/Sort defs + N QX,SS,STR,LSTHDR,T,T0,T8,T6,HASCASE,XT,HASDATE + S SS=0,HASCASE=0,HASDATE=0 + ; columns/hdrs: Order in T array by the Relative Column Order + F S SS=$O(^MAG(2006.631,LSTID,1,SS)) D Q:'SS + . I 'SS D Q + . . I 'HASCASE S X=1 D BLDDEF2(X) ; FORCE CASE# + . . I 'HASDATE S X=7 D BLDDEF2(X) ; DATE/TIME + . E S X=^MAG(2006.631,LSTID,1,SS,0) + . D BLDDEF2(X) + ; go thru T to build ordered field sequence for output columns + S QX="T",STR="",LSTHDR="" + F S QX=$Q(@QX) Q:QX="" S X=@QX D + . S STR=STR_$S(STR="":"",1:U)_$P(X,U) + . S LSTHDR=LSTHDR_$S(LSTHDR="":"",1:U)_$P(X,U,2) + S ^MAG(2006.631,LSTID,"DEF",.5)=LSTHDR,^(1)=STR + ; Sort values: + S SS=0,STR="" + F S SS=$O(^MAG(2006.631,LSTID,2,SS)) Q:'SS S X=^(SS,0) D + . S X=+X_$S($P(X,U,2):"-",1:"") + . S STR=STR_$S(STR="":"",1:U)_X + S ^MAG(2006.631,LSTID,"DEF",2)=STR + D NOW^%DTC S $P(^MAG(2006.631,LSTID,"DEF",0),U)=% + Q + ; +BLDDEF2(X) ; + S X=+X_$S($P(X,U,2):";"_+$P(X,U,2),1:"") + I 'HASCASE S HASCASE=(+X=1) + I 'HASDATE S HASDATE=(+X=7) + S T0=^MAG(2006.63,+X,0),T6=+$P(T0,U,6) S:'T6 T6=99 + S T8=$P(T0,U,8) I T8]"" S T8="~"_T8 + S XT=$S($P(T0,U,3)]"":$P(T0,U,3),1:$P(T0,U,2))_T8 + S $P(XT,"~",3)=+X + S T(T6,+X)=X_U_XT + Q + ; +PRE ; init 2006.63 prior to KIDS install + N DIK,DA S DIK="^MAG(2006.63,",DA=0 F S DA=$O(@(DIK_DA_")")) Q:'DA D ^DIK + Q + ; +P18 ; Patch 18 inits + D BLDALL + D POST + Q + ; +BLDALL ; Create "DEF" nodes, Button labels List Def'ns + ; Updates all lists after s/w update list defs are installed + N SS,LSTDAT,LSTNUM,BUTTON,LSTTYP + S SS=0 + F S SS=$O(^MAG(2006.631,SS)) Q:'SS S LSTDAT=$G(^(SS,0)) I LSTDAT]"" D + . S LSTNUM=$P(LSTDAT,U,2),BUTTON=$P(LSTDAT,U,7),LSTTYP=$P(LSTDAT,U,3) + . I LSTNUM>9900!$P(LSTDAT,U,6) D BLDDEF(SS) ; build DEF nodes for System Lists & any Enabled lists + . I BUTTON="",(LSTTYP]"") D ; Create Button Labels if needed + . . S BUTTON=$S(LSTTYP="U":"Unread #",LSTTYP="R":"Recent #",LSTTYP="A":"All Active #",LSTTYP="P":"Pending #",1:"List #")_LSTNUM + . . S $P(^MAG(2006.631,SS,0),U,7)=BUTTON + Q + ; +POST ; Install msg + D INS^MAGQBUT4(XPDNM,DUZ,$$NOW^XLFDT,XPDA) + Q + ; +YN(MSG,DFLT) ; get Yes/No reply + N X I $G(DFLT)="" S DFLT="N" + W ! + S DFLT=$E(DFLT),DFLT=$S(DFLT="N":"NO",1:"YES") +YN1 W !,MSG_" "_DFLT_"// " + R X:DTIME S:X="" X=DFLT S X=$E(X),X=$TR(X,"ynYN","YNYN") + I "YN"'[X W " ??? Enter YES or NO",! G YN1 + Q X + ; +LSTINQ ; Inq/Disp list def'n + N GREF,MAGIEN + W !!?15,"Display VistARad Exams List Definition",!! + N MAGIEN + S DIC=2006.631,DIC(0)="AMEQ" + D ^DIC I Y=-1 K DIC,DA,DR Q + K DR S DA=+Y,MAGIEN=DA + S GREF=$NA(^MAG(2006.631,MAGIEN,"DEF")) + W ! D EN^DIQ + R !,"Enter RETURN to display the Search Logic: ",X:DTIME W ! + D DISPSRCH(GREF) + G LSTINQ + Q + ; +DISPSRCH(GREF) ; GREF holds indirect ref for global holding search logic data + I $D(@GREF@(5,1)) W !,"List Exams where:",! D + . F I=1:1 Q:'$D(@GREF@(5,I)) W !?3,^(I) + E W !?3,"NO Search Logic defined!" + Q + ; +VRSIT ; + W @IOF,!!?10,"Enter/Edit VistARad Site Parameters",!! + S DIC=2006.69,DIC(0)="ALMEQ" + I '$D(^MAG(DIC,1)) S DLAYGO=DIC + D ^DIC I Y=-1 K DIC,DA,DR,DIE,DLAYGO Q + S DIE=2006.69,DA=+Y,DR=".01:3.99;4.1:20" + D ^DIE + K DIC,DA,DR,DIE,DLAYGO + N PLACE S DA="" + S PLACE=$$PLACE^MAGBAPI(+$G(DUZ(2))) + S:PLACE DA=PLACE + I DA D + . W !!,"Editing VistARad Timeout for division #",DUZ(2),! + . S DIE=2006.1,DR="123" D ^DIE + K DA,DR,DIE + Q + ; +EEPREF ; + W @IOF,!!?10,"Enter/Edit VistARad Prefetch Logic",!! + N MAGIEN + K DIC S (DIC,DLAYGO)=2006.65,DIC(0)="ALMEQ" + D ^DIC I Y=-1 K DIC,DIE,DR,DLAYGO Q + S DIE=2006.65,DA=+Y,DR="[MAGJ PRIOR EDIT]" + S MAGIEN=DA + D ^DIE I '$D(DA) G EEPREF + G EEPREF + Q +INPREF ; Inquire VRad PreFetch + W @IOF,!!?10,"Inquire VistARad Prefetch Logic",!! + N MAGIEN,BY,FR,TO + S DIC=2006.65,DIC(0)="AMEQ" + D ^DIC I Y=-1 K DIC Q + S DA=+Y,(FR,TO)=$P(Y,U,2),MAGIEN=DA,L=0 + S BY="[MAGJ PRIOR SORT]",DIS(0)="I D0=MAGIEN" + D EN^DIP + R !,"Enter RETURN to continue: ",X:DTIME W ! + G INPREF + Q +PRPREF ;Print VRad Prefetch + N BY + W !! S DIC=2006.65,L=0,BY="[MAGJ PRIOR SORT]" + D EN1^DIP + R !,"Enter RETURN to continue: ",X:DTIME W ! + Q + ; +END ; diff --git a/r/IMAGING-MAG-ZMAG/MAGJUPD1.m b/r/IMAGING-MAG-ZMAG/MAGJUPD1.m index 83af2101..c81f0aa2 100644 --- a/r/IMAGING-MAG-ZMAG/MAGJUPD1.m +++ b/r/IMAGING-MAG-ZMAG/MAGJUPD1.m @@ -1,169 +1,168 @@ -MAGJUPD1 ;WOIFO/JHC VistARad Update Exam Status ; 29 Jul 2003 10:02 AM - ;;3.0;IMAGING;**16,22,18,76**;Jun 22, 2007;Build 19 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q - ; Subroutines for RPC's to update Exam Status to "Interpreted", and - ; for "Closing" a case that is open on the DX Workstation - ; -ERR N ERR S ERR=$$EC^%ZOSV S @MAGGRY@(0)="0^Server Program Error: "_ERR - D @^%ZOSF("ERRTN") - Q:$Q 1 Q - ; -STATUS(MAGGRY,PARAMS,DATA) ; rpc: MAGJ RADSTATUSUPDATE - ; Update Exam Status to "Interpreted" and/or Close the exam - ; Only updates the Status if the current value is "Examined" - ; This routine defines variables needed for calling the Radiology - ; package routine UP1^RAUTL1, for filing Status updates - ; - ; PARAMS = UPDFLAG ^ RADFN ^ RADTI ^ RACNI ^ RARPT ^ UPDPSKEY - ; UPDFLAG = 1/0 -- 1 to perform update; else no update made - ; RARPT = ptr to Rad Exam Report file - ; RADFN,RADTI,RACNI = pointers to Rad Patient File for the exam - ; UPDPSKEY = 1/0 -- 1 to update Presentation State &/or Key Image data - ; MAGGRY = return results in @MAGGRY - ; - N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGJUPD1" - N RARPT,RADFN,RADTI,RACNI,RAEXT,RACNE,RADTE,RAINT,RAMDV,DIQUIET - N RAONLINE,ZTQUEUED,RAOR,RASN,RASTI,RAPRTSET,LOGDATA,RSL,TIMESTMP - N UPDPSKEY,MAGRET,MAGLST,REPLY,UPDFLAG,RADATA,RIST,MAGPSET,RACNILST,ACNLST - S MAGLST="MAGJUPDATE" - K MAGGRY S MAGGRY=$NA(^TMP($J,MAGLST)) K @MAGGRY ; assign MAGGRY value - S DIQUIET=1 D DT^DICRW - S TIMESTMP=$$NOW^XLFDT() - S UPDFLAG=$P(PARAMS,U),RADFN=$P(PARAMS,U,2),RADTI=$P(PARAMS,U,3),RACNI=$P(PARAMS,U,4),RARPT=$P(PARAMS,U,5),UPDPSKEY=+$P(PARAMS,U,6) - S REPLY="0^4~Closing case with"_$S(UPDFLAG:"",1:" NO")_" Status Update" - S RAPRTSET=0 - I RADFN,RADTI,RACNI - E S REPLY="0^4~Request Contains Invalid Case Pointer ("_RARPT_")" G STATUSZ - D GETEXAM2^MAGJUTL1(RADFN,RADTI,RACNI,0,.MAGRET) - I 'MAGRET S REPLY="0^4~Current Case Not Accessible for Updating" G STATUSZ - ; 1 RADFN RADTI RACNI RANME RASSN <--Contents of RADATA, - ; 6 RADATE RADTE RACN RAPRC RARPT from GETEXAM - ;11 RAST DAYCASE RAELOC RASTP RASTORD - ;16 RADTPRT - S RADATA=$G(^TMP($J,"MAGRAEX",1,1)) - S RAEXT=$P(RADATA,U,12),RACNE=$P(RAEXT,"-",2),RADTE=$P(RADATA,U,7) - S RAINT=RADTI_"-"_RACNI - D CLOSE(.RSL,RADFN_U_RADTI_U_RACNI_U_U_1,.LOGDATA) ; unlock the case - ; proceed only if case was locked by this user - ; if it was not Locked, then do NOT update PS, Key Images - I 'RSL S REPLY=RSL,UPDPSKEY=0 G STATUSZ - I 'UPDFLAG S REPLY="0^1~Case #"_RAEXT_" Closed; No Status Update performed" G STATUSZ - S RIST=$P(RSL,U,2) ; CLOSE reports back the type of radiologist - ; now we know this user had locked the case, & wants to do Status update - D EN2^RAUTL20(.MAGPSET) ; get info re rad PrintSet - ; - ; IF exam is not "Examined", and not "Cancelled" and past "Waiting" - ; then assume it has already been updated via another pathway, - ; either as printset member (via code at tag PRTSET, below), - ; or from a voice-dictation or terminal session by the radiologist - ; For these cases, no warning msg is sent - ; Else, update not allowed, so give warning msg - ; Note that when the Exam was OPENed, it must have had status "Examined" - I '$D(^RA(72,"AVC","E",$P(RADATA,U,11))) D G STATUSX:(+$P(REPLY,U,2)=1),STATUSZ ; Current Status MUST be "Examined" Category - . I $P(RADATA,U,15)>2 D ; assume update has otherwise been done, eg voice dictation or manual entry in Vista - .. S RACNILST=RACNI,RASTI=$P(RADATA,U,11) ; need for code at tag statusx - .. I RAPRTSET S REPLY="0^1~Printset Exams with Case #"_RAEXT_" have been updated" - .. E S REPLY="0^1~No Update done for Case #"_RAEXT_"--current status is "_$P(RADATA,U,14) - . E S REPLY="0^3~No Update Allowed for Case #"_RAEXT_"--current status is "_$P(RADATA,U,14) - ; - ; now ready to update exam status - S RAMDV=$P(^RADPT(RADFN,"DT",RADTI,0),U,3) - S RAMDV=$TR(^RA(79,RAMDV,.1),"YyNn","1100") - ; - ; Update interpreting radiologist field in Rad file - I RIST D I RACNILST="" G STATUSZ - . N SAVRACNI,RTN S RACNILST="" -PRTSET . ; if exam is part of Rad Print-Set, then update all exams of printset - . I RAPRTSET D - .. S ACNLST="",SAVRACNI=RACNI,X=0 - .. F I=0:1 S X=$O(MAGPSET(X)) Q:'X S RACNILST=RACNILST_$S(I:U,1:"")_X S:RACNE'=+MAGPSET(X) ACNLST=ACNLST_", "_"-"_+MAGPSET(X) - . E S RACNILST=RACNI - . F I=1:1:$L(RACNILST,U) S RACNI=$P(RACNILST,U,I) I RACNI D I RACNILST="" Q - .. S DA(2)=RADFN,DA(1)=RADTI,DA=RACNI - .. D STUFPHY^RARIC1(DUZ,RIST,.RTN) - .. I 'RTN S REPLY="0^4~Unable to update Interpreting Radiologist: "_RTN_"." S RACNILST="" - . I RAPRTSET S RACNI=SAVRACNI - S RAONLINE=1,ZTQUEUED=1 D UP1^RAUTL1 ; Suppress msgs, do Status update - ;<*> K RAONLINE,ZTQUEUED D UP1^RAUTL1 ; <*> Testing Only: ENABLE msgs - I RAOR<0 S REPLY="0^3~Exam Status for Case #"_RAEXT_" CANNOT be updated; current status remains: "_$S($G(RASN)]"":RASN,1:"Unknown") - I G STATUSZ - ; - S REPLY="0^1~For Case #"_$S($G(ACNLST)]"":"s ",1:"")_RAEXT_$S(RAPRTSET:ACNLST,1:"")_", Exam Status updated to "_RASN - ; -STATUSX ; Newly Interpreted exam: - ; Log the Interpreted event - D LOG^MAGJUTL3("VR-INT",LOGDATA) - ; Update Recent Exams List - G STATUSZ:'$P(^MAG(2006.69,1,0),U,8) ; no bkgnd compile enabled - L +^XTMP("MAGJ2","RECENT"):5 - E G STATUSZ - N INDX F I=1:1:$L(RACNILST,U) S RACNI=$P(RACNILST,U,I) I RACNI D - . S INDX=+$G(^XTMP("MAGJ2","RECENT",0))+1,$P(^(0),U)=INDX,^(INDX)=RADFN_U_RADTI_U_RACNI_U_RASTI - L -^XTMP("MAGJ2","RECENT") -STATUSZ ; - ; store PS, Key Image data - I UPDPSKEY,($D(DATA)>9) D - . D SAVKPS^MAGJUPD2(RARPT,UPDPSKEY,.DATA,.X) - . S REPLY=REPLY_$P(X,"~",2,99) - S @MAGGRY@(0)=REPLY - K ^TMP($J,"MAGRAEX"),^("RAE1") - Q - ; -CLOSE(RSL,PARAMS,LOGDATA) ; Close/unlock a case - ; Input: PARAMS = DFN ^ DTI ^ CNI ^ RPT ^ UPDFLAG - ; - ; DFN,DTI,CNI,RPT = pointers to Rad File for the exam - ; UPDFLAG = 1/0 -- 1 indicates CLOSE was called from subroutine - ; STATUS, above (which has already called GETEXAM) - ; RSL = return result of the Close - ; This subroutine may be called directly (to close a case without - ; doing a status update), or is called from tag STATUS, above, when - ; also doing a status update - ; - N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGJUPD1" - N RPT,DFN,DTI,CNI,MAGRET,REPLY,RARPT,UPDFLAG,RIST,DAYCASE,NLOCKS,MYLOCK - S DFN=$P(PARAMS,U),DTI=$P(PARAMS,U,2),CNI=$P(PARAMS,U,3),RPT=$P(PARAMS,U,4),UPDFLAG=$P(PARAMS,U,5) - S LOGDATA="" - I $P($G(^MAG(2006.69,1,0)),U,4) - E S REPLY=$S(UPDFLAG:"0^3~Updates not allowed at this site--no action taken",1:"") G CLOSEZ ; Status Update NOT Enabled - S RIST=+MAGJOB("USER",1) I RIST - E S REPLY=$S(UPDFLAG:"0^3~Update allowed only by a radiologist--no action taken",1:"") G CLOSEZ ; need only unlock a radiologist - I DFN,DTI,CNI - E S REPLY="0^4~Request Contains Invalid Case Pointer ("_RPT_")--no action taken" G CLOSEZ - ; - I 'UPDFLAG N RADATA D I 'MAGRET G CLOSEZ - . D GETEXAM2^MAGJUTL1(DFN,DTI,CNI,0,.MAGRET) - . I 'MAGRET S REPLY="0^4~No Current Case accessible to close--no action taken" - . E S RADATA=$G(^TMP($J,"MAGRAEX",1,1)) - S RARPT=$P(RADATA,U,10),DAYCASE=$P(RADATA,U,12) - I RARPT,DAYCASE - E S REPLY="0^4~Current Case not accessible to close--no action taken" G CLOSEZ - ; - D LOCKACT^MAGJEX1A(RARPT,DAYCASE,101,,.MYLOCK) - S LOGDATA=$P(MYLOCK(1),"|",2) - I 'MYLOCK(1) S X=$P(MYLOCK(1),U,4) D S LOGDATA="" G CLOSEZ - . I UPDFLAG S REPLY="0^1~Case #"_DAYCASE_$S(X]"":" locked by "_X,1:" not locked by "_$P(MAGJOB("USER",1),U,2))_"--No Status update performed" - . E S REPLY="0^1~ " ; case wasn't opened by this R'ist; nothing to do - ; - I UPDFLAG S REPLY=1_U_RIST - E S REPLY="0^1~Case #"_DAYCASE_$S(+MYLOCK(1):" unlocked",+MYLOCK(2):" reserve cancelled",1:" closed")_"--No Status Update performed." -CLOSEZ S RSL=REPLY - Q - ; -END Q ; +MAGJUPD1 ;WOIFO/JHC VistARad Update Exam Status ; 29 Jul 2003 10:02 AM + ;;3.0;IMAGING;**16,22,18**;Mar 07, 2006 + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q + ; Subroutines for RPC's to update Exam Status to "Interpreted", and + ; for "Closing" a case that is open on the DX Workstation + ; +ERR N ERR S ERR=$$EC^%ZOSV S @MAGGRY@(0)="0^Server Program Error: "_ERR + D @^%ZOSF("ERRTN") + Q:$Q 1 Q + ; +STATUS(MAGGRY,PARAMS,DATA) ; rpc: MAGJ RADSTATUSUPDATE + ; Update Exam Status to "Interpreted" and/or Close the exam + ; Only updates the Status if the current value is "Examined" + ; This routine defines variables needed for calling the Radiology + ; package routine UP1^RAUTL1, for filing Status updates + ; + ; PARAMS = UPDFLAG ^ RADFN ^ RADTI ^ RACNI ^ RARPT ^ UPDPSKEY + ; UPDFLAG = 1/0 -- 1 to perform update; else no update made + ; RARPT = ptr to Rad Exam Report file + ; RADFN,RADTI,RACNI = pointers to Rad Patient File for the exam + ; UPDPSKEY = 1/0 -- 1 to update Presentation State &/or Key Image data + ; MAGGRY = return results in @MAGGRY + ; + N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGJUPD1" + N RARPT,RADFN,RADTI,RACNI,RAEXT,RACNE,RADTE,RAINT,RAMDV,DIQUIET + N RAONLINE,ZTQUEUED,RAOR,RASN,RASTI,RAPRTSET,LOGDATA,RSL,TIMESTMP + N UPDPSKEY,MAGRET,MAGLST,REPLY,UPDFLAG,RADATA,RIST,MAGPSET,RACNILST,ACNLST + S MAGLST="MAGJUPDATE" + K MAGGRY S MAGGRY=$NA(^TMP($J,MAGLST)) K @MAGGRY ; assign MAGGRY value + S DIQUIET=1 D DT^DICRW + D NOW^%DTC S TIMESTMP=% + S UPDFLAG=$P(PARAMS,U),RADFN=$P(PARAMS,U,2),RADTI=$P(PARAMS,U,3),RACNI=$P(PARAMS,U,4),RARPT=$P(PARAMS,U,5),UPDPSKEY=+$P(PARAMS,U,6) + S REPLY="0^4~Closing case with"_$S(UPDFLAG:"",1:" NO")_" Status Update" + S RAPRTSET=0 + I RADFN,RADTI,RACNI + E S REPLY="0^4~Request Contains Invalid Case Pointer ("_RARPT_")" G STATUSZ + D GETEXAM2^MAGJUTL1(RADFN,RADTI,RACNI,0,.MAGRET) + I 'MAGRET S REPLY="0^4~Current Case Not Accessible for Updating" G STATUSZ + ; 1 RADFN RADTI RACNI RANME RASSN <--Contents of RADATA, + ; 6 RADATE RADTE RACN RAPRC RARPT from GETEXAM + ;11 RAST DAYCASE RAELOC RASTP RASTORD + ;16 RADTPRT + S RADATA=$G(^TMP($J,"MAGRAEX",1,1)) + S RAEXT=$P(RADATA,U,12),RACNE=$P(RAEXT,"-",2),RADTE=$P(RADATA,U,7) + S RAINT=RADTI_"-"_RACNI + D CLOSE(.RSL,RADFN_U_RADTI_U_RACNI_U_U_1,.LOGDATA) ; unlock the case + ; proceed only if case was locked by this user + ; if it was not Locked, then do NOT update PS, Key Images + I 'RSL S REPLY=RSL,UPDPSKEY=0 G STATUSZ + I 'UPDFLAG S REPLY="0^1~Case #"_RAEXT_" Closed; No Status Update performed" G STATUSZ + S RIST=$P(RSL,U,2) ; CLOSE reports back the type of radiologist + ; now we know this user had locked the case, & wants to do Status update + D EN2^RAUTL20(.MAGPSET) ; get info re rad PrintSet + ; + ; IF exam is not "Examined", and not "Cancelled" and past "Waiting" + ; then assume it has already been updated via another pathway, + ; either as printset member (via code at tag PRTSET, below), + ; or from a voice-dictation or terminal session by the radiologist + ; For these cases, no warning msg is sent + ; Else, update not allowed, so give warning msg + ; Note that when the Exam was OPENed, it must have had status "Examined" + I '$D(^RA(72,"AVC","E",$P(RADATA,U,11))) D G STATUSX:(+$P(REPLY,U,2)=1),STATUSZ ; Current Status MUST be "Examined" Category + . I $P(RADATA,U,15)>2 D ; assume update has otherwise been done, eg voice dictation or manual entry in Vista + .. S RACNILST=RACNI,RASTI=$P(RADATA,U,11) ; need for code at tag statusx + .. I RAPRTSET S REPLY="0^1~Printset Exams with Case #"_RAEXT_" have been updated" + .. E S REPLY="0^1~No Update done for Case #"_RAEXT_"--current status is "_$P(RADATA,U,14) + . E S REPLY="0^3~No Update Allowed for Case #"_RAEXT_"--current status is "_$P(RADATA,U,14) + ; + ; now ready to update exam status + S RAMDV=$P(^RADPT(RADFN,"DT",RADTI,0),U,3) + S RAMDV=$TR(^RA(79,RAMDV,.1),"YyNn","1100") + ; + ; Update interpreting radiologist field in Rad file + I RIST D I RACNILST="" G STATUSZ + . N SAVRACNI,RTN S RACNILST="" +PRTSET . ; if exam is part of Rad Print-Set, then update all exams of printset + . I RAPRTSET D + .. S ACNLST="",SAVRACNI=RACNI,X=0 + .. F I=0:1 S X=$O(MAGPSET(X)) Q:'X S RACNILST=RACNILST_$S(I:U,1:"")_X S:RACNE'=+MAGPSET(X) ACNLST=ACNLST_", "_"-"_+MAGPSET(X) + . E S RACNILST=RACNI + . F I=1:1:$L(RACNILST,U) S RACNI=$P(RACNILST,U,I) I RACNI D I RACNILST="" Q + .. S DA(2)=RADFN,DA(1)=RADTI,DA=RACNI + .. D STUFPHY^RARIC1(DUZ,RIST,.RTN) + .. I 'RTN S REPLY="0^4~Unable to update Interpreting Radiologist: "_RTN_"." S RACNILST="" + . I RAPRTSET S RACNI=SAVRACNI + S RAONLINE=1,ZTQUEUED=1 D UP1^RAUTL1 ; Suppress msgs, do Status update + ;<*> K RAONLINE,ZTQUEUED D UP1^RAUTL1 ; <*> Testing Only: ENABLE msgs + I RAOR<0 S REPLY="0^3~Exam Status for Case #"_RAEXT_" CANNOT be updated; current status remains: "_$S($G(RASN)]"":RASN,1:"Unknown") + I G STATUSZ + ; + S REPLY="0^1~For Case #"_$S($G(ACNLST)]"":"s ",1:"")_RAEXT_$S(RAPRTSET:ACNLST,1:"")_", Exam Status updated to "_RASN + ; +STATUSX ; Newly Interpreted exam: + ; Log the Interpreted event + D LOG^MAGJUTL3("VR-INT",LOGDATA) + ; Update Recent Exams List + G STATUSZ:'$P(^MAG(2006.69,1,0),U,8) ; no bkgnd compile enabled + L +^XTMP("MAGJ2","RECENT"):5 + E G STATUSZ + N INDX F I=1:1:$L(RACNILST,U) S RACNI=$P(RACNILST,U,I) I RACNI D + . S INDX=+$G(^XTMP("MAGJ2","RECENT",0))+1,$P(^(0),U)=INDX,^(INDX)=RADFN_U_RADTI_U_RACNI_U_RASTI + L -^XTMP("MAGJ2","RECENT") +STATUSZ ; + ; store PS, Key Image data + I UPDPSKEY,($D(DATA)>9) D + . D SAVKPS^MAGJUPD2(RARPT,UPDPSKEY,.DATA,.X) + . S REPLY=REPLY_$P(X,"~",2,99) + S @MAGGRY@(0)=REPLY + K ^TMP($J,"MAGRAEX"),^("RAE1") + Q + ; +CLOSE(RSL,PARAMS,LOGDATA) ; Close/unlock a case + ; Input: PARAMS = DFN ^ DTI ^ CNI ^ RPT ^ UPDFLAG + ; + ; DFN,DTI,CNI,RPT = pointers to Rad File for the exam + ; UPDFLAG = 1/0 -- 1 indicates CLOSE was called from subroutine + ; STATUS, above (which has already called GETEXAM) + ; RSL = return result of the Close + ; This subroutine may be called directly (to close a case without + ; doing a status update), or is called from tag STATUS, above, when + ; also doing a status update + ; + N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGJUPD1" + N RPT,DFN,DTI,CNI,MAGRET,REPLY,RARPT,UPDFLAG,RIST,DAYCASE,NLOCKS,MYLOCK + S DFN=$P(PARAMS,U),DTI=$P(PARAMS,U,2),CNI=$P(PARAMS,U,3),RPT=$P(PARAMS,U,4),UPDFLAG=$P(PARAMS,U,5) + S LOGDATA="" + I $P($G(^MAG(2006.69,1,0)),U,4) + E S REPLY=$S(UPDFLAG:"0^3~Updates not allowed at this site--no action taken",1:"") G CLOSEZ ; Status Update NOT Enabled + S RIST=+MAGJOB("USER",1) I RIST + E S REPLY=$S(UPDFLAG:"0^3~Update allowed only by a radiologist--no action taken",1:"") G CLOSEZ ; need only unlock a radiologist + I DFN,DTI,CNI + E S REPLY="0^4~Request Contains Invalid Case Pointer ("_RPT_")--no action taken" G CLOSEZ + ; + I 'UPDFLAG N RADATA D I 'MAGRET G CLOSEZ + . D GETEXAM2^MAGJUTL1(DFN,DTI,CNI,0,.MAGRET) + . I 'MAGRET S REPLY="0^4~No Current Case accessible to close--no action taken" + . E S RADATA=$G(^TMP($J,"MAGRAEX",1,1)) + S RARPT=$P(RADATA,U,10),DAYCASE=$P(RADATA,U,12) + I RARPT,DAYCASE + E S REPLY="0^4~Current Case not accessible to close--no action taken" G CLOSEZ + ; + D LOCKACT^MAGJEX1A(RARPT,DAYCASE,101,,.MYLOCK) + S LOGDATA=$P(MYLOCK(1),"|",2) + I 'MYLOCK(1) S X=$P(MYLOCK(1),U,4) D S LOGDATA="" G CLOSEZ + . I UPDFLAG S REPLY="0^1~Case #"_DAYCASE_$S(X]"":" locked by "_X,1:" not locked by "_$P(MAGJOB("USER",1),U,2))_"--No Status update performed" + . E S REPLY="0^1~ " ; case wasn't opened by this R'ist; nothing to do + ; + I UPDFLAG S REPLY=1_U_RIST + E S REPLY="0^1~Case #"_DAYCASE_$S(+MYLOCK(1):" unlocked",+MYLOCK(2):" reserve cancelled",1:" closed")_"--No Status Update performed." +CLOSEZ S RSL=REPLY + Q + ; +END Q ; diff --git a/r/IMAGING-MAG-ZMAG/MAGJUPD2.m b/r/IMAGING-MAG-ZMAG/MAGJUPD2.m index cf51d8b7..1941006d 100644 --- a/r/IMAGING-MAG-ZMAG/MAGJUPD2.m +++ b/r/IMAGING-MAG-ZMAG/MAGJUPD2.m @@ -1,202 +1,201 @@ -MAGJUPD2 ;WIRMFO/JHC VistaRad RPCs-Update PS & KEY Img ; 14 July 2004 10:05 AM - ;;3.0;IMAGING;**18,76**;Jun 22, 2007;Build 19 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q -ERR N ERR S ERR=$$EC^%ZOSV S @MAGGRY@(0)="0^4~"_ERR - D @^%ZOSF("ERRTN") - Q:$Q 1 Q - ; -SAVKPS(RARPT,INTERPFL,DATA,REPLY) ; Save study data: Key/Interpretation Images & Pres. State - ; RARPT--exam pointer - ; INTERPFL--1/0; 1=This is associated with a Rad Interpretation; Optional - ; DATA--array of input data; see structure at end of routine - ; REPLY--return string - N PSTRAK,IDATA,IMGCT,PSTOT,PSLINCT,PSKILCT,KEYCT,INTCT,STUDY,LINE,NEWIMG,NEWPS - N IMGREF,IMGIEN,PSIEN,SAVOP,STIEN,TYPE,IMG,ICT,NEWIMG,INITSTDY,SEQNUM - S INTERPFL=+$G(INTERPFL) - S NEWIMG=0,NEWPS=0,IMGIEN="",PSIEN="",SEQNUM=0 - S (IMGCT,PSTOT,PSLINCT,KEYCT,INTCT,PSKILCT)=0 - S IMGREF="",SAVOP="NOOP" - I '$D(TIMESTMP) N TIMESTMP S TIMESTMP=$$NOW^XLFDT() - ; 1st, process input in DATA - S IDATA="" - F S IDATA=$O(DATA(IDATA)) Q:IDATA="" S LINE=DATA(IDATA) I LINE]"" D - . I LINE="*IMAGE" S NEWIMG=1 Q - . I LINE="*PS" S NEWPS=1 Q - . I $E(LINE,1,4)="*END" S (NEWIMG,NEWPS)=0 Q - . I NEWIMG D IMGINIT(LINE) S NEWIMG=0 Q ; Init storage for this Image - . I NEWPS D PSINIT(LINE) S NEWPS=0 Q ; Init storage for a PS - . D @(SAVOP_"(LINE)") - ; Now update the Study node info - S INITSTDY=$S(INTERPFL:"INIT_STUDY",1:"") - S STIEN=$$STUDYID("",RARPT,1,INITSTDY) - I $D(PSTRAK) S IMG="" D ; Update key imgs in Study node - . F S IMG=$O(PSTRAK(IMG)) Q:'IMG S NEWIMG=1,TYPE="" D - . . F S TYPE=$O(PSTRAK(IMG,TYPE)) Q:TYPE="" D - . . . F ICT=1:1:PSTRAK(IMG,TYPE,0) D SAVKIMG(IMG,PSTRAK(IMG,TYPE,ICT),TYPE,NEWIMG) S NEWIMG=0 -SAVKPSZ ; - I IMGCT!PSTOT!PSLINCT!KEYCT!INTCT S REPLY="1~Saved: "_KEYCT_" Key Image"_$S(KEYCT-1:"s",1:"")_"; "_INTCT_" Interp Image"_$S(INTCT-1:"s",1:"")_"; " - I S REPLY=REPLY_PSLINCT_" PS line"_$S(PSLINCT-1:"s",1:"")_" for "_PSTOT_" PS"_$S(PSTOT-1:"s",1:"")_" for "_IMGCT_" Image"_$S(IMGCT-1:"s.",1:".") - I S:PSKILCT REPLY=REPLY_" Deleted: "_PSKILCT_" PS record"_$S(PSKILCT-1:"s",1:"")_"." - E I PSKILCT S REPLY="1~Deleted: "_PSKILCT_" PS record"_$S(PSKILCT-1:"s",1:"")_"." - E S REPLY="0~No Key Image/PS data was stored or deleted." - Q - ; -NOOP(X) Q ; do nothing/ skip erroneous input - ; -IMGINIT(LINE) ; Init storage space for an image ; inits some vars for the SAVE loop - N IEN - S IMGIEN="",IMGREF="" - S IEN=$P(LINE,U) - I IEN,$D(^MAG(2005,IEN,0)),'$D(^(1)) - E G IMGINITZ - S IMGIEN=IEN - S IMGREF=$NA(^MAG(2005,IMGIEN)) ; indirect ref used in psinit & savps - S IMGCT=IMGCT+1 -IMGINITZ Q - ; -PSINIT(LINE) ; Init storage space for a Presentation State ; inits some vars for SAVE loop - ; input = PS_UID ^ UID Type (KEY, INT) ^ "DELETE" - ; if peice 3 ="DELETE" then the PS data is deleted - N IEN,UID,TYPE,DELETE - S UID=$P(LINE,U),X=$P(LINE,U,2),DELETE=($P(LINE,U,3)="DELETE"),TYPE=$S(X="KEY":"K",X="INTERP":"I",1:"") - I UID="" G PSINITZ - I INTERPFL,(TYPE'="K"),(TYPE'="U") S TYPE="I" ; just in case... - S IEN=$O(@IMGREF@(210,"B",UID,"")) - L +@IMGREF@(210,0):5 - E Q - I 'IEN D ; Allocate node - . S X=$G(@IMGREF@(210,0)) I X="" S X="^2005.05A^^",^(0)=X - . S IEN=$P(X,U,3)+1,T=$P(X,U,4)+1,$P(X,U,3)=IEN,$P(X,U,4)=T - . S @IMGREF@(210,0)=X,@IMGREF@(210,"B",UID,IEN)="" - S PSIEN=IEN - I DELETE,PSIEN D ; delete this PS - . S PSKILCT=PSKILCT+1 - . K @IMGREF@(210,PSIEN),@IMGREF@(210,"B",UID,PSIEN) - . S T=$O(@IMGREF@(210,9999),-1) - . I 'T K @IMGREF@(210) Q ; no more PSs! - . N XD S XD=$G(@IMGREF@(210,0)) - . S $P(XD,U,3)=T,T=$P(XD,U,4) S:T T=T-1 S $P(XD,U,4)=T - . S @IMGREF@(210,0)=XD - E D ; init PS node for storage; PSTRAK keeps data for later update to STUDY file - . S @IMGREF@(210,PSIEN,0)=UID_U_TYPE_U_DUZ_U_TIMESTMP - . I "KI"[TYPE S SEQNUM=SEQNUM+1,T=$G(PSTRAK(IMGIEN,TYPE,0))+1,PSTRAK(IMGIEN,TYPE,0)=T,PSTRAK(IMGIEN,TYPE,T)=UID_U_SEQNUM - . K @IMGREF@(210,PSIEN,1) ; init Data & Keys - . S @IMGREF@(210,PSIEN,1,0)="^2005.51^0_U_0" - L -@IMGREF@(210,0) - S SAVOP="SAVPS" ; indirect label reference for use in SAVE loop - I DELETE S SAVOP="NOOP" - S PSTOT=PSTOT+1-DELETE -PSINITZ Q - ; -SAVPS(LINE) ; Save a line of PS data - ; input = line of free-text data - N PSCT,PSCTRL - L +(@IMGREF@(210,PSIEN)) - S PSCTRL=$G(@IMGREF@(210,PSIEN,1,0)) - S PSCT=+$P(PSCTRL,U,4)+1 - S @IMGREF@(210,PSIEN,1,PSCT,0)=LINE - S $P(PSCTRL,U,3,4)=PSCT_U_PSCT - S @IMGREF@(210,PSIEN,1,0)=PSCTRL - L -(@IMGREF@(210,PSIEN)) - S PSLINCT=PSLINCT+1 - Q - ; -SAVKIMG(IMGIEN,UIDSEQ,TYPE,NEWIMG) ; store a Key image & Interp images w/ PS refs in study node - ; - N STIEN,KIEN,STUDYREF,UID,SEQNUM - I 'IMGIEN G SAVKIMGZ - S STIEN=$$STUDYID(IMGIEN,"",0) - I 'STIEN G SAVKIMGZ ; should never happen - S STUDYREF=$NA(^MAG(2005.001,STIEN)) - S UID=$P(UIDSEQ,U),SEQNUM=$P(UIDSEQ,U,2) - S KIEN=$O(@STUDYREF@(1,"B",IMGIEN,"")) - I 'KIEN D - . L +@STUDYREF@(1,0) - . S X=$G(@STUDYREF@(1,0)) I X="" S X="^2005.031P^^",^(0)=X - . S KIEN=$P(X,U,3)+1,T=$P(X,U,4)+1,$P(X,U,3)=KIEN,$P(X,U,4)=T - . S @STUDYREF@(1,0)=X,@STUDYREF@(1,"B",IMGIEN,KIEN)="" - . L -@STUDYREF@(1,0) - E D - . I 'NEWIMG Q - . K @STUDYREF@(1,KIEN,1) ; init ps data if updating existing img - . S @STUDYREF@(1,KIEN,1,0)="^2005.311^0_U_0" - S $P(@STUDYREF@(1,KIEN,0),U)=IMGIEN - ; store the PS UID - I UID]"" D - . N IEN S IEN=$O(@STUDYREF@(1,KIEN,1,"B",UID,"")) - . I 'IEN D - . . L +@STUDYREF@(1,KIEN,1,0) - . . S X=$G(@STUDYREF@(1,KIEN,1,0)) I X="" S X="^2005.311^^",^(0)=X - . . S IEN=$P(X,U,3)+1,T=$P(X,U,4)+1,$P(X,U,3)=IEN,$P(X,U,4)=T - . . S @STUDYREF@(1,KIEN,1,0)=X,@STUDYREF@(1,KIEN,1,"B",UID,IEN)="" - . . L -@STUDYREF@(1,KIEN,1,0) - . S @STUDYREF@(1,KIEN,1,IEN,0)=UID_U_TYPE_U_SEQNUM - S KEYCT=KEYCT+(TYPE="K"),INTCT=INTCT+(TYPE="I") -SAVKIMGZ Q - ; -STUDYID(IEN,RARPT,READONLY,INITSTDY) ; return Study_IEN for input ImgIEN or RARPT - ; initialize Study node if INITSTDY is indicated (optional) - ; Either IEN or RARPT must be supplied; if both supplied, only RARPT is used - ; if READONLY is false, then create "STUDY" node if undefined - ; <*> Note: this routine is hard-coded for RADIOLOGY image data only (Parent file=74) - N STIEN,X,T,STDYINIT - S STIEN="" ; init return value - S IEN=$G(IEN),RARPT=$G(RARPT) - S:'$D(READONLY) READONLY=1 - S INITSTDY=$G(INITSTDY) - I IEN,'RARPT S RARPT=$$GETRPT(IEN) - I 'RARPT G STUDYIDZ - I $D(^MAG(2005.001,"ASTUDY",74,RARPT)) S STIEN=$O(^(RARPT,"")) D - . I INITSTDY="INIT_STUDY" K ^MAG(2005.001,STIEN,1) ; init for Key/Interp PS updates (full replacement) - E D:'READONLY ; create Study structure - . L +^MAG(2005.001,0) - . S X=^MAG(2005.001,0),STIEN=$P(X,U,3)+1,T=$P(X,U,4)+1,$P(X,U,3)=STIEN,$P(X,U,4)=T,^(0)=X - . L -^MAG(2005.001,0) - . S ^MAG(2005.001,STIEN,0)=RARPT_U_74,^MAG(2005.001,"ASTUDY",74,RARPT,STIEN)="",^MAG(2005.001,"B",RARPT,STIEN)="" - ; -STUDYIDZ Q:$Q STIEN Q - ; -GETRPT(IEN) ; return rarpt for input imgien - N IENGRP,X,RARPT - S RARPT="" - I IEN D - . I $D(^MAG(2005,IEN,1)) S IENGRP=IEN - . E S IENGRP=$P(^MAG(2005,IEN,0),U,10) - . I IENGRP S X=$G(^MAG(2005,IENGRP,2)) I $P(X,U,6)=74 S RARPT=$P(X,U,7) - . I RARPT,$D(^RARPT(RARPT,2005)) - . E S RARPT="" ; no Rad report node! - Q:$Q RARPT Q - ; - ;Structure of PS/PSTRAK data In: - ; *IMAGE - ; IEN^ - ; *PS - ; UID^[KEY/INTERP/USER] - ; 1: N Lines of PS data follow - ; *END_PS - ; *PS - ; UID^[KEY/INTERP/USER] - ; 1: N Lines of PS data follow - ; *END_PS - ; *END_IMAGE - ; *IMAGE - ; ... etc. - ; *END_IMAGE - ; *END -END ; +MAGJUPD2 ;WIRMFO/JHC VistaRad RPCs-Update PS & KEY Img ; 14 July 2004 10:05 AM + ;;3.0;IMAGING;**18**;Mar 07, 2006 + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q +ERR N ERR S ERR=$$EC^%ZOSV S @MAGGRY@(0)="0^4~"_ERR + D @^%ZOSF("ERRTN") + Q:$Q 1 Q + ; +SAVKPS(RARPT,INTERPFL,DATA,REPLY) ; Save study data: Key/Interpretation Images & Pres. State + ; RARPT--exam pointer + ; INTERPFL--1/0; 1=This is associated with a Rad Interpretation; Optional + ; DATA--array of input data; see structure at end of routine + ; REPLY--return string + N PSTRAK,IDATA,IMGCT,PSTOT,PSLINCT,PSKILCT,KEYCT,INTCT,STUDY,LINE,NEWIMG,NEWPS + N IMGREF,IMGIEN,PSIEN,SAVOP,STIEN,TYPE,IMG,ICT,NEWIMG,INITSTDY,SEQNUM + S INTERPFL=+$G(INTERPFL) + S NEWIMG=0,NEWPS=0,IMGIEN="",PSIEN="",SEQNUM=0 + S (IMGCT,PSTOT,PSLINCT,KEYCT,INTCT,PSKILCT)=0 + S IMGREF="",SAVOP="NOOP" + I '$D(TIMESTMP) N TIMESTMP D NOW^%DTC S TIMESTMP=% + ; 1st, process input in DATA + S IDATA="" + F S IDATA=$O(DATA(IDATA)) Q:IDATA="" S LINE=DATA(IDATA) I LINE]"" D + . I LINE="*IMAGE" S NEWIMG=1 Q + . I LINE="*PS" S NEWPS=1 Q + . I $E(LINE,1,4)="*END" S (NEWIMG,NEWPS)=0 Q + . I NEWIMG D IMGINIT(LINE) S NEWIMG=0 Q ; Init storage for this Image + . I NEWPS D PSINIT(LINE) S NEWPS=0 Q ; Init storage for a PS + . D @(SAVOP_"(LINE)") + ; Now update the Study node info + S INITSTDY=$S(INTERPFL:"INIT_STUDY",1:"") + S STIEN=$$STUDYID("",RARPT,1,INITSTDY) + I $D(PSTRAK) S IMG="" D ; Update key imgs in Study node + . F S IMG=$O(PSTRAK(IMG)) Q:'IMG S NEWIMG=1,TYPE="" D + . . F S TYPE=$O(PSTRAK(IMG,TYPE)) Q:TYPE="" D + . . . F ICT=1:1:PSTRAK(IMG,TYPE,0) D SAVKIMG(IMG,PSTRAK(IMG,TYPE,ICT),TYPE,NEWIMG) S NEWIMG=0 +SAVKPSZ ; + I IMGCT!PSTOT!PSLINCT!KEYCT!INTCT S REPLY="1~Saved: "_KEYCT_" Key Image"_$S(KEYCT-1:"s",1:"")_"; "_INTCT_" Interp Image"_$S(INTCT-1:"s",1:"")_"; " + I S REPLY=REPLY_PSLINCT_" PS line"_$S(PSLINCT-1:"s",1:"")_" for "_PSTOT_" PS"_$S(PSTOT-1:"s",1:"")_" for "_IMGCT_" Image"_$S(IMGCT-1:"s.",1:".") + I S:PSKILCT REPLY=REPLY_" Deleted: "_PSKILCT_" PS record"_$S(PSKILCT-1:"s",1:"")_"." + E I PSKILCT S REPLY="1~Deleted: "_PSKILCT_" PS record"_$S(PSKILCT-1:"s",1:"")_"." + E S REPLY="0~No Key Image/PS data was stored or deleted." + Q + ; +NOOP(X) Q ; do nothing/ skip erroneous input + ; +IMGINIT(LINE) ; Init storage space for an image ; inits some vars for the SAVE loop + N IEN + S IMGIEN="",IMGREF="" + S IEN=$P(LINE,U) + I IEN,$D(^MAG(2005,IEN,0)),'$D(^(1)) + E G IMGINITZ + S IMGIEN=IEN + S IMGREF=$NA(^MAG(2005,IMGIEN)) ; indirect ref used in psinit & savps + S IMGCT=IMGCT+1 +IMGINITZ Q + ; +PSINIT(LINE) ; Init storage space for a Presentation State ; inits some vars for SAVE loop + ; input = PS_UID ^ UID Type (KEY, INT) ^ "DELETE" + ; if peice 3 ="DELETE" then the PS data is deleted + N IEN,UID,TYPE,DELETE + S UID=$P(LINE,U),X=$P(LINE,U,2),DELETE=($P(LINE,U,3)="DELETE"),TYPE=$S(X="KEY":"K",X="INTERP":"I",1:"") + I UID="" G PSINITZ + I INTERPFL,(TYPE'="K"),(TYPE'="U") S TYPE="I" ; just in case... + S IEN=$O(@IMGREF@(210,"B",UID,"")) + L +@IMGREF@(210,0):5 + E Q + I 'IEN D ; Allocate node + . S X=$G(@IMGREF@(210,0)) I X="" S X="^2005.05A^^",^(0)=X + . S IEN=$P(X,U,3)+1,T=$P(X,U,4)+1,$P(X,U,3)=IEN,$P(X,U,4)=T + . S @IMGREF@(210,0)=X,@IMGREF@(210,"B",UID,IEN)="" + S PSIEN=IEN + I DELETE,PSIEN D ; delete this PS + . S PSKILCT=PSKILCT+1 + . K @IMGREF@(210,PSIEN),@IMGREF@(210,"B",UID,PSIEN) + . S T=$O(@IMGREF@(210,9999),-1) + . I 'T K @IMGREF@(210) Q ; no more PSs! + . N XD S XD=$G(@IMGREF@(210,0)) + . S $P(XD,U,3)=T,T=$P(XD,U,4) S:T T=T-1 S $P(XD,U,4)=T + . S @IMGREF@(210,0)=XD + E D ; init PS node for storage; PSTRAK keeps data for later update to STUDY file + . S @IMGREF@(210,PSIEN,0)=UID_U_TYPE_U_DUZ_U_TIMESTMP + . I "KI"[TYPE S SEQNUM=SEQNUM+1,T=$G(PSTRAK(IMGIEN,TYPE,0))+1,PSTRAK(IMGIEN,TYPE,0)=T,PSTRAK(IMGIEN,TYPE,T)=UID_U_SEQNUM + . K @IMGREF@(210,PSIEN,1) ; init Data & Keys + . S @IMGREF@(210,PSIEN,1,0)="^2005.51^0_U_0" + L -@IMGREF@(210,0) + S SAVOP="SAVPS" ; indirect label reference for use in SAVE loop + I DELETE S SAVOP="NOOP" + S PSTOT=PSTOT+1-DELETE +PSINITZ Q + ; +SAVPS(LINE) ; Save a line of PS data + ; input = line of free-text data + N PSCT,PSCTRL + L +(@IMGREF@(210,PSIEN)) + S PSCTRL=$G(@IMGREF@(210,PSIEN,1,0)) + S PSCT=+$P(PSCTRL,U,4)+1 + S @IMGREF@(210,PSIEN,1,PSCT,0)=LINE + S $P(PSCTRL,U,3,4)=PSCT_U_PSCT + S @IMGREF@(210,PSIEN,1,0)=PSCTRL + L -(@IMGREF@(210,PSIEN)) + S PSLINCT=PSLINCT+1 + Q + ; +SAVKIMG(IMGIEN,UIDSEQ,TYPE,NEWIMG) ; store a Key image & Interp images w/ PS refs in study node + ; + N STIEN,KIEN,STUDYREF,UID,SEQNUM + I 'IMGIEN G SAVKIMGZ + S STIEN=$$STUDYID(IMGIEN,"",0) + I 'STIEN G SAVKIMGZ ; should never happen + S STUDYREF=$NA(^MAG(2005.001,STIEN)) + S UID=$P(UIDSEQ,U),SEQNUM=$P(UIDSEQ,U,2) + S KIEN=$O(@STUDYREF@(1,"B",IMGIEN,"")) + I 'KIEN D + . L +@STUDYREF@(1,0) + . S X=$G(@STUDYREF@(1,0)) I X="" S X="^2005.031P^^",^(0)=X + . S KIEN=$P(X,U,3)+1,T=$P(X,U,4)+1,$P(X,U,3)=KIEN,$P(X,U,4)=T + . S @STUDYREF@(1,0)=X,@STUDYREF@(1,"B",IMGIEN,KIEN)="" + . L -@STUDYREF@(1,0) + E D + . I 'NEWIMG Q + . K @STUDYREF@(1,KIEN,1) ; init ps data if updating existing img + . S @STUDYREF@(1,KIEN,1,0)="^2005.311^0_U_0" + S $P(@STUDYREF@(1,KIEN,0),U)=IMGIEN + ; store the PS UID + I UID]"" D + . N IEN S IEN=$O(@STUDYREF@(1,KIEN,1,"B",UID,"")) + . I 'IEN D + . . L +@STUDYREF@(1,KIEN,1,0) + . . S X=$G(@STUDYREF@(1,KIEN,1,0)) I X="" S X="^2005.311^^",^(0)=X + . . S IEN=$P(X,U,3)+1,T=$P(X,U,4)+1,$P(X,U,3)=IEN,$P(X,U,4)=T + . . S @STUDYREF@(1,KIEN,1,0)=X,@STUDYREF@(1,KIEN,1,"B",UID,IEN)="" + . . L -@STUDYREF@(1,KIEN,1,0) + . S @STUDYREF@(1,KIEN,1,IEN,0)=UID_U_TYPE_U_SEQNUM + S KEYCT=KEYCT+(TYPE="K"),INTCT=INTCT+(TYPE="I") +SAVKIMGZ Q + ; +STUDYID(IEN,RARPT,READONLY,INITSTDY) ; return Study_IEN for input ImgIEN or RARPT + ; initialize Study node if INITSTDY is indicated (optional) + ; Either IEN or RARPT must be supplied; if both supplied, only RARPT is used + ; if READONLY is false, then create "STUDY" node if undefined + ; <*> Note: this routine is hard-coded for RADIOLOGY image data only (Parent file=74) + N STIEN,X,T,STDYINIT + S STIEN="" ; init return value + S IEN=$G(IEN),RARPT=$G(RARPT) + S:'$D(READONLY) READONLY=1 + S INITSTDY=$G(INITSTDY) + I IEN,'RARPT S RARPT=$$GETRPT(IEN) + I 'RARPT G STUDYIDZ + I $D(^MAG(2005.001,"ASTUDY",74,RARPT)) S STIEN=$O(^(RARPT,"")) D + . I INITSTDY="INIT_STUDY" K ^MAG(2005.001,STIEN,1) ; init for Key/Interp PS updates (full replacement) + E D:'READONLY ; create Study structure + . L +^MAG(2005.001,0) + . S X=^MAG(2005.001,0),STIEN=$P(X,U,3)+1,T=$P(X,U,4)+1,$P(X,U,3)=STIEN,$P(X,U,4)=T,^(0)=X + . L -^MAG(2005.001,0) + . S ^MAG(2005.001,STIEN,0)=RARPT_U_74,^MAG(2005.001,"ASTUDY",74,RARPT,STIEN)="",^MAG(2005.001,"B",RARPT,STIEN)="" + ; +STUDYIDZ Q:$Q STIEN Q + ; +GETRPT(IEN) ; return rarpt for input imgien + N IENGRP,X,RARPT + S RARPT="" + I IEN D + . I $D(^MAG(2005,IEN,1)) S IENGRP=IEN + . E S IENGRP=$P(^MAG(2005,IEN,0),U,10) + . I IENGRP S X=$G(^MAG(2005,IENGRP,2)) I $P(X,U,6)=74 S RARPT=$P(X,U,7) + . I RARPT,$D(^RARPT(RARPT,2005)) + . E S RARPT="" ; no Rad report node! + Q:$Q RARPT Q + ; + ;Structure of PS/PSTRAK data In: + ; *IMAGE + ; IEN^ + ; *PS + ; UID^[KEY/INTERP/USER] + ; 1: N Lines of PS data follow + ; *END_PS + ; *PS + ; UID^[KEY/INTERP/USER] + ; 1: N Lines of PS data follow + ; *END_PS + ; *END_IMAGE + ; *IMAGE + ; ... etc. + ; *END_IMAGE + ; *END +END ; diff --git a/r/IMAGING-MAG-ZMAG/MAGJUTL1.m b/r/IMAGING-MAG-ZMAG/MAGJUTL1.m index 9639e9d0..355ba86a 100644 --- a/r/IMAGING-MAG-ZMAG/MAGJUTL1.m +++ b/r/IMAGING-MAG-ZMAG/MAGJUTL1.m @@ -1,201 +1,197 @@ -MAGJUTL1 ;WIRMFO/JHC VistARad subroutines for RPC calls ; 29 Jul 2003 10:03 AM - ;;3.0;IMAGING;**22,18,65,76**;Jun 22, 2007;Build 19 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q - ;<*>Notes on possible changes to ^RAO7PC1/1A for fetching rad pkg data: - ; 1) Return also: Exam Status IEN, Order Request Urgency, & Pre-Op Date - ; 2) Allow to retrieve one specific exam; e.g. modify SETDATA^RAO7PC1A - ; to act as a true subrtn, W/ params for RADFN, RADTI, & RACNI--if - ; passed, then only the one exam would be returned - ; -GETEXAM3(DFN,BEGDT,ENDT,MAGRACNT,MAGRET,MORE,LIMEXAMS) ; Get data for all exams for a - ; pt within a date range - ; limit to LIMEXAMS entries--note, only PREFETCH & Auto-route Priors use this - ; Input: - ; DFN -- Patient DFN - ; BEGDT -- Opt, earliest date desired - ; ENDT -- Opt, latest date desired - ; MAGRACNT -- Opt, pass by ref to init counter to ref return data in ^TMP (see GETEXSET) - ; MORE -- Opt, If True, check for additional exams for pt - ; LIMEXAMS -- Opt, limit # exams to return - ; Return: - ; MAGRACNT -- highest counter for return data - ; MAGRET -- 1/0: exam was/not found - ; MORE -- more exams exist for pt on & B4 this date - ; ^TMP -- data returned (see GETEXSET) - ; - I '$D(DT) N DIQUIET S DIQUIET=1 D DT^DICRW - S LIMEXAMS=+$G(LIMEXAMS) - S:$G(BEGDT)="" BEGDT=2010101 S:$G(ENDT)="" ENDT=DT ; default all dates - N MORECHK S MORECHK=+$G(MORE) - S MAGRACNT=+$G(MAGRACNT),MAGRET=0,MORE=0 ; Init return data - I BEGDT>ENDT S X=ENDT,ENDT=BEGDT,BEGDT=X - I '(DFN&BEGDT&ENDT) Q - K ^TMP($J,"RAE1") D EN1^RAO7PC1(DFN,BEGDT,ENDT,LIMEXAMS) - N EXID,TMP,EX1,EX2 S EXID=0 - F MAGRET=0:1 S EXID=$O(^TMP($J,"RAE1",DFN,EXID)) Q:'EXID S TMP($P(EXID,"-"),$P(EXID,"-",2))=EXID - S (EX1,EX2)="" - F S EX1=$O(TMP(EX1)) Q:'EX1 F S EX2=$O(TMP(EX1,EX2)) Q:'EX2 D GETEXSET(DFN,TMP(EX1,EX2),"") - K ^TMP($J,"RAE1") - I 'MORECHK Q ; all done; else indicate if pt has more exams - N DTI,CNI,STS,DTCHK - I 'MAGRET S DTI=9999999.9999-BEGDT,CNI=0 ; no exam found in orig dt range - E S X=^TMP($J,"MAGRAEX",MAGRACNT,1),DTI=$P(X,U,2),CNI=$P(X,U,3) ; last exam processed - ; loop thru addl exams til find one that is NOT Cancelled -MORE1 F S CNI=$O(^RADPT(DFN,"DT",DTI,"P",CNI)) Q:'CNI S STS=$P($G(^(CNI,0)),U,3) I STS]"" D Q:MORE - . Q:($P($G(^RA(72,STS,0)),U,3)=0) ; Canceled--keep looking - . S DTCHK=9999999.9999-DTI D EN1^RAO7PC1(DFN,DTCHK,DTCHK,1) ; verify there is at least one "good" exam for this date (Remedy #200480) - . I +$O(^TMP($J,"RAE1",DFN,0)) S MORE=1 - . K ^TMP($J,"RAE1") - I 'MORE S DTI=$O(^RADPT(DFN,"DT",DTI)),CNI=0 G MORE1:DTI - I MORE S MORE=9999999.9999-DTI\1 - Q - ; -GETEXAM2(DFN,DTI,CNI,MAGRACNT,MAGRET) ; Fetch data for one exam - ;Input: - ; DFN -- Pt DFN - ; DTI -- Internal Date pointer to Rad exam - ; CNI -- Case pointer to Rad exam - ; MAGRACNT -- Opt, pass by ref to init counter for return data in ^TMP (see GETEXSET) - ; Return: - ; MAGRACNT -- highest counter for return data - ; MAGRET -- 1/0: exam was/not found - ; ^TMP -- data returned (see GETEXSET) - ; - ; This subroutine calls RAO7PC1A directly to fetch exam data - ; which is returned in ^TMP($J,"RAE1",DFN,DTI_"-"_CNI). - ; RAO7PC1A currently returns ALL exams filed under one DTI, - ; but this subroutine returns the single exam for the input DTI, CNI - ; - N RADFN,RACNT,RAIBDT,RAEXN,RAXIT ; Vars input to RAO7PC1A - S RADFN=DFN,RACNT=0,RAIBDT=DTI,RAEXN=0,RAXIT=0 - ; other Vars set by RAO7PC1A: - N RABNOR,RACSE,RADIAG,RANO,RAPRC,RAREX,RARPT,RARPTST,RASTNM,RAXAM,RAXID - N RABNORMR,RACPT - S MAGRACNT=+$G(MAGRACNT) - K ^TMP($J,"RAE1") D SETDATA^RAO7PC1A - S MAGRET=RACNT Q:'RACNT ; no exams found - D GETEXSET(DFN,DTI_"-"_CNI,.X) - I 'X S MAGRET=0 ; no exam for this CNI - K ^TMP($J,"RAE1") - Q - ; -GETEXSET(RADFN,EXID,MAGRET) ; - ; Used by GETEXAM* subroutines above to set up rad data for vrad - ; Input: - ; RADFN -- Pt DFN - ; EXID --- RADTI_"-"_RACNI, pointers to Rad exam - ; Output: - ; MAGRET- 1/0: an exam was/was not filed - ; ^TMP($J,"MAGRAEX",MAGRACNT)=Data String (see code at end) - ; MAGRACNT described in above subroutines - ; - N RACN,RACNI,RADATA,RADATE,RADTE,RADTI,RADTPRT,RAELOC,RANME - N RAPRC,RARPT,RASSN,RAST,RASTORD,RASTP,RASTNM,RACPT,IMTYPABB,PROCMOD - N DAYCASE,REQLOC,REQLOCN,REQLOCA,REQLOCT,RIST,RIST1,RIST2,COMPLIC - N RADIV,RISTISME,REQWARD,RASTCAT,CPTMOD,LRFLAG,MODTXT - S MAGRET=0,RADTI=$P(EXID,"-"),RACNI=$P(EXID,"-",2) - Q:'(RADTI&RACNI) - S RADIV="" - S RADATA=$G(^TMP($J,"RAE1",RADFN,EXID)) - Q:RADATA="" ; no exam for this EXID - S RARPT=$P(RADATA,U,5) - S X=$P(RADATA,U,6),RASTORD=$P(X,"~"),RASTNM=$P(X,"~",2) - S X=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),COMPLIC=$D(^("COMP")),PROCMOD=$D(^("M")),CPTMOD=$D(^("CMOD")) - S RAST=$P(X,U,3),REQLOC=$P(X,U,22),RIST1=$P(X,U,12),RIST2=$P(X,U,15),COMPLIC=$P(X,U,16)_"~"_COMPLIC - S REQWARD=$P(X,U,6) - N CT,MODS,IEN,TT ; Process Proc/CPT Modifier info - S CT=0 - I PROCMOD D - . S IEN=0 - . F S IEN=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",IEN)) Q:'IEN S X=$P($G(^(IEN,0)),U) I X D - . . S X=$P($G(^RAMIS(71.2,X,0)),U) Q:X="" S X=$$TRIM(X) - . . S X=$S(X="BILATERAL EXAM":"BILAT",1:X) - . . S CT=CT+1,MODS(CT)=X - I CPTMOD D - . S IEN=0 - . F S IEN=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",IEN)) Q:'IEN S X=$P($G(^(IEN,0)),U) I X D - . . S X=$P($$MOD^ICPTMOD(X,"I"),U,3) Q:X="" S X=$$TRIM(X) - . . S X=$S(X="LEFT SIDE":"LEFT",X="RIGHT SIDE":"RIGHT",X="BILATERAL PROCEDURE":"BILAT",1:X) - . . S CT=CT+1,MODS(CT)=X - S MODTXT="",LRFLAG=0 K TT - I CT F I=1:1:CT S X=MODS(I) D - . ; eliminate redundant values for L/R/Bilat (TT), & track L/R for prior matching (LRFLAG) - . S T=(X="LEFT") I T,$D(TT(1)) Q ; already got it - . I 'T S T=(X="RIGHT") I T S T=2 I T,$D(TT(2)) Q ; ditto - . I 'T S T=(X="BILAT") I T S T=3 I T,$D(TT(3)) Q ; ditto - . I T S TT(T)="",MODTXT=X_$S(MODTXT="":"",1:";")_MODTXT ; force L/R/Bilat to left end of string .. - . E S MODTXT=MODTXT_$S(MODTXT="":"",1:";")_X ; .. so is easier to spot in displayed column - . I 'LRFLAG S:T LRFLAG=T - . E I T S:(LRFLAG'=T) LRFLAG=3 ; L&R or Bilat--ignore result - S LRFLAG=$S(LRFLAG=1:"L",LRFLAG=2:"R",1:"") ; Left/Right indicator - S RADIV=$P(^RADPT(RADFN,"DT",RADTI,0),U,3) - K DIC,DR,DA,DIQ - I 'REQLOC S (REQLOCN,REQLOCT,REQLOCA)="" - E D - . S X=$G(^SC(REQLOC,0)),REQLOCN=$P(X,U),REQLOCA=$P(X,U,2) - . S:REQLOCA="" REQLOCA=REQLOCN - . S DIC="44",DR="2",DA=REQLOC,DIQ="REQLOCT" D EN^DIQ1 K DIC,DR,DA,DIQ - . S REQLOCT=REQLOCT(44,REQLOC,2) - I REQWARD]"" S DIC="42",DR=".01",DA=REQWARD,DIQ="REQWARD" D EN^DIQ1 K DIC,DR,DA,DIQ S REQWARD=REQWARD(42,REQWARD,.01) - S X=$$RIST(RIST1,RIST2),RIST=$P(X,U),RISTISME=$P(X,U,2) - S RADTE=9999999.9999-RADTI,(RADTPRT,Y)=RADTE D D^RAUTL S RADATE=Y - S RADTPRT=$E(RADTPRT,4,5)_"/"_$E(RADTPRT,6,7)_"/"_$E(RADTPRT,2,3) - S RAPRC=$E($P(RADATA,U),1,40),RACN=$P(RADATA,U,2),RAELOC=$P(RADATA,U,7) - S IMTYPABB=$P($P(RADATA,U,8),"~"),RACPT=$P(RADATA,U,10) - S DAYCASE=$E(RADTE,4,7)_$E(RADTE,2,3)_"-"_RACN - S RASTP=RASTNM,RASTCAT="" - I RAST S RASTCAT=$P($G(^RA(72,RAST,0)),U,9) - S RANME=$P(^DPT(RADFN,0),U) - S DFN=RADFN D PID^VADPT6 S RASSN=$S(VAERR:"Unknown",1:VA("PID")) - K VA("PID"),VA("BID"),VAERR - S MAGRACNT=$G(MAGRACNT)+1 - I MAGRACNT=1 K ^TMP($J,"MAGRAEX") - S ^TMP($J,"MAGRAEX",MAGRACNT,1)=RADFN_U_RADTI_U_RACNI_U_$E(RANME,1,30)_U_RASSN_U_RADATE_U_RADTE_U_RACN_U_$E(RAPRC,1,35)_U_RARPT_U_RAST_U_DAYCASE_U_RAELOC_U_RASTP_U_RASTORD_U_RADTPRT_U_RACPT_U_IMTYPABB - S ^TMP($J,"MAGRAEX",MAGRACNT,2)=REQLOCA_U_$E(REQLOCN,1,25)_U_RIST_U_COMPLIC_U_RADIV_U_$P($$IMGSIT(RADIV),U,2)_U_RISTISME_U_MODTXT_U_REQLOCT_U_REQWARD_U_RASTCAT_U_LRFLAG - S MAGRET=1 - Q - ; -RIST(RIST1,RIST2) ; return Interp Radiologist info - S RIST1=$G(RIST1),RIST2=$G(RIST2) - N RIST,RISTISME - S (RIST,RISTISME)="" - I RIST1!RIST2 D - . I RIST1 S RISTISME=RIST1=DUZ S RIST=$$USERINF^MAGJUTL3(RIST1,1) - . I RIST2 S:'RISTISME RISTISME=RIST2=DUZ S RIST2=$$USERINF^MAGJUTL3(RIST2,1) - . I RIST]"" S RIST=RIST_$S(RIST2]"":"/"_RIST2,1:"") - . E S RIST=RIST2 - Q RIST_U_RISTISME - ; -IMGSIT(DIV,DFLT) ; Return Imaging Site code for input Division - ; From 2006.1: IEN ^ Site Code ^ Parent_DIV - I DIV]"" D - . N IEN I $D(^MAG(2006.1,"B",DIV)) S IEN=$O(^(DIV,"")) I IEN - . E I $G(DFLT) S IEN=$O(^MAG(2006.1,0)) ; Dflt to 1st if requested - . E S X="" Q - . S X=^MAG(2006.1,IEN,0),X=IEN_U_$P(X,U,9)_U_$P(X,U) - Q X - ; -TRIM(X) ; Trim trailing spaces from X - I $G(X)]"" D - . F I=$L(X):-1:0 I $E(X,I)'=" " Q - . I I S X=$E(X,1,I) - . E S X="" - Q:$Q X Q - ; -END Q ; +MAGJUTL1 ;WIRMFO/JHC VistARad subroutines for RPC calls ; 29 Jul 2003 10:03 AM + ;;3.0;IMAGING;**22,18,65**;Jul 27, 2006;Build 28 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q + ;<*>Notes on possible changes to ^RAO7PC1/1A for fetching rad pkg data: + ; 1) Return also: Exam Status IEN, Order Request Urgency, & Pre-Op Date + ; 2) Allow to retrieve one specific exam; e.g. modify SETDATA^RAO7PC1A + ; to act as a true subrtn, W/ params for RADFN, RADTI, & RACNI--if + ; passed, then only the one exam would be returned + ; +GETEXAM3(DFN,BEGDT,ENDT,MAGRACNT,MAGRET,MORE,LIMEXAMS) ; Get data for all exams for a + ; pt within a date range (default all dates); limit returned list to LIMEXAMS + ; Input: + ; DFN -- Patient DFN + ; BEGDT -- Opt, earliest date desired + ; ENDT -- Opt, latest date desired + ; MAGRACNT -- Opt, pass by ref to init counter to ref return data in ^TMP (see GETEXSET) + ; LIMEXAMS -- Opt, limit # exams to return + ; Return: + ; MAGRACNT -- highest counter for return data + ; MAGRET -- 1/0: exam was/not found + ; MORE -- more exams exist for pt on & B4 this date + ; ^TMP -- data returned (see GETEXSET) + ; + I '$D(DT) N DIQUIET S DIQUIET=1 D DT^DICRW + N MORECHK + S LIMEXAMS=+$G(LIMEXAMS) + S MORECHK=BEGDT!LIMEXAMS + S:$G(BEGDT)="" BEGDT=2010101 S:$G(ENDT)="" ENDT=DT ; default all dates + S MAGRACNT=+$G(MAGRACNT),MAGRET=0,MORE=0 ; Init return data + I BEGDT>ENDT S X=ENDT,ENDT=BEGDT,BEGDT=X + I '(DFN&BEGDT&ENDT) Q + K ^TMP($J,"RAE1") D EN1^RAO7PC1(DFN,BEGDT,ENDT,LIMEXAMS) + N EXID,TMP,EX1,EX2 S EXID=0 + F MAGRET=0:1 S EXID=$O(^TMP($J,"RAE1",DFN,EXID)) Q:'EXID S TMP($P(EXID,"-"),$P(EXID,"-",2))=EXID + S (EX1,EX2)="" + F S EX1=$O(TMP(EX1)) Q:'EX1 F S EX2=$O(TMP(EX1,EX2)) Q:'EX2 D GETEXSET(DFN,TMP(EX1,EX2),"") + K ^TMP($J,"RAE1") + I 'MORECHK Q ; all done; else indicate if pt has more exams + N DTI,CNI,STS + I 'MAGRET S DTI=9999999.9999-BEGDT,CNI=0 ; no exam found in orig dt range + E S X=^TMP($J,"MAGRAEX",MAGRACNT,1),DTI=$P(X,U,2),CNI=$P(X,U,3) ; last exam processed + ; loop thru addl exams til find one that is NOT Cancelled +MORE1 F S CNI=$O(^RADPT(DFN,"DT",DTI,"P",CNI)) Q:'CNI S STS=$P($G(^(CNI,0)),U,3) I STS]"" D Q:MORE + . S MORE='($P($G(^RA(72,STS,0)),U,3)=0) ; True if sts is NOT Canc + I 'MORE S DTI=$O(^RADPT(DFN,"DT",DTI)),CNI=0 G MORE1:DTI + I MORE S MORE=9999999.9999-DTI\1 + Q + ; +GETEXAM2(DFN,DTI,CNI,MAGRACNT,MAGRET) ; Fetch data for one exam + ;Input: + ; DFN -- Pt DFN + ; DTI -- Internal Date pointer to Rad exam + ; CNI -- Case pointer to Rad exam + ; MAGRACNT -- Opt, pass by ref to init counter for return data in ^TMP (see GETEXSET) + ; Return: + ; MAGRACNT -- highest counter for return data + ; MAGRET -- 1/0: exam was/not found + ; ^TMP -- data returned (see GETEXSET) + ; + ; This subroutine calls RAO7PC1A directly to fetch exam data + ; which is returned in ^TMP($J,"RAE1",DFN,DTI_"-"_CNI). + ; RAO7PC1A currently returns ALL exams filed under one DTI, + ; but this subroutine returns the single exam for the input DTI, CNI + ; + N RADFN,RACNT,RAIBDT,RAEXN,RAXIT ; Vars input to RAO7PC1A + S RADFN=DFN,RACNT=0,RAIBDT=DTI,RAEXN=0,RAXIT=0 + ; other Vars set by RAO7PC1A: + N RABNOR,RACSE,RADIAG,RANO,RAPRC,RAREX,RARPT,RARPTST,RASTNM,RAXAM,RAXID + N RABNORMR,RACPT + S MAGRACNT=+$G(MAGRACNT) + K ^TMP($J,"RAE1") D SETDATA^RAO7PC1A + S MAGRET=RACNT Q:'RACNT ; no exams found + D GETEXSET(DFN,DTI_"-"_CNI,.X) + I 'X S MAGRET=0 ; no exam for this CNI + K ^TMP($J,"RAE1") + Q + ; +GETEXSET(RADFN,EXID,MAGRET) ; + ; Used by GETEXAM* subroutines above to set up rad data for vrad + ; Input: + ; RADFN -- Pt DFN + ; EXID --- RADTI_"-"_RACNI, pointers to Rad exam + ; Output: + ; MAGRET- 1/0: an exam was/was not filed + ; ^TMP($J,"MAGRAEX",MAGRACNT)=Data String (see code at end) + ; MAGRACNT described in above subroutines + ; + N RACN,RACNI,RADATA,RADATE,RADTE,RADTI,RADTPRT,RAELOC,RANME + N RAPRC,RARPT,RASSN,RAST,RASTORD,RASTP,RASTNM,RACPT,IMTYPABB,PROCMOD + N DAYCASE,REQLOC,REQLOCN,REQLOCA,REQLOCT,RIST,RIST1,RIST2,COMPLIC + N RADIV,RISTISME,REQWARD,RASTCAT,CPTMOD,LRFLAG,MODTXT + S MAGRET=0,RADTI=$P(EXID,"-"),RACNI=$P(EXID,"-",2) + Q:'(RADTI&RACNI) + S RADIV="" + S RADATA=$G(^TMP($J,"RAE1",RADFN,EXID)) + Q:RADATA="" ; no exam for this EXID + S RARPT=$P(RADATA,U,5) + S X=$P(RADATA,U,6),RASTORD=$P(X,"~"),RASTNM=$P(X,"~",2) + S X=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),COMPLIC=$D(^("COMP")),PROCMOD=$D(^("M")),CPTMOD=$D(^("CMOD")) + S RAST=$P(X,U,3),REQLOC=$P(X,U,22),RIST1=$P(X,U,12),RIST2=$P(X,U,15),COMPLIC=$P(X,U,16)_"~"_COMPLIC + S REQWARD=$P(X,U,6) + N CT,MODS,IEN,TT ; Process Proc/CPT Modifier info + S CT=0 + I PROCMOD D + . S IEN=0 + . F S IEN=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",IEN)) Q:'IEN S X=$P($G(^(IEN,0)),U) I X D + . . S X=$P($G(^RAMIS(71.2,X,0)),U) Q:X="" S X=$$TRIM(X) + . . S X=$S(X="BILATERAL EXAM":"BILAT",1:X) + . . S CT=CT+1,MODS(CT)=X + I CPTMOD D + . S IEN=0 + . F S IEN=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",IEN)) Q:'IEN S X=$P($G(^(IEN,0)),U) I X D + . . S X=$P($G(^DIC(81.3,X,0)),U,2) Q:X="" S X=$$TRIM(X) + . . S X=$S(X="LEFT SIDE":"LEFT",X="RIGHT SIDE":"RIGHT",X="BILATERAL PROCEDURE":"BILAT",1:X) + . . S CT=CT+1,MODS(CT)=X + S MODTXT="",LRFLAG=0 K TT + I CT F I=1:1:CT S X=MODS(I) D + . ; eliminate redundant values for L/R/Bilat (TT), & track L/R for prior matching (LRFLAG) + . S T=(X="LEFT") I T,$D(TT(1)) Q ; already got it + . I 'T S T=(X="RIGHT") I T S T=2 I T,$D(TT(2)) Q ; ditto + . I 'T S T=(X="BILAT") I T S T=3 I T,$D(TT(3)) Q ; ditto + . I T S TT(T)="",MODTXT=X_$S(MODTXT="":"",1:";")_MODTXT ; force L/R/Bilat to left end of string .. + . E S MODTXT=MODTXT_$S(MODTXT="":"",1:";")_X ; .. so is easier to spot in displayed column + . I 'LRFLAG S:T LRFLAG=T + . E I T S:(LRFLAG'=T) LRFLAG=3 ; L&R or Bilat--ignore result + S LRFLAG=$S(LRFLAG=1:"L",LRFLAG=2:"R",1:"") ; Left/Right indicator + S RADIV=$P(^RADPT(RADFN,"DT",RADTI,0),U,3) + K DIC,DR,DA,DIQ + I 'REQLOC S (REQLOCN,REQLOCT,REQLOCA)="" + E D + . S X=$G(^SC(REQLOC,0)),REQLOCN=$P(X,U),REQLOCA=$P(X,U,2) + . S:REQLOCA="" REQLOCA=REQLOCN + . S DIC="44",DR="2",DA=REQLOC,DIQ="REQLOCT" D EN^DIQ1 K DIC,DR,DA,DIQ + . S REQLOCT=REQLOCT(44,REQLOC,2) + I REQWARD]"" S DIC="42",DR=".01",DA=REQWARD,DIQ="REQWARD" D EN^DIQ1 K DIC,DR,DA,DIQ S REQWARD=REQWARD(42,REQWARD,.01) + S X=$$RIST(RIST1,RIST2),RIST=$P(X,U),RISTISME=$P(X,U,2) + S RADTE=9999999.9999-RADTI,(RADTPRT,Y)=RADTE D D^RAUTL S RADATE=Y + S RADTPRT=$E(RADTPRT,4,5)_"/"_$E(RADTPRT,6,7)_"/"_$E(RADTPRT,2,3) + S RAPRC=$E($P(RADATA,U),1,40),RACN=$P(RADATA,U,2),RAELOC=$P(RADATA,U,7) + S IMTYPABB=$P($P(RADATA,U,8),"~"),RACPT=$P(RADATA,U,10) + S DAYCASE=$E(RADTE,4,7)_$E(RADTE,2,3)_"-"_RACN + S RASTP=RASTNM,RASTCAT="" + I RAST S RASTCAT=$P($G(^RA(72,RAST,0)),U,9) + S RANME=$P(^DPT(RADFN,0),U) + S DFN=RADFN D PID^VADPT6 S RASSN=$S(VAERR:"Unknown",1:VA("PID")) + K VA("PID"),VA("BID"),VAERR + S MAGRACNT=$G(MAGRACNT)+1 + I MAGRACNT=1 K ^TMP($J,"MAGRAEX") + S ^TMP($J,"MAGRAEX",MAGRACNT,1)=RADFN_U_RADTI_U_RACNI_U_$E(RANME,1,30)_U_RASSN_U_RADATE_U_RADTE_U_RACN_U_$E(RAPRC,1,35)_U_RARPT_U_RAST_U_DAYCASE_U_RAELOC_U_RASTP_U_RASTORD_U_RADTPRT_U_RACPT_U_IMTYPABB + S ^TMP($J,"MAGRAEX",MAGRACNT,2)=REQLOCA_U_$E(REQLOCN,1,25)_U_RIST_U_COMPLIC_U_RADIV_U_$P($$IMGSIT(RADIV),U,2)_U_RISTISME_U_MODTXT_U_REQLOCT_U_REQWARD_U_RASTCAT_U_LRFLAG + S MAGRET=1 + Q + ; +RIST(RIST1,RIST2) ; return Interp Radiologist info + S RIST1=$G(RIST1),RIST2=$G(RIST2) + N RIST,RISTISME + S (RIST,RISTISME)="" + I RIST1!RIST2 D + . I RIST1 S RISTISME=RIST1=DUZ S RIST=$$USERINF^MAGJUTL3(RIST1,1) + . I RIST2 S:'RISTISME RISTISME=RIST2=DUZ S RIST2=$$USERINF^MAGJUTL3(RIST2,1) + . I RIST]"" S RIST=RIST_$S(RIST2]"":"/"_RIST2,1:"") + . E S RIST=RIST2 + Q RIST_U_RISTISME + ; +IMGSIT(DIV,DFLT) ; Return Imaging Site code for input Division + ; From 2006.1: IEN ^ Site Code ^ Parent_DIV + I DIV]"" D + . N IEN I $D(^MAG(2006.1,"B",DIV)) S IEN=$O(^(DIV,"")) I IEN + . E I $G(DFLT) S IEN=$O(^MAG(2006.1,0)) ; Dflt to 1st if requested + . E S X="" Q + . S X=^MAG(2006.1,IEN,0),X=IEN_U_$P(X,U,9)_U_$P(X,U) + Q X + ; +TRIM(X) ; Trim trailing spaces from X + I $G(X)]"" D + . F I=$L(X):-1:0 I $E(X,I)'=" " Q + . I I S X=$E(X,1,I) + . E S X="" + Q:$Q X Q + ; +END Q ; diff --git a/r/IMAGING-MAG-ZMAG/MAGJUTL2.m b/r/IMAGING-MAG-ZMAG/MAGJUTL2.m index 2d611efc..c0b6fe82 100644 --- a/r/IMAGING-MAG-ZMAG/MAGJUTL2.m +++ b/r/IMAGING-MAG-ZMAG/MAGJUTL2.m @@ -1,174 +1,173 @@ -MAGJUTL2 ;WIRMFO/JHC VistRad subroutines for RPC calls[ 2/21/97 10:53 AM ] ; 22 Mar 2001 2:24 PM - ;;3.0;IMAGING;**18,65,76**;Jun 22, 2007;Build 19 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q -IMGINFO(RARPT,RET) ; Fetch info from Image File for input RARPT: - ; Input: RARPT: Rad Report pointer - ; RET: see below - ; RET contents delimited by ^: - ; CT = # of images for case - ; ONL = Image Storage status (Y=On Magnetic disk, N=Jukebox - ; "n/a" for not available, e.g., film only) - ; note -- if last image in group is Online, considers ALL online - ; MAGDT = Date/Time of Image Capture - ; REMOTE = 1/0 to Indicate images were remotely cached - ; MODALITY= Modality abbrev - ; PLACE = Image storage PLace (ptr to 2006.1 entry) - ; KEY = 1/0 ind. Key Images exist for this exam - ; - N IRPT,MAGIEN,MAGIEN2,ONLCHK,NETLOC,STIEN - N CT,ONL,MAGDT,REMOTE,MODALITY,PLACE,REMCHK,KEY - S CT="",ONL="",MAGDT="",RET="",REMOTE="",MODALITY="",PLACE="",KEY=0 ; init return vars - G IMGINFQ:'RARPT G IMGINFQ:'$D(^RARPT(RARPT,2005,0)) - I 'MAGJOB("P32") D - . S STIEN=$$STUDYID^MAGJUPD2("",RARPT,1) - . I STIEN S T=$O(^MAG(2005,STIEN,205,0)) I T S KEY=1 - S IRPT=0 F S IRPT=$O(^RARPT(RARPT,2005,IRPT)) Q:'IRPT S MAGIEN=$P(^(IRPT,0),U) D - . Q:'$D(^MAG(2005,MAGIEN,0)) - . I MAGDT="" S MAGDT=$P($G(^MAG(2005,MAGIEN,100)),U,6) S:MAGDT="" MAGDT=$P($G(^(2)),U) - . I $O(^MAG(2005,MAGIEN,1,0)) S CT=CT+$P(^(0),U,4),Y=$P(^(0),U,3),MAGIEN2=$P($G(^(Y,0)),U) S:(MAGIEN2]"") ONLCHK=$$ONLCHK(MAGIEN2),REMCHK=$$REMOTE(MAGIEN2) ; last image in group - . E S CT=CT+1,ONLCHK=$$ONLCHK(MAGIEN),REMCHK=$$REMOTE(MAGIEN) - . S ONL=$S(ONL="":+ONLCHK,+ONL:+ONLCHK,1:0) ; NOT Online if ANY img is 0 - . S REMOTE=$S(REMOTE="":REMCHK,+REMOTE:REMCHK,1:0) ; NOT Remote if ANY img is 0 - . S X=$P(ONLCHK,U,3) - . I MODALITY="" S MODALITY=X - . E I MODALITY'[X S MODALITY=MODALITY_","_X - . I PLACE="" S PLACE=$P(ONLCHK,U,4) -IMGINFQ S ONL=$S(+ONL:"Y",ONL="":"n/a",1:"N") - S RET=CT_U_ONL_U_MAGDT_U_REMOTE_U_MODALITY_U_PLACE_U_KEY - Q - ; -ONLCHK(MAGIEN,USETGA) ; - ; Input: MAGIEN: Image pointer - ; USETGA: 1/0 -- if 1, forces return of TGA (not .big) file - ;Return: - ; - T/F for Full-Res image on Mag. Disk that is Online - ; - File type (BIG/FULL) - ; - Modality - ; - Place - ; - DFN - ; - File Name IFF this image is stored Off-Line (else null) - ; - USETGA as calculated in the logic below - ; - PROCDT = Img Processing DtTime - ; - ACQSITE = Acquisition site code - ; USETGA is set to False (0) if a low-resolution image (TGA) is - ; requested, but none exists; calling routine would call by ref. - ; - N BIG,X,NOD,MAG0,MODALITY,RET,PLACE,DFN,FILNAM,MAG2,PROCDT,ACQSITE,MAG100 - S USETGA=+$G(USETGA) ; Defaults to Full-Resolution image if not defined - S RET="",MODALITY="",PLACE="",ACQSITE="" - S MAG0=^MAG(2005,MAGIEN,0),BIG=$D(^("FBIG")),NOD=$S(BIG:^("FBIG"),1:MAG0) - S MAG2=^MAG(2005,MAGIEN,2),PROCDT=$P(MAG2,U) - S MAG100=$G(^MAG(2005,MAGIEN,100)),ACQSITE=$P(MAG100,U,3) - I USETGA D - . I 'BIG S USETGA=0 ; reply no low-res image available - . I BIG S NOD=MAG0,BIG=0 ; enable correct logic inside this subroutine - S MODALITY=$P(MAG0,U,8),DFN=$P(MAG0,U,7) - I BIG S X=+$P(NOD,U) ; $p 1 is Magnetic Disk/Volume (.big) <*> DCM--add to end: S:'X X=+$P(NOD,U,3) - E S X=+$P(NOD,U,3) ; $p 3 is Magnetic Disk/Volume (.tga) - I X D - . I '$D(NETLOC(X)) S NETLOC(X)=+$P(^MAG(2005.2,X,0),U,6)_U_$P(^(0),U,10) - . S RET=+NETLOC(X),PLACE=$P(NETLOC(X),U,2) ; NETLOC is global to this subrtn - . S FILNAM="" - E D - . S RET=0,FILNAM=$P(MAG0,U,2) - . S T=$S(BIG:$P(NOD,U,2),1:$P(NOD,U,5)) - . I T S PLACE=$P(^MAG(2005.2,T,0),U,10) ; <*>DCM--add anything? - S RET=RET_U_$S(BIG:"BIG",1:"FULL")_U_MODALITY_U_PLACE_U_DFN_U_FILNAM_U_USETGA_U_PROCDT_U_ACQSITE - Q RET - ; -REMOTE(MAGIEN) ;Return list of remote Cache Locations - ; else, return "" if none - N RET,LOC - S RET="" - I $D(^MAG(2005,MAGIEN,4,"LOC")) S LOC=0 D - . F S LOC=$O(^MAG(2005,MAGIEN,4,"LOC",LOC)) Q:'LOC S RET=RET_$S(RET="":"",1:",")_LOC - Q RET - ; -IMGINF2(RARPT,RET,USETGA) ; Fetch info from Image File for input RARPT: - ; Input: RARPT: Rad Report pointer - ; RET: see below - ; USETGA: 1/0 -- if 1, forces return of TGA (not .big) file - ; RET holds array of return values: - ; RET = # Images stored for the case - ; RET(1:n) = 1/0 ^ FULL/BIG ^ Mod ^ ien ^ Series ^ Routed-to Locations ^ PLACE ^ DFN ^ FileName (if OffLine) ^ PS_Indicator - ; (1=Image is on Magnetic Disk) - ; * This subroutine may be called by other VistARad routines - ; - N BIG,IMG,MAGIEN,MAGIEN2,MAGPTR,MAGINDX,MAGREF,NETLOC,SERIES,SERCT,SERPREV - K RET S RET=0,SERCT=0,SERPREV="" - S USETGA=+$G(USETGA) ; Defaults to Full-Resolution image if not defined - G IMGINF2Q:'RARPT S IMG=0 - S MAGINDX="ADCM" ; maybe others will exist in the future - ; *P18--this index is defunct for P18 & beyond - ; however, keep for bkwds-compat P18 to P32; remove later - F S IMG=$O(^RARPT(RARPT,2005,IMG)) Q:'IMG S MAGIEN=$P(^(IMG,0),U) D - . S MAGREF=$NA(^MAG(2005,MAGIEN,1,MAGINDX)) - . I 'MAGJOB("P32")!'$D(@MAGREF) D ; use group multiple structure - .. Q:'$D(^MAG(2005,MAGIEN,0)) S MAGPTR=0 - .. I '$O(^MAG(2005,MAGIEN,1,MAGPTR)) D Q - ... S T=$$ONLCHK(MAGIEN,USETGA) - ... S RET=RET+1,RET(RET)=$P(T,U,1,3)_U_MAGIEN_U_U_$$REMOTE(MAGIEN)_U_$P(T,U,4,7)_U_$$PSIND(MAGIEN)_U_$P(T,U,8)_U_$P(T,U,9) - .. E F S MAGPTR=$O(^MAG(2005,MAGIEN,1,MAGPTR)) Q:'MAGPTR S MAGIEN2=$P(^(MAGPTR,0),U) D - ... S T=$$ONLCHK(MAGIEN2,USETGA) - ... S RET=RET+1,RET(RET)=$P(T,U,1,3)_U_MAGIEN2_U_U_$$REMOTE(MAGIEN2)_U_$P(T,U,4,7)_U_$$PSIND(MAGIEN2)_U_$P(T,U,8)_U_$P(T,U,9) - . E I $D(@MAGREF) D ; use exam index, e.g., "ADCM" - .. F S MAGREF=$Q(@MAGREF) Q:($P(MAGREF,",",4)'=(""""_MAGINDX_"""")) D - ... S X=$L(MAGREF,","),MAGIEN2=$P(MAGREF,",",X-1),SERIES=$P(MAGREF,",",5) - ... S T=$$ONLCHK(MAGIEN2,USETGA) - ... S RET=RET+1,RET(RET)=$P(T,U,1,3)_U_MAGIEN2_U_SERIES_U_$$REMOTE(MAGIEN2)_U_$P(T,U,4,7) - ... I SERIES'=SERPREV S SERCT=SERCT+1,$P(RET("SER",SERCT),U,2)=SERIES,SERPREV=SERIES,RET("SER",0)=SERCT - ... S $P(RET("SER",SERCT),U)=RET("SER",SERCT)+1 -IMGINF2Q ; - Q - ; -PSIND(MAGIEN) ; return Presentation State Indicator(s) for image - ; K=Key Image PStype; I=Interpretation PStyp; U=User PStyp - N RSL,IEN,X - S RSL="",IEN=0 - I $D(^MAG(2005,MAGIEN,210,IEN)) F S IEN=$O(^MAG(2005,MAGIEN,210,IEN)) Q:'IEN S X=$P(^(IEN,0),U,2) Q:RSL[X S RSL=RSL_$S(RSL="":"",1:",")_X - Q:$Q RSL Q - ; -JBFETCH(RARPT,MAGS,USETGA) ; fetch this case's images from Jukebox, if necessary - ; Input: RARPT: Rad Report pointer - ; MAGS: see below - ; USETGA: 1/0 -- if 1, forces return of TGA (not .big) file - ; This is a function that returns a string containing: - ; # Images fetched from JB ^ Total # Images for Case ^ # Low Res Imgs - ; The MAGS array will be returned to the calling - ; routine if MAGS is provided as an input parameter - ; MAGS is populated by call to IMGINF2. - ; IF any images are stored OffLine, then this node is set here: - ; MAGS("OFFLN",JBOFFLN)="" JBOFFLN = Platter ID from file 2006.033 - ; - ; * This function may be called by other VistARad routines - ; - N MAGIEN,FETCH,IMAG,FILNAM,JBOFFLN,LORESCT - S USETGA=+$G(USETGA) ; Defaults to Full-Resolution image if not defined - S FETCH=0,LORESCT=0 - D IMGINF2(RARPT,.MAGS,USETGA) - I MAGS F IMAG=1:1:MAGS S X=MAGS(IMAG) D - . I USETGA S LORESCT=LORESCT+$P(X,U,10) - . I '+X D ; Call params below depend on Consolidated Site status - .. S FILNAM=$P(X,U,9) - .. I FILNAM]"",$D(^MAGQUEUE(2006.033,"B",FILNAM)) S T=$O(^(FILNAM,"")) S JBOFFLN=$P($G(^MAGQUEUE(2006.033,T,0)),U,2) S FETCH=FETCH+1,MAGS("OFFLN",JBOFFLN)="" Q ; OffLine Image - .. I '$G(MAGJOB("CONSOLIDATED")) S X=$$JBTOHD^MAGBAPI($P(X,U,4)_"^"_$P(X,U,2)),FETCH=FETCH+1 ; pre-consolidation vs - .. E S X=$$JBTOHD^MAGBAPI($P(X,U,4)_"^"_$P(X,U,2),$P(X,U,7)),FETCH=FETCH+1 - Q FETCH_U_MAGS_U_LORESCT - ; -END Q ; +MAGJUTL2 ;WIRMFO/JHC VistRad subroutines for RPC calls[ 2/21/97 10:53 AM ] ; 22 Mar 2001 2:24 PM + ;;3.0;IMAGING;**18,65**;Jul 27, 2006;Build 28 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q +IMGINFO(RARPT,RET) ; Fetch info from Image File for input RARPT: + ; Input: RARPT: Rad Report pointer + ; RET: see below + ; RET contents delimited by ^: + ; CT = # of images for case + ; ONL = Image Storage status (Y=On Magnetic disk, N=Jukebox + ; "n/a" for not available, e.g., film only) + ; note -- if last image in group is Online, considers ALL online + ; MAGDT = Date/Time of Image Capture + ; REMOTE = 1/0 to Indicate images were remotely cached + ; MODALITY= Modality abbrev + ; PLACE = Image storage PLace (ptr to 2006.1 entry) + ; KEY = 1/0 ind. Key Images exist for this exam + ; + N IRPT,MAGIEN,MAGIEN2,ONLCHK,NETLOC,STIEN + N CT,ONL,MAGDT,REMOTE,MODALITY,PLACE,REMCHK,KEY + S CT="",ONL="",MAGDT="",RET="",REMOTE="",MODALITY="",PLACE="",KEY=0 ; init return vars + G IMGINFQ:'RARPT G IMGINFQ:'$D(^RARPT(RARPT,2005,0)) + I 'MAGJOB("P32") D + . S STIEN=$$STUDYID^MAGJUPD2("",RARPT,1) + . I STIEN S T=$O(^MAG(2005,STIEN,205,0)) I T S KEY=1 + S IRPT=0 F S IRPT=$O(^RARPT(RARPT,2005,IRPT)) Q:'IRPT S MAGIEN=$P(^(IRPT,0),U) D + . Q:'$D(^MAG(2005,MAGIEN,0)) I MAGDT="" S MAGDT=$P($G(^(2)),U) + . I $O(^MAG(2005,MAGIEN,1,0)) S CT=CT+$P(^(0),U,4),Y=$P(^(0),U,3),MAGIEN2=$P($G(^(Y,0)),U) S:(MAGIEN2]"") ONLCHK=$$ONLCHK(MAGIEN2),REMCHK=$$REMOTE(MAGIEN2) ; last image in group + . E S CT=CT+1,ONLCHK=$$ONLCHK(MAGIEN),REMCHK=$$REMOTE(MAGIEN) + . S ONL=$S(ONL="":+ONLCHK,+ONL:+ONLCHK,1:0) ; NOT Online if ANY img is 0 + . S REMOTE=$S(REMOTE="":REMCHK,+REMOTE:REMCHK,1:0) ; NOT Remote if ANY img is 0 + . S X=$P(ONLCHK,U,3) + . I MODALITY="" S MODALITY=X + . E I MODALITY'[X S MODALITY=MODALITY_","_X + . I PLACE="" S PLACE=$P(ONLCHK,U,4) +IMGINFQ S ONL=$S(+ONL:"Y",ONL="":"n/a",1:"N") + S RET=CT_U_ONL_U_MAGDT_U_REMOTE_U_MODALITY_U_PLACE_U_KEY + Q + ; +ONLCHK(MAGIEN,USETGA) ; + ; Input: MAGIEN: Image pointer + ; USETGA: 1/0 -- if 1, forces return of TGA (not .big) file + ;Return: + ; - T/F for Full-Res image on Mag. Disk that is Online + ; - File type (BIG/FULL) + ; - Modality + ; - Place + ; - DFN + ; - File Name IFF this image is stored Off-Line (else null) + ; - USETGA as calculated in the logic below + ; - PROCDT = Img Processing DtTime + ; - ACQSITE = Acquisition site code + ; USETGA is set to False (0) if a low-resolution image (TGA) is + ; requested, but none exists; calling routine would call by ref. + ; + N BIG,X,NOD,MAG0,MODALITY,RET,PLACE,DFN,FILNAM,MAG2,PROCDT,ACQSITE,MAG100 + S USETGA=+$G(USETGA) ; Defaults to Full-Resolution image if not defined + S RET="",MODALITY="",PLACE="",ACQSITE="" + S MAG0=^MAG(2005,MAGIEN,0),BIG=$D(^("FBIG")),NOD=$S(BIG:^("FBIG"),1:MAG0) + S MAG2=^MAG(2005,MAGIEN,2),PROCDT=$P(MAG2,U) + S MAG100=$G(^MAG(2005,MAGIEN,100)),ACQSITE=$P(MAG100,U,3) + I USETGA D + . I 'BIG S USETGA=0 ; reply no low-res image available + . I BIG S NOD=MAG0,BIG=0 ; enable correct logic inside this subroutine + S MODALITY=$P(MAG0,U,8),DFN=$P(MAG0,U,7) + I BIG S X=+$P(NOD,U) ; $p 1 is Magnetic Disk/Volume (.big) <*> DCM--add to end: S:'X X=+$P(NOD,U,3) + E S X=+$P(NOD,U,3) ; $p 3 is Magnetic Disk/Volume (.tga) + I X D + . I '$D(NETLOC(X)) S NETLOC(X)=+$P(^MAG(2005.2,X,0),U,6)_U_$P(^(0),U,10) + . S RET=+NETLOC(X),PLACE=$P(NETLOC(X),U,2) ; NETLOC is global to this subrtn + . S FILNAM="" + E D + . S RET=0,FILNAM=$P(MAG0,U,2) + . S T=$S(BIG:$P(NOD,U,2),1:$P(NOD,U,5)) + . I T S PLACE=$P(^MAG(2005.2,T,0),U,10) ; <*>DCM--add anything? + S RET=RET_U_$S(BIG:"BIG",1:"FULL")_U_MODALITY_U_PLACE_U_DFN_U_FILNAM_U_USETGA_U_PROCDT_U_ACQSITE + Q RET + ; +REMOTE(MAGIEN) ;Return list of remote Cache Locations + ; else, return "" if none + N RET,LOC + S RET="" + I $D(^MAG(2005,MAGIEN,4,"LOC")) S LOC=0 D + . F S LOC=$O(^MAG(2005,MAGIEN,4,"LOC",LOC)) Q:'LOC S RET=RET_$S(RET="":"",1:",")_LOC + Q RET + ; +IMGINF2(RARPT,RET,USETGA) ; Fetch info from Image File for input RARPT: + ; Input: RARPT: Rad Report pointer + ; RET: see below + ; USETGA: 1/0 -- if 1, forces return of TGA (not .big) file + ; RET holds array of return values: + ; RET = # Images stored for the case + ; RET(1:n) = 1/0 ^ FULL/BIG ^ Mod ^ ien ^ Series ^ Routed-to Locations ^ PLACE ^ DFN ^ FileName (if OffLine) ^ PS_Indicator + ; (1=Image is on Magnetic Disk) + ; * This subroutine may be called by other VistARad routines + ; + N BIG,IMG,MAGIEN,MAGIEN2,MAGPTR,MAGINDX,MAGREF,NETLOC,SERIES,SERCT,SERPREV + K RET S RET=0,SERCT=0,SERPREV="" + S USETGA=+$G(USETGA) ; Defaults to Full-Resolution image if not defined + G IMGINF2Q:'RARPT S IMG=0 + S MAGINDX="ADCM" ; maybe others will exist in the future + ; *P18--this index is defunct for P18 & beyond + ; however, keep for bkwds-compat P18 to P32; remove later + F S IMG=$O(^RARPT(RARPT,2005,IMG)) Q:'IMG S MAGIEN=$P(^(IMG,0),U) D + . S MAGREF=$NA(^MAG(2005,MAGIEN,1,MAGINDX)) + . I 'MAGJOB("P32")!'$D(@MAGREF) D ; use group multiple structure + .. Q:'$D(^MAG(2005,MAGIEN,0)) S MAGPTR=0 + .. I '$O(^MAG(2005,MAGIEN,1,MAGPTR)) D Q + ... S T=$$ONLCHK(MAGIEN,USETGA) + ... S RET=RET+1,RET(RET)=$P(T,U,1,3)_U_MAGIEN_U_U_$$REMOTE(MAGIEN)_U_$P(T,U,4,7)_U_$$PSIND(MAGIEN)_U_$P(T,U,8)_U_$P(T,U,9) + .. E F S MAGPTR=$O(^MAG(2005,MAGIEN,1,MAGPTR)) Q:'MAGPTR S MAGIEN2=$P(^(MAGPTR,0),U) D + ... S T=$$ONLCHK(MAGIEN2,USETGA) + ... S RET=RET+1,RET(RET)=$P(T,U,1,3)_U_MAGIEN2_U_U_$$REMOTE(MAGIEN2)_U_$P(T,U,4,7)_U_$$PSIND(MAGIEN2)_U_$P(T,U,8)_U_$P(T,U,9) + . E I $D(@MAGREF) D ; use exam index, e.g., "ADCM" + .. F S MAGREF=$Q(@MAGREF) Q:($P(MAGREF,",",4)'=(""""_MAGINDX_"""")) D + ... S X=$L(MAGREF,","),MAGIEN2=$P(MAGREF,",",X-1),SERIES=$P(MAGREF,",",5) + ... S T=$$ONLCHK(MAGIEN2,USETGA) + ... S RET=RET+1,RET(RET)=$P(T,U,1,3)_U_MAGIEN2_U_SERIES_U_$$REMOTE(MAGIEN2)_U_$P(T,U,4,7) + ... I SERIES'=SERPREV S SERCT=SERCT+1,$P(RET("SER",SERCT),U,2)=SERIES,SERPREV=SERIES,RET("SER",0)=SERCT + ... S $P(RET("SER",SERCT),U)=RET("SER",SERCT)+1 +IMGINF2Q ; + Q + ; +PSIND(MAGIEN) ; return Presentation State Indicator(s) for image + ; K=Key Image PStype; I=Interpretation PStyp; U=User PStyp + N RSL,IEN,X + S RSL="",IEN=0 + I $D(^MAG(2005,MAGIEN,210,IEN)) F S IEN=$O(^MAG(2005,MAGIEN,210,IEN)) Q:'IEN S X=$P(^(IEN,0),U,2) Q:RSL[X S RSL=RSL_$S(RSL="":"",1:",")_X + Q:$Q RSL Q + ; +JBFETCH(RARPT,MAGS,USETGA) ; fetch this case's images from Jukebox, if necessary + ; Input: RARPT: Rad Report pointer + ; MAGS: see below + ; USETGA: 1/0 -- if 1, forces return of TGA (not .big) file + ; This is a function that returns a string containing: + ; # Images fetched from JB ^ Total # Images for Case ^ # Low Res Imgs + ; The MAGS array will be returned to the calling + ; routine if MAGS is provided as an input parameter + ; MAGS is populated by call to IMGINF2. + ; IF any images are stored OffLine, then this node is set here: + ; MAGS("OFFLN",JBOFFLN)="" JBOFFLN = Platter ID from file 2006.033 + ; + ; * This function may be called by other VistARad routines + ; + N MAGIEN,FETCH,IMAG,FILNAM,JBOFFLN,LORESCT + S USETGA=+$G(USETGA) ; Defaults to Full-Resolution image if not defined + S FETCH=0,LORESCT=0 + D IMGINF2(RARPT,.MAGS,USETGA) + I MAGS F IMAG=1:1:MAGS S X=MAGS(IMAG) D + . I USETGA S LORESCT=LORESCT+$P(X,U,10) + . I '+X D ; Call params below depend on Consolidated Site status + .. S FILNAM=$P(X,U,9) + .. I FILNAM]"",$D(^MAGQUEUE(2006.033,"B",FILNAM)) S T=$O(^(FILNAM,"")) S JBOFFLN=$P($G(^MAGQUEUE(2006.033,T,0)),U,2) S FETCH=FETCH+1,MAGS("OFFLN",JBOFFLN)="" Q ; OffLine Image + .. I '$G(MAGJOB("CONSOLIDATED")) S X=$$JBTOHD^MAGBAPI($P(X,U,4)_"^"_$P(X,U,2)),FETCH=FETCH+1 ; pre-consolidation vs + .. E S X=$$JBTOHD^MAGBAPI($P(X,U,4)_"^"_$P(X,U,2),$P(X,U,7)),FETCH=FETCH+1 + Q FETCH_U_MAGS_U_LORESCT + ; +END Q ; diff --git a/r/IMAGING-MAG-ZMAG/MAGJUTL3.m b/r/IMAGING-MAG-ZMAG/MAGJUTL3.m index 818a601b..4ea1a484 100644 --- a/r/IMAGING-MAG-ZMAG/MAGJUTL3.m +++ b/r/IMAGING-MAG-ZMAG/MAGJUTL3.m @@ -1,237 +1,235 @@ -MAGJUTL3 ;WIRMFO/JHC VistARad subrtns & RPCs ; 29 Jul 2003 10:03 AM - ;;3.0;IMAGING;**16,9,22,18,65,76**;Jun 22, 2007;Build 19 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q - ;RPC Entry points: - ; LISTINF--Custom list info - ; LOGOFF--update session file - ; CACHEQ--init session data - ; PINF1--Patient info - ; USERINF2--P18 inits for the session - ;Subrtn EPs: - ; LOG--Upd image access log - ; MAGJOBNC--inits for non-client sessions - ; USERKEYS--user key info - ; USERINF--user info - ; -LISTINF(MAGGRY) ; RPC: MAGJ CUSTOM LISTS - ; get Exam List data - ; Return in ^TMP($J,"MAGJLSTINF",0:N) - ; 0)= # Entries below (0:n) - ; 1:n)= Button Label^List #^Button Hints^List Type - ; - ; MAGGRY holds $NA ref to ^TMP for return message - ; all refs to MAGGRY use SS indirection - ; - ; GLB has $NA ref to ^MAG(2006.631), Custom Lists - ; refs to GLB use SS indirection to get data from this file - ; - S X="ERR1^MAGJUTL3",@^%ZOSF("TRAP") - N D0,GLB,INF,MAGLST,NAM,T - S MAGLST="MAGJLSTINF" - K MAGGRY S MAGGRY=$NA(^TMP($J,MAGLST)) K @MAGGRY S @MAGGRY@(0)=0 - S GLB=$NA(^MAG(2006.631)),NAM="" - F S NAM=$O(@GLB@("B",NAM)) Q:NAM="" S D0="" D - . S D0=$O(@GLB@("B",NAM,D0)) Q:'D0 D - . . S X=$G(@GLB@(D0,0)) Q:($P(X,U,2)>9000)!'$P(X,U,6) ; List Active & User-defined - . . S INF="" F I=1:1 S T=$P("7^2^1^3",U,I) Q:T="" S Y=$P(X,U,T) Q:Y="" S $P(INF,U,I)=Y - . . Q:T'="" ; req'd fields not all there - . . S T=@MAGGRY@(0)+1,^(0)=T,^(T)=INF ; add entry to reply - Q - ; -LOG(ACTION,LOGDATA) ; Log exam access - N PTCT,TXT,RADFN,MAGIEN,NIMGS,REMOTE - S RADFN=$P(LOGDATA,U),MAGIEN=$P(LOGDATA,U,2),NIMGS=$P(LOGDATA,U,3),REMOTE=$P(LOGDATA,U,4) - I ACTION="" S ACTION="UNKNOWN" ; Should never happen - S PTCT=RADFN'=$G(MAGJOB("LASTPT",ACTION)) - I PTCT S MAGJOB("LASTPT",ACTION)=RADFN - S TXT=ACTION_U_RADFN_U_MAGIEN_U_U_U_NIMGS - S TXT=TXT_U_PTCT_U_$S(+MAGJOB("USER",1):1,1:0)_U_REMOTE - ; Session Log - D ACTION^MAGGTAU(TXT,1) - ; Mag Log - I REMOTE S ACTION=ACTION_"/REM" - D ENTRY^MAGLOG(ACTION,+DUZ,MAGIEN,"VRAD:"_MAGJOB("VRVERSION"),RADFN,NIMGS) - Q - ; -LOGOFF(MAGGRY,DATA) ; RPC: MAGJ LOGOFF - ; update session file: logoff time & session entry closed - D LOGOFF^MAGGTAU(.MAGGRY) - Q - ; -CACHEQ(MAGGRY,DATA) ; RPC: MAGJ CACHELOCATION - ; some logon inits & get alternate paths for Remote Reading - ; input in DATA: - ; - WSLOC = WS Loc'n - ; - VRADVER = Client Vs -- p32 ONLY - ; - OSVER = Client OS Vs -- p32 ONLY - ; Return in ^TMP($J,"MAGJCACHE",0:N) (@MAGGRY) - ; 0)= # Entries below (0:n) - ; 1:n)= PhysName^Subdirectory^HashFlag^Username^Password^AltPath_IEN - ; - ; MAGGRY holds $NA reference to ^TMP for return message - ; refs to MAGGRY use SS indirection - ; - ; Also builds local array: p32/p18 compatibility: Some of this is moved to userinf2 below - ; MAGJOB("LOC",NetworkLocnIEN)=Site Abbrev - ; ("REMOTE")=1/0 (T/F for "User is Remote") - ; ("REMOTESCREEN")=0/1 (init User-switchable Remote Screening--P18 use only) - ; ("WSLOC")=WS Loc'n String - ; ("WSLOCTYP")=WS Loc'n Type - ; ("WSNAME")=WS ID - ; ("VRVERSION")=VRAD Vs - ; ("OSVER")=O/S Vs - ; ("ALTPATH")=1/0 ^ 1/0 (T/F Alt Paths are defined - ; ^ Alt Paths Enabled/Disabled for most recent exam) - ; - S X="ERR1^MAGJUTL3",@^%ZOSF("TRAP") - ; - N I,MAGLST,REPLY,TMP,WSLOC,XX,VRADVER,OSVER,DIQUIET,ALTIEN - S DIQUIET=1 D DT^DICRW - S REPLY=0,MAGLST="MAGJCACHE" - K MAGGRY S MAGGRY=$NA(^TMP($J,MAGLST)) K @MAGGRY - S WSLOC=$P(DATA,U),VRADVER=$P(DATA,U,2),OSVER=$P(DATA,U,3) - I '$D(MAGJOB("OSVER")) D ; ID p32 initialization - . S MAGJOB("OSVER")=$S(OSVER]"":OSVER,1:"UNK") - . S MAGJOB("VRVERSION")=$S(VRADVER]"":VRADVER,1:"UNK") - . D MAGJOB ; p32 init of VRAD - ; get alt paths location info - S MAGJOB("WSLOC")=WSLOC,MAGJOB("REMOTE")=0 - S MAGJOB("REMOTESCREEN")=+$P($G(^MAG(2006.69,1,0)),U,10) - I WSLOC]"" D - . S X=$P($G(^MAG(2006.1,+MAGJOB("SITEP"),0)),U,9) - . I X]"",(X'=WSLOC) S MAGJOB("REMOTE")=1 - . E Q - . D LIST^MAGBRTLD(WSLOC,.TMP) - . I TMP S REPLY=TMP,MAGJOB("ALTPATH")=$G(MAGJOB("ALTPATH"),"1^1") F I=1:1:TMP D - . . S ALTIEN=$P(TMP(I),U,7) - . . S XX=$P(TMP(I),U,1,5),X=$P(XX,U,3),$P(XX,U,3)=$S(X="Y":1,1:0) - . . S X=$P(XX,U,4),$P(XX,U,4)=$P(XX,U,5),$P(XX,U,5)=X,$P(XX,U,6)=ALTIEN - . . S @MAGGRY@(I)=XX,MAGJOB("LOC",ALTIEN)=$P(TMP(I),U,6) - I '$D(MAGJOB("ALTPATH")) S MAGJOB("ALTPATH")="0^0" - S @MAGGRY@(0)=REPLY -CACHEQZ Q - ; -MAGJOBNC ; EP for Prefetch/Bkgnd calls (NOT a Vrad Client) - N NOTCLIEN S NOTCLIEN=1 - D MAGJOB - Q - ; -MAGJOB ; Init magjob array - N T,RIST - I $G(MAGJOB("VRVERSION")) S X=MAGJOB("VRVERSION") - E S X="" ; non-client processes assume post-P32 logic - S MAGJOB("P32")=(X="3.0.41.17") ; P32 Client? - I MAGJOB("P32") D P32STOP^MAGJUTL5(.X) S MAGJOB("P32STOP")=X ; STOP support when P76 releases - D USERKEYS - S MAGJOB("CONSOLIDATED")=($G(^MAG(2006.1,"CONSOLIDATED"))="YES") - S MAGJOB("SITEP")=$$IMGSIT^MAGJUTL1(DUZ(2),1) ; Site Param ien - S RIST="" F X="S","R" I $D(^VA(200,"ARC",X,DUZ)) S RIST=X Q - S RIST=$S(RIST="S":15,RIST="R":12,1:0) ; Staff/Resident/Non rist - S MAGJOB("USER",1)=RIST_U_$$USERINF(+DUZ,".01;1") ; RIST_Type^NAME^INI - S X=$P($G(IO("CLNM")),"."),MAGJOB("WSNAME")=$S(X]"":X,1:"VistaradWS") - K MAGJOB("DIVSCRN") I MAGJOB("CONSOLIDATED") D - . ; include logon DIV, other DIVs to screen Unread Lists & Locking - . I $G(DUZ(2))]"" S MAGJOB("DIVSCRN",DUZ(2))="" - . S DIV="" - . I DUZ(2)'=$P(MAGJOB("SITEP"),U,3) D ; Assoc DIV - . . S IEN=$O(^MAG(2006.1,+MAGJOB("SITEP"),"INSTS","B",DUZ(2),0)) - . . I IEN F S DIV=$O(^MAG(2006.1,+MAGJOB("SITEP"),"INSTS",IEN,201,"B",DIV)) Q:'DIV S MAGJOB("DIVSCRN",DIV)="" - . E D ; Parent DIV - . . F S DIV=$O(^MAG(2006.1,+MAGJOB("SITEP"),201,"B",DIV)) Q:'DIV S MAGJOB("DIVSCRN",DIV)="" - S MAGJOB("WSLOCTYP")=$S(+MAGJOB("USER",1):"RAD",1:"Non-Rad") ; USer is Rist/Not - I '$D(MAGJOB("WRKSIEN")) D - . Q:+$G(NOTCLIEN) ; proceed only if Vrad Client is attached - . S X=MAGJOB("WSNAME")_"^^^"_MAGJOB("WSLOCTYP")_U_U_U_U_1_U_MAGJOB("OSVER")_U_MAGJOB("VRVERSION") - . D UPD^MAGGTAU(.Y,X) - . D REMLOCK^MAGJEX1B ; put here to only run 1x/ login - Q - ; -USERINF(DUZ,FLDS) ; get data from user file - I FLDS=""!'DUZ Q "" - N I,RSL,T S RSL="" - D GETS^DIQ(200,+DUZ,FLDS,"E","T") - S T=+DUZ_"," - F I=1:1:$L(FLDS,";") S RSL=RSL_$S(RSL="":"",1:U)_T(200,T,$P(FLDS,";",I),"E") - Q RSL - ; -USERKEYS ; Store Security Keys in MagJob - N I,X,Y - N MAGKS ; keys to send to XUS KEY CHECK - N MAGKG ; returned - K MAGJOB("KEYS") - S X="MAGJ",I=0 - F S X=$O(^XUSEC(X)) Q:$E(X,1,4)'="MAGJ" D - . S I=I+1,MAGKS(I)=X - I '$D(MAGKS) Q - D OWNSKEY^XUSRB(.MAGKG,.MAGKS) - S I=0 F S I=$O(MAGKG(I)) Q:'I I MAGKG(I) S MAGJOB("KEYS",MAGKS(I))="" - Q - ; -PINF1(MAGGRY,MAGDFN) ;RPC Call MAGJ PT INFO -- Get pt info - S X="ERR3^MAGJUTL3",@^%ZOSF("TRAP") - D INFO^MAGGTPT1(.MAGGRY,MAGDFN_"^1") ; 1=Don't log to session file - Q - ; -USERINF2(MAGGRY,DATA) ; rpc: MAGJ USER2--get user info - ; Input= unused ^ Client Vs ^ Client O/S Vs - ; Reply= - ; 0) = 1/0^code~Msg | DUZ ^ NAME ^ INITIALS ^ REQFLAG - ; 1)= Net UserName ^ PSW ^ UserType ^ SYSADMIN - ; 1/0=Success/Fail flag for vs chk - ; code=4 if fail - ; Msg=Disp msg if fail - ; REQFLAG = 1/0 (Ena/Disa Requisition for non-rad staff) - ; UserType = 3: Staff R'ist; 2: Resident R'ist; 1: Rad Tech; 0: Non-Rad - ; SYSADMIN = 1/0 1=user has System User privileges - ; 2:N)=Sec Keys - ; - S X="ERR2^MAGJUTL3",@^%ZOSF("TRAP") - K MAGGRY S MAGGRY(0)="",MAGGRY(1)="" - I +$G(DUZ)=0 S MAGGRY(0)="0^4~DUZ Undefined, Null or Zero|" Q - N I,J,K,Y,REQ,VRADVER,OSVER,RADTECH,PLACE,REPLY - S VRADVER=$P(DATA,U,2),OSVER=$P(DATA,U,3) - D CHKVER^MAGJUTL5(.REPLY,VRADVER,.PLACE,.SVERSION) - I 'REPLY S MAGGRY(0)=REPLY_"|^^^^",MAGGRY(1)="^^^" G USERIN2Z ; Version check or PLACE failed - S RADTECH="" - S MAGJOB("OSVER")=$S(OSVER]"":OSVER,1:"UNK") ; IDs P18 initialization; cf cacheq ep above - S MAGJOB("VRVERSION")=$S(VRADVER]"":VRADVER,1:"UNK") - S MAGJOB("VSVERSION")=SVERSION - D MAGJOB - ; Enable/Disable Requisition if not a radiology user - S REQ=1 - I 'MAGJOB("USER",1) D ; not a rist - . I $D(^VA(200,"ARC","T",+DUZ)) S RADTECH=1 Q ; Rad Tech OK - . S X=+$P($G(^MAG(2006.69,1,0)),U,16) - . I X S REQ=0 ; Disable Req - S MAGGRY(0)=REPLY_"|"_DUZ_U_$$GET1^DIQ(200,DUZ_",",.01)_U_$$GET1^DIQ(200,DUZ_",",1)_U_REQ_U_SVERSION - ; Network UserName and PSW - S MAGGRY(1)=$P($G(^MAG(2006.1,PLACE,"NET")),U,1,2) - S X=+MAGJOB("USER",1),X=$S(X=15:3,X=12:2,+RADTECH:1,1:0) - S MAGGRY(1)=MAGGRY(1)_U_X_U_$D(MAGJOB("KEYS","MAGJ SYSTEM USER")) - S MAGGRY(2)="*KEYS",X="" F I=3:1 S X=$O(MAGJOB("KEYS",X)) Q:X="" S MAGGRY(I)=X - S MAGGRY(I)="*END" -USERIN2Z Q - ; -ERR1 N ERR S ERR=$$EC^%ZOSV S @MAGGRY@(0)="0^4~"_ERR G ERR -ERR2 N ERR S ERR=$$EC^%ZOSV S MAGGRY(0)="0^4~"_ERR G ERR -ERR3 N ERR S ERR=$$EC^%ZOSV S MAGGRY="0^4~"_ERR -ERR D @^%ZOSF("ERRTN") - Q:$Q 1 Q - ; -END Q ; +MAGJUTL3 ;WIRMFO/JHC VistARad subrtns & RPCs ; 29 Jul 2003 10:03 AM + ;;3.0;IMAGING;**16,9,22,18,65**;Jul 27, 2006;Build 28 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q + ;RPC Entry points: + ; LISTINF--Custom list info + ; LOGOFF--update session file + ; CACHEQ--init session data + ; PINF1--Patient info + ; USERINF2--P18 inits for the session + ;Subrtn EPs: + ; LOG--Upd image access log + ; MAGJOBNC--inits for non-client sessions + ; USERKEYS--user key info + ; USERINF--user info + ; +LISTINF(MAGGRY) ; RPC: MAGJ CUSTOM LISTS + ; get Exam List data + ; Return in ^TMP($J,"MAGJLSTINF",0:N) + ; 0)= # Entries below (0:n) + ; 1:n)= Button Label^List #^Button Hints^List Type + ; + ; MAGGRY holds $NA ref to ^TMP for return message + ; all refs to MAGGRY use SS indirection + ; + ; GLB has $NA ref to ^MAG(2006.631), Custom Lists + ; refs to GLB use SS indirection to get data from this file + ; + S X="ERR1^MAGJUTL3",@^%ZOSF("TRAP") + N D0,GLB,INF,MAGLST,NAM,T + S MAGLST="MAGJLSTINF" + K MAGGRY S MAGGRY=$NA(^TMP($J,MAGLST)) K @MAGGRY S @MAGGRY@(0)=0 + S GLB=$NA(^MAG(2006.631)),NAM="" + F S NAM=$O(@GLB@("B",NAM)) Q:NAM="" S D0="" D + . S D0=$O(@GLB@("B",NAM,D0)) Q:'D0 D + . . S X=$G(@GLB@(D0,0)) Q:($P(X,U,2)>9000)!'$P(X,U,6) ; List Active & User-defined + . . S INF="" F I=1:1 S T=$P("7^2^1^3",U,I) Q:T="" S Y=$P(X,U,T) Q:Y="" S $P(INF,U,I)=Y + . . Q:T'="" ; req'd fields not all there + . . S T=@MAGGRY@(0)+1,^(0)=T,^(T)=INF ; add entry to reply + Q + ; +LOG(ACTION,LOGDATA) ; Log exam access + N PTCT,TXT,RADFN,MAGIEN,NIMGS,REMOTE + S RADFN=$P(LOGDATA,U),MAGIEN=$P(LOGDATA,U,2),NIMGS=$P(LOGDATA,U,3),REMOTE=$P(LOGDATA,U,4) + I ACTION="" S ACTION="UNKNOWN" ; Should never happen + S PTCT=RADFN'=$G(MAGJOB("LASTPT",ACTION)) + I PTCT S MAGJOB("LASTPT",ACTION)=RADFN + S TXT=ACTION_U_RADFN_U_MAGIEN_U_U_U_NIMGS + S TXT=TXT_U_PTCT_U_$S(+MAGJOB("USER",1):1,1:0)_U_REMOTE + ; Session Log + D ACTION^MAGGTAU(TXT,1) + ; Mag Log + I REMOTE S ACTION=ACTION_"/REM" + D ENTRY^MAGLOG(ACTION,+DUZ,MAGIEN,"VRAD:"_MAGJOB("VRVERSION"),RADFN,NIMGS) + Q + ; +LOGOFF(MAGGRY,DATA) ; RPC: MAGJ LOGOFF + ; update session file: logoff time & session entry closed + D LOGOFF^MAGGTAU(.MAGGRY) + Q + ; +CACHEQ(MAGGRY,DATA) ; RPC: MAGJ CACHELOCATION + ; some logon inits & get alternate paths for Remote Reading + ; input in DATA: + ; - WSLOC = WS Loc'n + ; - VRADVER = Client Vs -- p32 ONLY + ; - OSVER = Client OS Vs -- p32 ONLY + ; Return in ^TMP($J,"MAGJCACHE",0:N) (@MAGGRY) + ; 0)= # Entries below (0:n) + ; 1:n)= PhysName^Subdirectory^HashFlag^Username^Password^AltPath_IEN + ; + ; MAGGRY holds $NA reference to ^TMP for return message + ; refs to MAGGRY use SS indirection + ; + ; Also builds local array: p32/p18 compatibility: Some of this is moved to userinf2 below + ; MAGJOB("LOC",NetworkLocnIEN)=Site Abbrev + ; ("REMOTE")=1/0 (T/F for "User is Remote") + ; ("REMOTESCREEN")=0/1 (init User-switchable Remote Screening--P18 use only) + ; ("WSLOC")=WS Loc'n String + ; ("WSLOCTYP")=WS Loc'n Type + ; ("WSNAME")=WS ID + ; ("VRVERSION")=VRAD Vs + ; ("OSVER")=O/S Vs + ; ("ALTPATH")=1/0 ^ 1/0 (T/F Alt Paths are defined + ; ^ Alt Paths Enabled/Disabled for most recent exam) + ; + S X="ERR1^MAGJUTL3",@^%ZOSF("TRAP") + ; + N I,MAGLST,REPLY,TMP,WSLOC,XX,VRADVER,OSVER,DIQUIET,ALTIEN + S DIQUIET=1 D DT^DICRW + S REPLY=0,MAGLST="MAGJCACHE" + K MAGGRY S MAGGRY=$NA(^TMP($J,MAGLST)) K @MAGGRY + S WSLOC=$P(DATA,U),VRADVER=$P(DATA,U,2),OSVER=$P(DATA,U,3) + I '$D(MAGJOB("OSVER")) D ; ID p32 initialization + . S MAGJOB("OSVER")=$S(OSVER]"":OSVER,1:"UNK") + . S MAGJOB("VRVERSION")=$S(VRADVER]"":VRADVER,1:"UNK") + . D MAGJOB ; p32 init of VRAD + ; get alt paths location info + S MAGJOB("WSLOC")=WSLOC,MAGJOB("REMOTE")=0 + S MAGJOB("REMOTESCREEN")=+$P($G(^MAG(2006.69,1,0)),U,10) + I WSLOC]"" D + . S X=$P($G(^MAG(2006.1,+MAGJOB("SITEP"),0)),U,9) + . I X]"",(X'=WSLOC) S MAGJOB("REMOTE")=1 + . E Q + . D LIST^MAGBRTLD(WSLOC,.TMP) + . I TMP S REPLY=TMP,MAGJOB("ALTPATH")=$G(MAGJOB("ALTPATH"),"1^1") F I=1:1:TMP D + . . S ALTIEN=$P(TMP(I),U,7) + . . S XX=$P(TMP(I),U,1,5),X=$P(XX,U,3),$P(XX,U,3)=$S(X="Y":1,1:0) + . . S X=$P(XX,U,4),$P(XX,U,4)=$P(XX,U,5),$P(XX,U,5)=X,$P(XX,U,6)=ALTIEN + . . S @MAGGRY@(I)=XX,MAGJOB("LOC",ALTIEN)=$P(TMP(I),U,6) + I '$D(MAGJOB("ALTPATH")) S MAGJOB("ALTPATH")="0^0" + S @MAGGRY@(0)=REPLY +CACHEQZ Q + ; +MAGJOBNC ; EP for Prefetch/Bkgnd calls (NOT a Vrad Client) + N NOTCLIEN S NOTCLIEN=1 + D MAGJOB + Q + ; +MAGJOB ; Init magjob array + N T,RIST + I $G(MAGJOB("VRVERSION")) S X=MAGJOB("VRVERSION") + E S X="" ; non-client processes assume post-P32 logic + S MAGJOB("P32")=(X="3.0.41.17") ; support back-compatible P32 Client + D USERKEYS + S MAGJOB("CONSOLIDATED")=($G(^MAG(2006.1,"CONSOLIDATED"))="YES") + S MAGJOB("SITEP")=$$IMGSIT^MAGJUTL1(DUZ(2),1) ; Site Param ien + S RIST="" F X="S","R" I $D(^VA(200,"ARC",X,DUZ)) S RIST=X Q + S RIST=$S(RIST="S":15,RIST="R":12,1:0) ; Staff/Resident/Non rist + S MAGJOB("USER",1)=RIST_U_$$USERINF(+DUZ,".01;1") ; RIST_Type^NAME^INI + S X=$P($G(IO("CLNM")),"."),MAGJOB("WSNAME")=$S(X]"":X,1:"VistaradWS") + K MAGJOB("DIVSCRN") I MAGJOB("CONSOLIDATED") D + . ; include logon DIV, other DIVs to screen Unread Lists & Locking + . I $G(DUZ(2))]"" S MAGJOB("DIVSCRN",DUZ(2))="" + . S DIV="" + . I DUZ(2)'=$P(MAGJOB("SITEP"),U,3) D ; Assoc DIV + . . S IEN=$O(^MAG(2006.1,+MAGJOB("SITEP"),"INSTS","B",DUZ(2),0)) + . . I IEN F S DIV=$O(^MAG(2006.1,+MAGJOB("SITEP"),"INSTS",IEN,201,"B",DIV)) Q:'DIV S MAGJOB("DIVSCRN",DIV)="" + . E D ; Parent DIV + . . F S DIV=$O(^MAG(2006.1,+MAGJOB("SITEP"),201,"B",DIV)) Q:'DIV S MAGJOB("DIVSCRN",DIV)="" + S MAGJOB("WSLOCTYP")=$S(+MAGJOB("USER",1):"RAD",1:"Non-Rad") ; USer is Rist/Not + I '$D(MAGJOB("WRKSIEN")) D + . Q:+$G(NOTCLIEN) ; proceed only if Vrad Client is attached + . S X=MAGJOB("WSNAME")_"^^^"_MAGJOB("WSLOCTYP")_U_U_U_U_1_U_MAGJOB("OSVER")_U_MAGJOB("VRVERSION") + . D UPD^MAGGTAU(.Y,X) + . D REMLOCK^MAGJEX1B ; put here to only run 1x/ login + Q + ; +USERINF(DUZ,FLDS) ; get data from user file + I FLDS=""!'DUZ Q "" + N I,RSL,T S RSL="" + D GETS^DIQ(200,+DUZ,FLDS,"E","T") + S T=+DUZ_"," + F I=1:1:$L(FLDS,";") S RSL=RSL_$S(RSL="":"",1:U)_T(200,T,$P(FLDS,";",I),"E") + Q RSL + ; +USERKEYS ; Store VRad Security Keys in MagJob + ; + N I,X,Y + N MAGKS ; list of keys to send to XUS KEY CHECK + N MAGKG ; list returned + K MAGJOB("KEYS") + S X="MAGJ",I=0 + F S X=$O(^XUSEC(X)) Q:$E(X,1,4)'="MAGJ" D + . S I=I+1,MAGKS(I)=X + I '$D(MAGKS) Q + D OWNSKEY^XUSRB(.MAGKG,.MAGKS) + S I=0 F S I=$O(MAGKG(I)) Q:'I I MAGKG(I) S MAGJOB("KEYS",MAGKS(I))="" + Q + ; + Q +PINF1(MAGGRY,MAGDFN) ;RPC Call MAGJ PT INFO -- Get pt info + S X="ERR3^MAGJUTL3",@^%ZOSF("TRAP") + D INFO^MAGGTPT1(.MAGGRY,MAGDFN_"^1") ; 1=Don't log to session file + Q + ; +USERINF2(MAGGRY,DATA) ; rpc: MAGJ USER2 -- Return user info + ; Input = unused ^ Client Vrad Vs ^ Client O/S Vs + ; Reply = + ; (0) = 1/0^code~Msg | DUZ ^ NAME ^ INITIALS ^ REQ_FLAG + ; (1)= Net UserName ^ PSW ^ UserType ^ SYSADMIN + ; 1/0=Success/Failure flag for vs compatibility + ; code=4 if failure condition + ; Msg=Display msg if failure condition + ; REQ_FLAG = 1/0 (Enable/Disable Requisition for non-rad staff) + ; UserType = 3: Staff R'ist; 2: Resident R'ist; 1: Rad Tech; 0: Non-Rad + ; SYSADMIN = 1/0 1=user has Vrad System User privileges + ; + S X="ERR2^MAGJUTL3",@^%ZOSF("TRAP") + K MAGGRY S MAGGRY(0)="",MAGGRY(1)="" + I +$G(DUZ)=0 S MAGGRY(0)="0^4~DUZ Undefined, Null or Zero|" Q + N I,J,K,Y,REQ,VRADVER,OSVER,RADTECH,PLACE,REPLY + S VRADVER=$P(DATA,U,2),OSVER=$P(DATA,U,3) + D CHKVER^MAGJUTL5(.REPLY,VRADVER,.PLACE,.SVERSION) + I 'REPLY S MAGGRY(0)=REPLY_"|^^^^",MAGGRY(1)="^^^" G USERIN2Z ; Version check or PLACE failed + S RADTECH="" + S MAGJOB("OSVER")=$S(OSVER]"":OSVER,1:"UNK") ; IDs P18 initialization; cf cacheq ep above + S MAGJOB("VRVERSION")=$S(VRADVER]"":VRADVER,1:"UNK") + S MAGJOB("VSVERSION")=SVERSION + D MAGJOB + ; Enable/Disable Requisition if not a radiology user + S REQ=1 + I 'MAGJOB("USER",1) D ; not a rist + . I $D(^VA(200,"ARC","T",+DUZ)) S RADTECH=1 Q ; Rad Tech OK + . S X=+$P($G(^MAG(2006.69,1,0)),U,16) + . I X S REQ=0 ; Disable Req + S MAGGRY(0)=REPLY_"|"_DUZ_U_$$GET1^DIQ(200,DUZ_",",.01)_U_$$GET1^DIQ(200,DUZ_",",1)_U_REQ_U_SVERSION + ; Network UserName and PSW + S MAGGRY(1)=$P($G(^MAG(2006.1,PLACE,"NET")),U,1,2) + S X=+MAGJOB("USER",1),X=$S(X=15:3,X=12:2,+RADTECH:1,1:0) + S MAGGRY(1)=MAGGRY(1)_U_X_U_$D(MAGJOB("KEYS","MAGJ SYSTEM USER")) +USERIN2Z Q + ; +ERR1 N ERR S ERR=$$EC^%ZOSV S @MAGGRY@(0)="0^4~"_ERR G ERR +ERR2 N ERR S ERR=$$EC^%ZOSV S MAGGRY(0)="0^4~"_ERR G ERR +ERR3 N ERR S ERR=$$EC^%ZOSV S MAGGRY="0^4~"_ERR +ERR D @^%ZOSF("ERRTN") + Q:$Q 1 Q + ; +END Q ; diff --git a/r/IMAGING-MAG-ZMAG/MAGJUTL4.m b/r/IMAGING-MAG-ZMAG/MAGJUTL4.m index 6e4c4851..9aa46f97 100644 --- a/r/IMAGING-MAG-ZMAG/MAGJUTL4.m +++ b/r/IMAGING-MAG-ZMAG/MAGJUTL4.m @@ -1,181 +1,180 @@ -MAGJUTL4 ;WIRMFO/JHC VistARad subroutines for RPC calls ; 15 Jul 2004 4:34 PM - ;;3.0;IMAGING;**18,76**;Jun 22, 2007;Build 19 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q - ; -CPTGRP(MAGGRY,DATA) ; RPC: MAGJ CPTMATCH - ; FOR INPUT cpt code, return matching cpt's based on grouping criteria: - ; INPUT in DATA: CPT Code ^ Criteria - ; Criteria: - ; 1=Matching cpt - ; 2=Body Part - ; 3=Body Part & Modality - ; 10=Same CPT (used to return short description only) - ; Return: List of CPTs with Short Name: CPT ^ Short Name - ; MAGGRY holds $NA reference to ^TMP for rpc return - ; all ref's to MAGGRY use subscript indirection - ; - N $ETRAP,$ESTACK S $ETRAP="G ERR1^MAGJUTL4" - N REPLY,DIQUIET,CPT,CRIT,CT,MAGLST,NOD,NODLST - N MATCHGRP,INDXLST,AND,RET,CPTGLB,CPTIN,CPTIEN,TCPT - ; - ; <*> Issue: Unable get specific body part for some non-specific CPTs (e.g., 75774-ANGIO SELECT EA ADD VESSEL-S) - ; --> For these, could just return matching CPTs (or equivalent CPT?) - ; - ; Produce List of cptiens for each INDX of interest - ; AND with next list of cptiens; repeat until no more INDXs - ; build output list of CPT codes (w/ short names [optional]) - S DIQUIET=1 D DT^DICRW - S CT=0,MAGLST="MAGJCPT" - K MAGGRY S MAGGRY=$NA(^TMP($J,MAGLST)) K @MAGGRY ; assign MAGGRY value - S CPTIN=$P(DATA,U),CRIT=$P(DATA,U,2) - S REPLY="0^Getting matching CPT info." - S:'CRIT CRIT=1 ; default equivalent - I CPTIN="" S REPLY="0^Invalid CPT code ("_DATA_")." G CPTGRPZ - I '(CRIT=1!(CRIT=2)!(CRIT=3)!(CRIT=10)) S REPLY="0^Invalid criteria ("_DATA_")." G CPTGRPZ - S CPTGLB=$NA(^MAG(2006.67)) - S CPTIEN=$O(@CPTGLB@("B",CPTIN,"")) - I 'CPTIEN S REPLY="0^Input CPT code ("_CPTIN_") not defined in CPT Match table." G CPTGRPZ - S X=@CPTGLB@(CPTIEN,0),MATCHGRP=+$P(X,U,4) - ;CPTMATCH^BODYPART^MDL - I CRIT=2!(CRIT=3) D - . S X=0 F S X=$O(@CPTGLB@(CPTIEN,1,"B",X)) Q:'X D GETCPTS("BODYPART",X,"",.RET) - . I CRIT=3 D - . . M AND=RET K RET S X=0 - . . F S X=$O(@CPTGLB@(CPTIEN,2,"B",X)) Q:'X D GETCPTS("MDL",X,.AND,.RET) - I CRIT=1 D - . I MATCHGRP,(MATCHGRP'=CPTIEN) S RET(MATCHGRP)="" D GETCPTS("CPTMATCH",MATCHGRP,"",.RET) - . D GETCPTS("CPTMATCH",CPTIEN,"",.RET) - I CRIT=10 ; fall through answers this! - I '$D(RET(CPTIEN)) S RET(CPTIEN)="" ; always report back input cpt - S IEN=0 F S IEN=$O(RET(IEN)) Q:'IEN D - . N LIN S X=$G(@CPTGLB@(IEN,0)) - . Q:'(X]"") S TCPT=$P(X,U),LIN=TCPT_U_$P($$CPT^ICPTCOD(TCPT),U,3) ; _U_$$BODPART(IEN,"~")_U_$$MDLLST(IEN,"~") - . S CT=CT+1,@MAGGRY@(CT)=LIN - S REPLY=CT_U_"1~ "_CT_" CPT Matches returned for "_CPTIN -CPTGRPZ ; - S @MAGGRY@(0)=REPLY - Q - ; -GETCPTS(INDEX,VALUE,AND,OUT) ; return a list of CPTIENS in OUT - ; if array AND is defined, reply only values contained in AND & the index - N X,GLBREF,CPTIEN - S GLBREF=$NA(@CPTGLB@(INDEX,VALUE)) - S CPTIEN=0 - I $D(AND)>9 D - . F S CPTIEN=$O(AND(CPTIEN)) Q:CPTIEN="" I $D(@GLBREF@(CPTIEN)) S OUT(CPTIEN)="" - E F S CPTIEN=$O(@GLBREF@(CPTIEN)) Q:'CPTIEN D - . S OUT(CPTIEN)="" - Q - ; -BODPART(CPTIEN,DLM) ; return DLM-delimited list of body part values for this CPT - I +$G(CPTIEN) - E Q "" - N LIST,CPTGLB S LIST="" - S DLM=$E($G(DLM)) - I DLM="" S DLM="^" - S CPTGLB=$NA(^MAG(2006.67)) - S NOD=0 - F S NOD=$O(@CPTGLB@(CPTIEN,1,NOD)) Q:'NOD S X=$P(^(NOD,0),U) I X]"" S LIST=LIST_DLM_X - Q:$Q $E(LIST,2,999) Q - ; -MDLLST(CPTIEN,DLM) ; return DLM-delimited list of modality values for this CPT - I +$G(CPTIEN) - E Q "" - N LIST,CPTGLB S LIST="" - S DLM=$E($G(DLM)) - I DLM="" S DLM="^" - S CPTGLB=$NA(^MAG(2006.67)) - S NOD=0 - F S NOD=$O(@CPTGLB@(CPTIEN,2,NOD)) Q:'NOD S X=$P(^(NOD,0),U) I X]"" S LIST=LIST_DLM_X - Q:$Q $E(LIST,2,999) Q - ; -STATCHK(MAGGRY,DATA) ; - ; RPC: MAGJ RADSTATUSCHECK - ; This may also be accessed by subroutine call. <*> do not change name of EP - ; Exam Status check RPC and subroutine: determine if the exam has been Tech-Verified (at least). - ; Images are assumed to be verified if Exam Status is Examined, or higher status. - ; ; Input in DATA: RADFN^RADTI^RACNI^RARPT - ; Input is either RADFN, RADTI, and RACNI; or, RARPT only may be input in piece 4 - ; Return: Code^Text - ; 0 = Problem, or exam was cancelled - ; 1 = Not yet verified - ; 2 = Tech Verified - ; 3 = Radiologist Verified - ; 4 = User is a Radiology professional--always allow access - ; - N $ETRAP,$ESTACK S $ETRAP="G ERR3^MAGJUTL4" - N REPLY,STATUS,ORDER,VCAT,STOUT - N DIQUIET,RARPT,RADFN,RADTI,RACNI - S DIQUIET=1 D DT^DICRW - S RADFN=$P(DATA,U),RADTI=$P(DATA,U,2),RACNI=$P(DATA,U,3),RARPT=$P(DATA,U,4) - S STOUT="",REPLY="0^Getting image verification status." - I RADFN,RADTI,RACNI - E I RARPT D RPT2DPT(RARPT,.X) I X S RADFN=+X,RADTI=$P(X,U,2),RACNI=$P(X,U,3) I RADFN,RADTI,RACNI - E S REPLY="0^Image Verification Status request contains invalid case pointer ("_DATA_")" G STATCHKZ - S STATUS=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),U,3) - I STATUS="" S REPLY="0^Image Verification Status request error--no Exam Status is defined for ("_DATA_")" G STATCHKZ - S VCAT=$P(^RA(72,STATUS,0),U,9),ORDER=$P(^(0),U,3) - I VCAT]"" D G STATCHK2:STOUT - . I "EDT"[VCAT S STOUT=$S(VCAT="E":2,1:3) ; Examined or Interpreted - . E I VCAT="W" S STOUT=1 ; Not yet Verified - I ORDER=9 S STOUT=3 ; Completed exam - E I ORDER=0 S REPLY="0^Exam Cancelled" - E I ORDER=1 S STOUT=1 ; Waiting for exam -STATCHK2 ; - I STOUT<2 D - . F X="S","R","T" I $D(^VA(200,"ARC",X,DUZ)) S STOUT=4 Q ; Radiologist or Tech -- OK to access -STATCHKZ ; - I STOUT S REPLY=STOUT_U_$S(STOUT=1:"Images not yet verified",STOUT=2:"Images verified by Technologist",STOUT=3:"Images interpreted by Radiologist",STOUT=4:"Radiology professional--OK to view images.",1:"") - S MAGGRY=REPLY - Q - ; -REMSCRN(MAGGRY,DATA) ; User set/clear flag to show/not show remote exams only - ; RPC: MAGJ REMOTESCREEN - ; ; Input in DATA: 1/0 1=show remote only; 0=show all exams - ; Return: Reply^Code~msg - ; Reply -- 0=Problem; 1=Success - ; Code -- 4=Error; 1=ok - ; msg -- display text if error - ; - N $ETRAP,$ESTACK S $ETRAP="G ERR3^MAGJUTL4" - N REPLY - N DIQUIET S DIQUIET=1 D DT^DICRW - I $D(DATA),(DATA=0!(DATA=1)) - E S REPLY="0^4~REMOTESCREEN request has invalid parameter ("_$G(DATA)_")" G REMSCRNZ - S MAGJOB("REMOTESCREEN")=DATA,REPLY="1^1~"_DATA -REMSCRNZ ; - S MAGGRY=REPLY - Q - ; -RPT2DPT(RARPT,RET) ; Input RARPT. Return RET containing exam ss values for ^RADPT - ; - N DFN,DTI,CNI S (DFN,DTI,CNI)="" - I RARPT?1N.N,$D(^RARPT(RARPT)) S X=$G(^(RARPT,0)) I X]"" D - . S X=$P(X,U) - . S X=$O(^RADPT("ADC",X,0)) I X S DFN=X,DTI=$O(^(X,0)),CNI=$O(^(DTI,0)) - . S RET=DFN_U_DTI_U_CNI - E S RET="" - Q - ; -ERR1 N ERR S ERR=$$EC^%ZOSV S @MAGGRY@(0)="0^4~"_ERR G ERR -ERR3 N ERR S ERR=$$EC^%ZOSV S MAGGRY="0^4~"_ERR -ERR D @^%ZOSF("ERRTN") - Q:$Q 1 Q - ; -END Q ; +MAGJUTL4 ;WIRMFO/JHC VistARad subroutines for RPC calls ; 15 Jul 2004 4:34 PM + ;;3.0;IMAGING;**18**;Mar 07, 2006 + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q + ; +CPTGRP(MAGGRY,DATA) ; RPC: MAGJ CPTMATCH + ; FOR INPUT cpt code, return matching cpt's based on grouping criteria: + ; INPUT in DATA: CPT Code ^ Criteria + ; Criteria: + ; 1=Matching cpt + ; 2=Body Part + ; 3=Body Part & Modality + ; 10=Same CPT (used to return short description only) + ; Return: List of CPTs with Short Name: CPT ^ Short Name + ; MAGGRY holds $NA reference to ^TMP for rpc return + ; all ref's to MAGGRY use subscript indirection + ; + N $ETRAP,$ESTACK S $ETRAP="G ERR1^MAGJUTL4" + N REPLY,DIQUIET,CPT,CRIT,CT,MAGLST,NOD,NODLST + N MATCHGRP,INDXLST,AND,RET,CPTGLB,CPTIN,CPTIEN,TCPT + ; + ; <*> Issue: Unable get specific body part for some non-specific CPTs (e.g., 75774-ANGIO SELECT EA ADD VESSEL-S) + ; --> For these, could just return matching CPTs (or equivalent CPT?) + ; + ; Produce List of cptiens for each INDX of interest + ; AND with next list of cptiens; repeat until no more INDXs + ; build output list of CPT codes (w/ short names [optional]) + S DIQUIET=1 D DT^DICRW + S CT=0,MAGLST="MAGJCPT" + K MAGGRY S MAGGRY=$NA(^TMP($J,MAGLST)) K @MAGGRY ; assign MAGGRY value + S CPTIN=$P(DATA,U),CRIT=$P(DATA,U,2) + S REPLY="0^Getting matching CPT info." + S:'CRIT CRIT=1 ; default equivalent + I CPTIN="" S REPLY="0^Invalid CPT code ("_DATA_")." G CPTGRPZ + I '(CRIT=1!(CRIT=2)!(CRIT=3)!(CRIT=10)) S REPLY="0^Invalid criteria ("_DATA_")." G CPTGRPZ + S CPTGLB=$NA(^MAG(2006.67)) + S CPTIEN=$O(@CPTGLB@("B",CPTIN,"")) + I 'CPTIEN S REPLY="0^Input CPT code ("_CPTIN_") not defined in CPT Match table." G CPTGRPZ + S X=@CPTGLB@(CPTIEN,0),MATCHGRP=+$P(X,U,4) + ;CPTMATCH^BODYPART^MDL + I CRIT=2!(CRIT=3) D + . S X=0 F S X=$O(@CPTGLB@(CPTIEN,1,"B",X)) Q:'X D GETCPTS("BODYPART",X,"",.RET) + . I CRIT=3 D + . . M AND=RET K RET S X=0 + . . F S X=$O(@CPTGLB@(CPTIEN,2,"B",X)) Q:'X D GETCPTS("MDL",X,.AND,.RET) + I CRIT=1 D + . I MATCHGRP,(MATCHGRP'=CPTIEN) S RET(MATCHGRP)="" D GETCPTS("CPTMATCH",MATCHGRP,"",.RET) + . D GETCPTS("CPTMATCH",CPTIEN,"",.RET) + I CRIT=10 ; fall through answers this! + I '$D(RET(CPTIEN)) S RET(CPTIEN)="" ; always report back input cpt + S IEN=0 F S IEN=$O(RET(IEN)) Q:'IEN D + . N LIN S X=$G(@CPTGLB@(IEN,0)) + . Q:'(X]"") S TCPT=$P(X,U),LIN=TCPT_U_$P($G(^ICPT(TCPT,0)),U,2) ; _U_$$BODPART(IEN,"~")_U_$$MDLLST(IEN,"~") + . S CT=CT+1,@MAGGRY@(CT)=LIN + S REPLY=CT_U_"1~ "_CT_" CPT Matches returned for "_CPTIN +CPTGRPZ ; + S @MAGGRY@(0)=REPLY + Q + ; +GETCPTS(INDEX,VALUE,AND,OUT) ; return a list of CPTIENS in OUT + ; if array AND is defined, reply only values contained in AND & the index + N X,GLBREF,CPTIEN + S GLBREF=$NA(@CPTGLB@(INDEX,VALUE)) + S CPTIEN=0 + I $D(AND)>9 D + . F S CPTIEN=$O(AND(CPTIEN)) Q:CPTIEN="" I $D(@GLBREF@(CPTIEN)) S OUT(CPTIEN)="" + E F S CPTIEN=$O(@GLBREF@(CPTIEN)) Q:'CPTIEN D + . S OUT(CPTIEN)="" + Q + ; +BODPART(CPTIEN,DLM) ; return DLM-delimited list of body part values for this CPT + I +$G(CPTIEN) + E Q "" + N LIST,CPTGLB S LIST="" + S DLM=$E($G(DLM)) + I DLM="" S DLM="^" + S CPTGLB=$NA(^MAG(2006.67)) + S NOD=0 + F S NOD=$O(@CPTGLB@(CPTIEN,1,NOD)) Q:'NOD S X=$P(^(NOD,0),U) I X]"" S LIST=LIST_DLM_X + Q:$Q $E(LIST,2,999) Q + ; +MDLLST(CPTIEN,DLM) ; return DLM-delimited list of modality values for this CPT + I +$G(CPTIEN) + E Q "" + N LIST,CPTGLB S LIST="" + S DLM=$E($G(DLM)) + I DLM="" S DLM="^" + S CPTGLB=$NA(^MAG(2006.67)) + S NOD=0 + F S NOD=$O(@CPTGLB@(CPTIEN,2,NOD)) Q:'NOD S X=$P(^(NOD,0),U) I X]"" S LIST=LIST_DLM_X + Q:$Q $E(LIST,2,999) Q + ; +STATCHK(MAGGRY,DATA) ; + ; RPC: MAGJ RADSTATUSCHECK + ; This may also be accessed by subroutine call. <*> do not change name of EP + ; Exam Status check RPC and subroutine: determine if the exam has been Tech-Verified (at least). + ; Images are assumed to be verified if Exam Status is Examined, or higher status. + ; ; Input in DATA: RADFN^RADTI^RACNI^RARPT + ; Input is either RADFN, RADTI, and RACNI; or, RARPT only may be input in piece 4 + ; Return: Code^Text + ; 0 = Problem, or exam was cancelled + ; 1 = Not yet verified + ; 2 = Tech Verified + ; 3 = Radiologist Verified + ; 4 = User is a Radiology professional--always allow access + ; + N $ETRAP,$ESTACK S $ETRAP="G ERR3^MAGJUTL4" + N REPLY,STATUS,ORDER,VCAT,STOUT + N DIQUIET,RARPT,RADFN,RADTI,RACNI + S DIQUIET=1 D DT^DICRW + S RADFN=$P(DATA,U),RADTI=$P(DATA,U,2),RACNI=$P(DATA,U,3),RARPT=$P(DATA,U,4) + S STOUT="",REPLY="0^Getting image verification status." + I RADFN,RADTI,RACNI + E I RARPT D RPT2DPT(RARPT,.X) I X S RADFN=+X,RADTI=$P(X,U,2),RACNI=$P(X,U,3) I RADFN,RADTI,RACNI + E S REPLY="0^Image Verification Status request contains invalid case pointer ("_DATA_")" G STATCHKZ + S STATUS=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),U,3) + I STATUS="" S REPLY="0^Image Verification Status request error--no Exam Status is defined for ("_DATA_")" G STATCHKZ + S VCAT=$P(^RA(72,STATUS,0),U,9),ORDER=$P(^(0),U,3) + I VCAT]"" D G STATCHK2:STOUT + . I "EDT"[VCAT S STOUT=$S(VCAT="E":2,1:3) ; Examined or Interpreted + . E I VCAT="W" S STOUT=1 ; Not yet Verified + I ORDER=9 S STOUT=3 ; Completed exam + E I ORDER=0 S REPLY="0^Exam Cancelled" + E I ORDER=1 S STOUT=1 ; Waiting for exam +STATCHK2 ; + I STOUT<2 D + . F X="S","R","T" I $D(^VA(200,"ARC",X,DUZ)) S STOUT=4 Q ; Radiologist or Tech -- OK to access +STATCHKZ ; + I STOUT S REPLY=STOUT_U_$S(STOUT=1:"Images not yet verified",STOUT=2:"Images verified by Technologist",STOUT=3:"Images interpreted by Radiologist",STOUT=4:"Radiology professional--OK to view images.",1:"") + S MAGGRY=REPLY + Q + ; +REMSCRN(MAGGRY,DATA) ; User set/clear flag to show/not show remote exams only + ; RPC: MAGJ REMOTESCREEN + ; ; Input in DATA: 1/0 1=show remote only; 0=show all exams + ; Return: Reply^Code~msg + ; Reply -- 0=Problem; 1=Success + ; Code -- 4=Error; 1=ok + ; msg -- display text if error + ; + N $ETRAP,$ESTACK S $ETRAP="G ERR3^MAGJUTL4" + N REPLY + N DIQUIET S DIQUIET=1 D DT^DICRW + I $D(DATA),(DATA=0!(DATA=1)) + E S REPLY="0^4~REMOTESCREEN request has invalid parameter ("_$G(DATA)_")" G REMSCRNZ + S MAGJOB("REMOTESCREEN")=DATA,REPLY="1^1~"_DATA +REMSCRNZ ; + S MAGGRY=REPLY + Q + ; +RPT2DPT(RARPT,RET) ; Input RARPT. Return RET containing exam ss values for ^RADPT + ; + N DFN,DTI,CNI S (DFN,DTI,CNI)="" + I RARPT?1N.N,$D(^RARPT(RARPT)) S X=$G(^(RARPT,0)) I X]"" D + . S X=$P(X,U) + . S X=$O(^RADPT("ADC",X,0)) I X S DFN=X,DTI=$O(^(X,0)),CNI=$O(^(DTI,0)) + . S RET=DFN_U_DTI_U_CNI + E S RET="" + Q + ; +ERR1 N ERR S ERR=$$EC^%ZOSV S @MAGGRY@(0)="0^4~"_ERR G ERR +ERR3 N ERR S ERR=$$EC^%ZOSV S MAGGRY="0^4~"_ERR +ERR D @^%ZOSF("ERRTN") + Q:$Q 1 Q + ; +END Q ; diff --git a/r/IMAGING-MAG-ZMAG/MAGJUTL5.m b/r/IMAGING-MAG-ZMAG/MAGJUTL5.m index 4b2eb71c..9e66f2c3 100644 --- a/r/IMAGING-MAG-ZMAG/MAGJUTL5.m +++ b/r/IMAGING-MAG-ZMAG/MAGJUTL5.m @@ -1,119 +1,113 @@ -MAGJUTL5 ;WOIFO/JHC - VistARad RPCs ; [ 07/3/2006 17:17 ] - ;;3.0;IMAGING;**65,76**;Jun 22, 2007;Build 19 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q - ; adapted from MAGGTU4 -GETVER(SVRVER,SVRTVER,ALLOWCL) ; - ; The Server Version SVRVER is hardcoded to match the Client - ; so this Routine must be edited/distributed with a new Client - ; released Client will have the T version that the server expects - ; - S SVRVER="3.0.76",SVRTVER=14 ; <*> Edit this line for each patch/T-version - ; - S ALLOWCL="|3.0.65|" ; - Q - ; -CHKVER(MAGRY,CLVER,PLC,SVERSION) ; - ; Input CLVER is the version of the Client - ; format: Major.Minor.Patch.Build# (Build #=T-ver) eg 3.0.18.132 - ; Ver 3.0.65.n is first client Ver that makes this call - ; 3 possible return codes in MAGRY: - ; 2^n~msg : Client displays a message and continues - ; 1^1~msg : Client continues without displaying a message - ; 0^n~msg : Client displays a message then Aborts - ; PLC returns 2006.1 pointer - ; - S CLVER=$G(CLVER),PLC="",MAGRY="" - N SV,ST,CV,CT,CP,ALLOWV,TESTFLAG,SVSTAT - ; SVERSION = Full Server Version -> (3.0.18.132 or 3.0.18); test has 4, release has 3 parts - ; SV = Server Version -> (3.0.18); only 1st 3 parts - ; ST = Server T Version -> defined to always match client part-4 - ; CV = Client Version, w/out build # - ; CT = Client T Version alone - ; CP = Client Patch alone - ; ALLOWV = Hard coded string of allowed clients for this KIDS. - ; TESTFLAG = 1/0 -- 1=Test vs of server code; 0=Release vs - ;Below is placeholder for future enhancement: - ;I $P(CLVER,"|",2)="RIV" D Q - ;. S MAGJOB("RIV")=1 - ;. ; Allowing |RIV clients always - ;. S MAGRY="1^1~Allowing Remote Image Connection" - ; - I $G(DUZ(2)) S PLC=$$PLACE^MAGBAPI(DUZ(2)) - ; Quit if we don't have a valid DUZ(2) or valid PLACE: ^MAG(2006.1,PLC) - I 'PLC S MAGRY="0^4~Error verifying Imaging Site (Place) -- Contact Imaging support." Q - ; - D GETVER(.SV,.ST,.ALLOWV) - S CLVER=$P(CLVER,"|") - S CV=$P(CLVER,".",1,3),CT=+$P(CLVER,".",4),CP=+$P(CLVER,".",3) - ; - D VERSTAT(.SVSTAT,SV) - I 'SVSTAT S MAGRY(0)=SVSTAT Q ; KIDS status for this version indeterminate - S TESTFLAG=(+SVSTAT=1) - S SVERSION=SV - I TESTFLAG S SVERSION=SV_"."_ST - ; Check Version differences: - I (CV'=SV) D Q - . I '(ALLOWV[("|"_CV_"|")) D Q - . . S MAGRY="0^4~VistARad Workstation software version "_CLVER_" is not compatible with the VistA server version "_SVERSION_". Contact Imaging support. (CNA)" - . ; Warn the Client, allow to continue - . I TESTFLAG S MAGRY="2^3~VistARad Workstation software version "_CLVER_" is running with VistA server TEST Version "_SVERSION_" -- VistARad will Continue, but contact Imaging Support if problems occur. (Pdif)" - . E S MAGRY="2^3~VistARad Workstation software version "_CLVER_" is running with VistA server Version "_SVERSION_" -- VistARad will Continue, but contact Imaging Support to install Released Version. (RPdif)" - . Q - ; Versions are the Same: If T versions are not, warn the Client if needed. - ; Released Client (of any version) will have the T version that the server - ; expects, and no warning will be displayed. - I CT,(CT'=ST) D Q - . I TESTFLAG S MAGRY="2^3~VistARad Workstation software vs. "_CLVER_" is running with VistA server TEST vs. "_SVERSION_" -- VistARad will Continue, but contact Imaging Support " D - . . I CT Edit this line for each patch/T-version + ; + S ALLOWCL="|3.0.18|" ; note--patch 32 is numbered funny, so is hard-coded below + Q + ; +CHKVER(MAGRY,CLVER,PLC,SVERSION) ; + ; Input CLVER is the version of the Client + ; format: Major.Minor.Patch.Build# (Build #=T-ver) eg 3.0.18.132 + ; Ver 3.0.65.n is first client Ver that makes this call + ; 3 possible return codes in MAGRY: + ; 2^n~msg : Client displays a message and continues + ; 1^1~msg : Client continues without displaying a message + ; 0^n~msg : Client displays a message then Aborts + ; PLC returns 2006.1 pointer + ; + S CLVER=$G(CLVER),PLC="",MAGRY="" + N SV,ST,CV,CT,CP,ALLOWV,TESTFLAG,SVSTAT + ; SVERSION = Full Server Version -> (3.0.18.132 or 3.0.18); test has 4, release has 3 parts + ; SV = Server Version -> (3.0.18); only 1st 3 parts + ; ST = Server T Version -> defined to always match client part-4 + ; CV = Client Version, w/out build # + ; CT = Client T Version alone + ; CP = Client Patch alone + ; ALLOWV = Hard coded string of allowed clients for this KIDS. + ; TESTFLAG = 1/0 -- 1=Test vs of server code; 0=Release vs + ;Below is placeholder for future enhancement: + ;I $P(CLVER,"|",2)="RIV" D Q + ;. S MAGJOB("RIV")=1 + ;. ; Allowing |RIV clients always + ;. S MAGRY="1^1~Allowing Remote Image Connection" + ; + I $G(DUZ(2)) S PLC=$$PLACE^MAGBAPI(DUZ(2)) + ; Quit if we don't have a valid DUZ(2) or valid PLACE: ^MAG(2006.1,PLC) + I 'PLC S MAGRY="0^4~Error verifying Imaging Site (Place) -- Contact Imaging support." Q + ; + D GETVER(.SV,.ST,.ALLOWV) + S CLVER=$P(CLVER,"|") + S CV=$P(CLVER,".",1,3),CT=+$P(CLVER,".",4),CP=+$P(CLVER,".",3) + ; + D VERSTAT(.SVSTAT,SV) + I 'SVSTAT S MAGRY(0)=SVSTAT Q ; KIDS status for this version indeterminate + S TESTFLAG=(+SVSTAT=1) + S SVERSION=SV + I TESTFLAG S SVERSION=SV_"."_ST + ; + ; Patch 32 client is OK: + I CLVER="3.0.41.17" S MAGRY="1^1~P32 Client Version Check OK. Server: "_SVERSION_" Client: "_CLVER Q + ; Other Version differences: + I (CV'=SV) D Q + . I '(ALLOWV[("|"_CV_"|")) D Q + . . S MAGRY="0^4~VistARad Workstation software version "_CLVER_" is not compatible with the VistA server version "_SVERSION_". Contact Imaging support. (CNA)" + . ; Don't allow Test versions of P18 + . I CP=18,(CT'=132) D Q + . . S MAGRY="0^4~VistARad Workstation software version "_CLVER_" is not compatible with the VistA server version "_SVERSION_". Contact Imaging support. (C18T)" + . ; Warn the Client, allow to continue + . I TESTFLAG S MAGRY="2^3~VistARad Workstation software version "_CLVER_" is running with VistA server TEST Version "_SVERSION_" -- VistARad will Continue, but contact Imaging Support if problems occur. (Pdif)" + . E S MAGRY="2^3~VistARad Workstation software version "_CLVER_" is running with VistA server Version "_SVERSION_" -- VistARad will Continue, but contact Imaging Support to install Released Version. (RPdif)" + . Q + ; Versions are the Same: If T versions are not, warn the Client if needed. + ; Released Client (of any version) will have the T version that the server + ; expects, and no warning will be displayed. + I CT,(CT'=ST) D Q + . I TESTFLAG S MAGRY="2^3~VistARad Workstation software vs. "_CLVER_" is running with VistA server TEST vs. "_SVERSION_" -- VistARad will Continue, but contact Imaging Support " D + . . I CT 1|0 ^ message - ; OUT(1) -> Field Headers - ; '^' delimited list of column headers used in cMagListView - ; OUT(2..n) -> each line is information on 1 image. - ; piece '|' 1 is '^' delimited data to be displayed in columns. - ; piece '|' 2 is data that is used internally by App. - ; - ; PKG - Package fld 40 - ; CLS - Class fld 41 - ; TYPE - Type fld 42 - ; EVENT - Proc/Event fld 43 - ; SPEC - Spec/SubSpecialty fld 44 - ; FROM - Date to search from - ; UNTIL - Date to search to - ; ORIGIN - Origin fld 45 - ; DATA - Future - ; FLGS - Future - ; -PGI(OUT,DFN,PKG,CLS,TYPE,EVENT,SPEC,FROM,UNTIL,ORIGIN,DATA,FLGS) ;RPC [MAG4 PAT GET IMAGES] - ; Get Images for Patient. - ; New call in Patch 3.0.8 uses Image Filter to get list of images - N C,DAT1,DAT2,E,IMAGE,N,OK,P,RDT,RESULT,S,T,V,CT,PKG1,CLS1,TYPE1,EVENT1,SPEC1,FLTX,FLTY,CAPDUZ,CAPDT,MAGVR,FNL - S FROM=$G(FROM),UNTIL=$G(UNTIL) - D REVDT(FROM,UNTIL,.DAT1,.DAT2) - S RESULT="OUT" K OUT,^TMP($T(+0),$J) - S PKG=$G(PKG),CLS=$G(CLS),EVENT=$G(EVENT),SPEC=$G(SPEC),TYPE=$G(TYPE),ORIGIN=$G(ORIGIN) - I PKG'="" D PKG^MAGSIXGT Q:$D(OUT(0)) - I CLS'="" D CLS^MAGSIXGT Q:$D(OUT(0)) - I EVENT'="" D EVENT^MAGSIXGT Q:$D(OUT(0)) - I SPEC'="" D SPEC^MAGSIXGT Q:$D(OUT(0)) - I TYPE'="" D TYPE^MAGSIXGT Q:$D(OUT(0)) - I ORIGIN'="" D ORIGIN^MAGSIXGT Q:$D(OUT(0)) - I +DFN'=DFN S @RESULT@(0)="0^Invalid Patient Number: """_DFN_"""." Q - I '$D(^DPT(DFN,0))#2 S @RESULT@(0)="0^No Such Patient: """_DFN_"""." Q - S N=0 - D NETPLCS^MAGGTU6 - ;3.0.8/gek, Quit searching all images, just do the date range. - S RDT=DAT1 F S RDT=$O(^MAG(2005,"APDTPX",DFN,RDT)) Q:(RDT="")!(RDT>DAT2) D - . K ^TMP($J,"MAGSIX") - . N COUNT,PRX,X0,X2,X40,I1,X01 - . S PRX="" F S PRX=$O(^MAG(2005,"APDTPX",DFN,RDT,PRX)) Q:PRX="" M ^TMP($J,"MAGSIX")=^MAG(2005,"APDTPX",DFN,RDT,PRX) - . S IMAGE="" F S IMAGE=$O(^TMP($J,"MAGSIX",IMAGE),-1) Q:IMAGE="" D - . . S X0=$G(^MAG(2005,IMAGE,0)) - . . Q:$P(X0,"^",10) ; child of Group - . . S X2=$G(^MAG(2005,IMAGE,2)),X40=$G(^MAG(2005,IMAGE,40)),I1=$O(^MAG(2005,IMAGE,1,0)) - . . S P=$P(X40,U),C=$P(X40,"^",2),T=$P(X40,"^",3),E=$P(X40,"^",4),S=$P(X40,"^",5) - . . ;Patch 59. Treat Class as a computed Field. Arrange with Mike to change DB. - . . S C=$S('T:"",'$D(^MAG(2005.83,T,0)):"",1:$P(^(0),"^",2)) - . . S V=$S($P(X40,"^",6)="":"V",1:$P(X40,"^",6)) ; P48T1 show VA for Null - . . D CHK^DIE(2005,45,"E",V,.MAGVR) I MAGVR'="^" S V=MAGVR(0) ; P48T1 show External Value - . . I PKG'="",P'="",'$D(OK(5,P)) Q - . . I ORIGIN'="",V'="",'$D(OK(6,V)) Q - . . I CLS'="",C'="",'$D(OK(1,C)) Q - . . I EVENT'="",E,'$D(OK(2,E)) Q - . . ;3.0.8 Stop list entries with no Event, if Event is in Search Specs - . . I EVENT'="",E="" Q - . . I SPEC'="",S,'$D(OK(3,S)) Q - . . ;3.0.8 Stop list entries with no Spec, if Spec is in Search Specs - . . I SPEC'="",S="" Q - . . I TYPE'="",T,'$D(OK(4,T)) Q - . . ; Get Count of Images in Group, use 4th piece of ,1,0) multiple - . . S COUNT=$S($P($G(^MAG(2005,IMAGE,1,0)),"^",4):$P($G(^MAG(2005,IMAGE,1,0)),"^",4),1:1) - . . S FLTX="" - . . ; PUT in Site Code as 2nd piece. - . . S X01=$S(I1:$G(^MAG(2005,+$G(^MAG(2005,IMAGE,1,I1,0)),0)),1:X0) - . . S FNL=$S(+$P(X01,"^",3):$P(X01,"^",3),1:+$P(X01,"^",5)) - . . S FLTX=$P($G(MAGJOB("NETPLC",FNL)),"^",2) - . . I FLTX="" S FLTX=$G(MAGJOB("PLCODE")) - . . S FLTX=FLTX_"^"_$$RPTITLE($P(X2,"^",6),$P(X2,"^",7)) - . . S X=$$FMTE^XLFDT($P(X2,"^",5),"5Z") - . . S X=$P(X,"@",1)_" "_$S($L($P(X,"@",2)):$P(X,"@",2),1:"00:01") - . . S FLTX=FLTX_"^"_X - . . S FLTX=FLTX_"^"_$P(X0,"^",8)_"^"_COUNT_"^"_$P(X2,"^",4) - . . S FLTX=FLTX_"^"_P - . . S FLTX=FLTX_"^"_$P($G(^MAG(2005.82,+C,0)),"^",1) - . . S FLTX=FLTX_"^"_$P($G(^MAG(2005.83,+T,0)),"^",1) - . . S FLTX=FLTX_"^"_$P($G(^MAG(2005.84,+S,0)),"^",1) - . . S FLTX=FLTX_"^"_$P($G(^MAG(2005.85,+E,0)),"^",1) - . . S FLTX=FLTX_"^"_V - . . ;S FLTX=FLTX_"^"_$P($$FMTE^XLFDT($P(X2,"^",1),"5Z"),"@",1) - . . S X=$$FMTE^XLFDT($P(X2,"^",1),"5Z") - . . S X=$P(X,"@",1)_" "_$S($L($P(X,"@",2)):$P(X,"@",2),1:"00:01") - . . S FLTX=FLTX_"^"_X - . . ;;;;;;;;; - . . ; P8T36 gek. Fix Error caused if $P(X2,"^",2) "ImageSavedBy" is null - . . S FLTX=FLTX_"^"_$$GET1^DIQ(200,+$P(X2,"^",2)_",",.01) - . . N MAGFILE,MAGXX - . . S MAGXX=IMAGE D INFO^MAGGTII - . . S FLTX=FLTX_"^"_$P(MAGFILE,"^",1) - . . S N=N+1,@RESULT@(N+1)=N_"^"_FLTX_"|"_MAGFILE - . . Q:N<76 Q:RESULT["^" - . . ; Image count is getting big, switch from array to Global return type - . . S ^TMP($T(+0),$J)="" - . . M ^TMP($T(+0),$J)=OUT - . . K OUT - . . S X=$$RTRNFMT^XWBLIB("GLOBAL ARRAY",1) - . . S RESULT=$NA(^TMP($T(+0),$J)) - . . S OUT=$NA(^TMP($T(+0),$J)) ;GEK 10/01/02 - . . Q - . ;Q - . Q - S FLTY=$$FLTDESC(X) - I 'N S @RESULT@(0)="0^No images for filter: "_FLTY Q - S @RESULT@(0)="1^"_FLTY - S @RESULT@(1)="Item~S2^Site^Note Title~~W0^Proc DT~S1^Procedure^# Img~S2^Short Desc^Pkg^Class^Type^Specialty^Event^Origin^Cap Dt~S1~W0^Cap by~~W0^Image ID~S2~W0" - ;S @RESULT@(1)="Item~S2^Site^Proc DT~S1^Procedure^# Img~S2^Short Desc^Pkg^Class^Type^Specialty^Event^Origin^Cap Dt~S1~W0^Cap by~~W0^Image ID~S2~W0" - Q -RPTITLE(FILE,IEN) ; - I FILE=8925,$D(^TIU(8925,IEN,0)) Q $P(^TIU(8925.1,$P(^TIU(8925,IEN,0),"^",1),0),"^",1) - ;I FILE=8925,$D(^TIU(8925,IEN,0)) Q $$GET1^DIQ(FILE,IEN,".01:.01") - E Q " " -FLTDESC(X) ; - N FLT - S FLT="" - ; Package - S FLT=FLT_$S(PKG="":"",1:"Pkg: "_PKG_" - ") - ; Class - S FLT=FLT_$S(CLS="":"",CLS="ADMIN,ADMIN/CLIN,CLIN/ADMIN":"Class: ADMIN - ",CLS="CLIN,CLIN/ADMIN,ADMIN/CLIN":"Class: CLIN - ",1:"Class: "_CLS_" - ") - ; Type - F CT=1:1:$L(TYPE,",") D - . S TYPE1=$P(TYPE,",",CT) I TYPE1'="" S TYPE1=$P($G(^MAG(2005.83,TYPE1,0)),"^") - . S $P(TYPE,",",CT)=$E(TYPE1)_$$LOW^XLFSTR($E(TYPE1,2,999)) - S FLT=FLT_$S(TYPE="":"",1:"Type: "_TYPE_" - ") - ; Specialty/SubSpecialty - F CT=1:1:$L(SPEC,",") D - . S SPEC1=$P(SPEC,",",CT) I SPEC1'="" S SPEC1=$P($G(^MAG(2005.84,SPEC1,0)),"^") - . S $P(SPEC,",",CT)=$E(SPEC1)_$$LOW^XLFSTR($E(SPEC1,2,999)) - S FLT=FLT_$S(SPEC="":"",1:"Spec.: "_SPEC_" - ") - ; Procedure/Event - F CT=1:1:$L(EVENT,",") D - . S EVENT1=$P(EVENT,",",CT) I EVENT1'="" S EVENT1=$P($G(^MAG(2005.85,EVENT1,0)),"^") - . S $P(EVENT,",",CT)=$E(EVENT1)_$$LOW^XLFSTR($E(EVENT1,2,999)) - S FLT=FLT_$S(EVENT="":"",1:"Event: "_EVENT_" - ") - ; Origin - S FLT=FLT_$S(ORIGIN="":"",1:"Origin: "_ORIGIN_" - ") - ; Date Range - From - S FROM=$S($G(FROM)="":"",1:" from "_FROM) - ; Date Range - Until - S UNTIL=$S($G(UNTIL)="":"",1:" to "_UNTIL) - S FLT=FLT_$G(FROM)_$G(UNTIL) - ; If No Filter. Then get All. - I FLT="" S FLT="All Images" - Q FLT -REVDT(FROM,UNTIL,DAT1,DAT2) ; Calculate the Reverse Dates and switch for $O - ; for $O( through a data cross reference that is reversed, i.e. X=9999999.9999-DT - ; FROM = Date in External or Internal - ; UNTIL = Date in External or Internal - ; DAT1 = Reverse the two dates, FROM and UNTIL, equal to the earliest - ; DAT2 = Reverse the two dates, FROM and UNTIL, equal to the latest - ; - S DAT1=$$E2I^MAGSIXGT($G(FROM)) - S DAT2=$$E2I^MAGSIXGT($G(UNTIL)) - I 'DAT2 S DAT2=9999999.9999 - S DAT1=9999999.9999-DAT1 - S DAT2=9999999.9999-DAT2 - I DAT1]DAT2 S X=DAT1,DAT1=DAT2,DAT2=X - S DAT1=DAT1\1,$P(DAT2,".",2)="9999" - Q +MAGSIXG1 ;WOIFO/EdM/GEK/SEB - RPCs for Document Imaging ; 04/29/2002 16:15 + ;;3.0;IMAGING;**8,48**;Jan 11, 2005 + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q + ; + ; OUT ;--- Output array + ; CLS ;--- Class + ; TYPE ;-- Type (of what?) + ; SPEC ;-- Specialty or SubSpecialty + ; EVENT ;- Event or Procedure or Action +PGI(OUT,DFN,PKG,CLS,TYPE,EVENT,SPEC,FROM,UNTIL,ORIGIN) ;RPC [MAG4 PAT GET IMAGES] + ; Get Images for Patient. + ; New call in Patch 3.0.8 uses Image Filter to get list of images + ; + N C,DAT1,DAT2,E,IMAGE,N,OK,P,RDT,RESULT,S,T,V,CT,PKG1,CLS1,TYPE1,EVENT1,SPEC1,FLTX,FLTY,CAPDUZ,CAPDT,MAGVR,FNL + S FROM=$G(FROM),UNTIL=$G(UNTIL) + D REVDT(FROM,UNTIL,.DAT1,.DAT2) + S RESULT="OUT" K OUT,^TMP($T(+0),$J) + S PKG=$G(PKG),CLS=$G(CLS),EVENT=$G(EVENT),SPEC=$G(SPEC),TYPE=$G(TYPE),ORIGIN=$G(ORIGIN) + I PKG'="" D PKG^MAGSIXGT Q:$D(OUT(0)) + I CLS'="" D CLS^MAGSIXGT Q:$D(OUT(0)) + I EVENT'="" D EVENT^MAGSIXGT Q:$D(OUT(0)) + I SPEC'="" D SPEC^MAGSIXGT Q:$D(OUT(0)) + I TYPE'="" D TYPE^MAGSIXGT Q:$D(OUT(0)) + I ORIGIN'="" D ORIGIN^MAGSIXGT Q:$D(OUT(0)) + I +DFN'=DFN S @RESULT@(0)="0^Invalid Patient Number: """_DFN_"""." Q + I '$D(^DPT(DFN,0))#2 S @RESULT@(0)="0^No Such Patient: """_DFN_"""." Q + S N=0 + D NETPLCS^MAGGTU6 + ;S RDT="" F S RDT=$O(^MAG(2005,"APDTPX",DFN,RDT)) Q:RDT="" D + ;3.0.8/gek, Quit searching all images, just do the date range. + S RDT=DAT1 F S RDT=$O(^MAG(2005,"APDTPX",DFN,RDT)) Q:(RDT="")!(RDT>DAT2) D + . N COUNT,PRX,X0,X2,X40,I1,X01 + . S PRX="" F S PRX=$O(^MAG(2005,"APDTPX",DFN,RDT,PRX)) Q:PRX="" D + . . S IMAGE="" F S IMAGE=$O(^MAG(2005,"APDTPX",DFN,RDT,PRX,IMAGE)) Q:IMAGE="" D + . . . S X0=$G(^MAG(2005,IMAGE,0)) + . . . Q:$P(X0,"^",10) ; child of Group + . . . S X2=$G(^MAG(2005,IMAGE,2)),X40=$G(^MAG(2005,IMAGE,40)),I1=$O(^MAG(2005,IMAGE,1,0)) + . . . S P=$P(X40,U),C=$P(X40,"^",2),T=$P(X40,"^",3),E=$P(X40,"^",4),S=$P(X40,"^",5) + . . . S V=$S($P(X40,"^",6)="":"V",1:$P(X40,"^",6)) ; P48T1 show VA for Null + . . . D CHK^DIE(2005,45,"E",V,.MAGVR) S V=MAGVR(0) ; P48T1 show External Value + . . . I PKG'="",P'="",'$D(OK(5,P)) Q + . . . I ORIGIN'="",V'="",'$D(OK(6,V)) Q + . . . I CLS'="",C'="",'$D(OK(1,C)) Q + . . . I EVENT'="",E,'$D(OK(2,E)) Q + . . . ;3.0.8 Stop list entries with no Event, if Event is in Search Specs + . . . I EVENT'="",E="" Q + . . . I SPEC'="",S,'$D(OK(3,S)) Q + . . . ;3.0.8 Stop list entries with no Spec, if Spec is in Search Specs + . . . I SPEC'="",S="" Q + . . . I TYPE'="",T,'$D(OK(4,T)) Q + . . . ; Get Count of Images in Group, use 4th piece of ,1,0) multiple + . . . S COUNT=$S($P($G(^MAG(2005,IMAGE,1,0)),"^",4):$P($G(^MAG(2005,IMAGE,1,0)),"^",4),1:1) + . . . S FLTX="" + . . . ; PUT in Site Code as 2nd piece. + . . . S X01=$S(I1:$G(^MAG(2005,+$G(^MAG(2005,IMAGE,1,I1,0)),0)),1:X0) + . . . S FNL=$S(+$P(X01,"^",3):$P(X01,"^",3),1:+$P(X01,"^",5)) + . . . S FLTX=$P($G(MAGJOB("NETPLC",FNL)),"^",2) + . . . S FLTX=FLTX_"^"_$P($$FMTE^XLFDT($P(X2,"^",5),"5Z"),"@",1) + . . . S FLTX=FLTX_"^"_$P(X0,"^",8)_"^"_COUNT_"^"_$P(X2,"^",4) + . . . S FLTX=FLTX_"^"_P + . . . S FLTX=FLTX_"^"_$P($G(^MAG(2005.82,+C,0)),"^",1) + . . . S FLTX=FLTX_"^"_$P($G(^MAG(2005.83,+T,0)),"^",1) + . . . S FLTX=FLTX_"^"_$P($G(^MAG(2005.84,+S,0)),"^",1) + . . . S FLTX=FLTX_"^"_$P($G(^MAG(2005.85,+E,0)),"^",1) + . . . S FLTX=FLTX_"^"_V + . . . S FLTX=FLTX_"^"_$P($$FMTE^XLFDT($P(X2,"^",1),"5Z"),"@",1) + . . . ; P8T36 gek. Fix Error caused if $P(X2,"^",2) "ImageSavedBy" is null + . . . S FLTX=FLTX_"^"_$$GET1^DIQ(200,+$P(X2,"^",2)_",",.01) + . . . N MAGFILE,MAGXX + . . . S MAGXX=IMAGE D INFO^MAGGTII + . . . S FLTX=FLTX_"^"_$P(MAGFILE,"^",1) + . . . S N=N+1,@RESULT@(N+1)=N_"^"_FLTX_"|"_MAGFILE + . . . Q:N<101 Q:RESULT["^" + . . . ; Image count is getting big, switch from array to Global return type + . . . S ^TMP($T(+0),$J)="" + . . . M ^TMP($T(+0),$J)=OUT + . . . K OUT + . . . S X=$$RTRNFMT^XWBLIB("GLOBAL ARRAY",1) + . . . S RESULT=$NA(^TMP($T(+0),$J)) + . . . S OUT=$NA(^TMP($T(+0),$J)) ;GEK 10/01/02 + . . . Q + . . Q + . Q + S FLTY=$$FLTDESC(X) + I 'N S @RESULT@(0)="0^No images for filter: "_FLTY Q + S @RESULT@(0)="1^"_FLTY + S @RESULT@(1)="Item~S2^Site^Proc DT~S1^Procedure^# Img~S2^Short Desc^Pkg^Class^Type^Specialty^Event^Origin^Cap Dt~S1~W0^Cap by~~W0^Image ID~S2~W0" + Q +FLTDESC(X) ; + N FLT + S FLT="" + ; Package + S FLT=FLT_$S(PKG="":"",1:"Pkg: "_PKG_" - ") + ; Class + S FLT=FLT_$S(CLS="":"",CLS="ADMIN,ADMIN/CLIN,CLIN/ADMIN":"Class: ADMIN - ",CLS="CLIN,CLIN/ADMIN,ADMIN/CLIN":"Class: CLIN - ",1:"Class: "_CLS_" - ") + ; Type + F CT=1:1:$L(TYPE,",") D + . S TYPE1=$P(TYPE,",",CT) I TYPE1'="" S TYPE1=$P($G(^MAG(2005.83,TYPE1,0)),"^") + . S $P(TYPE,",",CT)=$E(TYPE1)_$$LOW^XLFSTR($E(TYPE1,2,999)) + S FLT=FLT_$S(TYPE="":"",1:"Type: "_TYPE_" - ") + ; Specialty/SubSpecialty + F CT=1:1:$L(SPEC,",") D + . S SPEC1=$P(SPEC,",",CT) I SPEC1'="" S SPEC1=$P($G(^MAG(2005.84,SPEC1,0)),"^") + . S $P(SPEC,",",CT)=$E(SPEC1)_$$LOW^XLFSTR($E(SPEC1,2,999)) + S FLT=FLT_$S(SPEC="":"",1:"Spec.: "_SPEC_" - ") + ; Procedure/Event + F CT=1:1:$L(EVENT,",") D + . S EVENT1=$P(EVENT,",",CT) I EVENT1'="" S EVENT1=$P($G(^MAG(2005.85,EVENT1,0)),"^") + . S $P(EVENT,",",CT)=$E(EVENT1)_$$LOW^XLFSTR($E(EVENT1,2,999)) + S FLT=FLT_$S(EVENT="":"",1:"Event: "_EVENT_" - ") + ; Orgin + S FLT=FLT_$S(ORIGIN="":"",1:"Origin: "_ORIGIN_" - ") + ; Date Range - From + S FROM=$S($G(FROM)="":"",1:" from "_FROM) + ; Date Range - Until + S UNTIL=$S($G(UNTIL)="":"",1:" to "_UNTIL) + S FLT=FLT_$G(FROM)_$G(UNTIL) + ; If No Filter. Then get All. + I FLT="" S FLT="All Images" + Q FLT +REVDT(FROM,UNTIL,DAT1,DAT2) ; Calculate the Reverse Dates and switch for $O + ; for $O( through a data cross reference that is reversed, i.e. X=9999999.9999-DT + ; FROM = Date in External or Internal + ; UNTIL = Date in External or Internal + ; DAT1 = Reverse the two dates, FROM and UNTIL, equal to the earliest + ; DAT2 = Reverse the two dates, FROM and UNTIL, equal to the latest + ; + S DAT1=$$E2I^MAGSIXGT($G(FROM)) + S DAT2=$$E2I^MAGSIXGT($G(UNTIL)) + I 'DAT2 S DAT2=9999999.9999 + S DAT1=9999999.9999-DAT1 + S DAT2=9999999.9999-DAT2 + I DAT1]DAT2 S X=DAT1,DAT1=DAT2,DAT2=X + S DAT1=DAT1\1,$P(DAT2,".",2)="9999" + Q diff --git a/r/IMAGING-MAG-ZMAG/MAGSIXGT.m b/r/IMAGING-MAG-ZMAG/MAGSIXGT.m index 86a67e8e..233272cd 100644 --- a/r/IMAGING-MAG-ZMAG/MAGSIXGT.m +++ b/r/IMAGING-MAG-ZMAG/MAGSIXGT.m @@ -1,233 +1,233 @@ -MAGSIXGT ;WOIFO/EdM/GEK/SEB - RPC for Document Imaging ; 04/29/2002 16:15 - ;;3.0;IMAGING;**8,48,61,59**;Nov 27, 2007;Build 20 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;; +---------------------------------------------------------------+ - ;; | Property of the US Government. | - ;; | No permission to copy or redistribute this software is given. | - ;; | Use of unreleased versions of this software requires the user | - ;; | to execute a written test agreement with the VistA Imaging | - ;; | Development Office of the Department of Veterans Affairs, | - ;; | telephone (301) 734-0100. | - ;; | The Food and Drug Administration classifies this software as | - ;; | a medical device. As such, it may not be changed in any way. | - ;; | Modifications to this software may result in an adulterated | - ;; | medical device under 21CFR820, the use of which is considered | - ;; | to be a violation of US Federal Statutes. | - ;; +---------------------------------------------------------------+ - ;; - Q - ; -IGT(OUT,CLS,FLGS) ;RPC [MAG4 INDEX GET TYPE] - ; OUT : the result array - ; CLS : a ',' separated list of Classes. - ; FLGS : An '^' delimited string - ; 1 IGN : Flag to IGNore the Status field - ; 2 INCL : Include Class in the Output string - ; 3 INST : Include Status in the Output String - ; - N C,D0,LOC,N,OK,X,NODE,IGN - N MAGX - K OUT - S CLS=$G(CLS),FLGS=$P($G(FLGS),"|") - ; Capture app will send CLS as ADMIN,ADMIN/CLIN for admin - ; or CLIN,CLIN/ADMIN for clinical - ; 61 - We're expanding CLASS returned to include ALL Clin - ; or all Admin - I CLS="ADMIN,ADMIN/CLIN" S CLS="ADMIN,ADMIN/CLIN,CLIN/ADMIN" - I CLS="CLIN,CLIN/ADMIN" S CLS="CLIN,CLIN/ADMIN,ADMIN/CLIN" - S IGN=$P(FLGS,"^",1),INCL=$P(FLGS,"^",2),INST=$P(FLGS,"^",3) - D CLS Q:$D(OUT(0)) - ; - S N=1 - S D0=0 F S D0=$O(^MAG(2005.83,D0)) Q:'D0 D - . S X=$G(^MAG(2005.83,D0,0)),C=$P(X,"^",2) - . ; if Class not null, check it. Null classes will be listed in output. - . I CLS'="" Q:C="" Q:'$D(OK(1,C)) - . I 'IGN Q:$P(X,"^",3)="I" ; This is the Status field inactive Flag; - . S NODE=$P(X,"^",1)_"^"_$P($G(^MAG(2005.83,D0,1)),"^",1) - . I INCL S NODE=NODE_"^"_$$GET1^DIQ(2005.83,D0,1,"MAGX") - . I INST S NODE=NODE_"^"_$$GET1^DIQ(2005.83,D0,2,"MAGX") - . S LOC(NODE_"|"_D0)="" - . Q - S X="" F S X=$O(LOC(X)) Q:X="" S N=N+1,OUT(N)=X - I N<2 S OUT(0)="0^-3, No Types Found for """_CLS_"""." Q - S OUT(0)="1^OK: "_N - S OUT(1)=CLS_" Image Types^Abbr" - I INCL S OUT(1)=OUT(1)_"^Class" - I INST S OUT(1)=OUT(1)_"^Status" - Q -IGE(OUT,CLS,SPEC,FLGS) ;RPC [MAG4 INDEX GET EVENT] - ; Index Get Procedure/Event (optionally based on (Sub)Specialty) - ; OUT : the result array - ; CLS : a ',' separated list of Classes. - ; SPEC : a ',' separated list of Spec/Subspecialties - ; FLGS : An '^' delimited string - ; - IGN [1|0] : Flag to IGNore the Status field - ; - INCL [1|0] : Include Class in the Output string - ; - INST [1|0] : Include Status in the Output String - ; - N C,D0,D1,LOC,N,NO,OK,S,X,NODE - K OUT - S CLS=$G(CLS),SPEC=$G(SPEC),FLGS=$P($G(FLGS),"|") - S IGN=$P(FLGS,"^",1),INCL=$P(FLGS,"^",2),INST=$P(FLGS,"^",3) - D CLS Q:$D(OUT(0)) - D SPEC Q:$D(OUT(0)) - ; - S N=1 - S D0=0 F S D0=$O(^MAG(2005.85,D0)) Q:'D0 D - . S X=$G(^MAG(2005.85,D0,0)),C=$P(X,"^",2) - . ; if Class not null, check it. Null classes will be listed in output. - . I CLS'="" Q:C="" Q:'$D(OK(1,C)) - . I 'IGN Q:$P(X,"^",3)="I" ;This is the Status field inactive Flag; - . ; if Specialty not null, check it. Null Specialties will be listed in output. - . I SPEC'="" D Q:NO - . . S NO=0 - . . ; Next line: put "S:'D1 NO=1" before the quit to block implicit mapping - . . S D1=0 F S D1=$O(^MAG(2005.85,D0,1,D1)) Q:'D1 D Q:'NO - . . . S NO=1 - . . . S S=$P($G(^MAG(2005.85,D0,1,D1,0)),"^",1) - . . . Q:S="" - . . . S:$D(OK(3,S)) NO=0 - . . . Q - . . Q - . S NODE=$P(X,"^",1)_"^"_$P($G(^MAG(2005.85,D0,2)),"^",1) - . I INCL S NODE=NODE_"^"_$$GET1^DIQ(2005.85,D0,1,"MAGX") - . I INST S NODE=NODE_"^"_$$GET1^DIQ(2005.85,D0,4,"MAGX") - . S LOC(NODE_"|"_D0)="" - . Q - S X="" F S X=$O(LOC(X)) Q:X="" S N=N+1,OUT(N)=X - I N<2 S OUT(0)="0^No Procedures or Events found for """_CLS_""" and """_SPEC_"""." Q - S OUT(0)="1^OK: "_N - S OUT(1)="Procedure/Event^Abbr" - I INCL S OUT(1)=OUT(1)_"^Class" - I INST S OUT(1)=OUT(1)_"^Status" - Q - ; -IGS(OUT,CLS,EVENT,FLGS) ;RPC [MAG4 INDEX GET SPECIALTY] - ; OUT : the result array - ; CLS : a ',' separated list of Classes. - ; EVENT : a ',' separated list of Proc/Events - ; FLGS : An '^' delimited string - ; - IGN [1|0] : Flag to IGNore the Status field - ; - INCL [1|0] : Include Class in the Output string - ; - INST [1|0] : Include Status in the Output String - ; - INSP [1|0] : Include Specialty in the OutPut String - ; - N C,D0,D1,E,LOC,N,OK,X - K OUT - S CLS=$G(CLS),EVENT=$G(EVENT),FLGS=$P($G(FLGS),"|") - S IGN=$P(FLGS,"^",1),INCL=$P(FLGS,"^",2),INST=$P(FLGS,"^",3),INSP=$P(FLGS,"^",4) - I CLS'="" D CLS Q:$D(OUT(0)) - I EVENT'="" D EVENT Q:$D(OUT(0)) - ; - S N=1 - I EVENT="" S D0=0 F S D0=$O(^MAG(2005.84,D0)) Q:'D0 D - . S X=$G(^MAG(2005.84,D0,0)),C=$P(X,"^",2) ;,E=$P(X,"^",3) - . ; if Class not null, check it. Null classes will be listed in output. - . I CLS'="" Q:C="" Q:'$D(OK(1,C)) - . I 'IGN Q:$P(X,"^",4)="I" ; This is the Status field inactive Flag; - . ;I EVENT'="" Q:E="" Q:'$D(OK(2,E)) - . S NODE=$P(X,"^",1)_"^"_$P($G(^MAG(2005.84,D0,2)),"^",1) - . I INCL S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D0,1,"MAGX") - . I INST S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D0,4,"MAGX") - . I INSP S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D0,2,"MAGX") - . S LOC(NODE_"|"_D0)="" - . Q - I EVENT]"" S E="" F S E=$O(OK(2,E)) Q:E="" D - . ; if Class isn't null, include image if Class matches; - . ; images with Null classes will be listed in output. - . I CLS'="" S C=$P($G(^MAG(2005.85,E,0)),"^",2) Q:'$D(OK(1,C)) - . ; if this procedure has specialty pointers, include it if they matches. - . ; images with Proc/Event - . I +$P($G(^MAG(2005.85,E,1,0)),U,3)=0 D GETSPECS(.LOC,INCL,INST,INSP) - . S D0="0" F S D0=$O(^MAG(2005.85,E,1,D0)) Q:D0="" D - . . S D1=$G(^MAG(2005.85,E,1,D0,0)) I D1="" Q - . . S X=$G(^MAG(2005.84,D1,0)) - . . I '(X]"") Q - . . S NODE=$P(X,"^",1)_"^"_$P($G(^MAG(2005.84,D1,2)),"^",1) - . . I INCL S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D1,1,"MAGX") - . . I INST S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D1,4,"MAGX") - . . I INSP S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D1,2,"MAGX") - . . S LOC(NODE_"|"_D1)="" - . Q - S X="" F S X=$O(LOC(X)) Q:X="" S N=N+1,OUT(N)=X - I N<2 S OUT(0)="0^-5, No (Sub)Specialties found for """_CLS_""" and """_EVENT_"""." Q - S OUT(0)="1^OK: "_N - S OUT(1)="Specialty/SubSpecialty^Abbr" - I INCL S OUT(1)=OUT(1)_"^Class" - I INST S OUT(1)=OUT(1)_"^Status" - I INSP S OUT(1)=OUT(1)_"^Specialty" - Q - ; -PKG N P,I - I $G(PKG)="" Q - F I=1:1:$L(PKG,",") I $L($P(PKG,",",I)) S OK(5,$P(PKG,",",I))="" - Q -ORIGIN N I - N V,MAGR,MAGD,MAGE - I $G(ORIGIN)="" Q - ; P48T1 Allow Internal or External for Origin (set of codes) - F I=1:1:$L(ORIGIN,",") I $L($P(ORIGIN,",",I)) S OK(6,$P(ORIGIN,",",I))="" D - . S MAGD=$P(ORIGIN,",",I) - . D CHK^DIE(2005,45,"E",MAGD,.MAGR) I MAGR'="^" S OK(6,MAGR)="",OK(6,MAGR(0))="" - Q -CLS N C,CLSX,I - I $G(CLS)="" Q - F I=1:1:$L(CLS,",") I $L($P(CLS,",",I)) S CLSX=$P(CLS,",",I) D - . I CLSX=+CLSX,$D(^MAG(2005.82,CLSX)) S OK(1,CLSX)="" - . S C="" F S C=$O(^MAG(2005.82,"B",CLSX,C)) Q:C="" S OK(1,C)="" - I $O(OK(1,""))="" S OUT(0)="0^Invalid Class: """_CLS_"""." Q - Q - ; -EVENT N E,EVENTX,I - I $G(EVENT)="" Q - F I=1:1:$L(EVENT,",") I $L($P(EVENT,",",I)) S EVENTX=$P(EVENT,",",I) D - . I EVENTX=+EVENTX,$D(^MAG(2005.85,EVENTX)) S OK(2,EVENTX)="" - . S E="" F S E=$O(^MAG(2005.85,"B",EVENTX,E)) Q:E="" S OK(2,E)="" - I $O(OK(2,""))="" S OUT(0)="0^Invalid Event: """_EVENT_"""." Q - Q - ; -SPEC N S,SS,SPECX,I - I $G(SPEC)="" Q - ; Here we examine each piece of Spec, If piece is a Specialty, include - ; its subspecialties. - ; - F I=1:1:$L(SPEC,",") I $L($P(SPEC,",",I)) S SPECX=$P(SPEC,",",I) D - . I SPECX=+SPECX,$D(^MAG(2005.84,SPECX)) S OK(3,SPECX)="" - . S S="" F S S=$O(^MAG(2005.84,"B",SPECX,S)) Q:S="" S OK(3,S)="" - . Q - I $O(OK(3,""))="" S OUT(0)="0^Invalid Specialty: """_SPEC_"""." Q - I $D(MAGJOB("CAPTURE")) Q ; 59 for capture we don't want subspecs. - S S="" F S S=$O(OK(3,S)) Q:S="" I $D(^MAG(2005.84,"ASPEC",S)) D - . S SS="" F S SS=$O(^MAG(2005.84,"ASPEC",S,SS)) Q:SS="" S OK(3,SS)="" - . Q - Q - ; -TYPE N T,TYPEX,I - I $G(TYPE)="" Q - F I=1:1:$L(TYPE,",") I $L($P(TYPE,",",I)) S TYPEX=$P(TYPE,",",I) D - . I TYPEX=+TYPEX,$D(^MAG(2005.83,TYPEX)) S OK(4,TYPEX)="" - . S T="" F S T=$O(^MAG(2005.83,"B",TYPEX,T)) Q:T="" S OK(4,T)="" - I $O(OK(4,""))="" S OUT(0)="0^Invalid Type: """_TYPE_"""." Q - Q - ; -GETSPECS(LOC,INCL,INST,INSP) N D0,X,NODE - S D0=0 F S D0=$O(^MAG(2005.84,D0)) Q:'D0 D - . S X=$G(^MAG(2005.84,D0,0)) - . ;I X]"" S LOC($P(X,"^",1)_"^"_$P($G(^MAG(2005.84,D0,2)),"^",1)_"|"_D0)="" - . ;Q - . S NODE=$P(X,"^",1)_"^"_$P($G(^MAG(2005.84,D0,2)),"^",1) - . I INCL S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D0,1,"MAGX") - . I INST S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D0,4,"MAGX") - . I INSP S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D0,2,"MAGX") - . S LOC(NODE_"|"_D0)="" - . Q - Q - ; -D2(N) Q $TR($J(N,2)," ",0) - ; -E2I(D) N %DT,X,Y - Q:$P(D,".",1)?7N D\1 - Q:D="" 0 - S X=D,%DT="TS" D ^%DT Q:Y<0 0 - Q Y\1 +MAGSIXGT ;WOIFO/EdM/GEK/SEB - RPC for Document Imaging ; 04/29/2002 16:15 + ;;3.0;IMAGING;**8,48,61**;Feb 07, 2006 + ;; +---------------------------------------------------------------+ + ;; | Property of the US Government. | + ;; | No permission to copy or redistribute this software is given. | + ;; | Use of unreleased versions of this software requires the user | + ;; | to execute a written test agreement with the VistA Imaging | + ;; | Development Office of the Department of Veterans Affairs, | + ;; | telephone (301) 734-0100. | + ;; | | + ;; | The Food and Drug Administration classifies this software as | + ;; | a medical device. As such, it may not be changed in any way. | + ;; | Modifications to this software may result in an adulterated | + ;; | medical device under 21CFR820, the use of which is considered | + ;; | to be a violation of US Federal Statutes. | + ;; +---------------------------------------------------------------+ + ;; + Q + ; +IGT(OUT,CLS,FLGS) ;RPC [MAG4 INDEX GET TYPE] + ; OUT : the result array + ; CLS : a ',' separated list of Classes. + ; FLGS : An '^' delimited string + ; 1 IGN : Flag to IGNore the Status field + ; 2 INCL : Include Class in the Output string + ; 3 INST : Include Status in the Output String + ; + N C,D0,LOC,N,OK,X,NODE,IGN + N MAGX + K OUT + S CLS=$G(CLS),FLGS=$G(FLGS) + ; Capture app will send CLS as ADMIN,ADMIN/CLIN for admin + ; or CLIN,CLIN/ADMIN for clinical + ; 61 - We're expanding CLASS returned to include ALL Clin + ; or all Admin + I CLS="ADMIN,ADMIN/CLIN" S CLS="ADMIN,ADMIN/CLIN,CLIN/ADMIN" + I CLS="CLIN,CLIN/ADMIN" S CLS="CLIN,CLIN/ADMIN,ADMIN/CLIN" + S IGN=$P(FLGS,"^",1),INCL=$P(FLGS,"^",2),INST=$P(FLGS,"^",3) + D CLS Q:$D(OUT(0)) + ; + S N=1 + S D0=0 F S D0=$O(^MAG(2005.83,D0)) Q:'D0 D + . S X=$G(^MAG(2005.83,D0,0)),C=$P(X,"^",2) + . ; if Class not null, check it. Null classes will be listed in output. + . I CLS'="" Q:C="" Q:'$D(OK(1,C)) + . I 'IGN Q:$P(X,"^",3)="I" ; This is the Status field inactive Flag; + . S NODE=$P(X,"^",1)_"^"_$P($G(^MAG(2005.83,D0,1)),"^",1) + . I INCL S NODE=NODE_"^"_$$GET1^DIQ(2005.83,D0,1,"MAGX") + . I INST S NODE=NODE_"^"_$$GET1^DIQ(2005.83,D0,2,"MAGX") + . S LOC(NODE_"|"_D0)="" + . Q + S X="" F S X=$O(LOC(X)) Q:X="" S N=N+1,OUT(N)=X + I N<2 S OUT(0)="0^-3, No Types Found for """_CLS_"""." Q + S OUT(0)="1^OK: "_N + S OUT(1)=CLS_" Image Types^Abbr" + I INCL S OUT(1)=OUT(1)_"^Class" + I INST S OUT(1)=OUT(1)_"^Status" + Q +IGE(OUT,CLS,SPEC,FLGS) ;RPC [MAG4 INDEX GET EVENT] + ; Index Get Procedure/Event (optionally based on (Sub)Specialty) + ; OUT : the result array + ; CLS : a ',' separated list of Classes. + ; SPEC : a ',' separated list of Spec/Subspecialties + ; FLGS : An '^' delimited string + ; - IGN [1|0] : Flag to IGNore the Status field + ; - INCL [1|0] : Include Class in the Output string + ; - INST [1|0] : Include Status in the Output String + ; + N C,D0,D1,LOC,N,NO,OK,S,X,NODE + K OUT + S CLS=$G(CLS),SPEC=$G(SPEC),FLGS=$G(FLGS) + S IGN=$P(FLGS,"^",1),INCL=$P(FLGS,"^",2),INST=$P(FLGS,"^",3) + D CLS Q:$D(OUT(0)) + D SPEC Q:$D(OUT(0)) + ; + S N=1 + S D0=0 F S D0=$O(^MAG(2005.85,D0)) Q:'D0 D + . S X=$G(^MAG(2005.85,D0,0)),C=$P(X,"^",2) + . ; if Class not null, check it. Null classes will be listed in output. + . I CLS'="" Q:C="" Q:'$D(OK(1,C)) + . I 'IGN Q:$P(X,"^",3)="I" ;This is the Status field inactive Flag; + . ; if Specialty not null, check it. Null Specialties will be listed in output. + . I SPEC'="" D Q:NO + . . S NO=0 + . . ; Next line: put "S:'D1 NO=1" before the quit to block implicit mapping + . . S D1=0 F S D1=$O(^MAG(2005.85,D0,1,D1)) Q:'D1 D Q:'NO + . . . S NO=1 + . . . S S=$P($G(^MAG(2005.85,D0,1,D1,0)),"^",1) + . . . Q:S="" + . . . S:$D(OK(3,S)) NO=0 + . . . Q + . . Q + . S NODE=$P(X,"^",1)_"^"_$P($G(^MAG(2005.85,D0,2)),"^",1) + . I INCL S NODE=NODE_"^"_$$GET1^DIQ(2005.85,D0,1,"MAGX") + . I INST S NODE=NODE_"^"_$$GET1^DIQ(2005.85,D0,4,"MAGX") + . S LOC(NODE_"|"_D0)="" + . Q + S X="" F S X=$O(LOC(X)) Q:X="" S N=N+1,OUT(N)=X + I N<2 S OUT(0)="0^No Procedures or Events found for """_CLS_""" and """_SPEC_"""." Q + S OUT(0)="1^OK: "_N + S OUT(1)="Procedure/Event^Abbr" + I INCL S OUT(1)=OUT(1)_"^Class" + I INST S OUT(1)=OUT(1)_"^Status" + Q + ; +IGS(OUT,CLS,EVENT,FLGS) ;RPC [MAG4 INDEX GET SPECIALTY] + ; OUT : the result array + ; CLS : a ',' separated list of Classes. + ; EVENT : a ',' separated list of Proc/Events + ; FLGS : An '^' delimited string + ; - IGN [1|0] : Flag to IGNore the Status field + ; - INCL [1|0] : Include Class in the Output string + ; - INST [1|0] : Include Status in the Output String + ; - INSP [1|0] : Include Specialty in the OutPut String + ; + N C,D0,D1,E,LOC,N,OK,X + K OUT + S CLS=$G(CLS),EVENT=$G(EVENT),FLGS=$G(FLGS) + S IGN=$P(FLGS,"^",1),INCL=$P(FLGS,"^",2),INST=$P(FLGS,"^",3),INSP=$P(FLGS,"^",4) + I CLS'="" D CLS Q:$D(OUT(0)) + I EVENT'="" D EVENT Q:$D(OUT(0)) + ; + S N=1 + I EVENT="" S D0=0 F S D0=$O(^MAG(2005.84,D0)) Q:'D0 D + . S X=$G(^MAG(2005.84,D0,0)),C=$P(X,"^",2) ;,E=$P(X,"^",3) + . ; if Class not null, check it. Null classes will be listed in output. + . I CLS'="" Q:C="" Q:'$D(OK(1,C)) + . I 'IGN Q:$P(X,"^",4)="I" ; This is the Status field inactive Flag; + . ;I EVENT'="" Q:E="" Q:'$D(OK(2,E)) + . S NODE=$P(X,"^",1)_"^"_$P($G(^MAG(2005.84,D0,2)),"^",1) + . I INCL S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D0,1,"MAGX") + . I INST S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D0,4,"MAGX") + . I INSP S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D0,2,"MAGX") + . S LOC(NODE_"|"_D0)="" + . Q + I EVENT]"" S E="" F S E=$O(OK(2,E)) Q:E="" D + . ; if Class isn't null, include image if Class matches; + . ; images with Null classes will be listed in output. + . I CLS'="" S C=$P($G(^MAG(2005.85,E,0)),"^",2) Q:'$D(OK(1,C)) + . ; if this procedure has specialty pointers, include it if they matches. + . ; images with Proc/Event + . I +$P($G(^MAG(2005.85,E,1,0)),U,3)=0 D GETSPECS(.LOC,INCL,INST,INSP) + . S D0="0" F S D0=$O(^MAG(2005.85,E,1,D0)) Q:D0="" D + . . S D1=$G(^MAG(2005.85,E,1,D0,0)) I D1="" Q + . . S X=$G(^MAG(2005.84,D1,0)) + . . I '(X]"") Q + . . S NODE=$P(X,"^",1)_"^"_$P($G(^MAG(2005.84,D1,2)),"^",1) + . . I INCL S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D1,1,"MAGX") + . . I INST S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D1,4,"MAGX") + . . I INSP S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D1,2,"MAGX") + . . S LOC(NODE_"|"_D1)="" + . Q + S X="" F S X=$O(LOC(X)) Q:X="" S N=N+1,OUT(N)=X + I N<2 S OUT(0)="0^-5, No (Sub)Specialties found for """_CLS_""" and """_EVENT_"""." Q + S OUT(0)="1^OK: "_N + S OUT(1)="Specialty/SubSpecialty^Abbr" + I INCL S OUT(1)=OUT(1)_"^Class" + I INST S OUT(1)=OUT(1)_"^Status" + I INSP S OUT(1)=OUT(1)_"^Specialty" + Q + ; +PKG N P,I + I $G(PKG)="" Q + F I=1:1:$L(PKG,",") I $L($P(PKG,",",I)) S OK(5,$P(PKG,",",I))="" + Q +ORIGIN N I + N V,MAGR,MAGD,MAGE + I $G(ORIGIN)="" Q + ; P48T1 Allow Internal or External for Origin (set of codes) + F I=1:1:$L(ORIGIN,",") I $L($P(ORIGIN,",",I)) S OK(6,$P(ORIGIN,",",I))="" D + . S MAGD=$P(ORIGIN,",",I) + . D CHK^DIE(2005,45,"E",MAGD,.MAGR) I MAGR'="^" S OK(6,MAGR)="",OK(6,MAGR(0))="" + Q +CLS N C,CLSX,I + I $G(CLS)="" Q + F I=1:1:$L(CLS,",") I $L($P(CLS,",",I)) S CLSX=$P(CLS,",",I) D + . I CLSX=+CLSX,$D(^MAG(2005.82,CLSX)) S OK(1,CLSX)="" + . S C="" F S C=$O(^MAG(2005.82,"B",CLSX,C)) Q:C="" S OK(1,C)="" + I $O(OK(1,""))="" S OUT(0)="0^Invalid Class: """_CLS_"""." Q + Q + ; +EVENT N E,EVENTX,I + I $G(EVENT)="" Q + F I=1:1:$L(EVENT,",") I $L($P(EVENT,",",I)) S EVENTX=$P(EVENT,",",I) D + . I EVENTX=+EVENTX,$D(^MAG(2005.85,EVENTX)) S OK(2,EVENTX)="" + . S E="" F S E=$O(^MAG(2005.85,"B",EVENTX,E)) Q:E="" S OK(2,E)="" + I $O(OK(2,""))="" S OUT(0)="0^Invalid Event: """_EVENT_"""." Q + Q + ; +SPEC N S,SS,SPECX,I + I $G(SPEC)="" Q + ; Here we examine each piece of Spec, If piece is a Specialty, include + ; its subspecialties. + ; + F I=1:1:$L(SPEC,",") I $L($P(SPEC,",",I)) S SPECX=$P(SPEC,",",I) D + . I SPECX=+SPECX,$D(^MAG(2005.84,SPECX)) S OK(3,SPECX)="" + . S S="" F S S=$O(^MAG(2005.84,"B",SPECX,S)) Q:S="" S OK(3,S)="" + . Q + I $O(OK(3,""))="" S OUT(0)="0^Invalid Specialty: """_SPEC_"""." Q + I $D(MAGJOB("CAPTURE")) Q ; 59 for capture we don't want subspecs. + S S="" F S S=$O(OK(3,S)) Q:S="" I $D(^MAG(2005.84,"ASPEC",S)) D + . S SS="" F S SS=$O(^MAG(2005.84,"ASPEC",S,SS)) Q:SS="" S OK(3,SS)="" + . Q + Q + ; +TYPE N T,TYPEX,I + I $G(TYPE)="" Q + F I=1:1:$L(TYPE,",") I $L($P(TYPE,",",I)) S TYPEX=$P(TYPE,",",I) D + . I TYPEX=+TYPEX,$D(^MAG(2005.83,TYPEX)) S OK(4,TYPEX)="" + . S T="" F S T=$O(^MAG(2005.83,"B",TYPEX,T)) Q:T="" S OK(4,T)="" + I $O(OK(4,""))="" S OUT(0)="0^Invalid Type: """_TYPE_"""." Q + Q + ; +GETSPECS(LOC,INCL,INST,INSP) N D0,X,NODE + S D0=0 F S D0=$O(^MAG(2005.84,D0)) Q:'D0 D + . S X=$G(^MAG(2005.84,D0,0)) + . ;I X]"" S LOC($P(X,"^",1)_"^"_$P($G(^MAG(2005.84,D0,2)),"^",1)_"|"_D0)="" + . ;Q + . S NODE=$P(X,"^",1)_"^"_$P($G(^MAG(2005.84,D0,2)),"^",1) + . I INCL S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D0,1,"MAGX") + . I INST S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D0,4,"MAGX") + . I INSP S NODE=NODE_"^"_$$GET1^DIQ(2005.84,D0,2,"MAGX") + . S LOC(NODE_"|"_D0)="" + . Q + Q + ; +D2(N) Q $TR($J(N,2)," ",0) + ; +E2I(D) N %DT,X,Y + Q:$P(D,".",1)?7N D\1 + Q:D="" 0 + S X=D,%DT="TS" D ^%DT Q:Y<0 0 + Q Y\1 diff --git a/r/INCOME_VERIFICATION_MATCH-IVM/IVMCM.m b/r/INCOME_VERIFICATION_MATCH-IVM/IVMCM.m index 6d5e4f4f..6c759462 100644 --- a/r/INCOME_VERIFICATION_MATCH-IVM/IVMCM.m +++ b/r/INCOME_VERIFICATION_MATCH-IVM/IVMCM.m @@ -1,264 +1,262 @@ -IVMCM ;ALB/SEK,KCL,RTK,AEG,BRM,AEG - PROCESS INCOME TEST (Z10) TRANSMISSIONS ; 04/23/03 1:43pm - ;;2.0;INCOME VERIFICATION MATCH;**12,17,28,41,44,53,34,49,59,55,63,77,74,123**;21-OCT-94;Build 6 - ; - ; -ORF ; Handler for ORF type HL7 messages received from HEC - ; - ; Make sure POSTMASTER DUZ instead of DUZ of Person who - ; started Incoming Logical Link. - S DUZ=.5 - N CNT,IVMRTN,SEGCNT - S IVMRTN="IVMCMX" ;USE "IVMCMX" BECAUSE "IVMCM" ALREADY USED - K ^TMP($J,IVMRTN),DIC - S (DGMSGF,DGMTMSG)=1 ; HL7 rtn. Don't need DG interative messages. - S HLECH=HL("ECH"),HLQ=HL("Q"),HLMID=HL("MID") - K %,%H,%I D NOW^%DTC S HLDT=% - F SEGCNT=1:1 X HLNEXT Q:HLQUIT'>0 D - . S CNT=0 - . S ^TMP($J,IVMRTN,SEGCNT,CNT)=HLNODE - . F S CNT=$O(HLNODE(CNT)) Q:'CNT D - . . S ^TMP($J,IVMRTN,SEGCNT,CNT)=HLNODE(CNT) - S HLDA=HLMTIEN - ; - N SEG,EVENT,MSGID - S:'$D(HLEVN) HLEVN=0 - D NXTSEG^DGENUPL(HLDA,0,.SEG) - Q:(SEG("TYPE")'="MSH") ;would not have reached here if this happened! - S EVENT=$P(SEG(9),$E(HLECH),2) - ; - ; INITIALIZE HL7 VARIABLES - S HLEID="VAMC "_$P($$SITE^VASITE,"^",3)_" ORF-"_EVENT_" SERVER" - S HLEID=$O(^ORD(101,"B",HLEID,0)) - D INIT^HLFNC2(HLEID,.HL) - S HLEIDS=$O(^ORD(101,HLEID,775,"B",0)) - ; - ; Handle means test signature ORF (Z06) event - I EVENT="Z06" D ORF^IVMPREC7 - ; - ; Handle income test ORF (Z10) event - I EVENT="Z10" D Z10 - ; - ; Handle enrollment/elig. ORF (Z11) event - I EVENT="Z11" D - .S MSGID=SEG(10) - .D ORFZ11^DGENUPL(HLDA,MSGID) - ; - K ^TMP($J,IVMRTN) - Q - ; - ; -Z10 ; Entry point for receipt of ORF~Z10 transmission - ; The Income Test (Z10) transmission has the following format: - ; - ; BHS ORF msgs do not include batch header or trailer. - ; {MSH - ; PID They will include the sequence: MSA - ; ZIC QRD - ; ZIR QRF - ; {ZDP These segments will follow the MSH segment. - ; ZIC - ; ZIR - ; } - ; {ZMT - ; } - ; ZBT - ; } - ; BTS - ; - S IVMORF=1 ; set ORF msg flag - S (HLEVN,IVMCT,IVMERROR,IVMCNTR)=0 ; init vars - ; -ORU ; Entry point for receipt of ORU~Z10 trans (called by IVMPREC2) - S IVMTYPE=5,IVMZ10F=1 - ; - ; - loop through the msg in (#772 file), and process (PROC) msgs - S IVMDA=0 F S IVMDA=$O(^TMP($J,IVMRTN,IVMDA)) Q:'IVMDA S IVMSEG=$G(^(IVMDA,0)) I $E(IVMSEG,1,3)="MSH" D PROC Q:'IVMDA - ; - ; - if ORF msg flag, update the Query Tran Log and send ACK - I $G(IVMORF) D - .I $G(DFN),$D(IVMMCI) D - ..N IVMCR - ..S IVMCR=$P("1^2^3^7^5^6^4","^",IVMTYPE) ;map reason to test type - ..D FIND^IVMCQ2(DFN,IVMMCI,HLDT,$S($D(HLERR):5,1:IVMCR),1) - .;D ACK^IVMPREC:'$D(HLERR) - .;N HLRESLTA,HLP - .;D GENACK^HLMA1(HLEID,HLMTIEN,HLEIDS,"LM",1,.HLRESLTA,"",.HLP) - ; - ; - if tests are uploaded, generate notification msg - I $D(^TMP($J,"IVMBULL")) D ^IVMCMB - ; -ENQ ; - K IVMDA,IVMORF,IVMSEG,IVMFLGC,IVMTYPE,IVMMTIEN,IVMMTDT,IVMDGBT,IVMMCI - K ^TMP($J,"IVMCM"),^("IVMBULL"),DGMSGF,DGADDF,IVMCPAY,IVMBULL,DFN - K DGMTMSG,IVMZ10F - Q - ; -PROC ; Process each HL7 message from (#772) file - ; - N IVMFUTR,TMSTAMP,SOURCE,NODE,HSDATE,IVMZ10,DGMTP,DGMTACT,DGMTI,DGMTA - S DGMTACT="ADD" - D PRIOR^DGMTEVT - S IVMZ10="UPLOAD IN PROGRESS" - S IVMFUTR=0 ;this flag will indicate whether or not a test with a future date is being uploaded - S IVMMTIEN=0 - ; - S MSGID=$P(IVMSEG,HLFS,10) ; msg control id for ACK's - ; - check if DCD messaging is enabled - I '$$DCDON^IVMUPAR1() D PROB^IVMCMC("Facility has DCD messaging disabled") Q - ; - ; - check HL7 msg structure for errors - K HLERR,^TMP($J,"IVMCM") - D ^IVMCMC I $D(HLERR) K:HLERR="" HLERR Q - ; - ; Determine type of test/transmission - S IVMTYPE=0 - ; - ; - was a means test sent? - I $P($G(^TMP($J,"IVMCM","ZMT1")),HLFS,2) S IVMTYPE=1 ; MT trans - ; - ; - if MT and CT transmitted, error - pt can't have both unless - ; one is a deletion, but HEC not currently handling that situation - I IVMTYPE,$P($G(^TMP($J,"IVMCM","ZMT2")),HLFS,2) D PROB^IVMCMC("Patient can not have both a Means Test and Copay Test") Q - I $P($G(^TMP($J,"IVMCM","ZMT2")),HLFS,2) S IVMTYPE=2 ; CT trans - ; - ; - if no MT or CT or LTC then Income Screening - I 'IVMTYPE,'$P($G(^TMP($J,"IVMCM","ZMT4")),HLFS,2) S IVMTYPE=3 ; IS trans - ; - ;send an eligibility query if no eligibility code - I '$$ELIG^IVMCUF1(DFN),'$$PENDING^DGENQRY(DFN) I $$SEND^DGENQRY1(DFN) - ; - ; obtain locks used to sychronize upload with local income test options - D GETLOCKS^IVMCUPL(DFN) - ; - ; -MT ; If transmission is a Means Test - N NODE0,RET,CODE,DATA - S HLQ=$G(HL("Q")) - S:HLQ="" HLQ="""""" - I IVMTYPE=1 D I $D(HLERR) G PROCQ - .S IVMMTDT=$$FMDATE^HLFNC($P($G(^TMP($J,"IVMCM","ZMT1")),HLFS,2)) - .S TMSTAMP=$$FMDATE^HLFNC($P($G(^TMP($J,"IVMCM","ZMT1")),HLFS,25)) - .S HSDATE=$$FMDATE^HLFNC($P($G(^TMP($J,"IVMCM","ZMT1")),HLFS,24)) - .S SOURCE=$P($G(^TMP($J,"IVMCM","ZMT1")),HLFS,22) - .S IVMLAST=$$LST^DGMTU(DFN,$E(IVMMTDT,1,3)_1231,1) - .; Check that test is for same year - .I $P(IVMLAST,U,2),$E($P(IVMLAST,U,2),1,3)'=$E(IVMMTDT,1,3) S IVMLAST="" - .I $$Z06MT^EASPTRN1(+IVMLAST) D PROB^IVMCMC("IVM Means Test already on file for this year") Q - .I '$$ELIG^IVMUFNC5(DFN) S ERRMSG="Means Test upload not appropriate for current patient" - .I $$AGE^IVMUFNC5(DT)>$$INCY^IVMUFNC5(IVMMTDT) D - ..N CATCZMT S CATCZMT=$G(^TMP($J,"IVMCM","ZMT1")) - ..S CATC=$$CATC^IVMUFNC5(CATCZMT) - ..I '+$G(CATC) S ERRMSG="Only Means Tests in current/previous income years are valid (not effective)" - .I $G(ERRMSG)'="" D PROB^IVMCMC(ERRMSG) K ERRMSG,CATC Q - .; - .; - perform edit checks and file MT - .D CHKDT - .;deletion indicator sent? - .I $P($G(^TMP($J,"IVMCM","ZMT1")),HLFS,3)=HLQ D Q - ..D - ...;if there is a future test for that income year, delete that - ...N IEN,DATA,IVMPAT - ...S IEN=$$FUTURE(DFN,($E(IVMMTDT,1,3)-1),1,.IVMPAT) - ...I IEN S DATA(.06)="" I $$UPD^DGENDBS(301.5,IVMPAT,.DATA) - ...I IEN,$D(^DGMT(408.31,IEN,0)) D - ....S IVMMTIEN=IEN - ....S IVMFUTR=1 - ...E D - ....S IVMFUTR=0 - ..Q:('IVMMTIEN) - ..S NODE0=$G(^DGMT(408.31,IVMMTIEN,0)) - ..I $$EN^IVMCMD(IVMMTIEN) D - ...S RET=$$LST^DGMTU(DFN,DT,IVMTYPE) - ...S CODE=$S(($E($P(RET,"^",2),1,3)=$E(DT,1,3)):$P(RET,"^",4),1:"") - ...D ADD^IVMCMB(DFN,IVMTYPE,$S(IVMFUTR:"DELETE FUTR TEST",1:"DELETE PRMRY TEST"),+$G(NODE0),$$GETCODE^DGMTH($P(NODE0,"^",3)),CODE) - .; - .;check timestamp - if matches current primary test and hardship matches, then this is a duplicate and does not need to be uploaded - .I TMSTAMP D - ..S NODE="" - ..I IVMFUTR N IVMMTIEN S IVMMTIEN=$$FUTURE(DFN,($E(IVMMTDT,1,3)-1),1) - ..Q:'IVMMTIEN - ..S NODE=$G(^DGMT(408.31,IVMMTIEN,2)) - .S NODE0=$G(^DGMT(408.31,IVMMTIEN,0)) - .I TMSTAMP,TMSTAMP=$P(NODE,"^",2),IVMMTDT=$P(NODE0,"^"),SOURCE=$P(NODE,"^",5),(HSDATE=$P(NODE,"^")) Q - .; - .D DELTYPE^IVMCMD(DFN,IVMMTDT,2) - .D EN^IVMCM1 - ; - ; -CT ; If transmission is a Copay Test - N NODE0,RET,CODE,DATA - I IVMTYPE=2 D I $D(HLERR) G PROCQ - .S IVMMTDT=$$FMDATE^HLFNC($P($G(^TMP($J,"IVMCM","ZMT2")),HLFS,2)) - .S TMSTAMP=$$FMDATE^HLFNC($P($G(^TMP($J,"IVMCM","ZMT2")),HLFS,25)) - .S SOURCE=$P($G(^TMP($J,"IVMCM","ZMT2")),HLFS,22) - .S IVMLAST=$$LST^DGMTU(DFN,$E(IVMMTDT,1,3)_1231,2) - .S IVMCPAY=$$RXST^IBARXEU(DFN) - .I $$AGE^IVMUFNC5(DT)>$$INCY^IVMUFNC5(IVMMTDT) D PROB^IVMCMC("Only Copay Tests in the current/previous income years are valid. (Not effective)") Q - .; - perform edit checks and file CT - .D CHKDT - .;deletion indicator sent? - .I $P($G(^TMP($J,"IVMCM","ZMT2")),HLFS,3)=HLQ D Q - ..D - ...;if there is a future test for that income year, delete that - ...N IEN,DATA,IVMPAT - ...S IEN=$$FUTURE(DFN,($E(IVMMTDT,1,3)-1),2,.IVMPAT) - ...I IEN S DATA(.07)="" I $$UPD^DGENDBS(301.5,IVMPAT,.DATA) - ...I IEN,$D(^DGMT(408.31,IEN,0)) D - ....S IVMMTIEN=IEN - ....S IVMFUTR=1 - ...E D - ....S IVMFUTR=0 - ..Q:('IVMMTIEN) - ..S NODE0=$G(^DGMT(408.31,IVMMTIEN,0)) - ..I $$EN^IVMCMD(IVMMTIEN) D - ...S RET=$$LST^DGMTU(DFN,DT,IVMTYPE) - ...S CODE=$S(($E($P(RET,"^",2),1,3)=$E(DT,1,3)):$P(RET,"^",4),1:"") - ...D ADD^IVMCMB(DFN,IVMTYPE,$S(IVMFUTR:"DELETE FUTR TEST",1:"DELETE PRMRY TEST"),+$G(NODE0),$$GETCODE^DGMTH($P(NODE0,"^",3)),CODE) - .; - .;check timestamp - if matches current primary test, then this is a duplicate and does not need to be uploaded - .I TMSTAMP D - ..S NODE="" - ..I IVMFUTR N IVMMTIEN S IVMMTIEN=$$FUTURE(DFN,($E(IVMMTDT,1,3)-1),2) - ..Q:'IVMMTIEN - ..S NODE=$G(^DGMT(408.31,IVMMTIEN,2)) - .S NODE0=$G(^DGMT(408.31,IVMMTIEN,0)) - .I TMSTAMP,TMSTAMP=$P(NODE,"^",2),IVMMTDT=$P(NODE0,"^"),SOURCE=$P(NODE,"^",5) Q - .; - .D DELTYPE^IVMCMD(DFN,IVMMTDT,1) - .D EN^IVMCM1 - ; -IS ; - If transmission is income screening info only then do not process - ; - outside of the scope of MTS - ;I IVMTYPE=3 S IVMMTDT=0 D EN^IVMCM1 I $D(HLERR) G PROCQ - I IVMTYPE=3 S IVMMTDT=0 - ; -LTC ; If transmission contains a Long Term Care Test (TYPE 4 TEST) - I $P($G(^TMP($J,"IVMCM","ZMT4")),HLFS,2) D LTC^IVMCM1 - ; -PROCQ ; - ; release locks used to sychronize upload with local income test options - D RELLOCKS^IVMCUPL(DFN) - Q - ; -CHKDT ; check date of income test being uploaded - ; Is it a future date? If so, set IVMFUTR=1 - ; - ; IVMMTIEN is the IEN of current primary test for the year - ; - I $E($P(IVMLAST,"^",2),1,3)=$E(IVMMTDT,1,3) S IVMMTIEN=+IVMLAST - I IVMMTDT>DT S IVMFUTR=1 - Q -FUTURE(DFN,YEAR,TYPE,IVMPAT) ; - ;Returns the ien of the future test, if there is one - ;Inputs: DFN - ; YEAR - income year - ; TYPE - type of test - ;Output: - ; function value - ien of future means test, if there is one, "" otherwise - ; IVMPAT - Pointer to the IVM Patient file for the income year if there is an entry (pass by reference) - ; - N RET - S RET="" - S IVMPAT=$$FIND^IVMPLOG(DFN,YEAR) - I IVMPAT S RET=$P($G(^IVM(301.5,IVMPAT,0)),"^",$S(TYPE=1:6,1:7)) - Q RET +IVMCM ;ALB/SEK,KCL,RTK,AEG,BRM,AEG - PROCESS INCOME TEST (Z10) TRANSMISSIONS ; 04/23/03 1:43pm + ;;2.0;INCOME VERIFICATION MATCH;**12,17,28,41,44,53,34,49,59,55,63,77,74**;21-OCT-94 + ; + ; +ORF ; Handler for ORF type HL7 messages received from HEC + ; + ; Make sure POSTMASTER DUZ instead of DUZ of Person who + ; started Incoming Logical Link. + S DUZ=.5 + N CNT,IVMRTN,SEGCNT + S IVMRTN="IVMCMX" ;USE "IVMCMX" BECAUSE "IVMCM" ALREADY USED + K ^TMP($J,IVMRTN),DIC + S (DGMSGF,DGMTMSG)=1 ; HL7 rtn. Don't need DG interative messages. + S HLECH=HL("ECH"),HLQ=HL("Q"),HLMID=HL("MID") + K %,%H,%I D NOW^%DTC S HLDT=% + F SEGCNT=1:1 X HLNEXT Q:HLQUIT'>0 D + . S CNT=0 + . S ^TMP($J,IVMRTN,SEGCNT,CNT)=HLNODE + . F S CNT=$O(HLNODE(CNT)) Q:'CNT D + . . S ^TMP($J,IVMRTN,SEGCNT,CNT)=HLNODE(CNT) + S HLDA=HLMTIEN + ; + N SEG,EVENT,MSGID + S:'$D(HLEVN) HLEVN=0 + D NXTSEG^DGENUPL(HLDA,0,.SEG) + Q:(SEG("TYPE")'="MSH") ;would not have reached here if this happened! + S EVENT=$P(SEG(9),$E(HLECH),2) + ; + ; INITIALIZE HL7 VARIABLES + S HLEID="VAMC "_$P($$SITE^VASITE,"^",3)_" ORF-"_EVENT_" SERVER" + S HLEID=$O(^ORD(101,"B",HLEID,0)) + D INIT^HLFNC2(HLEID,.HL) + S HLEIDS=$O(^ORD(101,HLEID,775,"B",0)) + ; + ; Handle means test signature ORF (Z06) event + I EVENT="Z06" D ORF^IVMPREC7 + ; + ; Handle income test ORF (Z10) event + I EVENT="Z10" D Z10 + ; + ; Handle enrollment/elig. ORF (Z11) event + I EVENT="Z11" D + .S MSGID=SEG(10) + .D ORFZ11^DGENUPL(HLDA,MSGID) + ; + K ^TMP($J,IVMRTN) + Q + ; + ; +Z10 ; Entry point for receipt of ORF~Z10 transmission + ; The Income Test (Z10) transmission has the following format: + ; + ; BHS ORF msgs do not include batch header or trailer. + ; {MSH + ; PID They will include the sequence: MSA + ; ZIC QRD + ; ZIR QRF + ; {ZDP These segments will follow the MSH segment. + ; ZIC + ; ZIR + ; } + ; {ZMT + ; } + ; ZBT + ; } + ; BTS + ; + S IVMORF=1 ; set ORF msg flag + S (HLEVN,IVMCT,IVMERROR,IVMCNTR)=0 ; init vars + ; +ORU ; Entry point for receipt of ORU~Z10 trans (called by IVMPREC2) + S IVMTYPE=5,IVMZ10F=1 + ; + ; - loop through the msg in (#772 file), and process (PROC) msgs + S IVMDA=0 F S IVMDA=$O(^TMP($J,IVMRTN,IVMDA)) Q:'IVMDA S IVMSEG=$G(^(IVMDA,0)) I $E(IVMSEG,1,3)="MSH" D PROC Q:'IVMDA + ; + ; - if ORF msg flag, update the Query Tran Log and send ACK + I $G(IVMORF) D + .I $G(DFN),$D(IVMMCI) D + ..N IVMCR + ..S IVMCR=$P("1^2^3^7^5^6^4","^",IVMTYPE) ;map reason to test type + ..D FIND^IVMCQ2(DFN,IVMMCI,HLDT,$S($D(HLERR):5,1:IVMCR),1) + .;D ACK^IVMPREC:'$D(HLERR) + .;N HLRESLTA,HLP + .;D GENACK^HLMA1(HLEID,HLMTIEN,HLEIDS,"LM",1,.HLRESLTA,"",.HLP) + ; + ; - if tests are uploaded, generate notification msg + I $D(^TMP($J,"IVMBULL")) D ^IVMCMB + ; +ENQ ; + K IVMDA,IVMORF,IVMSEG,IVMFLGC,IVMTYPE,IVMMTIEN,IVMMTDT,IVMDGBT,IVMMCI + K ^TMP($J,"IVMCM"),^("IVMBULL"),DGMSGF,DGADDF,IVMCPAY,IVMBULL,DFN + K DGMTMSG,IVMZ10F + Q + ; +PROC ; Process each HL7 message from (#772) file + ; + N IVMFUTR,TMSTAMP,SOURCE,NODE,HSDATE,IVMZ10,DGMTP,DGMTACT,DGMTI,DGMTA + S DGMTACT="ADD" + D PRIOR^DGMTEVT + S IVMZ10="UPLOAD IN PROGRESS" + S IVMFUTR=0 ;this flag will indicate whether or not a test with a future date is being uploaded + S IVMMTIEN=0 + ; + S MSGID=$P(IVMSEG,HLFS,10) ; msg control id for ACK's + ; - check if DCD messaging is enabled + I '$$DCDON^IVMUPAR1() D PROB^IVMCMC("Facility has DCD messaging disabled") Q + ; + ; - check HL7 msg structure for errors + K HLERR,^TMP($J,"IVMCM") + D ^IVMCMC I $D(HLERR) K:HLERR="" HLERR Q + ; + ; Determine type of test/transmission + S IVMTYPE=0 + ; + ; - was a means test sent? + I $P($G(^TMP($J,"IVMCM","ZMT1")),HLFS,2) S IVMTYPE=1 ; MT trans + ; + ; - if MT and CT transmitted, error - pt can't have both unless + ; one is a deletion, but HEC not currently handling that situation + I IVMTYPE,$P($G(^TMP($J,"IVMCM","ZMT2")),HLFS,2) D PROB^IVMCMC("Patient can not have both a Means Test and Copay Test") Q + I $P($G(^TMP($J,"IVMCM","ZMT2")),HLFS,2) S IVMTYPE=2 ; CT trans + ; + ; - if no MT or CT or LTC then Income Screening + I 'IVMTYPE,'$P($G(^TMP($J,"IVMCM","ZMT4")),HLFS,2) S IVMTYPE=3 ; IS trans + ; + ;send an eligibility query if no eligibility code + I '$$ELIG^IVMCUF1(DFN),'$$PENDING^DGENQRY(DFN) I $$SEND^DGENQRY1(DFN) + ; + ; obtain locks used to sychronize upload with local income test options + D GETLOCKS^IVMCUPL(DFN) + ; + ; +MT ; If transmission is a Means Test + N NODE0,RET,CODE,DATA + S HLQ=$G(HL("Q")) + S:HLQ="" HLQ="""""" + I IVMTYPE=1 D I $D(HLERR) G PROCQ + .S IVMMTDT=$$FMDATE^HLFNC($P($G(^TMP($J,"IVMCM","ZMT1")),HLFS,2)) + .S TMSTAMP=$$FMDATE^HLFNC($P($G(^TMP($J,"IVMCM","ZMT1")),HLFS,25)) + .S HSDATE=$$FMDATE^HLFNC($P($G(^TMP($J,"IVMCM","ZMT1")),HLFS,24)) + .S SOURCE=$P($G(^TMP($J,"IVMCM","ZMT1")),HLFS,22) + .S IVMLAST=$$LST^DGMTU(DFN,$E(IVMMTDT,1,3)_1231,1) + .I $$Z06MT^EASPTRN1(+IVMLAST) Q + .I '$$ELIG^IVMUFNC5(DFN) S ERRMSG="Means Test upload not appropriate for current patient" + .I $$AGE^IVMUFNC5(DT)>$$INCY^IVMUFNC5(IVMMTDT) D + ..N CATCZMT S CATCZMT=$G(^TMP($J,"IVMCM","ZMT1")) + ..S CATC=$$CATC^IVMUFNC5(CATCZMT) + ..I '+$G(CATC) S ERRMSG="Only Means Tests in current/previous income years are valid (not effective)" + .I $G(ERRMSG)'="" D PROB^IVMCMC(ERRMSG) K ERRMSG,CATC Q + .; + .; - perform edit checks and file MT + .D CHKDT + .;deletion indicator sent? + .I $P($G(^TMP($J,"IVMCM","ZMT1")),HLFS,3)=HLQ D Q + ..D + ...;if there is a future test for that income year, delete that + ...N IEN,DATA,IVMPAT + ...S IEN=$$FUTURE(DFN,($E(IVMMTDT,1,3)-1),1,.IVMPAT) + ...I IEN S DATA(.06)="" I $$UPD^DGENDBS(301.5,IVMPAT,.DATA) + ...I IEN,$D(^DGMT(408.31,IEN,0)) D + ....S IVMMTIEN=IEN + ....S IVMFUTR=1 + ...E D + ....S IVMFUTR=0 + ..Q:('IVMMTIEN) + ..S NODE0=$G(^DGMT(408.31,IVMMTIEN,0)) + ..I $$EN^IVMCMD(IVMMTIEN) D + ...S RET=$$LST^DGMTU(DFN,DT,IVMTYPE) + ...S CODE=$S(($E($P(RET,"^",2),1,3)=$E(DT,1,3)):$P(RET,"^",4),1:"") + ...D ADD^IVMCMB(DFN,IVMTYPE,$S(IVMFUTR:"DELETE FUTR TEST",1:"DELETE PRMRY TEST"),+$G(NODE0),$$GETCODE^DGMTH($P(NODE0,"^",3)),CODE) + .; + .;check timestamp - if matches current primary test and hardship matches, then this is a duplicate and does not need to be uploaded + .I TMSTAMP D + ..S NODE="" + ..I IVMFUTR N IVMMTIEN S IVMMTIEN=$$FUTURE(DFN,($E(IVMMTDT,1,3)-1),1) + ..Q:'IVMMTIEN + ..S NODE=$G(^DGMT(408.31,IVMMTIEN,2)) + .S NODE0=$G(^DGMT(408.31,IVMMTIEN,0)) + .I TMSTAMP,TMSTAMP=$P(NODE,"^",2),IVMMTDT=$P(NODE0,"^"),SOURCE=$P(NODE,"^",5),(HSDATE=$P(NODE,"^")) Q + .; + .D DELTYPE^IVMCMD(DFN,IVMMTDT,2) + .D EN^IVMCM1 + ; + ; +CT ; If transmission is a Copay Test + N NODE0,RET,CODE,DATA + I IVMTYPE=2 D I $D(HLERR) G PROCQ + .S IVMMTDT=$$FMDATE^HLFNC($P($G(^TMP($J,"IVMCM","ZMT2")),HLFS,2)) + .S TMSTAMP=$$FMDATE^HLFNC($P($G(^TMP($J,"IVMCM","ZMT2")),HLFS,25)) + .S SOURCE=$P($G(^TMP($J,"IVMCM","ZMT2")),HLFS,22) + .S IVMLAST=$$LST^DGMTU(DFN,$E(IVMMTDT,1,3)_1231,2) + .S IVMCPAY=$$RXST^IBARXEU(DFN) + .I $$AGE^IVMUFNC5(DT)>$$INCY^IVMUFNC5(IVMMTDT) D PROB^IVMCMC("Only Copay Tests in the current/previous income years are valid. (Not effective)") Q + .; - perform edit checks and file CT + .D CHKDT + .;deletion indicator sent? + .I $P($G(^TMP($J,"IVMCM","ZMT2")),HLFS,3)=HLQ D Q + ..D + ...;if there is a future test for that income year, delete that + ...N IEN,DATA,IVMPAT + ...S IEN=$$FUTURE(DFN,($E(IVMMTDT,1,3)-1),2,.IVMPAT) + ...I IEN S DATA(.07)="" I $$UPD^DGENDBS(301.5,IVMPAT,.DATA) + ...I IEN,$D(^DGMT(408.31,IEN,0)) D + ....S IVMMTIEN=IEN + ....S IVMFUTR=1 + ...E D + ....S IVMFUTR=0 + ..Q:('IVMMTIEN) + ..S NODE0=$G(^DGMT(408.31,IVMMTIEN,0)) + ..I $$EN^IVMCMD(IVMMTIEN) D + ...S RET=$$LST^DGMTU(DFN,DT,IVMTYPE) + ...S CODE=$S(($E($P(RET,"^",2),1,3)=$E(DT,1,3)):$P(RET,"^",4),1:"") + ...D ADD^IVMCMB(DFN,IVMTYPE,$S(IVMFUTR:"DELETE FUTR TEST",1:"DELETE PRMRY TEST"),+$G(NODE0),$$GETCODE^DGMTH($P(NODE0,"^",3)),CODE) + .; + .;check timestamp - if matches current primary test, then this is a duplicate and does not need to be uploaded + .I TMSTAMP D + ..S NODE="" + ..I IVMFUTR N IVMMTIEN S IVMMTIEN=$$FUTURE(DFN,($E(IVMMTDT,1,3)-1),2) + ..Q:'IVMMTIEN + ..S NODE=$G(^DGMT(408.31,IVMMTIEN,2)) + .S NODE0=$G(^DGMT(408.31,IVMMTIEN,0)) + .I TMSTAMP,TMSTAMP=$P(NODE,"^",2),IVMMTDT=$P(NODE0,"^"),SOURCE=$P(NODE,"^",5) Q + .; + .D DELTYPE^IVMCMD(DFN,IVMMTDT,1) + .D EN^IVMCM1 + ; +IS ; - If transmission is income screening info only then do not process + ; - outside of the scope of MTS + ;I IVMTYPE=3 S IVMMTDT=0 D EN^IVMCM1 I $D(HLERR) G PROCQ + I IVMTYPE=3 S IVMMTDT=0 + ; +LTC ; If transmission contains a Long Term Care Test (TYPE 4 TEST) + I $P($G(^TMP($J,"IVMCM","ZMT4")),HLFS,2) D LTC^IVMCM1 + ; +PROCQ ; + ; release locks used to sychronize upload with local income test options + D RELLOCKS^IVMCUPL(DFN) + Q + ; +CHKDT ; check date of income test being uploaded + ; Is it a future date? If so, set IVMFUTR=1 + ; + ; IVMMTIEN is the IEN of current primary test for the year + ; + I $E($P(IVMLAST,"^",2),1,3)=$E(IVMMTDT,1,3) S IVMMTIEN=+IVMLAST + I IVMMTDT>DT S IVMFUTR=1 + Q +FUTURE(DFN,YEAR,TYPE,IVMPAT) ; + ;Returns the ien of the future test, if there is one + ;Inputs: DFN + ; YEAR - income year + ; TYPE - type of test + ;Output: + ; function value - ien of future means test, if there is one, "" otherwise + ; IVMPAT - Pointer to the IVM Patient file for the income year if there is an entry (pass by reference) + ; + N RET + S RET="" + S IVMPAT=$$FIND^IVMPLOG(DFN,YEAR) + I IVMPAT S RET=$P($G(^IVM(301.5,IVMPAT,0)),"^",$S(TYPE=1:6,1:7)) + Q RET diff --git a/r/INCOME_VERIFICATION_MATCH-IVM/IVMLDEM9.m b/r/INCOME_VERIFICATION_MATCH-IVM/IVMLDEM9.m index 6b15c72b..1b452e56 100644 --- a/r/INCOME_VERIFICATION_MATCH-IVM/IVMLDEM9.m +++ b/r/INCOME_VERIFICATION_MATCH-IVM/IVMLDEM9.m @@ -1,206 +1,205 @@ -IVMLDEM9 ;ALB/BRM/PHH - IVM ADDRESS UPDATES PENDING REVIEW RPT ; 04/09/08 13:35pm - ;;2.0;INCOME VERIFICATION MATCH;**79,93,119,126**; 21-OCT-94;Build 1 - ;;Per VHA Directive 10-93-142, this routine should not be modified. - ; - Q - ; -EN2 ;entry point for IVM ADDR UPDT PENDING REVIEW menu option - K ^TMP("IVMLDEM9",$J) - K ^TMP($J,"IVMLDEM9") - ;If mail group has no member or remote-member - I '$$MEMBER() D Q - . I '$D(ZTQUEUED) W !!,"IVM ADDR UPDT REPORT does not have a member. Report not sent." K DIR S DIR(0)="E" D ^DIR K DIR - I +$G(ZTSK) D PRINT,EXIT Q ;started by Taskman job - ;User runs the option - I '$D(ZTQUEUED) D - . W !!,"The report will be sent to mail group IVM ADDR UPDT REPORT" - . D QUE - . D EXIT - . K DIR S DIR(0)="E" D ^DIR K DIR - Q - ; -LOOP(DTPARAM,FILDAT) ;main loop - N DFN,IVMDT,IVMDA,IVMDA1,IVMDA2,RF171,TODAY,AUTODT,DTDIFF,NAME,UPLDT - N X1,X2,Y,SSN,DFN - D DT^DILF("X","T"_$G(DTPARAM),.AUTODT) - S TODAY=$$DT^XLFDT S:'$G(FILDAT) FILDAT=0 - Q:'$G(AUTODT) ;this should never occur, but just in case - S RF171=$O(^IVM(301.92,"C","RF171","")),IVMDA2="" - Q:'RF171 - F S IVMDA2=$O(^IVM(301.5,IVMDA2)) Q:IVMDA2="" D - .S DFN=$P($G(^IVM(301.5,IVMDA2,0)),"^"),IVMDA1="" - .Q:('DFN)!('$D(^DPT(+DFN)))!('$D(^IVM(301.5,IVMDA2,"IN"))) - .F S IVMDA1=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1)) Q:IVMDA1="" D - ..Q:'$D(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",RF171)) - ..S IVMDA="" - ..F S IVMDA=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",RF171,IVMDA)) Q:'IVMDA D - ...S IVMDT=$P($G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMDA,0)),"^",3) - ...Q:('IVMDT)!(IVMDT>AUTODT) - ...; report addresses that will be auto-uploaded in DTDIFF days - ...S X1=TODAY,X2=IVMDT D ^%DTC S DTDIFF=+$G(X) - ...S NAME=$P($G(^DPT(DFN,0)),"^"),SSN=$P($G(^DPT(DFN,0)),"^",9) - ...S X1=IVMDT,X2=14 D C^%DTC S UPLDT=$G(X) - ...I '$D(^IVM(301.5,"ASEG","PID",IVMDA2)) Q - ...S ^TMP("IVMLDEM9",$J,DTDIFF,SSN,IVMDA)=$G(NAME)_"^"_$P(IVMDT,".")_"^"_$P(UPLDT,".")_"^"_DFN_"^"_IVMDA2_"^"_IVMDA1 - Q - ; -AUTOLOAD(DFN,IVMDA2,IVMDA1) ;auto-upload records that not been reviewed - ; this tag is called from ^IVMLDEMC - ; - Q:('$G(DFN))!('$G(IVMDA2))!('$G(IVMDA1)) - N IVMI,IVMJ,IVMFIELD,IVMVALUE,IVMNODE,IVMFLAG,DUZ - S DUZ="IVM AUTO ADDR JOB" - ; - ; determine appropriate address change dt/tm to be used - D ADDRDT^IVMLDEM6(DFN,IVMDA2,IVMDA1) - ; - N DGPRIOR D GETPRIOR^DGADDUTL(DFN,.DGPRIOR) - ; - ; loop through the record to be uploaded - S IVMI=0 F S IVMI=$O(^IVM(301.92,"AD",IVMI)) Q:IVMI']"" D - .S IVMJ=0 F S IVMJ=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,IVMJ)) Q:IVMJ']"" D - ..; - ..; check for data node in (#301.511) sub-file - ..S IVMNODE=$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0)) - ..Q:('+IVMNODE)!($P(IVMNODE,"^",2)']"") - ..; - ..; check for residence phone number -> do not auto-upload - ..Q:(+IVMNODE=$O(^IVM(301.92,"B","PHONE NUMBER [RESIDENCE]",0))) - ..; - ..; do not auto-upload if there is an active prescription - ..I $$PHARM^IVMLDEM6(+DFN) D REJTADD Q - ..; - ..; set upload parameters - ..S IVMFIELD=$P($G(^IVM(301.92,+IVMNODE,0)),"^",5) - ..S IVMVALUE=$P(IVMNODE,"^",2) - ..; - ..; load addr field into the Patient (#2) file - ..D UPLOAD^IVMLDEM6(DFN,IVMFIELD,IVMVALUE) S IVMFLAG=1 - ..; - ..; remove entry from (#301.511) sub-file - ..D DELENT^IVMLDEMU(IVMDA2,IVMDA1,IVMJ) - ..; - ..; if no display or uploadable fields, delete PID segment - ..I ('$$DEMO^IVMLDEM5(IVMDA2,IVMDA1,0))&('$$DEMO^IVMLDEM5(IVMDA2,IVMDA1,1)) D DELETE^IVMLDEM5(IVMDA2,IVMDA1," ") - ; - I +$G(IVMFLAG) D - .N DGCURR - .D GETUPDTS^DGADDUTL(DFN,.DGCURR) - .D UPDADDLG^DGADDUTL(DFN,.DGPRIOR,.DGCURR) - Q -REJTADD ;Reject the address - ; update the ADDRESS CHANGE DT/TM field #.118 in PATIENT file #2 - D UPDDTTM^DGADDUTL(DFN,"PERM") - ; - ; trigger the record to transmit the existing address on file to HEC - N DGENUPLD ; Used in SETSTAT^IVMPLOG to prevent filing. - N DA,X,IVMX - S (DA,X)=DFN - S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX - Q -PRINT ;report output - N DAYS,SSN,DATA,EX,PAGE,IVMDA,DATA,IVMLN,XMY,XMSUB,XMDUZ,XMTEXT - D LOOP("",0) - D HDR - D DISPLAY - D EMAIL - Q -DISPLAY ;Display the report - S DAYS="" - I '$D(^TMP("IVMLDEM9",$J)) Q - F S DAYS=$O(^TMP("IVMLDEM9",$J,DAYS),-1) Q:DAYS=""!($G(EX)) D - .S SSN="" - .F S SSN=$O(^TMP("IVMLDEM9",$J,DAYS,SSN)) Q:SSN=""!($G(EX)) D - ..S IVMDA="" - ..F S IVMDA=$O(^TMP("IVMLDEM9",$J,DAYS,SSN,IVMDA)) Q:(IVMDA="")!($G(EX)) D - ...S DATA=$G(^TMP("IVMLDEM9",$J,DAYS,SSN,IVMDA)) - ... D LNPLUS - ... S ^TMP($J,"IVMLDEM9",IVMLN)=" "_$$FMTE^XLFDT($P(DATA,"^",3))_" "_$$FMTE^XLFDT($P(DATA,"^",2))_" "_SSN_" "_$P(DATA,"^") - ... S ^TMP($J,"IVMLDEM9","TOTAL")=$G(^TMP($J,"IVMLDEM9","TOTAL"))+1 - D TOTAL - D - . D LNPLUS - . S ^TMP($J,"IVMLDEM9",IVMLN)="" - . D LNPLUS - . S ^TMP($J,"IVMLDEM9",IVMLN)=" <>" - I $E(IOST)="C" W ! K DIR S DIR(0)="E" D ^DIR K DIR - Q -HDR ;print header - N IVMDT,Y,DLINE - I $D(ZTQUEUED),$$S^%ZTLOAD S (ZTSTOP,EX)=1 Q - S Y=DT X ^DD("DD") S IVMDT=Y - D - . D LNPLUS - . S ^TMP($J,"IVMLDEM9",IVMLN)="" - . D LNPLUS - . S ^TMP($J,"IVMLDEM9",IVMLN)=" IVM ADDRESS UPDATES PENDING REVIEW "_IVMDT - . D LNPLUS - . S $P(^TMP($J,"IVMLDEM9",IVMLN),"=",78)="" - . D LNPLUS - . S ^TMP($J,"IVMLDEM9",IVMLN)="" - . D LNPLUS - . S ^TMP($J,"IVMLDEM9",IVMLN)=" Auto-Upload Date Date Received SSN Patient Name" - . D LNPLUS - . S ^TMP($J,"IVMLDEM9",IVMLN)=" ---------------- ------------- --------- ------------" - Q -EXIT D ^%ZISC,HOME^%ZIS Q - K ^TMP($J,"IVMLDEM9") - K ^TMP("IVMLDEM9",$J) - ; -ADRDTCK(DFN,IVMDA2,IVMDA1) ;is the incoming address older than #2 address? - Q:'$G(DFN)!('$G(IVMDA2))!('$G(IVMDA1)) "0^MISSING INPUT PARAMETER" - N OADDRDT,NADDRDT,ERR,IVMDA,IEN92,IENS - S OADDRDT=$$GET1^DIQ(2,DFN_",",.118,"I","","ERR") Q:$D(ERR) "0^OLD ADDR ERROR" - S IEN92=$O(^IVM(301.92,"C","RF171","")) Q:'IEN92 "0^BAD #301.92 ENTRY FOR RF171" - I '$D(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IEN92)) Q "0^ADDR DT NOT PRESENT" - S IVMDA=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IEN92,"")) Q:'IVMDA "0^MISSING ADDR DT IN 301.5" - S IENS=IVMDA_","_IVMDA1_","_IVMDA2_"," - S NADDRDT=$$GET1^DIQ(301.511,IENS,.02,"I","","ERR") Q:$D(ERR) "0^NEW ADDR ERROR" - Q:(OADDRDT="")&(NADDRDT="") 0 - Q:(NADDRDT="")!(OADDRDT'0),('$$GOTLOCAL^XMXAPIG("IVM ADDR UPDT REPORT")) S RESULT=0 - Q RESULT -EMAIL ;Set up parameters to email the report - ;If called within a task, protect variables - I $D(ZTQUEUED) N %,DIFROM - N RDT - D NOW^%DTC S Y=% X ^DD("DD") - S RDT=$P(Y,"@",1)_"@"_$P($P(Y,"@",2),":",1,2) - S XMSUB="IVM Address Pending Review ("_RDT_")" - S XMY("G.IVM ADDR UPDT REPORT")="" - I $G(^TMP($J,"IVMLDEM9","TOTAL"))<1 D - . D LNPLUS - . S ^TMP($J,"IVMLDEM9",IVMLN)="" - . D LNPLUS - . S ^TMP($J,"IVMLDEM9",IVMLN)="*** NO RECORDS TO PRINT ***" - S XMTEXT="^TMP($J,""IVMLDEM9""," - D ^XMD - Q -QUE ;Que the task if user invokes option - N ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK,ZUSR,POP,X,ERR,IOP - W ! - S ZTIO="" - S ZTRTN="PRINT^IVMLDEM9" - S ZTDESC="IVM AUTO ADDRESS UPLOAD RPT" - D ^%ZTLOAD - D ^%ZISC,HOME^%ZIS - W !,$S($D(ZTSK):"REQUEST QUEUED AS TASK#"_ZTSK,1:"REQUEST CANCELLED!") - Q -TOTAL ;Display record total on the report - N IVMTOTAL - S IVMTOTAL=$G(^TMP($J,"IVMLDEM9","TOTAL")) - D - . D LNPLUS - . S ^TMP($J,"IVMLDEM9",IVMLN)="" - . D LNPLUS - . S ^TMP($J,"IVMLDEM9",IVMLN)="TOTAL RECORD(S): "_$G(IVMTOTAL) - Q -LNPLUS ;Increase line number for the email text - S IVMLN=$G(IVMLN)+1 - Q +IVMLDEM9 ;ALB/BRM/PHH - IVM ADDRESS UPDATES PENDING REVIEW RPT ; 10/18/06 12:47pm + ;;2.0;INCOME VERIFICATION MATCH;**79,93,119**; 21-OCT-94;Build 1 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; + Q + ; +EN2 ;entry point for IVM ADDR UPDT PENDING REVIEW menu option + K ^TMP("IVMLDEM9",$J) + K ^TMP($J,"IVMLDEM9") + ;If mail group has no member or remote-member + I '$$MEMBER() D Q + . I '$D(ZTQUEUED) W !!,"IVM ADDR UPDT REPORT does not have a member. Report not sent." K DIR S DIR(0)="E" D ^DIR K DIR + I +$G(ZTSK) D PRINT,EXIT Q ;started by Taskman job + ;User runs the option + I '$D(ZTQUEUED) D + . W !!,"The report will be sent to mail group IVM ADDR UPDT REPORT" + . D QUE + . D EXIT + . K DIR S DIR(0)="E" D ^DIR K DIR + Q + ; +LOOP(DTPARAM,FILDAT) ;main loop + N DFN,IVMDT,IVMDA,IVMDA1,IVMDA2,RF171,TODAY,AUTODT,DTDIFF,NAME,UPLDT + N X1,X2,Y,SSN,DFN + D DT^DILF("X","T"_$G(DTPARAM),.AUTODT) + S TODAY=$$DT^XLFDT S:'$G(FILDAT) FILDAT=0 + Q:'$G(AUTODT) ;this should never occur, but just in case + S RF171=$O(^IVM(301.92,"C","RF171","")),IVMDA2="" + Q:'RF171 + F S IVMDA2=$O(^IVM(301.5,IVMDA2)) Q:IVMDA2="" D + .S DFN=$P($G(^IVM(301.5,IVMDA2,0)),"^"),IVMDA1="" + .Q:('DFN)!('$D(^DPT(+DFN)))!('$D(^IVM(301.5,IVMDA2,"IN"))) + .F S IVMDA1=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1)) Q:IVMDA1="" D + ..Q:'$D(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",RF171)) + ..S IVMDA="" + ..F S IVMDA=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",RF171,IVMDA)) Q:'IVMDA D + ...S IVMDT=$P($G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMDA,0)),"^",3) + ...Q:('IVMDT)!(IVMDT>AUTODT) + ...; report addresses that will be auto-uploaded in DTDIFF days + ...S X1=TODAY,X2=IVMDT D ^%DTC S DTDIFF=+$G(X) + ...S NAME=$P($G(^DPT(DFN,0)),"^"),SSN=$P($G(^DPT(DFN,0)),"^",9) + ...S X1=IVMDT,X2=14 D C^%DTC S UPLDT=$G(X) + ...S ^TMP("IVMLDEM9",$J,DTDIFF,SSN,IVMDA)=$G(NAME)_"^"_$P(IVMDT,".")_"^"_$P(UPLDT,".")_"^"_DFN_"^"_IVMDA2_"^"_IVMDA1 + Q + ; +AUTOLOAD(DFN,IVMDA2,IVMDA1) ;auto-upload records that not been reviewed + ; this tag is called from ^IVMLDEMC + ; + Q:('$G(DFN))!('$G(IVMDA2))!('$G(IVMDA1)) + N IVMI,IVMJ,IVMFIELD,IVMVALUE,IVMNODE,IVMFLAG,DUZ + S DUZ="IVM AUTO ADDR JOB" + ; + ; determine appropriate address change dt/tm to be used + D ADDRDT^IVMLDEM6(DFN,IVMDA2,IVMDA1) + ; + N DGPRIOR D GETPRIOR^DGADDUTL(DFN,.DGPRIOR) + ; + ; loop through the record to be uploaded + S IVMI=0 F S IVMI=$O(^IVM(301.92,"AD",IVMI)) Q:IVMI']"" D + .S IVMJ=0 F S IVMJ=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IVMI,IVMJ)) Q:IVMJ']"" D + ..; + ..; check for data node in (#301.511) sub-file + ..S IVMNODE=$G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMJ,0)) + ..Q:('+IVMNODE)!($P(IVMNODE,"^",2)']"") + ..; + ..; check for residence phone number -> do not auto-upload + ..Q:(+IVMNODE=$O(^IVM(301.92,"B","PHONE NUMBER [RESIDENCE]",0))) + ..; + ..; do not auto-upload if there is an active prescription + ..I $$PHARM^IVMLDEM6(+DFN) D REJTADD Q + ..; + ..; set upload parameters + ..S IVMFIELD=$P($G(^IVM(301.92,+IVMNODE,0)),"^",5) + ..S IVMVALUE=$P(IVMNODE,"^",2) + ..; + ..; load addr field into the Patient (#2) file + ..D UPLOAD^IVMLDEM6(DFN,IVMFIELD,IVMVALUE) S IVMFLAG=1 + ..; + ..; remove entry from (#301.511) sub-file + ..D DELENT^IVMLDEMU(IVMDA2,IVMDA1,IVMJ) + ..; + ..; if no display or uploadable fields, delete PID segment + ..I ('$$DEMO^IVMLDEM5(IVMDA2,IVMDA1,0))&('$$DEMO^IVMLDEM5(IVMDA2,IVMDA1,1)) D DELETE^IVMLDEM5(IVMDA2,IVMDA1," ") + ; + I +$G(IVMFLAG) D + .N DGCURR + .D GETUPDTS^DGADDUTL(DFN,.DGCURR) + .D UPDADDLG^DGADDUTL(DFN,.DGPRIOR,.DGCURR) + Q +REJTADD ;Reject the address + ; update the ADDRESS CHANGE DT/TM field #.118 in PATIENT file #2 + D UPDDTTM^DGADDUTL(DFN,"PERM") + ; + ; trigger the record to transmit the existing address on file to HEC + N DGENUPLD ; Used in SETSTAT^IVMPLOG to prevent filing. + N DA,X,IVMX + S (DA,X)=DFN + S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX + Q +PRINT ;report output + N DAYS,SSN,DATA,EX,PAGE,IVMDA,DATA,IVMLN,XMY,XMSUB,XMDUZ,XMTEXT + D LOOP("",0) + D HDR + D DISPLAY + D EMAIL + Q +DISPLAY ;Display the report + S DAYS="" + I '$D(^TMP("IVMLDEM9",$J)) Q + F S DAYS=$O(^TMP("IVMLDEM9",$J,DAYS),-1) Q:DAYS=""!($G(EX)) D + .S SSN="" + .F S SSN=$O(^TMP("IVMLDEM9",$J,DAYS,SSN)) Q:SSN=""!($G(EX)) D + ..S IVMDA="" + ..F S IVMDA=$O(^TMP("IVMLDEM9",$J,DAYS,SSN,IVMDA)) Q:(IVMDA="")!($G(EX)) D + ...S DATA=$G(^TMP("IVMLDEM9",$J,DAYS,SSN,IVMDA)) + ... D LNPLUS + ... S ^TMP($J,"IVMLDEM9",IVMLN)=" "_$$FMTE^XLFDT($P(DATA,"^",3))_" "_$$FMTE^XLFDT($P(DATA,"^",2))_" "_SSN_" "_$P(DATA,"^") + ... S ^TMP($J,"IVMLDEM9","TOTAL")=$G(^TMP($J,"IVMLDEM9","TOTAL"))+1 + D TOTAL + D + . D LNPLUS + . S ^TMP($J,"IVMLDEM9",IVMLN)="" + . D LNPLUS + . S ^TMP($J,"IVMLDEM9",IVMLN)=" <>" + I $E(IOST)="C" W ! K DIR S DIR(0)="E" D ^DIR K DIR + Q +HDR ;print header + N IVMDT,Y,DLINE + I $D(ZTQUEUED),$$S^%ZTLOAD S (ZTSTOP,EX)=1 Q + S Y=DT X ^DD("DD") S IVMDT=Y + D + . D LNPLUS + . S ^TMP($J,"IVMLDEM9",IVMLN)="" + . D LNPLUS + . S ^TMP($J,"IVMLDEM9",IVMLN)=" IVM ADDRESS UPDATES PENDING REVIEW "_IVMDT + . D LNPLUS + . S $P(^TMP($J,"IVMLDEM9",IVMLN),"=",78)="" + . D LNPLUS + . S ^TMP($J,"IVMLDEM9",IVMLN)="" + . D LNPLUS + . S ^TMP($J,"IVMLDEM9",IVMLN)=" Auto-Upload Date Date Received SSN Patient Name" + . D LNPLUS + . S ^TMP($J,"IVMLDEM9",IVMLN)=" ---------------- ------------- --------- ------------" + Q +EXIT D ^%ZISC,HOME^%ZIS Q + K ^TMP($J,"IVMLDEM9") + K ^TMP("IVMLDEM9",$J) + ; +ADRDTCK(DFN,IVMDA2,IVMDA1) ;is the incoming address older than #2 address? + Q:'$G(DFN)!('$G(IVMDA2))!('$G(IVMDA1)) "0^MISSING INPUT PARAMETER" + N OADDRDT,NADDRDT,ERR,IVMDA,IEN92,IENS + S OADDRDT=$$GET1^DIQ(2,DFN_",",.118,"I","","ERR") Q:$D(ERR) "0^OLD ADDR ERROR" + S IEN92=$O(^IVM(301.92,"C","RF171","")) Q:'IEN92 "0^BAD #301.92 ENTRY FOR RF171" + I '$D(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IEN92)) Q "0^ADDR DT NOT PRESENT" + S IVMDA=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",IEN92,"")) Q:'IVMDA "0^MISSING ADDR DT IN 301.5" + S IENS=IVMDA_","_IVMDA1_","_IVMDA2_"," + S NADDRDT=$$GET1^DIQ(301.511,IENS,.02,"I","","ERR") Q:$D(ERR) "0^NEW ADDR ERROR" + Q:(OADDRDT="")&(NADDRDT="") 0 + Q:(NADDRDT="")!(OADDRDT'0),('$$GOTLOCAL^XMXAPIG("IVM ADDR UPDT REPORT")) S RESULT=0 + Q RESULT +EMAIL ;Set up parameters to email the report + ;If called within a task, protect variables + I $D(ZTQUEUED) N %,DIFROM + N RDT + D NOW^%DTC S Y=% X ^DD("DD") + S RDT=$P(Y,"@",1)_"@"_$P($P(Y,"@",2),":",1,2) + S XMSUB="IVM Address Pending Review ("_RDT_")" + S XMY("G.IVM ADDR UPDT REPORT")="" + I $G(^TMP($J,"IVMLDEM9","TOTAL"))<1 D + . D LNPLUS + . S ^TMP($J,"IVMLDEM9",IVMLN)="" + . D LNPLUS + . S ^TMP($J,"IVMLDEM9",IVMLN)="*** NO RECORDS TO PRINT ***" + S XMTEXT="^TMP($J,""IVMLDEM9""," + D ^XMD + Q +QUE ;Que the task if user invokes option + N ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK,ZUSR,POP,X,ERR,IOP + W ! + S ZTIO="" + S ZTRTN="PRINT^IVMLDEM9" + S ZTDESC="IVM AUTO ADDRESS UPLOAD RPT" + D ^%ZTLOAD + D ^%ZISC,HOME^%ZIS + W !,$S($D(ZTSK):"REQUEST QUEUED AS TASK#"_ZTSK,1:"REQUEST CANCELLED!") + Q +TOTAL ;Display record total on the report + N IVMTOTAL + S IVMTOTAL=$G(^TMP($J,"IVMLDEM9","TOTAL")) + D + . D LNPLUS + . S ^TMP($J,"IVMLDEM9",IVMLN)="" + . D LNPLUS + . S ^TMP($J,"IVMLDEM9",IVMLN)="TOTAL RECORD(S): "_$G(IVMTOTAL) + Q +LNPLUS ;Increase line number for the email text + S IVMLN=$G(IVMLN)+1 + Q diff --git a/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ072.m b/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ072.m index a2fe85a5..9624f870 100644 --- a/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ072.m +++ b/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ072.m @@ -1,69 +1,68 @@ -IVMZ072 ;BAJ/PHH - HL7 Z07 CONSISTENCY CHECKER -- DRIVER ROUTINE II ; 05/22/08 - ;;2.0;INCOME VERIFICATION MATCH;**105,130**;JUL 8,1996;Build 2 - ; - ; - ; This routine supports the IVMZ07C consistency checker routines. -LOADSD(DFN,DGSD) ; Load spouse & dependent data into array - ; We will need to look at the Patient Relationship file to determine the spouse(s) and dependents for the patient - ; from the Patient Relation file ^DGPR(408.12) This file will point to an IEN in the Income Person file. - ; Next, we will load all of the spouse(s) and dependents from the Income Person file into the array. - N NIEN,IEN,RIEN,NODE,I,ENODE - ; look into Patient Relation file #408.12. Here we will find a pointer to each relation. And the record itself will - ; contain a pointer into the INCOME PERSON file (#408.13) - ; - ;Global ^DGPR(408.12,,DFN - ;^DGPR(408.12,"B",9999955601,3206)= - ; 3210)= <<------| - ; 3211)= | - ; 3212)= | - ; ] - ;Global ^DGPR(408.12,3210 <<------------ - ;^DGPR(408.12,3210,0)=9999955601^2^7170758;DGPR(408.13, - ;^DGPR(408.12,3210,"E",0)=^408.1275D^1^1 | - ;^DGPR(408.12,3210,"E",1,0)=2560406^1 | - ;^DGPR(408.12,3210,"E","AID",-2560406,1)= | - ;^DGPR(408.12,3210,"E","B",2560406,1)= | - ; | - ; | - ;Global ^DGPR(408.13,7170758 <<-------------- - ;^DGPR(408.13,7170758,0)=XXXXXX,XXXX SPOUSE^F^2560406^^^^^^174040656P^N - ; 1)=XXXXX,XXXX^^^^^^^ - ; - I '$D(^DGPR(408.12,"B",DFN)) Q - S NIEN="" F S NIEN=$O(^DGPR(408.12,"B",DFN,NIEN)) Q:NIEN="" D - . Q:'$D(^DGPR(408.12,NIEN,0)) - . S IEN=$P(^DGPR(408.12,NIEN,0),U,3) - . ; an entry in DPT is the patient. we only need relations - . Q:$P(IEN,";",2)["DPT"!'IEN - . Q:'$$ACTIF(NIEN,.ENODE) ;include only Active dependents - . S RIEN=$P(IEN,";",1),NODE=$P(IEN,";",2) - . S NODE=U_NODE,NODE=NODE_RIEN_")" - . Q:'$D(@NODE) - . S DGSD("DEP",RIEN,"EFF")=ENODE - . S DGSD("DEP",RIEN)=$P(^DGPR(408.12,NIEN,0),U,2) - . M DGSD("DEP",RIEN)=@NODE - Q - ; -ACTIF(NIEN,ENODE) ;determine if record in ^DGPR(408.12) is currently active. If active, populate variable ENODE with Effective Date. - ; This API should be called something like this I $$ACTIF^IVMZ072(NIEN,.ENODE)... - ; Input: - ; NIEN = IEN of ^DGPR(408.12) reference - ; ENODE = Variable to contain Effective Date - ; - ; Populates: - ; ENODE = With the most recent effective date of changes - ; - ; Returns: - ; ACTIVE flag - ; 1 = Active - ; 0 = Inactive - ; - N ROOT,ACTDAT,INDEX,ACTIVE,EFF - S ACTIVE=0 - D Q ACTIVE - . S ROOT=$O(^DGPR(408.12,NIEN,"E","AID","")) Q:ROOT="" - . S INDEX=$O(^DGPR(408.12,NIEN,"E","AID",ROOT,"")) Q:INDEX="" - . S ACTDAT=^DGPR(408.12,NIEN,"E",INDEX,0) - . S ACTIVE=$P(ACTDAT,"^",2),ENODE=$P(ACTDAT,"^",1) - Q ACTIVE - ; +IVMZ072 ;BAJ - HL7 Z07 CONSISTENCY CHECKER -- DRIVER ROUTINE II ; 09/27/06 + ;;2.0;INCOME VERIFICATION MATCH;**105**;JUL 8,1996;Build 2 + ; + ; + ; This routine supports the IVMZ07C consistency checker routines. +LOADSD(DFN,DGSD) ; Load spouse & dependent data into array + ; We will need to look at the Patient Relationship file to determine the spouse(s) and dependents for the patient + ; from the Patient Relation file ^DGPR(408.12) This file will point to an IEN in the Income Person file. + ; Next, we will load all of the spouse(s) and dependents from the Income Person file into the array. + N NIEN,IEN,RIEN,NODE,I,ENODE + ; look into Patient Relation file #408.12. Here we will find a pointer to each relation. And the record itself will + ; contain a pointer into the INCOME PERSON file (#408.13) + ; + ;Global ^DGPR(408.12,,DFN + ;^DGPR(408.12,"B",9999955601,3206)= + ; 3210)= <<------| + ; 3211)= | + ; 3212)= | + ; ] + ;Global ^DGPR(408.12,3210 <<------------ + ;^DGPR(408.12,3210,0)=9999955601^2^7170758;DGPR(408.13, + ;^DGPR(408.12,3210,"E",0)=^408.1275D^1^1 | + ;^DGPR(408.12,3210,"E",1,0)=2560406^1 | + ;^DGPR(408.12,3210,"E","AID",-2560406,1)= | + ;^DGPR(408.12,3210,"E","B",2560406,1)= | + ; | + ; | + ;Global ^DGPR(408.13,7170758 <<-------------- + ;^DGPR(408.13,7170758,0)=XXXXXX,XXXX SPOUSE^F^2560406^^^^^^174040656P^N + ; 1)=XXXXX,XXXX^^^^^^^ + ; + I '$D(^DGPR(408.12,"B",DFN)) Q + S NIEN="" F S NIEN=$O(^DGPR(408.12,"B",DFN,NIEN)) Q:NIEN="" D + . S IEN=$P(^DGPR(408.12,NIEN,0),U,3) + . ; an entry in DPT is the patient. we only need relations + . Q:$P(IEN,";",2)["DPT" + . Q:'$$ACTIF(NIEN,.ENODE) ;include only Active dependents + . S RIEN=$P(IEN,";",1),NODE=$P(IEN,";",2) + . S NODE=U_NODE,NODE=NODE_RIEN_")" + . Q:'$D(@NODE) + . S DGSD("DEP",RIEN,"EFF")=ENODE + . S DGSD("DEP",RIEN)=$P(^DGPR(408.12,NIEN,0),U,2) + . M DGSD("DEP",RIEN)=@NODE + Q + ; +ACTIF(NIEN,ENODE) ;determine if record in ^DGPR(408.12) is currently active. If active, populate variable ENODE with Effective Date. + ; This API should be called something like this I $$ACTIF^IVMZ072(NIEN,.ENODE)... + ; Input: + ; NIEN = IEN of ^DGPR(408.12) reference + ; ENODE = Variable to contain Effective Date + ; + ; Populates: + ; ENODE = With the most recent effective date of changes + ; + ; Returns: + ; ACTIVE flag + ; 1 = Active + ; 0 = Inactive + ; + N ROOT,ACTDAT,INDEX,ACTIVE,EFF + S ACTIVE=0 + D Q ACTIVE + . S ROOT=$O(^DGPR(408.12,NIEN,"E","AID","")) Q:ROOT="" + . S INDEX=$O(^DGPR(408.12,NIEN,"E","AID",ROOT,"")) Q:INDEX="" + . S ACTDAT=^DGPR(408.12,NIEN,"E",INDEX,0) + . S ACTIVE=$P(ACTDAT,"^",2),ENODE=$P(ACTDAT,"^",1) + Q ACTIVE + ; diff --git a/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ07C.m b/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ07C.m index dc8f5d3c..e80536f6 100644 --- a/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ07C.m +++ b/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ07C.m @@ -1,181 +1,182 @@ -IVMZ07C ;BAJ/PHH - HL7 Z07 CONSISTENCY CHECKER -- DRIVER ROUTINE ; 1/17/2008 - ;;2.0;INCOME VERIFICATION MATCH;**105,128**;JUL 8,1996;Build 2 - ; - ; - ; This routine calls various checking subroutines and manages arrays and data filing - ; for inconsistency checking prior to building a Z07 HL7 record. This routine returns - ; a value and must be called as an API: - ; - ; I '$$EN^IVMZ07C(DFN) Q - ; - ; Values returned: - ; 0 = Fail: inconsistencies found, do not build Z07 record - ; 1 = Pass: No inconsistencies found, Ok to build Z07 record - ; - ; Must be called from entry point - Q - ; -EN(DFN) ; entry point. Patient DFN is sent from calling routine. - ; initialize working variables - N PASS,DGP,DGSD,U - S U="^" - ; - ; Input: DFN = ^DPT(DFN) of record to check - ; BATCH = 1 batch/background job records should be counted - ; = 0 single job, do not count records - ; structure: - ; 1. delete existing Z07 inconsistencies - ; 2. load data arrays - ; 3. call subroutines - ; 4. check for Pass/Fail - ; 5. update file 38.5 if necessary - ; 6. return Pass/Fail - ; - ; Set flag - S PASS=0 - I '$D(^DPT(DFN)) Q PASS - S PASS=1 - ; - ; Load Patient and Spouse/dependent data - D LOADPT(DFN,.DGP),LOADSD^IVMZ072(DFN,.DGSD) - ; - ; Do checks and file inconsistencies - D WORK(DFN,.DGP,.DGSD) - ; - ; Delete old Inconsistency info - D DELETE(DFN) - ; - ; File new inconsistencies if necessary - I $$FILE(DFN) S PASS=0 - ; - ; update counters - D COUNT(PASS) - ; - ; return pass/fail flag - Q PASS - ; -COUNT(PASS) ; counter for batch run - N I - ; Set it up the first time through - I '$D(^TMP($J,"CC")) D - . F I=0,1 S ^TMP($J,"CC",I)=0 - ; - ; Increment Batch counter - S ^TMP($J,"CC",PASS)=^TMP($J,"CC",PASS)+1 - Q - ; -LOADPT(DFN,DGP) ; load patient data into arrays - N NIEN,IEN,I,DTTM,NAMCOM,NAME - ; we need to load data from the following files - ; Patient File 2 - ; Name Components 20 - ; Patient Enrollment 27.11 - ; Means test file 408.31 - ; MST History file 29.11 - ; Note: we also need Catastrophic data info, but that subroutine loads its own data array. - ; - ; *************************** - ; DGP("PAT") Patient file - F I=0,.3,.15,.29,.31,.32,.321,.322,.35,.36,.361,.38,.52,"SSN","TYPE","VET" S DGP("PAT",I)=$G(^DPT(DFN,I)) - S NAME=$P($G(^DPT(DFN,0)),"^",1),NAMCOM=$P($G(^DPT(DFN,"NAME")),"^",1)'="" - ; - ; *************************** - ; DGP("NAME") Name Components - I NAMCOM S NIEN=$P(^DPT(DFN,"NAME"),U,1) I '$D(^VA(20,NIEN,1)) S NAMCOM=0 - S DGP("NAME",1)=$S(NAMCOM:$G(^VA(20,NIEN,1)),1:$P(NAME,",")_"^"_$P($P(NAME,",",2)," ",1)_"^"_$P($P(NAME,",",2)," ",2)) - ; - ; *************************** - ; - ; DGP("ENR") Patient Enrollment - S NIEN="",NIEN=$P($G(^DPT(DFN,"ENR")),U,1) - I NIEN]"",$D(^DGEN(27.11,NIEN)) M DGP("ENR")=^DGEN(27.11,NIEN) - ; - ; *************************** - ; DGP("MEANS") Means Test - S NIEN=+$$LST^DGMTU(DFN) I NIEN,$D(^DGMT(408.31,NIEN,0)) S DGP("MEANS",0)=^DGMT(408.31,NIEN,0) - ; - ; *************************** - ; DGP("MST") MST History - S (DTTM,NIEN)="" - S DTTM=$O(^DGMS(29.11,"APDT",DFN,""),-1) - I DTTM'="" D - . S NIEN=$O(^DGMS(29.11,"APDT",DFN,DTTM,""),-1) - . I $D(^DGMS(29.11,NIEN,0)) S DGP("MST",0)=^DGMS(29.11,NIEN,0) - ; - ; *************************** - Q - ; -WORK(DFN,DGP,DGSD) ; - ; call subroutines to run rules and file any inconsistencies - ; - ; Demographics rules - D EN^IVMZ7CD(DFN,.DGP,.DGSD) - ; - ; Enrollment/Eligibility rules - D EN^IVMZ7CE(DFN,.DGP) - ; - ; Service rules - D EN^IVMZ7CS(DFN,.DGP) - ; - ; Catastrophic Disability rules - D EN^IVMZ7CCD(DFN) - ; - ; Registration Inconsistencies - D EN^IVMZ7CR(DFN,.DGP,.DGSD) - ; - Q - ; -DELETE(DFN) ; delete all Z07 inconsistencies from INCONSISTENT DATA file (#38.5). Since we're not sure which rules - ; will block a Z07 record, we need to loop through the INCONSISTENT DATA ELEMENTS file (#38.6) and grab only - ; those rules which are marked to prevent building a Z07 record: - ; - ; - N DELARRY,RULE,DIK,DA - ; - ; create an array of rules which prevent Z07 records - S RULE=0 F S RULE=$O(^DGIN(38.6,RULE)) Q:RULE="" Q:$A(RULE)>$A(9) D - . I '$P(^DGIN(38.6,RULE,0),U,5),$P(^DGIN(38.6,RULE,0),U,6) S DELARRY(RULE)="" - ; - ; Now we have to check the patient INCONSISTENT DATA file (#38.5) and delete any records which have to be rechecked. - ; - S DIK="^DGIN(38.5,"_DFN_","_"""I"""_"," - ; - S DA="" F S DA=$O(DELARRY(DA)) Q:DA="" D ^DIK - Q - ; -FILE(DFN) ; - N FILE,SUCCESS,CCS,I,DGENDA,DATA,SUBFILE,DIK,DA - S FILE=38.5,CCS=0 - ; if no inconsistencies, return 0 - I '$D(^TMP($J,DFN)) D Q CCS - . ; clean up INCONSISTENT DATA file if no inconsistencies exist - . I '$P($G(^DGIN(38.5,DFN,"I",0)),"^",4) D - . . S DIK="^DGIN(38.5,",DA=DFN - . . D ^DIK - ; - ; else process inconsistencies and return PASS=0 - S CCS=1 - ; if a new entry, create a stub - S DATA(.01)=DFN - I '$D(^DGIN(FILE,"B",DFN)) D - . S DATA(2)=$$DT^XLFDT,DATA(3)=.5 - . S SUCCESS=$$ADD^DGENDBS(FILE,,.DATA,,DFN) - ; - ; update file header with data and user info. - ; Last Updated field (#4) = Today's date - ; Last Updated by field (#5) = Postmaster - S DGENDA=DFN,DATA(4)=$$DT^XLFDT,DATA(5)=.5 - S SUCCESS=$$UPD^DGENDBS(FILE,.DGENDA,.DATA) - ; - ; add inconsistencies to file - K DATA - S SUBFILE=38.51,DGENDA(1)=DFN - S I="" F S I=$O(^TMP($J,DFN,I)) Q:I="" D - . S (DATA(.01),DATA(.001),DGENDA)=I - . S SUCCESS=$$ADD^DGENDBS(SUBFILE,.DGENDA,.DATA) - ; - ; kill temp file before exit - K ^TMP($J,DFN) - ; - Q CCS - ; +IVMZ07C ;BAJ - HL7 Z07 CONSISTENCY CHECKER -- DRIVER ROUTINE ; 9/27/2006 + ;;2.0;INCOME VERIFICATION MATCH;**105**;JUL 8,1996;Build 2 + ; + ; + ; This routine calls various checking subroutines and manages arrays and data filing + ; for inconsistency checking prior to building a Z07 HL7 record. This routine returns + ; a value and must be called as an API: + ; + ; I '$$EN^IVMZ07C(DFN) Q + ; + ; Values returned: + ; 0 = Fail: inconsistencies found, do not build Z07 record + ; 1 = Pass: No inconsistencies found, Ok to build Z07 record + ; + ; Must be called from entry point + Q + ; +EN(DFN) ; entry point. Patient DFN is sent from calling routine. + ; initialize working variables + N PASS,DGP,DGSD,U + S U="^" + ; + ; Input: DFN = ^DPT(DFN) of record to check + ; BATCH = 1 batch/background job records should be counted + ; = 0 single job, do not count records + ; structure: + ; 1. delete existing Z07 inconsistencies + ; 2. load data arrays + ; 3. call subroutines + ; 4. check for Pass/Fail + ; 5. update file 38.5 if necessary + ; 6. return Pass/Fail + ; + ; Set flag + S PASS=0 + I '$D(^DPT(DFN)) Q PASS + S PASS=1 + ; + ; Load Patient and Spouse/dependent data + D LOADPT(DFN,.DGP),LOADSD^IVMZ072(DFN,.DGSD) + ; + ; Do checks and file inconsistencies + D WORK(DFN,.DGP,.DGSD) + ; + ; Delete old Inconsistency info + D DELETE(DFN) + ; + ; File new inconsistencies if necessary + I $$FILE(DFN) S PASS=0 + ; + ; update counters + D COUNT(PASS) + ; + ; return pass/fail flag + Q PASS + ; +COUNT(PASS) ; counter for batch run + N I + ; Set it up the first time through + I '$D(^TMP($J,"CC")) D + . F I=0,1 S ^TMP($J,"CC",I)=0 + ; + ; Increment Batch counter + S ^TMP($J,"CC",PASS)=^TMP($J,"CC",PASS)+1 + Q + ; +LOADPT(DFN,DGP) ; load patient data into arrays + N NIEN,IEN,I,DTTM,NAMCOM,NAME + ; we need to load data from the following files + ; Patient File 2 + ; Name Components 20 + ; Patient Enrollment 27.11 + ; Means test file 408.31 + ; MST History file 29.11 + ; Note: we also need Catastrophic data info, but that subroutine loads its own data array. + ; + ; *************************** + ; DGP("PAT") Patient file + F I=0,.3,.15,.29,.31,.32,.321,.322,.35,.36,.361,.38,.52,"SSN","TYPE","VET" S DGP("PAT",I)=$G(^DPT(DFN,I)) + S NAME=$P($G(^DPT(DFN,0)),"^",1),NAMCOM=$P($G(^DPT(DFN,"NAME")),"^",1)'="" + ; + ; *************************** + ; DGP("NAME") Name Components + I NAMCOM S NIEN=$P(^DPT(DFN,"NAME"),U,1) I '$D(^VA(20,NIEN,1)) S NAMCOM=0 + S DGP("NAME",1)=$S(NAMCOM:$G(^VA(20,NIEN,1)),1:$P(NAME,",")_"^"_$P($P(NAME,",",2)," ",1)_"^"_$P($P(NAME,",",2)," ",2)) + ; + ; *************************** + ; + ; DGP("ENR") Patient Enrollment + S NIEN="",NIEN=$P($G(^DPT(DFN,"ENR")),U,1) + I NIEN]"",$D(^DGEN(27.11,NIEN)) M DGP("ENR")=^DGEN(27.11,NIEN) + ; + ; *************************** + ; DGP("MEANS") Means Test + S NIEN=+$$LST^DGMTU(DFN) I NIEN,$D(^DGMT(408.31,NIEN,0)) S DGP("MEANS",0)=^DGMT(408.31,NIEN,0) + ; + ; *************************** + ; DGP("MST") MST History + S (DTTM,NIEN)="" + S DTTM=$O(^DGMS(29.11,"APDT",DFN,""),-1) + I DTTM'="" D + . S DTTM=$O(^DGMS(29.11,"APDT",DFN,"")) + . S NIEN=$O(^DGMS(29.11,"APDT",DFN,DTTM,"")) + . I $D(^DGMS(29.11,NIEN,0)) S DGP("MST",0)=^DGMS(29.11,NIEN,0) + ; + ; *************************** + Q + ; +WORK(DFN,DGP,DGSD) ; + ; call subroutines to run rules and file any inconsistencies + ; + ; Demographics rules + D EN^IVMZ7CD(DFN,.DGP,.DGSD) + ; + ; Enrollment/Eligibility rules + D EN^IVMZ7CE(DFN,.DGP) + ; + ; Service rules + D EN^IVMZ7CS(DFN,.DGP) + ; + ; Catastrophic Disability rules + D EN^IVMZ7CCD(DFN) + ; + ; Registration Inconsistencies + D EN^IVMZ7CR(DFN,.DGP,.DGSD) + ; + Q + ; +DELETE(DFN) ; delete all Z07 inconsistencies from INCONSISTENT DATA file (#38.5). Since we're not sure which rules + ; will block a Z07 record, we need to loop through the INCONSISTENT DATA ELEMENTS file (#38.6) and grab only + ; those rules which are marked to prevent building a Z07 record: + ; + ; + N DELARRY,RULE,DIK,DA + ; + ; create an array of rules which prevent Z07 records + S RULE=0 F S RULE=$O(^DGIN(38.6,RULE)) Q:RULE="" Q:$A(RULE)>$A(9) D + . I '$P(^DGIN(38.6,RULE,0),U,5),$P(^DGIN(38.6,RULE,0),U,6) S DELARRY(RULE)="" + ; + ; Now we have to check the patient INCONSISTENT DATA file (#38.5) and delete any records which have to be rechecked. + ; + S DIK="^DGIN(38.5,"_DFN_","_"""I"""_"," + ; + S DA="" F S DA=$O(DELARRY(DA)) Q:DA="" D ^DIK + Q + ; +FILE(DFN) ; + N FILE,SUCCESS,CCS,I,DGENDA,DATA,SUBFILE,DIK,DA + S FILE=38.5,CCS=0 + ; if no inconsistencies, return 0 + I '$D(^TMP($J,DFN)) D Q CCS + . ; clean up INCONSISTENT DATA file if no inconsistencies exist + . I '$P($G(^DGIN(38.5,DFN,"I",0)),"^",4) D + . . S DIK="^DGIN(38.5,",DA=DFN + . . D ^DIK + ; + ; else process inconsistencies and return PASS=0 + S CCS=1 + ; if a new entry, create a stub + S DATA(.01)=DFN + I '$D(^DGIN(FILE,"B",DFN)) D + . S DATA(2)=$$DT^XLFDT,DATA(3)=.5 + . S SUCCESS=$$ADD^DGENDBS(FILE,,.DATA,,DFN) + ; + ; update file header with data and user info. + ; Last Updated field (#4) = Today's date + ; Last Updated by field (#5) = Postmaster + S DGENDA=DFN,DATA(4)=$$DT^XLFDT,DATA(5)=.5 + S SUCCESS=$$UPD^DGENDBS(FILE,.DGENDA,.DATA) + ; + ; add inconsistencies to file + K DATA + S SUBFILE=38.51,DGENDA(1)=DFN + S I="" F S I=$O(^TMP($J,DFN,I)) Q:I="" D + . S (DATA(.01),DATA(.001),DGENDA)=I + . S SUCCESS=$$ADD^DGENDBS(SUBFILE,.DGENDA,.DATA) + ; + ; kill temp file before exit + K ^TMP($J,DFN) + ; + Q CCS + ; diff --git a/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CD.m b/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CD.m index a559b87a..b2ee7d59 100644 --- a/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CD.m +++ b/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CD.m @@ -1,128 +1,128 @@ -IVMZ7CD ;CKN,BAJ,ERC - HL7 Z07 CONSISTENCY CHECKER -- DEMOGRAPHIC SUBROUTINE ; 9/27/2006 - ;;2.0;INCOME VERIFICATION MATCH;**105,127**;JUL 8,1996;Build 6 - ; - ; Demographic Consistency Checks - ; This routine will be called from driver routine and it checks the - ; various elements of Person demographic information prior to - ; building a Z07 record. Any test which fails consistency check will - ; be saved in file 38.6 INCONSISTENT DATA ELEMENT record for Person. - ; - ;It is all facade - Q - ; -EN(DFN,DGP,DGSD) ;Entry point - ; input: DFN - Patient IEN - ; DGP - Patient data array - ; DGSD - Spouse and Dependent data array - ; output: ^TMP($J,DFN,RULE) global - ; DFN - Patient IEN - ; RULE - Consistency rule # - ;initializing variables - N RULE,Y,X,FILERR - ; - ; loop through rules in INCONSISTENT DATA ELEMENTS file. - ; execute only the rules where CHECK/DON'T CHECK and INCLUDE IN Z07 - ; CHECKS fields are turned ON. - ; - ; ***NOTE loop boundary (301-311) must be changed if rule numbers - ; are added *** - F RULE=301:1:312 I $D(^DGIN(38.6,RULE)) D - . S Y=^DGIN(38.6,RULE,0) - . I '$P(Y,"^",5),$P(Y,"^",6) D @RULE - I $D(FILERR) M ^TMP($J,DFN)=FILERR - Q - ; -301 ; PERSON LASTNAME REQUIRED - S X=$P($G(DGP("NAME",1)),U) I X="" S FILERR(RULE)="" - I '$D(DGSD("DEP")) Q - S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D - . S X=$P(DGSD("DEP",RIEN,0),U) - . S X=$P(X,",") I X="" S FILERR(RULE)="" - Q - ; -302 ; DATE OF BIRTH REQUIRED - Duplicate with #4 - Q ;This tag needs to be removed after its placement in IVMZ7CR - S X=$P($G(DGP("PAT",0)),U,3) I X="" S FILERR(RULE)="" - I '$D(DGSD("DEP")) Q - S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D - . S X=$P(DGSD("DEP",RIEN,0),U,3) I X="" S FILERR(RULE)="" - Q - ; -303 ; GENDER REQUIRED - S X=$P($G(DGP("PAT",0)),U,2) I X="" S FILERR(RULE)="" - I '$D(DGSD("DEP")) Q - S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D - . S X=$P(DGSD("DEP",RIEN,0),U,2) I X="" S FILERR(RULE)="" - Q - ; -304 ; GENDER INVALID - S X=$P($G(DGP("PAT",0)),U,2) I X]"",X'="M",X'="F" S FILERR(RULE)="" - I '$D(DGSD("DEP")) Q - S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D - . S X=$P(DGSD("DEP",RIEN,0),U,2) - . I X]"",X'="M",X'="F" S FILERR(RULE)="" - Q - ; -305 ; VETERAN SSN MISSING - Duplicate with #7 - Q ;This tag needs to be removed after its placement in IVMZ7CR - S X=$P($G(DGP("PAT",0)),U,9) I X="" S FILERR(RULE)="" - Q - ; -306 ; VALID SSN/PSEUDO SSN REQUIRED, turned off with DG*5.3*771 - N Z - S X=$P($G(DGP("PAT",0)),U,9) - Q:X="" ;quit if no SSN - Q:$E(X,$L(X))="P" ;quit if SSN is a Pseudo - I $E(X,1,5)="00000" S FILERR(RULE)="" ;First 5 number are zero - S $P(Z,$E(X),9)=$E(X) I X=Z S FILERR(RULE)="" ;all numbers are same - I $E(X,1,3)="000" S FILERR(RULE)="" ;First 3 digits are zeros - I $E(X,4,5)="00" S FILERR(RULE)="" ;4th & 5th are zeros - I $E(X,6,9)="0000" S FILERR(RULE)="" ;Last 4 digits are zeros - I X=123456789 S FILERR(RULE)="" ;SSN is 123456789 - I X>728999999 S FILERR(RULE)="" ;SSN is greater than 728999999 - Q - ; -307 ; PSEUDO SSN REASON REQUIRED, turned off with DG*5.3*771 - S X=$P($G(DGP("PAT",0)),U,9) - I X]"",X["P",$P($G(DGP("PAT","SSN")),U)="" S FILERR(RULE)="" - I '$D(DGSD("DEP")) Q - S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D - . S X=$P(DGSD("DEP",RIEN,0),U,9) - . I X]"",X["P",$P(DGSD("DEP",RIEN,0),U,10)="" S FILERR(RULE)="" - Q - ; -308 ; DATE OF DEATH BEFORE DOB - S X=$P($G(DGP("PAT",.35)),U) I X']"" Q - I X<$P($G(DGP("PAT",0)),U,3) S FILERR(RULE)="" - Q - ; -309 ; PATIENT RELATIONSHIP INVALID - N DEPSEX,RELSEX,DEPREL - I '$D(DGSD("DEP")) Q - S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D - . S DEPREL=$G(DGSD("DEP",RIEN)) - . I DEPREL="" S FILERR(RULE)="" Q - . I '$D(^DG(408.11,DEPREL)) S FILERR(RULE)="" Q - . S DEPSEX=$P(DGSD("DEP",RIEN,0),U,2) - . S RELSEX=$P(^DG(408.11,DEPREL,0),U,3) - . I RELSEX="E" Q ;Gender for relation can be either - . I DEPSEX'=RELSEX S FILERR(RULE)="" - Q - ; -310 ; DEPENDENT EFF. DATE REQUIRED - I '$D(DGSD("DEP")) Q - S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D - . S X=$G(DGSD("DEP",RIEN,"EFF")) I 'X S FILERR(RULE)="" - Q - ; -311 ; DATE OF DEATH IS FUTURE DATE - Duplicate with #16 - Q ;This tag needs to be removed after its placement in IVMZ7CR - S X=$P($G(DGP("PAT",.35)),U) - I X]"",X>$$NOW^XLFDT() S FILERR(RULE)="" - Q - ; -312 ; PERSON MUST HAVE NATIONAL ICN - I $$GETICN^MPIF001(DFN)<0 S FILERR(RULE)="" Q ;No ICN - I $$IFLOCAL^MPIF001(DFN)=1 S FILERR(RULE)="" ;Not National ICN - Q - ; +IVMZ7CD ;CKN,BAJ - HL7 Z07 CONSISTENCY CHECKER -- DEMOGRAPHIC SUBROUTINE ; 9/27/2006 + ;;2.0;INCOME VERIFICATION MATCH;**105**;JUL 8,1996;Build 2 + ; + ; Demographic Consistency Checks + ; This routine will be called from driver routine and it checks the + ; various elements of Person demographic information prior to + ; building a Z07 record. Any test which fails consistency check will + ; be saved in file 38.6 INCONSISTENT DATA ELEMENT record for Person. + ; + ;It is all facade + Q + ; +EN(DFN,DGP,DGSD) ;Entry point + ; input: DFN - Patient IEN + ; DGP - Patient data array + ; DGSD - Spouse and Dependent data array + ; output: ^TMP($J,DFN,RULE) global + ; DFN - Patient IEN + ; RULE - Consistency rule # + ;initializing variables + N RULE,Y,X,FILERR + ; + ; loop through rules in INCONSISTENT DATA ELEMENTS file. + ; execute only the rules where CHECK/DON'T CHECK and INCLUDE IN Z07 + ; CHECKS fields are turned ON. + ; + ; ***NOTE loop boundary (301-311) must be changed if rule numbers + ; are added *** + F RULE=301:1:312 I $D(^DGIN(38.6,RULE)) D + . S Y=^DGIN(38.6,RULE,0) + . I '$P(Y,"^",5),$P(Y,"^",6) D @RULE + I $D(FILERR) M ^TMP($J,DFN)=FILERR + Q + ; +301 ; PERSON LASTNAME REQUIRED + S X=$P($G(DGP("NAME",1)),U) I X="" S FILERR(RULE)="" + I '$D(DGSD("DEP")) Q + S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D + . S X=$P(DGSD("DEP",RIEN,0),U) + . S X=$P(X,",") I X="" S FILERR(RULE)="" + Q + ; +302 ; DATE OF BIRTH REQUIRED - Duplicate with #4 + Q ;This tag needs to be removed after its placement in IVMZ7CR + S X=$P($G(DGP("PAT",0)),U,3) I X="" S FILERR(RULE)="" + I '$D(DGSD("DEP")) Q + S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D + . S X=$P(DGSD("DEP",RIEN,0),U,3) I X="" S FILERR(RULE)="" + Q + ; +303 ; GENDER REQUIRED + S X=$P($G(DGP("PAT",0)),U,2) I X="" S FILERR(RULE)="" + I '$D(DGSD("DEP")) Q + S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D + . S X=$P(DGSD("DEP",RIEN,0),U,2) I X="" S FILERR(RULE)="" + Q + ; +304 ; GENDER INVALID + S X=$P($G(DGP("PAT",0)),U,2) I X]"",X'="M",X'="F" S FILERR(RULE)="" + I '$D(DGSD("DEP")) Q + S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D + . S X=$P(DGSD("DEP",RIEN,0),U,2) + . I X]"",X'="M",X'="F" S FILERR(RULE)="" + Q + ; +305 ; VETERAN SSN MISSING - Duplicate with #7 + Q ;This tag needs to be removed after its placement in IVMZ7CR + S X=$P($G(DGP("PAT",0)),U,9) I X="" S FILERR(RULE)="" + Q + ; +306 ; VALID SSN/PSEUDO SSN REQUIRED + N Z + S X=$P($G(DGP("PAT",0)),U,9) + Q:X="" ;quit if no SSN + Q:$E(X,$L(X))="P" ;quit if SSN is a Pseudo + I $E(X,1,5)="00000" S FILERR(RULE)="" ;First 5 number are zero + S $P(Z,$E(X),9)=$E(X) I X=Z S FILERR(RULE)="" ;all numbers are same + I $E(X,1,3)="000" S FILERR(RULE)="" ;First 3 digits are zeros + I $E(X,4,5)="00" S FILERR(RULE)="" ;4th & 5th are zeros + I $E(X,6,9)="0000" S FILERR(RULE)="" ;Last 4 digits are zeros + I X=123456789 S FILERR(RULE)="" ;SSN is 123456789 + I X>728999999 S FILERR(RULE)="" ;SSN is greater than 728999999 + Q + ; +307 ; PSEUDO SSN REASON REQUIRED + S X=$P($G(DGP("PAT",0)),U,9) + I X]"",X["P",$P($G(DGP("PAT","SSN")),U)="" S FILERR(RULE)="" + I '$D(DGSD("DEP")) Q + S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D + . S X=$P(DGSD("DEP",RIEN,0),U,9) + . I X]"",X["P",$P(DGSD("DEP",RIEN,0),U,10)="" S FILERR(RULE)="" + Q + ; +308 ; DATE OF DEATH BEFORE DOB + S X=$P($G(DGP("PAT",.35)),U) I X']"" Q + I X<$P($G(DGP("PAT",0)),U,3) S FILERR(RULE)="" + Q + ; +309 ; PATIENT RELATIONSHIP INVALID + N DEPSEX,RELSEX,DEPREL + I '$D(DGSD("DEP")) Q + S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D + . S DEPREL=$G(DGSD("DEP",RIEN)) + . I DEPREL="" S FILERR(RULE)="" Q + . I '$D(^DG(408.11,DEPREL)) S FILERR(RULE)="" Q + . S DEPSEX=$P(DGSD("DEP",RIEN,0),U,2) + . S RELSEX=$P(^DG(408.11,DEPREL,0),U,3) + . I RELSEX="E" Q ;Gender for relation can be either + . I DEPSEX'=RELSEX S FILERR(RULE)="" + Q + ; +310 ; DEPENDENT EFF. DATE REQUIRED + I '$D(DGSD("DEP")) Q + S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D + . S X=$G(DGSD("DEP",RIEN,"EFF")) I 'X S FILERR(RULE)="" + Q + ; +311 ; DATE OF DEATH IS FUTURE DATE - Duplicate with #16 + Q ;This tag needs to be removed after its placement in IVMZ7CR + S X=$P($G(DGP("PAT",.35)),U) + I X]"",X>$$NOW^XLFDT() S FILERR(RULE)="" + Q + ; +312 ; PERSON MUST HAVE NATIONAL ICN + I $$GETICN^MPIF001(DFN)<0 S FILERR(RULE)="" Q ;No ICN + I $$IFLOCAL^MPIF001(DFN)=1 S FILERR(RULE)="" ;Not National ICN + Q + ; diff --git a/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CE.m b/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CE.m index fc5ae52f..705ae3e8 100644 --- a/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CE.m +++ b/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CE.m @@ -1,86 +1,85 @@ -IVMZ7CE ;TDM,BAJ,ERC - HL7 Z07 CONSISTENCY CHECKER -- SERVICE SUBROUTINE ; 12/4/07 2:56pm - ;;2.0;INCOME VERIFICATION MATCH;**105,127**;JUL 8,1996;Build 6 - ; - ; Eligibility Consistency Checks - ; This routine checks the various elements of service information - ; prior to building a Z07 record. Any tests which fail consistency - ; check will be saved to the ^DGIN(38.6 record for the patient. - ; - ; Must be called from entry point - Q - ; -EN(DFN,DGP) ; entry point. Patient DFN is sent from calling routine. - ; initialize working variables - N RULE,Y,X,FILERR - ; - ; loop through rules in INCONSISTENT DATA ELEMENTS file. - ; execute only the rules where CHECK/DON'T CHECK and INCLUDE IN Z07 - ; CHECKS fields are turned ON. - ; - ; ***NOTE loop boundary (401-413) must be changed if rule numbers - ; are added *** - F RULE=401:1:413 I $D(^DGIN(38.6,RULE)) D - . S Y=^DGIN(38.6,RULE,0) - . I '$P(Y,U,5),$P(Y,U,6) D @RULE - I $D(FILERR) M ^TMP($J,DFN)=FILERR - Q - ; -401 ; RATED INCOMPETENT INVALID - S X=$P(DGP("PAT",.29),U,12) I (X'="")&(X'=0)&(X'=1) S FILERR(RULE)="" - Q - ; -402 ; ELIGIBLE FOR MEDICAID INVALID - S X=$P(DGP("PAT",.38),U) I (X'="")&(X'=0)&(X'=1) S FILERR(RULE)="" - Q - ; -403 ; DT MEDICAID LAST ASKED INVALID - I $P(DGP("PAT",.38),U)=1,$P(DGP("PAT",.38),U,2)<1 S FILERR(RULE)="" - Q - ; -404 ; INELIGIBLE REASON INVALID - ; Note: RULE #15 in IVMZ7CR is a duplicate of this rule - Q - ; -405 ; NON VETERAN ELIG CODE INVALID - ; Note: RULE #60 in IVMZ7CR is a duplicate of this rule - Q - ; -406 ; CLAIM FOLDER NUMBER INVALID - S X=$P(DGP("PAT",.31),U,3) - I X'="",$P(DGP("PAT",0),U,9)'=X,(($L(X)>8)!($L(X)<7)) S FILERR(RULE)="" - Q - ; -407 ; ELIGIBILITY STATUS INVALID - S X=$P(DGP("PAT",.361),U) I (X'="")&(X'="P")&(X'="R")&(X'="V") S FILERR(RULE)="" - Q - ; -408 ; DECLINE TO GIVE INCOME INVALID - ; This CC removed per customer 05/08/2006 -- BAJ - ; I $D(DGP("MEANS",0)),$P(DGP("MEANS",0),U,4)<1,$P(DGP("MEANS",0),U,14)'=1 S FILERR(RULE)="" - Q - ; -409 ; AGREE TO PAY DEDUCT INVALID - ; this CC inactivated by DG*5.3*771 - ; 2 PENDING ADJUDICATION MEANS TEST - ; 6 MT COPAY REQUIRED MEANS TEST - ;16 GMT COPAY REQUIRED MEANS TEST - I $D(DGP("MEANS",0)),$P(DGP("MEANS",0),U,11)="" D - . S X=$P(DGP("MEANS",0),U,3) - . I (X=2)!(X=6) S FILERR(RULE)="" Q - . I X=16,'$P(DGP("MEANS",0),U,20) S FILERR(RULE)="" - Q - ; -410 ; Note: RULE #404 above is a duplicate of this rule - Q - ; -411 ; ENROLLMENT APP DATE INVALID - I $D(DGP("ENR",0)) S X=$P(DGP("ENR","0"),U) I ($E(X,1,3)<1)!($E(X,4,5)<1)!($E(X,6,7)<1) S FILERR(RULE)="" - Q - ; -412 ; POS/ELIG CODE INVALID - ; Note: RULE #24 in IVMZ7CR is a duplicate of this rule - Q - ; -413 ; POS INVALID - ; Note: RULE #13 in IVMZ7CR is a duplicate of this rule - Q +IVMZ7CE ;TDM,BAJ - HL7 Z07 CONSISTENCY CHECKER -- SERVICE SUBROUTINE ; 01/23/07 + ;;2.0;INCOME VERIFICATION MATCH;**105**;JUL 8,1996;Build 2 + ; + ; Eligibility Consistency Checks + ; This routine checks the various elements of service information + ; prior to building a Z07 record. Any tests which fail consistency + ; check will be saved to the ^DGIN(38.6 record for the patient. + ; + ; Must be called from entry point + Q + ; +EN(DFN,DGP) ; entry point. Patient DFN is sent from calling routine. + ; initialize working variables + N RULE,Y,X,FILERR + ; + ; loop through rules in INCONSISTENT DATA ELEMENTS file. + ; execute only the rules where CHECK/DON'T CHECK and INCLUDE IN Z07 + ; CHECKS fields are turned ON. + ; + ; ***NOTE loop boundary (401-413) must be changed if rule numbers + ; are added *** + F RULE=401:1:413 I $D(^DGIN(38.6,RULE)) D + . S Y=^DGIN(38.6,RULE,0) + . I '$P(Y,U,5),$P(Y,U,6) D @RULE + I $D(FILERR) M ^TMP($J,DFN)=FILERR + Q + ; +401 ; RATED INCOMPETENT INVALID + S X=$P(DGP("PAT",.29),U,12) I (X'="")&(X'=0)&(X'=1) S FILERR(RULE)="" + Q + ; +402 ; ELIGIBLE FOR MEDICAID INVALID + S X=$P(DGP("PAT",.38),U) I (X'="")&(X'=0)&(X'=1) S FILERR(RULE)="" + Q + ; +403 ; DT MEDICAID LAST ASKED INVALID + I $P(DGP("PAT",.38),U)=1,$P(DGP("PAT",.38),U,2)<1 S FILERR(RULE)="" + Q + ; +404 ; INELIGIBLE REASON INVALID + ; Note: RULE #15 in IVMZ7CR is a duplicate of this rule + Q + ; +405 ; NON VETERAN ELIG CODE INVALID + ; Note: RULE #60 in IVMZ7CR is a duplicate of this rule + Q + ; +406 ; CLAIM FOLDER NUMBER INVALID + S X=$P(DGP("PAT",.31),U,3) + I X'="",$P(DGP("PAT",0),U,9)'=X,(($L(X)>8)!($L(X)<7)) S FILERR(RULE)="" + Q + ; +407 ; ELIGIBILITY STATUS INVALID + S X=$P(DGP("PAT",.361),U) I (X'="")&(X'="P")&(X'="R")&(X'="V") S FILERR(RULE)="" + Q + ; +408 ; DECLINE TO GIVE INCOME INVALID + ; This CC removed per customer 05/08/2006 -- BAJ + ; I $D(DGP("MEANS",0)),$P(DGP("MEANS",0),U,4)<1,$P(DGP("MEANS",0),U,14)'=1 S FILERR(RULE)="" + Q + ; +409 ; AGREE TO PAY DEDUCT INVALID + ; 2 PENDING ADJUDICATION MEANS TEST + ; 6 MT COPAY REQUIRED MEANS TEST + ;16 GMT COPAY REQUIRED MEANS TEST + I $D(DGP("MEANS",0)),$P(DGP("MEANS",0),U,11)="" D + . S X=$P(DGP("MEANS",0),U,3) + . I (X=2)!(X=6) S FILERR(RULE)="" Q + . I X=16,'$P(DGP("MEANS",0),U,20) S FILERR(RULE)="" + Q + ; +410 ; Note: RULE #404 above is a duplicate of this rule + Q + ; +411 ; ENROLLMENT APP DATE INVALID + I $D(DGP("ENR",0)) S X=$P(DGP("ENR","0"),U) I ($E(X,1,3)<1)!($E(X,4,5)<1)!($E(X,6,7)<1) S FILERR(RULE)="" + Q + ; +412 ; POS/ELIG CODE INVALID + ; Note: RULE #24 in IVMZ7CR is a duplicate of this rule + Q + ; +413 ; POS INVALID + ; Note: RULE #13 in IVMZ7CR is a duplicate of this rule + Q diff --git a/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CR.m b/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CR.m index d9d993b1..2eae8597 100644 --- a/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CR.m +++ b/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CR.m @@ -1,249 +1,250 @@ -IVMZ7CR ;BAJ,ERC - HL7 Z07 CONSISTENCY CHECKER -- REGISTRATION SUBROUTINE ; 12/6/07 8:51am - ;;2.0;INCOME VERIFICATION MATCH;**105,127**;JUL 8,1996;Build 6 - ; - ; Registration Consistency Checks - Q ; Entry point must be specified -EN(DFN,DGP,DGSD) ;Entry point - ; input: DFN - Patient IEN - ; DGP - Patient data array - ; DGSD - Spouse and Dependent data array - ; output: ^TMP($J,DFN,RULE) global - ; DFN - Patient IEN - ; RULE - Consistency rule # - ;initialize variables - N RULE,Y,X,FILERR,SPDEP - S SPDEP=$D(DGSD("DEP")) - ; we do not count through all numbers to save routine space - F RULE=4,7,9,11,13,15,16,19,24,29:1:31,34,60,72,74,75,76,78,81,83,85,86 I $D(^DGIN(38.6,RULE)) D - . I $$ON(RULE) D @RULE - I $D(FILERR) M ^TMP($J,DFN)=FILERR - Q -4 ; DOB UNSPECIFIED - ; Note: RULE #302 in IVMZ7CD is a duplicate of this rule - N RIEN - I $P($G(DGP("PAT",0)),U,3)="" S FILERR(RULE)="" - I 'SPDEP Q - S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D - . I $P(DGSD("DEP",RIEN,0),U,3)="" S FILERR(RULE)="" - Q -7 ; SSN UNSPECIFIED - ; Note: RULE #305 in IVMZ7CD is a duplicate of this rule - I $P($G(DGP("PAT",0)),U,9)="" S FILERR(RULE)="" - Q -9 ; VETERAN STATUS UNSPECIFIED - I $P($G(DGP("PAT","VET")),U)="" S FILERR(RULE)="" - Q -11 ; SC PROMPT INCONSISTENT - N VET,SC,PTYPE - ; If VET Status is not specified (RULE 9) no need for this test - Q:$P($G(DGP("PAT","VET")),U)="" - S VET=$P(DGP("PAT","VET"),U,1)="Y",SC=$P(DGP("PAT",.3),U,1)="Y" - I 'VET,SC S FILERR(RULE)="" - Q -13 ; POS UNSPECIFIED - ; Note: Rule #413 IN IVMZ7CE is a duplicate of this rule - Q:$P($G(DGP("PAT","VET")),U,1)'="Y" - ; Make sure that the value in the field is valid -- DGRPC does this as well - I '$D(^DIC(21,+$P(DGP("PAT",.32),U,3),0)) S FILERR(RULE)="" - Q -15 ; INEL REASON UNSPECIFIED - ; Note: Rule #404 IN IVMZ7CE is a duplicate of this rule - I $P(DGP("PAT",.15),U,2),$P($G(DGP("PAT",.3)),U,7)="" S FILERR(RULE)="" - Q -16 ; DATE OF DEATH IN FUTURE - ; Note: Rule #308 IN IVMZ7CD is a duplicate of this rule - S X=$P($G(DGP("PAT",.35)),U) I X']"" Q - ; Compare DOD to right now - I X>$$DT^XLFDT S FILERR(RULE)="" - Q -19 ; ELIG/NONVET STAT INCONSISTENT - ; Note: Rule #405 in IVMZ7CE is a duplicate of this rule - N VET,ELIG,FILE8,FILE81,MPTR,MTYPE,PTYPE - ; Patient's VET status - S VET=$P($G(DGP("PAT","VET")),U,1) I VET="" S FILERR(RULE)="" Q - ; do this check for NON-VET status only - Q:VET="Y" - ; Check PT type to see if we skip VET checks - S PTYPE=$P($G(DGP("PAT","TYPE")),U,1) - I PTYPE]"",$P(^DG(391,PTYPE,0),U,2) Q - ; Eligibility Code - S ELIG=$P($G(DGP("PAT",.36)),U,1) I ELIG="" S FILERR(RULE)="" Q - ;start in File #8 - S FILE8=$G(^DIC(8,ELIG,0)) I FILE8="" S FILERR(RULE)="" Q - ;using the pointer value in field #8 (node 0; piece 9) - S MPTR=$P(FILE8,U,9) - ;find the record in File #8.1 - S FILE81=$G(^DIC(8.1,MPTR,0)) I FILE81="" S FILERR(RULE)="" Q - ;check the Type field #4 (node 0; piece 5). - S MTYPE=$P(FILE81,U,5) - ; Pt's VET status must match NON-VET Status of Eligibility Code - I VET'=MTYPE S FILERR(RULE)="" - Q -24 ; POS/ELIG CODE INCONSISTENT - ; Note: Rule #412 in IVMZ7CE is a duplicate of this rule - I '$D(^DIC(21,+$P(DGP("PAT",.32),U,3),"E",+$P(DGP("PAT",.36),U,1))) S FILERR(RULE)="" - Q -29 ; A&A CLAIMED, NONVET - I $P(DGP("PAT","VET"),U,1)'="Y",$P($G(^DPT(DFN,.362)),U,12)="Y" S FILERR(RULE)="" - Q -30 ; HOUSEBOUND CLAIMED, NONVET - I $P(DGP("PAT","VET"),U,1)'="Y",$P($G(^DPT(DFN,.362)),U,13)="Y" S FILERR(RULE)="" - Q -31 ; VA PENSION CLAIMED, NONVET - I $P(DGP("PAT","VET"),U,1)'="Y",$P($G(^DPT(DFN,.362)),U,14)="Y" S FILERR(RULE)="" - Q -34 ; POW CLAIMED, NONVET - I $P(DGP("PAT","VET"),U,1)'="Y",$P($G(^DPT(DFN,.52)),U,5)="Y" S FILERR(RULE)="" - Q -60 ; AGENT ORANGE EXP LOC MISSING - ; Note: Rule #512 in IVMZ7CS is a duplicate of this rule. - I $P(DGP("PAT",.321),U,2)="Y",$P(DGP("PAT",.321),U,13)="" S FILERR(RULE)="" - Q -72 ; MSE DATA MISSING/INCOMPLETE, turned off with DG*5.3*765 - ; Note: Rule #513 in IVMZ7CS is a duplicate of this rule. - N I,X - S X=DGP("PAT",.32) - F I=4,5,8 I $P(X,U,I)'="",'$$YY^IVMZ7CS($P(X,U,6)) S FILERR(RULE)="" Q ;LAST - F I=9,10,13 I $P(X,U,I)'="",'$$YY^IVMZ7CS($P(X,U,11)) S FILERR(RULE)="" Q ;NTL - F I=14,15,18 I $P(X,U,I)'="",'$$YY^IVMZ7CS($P(X,U,11)) S FILERR(RULE)="" ;NNTL - Q - ; -74 ; CONFLICT DT MISSING/INCOMPLETE, turned off with DG*5.3*765 - ; Note:#515 IVMZ7CS is a duplicate, turned off with DG*5.3*771 -75 ; ALSO # 75 CONFLICT TO DT BEFORE FROM DT -76 ; # 76 INACCURATE CONFLICT DATE, turned off with DG*5.3*771 - ; - N I,T,FROM,TO,NODE,PCE,PCEFR,PCETO,CONFL,RANGE,RFR,RTO,RNGE,ERR,COM,ON74,ON75,ON76 - S ON74=$$ON(74),ON75=$$ON(75),ON76=$$ON(76) - S I=$$RANGE^DGMSCK() ; load range table - F I=1:1 S CONFL=$P($T(CONLIST+I),";;",3) Q:CONFL="QUIT" D - . ;we have to have a flag ERR because we don't want multiple - . ;inconsistencies on a single conflict but we do want to - . ;flag a single inconsistency on multiple conflicts - . S ERR=0 - . S NODE=$P(CONFL,U,1),PCE=$P(CONFL,U,2),PCEFR=$P(CONFL,U,3),PCETO=$P(CONFL,U,4) - . S RNGE=$P(CONFL,U,5) - . Q:$P(DGP("PAT",NODE),U,PCE)'="Y" - . S FROM=$P(DGP("PAT",NODE),U,PCEFR),TO=$P(DGP("PAT",NODE),U,PCETO) - . ; check rule 74 CONFLICT DT MISSING/INCOMPLETE - . I ON74,(RULE=74) F T=FROM,TO I '$$YM^IVMZ7CS(T) S FILERR(RULE)="",ERR=1 - . Q:ERR - . ; check rule 75 CONFLICT TO DT BEFORE CONFLICT FROM DT - . I ON75,(RULE=75),(FROM>TO) S FILERR(RULE)="",ERR=1 - . Q:ERR - . ; check rule 76 INACCURATE CONFLICT DATE - . Q:ERR - . Q:'$D(RANGE(RNGE)) ; can't calculate if range table is missing - . ; determine whether dates are withing conflict range - . S RFR=$P(RANGE(RNGE),U,1),RTO=$P(RANGE(RNGE),U,2) - . I ON76,(RULE=76) D - . . I '((RFR'>FROM)&((RTO'FROM&((FROM'>RTO)&((RTO'$$DT^XLFDT S FILERR(RULE)="" + Q +19 ; ELIG/NONVET STAT INCONSISTENT + ; Note: Rule #405 in IVMZ7CE is a duplicate of this rule + N VET,ELIG,FILE8,FILE81,MPTR,MTYPE,PTYPE + ; Patient's VET status + S VET=$P($G(DGP("PAT","VET")),U,1) I VET="" S FILERR(RULE)="" Q + ; do this check for NON-VET status only + Q:VET="Y" + ; Check PT type to see if we skip VET checks + S PTYPE=$P($G(DGP("PAT","TYPE")),U,1) + I PTYPE]"",$P(^DG(391,PTYPE,0),U,2) Q + ; Eligibility Code + S ELIG=$P($G(DGP("PAT",.36)),U,1) I ELIG="" S FILERR(RULE)="" Q + ;start in File #8 + S FILE8=$G(^DIC(8,ELIG,0)) I FILE8="" S FILERR(RULE)="" Q + ;using the pointer value in field #8 (node 0; piece 9) + S MPTR=$P(FILE8,U,9) + ;find the record in File #8.1 + S FILE81=$G(^DIC(8.1,MPTR,0)) I FILE81="" S FILERR(RULE)="" Q + ;check the Type field #4 (node 0; piece 5). + S MTYPE=$P(FILE81,U,5) + ; Pt's VET status must match NON-VET Status of Eligibility Code + I VET'=MTYPE S FILERR(RULE)="" + Q +24 ; POS/ELIG CODE INCONSISTENT + ; Note: Rule #412 in IVMZ7CE is a duplicate of this rule + I '$D(^DIC(21,+$P(DGP("PAT",.32),U,3),"E",+$P(DGP("PAT",.36),U,1))) S FILERR(RULE)="" + Q +29 ; A&A CLAIMED, NONVET + I $P(DGP("PAT","VET"),U,1)'="Y",$P($G(^DPT(DFN,.362)),U,12)="Y" S FILERR(RULE)="" + Q +30 ; HOUSEBOUND CLAIMED, NONVET + I $P(DGP("PAT","VET"),U,1)'="Y",$P($G(^DPT(DFN,.362)),U,13)="Y" S FILERR(RULE)="" + Q +31 ; VA PENSION CLAIMED, NONVET + I $P(DGP("PAT","VET"),U,1)'="Y",$P($G(^DPT(DFN,.362)),U,14)="Y" S FILERR(RULE)="" + Q +34 ; POW CLAIMED, NONVET + I $P(DGP("PAT","VET"),U,1)'="Y",$P($G(^DPT(DFN,.52)),U,5)="Y" S FILERR(RULE)="" + Q +60 ; AGENT ORANGE EXP LOC MISSING + ; Note: Rule #512 in IVMZ7CS is a duplicate of this rule. + I $P(DGP("PAT",.321),U,2)="Y",$P(DGP("PAT",.321),U,13)="" S FILERR(RULE)="" + Q +72 ; MSE DATA MISSING/INCOMPLETE + ; Note: Rule #513 in IVMZ7CS is a duplicate of this rule. + N I,X + S X=DGP("PAT",.32) + F I=4,5,8 I $P(X,U,I)'="",'$$YY^IVMZ7CS($P(X,U,6)) S FILERR(RULE)="" Q ;LAST + F I=9,10,13 I $P(X,U,I)'="",'$$YY^IVMZ7CS($P(X,U,11)) S FILERR(RULE)="" Q ;NTL + F I=14,15,18 I $P(X,U,I)'="",'$$YY^IVMZ7CS($P(X,U,11)) S FILERR(RULE)="" ;NNTL + Q + ; +74 ; CONFLICT DT MISSING/INCOMPLETE + ; Note: Rule #515 in IVMZ7CS is a duplicate of this rule. + ; ALSO # 75 CONFLICT TO DT BEFORE FROM DT + ; # 76 INACCURATE CONFLICT DATE + ; + N I,T,FROM,TO,RULE1,RULE2,NODE,PCE,PCEFR,PCETO,CONFL,RANGE,RFR,RTO,RNGE,ERR,COM,ON75,ON76 + S RULE1=75,RULE2=76 + S ON75=$$ON(75),ON76=$$ON(76) + S I=$$RANGE^DGMSCK() ; load range table + F I=1:1 S CONFL=$P($T(CONLIST+I),";;",3) Q:CONFL="QUIT" D + . ;we have to have a flag ERR because we don't want multiple + . ;inconsistencies on a single conflict but we do want to + . ;flag a single inconsistency on multiple conflicts + . S ERR=0 + . S NODE=$P(CONFL,U,1),PCE=$P(CONFL,U,2),PCEFR=$P(CONFL,U,3),PCETO=$P(CONFL,U,4) + . S RNGE=$P(CONFL,U,5) + . Q:$P(DGP("PAT",NODE),U,PCE)'="Y" + . S FROM=$P(DGP("PAT",NODE),U,PCEFR),TO=$P(DGP("PAT",NODE),U,PCETO) + . ; check rule 74 CONFLICT DT MISSING/INCOMPLETE + . F T=FROM,TO I '$$YM^IVMZ7CS(T) S FILERR(RULE)="",ERR=1 + . Q:ERR + . ; check rule 75 CONFLICT TO DT BEFORE CONFLICT FROM DT + . I ON75,FROM>TO S FILERR(RULE1)="",ERR=1 + . Q:ERR + . ; check rule 76 INACCURATE CONFLICT DATE + . Q:ERR + . Q:'$D(RANGE(RNGE)) ; can't calculate if range table is missing + . ; determine whether dates are withing conflict range + . S RFR=$P(RANGE(RNGE),U,1),RTO=$P(RANGE(RNGE),U,2) + . I ON76 D + . . I '((RFR'>FROM)&((RTO'FROM&((FROM'>RTO)&((RTO'PSGDT D OLD Q - S PSGE="E" I '$D(PSGOETOF) S (PSGDFLG,PSGDI)='$$DDOK^PSGOE2("^PS(55,"_PSGP_",5,"_+PSGORD_",1,",+$G(^PS(55,PSGP,5,+PSGORD,.2))),PSGPFLG='$$OIOK^PSGOE2(+$G(^PS(55,PSGP,5,+PSGORD,.2))) - S:$P(X,"^",26) (PSGE,PSGR)="" - I '$D(PSGOETOF) S PSGPI=$P(X,"^",2) I PSGPI S PSGPI=$P($G(^VA(200,PSGPI,"PS")),"^",4) S:PSGPI PSGPI=PSGPI'>DT - S ST=$P(X,"^",9)="H"*4 S:ST (PSGE,PSGR)="" - N CMPOK S CMPOK=1 I $$COMPLEX^PSJOE(PSGP,PSGORD) S CMPOK=+$P(^PS(55,PSGP,5,+PSGORD,.2),"^",8) - S PSGACT="D"_$S('$G(CMPOK):"",1:PSGE)_$S($P(ND,"^",18+ST)&'$P(ND,"^",19+ST)&'$P(ND,"^",PSJSYSU):"",1:"H")_"L"_$S(ST:"",1:PSGR) - I PSJSYSU,'$P(ND,"^",+PSJSYSU) S PSGACT=PSGACT_"V" - I +PSJSYSU=3,$L($T(EN1^ORCFLAG)) S PSGACT=PSGACT_"G" - Q -OLD ; - S A=$P(ND0,"^",9),PSGACT=$E("H",A="H")_"L" I A'["D",A'["E" Q - I 'PSGOENG,($D(^XUSEC("PSJU MGR",DUZ))!$D(^XUSEC("PSJ RPHARM",DUZ))) S PSGACT="LN" - I PSJSYSU,'$P(ND,"^",+PSJSYSU) S:(A'["D")&($G(PSGPRIO)'="DONE") PSGACT="D"_PSGACT S PSGACT=PSGACT_"V" Q - Q:PSGR=""!'PSJPCAF D NOW^%DTC S (PSGDT,X1)=+$E(%,1,12),X2=-4 D C^%DTC I $S('$P(ND2,"^",4):1,1:$P(ND2,"^",4)'>X) Q - I A="E",$G(PSJPRI)'="D" S PSGACT=PSGACT_PSGR Q - I PSJSYSU,$P(ND,"^",11) S PSGACT=PSGACT_PSGR,PSGRRF=1 - Q -NON ; - N XND,DRGPT,XND2 - S (X,XND)=$G(^PS(53.1,+PSGORD,0)) I $P(X,"^",19),$D(^PS(55,PSGP,5,$P(X,"^",19))) L -^PS(53.1,+PSGORD) S PSGORD=$P(X,"^",19)_"U" G ACT - I $S($P(X,"^",26):1,$P(X,"^",9)["D":1,1:$P(X,"^",9)["E") S:$P(X,U,9)="P"&($P(X,U,26)) PSGACT="D" S:(+PSJSYSU=3)&($L($T(EN1^ORCFLAG))) PSGACT=PSGACT_"G" Q - I PSGORD["U" S PSGACT="DE" S:(+PSJSYSU=3)&($L($T(EN1^ORCFLAG))) PSGACT=PSGACT_"G" Q - I '$D(PSGOETOF) S (PSGDFLG,PSGDI)='$$DDOK^PSGOE2("^PS(53.1,"_+PSGORD_",1,",+$G(^PS(53.1,+PSGORD,.2))),PSGPFLG='$$OIOK^PSGOE2(+$G(^PS(53.1,+PSGORD,.2))) - S DRG=$$STUFFDD^PSGOE2 S:DRG ^PS(53.1,+PSGORD,1,0)="^53.11P^1^1",^PS(53.1,+PSGORD,1,1,0)=DRG,^PS(53.1,+PSGORD,1,"B",DRG,1)="" - F DRG=0:0 S DRG=$O(^PS(53.1,+PSGORD,1,DRG)) Q:'DRG S DRGPT=^(DRG,0) S INACTDT=$G(^PSDRUG(+DRGPT,"I")) I INACTDT,(INACTDT'>DT) S PSGDFLG=1 - I $P(XND,U,9)="P" S PSGACT=$S(+PSJSYSU=3:"BDEF",$G(PSJRNF):"BDEF",1:"") S:(+PSJSYSU=3)&($L($T(EN1^ORCFLAG))) PSGACT=PSGACT_"G" Q - I '$D(PSGOETOF) S PSGPI=$P(XND,"^",2) I PSGPI S PSGPI=$P($G(^VA(200,PSGPI,"PS")),"^",4) S:PSGPI PSGPI=PSGPI'>DT - S PSGACT="DEI" I PSJSYSU,'PSGPI,$P(XND,"^",9)'="I" S PSGACT=PSGACT_"V" - S XND2=$G(^PS(53.1,+PSGORD,.2)) I $P(XND2,"^",8),$P(XND,"^",9)="P" S PSGACT=$TR(PSGACT,"V") - I +PSJSYSU=3,$L($T(EN1^ORCFLAG)) S PSGACT=PSGACT_"G" - I $P($G(PSGRDTX),U,2)]"",'$P($G(^PS(53.1,+PSGORD,2.5)),"^",2) S $P(^PS(53.1,+PSGORD,2.5),U,2)=$P(PSGRDTX,U,2) - Q -ACTO ; - S PSGACTO="" I $G(PSGACT)]"" F X=1:1:$L(PSGACT) S PSGACTO=PSGACTO_$S($E(PSGACT,X)="D":"DC",1:$E(PSGACT,X))_" " - S:PSGACTO]"" PSGACTO=$E(PSGACTO,1,$L(PSGACTO)-1) Q +PSGOE1 ;BIR/CML3-ACTION ON INPATIENT ORDERS ;10 Mar 99 / 10:54 AM + ;;5.0; INPATIENT MEDICATIONS ;**7,19,26,39,58,85,80,110,127,133**;16 DEC 97 + ; + ; Reference to ^PS(55 is supported by DBIA #2191. + ; Reference to ^PSDRUG( is supported by DBIA #2192. + ; Reference to EN1^ORCFLAG is supported by DBIA #3620. + ; Reference to AND^ORX8 is supported by DBIA #3632. +EN ; + K PSGDFLG,PSGPFLG S PSGOEA="^",PSGACT="",(PSGDI,PSGOENG,PSGPI,PSGRRF)=0 + Q:'$G(DUZ) + D @$S(PSGORD["P":"NON",1:"ACT") +GO ; + K A,ND,PSGE,PSGR,ST,X,X1,X2,Y I $D(ORACTION) K PSGDI,PSGOENG,PSGPI Q + ;W:$G(PSGPFLG) !!?3,"(THE ORDERABLE ITEM IS CURRENTLY LISTED AS INACTIVE.)" W:$G(PSGDFLG) !!?3,"(ONE OR ALL DISPENSE DRUGS ARE CURRENTLY LISTED AS INACTIVE OR DO NOT MATCH",!?3,"THE ORDERABLE ITEM FOR THIS ORDER.)" + ;I $G(PSGPFLG)!$G(PSGDFLG) K DIR S DIR(0)="E" D ^DIR K DIR + ;S PSGCANFL=0 ;F D ACTO W !!,"ACTION"_$S(PSGACTO]"":" ("_PSGACTO_")",1:"")_"? " R PSGOEA:DTIME W:'$T $C(7) S:'$T PSGOEA="^" Q:"^"[PSGOEA D CHK D:C @PSGOEA Q:PSGCANFL + Q +ENACTION(PSGP,PSGORD) ; + ;Returns string identifying the actions allowed on this order. + D EN + Q PSGACT +DONE ; + I PSGORD["U"!(PSGORD["O") L -^PS(55,PSGP,5,+PSGORD) + E L -^PS(53.1,+PSGORD) + K C,PSGACT,PSGDFLG,PSGPFLG,PSGDI,PSGOENG,PSGPI,PSGRRF Q +B ; bypass + S PSGCANFL=1 + Q +C ; copy an order (does NOT discontinue original order) + D ^PSGOD Q +D ; discontinue (or delete) an order + I PSGOEAV,'$D(PSGODF) D ENDS^PSGPO Q + D ENO^PSGOEC(PSGP,PSGORD) Q +E ; edit orders + D ^PSGOEE Q +F ; finish released orders + D ^PSGOEF Q +H(PSGP,PSGORD) ; hold + S X=$G(^PS(55,PSGP,5,+PSGORD,4)) I $P(X,U,12),$P(X,U,13) W $C(7),!!,"WARNING! THIS ORDER HAS BEEN MARKED FOR CANCELLATION." + I $P($G(^PS(55,PSGP,5,+PSGORD,0)),"^",9)="H" D ^PSGOEH0 Q + D ^PSGOEH1 Q +I ; mark (or unmark) a non-verified order as 'incomplete' + D ^PSGOEI Q +L ; display logs + D ^PSGOEL Q +N ; mark order as 'not to be given' + D ^PSGOENG Q +O ; Outpatient (discharge) med + W !!,"UNDER DEVELOPMENT, NOT CURRENTLY AVAILABLE." + Q +P ; print expanded view + D ^PSGVWP Q +R ; renew an order + I 'PSJSYSU,$D(^PS(55,PSGP,5,+PSGORD,4)),$P(^(4),"^",15),$P(^(4),"^",16) W !!,"THIS ORDER IS ALREADY MARKED FOR RENEWAL!" Q + I 'PSGRRF D ^PSGOER Q + D ^PSGOERI Q +S ; show the order again + D EN2^PSGVW Q +V ; verify an order + D EN^PSGOEV Q +ACT ; + S X=$G(^PS(55,PSGP,5,+PSGORD,0)),ND0=X,ND=$G(^(4)),ND2=$G(^(2)),PSGOENG=$P(X,"^",22),PSGR=$E("R",'PSGOENG),PSJCOM=$P($G(^PS(55,PSGP,5,+PSGORD,.2)),U,8) + I 'PSGOENG,PSJCOM S PSGR=$E("R",$$AND^ORX8(PSJCOM)) S:PSGR="R" PSGR=$E("R",$$RNEWOK^PSJUTL2(PSJCOM,PSGP)) + S PSGR=$E("R",'$$EXPIRED^PSGOER(PSGP,PSGORD)) S PSGR=$E("R",$P(ND0,"^",7)'="O") + I $P(ND2,U,4)'>PSGDT D OLD Q + S PSGE="E" I '$D(PSGOETOF) S (PSGDFLG,PSGDI)='$$DDOK^PSGOE2("^PS(55,"_PSGP_",5,"_+PSGORD_",1,",+$G(^PS(55,PSGP,5,+PSGORD,.2))),PSGPFLG='$$OIOK^PSGOE2(+$G(^PS(55,PSGP,5,+PSGORD,.2))) + S:$P(X,"^",26) (PSGE,PSGR)="" + I '$D(PSGOETOF) S PSGPI=$P(X,"^",2) I PSGPI S PSGPI=$P($G(^VA(200,PSGPI,"PS")),"^",4) S:PSGPI PSGPI=PSGPI'>DT + S ST=$P(X,"^",9)="H"*4 S:ST (PSGE,PSGR)="" + ;S PSGACT="D"_$S(+$P(^PS(55,PSGP,5,+PSGORD,.2),"^",8):"",1:PSGE)_$S($P(ND,"^",18+ST)&'$P(ND,"^",19+ST)&'$P(ND,"^",PSJSYSU):"",1:"H")_"L"_$S(ST:"",1:PSGR) + N CMPOK S CMPOK=1 I $$COMPLEX^PSJOE(PSGP,PSGORD) S CMPOK=+$P(^PS(55,PSGP,5,+PSGORD,.2),"^",8) + S PSGACT="D"_$S('$G(CMPOK):"",1:PSGE)_$S($P(ND,"^",18+ST)&'$P(ND,"^",19+ST)&'$P(ND,"^",PSJSYSU):"",1:"H")_"L"_$S(ST:"",1:PSGR) + I PSJSYSU,'$P(ND,"^",+PSJSYSU) S PSGACT=PSGACT_"V" + I +PSJSYSU=3,$L($T(EN1^ORCFLAG)) S PSGACT=PSGACT_"G" + Q +OLD ; + S A=$P(ND0,"^",9),PSGACT=$E("H",A="H")_"L" I A'["D",A'["E" Q + I 'PSGOENG,($D(^XUSEC("PSJU MGR",DUZ))!$D(^XUSEC("PSJ RPHARM",DUZ))) S PSGACT="LN" + I PSJSYSU,'$P(ND,"^",+PSJSYSU) S:(A'["D")&($G(PSGPRIO)'="DONE") PSGACT="D"_PSGACT S PSGACT=PSGACT_"V" Q + Q:PSGR=""!'PSJPCAF D NOW^%DTC S (PSGDT,X1)=+$E(%,1,12),X2=-4 D C^%DTC I $S('$P(ND2,"^",4):1,1:$P(ND2,"^",4)'>X) Q + I A="E",$G(PSJPRI)'="D" S PSGACT=PSGACT_PSGR Q + I PSJSYSU,$P(ND,"^",11) S PSGACT=PSGACT_PSGR,PSGRRF=1 + Q +NON ; + N XND,DRGPT,XND2 + S (X,XND)=$G(^PS(53.1,+PSGORD,0)) I $P(X,"^",19),$D(^PS(55,PSGP,5,$P(X,"^",19))) L -^PS(53.1,+PSGORD) S PSGORD=$P(X,"^",19)_"U" G ACT + I $S($P(X,"^",26):1,$P(X,"^",9)["D":1,1:$P(X,"^",9)["E") S:$P(X,U,9)="P"&($P(X,U,26)) PSGACT="D" S:(+PSJSYSU=3)&($L($T(EN1^ORCFLAG))) PSGACT=PSGACT_"G" Q + I PSGORD["U" S PSGACT="DE" S:(+PSJSYSU=3)&($L($T(EN1^ORCFLAG))) PSGACT=PSGACT_"G" Q + I '$D(PSGOETOF) S (PSGDFLG,PSGDI)='$$DDOK^PSGOE2("^PS(53.1,"_+PSGORD_",1,",+$G(^PS(53.1,+PSGORD,.2))),PSGPFLG='$$OIOK^PSGOE2(+$G(^PS(53.1,+PSGORD,.2))) + S DRG=$$STUFFDD^PSGOE2 S:DRG ^PS(53.1,+PSGORD,1,0)="^53.11P^1^1",^PS(53.1,+PSGORD,1,1,0)=DRG,^PS(53.1,+PSGORD,1,"B",DRG,1)="" + F DRG=0:0 S DRG=$O(^PS(53.1,+PSGORD,1,DRG)) Q:'DRG S DRGPT=^(DRG,0) S INACTDT=$G(^PSDRUG(+DRGPT,"I")) I INACTDT,(INACTDT'>DT) S PSGDFLG=1 + I $P(XND,U,9)="P" S PSGACT=$S(+PSJSYSU=3:"BDEF",$G(PSJRNF):"BDEF",1:"") S:(+PSJSYSU=3)&($L($T(EN1^ORCFLAG))) PSGACT=PSGACT_"G" Q + I '$D(PSGOETOF) S PSGPI=$P(XND,"^",2) I PSGPI S PSGPI=$P($G(^VA(200,PSGPI,"PS")),"^",4) S:PSGPI PSGPI=PSGPI'>DT + S PSGACT="DEI" I PSJSYSU,'PSGPI,$P(XND,"^",9)'="I" S PSGACT=PSGACT_"V" + ;* S PSGACT="DEI" I PSJSYSU,'PSGDI,'PSGPI,$P(X,"^",9)'="I" S PSGACT=PSGACT_"V" + S XND2=$G(^PS(53.1,+PSGORD,.2)) I $P(XND2,"^",8),$P(XND,"^",9)="P" S PSGACT=$TR(PSGACT,"V") + I +PSJSYSU=3,$L($T(EN1^ORCFLAG)) S PSGACT=PSGACT_"G" + I $P($G(PSGRDTX),U,2)]"",'$D(^PS(53.1,+PSGORD,2.5)) S $P(^PS(53.1,+PSGORD,2.5),U,2)=$P(PSGRDTX,U,2) + Q +ACTO ; + S PSGACTO="" I $G(PSGACT)]"" F X=1:1:$L(PSGACT) S PSGACTO=PSGACTO_$S($E(PSGACT,X)="D":"DC",1:$E(PSGACT,X))_" " + S:PSGACTO]"" PSGACTO=$E(PSGACTO,1,$L(PSGACTO)-1) Q diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOE6.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOE6.m index 206ebe43..e97fa6ff 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOE6.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOE6.m @@ -1,89 +1,83 @@ -PSGOE6 ;BIR/CML3-ORDER ENTRY THROUGH OE/RR ;10 Mar 98 / 2:35 PM - ;;5.0; INPATIENT MEDICATIONS ;**3,7,39,45,65,58,81,156,134**;16 DEC 97;Build 124 - ; - ; Reference to ^PS(50.7 supported by DBIA #2180. - ; Reference to ^PS(51.1 is supported by DBIA #2177. - ; Reference to ^PS(51.2 is supported by DBIA #2178. - ; Reference to ^PS(55 is supported by DBIA #2191. - ; Reference to ^DD(53.1 is supported by DBIA #2256. - ; Reference to ^VA(200 is supported by DBIA #10060. - ; Reference to ^DICN is supported by DBIA #10009. - ; - K PSGFOK S F1=53.1,PSGPR=$S($D(PSGOERR):PSJORPV,1:PSGOEPR),PSGMR=$S($P(PSGNEDFD,"^",2):$P(PSGNEDFD,"^",2),1:PSGOEDMR),PSGSCH=$P(PSGNEDFD,"^",4),(PSGOROE1,PSGSI,SDT,PSGMRN,PSGSM,PSGHSM,PSGUD,PSGSD,PSGFD,PSGSI,PSGNEFD,PSGNESD)="" - S:PSGMR PSGMRN=$S('$P(PSGNEDFD,"^",2):"ORAL",'$D(^PS(51.2,PSGMR,0)):PSGMR,$P(^(0),"^")]"":$P(^(0),"^"),1:PSGMR) I PSGPR S PSGPRN=$P($G(^VA(200,PSGPR,0)),"^") S:PSGPRN="" PSGPRN=PSGPR - S PSGST=$S($P(PSGNEDFD,"^",3)]"":$P(PSGNEDFD,"^",3),1:"C") - ; Naked references in line below refer to ^PS(53.45,PSJSYSP - K ^PS(53.45,PSJSYSP,1),^(2) I PSGDRG S ^(2,0)="^53.4502P^"_PSGDRG_"^1",^(1,0)=PSGDRG,^PS(53.45,PSJSYSP,2,"B",PSGDRG,1)="" - ; -109 ; dosage ordered - W !,"DOSAGE ORDERED: ",$S(PSGDO]"":PSGDO_"// ",1:"") R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOROE1=1 G DONE - I X="" S X=PSGDO I X="" W $C(7)," (Required)" G 109 - S PSGF2=109 I X="@" W $C(7)," (Required)" G 109 - I X?1."?" S F1=53.1 D ENHLP^PSGOEM(53.1,109) G 109 - I $E(X)="^" D FF G:Y>0 @Y G 109 - I $E(X,$L(X))=" " F S X=$E(X,1,$L(X)-1) Q:$E(X,$L(X))'=" " - I $S(X?.E1C.E:1,$L(X)>20:1,X="":1,X["^":1,X?1.P:1,1:X=+X) W $C(7)," ",$S(X?1.P!(X=""):"(Required)",1:"??") S X="?" D ENHLP^PSGOEM(53.1,109) G 109 - S PSGDO=X,PSGFOK(109)="" - ; -3 ; med route - W !,"MED ROUTE: ",$S(PSGMR:PSGMRN_"// ",1:"") R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOROE1=1 G DONE - I X="",PSGMR S X=PSGMRN I PSGMR'=PSGMRN,$D(^PS(51.2,PSGMR,0)) W " "_$P(^(0),"^",3) S PSGFOK(3)="" G 26 - S PSGF2=3 I $S(X="@":1,X]"":0,1:'PSGMR) W $C(7)," (Required)" S X="?" D ENHLP^PSGOEM(53.1,3) G 3 - I X?1."?" D ENHLP^PSGOEM(53.1,3) - I $E(X)="^" D FF G:Y>0 @Y G 3 - K DIC S DIC="^PS(51.2,",DIC(0)="EMQZ",DIC("S")="I $P(^(0),""^"",4)" D ^DIC K DIC I Y'>0 G 3 - S PSGMR=+Y,PSGMRN=Y(0,0),PSGFOK(3)="" - ; -26 ; schedule - W !,"SCHEDULE: ",$S(PSGSCH]"":PSGSCH_"// ",1:"") R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOROE1=1 G DONE - S:X="" X=PSGSCH S PSGF2=26 ; I "@"[X W $C(7)," (Required)" S X="?" D ENHLP^PSGOEM(53.1,26) G 26 - I X?1."?" D ENHLP^PSGOEM(53.1,26) G 26 - I $E(X)="^" D FF G:Y>0 @Y G 26 - I X="" S (PSGS0XT,PSGS0Y,PSGST)="" - E D EN^PSGS0 I '$D(X) W $C(7)," ??" S X="?" D ENHLP^PSGOEM(53.1,26) G 26 - S PSGSCH=X,(PSGFOK(26),PSGST)="",PSGOES=1 S:PSGS0XT="O" $P(PSGNEDFD,"^",3)="O",PSGST="O" D ^PSGNE3 K PSGOES - ; -66 ; provider's comments - ; - ; -DONE ; - I PSGOROE1 K Y W $C(7)," ...order not entered..." - K F,F0,F1,PSGF2,F3,PSGFOK,SDT Q - ; -FF ; up-arrow to another field - S Y=-1 I '$D(PSGFOK) W $C(7)," ??" Q - S X=$E(X,2,99) I X=+X S Y=$S($D(PSGFOK(X)):X,1:-1) W " " W:Y>0 $$CODES2^PSIVUTL(53.1,X) W:Y'>0 $C(7),"??" Q - K DIC S DIC="^DD(53.1,",DIC(0)="QEM",DIC("S")="I $D(PSGFOK(+Y))" D ^DIC K DIC S Y=+Y - Q - ; -DEL ; - W !?3,"SURE YOU WANT TO DELETE" S %=0 D YN^DICN I %'=1 W " " - Q - ; -GTST(ON) ; Find schedule type for pending order. - N PD,PDAP,ST,X,ST1 S ST="" - S ST=$P($G(^PS(53.1,+ON,0)),"^",7) - I $P($G(^PS(53.1,+ON,0)),U,24)="R" D - .; naked ref below is from line above, ^PS(53.1,ON,0) - .S X=$P(^(0),U,25) S ST=$S(X["N"!(X["P"):$P($G(^PS(53.1,+X,0)),U,7),X["V":"C",1:$P($G(^PS(55,PSGP,5,+X,0)),U,7)) - .I ST]"" S (PSGOST,PSGST)=ST,PSGSTN=$$ENSTN^PSGMI(ST) Q - I ST'="" D - . S ST1="" - . S PD=+$G(^PS(53.1,+ON,.2)) S X=$G(^PS(50.7,PD,0)),ST1=$P(X,U,7) - . I $G(ST1)="R" S ST="R" - . K ST1 - I ST="" D - . ;PSJ*5*156 - Don't allow backdoor to override intended schedule type from CPRS unless the default - . ; schedule type (if any) is "Fill on Request". - . S PD=+$G(^PS(53.1,+ON,.2)) S X=$G(^PS(50.7,PD,0)),ST=$P(X,U,7) ;see if there is a default schedule type. - . I ST="R" Q ;Fill on Request default schedule type will override incoming schedule type from CPRS - . S ST="" ;Reset to null in case default schedule type other than Fill on Request is defined. - . D OTS I ST="O" Q - . I PSGSCH="ON CALL"!(PSGSCH="ONCALL")!(PSGSCH="ON-CALL") S ST="OC" Q - . I PSGSCH["PRN" S ST="P" Q - . S ST="C" - S (PSGOST,PSGST)=ST,PSGSTN=$$ENSTN^PSGMI(ST) - Q -OTS I PSGSCH]"" S X=+$O(^PS(51.1,"B",PSGSCH,0)) I $P($G(^PS(51.1,X,0)),"^",5)="O" S ST="O" Q - I PSGSCH="TODAY"!(PSGSCH="NOW")!(PSGSCH="STAT")!(PSGSCH="ONCE")!(PSGSCH="ONE TIME")!(PSGSCH="ONE-TIME")!(PSGSCH="ONETIME")!(PSGSCH="1TIME")!(PSGSCH="1 TIME")!(PSGSCH="1-TIME") S ST="O" - Q +PSGOE6 ;BIR/CML3-ORDER ENTRY THROUGH OE/RR ;10 Mar 98 / 2:35 PM + ;;5.0; INPATIENT MEDICATIONS ;**3,7,39,45,65,58,81,156**;16 DEC 97 + ; + ; Reference to ^PS(50.7 supported by DBIA #2180. + ; Reference to ^PS(51.1 is supported by DBIA #2177. + ; Reference to ^PS(51.2 is supported by DBIA #2178. + ; Reference to ^PS(55 is supported by DBIA #2191. + ; Reference to ^DD(53.1 is supported by DBIA #2256. + ; Reference to ^VA(200 is supported by DBIA #10060. + ; Reference to ^DICN is supported by DBIA #10009. + ; + K PSGFOK S F1=53.1,PSGPR=$S($D(PSGOERR):PSJORPV,1:PSGOEPR),PSGMR=$S($P(PSGNEDFD,"^",2):$P(PSGNEDFD,"^",2),1:PSGOEDMR),PSGSCH=$P(PSGNEDFD,"^",4),(PSGOROE1,PSGSI,SDT,PSGMRN,PSGSM,PSGHSM,PSGUD,PSGSD,PSGFD,PSGSI,PSGNEFD,PSGNESD)="" + S:PSGMR PSGMRN=$S('$P(PSGNEDFD,"^",2):"ORAL",'$D(^PS(51.2,PSGMR,0)):PSGMR,$P(^(0),"^")]"":$P(^(0),"^"),1:PSGMR) I PSGPR S PSGPRN=$P($G(^VA(200,PSGPR,0)),"^") S:PSGPRN="" PSGPRN=PSGPR + S PSGST=$S($P(PSGNEDFD,"^",3)]"":$P(PSGNEDFD,"^",3),1:"C") + K ^PS(53.45,PSJSYSP,1),^(2) I PSGDRG S ^(2,0)="^53.4502P^"_PSGDRG_"^1",^(1,0)=PSGDRG,^PS(53.45,PSJSYSP,2,"B",PSGDRG,1)="" + ; +109 ; dosage ordered + W !,"DOSAGE ORDERED: ",$S(PSGDO]"":PSGDO_"// ",1:"") R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOROE1=1 G DONE + I X="" S X=PSGDO I X="" W $C(7)," (Required)" G 109 + S PSGF2=109 I X="@" W $C(7)," (Required)" G 109 + I X?1."?" S F1=53.1 D ENHLP^PSGOEM(53.1,109) G 109 + I $E(X)="^" D FF G:Y>0 @Y G 109 + I $E(X,$L(X))=" " F S X=$E(X,1,$L(X)-1) Q:$E(X,$L(X))'=" " + I $S(X?.E1C.E:1,$L(X)>20:1,X="":1,X["^":1,X?1.P:1,1:X=+X) W $C(7)," ",$S(X?1.P!(X=""):"(Required)",1:"??") S X="?" D ENHLP^PSGOEM(53.1,109) G 109 + S PSGDO=X,PSGFOK(109)="" + ; +3 ; med route + W !,"MED ROUTE: ",$S(PSGMR:PSGMRN_"// ",1:"") R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOROE1=1 G DONE + I X="",PSGMR S X=PSGMRN I PSGMR'=PSGMRN,$D(^PS(51.2,PSGMR,0)) W " "_$P(^(0),"^",3) S PSGFOK(3)="" G 26 + S PSGF2=3 I $S(X="@":1,X]"":0,1:'PSGMR) W $C(7)," (Required)" S X="?" D ENHLP^PSGOEM(53.1,3) G 3 + I X?1."?" D ENHLP^PSGOEM(53.1,3) + I $E(X)="^" D FF G:Y>0 @Y G 3 + K DIC S DIC="^PS(51.2,",DIC(0)="EMQZ",DIC("S")="I $P(^(0),""^"",4)" D ^DIC K DIC I Y'>0 G 3 + S PSGMR=+Y,PSGMRN=Y(0,0),PSGFOK(3)="" + ; +26 ; schedule + W !,"SCHEDULE: ",$S(PSGSCH]"":PSGSCH_"// ",1:"") R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOROE1=1 G DONE + S:X="" X=PSGSCH S PSGF2=26 ; I "@"[X W $C(7)," (Required)" S X="?" D ENHLP^PSGOEM(53.1,26) G 26 + I X?1."?" D ENHLP^PSGOEM(53.1,26) G 26 + I $E(X)="^" D FF G:Y>0 @Y G 26 + I X="" S (PSGS0XT,PSGS0Y,PSGST)="" + E D EN^PSGS0 I '$D(X) W $C(7)," ??" S X="?" D ENHLP^PSGOEM(53.1,26) G 26 + S PSGSCH=X,(PSGFOK(26),PSGST)="",PSGOES=1 S:PSGS0XT="O" $P(PSGNEDFD,"^",3)="O",PSGST="O" D ^PSGNE3 K PSGOES + ; +66 ; provider's comments + ;S DA=PSJSYSP,DIE="^PS(53.45,",DR=4 D ^DIE K DA,DIE,DR + ;S PSGFOK(66)="",Y=1 + ; + ; +DONE ; + I PSGOROE1 K Y W $C(7)," ...order not entered..." + K F,F0,F1,PSGF2,F3,PSGFOK,SDT Q + ; +FF ; up-arrow to another field + S Y=-1 I '$D(PSGFOK) W $C(7)," ??" Q + S X=$E(X,2,99) I X=+X S Y=$S($D(PSGFOK(X)):X,1:-1) W " " W:Y>0 $$CODES2^PSIVUTL(53.1,X) W:Y'>0 $C(7),"??" Q + K DIC S DIC="^DD(53.1,",DIC(0)="QEM",DIC("S")="I $D(PSGFOK(+Y))" D ^DIC K DIC S Y=+Y + Q + ; +DEL ; + W !?3,"SURE YOU WANT TO DELETE" S %=0 D YN^DICN I %'=1 W " " + Q + ; +GTST(ON) ; Find schedule type for pending order. + N PD,PDAP,ST,X S ST="" I $P($G(^PS(53.1,+ON,0)),U,24)="R" D + .; naked ref below is from line above, ^PS(53.1,ON,0) + .S X=$P(^(0),U,25) S ST=$S(X["N"!(X["P"):$P($G(^PS(53.1,+X,0)),U,7),X["V":"C",1:$P($G(^PS(55,PSGP,5,+X,0)),U,7)) + .I ST]"" S (PSGOST,PSGST)=ST,PSGSTN=$$ENSTN^PSGMI(ST) Q + I ST="" D + . ;PSJ*5*156 - Don't allow backdoor to override intended schedule type from CPRS unless the default + . ; schedule type (if any) is "Fill on Request". + . S PD=+$G(^PS(53.1,+ON,.2)) S X=$G(^PS(50.7,PD,0)),ST=$P(X,U,7) ;see if there is a default schedule type. + . I ST="R" Q ;Fill on Request default schedule type will override incoming schedule type from CPRS + . S ST="" ;Reset to null in case default schedule type other than Fill on Request is defined. + . D OTS I ST="O" Q + . I PSGSCH="ON CALL"!(PSGSCH="ONCALL")!(PSGSCH="ON-CALL") S ST="OC" Q + . I PSGSCH["PRN" S ST="P" Q + . S ST="C" + S (PSGOST,PSGST)=ST,PSGSTN=$$ENSTN^PSGMI(ST) + Q +OTS I PSGSCH]"" S X=+$O(^PS(51.1,"B",PSGSCH,0)) I $P($G(^PS(51.1,X,0)),"^",5)="O" S ST="O" Q + I PSGSCH="TODAY"!(PSGSCH="NOW")!(PSGSCH="STAT")!(PSGSCH="ONCE")!(PSGSCH="ONE TIME")!(PSGSCH="ONE-TIME")!(PSGSCH="ONETIME")!(PSGSCH="1TIME")!(PSGSCH="1 TIME")!(PSGSCH="1-TIME") S ST="O" + Q diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOEC.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOEC.m index 7eff4f63..4fd76d09 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOEC.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOEC.m @@ -1,150 +1,110 @@ -PSGOEC ;BIR/CML3-CANCEL ORDERS ;02 Mar 99 / 9:29 AM - ;;5.0; INPATIENT MEDICATIONS ;**23,58,110,175,201,134**;16 DEC 97;Build 124 - ; - ; Reference to ^PS(55 is supported by DBIA# 2191. - ; Reference to ^PSSLOCK is supported by DBIA 2789. - ; -ENA ; all orders - D ENCV^PSGSETU Q:$D(XQUIT) S CF=$P(PSJSYSP0,U,5) N ND,ND1 S ND="$D(^PS(55,PSGP,5,PSGDA,4)),$P(^(4),U,12),$P(^(4),U,13)",ND1="$D(^PS(53.1,PSGDA,4)),$P(^(4),U,12),$P(^(4),U,13)" - F W !!,"Do you want to ",$S(CF:"discontinue",1:"mark for discontinuation")," all of this patient's orders" S %=1 D YN^DICN Q:% D ENCAM^PSGOEM - S PSGCF=0 Q:%<0 S PSGCF=1,T=$E("T",'PSJSYSU) G:%=1 ENCA F T=0:0 S T=$O(^PS(55,PSGP,5,"AUS",T)) Q:'T F PSGDA=0:0 S PSGDA=$O(^PS(55,PSGP,5,"AUS",T,PSGDA)) Q:'PSGDA I @ND Q - E F PSGDA=0:0 S PSGDA=$O(^PS(53.1,"AC",PSGP,PSGDA)) Q:'PSGDA I @ND1 Q - E G DONE - W !!,"SOME OR ALL OF THESE ORDERS HAVE" D ENUMK^PSGOEM Q:%'=1 - W !!,"...a few moments, please..." S PSGAL("C")=PSJSYSU*10+21400 - F T=PSGDT:0 S T=$O(^PS(55,PSGP,5,"AUS",T)) Q:'T F PSGDA=0:0 S PSGDA=$O(^PS(55,PSGP,5,"AUS",T,PSGDA)) Q:'PSGDA I @ND W "." D RS,^PSGAL5 - F PSGDA=0:0 S PSGDA=$O(^PS(53.1,"AC",PSGP,PSGDA)) Q:'PSGDA I @ND1 W "." D RS - W " . . . DONE!" G DONE -ENCA ; - D NOW^%DTC S (Q1,PSGDT)=+$E(%,1,12) F S Q1=$O(^PS(55,PSGP,5,"AUS",Q1)) Q:'Q1 F Q2=0:0 S Q2=$O(^PS(55,PSGP,5,"AUS",Q1,Q2)) Q:'Q2 I $P($G(^PS(55,PSGP,5,Q2,0)),"^",21) Q - E F Q2=0:0 S Q2=$O(^PS(53.1,"AC",PSGP,Q2)) Q:'Q2 I $P($G(^PS(53.1,Q2,0)),U,21) Q - I S PSJNOO=$$ENNOO^PSJUTL5("D") I PSJNOO<0!('$$REQPROV) D G DONE - .W !!,$C(7),"No changes made to this order." D PAUSE^VALM1 - S PSGALR=$S('$D(PSGALO):20,PSGALO?4N&($E(PSGALO)=1):10,1:20) I $P(PSJSYSP0,U,5) D ENHE^PSJADT0 S PSGOP=PSGP D ASET - F SD=PSGDT:0 S SD=$O(^PS(55,PSGP,5,"AUS",SD)) Q:'SD F PSGORD=0:0 S PSGORD=$O(^PS(55,PSGP,5,"AUS",SD,PSGORD)) Q:'PSGORD S PSGORD=+PSGORD_"A" D AC - D NSET S CF=$P(PSJSYSP0,U,5) F PSGORD=0:0 S PSGORD=$O(^PS(53.1,"AC",PSGP,PSGORD)) Q:'PSGORD S PSGORD=+PSGORD_"N" D NC - W " . . . DONE!" K PSGORD G DONE -ENO(PSGP,PSGORD) ; single order - I PSGSTAT="D" W !,"This order has already been DISCONTINUED." D PAUSE^VALM1 Q - S CF=$S($P(PSJSYSP0,U,5):1,PSGORD["U":0,1:($P($G(^PS(53.1,+PSGORD,0)),U,25)=""&($P($G(^(4)),U,7)=DUZ))) - S PSJCOM=+$S(PSGORD["U":$P($G(^PS(55,PSGP,5,+PSGORD,.2)),"^",8),1:$P($G(^PS(53.1,+PSGORD,.2)),"^",8)) - I 'CF,PSJCOM W !!,"This order is part of a complex order and CANNOT be marked for discontinuation." Q - I $$PNDRNOK(PSGORD) N PSJDCTYP S PSJDCTYP=$$PNDRNA(PSGORD) D:(PSJDCTYP=1!(PSJDCTYP=2)) PNDRN($G(PSJDCTYP),PSGORD) G DONE - I PSJCOM W !!,"This order is part of a complex order. If you discontinue this order the",!,"following orders will be discontinued too (unless the stop date has already",!,"been reached)." D CMPLX^PSJCOM1(PSGP,PSJCOM,PSGORD) - F W !!,"Do you want to ",$S(PSJCOM:"discontinue this series of complex orders",CF:"discontinue this order",1:"mark this order for discontinuation") S %=1 D YN^DICN Q:% D ENCOM^PSGOEM - I %<0 S VALMBCK="" Q - G:%=1 SOC I $S(PSGORD["U":$D(^PS(55,PSGP,5,+PSGORD,4)),1:$D(^PS(53.1,+PSGORD,4))),$P(^(4),U,12) W !!,"THIS ORDER HAS" - I D ENUMK^PSGOEM I %=1 W "..." K DA S:PSGORD["A" PSGAL("C")=PSJSYSU*10+21400,DA=+PSGORD,DA(1)=PSGP D RS,^PSGAL5:PSGORD["A" W " . . . DONE!" - G DONE -SOC ; - I 'CF,'$P($S(PSGORD["U":$G(^PS(55,PSGP,5,+PSGORD,0)),1:$G(^PS(53.1,+PSGORD,0))),U,21) W !!,"...one moment, please..." - E I CF,'($G(PSJDCTYP)=2) S PSJNOO=$$ENNOO^PSJUTL5("D") I PSJNOO<0 D ABORT^PSGOEE G DONE - ; prompt for requesting provider - I '($G(PSJDCTYP)=2) I CF,'$$REQPROV D ABORT^PSGOEE G DONE - K DA D NOW^%DTC S PSGDT=%,T=$E("T",'PSJSYSU),PSGALR=20,DA=+PSGORD,DA(1)=PSGP - I 'PSJCOM D - .I PSGORD["U" D ASET:CF,AC - .I PSGORD'["U" D NSET:CF,NC - I PSJCOM N COMFLG S COMFLG=0 D - . I PSGORD["P" Q:('$$LOCK^PSJOEA(PSGP,PSJCOM)) D - .. N O S O="" F S O=$O(^PS(53.1,"ACX",PSJCOM,O)) Q:O="" S (PSGORD,PSJORD)=O_"P" D NSET,NC - .I PSGORD["U" N O,OO S O=0,OO="" F S O=$O(^PS(55,"ACX",PSJCOM,O)) Q:'O F S OO=$O(^PS(55,"ACX",PSJCOM,O,OO)) Q:OO="" Q:COMFLG D - .. Q:OO=PSGORD I '$$LS^PSSLOCK(DFN,OO) S COMFLG=1 Q - I PSJCOM Q:COMFLG N O,OO S O=0,OO="" F S O=$O(^PS(55,"ACX",PSJCOM,O)) Q:'O F S OO=$O(^PS(55,"ACX",PSJCOM,O,OO)) Q:OO="" D - . I OO["V" S ON55=OO D D1^PSIVOPT2 S PSIVALT=1,PSIVALCK="STOP",PSIVREA="D",ON=ON55,P(3)=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,3) D - .. D LOG^PSIVORAL N PSJORD S PSJORD=ON55,P(3)=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,3),P("NAT")=PSJNOO D HL^PSIVORA - . I OO["U" N PSGORD,PSJORD S (PSGORD,PSJORD)=OO D ASET^PSGOEC,AC^PSGOEC - Q -D1 N %,DA,DIE,DIU,STP,NSTOP - D NOW^%DTC S NSTOP=+$E(%,1,12),STP=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,3),NSTOP=+$S(STP>NSTOP:NSTOP,1:STP),P(17)="D" - S DA(1)=DFN,DA=+ON55,DIE="^PS(55,"_DFN_",""IV"",",DR="109////"_NSTOP_$S('$P($G(^PS(55,DFN,"IV",+ON55,2)),U,7):";116////"_STP,1:"")_";100///D;.03////"_NSTOP,PSIVACT=1 D ^DIE - I $S($G(PSIVAC)="OD":0,$G(PSIVAC)'="AD":1,$G(PSGALO)<1060:0,1:$P($G(PSJSYSW0),U,15)) S X=$S($G(PSIVAC)="AD":1,1:2) D ENLBL^PSIVOPT(X,$S(X=1:+$G(PSGUOW),1:DUZ),DFN,3,+ON55,$E("AD",1,3-X)) - D:'$D(PSJIVORF) ORPARM^PSIVOREN Q:'PSJIVORF ;* S ORIFN=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,21) Q:'ORIFN - Q -OUT ; - W $S(PSJCOM:"...ORDER ",1:"...ORDERS "),$S(CF:"DISCONTINUED!",1:"MARKED!") S PSGCANFL=1 -DONE ; - K CF,DA,DIE,DP,DR,ORIFN,ORETURN,PSGAL,PSGALR,PSGDA,SD,ST,T,UCF,Y,PSJDCTYP Q -ASET ; - S DIE="^PS(55,"_PSGP_",5,",DR="28////"_$S($P($G(^PS(55,PSGP,5,+$G(PSJORD),0)),U,27)="E":"DE",$D(PSGEDIT):"DE",1:"D")_";Q;34////"_PSGDT_$S(T]"":";49////1",1:"") - Q -NSET ; - S DIE="^PS(53.1,",DR="28////"_$S($P($G(^PS(53.1,+$G(PSJORD),0)),U,27)="E":"DE",$D(PSGEDIT):"DE",1:"D")_$S(T]"":";42////1",1:"")_";25////"_PSGDT Q -AC ; - I 'CF K DA S $P(^PS(55,PSGP,5,+PSGORD,4),U,11,14)="^1^"_DUZ_U_PSGDT,PSGAL("C")=13040,DA=+PSGORD,DA(1)=PSGP D ^PSGAL5 - I 'CF,$D(PSJSYSO) S PSGORD=+PSGORD_"A",PSGPOSA="C",PSGPOSD=PSGDT D ENPOS^PSGVDS - Q:'CF K DA,ORIFN S PSGAL("C")=PSJSYSU*10+4000,DA=+PSGORD,DA(1)=PSGP D ^PSGAL5 S $P(^(2),U,3)=$P(^PS(55,PSGP,5,+PSGORD,2),U,4) D ^DIE S ^PS(55,"AUE",PSGP,+PSGORD)="" - I PSJSYSL K DA S $P(^PS(55,PSGP,5,+PSGORD,7),U,1,2)=PSGDT_U_$S($D(PSGEDIT):"DE",1:"D"),PSGTOL=2,PSGUOW=DUZ,PSGTOO=1,DA=+PSGORD,DA(1)=PSGP D ENL^PSGVDS - S ORIFN=$P($G(^PS(55,PSGP,5,+PSGORD,0)),U,21) D:ORIFN DCOR^PSGOECS - Q -NC ; - I 'CF S $P(^PS(53.1,+PSGORD,4),"^",11,14)="^1^"_DUZ_U_PSGDT - I 'CF,$D(PSJSYSO) S PSGORD=+PSGORD_"N",PSGPOSA="C",PSGPOSD=PSGDT D ENPOS^PSGVDS - Q:'CF S PSGSTAT=$P($G(^PS(53.1,+PSGORD,0)),U,9),PSGORIFN=$P($G(^(0)),U,21) - I PSGSTAT'="U" K DA,ORIFN S DA=+PSGORD D ^DIE I PSJSYSL,PSJSYSL<3,(PSGSTAT'="P") S $P(^PS(53.1,+PSGORD,7),U,1,2)=PSGDT_U_$S($D(PSGEDIT):"DE",1:"D"),PSGTOO=2,PSGUOW=DUZ,PSGTOL=2 D ENL^PSGVDS - I PSGSTAT="U" K DA S DA=+PSGORD,DIK="^PS(53.1," D ^DIK - I PSGORIFN S ORIFN=PSGORIFN D DCOR^PSGOECS - Q -T ; - F W !!,"Is this due to the patient being transferred" S %=2 D YN^DICN Q:% D ENCTM^PSGOEM1 - S T=$S(%<0:"^",1:$E("T",%=1)) Q -RS ; - ; naked ref below is from variable ND1, ^PS(53.1,PSGDA,4) - S $P(^(4),U,11,14)="^^^" Q -REQPROV() ; - I $G(PSJDCTYP)=2 Q 1 - K PSJDCPRV,DIC,DUOUT,DTOUT,Y - N PROVIDER,PROVNAME,RESULT,RSB S RESULT=0 - S PROVIDER=+$P($G(^PS(55,DFN,5.1)),"^",2),PROVNAME="" - I PROVIDER>0 D - .S DIC=200,DR="53.1;53.4",DIQ="RSB",DIQ(0)="I",DA=PROVIDER D EN^DIQ1 - .K DIC,DR,DA,DIQ - .I $G(RSB(200,PROVIDER,53.1,"I"))="1"&(($G(RSB(200,PROVIDER,53.4,"I"))="")!($G(RSB(200,PROVIDER,53.4,"I"))>DT)) D - ..S DIC=200,DA=PROVIDER,DR=".01",DIQ="RSB",DIQ(0)="E" D EN^DIQ1 - ..S PROVNAME=$G(RSB(200,PROVIDER,.01,"E")) K DA,DIQ,DR - K DIC S DIC=200,DIC(0)="AEMQZ" - S:PROVNAME]"" DIC("B")=PROVNAME - S DIC("A")="Requesting PROVIDER: " - S DIC("S")="I $D(^(""PS"")),^(""PS""),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)>DT)" D ^DIC K DIC - I +Y>0,'$D(DUOUT),'$D(DTOUT) S RESULT=1,PSJDCPRV=+Y - Q RESULT - ; -PNDRNA(ORDER) ; Ask Discontinue Pending Renewal only, or both Pending Renew and Renewed Order - ; Perform this action only for pending renewals - I '$G(ORDER)!'($G(ORDER)["P") Q 3 - ; Quit if original order is no longer active - N ORIGORD,ORIGSTOP S ORIGORD=$P($G(^PS(53.1,+ORDER,0)),"^",25) Q:'ORIGORD D I ORIGSTOP<$G(PSGDT) Q 1 - .S ORIGSTOP=$S(ORIGORD["U":$P($G(^PS(55,PSGP,5,+ORIGORD,2)),"^",4),ORIGORD["V":$P($G(^PS(55,PSGP,"IV",+ORIGORD,0)),"^",3),1:"") - N NDP2 - S NDP2=^PS(53.1,+ORDER,.2) S DRG=NDP2,DO=$P(DRG,"^",2) S DRG=$$ENPDN^PSGMI($P(DRG,"^")) - S ND2=^PS(53.1,+ORDER,2) S SCH=$P(ND2,"^"),START=$P(ND2,"^",2),START=$$FMTE^XLFDT(START,2) - W !!?5,DRG_" "_DO - W !?5,"This order has a pending status. If this pending order" - W !?5,"is discontinued, the original order may still be active." - S DIR("A")="Select order(s) to discontinue" - S DIR(0)="S^1:DC BOTH Orders;2:DC Pending Order;3:Cancel - No Action Taken" - S DIR("L",1)="1 - DC BOTH Orders" - S DIR("L",2)="2 - DC Pending Order" - S DIR("L",3)="3 - Cancel - No Action Taken" D ^DIR - ; Reverse order - Y=1 - Pending only Y=2:BOTH - S Y=$S(Y=1:2,Y=2:1,1:3) - Q Y - ; -PNDRN(PSJDCTYP,ORDER) ; Perform Discontinue action for Pending order only or both Pending and Renewed - ; Perform this action only for pending renewals - N PSGORD S PSGORD=ORDER - Q:'$G(PSGORD)!'($G(PSGORD)["P") - I PSJDCTYP=1 G SOC - I PSJDCTYP=2 S PSJDCTYP=1 D SOC Q:'$G(PSJDCTYP) D - .I ($G(PSJNOO)<0) Q - .N ND5310 S ND5310=$G(^PS(53.1,+PSGORD,0)) - .N PSGORD S PSGORD=$P(ND5310,"^",25) I PSGORD S PSJDCTYP=2 D SOC K PSJDCTYP - Q -PNDRNOK(ORDER) ; Execute DC Pending Renew if - ; 1) Renewal order is pending/non-verified, and - ; 2) Original order is not DC'd or Expired - Q:'$G(PSGORD)!'($G(PSGORD)["P") 0 - N ORIGORD,ORIGSTOP S ORIGORD=$P($G(^PS(53.1,+ORDER,0)),"^",25) Q:'ORIGORD 0 D I ORIGSTOP<$G(PSGDT) Q 0 - .S ORIGSTOP=$S(ORIGORD["U":$P($G(^PS(55,PSGP,5,+ORIGORD,2)),"^",4),ORIGORD["V":$P($G(^PS(55,PSGP,"IV",+ORIGORD,0)),"^",3),1:"") - Q:'($P($G(^PS(53.1,+PSGORD,0)),U,24)="R") 0 - Q 1 +PSGOEC ;BIR/CML3-CANCEL ORDERS ;02 Mar 99 / 9:29 AM + ;;5.0; INPATIENT MEDICATIONS ;**23,58,110,175**;16 DEC 97;Build 18 + ; + ; Reference to ^PS(55 is supported by DBIA# 2191. + ; Reference to ^PSSLOCK is supported by DBIA 2789. + ; +ENA ; all orders + D ENCV^PSGSETU Q:$D(XQUIT) S CF=$P(PSJSYSP0,U,5) N ND,ND1 S ND="$D(^PS(55,PSGP,5,PSGDA,4)),$P(^(4),U,12),$P(^(4),U,13)",ND1="$D(^PS(53.1,PSGDA,4)),$P(^(4),U,12),$P(^(4),U,13)" + F W !!,"Do you want to ",$S(CF:"discontinue",1:"mark for discontinuation")," all of this patient's orders" S %=1 D YN^DICN Q:% D ENCAM^PSGOEM + S PSGCF=0 Q:%<0 S PSGCF=1,T=$E("T",'PSJSYSU) G:%=1 ENCA F T=0:0 S T=$O(^PS(55,PSGP,5,"AUS",T)) Q:'T F PSGDA=0:0 S PSGDA=$O(^PS(55,PSGP,5,"AUS",T,PSGDA)) Q:'PSGDA I @ND Q + E F PSGDA=0:0 S PSGDA=$O(^PS(53.1,"AC",PSGP,PSGDA)) Q:'PSGDA I @ND1 Q + E G DONE + W !!,"SOME OR ALL OF THESE ORDERS HAVE" D ENUMK^PSGOEM Q:%'=1 + W !!,"...a few moments, please..." S PSGAL("C")=PSJSYSU*10+21400 + F T=PSGDT:0 S T=$O(^PS(55,PSGP,5,"AUS",T)) Q:'T F PSGDA=0:0 S PSGDA=$O(^PS(55,PSGP,5,"AUS",T,PSGDA)) Q:'PSGDA I @ND W "." D RS,^PSGAL5 + F PSGDA=0:0 S PSGDA=$O(^PS(53.1,"AC",PSGP,PSGDA)) Q:'PSGDA I @ND1 W "." D RS + W " . . . DONE!" G DONE +ENCA ; + D NOW^%DTC S (Q1,PSGDT)=+$E(%,1,12) F S Q1=$O(^PS(55,PSGP,5,"AUS",Q1)) Q:'Q1 F Q2=0:0 S Q2=$O(^PS(55,PSGP,5,"AUS",Q1,Q2)) Q:'Q2 I $P($G(^PS(55,PSGP,5,Q2,0)),"^",21) Q + E F Q2=0:0 S Q2=$O(^PS(53.1,"AC",PSGP,Q2)) Q:'Q2 I $P($G(^PS(53.1,Q2,0)),U,21) Q + I S PSJNOO=$$ENNOO^PSJUTL5("D") I PSJNOO<0!('$$REQPROV) D G DONE + .W !!,$C(7),"No changes made to this order." D PAUSE^VALM1 + S PSGALR=$S('$D(PSGALO):20,PSGALO?4N&($E(PSGALO)=1):10,1:20) I $P(PSJSYSP0,U,5) D ENHE^PSJADT0 S PSGOP=PSGP D ASET + F SD=PSGDT:0 S SD=$O(^PS(55,PSGP,5,"AUS",SD)) Q:'SD F PSGORD=0:0 S PSGORD=$O(^PS(55,PSGP,5,"AUS",SD,PSGORD)) Q:'PSGORD S PSGORD=+PSGORD_"A" D AC + D NSET S CF=$P(PSJSYSP0,U,5) F PSGORD=0:0 S PSGORD=$O(^PS(53.1,"AC",PSGP,PSGORD)) Q:'PSGORD S PSGORD=+PSGORD_"N" D NC + W " . . . DONE!" K PSGORD G DONE +ENO(PSGP,PSGORD) ; single order + I PSGSTAT="D" W !,"This order has already been DISCONTINUED." D PAUSE^VALM1 Q + S CF=$S($P(PSJSYSP0,U,5):1,PSGORD["U":0,1:($P($G(^PS(53.1,+PSGORD,0)),U,25)=""&($P($G(^(4)),U,7)=DUZ))) + S PSJCOM=+$S(PSGORD["U":$P($G(^PS(55,PSGP,5,+PSGORD,.2)),"^",8),1:$P($G(^PS(53.1,+PSGORD,.2)),"^",8)) + I 'CF,PSJCOM W !!,"This order is part of a complex order and CANNOT be marked for discontinuation." Q + I PSJCOM W !!,"This order is part of a complex order. If you discontinue this order the",!,"following orders will be discontinued too (unless the stop date has already",!,"been reached)." D CMPLX^PSJCOM1(PSGP,PSJCOM,PSGORD) + F W !!,"Do you want to ",$S(PSJCOM:"discontinue this series of complex orders",CF:"discontinue this order",1:"mark this order for discontinuation") S %=1 D YN^DICN Q:% D ENCOM^PSGOEM + I %<0 S VALMBCK="" Q + G:%=1 SOC I $S(PSGORD["U":$D(^PS(55,PSGP,5,+PSGORD,4)),1:$D(^PS(53.1,+PSGORD,4))),$P(^(4),U,12) W !!,"THIS ORDER HAS" + I D ENUMK^PSGOEM I %=1 W "..." K DA S:PSGORD["A" PSGAL("C")=PSJSYSU*10+21400,DA=+PSGORD,DA(1)=PSGP D RS,^PSGAL5:PSGORD["A" W " . . . DONE!" + G DONE +SOC ; + I 'CF,'$P($S(PSGORD["U":$G(^PS(55,PSGP,5,+PSGORD,0)),1:$G(^PS(53.1,+PSGORD,0))),U,21) W !!,"...one moment, please..." + E I CF S PSJNOO=$$ENNOO^PSJUTL5("D") I PSJNOO<0 D ABORT^PSGOEE G DONE + ; prompt for requesting provider + I CF,'$$REQPROV D ABORT^PSGOEE G DONE + K DA D NOW^%DTC S PSGDT=%,T=$E("T",'PSJSYSU),PSGALR=20,DA=+PSGORD,DA(1)=PSGP + I 'PSJCOM D + .I PSGORD["U" D ASET:CF,AC + .I PSGORD'["U" D NSET:CF,NC + I PSJCOM N COMFLG S COMFLG=0 D + . I PSGORD["P" Q:('$$LOCK^PSJOEA(PSGP,PSJCOM)) D + .. N O S O="" F S O=$O(^PS(53.1,"ACX",PSJCOM,O)) Q:O="" S (PSGORD,PSJORD)=O_"P" D NSET,NC + .I PSGORD["U" N O,OO S O=0,OO="" F S O=$O(^PS(55,"ACX",PSJCOM,O)) Q:'O F S OO=$O(^PS(55,"ACX",PSJCOM,O,OO)) Q:OO="" Q:COMFLG D + .. Q:OO=PSGORD I '$$LS^PSSLOCK(DFN,OO) S COMFLG=1 Q + I PSJCOM Q:COMFLG N O,OO S O=0,OO="" F S O=$O(^PS(55,"ACX",PSJCOM,O)) Q:'O F S OO=$O(^PS(55,"ACX",PSJCOM,O,OO)) Q:OO="" D + . I OO["V" S ON55=OO D D1^PSIVOPT2 S PSIVALT=1,PSIVALCK="STOP",PSIVREA="D",ON=ON55,P(3)=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,3) D + .. D LOG^PSIVORAL N PSJORD S PSJORD=ON55,P(3)=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,3),P("NAT")=PSJNOO D HL^PSIVORA + . I OO["U" N PSGORD,PSJORD S (PSGORD,PSJORD)=OO D ASET^PSGOEC,AC^PSGOEC + Q +D1 N %,DA,DIE,DIU,STP,NSTOP + D NOW^%DTC S NSTOP=+$E(%,1,12),STP=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,3),NSTOP=+$S(STP>NSTOP:NSTOP,1:STP),P(17)="D" + S DA(1)=DFN,DA=+ON55,DIE="^PS(55,"_DFN_",""IV"",",DR="109////"_NSTOP_$S('$P($G(^PS(55,DFN,"IV",+ON55,2)),U,7):";116////"_STP,1:"")_";100///D;.03////"_NSTOP,PSIVACT=1 D ^DIE + I $S($G(PSIVAC)="OD":0,$G(PSIVAC)'="AD":1,$G(PSGALO)<1060:0,1:$P($G(PSJSYSW0),U,15)) S X=$S($G(PSIVAC)="AD":1,1:2) D ENLBL^PSIVOPT(X,$S(X=1:+$G(PSGUOW),1:DUZ),DFN,3,+ON55,$E("AD",1,3-X)) + D:'$D(PSJIVORF) ORPARM^PSIVOREN Q:'PSJIVORF ;* S ORIFN=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,21) Q:'ORIFN + Q +OUT ; + W $S(PSJCOM:"...ORDER ",1:"...ORDERS "),$S(CF:"DISCONTINUED!",1:"MARKED!") S PSGCANFL=1 +DONE ; + K CF,DA,DIE,DP,DR,ORIFN,ORETURN,PSGAL,PSGALR,PSGDA,SD,ST,T,UCF,Y Q +ASET ; + S DIE="^PS(55,"_PSGP_",5,",DR="28////"_$S($P($G(^PS(55,PSGP,5,+$G(PSJORD),0)),U,27)="E":"DE",$D(PSGEDIT):"DE",1:"D")_";Q;34////"_PSGDT_$S(T]"":";49////1",1:"") + Q +NSET ; + S DIE="^PS(53.1,",DR="28////"_$S($P($G(^PS(53.1,+$G(PSJORD),0)),U,27)="E":"DE",$D(PSGEDIT):"DE",1:"D")_$S(T]"":";42////1",1:"")_";25////"_PSGDT Q +AC ; + I 'CF K DA S $P(^PS(55,PSGP,5,+PSGORD,4),U,11,14)="^1^"_DUZ_U_PSGDT,PSGAL("C")=13040,DA=+PSGORD,DA(1)=PSGP D ^PSGAL5 + I 'CF,$D(PSJSYSO) S PSGORD=+PSGORD_"A",PSGPOSA="C",PSGPOSD=PSGDT D ENPOS^PSGVDS + Q:'CF K DA,ORIFN S PSGAL("C")=PSJSYSU*10+4000,DA=+PSGORD,DA(1)=PSGP D ^PSGAL5 S $P(^(2),U,3)=$P(^PS(55,PSGP,5,+PSGORD,2),U,4) D ^DIE S ^PS(55,"AUE",PSGP,+PSGORD)="" + I PSJSYSL K DA S $P(^PS(55,PSGP,5,+PSGORD,7),U,1,2)=PSGDT_U_$S($D(PSGEDIT):"DE",1:"D"),PSGTOL=2,PSGUOW=DUZ,PSGTOO=1,DA=+PSGORD,DA(1)=PSGP D ENL^PSGVDS + S ORIFN=$P($G(^PS(55,PSGP,5,+PSGORD,0)),U,21) D:ORIFN DCOR^PSGOECS + Q +NC ; + I 'CF S $P(^PS(53.1,+PSGORD,4),"^",11,14)="^1^"_DUZ_U_PSGDT + I 'CF,$D(PSJSYSO) S PSGORD=+PSGORD_"N",PSGPOSA="C",PSGPOSD=PSGDT D ENPOS^PSGVDS + Q:'CF S PSGSTAT=$P($G(^PS(53.1,+PSGORD,0)),U,9),PSGORIFN=$P($G(^(0)),U,21) + I PSGSTAT'="U" K DA,ORIFN S DA=+PSGORD D ^DIE I PSJSYSL,PSJSYSL<3,(PSGSTAT'="P") S $P(^PS(53.1,+PSGORD,7),U,1,2)=PSGDT_U_$S($D(PSGEDIT):"DE",1:"D"),PSGTOO=2,PSGUOW=DUZ,PSGTOL=2 D ENL^PSGVDS + I PSGSTAT="U" K DA S DA=+PSGORD,DIK="^PS(53.1," D ^DIK + I PSGORIFN S ORIFN=PSGORIFN D DCOR^PSGOECS + Q +T ; + F W !!,"Is this due to the patient being transferred" S %=2 D YN^DICN Q:% D ENCTM^PSGOEM1 + S T=$S(%<0:"^",1:$E("T",%=1)) Q +RS ; + ; naked ref below is from variable ND1, ^PS(53.1,PSGDA,4) + S $P(^(4),U,11,14)="^^^" Q + ; +REQPROV() ; + K PSJDCPRV,DIC,DUOUT,DTOUT,Y + N PROVIDER,PROVNAME,RESULT,RSB S RESULT=0 + S PROVIDER=+$P($G(^PS(55,DFN,5.1)),"^",2),PROVNAME="" + I $G(PSJRQPND) S PROVIDER=0 + I PROVIDER>0 D + .S DIC=200,DR="53.1;53.4",DIQ="RSB",DIQ(0)="I",DA=PROVIDER D EN^DIQ1 + .K DIC,DR,DA,DIQ + .I $G(RSB(200,PROVIDER,53.1,"I"))="1"&(($G(RSB(200,PROVIDER,53.4,"I"))="")!($G(RSB(200,PROVIDER,53.4,"I"))>DT)) D + ..S DIC=200,DA=PROVIDER,DR=".01",DIQ="RSB",DIQ(0)="E" D EN^DIQ1 + ..S PROVNAME=$G(RSB(200,PROVIDER,.01,"E")) K DA,DIQ,DR + K DIC S DIC=200,DIC(0)="AEMQZ" + S:PROVNAME]"" DIC("B")=PROVNAME + S DIC("A")="Requesting PROVIDER: " + S DIC("S")="I $D(^(""PS"")),^(""PS""),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)>DT)" D ^DIC K DIC + I +Y>0,'$D(DUOUT),'$D(DTOUT) S RESULT=1,PSJDCPRV=+Y + Q RESULT diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOECS.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOECS.m index 8460f99c..63b334d7 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOECS.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOECS.m @@ -1,139 +1,127 @@ -PSGOECS ;BIR/CML3-CANCEL SELECTED ORDERS ;02 Mar 99 / 9:29 AM - ;;5.0; INPATIENT MEDICATIONS ;**23,29,44,58,81,110,134**;16 DEC 97;Build 124 - ; - ; Reference to FULL^VALM1 is supported by DBIA# 10116. - ; Reference to ^PS(55 is supported by DBIA# 2191. - ; Reference to ^PSSLOCK is supported by DBIA #2789. - ; -AM ; - W !,"...marking ",$P(X,U),"..." S $P(^PS(55,PSGP,5,DA,4),"^",11,14)="^1^"_DUZ_"^"_PSGDT,PSGAL("C")=13040 W "." D ^PSGAL5 W "." - I $D(PSJSYSO) S PSGORD=+PSGORD_"A",PSGPOSA="C",PSGPOSD=PSGDT D ENPOS^PSGVDS - Q - ; -NM ; - W !,"...marking ",$P(X,U),"..." S $P(^PS(53.1,DA,4),"^",11,14)="^1^"_DUZ_"^"_PSGDT W "." - I $D(PSJSYSO) S PSGORD=+PSGORD_"N",PSGPOSD=PSGDT,PSGPOSA="C" D ENPOS^PSGVDS - Q - ; -AC ; discontinue active order - K DA S DA(1)=PSGP,DA=+PSGORD - S X=$G(^PS(55,PSGP,5,DA,.2)) - I $P(X,U,4)="D" W !,$P($$DRUGNAME^PSJLMUTL(DFN,PSGORD),U,1),!,"NO ACTION WAS TAKEN ON DONE ORDER",!,$C(7) HANG 1 Q - NEW XX S XX=$P(^PS(55,PSGP,5,DA,0),U,9) - I $S(XX="E":1,XX="D":1,XX="DE":1,1:0) W !,$P($$DRUGNAME^PSJLMUTL(DFN,PSGORD),U,1),!,"NO ACTION WAS TAKEN ON "_$$CODES^PSIVUTL(XX,55.06,28)_" ORDER",!,$C(7) HANG 1 Q - S X=$$DRUGNAME^PSJLMUTL(PSGP,PSGORD) - I '$P(PSJSYSP0,"^",5) D AM Q - W !,"...discontinuing ",$P(X,U),"...",! S PSGAL("C")=PSJSYSU*10+4000 D ^PSGAL5 - S PSGALR=20,DIE="^PS(55,"_PSGP_",5,",DR="28////D;Q;34////"_PSGDT_$S(PSJSYSU:"",1:";49////1"),DP=55.06,$P(^(2),"^",3)=$P(^PS(55,PSGP,5,DA,2),"^",4) D ^DIE S ^PS(55,"AUE",PSGP,DA)="" - D EN1^PSJHL2(PSGP,"OD",PSGORD) S DA(1)=PSGP,DA=+PSGORD - I PSJSYSL S $P(^PS(55,PSGP,5,DA,7),"^",1,2)=PSGDT_"^D",PSGTOL=2,PSGUOW=DUZ,PSGTOO=1 D ENL^PSGVDS - Q - ; -NC ; discontinue non-verifed order - I $P($G(^PS(53.1,+PSGORD,0)),U,24)="R" S PSJDCTYP=$$PNDRNA^PSGOEC(PSGORD) I $G(PSJDCTYP)'=1 D PNDRN($G(PSJDCTYP)) Q -NC2 ; Called from PNDRN to discontinue both pending renewal and original order - K DA S DA=+PSGORD,X=$G(^PS(53.1,DA,.2)),X=$$DRUGNAME^PSJLMUTL(PSGP,PSGORD) - I $S($P(PSJSYSP0,"^",5):0,'$D(^PS(53.1,DA,4)):1,1:$P(^(4),"^",7)'=DUZ) D NM Q - W !,"...discontinuing ",$P(X,U),"...",! S DIE="^PS(53.1,",DR="28////D"_$S(PSJSYSU:"",1:";42////1") D ^DIE - D EN1^PSJHL2(PSGP,"OC",PSGORD) - S DA=+PSGORD I PSJSYSL,PSJSYSL<3 S $P(^PS(53.1,DA,7),"^",1,2)=PSGDT_"^D",PSGTOO=2,PSGUOW=DUZ,PSGTOL=2 D ENL^PSGVDS - I $G(PSJDCTYP) D UNL^PSSLOCK(DFN,PSGORD) - Q - ; -EN ; enter here - I $G(PSJIVPRF) D ^PSIVSPDC Q ;Use for Speed DC in IV Order Profile - D FULL^VALM1 -EN1 ; - S (PSGONC,PSGLMT)=PSJOCNT,PSGONW="C" D ENWO^PSGON I "^"[X K X G RESET - D NOW^%DTC S PSGDT=+$E(%,1,12) - W ! F PSGOECS=1:1:PSGODDD F PSGOECS1=1:1 S PSGOECS2=$P(PSGODDD(PSGOECS),",",PSGOECS1) Q:'PSGOECS2 D - .S PSGORD=^TMP("PSJON",$J,PSGOECS2) ; I $P($G(@($S((PSGORD["A")!(PSGORD["U"):"^PS(55,"_PSGP_",5,",(PSGORD["V"):"^PS(55,"_PSGP_",""IV"",",1:"^PS(53.1,")_(+PSGORD)_",0)")),"^",21) Q - S PSJNOO=$$ENNOO^PSJUTL5("D") G:PSJNOO<0 EN1 - ;Prompt for requesting provider - W ! I '$$REQPROV^PSGOEC G EN1 - W ! - ; - ;Replaced above line with block structure below. - N COMFLG,PSJCOM S (EXITLOOP,PSJCOM)=0 - F PSGOECS=1:1:PSGODDD D - .F PSGOECS1=1:1 D Q:EXITLOOP=1 - ..S PSGOECS2=$P(PSGODDD(PSGOECS),",",PSGOECS1) - ..I 'PSGOECS2 S EXITLOOP=1 Q - ..S (ON,PSGORD)=^TMP("PSJON",$J,PSGOECS2) - ..I PSGORD=+PSGORD D DCCOM Q - ..I '$$LS^PSSLOCK(DFN,PSGORD) D Q - ... W:PSGORD'["V" !,$P($$DRUGNAME^PSJLMUTL(DFN,PSGORD),"^",1),!,"NO ACTION WAS TAKEN",!,$C(7) HANG 1 Q - ... W ! I PSGORD["V" N PSJLINE S PSJLINE=1 D DSPLORDV^PSJLMUT1(PSGP,PSGORD) D W !,"NO ACTION WAS TAKEN",!,$C(7) HANG 1 - ....F X=0:0 S X=$O(PSJOC(ON,X)) Q:'X D - .....W !,$G(PSJOC(ON,X)) - ..D CHKCOM I COMFLG D - ... I PSGORD'["V" W !,$P($$DRUGNAME^PSJLMUTL(DFN,PSGORD),"^",1),!,"NO ACTION WAS TAKEN",!,$C(7) HANG 1 Q - ... W ! I PSGORD["V" N PSJLINE S PSJLINE=1 D DSPLORDV^PSJLMUT1(PSGP,PSGORD) D W !,"NO ACTION WAS TAKEN",!,$C(7) HANG 1 - ....F X=0:0 S X=$O(PSJOC(ON,X)) Q:'X D - .....W !,$G(PSJOC(ON,X)) - ..Q:PSJCOM - ..D:(PSGORD["U") AC - ..D:(PSGORD["P") NC - ..D:(PSGORD["V") SPDCIV^PSIVSPDC - ..; Call the unlock procedure - ..D UNL^PSSLOCK(DFN,PSGORD) - S X="" -RESET ; - I $G(PSGORD)["V" D INIT^PSJLMHED(3) S VALMBK="R" G DONE - D INIT^PSJLMHED(1) S VALMBCK="R" - ; -DONE ; - K DA,DIE,DP,DR,PSGAL,PSGALR,PSGLMT,PSGODDD,PSGOECS,PSGOECS1,PSGOECS2,PSGONW,PSGORD,PSGPOSA,PSGPOSD,PSGTOL,PSGTOO,PSGUOW,ORIFN,ORETURN,ORNATR - Q - ; -DCOR ; Create DC order/update stop date in OE/RR. - S PSOC=$S(PSGORD["P":"OC",PSGORD["N":"OC",1:"OD") - D EN1^PSJHL2(PSGP,PSOC,PSGORD) - Q - ; -ENOR ; - K DA S PSGEDIT=$S($D(PSGEDIT):PSGEDIT,1:"D"),CF=1,PSGALR=20,DA=+PSGORD,T="" I PSGORD'["U",(PSGORD'["O") D:CF NSET^PSGOEC D NC^PSGOEC D ENOR2 G DONE^PSGOEC - S DA(1)=PSGP D:CF ASET^PSGOEC D AC^PSGOEC - G DONE^PSGOEC - ; -ENOR2 ;Check to see if order being DC'd is a Pending Renewal and is being DC'd due to edit. - I PSGEDIT="DE",$P(^PS(53.1,+PSGORD,0),U,25),$P(^PS(53.1,+PSGORD,0),U,24)="R",PSGSD<$P($G(^PS(55,PSGP,5,+$P(^PS(53.1,+PSGORD,0),U,25),2)),U,4) D - .K DA,DR S DA(1)=PSGP,DA=+$P(^PS(53.1,+PSGORD,0),U,25),DIE="^PS(55,"_PSGP_",5,",DR="34////"_PSGSD_";25////"_$P($G(^PS(55,PSGP,5,+$P(^PS(53.1,+PSGORD,0),U,25),2)),U,4) - .D ^DIE,EN1^PSJHL2(PSGP,"XX",$P(^PS(53.1,+PSGORD,0),U,25)) - Q - ; -CHKCOM ;Check to see if order is part of complex order series. - S PSJCOM=$S(PSGORD["V":$P($G(^PS(55,PSGP,"IV",+PSGORD,.2)),U,8),PSGORD["U":$P($G(^PS(55,PSGP,5,+PSGORD,.2)),U,8),1:$P($G(^PS(53.1,+PSGORD,.2)),U,8)),COMFLG=0 - N PSJSTAT S PSJSTAT=$S(PSGORD["V":$P($G(^PS(55,PSGP,"IV",+PSGORD,0)),"^",17),PSGORD["U":$P($G(^PS(55,PSGP,5,+PSGORD,0)),"^",9),1:$P($G(^PS(53.1,+PSGORD,0)),"^",9)) - Q:'PSJCOM I "DE"[PSJSTAT Q - W ! I PSGORD["V" N PSJLINE S PSJLINE=1 D DSPLORDV^PSJLMUT1(PSGP,PSGORD) D - .F X=0:0 S X=$O(PSJOC(ON,X)) Q:'X D - ..W !,$G(PSJOC(ON,X)) - I PSGORD["U" W !,$P($$DRUGNAME^PSJLMUTL(PSGP,PSGORD),"^",1) D - .W !!,"is part of a complex order. If you discontinue this order the following orders",!,"will be discontinued too (unless the stop date has already been reached)." D CMPLX^PSJCOM1(PSGP,PSJCOM,PSGORD) - F W !!,"Do you want to discontinue this series of complex orders" S %=1 D YN^DICN Q:% - I %'=1 S COMFLG=1 Q - N O,OO S O=0,OO="" F S O=$O(^PS(55,"ACX",PSJCOM,O)) Q:'O F S OO=$O(^PS(55,"ACX",PSJCOM,O,OO)) Q:OO="" D Q:COMFLG - .Q:OO=PSGORD I '$$LS^PSSLOCK(DFN,OO) S COMFLG=1 Q - Q:COMFLG - N O,OO S O=0,OO="" F S O=$O(^PS(55,"ACX",PSJCOM,O)) Q:'O F S OO=$O(^PS(55,"ACX",PSJCOM,O,OO)) Q:OO="" D - .I (OO["U") N PSGORD S PSGORD=OO D AC - .I (OO["V") N PSGORD S (ON,PSGORD)=OO D SPDCIV^PSIVSPDC - .D UNL^PSSLOCK(DFN,PSGORD) - Q - ; -DCCOM ;DC pending/non-verified complex order - I '$$LOCK^PSJOEA(DFN,PSGORD) W !,"Order # ",PSGOECS2," could not be discontinued.",!,$C(7) HANG 1 Q - N PSGORD1 S PSGORD1=PSGORD - N PSJO S PSJO=0 F S PSJO=$O(^PS(53.1,"ACX",PSGORD1,PSJO)) Q:'PSJO S PSGORD=PSJO_"P" D NC - Q -PNDRN(PSJDCTYP) ; Discontinue both pending renewal and original order - N TMPORD S TMPORD=$G(PSGORD) - I PSJDCTYP=2 S PSJDCTYP=1 D NC2 Q:'$G(PSJDCTYP) D - .I ($G(PSJNOO)<0) Q - .N ND5310 S ND5310=$G(^PS(53.1,+PSGORD,0)) - .N PSGORD S PSGORD=$P(ND5310,"^",25) I PSGORD S PSJDCTYP=2 D - ..I '$$LS^PSSLOCK(DFN,PSGORD) K PSJDCTYP Q - ..D @$S(PSGORD["U":"AC",PSGORD["V":"SPDCIV^PSIVSPDC",1:"") - S PSGORD=TMPORD - Q +PSGOECS ;BIR/CML3-CANCEL SELECTED ORDERS ;02 Mar 99 / 9:29 AM + ;;5.0; INPATIENT MEDICATIONS ;**23,29,44,58,81,110**;16 DEC 97 + ; + ; Reference to FULL^VALM1 is supported by DBIA# 10116. + ; Reference to ^PS(55 is supported by DBIA# 2191. + ; Reference to ^PSSLOCK is supported by DBIA #2789. + ; +AM ; + W !,"...marking ",$P(X,U),"..." S $P(^PS(55,PSGP,5,DA,4),"^",11,14)="^1^"_DUZ_"^"_PSGDT,PSGAL("C")=13040 W "." D ^PSGAL5 W "." + I $D(PSJSYSO) S PSGORD=+PSGORD_"A",PSGPOSA="C",PSGPOSD=PSGDT D ENPOS^PSGVDS + Q + ; +NM ; + W !,"...marking ",$P(X,U),"..." S $P(^PS(53.1,DA,4),"^",11,14)="^1^"_DUZ_"^"_PSGDT W "." + I $D(PSJSYSO) S PSGORD=+PSGORD_"N",PSGPOSD=PSGDT,PSGPOSA="C" D ENPOS^PSGVDS + Q + ; +AC ; discontinue active order + K DA S DA(1)=PSGP,DA=+PSGORD + S X=$G(^PS(55,PSGP,5,DA,.2)) + I $P(X,U,4)="D" W !,$P($$DRUGNAME^PSJLMUTL(DFN,PSGORD),U,1),!,"NO ACTION WAS TAKEN ON DONE ORDER",!,$C(7) HANG 1 Q + NEW XX S XX=$P(^PS(55,PSGP,5,DA,0),U,9) + I $S(XX="E":1,XX="D":1,XX="DE":1,1:0) W !,$P($$DRUGNAME^PSJLMUTL(DFN,PSGORD),U,1),!,"NO ACTION WAS TAKEN ON "_$$CODES^PSIVUTL(XX,55.06,28)_" ORDER",!,$C(7) HANG 1 Q + S X=$$DRUGNAME^PSJLMUTL(PSGP,PSGORD) + I '$P(PSJSYSP0,"^",5) D AM Q + W !,"...discontinuing ",$P(X,U),"...",! S PSGAL("C")=PSJSYSU*10+4000 D ^PSGAL5 + S PSGALR=20,DIE="^PS(55,"_PSGP_",5,",DR="28////D;Q;34////"_PSGDT_$S(PSJSYSU:"",1:";49////1"),DP=55.06,$P(^(2),"^",3)=$P(^PS(55,PSGP,5,DA,2),"^",4) D ^DIE S ^PS(55,"AUE",PSGP,DA)="" + D EN1^PSJHL2(PSGP,"OD",PSGORD) S DA(1)=PSGP,DA=+PSGORD + I PSJSYSL S $P(^PS(55,PSGP,5,DA,7),"^",1,2)=PSGDT_"^D",PSGTOL=2,PSGUOW=DUZ,PSGTOO=1 D ENL^PSGVDS + Q + ; +NC ; discontinue non-verifed order + K DA S DA=+PSGORD,X=$G(^PS(53.1,DA,.2)),X=$$DRUGNAME^PSJLMUTL(PSGP,PSGORD) + I $S($P(PSJSYSP0,"^",5):0,'$D(^PS(53.1,DA,4)):1,1:$P(^(4),"^",7)'=DUZ) D NM Q + W !,"...discontinuing ",$P(X,U),"...",! S DIE="^PS(53.1,",DR="28////D"_$S(PSJSYSU:"",1:";42////1") D ^DIE + D EN1^PSJHL2(PSGP,"OC",PSGORD) + S DA=+PSGORD I PSJSYSL,PSJSYSL<3 S $P(^PS(53.1,DA,7),"^",1,2)=PSGDT_"^D",PSGTOO=2,PSGUOW=DUZ,PSGTOL=2 D ENL^PSGVDS + Q + ; +EN ; enter here + I $G(PSJIVPRF) D ^PSIVSPDC Q ;Use for Speed DC in IV Order Profile + D FULL^VALM1 +EN1 ; + S (PSGONC,PSGLMT)=PSJOCNT,PSGONW="C" D ENWO^PSGON I "^"[X K X G RESET + D NOW^%DTC S PSGDT=+$E(%,1,12) + W ! F PSGOECS=1:1:PSGODDD F PSGOECS1=1:1 S PSGOECS2=$P(PSGODDD(PSGOECS),",",PSGOECS1) Q:'PSGOECS2 D + .S PSGORD=^TMP("PSJON",$J,PSGOECS2) ; I $P($G(@($S((PSGORD["A")!(PSGORD["U"):"^PS(55,"_PSGP_",5,",(PSGORD["V"):"^PS(55,"_PSGP_",""IV"",",1:"^PS(53.1,")_(+PSGORD)_",0)")),"^",21) Q + S PSJNOO=$$ENNOO^PSJUTL5("D") G:PSJNOO<0 EN1 + ;Prompt for requesting provider + W ! I '$$REQPROV^PSGOEC G EN1 + W ! + ; + ;F PSGOECS=1:1:PSGODDD F PSGOECS1=1:1 S PSGOECS2=$P(PSGODDD(PSGOECS),",",PSGOECS1) Q:'PSGOECS2 S (ON,PSGORD)=^TMP("PSJON",$J,PSGOECS2) D:(PSGORD["U") AC D:(PSGORD["P") NC D:(PSGORD["V") SPDCIV^PSIVSPDC + ;Replaced above line with block structure below. + N COMFLG,PSJCOM S (EXITLOOP,PSJCOM)=0 + F PSGOECS=1:1:PSGODDD D + .F PSGOECS1=1:1 D Q:EXITLOOP=1 + ..S PSGOECS2=$P(PSGODDD(PSGOECS),",",PSGOECS1) + ..I 'PSGOECS2 S EXITLOOP=1 Q + ..S (ON,PSGORD)=^TMP("PSJON",$J,PSGOECS2) + ..I PSGORD=+PSGORD D DCCOM Q + ..I '$$LS^PSSLOCK(DFN,PSGORD) D Q + ... W:PSGORD'["V" !,$P($$DRUGNAME^PSJLMUTL(DFN,PSGORD),"^",1),!,"NO ACTION WAS TAKEN",!,$C(7) HANG 1 Q + ... W ! I PSGORD["V" N PSJLINE S PSJLINE=1 D DSPLORDV^PSJLMUT1(PSGP,PSGORD) D W !,"NO ACTION WAS TAKEN",!,$C(7) HANG 1 + ....F X=0:0 S X=$O(PSJOC(ON,X)) Q:'X D + .....W !,$G(PSJOC(ON,X)) + ..D CHKCOM I COMFLG D + ... I PSGORD'["V" W !,$P($$DRUGNAME^PSJLMUTL(DFN,PSGORD),"^",1),!,"NO ACTION WAS TAKEN",!,$C(7) HANG 1 Q + ... W ! I PSGORD["V" N PSJLINE S PSJLINE=1 D DSPLORDV^PSJLMUT1(PSGP,PSGORD) D W !,"NO ACTION WAS TAKEN",!,$C(7) HANG 1 + ....F X=0:0 S X=$O(PSJOC(ON,X)) Q:'X D + .....W !,$G(PSJOC(ON,X)) + ..Q:PSJCOM + ..D:(PSGORD["U") AC + ..D:(PSGORD["P") NC + ..D:(PSGORD["V") SPDCIV^PSIVSPDC + ..; Call the unlock procedure + ..D UNL^PSSLOCK(DFN,PSGORD) + S X="" +RESET ; + I $G(PSGORD)["V" D INIT^PSJLMHED(3) S VALMBK="R" G DONE + D INIT^PSJLMHED(1) S VALMBCK="R" + ; +DONE ; + K DA,DIE,DP,DR,PSGAL,PSGALR,PSGLMT,PSGODDD,PSGOECS,PSGOECS1,PSGOECS2,PSGONW,PSGORD,PSGPOSA,PSGPOSD,PSGTOL,PSGTOO,PSGUOW,ORIFN,ORETURN,ORNATR + Q + ; +DCOR ; Create DC order/update stop date in OE/RR. + S PSOC=$S(PSGORD["P":"OC",PSGORD["N":"OC",1:"OD") + D EN1^PSJHL2(PSGP,PSOC,PSGORD) + Q + ; +ENOR ; + K DA S PSGEDIT=$S($D(PSGEDIT):PSGEDIT,1:"D"),CF=1,PSGALR=20,DA=+PSGORD,T="" I PSGORD'["U",(PSGORD'["O") D:CF NSET^PSGOEC D NC^PSGOEC D ENOR2 G DONE^PSGOEC + S DA(1)=PSGP D:CF ASET^PSGOEC D AC^PSGOEC + G DONE^PSGOEC + ; +ENOR2 ;Check to see if order being DC'd is a Pending Renewal and is being DC'd due to edit. + I PSGEDIT="DE",$P(^PS(53.1,+PSGORD,0),U,25),$P(^PS(53.1,+PSGORD,0),U,24)="R",PSGSD<$P($G(^PS(55,PSGP,5,+$P(^PS(53.1,+PSGORD,0),U,25),2)),U,4) D + .K DA,DR S DA(1)=PSGP,DA=+$P(^PS(53.1,+PSGORD,0),U,25),DIE="^PS(55,"_PSGP_",5,",DR="34////"_PSGSD_";25////"_$P($G(^PS(55,PSGP,5,+$P(^PS(53.1,+PSGORD,0),U,25),2)),U,4) + .D ^DIE,EN1^PSJHL2(PSGP,"XX",$P(^PS(53.1,+PSGORD,0),U,25)) + Q + ; +CHKCOM ;Check to see if order is part of complex order series. + S PSJCOM=$S(PSGORD["V":$P($G(^PS(55,PSGP,"IV",+PSGORD,.2)),U,8),PSGORD["U":$P($G(^PS(55,PSGP,5,+PSGORD,.2)),U,8),1:$P($G(^PS(53.1,+PSGORD,.2)),U,8)),COMFLG=0 + N PSJSTAT S PSJSTAT=$S(PSGORD["V":$P($G(^PS(55,PSGP,"IV",+PSGORD,0)),"^",17),PSGORD["U":$P($G(^PS(55,PSGP,5,+PSGORD,0)),"^",9),1:$P($G(^PS(53.1,+PSGORD,0)),"^",9)) + Q:'PSJCOM I "DE"[PSJSTAT Q + W ! I PSGORD["V" N PSJLINE S PSJLINE=1 D DSPLORDV^PSJLMUT1(PSGP,PSGORD) D + .F X=0:0 S X=$O(PSJOC(ON,X)) Q:'X D + ..W !,$G(PSJOC(ON,X)) + I PSGORD["U" W !,$P($$DRUGNAME^PSJLMUTL(PSGP,PSGORD),"^",1) D + .W !!,"is part of a complex order. If you discontinue this order the following orders",!,"will be discontinued too (unless the stop date has already been reached)." D CMPLX^PSJCOM1(PSGP,PSJCOM,PSGORD) + F W !!,"Do you want to discontinue this series of complex orders" S %=1 D YN^DICN Q:% + I %'=1 S COMFLG=1 Q + N O,OO S O=0,OO="" F S O=$O(^PS(55,"ACX",PSJCOM,O)) Q:'O F S OO=$O(^PS(55,"ACX",PSJCOM,O,OO)) Q:OO="" D Q:COMFLG + .Q:OO=PSGORD I '$$LS^PSSLOCK(DFN,OO) S COMFLG=1 Q + Q:COMFLG + N O,OO S O=0,OO="" F S O=$O(^PS(55,"ACX",PSJCOM,O)) Q:'O F S OO=$O(^PS(55,"ACX",PSJCOM,O,OO)) Q:OO="" D + .I (OO["U") N PSGORD S PSGORD=OO D AC + .I (OO["V") N PSGORD S (ON,PSGORD)=OO D SPDCIV^PSIVSPDC + .D UNL^PSSLOCK(DFN,PSGORD) + Q + ; +DCCOM ;DC pending/non-verified complex order + I '$$LOCK^PSJOEA(DFN,PSGORD) W !,"Order # ",PSGOECS2," could not be discontinued.",!,$C(7) HANG 1 Q + N PSGORD1 S PSGORD1=PSGORD + N PSJO S PSJO=0 F S PSJO=$O(^PS(53.1,"ACX",PSGORD1,PSJO)) Q:'PSJO S PSGORD=PSJO_"P" D NC + Q diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOEF.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOEF.m index 665e7dbc..c9e30ef3 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOEF.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOEF.m @@ -1,149 +1,141 @@ -PSGOEF ;BIR/CML3-FINISH ORDERS ENTERED THROUGH OE/RR ;14 May 98 / 2:17 PM - ;;5.0; INPATIENT MEDICATIONS ;**7,30,29,35,39,47,50,56,80,116,110,111,133,153,134**;16 DEC 97;Build 124 - ; - ; Reference to ^PS(55 is supported by DBIA 2191 - ; Reference to ^PSDRUG( is supported by DBIA 2192 - ; Reference to DOSE^PSSORPH is supported by DBIA 3234. - ; -START ; - I '$D(^PS(53.1,+PSGORD)) W $C(7),!?3,"Cannot find this pending order (#",+PSGORD,")." Q - D NOW^%DTC S PSGDT=+$E(%,1,12) K PSGFDX,PSGEFN,PSGOEEF,PSGOES,PSGONF,PSGRDTX S PSGOES=1,(PSGOEF,PSGOEEF)=0,PSGOEEG=3 - I $D(PSJTUD) S PSGDO=$P($G(^PS(53.1,+PSGORD,.3)),U),(PSGPDRG,PSGPD)=PSJCOI,(PSGPDRGN,PSGPDN)=$$OINAME^PSJLMUTL(PSGPD) - I $P($G(^PS(53.1,+PSGORD,0)),U,24)'="R" S X=PSGSCH D EN^PSGORS0 D - . S:($D(X)&($P($G(^PS(53.1,+PSGORD,2)),"^",5)="")&($P($G(^PS(53.1,+PSGORD,0)),"^",24)="N")) PSGAT=PSGS0Y - . NEW PSJDOX,PSJDOSE,PSJPIECE,PSJUNIT,PSJX,X - . S X=$G(^PS(53.1,+PSGORD,1,1,0)) Q:'+X - . D DOSE^PSSORPH(.PSJDOX,+X,"U") - . I $S('$D(PSJDOX):1,1:+PSJDOX(1)=-1) Q - . S PSJPIECE=$S($P(PSJDOX(1),U)="":3,1:1) - . S X=^PS(53.1,+PSGORD,.2) - . S:PSJPIECE=3 PSJDOSE=$P(X,U,2) - . S:PSJPIECE=1 PSJDOSE=$P(X,U,5),PSJUNIT=$P(X,U,6) - . F X=0:0 S X=$O(PSJDOX(X)) Q:+$G(PSJX)!'X D - .. I PSJPIECE=3,($P(PSJDOX(X),U,3)'=PSJDOSE) Q - .. I PSJPIECE=1,($P(PSJDOX(X),U,1)_$P(PSJDOX(X),U,2)'=(PSJDOSE_PSJUNIT)) Q - .. S:+$P(PSJDOX(X),U,12) $P(^PS(53.45,PSJSYSP,2,1,0),U,2)=+$P(PSJDOX(X),U,12),PSJX=1 - I PSGEB'=PSGOPR F X=7,11 S Y=$T(@(3_X)),@("PSGEFN("_X_")="_$P(Y,";",7)),PSGOEEF(+$P(Y,";",3))="",PSGOEEF=PSGOEEF+1 - D GTST^PSGOE6(+PSGORD) - I $P($G(^PS(53.1,+PSGORD,0)),U,24)'="R" S PSGSD="" D:PSGS0Y]"" - .N PSJX S PSJX=$P($G(^PS(53.1,+PSGORD,0)),U,25) I PSJX="" Q - .I PSJX["U" S PSGSD=$P($G(^PS(55,DFN,5,+PSJX,2)),U,2) Q - .I PSJX["V" S PSGSD=$P($G(^PS(55,DFN,"IV",+PSJX,0)),U,2) Q - .I PSJX["P" S PSGSD=$P($G(^PS(53.1,+PSJX,2)),U,2) - S:PSGSD="" PSGSD=PSGLI - S PSGNEDFD=$$GTNEDFD^PSGOE7("U",+PSGPD) - S:$P($G(PSGNEDFD),U,3)="" $P(PSGNEDFD,U,3)=PSGST ; N PSGOEA S PSGOEA="R" - S (PSGNESD,PSGSD)=$$ENSD^PSGNE3(PSGSCH,PSGS0Y,PSGLI,PSGSD) - ;if this is a renewal order, ignore any 'requested start date' received. Use the system calculated start date. - I $P($G(^PS(53.1,+PSGORD,0)),U,24)'="R" D - . D REQDT^PSJLIVMD(PSGORD) - E D - . S X=$$DSTART^PSJDCU(DFN,$P(^PS(53.1,+PSGORD,0),U,25)) I X]"" S (PSGNESD,PSGSD)=X K PSGRSD - D ; Extend the Default Stop Date if needed for the first renewed order. - .N PSGOEAO,PSGWALLO - .I $P($G(^PS(53.1,+PSGORD,0)),U,24)="R" S PSGOEAO=PSGOEA,PSGOEA="R",PSGWALLO=$P(^PS(55,DFN,5.1),U) - .D ENFD^PSGNE3(PSGLI) S PSGFD=$S($G(PSGRDTX(+PSGORD,"PSGFD")):PSGRDTX(+PSGORD,"PSGFD"),1:PSGNEFD) - .I $P($G(^PS(53.1,+PSGORD,0)),U,24)="R" S PSGOEA=PSGOEAO,$P(^PS(55,DFN,5.1),U)=PSGWALLO - N DUR,PSGRNSD S PSGRNSD=+$$LASTREN^PSJLMPRI(DFN,PSGORD) I PSGRNSD S DUR=$$GETDUR^PSJLIVMD(DFN,PSGORD,"P",1) I DUR]"" D - . N DURMIN S DURMIN=$$DURMIN^PSJLIVMD(DUR) I DURMIN S PSGFD=$$FMADD^XLFDT(PSGRNSD,,,DURMIN) - S PSGOFD="",PSGSDN=$$ENDD^PSGMI(PSGSD)_U_$$ENDTC^PSGMI(PSGSD),PSGFDN=$$ENDD^PSGMI(PSGFD)_U_$$ENDTC^PSGMI(PSGFD) - S PSGLIN=$$ENDD^PSGMI(PSGLI)_U_$$ENDTC^PSGMI(PSGLI) - I '$O(^PS(53.45,PSJSYSP,2,0)) N DRG,DRGCNT S DRGCNT=0 D - .F X=0:0 S X=$O(^PSDRUG("ASP",+PSGPD,X)) Q:'X!(DRGCNT>1) S:$P($G(^PSDRUG(+X,2)),U,3)["U" DRGCNT=DRGCNT+1,DRG=+X - .I DRGCNT=1 K ^PS(53.45,PSJSYSP,2) S ^PS(53.45,PSJSYSP,2,1,0)=DRG_U_1,^PS(53.45,PSJSYSP,2,0)="^53.4502^1^1",PS(53.45,PSJSYSP,2,"B",+DRG,1)="" - Q -FINISH ; - ; force display of second screen if CPRS order checks exist - N NSFF,PSGOEF39 S NSFF=1 K PSJNSS - I $G(PSGORD),$D(PSGRDTX(+PSGORD)) D K PSGRDTX - . S:$G(PSGRDTX(+PSGORD,"PSGRSD")) PSGSD=PSGRDTX(+PSGORD,"PSGRSD") - . S:$G(PSGRDTX(+PSGORD,"PSGRFD")) PSGFD=$S($G(PSGRDTX(+PSGORD,"PSGRFD")):PSGRDTX(+PSGORD,"PSGRFD"),1:$G(PSGNEFD)) - N PSJCOM S PSJCOM=+$P($G(^PS(53.1,+PSGORD,.2)),"^",8) - I $O(^PS(53.1,+PSGORD,12,0))!$O(^PS(53.1,+PSGORD,10,0)) D - .Q:$G(PSJLMX)=1 ; there's no second screen to display - .S VALMBG=16 D RE^VALM4,PAUSE^VALM1 - D FULL^VALM1 - I $G(PSJPROT)=3,'$D(PSJTUD),'$$ENIVUD^PSGOEF1(PSGORD) Q - I $G(PSGOSCH)]"" D S:$G(PSGS0XT)'="" $P(^PS(53.1,+PSGORD,2),"^",6)=PSGS0XT - .N PSGOES,PSGS0Y,PSGSCH S X=PSGOSCH K:$G(PSJTUD) NSFF D ENOS^PSGS0 - .I '($G(PSGORD)["P"&($P($G(^PS(53.1,+PSGORD,0)),"^",24)="R")) I $G(X)]""&$G(PSGS0Y) S:$G(PSGAT)="" PSGAT=PSGS0Y - .I $G(PSJNSS) S PSGOSCH="" K PSJNSS - .I $G(PSGORD)["P",$G(PSGAT),$G(PSGS0Y),($G(PSGOSCH)]"") I PSGAT'=PSGS0Y D - ..S PSGNSTAT=1 W $C(7),!!,"PLEASE NOTE: This order's admin times (",PSGAT,")" - ..W !?13," do not match the ward times (",PSGS0Y,")" - ..W !?13," for this administration schedule (",PSGOSCH,")",! - ..S DIR(0)="EA",DIR("A")="Press Return to continue..." D ^DIR K DIR W ! - I $G(PSGS0XT)="" S $P(^PS(53.1,+PSGORD,2),"^",6)=$S($P($G(ZZND),"^",3)'="":$P(ZZND,"^",3),1:"") - S CHK=0 S:$P($G(^PS(53.1,+PSGORD,0)),U,24)'="R" PSGSI=$$ENPC^PSJUTL("U",+PSJSYSP,180,PSGSI) - I '$G(PSJTUD),$G(PSJNSS),($G(PSGOSCH)]"") D NSSCONT^PSGS0(PSGOSCH,PSGS0XT) K PSJNSS S PSGOSCH="" - S PSGOEFF=PSGOSCH=""+('$O(^PS(53.45,PSJSYSP,2,0))*10) - I PSGOEFF S X=$S(PSGOEFF#2:" a SCHEDULE",1:"")_$S(PSGOEFF=11:" and",1:"")_$S(PSGOEFF>9:" at least one DISPENSE DRUG",1:"") - I 'PSGOEFF I (($G(PSGS0XT)="D")&($G(PSGAT)="")) S X=" Admin Times",PSGOEFF=1,PSGOEF39=1 - I PSGOEFF,X]"" S X=X_" before it can be finished." - I PSGOEFF S CHK=1 W $C(7),!!,"PLEASE NOTE: This order must have" F Q=1:1:$L(X," ") S Y=$P(X," ",Q) W:$L(Y)+$X>78 ! W Y," " - I $G(PSGOEF39) S PSGOEE=0,PSGOEFF=0 D I 'PSGOEE D REFRESH^VALM G DONE - .S F1=53.1,MSG=0,Y=$T(39),@("PSGFN(39)="_$P(Y,";",7)),PSGOEEF(+$P(Y,";",3))=1,(PSGOEEF,PSGOEE)=1 W ! D @$P($T(39),";",3) S CHK=0 - I PSGOEFF=1 S F1=53.1,MSG=0,Y=$T(38),@("PSGFN(38)="_$P(Y,";",7)),PSGOEEF(+$P(Y,";",3))=1,(PSGOEE,PSGOEEF)=1 W ! D @$P($T(38),";",3) S CHK=0 G:'PSGOEE DONE - I PSGOEFF=11 S F1=53.1,MSG=0,Y=$T(32),@("PSGFN(32)="_$P(Y,";",7)),PSGOEEF(+$P(Y,";",3))=1,(PSGOEE,PSGOEEF)=1 W ! D @$P($T(32),";",3) D G:'PSGOEE DONE - .S F1=53.1,MSG=0,Y=$T(38),@("PSGFN(38)="_$P(Y,";",7)),PSGOEEF(+$P(Y,";",3))=1,(PSGOEE,PSGOEEF)=1 W ! D @$P($T(38),";",3) S CHK=0 - I PSGOEFF>9 S CHK=7 D ENDRG^PSGOEF1(+PSGPD,0) I CHK D ABORTACC Q - I 'PSGOEFF D OC531^PSGOESF ; check every dispense drug from CPRS - S VALMBG=1 - I 'PSGOEFF&($D(PSGORQF)) D RE^VALM4 Q - I $G(MSG) K DIR S DIR(0)="E" W !! D ^DIR - I PSGOEFF D:PSGST="" GTST^PSGOE6(+PSGORD) - S PSJLMFIN=1 - K PSJACEPT I $O(^PS(53.1,+PSGORD,12,0)) S PSJLMP2=1 - S PSGOEENO=0,PSGSTAT=$S($P(PSJSYSP0,U,9):"ACTIVE",1:"NON-VERIFIED") - NEW PSJDOSE,PSJDOX,PSJDSFLG - D DOSECHK^PSJDOSE - S:+$G(PSJDSFLG) VALMSG="Dosage Ordered & Dispense Drug are not compatible" - I PSGODO=PSGDO S PSGOEEF(109)="" - I PSGODO'=PSGDO S PSGOEENO=1,VALMSG="This change will cause a new order to be created " - D EN^VALM("PSJU LM ACCEPT") - I $G(PSJNSS) D S PSGOEEF(26)="" K PSJACEPT,PSJNSS - .K DIR S DIR(0)="FOA",DIR("A")="Invalid Schedule" D ^DIR K DIR - I $G(PSGS0XT)="D",'$G(PSGS0Y),'$G(PSGAT),((",P,R,")'[(","_$G(PSGST)_",")) D S PSGOEEF(39)="" K PSJACEPT - .K DIR S DIR(0)="FOA",DIR("A")=" WARNING - Admin times are required for DAY OF WEEK schedules " D ^DIR K DIR - I '$G(PSJACEPT) D ABORTACC Q - I $G(PSJRNF),$G(^PS(53.1,+PSGORD,4)) D - . W $C(7),!!,"ACCEPTING THIS ORDER WILL CHANGE THE STATUS TO ACTIVE." - . S DIR(0)="Y",DIR("A")="Do you wish to make this order Active",DIR("?",1)="Enter ""N"" if you wish to exit without Activating this order," - . S DIR("?")="or ""Y"" to continue with the Activation process." D ^DIR S:'Y Y=-1 K DIR - I $G(PSJRNF),$G(Y)=-1 S PSJACEPT=0 D ABORTACC Q - I $G(PSJRNF),$G(Y)=1 S PSGOEAV=1 - I PSGOEENO S PSJNOO=$$ENNOO^PSJUTL5("E"),PSJACEPT=$S(PSJNOO<0:0,1:1) -ACCEPT ; - S VALMBCK=$S($G(PSJACEPT):"Q",1:"R") - I '$G(PSJACEPT) D ABORTACC Q - K PSGOES,PSGRSD,PSGRSDN D:PSGOEENO NEW3^PSGOEE D:'PSGOEENO UPD^PSGOEF1 I $D(PSGOEF)!PSGOEENO S PSGCANFL=-1 - D DONE1^PSGOEE - D DONE - Q -BYPASS ; - S PSGCANFL=1 - ; -DONE ; - K CHK,DA,DIE,DR,DRG,MSG,Q1,Q2,PSGNSTAT ;PSGND,PSGOEE,PSGOEEF,PSGOEEND,PSGOEEG,PSGOEF,PSGOEFF,PSGOES,PSGOPD,PSGOPDN,PSGOPR,PSGOSCH,PSGPDRG,PSGDRGN,PSG0XT,PSGS0Y,OSGSD,Q1,Q2 - Q -ABORTACC ; Abort Accept process. - D ABORT^PSGOEE K PSGOEEF D GETUD^PSJLMGUD(PSGP,PSGORD),^PSGOEF,ENSFE^PSGOEE0(PSGP,PSGORD),INIT^PSJLMUDE(PSGP,PSGORD) S VALMBCK="R",PSGSD=PSGNESD,PSGFD=PSGNEFD Q - ; - ; -31 ;;101^PSGOE8;PSGOPD;PSGPD;101;1 -32 ;;109^PSGOE8;PSGODO;PSGDO;109;PSGODO]"" -33 ;;10^PSGOE81;PSGOSD;PSGSD;10;0 -34 ;;3^PSGOE8;PSGOMR;PSGMR;3;1 -35 ;;25^PSGOE81;PSGOFD;PSGFD;25;0 -36 ;;7^PSGOE8;PSGOST;PSGST;7;0 -37 ;;5^PSGOE82;PSGOSM;PSGSM;5;0 -38 ;;26^PSGOE8;PSGOSCH;PSGSCH;26;1 -39 ;;39^PSGOE81;PSGOAT;PSGAT;39;0 -310 ;;1^PSGOE82;PSGOPR;PSGPR;1;1 -311 ;;8^PSGOE81;PSGOSI;PSGSI;8;0 -312 ;;2^PSGOE82;;;2;0 -313 ;;40^PSGOE82;;;40;0 - ; -AH ; - W !!?2,"Answer 'YES' to accept this order as a NON-VERIFIED UNIT DOSE order. Answer",!,"'NO' to edit this order now. Enter '^' to BYPASS this order, leaving it as",!,"a PENDING INPATIENT order." - Q +PSGOEF ;BIR/CML3-FINISH ORDERS ENTERED THROUGH OE/RR ;14 May 98 / 2:17 PM + ;;5.0; INPATIENT MEDICATIONS ;**7,30,29,35,39,47,50,56,80,116,110,111,133,153**;16 DEC 97 + ; + ; Reference to ^PS(55 is supported by DBIA 2191 + ; Reference to ^PSDRUG( is supported by DBIA 2192 + ; Reference to DOSE^PSSORPH is supported by DBIA 3234. + ; +START ; + I '$D(^PS(53.1,+PSGORD)) W $C(7),!?3,"Cannot find this pending order (#",+PSGORD,")." Q + D NOW^%DTC S PSGDT=+$E(%,1,12) K PSGFDX,PSGEFN,PSGOEEF,PSGOES,PSGONF,PSGRDTX S PSGOES=1,(PSGOEF,PSGOEEF)=0,PSGOEEG=3 + I $D(PSJTUD) S PSGDO=$P($G(^PS(53.1,+PSGORD,.3)),U),(PSGPDRG,PSGPD)=PSJCOI,(PSGPDRGN,PSGPDN)=$$OINAME^PSJLMUTL(PSGPD) + I $P($G(^PS(53.1,+PSGORD,0)),U,24)'="R" S X=PSGSCH D EN^PSGORS0 S:$D(X) PSGAT=PSGS0Y D + . NEW PSJDOX,PSJDOSE,PSJPIECE,PSJUNIT,PSJX,X + . S X=$G(^PS(53.1,+PSGORD,1,1,0)) Q:'+X + . D DOSE^PSSORPH(.PSJDOX,+X,"U") + . I $S('$D(PSJDOX):1,1:+PSJDOX(1)=-1) Q + . S PSJPIECE=$S($P(PSJDOX(1),U)="":3,1:1) + . S X=^PS(53.1,+PSGORD,.2) + . S:PSJPIECE=3 PSJDOSE=$P(X,U,2) + . S:PSJPIECE=1 PSJDOSE=$P(X,U,5),PSJUNIT=$P(X,U,6) + . F X=0:0 S X=$O(PSJDOX(X)) Q:+$G(PSJX)!'X D + .. I PSJPIECE=3,($P(PSJDOX(X),U,3)'=PSJDOSE) Q + .. I PSJPIECE=1,($P(PSJDOX(X),U,1)_$P(PSJDOX(X),U,2)'=(PSJDOSE_PSJUNIT)) Q + .. S:+$P(PSJDOX(X),U,12) $P(^PS(53.45,PSJSYSP,2,1,0),U,2)=+$P(PSJDOX(X),U,12),PSJX=1 + I PSGEB'=PSGOPR F X=7,11 S Y=$T(@(3_X)),@("PSGEFN("_X_")="_$P(Y,";",7)),PSGOEEF(+$P(Y,";",3))="",PSGOEEF=PSGOEEF+1 + D GTST^PSGOE6(+PSGORD) + I $P($G(^PS(53.1,+PSGORD,0)),U,24)'="R" S PSGSD="" D:PSGS0Y]"" + .N PSJX S PSJX=$P($G(^PS(53.1,+PSGORD,0)),U,25) I PSJX="" Q + .I PSJX["U" S PSGSD=$P($G(^PS(55,DFN,5,+PSJX,2)),U,2) Q + .I PSJX["V" S PSGSD=$P($G(^PS(55,DFN,"IV",+PSJX,0)),U,2) Q + .I PSJX["P" S PSGSD=$P($G(^PS(53.1,+PSJX,2)),U,2) + S:PSGSD="" PSGSD=PSGLI + S PSGNEDFD=$$GTNEDFD^PSGOE7("U",+PSGPD) + S:$P($G(PSGNEDFD),U,3)="" $P(PSGNEDFD,U,3)=PSGST ; N PSGOEA S PSGOEA="R" + S (PSGNESD,PSGSD)=$$ENSD^PSGNE3(PSGSCH,PSGS0Y,PSGLI,PSGSD) + ;if this is a renewal order, ignore any 'requested start date' received. Use the system calculated start date. + I $P($G(^PS(53.1,+PSGORD,0)),U,24)'="R" D + . D REQDT^PSJLIVMD(PSGORD) + E D + . S X=$$DSTART^PSJDCU(DFN,$P(^PS(53.1,+PSGORD,0),U,25)) I X]"" S (PSGNESD,PSGSD)=X K PSGRSD + D ; Extend the Default Stop Date if needed for the first renewed order. + .N PSGOEAO,PSGWALLO + .I $P($G(^PS(53.1,+PSGORD,0)),U,24)="R" S PSGOEAO=PSGOEA,PSGOEA="R",PSGWALLO=$P(^PS(55,DFN,5.1),U) + .D ENFD^PSGNE3(PSGLI) S PSGFD=$S($G(PSGRDTX(+PSGORD,"PSGFD")):PSGRDTX(+PSGORD,"PSGFD"),1:PSGNEFD) + .I $P($G(^PS(53.1,+PSGORD,0)),U,24)="R" S PSGOEA=PSGOEAO,$P(^PS(55,DFN,5.1),U)=PSGWALLO + N DUR,PSGRNSD S PSGRNSD=+$$LASTREN^PSJLMPRI(DFN,PSGORD) I PSGRNSD S DUR=$$GETDUR^PSJLIVMD(DFN,PSGORD,"P",1) I DUR]"" D + . N DURMIN S DURMIN=$$DURMIN^PSJLIVMD(DUR) I DURMIN S PSGFD=$$FMADD^XLFDT(PSGRNSD,,,DURMIN) + S PSGOFD="",PSGSDN=$$ENDD^PSGMI(PSGSD)_U_$$ENDTC^PSGMI(PSGSD),PSGFDN=$$ENDD^PSGMI(PSGFD)_U_$$ENDTC^PSGMI(PSGFD) + S PSGLIN=$$ENDD^PSGMI(PSGLI)_U_$$ENDTC^PSGMI(PSGLI) + I '$O(^PS(53.45,PSJSYSP,2,0)) N DRG,DRGCNT S DRGCNT=0 D + .F X=0:0 S X=$O(^PSDRUG("ASP",+PSGPD,X)) Q:'X!(DRGCNT>1) S:$P($G(^PSDRUG(+X,2)),U,3)["U" DRGCNT=DRGCNT+1,DRG=+X + .I DRGCNT=1 K ^PS(53.45,PSJSYSP,2) S ^PS(53.45,PSJSYSP,2,1,0)=DRG_U_1,^PS(53.45,PSJSYSP,2,0)="^53.4502^1^1",PS(53.45,PSJSYSP,2,"B",+DRG,1)="" + Q +FINISH ; + ; force display of second screen if CPRS order checks exist + N NSFF,PSGOEF39 S NSFF=1 K PSJNSS + I $G(PSGORD),$D(PSGRDTX(+PSGORD)) D K PSGRDTX + . S:$G(PSGRDTX(+PSGORD,"PSGRSD")) PSGSD=PSGRDTX(+PSGORD,"PSGRSD") + . S:$G(PSGRDTX(+PSGORD,"PSGRFD")) PSGFD=$S($G(PSGRDTX(+PSGORD,"PSGRFD")):PSGRDTX(+PSGORD,"PSGRFD"),1:$G(PSGNEFD)) + N PSJCOM S PSJCOM=+$P($G(^PS(53.1,+PSGORD,.2)),"^",8) + I $O(^PS(53.1,+PSGORD,12,0))!$O(^PS(53.1,+PSGORD,10,0)) D + .Q:$G(PSJLMX)=1 ; there's no second screen to display + .S VALMBG=16 D RE^VALM4,PAUSE^VALM1 + D FULL^VALM1 + I $G(PSJPROT)=3,'$D(PSJTUD),'$$ENIVUD^PSGOEF1(PSGORD) Q + S CHK=0 S:$P($G(^PS(53.1,+PSGORD,0)),U,24)'="R" PSGSI=$$ENPC^PSJUTL("U",+PSJSYSP,180,PSGSI) + I $G(PSGOSCH)]"" D S:$G(PSGS0XT)'<0 $P(^PS(53.1,+PSGORD,2),"^",6)=PSGS0XT + .N PSGOES,PSGS0Y,PSGSCH S X=PSGOSCH K:$G(PSJTUD) NSFF D ENOS^PSGS0 I '($G(PSGORD)["P"&($P($G(^PS(53.1,+PSGORD,0)),"^",24)="R")) I $G(X)]""&$G(PSGS0Y) S PSGAT=PSGS0Y + .I $G(PSJNSS) S PSGOSCH="" K PSJNSS + I '$G(PSJTUD),$G(PSJNSS),($G(PSGOSCH)]"") D NSSCONT^PSGS0(PSGOSCH,PSGS0XT) K PSJNSS S PSGOSCH="" + S PSGOEFF=PSGOSCH=""+('$O(^PS(53.45,PSJSYSP,2,0))*10) + I PSGOEFF S X=$S(PSGOEFF#2:" a SCHEDULE",1:"")_$S(PSGOEFF=11:" and",1:"")_$S(PSGOEFF>9:" at least one DISPENSE DRUG",1:"") + I 'PSGOEFF I (($G(PSGS0XT)="D")&($G(PSGAT)="")) S X=" Admin Times",PSGOEFF=1,PSGOEF39=1 + I PSGOEFF,X]"" S X=X_" before it can be finished." + I PSGOEFF S CHK=1 W $C(7),!!,"PLEASE NOTE: This order must have" F Q=1:1:$L(X," ") S Y=$P(X," ",Q) W:$L(Y)+$X>78 ! W Y," " + I $G(PSGOEF39) S PSGOEE=0,PSGOEFF=0 D I 'PSGOEE D REFRESH^VALM G DONE + .S F1=53.1,MSG=0,Y=$T(39),@("PSGFN(39)="_$P(Y,";",7)),PSGOEEF(+$P(Y,";",3))=1,(PSGOEEF,PSGOEE)=1 W ! D @$P($T(39),";",3) S CHK=0 + I PSGOEFF=1 S F1=53.1,MSG=0,Y=$T(38),@("PSGFN(38)="_$P(Y,";",7)),PSGOEEF(+$P(Y,";",3))=1,(PSGOEE,PSGOEEF)=1 W ! D @$P($T(38),";",3) S CHK=0 G:'PSGOEE DONE + I PSGOEFF=11 S F1=53.1,MSG=0,Y=$T(32),@("PSGFN(32)="_$P(Y,";",7)),PSGOEEF(+$P(Y,";",3))=1,(PSGOEE,PSGOEEF)=1 W ! D @$P($T(32),";",3) D G:'PSGOEE DONE + .S F1=53.1,MSG=0,Y=$T(38),@("PSGFN(38)="_$P(Y,";",7)),PSGOEEF(+$P(Y,";",3))=1,(PSGOEE,PSGOEEF)=1 W ! D @$P($T(38),";",3) S CHK=0 + I PSGOEFF>9 S CHK=7 D ENDRG^PSGOEF1(+PSGPD,0) I CHK D ABORTACC Q + I 'PSGOEFF D OC531^PSGOESF ; check every dispense drug from CPRS + S VALMBG=1 + I 'PSGOEFF&($D(PSGORQF)) D RE^VALM4 Q + I $G(MSG) K DIR S DIR(0)="E" W !! D ^DIR + I PSGOEFF D:PSGST="" GTST^PSGOE6(+PSGORD) + S PSJLMFIN=1 + K PSJACEPT I $O(^PS(53.1,+PSGORD,12,0)) S PSJLMP2=1 + S PSGOEENO=0,PSGSTAT=$S($P(PSJSYSP0,U,9):"ACTIVE",1:"NON-VERIFIED") + NEW PSJDOSE,PSJDOX,PSJDSFLG + D DOSECHK^PSJDOSE + S:+$G(PSJDSFLG) VALMSG="Dosage Ordered & Dispense Drug are not compatible" + I PSGODO=PSGDO S PSGOEEF(109)="" + I PSGODO'=PSGDO S PSGOEENO=1,VALMSG="This change will cause a new order to be created " + D EN^VALM("PSJU LM ACCEPT") + I $G(PSJNSS) D S PSGOEEF(26)="" K PSJACEPT,PSJNSS + .K DIR S DIR(0)="FOA",DIR("A")="Invalid Schedule" D ^DIR K DIR + I $G(PSGS0XT)="D",'$G(PSGS0Y),'$G(PSGAT),((",P,R,")'[(","_$G(PSGST)_",")) D S PSGOEEF(39)="" K PSJACEPT + .K DIR S DIR(0)="FOA",DIR("A")=" WARNING - Admin times are required for DAY OF WEEK schedules " D ^DIR K DIR + I '$G(PSJACEPT) D ABORTACC Q + I $G(PSJRNF),$G(^PS(53.1,+PSGORD,4)) D + . W $C(7),!!,"ACCEPTING THIS ORDER WILL CHANGE THE STATUS TO ACTIVE." + . S DIR(0)="Y",DIR("A")="Do you wish to make this order Active",DIR("?",1)="Enter ""N"" if you wish to exit without Activating this order," + . S DIR("?")="or ""Y"" to continue with the Activation process." D ^DIR S:'Y Y=-1 K DIR + I $G(PSJRNF),$G(Y)=-1 S PSJACEPT=0 D ABORTACC Q + I $G(PSJRNF),$G(Y)=1 S PSGOEAV=1 + I PSGOEENO S PSJNOO=$$ENNOO^PSJUTL5("E"),PSJACEPT=$S(PSJNOO<0:0,1:1) +ACCEPT ; + S VALMBCK=$S($G(PSJACEPT):"Q",1:"R") + I '$G(PSJACEPT) D ABORTACC Q + K PSGOES,PSGRSD,PSGRSDN D:PSGOEENO NEW3^PSGOEE D:'PSGOEENO UPD^PSGOEF1 I $D(PSGOEF)!PSGOEENO S PSGCANFL=-1 + D DONE1^PSGOEE + D DONE + Q +BYPASS ; + S PSGCANFL=1 + ; +DONE ; + K CHK,DA,DIE,DR,DRG,MSG,Q1,Q2 ;PSGND,PSGOEE,PSGOEEF,PSGOEEND,PSGOEEG,PSGOEF,PSGOEFF,PSGOES,PSGOPD,PSGOPDN,PSGOPR,PSGOSCH,PSGPDRG,PSGDRGN,PSG0XT,PSGS0Y,OSGSD,Q1,Q2 + Q +ABORTACC ; Abort Accept process. + D ABORT^PSGOEE K PSGOEEF D GETUD^PSJLMGUD(PSGP,PSGORD),^PSGOEF,ENSFE^PSGOEE0(PSGP,PSGORD),INIT^PSJLMUDE(PSGP,PSGORD) S VALMBCK="R",PSGSD=PSGNESD,PSGFD=PSGNEFD Q + ; + ; +31 ;;101^PSGOE8;PSGOPD;PSGPD;101;1 +32 ;;109^PSGOE8;PSGODO;PSGDO;109;PSGODO]"" +33 ;;10^PSGOE81;PSGOSD;PSGSD;10;0 +34 ;;3^PSGOE8;PSGOMR;PSGMR;3;1 +35 ;;25^PSGOE81;PSGOFD;PSGFD;25;0 +36 ;;7^PSGOE8;PSGOST;PSGST;7;0 +37 ;;5^PSGOE82;PSGOSM;PSGSM;5;0 +38 ;;26^PSGOE8;PSGOSCH;PSGSCH;26;1 +39 ;;39^PSGOE81;PSGOAT;PSGAT;39;0 +310 ;;1^PSGOE82;PSGOPR;PSGPR;1;1 +311 ;;8^PSGOE81;PSGOSI;PSGSI;8;0 +312 ;;2^PSGOE82;;;2;0 +313 ;;40^PSGOE82;;;40;0 + ; +AH ; + W !!?2,"Answer 'YES' to accept this order as a NON-VERIFIED UNIT DOSE order. Answer",!,"'NO' to edit this order now. Enter '^' to BYPASS this order, leaving it as",!,"a PENDING INPATIENT order." + Q diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOT.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOT.m index 7410a03f..f7ffffed 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOT.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOT.m @@ -1,37 +1,39 @@ -PSGOT ;BIR/CML3-TRANSFERS DATA FROM 53.1 TO 55 ;24 SEP 97 / 7:54 AM - ;;5.0; INPATIENT MEDICATIONS ;**13,68,90,110,173,134**;16 DEC 97;Build 124 - ; - ; Reference to ^PS(55 supported by DBIA 2191. - ; -START ; get internal record number, lock record, and write - S ODA=+PSGORD S:$D(^PS(55,PSGP,0))[0 ^(0)=PSGP,^PS(55,"B",PSGP,PSGP)="",$P(^PS(55,0),U,3,4)=PSGP_U_($P($G(^PS(55,0)),U,4)+1) F L +^PS(55,PSGP,5,0):1 I Q - S ZND=$G(^PS(55,PSGP,5,0)) S:ZND="" ZND="^55.06IA" F DA=$P(ZND,"^",3)+1:1 I '$D(^PS(55,PSGP,5,DA)),'$D(^("B",DA)) L +^PS(55,PSGP,5,DA):1 I S $P(ZND,"^",3)=DA,$P(ZND,"^",4)=$P(ZND,"^",4)+1,^PS(55,PSGP,5,0)=ZND Q - L -^PS(55,PSGP,5,0) S ND0=^PS(53.1,ODA,0),$P(ND0,"^",23)=PSJPWD,^PS(55,PSGP,5,DA,0)=ND0 - S (ND1,^PS(55,PSGP,5,DA,.2))=$G(^PS(53.1,ODA,.2)),^PS(55,PSGP,5,DA,.3)=$G(^PS(53.1,ODA,.3)),(ND2,^PS(55,PSGP,5,DA,2))=^PS(53.1,ODA,2),^PS(55,PSGP,5,DA,4)=$G(^PS(53.1,ODA,4)),^PS(55,"AUD",+$P(ND2,"^",4),PSGP,DA)="" - S X=^PS(55,PSGP,0) I $P(X,"^",7)="" S $P(X,"^",7)=$P($P(ND0,"^",16),"."),$P(X,"^",8)="A",^(0)=X - I $P($G(^PS(55,PSGP,5,DA,2)),"^",6)="" S $P(^PS(55,PSGP,5,DA,2),"^",6)=$S($G(PSGS0XT)'="":PSGS0XT,$P($G(ZZND),"^",3)'="":$P(ZZND,"^",3),1:""),$P(^PS(53.1,ODA,2),"^",6)=$P(^PS(55,PSGP,5,DA,2),"^",6) - F X=6,7,13 I $D(^PS(53.1,ODA,X)) S ^PS(55,PSGP,5,DA,X)=^(X) - I $D(^PS(53.1,ODA,"DSS")) S ^PS(55,PSGP,5,DA,8)=^("DSS") - I $O(^PS(53.1,ODA,1,0)) S (C,X)=0 F S X=$O(^PS(53.1,ODA,1,X)) Q:'X S:$D(^(X,0)) C=C+1,^PS(55,PSGP,5,DA,1,C,0)=^(0),^PS(55,PSGP,5,DA,1,"B",+$P($G(^(0)),U),C)="" - I $O(^PS(53.1,ODA,1,0)) S ^PS(55,PSGP,5,DA,1,0)="^55.07P^"_C_"^"_C - F X=3,12 D S ^PS(55,PSGP,5,DA,X,0)="^55.0"_$S(X=3:8,1:612)_U_CNT_U_CNT - .S CNT=0 F C=0:0 S C=$O(^PS(53.1,ODA,X,C)) Q:'C I $D(^(C,0)) S ^PS(55,PSGP,5,DA,X,C,0)=^(0),CNT=CNT+1 - S $P(^PS(53.1,ODA,0),"^",19)=DA -CR ; set x-refs - N A - I $D(^PS(55,PSGP,5.1)),$P(^(5.1),"^",6) S X=$P(^(5.1),"^",6) I $P(ND2,"^",3),$P(ND2,"^",6)'>X S $P(^(5.1),"^",6)=$P(ND2,"^",3) - S ^PS(55,PSGP,5,"B",+ODA,DA)="",^PS(55,PSGP,5,"AU",$P(ND0,"^",7),+$P(ND2,"^",4),DA)="" - S ^PS(55,PSGP,5,"AUS",+$P(ND2,"^",4),DA)="" - S ^PS(55,PSGP,5,"C",+ND1,DA)="",^PS(55,"AUE",PSGP,DA)="" - S ^PS(55,"AUDS",+$P(ND2,"^",2),PSGP,DA)="" - I $D(^PS(55,PSGP,5,DA,8)) S A=^(8),^PS(55,"AUDC",+$P(ND2,"^",4),+A,PSGP,DA)="" - I $$PATCH^XPDUTL("PXRM*1.5*12") S X(1)=+$P(ND2,"^",2),X(2)=+$P(ND2,"^",4),DA(1)=PSGP D SPSPA^PSJXRFS(.X,.DA,"UD") - K DIK S DA(1)=PSGP S DIK="^PS(55,"_DA(1)_",5,",DIK(1)=125 D EN1^DIK K DIK - S PSGTOL=2,PSGTOO=1 F PSGUOW=0:0 S PSGUOW=$O(^PS(53.41,2,1,PSGUOW)) Q:'PSGUOW I $D(^(PSGUOW,1,PSGP,1,2,1,ODA)) K ^(ODA) D ENL^PSGVDS -DONE I $D(PSGOE2),PSGOE2]"",$D(^TMP("PSJON",$J,PSGOE2)) S ^(PSGOE2)=DA_"U" - S PSGODA=ODA,PSGORD=DA_"U" - S PSGNODE=$G(^PS(55,PSGP,5,DA,0)),PSG25=$P(PSGNODE,"^",25),PSG26=$P(PSGNODE,"^",26) - I PSG25 S X=$S(PSG25["V":"^PS(55,"_PSGP_",""IV"",",PSG25["U"!(PSG25["A"):"^PS(55,"_PSGP_",5,",1:"^PS(53.1,")_+PSG25_","_$E("02",PSG25["V"+1)_")" I $D(@X) S $P(@X,"^",$S(PSG25["V":6,1:26))=DA_"U" - I $P(PSGNODE,"^",26),$P(PSGNODE,"^",26)'["V",$D(^PS(55,PSGP,5,+$P(PSGNODE,"^",26),0)) S $P(^(0),"^",25)=DA_"U" - F Q=0:0 S Q=$O(^PS(53.44,Q)) Q:'Q I $D(^(Q,1,PSGP,ODA,0)) S $P(^(0),"^",2)=DA - L -^PS(53.1,ODA) L -^PS(55,DFN,5,+PSGORD) K CNT,ND,ODA,XX,ZND Q +PSGOT ;BIR/CML3-TRANSFERS DATA FROM 53.1 TO 55 ;24 SEP 97 / 7:54 AM + ;;5.0; INPATIENT MEDICATIONS ;**13,68,90,110,173**;16 DEC 97;Build 4 + ; + ; Reference to ^PS(55 supported by DBIA 2191. + ; +START ; get internal record number, lock record, and write + S ODA=+PSGORD S:$D(^PS(55,PSGP,0))[0 ^(0)=PSGP,^PS(55,"B",PSGP,PSGP)="",$P(^PS(55,0),U,3,4)=PSGP_U_($P($G(^PS(55,0)),U,4)+1) F L +^PS(55,PSGP,5,0):1 I Q + S ZND=$G(^PS(55,PSGP,5,0)) S:ZND="" ZND="^55.06IA" F DA=$P(ZND,"^",3)+1:1 I '$D(^PS(55,PSGP,5,DA)),'$D(^("B",DA)) L +^PS(55,PSGP,5,DA):1 I S $P(ZND,"^",3)=DA,$P(ZND,"^",4)=$P(ZND,"^",4)+1,^PS(55,PSGP,5,0)=ZND Q + L -^PS(55,PSGP,5,0) S ND0=^PS(53.1,ODA,0),$P(ND0,"^",23)=PSJPWD,^PS(55,PSGP,5,DA,0)=ND0 + S (ND1,^PS(55,PSGP,5,DA,.2))=$G(^PS(53.1,ODA,.2)),^PS(55,PSGP,5,DA,.3)=$G(^PS(53.1,ODA,.3)),(ND2,^PS(55,PSGP,5,DA,2))=^PS(53.1,ODA,2),^PS(55,PSGP,5,DA,4)=$G(^PS(53.1,ODA,4)),^PS(55,"AUD",+$P(ND2,"^",4),PSGP,DA)="" + S X=^PS(55,PSGP,0) I $P(X,"^",7)="" S $P(X,"^",7)=$P($P(ND0,"^",16),"."),$P(X,"^",8)="A",^(0)=X + F X=6,7,13 I $D(^PS(53.1,ODA,X)) S ^PS(55,PSGP,5,DA,X)=^(X) + I $D(^PS(53.1,ODA,"DSS")) S ^PS(55,PSGP,5,DA,8)=^("DSS") + I $O(^PS(53.1,ODA,1,0)) S (C,X)=0 F S X=$O(^PS(53.1,ODA,1,X)) Q:'X S:$D(^(X,0)) C=C+1,^PS(55,PSGP,5,DA,1,C,0)=^(0),^PS(55,PSGP,5,DA,1,"B",+$P($G(^(0)),U),C)="" + ;F C=0:0 S C=$O(^PS(55,PSGP,5,DA,1,C)) Q:'C S X=+$G(^(C,0)) S:X ^PS(55,PSGP,5,DA,1,"B",X,C)="" + I $O(^PS(53.1,ODA,1,0)) S ^PS(55,PSGP,5,DA,1,0)="^55.07P^"_C_"^"_C + F X=3,12 D S ^PS(55,PSGP,5,DA,X,0)="^55.0"_$S(X=3:8,1:612)_U_CNT_U_CNT + .S CNT=0 F C=0:0 S C=$O(^PS(53.1,ODA,X,C)) Q:'C I $D(^(C,0)) S ^PS(55,PSGP,5,DA,X,C,0)=^(0),CNT=CNT+1 + ;F X=3,12 I $O(^PS(53.1,ODA,X,0)) S ^PS(55,PSGP,5,DA,X,0)=^(0) F C=0:0 S C=$O(^PS(53.1,ODA,X,C)) Q:'C I $D(^(C,0)) S ^PS(55,PSGP,5,DA,X,C,0)=^(0) + S $P(^PS(53.1,ODA,0),"^",19)=DA +CR ; set x-refs + N A + I $D(^PS(55,PSGP,5.1)),$P(^(5.1),"^",6) S X=$P(^(5.1),"^",6) I $P(ND2,"^",3),$P(ND2,"^",6)'>X S $P(^(5.1),"^",6)=$P(ND2,"^",3) + S ^PS(55,PSGP,5,"B",+ODA,DA)="",^PS(55,PSGP,5,"AU",$P(ND0,"^",7),+$P(ND2,"^",4),DA)="" + S ^PS(55,PSGP,5,"AUS",+$P(ND2,"^",4),DA)="" + S ^PS(55,PSGP,5,"C",+ND1,DA)="",^PS(55,"AUE",PSGP,DA)="" + S ^PS(55,"AUDS",+$P(ND2,"^",2),PSGP,DA)="" + I $D(^PS(55,PSGP,5,DA,8)) S A=^(8),^PS(55,"AUDC",+$P(ND2,"^",4),+A,PSGP,DA)="" + I $$PATCH^XPDUTL("PXRM*1.5*12") S X(1)=+$P(ND2,"^",2),X(2)=+$P(ND2,"^",4),DA(1)=PSGP D SPSPA^PSJXRFS(.X,.DA,"UD") + K DIK S DA(1)=PSGP S DIK="^PS(55,"_DA(1)_",5,",DIK(1)=125 D EN1^DIK K DIK + S PSGTOL=2,PSGTOO=1 F PSGUOW=0:0 S PSGUOW=$O(^PS(53.41,2,1,PSGUOW)) Q:'PSGUOW I $D(^(PSGUOW,1,PSGP,1,2,1,ODA)) K ^(ODA) D ENL^PSGVDS +DONE I $D(PSGOE2),PSGOE2]"",$D(^TMP("PSJON",$J,PSGOE2)) S ^(PSGOE2)=DA_"U" + S PSGODA=ODA,PSGORD=DA_"U" + S PSGNODE=$G(^PS(55,PSGP,5,DA,0)),PSG25=$P(PSGNODE,"^",25),PSG26=$P(PSGNODE,"^",26) + I PSG25 S X=$S(PSG25["V":"^PS(55,"_PSGP_",""IV"",",PSG25["U"!(PSG25["A"):"^PS(55,"_PSGP_",5,",1:"^PS(53.1,")_+PSG25_","_$E("02",PSG25["V"+1)_")" I $D(@X) S $P(@X,"^",$S(PSG25["V":6,1:26))=DA_"U" + I $P(PSGNODE,"^",26),$P(PSGNODE,"^",26)'["V",$D(^PS(55,PSGP,5,+$P(PSGNODE,"^",26),0)) S $P(^(0),"^",25)=DA_"U" + ;I $P(PSGNODE,"^",21) S X=$O(^ORD(101,"B","PS EVSEND OR",0))_";ORD(101,",PSOC="SC",PSJORDER=$$ORDER^PSJHLU(PSGORD) D EN1^XQOR:X K X + F Q=0:0 S Q=$O(^PS(53.44,Q)) Q:'Q I $D(^(Q,1,PSGP,ODA,0)) S $P(^(0),"^",2)=DA + L -^PS(53.1,ODA) L -^PS(55,DFN,5,+PSGORD) K CNT,ND,ODA,XX,ZND Q diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGPLR.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGPLR.m index fe1f215e..f18a4f5d 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGPLR.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGPLR.m @@ -1,90 +1,87 @@ -PSGPLR ;BIR/CML3-PRINTS PICK LIST REPORT ; 6/15/07 1:12pm - ;;5.0; INPATIENT MEDICATIONS ;**10,50,67,119,129,191**;16 DEC 97;Build 9 - ; - ; Reference to ^PS(55 is supported by DBIA# 2191. - ; Reference to ^PS(59.7 is supported by DBIA# 2181. - ; Reference to ^PSDRUG is supported by DBIA# 2192. - ; Reference to ^%DTC is supported by DBIA# 10000. - ; Reference to ^VADPT is supported by DBIA# 10061. - ; - N PSGY,OLDWARD,STPDT D NOW^%DTC S PSGDT=+$E(%,1,12),PPLD=$$ENDTC^PSGMI(PSGDT),$P(OLINE,"-",75)="",PSGPLXR=$S($G(PSGPLUPF)=1:"AU",1:"AC") - S PGN=0,(FACL,LINE)="",$P(LINE,"-",81)="",$P(FACL,"_",31)="",TND=$G(^PS(53.5,PSGPLG,0)),PSD=$P(TND,"^",3),PFD=$P(TND,"^",4),WSF=$P(TND,"^",7),WGPN=$S('$D(^PS(57.5,PSGPLWG,0)):"N/F",$P(^(0),"^")]"":$P(^(0),"^"),1:"N/F") - S FFF=$S($P(PSGPLWGP,"^",4):2,$P(PSGPLWGP,"^",5):1,1:0),CML=IO'=IO(0)!($E(IOST,1,2)'="C-") - F X="PSD","PFD" S @X=$$ENDTC^PSGMI(@X) - U IO - I '$D(^PS(53.5,$S($D(PSGPLUPF):"AU",1:"AC"),PSGPLG)) S NPLF=0 D HEADER W !!?25,"*** No orders to fill ***" W:(IO'=IO(0)!(IOST'["C-"))&($Y) @IOF G DONE - ; -BEGIN ; - I '$$LOCK^PSGPLUTL(PSGPLG,"PSGPLR") H 60 G BEGIN - S NPLF=1,TM=0 F S TM=$O(^PS(53.5,PSGPLXR,PSGPLG,TM)) Q:TM=""!(TM["~") S (DDRG,PDRG,PN,PST,RM,WDN)="" D HEADER:'FFF,^PSGPLR0 I CML,'FFF D PAGECK W !!?25,"FILLED BY: ",FACL,!!?25,"CHECKED BY: ",FACL - I CML,FFF D PAGECK W !!?25,"FILLED BY: ",FACL,!!?25,"CHECKED BY: ",FACL W:$Y @IOF - ; -DONE ; - D UNLOCK^PSGPLUTL(PSGPLG,"PSGPLR") - K AT,ATC,CML,DDRG,DIS,DND,DO,DR,DRN,DRG,FACL,FD,FFF,FQC,LINE,ND,ND0,ND1,ND2,ND6,NEED,NPLF,OLINE,PSGPLDC,PSGPLXR,PSGPLXRX - K PSJJORD,PSJORDN,PFD,PGN,PN,POP,PPLD,PPN,PRM,PSD,PSGID,PSGOD,PSGP,PST,PW,RM,RTE,SCH,SD,SM,PSSN,TD,TM,TND,WDN,WL,WG,WSF,WGPN,X - Q - ; -DD ; - N PSJRNW,CNT - I $D(PSGPLREN("B",$G(PSGP),$G(PSJJORD))),$G(PSGPLUP) D - .N OSTOP,DRGND S (DDRG,OLDWARD)="" S DRGND=$O(PSGPLREN("B",PSGP,PSJJORD,0)) Q:'DRGND S OSTOP=PSGPLREN("B",PSGP,PSJJORD,DRGND) Q:'OSTOP - .N ST,TMPDRG S CNT=0,ST=$P(ND0,"^",7) S TMPDRG=0 S TMPDRG=$O(PSGPLREN("B",PSGP,PSJJORD,TMPDRG)) S TMPDRG=$P(DRG,"^")_"^"_TMPDRG - .F PSGPLXRX="AU","AC" Q:CNT F I=0:1 S DDRG=$O(PSGPLREN(53.5,PSGPLXRX,PSGPLG,TM,WDN,RM,PN,PST,TMPDRG,DDRG)) Q:(DDRG="")!(DDRG="NO DISPENSE DRUG") D - ..S X=$G(PSGPLREN(53.5,PSGPLG,1,PSGP,1,+DRGND,1,$P(DDRG,"^",2),0)) S DR=+X,DND=$P(X,U,2,4) Q:'X - ..S DRN=$G(^PS(55,PSGP,5,PSJJORD,1,DR,0)),DR=$$ENDDN^PSGMI($P(DRN,"^")) I DND?7N1"DI" S DND=$E($$ENDTC^PSGMI(+DND),1,8) - ..S DIS=$P(DND,"^",2),NEED=$S($P(DND,"^")]"":$P(DND,"^"),1:0) - ..;GMZ;PSJ*5*191;Allow for Multiple Dispensed Drug units needed - ..S PSJRNW(I)=1_"^"_+NEED - ..Q - .K PSGPLREN("B",PSGP,PSJJORD),PSGPLREN(53.5,PSGPLG,1,PSGP,1,+DRGND) W !! - ; - S CNT=0 - S (DDRG,OLDWARD)="" N ST S ST=$P(ND0,"^",7) F S DDRG=$O(^PS(53.5,PSGPLXR,PSGPLG,TM,WDN,RM,PN,PST,DRG,DDRG)) Q:(DDRG="")!(DDRG="NO DISPENSE DRUG") S X=$G(^PS(53.5,PSGPLG,1,+$P(PN,U,2),1,+$P(DRG,U,2),1,+$P(DDRG,U,2),0)),DR=+X,DND=$P(X,U,2,4) D - .S DRN=$G(^PS(55,PSGP,5,PSJJORD,1,DR,0)),DR=$$ENDDN^PSGMI($P(DRN,"^")) I DND?7N1"DI" S DND=$E($$ENDTC^PSGMI(+DND),1,8) W !?6,DR,?48,ST,?51,"(DI "_DND_")",?66,"Returns: ____" Q - .S UD=$P(DRN,"^",2),ATC=$P($G(^PSDRUG(+DRN,8.5)),"^",2)]"" S:ATC ATC=$D(^(212,"AC",PSGPLWG)) - .S DIS=$P(DND,"^",2),NEED=$S($P(DND,"^")]"":$P(DND,"^"),1:0) I ATC S ATCFF=+$P($G(^PS(59.7,1,26)),"^",7),ATC=$S(ATCFF:NEED,UD#1:0,DIS]"":+DIS,1:NEED) I ATC,$S(ATC<1:1,ATC'?1.3N:1,1:ATC#1) S ATC=0 - .I ATC S X=0,X=$O(^PS(59.7,X)) I $P($G(^(X,26)),U,2)=1,PST="OC" S ATC=0 - .S UD=$S('UD:1,UD=.5:"1/2",UD=.25:"1/4",UD<1:"0"_UD,1:UD) - .I $D(PSJRNW) D - ..I 'CNT W !?35,"**** RENEWAL ****" - ..S NEED=NEED-$P(PSJRNW(CNT),"^",2) S:NEED<0 NEED=0 S CNT=CNT+1 - .W !?6,DR,?48,ST W:(ATC)&(NEED>0) ?57,"ATC" W ?61,$J(UD,4),?68,$J(NEED,4),?75,$S(DIS]"":$J(DIS,4),1:"____") - .S:ST="DISCONTINUED" OLDWARD=1 S ST="" - I DDRG="NO DISPENSE DRUG" W !?6,PDRG,?48,ST,?57,"OI" S:ST="DISCONTINUED" OLDWARD=1 S ST="" - N GIVSTR S GIVSTR=$S(DO]"":DO_" ",1:"")_RTE_" "_SCH D - .N MARX,I,Y,X D TXT^PSGMUTL(GIVSTR,60) - .F I=1:1:MARX W:I=1 !?10,"Give: ",MARX(1) W:I>1 !?16,MARX(I) - D:OLDWARD WARDCHK W:AT]"" !,?65-$L(AT),AT W !?7,"Start: ",SD,?37,"Stop: ",FD - I Y]"" W !?10 F Q=1:1:$L(Y," ") S X=$P(Y," ",Q) W:$X+$L(X)>65 !?10 W X_" " - K ST - Q - ; -EXDD ; - W ! S (DDRG,OLDWARD)="" F S DDRG=$O(^PS(53.5,PSGPLXR,PSGPLG,TM,WDN,RM,PN,PST,DRG,DDRG)) Q:(DDRG="")!(DDRG="NO DISPENSE DRUG") S DND=^(DDRG) D - .S DR=$P(DDRG,"^",2),DRN=$G(^PS(55,PSGP,5,PSJJORD,1,DR,0)),ID=$P(DRN,"^",3),DR=$$ENDDN^PSGMI($P(DRN,"^")) W !?6,DR,?48,DIS,?66,"Returns: ____" S:DIS="DISCONTINUED" OLDWARD=1 S DIS="" - I DDRG="NO DISPENSE DRUG" S ND1=$G(^PS(55,PSGP,5,PSJJORD,.2)),PDRG=$$ENPDN^PSGMI($P(ND1,"^")) W !?6,PDRG,?48,DIS,?66,"Returns: ____" S:DIS="DISCONTINUED" OLDWARD=1 S DIS="" - W !?10,"Give: ",$S(DO]"":DO_" ",1:""),RTE," ",SCH D:OLDWARD WARDCHK W !?7,"Start: ",SD,?37,"Stop: ",FD - Q - ; -FCL ; - I PGN,CML,$P(PSGPLWGP,"^",6) W !!?25,"FILLED BY: ",FACL,!!?25,"CHECKED BY: "_FACL - ; -HEADER ; - S PGN=PGN+1 W:$Y @IOF - W ?1,"(",PSGPLG,")",?$S($D(PSGPLUPF):27,1:32),"PICK LIST REPORT" W:$D(PSGPLUPF) " (UPDATE)" W ?64,PPLD,!,"Ward group: ",WGPN,?73-$L(PGN),"Page: ",PGN,!?18,"For ",PSD," through ",PFD W:NPLF !,"Team: ",$S(TM'["zz":TM,1:"** N/F **") - W !!,$S($P(TND,"^",6)&'$P(TND,"^",8):"Bed-Room",1:"Room-Bed"),?15,"Patient",?67,"Units",?74,"Units",!?9,"Medication",?48,"ST",?62,"U/D",?66,"Needed",?74,"Disp'd",!,LINE Q - ; -PAGECK ; - S PSGPY=$Y,PSGPY=$Y+4 I PSGPY+4>IOSL W @IOF - Q - ; -WARDCHK ; if patient has discontinued orders from a different ward, print the ward and room/bed that the orders were discontinued from. - Q:'$G(STPDT) - S VAINDT=$$MINUTES(STPDT,5) - S DFN=PSGP D INP^VADPT I PW'=$P(VAIN(4),"^",2) W ?48,$E("(from "_$P(VAIN(4),"^",2)_" "_VAIN(5)_")",1,31) - S OLDWARD="" Q - ; -MINUTES(STPDT,LESS) ; pass in a FM date/time and the number of minutes (9 or less) to subtract from it - S VAINDT=$S($E(STPDT,9,12)0) ?57,"ATC" W ?61,$J(UD,4),?68,$J(NEED,4),?75,$S(DIS]"":$J(DIS,4),1:"____") + .S:ST="DISCONTINUED" OLDWARD=1 S ST="" + I DDRG="NO DISPENSE DRUG" W !?6,PDRG,?48,ST,?57,"OI" S:ST="DISCONTINUED" OLDWARD=1 S ST="" + N GIVSTR S GIVSTR=$S(DO]"":DO_" ",1:"")_RTE_" "_SCH D + .N MARX,I,Y,X D TXT^PSGMUTL(GIVSTR,60) + .F I=1:1:MARX W:I=1 !?10,"Give: ",MARX(1) W:I>1 !?16,MARX(I) + D:OLDWARD WARDCHK W:AT]"" !,?65-$L(AT),AT W !?7,"Start: ",SD,?37,"Stop: ",FD + I Y]"" W !?10 F Q=1:1:$L(Y," ") S X=$P(Y," ",Q) W:$X+$L(X)>65 !?10 W X_" " + K ST + Q + ; +EXDD ; + W ! S (DDRG,OLDWARD)="" F S DDRG=$O(^PS(53.5,PSGPLXR,PSGPLG,TM,WDN,RM,PN,PST,DRG,DDRG)) Q:(DDRG="")!(DDRG="NO DISPENSE DRUG") S DND=^(DDRG) D + .S DR=$P(DDRG,"^",2),DRN=$G(^PS(55,PSGP,5,PSJJORD,1,DR,0)),ID=$P(DRN,"^",3),DR=$$ENDDN^PSGMI($P(DRN,"^")) W !?6,DR,?48,DIS,?66,"Returns: ____" S:DIS="DISCONTINUED" OLDWARD=1 S DIS="" + I DDRG="NO DISPENSE DRUG" S ND1=$G(^PS(55,PSGP,5,PSJJORD,.2)),PDRG=$$ENPDN^PSGMI($P(ND1,"^")) W !?6,PDRG,?48,DIS,?66,"Returns: ____" S:DIS="DISCONTINUED" OLDWARD=1 S DIS="" + W !?10,"Give: ",$S(DO]"":DO_" ",1:""),RTE," ",SCH D:OLDWARD WARDCHK W !?7,"Start: ",SD,?37,"Stop: ",FD + Q + ; +FCL ; + I PGN,CML,$P(PSGPLWGP,"^",6) W !!?25,"FILLED BY: ",FACL,!!?25,"CHECKED BY: "_FACL + ; +HEADER ; + S PGN=PGN+1 W:$Y @IOF + W ?1,"(",PSGPLG,")",?$S($D(PSGPLUPF):27,1:32),"PICK LIST REPORT" W:$D(PSGPLUPF) " (UPDATE)" W ?64,PPLD,!,"Ward group: ",WGPN,?73-$L(PGN),"Page: ",PGN,!?18,"For ",PSD," through ",PFD W:NPLF !,"Team: ",$S(TM'["zz":TM,1:"** N/F **") + W !!,$S($P(TND,"^",6)&'$P(TND,"^",8):"Bed-Room",1:"Room-Bed"),?15,"Patient",?67,"Units",?74,"Units",!?9,"Medication",?48,"ST",?62,"U/D",?66,"Needed",?74,"Disp'd",!,LINE Q + ; +PAGECK ; + S PSGPY=$Y,PSGPY=$Y+4 I PSGPY+4>IOSL W @IOF + Q + ; +WARDCHK ; if patient has discontinued orders from a different ward, print the ward and room/bed that the orders were discontinued from. + Q:'$G(STPDT) + S VAINDT=$$MINUTES(STPDT,5) + S DFN=PSGP D INP^VADPT I PW'=$P(VAIN(4),"^",2) W ?48,$E("(from "_$P(VAIN(4),"^",2)_" "_VAIN(5)_")",1,31) + S OLDWARD="" Q + ; +MINUTES(STPDT,LESS) ; pass in a FM date/time and the number of minutes (9 or less) to subtract from it + S VAINDT=$S($E(STPDT,9,12)70)!($L(X)<1) K X Q - S X=$$TRIM^XLFSTR(X,"R"," ") - I X?.E1L.E S X=$$ENLU^PSGMI(X) I '$D(PSGOES) D EN^DDIOL(" ("_X_")") - ; -ENOS ; order set entry - N X0,Y0,PSJXI,PSJDIC2,TMPAT - I $G(X)="",$G(P(2)),$G(P(3)) S X=$G(P(9)) - I $G(X)="" Q - S PSGXT=$G(PSGS0XT),(PSGS0XT,PSGS0Y,XT,Y,PSJNSS)="" - S X0=X I X?2.4N1"-".E!(X?2.4N) D ENCHK S:$D(X) Y=X G Q - ; * GUI 27 CHANGES * Check for admin times to be derived from 'base' schedule - I X["@" S TMPAT=$P(X,"@",2) I TMPAT]"" D - .I '$D(^PS(51.1,"AC","PSJ",TMPAT)) K TMPAT Q - .I '$$DOW^PSIVUTL($P(X,"@")) K TMPAT Q - .N LYN,ZZND,PSGS0XT,PSGS0Y,X S (PSGS0Y,PSGS0XT,X)="" - .S X=TMPAT D DIC I $G(Y0)>0 S TMPAT=Y0 - I $G(TMPAT) S (PSGS0Y,$P(X,"@",2))=TMPAT,PSGS0XT="D" - ; * GUI 27 CHANGES * - I X["PRN",$$PRNOK(X),'$D(^PS(51.1,"AC","PSJ",X)) D G Q - .I X["@"!$$DOW^PSIVUTL($P(X," PRN")) N DOW D I $G(DOW) S (Y0,Y,PSGS0Y)=$P($P(X,"@",2)," ") - ..N TMP S TMP=X N X S X=$P(TMP," PRN") D DW I $G(X)]"" S DOW=1 - ..I $G(DOW),$G(PSGST)]"" I ",P,R,"'[(","_PSGST_",") S (XT,PSGS0XT)="D" - D DIC I $G(XT)]""!$G(Y0)!($G(X)]""&$G(PSJXI)) D I $G(X)]"" G:$D(^PS(51.1,"AC","PSJ",X)) Q3 I $P(X,"@")]"" G:$D(^PS(51.1,"AC","PSJ",$P(X,"@"))) Q3 - .S PSGS0XT=XT S:$G(Y0) (Y,PSGS0Y)=Y0 S:'PSGS0Y&((PSGS0XT)="D")&(X["@") PSGS0Y=$P(X,"@",2) - .S PSGS0Y=$P(PSGS0Y," ") - N TMPSCHX S TMPSCHX=X I $L(X,"@")<3 S TMPX=X D DW I $G(X)]"" K PSJNSS S (PSGS0XT,XT)="D" D G Q - .S Y=$S(($G(TMPSCHX)["@"):$P(TMPSCHX,"@",2),1:"") - .I Y,(X'["@"),(TMPSCHX["@") S X=TMPSCHX - S X=TMPSCHX - I X'="" I $D(^PS(51.1,"AC","PSJ",X)) K PSJNSS G Q - ; -NS I ($G(X)="^")!($G(X)="") K X S Y="" Q - N NS S NS=0,PSJNSS=0 - I $G(Y)'>0 S X=X0,Y="",NS=1,PSJNSS=1 -Q ; - S PSGS0XT=$S(XT]"":XT,1:$G(PSGS0XT)),PSGS0Y=$S($G(Y):Y,$G(PSGS0Y):PSGS0Y,1:"") S:PSGS0XT<0 PSGS0XT="" - I ('$G(PSGS0Y)&'$G(PSJDIC2)&$G(PSGAT))&'$G(PSJNEWOE)&$G(PSGS0XT) I PSGS0XT<1441 I ($L($G(PSGAT),"-")=PSGS0XT/1440)!($G(X)]""&($G(PSGSCH)=$G(X))) S PSGS0Y=$G(PSGAT) -Q2 K YY - I '$G(PSJNSS),'$G(PSGS0Y),$G(YY) S PSGS0Y=YY - I $G(X)]"",$$SCHREQ^PSJLIVFD(.P) D - .I $$DOW^PSIVUTL(X)!$$PRNOK(X)!$D(^PS(51.1,"AC","PSJ",X)) S PSJNSS=0 Q - .I $G(P(2))&$G(P(3)) D NSSCONT(X,PSGS0XT) S TMPX="" K X - I ($G(PSJNSS)&($G(VALMBCK)'="Q"))!($G(PSJNSS)&$G(PSJLIFNI))!($G(PSJNSS)&$G(PSJTUD)) D - .I $G(P(2))&$G(P(3)) Q - .I ($G(X)]"") I ($G(PSGS0XT)'="D") D NSSCONT(X,PSGS0XT) S TMPX="" K X -Q3 I $G(X)]"" I $D(^PS(51.1,"AC","PSJ",X)) K PSJNSS - K QX,SDW,SWD,X0,XT,Z Q - ; -NSSCONT(SCH,FREQ) ; - Q:SCH=""!($G(VALMBCK)]"")!$G(PSGMARSD)!$G(PSIVFN1) - I $G(PSGOES),'$G(NSFF) Q - N PSGS0XT,PSGSCH,DIR,X,Y S PSGSCH=SCH,PSGS0XT=FREQ,PSJNSS=1 - D NSSMSG I ($L(PSJNSS)>2),'$G(PSJXI) W !!,PSJNSS,! S PSJNSS=1 - S DIR(0)="EA",DIR("A")="Press Return to continue..." D ^DIR - K NSFF Q - ; -NSSMSG ; - Q:$G(PSJXI) - I '(",O,"[(","_$G(PSGST)_",")),$G(PSJNSS),$G(PSGSCH)]"" D - .S PSJNSS=" WARNING - "_PSGSCH_" is an invalid schedule." - S PSGSCH="",PSGS0XT="" - Q - ; -NSO(FQ) ; - Q:'FQ!(FQ<0)!(",D,O,"[(","_$G(PSGST)_",")) "" - K FRQOUT S FRQOUT=$S(FQ<60:(FQ_"minute"),(FQ<1440)&(FQ#60):(FQ_" minute"),(FQ<1440)!(FQ#1440):(FQ/60_" hour"),1:(FQ/1440_" day")) D - . S:(+FRQOUT'=1) FRQOUT=FRQOUT_"s" - Q FRQOUT - ; -ENCHK ; - I $S($L($P(X,"-"))>4:1,$L(X)>119:1,$L(X)<2:1,X'>0:1,1:X'?.ANP) K X Q - S X(1)=$P(X,"-") I X(1)'?2N,X(1)'?4N K X Q - S X(1)=$L(X(1)) I X'["-"&((X>$E(2400,1,X(1))!($E(X,3,4)>59))) K X Q - F X(2)=2:1:$L(X,"-") S X(3)=$P(X,"-",X(2)) I $S($L(X(3))'=X(1):1,X(3)>$E(2400,1,X(1)):1,$E(X(3),3,4)>59:1,1:X(3)'>$P(X,"-",X(2)-1)) K X Q - K:$D(X) X(1),X(2),X(3) Q - ; -DIC ; Check for schedule's existence in ADMINISTRATION SCHEDULE file (#51.1) - ; Input: - ; X = Schedule Name - ; PSJSLUP = If $G(PSJSLUP), perform interactive fileman lookup (optional). - ; PSGSFLG = If $G(PSGSFLG), return schedule IEN in PSGSCIEN variable (optional) - ; PSJLIFNI = Flag indicating a U/D order is being finished as an IV (optional). - ; PSGOES = If PSGOES=1, IX^DIC is called silently. If PSGOES=2, IX^DIC is not called (optional). - ; PSJPWD = IEN of Inpatient Ward associated with the patient/order/schedule combination (optional). - ; Output: - ; X = Schedule Name if valid Input Schedule X, undefined if invalid Input Schedule X. - ; PSGS0XT = Frequency of validated schedule. - ; PSGS0Y = Default Admin Times of validated schedule. - ; PSGSCIEN = IEN of validated schedule, if PSGSLFG is passed in and is evaluated to TRUE. - ; - ; - K Y0,PSJXI N Y - S Z=0 F PSJXI=0:1 S Z=$O(^PS(51.1,"AC","PSJ",X,Z)) Q:'Z - I $G(X)]"",'$G(PSJSLUP) D - .I $D(^PS(51.1,"AC","PSJ",X)) D Q:$G(PSGS0Y)&($G(PSGS0XT)]"") - ..I $$DOW^PSIVUTL(X) S PSGS0XT="D",PSJNSS=0 S:X["@" (Y0,PSGS0Y)=$P(X,"@",2) Q - ..I $G(NSFF) S Y0=$S($G(PSGS0Y):PSGS0Y,$G(PSGAT)&'$G(PSJNEWOE):PSGAT,1:"") S:Y0 PSGS0Y=Y0 - .; Check for duplicate schedules - force selection - .Q:PSJXI>1&('$G(PSGOES))&($G(PSGS0XT)]"") - .I $D(^PS(51.1,"AC","PSJ",X)) N FREQ,ADMATCH S FREQ=$G(PSGS0XT) D - ..N PSGS0XT,PSGS0Y,PSGST D ADMIN^PSJORPOE S:$G(PSGS0XT) XT=PSGS0XT S:$G(PSGS0Y) (Y0,Y)=PSGS0Y - ..;Check flag PSGSFLG to determine whether to return the schedule IEN in PSGSCIEN. - .S:$G(XT)]"" PSGS0XT=XT S:$G(Y) PSGS0Y=Y - .I $$DOW^PSIVUTL(X) S:PSGS0XT="" (XT,PSGS0XT)="D" S:PSGS0Y="" (Y0,PSGS0Y)=$S($P(X,"@",2):$P(X,"@",2),1:"") - I $G(PSJLIFNI)!($G(P(4))]""&($G(P(2))]"")) I '$D(^PS(51.1,"AC","PSJ",X))!($G(PSJXI)>1) S PSJSLUP=1 - I $G(NSFF),$G(PSJXI)>1 D - .I $G(PSGS0XT)="",$G(NSFF),$G(PSGXT)]"" S PSGS0XT=PSGXT Q - .I $G(PSGS0XT)=""!($G(PSGS0Y)="") S PSJSLUP=1 - I '$G(PSJSLUP) Q:$G(PSGS0XT)]""&($G(PSGS0Y)]"") Q:($G(PSGS0XT)="D"&('$D(^PS(51.1,"AC","PSJ",X)))) - Q:$G(PSGOES)=2 - Q:$G(PSGS0XT)]""&(PSJXI=1) - K PSJSLUP - ; - K DIC S DIC="^PS(51.1,",DIC(0)=$E("E",'$D(PSGOES))_"ISZ",DIC("W")="W "" "","_$S('$D(PSJPWD):"$P(^(0),""^"",2)",'PSJPWD:"$P(^(0),""^"",2)",1:"$S($D(^PS(51.1,+Y,1,+PSJPWD,0)):$P(^(0),""^"",2),1:$P(^PS(51.1,+Y,0),""^"",2))"),D="APPSJ" - I $D(PSGST) ;S DIC("S")="I $P(^(0),""^"",5)"_$E("'",PSGST'="O")_"=""O""" - S PSJDIC2=1 - D IX^DIC K DIC S:$D(DIE)#2 DIC=DIE I Y'>0 D Q - .I '$$DOW^PSIVUTL(X),'$$PRNOK(X) S X="",PSJNSS=1,XT="",PSJXI="" - S XT=$S("C"[$P(Y(0),"^",5):$P(Y(0),"^",3),1:$P(Y(0),"^",5)) - S X=+Y,Y="" I $D(PSJPWD),$D(^PS(51.1,+X,1,+PSJPWD,0)) S Y=$P(^(0),"^",2) - ;Check flag PSGSFLG to determine whether to return the schedule IEN in PSGSCIEN. - I $G(PSGSFLG) S PSGSCIEN=X - S (X,X0)=Y(0,0) S:$G(Y)="" Y=$P(Y(0),"^",2) - S (PSGS0Y,Y0)=$G(Y),Y0(0)=Y(0) I $P(Y(0),"^",3) S XT=$P(Y(0),"^",3) - I $G(PSGS0XT)="",$$DOW^PSIVUTL(X) S (XT,PSGS0XT)="D" - Q - ; -DW ; - N Y - Q:($L(X,"@")>2) - N AT I X["@" S AT=$P(X,"@",2) - S SWD="SUNDAYS^MONDAYS^TUESDAYS^WEDNESDAYS^THURSDAYS^FRIDAYS^SATURDAYS",SDW=X,X=$P(X,"@",2) N XABB S XABB="" - I X]"" D ENCHK Q:'$D(X) - S X=$P(SDW,"@"),X(1)="-" I X?.E1P.E,X'["-" ;F QX=1:1:$L(X) I $E(X,QX)?1P S X(1)=$E(X,QX) Q - F Q=1:1:$L(X,X(1)) K:SWD="" X Q:SWD="" S Z=$P(X,X(1),Q) D DWC Q:'$D(X) - I $D(X) F II=1:1:$L(X,X(1)) S XABB=$G(XABB)_$E($P(X,X(1),II),1,2)_"-" - K X(1) S:$D(X) X=SDW I $G(X)]"" I $TR(XABB,"-")]"" S X=$E($G(XABB),1,$L(XABB)-1) - I $G(AT) S PSGS0Y=AT - Q -DWC I $L(Z)<2 K X Q - F QX=1:1:$L(SWD,"^") S Y=$P(SWD,"^",QX) I $P(Y,Z)="" S SWD=$P(SWD,Y,2) S:$L(SWD) SWD=$E(SWD,2,50) Q - E K X - Q - ; -PRNOK(PSCH) ; - Q:PSCH'["PRN" 0 - I $TR(PSCH," ")="PRN" Q 1 - N BASE,I,OK S OK=0 S I=$P(PSCH," PRN") I I]"",$D(^PS(51.1,"AC","PSJ",I)) S OK=1 - I 'OK D - .I PSCH["@" I $D(^PS(51.1,"AC","PSJ",$P(PSCH,"@")))!$$DOW^PSIVUTL($P(PSCH,"@")) S OK=1 Q - .I $$DOW^PSIVUTL($P(PSCH," PRN")) S OK=1 - Q OK -ODD(PSF) ;determine if this is an odd schedule - I PSF>1439,PSF#1440 Q 1 - I PSF,PSF<1440,1440#PSF Q 1 - Q 0 +PSGS0 ;BIR/CML3-SCHEDULE PROCESSOR ;29 Jan 99 / 8:04 AM + ;;5.0; INPATIENT MEDICATIONS ;**12,25,26,50,63,74,83,116,110,111,133,138,174**;16 DEC 97 + ; + ; Reference to ^PS(51.1 is supported by DBIA 2177 + ; Reference to ^PS(55 is supported by DBIA 2191 + ; +ENA ; entry point for train option + D ENCV^PSGSETU Q:$D(XQUIT) + F S (PSGS0Y,PSGS0XT)="" R !!,"Select STANDARD SCHEDULE: ",X:DTIME W:'$T $C(7) S:'$T X="^" Q:"^"[X D:X?1."?" ENQ^PSGSH I X'?1."?" D EN W:$D(X)[0 $C(7)," ??" I $D(X)#2,'PSGS0Y,PSGS0XT W " Every ",PSGS0XT," minutes" + K DIC,DIE,PSGS0XT,PSGS0Y,Q,X,Y,PSGDT Q + ; +EN3 ; + S PSGST=$P($G(^PS(53.1,DA,0)),"^",7) G EN + ; +EN5 ; + S PSGST=$P($G(^PS(55,DA(1),5,DA,0)),"^",7) + ; +EN ; validate + K PSGS0Y + I X[""""!($A(X)=45)!(X?.E1C.E)!($L(X)>70)!($L(X)<1) K X Q + S X=$$TRIM^XLFSTR(X,"R"," ") + I X?.E1L.E S X=$$ENLU^PSGMI(X) I '$D(PSGOES) D EN^DDIOL(" ("_X_")") + ; +ENOS ; order set entry + N X0,Y0,PSJXI,PSJDIC2 + I $G(X)="",$G(P(2)),$G(P(3)) S X=$G(P(9)) + I $G(X)="" Q + S PSGXT=$G(PSGS0XT),(PSGS0XT,PSGS0Y,XT,Y,PSJNSS)="" + S X0=X I X?2.4N1"-".E!(X?2.4N) D ENCHK S:$D(X) Y=X G Q + I X["PRN",$$PRNOK(X),'$D(^PS(51.1,"AC","PSJ",X)) D G Q + .I X["@"!$$DOW^PSIVUTL($P(X," PRN")) N DOW D I $G(DOW) S (Y0,Y,PSGS0Y)=$P($P(X,"@",2)," ") + ..N TMP S TMP=X N X S X=$P(TMP," PRN") D DW I $G(X)]"" S DOW=1 + ..I $G(DOW),$G(PSGST)]"" I ",P,R,"'[(","_PSGST_",") S (XT,PSGS0XT)="D" + D DIC I $G(XT)]""!$G(Y0)!($G(X)]""&$G(PSJXI)) D I $G(X)]"" G:$D(^PS(51.1,"AC","PSJ",X)) Q3 I $P(X,"@")]"" G:$D(^PS(51.1,"AC","PSJ",$P(X,"@"))) Q3 + .S PSGS0XT=XT S:$G(Y0) (Y,PSGS0Y)=Y0 S:'PSGS0Y&((PSGS0XT)="D")&(X["@") PSGS0Y=$P(X,"@",2) + .S PSGS0Y=$P(PSGS0Y," ") + N TMPSCHX S TMPSCHX=X I $L(X,"@")<3 S TMPX=X D DW I $G(X)]"" K PSJNSS S (PSGS0XT,XT)="D" D G Q + .S Y=$S(($G(TMPSCHX)["@"):$P(TMPSCHX,"@",2),1:"") + .I Y,(X'["@"),(TMPSCHX["@") S X=TMPSCHX + S X=TMPSCHX + I X'="" I $D(^PS(51.1,"AC","PSJ",X)) K PSJNSS G Q + ; +NS I ($G(X)="^")!($G(X)="") K X S Y="" Q + N NS S NS=0,PSJNSS=0 + I $G(Y)'>0 S X=X0,Y="",NS=1,PSJNSS=1 +Q ; + S PSGS0XT=$S(XT]"":XT,1:$G(PSGS0XT)),PSGS0Y=$S($G(Y):Y,$G(PSGS0Y):PSGS0Y,1:"") S:PSGS0XT<0 PSGS0XT="" + I ('$G(PSGS0Y)&'$G(PSJDIC2)&$G(PSGAT))&'$G(PSJNEWOE)&$G(PSGS0XT) I PSGS0XT<1441 I ($L($G(PSGAT),"-")=PSGS0XT/1440)!($G(X)]""&($G(PSGSCH)=$G(X))) S PSGS0Y=$G(PSGAT) +Q2 K YY + I '$G(PSJNSS),'$G(PSGS0Y),$G(YY) S PSGS0Y=YY + I $G(X)]"",$$SCHREQ^PSJLIVFD(.P) D + .I $$DOW^PSIVUTL(X)!$$PRNOK(X)!$D(^PS(51.1,"AC","PSJ",X)) S PSJNSS=0 Q + .I $G(P(2))&$G(P(3)) D NSSCONT(X,PSGS0XT) S TMPX="" K X + I ($G(PSJNSS)&($G(VALMBCK)'="Q"))!($G(PSJNSS)&$G(PSJLIFNI))!($G(PSJNSS)&$G(PSJTUD)) D + .I $G(P(2))&$G(P(3)) Q + .I ($G(X)]"") I ($G(PSGS0XT)'="D") D NSSCONT(X,PSGS0XT) S TMPX="" K X +Q3 I $G(X)]"" I $D(^PS(51.1,"AC","PSJ",X)) K PSJNSS + K QX,SDW,SWD,X0,XT,Z Q + ; +NSSCONT(SCH,FREQ) ; + Q:SCH=""!($G(VALMBCK)]"")!$G(PSGMARSD)!$G(PSIVFN1) + I $G(PSGOES),'$G(NSFF) Q + N PSGS0XT,PSGSCH,DIR,X,Y S PSGSCH=SCH,PSGS0XT=FREQ,PSJNSS=1 + D NSSMSG I ($L(PSJNSS)>2),'$G(PSJXI) W !!,PSJNSS,! S PSJNSS=1 + S DIR(0)="EA",DIR("A")="Press Return to continue..." D ^DIR + K NSFF Q + ; +NSSMSG ; + Q:$G(PSJXI) + I '(",O,"[(","_$G(PSGST)_",")),$G(PSJNSS),$G(PSGSCH)]"" D + .S PSJNSS=" WARNING - "_PSGSCH_" is an invalid schedule." + S PSGSCH="",PSGS0XT="" + Q + ; +NSO(FQ) ; + Q:'FQ!(FQ<0)!(",D,O,"[(","_$G(PSGST)_",")) "" + K FRQOUT S FRQOUT=$S(FQ<60:(FQ_"minute"),(FQ<1440)&(FQ#60):(FQ_" minute"),(FQ<1440)!(FQ#1440):(FQ/60_" hour"),1:(FQ/1440_" day")) D + . S:(+FRQOUT'=1) FRQOUT=FRQOUT_"s" + Q FRQOUT + ; +ENCHK ; + I $S($L($P(X,"-"))>4:1,$L(X)>119:1,$L(X)<2:1,X'>0:1,1:X'?.ANP) K X Q + S X(1)=$P(X,"-") I X(1)'?2N,X(1)'?4N K X Q + S X(1)=$L(X(1)) I X'["-"&((X>$E(2400,1,X(1))!($E(X,3,4)>59))) K X Q + F X(2)=2:1:$L(X,"-") S X(3)=$P(X,"-",X(2)) I $S($L(X(3))'=X(1):1,X(3)>$E(2400,1,X(1)):1,$E(X(3),3,4)>59:1,1:X(3)'>$P(X,"-",X(2)-1)) K X Q + K:$D(X) X(1),X(2),X(3) Q + ; +DIC ; + K Y0,PSJXI N Y + S Z=0 F PSJXI=0:1 S Z=$O(^PS(51.1,"AC","PSJ",X,Z)) Q:'Z + I $G(X)]"",'$G(PSJSLUP) D + .I $D(^PS(51.1,"AC","PSJ",X)) D Q:$G(PSGS0Y)&($G(PSGS0XT)]"") + ..I $$DOW^PSIVUTL(X) S PSGS0XT="D",PSJNSS=0 S:X["@" (Y0,PSGS0Y)=$P(X,"@",2) Q + ..I $G(NSFF) S Y0=$S($G(PSGS0Y):PSGS0Y,$G(PSGAT)&'$G(PSJNEWOE):PSGAT,1:"") S:Y0 PSGS0Y=Y0 + .; Check for duplicate schedules - force selection + .Q:PSJXI>1&('$G(PSGOES))&($G(PSGS0XT)]"") + .I $D(^PS(51.1,"AC","PSJ",X)) N FREQ,ADMATCH S FREQ=PSGS0XT D + ..N PSGS0XT,PSGS0Y,PSGST D ADMIN^PSJORPOE S:$G(PSGS0XT) XT=PSGS0XT S:$G(PSGS0Y) (Y0,Y)=PSGS0Y + .S:$G(XT)]"" PSGS0XT=XT S:$G(Y) PSGS0Y=Y + .I $$DOW^PSIVUTL(X) S:PSGS0XT="" (XT,PSGS0XT)="D" S:PSGS0Y="" (Y0,PSGS0Y)=$S($P(X,"@",2):$P(X,"@",2),1:"") + I $G(PSJLIFNI)!($G(P(4))]""&($G(P(2))]"")) I '$D(^PS(51.1,"AC","PSJ",X))!($G(PSJXI)>1) S PSJSLUP=1 + I $G(NSFF),$G(PSJXI)>1 D + .I $G(PSGS0XT)="",$G(NSFF),$G(PSGXT)]"" S PSGS0XT=PSGXT Q + .I $G(PSGS0XT)=""!($G(PSGS0Y)="") S PSJSLUP=1 + I '$G(PSJSLUP) Q:$G(PSGS0XT)]""&($G(PSGS0Y)]"") Q:($G(PSGS0XT)="D"&('$D(^PS(51.1,"AC","PSJ",X)))) + Q:$G(PSGOES)=2 + Q:$G(PSGS0XT)]""&(PSJXI=1) + K PSJSLUP + ; + K DIC S DIC="^PS(51.1,",DIC(0)=$E("E",'$D(PSGOES))_"ISZ",DIC("W")="W "" "","_$S('$D(PSJPWD):"$P(^(0),""^"",2)",'PSJPWD:"$P(^(0),""^"",2)",1:"$S($D(^PS(51.1,+Y,1,+PSJPWD,0)):$P(^(0),""^"",2),1:$P(^PS(51.1,+Y,0),""^"",2))"),D="APPSJ" + I $D(PSGST) ;S DIC("S")="I $P(^(0),""^"",5)"_$E("'",PSGST'="O")_"=""O""" + S PSJDIC2=1 + D IX^DIC K DIC S:$D(DIE)#2 DIC=DIE I Y'>0 D Q + .I '$$DOW^PSIVUTL(X),'$$PRNOK(X) S X="",PSJNSS=1,XT="",PSJXI="" + S XT=$S("C"[$P(Y(0),"^",5):$P(Y(0),"^",3),1:$P(Y(0),"^",5)) + S X=+Y,Y="" I $D(PSJPWD),$D(^PS(51.1,+X,1,+PSJPWD,0)) S Y=$P(^(0),"^",2) + S (X,X0)=Y(0,0) S:$G(Y)="" Y=$P(Y(0),"^",2) + S (PSGS0Y,Y0)=$G(Y),Y0(0)=Y(0) I $P(Y(0),"^",3) S XT=$P(Y(0),"^",3) + I $G(PSGS0XT)="",$$DOW^PSIVUTL(X) S (XT,PSGS0XT)="D" + Q + ; +DW ; + N Y + Q:($L(X,"@")>2) + N AT I X["@" S AT=$P(X,"@",2) + S SWD="SUNDAYS^MONDAYS^TUESDAYS^WEDNESDAYS^THURSDAYS^FRIDAYS^SATURDAYS",SDW=X,X=$P(X,"@",2) N XABB S XABB="" + I X]"" D ENCHK Q:'$D(X) + S X=$P(SDW,"@"),X(1)="-" I X?.E1P.E,X'["-" ;F QX=1:1:$L(X) I $E(X,QX)?1P S X(1)=$E(X,QX) Q + F Q=1:1:$L(X,X(1)) K:SWD="" X Q:SWD="" S Z=$P(X,X(1),Q) D DWC Q:'$D(X) + I $D(X) F II=1:1:$L(X,X(1)) S XABB=$G(XABB)_$E($P(X,X(1),II),1,2)_"-" + K X(1) S:$D(X) X=SDW I $G(X)]"" I $TR(XABB,"-")]"" S X=$E($G(XABB),1,$L(XABB)-1) + I $G(AT) S PSGS0Y=AT + Q +DWC I $L(Z)<2 K X Q + F QX=1:1:$L(SWD,"^") S Y=$P(SWD,"^",QX) I $P(Y,Z)="" S SWD=$P(SWD,Y,2) S:$L(SWD) SWD=$E(SWD,2,50) Q + E K X + Q + ; +PRNOK(PSCH) ; + Q:PSCH'["PRN" 0 + I $TR(PSCH," ")="PRN" Q 1 + N BASE,I,OK S OK=0 S I=$P(PSCH," PRN") I I]"",$D(^PS(51.1,"AC","PSJ",I)) S OK=1 + I 'OK D + .I PSCH["@" I $D(^PS(51.1,"AC","PSJ",$P(PSCH,"@")))!$$DOW^PSIVUTL($P(PSCH,"@")) S OK=1 Q + .I $$DOW^PSIVUTL($P(PSCH," PRN")) S OK=1 + Q OK +ODD(PSF) ;determine if this is an odd schedule + I PSF>1439,PSF#1440 Q 1 + I PSF,PSF<1440,1440#PSF Q 1 + Q 0 diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGSICHK.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGSICHK.m index a7927901..f39d6054 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGSICHK.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGSICHK.m @@ -1,161 +1,118 @@ -PSGSICHK ;BIR/CML3-CHECKS SPECIAL INSTRUCTIONS ;17 Aug 98 / 8:33 AM - ;;5.0; INPATIENT MEDICATIONS ;**3,9,26,29,44,49,59,110,139,146,160,175,201,185**;16 DEC 97;Build 6 - ; - ; Reference to ^PS(50.605 is supported by DBIA 696. - ; Reference to EN^PSOORDRG is supported by DBIA 2190. - ; Reference to ^PSI(58.1 is supported by DBIA 2284. - ; Reference to ^PSDRUG( is supported by DBIA 2192. - ; Reference to ^PSD(58.8 is supported by DBIA 2283. - ; Reference to ^PS(55 is supported by DBIA 2191. - ; Reference to ^PS(51.2 is supported by DBIA 2178. - ; Reference to ^PS(51 is supported by DBIA 2176. - ; Reference to ^ORRDI1 is supported by DBIA 4659. - ; Reference to ^XTMP("ORRDI" is supported by DBIA 4660. - ; Reference to GETDATA^GMRAOR supported by DBIA 4847. - ; Reference to ^TMP("GMRAOC" supported by DBIA 4848. - ; -START ; - I $S(X'?.ANP:1,X["^":1,1:$L(X)>180) K X Q - S Y="" F Y(1)=1:1:$L(X," ") S Y(2)=$P(X," ",Y(1)) I Y(2)]"" D CHK Q:'$D(X) - I $D(X),Y]"",X'=$E(Y,1,$L(Y)-1) D EN^DDIOL("EXPANDS TO: ") W Y F Y(1)=1:1 S Y(2)=$P(Y," ",Y(1)) Q:Y(2)="" D:$L(Y(2))+$X>78 EN^DDIOL(Y(2)_" ") - Q - ; -CHK ; - I $L(Y(2))<31,$D(^PS(51,+$O(^PS(51,"B",Y(2),0)),0)),$P(^(0),"^",2)]"",$P(^(0),"^",4) S Y(2)=$P(^(0),"^",2) - I $L(Y)+$L(Y(2))>180 K X Q - S Y=Y_Y(2)_" " Q - ; -ENSET(X) ; expands the SPECIAL INSTRUCTIONS field contained in X into Y - N X1,X2,Y S Y="" - ;BHW;PSJ*5*185;Modified Logic below to NOT strip spaces and allow existing logic to flow. - ; ;Removed code I X2]"" Before Set of Y and created argumentless DO structure. - F X1=1:1:$L(X," ") S X2=$P(X," ",X1) D - . I X2']"" S Y=Y_" " Q ;if multiple spaces in text and were $P'ing through text, X2 will="" so just add space and continue - . S Y=Y_$S($L(X2)>30:X2,'$D(^PS(51,+$O(^PS(51,"B",X2,0)),0)):X2,$P(^(0),"^",2)]""&$P(^(0),"^",4):$P(^(0),"^",2),1:X2)_" " - . Q - ;BHW;Modified stripping of spaces at end of string - F X1=$L(Y):-1:0 Q:$E(Y,X1,X1)'=" " S Y=$E(Y,1,X1-1) - Q Y - ; -END ; used by DRUG (55.06,101 & 53.1,101) x-refs to warn user if patient is receiving or about to receive the drug just ordered - Q:$D(PSJHLSKP) - N Z,ZZ,STATUSNP I $G(PSJPWD)&($P($G(PSJSYSU),";")=3)&($G(PSGDRG)) I ($D(^PSI(58.1,"D",PSGDRG,PSJPWD)))!($D(^PSD(58.8,"D",PSGDRG,PSJPWD))) D EN^DDIOL(" *** A WARD STOCK ITEM ***") - D NOW^%DTC - N PSJDCHK F Z=%:0 S Z=$O(^PS(55,+PSGP,5,"AUS",Z)) Q:'Z!$D(DUOUT) F ZZ=0:0 S ZZ=$O(^PS(55,+PSGP,5,"AUS",Z,ZZ)) Q:'ZZ!$D(DUOUT) I +$G(^PS(55,+PSGP,5,ZZ,.2))=PSGX D PDWCHK(+PSGP,ZZ_"U") S PSJDCHK=1 - F STATUSNP="N","P" F Z=0:0 S Z=$O(^PS(53.1,"AS",STATUSNP,+PSGP,Z)) Q:'Z!$D(DUOUT) I +$G(^PS(53.1,+Z,.2))=PSGX D PDWCHK(+PSGP,Z_"P") S PSJDCHK=1 - I $D(PSJDCHK) N DIR D - .S DIR(0)="Y",DIR("A")="Do you wish to continue entering this order",DIR("?",1)="Enter ""N"" if you wish to exit without creating a new order," - .S DIR("?")="or ""Y"" to continue with the order entry process." D ^DIR S:'Y Y=-1,X="^" - K Z,ZZ - Q - ; -ENDDC(PSGP,PSJDD) ; Perform Duplicate Drug, Duplicate Class, - ; Drug-Drug interaction check, Drug-Allergy interaction check. - N PSJLINE,Z,ZZ,PSJFST - S (PSJLINE,PSJFST)=0 - I $G(PSJPWD)&($P($G(PSJSYSU),";")=3)&($G(PSJDD)) I ($D(^PSI(58.1,"D",PSJDD,PSJPWD)))!($D(^PSD(58.8,"D",PSJDD,PSJPWD))) W !?25,"*** A WARD STOCK ITEM ***" - D EN^PSOORDRG(PSGP,PSJDD) K PSJPDRG N INTERVEN,PSJIREQ,PSJRXREQ S Y=1,(PSJIREQ,PSJRXREQ,INTERVEN,X)="" S DFN=PSGP - I $T(HAVEHDR^ORRDI1)]"",$$HAVEHDR^ORRDI1,'$D(^XTMP("ORRDI","OUTAGE INFO","DOWN")) D - . I $P($G(^XTMP("ORRDI","PSOO",PSGP,0)),"^",3)<0 W !,"Remote data not available - Only local order checks processed." D PAUSE^PSJLMUT1 - I $D(^TMP($J,"DD")) D ORDCHK^PSJLMUT1(PSGP,"DD",4) - I $D(^TMP($J,"DC")) D ORDCHK^PSJLMUT1(PSGP,"DC",6) -IVSOL ;*** Start order check for IV solution at this point. - I '$D(PSJFST) N PSJFST S PSJFST=0 - I $D(^TMP($J,"DI")) S INTERVEN=1 D ORDCHK^PSJLMUT1(PSGP,"DI",8) - ;*** Allergy/adverse reaction check. - N PTR,X - S PTR=$P($G(^PSDRUG(PSJDD,"ND")),U)_"."_$P($G(^PSDRUG(PSJDD,"ND")),U,3) - K ^TMP("PSJDAI",$J) S PSJACK=$$ORCHK^GMRAOR(DFN,"DR",PTR) D:$G(PSJACK)=1 - .S ^TMP("PSJDAI",$J,0)=1 - .S I=0 F S I=$O(GMRAING(I)) Q:'I S ^TMP("PSJDAI",$J,I,0)=GMRAING(I) - I $D(^TMP("PSJDAI",$J)) S PSJPDRG=1 D - .W $C(7),!!,"A Drug-Allergy Reaction exists for this medication!",!! - .W !?7,"Drug: "_$P($G(^PSDRUG(PSJDD,0)),"^") I $O(^TMP("PSJDAI",$J)) W !,"Ingredients: " D - ..S I=0 F S I=$O(^TMP("PSJDAI",$J,I)) Q:'I W:$X+$L($G(^(I,0)))+2>IOM !?19 W:I=1 $G(^TMP("PSJDAI",$J,I,0)) W:I>1 ", ",$G(^TMP("PSJDAI",$J,I,0)) - .W !! - K PSJACK,GMRAING,I,^TMP($J) - D ALGCLASS -CONT ; Ask user if they wish to continue in spite of an order check. - Q:'$D(PSJPDRG) N DIR S DIR(0)="Y",DIR("A")="Do you wish to continue entering this order",DIR("?",1)="Enter ""N"" if you wish to exit without creating a new order," - S DIR("?")="or ""Y"" to continue with the order entry process.",DIR("B")="NO" D ^DIR I 'Y S PSGORQF=1,X="^",COMQUIT=1 Q - I 'INTERVEN!($P(PSJSYSU,";")'=3) Q - NEW PSJY - W:PSJIREQ !!,"This is a CRITICAL interaction, you must enter an intervention log to continue" - S DIR(0)="Y",DIR("A")="Do you wish to log an intervention",DIR("?",1)="Enter ""N"" if you do not wish to log an intervention,",DIR("?")="or ""Y"" to log an intervention." D ^DIR S PSJY=Y D:Y ^PSJRXI - I 'PSJY,PSJIREQ S PSGORQF=1,COMQUIT=1 - Q - ; -ENDL ; used by PSGTRAIN DRUG LOOK-UP option - D ENCV^PSGSETU Q:$D(XQUIT) - F S DIC="^PSDRUG(",DIC(0)="AEIMOQZ",DIC("A")="Select DRUG: " W ! D ^DIC K DIC Q:+Y'>0 D SF - D ENKV^PSGSETU K N5,ND,Q,Y Q - ; -SF ; - S Y=+Y,ND=$G(^PSDRUG(Y,0)),PSGID=+$G(^("I")) I PSGID W !!,"THIS DRUG IS INACTIVE AS OF ",$E($$ENDTC^PSGMI(PSGID),1,8) - W !!,$S($P(ND,"^",9):"NON-",1:""),"FORMULARY ITEM" W:$P(ND,"^",10)]"" !,$P(ND,"^",10) - S ND=$P($G(^PSDRUG(Y,2)),"^",3)["U" W !,$P("NOT^","^",ND+1)," A UNIT DOSE DRUG" W ! S ND=$G(^(8)),N5=$G(^(8.5)) W !?2,"DAY (nD) or DOSE (nL) LIMIT: " I ND W $P(ND,"^") - W !?10,"UNIT DOSE MED ROUTE: " I $P(ND,"^",2) W $S($D(^PS(51.2,$P(ND,"^",2),0)):$P(^(0),"^"),1:$P(ND,"^",2)) - ; NAKED REF below refers to ^PS(51.2, on line above. - W !?6,"UNIT DOSE SCHEDULE TYPE: " I $P(ND,"^",3)]"" W $P($P(";"_$P(^(0),"^",3),";"_$P(ND,"^",3)_":",2),";") - W !?11,"UNIT DOSE SCHEDULE: " I $P(ND,"^",4)]"" W $P(ND,"^",4) - W !,"CORRESPONDING OUTPATIENT DRUG: " I $P(ND,"^",5) W $S('$D(^PSDRUG(+$P(ND,"^",5),0)):$P(ND,"^",5),$P(^(0),"^")]"":$P(^(0),"^"),1:$P(ND,"^",5)) - W !?17,"ATC MNEMONIC: " I $P(N5,"^",2)]"" W $P(N5,"^",2) - W !?17,"ATC CANISTER: " F Q=0:0 S Q=$O(^PSDRUG(Y,212,Q)) Q:'Q S ND=$G(^(Q,0)) I ND,$P(ND,"^",2) W ?31,$S('$D(^PS(57.5,+ND,0)):+ND_";PS(57.5,",$P(^(0),"^")]"":$P(^(0),"^"),1:+ND_";PS(57.5,"),?56,$P(ND,"^",2),! - Q - ; -OCHK ; Add drugs in current order to ^TMP("ORDERS" and call order checker. - ; Set PSJOCHK=1 so OP order check doesn't Kill array. - ; - K ^TMP($J,"ORDERS") - N PSJOCHK S PSJOCHK=1 -PDWCHK(DFN,ON) ; Print Dup Drug order. - N ND,ND0,ND2,X - W:'$D(PSJDCHK) $C(7),$C(7),!!,"WARNING! THIS PATIENT HAS THE FOLLOWING ORDER(S) FOR THIS MEDICATION:",!! - S ND=$$DRUGNAME^PSJLMUTL(DFN,ON) - S F=$S(ON["P":"^PS(53.1,",1:"^PS(55,"_DFN_",5,"),ND0=$G(@(F_+ON_",0)")),ND2=$G(^(2)),X=$P(ND,U,2),X=$S(X=.2:$P($G(^(.2)),U,2),1:$G(^(.3))) - W ?10,$P(ND,U),!,?13,"Give: ",X," ",$$ENMRN^PSGMI(+$P(ND0,U,3))," ",$P(ND2,U),!! - Q -ALGCLASS ; checks any Drug allergies or reactions to see if - ; the new drug is the same class - ; this call can be removed by commenting out the call on IVSOL+16 - N PSJLIST,CT,CLS,CLCHK,CNT,PSJL,LIST,DCCNT,PSCLASS,LEN - S PSCLASS=$P($G(^PSDRUG(PSJDD,0)),"^",2),LEN=4 I $E(PSCLASS,1,4)="CN10" S LEN=5 ;look at 5 chars if ANALGESICS - I $T(GETDATA^GMRAOR)]"" G ALGC2 - S GMRA="0^0^111" D EN1^GMRADPT - F PSJLIST=0:0 S PSJLIST=$O(GMRAL(PSJLIST)) Q:'PSJLIST D - .K PSJAGL D EN1^GMRAOR2(PSJLIST,"PSJAGL") - .; is the allergy/reaction drug class first four digits the same as the - .; the class for the drug being entered? - .S (CT,CLS)="",DCCNT=0 - .I $D(PSJAGL("V")) D - ..F S DCCNT=$O(PSJAGL("V",DCCNT)) Q:'DCCNT S:$E($P($G(PSJAGL("V",DCCNT)),"^"),1,LEN)=$E(PSCLASS,1,LEN) (PSJPDRG,CLCHK)=1,CNT=$S('$D(CNT):1,1:CNT+1),LIST(CNT)=$P($G(PSJAGL),"^")_"^"_$P($G(PSJAGL("V",DCCNT)),"^",2) - D:$G(CLCHK) - .W !!,$C(7),"A Drug-Allergy Reaction exists for this medication and/or class!" - .F PSJL=0:0 S PSJL=$O(LIST(PSJL)) Q:'PSJL D - ..W !?6,"Drug: "_$P(LIST(PSJL),"^"),!,"Drug Class: "_$P(LIST(PSJL),"^",2),! - Q -ALGC2 ; - K GMRADRCL - D GETDATA^GMRAOR(DFN) Q:'$D(^TMP("GMRAOC",$J,"APC")) - N GMRACL,RET - S RET=0,GMRACL="" F S GMRACL=$O(^TMP("GMRAOC",$J,"APC",GMRACL)) Q:'$L(GMRACL) D - .N GMRANM,GMRALOC - .S GMRALOC=^TMP("GMRAOC",$J,"APC",GMRACL) - .S GMRANM=$P(^PS(50.605,+$O(^PS(50.605,"B",GMRACL,0)),0),U,2) - .S GMRADRCL(GMRACL)=GMRACL_U_GMRANM_" ("_GMRALOC_")" - .S RET=RET+1 - Q:'RET K ^TMP("GMRAOC",$J) - S CLCHK="",CT="" F S CT=$O(GMRADRCL(CT)) Q:CT="" D - .I $E(PSCLASS,1,LEN)=$E(CT,1,LEN) S CLCHK=$G(CLCHK)+1,^TMP($J,"PSJDRCLS",CLCHK)=CT_" "_$P(GMRADRCL(CT),"^",2) -CLASSDSP ; - I '$D(^TMP($J,"PSJDRCLS")) Q - W $C(7),!,"A Drug-Allergy Reaction exists for this medication and/or class!",! - W !,"Drug: "_$P($G(^PSDRUG(PSJDD,0)),"^") - S CT="" F S CT=$O(^TMP($J,"PSJDRCLS",CT)) Q:CT="" W !,"Drug Class: "_^TMP($J,"PSJDRCLS",CT) - K ^TMP($J,"PSJDRCLS") - S DIR("?",1)="Answer 'YES' if you DO want to enter a reaction for this medication," - S DIR("?")=" 'NO' if you DON'T want to enter a reaction for this medication," - S DIR(0)="SA^1:YES;0:NO",DIR("A")="Do you want to Intervene? ",DIR("B")="Y" W ! D ^DIR - I Y D ^PSJRXI - I '$G(Y) K DIR,DTOUT,DIRUT,DIROUT,DUOUT,Y Q - Q +PSGSICHK ;BIR/CML3-CHECKS SPECIAL INSTRUCTIONS ;17 Aug 98 / 8:33 AM + ;;5.0; INPATIENT MEDICATIONS ;**3,9,26,29,44,49,59,110,139,146,160,175**;16 DEC 97;Build 18 + ; + ; Reference to EN^PSOORDRG is supported by DBIA 2190. + ; Reference to ^PSI(58.1 is supported by DBIA 2284. + ; Reference to ^PSDRUG( is supported by DBIA 2192. + ; Reference to ^PSD(58.8 is supported by DBIA 2283. + ; Reference to ^PS(55 is supported by DBIA 2191. + ; Reference to ^PS(51.2 is supported by DBIA 2178. + ; Reference to ^PS(51 is supported by DBIA 2176. + ; Reference to ^ORRDI1 is supported by DBIA 4659. + ; Reference to ^XTMP("ORRDI" is supported by DBIA 4660. + ; +START ; + I $S(X'?.ANP:1,X["^":1,1:$L(X)>180) K X Q + S Y="" F Y(1)=1:1:$L(X," ") S Y(2)=$P(X," ",Y(1)) I Y(2)]"" D CHK Q:'$D(X) + I $D(X),Y]"",X'=$E(Y,1,$L(Y)-1) D EN^DDIOL("EXPANDS TO: ") W Y F Y(1)=1:1 S Y(2)=$P(Y," ",Y(1)) Q:Y(2)="" D:$L(Y(2))+$X>78 EN^DDIOL(Y(2)_" ") + Q + ; +CHK ; + I $L(Y(2))<31,$D(^PS(51,+$O(^PS(51,"B",Y(2),0)),0)),$P(^(0),"^",2)]"",$P(^(0),"^",4) S Y(2)=$P(^(0),"^",2) + I $L(Y)+$L(Y(2))>180 K X Q + S Y=Y_Y(2)_" " Q + ; +ENSET(X) ; expands the SPECIAL INSTRUCTIONS field contained in X into Y + N X1,X2,Y S Y="" + F X1=1:1:$L(X," ") S X2=$P(X," ",X1) I X2]"" S Y=Y_$S($L(X2)>30:X2,'$D(^PS(51,+$O(^PS(51,"B",X2,0)),0)):X2,$P(^(0),"^",2)]""&$P(^(0),"^",4):$P(^(0),"^",2),1:X2)_" " + S Y=$E(Y,1,$L(Y)-1) Q Y + ; +END ; used by DRUG (55.06,101 & 53.1,101) x-refs to warn user if patient is receiving or about to receive the drug just ordered + Q:$D(PSJHLSKP) + N Z,ZZ,STATUSNP I $G(PSJPWD)&($P($G(PSJSYSU),";")=3)&($G(PSGDRG)) I ($D(^PSI(58.1,"D",PSGDRG,PSJPWD)))!($D(^PSD(58.8,"D",PSGDRG,PSJPWD))) D EN^DDIOL(" *** A WARD STOCK ITEM ***") + D NOW^%DTC + N PSJDCHK F Z=%:0 S Z=$O(^PS(55,+PSGP,5,"AUS",Z)) Q:'Z!$D(DUOUT) F ZZ=0:0 S ZZ=$O(^PS(55,+PSGP,5,"AUS",Z,ZZ)) Q:'ZZ!$D(DUOUT) I +$G(^PS(55,+PSGP,5,ZZ,.2))=PSGX D PDWCHK(+PSGP,ZZ_"U") S PSJDCHK=1 + F STATUSNP="N","P" F Z=0:0 S Z=$O(^PS(53.1,"AS",STATUSNP,+PSGP,Z)) Q:'Z!$D(DUOUT) I +$G(^PS(53.1,+Z,.2))=PSGX D PDWCHK(+PSGP,Z_"P") S PSJDCHK=1 + I $D(PSJDCHK) N DIR D + .S DIR(0)="Y",DIR("A")="Do you wish to continue entering this order",DIR("?",1)="Enter ""N"" if you wish to exit without creating a new order," + .S DIR("?")="or ""Y"" to continue with the order entry process." D ^DIR S:'Y Y=-1,X="^" + K Z,ZZ + Q + ; +ENDDC(PSGP,PSJDD) ; Perform Duplicate Drug, Duplicate Class, + ; Drug-Drug interaction check, Drug-Allergy interaction check. + N PSJLINE,Z,ZZ,PSJFST + S (PSJLINE,PSJFST)=0 + I $G(PSJPWD)&($P($G(PSJSYSU),";")=3)&($G(PSJDD)) I ($D(^PSI(58.1,"D",PSJDD,PSJPWD)))!($D(^PSD(58.8,"D",PSJDD,PSJPWD))) W !?25,"*** A WARD STOCK ITEM ***" + D EN^PSOORDRG(PSGP,PSJDD) K PSJPDRG N INTERVEN,PSJIREQ,PSJRXREQ S Y=1,(PSJIREQ,PSJRXREQ,INTERVEN,X)="" S DFN=PSGP + I $T(HAVEHDR^ORRDI1)]"",$$HAVEHDR^ORRDI1,'$D(^XTMP("ORRDI","OUTAGE INFO","DOWN")) D + . I $P($G(^XTMP("ORRDI","PSOO",PSGP,0)),"^",3)<0 W !,"Remote data not available - Only local order checks processed." D PAUSE^PSJLMUT1 + K ^TMP($J,"DUPDRG") ;DEM - Duplicate Drug Check Ehancement. + I $D(^TMP($J,"DD")) D ORDCHK^PSJLMUT1(PSGP,"DD",4) + I $D(^TMP($J,"DC")) D ORDCHK^PSJLMUT1(PSGP,"DC",6) +IVSOL ;*** Start order check for IV solution at this point. + I '$D(PSJFST) N PSJFST S PSJFST=0 + I $D(^TMP($J,"DI")) S INTERVEN=1 D ORDCHK^PSJLMUT1(PSGP,"DI",8) + D DUPDRG^PSJLMUT2(PSGP) K ^TMP($J,"DUPDRG") ;DEM - Duplicate Drug Check Ehancement. + ;*** Allergy/adverse reaction check. + N PTR,X + S PTR=$P($G(^PSDRUG(PSJDD,"ND")),U)_"."_$P($G(^PSDRUG(PSJDD,"ND")),U,3) + K ^TMP("PSJDAI",$J) S PSJACK=$$ORCHK^GMRAOR(DFN,"DR",PTR) D:$G(PSJACK)=1 + .S ^TMP("PSJDAI",$J,0)=1 + .S I=0 F S I=$O(GMRAING(I)) Q:'I S ^TMP("PSJDAI",$J,I,0)=GMRAING(I) + I $D(^TMP("PSJDAI",$J)) S PSJPDRG=1 D + .W $C(7),!!,"A Drug-Allergy Reaction exists for this medication!",!! + .W !?7,"Drug: "_$P($G(^PSDRUG(PSJDD,0)),"^") I $O(^TMP("PSJDAI",$J)) W !,"Ingredients: " D + ..S I=0 F S I=$O(^TMP("PSJDAI",$J,I)) Q:'I W:$X+$L($G(^(I,0)))+2>IOM !?19 W:I=1 $G(^TMP("PSJDAI",$J,I,0)) W:I>1 ", ",$G(^TMP("PSJDAI",$J,I,0)) + .W !! + K PSJACK,GMRAING,I,^TMP($J) + D ALGCLASS^PSGSICH1 +CONT ; Ask user if they wish to continue in spite of an order check. + ;Variable PSJDDCON is the order continuation flag for Duplicate Drug Check Enhancement. + I $D(PSJDDCON("DD")),'PSJDDCON("DD") Q + I '$D(PSJDDCON("DD")) Q:'$D(PSJPDRG) N DIR D I 'Y S PSGORQF=1,X="^",COMQUIT=1 K PSJDDCON Q + . S DIR(0)="Y",DIR("A")=$S($G(PSJDDCON("DI")):"Do you wish to continue with the current order",1:"Do you wish to continue entering this order") + . S DIR("?",1)="Enter ""N"" if you wish to exit without creating a new order,",DIR("?")="or ""Y"" to continue with the order entry process.",DIR("B")=$S($G(PSJDDCON("DI")):"YES",1:"NO") + . D ^DIR + . Q + ; + K PSJDDCON ;Order continuation flag for Duplicate Drug Check Enhancement. + I 'INTERVEN!($P(PSJSYSU,";")'=3) Q + N PSJY + W:PSJIREQ !!,"This is a CRITICAL interaction, you must enter an intervention log to continue" + S DIR(0)="Y",DIR("A")="Do you wish to log an intervention",DIR("?",1)="Enter ""N"" if you do not wish to log an intervention,",DIR("?")="or ""Y"" to log an intervention." D ^DIR S PSJY=Y D:Y ^PSJRXI + I 'PSJY,PSJIREQ S PSGORQF=1,COMQUIT=1 + Q + ; +ENDL ; used by PSGTRAIN DRUG LOOK-UP option + D ENCV^PSGSETU Q:$D(XQUIT) + F S DIC="^PSDRUG(",DIC(0)="AEIMOQZ",DIC("A")="Select DRUG: " W ! D ^DIC K DIC Q:+Y'>0 D SF + D ENKV^PSGSETU K N5,ND,Q,Y + Q + ; +SF ; + N PSGID + S Y=+Y,ND=$G(^PSDRUG(Y,0)),PSGID=+$G(^("I")) I PSGID W !!,"THIS DRUG IS INACTIVE AS OF ",$E($$ENDTC^PSGMI(PSGID),1,8) + W !!,$S($P(ND,"^",9):"NON-",1:""),"FORMULARY ITEM" W:$P(ND,"^",10)]"" !,$P(ND,"^",10) + S ND=$P($G(^PSDRUG(Y,2)),"^",3)["U" W !,$P("NOT^","^",ND+1)," A UNIT DOSE DRUG" W ! S ND=$G(^(8)),N5=$G(^(8.5)) W !?2,"DAY (nD) or DOSE (nL) LIMIT: " I ND W $P(ND,"^") + W !?10,"UNIT DOSE MED ROUTE: " I $P(ND,"^",2) W $S($D(^PS(51.2,$P(ND,"^",2),0)):$P(^(0),"^"),1:$P(ND,"^",2)) + ; NAKED REF below refers to ^PS(51.2, on line above. + W !?6,"UNIT DOSE SCHEDULE TYPE: " I $P(ND,"^",3)]"" W $P($P(";"_$P(^(0),"^",3),";"_$P(ND,"^",3)_":",2),";") + W !?11,"UNIT DOSE SCHEDULE: " I $P(ND,"^",4)]"" W $P(ND,"^",4) + W !,"CORRESPONDING OUTPATIENT DRUG: " I $P(ND,"^",5) W $S('$D(^PSDRUG(+$P(ND,"^",5),0)):$P(ND,"^",5),$P(^(0),"^")]"":$P(^(0),"^"),1:$P(ND,"^",5)) + W !?17,"ATC MNEMONIC: " I $P(N5,"^",2)]"" W $P(N5,"^",2) + W !?17,"ATC CANISTER: " F Q=0:0 S Q=$O(^PSDRUG(Y,212,Q)) Q:'Q S ND=$G(^(Q,0)) I ND,$P(ND,"^",2) W ?31,$S('$D(^PS(57.5,+ND,0)):+ND_";PS(57.5,",$P(^(0),"^")]"":$P(^(0),"^"),1:+ND_";PS(57.5,"),?56,$P(ND,"^",2),! + Q + ; +OCHK ; Add drugs in current order to ^TMP("ORDERS" and call order checker. + ; Set PSJOCHK=1 so OP order check doesn't Kill array. + ; + K ^TMP($J,"ORDERS") + N PSJOCHK S PSJOCHK=1 +PDWCHK(DFN,ON) ; Print Dup Drug order. + N ND,ND0,ND2,X + W:'$D(PSJDCHK) $C(7),$C(7),!!,"WARNING! THIS PATIENT HAS THE FOLLOWING ORDER(S) FOR THIS MEDICATION:",!! + S ND=$$DRUGNAME^PSJLMUTL(DFN,ON) + S F=$S(ON["P":"^PS(53.1,",1:"^PS(55,"_DFN_",5,"),ND0=$G(@(F_+ON_",0)")),ND2=$G(^(2)),X=$P(ND,U,2),X=$S(X=.2:$P($G(^(.2)),U,2),1:$G(^(.3))) + W ?10,$P(ND,U),!,?13,"Give: ",X," ",$$ENMRN^PSGMI(+$P(ND0,U,3))," ",$P(ND2,U),!! + Q diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR3.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR3.m index afe6a133..17be191e 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR3.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR3.m @@ -1,4 +1,4 @@ -PSGXR3 ; DRIVER FOR COMPILED XREFS FOR FILE #53.1 ; 11/08/09 +PSGXR3 ; DRIVER FOR COMPILED XREFS FOR FILE #53.1 ; 01/17/08 ; N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2 I '$D(DIKSAT) S DIKLK=DIK_DA_")" L +@DIKLK:10 K:'$T DIKLK diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR31.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR31.m index 5bae31f4..a684fca7 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR31.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR31.m @@ -1,4 +1,4 @@ -PSGXR31 ; COMPILED XREF FOR FILE #53.1 ; 11/08/09 +PSGXR31 ; COMPILED XREF FOR FILE #53.1 ; 01/17/08 ; S DIKZK=2 S DIKZ(0)=$G(^PS(53.1,DA,0)) diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR310.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR310.m index d19a0156..5c20836a 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR310.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR310.m @@ -1,4 +1,4 @@ -PSGXR310 ; COMPILED XREF FOR FILE #53.1114 ; 11/08/09 +PSGXR310 ; COMPILED XREF FOR FILE #53.1114 ; 01/17/08 ; S DA=0 A1 ; diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR311.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR311.m index dcdf302c..c0800073 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR311.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR311.m @@ -1,4 +1,4 @@ -PSGXR311 ; COMPILED XREF FOR FILE #53.157 ; 11/08/09 +PSGXR311 ; COMPILED XREF FOR FILE #53.157 ; 01/17/08 ; S DA=0 A1 ; diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR312.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR312.m index 02c261b2..6bbcbce0 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR312.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR312.m @@ -1,4 +1,4 @@ -PSGXR312 ; COMPILED XREF FOR FILE #53.158 ; 11/08/09 +PSGXR312 ; COMPILED XREF FOR FILE #53.158 ; 01/17/08 ; S DA=0 A1 ; diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR32.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR32.m index 3ce75c1a..3a54dc9a 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR32.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR32.m @@ -1,4 +1,4 @@ -PSGXR32 ; COMPILED XREF FOR FILE #53.11 ; 11/08/09 +PSGXR32 ; COMPILED XREF FOR FILE #53.11 ; 01/17/08 ; S DA(1)=DA S DA=0 A1 ; diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR33.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR33.m index 1bdca20c..1ee954a8 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR33.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR33.m @@ -1,4 +1,4 @@ -PSGXR33 ; COMPILED XREF FOR FILE #53.1112 ; 11/08/09 +PSGXR33 ; COMPILED XREF FOR FILE #53.1112 ; 01/17/08 ; S DA=0 A1 ; diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR34.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR34.m index 0c2f938a..0033b61a 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR34.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR34.m @@ -1,4 +1,4 @@ -PSGXR34 ; COMPILED XREF FOR FILE #53.1114 ; 11/08/09 +PSGXR34 ; COMPILED XREF FOR FILE #53.1114 ; 01/17/08 ; S DA=0 A1 ; diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR35.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR35.m index 5e5f834d..446645ea 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR35.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR35.m @@ -1,4 +1,4 @@ -PSGXR35 ; COMPILED XREF FOR FILE #53.157 ; 11/08/09 +PSGXR35 ; COMPILED XREF FOR FILE #53.157 ; 01/17/08 ; S DA=0 A1 ; diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR36.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR36.m index ead09aaf..503a317a 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR36.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR36.m @@ -1,4 +1,4 @@ -PSGXR36 ; COMPILED XREF FOR FILE #53.158 ; 11/08/09 +PSGXR36 ; COMPILED XREF FOR FILE #53.158 ; 01/17/08 ; S DA=0 A1 ; diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR37.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR37.m index 8126d6ce..65b4dd55 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR37.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR37.m @@ -1,4 +1,4 @@ -PSGXR37 ; COMPILED XREF FOR FILE #53.1 ; 11/08/09 +PSGXR37 ; COMPILED XREF FOR FILE #53.1 ; 01/17/08 ; S DIKZK=1 S DIKZ(0)=$G(^PS(53.1,DA,0)) diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR38.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR38.m index 758f2683..69e00744 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR38.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR38.m @@ -1,4 +1,4 @@ -PSGXR38 ; COMPILED XREF FOR FILE #53.11 ; 11/08/09 +PSGXR38 ; COMPILED XREF FOR FILE #53.11 ; 01/17/08 ; S DA(1)=DA S DA=0 A1 ; diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR39.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR39.m index 156f0cf8..a1bc59ce 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR39.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR39.m @@ -1,4 +1,4 @@ -PSGXR39 ; COMPILED XREF FOR FILE #53.1112 ; 11/08/09 +PSGXR39 ; COMPILED XREF FOR FILE #53.1112 ; 01/17/08 ; S DA=0 A1 ; diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVCAL.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVCAL.m index 43c54d9e..7b41537a 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVCAL.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVCAL.m @@ -1,148 +1,131 @@ -PSIVCAL ;BIR/RGY,PR-CALCULATES START AND STOP DATES ;12 Mar 99 / 12:42 PM - ;;5.0; INPATIENT MEDICATIONS ;**4,26,41,47,63,67,69,58,94,80,110,111,177,120,134**;16 DEC 97;Build 124 - ; - ; Reference to ^PS(50.7 is supported by DBIA #2180. - ; Reference to ^PS(52.6 is supported by DBIA #1231. - ; Reference to ^PS(55 is supported by DBIA #2191. - ; -ENT ;NEEDS PSIVTYPE (P(4)) - I $G(PSJREN) D Q:P(2) - . I $G(P("OLDON")) N P2 S P2=$G(@("^PS(55,"_DFN_",""IV"","_+P("OLDON")_",0)")),P2=$P(P2,"^",2) I P2 S P(2)=P2 - I $G(PSJORD)["P",$G(P("APPT"))?7N1"."1.N S START=$$DATE2^PSJUTL2(P("APPT")) G Q - I $G(PSJSYSW0)=""!($P(PSJSYSW0,U,5)=2) S START=+$E(P("LOG"),1,12) G Q - S PSIVSN=+P("IVRM"),START="",PSIVTYPE=$G(P(4)) Q:PSIVTYPE="" - N PSIV X $S($E(PSIVAC)="C":"S X=+$E(P(""LOG""),1,12) D H^%DTC S PSIV=%T",1:"S PSIV=$P($H,"","",2)") G T2:PSIVTYPE'["P"&('P(5)) - I P(11)']"" X $S($E(PSIVAC)="C":"S Y=+$E(P(""LOG""),1,12)",1:"D NOW^%DTC S Y=%") S Y=Y+.007\.01/100 S:'$P(Y,".",2) Y=$$MDNGHT(Y) X ^DD("DD") S START=Y G Q - S X=P(11) D CHK S PX=Y,X1=PSIV\3600,X2=PSIV#3600\60,X=$E(".0",1,$L(X1)#2+1)_X1_$E("0",X2<10)_X2,START=$S($E(PSIVAC)="C":$P(P("LOG"),"."),1:"T") - S X1=$P(PX,"-"),X1=$E(".0",1,$L(X1)#2+1)_X1,X2=$P(PX,"-",PSGCNT),X2=$E(".0",1,$L(X2)#2+1)_X2 - S NAT=+$P($G(^PS(59.6,+$O(^PS(59.6,"B",+VAIN(4),0)),0)),U,5) - I '$D(PSGDT) S PSGDT=$$DATE^PSJUTL2() - I XX2 S START=$$ENSD^PSGNE3(P(9),P(11),+$E(P("LOG"),1,12),PSGDT) G Q -T6 F I=2:1:PSGCNT S X1="."_$P(PX,"-",I-1),X2="."_$P(PX,"-",I) Q:+X1X) - S X1=X-X1,X2=$S(NAT:0,1:X2-X),START=$S(X1240!($P(X,"-",Y)="") S $P(X,"-",Y)=$P(X,"-",Y)_$E("0000",1,4-$L($P(X,"-",Y))) - S Y=X,PSGCNT=$L(X,"-") S:X]""&(PSGCNT<1) PSGCNT=1 Q - ; -ENSTOP ; WILL CALCULATE STOP DATE FOR ORDER - ;NEEDS (DFN) & ON - N WALL,P3,ADX,DDLX,OIX,DRGT,PSIDAY,PSIMIN,LIMDAY S (WALL,P3,PSIDAY,PSIMIN)=0 - D:'$G(PSIVSITE) ^PSIVSET Q:'P(2) - I P(23)'="" S PSIVTYPE="C" - S STOP="",X="",PSIVSTRT=P(2),PSIVTYPE=$G(P(4)) I $G(PSJREN) D - . N RDT I $G(ON)["P" S RDT=+$$LASTREN^PSJLMPRI(DFN,ON) - . S PSIVSTRT=$$DATE2^PSJUTL2($S($G(RDT):RDT,1:$G(PSGDT))) - ;BHW - PSJ*5*177 - Begin Modifications - Reset Start date to Last Renewed date for active orders that have been renewed - I ('$G(PSJREN))&($G(P(4))="A")&($G(ON)["V") D - . N RDT S RDT=+$$LASTREN^PSJLMPRI(DFN,ON) - . I +RDT S PSIVSTRT=RDT - . Q - ;BHW - PSJ*5*177 - End Modifications - Resetting PSIVSTRT will recalculate the stop date based on the Last renewed date. - ; - I $S("^NOW^STAT^ONCE^ONE-TIME^ONE TIME^ONETIME^1TIME^1-TIME^1 TIME^"[(U_P(9)_U):1,1:0),PSIVTYPE="P"!P(5)!(P(23)="P") S X=$$ENOSD^PSJDCU(PSJSYSW0,PSIVSTRT,DFN) I X]"" S:P(11)=""&($G(ON)["P") PSIVCAL=1 G END - I '$G(P("OVRIDE")),$G(ON) N DUR,DURMIN,PSJPROV,PSJDNM,A,PSJDAY I $G(ON)["V"!(($G(ON)["P")&($P($G(^PS(53.1,+ON,0)),"^",4)="F")) D - . S DUR=$$GETDUR^PSJLIVMD(DFN,+ON,"IV",1) I DUR]"" S DURMIN=$$DURMIN^PSJLIVMD(DUR) I DURMIN S PSIMIN=DURMIN - I $P(PSIVSITE,"^",5) D - . N Z S Y=0 - . F S Y=$O(^PS(55,DFN,"IV",Y)) Q:'Y S Z=^(Y,0) D Q:X]"" - .. I $P(Z,"^",17)="A",$$ONE^PSJBCMA(DFN,Y_"V",$P(Z,"^",9))'="O" S X=$P(Z,"^",3) Q - S:$G(X) WALL=X - S PSIDAY=$S(PSIVTYPE="A":$P(PSIVSITE,"^",4),PSIVTYPE="H":$P(PSIVSITE,"^",17),PSIVTYPE="P":$P(PSIVSITE,"^",18),PSIVTYPE="S":$P(PSIVSITE,"^",20),1:$P(PSIVSITE,"^",21)) - I $G(ON)["P"!($G(ON)["V") I '$G(P("OVRIDE")) N MINS,LIM S PSIVLIM=$$GETLIM(DFN,ON) I $G(PSIVLIM)]"" S MINS=$$GETMIN(PSIVLIM,DFN,ON,.LIMDAY) D - .I (MINS&(MINSWALL S PSIDAY=$$FMDIFF^XLFDT(WALL,PSIVSTRT,1) S:PSIDAY<1 PSIDAY="" - S DRGT=$S($D(DRG("AD")):"AD",1:"SOL") F ADX=0:0 S ADX=$O(DRG(DRGT,ADX)) Q:'ADX!($G(DRGTMP)&($G(DRGTN)["AD")&(DRGT="SOL")) D - . S OIX=+$P(DRG(DRGT,ADX),"^",6),DDLX=$P(^PS(50.7,OIX,0),"^",5) Q:'DDLX D DDLIM(.PSIDAY,.P3) - I '$G(DRG("AD",0)),$G(DRGTMP),($G(DRGTN)["SOL") S OIX=$P($G(DRGTMP),"^",6) I OIX S DDLX=$P(^PS(50.7,OIX,0),"^",5) I DDLX D DDLIM(.PSIDAY,.P3) - I $G(PSIVLIM)["a",'$G(P("OVRIDE")) S DDLX=$P(PSIVLIM,"a",2)_"L" I $G(DDLX) D DDLIM(.PSIDAY,.P3) - I $G(P(2)) I P3>P(2) S X=P3 - S:('PSIDAY&'PSIMIN) PSIDAY=1 -TIME S X2=PSIDAY,X1=PSIVSTRT D C^%DTC S X=$P(X,"."),X=X_$S($P(PSIVSITE,"^",14)="":.2359,1:"."_$P(PSIVSITE,"^",14)) - I PSIMIN D - . I $G(PSIDAY),((PSIDAY*1440)2 S X=+PSGSA\1 F OD1=2:1:OD-1 I $P(PSGSA," ",OD1)'>$S(OD1>2:$P(PSGSA," ",OD1-1),1:PSGSA#1) S X1=X,X2=1 D C^%DTC - I PSIVSD,OD>2 S Y=X_PSIVSD - S PSIVADM=+Y,X=PSIVX,Y=PSIVY K PSGSA,PSIVSD,OD,OD1,PSIVMI,PSIVNOW S:PSIVADMP(2) S P(3)=X - I DDLX["L",($G(P(9))]""),("AH"'[$G(PSIVTYPE)) S LASTD=$$DOSES(DDLX,.P) I LASTD D - .S NEWDUR=$$FMDIFF^XLFDT(LASTD,P(2),2) I NEWDUR>0 S NEWDAYS=(NEWDUR/86400) - .I $G(NEWDAYS) I NEWDAYSX2 S START=$$ENSD^PSGNE3(P(9),P(11),+$E(P("LOG"),1,12),PSGDT) G Q +T6 F I=2:1:PSGCNT S X1="."_$P(PX,"-",I-1),X2="."_$P(PX,"-",I) Q:+X1X) + S X1=X-X1,X2=$S(NAT:0,1:X2-X),START=$S(X1240!($P(X,"-",Y)="") S $P(X,"-",Y)=$P(X,"-",Y)_$E("0000",1,4-$L($P(X,"-",Y))) + S Y=X,PSGCNT=$L(X,"-") S:X]""&(PSGCNT<1) PSGCNT=1 Q + ; +ENSTOP ; WILL CALCULATE STOP DATE FOR ORDER + ;NEEDS (DFN) & ON + N WALL,P3,ADX,DDLX,OIX,DRGT,PSIDAY,PSIMIN S (WALL,P3,PSIDAY,PSIMIN)=0 + D:'$G(PSIVSITE) ^PSIVSET Q:'P(2) + I P(23)'="" S PSIVTYPE="C" + S STOP="",X="",PSIVSTRT=P(2),PSIVTYPE=$G(P(4)) I $G(PSJREN) D + . N RDT I $G(ON)["P" S RDT=+$$LASTREN^PSJLMPRI(DFN,ON) + . S PSIVSTRT=$$DATE2^PSJUTL2($S($G(RDT):RDT,1:$G(PSGDT))) + ;BHW - PSJ*5*177 - Begin Modifications - Reset Start date to Last Renewed date for active orders that have been renewed + I ('$G(PSJREN))&($G(P(4))="A")&($G(ON)["V") D + . N RDT S RDT=+$$LASTREN^PSJLMPRI(DFN,ON) + . I +RDT S PSIVSTRT=RDT + . Q + ;BHW - PSJ*5*177 - End Modifications - Resetting PSIVSTRT will recalculate the stop date based on the Last renewed date. + ; + I $S("^NOW^STAT^ONCE^ONE-TIME^ONE TIME^ONETIME^1TIME^1-TIME^1 TIME^"[(U_P(9)_U):1,1:0),PSIVTYPE="P"!P(5)!(P(23)="P") S X=$$ENOSD^PSJDCU(PSJSYSW0,PSIVSTRT,DFN) I X]"" S:P(11)=""&($G(ON)["P") PSIVCAL=1 G END + N DUR,DURMIN,PSJPROV,PSJDNM,A,PSJDAY I $G(PSJORD)["V" S DUR=$$GETDUR^PSJLIVMD(DFN,+PSJORD,"IV",1) I DUR]"" S DURMIN=$$DURMIN^PSJLIVMD(DUR) I DURMIN S PSIMIN=DURMIN + I $G(PSJORD)["P"!($G(PSJORD)["V") N MINS,LIM S PSIVLIM=$$GETLIM(DFN,PSJORD) I PSIVLIM]"" S MINS=$$GETMIN(PSIVLIM,DFN,PSJORD) I MINS,MINSWALL S PSIDAY=$$FMDIFF^XLFDT(WALL,PSIVSTRT,1) S:PSIDAY<1 PSIDAY="" + S DRGT=$S($D(DRG("AD")):"AD",1:"SOL") F ADX=0:0 S ADX=$O(DRG(DRGT,ADX)) Q:'ADX!($G(DRGTMP)&($G(DRGTN)["AD")&(DRGT="SOL")) D + . S OIX=+$P(DRG(DRGT,ADX),"^",6),DDLX=$P(^PS(50.7,OIX,0),"^",5) Q:'DDLX D DDLIM(.PSIDAY,.P3) + I '$G(DRG("AD",0)),$G(DRGTMP),($G(DRGTN)["SOL") S OIX=$P($G(DRGTMP),"^",6) I OIX S DDLX=$P(^PS(50.7,OIX,0),"^",5) I DDLX D DDLIM(.PSIDAY,.P3) + I $G(P3),$G(P(2)) I P3>P(2) S X=P3 G END + S:('PSIDAY&'PSIMIN) PSIDAY=1 +TIME S X2=PSIDAY,X1=PSIVSTRT D C^%DTC S X=$P(X,"."),X=X_$S($P(PSIVSITE,"^",14)="":.2359,1:"."_$P(PSIVSITE,"^",14)) + I PSIMIN,PSIMIN<(PSIDAY*1440) S X=$$FMADD^XLFDT(PSIVSTRT,,,PSIMIN) D + . I '(PSIMIN#1440) S X=$P(X,"."),X=X_$S($P(PSIVSITE,"^",14)="":.2359,1:"."_$P(PSIVSITE,"^",14)) +END ; + S P(3)=+X + I $G(PSJORD)["P" D:'$G(PSGRDTX(+PSJORD,"PSGFD")) REQDT^PSJLIVMD(PSJORD) S P(3)=$S($G(PSGRDTX(+PSJORD,"PSGFD")):PSGRDTX(+PSJORD,"PSGFD"),1:P(3)) + S P(3)=$$DATE2^PSJUTL2(P(3)),P(2)=$$DATE2^PSJUTL2(P(2)) + Q + ; +ENAD ;Will get last admin. time for order (needs dfn and on) + N P4,PSIVX,PSIVY + I $P(PSJSYSW0,U,5)=2 S PSIVADM=$$DATE^PSJUTL2() Q + I $S($G(PSIVAC)["R":1,P(9)="QOD":1,1:P(9)?1"Q".N1"D") S PSIVADM=$$ENSD^PSGNE3(P(9),P(11),+$E(P("LOG"),1,12),+$P($G(^PS(55,DFN,"IV",+P("OLDON"),0)),U,2)) Q:PSIVADM + S PSIVX=X,PSIVY=Y,P4=P(4) S:P(4)="C" P4=P(23) S:P4="S" P4=$S(P(5):"P",1:"A") D NOW^%DTC S Y=%,PSIVNOW=Y I (P4="P"&(P(11)="")&'P(15))!("HA"[P4&'P(15)) S Y=Y+.007\.01/100 G QAD + D P:P4="P"&('P(15)),AH:P(15) +QAD ; + S:'$D(PSGSA) PSGSA="" + S PSIVSD=Y I Y S OD=$L(PSGSA," ") I OD>2 S X=+PSGSA\1 F OD1=2:1:OD-1 I $P(PSGSA," ",OD1)'>$S(OD1>2:$P(PSGSA," ",OD1-1),1:PSGSA#1) S X1=X,X2=1 D C^%DTC + I PSIVSD,OD>2 S Y=X_PSIVSD + S PSIVADM=+Y,X=PSIVX,Y=PSIVY K PSGSA,PSIVSD,OD,OD1,PSIVMI,PSIVNOW S:PSIVADMP(2) S P(3)=X + I DDLX["L",($G(P(9))]""),$G(P(15)),("AH"'[PSIVTYPE) D + . Q:'$G(P(2))!'$G(OIX) N FIRST,DOSAR,LAST,NEWDUR + . S STRING=P(2)_"^"_$S($G(STPDT):STPDT,1:$$FMADD^XLFDT(PSGDT,30))_"^"_P(9)_"^C^"_OIX S FIRST=$$ENQ^PSJORP2(DFN,STRING) + . S FIRST=$S($G(FIRST):FIRST,1:P(2)) Q:'FIRST S DSTMP=FIRST,DOSAR(1)=DSTMP F I=2:1:DDLX+1 S DOSAR(I)=$$FMADD^XLFDT(DSTMP,,,P(15)),DSTMP=DOSAR(I) + . I $D(DOSAR) S LAST=$O(DOSAR(""),-1) I LAST S LAST=DOSAR(LAST) I LAST>P(2) S NEWDUR=$$FMDIFF^XLFDT(LAST,P(2)) I NEWDUR$L(EDIT,U)!(DONE) Q:'$L($P(EDIT,U,PSIVE)) D @($P(EDIT,U,PSIVE)) S:$E(PSIVAC,2)="N" PSIVOK=PSIVOK_U_$P(EDIT,U,PSIVE) I $E(X)=U,$L(X)>1 S:PSIVE>1 PSIVE=PSIVE-1 F D FF Q:Y<0 D @Y Q:$E(X)'=U - K EDIT,PSIVOK,PSGDI - Q - ; -1 ; Provider. - I $G(P("RES"))="R" I $G(PSJORD)["P",$P($G(^PS(53.1,+$G(ON),0)),"^",24)="R" D Q - . W !!?5,"This is Renewal order. Provider may not be edited at this point." D PAUSE^VALM1 - I $G(DFN)&($G(ON)["V") I $$COMPLEX^PSJOE(DFN,ON) D Q - .Q:$G(PSJBKDR) W !!?5,"This is a Complex Order. Provider may not be edited at this point." D PAUSE^VALM1 - S P(6)=$S('$G(^VA(200,+P(6),"PS")):"",'$P(^("PS"),U,4):P(6),$P(^("PS"),U,4)DT:1,1:0)" D ^DIC K DIC I Y>0 S P(6)=+Y_U_Y(0,0) Q - S F1=53.1,F2=1 D ENHLP^PSIVORC1 W $C(7),!!,"A Provider must be entered.",!! G 1 - Q - ; -3 ; Med Route. - I $G(P("RES"))="R" I $G(PSJORD)["P",$P($G(^PS(53.1,+ON,0)),"^",24)="R" D Q - . W !!?5,"Med Route may not be edited at this point." D PAUSE^VALM1 - I $G(DFN)&($G(ON)["V") I $$COMPLEX^PSJOE(DFN,ON) D Q - .Q:$G(PSJBKDR) W !!?5,"This is a Complex Order. Med Route may not be edited at this point." D PAUSE^VALM1 - S P(6)=$S('$G(^VA(200,+P(6),"PS")):"",'$P(^("PS"),U,4):P(6),$P(^("PS"),U,4)1 - .S RT=$O(RT("")) I RT]"" S P("MR")=RT_"^"_$G(RT(RT)) - W !,"MED ROUTE: "_$S($P(P("MR"),U,2)]"":$P(P("MR"),U,2)_"//",1:"") R X:DTIME S:'$T X=U S:X=U DONE=1 I X=U!(X=""&P("MR"))!($E(X)=U) Q - I X["???",($E(P("OT"))="I"),(PSIVAC["C") D ORFLDS^PSIVEDT1 G 3 - I X]"" K DIC S DIC=51.2,DIC(0)="EQMZ",DIC("S")="I $P(^(0),U,4)" D ^DIC K DIC I Y>0 S P("MR")=+Y_U_$P(Y(0),U,3) Q - S F1=53.1,F2=3 D ENHLP^PSIVORC1 W $C(7),!!,"A Med Route must be entered." G 3 - Q - ; -10 ; Start Date. - D 10^PSIVEDT1 - Q - ; -25 ; Stop Date. - D 25^PSIVEDT1 - Q -26 ; Schedule - D 26^PSIVEDT1 - Q - ; -39 ; Admin Times. - D 39^PSIVEDT1 - Q - ; -57 ; Additive. - I $G(P("RES"))="R" I $G(PSJORD)["P",$P($G(^PS(53.1,+ON,0)),"^",24)="R" D Q - . W !!?5,"Additive may not be edited at this point." D PAUSE^VALM1 - I $G(DFN)&($G(ON)["V") I $$COMPLEX^PSJOE(DFN,ON) D Q - .Q:$G(PSJBKDR) W !!?5,"This is a Complex Order. Provider may not be edited at this point." D PAUSE^VALM1 - I $E(PSIVAC)="O" W !!,"Only additives marked for use in IV Fluid Order Entry may be selected." - S FIL=52.6,DRGT="AD",DRGTN="ADDITIVE" D DRG^PSIVEDRG,DKILL - Q - ; -58 ; Solution. - I $G(P("RES"))="R" I $G(PSJORD)["P",$P($G(^PS(53.1,+ON,0)),"^",24)="R" D Q - . W !!?5,"Solution may not be edited at this point." D PAUSE^VALM1 - S FIL=52.7,DRGT="SOL",DRGTN="SOLUTION" D DRG^PSIVEDRG - ; -DKILL ; Kill for drug edit. - K DRGI,DRGN,DRGT,DRGTN,FIL,PSIVSTR - Q - ; -59 ; Infusion Rate. - D 59^PSIVEDT1 - Q - ; -62 ; IV Room. - N DIR S DIR(0)="PA^59.5",DIR("A")="IV Room: ",DIR("??")="^S F1=59.5,F2=.01 D ENHLP^PSIVORC1" S:P("IVRM") DIR("B")=$P(P("IVRM"),U,2) - D ^DIR Q:$D(DIRUT) I Y>0 S P("IVRM")=Y W $P($P(Y,U,2),X,2) - Q - ; -63 ; Remarks. - D 63^PSIVEDT1 - Q - ; -64 ; Other Print Info. - D 64^PSIVEDT1 - Q - ; -66 ; Provider's comments. - N DA,DIE,DIR S DA=PSIVUP,DIE="^PS(53.45,",DR=4 D ^DIE S PSGSI=X,Y=1 - Q - ; -101 ; Orderable Item. - I $G(P("RES"))="R" I $G(PSJORD)["P",$P($G(^PS(53.1,+ON,0)),"^",24)="R" D Q - . W !!?5,"This is Renewal order. Orderable Item may not be edited at this point." D PAUSE^VALM1 - I $G(DFN)&($G(ON)["V") I $$COMPLEX^PSJOE(DFN,ON) D Q - .Q:$G(PSJBKDR) W !!?5,"This is a Complex Order. Orderable Item may not be edited at this point." D PAUSE^VALM1 - W !,"Orderable Item: "_$S(P("PD"):$P(P("PD"),U,2)_"//",1:"") R X:DTIME S:'$T X=U S:X=U DONE=1 I $E(X)=U!(X=""&P("PD")) Q - I X]"" N DIC S DIC="^PS(50.7,",DIC(0)="EMQZ",DIC("B")=$S(P("PD")]"":+$P(("PD"),U),1:""),DIC("S")="S PSJSCT=1 I $$DRGSC^PSIVUTL(Y,PSJSCT) K PSJSCT" D ^DIC K DIC I Y>0 S P("PD")=Y Q - W $C(7),!!,"Orderable Item is required!",!! G 101 - Q -109 ; Dosage Ordered. - W !,"DOSAGE ORDERED: "_$S(P("DO")]"":P("DO")_"//",1:"") R X:DTIME S:'$T X=U S:X=U DONE=1 I $E(X)=U!(P("DO")]""&(X="")) Q - I X="???" D ORFLDS^PSIVEDT1 G 109 - D:X]"" CHK^DIE(53.1,109,"",X,.X) I $G(X)="^" W $C(7),!!,"Enter the dosage in which the Orderable Item entered should be dispensed.",! W "Answer must be 1-20 characters in length." G 109 - S P("DO")=X - Q - ; -FF ; up-arrow to another field. - N DIC S X=$P(X,U,2),DIC="^DD(53.1,",DIC(0)="QEM",DIC("S")="I U_PSIVOK_U[(U_+Y_U)" D ^DIC K DIC S Y=+Y - Q - ; -NEWDRG ; Ask if adding a new drug. - K DIR S DIR(0)="Y",DIR("A")="Are you adding "_$P(TDRG,U,2)_" as a new "_$S(DRGT="AD":"additive",1:"solution")_" for this order",DIR("B")="NO" D ^DIR I $D(DTOUT)!$D(DUOUT) Q - I Y S (DRGI,DRG(DRGT,0))=DRG(DRGT,0)+1,DRG=TDRG,DRG(DRGT,+DRGI)=+DRG_U_$P(DRG,U,2) I DRGT="SOL" S X=$G(^PS(52.7,+DRG,0)),$P(DRG(DRGT,DRG),U,3)=$P(X,U,3) - Q +PSIVEDT ;BIR/MLM-EDIT IV ORDER ;10 Feb 98 / 3:23 PM + ;;5.0; INPATIENT MEDICATIONS ;**4,110,127,133**;16 DEC 97 + ; + ; Reference to ^DD(53.1 is supported by DBIA 2256. + ; Reference to ^PS(52.7 is supported by DBIA 2173. + ; Reference to ^PS(52.6 is supported by DBIA 1231. + ; Reference to ^PS(51.2 is supported by DBIA 2178. + ; Reference to ^PS(50.7 is supported by DBIA 2180. + ; Reference to ^PS(55 is supported by DBIA 2191. + ; +EDIT ; + I $G(DFN)&($G(PSJORD)["V") I $$COMPLEX^PSJOE(DFN,PSJORD) D + . N X,Y,PARENT,P2ND S P2ND=$S($G(^PS(55,PSGP,"IV",+PSJORD,.2)):$G(^PS(55,PSGP,"IV",+PSJORD,.2)),1:$G(^PS(55,PSGP,5,+PSJORD,.2))) + . S PARENT=$P(P2ND,"^",8) + . I PARENT D FULL^VALM1 W !!?5,"This order is part of a complex order. Please review the following ",!?5,"associated orders before changing this order." D CMPLX^PSJCOM1(PSGP,PARENT,PSJORD) + S DONE=0 + F PSIVE=1:1 S:DONE&$E(PSIVAC)="C" OREND=1 Q:PSIVE>$L(EDIT,U)!(DONE) Q:'$L($P(EDIT,U,PSIVE)) D @($P(EDIT,U,PSIVE)) S:$E(PSIVAC,2)="N" PSIVOK=PSIVOK_U_$P(EDIT,U,PSIVE) I $E(X)=U,$L(X)>1 S:PSIVE>1 PSIVE=PSIVE-1 F D FF Q:Y<0 D @Y Q:$E(X)'=U + K EDIT,PSIVOK,PSGDI + Q + ; +1 ; Provider. + I $G(P("RES"))="R" I $G(PSJORD)["P",$P($G(^PS(53.1,+$G(ON),0)),"^",24)="R" D Q + . W !!?5,"This is Renewal order. Provider may not be edited at this point." D PAUSE^VALM1 + I $G(DFN)&($G(ON)["V") I $$COMPLEX^PSJOE(DFN,ON) D Q + .Q:$G(PSJBKDR) W !!?5,"This is a Complex Order. Provider may not be edited at this point." D PAUSE^VALM1 + S P(6)=$S('$G(^VA(200,+P(6),"PS")):"",'$P(^("PS"),U,4):P(6),$P(^("PS"),U,4)DT:1,1:0)" D ^DIC K DIC I Y>0 S P(6)=+Y_U_Y(0,0) Q + S F1=53.1,F2=1 D ENHLP^PSIVORC1 W $C(7),!!,"A Provider must be entered.",!! G 1 + Q + ; +3 ; Med Route. + I $G(P("RES"))="R" I $G(PSJORD)["P",$P($G(^PS(53.1,+ON,0)),"^",24)="R" D Q + . W !!?5,"Med Route may not be edited at this point." D PAUSE^VALM1 + I $G(DFN)&($G(ON)["V") I $$COMPLEX^PSJOE(DFN,ON) D Q + .Q:$G(PSJBKDR) W !!?5,"This is a Complex Order. Med Route may not be edited at this point." D PAUSE^VALM1 + S P(6)=$S('$G(^VA(200,+P(6),"PS")):"",'$P(^("PS"),U,4):P(6),$P(^("PS"),U,4)0 S P("MR")=+Y_U_$P(Y(0),U,3) Q + S F1=53.1,F2=3 D ENHLP^PSIVORC1 W $C(7),!!,"A Med Route must be entered." G 3 + Q + ; +10 ; Start Date. + D 10^PSIVEDT1 + Q + ; +25 ; Stop Date. + D 25^PSIVEDT1 + Q +26 ; Schedule + D 26^PSIVEDT1 + Q + ; +39 ; Admin Times. + D 39^PSIVEDT1 + Q + ; +57 ; Additive. + I $G(P("RES"))="R" I $G(PSJORD)["P",$P($G(^PS(53.1,+ON,0)),"^",24)="R" D Q + . W !!?5,"Additive may not be edited at this point." D PAUSE^VALM1 + I $G(DFN)&($G(ON)["V") I $$COMPLEX^PSJOE(DFN,ON) D Q + .Q:$G(PSJBKDR) W !!?5,"This is a Complex Order. Provider may not be edited at this point." D PAUSE^VALM1 + I $E(PSIVAC)="O" W !!,"Only additives marked for use in IV Fluid Order Entry may be selected." + S FIL=52.6,DRGT="AD",DRGTN="ADDITIVE" D DRG^PSIVEDRG,DKILL + Q + ; +58 ; Solution. + I $G(P("RES"))="R" I $G(PSJORD)["P",$P($G(^PS(53.1,+ON,0)),"^",24)="R" D Q + . W !!?5,"Solution may not be edited at this point." D PAUSE^VALM1 + S FIL=52.7,DRGT="SOL",DRGTN="SOLUTION" D DRG^PSIVEDRG + ; +DKILL ; Kill for drug edit. + K DRGI,DRGN,DRGT,DRGTN,FIL,PSIVSTR + Q + ; +59 ; Infusion Rate. + D 59^PSIVEDT1 + Q + ; +62 ; IV Room. + N DIR S DIR(0)="PA^59.5",DIR("A")="IV Room: ",DIR("??")="^S F1=59.5,F2=.01 D ENHLP^PSIVORC1" S:P("IVRM") DIR("B")=$P(P("IVRM"),U,2) + D ^DIR Q:$D(DIRUT) I Y>0 S P("IVRM")=Y W $P($P(Y,U,2),X,2) + Q + ; +63 ; Remarks. + D 63^PSIVEDT1 + Q + ; +64 ; Other Print Info. + D 64^PSIVEDT1 + Q + ; +66 ; Provider's comments. + N DA,DIE,DIR S DA=PSIVUP,DIE="^PS(53.45,",DR=4 D ^DIE S PSGSI=X,Y=1 + Q + ; +101 ; Orderable Item. + I $G(P("RES"))="R" I $G(PSJORD)["P",$P($G(^PS(53.1,+ON,0)),"^",24)="R" D Q + . W !!?5,"This is Renewal order. Orderable Item may not be edited at this point." D PAUSE^VALM1 + I $G(DFN)&($G(ON)["V") I $$COMPLEX^PSJOE(DFN,ON) D Q + .Q:$G(PSJBKDR) W !!?5,"This is a Complex Order. Orderable Item may not be edited at this point." D PAUSE^VALM1 + W !,"Orderable Item: "_$S(P("PD"):$P(P("PD"),U,2)_"//",1:"") R X:DTIME S:'$T X=U S:X=U DONE=1 I $E(X)=U!(X=""&P("PD")) Q + I X]"" N DIC S DIC="^PS(50.7,",DIC(0)="EMQZ",DIC("B")=$S(P("PD")]"":+$P(("PD"),U),1:""),DIC("S")="S PSJSCT=1 I $$DRGSC^PSIVUTL(Y,PSJSCT) K PSJSCT" D ^DIC K DIC I Y>0 S P("PD")=Y Q + W $C(7),!!,"Orderable Item is required!",!! G 101 + Q +109 ; Dosage Ordered. + W !,"DOSAGE ORDERED: "_$S(P("DO")]"":P("DO")_"//",1:"") R X:DTIME S:'$T X=U S:X=U DONE=1 I $E(X)=U!(P("DO")]""&(X="")) Q + I X="???" D ORFLDS^PSIVEDT1 G 109 + D:X]"" CHK^DIE(53.1,109,"",X,.X) I $G(X)="^" W $C(7),!!,"Enter the dosage in which the Orderable Item entered should be dispensed.",! W "Answer must be 1-20 characters in length." G 109 + S P("DO")=X + Q + ; +FF ; up-arrow to another field. + N DIC S X=$P(X,U,2),DIC="^DD(53.1,",DIC(0)="QEM",DIC("S")="I U_PSIVOK_U[(U_+Y_U)" D ^DIC K DIC S Y=+Y + Q + ; +NEWDRG ; Ask if adding a new drug. + K DIR S DIR(0)="Y",DIR("A")="Are you adding "_$P(TDRG,U,2)_" as a new "_$S(DRGT="AD":"additive",1:"solution")_" for this order",DIR("B")="NO" D ^DIR I $D(DTOUT)!$D(DUOUT) Q + I Y S (DRGI,DRG(DRGT,0))=DRG(DRGT,0)+1,DRG=TDRG,DRG(DRGT,+DRGI)=+DRG_U_$P(DRG,U,2) I DRGT="SOL" S X=$G(^PS(52.7,+DRG,0)),$P(DRG(DRGT,DRG),U,3)=$P(X,U,3) + Q diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVORA.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVORA.m index 18559718..0906ab96 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVORA.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVORA.m @@ -1,101 +1,103 @@ -PSIVORA ;BIR/MLM-MAIN DRIVER FOR IV FLUIDS - OE/RR INTERFACE ;08 JAN 97 / 2:47 PM - ;;5.0; INPATIENT MEDICATIONS ;**29,41,110,134**;16 DEC 97;Build 124 - ; - ; Reference to ^PS(55 is supported by DBIA 2191 - ; -EN ; Entry point called by IV Fluid protocol. - S X=ORACTION,PSIVAC="O"_$S(X=0:"N",X=1:"E",X=2:"R",X=4:"H",X=6:"D",X="8":"S",1:"") S:X'=5&(X'=7) PSIVUP=+$$GTPCI^PSIVUTL - S (PSGP,DFN)=+ORVP,PSJACNWP=1 D ^PSJAC I "578"[ORACTION D @ORACTION,DONE^PSIVORA1 Q - D ENCPP^PSIVOREN Q:'PSJIVORF!('PSJORF) D EN1,DONE^PSIVORA1 - Q - ; -EN1 ; Take action on existing order. - S PSJORD=$G(ORPK) I ORGY>8 D @ORGY Q - I 'ORACTION D ^PSIVORFE Q - I '$G(ORPK) W !,"INSUFFICIENT INFORMATION, CANNOT CONTINUE." S OREND=1 Q - I ORPK["V",($P($G(^PS(55,DFN,"IV",+ORPK,0)),U,17)="O") D ONCALL^PSIVORV1 Q - I ORACTION<3 S P("FRES")=$S(ORPK["V":$P($G(^PS(55,DFN,"IV",+ORPK,2)),U,9),1:$P($G(^PS(53.1,+ORPK,0)),U,27)) I P("FRES")]"" D @$S(P("FRES")="R":"ALLREN^PSIVORV1",1:"ALLED^PSIVORV1") Q - S PSJORSTS=ORSTS,PSJORIFN=ORIFN L +@$S(PSJORD["V":"^PS(55,DFN,""IV"",+PSJORD)",1:"^PS(53.1,+PSJORD)"):1 E D LOCKERR^PSIVORA1 Q - D @ORACTION L -@$S(PSJORD["V":"^PS(55,DFN,""IV"",+PSJORD)",1:"^PS(53.1,+PSJORD)") - Q - ; -1 ; Edit an existing order. - D EDIT^PSIVORA1 - Q - ; -2 ; Renew - D RENEW^PSIVORA1 - Q - ; -3 ; Flag - Q - ; -4 ; Hold - I ORSTS'=3,ORSTS'=6 W !,$C(7),"Only ACTIVE orders may be placed on HOLD." S OREND=1 Q - S PSIVREA=$S(ORSTS=6:"H",1:"U"),ON55=PSJORD,$P(^PS(55,DFN,"IV",+ON55,0),U,10)=$S(PSIVREA="H":1,1:""),Y=$G(^PS(55,DFN,"IV",+ON55,0)),P(3)=$P(Y,U,3),P(17)=$P(Y,U,17) - D NOW^%DTC I ORSTS=3,P(3)<% S P(17)="E" D UPSTAT^PSIVOPT S ORSTS=7 W $C(7)," This order has expired." Q - S XED=0,PSIVALT=2,P(17)=$S(PSIVREA="H":"H",1:"A") D UPSTAT^PSIVOPT,LOG^PSIVORAL S ORSTS=$S(PSIVREA="H":3,1:6) - Q - ; -5 ; Event - N DA,DIE,DR,ON,P,PSIVACT,X - S ON=ORPK I ON["V" S X=$G(^PS(55,+ORVP,"IV",+ON,0)),P(3)=$P(X,U,3),P(17)=$P(X,U,17) - I ON'["V" S P(3)=$P($G(^PS(53.1,+ON,2)),U,4),P(17)=$P($G(^PS(53.1,+ON,0)),U,9) - Q:"AR"'[P(17) D NOW^%DTC Q:P(3)>% - I ON["V" S DR="100///E",DIE="^PS(55,"_+ORVP_",""IV"",",DA(1)=+ORVP - I ON'["V" S DR="28///E",DIE="^PS(53.1," - S PSIVACT=1,DA=+ON D ^DIE S ORSTS=7 - Q - ; -6 ; Cancel - Delete pending or unreleased orders from Nonverified orders - ; (53.1) and Orders (100) files. - I ORSTS=1 W $C(7),!,"This order has already been DISCONTINUED." Q - I ORSTS=7 W $C(7),!,"Expired orders cannot be DISCONTINUED." Q - I PSJORD'["V",ORSTS=11 D Q - .S P("OLDON")=$P($G(^PS(53.1,+PSJORD,0)),U,25) I P("OLDON") D - ..I P("OLDON")["V",$D(^PS(55,DFN,"IV",+P("OLDON"),2)) S PSJRES=$P(^(2),U,9) S:PSJRES'="R" $P(^(2),U,6)="",$P(^(2),U,9)="" ;; D:PSJRES="R" ENBKOUT^PSJOREN(DFN,PSJORD) - ..I P("OLDON")'["V",$D(^PS(53.1,+P("OLDON"),0)) S PSJRES=$P(^(0),U,27) S:PSJRES'="R" $P(^(0),U,26,27)="^" I PSJRES="R" ;; D ENBKOUT^PSJOREN(DFN,PSJORD) - .K DA,DIK S DIK="^PS(53.1,",DA=+PSJORD D ^DIK S PSGP=DFN,X="P" D ENSK^PSGAXR K DA,DIK S ORIFN=PSJORIFN,ORSTS="K" Q - ; -DC ; DC order from Pharmacy complete function. - I PSJORD["V",'PSJCOM N PSIVREA S ON55=PSJORD,X=$G(^PS(55,DFN,"IV",+ON55,0)),P(3)=$P(X,U,3),P(17)=$P(X,U,17),PSIVREA="D",PSIVALT=2,PSIVALCK="STOP" D D^PSIVOPT2 D HL Q - I PSJORD["V",PSJCOM N PSIVREA S ON55=PSJORD,X=$G(^PS(55,DFN,"IV",+ON55,0)),P(3)=$P(X,U,3),P(17)=$P(X,U,17),PSIVREA="D",PSIVALT=2,PSIVALCK="STOP" D D^PSIVOPT2 Q - N DA,DR,DIE,PSJND S DA=+PSJORD,PSJND=$G(^PS(53.1,DA,0)),P("OLDON")=$P(PSJND,U,25),DIE="^PS(53.1,",DR="28///"_$S($P(PSJND,U,27)="E":"DE",1:"D") D ^DIE - D HL - Q -HL ; - Q:'$D(P("NAT")) - NEW PSJCD,PSJTX,PSJOTMP - I PSJORD["P" N PSJNOO S PSJCD="OC",PSJTX="ORDER CANCELED",PSJNOO=$G(P("NAT")) - E S PSJCD="OD",PSJTX="ORDER DISCONTINUED" - S PSJOTMP=$G(P("OT")) S P("OT")="F" D EN1^PSJHL2(DFN,PSJCD,PSJORD,PSJTX) - Q - ; -7 ; Purge - N ND S ND=$S(ORPK["V":$P($G(^PS(55,+ORVP,"IV",+ORPK,0)),U,17)_U_$P($G(^(0)),U,3),1:$P($G(^PS(53.1,+ORPK,0)),U,9)_U_$P($G(^(2)),U,4)) - Q:"DE"'[$P(ND,U) S X1=+$P(ND,U,2),X2=30 D C^%DTC S ND=X D NOW^%DTC Q:ND>% - I ORPK["V",$D(^PS(55,+ORVP,"IV",+ORPK,0)) S $P(^(0),U,21)="" - I ORPK'["V",$D(^PS(53.1,+ORPK,0)) S $P(^(0),U,21)="" - S ORSTS="K" - Q - ; -8 ; Print - K DIR S DIR(0)="E" D ^DIR K DIR I $D(DUOUT)!'($D(ORPK)) S OREND=1 Q - S:'$G(PSIVUP) PSIVUP=+$$GTPCI^PSIVUTL S:'$D(PSIVAC) PSIVAC="OS" S (ON,ON55)=ORPK,DFN=+ORVP D @$S(ON["V":"GT55^PSIVORFB",1:"GT531^PSIVORFA("_DFN_","""_ON_""")"),ENDT^PSIVORV1 - Q - ; -9 ; Release order (status=incomplete in 53.1, pending in 100) - S X=ORACTION I X=4!(X=6) D @ORACTION Q - Q:"36"[ORSTS N ON,PSJORIFN S PSJORIFN=ORIFN,ON=ORPK L +^PS(53.1,+ON):1 E D LOCKERR^PSIVORA1 Q - S Y=$G(^PS(53.1,+ON,0)),P("RES")=$P(Y,U,24),P("OLDON")=$P(Y,U,25) - N DA,DIE,DR,OREND S DR="28////P",DIE="^PS(53.1,",DA=+ON D ^DIE - I P("OLDON")]"" K DA,DIE,DR S DA=P("OLDON") D - .I DA["V" S DA(1)=+ORPV,DIE="^PS(55,"_DA(1)_",""IV"",",DR="114////"_+ON_"P"_";123////"_P("RES") - .E S DIE="^PS(53.1,",DR="105////"_ON_"P"_";107////"_P("RES") I P("RES")="E",$P($G(^PS(53.1,+P("OLDON"),0)),U,9)="D" S DR=DR_";28////DE" - .S DA=+DA L +@(DIE_DA_")"):1 E D LOCKERR^PSIVORA1 Q - .D ^DIE L -@(DIE_DA_")") - L -^PS(53.1,+ON) D DONE^PSIVORA1 - Q - ; -10 ; Verify - Q +PSIVORA ;BIR/MLM-MAIN DRIVER FOR IV FLUIDS - OE/RR INTERFACE ;08 JAN 97 / 2:47 PM + ;;5.0; INPATIENT MEDICATIONS ;**29,41,110**;16 DEC 97 + ; + ; Reference to ^PS(55 is supported by DBIA 2191 + ; +EN ; Entry point called by IV Fluid protocol. + S X=ORACTION,PSIVAC="O"_$S(X=0:"N",X=1:"E",X=2:"R",X=4:"H",X=6:"D",X="8":"S",1:"") S:X'=5&(X'=7) PSIVUP=+$$GTPCI^PSIVUTL + S (PSGP,DFN)=+ORVP,PSJACNWP=1 D ^PSJAC I "578"[ORACTION D @ORACTION,DONE^PSIVORA1 Q + D ENCPP^PSIVOREN Q:'PSJIVORF!('PSJORF) D EN1,DONE^PSIVORA1 + Q + ; +EN1 ; Take action on existing order. + S PSJORD=$G(ORPK) I ORGY>8 D @ORGY Q + I 'ORACTION D ^PSIVORFE Q + I '$G(ORPK) W !,"INSUFFICIENT INFORMATION, CANNOT CONTINUE." S OREND=1 Q + I ORPK["V",($P($G(^PS(55,DFN,"IV",+ORPK,0)),U,17)="O") D ONCALL^PSIVORV1 Q + I ORACTION<3 S P("FRES")=$S(ORPK["V":$P($G(^PS(55,DFN,"IV",+ORPK,2)),U,9),1:$P($G(^PS(53.1,+ORPK,0)),U,27)) I P("FRES")]"" D @$S(P("FRES")="R":"ALLREN^PSIVORV1",1:"ALLED^PSIVORV1") Q + S PSJORSTS=ORSTS,PSJORIFN=ORIFN L +@$S(PSJORD["V":"^PS(55,DFN,""IV"",+PSJORD)",1:"^PS(53.1,+PSJORD)"):1 E D LOCKERR^PSIVORA1 Q + D @ORACTION L -@$S(PSJORD["V":"^PS(55,DFN,""IV"",+PSJORD)",1:"^PS(53.1,+PSJORD)") + Q + ; +1 ; Edit an existing order. + D EDIT^PSIVORA1 + Q + ; +2 ; Renew + D RENEW^PSIVORA1 + Q + ; +3 ; Flag + Q + ; +4 ; Hold + I ORSTS'=3,ORSTS'=6 W !,$C(7),"Only ACTIVE orders may be placed on HOLD." S OREND=1 Q + S PSIVREA=$S(ORSTS=6:"H",1:"U"),ON55=PSJORD,$P(^PS(55,DFN,"IV",+ON55,0),U,10)=$S(PSIVREA="H":1,1:""),Y=$G(^PS(55,DFN,"IV",+ON55,0)),P(3)=$P(Y,U,3),P(17)=$P(Y,U,17) + D NOW^%DTC I ORSTS=3,P(3)<% S P(17)="E" D UPSTAT^PSIVOPT S ORSTS=7 W $C(7)," This order has expired." Q + S XED=0,PSIVALT=2,P(17)=$S(PSIVREA="H":"H",1:"A") D UPSTAT^PSIVOPT,LOG^PSIVORAL S ORSTS=$S(PSIVREA="H":3,1:6) + Q + ; +5 ; Event + N DA,DIE,DR,ON,P,PSIVACT,X + S ON=ORPK I ON["V" S X=$G(^PS(55,+ORVP,"IV",+ON,0)),P(3)=$P(X,U,3),P(17)=$P(X,U,17) + I ON'["V" S P(3)=$P($G(^PS(53.1,+ON,2)),U,4),P(17)=$P($G(^PS(53.1,+ON,0)),U,9) + Q:"AR"'[P(17) D NOW^%DTC Q:P(3)>% + I ON["V" S DR="100///E",DIE="^PS(55,"_+ORVP_",""IV"",",DA(1)=+ORVP + I ON'["V" S DR="28///E",DIE="^PS(53.1," + S PSIVACT=1,DA=+ON D ^DIE S ORSTS=7 + Q + ; +6 ; Cancel - Delete pending or unreleased orders from Nonverified orders + ; (53.1) and Orders (100) files. + I ORSTS=1 W $C(7),!,"This order has already been DISCONTINUED." Q + I ORSTS=7 W $C(7),!,"Expired orders cannot be DISCONTINUED." Q + I PSJORD'["V",ORSTS=11 D Q + .S P("OLDON")=$P($G(^PS(53.1,+PSJORD,0)),U,25) I P("OLDON") D + ..I P("OLDON")["V",$D(^PS(55,DFN,"IV",+P("OLDON"),2)) S PSJRES=$P(^(2),U,9) S:PSJRES'="R" $P(^(2),U,6)="",$P(^(2),U,9)="" ;; D:PSJRES="R" ENBKOUT^PSJOREN(DFN,PSJORD) + ..I P("OLDON")'["V",$D(^PS(53.1,+P("OLDON"),0)) S PSJRES=$P(^(0),U,27) S:PSJRES'="R" $P(^(0),U,26,27)="^" I PSJRES="R" ;; D ENBKOUT^PSJOREN(DFN,PSJORD) + .K DA,DIK S DIK="^PS(53.1,",DA=+PSJORD D ^DIK S PSGP=DFN,X="P" D ENSK^PSGAXR K DA,DIK S ORIFN=PSJORIFN,ORSTS="K" Q + ; +DC ; DC order from Pharmacy complete function. + I PSJORD["V",'PSJCOM N PSIVREA S ON55=PSJORD,X=$G(^PS(55,DFN,"IV",+ON55,0)),P(3)=$P(X,U,3),P(17)=$P(X,U,17),PSIVREA="D",PSIVALT=2,PSIVALCK="STOP" D D^PSIVOPT2 D HL Q + I PSJORD["V",PSJCOM N PSIVREA S ON55=PSJORD,X=$G(^PS(55,DFN,"IV",+ON55,0)),P(3)=$P(X,U,3),P(17)=$P(X,U,17),PSIVREA="D",PSIVALT=2,PSIVALCK="STOP" D D^PSIVOPT2 Q + N DA,DR,DIE,PSJND S DA=+PSJORD,PSJND=$G(^PS(53.1,DA,0)),P("OLDON")=$P(PSJND,U,25),DIE="^PS(53.1,",DR="28///"_$S($P(PSJND,U,27)="E":"DE",1:"D") D ^DIE + D HL + Q +HL ; + Q:'$D(P("NAT")) + ;D EN1^PSJHL2(DFN,"OC",PSJORD,"ORDER CANCELED") + NEW PSJCD,PSJTX + I PSJORD["P" N PSJNOO S PSJCD="OC",PSJTX="ORDER CANCELED",PSJNOO=$G(P("NAT")) + E S PSJCD="OD",PSJTX="ORDER DISCONTINUED" + D EN1^PSJHL2(DFN,PSJCD,PSJORD,PSJTX) + ;D UNL^PSSLOCK(DFN,PSJORD) + Q + ; +7 ; Purge + N ND S ND=$S(ORPK["V":$P($G(^PS(55,+ORVP,"IV",+ORPK,0)),U,17)_U_$P($G(^(0)),U,3),1:$P($G(^PS(53.1,+ORPK,0)),U,9)_U_$P($G(^(2)),U,4)) + Q:"DE"'[$P(ND,U) S X1=+$P(ND,U,2),X2=30 D C^%DTC S ND=X D NOW^%DTC Q:ND>% + I ORPK["V",$D(^PS(55,+ORVP,"IV",+ORPK,0)) S $P(^(0),U,21)="" + I ORPK'["V",$D(^PS(53.1,+ORPK,0)) S $P(^(0),U,21)="" + S ORSTS="K" + Q + ; +8 ; Print + K DIR S DIR(0)="E" D ^DIR K DIR I $D(DUOUT)!'($D(ORPK)) S OREND=1 Q + S:'$G(PSIVUP) PSIVUP=+$$GTPCI^PSIVUTL S:'$D(PSIVAC) PSIVAC="OS" S (ON,ON55)=ORPK,DFN=+ORVP D @$S(ON["V":"GT55^PSIVORFB",1:"GT531^PSIVORFA("_DFN_","""_ON_""")"),ENDT^PSIVORV1 + Q + ; +9 ; Release order (status=incomplete in 53.1, pending in 100) + S X=ORACTION I X=4!(X=6) D @ORACTION Q + Q:"36"[ORSTS N ON,PSJORIFN S PSJORIFN=ORIFN,ON=ORPK L +^PS(53.1,+ON):1 E D LOCKERR^PSIVORA1 Q + S Y=$G(^PS(53.1,+ON,0)),P("RES")=$P(Y,U,24),P("OLDON")=$P(Y,U,25) + N DA,DIE,DR,OREND S DR="28////P",DIE="^PS(53.1,",DA=+ON D ^DIE + I P("OLDON")]"" K DA,DIE,DR S DA=P("OLDON") D + .I DA["V" S DA(1)=+ORPV,DIE="^PS(55,"_DA(1)_",""IV"",",DR="114////"_+ON_"P"_";123////"_P("RES") + .E S DIE="^PS(53.1,",DR="105////"_ON_"P"_";107////"_P("RES") I P("RES")="E",$P($G(^PS(53.1,+P("OLDON"),0)),U,9)="D" S DR=DR_";28////DE" + .S DA=+DA L +@(DIE_DA_")"):1 E D LOCKERR^PSIVORA1 Q + .D ^DIE L -@(DIE_DA_")") + L -^PS(53.1,+ON) D DONE^PSIVORA1 + Q + ; +10 ; Verify + Q diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVORC.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVORC.m index d7bbe8cf..c4f2860b 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVORC.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVORC.m @@ -1,104 +1,97 @@ -PSIVORC ;BIR/MLM-COMPLETE IV ORDERS ENTERED THROUGH OE/RR ;02 Mar 99 / 10:16 AM - ;;5.0; INPATIENT MEDICATIONS ;**23,53,80,110,134**;16 DEC 97;Build 124 - ; - ; Reference to ^DIC(42 is supported by DBIA 10039 - ; Reference to ^DPT is supported by DBIA 10035 - ; Reference to ^%DTC is supported by DBIA 10000 - ; Reference to ^DID is supported by DBIA 2052 - ; -EN ; Set IV parameters. - D SITE^PSIVORE Q:'$G(PSIVQ) K PSIVQ - ; -SELECT ; - F S PSGSSH="ORVC" D ^PSGSEL Q:U[PSGSS D GTORDRS - D DONE^PSIVORC1 - Q -GTORDRS ; - K ^TMP("PSIV",$J) N DIC,Y D @PSGSS Q:+$G(Y)'>0 W:PSGSS'="P" !,"...a few moments, please..." D @("G"_PSGSS) - I $G(Y),'$D(^TMP("PSIV",$J)) W !,$C(7),"NO PENDING ORDERS FOR ",$S(PSGSS="P":"PATIENT",1:"WARD"),$S(PSGSS="G":" GROUP",1:"")," SELECTED." Q - D NOW^%DTC S HDT=$$ENDTC^PSGMI(%),PSIVAC="C",DONE=0,WDN="" - F S WDN=$O(^TMP("PSIV",$J,WDN)) Q:WDN=""!DONE S PNME="" F S PNME=$O(^TMP("PSIV",$J,WDN,PNME)) Q:PNME=""!DONE D - . I PSGSS'="P" S PSGDFN=$P(PNME,";",2)_"^"_$P(PNME,";") D CHK^PSJDPT(.PSGDFN,1,1) I PSGDFN=-1 Q - . D PROFILE D:PSIVHD ASK - D:$G(PSIVHD) ASK - Q - ; -PROFILE ; Display profile of all incomplete orders. - ; - K PSGODDD S (DFN,PSGP)=$P(PNME,";",2) D ENBOTH^PSJAC - S RB=PSJPRB,PG=1,PSJORL=$$ENORL^PSJUTL($G(VAIN(4))),PSJIVOF=PSJORL,PSGLMT=0,LN2="" D ENHEAD^PSJO3 - S (DONE1,TYP)="" F S TYP=$O(^TMP("PSIV",$J,WDN,PNME,TYP)) Q:TYP=""!(DONE1) D:$Y+5'>IOSL GTYP F ON1=0:0 S ON1=$O(^TMP("PSIV",$J,WDN,PNME,TYP,ON1)) Q:'ON1!(DONE1) D DISPLAY - Q - ; -DISPLAY ; Display order on profile. - I $Y+5>IOSL D ASK Q:DONE1 D ENHEAD^PSJO3,GTYP - S PSIVHD=1,PSGLMT=PSGLMT+1,PSIVCV(PSGLMT)=ON1,PSJC="" W !?3,PSGLMT D PIV^PSIVUTL(+ON1_"P") - Q - ; -GTYP ; Get formatted heading for type - N PSJD5314 D FIELD^DID(53.1,4,"","POINTER","PSJD5314") - ; removed ^DD ref 3-2-99, pass ^^_set of codes value - ; because codes^psivutl uses the 3rd piece - S X=$$CODES^PSIVUTL(TYP,"^^"_PSJD5314("POINTER"),"") - S PSIV=$S(X]"":X,1:"UNKNOWN"),X="",$P(X,"-",40-($L(PSIV)/2))="" W !,X_PSIV_X - Q - ; -ASK ; Ask which orders to view. - S PSIVHD=0,ACTION="ORDER" D RD1^PSGON I X="^" S (DONE,DONE1)=1 Q - Q:'$D(PSGODDD) S DONE1=0 F PN=1:1:$L(PSGODDD(1),",")-1 S ON=+$P(PSGODDD(1),",",PN) Q:ON=""!DONE1 S ON=+$P(PSGODDD(1),",",PN) D SHOW - S DONE1=1,PSGOP=DFN D:$P(PSJSYSL,U,2)]"" ENQL^PSGLW - Q - ; -SHOW ; Display selected order and prompt for action - S (P("PON"),ON)=PSIVCV(ON) - ; -SHOW1 ; Entry point from backdoor. - S PSIVUP=+$$GTPCI^PSIVUTL D GT531^PSIVORFA(DFN,ON) I $G(PSIVAC)="PRO" D ENNONUM^PSIVORV2(DFN,ON) Q - I $G(PSJORD)["P" D REQDT^PSJLIVMD(PSJORD) - S PSJORD=+ON D ^PSJLIFN - Q - ; - ; look-ups on ward group, ward, or patient; depending on value of SS -G S DIC="^PS(57.5,",DIC(0)="QEAMI",DIC("A")="Select WARD GROUP: " W ! D ^DIC S:+Y>0 WG=+Y Q -W S DIC="^DIC(42,",DIC(0)="QEAMI",DIC("A")="Select WARD: " W ! D ^DIC S:+Y>0 WD=+Y Q -P D ENGETP^PSIV Q:DFN<0 S Y=1 I $D(^PS(53.1,"AS","P",+DFN)) S PNME=$G(^DPT(+DFN,0)),PNME=$P(PNME,U)_";"_DFN,WDN=$S(VAIN(4)]"":$P(VAIN(4),U,2),1:"OUTPATIENT") D GP - Q - ; -GG ; put patient(s) with incomplete orders into array - F WD=0:0 S WD=$O(^PS(57.5,"AC",WG,WD)) Q:'WD D GW - Q -GW S WDN=$G(^DIC(42,WD,0)),WDN=$P(WDN,U) I WDN]"" F DFN=0:0 S DFN=$O(^DPT("CN",WDN,DFN)) Q:'DFN I $D(^PS(53.1,"AS","P",DFN)) S Y=$G(^DPT(+DFN,0)),PNME=$P(Y,U)_";"_DFN D:PNME]"" GP - Q -GP ; - F ON=0:0 S ON=$O(^PS(53.1,"AS","P",DFN,ON)) Q:'ON S Y=$G(^PS(53.1,ON,0)),TYP=$S($P(Y,U,4)]"":$P(Y,U,4),1:"Z"),^TMP("PSIV",$J,WDN,PNME,TYP,ON)="" - Q -DISCONT ; Cancel incomplete order - N PSJDCTYP I $G(ON)["P",$P($G(^PS(53.1,+$G(ON),0)),"^",24)="R" S PSJDCTYP=$$PNDRNA^PSGOEC(ON) I $G(PSJDCTYP)'=1 D PNDRN(PSJDCTYP) Q -D2 ; Called from PNDRN for pending order - D:'$D(PSJIVORF) ORPARM^PSIVOREN I PSJIVORF D NATURE^PSIVOREN I '$D(P("NAT")) W !,$C(7),"Order Unchanged." Q - ;Prompt for requesting provider - W ! I '$$REQPROV^PSGOEC W !,$C(7),"Order Unchanged." K PSJDCTYP Q - W ! - ; -D3 ; called from PNDRN for original order - I 'PSJCOM N PSJORNAT S PSJORIFN=$P($G(^PS(53.1,+ON,0)),U,21),PSJORD=ON,PSJORNAT=P("NAT") D DC^PSIVORA ;* I PSJIVORF,PSJORIFN,(ON["V") D EN1^PSJHL2(PSGP,"OD",+ON_"V","ORDER DISCONTINUED") - I PSJCOM,PSJORD["P" N O S O="" F S O=$O(^PS(53.1,"ACX",PSJCOM,O)) Q:O="" D - .S ON=O_"P",PSJORIFN=$P($G(^PS(53.1,+ON,0)),U,21),PSJORD=ON,PSJORNAT=P("NAT") D DC^PSIVORA - W !,"Order discontinued.",! - Q - ; -EDIT ; Edit incomplete order - S PSIVAC="CE" L +^PS(53.1,+ON):1 E W !,$C(7),"This order LOCKED by another user." Q - D EDIT^PSIVORC2 L -^PS(53.1,+ON) - Q - ; -FINISH ; Finish incomplete order - S PSIVAC="CF" L +^PS(53.1,+ON):1 E W !,$C(7),"This order LOCKED by another user." Q - D FINISH^PSIVORC2 L -^PS(53.1,+ON) - Q - ; -PNDRN(PSJDCTYP) ; Discontinue pending renewal only or both pending and original orders - I PSJDCTYP=2 S PSJDCTYP=1 D D2 Q:'$G(PSJDCTYP) D - .N ND5310 S ND5310=$G(^PS(53.1,+ON,0)) - .N ON S ON=$P(ND5310,"^",25) I ON S PSJDCTYP=2 D D3 - Q +PSIVORC ;BIR/MLM-COMPLETE IV ORDERS ENTERED THROUGH OE/RR ;02 Mar 99 / 10:16 AM + ;;5.0; INPATIENT MEDICATIONS ;**23,53,80,110**;16 DEC 97 + ; + ; Reference to ^DIC(42 is supported by DBIA 10039 + ; Reference to ^DPT is supported by DBIA 10035 + ; Reference to ^%DTC is supported by DBIA 10000 + ; Reference to ^DID is supported by DBIA 2052 + ; +EN ; Set IV parameters. + D SITE^PSIVORE Q:'$G(PSIVQ) K PSIVQ + ; +SELECT ; + F S PSGSSH="ORVC" D ^PSGSEL Q:U[PSGSS D GTORDRS + D DONE^PSIVORC1 + Q +GTORDRS ; + K ^TMP("PSIV",$J) N DIC,Y D @PSGSS Q:+$G(Y)'>0 W:PSGSS'="P" !,"...a few moments, please..." D @("G"_PSGSS) + I $G(Y),'$D(^TMP("PSIV",$J)) W !,$C(7),"NO PENDING ORDERS FOR ",$S(PSGSS="P":"PATIENT",1:"WARD"),$S(PSGSS="G":" GROUP",1:"")," SELECTED." Q + D NOW^%DTC S HDT=$$ENDTC^PSGMI(%),PSIVAC="C",DONE=0,WDN="" + F S WDN=$O(^TMP("PSIV",$J,WDN)) Q:WDN=""!DONE S PNME="" F S PNME=$O(^TMP("PSIV",$J,WDN,PNME)) Q:PNME=""!DONE D + . I PSGSS'="P" S PSGDFN=$P(PNME,";",2)_"^"_$P(PNME,";") D CHK^PSJDPT(.PSGDFN,1,1) I PSGDFN=-1 Q + . D PROFILE D:PSIVHD ASK + D:$G(PSIVHD) ASK + Q + ; +PROFILE ; Display profile of all incomplete orders. + ; + K PSGODDD S (DFN,PSGP)=$P(PNME,";",2) D ENBOTH^PSJAC + S RB=PSJPRB,PG=1,PSJORL=$$ENORL^PSJUTL($G(VAIN(4))),PSJIVOF=PSJORL,PSGLMT=0,LN2="" D ENHEAD^PSJO3 + S (DONE1,TYP)="" F S TYP=$O(^TMP("PSIV",$J,WDN,PNME,TYP)) Q:TYP=""!(DONE1) D:$Y+5'>IOSL GTYP F ON1=0:0 S ON1=$O(^TMP("PSIV",$J,WDN,PNME,TYP,ON1)) Q:'ON1!(DONE1) D DISPLAY + Q + ; +DISPLAY ; Display order on profile. + I $Y+5>IOSL D ASK Q:DONE1 D ENHEAD^PSJO3,GTYP + S PSIVHD=1,PSGLMT=PSGLMT+1,PSIVCV(PSGLMT)=ON1,PSJC="" W !?3,PSGLMT D PIV^PSIVUTL(+ON1_"P") + Q + ; +GTYP ; Get formatted heading for type + N PSJD5314 D FIELD^DID(53.1,4,"","POINTER","PSJD5314") + ; removed ^DD ref 3-2-99, pass ^^_set of codes value + ; because codes^psivutl uses the 3rd piece + ;S X=$$CODES^PSIVUTL(TYP,"^^"_PSJD5314("POINTER")),PSIV=$S(X]"":X,1:"UNKNOWN"),X="",$P(X,"-",40-($L(PSIV)/2))="" W !,X_PSIV_X + S X=$$CODES^PSIVUTL(TYP,"^^"_PSJD5314("POINTER"),"") + S PSIV=$S(X]"":X,1:"UNKNOWN"),X="",$P(X,"-",40-($L(PSIV)/2))="" W !,X_PSIV_X + Q + ; +ASK ; Ask which orders to view. + S PSIVHD=0,ACTION="ORDER" D RD1^PSGON I X="^" S (DONE,DONE1)=1 Q + Q:'$D(PSGODDD) S DONE1=0 F PN=1:1:$L(PSGODDD(1),",")-1 S ON=+$P(PSGODDD(1),",",PN) Q:ON=""!DONE1 S ON=+$P(PSGODDD(1),",",PN) D SHOW + S DONE1=1,PSGOP=DFN D:$P(PSJSYSL,U,2)]"" ENQL^PSGLW + Q + ; +SHOW ; Display selected order and prompt for action + S (P("PON"),ON)=PSIVCV(ON) + ; +SHOW1 ; Entry point from backdoor. + S PSIVUP=+$$GTPCI^PSIVUTL D GT531^PSIVORFA(DFN,ON) I $G(PSIVAC)="PRO" D ENNONUM^PSIVORV2(DFN,ON) Q + I $G(PSJORD)["P" D REQDT^PSJLIVMD(PSJORD) + S PSJORD=+ON D ^PSJLIFN + Q + ; + ; look-ups on ward group, ward, or patient; depending on value of SS +G S DIC="^PS(57.5,",DIC(0)="QEAMI",DIC("A")="Select WARD GROUP: " W ! D ^DIC S:+Y>0 WG=+Y Q +W S DIC="^DIC(42,",DIC(0)="QEAMI",DIC("A")="Select WARD: " W ! D ^DIC S:+Y>0 WD=+Y Q +P D ENGETP^PSIV Q:DFN<0 S Y=1 I $D(^PS(53.1,"AS","P",+DFN)) S PNME=$G(^DPT(+DFN,0)),PNME=$P(PNME,U)_";"_DFN,WDN=$S(VAIN(4)]"":$P(VAIN(4),U,2),1:"OUTPATIENT") D GP + Q + ; +GG ; put patient(s) with incomplete orders into array + F WD=0:0 S WD=$O(^PS(57.5,"AC",WG,WD)) Q:'WD D GW + Q +GW S WDN=$G(^DIC(42,WD,0)),WDN=$P(WDN,U) I WDN]"" F DFN=0:0 S DFN=$O(^DPT("CN",WDN,DFN)) Q:'DFN I $D(^PS(53.1,"AS","P",DFN)) S Y=$G(^DPT(+DFN,0)),PNME=$P(Y,U)_";"_DFN D:PNME]"" GP + Q +GP ; + F ON=0:0 S ON=$O(^PS(53.1,"AS","P",DFN,ON)) Q:'ON S Y=$G(^PS(53.1,ON,0)),TYP=$S($P(Y,U,4)]"":$P(Y,U,4),1:"Z"),^TMP("PSIV",$J,WDN,PNME,TYP,ON)="" + Q +DISCONT ; Cancel incomplete order + D:'$D(PSJIVORF) ORPARM^PSIVOREN I PSJIVORF D NATURE^PSIVOREN I '$D(P("NAT")) W !,$C(7),"Order Unchanged." Q + ;Prompt for requesting provider + W ! I '$$REQPROV^PSGOEC W !,$C(7),"Order Unchanged." Q + W ! + ; + ;* N PSJORNAT S (PSJORIFN,ORIFN)=$P($G(^PS(53.1,+ON,0)),U,21),PSJORD=ON,PSJORNAT=P("NAT") D DC^PSIVORA ;* I PSJIVORF,PSJORIFN,(ON["V") D EN1^PSJHL2(PSGP,"OD",+ON_"V","ORDER DISCONTINUED") + I 'PSJCOM N PSJORNAT S PSJORIFN=$P($G(^PS(53.1,+ON,0)),U,21),PSJORD=ON,PSJORNAT=P("NAT") D DC^PSIVORA ;* I PSJIVORF,PSJORIFN,(ON["V") D EN1^PSJHL2(PSGP,"OD",+ON_"V","ORDER DISCONTINUED") + I PSJCOM,PSJORD["P" N O S O="" F S O=$O(^PS(53.1,"ACX",PSJCOM,O)) Q:O="" D + .S ON=O_"P",PSJORIFN=$P($G(^PS(53.1,+ON,0)),U,21),PSJORD=ON,PSJORNAT=P("NAT") D DC^PSIVORA + W !,"Order discontinued.",! + Q + ; +EDIT ; Edit incomplete order + S PSIVAC="CE" L +^PS(53.1,+ON):1 E W !,$C(7),"This order LOCKED by another user." Q + D EDIT^PSIVORC2 L -^PS(53.1,+ON) + Q + ; +FINISH ; Finish incomplete order + S PSIVAC="CF" L +^PS(53.1,+ON):1 E W !,$C(7),"This order LOCKED by another user." Q + D FINISH^PSIVORC2 L -^PS(53.1,+ON) + Q diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVORC1.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVORC1.m index 104be5fb..e10c15d1 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVORC1.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVORC1.m @@ -1,117 +1,107 @@ -PSIVORC1 ;BIR/MLM-PROCESS INCOMPLETE IV ORDER - CONT ;13 Jan 98 / 11:36 AM - ;;5.0; INPATIENT MEDICATIONS ;**1,37,69,110,157,134**;16 DEC 97;Build 124 - ; - ; Reference to ^DD("DD" is supported by DBIA 10017. - ; Reference to ^DD( is supported by DBIA 2255. - ; Reference to ^VA(200 is supported by DBIA 10060. - ; Reference to ^%DT is supported by DBIA 10003. - ; Reference to ^%DTC is supported by DBIA 10000. - ; Reference to ^DID is supported by DBIA 2052. - ; Reference to ^VALM is supported by DBIA 10118. - ; Reference to ^PS(55 is supported by DBIA# 2191. - ; -53 ; IV Type - I $G(PSGORD)["P",$G(PSGAT),($G(P(9))]"") D - .N X,PSGS0Y,ZZ,LYN,ZZND,ZZNDW S X=P(9) S PSGS0Y="",ZZ=0 D FIND^DIC(51.1,,,,X,,"APPSJ",,,"LYN") - .S ZZ=$O(LYN("DILIST",2,ZZ)) I ZZ S ZZ=+LYN("DILIST",2,ZZ) I ZZ S ZZND=$G(^PS(51.1,ZZ,0)) S PSGST=$P(ZZND,U,5),PSGS0XT=$P(ZZND,U,3) I $G(PSJPWD) D - ..N ZZNDW S ZZNDW=$G(^PS(51.1,ZZ,1,PSJPWD,0)) I $P(ZZNDW,"^",2)]"" S PSGS0Y=$P(ZZNDW,"^",2),$P(ZZND,"^",2)=PSGS0Y - .S ZZ=0 F S ZZ=$O(LYN("DILIST",1,ZZ)) Q:'ZZ I $G(LYN("DILIST",1,ZZ))'=X K LYN("DILIST",1,ZZ),LYN("DILIST",2,ZZ),LYN("DILIST","ID",ZZ,1) - .I $D(PSJPWD) S ZZ=0 F S ZZ=$O(LYN("DILIST",2,ZZ)) Q:'ZZ I $P($G(^PS(51.1,+LYN("DILIST",2,ZZ),1,+PSJPWD,0)),U,2)]"" S PSGS0Y=$P($G(^(0)),U,2) - .I '$G(PSGS0Y) S ZZ=0 F S ZZ=$O(LYN("DILIST",2,ZZ)) Q:'ZZ Q:PSGS0Y]"" I $G(LYN("DILIST","ID",ZZ,1))]"" S PSGS0Y=$G(LYN("DILIST","ID",ZZ,1)) - .Q:(PSGS0Y=PSGAT)!'$G(PSGS0Y)!($G(IVCAT)="C") - .S PSGNSTAT=1 W $C(7),!!,"PLEASE NOTE: This order's admin times (",PSGAT,")" - .W !?13," do not match the ward times (",PSGS0Y,")" - .W !?13," for this administration schedule (",P(9),")",! - .S DIR(0)="EA",DIR("A")="Press Return to continue..." D ^DIR K DIR W ! - S DONE=0 N DIR S DIR(0)="SNA^A:ADMIXTURE;C:CHEMOTHERAPY;H:HYPERAL;P:PIGGYBACK;S:SYRINGE",DIR("A")="IV TYPE: " - I $G(P("RES"))'="R",$G(PSGORD)["P" N IVCAT,IVTYPTMP S IVCAT=$P($G(^PS(53.1,+PSGORD,2.5)),"^",5) S IVTYPTMP=$S((P(9)]""):"P",$G(P(5)):"P",$G(P(23))="P":"P",1:"") - S DIR("B")=$S($G(IVCAT)="C"!($G(IVTYPTMP)="A"):"ADMIXTURE",$G(IVCAT)="I"!($G(IVTYPTMP)="P"):"PIGGYBACK",1:"ADMIXTURE") - D DIRQ,^DIR S:$D(DTOUT)!(X="^") DONE=1 Q:DONE G:$E(X)="^" 53 S P(4)=Y D:"CS"[P(4) @P(4) - I PSIVAC'="PN" D ENT^PSIVCAL K %DT S X=P(2),%DT="RTX" D ^%DT S P(2)=+Y D ENSTOP^PSIVCAL K %DT S X=P(3),%DT="RTX" D ^%DT S P(3)=+Y -OTYP ; Get order type, display type. - S P("DTYP")=$S(P(4)="":0,P(4)="P"!(P(23)="P")!(P(5)):1,P(4)="H":2,1:3) S:PSIVAC'="CF" P("OT")=$S(P(4)="A":"F",P(4)="H":"H",1:"I") - Q - ; -C ; Edit Chemo order - N DIR S DIR(0)="SA^A:ADMIXTURE;P:PIGGYBACK;S:SYRINGE",DIR("A")="CHEMOTHERAPY TYPE: " D DIRQ,^DIR S:$D(DTOUT)!(X=U) DONE=1 Q:$E(X)="^"!(DONE) S P(23)=Y D:P(23)["S" S - Q - ; -S ; Edit Syringe order -56 ; Intermittent Syringe - N DIR S DIR(0)="Y",DIR("??")="^S F1=53.1,F2=56 D ENHLP^PSIVORC1",DIR("A")="INTERMITTENT SYRINGE" D ^DIR Q:$D(DIRUT) S P(5)=Y - ; -55 ; Syringe Size - N DA,DIR S DIR(0)="53.1,55" D ^DIR I $D(DTOUT)!$D(DUOUT) S DONE=1 Q - S P("SYRS")=Y - Q - ; -DIRQ ; Set DIR("?") for IV Type prompt. - S DIR("?")="Enter a code from the list above.",DIR("??")="^S F1=55.01,F2="_$S(DIR("A")["CHEMO":106,1:.04)_" D ENHLP^PSIVORC1" - S DIR("?",1)="CHOOSE FROM:",Y=$P(DIR(0),U,2) F X=1:1:5 S DIR("?",X+1)=" "_$P($P(Y,";",X),":")_" "_$P($P(Y,";",X),":",2) - Q - ; -CKFLDS ; Find required fields missing data. - NEW PSIVASX,PSIVASY,FIL,DRGTMP - S EDIT="" F PSIVASX="AD","SOL" D - .I '$D(DRG(PSIVASX)) S EDIT=EDIT_U_$S(PSIVASX="AD":57,1:58) Q - .S DNE=0 F PSIVASY=0:0 S PSIVASY=$O(DRG(PSIVASX,PSIVASY)) Q:'PSIVASY!DNE D - .. I $P(DRG(PSIVASX,PSIVASY),U,3)="" S EDIT=EDIT_U_$S(PSIVASX="AD":57,1:58),DNE=1 - S:'P("MR") EDIT=EDIT_U_3 F X=8,6,2,3 I P(X)="" S EDIT=EDIT_U_$S(X=8:59,X=6:1,X=2:10,X=3:25,1:"") - I P("DTYP")=1 S:P(9)="" EDIT=EDIT_U_26 S:P(11)="" EDIT=EDIT_U_39 - S:$E(EDIT,1)=U EDIT=$E(EDIT,2,999) - Q - ; -DONE ; Kill variables and exit - K ACTION,AD,DFN,DNE,DONE,DONE1,DRG,DRGI,DRGN,DRGT,DRGTN,EDIT,ERR,F1,F2,FIL,HDT,J,LN,LN2,ND,ON,ON1,ON55,ORIFN,P,P16,PC,PDM,PG,PN,PNME,PNOW,PSGLMT,PSGODDD - K PSGSS,PSGSSH,PSIV,PSIVAC,PSIVAT,PSIVCV,PSIVE,PSIVHD,PSIVLN,PSIVOK,PSIVOLD,PSIVORUT,PSIVREA,PSIVSC1,PSIVSTR,PSIVSTRT,PSIVTYPE,PSIVUP,PSIVX,PSIVX1 - K PSJIVORF,PSJORF,PSJORIFN,PSJORL,PSJORNP,PSJORPF,PSJORSTS,PSJIVOF,PSJNKF,PSJORD,RB,RF,SOL,STOP,TYP,UL80,WD,WDN,WG,^TMP("PSIV",$J) D ENIVKV^PSGSETU - Q -ENHLP ; order entry fields' help - N PSJHP,PSJX,PSJD - ; From within this routine, F1 and F2 will refer to file 53.1,field 56, file 55.01,field 106, or file 55.01,field .04 - D FIELD^DID(F1,F2,"","HELP-PROMPT","PSJHP") - I X="?",$D(PSJHP("HELP-PROMPT")) S F=$G(PSJHP("HELP-PROMPT")) W !?5 F F0=1:1:$L(F," ") S F3=$P(F," ",F0) W:$L(F3)+$X>78 !?5 W F3_" " - ; - W:$D(^DD(F1,F2,12)) !,"("_^(12)_")" D FIELD^DID(F1,F2,"","XECUTABLE HELP","PSJX") I $D(PSJX("XECUTABLE HELP")) X PSJX("XECUTABLE HELP") - ; - ; new code - D FIELD^DID(F1,F2,"","DESCRIPTION","PSJD") - G:$S($G(X)="?":1,1:'$O(PSJD("DESCRIPTION",0))) SC F F=0:0 S F=$O(PSJD("DESCRIPTION",F)) Q:'F I $D(PSJD("DESCRIPTION",F)) W !?2,PSJD("DESCRIPTION",F) -SC ; - I F2=5!(F2=6) W !,"CHOOSE FROM:",!?8,0,?16,"NO",!?8,1,?16,"YES" Q - Q -COMPLTE ; - S P16=0,PSIVEXAM=1,(PSIVNOL,PSIVCT)=1 D GTOT^PSIVUTL(P(4)) D ^PSIVCHK I $D(DUOUT) W $C(7),!,"Order Unchanged.",! Q - G:'$D(PSIVFN1) EDIT1 - I ERR=1 S Y=0 G EDIT1 - D CKORD^PSIVORC2 I PSIVCHG D NOW^%DTC S P("LOG")=$E(%,1,12),P("CLRK")=DUZ_U_$P($G(^VA(200,DUZ,0)),U),P("INS")="" - W ! D ^PSIVORLB K PSIVEXAM S Y=P(2) - W !,"Start date: " X ^DD("DD") W $P(Y,"@")," ",$P(Y,"@",2),?30," Stop date: " S Y=P(3) X ^DD("DD") W $P(Y,"@")," ",$P(Y,"@",2),! -EDIT ; - I ERR=1 W !,"Please re-edit this order" K DIR S DIR(0)="E" D ^DIR K DIR W:'Y $C(7),"order unchanged." Q:'Y S Y=0 G EDIT1 - ;PSJ*5*157 EFD FOR IV - D EFDIV^PSJUTL($G(ZZND)) - W:$G(PSIVCHG) !,"*** This change will cause a new order to be created. ***" - K DIR S DIR(0)="Y",DIR("A")="Is this O.K.",DIR("B")=$S(ERR:"NO",1:"YES"),DIR("?",1)="Enter ""Y"" to make this an active order (only allowed if no errors were" - S DIR("?")="found in order), ""N"" to edit the order, or ""^"" to leave order unchanged.",DIR("??")="^S HELP=""EDIT"" D ^PSIVHLP" - D ^DIR K DIR I $D(DIRUT) K DIRUT W $C(7),"Order unchanged." Q - ;* Kill Unit dose variables when calling from ^PSJLIFNI. - I +Y,$G(PSJLIFNI) D - . K ND,ND4,ND6,NDP2 - . K PSGAT,PSGCANFL,PSGDI,PSGDO,PSGDT,PSGEB,PSGEBN,PSGEFN,PSGFD,PSGFDN - . K PSGHSM,PSGLI,PSGLIN,PSGLMT,PSGMR,PSGMRN,PSGNEDFD,PSGNEF,PSGNEFD - . K PSGNESD,PSGOAT,PSGODO,PSGODT,PSGEA,PSGOEAV,PSGOEEF - . K PSGOEEWF,PSGOEEG,PSGOEF,PSGOENG,PSGOES,PSGOFD,PSGOFDN,PSGOHSM - . K PSGOINST,PSGOMR,PSGOMRN,PSGONC - . K PSGOPD,PSOPDN,PSGOPR,PSGOPRN,PSGOSD,PSGOSDN,PSGOSI,PSGOSM - . K PSGOST,PSGOSTN - . K PSGPD,PSGPDN,PSGPDRG,PSGDRGN,PSGPFLG,PSGPI,PSGPR,PSGPRIO,PSGPRN - . K PSGPTMP,PSGRRF,PSG0XT,PSGS0Y,PSGSCH,PSGSD,PSGSDN,PSGSI,PSGSM - . K PSGST,PSGSTAT,PSGSTN,PSJACNWP,PSJACOK,PSJCOI -EDIT1 ; - NEW XFLG,PSIVY S PSIVY=Y - NEW X S X=^TMP("PSJI",$J,0),VALMBG=$S((X<17):1,1:(X-(X#16))) - I PSIVY=0!'$G(PSIVFN1) S PSIVFN1=1 D EN^VALM("PSJ LM IV AC/EDIT") Q - S PSIVCHG=0 D EDCHK^PSIVORC2 K PSIVCHG - S VALMBCK="Q",PSIVACEP=1 - Q +PSIVORC1 ;BIR/MLM-PROCESS INCOMPLETE IV ORDER - CONT ;13 Jan 98 / 11:36 AM + ;;5.0; INPATIENT MEDICATIONS ;**1,37,69,110,157**;16 DEC 97 + ; + ; Reference to ^DD("DD" is supported by DBIA 10017. + ; Reference to ^DD( is supported by DBIA 2255. + ; Reference to ^VA(200 is supported by DBIA 10060. + ; Reference to ^%DT is supported by DBIA 10003. + ; Reference to ^%DTC is supported by DBIA 10000. + ; Reference to ^DID is supported by DBIA 2052. + ; Reference to ^VALM is supported by DBIA 10118. + ; +53 ; IV Type + ;*S DONE=0 N DIR S DIR(0)="SNA^A:ADMIXTURE;C:CHEMOTHERAPY;"_$S($E(PSIVAC)'["C":"H:HYPERAL;",1:"")_"P:PIGGYBACK;S:SYRINGE",DIR("A")="IV TYPE: " + S DONE=0 N DIR S DIR(0)="SNA^A:ADMIXTURE;C:CHEMOTHERAPY;H:HYPERAL;P:PIGGYBACK;S:SYRINGE",DIR("A")="IV TYPE: " + I $G(P("RES"))'="R" S:P(4)]"" DIR("B")="ADMIXTURE",P(4)="" + D DIRQ,^DIR S:$D(DTOUT)!(X="^") DONE=1 Q:DONE G:$E(X)="^" 53 S P(4)=Y D:"CS"[P(4) @P(4) + I PSIVAC'="PN" D ENT^PSIVCAL K %DT S X=P(2),%DT="RTX" D ^%DT S P(2)=+Y D ENSTOP^PSIVCAL K %DT S X=P(3),%DT="RTX" D ^%DT S P(3)=+Y +OTYP ; Get order type, display type. + S P("DTYP")=$S(P(4)="":0,P(4)="P"!(P(23)="P")!(P(5)):1,P(4)="H":2,1:3) S:PSIVAC'="CF" P("OT")=$S(P(4)="A":"F",P(4)="H":"H",1:"I") + Q + ; +C ; Edit Chemo order + N DIR S DIR(0)="SA^A:ADMIXTURE;P:PIGGYBACK;S:SYRINGE",DIR("A")="CHEMOTHERAPY TYPE: " D DIRQ,^DIR S:$D(DTOUT)!(X=U) DONE=1 Q:$E(X)="^"!(DONE) S P(23)=Y D:P(23)["S" S + Q + ; +S ; Edit Syringe order +56 ; Intermittent Syringe + N DIR S DIR(0)="Y",DIR("??")="^S F1=53.1,F2=56 D ENHLP^PSIVORC1",DIR("A")="INTERMITTENT SYRINGE" D ^DIR Q:$D(DIRUT) S P(5)=Y + ; +55 ; Syringe Size + N DA,DIR S DIR(0)="53.1,55" D ^DIR I $D(DTOUT)!$D(DUOUT) S DONE=1 Q + S P("SYRS")=Y + Q + ; +DIRQ ; Set DIR("?") for IV Type prompt. + S DIR("?")="Enter a code from the list above.",DIR("??")="^S F1=55.01,F2="_$S(DIR("A")["CHEMO":106,1:.04)_" D ENHLP^PSIVORC1" + S DIR("?",1)="CHOOSE FROM:",Y=$P(DIR(0),U,2) F X=1:1:5 S DIR("?",X+1)=" "_$P($P(Y,";",X),":")_" "_$P($P(Y,";",X),":",2) + Q + ; +CKFLDS ; Find required fields missing data. + NEW PSIVASX,PSIVASY,FIL,DRGTMP + S EDIT="" F PSIVASX="AD","SOL" D + .I '$D(DRG(PSIVASX)) S EDIT=EDIT_U_$S(PSIVASX="AD":57,1:58) Q + .S DNE=0 F PSIVASY=0:0 S PSIVASY=$O(DRG(PSIVASX,PSIVASY)) Q:'PSIVASY!DNE D + .. I $P(DRG(PSIVASX,PSIVASY),U,3)="" S EDIT=EDIT_U_$S(PSIVASX="AD":57,1:58),DNE=1 + .. ;S FIL=$S(PSIVASX="AD":"52.6",1:"52.7") + .. ;S DRGTMP=DRG(PSIVASX,PSIVASY) D ORDERCHK^PSIVEDRG(DFN) + S:'P("MR") EDIT=EDIT_U_3 F X=8,6,2,3 I P(X)="" S EDIT=EDIT_U_$S(X=8:59,X=6:1,X=2:10,X=3:25,1:"") + I P("DTYP")=1 S:P(9)="" EDIT=EDIT_U_26 S:P(11)="" EDIT=EDIT_U_39 + S:$E(EDIT,1)=U EDIT=$E(EDIT,2,999) + Q + ; +DONE ; Kill variables and exit + K ACTION,AD,DFN,DNE,DONE,DONE1,DRG,DRGI,DRGN,DRGT,DRGTN,EDIT,ERR,F1,F2,FIL,HDT,J,LN,LN2,ND,ON,ON1,ON55,ORIFN,P,P16,PC,PDM,PG,PN,PNME,PNOW,PSGLMT,PSGODDD + K PSGSS,PSGSSH,PSIV,PSIVAC,PSIVAT,PSIVCV,PSIVE,PSIVHD,PSIVLN,PSIVOK,PSIVOLD,PSIVORUT,PSIVREA,PSIVSC1,PSIVSTR,PSIVSTRT,PSIVTYPE,PSIVUP,PSIVX,PSIVX1 + K PSJIVORF,PSJORF,PSJORIFN,PSJORL,PSJORNP,PSJORPF,PSJORSTS,PSJIVOF,PSJNKF,PSJORD,RB,RF,SOL,STOP,TYP,UL80,WD,WDN,WG,^TMP("PSIV",$J) D ENIVKV^PSGSETU + Q +ENHLP ; order entry fields' help + N PSJHP,PSJX,PSJD + ; + D FIELD^DID(F1,F2,"","HELP-PROMPT","PSJHP") + I X="?",$D(PSJHP("HELP-PROMPT")) S F=$G(PSJHP("HELP-PROMPT")) W !?5 F F0=1:1:$L(F," ") S F3=$P(F," ",F0) W:$L(F3)+$X>78 !?5 W F3_" " + ;I X="?",$D(^DD(F1,F2,3)) S F=^(3) W !?5 F F0=1:1:$L(F," ") S F3=$P(F," ",F0) W:$L(F3)+$X>78 !?5 W F3_" " + ; + W:$D(^DD(F1,F2,12)) !,"("_^(12)_")" D FIELD^DID(F1,F2,"","XECUTABLE HELP","PSJX") I $D(PSJX("XECUTABLE HELP")) X PSJX("XECUTABLE HELP") + ; + ; new code + D FIELD^DID(F1,F2,"","DESCRIPTION","PSJD") + G:$S($G(X)="?":1,1:'$O(PSJD("DESCRIPTION",0))) SC F F=0:0 S F=$O(PSJD("DESCRIPTION",F)) Q:'F I $D(PSJD("DESCRIPTION",F)) W !?2,PSJD("DESCRIPTION",F) +SC ; + I F2=5!(F2=6) W !,"CHOOSE FROM:",!?8,0,?16,"NO",!?8,1,?16,"YES" Q + Q +COMPLTE ; + S P16=0,PSIVEXAM=1,(PSIVNOL,PSIVCT)=1 D GTOT^PSIVUTL(P(4)) D ^PSIVCHK I $D(DUOUT) W $C(7),!,"Order Unchanged.",! Q + G:'$D(PSIVFN1) EDIT1 + I ERR=1 S Y=0 G EDIT1 + D CKORD^PSIVORC2 I PSIVCHG D NOW^%DTC S P("LOG")=$E(%,1,12),P("CLRK")=DUZ_U_$P($G(^VA(200,DUZ,0)),U),P("INS")="" + W ! D ^PSIVORLB K PSIVEXAM S Y=P(2) + W !,"Start date: " X ^DD("DD") W $P(Y,"@")," ",$P(Y,"@",2),?30," Stop date: " S Y=P(3) X ^DD("DD") W $P(Y,"@")," ",$P(Y,"@",2),! +EDIT ; + I ERR=1 W !,"Please re-edit this order" K DIR S DIR(0)="E" D ^DIR K DIR W:'Y $C(7),"order unchanged." Q:'Y S Y=0 G EDIT1 + ;PSJ*5*157 EFD FOR IV + D EFDIV^PSJUTL($G(ZZND)) + W:$G(PSIVCHG) !,"*** This change will cause a new order to be created. ***" + K DIR S DIR(0)="Y",DIR("A")="Is this O.K.",DIR("B")=$S(ERR:"NO",1:"YES"),DIR("?",1)="Enter ""Y"" to make this an active order (only allowed if no errors were" + S DIR("?")="found in order), ""N"" to edit the order, or ""^"" to leave order unchanged.",DIR("??")="^S HELP=""EDIT"" D ^PSIVHLP" + D ^DIR K DIR I $D(DIRUT) K DIRUT W $C(7),"Order unchanged." Q + ;* Kill Unit dose variables when calling from ^PSJLIFNI. + I +Y,$G(PSJLIFNI) D + . K ND,ND4,ND6,NDP2 + . K PSGAT,PSGCANFL,PSGDI,PSGDO,PSGDT,PSGEB,PSGEBN,PSGEFN,PSGFD,PSGFDN + . K PSGHSM,PSGLI,PSGLIN,PSGLMT,PSGMR,PSGMRN,PSGNEDFD,PSGNEF,PSGNEFD + . K PSGNESD,PSGOAT,PSGODO,PSGODT,PSGEA,PSGOEAV,PSGOEEF + . K PSGOEEWF,PSGOEEG,PSGOEF,PSGOENG,PSGOES,PSGOFD,PSGOFDN,PSGOHSM + . K PSGOINST,PSGOMR,PSGOMRN,PSGONC + . K PSGOPD,PSOPDN,PSGOPR,PSGOPRN,PSGOSD,PSGOSDN,PSGOSI,PSGOSM + . K PSGOST,PSGOSTN + . K PSGPD,PSGPDN,PSGPDRG,PSGDRGN,PSGPFLG,PSGPI,PSGPR,PSGPRIO,PSGPRN + . K PSGPTMP,PSGRRF,PSG0XT,PSGS0Y,PSGSCH,PSGSD,PSGSDN,PSGSI,PSGSM + . K PSGST,PSGSTAT,PSGSTN,PSJACNWP,PSJACOK,PSJCOI +EDIT1 ; + NEW XFLG,PSIVY S PSIVY=Y + NEW X S X=^TMP("PSJI",$J,0),VALMBG=$S((X<17):1,1:(X-(X#16))) + I PSIVY=0!'$G(PSIVFN1) S PSIVFN1=1 D EN^VALM("PSJ LM IV AC/EDIT") Q + S PSIVCHG=0 D EDCHK^PSIVORC2 K PSIVCHG + S VALMBCK="Q",PSIVACEP=1 + Q diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVOREN.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVOREN.m index b62499a5..a93ed802 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVOREN.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVOREN.m @@ -1,88 +1,91 @@ -PSIVOREN ;BIR/MLM-UTILITIES FOR IV FLUIDS - OE/RR INTERFACE ; 25 Sep 98 / 2:00 PM - ;;5.0; INPATIENT MEDICATIONS ;**3,18,69,110,127,133,140,134**;16 DEC 97;Build 124 - ; - ; Reference to ^PS(55 is supported by DBIA 2191. - ; Reference to ^VA(200 is supported by DBIA 10060. - ; Reference to ^DIE is supported by DBIA 10018. - ; -ENCPP ; Check Package Parameter - D ORPARM I 'PSJORF W !!,"Inpatient Medications is not turned on for OE/RR.",!,"You will not be able to enter or edit IV or Unit Dose orders." - I 'PSJIVORF W !!,"IV Medications is not turned on for OE/RR.",!,"You will not be able to enter or edit IV orders." - I 'PSJORF!'PSJIVORF S PSJIVORF="" D DONE^PSIVORA1 Q - S PSJORL=$G(VAIN(4)) I 'PSJORL,$G(DFN) D INP^VADPT S PSJORL=$G(VAIN(4)) - S PSJORPF=0,P("OT")="F^",PSJORNP=$S($G(PSJORNP):PSJORNP,1:+$G(DUZ)) - Q - ; -PS ; Check if MD is authorized to write med. orders. - S PSJORPF=0 S:PSJORNP X=$G(^VA(200,+PSJORNP,"PS")) Q:$S('PSJORNP:0,'X:0,'$P(X,U,4):1,$P(X,U,4)>DT:1,1:0) D - .W !?2,"(The selected PROVIDER is NOT qualified to write MEDICATION orders. You must",!,"select a valid provider to be able to continue with Inpatient Medications.)" - .K DIC S DIC="^VA(200,",DIC(0)="AEMQZ",DIC("A")="Select PHARMACY PROVIDER: ",DIC("S")="S PSIV=$G(^(""PS"")) I PSIV,$S($P(PSIV,""^"",4)="""":1,DT<$P(PSIV,""^"",4):1,1:0)" F W ! D ^DIC Q:$D(DUOUT)!$D(DTOUT)!(Y>0) W $C(7)," (Required.)" - .K DIC S:Y'>0 PSJORPF=11 S:Y>0 PSJORNP=+Y Q - K DTOUT - Q - ; -RUPDATE(DFN,ON,NSTRT) ; - ; Update renewal orders (called from Pharmacy options). - N DA,DIE,DR,ND,NSTOP,OSTOP,NOO,ORETURN,PSIVACT,PSIVAL,PSIVALCK,PSJOSTRT,PSGOLDOE S DIE="^PS(55,"_DFN_"," - I ON["P" S OLDON=$P($G(^PS(53.1,+ON,0)),"^",25),NOO=$P($G(^PS(53.1,+ON,.2)),"^",3) - I ON["V" S OLDON=ON,NOO=$P($G(^PS(55,DFN,"IV",+ON,.2)),"^",5) - I ON["U" S OLDON=$P($G(^PS(55,DFN,5,+ON,0)),U,25) - I OLDON["P" S OLDON=$P($G(^PS(53.1,+OLDON,0)),U,25) - I OLDON["V" S ON55=OLDON,X=$G(^PS(55,DFN,"IV",+OLDON,2)),PSJOSTRT=$P(X,U,7),OSTOP=$S(($G(PSJOSTOP)>PSJOSTRT):PSJOSTOP,1:$P($G(^(0)),U,3)),DIE=DIE_"""IV"",",DR="100////A",PSIVACT=1 - I OLDON["U" S X=$G(^PS(55,DFN,5,+OLDON,2)),PSJOSTRT=$P(X,U,7),OSTOP=$P(X,U,4),DIE=DIE_"5," - S NSTOP=+$S($G(P(3)):P(3),1:0),DA=+OLDON,DA(1)=DFN I 'NSTOP W !,"CAN'T RENEW THIS ORDER!" D PAUSE^VALM1 Q - ; - I ON["V"!(ON["P") D EXPOE^PSGOER(DFN,ON) - ; - S DR=DR_";"_$S(OLDON["V":.03,OLDON["U":34,1:25)_"////"_NSTOP_";"_$S(OLDON["V":"114////@;123////@",1:"105////@;107////@") S:+$G(P(6))?1.30N DR=DR_";.06////"_+P(6) D ^DIE - I ON["P" S DIE="^PS(53.1,",DR="28////A;105////@;",DA=+ON D ^DIE D - .I $G(OLDON)["V" S PSGOLDOE=$P($G(^PS(55,DFN,"IV",+OLDON,0)),"^",21) - .N NOEORD,VN,VNDT S NOEORD=$P(^PS(53.1,+ON,0),U,21) S VN=$P($G(^PS(53.1,+ON,4)),"^") I VN S VNDT=$P($G(^PS(53.1,+ON,4)),"^",2) - .I NOEORD K DA,DR,DIE S DIE="^PS(55,"_DFN_",""IV"",",DA(1)=DFN,DA=+ON55,DR="110////"_+NOEORD D - ..S DR=DR_";16////"_$S($G(VN):VN,1:"@")_";17////"_$S($G(VNDT):VNDT,1:"@")_";" D ^DIE I NOEORD[";" S $P(^PS(53.1,+ON,0),U,21)=NOEORD - ..I $G(VN) D EN1^PSJHL2(DFN,"ZV",ON55) - I ON["V" S DIE="^PS(55,DFN,""IV"",",DR="100////A;114////@;16////@;17////@" S DA=+ON55 D ^DIE - N RDT S RDT=$P($G(@("^PS(53.1,"_+ON_",14,0)")),U,3) S:RDT RDT=+(^(RDT,0)) S RDT=$S(RDT:RDT,1:$$DATE^PSJUTL2) I RDT D UPDREN^PSIVOPT2(DFN,OLDON,RDT,+P(6),+$G(OSTOP),$G(NOO)) - ; - I ON["V" D EN1^PSJHL2(DFN,"SN",ON,"NEW ORDER CREATED") - I OLDON["V" S (ON,ON55)=OLDON,PSIVAL="",PSIVALCK="STOP",(P("FRES"),PSIVREA)="R" D LOG^PSIVORAL D - .I $G(ON55),$G(OSTOP),$G(DFN) D STIX(OSTOP,OLDON,DFN) - .;Add check to If statement below. If New Stop date ='s the old Stop Don't delete AIV x-ref (NSTOP'=PSJOSTOP) - .I $G(PSJOSTOP),$G(NSTOP) I NSTOP=$P($G(^PS(55,DFN,"IV",+ON55,0)),"^",3),$D(^PS(55,"AIV",NSTOP,DFN,+ON55)),NSTOP'=PSJOSTOP K ^PS(55,"AIV",PSJOSTOP,DFN,+ON55) - D:'$D(PSJIVORF) ORPARM Q:'PSJIVORF - Q - ; -RUPTXT(DFN,OLDON) ; - ;Update ORTX( in OE/RR - I OLDON'["V" ;; D ENUDTX^PSJOREN(DFN,OLDON,"OR") S ORIFN=$P($G(^PS(55,DFN,"IV",+OLDON,0)),U,21) - I OLDON["V" S P("FRES")="R" D GTPC^PSIVORFB(OLDON),SORTX^PSIVORFE S ORIFN=$P($G(^PS(55,DFN,"IV",+OLDON,0)),U,21) - Q - ; -ORPARM ;Check if inpatient pkges are on. - S (PSJORF,PSJIVORF)=1 - Q - ; -NATURE ; Ask nature of order. - Q:$G(PSJDCTYP)=2 - I '+$G(PSJSYSU) S P("NAT")="W" Q - K P("NAT") NEW X - I $D(XQORNOD(0)) S X=$E($P(XQORNOD(0),U,3),1,1) S:X="" X="E" - S:'$D(X) X="N" S:"AF"[X X="E" - I $G(PSIVCOPY) S X="N" - S P("NAT")=$$ENNOO^PSJUTL5(X) - K:P("NAT")=-1 P("NAT") - Q -CLINIC ;Ask clinic where outpt is being seen for DSS - K P("CLIN") NEW X1,X2,X,PSJDT,DIC,Y - S X1=DT,X2=-7 D C^%DTC S PSJDT=X - S DIC("S")="I $P($G(^SC(Y,0)),U,3)=""C"",$S('$P($G(^(""I"")),U):1,($P($G(^(""I"")),U)>PSJDT):1,(($P($G(^(""I"")),U)$P($G(^(""I"")),U,2))):1,1:0)" - S DIC=44,DIC(0)="QEAZ",DIC("A")="Select CLINIC LOCATION: " D ^DIC - I $S($D(DTOUT):1,$D(DUOUT):1,1:0) Q - S:+Y>0 P("CLIN")=+Y,$P(^PS(55,DFN,"IV",+ON55,"DSS"),"^")=+Y - Q - ; -STIX(OST,OON,DFN) ; Check start index, cleanup old start - I $G(OST),$G(OON) S OS="" F S OS=$O(^PS(55,DFN,"IV","AIS",OS)) Q:'OS D - . Q:'$D(^PS(55,DFN,"IV","AIS",OS,+OON)) - . I $P($G(^PS(55,DFN,"IV",+OON,0)),"^",3)'=OS K ^PS(55,DFN,"IV","AIS",OS,+OON) - Q +PSIVOREN ;BIR/MLM-UTILITIES FOR IV FLUIDS - OE/RR INTERFACE ; 25 Sep 98 / 2:00 PM + ;;5.0; INPATIENT MEDICATIONS ;**3,18,69,110,127,133,140**;16 DEC 97 + ; + ; Reference to ^PS(55 is supported by DBIA 2191. + ; Reference to ^VA(200 is supported by DBIA 10060. + ; Reference to ^DIE is supported by DBIA 10018. + ; +ENCPP ; Check Package Parameter + D ORPARM I 'PSJORF W !!,"Inpatient Medications is not turned on for OE/RR.",!,"You will not be able to enter or edit IV or Unit Dose orders." + I 'PSJIVORF W !!,"IV Medications is not turned on for OE/RR.",!,"You will not be able to enter or edit IV orders." + I 'PSJORF!'PSJIVORF S PSJIVORF="" D DONE^PSIVORA1 Q + S PSJORL=$G(VAIN(4)) I 'PSJORL,$G(DFN) D INP^VADPT S PSJORL=$G(VAIN(4)) + S PSJORPF=0,P("OT")="F^",PSJORNP=$S($G(PSJORNP):PSJORNP,1:+$G(DUZ)) + ;; S PSJORL=ORL,PSJORPF=0,P("OT")="F^"_$O(^ORD(101,"B","PSJI OR PAT FLUID OE",0))_";ORD(101,",PSJORNP=ORNP + Q + ; +PS ; Check if MD is authorized to write med. orders. + S PSJORPF=0 S:PSJORNP X=$G(^VA(200,+PSJORNP,"PS")) Q:$S('PSJORNP:0,'X:0,'$P(X,U,4):1,$P(X,U,4)>DT:1,1:0) D + .W !?2,"(The selected PROVIDER is NOT qualified to write MEDICATION orders. You must",!,"select a valid provider to be able to continue with Inpatient Medications.)" + .K DIC S DIC="^VA(200,",DIC(0)="AEMQZ",DIC("A")="Select PHARMACY PROVIDER: ",DIC("S")="S PSIV=$G(^(""PS"")) I PSIV,$S($P(PSIV,""^"",4)="""":1,DT<$P(PSIV,""^"",4):1,1:0)" F W ! D ^DIC Q:$D(DUOUT)!$D(DTOUT)!(Y>0) W $C(7)," (Required.)" + .K DIC S:Y'>0 PSJORPF=11 S:Y>0 PSJORNP=+Y Q + K DTOUT + Q + ; +RUPDATE(DFN,ON,NSTRT) ; + ; Update renewal orders (called from Pharmacy options). + N DA,DIE,DR,ND,NSTOP,OSTOP,NOO,ORETURN,PSIVACT,PSIVAL,PSIVALCK,PSJOSTRT,PSGOLDOE S DIE="^PS(55,"_DFN_"," + I ON["P" S OLDON=$P($G(^PS(53.1,+ON,0)),"^",25),NOO=$P($G(^PS(53.1,+ON,.2)),"^",3) + I ON["V" S OLDON=ON,NOO=$P($G(^PS(55,DFN,"IV",+ON,.2)),"^",5) + I ON["U" S OLDON=$P($G(^PS(55,DFN,5,+ON,0)),U,25) + I OLDON["P" S OLDON=$P($G(^PS(53.1,+OLDON,0)),U,25) + I OLDON["V" S ON55=OLDON,X=$G(^PS(55,DFN,"IV",+OLDON,2)),PSJOSTRT=$P(X,U,7),OSTOP=$S(($G(PSJOSTOP)>PSJOSTRT):PSJOSTOP,1:$P($G(^(0)),U,3)),DIE=DIE_"""IV"",",DR="100////A",PSIVACT=1 + I OLDON["U" S X=$G(^PS(55,DFN,5,+OLDON,2)),PSJOSTRT=$P(X,U,7),OSTOP=$P(X,U,4),DIE=DIE_"5," + S NSTOP=+$S($G(P(3)):P(3),1:0),DA=+OLDON,DA(1)=DFN I 'NSTOP W !,"CAN'T RENEW THIS ORDER!" D PAUSE^VALM1 Q + ;I OSTOP>NSTOP W !,"NEW STOP DATE IS LESS THAN PREVIOUS STOP DATE" D PAUSE^VALM1 + ; + I ON["V"!(ON["P") D EXPOE^PSGOER(DFN,ON) + ; + S DR=DR_";"_$S(OLDON["V":.03,OLDON["U":34,1:25)_"////"_NSTOP_";"_$S(OLDON["V":"114////@;123////@",1:"105////@;107////@") S:+$G(P(6))?1.30N DR=DR_";.06////"_+P(6) D ^DIE + I ON["P" S DIE="^PS(53.1,",DR="28////A;105////@;",DA=+ON D ^DIE D + .I $G(OLDON)["V" S PSGOLDOE=$P($G(^PS(55,DFN,"IV",+OLDON,0)),"^",21) + .N NOEORD,VN,VNDT S NOEORD=$P(^PS(53.1,+ON,0),U,21) S VN=$P($G(^PS(53.1,+ON,4)),"^") I VN S VNDT=$P($G(^PS(53.1,+ON,4)),"^",2) + .I NOEORD K DA,DR,DIE S DIE="^PS(55,"_DFN_",""IV"",",DA(1)=DFN,DA=+ON55,DR="110////"_+NOEORD D + ..S DR=DR_";16////"_$S($G(VN):VN,1:"@")_";17////"_$S($G(VNDT):VNDT,1:"@")_";" D ^DIE I NOEORD[";" S $P(^PS(53.1,+ON,0),U,21)=NOEORD + ..I $G(VN) D EN1^PSJHL2(DFN,"ZV",ON55) + I ON["V" S DIE="^PS(55,DFN,""IV"",",DR="100////A;114////@;16////@;17////@" S DA=+ON55 D ^DIE + N RDT S RDT=$P($G(@("^PS(53.1,"_+ON_",14,0)")),U,3) S:RDT RDT=+(^(RDT,0)) S RDT=$S(RDT:RDT,1:$$DATE^PSJUTL2) I RDT D UPDREN^PSIVOPT2(DFN,OLDON,RDT,+P(6),+$G(OSTOP),$G(NOO)) + ; + I ON["V" D EN1^PSJHL2(DFN,"SN",ON,"NEW ORDER CREATED") + I OLDON["V" S (ON,ON55)=OLDON,PSIVAL="",PSIVALCK="STOP",(P("FRES"),PSIVREA)="R" D LOG^PSIVORAL D + .I $G(ON55),$G(OSTOP),$G(DFN) D STIX(OSTOP,OLDON,DFN) + .;Add check to If statement below. If New Stop date ='s the old Stop Don't delete AIV x-ref (NSTOP'=PSJOSTOP) + .I $G(PSJOSTOP),$G(NSTOP) I NSTOP=$P($G(^PS(55,DFN,"IV",+ON55,0)),"^",3),$D(^PS(55,"AIV",NSTOP,DFN,+ON55)),NSTOP'=PSJOSTOP K ^PS(55,"AIV",PSJOSTOP,DFN,+ON55) + D:'$D(PSJIVORF) ORPARM Q:'PSJIVORF + Q + ; +RUPTXT(DFN,OLDON) ; + ;Update ORTX( in OE/RR + I OLDON'["V" ;; D ENUDTX^PSJOREN(DFN,OLDON,"OR") S ORIFN=$P($G(^PS(55,DFN,"IV",+OLDON,0)),U,21) + I OLDON["V" S P("FRES")="R" D GTPC^PSIVORFB(OLDON),SORTX^PSIVORFE S ORIFN=$P($G(^PS(55,DFN,"IV",+OLDON,0)),U,21) + ;; F X=0:0 S X=$O(ORTX(X)) Q:'X S ORETURN("ORTX",X)=ORTX(X) + Q + ; +ORPARM ;Check if inpatient pkges are on. + S (PSJORF,PSJIVORF)=1 + Q + ; +NATURE ; Ask nature of order. + I '+$G(PSJSYSU) S P("NAT")="W" Q + K P("NAT") NEW X + I $D(XQORNOD(0)) S X=$E($P(XQORNOD(0),U,3),1,1) S:X="" X="E" + ;* S:'$D(X) X="N" S:X="A" X="E" + S:'$D(X) X="N" S:"AF"[X X="E" + I $G(PSIVCOPY) S X="N" + S P("NAT")=$$ENNOO^PSJUTL5(X) + K:P("NAT")=-1 P("NAT") + Q +CLINIC ;Ask clinic where outpt is being seen for DSS + K P("CLIN") NEW X1,X2,X,PSJDT,DIC,Y + S X1=DT,X2=-7 D C^%DTC S PSJDT=X + S DIC("S")="I $P($G(^SC(Y,0)),U,3)=""C"",$S('$P($G(^(""I"")),U):1,($P($G(^(""I"")),U)>PSJDT):1,(($P($G(^(""I"")),U)$P($G(^(""I"")),U,2))):1,1:0)" + S DIC=44,DIC(0)="QEAZ",DIC("A")="Select CLINIC LOCATION: " D ^DIC + I $S($D(DTOUT):1,$D(DUOUT):1,1:0) Q + S:+Y>0 P("CLIN")=+Y,$P(^PS(55,DFN,"IV",+ON55,"DSS"),"^")=+Y + Q + ; +STIX(OST,OON,DFN) ; Check start index, cleanup old start + I $G(OST),$G(OON) S OS="" F S OS=$O(^PS(55,DFN,"IV","AIS",OS)) Q:'OS D + . Q:'$D(^PS(55,DFN,"IV","AIS",OS,+OON)) + . I $P($G(^PS(55,DFN,"IV",+OON,0)),"^",3)'=OS K ^PS(55,DFN,"IV","AIS",OS,+OON) + Q diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVORFA.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVORFA.m index a09c7a17..70a6ede3 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVORFA.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVORFA.m @@ -1,80 +1,80 @@ -PSIVORFA ;BIR/MLM-FILE/RETRIEVE ORDERS IN 53.1 ;26 Jun 98 / 9:16 AM - ;;5.0; INPATIENT MEDICATIONS ;**4,7,18,28,50,71,58,91,80,110,111,134**;16 DEC 97;Build 124 - ; - ; Reference to ^PS(51.1 supported by DBIA 2177. - ; Reference to ^PS(51.2 supported by DBIA 2178. - ; Reference to ^PS(52.7 supported by DBIA 2173. - ; Reference to ^PS(52.6 supported by DBIA 1231. - ; -GT531(DFN,ON) ; Retrieve order data from 53.1 and place into local array - ; - NEW PSGOES S PSGOES=1 - F X="CUM","LF","LFA","LF","PRNTON" S P(X)="" - S Y=$G(^PS(53.1,+ON,0)),P(17)=$P(Y,U,9),P("LOG")=$P(Y,U,16),(P(21),P("21FLG"),PSJORIFN)=$P(Y,U,21) - S P("RES")=$P(Y,U,24),P("OLDON")=$P(Y,U,25),P("NEWON")=$P(Y,U,26),P("FRES")=$P(Y,U,27) - S P("MR")=$P(Y,U,3),P(6)=+$P(Y,U,2),Y=$G(^VA(200,+P(6),0)),$P(P(6),U,2)=$P(Y,U),Y=$G(^PS(51.2,+P("MR"),0)),$P(P("MR"),U,2)=$S($P(Y,U,3)]"":$P(Y,U,3),1:$P(Y,U)) - S Y=$G(^PS(53.1,+ON,.2)),P("PD")=$S(+Y:$P(Y,U)_U_$$OIDF^PSJLMUT1(+Y),1:""),P("DO")=$P(Y,U,2),P("NAT")=$P(Y,U,3),P("PRY")=$P(Y,U,4),(PSJCOM,P("PRNTON"))=$P(Y,U,8) - S P("INS")=$G(^PS(53.1,+ON,.3)) - I $G(^PS(53.1,+ON,4))]"" S P("NINIT")=$P(^(4),U),P("NINITDT")=$P(^(4),U,2) - NEW NAME S NAME="" - I $D(^PS(53.1,+ON,1,1)) D DD^PSJLMUT1("^PS(53.1,+ON,",.NAME) - S P("INS")=P("INS")_$S(P("INS")]"":" of ",1:"")_NAME - S P("APPT")=$G(^PS(53.1,+ON,"DSS")),P("CLIN")=$P(P("APPT"),"^"),P("APPT")=$P(P("APPT"),"^",2) - S Y=$G(^PS(53.1,+ON,2)),P(9)=$P(Y,U),P(11)=$P(Y,U,5),P(15)=$S($P(Y,U,6)'="":$P(Y,U,6),$G(PSGS0XT)'="":PSGS0XT,$P($G(ZZND),"^",3)'="":$P(ZZND,"^",3),1:""),P(2)=$P(Y,U,2),P(3)=$P(Y,U,4) - S Y=$G(^PS(53.1,+ON,4)),P("CLRK")=$P(Y,U,7)_U_$P($G(^VA(200,+$P(Y,U,7),0)),U),P("REN")=$P(Y,U,9),X=P(9) - I $P($G(^PS(53.1,+ON,0)),U,7)="P",(P(9)'["PRN") S P(9)=P(9)_" PRN" - K PSGST,XT - I P(9)]"",(P(11)="") D S P(15)=$S($G(XT)]""&'+$G(XT):XT,+$G(XT)>0:XT,$G(PSGS0XT):PSGS0XT,1:1440),P(11)=Y - . I $O(^PS(51.1,"APPSJ",P(9),0)) D DIC^PSGORS0 Q - . I '$O(^PS(51.1,"APPSJ",P(9),0)) N NOECH,PSGSCH S NOECH=1 D EN^PSIVSP - S Y=$G(^PS(53.1,+ON,8)),P(4)=$P(Y,U),P(23)=$P(Y,U,2),P("SYRS")=$P(Y,U,3),P(5)=$P(Y,U,4),P(8)=$P(Y,U,5),P(7)=$P(Y,U,7),P("IVRM")=$P(Y,U,8) - S P(4)=$S(P(4)'="":P(4),$G(PSIVTYPE):PSIVTYPE,1:"") - S:'P("IVRM")&($D(PSIVSN)) P("IVRM")=+PSIVSN S Y=$G(^PS(59.5,+P("IVRM"),0)),$P(P("IVRM"),U,2)=$P(Y,U),Y=$G(^PS(53.1,+ON,9)),P("REM")=$P(Y,U),P("OPI")=$P(Y,U,2,3) - S P("DTYP")=$S(P(4)="":0,P(4)="P"!(P(23)="P")!(P(5)):1,P(4)="H":2,1:3) - S P("PACT")=$G(^PS(53.1,+ON,"A",1,0)) - D GTDRG,GTOT^PSIVUTL(P(4)) D:'$D(PSJLABEL) GTPC(ON) - N ND2P5 S ND2P5=$G(^PS(53.1,+ON,2.5)) D - .S P("DUR")=$P(ND2P5,"^",2) - .S P("LIMIT")=$P(ND2P5,"^",4) - .S P("IVCAT")=$P(ND2P5,"^",5) - Q -GTDRG ; - K DRG F X="AD","SOL" S FIL=$S(X="AD":52.6,1:52.7) F Y=0:0 S Y=$O(^PS(53.1,+ON,X,Y)) Q:'Y D - .S (DRGI,DRG(X,0))=$G(DRG(X,0))+1,DRG=$G(^PS(53.1,+ON,X,Y,0)),ND=$G(^PS(FIL,+DRG,0)),DRGN=$P(ND,U),DRG(X,+DRGI)=+DRG_U_$P(ND,U)_U_$P(DRG,U,2)_U_$P(DRG,U,3)_U_$P(ND,U,13)_U_$P(ND,U,11) - Q - ; -GTPC(ON) ; Retrieve Provider Comments and create "scratch" fields to edit - Q - ; -PUT531 ; Move data in local variables to 53.1 - S:'$D(P(9)) P(9)=$G(PSGSCH) - S ND(0)=+ON_U_+P(6)_U_$S(+P("MR"):+P("MR"),1:"")_U_$P(P("OT"),U)_U_U_U_"C",$P(ND(0),U,9)=P(17),$P(ND(0),U,21)=$G(P(21)) - S $P(ND(0),U,14,16)=P("LOG")_U_DFN_U_P("LOG"),$P(ND(0),U,24,26)=$G(P("RES"))_U_$G(P("OLDON"))_U_$G(P("NEWON")) - S ND(2)=P(9)_U_P(2)_U_U_P(3)_U_P(11)_U_$S($G(P(15))'="":P(15),$G(PSGS0XT)'="":PSGS0XT,$P($G(ZZND),"^",3)'="":$P(ZZND,"^",3),1:""),$P(ND(4),U,7,9)=+P("CLRK")_U_U_P("REN") - S ND(8)=P(4)_U_P(23)_U_P("SYRS")_U_P(5)_U_P(8)_"^^"_P(7)_"^"_+P("IVRM"),ND(9)=$S($L(P("REM")_P("OPI")):P("REM")_U_P("OPI"),1:"") S $P(ND(4),U,1,2)=$G(P("NINIT"))_U_$G(P("NINITDT")) - S:+$G(P("CLIN")) $P(^PS(53.1,+ON,"DSS"),"^")=P("CLIN") - S:+$G(P("APPT")) $P(^PS(53.1,+ON,"DSS"),"^",2)=P("APPT") - S:$G(P("LIMIT"))]"" $P(^PS(53.1,+ON,2.5),"^",4)=P("LIMIT") - I $G(PSJORD)["V"!($G(PSJORD)["P") I $G(^PS(53.1,+ON,2.5))="" N DUR S DUR=$$GETDUR^PSJLIVMD(DFN,+PSJORD,$S((PSJORD["P"):"P",1:"IV"),1) I DUR]"" D - .I $G(IVLIMIT) S $P(^PS(53.1,+ON,2.5),"^",4)=DUR K IVLIMIT Q - .S $P(^PS(53.1,+ON,2.5),"^",2)=DUR - F X=0,2,4,8,9 S ^PS(53.1,+ON,X)=ND(X) - S PSIVCAT=$$IVCAT^PSJHLU(DFN,ON,.P) S:PSIVCAT]"" $P(^PS(53.1,+ON,2.5),"^",5)=PSIVCAT K PSIVCAT - S:'+$G(^PS(53.1,+ON,.2)) $P(^(.2),U,1,3)=+P("PD")_U_P("DO")_U_$G(P("NAT")) - F DRGT="AD","SOL" D:$D(DRG(DRGT)) PTD531 - K DA,DIK S PSGS0Y=P(11),PSGS0XT=P(15),DA=+ON,DIK="^PS(53.1," D IX^DIK K DA,DIK,PSGS0Y,PSGS0XT,ND,^PS(53.1,"AS","P",DFN,+ON) - K:P(17)="A" ^PS(53.1,"AS","N",DFN,+ON) - S:P(15)="D" $P(^PS(53.1,+ON,2),U,6)="D" - Q - ; -UPD100 ; Update order data in file 100 - D:'$D(PSJIVORF) ORPARM^PSIVOREN Q:'PSJIVORF - S PSJORL=$$ENORL^PSJUTL($G(VAIN(4))) D SET^PSIVORFE - Q - ; -PTD531 ; Move drug data from local array into 53.1 - K ^PS(53.1,+ON,DRGT) S ^PS(53.1,+ON,DRGT,0)=$S(DRGT="AD":"^53.157^0^0",1:"^53.158^0^0") - F X=0:0 S X=$O(DRG(DRGT,X)) Q:'X D - .S X1=$P(DRG(DRGT,X),U),Y=^PS(53.1,+ON,DRGT,0),$P(Y,U,3)=$P(Y,U,3)+1,DRG=$P(Y,U,3),$P(Y,U,4)=$P(Y,U,4)+1 - .S ^PS(53.1,+ON,DRGT,0)=Y,Y=+X1_U_$P(DRG(DRGT,X),U,3) S:DRGT="AD" $P(Y,U,3)=$P(DRG(DRGT,X),U,4) S ^PS(53.1,+ON,DRGT,+DRG,0)=Y - Q +PSIVORFA ;BIR/MLM-FILE/RETRIEVE ORDERS IN 53.1 ;26 Jun 98 / 9:16 AM + ;;5.0; INPATIENT MEDICATIONS ;**4,7,18,28,50,71,58,91,80,110,111**;16 DEC 97 + ; + ; Reference to ^PS(51.1 supported by DBIA 2177. + ; Reference to ^PS(51.2 supported by DBIA 2178. + ; Reference to ^PS(52.7 supported by DBIA 2173. + ; Reference to ^PS(52.6 supported by DBIA 1231. + ; +GT531(DFN,ON) ; Retrieve order data from 53.1 and place into local array + ; + NEW PSGOES S PSGOES=1 + F X="CUM","LF","LFA","LF","PRNTON" S P(X)="" + S Y=$G(^PS(53.1,+ON,0)),P(17)=$P(Y,U,9),P("LOG")=$P(Y,U,16),(P(21),P("21FLG"),PSJORIFN)=$P(Y,U,21) + S P("RES")=$P(Y,U,24),P("OLDON")=$P(Y,U,25),P("NEWON")=$P(Y,U,26),P("FRES")=$P(Y,U,27) + S P("MR")=$P(Y,U,3),P(6)=+$P(Y,U,2),Y=$G(^VA(200,+P(6),0)),$P(P(6),U,2)=$P(Y,U),Y=$G(^PS(51.2,+P("MR"),0)),$P(P("MR"),U,2)=$S($P(Y,U,3)]"":$P(Y,U,3),1:$P(Y,U)) + S Y=$G(^PS(53.1,+ON,.2)),P("PD")=$S(+Y:$P(Y,U)_U_$$OIDF^PSJLMUT1(+Y),1:""),P("DO")=$P(Y,U,2),P("NAT")=$P(Y,U,3),P("PRY")=$P(Y,U,4),(PSJCOM,P("PRNTON"))=$P(Y,U,8) + S P("INS")=$G(^PS(53.1,+ON,.3)) + I $G(^PS(53.1,+ON,4))]"" S P("NINIT")=$P(^(4),U),P("NINITDT")=$P(^(4),U,2) + NEW NAME S NAME="" + I $D(^PS(53.1,+ON,1,1)) D DD^PSJLMUT1("^PS(53.1,+ON,",.NAME) + S P("INS")=P("INS")_$S(P("INS")]"":" of ",1:"")_NAME + S P("APPT")=$G(^PS(53.1,+ON,"DSS")),P("CLIN")=$P(P("APPT"),"^"),P("APPT")=$P(P("APPT"),"^",2) + ;;S Y=$G(^PS(53.1,+ON,2)),P(9)=$P(Y,U),P(11)=$P(Y,U,5),P(15)=$P(Y,U,6),Y=$G(^PS(53.1,+ON,4)),P("CLRK")=$P(Y,U,7)_U_$P($G(^VA(200,+$P(Y,U,7),0)),U),P("REN")=$P(Y,U,9),X=P(9) + S Y=$G(^PS(53.1,+ON,2)),P(9)=$P(Y,U),P(11)=$P(Y,U,5),P(15)=$P(Y,U,6),P(2)=$P(Y,U,2),P(3)=$P(Y,U,4) + S Y=$G(^PS(53.1,+ON,4)),P("CLRK")=$P(Y,U,7)_U_$P($G(^VA(200,+$P(Y,U,7),0)),U),P("REN")=$P(Y,U,9),X=P(9) + I $P($G(^PS(53.1,+ON,0)),U,7)="P",(P(9)'["PRN") S P(9)=P(9)_" PRN" + K PSGST,XT + I P(9)]"",(P(11)="") D S P(15)=$S($G(XT)]""&'+$G(XT):XT,+$G(XT)>0:XT,1:1440),P(11)=Y + . I $O(^PS(51.1,"APPSJ",P(9),0)) D DIC^PSGORS0 Q + . I '$O(^PS(51.1,"APPSJ",P(9),0)) N NOECH,PSGSCH S NOECH=1 D EN^PSIVSP + S Y=$G(^PS(53.1,+ON,8)),P(4)=$P(Y,U),P(23)=$P(Y,U,2),P("SYRS")=$P(Y,U,3),P(5)=$P(Y,U,4),P(8)=$P(Y,U,5),P(7)=$P(Y,U,7),P("IVRM")=$P(Y,U,8) + S:'P("IVRM")&($D(PSIVSN)) P("IVRM")=+PSIVSN S Y=$G(^PS(59.5,+P("IVRM"),0)),$P(P("IVRM"),U,2)=$P(Y,U),Y=$G(^PS(53.1,+ON,9)),P("REM")=$P(Y,U),P("OPI")=$P(Y,U,2,3) + S P("DTYP")=$S(P(4)="":0,P(4)="P"!(P(23)="P")!(P(5)):1,P(4)="H":2,1:3) + S P("PACT")=$G(^PS(53.1,+ON,"A",1,0)) + ;;D GTDRG,GTOT^PSIVUTL(P(4)) D:'$D(PSJLABEL) GTPC(ON) S (P(2),P(3))="" ;L -^PS(53.1,+ON) + D GTDRG,GTOT^PSIVUTL(P(4)) D:'$D(PSJLABEL) GTPC(ON) + Q +GTDRG ; + K DRG F X="AD","SOL" S FIL=$S(X="AD":52.6,1:52.7) F Y=0:0 S Y=$O(^PS(53.1,+ON,X,Y)) Q:'Y D + .S (DRGI,DRG(X,0))=$G(DRG(X,0))+1,DRG=$G(^PS(53.1,+ON,X,Y,0)),ND=$G(^PS(FIL,+DRG,0)),DRGN=$P(ND,U),DRG(X,+DRGI)=+DRG_U_$P(ND,U)_U_$P(DRG,U,2)_U_$P(DRG,U,3)_U_$P(ND,U,13)_U_$P(ND,U,11) + Q + ; +GTPC(ON) ; Retrieve Provider Comments and create "scratch" fields to edit + ;S:'$D(PSIVUP) PSIVUP=+$$GTPCI^PSIVUTL K ^PS(53.45,PSIVUP,4) I $O(^PS(53.1,+ON,12,0)) S %X="^PS(53.1,"_+ON_",12,",%Y="^PS(53.45,"_PSIVUP_",4," D %XY^%RCR + Q + ; +PUT531 ; Move data in local variables to 53.1 + S ND(0)=+ON_U_+P(6)_U_$S(+P("MR"):+P("MR"),1:"")_U_$P(P("OT"),U)_U_U_U_"C",$P(ND(0),U,9)=P(17),$P(ND(0),U,21)=$G(P(21)) + ;;S $P(ND(0),U,14,16)=P("LOG")_U_DFN_U_P("LOG"),$P(ND(0),U,21)=$S("AD"'[P(17):PSJORIFN,1:""),$P(ND(0),U,24,26)=$G(P("RES"))_U_$G(P("OLDON"))_U_$G(P("NEWON")) S ND(2)=P(9)_U_P(2)_U_U_P(3)_U_P(11)_U_P(15),$P(ND(4),U,7,9)=+P("CLRK")_U_U_P("REN") + S $P(ND(0),U,14,16)=P("LOG")_U_DFN_U_P("LOG"),$P(ND(0),U,24,26)=$G(P("RES"))_U_$G(P("OLDON"))_U_$G(P("NEWON")) S ND(2)=P(9)_U_P(2)_U_U_P(3)_U_P(11)_U_P(15),$P(ND(4),U,7,9)=+P("CLRK")_U_U_P("REN") + S ND(8)=P(4)_U_P(23)_U_P("SYRS")_U_P(5)_U_P(8)_"^^"_P(7)_"^"_+P("IVRM"),ND(9)=$S($L(P("REM")_P("OPI")):P("REM")_U_P("OPI"),1:"") + S $P(ND(4),U,1,2)=$G(P("NINIT"))_U_$G(P("NINITDT")) + S:+$G(P("CLIN")) $P(^PS(53.1,+ON,"DSS"),"^")=P("CLIN") + S:+$G(P("APPT")) $P(^PS(53.1,+ON,"DSS"),"^",2)=P("APPT") + I $G(PSJORD)["V"!($G(PSJORD)["P") I $G(^PS(53.1,+ON,2.5))="" N DUR S DUR=$$GETDUR^PSJLIVMD(DFN,+PSJORD,$S((PSJORD["P"):"P",1:"IV"),1) I DUR]"" D + .I $G(IVLIMIT) S $P(^PS(53.1,+ON,2.5),"^",4)=DUR K IVLIMIT Q + .S $P(^PS(53.1,+ON,2.5),"^",2)=DUR + F X=0,2,4,8,9 S ^PS(53.1,+ON,X)=ND(X) + ;;S:+P("PD") ^PS(53.1,+ON,.2)=+P("PD")_U_P("DO") + S:'+$G(^PS(53.1,+ON,.2)) $P(^(.2),U,1,3)=+P("PD")_U_P("DO")_U_$G(P("NAT")) + ;;K ^PS(53.1,+ON,12) I $O(^PS(53.45,PSIVUP,4,0)) S %X="^PS(53.45,"_PSIVUP_",4,",%Y="^PS(53.1,"_+ON_",12," D %XY^%RCR + ;;K ^PS(53.45,+PSIVUP,4) + F DRGT="AD","SOL" D:$D(DRG(DRGT)) PTD531 + K DA,DIK S PSGS0Y=P(11),PSGS0XT=P(15),DA=+ON,DIK="^PS(53.1," D IX^DIK K DA,DIK,PSGS0Y,PSGS0XT,ND,^PS(53.1,"AS","P",DFN,+ON) + K:P(17)="A" ^PS(53.1,"AS","N",DFN,+ON) + S:P(15)="D" $P(^PS(53.1,+ON,2),U,6)="D" + Q + ; +UPD100 ; Update order data in file 100 + D:'$D(PSJIVORF) ORPARM^PSIVOREN Q:'PSJIVORF + ;* S ORIFN=PSJORIFN,PSJORL=$$ENORL^PSJUTL($G(VAIN(4))) D SET^PSIVORFE K ORETURN ;; F X="OREVENT","ORSTS","ORSTRT","ORSTOP","ORPK","ORPCL","ORNP","ORPK" S ORETURN(X)=@X + S PSJORL=$$ENORL^PSJUTL($G(VAIN(4))) D SET^PSIVORFE + Q + ; +PTD531 ; Move drug data from local array into 53.1 + K ^PS(53.1,+ON,DRGT) S ^PS(53.1,+ON,DRGT,0)=$S(DRGT="AD":"^53.157^0^0",1:"^53.158^0^0") + F X=0:0 S X=$O(DRG(DRGT,X)) Q:'X D + .S X1=$P(DRG(DRGT,X),U),Y=^PS(53.1,+ON,DRGT,0),$P(Y,U,3)=$P(Y,U,3)+1,DRG=$P(Y,U,3),$P(Y,U,4)=$P(Y,U,4)+1 + .S ^PS(53.1,+ON,DRGT,0)=Y,Y=+X1_U_$P(DRG(DRGT,X),U,3) S:DRGT="AD" $P(Y,U,3)=$P(DRG(DRGT,X),U,4) S ^PS(53.1,+ON,DRGT,+DRG,0)=Y + Q diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVORFB.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVORFB.m index 11e78abc..2761242f 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVORFB.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVORFB.m @@ -1,138 +1,121 @@ -PSIVORFB ;BIR/MLM-FILE/RETRIEVE ORDERS IN ^PS(55 ;25 Sep 98 / 2:24 PM - ;;5.0; INPATIENT MEDICATIONS ;**3,18,28,68,58,85,110,111,120,134**;16 DEC 97;Build 124 - ; - ; Reference to ^PS(50.7 is supported by DBIA #2180. - ; Reference to ^PS(51.2 is supported by DBIA #2178. - ; Reference to ^PS(52.6 is supported by DBIA #1231. - ; Reference to ^PS(52.7 is supported by DBIA #2173. - ; Reference to ^PS(55 is supported by DBIA #2191. - ; -NEW55 ; Get new order number in 55. - N DA,DD,DO,DIC,DLAYGO,X,Y,PSIVLIM,MINS,PSJDSTP1,PSJDSTP2,A,PSJCLIN,PSJDNM,PSJPROV,PSJWARD,PSJPAO,PSJALRT - I $D(^PS(55,+DFN)),'$D(^PS(55,+DFN,0)) D ENSET0^PSGNE3(+DFN) - I $G(PSJORD)["V"!($G(PSJORD)["P"),$G(P(2))]"" D LIMSTOP(.PSJDSTP1,.PSJDSTP2) - I ($G(PSJORD)["P"!($G(PSJORD)["V"))&$G(PSIVLIM) I $$CMPLIM(PSJORD,PSJDSTP1,PSJDSTP2) D - . D - .. S PSJPROV=DUZ I PSJORD["P" S PSJPROV=$P($G(^PS(53.1,+PSJORD,0)),"^",2) - .. I PSJORD["V" S PSJPROV=$P($G(^PS(55,DFN,"IV",+PSJORD,0)),"^",6) - .. D NOW^%DTC S XQA(PSJPROV)="",XQAID="PSJ,"_DFN_";"_PSJPROV_";"_%,XQADATA="" - .. D - ... I PSJORD["P" S A=$G(^PS(53.1,+PSJORD,"DSS")) - ... I PSJORD["V" S A=$G(^PS(55,PSGP,"IV",+PSJORD,"DSS")) - ... S PSJCLIN=$P(A,"^") I PSJCLIN]"" S PSJCLIN=$P(^SC(PSJCLIN,0),"^") - .. S A=$G(^DPT(DFN,0)),PSJWARD=$G(^(.1)) - .. S XQAMSG=$P(A,"^")_" ("_$E($P(A,"^"))_$E($P(A,"^",9),6,9)_"): ["_$S(PSJWARD]"":$E(PSJWARD,1,10),$G(PSJCLIN)]"":$E(PSJCLIN,1,10),1:"UNKNOWN")_"] " - .. S A=$O(DRG("AD",0)) I A]"" S A=DRG("AD",A) - .. I A="" S A=$O(DRG("SOL",0)) I A]"" S A=DRG("SOL",A) - .. S PSJDNM=$P(^PS(50.7,+$P(A,"^",6),0),"^") - .. S XQAMSG=XQAMSG_PSJDNM_" your DURATION not used for stop date/time" - .. D SETUP^XQALERT - .. S PSJALRT=$$FMTDUR^PSJLIVMD($S(PSJORD["P":$P($G(^PS(53.1,+PSJORD,2.5)),"^",4),PSJORD["IV":$P($G(^PS(55,DFN,"IV",+PSJORD,2.5)),"^",4),1:"UNK")) - S DIC="^PS(55,",DIC(0)="LN",DLAYGO=55,(DINUM,X)=+DFN D ^DIC Q:Y<0 -LOCK0 F L +^PS(55,DFN,"IV",0):0 I Q - S ND=$S($D(^PS(55,DFN,"IV",0)):^(0),1:"^55.01") F DA=$P(ND,"^",3)+1:1 W "." I '$D(^PS(55,DFN,"IV",DA)) S $P(ND,"^",3)=DA,$P(ND,"^",4)=$P(ND,"^",4)+1,^PS(55,DFN,"IV",0)=ND Q - L +^PS(55,DFN,"IV",+DA):0 E G LOCK0 - S ^PS(55,DFN,"IV",+DA,0)=+DA,^PS(55,DFN,"IV","B",+DA,+DA)="" - L -^PS(55,DFN,"IV",0) S ON55=+DA_"V" - I $G(PSJALRT)]"" S PSIVAL="IV LIMIT OVERRIDDEN ("_$G(PSJALRT)_"): ALERT SENT",PSIVALT="",PSIVREA="E" D - .D LOG^PSIVORAL S P("LIMIT")="",P("OVRIDE")=1 K IVLIM,IVLIMIT - .S $P(^PS(55,DFN,"IV",+ON55,2.5),"^",4)="" S:$G(PSJORD)["P" $P(^PS(53.1,+PSJORD,2.5),"^",4)="" - .K PSIVAL,PSIVREA,PSIVALT - Q -SET55 ; Move data from local variables to 55. - I '$D(ON55) W !,"*** Can't create this order at this time ***" Q - N DA,DIK,ND,PSIVACT,PSIVDUR - S:'$D(P(21)) (P(21),P("21FLG"))="" S ND(0)=+ON55,P(22)=$S(VAIN(4):+VAIN(4),1:.5) F X=2:1:23 I $D(P(X)) S $P(ND(0),U,X)=P(X) - S ND(.3)=$G(P("INS")),ND(2.5)="" N X S X=$S($G(PSGORD):PSGORD,1:$G(ON)) I X D - .N PKG S PKG=$E(X,$L(X)) S PKG=$S(PKG="V":"""IV""",PKG="U":5,PKG="P":"P",1:"") Q:PKG="" - .S PSIVDUR=$$GETDUR^PSJLIVMD(DFN,+X,$E(X,$L(X)),1) Q:PSIVDUR="" - .I $G(IVLIMIT) S ND(2.5)="^^^"_PSIVDUR K IVLIMIT Q - S $P(ND(0),U,17)="A",ND(1)=P("REM"),ND(3)=P("OPI"),ND(.2)=$P($G(P("PD")),U)_U_$G(P("DO"))_U_+P("MR")_U_$G(P("PRY"))_U_$G(P("NAT"))_U_U_U_$G(P("PRNTON")) - F X=0,1,2.5,3,.2,.3 S ^PS(55,DFN,"IV",+ON55,X)=ND(X) - S $P(^PS(55,DFN,"IV",+ON55,2),U,1,4)=P("LOG")_U_+P("IVRM")_U_U_P("SYRS"),$P(^(2),U,8,10)=P("RES")_U_$G(P("FRES"))_U_$S($G(VAIN(4)):+VAIN(4),1:"") - S X=^PS(55,DFN,0) I $P(X,"^",7)="" S $P(X,"^",7)=$P($P(P("LOG"),"^"),"."),$P(X,"^",8)="A",^(0)=X - S $P(^PS(55,DFN,"IV",+ON55,2),U,11)=+P("CLRK") - S:+$G(P("CLIN")) $P(^PS(55,DFN,"IV",+ON55,"DSS"),"^")=P("CLIN") - S:+$G(P("APPT")) $P(^PS(55,DFN,"IV",+ON55,"DSS"),"^",2)=P("APPT") - S:+$G(P("NINIT")) ^PS(55,DFN,"IV",+ON55,4)=P("NINIT")_U_P("NINITDT") - I '$G(PSIVCHG)!($G(PSJREN)&($G(PSIVCHG)=2)) I $G(P("PON")),P("PON")'=ON55 D - . N X S X=$S(P("PON")["P":"^PS(53.1,+P(""PON""),12,0)",P("PON")["V"&$G(PSJREN):"^PS(55,DFN,""IV"",+P(""PON""),5,0)",1:"") Q:X="" - . I $O(@X) S %X=X,%Y="^PS(55,"_DFN_",""IV"","_+ON55_",5," D %XY^%RCR - F DRGT="AD","SOL" D PUTD55 - K DA,DIK S DA(1)=DFN,DA=+ON55,DIK="^PS(55,"_DA(1)_",""IV"",",PSIVACT=1 D IX^DIK - I $G(PSJCOM),$G(PSJCOMSI),$G(PSJORD)["V" K PSJCOMSI N PSJCHILD,PSJOEORD S PSJOEORD=0 F S PSJOEORD=$O(^PS(55,"ACX",PSJCOM,PSJOEORD)) Q:'PSJOEORD D - . N PSJCHILD S PSJCHILD=0 F S PSJCHILD=$O(^PS(55,"ACX",PSJCOM,PSJOEORD,PSJCHILD)) Q:'PSJCHILD S PSJCHILD(+PSJCHILD)=PSJCOM - . S PSJCHILD=0 F S PSJCHILD=$O(PSJCHILD(PSJCHILD)) Q:'PSJCHILD D - .. Q:PSJCHILD=PSJORD K DR,DA,DIE,ORD S DR="31////"_$P($G(P("OPI")),"^",1,2),DA(1)=DFN - .. N ON,ON55 S (ON,ON55)=+PSJCHILD_"V" S:+$G(PSJPINIT)'>0 PSJPINIT=DUZ S PSIVALT=1,PSIVAL="COMPLEX ORDER" D ENTACT^PSIVAL D - ... I $P($G(^PS(55,DFN,"IV",+ON55,3)),"^")'=$P(P("OPI"),"^") S P("FC")="OTHER PRINT INFO^"_$P($G(^(3)),"^")_U_$P(P("OPI"),"^") D GTFC^PSIVORAL - ... I $D(^PS(55,DFN,"IV",+ON55,0)) S ^PS(55,DFN,"IV",+ON55,3)=P("OPI") D EN1^PSJHL2(DFN,"XX",ON55) - Q - ; -PUTD55 ; Move drug data from local array into 55 - K ^PS(55,DFN,"IV",+ON55,DRGT) S ^PS(55,DFN,"IV",+ON55,DRGT,0)=$S(DRGT="AD":"^55.02PA",1:"^55.11IPA") - F X=0:0 S X=$O(DRG(DRGT,X)) Q:'X D - .S Y=^PS(55,DFN,"IV",+ON55,DRGT,0),$P(Y,U,3)=$P(Y,U,3)+1,DRG=$P(Y,U,3),$P(Y,U,4)=$P(Y,U,4)+1 - .S ^PS(55,DFN,"IV",+ON55,DRGT,0)=Y,Y=$P(DRG(DRGT,X),U)_U_$P(DRG(DRGT,X),U,3) S:DRGT="AD" $P(Y,U,3)=$P(DRG(DRGT,X),U,4) S ^PS(55,DFN,"IV",+ON55,DRGT,+DRG,0)=Y - Q -GT55 ; Retrieve data from 55 into local array - K DRG,DRGN,P S:'$D(ON55) ON55=ON S P("REN")="",Y=$G(^PS(55,DFN,"IV",+ON55,0)) F X=1:1:23 S P(X)=$P(Y,U,X) - S P("21FLG")=P(21) - S P("PON")=ON55,PSJORIFN=P(21),P(6)=P(6)_U_$P($G(^VA(200,+P(6),0)),U),(DRG,DRGN)="",P("REM")=$G(^PS(55,DFN,"IV",+ON55,1)) - S Y=$G(^PS(55,DFN,"IV",+ON55,2)),P("LOG")=$P(Y,U),P("IVRM")=$P(Y,U,2)_U_$P($G(^PS(59.5,+$P(Y,U,2),0)),U) - S P("CLRK")=$P(Y,U,11)_U_$P($G(^VA(200,+$P(Y,U,11),0)),U),P("RES")=$P(Y,U,8),P("FRES")=$P(Y,U,9),P("SYRS")=$P(Y,U,4),P("OPI")=$G(^PS(55,DFN,"IV",+ON55,3)) - S P("INS")=$G(^PS(55,DFN,"IV",+ON55,.3)) - S P("CLIN")=$P($G(^PS(55,DFN,"IV",+ON55,"DSS")),"^"),P("APPT")=$P($G(^PS(55,DFN,"IV",+ON55,"DSS")),"^",2) - S P("DTYP")=$S(P(4)="":0,P(4)="P"!(P(23)="P")!(P(5)):1,P(4)="H":2,1:3) - D:'$D(PSJLABEL) GTPC(ON55) S ND=$G(^PS(55,DFN,"IV",+ON55,.2)),P("PD")=$S($P(ND,U):$P(ND,U)_U_$$OIDF^PSJLMUT1(+ND)_U_$P($G(^PS(50.7,+ND,0)),U),1:""),P("DO")=$P(ND,U,2),P("PRY")=$P(ND,U,4),P("NAT")=$P(ND,U,5),(PSJCOM,P("PRNTON"))=$P(ND,U,8) - I P("PRY")="D",'+P("IVRM") S P("IVRM")=+$G(PSIVSN)_U_$P($G(^PS(59.5,+$G(PSIVSN),0)),U) - S P("MR")=$P(ND,U,3),ND=$G(^PS(51.2,+P("MR"),0)),P("MR")=P("MR")_U_$S($P(ND,U,3)]"":$P(ND,U,3),1:$P(ND,U)) D GTCUM - D GTDRG,GTOT^PSIVUTL(P(4)) - N ND2P5 S ND2P5=$G(^PS(55,DFN,"IV",+ON55,2.5)) D - .S P("DUR")=$P(ND2P5,"^",2) - .S P("LIMIT")=$P(ND2P5,"^",4) - .S P("IVCAT")=$P(ND2P5,"^",5) -K ; Kill and exit. - K FIL,ND - Q -GTDRG ; Get drug info and place in DRG(. - F DRGT="AD","SOL" S FIL=$S(DRGT="AD":52.6,1:52.7) F Y=0:0 S Y=$O(^PS(55,DFN,"IV",+ON55,DRGT,Y)) Q:'Y D - .; naked ref below refers to line above - .S DRG=$G(^(Y,0)),ND=$G(^PS(FIL,+DRG,0)),(DRGI,DRG(DRGT,0))=$G(DRG(DRGT,0))+1 - .S DRG(DRGT,+DRGI)=+DRG_U_$P(ND,U)_U_$P(DRG,U,2)_U_$P(DRG,U,3)_U_$P(ND,U,13)_U_$P(ND,U,11) - Q - ; -GTCUM ; Retrieve dispensing info. - S ND=$G(^PS(55,DFN,"IV",+ON55,9)),P("LF")=$P(ND,U),P("LFA")=$P(ND,U,2),P("CUM")=$P(ND,U,3) - Q - ; -GTPC(ON) ; Retrieve Provider Comments and create "scratch" fields to edit - Q - ; -SETNEW ; Create new order and set - D NEW55,SET55 - Q - ; -CMPLIM(PSJORD,PSJDSTP1,PSJDSTP2) ; Compare stop date of order against IV Limit - I $P($G(^PS(53.1,+PSJORD,0)),"^",25)]"" D CHKD Q:PSJPAO 0 - I $G(PSJDSTP1),$E(+PSJDSTP1,1,11)'=$E(+P(3),1,11),+PSJDSTP2'=+P(3) Q 1 - Q 0 - ; -LIMSTOP(PSJDSTP1,PSJDSTP2) ; Calculate default stop date using IV Limit - ; Output: PSJDSTP1 - Default stop using duration only - ; PSJDSTP2 - Default stop using duration and IV parameters for time - S PSIVLIM=$$GETLIM^PSIVCAL(DFN,PSJORD) - I 'PSIVLIM,PSIVLIM]"" S PSIVLIM=$$GETMIN^PSIVCAL(PSIVLIM,DFN,PSJORD) - I PSIVLIM]"" D - . S MINS=$$GETMIN^PSIVCAL(PSIVLIM,DFN,PSJORD),PSJDSTP1=$$FMADD^XLFDT(P(2),,,MINS) - . S X=$P(PSJDSTP1,"."),PSJDSTP2=X_$S($P(PSIVSITE,"^",14)="":.2359,1:"."_$P(PSIVSITE,"^",14)) - Q - ; -CHKD ;Check for a previous active order and compare the duration - N PSJPO,A,PSJDUR - S PSJDUR=$$GETLIM^PSIVCAL(DFN,PSJORD) - S PSJPAO=0,PSJPO=PSJORD -CHKDR S PSJPO=$P($G(^PS(53.1,+PSJPO,0)),"^",25) Q:PSJPO="" - I PSJPO["P" G CHKDR - I PSJPO["V" S PSIVLIM=$$GETLIM^PSIVCAL(DFN,PSJPO) I PSJDUR'=PSIVLIM S PSJPAO=1 Q - G CHKDR +PSIVORFB ;BIR/MLM-FILE/RETRIEVE ORDERS IN ^PS(55 ;25 Sep 98 / 2:24 PM + ;;5.0; INPATIENT MEDICATIONS ;**3,18,28,68,58,85,110,111,120**;16 DEC 97;Build 10 + ; + ; Reference to ^PS(50.7 is supported by DBIA #2180. + ; Reference to ^PS(51.2 is supported by DBIA #2178. + ; Reference to ^PS(52.6 is supported by DBIA #1231. + ; Reference to ^PS(52.7 is supported by DBIA #2173. + ; Reference to ^PS(55 is supported by DBIA #2191. + ; +NEW55 ; Get new order number in 55. + N DA,DD,DO,DIC,DLAYGO,X,Y,PSIVLIM,MINS,PSJDSTP1,PSJDSTP2,A,PSJCLIN,PSJDNM,PSJPROV,PSJWARD,PSJPAO + I $D(^PS(55,+DFN)),'$D(^PS(55,+DFN,0)) D ENSET0^PSGNE3(+DFN) + I $G(PSJORD)["V"!($G(PSJORD)["P"),$G(P(2))]"" S PSIVLIM=$$GETLIM^PSIVCAL(DFN,PSJORD) I PSIVLIM D + . S MINS=$$GETMIN^PSIVCAL(PSIVLIM,DFN,PSJORD),PSJDSTP1=$$FMADD^XLFDT(P(2),,,MINS) + . S X=$P(PSJDSTP1,"."),PSJDSTP2=X_$S($P(PSIVSITE,"^",14)="":.2359,1:"."_$P(PSIVSITE,"^",14)) + I $G(PSJORD)["P",$G(PSIVLIM) D + . I $P($G(^PS(53.1,+PSJORD,0)),"^",25)]"" D CHKD Q:PSJPAO + . I $G(PSJDSTP1),+PSJDSTP1'=+P(3),+PSJDSTP2'=+P(3) D + .. S PSJPROV=DUZ I PSJORD["P" S PSJPROV=$P($G(^PS(53.1,+PSJORD,0)),"^",2) + .. I PSJORD["V" S PSJPROV=$P($G(^PS(55,DFN,"IV",+PSJORD,0)),"^",6) + .. D NOW^%DTC S XQA(PSJPROV)="",XQAID="PSJ,"_DFN_";"_PSJPROV_";"_%,XQADATA="" + .. D + ... I PSJORD["P" S A=$G(^PS(53.1,+PSJORD,"DSS")) + ... I PSJORD["V" S A=$G(^PS(55,PSGP,"IV",+PSJORD,"DSS")) + ... S PSJCLIN=$P(A,"^") I PSJCLIN]"" S PSJCLIN=$P(^SC(PSJCLIN,0),"^") + .. S A=$G(^DPT(DFN,0)),PSJWARD=$G(^(.1)) + .. S XQAMSG=$P(A,"^")_" ("_$E($P(A,"^"))_$E($P(A,"^",9),6,9)_"): ["_$S(PSJWARD]"":$E(PSJWARD,1,10),$G(PSJCLIN)]"":$E(PSJCLIN,1,10),1:"UNKNOWN")_"] " + .. S A=$O(DRG("AD",0)) I A]"" S A=DRG("AD",A) + .. I A="" S A=$O(DRG("SOL",0)) I A]"" S A=DRG("SOL",A) + .. S PSJDNM=$P(^PS(50.7,+$P(A,"^",6),0),"^") + .. S XQAMSG=XQAMSG_PSJDNM_" your DURATION not used for stop date/time" + .. D SETUP^XQALERT + S DIC="^PS(55,",DIC(0)="LN",DLAYGO=55,(DINUM,X)=+DFN D ^DIC Q:Y<0 +LOCK0 F L +^PS(55,DFN,"IV",0):0 I Q + S ND=$S($D(^PS(55,DFN,"IV",0)):^(0),1:"^55.01") F DA=$P(ND,"^",3)+1:1 W "." I '$D(^PS(55,DFN,"IV",DA)) S $P(ND,"^",3)=DA,$P(ND,"^",4)=$P(ND,"^",4)+1,^PS(55,DFN,"IV",0)=ND Q + L +^PS(55,DFN,"IV",+DA):0 E G LOCK0 + S ^PS(55,DFN,"IV",+DA,0)=+DA,^PS(55,DFN,"IV","B",+DA,+DA)="" + L -^PS(55,DFN,"IV",0) S ON55=+DA_"V" + Q + ; +SET55 ; Move data from local variables to 55. + I '$D(ON55) W !,"*** Can't create this order at this time ***" Q + N DA,DIK,ND,PSIVACT,PSIVDUR + S:'$D(P(21)) (P(21),P("21FLG"))="" S ND(0)=+ON55,P(22)=$S(VAIN(4):+VAIN(4),1:.5) F X=2:1:23 I $D(P(X)) S $P(ND(0),U,X)=P(X) + S ND(.3)=$G(P("INS")),ND(2.5)="" N X S X=$S($G(PSGORD):PSGORD,1:$G(ON)) I X D + .N PKG S PKG=$E(X,$L(X)) S PKG=$S(PKG="V":"""IV""",PKG="U":5,PKG="P":"P",1:"") Q:PKG="" + .S PSIVDUR=$$GETDUR^PSJLIVMD(DFN,+X,$E(X,$L(X)),1) Q:PSIVDUR="" + .I $G(IVLIMIT) S ND(2.5)="^^^"_PSIVDUR K IVLIMIT Q + .S ND(2.5)="^"_PSIVDUR + S $P(ND(0),U,17)="A",ND(1)=P("REM"),ND(3)=P("OPI"),ND(.2)=$P($G(P("PD")),U)_U_$G(P("DO"))_U_+P("MR")_U_$G(P("PRY"))_U_$G(P("NAT"))_U_U_U_$G(P("PRNTON")) + F X=0,1,2.5,3,.2,.3 S ^PS(55,DFN,"IV",+ON55,X)=ND(X) + S $P(^PS(55,DFN,"IV",+ON55,2),U,1,4)=P("LOG")_U_+P("IVRM")_U_U_P("SYRS"),$P(^(2),U,8,10)=P("RES")_U_$G(P("FRES"))_U_$S($G(VAIN(4)):+VAIN(4),1:"") + S X=^PS(55,DFN,0) I $P(X,"^",7)="" S $P(X,"^",7)=$P($P(P("LOG"),"^"),"."),$P(X,"^",8)="A",^(0)=X + S $P(^PS(55,DFN,"IV",+ON55,2),U,11)=+P("CLRK") + S:+$G(P("CLIN")) $P(^PS(55,DFN,"IV",+ON55,"DSS"),"^")=P("CLIN") + S:+$G(P("APPT")) $P(^PS(55,DFN,"IV",+ON55,"DSS"),"^",2)=P("APPT") + S:+$G(P("NINIT")) ^PS(55,DFN,"IV",+ON55,4)=P("NINIT")_U_P("NINITDT") + ;S:'$D(PSIVUP) PSIVUP=+$$GTPCI^PSIVUTL K ^PS(55,DFN,"IV",+ON55,5) I $O(^PS(53.45,PSIVUP,4,0)) S %X="^PS(53.45,"_PSIVUP_",4,",%Y="^PS(55,"_DFN_",""IV"","_+ON55_",5," D %XY^%RCR + I '$G(PSIVCHG)!($G(PSJREN)&($G(PSIVCHG)=2)) I $G(P("PON")),P("PON")'=ON55 D + . N X S X=$S(P("PON")["P":"^PS(53.1,+P(""PON""),12,0)",P("PON")["V"&$G(PSJREN):"^PS(55,DFN,""IV"",+P(""PON""),5,0)",1:"") Q:X="" + . I $O(@X) S %X=X,%Y="^PS(55,"_DFN_",""IV"","_+ON55_",5," D %XY^%RCR + F DRGT="AD","SOL" D PUTD55 + K DA,DIK S DA(1)=DFN,DA=+ON55,DIK="^PS(55,"_DA(1)_",""IV"",",PSIVACT=1 D IX^DIK + I $G(PSJCOM),$G(PSJCOMSI),$G(PSJORD)["V" K PSJCOMSI N PSJCHILD,PSJOEORD S PSJOEORD=0 F S PSJOEORD=$O(^PS(55,"ACX",PSJCOM,PSJOEORD)) Q:'PSJOEORD D + . N PSJCHILD S PSJCHILD=0 F S PSJCHILD=$O(^PS(55,"ACX",PSJCOM,PSJOEORD,PSJCHILD)) Q:'PSJCHILD S PSJCHILD(+PSJCHILD)=PSJCOM + . S PSJCHILD=0 F S PSJCHILD=$O(PSJCHILD(PSJCHILD)) Q:'PSJCHILD D + .. Q:PSJCHILD=PSJORD K DR,DA,DIE,ORD S DR="31////"_$P($G(P("OPI")),"^",1,2),DA(1)=DFN + .. N ON,ON55 S (ON,ON55)=+PSJCHILD_"V" S:+$G(PSJPINIT)'>0 PSJPINIT=DUZ S PSIVALT=1,PSIVAL="COMPLEX ORDER" D ENTACT^PSIVAL D + ... I $P($G(^PS(55,DFN,"IV",+ON55,3)),"^")'=$P(P("OPI"),"^") S P("FC")="OTHER PRINT INFO^"_$P($G(^(3)),"^")_U_$P(P("OPI"),"^") D GTFC^PSIVORAL + ... I $D(^PS(55,DFN,"IV",+ON55,0)) S ^PS(55,DFN,"IV",+ON55,3)=P("OPI") D EN1^PSJHL2(DFN,"XX",ON55) + Q + ; +PUTD55 ; Move drug data from local array into 55 + K ^PS(55,DFN,"IV",+ON55,DRGT) S ^PS(55,DFN,"IV",+ON55,DRGT,0)=$S(DRGT="AD":"^55.02PA",1:"^55.11IPA") + F X=0:0 S X=$O(DRG(DRGT,X)) Q:'X D + .S Y=^PS(55,DFN,"IV",+ON55,DRGT,0),$P(Y,U,3)=$P(Y,U,3)+1,DRG=$P(Y,U,3),$P(Y,U,4)=$P(Y,U,4)+1 + .S ^PS(55,DFN,"IV",+ON55,DRGT,0)=Y,Y=$P(DRG(DRGT,X),U)_U_$P(DRG(DRGT,X),U,3) S:DRGT="AD" $P(Y,U,3)=$P(DRG(DRGT,X),U,4) S ^PS(55,DFN,"IV",+ON55,DRGT,+DRG,0)=Y + Q +GT55 ; Retrieve data from 55 into local array + K DRG,DRGN,P S:'$D(ON55) ON55=ON S P("REN")="",Y=$G(^PS(55,DFN,"IV",+ON55,0)) F X=1:1:23 S P(X)=$P(Y,U,X) + S P("21FLG")=P(21) + S P("PON")=ON55,PSJORIFN=P(21),P(6)=P(6)_U_$P($G(^VA(200,+P(6),0)),U),(DRG,DRGN)="",P("REM")=$G(^PS(55,DFN,"IV",+ON55,1)) + S Y=$G(^PS(55,DFN,"IV",+ON55,2)),P("LOG")=$P(Y,U),P("IVRM")=$P(Y,U,2)_U_$P($G(^PS(59.5,+$P(Y,U,2),0)),U) + S P("CLRK")=$P(Y,U,11)_U_$P($G(^VA(200,+$P(Y,U,11),0)),U),P("RES")=$P(Y,U,8),P("FRES")=$P(Y,U,9),P("SYRS")=$P(Y,U,4),P("OPI")=$G(^PS(55,DFN,"IV",+ON55,3)) + S P("INS")=$G(^PS(55,DFN,"IV",+ON55,.3)) + S P("CLIN")=$P($G(^PS(55,DFN,"IV",+ON55,"DSS")),"^"),P("APPT")=$P($G(^PS(55,DFN,"IV",+ON55,"DSS")),"^",2) + S P("DTYP")=$S(P(4)="":0,P(4)="P"!(P(23)="P")!(P(5)):1,P(4)="H":2,1:3) + D:'$D(PSJLABEL) GTPC(ON55) S ND=$G(^PS(55,DFN,"IV",+ON55,.2)),P("PD")=$S($P(ND,U):$P(ND,U)_U_$$OIDF^PSJLMUT1(+ND)_U_$P($G(^PS(50.7,+ND,0)),U),1:""),P("DO")=$P(ND,U,2),P("PRY")=$P(ND,U,4),P("NAT")=$P(ND,U,5),(PSJCOM,P("PRNTON"))=$P(ND,U,8) + I P("PRY")="D",'+P("IVRM") S P("IVRM")=+$G(PSIVSN)_U_$P($G(^PS(59.5,+$G(PSIVSN),0)),U) + S P("MR")=$P(ND,U,3),ND=$G(^PS(51.2,+P("MR"),0)),P("MR")=P("MR")_U_$S($P(ND,U,3)]"":$P(ND,U,3),1:$P(ND,U)) D GTCUM + D GTDRG,GTOT^PSIVUTL(P(4)) +K ; Kill and exit. + K FIL,ND + Q +GTDRG ; Get drug info and place in DRG(. + F DRGT="AD","SOL" S FIL=$S(DRGT="AD":52.6,1:52.7) F Y=0:0 S Y=$O(^PS(55,DFN,"IV",+ON55,DRGT,Y)) Q:'Y D + .; naked ref below refers to line above + .S DRG=$G(^(Y,0)),ND=$G(^PS(FIL,+DRG,0)),(DRGI,DRG(DRGT,0))=$G(DRG(DRGT,0))+1 + .S DRG(DRGT,+DRGI)=+DRG_U_$P(ND,U)_U_$P(DRG,U,2)_U_$P(DRG,U,3)_U_$P(ND,U,13)_U_$P(ND,U,11) + Q + ; +GTCUM ; Retrieve dispensing info. + S ND=$G(^PS(55,DFN,"IV",+ON55,9)),P("LF")=$P(ND,U),P("LFA")=$P(ND,U,2),P("CUM")=$P(ND,U,3) + Q + ; +GTPC(ON) ; Retrieve Provider Comments and create "scratch" fields to edit + ;S:'$D(PSIVUP) PSIVUP=+$$GTPCI^PSIVUTL K ^PS(53.45,PSIVUP,4) + ;K ^PS(53.45,PSIVUP,4) I $O(^PS(55,DFN,"IV",+ON,5,0)) S %X="^PS(55,"_DFN_",""IV"","_+ON_",5,",%Y="^PS(53.45,"_PSIVUP_",4," D %XY^%RCR + Q + ; +SETNEW ; Create new order and set + D NEW55,SET55 + Q +CHKD ;Check for a previous active order and compare the duration + N PSJPO,A,PSJDUR + S PSJDUR=$$GETLIM^PSIVCAL(DFN,PSJORD) + S PSJPAO=0,PSJPO=PSJORD +CHKDR S PSJPO=$P($G(^PS(53.1,+PSJPO,0)),"^",25) Q:PSJPO="" + I PSJPO["P" G CHKDR + I PSJPO["V" S PSIVLIM=$$GETLIM^PSIVCAL(DFN,PSJPO) I PSJDUR'=PSIVLIM S PSJPAO=1 Q + G CHKDR diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVSP.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVSP.m index 7c14191c..f932071b 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVSP.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVSP.m @@ -1,109 +1,104 @@ -PSIVSP ;BIR/RGY,PR,CML3-DOSE PROCESSOR ;09 Feb 99 / 12:30 PM - ;;5.0; INPATIENT MEDICATIONS ;**30,37,41,50,56,74,83,111,133,138,134**;16 DEC 97;Build 124 - ; - ; Reference to ^PS(51.1 is supported by DBIA #2177 - ; -EN ; - Q:'$D(X) - S ATZERO=0 I X["@",$P(X,"@",2)=0 S ATZERO=1,X=$P(X,"@") - D EN^PSGS0 S (P(9),PSIVSC1)=$S($G(X)]"":X,1:$G(P(9))),P(11)=$S($G(PSGS0Y):PSGS0Y,1:$G(P(11))),(XT,P(15))=$S(($G(PSGS0XT)!($G(PSGS0XT)="O")!($G(PSGS0XT)="D")):$G(PSGS0XT),1:$G(P(15))) - I $G(ATZERO) S P(7)=1 - K ATZERO Q -EN1 ; - S (PSIVAT,PSIVWAT,Y)="",XT=-1,X0=X,X=$S(X="ON CALL":X,X="ONCALL":X,X="ON-CALL":X,X="ONETIME":X,X="ONE-TIME":X,X="ONE TIME":X,X="1TIME":X,X="1 TIME":X,X="1-TIME":X,$L(X," ")<3:$P(X," "),1:$P(X," ",1,2)) - S:$E(X)="^" X=$E(X,2,999) G:X="" Q S:X["@0" ATZERO=1 S X=$S(X["@0":$P(X,"@"),1:X),P(7)=$S($D(ATZERO):1,1:"") K ATZERO - I $S($D(^PS(51.1,"AC","PSJ",X)):1,1:$E($O(^(X)),1,$L(X))=X) D DIC I Y'<0 G SH -NS0 S Y="" - I $E(X,1,2)="AD" S XT=-1 Q - I $E(X,1,3)="BID"!($E(X,1,3)="TID")!($E(X,1,3)="QID") S XT=1440\$F("BTQ",$E(X)) - E S:$E(X)="Q" X=$E(X,2,99) S:'X X=$E(X)["O"+1_X S I=+X,X=$P(X,I,2),XT=I*$S(X["'":1,(X["D"&(X'["AD"))!(X["AM")!(X["PM")!(X["HS"&(X'["THS")):1440,X["H"&(X'["TH"):60,X["AC"!(X["PC"):480,X["W":10080,X["M":40320,1:0),X=X0 D - . I 'XT,X'="NOW",X'="STAT",X'="ONCE",X'="ONE-TIME",X'="ONE TIME",X'="ONETIME",X'="1-TIME",X'="1 TIME",X'="1TIME",Y="" S XT=-1 -SH ; - I +Y<1,$E(X0)'="^" W:$G(ON)'["P" " ",$S(XT=0&($S("^NOW^STAT^ONCE^ONE-TIME^ONETIME^1TIME^1-TIME^"[(U_$P(X," ")_U):1,X["1 TIME":1,1:X["ONE TIME")):"(ONCE ONLY)",XT>0:"Nonstandard schedule",XT<0:"",1:"(??)") W:XT>0 " (",XT," MINUTES)" -Q Q:X="ONE TIME" - N I S X0=$P(X," ")_$S($L(X0," ")-1:" ",1:"")_$P(X0," ",2,99) K:XT<0!($L(X0)>22) X S:$D(X) X=X0 K X0 S:$G(P(7)) XT="" Q -NEWQ ;N I S X0=$P(X," ")_$S($L(X0," ")-1:" ",1:"")_$P(X0," ",2,99) K:XT<0!($L(X0)>22) X S:$D(X) X=X0 S:P(7) X=X0 K X0 K:XT>0&('P(7)) X Q - Q - ; -ENDL W " Dose limit .... " S PSIVMIN=P(15)*X,PSIVSD=+P(2) - I PSIVMIN<0 W !!," --- There is something wrong with this order !!",!," Call inpatient supervisor ....." S Y=-1 K PSIVMIN Q - I P(4)="P"!(P(5))!(P(23)="P"),PSIVMIN=0,"^NOW^STAT^ONCE^ONE-TIME^ONE TIME^ON CALL^ONETIME^1TIME^1 TIME^1-TIME^"'[(U_P(9)_U) D DLP G QDL - D ENT^PSIVWL -QDL I $D(X) S X=Y X ^DD("DD") W $P(Y,"@")," ",$P(Y,"@",2) S Y=X - Q -DLP ; - S X=X+1,$P(PSIVSD,".",2)=$P(PSIVSD,".",2)_$E("0000",1,4-$L($P(PSIVSD,".",2))) D CHK S X2=0,Y=1 I X<2 S Y=+PSIVSD G QDLP - I $P(PSIVSD,".",2)>$P(P(11),"-",$L(P(11),"-")) S X2=1 G OV - G:$P(P(11),"-")>$P(PSIVSD,".",2) OV - F Y=1:1 S X1=$P(P(11),"-",Y) I X1=$P(PSIVSD,".",2)!($P(PSIVSD,".",2)0 S X1=PSIVSD D C^%DTC S X=$P(X,".") ; install with version 17.3 of fileman - S Y=+(X_"."_$P(P(11),"-",Y)) -QDLP K X1,X2 Q - ; -ENI ; - K:$L(X)<1!($L(X)>30)!(X["""")!($A(X)=45) X I '$D(X)!'$D(P(4)) Q - I P(4)="P"!(P(5))!(P(23)="P") Q:'X S X="INFUSE OVER "_X_" MINUTE"_$S(X>1:"S",1:"") W " ",X Q - I X'=+X,($P(X,"@",2,999)'=+$P(X,"@",2,999)!(+$P(X,"@",2,999)<0)) K X Q - S SPSOL=$O(DRG("SOL",0)) I 'SPSOL K SPSOL,X W " You must define at least one solution !!" Q - I X=+X S X=X_" ml/hr" W " ml/hr" D SPSOL S P(15)=$S('X:0,1:SPSOL\X*60+(SPSOL#X/X*60+.5)\1) K SPSOL Q - S SPSOL=$P(X,"@",2) S:$P(X,"@")=+X $P(X,"@")=$P(X,"@")_" ml/hr" W " ",+SPSOL," Label",$S(SPSOL'=1:"s",1:"")," per day",!?15,"at an infusion rate of: ",$P(X,"@") S P(15)=$S('SPSOL:0,1:1440/SPSOL\1) K SPSOL - Q -SPSOL S SPSOL=0 F XXX=0:0 S XXX=$O(DRG("SOL",XXX)) Q:'XXX S SPSOL=SPSOL+$P(DRG("SOL",XXX),U,3) - K XXX Q -CHK F Y=1:1 Q:$L(P(11))>240!($P(P(11),"-",Y)="") S $P(P(11),"-",Y)=$P(P(11),"-",Y)_$E("0000",1,4-$L($P(P(11),"-",Y))) - Q - ; -DIC ; 51.1 look-up - N PSJSCH S PSJSCH=X I '$D(WSCHADM) N VAIP D IN5^VADPT S WSCHADM=VAIP(5),X=PSJSCH - K DIC S DIC="^PS(51.1,",DIC(0)=$E("E",'$D(NOECH))_"ISZ" - S DIC("W")="W "" "","_$S('$D(WSCHADM):"$P(^(0),""^"",2)",'+WSCHADM:"$P(^(0),""^"",2)",1:"$S($D(^PS(51.1,+Y,1,+WSCHADM,0)):$P(^(0),""^"",2),1:$P(^PS(51.1,+Y,0),""^"",2))"),D="APPSJ" S:$D(PSIVSPQF) DIC(0)=DIC(0)_"O" - D IX^DIC K DIC - S:$D(DIE)#2 DIC=DIE Q:Y<0 - S X=Y(0,0),ZZY=Y,(XT,Y)="" I $D(WSCHADM),$D(^PS(51.1,+ZZY,1,+WSCHADM,0)),$P(^(0),"^",2)]"" S (PSIVWAT,Y)=$P(^(0),"^",2) - K ZZY,WSCHADM S:Y="" (X,PSIVSC1)=$P(Y(0),U),(PSIVAT,Y)=$P(Y(0),"^",2) S XT=$P(Y(0),"^",3) Q - ; -ORINF ; OERR input transform for Infusion Rate - ; X=data - N INFUSE - K:$L(X)<1!($L(X)>30)!(X["""")!($A(X)=45) X I '$D(X) Q - I X?.E1L.E S INFUSE=$$ENLU^PSGMI(X) Q:(INFUSE="TITRATE")!(INFUSE="BOLUS")!($P(INFUSE," ")="INFUSE")!($P(INFUSE," ")="Infuse") - Q:(X="TITRATE")!(X="BOLUS")!($P(X," ")="INFUSE")!($P(X," ")="Infuse") - I X["=" D Q ; NOIS LOU-0501-42191 - .N X2,X1 S X1=$P(X,"="),X2=$P(X,"=",2) - .I X1["ML/HR",(+X1=$P(X1,"ML/HR"))!(+X1=$P(X1," ML/HR")) D - ..S X1=$TR(X1,"ML/HR","ml/hr") - .I X2["ML/HR",(+X2=$P(X2,"ML/HR"))!(+X2=$P(X2," ML/HR")) D - ..S X2=$TR(X2,"ML/HR","ml/hr") - .I X1[" ml/hr",(+X1=$P(X1," ml/hr")) D - ..S X1=$P(X1," ml/hr")_$P(X1," ml/hr",2,9999) - .I X2[" ml/hr",(+X2=$P(X2," ml/hr")) D - ..S X2=$P(X2," ml/hr")_$P(X2," ml/hr",2,9999) - .I X1["ml/hr",(+X1=$P(X1,"ml/hr")) D - ..S X1=$P(X1,"ml/hr")_$P(X1,"ml/hr",2,9999) - .I X2["ml/hr",(+X2=$P(X2,"ml/hr")) D - ..S X2=$P(X2,"ml/hr")_$P(X2,"ml/hr",2,9999) - .I X2'=+X2 D - ..I X2>0&(X2<1) Q - ..I ($P(X2,"@",2,999)'=+$P(X2,"@",2,999)!(+$P(X2,"@",2,999)<0)) K X Q - .I X1>0&(X1<1) I +X1="."_$P(X1,".",2) S X1=X1_" ml/hr" - .I X2>0&(X2<1) I +X2="."_$P(X2,".",2) S X2=X2_" ml/hr" - .I X1=+X1 S X1=X1_" ml/hr" - .I X2=+X2 S X2=X2_" ml/hr" - .S:$P(X2,"@")=+X2 $P(X2,"@")=$P(X2,"@")_" ml/hr" - .S X=X1_"="_X2 - I X["ML/HR",(+X=$P(X,"ML/HR"))!(+X=$P(X," ML/HR")) S X=$TR(X,"ML/HR","ml/hr") - I X[" ml/hr",+X=$P(X," ml/hr") S X=$P(X," ml/hr")_$P(X," ml/hr",2,9999) - I X["ml/hr",+X=$P(X,"ml/hr") S X=$P(X,"ml/hr")_$P(X,"ml/hr",2,9999) - I X>0,X<1 D Q - .I X["ML/HR",(+X=$P($P(X,"ML/HR"),".",2))!(+X=$P($P(X," ML/HR"),".",2)) S X=$TR(X,"ML/HR","ml/hr") - .I X[" ml/hr",(+X=$P($P(X," ml/hr"),".",2)) S X=$P(X," ml/hr")_$P(X," ml/hr",2,9999) - .I X["ml/hr",+X=$P(X,"ml/hr") S X=$P(X,"ml/hr")_$P(X,"ml/hr",2,9999) - .I +X=X S X=X_" ml/hr" - .I $P(X,0,2)=+X S X=X_" ml/hr" - .S X=0_+X_$P(X,+X,2) - I '(X>0&X<1) I X'=+X,($P(X,"@",2,999)'=+$P(X,"@",2,999)!(+$P(X,"@",2,999)<0)) K X Q - I X=+X S X=X_" ml/hr" Q - S:$P(X,"@")=+X $P(X,"@")=$P(X,"@")_" ml/hr" - Q +PSIVSP ;BIR/RGY,PR,CML3-DOSE PROCESSOR ;09 Feb 99 / 12:30 PM + ;;5.0; INPATIENT MEDICATIONS ;**30,37,41,50,56,74,83,111,133,138**;16 DEC 97 + ; + ; Reference to ^PS(51.1 is supported by DBIA #2177 + ; +EN ; + Q:'$D(X) + ;/S (PSIVAT,PSIVWAT,Y)="",XT=-1,X0=X,X=$S(X="ON CALL":X,X["ONE ":X,1:$P(X," ")) + S ATZERO=0 I X["@",$P(X,"@",2)=0 S ATZERO=1,X=$P(X,"@") + D EN^PSGS0 S (P(9),PSIVSC1)=$S($G(X)]"":X,1:$G(P(9))),P(11)=$S($G(PSGS0Y):PSGS0Y,1:$G(P(11))),(XT,P(15))=$S(($G(PSGS0XT)!($G(PSGS0XT)="O")!($G(PSGS0XT)="D")):$G(PSGS0XT),1:$G(P(15))) + I $G(ATZERO) S P(7)=1 + K ATZERO Q +EN1 ; + S (PSIVAT,PSIVWAT,Y)="",XT=-1,X0=X,X=$S(X="ON CALL":X,X="ONCALL":X,X="ON-CALL":X,X="ONETIME":X,X="ONE-TIME":X,X="ONE TIME":X,X="1TIME":X,X="1 TIME":X,X="1-TIME":X,$L(X," ")<3:$P(X," "),1:$P(X," ",1,2)) + S:$E(X)="^" X=$E(X,2,999) G:X="" Q S:X["@0" ATZERO=1 S X=$S(X["@0":$P(X,"@"),1:X),P(7)=$S($D(ATZERO):1,1:"") K ATZERO + ;;I X0["@",$P(X0,"@",2)'=0 K X Q + I $S($D(^PS(51.1,"AC","PSJ",X)):1,1:$E($O(^(X)),1,$L(X))=X) D DIC I Y'<0 G SH + ;;I $S(X="NOW":1,X="ONCE":1,X="STAT":1,X="ONE-TIME":1,X="ONE TIME":1,1:0) S XT=0,Y(0)=X G SH +NS0 S Y="" + I $E(X,1,2)="AD" S XT=-1 Q + I $E(X,1,3)="BID"!($E(X,1,3)="TID")!($E(X,1,3)="QID") S XT=1440\$F("BTQ",$E(X)) + E S:$E(X)="Q" X=$E(X,2,99) S:'X X=$E(X)["O"+1_X S I=+X,X=$P(X,I,2),XT=I*$S(X["'":1,(X["D"&(X'["AD"))!(X["AM")!(X["PM")!(X["HS"&(X'["THS")):1440,X["H"&(X'["TH"):60,X["AC"!(X["PC"):480,X["W":10080,X["M":40320,1:0),X=X0 D + . I 'XT,X'="NOW",X'="STAT",X'="ONCE",X'="ONE-TIME",X'="ONE TIME",X'="ONETIME",X'="1-TIME",X'="1 TIME",X'="1TIME",Y="" S XT=-1 +SH ; + I +Y<1,$E(X0)'="^" W:$G(ON)'["P" " ",$S(XT=0&($S("^NOW^STAT^ONCE^ONE-TIME^ONETIME^1TIME^1-TIME^"[(U_$P(X," ")_U):1,X["1 TIME":1,1:X["ONE TIME")):"(ONCE ONLY)",XT>0:"Nonstandard schedule",XT<0:"",1:"(??)") W:XT>0 " (",XT," MINUTES)" +Q Q:X="ONE TIME" + N I S X0=$P(X," ")_$S($L(X0," ")-1:" ",1:"")_$P(X0," ",2,99) K:XT<0!($L(X0)>22) X S:$D(X) X=X0 K X0 S:$G(P(7)) XT="" Q + ;N I S X0=$P(X," ")_$S($L(X0," ")-1:" ",1:"")_$P(X," ",2,99) K:XT<0!($L(X0)>22) X S:$D(X) X=X0 K X0 S:$G(P(7)) XT="" Q + ;S X0=X K:XT<0!($L(X0)>22) X S:$D(X) X=X0 K X0 S:$G(P(7)) XT="" Q +NEWQ ;N I S X0=$P(X," ")_$S($L(X0," ")-1:" ",1:"")_$P(X0," ",2,99) K:XT<0!($L(X0)>22) X S:$D(X) X=X0 S:P(7) X=X0 K X0 K:XT>0&('P(7)) X Q + Q + ; +ENDL W " Dose limit .... " S PSIVMIN=P(15)*X,PSIVSD=+P(2) + I PSIVMIN<0 W !!," --- There is something wrong with this order !!",!," Call inpatient supervisor ....." S Y=-1 K PSIVMIN Q + I P(4)="P"!(P(5))!(P(23)="P"),PSIVMIN=0,"^NOW^STAT^ONCE^ONE-TIME^ONE TIME^ON CALL^ONETIME^1TIME^1 TIME^1-TIME^"'[(U_P(9)_U) D DLP G QDL + D ENT^PSIVWL +QDL I $D(X) S X=Y X ^DD("DD") W $P(Y,"@")," ",$P(Y,"@",2) S Y=X + Q +DLP ; + S X=X+1,$P(PSIVSD,".",2)=$P(PSIVSD,".",2)_$E("0000",1,4-$L($P(PSIVSD,".",2))) D CHK S X2=0,Y=1 I X<2 S Y=+PSIVSD G QDLP + I $P(PSIVSD,".",2)>$P(P(11),"-",$L(P(11),"-")) S X2=1 G OV + G:$P(P(11),"-")>$P(PSIVSD,".",2) OV + F Y=1:1 S X1=$P(P(11),"-",Y) I X1=$P(PSIVSD,".",2)!($P(PSIVSD,".",2)0 S X1=PSIVSD D C^%DTC S X=$P(X,".") ; install with version 17.3 of fileman + S Y=+(X_"."_$P(P(11),"-",Y)) +QDLP K X1,X2 Q + ; +ENI ; + K:$L(X)<1!($L(X)>30)!(X["""")!($A(X)=45) X I '$D(X)!'$D(P(4)) Q + I P(4)="P"!(P(5))!(P(23)="P") Q:'X S X="INFUSE OVER "_X_" MIN." W " ",X Q + I X'=+X,($P(X,"@",2,999)'=+$P(X,"@",2,999)!(+$P(X,"@",2,999)<0)) K X Q + S SPSOL=$O(DRG("SOL",0)) I 'SPSOL K SPSOL,X W " You must define at least one solution !!" Q + I X=+X S X=X_" ml/hr" W " ml/hr" D SPSOL S P(15)=$S('X:0,1:SPSOL\X*60+(SPSOL#X/X*60+.5)\1) K SPSOL Q + S SPSOL=$P(X,"@",2) S:$P(X,"@")=+X $P(X,"@")=$P(X,"@")_" ml/hr" W " ",+SPSOL," Label",$S(SPSOL'=1:"s",1:"")," per day",!?15,"at an infusion rate of: ",$P(X,"@") S P(15)=$S('SPSOL:0,1:1440/SPSOL\1) K SPSOL + Q +SPSOL S SPSOL=0 F XXX=0:0 S XXX=$O(DRG("SOL",XXX)) Q:'XXX S SPSOL=SPSOL+$P(DRG("SOL",XXX),U,3) + K XXX Q +CHK F Y=1:1 Q:$L(P(11))>240!($P(P(11),"-",Y)="") S $P(P(11),"-",Y)=$P(P(11),"-",Y)_$E("0000",1,4-$L($P(P(11),"-",Y))) + Q + ; +DIC ; 51.1 look-up + N PSJSCH S PSJSCH=X I '$D(WSCHADM) N VAIP D IN5^VADPT S WSCHADM=VAIP(5),X=PSJSCH + K DIC S DIC="^PS(51.1,",DIC(0)=$E("E",'$D(NOECH))_"ISZ" + S DIC("W")="W "" "","_$S('$D(WSCHADM):"$P(^(0),""^"",2)",'+WSCHADM:"$P(^(0),""^"",2)",1:"$S($D(^PS(51.1,+Y,1,+WSCHADM,0)):$P(^(0),""^"",2),1:$P(^PS(51.1,+Y,0),""^"",2))"),D="APPSJ" S:$D(PSIVSPQF) DIC(0)=DIC(0)_"O" + D IX^DIC K DIC + S:$D(DIE)#2 DIC=DIE Q:Y<0 + S X=Y(0,0),ZZY=Y,(XT,Y)="" I $D(WSCHADM),$D(^PS(51.1,+ZZY,1,+WSCHADM,0)),$P(^(0),"^",2)]"" S (PSIVWAT,Y)=$P(^(0),"^",2) + K ZZY,WSCHADM S:Y="" (X,PSIVSC1)=$P(Y(0),U),(PSIVAT,Y)=$P(Y(0),"^",2) S XT=$P(Y(0),"^",3) Q + ; +ORINF ; OERR input transform for Infusion Rate + ; X=data + N INFUSE + K:$L(X)<1!($L(X)>30)!(X["""")!($A(X)=45) X I '$D(X) Q + I X?.E1L.E S INFUSE=$$ENLU^PSGMI(X) Q:(INFUSE="TITRATE")!(INFUSE="BOLUS") + Q:(X="TITRATE")!(X="BOLUS") + I X["=" D Q ; NOIS LOU-0501-42191 + .N X2,X1 S X1=$P(X,"="),X2=$P(X,"=",2) + .I X1["ML/HR",(+X1=$P(X1,"ML/HR"))!(+X1=$P(X1," ML/HR")) D + ..S X1=$TR(X1,"ML/HR","ml/hr") + .I X2["ML/HR",(+X2=$P(X2,"ML/HR"))!(+X2=$P(X2," ML/HR")) D + ..S X2=$TR(X2,"ML/HR","ml/hr") + .I X1[" ml/hr",(+X1=$P(X1," ml/hr")) D + ..S X1=$P(X1," ml/hr")_$P(X1," ml/hr",2,9999) + .I X2[" ml/hr",(+X2=$P(X2," ml/hr")) D + ..S X2=$P(X2," ml/hr")_$P(X2," ml/hr",2,9999) + .I X1["ml/hr",(+X1=$P(X1,"ml/hr")) D + ..S X1=$P(X1,"ml/hr")_$P(X1,"ml/hr",2,9999) + .I X2["ml/hr",(+X2=$P(X2,"ml/hr")) D + ..S X2=$P(X2,"ml/hr")_$P(X2,"ml/hr",2,9999) + .I X2'=+X2 D + ..I ($P(X2,"@",2,999)'=+$P(X2,"@",2,999)!(+$P(X2,"@",2,999)<0)) K X Q + .I X1=+X1 S X1=X1_" ml/hr" + .I X2=+X2 S X2=X2_" ml/hr" + .S:$P(X2,"@")=+X2 $P(X2,"@")=$P(X2,"@")_" ml/hr" + .S X=X1_"="_X2 + I X["ML/HR",(+X=$P(X,"ML/HR"))!(+X=$P(X," ML/HR")) S X=$TR(X,"ML/HR","ml/hr") + I X[" ml/hr",+X=$P(X," ml/hr") S X=$P(X," ml/hr")_$P(X," ml/hr",2,9999) + I X["ml/hr",+X=$P(X,"ml/hr") S X=$P(X,"ml/hr")_$P(X,"ml/hr",2,9999) + I X'=+X,($P(X,"@",2,999)'=+$P(X,"@",2,999)!(+$P(X,"@",2,999)<0)) K X Q + I X=+X S X=X_" ml/hr" Q + S:$P(X,"@")=+X $P(X,"@")=$P(X,"@")_" ml/hr" + Q diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVUTL1.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVUTL1.m index ef8ce6d4..13c5e8db 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVUTL1.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVUTL1.m @@ -1,127 +1,98 @@ -PSIVUTL1 ;BIR/MLM-IV UTILITIES ;21 MAY 96 / 10:37 AM - ;;5.0; INPATIENT MEDICATIONS ;**58,81,111,134**;16 DEC 97;Build 124 - ; - ; Reference to ^PS(50.7 is supported by DBIA 2180 - ; Reference to ^PS(51.2 is supported by DBIA 2178 - ; Reference to ^PS(52.6 is supported by DBIA 1231 - ; Reference to ^PS(52.7 is supported by DBIA 2173. - ; Reference to ^PS(55 is supported by DBIA 2191 - ; -DRGSC(Y,PSJSCT) ; Called to set DIC("S") when selecting orderable item. - N OK,ND,NDU,NDI S OK=0 ;* I '$D(^PSDRUG("AP",+Y)) K PSJSCT Q 0 - S ND=$G(^PS(50.7,+Y,0)) - I $P(ND,U,3) S OK=$S('$P(ND,U,4):1,$P(ND,U,4)>DT:1,1:0) - Q OK - ; -IVDRGSC(Y) ; Set DIC("S") for IV additive/solution selection. - ; Naked reference below refers to full reference in Y, which is either ^PS(52.6, or ^PS(52.7 - N Y S Y="S X(1)=$G(^(0)),X(2)=$G(^(""I"")) I $S('X(2):1,X(2)>DT:1,1:0),$D(^PSDRUG(+$P(X(1),U,2),0)) S X(2)=$G(^(""I"")) I $S('X(2):1,X(2)>DT:1,1:0)" - Q Y - ; -ENU(Y) ;Get IV additive strength. - N X S X=$P(^PS(52.6,+Y,0),U,3),Y=$$CODES^PSIVUTL(X,52.6,2) - Q Y - ; -CODES(X,Y) ; Get name from code. - S Y=$P($P(";"_$P(Y,U,3),";"_X_":",2),";") - Q Y - ; -GTPCI(Y) ; Set up "work" area for provider comments. - N DIC,DINUM,DLAYGO,X S DIC="^PS(53.45,",DIC(0)="LNZ",DLAYGO=53.45,(DINUM,X)=+DUZ D ^DIC - Q Y - ; -WDTE(Y) ; Format and print date. - I 'Y S Y="******" - E X ^DD("DD") S Y=$P(Y,"@")_" "_$P($P(Y,"@",2),":",1,2) - Q Y -GTOT(DFN,ON) ; Get order type for display. - N DRGT,DRGI,Y - S X=$P($G(^PS(55,DFN,"IV",ON,0)),U,4) - S Y=$S(X="A":"F",X="H":"H",1:"I") - I Y="F" F DRGT="AD","SOL" F DRGI=0:0 S DRGI=$O(^PS(55,DFN,"IV",+ON,DRGT,DRGI)) Q:'DRGI I '$P($G(^PS(55,DFN,"IV",+ON,DRGT,DRGI)),U,5) S Y="I" Q - Q Y - ; -PIV(ON) ; Display IV orders. - N DRG,ON55,P,PSJORIFN,TYP,X,Y S TYP="?" I ON["V" D - .S Y=$G(^PS(55,DFN,"IV",+ON,0)) F X=2,3,4,5,8,9,17,23 S P(X)=$P(Y,U,X) - .S TYP=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3)) I TYP'="O" S TYP="C" - .S ON55=ON,P("OT")=$S(P(4)="A":"F",P(4)="H":"H",1:"I") D GTDRG^PSIVORFB,GTOT^PSIVUTL(P(4)) - I ON'["V" S (P(2),P(3))="",P(17)=$P($G(^PS(53.1,+ON,0)),U,9),Y=$G(^(8)),P(4)=$P(Y,U),P(8)=$P(Y,U,5),P(9)=$P($G(^(2)),U) D GTDRG^PSIVORFA,GTOT^PSIVUTL(P(4)) I $E(P("OT"))="I" D Q - .S P("PD")=$P($$DRUGNAME^PSJLMUTL(PSGP,ON),"^"),P("DO")=$S($P(DN,"^",2)=.2:$P($G(^PS(55,PSGP,5,+PSJO,.2)),"^",2),1:$G(^PS(55,PSGP,5,+PSJO,.3))),P("DO")=$P(P("DO"),"^") - .S Y=$G(^PS(53.1,+ON,.2)),P("MR")=$P($G(^PS(53.1,+ON,0)),U,3)_U_$P($G(^PS(51.2,+$P($G(^PS(53.1,+ON,0)),U,3),0)),U,3) - .W ?9,P("PD") D PIV1 W !?11,"Give: ",P("DO")," ",$P(P("MR"),U,2)," ",$S(P(9)]"":P(9),1:P(8)) - S DRG=0 F S DRG=$O(DRG("AD",DRG)) Q:'DRG D PIVAD -SOL ; - NEW NAME - S DRG=0 F S DRG=$O(DRG("SOL",DRG)) Q:'DRG D - . D NAME(DRG("SOL",DRG),39,.NAME,0) - . W ! W:DRG=1 ?9,"in " - . F X=0:0 S X=$O(NAME(X)) Q:'X W ?12 W NAME(X) I X=1,DRG=1,'$D(DRG("AD",1)) D PIV1 - Q -PIVAD ; Print IV Additives. - NEW NAME - D NAME(DRG("AD",DRG),39,.NAME,1) - F X=0:0 S X=$O(NAME(X)) Q:'X W:DRG'=1 ! W ?9,NAME(X) I X=1,DRG=1 D PIV1 - Q - ; -PIV1 ; Print Sched type, start/stop dates, and status. - F X=2,3 S P(X)=$E($$ENDTC^PSGMI(P(X)),1,$S($D(PSJEXTP):8,1:5)) - I '$D(PSJEXTP) W ?50,TYP,?53,P(2),?60,P(3),?67,P(17) Q - W ?50,TYP,?53,P(2),?63,P(3),?73,P(17) - Q -59 ; Validate the Infusion rate entered using IV Quick order code. - N I F I=2,3,5,7,8,9,11,15,23 S P(I)="" - S P(4)="A",P(8)=$P($G(^PS(57.1,PSJQO,1)),U,5) - I $G(^PS(57.1,PSJQO,4,1,0)) S DRG("SOL",1)=^(0),DRG("SOL",0)=1 - I X["?" S F1=53.1,F2=59 D ENHLP^PSIVORC1 G 59 - I X]"" D ENI^PSIVSP S:$D(X) P(8)=X - Q -WRTDRG(X,L) ; Format and print drug name, strength and bottle no. - N Y S Y=" "_$P(X,U,3) S:$P(X,U,4) Y=Y_" ("_$P(X,U,4)_")" - Q $E($P(X,U,2),1,(L-$L(Y)))_Y -NAME(X,L,NAME,AD) ; Format Additive display. - ;INPUT : X=DRG("AD",DRG) L=Display length AD=for Addtive(1/0) - ;OUTPUT: AD(X) if X=2 that means there is a second line to display - K NAME - NEW Y S Y=$P(X,U,3) S:(AD&$P(X,U,4)) Y=Y_" ("_$P(X,U,4)_")" - S:'AD Y=Y_" "_$S(P(4)="P"!($G(P(23))="P")!$G(P(5)):P(9),1:$P(P(8),"@")) - I ($L($P(X,U,2))+$L(Y)+1)>L S NAME(1)=$P(X,U,2),NAME(2)=" "_Y Q - S NAME(1)=$P(X,U,2)_" "_Y - Q - ; -CNVTOM(RATE,TVOL) ; Convert volume to minutes - ; Input: - ; RATE - Infusion Rate - ; TVOL - Volume being infused, EX: m100 (100 Milliliters) or l5 (5 Liters) - ; Output: - ; MINS - Minutes required to infuse volume - N DAYS,ML,MLSHR - ; Get rate in terms of mils per hour - I 'RATE Q 0 - I RATE<1 S RATE=1 - S TVOL=$S($E(TVOL)="m":$E(TVOL,2,9),$E(TVOL)="l":$E(TVOL,2,9)*1000,1:0) Q:'TVOL 0 - ; Find IV duration in minutes - S MINS=(TVOL/RATE)*60 - Q MINS - ; -GETMIN(LIM,DFN,PSJORD,DAYS) ; - N F,DDLX - I LIM!(LIM=0) Q LIM - S F=$S(PSJORD["P":"^PS(53.1,+PSJORD,",PSJORD["V":"^PS(55,DFN,""IV"",+PSJORD,",1:"") - N RATE S RATE=$S(PSJORD["P":+$P($G(@(F_"8)")),"^",5),PSJORD["V":+$P($G(@(F_"0)")),"^",8),1:0) - I (",l,m,")[(","_$E(LIM)_",") D - .I RATE D - ..I RATE<1 S RATE=1 - ..S MIN=$$CNVTOM(RATE,LIM) I MIN S LIM=MIN - .I 'RATE N SOL,SOLVOL,DOSVOL,DUR,STOP,OIX,X S (SOLVOL,DOSVOL)="" D - ..S SOL=0 F S SOL=$O(@(F_"""SOL"",SOL)")) Q:'SOL D - ...S SOLVOL=$P(@(F_"""SOL"",SOL,0)"),"^",2) I SOLVOL S DOSVOL=DOSVOL+SOLVOL - ..S DDLX=$S($E(LIM)["l":(($E(LIM,2,99)*1000)/DOSVOL),1:($E(LIM,2,99)/DOSVOL))_"L" - I (",a,")[(","_$E(LIM)_",") S DDLX=$E(LIM,2,99)_"L" - I $G(DDLX)>0 D - .N STOP,LASTD S DAYS="",STOP="" - .S OIX=$P($G(@(F_".2)")),"^") S:(DDLX<1) DDLX="1L" S LASTD=$$DOSES^PSIVCAL(DDLX,.P) - .I LASTD,$G(P(2)) S DAYS=$$FMDIFF^XLFDT(LASTD,P(2),2) I DAYS>0 S DAYS=DAYS/86400 - .I DAYS>0 S LIM=DAYS*1440 - I (",h,d,")[(","_$E(LIM)_",") S LIM=$S($E(LIM)="d":(1440*$E(LIM,2,99)),1:(60*$E(LIM,2,99))) Q - Q LIM +PSIVUTL1 ;BIR/MLM-IV UTILITIES ;21 MAY 96 / 10:37 AM + ;;5.0; INPATIENT MEDICATIONS ;**58,81,111**;16 DEC 97 + ; + ; Reference to ^PS(50.7 is supported by DBIA 2180 + ; Reference to ^PS(51.2 is supported by DBIA 2178 + ; Reference to ^PS(52.6 is supported by DBIA 1231 + ; Reference to ^PS(55 is supported by DBIA 2191 + ; +DRGSC(Y,PSJSCT) ; Called to set DIC("S") when selecting orderable item. + N OK,ND,NDU,NDI S OK=0 ;* I '$D(^PSDRUG("AP",+Y)) K PSJSCT Q 0 + S ND=$G(^PS(50.7,+Y,0)) + I $P(ND,U,3) S OK=$S('$P(ND,U,4):1,$P(ND,U,4)>DT:1,1:0) + Q OK + ; +IVDRGSC(Y) ; Set DIC("S") for IV additive/solution selection. + N Y S Y="S X(1)=$G(^(0)),X(2)=$G(^(""I"")) I $S('X(2):1,X(2)>DT:1,1:0),$D(^PSDRUG(+$P(X(1),U,2),0)) S X(2)=$G(^(""I"")) I $S('X(2):1,X(2)>DT:1,1:0)" + Q Y + ; +ENU(Y) ;Get IV additive strength. + N X S X=$P(^PS(52.6,+Y,0),U,3),Y=$$CODES^PSIVUTL(X,52.6,2) + Q Y + ; +CODES(X,Y) ; Get name from code. + S Y=$P($P(";"_$P(Y,U,3),";"_X_":",2),";") + Q Y + ; +GTPCI(Y) ; Set up "work" area for provider comments. + N DIC,DINUM,DLAYGO,X S DIC="^PS(53.45,",DIC(0)="LNZ",DLAYGO=53.45,(DINUM,X)=+DUZ D ^DIC + Q Y + ; +WDTE(Y) ; Format and print date. + I 'Y S Y="******" + E X ^DD("DD") S Y=$P(Y,"@")_" "_$P($P(Y,"@",2),":",1,2) + Q Y +GTOT(DFN,ON) ; Get order type for display. + N DRGT,DRGI,Y + S X=$P($G(^PS(55,DFN,"IV",ON,0)),U,4) + S Y=$S(X="A":"F",X="H":"H",1:"I") + I Y="F" F DRGT="AD","SOL" F DRGI=0:0 S DRGI=$O(^PS(55,DFN,"IV",+ON,DRGT,DRGI)) Q:'DRGI I '$P($G(^PS(55,DFN,"IV",+ON,DRGT,DRGI)),U,5) S Y="I" Q + Q Y + ; +PIV(ON) ; Display IV orders. + N DRG,ON55,P,PSJORIFN,TYP,X,Y S TYP="?" I ON["V" D + .S Y=$G(^PS(55,DFN,"IV",+ON,0)) F X=2,3,4,5,8,9,17,23 S P(X)=$P(Y,U,X) + .S TYP=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3)) I TYP'="O" S TYP="C" + .S ON55=ON,P("OT")=$S(P(4)="A":"F",P(4)="H":"H",1:"I") D GTDRG^PSIVORFB,GTOT^PSIVUTL(P(4)) + I ON'["V" S (P(2),P(3))="",P(17)=$P($G(^PS(53.1,+ON,0)),U,9),Y=$G(^(8)),P(4)=$P(Y,U),P(8)=$P(Y,U,5),P(9)=$P($G(^(2)),U) D GTDRG^PSIVORFA,GTOT^PSIVUTL(P(4)) I $E(P("OT"))="I" D Q + .S P("PD")=$P($$DRUGNAME^PSJLMUTL(PSGP,ON),"^"),P("DO")=$S($P(DN,"^",2)=.2:$P($G(^PS(55,PSGP,5,+PSJO,.2)),"^",2),1:$G(^PS(55,PSGP,5,+PSJO,.3))),P("DO")=$P(P("DO"),"^") + .S Y=$G(^PS(53.1,+ON,.2)),P("MR")=$P($G(^PS(53.1,+ON,0)),U,3)_U_$P($G(^PS(51.2,+$P($G(^PS(53.1,+ON,0)),U,3),0)),U,3) + .W ?9,P("PD") D PIV1 W !?11,"Give: ",P("DO")," ",$P(P("MR"),U,2)," ",$S(P(9)]"":P(9),1:P(8)) + S DRG=0 F S DRG=$O(DRG("AD",DRG)) Q:'DRG D PIVAD +SOL ; + NEW NAME + S DRG=0 F S DRG=$O(DRG("SOL",DRG)) Q:'DRG D + . D NAME(DRG("SOL",DRG),39,.NAME,0) + . W ! W:DRG=1 ?9,"in " + . F X=0:0 S X=$O(NAME(X)) Q:'X W ?12 W NAME(X) I X=1,DRG=1,'$D(DRG("AD",1)) D PIV1 + Q +PIVAD ; Print IV Additives. + NEW NAME + D NAME(DRG("AD",DRG),39,.NAME,1) + F X=0:0 S X=$O(NAME(X)) Q:'X W:DRG'=1 ! W ?9,NAME(X) I X=1,DRG=1 D PIV1 + Q + ; +PIV1 ; Print Sched type, start/stop dates, and status. + F X=2,3 S P(X)=$E($$ENDTC^PSGMI(P(X)),1,$S($D(PSJEXTP):8,1:5)) + I '$D(PSJEXTP) W ?50,TYP,?53,P(2),?60,P(3),?67,P(17) Q + W ?50,TYP,?53,P(2),?63,P(3),?73,P(17) + Q +59 ; Validate the Infusion rate entered using IV Quick order code. + N I F I=2,3,5,7,8,9,11,15,23 S P(I)="" + S P(4)="A",P(8)=$P($G(^PS(57.1,PSJQO,1)),U,5) + I $G(^PS(57.1,PSJQO,4,1,0)) S DRG("SOL",1)=^(0),DRG("SOL",0)=1 + I X["?" S F1=53.1,F2=59 D ENHLP^PSIVORC1 G 59 + I X]"" D ENI^PSIVSP S:$D(X) P(8)=X + Q +WRTDRG(X,L) ; Format and print drug name, strength and bottle no. + N Y S Y=" "_$P(X,U,3) S:$P(X,U,4) Y=Y_" ("_$P(X,U,4)_")" + Q $E($P(X,U,2),1,(L-$L(Y)))_Y + ;Q $E($$ENPDN^PSGMI($P(X,U,6)),1,(L-$L(Y)))_Y +NAME(X,L,NAME,AD) ; Format Additive display. + ;INPUT : X=DRG("AD",DRG) L=Display length AD=for Addtive(1/0) + ;OUTPUT: AD(X) if X=2 that means there is a second line to display + K NAME + NEW Y S Y=$P(X,U,3) S:(AD&$P(X,U,4)) Y=Y_" ("_$P(X,U,4)_")" + S:'AD Y=Y_" "_$S(P(4)="P"!($G(P(23))="P")!$G(P(5)):P(9),1:$P(P(8),"@")) + I ($L($P(X,U,2))+$L(Y)+1)>L S NAME(1)=$P(X,U,2),NAME(2)=" "_Y Q + S NAME(1)=$P(X,U,2)_" "_Y + Q + ; +CNVTOM(RATE,TVOL) ; Convert volume to minutes + N DAYS,ML,MLSHR + ; Get rate in terms of mils per hour + I 'RATE Q 0 + S TVOL=$S($E(TVOL)="m":$E(TVOL,2,9),$E(TVOL)="l":$E(TVOL,2,9)*1000,1:0) Q:'TVOL 0 + ; Find IV duration in minutes + S MINS=(TVOL/RATE)*60 S MINS=MINS+1 + Q MINS diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL2.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL2.m index e1099cad..5731b7f4 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL2.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL2.m @@ -1,117 +1,112 @@ -PSJHL2 ;BIR/RLW-PATIENT ID AND VISIT SEGMENTS ;22 Nov 1999 9:27 AM - ;;5.0; INPATIENT MEDICATIONS ;**1,18,16,23,28,42,50,70,58,100,102,110,111,112,144,141,134**;16 DEC 97;Build 124 - ; - ; Reference to ^PS(55 is supported by DBIA# 2191. - ; Reference to ^ORERR is supported by DBIA# 2187. - ; Reference to ^ORHLESC IS supported by DBIA# 4922. - ; -EN1(PSJHLDFN,PSOC,PSJORDER,PSREASON) ; start here - ; passed in are PSJHLDFN (patient ien) - ; PSJORDER* (order_file (N,P,V, etc)) - ; PSOC* (order control code - NW for new order, OK to return filler number to OE/RR, OC for order canceled, SC for status change) - ; PSREASON* (text reason) - ; *=optional, only required if an order segment is also to be generated -START ; - K ^TMP("PSJHLS",$J,"PS") - N CLERK,J,LIMIT,NAME,NEXT,NODE1,NODE2,NODE4,NOO,PSJCLEAR,PSJHINST,PSJHLSDT,PROVIDER,PSJI,ROOMBED,RXORDER,STATUS,UNDO,VERIFY,WARD,PSGST,DUR - S RXORDER=PSJORDER,PSJORDER=$S((PSJORDER["N")!(PSJORDER["P"):"^PS(53.1,"_+PSJORDER,PSJORDER["V":"^PS(55,"_PSJHLDFN_",""IV"","_+PSJORDER,1:"^PS(55,"_PSJHLDFN_",5,"_+PSJORDER)_"," - I RXORDER["P",$P($G(@(PSJORDER_"0)")),U,15)'=PSJHLDFN S ORDCON="Patient does not match/PSJHL2" S X="ORERR" X ^%ZOSF("TEST") I D EN^ORERR(ORDCON) Q - S UNDO=$S("OC^CR"[PSOC:1,1:0) - D INIT,PID,PV1,ORC - D @$S("SN^SC^OC^OD^DR^CR^OH^OR^XX^ZC^XR"[PSOC:"EN1^PSJHL3(PSJHLDFN,PSOC,PSJORDER)",1:"CALL^PSJHLU(PSJI)") - I UNDO D UNDO - K ^TMP("PSJHLS",$J,"PS"),FIELD - Q - ; -INIT ; initialize HL7 variables, set master file identification segment - ; PSJHLMTN = message type - ORR for messages sent as a response to an OE/RR event; ORM for "unsolicited" messages. - S PSJI=0,PSJHLMTN=$S($G(PSJHLMTN)]"":PSJHLMTN,1:"ORM") - D INIT^PSJHLU - S LIMIT=17 X PSJCLEAR - S FIELD(0)="MSH",FIELD(1)="^~\&",FIELD(2)="PHARMACY",FIELD(3)=$G(PSJHINST),FIELD(8)=PSJHLMTN - D SEGMENT^PSJHLU(LIMIT),DISPLAY - Q - ; -PID ; get patient data, format PID SEGMENT - S LIMIT=22 X PSJCLEAR - S FIELD(0)="PID" - S FIELD(3)=PSJHLDFN - N DFN S DFN=PSJHLDFN D DEM^VADPT S FIELD(5)=VADM(1) - I '$G(PSJBCBU) S FIELD(5)=$$ESC^ORHLESC(FIELD(5)) - D SEGMENT^PSJHLU(LIMIT),DISPLAY - Q - ; -PV1 ; get patient visit information, format PV1 segment - N PSJAPPT - S LIMIT=50 X PSJCLEAR - S FIELD(0)="PV1" - I PSJHLMTN="ORR" S FIELD(3)=LOC - I PSJHLMTN="ORM" D - .S LOC="",WARD=$G(^DPT(PSJHLDFN,.1)),LOC=$S($G(WARD)]"":$O(^SC("B",WARD,LOC)),1:LOC) - .I $G(LOC)="" D - .. N A - .. I RXORDER["P",($G(^PS(53.1,+RXORDER,"DSS"))) S A=^("DSS"),LOC=$P(A,"^"),PSJAPPT=$P(A,"^",2) - .. I RXORDER["V",($G(^PS(55,PSJHLDFN,"IV",+RXORDER,"DSS"))) S A=^("DSS"),LOC=$P(A,"^"),PSJAPPT=$P(A,"^",2) - .. I RXORDER["U",$G(^PS(55,PSJHLDFN,5,+RXORDER,8)) S A=^(8),LOC=$P(A,"^"),PSJAPPT=$P(A,"^",2) - .I $G(LOC)]"" S ROOMBED=$G(^DPT(PSJHLDFN,.101)) S LOC=LOC_"^"_$S($G(PSJBCBU):ROOMBED,1:$$ESC^ORHLESC(ROOMBED)) - .S FIELD(3)=LOC I $G(PSJAPPT)]"" S FIELD(44)=$$FMTHL7^XLFDT(PSJAPPT) - S FIELD(2)=$S($G(CLASS)="O":CLASS,1:"I") - I FIELD(2)="I" N DFN S DFN=PSJHLDFN D INP^VADPT S FIELD(19)=VAIN(1) - D SEGMENT^PSJHLU(LIMIT),DISPLAY - Q - ; -ORC ; order control segment - S LIMIT=18 X PSJCLEAR - Q:'$D(PSJORDER)!'$D(PSOC) - S NODE1=$G(@(PSJORDER_"0)")),NODE2=$G(@(PSJORDER_"2)")) - S NODE4=$G(@(PSJORDER_"4)")) - I $G(PSGST)="" N PSGST D - .S PSGST=$P($G(NODE1),"^",7) - S FIELD(0)="ORC" - S FIELD(1)=PSOC - S FIELD(2)=$S(PSOC="SN":"",1:$P(NODE1,"^",21))_"^OR" I $P(FIELD(2),"^")=0 S $P(FIELD(2),"^")="" ; IV orders are created with a zero in the oerr order number, for some reason - S FIELD(3)=RXORDER_"^PS" - ; translate Pharmacy status code to HL7 status code, set in FIELD(5) - S STATUS=$S($G(PSJEXPOE):"E",(($P(NODE1,"^",17)]"")&(RXORDER["V")):($P(NODE1,"^",17)),($P(NODE1,"^",9)]""):$P(NODE1,"^",9),$G(PSIVCOPY):"DE",1:"") - ;BHW;Remedy HD0000000086717;If the order has a pending number, send pending status even if current status is Active. - I STATUS="A",RXORDER["P" S STATUS="N" D @STATUS S STATUS="A" - E D @STATUS - I STATUS="U",RXORDER["P" S FIELD(3)="^PS" - S FIELD(7)="^"_$S(RXORDER["V":$P(NODE1,"^",9)_"&"_$P(NODE1,"^",11),1:$P(NODE2,"^")_"&"_$P(NODE2,"^",5))_"^^^^^"_$G(PSGST) - S FIELD(9)=$S(RXORDER["V":$$FMTHL7^XLFDT($P(NODE2,"^")),1:$$FMTHL7^XLFDT($P(NODE1,"^",16))) - S CLERK=$S(RXORDER["V":$P(NODE2,"^",11),1:$P(NODE4,"^",7)) - S NAME=$P($G(^VA(200,+CLERK,0)),"^") - S FIELD(10)=CLERK_"^"_$S($G(PSJBCBU):NAME,1:$$ESC^ORHLESC(NAME)) - I PSOC="ZV"!($G(PSJBCBU)) S VERIFY=$P($G(NODE4),"^"),FIELD(11)=VERIFY_"^"_$S($G(PSJBCBU):$P($G(^VA(200,+VERIFY,0)),"^"),1:$$ESC^ORHLESC($P($G(^VA(200,+VERIFY,0)),"^"))),FIELD(9)=$$FMTHL7^XLFDT($P(NODE4,"^",2)) - S PROVIDER=$S($G(PSJDCPRV)]"":$G(PSJDCPRV),RXORDER["V":$P(NODE1,"^",6),1:$P(NODE1,"^",2)) K PSJDCPRV - S NAME=$P($G(^VA(200,+PROVIDER,0)),"^") - S FIELD(12)=PROVIDER_"^"_NAME - S FIELD(15)=$S(RXORDER["V":$$FMTHL7^XLFDT($P(NODE1,"^",2)),1:$$FMTHL7^XLFDT($P(NODE2,"^",2))) - I $S(RXORDER["V":$P(NODE2,"^",8)="R",1:$P(NODE1,"^",24)="R") - ; PSJ*5*141 - If this is a renewal order, update FIELD(10) with the person who entered the renewal order. - N FIELD9 S FIELD9=$$FMTHL7^XLFDT($$LASTREN^PSJLMPRI(PSJHLDFN,RXORDER)) I FIELD9>FIELD(9) S FIELD(9)=FIELD9,FIELD(15)=FIELD9,FIELD(10)=$$LASTRNBY^PSJLMPRI(PSJHLDFN,RXORDER) - S NOO=$S(PSJORDER["IV":$G(P("NAT")),(($G(PSJNOO)="")&($G(P("NAT"))]"")):$G(P("NAT")),1:$G(PSJNOO)),PSREASON=$S(NOO="D":"",1:$G(PSREASON)) - S FIELD(16)=NOO_U_$S(NOO="P":"Telephoned",NOO="D":"Duplicate",NOO="X":"Rejected",NOO="A":"Auto",NOO="S":"Service Correction",NOO="W":"Written",NOO="V":"Verbal",NOO="E":"Physician Entered",NOO="I":"Policy",1:"")_U_"99ORN"_U_U_$G(PSREASON)_U - D SEGMENT^PSJHLU(LIMIT),DISPLAY - Q - ; -DISPLAY ; just for testing - I $G(MSGTEST) W ! F NEXT=0:1:LIMIT W FIELD(NEXT)_"|" - Q -UNDO ;Undo Renew if Pending Renewal is dc'd - I RXORDER["P",(STATUS="D"),($G(PSJNOO)'="A"),($P(NODE1,U,24)="R") D ENBKOUT^PSJOREN(PSJHLDFN,RXORDER) - Q - ; -A S FIELD(5)="CM" Q ; active -D S FIELD(5)="DC" Q ; discontinued -I S FIELD(5)="IP" Q ; incomplete -N S FIELD(5)="IP" Q ; non-verified -U S FIELD(5)="ZX" Q ; unreleased -P S FIELD(5)="IP" Q ; pending -DE S FIELD(5)="RP" Q ; discontinued (edit) -E S FIELD(5)="ZE" Q ; expired -H S FIELD(5)="HD" Q ; hold -R S FIELD(5)="ZZ" Q ; renewed -RE S FIELD(5)="CM" Q ; reinstated -DR S FIELD(5)="DC" Q ; discontinued (renewal) -O S FIELD(5)="HD" Q ; on call (is this kind of like HOLD?) +PSJHL2 ;BIR/RLW-PATIENT ID AND VISIT SEGMENTS ;22 Nov 1999 9:27 AM + ;;5.0; INPATIENT MEDICATIONS ;**1,18,16,23,28,42,50,70,58,100,102,110,111,112,144,141**;16 DEC 97 + ; + ; Reference to ^PS(55 is supported by DBIA# 2191. + ; Reference to ^ORERR is supported by DBIA# 2187. + ; +EN1(PSJHLDFN,PSOC,PSJORDER,PSREASON) ; start here + ; passed in are PSJHLDFN (patient ien) + ; PSJORDER* (order_file (N,P,V, etc)) + ; PSOC* (order control code - NW for new order, OK to return filler number to OE/RR, OC for order canceled, SC for status change) + ; PSREASON* (text reason) + ; *=optional, only required if an order segment is also to be generated +START ; + K ^TMP("PSJHLS",$J,"PS") + N CLERK,J,LIMIT,NAME,NEXT,NODE1,NODE2,NODE4,NOO,PSJCLEAR,PSJHINST,PSJHLSDT,PROVIDER,PSJI,ROOMBED,RXORDER,STATUS,UNDO,VERIFY,WARD + S RXORDER=PSJORDER,PSJORDER=$S((PSJORDER["N")!(PSJORDER["P"):"^PS(53.1,"_+PSJORDER,PSJORDER["V":"^PS(55,"_PSJHLDFN_",""IV"","_+PSJORDER,1:"^PS(55,"_PSJHLDFN_",5,"_+PSJORDER)_"," + I RXORDER["P",$P($G(@(PSJORDER_"0)")),U,15)'=PSJHLDFN S ORDCON="Patient does not match/PSJHL2" S X="ORERR" X ^%ZOSF("TEST") I D EN^ORERR(ORDCON) Q + S UNDO=$S("OC^CR"[PSOC:1,1:0) + D INIT,PID,PV1,ORC + D @$S("SN^SC^OC^OD^DR^CR^OH^OR^XX^ZC^XR"[PSOC:"EN1^PSJHL3(PSJHLDFN,PSOC,PSJORDER)",1:"CALL^PSJHLU(PSJI)") + I UNDO D UNDO + K ^TMP("PSJHLS",$J,"PS"),FIELD + Q + ; +INIT ; initialize HL7 variables, set master file identification segment + ; PSJHLMTN = message type - ORR for messages sent as a response to an OE/RR event; ORM for "unsolicited" messages. + S PSJI=0,PSJHLMTN=$S($G(PSJHLMTN)]"":PSJHLMTN,1:"ORM") + D INIT^PSJHLU + S LIMIT=17 X PSJCLEAR + S FIELD(0)="MSH",FIELD(1)="^~\&",FIELD(2)="PHARMACY",FIELD(3)=$G(PSJHINST),FIELD(8)=PSJHLMTN + D SEGMENT^PSJHLU(LIMIT),DISPLAY + Q + ; +PID ; get patient data, format PID SEGMENT + S LIMIT=22 X PSJCLEAR + S FIELD(0)="PID" + S FIELD(3)=PSJHLDFN + N DFN S DFN=PSJHLDFN D DEM^VADPT S FIELD(5)=VADM(1) + D SEGMENT^PSJHLU(LIMIT),DISPLAY + Q + ; +PV1 ; get patient visit information, format PV1 segment + N PSJAPPT + S LIMIT=50 X PSJCLEAR + S FIELD(0)="PV1" + I PSJHLMTN="ORR" S FIELD(3)=LOC + I PSJHLMTN="ORM" D + .S LOC="",WARD=$G(^DPT(PSJHLDFN,.1)),LOC=$S($G(WARD)]"":$O(^SC("B",WARD,LOC)),1:LOC) + .I $G(LOC)="" D + .. N A + .. I RXORDER["P",($G(^PS(53.1,+RXORDER,"DSS"))) S A=^("DSS"),LOC=$P(A,"^"),PSJAPPT=$P(A,"^",2) + .. I RXORDER["V",($G(^PS(55,PSJHLDFN,"IV",+RXORDER,"DSS"))) S A=^("DSS"),LOC=$P(A,"^"),PSJAPPT=$P(A,"^",2) + .. I RXORDER["U",$G(^PS(55,PSJHLDFN,5,+RXORDER,8)) S A=^(8),LOC=$P(A,"^"),PSJAPPT=$P(A,"^",2) + .I $G(LOC)]"" S ROOMBED=$G(^DPT(PSJHLDFN,.101)),LOC=LOC_"^"_ROOMBED + .S FIELD(3)=LOC I $G(PSJAPPT)]"" S FIELD(44)=$$FMTHL7^XLFDT(PSJAPPT) + S FIELD(2)=$S($G(CLASS)="O":CLASS,1:"I") + I FIELD(2)="I" N DFN S DFN=PSJHLDFN D INP^VADPT S FIELD(19)=VAIN(1) + D SEGMENT^PSJHLU(LIMIT),DISPLAY + Q + ; +ORC ; order control segment + S LIMIT=18 X PSJCLEAR + Q:'$D(PSJORDER)!'$D(PSOC) + S NODE1=$G(@(PSJORDER_"0)")),NODE2=$G(@(PSJORDER_"2)")) + S NODE4=$G(@(PSJORDER_"4)")) + S FIELD(0)="ORC" + S FIELD(1)=PSOC + S FIELD(2)=$S(PSOC="SN":"",1:$P(NODE1,"^",21))_"^OR" I $P(FIELD(2),"^")=0 S $P(FIELD(2),"^")="" ; IV orders are created with a zero in the oerr order number, for some reason + S FIELD(3)=RXORDER_"^PS" + ; translate Pharmacy status code to HL7 status code, set in FIELD(5) + S STATUS=$S($G(PSJEXPOE):"E",(($P(NODE1,"^",17)]"")&(RXORDER["V")):($P(NODE1,"^",17)),($P(NODE1,"^",9)]""):$P(NODE1,"^",9),$G(PSIVCOPY):"DE",1:"") + ;BHW;Remedy HD0000000086717;If the order has a pending number, send pending status even if current status is Active. + I STATUS="A",RXORDER["P" S STATUS="N" D @STATUS S STATUS="A" + E D @STATUS + I STATUS="U",RXORDER["P" S FIELD(3)="^PS" + S FIELD(9)=$S(RXORDER["V":$$FMTHL7^XLFDT($P(NODE2,"^")),1:$$FMTHL7^XLFDT($P(NODE1,"^",16))) + S CLERK=$S(RXORDER["V":$P(NODE2,"^",11),1:$P(NODE4,"^",7)) + S NAME=$P($G(^VA(200,+CLERK,0)),"^") + S FIELD(10)=CLERK_"^"_NAME + I PSOC="ZV"!($G(PSJBCBU)) S VERIFY=$P($G(NODE4),"^"),FIELD(11)=VERIFY_"^"_$P($G(^VA(200,+VERIFY,0)),"^"),FIELD(9)=$$FMTHL7^XLFDT($P(NODE4,"^",2)) + S PROVIDER=$S($G(PSJDCPRV)]"":$G(PSJDCPRV),RXORDER["V":$P(NODE1,"^",6),1:$P(NODE1,"^",2)) K PSJDCPRV + S NAME=$P($G(^VA(200,+PROVIDER,0)),"^") + S FIELD(12)=PROVIDER_"^"_NAME + S FIELD(15)=$S(RXORDER["V":$$FMTHL7^XLFDT($P(NODE1,"^",2)),1:$$FMTHL7^XLFDT($P(NODE2,"^",2))) + I $S(RXORDER["V":$P(NODE2,"^",8)="R",1:$P(NODE1,"^",24)="R") + ; PSJ*5*141 - If this is a renewal order, update FIELD(10) with the person who entered the renewal order. + N FIELD9 S FIELD9=$$FMTHL7^XLFDT($$LASTREN^PSJLMPRI(PSJHLDFN,RXORDER)) I FIELD9>FIELD(9) S FIELD(9)=FIELD9,FIELD(15)=FIELD9,FIELD(10)=$$LASTRNBY^PSJLMPRI(PSJHLDFN,RXORDER) + S NOO=$S(PSJORDER["IV":$G(P("NAT")),(($G(PSJNOO)="")&($G(P("NAT"))]"")):$G(P("NAT")),1:$G(PSJNOO)),PSREASON=$S(NOO="D":"",1:$G(PSREASON)) + S FIELD(16)=NOO_U_$S(NOO="P":"Telephoned",NOO="D":"Duplicate",NOO="X":"Rejected",NOO="A":"Auto",NOO="S":"Service Correction",NOO="W":"Written",NOO="V":"Verbal",NOO="E":"Physician Entered",NOO="I":"Policy",1:"")_U_"99ORN"_U_U_$G(PSREASON)_U + D SEGMENT^PSJHLU(LIMIT),DISPLAY + Q + ; +DISPLAY ; just for testing + I $G(MSGTEST) W ! F NEXT=0:1:LIMIT W FIELD(NEXT)_"|" + Q +UNDO ;Undo Renew if Pending Renewal is dc'd + I RXORDER["P",(STATUS="D"),($G(PSJNOO)'="A"),($P(NODE1,U,24)="R") D ENBKOUT^PSJOREN(PSJHLDFN,RXORDER) + Q + ; +A S FIELD(5)="CM" Q ; active +D S FIELD(5)="DC" Q ; discontinued +I S FIELD(5)="IP" Q ; incomplete +N S FIELD(5)="IP" Q ; non-verified +U S FIELD(5)="ZX" Q ; unreleased +P S FIELD(5)="IP" Q ; pending +DE S FIELD(5)="RP" Q ; discontinued (edit) +E S FIELD(5)="ZE" Q ; expired +H S FIELD(5)="HD" Q ; hold +R S FIELD(5)="ZZ" Q ; renewed +RE S FIELD(5)="CM" Q ; reinstated +DR S FIELD(5)="DC" Q ; discontinued (renewal) +O S FIELD(5)="HD" Q ; on call (is this kind of like HOLD?) diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL3.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL3.m index 88e000ee..efb8b79e 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL3.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL3.m @@ -1,147 +1,160 @@ -PSJHL3 ;BIR/RLW-PHARMACY ORDER SEGMENTS ;04 Aug 98 / 10:10 AM - ;;5.0; INPATIENT MEDICATIONS ;**1,11,14,40,42,47,50,56,58,92,101,102,123,110,111,152,134**;16 DEC 97;Build 124 - ; - ; Reference to ^PS(50.606 is supported by DBIA# 2174. - ; Reference to ^PS(50.607 is supported by DBIA# 2221. - ; Reference to ^PS(50.7 is supported by DBIA# 2180. - ; Reference to ^PS(51.2 is supported by DBIA# 2178. - ; Reference to ^PS(52.6 is supported by DBIA# 1231. - ; Reference to ^PS(52.7 is supported by DBIA# 2173. - ; Reference to ^PS(55 is supported by DBIA# 2191. - ; Reference to ^PSDRUG( is supported by DBIA# 2192. - ; Reference to ^PSNDF( is supported by DBIA# 2195. - ; Reference to ^VA(200 is supported by DBIA# 10060. - ; Reference to ^PSNAPIS is supported by DBIA# 2531. - ; Reference to ^XLFDT is supported by DBIA# 10103. - ; Reference to ^PSSUTIL1 is supported by DBIA# 3179. - ; Reference to ^ORHLESC is supported by DBIA# 4922. - ; -EN1(PSJHLDFN,PSOC,PSJORDER) ; start here - ; passed in are PSJHLDFN (patient ien) - ; PSJORDER (file root of order) - ; OC (order control code - NW for new order, OK for finished order, OC for order canceled) - I $G(PSJHLDFN)']""!$G(PSOC)']""!$G(PSJORDER)']"" W !,"INSUFFICIENT DATA FOR ^PSJHL3" Q - N COMMENTS,DDIEA,DDNUM,DOSE,DOSEFORM,DOSEOR,NAME,DURATION,IVTYPE,NODE1,NODE2,NDNODE,OINODE,PSGPLS,PSGPLF,PRODNAME,SPDIEN,UNIT,UNITS,CNT,DDIEN,SCHEDULE,PSGST - D INIT - S IVTYPE=$S(RXORDER["U":"",1:$$IVTYPE^PSJHLU(PSJORDER)) - D RXO,RXE,RXR D ZRX - D CALL^PSJHLU(PSJI) - Q -INIT ; initialize HL7 variables - D INIT^PSJHLU - Q -RXO ; pharmacy prescription order segment (used to send Orderable Item to OE/RR) - S LIMIT=17 X PSJCLEAR - S FIELD(0)="RXO" - S OINODE=$G(@(PSJORDER_".2)")) - S SPDIEN=+$P(OINODE,"^"),DOSEOR=$$ESC^ORHLESC($P(OINODE,"^",2)),DOSE=$P(OINODE,"^",5),UNIT=$P(OINODE,"^",6) S:'$G(PSJBCBU) UNIT=$$ESC^ORHLESC(UNIT) - S FIELD(1)=$S(SPDIEN=0:"^^^^",1:"^^^"_SPDIEN_"^") - I SPDIEN S DOSEFORM=$P($G(^PS(50.7,SPDIEN,0)),"^",2),NAME=$P($G(^PS(50.606,+DOSEFORM,0)),"^") S:'$G(PSJBCBU) NAME=$$ESC^ORHLESC(NAME) S FIELD(1)=FIELD(1)_$$ESC^ORHLESC($P($G(^PS(50.7,SPDIEN,0)),"^"))_" "_NAME - S FIELD(1)=FIELD(1)_"^99PSP" - N IVLNOD S IVLNOD=$G(@(PSJORDER_"2.5)")) D - .S IVLIM=$P(IVLNOD,"^",4) I IVLIM?1"a".N S IVLIM="doses"_$P(IVLIM,"a",2) - .S $P(FIELD(1),"^",3)=IVLIM - D SEGMENT^PSJHLU(LIMIT),DISPLAY^PSJHL2 - Q -RXE ; pharmacy encoded order segment - S (UNITS,NDNODE,SPDIEN,PRODNAME,DDNUM,DDIEN,CNT)="",LIMIT=26 X PSJCLEAR - S FIELD(0)="RXE" - S NODE1=$G(@(PSJORDER_"0)")),NODE2=$G(@(PSJORDER_"2)")),NODEPT2=$G(@(PSJORDER_".2)")) - I $G(PSGST)="" N PSGST D - .I $G(RXORDER)["V" N X,ZZND,LYN,PSGS0XT,PSGS0Y,PSGOES S PSGOES=1 S X=$G(P(9)) I X]"" D EN^PSGS0 S:$G(ZZND)'="" PSGST=$P(ZZND,"^",5) Q - .S PSGST=$P($G(NODE1),"^",7) - I RXORDER["V" D IVRXE Q - I RXORDER["P",IVTYPE="F" D IVRXE Q - I RXORDER["P",$P(NODE1,"^",4)="H" D IVRXE Q - N RENEW S RENEW=$$LASTREN^PSJLMPRI(PSJHLDFN,RXORDER) - S PSGPLS=$S($G(PSJEXPOE):$P(NODE2,"^",2),RENEW>$P(NODE2,"^",2):RENEW,1:$P(NODE2,"^",2)) - S PSGPLF=$S($G(PSJEXPOE):PSJEXPOE,1:$P(NODE2,"^",4)) - S FIELD(1)="^"_$S($G(PSJBCBU):$P(NODE2,"^"),1:$$ESC^ORHLESC($P(NODE2,"^")))_"&"_$P(NODE2,"^",5)_"^^"_$$FMTHL7^XLFDT(PSGPLS)_"^"_$$FMTHL7^XLFDT(PSGPLF)_"^"_$P($G(NODEPT2),"^",4)_"^"_$G(PSGST) - S FIELD(21)="^"_$P(NODE2,"^",5)_"^99PSA^^^" - I ($G(DOSEOR)']"")!($O(@(PSJORDER_"1,"" "")"),-1)=1) D - .S (CNT,DDNUM)=0 F S DDNUM=$O(@(PSJORDER_"1,"_DDNUM_")")) Q:'DDNUM Q:CNT=1 S DDIEN=+$G(@(PSJORDER_"1,"_DDNUM_",0)")) D - ..S FIELD(1)=$S($P(@(PSJORDER_"1,"_DDNUM_",0)"),"^",2)="":"1",1:$P(@(PSJORDER_"1,"_DDNUM_",0)"),"^",2))_"&"_FIELD(1) - ..S FIELD(1)=DOSE_"&"_UNIT_"&"_FIELD(1),$P(FIELD(1),"^",8)=$S($G(DOSEOR)]"":$G(DOSEOR),1:DOSE_UNIT) - ..S:$P(FIELD(1),"^",8)="" $P(FIELD(1),"^",8)=$$ESC^ORHLESC($G(@(PSJORDER_".3)"))) - ..S NDNODE=$G(^PSDRUG(DDIEN,"ND")) - ..; CHANGE FOR NEW NDF CALL - ..S PRODNAME=$S($T(^PSNAPIS)]"":$$PROD0^PSNAPIS(+NDNODE,$P(NDNODE,"^",3)),$G(^PSNDF(+NDNODE,5,+$P(NDNODE,"^",3),0))]"":^(0),1:"N/A") - ..S:PRODNAME="" PRODNAME="N/A" - ..S FIELD(2)=$S(PRODNAME="N/A":"^^",1:+NDNODE_"."_+$P(NDNODE,"^",3)_"^"_$P(NDNODE,"^",2)_"^"_"99NDF")_"^"_DDIEN_"^"_$S($G(PSJBCBU):$P($G(^PSDRUG(DDIEN,0)),"^"),1:$$ESC^ORHLESC($P($G(^PSDRUG(DDIEN,0)),"^")))_"^"_"99PSD" - ..S UNITS=$S(PRODNAME="N/A":"N/A",1:$S($T(^PSNAPIS)]"":$P($$DFSU^PSNAPIS(+NDNODE,$P(NDNODE,"^",3)),"^",5),1:$P($G(^PSNDF(+NDNODE,2,+$P(PRODNAME,"^",2),3,+$P(PRODNAME,"^",3),4,+$P(PRODNAME,"^",4),0)),"^"))) - ..S FIELD(5)="^^^"_$$ESC^ORHLESC(UNITS)_"^"_$$ESC^ORHLESC($P($G(^PS(50.607,UNITS,0)),"^"))_"^99PSU" - ..S FIELD(6)="^^^"_$$ESC^ORHLESC($G(DOSEFORM))_"^"_$$ESC^ORHLESC($P($G(^PS(50.606,+$G(DOSEFORM),0)),"^"))_"^99PSF" - ..S FIELD(25)=$$EN^PSSUTIL1(DDIEN),FIELD(26)=$P(FIELD(25),"|",2),FIELD(25)=$P(FIELD(25),"|") - ..I $P(FIELD(25),"^",5)]"" S $P(FIELD(25),"^",5)=$$ESC^ORHLESC($P(FIELD(25),"^",5)) - ..S CNT=CNT+1 - E S $P(FIELD(1),"^",8)=$$ESC^ORHLESC(DOSEOR) - S NAME=$P($G(^VA(200,DUZ,0)),"^") S:'$G(PSJBCBU) NAME=$$ESC^ORHLESC(NAME) S FIELD(14)=DUZ_"^"_NAME_"^"_"99NP" - D SEGMENT^PSJHLU(LIMIT),DISPLAY^PSJHL2 - D SEGMENT2^PSJHLU - Q -IVRXE ; RXE segment for IV orders - ; If an Inpatient Med IV order, send RXE w/dispense drug info. - ; If an IV FLUID order, send start/stop date and duration in the RXE - ; and send an RXC for each additive and solution. - N ADSNODE - I RXORDER["V" S PSGPLS=$P(NODE1,"^",2),PSGPLF=$P(NODE1,"^",3) - E S PSGPLS=$P(NODE2,"^",2),PSGPLF=$P(NODE2,"^",4) - S FIELD(1)="^"_$S(PSJORDER["IV":($P(NODE1,"^",9)_"&"_$P(NODE1,"^",11)),1:$P(NODE2,"^"))_"^^"_$$FMTHL7^XLFDT(PSGPLS)_"^"_$$FMTHL7^XLFDT(PSGPLF)_"^"_$G(P("PRY")) - S FIELD(21)="^"_$S(PSJORDER["IV":$P(NODE1,"^",11),1:$P(NODE2,"^",5))_"^99PSA^^^" - S NAME=$P($G(^VA(200,DUZ,0)),"^") S:'$G(PSJBCBU) NAME=$$ESC^ORHLESC(NAME) - S FIELD(14)=DUZ_"^"_NAME_"^"_"99NP" - N X,Y - I RXORDER["V" S INFUSE=$P(NODE1,"^",8) - E S INFUSE=$P($G(@(PSJORDER_"8)")),"^",5) - I INFUSE?1N.N1" ml/hr" S FIELD(23)=+INFUSE,Y=$P(INFUSE,+INFUSE,2),Y=$$TRIM^XLFSTR(Y,"LR"," "),FIELD(24)="^^^^"_Y_"^PSU" - I FIELD(23)="",FIELD(24)="" S FIELD(23)=INFUSE - D SEGMENT^PSJHLU(LIMIT),DISPLAY^PSJHL2 - K SEGMENT I RXORDER["V" S JJ=0 F S JJ=$O(@(PSJORDER_"5,"_JJ_")")) Q:'JJ S SEGMENT(JJ-1)=$S($G(PSJBCBU):$G(@(PSJORDER_"5,"_JJ_",0)")),1:$$ESC^ORHLESC($G(@(PSJORDER_"5,"_JJ_",0)")))) - E S JJ=0 F S JJ=$O(@(PSJORDER_"12,"_JJ_")")) Q:'JJ S SEGMENT(JJ-1)=$S($G(PSJBCBU):$G(@(PSJORDER_"12,"_JJ_",0)")),1:$G(@(PSJORDER_"12,"_JJ_",0)"))) - I $D(SEGMENT(0)) S SEGMENT(0)="NTE|6|L|"_SEGMENT(0) D - .D SET^PSJHLU K SEGMENT,JJ - I RXORDER["V",$P($G(@(PSJORDER_"3)")),"^")]"" K SEGMENT D - .S SEGMENT(0)="NTE|21|L|"_$S($G(PSJSBCBU):$P($G(@(PSJORDER_"3)")),"^"),1:$$ESC^ORHLESC($P($G(@(PSJORDER_"3)")),"^"))) D - .D SET^PSJHLU K SEGMENT - I RXORDER["P",$P($G(@(PSJORDER_"9)")),U,2)]"" K SEGMENT D - .S SEGMENT(0)="NTE|21|L|"_$S($G(PSJSBCBU):$P($G(@(PSJORDER_"9)")),U,2),1:$$ESC^ORHLESC($P($G(@(PSJORDER_"9)")),U,2))) D - .D SET^PSJHLU K SEGMENT -RXC ;component segments - N ADDITIVE,SOLUTION,SUB,TYPE,AD,SOL,PTR,NUM,UTMP,XTMP - S LIMIT=24 X PSJCLEAR - S FIELD(0)="RXC" - ; In the line below, the naked reference refers to the full global reference represented in PSJORDER_TYPE... - ; This could be a reference to either ^PS(53.1 or ^PS(55 - S AD="AD",SOL="SOL" F TYPE="AD","SOL" S SUB=0 F S SUB=$O(@(PSJORDER_TYPE_","_SUB_")")) Q:SUB="" S NODE1=$G(^(SUB,0)) Q:NODE1="" D - .S FIELD(1)=$S(TYPE="AD":"A",1:"B") - .S PTR=+$S(TYPE="AD":+$P($G(^PS(52.6,$P(NODE1,"^"),0)),"^",11),1:+$P($G(^PS(52.7,$P(NODE1,"^"),0)),"^",11)) - .S FIELD(2)="^^^"_$S($G(PSJBCBU):+$P(NODE1,"^"),1:PTR)_"^"_$S($G(PSJBCBU):$S(TYPE="AD":$P($G(^PS(52.6,+$P(NODE1,"^"),0)),"^"),1:$P($G(^PS(52.7,+$P(NODE1,"^"),0)),"^")_" "_$P($G(^(0)),U,4)),1:$P($G(^PS(50.7,PTR,0)),"^")) - .S:(TYPE="AD"&$G(PSJBCBU)) FIELD(2)=FIELD(2)_$S($P(NODE1,"^",3)]"":" BOTTLE: "_$P(NODE1,"^",3),1:"") - .S FIELD(2)=FIELD(2)_"^99PSP" - .S FIELD(3)=$P($P(NODE1,"^",2)," ") - .S FIELD(4)=$P($P(NODE1,"^",2)," ",2) - .F XTMP=1:1:14 S UTMP($P("ML^LITER^MCG^MG^GM^UNITS^IU^MEQ^MM^MU^THOUU^MG-PE^NANOGRAM^MMOL","^",XTMP))="PSIV-"_XTMP - .S NUM="" S:FIELD(4)'="" NUM=$G(UTMP(FIELD(4))) - .S FIELD(4)="^^^"_NUM_"^"_FIELD(4)_"^99OTH" - .D SEGMENT^PSJHLU(LIMIT),DISPLAY^PSJHL2 - Q -RXR ; med route segment - S LIMIT=4 X PSJCLEAR - S FIELD(0)="RXR" - I PSJORDER["IV" S FIELD(1)="^^^"_$P($G(@(PSJORDER_".2)")),"^",3) Q:$P(FIELD(1),U,4)="" D - .N PSJUNITS S PSJUNITS=$S($G(PSJBCBU):$P($G(^PS(51.2,+$P(FIELD(1),"^",4),0)),"^"),1:$$ESC^ORHLESC($P($G(^PS(51.2,+$P(FIELD(1),"^",4),0)),"^"))) - .S FIELD(1)=FIELD(1)_"^"_PSJUNITS_"^99PSR" - .S:$G(PSJBCBU) FIELD(4)="^^^"_$P($G(@(PSJORDER_"0)")),"^",4)_"^"_$$CODES^PSIVUTL($P($G(@(PSJORDER_"0)")),"^",4),55.01,.04)_"^99PSR" - I PSJORDER[53.1 S FIELD(1)="^^^"_$P($G(@(PSJORDER_"0)")),"^",3) Q:$P(FIELD(1),U,4)="" D - .N PSJUNITS S PSJUNITS=$S($G(PSJBCBU):$P($G(^PS(51.2,+$P(FIELD(1),"^",4),0)),"^"),1:$$ESC^ORHLESC($P($G(^PS(51.2,+$P(FIELD(1),"^",4),0)),"^"))) - .S FIELD(1)=FIELD(1)_"^"_PSJUNITS_"^99PSR" - .S:$G(PSJBCBU) FIELD(4)="^^^"_$P($G(@(PSJORDER_"0)")),"^",4)_"^"_$$CODES^PSIVUTL($P($G(@(PSJORDER_"0)")),"^",4),53.1,4)_"^99PSR" - S:FIELD(1)="" FIELD(1)="^^^"_$P(NODE1,"^",3)_"^"_$S($G(PSJBCBU):$P($G(^PS(51.2,+$P(NODE1,"^",3),0)),"^"),1:$$ESC^ORHLESC($P($G(^PS(51.2,+$P(NODE1,"^",3),0)),"^")))_"^99PSR" - D SEGMENT^PSJHLU(LIMIT),DISPLAY^PSJHL2 - Q -ZRX ; pharmacy Z-segment - D ZRX^PSJHLU - Q -CNT ;Count dispense drugs for an order - S (CNT,DDNUM)=0 F S DDNUM=$O(@(PSJORDER_"1,"_DDNUM_")")) Q:'DDNUM S CNT=CNT+1 - Q +PSJHL3 ;BIR/RLW-PHARMACY ORDER SEGMENTS ;04 Aug 98 / 10:10 AM + ;;5.0; INPATIENT MEDICATIONS ;**1,11,14,40,42,47,50,56,58,92,101,102,123,110,111,152**;16 DEC 97 + ; + ; Reference to ^PS(50.606 is supported by DBIA# 2174. + ; Reference to ^PS(50.607 is supported by DBIA# 2221. + ; Reference to ^PS(50.7 is supported by DBIA# 2180. + ; Reference to ^PS(51.2 is supported by DBIA# 2178. + ; Reference to ^PS(52.6 is supported by DBIA# 1231. + ; Reference to ^PS(52.7 is supported by DBIA# 2173. + ; Reference to ^PS(55 is supported by DBIA# 2191. + ; Reference to ^PSDRUG( is supported by DBIA# 2192. + ; Reference to ^PSNDF( is supported by DBIA# 2195. + ; Reference to ^VA(200 is supported by DBIA# 10060. + ; Reference to ^PSNAPIS is supported by DBIA# 2531. + ; Reference to ^XLFDT is supported by DBIA# 10103. + ; Reference to ^PSSUTIL1 is supported by DBIA# 3179. + ; +EN1(PSJHLDFN,PSOC,PSJORDER) ; start here + ; passed in are PSJHLDFN (patient ien) + ; PSJORDER (file root of order) + ; OC (order control code - NW for new order, OK for finished order, OC for order canceled) + I $G(PSJHLDFN)']""!$G(PSOC)']""!$G(PSJORDER)']"" W !,"INSUFFICIENT DATA FOR ^PSJHL3" Q + N COMMENTS,DDIEA,DDNUM,DOSE,DOSEFORM,DOSEOR,NAME,DURATION,IVTYPE,NODE1,NODE2,NDNODE,OINODE,PSGPLS,PSGPLF,PRODNAME,SPDIEN,UNIT,UNITS,CNT,DDIEN,SCHEDULE + D INIT + S IVTYPE=$S(RXORDER["U":"",1:$$IVTYPE^PSJHLU(PSJORDER)) + D RXO,RXE D:(IVTYPE'="F")!($G(PSJBCBU)) RXR D ZRX + D CALL^PSJHLU(PSJI) + Q + ; +INIT ; initialize HL7 variables + D INIT^PSJHLU + Q + ; +RXO ; pharmacy prescription order segment (used to send Orderable Item to OE/RR) + S LIMIT=17 X PSJCLEAR + S FIELD(0)="RXO" + S OINODE=$G(@(PSJORDER_".2)")) + S SPDIEN=+$P(OINODE,"^"),DOSEOR=$P(OINODE,"^",2),DOSE=$P(OINODE,"^",5),UNIT=$P(OINODE,"^",6) + S FIELD(1)=$S(SPDIEN=0:"^^^^",1:"^^^"_SPDIEN_"^") + I SPDIEN S DOSEFORM=$P($G(^PS(50.7,SPDIEN,0)),"^",2),NAME=$P($G(^PS(50.606,+DOSEFORM,0)),"^"),FIELD(1)=FIELD(1)_$P($G(^PS(50.7,SPDIEN,0)),"^")_" "_NAME + S FIELD(1)=FIELD(1)_"^99PSP" + N DURNOD S DURNOD=$G(@(PSJORDER_"2.5)")) I $P(DURNOD,"^",4)]"" S $P(FIELD(1),"^",3)=$P(DURNOD,"^",4) + D SEGMENT^PSJHLU(LIMIT),DISPLAY^PSJHL2 + Q + ; +RXE ; pharmacy encoded order segment + S (UNITS,NDNODE,SPDIEN,PRODNAME,DDNUM,DDIEN,CNT)="",LIMIT=26 X PSJCLEAR + S FIELD(0)="RXE" + S NODE1=$G(@(PSJORDER_"0)")),NODE2=$G(@(PSJORDER_"2)")) + I RXORDER["V" D IVRXE Q + I RXORDER["P",IVTYPE="F" D IVRXE Q + I RXORDER["P",$P(NODE1,"^",4)="H" D IVRXE Q + ;S PSGPLS=$P(NODE2,"^",2),PSGPLF=$P(NODE2,"^",4),X1=PSGPLF,X2=PSGPLS D ^%DTC S DURATION="D"_X + N RENEW S RENEW=$$LASTREN^PSJLMPRI(PSJHLDFN,RXORDER) + S PSGPLS=$S($G(PSJEXPOE):$P(NODE2,"^",2),RENEW>$P(NODE2,"^",2):RENEW,1:$P(NODE2,"^",2)) + S PSGPLF=$S($G(PSJEXPOE):PSJEXPOE,1:$P(NODE2,"^",4)) + ;S FIELD(1)="^"_$P(NODE2,"^")_$S($G(PSJBCBU):"&"_$P(NODE2,"^",5),1:"")_"^^"_$$FMTHL7^XLFDT(PSGPLS)_"^"_$$FMTHL7^XLFDT(PSGPLF) + S FIELD(1)="^"_$P(NODE2,"^")_"^^"_$$FMTHL7^XLFDT(PSGPLS)_"^"_$$FMTHL7^XLFDT(PSGPLF) + S FIELD(21)="^"_$P(NODE2,"^",5)_"^99PSA^^^" + I ($G(DOSEOR)']"")!($O(@(PSJORDER_"1,"" "")"),-1)=1) D + .S (CNT,DDNUM)=0 F S DDNUM=$O(@(PSJORDER_"1,"_DDNUM_")")) Q:'DDNUM Q:CNT=1 S DDIEN=+$G(@(PSJORDER_"1,"_DDNUM_",0)")) D + ..S FIELD(1)=$S($P(@(PSJORDER_"1,"_DDNUM_",0)"),"^",2)="":"1",1:$P(@(PSJORDER_"1,"_DDNUM_",0)"),"^",2))_"&"_FIELD(1) + ..S FIELD(1)=DOSE_"&"_UNIT_"&"_FIELD(1),$P(FIELD(1),"^",8)=$S($G(DOSEOR)]"":$G(DOSEOR),1:DOSE_UNIT) + ..S:$P(FIELD(1),"^",8)="" $P(FIELD(1),"^",8)=$G(@(PSJORDER_".3)")) + ..S NDNODE=$G(^PSDRUG(DDIEN,"ND")) + ..; CHANGE FOR NEW NDF CALL + ..;S PRODNAME=$S($G(^PSNDF(+NDNODE,5,+$P(NDNODE,"^",3),0))]"":^(0),1:"N/A") + ..S PRODNAME=$S($T(^PSNAPIS)]"":$$PROD0^PSNAPIS(+NDNODE,$P(NDNODE,"^",3)),$G(^PSNDF(+NDNODE,5,+$P(NDNODE,"^",3),0))]"":^(0),1:"N/A") + ..S:PRODNAME="" PRODNAME="N/A" + ..S FIELD(2)=$S(PRODNAME="N/A":"^^",1:+NDNODE_"."_+$P(NDNODE,"^",3)_"^"_$P(NDNODE,"^",2)_"^"_"99NDF")_"^"_DDIEN_"^"_$P($G(^PSDRUG(DDIEN,0)),"^")_"^"_"99PSD" + ..;S UNITS=$S(PRODNAME="N/A":"N/A",1:$P($G(^PSNDF(+NDNODE,2,+$P(PRODNAME,"^",2),3,+$P(PRODNAME,"^",3),4,+$P(PRODNAME,"^",4),0)),"^")) + ..S UNITS=$S(PRODNAME="N/A":"N/A",1:$S($T(^PSNAPIS)]"":$P($$DFSU^PSNAPIS(+NDNODE,$P(NDNODE,"^",3)),"^",5),1:$P($G(^PSNDF(+NDNODE,2,+$P(PRODNAME,"^",2),3,+$P(PRODNAME,"^",3),4,+$P(PRODNAME,"^",4),0)),"^"))) + ..S FIELD(5)="^^^"_UNITS_"^"_$P($G(^PS(50.607,UNITS,0)),"^")_"^99PSU" + ..S FIELD(6)="^^^"_$G(DOSEFORM)_"^"_$P($G(^PS(50.606,+$G(DOSEFORM),0)),"^")_"^99PSF" + ..S FIELD(25)=$$EN^PSSUTIL1(DDIEN),FIELD(26)=$P(FIELD(25),"|",2),FIELD(25)=$P(FIELD(25),"|") + ..S CNT=CNT+1 + E S $P(FIELD(1),"^",8)=DOSEOR + S NAME=$P($G(^VA(200,DUZ,0)),"^"),FIELD(14)=DUZ_"^"_NAME_"^"_"99NP" + D SEGMENT^PSJHLU(LIMIT),DISPLAY^PSJHL2 + K SEGMENT S JJ=0 F S JJ=$O(@(PSJORDER_"12,"_JJ_")")) Q:'JJ S SEGMENT(JJ-1)=$G(@(PSJORDER_"12,"_JJ_",0)")) + I $D(SEGMENT(0)) S SEGMENT(0)="NTE|6|L|"_SEGMENT(0) D SET^PSJHLU K SEGMENT,JJ + I $P($G(@(PSJORDER_"6)")),"^")]"" K SEGMENT S SEGMENT(0)="NTE|21|L|"_$P($G(@(PSJORDER_"6)")),"^") D SET^PSJHLU K SEGMENT + I PSJORDER["P",$P($G(@(PSJORDER_"9)")),"^",2)]"" K SEGMENT S SEGMENT(0)="NTE|21|L|"_$P($G(@(PSJORDER_"9)")),"^",2) D SET^PSJHLU K SEGMENT + Q + ; +IVRXE ; RXE segment for IV orders + ; if it's an Inpatient Med IV order, send the RXE with dispense drug + ; information. If it's an IV FLUID order, send just the start/stop + ; date, duration in the RXE and send an RXC for each additive and + ; solution. + N ADSNODE + I RXORDER["V" S PSGPLS=$P(NODE1,"^",2),PSGPLF=$P(NODE1,"^",3) + E S PSGPLS=$P(NODE2,"^",2),PSGPLF=$P(NODE2,"^",4) + ;S X1=PSGPLF,X2=PSGPLS D ^%DTC S DURATION=$S(X]"":"D"_X,1:"") + S FIELD(1)="^"_$S(PSJORDER["IV":$P(NODE1,"^",9),1:$P(NODE2,"^"))_"^^"_$$FMTHL7^XLFDT(PSGPLS)_"^"_$$FMTHL7^XLFDT(PSGPLF) + ;S:$G(PSJBCBU) $P(FIELD(1),"^",2)=$P(FIELD(1),"^",2)_"&"_$S(PSJORDER["IV":$P(NODE1,"^",11),1:$P(NODE2,"^",5)) + S FIELD(21)="^"_$S(PSJORDER["IV":$P(NODE1,"^",11),1:$P(NODE2,"^",5))_"^99PSA^^^" + S NAME=$P($G(^VA(200,DUZ,0)),"^") + S FIELD(14)=DUZ_"^"_NAME_"^"_"99NP" + N X,Y + I RXORDER["V" S INFUSE=$P(NODE1,"^",8) + E S INFUSE=$P($G(@(PSJORDER_"8)")),"^",5) + I INFUSE?1N.N1" ml/hr" S FIELD(23)=+INFUSE,Y=$P(INFUSE,+INFUSE,2),Y=$$TRIM^XLFSTR(Y,"LR"," "),FIELD(24)="^^^^"_Y_"^PSU" + I FIELD(23)="",FIELD(24)="" S FIELD(23)=INFUSE + D SEGMENT^PSJHLU(LIMIT),DISPLAY^PSJHL2 + K SEGMENT I RXORDER["V" S JJ=0 F S JJ=$O(@(PSJORDER_"5,"_JJ_")")) Q:'JJ S SEGMENT(JJ-1)=$G(@(PSJORDER_"5,"_JJ_",0)")) + E S JJ=0 F S JJ=$O(@(PSJORDER_"12,"_JJ_")")) Q:'JJ S SEGMENT(JJ-1)=$G(@(PSJORDER_"12,"_JJ_",0)")) + I $D(SEGMENT(0)) S SEGMENT(0)="NTE|6|L|"_SEGMENT(0) D SET^PSJHLU K SEGMENT,JJ + I RXORDER["V",$P($G(@(PSJORDER_"3)")),"^")]"" K SEGMENT S SEGMENT(0)="NTE|21|L|"_$P($G(@(PSJORDER_"3)")),"^") D SET^PSJHLU K SEGMENT + I RXORDER["P",$P($G(@(PSJORDER_"9)")),U,2)]"" S SEGMENT(0)="NTE|21|L|"_$P($G(@(PSJORDER_"9)")),U,2) D SET^PSJHLU K SEGMENT + ; +RXC ;component segments + N ADDITIVE,SOLUTION,SUB,TYPE,AD,SOL,PTR,NUM,UTMP,XTMP + S LIMIT=24 X PSJCLEAR + S FIELD(0)="RXC" + ; In the line below, the naked reference refers to the full global reference represented in PSJORDER_TYPE... + ; This could be a reference to either ^PS(53.1 or ^PS(55 + S AD="AD",SOL="SOL" F TYPE="AD","SOL" S SUB=0 F S SUB=$O(@(PSJORDER_TYPE_","_SUB_")")) Q:SUB="" S NODE1=$G(^(SUB,0)) Q:NODE1="" D + .S FIELD(1)=$S(TYPE="AD":"A",1:"B") + .S PTR=+$S(TYPE="AD":+$P($G(^PS(52.6,$P(NODE1,"^"),0)),"^",11),1:+$P($G(^PS(52.7,$P(NODE1,"^"),0)),"^",11)) + .S FIELD(2)="^^^"_$S($G(PSJBCBU):+$P(NODE1,"^"),1:PTR)_"^"_$S($G(PSJBCBU):$S(TYPE="AD":$P($G(^PS(52.6,+$P(NODE1,"^"),0)),"^"),1:$P($G(^PS(52.7,+$P(NODE1,"^"),0)),"^")_" "_$P($G(^(0)),U,4)),1:$P($G(^PS(50.7,PTR,0)),"^")) + .S:(TYPE="AD"&$G(PSJBCBU)) FIELD(2)=FIELD(2)_$S($P(NODE1,"^",3)]"":" BOTTLE: "_$P(NODE1,"^",3),1:"") + .S FIELD(2)=FIELD(2)_"^99PSP" + .S FIELD(3)=$P($P(NODE1,"^",2)," ") + .S FIELD(4)=$P($P(NODE1,"^",2)," ",2) + .F XTMP=1:1:13 S UTMP($P("ML^LITER^MCG^MG^GM^UNITS^IU^MEQ^MM^MU^THOUU^MG-PE^NANOGRAM","^",XTMP))="PSIV-"_XTMP + .S NUM="" S:FIELD(4)'="" NUM=$G(UTMP(FIELD(4))) + .S FIELD(4)="^^^"_NUM_"^"_FIELD(4)_"^99OTH" + .D SEGMENT^PSJHLU(LIMIT),DISPLAY^PSJHL2 + Q + ; +RXR ; med route segment + S LIMIT=4 X PSJCLEAR + S FIELD(0)="RXR" + I PSJORDER["IV" S FIELD(1)="^^^"_$P($G(@(PSJORDER_".2)")),"^",3) Q:$P(FIELD(1),U,4)="" D + .S FIELD(1)=FIELD(1)_"^"_$P($G(^PS(51.2,+$P(FIELD(1),"^",4),0)),"^")_"^99PSR" + .S:$G(PSJBCBU) FIELD(4)="^^^"_$P($G(@(PSJORDER_"0)")),"^",4)_"^"_$$CODES^PSIVUTL($P($G(@(PSJORDER_"0)")),"^",4),55.01,.04)_"^99PSR" + S:FIELD(1)="" FIELD(1)="^^^"_$P(NODE1,"^",3)_"^"_$P($G(^PS(51.2,+$P(NODE1,"^",3),0)),"^")_"^99PSR" + D SEGMENT^PSJHLU(LIMIT),DISPLAY^PSJHL2 + Q + ; +ZRX ; pharmacy Z-segment + S LIMIT=6 X PSJCLEAR + S FIELD(0)="ZRX" + I '$G(PSJREN) N PREON,PSJREN I $G(PSJORD)["U"&($P(NODE1,"^",24)="R") S PSJREN=1 + I $G(PSJORD)["V"&($P(NODE2,"^",8)="R") S PSJREN=1 + S PREON=$S($G(PSJREN):$G(PSJORD),PSJORDER["IV":$P(NODE2,"^",5),1:$P(NODE1,"^",25)) + S FIELD(1)=$S(PREON["P":$P($G(^PS(53.1,+PREON,0)),"^",21),PREON["V":$P($G(^PS(55,PSJHLDFN,"IV",+PREON,0)),"^",21),1:$P($G(^PS(55,PSJHLDFN,5,+PREON,0)),"^",21)) + S FIELD(2)=$S(PSJORDER["IV":$G(P("NAT")),1:$G(PSJNOO)) + S FIELD(3)=$S($G(PSJREN):"R",PSJORDER["IV":$P(NODE2,"^",8),1:$P(NODE1,"^",24)) + I FIELD(3)="" I PSOC="SN" S FIELD(3)="N" + S NAME=$P($G(^VA(200,DUZ,0)),"^") + S FIELD(5)=DUZ_"^"_NAME_"^"_"99NP" + S FIELD(6)=$S($G(IVTYPE)="F":"IV",$P($G(@(PSJORDER_"0)")),U,4)="H":"TPN",1:"") + D SEGMENT^PSJHLU(LIMIT),DISPLAY^PSJHL2 + Q + ; +CNT ;Count dispense drugs for an order + S (CNT,DDNUM)=0 F S DDNUM=$O(@(PSJORDER_"1,"_DDNUM_")")) Q:'DDNUM S CNT=CNT+1 + Q diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL4.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL4.m index 8116b303..366aa11c 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL4.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL4.m @@ -1,189 +1,209 @@ -PSJHL4 ;BIR/RLW-DECODE HL7 /MESSSAGE FROM OE/RR ;16 Mar 99 / 4:55 PM - ;;5.0; INPATIENT MEDICATIONS ;**1,12,27,34,40,42,55,47,50,56,58,98,85,105,107,110,111,154,134**;16 DEC 97;Build 124 - ; Reference to $$EN^PSOHLNEW is supported by DBIA# 2188. - ; Reference to ^PS(50.7 is supported by DBIA 2180. - ; Reference to ^PS(51.2 is supported by DBIA 2178. - ; Reference to ^PS(55 is supported by DBIA 2191. - ; Reference to ^PS(59.7 supported by DBIA 2181. - ; Reference to ^ORHLESC is supported by DBIA 4922. - ; -EN(PSJMSG) ; Start - K ^TMP("PSJNVO",$J) - N ADCNT,SOLCNT,OCCNT - N ACKDATE,ADDITIVE,ADMINSTR,APPL,COMMENT,PSJHLDFN,DISPENSE,DOSE,DURATION,II,INSTR,J,JJ,JJJ,K,LOGIN,NEWORDER,NURSEACK,OBXFL,OCNARR,OCPROV,OCRSN,ORDER,PRIORITY,PSITEM,ORDCON,PROCOM,PSJORDER,PSREASON - N LOC,PROVIDER,PSPR,PSOC,PTR,QQ,REQST,ROUTE,RXON,RXORDER,SCHEDULE,SEGMENT,SOLUTION,STPDT,STRENGTH,TEXT,CLERK,INFRT,IVTYP,SCHTYP,PREON,NOO,ROC,FREQ,CLASS,PSJHLMTN,UNIT,UNITS,QFLG,VOLUME,TVOLUME,PSGP - N PSJASTP,FLDATE,FLCMNT,PSJFLAG,PSJYN,PRNTON,APPT,IVLIMIT,IVCAT,INTRMT - S (ADCNT,SOLCNT,OCCNT,II,TVOLUME)="",(OBXFL,QFLG)=0,PSJHLMTN="ORR" F S II=$O(PSJMSG(II)) Q:'II D DECODE Q:QFLG D @FIELD(0) Q:$G(CLASS)="O" Q:QFLG - I ($G(CLASS)'="I")!(QFLG) G END - I ($G(PSOC)="NW")!($G(PSOC)="XO") N DIK,DA S DIK="^PS(53.1,",DA=NEWORDER D EN1^DIK L -^PS(53.1,NEWORDER) - I ($G(PSOC)="NW")!($G(PSOC)="XO") D EN1^PSJHL2(PSJHLDFN,$S(PSOC="NW":"OK",1:"XR"),NEWORDER_"P") -END ; - K ^TMP("PSJNVO",$J) - I (",S,A,")[(","_$G(PRIORITY)_",")!($G(SCHEDULE)="NOW")!($G(SCHEDULE)["STAT") D - . I $G(PRIORITY)="ZD",$G(PSGORD) D NOTIFY(PSGORD_$S(PSGORD["V":"V",PSGORD["U":"U",1:""),PSJHLDFN,$G(PRIORITY),$G(SCHEDULE)) - . I $G(NEWORDER) D NOTIFY(NEWORDER_"P",PSJHLDFN,$G(PRIORITY),$G(SCHEDULE)) - Q -DECODE ; Parse into fields - K FIELD - N PSJCTR1 S PSJCTR1="" - S SEGMENT=$G(PSJMSG(II)) - I $D(PSJMSG(II,1)),$P(SEGMENT,"|",1)="ORC" F S PSJCTR1=$O(PSJMSG(II,PSJCTR1)) Q:PSJCTR1="" D - . S SEGMENT=SEGMENT_PSJMSG(II,PSJCTR1) ;Handle CPRS "overflow" ORC nodes - S J=0 - F Q:$G(SEGMENT)="" D - .I SEGMENT["|" S FIELD(J)=$P(SEGMENT,"|"),SEGMENT=$E(SEGMENT,$L(FIELD(J))+2,$L(SEGMENT)),J=J+1 Q - .I SEGMENT'["|" S FIELD(J)=SEGMENT,SEGMENT="" Q - K PSJCTR1 - Q -NOTIFY(ORDER,PSJHLDFN,PRIO,PSJSCHED) ; Send msg - N NTFYREAS,WARD,MGROUP,NTFSTAT,DRUG,DRIEN,PNAME,ORDATE,DO,PSG,XMY,VADPT,LASTFOUR,PSJSOK - Q:($G(PRIO)=""&($G(PSJSCHED)="")) - S DFN=PSJHLDFN D DEM^VADPT S LASTFOUR=$P($P(VADM(2),"^",2),"-",3) - S NTFYREAS=$S((",S,A,")[(","_PRIO_","):1,($G(PSJSCHED)="NOW"):2,($G(PSJSCHED)="STAT"):3,1:0) Q:'NTFYREAS - S PSJSOK=1 - I ORDER["P" D PND - I ORDER["U" D UD - I ORDER["V" D IV - Q:PSJSOK=1 - D XMD^PSJHL4A - Q -PND ; Pending - N WARD,WDPARM,MGRP - Q:'$D(^PS(53.1,+ORDER,0)) - S WARD=$G(^DPT(PSJHLDFN,.1)) I WARD]"" D - .N DIC,X,Y S DIC="^DIC(42,",DIC(0)="BOXZ",X=WARD D ^DIC S WARD=+Y Q:WARD=0 - .S WARD=$O(^PS(59.6,"B",WARD,0)) Q:+WARD=0 - .Q:$$SNDTSTW^PSJHL4A(PRIO,PSJSCHED,WARD) - .S WDPARM=$G(^PS(59.6,+WARD,0)),MGRP=$P(WDPARM,"^",30) Q:+MGRP=0 - .S MGRP=$$GET1^DIQ(3.8,MGRP,.01) I MGRP]"" S XMY("G."_MGRP_"@"_$G(^XMB("NETNAME")))="",PSJSOK=0 - S:'$$SNDTSTP^PSJHL4A(PRIO,PSJSCHED) MGROUP="G.PSJ STAT NOW PENDING ORDER@"_$G(^XMB("NETNAME")),XMY(MGROUP)="",PSJSOK=0 - S NTFSTAT="PENDING" - N NDP2,ND0 S NDP2=$G(^PS(53.1,+ORDER,.2)),ND0=$G(^PS(53.1,+ORDER,0)) - S DRIEN=+$P(NDP2,"^"),DO=$P(NDP2,"^",2),RTE=$P(ND0,"^",3),ORDATE=$P(ND0,"^",14) - S SCHED=$P($G(^PS(53.1,+ORDER,2)),"^") - Q -UD ; UD - N WARD,WDPARM,MGRP - Q:'$D(^PS(55,PSJHLDFN,5,+ORDER,0)) - S WARD=$P($G(^PS(55,PSJHLDFN,5,+ORDER,0)),"^",23) I +WARD D - .S WARD=$O(^PS(59.6,"B",WARD,0)) Q:+WARD=0 - .Q:$$SNDTSTW^PSJHL4A(PRIO,PSJSCHED,WARD) - .S WDPARM=$G(^PS(59.6,+WARD,0)),MGRP=$P(WDPARM,"^",30) Q:+MGRP=0 - .S MGRP=$$GET1^DIQ(3.8,MGRP,.01) I MGRP]"" S XMY("G."_MGRP_"@"_$G(^XMB("NETNAME")))="",PSJSOK=0 - S:'$$SNDTSTA^PSJHL4A(PRIO,PSJSCHED) MGROUP="G.PSJ STAT NOW ACTIVE ORDER@"_$G(^XMB("NETNAME")),XMY(MGROUP)="",PSJSOK=0 - S NTFSTAT="ACTIVE" - N ND2,ND0 S ND0=$G(^PS(55,PSJHLDFN,5,+ORDER,0)),ND2=$G(^PS(55,PSJHLDFN,5,+ORDER,2)),NDP2=$G(^PS(55,PSJHLDFN,5,+ORDER,.2)) - S DRIEN=+$P(NDP2,"^"),DO=$P(NDP2,"^",2),RTE=$P(ND0,"^",3),ORDATE=$P(ND0,"^",14) - S SCHED=$P(ND2,"^") - Q -IV ; IV - N WARD,WDPARM,MGRP - Q:'$D(^PS(55,PSJHLDFN,"IV",+ORDER,0)) - S WARD=$P($G(^PS(55,PSJHLDFN,"IV",+ORDER,0)),"^",22) I +WARD D - .S WARD=$O(^PS(59.6,"B",WARD,0)) Q:+WARD=0 - .Q:$$SNDTSTW^PSJHL4A(PRIO,PSJSCHED,WARD) - .S WDPARM=$G(^PS(59.6,+WARD,0)),MGRP=$P(WDPARM,"^",30) Q:+MGRP=0 - .S MGRP=$$GET1^DIQ(3.8,MGRP,.01) I MGRP]"" S XMY("G."_MGRP_"@"_$G(^XMB("NETNAME")))="",PSJSOK=0 - S:'$$SNDTSTA^PSJHL4A(PRIO,PSJSCHED) MGROUP="G.PSJ STAT NOW ACTIVE ORDER@"_$G(^XMB("NETNAME")),XMY(MGROUP)="",PSJSOK=0 - S NTFSTAT="ACTIVE" - N ND2,NDP2,ND0 S ND0=$G(^PS(55,PSJHLDFN,"IV",+ORDER,0)),ND2=$G(^PS(55,PSJHLDFN,"IV",+ORDER,2)) - S NDP2=$G(^PS(55,PSJHLDFN,"IV",+ORDER,.2)) - S DRIEN=$P(NDP2,"^"),DO=$P(NDP2,"^",2),RTE=$P(NDP2,"^",3) - S ORDATE=$P(ND2,"^"),SCHED=$P(ND0,"^",9) - Q -MSH ; Header - S PSOC=FIELD(8) - Q -PID ; ID - S PSJHLDFN=$$UNESC^ORHLESC(FIELD(3)) - Q -PV1 ; Visit - N A - S CLASS=FIELD(2),LOC=$P(FIELD(3),"^"),APPT="" I $G(FIELD(44))]"" S APPT=+$$HL7TFM^XLFDT(FIELD(44)) - I "IO"'[CLASS S PSREASON="Invalid patient class" Q - N QQ K PSJNVA S QQ=II F S QQ=$O(PSJMSG(QQ)) Q:'QQ D Q:$G(PSJNVA) - .S X=$G(PSJMSG(QQ)) - .I $P(X,"|")="ZRN" S PSJNVA=1,CLASS="O" D EN^PSOHLNEW(.PSJMSG) - I $G(PSJNVA) K PSJNVA Q - I CLASS="O" N QQ S QQ=II F S QQ=$O(PSJMSG(QQ)) Q:'QQ I $P(PSJMSG(QQ),"|")="OBR" D Q:$P(PSJMSG(QQ),"|")="OBR" - .S RXON=$P(PSJMSG(QQ),"|",4) I RXON]"" S RXON=$P(RXON,"^") I "ABNPUV"[$E(RXON,$L(RXON)) S CLASS="I" - I CLASS="O" N QQ S QQ=II F S QQ=$O(PSJMSG(QQ)) Q:'QQ I $P(PSJMSG(QQ),"|")="ORC" D Q:$P(PSJMSG(QQ),"|")="ORC" - .S RXON=$P(PSJMSG(QQ),"|",4) I RXON]"" S RXON=$P(RXON,"^") I "ABNPUV"[$E(RXON,$L(RXON)) S CLASS="I" - I CLASS="O" N CHK,QQ S QQ=II F S QQ=$O(PSJMSG(QQ)) Q:'QQ I $P(PSJMSG(QQ),"|")="RXO" D Q:$P(PSJMSG(QQ),"|")="RXO" - .S CHK=$P(PSJMSG(QQ),"|",2),CHK=$S($P(CHK,"^",5)="IV":"IV",1:$P(CHK,"^",4)) - .I CHK="IV" S CLASS="I" Q - .I 'CHK S PSREASON="Missing or Invalid Orderable Item",CLASS="I" Q - .I $P($G(^PS(50.7,CHK,0)),"^",3)=1 S CLASS="I" Q - D:CLASS="O" EN^PSOHLNEW(.PSJMSG) - Q -ORC ; Order - S TMPAT="" - S PSOC=FIELD(1) - S ORDER=FIELD(2) - I $G(PSREASON)]"" D ERROR^PSJHL9 Q - S PSJORDER=$P(FIELD(2),"^"),RXON=$P(FIELD(3),"^"),RXORDER=$S((RXON["N")!(RXON["P"):"^PS(53.1,"_+RXON_",",RXON["V":"^PS(55,"_PSJHLDFN_",""IV"","_+RXON_",",1:"^PS(55,"_PSJHLDFN_",5,"_+RXON_",") - I PSOC="NA" D ASSIGN^PSJHL5 Q - S CLERK=+$G(FIELD(10)) - S PROVIDER=+$G(FIELD(12)) D:PSOC="NW" - .I PROVIDER=0 S PSREASON="Invalid Provider" D ERROR^PSJHL9 Q - .I PROVIDER>0 S PSPR=$G(^VA(200,+PROVIDER,"PS")) I '$D(PSPR)!'(PSPR)!$S($P(PSPR,"^",4)="":0,1:$P(PSPR,"^",4)'>DT) S PSREASON="Invalid Provider" D ERROR^PSJHL9 Q - S UNITS=$P(FIELD(7),"^"),INSTR=$$UNESC^ORHLESC($P(FIELD(7),"^",8)) - S:UNITS["&" DOSE=$P(UNITS,"&"),UNIT=$P(UNITS,"&",2),UNITS=$P(UNITS,"&",3) S:UNITS]"" UNITS=$$UNESC^ORHLESC(UNITS) S:$G(DOSE)]"" DOSE=$$UNESC^ORHLESC(DOSE) - S SCHEDULE=$P(FIELD(7),"^",2),PRIORITY=$P(FIELD(7),"^",6) S:SCHEDULE["PRN" SCHTYP="P" - I SCHEDULE["&" S ADMINS=$P(SCHEDULE,"&",2),SCHEDULE=$P(SCHEDULE,"&") S ADMINS=$TR(ADMINS," ","") S ADMINS=$S(ADMINS:ADMINS,1:"") - S SCHEDULE=$$UNESC^ORHLESC(SCHEDULE) - I SCHEDULE["@" S TMPAT=$$TMPAT^PSJHL4A(SCHEDULE) - I $G(TMPAT) S $P(SCHEDULE,"@",2)=TMPAT,ADMINS=TMPAT - S DURATION=$P(FIELD(7),"^",3),REQST=$P(FIELD(7),"^",4) S:REQST'="" REQST=+$E(+$$HL7TFM^XLFDT(REQST),1,12) S REQST=$$DATE2^PSJUTL2(REQST) - S PRIORITY=$S($G(PRIORITY)]"":PRIORITY,1:"R") - I $E(SCHEDULE,1)=" " S:$TR(SCHEDULE," ")="PRN" SCHEDULE="PRN" I '(SCHEDULE="PRN") S PSREASON="Invalid Schedule" D ERROR^PSJHL9 Q - S SCHTYP=$P(FIELD(7),"^",7) - I $G(SCHTYP)="D" S SCHTYP="C" ;Makes CPRS Day of Week consistent in behavior with backdoor order of Day of Week - S PRNTON=$P(FIELD(8),"^") - S NURSEACK=$G(FIELD(11)) - S LOGIN=$G(FIELD(15)) S:LOGIN'="" LOGIN=+$E(+$$HL7TFM^XLFDT(FIELD(15)),1,12) S LOGIN=$$DATE2^PSJUTL2(LOGIN) - S:$G(NURSEACK)]"" ACKDATE=LOGIN - S ORDCON=$P($G(FIELD(16)),U) I ORDCON="A" S PSJASTP=$G(FIELD(9)) S:$G(PSJASTP)'="" PSJASTP=+$E(+$$HL7TFM^XLFDT(PSJASTP),1,12) S PSJASTP=$$DATE2^PSJUTL2(PSJASTP) - I (PSOC="CA")!(PSOC="DC") D CANCEL^PSJHL6 Q - I PSOC="HD" D HOLD^PSJHL6 Q - I PSOC="RL" D UNHOLD^PSJHL6 Q - I PSOC="ZV" D NURSEACK^PSJHL5 Q - I PSOC="SS" D STATUS^PSJHL5 Q - I PSOC="Z@" N X S X="PSJHL8" X ^%ZOSF("TEST") I D PURGE^PSJHL8 Q - I PSOC="DE" S QFLG=1 Q - Q -OBR ; Flagging from CPRS. - S ORDER=FIELD(2) - S PSJORDER=$P(FIELD(2),"^"),RXON=$P(FIELD(3),"^"),RXORDER=$S((RXON["N")!(RXON["P"):"^PS(53.1,"_+RXON_",",RXON["V":"^PS(55,"_PSJHLDFN_",""IV"","_+RXON_",",1:"^PS(55,"_PSJHLDFN_",5,"_+RXON_",") - S PSJFLAG=FIELD(4) - S FLDATE=$G(FIELD(7)) S:FLDATE'="" FLDATE=+$E(+$$HL7TFM^XLFDT(FIELD(7)),1,12) S FLDATE=$$DATE2^PSJUTL2(FLDATE) - S CLERK=+$G(FIELD(16)) - S PSJYN=$G(FIELD(24)) - S FLCMNT=$$UNESC^ORHLESC($G(FIELD(13))) - I PSOC="ORU" D FLAG^PSJHL5 - Q -RXC ; IV - D RXC^PSJHL4A - Q -RXO ; OP - D RXO^PSJHL4A - Q -RXR ; Route - S ROUTE=$P(FIELD(1),"^",4) - Q -OBX ; Obs. - D OBX^PSJHL4A - Q -NTE ; Note - D NTE^PSJHL4A - Q -ZRX ; Custom - D ZRX^PSJHL4A - Q -ZSC ;Service Connected - Not Used - Q -ZRN ;Non-VA Med (Herbal/OTC) - S CLASS="O" D EN^PSOHLNEW(.PSJMSG) - Q -DG1 ;Billing Awareness - Not used - Q +PSJHL4 ;BIR/RLW-DECODE HL7 /MESSSAGE FROM OE/RR ;16 Mar 99 / 4:55 PM + ;;5.0; INPATIENT MEDICATIONS ;**1,12,27,34,40,42,55,47,50,56,58,98,85,105,107,110,111,154**;16 DEC 97 + ; + ; Reference to $$EN^PSOHLNEW is supported by DBIA# 2188. + ; Reference to ^PS(50.7 is supported by DBIA# 2180. + ; Reference to ^PS(51.2 is supported by DBIA# 2178. + ; Reference to ^PS(55 is supported by DBIA# 2191. + ; Reference to ^PS(59.7 supported by DBIA #2181. + ; +EN(PSJMSG) ; start here + K ^TMP("PSJNVO",$J) + N ADCNT,SOLCNT,OCCNT + N ACKDATE,ADDITIVE,ADMINSTR,APPL,COMMENT,PSJHLDFN,DISPENSE,DOSE,DURATION,II,INSTR,J,JJ,JJJ,K,LOGIN,NEWORDER,NURSEACK,OBXFL,OCNARR,OCPROV,OCRSN,ORDER,PRIORITY,PSITEM,ORDCON,PROCOM,PSJORDER,PSREASON + N LOC,PROVIDER,PSPR,PSOC,PTR,QQ,REQST,ROUTE,RXON,RXORDER,SCHEDULE,SEGMENT,SOLUTION,STPDT,STRENGTH,TEXT,CLERK,INFRT,IVTYP,SCHTYP,PREON,NOO,ROC,FREQ,CLASS,PSJHLMTN,UNIT,UNITS,QFLG,VOLUME,TVOLUME,PSGP + N PSJASTP,FLDATE,FLCMNT,PSJFLAG,PSJYN,PRNTON,APPT,IVLIMIT + S (ADCNT,SOLCNT,OCCNT,II,TVOLUME)="",(OBXFL,QFLG)=0,PSJHLMTN="ORR" F S II=$O(PSJMSG(II)) Q:'II D DECODE Q:QFLG D @FIELD(0) Q:$G(CLASS)="O" Q:QFLG + I ($G(CLASS)'="I")!(QFLG) G END + I ($G(PSOC)="NW")!($G(PSOC)="XO") N DIK,DA S DIK="^PS(53.1,",DA=NEWORDER D EN1^DIK L -^PS(53.1,NEWORDER) + I ($G(PSOC)="NW")!($G(PSOC)="XO") D EN1^PSJHL2(PSJHLDFN,$S(PSOC="NW":"OK",1:"XR"),NEWORDER_"P") +END ; + K ^TMP("PSJNVO",$J) + I (",S,A,")[(","_$G(PRIORITY)_",")!($G(SCHEDULE)="NOW")!($G(SCHEDULE)["STAT") D + . I $G(PRIORITY)="ZD",$G(PSGORD) D NOTIFY(PSGORD_$S(PSGORD["V":"V",PSGORD["U":"U",1:""),PSJHLDFN,$G(PRIORITY),$G(SCHEDULE)) + . I $G(NEWORDER) D NOTIFY(NEWORDER_"P",PSJHLDFN,$G(PRIORITY),$G(SCHEDULE)) + Q + ; +DECODE ;break segment down into fields + K FIELD + S SEGMENT=$G(PSJMSG(II)) + S J=0 + F Q:$G(SEGMENT)="" D + .;get fields from segment + .I SEGMENT["|" S FIELD(J)=$P(SEGMENT,"|"),SEGMENT=$E(SEGMENT,$L(FIELD(J))+2,$L(SEGMENT)),J=J+1 Q + .I SEGMENT'["|" S FIELD(J)=SEGMENT,SEGMENT="" Q + Q + ; +NOTIFY(ORDER,PSJHLDFN,PRIO,PSJSCHED) ; + N NTFYREAS,WARD,MGROUP,NTFSTAT,DRUG,DRIEN,PNAME,ORDATE,DO,PSG,XMY,VADPT,LASTFOUR,PSJSOK + Q:($G(PRIO)=""&($G(PSJSCHED)="")) + S DFN=PSJHLDFN D DEM^VADPT S LASTFOUR=$P($P(VADM(2),"^",2),"-",3) + S NTFYREAS=$S((",S,A,")[(","_PRIO_","):1,($G(PSJSCHED)="NOW"):2,($G(PSJSCHED)="STAT"):3,1:0) Q:'NTFYREAS + S PSJSOK=1 + I ORDER["P" D PND + I ORDER["U" D UD + I ORDER["V" D IV + Q:PSJSOK=1 + S PNAME=$P($G(^DPT(+PSJHLDFN,0)),"^") S:$G(RTE) RTE=$P(^PS(51.2,+RTE,0),"^",3) + S DRUG=$S(DRIEN:$P($G(^PS(50.7,+DRIEN,0)),"^"),1:""),WARD=$G(^DPT(PSJHLDFN,.1)) + S XMDUZ="MEDICATIONS,INPATIENT",XMSUB=$G(WARD) + S XMSUB=XMSUB_"-"_NTFSTAT_" "_$S($G(PRIO)="A":"ASAP",$G(PRIO)="S":"STAT",$G(NTFYREAS)=2:"NOW",$G(NTFYREAS)=3:"STAT",1:"")_"-" + S XMSUB=XMSUB_$E(PNAME,1,65-$L(XMSUB)) + S XMTEXT="PSG(" + S PSG(1,0)="Inpatient Medications has received the following "_$S($G(PRIO)="A":"ASAP",$G(PRIO)="S":"STAT",$G(NTFYREAS)=2:"NOW",1:"")_" order ("_NTFSTAT_")" + S PSG(2,0)="" + S PSG(3,0)=" Patient: "_PNAME I $G(LASTFOUR) S PSG(3,0)=PSG(3,0)_" ("_LASTFOUR_")" + S PSG(4,0)="Order Information: "_DRUG_" "_DO_" "_RTE_" "_$G(PSJSCHED) + S PSG(5,0)=" Order Date: "_$$ENDTC^PSGMI(ORDATE) + D ^XMD + Q + ; +PND ; + N WARD,WDPARM,MGRP + Q:'$D(^PS(53.1,+ORDER,0)) + S WARD=$G(^DPT(PSJHLDFN,.1)) I WARD]"" D + .N DIC,X,Y S DIC="^DIC(42,",DIC(0)="BOXZ",X=WARD D ^DIC S WARD=+Y Q:WARD=0 + .S WARD=$O(^PS(59.6,"B",WARD,0)) Q:+WARD=0 + .Q:$$SNDTSTW^PSJHL4A(PRIO,PSJSCHED,WARD) + .S WDPARM=$G(^PS(59.6,+WARD,0)),MGRP=$P(WDPARM,"^",30) Q:+MGRP=0 + .S MGRP=$$GET1^DIQ(3.8,MGRP,.01) I MGRP]"" S XMY("G."_MGRP_"@"_$G(^XMB("NETNAME")))="",PSJSOK=0 + S:'$$SNDTSTP^PSJHL4A(PRIO,PSJSCHED) MGROUP="G.PSJ STAT NOW PENDING ORDER@"_$G(^XMB("NETNAME")),XMY(MGROUP)="",PSJSOK=0 + S NTFSTAT="PENDING" + N NDP2,ND0 S NDP2=$G(^PS(53.1,+ORDER,.2)),ND0=$G(^PS(53.1,+ORDER,0)) + S DRIEN=+$P(NDP2,"^"),DO=$P(NDP2,"^",2),RTE=$P(ND0,"^",3),ORDATE=$P(ND0,"^",14) + S SCHED=$P($G(^PS(53.1,+ORDER,2)),"^") + Q + ; +UD ; + N WARD,WDPARM,MGRP + Q:'$D(^PS(55,PSJHLDFN,5,+ORDER,0)) + S WARD=$P($G(^PS(55,PSJHLDFN,5,+ORDER,0)),"^",23) I +WARD D + .S WARD=$O(^PS(59.6,"B",WARD,0)) Q:+WARD=0 + .Q:$$SNDTSTW^PSJHL4A(PRIO,PSJSCHED,WARD) + .S WDPARM=$G(^PS(59.6,+WARD,0)),MGRP=$P(WDPARM,"^",30) Q:+MGRP=0 + .S MGRP=$$GET1^DIQ(3.8,MGRP,.01) I MGRP]"" S XMY("G."_MGRP_"@"_$G(^XMB("NETNAME")))="",PSJSOK=0 + S:'$$SNDTSTA^PSJHL4A(PRIO,PSJSCHED) MGROUP="G.PSJ STAT NOW ACTIVE ORDER@"_$G(^XMB("NETNAME")),XMY(MGROUP)="",PSJSOK=0 + S NTFSTAT="ACTIVE" + N ND2,ND0 S ND0=$G(^PS(55,PSJHLDFN,5,+ORDER,0)),ND2=$G(^PS(55,PSJHLDFN,5,+ORDER,2)),NDP2=$G(^PS(55,PSJHLDFN,5,+ORDER,.2)) + S DRIEN=+$P(NDP2,"^"),DO=$P(NDP2,"^",2),RTE=$P(ND0,"^",3),ORDATE=$P(ND0,"^",14) + S SCHED=$P(ND2,"^") + Q + ; +IV ; + N WARD,WDPARM,MGRP + Q:'$D(^PS(55,PSJHLDFN,"IV",+ORDER,0)) + S WARD=$P($G(^PS(55,PSJHLDFN,"IV",+ORDER,0)),"^",22) I +WARD D + .S WARD=$O(^PS(59.6,"B",WARD,0)) Q:+WARD=0 + .Q:$$SNDTSTW^PSJHL4A(PRIO,PSJSCHED,WARD) + .S WDPARM=$G(^PS(59.6,+WARD,0)),MGRP=$P(WDPARM,"^",30) Q:+MGRP=0 + .S MGRP=$$GET1^DIQ(3.8,MGRP,.01) I MGRP]"" S XMY("G."_MGRP_"@"_$G(^XMB("NETNAME")))="",PSJSOK=0 + S:'$$SNDTSTA^PSJHL4A(PRIO,PSJSCHED) MGROUP="G.PSJ STAT NOW ACTIVE ORDER@"_$G(^XMB("NETNAME")),XMY(MGROUP)="",PSJSOK=0 + S NTFSTAT="ACTIVE" + N ND2,NDP2,ND0 S ND0=$G(^PS(55,PSJHLDFN,"IV",+ORDER,0)),ND2=$G(^PS(55,PSJHLDFN,"IV",+ORDER,2)) + S NDP2=$G(^PS(55,PSJHLDFN,"IV",+ORDER,.2)) + S DRIEN=$P(NDP2,"^"),DO=$P(NDP2,"^",2),RTE=$P(NDP2,"^",3) + S ORDATE=$P(ND2,"^"),SCHED=$P(ND0,"^",9) + Q + ; +MSH ; + S PSOC=FIELD(8) + Q + ; +PID ; + S PSJHLDFN=FIELD(3) + Q + ; +PV1 ; + N A + S CLASS=FIELD(2),LOC=$P(FIELD(3),"^"),APPT="" I $G(FIELD(44))]"" S APPT=+$$HL7TFM^XLFDT(FIELD(44)) + I "IO"'[CLASS S PSREASON="Invalid patient class" Q + ;N II K PSJNVA S II="" F S II=$O(PSJMSG(II)) Q:'II D Q:CLASS="O" + N QQ K PSJNVA S QQ=II F S QQ=$O(PSJMSG(QQ)) Q:'QQ D Q:$G(PSJNVA) + .S X=$G(PSJMSG(QQ)) + .I $P(X,"|")="ZRN" S PSJNVA=1,CLASS="O" D EN^PSOHLNEW(.PSJMSG) + .;I $P(X,"|")="ZRN" S PSJNVA=1 D EN^PSOHLNEW(.PSJMSG) + ; OBR check - enable outpatient flagging from backdoor + I $G(PSJNVA) K PSJNVA Q + I CLASS="O" N QQ S QQ=II F S QQ=$O(PSJMSG(QQ)) Q:'QQ I $P(PSJMSG(QQ),"|")="OBR" D Q:$P(PSJMSG(QQ),"|")="OBR" + .S RXON=$P(PSJMSG(QQ),"|",4) I RXON]"" S RXON=$P(RXON,"^") I "ABNPUV"[$E(RXON,$L(RXON)) S CLASS="I" + I CLASS="O" N QQ S QQ=II F S QQ=$O(PSJMSG(QQ)) Q:'QQ I $P(PSJMSG(QQ),"|")="ORC" D Q:$P(PSJMSG(QQ),"|")="ORC" + .S RXON=$P(PSJMSG(QQ),"|",4) I RXON]"" S RXON=$P(RXON,"^") I "ABNPUV"[$E(RXON,$L(RXON)) S CLASS="I" + I CLASS="O" N CHK,QQ S QQ=II F S QQ=$O(PSJMSG(QQ)) Q:'QQ I $P(PSJMSG(QQ),"|")="RXO" D Q:$P(PSJMSG(QQ),"|")="RXO" + .S CHK=$P(PSJMSG(QQ),"|",2),CHK=$S($P(CHK,"^",5)="IV":"IV",1:$P(CHK,"^",4)) + .I CHK="IV" S CLASS="I" Q + .I 'CHK S PSREASON="Missing or Invalid Orderable Item",CLASS="I" Q + .I $P($G(^PS(50.7,CHK,0)),"^",3)=1 S CLASS="I" Q + D:CLASS="O" EN^PSOHLNEW(.PSJMSG) + Q + ; +ORC ; + S PSOC=FIELD(1) + S ORDER=FIELD(2) + I $G(PSREASON)]"" D ERROR^PSJHL9 Q + S PSJORDER=$P(FIELD(2),"^"),RXON=$P(FIELD(3),"^"),RXORDER=$S((RXON["N")!(RXON["P"):"^PS(53.1,"_+RXON_",",RXON["V":"^PS(55,"_PSJHLDFN_",""IV"","_+RXON_",",1:"^PS(55,"_PSJHLDFN_",5,"_+RXON_",") + I PSOC="NA" D ASSIGN^PSJHL5 Q + S CLERK=+$G(FIELD(10)) + S PROVIDER=+$G(FIELD(12)) D:PSOC="NW" + .I PROVIDER=0 S PSREASON="Invalid Provider" D ERROR^PSJHL9 Q + .I PROVIDER>0 S PSPR=$G(^VA(200,+PROVIDER,"PS")) I '$D(PSPR)!'(PSPR)!$S($P(PSPR,"^",4)="":0,1:$P(PSPR,"^",4)'>DT) S PSREASON="Invalid Provider" D ERROR^PSJHL9 Q + S UNITS=$P(FIELD(7),"^"),INSTR=$P(FIELD(7),"^",8) + S:UNITS["&" DOSE=$P(UNITS,"&"),UNIT=$P(UNITS,"&",2),UNITS=$P(UNITS,"&",3) + S SCHEDULE=$P(FIELD(7),"^",2),PRIORITY=$P(FIELD(7),"^",6) S:SCHEDULE["PRN" SCHTYP="P" + S DURATION=$P(FIELD(7),"^",3),REQST=$P(FIELD(7),"^",4) S:REQST'="" REQST=+$E(+$$HL7TFM^XLFDT(REQST),1,12) S REQST=$$DATE2^PSJUTL2(REQST) + S PRIORITY=$S($G(PRIORITY)]"":PRIORITY,1:"R") + I $E(SCHEDULE,1)=" " S:$TR(SCHEDULE," ")="PRN" SCHEDULE="PRN" I '(SCHEDULE="PRN") S PSREASON="Invalid Schedule" D ERROR^PSJHL9 Q + S PRNTON=$P(FIELD(8),"^") + S NURSEACK=$G(FIELD(11)) + S LOGIN=$G(FIELD(15)) S:LOGIN'="" LOGIN=+$E(+$$HL7TFM^XLFDT(FIELD(15)),1,12) S LOGIN=$$DATE2^PSJUTL2(LOGIN) + S:$G(NURSEACK)]"" ACKDATE=LOGIN + S ORDCON=$P($G(FIELD(16)),U) I ORDCON="A" S PSJASTP=$G(FIELD(9)) S:$G(PSJASTP)'="" PSJASTP=+$E(+$$HL7TFM^XLFDT(PSJASTP),1,12) S PSJASTP=$$DATE2^PSJUTL2(PSJASTP) + I (PSOC="CA")!(PSOC="DC") D CANCEL^PSJHL6 Q + I PSOC="HD" D HOLD^PSJHL6 Q + I PSOC="RL" D UNHOLD^PSJHL6 Q + I PSOC="ZV" D NURSEACK^PSJHL5 Q + I PSOC="SS" D STATUS^PSJHL5 Q + I PSOC="Z@" N X S X="PSJHL8" X ^%ZOSF("TEST") I D PURGE^PSJHL8 Q + I PSOC="DE" S QFLG=1 Q + Q +OBR ; This segment is used to pass flagging information from CPRS. + S ORDER=FIELD(2) + S PSJORDER=$P(FIELD(2),"^"),RXON=$P(FIELD(3),"^"),RXORDER=$S((RXON["N")!(RXON["P"):"^PS(53.1,"_+RXON_",",RXON["V":"^PS(55,"_PSJHLDFN_",""IV"","_+RXON_",",1:"^PS(55,"_PSJHLDFN_",5,"_+RXON_",") + S PSJFLAG=FIELD(4) + S FLDATE=$G(FIELD(7)) S:FLDATE'="" FLDATE=+$E(+$$HL7TFM^XLFDT(FIELD(7)),1,12) S FLDATE=$$DATE2^PSJUTL2(FLDATE) + S CLERK=+$G(FIELD(16)) + S PSJYN=$G(FIELD(24)) + S FLCMNT=$G(FIELD(13)) + I PSOC="ORU" D FLAG^PSJHL5 + Q +RXC ; IV order + D RXC^PSJHL4A + Q + ; +RXO ; + D RXO^PSJHL4A + Q + ; +RXR ; + S ROUTE=$P(FIELD(1),"^",4) + Q + ; +OBX ; + D OBX^PSJHL4A + Q + ; +NTE ; + D NTE^PSJHL4A + Q + ; +ZRX ; + D ZRX^PSJHL4A + Q + ; +ZSC ;Service Connected - Not Used by Inpatient + Q + ; +ZRN ;Non-VA Med (Herbal/OTC) + S CLASS="O" D EN^PSOHLNEW(.PSJMSG) + Q +DG1 ;Billing Awareness - Not used by Inpatient + Q diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL4A.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL4A.m index a824cabe..1e1968fb 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL4A.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL4A.m @@ -1,160 +1,121 @@ -PSJHL4A ;BIR/RLW-CONTINUE DECODE HL7 /MESSSAGE FROM OE/RR ;16 Mar 99 / 4:55 PM - ;;5.0; INPATIENT MEDICATIONS ;**105,111,154,170,159,134**;16 DEC 97;Build 124 - ; - ; Reference to ^PS(52.6 is supported by DBIA# 1231. - ; Reference to ^PS(52.7 is supported by DBIA# 2173. - ; Reference to ^PS(55 is supported by DBIA# 2191. - ; Reference to ^PS(59.7 supported by DBIA #2181. - ; Reference to ^ORHLESC is supported by DBIA# 4922. - ; Reference to ^SC( is supported by DBIA# 10040. - ; Reference to ^PS(51.1 is supported by DBIA# 2177. - ; Reference to ^PS(50.7 is supported by DBIA #2180. - ; Reference to ^PS(51.2 is supported by DBIA 2178. - ; -RXC ; IV order - N IVFL - S APPL=FIELD(1) - I APPL["B" S SOLCNT=SOLCNT+1,PTR=$P(FIELD(2),"^",4) Q:'PTR S VOLUME=+FIELD(3)_" ML" D I '$D(^TMP("PSJNVO",$J,"SOL",SOLCNT,0)) D SOLSRCH - .S SOLUTION="" F S SOLUTION=$O(^PS(52.7,"AOI",PTR,SOLUTION)) Q:'SOLUTION S INACT=$G(^PS(52.7,SOLUTION,"I")) I 'INACT!(INACT>DT) I VOLUME=$P(^PS(52.7,SOLUTION,0),U,3) D - ..S ^TMP("PSJNVO",$J,"SOL",0)=SOLCNT - ..S ^TMP("PSJNVO",$J,"SOL",SOLCNT,0)=SOLUTION_"^"_VOLUME,TVOLUME=TVOLUME+(+VOLUME) - I $G(INFRT)]"" S X=INFRT D ENI^PSJHLU S INFRT=$G(X) - I APPL="A" S ADCNT=ADCNT+1,PTR=$P(FIELD(2),"^",4) Q:'PTR S STRENGTH=$G(FIELD(3))_" "_$P($G(FIELD(4)),"^",5) D I '$D(^TMP("PSJNVO",$J,"AD",ADCNT,0)) S PSREASON="Can't find matching additive" D ERROR^PSJHL9 Q - .S ADDITIVE="" F S ADDITIVE=$O(^PS(52.6,"AOI",PTR,ADDITIVE)) Q:'ADDITIVE S INACT=$G(^PS(52.6,ADDITIVE,"I")),IVFL=$P($G(^(0)),"^",13) I 'INACT!(INACT>DT),IVFL'=0 Q:$G(^PS(52.6,ADDITIVE,0))']"" D Q:ADDITIVE - ..I $G(PSITEM)="" S PSITEM=PTR - ..S ^TMP("PSJNVO",$J,"AD",0)=ADCNT - ..S ^TMP("PSJNVO",$J,"AD",ADCNT,0)=ADDITIVE_"^"_STRENGTH - Q - ; -RXO ; - I $O(PSJMSG(II,0)) D - .K SEGMENT - .N KK,JJ,XX - .S SEGMENT(1)=$G(PSJMSG(II)) - .S KK=1,JJ="" F S JJ=$O(PSJMSG(II,JJ)) Q:'JJ S KK=KK+1,SEGMENT(KK)=$G(PSJMSG(II,JJ)) - .S KK=1,JJ=0 - .F Q:'$D(SEGMENT(KK)) D - ..I SEGMENT(KK)["|" S FIELD(JJ)=$P(SEGMENT(KK),"|"),SEGMENT(KK)=$E(SEGMENT(KK),$L(FIELD(JJ))+2,$L(SEGMENT(KK))),JJ=JJ+1 Q - ..I SEGMENT(KK)'["|" S FIELD(JJ)=SEGMENT(KK),KK=KK+1 Q:'$D(SEGMENT(KK)) D - ...S XX=$P(SEGMENT(KK),"|"),SEGMENT(KK)=$E(SEGMENT(KK),$L(X)+2,$L(SEGMENT(KK))),FIELD(JJ)=FIELD(JJ)_XX,JJ=JJ+1 - S APPL="",PSITEM=$S($P(FIELD(1),"^",5)="IV":"",1:$P(FIELD(1),"^",4)) - S:$P(FIELD(1),"^",6)="ORD" PSITEM="" - S:$P(FIELD(1),"^",5)="IV" IVTYP="A",SCHTYP="C",INFRT=$G(FIELD(2)) - S DISPENSE=$P($G(FIELD(10)),"^",4) - S IVLIMIT=$P($G(PSJMSG(II)),"^",3) - S:IVLIMIT["doses" IVLIMIT=$TR(IVLIMIT,"doses","a") - Q - ; -OBX ; - S OBXFL=1,OCNARR=FIELD(5),OCPROV=CLERK,OCCNT=OCCNT+1 - S ^TMP("PSJNVO",$J,10,0)=OCCNT - S ^TMP("PSJNVO",$J,10,OCCNT,0)=OCNARR - S ^TMP("PSJNVO",$J,10,OCCNT,1)=$$UNESC^ORHLESC($P($G(^VA(200,+OCPROV,0)),"^")) - Q - ; -NTE ; - S TEXT=$S((FIELD(1)=6)&('OBXFL):"PROCOM",(FIELD(1)=7)&('OBXFL):"ADMINSTR",1:"OCRSN") - S @TEXT@(1)=$$UNESC^ORHLESC($G(FIELD(3))) - S K=1,J="" F S J=$O(PSJMSG(II,J)) Q:'J S K=K+1,@TEXT@(K)=$G(PSJMSG(II,J)) - D:$D(OCRSN) - .S QQ=0 F S QQ=$O(OCRSN(QQ)) Q:'QQ S ^TMP("PSJNVO",$J,10,OCCNT,2,QQ,0)=OCRSN(QQ) - S OBXFL=0 - Q - ; -ZRX ; - N ND,ND2,CHK,FOLOR,STDT - S PREON=$G(FIELD(1)),ROC=$G(FIELD(3)),IVCAT=$G(FIELD(6)) - S IVCAT=$S(",I,C,"[(","_IVCAT_","):IVCAT,1:"") I 'PREON S IVTYP=$S($G(PSGS0XT):"P",1:"A") S IVTYP=$S(IVCAT="I":"P",IVCAT="C":"A",1:$G(IVTYP)) - S ND=$S((PREON["N")!(PREON["P"):$G(^PS(53.1,+PREON,0)),PREON["V":$G(^PS(55,PSJHLDFN,"IV",+PREON,0)),1:$G(^PS(55,PSJHLDFN,5,+PREON,0))) - S ND2=$S((PREON["N")!(PREON["P"):$G(^PS(53.1,+PREON,2)),PREON["V":$G(^PS(55,PSJHLDFN,"IV",+PREON,2)),1:$G(^PS(55,PSJHLDFN,5,+PREON,2))) - I 'ND I ROC'="N" S PSREASON="Invalid Pharmacy order number" D ERROR^PSJHL9 Q - I ND I ROC="R" S FOLOR=$S(PREON["V":$P(ND2,U,6),1:$P(ND,U,26)) I FOLOR S PSREASON="Duplicate Renewal Request" D ERROR^PSJHL9 Q - I ND I ROC="R" S CHK=$S(PREON["V":$P(ND,U,17),1:$P(ND,U,9)) I "AE"'[CHK S PSREASON="Pharmacy orders with a status of "_CHK_" may not be renewed" D ERROR^PSJHL9 Q - I $G(CHK)="E" I PREON'["V" D NOW^%DTC S X1=+$E(%,1,12),X2=-4 D C^%DTC S STDT=$S(PREON["V":$P(ND,U,3),1:$P(ND2,U,4)) I STDT'>X S PSREASON="Pharmacy orders expired longer than 4 days may not be renewed" D ERROR^PSJHL9 Q - I ND I ROC="E" S FOLOR=$S(PREON["V":$P(ND2,U,6),1:$P(ND,U,26)) I FOLOR S PSREASON="Pharmacy orders may only be edited ONCE" D ERROR^PSJHL9 Q - I ND I ROC="E" S CHK=$S(PREON["V":$P(ND,U,17),1:$P(ND,U,9)) I "DEHO"[CHK N CHKRTN S CHKRTN=CHK_"^PSJHL6" D @CHKRTN S PSREASON=PSREASON_" orders may not be edited" D ERROR^PSJHL9 Q - D:ROC'="R" VALID^PSJHL9 Q:QFLG - I $G(PSITEM)="",$D(^TMP("PSJNVO",$J,"SOL",1,0)) S PSITEM=$P($G(^PS(52.7,+^TMP("PSJNVO",$J,"SOL",1,0),0)),"^",11) - I PRIORITY="ZD" D VALID^PSJHL10 S QFLG=1 Q - I (PREON]"")&(ROC="E") D EDITCK^PSJHL5 Q:QFLG - D NVO^PSJHL9 - I (PREON]"")&(ROC="R") D RENEW^PSJHL7 Q - I (PREON]"")&(ROC="E") D EDIT^PSJHL5 - Q - ; -SOLSRCH ;Find solution - N SSSS,SEG,ON,ROC,SOL,SOL2 - F SSSS=II:0 S SSSS=$O(PSJMSG(SSSS)) Q:'SSSS I $P(PSJMSG(SSSS),"|")="ZRX" D Q - .S SEG=$G(PSJMSG(SSSS)),ON=$P(SEG,"|",2),ROC=$P(SEG,"|",4) - I $G(ROC)'="N" F SOL=0:0 S SOL=$O(^PS(55,PSJHLDFN,"IV",+ON,"SOL",SOL)) Q:'SOL S SOL2=$G(^PS(55,PSJHLDFN,"IV",+ON,"SOL",SOL,0)) I $D(^PS(52.7,"AOI",PTR,+SOL2))&($P(SOL2,U,2)=VOLUME) S SOLUTION=+SOL2 D SET Q - I 'SOLUTION S SOLUTION=$O(^PS(52.7,"AOI",PTR,SOLUTION)) D SET - Q -SET ;Set solution tmp nodes - Q:'+SOLUTION - S ^TMP("PSJNVO",$J,"SOL",0)=SOLCNT - S ^TMP("PSJNVO",$J,"SOL",SOLCNT,0)=SOLUTION_"^"_VOLUME,TVOLUME=TVOLUME+(+VOLUME) - Q - ; -SNDTSTW(PRIO,PSJSCHED,WARD) ; Test to determine if mail message should be sent. - N SNPRIO,SNSCHD,SNOPT - S SNPRIO=$S(PRIO="S":"S",PRIO="A":"A",1:"R") - S SNSCHD=$S(PSJSCHED="STAT":"S",PSJSCHED="NOW":"N",1:"R") - S SNOPT=$P($G(^PS(59.6,WARD,0)),"^",32) - S:SNOPT="" SNOPT=$P($G(^PS(59.7,1,27)),"^",1) - Q:SNOPT="" 0 - Q:SNOPT[SNPRIO 0 - Q:SNOPT[SNSCHD 0 - Q 1 - ; -SNDTSTP(PRIO,PSJSCHED) ; Test to determine if mail message should be sent. - N SNPRIO,SNSCHD,SNOPT - S SNPRIO=$S(PRIO="S":"S",PRIO="A":"A",1:"R") - S SNSCHD=$S(PSJSCHED="STAT":"S",PSJSCHED="NOW":"N",1:"R") - S SNOPT=$P($G(^PS(59.7,1,27)),"^",1) - Q:SNOPT="" 1 - Q:SNOPT[SNPRIO 0 - Q:SNOPT[SNSCHD 0 - Q 1 - ; -SNDTSTA(PRIO,PSJSCHED) ; Test to determine if mail message should be sent. - N SNPRIO,SNSCHD,SNOPT - S SNPRIO=$S(PRIO="S":"S",PRIO="A":"A",1:"R") - S SNSCHD=$S(PSJSCHED="STAT":"S",PSJSCHED="NOW":"N",1:"R") - S SNOPT=$P($G(^PS(59.7,1,27)),"^",2) - S:SNOPT="" SNOPT=$P($G(^PS(59.7,1,27)),"^",1) - Q:SNOPT="" 1 - Q:SNOPT[SNPRIO 0 - Q:SNOPT[SNSCHD 0 - Q 1 - ; -TMPAT(SCHEDULE) ; Extract admin times from schedule in format schedule@schedule - S TMPAT="" I SCHEDULE'["@" Q TMPAT - S TMPAT=$P(SCHEDULE,"@",2) I TMPAT]"" D - .N WARD S WARD=$G(^DPT(PSJHLDFN,.1)) I WARD]"" D - ..N DIC,X,Y S DIC="^DIC(42,",DIC(0)="BOXZ",X=WARD D ^DIC S WARD=+Y Q:WARD=0 - ..S WARD=$O(^PS(59.6,"B",WARD,0)) - .I '$D(^PS(51.1,"AC","PSJ",TMPAT)) S TMPAT="" Q - .N II I '$$DOW^PSIVUTL($P(SCHEDULE,"@")) S TMPAT="" Q - .N TMPIEN S TMPIEN=$O(^PS(51.1,"AC","PSJ",TMPAT,0)),TMPAT=$P($G(^PS(51.1,+TMPIEN,0)),"^",2) D - ..I $P($G(^PS(51.1,+TMPIEN,1,+$G(WARD),0)),"^",2) S TMPAT=$P($G(^(0)),"^",2) - Q TMPAT - ; -XMD ; Mailman call for NOTIFY^PSJHL4 - ; Input - PNAME = Patient Name - ; RTE = Route - ; DRUG = Drug Name - ; WARD = Ward Name - ; PRIO = CPRS Order Priority - S PNAME=$P($G(^DPT(+PSJHLDFN,0)),"^") S:$G(RTE) RTE=$P(^PS(51.2,+RTE,0),"^",3) - S DRUG=$S(DRIEN:$P($G(^PS(50.7,+DRIEN,0)),"^"),1:""),WARD=$G(^DPT(PSJHLDFN,.1)) - S XMDUZ="MEDICATIONS,INPATIENT",XMSUB=$G(WARD) - S XMSUB=XMSUB_"-"_NTFSTAT_" "_$S($G(PRIO)="A":"ASAP",$G(PRIO)="S":"STAT",$G(NTFYREAS)=2:"NOW",$G(NTFYREAS)=3:"STAT",1:"")_"-" - S XMSUB=XMSUB_$E(PNAME,1,65-$L(XMSUB)) - S XMTEXT="PSG(" - S PSG(1,0)="Inpatient Medications has received the following "_$S($G(PRIO)="A":"ASAP",$G(PRIO)="S":"STAT",$G(NTFYREAS)=2:"NOW",1:"")_" order ("_NTFSTAT_")" - S PSG(2,0)="" - S PSG(3,0)=" Patient: "_PNAME I $G(LASTFOUR) S PSG(3,0)=PSG(3,0)_" ("_LASTFOUR_")" - S PSG(4,0)="Order Information: "_DRUG_" "_DO_" "_RTE_" "_$G(PSJSCHED) - S PSG(5,0)=" Order Date: "_$$ENDTC^PSGMI(ORDATE) - D ^XMD - Q +PSJHL4A ;BIR/RLW-CONTINUE DECODE HL7 /MESSSAGE FROM OE/RR ;16 Mar 99 / 4:55 PM + ;;5.0; INPATIENT MEDICATIONS ;**105,111,154,170,159**;16 DEC 97;Build 15 + ; + ; Reference to ^PS(52.6 is supported by DBIA# 1231. + ; Reference to ^PS(52.7 is supported by DBIA# 2173. + ; Reference to ^PS(55 is supported by DBIA# 2191. + ; Reference to ^PS(59.7 supported by DBIA #2181. + ; +RXC ; IV order + N IVFL + S APPL=FIELD(1) + I APPL["B" S SOLCNT=SOLCNT+1,PTR=$P(FIELD(2),"^",4) Q:'PTR S VOLUME=+FIELD(3)_" ML" D I '$D(^TMP("PSJNVO",$J,"SOL",SOLCNT,0)) D SOLSRCH + .S SOLUTION="" F S SOLUTION=$O(^PS(52.7,"AOI",PTR,SOLUTION)) Q:'SOLUTION S INACT=$G(^PS(52.7,SOLUTION,"I")) I 'INACT!(INACT>DT) I VOLUME=$P(^PS(52.7,SOLUTION,0),U,3) D + ..S ^TMP("PSJNVO",$J,"SOL",0)=SOLCNT + ..S ^TMP("PSJNVO",$J,"SOL",SOLCNT,0)=SOLUTION_"^"_VOLUME,TVOLUME=TVOLUME+(+VOLUME) + I $G(INFRT)]"" S X=INFRT D ENI^PSJHLU S INFRT=$G(X) + I APPL="A" S ADCNT=ADCNT+1,PTR=$P(FIELD(2),"^",4) Q:'PTR S STRENGTH=$G(FIELD(3))_" "_$P($G(FIELD(4)),"^",5) D I '$D(^TMP("PSJNVO",$J,"AD",ADCNT,0)) S PSREASON="Can't find matching additive" D ERROR^PSJHL9 Q + .S ADDITIVE="" F S ADDITIVE=$O(^PS(52.6,"AOI",PTR,ADDITIVE)) Q:'ADDITIVE S INACT=$G(^PS(52.6,ADDITIVE,"I")),IVFL=$P($G(^(0)),"^",13) I 'INACT!(INACT>DT),IVFL'=0 Q:$G(^PS(52.6,ADDITIVE,0))']"" D Q:ADDITIVE + ..I $G(PSITEM)="" S PSITEM=PTR + ..S ^TMP("PSJNVO",$J,"AD",0)=ADCNT + ..S ^TMP("PSJNVO",$J,"AD",ADCNT,0)=ADDITIVE_"^"_STRENGTH + Q + ; +RXO ; + I $O(PSJMSG(II,0)) D + .K SEGMENT + .N KK,JJ,XX + .S SEGMENT(1)=$G(PSJMSG(II)) + .S KK=1,JJ="" F S JJ=$O(PSJMSG(II,JJ)) Q:'JJ S KK=KK+1,SEGMENT(KK)=$G(PSJMSG(II,JJ)) + .S KK=1,JJ=0 + .F Q:'$D(SEGMENT(KK)) D + ..I SEGMENT(KK)["|" S FIELD(JJ)=$P(SEGMENT(KK),"|"),SEGMENT(KK)=$E(SEGMENT(KK),$L(FIELD(JJ))+2,$L(SEGMENT(KK))),JJ=JJ+1 Q + ..I SEGMENT(KK)'["|" S FIELD(JJ)=SEGMENT(KK),KK=KK+1 Q:'$D(SEGMENT(KK)) D + ...S XX=$P(SEGMENT(KK),"|"),SEGMENT(KK)=$E(SEGMENT(KK),$L(X)+2,$L(SEGMENT(KK))),FIELD(JJ)=FIELD(JJ)_XX,JJ=JJ+1 + S APPL="",PSITEM=$S($P(FIELD(1),"^",5)="IV":"",1:$P(FIELD(1),"^",4)) + S:$P(FIELD(1),"^",6)="ORD" PSITEM="" + S:$P(FIELD(1),"^",5)="IV" IVTYP="A",SCHTYP="C",INFRT=$G(FIELD(2)) + S DISPENSE=$P($G(FIELD(10)),"^",4) + S IVLIMIT=$P($G(PSJMSG(II)),"^",3) + Q + ; +OBX ; + S OBXFL=1,OCNARR=FIELD(5),OCPROV=CLERK,OCCNT=OCCNT+1 + S ^TMP("PSJNVO",$J,10,0)=OCCNT + S ^TMP("PSJNVO",$J,10,OCCNT,0)=OCNARR + S ^TMP("PSJNVO",$J,10,OCCNT,1)=$P($G(^VA(200,+OCPROV,0)),"^") + Q + ; +NTE ; + S TEXT=$S((FIELD(1)=6)&('OBXFL):"PROCOM",(FIELD(1)=7)&('OBXFL):"ADMINSTR",1:"OCRSN") + S @TEXT@(1)=$G(FIELD(3)) + S K=1,J="" F S J=$O(PSJMSG(II,J)) Q:'J S K=K+1,@TEXT@(K)=$G(PSJMSG(II,J)) + D:$D(OCRSN) + .S QQ=0 F S QQ=$O(OCRSN(QQ)) Q:'QQ S ^TMP("PSJNVO",$J,10,OCCNT,2,QQ,0)=OCRSN(QQ) + S OBXFL=0 + Q + ; +ZRX ; + N ND,ND2,CHK,FOLOR,STDT + S PREON=$G(FIELD(1)),ROC=$G(FIELD(3)) + S ND=$S((PREON["N")!(PREON["P"):$G(^PS(53.1,+PREON,0)),PREON["V":$G(^PS(55,PSJHLDFN,"IV",+PREON,0)),1:$G(^PS(55,PSJHLDFN,5,+PREON,0))) + S ND2=$S((PREON["N")!(PREON["P"):$G(^PS(53.1,+PREON,2)),PREON["V":$G(^PS(55,PSJHLDFN,"IV",+PREON,2)),1:$G(^PS(55,PSJHLDFN,5,+PREON,2))) + I 'ND I ROC'="N" S PSREASON="Invalid Pharmacy order number" D ERROR^PSJHL9 Q + I ND I ROC="R" S FOLOR=$S(PREON["V":$P(ND2,U,6),1:$P(ND,U,26)) I FOLOR S PSREASON="Duplicate Renewal Request" D ERROR^PSJHL9 Q + I ND I ROC="R" S CHK=$S(PREON["V":$P(ND,U,17),1:$P(ND,U,9)) I "AE"'[CHK S PSREASON="Pharmacy orders with a status of "_CHK_" may not be renewed" D ERROR^PSJHL9 Q + I $G(CHK)="E" I PREON'["V" D NOW^%DTC S X1=+$E(%,1,12),X2=-4 D C^%DTC S STDT=$S(PREON["V":$P(ND,U,3),1:$P(ND2,U,4)) I STDT'>X S PSREASON="Pharmacy orders expired longer than 4 days may not be renewed" D ERROR^PSJHL9 Q + I ND I ROC="E" S FOLOR=$S(PREON["V":$P(ND2,U,6),1:$P(ND,U,26)) I FOLOR S PSREASON="Pharmacy orders may only be edited ONCE" D ERROR^PSJHL9 Q + I ND I ROC="E" S CHK=$S(PREON["V":$P(ND,U,17),1:$P(ND,U,9)) I "DEHO"[CHK N CHKRTN S CHKRTN=CHK_"^PSJHL6" D @CHKRTN S PSREASON=PSREASON_" orders may not be edited" D ERROR^PSJHL9 Q + D:ROC'="R" VALID^PSJHL9 Q:QFLG + I $G(PSITEM)="",$D(^TMP("PSJNVO",$J,"SOL",1,0)) S PSITEM=$P($G(^PS(52.7,+^TMP("PSJNVO",$J,"SOL",1,0),0)),"^",11) + I PRIORITY="ZD" D VALID^PSJHL10 S QFLG=1 Q + I (PREON]"")&(ROC="E") D EDITCK^PSJHL5 Q:QFLG + D NVO^PSJHL9 + I (PREON]"")&(ROC="R") D RENEW^PSJHL7 Q + I (PREON]"")&(ROC="E") D EDIT^PSJHL5 + Q + ; +SOLSRCH ;Find solution + N SSSS,SEG,ON,ROC,SOL,SOL2 + F SSSS=II:0 S SSSS=$O(PSJMSG(SSSS)) Q:'SSSS I $P(PSJMSG(SSSS),"|")="ZRX" D Q + .S SEG=$G(PSJMSG(SSSS)),ON=$P(SEG,"|",2),ROC=$P(SEG,"|",4) + I $G(ROC)'="N" F SOL=0:0 S SOL=$O(^PS(55,PSJHLDFN,"IV",+ON,"SOL",SOL)) Q:'SOL S SOL2=$G(^PS(55,PSJHLDFN,"IV",+ON,"SOL",SOL,0)) I $D(^PS(52.7,"AOI",PTR,+SOL2))&($P(SOL2,U,2)=VOLUME) S SOLUTION=+SOL2 D SET Q + I 'SOLUTION S SOLUTION=$O(^PS(52.7,"AOI",PTR,SOLUTION)) D SET + Q +SET ;Set solution tmp nodes + Q:'+SOLUTION + S ^TMP("PSJNVO",$J,"SOL",0)=SOLCNT + S ^TMP("PSJNVO",$J,"SOL",SOLCNT,0)=SOLUTION_"^"_VOLUME,TVOLUME=TVOLUME+(+VOLUME) + Q + ; +SNDTSTW(PRIO,PSJSCHED,WARD) ; Test to determine if mail message should be sent. + N SNPRIO,SNSCHD,SNOPT + S SNPRIO=$S(PRIO="S":"S",PRIO="A":"A",1:"R") + S SNSCHD=$S(PSJSCHED="STAT":"S",PSJSCHED="NOW":"N",1:"R") + S SNOPT=$P($G(^PS(59.6,WARD,0)),"^",32) + S:SNOPT="" SNOPT=$P($G(^PS(59.7,1,27)),"^",1) + Q:SNOPT="" 0 + Q:SNOPT[SNPRIO 0 + Q:SNOPT[SNSCHD 0 + Q 1 + ; +SNDTSTP(PRIO,PSJSCHED) ; Test to determine if mail message should be sent. + N SNPRIO,SNSCHD,SNOPT + S SNPRIO=$S(PRIO="S":"S",PRIO="A":"A",1:"R") + S SNSCHD=$S(PSJSCHED="STAT":"S",PSJSCHED="NOW":"N",1:"R") + S SNOPT=$P($G(^PS(59.7,1,27)),"^",1) + Q:SNOPT="" 1 + Q:SNOPT[SNPRIO 0 + Q:SNOPT[SNSCHD 0 + Q 1 + ; +SNDTSTA(PRIO,PSJSCHED) ; Test to determine if mail message should be sent. + N SNPRIO,SNSCHD,SNOPT + S SNPRIO=$S(PRIO="S":"S",PRIO="A":"A",1:"R") + S SNSCHD=$S(PSJSCHED="STAT":"S",PSJSCHED="NOW":"N",1:"R") + S SNOPT=$P($G(^PS(59.7,1,27)),"^",2) + S:SNOPT="" SNOPT=$P($G(^PS(59.7,1,27)),"^",1) + Q:SNOPT="" 1 + Q:SNOPT[SNPRIO 0 + Q:SNOPT[SNSCHD 0 + Q 1 diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL5.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL5.m index 9b913aaf..81892308 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL5.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL5.m @@ -1,89 +1,87 @@ -PSJHL5 ;BIR/LDT-ACTIONS ON HL7 MESSAGES FROM OE/RR ;28 Jan 98 / 3:34 PM - ;;5.0; INPATIENT MEDICATIONS ;**1,28,39,40,42,84,85,95,80,173,134**;16 DEC 97;Build 124 - ; - ; Reference to ^PS(55 is supported by DBIA# 2191. - ; Reference to EN^ORERR is supported by DBIA# 2187. - ; Reference to NURV^ALPBCBU is supported by DBIA# 4120. - ; Reference to UNESC^ORHLESC is supported by DBIA# 4922 - ; -ASSIGN ; number assigned, update ORDERS FILE ENTRY - S RXORDER=RXORDER_"0)" - I '$P($G(@RXORDER),U) S ORDCON="Invalid Pharmacy order number/Number Assign Msg" S X="ORERR" X ^%ZOSF("TEST") I D EN^ORERR(ORDCON,.PSJMSG) Q - Q:'$P($G(@RXORDER),U) - I RXON["P",PSJHLDFN'=$P($G(@(RXORDER)),U,15) S ORDCON="Patient does not match/Number Assign Msg" S X="ORERR" X ^%ZOSF("TEST") I D EN^ORERR(ORDCON,.PSJMSG) Q - I RXON["P",PSJHLDFN'=$P($G(@(RXORDER)),U,15) Q - S $P(@RXORDER,"^",21)=PSJORDER - Q - ; -NURSEACK ;Nurse Acknowledgement of Pending Orders - I '$P($G(@(RXORDER_"0)")),U) S ORDCON="Invalid Pharmacy order number/Nurse Acknowledgement Msg" S X="ORERR" X ^%ZOSF("TEST") I D EN^ORERR(ORDCON,.PSJMSG) Q - Q:'$P($G(@(RXORDER_"0)")),U) - I RXON["P",PSJHLDFN'=$P($G(@(RXORDER_"0)")),U,15) S ORDCON="Patient does not match/Nurse Acknowledgement Msg" S X="ORERR" X ^%ZOSF("TEST") I D EN^ORERR(ORDCON,.PSJMSG) Q - I RXON["P",PSJHLDFN'=$P($G(@(RXORDER_"0)")),U,15) Q - I RXON["P" N STATUS S STATUS=$P($G(@(RXORDER_"0)")),U,9) D:STATUS="N" EN^PSJHLV(PSJHLDFN,RXON) - I RXON["P" N STATUS S STATUS=$P($G(@(RXORDER_"0)")),U,9) Q:STATUS="A" - N DIE,DA - S DIE=$S(RXON["N"!(RXON["P"):"^PS(53.1,",RXON["V":"^PS(55,"_PSJHLDFN_",""IV"",",1:"^PS(55,"_PSJHLDFN_",5,"),DA=+RXON,DA(1)=PSJHLDFN - S DR="16////"_NURSEACK_";17////"_ACKDATE S:RXON["U" DR=DR_";51////1" S:RXON["V" DR=DR_";143////1",PSIVACT="" - I RXON["U" D NEWUDAL^PSGAL5(PSJHLDFN,RXON,22010) - I RXON["P" D NEWNVAL^PSGAL5(RXON,22010) - S PSGNVF=1 D ^DIE - I RXON["V" NEW ON55,DFN,PSIVAL,PSIVREA,PSIVLN K PSIVACT D - . S ON55=RXON,DFN=PSJHLDFN,PSIVAL="ORDER VERIFIED BY NURSE",PSIVALT="",PSIVREA="V" - . D LOG^PSIVORAL - D:RXON["P" EN^PSJLOI(PSJHLDFN,RXON) D:RXON["U" EN2^PSJLOI(PSJHLDFN,RXON) - K:RXON["U" ^PS(55,"ANV",PSJHLDFN,+RXON) - I $T(NURV^ALPBCBU)'="" D NURV^ALPBCBU(PSJHLDFN,RXON) - Q - ; -EDIT ;Edit orders thru OE/RR - N DA,DR,DIE,PREORDER,STPDT,PSIVACT,PSIVALT,ON55,PSIVREA,PSIVALCK,P - S PREORDER=$S((PREON["N")!(PREON["P"):"^PS(53.1,"_+PREON_",2)",PREON["V":"^PS(55,"_PSJHLDFN_",""IV"","_+PREON_",0)",1:"^PS(55,"_PSJHLDFN_",5,"_+PREON_",2)") - S STPDT=$S(PREON["V":$P($G(@PREORDER),"^",3),1:$P($G(@PREORDER),"^",4)) - D NOW^%DTC - S DIE=$S(PREON["N"!(PREON["P"):"^PS(53.1,",PREON["V":"^PS(55,"_PSJHLDFN_",""IV"",",1:"^PS(55,"_PSJHLDFN_",5,"),DA=+PREON,DA(1)=+PSJHLDFN - S DR=$S(PREON["V":"100////D;116////^S X=STPDT;123////E;114////"_PSJORDER_";.03////"_%,((PREON["P")!(PREON["N")):"25////"_%_";28////DE;107////E;105////"_PSJORDER_";32////"_STPDT,1:"25////"_STPDT_";28////DE;107////E;105////"_PSJORDER_";34////"_%) - I PREON["U"!(PREON["A") S PSGAL("C")=4100 D ^PSGAL5 - I PREON["V" S PSIVACT=1,PSIVALT=2,ON55=PREON,PSIVREA="D",PSIVALCK="STOP",P(3)=STPDT - D ^DIE,AUE^PSJHL6(PSJHLDFN,PREON) - I PREON["V" N DFN S DFN=PSJHLDFN D LOG^PSIVORAL - S PSJHLMTN="ORM",PSOC=$S((PREON["N")!(PREON["P"):"OC",1:"OD") D EN1^PSJHL2(PSJHLDFN,PSOC,PREON) S PSJHLMTN="ORR",PSOC="XO" - Q - ; -EDITCK ;Check to see if PSJHLDFN passed matches PSJHLDFN in pending order. - I (PREON["N")!(PREON["P"),PSJHLDFN'=$P($G(^PS(53.1,+PREON,0)),U,15) D - . S ORDCON="Patient does not match/Edit Msg" S X="ORERR" X ^%ZOSF("TEST") I D EN^ORERR(ORDCON,.PSJMSG) - . D EN1^PSJHLERR(PSJHLDFN,"UX",$P(ORDER,"^"),ORDCON) S QFLG=1 - Q - ; -STATUS ;Check status of an order in response to a send order status request from CPRS. - N STATUS,STPDT,NODE,NODE2 - S NODE=$G(@(RXORDER_"0)")),NODE2=$G(@(RXORDER_"2)")) - I 'NODE S PSREASON="Invalid Pharmacy order number" D Q - .S X="ORERR" X ^%ZOSF("TEST") I D EN^ORERR(PSREASON_"/Status Check",.PSJMSG) - .D EN1^PSJHLERR(PSJHLDFN,"DE",$P(ORDER,U),PSREASON) - S $P(@(RXORDER_"0)"),"^",21)=$P(ORDER,"^") - S STATUS=$S(RXON["V":$P(NODE,"^",17),1:$P(NODE,"^",9)) - S STPDT=$S(RXON["V":$P(NODE,"^",3),1:$P(NODE2,"^",4)) - D NOW^%DTC I RXON'["P" I "DEH"'[STATUS I STPDT<% D EXPIR^PSJHL6 Q - D EN1^PSJHL2(PSJHLDFN,"SC",RXON) - Q - ; -FLAG ;Flag/Unflag orders - I '$P($G(@(RXORDER_"0)")),U) S ORDCON="Invalid Pharmacy order number/Flag Msg" S X="ORERR" X ^%ZOSF("TEST") I D EN^ORERR(ORDCON,.PSJMSG) Q - Q:'$P($G(@(RXORDER_"0)")),U) - S DIE=$S(RXON["N"!(RXON["P"):"^PS(53.1,",RXON["V":"^PS(55,"_PSJHLDFN_",""IV"",",1:"^PS(55,"_PSJHLDFN_",5,"),DA=+RXON,DA(1)=PSJHLDFN - S DR=$S(PSJFLAG="FL":$S(RXON["V":"148////1",1:"124////1"),1:$S(RXON["V":"148////@",1:"124////@")) - D ^DIE - I $G(FLCMNT)]"" S FLCMNT=$$UNESC^ORHLESC(FLCMNT) - I RXON["U" D - . S ^PS(55,PSJHLDFN,5,+RXON,13)=FLCMNT - . S FLCMNT="COMMENTS: "_FLCMNT S:$L(FLCMNT)>52 FLCMNT=$E(FLCMNT,1,49)_"..." - . D NEWUDAL^PSGAL5(PSJHLDFN,+RXON,$S((PSJFLAG="FL")&(PSJYN="PHR"):7000,(PSJFLAG="UF")&(PSJYN="PHR"):7010,(PSJFLAG="FL")&(PSJYN=""):7020,1:7030),FLCMNT) - I RXON["V" N DFN,ON55,PSIVREA,PSIVAL S DFN=PSJHLDFN S PSIVALT="",ON55=RXON,PSIVREA=$S(PSJFLAG="FL":"G",1:"UG"),PSIVAL=$S(PSJYN="PHR":"FLAGGED BY PHARMACIST ",1:"FLAGGED BY CPRS ")_FLCMNT D LOG^PSIVORAL - I RXON["P" D - . S ^PS(53.1,+RXON,13)=FLCMNT - . S FLCMNT="COMMENTS: "_FLCMNT S:$L(FLCMNT)>52 FLCMNT=$E(FLCMNT,1,49)_"..." - . D NEWNVAL^PSGAL5(+RXON,$S((PSJFLAG="FL")&(PSJYN="PHR"):7000,(PSJFLAG="UF")&(PSJYN="PHR"):7010,(PSJFLAG="FL")&(PSJYN=""):7020,1:7030),FLCMNT) - ;The ... on Unit Dose and Pending orders is because of the limitations in the DD of 53.1. - Q +PSJHL5 ;BIR/LDT-ACTIONS ON HL7 MESSAGES FROM OE/RR ;28 Jan 98 / 3:34 PM + ;;5.0; INPATIENT MEDICATIONS ;**1,28,39,40,42,84,85,95,80,173**;16 DEC 97;Build 4 + ; + ; Reference to ^PS(55 is supported by DBIA# 2191. + ; Reference to EN^ORERR is supported by DBIA# 2187. + ; Reference to NURV^ALPBCBU is supported by DBIA# 4120. + ; +ASSIGN ; number assigned, update ORDERS FILE ENTRY + S RXORDER=RXORDER_"0)" + I '$P($G(@RXORDER),U) S ORDCON="Invalid Pharmacy order number/Number Assign Msg" S X="ORERR" X ^%ZOSF("TEST") I D EN^ORERR(ORDCON,.PSJMSG) Q + Q:'$P($G(@RXORDER),U) + I RXON["P",PSJHLDFN'=$P($G(@(RXORDER)),U,15) S ORDCON="Patient does not match/Number Assign Msg" S X="ORERR" X ^%ZOSF("TEST") I D EN^ORERR(ORDCON,.PSJMSG) Q + I RXON["P",PSJHLDFN'=$P($G(@(RXORDER)),U,15) Q + S $P(@RXORDER,"^",21)=PSJORDER + Q + ; +NURSEACK ;Nurse Acknowledgement of Pending Orders + I '$P($G(@(RXORDER_"0)")),U) S ORDCON="Invalid Pharmacy order number/Nurse Acknowledgement Msg" S X="ORERR" X ^%ZOSF("TEST") I D EN^ORERR(ORDCON,.PSJMSG) Q + Q:'$P($G(@(RXORDER_"0)")),U) + I RXON["P",PSJHLDFN'=$P($G(@(RXORDER_"0)")),U,15) S ORDCON="Patient does not match/Nurse Acknowledgement Msg" S X="ORERR" X ^%ZOSF("TEST") I D EN^ORERR(ORDCON,.PSJMSG) Q + I RXON["P",PSJHLDFN'=$P($G(@(RXORDER_"0)")),U,15) Q + I RXON["P" N STATUS S STATUS=$P($G(@(RXORDER_"0)")),U,9) D:STATUS="N" EN^PSJHLV(PSJHLDFN,RXON) + I RXON["P" N STATUS S STATUS=$P($G(@(RXORDER_"0)")),U,9) Q:STATUS="A" + N DIE,DA + S DIE=$S(RXON["N"!(RXON["P"):"^PS(53.1,",RXON["V":"^PS(55,"_PSJHLDFN_",""IV"",",1:"^PS(55,"_PSJHLDFN_",5,"),DA=+RXON,DA(1)=PSJHLDFN + S DR="16////"_NURSEACK_";17////"_ACKDATE S:RXON["U" DR=DR_";51////1" S:RXON["V" DR=DR_";143////1",PSIVACT="" + I RXON["U" D NEWUDAL^PSGAL5(PSJHLDFN,RXON,22010) + I RXON["P" D NEWNVAL^PSGAL5(RXON,22010) + S PSGNVF=1 D ^DIE + I RXON["V" NEW ON55,DFN,PSIVAL,PSIVREA,PSIVLN K PSIVACT D + . S ON55=RXON,DFN=PSJHLDFN,PSIVAL="ORDER VERIFIED BY NURSE",PSIVALT="",PSIVREA="V" + . D LOG^PSIVORAL + D:RXON["P" EN^PSJLOI(PSJHLDFN,RXON) D:RXON["U" EN2^PSJLOI(PSJHLDFN,RXON) + K:RXON["U" ^PS(55,"ANV",PSJHLDFN,+RXON) + I $T(NURV^ALPBCBU)'="" D NURV^ALPBCBU(PSJHLDFN,RXON) + Q + ; +EDIT ;Edit orders thru OE/RR + N DA,DR,DIE,PREORDER,STPDT,PSIVACT,PSIVALT,ON55,PSIVREA,PSIVALCK,P + S PREORDER=$S((PREON["N")!(PREON["P"):"^PS(53.1,"_+PREON_",2)",PREON["V":"^PS(55,"_PSJHLDFN_",""IV"","_+PREON_",0)",1:"^PS(55,"_PSJHLDFN_",5,"_+PREON_",2)") + S STPDT=$S(PREON["V":$P($G(@PREORDER),"^",3),1:$P($G(@PREORDER),"^",4)) + D NOW^%DTC + S DIE=$S(PREON["N"!(PREON["P"):"^PS(53.1,",PREON["V":"^PS(55,"_PSJHLDFN_",""IV"",",1:"^PS(55,"_PSJHLDFN_",5,"),DA=+PREON,DA(1)=+PSJHLDFN + S DR=$S(PREON["V":"100////D;116////^S X=STPDT;123////E;114////"_PSJORDER_";.03////"_%,((PREON["P")!(PREON["N")):"25////"_%_";28////DE;107////E;105////"_PSJORDER_";32////"_STPDT,1:"25////"_STPDT_";28////DE;107////E;105////"_PSJORDER_";34////"_%) + I PREON["U"!(PREON["A") S PSGAL("C")=4100 D ^PSGAL5 + I PREON["V" S PSIVACT=1,PSIVALT=2,ON55=PREON,PSIVREA="D",PSIVALCK="STOP",P(3)=STPDT + D ^DIE,AUE^PSJHL6(PSJHLDFN,PREON) + I PREON["V" N DFN S DFN=PSJHLDFN D LOG^PSIVORAL + S PSJHLMTN="ORM",PSOC=$S((PREON["N")!(PREON["P"):"OC",1:"OD") D EN1^PSJHL2(PSJHLDFN,PSOC,PREON) S PSJHLMTN="ORR",PSOC="XO" + Q + ; +EDITCK ;Check to see if PSJHLDFN passed matches PSJHLDFN in pending order. + I (PREON["N")!(PREON["P"),PSJHLDFN'=$P($G(^PS(53.1,+PREON,0)),U,15) D + . S ORDCON="Patient does not match/Edit Msg" S X="ORERR" X ^%ZOSF("TEST") I D EN^ORERR(ORDCON,.PSJMSG) + . D EN1^PSJHLERR(PSJHLDFN,"UX",$P(ORDER,"^"),ORDCON) S QFLG=1 + Q + ; +STATUS ;Check status of an order in response to a send order status request from CPRS. + N STATUS,STPDT,NODE,NODE2 + S NODE=$G(@(RXORDER_"0)")),NODE2=$G(@(RXORDER_"2)")) + I 'NODE S PSREASON="Invalid Pharmacy order number" D Q + .S X="ORERR" X ^%ZOSF("TEST") I D EN^ORERR(PSREASON_"/Status Check",.PSJMSG) + .D EN1^PSJHLERR(PSJHLDFN,"DE",$P(ORDER,U),PSREASON) + S $P(@(RXORDER_"0)"),"^",21)=$P(ORDER,"^") + S STATUS=$S(RXON["V":$P(NODE,"^",17),1:$P(NODE,"^",9)) + S STPDT=$S(RXON["V":$P(NODE,"^",3),1:$P(NODE2,"^",4)) + D NOW^%DTC I RXON'["P" I "DEH"'[STATUS I STPDT<% D EXPIR^PSJHL6 Q + D EN1^PSJHL2(PSJHLDFN,"SC",RXON) + Q + ; +FLAG ;Flag/Unflag orders + I '$P($G(@(RXORDER_"0)")),U) S ORDCON="Invalid Pharmacy order number/Flag Msg" S X="ORERR" X ^%ZOSF("TEST") I D EN^ORERR(ORDCON,.PSJMSG) Q + Q:'$P($G(@(RXORDER_"0)")),U) + S DIE=$S(RXON["N"!(RXON["P"):"^PS(53.1,",RXON["V":"^PS(55,"_PSJHLDFN_",""IV"",",1:"^PS(55,"_PSJHLDFN_",5,"),DA=+RXON,DA(1)=PSJHLDFN + S DR=$S(PSJFLAG="FL":$S(RXON["V":"148////1",1:"124////1"),1:$S(RXON["V":"148////@",1:"124////@")) + D ^DIE + I RXON["U" D + . S ^PS(55,PSJHLDFN,5,+RXON,13)=FLCMNT + . S FLCMNT="COMMENTS: "_FLCMNT S:$L(FLCMNT)>52 FLCMNT=$E(FLCMNT,1,49)_"..." + . D NEWUDAL^PSGAL5(PSJHLDFN,+RXON,$S((PSJFLAG="FL")&(PSJYN="PHR"):7000,(PSJFLAG="UF")&(PSJYN="PHR"):7010,(PSJFLAG="FL")&(PSJYN=""):7020,1:7030),FLCMNT) + I RXON["V" N DFN,ON55,PSIVREA,PSIVAL S DFN=PSJHLDFN S PSIVALT="",ON55=RXON,PSIVREA=$S(PSJFLAG="FL":"G",1:"UG"),PSIVAL=$S(PSJYN="PHR":"FLAGGED BY PHARMICIST ",1:"FLAGGED BY CPRS ")_FLCMNT D LOG^PSIVORAL + I RXON["P" D + . S ^PS(53.1,+RXON,13)=FLCMNT + . S FLCMNT="COMMENTS: "_FLCMNT S:$L(FLCMNT)>52 FLCMNT=$E(FLCMNT,1,49)_"..." + . D NEWNVAL^PSGAL5(+RXON,$S((PSJFLAG="FL")&(PSJYN="PHR"):7000,(PSJFLAG="UF")&(PSJYN="PHR"):7010,(PSJFLAG="FL")&(PSJYN=""):7020,1:7030),FLCMNT) + ;The ... on Unit Dose and Pending orders is because of the limitations in the DD of 53.1. + Q diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL9.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL9.m index 2a7ac4cd..3255e72a 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL9.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL9.m @@ -1,146 +1,133 @@ -PSJHL9 ;BIR/LDT-VALIDATE INCOMING HL7 DATA/CREATE NEW ORDER ;08 Jul 99 / 10:50 AM - ;;5.0; INPATIENT MEDICATIONS ;**1,18,31,42,47,50,63,72,75,58,80,110,111,134**;16 DEC 97;Build 124 - ; - ; Reference to ^PSDRUG is supported by DBIA# 2192. - ; Reference to ^PS(50.7 is supported by DBIA# 2180. - ; Reference to ^PS(51.2 is supported by DBIA# 2178. - ; Reference to ^PS(55 is supported by DBIA# 2191. - ; Reference to ^ORERR is supported by DBIA# 2187. - ; Reference to ^ORHLESC is supported by DBIA# 4922. - ; -VALID ; - I APPL="",PSITEM="" S PSREASON="Missing or invalid Orderable Item" D ERROR Q - I PSITEM]"",'$D(^PS(50.7,+PSITEM,0)) S PSREASON="Missing or invalid Orderable Item" D ERROR Q - I $G(APPL)'["B",$G(APPL)'["A",+$G(ROUTE)'>0 S PSREASON="Missing or invalid Med Route" D ERROR Q - S APPL=$S($G(APPL)["B":"F",$G(APPL)["A":"F",$G(DISPENSE)]"":$$ORTYP(ROUTE,DISPENSE),1:$$TRYAGAIN(ROUTE,PSITEM)) - S:APPL="" APPL="IP" - I APPL'="F" D - .I $G(SCHEDULE)]"" N X S X=SCHEDULE D S SCHEDULE=X - ..I X[""""!($A(X)=45)!(X?.E1C.E)!($L(X," ")>3)!($L($P(X,"@"))>70)!($L($P(X,"@",2))>119)!($L(X)<1)!(X["P RN")!(X["PR N") S X="" Q - ..I X?.E1L.E S X=$$ENLU^PSGMI(X) - ..S X=$$TRIM^XLFSTR(X,"R"," ") - ..I X["Q0" S X="" Q - .I APPL["U",$G(SCHEDULE)="" S PSREASON="Missing or invalid schedule" D ERROR Q - .N DFN S DFN=PSJHLDFN D IN5^VADPT I 'VAIP(5) D:APPT="" I APPL="UN",APPT="" S PSREASON="Cannot place Unit Dose orders for an Outpatient" D ERROR Q - .. I APPL="UP" S APPL="IN" Q - .. I APPL="IP" S APPL="IN" Q - .I $G(ROC)'="R",$G(ROUTE)'>0 S PSREASON="Missing or invalid Med Route" D ERROR Q - I APPL="F" D - .I '$O(^TMP("PSJNVO",$J,"SOL",0))&('$O(^TMP("PSJNVO",$J,"AD",0))) S PSREASON="IV Fluid orders must have at least one additive or solution" D ERROR Q - .I $G(IVCAT)="I",$G(INFRT)="" Q ;Allow intermittent IV orders to have a null infusion rate. - .I $G(INFRT)="" S PSREASON="Invalid Infusion Rate" D ERROR Q - Q - ; -ERROR ;Sends error msg to CPRS, logs error in OE/RR Errors file - S X="ORERR" X ^%ZOSF("TEST") I D EN^ORERR(PSREASON,.PSJMSG) - D EN1^PSJHLERR(PSJHLDFN,$S(PSOC="XO":"UX",1:"OC"),$P(ORDER,U),PSREASON) S QFLG=1 K ^TMP("PSJNVO",$J) - Q - ; -NVO ; put new orders in non-verified orders file - I '$D(ROUTE) S ROUTE="" - I $G(ROUTE)="" S:APPL="F" ROUTE=$O(^PS(51.2,"B","INTRAVENOUS",0)) - N DA,DR,DIE D ENGNN^PSGOETO S DIE="^PS(53.1," - S DR="1////"_PROVIDER_";3////"_$$ESC^ORHLESC(ROUTE)_";4////"_$E(APPL)_";28////P"_";108////"_PSITEM_";27.1////"_LOGIN_";27////"_LOGIN_";.5////"_PSJHLDFN_";.24////"_PRIORITY_";125////"_$G(PRNTON) - I $G(LOC)]"" S:$P($G(^SC(+LOC,0)),U,3)="C" DR=DR_";113////"_LOC_";126////"_$G(APPT) - I $G(IVCAT)]"" S DR=DR_";128////"_IVCAT S ADMINS="" - S:$G(SCHTYP)]"" DR=DR_";7////"_SCHTYP - D ^DIE K PSJHLSKP S NEWORDER=DA,PSJORDER=DA_"P" - S $P(^PS(55,PSJHLDFN,5.1),"^",2)=PROVIDER - S:$G(ORDER)]"" $P(^PS(53.1,DA,0),"^",21)=$P(ORDER,"^") - S:$G(APPL)["P" $P(^PS(53.1,DA,0),"^",13)=1 - S $P(^PS(53.1,DA,0),"^",18)=DA - S:$G(ROC)]"" $P(^PS(53.1,DA,0),"^",24)=ROC - S:$G(PREON)]"" $P(^PS(53.1,DA,0),"^",25)=PREON - S:$G(ADMINS) $P(^PS(53.1,DA,2),"^",5)=ADMINS - S:$G(REQST)]"" $P(^PS(53.1,DA,2.5),"^")=REQST - ; Transform duration units of doses to a for administrations - S:$E(DURATION,1,5)="doses" DURATION=$TR(DURATION,"doses","a") - S:$G(DURATION)]"" $P(^PS(53.1,DA,2.5),"^",2)=DURATION - S:$G(IVLIMIT)]"" $P(^PS(53.1,DA,2.5),"^",4)=IVLIMIT - I $G(REQST)]"",$G(DURATION)]"" S $P(^PS(53.1,DA,2.5),"^",3)=$$STOP(REQST,DURATION) - S:$G(INSTR)]"" $P(^PS(53.1,DA,.3),"^")=INSTR - I $G(INFRT)]"" D - .I INFRT S:(INFRT["Minutes"!(INFRT["Hours")) INFRT="INFUSE OVER "_INFRT - .S ^PS(53.1,DA,8)=IVTYP_"^^^^"_INFRT - S:$G(FREQ)]"" $P(^PS(53.1,DA,2),"^",6)=FREQ - S:$G(SCHTYP)]"" $P(^PS(53.1,DA,0),"^",7)=SCHTYP - I $G(APPL)'="I" I $G(INSTR)]"" N X S X=INSTR D STRIP I $S(X?.E1C.E:0,$L(X)>60:0,X="":0,X["^":0,X?1.P:1,1:1) S $P(^PS(53.1,DA,.2),"^",2)=X,$P(^PS(53.1,DA,.2),"^",5,6)=$G(DOSE)_"^"_$$UNESC^ORHLESC($G(UNIT)) - S $P(^PS(53.1,DA,.2),"^",3)=ORDCON - I $G(SCHEDULE)]"" S $P(^PS(53.1,DA,2),"^")=$$UNESC^ORHLESC(SCHEDULE) - I $G(APPL)="I" I $G(UNITS)]"" S $P(^PS(53.1,DA,.3),"^")=$$UNESC^ORHLESC(UNITS) - S ^PS(53.1,DA,4)="^^^^^^"_CLERK - I $G(DISPENSE) S ^PS(53.1,DA,1,0)="^53.11P^1^1",^PS(53.1,DA,1,1,0)=DISPENSE_"^"_$$UNESC^ORHLESC(UNITS),^PS(53.1,DA,1,"B",$E(DISPENSE,1,30),1)="" - I $D(PROCOM) D - .I '$D(^PS(53.1,DA,12,0)) S ^(0)="^53.1012^0^0" - .S JJ=0 F S JJ=$O(PROCOM(JJ)) Q:'JJ S $P(^PS(53.1,DA,12,0),"^",3,4)=JJ_"^"_JJ,^PS(53.1,DA,12,JJ,0)=$$UNESC^ORHLESC(PROCOM(JJ)) - I $D(ADMINSTR) D - .I '$D(^PS(53.1,DA,3,0)) S ^(0)="^53.12^0^0" - .S JJ=0 F S JJ=$O(ADMINSTR(JJ)) Q:'JJ S $P(^PS(53.1,DA,3,0),"^",3,4)=JJ_"^"_JJ,^PS(53.1,DA,3,JJ,0)=ADMINSTR(JJ) - I $D(^TMP("PSJNVO",$J,"AD")) D - .S ^PS(53.1,DA,"AD",0)="^53.157PA^0^0" - .S JJ=0 F S JJ=$O(^TMP("PSJNVO",$J,"AD",JJ)) Q:'JJ S $P(^PS(53.1,DA,"AD",0),"^",3,4)=JJ_"^"_JJ,^PS(53.1,DA,"AD",JJ,0)=^TMP("PSJNVO",$J,"AD",JJ,0),^PS(53.1,DA,"AD","B",$$UNESC^ORHLESC($P(^TMP("PSJNVO",$J,"AD",JJ,0),"^")),JJ)="" - I $D(^TMP("PSJNVO",$J,"SOL")) D - .S ^PS(53.1,DA,"SOL",0)="^53.158PA^0^0" - .S JJ=0 F S JJ=$O(^TMP("PSJNVO",$J,"SOL",JJ)) Q:'JJ S $P(^PS(53.1,DA,"SOL",0),"^",3,4)=JJ_"^"_JJ,^PS(53.1,DA,"SOL",JJ,0)=^TMP("PSJNVO",$J,"SOL",JJ,0),^PS(53.1,DA,"SOL","B",$P(^TMP("PSJNVO",$J,"SOL",JJ,0),"^"),JJ)="" - I $O(^TMP("PSJNVO",$J,10,0)) D - .S ^PS(53.1,DA,10,0)="^53.1112A^0^0" - .S JJ=0 F S JJ=$O(^TMP("PSJNVO",$J,10,JJ)) Q:'JJ S $P(^PS(53.1,DA,10,0),"^",3,4)=JJ_"^"_JJ,^PS(53.1,DA,10,JJ,0)=$$UNESC^ORHLESC(^TMP("PSJNVO",$J,10,JJ,0)),^PS(53.1,DA,10,"B",$$UNESC^ORHLESC($E(^TMP("PSJNVO",$J,10,JJ,0),1,30)),JJ)="" D - ..S ^PS(53.1,DA,10,JJ,1)=$P($G(^VA(200,+CLERK,0)),"^") - ..I $O(^TMP("PSJNVO",$J,10,JJ,2,0)) S ^PS(53.1,DA,10,JJ,2,0)="^53.11122^0^0" D - ...S QQ=0 F S QQ=$O(^TMP("PSJNVO",$J,10,JJ,2,QQ)) Q:'QQ S $P(^PS(53.1,DA,10,JJ,2,0),"^",3,4)=QQ_"^"_QQ,^PS(53.1,DA,10,JJ,2,QQ,0)=$$UNESC^ORHLESC(^TMP("PSJNVO",$J,10,JJ,2,QQ,0)) - Q -STRIP ;Strips spaces off the end of instructions. - I $E(X,$L(X))=" " F S X=$E(X,1,$L(X)-1) Q:$E(X,$L(X))'=" " - Q - ; -ORTYP(MDRT,DDRG) ;Entry point to determine order type for 53.1 - ;MDRT=Med Route from 51.2, DDRG=Dispense Drug - I '$G(DDRG) S ORTYP="" Q ORTYP - I '$D(^PSDRUG(+DDRG,2)) S ORTYP="" Q ORTYP - I $P(^PSDRUG(DDRG,2),"^",3)'["I",$P(^PSDRUG(DDRG,2),"^",3)'["U" S ORTYP="" Q ORTYP - I '$G(MDRT) S ORTYP="" Q ORTYP - I '$D(^PS(51.2,+MDRT,0)) S ORTYP="" Q ORTYP - I $P(^PSDRUG(DDRG,2),"^",3)["I",$P(^PSDRUG(DDRG,2),"^",3)'["U",$P(^PS(51.2,MDRT,0),"^",6)=1 S ORTYP="IN" Q ORTYP - I $P(^PSDRUG(DDRG,2),"^",3)'["I",$P(^PS(51.2,MDRT,0),"^",6)=1 S ORTYP="UP" Q ORTYP - I $P(^PSDRUG(DDRG,2),"^",3)["I",$P(^PS(51.2,MDRT,0),"^",6)=1 S ORTYP="IP" Q ORTYP - I $P(^PSDRUG(DDRG,2),"^",3)["I",$P(^PSDRUG(DDRG,2),"^",3)'["U",$P(^PS(51.2,MDRT,0),"^",6)'=1 S ORTYP="IP" Q ORTYP - I $P(^PSDRUG(DDRG,2),"^",3)["U",$P(^PSDRUG(DDRG,2),"^",3)'["I",$P(^PS(51.2,MDRT,0),"^",6)'=1 S ORTYP="UN" Q ORTYP - I $P(^PSDRUG(DDRG,2),"^",3)["U",$P(^PS(51.2,MDRT,0),"^",6)'=1 S ORTYP="UP" Q ORTYP - S ORTYP="" Q ORTYP - ; -TRYAGAIN(MDRT,OI) ; - ;MDRT=Med Route from 51.2, OI=Orderable Item - N ORTYPI,ORTYPU,ORTYPP - S ORTYP="",ORTYPI=0,ORTYPU=0,ORTYPP=0 - N DDRG S DDRG=0 F S DDRG=$O(^PSDRUG("ASP",OI,DDRG)) Q:'DDRG D - .I $G(^PSDRUG(DDRG,"I"))]"" Q:^PSDRUG(DDRG,"I")'>DT - .S ORTYP=$$ORTYP(MDRT,DDRG) D - ..I ORTYP["I" S ORTYPI=ORTYPI+1 - ..I ORTYP["U" S ORTYPU=ORTYPU+1 - ..I ORTYP["P" S ORTYPP=ORTYPP+1 - S ORTYP=$S(ORTYPU>ORTYPI:"U",1:"I") S ORTYP=ORTYP_$S(ORTYPP>0:"P",1:"N") - Q ORTYP - ; -STOP(REQST,DURA) ; - ;REQST=Requested start date, DURA=Duration from CPRS - I DURA["L",DURA?1A1".".N S DAYS=$$DAY($E(REQST,1,5)),DURA="H"_((DAYS*$P(DURA,"L",2))*24) - I DURA["L",DURA?1A.1N.N1"."1N.N D Q STOP - .S NUM=$E(REQST,4,5)+$P($P(DURA,"."),"L",2),NUM=$S(NUM<10:"0"_NUM,NUM<13:NUM,1:$S((NUM-12)<10:"0"_(NUM-12),1:(NUM-12))),DATE=$E(REQST,1,3)_NUM - .S DAYS=$$DAY(DATE),STOP=$$SCH^XLFDT($P($P(DURA,"."),"L",2)_"M",$P(REQST,"."))_"."_$P(REQST,".",2),DEL=$P($P(DURA,"L",2),"."),STOP=$$FMADD^XLFDT(STOP,"",((DAYS*$P(DURA,DEL,2))*24)) - I DURA["L" S STOP=$P($$SCH^XLFDT($P(DURA,"L",2)_"M",$P(REQST,".")),".")_"."_$P(REQST,".",2) Q STOP - I DURA["W",DURA["." S DURA="H"_(($P(DURA,"W",2)*7)*24) - I DURA["D",DURA["." S DURA="H"_($P(DURA,"D",2)*24) - I +DURA=DURA,DURA["." S DURA="H"_(DURA*24) - S STOP=$$FMADD^XLFDT(REQST,$S(DURA["W":$P(DURA,"W",2)*7,DURA["D":$P(DURA,"D",2),+DURA=DURA:+DURA,1:""),$S(DURA["H":$P(DURA,"H",2),1:""),$S(DURA["M":$P(DURA,"M",2),1:""),$S(DURA["S":$P(DURA,"S",2),1:"")) - Q STOP -ZQDATE(DATE,MONTHS) ;BUMP DATE BY A MONTH (OR SO) - ;; - S X=$E($P(DATE,"."),1,5)+($E($P(DATE,"."),4,5)>(12-MONTHS)*88+MONTHS)_$E($P(DATE,"."),6,7) F D ^%DT Q:Y>0 S X=X-1 - S NEWDATE=X_"."_$P(DATE,".",2) - Q NEWDATE -DAY(DATE) ;DATE=FIRST FIVE DIGITS OF FM DATE - N X - I DATE'?5N Q -1 - S X=$E(DATE,4,5) I X<1!(X>12) Q -1 - S X=DATE+1+(X=12*88)_"01" - Q $E($$FMADD^XLFDT(X,-1),6,7) +PSJHL9 ;BIR/LDT-VALIDATE INCOMING HL7 DATA/CREATE NEW ORDER ;08 Jul 99 / 10:50 AM + ;;5.0; INPATIENT MEDICATIONS ;**1,18,31,42,47,50,63,72,75,58,80,110,111**;16 DEC 97 + ; + ; Reference to ^PSDRUG is supported by DBIA# 2192. + ; Reference to ^PS(50.7 is supported by DBIA# 2180. + ; Reference to ^PS(51.2 is supported by DBIA# 2178. + ; Reference to ^PS(55 is supported by DBIA# 2191. + ; Reference to ^ORERR is supported by DBIA# 2187. + ; +VALID ; + I APPL="",PSITEM="" S PSREASON="Missing or invalid Orderable Item" D ERROR Q + I PSITEM]"",'$D(^PS(50.7,+PSITEM,0)) S PSREASON="Missing or invalid Orderable Item" D ERROR Q + I $G(APPL)'["B",$G(APPL)'["A",+$G(ROUTE)'>0 S PSREASON="Missing or invalid Med Route" D ERROR Q + S APPL=$S($G(APPL)["B":"F",$G(APPL)["A":"F",$G(DISPENSE)]"":$$ORTYP(ROUTE,DISPENSE),1:$$TRYAGAIN(ROUTE,PSITEM)) + S:APPL="" APPL="IP" + I APPL'="F" D + .I $G(SCHEDULE)]"" N X S X=SCHEDULE D S SCHEDULE=X + ..I X[""""!($A(X)=45)!(X?.E1C.E)!($L(X," ")>3)!($L(X)>70)!($L(X)<1)!(X["P RN")!(X["PR N") S X="" Q + ..I X?.E1L.E S X=$$ENLU^PSGMI(X) + ..S X=$$TRIM^XLFSTR(X,"R"," ") + ..I X["Q0" S X="" Q + .I APPL["U",$G(SCHEDULE)="" S PSREASON="Missing or invalid schedule" D ERROR Q + .N DFN S DFN=PSJHLDFN D IN5^VADPT I 'VAIP(5) D:APPT="" I APPL="UN",APPT="" S PSREASON="Cannot place Unit Dose orders for an Outpatient" D ERROR Q + .. I APPL="UP" S APPL="IN" Q + .. I APPL="IP" S APPL="IN" Q + .I $G(ROC)'="R",$G(ROUTE)'>0 S PSREASON="Missing or invalid Med Route" D ERROR Q + I APPL="F" D + .I '$O(^TMP("PSJNVO",$J,"SOL",0))&('$O(^TMP("PSJNVO",$J,"AD",0))) S PSREASON="IV Fluid orders must have at least one additive or solution" D ERROR Q + .I $G(INFRT)="" S PSREASON="Invalid Infusion Rate" D ERROR Q + Q + ; +ERROR ;Sends error msg to CPRS, logs error in OE/RR Errors file + S X="ORERR" X ^%ZOSF("TEST") I D EN^ORERR(PSREASON,.PSJMSG) + D EN1^PSJHLERR(PSJHLDFN,$S(PSOC="XO":"UX",1:"OC"),$P(ORDER,U),PSREASON) S QFLG=1 K ^TMP("PSJNVO",$J) + Q + ; +NVO ; put new orders in non-verified orders file + I '$D(ROUTE) S ROUTE="" + S:APPL="F" ROUTE=$O(^PS(51.2,"B","INTRAVENOUS",0)) + N DA,DR,DIE D ENGNN^PSGOETO S DIE="^PS(53.1," + S DR="1////"_PROVIDER_";3////"_ROUTE_";4////"_$E(APPL)_";28////P"_";108////"_PSITEM_";27.1////"_LOGIN_";27////"_LOGIN_";.5////"_PSJHLDFN_";.24////"_PRIORITY_";125////"_$G(PRNTON) + I $G(LOC)]"" S:$P($G(^SC(+LOC,0)),U,3)="C" DR=DR_";113////"_LOC_";126////"_$G(APPT) + D ^DIE K PSJHLSKP S NEWORDER=DA,PSJORDER=DA_"P" + S $P(^PS(55,PSJHLDFN,5.1),"^",2)=PROVIDER + S:$G(ORDER)]"" $P(^PS(53.1,DA,0),"^",21)=$P(ORDER,"^") + S:$G(APPL)["P" $P(^PS(53.1,DA,0),"^",13)=1 + S $P(^PS(53.1,DA,0),"^",18)=DA + S:$G(ROC)]"" $P(^PS(53.1,DA,0),"^",24)=ROC + S:$G(PREON)]"" $P(^PS(53.1,DA,0),"^",25)=PREON + S:$G(REQST)]"" $P(^PS(53.1,DA,2.5),"^")=REQST + S:$G(DURATION)]"" $P(^PS(53.1,DA,2.5),"^",2)=DURATION + S:$G(IVLIMIT)]"" $P(^PS(53.1,DA,2.5),"^",4)=IVLIMIT + I $G(REQST)]"",$G(DURATION)]"" S $P(^PS(53.1,DA,2.5),"^",3)=$$STOP(REQST,DURATION) + S:$G(INSTR)]"" $P(^PS(53.1,DA,.3),"^")=INSTR + S:$G(INFRT)]"" ^PS(53.1,DA,8)=IVTYP_"^^^^"_INFRT + S:$G(FREQ)]"" $P(^PS(53.1,DA,2),"^",6)=FREQ + S:$G(SCHTYP)]"" $P(^PS(53.1,DA,0),"^",7)=SCHTYP + I $G(APPL)'="I" I $G(INSTR)]"" N X S X=INSTR D STRIP I $S(X?.E1C.E:0,$L(X)>60:0,X="":0,X["^":0,X?1.P:1,1:1) S $P(^PS(53.1,DA,.2),"^",2)=X,$P(^PS(53.1,DA,.2),"^",5,6)=$G(DOSE)_"^"_$G(UNIT) + S $P(^PS(53.1,DA,.2),"^",3)=ORDCON + I $G(SCHEDULE)]"" S ^PS(53.1,DA,2)=SCHEDULE + I $G(APPL)="I" I $G(UNITS)]"" S $P(^PS(53.1,DA,.3),"^")=UNITS + S ^PS(53.1,DA,4)="^^^^^^"_CLERK + I $G(DISPENSE) S ^PS(53.1,DA,1,0)="^53.11P^1^1",^PS(53.1,DA,1,1,0)=DISPENSE_"^"_UNITS,^PS(53.1,DA,1,"B",$E(DISPENSE,1,30),1)="" + I $D(PROCOM) D + .I '$D(^PS(53.1,DA,12,0)) S ^(0)="^53.1012^0^0" + .S JJ=0 F S JJ=$O(PROCOM(JJ)) Q:'JJ S $P(^PS(53.1,DA,12,0),"^",3,4)=JJ_"^"_JJ,^PS(53.1,DA,12,JJ,0)=PROCOM(JJ) + I $D(ADMINSTR) D + .I '$D(^PS(53.1,DA,3,0)) S ^(0)="^53.12^0^0" + .S JJ=0 F S JJ=$O(ADMINSTR(JJ)) Q:'JJ S $P(^PS(53.1,DA,3,0),"^",3,4)=JJ_"^"_JJ,^PS(53.1,DA,3,JJ,0)=ADMINSTR(JJ) + I $D(^TMP("PSJNVO",$J,"AD")) D + .S ^PS(53.1,DA,"AD",0)="^53.157PA^0^0" + .S JJ=0 F S JJ=$O(^TMP("PSJNVO",$J,"AD",JJ)) Q:'JJ S $P(^PS(53.1,DA,"AD",0),"^",3,4)=JJ_"^"_JJ,^PS(53.1,DA,"AD",JJ,0)=^TMP("PSJNVO",$J,"AD",JJ,0),^PS(53.1,DA,"AD","B",$P(^TMP("PSJNVO",$J,"AD",JJ,0),"^"),JJ)="" + I $D(^TMP("PSJNVO",$J,"SOL")) D + .S ^PS(53.1,DA,"SOL",0)="^53.158PA^0^0" + .S JJ=0 F S JJ=$O(^TMP("PSJNVO",$J,"SOL",JJ)) Q:'JJ S $P(^PS(53.1,DA,"SOL",0),"^",3,4)=JJ_"^"_JJ,^PS(53.1,DA,"SOL",JJ,0)=^TMP("PSJNVO",$J,"SOL",JJ,0),^PS(53.1,DA,"SOL","B",$P(^TMP("PSJNVO",$J,"SOL",JJ,0),"^"),JJ)="" + I $O(^TMP("PSJNVO",$J,10,0)) D + .S ^PS(53.1,DA,10,0)="^53.1112A^0^0" + .S JJ=0 F S JJ=$O(^TMP("PSJNVO",$J,10,JJ)) Q:'JJ S $P(^PS(53.1,DA,10,0),"^",3,4)=JJ_"^"_JJ,^PS(53.1,DA,10,JJ,0)=^TMP("PSJNVO",$J,10,JJ,0),^PS(53.1,DA,10,"B",$E(^TMP("PSJNVO",$J,10,JJ,0),1,30),JJ)="" D + ..S ^PS(53.1,DA,10,JJ,1)=$P($G(^VA(200,+CLERK,0)),"^") + ..I $O(^TMP("PSJNVO",$J,10,JJ,2,0)) S ^PS(53.1,DA,10,JJ,2,0)="^53.11122^0^0" D + ...S QQ=0 F S QQ=$O(^TMP("PSJNVO",$J,10,JJ,2,QQ)) Q:'QQ S $P(^PS(53.1,DA,10,JJ,2,0),"^",3,4)=QQ_"^"_QQ,^PS(53.1,DA,10,JJ,2,QQ,0)=^TMP("PSJNVO",$J,10,JJ,2,QQ,0) + Q +STRIP ;Strips spaces off the end of instructions. + I $E(X,$L(X))=" " F S X=$E(X,1,$L(X)-1) Q:$E(X,$L(X))'=" " + Q + ; +ORTYP(MDRT,DDRG) ;Entry point to determine order type for 53.1 + ;MDRT=Med Route from 51.2, DDRG=Dispense Drug + I $P(^PSDRUG(DDRG,2),"^",3)'["I",$P(^PSDRUG(DDRG,2),"^",3)'["U" S ORTYP="" Q ORTYP + I $P(^PSDRUG(DDRG,2),"^",3)["I",$P(^PSDRUG(DDRG,2),"^",3)'["U",$P(^PS(51.2,MDRT,0),"^",6)=1 S ORTYP="IN" Q ORTYP + I $P(^PSDRUG(DDRG,2),"^",3)'["I",$P(^PS(51.2,MDRT,0),"^",6)=1 S ORTYP="UP" Q ORTYP + I $P(^PSDRUG(DDRG,2),"^",3)["I",$P(^PS(51.2,MDRT,0),"^",6)=1 S ORTYP="IP" Q ORTYP + I $P(^PSDRUG(DDRG,2),"^",3)["I",$P(^PSDRUG(DDRG,2),"^",3)'["U",$P(^PS(51.2,MDRT,0),"^",6)'=1 S ORTYP="IP" Q ORTYP + I $P(^PSDRUG(DDRG,2),"^",3)["U",$P(^PSDRUG(DDRG,2),"^",3)'["I",$P(^PS(51.2,MDRT,0),"^",6)'=1 S ORTYP="UN" Q ORTYP + I $P(^PSDRUG(DDRG,2),"^",3)["U",$P(^PS(51.2,MDRT,0),"^",6)'=1 S ORTYP="UP" Q ORTYP + S ORTYP="" Q ORTYP + ; +TRYAGAIN(MDRT,OI) ; + ;MDRT=Med Route from 51.2, OI=Orderable Item + N ORTYPI,ORTYPU,ORTYPP + S ORTYP="",ORTYPI=0,ORTYPU=0,ORTYPP=0 + N DDRG S DDRG=0 F S DDRG=$O(^PSDRUG("ASP",OI,DDRG)) Q:'DDRG D + .I $G(^PSDRUG(DDRG,"I"))]"" Q:^PSDRUG(DDRG,"I")'>DT + .S ORTYP=$$ORTYP(MDRT,DDRG) D + ..I ORTYP["I" S ORTYPI=ORTYPI+1 + ..I ORTYP["U" S ORTYPU=ORTYPU+1 + ..I ORTYP["P" S ORTYPP=ORTYPP+1 + S ORTYP=$S(ORTYPU>ORTYPI:"U",1:"I") S ORTYP=ORTYP_$S(ORTYPP>0:"P",1:"N") + Q ORTYP + ; +STOP(REQST,DURA) ; + ;REQST=Requested start date, DURA=Duration from CPRS + I DURA["L",DURA?1A1".".N S DAYS=$$DAY($E(REQST,1,5)),DURA="H"_((DAYS*$P(DURA,"L",2))*24) + I DURA["L",DURA?1A.1N.N1"."1N.N D Q STOP + .S NUM=$E(REQST,4,5)+$P($P(DURA,"."),"L",2),NUM=$S(NUM<10:"0"_NUM,NUM<13:NUM,1:$S((NUM-12)<10:"0"_(NUM-12),1:(NUM-12))),DATE=$E(REQST,1,3)_NUM + .S DAYS=$$DAY(DATE),STOP=$$SCH^XLFDT($P($P(DURA,"."),"L",2)_"M",$P(REQST,"."))_"."_$P(REQST,".",2),DEL=$P($P(DURA,"L",2),"."),STOP=$$FMADD^XLFDT(STOP,"",((DAYS*$P(DURA,DEL,2))*24)) + I DURA["L" S STOP=$P($$SCH^XLFDT($P(DURA,"L",2)_"M",$P(REQST,".")),".")_"."_$P(REQST,".",2) Q STOP + I DURA["W",DURA["." S DURA="H"_(($P(DURA,"W",2)*7)*24) + I DURA["D",DURA["." S DURA="H"_($P(DURA,"D",2)*24) + I +DURA=DURA,DURA["." S DURA="H"_(DURA*24) + S STOP=$$FMADD^XLFDT(REQST,$S(DURA["W":$P(DURA,"W",2)*7,DURA["D":$P(DURA,"D",2),+DURA=DURA:+DURA,1:""),$S(DURA["H":$P(DURA,"H",2),1:""),$S(DURA["M":$P(DURA,"M",2),1:""),$S(DURA["S":$P(DURA,"S",2),1:"")) + Q STOP +ZQDATE(DATE,MONTHS) ;BUMP DATE BY A MONTH (OR SO) + ;; + S X=$E($P(DATE,"."),1,5)+($E($P(DATE,"."),4,5)>(12-MONTHS)*88+MONTHS)_$E($P(DATE,"."),6,7) F D ^%DT Q:Y>0 S X=X-1 + S NEWDATE=X_"."_$P(DATE,".",2) + Q NEWDATE +DAY(DATE) ;DATE=FIRST FIVE DIGITS OF FM DATE + N X + I DATE'?5N Q -1 + S X=$E(DATE,4,5) I X<1!(X>12) Q -1 + S X=DATE+1+(X=12*88)_"01" + Q $E($$FMADD^XLFDT(X,-1),6,7) diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHLU.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHLU.m index 2128b610..926de2d8 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHLU.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHLU.m @@ -1,118 +1,74 @@ -PSJHLU ;BIR/RLW-UTILITIES USED IN BUILDING HL7 SEGMENTS ;20 Apr 98 / 9:58 AM - ;;5.0; INPATIENT MEDICATIONS ;**1,56,72,102,134**;16 DEC 97;Build 124 - ; - ; Reference to ^PS(52.6 is supported by DBIA# 1231. - ; Reference to ^PS(52.7 is supported by DBIA# 2173. - ; Reference to ^VA(200 is supported by DBIA 10060. - ; Reference to ^PS(55 is supported by DBIA# 2191. - ; -INIT ; set up HL7 application variables - S PSJHLSDT="PS",PSJHINST=$P($$SITE^VASITE(),"^") - S PSJCLEAR="K FIELD F J=0:1:LIMIT S FIELD(J)=""""" - Q - ; -SEGMENT(LIMIT) ; - K SEGMENT - N SUBSEG,SEGLENGT S SUBSEG=0,SEGMENT="" F J=0:1:LIMIT D - .I SEGMENT']"" S SEGMENT=FIELD(J) Q - .S SEGMENT=SEGMENT_"|"_FIELD(J) - F S SEGLENGT=$L(SEGMENT) D Q:$L(SEGMENT)'>246 - .I SEGLENGT'>246 S SEGMENT(SUBSEG)=SEGMENT - .I SEGLENGT>245 S SEGMENT(SUBSEG)=$E(SEGMENT,1,245),SUBSEG=SUBSEG+1 D - ..S SEGMENT=$E(SEGMENT,246,SEGLENGT),SEGMENT(SUBSEG)=$E(SEGMENT,1,245) -SET S PSJI=PSJI+1,^TMP("PSJHLS",$J,PSJHLSDT,PSJI)=SEGMENT(0) - F J=1:1 Q:'$D(SEGMENT(J)) S ^TMP("PSJHLS",$J,PSJHLSDT,PSJI,J)=SEGMENT(J) - Q - ; -SEGMENT2 ; Retrieve text fields - K SEGMENT S JJ=0 F S JJ=$O(@(PSJORDER_"12,"_JJ_")")) Q:'JJ S SEGMENT(JJ-1)=$G(@(PSJORDER_"12,"_JJ_",0)")) - I $D(SEGMENT(0)) S SEGMENT(0)="NTE|6|L|"_$S($G(PSJBCBU):SEGMENT(0),1:$$ESC^ORHLESC(SEGMENT(0))) D - .D SET^PSJHLU K SEGMENT,JJ - I $P($G(@(PSJORDER_"6)")),"^")]"" K SEGMENT S SEGMENT(0)="NTE|21|L|"_$S($G(PSJBCBU):$P($G(@(PSJORDER_"6)")),"^"),1:$$ESC^ORHLESC($P($G(@(PSJORDER_"6)")),"^"))) D - .D SET^PSJHLU K SEGMENT - I PSJORDER["P",$P($G(@(PSJORDER_"9)")),"^",2)]"" K SEGMENT S SEGMENT(0)="NTE|21|L|"_$S($G(PSJBCBU):$P($G(@(PSJORDER_"9)")),"^",2),1:$$ESC^ORHLESC($P($G(@(PSJORDER_"9)")),"^",2))) D - .D SET^PSJHLU K SEGMENT - Q - ; -CALL(HLEVN) ; call DHCP HL7 package -or- protocol, to pass Orders - ; HLEVN = number of segments in message - K CLERK,DDIEN,DDNUM,DOSEFORM,DOSEOR,FIELD,IVTYPE,LIMIT,NAME,NDNODE,NODE1,NODE2,PRODNAME,PROVIDER,PSGS0Y,PSJHINST,PSJHLSDT,PSJI,PSJORDER,PSOC,PSREASON,ROOMBED,SPDIEN,SEGMENT - I $G(PSJBCBU)=1 M PSJNAME=^TMP("PSJHLS",$J,"PS") Q - S PSJMSG="^TMP(""PSJHLS"",$J,""PS"")" - D MSG^XQOR("PS EVSEND OR",.PSJMSG) - Q - ; -IVTYPE(PSJORDER) ; check whether a back-door order is Inpatient IV or IV fluid - I RXORDER["V",$P($G(@(PSJORDER_"0)")),"^",4)'="A" Q "I" - I RXORDER["P" I $P($G(@(PSJORDER_"0)")),"^",4)'="F" S IVTYPE="" Q IVTYPE - N SUB,AD,SOL,IVTYPE,NODE1 S SUB=0,IVTYPE="F" - ;naked reference on line below refers to the full indirect reference of PSJORDER_ which is from ^PS(55,DFN,"IV",PSJORD - F TYPE="AD","SOL" S SUB=0 F S SUB=$O(@(PSJORDER_""""_TYPE_""""_","_SUB_")")) Q:(SUB="")!(IVTYPE="I") S NODE1=$G(^(SUB,0)) Q:NODE1="" D Q:IVTYPE="I" - .I TYPE="AD" D - ..I '$P($G(^PS(52.6,$P(NODE1,"^"),0)),"^",13) S IVTYPE="I" - .D:TYPE="SOL" - ..S:'$P($G(^PS(52.7,$P(NODE1,"^"),0)),"^",13) IVTYPE="I" - Q IVTYPE -ENI ;Calculate Frequency for IV orders - N INFUSE - I X?.E1L.E S INFUSE=$$ENLU^PSGMI(X) Q:(INFUSE="TITRATE")!(INFUSE="BOLUS")!($P(INFUSE," ")="INFUSE")!($P(INFUSE," ")="Infuse") - Q:(X="TITRATE")!(X="BOLUS")!($P(X," ")="INFUSE")!($P(X," ")="Infuse") - Q:$$INTRMT(X) - K:$L(X)<1!($L(X)>30)!(X["""")!($A(X)=45) X I '$D(X) Q - I X["=" D Q ; NOIS LOU-0501-42191 - .N X2,X1 S X1=$P(X,"="),X2=$P(X,"=",2) - .I X1["ML/HR",(+X1=$P(X1,"ML/HR"))!(+X1=$P(X1," ML/HR")) D - ..S X1=$TR(X1,"ML/HR","ml/hr") - .I X2["ML/HR",(+X2=$P(X2,"ML/HR"))!(+X2=$P(X2," ML/HR")) D - ..S X2=$TR(X2,"ML/HR","ml/hr") - .I X1[" ml/hr",(+X1=$P(X1," ml/hr")) D - ..S X1=$P(X1," ml/hr")_$P(X1," ml/hr",2,9999) - .I X2[" ml/hr",(+X2=$P(X2," ml/hr")) D - ..S X2=$P(X2," ml/hr")_$P(X2," ml/hr",2,9999) - .I X1["ml/hr",(+X1=$P(X1,"ml/hr")) D - ..S X1=$P(X1,"ml/hr")_$P(X1,"ml/hr",2,9999) - .I X2["ml/hr",(+X2=$P(X2,"ml/hr")) D - ..S X2=$P(X2,"ml/hr")_$P(X2,"ml/hr",2,9999) - .I X2'=+X2 D - ..I ($P(X2,"@",2,999)'=+$P(X2,"@",2,999)!(+$P(X2,"@",2,999)<0)) K X Q - .I X1=+X1 S X1=X1_" ml/hr" - .I X2=+X2 S X2=X2_" ml/hr" - .S:$P(X2,"@")=+X2 $P(X2,"@")=$P(X2,"@")_" ml/hr" - .S X=X1_"="_X2 - I X'=+X,($P($TR(X," ml/hr",""),"@",2,999)'=+$P($TR(X," ml/hr",""),"@",2,999)!(+$P(X,"@",2,999)<0)),($P(X," ml/hr")'=+$P(X," ml/hr")!(+$P(X," ml/hr")<0)) Q:(X>0&($E(X)=0)) K X Q - I X=+X!(X>0&($E(X)=0)) S X=X_" ml/hr" D SPSOL S FREQ=$S('X:0,1:SPSOL\X*60+(SPSOL#X/X*60+.5)\1) K SPSOL Q - I X[" ml/hr" D SPSOL S FREQ=$S('X:0,1:SPSOL\X*60+(SPSOL#X/X*60+.5)\1) K SPSOL Q - S SPSOL=$P(X,"@",2) S:$P(X,"@")=+X $P(X,"@")=$P(X,"@")_" ml/hr" S FREQ=$S('SPSOL:0,1:1440/SPSOL\1) K SPSOL - Q -SPSOL S SPSOL=+TVOLUME Q -INTRMT(X) ; - Q:'$P(X," ") 0 - Q:$P(X," ",2)="Minutes" 1 - Q:$P(X," ",2)="Hours" 1 - Q 0 -IVCAT(DFN,PSJORD,PARRAY) ; This returns the IV CATEGORY based on the IV TYPE and CHEMO TYPE (not what is already in the IV CATEGORY field) - ; Passed in: PSJORDER (file root of order) - N NODE,TYP,CHEMTYP,INTSYR,ND2P5 - S (CHEMTYP,INTSYR)="" - S TYP=$G(P(4)),INTSYR=$G(P(5)),CHEMTYP=$G(P(23)) - I TYP="",$G(PSJORD)["V" S NODE=$G(^PS(55,DFN,"IV",+PSJORD,0)) S TYP=$P(NODE,"^",4),INTSYR=$P(NODE,"^",5),CHEMTYP=$P(NODE,"^",23) - I TYP="",$G(PSJORD)["P" S NODE=$G(^PS(53.1,+PSJORD,8)) S TYP=$P(NODE,"^"),INTSYR=$P(NODE,"^",4),CHEMTYP=$P(NODE,"^",2) - I TYP="" S TYP=$G(PARRAY(4)),INTSYR=$G(PARRAY(5)),CHEMTYP=$G(PARRAY(23)) - Q:$G(TYP)="" "" - S CAT=$S(",A,H,"[(","_TYP_","):"C",TYP="C"&(",A,H,S,"[(","_CHEMTYP_",")&'INTSYR):"C",TYP="C"&(CHEMTYP="P"):"I",TYP="S"&'INTSYR:"C",TYP="P":"I",$G(INTSYR):"I",1:"") - Q CAT -ZRX ; Perform outbound processing - S LIMIT=6 X PSJCLEAR - S FIELD(0)="ZRX" - I '$G(PSJREN) N PREON,PSJREN I $G(PSJORD)["U"&($P(NODE1,"^",24)="R") S PSJREN=1 - I $G(PSJORD)["V"&($P(NODE2,"^",8)="R") S PSJREN=1 - S PREON=$S($G(PSJREN):$G(PSJORD),PSJORDER["IV":$P(NODE2,"^",5),1:$P(NODE1,"^",25)) - S FIELD(1)=$S(PREON["P":$P($G(^PS(53.1,+PREON,0)),"^",21),PREON["V":$P($G(^PS(55,PSJHLDFN,"IV",+PREON,0)),"^",21),1:$P($G(^PS(55,PSJHLDFN,5,+PREON,0)),"^",21)) - S FIELD(2)=$S(PSJORDER["IV":$G(P("NAT")),1:$G(PSJNOO)) - S FIELD(3)=$S($G(PSJREN):"R",PSJORDER["IV":$P(NODE2,"^",8),1:$P(NODE1,"^",24)) - I FIELD(3)="" I PSOC="SN" S FIELD(3)="N" - I $D(P)>1 S FIELD(6)=$$IVCAT^PSJHLU(PSJHLDFN,RXORDER,.P) - S NAME=$P($G(^VA(200,DUZ,0)),"^") - S FIELD(5)=DUZ_"^"_$S($G(PSJBCBU):NAME,1:$$ESC^ORHLESC(NAME))_"^"_"99NP" - D SEGMENT^PSJHLU(LIMIT),DISPLAY^PSJHL2 - Q +PSJHLU ;BIR/RLW-UTILITIES USED IN BUILDING HL7 SEGMENTS ;20 Apr 98 / 9:58 AM + ;;5.0; INPATIENT MEDICATIONS ;**1,56,72,102**;16 DEC 97 + ; + ; Reference to ^PS(52.6 is supported by DBIA# 1231. + ; Reference to ^PS(52.7 is supported by DBIA# 2173. + ; +INIT ; set up HL7 application variables + S PSJHLSDT="PS",PSJHINST=$P($$SITE^VASITE(),"^") + S PSJCLEAR="K FIELD F J=0:1:LIMIT S FIELD(J)=""""" + Q + ; +SEGMENT(LIMIT) ; + K SEGMENT + N SUBSEG,SEGLENGT S SUBSEG=0,SEGMENT="" F J=0:1:LIMIT D + .I SEGMENT']"" S SEGMENT=FIELD(J) Q + .S SEGMENT=SEGMENT_"|"_FIELD(J) + F S SEGLENGT=$L(SEGMENT) D Q:$L(SEGMENT)'>246 + .I SEGLENGT'>246 S SEGMENT(SUBSEG)=SEGMENT + .I SEGLENGT>245 S SEGMENT(SUBSEG)=$E(SEGMENT,1,245),SUBSEG=SUBSEG+1 D + ..S SEGMENT=$E(SEGMENT,246,SEGLENGT),SEGMENT(SUBSEG)=$E(SEGMENT,1,245) +SET S PSJI=PSJI+1,^TMP("PSJHLS",$J,PSJHLSDT,PSJI)=SEGMENT(0) + F J=1:1 Q:'$D(SEGMENT(J)) S ^TMP("PSJHLS",$J,PSJHLSDT,PSJI,J)=SEGMENT(J) + Q + ; +CALL(HLEVN) ; call DHCP HL7 package -or- protocol, to pass Orders + ; HLEVN = number of segments in message + K CLERK,DDIEN,DDNUM,DOSEFORM,DOSEOR,FIELD,IVTYPE,LIMIT,NAME,NDNODE,NODE1,NODE2,PRODNAME,PROVIDER,PSGS0Y,PSJHINST,PSJHLSDT,PSJI,PSJORDER,PSOC,PSREASON,ROOMBED,SPDIEN,SEGMENT + I $G(PSJBCBU)=1 M PSJNAME=^TMP("PSJHLS",$J,"PS") Q + S PSJMSG="^TMP(""PSJHLS"",$J,""PS"")" + D MSG^XQOR("PS EVSEND OR",.PSJMSG) + Q + ; +IVTYPE(PSJORDER) ; check whether a back-door order is Inpatient IV or IV fluid + I RXORDER["V",$P($G(@(PSJORDER_"0)")),"^",4)'="A" Q "I" + I RXORDER["P" I $P($G(@(PSJORDER_"0)")),"^",4)'="F" S IVTYPE="" Q IVTYPE + N SUB,AD,SOL,IVTYPE,NODE1 S SUB=0,IVTYPE="F" + ;naked reference on line below refers to the full indirect reference of PSJORDER_... + F TYPE="AD","SOL" S SUB=0 F S SUB=$O(@(PSJORDER_""""_TYPE_""""_","_SUB_")")) Q:(SUB="")!(IVTYPE="I") S NODE1=$G(^(SUB,0)) Q:NODE1="" D Q:IVTYPE="I" + .I TYPE="AD" D + ..I '$P($G(^PS(52.6,$P(NODE1,"^"),0)),"^",13) S IVTYPE="I" + .D:TYPE="SOL" + ..S:'$P($G(^PS(52.7,$P(NODE1,"^"),0)),"^",13) IVTYPE="I" + Q IVTYPE +ENI ;Calculate Frequency for IV orders + N INFUSE + K:$L(X)<1!($L(X)>30)!(X["""")!($A(X)=45) X I '$D(X) Q + I X?.E1L.E S INFUSE=$$ENLU^PSGMI(X) Q:(INFUSE="TITRATE")!(INFUSE="BOLUS") + Q:(X="TITRATE")!(X="BOLUS") + I X["=" D Q ; NOIS LOU-0501-42191 + .N X2,X1 S X1=$P(X,"="),X2=$P(X,"=",2) + .I X1["ML/HR",(+X1=$P(X1,"ML/HR"))!(+X1=$P(X1," ML/HR")) D + ..S X1=$TR(X1,"ML/HR","ml/hr") + .I X2["ML/HR",(+X2=$P(X2,"ML/HR"))!(+X2=$P(X2," ML/HR")) D + ..S X2=$TR(X2,"ML/HR","ml/hr") + .I X1[" ml/hr",(+X1=$P(X1," ml/hr")) D + ..S X1=$P(X1," ml/hr")_$P(X1," ml/hr",2,9999) + .I X2[" ml/hr",(+X2=$P(X2," ml/hr")) D + ..S X2=$P(X2," ml/hr")_$P(X2," ml/hr",2,9999) + .I X1["ml/hr",(+X1=$P(X1,"ml/hr")) D + ..S X1=$P(X1,"ml/hr")_$P(X1,"ml/hr",2,9999) + .I X2["ml/hr",(+X2=$P(X2,"ml/hr")) D + ..S X2=$P(X2,"ml/hr")_$P(X2,"ml/hr",2,9999) + .I X2'=+X2 D + ..I ($P(X2,"@",2,999)'=+$P(X2,"@",2,999)!(+$P(X2,"@",2,999)<0)) K X Q + .I X1=+X1 S X1=X1_" ml/hr" + .I X2=+X2 S X2=X2_" ml/hr" + .S:$P(X2,"@")=+X2 $P(X2,"@")=$P(X2,"@")_" ml/hr" + .S X=X1_"="_X2 + I X'=+X,($P(X,"@",2,999)'=+$P(X,"@",2,999)!(+$P(X,"@",2,999)<0)),($P(X," ml/hr")'=+$P(X," ml/hr")!(+$P(X," ml/hr")<0)) K X Q + I X=+X S X=X_" ml/hr" D SPSOL S FREQ=$S('X:0,1:SPSOL\X*60+(SPSOL#X/X*60+.5)\1) K SPSOL Q + I X[" ml/hr" D SPSOL S FREQ=$S('X:0,1:SPSOL\X*60+(SPSOL#X/X*60+.5)\1) K SPSOL Q + S SPSOL=$P(X,"@",2) S:$P(X,"@")=+X $P(X,"@")=$P(X,"@")_" ml/hr" S FREQ=$S('SPSOL:0,1:1440/SPSOL\1) K SPSOL + Q +SPSOL S SPSOL=+TVOLUME Q diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLIACT.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLIACT.m index ad014a10..44805cbc 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLIACT.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLIACT.m @@ -1,151 +1,154 @@ -PSJLIACT ;BIR/MV-IV ACTION ;28 Jul 98 / 8:50 AM - ;;5.0; INPATIENT MEDICATIONS ;**15,47,62,58,82,97,80,110,111,134**;16 DEC 97;Build 124 - ; - ; Reference to ^PS(55 is supported by DBIA 2191. - ; Reference to MAIN^TIUEDIT is supported by DBIA 2410. - ; -DC ; Discontinue order - D HOLDHDR^PSJOE - S PSJCOM=+$S(PSJORD["V":$P($G(^PS(55,DFN,"IV",+PSJORD,.2)),"^",8),1:$P($G(^PS(53.1,+PSJORD,.2)),"^",8)) - I PSJCOM W !!,"This order is part of a complex order. If you discontinue this order the",!,"following orders will be discontinued too (unless the stop date has already",!,"been reached)." D CMPLX^PSJCOM1(PSGP,PSJCOM,PSJORD) - I PSJCOM F W !!,"Do you want to discontinue this order" S %=1 D YN^DICN Q:% D ENCOM^PSGOEM - I PSJCOM,%'=1 S VALMBK="" Q - I PSJORD["V" D DC^PSIVORA,EN^PSJLIORD(DFN,ON) Q - D:PSJORD["P" DISCONT^PSIVORC - S VALMBCK="Q" - Q -ACEDIT ; Display LM screen and AC and EDit actions - D EN^PSJLIVMD - S VALMBCK=$S($G(PSIVACEP):"Q",1:"R") - Q -AEEXIT ; Call for EXIT CODE in PSJ LM IV AC/EDIT - D:ON["V" GT55^PSIVORFB - I ON["P" D GT531^PSIVORFA(DFN,ON) D:P("OT")'="I" GTDATA^PSJLIFN - D EN^PSJLIVMD - K PSIVENO - Q -EDIT ; Edit order - K PSIVFN1 NEW PSIVNBD - I $D(PSGACT),PSGACT'["E" W !,"This order may not be edited." D PAUSE^VALM1 Q - D EDIT1 - Q:$D(PSIVNBD)!($G(PSIVCOPY)&'$G(PSIVENO)) - D EN^PSJLIVMD - S VALMBCK=$S($G(PSIVFN1):"Q",1:"R") - Q -EDIT1 ; - ;Ensure P() is defined - I $D(P)<10 S XQORQUIT=1,P("PON")="",PSIVNBD=1 D Q - .W !,"WARNING: An error has occurred. Changes will not be saved" - .D PAUSE^VALM1 - .S VALMBCK="Q" - I "ANP"'[P(17) W !,"You cannot edit an inactive order" D PAUSE^VALM1 Q - S:$G(ON55)="" ON55=$G(PSJORD) - D HOLDHDR^PSJOE - ;* Edit a new back door order - I ($G(ON55)["V"&($G(P("21FLG"))="")) D Q - . D GSTRING^PSIVORE1,GTFLDS^PSIVORFE - . I $G(ON55)["V",'$G(DONE) D OK^PSIVORE - . S VALMBCK="Q",PSIVNBD=1 - ;* Edit an active order - I $G(ON55)["V" NEW PSJEDIT1 D E^PSIVOPT1 D Q - . I $G(PSJIVBD) K PSJIVBD D EN^PSJLIORD(DFN,ON) - I $G(ON55)["P" D EDIT^PSIVORC ;Edit incomplete order. - K P("OVRIDE") - Q -ACCEPT ; Accept order - D HOLDHDR^PSJOE - ;Accept IV from back door. - I $G(PSJIVBD) K PSJIVBD D OK^PSIVORE S VALMBCK="Q" Q - I ON["V" D ACCEPT^PSIVOPT1 Q - S PSIVFN1=1 - D COMPLTE^PSIVORC1 - S VALMBCK="Q" - Q -R ; Renewal - S PSJREN=1 - D HOLDHDR^PSJOE - NEW PSIVAC S PSIVAC="PR" K PSGFDX - D R^PSIVOPT - D EN^PSJLIORD(DFN,ON) - K PSJREN - Q -H ; Hold - NEW TEX S TEX="Active order ***" - D HOLDHDR^PSJOE - D H^PSIVOPT(DFN,ON,P(17),P(3)) - D:P(17)="A" PAUSE^VALM1 - D EN^PSJLIORD(DFN,ON) - Q -L ; Activity Log - NEW PSIVLAB,PSIVLOG,PSJHIS S (PSIVLAB,PSIVLOG)=1 - D EN^PSIVVW1 - D EN^PSJLIVMD - S VALMBCK="R" - Q -O ; On Call - NEW TEX S TEX="Active order ***" - D HOLDHDR^PSJOE - D O^PSIVOPT(DFN,ON,P(17),P(3)) - D:P(17)="A" PAUSE^VALM1 - D EN^PSJLIORD(DFN,ON) - Q -VF ; Make the order active - NEW PSIVCHG S PSIVCHG=0 - I ON["V" S ON55=ON D VF1("V","ORDER VERIFIED BY ",1) Q - D ACTIVE^PSIVORC2 - Q -VF1(PSIVREA,PSIVAL,PSIVLOG) ; - ;Update 4 node and set activity log. - ;PSIVREA: the reason use by LOG^PSIVORAL - ;PSIVAL : the description reason - ;PSIVLOG: Log an activity if = 1 - I '+$G(OD)!($L($G(OD))>16) K OD - D:+PSJSYSU=3 ^PSIVORE1 - NEW DIE,DA,DR,PSJX,XX,PSIVACT,PSJRQND - S PSIVACT=1 - S PSJX=$G(^PS(55,DFN,"IV",+ON55,4)),XX="" - I $P(PSJX,U)="" S XX=";143////0" - I $P(PSJX,U,4)="" S XX=XX_U_";142////0" - D NOW^%DTC - S DIE="^PS(55,"_DFN_",""IV"",",DA=+ON55,DA(1)=DFN - I +PSJSYSU=3 S DR="140////"_DUZ_";141////"_$E(%,1,12)_";142////1"_$P(XX,U) - I +PSJSYSU=1 S DR="16////"_DUZ_";17////"_$E(%,1,12)_";143////1"_$P(XX,U,2) - I $G(P("PRY"))="D" S DR=DR_";.22////"_+P("IVRM") - D ^DIE - ; If pending IV renew is edited during finish, go back and DE the original active order left in RENEWED status - S PREREN=$S(ON55["V":$G(@(DIE_"+ON55,2)")),1:""),PREREN=$P(PREREN,"^",5) I PREREN D K PREREN - . I PREREN["P" S PREREN=$G(@("^PS(53.1,+PREREN,0)")),PREREN=$P(PREREN,"^",25) - . I PREREN["V" N PRERENOD S PRERENOD=$G(@("^PS(55,DFN,""IV"",+PREREN,0)")) I $P(PRERENOD,"^",17)="R",($G(P("RES"))="E") D - .. S DIE="^PS(55,"_DFN_",""IV"",",DA=+PREREN,DA(1)=DFN - .. S DR="100////D;.03////"_PSGDT S ORIGSTOP=$P($G(@("^PS(55,DFN,""IV"",+PREREN,2)")),"^",3) I ORIGSTOP S DR=DR_";116////"_ORIGSTOP - .. D ^DIE D EN1^PSJHL2(DFN,"SC",PREREN) - K DR,DIE,DA - I (+PSJSYSU=3)&($G(P("PRY"))="D") D - .N DIR W ! S DIR(0)="S^Y:Yes;N:No",DIR("A")="Do you want to enter a Progress Note",DIR("B")="No" D ^DIR - .Q:Y="N" - .D MAIN^TIUEDIT(3,.TIUDA,DFN,"","","","",1) - Q:'$G(PSIVLOG) - I $G(P("PACT"))]"",+$P(P("PACT"),U,2),+$P(P("PACT"),U,3) D - . NEW DIC,DA,X,Y,XX,DO D NAME^PSJBCMA1($P(P("PACT"),U,2),.XX) - . S DIC(0)="L",DA(1)=DFN,DA(2)=+ON55,X=1 - . S DIC="^PS(55,"_DA(1)_",""IV"","_DA(2)_",""A""," - . S DIC("DR")=".02////F;.03////"_XX_";.04////"_$P($G(^PS(53.3,+$P(P("PACT"),U,3),0)),U)_";.05////"_$P(P("PACT"),U)_";.06////"_$P(P("PACT"),U,2) - . D FILE^DICN - NEW PSIVALCK - S PSIVREA="V",PSIVALT="" - S PSIVAL=PSIVAL_$S(+PSJSYSU=3:"PHARMACIST",1:"NURSE") - D LOG^PSIVORAL K PSIVAL,PSIVREA,PSIVLN - I $G(PSJORD)["P" S PSIVREA="V",PSIVALT="",PSGRDTX=$G(^PS(53.1,+PSJORD,2.5)) D - . I $G(PSGRDTX) S PSIVAL="Requested Start Date: "_$$ENDTC^PSGMI($$DATE2^PSJUTL2($P(PSGRDTX,U))) D LOG^PSIVORAL - . I $P(PSGRDTX,U,3) S PSIVREA="V",PSIVALT="" S PSIVAL="Requested Stop Date: "_$$ENDTC^PSGMI($$DATE2^PSJUTL2($P(PSGRDTX,U,3))) D LOG^PSIVORAL - N DUR I $G(PSJORD) S DUR=$$GETDUR^PSJLIVMD(DFN,+PSJORD,$S(PSJORD["P":"P",1:"IV"),1) I DUR]"" D - . K DR S DIE="^PS(55,"_DFN_",""IV"",",DA=+ON55,DA(1)=DFN - . S DR=$S($G(IVLIMIT):"152////"_DUR,1:"151////"_DUR) K IVLIMIT - . D ^DIE - D EN1^PSJHL2(DFN,"SC",ON55) - D:+PSJSYSU=1 EN1^PSJHL2(DFN,"ZV",ON55) - D GT55^PSIVORFB S OLDON=$P($G(^PS(55,DFN,"IV",+ON55,2)),"^",5),P("OLDON")=OLDON - N PSJPRIO,PSJSCH,NODE0,NODEP2 S NODE0=$G(^PS(55,DFN,"IV",+ON55,0)),NODEP2=$G(^PS(55,DFN,"IV",+ON55,.2)) - S PSJPRIO=$P(NODEP2,"^",4),PSJSCH=$P(NODE0,"^",9) - I (",S,A,")[(","_$G(PSJPRIO)_",")!($G(PSJSCH)="NOW")!($G(PSJSCH)["STAT") D NOTIFY^PSJHL4(ON55,DFN,$G(PSJPRIO),$G(PSJSCH)) - Q +PSJLIACT ;BIR/MV-IV ACTION ;28 Jul 98 / 8:50 AM + ;;5.0; INPATIENT MEDICATIONS ;**15,47,62,58,82,97,80,110,111**;16 DEC 97 + ; + ; Reference to ^PS(55 is supported by DBIA 2191. + ; Reference to MAIN^TIUEDIT is supported by DBIA 2410. + ; +DC ; Discontinue order + D HOLDHDR^PSJOE + S PSJCOM=+$S(PSJORD["V":$P($G(^PS(55,DFN,"IV",+PSJORD,.2)),"^",8),1:$P($G(^PS(53.1,+PSJORD,.2)),"^",8)) + I PSJCOM W !!,"This order is part of a complex order. If you discontinue this order the",!,"following orders will be discontinued too (unless the stop date has already",!,"been reached)." D CMPLX^PSJCOM1(PSGP,PSJCOM,PSJORD) + I PSJCOM F W !!,"Do you want to discontinue this order" S %=1 D YN^DICN Q:% D ENCOM^PSGOEM + I PSJCOM,%'=1 S VALMBK="" Q + I PSJORD["V" D DC^PSIVORA,EN^PSJLIORD(DFN,ON) Q + D:PSJORD["P" DISCONT^PSIVORC + S VALMBCK="Q" + Q +ACEDIT ; Display LM screen and AC and EDit actions + ;K PSIVFN1 ; if not set display the second screen when finish. + D EN^PSJLIVMD + S VALMBCK=$S($G(PSIVACEP):"Q",1:"R") + Q +AEEXIT ; Call for EXIT CODE in PSJ LM IV AC/EDIT + D:ON["V" GT55^PSIVORFB + I ON["P" D GT531^PSIVORFA(DFN,ON) D:P("OT")'="I" GTDATA^PSJLIFN + D EN^PSJLIVMD + K PSIVENO + Q +EDIT ; Edit order + K PSIVFN1 NEW PSIVNBD + I $D(PSGACT),PSGACT'["E" W !,"This order may not be edited." D PAUSE^VALM1 Q + D EDIT1 + ;Q:$D(PSIVNBD) + Q:$D(PSIVNBD)!($G(PSIVCOPY)&'$G(PSIVENO)) + D EN^PSJLIVMD + S VALMBCK=$S($G(PSIVFN1):"Q",1:"R") + Q +EDIT1 ; + ;Ensure P() is defined + I $D(P)<10 S XQORQUIT=1,P("PON")="",PSIVNBD=1 D Q + .W !,"WARNING: An error has occurred. Changes will not be saved" + .D PAUSE^VALM1 + .S VALMBCK="Q" + I "ANP"'[P(17) W !,"You cannot edit an inactive order" D PAUSE^VALM1 Q + S:$G(ON55)="" ON55=$G(PSJORD) + D HOLDHDR^PSJOE + ;* Edit a new back door order + ;;I ($G(ON55)["V"&($G(P(21))="")) D Q + I ($G(ON55)["V"&($G(P("21FLG"))="")) D Q + . D GSTRING^PSIVORE1,GTFLDS^PSIVORFE + . I $G(ON55)["V",'$G(DONE) D OK^PSIVORE + . S VALMBCK="Q",PSIVNBD=1 + ;* Edit an active order + I $G(ON55)["V" NEW PSJEDIT1 D E^PSIVOPT1 D Q + . I $G(PSJIVBD) K PSJIVBD D EN^PSJLIORD(DFN,ON) + I $G(ON55)["P" D EDIT^PSIVORC ;Edit incomplete order. + Q +ACCEPT ; Accept order + D HOLDHDR^PSJOE + ;Accept IV from back door. + I $G(PSJIVBD) K PSJIVBD D OK^PSIVORE S VALMBCK="Q" Q + I ON["V" D ACCEPT^PSIVOPT1 Q + S PSIVFN1=1 + D COMPLTE^PSIVORC1 + S VALMBCK="Q" + Q +R ; Renewal + S PSJREN=1 + D HOLDHDR^PSJOE + NEW PSIVAC S PSIVAC="PR" K PSGFDX + D R^PSIVOPT + D EN^PSJLIORD(DFN,ON) + K PSJREN + Q +H ; Hold + NEW TEX S TEX="Active order ***" + D HOLDHDR^PSJOE + D H^PSIVOPT(DFN,ON,P(17),P(3)) + D:P(17)="A" PAUSE^VALM1 + D EN^PSJLIORD(DFN,ON) + Q +L ; Activity Log + NEW PSIVLAB,PSIVLOG,PSJHIS S (PSIVLAB,PSIVLOG)=1 + D EN^PSIVVW1 + D EN^PSJLIVMD + S VALMBCK="R" + Q +O ; On Call + NEW TEX S TEX="Active order ***" + D HOLDHDR^PSJOE + D O^PSIVOPT(DFN,ON,P(17),P(3)) + D:P(17)="A" PAUSE^VALM1 + D EN^PSJLIORD(DFN,ON) + Q +VF ; Make the order active + NEW PSIVCHG S PSIVCHG=0 + I ON["V" S ON55=ON D VF1("V","ORDER VERIFIED BY ",1) Q + D ACTIVE^PSIVORC2 + Q +VF1(PSIVREA,PSIVAL,PSIVLOG) ; + ;Update 4 node and set activity log. + ;PSIVREA: the reason use by LOG^PSIVORAL + ;PSIVAL : the description reason + ;PSIVLOG: Log an activity if = 1 + I '+$G(OD)!($L($G(OD))>16) K OD + D:+PSJSYSU=3 ^PSIVORE1 + NEW DIE,DA,DR,PSJX,XX,PSIVACT,PSJRQND + S PSIVACT=1 + S PSJX=$G(^PS(55,DFN,"IV",+ON55,4)),XX="" + I $P(PSJX,U)="" S XX=";143////0" + I $P(PSJX,U,4)="" S XX=XX_U_";142////0" + D NOW^%DTC + S DIE="^PS(55,"_DFN_",""IV"",",DA=+ON55,DA(1)=DFN + I +PSJSYSU=3 S DR="140////"_DUZ_";141////"_$E(%,1,12)_";142////1"_$P(XX,U) + I +PSJSYSU=1 S DR="16////"_DUZ_";17////"_$E(%,1,12)_";143////1"_$P(XX,U,2) + I $G(P("PRY"))="D" S DR=DR_";.22////"_+P("IVRM") + D ^DIE + ; If pending IV renew is edited during finish, go back and DE the original active order left in RENEWED status + S PREREN=$S(ON55["V":$G(@(DIE_"+ON55,2)")),1:""),PREREN=$P(PREREN,"^",5) I PREREN D K PREREN + . I PREREN["P" S PREREN=$G(@("^PS(53.1,+PREREN,0)")),PREREN=$P(PREREN,"^",25) + . I PREREN["V" N PRERENOD S PRERENOD=$G(@("^PS(55,DFN,""IV"",+PREREN,0)")) I $P(PRERENOD,"^",17)="R",($G(P("RES"))="E") D + .. S DIE="^PS(55,"_DFN_",""IV"",",DA=+PREREN,DA(1)=DFN + .. S DR="100////D;.03////"_PSGDT S ORIGSTOP=$P($G(@("^PS(55,DFN,""IV"",+PREREN,2)")),"^",3) I ORIGSTOP S DR=DR_";116////"_ORIGSTOP + .. D ^DIE D EN1^PSJHL2(DFN,"SC",PREREN) + K DR,DIE,DA + ;I ((+PSJSYSU=3)&($G(PSJPRI)="D"))!((+PSJSYSU=3)&($G(P("PRY"))="D")) D + I (+PSJSYSU=3)&($G(P("PRY"))="D") D + .N DIR W ! S DIR(0)="S^Y:Yes;N:No",DIR("A")="Do you want to enter a Progress Note",DIR("B")="No" D ^DIR + .Q:Y="N" + .D MAIN^TIUEDIT(3,.TIUDA,DFN,"","","","",1) + Q:'$G(PSIVLOG) + I $G(P("PACT"))]"",+$P(P("PACT"),U,2),+$P(P("PACT"),U,3) D + . NEW DIC,DA,X,Y,XX,DO D NAME^PSJBCMA1($P(P("PACT"),U,2),.XX) + . S DIC(0)="L",DA(1)=DFN,DA(2)=+ON55,X=1 + . S DIC="^PS(55,"_DA(1)_",""IV"","_DA(2)_",""A""," + . S DIC("DR")=".02////F;.03////"_XX_";.04////"_$P($G(^PS(53.3,+$P(P("PACT"),U,3),0)),U)_";.05////"_$P(P("PACT"),U)_";.06////"_$P(P("PACT"),U,2) + . D FILE^DICN + NEW PSIVALCK + S PSIVREA="V",PSIVALT="" + S PSIVAL=PSIVAL_$S(+PSJSYSU=3:"PHARMACIST",1:"NURSE") + D LOG^PSIVORAL K PSIVAL,PSIVREA,PSIVLN + I $G(PSJORD)["P" S PSIVREA="V",PSIVALT="",PSGRDTX=$G(^PS(53.1,+PSJORD,2.5)) D + . I $G(PSGRDTX) S PSIVAL="Requested Start Date: "_$$ENDTC^PSGMI($$DATE2^PSJUTL2($P(PSGRDTX,U))) D LOG^PSIVORAL + . I $P(PSGRDTX,U,3) S PSIVREA="V",PSIVALT="" S PSIVAL="Requested Stop Date: "_$$ENDTC^PSGMI($$DATE2^PSJUTL2($P(PSGRDTX,U,3))) D LOG^PSIVORAL + N DUR I $G(PSJORD) S DUR=$$GETDUR^PSJLIVMD(DFN,+PSJORD,$S(PSJORD["P":"P",1:"IV"),1) I DUR]"" D + . K DR S DIE="^PS(55,"_DFN_",""IV"",",DA=+ON55,DA(1)=DFN + . S DR=$S($G(IVLIMIT):"152////"_DUR,1:"151////"_DUR) K IVLIMIT + . D ^DIE + D EN1^PSJHL2(DFN,"SC",ON55) + D:+PSJSYSU=1 EN1^PSJHL2(DFN,"ZV",ON55) + D GT55^PSIVORFB S OLDON=$P($G(^PS(55,DFN,"IV",+ON55,2)),"^",5),P("OLDON")=OLDON + N PSJPRIO,PSJSCH,NODE0,NODEP2 S NODE0=$G(^PS(55,DFN,"IV",+ON55,0)),NODEP2=$G(^PS(55,DFN,"IV",+ON55,.2)) + S PSJPRIO=$P(NODEP2,"^",4),PSJSCH=$P(NODE0,"^",9) + I (",S,A,")[(","_$G(PSJPRIO)_",")!($G(PSJSCH)="NOW")!($G(PSJSCH)["STAT") D NOTIFY^PSJHL4(ON55,DFN,$G(PSJPRIO),$G(PSJSCH)) + Q diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLIVFD.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLIVFD.m index f169049c..e5c2db6e 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLIVFD.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLIVFD.m @@ -1,145 +1,146 @@ -PSJLIVFD ;BIR/MV-SETUP LM TEMPLATE FOR IV FLUID ;4 Aug 00 / 2:37 PM - ;;5.0; INPATIENT MEDICATIONS ;**7,50,63,64,58,81,91,80,116,110,111,180,134**;16 DEC 97;Build 124 - ; - ; Reference to ^VALM0 is supported by DBIA # 2615. - ; - ;NFI changes for FR# 3@AD+4 - ; -EN ; Build LM template to display IV order. - K ^TMP("PSJI",$J) - S UL80="",$P(UL80,"=",80)="" - S PSJLN=1 -AD ; - NEW VALMEVL S VALMEVL=1 - S PSJL="" D FLDNO^PSJLIUTL("(1)",1) - S PSJL=PSJL_"Additives:" - S:$G(P("PON"))["V"&(P(17)'="N") PSJL=$$SETSTR^VALM1("Order number:",PSJL,30,14)_+P("PON") - S PSJL=$$SETSTR^VALM1("Type:",PSJL,57,6)_$$TYPE^PSJLIUTL - NEW PSJVD S PSJVD=$$DINFLIV^PSJDIN(.DRG) - S PSJL=$$SETSTR^VALM1(PSJVD,PSJL,75,6) - I '$D(IORVON),$D(IOST(0)) D ENS^%ZISS,TERM^VALM0 - I $D(IORVON),(PSJVD]"") D CNTRL^VALM10(1,76,5,IORVON,IORVOFF,0) K PSJVD - D SETTMP^PSJLMPRU("PSJI",PSJL) - D:+$G(PSJLMX) CLRDSPL^PSJLIVMD - ;PSJLMX count number of lines needed to display the add/sol - S PSJLMX=0 D WRTDRG^PSJLIUTL("AD") -SOL ; - S PSJL="" D FLDNO^PSJLIUTL("(2)",1) - S PSJL=PSJL_"Solutions:" - I P("SYRS")]"" D - . S PSJL=$$SETSTR^VALM1("Syr. Size:",PSJL,52,10)_$E(P("SYRS"),1,13) - . S:$L(P("SYRS"))>13 PSJL=PSJL_"..." - D SETTMP^PSJLMPRU("PSJI",PSJL) - D WRTDRG^PSJLIUTL("SOL") -DUR ; - S PSJL="" - N DUROUT,IVLIMIT S DUROUT=$$GETDUR^PSJLIVMD(PSGP,+PSJORD,$S(PSJORD["P":"P",1:"IV")) - I $G(PSJORD)["P" N ND25 S ND25=$G(^PS(53.1,+PSJORD,2.5)),IVLIMIT=$P(ND25,"^",4) D - .S IVLIMIT=$S(IVLIMIT]"":$$FMTDUR^PSJLIVMD(IVLIMIT),1:"") S:IVLIMIT]"" DUROUT=IVLIMIT - S LABEL=$S($G(IVLIMIT):"IV Limit: ",1:"Duration: ") K IVLIMIT - S PSJL=$$SETSTR^VALM1(LABEL,PSJL,12,10) - S PSJL=PSJL_DUROUT -START ; - D FLDNO^PSJLIUTL("(4)",47) - S PSJL=$$SETSTR^VALM1("Start:",PSJL,56,7)_$$STARTDT^PSJLIUTL - D SETTMP^PSJLMPRU("PSJI",PSJL) - NEW PSGRSD,PSGRSDN,PSGRFD,PSGRFDN - S PSJL="" I $G(PSJORD)["P",$G(PSGRDTX) D - . N RSDLABL,PSJRQB,PSJRQL,PSGRSD,PSGSRSDN - . S RSDLABL=" REQUESTED START: ",PSJRQB=41,PSJRQL=39,PSGRSD="",PSGRSDN="" - . I $G(PSGRDTX(+$G(PSJORD),"PSGRSD")),$G(P(2)) S PSJRQB=51,PSJRQL=29 D - .. S PSGRSD=PSGRDTX(+$G(PSJORD),"PSGRSD"),PSGRSDN=$$ENDTC^PSGMI(+PSGRSD),RSDLABL="Calc Start: " - . I '$G(P(2)),'$P(PSGRDTX,U,3) S PSGRSD=+PSGRDTX,PSGRSDN=$$ENDTC^PSGMI(PSGRSD) - . I $G(PSGRSD),($G(PSGRSDN)]"") D DSPLYDT^PSJLIVMD(PSJLMX+5,.PSGRSD,.PSGRSDN,RSDLABL,1,PSJRQB,PSJRQL),SETTMP^PSJLMPRU("PSJI",PSJL) -INFRATE ; - S PSJL="" D FLDNO^PSJLIUTL("(3)",1) - S PSJL=$$SETSTR^VALM1("Infusion Rate:",PSJL,7,15) - D LONG^PSJLIUTL(P(8),22,24) -LASTREN ; - N PSGRNDT S PSGRNDT=$$LASTREN^PSJLMPRI(DFN,$S($G(PSJORD):PSJORD,1:$G(ON))) I PSGRNDT D - . S PSGRNDT=$$ENDTC^PSGMI(+PSGRNDT),PSJL=$$SETSTR^VALM1("Renewed: "_PSGRNDT,PSJL,54,32) - D SETTMP^PSJLMPRU("PSJI",PSJL) -MR ; - S PSJL="" D FLDNO^PSJLIUTL("(5)",1) - S PSJL=$$SETSTR^VALM1("Med Route:",PSJL,11,11) - S PSJL=PSJL_$P(P("MR"),U,2) -STOP ; - D FLDNO^PSJLIUTL("(6)",47) - ;PSJ*5*180 - If Invalid Duration/Limit - Cannot Calculate Stop Date - S PSJL=$$SETSTR^VALM1("Stop:",PSJL,57,6)_$S($G(PSJBADD)=1:"CANNOT CALCULATE",1:$$STOPDT^PSJLIUTL) - D SETTMP^PSJLMPRU("PSJI",PSJL) - S PSJL="" - N PSJBCMA S PSJBCMA=$$BCMALG^PSJUTL2(DFN,PSJORD) - I $G(PSJBCMA)]"" S PSJL=$$SETSTR^VALM1(PSJBCMA,PSJL,1,52) - I $G(PSGRDTX(+PSJORD,"PSGRFD")) S PSGRFD=PSGRDTX(+PSJORD,"PSGRFD"),PSGRFDN=$$ENDTC^PSGMI(PSGRFD) D - . D DSPLYDT^PSJLIVMD(PSJLMX+7,.PSGRFD,.PSGRFDN," Calc Stop: ",0,51,29) - D:($G(PSJBCMA)]"")!($G(PSGRFD)]"") SETTMP^PSJLMPRU("PSJI",PSJL) -SCH ; - S PSJL="" D FLDNO^PSJLIUTL("(7)",1) - S PSJL=$$SETSTR^VALM1("Schedule:",PSJL,12,11) - D LONG^PSJLIUTL(P(9),22,32) S PSJL=PSJL_$S(P(7):"@0 labels a day",1:"") -LASTFL ; - S PSJL=$$SETSTR^VALM1("Last Fill:",PSJL,52,11) - S PSJL=PSJL_$$ENDTC^PSGMI(P("LF")) - D SETTMP^PSJLMPRU("PSJI",PSJL) -ADM ; - S PSJL="" D FLDNO^PSJLIUTL("(8)",1) - S PSJL=$$SETSTR^VALM1("Admin Times:",PSJL,9,14) - D LONG^PSJLIUTL(P(11),22,30) -QTY ; - S PSJL=$$SETSTR^VALM1("Quantity:",PSJL,53,10)_+P("LFA") - D SETTMP^PSJLMPRU("PSJI",PSJL) -PROVIDER ; - S PSJL="" D FLDNO^PSJLIUTL("(9)",1) - S PSJL=$$SETSTR^VALM1("Provider:",PSJL,12,10)_$$PROVIDER^PSJLIUTL -CUMDOSES ; - S PSJL=$$SETSTR^VALM1("Cum. Doses:",PSJL,51,12)_P("CUM") - D SETTMP^PSJLMPRU("PSJI",PSJL) -OPI ; - S PSJL="" D FLDNO^PSJLIUTL("(10)",1) - S PSJL=$$SETSTR^VALM1("Other Print"_$S($P(P("OPI"),"^",2)=1:"!: ",1:": "),PSJL,9,13)_$P(P("OPI"),"^") - D SETTMP^PSJLMPRU("PSJI",PSJL) -PC ; - S PSJL="" - S PSJL=$$SETSTR^VALM1("Provider Comments:",PSJL,3,18) D WTPC^PSJLIUTL -REMARK ; - D SETTMP^PSJLMPRU("PSJI","") - S PSJL="" D FLDNO^PSJLIUTL("(11)",1) - S PSJL=$$SETSTR^VALM1("Remarks :",PSJL,8,10) - D LONG^PSJLIUTL(P("REM"),18,62) - D SETTMP^PSJLMPRU("PSJI",PSJL) -IVROOM ; - S PSJL="" - S PSJL=$$SETSTR^VALM1("IV Room:",PSJL,9,9)_$P(P("IVRM"),U,2) - D SETTMP^PSJLMPRU("PSJI",PSJL) -ENTRY ; - S PSJL="",PSJL=$$SETSTR^VALM1("Entry By:",PSJL,8,10) - S PSJL=PSJL_$S($P(P("CLRK"),U,2)]"":$E($P(P("CLRK"),U,2),1,18),1:"*** Undefined") - S PSJL=$$SETSTR^VALM1("Entry Date:",PSJL,51,12)_$$ENDTC^PSGMI(P("LOG")) - D SETTMP^PSJLMPRU("PSJI",PSJL) - S PSJL="" S PSGLRN=$$LASTRNBY^PSJLMPRI(DFN,$S($G(PSJORD):PSJORD,1:$G(ON))) I PSGLRN D - . S PSJL=$$SETSTR^VALM1("Renewed By: ",PSJL,6,12)_$$ENNPN^PSGMI(PSGLRN) D SETTMP^PSJLMPRU("PSJI",PSJL) K PSGLRN - S VALM("TITLE")=$$CODES^PSIVUTL(P(17),$S($G(ON)["P":53.1,1:55.01),$S(ON["P":28,1:100))_" IV " - I $G(P("PRY"))="D"!($G(P("PON"))["P") S VALM("TITLE")=VALM("TITLE")_$S($G(P("PRY"))="":"",1:"("_$$CODES^PSIVUTL(P("PRY"),53.1,.24)_")") - I $G(P("PON"))["P" D ORDCHK - S VALMCNT=PSJLN-1,^TMP("PSJI",$J,0)=VALMCNT - Q - ; -ORDCHK ;Display order check for pending order - Q:'$O(^PS(53.1,+ON,10,0)) - NEW PSJIVX,PSJIVXX - F PSJIVX=0:0 S PSJIVX=$O(^PS(53.1,+ON,10,PSJIVX)) Q:'PSJIVX D - . D SETTMP^PSJLMPRU("PSJI","") - . S PSJL="Order Checks :" D LONG^PSJLIUTL($G(^PS(53.1,+ON,10,PSJIVX,0)),22,60) - . D SETTMP^PSJLMPRU("PSJI",PSJL) - . S PSJL="Overriding Provider: "_$P($G(^PS(53.1,+ON,10,PSJIVX,1)),U) - . D SETTMP^PSJLMPRU("PSJI",PSJL) - . S PSJL="Overriding Reason : " - . F PSJIVXX=0:0 S PSJIVXX=$O(^PS(53.1,+ON,10,PSJIVX,2,PSJIVXX)) Q:'PSJIVXX D - .. D LONG^PSJLIUTL($G(^PS(53.1,+ON,10,PSJIVX,2,PSJIVXX,0)),22,60) - .. D SETTMP^PSJLMPRU("PSJI",PSJL) S PSJL="" - Q - ; -SCHREQ(IVAR) ; - I $G(IVAR(4))="P"!($G(IVAR(23))="P")!($G(IVAR(5))) Q 1 - Q 0 +PSJLIVFD ;BIR/MV-SETUP LM TEMPLATE FOR IV FLUID ;4 Aug 00 / 2:37 PM + ;;5.0; INPATIENT MEDICATIONS ;**7,50,63,64,58,81,91,80,116,110,111,180**;16 DEC 97;Build 5 + ; + ; Reference to ^VALM0 is supported by DBIA # 2615. + ; + ;NFI changes for FR# 3@AD+4 + ; +EN ; Build LM template to display IV order. + K ^TMP("PSJI",$J) + S UL80="",$P(UL80,"=",80)="" + S PSJLN=1 +AD ; + NEW VALMEVL S VALMEVL=1 + S PSJL="" D FLDNO^PSJLIUTL("(1)",1) + S PSJL=PSJL_"Additives:" + S:$G(P("PON"))["V"&(P(17)'="N") PSJL=$$SETSTR^VALM1("Order number:",PSJL,30,14)_+P("PON") + S PSJL=$$SETSTR^VALM1("Type:",PSJL,57,6)_$$TYPE^PSJLIUTL + NEW PSJVD S PSJVD=$$DINFLIV^PSJDIN(.DRG) + S PSJL=$$SETSTR^VALM1(PSJVD,PSJL,75,6) + I '$D(IORVON),$D(IOST(0)) D ENS^%ZISS,TERM^VALM0 + I $D(IORVON),(PSJVD]"") D CNTRL^VALM10(1,76,5,IORVON,IORVOFF,0) K PSJVD + D SETTMP^PSJLMPRU("PSJI",PSJL) + D:+$G(PSJLMX) CLRDSPL^PSJLIVMD + ;PSJLMX count number of lines needed to display the add/sol + S PSJLMX=0 D WRTDRG^PSJLIUTL("AD") +SOL ; + S PSJL="" D FLDNO^PSJLIUTL("(2)",1) + S PSJL=PSJL_"Solutions:" + I P("SYRS")]"" D + . S PSJL=$$SETSTR^VALM1("Syr. Size:",PSJL,52,10)_$E(P("SYRS"),1,13) + . S:$L(P("SYRS"))>13 PSJL=PSJL_"..." + D SETTMP^PSJLMPRU("PSJI",PSJL) + D WRTDRG^PSJLIUTL("SOL") +DUR ; + S PSJL="" + N DUROUT,IVLIMIT S DUROUT=$$GETDUR^PSJLIVMD(PSGP,+PSJORD,$S(PSJORD["P":"P",1:"IV")) + S LABEL=$S($G(IVLIMIT):"IV Limit: ",1:"Duration: ") K IVLIMIT + S PSJL=$$SETSTR^VALM1(LABEL,PSJL,12,10) + S PSJL=PSJL_DUROUT +START ; + D FLDNO^PSJLIUTL("(4)",47) + S PSJL=$$SETSTR^VALM1("Start:",PSJL,56,7)_$$STARTDT^PSJLIUTL + D SETTMP^PSJLMPRU("PSJI",PSJL) + NEW PSGRSD,PSGRSDN,PSGRFD,PSGRFDN + S PSJL="" I $G(PSJORD)["P",$G(PSGRDTX) D + . N RSDLABL,PSJRQB,PSJRQL,PSGRSD,PSGSRSDN + . S RSDLABL=" REQUESTED START: ",PSJRQB=41,PSJRQL=39,PSGRSD="",PSGRSDN="" + . I $G(PSGRDTX(+$G(PSJORD),"PSGRSD")),$G(P(2)) S PSJRQB=51,PSJRQL=29 D + .. S PSGRSD=PSGRDTX(+$G(PSJORD),"PSGRSD"),PSGRSDN=$$ENDTC^PSGMI(+PSGRSD),RSDLABL="Calc Start: " + . I '$G(P(2)),'$P(PSGRDTX,U,3) S PSGRSD=+PSGRDTX,PSGRSDN=$$ENDTC^PSGMI(PSGRSD) + . I $G(PSGRSD),($G(PSGRSDN)]"") D DSPLYDT^PSJLIVMD(PSJLMX+5,.PSGRSD,.PSGRSDN,RSDLABL,1,PSJRQB,PSJRQL),SETTMP^PSJLMPRU("PSJI",PSJL) +INFRATE ; + S PSJL="" D FLDNO^PSJLIUTL("(3)",1) + S PSJL=$$SETSTR^VALM1("Infusion Rate:",PSJL,7,15) + D LONG^PSJLIUTL(P(8),22,24) +LASTREN ; + N PSGRNDT S PSGRNDT=$$LASTREN^PSJLMPRI(DFN,$S($G(PSJORD):PSJORD,1:$G(ON))) I PSGRNDT D + . S PSGRNDT=$$ENDTC^PSGMI(+PSGRNDT),PSJL=$$SETSTR^VALM1("Renewed: "_PSGRNDT,PSJL,54,32) + D SETTMP^PSJLMPRU("PSJI",PSJL) +MR ; + S PSJL="" D FLDNO^PSJLIUTL("(5)",1) + S PSJL=$$SETSTR^VALM1("Med Route:",PSJL,11,11) + S PSJL=PSJL_$P(P("MR"),U,2) +STOP ; + D FLDNO^PSJLIUTL("(6)",47) + ;PSJ*5*180 - If Invalid Duration/Limit - Cannot Calculate Stop Date + S PSJL=$$SETSTR^VALM1("Stop:",PSJL,57,6)_$S($G(PSJBADD)=1:"CANNOT CALCULATE",1:$$STOPDT^PSJLIUTL) + D SETTMP^PSJLMPRU("PSJI",PSJL) + S PSJL="" + N PSJBCMA S PSJBCMA=$$BCMALG^PSJUTL2(DFN,PSJORD) + I $G(PSJBCMA)]"" S PSJL=$$SETSTR^VALM1(PSJBCMA,PSJL,1,52) + ;D:$G(PSGRFD) DSPLYDT^PSJLIVMD(PSJLMX+7,.PSGRFD,.PSGRFDN," REQUESTED STOP: ",P(3)'=PSGRFD) + I $G(PSGRDTX(+PSJORD,"PSGRFD")) S PSGRFD=PSGRDTX(+PSJORD,"PSGRFD"),PSGRFDN=$$ENDTC^PSGMI(PSGRFD) D + . D DSPLYDT^PSJLIVMD(PSJLMX+7,.PSGRFD,.PSGRFDN," Calc Stop: ",0,51,29) + D:($G(PSJBCMA)]"")!($G(PSGRFD)]"") SETTMP^PSJLMPRU("PSJI",PSJL) +SCH ; + S PSJL="" D FLDNO^PSJLIUTL("(7)",1) + S PSJL=$$SETSTR^VALM1("Schedule:",PSJL,12,11) + D LONG^PSJLIUTL(P(9),22,32) S PSJL=PSJL_$S(P(7):"@0 labels a day",1:"") +LASTFL ; + S PSJL=$$SETSTR^VALM1("Last Fill:",PSJL,52,11) + S PSJL=PSJL_$$ENDTC^PSGMI(P("LF")) + D SETTMP^PSJLMPRU("PSJI",PSJL) +ADM ; + S PSJL="" D FLDNO^PSJLIUTL("(8)",1) + S PSJL=$$SETSTR^VALM1("Admin Times:",PSJL,9,14) + D LONG^PSJLIUTL(P(11),22,30) +QTY ; + S PSJL=$$SETSTR^VALM1("Quantity:",PSJL,53,10)_+P("LFA") + D SETTMP^PSJLMPRU("PSJI",PSJL) +PROVIDER ; + S PSJL="" D FLDNO^PSJLIUTL("(9)",1) + S PSJL=$$SETSTR^VALM1("Provider:",PSJL,12,10)_$$PROVIDER^PSJLIUTL +CUMDOSES ; + ;S PSJL=$$SETSTR^VALM1("Cumulative Doses:",PSJL,45,17)_P("CUM") + S PSJL=$$SETSTR^VALM1("Cum. Doses:",PSJL,51,12)_P("CUM") + D SETTMP^PSJLMPRU("PSJI",PSJL) +OPI ; + S PSJL="" D FLDNO^PSJLIUTL("(10)",1) + S PSJL=$$SETSTR^VALM1("Other Print"_$S($P(P("OPI"),"^",2)=1:"!: ",1:": "),PSJL,9,13)_$P(P("OPI"),"^") + D SETTMP^PSJLMPRU("PSJI",PSJL) +PC ; + S PSJL="" + ;S PSJL=$$SETSTR^VALM1("Provider Comments:",PSJL,3,18) D SETTMP^PSJLMPRU("PSJI",PSJL) D WTPC^PSJLIUTL + S PSJL=$$SETSTR^VALM1("Provider Comments:",PSJL,3,18) D WTPC^PSJLIUTL +REMARK ; + D SETTMP^PSJLMPRU("PSJI","") + S PSJL="" D FLDNO^PSJLIUTL("(11)",1) + S PSJL=$$SETSTR^VALM1("Remarks :",PSJL,8,10) + D LONG^PSJLIUTL(P("REM"),18,62) + D SETTMP^PSJLMPRU("PSJI",PSJL) +IVROOM ; + S PSJL="" + S PSJL=$$SETSTR^VALM1("IV Room:",PSJL,9,9)_$P(P("IVRM"),U,2) + D SETTMP^PSJLMPRU("PSJI",PSJL) +ENTRY ; + S PSJL="",PSJL=$$SETSTR^VALM1("Entry By:",PSJL,8,10) + S PSJL=PSJL_$S($P(P("CLRK"),U,2)]"":$E($P(P("CLRK"),U,2),1,18),1:"*** Undefined") + S PSJL=$$SETSTR^VALM1("Entry Date:",PSJL,51,12)_$$ENDTC^PSGMI(P("LOG")) + D SETTMP^PSJLMPRU("PSJI",PSJL) + S PSJL="" S PSGLRN=$$LASTRNBY^PSJLMPRI(DFN,$S($G(PSJORD):PSJORD,1:$G(ON))) I PSGLRN D + . S PSJL=$$SETSTR^VALM1("Renewed By: ",PSJL,6,12)_$$ENNPN^PSGMI(PSGLRN) D SETTMP^PSJLMPRU("PSJI",PSJL) K PSGLRN + S VALM("TITLE")=$$CODES^PSIVUTL(P(17),$S($G(ON)["P":53.1,1:55.01),$S(ON["P":28,1:100))_" IV " + I $G(P("PRY"))="D"!($G(P("PON"))["P") S VALM("TITLE")=VALM("TITLE")_$S($G(P("PRY"))="":"",1:"("_$$CODES^PSIVUTL(P("PRY"),53.1,.24)_")") + I $G(P("PON"))["P" D ORDCHK + S VALMCNT=PSJLN-1,^TMP("PSJI",$J,0)=VALMCNT + Q + ; +ORDCHK ;Display order check for pending order + Q:'$O(^PS(53.1,+ON,10,0)) + NEW PSJIVX,PSJIVXX + F PSJIVX=0:0 S PSJIVX=$O(^PS(53.1,+ON,10,PSJIVX)) Q:'PSJIVX D + . D SETTMP^PSJLMPRU("PSJI","") + . S PSJL="Order Checks :" D LONG^PSJLIUTL($G(^PS(53.1,+ON,10,PSJIVX,0)),22,60) + . D SETTMP^PSJLMPRU("PSJI",PSJL) + . S PSJL="Overriding Provider: "_$P($G(^PS(53.1,+ON,10,PSJIVX,1)),U) + . D SETTMP^PSJLMPRU("PSJI",PSJL) + . S PSJL="Overriding Reason : " + . F PSJIVXX=0:0 S PSJIVXX=$O(^PS(53.1,+ON,10,PSJIVX,2,PSJIVXX)) Q:'PSJIVXX D + .. D LONG^PSJLIUTL($G(^PS(53.1,+ON,10,PSJIVX,2,PSJIVXX,0)),22,60) + .. D SETTMP^PSJLMPRU("PSJI",PSJL) S PSJL="" + Q + ; +SCHREQ(IVAR) ; + I $G(IVAR(4))="P"!($G(IVAR(23))="P")!($G(IVAR(5))) Q 1 + Q 0 diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLIVMD.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLIVMD.m index 031756e9..2c61902b 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLIVMD.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLIVMD.m @@ -1,216 +1,207 @@ -PSJLIVMD ;BIR/MV-SETUP LM TEMPLATE FOR INPT MED. IV ;4 Aug 00 / 4:29 PM - ;;5.0; INPATIENT MEDICATIONS ;**37,50,63,58,81,91,80,116,110,111,180,134**;16 DEC 97;Build 124 - ; - ;Reference to ^PS(55 is supported by DBIA #2191. - ; -EN ; Build LM template to display IV order. - D GTOT^PSIVUTL(P(4)) - S:'$D(PSJSTAR) PSJSTAR="" S:'$D(PSGP) PSGP=DFN - I $E(P("OT"))'="I" D EN^PSJLIVFD Q - K ^TMP("PSJI",$J) - S UL80="",$P(UL80,"=",80)="" - S PSJLN=1 - I $G(PSIV531),P("PON")["P" S (P(2),P(3),P(4))="" -AD ; - NEW VALMEVL S VALMEVL=1 - S PSJL="" D FLDNO^PSJLIUTL("(1)",1) - S PSJL=PSJL_" Additives:" - S:$G(P("PON"))["V"&(P(17)'="N") PSJL=$$SETSTR^VALM1("Order number:",PSJL,28,14)_+P("PON") - S PSJL=$$SETSTR^VALM1("Type:",PSJL,57,6)_$$TYPE^PSJLIUTL - NEW PSJVD S PSJVD=$$DINFLIV^PSJDIN(.DRG) - S PSJL=$$SETSTR^VALM1(PSJVD,PSJL,75,6) - I $D(IORVON),(PSJVD]"") D CNTRL^VALM10(1,76,5,IORVON,IORVOFF,0) K PSJVD - D SETTMP^PSJLMPRU("PSJI",PSJL) - D:+$G(PSJLMX) CLRDSPL - ;PSJLMX count number of lines needed to display the add/sol - S PSJLMX=0 D WRTDRG^PSJLIUTL("AD") -SOL ; - S PSJL="" D FLDNO^PSJLIUTL("(2)",1) - S PSJL=PSJL_" Solutions:" - I P("SYRS")]"" D - . S PSJL=$$SETSTR^VALM1("Syr. Size:",PSJL,52,11)_$E(P("SYRS"),1,13) - . S:$L(P("SYRS"))>13 PSJL=PSJL_"..." - D SETTMP^PSJLMPRU("PSJI",PSJL) - D WRTDRG^PSJLIUTL("SOL") - D DUR -START ; - NEW PSGRSD,PSGRSDN,PSGRFD,PSGRFDN - I $G(P("OT"))="I",$G(P(4))]"" D - .Q:$G(ON)["V" I $G(PSIVAC)="" N PSIVAC S PSIVAC="CF" - .Q:$G(P(3)) - .D ENT^PSIVCAL,ENSTOP^PSIVCAL - D REQDT(ON) - D FLDNO^PSJLIUTL("(4)",47) - S PSJL=$$SETSTR^VALM1("Start:",PSJL,56,7)_$$STARTDT^PSJLIUTL - D SETTMP^PSJLMPRU("PSJI",PSJL) -INFRATE ; - S PSJL="" D FLDNO^PSJLIUTL("(3)",1) - S PSJL=$$SETSTR^VALM1("Infusion Rate:",PSJL,7,15) - D LONG^PSJLIUTL(P(8),22,23) -RSTART ; - I $G(ON)["P" N PSGNDT S PSGRNDT=$$LASTREN^PSJLMPRI(DFN,ON) D - . I PSGRNDT S PSGRNDT=$$ENDTC^PSGMI(+PSGRNDT),PSJL=$$SETSTR^VALM1("Renewed: "_PSGRNDT,PSJL,54,32) Q - . Q:'$G(PSGRDTX) N PSJRQB,PSJRQL,RSDLABL,PSGRSD,PSGRSDN - . S RSDLABL=" REQUESTED START: ",PSJRQB=41,PSJRQL=39,PSGRSD="",PSGRSDN="" - . I $G(PSGRDTX(+$G(PSJORD),"PSGRSD")),$G(P(2)) S PSJRQB=51,PSJRQL=29 D - .. S PSGRSD=PSGRDTX(+$G(PSJORD),"PSGRSD"),PSGRSDN=$$ENDTC^PSGMI(+PSGRSD),RSDLABL="Calc Start: " - . I '$G(P(2)),'$P(PSGRDTX,U,3) S PSGRSD=+PSGRDTX,PSGRSDN=$$ENDTC^PSGMI(PSGRSD) - . I $G(PSGRSD),($G(PSGRSDN)]"") D DSPLYDT(PSJLMX+5,.PSGRSD,.PSGRSDN,RSDLABL,1,PSJRQB,PSJRQL) ;,SETTMP^PSJLMPRU("PSJI",PSJL) - I $G(ON)["V" N PSGRNDT S PSGRNDT=$$LASTREN^PSJLMPRI(DFN,ON) I PSGRNDT S PSGRNDT=$$ENDTC^PSGMI(+PSGRNDT),PSJL=$$SETSTR^VALM1("Renewed: "_PSGRNDT,PSJL,54,32) - I PSJL]"" D SETTMP^PSJLMPRU("PSJI",PSJL) - ; -MR ; - S PSJL="" D FLDNO^PSJLIUTL("(5)",1) - S PSJL=$$SETSTR^VALM1("Med Route:",PSJL,11,11) - S PSJL=PSJL_$P(P("MR"),U,2) -STOP ; - S:'$D(PSGP) PSGP=DFN - D FLDNO^PSJLIUTL("(6)",47) - ;PSJ*5*180 - If CPRS sends invalid duration/limit - Cannot Calculate Stop Date. - S PSJL=$$SETSTR^VALM1("Stop:",PSJL,57,6)_$S($G(PSJBADD)=1:"CANNOT CALCULATE",1:$$STOPDT^PSJLIUTL) - D SETTMP^PSJLMPRU("PSJI",PSJL) - S PSJL="" - N PSJBCMA S PSJBCMA=$$BCMALG^PSJUTL2(PSGP,PSJORD) - I $G(PSJBCMA)]"",$G(DFN) S PSJL=$$SETSTR^VALM1(PSJBCMA,PSJL,1,52) - I $G(PSJORD)["P",$G(PSGRDTX(+$G(PSJORD),"PSGRFD")),$G(P(3)) S PSGRFDN=$$ENDTC^PSGMI(PSGRDTX(+PSJORD,"PSGRFD")) D - . D DSPLYDT(PSJLMX+7,.PSGRFD,.PSGRFDN," Calc Stop: ",1,51,29) - I ($G(PSJBCMA)]"")!($G(PSGRDTX(+$G(PSJORD),"PSGRFD"))&$G(P(3))) D SETTMP^PSJLMPRU("PSJI",PSJL) -SCH ; - S PSJL="" D FLDNO^PSJLIUTL("(7)",1) - S PSJL=$$SETSTR^VALM1("Schedule:",PSJL,12,11) - D LONG^PSJLIUTL(P(9)_$S(P(7):"@0 labels a day",1:"")_$G(SCHMSG),22,31) -LASTFL ; - S PSJL=$$SETSTR^VALM1("Last Fill:",PSJL,52,11) - S PSJL=PSJL_$$ENDTC^PSGMI(P("LF")) - D SETTMP^PSJLMPRU("PSJI",PSJL) -ADM ; - S PSJL="" D FLDNO^PSJLIUTL("(8)",1) - S PSJL=$$SETSTR^VALM1("Admin Times:",PSJL,9,14) - NEW NOECH - D LONG^PSJLIUTL(P(11),22,29) -QTY ; - S PSJL=$$SETSTR^VALM1("Quantity:",PSJL,53,10)_+P("LFA") - D SETTMP^PSJLMPRU("PSJI",PSJL) -PROVIDER ; - S PSJL="" D FLDNO^PSJLIUTL("(9)",1) - S PSJL=$$SETSTR^VALM1("Provider:",PSJL,12,10)_$$PROVIDER^PSJLIUTL -CUMDOSES ; - S PSJL=$$SETSTR^VALM1("Cum. Doses:",PSJL,51,12)_P("CUM") - D SETTMP^PSJLMPRU("PSJI",PSJL) -OI ; - S PSJL="" D FLDNO^PSJLIUTL("(10)",1) - S PSJL=$$SETSTR^VALM1("Orderable Item:",PSJL,6,16)_$P(P("PD"),U,2)_$$OINF^PSJDIN(+P("PD")) - D SETTMP^PSJLMPRU("PSJI",PSJL) -INS ; - S PSJL="" - S PSJL=$$SETSTR^VALM1("Instructions:",PSJL,8,14) - D LONG^PSJLIUTL(P("INS"),22,58) - D SETTMP^PSJLMPRU("PSJI",PSJL) -OPI ; - S PSJL="" D FLDNO^PSJLIUTL("(11)",1) - S PSJL=$$SETSTR^VALM1("Other Print"_$S($P(P("OPI"),"^",2)=1:"!: ",1:": "),PSJL,9,13)_$P(P("OPI"),"^") - D SETTMP^PSJLMPRU("PSJI",PSJL) -PC ; - S PSJL="" - S PSJL=$$SETSTR^VALM1("Provider Comments:",PSJL,3,18) D WTPC^PSJLIUTL -REMARK ; - D SETTMP^PSJLMPRU("PSJI","") - S PSJL="" D FLDNO^PSJLIUTL("(12)",1) - S PSJL=$$SETSTR^VALM1("Remarks :",PSJL,8,10) - D LONG^PSJLIUTL(P("REM"),18,62) - D SETTMP^PSJLMPRU("PSJI",PSJL) -IVROOM ; - S PSJL="" - S PSJL=$$SETSTR^VALM1("IV Room:",PSJL,9,9)_$P(P("IVRM"),U,2) - D SETTMP^PSJLMPRU("PSJI",PSJL) -ENTRY ; - S PSJL="",PSJL=$$SETSTR^VALM1("Entry By:",PSJL,8,10) - S PSJL=PSJL_$S($P(P("CLRK"),U,2)]"":$E($P(P("CLRK"),U,2),1,24),1:"*** Undefined") - S PSJL=$$SETSTR^VALM1("Entry Date:",PSJL,51,12)_$$ENDTC^PSGMI(P("LOG")) - D SETTMP^PSJLMPRU("PSJI",PSJL) - S PSJL="" S PSGLRN=$$LASTRNBY^PSJLMPRI(DFN,$S($G(PSJORD):PSJORD,1:$G(ON))) I PSGLRN D - . S PSJL=$$SETSTR^VALM1("Renewed By: ",PSJL,6,12)_$$ENNPN^PSGMI(PSGLRN) D SETTMP^PSJLMPRU("PSJI",PSJL) K PSGLRN - S VALM("TITLE")=$$CODES^PSIVUTL(P(17),$S($G(ON)["P":53.1,1:55.01),$S($G(ON)["P":28,1:100))_" IV " - I $G(P("PRY"))="D"!($G(P("PON"))["P") S VALM("TITLE")=VALM("TITLE")_$S($G(P("PRY"))="":"",1:"("_$$CODES^PSIVUTL(P("PRY"),53.1,.24)_")") - I $G(P("PON"))["P" D ORDCHK^PSJLIVFD - S VALMCNT=PSJLN-1,^TMP("PSJI",$J,0)=VALMCNT - Q -DSPLYDT(PSJLN,PSGRDT,PSGRDTN,TXT,PSJFSH,PSJRDBEG,PSJRDLEN) ; - ;LINE : Line number the Requested Start and Stop dates are display in - ;PSGRDT : Either it is the requested start or stop date in FM format - ;PSGRDTN: Either it is the requested start or stop date in IPM format - ;TXT : The display text - ;PSJFSH : if it is 1 then flash - ; - S:'$G(PSJRDBEG) PSJRDBEG=41,PSJRDLEN=39 - S PSJL=$$SETSTR^VALM1(TXT_PSGRDTN,PSJL,PSJRDBEG,PSJRDLEN) - Q -CLRDSPL ; - ;Clear the blinking after edit the pending order. - ;Without it more than the requested start and stop dates are blinking at the ac/edit screen - ;PSJLMX: # ad/sol counted in WRTDRG^PSJLIUTL - Q:'$D(IOBOFF) - NEW PSJX - F PSJX=5:1:PSJLMX+7 D CNTRL^VALM10(PSJX,36,80,IOBOFF,IOINORM) - Q -REQDT(ORDER) ;Get requested date if it is a pending order - ;ORDER : Pending Order Number (PSJORD or PSGORD) - Q:ORDER'["P" D REQDT^PSJLIUTL(ORDER) - Q - ; -GETDUR(PAT,ORD,PKG,RAW) ; - ; PAT= Patient DFN - ; ORD= Order # - ; PKG= 5(UD), "IV"(IV), "P"(Pending) - N ACT,DUR,ND,ND25,F25,ND0,ND2,OLDORD S DUR="",ORD=+ORD K IVLIMIT - S:PKG="V" PKG="IV" - I PKG="P" S ND=$G(^PS(53.1,+ORD,0)) D I '$G(OLDORD) Q DUR - . I $G(P("OVRIDE")) S DUR="" Q - . D PENDING(ORD) Q:DUR]"" - . S ND0=$G(^PS(53.1,ORD,0)) I $P(ND0,U,24)="E" S OLDORD=$P(ND0,U,25) I OLDORD S PKG=$S(OLDORD["V":"IV",OLDORD["U":5,OLDORD["P":"P",1:"") - . Q:($G(OLDORD)'["P") - . D PENDING(OLDORD) S OLDORD="" - I PKG="IV" S ND2=$G(^PS(55,PAT,PKG,ORD,2)) I $P(ND2,U,8)="E" S OLDORD=$P(ND2,U,5) S:OLDORD'["V" OLDORD="" I OLDORD D - .N ACTND S ACTND=0 F S ACTND=$O(^PS(55,PAT,"IV",ORD,"A",ACTND)) Q:'ACTND D - ..I $G(^PS(55,PAT,"IV",ORD,"A",ACTND,0))["IV LIMIT OVERRIDDEN" S OLDORD="" - I $G(P("LIMIT"))]"" S DUR=P("LIMIT"),IVLIMIT=1 I '$G(RAW) S DUR=$$FMTDUR(DUR) Q DUR - I PKG=5 S ND0=$G(^PS(55,PAT,PKG,ORD,0)) I $P(ND0,U,24)="E" S OLDORD=$P(ND0,U,25) S:OLDORD'["U" OLDORD="" - S F25="^PS(55,PAT,PKG,ORD,2.5)" I '$G(OLDORD) Q:'$D(@(F25)) DUR - S ND25=$G(@(F25)) S DUR=$P(ND25,U,2) I DUR="" S DUR=$P(ND25,U,4) I DUR]"" S IVLIMIT=1 - I DUR="",$G(OLDORD) S ORD=+OLDORD Q:'$D(@(F25)) DUR D - . S ND25=$G(@(F25)) S DUR=$P(ND25,U,2) I DUR="" S DUR=$P(ND25,U,4) I DUR]"" S IVLIMIT=1 - I '$G(RAW),DUR]"" S DUR=$$FMTDUR(DUR) - Q DUR - ; -PENDING(PNDON) ; - S ND=$G(^PS(53.1,+ORD,0)) - I ND S ND25=$S(($P(ND,U,15)=PAT):$G(^PS(53.1,+ORD,2.5)),1:"") - S DUR=$P(ND25,U,4) I DUR]"" D Q - .S:($E(DUR)="s")!($E(DUR)="m")!($E(DUR)="l")!($E(DUR)="d")!($E(DUR)="h")!($E(DUR)="a") IVLIMIT=1 S DUR=$S($G(RAW):DUR,1:$$FMTDUR(DUR)) - S DUR=$P(ND25,U,2) I DUR]"" S DUR=$S($G(RAW):DUR,1:$$FMTDUR(DUR)) - Q - ; -FMTDUR(DURCODE) ; - N DUNIT,DNUM,BAD S BAD=0 - ;PSJ*5*180 - Add PSJBADD variable - K PSJBADD S PSJBADD=0 - S DUNIT=$E(DURCODE),DNUM=$P(DURCODE,DUNIT,2) I 'DNUM S BAD=1 - I DUNIT'="",DUNIT'?1(1U,1L) S PSJBADD=1 - S DUNIT=$S(DUNIT="D"!(DUNIT="d"):" day",DUNIT="H"!(DUNIT="h"):" hour",DUNIT="W":" week",DUNIT="L":" month",DUNIT="M":" minute",DUNIT="S":" second",DUNIT="m":" ml",DUNIT="l":" liter",DUNIT="a":" dose",1:"") - S:DUNIT="" BAD=1 I (DNUM'=1),(DUNIT'["ml") S DUNIT=DUNIT_"s" - I PSJBADD=1 S PSGACT=$TR($G(PSGACT),"F") - Q $S(PSJBADD=1:"*INVALID DURATION/LIMIT*",BAD:"",1:DNUM_DUNIT) - ; -DURMIN(DCOD) ; - N DUR,DMIN,CHR S DUR="" F I=1:1:$L(DCOD) S CHR=$E(DCOD,I) I CHR?1N S DUR=DUR_CHR - S DMIN=DUR*$S(DCOD["L":43200,DCOD["W":10080,DCOD["M":1,DCOD["S":(1/60),DCOD["D":1440,1:0) S DMIN=+$FN(DMIN,"",1) - Q DMIN - ; -DUR ; - N DUROUT,LABEL,IVLIMIT - Q:'$G(PSJORD) S PSJL="" - S DUROUT=$$GETDUR^PSJLIVMD(PSGP,+PSJORD,$S(PSJORD["P":"P",1:"IV")) - S LABEL=$S($G(IVLIMIT):"IV Limit: ",1:"Duration: ") K IVLIMIT - S PSJL=$$SETSTR^VALM1(LABEL,PSJL,12,10) - S PSJL=PSJL_DUROUT - Q +PSJLIVMD ;BIR/MV-SETUP LM TEMPLATE FOR INPT MED. IV ;4 Aug 00 / 4:29 PM + ;;5.0; INPATIENT MEDICATIONS ;**37,50,63,58,81,91,80,116,110,111,180**;16 DEC 97;Build 5 + ; + ;Reference to ^PS(55 is supported by DBIA #2191. + ; +EN ; Build LM template to display IV order. + D GTOT^PSIVUTL(P(4)) + S:'$D(PSJSTAR) PSJSTAR="" S:'$D(PSGP) PSGP=DFN + I $E(P("OT"))'="I" D EN^PSJLIVFD Q + K ^TMP("PSJI",$J) + S UL80="",$P(UL80,"=",80)="" + S PSJLN=1 + I $G(PSIV531),P("PON")["P" S (P(2),P(3),P(4))="" +AD ; + NEW VALMEVL S VALMEVL=1 + S PSJL="" D FLDNO^PSJLIUTL("(1)",1) + S PSJL=PSJL_" Additives:" + S:$G(P("PON"))["V"&(P(17)'="N") PSJL=$$SETSTR^VALM1("Order number:",PSJL,28,14)_+P("PON") + S PSJL=$$SETSTR^VALM1("Type:",PSJL,57,6)_$$TYPE^PSJLIUTL + NEW PSJVD S PSJVD=$$DINFLIV^PSJDIN(.DRG) + S PSJL=$$SETSTR^VALM1(PSJVD,PSJL,75,6) + I $D(IORVON),(PSJVD]"") D CNTRL^VALM10(1,76,5,IORVON,IORVOFF,0) K PSJVD + D SETTMP^PSJLMPRU("PSJI",PSJL) + D:+$G(PSJLMX) CLRDSPL + ;PSJLMX count number of lines needed to display the add/sol + S PSJLMX=0 D WRTDRG^PSJLIUTL("AD") +SOL ; + S PSJL="" D FLDNO^PSJLIUTL("(2)",1) + S PSJL=PSJL_" Solutions:" + I P("SYRS")]"" D + . S PSJL=$$SETSTR^VALM1("Syr. Size:",PSJL,52,11)_$E(P("SYRS"),1,13) + . S:$L(P("SYRS"))>13 PSJL=PSJL_"..." + D SETTMP^PSJLMPRU("PSJI",PSJL) + D WRTDRG^PSJLIUTL("SOL") + D DUR +START ; + NEW PSGRSD,PSGRSDN,PSGRFD,PSGRFDN + D REQDT(ON) + D FLDNO^PSJLIUTL("(4)",47) + S PSJL=$$SETSTR^VALM1("Start:",PSJL,56,7)_$$STARTDT^PSJLIUTL + D SETTMP^PSJLMPRU("PSJI",PSJL) +INFRATE ; + S PSJL="" D FLDNO^PSJLIUTL("(3)",1) + S PSJL=$$SETSTR^VALM1("Infusion Rate:",PSJL,7,15) + D LONG^PSJLIUTL(P(8),22,23) +RSTART ; + I $G(ON)["P" N PSGNDT S PSGRNDT=$$LASTREN^PSJLMPRI(DFN,ON) D + . I PSGRNDT S PSGRNDT=$$ENDTC^PSGMI(+PSGRNDT),PSJL=$$SETSTR^VALM1("Renewed: "_PSGRNDT,PSJL,54,32) Q + . Q:'$G(PSGRDTX) N PSJRQB,PSJRQL,RSDLABL,PSGRSD,PSGRSDN + . S RSDLABL=" REQUESTED START: ",PSJRQB=41,PSJRQL=39,PSGRSD="",PSGRSDN="" + . I $G(PSGRDTX(+$G(PSJORD),"PSGRSD")),$G(P(2)) S PSJRQB=51,PSJRQL=29 D + .. S PSGRSD=PSGRDTX(+$G(PSJORD),"PSGRSD"),PSGRSDN=$$ENDTC^PSGMI(+PSGRSD),RSDLABL="Calc Start: " + . I '$G(P(2)),'$P(PSGRDTX,U,3) S PSGRSD=+PSGRDTX,PSGRSDN=$$ENDTC^PSGMI(PSGRSD) + . I $G(PSGRSD),($G(PSGRSDN)]"") D DSPLYDT(PSJLMX+5,.PSGRSD,.PSGRSDN,RSDLABL,1,PSJRQB,PSJRQL) ;,SETTMP^PSJLMPRU("PSJI",PSJL) + I $G(ON)["V" N PSGRNDT S PSGRNDT=$$LASTREN^PSJLMPRI(DFN,ON) I PSGRNDT S PSGRNDT=$$ENDTC^PSGMI(+PSGRNDT),PSJL=$$SETSTR^VALM1("Renewed: "_PSGRNDT,PSJL,54,32) + I PSJL]"" D SETTMP^PSJLMPRU("PSJI",PSJL) + ; +MR ; + S PSJL="" D FLDNO^PSJLIUTL("(5)",1) + S PSJL=$$SETSTR^VALM1("Med Route:",PSJL,11,11) + S PSJL=PSJL_$P(P("MR"),U,2) +STOP ; + S:'$D(PSGP) PSGP=DFN + D FLDNO^PSJLIUTL("(6)",47) + ;PSJ*5*180 - If CPRS sends invalid duration/limit - Cannot Calculate Stop Date. + S PSJL=$$SETSTR^VALM1("Stop:",PSJL,57,6)_$S($G(PSJBADD)=1:"CANNOT CALCULATE",1:$$STOPDT^PSJLIUTL) + D SETTMP^PSJLMPRU("PSJI",PSJL) + S PSJL="" + N PSJBCMA S PSJBCMA=$$BCMALG^PSJUTL2(PSGP,PSJORD) + I $G(PSJBCMA)]"",$G(DFN) S PSJL=$$SETSTR^VALM1(PSJBCMA,PSJL,1,52) + I $G(PSJORD)["P",$G(PSGRDTX(+$G(PSJORD),"PSGRFD")),$G(P(3)) S PSGRFDN=$$ENDTC^PSGMI(PSGRDTX(+PSJORD,"PSGRFD")) D + . D DSPLYDT(PSJLMX+7,.PSGRFD,.PSGRFDN," Calc Stop: ",1,51,29) + I ($G(PSJBCMA)]"")!($G(PSGRDTX(+$G(PSJORD),"PSGRFD"))&$G(P(3))) D SETTMP^PSJLMPRU("PSJI",PSJL) +SCH ; + S PSJL="" D FLDNO^PSJLIUTL("(7)",1) + S PSJL=$$SETSTR^VALM1("Schedule:",PSJL,12,11) + D LONG^PSJLIUTL(P(9)_$S(P(7):"@0 labels a day",1:"")_$G(SCHMSG),22,31) +LASTFL ; + S PSJL=$$SETSTR^VALM1("Last Fill:",PSJL,52,11) + S PSJL=PSJL_$$ENDTC^PSGMI(P("LF")) + D SETTMP^PSJLMPRU("PSJI",PSJL) +ADM ; + S PSJL="" D FLDNO^PSJLIUTL("(8)",1) + S PSJL=$$SETSTR^VALM1("Admin Times:",PSJL,9,14) + NEW NOECH + D LONG^PSJLIUTL(P(11),22,29) +QTY ; + S PSJL=$$SETSTR^VALM1("Quantity:",PSJL,53,10)_+P("LFA") + D SETTMP^PSJLMPRU("PSJI",PSJL) +PROVIDER ; + S PSJL="" D FLDNO^PSJLIUTL("(9)",1) + S PSJL=$$SETSTR^VALM1("Provider:",PSJL,12,10)_$$PROVIDER^PSJLIUTL +CUMDOSES ; + S PSJL=$$SETSTR^VALM1("Cum. Doses:",PSJL,51,12)_P("CUM") + D SETTMP^PSJLMPRU("PSJI",PSJL) +OI ; + S PSJL="" D FLDNO^PSJLIUTL("(10)",1) + S PSJL=$$SETSTR^VALM1("Orderable Item:",PSJL,6,16)_$P(P("PD"),U,2)_$$OINF^PSJDIN(+P("PD")) + D SETTMP^PSJLMPRU("PSJI",PSJL) +INS ; + S PSJL="" + S PSJL=$$SETSTR^VALM1("Instructions:",PSJL,8,14) + D LONG^PSJLIUTL(P("INS"),22,58) + D SETTMP^PSJLMPRU("PSJI",PSJL) +OPI ; + S PSJL="" D FLDNO^PSJLIUTL("(11)",1) + S PSJL=$$SETSTR^VALM1("Other Print"_$S($P(P("OPI"),"^",2)=1:"!: ",1:": "),PSJL,9,13)_$P(P("OPI"),"^") + D SETTMP^PSJLMPRU("PSJI",PSJL) +PC ; + S PSJL="" + S PSJL=$$SETSTR^VALM1("Provider Comments:",PSJL,3,18) D WTPC^PSJLIUTL +REMARK ; + D SETTMP^PSJLMPRU("PSJI","") + S PSJL="" D FLDNO^PSJLIUTL("(12)",1) + S PSJL=$$SETSTR^VALM1("Remarks :",PSJL,8,10) + D LONG^PSJLIUTL(P("REM"),18,62) + D SETTMP^PSJLMPRU("PSJI",PSJL) +IVROOM ; + S PSJL="" + S PSJL=$$SETSTR^VALM1("IV Room:",PSJL,9,9)_$P(P("IVRM"),U,2) + D SETTMP^PSJLMPRU("PSJI",PSJL) +ENTRY ; + S PSJL="",PSJL=$$SETSTR^VALM1("Entry By:",PSJL,8,10) + S PSJL=PSJL_$S($P(P("CLRK"),U,2)]"":$E($P(P("CLRK"),U,2),1,24),1:"*** Undefined") + S PSJL=$$SETSTR^VALM1("Entry Date:",PSJL,51,12)_$$ENDTC^PSGMI(P("LOG")) + D SETTMP^PSJLMPRU("PSJI",PSJL) + S PSJL="" S PSGLRN=$$LASTRNBY^PSJLMPRI(DFN,$S($G(PSJORD):PSJORD,1:$G(ON))) I PSGLRN D + . S PSJL=$$SETSTR^VALM1("Renewed By: ",PSJL,6,12)_$$ENNPN^PSGMI(PSGLRN) D SETTMP^PSJLMPRU("PSJI",PSJL) K PSGLRN + S VALM("TITLE")=$$CODES^PSIVUTL(P(17),$S($G(ON)["P":53.1,1:55.01),$S($G(ON)["P":28,1:100))_" IV " + I $G(P("PRY"))="D"!($G(P("PON"))["P") S VALM("TITLE")=VALM("TITLE")_$S($G(P("PRY"))="":"",1:"("_$$CODES^PSIVUTL(P("PRY"),53.1,.24)_")") + I $G(P("PON"))["P" D ORDCHK^PSJLIVFD + S VALMCNT=PSJLN-1,^TMP("PSJI",$J,0)=VALMCNT + Q +DSPLYDT(PSJLN,PSGRDT,PSGRDTN,TXT,PSJFSH,PSJRDBEG,PSJRDLEN) ; + ;LINE : Line number the Requested Start and Stop dates are display in + ;PSGRDT : Either it is the requested start or stop date in FM format + ;PSGRDTN: Either it is the requested start or stop date in IPM format + ;TXT : The display text + ;PSJFSH : if it is 1 then flash + ; + S:'$G(PSJRDBEG) PSJRDBEG=41,PSJRDLEN=39 + S PSJL=$$SETSTR^VALM1(TXT_PSGRDTN,PSJL,PSJRDBEG,PSJRDLEN) + Q +CLRDSPL ; + ;Clear the blinking after edit the pending order. + ;Without it more than the requested start and stop dates are blinking at the ac/edit screen + ;PSJLMX: # ad/sol counted in WRTDRG^PSJLIUTL + Q:'$D(IOBOFF) + NEW PSJX + F PSJX=5:1:PSJLMX+7 D CNTRL^VALM10(PSJX,36,80,IOBOFF,IOINORM) + Q +REQDT(ORDER) ;Get requested date if it is a pending order + ;ORDER : Pending Order Number (PSJORD or PSGORD) + Q:ORDER'["P" D REQDT^PSJLIUTL(ORDER) + Q + ; +GETDUR(PAT,ORD,PKG,RAW) ; + ; PAT= Patient DFN + ; ORD= Order # + ; PKG= 5(UD), "IV"(IV), "P"(Pending) + N ACT,DUR,ND,ND25,F25,ND0,ND2,OLDORD S DUR="",ORD=+ORD K IVLIMIT + S:PKG="V" PKG="IV" + I PKG="P" S ND=$G(^PS(53.1,+ORD,0)) D I '$G(OLDORD) Q DUR + . D PENDING(ORD) Q:DUR]"" + . S ND0=$G(^PS(53.1,ORD,0)) I $P(ND0,U,24)="E" S OLDORD=$P(ND0,U,25) I OLDORD S PKG=$S(OLDORD["V":"IV",OLDORD["U":5,OLDORD["P":"P",1:"") + . Q:($G(OLDORD)'["P") + . D PENDING(OLDORD) S OLDORD="" + I PKG="IV" S ND2=$G(^PS(55,PAT,PKG,ORD,2)) I $P(ND2,U,8)="E" S OLDORD=$P(ND2,U,5) S:OLDORD'["V" OLDORD="" + I PKG=5 S ND0=$G(^PS(55,PAT,PKG,ORD,0)) I $P(ND0,U,24)="E" S OLDORD=$P(ND0,U,25) S:OLDORD'["U" OLDORD="" + S F25="^PS(55,PAT,PKG,ORD,2.5)" I '$G(OLDORD) Q:'$D(@(F25)) DUR + S ND25=$G(@(F25)) S DUR=$P(ND25,U,2) I DUR="" S DUR=$P(ND25,U,4) I DUR]"" S IVLIMIT=1 + I DUR="",$G(OLDORD) S ORD=+OLDORD Q:'$D(@(F25)) DUR D + . S ND25=$G(@(F25)) S DUR=$P(ND25,U,2) I DUR="" S DUR=$P(ND25,U,4) I DUR]"" S IVLIMIT=1 + I '$G(RAW),DUR]"" S DUR=$$FMTDUR(DUR) + Q DUR + ; +PENDING(PNDON) ; + S ND=$G(^PS(53.1,+ORD,0)) + I ND S ND25=$S(($P(ND,U,15)=PAT):$G(^PS(53.1,+ORD,2.5)),1:"") + S DUR=$P(ND25,U,4) I DUR]"" S:$E(DUR)="m"!($E(DUR)="l")!($E(DUR)="d")!($E(DUR)="h") IVLIMIT=1 S DUR=$S($G(RAW):DUR,1:$$FMTDUR(DUR)) Q + S DUR=$P(ND25,U,2) I DUR]"" S DUR=$S($G(RAW):DUR,1:$$FMTDUR(DUR)) + Q + ; +FMTDUR(DURCODE) ; + N DUNIT,DNUM,BAD S BAD=0 + ;PSJ*5*180 - Add PSJBADD variable + K PSJBADD S PSJBADD=0 + S DUNIT=$E(DURCODE),DNUM=$P(DURCODE,DUNIT,2) I 'DNUM S BAD=1 + I DUNIT'="",DUNIT'?1(1U,1L) S PSJBADD=1 + S DUNIT=$S(DUNIT="D"!(DUNIT="d"):" day",DUNIT="H"!(DUNIT="h"):" hour",DUNIT="W":" week",DUNIT="L":" month",DUNIT="M":" minute",DUNIT="S":" second",DUNIT="m":" ml",DUNIT="l":" liter",1:"") + S:DUNIT="" BAD=1 I (DNUM'=1),(DUNIT'["ml") S DUNIT=DUNIT_"s" + I PSJBADD=1 S PSGACT=$TR($G(PSGACT),"F") + Q $S(PSJBADD=1:"*INVALID DURATION/LIMIT*",BAD:"",1:DNUM_DUNIT) + ; +DURMIN(DCOD) ; + N DUR,DMIN,CHR S DUR="" F I=1:1:$L(DCOD) S CHR=$E(DCOD,I) I CHR?1N S DUR=DUR_CHR + S DMIN=DUR*$S(DCOD["L":43200,DCOD["W":10080,DCOD["M":1,DCOD["S":(1/60),DCOD["D":1440,1:0) S DMIN=+$FN(DMIN,"",1) + Q DMIN + ; +DUR ; + N DUROUT,LABEL,IVLIMIT + Q:'$G(PSJORD) S PSJL="" + S DUROUT=$$GETDUR^PSJLIVMD(PSGP,+PSJORD,$S(PSJORD["P":"P",1:"IV")) + S LABEL=$S($G(IVLIMIT):"IV Limit: ",1:"Duration: ") K IVLIMIT + S PSJL=$$SETSTR^VALM1(LABEL,PSJL,12,10) + S PSJL=PSJL_DUROUT + Q diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMPRU.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMPRU.m index 9dd29b27..7b40254e 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMPRU.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMPRU.m @@ -1,60 +1,55 @@ -PSJLMPRU ;BIR/MLM-INPATIENT LISTMAN UD PROFILE UTILITIES ;27 Aug 98 / 8:45 AM - ;;5.0; INPATIENT MEDICATIONS ;**16,58,85,110,185**;16 DEC 97;Build 6 - ; - ; Reference to ^PSDRUG is supported by DBIA 2192. - ; Reference to ^PS(55 is supported by DBIA 2191. - ; -PUD(DFN,ON,PSJF,DN) ; Setup LM profile view for UD - N PSJFLAG,PSJV - ; Naked references on the two lines below refer to full reference ^PS(55,DFN,5,+ON in PSJF using indirection. - S ND=$G(@(PSJF_+ON_",0)")),SCH=$G(^(2)),ND4=$G(^(4)),ND6=$G(^(6)),NDP2=$G(^(.2)),PSJFLAG=$P(NDP2,U,7),X=$P(DN,U,2),DO=$S('X:"",1:$G(^(+X))) S:X=.2 DO=$P(DO,U,2) - S ND14=$G(@(PSJF_+ON_",14,0)")),RNDT="" I $P(ND14,"^",3) S ND14=$G(^($P(ND14,"^",3),0)),RNDT=$P(ND14,"^") - I "AO"[PSJC D - .;S V='$P(ND4,"^",UDU),PSJL=$$SETSTR^VALM1($S(ND4="":" ",$P(ND4,"^",12):"D",$P(ND4,"^",18)&($P(ND4,"^",19)!V):"H",$P(ND4,"^",22)&($P(ND4,"^",23)!V):"H",$P(ND4,"^",15)&($P(ND4,"^",16)!V):"R",1:" "),PSJL,5,1) - .S V='$P(ND4,"^",UDU),PSJL=$$SETSTR^VALM1($S(ND4="":" ",$P(ND4,"^",12):"D",$P(ND4,"^",19)&$P(ND4,"^",18):"H",$P(ND4,"^",23)&$P(ND4,"^",22):"H",$P(ND4,"^",15)&($P(ND4,"^",16)!V):"R",1:" "),PSJL,5,1) - .;S X=$S(+PSJSYSU=1&V:1,+PSJSYSU=3&V:1,1:0) - .S PSJV=$S($P(NDP2,U,4)="D":"d",1:" ")_$S(+PSJSYSU=1&V:"->",+PSJSYSU=3&V:"->",1:" ") I PSJFLAG D CNTRL^VALM10(PSJLN,1,4,IORVON,IORVOFF,0) - .S PSJL=$$SETSTR^VALM1(PSJV,PSJL,6,3) - ;I $S(PSJC["C":0,1:PSJC["B") S PSJL=$$SETSTR^VALM1($S($P(ND4,"^",12):"D",1:" ")_$S($P(ND,U,4)="I":"",PSJSYSU:"->",1:""),PSJL,6,3) - ;I $S(PSJC["C":0,1:PSJC["B") S PSJL=$$SETSTR^VALM1($S($P(ND4,"^",12):"D",1:" ") - S RTE=$P(ND,"^",3),SM=$S('$P(ND,"^",5):0,$P(ND,"^",6):1,1:2),STAT=$S($P(ND,"^",9)]"":$P(ND,"^",9),1:"NF"),PF=$E("*",$P(ND,"^",20)>0),PSGID=$P(SCH,"^",2),SD=$P(SCH,"^",4),SCH=$P(SCH,"^") - I STAT="A",$P(ND,U,27)="R" S STAT="R" - ;S NF=$P(DN,"^",3),WS=$S(PSJPWD:$$WS^PSJO(PSJPWD,PSGP,PSJF,+ON),1:0) - S NF="",WS=$S(PSJPWD:$$WS^PSJO(PSJPWD,PSGP,PSJF,+ON),1:0) - N PSJDISP F PSJDISP=0:0 S PSJDISP=$O(@(PSJF_+ON_",1,"_PSJDISP_")")) Q:'PSJDISP D - .I $P($G(^PSDRUG(+$P($G(@(PSJF_+ON_",1,"_PSJDISP_",0)")),"^"),0)),"^",9)=1 S NF=1 - NEW DRUGNAME,PSGID1,SD1,LEN,PSGID1,SD1 S LEN=$S($D(PSJEXPT):8,1:5) - F X="PSGID","SD" S @(X_1)=$S(PSJC["C":"*****",1:$E($$ENDTC^PSGMI(@X),1,LEN)) - D DRGDISP^PSJLMUT1(PSGP,ON,39,54,.DRUGNAME,0) - F PSJX=0:0 S PSJX=$O(DRUGNAME(PSJX)) Q:'PSJX D - . I PSJX=1 D - ..I PSJFLAG D CNTRL^VALM10(PSJLN,1,4,IORVON,IORVOFF,0) - ..S PSJL=$$SETSTR^VALM1($S($E(PSJS)="*":$P(PSJS,"^"),1:DRUGNAME(PSJX)),PSJL,9,39) - ..S PSJL=$$SETSTR^VALM1($S(PSJC["C":"?",PSJSCHT'="z":PSJSCHT,1:"?"),PSJL,50,3) - ..S PSJL=PSJL_PSGID1_" "_SD1_" "_$E(STAT,1)_" "_$S($G(RNDT):$E($$ENDTC^PSGMI(RNDT),1,LEN),1:"") - ..I NF!WS!SM!PF S PSJL=$$SETSTR^VALM1($S(NF:"NF ",WS:"WS ",SM:$E("HSM",SM,3),1:""),PSJL,69,3) S:PF PSJL=$$SETSTR^VALM1("*",PSJL,79,1) - . I PSJX>1 S PSJL="",PSJL=$$SETSTR^VALM1(DRUGNAME(PSJX),PSJL,11,66) - . D SETTMP("PSJPRO",PSJL) I ($P(NDP2,U,4)="S"),STAT="P" D CNTRL^VALM10((PSJLN-1),9,9+$L(PSJL),IOINHI_IOBON,IOINORM,0) - D:$P(ND6,"^")]"" PTXT($P(ND6,"^"),"PSJPRO",10,66) - Q - ; -PTXT(TXT,SUB,LM,RM) ; Display Instructions/dosage ordered. - ;* Input: TXT = Text to display. - ; SUB = First subscript for ^TMP node, ** MUST be PSJ namespace ** - ; LM = Begin display of text after LM spaces. - ; RM = Length of display text. - ; - ;BHW;PSJ*5*185;Extra spaces causes display to "skip" part of the field. - ;S PSJL="",$P(PSJL," ",LM)="" F X=1:1 S WRD=$P(TXT," ",X) Q:WRD="" D - S PSJL="",$P(PSJL," ",LM)="" - F X=1:1:$L(TXT," ") S WRD=$P(TXT," ",X) D - .;BHW;PSJ*5*185;check if end of string or just extra space. - .I WRD="" S PSJL=PSJL_" " Q - .I $L(PSJL_" "_WRD)'",+PSJSYSU=3&V:"->",1:" ") I PSJFLAG D CNTRL^VALM10(PSJLN,1,4,IORVON,IORVOFF,0) + .S PSJL=$$SETSTR^VALM1(PSJV,PSJL,6,3) + ;I $S(PSJC["C":0,1:PSJC["B") S PSJL=$$SETSTR^VALM1($S($P(ND4,"^",12):"D",1:" ")_$S($P(ND,U,4)="I":"",PSJSYSU:"->",1:""),PSJL,6,3) + ;I $S(PSJC["C":0,1:PSJC["B") S PSJL=$$SETSTR^VALM1($S($P(ND4,"^",12):"D",1:" ") + S RTE=$P(ND,"^",3),SM=$S('$P(ND,"^",5):0,$P(ND,"^",6):1,1:2),STAT=$S($P(ND,"^",9)]"":$P(ND,"^",9),1:"NF"),PF=$E("*",$P(ND,"^",20)>0),PSGID=$P(SCH,"^",2),SD=$P(SCH,"^",4),SCH=$P(SCH,"^") + I STAT="A",$P(ND,U,27)="R" S STAT="R" + ;S NF=$P(DN,"^",3),WS=$S(PSJPWD:$$WS^PSJO(PSJPWD,PSGP,PSJF,+ON),1:0) + S NF="",WS=$S(PSJPWD:$$WS^PSJO(PSJPWD,PSGP,PSJF,+ON),1:0) + N PSJDISP F PSJDISP=0:0 S PSJDISP=$O(@(PSJF_+ON_",1,"_PSJDISP_")")) Q:'PSJDISP D + .I $P($G(^PSDRUG(+$P($G(@(PSJF_+ON_",1,"_PSJDISP_",0)")),"^"),0)),"^",9)=1 S NF=1 + NEW DRUGNAME,PSGID1,SD1,LEN,PSGID1,SD1 S LEN=$S($D(PSJEXPT):8,1:5) + F X="PSGID","SD" S @(X_1)=$S(PSJC["C":"*****",1:$E($$ENDTC^PSGMI(@X),1,LEN)) + D DRGDISP^PSJLMUT1(PSGP,ON,39,54,.DRUGNAME,0) + F PSJX=0:0 S PSJX=$O(DRUGNAME(PSJX)) Q:'PSJX D + . I PSJX=1 D + ..I PSJFLAG D CNTRL^VALM10(PSJLN,1,4,IORVON,IORVOFF,0) + ..S PSJL=$$SETSTR^VALM1($S($E(PSJS)="*":$P(PSJS,"^"),1:DRUGNAME(PSJX)),PSJL,9,39) + ..S PSJL=$$SETSTR^VALM1($S(PSJC["C":"?",PSJSCHT'="z":PSJSCHT,1:"?"),PSJL,50,3) + ..S PSJL=PSJL_PSGID1_" "_SD1_" "_$E(STAT,1)_" "_$S($G(RNDT):$E($$ENDTC^PSGMI(RNDT),1,LEN),1:"") + ..I NF!WS!SM!PF S PSJL=$$SETSTR^VALM1($S(NF:"NF ",WS:"WS ",SM:$E("HSM",SM,3),1:""),PSJL,69,3) S:PF PSJL=$$SETSTR^VALM1("*",PSJL,79,1) + . I PSJX>1 S PSJL="",PSJL=$$SETSTR^VALM1(DRUGNAME(PSJX),PSJL,11,66) + . D SETTMP("PSJPRO",PSJL) I ($P(NDP2,U,4)="S"),STAT="P" D CNTRL^VALM10((PSJLN-1),9,9+$L(PSJL),IOINHI_IOBON,IOINORM,0) + D:$P(ND6,"^")]"" PTXT($P(ND6,"^"),"PSJPRO",10,66) + Q + ; +PTXT(TXT,SUB,LM,RM) ; Display Instructions/dosage ordered. + ;* Input: TXT = Text to display. + ; SUB = First subscript for ^TMP node, ** MUST be PSJ namespace ** + ; LM = Begin display of text after LM spaces. + ; RM = Length of display text. + ; + S PSJL="",$P(PSJL," ",LM)="" F X=1:1 S WRD=$P(TXT," ",X) Q:WRD="" D + .I $L(PSJL_" "_WRD)'15 - S PSJL=$S($D(PSGEFN(12)):$E(" *",PSGEFN(12))_" (12)",1:" ")_" Dispense Drug",PSJL=$$SETSTR^VALM1("U/D",PSJL,54,60),PSJL=$$SETSTR^VALM1("Inactive Date",PSJL,65,16) D SETTMP,CNTRL^VALM10(13,1,80,IOUON,IOUOFF,0) - ;S $P(PSJL,"-",80)="" D SETTMP - NEW PSJX - F Q=0:0 S Q=$O(^PS(53.45,PSJSYSP,2,Q)) Q:'Q S ND=$G(^(Q,0)) D - .S D=$P(ND,"^"),PSGID=$P(ND,"^",3) I PSGID S PSGID=$$ENDTC^PSGMI(PSGID) - .S D=$S(D="":"NOT FOUND",'$D(^PSDRUG(D,0)):D,$P(^(0),"^")]"":$P(^(0),"^"),1:D_";PSDRUG(") - .S PSJL=" "_D_$$DDNF^PSJDIN(+ND),PSJL=$$SETSTR^VALM1($S($P(ND,"^",2):$S($P(ND,"^",2)=.5:"1/2",$P(ND,"^",2)=.25:"1/4",1:$P(ND,"^",2)),$P(ND,"^",2)=0:0,1:1),PSJL,54,63) S:PSGID PSJL=$$SETSTR^VALM1(PSGID,PSJL,65,16) D D SETTMP - ..S PSJX=$G(PSJX)+1 - ..I $G(PSGOEEF(109)) D CNTRL^VALM10(13+PSJX,7,73,IORVON_IOBON,IORVOFF_IOBOFF,0) - I $S(PSGORD["P":$O(^PS(53.1,+$G(PSGORD),12,0)),1:$O(^PS(55,PSGP,5,+PSGORD,12,0))) S PSJL="Provider Comments:" D SETTMP S PSJL="" D - .F Q=0:0 S Q=$S(PSGORD["P":$O(^PS(53.1,+$G(PSGORD),12,Q)),1:$O(^PS(55,PSGP,5,+PSGORD,12,Q))) Q:'Q S PSJL=$G(^(Q,0)) D SETTMP - D SETTMP S PSJL=$$SETSTR^VALM1($S($D(PSGEFN(7)):$E(" *",PSGEFN(7)+1)_"(7)",1:" ")_"Self Med: "_PSGSMN,PSJL,1,24) - S:PSGSM&PSGHSM PSJL=$$SETSTR^VALM1(" (HS)",PSJL,16,7) D SETTMP D:$G(PSGOEEF(5)) HILITE(7) - D SETTMP S PSJL="Entry By: "_PSGEBN,PSJL=$$SETSTR^VALM1("Entry Date: "_$P(PSGLIN,U,2),PSJL,51,39) D SETTMP - I $G(PSGLRN) D SETTMP S PSJL="Renewed By: "_$$ENNPN^PSGMI($P(PSGLRN,"^",2)) D SETTMP - D SETTMP S PSJL="(13)"_" Comments:" - D:'$O(^PS(53.45,PSJSYSP,1,0)) SETTMP - D SETTMP F Q=0:0 S Q=$O(^PS(53.45,PSJSYSP,1,Q)) Q:'Q S PSJWPL=PSJL_$S($E(PSJL)=" ":"",1:" ")_$G(^(Q,0)),PSJL="" D DISPLAY - D SETTMP - I PSGORD["P",($P($G(^PS(53.1,+PSGORD,0)),U,9)="P"),$O(^PS(53.1,+PSGORD,10,0)) D - .D SETTMP S PSJL="Order Checks:" D SETTMP - .F Q=0:0 S Q=$O(^PS(53.1,+PSGORD,10,Q)) Q:'Q D - ..S PSJL="" D SETTMP S PSJL=$G(^PS(53.1,+PSGORD,10,Q,0)) D SETTMP - ..S PSJL="Overriding Provider: "_$P($G(^PS(53.1,+PSGORD,10,Q,1)),U) D SETTMP - ..S PSJL="Overriding Reason: " F X=0:0 S X=$O(^PS(53.1,+PSGORD,10,Q,2,X)) Q:'X D - ...S PSJL=PSJL_$G(^PS(53.1,+PSGORD,10,Q,2,X,0)) D SETTMP S PSJL=" " -ACTFLG ; - S ND4=$S(PSGORD["P":$G(^PS(53.1,+PSGORD,4)),1:$G(^PS(55,PSGP,5,+PSGORD,4))) - S AT="",Y="12,13,D,18,19,H1,22,23,H0,15,16,R" F X=1:3:12 I $P(ND4,"^",$P(Y,",",X)),$P(ND4,"^",$P(Y,",",X+1)) S AT=$P(Y,",",X+2) Q - I AT="",'$P(ND4,"^",$S($P(PSJSYSU,";",3)>1:3,1:1)) S AT="V"_$S($P(ND4,"^",18):"H1",$P(ND4,"^",22):"H0",$P(ND4,"^",15):"R",1:"") - I AT]"" D - .S PSJL="" D SETTMP - .S PSJL="ORDER "_$S(AT["V":"NOT VERIFIED"_$S($P(AT,"V",2)="":"",1:" ("_$S(AT["H1":"ON HOLD",AT["H0":"OFF HOLD",1:"RENEWAL")_")"),1:"MARKED TO BE "_$S(AT["D":"CANCELLED",AT["H1":"PLACED ON HOLD",AT["H0":"TAKEN OFF OF HOLD",1:"RENEWED")) - I AT'["V",AT["H1",$D(^PS(55,PSGP,5.1)) S AT=^(5.1) I $P(AT,"^",7),$P(AT,"^",10)]"" S PSJL=PSJL_" ("_$P(AT,"^",10)_")" - D SETTMP - S VALMCNT=PSJLN-1 - K PSGSMN,Q,Y,Y1,Y2,PSGLRN - S VALM("TITLE")=PSGSTAT_" UNIT DOSE "_$S((PSGSTAT="PENDING")&($G(PSGPRIO)]""):"("_PSGPRIO_")",$G(PSGPRIO)="DONE":"("_PSGPRIO_")",1:"") I $D(PSJLMP2) S VALMBG=16 K PSJLMP2 -TEST ; - I $G(PSGPFLG) S VALMSG="INVALID ORDERABLE ITEM" - I $G(PSGDI) S VALMSG=$S($G(VALMSG)="":"INVALID",1:VALMSG_",")_" DISPENSE DRUG" - I $G(PSGPI) S VALMSG=$S($G(VALMSG)="":"INVALID",1:VALMSG_",")_" PROVIDER" - Q -DISPLAY ; - S PSJL=PSJWPL D SETTMP - ;F X=1:1 S WRD=$P(PSJWPL," ",X) Q:WRD="" D - ;.I $L(PSJL_" "_WRD)'<80 D SETTMP S PSJL=$P(PSJWPL,PSJL,2) S:$E(PSJL,1)=" " PSJL=$E(PSJL,2,999),PSJWPL="" Q - ;.S PSJL=PSJL_$S(PSJL="":"",1:" ")_WRD - Q - ; -SETTMP ; - S ^TMP("PSJUDE",$J,PSJLN,0)=PSJL,PSJLN=PSJLN+1,PSJL="" - Q - ; -HILITE(FLD) ; - N COL,LIN,WID,X - ;Q:'$G(PSGOEENO) - S X="$T("_FLD_"^PSJLMUDE)",@("X="_X),X=$P(X,";;",2),LIN=+X,COL=$P(X,",",2),LAB=$P(X,",",3),X=$P(X,",",4),WID=(LAB+$L(@X)) - ;D CNTRL^VALM10(LIN,COL,WID,IORVON_IOBON,IOINORM,0) - I FLD=7 S LIN=+$G(PSJLN)-1 Q:LIN<13 - D CNTRL^VALM10(LIN,COL,WID,IORVON_IOBON,IORVOFF_IOBOFF,0) - Q - ; -1 ;;1,5,16,PSGPDN -2 ;;3,5,16,PSGDO -3 ;;4,58,7,PSGSDN -4 ;;5,10,11,PSGMRN -5 ;;6,59,6,PSGFDN -6 ;;7,6,15,PSGSTN -7 ;;18,5,14,PSGSMN -8 ;;8,11,12,PSGSCH -9 ;;9,8,13,PSGAT -10 ;;10,11,10,PSGPRN -11 ;;11,7,22,PSGSI -ENKILL ; - K PSGAT,PSGEB,PSGEFN,PSGFD,PSGHSM,PSGNEFD,PSGNESD,PSGOEEF,PSGOEER,PSGOFD,PSGOHSM,PSGOMR,PSGOMRN,PSGOPD,PSGOPDN,PSGOPR,PSGOSCH,PSGOSD,PSGOSM,PSGOST,PSGPD,PSGPDN,PSGPR,PSGSD,PSGSM Q +PSJLMUDE ;BIR/MLM-SHOW FIELDS FOR EDIT (LISTMAN STYLE) ;01 JUNE 00 / 2:40 PM + ;;5.0; INPATIENT MEDICATIONS ;**7,47,50,63,64,58,80,116,110,111,164,175**;16 DEC 97;Build 18 + ;NFI-UD Fr#:2 chgs@init+4 to display non-formulary (N/F) + ;also chgs @init+23 + ; + ; Reference to ^PS(55 is supported by DBIA# 2191 + ; Reference to ^PSDRUG is supported by DBIA 2192 + ; +INIT(PSGP,PSGORD) ; + N D,ND,PSJBCMA,PSJL,PSJLM,PSJLN,Q,QQ,PSJDUR K ^TMP("PSJUDE",$J) + K:$G(PSJNORD) PSGOEEF S PSJLN=1 + D CLEAN^VALM10 + S PSJL=$S($D(PSGEFN(1)):$E(" *",PSGEFN(1)+1)_"(1)",1:" "),PSJL=$$SETSTR^VALM1("Orderable Item: "_PSGPDN_$$OINF^PSJDIN(PSGPD),PSJL,5,74) D D SETTMP D:$G(PSGOEEF(108))!($G(PSGOEEF(101))) HILITE(1) + . N Q,PSJDDA,PSJVD F Q=0:0 S Q=$O(^PS(53.45,PSJSYSP,2,Q)) Q:'Q S PSJDDA(+$G(^(Q,0)))="" + . S PSJVD=$$DINFLUD^PSJDIN(PSGPD,.PSJDDA) + . S PSJL=$$SETSTR^VALM1(PSJVD,PSJL,75,80) + . D:PSJVD]"" CNTRL^VALM10(1,75,5,IORVON,IORVOFF,0) + I $G(PSJORD)["P" D REQDT^PSJLIVMD(PSJORD) + S PSJL="Instructions: "_PSGOINST D PTXT^PSJLMPRU(PSJL,"PSJUDE",6,120) + S PSJL=$S($D(PSGEFN(2)):$E(" *",PSGEFN(2)+1)_"(2)",1:" "),PSJL=$$SETSTR^VALM1("Dosage Ordered: "_PSGDO,PSJL,5,76) D SETTMP D:$G(PSGOEEF(109)) HILITE(2) + I $G(PSGRDTX) S PSJDUR=$$FMTDUR^PSJLIVMD($P($G(PSGRDTX),U,2)) + I $G(PSJORD),($G(PSJDUR)="") S P=$S(PSJORD["U":5,PSJORD["V":"IV",PSJORD["P":"P",1:-1) S PSJDUR=$$GETDUR^PSJLIVMD(PSGP,+PSJORD,P) + S PSJL=$$SETSTR^VALM1("Duration: "_$G(PSJDUR),PSJL,11,25) + S PSJL=$$SETSTR^VALM1($S($D(PSGEFN(3)):$E(" *",PSGEFN(3)+1)_"(3)",1:" ")_"Start: "_$P(PSGSDN,U,2),PSJL,54,26) D:$G(PSGOEEF(10)) HILITE(3) + I $G(PSGORD)["P" N ND0,OLDO S ND0=@(PSGOEEWF_"0)") I $P(ND0,"^",24)="R" S OLDO=$P(ND0,"^",25) I OLDO,(OLDO["U") D + . N OSTRT,OSTRTN S OSTRT=$G(@("^PS(55,"_PSGP_",5,"_+OLDO_",2)")),OSTRT=$P(OSTRT,"^",2) Q:'OSTRT S OSTRTN=$$ENDTC^PSGMI(+OSTRT) + . S PSJL=$$SETSTR^VALM1($S($D(PSGEFN(3)):$E(" *",PSGEFN(3)+1)_"(3)",1:" ")_"Start: "_OSTRTN,PSJL,54,26) + D SETTMP + S PSJL=$S($D(PSGEFN(4)):$E(" *",PSGEFN(4)+1)_"(4)",1:" "),PSJL=$$SETSTR^VALM1("Med Route: "_PSGMRN,PSJL,10,35) D:$G(PSGOEEF(3)) HILITE(4) + I $G(PSJORD)["P" N PSGRNDT S PSGRNDT=$$LASTREN^PSJLMPRI(DFN,PSGORD) S:PSGRNDT PSGRNDT=$$ENDTC^PSGMI(+PSGRNDT),PSJL=$$SETSTR^VALM1("Renewed: "_PSGRNDT,PSJL,56,32) + I '$G(PSGRNDT),$G(PSGRDTX) D + . I $D(PSGRDTX)<10 S PSGRSDN=$$ENDTC^PSGMI(+PSGRDTX),PSJL=$$SETSTR^VALM1("REQUESTED START: "_PSGRSDN,PSJL,48,32) Q + . I $G(PSGRDTX(+$G(PSJORD),"PSGRSD")),$P($G(PSGSDN),U,2) S PSGRSDN=$$ENDTC^PSGMI(PSGRDTX(+PSJORD,"PSGRSD")),PSJL=$$SETSTR^VALM1("Calc Start: "_PSGRSDN,PSJL,53,32) D + .. I PSGSD'=PSGRDTX(+PSJORD,"PSGRSD") D CNTRL^VALM10(5,53,80,IORVON,IORVOFF) + ; Indirect reference in PSGOEEWF below refers to either ^PS(53.1 or ^PS(55,DFN,5,. Naked reference refers to full indirect reference + I $G(PSJORD)["U" N ND14 S ND14=$G(@(PSGOEEWF_"14,0)")) I ND14]"" S ND14=$G(^($P(ND14,"^",3),0)),RNDT=$P(ND14,"^") I RNDT D + . N PSGRNDT S PSGRNDT=$$ENDTC^PSGMI(+RNDT),PSJL=$$SETSTR^VALM1("Renewed: "_PSGRNDT,PSJL,56,32) + D SETTMP + I PSGORD]"" S PSJBCMA=$$BCMALG^PSJUTL2(PSGP,PSGORD) + I $G(PSJBCMA)]"" S PSJL=$$SETSTR^VALM1(PSJBCMA,PSJL,1,52) + S PSJL=$$SETSTR^VALM1($S($D(PSGEFN(5)):$E(" *",PSGEFN(5)+1)_"(5)",1:" ")_" Stop: "_$P(PSGFDN,U,2),PSJL,54,26) D SETTMP D:$G(PSGOEEF(25))!($G(PSGOEEF(34))) HILITE(5) + S PSJL=$S($D(PSGEFN(6)):$E(" *",PSGEFN(6)+1)_"(6)",1:" "),PSJL=$$SETSTR^VALM1("Schedule Type: "_PSGSTN,PSJL,6,45) D:$G(PSGOEEF(7)) HILITE(6) + I $G(PSJORD)["P",$G(PSGRDTX(+$G(PSJORD),"PSGRFD")),$P($G(PSGFDN),U,2) S PSGRFDN=$$ENDTC^PSGMI(PSGRDTX(+PSJORD,"PSGRFD")),PSJL=$$SETSTR^VALM1("Calc Stop: "_PSGRFDN,PSJL,54,26) D + . I PSGFD'=PSGRDTX(+PSJORD,"PSGRFD") D CNTRL^VALM10(7,54,80,IORVON,IORVOFF) + D SETTMP + S PSGSMN=$P("NO^YES",U,PSGSM+1) + S PSJL=$S($D(PSGEFN(8)):$E(" *",PSGEFN(8)+1)_"(8)",1:" "),PSJL=$$SETSTR^VALM1("Schedule: "_PSGSCH_$G(SCHMSG),PSJL,11,68) D SETTMP D:$G(PSGOEEF(26)) HILITE(8) + S PSJL=$S($D(PSGEFN(9)):$E(" *",PSGEFN(9)+1)_"(9)",1:" "),PSJL=$$SETSTR^VALM1("Admin Times: "_PSGAT,PSJL,8,71) D SETTMP D:$G(PSGOEEF(39))!($G(PSGOEEF(41))) HILITE(9) + S PSJL=$S($D(PSGEFN(10)):$E(" *",PSGEFN(10)+1)_"(10)",1:" "),PSJL=$$SETSTR^VALM1("Provider: "_PSGPRN,PSJL,11,68) D:$G(PSGOEEF(1)) HILITE(10) D SETTMP + S PSJL=$S($D(PSGEFN(11)):$E(" *",PSGEFN(11))_"(11)",1:" ")_" Special Instructions"_$S($P(PSGSI,"^",2)=1:"!: ",1:": ")_$P(PSGSI,"^") D PTXT^PSJLMPRU(PSJL,"PSJUDE",1,80) + S PSJL="" D SETTMP D:$G(PSGOEEF(8)) HILITE(11) + ; E3R 16130 + I $O(^PS(53.45,PSJSYSP,2,1)) F S PSJL="" D SETTMP Q:PSJLN>15 + S PSJL=$S($D(PSGEFN(12)):$E(" *",PSGEFN(12))_" (12)",1:" ")_" Dispense Drug",PSJL=$$SETSTR^VALM1("U/D",PSJL,54,60),PSJL=$$SETSTR^VALM1("Inactive Date",PSJL,65,16) D SETTMP,CNTRL^VALM10(13,1,80,IOUON,IOUOFF,0) + N PSJX,PSGID + F Q=0:0 S Q=$O(^PS(53.45,PSJSYSP,2,Q)) Q:'Q S ND=$G(^(Q,0)) D + .S D=$P(ND,"^"),PSGID=$P(ND,"^",3) I PSGID S PSGID=$$ENDTC^PSGMI(PSGID) + .S D=$S(D="":"NOT FOUND",'$D(^PSDRUG(D,0)):D,$P(^(0),"^")]"":$P(^(0),"^"),1:D_";PSDRUG(") + .S PSJL=" "_D_$$DDNF^PSJDIN(+ND),PSJL=$$SETSTR^VALM1($S($P(ND,"^",2):$S($P(ND,"^",2)=.5:"1/2",$P(ND,"^",2)=.25:"1/4",1:$P(ND,"^",2)),$P(ND,"^",2)=0:0,1:1),PSJL,54,63) S:PSGID PSJL=$$SETSTR^VALM1(PSGID,PSJL,65,16) D D SETTMP + ..S PSJX=$G(PSJX)+1 + ..I $G(PSGOEEF(109)) D CNTRL^VALM10(13+PSJX,7,73,IORVON_IOBON,IORVOFF_IOBOFF,0) + I $S(PSGORD["P":$O(^PS(53.1,+$G(PSGORD),12,0)),1:$O(^PS(55,PSGP,5,+PSGORD,12,0))) S PSJL="Provider Comments:" D SETTMP S PSJL="" D + .F Q=0:0 S Q=$S(PSGORD["P":$O(^PS(53.1,+$G(PSGORD),12,Q)),1:$O(^PS(55,PSGP,5,+PSGORD,12,Q))) Q:'Q S PSJL=$G(^(Q,0)) D SETTMP + D SETTMP S PSJL=$$SETSTR^VALM1($S($D(PSGEFN(7)):$E(" *",PSGEFN(7)+1)_"(7)",1:" ")_"Self Med: "_PSGSMN,PSJL,1,24) + S:PSGSM&PSGHSM PSJL=$$SETSTR^VALM1(" (HS)",PSJL,16,7) D SETTMP D:$G(PSGOEEF(5)) HILITE(7) + D SETTMP S PSJL="Entry By: "_PSGEBN,PSJL=$$SETSTR^VALM1("Entry Date: "_$P(PSGLIN,U,2),PSJL,51,39) D SETTMP + I $G(PSGLRN) D SETTMP S PSJL="Renewed By: "_$$ENNPN^PSGMI($P(PSGLRN,"^",2)) D SETTMP + D SETTMP S PSJL="(13)"_" Comments:" + D:'$O(^PS(53.45,PSJSYSP,1,0)) SETTMP + D SETTMP F Q=0:0 S Q=$O(^PS(53.45,PSJSYSP,1,Q)) Q:'Q S PSJWPL=PSJL_$S($E(PSJL)=" ":"",1:" ")_$G(^(Q,0)),PSJL="" D DISPLAY + D SETTMP + I PSGORD["P",($P($G(^PS(53.1,+PSGORD,0)),U,9)="P"),$O(^PS(53.1,+PSGORD,10,0)) D + .D SETTMP S PSJL="Order Checks:" D SETTMP + .F Q=0:0 S Q=$O(^PS(53.1,+PSGORD,10,Q)) Q:'Q D + ..S PSJL="" D SETTMP S PSJL=$G(^PS(53.1,+PSGORD,10,Q,0)) S PSJWPL=PSJL D DISPLAY + ..S PSJL="Overriding Provider: "_$P($G(^PS(53.1,+PSGORD,10,Q,1)),U) D SETTMP + ..S PSJL="Overriding Reason: " F X=0:0 S X=$O(^PS(53.1,+PSGORD,10,Q,2,X)) Q:'X D + ...S PSJL=PSJL_$G(^PS(53.1,+PSGORD,10,Q,2,X,0)) D SETTMP S PSJL=" " +ACTFLG ; + N ND4,AT,Y,X + S ND4=$S(PSGORD["P":$G(^PS(53.1,+PSGORD,4)),1:$G(^PS(55,PSGP,5,+PSGORD,4))) + S AT="",Y="12,13,D,18,19,H1,22,23,H0,15,16,R" F X=1:3:12 I $P(ND4,"^",$P(Y,",",X)),$P(ND4,"^",$P(Y,",",X+1)) S AT=$P(Y,",",X+2) Q + I AT="",'$P(ND4,"^",$S($P(PSJSYSU,";",3)>1:3,1:1)) S AT="V"_$S($P(ND4,"^",18):"H1",$P(ND4,"^",22):"H0",$P(ND4,"^",15):"R",1:"") + I AT]"" D + .S PSJL="" D SETTMP + .S PSJL="ORDER "_$S(AT["V":"NOT VERIFIED"_$S($P(AT,"V",2)="":"",1:" ("_$S(AT["H1":"ON HOLD",AT["H0":"OFF HOLD",1:"RENEWAL")_")"),1:"MARKED TO BE "_$S(AT["D":"CANCELLED",AT["H1":"PLACED ON HOLD",AT["H0":"TAKEN OFF OF HOLD",1:"RENEWED")) + I AT'["V",AT["H1",$D(^PS(55,PSGP,5.1)) S AT=^(5.1) I $P(AT,"^",7),$P(AT,"^",10)]"" S PSJL=PSJL_" ("_$P(AT,"^",10)_")" + D SETTMP + S VALMCNT=PSJLN-1 + K PSGSMN,Q,Y,Y1,Y2,PSGLRN + S VALM("TITLE")=PSGSTAT_" UNIT DOSE "_$S((PSGSTAT="PENDING")&($G(PSGPRIO)]""):"("_PSGPRIO_")",$G(PSGPRIO)="DONE":"("_PSGPRIO_")",1:"") I $D(PSJLMP2) S VALMBG=16 K PSJLMP2 +TEST ; + I $G(PSGPFLG) S VALMSG="INVALID ORDERABLE ITEM" + I $G(PSGDI) S VALMSG=$S($G(VALMSG)="":"INVALID",1:VALMSG_",")_" DISPENSE DRUG" + I $G(PSGPI) S VALMSG=$S($G(VALMSG)="":"INVALID",1:VALMSG_",")_" PROVIDER" + Q + ; +DISPLAY ; + N X,LEN,LIM,PCS + S LIM=$L(PSJWPL," "),PCS=1 + F X=1:1:LIM S LEN=$L($P(PSJWPL," ",PCS,X)) D + . I LEN'<72!(X=LIM) D + .. S PSJL=$P(PSJWPL," ",PCS,X) + .. I PCS>1 S PSJL=" "_PSJL + .. S PCS=X+1 + .. D SETTMP + Q + ; +SETTMP ; + S ^TMP("PSJUDE",$J,PSJLN,0)=PSJL,PSJLN=PSJLN+1,PSJL="" + Q + ; +HILITE(FLD) ; + N COL,LAB,LIN,WID,X + S X="$T("_FLD_"^PSJLMUDE)",@("X="_X),X=$P(X,";;",2),LIN=+X,COL=$P(X,",",2),LAB=$P(X,",",3),X=$P(X,",",4),WID=(LAB+$L(@X)) + I FLD=7 S LIN=+$G(PSJLN)-1 Q:LIN<13 + D CNTRL^VALM10(LIN,COL,WID,IORVON_IOBON,IORVOFF_IOBOFF,0) + Q + ; +1 ;;1,5,16,PSGPDN +2 ;;3,5,16,PSGDO +3 ;;4,58,7,PSGSDN +4 ;;5,10,11,PSGMRN +5 ;;6,59,6,PSGFDN +6 ;;7,6,15,PSGSTN +7 ;;18,5,14,PSGSMN +8 ;;8,11,12,PSGSCH +9 ;;9,8,13,PSGAT +10 ;;10,11,10,PSGPRN +11 ;;11,7,22,PSGSI +ENKILL ; + K PSGAT,PSGDO,PSGEB,PSGEFN,PSGFD,PSGFDN,PSGHSM,PSGNEFD,PSGNESD,PSGOEEF,PSGOEER,PSGOFD,PSGOHSM,PSGOMR,PSGMRN,PSGOPD,PSGOPDN,PSGOPR,PSGOSCH,PSGOSD + K PSGOSM,PSGOST,PSGPD,PSGPDN,PSGPR,PSGSD,PSGSM,PSGOINST,PSGPRN,PSGRFDN,PSGRSDN,PSGSCH,PSGSDN,PSGSI,PSGSTN,PSJWPL,RNDT + Q diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMUT1.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMUT1.m index 3ba20b7e..fb62207b 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMUT1.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMUT1.m @@ -1,150 +1,169 @@ -PSJLMUT1 ;BIR/MLM-DRUG NAME DISPLAY ;05 Feb 98 / 1:39 PM - ;;5.0; INPATIENT MEDICATIONS ;**4,27,29,49,58,107,110,146,175,201**;16 DEC 97;Build 2 - ; - ; Reference to ^PS(55 is supported by DBIA# 2191. - ; Reference to ^PS(50.7 is supported by DBIA# 2180. - ; Reference to ^PS(50.606 is supported by DBIA# 2174. - ; Reference to EN^PSODRDU2 is supported by DBIA# 2189. - ; Reference to ^PSDRUG( is supported by DBIA 2192. - ; -DRGDISP(DFN,ON,NL,GL,NAME,DRUGONLY) ; - ;; DRUGONLY = 1/0 - Only the drug name will be returned. - ;; NL = The drug name display length - ;; GL = The give line display length, total length-6 ("Give: ") - ;; NAME(X) = Drug name and give line in displayable format. - ;; ON = IEN#_U/P (U=Unit Dose; P=Pending) - ; - NEW F,OIND,MARX,MR,NOTGV,SCH,PSGUPDDO,PSGGV,X,PSGX,PSGINS,DRUGNAME - K NAME S PSGINS="" - S:ON["U" F="^PS(55,DFN,5,+ON," - I ON["P" S F="^PS(53.1,+ON,",X=$G(@(F_".3)")),PSGINS=$S(X]"":X,1:"") - I $G(@(F_"0)"))="" S NAME(1)="NOT FOUND" Q - S OIND=$G(@(F_".2)")),PSGUPDDO=$P(OIND,U,2),X=@(F_"0)"),NOTGV=$P(X,U,22),MR=$$ENMRN^PSGMI(+$P(X,U,3)) - I '+OIND,($P(X,U,4)'="U") NEW DRG D GTDRG^PSIVORFA F X="AD","SOL" Q:+OIND F PSGX=0:0 S PSGX=$O(DRG(X,PSGX)) Q:'PSGX S OIND=$P(DRG(X,PSGX),U,6) Q:+OIND - S SCH=$P($G(@(F_"2)")),U) - I +$O(@(F_"1,0)")),'+$O(@(F_"1,1)")),PSGUPDDO="" D DD(F,.DRUGNAME) - S:($G(DRUGNAME)=""!($G(DRUGNAME)["NOT FOUND")) DRUGNAME=$$OIDF(OIND) - ;S PSGGV=$S(NOTGV:"*** NOT TO BE GIVEN *** ",1:"")_PSGINS_PSGUPDDO_" "_MR_" "_SCH - S PSGGV=$S(NOTGV:"*** NOT TO BE GIVEN *** ",1:"")_$S(('$D(PSJPDDDP)&('$L(PSGUPDDO))):PSGINS,1:PSGUPDDO)_" "_MR_" "_SCH - S PSGX=0 K PSJPDDDP - D TXT^PSGMUTL(DRUGNAME,NL) F X=0:0 S X=$O(MARX(X)) Q:'X S NAME(X)=$S(X>1:" ",1:"")_MARX(X),PSGX=X - Q:+DRUGONLY - D TXT^PSGMUTL(PSGGV,GL) F X=0:0 S X=$O(MARX(X)) Q:'X D - . I X=1 S NAME(PSGX+X)="Give: "_MARX(X) Q - . S NAME(PSGX+X)=$S(X>1:" ",1:"")_MARX(X) - Q -OIDF(OIND) ; Return Orderable Item name and Dosage form. - ;; +OIND = orderable item IEN - NEW X,NAME - S X=$G(^PS(50.7,+OIND,0)) - S:$P(X,U)]"" NAME=$P(X,U)_" "_$P($G(^PS(50.606,+$P(X,U,2),0)),U) - Q $S($G(NAME)]"":NAME,1:"NOT FOUND "_+OIND_";PS(50.7") - ; -DD(F,NAME) ; Return Dispense drug name. - ;; F = "^PS(55,DFN,5,+ON," or "^PS(53.1,+ON," - NEW X K NAME - S X=$O(@(F_"1,0)")),X=$G(@(F_"1,"_+X_",0)")) - I $P(X,U)]"" S NAME=$P($G(^PSDRUG(+X,0)),U) - E S NAME="NOT FOUND "_+X_";PSDRUG" - I '$O(@(F_"1,1)")),+$P(X,U,2)>1 S PSGUPDDO=+$P(X,U,2) - S PSJPDDDP=1 - Q -DSPLORDU(PSGP,ON) ; Display UD order for order check as in the Inpat Profile. - NEW DRUGNAME,F,NODE0,NODE2,PSJID,PSJX,SCH,SD,STAT,X,Y - S F=$S(ON["U":"^PS(55,PSGP,5,"_+ON_",",1:"^PS(53.1,"_+ON_",") - S NODE0=$G(@(F_"0)")),NODE2=$G(@(F_"2)")) - D DRGDISP^PSJLMUT1(PSGP,ON,39,54,.DRUGNAME,0) - I ON["P",$P(NODE0,U,4)="F" D DSPLORDV(PSGP,ON) Q - S SCH=$P(NODE0,U,7) - S STAT=$P(NODE0,U,9) I STAT="A",$P(NODE0,U,27)="R" S STAT="R" - I STAT'="P" S PSJID=$E($$ENDTC^PSGMI($P(NODE2,U,2)),1,5),SD=$E($$ENDTC^PSGMI($P(NODE2,U,4)),1,5) - I STAT="P" S (PSJID,SD)="*****",SCH="?" - F PSJX=0:0 S PSJX=$O(DRUGNAME(PSJX)) Q:'PSJX D - . S:PSJX=1 X=SCH_" "_PSJID_" "_SD_" "_$E(STAT,1) - . S:PSJX=1 DRUGNAME(1)=$$SETSTR^VALM1(X,$E(DRUGNAME(1),1,40),42,20) - . S PSJOC(ON,PSJLINE)=" "_DRUGNAME(PSJX) - . S PSJLINE=PSJLINE+1 - Q -DSPLORDV(DFN,ON) ; Display IV order for order check as in the Inpat Profile. - N DRG,DRGI,DRGT,DRGX,FIL,ND,ON55,P,PSJIVFLG,PSJORIFN,TYP,X,Y - S TYP="?" I ON["V" D - .S Y=$G(^PS(55,DFN,"IV",+ON,0)) F X=2,3,4,5,8,9,17,23 S P(X)=$P(Y,U,X) - .S TYP=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3)) I TYP'="O" S TYP="C" - .S ON55=ON,P("OT")=$S(P(4)="A":"F",P(4)="H":"H",1:"I") D GTDRG^PSIVORFB,GTOT^PSIVUTL(P(4)) - S PSJCT=0,PSJL="" - I ON'["V" S (P(2),P(3))="",P(17)=$P($G(^PS(53.1,+ON,0)),U,9),Y=$G(^(8)),P(4)=$P(Y,U),P(8)=$P(Y,U,5),P(9)=$P($G(^(2)),U) D GTDRG^PSIVORFA,GTOT^PSIVUTL(P(4)) - S PSJIVFLG=1 D PIVAD,SOL - Q -SOL ; - S PSJL=$S($G(PSJIVFLG):PSJL,1:"")_" in" - S DRG=0 F S DRG=+$O(DRG("SOL",DRG)) Q:'DRG D NAME^PSIVUTL(DRG("SOL",DRG),39,.NAME,0) S DRGX=0 F S DRGX=$O(NAME(DRGX)) Q:'DRGX S PSJL=$$SETSTR^VALM1(NAME(DRGX),PSJL,12,60) D:$G(PSJIVFLG) PIV1 D SETTMP S PSJL=" " - Q -PIVAD ; Print IV Additives. - F DRG=0:0 S DRG=$O(DRG("AD",DRG)) Q:'DRG D NAME^PSIVUTL(DRG("AD",DRG),39,.NAME,1) F DRGX=0:0 S DRGX=$O(NAME(DRGX)) Q:'DRGX S PSJL=$$SETSTR^VALM1(NAME(DRGX),PSJL,9,60) D:$G(PSJIVFLG) PIV1 D SETTMP - Q - ; -PIV1 ; Print Sched type, start/stop dates, and status. - K PSJIVFLG - F X=2,3 S P(X)=$E($$ENDTC^PSGMI(P(X)),1,$S($D(PSJEXTP):8,1:5)) - I '$D(PSJEXTP) S PSJL=$$SETSTR^VALM1(TYP,PSJL,50,1),PSJL=$$SETSTR^VALM1(P(2),PSJL,53,7),PSJL=$$SETSTR^VALM1(P(3),PSJL,60,7),PSJL=$$SETSTR^VALM1(P(17),PSJL,67,1) - E S PSJL=$$SETSTR^VALM1(TYP,PSJL,50,1),PSJL=$$SETSTR^VALM1(P(2),53,7),PSJL=$$SETSTR^VALM1(P(3),PSJL,63,7),PSJL=$$SETSTR^VALM1(P(17),PSJL,73,1) - Q -SETTMP ; - S PSJOC(ON,PSJLINE)=PSJL,PSJLINE=PSJLINE+1 - Q -ORDCHK(DFN,TYPE,PIECE) ; - ;TYPE ="DD" - Duplicate drug - ; ="DC" - Duplicate class - ; -"DI" - Drug Interaction - ;PIECE = The piece order number is return from ^TMP($J,"DD"... - ;PSJOC(ON,x) = Array of inpatient orders to be displayed - ; - NEW ON,PSJL,PSIVX,PSJOC,PSJORIEN,PSJPACK,PSJLINE - S PSJOC=0,PSJLINE=1 - F PSIVX=0:0 S PSIVX=$O(^TMP($J,TYPE,PSIVX)) Q:'PSIVX D - . S PSJPACK=$P(^TMP($J,TYPE,PSIVX,0),U,PIECE) - . I $G(PSGORD) S PSJORD=PSGORD ; Set PSJORD if PSGORD exists and is not Null - . I $G(PSJORD)]"" I $S($D(PSJORD):$G(PSJORD),1:$G(PSGORD))'["V",$P(PSJPACK,";")=$S($D(PSJORD):$G(PSJORD),1:$G(PSGORD)) Q ; don't flag order that is being renewed as duplicate, only checks Unit Dose orders - . I $G(PSJCOM),($G(PSJORD)["P") Q:$D(^PS(53.1,"ACX",PSJCOM,+PSJPACK)) - . ; Don't flag if pending renewal from CPRS - . I $G(PSJORD)]"",(PSJORD["P"),($P($G(^PS(53.1,+PSJORD,0)),"^",24)="R"),($P(PSJPACK,";")["U"),($P($G(^PS(55,DFN,5,+$P(PSJPACK,";"),0)),"^",27)="R"),($P($G(^PS(55,DFN,5,+$P(PSJPACK,";"),0)),"^",26)=PSJORD) Q - . I $G(PSIVRNFG),$G(ON55)["V",$P(PSJPACK,";")=$G(ON55) Q ;PSIVRNFG set and kill in R+2^PSIVOPT2. Needed to do dupl. check on new order but not renew. - . S PSJORIEN=$P(^TMP($J,TYPE,PSIVX,0),U,PIECE-1) - . I TYPE="DI",($P(^TMP($J,TYPE,PSIVX,0),U,4)="CRITICAL") S PSJIREQ=1 - . ; Adding Drug Interactions check for use in Intervention defaults in PSJRXI. - . I TYPE="DI" S PSJRXREQ=$S($P(^TMP($J,TYPE,PSIVX,0),U,4)="CRITICAL":1,1:2) - . ;I $P(PSJPACK,";",2)["O" D Q - . N X S X=$P(PSJPACK,";",2) I X["O" D Q - .. D:PSJFST=1 PAUSE - .. W !!,"The patient has this "_$S($P(PSJPACK,";")["N":"Non-VA Meds",$P(PSJPACK,";",2)["O":"Outpatient",1:"")_" order:",! - .. I $D(^TMP($J,TYPE,PSIVX,1)) D SHOR^PSJLMUT2(TYPE,PSIVX),PAUSE S PSJFST=$S(PSJFST=0:PSJFST+2,1:PSJFST+1) Q - .. D EN^PSODRDU2(DFN,PSJPACK),PAUSE S PSJPDRG=1,PSJFST=$S(PSJFST=0:PSJFST+2,1:PSJFST+1) - . S ON=$P(PSJPACK,";") Q:$D(PSJOC(ON)) - . I ON=$G(PSIVOCON),+PSJORIEN Q - . I ON=$G(PSIVOCON),'+PSJORIEN D SETPSJOC Q - . ;S PSJOC=PSJOC+1,PSJPDRG=1 D:PSJOC=1 WRITE(TYPE) - . I ON["V" D - .. I '$O(^PS(55,DFN,"IV",+ON,0)) D SETPSJOC Q - .. D DSPLORDV(DFN,ON) S PSJOC=PSJOC+1 - . I ON'["V" D DSPLORDU(DFN,ON) S PSJOC=PSJOC+1 - . S PSJOC(ON,PSJLINE)="",PSJLINE=PSJLINE+1 - D:PSJOC WRITE(TYPE) - S ON="" F S ON=$O(PSJOC(ON)) Q:ON="" W ! S PSJLINE=PSJLINE+1,PSJFST=PSJFST+1 D - . F PSIVX=0:0 S PSIVX=$O(PSJOC(ON,PSIVX)) Q:'PSIVX W !,PSJOC(ON,PSIVX) S PSJLINE=PSJLINE+1 D:'(PSIVX#6) PAUSE - W ! - Q -SETPSJOC ;Set PSJOC array to be displayed later - NEW PIECE S PIECE=$S(TYPE="DC":4,1:2) - S X=$$SETSTR^VALM1($P(^TMP($J,TYPE,PSIVX,0),U,PIECE),"",9,40) - S X=$$SETSTR^VALM1("* EXISTS IN CURRENT ORDER *",X,50,27) - S PSJOC(ON,PSJLINE)=X,PSJLINE=PSJLINE+1,PSJOC=PSJOC+1 - Q -WRITE(TYPE) ;Display order check description - S PSJPDRG=1 - I TYPE="DD" W !!,"This patient is already receiving the following order",$S(PSJOC>1:"s",1:"")," for ",$S($G(PSJDD)]"":$P($G(^PSDRUG(PSJDD,0)),U),1:"this drug"),":",! - I TYPE="DC" W !!,"This patient is already receiving ",$S(PSJOC>1:"orders",1:"an order")," for the following drug",$S(PSJOC>1:"s",1:"")," in the same",!,"class as ",$S($G(PSJDD)]"":$P($G(^PSDRUG(PSJDD,0)),U),1:"the drug selected"),":",! - I TYPE="DI" W !!,"This patient is receiving the following medication",$S(PSJOC>1:"s",1:"")," that ha",$S(PSJOC>1:"ve",1:"s")," an interaction",!,"with ",$P($G(^PSDRUG(PSJDD,0)),U),":",! - Q -PAUSE ; - K DIR W ! S DIR(0)="EA",DIR("A")="Press Return to continue..." D ^DIR W ! - Q +PSJLMUT1 ;BIR/MLM-DRUG NAME DISPLAY ;05 Feb 98 / 1:39 PM + ;;5.0; INPATIENT MEDICATIONS ;**4,27,29,49,58,107,110,146,175**;16 DEC 97;Build 18 + ; + ; Reference to ^PS(55 is supported by DBIA# 2191. + ; Reference to ^PS(50.7 is supported by DBIA# 2180. + ; Reference to ^PS(50.606 is supported by DBIA# 2174. + ; Reference to EN^PSODRDU2 is supported by DBIA# 2189. + ; Reference to ^PSDRUG( is supported by DBIA 2192. + ; +DRGDISP(DFN,ON,NL,GL,NAME,DRUGONLY) ; + ;; DRUGONLY = 1/0 - Only the drug name will be returned. + ;; NL = The drug name display length + ;; GL = The give line display length, total length-6 ("Give: ") + ;; NAME(X) = Drug name and give line in displayable format. + ;; ON = IEN#_U/P (U=Unit Dose; P=Pending) + ; + NEW F,OIND,MARX,MR,NOTGV,SCH,PSGUPDDO,PSGGV,X,PSGX,PSGINS,DRUGNAME + K NAME S PSGINS="" + S:ON["U" F="^PS(55,DFN,5,+ON," + I ON["P" S F="^PS(53.1,+ON,",X=$G(@(F_".3)")),PSGINS=$S(X]"":X,1:"") + I $G(@(F_"0)"))="" S NAME(1)="NOT FOUND" Q + S OIND=$G(@(F_".2)")),PSGUPDDO=$P(OIND,U,2),X=@(F_"0)"),NOTGV=$P(X,U,22),MR=$$ENMRN^PSGMI(+$P(X,U,3)) + I '+OIND,($P(X,U,4)'="U") NEW DRG D GTDRG^PSIVORFA F X="AD","SOL" Q:+OIND F PSGX=0:0 S PSGX=$O(DRG(X,PSGX)) Q:'PSGX S OIND=$P(DRG(X,PSGX),U,6) Q:+OIND + S SCH=$P($G(@(F_"2)")),U) + I +$O(@(F_"1,0)")),'+$O(@(F_"1,1)")),PSGUPDDO="" D DD(F,.DRUGNAME) + S:($G(DRUGNAME)=""!($G(DRUGNAME)["NOT FOUND")) DRUGNAME=$$OIDF(OIND) + S PSGGV=$S(NOTGV:"*** NOT TO BE GIVEN *** ",1:"")_$S(('$D(PSJPDDDP)&('$L(PSGUPDDO))):PSGINS,1:PSGUPDDO)_" "_MR_" "_SCH + S PSGX=0 K PSJPDDDP + D TXT^PSGMUTL(DRUGNAME,NL) F X=0:0 S X=$O(MARX(X)) Q:'X S NAME(X)=$S(X>1:" ",1:"")_MARX(X),PSGX=X + Q:+DRUGONLY + D TXT^PSGMUTL(PSGGV,GL) F X=0:0 S X=$O(MARX(X)) Q:'X D + . I X=1 S NAME(PSGX+X)="Give: "_MARX(X) Q + . S NAME(PSGX+X)=$S(X>1:" ",1:"")_MARX(X) + Q + ; +OIDF(OIND) ; Return Orderable Item name and Dosage form. + ;; +OIND = orderable item IEN + NEW X,NAME + S X=$G(^PS(50.7,+OIND,0)) + S:$P(X,U)]"" NAME=$P(X,U)_" "_$P($G(^PS(50.606,+$P(X,U,2),0)),U) + Q $S($G(NAME)]"":NAME,1:"NOT FOUND "_+OIND_";PS(50.7") + ; +DD(F,NAME) ; Return Dispense drug name. + ;; F = "^PS(55,DFN,5,+ON," or "^PS(53.1,+ON," + NEW X K NAME + S X=$O(@(F_"1,0)")),X=$G(@(F_"1,"_+X_",0)")) + I $P(X,U)]"" S NAME=$P($G(^PSDRUG(+X,0)),U) + E S NAME="NOT FOUND "_+X_";PSDRUG" + I '$O(@(F_"1,1)")),+$P(X,U,2)>1 S PSGUPDDO=+$P(X,U,2) + S PSJPDDDP=1 + Q + ; +DSPLORDU(PSGP,ON) ; Display UD order for order check as in the Inpat Profile. + NEW DRUGNAME,F,NODE0,NODE2,PSJID,PSJX,SCH,SD,STAT,X,Y + S F=$S(ON["U":"^PS(55,PSGP,5,"_+ON_",",1:"^PS(53.1,"_+ON_",") + S NODE0=$G(@(F_"0)")),NODE2=$G(@(F_"2)")) + D DRGDISP^PSJLMUT1(PSGP,ON,39,54,.DRUGNAME,0) + I ON["P",$P(NODE0,U,4)="F" D DSPLORDV(PSGP,ON) Q + S SCH=$P(NODE0,U,7) + S STAT=$P(NODE0,U,9) I STAT="A",$P(NODE0,U,27)="R" S STAT="R" + I STAT'="P" S PSJID=$E($$ENDTC^PSGMI($P(NODE2,U,2)),1,5),SD=$E($$ENDTC^PSGMI($P(NODE2,U,4)),1,5) + I STAT="P" S (PSJID,SD)="*****",SCH="?" + F PSJX=0:0 S PSJX=$O(DRUGNAME(PSJX)) Q:'PSJX D + . S:PSJX=1 X=SCH_" "_PSJID_" "_SD_" "_$E(STAT,1) + . S:PSJX=1 DRUGNAME(1)=$$SETSTR^VALM1(X,$E(DRUGNAME(1),1,40),42,20) + . S PSJOC(ON,PSJLINE)=" "_DRUGNAME(PSJX) + . S PSJLINE=PSJLINE+1 + Q + ; +DSPLORDV(DFN,ON) ; Display IV order for order check as in the Inpat Profile. + N DRG,DRGI,DRGT,DRGX,FIL,ND,ON55,P,PSJCT,PSJIVFLG,PSJORIFN,TYP,X,Y + S TYP="?" I ON["V" D + .S Y=$G(^PS(55,DFN,"IV",+ON,0)) F X=2,3,4,5,8,9,17,23 S P(X)=$P(Y,U,X) + .S TYP=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3)) I TYP'="O" S TYP="C" + .S ON55=ON,P("OT")=$S(P(4)="A":"F",P(4)="H":"H",1:"I") D GTDRG^PSIVORFB,GTOT^PSIVUTL(P(4)) + S PSJCT=0,PSJL="" + I ON'["V" S (P(2),P(3))="",P(17)=$P($G(^PS(53.1,+ON,0)),U,9),Y=$G(^(8)),P(4)=$P(Y,U),P(8)=$P(Y,U,5),P(9)=$P($G(^(2)),U) D GTDRG^PSIVORFA,GTOT^PSIVUTL(P(4)) + S PSJIVFLG=1 D PIVAD,SOL + Q + ; +SOL ; + S PSJL=$S($G(PSJIVFLG):PSJL,1:"")_" in" + S DRG=0 F S DRG=+$O(DRG("SOL",DRG)) Q:'DRG D NAME^PSIVUTL(DRG("SOL",DRG),39,.NAME,0) S DRGX=0 F S DRGX=$O(NAME(DRGX)) Q:'DRGX S PSJL=$$SETSTR^VALM1(NAME(DRGX),PSJL,12,60) D:$G(PSJIVFLG) PIV1 D SETTMP S PSJL=" " + Q + ; +PIVAD ; Print IV Additives. + F DRG=0:0 S DRG=$O(DRG("AD",DRG)) Q:'DRG D NAME^PSIVUTL(DRG("AD",DRG),39,.NAME,1) F DRGX=0:0 S DRGX=$O(NAME(DRGX)) Q:'DRGX S PSJL=$$SETSTR^VALM1(NAME(DRGX),PSJL,9,60) D:$G(PSJIVFLG) PIV1 D SETTMP + Q + ; +PIV1 ; Print Sched type, start/stop dates, and status. + K PSJIVFLG + F X=2,3 S P(X)=$E($$ENDTC^PSGMI(P(X)),1,$S($D(PSJEXTP):8,1:5)) + I '$D(PSJEXTP) S PSJL=$$SETSTR^VALM1(TYP,PSJL,50,1),PSJL=$$SETSTR^VALM1(P(2),PSJL,53,7),PSJL=$$SETSTR^VALM1(P(3),PSJL,60,7),PSJL=$$SETSTR^VALM1(P(17),PSJL,67,1) + E S PSJL=$$SETSTR^VALM1(TYP,PSJL,50,1),PSJL=$$SETSTR^VALM1(P(2),53,7),PSJL=$$SETSTR^VALM1(P(3),PSJL,63,7),PSJL=$$SETSTR^VALM1(P(17),PSJL,73,1) + Q + ; +SETTMP ; + S PSJOC(ON,PSJLINE)=PSJL,PSJLINE=PSJLINE+1 + Q + ; +ORDCHK(DFN,TYPE,PIECE) ; + ;TYPE ="DD" - Duplicate drug + ; ="DC" - Duplicate class + ; -"DI" - Drug Interaction + ;PIECE = The piece order number is return from ^TMP($J,"DD"... + ;PSJOC(ON,x) = Array of inpatient orders to be displayed + ; + NEW ON,PSJL,PSIVX,PSJOC,PSJORIEN,PSJPACK,PSJLINE + S PSJOC=0,PSJLINE=1 + F PSIVX=0:0 S PSIVX=$O(^TMP($J,TYPE,PSIVX)) Q:'PSIVX D + . S PSJPACK=$P(^TMP($J,TYPE,PSIVX,0),U,PIECE) + . I $G(PSGORD) S PSJORD=PSGORD ; Set PSJORD if PSGORD exists and is not Null + . I $G(PSJORD)]"" I $S($D(PSJORD):$G(PSJORD),1:$G(PSGORD))'["V",$P(PSJPACK,";")=$S($D(PSJORD):$G(PSJORD),1:$G(PSGORD)) Q ; don't flag order that is being renewed as duplicate, only checks Unit Dose orders + . I $G(PSJCOM),($G(PSJORD)["P") Q:$D(^PS(53.1,"ACX",PSJCOM,+PSJPACK)) + . ; Don't flag if pending renewal from CPRS + . I $G(PSJORD)]"",(PSJORD["P"),($P($G(^PS(53.1,+PSJORD,0)),"^",24)="R"),($P(PSJPACK,";")["U"),($P($G(^PS(55,DFN,5,+$P(PSJPACK,";"),0)),"^",27)="R"),($P($G(^PS(55,DFN,5,+$P(PSJPACK,";"),0)),"^",26)=PSJORD) Q + . I $G(PSIVRNFG),$G(ON55)["V",$P(PSJPACK,";")=$G(ON55) Q ;PSIVRNFG set and kill in R+2^PSIVOPT2. Needed to do dupl. check on new order but not renew. + . S PSJORIEN=$P(^TMP($J,TYPE,PSIVX,0),U,PIECE-1) + . I TYPE="DI",($P(^TMP($J,TYPE,PSIVX,0),U,4)="CRITICAL") S PSJIREQ=1 + . ; Adding Drug Interactions check for use in Intervention defaults in PSJRXI. + . I TYPE="DI" S PSJRXREQ=$S($P(^TMP($J,TYPE,PSIVX,0),U,4)="CRITICAL":1,1:2) + . N X S X=$P(PSJPACK,";",2) I X["O" D Q + .. D:PSJFST=1 PAUSE + .. W !!,"The patient has this "_$S($P(PSJPACK,";")["N":"Non-VA Meds",$P(PSJPACK,";",2)["O":"Outpatient",1:"")_" order:",! + .. I $D(^TMP($J,TYPE,PSIVX,1)) D SHOR^PSJLMUT2(TYPE,PSIVX),PAUSE S PSJFST=$S(PSJFST=0:PSJFST+2,1:PSJFST+1) Q + .. D EN^PSODRDU2(DFN,PSJPACK),PAUSE S PSJPDRG=1,PSJFST=$S(PSJFST=0:PSJFST+2,1:PSJFST+1) + . S ON=$P(PSJPACK,";") Q:$D(PSJOC(ON)) + . I ON=$G(PSIVOCON),+PSJORIEN Q + . I ON=$G(PSIVOCON),'+PSJORIEN D SETPSJOC Q + . I ON["V" D + .. I '$O(^PS(55,DFN,"IV",+ON,0)) D SETPSJOC Q + .. D DSPLORDV(DFN,ON) S PSJOC=PSJOC+1 + . I ON'["V" D DSPLORDU(DFN,ON) S PSJOC=PSJOC+1 + . S PSJOC(ON,PSJLINE)="",PSJLINE=PSJLINE+1 + ; DEM - If TYPE="DI", and there are "DI" orders, + ; then display "DI" orders. + I TYPE="DI",PSJOC D WRITE(TYPE) D ;DEM + . S ON="" F S ON=$O(PSJOC(ON)) Q:ON="" S PSJLINE=PSJLINE+1,PSJFST=PSJFST+1 D ;DEM + .. F PSIVX=0:0 S PSIVX=$O(PSJOC(ON,PSIVX)) Q:'PSIVX W !,PSJOC(ON,PSIVX) S PSJLINE=PSJLINE+1 ;DEM + Q:(TYPE="DI") ;DEM - Don't continue if TYPE="DI". Code that follows is for TYPEs "DD" and "DC" only. + Q:'PSJOC ;DEM - No need to continue if no "DD", or "DC" orders. + ; DEM - If we are here, then there are "DD", or "DC" orders in + ; PSJOC array. Loop on PSJOC array and set orders into + ; ^TMP($J,"DUPDRG",TYPE) global. The ^TMP($J,"DUPDRG",TYPE) + ; global will be used for display of "DD" and "DC" orders + ; for possible discontinuation of the "DD", or "DC" orders. + ; See subroutine DUPDRG and calling routine ENDDC^PSGSICHK + ; for details. + S ON="" F S ON=$O(PSJOC(ON)) Q:ON="" D ;DEM + . F PSIVX=0:0 S PSIVX=$O(PSJOC(ON,PSIVX)) Q:'PSIVX S ^TMP($J,"DUPDRG",TYPE,ON,PSIVX)=PSJOC(ON,PSIVX) ;DEM + Q + ; +SETPSJOC ;Set PSJOC array to be displayed later + NEW PIECE S PIECE=$S(TYPE="DC":4,1:2) + S X=$$SETSTR^VALM1($P(^TMP($J,TYPE,PSIVX,0),U,PIECE),"",9,40) + S X=$$SETSTR^VALM1("* EXISTS IN CURRENT ORDER *",X,50,27) + S PSJOC(ON,PSJLINE)=X,PSJLINE=PSJLINE+1,PSJOC=PSJOC+1 + Q + ; +WRITE(TYPE) ;Display order check description + S PSJPDRG=1 + I TYPE="DD" W !!,"This patient is already receiving the following order",$S(PSJOC>1:"s",1:"")," for ",$S($G(PSJDD)]"":$P($G(^PSDRUG(PSJDD,0)),U),1:"this drug"),":",! + I TYPE="DC" W !!,"This patient is already receiving ",$S(PSJOC>1:"orders",1:"an order")," for the following drug",$S(PSJOC>1:"s",1:"")," in the same",!,"class as ",$S($G(PSJDD)]"":$P($G(^PSDRUG(PSJDD,0)),U),1:"the drug selected"),":",! + I TYPE="DI" W !!,"This patient is receiving the following medication",$S(PSJOC>1:"s",1:"")," that ha",$S(PSJOC>1:"ve",1:"s")," an interaction",!,"with ",$P($G(^PSDRUG(PSJDD,0)),U),":",! + Q + ; +PAUSE ; + K DIR W ! S DIR(0)="EA",DIR("A")="Press Return to continue..." D ^DIR W ! + Q diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMUT2.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMUT2.m index be0ae042..f9268e9b 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMUT2.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMUT2.m @@ -1,41 +1,142 @@ -PSJLMUT2 ;BIR/JLC-DISPLAY UTILITIES ;22 Jun 05 - ;;5.0; INPATIENT MEDICATIONS ;**146,175,201**;16 DEC 97;Build 2 - ; -SHOR(PSJT,PSJI) ;Display outpatient remote order checks. - ;; PSJT = Type of order check in ^TMP - ;; PSJI = Index to ^TMP to find order check detail - ; - N PSJD0,PSJD1,PSJRX,PSJRS,FSIG,PSJULN,PSJLF,PSJDN - S PSJD0=^TMP($J,PSJT,PSJI,0),PSJD1=^(1) - I PSJT="DD" S PSJRX=$P($P(PSJD0,"^",4),";"),PSJRS=$P(PSJD0,"^",5),PSJDN=$P(PSJD0,"^",2) - I PSJT="DC" S PSJRX=$P($P(PSJD0,"^",6),";"),PSJRS=$P(PSJD0,"^",7),PSJDN=$P(PSJD0,"^",4) - I PSJT="DI" S PSJRX=$P($P(PSJD0,"^",8),";"),PSJRS=$P(PSJD0,"^",9),PSJDN=$P(PSJD0,"^",2) - S PSJLF=$P(PSJD1,"^",3),$P(PSJULN,"-",79)="" - W !,PSJULN,! - W PSJRS I $L(PSJRS)>13 W ! - W ?14,"Rx #: ",$E(PSJRX,1,$L(PSJRX)-1) I $A($L(PSJRX))<54 W $E(PSJRX,$L(PSJRX)) - W ?39,PSJDN,! I PSJT="DI" W ?39,$P(PSJD0,"^",4)," INTERACTION",! - W $J("Status: ",20),$P(PSJD1,"^",2),?40,$J("Issued: ",20),$P(PSJD1,"^",9) - D FSIG(.FSIG) - W !,$J("SIG: ",20) F I=1:1 Q:'$D(FSIG(I)) W ?20,FSIG(I),! - W $J("QTY: ",20)_$P(PSJD1,"^",5) - W !,$J("Provider: ",20),$P(PSJD1,"^",8),?40,$J("Refills remaining: ",20),$P(PSJD1,"^",6) - W !?40,$J("Last filled on: ",20),PSJLF - W !?40,$J("Days Supply: ",20)_$P(PSJD1,"^",4) - W !,PSJULN - Q -FSIG(FSIG) ;Format sig from remote site - ;returned in the FSIG array - N FFF,NNN,CNT,FVAR,FVAR1,FLIM,HSIG,II,I - F I=0:1 Q:'$D(^TMP($J,PSJT,PSJI,1,I)) S HSIG(I+1)=^(I) -FSTART S (FVAR,FVAR1)="",II=1 - F FFF=0:0 S FFF=$O(HSIG(FFF)) Q:'FFF S CNT=0 F NNN=1:1:$L(HSIG(FFF)) I $E(HSIG(FFF),NNN)=" "!($L(HSIG(FFF))=NNN) S CNT=CNT+1 D I $L(FVAR)>52 S FSIG(II)=FLIM_" ",II=II+1,FVAR=FVAR1 - .S FVAR1=$P(HSIG(FFF)," ",(CNT)) - .S FLIM=FVAR - .S FVAR=$S(FVAR="":FVAR1,1:FVAR_" "_FVAR1) - I $G(FVAR)'="" S FSIG(II)=FVAR - I $G(FSIG(1))=""!($G(FSIG(1))=" ") S FSIG(1)=$G(FSIG(2)) K FSIG(2) -FQUIT Q -PAUSE ; - K DIR W ! S DIR(0)="EA",DIR("A")="Press Return to continue..." D ^DIR W ! - Q +PSJLMUT2 ;BIR/JLC-DISPLAY UTILITIES ;22 Jun 05 + ;;5.0; INPATIENT MEDICATIONS ;**146,175**;16 DEC 97;Build 18 + ; + ; Reference to ^PS(55 is supported by DBIA# 2191. + ; Reference to ^PSDRUG is supported by DBIA# 2192. + ; Reference to ^PSSLOCK is supported by DBIA# 2789. + ; Reference to ^VA(200 is supported by DBIA# 10060. + ; +SHOR(PSJT,PSJI) ;Display outpatient remote order checks. + ;; PSJT = Type of order check in ^TMP + ;; PSJI = Index to ^TMP to find order check detail + ; + N PSJD0,PSJD1,PSJRX,PSJRS,FSIG,PSJULN,PSJLF,PSJDN + S PSJD0=^TMP($J,PSJT,PSJI,0),PSJD1=^(1) + I PSJT="DD" S PSJRX=$P($P(PSJD0,"^",4),";"),PSJRS=$P(PSJD0,"^",5),PSJDN=$P(PSJD0,"^",2) + I PSJT="DC" S PSJRX=$P($P(PSJD0,"^",6),";"),PSJRS=$P(PSJD0,"^",7),PSJDN=$P(PSJD0,"^",4) + I PSJT="DI" S PSJRX=$P($P(PSJD0,"^",8),";"),PSJRS=$P(PSJD0,"^",9),PSJDN=$P(PSJD0,"^",2) + S PSJLF=$P(PSJD1,"^",3),$P(PSJULN,"-",79)="" + W !,PSJULN,! + W PSJRS I $L(PSJRS)>13 W ! + W ?14,"Rx #: ",$E(PSJRX,1,$L(PSJRX)-1) I $A($L(PSJRX))<54 W $E(PSJRX,$L(PSJRX)) + W ?39,PSJDN,! I PSJT="DI" W ?39,$P(PSJD0,"^",4)," INTERACTION",! + W $J("Status: ",20),$P(PSJD1,"^",2),?40,$J("Issued: ",20),$P(PSJD1,"^",9) + D FSIG(.FSIG) + W !,$J("SIG: ",20) F I=1:1 Q:'$D(FSIG(I)) W ?20,FSIG(I),! + W $J("QTY: ",20)_$P(PSJD1,"^",5) + W !,$J("Provider: ",20),$P(PSJD1,"^",8),?40,$J("Refills remaining: ",20),$P(PSJD1,"^",6) + W !?40,$J("Last filled on: ",20),PSJLF + W !?40,$J("Days Supply: ",20)_$P(PSJD1,"^",4) + W !,PSJULN + Q + ; +FSIG(FSIG) ;Format sig from remote site + ;returned in the FSIG array + N FFF,NNN,CNT,FVAR,FVAR1,FLIM,HSIG,II,I + F I=0:1 Q:'$D(^TMP($J,PSJT,PSJI,1,I)) S HSIG(I+1)=^(I) +FSTART S (FVAR,FVAR1)="",II=1 + F FFF=0:0 S FFF=$O(HSIG(FFF)) Q:'FFF S CNT=0 F NNN=1:1:$L(HSIG(FFF)) I $E(HSIG(FFF),NNN)=" "!($L(HSIG(FFF))=NNN) S CNT=CNT+1 D I $L(FVAR)>52 S FSIG(II)=FLIM_" ",II=II+1,FVAR=FVAR1 + .S FVAR1=$P(HSIG(FFF)," ",(CNT)) + .S FLIM=FVAR + .S FVAR=$S(FVAR="":FVAR1,1:FVAR_" "_FVAR1) + I $G(FVAR)'="" S FSIG(II)=FVAR + I $G(FSIG(1))=""!($G(FSIG(1))=" ") S FSIG(1)=$G(FSIG(2)) K FSIG(2) +FQUIT Q + ; +DUPDRG(DFN) ;DEM - Duplicate Drug Check Ehancement + ; + ; Note: Display of Drug Interaction, Non-VA Meds, and Outpatient + ; orders is done by ORDCHK^PSJLMUT1. ORDCHK is called by + ; routine ENDDC^PSGSICHK before routine ENDDC^PSGSICHK calls + ; DUPDRG^PSJLMUT2. If ORDCHK finds "DD", or "DC" orders, + ; then ORDCHK will set "DD", or "DC" orders into + ; ^TMP($J,"DUPDRG",TYPE) global. + ; + K PSJDDCON ;Order continuation flag used by routine PSGSICHK. + S:$D(^TMP($J,"DI")) PSJDDCON("DI")=1 ;Order continuation flag used by routine PSGSICHK. + ; Quit if no duplicate drug orders(s), or duplicate drug class + ; order(s) found. + Q:'$D(^TMP($J,"DUPDRG","DD"))&'$D(^TMP($J,"DUPDRG","DC")) + S PSJDDCON("DD")=0 ;Order continuation flag used by routine PSGSICHK. + ; + ; Display orders in ^TMP($J,"DUPDRG",DUPLICATE_TYPE,ON,LINE_#) + ; (DUPLICATE TYPEs: "DD" - "Duplicate Drug" + ; "DC" - "Duplicate Drug Class" + ; + S PSJPDRG=1 ;If we are here, then set PSJPDRG=1. ORDCHK^PSJLMUT1 addresses this variable for Outpatient orders and "DI" orders. + N X,Y,DIR,TYPE,ON,PSJOC,PSJOCPOP,PSJSYSL + W !!,"This patient is already receiving the following INPATIENT order(s) for the same drug or in the same drug class as "_$S($G(PSJDD)]"":$P($G(^PSDRUG(PSJDD,0)),U),1:"the drug selected"),":",!! + D DSPLDD ;Display patients orders for the same drug or same drug class as drug selected. + ; Ask user if they wish to continue in spite of an order check. + S DIR(0)="Y",DIR("A")="Do you wish to continue with the current order",DIR("?",1)="Enter ""N"" if you wish to exit without creating a new order," + S DIR("?")="or ""Y"" to continue with the order entry process.",DIR("B")="YES" D ^DIR I 'Y S PSGORQF=1,COMQUIT=1 K X,Y,DIR W ! Q + K X,Y,DIR + S PSJDDCON("DD")=1,PSJSYSL=0 ;Order continuation flag used by routine PSGSICHK. + W ! + F D Q:('PSJOC)!(PSJOCPOP) ;Order discontinuation loop. + . N TYPE,ON,PSJOCSEQ + . S PSJOCPOP=0 + . ; Ask user if they wish to discontinue any of the listed orders. + . S DIR(0)="Y",DIR("A")="Do you wish to DISCONTINUE any of the listed orders",DIR("?",1)="Enter ""N"" if you wish to exit without discontinuing any of the listed orders," + . S DIR("?")="or ""Y"" to discontinue any of the listed orders.",DIR("B")="NO" D ^DIR I 'Y K X,Y,DIR S PSJOCPOP=1 W ! Q + . K X,Y,DIR + . W ! + . ; Choose for DISCONTINUE 1-PSJOC (PSJOC is the total number of duplicate and duplicate class orders). + . S DIR(0)="N^1:"_PSJOC,DIR("A")="Choose for DISCONTINUE",DIR("?")="Choose an order 1-"_PSJOC D ^DIR I 'Y K X,Y,DIR S PSJOCPOP=1 W ! Q + . S PSJOCSEQ=+Y + . K X,Y,DIR + . ; + . ; *** Discontinue order *** + . S ON=$P(PSJOC(PSJOCSEQ),"^",2) + . I '$$LS^PSSLOCK(DFN,ON) S PSJOCPOP=1 Q + . S PSGSTAT=$$GTSTATUS^PSJOE(DFN,ON) + . D ;Set PSGOEEWF for order being discontinued - DRF + .. I ON["P" S PSGOEEWF="^PS(53.1,"_+ON_"," Q + .. I ON["U" S PSGOEEWF="^PS(55,"_DFN_",5,"_+ON_"," Q + .. S PSGOEEWF="^PS(55,"_DFN_",""IV"","_+ON_"," + . D ;The following variables must be newed or they are stomped on by the discontinue code + .. N %DT,CF,D,D0,DA,DI,DIC,DIE,DISYS,DQ,DR,DRG,DRGT,DRGTMP,DRGX + .. N DTIME,FIL,I,JJ,LOC,OCXDT,OCXI,OCXSEG,ORIFN,ORO,POP,PSGALR + .. N PSGDT,PSGOEAV,PSJNOO,PSGOEDMR,PSGOEPR,PSGPDRG,PSGTOO,PSGTOL + .. N PSGUOW,PSIVOI,PSIVX,PSJCOM,PSJDD,PSJHLMTN,PSJMSG,PSJQO,PSOC + .. N Q,QQ,T,VA,VADM,VAERR,VAIN,XPARSYS,XQXFLG,Y,PSJRQPND + .. D + ... S PSJRQPND=1 + ... I ON["V" D Q ;IV order + .... N PSJORD + .... S PSJORD=ON + .... D DC^PSJLIACT + ... D DC^PSJOE(DFN,ON) ;UD order + .. I $$GTSTATUS^PSJOE(DFN,ON)="D" D ; Clean up PSJOC and ^TMP($J,"DUPDRG") arrays, and reset PSJOC counter IF and after selected order has been discontinued. + ... S TYPE=$P(PSJOC(PSJOCSEQ),"^",1),ON=$P(PSJOC(PSJOCSEQ),"^",2),PSJOC=PSJOC-1 + ... K PSJOC(PSJOCSEQ),^TMP($J,"DUPDRG",TYPE,ON),PSJOCSEQ + . D UNL^PSSLOCK(DFN,ON) + . Q:'PSJOC + . W !!,"Now, this patient is already receiving the following INPATIENT order(s) for the same drug or in the same drug class as "_$S($G(PSJDD)]"":$P($G(^PSDRUG(PSJDD,0)),U),1:"the drug selected"),":",!! + . D DSPLDD + . Q + W ! + K PSJOCPOP,PSGSTAT + Q + ; +DSPLDD ; + ; Display patients orders for the same drug or same drug class as drug selected. + N X,REQPROV,PSJLINE,PSJFLN + K PSJOC + ; Requesting Provider + S PSJOC=0 + F TYPE="DD","DC" S ON="" F S ON=$O(^TMP($J,"DUPDRG",TYPE,ON)) Q:ON="" S PSJFLN=1 D + . I ON["U" S REQPROV=$P(^PS(55,DFN,5,+ON,0),"^",2) + . I ON["V" S REQPROV=$P(^PS(55,DFN,"IV",+ON,0),"^",6) + . I ON["P" S REQPROV=$P(^PS(53.1,+ON,0),"^",2) + . S REQPROV=$S(REQPROV>0:$P($G(^VA(200,REQPROV,0)),"^",1),1:"") S:REQPROV="" REQPROV="Requesting Provider Unknown" + . F PSJLINE=0:0 S PSJLINE=$O(^TMP($J,"DUPDRG",TYPE,ON,PSJLINE)) Q:'PSJLINE D + .. I PSJFLN=1 S PSJOC=PSJOC+1,PSJOC(PSJOC)=TYPE_"^"_ON W PSJOC_".",^TMP($J,"DUPDRG",TYPE,ON,PSJLINE),! S PSJFLN=PSJFLN+1 Q + .. S X=^TMP($J,"DUPDRG",TYPE,ON,PSJLINE) S:PSJFLN=2 X=$$SETSTR^VALM1(REQPROV,X,(48+$L(PSJOC_".")),25) W ?($L(PSJOC_".")),X,! S PSJFLN=PSJFLN+1 Q + .. Q + . Q + Q + ; +PAUSE ; + K DIR W ! S DIR(0)="EA",DIR("A")="Press Return to continue..." D ^DIR W ! + Q diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJMPEND.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJMPEND.m index ac5859a3..6c427261 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJMPEND.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJMPEND.m @@ -1,56 +1,55 @@ -PSJMPEND ;BIR/CML3-MD MARS - GATHER ACK ORDERS INFO (MDWS) ; 6/18/07 12:11pm - ;;5.0; INPATIENT MEDICATIONS ;**191**;16 DEC 97;Build 9 - ; -PEND ;*** Only select orders that were acknowledged by nurses and are - ;*** still having pending status. - NEW X S X=$O(^PS(59.6,"B",+PSJPWD,0)) Q:'+$P($G(^PS(59.6,+X,0)),U,6) - NEW ND,ON,TYPE,QST - F ON=0:0 S ON=$O(^PS(53.1,"AV",PSGP,ON)) Q:'ON D - . S ND=$G(^PS(53.1,ON,0)),TYPE=$P(ND,U,4) - . S ND2=$G(^PS(53.1,ON,2)),PSGLSD=$P(ND2,U,2),PSGLFD=$P(ND2,U,4) - . I $P(ND,U,7)="P"!($P($G(^PS(53.1,ON,2)),U)["PRN") S QST="PZ"_$S($P(ND,U,4)="F":"V",1:"A") - . E S QST="CZ"_$S($P(ND,U,4)="F":"V",1:"A") - . I PSGMTYPE[1 D:TYPE'="F" SETTMP D:TYPE="F" IV - . I PSGMTYPE'[1 D - .. I PSGMTYPE[2,(TYPE="U") D SETTMP Q - .. I PSGMTYPE'[2,(TYPE="I") D SETTMP Q - .. I PSGMTYPE[4,(TYPE="F") D IV - Q - ; -SETTMP ;*** Setup ^tmp for pending U/D and Inpatient med IVs. - ;*** PZ_(V/A) = PRN/One time orders (V=IV). - ;*** CZ_(V/A) = Continuous orders (A=U/D). - I 'PSJMPRN,(QST["PZ") Q - NEW MARX - D DRGDISP^PSJLMUT1(PSGP,+ON_"P",20,0,.MARX,1) S DRG=MARX(1)_U_ON - ;*** Set up ^TMP for sort by patients - S PSJDOS=$P(^PS(53.1,ON,.2),U,2),PSJMR=$E($S($P(ND,U,3)]"":$P(ND,U,3),1:$P(ND,U)),1,5),PSJSCHE=$P($G(^PS(53.1,ON,2)),U) - S PSJHOLD=$S($P(ND,U,9)["H":1,1:0),PSGLOD=$P(ND,U,14),PSJATME=9999,PSJADT=$S(QST["C":"8999999",1:"9999999") - D SI - I PSGSS="P" D Q - . S ^TMP($J,PSJADT,PPN_U_PSGP,PSJATME,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSJPWDN_U_PSJPRB - . S ^TMP($J,QST,PSGP,ON)=PSJDOS_U_PSJMR_U_PSJSCHE_U_PSJHOLD_U_PSGLOD - . S ^TMP($J,QST,PSGP,ON,1)=PSJSI - ;*** Set up ^TMP when listing by ward - S:PSGRBADM="A" ^TMP($J,PSJADT,TM,PSJATME,PSJPRB,PPN,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB - S:PSGRBADM="R" ^TMP($J,PSJADT,TM,PSJPRB,PPN,PSJATME,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB - S:PSGRBADM="P" ^TMP($J,PSJADT,TM,PPN_U_PSGP,PSJATME,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB - S ^TMP($J,QST,PSGP,ON)=PSJDOS_U_PSJMR_U_PSJSCHE_U_PSJHOLD_U_PSGLOD_U_PSGLSD_U_PSGLFD - S ^TMP($J,QST,PSGP,ON,1)=PSJSI - Q -SI ;*** Find the Special instructions. - S X=0,PSJSI="" F S X=$O(^PS(53.1,ON,12,X)) Q:'X S Z=$G(^(X,0)),Y=$L(PSJSI) S:Y+$L(Z)'>179 PSJSI=PSJSI_Z_" " I Y+$L(Z)>179 S PSJSI="SEE PROVIDER COMMENTS" Q - Q - ; -IV ;*** Sort IV pending orders for 24 Hrs, 7/14 Day MAR. - K DRG,P NEW X,ON55,P,PSJLABEL - S DFN=PSGP,PSJLABEL=1 D GT531^PSIVORFA(DFN,ON) - S X=$P(P("MR"),U,2) - S QST=QST_4 - S PSJADT=$S(QST["C":"8999999",1:"9999999") - I DRG S X=$S($G(DRG("AD",1)):DRG("AD",1),1:$G(DRG("SOL",1))),X=$E($P(X,U,2),1,20)_U_ON D - . I PSGSS="P" S ^TMP($J,PSJADT,PPN_U_PSGP,"9999",QST,X)=PSGP_U_ON_U_PSJPPID_U_PSJPWDN_U_PSJPRB Q - . S:PSGRBADM="A" ^TMP($J,PSJADT,TM,"9999",PSJPRB,PPN,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB - . S:PSGRBADM="R" ^TMP($J,PSJADT,TM,PSJPRB,PPN,"9999",QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB - . S:PSGRBADM="P" ^TMP($J,PSJADT,TM,PPN_U_PSGP,"9999",QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB - Q +PSJMPEND ;BIR/CML3-MD MARS - GATHER ACK ORDERS INFO (MDWS) ;20 DEC 96 / 3:15 PM + ;;5.0; INPATIENT MEDICATIONS ;;16 DEC 97 + ; +PEND ;*** Only select orders that were acknowledged by nurses and are + ;*** still having pending status. + NEW X S X=$O(^PS(59.6,"B",+PSJPWD,0)) Q:'+$P($G(^PS(59.6,+X,0)),U,6) + NEW ND,ON,TYPE,QST + F ON=0:0 S ON=$O(^PS(53.1,"AV",PSGP,ON)) Q:'ON D + . S ND=$G(^PS(53.1,ON,0)),TYPE=$P(ND,U,4) + . I $P(ND,U,7)="P"!($P($G(^PS(53.1,ON,2)),U)["PRN") S QST="PZ"_$S($P(ND,U,4)="F":"V",1:"A") + . E S QST="CZ"_$S($P(ND,U,4)="F":"V",1:"A") + . I PSGMTYPE[1 D:TYPE'="F" SETTMP D:TYPE="F" IV + . I PSGMTYPE'[1 D + .. I PSGMTYPE[2,(TYPE="U") D SETTMP Q + .. I PSGMTYPE'[2,(TYPE="I") D SETTMP Q + .. I PSGMTYPE[4,(TYPE="F") D IV + Q + ; +SETTMP ;*** Setup ^tmp for pending U/D and Inpatient med IVs. + ;*** PZ_(V/A) = PRN/One time orders (V=IV). + ;*** CZ_(V/A) = Continuous orders (A=U/D). + I 'PSJMPRN,(QST["PZ") Q + NEW MARX + D DRGDISP^PSJLMUT1(PSGP,+ON_"P",20,0,.MARX,1) S DRG=MARX(1)_U_ON + ;*** Set up ^TMP for sort by patients + S PSJDOS=$P(^PS(53.1,ON,.2),U,2),PSJMR=$E($S($P(ND,U,3)]"":$P(ND,U,3),1:$P(ND,U)),1,5),PSJSCH=$P($G(^PS(53.1,ON,2)),U) + S PSJHOLD=$S($P(ND,U,9)["H":1,1:0),PSGLOD=$P(ND,U,14),PSJATME=9999,PSJADT=$S(QST["C":"8999999",1:"9999999") + D SI + I PSGSS="P" D Q + . S ^TMP($J,PSJADT,PPN_U_PSGP,PSJATME,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSJPWDN_U_PSJPRB + . S ^TMP($J,QST,PSGP,ON)=PSJDOS_U_PSJMR_U_PSJSCHE_U_PSJHOLD_U_PSGLOD + . S ^TMP($J,QST,PSGP,ON,1)=PSJSI + ;*** Set up ^TMP when listing by ward + S:PSGRBADM="A" ^TMP($J,PSJADT,TM,PSJATME,PSJPRB,PPN,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB + S:PSGRBADM="R" ^TMP($J,PSJADT,TM,PSJPRB,PPN,PSJATME,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB + S:PSGRBADM="P" ^TMP($J,PSJADT,TM,PPN_U_PSGP,PSJATME,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB + S ^TMP($J,QST,PSGP,ON)=PSJDOS_U_PSJMR_U_PSJSCHE_U_PSJHOLD_U_PSGLOD_U_PSGLSD_U_PSGLFD + S ^TMP($J,QST,PSGP,ON,1)=PSJSI + Q +SI ;*** Find the Special instructions. + S X=0,PSJSI="" F S X=$O(^PS(53.1,ON,12,X)) Q:'X S Z=$G(^(X,0)),Y=$L(PSJSI) S:Y+$L(Z)'>179 PSJSI=PSJSI_Z_" " I Y+$L(Z)>179 S PSJSI="SEE PROVIDER COMMENTS" Q + Q + ; +IV ;*** Sort IV pending orders for 24 Hrs, 7/14 Day MAR. + K DRG,P NEW X,ON55,P,PSJLABEL + S DFN=PSGP,PSJLABEL=1 D GT531^PSIVORFA(DFN,ON) + S X=$P(P("MR"),U,2) + S QST=QST_4 + S PSJADT=$S(QST["C":"8999999",1:"9999999") + I DRG S X=$S($G(DRG("AD",1)):DRG("AD",1),1:$G(DRG("SOL",1))),X=$E($P(X,U,2),1,20)_U_ON D + . I PSGSS="P" S ^TMP($J,PSJADT,PPN_U_PSGP,"9999",QST,X)=PSGP_U_ON_U_PSJPPID_U_PSJPWDN_U_PSJPRB Q + . S:PSGRBADM="A" ^TMP($J,PSJADT,TM,"9999",PSJPRB,PPN,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB + . S:PSGRBADM="R" ^TMP($J,PSJADT,TM,PSJPRB,PPN,"9999",QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB + . S:PSGRBADM="P" ^TMP($J,PSJADT,TM,PPN_U_PSGP,"9999",QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB + Q diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJOERI.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJOERI.m index aa7aa282..a5f93be0 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJOERI.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJOERI.m @@ -1,45 +1,41 @@ -PSJOERI ;BIR/LDT-CPRS ORDER UPDATE FOR INPATIENT MEDS ; 7/30/08 7:51am - ;;5.0; INPATIENT MEDICATIONS ;**86,108,204**;16 DEC 97;Build 3 - ; - ; Reference to ^PS(55 is supported by DBIA 2191 - ; Reference to ^%DTC is supported by DBIA 10000 - ; Reference to ^DIE is supported by DBIA 10018 - ; -ENR(DFN,ON,PSJWARD) ; - I $G(DFN)=""!($G(ON)="")!(+$G(PSJWARD)'>0) Q - I PSJWARD'=+PSJWARD Q - D NOW^%DTC S PSJNOW=% - I ON["V" D Q - . I '$D(^PS(55,DFN,"IV",+ON)) Q - . I $P(^PS(55,DFN,"IV",+ON,0),"^",17)'="D" Q - . I $P(^PS(55,DFN,"IV",+ON,0),"^",12)="" Q - . N DA,DR,DIE,DIK,PSIVREA,PSIVALCK,PSIVOPT,PSIVAL,PSIVALT,X,Y - . S P(3)=$P($G(^PS(55,DFN,"IV",+ON,0)),"^",3) - . S X=$G(^PS(55,DFN,"IV",+ON,"ADC")) I X K ^PS(55,"ADC",X,DFN,+ON),^PS(55,DFN,"IV",+ON,"ADC") - . S PSIVACT=1,DR="100///A;.03////"_+$P($G(^PS(55,DFN,"IV",+ON,2)),U,7)_";9////^S X=PSJWARD;109///@;116///@;121///@",DIE="^PS(55,"_DFN_",""IV"",",DA=+ON,DA(1)=DFN - .;PSJ*5.0*204 - . I $P($G(^PS(55,DFN,"IV",+ON,4)),"^",18)=1 S DR="100////H;.03////"_+$P($G(^PS(55,DFN,"IV",+ON,2)),U,7)_";9////^S X=PSJWARD;109///@;116///@;121///@" - . N CHKIT S CHKIT=$G(^PS(55,DFN,"IV",+ON,2)) I $P(CHKIT,U,6)["P",($P(CHKIT,U,9)="R") S DR=DR_";114///@;123///@" - . D ^DIE - . D IRA(1),EN1^PSJHL2(DFN,"SC",ON,"AUTO REINSTATED (CPRS)") - I ON["U" D Q - . I '$D(^PS(55,DFN,5,+ON)) Q - . I $P(^PS(55,DFN,5,+ON,0),"^",9)'="D" Q - . I $P(^PS(55,DFN,5,+ON,4),"^",11)="" Q - . N DA,DR,DIE,PSGFD,X,Z - . S PSGFD=$P($G(^PS(55,DFN,5,+ON,2)),"^",3) - . S DR="28////A;34////^S X=PSGFD;68////^S X=PSJWARD",Z=$G(^PS(55,DFN,5,+ON,4)),$P(Z,U,11)="",$P(Z,"^",15,17)="^^" S ^(4)=Z - .;PSJ*5.0*204 - . I $P($G(^PS(55,DFN,5,+ON,4)),"^",18)=1 S DR="28////H;34////^S X=PSGFD;68////^S X=PSJWARD" - . N CHKIT S CHKIT=$G(^PS(55,DFN,5,+ON,0)) I $P(CHKIT,U,26)["P",($P(CHKIT,U,27)="R") S DR=DR_";105///@;107///@" - . S DIE="^PS(55,"_DFN_",5,",DA(1)=DFN,DA=+ON D ^DIE - . S X=$P(^PS(55,DFN,5,+ON,0),"^",20),$P(^(0),"^",20)="" K:X ^PS(55,"AUDDD",X,DFN,+ON) ;Removed cross reference after reinstate order. - . D URA(1),EN1^PSJHL2(DFN,"SC",ON,"AUTO REINSTATED (CPRS)") - Q -IRA(STAT) ; - S ON55=ON,P(17)="A",PSIVREA="AI",PSIVALCK="STOP",(PSIVOPT,PSIVALT)=1,PSJUNDC=1,PSIVAL="AUTO REINSTATED (CPRS)" - D LOG^PSIVORAL - Q -URA(STAT) ; - S PSGAL("C")=18560 D ^PSGAL5 - Q +PSJOERI ;BIR/LDT-CPRS ORDER UPDATE FOR INPATIENT MEDS ;18 JUN 01 + ;;5.0; INPATIENT MEDICATIONS ;**86,108**;16 DEC 97 + ; + ; Reference to ^PS(55 is supported by DBIA 2191 + ; Reference to ^%DTC is supported by DBIA 10000 + ; Reference to ^DIE is supported by DBIA 10018 + ; +ENR(DFN,ON,PSJWARD) ; + I $G(DFN)=""!($G(ON)="")!(+$G(PSJWARD)'>0) Q + I PSJWARD'=+PSJWARD Q + D NOW^%DTC S PSJNOW=% + I ON["V" D Q + . I '$D(^PS(55,DFN,"IV",+ON)) Q + . I $P(^PS(55,DFN,"IV",+ON,0),"^",17)'="D" Q + . I $P(^PS(55,DFN,"IV",+ON,0),"^",12)="" Q + . N DA,DR,DIE,DIK,PSIVREA,PSIVALCK,PSIVOPT,PSIVAL,PSIVALT,X,Y + . S P(3)=$P($G(^PS(55,DFN,"IV",+ON,0)),"^",3) + . S X=$G(^PS(55,DFN,"IV",+ON,"ADC")) I X K ^PS(55,"ADC",X,DFN,+ON),^PS(55,DFN,"IV",+ON,"ADC") + . S PSIVACT=1,DR="100///A;.03////"_+$P($G(^PS(55,DFN,"IV",+ON,2)),U,7)_";9////^S X=PSJWARD;109///@;116///@;121///@",DIE="^PS(55,"_DFN_",""IV"",",DA=+ON,DA(1)=DFN + . N CHKIT S CHKIT=$G(^PS(55,DFN,"IV",+ON,2)) I $P(CHKIT,U,6)["P",($P(CHKIT,U,9)="R") S DR=DR_";114///@;123///@" + . D ^DIE + . D IRA(1),EN1^PSJHL2(DFN,"SC",ON,"AUTO REINSTATED (CPRS)") + I ON["U" D Q + . I '$D(^PS(55,DFN,5,+ON)) Q + . I $P(^PS(55,DFN,5,+ON,0),"^",9)'="D" Q + . I $P(^PS(55,DFN,5,+ON,4),"^",11)="" Q + . N DA,DR,DIE,PSGFD,X,Z + . S PSGFD=$P($G(^PS(55,DFN,5,+ON,2)),"^",3) + . S DR="28////A;34////^S X=PSGFD;68////^S X=PSJWARD",Z=$G(^PS(55,DFN,5,+ON,4)),$P(Z,U,11)="",$P(Z,"^",15,17)="^^" S ^(4)=Z + . N CHKIT S CHKIT=$G(^PS(55,DFN,5,+ON,0)) I $P(CHKIT,U,26)["P",($P(CHKIT,U,27)="R") S DR=DR_";105///@;107///@" + . S DIE="^PS(55,"_DFN_",5,",DA(1)=DFN,DA=+ON D ^DIE + . S X=$P(^PS(55,DFN,5,+ON,0),"^",20),$P(^(0),"^",20)="" K:X ^PS(55,"AUDDD",X,DFN,+ON) ;Removed cross reference after reinstate order. + . D URA(1),EN1^PSJHL2(DFN,"SC",ON,"AUTO REINSTATED (CPRS)") + Q +IRA(STAT) ; + S ON55=ON,P(17)="A",PSIVREA="AI",PSIVALCK="STOP",(PSIVOPT,PSIVALT)=1,PSJUNDC=1,PSIVAL="AUTO REINSTATED (CPRS)" + D LOG^PSIVORAL + Q +URA(STAT) ; + S PSGAL("C")=18560 D ^PSGAL5 + Q diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJOREN.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJOREN.m index 344ce5e1..f5dfee0f 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJOREN.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJOREN.m @@ -1,52 +1,47 @@ -PSJOREN ;BIR/CML3-INTERFACE FOR INPATIENT PHARMACY AND OE/RR ;07 AUG 97 / 3:21 PM - ;;5.0; INPATIENT MEDICATIONS ;**109,127,134**;16 DEC 97;Build 124 - ; - ;Reference to ^ORD(100.98 supported by DBIA 873 - ;Reference to ^PS(51.2 supported by DBIA 2178 - ;Reference to ^PS(55 supported by DBIA 2191 - ; -ENTRY ; - K PSGOEE,PSGOES - I '$D(^DPT(+ORVP,.1)) W !!,"THIS PATIENT HAS NOT BEEN ADMITTED.",!,"(Any non-IV orders entered will be discontinued by the pharmacist...)" - ; -GO ; get orders - S PSGOEORF=1,PSGOEAV=0,PSJORTOU=$O(^ORD(100.98,"B","INPATIENT MEDICATIONS",0)),PSGOEDMR=$O(^PS(51.2,"B","ORAL",0)),PSGOEPR=PSJORPV - F S PSGOEOS="U" D ^PSGOE7 Q:Y<0 D:X?1"S."1.E ^PSGOES I X'?1."S."1.E D ^PSGOE6 K PSGOEE D:$D(Y) ^PSGOETO - ; -DONE ; - ; -OUT ; - Q ; -PS ; - W $C(7),!!,"The selected PROVIDER is NOT qualified to write MEDICATION orders. You must",!,"select a valid provider to be able to continue with Inpatient Medications." - K DIC S DIC="^VA(200,",DIC(0)="AEMQZ",DIC("A")="Select PHARMACY PROVIDER: ",DIC("S")="S PSG=$G(^(""PS"")) I PSG,$S('$P(PSG,""^"",4):1,1:DT<$P(PSG,""^"",4))" F W ! D ^DIC Q:$D(DUOUT)!$D(DTOUT)!(Y>0) W $C(7)," (Required.)" - K DIC S:Y'>0 PSJORPF=11 S:Y>0 PSJORPV=+Y,PSJORPVN=Y(0,0) Q - Q -ENBKOUT(DFN,ON) ; Undo Renew. - Q:'$G(ON) - N PSJOLD,PSJRES,PSJOC,PSJOC2,PSIVACT,PSIVALT,PSIVREA,ON55,PSGAL,DA,PSIVAL,PSJUNDC - S PSJOC=PSOC,PSJOC2=PSJHLMTN,PSIVAL=24000 - S X=$G(^PS(53.1,+ON,0)) Q:'X - S PSJRES=$P(X,U,24),(X,PSJOLD)=$P(X,U,25) - I PSJOLD["V" D - .I $D(^PS(55,DFN,"IV",+PSJOLD,2)) D - ..N PSJOSTOP,PSJNOW,PSJSTAT S PSJNOW=$$DATE^PSJUTL2(),PSJOSTOP=$P($G(^PS(55,DFN,"IV",+PSJOLD,0)),"^",3),PSJSTAT=$P(^(0),"^",17) - ..S $P(^PS(55,DFN,"IV",+PSJOLD,2),U,6)="",$P(^(2),U,9)="",$P(^(0),U,17)=$S(PSJNOW>PSJOSTOP:"E",PSJSTAT="R":"A",1:PSJSTAT) - ..S PSIVACT=1,PSIVALT=$S(PSOC="CR":2,1:1),PSJUNDC=1,PSIVAL=$P($G(^PS(53.3,+PSIVAL,0)),U),PSIVREA="PNRD",ON55=PSJOLD - .D LOG^PSIVORAL - I PSJOLD["U" D - .I $D(^PS(55,DFN,5,+PSJOLD,0)) N PSJSTAT S PSJSTAT=$P(^(0),"^",9) D - ..N PSJOSTOP,PSJNOW S PSJNOW=$$DATE^PSJUTL2(),PSJOSTOP=$P($G(^PS(55,DFN,5,+PSJOLD,2)),"^",4) - ..S $P(^PS(55,DFN,5,+PSJOLD,0),U,26,27)=U,PSGAL("C")=24000,DA=+PSJOLD,DA(1)=DFN S $P(^(0),U,9)=$S(PSJNOW>PSJOSTOP:"E",PSJSTAT="R":"A",1:PSJSTAT) - .D ^PSGAL5 - S PSOC="SC",PSJHLMTN="ORM" D EN1^PSJHL2(DFN,PSOC,PSJOLD) S PSOC=PSJOC,PSJHLMTN=PSJOC2 - Q - ; -ENUDTX(DFN,ON,RES) ; Set up ORTX( Array for UD orders. - K ORTX N DO,MRN,ND0,NDP1,ND2,PD,ST,SCH - S Y=2 I ON["A"!(ON["O") S ND0=$G(^PS(55,DFN,5,+ON,0)),NDP1=$G(^(.1)),ND2=$G(^(2)),Y=2 F X=0:0 S X=$O(^PS(55,DFN,5,+ON,12,X)) Q:'X S Y=Y+1,ORTX(Y)=$G(^(X,0)) - E S ND0=$G(^PS(53.1,+ON,0)),NDP1=$G(^(.1)),ND2=$G(^(2)),Y=2 F X=0:0 S X=$O(^PS(53.1,+ON,12,X)) Q:'X S Y=Y+1,ORTX(Y)=$G(^(X,0)) - S ORTX(1)=$S($G(RES)="NR":"RENEWAL -",$G(RES)="OR":"RENEWED -",1:"")_$P($G(^PS(50.3,+NDP1,0)),U) - S ORTX(2)=" Give: "_$S($P(NDP1,U,2)]"":$P(NDP1,U,2)_" ",1:"")_$P($G(^PS(51.2,+$P(ND0,U,3),0)),U,3)_" "_$P(ND2,U)_$S($P(ND2,U)["PRN":"",$P(ND0,U,7)="P":" PRN",1:"") - I $G(DFN),$G(ON) S:ON["U" ^PS(55,"AUE",DFN,+ON)="" - Q +PSJOREN ;BIR/CML3-INTERFACE FOR INPATIENT PHARMACY AND OE/RR ;07 AUG 97 / 3:21 PM + ;;5.0; INPATIENT MEDICATIONS ;**109,127**;16 DEC 97 + ; + ;Reference to ^ORD(100.98 supported by DBIA 873 + ;Reference to ^PS(51.2 supported by DBIA 2178 + ;Reference to ^PS(55 supported by DBIA 2191 + ; +ENTRY ; + K PSGOEE,PSGOES + ;S PSJORPF=0 S:ORNP PSJORPV=ORNP,PSJORPVN=$P(^VA(200,+ORNP,0),"^"),X=$G(^("PS")) I $S('ORNP:1,'X:1,'$P(X,"^",4):0,1:$P(X,"^",4)'>DT) D PS I PSJORPF G OUT + I '$D(^DPT(+ORVP,.1)) W !!,"THIS PATIENT HAS NOT BEEN ADMITTED.",!,"(Any non-IV orders entered will be discontinued by the pharmacist...)" + ; +GO ; get orders + ; S PSJORPCL=XQORNOD,PSJORNS=+XQORNOD,PSJORL=ORL,PSJORTS=ORTS,PSJORVP=ORVP + S PSGOEORF=1,PSGOEAV=0,PSJORTOU=$O(^ORD(100.98,"B","INPATIENT MEDICATIONS",0)),PSGOEDMR=$O(^PS(51.2,"B","ORAL",0)),PSGOEPR=PSJORPV + F S PSGOEOS="U" D ^PSGOE7 Q:Y<0 D:X?1"S."1.E ^PSGOES I X'?1."S."1.E D ^PSGOE6 K PSGOEE D:$D(Y) ^PSGOETO + ; +DONE ; + ; I $P(PSJSYSL,"^",2)]"" S PSGOP=PSGP D ENQL^PSGLW + ; +OUT ; + ; S PSJNKF=1 D ENIVKV^PSGSETU K PSJORPCL,PSJORTOI,PSJORTOU,PSJORPV,PSJORPVN,PSJORNS,PSJORVP,PSJORL,PSJORTS,PSGOEORF,PSGOEAV,PSJORPF,PSJORQF,PSJPV,PSGOEOS Q + Q ; +PS ; + W $C(7),!!,"The selected PROVIDER is NOT qualified to write MEDICATION orders. You must",!,"select a valid provider to be able to continue with Inpatient Medications." + K DIC S DIC="^VA(200,",DIC(0)="AEMQZ",DIC("A")="Select PHARMACY PROVIDER: ",DIC("S")="S PSG=$G(^(""PS"")) I PSG,$S('$P(PSG,""^"",4):1,1:DT<$P(PSG,""^"",4))" F W ! D ^DIC Q:$D(DUOUT)!$D(DTOUT)!(Y>0) W $C(7)," (Required.)" + K DIC S:Y'>0 PSJORPF=11 S:Y>0 PSJORPV=+Y,PSJORPVN=Y(0,0) Q + Q +ENBKOUT(DFN,ON) ; Undo Renew. + Q:'$G(ON) + N PSJOLD,PSJRES,PSJOC,PSJOC2,PSIVACT,PSIVALT,PSIVREA,ON55,PSGAL,DA,PSIVAL,PSJUNDC + S PSJOC=PSOC,PSJOC2=PSJHLMTN,PSIVAL=24000 + S X=$G(^PS(53.1,+ON,0)) Q:'X + S PSJRES=$P(X,U,24),(X,PSJOLD)=$P(X,U,25) + I PSJOLD["V" S:$D(^PS(55,DFN,"IV",+PSJOLD,2)) $P(^(2),U,6)="",$P(^(2),U,9)="",$P(^(0),U,17)="A",PSIVACT=1,PSIVALT=$S(PSOC="CR":2,1:1),PSJUNDC=1,PSIVAL=$P($G(^PS(53.3,+PSIVAL,0)),U),PSIVREA="PNRD",ON55=PSJOLD D LOG^PSIVORAL + I PSJOLD["U" S:$D(^PS(55,DFN,5,+PSJOLD,0)) $P(^(0),U,26,27)=U,$P(^(0),U,9)="A",PSGAL("C")=24000,DA=+PSJOLD,DA(1)=DFN D ^PSGAL5 + S PSOC="SC",PSJHLMTN="ORM" D EN1^PSJHL2(DFN,PSOC,PSJOLD) S PSOC=PSJOC,PSJHLMTN=PSJOC2 + Q + ; +ENUDTX(DFN,ON,RES) ; Set up ORTX( Array for UD orders. + K ORTX N DO,MRN,ND0,NDP1,ND2,PD,ST,SCH + S Y=2 I ON["A"!(ON["O") S ND0=$G(^PS(55,DFN,5,+ON,0)),NDP1=$G(^(.1)),ND2=$G(^(2)),Y=2 F X=0:0 S X=$O(^PS(55,DFN,5,+ON,12,X)) Q:'X S Y=Y+1,ORTX(Y)=$G(^(X,0)) + E S ND0=$G(^PS(53.1,+ON,0)),NDP1=$G(^(.1)),ND2=$G(^(2)),Y=2 F X=0:0 S X=$O(^PS(53.1,+ON,12,X)) Q:'X S Y=Y+1,ORTX(Y)=$G(^(X,0)) + S ORTX(1)=$S($G(RES)="NR":"RENEWAL -",$G(RES)="OR":"RENEWED -",1:"")_$P($G(^PS(50.3,+NDP1,0)),U) + S ORTX(2)=" Give: "_$S($P(NDP1,U,2)]"":$P(NDP1,U,2)_" ",1:"")_$P($G(^PS(51.2,+$P(ND0,U,3),0)),U,3)_" "_$P(ND2,U)_$S($P(ND2,U)["PRN":"",$P(ND0,U,7)="P":" PRN",1:"") + I $G(DFN),$G(ON) S:ON["U" ^PS(55,"AUE",DFN,+ON)="" + Q diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJORPOE.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJORPOE.m index 8420c78e..9e0a8d97 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJORPOE.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJORPOE.m @@ -1,118 +1,114 @@ -PSJORPOE ;BIR/MLM,LDT-MISC. PROCEDURE CALLS FOR OE/RR 3.0 ;24 Feb 99 / 10:43 AM - ;;5.0; INPATIENT MEDICATIONS ;**50,56,92,80,110,127,133,134**;16 DEC 97;Build 124 - ; - ; Reference to ^PS(50.7 is supported by DBIA# 2180. - ; Reference to ^PS(51.2 is supported by DBIA# 2178. - ; Reference to ^PS(55 is supported by DBIA# 2191. - ; Reference to ^PS(51.1 is supported by DBIA# 2177. - ; Reference to ^PS(52.6 is supported by DBIA# 1231. - ; Reference to ^PS(52.7 is supported by DBIA# 2173. - ; Reference to ^PSDRUG is supported by DBIA# 2192. - ; -STARTSTP(PSGP,SCH,OI,PSJPWD,PSGORD,PSJADM) ; - ; PSGP=Patient IEN - ; SCH=Schedule - ; OI=Orderable Item - ; PSJPWD=Ward Location (Optional) - ; PSGORD=Pharmacy Order Number if the order being placed is a Renewal (Optional) - ; - Q:+PSGP'>0 "" - Q:SCH']"" "" - Q:+OI'>0 "" - I SCH?.E1L.E S SCH=$$ENLU^PSGMI(SCH) - K DFN,PSGNEFDO,PSGNEFD,PSGST,PSGSCH,PSGNEDFD,PSGNESD,PSJSYSW,PSJSYSW0 N RESULT - S:'$D(PSGS0XT) PSGS0XT="" S:'$D(PSGS0Y) PSGSOY="" - I $G(PSJPWD)']"" S DFN=PSGP D IN5^VADPT S:VAIP(5)]"" PSJPWD=+VAIP(5) - S PSJSYSW0="",PSJSYSW=0 I $G(PSJPWD)]"" S PSJSYSW=+$O(^PS(59.6,"B",PSJPWD,0)) I PSJSYSW S PSJSYSW0=$G(^PS(59.6,PSJSYSW,0)) - S RESULT=$S($P(PSJSYSW0,"^",5)=0:"CLOSEST",$P(PSJSYSW0,"^",5)=1:"NEXT",1:"NOW") - I OI]"" S PSGST=$S($P($G(^PS(50.7,OI,0)),"^",7)]"":$P($G(^PS(50.7,OI,0)),"^",7),1:"C") - N %,PSGXSCH D NOW^%DTC S PSGDT=%,DFN=PSGP,(PSGSCH,PSGXSCH)=SCH - S X=PSGSCH,PSGS0Y="" D ADMIN - I $G(PSGORD)]"" D - .S PSGNESD=$$DSTART^PSJDCU(PSGP,PSGORD) I PSGNESD]"" S $P(RESULT,"^",2)=PSGNESD Q - .S ND=$S(PSGORD["U":$G(^PS(55,PSGP,5,+PSGORD,2)),1:$G(^PS(55,PSGP,"IV",+PSGORD,0))) - .N PSJADM,PSJSTRT S PSJADM=$S(PSGORD["U":$P(ND,"^",5),1:$P(ND,"^",11)),PSJSTRT=$P(ND,"^",2),PSJREN=1 - S SCH=PSGXSCH - N PSJTMPW0 S PSJTMPW0=PSJSYSW0 S $P(PSJSYSW0,"^",5)=1 - I $G(PSGNESD)="" S RESULT=RESULT_"^"_$$ENSD^PSGNE3(PSGSCH,$S($G(PSJADM)]"":$G(PSJADM),1:PSGS0Y),PSGDT,$S($G(PSJSTRT)]"":$G(PSJSTRT),1:PSGDT)) - S PSJSYSW0=PSJTMPW0 - S PSGNESD=$P(RESULT,"^",2) - S PSGNEDFD=$$GTNEDFD^PSGOE7("U",OI) - K PSGODF,PSGOES,PSJREN - S SCH=PSGXSCH - D ENFD^PSGNE3(PSGDT) S RESULT=RESULT_"^"_$G(PSGNEFD) ;_"^"_$G(PSGNEFDO) - N DATE S DATE=$$FMDIFF^XLFDT($P(RESULT,"^",3),$P(RESULT,"^",2),3) - S $P(RESULT,"^",3)=$S($G(PSGST)="O":0,+DATE>0:+DATE_"D",$P($P(DATE," ",2),":")>0:$P($P(DATE," ",2),":")_"H",1:0) - N STRING S STRING=PSGNESD_U_PSGNEFD_U_$G(PSGSCH)_U_$G(PSGST)_U_$G(OI) I ($P($G(ZZND),U,2)]"")&($P($G(ZZND),"^")=$G(PSGSCH)) S STRING=STRING_U_$P(ZZND,U,2) - I $G(PSGSCH)]"" I $$DOW^PSIVUTL(PSGSCH) S:$G(PSGS0Y) $P(STRING,"^",6)=PSGS0Y - I $G(PSJADM) S $P(STRING,"^",6)=PSJADM - S RESULT=RESULT_"^"_$$ENQ^PSJORP2(PSGP,STRING) I ($G(PSGSCH)]"") I $$DOW^PSIVUTL(PSGSCH),(PSGSCH'["@"),'$G(PSGS0Y) S $P(RESULT,"^",4)=$P(RESULT,"^",2) - I ($G(PSGSCH)]"") I $$PRNOK^PSGS0(PSGSCH) S $P(RESULT,"^",4)=$P(RESULT,"^",2) - D KVAR^VADPT K LYN,ND,PSGDT,PSGNEDFD,PSGNEFD,PSGNEFDO,PSGNESD,PSGS0Y,PSGSCH,PSGST,PSJSYSW,PSJSYSW0,ZZ - ;RESULT=WARD PARAMETER^DEFAULT START DATE/TIME^#_D(NUMBER OF DAYS ORDER LASTS) OR #_H(NUMBER OF HOURS ORDER LASTS)^EXPECTED FIRST DOSE - Q RESULT - ; -RESOLVE(PSGP,SCH,OI,PCH,PSJPWD,PSJADM) ; - ; PSGP=Patient IEN - ; SCH=Schedule - ; OI=Orderable Item - ; PCH=Providers Choice - ; PSJPWD=Ward Location (Optional) - ; PSJADM=Admin Times (Optional) - ; - N PSJSYSW0,PSJSYSW,PSGSCH,PSGOES,PSGS0Y,DFN,RESULT1 - I $G(PSJPWD)']"" S DFN=PSGP D IN5^VADPT S:VAIP(5)]"" PSJPWD=+VAIP(5) - S PSJSYSW0="",PSJSYSW=0 I $G(PSJPWD)]"" S PSJSYSW=+$O(^PS(59.6,"B",PSJPWD,0)) I PSJSYSW S PSJSYSW0=$G(^PS(59.6,PSJSYSW,0)) - S $P(PSJSYSW0,"^",5)=$S($$ONE(SCH):2,PCH="NEXT":1,1:0) - S RESULT1=$S($P(PSJSYSW0,"^",5)=0:"CLOSEST",$P(PSJSYSW0,"^",5)=1:"NEXT",1:"NOW") - I OI]"" S PSGST=$S($P($G(^PS(50.7,OI,0)),"^",7)]"":$P($G(^PS(50.7,OI,0)),"^",7),1:"C") - N % D NOW^%DTC S PSGDT=%,DFN=PSGP,PSGSCH=SCH - S X=PSGSCH,PSGS0Y="" I $D(^PS(51.1,"AC","PSJ",X)) D ADMIN - S:$G(PSJADM) PSGS0Y=PSJADM - S RESULT1=RESULT1_"^"_$$ENSD^PSGNE3(SCH,PSGS0Y,PSGDT,PSGDT) - I $G(PSGSCH)]"" I $$DOW^PSIVUTL(PSGSCH),(PSGSCH'["@"),'$G(PSGS0Y) S $P(RESULT,"^",4)=$P(RESULT,"^",2) - I $G(PSGSCH)]"" I $$PRNOK^PSGS0(PSGSCH) S $P(RESULT1,"^",4)=$P(RESULT,"^",2) - D KVAR^VADPT K LYN,PSGDT,PSGNEDFD,PSGNEFD,PSGNEFDO,PSGNESD,PSGS0Y,PSGSCH,PSGST,PSJSYSW,PSJSYSW0,ZZ,PSGS0XT,PSGS0Y - Q RESULT1 - ; -SCHREQ(MR,OI,DD) ; - ; MR=Medication Route from 51.2 (Required) - ; OI=Orderable Item from 50.7 (Optional) - ; DD=Dispense Drug from 50 (Optional) - N ADDITIVE,SOLUTION,REQ S REQ=0,(SOLUTION,ADDITIVE)="" - I '+$G(MR) S REQ=1 Q REQ - I '+$G(OI),'+$G(DD) S REQ=1 Q REQ - I +$G(DD) S:$P($G(^PSDRUG(+DD,2)),U,3)["U" REQ=1 Q REQ - I '$D(PS(51.2,+MR,0)) S REQ=1 Q REQ - I $P($G(^PS(51.2,+MR,0)),"^",6)=1 D - .I +$G(OI) D - ..I '$D(^PS(50.7,+OI,0)) S REQ=1 Q - ..F S SOLUTION=$O(^PS(52.7,"AOI",+OI,SOLUTION)) Q:'SOLUTION Q:REQ=1 S:$P(^PSDRUG(+$P(^PS(52.7,SOLUTION,0),U,2),2),U,3)["U" REQ=1 - ..F S ADDITIVE=$O(^PS(52.6,"AOI",+OI,ADDITIVE)) Q:'ADDITIVE Q:REQ=1 S:$P(^PSDRUG(+$P(^PS(52.6,ADDITIVE,0),U,2),2),U,3)["U" REQ=1 - Q REQ - ; -ADMIN ; Get admin times associated with schedule - S PSGS0Y="",ZZ=0 - I $$DOW^PSIVUTL($P(X,"@")),'$D(^PS(51.1,"AC","PSJ",X)) S PSGST="D" D Q:$G(PSGS0Y) - .I $P(X,"@",2) N PSJADBAD D Q - ..S PSGS0Y=$S($G(PSJADBAD):"",1:$P(X,"@",2)) - ..N ADMIN,TIME,II S ADMIN=$P(X,"@",2) F II=1:1:$L(ADMIN,"-") S TIME=$P(ADMIN,"-",II) I TIME'?2N&(TIME'?4N) S PSJADBAD=1 - .I $P(X,"@",2)]"",$D(^PS(51.1,"APPSJ",$P(X,"@",2))) S X=$P(X,"@",2) - D FIND^DIC(51.1,,,,X,,"APPSJ",,,"LYN") - S ZZ=$O(LYN("DILIST",2,ZZ)) I ZZ S ZZ=+LYN("DILIST",2,ZZ) I ZZ S ZZND=$G(^PS(51.1,ZZ,0)) S PSGST=$P(ZZND,U,5),PSGS0XT=$P(ZZND,U,3) S:$G(PSGSFLG) PSGSCIEN=$G(LYN("DILIST",2,ZZ)) I $G(PSJPWD) D - . N ZZNDW S ZZNDW=$G(^PS(51.1,ZZ,1,PSJPWD,0)) I $P(ZZNDW,"^",2)]"" S PSGS0Y=$P(ZZNDW,"^",2),$P(ZZND,"^",2)=PSGS0Y I $G(PSGSFLG) S PSGSCIEN=$G(LYN("DILIST",2,ZZ)) - S ZZ=0 F S ZZ=$O(LYN("DILIST",1,ZZ)) Q:'ZZ I $G(LYN("DILIST",1,ZZ))'=X K LYN("DILIST",1,ZZ),LYN("DILIST",2,ZZ),LYN("DILIST","ID",ZZ,1) - I $D(PSJPWD) S ZZ=0 F S ZZ=$O(LYN("DILIST",2,ZZ)) Q:'ZZ!$G(PSGS0Y) I $P($G(^PS(51.1,+LYN("DILIST",2,ZZ),1,+PSJPWD,0)),U,2)]"" S PSGS0Y=$P($G(^(0)),U,2) I $G(PSGSFLG) S PSGSCIEN=$G(LYN("DILIST",2,ZZ)) - Q:PSGS0Y]"" S ZZ=0 F S ZZ=$O(LYN("DILIST",2,ZZ)) Q:'ZZ!$G(PSGS0Y) I $G(LYN("DILIST","ID",ZZ,1))]"" S PSGS0Y=$G(LYN("DILIST","ID",ZZ,1)) - Q - ; -ONE(SCH) ; - ; SCH=Admin Schedule - ; Returns 0 = (zero) Not a one time schedule. - ; 1 = One time schedule. - Q:$G(SCH)="" 0 - N X,SCHLST - S SCHLST=",TODAY,ONCE,NOW,ONE TIME,ONETIME,ONE-TIME,1TIME,1 TIME,1-TIME,STAT," - I SCHLST[(","_SCH_",") Q 1 - I $D(^PS(51.1,"AC","PSJ",SCH)) S X=$O(^(SCH,"")) S X=$P(^PS(51.1,X,0),"^",5) Q $S(X="O":1,1:0) - Q 0 +PSJORPOE ;BIR/MLM,LDT-MISC. PROCEDURE CALLS FOR OE/RR 3.0 ;24 Feb 99 / 10:43 AM + ;;5.0; INPATIENT MEDICATIONS ;**50,56,92,80,110,127,133**;16 DEC 97 + ; + ; Reference to ^PS(50.7 is supported by DBIA# 2180. + ; Reference to ^PS(51.2 is supported by DBIA# 2178. + ; Reference to ^PS(55 is supported by DBIA# 2191. + ; Reference to ^PS(51.1 is supported by DBIA# 2177. + ; Reference to ^PS(52.6 is supported by DBIA# 1231. + ; Reference to ^PS(52.7 is supported by DBIA# 2173. + ; Reference to ^PSDRUG is supported by DBIA# 2192. + ; +STARTSTP(PSGP,SCH,OI,PSJPWD,PSGORD) ; + ; PSGP=Patient IEN + ; SCH=Schedule + ; OI=Orderable Item + ; PSJPWD=Ward Location (Optional) + ; PSGORD=Pharmacy Order Number if the order being placed is a Renewal (Optional) + ; + Q:+PSGP'>0 "" + Q:SCH']"" "" + Q:+OI'>0 "" + I SCH?.E1L.E S SCH=$$ENLU^PSGMI(SCH) + K DFN,PSGNEFDO,PSGNEFD,PSGST,PSGSCH,PSGNEDFD,PSGNESD,PSJSYSW,PSJSYSW0 N RESULT + S:'$D(PSGS0XT) PSGS0XT="" S:'$D(PSGS0Y) PSGSOY="" + I $G(PSJPWD)']"" S DFN=PSGP D IN5^VADPT S:VAIP(5)]"" PSJPWD=+VAIP(5) + S PSJSYSW0="",PSJSYSW=0 I $G(PSJPWD)]"" S PSJSYSW=+$O(^PS(59.6,"B",PSJPWD,0)) I PSJSYSW S PSJSYSW0=$G(^PS(59.6,PSJSYSW,0)) + S RESULT=$S($P(PSJSYSW0,"^",5)=0:"CLOSEST",$P(PSJSYSW0,"^",5)=1:"NEXT",1:"NOW") + I OI]"" S PSGST=$S($P($G(^PS(50.7,OI,0)),"^",7)]"":$P($G(^PS(50.7,OI,0)),"^",7),1:"C") + N %,PSGXSCH D NOW^%DTC S PSGDT=%,DFN=PSGP,(PSGSCH,PSGXSCH)=SCH + S X=PSGSCH,PSGS0Y="" D ADMIN + I $G(PSGORD)]"" D + .S PSGNESD=$$DSTART^PSJDCU(PSGP,PSGORD) I PSGNESD]"" S RESULT=RESULT_"^"_PSGNESD Q + .S ND=$S(PSGORD["U":$G(^PS(55,PSGP,5,+PSGORD,2)),1:$G(^PS(55,PSGP,"IV",+PSGORD,0))) + .N PSJADM,PSJSTRT S PSJADM=$S(PSGORD["U":$P(ND,"^",5),1:$P(ND,"^",11)),PSJSTRT=$P(ND,"^",2),PSJREN=1 + S SCH=PSGXSCH + I $G(PSGNESD)="" S RESULT=RESULT_"^"_$$ENSD^PSGNE3(PSGSCH,$S($G(PSJADM)]"":$G(PSJADM),1:PSGS0Y),PSGDT,$S($G(PSJSTRT)]"":$G(PSJSTRT),1:PSGDT)) + ;S Y=$P(RESULT,"^",2) X ^DD("DD") S RESULT=RESULT_"^"_Y + S PSGNESD=$P(RESULT,"^",2) + S PSGNEDFD=$$GTNEDFD^PSGOE7("U",OI) + K PSGODF,PSGOES,PSJREN + S SCH=PSGXSCH + D ENFD^PSGNE3(PSGDT) S RESULT=RESULT_"^"_$G(PSGNEFD) ;_"^"_$G(PSGNEFDO) + N DATE S DATE=$$FMDIFF^XLFDT($P(RESULT,"^",3),$P(RESULT,"^",2),3) + S $P(RESULT,"^",3)=$S($G(PSGST)="O":0,+DATE>0:+DATE_"D",$P($P(DATE," ",2),":")>0:$P($P(DATE," ",2),":")_"H",1:0) + ;S RESULT=RESULT_"^"_$P($$RESOLVE(PSGP,SCH,OI,"NEXT"),"^",2) + N STRING S STRING=PSGNESD_U_PSGNEFD_U_$G(PSGSCH)_U_$G(PSGST)_U_$G(OI) I ($P($G(ZZND),U,2)]"")&($P($G(ZZND),"^")=$G(PSGSCH)) S STRING=STRING_U_$P(ZZND,U,2) + I $G(PSGSCH)]"" I $$DOW^PSIVUTL(PSGSCH) S:$G(PSGS0Y) $P(STRING,"^",6)=PSGS0Y + S RESULT=RESULT_"^"_$$ENQ^PSJORP2(PSGP,STRING) I ($G(PSGSCH)]"") I $$DOW^PSIVUTL(PSGSCH),(PSGSCH'["@"),'$G(PSGS0Y) S $P(RESULT,"^",4)=$P(RESULT,"^",2) + I ($G(PSGSCH)]"") I $$PRNOK^PSGS0(PSGSCH) S $P(RESULT,"^",4)=$P(RESULT,"^",2) + D KVAR^VADPT K LYN,ND,PSGDT,PSGNEDFD,PSGNEFD,PSGNEFDO,PSGNESD,PSGS0Y,PSGSCH,PSGST,PSJSYSW,PSJSYSW0,ZZ + ;RESULT=WARD PARAMETER^DEFAULT START DATE/TIME^#_D(NUMBER OF DAYS ORDER LASTS) OR #_H(NUMBER OF HOURS ORDER LASTS)^EXPECTED FIRST DOSE + Q RESULT + ; +RESOLVE(PSGP,SCH,OI,PCH,PSJPWD) ; + ; PSGP=Patient IEN + ; SCH=Schedule + ; OI=Orderable Item + ; PCH=Providers Choice + ; PSJPWD=Ward Location (Optional) + ; + N PSJSYSW0,PSJSYSW,PSGSCH,PSGOES,PSGS0Y,DFN,RESULT1 + I $G(PSJPWD)']"" S DFN=PSGP D IN5^VADPT S:VAIP(5)]"" PSJPWD=+VAIP(5) + S PSJSYSW0="",PSJSYSW=0 I $G(PSJPWD)]"" S PSJSYSW=+$O(^PS(59.6,"B",PSJPWD,0)) I PSJSYSW S PSJSYSW0=$G(^PS(59.6,PSJSYSW,0)) + S $P(PSJSYSW0,"^",5)=$S($$ONE(SCH):2,PCH="NEXT":1,1:0) + S RESULT1=$S($P(PSJSYSW0,"^",5)=0:"CLOSEST",$P(PSJSYSW0,"^",5)=1:"NEXT",1:"NOW") + I OI]"" S PSGST=$S($P($G(^PS(50.7,OI,0)),"^",7)]"":$P($G(^PS(50.7,OI,0)),"^",7),1:"C") + N % D NOW^%DTC S PSGDT=%,DFN=PSGP,PSGSCH=SCH + S X=PSGSCH,PSGS0Y="" I $D(^PS(51.1,"AC","PSJ",X)) D ADMIN + S RESULT1=RESULT1_"^"_$$ENSD^PSGNE3(SCH,PSGS0Y,PSGDT,PSGDT) + I $G(PSGSCH)]"" I $$DOW^PSIVUTL(PSGSCH),(PSGSCH'["@"),'$G(PSGS0Y) S $P(RESULT,"^",4)=$P(RESULT,"^",2) + I $G(PSGSCH)]"" I $$PRNOK^PSGS0(PSGSCH) S $P(RESULT1,"^",4)=$P(RESULT,"^",2) + D KVAR^VADPT K LYN,PSGDT,PSGNEDFD,PSGNEFD,PSGNEFDO,PSGNESD,PSGS0Y,PSGSCH,PSGST,PSJSYSW,PSJSYSW0,ZZ,PSGS0XT,PSGS0Y + Q RESULT1 + ; +SCHREQ(MR,OI,DD) ; + ; MR=Medication Route from 51.2 (Required) + ; OI=Orderable Item from 50.7 (Optional) + ; DD=Dispense Drug from 50 (Optional) + N ADDITIVE,SOLUTION,REQ S REQ=0,(SOLUTION,ADDITIVE)="" + I '+$G(MR) S REQ=1 Q REQ + I '+$G(OI),'+$G(DD) S REQ=1 Q REQ + I +$G(DD) S:$P($G(^PSDRUG(+DD,2)),U,3)["U" REQ=1 Q REQ + I '$D(PS(51.2,+MR,0)) S REQ=1 Q REQ + I $P($G(^PS(51.2,+MR,0)),"^",6)=1 D + .I +$G(OI) D + ..I '$D(^PS(50.7,+OI,0)) S REQ=1 Q + ..F S SOLUTION=$O(^PS(52.7,"AOI",+OI,SOLUTION)) Q:'SOLUTION Q:REQ=1 S:$P(^PSDRUG(+$P(^PS(52.7,SOLUTION,0),U,2),2),U,3)["U" REQ=1 + ..F S ADDITIVE=$O(^PS(52.6,"AOI",+OI,ADDITIVE)) Q:'ADDITIVE Q:REQ=1 S:$P(^PSDRUG(+$P(^PS(52.6,ADDITIVE,0),U,2),2),U,3)["U" REQ=1 + Q REQ + ; +ADMIN ; Get admin times associated with schedule + S PSGS0Y="",ZZ=0 + I $$DOW^PSIVUTL(X),'$D(^PS(51.1,"AC","PSJ",X)) S PSGST="D" D Q + .I $P(X,"@",2) N PSJADBAD D I '$G(PSJADBAD) S PSGS0Y=$P(X,"@",2) + ..N ADMIN,TIME,II S ADMIN=$P(X,"@",2) F II=1:1:$L(ADMIN,"-") S TIME=$P(ADMIN,"-",II) I TIME'?2N&(TIME'?4N) S PSJADBAD=1 + .I '$G(PSGS0Y) S PSGS0Y="" + D FIND^DIC(51.1,,,,X,,"APPSJ",,,"LYN") + S ZZ=$O(LYN("DILIST",2,ZZ)) I ZZ S ZZ=+LYN("DILIST",2,ZZ) I ZZ S ZZND=$G(^PS(51.1,ZZ,0)) S PSGST=$P(ZZND,U,5),PSGS0XT=$P(ZZND,U,3) I $G(PSJPWD) D + . N ZZNDW S ZZNDW=$G(^PS(51.1,ZZ,1,PSJPWD,0)) I $P(ZZNDW,"^",2)]"" S PSGS0Y=$P(ZZNDW,"^",2),$P(ZZND,"^",2)=PSGS0Y + S ZZ=0 F S ZZ=$O(LYN("DILIST",1,ZZ)) Q:'ZZ I $G(LYN("DILIST",1,ZZ))'=X K LYN("DILIST",1,ZZ),LYN("DILIST",2,ZZ),LYN("DILIST","ID",ZZ,1) + I $D(PSJPWD) S ZZ=0 F S ZZ=$O(LYN("DILIST",2,ZZ)) Q:'ZZ I $P($G(^PS(51.1,+LYN("DILIST",2,ZZ),1,+PSJPWD,0)),U,2)]"" S PSGS0Y=$P($G(^(0)),U,2) + Q:PSGS0Y]"" S ZZ=0 F S ZZ=$O(LYN("DILIST",2,ZZ)) Q:'ZZ Q:PSGS0Y]"" I $G(LYN("DILIST","ID",ZZ,1))]"" S PSGS0Y=$G(LYN("DILIST","ID",ZZ,1)) + Q + ; +ONE(SCH) ; + ; SCH=Admin Schedule + ; Returns 0 = (zero) Not a one time schedule. + ; 1 = One time schedule. + Q:$G(SCH)="" 0 + N X,SCHLST + S SCHLST=",TODAY,ONCE,NOW,ONE TIME,ONETIME,ONE-TIME,1TIME,1 TIME,1-TIME,STAT," + I SCHLST[(","_SCH_",") Q 1 + I $D(^PS(51.1,"AC","PSJ",SCH)) S X=$O(^(SCH,"")) S X=$P(^PS(51.1,X,0),"^",5) Q $S(X="O":1,1:0) + Q 0 diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJORRE.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJORRE.m index 25df130b..2fb959d3 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJORRE.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJORRE.m @@ -1,90 +1,92 @@ -PSJORRE ;BIR/MV-RETURN INPATIENT ACTIVE MEDS (CONDENSED) ;28 Jan 99 / 12:56 PM - ;;5.0; INPATIENT MEDICATIONS ;**22,51,50,58,81,110,111,112,134**;16 DEC 97;Build 124 - ; - ;Reference to ^PS(52.6 is supported by DBIA 1231. - ;Reference to ^PS(52.7 is supported by DBIA 2173. - ;Reference to ^PS(55 is supported by DBIA 2191. - ;Reference to ^TMP("PS" is documented in DBIA #2383. - ; -OCL(DFN,BDT,EDT,TFN,MVIEW) ; return condensed list of inpat meds - ; MVIEW=0 - This returns the 'unsorted' list as it was returned prior to GUI 27 - ; MVIEW=1 - This returns the old sort view of the list, pre-sorted for GUI 27 - ; MVIEW=2 - This returns new sort view #1 of the order profile for GUI 27 - ; MVIEW=3 - This returns new sort view #2 of the order profile for GUI 27 - D @$S($G(MVIEW)=3:"OCL^PSJORRN1(DFN,BDT,EDT,.TFN)",$G(MVIEW)=2:"OCL^PSJORRN(DFN,BDT,EDT,.TFN)",$G(MVIEW)=1:"OCL^PSJORRO(DFN,BDT,EDT,.TFN)",1:"OCL1(DFN,BDT,EDT,TFN)") - Q -OCL1(DFN,BDT,EDT,TFN,MVIEW) ; Execute this section if MVIEW=0 - N ADM,CNT,DN,DO,F,FON,INFUS,INST,MR,ND,ND0,ND2,ND6,ON,PON,PST,SCH,SIO,STAT,TYPE,UNITS,WBDT,X,Y,PSJCLIN,A - ; PON=placer order number (oerr), FON=filler order number - S:BDT="" BDT=DT S WBDT=BDT_".000001" - S:EDT="" EDT=9999999 - S:EDT'["." EDT=EDT_".999999" - S F="^PS(55,DFN,5," F S WBDT=$O(^PS(55,DFN,5,"AUS",WBDT)) Q:'WBDT F ON=0:0 S ON=$O(^PS(55,DFN,5,"AUS",WBDT,ON)) Q:'ON D UDTMP - S F="^PS(53.1," F PST="P","N" F ON=0:0 S ON=$O(^PS(53.1,"AS",PST,DFN,ON)) Q:'ON S X=$P($G(^PS(53.1,+ON,0)),U,4) D @$S(X="U":"UDTMP",1:"IVTMP") - S F="^PS(55,"_DFN_",""IV"",",WBDT=BDT F S WBDT=$O(^PS(55,DFN,"IV","AIS",WBDT)) Q:'WBDT F ON=0:0 S ON=$O(^PS(55,DFN,"IV","AIS",WBDT,ON)) Q:'ON D IVTMP - Q - ; -UDTMP ;*** Set ^TMP for Unit dose orders. - N PROVIDER,RNWDT,EDTCMPLX,NDP2 S (MR,SCH,INST,PON)="",FON=+ON_$S(F["53.1":"P",1:"U") - D TYPE - S RNWDT=$$LASTREN^PSJLMPRI(DFN,FON) I RNWDT S RNWDT=+RNWDT - S NDP2=$G(@(F_ON_",.2)")) S EDTCMPLX=$P(NDP2,"^",8) - S ND2=$G(@(F_ON_",2)")) I 'EDTCMPLX I F'["53.1",($P(ND2,U,2)>EDT) Q - S ND0=$G(@(F_ON_",0)")) I 'EDTCMPLX I F["53.1",($P(ND0,U,16)>EDT) Q - S STAT=$$CODES^PSIVUTL($P(ND0,U,9),$S(FON["P":53.1,1:55.06),28) - S ND6=$P($G(@(F_ON_",6)")),"^"),INST=$G(@(F_+ON_",.3)")) - S FON=+ON_$S(F["53.1":"P",1:"U"),DO=$P($G(@(F_ON_",.2)")),"^",2) - D DRGDISP^PSJLMUT1(DFN,FON,40,0,.DN,1) - S UNITS="" I '$O(@(F_+ON_",1,1)")) S UNITS=$P($G(@(F_+ON_",1,1,0)")),U,2) S:(FON["U")&(UNITS="") UNITS=1 - S:+$P(ND0,U,3) MR=$$MR^PSJORRE1(+$P(ND0,U,3)) - N NOTGIVEN S NOTGIVEN=$S(FON["U":$P($G(^PS(55,DFN,5,+ON,0)),"^",22),1:"") - S TFN=TFN+1 - S ^TMP("PS",$J,TFN,0)=FON_";I"_U_DN(1)_"^^"_$P(ND2,U,4)_"^^"_DO_U_UNITS_U_$P(ND0,U,21)_U_STAT_U_U_U_U_NOTGIVEN_U_($P(ND0,U,9)="P"&($P(ND0,U,24)="R"))_U_$P(ND2,U,2)_U_$G(RNWDT) - K ^TMP("PS",$J,TFN,"CLINIC",0) I PSJCLIN]"" S ^TMP("PS",$J,TFN,"CLINIC",0)=PSJCLIN - S PROVIDER=$P($G(@(F_+ON_",0)")),"^",2) - I PROVIDER S ^TMP("PS",$J,TFN,"P",0)=PROVIDER_"^"_$P($G(^VA(200,PROVIDER,0)),"^") - S ^TMP("PS",$J,TFN,"MDR",0)=MR]"" S:MR]"" ^TMP("PS",$J,TFN,"MDR",1,0)=MR - S ^TMP("PS",$J,TFN,"SCH",0)=$P(ND2,U)]"" S:$P(ND2,U)]"" ^TMP("PS",$J,TFN,"SCH",1,0)=$P(ND2,U) - S ^TMP("PS",$J,TFN,"SIG",0)=INST]"" S:INST]"" ^TMP("PS",$J,TFN,"SIG",1,0)=INST - S ^TMP("PS",$J,TFN,"ADM",0)=$P(ND2,U,5)]"" S:$P(ND2,U,5)]"" ^TMP("PS",$J,TFN,"ADM",1,0)=$P(ND2,U,5) - S ^TMP("PS",$J,TFN,"SIO",0)=ND6]"" S:ND6]"" ^TMP("PS",$J,TFN,"SIO",1,0)=ND6 - Q - ; -IVTMP ;*** Set ^TMP for IV orders. - N PROVIDER,START,STOP,EDTCMPLX,NDP2,IVLIM - S NDP2=$G(@(F_ON_",.2)")) S EDTCMPLX=$P(NDP2,"^",8) - S ND0=$G(@(F_ON_",0)")) I 'EDTCMPLX I F'["53.1",($P(ND0,U,2)>EDT) Q - D TYPE - S FON=+ON_$S(F["53.1":"P",1:"V"),TFN=TFN+1,CNT=0 - S RNWDT=$$LASTREN^PSJLMPRI(DFN,FON) I RNWDT S RNWDT=+RNWDT - F X=0:0 S X=$O(@(F_ON_",""AD"","_X_")")) Q:'X S ND=$G(@(F_ON_",""AD"","_X_",0)")),DN=$P($G(^PS(52.6,+ND,0)),U),Y=DN_U_$P(ND,U,2) S:$P(ND,U,3) Y=Y_U_$P(ND,U,3) S CNT=CNT+1,^TMP("PS",$J,TFN,"A",CNT,0)=Y - S ^TMP("PS",$J,TFN,"A",0)=CNT,CNT=0 - F X=0:0 S X=$O(@(F_ON_",""SOL"","_X_")")) Q:'X S ND=$G(@(F_ON_",""SOL"","_X_",0)")),DN=$G(^PS(52.7,+ND,0)),CNT=CNT+1,^TMP("PS",$J,TFN,"B",CNT,0)=$P(DN,U)_U_$P(ND,U,2)_U_$P(DN,U,4) - S ^TMP("PS",$J,TFN,"B",0)=CNT - S TYPE=$P(ND0,U,4),(MR,SCH,INST,INFUS)="" - I FON["P" S ND2=$G(^PS(53.1,+ON,2)),SCH=$P(ND2,U),START=$P(ND2,U,2),STOP=$P(ND2,U,4),MR=$P(ND0,U,3),INFUS=$P($G(^PS(53.1,+ON,8)),U,5),STAT=$$CODES^PSIVUTL($P(ND0,U,9),53.1,28),ADM=$P(ND2,U,5),SIO=$P($G(@(F_+ON_",6)")),"^") - I FON'["P" S START=$P(ND0,U,2),STOP=$P(ND0,U,3),SCH=$P(ND0,U,9),INFUS=$P(ND0,U,8),MR=$P($G(^PS(55,DFN,"IV",+ON,.2)),U,3),STAT=$$CODES^PSIVUTL($P(ND0,U,17),55.01,100),ADM=$P(ND0,U,11),SIO=$P($G(@(F_+ON_",3)")),"^") - S DN=$G(@(F_+ON_",.2)")),DO=$P(DN,U,2) - S DN=$S(+$P(DN,U):$$OIDF^PSJLMUT1($P(DN,U)),1:"") - S:MR MR=$$MR^PSJORRE1(+MR),INST=$G(@(F_+ON_",.3)")) - S ^TMP("PS",$J,TFN,0)=FON_";I"_U_DN_U_INFUS_U_STOP_"^^"_DO_"^^"_$P(ND0,"^",21)_U_STAT_U_U_U_U_U_($P(ND0,U,9)="P"&($P(ND0,U,24)="R"))_U_START_U_$G(RNWDT) - K ^TMP("PS",$J,TFN,"CLINIC",0) I PSJCLIN]"" S ^TMP("PS",$J,TFN,"CLINIC",0)=PSJCLIN - S PROVIDER=$P($G(@(F_+ON_",0)")),"^",6) - I PROVIDER S ^TMP("PS",$J,TFN,"P",0)=PROVIDER_"^"_$P($G(^VA(200,PROVIDER,0)),"^") - S ND2P5=$G(@(F_+ON_",2.5)")) S IVLIM=$P(ND2P5,U,4) I $E(IVLIM)="a" S IVLIM="doses"_$P(IVLIM,"a",2) - I IVLIM="" S IVLIM=$P(ND2P5,U,2) S:(IVLIM'["d")&(IVLIM'["h") IVLIM="" - S ^TMP("PS",$J,TFN,"MDR",0)=MR]"" S:MR]"" ^TMP("PS",$J,TFN,"MDR",1,0)=MR - S ^TMP("PS",$J,TFN,"SIG",0)=INST]"" S:INST]"" ^TMP("PS",$J,TFN,"SIG",1,0)=INST - S ^TMP("PS",$J,TFN,"SCH",0)=SCH]"" S:SCH]"" ^TMP("PS",$J,TFN,"SCH",1,0)=SCH - S ^TMP("PS",$J,TFN,"ADM",0)=ADM]"" S:ADM]"" ^TMP("PS",$J,TFN,"ADM",1,0)=ADM - S ^TMP("PS",$J,TFN,"SIO",0)=SIO]"" S:SIO]"" ^TMP("PS",$J,TFN,"SIO",1,0)=SIO - I $G(IVLIM)]"" S ^TMP("PS",$J,TFN,"IVLIM",0)=IVLIM - Q -STAT(Y,X) ;* Return the full status instead of just the code for U/D. - S X=$P($P(";"_$P(Y,U,3),";"_X_":",2),";") - Q X -TYPE ;determine if this is an IMO order or not - S (A,PSJCLIN)="" I F["PS(53.1" S A=$G(^PS(53.1,ON,"DSS")) - I F["PS(55" S A=$S(F["IV":$G(^PS(55,DFN,"IV",ON,"DSS")),1:$G(^PS(55,DFN,5,ON,8))) - I $P(A,"^",2)'="" S PSJCLIN=+A - Q +PSJORRE ;BIR/MV-RETURN INPATIENT ACTIVE MEDS (CONDENSED) ;28 Jan 99 / 12:56 PM + ;;5.0; INPATIENT MEDICATIONS ;**22,51,50,58,81,110,111,112**;16 DEC 97 + ; + ;Reference to ^PS(52.6 is supported by DBIA 1231. + ;Reference to ^PS(52.7 is supported by DBIA 2173. + ;Reference to ^PS(55 is supported by DBIA 2191. + ;Reference to OTF^OR3CONV is supported by DBIA 2412. + ;Reference to ^TMP("PS" is documented in DBIA #2383. + ; +OCL(DFN,BDT,EDT,TFN) ; return condensed list of inpat meds + N ADM,CNT,DN,DO,F,FON,INFUS,INST,MR,ND,ND0,ND2,ND6,ON,PON,PST,SCH,SIO,STAT,TYPE,UNITS,WBDT,X,Y,PSJCLIN,A + ;Check if 5.0 order conversion should be run for the selected patient. + F S X=$$OTF^OR3CONV(DFN,$S($E($G(IOST),1)="C":0,1:1)) Q:+X'<0 D + .I +X=-1 H 3 + ; PON=placer order number (oerr), FON=filler order number + S:BDT="" BDT=DT S WBDT=BDT_".000001" + S:EDT="" EDT=9999999 + S:EDT'["." EDT=EDT_".999999" + S F="^PS(55,DFN,5," F S WBDT=$O(^PS(55,DFN,5,"AUS",WBDT)) Q:'WBDT F ON=0:0 S ON=$O(^PS(55,DFN,5,"AUS",WBDT,ON)) Q:'ON D UDTMP + S F="^PS(53.1," F PST="P","N" F ON=0:0 S ON=$O(^PS(53.1,"AS",PST,DFN,ON)) Q:'ON S X=$P($G(^PS(53.1,+ON,0)),U,4) D @$S(X="U":"UDTMP",1:"IVTMP") + S F="^PS(55,"_DFN_",""IV"",",WBDT=BDT-1 F S WBDT=$O(^PS(55,DFN,"IV","AIS",WBDT)) Q:'WBDT F ON=0:0 S ON=$O(^PS(55,DFN,"IV","AIS",WBDT,ON)) Q:'ON D IVTMP + Q + ; +UDTMP ;*** Set ^TMP for Unit dose orders. + N PROVIDER,RNWDT,EDTCMPLX,NDP2 S (MR,SCH,INST,PON)="",FON=+ON_$S(F["53.1":"P",1:"U") + D TYPE + S RNWDT=$$LASTREN^PSJLMPRI(DFN,FON) I RNWDT S RNWDT=+RNWDT + S NDP2=$G(@(F_ON_",.2)")) S EDTCMPLX=$P(NDP2,"^",8) + S ND2=$G(@(F_ON_",2)")) I 'EDTCMPLX I F'["53.1",($P(ND2,U,2)>EDT) Q + S ND0=$G(@(F_ON_",0)")) I 'EDTCMPLX I F["53.1",($P(ND0,U,16)>EDT) Q + S STAT=$$CODES^PSIVUTL($P(ND0,U,9),$S(FON["P":53.1,1:55.06),28) + S ND6=$P($G(@(F_ON_",6)")),"^"),INST=$G(@(F_+ON_",.3)")) + S FON=+ON_$S(F["53.1":"P",1:"U"),DO=$P($G(@(F_ON_",.2)")),"^",2) + D DRGDISP^PSJLMUT1(DFN,FON,40,0,.DN,1) + ;S UNITS="" I '$O(@(F_+ON_",1,1)")),DO="" S UNITS=$P($G(@(F_+ON_",1,1,0)")),U,2) + S UNITS="" I '$O(@(F_+ON_",1,1)")) S UNITS=$P($G(@(F_+ON_",1,1,0)")),U,2) S:(FON["U")&(UNITS="") UNITS=1 + S:+$P(ND0,U,3) MR=$$MR^PSJORRE1(+$P(ND0,U,3)) + N NOTGIVEN S NOTGIVEN=$S(FON["U":$P($G(^PS(55,DFN,5,+ON,0)),"^",22),1:"") + S TFN=TFN+1 + S ^TMP("PS",$J,TFN,0)=FON_";I"_U_DN(1)_"^^"_$P(ND2,U,4)_"^^"_DO_U_UNITS_U_$P(ND0,U,21)_U_STAT_U_U_U_U_NOTGIVEN_U_($P(ND0,U,9)="P"&($P(ND0,U,24)="R"))_U_$P(ND2,U,2)_U_$G(RNWDT) + K ^TMP("PS",$J,TFN,"CLINIC",0) I PSJCLIN]"" S ^TMP("PS",$J,TFN,"CLINIC",0)=PSJCLIN + ;*S ^TMP("PS",$J,TFN,0)=FON_";I"_U_DN(1)_"^^"_$P(ND2,U,4)_"^^"_DO_U_UNITS_U_$P(ND0,U,21)_U_STAT_U_U_U_U_$P($G(^PS(55,DFN,5,+ON,0)),"^",22)_U_($P(ND0,U,9)="P"&($P(ND0,U,24)="R")) + S PROVIDER=$P($G(@(F_+ON_",0)")),"^",2) + I PROVIDER S ^TMP("PS",$J,TFN,"P",0)=PROVIDER_"^"_$P($G(^VA(200,PROVIDER,0)),"^") + S ^TMP("PS",$J,TFN,"MDR",0)=MR]"" S:MR]"" ^TMP("PS",$J,TFN,"MDR",1,0)=MR + S ^TMP("PS",$J,TFN,"SCH",0)=$P(ND2,U)]"" S:$P(ND2,U)]"" ^TMP("PS",$J,TFN,"SCH",1,0)=$P(ND2,U) + ;S:$P(ND0,U,7)]"" ^TMP("PS",$J,TFN,"SCH",0)=1,$P(^TMP("PS",$J,TFN,"SCH",1,0),U,2)=$P(ND0,U,7) + S ^TMP("PS",$J,TFN,"SIG",0)=INST]"" S:INST]"" ^TMP("PS",$J,TFN,"SIG",1,0)=INST + S ^TMP("PS",$J,TFN,"ADM",0)=$P(ND2,U,5)]"" S:$P(ND2,U,5)]"" ^TMP("PS",$J,TFN,"ADM",1,0)=$P(ND2,U,5) + S ^TMP("PS",$J,TFN,"SIO",0)=ND6]"" S:ND6]"" ^TMP("PS",$J,TFN,"SIO",1,0)=ND6 + Q + ; +IVTMP ;*** Set ^TMP for IV orders. + N PROVIDER,START,STOP,EDTCMPLX,NDP2,IVLIM + S NDP2=$G(@(F_ON_",.2)")) S EDTCMPLX=$P(NDP2,"^",8) + S ND0=$G(@(F_ON_",0)")) I 'EDTCMPLX I F'["53.1",($P(ND0,U,2)>EDT) Q + D TYPE + S FON=+ON_$S(F["53.1":"P",1:"V"),TFN=TFN+1,CNT=0 + S RNWDT=$$LASTREN^PSJLMPRI(DFN,FON) I RNWDT S RNWDT=+RNWDT + F X=0:0 S X=$O(@(F_ON_",""AD"","_X_")")) Q:'X S ND=$G(@(F_ON_",""AD"","_X_",0)")),DN=$P($G(^PS(52.6,+ND,0)),U),Y=DN_U_$P(ND,U,2) S:$P(ND,U,3) Y=Y_U_$P(ND,U,3) S CNT=CNT+1,^TMP("PS",$J,TFN,"A",CNT,0)=Y + S ^TMP("PS",$J,TFN,"A",0)=CNT,CNT=0 + F X=0:0 S X=$O(@(F_ON_",""SOL"","_X_")")) Q:'X S ND=$G(@(F_ON_",""SOL"","_X_",0)")),DN=$G(^PS(52.7,+ND,0)),CNT=CNT+1,^TMP("PS",$J,TFN,"B",CNT,0)=$P(DN,U)_U_$P(ND,U,2)_U_$P(DN,U,4) + S ^TMP("PS",$J,TFN,"B",0)=CNT + S TYPE=$P(ND0,U,4),(MR,SCH,INST,INFUS)="" + I FON["P" S ND2=$G(^PS(53.1,+ON,2)),SCH=$P(ND2,U),START=$P(ND2,U,2),STOP=$P(ND2,U,4),MR=$P(ND0,U,3),INFUS=$P($G(^PS(53.1,+ON,8)),U,5),STAT=$$CODES^PSIVUTL($P(ND0,U,9),53.1,28),ADM=$P(ND2,U,5),SIO=$P($G(@(F_+ON_",6)")),"^") + I FON'["P" S START=$P(ND0,U,2),STOP=$P(ND0,U,3),SCH=$P(ND0,U,9),INFUS=$P(ND0,U,8),MR=$P($G(^PS(55,DFN,"IV",+ON,.2)),U,3),STAT=$$CODES^PSIVUTL($P(ND0,U,17),55.01,100),ADM=$P(ND0,U,11),SIO=$P($G(@(F_+ON_",3)")),"^") + S DN=$G(@(F_+ON_",.2)")),DO=$P(DN,U,2) + S DN=$S(+$P(DN,U):$$OIDF^PSJLMUT1($P(DN,U)),1:"") + S:MR MR=$$MR^PSJORRE1(+MR),INST=$G(@(F_+ON_",.3)")) + ;S ^TMP("PS",$J,TFN,0)=FON_";I"_U_DN_U_INFUS_U_$P(ND0,U,3)_"^^"_DO_"^^"_$P(ND0,"^",21)_U_STAT + S ^TMP("PS",$J,TFN,0)=FON_";I"_U_DN_U_INFUS_U_STOP_"^^"_DO_"^^"_$P(ND0,"^",21)_U_STAT_U_U_U_U_U_($P(ND0,U,9)="P"&($P(ND0,U,24)="R"))_U_START_U_$G(RNWDT) + K ^TMP("PS",$J,TFN,"CLINIC",0) I PSJCLIN]"" S ^TMP("PS",$J,TFN,"CLINIC",0)=PSJCLIN + S PROVIDER=$P($G(@(F_+ON_",0)")),"^",6) + I PROVIDER S ^TMP("PS",$J,TFN,"P",0)=PROVIDER_"^"_$P($G(^VA(200,PROVIDER,0)),"^") + S ND2P5=$G(@(F_+ON_",2.5)")) S IVLIM=$P(ND2P5,U,4) + I IVLIM="" S IVLIM=$P(ND2P5,U,2) S:(IVLIM'["d")&(IVLIM'["h") IVLIM="" + S ^TMP("PS",$J,TFN,"MDR",0)=MR]"" S:MR]"" ^TMP("PS",$J,TFN,"MDR",1,0)=MR + S ^TMP("PS",$J,TFN,"SIG",0)=INST]"" S:INST]"" ^TMP("PS",$J,TFN,"SIG",1,0)=INST + S ^TMP("PS",$J,TFN,"SCH",0)=SCH]"" S:SCH]"" ^TMP("PS",$J,TFN,"SCH",1,0)=SCH + ;I FON["P" S:$P(ND0,U,7)]"" ^TMP("PS",$J,TFN,"SCH",0)=1,$P(^TMP("PS",$J,TFN,"SCH",1,0),U,2)=$P(ND0,U,7) + S ^TMP("PS",$J,TFN,"ADM",0)=ADM]"" S:ADM]"" ^TMP("PS",$J,TFN,"ADM",1,0)=ADM + S ^TMP("PS",$J,TFN,"SIO",0)=SIO]"" S:SIO]"" ^TMP("PS",$J,TFN,"SIO",1,0)=SIO + I $G(IVLIM)]"" S ^TMP("PS",$J,TFN,"IVLIM",0)=IVLIM + Q +STAT(Y,X) ;* Return the full status instead of just the code for U/D. + S X=$P($P(";"_$P(Y,U,3),";"_X_":",2),";") + Q X +TYPE ;determine if this is an IMO order or not + S (A,PSJCLIN)="" I F["PS(53.1" S A=$G(^PS(53.1,ON,"DSS")) + I F["PS(55" S A=$S(F["IV":$G(^PS(55,DFN,"IV",ON,"DSS")),1:$G(^PS(55,DFN,5,ON,8))) + I $P(A,"^",2)'="" S PSJCLIN=+A + Q diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJORRE1.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJORRE1.m index ec01e8ae..56142d81 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJORRE1.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJORRE1.m @@ -1,117 +1,125 @@ -PSJORRE1 ;BIR/MV-RETURN INPATIENT ACTIVE MEDS (EXPANDED) ;29 Jan 99 / 8:49 AM - ;;5.0; INPATIENT MEDICATIONS ;**22,51,50,58,81,91,110,111,134**;16 DEC 97;Build 124 - ; - ; Reference to ^PS(51.2 is supported by DBIA 2178. - ; Reference to ^PS(52.6 is supported by DBIA 1231. - ; Reference to ^PS(52.7 is supported by DBIA 2173. - ; Reference to ^PS(55 is supported by DBIA 2191. - ; Reference to ^PSDRUG is supported by DBIA 2192. - ; Reference to ^TMP("PS" is documented in DBIA #2384. - ; -OEL(DFN,ON) ; return list of expanded inpat meds - K ^TMP("PS",$J) - N ADM,CNT,DN,DO,F,INFUS,INST,MR,ND,ND0,ND2,ND2P5,ND6,NDOI,SCH,SIO,START,STAT,STOP,TYP,UNITS,X,Y - S F=$S(ON["P":"^PS(53.1,",ON["U":"^PS(55,DFN,5,",1:"^PS(55,"_DFN_",""IV"",") - I ON'["P",'$D(@(F_+ON_")")) Q - I ON["P" S X=$G(^PS(53.1,+ON,0)) Q:$P(X,U,15)'=DFN S TYP=$P(X,U,4) D @$S(TYP="U":"UDTMP",1:"IVTMP") - D:ON'["P" @$S(ON["U":"UDTMP",1:"IVTMP") - S Y=$S(ON["V":5,1:12),CNT=0 - I $O(@(F_+ON_","_Y_",0)")) D - . F X=0:0 S X=$O(@(F_+ON_","_Y_","_X_")")) Q:'X D - ..S CNT=CNT+1,ND=$G(@(F_+ON_","_Y_","_X_",0)")),^TMP("PS",$J,"PC",CNT,0)=ND - S ^TMP("PS",$J,"PC",0)=CNT - Q - ; -UDTMP ;*** Set ^TMP for Unit dose orders. - N DO,DN,INST,X,Y,PROVIDER,NOTGIVEN,RNWDT - S (MR,SCH,INST)="" - S ND2=$G(@(F_+ON_",2)")),ND0=$G(@(F_+ON_",0)")) - S ND6=$P($G(@(F_+ON_",6)")),"^") - S RNWDT=$$LASTREN^PSJLMPRI(DFN,ON) I RNWDT S RNWDT=+RNWDT - S STAT=$$CODES^PSIVUTL($P(ND0,U,9),$S(ON["P":53.1,1:55.06),28) - S NDOI=$G(@(F_+ON_",.2)")),DO=$P(NDOI,U,2) - S DN(1)=$$OIDF^PSJLMUT1(NDOI) I DN(1)="" K DN D DRGDISP^PSJLMUT1(DFN,ON,40,0,.DN,1) - S UNITS="" I '$O(@(F_+ON_",1,1)")) S UNITS=$P($G(@(F_+ON_",1,1,0)")),U,2) S:(ON["U")&(UNITS="") UNITS=1 - S MR=$$MR(+$P(ND0,U,3)),INST=$G(@(F_+ON_",.3)")) - S NOTGIVEN=$S(ON["U":$P($G(^PS(55,DFN,5,+ON,0)),"^",22),1:"") - S ^TMP("PS",$J,0)=DN(1)_"^^"_$P(ND2,U,4)_"^^"_$P(ND2,U,2)_U_STAT_"^^^"_DO_U_UNITS_U_$P(ND0,U,21)_U_U_NOTGIVEN_U_($P(ND0,U,9)="P"&($P(ND0,U,24)="R"))_U_U_$G(RNWDT) - S PROVIDER=$P($G(@(F_+ON_",0)")),"^",2) - I PROVIDER S ^TMP("PS",$J,"P",0)=PROVIDER_"^"_$P($G(^VA(200,PROVIDER,0)),"^") - S ^TMP("PS",$J,"MDR",0)=MR]"" S:MR]"" ^TMP("PS",$J,"MDR",1,0)=MR - S ^TMP("PS",$J,"SCH",0)=$P(ND2,U)]"" S:$P(ND2,U)]"" ^TMP("PS",$J,"SCH",1,0)=$P(ND2,U) - S:$P(ND0,U,7)]"" ^TMP("PS",$J,"SCH",0)=1,$P(^TMP("PS",$J,"SCH",1,0),U,2)=$$GTSCHT($P(ND0,U,7))_"^"_$P(ND0,U,7) - S ^TMP("PS",$J,"SIG",0)=INST]"" S:INST]"" ^TMP("PS",$J,"SIG",1,0)=INST - S ^TMP("PS",$J,"ADM",0)=$P(ND2,U,5)]"" S:$P(ND2,U,5)]"" ^TMP("PS",$J,"ADM",1,0)=$P(ND2,U,5) - S ^TMP("PS",$J,"SIO",0)=ND6]"" S:ND6]"" ^TMP("PS",$J,"SIO",1,0)=ND6 - NEW VERPHARM S:ON["U" VERPHARM=$P($G(@(F_+ON_",4)")),U,3) - S:+$G(VERPHARM) $P(^TMP("PS",$J,"RXN",0),U,5)=VERPHARM - NEW PSJDD,INACTDT,NDDD,OUTOI,PSJOUT S CNT=0 - F PSJDD=0:0 S PSJDD=$O(@(F_+ON_",1,PSJDD)")) Q:'PSJDD D - . S NDDD=@(F_+ON_",1,PSJDD,0)") - . I $P(NDDD,U,3)]"",($P(NDDD,U,3)'>DT) Q - . S PSJOUT=$P($G(^PSDRUG(+NDDD,8)),U,5) - . I +PSJOUT D - .. S INACTDT=$G(^PSDRUG(+PSJOUT,"I")),OUTOI=+$G(^PSDRUG(+PSJOUT,2)) - .. I INACTDT]"",(INACTDT'>DT) S (PSJOUT,OUTOI)="" - . I '+PSJOUT,($P($G(^PSDRUG(+NDDD,2)),U,3)["O") D - .. S PSJOUT=+NDDD,OUTOI=+NDOI - .. S INACTDT=$G(^PSDRUG(+NDDD,"I")) - .. I INACTDT]"",(INACTDT'>DT) S (PSJOUT,OUTOI)="" - . S UNITS=$P(NDDD,U,2) S:(ON["U")&(UNITS="") UNITS=1 - . S CNT=CNT+1,^TMP("PS",$J,"DD",CNT,0)=+NDDD_U_UNITS_U_PSJOUT_U_$G(OUTOI) - S ^TMP("PS",$J,"DD",0)=CNT - Q - ; -IVTMP ;*** Set ^TMP for IV orders. - N PROVIDER,RNWDT,IVLIM S ND0=$G(@(F_+ON_",0)")),CNT=0 - F X=0:0 S X=$O(@(F_+ON_",""AD"","_X_")")) Q:'X S ND=$G(@(F_+ON_",""AD"","_X_",0)")),DN=$P($G(^PS(52.6,+ND,0)),U),Y=DN_U_$P(ND,U,2) S:$P(ND,U,3) Y=Y_U_$P(ND,U,3) S CNT=CNT+1,^TMP("PS",$J,"A",CNT,0)=Y - S RNWDT=$$LASTREN^PSJLMPRI(DFN,ON) I RNWDT S RNWDT=+RNWDT - S ^TMP("PS",$J,"A",0)=CNT,CNT=0 - F X=0:0 S X=$O(@(F_+ON_",""SOL"","_X_")")) Q:'X S ND=$G(@(F_+ON_",""SOL"","_X_",0)")),DN=$G(^PS(52.7,+ND,0)),CNT=CNT+1,^TMP("PS",$J,"B",CNT,0)=$P(DN,U)_U_$P(ND,U,2)_U_$P(DN,U,4) - S ^TMP("PS",$J,"B",0)=CNT - S INST=$G(@(F_+ON_",.3)")) - I ON["P" D - . S SCH=$P($G(^PS(53.1,+ON,2)),U) - . S PROVIDER=$P(ND0,U,2) - . S MR=$$MR(+$P(ND0,U,3)),STAT=$$CODES^PSIVUTL($P(ND0,U,9),53.1,28) - . S INFUS=$P($G(^PS(53.1,+ON,8)),U,5) - . S ND2=$G(@(F_+ON_",2)")),START=$P(ND2,U,2),STOP=$P(ND2,U,4) - . S ADM=$P(ND2,U,5),SIO=$P($G(@(F_+ON_",6)")),"^") - . S ND2P5=$G(@(F_+ON_",2.5)")) S IVLIM=$P(ND2P5,U,4) I $E(IVLIM)="a" S IVLIM="doses"_$P(IVLIM,"a",2) - . I IVLIM="" S IVLIM=$P(ND2P5,U,2) S:(IVLIM'["d")&(IVLIM'["h") IVLIM="" - I ON'["P" D - . S PROVIDER=$P(ND0,U,6) - . S SCH=$P(ND0,U,9),INFUS=$P(ND0,U,8),STAT=$$CODES^PSIVUTL($P(ND0,U,17),55.01,100) - . S MR=$$MR(+$P($G(^PS(55,DFN,"IV",+ON,.2)),U,3)) - . S START=$P(ND0,U,2),STOP=$P(ND0,U,3) - . S ADM=$P(ND0,U,11),SIO=$P($G(@(F_+ON_",3)")),"^") - . NEW VERPHARM S VERPHARM=$P($G(^PS(55,DFN,"IV",+ON,4)),U,4) - . S:+VERPHARM $P(^TMP("PS",$J,"RXN",0),U,5)=VERPHARM - . S ND2P5=$G(@(F_+ON_",2.5)")) S IVLIM=$P(ND2P5,U,4) I IVLIM="" S IVLIM=$P(ND2P5,U,2) S:(IVLIM'["d")&(IVLIM'["h") IVLIM="" - S DN=$G(@(F_+ON_",.2)")),DO=$P(DN,U,2) - S DN=$S(+$P(DN,U):$$OIDF^PSJLMUT1($P(DN,U)),1:"") - S ^TMP("PS",$J,0)=DN_U_INFUS_U_STOP_"^^"_START_U_STAT_"^^^"_DO_"^^"_$P(ND0,U,21)_U_U_U_($P(ND0,U,9)="P"&($P(ND0,U,24)="R"))_U_U_$G(RNWDT) - I PROVIDER S ^TMP("PS",$J,"P",0)=PROVIDER_"^"_$P($G(^VA(200,PROVIDER,0)),"^") - S ^TMP("PS",$J,"MDR",0)=MR]"" S:MR]"" ^TMP("PS",$J,"MDR",1,0)=MR - S ^TMP("PS",$J,"SCH",0)=SCH]"" S:SCH]"" ^TMP("PS",$J,"SCH",1,0)=SCH - I ON["P" S:$P(ND0,U,7)]"" ^TMP("PS",$J,"SCH",0)=1,$P(^TMP("PS",$J,"SCH",1,0),U,2)=$$GTSCHT($P(ND0,U,7))_"^"_$P(ND0,U,7) - S ^TMP("PS",$J,"SIG",0)=INST]"" S:INST]"" ^TMP("PS",$J,"SIG",1,0)=INST - S ^TMP("PS",$J,"ADM",0)=ADM]"" S:ADM]"" ^TMP("PS",$J,"ADM",1,0)=ADM - S ^TMP("PS",$J,"SIO",0)=SIO]"" S:SIO]"" ^TMP("PS",$J,"SIO",1,0)=SIO - I $G(IVLIM)]"" S ^TMP("PS",$J,"IVLIM",0)=$G(IVLIM) - Q - ; -MR(X) ;RETURN MED ROUTE ABBR. IF THE ABBR="" RETURN MED ROUTE'S NAME. - S X=$G(^PS(51.2,X,0)) - Q $S($P(X,U,3)]"":$P(X,U,3),1:$P(X,U)) - ; -GTSTAT(X) ; - Q $S(X="A":"ACTIVE",X="D":"DISCONTINUED",X="I":"INCOMPLETE",X="N":"NON-VERFIED",X="U":"UNRELEASED",X="P":"PENDING",X="DE":"DISCONTINUED (EDIT)",X="O":"ON CALL",1:"NOT FOUND") - ; -VA200(X) ;Return the IEN for the user. - ; X = User name - NEW DIC,Y S DIC="^VA(200,",DIC(0)="NZ" D ^DIC - I +Y=-1 Q "" - Q $P(Y,U) -GTSCHT(X) ; - Q $S(X="C":"CONTINUOUS",X="O":"ONE TIME",X="P":"PRN",X="R":"FILL ON REQUEST",X="OC":"ON CALL",1:"NOT FOUND") +PSJORRE1 ;BIR/MV-RETURN INPATIENT ACTIVE MEDS (EXPANDED) ;29 Jan 99 / 8:49 AM + ;;5.0; INPATIENT MEDICATIONS ;**22,51,50,58,81,91,110,111**;16 DEC 97 + ; + ; Reference to ^PS(51.2 is supported by DBIA 2178. + ; Reference to ^PS(52.6 is supported by DBIA 1231. + ; Reference to ^PS(52.7 is supported by DBIA 2173. + ; Reference to ^PS(55 is supported by DBIA 2191. + ; Reference to ^PSDRUG is supported by DBIA 2192. + ; Reference to OTF^OR3CONV is supported by DBIA 2412. + ; Reference to ^TMP("PS" is documented in DBIA #2384. + ; +OEL(DFN,ON) ; return list of expanded inpat meds + K ^TMP("PS",$J) + N ADM,CNT,DN,DO,F,INFUS,INST,MR,ND,ND0,ND2,ND2P5,ND6,NDOI,SCH,SIO,START,STAT,STOP,TYP,UNITS,X,Y + ;Check if 5.0 order conversion should be run for the selected patient. + ;I '$P($G(^PS(55,DFN,5.1)),U,11) D CONVERT^PSJUTL1(DFN,0) + F S X=$$OTF^OR3CONV(DFN,$S($E(IOST,1)="C":0,1:1)) Q:+X'<0 D + .I +X=-1 H 3 + S F=$S(ON["P":"^PS(53.1,",ON["U":"^PS(55,DFN,5,",1:"^PS(55,"_DFN_",""IV"",") + I ON'["P",'$D(@(F_+ON_")")) Q + I ON["P" S X=$G(^PS(53.1,+ON,0)) Q:$P(X,U,15)'=DFN S TYP=$P(X,U,4) D @$S(TYP="U":"UDTMP",1:"IVTMP") + D:ON'["P" @$S(ON["U":"UDTMP",1:"IVTMP") + S Y=$S(ON["V":5,1:12),CNT=0 + I $O(@(F_+ON_","_Y_",0)")) D + . F X=0:0 S X=$O(@(F_+ON_","_Y_","_X_")")) Q:'X D + ..S CNT=CNT+1,ND=$G(@(F_+ON_","_Y_","_X_",0)")),^TMP("PS",$J,"PC",CNT,0)=ND + S ^TMP("PS",$J,"PC",0)=CNT + Q + ; +UDTMP ;*** Set ^TMP for Unit dose orders. + N DO,DN,INST,X,Y,PROVIDER,NOTGIVEN,RNWDT + S (MR,SCH,INST)="" + S ND2=$G(@(F_+ON_",2)")),ND0=$G(@(F_+ON_",0)")) + S ND6=$P($G(@(F_+ON_",6)")),"^") + S RNWDT=$$LASTREN^PSJLMPRI(DFN,ON) I RNWDT S RNWDT=+RNWDT + S STAT=$$CODES^PSIVUTL($P(ND0,U,9),$S(ON["P":53.1,1:55.06),28) + D DRGDISP^PSJLMUT1(DFN,ON,40,0,.DN,1) + S NDOI=$G(@(F_+ON_",.2)")),DO=$P(NDOI,U,2) + ;S UNITS="" I '$O(@(F_+ON_",1,1)")),DO="" S UNITS=$P($G(@(F_+ON_",1,1,0)")),U,2) + S UNITS="" I '$O(@(F_+ON_",1,1)")) S UNITS=$P($G(@(F_+ON_",1,1,0)")),U,2) S:(ON["U")&(UNITS="") UNITS=1 + S MR=$$MR(+$P(ND0,U,3)),INST=$G(@(F_+ON_",.3)")) + S NOTGIVEN=$S(ON["U":$P($G(^PS(55,DFN,5,+ON,0)),"^",22),1:"") + S ^TMP("PS",$J,0)=DN(1)_"^^"_$P(ND2,U,4)_"^^"_$P(ND2,U,2)_U_STAT_"^^^"_DO_U_UNITS_U_$P(ND0,U,21)_U_U_NOTGIVEN_U_($P(ND0,U,9)="P"&($P(ND0,U,24)="R"))_U_U_$G(RNWDT) + ;S ^TMP("PS",$J,0)=DN(1)_"^^"_$P(ND2,U,4)_"^^"_$P(ND2,U,2)_U_STAT_"^^^"_DO_U_UNITS_U_$P(ND0,U,21)_U_U_$P($G(^PS(55,DFN,5,+ON,0)),"^",22)_U_($P(ND0,U,9)="P"&($P(ND0,U,24)="R")) + S PROVIDER=$P($G(@(F_+ON_",0)")),"^",2) + I PROVIDER S ^TMP("PS",$J,"P",0)=PROVIDER_"^"_$P($G(^VA(200,PROVIDER,0)),"^") + S ^TMP("PS",$J,"MDR",0)=MR]"" S:MR]"" ^TMP("PS",$J,"MDR",1,0)=MR + S ^TMP("PS",$J,"SCH",0)=$P(ND2,U)]"" S:$P(ND2,U)]"" ^TMP("PS",$J,"SCH",1,0)=$P(ND2,U) + S:$P(ND0,U,7)]"" ^TMP("PS",$J,"SCH",0)=1,$P(^TMP("PS",$J,"SCH",1,0),U,2)=$$GTSCHT($P(ND0,U,7))_"^"_$P(ND0,U,7) + S ^TMP("PS",$J,"SIG",0)=INST]"" S:INST]"" ^TMP("PS",$J,"SIG",1,0)=INST + S ^TMP("PS",$J,"ADM",0)=$P(ND2,U,5)]"" S:$P(ND2,U,5)]"" ^TMP("PS",$J,"ADM",1,0)=$P(ND2,U,5) + S ^TMP("PS",$J,"SIO",0)=ND6]"" S:ND6]"" ^TMP("PS",$J,"SIO",1,0)=ND6 + NEW VERPHARM S:ON["U" VERPHARM=$P($G(@(F_+ON_",4)")),U,3) + S:+$G(VERPHARM) $P(^TMP("PS",$J,"RXN",0),U,5)=VERPHARM + NEW PSJDD,INACTDT,NDDD,OUTOI,PSJOUT S CNT=0 + F PSJDD=0:0 S PSJDD=$O(@(F_+ON_",1,PSJDD)")) Q:'PSJDD D + . S NDDD=@(F_+ON_",1,PSJDD,0)") + . I $P(NDDD,U,3)]"",($P(NDDD,U,3)'>DT) Q + . S PSJOUT=$P($G(^PSDRUG(+NDDD,8)),U,5) + . I +PSJOUT D + .. S INACTDT=$G(^PSDRUG(+PSJOUT,"I")),OUTOI=+$G(^PSDRUG(+PSJOUT,2)) + .. I INACTDT]"",(INACTDT'>DT) S (PSJOUT,OUTOI)="" + . I '+PSJOUT,($P($G(^PSDRUG(+NDDD,2)),U,3)["O") D + .. S PSJOUT=+NDDD,OUTOI=+NDOI + .. S INACTDT=$G(^PSDRUG(+NDDD,"I")) + .. I INACTDT]"",(INACTDT'>DT) S (PSJOUT,OUTOI)="" + . ;* S UNITS=$S('+$P(NDDD,U,2):1,1:$P(NDDD,U,2)) + . S UNITS=$P(NDDD,U,2) S:(ON["U")&(UNITS="") UNITS=1 + . S CNT=CNT+1,^TMP("PS",$J,"DD",CNT,0)=+NDDD_U_UNITS_U_PSJOUT_U_$G(OUTOI) + S ^TMP("PS",$J,"DD",0)=CNT + Q + ; +IVTMP ;*** Set ^TMP for IV orders. + N PROVIDER,RNWDT,IVLIM S ND0=$G(@(F_+ON_",0)")),CNT=0 + F X=0:0 S X=$O(@(F_+ON_",""AD"","_X_")")) Q:'X S ND=$G(@(F_+ON_",""AD"","_X_",0)")),DN=$P($G(^PS(52.6,+ND,0)),U),Y=DN_U_$P(ND,U,2) S:$P(ND,U,3) Y=Y_U_$P(ND,U,3) S CNT=CNT+1,^TMP("PS",$J,"A",CNT,0)=Y + S RNWDT=$$LASTREN^PSJLMPRI(DFN,ON) I RNWDT S RNWDT=+RNWDT + S ^TMP("PS",$J,"A",0)=CNT,CNT=0 + F X=0:0 S X=$O(@(F_+ON_",""SOL"","_X_")")) Q:'X S ND=$G(@(F_+ON_",""SOL"","_X_",0)")),DN=$G(^PS(52.7,+ND,0)),CNT=CNT+1,^TMP("PS",$J,"B",CNT,0)=$P(DN,U)_U_$P(ND,U,2)_U_$P(DN,U,4) + S ^TMP("PS",$J,"B",0)=CNT + S INST=$G(@(F_+ON_",.3)")) + I ON["P" D + . S SCH=$P($G(^PS(53.1,+ON,2)),U) + . S PROVIDER=$P(ND0,U,2) + . S MR=$$MR(+$P(ND0,U,3)),STAT=$$CODES^PSIVUTL($P(ND0,U,9),53.1,28) + . S INFUS=$P($G(^PS(53.1,+ON,8)),U,5) + . S ND2=$G(@(F_+ON_",2)")),START=$P(ND2,U,2),STOP=$P(ND2,U,4) + . S ADM=$P(ND2,U,5),SIO=$P($G(@(F_+ON_",6)")),"^") + . S ND2P5=$G(@(F_+ON_",2.5)")) S IVLIM=$P(ND2P5,U,4) I IVLIM="" S IVLIM=$P(ND2P5,U,2) S:(IVLIM'["d")&(IVLIM'["h") IVLIM="" + I ON'["P" D + . S PROVIDER=$P(ND0,U,6) + . S SCH=$P(ND0,U,9),INFUS=$P(ND0,U,8),STAT=$$CODES^PSIVUTL($P(ND0,U,17),55.01,100) + . S MR=$$MR(+$P($G(^PS(55,DFN,"IV",+ON,.2)),U,3)) + . S START=$P(ND0,U,2),STOP=$P(ND0,U,3) + . S ADM=$P(ND0,U,11),SIO=$P($G(@(F_+ON_",3)")),"^") + . NEW VERPHARM S VERPHARM=$P($G(^PS(55,DFN,"IV",+ON,4)),U,4) + . S:+VERPHARM $P(^TMP("PS",$J,"RXN",0),U,5)=VERPHARM + . S ND2P5=$G(@(F_+ON_",2.5)")) S IVLIM=$P(ND2P5,U,4) I IVLIM="" S IVLIM=$P(ND2P5,U,2) S:(IVLIM'["d")&(IVLIM'["h") IVLIM="" + S DN=$G(@(F_+ON_",.2)")),DO=$P(DN,U,2) + S DN=$S(+$P(DN,U):$$OIDF^PSJLMUT1($P(DN,U)),1:"") + S ^TMP("PS",$J,0)=DN_U_INFUS_U_STOP_"^^"_START_U_STAT_"^^^"_DO_"^^"_$P(ND0,U,21)_U_U_U_($P(ND0,U,9)="P"&($P(ND0,U,24)="R"))_U_U_$G(RNWDT) + ;*S PROVIDER=$P($G(@(F_+ON_",0)")),"^",6) + I PROVIDER S ^TMP("PS",$J,"P",0)=PROVIDER_"^"_$P($G(^VA(200,PROVIDER,0)),"^") + S ^TMP("PS",$J,"MDR",0)=MR]"" S:MR]"" ^TMP("PS",$J,"MDR",1,0)=MR + S ^TMP("PS",$J,"SCH",0)=SCH]"" S:SCH]"" ^TMP("PS",$J,"SCH",1,0)=SCH + I ON["P" S:$P(ND0,U,7)]"" ^TMP("PS",$J,"SCH",0)=1,$P(^TMP("PS",$J,"SCH",1,0),U,2)=$$GTSCHT($P(ND0,U,7))_"^"_$P(ND0,U,7) + S ^TMP("PS",$J,"SIG",0)=INST]"" S:INST]"" ^TMP("PS",$J,"SIG",1,0)=INST + S ^TMP("PS",$J,"ADM",0)=ADM]"" S:ADM]"" ^TMP("PS",$J,"ADM",1,0)=ADM + S ^TMP("PS",$J,"SIO",0)=SIO]"" S:SIO]"" ^TMP("PS",$J,"SIO",1,0)=SIO + I $G(IVLIM)]"" S ^TMP("PS",$J,"IVLIM",0)=$G(IVLIM) + Q + ; +MR(X) ;RETURN MED ROUTE ABBR. IF THE ABBR="" RETURN MED ROUTE'S NAME. + S X=$G(^PS(51.2,X,0)) + Q $S($P(X,U,3)]"":$P(X,U,3),1:$P(X,U)) + ; +GTSTAT(X) ; + Q $S(X="A":"ACTIVE",X="D":"DISCONTINUED",X="I":"INCOMPLETE",X="N":"NON-VERFIED",X="U":"UNRELEASED",X="P":"PENDING",X="DE":"DISCONTINUED (EDIT)",X="O":"ON CALL",1:"NOT FOUND") + ; +VA200(X) ;Return the IEN for the user. + ; X = User name + NEW DIC,Y S DIC="^VA(200,",DIC(0)="NZ" D ^DIC + I +Y=-1 Q "" + Q $P(Y,U) +GTSCHT(X) ; + Q $S(X="C":"CONTINUOUS",X="O":"ONE TIME",X="P":"PRN",X="R":"FILL ON REQUEST",X="OC":"ON CALL",1:"NOT FOUND") diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJORREN.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJORREN.m index 28a98c29..0ea0b04c 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJORREN.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJORREN.m @@ -1,86 +1,86 @@ -PSJORREN ;BIR/MV-RENEWAL FLAG ;6 DEC 00 / 3:11 PM - ;;5.0; INPATIENT MEDICATIONS ;**50,70,58,89,91,110,127,134**;16 DEC 97;Build 124 - ; - ; Reference to ^PS(50.7 supported by DBIA #2180 - ; References to ^PS(52.6 supported by DBIA #1231 - ; References to ^PS(52.7 supported by DBIA #2173 - ; References to ^PS(55 supported by DBIA #2191 - ; Reference to ^PSDRUG( is supported by DBIA 2192 - ; -ACTIVE(DFN,ON) ; - ;DFN: Patient IEN - ;ON : Order number_"U/V/P" - ;Output: 0^reason not renewable (Can't renew) - ; 2^New OI (Need to create a new order as in edit) - ; note: with PSJ*5*70 - instead of 2, IV order will return 0 - ; 1 (OK to renew) - NEW PSJRT,PSJEXP - I '$D(^PS(53.1,+ON))&'$D(^PS(55,+DFN,5,+ON,0))&'$D(^PS(55,+DFN,"IV",+ON,0)) S PSJRT="0^Invalid Package Reference" Q $G(PSJRT) - D:ON["U" UD - D:ON["V" IV - I (+$G(PSJRT)=1) S PSJEXP=$$EXPIRED^PSGOER(DFN,ON) I PSJEXP S PSJRT="0^Expired Time Limit Exceeded" - Q $G(PSJRT) -UD ; - ;If both PSJRT(2) & (3) existed it meant order has multiple DDs and one - ;is tied to a different OI. It's best to not allow renewal of the order. - ; - NEW PSJDD,PSJDDOI,PSJDDX,PSJACT,PSJOI,PSJOIACT,PSJUSE,PSJPRI,X,ND2 - K PSJRT - S PSJOI=+^PS(55,DFN,5,+ON,.2) - S PSJPRI=$P(^PS(55,DFN,5,+ON,.2),"^",4) - I PSJPRI="D" S PSJRT="0^Orders with a Done priority may not be renewed" Q - S ND0=$G(^PS(55,DFN,5,+ON,0)) I $P(ND0,"^",7)="O" S PSJRT="0^One Time orders may not be renewed" Q - N PSJCANT,PSJDAD,NDP2,PSJORKID,PSJKID S NDP2=$G(^PS(55,DFN,5,+ON,.2)),PSJDAD=$P(NDP2,"^",8) I PSJDAD D - .S PSJORKID="" F S PSJORKID=$O(^PS(55,"ACX",PSJDAD,PSJORKID)) Q:'PSJORKID!$G(PSJCANT) S PSJKID="" F S PSJKID=$O(^PS(55,"ACX",PSJDAD,PSJORKID,PSJKID)) Q:'PSJKID!$G(PSJCANT) D - ..S ND0=$G(^PS(55,DFN,5,+PSJKID,2)) I $P(ND0,"^",7)="O" S PSJRT="0^Complex Orders with One-Time doses may not be renewed",PSJCANT=1 - Q:$G(PSJCANT) - F PSJDD=0:0 S PSJDD=$O(^PS(55,DFN,5,+ON,1,PSJDD)) Q:('PSJDD!$D(PSJRT(1))) D - . S (PSJACT,PSJOIACT)=0 S PSJDDX=^PS(55,DFN,5,+ON,1,PSJDD,0) - . S X=$P(PSJDDX,U,3) I X]"",(X'>DT) S PSJACT=1 - . S X=$G(^PSDRUG(+PSJDDX,"I")) I X]"",(X'>DT) S PSJACT=1 - . S X=$G(^PSDRUG(+PSJDDX,2)),PSJUSE=$P(X,U,3)["U",PSJDDOI=+X I '+PSJDDOI S PSJRT(3)="0^Dispense drug is not matched to an Orderable Item" Q - . S X=$P($G(^PS(50.7,+PSJDDOI,0)),U,4) I X]"",(X'>DT) S PSJOIACT=1 - . I 'PSJACT,PSJUSE D Q - .. I PSJOI=PSJDDOI D Q - ... I 'PSJOIACT S PSJRT(1)=1 Q - ... S:PSJOIACT PSJRT(3)="0^Inactive Orderable Item" - .. I +PSJDDOI,(PSJOI'=PSJDDOI) D - ... S:'PSJOIACT PSJRT(2)="2"_U_PSJDDOI - ... S:PSJOIACT PSJRT(3)="0^Dispense drug ties to an inactive Orderable Item" - . I PSJACT S PSJRT(3)="0^This drug has been Inactivated" - . I 'PSJUSE S PSJRT(3)="0^Drug is No longer used in Inpatient Meds" - I $D(PSJRT(1)) S PSJRT=1 Q - I $D(PSJRT(2)),$D(PSJRT(3)) S PSJRT=PSJRT(3) Q - I '$D(PSJRT) S PSJRT="0^Order has no Dispense drug" Q - S X=$O(PSJRT(0)),PSJRT=$G(PSJRT(X)) - Q -IV ; - NEW FIL,PSJACT,PSJAS,PSJASNO,PSJASOI,PSJCNT,PSJIEN,PSJOI,PSJOIACT,PSJPRI,X - K PSJRT - S PSJCNT=0 - S PSJOI=+$G(^PS(55,DFN,"IV",+ON,.2)) - S PSJPRI=$P(^PS(55,DFN,"IV",+ON,.2),"^",4) - I PSJPRI="D" S PSJRT="0^Orders with a Done priority may not be renewed" Q - N ND2,PSBACT,IVSCHED - S ND0=$G(^PS(55,DFN,"IV",+ON,0)) I ($P(ND0,"^",4)="P")!($P(ND0,"^",23)="P")!$P(ND0,"^",5) D Q:$G(PSJRT)]"" - .N X,PSGOES,ZZND S PSGOES=2,X=$P(ND0,"^",9) D ENOS^PSGS0 Q:($G(X)="")!($P($G(ZZND),"^",5)'="O") - .S PSJRT="0^This One-Time order may not be renewed" - F FIL="AD","SOL" F PSJAS=0:0 S PSJAS=$O(^PS(55,DFN,"IV",+ON,FIL,PSJAS)) Q:'PSJAS D - . S (PSJACT,PSJOIACT)=0 - . S PSJASNO=$S(FIL="AD":52.6,1:52.7) - . S PSJIEN=+^PS(55,DFN,"IV",+ON,FIL,PSJAS,0) - . S X=$G(^PS(PSJASNO,+PSJIEN,"I")) I X]"",(X'>DT) S PSJACT=1 - . S PSJASOI=$P(^PS(PSJASNO,PSJIEN,0),U,11) - . S X=$P($G(^PS(50.7,+PSJASOI,0)),U,4) I X]"",(X'>DT) S PSJOIACT=1 - . I PSJACT S PSJCNT=PSJCNT+1,PSJRT(3)="0^Inactive "_$S(FIL="AD":"Additive",1:"Solution") Q - . I PSJOI=PSJASOI D Q - .. I 'PSJOIACT S PSJRT(1)="" Q - .. I PSJOIACT S PSJRT(3)="0^Inactive Orderable Item" - . I PSJOI'=PSJASOI D - .. I 'PSJOIACT S PSJCNT=PSJCNT+1,PSJRT(2)=2_U_PSJASOI - .. I PSJOIACT S PSJRT(3)="0^Inactive Orderable Item" - I $D(PSJRT(1)) S PSJRT=1 Q - I $D(PSJRT(3)) S PSJRT=PSJRT(3) Q - I $D(PSJRT(2)),PSJCNT=1 S PSJRT="0^New Orderable Item" Q - S PSJRT="0^Inactive drug" - Q +PSJORREN ;BIR/MV-RENEWAL FLAG ;6 DEC 00 / 3:11 PM + ;;5.0; INPATIENT MEDICATIONS ;**50,70,58,89,91,110,127**;16 DEC 97 + ; + ; Reference to ^PS(50.7 supported by DBIA #2180 + ; References to ^PS(52.6 supported by DBIA #1231 + ; References to ^PS(52.7 supported by DBIA #2173 + ; References to ^PS(55 supported by DBIA #2191 + ; Reference to ^PSDRUG( is supported by DBIA 2192 + ; +ACTIVE(DFN,ON) ; + ;DFN: Patient IEN + ;ON : Order number_"U/V/P" + ;Output: 0^reason not renewable (Can't renew) + ; 2^New OI (Need to create a new order as in edit) + ; note: with PSJ*5*70 - instead of 2, IV order will return 0 + ; 1 (OK to renew) + NEW PSJRT,PSJEXP + D:ON["U" UD + D:ON["V" IV + I (+$G(PSJRT)=1) S PSJEXP=$$EXPIRED^PSGOER(DFN,ON) I PSJEXP S PSJRT="0^Expired Time Limit Exceeded" + Q $G(PSJRT) +UD ; + ;If both PSJRT(2) & (3) existed it meant order has multiple DDs and one + ;is tied to a different OI. It's best to not allow renewal of the order. + ; + NEW PSJDD,PSJDDOI,PSJDDX,PSJACT,PSJOI,PSJOIACT,PSJUSE,PSJPRI,X,ND2 + K PSJRT + S PSJOI=+^PS(55,DFN,5,+ON,.2) + S PSJPRI=$P(^PS(55,DFN,5,+ON,.2),"^",4) + I PSJPRI="D" S PSJRT="0^Orders with a Done priority may not be renewed" Q + S ND0=$G(^PS(55,DFN,5,+ON,0)) I $P(ND0,"^",7)="O" S PSJRT="0^One Time orders may not be renewed" Q + N PSJCANT,PSJDAD,NDP2,PSJORKID,PSJKID S NDP2=$G(^PS(55,DFN,5,+ON,.2)),PSJDAD=$P(NDP2,"^",8) I PSJDAD D + .S PSJORKID="" F S PSJORKID=$O(^PS(55,"ACX",PSJDAD,PSJORKID)) Q:'PSJORKID!$G(PSJCANT) S PSJKID="" F S PSJKID=$O(^PS(55,"ACX",PSJDAD,PSJORKID,PSJKID)) Q:'PSJKID!$G(PSJCANT) D + ..S ND0=$G(^PS(55,DFN,5,+PSJKID,2)) I $P(ND0,"^",7)="O" S PSJRT="0^Complex Orders with One-Time doses may not be renewed",PSJCANT=1 + Q:$G(PSJCANT) + F PSJDD=0:0 S PSJDD=$O(^PS(55,DFN,5,+ON,1,PSJDD)) Q:('PSJDD!$D(PSJRT(1))) D + . S (PSJACT,PSJOIACT)=0 S PSJDDX=^PS(55,DFN,5,+ON,1,PSJDD,0) + . S X=$P(PSJDDX,U,3) I X]"",(X'>DT) S PSJACT=1 + . S X=$G(^PSDRUG(+PSJDDX,"I")) I X]"",(X'>DT) S PSJACT=1 + . S X=$G(^PSDRUG(+PSJDDX,2)),PSJUSE=$P(X,U,3)["U",PSJDDOI=+X I '+PSJDDOI S PSJRT(3)="0^Dispense drug is not matched to an Orderable Item" Q + . S X=$P($G(^PS(50.7,+PSJDDOI,0)),U,4) I X]"",(X'>DT) S PSJOIACT=1 + . I 'PSJACT,PSJUSE D Q + .. I PSJOI=PSJDDOI D Q + ... I 'PSJOIACT S PSJRT(1)=1 Q + ... S:PSJOIACT PSJRT(3)="0^Inactive Orderable Item" + .. I +PSJDDOI,(PSJOI'=PSJDDOI) D + ... S:'PSJOIACT PSJRT(2)="2"_U_PSJDDOI + ... S:PSJOIACT PSJRT(3)="0^Dispense drug ties to an inactive Orderable Item" + . I PSJACT S PSJRT(3)="0^This drug has been Inactivated" + . I 'PSJUSE S PSJRT(3)="0^Drug is No longer used in Inpatient Meds" + I $D(PSJRT(1)) S PSJRT=1 Q + I $D(PSJRT(2)),$D(PSJRT(3)) S PSJRT=PSJRT(3) Q + I '$D(PSJRT) S PSJRT="0^Order has no Dispense drug" Q + S X=$O(PSJRT(0)),PSJRT=$G(PSJRT(X)) + Q +IV ; + NEW FIL,PSJACT,PSJAS,PSJASNO,PSJASOI,PSJCNT,PSJIEN,PSJOI,PSJOIACT,PSJPRI,X + K PSJRT + S PSJCNT=0 + S PSJOI=+$G(^PS(55,DFN,"IV",+ON,.2)) + S PSJPRI=$P(^PS(55,DFN,"IV",+ON,.2),"^",4) + I PSJPRI="D" S PSJRT="0^Orders with a Done priority may not be renewed" Q + N ND2,PSBACT,IVSCHED + S ND0=$G(^PS(55,DFN,"IV",+ON,0)) I ($P(ND0,"^",4)="P")!($P(ND0,"^",23)="P")!$P(ND0,"^",5) D Q:$G(PSJRT)]"" + .N X,PSGOES,ZZND S PSGOES=2,X=$P(ND0,"^",9) D ENOS^PSGS0 Q:($G(X)="")!($P($G(ZZND),"^",5)'="O") + .S PSJRT="0^This One-Time order may not be renewed" + F FIL="AD","SOL" F PSJAS=0:0 S PSJAS=$O(^PS(55,DFN,"IV",+ON,FIL,PSJAS)) Q:'PSJAS D + . S (PSJACT,PSJOIACT)=0 + . S PSJASNO=$S(FIL="AD":52.6,1:52.7) + . S PSJIEN=+^PS(55,DFN,"IV",+ON,FIL,PSJAS,0) + . S X=$G(^PS(PSJASNO,+PSJIEN,"I")) I X]"",(X'>DT) S PSJACT=1 + . S PSJASOI=$P(^PS(PSJASNO,PSJIEN,0),U,11) + . S X=$P($G(^PS(50.7,+PSJASOI,0)),U,4) I X]"",(X'>DT) S PSJOIACT=1 + . I PSJACT S PSJCNT=PSJCNT+1,PSJRT(3)="0^Inactive "_$S(FIL="AD":"Additive",1:"Solution") Q + . I PSJOI=PSJASOI D Q + .. I 'PSJOIACT S PSJRT(1)="" Q + .. I PSJOIACT S PSJRT(3)="0^Inactive Orderable Item" + . I PSJOI'=PSJASOI D + .. I 'PSJOIACT S PSJCNT=PSJCNT+1,PSJRT(2)=2_U_PSJASOI + .. I PSJOIACT S PSJRT(3)="0^Inactive Orderable Item" + I $D(PSJRT(1)) S PSJRT=1 Q + I $D(PSJRT(3)) S PSJRT=PSJRT(3) Q + ;I $D(PSJRT(2)),PSJCNT=1 S PSJRT=PSJRT(2) Q + I $D(PSJRT(2)),PSJCNT=1 S PSJRT="0^New Orderable Item" Q + S PSJRT="0^Inactive drug" + Q diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJORUT2.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJORUT2.m index 13e640f7..c161a402 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJORUT2.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJORUT2.m @@ -1,144 +1,143 @@ -PSJORUT2 ;BIR/MLM-MISC. PROCEDURE CALLS FOR OE/RR 3.0 (CONT.) ;03 Aug 98 / 8:42 AM - ;;5.0; INPATIENT MEDICATIONS ;**14,29,50,56,58,107,152,134**;16 DEC 97;Build 124 - ; - ; Reference to ^PS(55 is supported by DBIA 2191 - ; Reference to ^PS(50.605 is supported by DBIA 2138,696. - ; References to ^PS(52.6 supported by DBIA 1231 - ; Reference to ^PS(52.7 supported by DBIA 2173. - ; Reference to ^PSDRUG( is supported by DBIA 2192 - ; Reference to ^PSNDF( is supported by DBIA 2195 - ; Reference to ^PSRX( is supported by DBIA 824 - ; Reference to ^PSNAPIS is supported by DBIA 2531 - ; -ENVAC(PN) ; Find VA CLASS of VA Product Name - ;Input: PN - See above - ;Output: VA Drug Class^Classification - ; - ; NEW NDF CALL - N X S X="PSNAPIS" X ^%ZOSF("TEST") I N PSJC,X1,X2 S X1=+$P(PN,"."),X2=+$P(PN,".",2),PSJC=$$DCLASS^PSNAPIS(X1,X2) Q PSJC - ; - N GDP,PNP S GDP=$P(PN,"."),PNP=$P(PN,".",2) - S X=+$P($G(^PSNDF(+GDP,5,+PNP,0)),U,2),X=+$P($G(^PSNDF(GDP,2,X,0)),U,3),PSJC=$P($G(^PS(50.605,X,0)),U,2) - Q $S('X:0,PSJC="":0,1:X_U_PSJC) - ; -ENVAGN(PN) ; Return VA Generic Name for specified VA Product Name. - ;Input: PN - VA Product Name IEN - ;Output: VA Generic Name IEN^VA Generic Name - ; - ; NEW NDF CALL - N X S X="PSNAPIS" X ^%ZOSF("TEST") I N GDP,X1,X2 S X1=+$P(PN,"."),X2=+$P(PN,".",2),GDP=$$VAGN^PSNAPIS(X1) Q $S(GDP=0:0,1:X1_U_GDP) - ; - N GDP,PNP S GDP=+$P(PN,"."),PNP=+$P(PN,".",2) - S X=$P($G(^PSNDF(GDP,0)),U) - Q $S('GDP:0,X="":0,1:GDP_U_X) -ENVOL(PN,ARRAY) ; - I (PN'["A")&(PN'["B") S ARRAY="0" Q - N X,XX,F,INACT,IVFL - S X(1)="ML",X(2)="LITER",X(3)="MCG",X(4)="MG",X(5)="GM",X(6)="UNITS",X(7)="IU",X(8)="MEQ",X(9)="MM",X(10)="MU",X(11)="THOUU",X(12)="MG-PE",X(13)="NANOGRAM",X(14)="MMOL" - I PN["A" N ADD S (ADD,X,XX)=0 F S ADD=$O(^PS(52.6,"AOI",+PN,ADD)) Q:ADD="" D - .S INACT=$G(^PS(52.6,ADD,"I")) I INACT']""!(INACT>DT) S IVFL=$P($G(^(0)),"^",13) Q:'IVFL S XX=XX+1,ARRAY(ADD)="^"_X($P($G(^PS(52.6,ADD,0)),U,3)) Q - I PN["B" N SOL S SOL=0,XX=0 F S SOL=$O(^PS(52.7,"AOI",+PN,SOL)) Q:SOL="" D - .S INACT=$G(^PS(52.7,SOL,"I")) I INACT']""!(INACT>DT) S IVFL=$P($G(^(0)),"^",13) Q:'IVFL S XX=XX+1,ARRAY(SOL)=$P($G(^PS(52.7,SOL,0)),"^",3) - S ARRAY=XX>0 - Q - ; -ENVOL2(PN,ARRAY) ;Only for Med Button IV orders. - I (PN'["A")&(PN'["B") S ARRAY="0" Q - N X,XX,F,INACT - S X(1)="ML",X(2)="LITER",X(3)="MCG",X(4)="MG",X(5)="GM",X(6)="UNITS",X(7)="IU",X(8)="MEQ",X(9)="MM",X(10)="MU",X(11)="THOUU",X(12)="MG-PE",X(13)="NANOGRAM",X(14)="MMOL" - I PN["A" N ADD S (ADD,X,XX)=0 F S ADD=$O(^PS(52.6,"AOI",+PN,ADD)) Q:ADD="" D - .S INACT=$G(^PS(52.6,ADD,"I")) I INACT']""!(INACT>DT) S XX=XX+1,ARRAY(ADD)="^"_X($P($G(^PS(52.6,ADD,0)),U,3)) Q - I PN["B" N SOL S SOL=0,XX=0 F S SOL=$O(^PS(52.7,"AOI",+PN,SOL)) Q:SOL="" D - .S INACT=$G(^PS(52.7,SOL,"I")) I INACT']""!(INACT>DT) S XX=XX+1,ARRAY(SOL)=$P($G(^PS(52.7,SOL,0)),"^",3) - S ARRAY=XX>0 - Q - ; - ; -SENVOL(PN,PSJ) ;Return array listing volume (base only) and volume units for the specified additive or solution. - ;Input: PN - IEN_B (Base) or A (Additive) - ;Output: ARRAY(IEN,A:additive or B:Base)=volume^volume units - ; If no volume or units found PSJ=0; If found PSJ=1. - ; - N X S PSJ=1 - S X(1)="ML",X(2)="LITER",X(3)="MCG",X(4)="MG",X(5)="GM",X(6)="UNITS",X(7)="IU",X(8)="MEQ",X(9)="MM",X(10)="MU",X(11)="THOUU",X(12)="MG-PE",X(13)="NANOGRAM",X(14)="MMOL" - I PN'["A",PN'["B" S PSJ=0 Q - S PSJ=PSJ+1 - I PN["A" S PSJ(+PN,"A")=U_X(+$P($G(^PS(52.6,+PN,0)),U,3)) Q - I PN["B" S PSJ(+PN,"B")=+$P($G(^PS(52.7,+PN,0)),U,3)_U_X(1) Q - Q - ; -ENREF(PRX) ; Return number of refills remaining. - ;Input: PRX - Internal prescription number from File #52. - ;Output: Number of refills remaining. - ; - N X,COUNT,CNT S PRX=$P(PRX,"^"),COUNT=0,X=$P(^PSRX(PRX,0),"^",9) - D:$O(^PSRX(PRX,1,0)) - .F CNT=0:0 S CNT=$O(^PSRX(PRX,1,CNT)) Q:'CNT S COUNT=COUNT+1 - S:$G(COUNT) X=X-COUNT - Q X - ; -ENCHK(DFN,PSJINX) ; Return dispense drug check array. - ;Input: DFN - Patient internal entry number - ; PSJINX - Index number so duplicate drugs will be returned. - ; PSGOCHK - Check should include dispense drugs in 53.45 - ; PSIVOCHK - Check should include entries in DRG array - ;Output: ^TMP($J,"ORDERS",PSJINX)=DRUG CLASS^NATIONAL DRUG FILE ENTRY - ; _"A"_PSNDFA PRODUCT NAME ENTRY_DISPENSE DRUG NAME^OE/RR # - ; _ORDER NUMBER(P/I/V)_";I" - ; - NEW BDT,DDRUG,DDRUG0,DDRUGND,EDT,F,ON,ON1,PST,WBDT,X,PSJORIEN - D NOW^%DTC S (BDT,WBDT)=%,EDT=9999999 - S F="^PS(55,DFN,5," F S WBDT=$O(^PS(55,DFN,5,"AUS",WBDT)) Q:'WBDT F ON=0:0 S ON=$O(^PS(55,DFN,5,"AUS",WBDT,ON)) Q:'ON D UD - S F="^PS(53.1," F PST="P","N" F ON=0:0 S ON=$O(^PS(53.1,"AS",PST,DFN,ON)) Q:'ON D - . I $O(^PS(53.1,+ON,"AD",0))!$O(^PS(53.1,+ON,"SOL",0)) D PIV Q - . D UD - S WBDT=BDT F S WBDT=$O(^PS(55,DFN,"IV","AIS",WBDT)) Q:'WBDT F ON=0:0 S ON=$O(^PS(55,DFN,"IV","AIS",WBDT,ON)) Q:'ON D IV - I '$G(PSIVOCON) D NEWIV ; Don't do this when Finishing orders (FN) - Q -UD ;*** Get the dispense drugs for the Unit Dose orders. - S PSJORIEN=$P(@(F_ON_",0)"),U,21),DDRUG=0 - I F="^PS(53.1,",($P(@(F_ON_",0)"),U,4)="I") D Q - . NEW PSJPD S COD=ON_"P" - . S PSJPD=+$G(^PS(53.1,ON,.2)) D:$D(^PS(52.6,"AOI",PSJPD)) ENDDIV^PSJORUTL(PSJPD,"A","",.DDRUG) S DDRUG=+DDRUG D:DDRUG DDRUG - S ON1=0 F S ON1=$O(@(F_ON_",1,"_ON1_")")) Q:'ON1 S DDRUG=@(F_ON_",1,"_ON1_",0)") I $P(DDRUG,U,3)=""!($P(DDRUG,U,3)>BDT) S COD=ON_$S(F["^PS(53.1":"P",1:"U") D DDRUG - I $D(PSGOCHK) F ON1=0:0 S ON1=$O(^PS(53.45,+PSJSYSP,1,ON1)) Q:'ON1 S DDRUG=$G(^PS(53.45,+PSJSYSP,1,ON1,0)) I $P(DDRUG,U,3)=""!@($P(DDRUG,U,3)>BDT) S (COD,PSJORIEN)="" D DDRUG - I '$O(@(F_ON_",1,"_0_")")) N OI S OI=+$G(@(F_ON_",.2)")) I OI D - .S DDRUG="" F S DDRUG=$O(^PSDRUG("ASP",OI,DDRUG)) Q:'DDRUG D - ..I ($P(DDRUG,U,3)=""!($P(DDRUG,U,3)>BDT)) S COD=ON_$S(F["^PS(53.1":"P",1:"U") D DDRUG - Q -PIV ;*** Get the dispense drugs for the Pending IV orders. - S X=^PS(53.1,+ON,0),PSJORIEN=$P(X,U,21) Q:$P(X,U,27)="R" - S ON1=0 F S ON1=$O(^PS(53.1,+ON,"AD",ON1)) Q:'ON1 S X=+^PS(53.1,+ON,"AD",ON1,0),DDRUG=$P($G(^PS(52.6,X,0)),U,2) S COD=+ON_"P" D DDRUG - S ON1=0 F S ON1=$O(^PS(53.1,+ON,"SOL",ON1)) Q:'ON1 S X=+^PS(53.1,+ON,"SOL",ON1,0),DDRUG=$P($G(^PS(52.7,X,0)),U,2) S COD=+ON_"P" D DDRUG - Q -IV ;*** Get the dispense drugs for the IV orders. - NEW X S X=^PS(55,DFN,"IV",ON,0),PSJORIEN=$P(X,U,21) Q:$P(X,U,17)="R" - S ON1=0 F S ON1=$O(^PS(55,DFN,"IV",ON,"AD",ON1)) Q:'ON1 S X=+^PS(55,DFN,"IV",ON,"AD",ON1,0),DDRUG=$P($G(^PS(52.6,X,0)),U,2) S COD=ON_"V" D DDRUG - S ON1=0 F S ON1=$O(^PS(55,DFN,"IV",ON,"SOL",ON1)) Q:'ON1 S X=+^PS(55,DFN,"IV",ON,"SOL",ON1,0),DDRUG=$P($G(^PS(52.7,X,0)),U,2) S COD=ON_"V" D DDRUG - Q -NEWIV ;*** Get the dispense drugs for the newly entered IV order. - NEW PSIVX,ON - S ON=$O(DRGOC(0)),PSJORIEN="" Q:'+ON - F PSIVX=0:0 S PSIVX=$O(DRGOC(ON,"AD",PSIVX)) Q:'PSIVX S DDRUG=$P(^PS(52.6,+DRGOC(ON,"AD",PSIVX),0),U,2),COD=ON55 D DDRUG - F PSIVX=0:0 S PSIVX=$O(DRGOC(ON,"SOL",PSIVX)) Q:'PSIVX S DDRUG=$P(^PS(52.7,+DRGOC(ON,"SOL",PSIVX),0),U,2),COD=ON D DDRUG - Q -DDRUG ;*** Set PSJ(DDRUG NAME) arrays. - Q:'DDRUG S DDRUG0=$G(^PSDRUG(+DDRUG,0)),DDRUGND=$G(^PSDRUG(+DDRUG,"ND")) - S PSJINX=+$G(PSJINX)+1 ;* ^PSOORDRG calls this entry point. - I $D(DDRUG)=11,DDRUG[";" D Q ; if called from ^PSOORDRG - .N IPOROP S IPOROP=$P(DDRUG,";",2) - .S IPOROP=$S(IPOROP="PSO":";O",IPOROP="PSH":"N;O",1:";I") - .S ^TMP($J,"ORDERS",PSJINX)=$P(DDRUG0,U,2)_U_$P(DDRUGND,U)_"A"_$P(DDRUGND,U,3)_U_$P(DDRUG0,U)_U_$S($G(DDRUG(DDRUG)):DDRUG(DDRUG),1:$G(PSJORIEN))_U_$G(COD)_IPOROP - S ^TMP($J,"ORDERS",PSJINX)=$P(DDRUG0,U,2)_U_$P(DDRUGND,U)_"A"_$P(DDRUGND,U,3)_U_$P(DDRUG0,U)_U_$G(PSJORIEN)_U_$G(COD)_";I" - Q - ; -PRCHK(PSJ) ; Check if authorized to write med orders. - N %,X - D NOW^%DTC S X=$G(^VA(200,PSJ,"PS")) I $S('X:1,'$P(%,"^",4):0,1:$P(X,"^",4)'>%) Q 0 - Q PSJ - ; -ENNG(PSJDPT,PSJNUM) ; returns 1 if order marked "Not To Be Given" - ; 0 if not marked - I '$D(^PS(55,PSJDPT,5,+PSJNUM,0)) Q 0 - I $P($G(^PS(55,PSJDPT,5,+PSJNUM,0)),"^",22)=1 Q 1 - Q 0 +PSJORUT2 ;BIR/MLM-MISC. PROCEDURE CALLS FOR OE/RR 3.0 (CONT.) ;03 Aug 98 / 8:42 AM + ;;5.0; INPATIENT MEDICATIONS ;**14,29,50,56,58,107,152**;16 DEC 97 + ; + ; Reference to ^PS(55 is supported by DBIA 2191 + ; Reference to ^PS(50.605 is supported by DBIA 2138 + ; References to ^PS(52.6 supported by DBIA 1231 + ; Reference to ^PS(52.7 supported by DBIA 2173. + ; Reference to ^PSDRUG( is supported by DBIA 2192 + ; Reference to ^PSNDF( is supported by DBIA 2195 + ; Reference to ^PSRX( is supported by DBIA 824 + ; Reference to ^PSNAPIS is supported by DBIA 2531 + ; +ENVAC(PN) ; Find VA CLASS of VA Product Name + ;Input: PN - See above + ;Output: VA Drug Class^Classification + ; + ; NEW NDF CALL + N X S X="PSNAPIS" X ^%ZOSF("TEST") I N PSJC,X1,X2 S X1=+$P(PN,"."),X2=+$P(PN,".",2),PSJC=$$DCLASS^PSNAPIS(X1,X2) Q PSJC + ; + N GDP,PNP S GDP=$P(PN,"."),PNP=$P(PN,".",2) + S X=+$P($G(^PSNDF(+GDP,5,+PNP,0)),U,2),X=+$P($G(^PSNDF(GDP,2,X,0)),U,3),PSJC=$P($G(^PS(50.605,X,0)),U,2) + Q $S('X:0,PSJC="":0,1:X_U_PSJC) + ; +ENVAGN(PN) ; Return VA Generic Name for specified VA Product Name. + ;Input: PN - VA Product Name IEN + ;Output: VA Generic Name IEN^VA Generic Name + ; + ; NEW NDF CALL + N X S X="PSNAPIS" X ^%ZOSF("TEST") I N GDP,X1,X2 S X1=+$P(PN,"."),X2=+$P(PN,".",2),GDP=$$VAGN^PSNAPIS(X1) Q $S(GDP=0:0,1:X1_U_GDP) + ; + N GDP,PNP S GDP=+$P(PN,"."),PNP=+$P(PN,".",2) + S X=$P($G(^PSNDF(GDP,0)),U) + Q $S('GDP:0,X="":0,1:GDP_U_X) +ENVOL(PN,ARRAY) ; + I (PN'["A")&(PN'["B") S ARRAY="0" Q + N X,XX,F,INACT,IVFL S X(1)="ML",X(2)="LITER",X(3)="MCG",X(4)="MG",X(5)="GM",X(6)="UNITS",X(7)="IU",X(8)="MEQ",X(9)="MM",X(10)="MU",X(11)="THOUU",X(12)="MG-PE",X(13)="NANOGRAM" + I PN["A" N ADD S (ADD,X,XX)=0 F S ADD=$O(^PS(52.6,"AOI",+PN,ADD)) Q:ADD="" D + .S INACT=$G(^PS(52.6,ADD,"I")) I INACT']""!(INACT>DT) S IVFL=$P($G(^(0)),"^",13) Q:'IVFL S XX=XX+1,ARRAY(ADD)="^"_X($P($G(^PS(52.6,ADD,0)),U,3)) Q + I PN["B" N SOL S SOL=0,XX=0 F S SOL=$O(^PS(52.7,"AOI",+PN,SOL)) Q:SOL="" D + .S INACT=$G(^PS(52.7,SOL,"I")) I INACT']""!(INACT>DT) S IVFL=$P($G(^(0)),"^",13) Q:'IVFL S XX=XX+1,ARRAY(SOL)=$P($G(^PS(52.7,SOL,0)),"^",3) + S ARRAY=XX>0 + Q + ; +ENVOL2(PN,ARRAY) ;Only for Med Button IV orders. + I (PN'["A")&(PN'["B") S ARRAY="0" Q + N X,XX,F,INACT S X(1)="ML",X(2)="LITER",X(3)="MCG",X(4)="MG",X(5)="GM",X(6)="UNITS",X(7)="IU",X(8)="MEQ",X(9)="MM",X(10)="MU",X(11)="THOUU",X(12)="MG-PE",X(13)="NANOGRAM" + I PN["A" N ADD S (ADD,X,XX)=0 F S ADD=$O(^PS(52.6,"AOI",+PN,ADD)) Q:ADD="" D + .S INACT=$G(^PS(52.6,ADD,"I")) I INACT']""!(INACT>DT) S XX=XX+1,ARRAY(ADD)="^"_X($P($G(^PS(52.6,ADD,0)),U,3)) Q + I PN["B" N SOL S SOL=0,XX=0 F S SOL=$O(^PS(52.7,"AOI",+PN,SOL)) Q:SOL="" D + .S INACT=$G(^PS(52.7,SOL,"I")) I INACT']""!(INACT>DT) S XX=XX+1,ARRAY(SOL)=$P($G(^PS(52.7,SOL,0)),"^",3) + S ARRAY=XX>0 + Q + ; + ; +SENVOL(PN,PSJ) ;Return array listing volume (base only) and volume units for the specified additive or solution. + ;Input: PN - IEN_B (Base) or A (Additive) + ;Output: ARRAY(IEN,A:additive or B:Base)=volume^volume units + ; If no volume or units found PSJ=0; If found PSJ=1. + ; + N X S PSJ=1,X(1)="ML",X(2)="LITER",X(3)="MCG",X(4)="MG",X(5)="GM",X(6)="UNITS",X(7)="IU",X(8)="MEQ",X(9)="MM",X(10)="MU",X(11)="THOUU",X(12)="MG-PE",X(13)="NANOGRAM" + I PN'["A",PN'["B" S PSJ=0 Q + S PSJ=PSJ+1 + I PN["A" S PSJ(+PN,"A")=U_X(+$P($G(^PS(52.6,+PN,0)),U,3)) Q + I PN["B" S PSJ(+PN,"B")=+$P($G(^PS(52.7,+PN,0)),U,3)_U_X(1) Q + Q + ; +ENREF(PRX) ; Return number of refills remaining. + ;Input: PRX - Internal prescription number from File #52. + ;Output: Number of refills remaining. + ; + N X,COUNT,CNT S PRX=$P(PRX,"^"),COUNT=0,X=$P(^PSRX(PRX,0),"^",9) + D:$O(^PSRX(PRX,1,0)) + .F CNT=0:0 S CNT=$O(^PSRX(PRX,1,CNT)) Q:'CNT S COUNT=COUNT+1 + S:$G(COUNT) X=X-COUNT + Q X + ; +ENCHK(DFN,PSJINX) ; Return dispense drug check array. + ;Input: DFN - Patient internal entry number + ; PSJINX - Index number so duplicate drugs will be returned. + ; PSGOCHK - Check should include dispense drugs in 53.45 + ; PSIVOCHK - Check should include entries in DRG array + ;Output: ^TMP($J,"ORDERS",PSJINX)=DRUG CLASS^NATIONAL DRUG FILE ENTRY + ; _"A"_PSNDFA PRODUCT NAME ENTRY_DISPENSE DRUG NAME^OE/RR # + ; _ORDER NUMBER(P/I/V)_";I" + ; + NEW BDT,DDRUG,DDRUG0,DDRUGND,EDT,F,ON,ON1,PST,WBDT,X,PSJORIEN + ;* S BDT=DT,WBDT=BDT_".000001",EDT=9999999 + D NOW^%DTC S (BDT,WBDT)=%,EDT=9999999 + S F="^PS(55,DFN,5," F S WBDT=$O(^PS(55,DFN,5,"AUS",WBDT)) Q:'WBDT F ON=0:0 S ON=$O(^PS(55,DFN,5,"AUS",WBDT,ON)) Q:'ON D UD + S F="^PS(53.1," F PST="P","N" F ON=0:0 S ON=$O(^PS(53.1,"AS",PST,DFN,ON)) Q:'ON D + . I $O(^PS(53.1,+ON,"AD",0))!$O(^PS(53.1,+ON,"SOL",0)) D PIV Q + . D UD + S WBDT=BDT F S WBDT=$O(^PS(55,DFN,"IV","AIS",WBDT)) Q:'WBDT F ON=0:0 S ON=$O(^PS(55,DFN,"IV","AIS",WBDT,ON)) Q:'ON D IV + I '$G(PSIVOCON) D NEWIV ; Don't do this when Finishing orders (FN) + Q +UD ;*** Get the dispense drugs for the Unit Dose orders. + S PSJORIEN=$P(@(F_ON_",0)"),U,21),DDRUG=0 + I F="^PS(53.1,",($P(@(F_ON_",0)"),U,4)="I") D Q + . NEW PSJPD S COD=ON_"P" + . S PSJPD=+$G(^PS(53.1,ON,.2)) D:$D(^PS(52.6,"AOI",PSJPD)) ENDDIV^PSJORUTL(PSJPD,"A","",.DDRUG) S DDRUG=+DDRUG D:DDRUG DDRUG + S ON1=0 F S ON1=$O(@(F_ON_",1,"_ON1_")")) Q:'ON1 S DDRUG=@(F_ON_",1,"_ON1_",0)") I $P(DDRUG,U,3)=""!($P(DDRUG,U,3)>BDT) S COD=ON_$S(F["^PS(53.1":"P",1:"U") D DDRUG + I $D(PSGOCHK) F ON1=0:0 S ON1=$O(^PS(53.45,+PSJSYSP,1,ON1)) Q:'ON1 S DDRUG=$G(^PS(53.45,+PSJSYSP,1,ON1,0)) I $P(DDRUG,U,3)=""!@($P(DDRUG,U,3)>BDT) S (COD,PSJORIEN)="" D DDRUG + I '$O(@(F_ON_",1,"_0_")")) N OI S OI=+$G(@(F_ON_",.2)")) I OI D + .S DDRUG="" F S DDRUG=$O(^PSDRUG("ASP",OI,DDRUG)) Q:'DDRUG D + ..I ($P(DDRUG,U,3)=""!($P(DDRUG,U,3)>BDT)) S COD=ON_$S(F["^PS(53.1":"P",1:"U") D DDRUG + Q +PIV ;*** Get the dispense drugs for the Pending IV orders. + S X=^PS(53.1,+ON,0),PSJORIEN=$P(X,U,21) Q:$P(X,U,27)="R" + S ON1=0 F S ON1=$O(^PS(53.1,+ON,"AD",ON1)) Q:'ON1 S X=+^PS(53.1,+ON,"AD",ON1,0),DDRUG=$P($G(^PS(52.6,X,0)),U,2) S COD=+ON_"P" D DDRUG + S ON1=0 F S ON1=$O(^PS(53.1,+ON,"SOL",ON1)) Q:'ON1 S X=+^PS(53.1,+ON,"SOL",ON1,0),DDRUG=$P($G(^PS(52.7,X,0)),U,2) S COD=+ON_"P" D DDRUG + Q +IV ;*** Get the dispense drugs for the IV orders. + NEW X S X=^PS(55,DFN,"IV",ON,0),PSJORIEN=$P(X,U,21) Q:$P(X,U,17)="R" + S ON1=0 F S ON1=$O(^PS(55,DFN,"IV",ON,"AD",ON1)) Q:'ON1 S X=+^PS(55,DFN,"IV",ON,"AD",ON1,0),DDRUG=$P($G(^PS(52.6,X,0)),U,2) S COD=ON_"V" D DDRUG + S ON1=0 F S ON1=$O(^PS(55,DFN,"IV",ON,"SOL",ON1)) Q:'ON1 S X=+^PS(55,DFN,"IV",ON,"SOL",ON1,0),DDRUG=$P($G(^PS(52.7,X,0)),U,2) S COD=ON_"V" D DDRUG + ;*D:$G(PSIVNEW) NEWIV + Q +NEWIV ;*** Get the dispense drugs for the newly entered IV order. + NEW PSIVX,ON + S ON=$O(DRGOC(0)),PSJORIEN="" Q:'+ON + F PSIVX=0:0 S PSIVX=$O(DRGOC(ON,"AD",PSIVX)) Q:'PSIVX S DDRUG=$P(^PS(52.6,+DRGOC(ON,"AD",PSIVX),0),U,2),COD=ON55 D DDRUG + F PSIVX=0:0 S PSIVX=$O(DRGOC(ON,"SOL",PSIVX)) Q:'PSIVX S DDRUG=$P(^PS(52.7,+DRGOC(ON,"SOL",PSIVX),0),U,2),COD=ON D DDRUG + Q +DDRUG ;*** Set PSJ(DDRUG NAME) arrays. + Q:'DDRUG S DDRUG0=$G(^PSDRUG(+DDRUG,0)),DDRUGND=$G(^PSDRUG(+DDRUG,"ND")) + S PSJINX=+$G(PSJINX)+1 ;* ^PSOORDRG calls this entry point. + I $D(DDRUG)=11,DDRUG[";" D Q ; if called from ^PSOORDRG + .N IPOROP S IPOROP=$P(DDRUG,";",2) + .S IPOROP=$S(IPOROP="PSO":";O",IPOROP="PSH":"N;O",1:";I") + .S ^TMP($J,"ORDERS",PSJINX)=$P(DDRUG0,U,2)_U_$P(DDRUGND,U)_"A"_$P(DDRUGND,U,3)_U_$P(DDRUG0,U)_U_$S($G(DDRUG(DDRUG)):DDRUG(DDRUG),1:$G(PSJORIEN))_U_$G(COD)_IPOROP + S ^TMP($J,"ORDERS",PSJINX)=$P(DDRUG0,U,2)_U_$P(DDRUGND,U)_"A"_$P(DDRUGND,U,3)_U_$P(DDRUG0,U)_U_$G(PSJORIEN)_U_$G(COD)_";I" + Q + ; +PRCHK(PSJ) ; Check if authorized to write med orders. + N %,X + D NOW^%DTC S X=$G(^VA(200,PSJ,"PS")) I $S('X:1,'$P(%,"^",4):0,1:$P(X,"^",4)'>%) Q 0 + Q PSJ + ; +ENNG(PSJDPT,PSJNUM) ; returns 1 if order marked "Not To Be Given" + ; 0 if not marked + I '$D(^PS(55,PSJDPT,5,+PSJNUM,0)) Q 0 + I $P($G(^PS(55,PSJDPT,5,+PSJNUM,0)),"^",22)=1 Q 1 + Q 0 diff --git a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJUTL.m b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJUTL.m index 67295473..3d58420b 100644 --- a/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJUTL.m +++ b/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJUTL.m @@ -1,212 +1,211 @@ -PSJUTL ;BIR/MLM-MISC. INPATIENT UTILITIES ;17 Mar 98 / 11:05 AM - ;;5.0; INPATIENT MEDICATIONS ;**9,47,58,80,110,136,157,177,134**;16 DEC 97;Build 124 - ; - ; Reference to ^DIC(42 is supported by DBIA 10039. - ; Reference to ^PS(50.7 is supported by DBIA 2180. - ; Reference to ^PSDRUG( is supported by DBIA 2192. - ; Reference to ^DIC is supported by DBIA 10006. - ; Reference to ^DIC1 is supported by DBIA 10007. - ; Reference to ^DIR is supported by DBIA 10026. - ; Reference to ^VALM1 is supported by DBIA 10116. - ; -ENDL ; device look-up - N DA,DIC,DIE,DIX,DO,DR - S DIC="^%ZIS(1,",DIC(0)="EIMZ" D DO^DIC1,^DIC I Y'>0 K X Q - S X=Y(0,0) - Q - ; -ENDH(X) ; device help - N D,XQH,DA,DIC,DIE,DO,DR,DZ - S DIC="^%ZIS(1,",DIC(0)="EIM" D DO^DIC1,^DIC - Q - ; -READ ; hold screen - I $D(IOST) Q:$E(IOST)'="C" - W ! I $D(IOSL),$Y<(IOSL-4) G READ - W !?5,"Press return to continue " R X:$S($D(DTIME):DTIME,1:300) - Q - ; -ENOISC(PSJOI,USAGE) ;Set DIC("S") so that only Orderable Items with at - ;least 1 active dispense drug for the specified usage. - ;Input: PSJOI IEN of Orderable Item selected - ; USAGE - Type of drugs (UD,IV,etc) to be selected - ;Output: 1-At least one dispense drug found - ; 0-None found - N FOUND,PSJ - S PSJ=$P($G(^PS(50.7,+PSJOI,0)),U,4),FOUND=$S('PSJ:1,PSJ>DT:1,1:0) - I FOUND S FOUND=0 F PSJ=0:0 S PSJ=$O(^PSDRUG("ASP",PSJOI,PSJ)) Q:FOUND!'PSJ I $P($G(^PSDRUG(PSJ,2)),U,3)[USAGE,'$G(^("I"))!($G(^("I"))'0 K X Q - S X=$P(Y(0),"^",2) K:$S(X="":1,1:$D(^PS(50.3,PSJ,1,"B",X))) X - Q - ; -ENAQ ; application query - S X=DZ N D,DA,DIC,DIE,DO,DR,DZ,XQH S DIC="^PS(50.35,",DIC(0)="EIMQ" D DO^DIC1,^DIC - Q - ; -ENPC(PSJTYP,PSJSYSP,LEN,TEXT) ; Copy Provider Comments -> Special Instructions. - Q:'$D(^PS(53.1,+$G(PSJORD),12,1,0)) "" - N DIR,PSGSI,PSGOEE,X,Y - S Y="" F X=0:0 S X=$O(^PS(53.1,+$G(PSJORD),12,X)) Q:'X S Y=Y_^(X,0)_" " Q:$L(Y)>LEN - S:$G(PSJTYP)'="V" Y=$$ENSET^PSGSICHK(Y) S:$G(PSJTYP)="V" Y=$E(Y,1,$L(Y)-1) - I $L(Y)'1 W !!,"All Medications (1) may not be selected in combination with other types." K PSJANS Q - .W ?47,$P(PSJANS,",",Q)," - ",$P($T(@$P(PSJANS,",",Q)),";;",2),! - S:$G(PSJANS) X=PSJANS Q $G(PSJANS) - ; -FS ; - I $S(PSJX1?1.N1"-"1.N:0,PSJX1'?1.N:1,'$D(RANGE(PSJX1)):1,1:","_PSJANS[PSJX1) K PSJANS Q - I PSJX1'["-" S PSJANS=PSJANS_PSJX1_"," Q - S PSJX2=+PSJX1,PSJANS=PSJANS_PSJX2_"," - F S PSJX2=$O(RANGE(PSJX2)) K:$S(X="":1,","_PSJANS[PSJX2:1,1:PSJX2>$P(PSJX1,"-",2)) PSJANS Q:'$D(PSJANS) S PSJANS=PSJANS_PSJX2_"," Q:PSJX2=$P(PSJX1,"-",2) - Q - ; -ENMARDH ;Help text for MAR default answer. - W !!?2,"Enter the number corresponding to the type of orders to be included on MARs",!,"printed for this ward. Multiple types (except 1) may be selected using ""-""",!,"or "","" as delimiters.",!!,"Choose from: ",! - N X F X=1:1:6 W !?13,X," - ",$P($T(@X),";;",2) - W ! - Q -1 ;;All Medications -2 ;;Non-IV Medications only -3 ;;IV Piggybacks -4 ;;LVPs -5 ;;TPNs -6 ;;Chemotherapy Medications (IV) - ; -EFD ;The following EFD Tags are used to Calculate the Expected First Dose for backdoor - ;orders. The call to $$ENQ^PSJORP2 is used to actually perform the calculation. - ;The program $$ENQ^PSJORP2 requires the variable INFO to equal the following: - ;BHW;PSJ*5*136 - ; INFO (piece 1) = START DATE/TIME ;PSGNESD (NEW ORDER) - ; INFO (piece 2) = STOP DATE/TIME ;PSGNEFD (NEW ORDER) - ; INFO (piece 3) = SCHEDULE ;PSGSCH (NEW ORDER) - ; INFO (piece 4) = SCHEDULE TYPE ;PSGST (NEW ORDER) - ; INFO (piece 5) = ORDERABLE ITEM ;PSGDRG (NEW ORDER) - ; INFO (piece 6) = ADMIN TIMES ;PSGS0Y (NEW ORDER) - ; -EFDNEW ;Call Here if NEW or RENEWED Order - N INFO - S INFO=($G(PSGNESD))_U_($G(PSGNEFD))_U_($G(PSGSCH))_U_($G(PSGST))_U_($G(PSGDRG))_U_($G(PSGS0Y)) - D EFDDISP - QUIT -EFDACT ;Call here if Editing Fields for an ACTIVE order - ; Field 10 = Start Date - ; Field 34 = Stop Date - ; Field 41 = Admin Times - N INFO,KEY,ORDER,LAST - ;Loop Fields to be edited, in order, and determine when to Display expected first dose message - F KEY=1:1 S ORDER=$P(PSGOEER,";",KEY) Q:'$L(ORDER) I "10^34^41"[$P(ORDER,U,1) S ORDER(KEY)=$P(ORDER,U,1) - ;If there are no entries in ORDER, then were Not Editing Start/Stop or Admin Times - S LAST=$O(ORDER(99),-1) Q:'LAST - ;Only display EFD once, so Quit if this call is not for the Last field in the Edit - S LAST=ORDER(LAST) - I LAST'=PSGF2 Q - S INFO=($G(PSGSD))_U_($G(PSGFD))_U_($G(PSGSCH))_U_($G(PSGST))_U_($G(PSGPDRG))_U_($G(PSGS0Y)) - D EFDDISP - QUIT -EFDNV ;Call here if Editing Fields for a NON-VERIFIED order - ; Field 10 = Start Date - ; Field 25 = Stop Date - ; Field 39 = Admin Times - N INFO,KEY,ORDER,LAST - ;Check if called during finish process - I '$D(PSGOEER) D D EFDDISP Q - . S INFO=($G(PSGNESD))_U_($G(PSGNEFD))_U_($G(PSGSCH))_U_($G(PSGST))_U_($G(PSGPDRG))_U_($G(PSGS0Y)) - . Q - ;Loop Fields to be edited, in order, and determine when to Display expected first dose message - F KEY=1:1 S ORDER=$P(PSGOEER,";",KEY) Q:'$L(ORDER) I "10^25^39"[$P(ORDER,U,1) S ORDER(KEY)=$P(ORDER,U,1) - ;If there are no entries in ORDER, then were Not Editing Start/Stop or Admin Times - S LAST=$O(ORDER(99),-1) Q:'LAST - ;Only display EFD once, so Quit if this call is not for the Last field in the Edit - S LAST=ORDER(LAST) - I LAST'=PSGF2 Q - S INFO=($G(PSGSD))_U_($G(PSGFD))_U_($G(PSGSCH))_U_($G(PSGST))_U_($G(PSGPDRG))_U_($G(PSGS0Y)) - D EFDDISP - QUIT -EFDIV(PSGZZND) ;Set variables for EFD on IV orders. - I $G(PSGZZND)="" D - .N X,ZZND,LYN,PSGS0XT,PSGS0Y,PSGOES S PSGOES=1 S X=P(9) D EN^PSGS0 S:$G(ZZND)'="" PSGZZND=ZZND - S PSGNESD=P(2),PSGNEFD=P(3),PSGSCH=P(9),PSGST=$P($G(PSGZZND),"^",5),PSGDRG=$P($G(P("PD")),"^"),PSGS0Y=P(11) - ;BHW - PSJ*5*177 Add call to check stop date. If it's in the past, Display Message - D CHKSTOP - D EFDNEW - W ! - Q -EFDDISP ;Display Expected First Dose - N Y,Z - Q:$G(PSGST)="OC"!($G(PSGST)="P")!($G(PSGST)="O") - Q:$G(PSGSCH)["ON CALL"!($G(PSGSCH)["ON-CALL")!($G(PSGSCH)["ONCALL") - Q:$G(PSGSCH)["PRN" - I '$L($G(PSGP)) N PSGP S PSGP="" - S Y=$$ENQ^PSJORP2(PSGP,INFO) - I 'Y S Y="Unable to Calculate" - X ^DD("DD") - W !,"Expected First Dose: ",Y H 2 - Q -CHKSTOP ;BHW - PSJ*5*177 Warn user if the Stop Date is < now. - I '+$G(P(3)) Q - N PSNOW,%,%H,%I,X D NOW^%DTC S PSNOW=% - I +P(3)0 K X Q + S X=Y(0,0) + Q + ; +ENDH(X) ; device help + N D,XQH,DA,DIC,DIE,DO,DR,DZ + S DIC="^%ZIS(1,",DIC(0)="EIM" D DO^DIC1,^DIC + Q + ; +READ ; hold screen + I $D(IOST) Q:$E(IOST)'="C" + W ! I $D(IOSL),$Y<(IOSL-4) G READ + W !?5,"Press return to continue " R X:$S($D(DTIME):DTIME,1:300) + Q + ; +ENOISC(PSJOI,USAGE) ;Set DIC("S") so that only Orderable Items with at + ;least 1 active dispense drug for the specified usage. + ;Input: PSJOI IEN of Orderable Item selected + ; USAGE - Type of drugs (UD,IV,etc) to be selected + ;Output: 1-At least one dispense drug found + ; 0-None found + N FOUND,PSJ + S PSJ=$P($G(^PS(50.7,+PSJOI,0)),U,4),FOUND=$S('PSJ:1,PSJ>DT:1,1:0) + I FOUND S FOUND=0 F PSJ=0:0 S PSJ=$O(^PSDRUG("ASP",PSJOI,PSJ)) Q:FOUND!'PSJ I $P($G(^PSDRUG(PSJ,2)),U,3)[USAGE,'$G(^("I"))!($G(^("I"))'0 K X Q + S X=$P(Y(0),"^",2) K:$S(X="":1,1:$D(^PS(50.3,PSJ,1,"B",X))) X + Q + ; +ENAQ ; application query + S X=DZ N D,DA,DIC,DIE,DO,DR,DZ,XQH S DIC="^PS(50.35,",DIC(0)="EIMQ" D DO^DIC1,^DIC + Q + ; +ENPC(PSJTYP,PSJSYSP,LEN,TEXT) ; Copy Provider Comments -> Special Instructions. + Q:'$D(^PS(53.1,+$G(PSJORD),12,1,0)) "" + N DIR,PSGSI,PSGOEE,X,Y + S Y="" F X=0:0 S X=$O(^PS(53.1,+$G(PSJORD),12,X)) Q:'X S Y=Y_^(X,0)_" " Q:$L(Y)>LEN + S:$G(PSJTYP)'="V" Y=$$ENSET^PSGSICHK(Y) S:$G(PSJTYP)="V" Y=$E(Y,1,$L(Y)-1) + I $L(Y)'1 W !!,"All Medications (1) may not be selected in combination with other types." K PSJANS Q + .W ?47,$P(PSJANS,",",Q)," - ",$P($T(@$P(PSJANS,",",Q)),";;",2),! + S:$G(PSJANS) X=PSJANS Q $G(PSJANS) + ; +FS ; + I $S(PSJX1?1.N1"-"1.N:0,PSJX1'?1.N:1,'$D(RANGE(PSJX1)):1,1:","_PSJANS[PSJX1) K PSJANS Q + I PSJX1'["-" S PSJANS=PSJANS_PSJX1_"," Q + S PSJX2=+PSJX1,PSJANS=PSJANS_PSJX2_"," + F S PSJX2=$O(RANGE(PSJX2)) K:$S(X="":1,","_PSJANS[PSJX2:1,1:PSJX2>$P(PSJX1,"-",2)) PSJANS Q:'$D(PSJANS) S PSJANS=PSJANS_PSJX2_"," Q:PSJX2=$P(PSJX1,"-",2) + Q + ; +ENMARDH ;Help text for MAR default answer. + W !!?2,"Enter the number corresponding to the type of orders to be included on MARs",!,"printed for this ward. Multiple types (except 1) may be selected using ""-""",!,"or "","" as delimiters.",!!,"Choose from: ",! + N X F X=1:1:6 W !?13,X," - ",$P($T(@X),";;",2) + W ! + Q +1 ;;All Medications +2 ;;Non-IV Medications only +3 ;;IV Piggybacks +4 ;;LVPs +5 ;;TPNs +6 ;;Chemotherapy Medications (IV) + ; +EFD ;The following EFD Tags are used to Calculate the Expected First Dose for backdoor + ;orders. The call to $$ENQ^PSJORP2 is used to actually perform the calculation. + ;The program $$ENQ^PSJORP2 requires the variable INFO to equal the following: + ;BHW;PSJ*5*136 + ; INFO (piece 1) = START DATE/TIME ;PSGNESD (NEW ORDER) + ; INFO (piece 2) = STOP DATE/TIME ;PSGNEFD (NEW ORDER) + ; INFO (piece 3) = SCHEDULE ;PSGSCH (NEW ORDER) + ; INFO (piece 4) = SCHEDULE TYPE ;PSGST (NEW ORDER) + ; INFO (piece 5) = ORDERABLE ITEM ;PSGDRG (NEW ORDER) + ; INFO (piece 6) = ADMIN TIMES ;PSGS0Y (NEW ORDER) + ; +EFDNEW ;Call Here if NEW or RENEWED Order + N INFO + S INFO=($G(PSGNESD))_U_($G(PSGNEFD))_U_($G(PSGSCH))_U_($G(PSGST))_U_($G(PSGDRG))_U_($G(PSGS0Y)) + D EFDDISP + QUIT +EFDACT ;Call here if Editing Fields for an ACTIVE order + ; Field 10 = Start Date + ; Field 34 = Stop Date + ; Field 41 = Admin Times + N INFO,KEY,ORDER,LAST + ;Loop Fields to be edited, in order, and determine when to Display expected first dose message + F KEY=1:1 S ORDER=$P(PSGOEER,";",KEY) Q:'$L(ORDER) I "10^34^41"[$P(ORDER,U,1) S ORDER(KEY)=$P(ORDER,U,1) + ;If there are no entries in ORDER, then were Not Editing Start/Stop or Admin Times + S LAST=$O(ORDER(99),-1) Q:'LAST + ;Only display EFD once, so Quit if this call is not for the Last field in the Edit + S LAST=ORDER(LAST) + I LAST'=PSGF2 Q + S INFO=($G(PSGSD))_U_($G(PSGFD))_U_($G(PSGSCH))_U_($G(PSGST))_U_($G(PSGPDRG))_U_($G(PSGS0Y)) + D EFDDISP + QUIT +EFDNV ;Call here if Editing Fields for a NON-VERIFIED order + ; Field 10 = Start Date + ; Field 25 = Stop Date + ; Field 39 = Admin Times + N INFO,KEY,ORDER,LAST + ;Check if called during finish process + I '$D(PSGOEER) D D EFDDISP Q + . S INFO=($G(PSGNESD))_U_($G(PSGNEFD))_U_($G(PSGSCH))_U_($G(PSGST))_U_($G(PSGPDRG))_U_($G(PSGS0Y)) + . Q + ;Loop Fields to be edited, in order, and determine when to Display expected first dose message + F KEY=1:1 S ORDER=$P(PSGOEER,";",KEY) Q:'$L(ORDER) I "10^25^39"[$P(ORDER,U,1) S ORDER(KEY)=$P(ORDER,U,1) + ;If there are no entries in ORDER, then were Not Editing Start/Stop or Admin Times + S LAST=$O(ORDER(99),-1) Q:'LAST + ;Only display EFD once, so Quit if this call is not for the Last field in the Edit + S LAST=ORDER(LAST) + I LAST'=PSGF2 Q + S INFO=($G(PSGSD))_U_($G(PSGFD))_U_($G(PSGSCH))_U_($G(PSGST))_U_($G(PSGPDRG))_U_($G(PSGS0Y)) + D EFDDISP + QUIT +EFDIV(PSGZZND) ;Set variables for EFD on IV orders. + S PSGNESD=P(2),PSGNEFD=P(3),PSGSCH=P(9),PSGST=$P($G(PSGZZND),"^",5),PSGDRG=$P($G(P("PD")),"^"),PSGS0Y=P(11) + ;BHW - PSJ*5*177 Add call to check stop date. If it's in the past, Display Message + D CHKSTOP + D EFDNEW + W ! + Q +EFDDISP ;Display Expected First Dose + N Y + Q:$G(PSGST)="OC"!($G(PSGST)="P") + Q:$G(PSGSCH)["ON CALL"!($G(PSGSCH)["ON-CALL")!($G(PSGSCH)["ONCALL") + Q:$G(PSGSCH)["PRN" + I '$L($G(PSGP)) N PSGP S PSGP="" + ; + S Y=$$ENQ^PSJORP2(PSGP,INFO) + I 'Y S Y="Unable to Calculate" + X ^DD("DD") + W !,"Expected First Dose: ",Y H 2 + Q +CHKSTOP ;BHW - PSJ*5*177 Warn user if the Stop Date is < now. + I '+$G(P(3)) Q + N PSNOW,%,%H,%I,X D NOW^%DTC S PSNOW=% + I +P(3)DT) S IBDA="" F S IBDA=$O(^RMPR(660,"CT",IBDT,IBDA)) Q:'IBDA D CHECK - ; - Q - ; -CHECK ; check if transfer pricing and not already added - ; - N IBDATA,IBDATA1,IBDFN - ; - ; already in file - I $O(^IBAT(351.61,"AD",(IBDA_";RMPR(660,"),0)) Q - ; - ; valid tp patient - S IBDATA=$G(^RMPR(660,+IBDA,0)) Q:IBDATA="" S IBDATA1=$G(^RMPR(660,+IBDA,1)) - S IBDFN=$P(IBDATA,"^",2) Q:'IBDFN Q:'$$TPP^IBATUTL(IBDFN) - ; - ; checks from RMPRBIL copied 4/7/2000 with mod for patient type removed - I $S('$D(^RMPR(660,IBDA,"AM")):1,$P(IBDATA,"^",9)="":1,$P(IBDATA,"^",12)="":1,$P(IBDATA1,"^",4)="":1,$P(IBDATA,"^",14)="V":1,$P(IBDATA,"^",15)="*":1,1:0) Q - ; - ; now if inpt, must be in 351.67 - I $P(^RMPR(660,IBDA,"AM"),"^",3)'=1,$P(^("AM"),"^",3)'=4,'$D(^IBAT(351.67,"B",$P(IBDATA1,"^",4))) Q - ; - Q:'$P(IBDATA,"^",16) ; no total cost, at least yet - ; -FILE ; ok transaction needs to be filled in tp files - ; - S IBDATA=$$RMPR^IBATFILE(IBDFN,IBDT,$$PPF^IBATUTL(IBDFN),(IBDA_";RMPR(660,"),,$P(IBDATA,"^",16)) - ; - Q +IBATER ;LL/ELZ - TRANSFER PRICING PROSTHETICS DRIVER ; 7-APR-2000 + ;;2.0;INTEGRATED BILLING;**115**;21-MAR-94 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; + ; This routine is called by the nightly back ground job. It will go + ; through the prosthetics file (660) and look for transfer pricing + ; transactions that it has not previously found. It looks for T-30 + ; through T based upon the delivery date. File 660 - dbia #373 + ; +EN ; + I '$P($G(^IBE(350.9,1,10)),"^",5) Q ; transfer pricing turned off + ; + N IBDT,IBDA + ; + ; date range t-30 to t + S IBDT=$$FMADD^XLFDT(DT,-30) + ; + F S IBDT=$O(^RMPR(660,"CT",IBDT)) Q:'IBDT!(IBDT>DT) S IBDA="" F S IBDA=$O(^RMPR(660,"CT",IBDT,IBDA)) Q:'IBDA D CHECK + ; + Q + ; +CHECK ; check if transfer pricing and not already added + ; + N IBDATA,IBDFN + ; + ; already in file + I $O(^IBAT(351.61,"AD",(IBDA_";RMPR(660,"),0)) Q + ; + ; valid tp patient + S IBDATA=$G(^RMPR(660,+IBDA,0)) Q:IBDATA="" + S IBDFN=$P(IBDATA,"^",2) Q:'IBDFN Q:'$$TPP^IBATUTL(IBDFN) + ; + ; checks from RMPRBIL copied 4/7/2000 with mod for patient type removed + I $S('$D(^RMPR(660,IBDA,"AM")):1,$P(IBDATA,"^",9)="":1,$P(IBDATA,"^",12)="":1,$P(IBDATA,"^",6)="":1,$P(IBDATA,"^",14)="V":1,$P(IBDATA,"^",15)="*":1,1:0) Q + ; + ; now if inpt, must be in 351.67 + I $P(^RMPR(660,IBDA,"AM"),"^",3)'=1,$P(^("AM"),"^",3)'=4,'$D(^IBAT(351.67,"B",$P(IBDATA,"^",6))) Q + ; + Q:'$P(IBDATA,"^",16) ; no total cost, at least yet + ; +FILE ; ok transaction needs to be filled in tp files + ; + S IBDATA=$$RMPR^IBATFILE(IBDFN,IBDT,$$PPF^IBATUTL(IBDFN),(IBDA_";RMPR(660,"),$P(IBDATA,"^",6),$P(IBDATA,"^",16)) + ; + Q diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATFILE.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATFILE.m index b958c65e..a56d054a 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATFILE.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATFILE.m @@ -1,197 +1,197 @@ -IBATFILE ;LL/ELZ - TRANSFER PRICING FILLING ; 22-JAN-1999 - ;;2.0;INTEGRATED BILLING;**115,389**;21-MAR-94;Build 6 - ;;Per VHA Directive 2004-038, this routine should not be modified. -PAT(DA,IBFAC,IBOVER) ; files patient in transfer pricing returns dfn - Q:'$G(DA) 0 - I $D(^IBAT(351.6,DA,0)) Q DA - N DO,DD,DIC,X,DINUM - S DIC="^IBAT(351.6,",DIC(0)="",X=DA,DINUM=DA - S DIC("DR")=".02///"_$$NOW^XLFDT_";.03////"_+$S($G(IBFAC):IBFAC,1:$$PPF^IBATUTL(DA))_";.04///1"_$S($D(IBOVER):";.1////"_+IBOVER,1:"") - D FILE^DICN - Q $S(Y>0:Y,1:0) -UPPPF(DA,PPF) ; updates a patient's enrolled facility - I '$G(DA)!('$G(PPF))!('$D(^IBAT(351.6,DA))) Q - N DIE,DR - S DIE="^IBAT(351.6,",DR=".03////"_+PPF D ^DIE - Q -ADM(DFN,IBADMDT,IBPREF,IBSOURCE) ; - files admissions - ; IBADMDT=admission date, IBPREF=enrolled facility - ; IBSOURCE=source (movement ien;DGPM( - I '$G(DFN)!('$G(IBADMDT))!('$G(IBPREF))!($G(IBSOURCE)="") Q 0 - Q $$NEW(DFN,IBADMDT,IBPREF,IBSOURCE) -DIS(DA,IBDISDT,IBPTF,IBDISM) ; - files discharges - ; DA=transaction ien in 351.61, IBDISDT=discharge date - ; IBPTF=ptf pointer, IBDISM=discharge movement pointer - I '$G(DA)!('$G(IBDISDT))!('$G(IBPTF))!('$G(IBDISM)) Q 0 - N DIE,DR - S DIE="^IBAT(351.61," - S DR=".05////C;.1////"_IBDISDT_";1.07////"_IBPTF_";1.08////"_IBDISM - L +^IBAT(351.61,DA):10 I '$T Q "0^Transaction Locked" - D ^DIE L -^IBAT(351.61,DA) - Q DA -DISC(DA) ; - deletes discharge data - ; DA=transaction ien in 351.61 - N DIE,DR Q:'$G(DA) 0 - S DIE="^IBAT(351.61," - S DR=".05////E;.1///@;1.08///@" - L +^IBAT(351.61,DA):10 I '$T Q "0^Transaction Locked" - D ^DIE L -^IBAT(351.61,DA) - Q DA -INPT(IBIEN,IBDRG,IBDRGA,IBLOS,IBHIGH,IBOUT,IBOUTR) ; - file remaining inpt - ; IBIEN=transaction ien in 351.61, IBDRG=DRG pointer - ; IBDRGA=DRG amount,IBLOS=inpatient LOS,IBHIGH=high trim days - ; IBOUT=outlier days,IBOUTR=outlier rate - I '$G(IBIEN)!('$G(IBLOS))!('$D(IBHIGH))!('$D(IBOUT)) Q 0 - N DIE,X,Y,DR - S DIE="^IBAT(351.61,",DA=IBIEN - S DR="1.03////"_IBLOS_";1.04////"_IBHIGH_";1.05////"_IBOUT - S:$G(IBDRG) DR=DR_";1.01///"_IBDRG - S:$G(IBDRGA) DR=DR_";1.02////"_IBDRGA - S:$G(IBOUTR) DR=DR_";1.06////"_IBOUTR - L +^IBAT(351.61,IBIEN):10 I '$T Q "0^Transaction Locked" - D ^DIE,TOTAL^IBATCM(IBIEN) I $P($G(^IBAT(351.61,IBIEN,6)),"^",2) D - . S DR=";.05////P;.13////"_DT D ^DIE - L -^IBAT(351.61,IBIEN) - Q IBIEN -OUT(DFN,IBEDT,IBPREF,IBSOURCE,IBPROC) ; - files outpatient data - ; DFN=dfn for patient, IBEDT=event date, IBPREF=enrolled facility - ; IBSOURCE=source (outpatient encounter ien;SCE( - ; IBPROC=procedures (by ref in array) - I '$G(DFN)!('$G(IBEDT))!('$G(IBPREF))!($G(IBSOURCE)="") Q 0 - N IBIEN,IBX,Y,IBPRICE - S IBIEN=$$NEW(DFN,IBEDT,IBPREF,IBSOURCE) I 'IBIEN Q IBIEN - L +^IBAT(351.61,IBIEN):10 I '$T Q "0^Transaction Locked" - S IBIEN=$$PROC(IBIEN,.IBPROC,.IBPRICE) ; file procedures - I IBIEN<1 L -^IBAT(351.61,IBIEN) Q "0^Unable to file procedures" - S DIE="^IBAT(351.61,",DA=IBIEN - S DR=".1////"_IBEDT_";.05////"_$S($G(IBPRICE):"C",1:"P;.13////"_DT) - D ^DIE,TOTAL^IBATCM(IBIEN) L -^IBAT(351.61,IBIEN) - Q IBIEN -UPDATE(IBIEN,IBPROC) ; -- updates procedures - ; IBIEN=351.61 ien, IBPROC=procedures by ref like above - Q:'$G(IBIEN) 0 - N IBX,IBPRICE,DIE,DA,DR,X,Y - S IBIEN(0)=^IBAT(351.61,IBIEN,0),IBEDT=$P(IBIEN(0),"^",4) - ; if approved, cancel and create a new one - I $P(IBIEN(0),"^",5)="A" D Q IBIEN - . S IBIEN=$$CANC(IBIEN) - . S IBIEN=$$OUT($P(IBIEN(0),"^",2),IBEDT,$P(IBIEN(0),"^",11),$P(IBIEN(0),"^",12),.IBPROC) - L +^IBAT(351.61,IBIEN):10 I '$T Q "0^Transaction Locked" - ; first clean out procedures there - S IBX=0 F S IBX=$O(^IBAT(351.61,IBIEN,3,IBX)) Q:IBX<1 S DIK="^IBAT(351.61,"_IBIEN_",3,",DA(1)=IBIEN,DA=IBX D ^DIK - S IBIEN=$$PROC(IBIEN,.IBPROC,.IBPRICE) ; file procedures - I IBIEN<1 L -^IBAT(351.61,IBIEN) Q "0^Unable to file procedures" - S DIE="^IBAT(351.61,",DA=IBIEN - S DR=".1////"_IBEDT_";.05////"_$S($G(IBPRICE):"C",1:"P;.13////"_DT) - D ^DIE,TOTAL^IBATCM(IBIEN) L -^IBAT(351.61,IBIEN) - Q IBIEN -RX(DFN,IBEDT,IBPREF,IBSOURCE,IBDRUG,IBQTY,IBCOST) ; - files pharmacy data - ; DFN=dfn for patient, IBEDT=event date, IBPREF=enrolled facility - ; IBSOURCE=source (prescription ien;PSRX(;refill # - ; IBDRUG=ien from drug file - ; IBQTY=quantity of drug, IBCOST=drug cost - I '$G(DFN)!('$G(IBEDT))!('$G(IBPREF))!($G(IBSOURCE)="")!('$G(IBDRUG))!('$G(IBQTY)) Q 0 - N IBIEN - S IBIEN=$$NEW(DFN,IBEDT,IBPREF,IBSOURCE) I 'IBIEN Q IBIEN - S DIE="^IBAT(351.61,",DA=IBIEN - S DR=".1////"_+IBEDT_";4.01////"_+IBDRUG_";4.02////"_+IBQTY_";.05////"_$S($G(IBCOST):"P;4.03////"_+IBCOST_";.13////"_DT,1:"C") - L +^IBAT(351.61,IBIEN):10 I '$T Q "0^Transaction Locked" - D ^DIE D:$G(IBCOST) TOTAL^IBATCM(IBIEN) - L -^IBAT(351.61,IBIEN) - Q IBIEN - ; -RMPR(DFN,IBEDT,IBPREF,IBSOURCE,IBPROS,IBCOST) ; - files prost. data - ; DFN=dfn for patient, IBEDT=event date, IBPREF=enrolled facility - ; IBSOURCE=source (prost ien;RMPR(660, - ; IBPROS=ien from file 661 - removed in 389 no longer valid - ; IBCOST=item cost - I '$G(DFN)!('$G(IBEDT))!('$G(IBPREF))!($G(IBSOURCE)="") Q 0 - N IBIEN - S IBIEN=$$NEW(DFN,IBEDT,IBPREF,IBSOURCE) I 'IBIEN Q IBIEN - S DIE="^IBAT(351.61,",DA=IBIEN - S DR=".1////"_+IBEDT_";.05////"_$S($G(IBCOST):"P;4.05////"_+IBCOST_";.13////"_DT,1:"C") - L +^IBAT(351.61,IBIEN):10 I '$T Q "0^Transaction Locked" - D ^DIE D:$G(IBCOST) TOTAL^IBATCM(IBIEN) - L -^IBAT(351.61,IBIEN) - Q IBIEN - ; -CANC(DA) ; - used to cancel any transaction - N DIE,DR,X,Y Q:'$G(DA) - S DIE="^IBAT(351.61,",DR=".05///X" D ^DIE - Q -DEL(DA) ; - used to delete a transaction (only valid for inpatients or rx) - N DIK,DR,X,Y,Z Q:'$G(DA) - S Z=$G(^IBAT(351.61,DA,0)) Q:'Z - Q:$P(Z,"^",12)["SCE(" - S DIK="^IBAT(351.61," D ^DIK - Q -NEW(DFN,IBEDT,IBPREF,IBSOURCE) ; - creates new transaction and returns ien - N IBIEN,IBSITE,DD,DO,DIC,X,Y,DINUM,DLAYGO,DIE,DA,DR - S IBSITE=$$SITE^IBATUTL - L +^IBAT(351.6,DFN):10 I '$T Q "0^Patient file Locked" - L +^IBAT(351.61,0):10 I '$T Q "0^Transaction File Locked" - S IBIEN=$P(^IBAT(351.61,0),"^",3)+1 - F IBIEN=IBIEN:1 Q:'$D(^IBAT(351.61,"B",IBSITE_IBIEN)) - S DIC="^IBAT(351.61,",DIC(0)="",X=IBSITE_IBIEN,DINUM=IBIEN,DLAYGO=351.61 - S DIC("DR")=".02////"_+DFN_";.03////"_+DT_";.04////"_+IBEDT_";.05////E;.09////"_+IBEDT_";.11////"_+IBPREF_";.12////^S X=IBSOURCE" - D FILE^DICN I +Y<1 L -(^IBAT(351.61,0),^IBAT(351.6,DFN)) Q "0^Unable to add new transaction" - S DIE="^IBAT(351.6,",DA=+DFN - S DR=$S(IBSOURCE["DGPM":".05",IBSOURCE["SCE":".06",IBSOURCE["RMPR":".11",1:".07")_"////"_+IBEDT - I $P(^IBAT(351.6,DFN,0),"^",+(DR*100))0:Y,1:0) +UPPPF(DA,PPF) ; updates a patient's enrolled facility + I '$G(DA)!('$G(PPF))!('$D(^IBAT(351.6,DA))) Q + N DIE,DR + S DIE="^IBAT(351.6,",DR=".03////"_+PPF D ^DIE + Q +ADM(DFN,IBADMDT,IBPREF,IBSOURCE) ; - files admissions + ; IBADMDT=admission date, IBPREF=enrolled facility + ; IBSOURCE=source (movement ien;DGPM( + I '$G(DFN)!('$G(IBADMDT))!('$G(IBPREF))!($G(IBSOURCE)="") Q 0 + Q $$NEW(DFN,IBADMDT,IBPREF,IBSOURCE) +DIS(DA,IBDISDT,IBPTF,IBDISM) ; - files discharges + ; DA=transaction ien in 351.61, IBDISDT=discharge date + ; IBPTF=ptf pointer, IBDISM=discharge movement pointer + I '$G(DA)!('$G(IBDISDT))!('$G(IBPTF))!('$G(IBDISM)) Q 0 + N DIE,DR + S DIE="^IBAT(351.61," + S DR=".05////C;.1////"_IBDISDT_";1.07////"_IBPTF_";1.08////"_IBDISM + L +^IBAT(351.61,DA):10 I '$T Q "0^Transaction Locked" + D ^DIE L -^IBAT(351.61,DA) + Q DA +DISC(DA) ; - deletes discharge data + ; DA=transaction ien in 351.61 + N DIE,DR Q:'$G(DA) 0 + S DIE="^IBAT(351.61," + S DR=".05////E;.1///@;1.08///@" + L +^IBAT(351.61,DA):10 I '$T Q "0^Transaction Locked" + D ^DIE L -^IBAT(351.61,DA) + Q DA +INPT(IBIEN,IBDRG,IBDRGA,IBLOS,IBHIGH,IBOUT,IBOUTR) ; - file remaining inpt + ; IBIEN=transaction ien in 351.61, IBDRG=DRG pointer + ; IBDRGA=DRG amount,IBLOS=inpatient LOS,IBHIGH=high trim days + ; IBOUT=outlier days,IBOUTR=outlier rate + I '$G(IBIEN)!('$G(IBLOS))!('$D(IBHIGH))!('$D(IBOUT)) Q 0 + N DIE,X,Y,DR + S DIE="^IBAT(351.61,",DA=IBIEN + S DR="1.03////"_IBLOS_";1.04////"_IBHIGH_";1.05////"_IBOUT + S:$G(IBDRG) DR=DR_";1.01///"_IBDRG + S:$G(IBDRGA) DR=DR_";1.02////"_IBDRGA + S:$G(IBOUTR) DR=DR_";1.06////"_IBOUTR + L +^IBAT(351.61,IBIEN):10 I '$T Q "0^Transaction Locked" + D ^DIE,TOTAL^IBATCM(IBIEN) I $P($G(^IBAT(351.61,IBIEN,6)),"^",2) D + . S DR=";.05////P;.13////"_DT D ^DIE + L -^IBAT(351.61,IBIEN) + Q IBIEN +OUT(DFN,IBEDT,IBPREF,IBSOURCE,IBPROC) ; - files outpatient data + ; DFN=dfn for patient, IBEDT=event date, IBPREF=enrolled facility + ; IBSOURCE=source (outpatient encounter ien;SCE( + ; IBPROC=procedures (by ref in array) + I '$G(DFN)!('$G(IBEDT))!('$G(IBPREF))!($G(IBSOURCE)="") Q 0 + N IBIEN,IBX,Y,IBPRICE + S IBIEN=$$NEW(DFN,IBEDT,IBPREF,IBSOURCE) I 'IBIEN Q IBIEN + L +^IBAT(351.61,IBIEN):10 I '$T Q "0^Transaction Locked" + S IBIEN=$$PROC(IBIEN,.IBPROC,.IBPRICE) ; file procedures + I IBIEN<1 L -^IBAT(351.61,IBIEN) Q "0^Unable to file procedures" + S DIE="^IBAT(351.61,",DA=IBIEN + S DR=".1////"_IBEDT_";.05////"_$S($G(IBPRICE):"C",1:"P;.13////"_DT) + D ^DIE,TOTAL^IBATCM(IBIEN) L -^IBAT(351.61,IBIEN) + Q IBIEN +UPDATE(IBIEN,IBPROC) ; -- updates procedures + ; IBIEN=351.61 ien, IBPROC=procedures by ref like above + Q:'$G(IBIEN) 0 + N IBX,IBPRICE,DIE,DA,DR,X,Y + S IBIEN(0)=^IBAT(351.61,IBIEN,0),IBEDT=$P(IBIEN(0),"^",4) + ; if approved, cancel and create a new one + I $P(IBIEN(0),"^",5)="A" D Q IBIEN + . S IBIEN=$$CANC(IBIEN) + . S IBIEN=$$OUT($P(IBIEN(0),"^",2),IBEDT,$P(IBIEN(0),"^",11),$P(IBIEN(0),"^",12),.IBPROC) + L +^IBAT(351.61,IBIEN):10 I '$T Q "0^Transaction Locked" + ; first clean out procedures there + S IBX=0 F S IBX=$O(^IBAT(351.61,IBIEN,3,IBX)) Q:IBX<1 S DIK="^IBAT(351.61,"_IBIEN_",3,",DA(1)=IBIEN,DA=IBX D ^DIK + S IBIEN=$$PROC(IBIEN,.IBPROC,.IBPRICE) ; file procedures + I IBIEN<1 L -^IBAT(351.61,IBIEN) Q "0^Unable to file procedures" + S DIE="^IBAT(351.61,",DA=IBIEN + S DR=".1////"_IBEDT_";.05////"_$S($G(IBPRICE):"C",1:"P;.13////"_DT) + D ^DIE,TOTAL^IBATCM(IBIEN) L -^IBAT(351.61,IBIEN) + Q IBIEN +RX(DFN,IBEDT,IBPREF,IBSOURCE,IBDRUG,IBQTY,IBCOST) ; - files pharmacy data + ; DFN=dfn for patient, IBEDT=event date, IBPREF=enrolled facility + ; IBSOURCE=source (prescription ien;PSRX(;refill # + ; IBDRUG=ien from drug file + ; IBQTY=quantity of drug, IBCOST=drug cost + I '$G(DFN)!('$G(IBEDT))!('$G(IBPREF))!($G(IBSOURCE)="")!('$G(IBDRUG))!('$G(IBQTY)) Q 0 + N IBIEN + S IBIEN=$$NEW(DFN,IBEDT,IBPREF,IBSOURCE) I 'IBIEN Q IBIEN + S DIE="^IBAT(351.61,",DA=IBIEN + S DR=".1////"_+IBEDT_";4.01////"_+IBDRUG_";4.02////"_+IBQTY_";.05////"_$S($G(IBCOST):"P;4.03////"_+IBCOST_";.13////"_DT,1:"C") + L +^IBAT(351.61,IBIEN):10 I '$T Q "0^Transaction Locked" + D ^DIE D:$G(IBCOST) TOTAL^IBATCM(IBIEN) + L -^IBAT(351.61,IBIEN) + Q IBIEN + ; +RMPR(DFN,IBEDT,IBPREF,IBSOURCE,IBPROS,IBCOST) ; - files prost. data + ; DFN=dfn for patient, IBEDT=event date, IBPREF=enrolled facility + ; IBSOURCE=source (prost ien;RMPR(660, + ; IBPROS=ien from file 661 + ; IBCOST=item cost + I '$G(DFN)!('$G(IBEDT))!('$G(IBPREF))!($G(IBSOURCE)="")!('$G(IBPROS)) Q 0 + N IBIEN + S IBIEN=$$NEW(DFN,IBEDT,IBPREF,IBSOURCE) I 'IBIEN Q IBIEN + S DIE="^IBAT(351.61,",DA=IBIEN + S DR=".1////"_+IBEDT_";4.04////"_+IBPROS_";.05////"_$S($G(IBCOST):"P;4.05////"_+IBCOST_";.13////"_DT,1:"C") + L +^IBAT(351.61,IBIEN):10 I '$T Q "0^Transaction Locked" + D ^DIE D:$G(IBCOST) TOTAL^IBATCM(IBIEN) + L -^IBAT(351.61,IBIEN) + Q IBIEN + ; +CANC(DA) ; - used to cancel any transaction + N DIE,DR,X,Y Q:'$G(DA) + S DIE="^IBAT(351.61,",DR=".05///X" D ^DIE + Q +DEL(DA) ; - used to delete a transaction (only valid for inpatients or rx) + N DIK,DR,X,Y,Z Q:'$G(DA) + S Z=$G(^IBAT(351.61,DA,0)) Q:'Z + Q:$P(Z,"^",12)["SCE(" + S DIK="^IBAT(351.61," D ^DIK + Q +NEW(DFN,IBEDT,IBPREF,IBSOURCE) ; - creates new transaction and returns ien + N IBIEN,IBSITE,DD,DO,DIC,X,Y,DINUM,DLAYGO,DIE,DA,DR + S IBSITE=$$SITE^IBATUTL + L +^IBAT(351.6,DFN):10 I '$T Q "0^Patient file Locked" + L +^IBAT(351.61,0):10 I '$T Q "0^Transaction File Locked" + S IBIEN=$P(^IBAT(351.61,0),"^",3)+1 + F IBIEN=IBIEN:1 Q:'$D(^IBAT(351.61,"B",IBSITE_IBIEN)) + S DIC="^IBAT(351.61,",DIC(0)="",X=IBSITE_IBIEN,DINUM=IBIEN,DLAYGO=351.61 + S DIC("DR")=".02////"_+DFN_";.03////"_+DT_";.04////"_+IBEDT_";.05////E;.09////"_+IBEDT_";.11////"_+IBPREF_";.12////^S X=IBSOURCE" + D FILE^DICN I +Y<1 L -(^IBAT(351.61,0),^IBAT(351.6,DFN)) Q "0^Unable to add new transaction" + S DIE="^IBAT(351.6,",DA=+DFN + S DR=$S(IBSOURCE["DGPM":".05",IBSOURCE["SCE":".06",IBSOURCE["RMPR":".11",1:".07")_"////"_+IBEDT + I $P(^IBAT(351.6,DFN,0),"^",+(DR*100))IOSL D H X:'$D(DIRUT) "W @IOF,!" I $D(DIRUT) S IBOUT=1 Q - .. S IBNUM(IBCOUNT)=IBPSRX_"^"_IBDT - W ! K DIRUT S DIR(0)="L^1:"_IBCOUNT,DIR("A")="Which Prescriptions" - D ^DIR Q:$D(DIRUT) W !!,"Selected number(s): "_Y S IBNUM=Y - W !,"Ok to add: " S %=1 D YN^DICN I %'=1 D H Q - S IBFAC=$$PPF^IBATUTL(DFN),IBSITE=$$SITE^IBATUTL - F IBP=1:1 S IBRX=$P(IBNUM,",",IBP) Q:'IBRX D - . S IBRX(0)=IBRX($P(IBNUM(IBRX),"^"),$P(IBNUM(IBRX),"^",2)) - . D DUP($P(IBRX(0),"^")_";PSRX(;"_$P(IBRX(0),"^",2),.IBQUIT) - . I $G(IBQUIT) K IBQUIT Q - . W !!,"Adding Transaction number ",IBSITE - . W $$RX^IBATFILE(DFN,$P(IBNUM(IBRX),"^",2),IBFAC,$P(IBRX(0),"^")_";PSRX(;"_$P(IBRX(0),"^",2),$P(IBRX(0),"^",3),$P(IBRX(0),"^",5),$P(IBRX(0),"^",6)) - . W "!" H 1 - D H - Q -R ; -- select an prosthetic - N IBBDT,IBEDT,IBCOUNT,IBOUT,IBDA,IBDATA,IBDATA1,IBP,IBC,IBCOUNT,%,DIRUT - ; - S (IBCOUNT,IBOUT)=0 - Q:$$SLDR^IBATUTL - ; - ; look up prosthetic devices issued - S IBDA="" F S IBDA=$O(^RMPR(660,"C",DFN,IBDA)) Q:'IBDA D - . ; - . ; valid data - . S IBDATA=$G(^RMPR(660,+IBDA,0)) Q:IBDATA="" S IBDATA1=$G(^RMPR(660,+IBDA,1)) - . ; - . ; valid date range - . I $P(IBDATA,"^",12)IBEDT) Q - . ; - . ; checks from RMPRBIL copied 4/7/2000 with mod for AM node patients - . I $S('$D(^RMPR(660,IBDA,"AM")):1,$P(IBDATA,"^",9)="":1,$P(IBDATA,"^",12)="":1,$P(IBDATA1,"^",4)="":1,$P(IBDATA,"^",14)="V":1,$P(IBDATA,"^",15)="*":1,1:0) Q - . ; - . ; set array - . S IBCOUNT=IBCOUNT+1,IBP(IBCOUNT,IBDA)=IBDATA - ; - I 'IBCOUNT W !!,"No Prosthetic Devices on file for date range selected." D H Q - ; - W @IOF,!,"Prosthetic Devices Issued:",! - F IBC=1:1:IBCOUNT Q:IBOUT D - . S IBDATA=IBP(IBC,$O(IBP(IBC,0))) - . W !,IBC,?4,$$FMTE^XLFDT($P(IBDATA,"^",12),"5D") - . W ?20,$E($P($$PIN^IBATUTL($O(IBP(IBC,0))),U,2),1,28),?50,"(" - . W $$EX^IBATUTL(660,62,$P(^RMPR(660,$O(IBP(IBC,0)),"AM"),"^",3)),")" - . W ?65,$J($FN($P(IBDATA,"^",16),",",2),12) - ; - W ! K DIRUT S DIR(0)="N^1:"_IBCOUNT_":0" - S DIR("A")="Which Prosthetic Device" D ^DIR Q:$D(DIRUT) S IBC=+Y - W !,"Ok to add: " S %=1 D YN^DICN I %'=1 D H Q - S IBDA=$O(IBP(IBC,0)),IBDATA=IBP(IBC,IBDA) - D DUP(IBDA_";RMPR(660,",.DIRUT) - I $D(DIRUT) D H Q - W !!,"Adding Transaction number ",$$SITE^IBATUTL - W $$RMPR^IBATFILE(DFN,$P(IBDATA,"^",12),$$PPF^IBATUTL(DFN),(IBDA_";RMPR(660,"),,$P(IBDATA,"^",16)) - W "!" H 1 - D H - Q -H ; -- page reader - N DIR,X,Y,DTOUT,DUOUT,DIROUT - W !! S DIR(0)="E" D ^DIR - Q -DUP(IBSOURCE,IBQUIT) ; -- checks for dups that are not cancelled - N IBT S IBT=0 - F S IBT=$O(^IBAT(351.61,"AD",IBSOURCE,IBT)) Q:IBT<1!($D(IBQUIT)) D - . Q:$P(^IBAT(351.61,IBT,0),"^",5)="X" - . W !,$S(IBSOURCE["SCE(":"Visit",IBSOURCE["DGPM(":"Admission",IBSOURCE["RMPR(":"Prosthetic",1:"Prescription")," exists already!" S IBQUIT=1 - Q +IBATLM1B ;LL/ELZ - TRANSFER PRICING TRANSACTION LIST MENU ; 15-SEP-1998 + ;;2.0;INTEGRATED BILLING;**115,261**;21-MAR-94 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; +CF ; -- change facility from patient level + D LMOPT^IBATUTL,CFP^IBATLM0A(DFN),HDR^IBATLM1 + Q +CS ; -- change status of patient from patient level + D LMOPT^IBATUTL,CSP^IBATLM0A(DFN),HDR^IBATLM1 + Q +CT ; -- cancel a transaction + N IBVAL,DIE,DA,DR,DTOUT,% + D LMOPT^IBATUTL,EN^VALM2($G(XQORNOD(0))) + S (DA,IBVAL)=0,IBVAL=$O(VALMY(IBVAL)) Q:'IBVAL + S DA=$O(@VALMAR@("INDEX",IBVAL,DA)) + I $P(^IBAT(351.61,DA,0),U,5)="X" W !!,"Transaction already cancelled!" D H Q + W !!,"Are you sure you want to cancel this transaction" + S %=2 D YN^DICN Q:%'=1 + D CANC^IBATFILE(DA),ARRAY^IBATLM1A(VALMAR) + Q +CD ; -- change the current date range for transactions displayed + N IBSAVE S IBSAVE=IBBDT_"^"_IBEDT + D LMOPT^IBATUTL + I $$SLDR^IBATUTL S IBBDT=$P(IBSAVE,"^"),IBEDT=$P(IBSAVE,"^",2) + D ARRAY^IBATLM1A(VALMAR),HDR^IBATLM1 + Q +CP ; -- change the currently selected patient + N IBDFN + D LMOPT^IBATUTL + S IBDFN=$$SLPT^IBATUTL I 'IBDFN Q + I $$SLDR^IBATUTL Q + S DFN=IBDFN K ^TMP("VALM DATA",$J),^TMP("VALMAR",$J) + D HDR^IBATLM1,ARRAY^IBATLM1A(VALMAR) + Q +AT ; -- add a transaction + N X,Y,DTOUT,DUOUT,DIRUT,DIROUT + D LMOPT^IBATUTL + S DIR(0)="SMBA^I:Inpatient;O:Outpatient;P:Prescription;R:Prosthetic" + S DIR("A")="Select type of Transaction to add: " D ^DIR Q:$D(DIRUT) + D @Y K ^TMP("VALM DATA",$J),^TMP("VALMAR",$J) + D HDR^IBATLM1,ARRAY^IBATLM1A(VALMAR) + Q +I ; -- select an inpatient stay and add + N IBXA,IBADM,DIRUT,IBIEN,VAIP,IBCHARGE,IBPPF,IBRES + S IBXA=7,IBADM=+$$ADSEL^IBECEA31(DFN) Q:IBADM<0 + I IBADM=0 W !!,"Patient has no admissions on file." D H Q + D DUP(IBADM_";DGPM(",.DIRUT) + I $D(DIRUT) D H Q + S VAIP("E")=IBADM D IN5^VADPT S IBPPF=$$PPF^IBATUTL(DFN) + S IBIEN=$$ADM^IBATFILE(DFN,+VAIP(13,1),IBPPF,(+IBADM)_";DGPM(") + I 'IBIEN D M(,$P(IBIEN,"^",2)) Q + I '$G(VAIP(17)) D M(IBIEN,"missing discharge information") Q + S IBRES=$$DIS^IBATFILE(IBIEN,+VAIP(17,1),VAIP(12),VAIP(17)) + I 'IBRES D M(IBIEN,$P(IBRES,"^",2)) Q + S IBFINDRT=$$FINDRT^IBATEI(VAIP(12),VAIP(13),DFN) + I '+IBFINDRT D M(IBIEN,"Cannot price transaction") Q + I $P(IBFINDRT,"^",3)="B" S IBRES=$$INPT^IBATFILE(IBIEN,0,0,$P(IBFINDRT,"^",4),0,$P(IBFINDRT,"^",4),$P(IBFINDRT,"^",7)) + E S IBRES=$$INPT^IBATFILE(IBIEN,$P(IBFINDRT,"^",3),$P(IBFINDRT,"^",2),$P(IBFINDRT,"^",4),$P(IBFINDRT,"^",5),$P(IBFINDRT,"^",6),$P(IBFINDRT,"^",7)) + I 'IBRES D M(IBIEN,"Error in filling pricing information") Q + D M(IBIEN) + Q +M(X,Y) ; Prints message and hangs + N IBSITE S IBSITE=$$SITE^IBATUTL + I $D(X) W !,"Transaction #",IBSITE,X," Added" + I $D(Y) W !,"Cannot complete, ",Y + D H + Q +O ; -- select an outpatient stay + N X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT,IBDATA,IBX,IBC,CPTLIST,IBIEN,IBFAC + K ^TMP("IBAT",$J) + S DIR(0)="D^::AEPX",DIR("A")="Visit Date" D ^DIR Q:$D(DIRUT) + S IBDATA("DFN")=DFN,IBDATA("BDT")=Y,IBDATA("EDT")=Y+.99999 + ; + ; scan for the appointments and set up tmp global + ; screen to eliminate children and inpatient appointments + D SCAN^IBSDU("PATIENT/DATE",.IBDATA,"I '$P(Y0,""^"",6),$P(Y0,""^"",12)'=8","S ^TMP(""IBAT"",$J,Y)=Y0","") + ; + I '$D(^TMP("IBAT",$J)) W !!,"No appointments exist for the date!" D H Q + W !,?10,"Choose which Visit:" S IBX=0 + F IBC=1:1 S IBX=$O(^TMP("IBAT",$J,IBX)) Q:IBX<1 S IBDATA=^(IBX) D + . W !,?4,IBC,?10,$$FMTE^XLFDT($P(IBDATA,"^"),"1P") + . W ?35,$$EX^IBATUTL(409.68,.04,$P(IBDATA,"^",4)) + . W ?55,$$EX^IBATUTL(409.68,.12,$P(IBDATA,"^",12)) + S DIR(0)="N^1:"_(IBC-1),DIR("A")="Select" D ^DIR Q:$D(DIRUT) + S IBX=0 F IBC=1:1:Y S IBX=$O(^TMP("IBAT",$J,IBX)) + ; check for duplicates + D DUP(IBX_";SCE(",.DIRUT) I $D(DIRUT) D H Q + ; setup visit info + S IBX(0)=^TMP("IBAT",$J,IBX) + D GETCPT^SDOE(IBX,"CPTLIST") ;GETDX^SDOE(IBX,"DXLIST") + S IBFAC=$$PPF^IBATUTL(DFN) + ; ok now lets format cpts and price + S IBIEN=0 F S IBIEN=$O(CPTLIST(IBIEN)) Q:IBIEN<1 D + . N IBCPT,IBQTY,IBPRICE + . S IBCPT=$P(CPTLIST(IBIEN),"^"),IBQTY=$P(CPTLIST(IBIEN),"^",16) + . S IBPRICE=$$OPT^IBATCM(IBCPT,$P(IBX(0),"^"),IBFAC) + . S IBIEN(IBCPT)=IBQTY_"^"_$S(IBPRICE:$P(IBPRICE,"^",4),1:0) + S IBIEN=$$OUT^IBATFILE(DFN,$P(IBX(0),"^"),IBFAC,IBX_";SCE(",.IBIEN) + W !!,"Transaction Number ",$P(^IBAT(351.61,IBIEN,0),"^")," Added!" D H + K ^TMP("IBAT",$J) + Q +P ; -- select an rx + N IBRX,IBPSRX,IBOUT,IBCOUNT,DIRUT,DIR,IBP,IBNUM,IBSITE,IBQUIT,IBBDT,IBEDT + S (IBCOUNT,IBOUT)=0 + Q:$$SLDR^IBATUTL + D RX^IBATRX(DFN,IBBDT,IBEDT,.IBRX) + I '$D(IBRX) W !!,"No Rx's on file for date range selected." D H Q + W @IOF,!,"Prescriptions Issued:",! + S IBPSRX=0 F S IBPSRX=$O(IBRX(IBPSRX)) Q:IBPSRX=""!(IBOUT) D + . S IBDT=0 F S IBDT=$O(IBRX(IBPSRX,IBDT)) Q:IBDT<1!(IBOUT) D + .. S IBDAT=IBRX(IBPSRX,IBDT),IBCOUNT=IBCOUNT+1 + .. W !,IBCOUNT,?4,$$FMTE^XLFDT(IBDT,"5D"),?18,$P(IBDAT,"^") + .. W "(",$P(IBDAT,"^",2),")",?35,$E($P(IBDAT,"^",4),1,27) + .. W ?65,$J($FN($P(IBDAT,"^",5)*$P(IBDAT,"^",6),",",2),12) + .. ;I $Y+4>IOSL D H X:'$D(DIRUT) "W @IOF,!" I $D(DIRUT) S IBOUT=1 Q + .. S IBNUM(IBCOUNT)=IBPSRX_"^"_IBDT + W ! K DIRUT S DIR(0)="L^1:"_IBCOUNT,DIR("A")="Which Prescriptions" + D ^DIR Q:$D(DIRUT) W !!,"Selected number(s): "_Y S IBNUM=Y + W !,"Ok to add: " S %=1 D YN^DICN I %'=1 D H Q + S IBFAC=$$PPF^IBATUTL(DFN),IBSITE=$$SITE^IBATUTL + F IBP=1:1 S IBRX=$P(IBNUM,",",IBP) Q:'IBRX D + . S IBRX(0)=IBRX($P(IBNUM(IBRX),"^"),$P(IBNUM(IBRX),"^",2)) + . D DUP($P(IBRX(0),"^")_";PSRX(;"_$P(IBRX(0),"^",2),.IBQUIT) + . I $G(IBQUIT) K IBQUIT Q + . W !!,"Adding Transaction number ",IBSITE + . W $$RX^IBATFILE(DFN,$P(IBNUM(IBRX),"^",2),IBFAC,$P(IBRX(0),"^")_";PSRX(;"_$P(IBRX(0),"^",2),$P(IBRX(0),"^",3),$P(IBRX(0),"^",5),$P(IBRX(0),"^",6)) + . W "!" H 1 + D H + Q +R ; -- select an prosthetic + N IBBDT,IBEDT,IBCOUNT,IBOUT,IBDA,IBDATA,IBP,IBC,IBCOUNT,%,DIRUT + ; + S (IBCOUNT,IBOUT)=0 + Q:$$SLDR^IBATUTL + ; + ; look up prosthetic devices issued + S IBDA="" F S IBDA=$O(^RMPR(660,"C",DFN,IBDA)) Q:'IBDA D + . ; + . ; valid data + . S IBDATA=$G(^RMPR(660,+IBDA,0)) Q:IBDATA="" + . ; + . ; valid date range + . I $P(IBDATA,"^",12)IBEDT) Q + . ; + . ; checks from RMPRBIL copied 4/7/2000 with mod for AM node patients + . I $S('$D(^RMPR(660,IBDA,"AM")):1,$P(IBDATA,"^",9)="":1,$P(IBDATA,"^",12)="":1,$P(IBDATA,"^",6)="":1,$P(IBDATA,"^",14)="V":1,$P(IBDATA,"^",15)="*":1,1:0) Q + . ; + . ; set array + . S IBCOUNT=IBCOUNT+1,IBP(IBCOUNT,IBDA)=IBDATA + ; + I 'IBCOUNT W !!,"No Prosthetic Devices on file for date range selected." D H Q + ; + W @IOF,!,"Prosthetic Devices Issued:",! + F IBC=1:1:IBCOUNT Q:IBOUT D + . S IBDATA=IBP(IBC,$O(IBP(IBC,0))) + . W !,IBC,?4,$$FMTE^XLFDT($P(IBDATA,"^",12),"5D") + . W ?20,$$EX^IBATUTL(660,4,$P(IBDATA,"^",6)),?40,"(" + . W $$EX^IBATUTL(660,62,$P(^RMPR(660,$O(IBP(IBC,0)),"AM"),"^",3)),")" + . W ?65,$J($FN($P(IBDATA,"^",16),",",2),12) + ; + W ! K DIRUT S DIR(0)="N^1:"_IBCOUNT_":0" + S DIR("A")="Which Prosthetic Device" D ^DIR Q:$D(DIRUT) S IBC=+Y + W !,"Ok to add: " S %=1 D YN^DICN I %'=1 D H Q + S IBDA=$O(IBP(IBC,0)),IBDATA=IBP(IBC,IBDA) + D DUP(IBDA_";RMPR(660,",.DIRUT) + I $D(DIRUT) D H Q + W !!,"Adding Transaction number ",$$SITE^IBATUTL + W $$RMPR^IBATFILE(DFN,$P(IBDATA,"^",12),$$PPF^IBATUTL(DFN),(IBDA_";RMPR(660,"),$P(IBDATA,"^",6),$P(IBDATA,"^",16)) + W "!" H 1 + D H + Q +H ; -- page reader + N DIR,X,Y,DTOUT,DUOUT,DIROUT + W !! S DIR(0)="E" D ^DIR + Q +DUP(IBSOURCE,IBQUIT) ; -- checks for dups that are not cancelled + N IBT S IBT=0 + F S IBT=$O(^IBAT(351.61,"AD",IBSOURCE,IBT)) Q:IBT<1!($D(IBQUIT)) D + . Q:$P(^IBAT(351.61,IBT,0),"^",5)="X" + . W !,$S(IBSOURCE["SCE(":"Visit",IBSOURCE["DGPM(":"Admission",IBSOURCE["RMPR(":"Prosthetic",1:"Prescription")," exists already!" S IBQUIT=1 + Q diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATLM2A.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATLM2A.m index 4a3ec267..fff39c5f 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATLM2A.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATLM2A.m @@ -1,183 +1,183 @@ -IBATLM2A ;LL/ELZ - TRANSFER PRICING PT TRANSACTION DETAIL ; 15-SEP-1998 - ;;2.0;INTEGRATED BILLING;**115,210,266,309,389**;21-MAR-94;Build 6 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - N IBX,IBY K ^TMP("IBATEE",$J) - F IBX=0,4,5,6 S IBDATA(IBX)=$G(^IBAT(351.61,IBIEN,IBX)) - ; - S IBY="" - D SET("*** General Information ***",.IBY,26,27) - D SETVALM(.VALMCNT,.IBY) - D CNTRL^VALM10(VALMCNT,26,27,IOINHI,IOINORM) - D SETVALM(.VALMCNT,"") - ; - D SET("Transaction Date:",.IBY,1,17) - D SET($$DATE($P(IBDATA(0),"^",3)),.IBY,19,19) - D SET("Event Date:",.IBY,48,11) - D SET($$DATE($P(IBDATA(0),"^",4)),.IBY,60,20) - D SETVALM(.VALMCNT,.IBY) - ; - D SET("Status:",.IBY,11,7) - D SET($$EX^IBATUTL(351.61,.05,$P(IBDATA(0),"^",5)),.IBY,19,19) - D SET("Priced Date:",.IBY,47,12) - D SET($$DATE($P(IBDATA(0),"^",13)),.IBY,60,20) - D SETVALM(.VALMCNT,.IBY) - ; - D SET("From Date:",.IBY,8,10) - D SET($$DATE($P(IBDATA(0),"^",9)),.IBY,19,19) - D SET("To Date:",.IBY,51,8) - D SET($$DATE($P(IBDATA(0),"^",10)),.IBY,60,20) - D SETVALM(.VALMCNT,.IBY) - ; - D SET("Facility:",.IBY,9,9) - D SET($$EX^IBATUTL(351.61,.11,$P(IBDATA(0),"^",11)),.IBY,19,19) - D SETVALM(.VALMCNT,.IBY),SETVALM(.VALMCNT,""),SETVALM(.VALMCNT,"") - ; - D SET("*** Workload/Pricing Detail ***",.IBY,24,31) - D SETVALM(.VALMCNT,.IBY) - D CNTRL^VALM10(VALMCNT,24,31,IOINHI,IOINORM) - ; - D @$S($P(IBDATA(0),"^",12)["DGPM(":"INPT",$P(IBDATA(0),"^",12)["SCE(":"OUT",$P(IBDATA(0),"^",12)["RMPR(":"RMPR",1:"RX") - ; - D SETVALM(.VALMCNT,"") - D SET("*** Totals ***",.IBY,33,14) - D SETVALM(.VALMCNT,.IBY) - D CNTRL^VALM10(VALMCNT,26,28,IOINHI,IOINORM) - D SETVALM(.VALMCNT,"") - ; - D SET("Bill Amount:",.IBY,6,18) - D SET($FN($P(IBDATA(6),"^",2),"",2),.IBY,25,54) - D SETVALM(.VALMCNT,.IBY) - ; - D SET("Patient Copay:",.IBY,6,14) - S $P(IBDATA(6),"^",3)=$$COPAY^IBATUTL(DFN,$P(IBDATA(0),"^",12),$P(IBDATA(0),"^",9),$P(IBDATA(0),"^",10)) - D SET($FN($P(IBDATA(6),"^",3),"",2),.IBY,26,54) - D SETVALM(.VALMCNT,.IBY) - ; - Q -INPT ; -- detail display for inpatient - N IBDRG,VAIP - ; - S IBDRG=$G(^IBAT(351.61,IBIEN,1)) - ; - S VAIP("E")=+$P(IBDATA(0),"^",12) D IN5^VADPT - ; - D SETVALM(.VALMCNT,"") - D SET("Admission Date:",.IBY,3,15) - D SET($P(VAIP(13,1),"^",2),.IBY,19,19) - D SET("Discharge Date:",.IBY,44,15) - D SET($P(VAIP(17,1),"^",2),.IBY,60,20) - D SETVALM(.VALMCNT,.IBY) - ; - D SET("Ward Location:",.IBY,4,14) - D SET($P(VAIP(5),"^",2),.IBY,19,19) - D SET("Treating Specialty:",.IBY,40,19) - D SET($P(VAIP(8),"^",2),.IBY,60,20) - D SETVALM(.VALMCNT,.IBY) - ; - D SET("DRG:",.IBY,14,4) - D SET($$EX^IBATUTL(351.61,1.01,$P(IBDRG,"^")),.IBY,19,19) - D SET("DRG Charge:",.IBY,48,11) - D SET($FN($P(IBDRG,"^",2),"",2),.IBY,60,20) - D SETVALM(.VALMCNT,.IBY) - ; - D SET("Inpatient LOS:",.IBY,4,14) - D SET(+$P(IBDRG,"^",3),.IBY,19,19) - D SET("High Trim Days:",.IBY,44,15) - D SET(+$P(IBDRG,"^",4),.IBY,60,20) - D SETVALM(.VALMCNT,.IBY) - ; - D SET("Outlier Days:",.IBY,5,13) - D SET(+$P(IBDRG,"^",5),.IBY,19,19) - D SET("Outlier Rate:",.IBY,46,13) - D SET($FN($P(IBDRG,"^",6),"",2),.IBY,60,20) - D SETVALM(.VALMCNT,.IBY) - Q -OUT ; -- detail display for outpatient - N IBX,IBDXLIST,IBSCE,IBPROV,IBDATE - ; - D GETGEN^SDOE($P($P(IBDATA(0),"^",12),";"),"IBSCE") - D GETPRV^SDOE($P($P(IBDATA(0),"^",12),";"),"IBPROV") - ; - D GETDX^SDOE($P($P(IBDATA(0),"^",12),";"),"IBDXLIST") - S IBDATE=$P($G(IBDATA(0)),U,4) ; Event date - D DX(.IBDXLIST,IBDATE) - ; - D SET("Procedure Information:",.IBY,1,22) - D SETVALM(.VALMCNT,.IBY) - D CNTRL^VALM10(VALMCNT,1,22,IOINHI,IOINORM) - ; - S IBX=0 F S IBX=$O(^IBAT(351.61,IBIEN,3,IBX)) Q:IBX<1 D - . S IBX(0)=$G(^IBAT(351.61,IBIEN,3,IBX,0)) - . S IBX(1)=$$PROC^IBATUTL($P(IBX(0),U),IBDATE) - . ; - . D SET(+IBX(1),.IBY,5,6) - . D SET("-",.IBY,13,1) - . D SET($P(IBX(1),"^",2),.IBY,15,40) - . D SET(+$P(IBX(0),"^",2),.IBY,57,3) - . D SET("x",.IBY,62,1) - . D SET($FN($P(IBX(0),"^",3),"",2),.IBY,64,15) - . D SETVALM(.VALMCNT,.IBY) - D SETVALM(.VALMCNT,"") - ; - D SET("Visit Information:",.IBY,1,18) - D SETVALM(.VALMCNT,.IBY) - D CNTRL^VALM10(VALMCNT,1,22,IOINHI,IOINORM) - ; - D SET("Location:",.IBY,8,14) - D SET($P(^SC(+$P(IBSCE(0),"^",4),0),"^"),.IBY,19,46) ; dbia 10040 - D SETVALM(.VALMCNT,.IBY) - ; - D SETVALM(.VALMCNT,"") - D SET("Provider(s):",.IBY,5,17) - S IBX=0 F S IBX=$O(IBPROV(IBX)) Q:IBX<.5 D - . D SET($$GET1^DIQ(200,+IBPROV(IBX),.01),.IBY,19,49) ; dbia 10060 - . D SETVALM(.VALMCNT,.IBY) - ; - Q -RX ; -- detail display for rx - D SET("Drug:",.IBY,5,5) - D ZERO^IBRXUTL(+IBDATA(4)) - D SET(^TMP($J,"IBDRUG",+IBDATA(4),.01),.IBY,12,40) ; dbia 4533 - D SET(+$P(IBDATA(4),"^",2),.IBY,55,3) - D SET("x",.IBY,60,1) - D SET($FN($P(IBDATA(4),"^",3),"",3),.IBY,62,15) - D SETVALM(.VALMCNT,.IBY) - D SETVALM(.VALMCNT,"") - K ^TMP($J,"IBDRUG") - Q -RMPR ; -- detail display for prosthetic - D SETVALM(.VALMCNT,"") - D SET("Prosthetic Item:",.IBY,5,16) - D SET($P($$PIN^IBATUTL(+$P(IBDATA(0),"^",12)),U,2),.IBY,23,30) ; dbia 374 - D SET($FN($P(IBDATA(4),"^",5),",",2),.IBY,58,15) - D SETVALM(.VALMCNT,.IBY) - D SETVALM(.VALMCNT,"") - Q -DX(IBDX,IBDATE) ; -- diagnosis info - N IBX - ; - D SETVALM(.VALMCNT,"") - D SET("Diagnosis Information:",.IBY,1,22) - D SETVALM(.VALMCNT,.IBY) - D CNTRL^VALM10(VALMCNT,1,22,IOINHI,IOINORM) - ; - S IBX=0 F S IBX=$O(IBDX(IBX)) Q:IBX<1 D - . S IBX(0)=$$ICD9^IBACSV(+IBDX(IBX),$G(IBDATE)) - . ; - . D SET($P(IBX(0),"^"),.IBY,5,7) - . D SET("-",.IBY,14,1) - . D SET($P(IBX(0),"^",3),.IBY,16,30) - . D SETVALM(.VALMCNT,.IBY) - D SETVALM(.VALMCNT,"") - Q -SET(TEXT,STRING,COL,LENGTH) ; -- set up string with valm1 - S STRING=$$SETSTR^VALM1($$LOWER^VALM1(TEXT),STRING,COL,LENGTH) - Q -SETVALM(LINE,TEXT) ; -- sets line for display - S LINE=LINE+1 - S ^TMP("IBATEE",$J,LINE,0)=TEXT - S TEXT="" - Q -DATE(X) ; -- returns date for display - Q $$FMTE^XLFDT(X,"5D") +IBATLM2A ;LL/ELZ - TRANSFER PRICING PT TRANSACTION DETAIL ; 15-SEP-1998 + ;;2.0;INTEGRATED BILLING;**115,210,266,309**;21-MAR-94 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; + N IBX,IBY K ^TMP("IBATEE",$J) + F IBX=0,4,5,6 S IBDATA(IBX)=$G(^IBAT(351.61,IBIEN,IBX)) + ; + S IBY="" + D SET("*** General Information ***",.IBY,26,27) + D SETVALM(.VALMCNT,.IBY) + D CNTRL^VALM10(VALMCNT,26,27,IOINHI,IOINORM) + D SETVALM(.VALMCNT,"") + ; + D SET("Transaction Date:",.IBY,1,17) + D SET($$DATE($P(IBDATA(0),"^",3)),.IBY,19,19) + D SET("Event Date:",.IBY,48,11) + D SET($$DATE($P(IBDATA(0),"^",4)),.IBY,60,20) + D SETVALM(.VALMCNT,.IBY) + ; + D SET("Status:",.IBY,11,7) + D SET($$EX^IBATUTL(351.61,.05,$P(IBDATA(0),"^",5)),.IBY,19,19) + D SET("Priced Date:",.IBY,47,12) + D SET($$DATE($P(IBDATA(0),"^",13)),.IBY,60,20) + D SETVALM(.VALMCNT,.IBY) + ; + D SET("From Date:",.IBY,8,10) + D SET($$DATE($P(IBDATA(0),"^",9)),.IBY,19,19) + D SET("To Date:",.IBY,51,8) + D SET($$DATE($P(IBDATA(0),"^",10)),.IBY,60,20) + D SETVALM(.VALMCNT,.IBY) + ; + D SET("Facility:",.IBY,9,9) + D SET($$EX^IBATUTL(351.61,.11,$P(IBDATA(0),"^",11)),.IBY,19,19) + D SETVALM(.VALMCNT,.IBY),SETVALM(.VALMCNT,""),SETVALM(.VALMCNT,"") + ; + D SET("*** Workload/Pricing Detail ***",.IBY,24,31) + D SETVALM(.VALMCNT,.IBY) + D CNTRL^VALM10(VALMCNT,24,31,IOINHI,IOINORM) + ; + D @$S($P(IBDATA(0),"^",12)["DGPM(":"INPT",$P(IBDATA(0),"^",12)["SCE(":"OUT",$P(IBDATA(0),"^",12)["RMPR(":"RMPR",1:"RX") + ; + D SETVALM(.VALMCNT,"") + D SET("*** Totals ***",.IBY,33,14) + D SETVALM(.VALMCNT,.IBY) + D CNTRL^VALM10(VALMCNT,26,28,IOINHI,IOINORM) + D SETVALM(.VALMCNT,"") + ; + D SET("Bill Amount:",.IBY,6,18) + D SET($FN($P(IBDATA(6),"^",2),"",2),.IBY,25,54) + D SETVALM(.VALMCNT,.IBY) + ; + D SET("Patient Copay:",.IBY,6,14) + S $P(IBDATA(6),"^",3)=$$COPAY^IBATUTL(DFN,$P(IBDATA(0),"^",12),$P(IBDATA(0),"^",9),$P(IBDATA(0),"^",10)) + D SET($FN($P(IBDATA(6),"^",3),"",2),.IBY,26,54) + D SETVALM(.VALMCNT,.IBY) + ; + Q +INPT ; -- detail display for inpatient + N IBDRG,VAIP + ; + S IBDRG=$G(^IBAT(351.61,IBIEN,1)) + ; + S VAIP("E")=+$P(IBDATA(0),"^",12) D IN5^VADPT + ; + D SETVALM(.VALMCNT,"") + D SET("Admission Date:",.IBY,3,15) + D SET($P(VAIP(13,1),"^",2),.IBY,19,19) + D SET("Discharge Date:",.IBY,44,15) + D SET($P(VAIP(17,1),"^",2),.IBY,60,20) + D SETVALM(.VALMCNT,.IBY) + ; + D SET("Ward Location:",.IBY,4,14) + D SET($P(VAIP(5),"^",2),.IBY,19,19) + D SET("Treating Specialty:",.IBY,40,19) + D SET($P(VAIP(8),"^",2),.IBY,60,20) + D SETVALM(.VALMCNT,.IBY) + ; + D SET("DRG:",.IBY,14,4) + D SET($$EX^IBATUTL(351.61,1.01,$P(IBDRG,"^")),.IBY,19,19) + D SET("DRG Charge:",.IBY,48,11) + D SET($FN($P(IBDRG,"^",2),"",2),.IBY,60,20) + D SETVALM(.VALMCNT,.IBY) + ; + D SET("Inpatient LOS:",.IBY,4,14) + D SET(+$P(IBDRG,"^",3),.IBY,19,19) + D SET("High Trim Days:",.IBY,44,15) + D SET(+$P(IBDRG,"^",4),.IBY,60,20) + D SETVALM(.VALMCNT,.IBY) + ; + D SET("Outlier Days:",.IBY,5,13) + D SET(+$P(IBDRG,"^",5),.IBY,19,19) + D SET("Outlier Rate:",.IBY,46,13) + D SET($FN($P(IBDRG,"^",6),"",2),.IBY,60,20) + D SETVALM(.VALMCNT,.IBY) + Q +OUT ; -- detail display for outpatient + N IBX,IBDXLIST,IBSCE,IBPROV,IBDATE + ; + D GETGEN^SDOE($P($P(IBDATA(0),"^",12),";"),"IBSCE") + D GETPRV^SDOE($P($P(IBDATA(0),"^",12),";"),"IBPROV") + ; + D GETDX^SDOE($P($P(IBDATA(0),"^",12),";"),"IBDXLIST") + S IBDATE=$P($G(IBDATA(0)),U,4) ; Event date + D DX(.IBDXLIST,IBDATE) + ; + D SET("Procedure Information:",.IBY,1,22) + D SETVALM(.VALMCNT,.IBY) + D CNTRL^VALM10(VALMCNT,1,22,IOINHI,IOINORM) + ; + S IBX=0 F S IBX=$O(^IBAT(351.61,IBIEN,3,IBX)) Q:IBX<1 D + . S IBX(0)=$G(^IBAT(351.61,IBIEN,3,IBX,0)) + . S IBX(1)=$$PROC^IBATUTL($P(IBX(0),U),IBDATE) + . ; + . D SET(+IBX(1),.IBY,5,6) + . D SET("-",.IBY,13,1) + . D SET($P(IBX(1),"^",2),.IBY,15,40) + . D SET(+$P(IBX(0),"^",2),.IBY,57,3) + . D SET("x",.IBY,62,1) + . D SET($FN($P(IBX(0),"^",3),"",2),.IBY,64,15) + . D SETVALM(.VALMCNT,.IBY) + D SETVALM(.VALMCNT,"") + ; + D SET("Visit Information:",.IBY,1,18) + D SETVALM(.VALMCNT,.IBY) + D CNTRL^VALM10(VALMCNT,1,22,IOINHI,IOINORM) + ; + D SET("Location:",.IBY,8,14) + D SET($P(^SC(+$P(IBSCE(0),"^",4),0),"^"),.IBY,19,46) ; dbia 10040 + D SETVALM(.VALMCNT,.IBY) + ; + D SETVALM(.VALMCNT,"") + D SET("Provider(s):",.IBY,5,17) + S IBX=0 F S IBX=$O(IBPROV(IBX)) Q:IBX<.5 D + . D SET($$GET1^DIQ(200,+IBPROV(IBX),.01),.IBY,19,49) ; dbia 10060 + . D SETVALM(.VALMCNT,.IBY) + ; + Q +RX ; -- detail display for rx + D SET("Drug:",.IBY,5,5) + D ZERO^IBRXUTL(+IBDATA(4)) + D SET(^TMP($J,"IBDRUG",+IBDATA(4),.01),.IBY,12,40) ; dbia 4533 + D SET(+$P(IBDATA(4),"^",2),.IBY,55,3) + D SET("x",.IBY,60,1) + D SET($FN($P(IBDATA(4),"^",3),"",3),.IBY,62,15) + D SETVALM(.VALMCNT,.IBY) + D SETVALM(.VALMCNT,"") + K ^TMP($J,"IBDRUG") + Q +RMPR ; -- detail display for prosthetic + D SETVALM(.VALMCNT,"") + D SET("Prosthetic Item:",.IBY,5,16) + D SET($$GET1^DIQ(661,$P(IBDATA(4),"^",4),.01),.IBY,12,40) ; dbia 374 + D SET($FN($P(IBDATA(4),"^",5),",",2),.IBY,55,15) + D SETVALM(.VALMCNT,.IBY) + D SETVALM(.VALMCNT,"") + Q +DX(IBDX,IBDATE) ; -- diagnosis info + N IBX + ; + D SETVALM(.VALMCNT,"") + D SET("Diagnosis Information:",.IBY,1,22) + D SETVALM(.VALMCNT,.IBY) + D CNTRL^VALM10(VALMCNT,1,22,IOINHI,IOINORM) + ; + S IBX=0 F S IBX=$O(IBDX(IBX)) Q:IBX<1 D + . S IBX(0)=$$ICD9^IBACSV(+IBDX(IBX),$G(IBDATE)) + . ; + . D SET($P(IBX(0),"^"),.IBY,5,7) + . D SET("-",.IBY,14,1) + . D SET($P(IBX(0),"^",3),.IBY,16,30) + . D SETVALM(.VALMCNT,.IBY) + D SETVALM(.VALMCNT,"") + Q +SET(TEXT,STRING,COL,LENGTH) ; -- set up string with valm1 + S STRING=$$SETSTR^VALM1($$LOWER^VALM1(TEXT),STRING,COL,LENGTH) + Q +SETVALM(LINE,TEXT) ; -- sets line for display + S LINE=LINE+1 + S ^TMP("IBATEE",$J,LINE,0)=TEXT + S TEXT="" + Q +DATE(X) ; -- returns date for display + Q $$FMTE^XLFDT(X,"5D") diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATO1.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATO1.m index f614b370..cfe29734 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATO1.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATO1.m @@ -1,210 +1,210 @@ -IBATO1 ;LL/ELZ - TRANSFER PRICING REPORTS CONT. ; 18-DEC-98 - ;;2.0;INTEGRATED BILLING;**115,266,389**;21-MAR-94;Build 6 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -PAGE() ; performs page reads and returns 1 if quiting is needed - N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT - S DIR(0)="E" D ^DIR - Q $D(DIRUT) -NUM(X,X2,X3) ; calls to format numbers - D COMMA^%DTC - Q $E(X,1,$L(X)-1) -UNIT(IBA,IBD,IBO) ; sets IBD subscripted with units for IBA - N IBX,IBB S IBB="UNIT" - I $P(IBA(0),"^",12)["DGPM" D Q - . S IBD(1,IBO,IBB)=$$EX^IBATUTL(351.61,1.01,+IBA(1)) - I $P(IBA(0),"^",12)["PSRX(" D Q - . S IBD(1,IBO,IBB)=$$EX^IBATUTL(52,.01,+$P(IBA(0),"^",12)) - I $P(IBA(0),"^",12)["RMPR" D Q - . S IBD(1,IBO,IBB)="PROSTHETIC" - S IBX=0 F S IBX=$O(^IBAT(351.61,IBA,3,IBX)) Q:IBX<1 D - . S IBX(0)=^IBAT(351.61,IBIEN,3,IBX,0) - . S IBD(IBX,IBO,IBB)="CPT"_$P($$PROC^IBATUTL(+IBX(0)),U) - Q -TYPE(IBA,IBO) ; sets IBO with descriptive trans type for IBA - N IBB,IBC,IBD - S:'$D(IBA(0)) IBA(0)=^IBAT(351.61,IBA,0) - S IBB=$P(IBA(0),"^",12) - I IBB["DGPM(" S IBO="INPATIENT" Q - I IBB["PSRX(" S IBO="PHARMACY" Q - I IBB["RMPR(660," S IBO="PROSTHETICS" Q - D GETGEN^SDOE(+$P(IBA(0),"^",12),"IBC") - D:$P($G(IBC(0)),"^",3) PARSE^SDOE(.IBC,"EXTERNAL","IBD") - S IBO=$S($G(IBD(.03))="":"OUTPATINET",1:$E("OUT "_IBD(.03),1,10)) - Q -DES(IBA,IBD,IBO) ; sets IBD subscripted with description for IBA - N IBX,IBB,IBDATE S IBB="UNIT DESCRIPTION" - I $P(IBA(0),"^",12)["DGPM" D Q - . S IBD(1,IBO,IBB)=$E($$DRGTD^IBACSV(+IBA(1),$P(IBA(0),U,4)),1,18) - I $P(IBA(0),"^",12)["PSRX(" D Q - . S IBD(1,IBO,IBB)=$E($$EX^IBATUTL(351.61,4.01,+IBA(4)),1,18) - I $P(IBA(0),"^",12)["RMPR(660," D Q - . S IBD(1,IBO,IBB)=$E($P($$PIN^IBATUTL(+$P(IBA(0),"^",12)),U,2),1,18) - S IBDATE=$P($G(^IBAT(351.61,IBIEN,0)),U,4) ; Event Date - S IBX=0 F S IBX=$O(^IBAT(351.61,IBA,3,IBX)) Q:IBX<1 D - . S IBX(0)=^IBAT(351.61,IBIEN,3,IBX,0) - . S IBD(IBX,IBO,IBB)=$E($P($$PROC^IBATUTL(+IBX(0),IBDATE),U,2),1,18) - Q -PRICE(IBA,IBD,IBO) ; sets IBD subscripted with price for IBA - N IBX,IBB S IBB="UNIT PRICE" - I $P(IBA(0),"^",12)["DGPM" D Q - . S IBD(1,IBO,IBB)=$$NUM($P(IBA(1),"^",2),2,9) - I $P(IBA(0),"^",12)["PSRX(" D Q - . S IBD(1,IBO,IBB)=$$NUM($P(IBA(4),"^",3),3,10) - I $P(IBA(0),"^",12)["RMPR(660," D Q - . S IBD(1,IBO,IBB)=$$NUM($P(IBA(4),"^",5),3,10) - S IBX=0 F S IBX=$O(^IBAT(351.61,IBA,3,IBX)) Q:IBX<1 D - . S IBX(0)=^IBAT(351.61,IBIEN,3,IBX,0) - . S IBD(IBX,IBO,IBB)=$$NUM($P(IBX(0),"^",3),2,9) - Q -QTY(IBA,IBD,IBO) ; sets IBD subscripted with quantity for IBA - N IBX,IBB S IBB="QTY" - I $P(IBA(0),"^",12)["DGPM" D Q - . S IBD(1,IBO,IBB)=$$NUM($P(IBA(1),"^",5),0,3) - I $P(IBA(0),"^",12)["PSRX(" D Q - . S IBD(1,IBO,IBB)=$$NUM($P(IBA(4),"^",2),0,3) - I $P(IBA(0),"^",12)["RMPR(660," D Q - . S IBD(1,IBO,IBB)=$$NUM(1,0,3) - S IBX=0 F S IBX=$O(^IBAT(351.61,IBA,3,IBX)) Q:IBX<1 D - . S IBX(0)=^IBAT(351.61,IBIEN,3,IBX,0) - . S IBD(IBX,IBO,IBB)=$$NUM($P(IBX(0),"^",2),0,3) - Q -COPAY(IBA) ; compute copay for iba and return - N IBC,IBT,IBCOPAY - S IBCOPAY=$$COPAY^IBATUTL($P(IBA(0),"^",2),$P(IBA(0),"^",12),$P($P(IBA(0),"^",9),"."),$P($P(IBA(0),"^",10),".")) - I IBCOPAY,$P(IBA(0),"^",12)["SCE(" S (IBC,IBT)=0 F S IBT=$O(^IBAT(351.61,"AH",$P(IBA(0),"^",2),$P(IBA(0),"^",4),IBT)) Q:IBT<1 I $P(^IBAT(351.61,IBT,0),"^",12)["SCE(" S IBC=IBC+1 - I S IBCOPAY=IBCOPAY/IBC - Q $$NUM(IBCOPAY,2,7) - ; -VAR(IBA) ; set up required variables - N IBX - F IBX=0,1,4 S IBA(IBX)=$G(^IBAT(351.61,IBA,IBX)) - Q -PRT(IBIEN) ; main entry for report printing - ; - N DFN,IBXDATA,IBC,IBF,IBF1,IBF2,IBO,VA,VAERR,IBM - ; - D VAR(.IBIEN) - S DFN=$P(IBIEN(0),"^",2) - I IBPAGE=0!($Y+5>IOSL)!(IBLAST'=$P(IBIEN(0),"^",11)) S IBLAST=$P(IBIEN(0),"^",11) D PRTH Q:IBQUIT - W ! S IBC=0 - ; - ; print single valued data first - S IBF=0 F S IBF=$O(IBFIELD(IBF)) Q:IBF<1 D - . D PRTG(.IBFIELD,.IBF,.IBF1,.IBC) - . X ^IBAT(351.62,IBF1,1) - . W IBXDATA,?IBC - ; - ; compute multiple valued data - S IBM=IBC - S IBF=0 F S IBF=$O(IBMUL(IBF)) Q:IBF<1 D - . S IBF1=0,IBF1=$O(IBMUL(IBF,IBF1)) - . X ^IBAT(351.62,IBF1,1) - ; - ; print multiple valued data - S IBF=0 F S IBF=$O(IBXDATA(IBF)) Q:IBF="" W:IBC'=IBM ! W ?IBM S IBC=IBM D - . S IBO=0 F S IBO=$O(IBXDATA(IBF,IBO)) Q:IBO<1 S IBF1=0 F S IBF1=$O(IBXDATA(IBF,IBO,IBF1)) Q:IBF1="" D - .. S IBF2=0,IBF2=$O(^IBAT(351.62,"B",IBF1,IBF2)) - .. S IBF2=^IBAT(351.62,IBF2,0) - .. S IBC=IBC+$P(IBF2,"^",2)+1 - .. I IBC>IOM W !?5 S IBC=$P(IBF2,"^",2)+6 - .. W IBXDATA(IBF,IBO,IBF1),?IBC - ; - ; clean up - X ^IBAT(351.62,999,1) - ; - Q -EXPRT(IBIEN) ; main entry for excel printing - ; - N DFN,IBXDATA,IBF,IBF1,IBF2,IBO,VA,VAERR - ; - D VAR(.IBIEN) - S DFN=$P(IBIEN(0),"^",2) - ; - ; do single if no multiple - I '$D(IBMUL) D EXSING() W ! X ^IBAT(351.62,999,1) Q - ; - ; compute multiple valued data - S IBF=0 F S IBF=$O(IBMUL(IBF)) Q:IBF<1 D - . S IBF1=0,IBF1=$O(IBMUL(IBF,IBF1)) - . X ^IBAT(351.62,IBF1,1) - ; - ; print multiple valued data - S IBF=0 F S IBF=$O(IBXDATA(IBF)) Q:IBF="" D EXSING(IBF) D - . S IBO=0 F S IBO=$O(IBXDATA(IBF,IBO)) Q:IBO<1 S IBF1=0 F S IBF1=$O(IBXDATA(IBF,IBO,IBF1)) Q:IBF1="" D - .. S IBF2=0,IBF2=$O(^IBAT(351.62,"B",IBF1,IBF2)) - .. S IBF2=^IBAT(351.62,IBF2,0) - .. W $$STRIP(IBXDATA(IBF,IBO,IBF1),IBF2),"|" - . W ! - ; - ; clean up - X ^IBAT(351.62,999,1) - ; - Q -STRIP(A,B) ; strips off junk from numbers - Q $S($P(B,"^",5):+$TR(A,", "),1:A) - ; -EXSING(IBF) ; print single valued data first - S IBF=0 F S IBF=$O(IBFIELD(IBF)) Q:IBF<1 D - . D PRTG(.IBFIELD,.IBF,.IBF1,.IBC) - . X ^IBAT(351.62,IBF1,1) - . W $$STRIP(IBXDATA,IBF1(0)),"|" - Q - ; -PRTH ; header - S IBC=0 - D HEAD^IBATO($P(IBIEN(0),"^",11)) Q:IBQUIT - W ! - S IBF=0 F S IBF=$O(IBFIELD(IBF)) Q:IBF<1 D - . D PRTG(.IBFIELD,.IBF,.IBF1,.IBC) - . W $P(IBF1(0),"^"),?IBC - ; - ; multiple part of header - S IBF=0 F S IBF=$O(IBMUL(IBF)) Q:IBF<1 D - . D PRTG(.IBMUL,.IBF,.IBF1,.IBC) - . W $P(IBF1(0),"^"),?IBC - ; - W ! F IBC=1:1:IOM W "-" - Q -PRTG(X,Y,Z,C) ; general printing stuff - S Z=0,Z=$O(X(Y,Z)) - S Z(0)=X(Y,Z) - I $D(C) S C=C+$P(Z(0),"^",2)+1 I C>IOM W !?5 S C=$P(Z(0),"^",2)+6 - Q -SEL(B) ; selection of which fields B = default - ; sets up variables IBFIELD and IBMUL - ; returns max length of output - ; - N DTOUT,DUOUT,DIRUT,DIROUT,DIR,W,X,Y,Z,IBR,IBM - S (IBR,IBM)=0 - ; -AGAIN S DIR(0)="LAO^1:98",DIR("A")="Which fields: "_$S($D(B):B_"//",1:"") - S DIR("?")="Select what fields you want printed. Ranges must start with a valid number." - D ^DIR Q:$D(DTOUT)!($D(DUOUT))!($D(DIROUT)) 0 - ; - ; if default selected set Y - S:Y="" Y=$G(B) - ; - ; validate input - I '$D(^IBAT(351.62,"AC",+Y)) W *7,"??" G AGAIN - F X=1:1 Q:$P(Y,",",X)="" S:'$D(^IBAT(351.62,"AC",$P(Y,",",X))) Y=$P(Y,",",1,X-1)_","_$P(Y,",",X+1,98),X=X-1 - ; - ; setup variables for output - F X=1:1 Q:'$P(Y,",",X) S W=+$P($Q(^IBAT(351.62,"AC",$P(Y,",",X))),",",4),Z=^IBAT(351.62,W,0),IBR=$S($P(Z,"^",3):"IBMUL",1:"IBFIELD"),@(IBR_"("_X_","_W_")")=Z,@IBR=$G(@IBR)+$P(Z,"^",2)+1 - ; - Q $G(IBFIELD)+$G(IBMUL) - ; -DISP ; displays fields for selection - ; - N IBX,IBL,IBI - ; - ; set up lines - S (IBX,IBL)=0 F S IBX=$O(^IBAT(351.62,"AC",IBX)),IBL=IBL+1 Q:IBX<1 S:IBX=40 IBL=1 S IBI=+$P($Q(^IBAT(351.62,"AC",IBX)),",",4),IBL(IBL,$S(IBX<40:0,1:40))=^IBAT(351.62,IBI,0) - ; - ; display lines - W @IOF,!,"Select the fields you would like printed on this report, in the order you",!,"want them printed. Fields with an asterisk (*) are fields that are multiples.",! - S IBX="" F S IBX=$O(IBL(IBX)) Q:IBX="" W ! S IBI="" F S IBI=$O(IBL(IBX,IBI)) Q:IBI="" W ?IBI,$P(IBL(IBX,IBI),"^",4),?IBI+4,$S($P(IBL(IBX,IBI),"^",3):"*",1:""),$P(IBL(IBX,IBI),"^") - ; - W ! - ; - Q +IBATO1 ;LL/ELZ - TRANSFER PRICING REPORTS CONT. ; 18-DEC-98 + ;;2.0;INTEGRATED BILLING;**115,266**;21-MAR-94 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; +PAGE() ; performs page reads and returns 1 if quiting is needed + N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT + S DIR(0)="E" D ^DIR + Q $D(DIRUT) +NUM(X,X2,X3) ; calls to format numbers + D COMMA^%DTC + Q $E(X,1,$L(X)-1) +UNIT(IBA,IBD,IBO) ; sets IBD subscripted with units for IBA + N IBX,IBB S IBB="UNIT" + I $P(IBA(0),"^",12)["DGPM" D Q + . S IBD(1,IBO,IBB)=$$EX^IBATUTL(351.61,1.01,+IBA(1)) + I $P(IBA(0),"^",12)["PSRX(" D Q + . S IBD(1,IBO,IBB)=$$EX^IBATUTL(52,.01,+$P(IBA(0),"^",12)) + I $P(IBA(0),"^",12)["RMPR" D Q + . S IBD(1,IBO,IBB)="PROSTHETIC" + S IBX=0 F S IBX=$O(^IBAT(351.61,IBA,3,IBX)) Q:IBX<1 D + . S IBX(0)=^IBAT(351.61,IBIEN,3,IBX,0) + . S IBD(IBX,IBO,IBB)="CPT"_$P($$PROC^IBATUTL(+IBX(0)),U) + Q +TYPE(IBA,IBO) ; sets IBO with descriptive trans type for IBA + N IBB,IBC,IBD + S:'$D(IBA(0)) IBA(0)=^IBAT(351.61,IBA,0) + S IBB=$P(IBA(0),"^",12) + I IBB["DGPM(" S IBO="INPATIENT" Q + I IBB["PSRX(" S IBO="PHARMACY" Q + I IBB["RMPR(660," S IBO="PROSTHETICS" Q + D GETGEN^SDOE(+$P(IBA(0),"^",12),"IBC") + D:$P($G(IBC(0)),"^",3) PARSE^SDOE(.IBC,"EXTERNAL","IBD") + S IBO=$S($G(IBD(.03))="":"OUTPATINET",1:$E("OUT "_IBD(.03),1,10)) + Q +DES(IBA,IBD,IBO) ; sets IBD subscripted with description for IBA + N IBX,IBB,IBDATE S IBB="UNIT DESCRIPTION" + I $P(IBA(0),"^",12)["DGPM" D Q + . S IBD(1,IBO,IBB)=$E($$DRGTD^IBACSV(+IBA(1),$P(IBA(0),U,4)),1,18) + I $P(IBA(0),"^",12)["PSRX(" D Q + . S IBD(1,IBO,IBB)=$E($$EX^IBATUTL(351.61,4.01,+IBA(4)),1,18) + I $P(IBA(0),"^",12)["RMPR(660," D Q + . S IBD(1,IBO,IBB)=$E($$EX^IBATUTL(351.61,4.04,$P(IBA(4),"^",4)),1,18) + S IBDATE=$P($G(^IBAT(351.61,IBIEN,0)),U,4) ; Event Date + S IBX=0 F S IBX=$O(^IBAT(351.61,IBA,3,IBX)) Q:IBX<1 D + . S IBX(0)=^IBAT(351.61,IBIEN,3,IBX,0) + . S IBD(IBX,IBO,IBB)=$E($P($$PROC^IBATUTL(+IBX(0),IBDATE),U,2),1,18) + Q +PRICE(IBA,IBD,IBO) ; sets IBD subscripted with price for IBA + N IBX,IBB S IBB="UNIT PRICE" + I $P(IBA(0),"^",12)["DGPM" D Q + . S IBD(1,IBO,IBB)=$$NUM($P(IBA(1),"^",2),2,9) + I $P(IBA(0),"^",12)["PSRX(" D Q + . S IBD(1,IBO,IBB)=$$NUM($P(IBA(4),"^",3),3,10) + I $P(IBA(0),"^",12)["RMPR(660," D Q + . S IBD(1,IBO,IBB)=$$NUM($P(IBA(4),"^",5),3,10) + S IBX=0 F S IBX=$O(^IBAT(351.61,IBA,3,IBX)) Q:IBX<1 D + . S IBX(0)=^IBAT(351.61,IBIEN,3,IBX,0) + . S IBD(IBX,IBO,IBB)=$$NUM($P(IBX(0),"^",3),2,9) + Q +QTY(IBA,IBD,IBO) ; sets IBD subscripted with quantity for IBA + N IBX,IBB S IBB="QTY" + I $P(IBA(0),"^",12)["DGPM" D Q + . S IBD(1,IBO,IBB)=$$NUM($P(IBA(1),"^",5),0,3) + I $P(IBA(0),"^",12)["PSRX(" D Q + . S IBD(1,IBO,IBB)=$$NUM($P(IBA(4),"^",2),0,3) + I $P(IBA(0),"^",12)["RMPR(660," D Q + . S IBD(1,IBO,IBB)=$$NUM(1,0,3) + S IBX=0 F S IBX=$O(^IBAT(351.61,IBA,3,IBX)) Q:IBX<1 D + . S IBX(0)=^IBAT(351.61,IBIEN,3,IBX,0) + . S IBD(IBX,IBO,IBB)=$$NUM($P(IBX(0),"^",2),0,3) + Q +COPAY(IBA) ; compute copay for iba and return + N IBC,IBT,IBCOPAY + S IBCOPAY=$$COPAY^IBATUTL($P(IBA(0),"^",2),$P(IBA(0),"^",12),$P($P(IBA(0),"^",9),"."),$P($P(IBA(0),"^",10),".")) + I IBCOPAY,$P(IBA(0),"^",12)["SCE(" S (IBC,IBT)=0 F S IBT=$O(^IBAT(351.61,"AH",$P(IBA(0),"^",2),$P(IBA(0),"^",4),IBT)) Q:IBT<1 I $P(^IBAT(351.61,IBT,0),"^",12)["SCE(" S IBC=IBC+1 + I S IBCOPAY=IBCOPAY/IBC + Q $$NUM(IBCOPAY,2,7) + ; +VAR(IBA) ; set up required variables + N IBX + F IBX=0,1,4 S IBA(IBX)=$G(^IBAT(351.61,IBA,IBX)) + Q +PRT(IBIEN) ; main entry for report printing + ; + N DFN,IBXDATA,IBC,IBF,IBF1,IBF2,IBO,VA,VAERR,IBM + ; + D VAR(.IBIEN) + S DFN=$P(IBIEN(0),"^",2) + I IBPAGE=0!($Y+5>IOSL)!(IBLAST'=$P(IBIEN(0),"^",11)) S IBLAST=$P(IBIEN(0),"^",11) D PRTH Q:IBQUIT + W ! S IBC=0 + ; + ; print single valued data first + S IBF=0 F S IBF=$O(IBFIELD(IBF)) Q:IBF<1 D + . D PRTG(.IBFIELD,.IBF,.IBF1,.IBC) + . X ^IBAT(351.62,IBF1,1) + . W IBXDATA,?IBC + ; + ; compute multiple valued data + S IBM=IBC + S IBF=0 F S IBF=$O(IBMUL(IBF)) Q:IBF<1 D + . S IBF1=0,IBF1=$O(IBMUL(IBF,IBF1)) + . X ^IBAT(351.62,IBF1,1) + ; + ; print multiple valued data + S IBF=0 F S IBF=$O(IBXDATA(IBF)) Q:IBF="" W:IBC'=IBM ! W ?IBM S IBC=IBM D + . S IBO=0 F S IBO=$O(IBXDATA(IBF,IBO)) Q:IBO<1 S IBF1=0 F S IBF1=$O(IBXDATA(IBF,IBO,IBF1)) Q:IBF1="" D + .. S IBF2=0,IBF2=$O(^IBAT(351.62,"B",IBF1,IBF2)) + .. S IBF2=^IBAT(351.62,IBF2,0) + .. S IBC=IBC+$P(IBF2,"^",2)+1 + .. I IBC>IOM W !?5 S IBC=$P(IBF2,"^",2)+6 + .. W IBXDATA(IBF,IBO,IBF1),?IBC + ; + ; clean up + X ^IBAT(351.62,999,1) + ; + Q +EXPRT(IBIEN) ; main entry for excel printing + ; + N DFN,IBXDATA,IBF,IBF1,IBF2,IBO,VA,VAERR + ; + D VAR(.IBIEN) + S DFN=$P(IBIEN(0),"^",2) + ; + ; do single if no multiple + I '$D(IBMUL) D EXSING() W ! X ^IBAT(351.62,999,1) Q + ; + ; compute multiple valued data + S IBF=0 F S IBF=$O(IBMUL(IBF)) Q:IBF<1 D + . S IBF1=0,IBF1=$O(IBMUL(IBF,IBF1)) + . X ^IBAT(351.62,IBF1,1) + ; + ; print multiple valued data + S IBF=0 F S IBF=$O(IBXDATA(IBF)) Q:IBF="" D EXSING(IBF) D + . S IBO=0 F S IBO=$O(IBXDATA(IBF,IBO)) Q:IBO<1 S IBF1=0 F S IBF1=$O(IBXDATA(IBF,IBO,IBF1)) Q:IBF1="" D + .. S IBF2=0,IBF2=$O(^IBAT(351.62,"B",IBF1,IBF2)) + .. S IBF2=^IBAT(351.62,IBF2,0) + .. W $$STRIP(IBXDATA(IBF,IBO,IBF1),IBF2),"|" + . W ! + ; + ; clean up + X ^IBAT(351.62,999,1) + ; + Q +STRIP(A,B) ; strips off junk from numbers + Q $S($P(B,"^",5):+$TR(A,", "),1:A) + ; +EXSING(IBF) ; print single valued data first + S IBF=0 F S IBF=$O(IBFIELD(IBF)) Q:IBF<1 D + . D PRTG(.IBFIELD,.IBF,.IBF1,.IBC) + . X ^IBAT(351.62,IBF1,1) + . W $$STRIP(IBXDATA,IBF1(0)),"|" + Q + ; +PRTH ; header + S IBC=0 + D HEAD^IBATO($P(IBIEN(0),"^",11)) Q:IBQUIT + W ! + S IBF=0 F S IBF=$O(IBFIELD(IBF)) Q:IBF<1 D + . D PRTG(.IBFIELD,.IBF,.IBF1,.IBC) + . W $P(IBF1(0),"^"),?IBC + ; + ; multiple part of header + S IBF=0 F S IBF=$O(IBMUL(IBF)) Q:IBF<1 D + . D PRTG(.IBMUL,.IBF,.IBF1,.IBC) + . W $P(IBF1(0),"^"),?IBC + ; + W ! F IBC=1:1:IOM W "-" + Q +PRTG(X,Y,Z,C) ; general printing stuff + S Z=0,Z=$O(X(Y,Z)) + S Z(0)=X(Y,Z) + I $D(C) S C=C+$P(Z(0),"^",2)+1 I C>IOM W !?5 S C=$P(Z(0),"^",2)+6 + Q +SEL(B) ; selection of which fields B = default + ; sets up variables IBFIELD and IBMUL + ; returns max length of output + ; + N DTOUT,DUOUT,DIRUT,DIROUT,DIR,W,X,Y,Z,IBR,IBM + S (IBR,IBM)=0 + ; +AGAIN S DIR(0)="LAO^1:98",DIR("A")="Which fields: "_$S($D(B):B_"//",1:"") + S DIR("?")="Select what fields you want printed. Ranges must start with a valid number." + D ^DIR Q:$D(DTOUT)!($D(DUOUT))!($D(DIROUT)) 0 + ; + ; if default selected set Y + S:Y="" Y=$G(B) + ; + ; validate input + I '$D(^IBAT(351.62,"AC",+Y)) W *7,"??" G AGAIN + F X=1:1 Q:$P(Y,",",X)="" S:'$D(^IBAT(351.62,"AC",$P(Y,",",X))) Y=$P(Y,",",1,X-1)_","_$P(Y,",",X+1,98),X=X-1 + ; + ; setup variables for output + F X=1:1 Q:'$P(Y,",",X) S W=+$P($Q(^IBAT(351.62,"AC",$P(Y,",",X))),",",4),Z=^IBAT(351.62,W,0),IBR=$S($P(Z,"^",3):"IBMUL",1:"IBFIELD"),@(IBR_"("_X_","_W_")")=Z,@IBR=$G(@IBR)+$P(Z,"^",2)+1 + ; + Q $G(IBFIELD)+$G(IBMUL) + ; +DISP ; displays fields for selection + ; + N IBX,IBL,IBI + ; + ; set up lines + S (IBX,IBL)=0 F S IBX=$O(^IBAT(351.62,"AC",IBX)),IBL=IBL+1 Q:IBX<1 S:IBX=40 IBL=1 S IBI=+$P($Q(^IBAT(351.62,"AC",IBX)),",",4),IBL(IBL,$S(IBX<40:0,1:40))=^IBAT(351.62,IBI,0) + ; + ; display lines + W @IOF,!,"Select the fields you would like printed on this report, in the order you",!,"want them printed. Fields with an asterisk (*) are fields that are multiples.",! + S IBX="" F S IBX=$O(IBL(IBX)) Q:IBX="" W ! S IBI="" F S IBI=$O(IBL(IBX,IBI)) Q:IBI="" W ?IBI,$P(IBL(IBX,IBI),"^",4),?IBI+4,$S($P(IBL(IBX,IBI),"^",3):"*",1:""),$P(IBL(IBX,IBI),"^") + ; + W ! + ; + Q diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATUTL.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATUTL.m index a7d2d844..4f90c246 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATUTL.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATUTL.m @@ -1,175 +1,167 @@ -IBATUTL ;LL/ELZ - TRANSFER PRICING UTILITES ; 3-SEP-1998 - ;;2.0;INTEGRATED BILLING;**115,266,347,389**;21-MAR-94;Build 6 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -SL() ; -- called to select a patient or enrolled facility - N X,Y,DTOUT,DUOUT,DIRUT,DIROUT,DIR - S DIR(0)="350.9,10.01",DIR("A")="Select Patient or Enrolled Facility" - D ^DIR - Q Y -SLPT() ; -- called to select a patient, returns 0 or patient dfn - N X,Y,DIC,DTOUT,DUOUT - S DIC="^IBAT(351.6,",DIC(0)="AEMQ" D ^DIC - Q $S(+Y>0:+Y,1:0) - ; -SLDR(Q) ; -- called to select a date range - ; defaults are from=T-365, to=TODAY - ; output IBBDT, IBEDT, quit returns 0 if not valid - ; - N DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y,IBDT - S DIR(0)="DA^:NOW:EX",DIR("A")="Select FROM DATE: " - S:$D(Q) DIR("?")=Q - D ^DIR G:'Y SLDRQ S IBDT=+Y - S DIR(0)="DA^"_+Y_":NOW:EX",DIR("A")=" TO: " - D ^DIR - S:Y IBEDT=+Y+.999999,IBBDT=IBDT G SLDRQ -SLDR1Y() ; -- called to select a date range w/1y past default - ; defaults are from=T-365, to=TODAY - ; output IBBDT, IBEDT, quit returns 0 if not valid - ; - N DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y,IBDT - S DIR(0)="DA^:NOW:EX",DIR("A")="Select FROM DATE: " - S DIR("B")=$$DAT2^IBOUTL($$FMADD^XLFDT(DT,-365)) D ^DIR - G:'Y SLDRQ S IBDT=+Y - S DIR(0)="DA^"_+Y_":NOW:EX",DIR("A")=" to: " - S DIR("B")=$$DAT2^IBOUTL($$FMADD^XLFDT(IBDT,365)) D ^DIR - G:'Y SLDRQ S IBEDT=+Y+.999999,IBBDT=IBDT -SLDRQ Q $D(DIRUT)!($D(DUOUT)) - ; -PTTRAN(IBFILE,IBARRAY,IBXREF) ; builds a list of patient transactions by date - ; assumes DFN, IBBDT, IBEDT - ; input IBARRAY - where to store info - ; IBXREF - which date x-ref to use - ; output 0,6 node of file IBFILE in array specified - ; - N IBIEN,IBDT,IBNODE - K @IBARRAY - S IBDT=IBBDT-.999999 - F S IBDT=$O(^IBAT(IBFILE,IBXREF,DFN,IBDT)) Q:IBDT<1!(IBDT>IBEDT) D - . S IBIEN=0 - . F S IBIEN=$O(^IBAT(IBFILE,IBXREF,DFN,IBDT,IBIEN)) Q:IBIEN<1 D - .. F IBNODE=0,6 S @IBARRAY@(IBDT,IBIEN,IBNODE)=$G(^IBAT(IBFILE,IBIEN,IBNODE)) - Q -LMOPT ; -- called to do standard listmanager option calling - D FULL^VALM1 - S VALMBCK="R" - Q - ; -SETVALM(LINE,TEXT,IEN,ON,OFF) ; -- sets up listmanager lines - S LINE=LINE+1 - D SET^VALM10(LINE,TEXT,LINE) - S:$G(IEN) @VALMAR@("INDEX",LINE,IEN)="" - D:$G(ON)]""!($G(OFF)]"") CNTRL^VALM10(LINE,1,$L(TEXT),$G(ON),$G(OFF)) - W:'(LINE#5) "." - Q LINE - ; -VISN(STATION) ; -- looks up ien & name of VISN from ien of station - N IBAT - D PARENT^XUAF4("IBAT","`"_STATION,"VISN") - S IBAT=0,IBAT=$O(IBAT("P",IBAT)) - Q $S(IBAT:IBAT_"^"_$P(IBAT("P",IBAT),"^"),1:"") - ; -ONEFAC() ; returns one facility only, no visns allowed - N DIC,DTOUT,DUOUT,X,Y - S DIC="^DIC(4,",DIC(0)="AEMNQ" - S DIC("S")="I $$SCR^IBATUTL(Y),$$INST^IBATUTL(Y)'[""VISN""" - D ^DIC - Q Y -FAC() ; -- facility/visn or all selection - N DIC,X,Y,DTOUT,DUOUT K IBFAC - S DIC="^DIC(4,",DIC(0)="EQMNZ" - S DIC("S")="I $$SCR^IBATUTL(Y)" -REDO W !,"Select FACILITY/VISN: ALL// " R X:DTIME Q:(X["^")!'$T 1 - I X="?" W !,"Select a Facility (Name or Number), VISN (VISN XX), or press RETURN for ALL" G REDO - I X=""!($$UP^XLFSTR(X)="ALL") Q 0 - D ^DIC G:Y<1 REDO D SET(Y) - S DIC("A")="Select another FACILITY/VISN: ",DIC(0)="AEQMNZ" - F D ^DIC Q:X=""!(Y<1) D SET(Y) - Q 0 -SET(Y) I Y'["VISN" N IBVISN D PARENT^XUAF4("IBVISN","`"_+Y,"VISN") D - . S IBVISN=0,IBVISN=$O(IBVISN("P",IBVISN)) - . S IBFAC(IBVISN,"C",+Y)=$$INST(+Y) - E S IBFAC(+Y)="" D CHILDREN^XUAF4("IBFAC(+Y)","`"_+Y,"VISN") - Q -SCR(X) ; screens invalid institution file entries - N IBVISN - ;Q:$P(X,".",2) 0 - D PARENT^XUAF4("IBVISN","`"_X,"VISN") - S IBVISN=0,IBVISN=$O(IBVISN("P",IBVISN)) I IBVISN Q 1 - D CHILDREN^XUAF4("IBVISN","`"_X,"VISN") - S IBVISN=0,IBVISN=$O(IBVISN("C",IBVISN)) I IBVISN Q 1 - Q 0 -PPF(DFN) ; returns patient's enrolled/preferred facility - N IBPPF - ; first find current enrolment - S IBPPF=+$$PREF^DGENPTA(DFN) ; dbia #2919 - ; now if they are already tp update if necessary - I $D(^IBAT(351.6,DFN)),$P(^(DFN,0),"^",3)'=IBPPF D UPPPF^IBATFILE(DFN,IBPPF) - ; now if they have an over ride facility use that - Q $S($P($G(^IBAT(351.6,DFN,0)),"^",10):$P(^(0),"^",10),IBPPF=$$SITE:0,1:IBPPF) -TPP(DFN) ; returns dfn and files patient if a valid tp patient - N IBSITE,IBPPF - S IBSITE=$$SITE - S IBPPF=$$PPF(DFN) - I IBPPF,IBSITE'=IBPPF S DFN=+$$PAT^IBATFILE(DFN,IBPPF) - I DFN,$P($G(^IBAT(351.6,DFN,0)),"^",4) Q DFN - Q 0 -SITE() ; returns ien of current va site (this way I have only one outside call - Q +$$SITE^VASITE - ; -INST(DA) ; returns institution file info - ; This will return the station name ^ station number ^ station type - ; DA - The pointer value into file 4. - I '$D(^DIC(4,DA,0)) Q 0 - Q $$NNT^XUAF4(DA) -IPT(X) ; returns institution file pointer from name - Q $$LKUP^XUAF4(X) -PROC(X,IBDATE) ; -- returns CPT and descriptive name for cpts - S X=$$CPT^ICPTCOD(X,$G(IBDATE)) - Q $P(X,"^",2,3) -COPAY(DFN,IBFROM,IBBDT,IBEDT) ; -- returns copay amount if any - ; dfn=patient's dfn, from=what event the bill is from - ; ibbdt & ibedt are date ranges (n/a for rx) - N IBAMT,Y,Y1,IBDA,IBX S IBAMT=0 - I IBFROM["PSRX(" D Q IBAMT - . I $P(IBFROM,";",3)>0 D Q - .. ; refills - .. S IBFROM=$$SUBFILE^IBRXUTL(+IBFROM,$P(IBFROM,";",3),52,9) I 'IBFROM Q - .. S IBAMT=$P($G(^IB(IBFROM,0)),"^",7) - . E D Q - .. ; initial fill - .. S IBFROM=$$FILE^IBRXUTL(+IBFROM,106) I 'IBFROM Q - .. S IBAMT=$P($G(^IB(IBFROM,0)),"^",7) - ; now on to scheduling and admissions - S Y="" F S Y=$O(^IB("AFDT",DFN,Y)) Q:'Y I -Y'>IBEDT S Y1=0 F S Y1=$O(^IB("AFDT",DFN,Y,Y1)) Q:'Y1 D - . S IBDA=0 F S IBDA=$O(^IB("AF",Y1,IBDA)) Q:'IBDA D - .. Q:'$D(^IB(IBDA,0)) S IBX=^(0) - .. Q:$P(IBX,"^",8)["ADMISSION" - .. ; - .. ; quit if not correct type (inpatient vs outpatient) - .. Q:$S(IBFROM["SCE("&($P($P(IBX,"^",4),":")'=409.68):1,IBFROM["DGPM("&($P($P(IBX,"^",4),":")=409.68):1,1:0) - .. ; - .. I $P(IBX,"^",15)IBEDT) Q - .. S IBAMT=IBAMT+$P(IBX,"^",7) - Q IBAMT -FINDT(X) ; -- looks up transactions for source in X - ; returns ien of 351.61 if not cancelled - Q:$G(X)="" 0 - N Y,Z S (Y,Z)=0 - F S Y=$O(^IBAT(351.61,"AD",X,Y)) Q:Y<1!(Z) D - . I $G(^IBAT(351.61,Y,0)),$P(^(0),"^",5)'="X" S Z=Y - Q Z - ; -PIN(P660,P6611) ; return Prosthetics Item Description (#661.1,.02) - ; input: P660 - pointer to Patient Item (#660) or P6611 - pointer to HCPCS (#661.1) - ; return: pointer to HCPCS (#661.1) ^ Short Description (#661.1,.01) ^ HCPCS (#661.1,.01) - N IBX,IBY S IBY="" - I +$G(P660) S P6611=+$P($G(^RMPR(660,+P660,1)),U,4) - I +$G(P6611) S IBX=$G(^RMPR(661.1,+P6611,0)) I IBX'="" S IBY=P6611_U_$P(IBX,U,2)_U_$P(IBX,U,1) - Q IBY - ; -EX(FILE,FIELD,VALUE) ; -- return external value - N Y,C S Y=$G(VALUE) - I +$G(FILE),+$G(FIELD),Y'="" S C=$P(^DD(FILE,FIELD,0),"^",2) D Y^DIQ - Q Y - ; +IBATUTL ;LL/ELZ - TRANSFER PRICING UTILITES ; 3-SEP-1998 + ;;2.0;INTEGRATED BILLING;**115,266,347**;21-MAR-94;Build 24 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; +SL() ; -- called to select a patient or enrolled facility + N X,Y,DTOUT,DUOUT,DIRUT,DIROUT,DIR + S DIR(0)="350.9,10.01",DIR("A")="Select Patient or Enrolled Facility" + D ^DIR + Q Y +SLPT() ; -- called to select a patient, returns 0 or patient dfn + N X,Y,DIC,DTOUT,DUOUT + S DIC="^IBAT(351.6,",DIC(0)="AEMQ" D ^DIC + Q $S(+Y>0:+Y,1:0) + ; +SLDR(Q) ; -- called to select a date range + ; defaults are from=T-365, to=TODAY + ; output IBBDT, IBEDT, quit returns 0 if not valid + ; + N DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y,IBDT + S DIR(0)="DA^:NOW:EX",DIR("A")="Select FROM DATE: " + S:$D(Q) DIR("?")=Q + D ^DIR G:'Y SLDRQ S IBDT=+Y + S DIR(0)="DA^"_+Y_":NOW:EX",DIR("A")=" TO: " + D ^DIR + S:Y IBEDT=+Y+.999999,IBBDT=IBDT G SLDRQ +SLDR1Y() ; -- called to select a date range w/1y past default + ; defaults are from=T-365, to=TODAY + ; output IBBDT, IBEDT, quit returns 0 if not valid + ; + N DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y,IBDT + S DIR(0)="DA^:NOW:EX",DIR("A")="Select FROM DATE: " + S DIR("B")=$$DAT2^IBOUTL($$FMADD^XLFDT(DT,-365)) D ^DIR + G:'Y SLDRQ S IBDT=+Y + S DIR(0)="DA^"_+Y_":NOW:EX",DIR("A")=" to: " + S DIR("B")=$$DAT2^IBOUTL($$FMADD^XLFDT(IBDT,365)) D ^DIR + G:'Y SLDRQ S IBEDT=+Y+.999999,IBBDT=IBDT +SLDRQ Q $D(DIRUT)!($D(DUOUT)) + ; +PTTRAN(IBFILE,IBARRAY,IBXREF) ; builds a list of patient transactions by date + ; assumes DFN, IBBDT, IBEDT + ; input IBARRAY - where to store info + ; IBXREF - which date x-ref to use + ; output 0,6 node of file IBFILE in array specified + ; + N IBIEN,IBDT,IBNODE + K @IBARRAY + S IBDT=IBBDT-.999999 + F S IBDT=$O(^IBAT(IBFILE,IBXREF,DFN,IBDT)) Q:IBDT<1!(IBDT>IBEDT) D + . S IBIEN=0 + . F S IBIEN=$O(^IBAT(IBFILE,IBXREF,DFN,IBDT,IBIEN)) Q:IBIEN<1 D + .. F IBNODE=0,6 S @IBARRAY@(IBDT,IBIEN,IBNODE)=$G(^IBAT(IBFILE,IBIEN,IBNODE)) + Q +LMOPT ; -- called to do standard listmanager option calling + D FULL^VALM1 + S VALMBCK="R" + Q + ; +SETVALM(LINE,TEXT,IEN,ON,OFF) ; -- sets up listmanager lines + S LINE=LINE+1 + D SET^VALM10(LINE,TEXT,LINE) + S:$G(IEN) @VALMAR@("INDEX",LINE,IEN)="" + D:$G(ON)]""!($G(OFF)]"") CNTRL^VALM10(LINE,1,$L(TEXT),$G(ON),$G(OFF)) + W:'(LINE#5) "." + Q LINE + ; +VISN(STATION) ; -- looks up ien & name of VISN from ien of station + N IBAT + D PARENT^XUAF4("IBAT","`"_STATION,"VISN") + S IBAT=0,IBAT=$O(IBAT("P",IBAT)) + Q $S(IBAT:IBAT_"^"_$P(IBAT("P",IBAT),"^"),1:"") + ; +ONEFAC() ; returns one facility only, no visns allowed + N DIC,DTOUT,DUOUT,X,Y + S DIC="^DIC(4,",DIC(0)="AEMNQ" + S DIC("S")="I $$SCR^IBATUTL(Y),$$INST^IBATUTL(Y)'[""VISN""" + D ^DIC + Q Y +FAC() ; -- facility/visn or all selection + N DIC,X,Y,DTOUT,DUOUT K IBFAC + S DIC="^DIC(4,",DIC(0)="EQMNZ" + S DIC("S")="I $$SCR^IBATUTL(Y)" +REDO W !,"Select FACILITY/VISN: ALL// " R X:DTIME Q:(X["^")!'$T 1 + I X="?" W !,"Select a Facility (Name or Number), VISN (VISN XX), or press RETURN for ALL" G REDO + I X=""!($$UP^XLFSTR(X)="ALL") Q 0 + D ^DIC G:Y<1 REDO D SET(Y) + S DIC("A")="Select another FACILITY/VISN: ",DIC(0)="AEQMNZ" + F D ^DIC Q:X=""!(Y<1) D SET(Y) + Q 0 +SET(Y) I Y'["VISN" N IBVISN D PARENT^XUAF4("IBVISN","`"_+Y,"VISN") D + . S IBVISN=0,IBVISN=$O(IBVISN("P",IBVISN)) + . S IBFAC(IBVISN,"C",+Y)=$$INST(+Y) + E S IBFAC(+Y)="" D CHILDREN^XUAF4("IBFAC(+Y)","`"_+Y,"VISN") + Q +SCR(X) ; screens invalid institution file entries + N IBVISN + ;Q:$P(X,".",2) 0 + D PARENT^XUAF4("IBVISN","`"_X,"VISN") + S IBVISN=0,IBVISN=$O(IBVISN("P",IBVISN)) I IBVISN Q 1 + D CHILDREN^XUAF4("IBVISN","`"_X,"VISN") + S IBVISN=0,IBVISN=$O(IBVISN("C",IBVISN)) I IBVISN Q 1 + Q 0 +PPF(DFN) ; returns patient's enrolled/preferred facility + N IBPPF + ; first find current enrolment + S IBPPF=+$$PREF^DGENPTA(DFN) ; dbia #2919 + ; now if they are already tp update if necessary + I $D(^IBAT(351.6,DFN)),$P(^(DFN,0),"^",3)'=IBPPF D UPPPF^IBATFILE(DFN,IBPPF) + ; now if they have an over ride facility use that + Q $S($P($G(^IBAT(351.6,DFN,0)),"^",10):$P(^(0),"^",10),IBPPF=$$SITE:0,1:IBPPF) +TPP(DFN) ; returns dfn and files patient if a valid tp patient + N IBSITE,IBPPF + S IBSITE=$$SITE + S IBPPF=$$PPF(DFN) + I IBPPF,IBSITE'=IBPPF S DFN=+$$PAT^IBATFILE(DFN,IBPPF) + I DFN,$P($G(^IBAT(351.6,DFN,0)),"^",4) Q DFN + Q 0 +SITE() ; returns ien of current va site (this way I have only one outside call + Q +$$SITE^VASITE + ; +INST(DA) ; returns institution file info + ; This will return the station name ^ station number ^ station type + ; DA - The pointer value into file 4. + I '$D(^DIC(4,DA,0)) Q 0 + Q $$NNT^XUAF4(DA) +IPT(X) ; returns institution file pointer from name + Q $$LKUP^XUAF4(X) +PROC(X,IBDATE) ; -- returns CPT and descriptive name for cpts + S X=$$CPT^ICPTCOD(X,$G(IBDATE)) + Q $P(X,"^",2,3) +COPAY(DFN,IBFROM,IBBDT,IBEDT) ; -- returns copay amount if any + ; dfn=patient's dfn, from=what event the bill is from + ; ibbdt & ibedt are date ranges (n/a for rx) + N IBAMT,Y,Y1,IBDA,IBX S IBAMT=0 + I IBFROM["PSRX(" D Q IBAMT + . I $P(IBFROM,";",3)>0 D Q + .. ; refills + .. S IBFROM=$$SUBFILE^IBRXUTL(+IBFROM,$P(IBFROM,";",3),52,9) I 'IBFROM Q + .. S IBAMT=$P($G(^IB(IBFROM,0)),"^",7) + . E D Q + .. ; initial fill + .. S IBFROM=$$FILE^IBRXUTL(+IBFROM,106) I 'IBFROM Q + .. S IBAMT=$P($G(^IB(IBFROM,0)),"^",7) + ; now on to scheduling and admissions + S Y="" F S Y=$O(^IB("AFDT",DFN,Y)) Q:'Y I -Y'>IBEDT S Y1=0 F S Y1=$O(^IB("AFDT",DFN,Y,Y1)) Q:'Y1 D + . S IBDA=0 F S IBDA=$O(^IB("AF",Y1,IBDA)) Q:'IBDA D + .. Q:'$D(^IB(IBDA,0)) S IBX=^(0) + .. Q:$P(IBX,"^",8)["ADMISSION" + .. ; + .. ; quit if not correct type (inpatient vs outpatient) + .. Q:$S(IBFROM["SCE("&($P($P(IBX,"^",4),":")'=409.68):1,IBFROM["DGPM("&($P($P(IBX,"^",4),":")=409.68):1,1:0) + .. ; + .. I $P(IBX,"^",15)IBEDT) Q + .. S IBAMT=IBAMT+$P(IBX,"^",7) + Q IBAMT +FINDT(X) ; -- looks up transactions for source in X + ; returns ien of 351.61 if not cancelled + Q:$G(X)="" 0 + N Y,Z S (Y,Z)=0 + F S Y=$O(^IBAT(351.61,"AD",X,Y)) Q:Y<1!(Z) D + . I $G(^IBAT(351.61,Y,0)),$P(^(0),"^",5)'="X" S Z=Y + Q Z + ; +EX(FILE,FIELD,VALUE) ; -- return external value + N Y,C S Y=$G(VALUE) + I +$G(FILE),+$G(FIELD),Y'="" S C=$P(^DD(FILE,FIELD,0),"^",2) D Y^DIQ + Q Y + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB.m index 80cd28e0..86527ac7 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB.m @@ -1,216 +1,105 @@ -IBCBB ;ALB/AAS - EDIT CHECK ROUTINE TO BE INVOKED BEFORE ALL BILL APPROVAL ACTIONS ;2-NOV-89 - ;;2.0;INTEGRATED BILLING;**80,51,137,288,327,361,371,377**;21-MAR-94;Build 23 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ;MAP TO DGCRBB - ; - ;IBNDn = IBND(n) = ^ib(399,n) - ;RETURNS: - ;IBER=fields with errors separated by semi-colons - ;PRCASV("OKAY")=1 if iber="" and $D(prcasv("array")) compete - ; -GVAR ;set up variables for mccr - Q:'$D(IBIFN) F I=0,"M","U","U1","S","MP","TX","UF3","UF31","U2" S @("IBND"_I)=$G(^DGCR(399,IBIFN,I)) - S IBBNO=$P(IBND0,"^"),DFN=$P(IBND0,"^",2),IBEVDT=$P(IBND0,"^",3) - S IBLOC=$P(IBND0,"^",4),IBCL=$P(IBND0,"^",5),IBTF=$P(IBND0,"^",6) - S IBAT=$P(IBND0,"^",7),IBWHO=$P(IBND0,"^",11),IBST=$P(IBND0,"^",13),IBFT=$P(IBND0,"^",19) - S IBFDT=$P(IBNDU,"^",1),IBTDT=$P(IBNDU,"^",2) - S IBTC=$P(IBNDU1,"^",1),IBFY=$P(IBNDU1,"^",9),IBFYC=$P(IBNDU1,"^",10) - S IBEU=$P(IBNDS,"^",2),IBRU=$P(IBNDS,"^",5),IBAU=$P(IBNDS,"^",8) - S IBTOB=$$TOB(IBND0),IBTOB12=$E(IBTOB,1,2) - K ^TMP($J,"BILL-WARN") - Q - ; -EN ;Entry to check for errors - N IBQ,IBXERR,IBXDATA,IBXSAVE,IBZPRC92,IBQUIT,IBISEQ,IDDATA,IBFOR,IBC - I $D(IBFL) N IBFL - K ^TMP($J) - W ! - S IBER="" D GVAR I '$D(IBND0) S IBER=-1 Q - ; - ;patient in patient file - I DFN="" S IBER=IBER_"IB057;" - I DFN]"",'$D(^DPT(DFN)) S IBER=IBER_"IB057;" - ; - ;Event date in correct format - I IBEVDT="" S IBER=IBER_"IB049;" - I IBEVDT]"",IBEVDT'?7N&(IBEVDT'?7N1".".N) S IBER=IBER_"IB049;" - ; - ;Rate Type - I IBAT="" S IBER=IBER_"IB059;" - I IBAT]"",'$D(^DGCR(399.3,IBAT,0)) S IBER=IBER_"IB059;" - I IBAT]"",$D(^DGCR(399.3,IBAT,0)),'$P(^(0),"^",6) S IBER=IBER_"IB059;",IBAT="" - I IBAT]"",$P($G(^DGCR(399.3,IBAT,0)),"^",6) S IBARTP=$P($$CATN^PRCAFN($P(^DGCR(399.3,IBAT,0),"^",6)),"^",3) - ;Check that AR category expects same debtor as defined in who's responsible. - I $D(IBARTP),IBWHO="i"&(IBARTP'="T")!(IBWHO="p"&("PC"'[IBARTP))!(IBWHO="o"&(IBARTP'="N")) S IBER=IBER_"IB058;" - ; - ;Who's Responsible - I IBWHO=""!($L(IBWHO)>1)!("iop"'[IBWHO) S IBER=IBER_"IB065;" - S IBMRA=$S($$MCRWNR^IBEFUNC(+$$CURR^IBCEF2(IBIFN)):$$TXMT^IBCEF4(IBIFN)>0,1:0) - ; MCR will not reimburse is only valid if there is subsequent insurance - ; that will reimburse - I IBWHO="i" D - . I IBMRA D Q - .. N Z,IBZ - .. S IBZ=0 - .. F Z=$$COBN^IBCEF(IBIFN):1:3 I $D(^DGCR(399,IBIFN,"I"_(Z+1))),$P($G(^DIC(36,+$G(^DGCR(399,IBIFN,"I"_(Z+1))),0)),U,2)'="N" S IBZ=1 Q - .. I 'IBZ S IBER=IBER_"IB054;" D WARN^IBCBB11("A valid claim for MEDICARE WNR needs subsequent ins. that will reimburse") - .. - . I $$COB^IBCEF(IBIFN)="S",$$MCRWNR^IBEFUNC(+$$CURR^IBCEF2(IBIFN))=1,$D(^DGCR(399,IBIFN,"I3")) Q - . I $S('IBNDMP:1,1:$P(IBNDMP,U,2)'=$$BPP^IBCNS2(IBIFN,1)) S IBER=IBER_"IB054;" - I IBWHO="o",'$P(IBNDM,"^",11) S IBER=IBER_"IB053;" - ; - ; All insurance subscribers must have a birth date on file - ; - 11/10/04 - IB*2.0*288 - ; - 12/14/06 - IB*2.0*361 - must have INSURED'S SEX too - ; IB error codes - ; IB221 - Primary insurance subscriber missing date of birth - ; IB222 - Secondary insurance subscriber missing date of birth - ; IB223 - Tertiary insurance subscriber missing date of birth - ; IB261 - Primary insurance subscriber is missing INSURED'S SEX - ; IB262 - Secondary insurance subscriber is missing INSURED'S SEX - ; IB263 - Tertiary insurance subscriber is missing INSURED'S SEX - ; - F IBISEQ=1:1:3 D - . I '$P($G(^DGCR(399,IBIFN,"I"_IBISEQ)),U,1) Q ; no insurance here - . K ^UTILITY("VADM",$J),^UTILITY("VAPA",$J) - . S IDDATA=$$INSDEM^IBCEF(IBIFN,IBISEQ) - . K ^UTILITY("VADM",$J),^UTILITY("VAPA",$J) - . ; - . I '$P(IDDATA,U,1) D ERR(221) ; birth date missing - . ; - . I "^M^F^"'[(U_$P(IDDATA,U,2)_U) D ERR(261) ; sex missing - . ; - . ; IB*2*371 - esg - check for other missing insurance pieces - . ; check insured's name, primary ID#, pt. relationship to insured, - . ; and subscriber address data - . N INNAME,SUBID,PTREL,SFA,CAS,LN,FN - . ; - . ; IB273 - Primary Insurance name of insured missing - . ; IB274 - Secondary Insurance name of insured missing - . ; IB275 - Tertiary Insurance name of insured missing - . S INNAME=$$POLICY^IBCEF(IBIFN,17,IBISEQ) - . S LN=$P(INNAME,",",1),FN=$P(INNAME,",",2) ; last name,first name - . S LN=$$NOPUNCT^IBCEF(LN,1) - . S FN=$$NOPUNCT^IBCEF(FN,1) - . I LN=""!(FN="") D ERR(273) ; name of insured missing or invalid - . S LN=$$NAME^IBCEFG1(INNAME) ; additional name checks - . S FN=$P(LN,U,2) - . S LN=$P(LN,U,1) - . I LN=""!(FN="") D ERR(273) ; name of insured missing or invalid - . ; - . ; IB276 - Primary Insurance subscriber ID missing - . ; IB277 - Secondary Insurance subscriber ID missing - . ; IB278 - Tertiary Insurance subscriber ID missing - . S SUBID=$$NOPUNCT^IBCEF($$POLICY^IBCEF(IBIFN,2,IBISEQ),1) - . I SUBID="" D ERR(276) ; subscriber ID# missing - . ; - . ; IB279 - Primary Insurance missing pt relationship - . ; IB280 - Secondary Insurance missing pt relationship - . ; IB281 - Tertiary Insurance missing pt relationship - . S PTREL=$$POLICY^IBCEF(IBIFN,16,IBISEQ) - . I PTREL="" D ERR(279) ; missing patient relationship to insured - . ; - . ; subscriber address section - . S SFA=$$INSADDR^IBCEF(IBIFN,IBISEQ) ; full address all pieces - . S CAS=$$NOPUNCT^IBCEF($P(SFA,U,2,5),1) ; string city,st,zip,addr1 - . ; - . ; IB282 - Primary Insurance address line 1 missing - . ; IB283 - Secondary Insurance address line 1 missing - . ; IB284 - Tertiary Insurance address line 1 missing - . I $$NOPUNCT^IBCEF($P(SFA,U,5),1)="" D ; address line 1 is blank - .. ; pat=subscriber and current insurance - address is required - .. I +PTREL=1,IBISEQ=$$COBN^IBCEF(IBIFN) D ERR(282) Q - .. ; if any part of the address is there, then all fields are required - .. I CAS'="" D ERR(282) Q - .. Q - . ; - . ; IB285 - Primary Insurance city missing - . ; IB286 - Secondary Insurance city missing - . ; IB287 - Tertiary Insurance city missing - . I $$NOPUNCT^IBCEF($P(SFA,U,2),1)="" D ; city is blank - .. ; pat=subscriber and current insurance - address is required - .. I +PTREL=1,IBISEQ=$$COBN^IBCEF(IBIFN) D ERR(285) Q - .. ; if any part of the address is there, then all fields are required - .. I CAS'="" D ERR(285) Q - .. Q - . ; - . ; IB288 - Primary Insurance state missing - . ; IB289 - Secondary Insurance state missing - . ; IB290 - Tertiary Insurance state missing - . I $$NOPUNCT^IBCEF($P(SFA,U,3),1)="" D ; state is blank - .. ; pat=subscriber and current insurance - address is required - .. I +PTREL=1,IBISEQ=$$COBN^IBCEF(IBIFN) D ERR(288) Q - .. ; if any part of the address is there, then all fields are required - .. I CAS'="" D ERR(288) Q - .. Q - . ; - . ; IB291 - Primary Insurance zipcode missing - . ; IB292 - Secondary Insurance zipcode missing - . ; IB293 - Tertiary Insurance zipcode missing - . I $$NOPUNCT^IBCEF($P(SFA,U,4),1)="" D ; zipcode is blank - .. ; pat=subscriber and current insurance - address is required - .. I +PTREL=1,IBISEQ=$$COBN^IBCEF(IBIFN) D ERR(291) Q - .. ; if any part of the address is there, then all fields are required - .. I CAS'="" D ERR(291) Q - .. Q - . ; - . Q - ; - ; esg - IB*2*371 - check patient address fields - K ^UTILITY("VAPA",$J) - ; - S IBFOR=0 ; foreign address flag - S IBC=+$$PTADDR^IBCEF(IBIFN,25) ; country code ien - I IBC D - . N CODE - . S CODE=$$GET1^DIQ(779.004,IBC,.01) ; .01 code field file 779.004 - . I CODE'="",CODE'="USA" S IBFOR=1 ; foreign country exists - . Q - ; - I $$NOPUNCT^IBCEF($$PTADDR^IBCEF(IBIFN,1),1)="" S IBER=IBER_"IB269;" - I $$NOPUNCT^IBCEF($$PTADDR^IBCEF(IBIFN,4),1)="" S IBER=IBER_"IB270;" - I $$NOPUNCT^IBCEF($$PTADDR^IBCEF(IBIFN,5),1)="",'IBFOR S IBER=IBER_"IB271;" - I $$NOPUNCT^IBCEF($$PTADDR^IBCEF(IBIFN,11),1)="",'IBFOR S IBER=IBER_"IB272;" - K ^UTILITY("VAPA",$J) - ; - D PAYERADD^IBCBB0(IBIFN) ; check the payer addresses - ; - ; esg - 9/20/07 - IB patch 371 - prevent EDI transmission for 3 payer - ; claims for all but the first payer. To be removed when Emdeon - ; and FSC are able to deal with these. - ; - I +$G(^DGCR(399,IBIFN,"I2")),+$G(^DGCR(399,IBIFN,"I3")),$$TXMT^IBCEF4(IBIFN) D - . ; for MRA request claims, make sure the MRA secondary claim is forced to print - . I $$REQMRA^IBEFUNC(IBIFN) D Q - .. I '$P($G(^DGCR(399,IBIFN,"TX")),U,9) S IBER=IBER_"IB146;" - .. Q - . ; - . I $$COBN^IBCEF(IBIFN)=1 Q ; primary payer sequence claims are OK - . ; - . ; But claims with a payer sequence of 2 or 3 need to print locally - . S IBER=IBER_"IB147;" - . Q - ; - D ^IBCBB1 - Q - ; -EDIT(IBIFN) ; Run edits from within the billing edit screens - N IBVIEW,IBDISP,IBNOFIX,DIR,X,Y - S (IBNOFIX,IBVIEW,IBDISP)=1 - D EDITS^IBCB2 - W ! S DIR("A")="Press RETURN to continue",DIR(0)="E" D ^DIR K DIR - Q - ; -TOB(IBND0) ; - ; IBND0 = the 0-node of the bill (file 399) - Q ($P(IBND0,U,24)_$P($G(^DGCR(399.1,+$P(IBND0,U,25),0)),U,2)_$P(IBND0,U,26)) - ; -ERR(Z) ; update IBER variable from the above insurance checks - ; Z is the IB error code# for the primary insurance error - N IBERRNO - S IBERRNO="IB"_(Z+IBISEQ-1) - I IBER[IBERRNO Q - S IBER=IBER_IBERRNO_";" - Q - ; +IBCBB ;ALB/AAS - EDIT CHECK ROUTINE TO BE INVOKED BEFORE ALL BILL APPROVAL ACTIONS ;2-NOV-89 + ;;2.0;INTEGRATED BILLING;**80,51,137,288,327,361**;21-MAR-94;Build 9 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; + ;MAP TO DGCRBB + ; + ;IBNDn = IBND(n) = ^ib(399,n) + ;RETURNS: + ;IBER=fields with errors separated by semi-colons + ;PRCASV("OKAY")=1 if iber="" and $D(prcasv("array")) compete + ; +GVAR ;set up variables for mccr + Q:'$D(IBIFN) F I=0,"M","U","U1","S","MP","TX","UF3","UF31","U2" S @("IBND"_I)=$G(^DGCR(399,IBIFN,I)) + S IBBNO=$P(IBND0,"^"),DFN=$P(IBND0,"^",2),IBEVDT=$P(IBND0,"^",3) + S IBLOC=$P(IBND0,"^",4),IBCL=$P(IBND0,"^",5),IBTF=$P(IBND0,"^",6) + S IBAT=$P(IBND0,"^",7),IBWHO=$P(IBND0,"^",11),IBST=$P(IBND0,"^",13),IBFT=$P(IBND0,"^",19) + S IBFDT=$P(IBNDU,"^",1),IBTDT=$P(IBNDU,"^",2) + S IBTC=$P(IBNDU1,"^",1),IBFY=$P(IBNDU1,"^",9),IBFYC=$P(IBNDU1,"^",10) + S IBEU=$P(IBNDS,"^",2),IBRU=$P(IBNDS,"^",5),IBAU=$P(IBNDS,"^",8) + S IBTOB=$$TOB(IBND0),IBTOB12=$E(IBTOB,1,2) + K ^TMP($J,"BILL-WARN") + Q + ; +EN ;Entry to check for errors + N IBQ,IBXERR,IBXDATA,IBXSAVE,IBZPRC92,IBQUIT,IBISEQ,IDDATA,IBERRNO + I $D(IBFL) N IBFL + K ^TMP($J) + W ! + S IBER="" D GVAR I '$D(IBND0) S IBER=-1 Q + ; + ;I $$ISPROS^IBCEF1(IBIFN) D + ;. D WARN^IBCBB11("Bill has prosthetics item(s) and will only print locally") + ;. I $$NEEDMRA^IBEFUNC(IBIFN) S IBQUIT=$$IBER^IBCBB3(.IBER,"098") + ; + ;patient in patient file + I DFN="" S IBER=IBER_"IB057;" + I DFN]"",'$D(^DPT(DFN)) S IBER=IBER_"IB057;" + ; + ;Event date in correct format + I IBEVDT="" S IBER=IBER_"IB049;" + I IBEVDT]"",IBEVDT'?7N&(IBEVDT'?7N1".".N) S IBER=IBER_"IB049;" + ; + ;Rate Type + I IBAT="" S IBER=IBER_"IB059;" + I IBAT]"",'$D(^DGCR(399.3,IBAT,0)) S IBER=IBER_"IB059;" + I IBAT]"",$D(^DGCR(399.3,IBAT,0)),'$P(^(0),"^",6) S IBER=IBER_"IB059;",IBAT="" + ;I IBAT]"",$D(^DGCR(399.3,IBAT,0)) S IBARTP=$P(^PRCA(430.2,$P(^DGCR(399.3,IBAT,0),"^",6),0),"^",6) + I IBAT]"",$P($G(^DGCR(399.3,IBAT,0)),"^",6) S IBARTP=$P($$CATN^PRCAFN($P(^DGCR(399.3,IBAT,0),"^",6)),"^",3) + ;Check that AR category expects same debtor as defined in who's responsible. + I $D(IBARTP),IBWHO="i"&(IBARTP'="T")!(IBWHO="p"&("PC"'[IBARTP))!(IBWHO="o"&(IBARTP'="N")) S IBER=IBER_"IB058;" + ; + ;Who's Responsible + I IBWHO=""!($L(IBWHO)>1)!("iop"'[IBWHO) S IBER=IBER_"IB065;" + S IBMRA=$S($$MCRWNR^IBEFUNC(+$$CURR^IBCEF2(IBIFN)):$$TXMT^IBCEF4(IBIFN)>0,1:0) + ; MCR will not reimburse is only valid if there is subsequent insurance + ; that will reimburse + I IBWHO="i" D + . I IBMRA D Q + .. N Z,IBZ + .. S IBZ=0 + .. F Z=$$COBN^IBCEF(IBIFN):1:3 I $D(^DGCR(399,IBIFN,"I"_(Z+1))),$P($G(^DIC(36,+$G(^DGCR(399,IBIFN,"I"_(Z+1))),0)),U,2)'="N" S IBZ=1 Q + .. I 'IBZ S IBER=IBER_"IB054;" D WARN^IBCBB11("A valid claim for MEDICARE WNR needs subsequent ins. that will reimburse") + .. + . I $$COB^IBCEF(IBIFN)="S",$$MCRWNR^IBEFUNC(+$$CURR^IBCEF2(IBIFN))=1,$D(^DGCR(399,IBIFN,"I3")) Q + . I $S('IBNDMP:1,1:$P(IBNDMP,U,2)'=$$BPP^IBCNS2(IBIFN,1)) S IBER=IBER_"IB054;" + I IBWHO="o",'$P(IBNDM,"^",11) S IBER=IBER_"IB053;" + ; + ; All insurance subscribers must have a birth date on file + ; - 11/10/04 - IB*2.0*288 + ; - 12/14/06 - IB*2.0*361 - must have INSURED'S SEX too + ; IB error codes + ; IB221 - Primary insurance subscriber missing date of birth + ; IB222 - Secondary insurance subscriber missing date of birth + ; IB223 - Tertiary insurance subscriber missing date of birth + ; IB261 - Primary insurance subscriber is missing INSURED'S SEX + ; IB262 - Secondary insurance subscriber is missing INSURED'S SEX + ; IB263 - Tertiary insurance subscriber is missing INSURED'S SEX + ; + F IBISEQ=1:1:3 D + . I '$P($G(^DGCR(399,IBIFN,"I"_IBISEQ)),U,1) Q ; no insurance here + . K ^UTILITY("VADM",$J),^UTILITY("VAPA",$J) + . S IDDATA=$$INSDEM^IBCEF(IBIFN,IBISEQ) + . K ^UTILITY("VADM",$J),^UTILITY("VAPA",$J) + . I '$P(IDDATA,U,1) D ; birth date missing + .. S IBERRNO=220+IBISEQ + .. S IBER=IBER_"IB"_IBERRNO_";" + . I "^M^F^"'[(U_$P(IDDATA,U,2)_U) D ; sex missing + .. S IBERRNO=260+IBISEQ + .. S IBER=IBER_"IB"_IBERRNO_";" + . Q + ; + D ^IBCBB1 + Q + ; +EDIT(IBIFN) ; Run edits from within the billing edit screens + N IBVIEW,IBDISP,IBNOFIX,DIR,X,Y + S (IBNOFIX,IBVIEW,IBDISP)=1 + D EDITS^IBCB2 + W ! S DIR("A")="Press RETURN to continue",DIR(0)="E" D ^DIR K DIR + Q + ; +TOB(IBND0) ; + ; IBND0 = the 0-node of the bill (file 399) + Q ($P(IBND0,U,24)_$P($G(^DGCR(399.1,+$P(IBND0,U,25),0)),U,2)_$P(IBND0,U,26)) + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB1.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB1.m index 2aa1cece..86196851 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB1.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB1.m @@ -1,204 +1,209 @@ -IBCBB1 ;ALB/AAS - CONTINUATION OF EDIT CHECK ROUTINE ;2-NOV-89 - ;;2.0;INTEGRATED BILLING;**27,52,80,93,106,51,151,148,153,137,232,280,155,320,343,349,363,371,395**;21-MAR-94;Build 3 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ;MAP TO DGCRBB1 - ; -% ;Bill Status - N Z,Z0,Z1 - I $S(+IBST=0:1,1:"^1^2^3^4^7^"'[(U_IBST_U)) S IBER=IBER_"IB045;" - ; - ;Statement Covers From - I IBFDT="" S IBER=IBER_"IB061;" - I IBFDT]"",IBFDT'?7N&(IBFDT'?7N1".".N) S IBER=IBER_"IB061;" - I IBFDT>IBTDT S IBER=IBER_"IB061;" ; from must be on or before the to date - S IBFFY=$$FY^IBOUTL(IBFDT) - ; if inpat - from date must not be prior to admit date. - I $$INPAT^IBCEF(IBIFN,1),(IBFDT<($P($G(^DGPT(+$P(IBND0,U,8),0)),U,2)\1)) S IBER=IBER_"IB061;" - ; - ;Statement Covers To - I IBTDT="" S IBER=IBER_"IB062;" - I IBTDT]"",IBTDT'?7N&(IBTDT'?7N1".".N) S IBER=IBER_"IB062;" - I IBTDT>DT!(IBTDTthan today's date - S IBTFY=$$FY^IBOUTL(IBTDT) - ; - ;Total Charges - I +IBTC'>0!(+IBTC'=IBTC) S IBER=IBER_"IB064;" - ; - ;Billable charges for secondary claim - I $$MCRONBIL^IBEFUNC(IBIFN)&(($P(IBNDU1,U,1)-$P(IBNDU1,U,2))'>0) S IBER=IBER_"IB094;" - ;Fiscal Year 1 - S IBFFY=$$FY^IBOUTL(IBFDT) - ; - ;Check provider link for current user, enterer, reviewer and Authorizor - I '$D(^VA(200,DUZ,0)) S IBER=IBER_"IB048;" - I IBEU]"",'$D(^VA(200,IBEU,0)) S IBER=IBER_"IB048;" - I IBRU]"",'$D(^VA(200,IBRU,0)) S IBER=IBER_"IB060;" - I IBAU]"",'$D(^VA(200,IBAU,0)) S IBER=IBER_"IB041;" - ; - I IBER="",+$$STA^PRCAFN(IBIFN)=104 S IBER=IBER_"IB040;" - ; If ins bill, must have valid COB sequence - I $P(IBND0,U,11)="i",$S($P(IBND0,U,21)="":1,1:"PST"'[$P(IBND0,U,21)) S IBER=IBER_"IB324;" - ; - ; Check for valid sec provider id for current ins - S Z=0 F S Z=$O(^DGCR(399,IBIFN,"PRV",Z)) Q:'Z S Z0=$G(^(Z,0)),Z1=+$$COBN^IBCEF(IBIFN) I $P(Z0,U,4+Z1)'="",$P(Z0,U,11+Z1)'="" D - . I '$$SECIDCK^IBCEF74(IBIFN,Z1,$P(Z0,U,11+Z1),Z) D WARN^IBCBB11("Prov secondary id type for the "_$P("PRIMARY^SECONDARY^TERTIARY",U,Z1)_" "_$$EXTERNAL^DILFD(399.0222,.01,,+Z0)_" is invalid/won't transmit") - ; Check NPIs - D NPICHK^IBCBB11 - ; - ; Check multiple rx NPIs - D RXNPI^IBCBB11(IBIFN) - ; - ; Check taxonomies - D TAXCHK^IBCBB11 - ; - ; Check for Physician Name - K IBXDATA D F^IBCEF("N-ATT/REND PHYSICIAN NAME",,,IBIFN) - I $P($G(IBXDATA),U)="" S IBER=IBER_"IB303;" - ; - N FUNCTION,IBINS - S FUNCTION=$S($$FT^IBCEF(IBIFN)=3:4,1:3) - I IBER'["IB303;" D - . F IBINS=1:1:3 D - .. S Z=$$GETTYP^IBCEP2A(IBIFN,IBINS) - .. I Z,$P(Z,U,2) D ; Rendering/attending prov secondary id required - ... N IBID,IBOK,Q0 - ... D PROVINF^IBCEF74(IBIFN,IBINS,.IBID,1,"C") ; check all as though they were current - ... S IBOK=0 - ... S Q0=0 F S Q0=$O(IBID(1,FUNCTION,Q0)) Q:'Q0 I $P(IBID(1,FUNCTION,Q0),U,9)=+Z S IBOK=1 Q - ... I 'IBOK S IBER=IBER_$S(IBINS=1:"IB236;",IBINS=2:"IB237;",IBINS=3:"IB238;",1:"") - ; - D PRIIDCHK^IBCBB11 - ; - N IBM,IBM1 - S IBM=$G(^DGCR(399,IBIFN,"M")) - S IBM1=$G(^DGCR(399,IBIFN,"M1")) - I $P(IBM,U),$P($G(^DIC(36,$P(IBM,U),4)),U,6),$P(IBM1,U,2)="" S IBER=IBER_"IB244;" - I $P(IBM,U,2),$P($G(^DIC(36,$P(IBM,U,2),4)),U,6),$P(IBM1,U,3)="" S IBER=IBER_"IB245;" - I $P(IBM,U,3),$P($G(^DIC(36,$P(IBM,U,3),4)),U,6),$P(IBM1,U,4)="" S IBER=IBER_"IB246;" - ; - ; If outside facility, check for ID and qualifier in 355.93 - ; 5/15/06 - esg - hard error IB243 turned into warning message instead - S Z=$P($G(^DGCR(399,IBIFN,"U2")),U,10) - I Z D - . I $P($G(^IBA(355.93,Z,0)),U,9)=""!($P($G(^IBA(355.93,Z,0)),U,13)="") D - .. N Z1,Z2 - .. S Z1="Missing Lab or Facility Primary ID for non-VA facility, " - .. S Z2=$$EXTERNAL^DILFD(399,232,,Z) - .. I $L(Z2)'>19 D WARN^IBCBB11(Z1_Z2) Q - .. D WARN^IBCBB11(Z1),WARN^IBCBB11(" "_Z2) - .. Q - . Q - ; - ; Must be one and only one division on bill - S IBZ=$$MULTDIV^IBCBB11(IBIFN,IBND0) - I IBZ S IBER=IBER_$S(IBZ=1:"IB095;",IBZ=2:"IB104;",1:"IB105;") - ; Division address must be defined in institution file - I $P(IBND0,U,22) D - . N Z,Z0,Z1 - . S Z0=$G(^DIC(4,+$P($G(^DG(40.8,+$P(IBND0,U,22),0)),U,7),0)) - . S Z1=$G(^DIC(4,+$P($G(^DG(40.8,+$P(IBND0,U,22),0)),U,7),1)) - . I $P(Z0,U,2)="" S IBER=IBER_"IB097;" Q - . F Z=1,3,4 I $P(Z1,U,Z)="" S IBER=IBER_"IB097;" Q - ; - ;CHAMPVA Rate Type and Primary Insurance Carriers Type of Coverage must match - S (IBRTCHV,IBPICHV)=0 - I $P($G(^DGCR(399.3,+IBAT,0)),U,1)="CHAMPVA" S IBRTCHV=1 - I $P($G(^IBE(355.2,+$P($G(^DIC(36,+IBNDMP,0)),U,13),0)),U,1)="CHAMPVA" S IBPICHV=1 - I (+IBRTCHV!+IBPICHV)&('IBRTCHV!'IBPICHV) S IBER=IBER_"IB085;" - ; - N IBZPRC,IBZPRCUB - D F^IBCEF("N-ALL PROCEDURES","IBZPRC",,IBIFN) - ; Procedure Clinic is required for Surgical Procedures Outpt Facility Charges - I +$P(IBND0,U,27)'=2,$$BILLRATE^IBCRU3(IBAT,IBCL,IBEVDT,"RC OUTPATIENT") D - . N Z,Z0,Z1,ZE S (ZE,Z)=0 F S Z=$O(^DGCR(399,IBIFN,"CP",Z)) Q:'Z D I +ZE S IBER=IBER_"IB320;" Q - .. S Z0=$G(^DGCR(399,IBIFN,"CP",Z,0)),Z1=+Z0 I Z0'[";ICPT(" Q - .. I '((Z1'<10000)&(Z1'>69999))&'((Z1'<93501)&(Z1'>93533)) Q - .. I '$P(Z0,U,7) S ZE=1 - ; - ; Extract procedures for UB-04 - D F^IBCEF("N-UB-04 PROCEDURES","IBZPRCUB",,IBIFN) - ; Does this bill have ANY prescriptions associated with it? - ; Must bill prescriptions separately from other charges - ; - I $$ISRX^IBCEF1(IBIFN) D - . N IBZ,IBRXDEF - . S IBRXDEF=$P($G(^IBE(350.9,1,1)),U,30),IBZ=0 - . F S IBZ=$O(IBZPRCUB(IBZ)) Q:'IBZ I IBZPRCUB(IBZ),+$P(IBZPRCUB(IBZ),U)'=IBRXDEF S IBER=IBER_"IB102;" Q - . K IBZ - ; - ; Check that COB sequences are not skipped - K Z - F Z=1:1:3 S:+$G(^DGCR(399,IBIFN,"I"_Z)) Z(Z)="" - F Z=0:1:2 S Z0=$O(Z(Z)) Q:'Z0 I Z0'=(Z+1) S IBER=IBER_"IB322;" Q - K Z - ; HD64676 IB*2*371 - OK for payer sequence to be blank when the Rate - ; Type is either Interagency or Sharing Agreement - I $P($G(^DGCR(399,IBIFN,0)),U,21)="",$P($G(^DGCR(399,IBIFN,0)),U,7)'=4,$P($G(^DGCR(399,IBIFN,0)),U,7)'=9 S IBER=IBER_"IB323;" - K IBXDATA D F^IBCEF("N-PROCEDURE CODING METHD",,,IBIFN) - ; Coding method should agree with types of procedure codes - S IBOK=$S('$O(IBZPRC(0))!(IBXDATA=""):1,1:0) - I 'IBOK S IBOK=1,IBZ=0 F S IBZ=$O(IBZPRC(IBZ)) Q:'IBZ I IBZPRC(IBZ),$P(IBZPRC(IBZ),U)'[$S(IBXDATA=9:"ICD",1:"ICP") S IBOK=0 Q - I 'IBOK D WARN^IBCBB11("Coding Method does not agree with all procedure codes found on bill") - D EDITMRA^IBCBB3(.IBQUIT,.IBER,IBIFN,IBFT) - Q:$G(IBQUIT) - ; - ;Other things that could be added: Rev Code - calculating charges - ; Diagnosis Coding, if MT copay - check for other co-payments - ; - I $P(IBNDTX,U,8),$$REQMRA^IBEFUNC(IBIFN) S IBER=IBER_"IB121;" ; can't force MRAs to print - I $P(IBNDTX,U,8)!$P(IBNDTX,U,9) D WARN^IBCBB11($S($$REQMRA^IBEFUNC(IBIFN)&($P(IBNDTX,U,9)):"MRA Secondary ",1:"")_"Bill has been forced to print "_$S($P(IBNDTX,U,8)=1!($P(IBNDTX,U,9)=1):"locally",1:"at clearinghouse")) - N IBXZ,IBIZ F IBIZ=12,13,14 S IBXZ=$P(IBNDM,U,IBIZ) I +IBXZ S IBXZ=$P($G(^DPT(DFN,.312,IBXZ,0)),U,18) I +IBXZ S IBXZ=$G(^IBA(355.3,+IBXZ,0)) I +$P(IBXZ,U,12) D - . D WARN^IBCBB11($P($G(^DIC(36,+IBXZ,0)),U,1)_" requires Amb Care Certification") - ; - D VALNDC^IBCBB11(IBIFN,DFN) ;validate NDC# - ; - ;Build AR array if no errors and MRA not needed or already rec'd - I IBER="",$S($$NEEDMRA^IBEFUNC(IBIFN)!($$REQMRA^IBEFUNC(IBIFN)):0,1:1) D ARRAY - ; -END ;Don't kill IBIFN, IBER, DFN - I $O(^TMP($J,"BILL-WARN",0)),$G(IBER)="" S IBER="WARN" ;Warnings only - K IBBNO,IBEVDT,IBLOC,IBCL,IBTF,IBAT,IBWHO,IBST,IBFDT,IBTDT,IBTC,IBFY,IBFY1,IBAU,IBRU,IBEU,IBARTP,IBFYC,IBMRA,IBTOB,IBTOB12,IBNDU2,IBNDUF3,IBNDUF31,IBNDTX - K IBNDS,IBND0,IBNDU,IBNDM,IBNDMP,IBNDU1,IBFFY,IBTFY,IBFT,IBRTCHV,IBPICHV,IBXDATA,IBOK - I $D(IBER),IBER="" W !,"No Errors found for National edits" - Q - ; -ARRAY ;Build PRCASV(array) - N IBCOBN,X - K PRCASV - Q:$$MCRWNR^IBEFUNC(+$$CURR^IBCEF2(IBIFN)) - S IBCOBN=$$COBN^IBCEF(IBIFN) - S X=IBIFN - S PRCASV("BDT")=DT,PRCASV("ARREC")=IBIFN - S PRCASV("APR")=DUZ - S PRCASV("PAT")=DFN,PRCASV("CAT")=$P(^DGCR(399.3,IBAT,0),"^",6) - I IBWHO="i" S PRCASV("DEBTOR")=+IBNDMP_";DIC(36," - S PRCASV("DEBTOR")=$S(IBWHO="p":DFN_";DPT(",IBWHO="o":$P(IBNDM,"^",11)_";DIC(4,",IBWHO="i":PRCASV("DEBTOR"),1:"") - S PRCASV("CARE")=$E($$TOB^IBCEF1(IBIFN),1,2) - S PRCASV("FY")=$$FY^IBOUTL(DT)_U_($P(IBNDU1,U)-$P(IBNDU1,U,2)) - ;S PRCASV("FY")=$P(IBNDU1,U,9)_U_$S($P(IBNDU1,U,2)]"":($P(IBNDU1,U,10)-$P(IBNDU1,U,2)),1:$P(IBNDU1,U,10))_$S($P(IBNDU1,U,11)]"":U_$P(IBNDU1,U,11)_U_$P(IBNDU1,U,12),1:"") -PLUS I IBWHO="i",$P(IBNDM,"^",2),$D(^DIC(36,$P(IBNDM,"^",2),0)) S PRCASV("2NDINS")=$P(IBNDM,"^",2) - I IBWHO="i",$P(IBNDM,"^",3),$D(^DIC(36,$P(IBNDM,"^",3),0)) S PRCASV("3RDINS")=$P(IBNDM,"^",3) - ; - N IBX S IBX=$P(IBND0,U,21),IBX=$S(IBX="P":"I1",IBX="S":"I2",IBX="T":"I3",1:"") Q:IBX="" - N IBNDI1 - Q:'$D(^DGCR(399,IBIFN,IBX)) S IBNDI1=^(IBX) - S:$P(IBNDI1,"^",3)]"" PRCASV("GPNO")=$P(IBNDI1,"^",3) - S:$P(IBNDI1,"^",15)]"" PRCASV("GPNM")=$P(IBNDI1,"^",15) - S:$P(IBNDI1,"^",17)]"" PRCASV("INPA")=$P(IBNDI1,"^",17) - S:$P(IBNDI1,"^",2)]"" PRCASV("IDNO")=$P(IBNDI1,"^",2),PRCASV("INID")=PRCASV("IDNO") - ; Check that this is a secondary or tertiary bill and insurance for previous - ; COB sequence is Medicare WNR and MRA is active --> send data elements to AR - I IBCOBN>1,$$WNRBILL^IBEFUNC(IBIFN,IBCOBN-1),$$EDIACTV^IBCEF4(2) D MRA - Q - ; -MRA N IBEOB S IBEOB=0 - ; - K PRCASV("MEDURE"),PRCASV("MEDCA") - ; Get EOB data - F S IBEOB=$O(^IBM(361.1,"B",IBIFN,IBEOB)) Q:'IBEOB D - . D MRACALC^IBCEMU2(IBEOB,IBIFN,1,.PRCASV) - Q ;MRA - ; - ;; PREGNANCY DX CODES: V22**-V24**, V27**-V28**, 630**-677** - ;; FLU SHOTS PROCEDURE CODES: 90724, G0008, 90732, G0009 +IBCBB1 ;ALB/AAS - CONTINUATION OF EDIT CHECK ROUTINE ;2-NOV-89 + ;;2.0;INTEGRATED BILLING;**27,52,80,93,106,51,151,148,153,137,232,280,155,320,343,349,363**;21-MAR-94;Build 35 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; + ;MAP TO DGCRBB1 + ; +% ;Bill Status + N Z,Z0,Z1 + I $S(+IBST=0:1,1:"^1^2^3^4^7^"'[(U_IBST_U)) S IBER=IBER_"IB045;" + ; + ;Statement Covers From + I IBFDT="" S IBER=IBER_"IB061;" + I IBFDT]"",IBFDT'?7N&(IBFDT'?7N1".".N) S IBER=IBER_"IB061;" + I IBFDT>IBTDT S IBER=IBER_"IB061;" ; from must be on or before the to date + S IBFFY=$$FY^IBOUTL(IBFDT) + ; if inpat - from date must not be prior to admit date. + I $$INPAT^IBCEF(IBIFN,1),(IBFDT<($P($G(^DGPT(+$P(IBND0,U,8),0)),U,2)\1)) S IBER=IBER_"IB061;" + ; + ;Statement Covers To + I IBTDT="" S IBER=IBER_"IB062;" + I IBTDT]"",IBTDT'?7N&(IBTDT'?7N1".".N) S IBER=IBER_"IB062;" + I IBTDT>DT!(IBTDTthan today's date + S IBTFY=$$FY^IBOUTL(IBTDT) + ; + ;Statement crosses fiscal years + ;I IBTFY'=IBFFY S IBER=IBER_"IB047;" + ; + ;Statement crosses calendar years + ;I $E(IBTDT,1,3)'=$E(IBFDT,1,3) S IBER=IBER_"IB046;" + ; + ;Total Charges + I +IBTC'>0!(+IBTC'=IBTC) S IBER=IBER_"IB064;" + ; + ;Billable charges for secondary claim + I $$MCRONBIL^IBEFUNC(IBIFN)&(($P(IBNDU1,U,1)-$P(IBNDU1,U,2))'>0) S IBER=IBER_"IB094;" + ;Fiscal Year 1 + S IBFFY=$$FY^IBOUTL(IBFDT) + ; + ;Check provider link for current user, enterer, reviewer and Authorizor + I '$D(^VA(200,DUZ,0)) S IBER=IBER_"IB048;" + I IBEU]"",'$D(^VA(200,IBEU,0)) S IBER=IBER_"IB048;" + I IBRU]"",'$D(^VA(200,IBRU,0)) S IBER=IBER_"IB060;" + I IBAU]"",'$D(^VA(200,IBAU,0)) S IBER=IBER_"IB041;" + ; + ;Bill exists and not already new bill + ;I $S('$D(^PRCA(430,IBIFN,0)):1,$P($P(^PRCA(430,IBIFN,0),"^"),"-",2)'=IBBNO:1,1:0) S IBER=IBER_"IB056;" + ;I $P($$BN^PRCAFN(IBIFN),"-",2)'=IBBNO S IBER=IBER_"IB056;" + ;I IBER="",$P(^PRCA(430,IBIFN,0),"^",8)=$O(^PRCA(430.3,"AC",104,"")) S IBER=IBER_"IB040;" + I IBER="",+$$STA^PRCAFN(IBIFN)=104 S IBER=IBER_"IB040;" + ; If ins bill, must have valid COB sequence + I $P(IBND0,U,11)="i",$S($P(IBND0,U,21)="":1,1:"PST"'[$P(IBND0,U,21)) S IBER=IBER_"IB324;" + ; + ; Check for valid sec provider id for current ins + S Z=0 F S Z=$O(^DGCR(399,IBIFN,"PRV",Z)) Q:'Z S Z0=$G(^(Z,0)),Z1=+$$COBN^IBCEF(IBIFN) I $P(Z0,U,4+Z1)'="",$P(Z0,U,11+Z1)'="" D + . I '$$SECIDCK^IBCEF74(IBIFN,Z1,$P(Z0,U,11+Z1),Z) D WARN^IBCBB11("Prov secondary id type for the "_$P("PRIMARY^SECONDARY^TERTIARY",U,Z1)_" "_$$EXTERNAL^DILFD(399.0222,.01,,+Z0)_" is invalid/won't transmit") + ; Check NPIs + D NPICHK^IBCBB11 + ; + ; Check taxonomies + D TAXCHK^IBCBB11 + ; + ; Check for Physician Name + K IBXDATA D F^IBCEF("N-ATT/REND PHYSICIAN NAME",,,IBIFN) + I $P($G(IBXDATA),U)="" S IBER=IBER_"IB303;" + ; + N FUNCTION,IBINS + S FUNCTION=$S($$FT^IBCEF(IBIFN)=3:4,1:3) + I IBER'["IB303;" D + . F IBINS=1:1:3 D + .. S Z=$$GETTYP^IBCEP2A(IBIFN,IBINS) + .. I Z,$P(Z,U,2) D ; Rendering/attending prov secondary id required + ... N IBID,IBOK,Q0 + ... D PROVINF^IBCEF74(IBIFN,IBINS,.IBID,1,"C") ; check all as though they were current + ... S IBOK=0 + ... S Q0=0 F S Q0=$O(IBID(1,FUNCTION,Q0)) Q:'Q0 I $P(IBID(1,FUNCTION,Q0),U,9)=+Z S IBOK=1 Q + ... I 'IBOK S IBER=IBER_$S(IBINS=1:"IB236;",IBINS=2:"IB237;",IBINS=3:"IB238;",1:"") + . I $$TXMT^IBCEF4(IBIFN) D + .. D F^IBCEF("N-ALL ATT/REND PROV SSN/EI","IBZ",,IBIFN) + .. I $P(IBZ,U,3)=""&($P(IBZ,U,4)="") S IBER=IBER_"IB321;" ; SSN/IEN required for rend/att + ; + N IBM,IBM1 + S IBM=$G(^DGCR(399,IBIFN,"M")) + S IBM1=$G(^DGCR(399,IBIFN,"M1")) + I $P(IBM,U),$P($G(^DIC(36,$P(IBM,U),4)),U,6),$P(IBM1,U,2)="" S IBER=IBER_"IB244;" + I $P(IBM,U,2),$P($G(^DIC(36,$P(IBM,U,2),4)),U,6),$P(IBM1,U,3)="" S IBER=IBER_"IB245;" + I $P(IBM,U,3),$P($G(^DIC(36,$P(IBM,U,3),4)),U,6),$P(IBM1,U,4)="" S IBER=IBER_"IB246;" + ; + ; If outside facility, check for ID and qualifier in 355.93 + ; 5/15/06 - esg - hard error IB243 turned into warning message instead + S Z=$P($G(^DGCR(399,IBIFN,"U2")),U,10) + I Z D + . I $P($G(^IBA(355.93,Z,0)),U,9)=""!($P($G(^IBA(355.93,Z,0)),U,13)="") D + .. N Z1,Z2 + .. S Z1="Missing Lab or Facility Primary ID for non-VA facility, " + .. S Z2=$$EXTERNAL^DILFD(399,232,,Z) + .. I $L(Z2)'>19 D WARN^IBCBB11(Z1_Z2) Q + .. D WARN^IBCBB11(Z1),WARN^IBCBB11(" "_Z2) + .. Q + . Q + ; + ; Must be one and only one division on bill + S IBZ=$$MULTDIV^IBCBB11(IBIFN,IBND0) + I IBZ S IBER=IBER_$S(IBZ=1:"IB095;",IBZ=2:"IB104;",1:"IB105;") + ; Division address must be defined in institution file + I $P(IBND0,U,22) D + . N Z,Z0,Z1 + . S Z0=$G(^DIC(4,+$P($G(^DG(40.8,+$P(IBND0,U,22),0)),U,7),0)) + . S Z1=$G(^DIC(4,+$P($G(^DG(40.8,+$P(IBND0,U,22),0)),U,7),1)) + . I $P(Z0,U,2)="" S IBER=IBER_"IB097;" Q + . F Z=1,3,4 I $P(Z1,U,Z)="" S IBER=IBER_"IB097;" Q + ; + ;CHAMPVA Rate Type and Primary Insurance Carriers Type of Coverage must match + S (IBRTCHV,IBPICHV)=0 + I $P($G(^DGCR(399.3,+IBAT,0)),U,1)="CHAMPVA" S IBRTCHV=1 + I $P($G(^IBE(355.2,+$P($G(^DIC(36,+IBNDMP,0)),U,13),0)),U,1)="CHAMPVA" S IBPICHV=1 + I (+IBRTCHV!+IBPICHV)&('IBRTCHV!'IBPICHV) S IBER=IBER_"IB085;" + ; + N IBZPRC,IBZPRCUB + D F^IBCEF("N-ALL PROCEDURES","IBZPRC",,IBIFN) + ; Procedure Clinic is required for Surgical Procedures Outpt Facility Charges + I +$P(IBND0,U,27)'=2,$$BILLRATE^IBCRU3(IBAT,IBCL,IBEVDT,"RC OUTPATIENT") D + . N Z,Z0,Z1,ZE S (ZE,Z)=0 F S Z=$O(^DGCR(399,IBIFN,"CP",Z)) Q:'Z D I +ZE S IBER=IBER_"IB320;" Q + .. S Z0=$G(^DGCR(399,IBIFN,"CP",Z,0)),Z1=+Z0 I Z0'[";ICPT(" Q + .. I '((Z1'<10000)&(Z1'>69999))&'((Z1'<93501)&(Z1'>93533)) Q + .. I '$P(Z0,U,7) S ZE=1 + ; + ; Extract procedures for UB-04 + D F^IBCEF("N-UB-04 PROCEDURES","IBZPRCUB",,IBIFN) + ; Does this bill have ANY prescriptions associated with it? + ; Must bill prescriptions separately from other charges + ; + I $$ISRX^IBCEF1(IBIFN) D + . N IBZ,IBRXDEF + . S IBRXDEF=$P($G(^IBE(350.9,1,1)),U,30),IBZ=0 + . F S IBZ=$O(IBZPRCUB(IBZ)) Q:'IBZ I IBZPRCUB(IBZ),+$P(IBZPRCUB(IBZ),U)'=IBRXDEF S IBER=IBER_"IB102;" Q + . K IBZ + ; + ; Check that COB sequences are not skipped + K Z + F Z=1:1:3 S:+$G(^DGCR(399,IBIFN,"I"_Z)) Z(Z)="" + F Z=0:1:2 S Z0=$O(Z(Z)) Q:'Z0 I Z0'=(Z+1) S IBER=IBER_"IB322;" Q + K Z + I $P($G(^DGCR(399,IBIFN,0)),U,21)="" S IBER=IBER_"IB323;" + K IBXDATA D F^IBCEF("N-PROCEDURE CODING METHD",,,IBIFN) + ; Coding method should agree with types of procedure codes + S IBOK=$S('$O(IBZPRC(0))!(IBXDATA=""):1,1:0) + I 'IBOK S IBOK=1,IBZ=0 F S IBZ=$O(IBZPRC(IBZ)) Q:'IBZ I IBZPRC(IBZ),$P(IBZPRC(IBZ),U)'[$S(IBXDATA=9:"ICD",1:"ICP") S IBOK=0 Q + I 'IBOK D WARN^IBCBB11("Coding Method does not agree with all procedure codes found on bill") + D EDITMRA^IBCBB3(.IBQUIT,.IBER,IBIFN,IBFT) + Q:$G(IBQUIT) + ; + ;Other things that could be added: Rev Code - calculating charges + ; Diagnosis Coding, if MT copay - check for other co-payments + ; + I $P(IBNDTX,U,8),$$REQMRA^IBEFUNC(IBIFN) S IBER=IBER_"IB121;" ; can't force MRAs to print + I $P(IBNDTX,U,8)!$P(IBNDTX,U,9) D WARN^IBCBB11($S($$REQMRA^IBEFUNC(IBIFN)&($P(IBNDTX,U,9)):"MRA Secondary ",1:"")_"Bill has been forced to print "_$S($P(IBNDTX,U,8)=1!($P(IBNDTX,U,9)=1):"locally",1:"at clearinghouse")) + N IBXZ,IBIZ F IBIZ=12,13,14 S IBXZ=$P(IBNDM,U,IBIZ) I +IBXZ S IBXZ=$P($G(^DPT(DFN,.312,IBXZ,0)),U,18) I +IBXZ S IBXZ=$G(^IBA(355.3,+IBXZ,0)) I +$P(IBXZ,U,12) D + . D WARN^IBCBB11($P($G(^DIC(36,+IBXZ,0)),U,1)_" requires Amb Care Certification") + ; + D VALNDC^IBCBB11(IBIFN,DFN) ;validate NDC# + ;Build AR array if no errors and MRA not needed or already rec'd + I IBER="",$S($$NEEDMRA^IBEFUNC(IBIFN)!($$REQMRA^IBEFUNC(IBIFN)):0,1:1) D ARRAY + ; +END ;Don't kill IBIFN, IBER, DFN + I $O(^TMP($J,"BILL-WARN",0)),$G(IBER)="" S IBER="WARN" ;Warnings only + K IBBNO,IBEVDT,IBLOC,IBCL,IBTF,IBAT,IBWHO,IBST,IBFDT,IBTDT,IBTC,IBFY,IBFY1,IBAU,IBRU,IBEU,IBARTP,IBFYC,IBMRA,IBTOB,IBTOB12,IBNDU2,IBNDUF3,IBNDUF31,IBNDTX + K IBNDS,IBND0,IBNDU,IBNDM,IBNDMP,IBNDU1,IBFFY,IBTFY,IBFT,IBRTCHV,IBPICHV,IBXDATA,IBOK + I $D(IBER),IBER="" W !,"No Errors found for National edits" + Q + ; +ARRAY ;Build PRCASV(array) + N IBCOBN,X + K PRCASV + Q:$$MCRWNR^IBEFUNC(+$$CURR^IBCEF2(IBIFN)) + S IBCOBN=$$COBN^IBCEF(IBIFN) + S X=IBIFN + S PRCASV("BDT")=DT,PRCASV("ARREC")=IBIFN + S PRCASV("APR")=DUZ + S PRCASV("PAT")=DFN,PRCASV("CAT")=$P(^DGCR(399.3,IBAT,0),"^",6) + I IBWHO="i" S PRCASV("DEBTOR")=+IBNDMP_";DIC(36," + S PRCASV("DEBTOR")=$S(IBWHO="p":DFN_";DPT(",IBWHO="o":$P(IBNDM,"^",11)_";DIC(4,",IBWHO="i":PRCASV("DEBTOR"),1:"") + S PRCASV("CARE")=$E($$TOB^IBCEF1(IBIFN),1,2) + S PRCASV("FY")=$$FY^IBOUTL(DT)_U_($P(IBNDU1,U)-$P(IBNDU1,U,2)) + ;S PRCASV("FY")=$P(IBNDU1,U,9)_U_$S($P(IBNDU1,U,2)]"":($P(IBNDU1,U,10)-$P(IBNDU1,U,2)),1:$P(IBNDU1,U,10))_$S($P(IBNDU1,U,11)]"":U_$P(IBNDU1,U,11)_U_$P(IBNDU1,U,12),1:"") +PLUS I IBWHO="i",$P(IBNDM,"^",2),$D(^DIC(36,$P(IBNDM,"^",2),0)) S PRCASV("2NDINS")=$P(IBNDM,"^",2) + I IBWHO="i",$P(IBNDM,"^",3),$D(^DIC(36,$P(IBNDM,"^",3),0)) S PRCASV("3RDINS")=$P(IBNDM,"^",3) + ; + N IBX S IBX=$P(IBND0,U,21),IBX=$S(IBX="P":"I1",IBX="S":"I2",IBX="T":"I3",1:"") Q:IBX="" + N IBNDI1 + Q:'$D(^DGCR(399,IBIFN,IBX)) S IBNDI1=^(IBX) + S:$P(IBNDI1,"^",3)]"" PRCASV("GPNO")=$P(IBNDI1,"^",3) + S:$P(IBNDI1,"^",15)]"" PRCASV("GPNM")=$P(IBNDI1,"^",15) + S:$P(IBNDI1,"^",17)]"" PRCASV("INPA")=$P(IBNDI1,"^",17) + S:$P(IBNDI1,"^",2)]"" PRCASV("IDNO")=$P(IBNDI1,"^",2),PRCASV("INID")=PRCASV("IDNO") + ; Check that this is a secondary or tertiary bill and insurance for previous + ; COB sequence is Medicare WNR and MRA is active --> send data elements to AR + I IBCOBN>1,$$WNRBILL^IBEFUNC(IBIFN,IBCOBN-1),$$EDIACTV^IBCEF4(2) D MRA + Q + ; +MRA N IBEOB S IBEOB=0 + ; + K PRCASV("MEDURE"),PRCASV("MEDCA") + ; Get EOB data + F S IBEOB=$O(^IBM(361.1,"B",IBIFN,IBEOB)) Q:'IBEOB D + . D MRACALC^IBCEMU2(IBEOB,IBIFN,1,.PRCASV) + Q ;MRA + ; + ;; PREGNANCY DX CODES: V22**-V24**, V27**-V28**, 630**-677** + ;; FLU SHOTS PROCEDURE CODES: 90724, G0008, 90732, G0009 diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB11.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB11.m index 9e281d6f..662b1312 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB11.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB11.m @@ -1,96 +1,75 @@ -IBCBB11 ;ALB/AAS - CONTINUATION OF EDIT CHECK ROUTINE ;12 Jun 2006 3:45 PM - ;;2.0;INTEGRATED BILLING;**51,343,363,371,395,392,401**;21-MAR-94;Build 5 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -WARN(IBDISP) ; Set warning in global - ; DISP = warning text to display - ; - N Z - S Z=+$O(^TMP($J,"BILL-WARN",""),-1) - I Z=0 S ^TMP($J,"BILL-WARN",1)=$J("",5)_"**Warnings**:",Z=1 - S Z=Z+1,^TMP($J,"BILL-WARN",Z)=$J("",5)_IBDISP - Q - ; -MULTDIV(IBIFN,IBND0) ; Check for multiple divisions on a bill ien IBIFN - ; IBND0 = 0-node of bill - ; - ; Function returns 1 if more than 1 division found on bill - N Z,Z0,Z1,MULT - S MULT=0,Z1=$P(IBND0,U,22) - I Z1 D - . S Z=0 F S Z=$O(^DGCR(399,IBIFN,"RC",Z)) Q:'Z S Z0=$P(^(Z,0),U,7) I Z0,Z0'=Z1 S MULT=1 Q - . S Z=0 F S Z=$O(^DGCR(399,IBIFN,"CP",Z)) Q:'Z S Z0=$P(^(Z,0),U,6) I Z0,Z0'=Z1 S MULT=2 Q - I 'Z1 S MULT=3 - Q MULT - ; - ;; PREGNANCY DX CODES: V22**-V24**, V27**-V28**, 630**-677** - ;; FLU SHOTS PROCEDURE CODES: 90724, G0008, 90732, G0009 - ; - ; Check for required NPIs -NPICHK ; - N IBNPIS,IBNONPI,IBNPIREQ,Z - S IBNPIREQ=$$NPIREQ^IBCEP81(DT) ; Check if NPI is required - ; Check providers - S IBNPIS=$$PROVNPI^IBCEF73A(IBIFN,.IBNONPI) - I $L(IBNONPI) F Z=1:1:$L(IBNONPI,U) D - . I IBNPIREQ S IBER=IBER_"IB"_(140+$P(IBNONPI,U,Z))_";" Q ; If required, set error - . D WARN("NPI for the "_$P("referring^operating^rendering^attending^supervising^^^^other",U,$P(IBNONPI,U,Z))_" provider has no value") ; Else, set warning - ; Check organizations - S IBNONPI="" - S IBNPIS=$$ORGNPI^IBCEF73A(IBIFN,.IBNONPI) - I $L(IBNONPI) F Z=1:1:$L(IBNONPI,U) D - . ; Turn IB161, IB162 to a warning - . I IBNPIREQ,$P(IBNONPI,U,Z)=3 S IBER=IBER_"IB163;" Q - . ; PRXM/KJH - Changed descriptions. - . D WARN("NPI for the "_$P("Division^Non-VA Service Facility^Billing Provider",U,$P(IBNONPI,U,Z))_" has no value") ; Else, set warning - Q - ; - ; Check for required taxonomies -TAXCHK ; - N IBTAXS,IBNOTAX,IBTAXREQ,Z - S IBTAXREQ=$$TAXREQ^IBCEP81(DT) ; Check if taxonomy is required - ; Check providers - S IBTAXS=$$PROVTAX^IBCEF73A(IBIFN,.IBNOTAX) - I $L(IBNOTAX) F Z=1:1:$L(IBNOTAX,U) D - . ; Only Referring, Rendering and Attending are currently sent to the payer - . I IBTAXREQ,"134"[$P(IBNOTAX,U,Z) S IBER=IBER_"IB"_(250+$P(IBNOTAX,U,Z))_";" Q ; If required, set error - . D WARN("Taxonomy for the "_$P("referring^operating^rendering^attending^supervising^^^^other",U,$P(IBNOTAX,U,Z))_" provider has no value") ; Else, set warning - ; Check organizations - S IBNOTAX="" - S IBTAXS=$$ORGTAX^IBCEF73A(IBIFN,.IBNOTAX) - I $L(IBNOTAX) F Z=1:1:$L(IBNOTAX,U) D - . ; Turn IB165, IB166 to a warning - . I IBTAXREQ,$P(IBNOTAX,U,Z)=3 S IBER=IBER_"IB167;" Q - . ; PRXM/KJH - Changed descriptions. - . D WARN("Taxonomy for the "_$P("Division^Non-VA Service Facility^Billing Provider",U,$P(IBNOTAX,U,Z))_" has no value") ; Else, set warning - Q - ; -VALNDC(IBIFN,IBDFN) ; IB*2*363 - validate NDC# between PRESCRIPTION file (#52) - ; and IB BILL/CLAIMS PRESCRIPTION REFILL file (#362.4) - ; input - IBIFN = internal entry number of the billing record in the BILL/CLAIMS file (#399) - ; IBDFN = internal entry number of patient record in the PATIENT file (#2) - N IBX,IBRXCOL - ; call program that determines if NDC differences exist - D VALNDC^IBEFUNC3(IBIFN,IBDFN,.IBRXCOL) - Q:'$D(IBRXCOL) - ; at least one RX on the IB record has an NDC discrepancy - S IBX=0 F S IBX=$O(IBRXCOL(IBX)) Q:'IBX D WARN("NDC# on Bill does not equal the NDC# on Rx "_IBRXCOL(IBX)) - Q - ; -PRIIDCHK ; Check for required Pimarary ID (SSN/EIN) - ; If the provider is on the claim, he must have one - ; - N IBI,IBZ - I $$TXMT^IBCEF4(IBIFN) D - . D F^IBCEF("N-ALL ATT/REND PROV SSN/EI","IBZ",,IBIFN) - . S IBI="" F S IBI=$O(^DGCR(399,IBIFN,"PRV","B",IBI)) Q:IBI="" D - .. I $P(IBZ,U,IBI)="" S IBER=IBER_$S(IBI=1:"IB151;",IBI=2:"IB152;",IBI=3!(IBI=4):"IB321;",IBI=5:"IB153;",IBI=9:"IB154;",1:"") - Q - ; -RXNPI(IBIFN) ; check for multiple pharmacy npi's on the same bill - N IBORG,IBRXNPI,IBX,IBY - S IBORG=$$RXSITE^IBCEF73A(IBIFN,.IBORG) - S IBX=0 F S IBX=$O(IBORG(IBX)) Q:'IBX S IBY=0 F S IBY=$O(IBORG(IBX,IBY)) Q:'IBY S IBRXNPI(+IBORG(IBX,IBY))="" - S (IBX,IBY)=0 F S IBX=$O(IBRXNPI(IBX)) Q:'IBX S IBY=IBY+1 - I IBY>1 D WARN("Bill has prescriptions resulting from "_IBY_" different NPI locations") - Q +IBCBB11 ;ALB/AAS - CONTINUATION OF EDIT CHECK ROUTINE ;12 Jun 2006 3:45 PM + ;;2.0;INTEGRATED BILLING;**51,343,363**;21-MAR-94;Build 35 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; +WARN(IBDISP) ; Set warning in global + ; DISP = warning text to display + ; + N Z + S Z=+$O(^TMP($J,"BILL-WARN",""),-1) + I Z=0 S ^TMP($J,"BILL-WARN",1)=$J("",5)_"**Warnings**:",Z=1 + S Z=Z+1,^TMP($J,"BILL-WARN",Z)=$J("",5)_IBDISP + Q + ; +MULTDIV(IBIFN,IBND0) ; Check for multiple divisions on a bill ien IBIFN + ; IBND0 = 0-node of bill + ; + ; Function returns 1 if more than 1 division found on bill + N Z,Z0,Z1,MULT + S MULT=0,Z1=$P(IBND0,U,22) + I Z1 D + . S Z=0 F S Z=$O(^DGCR(399,IBIFN,"RC",Z)) Q:'Z S Z0=$P(^(Z,0),U,7) I Z0,Z0'=Z1 S MULT=1 Q + . S Z=0 F S Z=$O(^DGCR(399,IBIFN,"CP",Z)) Q:'Z S Z0=$P(^(Z,0),U,6) I Z0,Z0'=Z1 S MULT=2 Q + I 'Z1 S MULT=3 + Q MULT + ; + ;; PREGNANCY DX CODES: V22**-V24**, V27**-V28**, 630**-677** + ;; FLU SHOTS PROCEDURE CODES: 90724, G0008, 90732, G0009 + ; + ; Check for required NPIs +NPICHK ; + N IBNPIS,IBNONPI,IBNPIREQ,Z + S IBNPIREQ=$$NPIREQ^IBCEP81(DT) ; Check if NPI is required + ; Check providers + S IBNPIS=$$PROVNPI^IBCEF73A(IBIFN,.IBNONPI) + I $L(IBNONPI) F Z=1:1:$L(IBNONPI,U) D + . I IBNPIREQ S IBER=IBER_"IB"_(140+$P(IBNONPI,U,Z))_";" Q ; If required, set error + . D WARN("NPI for the "_$P("referring^operating^rendering^attending^supervising^^^^other",U,$P(IBNONPI,U,Z))_" provider has no value") ; Else, set warning + ; Check organizations + S IBNONPI="" + S IBNPIS=$$ORGNPI^IBCEF73A(IBIFN,.IBNONPI) + I $L(IBNONPI) F Z=1:1:$L(IBNONPI,U) D + . I IBNPIREQ S IBER=IBER_"IB"_(160+$P(IBNONPI,U,Z))_";" Q ; If required, set error + . ; PRXM/KJH - Changed descriptions. + . D WARN("NPI for the "_$P("Division^Non-VA Service Facility^Billing Provider",U,$P(IBNONPI,U,Z))_" has no value") ; Else, set warning + Q + ; + ; Check for required taxonomies +TAXCHK ; + N IBTAXS,IBNOTAX,IBTAXREQ,Z + S IBTAXREQ=$$TAXREQ^IBCEP81(DT) ; Check if taxonomy is required + ; Check providers + S IBTAXS=$$PROVTAX^IBCEF73A(IBIFN,.IBNOTAX) + I $L(IBNOTAX) F Z=1:1:$L(IBNOTAX,U) D + . I IBTAXREQ S IBER=IBER_"IB"_(250+$P(IBNOTAX,U,Z))_";" Q ; If required, set error + . D WARN("Taxonomy for the "_$P("referring^operating^rendering^attending^supervising^^^^other",U,$P(IBNOTAX,U,Z))_" provider has no value") ; Else, set warning + ; Check organizations + S IBNOTAX="" + S IBTAXS=$$ORGTAX^IBCEF73A(IBIFN,.IBNOTAX) + I $L(IBNOTAX) F Z=1:1:$L(IBNOTAX,U) D + . I IBTAXREQ S IBER=IBER_"IB"_(164+$P(IBNOTAX,U,Z))_";" Q ; If required, set error + . ; PRXM/KJH - Changed descriptions. + . D WARN("Taxonomy for the "_$P("Division^Non-VA Service Facility^Billing Provider",U,$P(IBNOTAX,U,Z))_" has no value") ; Else, set warning + Q + ; +VALNDC(IBIFN,IBDFN) ; IB*2*363 - validate NDC# between PRESCRIPTION file (#52) + ; and IB BILL/CLAIMS PRESCRIPTION REFILL file (#362.4) + ; input - IBIFN = internal entry number of the billing record in the BILL/CLAIMS file (#399) + ; IBDFN = internal entry number of patient record in the PATIENT file (#2) + N IBX,IBRXCOL + ; call program that determines if NDC differences exist + D VALNDC^IBEFUNC3(IBIFN,IBDFN,.IBRXCOL) + Q:'$D(IBRXCOL) + ; at least one RX on the IB record has an NDC discrepancy + S IBX=0 F S IBX=$O(IBRXCOL(IBX)) Q:'IBX D WARN("NDC# on Bill does not equal the NDC# on Rx "_IBRXCOL(IBX)) + Q diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB2.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB2.m index 1bbd51a3..3205cf8d 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB2.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB2.m @@ -1,131 +1,127 @@ -IBCBB2 ;ALB/ARH - CONTINUATION OF EDIT CHECKS ROUTINE (CMS-1500) ;04/14/92 - ;;2.0;INTEGRATED BILLING;**51,137,210,245,232,296,320,349,371**;21-MAR-94;Build 57 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ;MAP TO DGCRBB2 - ; -EN ; - N IBI,IBJ,IBN,IBY,IBDX,IBDXO,IBDXL,IBCPT,IBCPTL,IBOLAB,Z,IBXSAVE,IBLOC,IBTX,IBPS,IBSP,IBLCT,IBNVFLG,IBU3 - I '$D(IBER) S IBER="" - S IBTX=$$TXMT^IBCEF4(IBIFN) - ; - ; Max 4 modifiers per CPT code allowed before warning - K IBXDATA - D F^IBCEF("N-HCFA 1500 MODIFIERS",,,IBIFN) ;Get modifiers - ; - S Z=0 F S Z=$O(IBZPRC92(Z)) Q:'Z I $P(IBZPRC92(Z),U)["ICPT(",$L($P(IBZPRC92(Z),U,15),",")>4 S IBI="Proc "_$$PRCD^IBCEF1($P(IBZPRC92(Z),U))_" has > 4 modifiers - only first 4 will be used" D WARN^IBCBB11(IBI) - ; ICD-9 diagnosis, at least 1 required - D SET^IBCSC4D(IBIFN,.IBDX,.IBDXO) I '$P(IBDX,U,2) S IBER=IBER_"IB071;" - S IBI=$O(IBDXO(0)) - I IBI,$$INPAT^IBCEF(IBIFN,1),$E($$ICD9^IBACSV(+$P(IBDXO(IBI),U)))="V" S Z="Principal Dx V-code may not be valid" D WARN^IBCBB11(Z) - ; - ; CPT procs must be associated with a dx, must have a defined provider - S (IBLOC,IBN,IBI,IBY)=0 F S IBI=$O(^DGCR(399,IBIFN,"CP",IBI)) Q:IBI'?1N.N S IBCPT=^(IBI,0) D I +IBY S IBN=1 - . I 'IBLOC,$P(IBCPT,U,15)'="",IBTX S Z="At least 1 charge has local box 24K data that will not be transmitted - " S IBLOC=1 D WARN^IBCBB11(Z) S Z=" This data will only print locally" D WARN^IBCBB11(Z) - . I $P(IBCPT,U)'["ICPT(" S:IBER'["IB092" IBER=IBER_"IB092;" Q - . S IBY=1 F IBJ=11:1:14 I +$P(IBCPT,"^",IBJ) S IBCPTL(+$P(IBCPT,"^",IBJ))="",IBY=0 - I +IBN S IBER=IBER_"IB072;" - ; - I '$$OCC10(IBIFN,.IBDX,2) S IBER=IBER_"IB093;" - ; CMS-1500: dxs associated with procs must be defined dxs for the bill - S IBI=0 F S IBI=$O(IBDX(IBI)) Q:'IBI S IBDXL(IBDX(IBI))="" - S (IBN,IBI)=0 F S IBI=$O(IBCPTL(IBI)) Q:'IBI I '$D(IBDXL(IBI)) S IBN=1 Q - I +IBN S IBER=IBER_"IB073;" - ; ejk *296* Change # of diagnoses codes from 4 to 8 on CMS-1500 Claims. - I IBTX S IBI=8 F S IBI=$O(IBDXO(IBI)) Q:'IBI S Z=+$G(IBDX(+$G(IBDXO(IBI)))) I Z,$D(IBCPTL(Z)) D WARN^IBCBB11("Too many diagnoses for claim & will be rejected - consider printing locally") - ; - I $$WNRBILL^IBEFUNC(IBIFN),$$MRATYPE^IBEFUNC(IBIFN)'="B" S IBER=IBER_"IB087;" - ; - ; IB*320 - CLIA# error/warning - error msg for MRA claims, else warning - I $P(IBNDU2,U,13)="",$$CLIAREQ^IBCEP8A(IBIFN) D - . I $$REQMRA^IBEFUNC(IBIFN) S IBER=IBER_"IB235;" Q - . D WARN^IBCBB11("Claim contains laboratory services. The payer may require a CLIA #.") - . Q - ; - ; Only one occurrence code can be present for event date for box 14 - S Z=$$EVENT^IBCF22(IBIFN,.IBXSAVE,.IBI) - I IBI S IBER=IBER_"IB099;" - ; - ; esg - 6/6/07 - warning if missing non-VA care type for outside facility - S IBNVFLG=0 - I $P(IBNDU2,U,10),'$P(IBNDU2,U,11) D WARN^IBCBB11("Non-VA facility indicated, but the Non-VA Care Type field is not defined") S IBNVFLG=1 - ; - ; unit/charge limits - K IBXDATA - D F^IBCEF("N-HCFA 1500 SERVICES (PRINT)",,,IBIFN) ;Get charge lines - S (IBLCT,IBOLAB)=0,IBPS="",IBSP=$$BILLSPEC^IBCEU3(IBIFN) - S IBI=0 F S IBI=$O(IBXDATA(IBI)) Q:'IBI D Q:IBER["IB310"!(IBER["IB311") - . S IBLCT=IBLCT+1 - . I $P(IBNDU2,U,11) D - .. I '$P(IBXDATA(IBI),U,11) S IBPS=IBPS_$S(IBPS'="":",",1:"")_IBI Q - .. I $P(IBXDATA(IBI),U,14),"24"'[$P(IBNDU2,U,11) D WARN^IBCBB11("Outside lab charges exist on a non-lab NON-VA bill") - . I '$P(IBNDU2,U,11),$P(IBXDATA(IBI),U,11) D WARN^IBCBB11("Purchased service amounts are invalid unless this is a NON-VA bill") - . I IBNVFLG,'$P(IBXDATA(IBI),U,11) D WARN^IBCBB11("Non-VA facility indicated, but no purchased service charge on line# "_IBI) - . I $D(IBXDATA(IBI,"A")) S IBER=IBER_"IB310;" Q - . I $D(IBXDATA(IBI,"ARX")),IBER'["311;" S IBER=IBER_"IB311;" Q - . I $P(IBXDATA(IBI),U,14) S IBOLAB=IBOLAB+1 - . ; Place of service required - . I $G(IBER)'["IB314;",$P(IBXDATA(IBI),U,3)="" S IBER=IBER_"IB314;" - . ; Type of service required - . I $G(IBER)'["IB313;",$P(IBXDATA(IBI),U,4)="" S IBER=IBER_"IB313;" - . ; 43 and 53 are invalid types of service - . I $G(IBER)'["IB110;",($P(IBXDATA(IBI),U,4)=43!($P(IBXDATA(IBI),U,4)=53)) S IBER=IBER_"IB110;" - . ; Units for the line item must be less than 100/1000 - . I IBER'["IB088",$P(IBXDATA(IBI),U,9)'<100 D - .. I $P(IBXDATA(IBI),U,4)'=7 S IBER=IBER_"IB088;" Q - .. I $P(IBXDATA(IBI),U,9)'<1000 S IBER=IBER_"IB088;" - . ; Line item total charge must be less than $10,000.00, greater than 0 - . I IBER'["IB090",$P(IBXDATA(IBI),U,9)'<10000 S IBER=IBER_"IB090;" - . I '($P(IBXDATA(IBI),U,9)*$P(IBXDATA(IBI),U,8)),$$COBN^IBCEF(IBIFN)'>1 S Z="Procedure "_$P(IBXDATA(IBI),U,5)_" has a 0-charge and will not be transmitted" D WARN^IBCBB11(Z) - I IBTX,IBLCT>50 D - . I '$$REQMRA^IBEFUNC(IBIFN) S IBER=IBER_"IB308;" Q - . I '$P(IBNDTX,U,9) S IBER=IBER_"IB325;" - S IBU3=$P($G(^DGCR(399,IBIFN,"U3")),U,4,7) I $TR(IBU3,U)'="" D - .I +IBSP'=35 D WARN^IBCBB11("Chiropractic service details only valid if provider specialty is '35'") - .I $P(IBU3,U,2)="" S IBER=IBER_"IB137;" - .I $P(IBU3,U,4)="" S IBER=IBER_"IB138;" Q - .I $P(IBU3,U,3)="","AM"[$P(IBU3,U,4) S IBER=IBER_"IB139;" - .Q - I IBPS'="" D WARN^IBCBB11("NON-VA facility indicated, but no purchased service charge on line item"_$S(IBPS[",":"s",1:"")_" #"_IBPS) - I $P(IBNDU2,U,11),$P(IBNDU2,U,11)=4,IBOLAB>1 D WARN^IBCBB11("For proper payment, you must bill each outside lab on a separate claim form") - K IBXDATA - ; - ; ; Check for Physician Name - D F^IBCEF("N-REFERRING PROVIDER NAME",,,IBIFN) - I $P($G(IBXDATA),U)]"" D - .N IBZ,FUNCTION,IBINS - .S FUNCTION=1 - .F IBINS=1:1:3 D - .. S Z=$$GETTYP^IBCEP2A(IBIFN,IBINS,FUNCTION) - .. I Z,$P(Z,U,2) D ; Rendering/attending prov secondary id required - ... N IBID,IBOK,Q0 - ... D PROVINF^IBCEF74(IBIFN,IBINS,.IBID,1,"C") ; check all as though they were current - ... S IBOK=0 - ... S Q0=0 F S Q0=$O(IBID(1,FUNCTION,Q0)) Q:'Q0 I $P(IBID(1,FUNCTION,Q0),U,9)=+Z S IBOK=1 Q - ... I 'IBOK S IBER=IBER_$S(IBINS=1:"IB239;",IBINS=2:"IB240;",IBINS=3:"IB241;",1:"") - ; - Q - ; -OCC10(IBIFN,IBARR,IBFT) ; Determine if occurrence code 10 exists for pregnancy dx - ; IBARR=array subscripted by ien of DX code if IBFT=2 (CMS-1500 form) - ; by seq # and = ien of DX code if IBFT'=2 - ; - N IBN,IBI,IBXDATA,IBXSAVE,IBDX,Z - S IBN=1 - ; - I '$D(^TMP($J,"LMD")) D - . D F^IBCEF("N-OCCURRENCE CODES",,,IBIFN) - . S ^TMP($J,"LMD")="" - . S Z=0 F S Z=$O(IBXSAVE("OCC",Z)) Q:'Z I +IBXSAVE("OCC",Z)=10 S ^TMP($J,"LMD")=1 Q - ; - I '^TMP($J,"LMD") S IBI=0 F S IBI=$O(IBARR(IBI)) Q:'IBI D Q:'IBN - . N Z,Z1 - . ; If a pregnancy DX exists, must be an occurrence code 10 for LMP date - . ; dx ranges are: V22*-V24*, V27*-V28*, 630*-677* - . S IBDX=$S($G(IBFT)'=2:+IBARR(IBI),1:IBI) - . S Z=$E($P($$ICD9^IBACSV(IBDX),U),1,3),Z1=$E(Z,2,3) - . I $S(Z'<630&(Z<678):1,$E(Z)="V":$S(Z1'<22&(Z1<25):1,1:Z1'<27&(Z1<28)),1:0) S IBN=0 ;Pregnancy Dx exists - ; -OCC10Q K ^TMP($J,"LMD") - Q IBN - ; +IBCBB2 ;ALB/ARH - CONTINUATION OF EDIT CHECKS ROUTINE (CMS-1500) ;04/14/92 + ;;2.0;INTEGRATED BILLING;**51,137,210,245,232,296,320,349**;21-MAR-94;Build 46 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; + ;MAP TO DGCRBB2 + ; +EN ; + N IBI,IBJ,IBN,IBY,IBDX,IBDXO,IBDXL,IBCPT,IBCPTL,IBOLAB,Z,IBXSAVE,IBLOC,IBTX,IBPS,IBSP,IBLCT + I '$D(IBER) S IBER="" + S IBTX=$$TXMT^IBCEF4(IBIFN) + ; + ; Warn if no group provider id (MCRWNR is a default) + ; I '$$WNRBILL^IBEFUNC(IBIFN) D + ; . S Z=$P($G(^DGCR(399,IBIFN,"M1")),U,$$COBN^IBCEF(IBIFN)+1) + ; . I Z="" D WARN^IBCBB11("No group prov # for the current ins co - site tax id will be used") + ; Max 4 modifiers per CPT code allowed before warning + K IBXDATA + D F^IBCEF("N-HCFA 1500 MODIFIERS",,,IBIFN) ;Get modifiers + ; + S Z=0 F S Z=$O(IBZPRC92(Z)) Q:'Z I $P(IBZPRC92(Z),U)["ICPT(",$L($P(IBZPRC92(Z),U,15),",")>4 S IBI="Proc "_$$PRCD^IBCEF1($P(IBZPRC92(Z),U))_" has > 4 modifiers - only first 4 will be used" D WARN^IBCBB11(IBI) + ; ICD-9 diagnosis, at least 1 required + D SET^IBCSC4D(IBIFN,.IBDX,.IBDXO) I '$P(IBDX,U,2) S IBER=IBER_"IB071;" + S IBI=$O(IBDXO(0)) + I IBI,$$INPAT^IBCEF(IBIFN,1),$E($$ICD9^IBACSV(+$P(IBDXO(IBI),U)))="V" S Z="Principal Dx V-code may not be valid" D WARN^IBCBB11(Z) + ; + ; CPT procs must be associated with a dx, must have a defined provider + S (IBLOC,IBN,IBI,IBY)=0 F S IBI=$O(^DGCR(399,IBIFN,"CP",IBI)) Q:IBI'?1N.N S IBCPT=^(IBI,0) D I +IBY S IBN=1 + . ;I IBER'["IB089",$P(IBCPT,U,10)=7,$S('$P(IBCPT,U,16):1,1:$P(IBCPT,U,16)#15) S IBER=IBER_"IB089;" ;anesthesia needs minutes in multiple of 15 + . I 'IBLOC,$P(IBCPT,U,15)'="",IBTX S Z="At least 1 charge has local box 24K data that will not be transmitted - " S IBLOC=1 D WARN^IBCBB11(Z) S Z=" This data will only print locally" D WARN^IBCBB11(Z) + . I $P(IBCPT,U)'["ICPT(" S:IBER'["IB092" IBER=IBER_"IB092;" Q + . S IBY=1 F IBJ=11:1:14 I +$P(IBCPT,"^",IBJ) S IBCPTL(+$P(IBCPT,"^",IBJ))="",IBY=0 + . ;I '$P(IBCPT,U,18) S:IBER'["IB094;" IBER=IBER_"IB094;" Q + I +IBN S IBER=IBER_"IB072;" + ; + I '$$OCC10(IBIFN,.IBDX,2) S IBER=IBER_"IB093;" + ; CMS-1500: dxs associated with procs must be defined dxs for the bill + S IBI=0 F S IBI=$O(IBDX(IBI)) Q:'IBI S IBDXL(IBDX(IBI))="" + S (IBN,IBI)=0 F S IBI=$O(IBCPTL(IBI)) Q:'IBI I '$D(IBDXL(IBI)) S IBN=1 Q + I +IBN S IBER=IBER_"IB073;" + ; ejk *296* Change # of diagnoses codes from 4 to 8 on CMS-1500 Claims. + I IBTX S IBI=8 F S IBI=$O(IBDXO(IBI)) Q:'IBI S Z=+$G(IBDX(+$G(IBDXO(IBI)))) I Z,$D(IBCPTL(Z)) D WARN^IBCBB11("Too many diagnoses for claim & will be rejected - consider printing locally") + ; + I $$WNRBILL^IBEFUNC(IBIFN),$$MRATYPE^IBEFUNC(IBIFN)'="B" S IBER=IBER_"IB087;" + ; + ; IB*320 - CLIA# error/warning - error msg for MRA claims, else warning + I $P(IBNDU2,U,13)="",$$CLIAREQ^IBCEP8A(IBIFN) D + . I $$REQMRA^IBEFUNC(IBIFN) S IBER=IBER_"IB235;" Q + . D WARN^IBCBB11("Claim contains laboratory services. The payer may require a CLIA #.") + . Q + ; + ; Only one occurrence code can be present for event date for box 14 + S Z=$$EVENT^IBCF22(IBIFN,.IBXSAVE,.IBI) + I IBI S IBER=IBER_"IB099;" + ; unit/charge limits + K IBXDATA + D F^IBCEF("N-HCFA 1500 SERVICES (PRINT)",,,IBIFN) ;Get charge lines + S (IBLCT,IBOLAB)=0,IBPS="",IBSP=$$BILLSPEC^IBCEU3(IBIFN) + S IBI=0 F S IBI=$O(IBXDATA(IBI)) Q:'IBI D Q:IBER["IB310"!(IBER["IB311") + . S IBLCT=IBLCT+1 + . I $P(IBNDU2,U,11) D + .. I '$P(IBXDATA(IBI),U,11) S IBPS=IBPS_$S(IBPS'="":",",1:"")_IBI Q + .. I $P(IBXDATA(IBI),U,14),"24"'[$P(IBNDU2,U,11) D WARN^IBCBB11("Outside lab charges exist on a non-lab NON-VA bill") + . I '$P(IBNDU2,U,11),$P(IBXDATA(IBI),U,11) D WARN^IBCBB11("Purchased service amounts are invalid unless this is a NON-VA bill") + . I $D(IBXDATA(IBI,"A")) S IBER=IBER_"IB310;" Q + . I $D(IBXDATA(IBI,"ARX")),IBER'["311;" S IBER=IBER_"IB311;" Q + . I $P(IBXDATA(IBI),U,14) S IBOLAB=IBOLAB+1 + . ; Place of service required + . I $G(IBER)'["IB314;",$P(IBXDATA(IBI),U,3)="" S IBER=IBER_"IB314;" + . ; Type of service required + . I $G(IBER)'["IB313;",$P(IBXDATA(IBI),U,4)="" S IBER=IBER_"IB313;" + . ; 43 and 53 are invalid types of service + . I $G(IBER)'["IB110;",($P(IBXDATA(IBI),U,4)=43!($P(IBXDATA(IBI),U,4)=53)) S IBER=IBER_"IB110;" + . ; Units for the line item must be less than 100/1000 + . I IBER'["IB088",$P(IBXDATA(IBI),U,9)'<100 D + .. I $P(IBXDATA(IBI),U,4)'=7 S IBER=IBER_"IB088;" Q + .. I $P(IBXDATA(IBI),U,9)'<1000 S IBER=IBER_"IB088;" + . ; Line item total charge must be less than $10,000.00, greater than 0 + . I IBER'["IB090",$P(IBXDATA(IBI),U,9)'<10000 S IBER=IBER_"IB090;" + . I '($P(IBXDATA(IBI),U,9)*$P(IBXDATA(IBI),U,8)),$$COBN^IBCEF(IBIFN)'>1 S Z="Procedure "_$P(IBXDATA(IBI),U,5)_" has a 0-charge and will not be transmitted" D WARN^IBCBB11(Z) + . I $G(IBXDATA(IBI,"AUX"))'="",'$G(IBSP(1)),+IBSP'=35,$TR($P(IBXDATA(IBI,"AUX"),U,4,6)_$P(IBXDATA(IBI,"AUX"),U,2),U)'="" S IBSP(1)=1 + I IBTX,IBLCT>50 D + . I '$$REQMRA^IBEFUNC(IBIFN) S IBER=IBER_"IB308;" Q + . I '$P(IBNDTX,U,9) S IBER=IBER_"IB325;" + I $G(IBSP(1)) D WARN^IBCBB11("Chiropractic service details only valid if provider specialty is '35'") + I IBPS'="" D WARN^IBCBB11("NON-VA facility indicated, but no purchased service charge on line item"_$S(IBPS[",":"s",1:"")_" #"_IBPS) + I $P(IBNDU2,U,11),$P(IBNDU2,U,11)=4,IBOLAB>1 D WARN^IBCBB11("For proper payment, you must bill each outside lab on a separate claim form") + K IBXDATA + ; + ; ; Check for Physician Name + D F^IBCEF("N-REFERRING PROVIDER NAME",,,IBIFN) + I $P($G(IBXDATA),U)]"" D + .N IBZ,FUNCTION,IBINS + .S FUNCTION=1 + .F IBINS=1:1:3 D + .. S Z=$$GETTYP^IBCEP2A(IBIFN,IBINS,FUNCTION) + .. I Z,$P(Z,U,2) D ; Rendering/attending prov secondary id required + ... N IBID,IBOK,Q0 + ... D PROVINF^IBCEF74(IBIFN,IBINS,.IBID,1,"C") ; check all as though they were current + ... S IBOK=0 + ... S Q0=0 F S Q0=$O(IBID(1,FUNCTION,Q0)) Q:'Q0 I $P(IBID(1,FUNCTION,Q0),U,9)=+Z S IBOK=1 Q + ... I 'IBOK S IBER=IBER_$S(IBINS=1:"IB239;",IBINS=2:"IB240;",IBINS=3:"IB241;",1:"") + ; + Q + ; +OCC10(IBIFN,IBARR,IBFT) ; Determine if occurrence code 10 exists for pregnancy dx + ; IBARR=array subscripted by ien of DX code if IBFT=2 (CMS-1500 form) + ; by seq # and = ien of DX code if IBFT'=2 + ; + N IBN,IBI,IBXDATA,IBXSAVE,IBDX,Z + S IBN=1 + ; + I '$D(^TMP($J,"LMD")) D + . D F^IBCEF("N-OCCURRENCE CODES",,,IBIFN) + . S ^TMP($J,"LMD")="" + . S Z=0 F S Z=$O(IBXSAVE("OCC",Z)) Q:'Z I +IBXSAVE("OCC",Z)=10 S ^TMP($J,"LMD")=1 Q + ; + I '^TMP($J,"LMD") S IBI=0 F S IBI=$O(IBARR(IBI)) Q:'IBI D Q:'IBN + . N Z,Z1 + . ; If a pregnancy DX exists, must be an occurrence code 10 for LMP date + . ; dx ranges are: V22*-V24*, V27*-V28*, 630*-677* + . S IBDX=$S($G(IBFT)'=2:+IBARR(IBI),1:IBI) + . S Z=$E($P($$ICD9^IBACSV(IBDX),U),1,3),Z1=$E(Z,2,3) + . I $S(Z'<630&(Z<678):1,$E(Z)="V":$S(Z1'<22&(Z1<25):1,1:Z1'<27&(Z1<28)),1:0) S IBN=0 ;Pregnancy Dx exists + ; +OCC10Q K ^TMP($J,"LMD") + Q IBN + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB3.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB3.m index 86b9a4c4..e91e321b 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB3.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB3.m @@ -1,207 +1,185 @@ -IBCBB3 ;ALB/TMP - CONTINUATION OF EDIT CHECKS ROUTINE (MEDICARE) ;06/23/98 - ;;2.0;INTEGRATED BILLING;**51,137,155,349,371,377**;21-MAR-94;Build 23 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -EDITMRA(IBQUIT,IBER,IBIFN,IBFT) ; - ; Requires execution of GVAR^IBCBB, IBIFN defined - ; File IB ERROR (350.8) contains error codes/text - ; - N IBMRATYP,Z,IBZP,IBZP1,IBOK - S IBQUIT=0 ;Flag to say we have too many errors - quit edits - ; - S IBMRATYP=$$MRATYPE^IBEFUNC(IBIFN,"C") - ; - I IBFT=3 D - . D PARTA - ; - I IBFT=2 D PARTB^IBCBB9 - ; - K IBXDATA D F^IBCEF("N-ADMITTING DIAGNOSIS",,,IBIFN) - ; Req. for UB-04 type of bills 11x!18x - I $G(IBXDATA)="",IBFT=3 D Q:IBQUIT - . N Z - . I "^11^18^"[(U_IBTOB12_U) S IBQUIT=$$IBER(.IBER,231) Q - . I $$INPAT^IBCEF(IBIFN,1) S Z="Admitting Diagnosis may be required by payer, please verify" D WARN^IBCBB11(Z) - ; - D GETPRV^IBCEU(IBIFN,"2,3,4",.Z) - S IBOK=1,Z=0,IBZP=U F S Z=$O(Z(Z)) Q:'Z S:$S($P($G(Z(Z,1)),U,3)["VA(200":1,1:0) IBZP=IBZP_+$P(Z(Z,1),U,3)_U - D ALLPROC^IBCVA1(IBIFN,.IBZP1) - S Z=0 F S Z=$O(IBZP1(Z)) Q:'Z I $P(IBZP1(Z),U,18),IBZP'[(U_$P(IBZP1(Z),U,18)_U) S IBOK=0 Q - I 'IBOK D WARN^IBCBB11("At least one provider on a procedure does not match your "_$S(IBFT=2:"render",1:"attend")_"ing or operating provider") - I IBFT=2 D EN^IBCBB2 - ; edit checks for UB-04 (institutional) forms - I IBFT=3 D EN^IBCBB21(.IBZPRC92) - ; - Q - ; -PARTA ; MEDICARE specific edit checks for PART A claims (UB-04 formats) - ; - N IBI,IBJ,IBX,IBCTYP,VADM,VAPA,IBSTOP,IBDXC,IBDXARY,IBPR,IBLABS,REQMRA - N IBS,IBTUNIT,IBCAGE,IBREV1,IBOCCS,IBOCSDT,IBVALCD,IBOCCD,IBNOPR - N IBCCARY1,IBPATST,IBZADMIT,IBZDISCH,IBXIEN,IBXERR,IBXDATA,IBOCSP - N IBCOV,IBNCOV,IBREVC,IBREVDUP,IBBCPT,IBREVC12,IBREVTOT,IBECAT,IBINC - ; - ; Medicare is the current payer, but no diagnosis codes - I $$WNRBILL^IBEFUNC(IBIFN) D SET^IBCSC4D(IBIFN,.IBDX,.IBDXO) I '$P(IBDX,U,2) S IBQUIT=$$IBER(.IBER,120) Q:IBQUIT - ; - ; Type of Bill must be three digits - I IBTOB'?3N S X=$$IBER(.IBER,103) Q - ; - ; Covered Days - S IBCTYP=0 - S IBCOV=$P(IBNDU2,U,2),IBNCOV=$P(IBNDU2,U,3) - ; - ; If interim bill, covered days must not be greater than 60 - I "23"[$E(IBTOB,3),IBCOV>60 S IBQUIT=$$IBER(.IBER,"096") Q:IBQUIT - ; - ; I bill type is 11x or 18x or 21x then we need covered days - I "^11^18^21^"[(U_IBTOB12_U) S IBCTYP=1 I IBCOV="" S IBQUIT=$$IBER(.IBER,106) Q:IBQUIT - ; - S (IBI,IBJ)=0 - K IBXDATA D F^IBCEF("N-CONDITION CODES",,,IBIFN) - ; Re-sort the condition codes by code - S IBI=0 F S IBI=$O(IBXDATA(IBI)) Q:'IBI S IBCCARY1($P(IBXDATA(IBI),U))="" - ; - ; for condition code 40, covered days must be 0 - I $D(IBCCARY1(40)),IBCOV'=0 S IBQUIT=$$IBER(.IBER,107) Q:IBQUIT - ; - ; cov days+non=to date -from date unless the patient status = 30 (still - ; pt) or outpatient or if the to date and from date are same then add 1 - S IBPATST="",IBX=$P(IBNDU,U,12),IBPATST=$P($G(^DGCR(399.1,+IBX,0)),U,2) - S IBINC=$S(IBPATST=30!(IBFDT=IBTDT):1,1:0) - I $$INPAT^IBCEF(IBIFN,1),(IBCOV+IBNCOV)'=($$FMDIFF^XLFDT(IBTDT,IBFDT)+IBINC) S IBQUIT=$$IBER(.IBER,108) Q:IBQUIT - ; - ; if covered days >100 and type of bill is 21x or 18x error - I IBCOV>100,(IBTOB12=18!(IBTOB12=21)) S IBQUIT=$$IBER(.IBER,109) Q:IBQUIT - ; - S (IBJ,IBTUNIT,IBS,IBREVTOT("AC"),IBREVTOT("AI"),IBREVTOT("AO"),IBREVTOT)=0 - ; - K IBXDATA D F^IBCEF("N-UB-04 SERVICE LINE (EDI)",,,IBIFN) ;Get rev codes - ; - ; Re-sort the revenue codes by code - ;>> IBREV1(rev code,x)=Rev code^ptr cpt^unit chg^units^total^tot unc - ; IBREV1(rev code) = revenue code edit category - ; - ; IBNOPR = flag that determines if there are revenue codes with - ; charges that do not have a procedure - no need to check - ; for billable MCR procedures if at least one RC is billable - ; 1 = there is at least one billable revenue code without a - ; procedure - ; - S REQMRA=$$REQMRA^IBEFUNC(IBIFN) - S (IBNOPR,IBI)=0 - F S IBI=$O(IBXDATA(IBI)) Q:'IBI D - . I REQMRA D GYMODCHK(IBXDATA(IBI)) ; IB*2*377 GY modifier check - . S IBJ=$P(IBXDATA(IBI),U),IBECAT="" - . I 'IBNOPR D - .. I $P(IBXDATA(IBI),U,2)'="" S IBPR($P(IBXDATA(IBI),U,2))=IBI Q - .. S IBNOPR=1 K IBPR - . S:$D(IBREV1(IBJ)) IBECAT=$G(IBREV1(IBJ)) - . I '$D(IBREV1(IBJ))!(IBECAT="") D S IBREV1(IBJ)=IBECAT - . . ; - . . ; Accomodations (AC) - . . I (IBJ'<100&(IBJ'>219))!(IBJ=224) S IBECAT="AC" Q - . . ; - . . ; Ancillary Outpatient (AO) - . . I '$$INPAT^IBCEF(IBIFN,1) S IBECAT="AO" Q - . . ; - . . ; Ancillary Inpatient (AI) - . . S IBECAT="AI" - . ; - . S IBREV1(IBJ,+$O(IBREV1(IBJ,""),-1)+1)=IBXDATA(IBI) - . S IBREVTOT(IBECAT)=IBREVTOT(IBECAT)+$P(IBXDATA(IBI),U,6) - . I IBECAT="AC" S IBTUNIT=IBTUNIT+$P(IBXDATA(IBI),U,4) - ; - I $$NEEDMRA^IBEFUNC(IBIFN),$O(IBPR(""))'="" D Q:IBQUIT - . ; Don't allow a bill containing only billable procedures for: - . ; Oxygen, labs, or influenza shots - . ; OR a bill with prosthetics on it - . ; to be sent to MEDICARE for an MRA - . D NONMCR(.IBPR,.IBLABS) ; Remove Oxygen, labs, influenza shots - . I $G(IBLABS) D WARN^IBCBB11("The only possible billable procedures on this bill are labs -"),WARN^IBCBB11(" Please verify that MEDICARE does not reimburse these labs at 100%") Q - . I $O(IBPR(""))="" D - .. S IBQUIT=$$IBER(.IBER,"098") - ; - ; covered days+non covered = units of accom rev codes - ; Check room and board - I IBTUNIT,IBTUNIT'=(IBCOV+IBNCOV) S IBQUIT=$$IBER(.IBER,114) Q:IBQUIT - ; - ; Non Covered Days - ; required when the type of bill is 11x,18x,21x or covered days=0 - I IBNCOV="",(IBCTYP!(IBCOV=0)) S IBQUIT=$$IBER(.IBER,115) Q:IBQUIT - ; - ; if cc code=40 then non-covered days must be 1 - I $D(IBCCARY1(40)),IBNCOV'=1 S IBQUIT=$$IBER(.IBER,116) Q:IBQUIT - ; - ; Patient Sex - ; must be "M" or "F" - D DEM^VADPT - I $P(VADM(5),U)'="M",$P(VADM(5),U)'="F" S IBQUIT=$$IBER(.IBER,124) Q:IBQUIT - ; - ; esg - 10/17/07 - patch 371 - ; For Part A replacement MRA request claims, make sure - ; the Medicare ICN/DCN number is present and also text in FL-80. - I $$REQMRA^IBEFUNC(IBIFN),$F(".137.138.117.118.","."_IBTOB_".") D Q:IBQUIT - . N IBZ,FL80TXT - . D F^IBCEF("N-CURR INS FORM LOC 64","IBZ",,IBIFN) ; see CI3-11 - . I IBZ="" S IBQUIT=$$IBER(.IBER,205) Q:IBQUIT ; missing ICN/DCN - . S FL80TXT=$P($G(^DGCR(399,IBIFN,"UF2")),U,3) - . I FL80TXT="" S IBQUIT=$$IBER(.IBER,206) Q:IBQUIT ; missing FL80 text - . Q - ; - D ^IBCBB4 - Q - ; -IBER(IBER,ERRNO) ; Sets error list - ; NOTE: add code to check error list > 20 ... If so, display message and - ; quit so we don't get too many errors at once to handle - ; Print all if printing list - ; - I '$G(IBQUIT) D - . I ERRNO?1N.N S:$L(ERRNO)<3 ERRNO=$E("00",1,3-$L(ERRNO))_ERRNO - . I $L(IBER,";")>19,'$G(IBPRT("PRT")) S IBER=IBER_"IB999;",IBQUIT=1 - . I $G(IBER)'[("IB"_ERRNO_";") S IBER=IBER_"IB"_ERRNO_";" - Q IBQUIT - ; -NONMCR(IBPR,IBLABS) ; Delete all oxygen and lab, flu shot CPT entries from IBPR - ; IBPR = array subscripted by CPT codes from bill - ; IBLABS = flag returned =1 if labs found on bill - N Z S IBLABS=0 - ; Oxygen - F Z="A0422","A4575","A4616","A4619","A4620","A4621","E0455","E1353","E1355" K IBPR(Z) - F Z=77:1:85 S Z0="E13"_Z K IBPR(Z0) - ; Labs - S Z="80000" F S Z=$O(IBPR(Z)) Q:Z'?1"8"4N S IBLABS=1 - ; Flu shots - F Z="90724","G0008","90732","G0009","90657","90658","90659","90660" K IBPR(Z) - Q - ; -MCRANUM(IBIFN) ; Determine MEDICARE A provider ID # from bedsection for - ; bill ien IBIFN - N IBX - ; PART A MRA (only) needed - determine if psych/non-psych claim - N IBX,IBI - S IBI=$P($G(^DGCR(399,IBIFN,"U")),U,11) - S IBX=$S($TR($P($G(^DGCR(399.1,+IBI,0)),U),"psych","PSYCH")'["PSYCH":670899,1:674499) - Q IBX - ; -MCRACK(IBIFN,X,IBFLD) ; Check for MEDICARE A for bill IBIFN - ; Called from CLAIM STATUS MRA field (#24) xrefs in file 399 - ; X = current value of field 399;24 - ; IBFLD = 1 for primary ins co, 2 for secondary, 3 for tertiary - N IB - S IB=0 - I +X,$$COBN^IBCEF(IBIFN)=IBFLD,$$WNRBILL^IBEFUNC(IBIFN,IBFLD),$$MRATYPE^IBEFUNC(IBIFN,"C")="A" S IB=1 - Q IB - ; -GYMODCHK(Z) ; GY modifier check procedure. IB*2*377 - 2/4/08 - ; Z is the IBXDATA(IBI) service line EDI - N MODS - I IBER["IB123" Q ; error already found - S MODS=$P(Z,U,9) ; list of modifiers separated by commas - I MODS'["GY" Q ; GY modifier not here on this line item - I $P(Z,U,6) Q ; non-covered charges exist on this line item - S IBQUIT=$$IBER(.IBER,123) -GYMODX ; - Q - ; +IBCBB3 ;ALB/TMP - CONTINUATION OF EDIT CHECKS ROUTINE (MEDICARE) ;06/23/98 + ;;2.0;INTEGRATED BILLING;**51,137,155,349**;21-MAR-94;Build 46 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; +EDITMRA(IBQUIT,IBER,IBIFN,IBFT) ; + ; Requires execution of GVAR^IBCBB, IBIFN defined + ; File IB ERROR (350.8) contains error codes/text + ; + N IBMRATYP,Z,IBZP,IBZP1,IBOK + S IBQUIT=0 ;Flag to say we have too many errors - quit edits + ; + S IBMRATYP=$$MRATYPE^IBEFUNC(IBIFN,"C") + ; + I IBFT=3 D + . D PARTA + ; + I IBFT=2 D PARTB^IBCBB9 + ; + K IBXDATA D F^IBCEF("N-ADMITTING DIAGNOSIS",,,IBIFN) + ; Req. for UB-04 type of bills 11x!18x + I $G(IBXDATA)="",IBFT=3 D Q:IBQUIT + . N Z + . I "^11^18^"[(U_IBTOB12_U) S IBQUIT=$$IBER^IBCBB3(.IBER,231) Q + . I $$INPAT^IBCEF(IBIFN,1) S Z="Admitting Diagnosis may be required by payer, please verify" D WARN^IBCBB11(Z) + ; + D GETPRV^IBCEU(IBIFN,"2,3,4",.Z) + S IBOK=1,Z=0,IBZP=U F S Z=$O(Z(Z)) Q:'Z S:$S($P($G(Z(Z,1)),U,3)["VA(200":1,1:0) IBZP=IBZP_+$P(Z(Z,1),U,3)_U + D ALLPROC^IBCVA1(IBIFN,.IBZP1) + S Z=0 F S Z=$O(IBZP1(Z)) Q:'Z I $P(IBZP1(Z),U,18),(U_$P(IBZP1(Z),U,18)_U)'[IBZP S IBOK=0 Q + I 'IBOK D WARN^IBCBB11("At least one provider on a procedure does not match your "_$S(IBFT=2:"render",1:"attend")_"ing or operating provider") + I IBFT=2 D EN^IBCBB2 + ; edit checks for UB-04 (institutional) forms + I IBFT=3 D EN^IBCBB21(.IBZPRC92) + ; + Q + ; +PARTA ; MEDICARE specific edit checks for PART A claims (UB-04 formats) + ; + N IBI,IBJ,IBX,IBCTYP,VADM,VAPA,IBSTOP,IBDXC,IBDXARY,IBPR,IBLABS + N IBS,IBTUNIT,IBCAGE,IBREV1,IBOCCS,IBOCSDT,IBVALCD,IBOCCD,IBNOPR + N IBCCARY1,IBPATST,IBZADMIT,IBZDISCH,IBXIEN,IBXERR,IBXDATA,IBOCSP + N IBCOV,IBNCOV,IBREVC,IBREVDUP,IBBCPT,IBREVC12,IBREVTOT,IBECAT,IBINC + ; + ; Medicare is the current payer, but no diagnosis codes + I $$WNRBILL^IBEFUNC(IBIFN) D SET^IBCSC4D(IBIFN,.IBDX,.IBDXO) I '$P(IBDX,U,2) S IBQUIT=$$IBER(.IBER,120) Q:IBQUIT + ; + ; Type of Bill must be three digits + I IBTOB'?3N S X=$$IBER(.IBER,103) Q + ; + ; Covered Days + S IBCTYP=0 + S IBCOV=$P(IBNDU2,U,2),IBNCOV=$P(IBNDU2,U,3) + ; + ; If interim bill, covered days must not be greater than 60 + I "23"[$E(IBTOB,3),IBCOV>60 S IBQUIT=$$IBER(.IBER,"096") Q:IBQUIT + ; + ; I bill type is 11x or 18x or 21x then we need covered days + I "^11^18^21^"[(U_IBTOB12_U) S IBCTYP=1 I IBCOV="" S IBQUIT=$$IBER(.IBER,106) Q:IBQUIT + ; + S (IBI,IBJ)=0 + K IBXDATA D F^IBCEF("N-CONDITION CODES",,,IBIFN) + ; Re-sort the condition codes by code + S IBI=0 F S IBI=$O(IBXDATA(IBI)) Q:'IBI S IBCCARY1($P(IBXDATA(IBI),U))="" + ; + ; for condition code 40, covered days must be 0 + I $D(IBCCARY1(40)),IBCOV'=0 S IBQUIT=$$IBER(.IBER,107) Q:IBQUIT + ; + ; cov days+non=to date -from date unless the patient status = 30 (still + ; pt) or outpatient or if the to date and from date are same then add 1 + S IBPATST="",IBX=$P(IBNDU,U,12),IBPATST=$P($G(^DGCR(399.1,+IBX,0)),U,2) + S IBINC=$S(IBPATST=30!(IBFDT=IBTDT):1,1:0) + I $$INPAT^IBCEF(IBIFN,1),(IBCOV+IBNCOV)'=($$FMDIFF^XLFDT(IBTDT,IBFDT)+IBINC) S IBQUIT=$$IBER(.IBER,108) Q:IBQUIT + ; + ; if covered days >100 and type of bill is 21x or 18x error + I IBCOV>100,(IBTOB12=18!(IBTOB12=21)) S IBQUIT=$$IBER(.IBER,109) Q:IBQUIT + ; + S (IBJ,IBTUNIT,IBS,IBREVTOT("AC"),IBREVTOT("AI"),IBREVTOT("AO"),IBREVTOT)=0 + ; + K IBXDATA D F^IBCEF("N-UB-04 SERVICE LINE (EDI)",,,IBIFN) ;Get rev codes + ; + ; Re-sort the revenue codes by code + ;>> IBREV1(rev code,x)=Rev code^ptr cpt^unit chg^units^total^tot unc + ; IBREV1(rev code) = revenue code edit category + ; + ; IBNOPR = flag that determines if there are revenue codes with + ; charges that do not have a procedure - no need to check + ; for billable MCR procedures if at least one RC is billable + ; 1 = there is at least one billable revenue code without a + ; procedure + ; + S (IBNOPR,IBI)=0 + F S IBI=$O(IBXDATA(IBI)) Q:'IBI D + . S IBJ=$P(IBXDATA(IBI),U),IBECAT="" + . I 'IBNOPR D + .. I $P(IBXDATA(IBI),U,2)'="" S IBPR($P(IBXDATA(IBI),U,2))=IBI Q + .. S IBNOPR=1 K IBPR + . S:$D(IBREV1(IBJ)) IBECAT=$G(IBREV1(IBJ)) + . I '$D(IBREV1(IBJ))!(IBECAT="") D S IBREV1(IBJ)=IBECAT + . . ; + . . ; Accomodations (AC) + . . I (IBJ'<100&(IBJ'>219))!(IBJ=224) S IBECAT="AC" Q + . . ; + . . ; Ancillary Outpatient (AO) + . . I '$$INPAT^IBCEF(IBIFN,1) S IBECAT="AO" Q + . . ; + . . ; Ancillary Inpatient (AI) + . . S IBECAT="AI" + . ; + . S IBREV1(IBJ,+$O(IBREV1(IBJ,""),-1)+1)=IBXDATA(IBI) + . S IBREVTOT(IBECAT)=IBREVTOT(IBECAT)+$P(IBXDATA(IBI),U,6) + . I IBECAT="AC" S IBTUNIT=IBTUNIT+$P(IBXDATA(IBI),U,4) + ; + I $$NEEDMRA^IBEFUNC(IBIFN),$O(IBPR(""))'="" D Q:IBQUIT + . ; Don't allow a bill containing only billable procedures for: + . ; Oxygen, labs, or influenza shots + . ; OR a bill with prosthetics on it + . ; to be sent to MEDICARE for an MRA + . D NONMCR(.IBPR,.IBLABS) ; Remove Oxygen, labs, influenza shots + . ;I $O(IBPR(""))="" D + . I $G(IBLABS) D WARN^IBCBB11("The only possible billable procedures on this bill are labs -"),WARN^IBCBB11(" Please verify that MEDICARE does not reimburse these labs at 100%") Q + . I $O(IBPR(""))="" D + .. S IBQUIT=$$IBER(.IBER,"098") + ; + ; covered days+non covered = units of accom rev codes + ; Check room and board + I IBTUNIT,IBTUNIT'=(IBCOV+IBNCOV) S IBQUIT=$$IBER(.IBER,114) Q:IBQUIT + ; + ; Non Covered Days + ; required when the type of bill is 11x,18x,21x or covered days=0 + I IBNCOV="",(IBCTYP!(IBCOV=0)) S IBQUIT=$$IBER(.IBER,115) Q:IBQUIT + ; + ; if cc code=40 then non-covered days must be 1 + I $D(IBCCARY1(40)),IBNCOV'=1 S IBQUIT=$$IBER(.IBER,116) Q:IBQUIT + ; + ; Patient Sex + ; must be "M" or "F" + D DEM^VADPT + I $P(VADM(5),U)'="M",$P(VADM(5),U)'="F" S IBQUIT=$$IBER(.IBER,124) Q:IBQUIT + ; + D ^IBCBB4 + Q + ; +IBER(IBER,ERRNO) ; Sets error list + ; NOTE: add code to check error list > 20 ... If so, display message and + ; quit so we don't get too many errors at once to handle + ; Print all if printing list + ; + I '$G(IBQUIT) D + . I ERRNO?1N.N S:$L(ERRNO)<3 ERRNO=$E("00",1,3-$L(ERRNO))_ERRNO + . I $L(IBER,";")>19,'$G(IBPRT("PRT")) S IBER=IBER_"IB999;",IBQUIT=1 + . I $G(IBER)'[("IB"_ERRNO_";") S IBER=IBER_"IB"_ERRNO_";" + Q IBQUIT + ; +NONMCR(IBPR,IBLABS) ; Delete all oxygen and lab, flu shot CPT entries from IBPR + ; IBPR = array subscripted by CPT codes from bill + ; IBLABS = flag returned =1 if labs found on bill + N Z S IBLABS=0 + ; Oxygen + F Z="A0422","A4575","A4616","A4619","A4620","A4621","E0455","E1353","E1355" K IBPR(Z) + F Z=77:1:85 S Z0="E13"_Z K IBPR(Z0) + ; Labs + ;S Z="80000" F S Z=$O(IBPR(Z)) Q:Z'?1"8"4N K IBPR(Z) S IBLABS=1 + S Z="80000" F S Z=$O(IBPR(Z)) Q:Z'?1"8"4N S IBLABS=1 + ; Flu shots + F Z="90724","G0008","90732","G0009","90657","90658","90659","90660" K IBPR(Z) + Q + ; +MCRANUM(IBIFN) ; Determine MEDICARE A provider ID # from bedsection for + ; bill ien IBIFN + N IBX + ; PART A MRA (only) needed - determine if psych/non-psych claim + N IBX,IBI + S IBI=$P($G(^DGCR(399,IBIFN,"U")),U,11) + S IBX=$S($TR($P($G(^DGCR(399.1,+IBI,0)),U),"psych","PSYCH")'["PSYCH":670899,1:674499) + Q IBX + ; +MCRACK(IBIFN,X,IBFLD) ; Check for MEDICARE A for bill IBIFN + ; Called from CLAIM STATUS MRA field (#24) xrefs in file 399 + ; X = current value of field 399;24 + ; IBFLD = 1 for primary ins co, 2 for secondary, 3 for tertiary + N IB + S IB=0 + I +X,$$COBN^IBCEF(IBIFN)=IBFLD,$$WNRBILL^IBEFUNC(IBIFN,IBFLD),$$MRATYPE^IBEFUNC(IBIFN,"C")="A" S IB=1 + Q IB + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB5.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB5.m index c5d8ddad..ff6debe4 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB5.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB5.m @@ -1,56 +1,55 @@ -IBCBB5 ;ALB/BGA - CONT OF MEDICARE EDIT CHECKS ;08/12/98 - ;;2.0;INTEGRATED BILLING;**51,137,371**;21-MAR-94;Build 57 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - D F^IBCEF("N-ADMISSION DATE","IBZADMIT",,IBIFN) - D F^IBCEF("N-DISCHARGE DATE","IBZDISCH",,IBIFN) - ; - ; Occurrence Code and Dates - ; occ codes can not be duplicates for same dates and must have a date - K IBXSAVE,IBXDATA D F^IBCEF("N-OCCURRENCE CODES",,,IBIFN) - ; Returns arrays IBXSAVE("OCC",n) AND IBXSAVE("OCCS",n) = - ; code^start date^state^end date - ; IBOCS=occ codes ;; IBOCSP=occ span codes - ; - S IBI=0 F S IBI=$O(IBXSAVE("OCCS",IBI)) Q:'IBI D - . N IBOCSDT,IBOCSDT1,Z - . S IBOCSDT=$P(IBXSAVE("OCCS",IBI),U,2),IBOCSDT1=$P(IBXSAVE("OCCS",IBI),U,3),IBOCCS=$P(IBXSAVE("OCCS",IBI),U) - . S IBOCSP(IBOCCS,$O(IBOCSP(IBOCCS,""),-1)+1)=IBXSAVE("OCCS",IBI) - . ; Occurrence Code End dates must be > start date and are required for OCCURANCE SPANS - . I 'IBOCSDT1 S IBER=IBER_"IB155;" Q - . I IBOCSDT10 - . I $P(IBXDATA(IBX),U)="01",IBER'["134;",$P(IBXDATA(IBX),U,2)'>0 S IBQUIT=$$IBER^IBCBB3(.IBER,134) Q - . ; value code 02 must have a value=0 - . I $P(IBXDATA(IBX),U)="02",IBER'["135;",+$P(IBXDATA(IBX),U,2)'=0 S IBQUIT=$$IBER^IBCBB3(.IBER,135) Q - . ; code^amount^dollar amt flag (1=amt,0=quantity) - . I $P(IBXDATA(IBX),U,2)="",IBER'["157;" S IBQUIT=$$IBER^IBCBB3(.IBER,157) Q - . I '$$CHK^IBCVC($P(IBXDATA(IBX),U,4),$P(IBXDATA(IBX),U,2)),IBER'["158;" S IBQUIT=$$IBER^IBCBB3(.IBER,158) Q - ; - Q:IBQUIT - ; Must have acc hr if accident is indicated on inpatient bill - I $$INPAT^IBCEF(IBIFN,1) D - . I $D(IBOCCD("01"))!$D(IBOCCD("02"))!$D(IBOCCD("03"))!$D(IBOCCD("04"))!$D(IBOCCD("05")) D - .. I '$D(IBVALCD(45)),'$P($G(^DGCR(399,IBIFN,"U")),U,10) S IBQUIT=$$IBER^IBCBB3(.IBER,156) - Q:IBQUIT - ; - D ^IBCBB6 - Q +IBCBB5 ;ALB/BGA - CONT OF MEDICARE EDIT CHECKS ;08/12/98 + ;;2.0;INTEGRATED BILLING;**51,137**;21-MAR-94 + ;;Per VHA Directive 10-93-142, this routine should not be modified + ; + D F^IBCEF("N-ADMISSION DATE","IBZADMIT",,IBIFN) + D F^IBCEF("N-DISCHARGE DATE","IBZDISCH",,IBIFN) + ; + ; Occurrence Code and Dates + ; occ codes can not be duplicates for same dates and must have a date + K IBXSAVE,IBXDATA D F^IBCEF("N-OCCURRENCE CODES",,,IBIFN) + ; Returns arrays IBXSAVE("OCC",n) AND IBXSAVE("OCCS",n) = + ; code^start date^state^end date + ; IBOCS=occ codes ;; IBOCSP=occ span codes + ; + S IBI=0 F S IBI=$O(IBXSAVE("OCCS",IBI)) Q:'IBI D + . N IBOCSDT,IBOCSDT1,Z + . S IBOCSDT=$P(IBXSAVE("OCCS",IBI),U,2),IBOCSDT1=$P(IBXSAVE("OCCS",IBI),U,4),IBOCCS=$P(IBXSAVE("OCCS",IBI),U) + . S IBOCSP(IBOCCS,$O(IBOCSP(IBOCCS,""),-1)+1)=IBXSAVE("OCCS",IBI) + ; + S IBI=0 F S IBI=$O(IBXSAVE("OCC",IBI)) Q:'IBI D + . N Z + . S IBOCCD=$P(IBXSAVE("OCC",IBI),U) + . S IBOCCD(IBOCCD,$O(IBOCCD(IBOCCD,""),-1)+1)=IBXSAVE("OCC",IBI) + . I IBOCCD=10 S ^TMP($J,"LMD")=1 + Q:IBQUIT + ; + ; For type of admit = 1 or 2, at least one occ code 1-6, 10, or 11 req + I $P(IBNDU,U,8)=1!($P(IBNDU,U,8)=2) D + . N OK + . S OK=0 + . F Z="01","02","03","04","05","06",10,11 I $D(IBOCCD(Z))!($D(IBOCCD(+Z))) S OK=1 Q + . I 'OK S IBQUIT=$$IBER^IBCBB3(.IBER,133) + K IBXDATA D F^IBCEF("N-VALUE CODES",,,IBIFN) + S IBX=0 + F S IBX=$O(IBXDATA(IBX)) Q:'IBX D Q:IBQUIT + . ; value code 01 must have a value>0 + . I $P(IBXDATA(IBX),U)="01",IBER'["134;",$P(IBXDATA(IBX),U,2)'>0 S IBQUIT=$$IBER^IBCBB3(.IBER,134) + . Q:IBQUIT + . ; value code 02 must have a value=0 + . I $P(IBXDATA(IBX),U)="02",IBER'["135;",+$P(IBXDATA(IBX),U,2)'=0 S IBQUIT=$$IBER^IBCBB3(.IBER,135) + . ; code^amount^dollar amt flag (1=amt,0=quantity) + . Q:IBQUIT + . I '$D(IBVALCD($P(IBXDATA(IBX),U))) S IBVALCD($P(IBXDATA(IBX),U))=$P(IBXDATA(IBX),U,2) Q + ; Must have value code 01 or 02 for TOB 11X, 18X, 21X - default it + ;I '$D(IBVALCD("01")),'$D(IBVALCD("02")),$S(IBTOB12="11":1,IBTOB12="18":1,1:IBTOB12="21") S IBQUIT=$$IBER^IBCBB3(.IBER,132) + ; + Q:IBQUIT + ; Must have acc hr if accident is indicated on inpatient bill + I $$INPAT^IBCEF(IBIFN,1) D + . I $D(IBOCCD("01"))!$D(IBOCCD("02"))!$D(IBOCCD("03"))!$D(IBOCCD("04"))!$D(IBOCCD("05")) D + .. I '$D(IBVALCD(45)),'$P($G(^DGCR(399,IBIFN,"U")),U,10) S IBQUIT=$$IBER^IBCBB3(.IBER,156) + Q:IBQUIT + ; + D ^IBCBB6 + Q diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB9.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB9.m index d8b7ad99..309f2b54 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB9.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB9.m @@ -1,36 +1,43 @@ -IBCBB9 ;ALB/BGA MEDICARE PART B EDIT CHECKS ;10/15/98 - ;;2.0;INTEGRATED BILLING;**51,137,155,349,371**;21-MAR-94;Build 57 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -PARTB ; MEDICARE specific edit checks for PART B claims (CMS-1500) - ; - N IBXDATA,IBXERR,IBXIEN,IBXSAVE,IBPR,IBDTFLG - ; - I $$NEEDMRA^IBEFUNC(IBIFN) D - . K IBXDATA - . D F^IBCEF("N-HCFA 1500 SERVICE LINE (EDI)",,,IBIFN) - . S IBI=0 - . F S IBI=$O(IBXDATA(IBI)) Q:'IBI D - .. S IBJ=$P(IBXDATA(IBI),U,5) - .. I IBJ'="","^CJ^HC^"[(U_$P(IBXDATA(IBI),U,6)_U) S IBPR(IBJ)="" - . I $$REQMRA^IBEFUNC(IBIFN),$O(IBXDATA(""),-1)>12 D WARN^IBCBB11("This claim will be split into multiple EOB'S since there are more than 12"),WARN^IBCBB11("service lines being submitted on the claim.") - . I $$REQMRA^IBEFUNC(IBIFN),$E(IBFDT,1,3)'=$E(IBTDT,1,3) D WARN^IBCBB11("This claim will be split into multiple EOB'S due to the service dates"),WARN^IBCBB11("spanning different calendar years.") - . D NONMCR^IBCBB3(.IBPR,.IBLABS) ; Oxygen, labs, influenza shots - . S Z="80000" F S Z=$O(IBPR(Z)) Q:Z'?1"8"4N S IBLABS=1 - . I $G(IBLABS) D WARN^IBCBB11("The only possible billable procedures on this bill are labs -"),WARN^IBCBB11(" Please verify that MEDICARE does not reimburse these labs at 100%") Q - . I $O(IBPR(""))="" S IBQUIT=$$IBER^IBCBB3(.IBER,"098") - ; - ; First char of the pat's first and last name must be present and - ; must be an alpha - K IBXDATA D F^IBCEF("N-PATIENT NAME",,,IBIFN) - S IBXDATA=$$NAME^IBCEFG1(IBXDATA) - I $S($G(IBXDATA)="":1,$E($P(IBXDATA,U))=" "!($E($P(IBXDATA,U))'?1A):1,$E($P(IBXDATA,U,2))=" "!($E($P(IBXDATA,U,2))'?1A):1,1:0) S IBQUIT=$$IBER^IBCBB3(.IBER,300) Q:IBQUIT - ; - ; Must be a valid HIC # - I '$$VALID^IBCBB8(IBIFN) S IBQUIT=$$IBER^IBCBB3(.IBER,215) Q:IBQUIT - ; - ; Specialty code 99 is not valid for Medicare MRA request claims - I $$REQMRA^IBEFUNC(IBIFN),$$BILLSPEC^IBCEU3(IBIFN)=99 S IBQUIT=$$IBER^IBCBB3(.IBER,122) Q:IBQUIT - ; - Q - ; +IBCBB9 ;ALB/BGA MEDICARE PART B EDIT CHECKS ;10/15/98 + ;;2.0;INTEGRATED BILLING;**51,137,155,349**;21-MAR-94;Build 46 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; +PARTB ; MEDICARE specific edit checks for PART B claims (CMS-1500) + ; + N IBXDATA,IBXERR,IBXIEN,IBXSAVE,IBPR,IBDTFLG + ; + I $$NEEDMRA^IBEFUNC(IBIFN) D + . K IBXDATA + . D F^IBCEF("N-HCFA 1500 SERVICE LINE (EDI)",,,IBIFN) + . S IBI=0 + . F S IBI=$O(IBXDATA(IBI)) Q:'IBI D + .. S IBJ=$P(IBXDATA(IBI),U,5) + .. I IBJ'="","^CJ^HC^"[(U_$P(IBXDATA(IBI),U,6)_U) S IBPR(IBJ)="" + . I $$REQMRA^IBEFUNC(IBIFN),$O(IBXDATA(""),-1)>12 D WARN^IBCBB11("This claim will be split into multiple EOB'S since there are more than 12"),WARN^IBCBB11("service lines being submitted on the claim.") + . I $$REQMRA^IBEFUNC(IBIFN),$E(IBFDT,1,3)'=$E(IBTDT,1,3) D WARN^IBCBB11("This claim will be split into multiple EOB'S due to the service dates"),WARN^IBCBB11("spanning different calendar years.") + . D NONMCR^IBCBB3(.IBPR,.IBLABS) ; Oxygen, labs, influenza shots + . S Z="80000" F S Z=$O(IBPR(Z)) Q:Z'?1"8"4N S IBLABS=1 + . I $G(IBLABS) D WARN^IBCBB11("The only possible billable procedures on this bill are labs -"),WARN^IBCBB11(" Please verify that MEDICARE does not reimburse these labs at 100%") Q + . I $O(IBPR(""))="" S IBQUIT=$$IBER^IBCBB3(.IBER,"098") + ; + ; First char of the pat's first and last name must be present and + ; must be an alpha + K IBXDATA D F^IBCEF("N-PATIENT NAME",,,IBIFN) + S IBXDATA=$$NAME^IBCEFG1(IBXDATA) + I $S($G(IBXDATA)="":1,$E($P(IBXDATA,U))=" "!($E($P(IBXDATA,U))'?1A):1,$E($P(IBXDATA,U,2))=" "!($E($P(IBXDATA,U,2))'?1A):1,1:0) S IBQUIT=$$IBER^IBCBB3(.IBER,300) Q:IBQUIT + ; + ; First char of the pat's address and city must not be a space + K IBXDATA D F^IBCEF("N-PATIENT STREET ADDRESS LN 1",,,IBIFN) + I $G(IBXDATA)=""!($E($G(IBXDATA))=" ") S IBQUIT=$$IBER^IBCBB3(.IBER,302) Q:IBQUIT + ; + K IBXDATA D F^IBCEF("N-PATIENT CITY",,,IBIFN) + I $G(IBXDATA)=""!($E($G(IBXDATA))=" ") S IBQUIT=$$IBER^IBCBB3(.IBER,302) Q:IBQUIT + ; + ; Must be a valid HIC # + I '$$VALID^IBCBB8(IBIFN) S IBQUIT=$$IBER^IBCBB3(.IBER,215) Q:IBQUIT + ; + ; Specialty code 99 is not valid for Medicare MRA request claims + I $$REQMRA^IBEFUNC(IBIFN),$$BILLSPEC^IBCEU3(IBIFN)=99 S IBQUIT=$$IBER^IBCBB3(.IBER,122) Q:IBQUIT + ; + Q + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCC1.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCC1.m index 894a3142..9fd9d8f6 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCC1.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCC1.m @@ -1,141 +1,64 @@ -IBCC1 ;ALB/MJB - CANCEL THIRD PARTY BILL ;10-OCT-94 - ;;2.0;INTEGRATED BILLING;**19,95,160,159,320,347,377**;21-MAR-94;Build 23 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -RNB ; -- Add a reason not billable to claims tracking - N X,Y,DIC,DIE,I,J,DA,DR,IBTYP,IBTRE,IB,IBAPPT,IBDT,IBTALK,IBCODE,IBTRED,IBTSAV,FILL,IBRX,IBDATA,IBD,IBDT,IBQUIT,IBPRO,IBDD - N ZT,TCNT,CNT - Q:'$G(IBIFN) - S IB(0)=$G(^DGCR(399,IBIFN,0)),IBTYP=$P(IB(0),"^",5),IBQUIT=0 - I '$D(DFN) S DFN=$P(IB(0),"^",2) - KILL ^TMP($J,"IBCC1") - ; - ; -- is inpt find entry in dgpm, then in ibt(356, s da=ibtre then edit -INPT I IBTYP<3 D - .S DATE=$P(IB(0),"^",3),DFN=$P(IB(0),"^",2) - .S DGPM=$O(^DGPM("APTT1",DFN,DATE,0)) ; double check for asih - .I DGPM S (IBTRE,IBTSAV)=$O(^IBT(356,"AD",DGPM,0)) - .I $G(IBTRE) D CTSET(IBTRE) - .Q:IBQUIT - .; - .; -- alternate inpt method - .S IBCODE=$O(^IBE(356.6,"ACODE",1,0)) - .S DATE=$P(IB(0),"^",3),DFN=$P(IB(0),"^",2) - .S IBDT=(DATE-.25) F S IBDT=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT)) Q:'IBDT!(IBDT>(DATE+.24)) D - ..S IBTRE=0 F S IBTRE=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT,IBTRE)) Q:IBTRE=""!(IBQUIT) D:$G(IBTSAV)'=IBTRE CTSET(IBTRE) - .Q - ; -OPT ; -- is opt-find entries in IBT(356, for opt dates and then edit - I IBTYP>2 S IBCODE=$O(^IBE(356.6,"ACODE",2,0)) D - .S IBAPPT=0 F S IBAPPT=$O(^DGCR(399,IBIFN,"OP",IBAPPT)) Q:'IBAPPT!(IBQUIT) D - ..S IBDT=(IBAPPT-.01) F S IBDT=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT)) Q:'IBDT!(IBDT>(IBAPPT+.24)) D - ...S IBTRE=0 F S IBTRE=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT,IBTRE)) Q:IBTRE=""!(IBQUIT) D CTSET(IBTRE) - .Q - ; -RX ; -- find rx's on bill - S IBDD=0 F S IBDD=$O(^IBA(362.4,"AIFN"_IBIFN,IBDD)) Q:'IBDD S IBD=0 F S IBD=$O(^IBA(362.4,"AIFN"_IBIFN,IBDD,IBD)) Q:'IBD!(IBQUIT) D - .S IBDATA=$G(^IBA(362.4,IBD,0)),IBRX=$P(IBDATA,"^",5),IBDT=$P(IBDATA,"^",3) - .I '$G(IBRX) S DIC=52,DIC(0)="BO",X=$P(IBDATA,"^",1) D DIC^PSODI(52,.DIC,X) S IBRX=+Y K DIC,X,Y Q:IBRX=-1 - .S FILL="" F S FILL=$O(^IBT(356,"ARXFL",IBRX,FILL)) Q:FILL=""!(IBQUIT) D - ..S IBTRE=0 F S IBTRE=$O(^IBT(356,"ARXFL",IBRX,FILL,IBTRE)) Q:'IBTRE!(IBQUIT) I $P(^IBT(356,+IBTRE,0),"^",6)=IBDT D CTSET(IBTRE) - ; -PRO ; -- find prosthetics on bill - S IBDD=0 F S IBDD=$O(^IBA(362.5,"AIFN"_IBIFN,IBDD)) Q:'IBDD S IBD=0 F S IBD=$O(^IBA(362.5,"AIFN"_IBIFN,IBDD,IBD)) Q:'IBD!(IBQUIT) D - .S IBDATA=$G(^IBA(362.5,IBD,0)),IBPRO=$P(IBDATA,"^",4) - .Q:'$G(IBPRO) - .S IBTRE=0 F S IBTRE=$O(^IBT(356,"APRO",+IBPRO,IBTRE)) Q:'IBTRE!(IBQUIT) D CTSET(IBTRE) - ; - ; ----- Finished with the gathering of the CT data entries ----- - ; - ; count up the total number of CT entries recorded in the scratch global - S ZT="",TCNT=0 - F S ZT=$O(^TMP($J,"IBCC1",ZT)) Q:ZT="" S IBTRE=0 F S IBTRE=$O(^TMP($J,"IBCC1",ZT,IBTRE)) Q:'IBTRE S TCNT=TCNT+1 - ; - ; loop thru all of the associated CT entries and call the RNBEDIT procedure for each one - S ZT="",CNT=0 - F S ZT=$O(^TMP($J,"IBCC1",ZT)) Q:ZT=""!IBQUIT D Q:IBQUIT - . S IBTRE=0 F S IBTRE=$O(^TMP($J,"IBCC1",ZT,IBTRE)) Q:'IBTRE!IBQUIT S CNT=CNT+1 D RNBEDIT(IBTRE,ZT,TCNT,CNT) - . Q - ; - ; clean-up the scratch global when completed - KILL ^TMP($J,"IBCC1") - Q - ; -CTSET(IBTRE) ; procedure to store this CT entry in the scratch global - Q:'$G(IBTRE) - S ^TMP($J,"IBCC1",$$TYPE(IBTRE),IBTRE)="" -CTSETX ; - Q - ; -RNBEDIT(IBTRE,CTTYPE,TCNT,CNT) ; CT entry display and capture RNB data and additional comment data - Q:IBQUIT - I '$D(IBTALK) D - . N CTZ - . W !!,"Since you have canceled this bill, you may enter a Reason Not Billable and" - . W !,"an Additional Comment into Claims Tracking." - . W !,"This will take the care off of the UNBILLED lists." - . I TCNT=1 S CTZ="Note: There is 1 associated Claims Tracking entry." - . E S CTZ="Note: There are "_TCNT_" associated Claims Tracking entries." - . W !!,CTZ - . Q - ; - S IBTALK=1 - ; - N %,IBTRED,IBTRED1 S IBTRED=$G(^IBT(356,IBTRE,0)),IBTRED1=$G(^IBT(356,IBTRE,1)) - ; - W !!,"Claims Tracking Entry [",CNT," of ",TCNT,"]" - W !?7,"Entry ID#: ",+IBTRED - W !?12,"Type: ",$$EXPAND^IBTRE(356,.18,$P(IBTRED,U,18)) - ; - I CTTYPE=1 D ; inpatient admission or scheduled admission - . W !?2,"Admission Date: ",$$FMTE^XLFDT($P(IBTRED,U,6),"1P") - . Q - ; - I CTTYPE=2 D ; outpatient visit - . N IBOE,IBOE0 - . W !?6,"Visit Date: ",$$FMTE^XLFDT($P(IBTRED,U,6),"1P") - . S IBOE=+$P(IBTRED,U,4),IBOE0=$$SCE^IBSDU(IBOE) - . W !?10,"Clinic: ",$$GET1^DIQ(44,+$P(IBOE0,U,4)_",",.01) - . Q - ; - I CTTYPE=3 D ; prescription refill - . N PSONTALK,PSOTMP,X - . S PSONTALK=1 - . S X=+$P(IBTRED,U,8)_U_+$P(IBTRED,U,10) D EN^PSOCPVW - . ;if refill was deleted and EN^PSOCPVW doesn't return any data use IB API - . I '$D(PSOTMP) D PSOCPVW^IBNCPDPC(+$P(IBTRED,U,2),+$P(IBTRED,U,8),.PSOTMP) - . W !?3,"Prescription#: ",$G(PSOTMP(52,+$P(IBTRED,U,8),.01,"E")) - . I '$P(IBTRED,U,10) W !?7,"Fill Date: ",$$FMTE^XLFDT($P(IBTRED,U,6),"1P") - . I $P(IBTRED,U,10) W !?5,"Refill Date: ",$$FMTE^XLFDT($P(IBTRED,U,6),"1P") - . W !?12,"Drug: ",$G(PSOTMP(52,+$P(IBTRED,U,8),6,"E")) - . Q - ; - I CTTYPE=4 D ; prosthetic item - . N IBDA,IBRMPR - . S IBDA=$P(IBTRED,U,9) - . D PRODATA^IBTUTL1(IBDA) - . W !?3,"Delivery Date: ",$$FMTE^XLFDT($P(IBTRED,U,6),"1P") - . W !?12,"Item: ",$G(IBRMPR(660,+IBDA,4,"E")) - . W !?5,"Description: ",$G(IBRMPR(660,+IBDA,24,"E")) - . Q - ; - I $G(IBMCSRNB)'="",$P(IBTRED,U,19) W !," Note: A Reason Not Billable has been previously entered",!?8,"for this Claims Tracking record." - I $G(IBMCSCAC)'="",$P(IBTRED1,U,8)'="" W !," Note: An Additional Comment has been previously entered",!?8,"for this Claims Tracking record." - ; - S DA=IBTRE,DIE="^IBT(356,",DR=".19" - I $G(IBMCSRNB)'="" S DR=".19//"_$P(IBMCSRNB,U,2) ; IB*320 MCS cancel - reason not billable - I $G(IBMCSCAC)'="" S DR=DR_";1.08//^S X=IBMCSCAC" ; IB*377 MCS cancel - additional comment - I $G(IBMCSCAC)="" S DR=DR_";1.08" ; IB*377 additional comment field SRS 3.3.2.1 - D ^DIE - ; - ; - if the RNB or additional comment changed, update the user and date/time last edited - I $P(IBTRED,U,19)'=$P($G(^IBT(356,IBTRE,0)),U,19)!($P(IBTRED1,U,8)'=$P($G(^IBT(356,IBTRE,1)),U,8)) D NOW^%DTC S DR="1.03///"_%_";1.04////"_DUZ D ^DIE - ; - ; $D(Y) indicates an up-arrow exit from the DIE call (??) - I $D(Y) S DFN=+$P(^IBT(356,IBTRE,0),"^",2) D FIND^IBOHCT(DFN,IBTRE) S IBQUIT=1 - Q - ; -TYPE(Z) ; function to get the type of claims tracking entry - ; Z is the ien to file 356 - Q +$P($G(^IBE(356.6,+$P($G(^IBT(356,+Z,0)),U,18),0)),U,3) - ; +IBCC1 ;ALB/MJB - CANCEL UB-82 THIRD PARTY BILL ;10-OCT-94 + ;;2.0;INTEGRATED BILLING;**19,95,160,159,320,347**;21-MAR-94;Build 24 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; +RNB ; -- Add a reason not billable to claims tracking + N X,Y,DIC,DIE,I,J,DA,DR,IBTYP,IBTRE,IB,IBAPPT,IBDT,IBTALK,IBCODE,IBTRED,IBTSAV,FILL,IBRX,IBDATA,IBD,IBDT,IBQUIT,IBPRO,IBDD + Q:'$G(IBIFN) + S IB(0)=$G(^DGCR(399,IBIFN,0)),IBTYP=$P(IB(0),"^",5),IBQUIT=0 + I '$D(DFN) S DFN=$P(IB(0),"^",2) + ; + ; -- is inpt find entry in dgpm, then in ibt(356, s da=ibtre then edit +INPT I IBTYP<3 D + .S DATE=$P(IB(0),"^",3),DFN=$P(IB(0),"^",2) + .S DGPM=$O(^DGPM("APTT1",DFN,DATE,0)) ; double check for asih + .I DGPM S (IBTRE,IBTSAV)=$O(^IBT(356,"AD",DGPM,0)) + .I $G(IBTRE) D RNBEDIT + .Q:IBQUIT + .; + .; -- alternate inpt method + .S IBCODE=$O(^IBE(356.6,"ACODE",1,0)) + .S DATE=$P(IB(0),"^",3),DFN=$P(IB(0),"^",2) + .S IBDT=(DATE-.25) F S IBDT=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT)) Q:'IBDT!(IBDT>(DATE+.24)) D + ..S IBTRE=0 F S IBTRE=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT,IBTRE)) Q:IBTRE=""!(IBQUIT) D:$G(IBTSAV)'=IBTRE RNBEDIT + .Q + ; +OPT ; -- is opt-find entries in IBT(356, for opt dates and then edit + I IBTYP>2 S IBCODE=$O(^IBE(356.6,"ACODE",2,0)) D + .S IBAPPT=0 F S IBAPPT=$O(^DGCR(399,IBIFN,"OP",IBAPPT)) Q:'IBAPPT!(IBQUIT) D + ..S IBDT=(IBAPPT-.01) F S IBDT=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT)) Q:'IBDT!(IBDT>(IBAPPT+.24)) D + ...S IBTRE=0 F S IBTRE=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT,IBTRE)) Q:IBTRE=""!(IBQUIT) D RNBEDIT + .Q + ; +RX ; -- find rx's on bill + S IBDD=0 F S IBDD=$O(^IBA(362.4,"AIFN"_IBIFN,IBDD)) Q:'IBDD S IBD=0 F S IBD=$O(^IBA(362.4,"AIFN"_IBIFN,IBDD,IBD)) Q:'IBD!(IBQUIT) D + .S IBDATA=$G(^IBA(362.4,IBD,0)),IBRX=$P(IBDATA,"^",5),IBDT=$P(IBDATA,"^",3) + .I '$G(IBRX) S DIC=52,DIC(0)="BO",X=$P(IBDATA,"^",1) D DIC^PSODI(52,.DIC,X) S IBRX=+Y K DIC,X,Y Q:IBRX=-1 + .S FILL="" F S FILL=$O(^IBT(356,"ARXFL",IBRX,FILL)) Q:FILL=""!(IBQUIT) D + ..S IBTRE=0 F S IBTRE=$O(^IBT(356,"ARXFL",IBRX,FILL,IBTRE)) Q:'IBTRE!(IBQUIT) I $P(^IBT(356,+IBTRE,0),"^",6)=IBDT D RNBEDIT + ; +PRO ; -- find prosthetics on bill + S IBDD=0 F S IBDD=$O(^IBA(362.5,"AIFN"_IBIFN,IBDD)) Q:'IBDD S IBD=0 F S IBD=$O(^IBA(362.5,"AIFN"_IBIFN,IBDD,IBD)) Q:'IBD!(IBQUIT) D + .S IBDATA=$G(^IBA(362.5,IBD,0)),IBPRO=$P(IBDATA,"^",4) + .Q:'$G(IBPRO) + .S IBTRE=0 F S IBTRE=$O(^IBT(356,"APRO",+IBPRO,IBTRE)) Q:'IBTRE!(IBQUIT) D RNBEDIT + Q + ; +RNBEDIT ; + Q:IBQUIT + W:'$D(IBTALK) !!,"Since you have canceled this bill, you may enter a Reason Not Billable",!,"into Claims Tracking. This will take the care off of the UNBILLED lists" + S IBTALK=1 + ; + N %,IBTRED S IBTRED=$G(^IBT(356,IBTRE,0)) + W !!,"Claims Tracking entry: ",+IBTRED," ",$$EXPAND^IBTRE(356,.18,$P(IBTRED,"^",18))," ",$$FMTE^XLFDT($P(IBTRED,"^",6)) + I $G(IBMCSRNB)'="",$P(IBTRED,U,19) W !," Note: A Reason Not Billable has been previously entered",!?8,"for this Claims Tracking record." + S DA=IBTRE,DIE="^IBT(356,",DR=".19" + I $G(IBMCSRNB)'="" S DR=".19//"_$P(IBMCSRNB,U,2) ; IB*320 MCS cancel + D ^DIE + ; + ; - if the RNB changed, update the user and date/time last edited + I $P(IBTRED,"^",19)'=$P($G(^IBT(356,IBTRE,0)),"^",19) D NOW^%DTC S DR="1.03///"_%_";1.04////"_DUZ D ^DIE + ; + ; $D(Y) indicates an up-arrow exit from the DIE call (??) + I $D(Y) S DFN=+$P(^IBT(356,IBTRE,0),"^",2) D FIND^IBOHCT(DFN,IBTRE) S IBQUIT=1 + Q diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCCC2.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCCC2.m index 78953ac9..07fc916c 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCCC2.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCCC2.m @@ -1,200 +1,200 @@ -IBCCC2 ;ALB/AAS - CANCEL AND CLONE A BILL - CONTINUED ;6/6/03 9:56am - ;;2.0;INTEGRATED BILLING;**80,106,124,138,51,151,137,161,182,211,245,155,296,320,348,349,371**;21-MAR-94;Build 57 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ;MAP TO DGCRCC2 - ; - ;STEP 5 - get remainder of data to move and store in MCCR then x-ref - ;STEP 6 - go to screens, come out to IBB1 or something like that - ; -STEP5 S IBIFN1=$P(^DGCR(399,IBIFN,0),"^",15) G END:$S(IBIFN1="":1,'$D(^DGCR(399,IBIFN1,0)):1,1:0) - ; - ;move pure data nodes - F I="I1","I2","I3","M1" I $D(^DGCR(399,IBIFN1,I)) S ^DGCR(399,IBIFN,I)=^DGCR(399,IBIFN1,I) - ; - ;move top level data node. ;Do not move 'TX' node - F I="U","U1","U2","U3","UF2","UF3","UF31","C","M" I $D(^DGCR(399,IBIFN1,I)) S IBND(I)=^(I) D @I - ; - ;move multiple level data - F I="CC","OC","OP","OT","RC","CP","CV","PRV" I $D(^DGCR(399,IBIFN1,I,0)) D @I - ; - D FTPRV^IBCEU5(IBIFN) ; Ask change prov type if form type not the same - D COBCHG(IBIFN,,.IBCOB) - ; - D ^IBCCC3 ; copy table files (362.3) - ; - S I=$G(^DGCR(399,IBIFN1,0)) I $P(I,U,13)=7,$P(I,U,20)=1 D COPYB^IBCDC(IBIFN1,IBIFN) ; update auto bill files - D PRIOR(IBIFN) ; add new bill to previous bills in series, primary/secondary - I +$G(IBCTCOPY) N IBAUTO S IBAUTO=1 D PROC^IBCU7A(IBIFN),BILL^IBCRBC(IBIFN),CPTMOD26^IBCU73(IBIFN) D RECALL^DILFD(399,IBIFN_",",DUZ) G END - ; -STEP6 N IBGOEND - I '$G(IBCE("EDI"))!$G(IBCE("EDI","NEW")),'$G(IBCEAUTO) D IBSCEDT G END:$G(IBGOEND) - ; - ; -END K DFN,IB,IBA,IBA2,IBAD,IBADD1,IBBNO,IBCAN,IBCCC,IBDA,IBDPT,IBDR,IBDT,IBI,IBI1,IBIDS,IBIFN,IBIFN1,IBND,IBQUIT,IBU,IBUN,IBARST,IBCOB,IBCNCOPY,IBCBCOPY - K IBV,IBV1,IBW,IBWW,IBYN,IBZZ,PRCASV,PRCAERCD,PRCAERR,PRCASVC,PRCAT,IBBT,IBCH,IBNDS,IBOA,IBREV,IBX,DGXRF1,VAEL,VAERR,IBAC,IBCCC,IBDD1,IBIN,DGREV,DGREV00,DGREVHDR,IBCHK - K IBBS,IBLS,DGPCM,IBIP,IBND0,IBNDU,IBO,IBPTF,IBST,IBUC,IBDD,D,%,%DT,DIC,VA,VADM,X,X1,X2,X3,X4,Y,I,J,K,DGRVRCAL,DDH,DGACTDT,DGAMNT,DGBR,DGBRN,DGBSI,DGBSLOS,IBA1,IBOD,IBINS,IBN,IBPROC,DGFUNC,DGIFN - Q - ; - ; -IBSCEDT ; call the IB bill edit screens and validate the data - N IBV,IBPAR,IBAC,IBHV,IBH,IBCIREDT - D RECALL^DILFD(399,IBIFN_",",DUZ) -ST1 S IBV=0 D ^IBCSCU,^IBCSC1 I $G(IBPOPOUT) S IBGOEND=1 G IBSCX - S IBAC=1 - D ^IBCB1 - I $G(IBCIREDT) G ST1 -IBSCX ; - Q - ; - ; -U F J=3,4,6:1:17,20 I $P(IBND("U"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U"),"^",J)=$P(IBND("U"),"^",J) - Q -U1 F J=1:1:9,13,14 I $P(IBND("U1"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U1"),"^",J)=$P(IBND("U1"),"^",J) - Q -U2 F J=1:1:19 I $P(IBND("U2"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U2"),"^",J)=$P(IBND("U2"),"^",J) - Q -U3 F J=1:1:7 I $P(IBND("U3"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U3"),"^",J)=$P(IBND("U3"),"^",J) - Q -UF2 F J=1,3 I $P(IBND("UF2"),"^",J)]"" S $P(^DGCR(399,IBIFN,"UF2"),"^",J)=$P(IBND("UF2"),"^",J) - Q -UF3 F J=1:1:7 I $P(IBND("UF3"),"^",J)]"" S $P(^DGCR(399,IBIFN,"UF3"),"^",J)=$P(IBND("UF3"),"^",J) - Q -UF31 F J=1:1:3 I $P(IBND("UF31"),"^",J)]"" S $P(^DGCR(399,IBIFN,"UF31"),"^",J)=$P(IBND("UF31"),"^",J) - Q -C F J=10 I $P(IBND("C"),"^",J)]"" S $P(^DGCR(399,IBIFN,"C"),"^",J)=$P(IBND("C"),"^",J) - I '$D(^DGCR(399,IBIFN1,"CP")) D CP1 - Q -M F J=1:1:14 I $P(IBND("M"),"^",J)]"" S $P(^DGCR(399,IBIFN,"M"),"^",J)=$P(IBND("M"),"^",J) - Q -CC S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0) - S IBDD=399.04 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J I $D(^(J,0)) S ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0),X=$P(^(0),"^") -OP S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0) - S IBDD=399.043 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J I $D(^(J,0)) S ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0),X=$P(^(0),"^") - Q -OC S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0) - S IBDD=399.041 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J I $D(^(J,0)) S ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0),X=$P(^(0),"^") - Q -OT S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0) - S IBDD=399.048 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J I $D(^(J,0)) S ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0),X=$P(^(0),"^") - Q -CV ; Don't copy value codes from inpatient inst to inpatient prof bills - I $$FT^IBCEF(IBIFN1)'=2,$$FT^IBCEF(IBIFN)=2 Q - S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0) - S IBDD=399.047 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J I $D(^(J,0)) S ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0),X=$P(^(0),"^") - Q -RC S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0) - S IBDD=399.042 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J I $D(^(J,0)) S IBND("RC")=^(0) F K=1:1:15 S $P(^DGCR(399,IBIFN,I,J,0),"^",K)=$P(IBND("RC"),"^",K),X=$P(IBND("RC"),"^",K) - Q -CP S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0) - I +$G(IBNOCPT) Q - S IBDD=399.0304 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J I $D(^(J,0)) S IBND("CP")=^(0),IBND("CP-AUX")=$G(^("AUX")) D - . F K=1:1:7,9:1:14,16:1:22 S $P(^DGCR(399,IBIFN,I,J,0),"^",K)=$P(IBND("CP"),"^",K) - . ; esg - 11/2/06 - IB*2*348 - 50.09 field was added - AUX piece [9] - . I IBND("CP-AUX")'="" F K=1:1:9 S $P(^DGCR(399,IBIFN,I,J,"AUX"),"^",K)=$P(IBND("CP-AUX"),"^",K) - . I $D(^DGCR(399,IBIFN1,I,J,"MOD",0)) S ^DGCR(399,IBIFN,I,J,"MOD",0)=^DGCR(399,IBIFN1,I,J,"MOD",0) D - .. S K=0 F S K=$O(^DGCR(399,IBIFN1,I,J,"MOD",K)) Q:'K D - ... I $G(IBNOTC),$P($$MOD^ICPTMOD(+$P($G(^DGCR(399,IBIFN1,I,J,"MOD",K,0)),U,2),"I"),U,2)="TC" Q ; Don't copy TC modifier from inst to prof bill - ... S ^DGCR(399,IBIFN,I,J,"MOD",K,0)=^DGCR(399,IBIFN1,I,J,"MOD",K,0) -CP1 S IBCOD=$P($G(^DGCR(399,IBIFN,0)),"^",9) Q:IBCOD=""!('$D(^DGCR(399,IBIFN1,"C"))) - I IBCOD=9 F DGI=4,5,6 I $P(^DGCR(399,IBIFN1,"C"),"^",DGI) S X=$P(^("C"),"^",DGI)_";ICD0(",DGPROCDT=$P(^("C"),"^",DGI+7) D FILE - I IBCOD=4 F DGI=1,2,3 I $P(^DGCR(399,IBIFN1,"C"),"^",DGI) S X=$P(^("C"),"^",DGI)_";ICPT(",DGPROCDT=$P(^("C"),"^",DGI+10) D FILE - I IBCOD=5 F DGI=7,8,9 I $P(^DGCR(399,IBIFN1,"C"),"^",DGI) S X=$P(^("C"),"^",DGI)_";ICPT(",DGPROCDT=$P(^("C"),"^",DGI+4) D FILE - Q - ; -PRV S ^DGCR(399,IBIFN,I,0)=^DGCR(399,IBIFN1,I,0) - N Z,Z0 - S Z=$P($G(^DGCR(399,IBIFN,0)),U,19),Z0=$P($G(^DGCR(399,IBIFN1,0)),U,19) - S IBDD=399.0222 F J=0:0 S J=$O(^DGCR(399,IBIFN1,I,J)) Q:'J I $D(^(J,0)) D - . S ^DGCR(399,IBIFN,I,J,0)=^DGCR(399,IBIFN1,I,J,0),X=$P(^(0),"^") - . I Z'=Z0,$S(X=3:Z0=3,X=4:Z0=2,1:0) S $P(^DGCR(399,IBIFN,I,J,0),U)=(Z0+1) - Q - ; -COB S J=0 F S J=$O(IBCOB(I,J)) Q:'J S $P(^DGCR(399,IBIFN,I),U,J)=IBCOB(I,J) - Q - ; -FILE N DIC,DIE,DR,DA,X,Y,DLAYGO,DD,DO - I '$D(^DGCR(399,IBIFN,"CP",0)) S DIC("P")=$$GETSPEC^IBEFUNC(399,304) - S DIC(0)="L",DLAYGO=399,DA(1)=IBIFN,DIC="^DGCR(399,"_DA(1)_",""CP""," Q:X="" D FILE^DICN K DO,DD Q:+Y<1 S DA=+Y - S DIE="^DGCR(399,"_DA(1)_",""CP"",",DR="1///"_DGPROCDT D ^DIE - K DGPROCDT - Q - ; -INDEX ;index entire file (set logic) - S DIK="^DGCR(399,",DA=IBIFN D IX1^DIK K DA,DIK - Q - ; -PRIOR(IBIFN) ; set Secondary/Tertiary Bill #s on prior bills, if the bill is cancelled remove it from prior bills - N IBSEQ,IBSEQN,IBM1,I,IBIFN1 - S IBSEQ=$$COB^IBCEF(IBIFN) - S IBSEQN=$S(IBSEQ="S":6,IBSEQ="T":7,1:"") Q:'IBSEQN - ; - S IBM1=$G(^DGCR(399,IBIFN,"M1")) I +$P(^DGCR(399,IBIFN,0),U,13)=7 S IBIFN="" - F I=5,6 I I 362.3) - N IBCPT,IBDIFN1,IBLN,IBI - S IBCPT=0 F S IBCPT=$O(^DGCR(399,+IBIFN,"CP",IBCPT)) Q:'IBCPT D - . S IBLN=$G(^DGCR(399,+IBIFN,"CP",IBCPT,0)) F IBI=11:1:14 S IBDIFN1=$P(IBLN,U,IBI) I +IBDIFN1 D - .. S IBDX=+$G(^IBA(362.3,+IBDIFN1,0)) Q:'IBDX - .. S IBDIFN=$O(^IBA(362.3,"AIFN"_IBIFN,IBDX,0)) Q:'IBDIFN - .. S $P(^DGCR(399,+IBIFN,"CP",IBCPT,0),U,IBI)=IBDIFN - ; -RX ;copy rx refills (362.4) - N IBRX,IBRIFN,IBRXDA,IBDATE,IBNDC,IBDFN,IB3624DA - ;copy rx refills from old bill - ; IB*2*363 - get NDC# from PRESCRIPTION file (#52) before creating new - ; record entry in 362.4 - I $D(^IBA(362.4,"AIFN"_IBIFN1)) S IBXR="AIFN"_IBIFN1 D - . S IBRX=0 F S IBRX=$O(^IBA(362.4,IBXR,IBRX)) Q:IBRX="" D - .. S IBRIFN=0 F S IBRIFN=$O(^IBA(362.4,IBXR,IBRX,IBRIFN)) Q:'IBRIFN D - ... S IBX=$G(^IBA(362.4,IBRIFN,0)) I IBX=""!($P(IBX,U,2)'=IBIFN1) Q - ... S DIC="^IBA(362.4,",DIC(0)="L",X=$P(IBX,U,1) K DA,DO D FILE^DICN K DA,DO Q:Y'>0 - ... S IB3624DA=+Y,IBRXDA=$P(IBX,U,5),IBDATE=$P(IBX,U,3),IBDFN=$$GET1^DIQ(399,IBIFN1,.02,"I") - ... S IBNDC=$S(IBRXDA:$$GETNDC^IBEFUNC3(IBDFN,IBRXDA,IBDATE),1:$P(IBX,U,8)) - ... S DR=".02////"_IBIFN_";.03////"_IBDATE_";.04////"_$P(IBX,U,4)_";.05////"_IBRXDA_";.06////"_$P(IBX,U,6)_";.07////"_$P(IBX,U,7)_";.08////"_IBNDC - ... S DIE=DIC,DA=IB3624DA D ^DIE K DIC,DIE,DA,DO,DR - K DIE,DIC,DA,DO,DR,X,Y - ; -PROS ;copy prosthetics (362.5) - N IBPR,IBPIFN - ;copy rx refills from old bill - I $D(^IBA(362.5,"AIFN"_IBIFN1)) S IBXR="AIFN"_IBIFN1 D - . S IBPR=0 F S IBPR=$O(^IBA(362.5,IBXR,IBPR)) Q:IBPR="" D - .. S IBPIFN=0 F S IBPIFN=$O(^IBA(362.5,IBXR,IBPR,IBPIFN)) Q:'IBPIFN D - ... S IBX=$G(^IBA(362.5,IBPIFN,0)) I IBX=""!($P(IBX,U,2)'=IBIFN1) Q - ... S DIC="^IBA(362.5,",DIC(0)="L",X=$P(IBX,U,1) K DA,DO D FILE^DICN K DA,DO Q:Y'>0 - ... S DR=".02////"_IBIFN_";.04////"_$P(IBX,U,4)_";.05////^S X=$P(IBX,U,5)" - ... S DIE=DIC,DA=+Y D ^DIE K DIC,DIE,DA,DO,DR - K DIE,DIC,DA,DO,DR,X,Y - Q - ;IBCCC3 +IBCCC3 ;ALB/AAS - CANCEL AND CLONE A BILL - CONTINUED ;25-JAN-90 + ;;2.0;INTEGRATED BILLING;**363,381**;21-MAR-94;Build 1 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; + ;copy entries from table files: + ;passed in: IBIFN=new bill, IBIFN1=old bill + ; + I '$D(^DGCR(399,+$G(IBIFN),0))!'$D(^DGCR(399,+$G(IBIFN1),0)) Q + N IBXR,X,Y,IBX + ; +DX ;copy diagnosis' (362.3) + N IBDX,IBDIFN + ;copy diagnosis from old bill + I $D(^IBA(362.3,"AIFN"_IBIFN1)) S IBXR="AIFN"_IBIFN1 D + . S IBDX=0 F S IBDX=$O(^IBA(362.3,IBXR,IBDX)) Q:'IBDX D + .. S IBDIFN=0 F S IBDIFN=$O(^IBA(362.3,IBXR,IBDX,IBDIFN)) Q:'IBDIFN D + ... S IBX=$G(^IBA(362.3,IBDIFN,0)) I 'IBX!($P(IBX,U,2)'=IBIFN1) Q + ... S DIC="^IBA(362.3,",DIC(0)="L",X=+IBX K DA,DO D FILE^DICN + ... S DIE=DIC,DA=+Y,DR=".02////"_IBIFN_";.03////"_$P(IBX,U,3) D ^DIE K DIC,DIE,DA,DO,DR + K DIE,DIC,DA,DO,DR,X,Y + ; +PRDX ;repoint procedure's associated diagnosis (2,304,10-13 -> 362.3) + N IBCPT,IBDIFN1,IBLN,IBI + S IBCPT=0 F S IBCPT=$O(^DGCR(399,+IBIFN,"CP",IBCPT)) Q:'IBCPT D + . S IBLN=$G(^DGCR(399,+IBIFN,"CP",IBCPT,0)) F IBI=11:1:14 S IBDIFN1=$P(IBLN,U,IBI) I +IBDIFN1 D + .. S IBDX=+$G(^IBA(362.3,+IBDIFN1,0)) Q:'IBDX + .. S IBDIFN=$O(^IBA(362.3,"AIFN"_IBIFN,IBDX,0)) Q:'IBDIFN + .. S $P(^DGCR(399,+IBIFN,"CP",IBCPT,0),U,IBI)=IBDIFN + ; +RX ;copy rx refills (362.4) + N IBRX,IBRIFN,IBRXDA,IBDATE,IBNDC,IBDFN,IB3624DA + ;copy rx refills from old bill + ; IB*2*363 - get NDC# from PRESCRIPTION file (#52) before creating new + ; record entry in 362.4 + I $D(^IBA(362.4,"AIFN"_IBIFN1)) S IBXR="AIFN"_IBIFN1 D + . S IBRX=0 F S IBRX=$O(^IBA(362.4,IBXR,IBRX)) Q:IBRX="" D + .. S IBRIFN=0 F S IBRIFN=$O(^IBA(362.4,IBXR,IBRX,IBRIFN)) Q:'IBRIFN D + ... S IBX=$G(^IBA(362.4,IBRIFN,0)) I IBX=""!($P(IBX,U,2)'=IBIFN1) Q + ... S DIC="^IBA(362.4,",DIC(0)="L",X=$P(IBX,U,1) K DA,DO D FILE^DICN K DA,DO Q:Y'>0 + ... S IB3624DA=+Y,IBRXDA=$P(IBX,U,5),IBDATE=$P(IBX,U,3),IBDFN=$$GET1^DIQ(399,IBIFN1,.02,"I") + ... S IBNDC=$S(IBRXDA:$$GETNDC^IBEFUNC3(IBDFN,IBRXDA,IBDATE),1:$P(IBX,U,8)) + ... S DR=".02////"_IBIFN_";.03////"_IBDATE_";.04////"_$P(IBX,U,4)_";.05////"_IBRXDA_";.06////"_$P(IBX,U,6)_";.07////"_$P(IBX,U,7)_";.08////"_IBNDC + ... S DIE=DIC,DA=IB3624DA D ^DIE K DIC,DIE,DA,DO,DR + K DIE,DIC,DA,DO,DR,X,Y + ; +PROS ;copy prosthetics (362.5) + N IBPR,IBPIFN + ;copy rx refills from old bill + I $D(^IBA(362.5,"AIFN"_IBIFN1)) S IBXR="AIFN"_IBIFN1 D + . S IBPR=0 F S IBPR=$O(^IBA(362.5,IBXR,IBPR)) Q:IBPR="" D + .. S IBPIFN=0 F S IBPIFN=$O(^IBA(362.5,IBXR,IBPR,IBPIFN)) Q:'IBPIFN D + ... S IBX=$G(^IBA(362.5,IBPIFN,0)) I IBX=""!($P(IBX,U,2)'=IBIFN1) Q + ... S DIC="^IBA(362.5,",DIC(0)="L",X=$P(IBX,U,1) K DA,DO D FILE^DICN K DA,DO Q:Y'>0 + ... S DR=".02////"_IBIFN_";.03////"_$P(IBX,U,3)_";.04////"_$P(IBX,U,4) + ... S DIE=DIC,DA=+Y D ^DIE K DIC,DIE,DA,DO,DR + K DIE,DIC,DA,DO,DR,X,Y + Q + ;IBCCC3 diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCE.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCE.m index 4db81aaa..3c7ecd2f 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCE.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCE.m @@ -1,98 +1,89 @@ -IBCE ;ALB/TMP - 837 EDI TRANSMISSION UTILITIES/NIGHTLY JOB ;22-JAN-96 - ;;2.0;INTEGRATED BILLING;**137,283,296,371**;21-MAR-94;Build 57 - ;;Per VHA Directive 2004-038, this routine should not be modified. -EN ; Run all jobs needed for EDI processing nightly - ; including transmit bills waiting for extract, batches not sent, - N IBLAST,IBZ,IBZ0 - D NOTSENT^IBCEBUL - D EN^IBCE837 - D EN^IBCEMPRG ; purge status messages from file 361 - D PURGE^IBCEPTU ; purge transmission detail and claims status data associated with test transmissions after 60 days - S IBLAST=$G(^IBA(364.2,"ALAST")),^IBA(364.2,"ALAST")=$$NOW^XLFDT() - ; Clean up ACOB xref in 364 - S IBZ=0 - F S IBZ=$O(^IBA(364,"ACOB",IBZ)) Q:'IBZ S IBZ0=0 F S IBZ0=$O(^IBA(364,"ACOB",IBZ,IBZ0)) Q:'IBZ0 I '$$COBPOSS^IBCECOB(IBZ0) D UPDEDI^IBCEM(IBZ0,"N",1) - Q - ; -EN1 ; Manual entry point for transmitting EDI bills - N DIR,X,Y,IBLAST,IBTASK,IBOPTX,DTOUT,DUOUT - I '$$MGCHK(1) G EN1Q - S DIR("A")="Select transmit option: ",DIR("B")="S",DIR(0)="SAM^A:Transmit (A)LL bills in READY FOR EXTRACT status;S:Transmit only (S)ELECTED bills" - D ^DIR K DIR - I $D(DTOUT)!$D(DUOUT) G EN1Q - S IBOPTX=Y - I Y="A" D G EN1Q - . S DIR("A",1)="This option will run a job to transmit ALL bills ready for EDI transmission" - . S DIR("A",2)="This option's last scheduled run was "_$$FMTE^XLFDT($G(^IBA(364.2,"ALAST")),2) - . S DIR("A",3)=" " - . S DIR("A")="Are you absolutely sure this is what you want to do? " - . S DIR("B")="NO",DIR(0)="YA" D ^DIR K DIR - . Q:'Y - . S DIR(0)="YA",DIR("A",1)=" " - . S DIR("A",2)="Transmission of ALL bills will be run now" - . S DIR("A")="Is this OK? ",DIR("B")="NO" - . D ^DIR K DIR - . Q:'Y - . D EN1^IBCE837B(.IBTASK) - . I $G(IBTASK) D - .. S DIR("A",1)="Task # for this job is: "_IBTASK - . E D - .. I $G(IBTASK)'="" S DIR("A",1)="Error encountered in tasking job - check IRM for reported errors" - .. S DIR(0)="EA",DIR("A")=" Press RETURN to continue " W !! D ^DIR K DIR - I IBOPTX="S" D SUB1^IBCEM03 G EN1Q -EN1Q Q - ; -RESUB(IB364) ; Manually resubmit bill for transmission (ien file 364 = IB364) - N DIR,X,Y,IBBTCH,DTOUT,DUOUT,IBIFN,NEW364 - I '$$MGCHK(1) G RESUBQ - S IBIFN=+$P($G(^IBA(364,+$G(IB364),0)),U,1) I 'IBIFN G RESUBQ - S IBBTCH="" - W ! S DIR(0)="SA^I:IMMEDIATE TRANSMIT;L:TRANSMIT LATER WITH REST OF READY FOR EXTRACT BILLS",DIR("A")="TRANSMIT (I)MMEDIATELY OR (L)ATER?: ",DIR("B")="L" - S DIR("?",1)="IF YOU CHOOSE TO TRANSMIT IMMEDIATELY, THE BILL'S DATA WILL BE BATCHED BY",DIR("?",2)=" ITSELF AND SENT OUT IMMEDIATELY. IF YOU CHOOSE TO TRANSMIT LATER, THE" - S DIR("?",3)=" BILL'S TRANSMISSION STATUS WILL BE RESET TO 'READY FOR EXTRACT' AND THE BILL'S",DIR("?",4)=" DATA WILL BE EXTRACTED THE NEXT TIME A GENERAL TRANSMISSION OF YOUR BILLS",DIR("?")=" IN READY TO EXTRACT STATUS OCCURS" - D ^DIR K DIR - I $D(DTOUT)!$D(DUOUT) G RESUBQ - ; - ; immediate retransmission of claim - I Y="I" D G RESUBQ - . S NEW364=$$ADDTBILL^IBCB1(IBIFN) ; Add a new transmission record - . I '$P(NEW364,U,3) D Q - .. S DIR("A",1)="FAILED TO ADD A NEW EDI TRANSMISSION",DIR(0)="EA",DIR("A")="PRESS ENTER TO CONTINUE " W ! D ^DIR K DIR - .. Q - . ; - . K ^TMP("IBONE",$J),^TMP("IBSELX",$J),^TMP("IBCE-BATCH",$J) - . S ^TMP("IBONE",$J,+NEW364)="",^TMP("IBONE",$J)=0,^TMP("IBSELX",$J)="" - . D ONE^IBCE837 - . S IBBTCH=$O(^TMP("IBCE-BATCH",$J,0)) ; external batch# - . I IBBTCH'="" S IBBTCH=+$G(^TMP("IBCE-BATCH",$J,IBBTCH)) ; internal batch# - . K ^TMP("IBONE",$J),^TMP("IBSELX",$J),^TMP("IBCE-BATCH",$J) - . ; - . I 'IBBTCH D - .. S DIR("A",1)="BILL NOT RESUBMITTED - CHECK ALERTS/MAIL FOR DETAILS" - . E D - .. N DIE,DR,DA - .. D UPDEDI^IBCEM(IB364,"R") ; update EDI files for old transmission - .. S DIE="^IBA(364,",DR=".06////"_+IBBTCH,DA=IB364 D ^DIE - .. S DIR("A",1)="BILL RESUBMITTED IN BATCH #"_$P($G(^IBA(364.1,+IBBTCH,0)),U,1) - . S DIR(0)="EA",DIR("A")="PRESS ENTER TO CONTINUE " W ! D ^DIR K DIR - . Q - ; - ; Later retransmission of claim - D UPDEDI^IBCEM(IB364,"R") ; update EDI files for old transmission record - S Y=$$ADDTBILL^IBCB1(IBIFN) ; Add a new transmission record - S DIR("A",1)="BILL'S TRANSMISSION STATUS RESET TO 'READY TO EXTRACT'" - S DIR(0)="EA",DIR("A")="PRESS ENTER TO CONTINUE " W ! D ^DIR K DIR - ; -RESUBQ Q - ; -MGCHK(DSP) ; Returns 1 if mail group IB EDI has at least 1 local member, - ; 0 if none found - ; DSP = flag that if =1, displays error message - N IB - S IB=$$GOTLOCAL^XMXAPIG("IB EDI") - I 'IB,$G(DSP) D - . ; No local members in mail group for EDI messages - . S DIR("A",1)="YOU MUST HAVE AT LEAST 1 MEMBER IN THE 'IB EDI' MAIL GROUP TO TRANSMIT A BILL",DIR("A")="PRESS RETURN TO CONTINUE " - . S DIR(0)="EA" D ^DIR K DIR - Q IB - ; +IBCE ;ALB/TMP - 837 EDI TRANSMISSION UTILITIES/NIGHTLY JOB ;22-JAN-96 + ;;2.0;INTEGRATED BILLING;**137,283,296**;21-MAR-94 +EN ; Run all jobs needed for EDI processing nightly + ; including transmit bills waiting for extract, batches not sent, + N IBLAST,IBZ,IBZ0 + D NOTSENT^IBCEBUL + D EN^IBCE837 + D EN^IBCEMPRG ; purge status messages from file 361 + D PURGE^IBCEPTU ; purge transmission detail and claims status data associated with test transmissions after 60 days + S IBLAST=$G(^IBA(364.2,"ALAST")),^IBA(364.2,"ALAST")=$$NOW^XLFDT() + ; Clean up ACOB xref in 364 + S IBZ=0 + F S IBZ=$O(^IBA(364,"ACOB",IBZ)) Q:'IBZ S IBZ0=0 F S IBZ0=$O(^IBA(364,"ACOB",IBZ,IBZ0)) Q:'IBZ0 I '$$COBPOSS^IBCECOB(IBZ0) D UPDEDI^IBCEM(IBZ0,"N",1) + Q + ; +EN1 ; Manual entry point for transmitting EDI bills + N DIR,X,Y,IBLAST,IBTASK,IBOPTX,DTOUT,DUOUT + I '$$MGCHK(1) G EN1Q + S DIR("A")="Select transmit option: ",DIR("B")="S",DIR(0)="SAM^A:Transmit (A)LL bills in READY FOR EXTRACT status;S:Transmit only (S)ELECTED bills" + D ^DIR K DIR + I $D(DTOUT)!$D(DUOUT) G EN1Q + S IBOPTX=Y + I Y="A" D G EN1Q + . S DIR("A",1)="This option will run a job to transmit ALL bills ready for EDI transmission" + . S DIR("A",2)="This option's last scheduled run was "_$$FMTE^XLFDT($G(^IBA(364.2,"ALAST")),2) + . S DIR("A",3)=" " + . S DIR("A")="Are you absolutely sure this is what you want to do? " + . S DIR("B")="NO",DIR(0)="YA" D ^DIR K DIR + . Q:'Y + . S DIR(0)="YA",DIR("A",1)=" " + . S DIR("A",2)="Transmission of ALL bills will be run now" + . S DIR("A")="Is this OK? ",DIR("B")="NO" + . D ^DIR K DIR + . Q:'Y + . D EN1^IBCE837B(.IBTASK) + . I $G(IBTASK) D + .. S DIR("A",1)="Task # for this job is: "_IBTASK + . E D + .. I $G(IBTASK)'="" S DIR("A",1)="Error encountered in tasking job - check IRM for reported errors" + .. S DIR(0)="EA",DIR("A")=" Press RETURN to continue " W !! D ^DIR K DIR + I IBOPTX="S" D SUB1^IBCEM03 G EN1Q +EN1Q Q + ; +RESUB(IB364) ; Manually resubmit bill for transmission (ien file 364 = IB364) + N DIR,X,Y,IBBTCH,DTOUT,DUOUT + I '$$MGCHK(1) G RESUBQ + S IBBTCH="" + W ! S DIR(0)="SA^I:IMMEDIATE TRANSMIT;L:TRANSMIT LATER WITH REST OF READY FOR EXTRACT BILLS",DIR("A")="TRANSMIT (I)MMEDIATELY OR (L)ATER?: ",DIR("B")="L" + S DIR("?",1)="IF YOU CHOOSE TO TRANSMIT IMMEDIATELY, THE BILL'S DATA WILL BE BATCHED BY",DIR("?",2)=" ITSELF AND SENT OUT IMMEDIATELY. IF YOU CHOOSE TO TRANSMIT LATER, THE" + S DIR("?",3)=" BILL'S TRANSMISSION STATUS WILL BE RESET TO 'READY FOR EXTRACT' AND THE BILL'S",DIR("?",4)=" DATA WILL BE EXTRACTED THE NEXT TIME A GENERAL TRANSMISSION OF YOUR BILLS",DIR("?")=" IN READY TO EXTRACT STATUS OCCURS" + D ^DIR K DIR + I $D(DTOUT)!$D(DUOUT) G RESUBQ + I Y="I" D G:'IBBTCH RESUBQ + . N Y + . K ^TMP("IBONE",$J),^TMP("IBSELX",$J),^TMP("IBCE-BATCH",$J) + . S ^TMP("IBONE",$J,IB364)="",^TMP("IBONE",$J)=0,^TMP("IBSELX",$J)="" + . D ONE^IBCE837 + . S IBBTCH=$O(^TMP("IBCE-BATCH",$J,0)) ; external batch# + . I IBBTCH'="" S IBBTCH=+$G(^TMP("IBCE-BATCH",$J,IBBTCH)) ; internal batch# + . K ^TMP("IBONE",$J),^TMP("IBSELX",$J),^TMP("IBCE-BATCH",$J) + . I 'IBBTCH D + .. S DIR("A",1)="BILL NOT RESUBMITTED - CHECK ALERTS/MAIL FOR DETAILS" + . E D + .. N DIE,DR,DA + .. D UPDEDI^IBCEM(IB364,"R") + .. S DIE="^IBA(364,",DR=".06////"_+IBBTCH,DA=IB364 D ^DIE + .. S DIR("A",1)="BILL RESUBMITTED IN BATCH #"_$P($G(^IBA(364.1,IBBTCH,0)),U) + . S DIR(0)="EA",DIR("A")="PRESS ENTER TO CONTINUE " D ^DIR K DIR + I Y="L" D + . N Y + . D UPDEDI^IBCEM(IB364,"R") + . ;Add a new transmission record + . S Y=$$ADDTBILL^IBCB1($P($G(^IBA(364,+IB364,0)),U),1) + . S DIR("A",1)="BILL'S TRANSMISSION STATUS RESET TO 'READY TO EXTRACT'" + . S DIR(0)="EA",DIR("A")="PRESS ENTER TO CONTINUE " D ^DIR K DIR + ; +RESUBQ Q + ; +MGCHK(DSP) ; Returns 1 if mail group IB EDI has at least 1 local member, + ; 0 if none found + ; DSP = flag that if =1, displays error message + N IB + S IB=$$GOTLOCAL^XMXAPIG("IB EDI") + I 'IB,$G(DSP) D + . ; No local members in mail group for EDI messages + . S DIR("A",1)="YOU MUST HAVE AT LEAST 1 MEMBER IN THE 'IB EDI' MAIL GROUP TO TRANSMIT A BILL",DIR("A")="PRESS RETURN TO CONTINUE " + . S DIR(0)="EA" D ^DIR K DIR + Q IB + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCE277.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCE277.m index d908e29e..d6bf6ba8 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCE277.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCE277.m @@ -1,220 +1,216 @@ -IBCE277 ;ALB/TMP - 277 EDI CLAIM STATUS MESSAGE PROCESSING ;15-JUL-98 - ;;2.0;INTEGRATED BILLING;**137,155,368**;21-MAR-94;Build 21 - ;;Per VHA Directive 2004-038, this routine should not be modified. - Q - ; MESSAGE HEADER DATA STRING = - ; type of message^msg queue^msg #^bill #^REF NUM/Batch #^date/time - ; -HDR(ENTITY,ENTVAL,IBTYPE,IBD) ;Process header data - ; INPUT: - ; ENTITY = "BATCH" or "CLAIM" for batch/claim level messages respectively - ; ENTVAL = claim # - ; IBTYPE = the type of status msg this piece of the message represents - ; (837REC1, 837REJ1) - ; ^TMP("IBMSGH",$J,0) = header message text - ; - ; OUTPUT: - ; IBD array returned with processed data - ; "DATE" = Date/Time of status (Fileman format) - ; "MRA" = 1 if MRA, 0 if not "X12" = 1 if X12, 0 if not - ; "BATCH" = Batch ien for batch level calls - ; "SOURCE" = Source of message code^source name, if known - ; - ; ^TMP("IBMSG",$J,"BATCH",batch #,0)=MESSAGE HEADER DATA STRING - ; if batch level message - ; ,"D",0,1)=header record raw data - ; ,line #)=batch status message lines - ; - ; ^TMP("IBMSG",$J,"CLAIM",claim #,0)=MESSAGE HEADER DATA STRING - ; if claim level message - ; ,"D",0,1)=header record raw data - ; ,line #)=claim status message lines - ; - N DATA,IBD0,L,PC,X,Y - S IBD0=$G(^TMP("IBMSGH",$J,0)) Q:IBD0="" - S Y=0,L=1 - ; Convert claim date/time - S X=$$DATE($P(IBD0,U,3))_"@"_$E($P(IBD0,U,4)_"0000",1,4) I X S %DT="XTS" D ^%DT - ; populate IBD array - S IBD("DATE")=$S(Y>0:Y,1:""),IBD("MRA")=$P(IBD0,U,5),IBD("X12")=($P(IBD0,U,2)="X") - S IBD("SOURCE")=$P(IBD0,U,12,13),IBD("BATCH")=$P(IBD0,U,14) - I +$TR($P(IBD0,U,6,9),U) F PC=6:1:9 D - .I $P(IBD0,U,PC)'="" S DATA=$P("# Claims Submitted^# Claims Rejected^Total Charges Submitted^Total Charges Rejected",U,PC-5)_": "_$S(PC<8:+$P(IBD0,U,PC),1:$FNUMBER($P(IBD0,U,PC)/100,"",2))_" " - .I $L($G(^TMP("IBMSG-H",$J,ENTITY,ENTVAL,L)))+$L(DATA)>70 S L=L+1 ; if data doesn't fit into current line, go to the next line - .S ^TMP("IBMSG-H",$J,ENTITY,ENTVAL,L)=$G(^TMP("IBMSG-H",$J,ENTITY,ENTVAL,L))_DATA ; file this piece of data - .Q - ; file batch ref. number - S:IBD("BATCH")'="" L=L+1,^TMP("IBMSG-H",$J,ENTITY,ENTVAL,L)="Batch Reference Number: "_IBD("BATCH") - I $TR($P(IBD0,U,10,13),U)'="" D - .S L=L+1 - .; generate and file Payer Name / Payer Id line - .S DATA="Payer Name: "_$S($P(IBD0,U,10)'="":$P(IBD0,U,10),1:"N/A")_" Payer ID: "_$S($P(IBD0,U,11)'="":$P(IBD0,U,11),1:"N/A") - .S ^TMP("IBMSG-H",$J,ENTITY,ENTVAL,L)=DATA - .I $P(IBD0,U,12)'=""!($P(IBD0,U,13)'="") D - ..; generate and file Message Source line - ..S DATA="Source: "_$S($P(IBD0,U,12)="Y":"Sent by payer",$P(IBD0,U,13)'="":"Sent by non-payer ("_$P(IBD0,U,13)_")",1:"UNKNOWN") - ..S L=L+1,^TMP("IBMSG-H",$J,ENTITY,ENTVAL,L)=DATA - ..Q - .Q - S ^TMP("IBMSG",$J,ENTITY,ENTVAL,0)=IBTYPE_U_$G(IBD("MSG#"))_U_$G(IBD("SUBJ"))_U_$$GETBILL(ENTVAL)_U_U_IBD("DATE")_U_IBD("SOURCE") - ; file raw data - S ^TMP("IBMSG",$J,ENTITY,ENTVAL,"D",0,1)="##RAW DATA: "_IBD0 - Q - ; -9(IBD) ; Process Message Header record - ; INPUT: - ; IBD must be passed by reference = entire message line - ; OUTPUT: - ; IBD array returned with processed data - ; "CLAIM" = claim # - ; "LINE" = last line # populated in the message - ; - ; ^TMP("IBMSG",$J,"CLAIM",claim #,line#)= message data lines - ; ,"D",9,msg seq #)= raw data - N ENTITY,ERR,FLD,IBCLM,IBIFN,L - D STRTREC Q:IBCLM="" ; if no claim/batch number, bail out - ; make sure that we have data to file - S ERR=$P(IBD,U,4) Q:ERR="" - ; file error along with corresponding field number (if available) - S L=L+1,FLD=$P(IBD,U,5),^TMP("IBMSG",$J,ENTITY,IBCLM,L)="Error"_$S(FLD'="":" in field "_FLD,1:"")_":" - S L=L+1,^TMP("IBMSG",$J,ENTITY,IBCLM,L)=ERR - D ENDREC(9) - Q - ; -10(IBD) ; Process message data - ; INPUT: - ; IBD must be passed by reference = entire message line - ; OUTPUT: - ; IBD array returned with processed data - ; "CLAIM" = claim # - ; "LINE" = last line # populated in the message - ; - ; ^TMP("IBMSG",$J,"CLAIM",claim #,line#)= message data lines - ; ,"D",10,msg seq #)= raw data - ; ^TMP("IBCONF",$J,claim #")="" for invalid claims within the batch - ; - N CODE,DATA,ENTITY,IBCLM,IBIFN,IBTYPE,L,Z - D STRTREC Q:IBCLM="" ; if no claim number, bail out - S:$P(IBD,U,3)="R" ^TMP("IBCONF",$J,IBIFN)="" - S IBTYPE=$S($P(IBD,U,3)="R":"837REJ1",1:"837REC1") - ;Process header data if not already done - I '$D(^TMP("IBMSG",$J,ENTITY,IBCLM,0)) D HDR(ENTITY,IBCLM,IBTYPE,.IBD) - I IBTYPE="837REJ1",$P($G(^TMP("IBMSG",$J,ENTITY,IBCLM,0)),U,1)'="837REJ1" D HDR(ENTITY,IBCLM,IBTYPE,.IBD) - S CODE=$P(IBD,U,4) I CODE'="",$TR($P(IBD,U,5,6),U)'="" D - .S Z=CODE_$P(IBD,U,5) I Z'=$G(IBD("SCODE")) D - ..; determine type of status code and file it - ..S L=L+1,DATA=$S(CODE="W":"Warning",CODE="E":"Error",1:"Informational")_" " - ..I $P(IBD,U,5)'="" S ^TMP("IBMSG",$J,ENTITY,IBCLM,L)=DATA_"Code: "_$P(IBD,U,5) - ..I $P(IBD,U,6)'="" S:$P(IBD,U,5)'="" L=L+1 S ^TMP("IBMSG",$J,ENTITY,IBCLM,L)=DATA_"Message:",L=L+1 - ..S IBD("SCODE")=Z - ..Q - .; file status message - .I $P(IBD,U,6)'="" S ^TMP("IBMSG",$J,ENTITY,IBCLM,L)=$P(IBD,U,6),L=L+1,^TMP("IBMSG",$J,ENTITY,IBCLM,L)=" " - .Q - D ENDREC(10) - Q - ; -13(IBD) ; Process claim data - ; Claim must have been referenced by a previous '10' level - ; INPUT: - ; IBD must be passed by reference = entire message line - ; - ; OUTPUT: - ; IBD("LINE") = The last line # populated in the message - ; - ; ^TMP("IBMSG",$J,"CLAIM",claim #,line#)=claim data lines - ; ,"D",13,msg seq #)=raw data - ; - N CTYPE,ENTITY,IBCLM,IBIFN,L,Z1,Z2 - D STRTREC - ; quit if no claim number or no previous 'line 10' record - Q:$S(IBCLM="":1,1:'$D(^TMP("IBMSG",$J,"CLAIM",IBCLM))) - ; file clearinghouse trace number - I $P(IBD,U,3)'="" S L=L+1,^TMP("IBMSG",$J,ENTITY,IBCLM,L)="Clearinghouse Trace Number: "_$P(IBD,U,3) - ; file payer status date - I $P(IBD,U,4)'="" S L=L+1,^TMP("IBMSG",$J,ENTITY,IBCLM,L)=" Payer Status Date: "_$$DATE($P(IBD,U,4)) - ; file payer claim number - I $P(IBD,U,5)'="" S L=L+1,^TMP("IBMSG",$J,ENTITY,IBCLM,L)=" Payer Claim Number: "_$P(IBD,U,5) - ; file split claim indicator - I +$P(IBD,U,6)'=0 S L=L+1,^TMP("IBMSG",$J,ENTITY,IBCLM,L)=" Split Claim: "_$S(+$P(IBD,U,6)=1:"No",1:"Yes ("_+$P(IBD,U,6)_" parts)") - ; file claim type if it either doesn't match value in VistA or if it's a dental claim - S Z1=$P(IBD,U,7),Z2=$$FT^IBCEF(IBIFN),CTYPE=$S(Z1="P"&(Z2'=2):"Professional",Z1="I"&(Z2'=3):"Institutional",Z1="D":"Dental",1:"") - S:CTYPE'="" L=L+1,^TMP("IBMSG",$J,ENTITY,IBCLM,L)=" Claim Type: "_CTYPE - D ENDREC(13) - Q - ; -15(IBD) ; Process subscriber/patient data - ; Claim must have been referenced by a previous '10' level - ; INPUT: - ; IBD must be passed by reference = entire message line - ; - ; OUTPUT: - ; IBD("LINE") = The last line # populated in the message - ; - ; ^TMP("IBMSG",$J,"CLAIM",claim #,line#)=formatted service dates - ; ,"D",15,msg seq #)= - ; subscr/patient raw data - ; - N ENTITY,DATA,IBCLM,IBIFN,IBNM,IBNUM,IBDFN,L - D STRTREC - ; quit if no claim number or no previous 'line 10' record - Q:$S(IBCLM="":1,1:'$D(^TMP("IBMSG",$J,"CLAIM",IBCLM))) - S IBDFN=+$P(^DGCR(399,IBIFN,0),U,2) - S IBNM=$S($P(IBD,U,3)'="":$P(IBD,U,3)_","_$P(IBD,U,4)_$S($P(IBD,U,5)'="":" "_$P(IBD,U,5),1:""),1:$P($G(^DPT(IBDFN,0)),U)) - S IBNUM=$S($P(IBD,U,6)'="":$P(IBD,U,6),1:$P($G(^DPT(IBDFN,0)),U,9)) - S L=L+1,^TMP("IBMSG",$J,ENTITY,IBCLM,L)="Patient: "_IBNM_" "_IBNUM - I $P(IBD,U,11) D - .S DATA=$$DATE($P(IBD,U,11)),L=L+1 - .S ^TMP("IBMSG",$J,ENTITY,IBCLM,L)="Service Dates: "_DATA_" - "_$S($P(IBD,U,12):$$DATE($P(IBD,U,12)),1:DATA) - .Q - D ENDREC(15) - Q - ; -STRTREC ; start processing of the record - ; - ; OUTPUT: - ; sets the following variables - ; IBCLM = claim # - ; ENTITY = "CLAIM" (all 277STAT messages are on claim level) - ; L = last populated line number - ; - S IBCLM=$$GETCLM($P(IBD,U,2)),ENTITY="CLAIM",L=+$G(IBD("LINE")) - S IBIFN=+$O(^DGCR(399,"B",IBCLM,0)) - Q - ; -ENDREC(TYPE) ; finish processing of the record - ; INPUT: - ; TYPE = record type (line type) - ; - ; OUTPUT: - ; IBD("LINE") = is updated with last populated line number - ; - ;make sure all variables are set properly - Q:$G(ENTITY)="" - Q:$G(IBCLM)="" - Q:$G(TYPE)="" - ; file raw data - S ^TMP("IBMSG",$J,ENTITY,IBCLM,"D",TYPE,$O(^TMP("IBMSG",$J,ENTITY,IBCLM,"D",TYPE,""),-1)+1)="##RAW DATA: "_IBD - ; update line count - S IBD("LINE")=$G(IBD("LINE"))+L - Q - ; -GETBILL(CLAIM) ; Extract transmission # - N TRANS - S TRANS=$$LAST364^IBCEF4(IBIFN) - ; if status of the last transmission is "X" or "P", keep searching backwards through file 364 until record - ; with different status is found - I TRANS F Q:"XP"'[$P(^IBA(364,TRANS,0),U,3) S TRANS=$O(^IBA(364,"B",IBIFN,TRANS),-1) Q:TRANS="" ; - Q +TRANS - ; -DATE(DT) ; Convert YYMMDD Date into MM/DD/YY or YYYYMMDD into MM/DD/YYYY - N D,Y - S D=DT,Y="" - I $L(DT)=8 S D=$E(DT,3,8),Y=$E(DT,1,2) - Q ($E(D,3,4)_"/"_$E(D,5,6)_"/"_Y_$E(D,1,2)) - ; -GETCLM(X) ; Extract the claim # without site id from the data in X - N IBCLM - S IBCLM=$P(X,"-",2) I IBCLM="",X'="" S IBCLM=$E(X,$S($L(X)>7:4,1:1),$L(X)) - Q IBCLM - ; +IBCE277 ;ALB/TMP - 277 EDI CLAIM STATUS MESSAGE PROCESSING ;15-JUL-98 + ;;2.0;INTEGRATED BILLING;**137,155**;21-MAR-94 + Q + ; MESSAGE HEADER DATA STRING = + ; type of message^msg queue^msg #^bill #^REF NUM/Batch #^date/time + ; +HDR(ENTITY,ENTVAL,IBTYPE,IBD) ;Process header data + ; INPUT: + ; ENTITY = "BATCH" if batch level message + ; "CLAIM" if claim level message + ; ENTVAL = batch # or claim # + ; IBTYPE = the type of status msg this piece of the message represents + ; (837REC1, 837REJ1) + ; ^TMP("IBMSGH",$J,0) = header message text + ; + ; OUTPUT: + ; IBD array returned with processed data + ; "LINE" = The last line # populated in the message + ; "DATE" = Date/Time of status (Fileman format) + ; "MRA" = 1 if MRA, 0 if not "X12" = 1 if X12, 0 if not + ; "BATCH" = Batch ien for batch level calls + ; "SOURCE" = Source of message code^source name, if known + ; + ; ^TMP("IBMSG",$J,"BATCH",batch #,0)=MESSAGE HEADER DATA STRING + ; if called from batch level + ; ,"D",0,1)=header record raw data + ; ,line #)=batch status message lines + ; + ; ^TMP("IBMSG",$J,"CLAIM",claim #,0)=MESSAGE HEADER DATA STRING + ; if called from claim level + ; ,"D",0,1)=header record raw data + ; ,line #)=claim status message lines + ; + N CT,CT1,IBBILL,IBD0,L,LINE,PC,Z,X,Y + S IBD0=$G(^TMP("IBMSGH",$J,0)),IBD("LINE")=0 + Q:IBD0="" + S Y=0,X=$$DATE($P(IBD0,U,3))_"@"_$E($P(IBD0,U,4)_"0000",1,4) + I X S %DT="XTS" D ^%DT + S IBD("DATE")=$S(Y>0:Y,1:"") + S IBD("MRA")=$P(IBD0,U,5),IBD("X12")=($P(IBD0,U,2)="X") + S IBD("SOURCE")=$P(IBD0,U,12,13) + S CT=0 + ; + I ENTITY="BATCH",ENTVAL'="" D ;Only pertinent for batch level extract + . S IBD("BATCH")=$O(^IBA(364.1,"B",ENTVAL,0)) + . F PC=6:1:9 D + .. I $P(IBD0,U,PC)'="" S DATA=$P("# Claims Submitted^# Claims Rejected^Total Charges Submitted^Total Charges Rejected",U,PC-5)_": "_$S(PC<8:+$P(IBD0,U,PC),1:$FNUMBER($P(IBD0,U,PC)/100,"",2))_" " + .. I CT,$L($G(LINE(CT)))+$L(DATA)>80 S CT=CT+1 + .. S:'CT CT=1 S LINE(CT)=$G(LINE(CT))_DATA + ; + I ENTVAL'="",$TR($P(IBD0,U,10,13),U)'="" S CT1=CT,CT=CT+1 F PC=10,11,12 D ;Both batch, claim levels extract + . Q:$P(IBD0,U,PC)="" + . I PC<12 S LINE(CT)=$G(LINE(CT))_$P("Payer Name^Payer ID",U,PC-9)_": "_$P(IBD0,U,PC)_" ",CT1=CT Q + . I $P(IBD0,U,12)'=""!($P(IBD0,U,13)'="") S:$P(IBD0,U,10)'=""!($P(IBD0,U,11)'="") CT=CT+1 S LINE(CT)="Source: "_$S($P(IBD0,U,12)="Y":"Sent by payer",$P(IBD0,U,13)'="":"Sent by non-payer ("_$P(IBD0,U,13)_")",1:"UNKNOWN")_" " + ; + I CT D + . S (L,Z)=0 + . F S Z=$O(LINE(Z)) Q:'Z S L=L+1,^TMP("IBMSG-H",$J,ENTITY,ENTVAL,L)=LINE(Z) + . ;S IBD("LINE")=$G(IBD("LINE"))+CT + ; + I ENTITY="CLAIM" D + . N Z0 + . S Z0=+$O(^DGCR(399,"B",ENTVAL,0)) + . I $G(IBD("BATCH")) S IBBILL=$O(^IBA(364,"ABABI",+$G(IBD("BATCH")),Z0,""),-1) Q + . S IBBILL=$$LAST364^IBCEF4(Z0) + S ^TMP("IBMSG",$J,ENTITY,ENTVAL,0)=IBTYPE_U_$G(IBD("MSG#"))_U_$G(IBD("SUBJ"))_U_$S(ENTITY="CLAIM":IBBILL,1:"")_U_$S(ENTITY="BATCH":ENTVAL,1:"")_U_IBD("DATE")_U_IBD("SOURCE") + ; + S ^TMP("IBMSG",$J,ENTITY,ENTVAL,"D",0,1)="##RAW DATA: "_IBD0 + Q + ; +5(IBD) ; Process batch status data + ; INPUT: + ; IBD must be passed by reference = entire message line + ; OUTPUT: + ; IBD array returned with processed data + ; "LINE" = The last line # populated in the message + ; + ; ^TMP("IBMSG",$J,"BATCH",batch #,line#)=batch status message lines + ; ,"D",5,msg seq #)= + ; batch status message raw data + ; + N CT,DATA,IBBTCH,IBTYPE,L,LINE,Z + K ^TMP("IBCONF",$J) + S IBBTCH=+$P(IBD,U,2) + S IBTYPE=$S($P(IBD,U,3)="R":"837REJ1",1:"837REC1") + I '$D(^TMP("IBMSG",$J,"BATCH",IBBTCH)) D HDR("BATCH",IBBTCH,IBTYPE,.IBD) ;Process header data if not already done for batch + S CT=0,LINE(1)="" + S DATA=$P(IBD,U,4) + I DATA'="",$TR($P(IBD,U,5,7),U)'="" D + . Q:$G(^TMP("IBMSG",$J,"BATCH",IBBTCH))=DATA + . S:'CT CT=CT+1 S LINE(CT)=$G(LINE(CT))_$S(DATA="W":"Warning",DATA="E":"Error",1:"Informational")_" " + S ^TMP("IBMSG",$J,"BATCH",IBBTCH)=DATA + I $P(IBD,U,5)'="" S:'CT CT=CT+1 S LINE(CT)=$G(LINE(CT))_"Code: "_$P(IBD,U,5) + I $P(IBD,U,6)'="" S:'CT CT=CT+1 S LINE(CT)=$G(LINE(CT))_" "_$P(IBD,U,6),CT=CT+1 + I $P(IBD,U,7)'="" S:'CT CT=CT+1 S LINE(CT)=$G(LINE(CT))_" "_$P(IBD,U,7) + I CT D + . S L=$G(IBD("LINE")),Z=0 + . F S Z=$O(LINE(Z)) Q:'Z S L=L+1,^TMP("IBMSG",$J,"BATCH",IBBTCH,L)=LINE(Z) + . S ^TMP("IBMSG",$J,"BATCH",IBBTCH,"D",5,$O(^TMP("IBMSG",$J,"BATCH",IBBTCH,"D",5,""),-1)+1)="##RAW DATA: "_IBD + . S IBD("LINE")=$G(IBD("LINE"))+CT + Q + ; +10(IBD) ; Process claim status data + ; INPUT: + ; IBD must be passed by reference = entire message line + ; OUTPUT: + ; IBD array returned with processed data + ; "CLAIM" = The claim # + ; "LINE" = The last line # populated in the message + ; + ; ^TMP("IBMSG",$J,"CLAIM",claim #,line#)=claim status message lines + ; ,"D",10,msg seq #)= + ; claim status raw data + ; ^TMP("IBCONF",$J,claim #")="" for invalid claims within the batch + ; + N CT,DATA,IBCLM,IBTYPE,L,LINE,Z + S IBCLM=$$GETCLM($P(IBD,U,2)) + Q:IBCLM="" + S:$P(IBD,U,3)="R" ^TMP("IBCONF",$J,+$O(^DGCR(399,"B",IBCLM,0)))="" + S IBTYPE=$S($P(IBD,U,3)="R":"837REJ1",1:"837REC1") + I '$D(^TMP("IBMSG",$J,"CLAIM",IBCLM)) D HDR("CLAIM",IBCLM,IBTYPE,.IBD) ;Process header data if not already done for claim + I IBTYPE="837REJ1",$P($G(^TMP("IBMSG",$J,"CLAIM",IBCLM,0)),U,1)'="837REJ1" D HDR("CLAIM",IBCLM,IBTYPE,.IBD) + S CT=0,DATA=$P(IBD,U,4) + I DATA'="",$TR($P(IBD,U,5,7),U)'="" D + . Q:$G(^TMP("IBMSG",$J,"CLAIM",IBCLM))=DATA + . S ^TMP("IBMSG",$J,"CLAIM",IBCLM)=DATA + . S CT=CT+1,LINE(CT)=$G(LINE(CT))_$S(DATA="W":"Warning",DATA="E":"Error",1:"Informational")_" " + I $P(IBD,U,5)'="" S CT=$S('CT:1,1:CT),LINE(CT)=$G(LINE(CT))_"Code: "_$P(IBD,U,5) + I $P(IBD,U,6)'="" S CT=$S('CT:1,1:CT),LINE(CT)=$G(LINE(CT))_" "_$P(IBD,U,6) + I $P(IBD,U,7)'="" S CT=CT+1,LINE(CT)=" "_$P(IBD,U,7) + I CT D + . S L=$G(IBD("LINE")),Z=0 + . F S Z=$O(LINE(Z)) Q:'Z S L=L+1,^TMP("IBMSG",$J,"CLAIM",IBCLM,L)=LINE(Z) + . S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",10,$O(^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",10,""),-1)+1)="##RAW DATA: "_IBD + . S IBD("LINE")=$G(IBD("LINE"))+CT + Q + ; +15(IBD) ; Process subscriber/patient data + ; Claim must have been referenced by a previous '10' level + ; INPUT: + ; IBD must be passed by reference = entire message line + ; + ; OUTPUT: + ; IBD("LINE") = The last line # populated in the message + ; + ; ^TMP("IBMSG",$J,"CLAIM",claim #,line#)=formatted service dates + ; ,"D",15,msg seq #)= + ; subscr/patient raw data + ; + N CT,Z,L,LINE,DATA,IBCLM,IBNM,IBNUM,IBDFN + S IBCLM=$$GETCLM($P(IBD,U,2)),CT=0,L=$G(IBD("LINE")) + Q:$S(IBCLM="":1,1:'$D(^TMP("IBMSG",$J,"CLAIM",IBCLM))) + S IBDFN=+$G(^DGCR(+$O(^DGCR(399,"B",IBCLM,0)),0)) + S IBNM=$S($P(IBD,U,3)'="":$P(IBD,U,3)_","_$P(IBD,U,4)_$S($P(IBD,U,5)'="":" "_$P(IBD,U,5),1:""),1:$P($G(^DPT(IBDFN,0)),U)) + S IBNUM=$S($P(IBD,U,6)'="":$P(IBD,U,6),1:$P($G(^DPT(IBDFN,0)),U,9)) + S CT=CT+1,LINE(CT)="Patient: "_IBNM_" "_IBNUM + I $P(IBD,U,11) D + . S DATA=$$DATE($P(IBD,U,11)),CT=CT+1 + . S LINE(CT)="Service Dates: "_DATA_" - "_$S($P(IBD,U,12):$$DATE($P(IBD,U,12)),1:DATA)_" " + . ; Add additional lines of display data here for record 15 + S Z=0 F S Z=$O(LINE(Z)) Q:'Z S L=L+1,^TMP("IBMSG",$J,"CLAIM",IBCLM,L)=LINE(Z) + S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",15,$O(^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",15,""),-1)+1)="##RAW DATA: "_IBD + S IBD("LINE")=$G(IBD("LINE"))+CT + Q + ; +20(IBD) ; Process service line status data + ; Claim must have been referenced by a previous '10' level + ; INPUT: + ; IBD must be passed by reference = entire message line + ; OUTPUT: + ; IBD array returned with processed data + ; "LINE" = The last line # populated in the message + ; "TYPE" = The msg type of status record (Confirmation/rejection) + ; Note: returned if not already set at batch or claim level + ; + ; ^TMP("IBMSG",$J,"CLAIM",claim #)="" + ; ,line#)=service line status msg lines + ; ,"D",20,msg seq #)= + ; service line status raw data + ; + N CT,DATA,L,LINE,Z,IBCLM,IBLNUM + S IBCLM=$$GETCLM($P(IBD,U,2)),IBLNUM=$P(IBD,U,8) + Q:'$D(^TMP("IBMSG",$J,"CLAIM",IBCLM)) + S CT=0 + I IBLNUM'="" S CT=CT+1,LINE(CT)="Claim Line: "_IBLNUM,^TMP("IBMSG",$J,"LINE",IBCLM,IBLNUM)="" + S DATA=$P(IBD,U,4) + I DATA'="",$TR($P(IBD,U,5,7),U)'="" S:'CT CT=CT+1 S LINE(CT)=$S(DATA="W":"Warning",DATA="E":"Error",1:"Informational")_" "_$G(LINE(CT)) + S:$G(IBD("TYPE"))="" IBD("TYPE")=$S(DATA="E":"837REJ1",1:"837REC1") + I $P(IBD,U,5)'="" S:'CT CT=CT+1 S LINE(CT)=LINE(CT)_$P(IBD,U,5) + I $P(IBD,U,6)'="" S CT=CT+1,LINE(CT)=" "_$P(IBD,U,6) + I $P(IBD,U,7)'="" S CT=CT+1,LINE(CT)=" "_$P(IBD,U,7) + I CT D + . S L=$G(IBD("LINE")),Z=0 + . F S Z=$O(LINE(Z)) Q:'Z S L=L+1,^TMP("IBMSG",$J,"CLAIM",IBCLM,L)=LINE(Z) + . S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",20,$O(^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",20,""),-1)+1)="##RAW DATA: "_IBD + . S IBD("LINE")=$G(IBD("LINE"))+CT + Q + ; +21(IBD) ; Process service line ID data + ; Moved for size too big + D 21^IBCE277A(IBD) + Q + ; +DATE(DT) ; Convert YYMMDD Date into MM/DD/YY or YYYYMMDD into MM/DD/YYYY + N D,Y + S D=DT,Y="" + I $L(DT)=8 S D=$E(DT,3,8),Y=$E(DT,1,2) + Q ($E(D,3,4)_"/"_$E(D,5,6)_"/"_Y_$E(D,1,2)) + ; +GETCLM(X) ; Extract the claim # without site id from the data in X + N IBCLM + S IBCLM=$P(X,"-",2) + I IBCLM="",X'="" S IBCLM=$E(X,$S($L(X)>7:4,1:1),$L(X)) + ;S IBCLM=$E(X,$L(IBCLM)-6,$L(IBCLM)) ; Only take last 7 char + Q IBCLM + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCE835.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCE835.m index c13749dd..9991cdce 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCE835.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCE835.m @@ -1,238 +1,231 @@ -IBCE835 ;ALB/TMP - 835 EDI EXPLANATION OF BENEFITS MSG PROCESSING ;19-JAN-99 - ;;2.0;INTEGRATED BILLING;**137,135,155,377**;21-MAR-94;Build 23 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - Q - ; - ; MESSAGE HEADER DATA STRING = - ; type of message^msg queue^msg #^bill #^^date/time - ; -HDR(IBCLNO,IBD) ;Process header data - ; INPUT: - ; IBCLNO = claim # - ; - ; ^TMP("IBMSGH",$J,0) = header message text - ; - ; OUTPUT: - ; IBD array returned with processed data - ; "LINE" = The last line # populated in the message - ; "DATE" = Date/Time of EOB (Fileman format) - ; "MRA" = 1 if MRA, 0 if not - ; "X12" = 1 if X12, 0 if not - ; - ; ^TMP("IBMSG",$J,"CLAIM",claim #,0)=MESSAGE HEADER DATA STRING - ; ,"D",0,1)=header record raw data - ; ,"D1",1,0)=header record raw data - ; ,line #)=EOB message lines - ; - N CT,IB399,IBD0,IBBILL,LINE,L,X,Y,Z,%DT - S IBD0=$G(^TMP("IBMSGH",$J,0)),IBD("LINE")=0 - Q:IBD0="" - S X=$P(IBD0,U,3),X=$E(X,5,8)_$E(X,1,4)_"@"_$P(IBD0,U,4) - I X S %DT="XTS" D ^%DT - S IBD("DATE")=$S(Y>0:Y,1:"") - S IBD("MRA")=$P(IBD0,U,5) - S IBD("X12")=($P(IBD0,U,2)="X") - S CT=0 - ; - I $P(IBD0,U,6)'="" S CT=CT+1 S LINE(CT)=$G(LINE(CT))_"Payer Name: "_$P(IBD0,U,6) - ; - I CT D - . S (L,Z)=0 - . F S Z=$O(LINE(Z)) Q:'Z S L=L+1,^TMP("IBMSG",$J,"CLAIM",IBCLNO,L)=LINE(Z) - . S IBD("LINE")=IBD("LINE")+CT - ; - S IB399=+$O(^DGCR(399,"B",$$GETCLM^IBCE277(IBCLNO),""),-1) - ; - S IBBILL=$$LAST364^IBCEF4(IB399) - ; - S ^TMP("IBMSG",$J,"CLAIM",IBCLNO,0)="835EOB"_U_$G(IBD("MSG#"))_U_$G(IBD("SUBJ"))_U_IBBILL_U_U_IBD("DATE") - ; - S ^TMP("IBMSG",$J,"CLAIM",IBCLNO,"D",0,1)="##RAW DATA: "_IBD0 - S ^TMP("IBMSG",$J,"CLAIM",IBCLNO,"D1",1,0)="##RAW DATA: "_IBD0 - Q - ; -5(IBD) ; Process claim patient ID data - ; INPUT: - ; IBD must be passed by reference = entire message line - ; - ; OUTPUT: - ; IBD array - ; "LINE" = the last line # populated in the message - ; - ; ^TMP("IBMSG",$J,"CLAIM",claim #,line#)=claim pt id message lines - ; ,"D",5,msg seq #)= - ; ,"D1",msg seq #,5)= - ; claim pt id message raw data - ; - N IBBILL - S IBBILL=$$GETCLM^IBCE277($P(IBD,U,2)) - ; - I '$D(^TMP("IBMSG",$J,"CLAIM",IBBILL)) D HDR(IBBILL,.IBD) ;Process header data if not already done for claim - ; - I $P(IBD,U,9) D ;Statement dates - . S IBD("LINE")=$G(IBD("LINE"))+1 - . S ^TMP("IBMSG",$J,"CLAIM",IBBILL,IBD("LINE"))="Statement Dates: "_$$DATE^IBCE277($P(IBD,U,9))_" - "_$$DATE^IBCE277($P(IBD,U,10)) - ; - S ^TMP("IBMSG",$J,"CLAIM",IBBILL,"D",5,1)="##RAW DATA: "_IBD - S ^TMP("IBMSG",$J,"CLAIM",IBBILL,"D1",1,5)="##RAW DATA: "_IBD - Q - ; -6(IBD) ; Process 06 record type for corrected name and/or ID# - IB*2*377 - 1/14/08 - NEW IBCLM,Z - S IBCLM=$$GETCLM^IBCE277($P(IBD,U,2)) - Q:IBCLM="" - I '$D(^TMP("IBMSG",$J,"CLAIM",IBCLM)) D HDR(IBCLM,.IBD) ;Process header data if not already done for claim - ; - S Z=$G(IBD("LINE")) - I $P(IBD,U,3)'="" S Z=Z+1,^TMP("IBMSG",$J,"CLAIM",IBCLM,Z)="Corrected Patient Last Name: "_$P(IBD,U,3) - I $P(IBD,U,4)'="" S Z=Z+1,^TMP("IBMSG",$J,"CLAIM",IBCLM,Z)="Corrected Patient First Name: "_$P(IBD,U,4) - I $P(IBD,U,5)'="" S Z=Z+1,^TMP("IBMSG",$J,"CLAIM",IBCLM,Z)="Corrected Patient Middle Name: "_$P(IBD,U,5) - I $P(IBD,U,6)'="" S Z=Z+1,^TMP("IBMSG",$J,"CLAIM",IBCLM,Z)="Corrected Patient ID#: "_$P(IBD,U,6) - S IBD("LINE")=Z - ; - S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",6,1)="##RAW DATA: "_IBD - S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D1",1,6)="##RAW DATA: "_IBD - Q - ; -10(IBD) ; Process claim status data - ; INPUT: - ; IBD must be passed by reference = entire message line - ; - ; OUTPUT: - ; IBD array returned with processed data - ; "CLAIM" = The claim # - ; "LINE" = The last line # populated in the message - ; - ; ^TMP("IBMSG",$J,"CLAIM",claim #,line#)=claim status message lines - ; ,"D",10,msg seq #)= - ; ,"D1",msg seq #,10)= - ; claim status raw data - ; - N IBCLM,CT,LINE,L,Z,Z0,IBDATA,IBSTAT - S IBCLM=$$GETCLM^IBCE277($P(IBD,U,2)) - Q:IBCLM="" - ; - I '$D(^TMP("IBMSG",$J,"CLAIM",IBCLM)) D HDR(IBCLM,.IBD) ;Process header data if not already done for claim - ; - S CT=0 - F Z=3:1:6 I $P(IBD,U,Z)="Y" D Q ;Claim status - . S IBSTAT=(Z-2) - . S CT=CT+1,LINE(CT)="CLAIM STATUS: "_$P("PROCESSED^DENIED^PENDED^REVERSAL",U,IBSTAT) - I '$G(IBSTAT) D - . S CT=CT+1,LINE(CT)="CLAIM STATUS: "_$P(IBD,U,7)_" (OTHER)" - ; - I $P(IBD,U,8)'="" D ;Crossed over info - . S LINE(CT)=LINE(CT)_" Crossed over to: "_$P(IBD,U,9)_" "_$P(IBD,U,8) - ; - I CT D - . S L=$G(IBD("LINE")),Z=0 - . F S Z=$O(LINE(Z)) Q:'Z S L=L+1,^TMP("IBMSG",$J,"CLAIM",IBCLM,L)=LINE(Z) - . S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",10,1)="##RAW DATA: "_IBD - . S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D1",1,10)="##RAW DATA: "_IBD - . S IBD("LINE")=$G(IBD("LINE"))+CT - Q - ; -15(IBD) ; Process claim status data - ; INPUT: - ; IBD must be passed by reference = entire message line - ; - ; OUTPUT: - ; IBD array - ; "LINE" = The last line # populated in the message - ; - ; ^TMP("IBMSG",$J,"CLAIM",claim #,"D",15,msg seq #)= - ; ^TMP("IBMSG",$J,"CLAIM",claim #,"D1",msg seq #,15)= - ; claim status raw data - ; - N IBCLM,Z,Z0,IBDATA - S IBCLM=$$GETCLM^IBCE277($P(IBD,U,2)) - Q:IBCLM="" - ; - I '$D(^TMP("IBMSG",$J,"CLAIM",IBCLM)) D HDR(IBCLM,.IBD) ;Process header data if not already done for claim - ; - S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",15,1)="##RAW DATA: "_IBD - S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D1",1,15)="##RAW DATA: "_IBD - Q - ; -20(IBD) ; Process claim level adjustment data - ; Claim must have been referenced by a previous '05' level - ; - ; INPUT: - ; IBD must be passed by reference = entire message line - ; - ; OUTPUT: - ; IBD("LINE") = The last line # populated in the message - ; ^TMP("IBMSG",$J,"CLAIM",claim #,line #)=claim level adjustment - ; ,"D",20,seq#)= - ; ,"D1",seq#,20)= - ; claim level adjust. raw data - ; - N IBCLM - S IBCLM=$$GETCLM^IBCE277($P(IBD,U,2)) - Q:'$D(^TMP("IBMSG",$J,"CLAIM",IBCLM)) - S IBD("LINE")=$G(IBD("LINE"))+1 - S ^TMP("IBMSG",$J,"CLAIM",IBCLM,IBD("LINE"))="ADJUSTMENT GROUP: "_$P(IBD,U,3)_" QTY: "_+$P(IBD,U,6)_", AMT: "_($P(IBD,U,5)/100) - S IBD("LINE")=IBD("LINE")+1 - S ^TMP("IBMSG",$J,"CLAIM",IBCLM,IBD("LINE"))=" REASON: ("_$P(IBD,U,4)_") "_$P(IBD,U,7) - S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",20,IBD("LINE"))="##RAW DATA: "_IBD - S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D1",IBD("LINE"),20)="##RAW DATA: "_IBD - Q - ; -37(IBD) ; Process claim level adjustment data for Inpatient MEDICARE - D 37^IBCE835A(.IBD) - Q - ; -40(IBD) ; Process service line data - D 40^IBCE835A(.IBD) - Q - ; -45(IBD) ; Process service line adjustment data - D 45^IBCE835A(.IBD) - Q - ; -17(IBD) ; Process claim contact data segment - D XX(.IBD,17) - Q - ; -30(IBD) ; Process MEDICARE inpatient adjudication data (part 1) - D XX(.IBD,30) - Q - ; -35(IBD) ; Process MEDICARE inpatient adjudication data (part 2) - D XX(.IBD,35) - Q - ; -41(IBD) ; Process service line data (part 2) - D XX(.IBD,41) - Q - ; -42(IBD) ; Process service line data (part 3) - D XX(.IBD,42) - Q - ; -99(IBD) ; Process trailer record for non-MRA EOB - D XX(.IBD,99) - Q - ; -XX(IBD,IBID) ; Store non-displayed data nodes in TMP array - ; - ; INPUT: - ; IBD must be passed by reference = entire message line - ; IBID = record id for generic store - ; - ; OUTPUT: - ; ^TMP("IBMSG",$J,"CLAIM",claim #,"D",IBID,msg seq #)= - ; ^TMP("IBMSG",$J,"CLAIM",claim #,"D1",msg seq #,IBID)= - ; claim status raw data - ; IBD("LINE") = The last line # populated in the message - ; - N IBCLM - S IBCLM=$$GETCLM^IBCE277($P(IBD,U,2)) - ; - S IBD("LINE")=$G(IBD("LINE"))+1 - S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",IBID,IBD("LINE"))="##RAW DATA: "_IBD - S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D1",IBD("LINE"),IBID)="##RAW DATA: "_IBD - ; - Q - ; +IBCE835 ;ALB/TMP - 835 EDI EXPLANATION OF BENEFITS MSG PROCESSING ;19-JAN-99 + ;;2.0;INTEGRATED BILLING;**137,135,155**;21-MAR-94 + Q + ; + ; MESSAGE HEADER DATA STRING = + ; type of message^msg queue^msg #^bill #^^date/time + ; +HDR(IBCLNO,IBD) ;Process header data + ; INPUT: + ; IBCLNO = claim # + ; + ; ^TMP("IBMSGH",$J,0) = header message text + ; + ; OUTPUT: + ; IBD array returned with processed data + ; "LINE" = The last line # populated in the message + ; "DATE" = Date/Time of EOB (Fileman format) + ; "MRA" = 1 if MRA, 0 if not + ; "X12" = 1 if X12, 0 if not + ; + ; ^TMP("IBMSG",$J,"CLAIM",claim #,0)=MESSAGE HEADER DATA STRING + ; ,"D",0,1)=header record raw data + ; ,"D1",1,0)=header record raw data + ; ,line #)=EOB message lines + ; + N CT,IB399,IBD0,IBBILL,LINE,L,X,Y,Z,%DT + S IBD0=$G(^TMP("IBMSGH",$J,0)),IBD("LINE")=0 + Q:IBD0="" + S X=$P(IBD0,U,3),X=$E(X,5,8)_$E(X,1,4)_"@"_$P(IBD0,U,4) + I X S %DT="XTS" D ^%DT + S IBD("DATE")=$S(Y>0:Y,1:"") + S IBD("MRA")=$P(IBD0,U,5) + S IBD("X12")=($P(IBD0,U,2)="X") + S CT=0 + ; + I $P(IBD0,U,6)'="" S CT=CT+1 S LINE(CT)=$G(LINE(CT))_"Payer Name: "_$P(IBD0,U,6) + ; + I CT D + . S (L,Z)=0 + . F S Z=$O(LINE(Z)) Q:'Z S L=L+1,^TMP("IBMSG",$J,"CLAIM",IBCLNO,L)=LINE(Z) + . S IBD("LINE")=IBD("LINE")+CT + ; + S IB399=+$O(^DGCR(399,"B",$$GETCLM^IBCE277(IBCLNO),""),-1) + ; + S IBBILL=$$LAST364^IBCEF4(IB399) + ; + S ^TMP("IBMSG",$J,"CLAIM",IBCLNO,0)="835EOB"_U_$G(IBD("MSG#"))_U_$G(IBD("SUBJ"))_U_IBBILL_U_U_IBD("DATE") + ; + S ^TMP("IBMSG",$J,"CLAIM",IBCLNO,"D",0,1)="##RAW DATA: "_IBD0 + S ^TMP("IBMSG",$J,"CLAIM",IBCLNO,"D1",1,0)="##RAW DATA: "_IBD0 + Q + ; +5(IBD) ; Process claim patient ID data + ; INPUT: + ; IBD must be passed by reference = entire message line + ; + ; OUTPUT: + ; IBD array + ; "LINE" = the last line # populated in the message + ; + ; ^TMP("IBMSG",$J,"CLAIM",claim #,line#)=claim pt id message lines + ; ,"D",5,msg seq #)= + ; ,"D1",msg seq #,5)= + ; claim pt id message raw data + ; + N IBBILL + S IBBILL=$$GETCLM^IBCE277($P(IBD,U,2)) + ; + I '$D(^TMP("IBMSG",$J,"CLAIM",IBBILL)) D HDR(IBBILL,.IBD) ;Process header data if not already done for claim + ; + I $P(IBD,U,7)="Y"!($P(IBD,U,8)="Y") D ;New patient name or id reported + . ; + . ; Alert to EDI mail group that name or ID has changed + . N XQA,XQAMSG + . S XQA("G.IB EDI")="" + . S XQAMSG="EOB for bill # "_IBBILL_" indicates a new name or id exists for patient" + . D SETUP^XQALERT + . ; + . S IBD("LINE")=$G(IBD("LINE"))+1 + . I $P(IBD,U,7)="Y" S ^TMP("IBMSG",$J,"CLAIM",IBBILL,IBD("LINE"))="New patient name: "_$P(IBD,U,3)_","_$P(IBD,U,4)_" "_$P(IBD,U,5)_" " + . I $P(IBD,U,8)="Y" S ^TMP("IBMSG",$J,"CLAIM",IBBILL,IBD("LINE"))=$G(^TMP("IBMSG",$J,"CLAIM",IBBILL,IBD("LINE")))_"New patient id: "_$P(IBD,U,6) + ; + I $P(IBD,U,9) D ;Statement dates + . S IBD("LINE")=$G(IBD("LINE"))+1 + . S ^TMP("IBMSG",$J,"CLAIM",IBBILL,IBD("LINE"))="Statement Dates: "_$$DATE^IBCE277($P(IBD,U,9))_" - "_$$DATE^IBCE277($P(IBD,U,10)) + ; + S ^TMP("IBMSG",$J,"CLAIM",IBBILL,"D",5,1)="##RAW DATA: "_IBD + S ^TMP("IBMSG",$J,"CLAIM",IBBILL,"D1",1,5)="##RAW DATA: "_IBD + Q + ; +10(IBD) ; Process claim status data + ; INPUT: + ; IBD must be passed by reference = entire message line + ; + ; OUTPUT: + ; IBD array returned with processed data + ; "CLAIM" = The claim # + ; "LINE" = The last line # populated in the message + ; + ; ^TMP("IBMSG",$J,"CLAIM",claim #,line#)=claim status message lines + ; ,"D",10,msg seq #)= + ; ,"D1",msg seq #,10)= + ; claim status raw data + ; + N IBCLM,CT,LINE,L,Z,Z0,IBDATA,IBSTAT + S IBCLM=$$GETCLM^IBCE277($P(IBD,U,2)) + Q:IBCLM="" + ; + I '$D(^TMP("IBMSG",$J,"CLAIM",IBCLM)) D HDR(IBCLM,.IBD) ;Process header data if not already done for claim + ; + S CT=0 + F Z=3:1:6 I $P(IBD,U,Z)="Y" D Q ;Claim status + . S IBSTAT=(Z-2) + . S CT=CT+1,LINE(CT)="CLAIM STATUS: "_$P("PROCESSED^DENIED^PENDED^REVERSAL",U,IBSTAT) + I '$G(IBSTAT) D + . S CT=CT+1,LINE(CT)="CLAIM STATUS: "_$P(IBD,U,7)_" (OTHER)" + ; + I $P(IBD,U,8)'="" D ;Crossed over info + . S LINE(CT)=LINE(CT)_" Crossed over to: "_$P(IBD,U,9)_" "_$P(IBD,U,8) + ; + I CT D + . S L=$G(IBD("LINE")),Z=0 + . F S Z=$O(LINE(Z)) Q:'Z S L=L+1,^TMP("IBMSG",$J,"CLAIM",IBCLM,L)=LINE(Z) + . S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",10,1)="##RAW DATA: "_IBD + . S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D1",1,10)="##RAW DATA: "_IBD + . S IBD("LINE")=$G(IBD("LINE"))+CT + Q + ; +15(IBD) ; Process claim status data + ; INPUT: + ; IBD must be passed by reference = entire message line + ; + ; OUTPUT: + ; IBD array + ; "LINE" = The last line # populated in the message + ; + ; ^TMP("IBMSG",$J,"CLAIM",claim #,"D",15,msg seq #)= + ; ^TMP("IBMSG",$J,"CLAIM",claim #,"D1",msg seq #,15)= + ; claim status raw data + ; + N IBCLM,Z,Z0,IBDATA + S IBCLM=$$GETCLM^IBCE277($P(IBD,U,2)) + Q:IBCLM="" + ; + I '$D(^TMP("IBMSG",$J,"CLAIM",IBCLM)) D HDR(IBCLM,.IBD) ;Process header data if not already done for claim + ; + S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",15,1)="##RAW DATA: "_IBD + S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D1",1,15)="##RAW DATA: "_IBD + Q + ; +20(IBD) ; Process claim level adjustment data + ; Claim must have been referenced by a previous '05' level + ; + ; INPUT: + ; IBD must be passed by reference = entire message line + ; + ; OUTPUT: + ; IBD("LINE") = The last line # populated in the message + ; ^TMP("IBMSG",$J,"CLAIM",claim #,line #)=claim level adjustment + ; ,"D",20,seq#)= + ; ,"D1",seq#,20)= + ; claim level adjust. raw data + ; + N IBCLM + S IBCLM=$$GETCLM^IBCE277($P(IBD,U,2)) + Q:'$D(^TMP("IBMSG",$J,"CLAIM",IBCLM)) + S IBD("LINE")=$G(IBD("LINE"))+1 + S ^TMP("IBMSG",$J,"CLAIM",IBCLM,IBD("LINE"))="ADJUSTMENT GROUP: "_$P(IBD,U,3)_" QTY: "_+$P(IBD,U,6)_", AMT: "_($P(IBD,U,5)/100) + S IBD("LINE")=IBD("LINE")+1 + S ^TMP("IBMSG",$J,"CLAIM",IBCLM,IBD("LINE"))=" REASON: ("_$P(IBD,U,4)_") "_$P(IBD,U,7) + S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",20,IBD("LINE"))="##RAW DATA: "_IBD + S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D1",IBD("LINE"),20)="##RAW DATA: "_IBD + Q + ; +37(IBD) ; Process claim level adjustment data for Inpatient MEDICARE + D 37^IBCE835A(.IBD) + Q + ; +40(IBD) ; Process service line data + D 40^IBCE835A(.IBD) + Q + ; +45(IBD) ; Process service line adjustment data + D 45^IBCE835A(.IBD) + Q + ; +17(IBD) ; Process claim contact data segment + D XX(.IBD,17) + Q + ; +30(IBD) ; Process MEDICARE inpatient adjudication data (part 1) + D XX(.IBD,30) + Q + ; +35(IBD) ; Process MEDICARE inpatient adjudication data (part 2) + D XX(.IBD,35) + Q + ; +41(IBD) ; Process service line data (part 2) + D XX(.IBD,41) + Q + ; +42(IBD) ; Process service line data (part 3) + D XX(.IBD,42) + Q + ; +99(IBD) ; Process trailer record for non-MRA EOB + D XX(.IBD,99) + Q + ; +XX(IBD,IBID) ; Store non-displayed data nodes in TMP array + ; + ; INPUT: + ; IBD must be passed by reference = entire message line + ; IBID = record id for generic store + ; + ; OUTPUT: + ; ^TMP("IBMSG",$J,"CLAIM",claim #,"D",IBID,msg seq #)= + ; ^TMP("IBMSG",$J,"CLAIM",claim #,"D1",msg seq #,IBID)= + ; claim status raw data + ; IBD("LINE") = The last line # populated in the message + ; + N IBCLM + S IBCLM=$$GETCLM^IBCE277($P(IBD,U,2)) + ; + S IBD("LINE")=$G(IBD("LINE"))+1 + S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",IBID,IBD("LINE"))="##RAW DATA: "_IBD + S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D1",IBD("LINE"),IBID)="##RAW DATA: "_IBD + ; + Q + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCE837A.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCE837A.m index 3a33e3a2..1a448833 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCE837A.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCE837A.m @@ -1,189 +1,177 @@ -IBCE837A ;ALB/TMP - OUTPUT FOR 837 TRANSMISSION - CONTINUED ;8/6/03 10:50am - ;;2.0;INTEGRATED BILLING;**137,191,211,232,296,377**;21-MAR-94;Build 23 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -UPD(MSGNUM,BATCH,CNT,BILLS,DESC,IBBTYP,IBINS) ; Upd current batch + bills w/new status - ;MSGNUM = mail msg # for batch - ;BATCH = batch # - ;CNT = # of bills in batch - ;BILLS = array BILLS(bill ien in 364) in batch - ;DESC = 1-80 character description of batch - ;IBBTYP = X-Y where X = P for professional or I for institution - ; Y = 1 for test or 0 for live transmission - ; or 2 for live claim resubmitted as test - ;IBINS = ien of single insurance company for the batch (optional) - ; - N DIC,DIE,DR,DA,IBBATCH,IBIFN,IBIEN,IBYY,IBTXTEST,IBMRA - S IBBATCH=$O(^IBA(364.1,"B",+BATCH,"")) Q:'IBBATCH - S IBTXTEST=+$P(IBBTYP,"-",2) - I '$P($G(^IBE(350.9,1,8)),U,7) S IBINS="" - ; - S DIE="^IBA(364.1,",DA=IBBATCH,DR=".02////P;.03///"_CNT_";.04///"_MSGNUM_";.05///0;.07////1;.08///^S X="""_DESC_""""_$S($G(IBINS):";.12////"_IBINS,1:"") - ; - I '$P($G(^TMP("IBRESUBMIT",$J)),U,3) S DR=DR_";1.01///NOW;1.02///.5" - I $P($G(^TMP("IBRESUBMIT",$J)),U,2) S DR=DR_";.15////"_$P(^($J),U,2) - ; - S DR=DR_";.14////"_$S('IBTXTEST:0,1:1)_";.06////"_$S($E(IBBTYP)="P":2,1:3) D ^DIE ; Update batch - ; - I IBTXTEST=2 D ADDTXM^IBCEPTM(.BILLS,IBBATCH,$$NOW^XLFDT()) Q - I IBTXTEST'=2 S IBIEN=0 F S IBIEN=$O(BILLS(IBIEN)) Q:'IBIEN D ;Update each bill - .S DA=IBIEN,DIE="^IBA(364,",DR=".02////"_IBBATCH_";.03///P;.04///NOW" D ^DIE - .S IBIFN=+$G(^IBA(364,IBIEN,0)) - . ; - . ; If this claim has just been retransmitted, set the .06 field for the previous transmission entry - . N PRVTXI,PRVTXD - . S PRVTXI=$O(^IBA(364,"B",IBIFN,IBIEN),-1) ; previous transmission for this claim - . I PRVTXI D - .. S PRVTXD=$G(^IBA(364,PRVTXI,0)) - .. I '$F(".R.E.","."_$P(PRVTXD,U,3)_".") Q ; prev trans must have status of "R" or "E" - .. I $P(PRVTXD,U,7,8)'=$P($G(^IBA(364,IBIEN,0)),U,7,8) Q ; test bill and COB must be the same - .. S DA=PRVTXI,DIE=364,DR=".06///"_IBBATCH D ^DIE ; update the resubmit batch number - .. Q - . ; - .Q:$D(^TMP("IBRESUBMIT",$J))!($P($G(^DGCR(399,IBIFN,0)),U,13)=4)!(+$$TXMT^IBCEF4(IBIEN)=2) - .S IBMRA=$$NEEDMRA^IBEFUNC(IBIFN) - .I IBMRA="C",$P($G(^DGCR(399,IBIFN,0)),U,13)=2 S IBMRA=1 - .I IBIFN D - ..S (DIC,DIE)="^DGCR(399,",DA=$P($G(^IBA(364,IBIEN,0)),U),DR="[IB STATUS]",IBYY=$S('IBMRA:"@91",1:"@911") D:DA ^DIE - ..D BSTAT^IBCDC(IBIFN) ; remove from AB list - Q - ; -PRE ; Run before processing a bill entry - K IBXSAVE,IBXERR,^UTILITY("VAPA",$J),^TMP("IBXSAVE",$J),^TMP($J),^TMP("DIERR",$J) - Q - ; -POST ; Run after processing a bill entry for cleanup - N Q - I $G(IBXERR)'="" D - .S ^TMP("IBXERR",$J,IBXIEN)=IBXERR K ^TMP("IBXDATA",$J) - .K ^TMP("IBHDR1",$J) - .I $D(^TMP("IBRESUBMIT",$J)),'$G(^TMP("IBEDI_TEST_BATCH",$J)) D ;Set not resub flag for non-test bill - ..N Z,Z0 - ..S Z0=$P($G(^TMP("IBRESUBMIT",$J)),U) Q:Z0="" - ..S Z=$O(^IBA(364,"ABABI",+$O(^IBA(364.1,"B",Z0,"")),IBXIEN,"")) - ..I Z S ^TMP("IBNOT",$J,Z)=IBXIEN - K IBXSAVE,IBXNOREQ,^TMP("IBXSAVE",$J),^TMP($J) - S Q="VA" F S Q=$O(^UTILITY(Q)) Q:$E(Q,1,2)'="VA" I $D(^(Q,$J)) K ^UTILITY(Q,$J) - D CLEAN^DILF - Q - ; -MAILIT(IBQUEUE,IBBILL,IBCTM,IBDUZ,IBDESC,IBBTYP,IBINS) ; Send mail msg, update bills - ;IBQUEUE = mail queue name to send 837 transactions to - ;IBBILL = array of ien's in file 364 of bills in batch - IBBILL(IEN)="" - ;IBCTM = # of bills in batch, returned reset to 0 - ;IBDUZ = ien of user 'running' extract (if any) - ;IBDESC = description of batch - ;IBBTYP = X-Y where X = P for professional or I for institution - ; Y = 1 or 2 for test or 0 for live transmission - ;IBINS = ien of insurance company if only one/batch option (optional) - ; - N DIK,DA,XMTO,XMZ,XMBODY,XMDUZ,XMSUBJ,IBBDA,IBBNO - ; - S IBBNO=+$P($G(^TMP("IBHDR",$J)),U),IBBDA=$O(^IBA(364.1,"B",IBBNO,"")) - I '$P($G(^IBE(350.9,1,8)),U,7) S IBINS="" - ; - I IBCTM D - . I +$G(^TMP("IBEDI_TEST_BATCH",$J)) S IBQUEUE="MCT" - . I IBQUEUE'="",IBQUEUE'["@" S XMTO("XXX@Q-"_IBQUEUE_".VA.GOV")="" - . I IBQUEUE["@" S XMTO(IBQUEUE)="" - . S XMDUZ=$G(IBDUZ),XMBODY="^TMP(""IBXMSG"","_$J_")",XMSUBJ=$S($P(IBBTYP,U,2):"** TEST"_$S($P(IBBTYP,U,2)=2:"/RESUB OF LIVE",1:""),1:"")_" CLAIM BATCH: "_$S(IBQUEUE'["@":IBQUEUE,1:$P(IBQUEUE,"@"))_"/"_IBBNO - . K XMZ - . D SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO,,.XMZ) - . I $G(XMZ) D - .. D UPD(XMZ,$P($G(^TMP("IBHDR",$J)),U),IBCTM,.IBBILL,IBDESC,IBBTYP,IBINS) ;Update batch/bills - .. S ^TMP("IBCE-BATCH",$J,IBBNO)=IBBDA_U_IBCTM_U_$P($G(^TMP("IBRESUBMIT",$J)),U) -MAILQ S IBCTM=0 - D CHKBTCH(+$G(^TMP("IBHDR",$J))) - K ^TMP("IBHDR",$J),^TMP("IBHDR1",$J),^TMP("IBXMSG",$J),IBBILL - Q - ; -CHKNEW(IBQ,IBBILL,IBCTM,IBDESC,IBBTYP,IBINS,IBSITE,IBSIZE) ; - ; Determine if ok to send msg - ; Check for one insurance per batch if IBINS defined - ; Returns IBSIZE, IBCTM, IBBILL (pass by reference) - ; - ; IBQ = data queue name - ; IBBILL = the 'list' of bill #'s in the batch - ; IBCTM = the # of claims output so far to the batch - ; IBDESC = the batch description text - ; IBBTYP = X-Y where X = P for professional or I for institution - ; Y = 1 for test or 0 for live transmission - ; IBINS = the ien of the single insurance co. for the batch (optional) - ; IBSITE = the '8' node of file 350.9 (IB PARAMETERS) - ; IBSIZE = the 'running' size of the output message - ; - Q:$S($G(IBINS)="":0,1:'$P(IBSITE,U,7)) - ; - ; New batch needed - I IBCTM D MAILIT(IBQ,.IBBILL,.IBCTM,"",IBDESC,IBBTYP,IBINS) S IBSIZE=0 - Q - ; -ERRMSG(XMBODY) ; Send bulletin for error message - N XMTO,XMSUBJ - S XMTO("I:G.IB EDI")="",XMSUBJ="EDI 837 TRANSMISSION ERRORS" - ; - D SENDMSG^XMXAPI(,XMSUBJ,XMBODY,.XMTO) - D ALERT("One or more EDI bills were not transmitted. Check your mail for details","G.IB EDI") - Q - ; -CLEANUP ; Cleans up bill transmission environment - ; - N IBTEST - S IBTEST=+$G(^TMP("IBEDI_TEST_BATCH",$J)) - L -^IBA(364,0) - I $D(^TMP("IBRESUBMIT",$J,"IBXERR"))!$D(^TMP("IBONE",$J,"IBXERR"))!$D(^TMP("IBSELX",$J,"IBXERR")) D ;Error message to mail group - . N XMTO,XMBODY,XMDUZ,XMSUBJ,XMZ,IBFUNC - . S IBFUNC=$S($D(^TMP("IBRESUBMIT",$J,"IBXERR")):$S('IBTEST:1,1:4),$D(^TMP("IBONE",$J,"IBXERR")):2,1:3) - . Q:'IBFUNC - . S XMTO("I:G.IB EDI")="",XMDUZ="",XMBODY="^TMP("""_$S(IBFUNC=1!(IBFUNC=4):"IBRESUBMIT",1:"IBONE")_""","_$J_",""IBXERR"")" - . S XMSUBJ="EDI 837 B"_$P("ATCH^ILL^ILL(s)^ILL(s)",U,IBFUNC)_" NOT "_$S($G(^TMP("IBONE",$J)):"RE",1:"")_"SUBMITTED"_$S('IBTEST:"",1:" AS TEST CLAIMS") - . D SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO,,.XMZ) - . K ^TMP("IBRESUBMIT",$J),^TMP("IBONE",$J) - ; - I $D(^TMP("IBRESUBMIT",$J)),'IBTEST D RESUBUP^IBCEM02 ;Upd resubmtd batch bills - I '$D(^TMP("IBSELX",$J)) K ^TMP("IBCE-BATCH",$J) - K ^TMP("IBXERR",$J),IBXERR - I 'IBTEST D CHKBTCH(+$G(^TMP("IBHDR",$J))) -CLEANP ; Entrypoint for extract data disply - K ^TMP("IBTXMT",$J),^TMP("IBXINS",$J) - K ^TMP("IBRESUBMIT",$J),^TMP("IBRESUB",$J),^TMP("IBNOT",$J),^TMP("IBONE",$J),^TMP("IBHDR",$J),^TMP("IBTX",$J),^TMP("IBEDI_TEST_BATCH",$J) - K ^UTILITY("VADM",$J) - D CLEAN^DILF - K ZTREQ S ZTREQ="@" - Q - ; -ALERT(XQAMSG,IBGRP) ; Send alert message - N XQA - S XQA(IBGRP)="" - D SETUP^XQALERT - Q -CHKBTCH(IBBNO) ; Delete batch whose batch # is IBBNO if no entries in file 364 - ; and not a resubmitted batch - N IBZ,DA,DIK - S IBZ=+$O(^IBA(364.1,"B",+IBBNO,"")) - I IBZ,'$O(^IBA(364,"C",IBZ,0)),'$P($G(^IBA(364.1,IBZ,0)),U,14) S DA=IBZ,DIK="^IBA(364.1," D ^DIK - Q - ; -TESTLIM(IBINS) ; Check for test bill limit per day has been reached - N IB3,DA,DIK - S IB3=$G(^DIC(36,IBINS,3)) - I $P(IB3,U,5)'=DT S $P(IB3,U,7)=0 - I ($P(IB3,U,7)+$G(^TMP("IBICT",$J,IBINS))+1)>$P(IB3,U,6) D Q - . S IBINS="" ;max # hit - . S DA=IBX,DIK="^IBA(364," D ^DIK - S ^TMP("IBICT",$J,IBINS)=$G(^TMP("IBICT",$J,IBINS))+1 - Q - ; -SETVAR(IBXIEN,IBINS,IB0,IBSEC,IBNID,IB837R,IBDIV) ; - ; Set up variables needed for subscripts in sort global - ; ejk added IBSEC logic for patch 296 - ; IBSEC=1 if primary bill, 2 if 2nd/non-MRA, 3 if 2nd/MRA - S IBSEC=$S($$COBN^IBCEF(IBXIEN)=1:1,'$$MRASEC^IBCEF4(IBXIEN):2,1:3) - S IBNID=$$PAYERID^IBCEF2(IBXIEN) - S IB837R=$$RECVR^IBCEF2(IBXIEN) - S IBDIV=$P($S($P(IB0,U,22):$$SITE^VASITE(DT,$P(IB0,U,22)),1:$$SITE^VASITE()),U,3) - I IBNID'="","RPIHS"[$E(IBNID),$E(IBNID,2,$L(IBNID))="PRNT" S IBNID=IBNID_"*"_IBINS - I IBNID="" S IBNID="*"_IBINS - S $P(IBNID,"*",3)=$S($P(IB0,U,22):$P(IB0,U,22),1:"") - Q - ; +IBCE837A ;ALB/TMP - OUTPUT FOR 837 TRANSMISSION - CONTINUED ;8/6/03 10:50am + ;;2.0;INTEGRATED BILLING;**137,191,211,232,296**;21-MAR-94 + ; +UPD(MSGNUM,BATCH,CNT,BILLS,DESC,IBBTYP,IBINS) ; Upd current batch + bills w/new status + ;MSGNUM = mail msg # for batch + ;BATCH = batch # + ;CNT = # of bills in batch + ;BILLS = array BILLS(bill ien in 364) in batch + ;DESC = 1-80 character description of batch + ;IBBTYP = X-Y where X = P for professional or I for institution + ; Y = 1 for test or 0 for live transmission + ; or 2 for live claim resubmitted as test + ;IBINS = ien of single insurance company for the batch (optional) + ; + N DIC,DIE,DR,DA,IBBATCH,IBIFN,IBIEN,IBYY,IBTXTEST,IBMRA + S IBBATCH=$O(^IBA(364.1,"B",+BATCH,"")) Q:'IBBATCH + S IBTXTEST=+$P(IBBTYP,"-",2) + I '$P($G(^IBE(350.9,1,8)),U,7) S IBINS="" + ; + S DIE="^IBA(364.1,",DA=IBBATCH,DR=".02////P;.03///"_CNT_";.04///"_MSGNUM_";.05///0;.07////1;.08///^S X="""_DESC_""""_$S($G(IBINS):";.12////"_IBINS,1:"") + ; + I '$P($G(^TMP("IBRESUBMIT",$J)),U,3) S DR=DR_";1.01///NOW;1.02///.5" + I $P($G(^TMP("IBRESUBMIT",$J)),U,2) S DR=DR_";.15////"_$P(^($J),U,2) + ; + S DR=DR_";.14////"_$S('IBTXTEST:0,1:1)_";.06////"_$S($E(IBBTYP)="P":2,1:3) D ^DIE ; Update batch + ; + I IBTXTEST=2 D ADDTXM^IBCEPTM(.BILLS,IBBATCH,$$NOW^XLFDT()) Q + I IBTXTEST'=2 S IBIEN=0 F S IBIEN=$O(BILLS(IBIEN)) Q:'IBIEN D ;Update each bill + .S DA=IBIEN,DIE="^IBA(364,",DR=".02////"_IBBATCH_";.03///P;.04///NOW" D ^DIE + .S IBIFN=+$G(^IBA(364,IBIEN,0)) + .Q:$D(^TMP("IBRESUBMIT",$J))!($P($G(^DGCR(399,IBIFN,0)),U,13)=4)!(+$$TXMT^IBCEF4(IBIEN)=2) + .S IBMRA=$$NEEDMRA^IBEFUNC(IBIFN) + .I IBMRA="C",$P($G(^DGCR(399,IBIFN,0)),U,13)=2 S IBMRA=1 + .I IBIFN D + ..S (DIC,DIE)="^DGCR(399,",DA=$P($G(^IBA(364,IBIEN,0)),U),DR="[IB STATUS]",IBYY=$S('IBMRA:"@91",1:"@911") D:DA ^DIE + ..D BSTAT^IBCDC(IBIFN) ; remove from AB list + Q + ; +PRE ; Run before processing a bill entry + K IBXSAVE,IBXERR,^UTILITY("VAPA",$J),^TMP("IBXSAVE",$J),^TMP($J),^TMP("DIERR",$J) + Q + ; +POST ; Run after processing a bill entry for cleanup + N Q + I $G(IBXERR)'="" D + .S ^TMP("IBXERR",$J,IBXIEN)=IBXERR K ^TMP("IBXDATA",$J) + .K ^TMP("IBHDR1",$J) + .I $D(^TMP("IBRESUBMIT",$J)),'$G(^TMP("IBEDI_TEST_BATCH",$J)) D ;Set not resub flag for non-test bill + ..N Z,Z0 + ..S Z0=$P($G(^TMP("IBRESUBMIT",$J)),U) Q:Z0="" + ..S Z=$O(^IBA(364,"ABABI",+$O(^IBA(364.1,"B",Z0,"")),IBXIEN,"")) + ..I Z S ^TMP("IBNOT",$J,Z)=IBXIEN + K IBXSAVE,IBXNOREQ,^TMP("IBXSAVE",$J),^TMP($J) + S Q="VA" F S Q=$O(^UTILITY(Q)) Q:$E(Q,1,2)'="VA" I $D(^(Q,$J)) K ^UTILITY(Q,$J) + D CLEAN^DILF + Q + ; +MAILIT(IBQUEUE,IBBILL,IBCTM,IBDUZ,IBDESC,IBBTYP,IBINS) ; Send mail msg, update bills + ;IBQUEUE = mail queue name to send 837 transactions to + ;IBBILL = array of ien's in file 364 of bills in batch - IBBILL(IEN)="" + ;IBCTM = # of bills in batch, returned reset to 0 + ;IBDUZ = ien of user 'running' extract (if any) + ;IBDESC = description of batch + ;IBBTYP = X-Y where X = P for professional or I for institution + ; Y = 1 or 2 for test or 0 for live transmission + ;IBINS = ien of insurance company if only one/batch option (optional) + ; + N DIK,DA,XMTO,XMZ,XMBODY,XMDUZ,XMSUBJ,IBBDA,IBBNO + ; + S IBBNO=+$P($G(^TMP("IBHDR",$J)),U),IBBDA=$O(^IBA(364.1,"B",IBBNO,"")) + I '$P($G(^IBE(350.9,1,8)),U,7) S IBINS="" + ; + I IBCTM D + . I +$G(^TMP("IBEDI_TEST_BATCH",$J)) S IBQUEUE="MCT" + . I IBQUEUE'="",IBQUEUE'["@" S XMTO("XXX@Q-"_IBQUEUE_".VA.GOV")="" + . I IBQUEUE["@" S XMTO(IBQUEUE)="" + . S XMDUZ=$G(IBDUZ),XMBODY="^TMP(""IBXMSG"","_$J_")",XMSUBJ=$S($P(IBBTYP,U,2):"** TEST"_$S($P(IBBTYP,U,2)=2:"/RESUB OF LIVE",1:""),1:"")_" CLAIM BATCH: "_$S(IBQUEUE'["@":IBQUEUE,1:$P(IBQUEUE,"@"))_"/"_IBBNO + . K XMZ + . D SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO,,.XMZ) + . I $G(XMZ) D + .. D UPD(XMZ,$P($G(^TMP("IBHDR",$J)),U),IBCTM,.IBBILL,IBDESC,IBBTYP,IBINS) ;Update batch/bills + .. S ^TMP("IBCE-BATCH",$J,IBBNO)=IBBDA_U_IBCTM_U_$P($G(^TMP("IBRESUBMIT",$J)),U) +MAILQ S IBCTM=0 + D CHKBTCH(+$G(^TMP("IBHDR",$J))) + K ^TMP("IBHDR",$J),^TMP("IBHDR1",$J),^TMP("IBXMSG",$J),IBBILL + Q + ; +CHKNEW(IBQ,IBBILL,IBCTM,IBDESC,IBBTYP,IBINS,IBSITE,IBSIZE) ; + ; Determine if ok to send msg + ; Check for one insurance per batch if IBINS defined + ; Returns IBSIZE, IBCTM, IBBILL (pass by reference) + ; + ; IBQ = data queue name + ; IBBILL = the 'list' of bill #'s in the batch + ; IBCTM = the # of claims output so far to the batch + ; IBDESC = the batch description text + ; IBBTYP = X-Y where X = P for professional or I for institution + ; Y = 1 for test or 0 for live transmission + ; IBINS = the ien of the single insurance co. for the batch (optional) + ; IBSITE = the '8' node of file 350.9 (IB PARAMETERS) + ; IBSIZE = the 'running' size of the output message + ; + Q:$S($G(IBINS)="":0,1:'$P(IBSITE,U,7)) + ; + ; New batch needed + I IBCTM D MAILIT(IBQ,.IBBILL,.IBCTM,"",IBDESC,IBBTYP,IBINS) S IBSIZE=0 + Q + ; +ERRMSG(XMBODY) ; Send bulletin for error message + N XMTO,XMSUBJ + S XMTO("I:G.IB EDI")="",XMSUBJ="EDI 837 TRANSMISSION ERRORS" + ; + D SENDMSG^XMXAPI(,XMSUBJ,XMBODY,.XMTO) + D ALERT("One or more EDI bills were not transmitted. Check your mail for details","G.IB EDI") + Q + ; +CLEANUP ; Cleans up bill transmission environment + ; + N IBTEST + S IBTEST=+$G(^TMP("IBEDI_TEST_BATCH",$J)) + L -^IBA(364,0) + I $D(^TMP("IBRESUBMIT",$J,"IBXERR"))!$D(^TMP("IBONE",$J,"IBXERR"))!$D(^TMP("IBSELX",$J,"IBXERR")) D ;Error message to mail group + . N XMTO,XMBODY,XMDUZ,XMSUBJ,XMZ,IBFUNC + . S IBFUNC=$S($D(^TMP("IBRESUBMIT",$J,"IBXERR")):$S('IBTEST:1,1:4),$D(^TMP("IBONE",$J,"IBXERR")):2,1:3) + . Q:'IBFUNC + . S XMTO("I:G.IB EDI")="",XMDUZ="",XMBODY="^TMP("""_$S(IBFUNC=1!(IBFUNC=4):"IBRESUBMIT",1:"IBONE")_""","_$J_",""IBXERR"")" + . S XMSUBJ="EDI 837 B"_$P("ATCH^ILL^ILL(s)^ILL(s)",U,IBFUNC)_" NOT "_$S($G(^TMP("IBONE",$J)):"RE",1:"")_"SUBMITTED"_$S('IBTEST:"",1:" AS TEST CLAIMS") + . D SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO,,.XMZ) + . K ^TMP("IBRESUBMIT",$J),^TMP("IBONE",$J) + ; + I $D(^TMP("IBRESUBMIT",$J)),'IBTEST D RESUBUP^IBCEM02 ;Upd resubmtd batch bills + I '$D(^TMP("IBSELX",$J)) K ^TMP("IBCE-BATCH",$J) + K ^TMP("IBXERR",$J),IBXERR + I 'IBTEST D CHKBTCH(+$G(^TMP("IBHDR",$J))) +CLEANP ; Entrypoint for extract data disply + K ^TMP("IBTXMT",$J),^TMP("IBXINS",$J) + K ^TMP("IBRESUBMIT",$J),^TMP("IBRESUB",$J),^TMP("IBNOT",$J),^TMP("IBONE",$J),^TMP("IBHDR",$J),^TMP("IBTX",$J),^TMP("IBEDI_TEST_BATCH",$J) + K ^UTILITY("VADM",$J) + D CLEAN^DILF + K ZTREQ S ZTREQ="@" + Q + ; +ALERT(XQAMSG,IBGRP) ; Send alert message + N XQA + S XQA(IBGRP)="" + D SETUP^XQALERT + Q +CHKBTCH(IBBNO) ; Delete batch whose batch # is IBBNO if no entries in file 364 + ; and not a resubmitted batch + N IBZ,DA,DIK + S IBZ=+$O(^IBA(364.1,"B",+IBBNO,"")) + I IBZ,'$O(^IBA(364,"C",IBZ,0)),'$P($G(^IBA(364.1,IBZ,0)),U,14) S DA=IBZ,DIK="^IBA(364.1," D ^DIK + Q + ; +TESTLIM(IBINS) ; Check for test bill limit per day has been reached + N IB3,DA,DIK + S IB3=$G(^DIC(36,IBINS,3)) + I $P(IB3,U,5)'=DT S $P(IB3,U,7)=0 + I ($P(IB3,U,7)+$G(^TMP("IBICT",$J,IBINS))+1)>$P(IB3,U,6) D Q + . S IBINS="" ;max # hit + . S DA=IBX,DIK="^IBA(364," D ^DIK + S ^TMP("IBICT",$J,IBINS)=$G(^TMP("IBICT",$J,IBINS))+1 + Q + ; +SETVAR(IBXIEN,IBINS,IB0,IBSEC,IBNID,IB837R,IBDIV) ; + ; Set up variables needed for subscripts in sort global + ; ejk added IBSEC logic for patch 296 + ; IBSEC=1 if primary bill, 2 if 2nd/non-MRA, 3 if 2nd/MRA + S IBSEC=$S($$COBN^IBCEF(IBXIEN)=1:1,'$$MRASEC^IBCEF4(IBXIEN):2,1:3) + S IBNID=$$PAYERID^IBCEF2(IBXIEN) + S IB837R=$$RECVR^IBCEF2(IBXIEN) + S IBDIV=$P($S($P(IB0,U,22):$$SITE^VASITE(DT,$P(IB0,U,22)),1:$$SITE^VASITE()),U,3) + I IBNID'="","RPIHS"[$E(IBNID),$E(IBNID,2,$L(IBNID))="PRNT" S IBNID=IBNID_"*"_IBINS + I IBNID="" S IBNID="*"_IBINS + S $P(IBNID,"*",3)=$S($P(IB0,U,22):$P(IB0,U,22),1:"") + Q + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEBUL.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEBUL.m index 530ce03a..cc4f1987 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEBUL.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEBUL.m @@ -1,88 +1,33 @@ -IBCEBUL ;ALB/TMP - 837 EDI SPECIAL BULLETINS PROCESSING ;19-SEP-96 - ;;2.0;INTEGRATED BILLING;**137,250,377**;21-MAR-94;Build 23 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -NOTSENT ; Check for batches in pending status (no confirmation from Austin) - ; from yesterday or before - N XMTO,XMSUBJ,XMBODY,XMDUZ,IBT,IB,IBE,IBCT,IBI,IB0,IB1,Z,IBTYP - K ^TMP($J,"IBNOTSENT") - S (IBCT,IBI)=0 - F S IBI=$O(^IBA(364.1,"ASTAT","P",IBI)) Q:'IBI D - . I $$BCHCHK(IBI) Q ; Batch check function - . S IBCT=IBCT+1 - . S IBTYP=$P($G(^IBA(364.1,IBI,0)),U,7) - . I IBCT'>10,IBTYP'="" S ^TMP($J,"IBNOTSENT",IBTYP,IBI)="" - . Q - ; - I IBCT D - .S IBT(1)="There are "_IBCT_" EDI batch(es) still pending Austin receipt " - .S IBT(2)="for more than 1 day. Please investigate why they have not yet been confirmed" - .S IBT(3)="as being received by Austin." - .S IBT(4)=" " - .I IBCT>10 S IBT(5)="Since there were more than 10 batches found, please run the ",IBT(6)=" EDI BATCHES PENDING RECEIPT report to get a list of these batches." - .I IBCT'>10 D - ..S IBT(5)=" BATCH # PENDING SINCE MAIL MESSAGE #",IBT(6)="",$P(IBT(6),"-",76)="",IBT(6)=" "_IBT(6),IBE=6 - ..S IBTYP="" - ..F S IBTYP=$O(^TMP($J,"IBNOTSENT",IBTYP)) Q:IBTYP="" D - ...S Z=$$EXPAND^IBTRE(364.1,.07,IBTYP) S:Z="" Z="??" - ...I $O(^TMP($J,"IBNOTSENT",IBTYP),-1)'="" S IBE=IBE+1,IBT(IBE)=" " - ...S IBE=IBE+1,IBT(IBE)=" BATCH TYPE: "_Z - ...S IBI=0 F S IBI=$O(^TMP($J,"IBNOTSENT",IBTYP,IBI)) Q:'IBI D - ....S IBE=IBE+1,IB0=$G(^IBA(364.1,IBI,0)),IB1=$G(^(1)) - ....S IBT(IBE)=" "_$E($P(IB0,U)_$J("",10),1,10)_" "_$E($$FMTE^XLFDT($P(IB1,U,6),1)_$J("",20),1,20)_" "_$P(IB0,U,4),IBE=IBE+1,IBT(IBE)=$J("",8)_$E($P(IB0,U,8),1,72) - .S XMSUBJ="EDI BATCHES WAITING AUSTIN RECEIPT FOR OVER 1 DAY",XMBODY="IBT",XMDUZ="",XMTO("I:G.IB EDI")="" - .D SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO) - K ^TMP($J,"IBNOTSENT") - Q - ; -UPDBCH(BCHIEN) ; update the status of this batch to show A0:received in Austin - NEW DIE,DA,DR - S DIE=364.1,DA=+BCHIEN,DR=".02///A0" - I $D(^IBA(DIE,DA,0)) D ^DIE -UPDBCHX ; - Q - ; -BCHCHK(BCHIEN) ; This function will check the EDI claims associated with this - ; batch and determine if this batch has been received in Austin or not. - ; - ; ** This function is also called by routine IBCERP3 ** - ; - ; Function value = 1 if we can determine that the batch was received in Austin, or - ; = 1 if there are no claims in this batch, or - ; = 1 if the batch is less than 24 hours old - too new to worry about - ; = 1 means don't display on report or MailMan message - ; - ; Function value = 0 if the batch has not yet been received in Austin - ; = 0 means we need to display batch on report and in MailMan message - ; - NEW IBEDI,IBOK,IBZ,IBIFN,IB0,AR,IBSECS - S IBEDI=0,IBOK=1,BCHIEN=+$G(BCHIEN) - ; - ; if the batch transmission is still less than 24 hours old, skip this batch and get out - S IBSECS=$$FMDIFF^XLFDT($$NOW^XLFDT,$P($G(^IBA(364.1,BCHIEN,1)),U,6),2) - I IBSECS<86400 G BCHCHKX ; # seconds in a day - ; - ; if no edi claims in this batch, update batch status and get out - I '$O(^IBA(364,"C",BCHIEN,0)) D UPDBCH(BCHIEN) G BCHCHKX - ; - F S IBEDI=$O(^IBA(364,"C",BCHIEN,IBEDI)) Q:'IBEDI D Q:'IBOK - . S IBZ=$G(^IBA(364,IBEDI,0)) - . S IBIFN=+IBZ,IB0=$G(^DGCR(399,IBIFN,0)) - . I $P(IB0,U,13)=7 Q ; cancelled in IB - . I $P(IBZ,U,3)'="P" Q ; edi claim status is not pending - . S AR=$P($$BILL^RCJIBFN2(IBIFN),U,2) ; AR status DBIA 1452 - . I $F(".22.26.39.","."_AR_".") Q ; collected/closed or cancelled - . ; - . ; if we get to this point, then we have found an EDI claim in this batch - . ; that is not cancelled in IB, the EDI claim status is "P", and the - . ; AR status is not collected/closed nor cancelled in AR. So therefore - . ; this claim didn't get to Austin, so the batch didn't get to Austin. - . S IBOK=0 - . Q - ; - ; If we find the batch has been received in Austin, then change the batch status. - I IBOK D UPDBCH(BCHIEN) - ; -BCHCHKX ; - Q IBOK - ; +IBCEBUL ;ALB/TMP - 837 EDI SPECIAL BULLETINS PROCESSING ;19-SEP-96 + ;;2.0;INTEGRATED BILLING;**137,250**;21-MAR-94 + ; +NOTSENT ; Check for batches in pending status (no confirmation from Austin) + ; from yesterday or before + N XMTO,XMSUBJ,XMBODY,XMDUZ,IBT,IB,IBE,IBCT,IBI,IB0,IB1,Z,IBDTM + K ^TMP($J,"IBNOTSENT") + D NOW^%DTC S IBDTM=% + S (IBCT,IBI)=0 + F S IBI=$O(^IBA(364.1,"ASTAT","P",IBI)) Q:'IBI S IBTYP=$P($G(^IBA(364.1,IBI,0)),U,7),IBDAYS=(IBDTM-$P($G(^(1)),U,6)) I IBDAYS>1,IBDAYS'=IBDTM,$O(^IBA(364,"C",IBI,0)) D + .S IBCT=IBCT+1,IBCT(+IBTYP)=$G(IBCT(+IBTYP))+1 + .I IBCT'>10 S ^TMP($J,"IBNOTSENT",IBTYP,IBI)="" + I IBCT D + .S IBT(1)="There are "_IBCT_" EDI batch(es) still pending Austin receipt " + .S IBT(2)="for more than 1 day. Please investigate why they have not yet been confirmed" + .S IBT(3)="as being received by Austin." + .S IBT(4)=" " + .I IBCT>10 S IBT(5)="Since there were more than 10 batches found, please run the ",IBT(6)=" EDI BATCHES WAITING FOR AUSTIN RECEIPT OVER 1-DAY report to get a list of these batches." + .I IBCT'>10 D + ..S IBT(5)=" BATCH # PENDING SINCE MAIL MESSAGE #",IBT(6)="",$P(IBT(6),"-",76)="",IBT(6)=" "_IBT(6),IBE=6 + ..S IBTYP="" + ..F S IBTYP=$O(^TMP($J,"IBNOTSENT",IBTYP)) Q:IBTYP="" D + ...S Z=$$EXPAND^IBTRE(364.1,.07,IBTYP) S:Z="" Z="??" + ...I $O(^TMP($J,"IBNOTSENT",IBTYP),-1)'="" S IBE=IBE+1,IBT(IBE)=" " + ...S IBE=IBE+1,IBT(IBE)=" BATCH TYPE: "_Z + ...S IBI=0 F S IBI=$O(^TMP($J,"IBNOTSENT",IBTYP,IBI)) Q:'IBI D + ....S IBE=IBE+1,IB0=$G(^IBA(364.1,IBI,0)),IB1=$G(^(1)) + ....S IBT(IBE)=" "_$E($P(IB0,U)_$J("",10),1,10)_" "_$E($$FMTE^XLFDT($P(IB1,U,6),1)_$J("",20),1,20)_" "_$P(IB0,U,4),IBE=IBE+1,IBT(IBE)=$J("",8)_$E($P(IB0,U,8),1,72) + .S XMSUBJ="EDI BATCHES WAITING AUSTIN RECEIPT FOR OVER 1 DAY",XMBODY="IBT",XMDUZ="",XMTO("I:G.IB EDI")="" + .D SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO,,.XMZ) + K ^TMP($J,"IBNOTSENT") + Q + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCECOB1.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCECOB1.m index 6ba84a54..bf8fcd51 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCECOB1.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCECOB1.m @@ -1,204 +1,203 @@ -IBCECOB1 ;ALB/CXW - IB COB MANAGEMENT SCREEN/REPORT ;14-JUN-99 - ;;2.0;INTEGRATED BILLING;**137,155,288,348,377**;21-MAR-94;Build 23 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -BLD ; Build list entrypoint - N I,IBFND,IBB,IBIFN,IB364,IBDA1,IBDTN,IBDA,IBDAY,IBHIS,IBNDS,IBEUT,IBAPY,IBOAM,IBDT,IBMUT,IBBPY,IBINS,IBNDM,IBQ,IBNDI1,IBNDI2,IBNDI3,Z,Z0,IBSEQ,IB3611,IBINS1,IBINS2,IBEXPY,IBNBAL,IBPTRSP,IBAMT,IBMRACNT,IBPTNM,IBSRVC,IBPY,IBB364 - N IBEOBREV,IBDENDUP - K ^TMP("IBCECOB",$J),^TMP("IBCECOB1",$J),^TMP("IBCOBST",$J),^TMP("IBCOBSTX",$J) - D CLEAN^VALM10 ; kill data and video control arrays - S VALMCNT=0,IBHIS="" - ; since 0 is a valid Review Status, init w/null - S IBEOBREV="" - ; get EOB's w/Review Status of 0, 1, 1.5 or 2; If 3 or higher, not needed - F S IBEOBREV=$O(^IBM(361.1,"AMRA",1,IBEOBREV)) Q:IBEOBREV="" Q:IBEOBREV>2 D ; - . S IBDA="A" F S IBDA=$O(^IBM(361.1,"AMRA",1,IBEOBREV,IBDA),-1) Q:'IBDA D BLD1 - ; no data accumulated - I $O(^TMP("IBCOBST",$J,""))="" D NMAT Q - ; display accumulated data - D SCRN - Q -BLD1 ; - I '$$ELIG(IBDA) Q - S IBDENDUP=$$DENDUP^IBCEMU4(IBDA) - I '$G(IBMRADUP),IBDENDUP Q ; don't include denied MRAs for Duplicate Claim/Service - S IB3611=$G(^IBM(361.1,IBDA,0)) - S IBIFN=+IB3611,IB364=$P(IB3611,U,19),IBDT=+$P(IB3611,U,6) - I $D(^TMP("IBCOBSTX",$J,IBIFN)) Q ;show each bill once on the worklist - S IBB=$G(^DGCR(399,IBIFN,0)) - S IBNDS=$G(^DGCR(399,IBIFN,"S")),IBNDI1=$G(^("I1")),IBNDI2=$G(^("I2")),IBNDI3=$G(^("I3")),IBNDM=$G(^("M")) - S IBMUT=+$P(IBNDS,U,8),IBEUT=+$P(IBNDS,U,2) - S IBINS="",IBSEQ=$P(IB3611,U,15) - F I=1:1:3 S Z="IBNDI"_I I @Z D - . N Q - . S Q=(IBSEQ=I) - . I Q S IBINS1=+@Z_U_$P($G(^DIC(36,+@Z,0)),U) - . S IBINS=IBINS_$S(IBINS="":"",1:", ")_$P($G(^DIC(36,+@Z,0)),U) - ; Get the payer/insurance company that comes after Medicare WNR - ; If WNR is Primary, get the secondary ins. co. - ; If WNR is secondary, get the tertiary ins. co. - D I $P(IBINS2,U,2)="" S $P(IBINS2,U,2)="UNKNOWN" - . I $$WNRBILL^IBEFUNC(IBIFN,1) S IBINS2=+IBNDI2_U_$P($G(^DIC(36,+IBNDI2,0)),U) Q - . S IBINS2=+IBNDI3_U_$P($G(^DIC(36,+IBNDI3,0)),U) - S IBFND=0 - ; biller entry not ALL and no biller, then get entered/edited by user - I $D(^TMP("IBBIL",$J)) D Q:'IBFND - . S IBFND=$S($D(^TMP("IBBIL",$J,IBMUT)):IBMUT,$D(^TMP("IBBIL",$J,IBEUT)):IBEUT,1:0) - S Z=$S(IBFND:IBFND,IBMUT:IBMUT,1:IBEUT) - S IBMUT=$P($G(^VA(200,+Z,0)),U)_"~"_Z - S:'$P(IBMUT,"~",2) IBMUT="UNKNOWN~0" - S IBBPY=+$$COBN^IBCEF(IBIFN),IBQ=1 - ;IBQ;1=EOB without subsequent insurer,0=COB,2=0 balance - D ;I IBQ Q - . ;Check for no reimbursable subsequent insurance - . F I=IBBPY+1:1:3 D Q:'IBQ - .. S Z="IBNDI"_I,Z=$G(@Z) - .. I $P($G(^DIC(36,+Z,0)),U,2)="N" S IBQ=0 Q - . ;Check if next ins doesn't exist or next bill# already created - . S Z="IBNDI"_(IBBPY+1),Z=$G(@Z) - . I Z,'$P($G(^DGCR(399,IBIFN,"M1")),U,5+IBBPY) S IBQ=0 - ; - ; Days since transmission of latest bill in COB - IBDAY - S IBDAY=+$P($G(^DGCR(399,IBIFN,"TX")),U,2) I IBDAY S IBDAY=$$FMDIFF^XLFDT(DT,IBDAY,1) - ; if no Last Electronic Extract Date on file 399, get it from file 364 - I 'IBDAY D I IBDAY S IBDAY=$$FMDIFF^XLFDT(DT,IBDAY,1) ;calc. the difference - . S IBB364=$$LAST364^IBCEF4(IBIFN) I IBB364'="" S IBDAY=+$P($P($G(^IBA(364,IBB364,0)),U,4),".",1) - ; - S IBAPY=$$TPR^PRCAFN(IBIFN) ; payment on this bill from A/R - S IBEXPY=+$G(^IBM(361.1,IBDA,1)) ; payer paid amount - S IBPTRSP=$$PREOBTOT^IBCEU0(IBIFN) ; patient resp. function - S IBPY=$S(IBAPY:IBAPY,1:IBEXPY) - S IBOAM=+$G(^DGCR(399,IBIFN,"U1")) ; total charges for bill - S IBNBAL=IBOAM-IBPY - I IBNBAL'>0 S IBQ=2 - S IBPTNM=$P($G(^DPT(+$P($G(^DGCR(399,IBIFN,0)),U,2),0)),U) I IBPTNM="" S IBPTNM="UNKNOWN" - S IBSRVC=$P($G(^DGCR(399,IBIFN,"U")),U) - S Z0=$S(IBSRT="B":IBMUT,IBSRT="D":-IBDAY,IBSRT="I":$P(IBINS2,U,2)_"~"_$P(IBINS2,U),IBSRT="M":$$EXTERNAL^DILFD(361.1,.13,"",$P(IB3611,"^",13)),IBSRT="R":-IBPTRSP,IBSRT="P":IBPTNM,IBSRT="S":IBSRVC,1:IBDT) - S ^TMP("IBCOBST",$J,Z0,IBIFN)=IBSRVC_U_IBOAM_U_IBAPY_U_$S(IBNBAL>0:IBNBAL,1:0)_U_$P(IBB,U,5)_U_$P(IBB,U,19)_U_IBBPY_U_$P(IBMUT,"~")_U_IBINS_U_IBDA_U_$$HIS(IBIFN)_U_IBDAY_U_IBDT_U_IBQ_U_IB364_U_IBSEQ_U_IBEXPY_U_IBPTRSP - S ^TMP("IBCOBST",$J,Z0,IBIFN,1)=$$EXTERNAL^DILFD(361.1,.13,"",$P(IB3611,"^",13))_", "_$$FMTE^XLFDT($P($P(IB3611,"^",6),"."))_"^"_$P(IB3611,"^",16) - S ^TMP("IBCOBSTX",$J,IBIFN)=IBDA ;keep track of compiled IBIFN's - ; - ; Save some data when there are multiple MRA's on file for this bill - S IBMRACNT=$$MRACNT^IBCEMU1(IBIFN) - I IBMRACNT>1 S $P(^TMP("IBCOBST",$J,Z0,IBIFN,1),U,1)="Multiple MRA's on file" - S $P(^TMP("IBCOBST",$J,Z0,IBIFN,1),U,3)=IBMRACNT - S $P(^TMP("IBCOBST",$J,Z0,IBIFN,1),U,4)=IBDENDUP - Q - ; -HIS(IBIFN) ; COB history - N A,B,IBST,IBBIL,IBHIS - S IBHIS="",A=0 F S A=$O(^IBM(361.1,"ABS",IBIFN,A)) Q:'A S B=0 F S B=$O(^IBM(361.1,"ABS",IBIFN,A,B)) Q:'B D - . S IBST=$P($G(^IBM(361.1,B,0)),U,4),IBBIL=$P(^DGCR(399,IBIFN,"M1"),U,4+A) - . Q:IBBIL="" - . S IBHIS=IBHIS_$S(IBHIS="":"",1:";")_$S(A=1:"PRIMARY",A=2:"SECONDARY",1:"TERTIARY")_" "_$S(IBST:"MRA",1:"EOB")_" RECEIVED - "_IBBIL - Q IBHIS - ; -NMAT ;No COB list - S VALMCNT=2,IBCNT=2 - S ^TMP("IBCECOB",$J,1,0)=" " - S ^TMP("IBCECOB",$J,2,0)=" No MRA's Matching Selection Criteria Were Found" - Q - ; -SCRN ; - N IBX,IBCNT,IBIFN,IBDA,IB,X,IBS1,IBPAT,Z,IBK,IBFORM - S IBCNT=0 - S IBS1=$S(IBSRT="B":"BILLER",IBSRT="D":"Days Since Last Transmission",IBSRT="L":"Date Last MRA Received",IBSRT="I":"SECONDARY INSURANCE COMPANY",IBSRT="M":"MRA Status",1:"") - S IBX="" F S IBX=$O(^TMP("IBCOBST",$J,IBX)) Q:IBX="" D - . I IBSRT="B"!(IBSRT="I")!(IBSRT="M") D - .. D:IBCNT SET("",IBCNT+1) - .. D SET(IBS1_": "_$P(IBX,"~"),IBCNT+1) - . S IBIFN=0 F S IBIFN=$O(^TMP("IBCOBST",$J,IBX,IBIFN)) Q:'IBIFN D - .. S IB=$G(^TMP("IBCOBST",$J,IBX,IBIFN)) - .. S Z=$G(^DPT(+$P($G(^DGCR(399,IBIFN,0)),U,2),0)) - .. S IBPAT=$$LJ^XLFSTR($E($P(Z,U),1,18),18," ")_" "_$E($P(Z,U,9),6,9) - .. S IBDA=$P(IB,U,10) ;361.1-ien - .. S IBQ=$P(IB,U,14),IB364=$P(IB,U,15) - .. S IBFORM=$$EXTERNAL^DILFD(399,.19,,+$P(IB,U,6)) - .. I +$P(IB,U,6)=2 S IBFORM=1500 ; for space reasons - .. S IBPTRSP=$P(IB,U,18) - .. S IBAMT=$P(IB,U,2) - .. S IBCNT=IBCNT+1 - .. S X="" - .. S X=$$SETFLD^VALM1(IBCNT,X,"NUMBER") - .. S X=$$SETFLD^VALM1($$BN1^PRCAFN(IBIFN)_$S($P($G(^DGCR(399,IBIFN,"TX")),U,10)=1:"*",1:""),X,"BILL") - .. S X=$$SETFLD^VALM1($$DAT1^IBOUTL($P(IB,U)),X,"SERVICE") - .. S X=$$SETFLD^VALM1(IBPAT,X,"PATNM") - .. S X=$$SETFLD^VALM1($$RJ^XLFSTR($FN(IBPTRSP,"",2),9," "),X,"PTRESP") - .. S X=$$SETFLD^VALM1($$RJ^XLFSTR($FN(IBAMT,"",2),9," "),X,"IBAMT") - .. S X=$$SETFLD^VALM1($$TYPE^IBJTLA1($P(IB,U,5))_"/"_IBFORM,X,"BTYPE") - .. D SET(X,IBCNT,IBIFN,IBDA,IBQ,IB364,IBX,IB) - .. ;For R (Pt Resp), P (Pt Name) and S (Service Date) don't display sub-headers - .. I "BIMRPS"'[IBSRT D - ... S Z=$S(IBSRT="L":$$DAT1^IBOUTL(IBX),IBSRT="D":-IBX,1:IBX) - ... D SET(" "_IBS1_": "_Z,IBCNT) - .. S X=$$SETSTR^VALM1("Insurers: "_$P(IB,U,9),"",7,74) - .. D SET(X,IBCNT,IBIFN,IBDA,IBQ,IB364,IBX,IB) - .. ; - .. ; line 3 of display: MRA status/date/split claim indicator - .. S X=$$SETSTR^VALM1("MRA Status: ","",5,13) - .. S IBK=$G(^TMP("IBCOBST",$J,IBX,IBIFN,1)) - .. S X=$$SETSTR^VALM1($P(IBK,U,1),X,18,63) - .. I $P(IBK,U,2)=2 S X=$$SETSTR^VALM1("** SPLIT CLAIM **",X,63,18) - .. I $P(IBK,U,4),$P(IBK,U,2)'=2,$P(IBK,U,3)=1 S X=$$SETSTR^VALM1("** Denied for Duplicate **",X,54,27) - .. D SET(X,IBCNT,IBIFN,IBDA,IBQ,IB364,IBX,IB) - .. ; - .. ; conditionally update video attributes of line 3 - .. I '$D(IOINHI) D ENS^%ZISS - .. ; split claim - .. I $P(IBK,U,2)=2 D CNTRL^VALM10(VALMCNT,63,17,IOINHI,IOINORM) - .. ; multiple mra's on file - .. I $P(IBK,U,3)>1 D CNTRL^VALM10(VALMCNT,18,22,IOINHI,IOINORM) - .. ; Denied for Duplicate - no split claim and single MRA only - .. I $P(IBK,U,4),$P(IBK,U,2)'=2,$P(IBK,U,3)=1 D CNTRL^VALM10(VALMCNT,54,26,IOINHI,IOINORM) - .. Q - Q - ; -SET(X,CNT,IBIFN,IBDA,IBQ,IB364,IBX,IB) ;set up list manager screen array - S VALMCNT=VALMCNT+1 - S ^TMP("IBCECOB",$J,VALMCNT,0)=X - S ^TMP("IBCECOB",$J,"IDX",VALMCNT,CNT)="" - I $G(IBIFN),$G(^TMP("IBCECOB",$J,CNT))="" S ^TMP("IBCECOB",$J,CNT)=VALMCNT_U_IBIFN_U_IB364_U_IBDA_U_IBQ_U_IBX,^TMP("IBCECOB1",$J,CNT)=IB - Q - ; -FTYPE(Y) ;type classification - Q $E($P($G(^IBE(353,Y,0)),U),1,8) - ; -PTRESPI(IBEOB) ; Function - Computes the Patient's Responsibility based on IBEOB - ; of 361.1 for Claims/Bills with form type 3=UB - ; Input IBEOB - a single EOB ien; Required - ; Output - Function Returns IBPTRES - Patient Responsibility Amount for the EOB - ; - N IBPTRES,IBC,EOBADJ - S IBPTRES=0,IBEOB=+$G(IBEOB) - I 'IBEOB Q IBPTRES ;PTRESPI - ; - ; get claim level adjustments - K EOBADJ M EOBADJ=^IBM(361.1,IBEOB,10) - S IBPTRES=$$CALCPR^IBCEU0(.EOBADJ) - ; - ; get line level adjustments - S IBC=0 F S IBC=$O(^IBM(361.1,IBEOB,15,IBC)) Q:'IBC D - . K EOBADJ M EOBADJ=^IBM(361.1,IBEOB,15,IBC,1) - . S IBPTRES=IBPTRES+$$CALCPR^IBCEU0(.EOBADJ) - Q IBPTRES - ; -ELIG(IBEOB) ; Function to determine if an EOB entry is eligible for - ; inclusion on the MRA management worklist or not. - ; IBEOB - ien into file 361.1 (required) - ; Returns 1 if EOB should appear on the worklist - ; Returns 0 if EOB should not appear on the worklist - ; - NEW ELIG,IB3611,IBIFN - S ELIG=0,IBEOB=+$G(IBEOB) - S IB3611=$G(^IBM(361.1,IBEOB,0)) - I $P(IB3611,U,4)'=1 G ELIGX ; eob type must be Medicare MRA - I $P(IB3611,U,16)>2 G ELIGX ; review status must be <= 2 - S IBIFN=+IB3611 - I $P($G(^DGCR(399,IBIFN,0)),U,13)'=2 G ELIGX ; Request MRA bill status - I $D(^IBM(361.1,IBEOB,"ERR")) G ELIGX ; filing errors - ; - S ELIG=1 ; this EOB is eligible for the worklist - ; -ELIGX ; - Q ELIG - ; +IBCECOB1 ;ALB/CXW - IB COB MANAGEMENT SCREEN/REPORT ;14-JUN-99 + ;;2.0;INTEGRATED BILLING;**137,155,288,348**;21-MAR-94;Build 5 + ; +BLD ; Build list entrypoint + N I,IBFND,IBB,IBIFN,IB364,IBDA1,IBDTN,IBDA,IBDAY,IBHIS,IBNDS,IBEUT,IBAPY,IBOAM,IBDT,IBMUT,IBBPY,IBINS,IBNDM,IBQ,IBNDI1,IBNDI2,IBNDI3,Z,Z0,IBSEQ,IB3611,IBINS1,IBINS2,IBEXPY,IBNBAL,IBPTRSP,IBAMT,IBMRACNT,IBPTNM,IBSRVC,IBPY,IBB364 + N IBEOBREV,IBDENDUP + K ^TMP("IBCECOB",$J),^TMP("IBCECOB1",$J),^TMP("IBCOBST",$J),^TMP("IBCOBSTX",$J) + D CLEAN^VALM10 ; kill data and video control arrays + S VALMCNT=0,IBHIS="" + ; since 0 is a valid Review Status, init w/null + S IBEOBREV="" + ; get EOB's w/Review Status of 0, 1, 1.5 or 2; If 3 or higher, not needed + F S IBEOBREV=$O(^IBM(361.1,"AMRA",1,IBEOBREV)) Q:IBEOBREV="" Q:IBEOBREV>2 D ; + . S IBDA="A" F S IBDA=$O(^IBM(361.1,"AMRA",1,IBEOBREV,IBDA),-1) Q:'IBDA D BLD1 + ; no data accumulated + I $O(^TMP("IBCOBST",$J,""))="" D NMAT Q + ; display accumulated data + D SCRN + Q +BLD1 ; + I '$$ELIG(IBDA) Q + S IBDENDUP=$$DENDUP^IBCEMU4(IBDA) + I '$G(IBMRADUP),IBDENDUP Q ; don't include denied MRAs for Duplicate Claim/Service + S IB3611=$G(^IBM(361.1,IBDA,0)) + S IBIFN=+IB3611,IB364=$P(IB3611,U,19),IBDT=+$P(IB3611,U,6) + I $D(^TMP("IBCOBSTX",$J,IBIFN)) Q ;show each bill once on the worklist + S IBB=$G(^DGCR(399,IBIFN,0)) + S IBNDS=$G(^DGCR(399,IBIFN,"S")),IBNDI1=$G(^("I1")),IBNDI2=$G(^("I2")),IBNDI3=$G(^("I3")),IBNDM=$G(^("M")) + S IBMUT=+$P(IBNDS,U,8),IBEUT=+$P(IBNDS,U,2) + S IBINS="",IBSEQ=$P(IB3611,U,15) + F I=1:1:3 S Z="IBNDI"_I I @Z D + . N Q + . S Q=(IBSEQ=I) + . I Q S IBINS1=+@Z_U_$P($G(^DIC(36,+@Z,0)),U) + . S IBINS=IBINS_$S(IBINS="":"",1:", ")_$P($G(^DIC(36,+@Z,0)),U) + ; Get the payer/insurance company that comes after Medicare WNR + ; If WNR is Primary, get the secondary ins. co. + ; If WNR is secondary, get the tertiary ins. co. + D I $P(IBINS2,U,2)="" S $P(IBINS2,U,2)="UNKNOWN" + . I $$WNRBILL^IBEFUNC(IBIFN,1) S IBINS2=+IBNDI2_U_$P($G(^DIC(36,+IBNDI2,0)),U) Q + . S IBINS2=+IBNDI3_U_$P($G(^DIC(36,+IBNDI3,0)),U) + S IBFND=0 + ; biller entry not ALL and no biller, then get entered/edited by user + I $D(^TMP("IBBIL",$J)) D Q:'IBFND + . S IBFND=$S($D(^TMP("IBBIL",$J,IBMUT)):IBMUT,$D(^TMP("IBBIL",$J,IBEUT)):IBEUT,1:0) + S Z=$S(IBFND:IBFND,IBMUT:IBMUT,1:IBEUT) + S IBMUT=$P($G(^VA(200,+Z,0)),U)_"~"_Z + S:'$P(IBMUT,"~",2) IBMUT="UNKNOWN~0" + S IBBPY=+$$COBN^IBCEF(IBIFN),IBQ=1 + ;IBQ;1=EOB without subsequent insurer,0=COB,2=0 balance + D ;I IBQ Q + . ;Check for no reimbursable subsequent insurance + . F I=IBBPY+1:1:3 D Q:'IBQ + .. S Z="IBNDI"_I,Z=$G(@Z) + .. I $P($G(^DIC(36,+Z,0)),U,2)="N" S IBQ=0 Q + . ;Check if next ins doesn't exist or next bill# already created + . S Z="IBNDI"_(IBBPY+1),Z=$G(@Z) + . I Z,'$P($G(^DGCR(399,IBIFN,"M1")),U,5+IBBPY) S IBQ=0 + ; + ; Days since transmission of latest bill in COB - IBDAY + S IBDAY=+$P($G(^DGCR(399,IBIFN,"TX")),U,2) I IBDAY S IBDAY=$$FMDIFF^XLFDT(DT,IBDAY,1) + ; if no Last Electronic Extract Date on file 399, get it from file 364 + I 'IBDAY D I IBDAY S IBDAY=$$FMDIFF^XLFDT(DT,IBDAY,1) ;calc. the difference + . S IBB364=$$LAST364^IBCEF4(IBIFN) I IBB364'="" S IBDAY=+$P($P($G(^IBA(364,IBB364,0)),U,4),".",1) + ; + S IBAPY=$$TPR^PRCAFN(IBIFN) ; payment on this bill from A/R + S IBEXPY=+$G(^IBM(361.1,IBDA,1)) ; payer paid amount + S IBPTRSP=$$PREOBTOT^IBCEU0(IBIFN) ; patient resp. function + S IBPY=$S(IBAPY:IBAPY,1:IBEXPY) + S IBOAM=+$G(^DGCR(399,IBIFN,"U1")) ; total charges for bill + S IBNBAL=IBOAM-IBPY + I IBNBAL'>0 S IBQ=2 + S IBPTNM=$P($G(^DPT(+$P($G(^DGCR(399,IBIFN,0)),U,2),0)),U) I IBPTNM="" S IBPTNM="UNKNOWN" + S IBSRVC=$P($G(^DGCR(399,IBIFN,"U")),U) + S Z0=$S(IBSRT="B":IBMUT,IBSRT="D":-IBDAY,IBSRT="I":$P(IBINS2,U,2)_"~"_$P(IBINS2,U),IBSRT="M":$$EXTERNAL^DILFD(361.1,.13,"",$P(IB3611,"^",13)),IBSRT="R":-IBPTRSP,IBSRT="P":IBPTNM,IBSRT="S":IBSRVC,1:IBDT) + S ^TMP("IBCOBST",$J,Z0,IBIFN)=IBSRVC_U_IBOAM_U_IBAPY_U_$S(IBNBAL>0:IBNBAL,1:0)_U_$P(IBB,U,5)_U_$P(IBB,U,19)_U_IBBPY_U_$P(IBMUT,"~")_U_IBINS_U_IBDA_U_$$HIS(IBIFN)_U_IBDAY_U_IBDT_U_IBQ_U_IB364_U_IBSEQ_U_IBEXPY_U_IBPTRSP + S ^TMP("IBCOBST",$J,Z0,IBIFN,1)=$$EXTERNAL^DILFD(361.1,.13,"",$P(IB3611,"^",13))_", "_$$FMTE^XLFDT($P($P(IB3611,"^",6),"."))_"^"_$P(IB3611,"^",16) + S ^TMP("IBCOBSTX",$J,IBIFN)=IBDA ;keep track of compiled IBIFN's + ; + ; Save some data when there are multiple MRA's on file for this bill + S IBMRACNT=$$MRACNT^IBCEMU1(IBIFN) + I IBMRACNT>1 S $P(^TMP("IBCOBST",$J,Z0,IBIFN,1),U,1)="Multiple MRA's on file" + S $P(^TMP("IBCOBST",$J,Z0,IBIFN,1),U,3)=IBMRACNT + S $P(^TMP("IBCOBST",$J,Z0,IBIFN,1),U,4)=IBDENDUP + Q + ; +HIS(IBIFN) ; COB history + N A,B,IBST,IBBIL,IBHIS + S IBHIS="",A=0 F S A=$O(^IBM(361.1,"ABS",IBIFN,A)) Q:'A S B=0 F S B=$O(^IBM(361.1,"ABS",IBIFN,A,B)) Q:'B D + . S IBST=$P($G(^IBM(361.1,B,0)),U,4),IBBIL=$P(^DGCR(399,IBIFN,"M1"),U,4+A) + . Q:IBBIL="" + . S IBHIS=IBHIS_$S(IBHIS="":"",1:";")_$S(A=1:"PRIMARY",A=2:"SECONDARY",1:"TERTIARY")_" "_$S(IBST:"MRA",1:"EOB")_" RECEIVED - "_IBBIL + Q IBHIS + ; +NMAT ;No COB list + S VALMCNT=2,IBCNT=2 + S ^TMP("IBCECOB",$J,1,0)=" " + S ^TMP("IBCECOB",$J,2,0)=" No MRA's Matching Selection Criteria Were Found" + Q + ; +SCRN ; + N IBX,IBCNT,IBIFN,IBDA,IB,X,IBS1,IBPAT,Z,IBK,IBFORM + S IBCNT=0 + S IBS1=$S(IBSRT="B":"BILLER",IBSRT="D":"Days Since Last Transmission",IBSRT="L":"Date Last MRA Received",IBSRT="I":"SECONDARY INSURANCE COMPANY",IBSRT="M":"MRA Status",1:"") + S IBX="" F S IBX=$O(^TMP("IBCOBST",$J,IBX)) Q:IBX="" D + . I IBSRT="B"!(IBSRT="I")!(IBSRT="M") D + .. D:IBCNT SET("",IBCNT+1) + .. D SET(IBS1_": "_$P(IBX,"~"),IBCNT+1) + . S IBIFN=0 F S IBIFN=$O(^TMP("IBCOBST",$J,IBX,IBIFN)) Q:'IBIFN D + .. S IB=$G(^TMP("IBCOBST",$J,IBX,IBIFN)) + .. S Z=$G(^DPT(+$P($G(^DGCR(399,IBIFN,0)),U,2),0)) + .. S IBPAT=$$LJ^XLFSTR($E($P(Z,U),1,18),18," ")_" "_$E($P(Z,U,9),6,9) + .. S IBDA=$P(IB,U,10) ;361.1-ien + .. S IBQ=$P(IB,U,14),IB364=$P(IB,U,15) + .. S IBFORM=$$EXTERNAL^DILFD(399,.19,,+$P(IB,U,6)) + .. I +$P(IB,U,6)=2 S IBFORM=1500 ; for space reasons + .. S IBPTRSP=$P(IB,U,18) + .. S IBAMT=$P(IB,U,2) + .. S IBCNT=IBCNT+1 + .. S X="" + .. S X=$$SETFLD^VALM1(IBCNT,X,"NUMBER") + .. S X=$$SETFLD^VALM1($$BN1^PRCAFN(IBIFN),X,"BILL") + .. S X=$$SETFLD^VALM1($$DAT1^IBOUTL($P(IB,U)),X,"SERVICE") + .. S X=$$SETFLD^VALM1(IBPAT,X,"PATNM") + .. S X=$$SETFLD^VALM1($$RJ^XLFSTR($FN(IBPTRSP,"",2),9," "),X,"PTRESP") + .. S X=$$SETFLD^VALM1($$RJ^XLFSTR($FN(IBAMT,"",2),9," "),X,"IBAMT") + .. S X=$$SETFLD^VALM1($$TYPE^IBJTLA1($P(IB,U,5))_"/"_IBFORM,X,"BTYPE") + .. D SET(X,IBCNT,IBIFN,IBDA,IBQ,IB364,IBX,IB) + .. ;For R (Pt Resp), P (Pt Name) and S (Service Date) don't display sub-headers + .. I "BIMRPS"'[IBSRT D + ... S Z=$S(IBSRT="L":$$DAT1^IBOUTL(IBX),IBSRT="D":-IBX,1:IBX) + ... D SET(" "_IBS1_": "_Z,IBCNT) + .. S X=$$SETSTR^VALM1("Insurers: "_$P(IB,U,9),"",7,74) + .. D SET(X,IBCNT,IBIFN,IBDA,IBQ,IB364,IBX,IB) + .. ; + .. ; line 3 of display: MRA status/date/split claim indicator + .. S X=$$SETSTR^VALM1("MRA Status: ","",5,13) + .. S IBK=$G(^TMP("IBCOBST",$J,IBX,IBIFN,1)) + .. S X=$$SETSTR^VALM1($P(IBK,U,1),X,18,63) + .. I $P(IBK,U,2)=2 S X=$$SETSTR^VALM1("** SPLIT CLAIM **",X,63,18) + .. I $P(IBK,U,4),$P(IBK,U,2)'=2,$P(IBK,U,3)=1 S X=$$SETSTR^VALM1("** Denied for Duplicate **",X,54,27) + .. D SET(X,IBCNT,IBIFN,IBDA,IBQ,IB364,IBX,IB) + .. ; + .. ; conditionally update video attributes of line 3 + .. I '$D(IOINHI) D ENS^%ZISS + .. ; split claim + .. I $P(IBK,U,2)=2 D CNTRL^VALM10(VALMCNT,63,17,IOINHI,IOINORM) + .. ; multiple mra's on file + .. I $P(IBK,U,3)>1 D CNTRL^VALM10(VALMCNT,18,22,IOINHI,IOINORM) + .. ; Denied for Duplicate - no split claim and single MRA only + .. I $P(IBK,U,4),$P(IBK,U,2)'=2,$P(IBK,U,3)=1 D CNTRL^VALM10(VALMCNT,54,26,IOINHI,IOINORM) + .. Q + Q + ; +SET(X,CNT,IBIFN,IBDA,IBQ,IB364,IBX,IB) ;set up list manager screen array + S VALMCNT=VALMCNT+1 + S ^TMP("IBCECOB",$J,VALMCNT,0)=X + S ^TMP("IBCECOB",$J,"IDX",VALMCNT,CNT)="" + I $G(IBIFN),$G(^TMP("IBCECOB",$J,CNT))="" S ^TMP("IBCECOB",$J,CNT)=VALMCNT_U_IBIFN_U_IB364_U_IBDA_U_IBQ_U_IBX,^TMP("IBCECOB1",$J,CNT)=IB + Q + ; +FTYPE(Y) ;type classification + Q $E($P($G(^IBE(353,Y,0)),U),1,8) + ; +PTRESPI(IBEOB) ; Function - Computes the Patient's Responsibility based on IBEOB + ; of 361.1 for Claims/Bills with form type 3=UB + ; Input IBEOB - a single EOB ien; Required + ; Output - Function Returns IBPTRES - Patient Responsibility Amount for the EOB + ; + N IBPTRES,IBC,EOBADJ + S IBPTRES=0,IBEOB=+$G(IBEOB) + I 'IBEOB Q IBPTRES ;PTRESPI + ; + ; get claim level adjustments + K EOBADJ M EOBADJ=^IBM(361.1,IBEOB,10) + S IBPTRES=$$CALCPR^IBCEU0(.EOBADJ) + ; + ; get line level adjustments + S IBC=0 F S IBC=$O(^IBM(361.1,IBEOB,15,IBC)) Q:'IBC D + . K EOBADJ M EOBADJ=^IBM(361.1,IBEOB,15,IBC,1) + . S IBPTRES=IBPTRES+$$CALCPR^IBCEU0(.EOBADJ) + Q IBPTRES + ; +ELIG(IBEOB) ; Function to determine if an EOB entry is eligible for + ; inclusion on the MRA management worklist or not. + ; IBEOB - ien into file 361.1 (required) + ; Returns 1 if EOB should appear on the worklist + ; Returns 0 if EOB should not appear on the worklist + ; + NEW ELIG,IB3611,IBIFN + S ELIG=0,IBEOB=+$G(IBEOB) + S IB3611=$G(^IBM(361.1,IBEOB,0)) + I $P(IB3611,U,4)'=1 G ELIGX ; eob type must be Medicare MRA + I $P(IB3611,U,16)>2 G ELIGX ; review status must be <= 2 + S IBIFN=+IB3611 + I $P($G(^DGCR(399,IBIFN,0)),U,13)'=2 G ELIGX ; Request MRA bill status + I $D(^IBM(361.1,IBEOB,"ERR")) G ELIGX ; filing errors + ; + S ELIG=1 ; this EOB is eligible for the worklist + ; +ELIGX ; + Q ELIG + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCECSA1.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCECSA1.m index c8befc16..579f7217 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCECSA1.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCECSA1.m @@ -1,174 +1,167 @@ -IBCECSA1 ;ALB/CXW - IB STATUS AWAITING RESOLUTION SCREEN ;28-JUL-99 - ;;2.0;INTEGRATED BILLING;**137,283,288,320,368**;21-MAR-94;Build 21 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; DBIA for $$BN1^PRCAFN() - ; -BLD ; Build list entrypoint - N IBDA,IBREV,IBIFN,IBPAY,IBSSN,IBSER,IB399,IBLOC,IBDIV,IBUER,IBMSG,IBERR,IBPEN,SEVERITY,A,IBOAM,IBPAT,IBSTSMSG,SV1,SV2,SV3 - K ^TMP("IBCECSA",$J),^TMP("IBCECSB",$J),^TMP("IBCECSD",$J) - W !!,"Compiling CSA status messages ... " - S IBSEV=$G(IBSEV,"R") - S VALMCNT=0,IB364="" - S SEVERITY="" - F S SEVERITY=$O(^IBM(361,"ACSA",SEVERITY)) Q:SEVERITY="" I SEVERITY="R"!(IBSEV="B") S IBREV="" F S IBREV=$O(^IBM(361,"ACSA",SEVERITY,IBREV)) Q:IBREV="" I IBREV<2 S IBDA=0 F S IBDA=$O(^IBM(361,"ACSA",SEVERITY,IBREV,IBDA)) Q:'IBDA D - . S IB=$G(^IBM(361,IBDA,0)),IBIFN=+IB - . S IBPEN=$$FMDIFF^XLFDT(DT,$P(IB,U,2),1) - . ;quit if not pending for at least the minimum # of days requested - . Q:IBDAYS>IBPEN - . S IB399=$G(^DGCR(399,IBIFN,0)) - . ; - . ; no cancelled claims allowed on the CSA screen - . ; if we find one, then update the appropriate EDI files - . I $P(IB399,U,13)=7 D UPDEDI^IBCEM(+$P(IB,U,11),"C") Q - . ; - . ; automatically review this message if the claim was last printed on - . ; or after the MCS - 'Resubmit by Print' date - . I $P(IB,U,16),($P($G(^DGCR(399,IBIFN,"S")),U,14)\1)'<$P(IB,U,16) D UPDEDI^IBCEM(+$P(IB,U,11),"P") Q - . ; - . S IBDIV=+$P(IB399,U,22) - . S IBUER=+$P($G(^DGCR(399,IBIFN,"S")),U,11) - . ; - . ; If Request MRA bill, pull the MRA Requestor user instead - . I 'IBUER,$P(IB399,U,13)=2 S IBUER=+$P($G(^DGCR(399,IBIFN,"S")),U,8) - . I $D(^TMP("IBBIL",$J)),'$D(^TMP("IBBIL",$J,IBUER)) Q ; User not selected - . I $D(^TMP("IBDIV",$J)),'$D(^TMP("IBDIV",$J,IBDIV)) Q ; Div not selected - . ; - . S IBPAY=$P($G(^DIC(36,+$P($G(^DGCR(399,IBIFN,"MP")),U),0)),U) - . I IBPAY="" S IBPAY=$P($G(^DIC(36,+$$CURR^IBCEF2(IBIFN),0)),U) - . I IBPAY="" S IBPAY="UNKNOWN PAYER" - . S IBPAT=$G(^DPT(+$P(IB399,U,2),0)) - . S IBSSN=$E($P(IBPAT,U,9),6,9) I IBSSN="" S IBSSN="~unk" - . S IBPAT=$P(IBPAT,U,1) I IBPAT="" S IBPAT="~UNKNOWN PATIENT NAME" - . S IBSER=$P($G(^DGCR(399,IBIFN,"U")),U) - . S IBLOC=$P(IB399,U,4) - . S IBLOC=$S(IBLOC=1:"HOSPITAL",IBLOC=2:"SKILLED NURSING",1:"CLINIC") - . I IBDIV S IBDIV=$P($G(^DG(40.8,IBDIV,0)),U) - . I IBDIV=""!(IBDIV=0) S IBDIV="UNSPECIFIED" - . S IBMSG=$S($P(IB,U,8):"PAYER",1:"NON-PAYER") - . S IBUER=$S(IBUER:$P($G(^VA(200,IBUER,0)),U),1:"UNKNOWN")_"~"_IBUER - . S IB364=$P(IB,U,11) - . S IBOAM=$G(^DGCR(399,IBIFN,"U1")) - . S IBOAM=$P(IBOAM,U,1)-$P(IBOAM,U,2) ; current balance (total charges - offset) - . ; - . S IBSTSMSG=$$TXT(IBDA) ; status message text - . S IBERR=$E(IBSTSMSG,1,60) - . I IBERR="" S IBERR="-" - . ; - . S IB=$$BN1^PRCAFN(IBIFN) ; external bill# - . S A=IBIFN_U_IBPAY_U_IBPAT_U_IBSSN_U_IBSER_U_IBOAM_U_IBLOC_U_IBDIV_U_IBUER_U_IBMSG_U_IBPEN_U_$S(IBREV:"*",1:"")_U_IB364_U_IB - . ; - . S SV1=$$SRTV($G(IBSORT1),IBDA) - . S SV2=$$SRTV($G(IBSORT2),IBDA) - . S SV3=$$SRTV($G(IBSORT3),IBDA) - . S ^TMP("IBCECSB",$J,SV1,SV2,SV3,IBDA)=A - . S ^TMP("IBCECSB",$J,SV1,SV2,SV3,IBDA,"MSG")=IBSTSMSG - . Q - ; - I '$D(^TMP("IBCECSB",$J)) D NMAT Q - D SCRN - Q - ; -NMAT ;No CSA list - S VALMCNT=2,IBCNT=2 - S ^TMP("IBCECSA",$J,1,0)=" " - S ^TMP("IBCECSA",$J,2,0)="No Messages Matching Selection Criteria Found" - Q - ; -SRTV(SORT,IBDA) ; sort value calculation given the sort code letter - I SORT="" Q IBDA - Q $$SV^IBCECSA(SORT) - ; -SCRN ; - NEW IBSRT1,IBSRT2,IBSRT3,IBX,IBCNT,IBIFN,IBDA,IB,INFX,DAT,X - W !,"Building the CSA list display ... " - S IBCNT=0,IBSRT1="" - F S IBSRT1=$O(^TMP("IBCECSB",$J,IBSRT1)) Q:IBSRT1="" D - . D SRTBRK(1,$G(IBSORT1),IBSRT1) - . S IBSRT2="" - . F S IBSRT2=$O(^TMP("IBCECSB",$J,IBSRT1,IBSRT2)) Q:IBSRT2="" D - .. D SRTBRK(2,$G(IBSORT2),IBSRT2) - .. S IBSRT3="" - .. F S IBSRT3=$O(^TMP("IBCECSB",$J,IBSRT1,IBSRT2,IBSRT3)) Q:IBSRT3="" D - ... D SRTBRK(3,$G(IBSORT3),IBSRT3) - ... S IBDA=0 - ... F S IBDA=$O(^TMP("IBCECSB",$J,IBSRT1,IBSRT2,IBSRT3,IBDA)) Q:'IBDA D - .... S IB=$G(^TMP("IBCECSB",$J,IBSRT1,IBSRT2,IBSRT3,IBDA)) - .... S IBSTSMSG=$G(^TMP("IBCECSB",$J,IBSRT1,IBSRT2,IBSRT3,IBDA,"MSG")) - .... S IBIFN=+IB - .... S IB364=$P(IB,U,13) - .... S DAT=IBIFN_U_IBDA_U_IBSRT1_U_IBSRT2_U_IB364_U_IBSRT3 - .... ; - .... S IBCNT=IBCNT+1 - .... S X=$$SETFLD^VALM1($J(IBCNT,3),"","NUMBER") - .... D SETL1(IB,.X) - .... D SET(X,IBCNT,DAT) - .... ; - .... S X=$$SETSTR^VALM1(IBSTSMSG,"",6,75) - .... D SET(X,IBCNT,DAT) - .... Q - ... Q - .. Q - . Q - Q - ; -SRTBRK(LVL,SORT,IBSRT) ; sort break for display of certain sort data - ; LVL - sort level - ; SORT - sort letter code - ; IBSRT - subscript data - ; - NEW IBS,DSPDATA - I '$F(".A.D.N.","."_$G(SORT)_".") G SRTBRKX - S IBS=$$SD^IBCECSA(SORT) - S DSPDATA=IBSRT - I SORT="A" S DSPDATA=$P(DSPDATA,"~",1) ; biller name - I SORT="N" S DSPDATA=-DSPDATA ; number of days pending - D SET($J("",LVL-1)_IBS_": "_DSPDATA,IBCNT,"") -SRTBRKX ; - Q - ; -SET(X,CNT,DAT) ;set up list manager screen array - S VALMCNT=VALMCNT+1 - I 'CNT S CNT=1 - S ^TMP("IBCECSA",$J,VALMCNT,0)=X - S ^TMP("IBCECSA",$J,"IDX",VALMCNT,CNT)="" - I DAT'="" S ^TMP("IBCECSA",$J,CNT)=VALMCNT_U_DAT - Q - ; -SETL1(IB,X) ; - S X=$$SETFLD^VALM1($P($G(^DGCR(399,+IB,0)),U,1)_$P(IB,U,12),X,"BILL") - S X=$$SETFLD^VALM1($P(IB,U,2),X,"PNAME") - S X=$$SETFLD^VALM1($P(IB,U,3),X,"PANAME") - S X=$$SETFLD^VALM1($P(IB,U,4),X,"SSN") - S X=$$SETFLD^VALM1($$FMTE^XLFDT($P(IB,U,5),"2Z"),X,"SERVICE") - S X=$$SETFLD^VALM1($J("$"_$FN($P(IB,U,6),"",2),10),X,"CURBAL") - Q - ; -TXT(IBDA,LEN) ; Return a string of status message text - ; IBDA - ien to file 361 - ; LEN - desired maximum length of combined text string - NEW MSG,LN,STOP,TX,HLN,REFN,DELIM - S MSG="",LN=0,LEN=$G(LEN,75),STOP=0 - F S LN=$O(^IBM(361,+$G(IBDA),1,LN)) Q:'LN D Q:STOP - . S TX=$G(^IBM(361,IBDA,1,LN,0)) - . S TX=$$TRIM^XLFSTR(TX) - . ; Don't include parts added by ^IBCE277 - . Q:TX="Informational Message:" - . Q:TX="Warning Message:" - . Q:TX="Error Message:" - . I $E(TX,1,27)="Clearinghouse Trace Number:" S STOP=1 Q - . I $E(TX,1,18)="Payer Status Date:" S STOP=1 Q - . I $E(TX,1,19)="Payer Claim Number:" S STOP=1 Q - . I $E(TX,1,12)="Split Claim:" S STOP=1 Q - . I $E(TX,1,11)="Claim Type:" S STOP=1 Q - . I $E(TX,1,8)="Patient:" S STOP=1 Q - . I $E(TX,1,14)="Service Dates:" S STOP=1 Q - . I $E(TX,1,11)="Payer Name:" S STOP=1 Q - . I $E(TX,1,7)="Source:" S STOP=1 Q - . I TX["HL=" S HLN=+$P(TX,"HL=",2),DELIM="HL="_HLN,TX=$P(TX,DELIM,1)_"HL= "_$P(TX,DELIM,2,9) - . I TX["ENVOY REF: " S REFN=$E($P(TX,"ENVOY REF: ",2),1,14),DELIM="ENVOY REF: "_REFN,TX=$P(TX,DELIM,1)_"ENVOY REF: "_$P(TX,DELIM,2,9) - . I ($L(MSG)+$L(TX))>500 S STOP=1 Q - . S MSG=MSG_$S(MSG="":"",1:" ")_TX - . I $L(MSG)>LEN S STOP=1 - . Q - Q $E(MSG,1,LEN) - ; +IBCECSA1 ;ALB/CXW - IB STATUS AWAITING RESOLUTION SCREEN ;28-JUL-99 + ;;2.0;INTEGRATED BILLING;**137,283,288,320**;21-MAR-94 + ; DBIA for $$BN1^PRCAFN() + ; +BLD ; Build list entrypoint + N IBDA,IBREV,IBIFN,IBPAY,IBSSN,IBSER,IB399,IBLOC,IBDIV,IBUER,IBMSG,IBERR,IBPEN,SEVERITY,A,IBOAM,IBPAT,IBSTSMSG,SV1,SV2,SV3 + K ^TMP("IBCECSA",$J),^TMP("IBCECSB",$J),^TMP("IBCECSD",$J) + W !!,"Compiling CSA status messages ... " + S IBSEV=$G(IBSEV,"R") + S VALMCNT=0,IB364="" + S SEVERITY="" + F S SEVERITY=$O(^IBM(361,"ACSA",SEVERITY)) Q:SEVERITY="" I SEVERITY="R"!(IBSEV="B") S IBREV="" F S IBREV=$O(^IBM(361,"ACSA",SEVERITY,IBREV)) Q:IBREV="" I IBREV<2 S IBDA=0 F S IBDA=$O(^IBM(361,"ACSA",SEVERITY,IBREV,IBDA)) Q:'IBDA D + . S IB=$G(^IBM(361,IBDA,0)),IBIFN=+IB + . S IBPEN=$$FMDIFF^XLFDT(DT,$P(IB,U,2),1) + . ;quit if not pending for at least the minimum # of days requested + . Q:IBDAYS>IBPEN + . S IB399=$G(^DGCR(399,IBIFN,0)) + . ; + . ; no cancelled claims allowed on the CSA screen + . ; if we find one, then update the appropriate EDI files + . I $P(IB399,U,13)=7 D UPDEDI^IBCEM(+$P(IB,U,11),"C") Q + . ; + . ; automatically review this message if the claim was last printed on + . ; or after the MCS - 'Resubmit by Print' date + . I $P(IB,U,16),($P($G(^DGCR(399,IBIFN,"S")),U,14)\1)'<$P(IB,U,16) D UPDEDI^IBCEM(+$P(IB,U,11),"P") Q + . ; + . S IBDIV=+$P(IB399,U,22) + . S IBUER=+$P($G(^DGCR(399,IBIFN,"S")),U,11) + . ; + . ; If Request MRA bill, pull the MRA Requestor user instead + . I 'IBUER,$P(IB399,U,13)=2 S IBUER=+$P($G(^DGCR(399,IBIFN,"S")),U,8) + . I $D(^TMP("IBBIL",$J)),'$D(^TMP("IBBIL",$J,IBUER)) Q ; User not selected + . I $D(^TMP("IBDIV",$J)),'$D(^TMP("IBDIV",$J,IBDIV)) Q ; Div not selected + . ; + . S IBPAY=$P($G(^DIC(36,+$P($G(^DGCR(399,IBIFN,"MP")),U),0)),U) + . I IBPAY="" S IBPAY=$P($G(^DIC(36,+$$CURR^IBCEF2(IBIFN),0)),U) + . I IBPAY="" S IBPAY="UNKNOWN PAYER" + . S IBPAT=$G(^DPT(+$P(IB399,U,2),0)) + . S IBSSN=$E($P(IBPAT,U,9),6,9) I IBSSN="" S IBSSN="~unk" + . S IBPAT=$P(IBPAT,U,1) I IBPAT="" S IBPAT="~UNKNOWN PATIENT NAME" + . S IBSER=$P($G(^DGCR(399,IBIFN,"U")),U) + . S IBLOC=$P(IB399,U,4) + . S IBLOC=$S(IBLOC=1:"HOSPITAL",IBLOC=2:"SKILLED NURSING",1:"CLINIC") + . I IBDIV S IBDIV=$P($G(^DG(40.8,IBDIV,0)),U) + . I IBDIV=""!(IBDIV=0) S IBDIV="UNSPECIFIED" + . S IBMSG=$S($P(IB,U,8):"PAYER",1:"NON-PAYER") + . S IBUER=$S(IBUER:$P($G(^VA(200,IBUER,0)),U),1:"UNKNOWN")_"~"_IBUER + . S IB364=$P(IB,U,11) + . S IBOAM=$G(^DGCR(399,IBIFN,"U1")) + . S IBOAM=$P(IBOAM,U,1)-$P(IBOAM,U,2) ; current balance (total charges - offset) + . ; + . S IBSTSMSG=$$TXT(IBDA) ; status message text + . S IBERR=$E(IBSTSMSG,1,30) + . I IBERR="" S IBERR="-" + . ; + . S IB=$$BN1^PRCAFN(IBIFN) ; external bill# + . S A=IBIFN_U_IBPAY_U_IBPAT_U_IBSSN_U_IBSER_U_IBOAM_U_IBLOC_U_IBDIV_U_IBUER_U_IBMSG_U_IBPEN_U_$S(IBREV:"*",1:"")_U_IB364_U_IB + . ; + . S SV1=$$SRTV($G(IBSORT1),IBDA) + . S SV2=$$SRTV($G(IBSORT2),IBDA) + . S SV3=$$SRTV($G(IBSORT3),IBDA) + . S ^TMP("IBCECSB",$J,SV1,SV2,SV3,IBDA)=A + . S ^TMP("IBCECSB",$J,SV1,SV2,SV3,IBDA,"MSG")=IBSTSMSG + . Q + ; + I '$D(^TMP("IBCECSB",$J)) D NMAT Q + D SCRN + Q + ; +NMAT ;No CSA list + S VALMCNT=2,IBCNT=2 + S ^TMP("IBCECSA",$J,1,0)=" " + S ^TMP("IBCECSA",$J,2,0)="No Messages Matching Selection Criteria Found" + Q + ; +SRTV(SORT,IBDA) ; sort value calculation given the sort code letter + I SORT="" Q IBDA + Q $$SV^IBCECSA(SORT) + ; +SCRN ; + NEW IBSRT1,IBSRT2,IBSRT3,IBX,IBCNT,IBIFN,IBDA,IB,INFX,DAT,X + W !,"Building the CSA list display ... " + S IBCNT=0,IBSRT1="" + F S IBSRT1=$O(^TMP("IBCECSB",$J,IBSRT1)) Q:IBSRT1="" D + . D SRTBRK(1,$G(IBSORT1),IBSRT1) + . S IBSRT2="" + . F S IBSRT2=$O(^TMP("IBCECSB",$J,IBSRT1,IBSRT2)) Q:IBSRT2="" D + .. D SRTBRK(2,$G(IBSORT2),IBSRT2) + .. S IBSRT3="" + .. F S IBSRT3=$O(^TMP("IBCECSB",$J,IBSRT1,IBSRT2,IBSRT3)) Q:IBSRT3="" D + ... D SRTBRK(3,$G(IBSORT3),IBSRT3) + ... S IBDA=0 + ... F S IBDA=$O(^TMP("IBCECSB",$J,IBSRT1,IBSRT2,IBSRT3,IBDA)) Q:'IBDA D + .... S IB=$G(^TMP("IBCECSB",$J,IBSRT1,IBSRT2,IBSRT3,IBDA)) + .... S IBSTSMSG=$G(^TMP("IBCECSB",$J,IBSRT1,IBSRT2,IBSRT3,IBDA,"MSG")) + .... S IBIFN=+IB + .... S IB364=$P(IB,U,13) + .... S DAT=IBIFN_U_IBDA_U_IBSRT1_U_IBSRT2_U_IB364_U_IBSRT3 + .... ; + .... S IBCNT=IBCNT+1 + .... S X=$$SETFLD^VALM1($J(IBCNT,3),"","NUMBER") + .... D SETL1(IB,.X) + .... D SET(X,IBCNT,DAT) + .... ; + .... S X=$$SETSTR^VALM1(IBSTSMSG,"",6,75) + .... D SET(X,IBCNT,DAT) + .... Q + ... Q + .. Q + . Q + Q + ; +SRTBRK(LVL,SORT,IBSRT) ; sort break for display of certain sort data + ; LVL - sort level + ; SORT - sort letter code + ; IBSRT - subscript data + ; + NEW IBS,DSPDATA + I '$F(".A.D.N.","."_$G(SORT)_".") G SRTBRKX + S IBS=$$SD^IBCECSA(SORT) + S DSPDATA=IBSRT + I SORT="A" S DSPDATA=$P(DSPDATA,"~",1) ; biller name + I SORT="N" S DSPDATA=-DSPDATA ; number of days pending + D SET($J("",LVL-1)_IBS_": "_DSPDATA,IBCNT,"") +SRTBRKX ; + Q + ; +SET(X,CNT,DAT) ;set up list manager screen array + S VALMCNT=VALMCNT+1 + I 'CNT S CNT=1 + S ^TMP("IBCECSA",$J,VALMCNT,0)=X + S ^TMP("IBCECSA",$J,"IDX",VALMCNT,CNT)="" + I DAT'="" S ^TMP("IBCECSA",$J,CNT)=VALMCNT_U_DAT + Q + ; +SETL1(IB,X) ; + S X=$$SETFLD^VALM1($P($G(^DGCR(399,+IB,0)),U,1)_$P(IB,U,12),X,"BILL") + S X=$$SETFLD^VALM1($P(IB,U,2),X,"PNAME") + S X=$$SETFLD^VALM1($P(IB,U,3),X,"PANAME") + S X=$$SETFLD^VALM1($P(IB,U,4),X,"SSN") + S X=$$SETFLD^VALM1($$FMTE^XLFDT($P(IB,U,5),"2Z"),X,"SERVICE") + S X=$$SETFLD^VALM1($J("$"_$FN($P(IB,U,6),"",2),10),X,"CURBAL") + Q + ; +TXT(IBDA,LEN) ; Return a string of status message text + ; IBDA - ien to file 361 + ; LEN - desired maximum length of combined text string + NEW MSG,LN,STOP,TX,HLN,REFN,DELIM + S MSG="",LN=0,LEN=$G(LEN,75),STOP=0 + F S LN=$O(^IBM(361,+$G(IBDA),1,LN)) Q:'LN D Q:STOP + . S TX=$G(^IBM(361,IBDA,1,LN,0)) + . I $E(TX,1,5)="Error" S TX=$E(TX,6,999) + . S TX=$$TRIM^XLFSTR(TX) + . I $E(TX,1,8)="Patient:" S STOP=1 Q + . I $E(TX,1,14)="Service Dates:" S STOP=1 Q + . I $E(TX,1,11)="Payer Name:" S STOP=1 Q + . I $E(TX,1,7)="Source:" S STOP=1 Q + . I $E(TX,1,11)="Claim Line:" S STOP=1 Q + . I $E(TX,1,13)="Service Type:" S STOP=1 Q + . I TX["HL=" S HLN=+$P(TX,"HL=",2),DELIM="HL="_HLN,TX=$P(TX,DELIM,1)_"HL= "_$P(TX,DELIM,2,9) + . I TX["ENVOY REF: " S REFN=$E($P(TX,"ENVOY REF: ",2),1,14),DELIM="ENVOY REF: "_REFN,TX=$P(TX,DELIM,1)_"ENVOY REF: "_$P(TX,DELIM,2,9) + . I ($L(MSG)+$L(TX))>500 S STOP=1 Q + . S MSG=MSG_$S(MSG="":"",1:" ")_TX + . I $L(MSG)>LEN S STOP=1 + . Q + Q $E(MSG,1,LEN) + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCECSA3.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCECSA3.m index b58b80ab..336e9174 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCECSA3.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCECSA3.m @@ -1,165 +1,124 @@ -IBCECSA3 ;ALB/CXW - CLAIMS STATUS AWAITING RESOLUTION REPORT ;23-JUL-99 - ;;2.0;INTEGRATED BILLING;**137,320,371,377**;21-MAR-94;Build 23 - ;;Per VHA Directive 2004-038, this routine should not be modified. - Q -EN ; Report of claims status awaiting resolution - NEW %ZIS,ZTSAVE,ZTRTN,ZTDESC,DIR,X,Y,DIRUT,DTOUT,DUOUT,DIROUT,IBRVW - ; - D FULL^VALM1 - W ! - S DIR(0)="YO" ; IB*2*377 new question - S DIR("A")="Would you like to include Review Comments with this report" - S DIR("B")="No" - D ^DIR K DIR - I $D(DIRUT) Q - S IBRVW=Y - ; - W !!,"You will need a 132 column printer for this report!",! - ; - S %ZIS="QM" D ^%ZIS Q:POP - I $D(IO("Q")) K IO("Q") D Q - . S ZTRTN="LIST^IBCECSA3" - . S ZTSAVE("IBSORT1")="" - . S ZTSAVE("IBSORT2")="" - . S ZTSAVE("IBSORT3")="" - . S ZTSAVE("IBSORTOR")="" - . S ZTSAVE("^TMP(""IBCECSB"",$J,")="" - . S ZTSAVE("IBRVW")="" - . S ZTDESC="IB -Claims Status Awaiting Resolution Report" D ^%ZTLOAD K ZTSK D HOME^%ZIS - U IO -LIST ; display - N IBSTOP,X,IBPAGE,IBX,IBDIV,IBDA,IBPAY,IB,IBZ,IBZFT,IBFST,IBX2 - W:$E(IOST,1,2)["C-" @IOF ;Only initial form feed for print to screen - S (IBSTOP,IBPAGE,IBFST,IBDIV)=0 - I IBSORT1="D" S IBDIV=1 - I '$D(^TMP("IBCECSB",$J)) D G LISTQ - . D HDR1 W !,"No entries found for this report" - S IBX="" F S IBX=$O(^TMP("IBCECSB",$J,IBX)) Q:IBX=""!IBSTOP S IBX2="" F S IBX2=$O(^TMP("IBCECSB",$J,IBX,IBX2)) Q:IBX2=""!IBSTOP S IBX3="" F S IBX3=$O(^TMP("IBCECSB",$J,IBX,IBX2,IBX3)) Q:IBX3=""!IBSTOP D Q:IBSTOP - . I 'IBFST S IBPAY=$$IBPAY(IBX,IBX2,IBX3) D HDR1 S:'IBDIV IBFST=1 Q:IBSTOP - . S IBDA=0 F S IBDA=$O(^TMP("IBCECSB",$J,IBX,IBX2,IBX3,IBDA)) Q:'IBDA!IBSTOP S IB=$G(^TMP("IBCECSB",$J,IBX,IBX2,IBX3,IBDA)) D Q:IBSTOP - .. I ($Y+3)>IOSL D HDR1 Q:IBSTOP - .. W $$BN1^PRCAFN(+IB),$P(IB,U,12),?13,$E($P(IB,U,2),1,25),?40,$E($P(IB,U,3),1,30),?72,$P($P(IB,U,4),"~"),?78,$$DAT1^IBOUTL($P(IB,U,5)),?88,$E($P(IB,U,7),1,10),?100,"$"_$J($P(IB,U,6),0,2),?110,$P(IB,U,10),?122,$P(IB,U,11),! - .. I $P(IB,U,12)="*" W " ***** CSA REVIEW IN PROCESS *****",! - .. W " FORM TYPE: "_$P($G(^IBE(353,$P($G(^DGCR(399,+IB,0)),U,19),0)),U),! - .. I 'IBDIV S X=" DIVISION: "_$P(IB,U,8) W X,$J(" ",40-$L(X))_"AUTHORIZING BILLER: "_$P($P(IB,U,9),"~",1),! - .. W " MESSAGE TEXT: " S IBZFT=0 - .. S IBZ=0 F S IBZ=$O(^IBM(361,IBDA,1,IBZ)) Q:'IBZ D Q:IBSTOP - ... W:'IBZFT ?15 S X=$G(^IBM(361,IBDA,1,IBZ,0)) - ... F I=1:131:$L(X) W " "_$E(X,I,I+130),! - ... S IBZFT=1 - ... I ($Y+3)>IOSL D HDR1 Q:IBSTOP - ... Q - .. Q:IBSTOP - .. ; - .. ; Display the Review Comments if they exist based on user choice (IB*377) - .. I $G(IBRVW),+$O(^IBM(361,IBDA,2,0)) D Q:IBSTOP - ... N IBCM,IBT1,IBT0,IBD0,IBCL - ... I ($Y+3)>IOSL D HDR1 Q:IBSTOP - ... W ?3,"*** Review Comments for Claim "_$$BN1^PRCAFN(+IB)_" ***",! - ... S IBCM=0 F IBT1=0:1 S IBCM=$O(^IBM(361,IBDA,2,IBCM)) Q:'IBCM ; count up # of comments - ... S IBT0=0 - ... S IBCM=0 F S IBCM=$O(^IBM(361,IBDA,2,IBCM)) Q:'IBCM!IBSTOP D Q:IBSTOP - .... S IBT0=IBT0+1 - .... S IBD0=$G(^IBM(361,IBDA,2,IBCM,0)) - .... I ($Y+3)>IOSL D HDR1 Q:IBSTOP - .... W ?7,"Entered "_$$FMTE^XLFDT($P(IBD0,U,1),"5ZPM") - .... I $P(IBD0,U,2) W " by "_$P($G(^VA(200,$P(IBD0,U,2),0)),U,1) - .... W " ("_IBT0_" of "_IBT1_")",! - .... S IBCL=0 F S IBCL=$O(^IBM(361,IBDA,2,IBCM,1,IBCL)) Q:'IBCL!IBSTOP D Q:IBSTOP - ..... I ($Y+3)>IOSL D HDR1 Q:IBSTOP - ..... W ?10,$G(^IBM(361,IBDA,2,IBCM,1,IBCL,0)),! - ..... Q - .... Q - ... Q - .. ; - .. ; Display a line break before the next claim in this report - .. I ($Y+3)>IOSL D HDR1 Q:IBSTOP - .. W ! - .. Q - . Q - ; - G:IBSTOP LISTQ - I $E(IOST,1,2)["C-" K DIR S DIR(0)="E" D ^DIR K DIR -LISTQ I $D(ZTQUEUED) S ZTREQ="@" Q - W ! D ^%ZISC - Q -IBPAY(IBX,IBX2,IBX3) ; return biller name - N X - S X=$O(^TMP("IBCECSB",$J,IBX,IBX2,IBX3,0)) - S X=$G(^TMP("IBCECSB",$J,IBX,IBX2,IBX3,X)) - Q $P($P(X,U,9),"~",1) -HDR1 ; - N DIR,Y - I IBPAGE D Q:IBSTOP - . I $E(IOST,1,2)["C-" K DIR S DIR(0)="E" D ^DIR K DIR S IBSTOP=('Y) Q:IBSTOP - . W @IOF - S IBPAGE=IBPAGE+1 - W !,"Sort 1: ",$$SD^IBCECSA(IBSORT1) - W ?46,"Claims Status Awaiting Resolution Report",?120,$J("Page: "_IBPAGE,11) - W !,"Sort 2: ",$S($G(IBSORT2)'="":$$SD^IBCECSA(IBSORT2),1:"n/a") - W ?104,$J("Run Date: "_$$HTE^XLFDT($H,"2Z"),27) - W !,"Sort 3: ",$S($G(IBSORT3)'="":$$SD^IBCECSA(IBSORT3),1:"n/a") - I IBDIV W !!,"Division: "_$S($G(IBX)=0:"",1:$G(IBX)),!,"Authorizing Biller: "_$G(IBPAY) - W !,?72,"Last",?78,"Date of",?88,"Location",?100,"Current",?110,"Source of",?122,"Days Msg" - W !,"Bill #",?13,"Payer Name",?40,"Patient Name",?72,"4 SSN",?78,"Service",?88,"of Service",?100,"Balance",?110,"Message",?122,"Pending" - W !,$TR($J("",132)," ","-"),! - Q - ; - ; -RESORT ; CSA screen re-sort action - NEW DIR,X,Y,Z,IBSAVE,VALMQUIT,IBCURR - D FULL^VALM1 S VALMBCK="R" - W !!?2,"The CSA screen is currently sorted in the following manner:" - W !!?9,"Primary Sort: ",$S($G(IBSORT1)'="":$$SD^IBCECSA(IBSORT1),1:"n/a") - W !?7,"Secondary Sort: ",$S($G(IBSORT2)'="":$$SD^IBCECSA(IBSORT2),1:"n/a") - W !?8,"Tertiary Sort: ",$S($G(IBSORT3)'="":$$SD^IBCECSA(IBSORT3),1:"n/a") - ; - W ! - S DIR(0)="Y",DIR("A")="Would you like to change the sort criteria" - S DIR("B")="Yes" D ^DIR K DIR - I 'Y G RESORTX - ; - ; save the old sort criteria - S IBSAVE=$G(IBSORT1)_U_$G(IBSORT2)_U_$G(IBSORT3) - S Z="" F S Z=$O(IBSORTOR(Z)) Q:Z="" S IBSAVE=IBSAVE_U_Z_U_IBSORTOR(Z) - ; - W ! - K IBSORTOR - D SORT^IBCECSA(1,$P(IBSAVE,U,1)) I $G(VALMQUIT) G RES1 - D SORT^IBCECSA(2) I $G(VALMQUIT) G RES1 - I $G(IBSORT2)'="" D SORT^IBCECSA(3) I $G(VALMQUIT) G RES1 -RES1 ; - I $G(IBSORT1)="" S IBSORT1=$P(IBSAVE,U,1) ; need at least one - ; - ; see if the sort criteria changed - S IBCURR=$G(IBSORT1)_U_$G(IBSORT2)_U_$G(IBSORT3) - S Z="" F S Z=$O(IBSORTOR(Z)) Q:Z="" S IBCURR=IBCURR_U_Z_U_IBSORTOR(Z) - I IBSAVE=IBCURR G RESORTX ; no sort changes made at all - ; - ; time to rebuild the list because sorts have changed - I $G(IBDAYS)="" S IBDAYS=0 - I $G(IBSEV)="" S IBSEV="R" - D BLD^IBCECSA1 - S VALMBCK="R",VALMBG=1 - ; -RESORTX ; - Q - ; -MCS ; Link to the Multiple CSA Message Management option - NEW IBCSAMCS S IBCSAMCS=1 - D FULL^VALM1 S VALMBCK="R" - I '$$KCHK^XUSRB("IB MESSAGE MANAGEMENT") D G MCSX - . W !!?5,"You must hold the IB MESSAGE MANAGEMENT key to access this option." - . D PAUSE^VALM1 - . Q - ; - D ; call the MCS screen - . NEW IBSORT1,IBSORT2,IBSORT3,IBDAYS,IBSEV ; protect CSA vars - . D EN^IBCEMCL - . Q - ; - I $G(IBCSAMCS)=2 D BLD^IBCECSA1 S VALMBG=1 ; rebuild CSA - S VALMBCK="R" -MCSX ; - Q - ; +IBCECSA3 ;ALB/CXW - CLAIMS STATUS AWAITING RESOLUTION REPORT ;23-JUL-99 + ;;2.0;INTEGRATED BILLING;**137,320**;21-MAR-94 + Q +EN ; Report of claims status awaiting resolution + D FULL^VALM1 + W !!,"You will need a 132 column printer for this report!",! + ; + N %ZIS,ZTSAVE,ZTRTN,ZTDESC + S %ZIS="QM" D ^%ZIS Q:POP + I $D(IO("Q")) K IO("Q") D Q + . S ZTRTN="LIST^IBCECSA3" + . S ZTSAVE("IBSORT1")="" + . S ZTSAVE("IBSORT2")="" + . S ZTSAVE("IBSORT3")="" + . S ZTSAVE("IBSORTOR")="" + . S ZTSAVE("^TMP(""IBCECSB"",$J,")="" + . S ZTDESC="IB -Claims Status Awaiting Resolution Report" D ^%ZTLOAD K ZTSK D HOME^%ZIS + U IO +LIST ; display + N IBSTOP,X,IBPAGE,IBX,IBDIV,IBDA,IBPAY,IB,IBZ,IBZFT,IBFST,IBX2 + W:$E(IOST,1,2)["C-" @IOF ;Only initial form feed for print to screen + S (IBSTOP,IBPAGE,IBFST,IBDIV)=0 + I IBSORT1="D" S IBDIV=1 + I '$D(^TMP("IBCECSB",$J)) D G LISTQ + . D HDR1 W !,"No entries found for this report" + S IBX="" F S IBX=$O(^TMP("IBCECSB",$J,IBX)) Q:IBX=""!IBSTOP S IBX2="" F S IBX2=$O(^TMP("IBCECSB",$J,IBX,IBX2)) Q:IBX2=""!IBSTOP S IBX3="" F S IBX3=$O(^TMP("IBCECSB",$J,IBX,IBX2,IBX3)) Q:IBX3=""!IBSTOP D + . I 'IBFST S IBPAY=$$IBPAY(IBX,IBX2,IBX3) D HDR1 S:'IBDIV IBFST=1 Q:IBSTOP + . S IBDA=0 F S IBDA=$O(^TMP("IBCECSB",$J,IBX,IBX2,IBX3,IBDA)) Q:'IBDA!IBSTOP S IB=$G(^TMP("IBCECSB",$J,IBX,IBX2,IBX3,IBDA)) D + .. I ($Y+5)>IOSL D HDR1 Q:IBSTOP + .. W $$BN1^PRCAFN(+IB),?13,$E($P(IB,U,2),1,25),?40,$E($P(IB,U,3),1,30),?72,$P($P(IB,U,4),"~"),?78,$$DAT1^IBOUTL($P(IB,U,5)),?88,$E($P(IB,U,7),1,10),?100,"$"_$J($P(IB,U,6),0,2),?110,$P(IB,U,10),?122,$P(IB,U,11),! + .. W " FORM TYPE: "_$P($G(^IBE(353,$P($G(^DGCR(399,+IB,0)),U,19),0)),U),! + .. I 'IBDIV S X=" DIVISION: "_$P(IB,U,8) W X,$J(" ",40-$L(X))_"AUTHORIZING BILLER: "_$P($P(IB,U,9),"~",1),! + .. W " MESSAGE TEXT: " S IBZFT=0 + .. S IBZ=0 F S IBZ=$O(^IBM(361,IBDA,1,IBZ)) Q:'IBZ D Q:IBSTOP + ... W:'IBZFT ?15 S X=$G(^IBM(361,IBDA,1,IBZ,0)) + ... F I=1:131:$L(X) W " "_$E(X,I,I+130),! + ... S IBZFT=1 + ... I ($Y+5)>IOSL D HDR1 Q:IBSTOP + .. W ! + G:IBSTOP LISTQ + I $E(IOST,1,2)["C-" K DIR S DIR(0)="E" D ^DIR K DIR +LISTQ I $D(ZTQUEUED) S ZTREQ="@" Q + W ! D ^%ZISC + Q +IBPAY(IBX,IBX2,IBX3) ; return biller name + N X + S X=$O(^TMP("IBCECSB",$J,IBX,IBX2,IBX3,0)) + S X=$G(^TMP("IBCECSB",$J,IBX,IBX2,IBX3,X)) + Q $P($P(X,U,9),"~",1) +HDR1 ; + N DIR,Y + I IBPAGE D Q:IBSTOP + . I $E(IOST,1,2)["C-" K DIR S DIR(0)="E" D ^DIR K DIR S IBSTOP=('Y) Q:IBSTOP + . W @IOF + S IBPAGE=IBPAGE+1 + W !,"Sort 1: ",$$SD^IBCECSA(IBSORT1) + W ?46,"Claims Status Awaiting Resolution Report",?120,$J("Page: "_IBPAGE,11) + W !,"Sort 2: ",$S($G(IBSORT2)'="":$$SD^IBCECSA(IBSORT2),1:"n/a") + W ?104,$J("Run Date: "_$$HTE^XLFDT($H,"2Z"),27) + W !,"Sort 3: ",$S($G(IBSORT3)'="":$$SD^IBCECSA(IBSORT3),1:"n/a") + I IBDIV W !!,"Division: "_$S($G(IBX)=0:"",1:$G(IBX)),!,"Authorizing Biller: "_$G(IBPAY) + W !,?72,"Last",?78,"Date of",?88,"Location",?100,"Current",?110,"Source of",?122,"Days Msg" + W !,"Bill #",?13,"Payer Name",?40,"Patient Name",?72,"4 SSN",?78,"Service",?88,"of Service",?100,"Balance",?110,"Message",?122,"Pending" + W !,$TR($J("",132)," ","-"),! + Q + ; + ; +RESORT ; CSA screen re-sort action + NEW DIR,X,Y,Z,IBSAVE,VALMQUIT,IBCURR + D FULL^VALM1 S VALMBCK="R" + W !!?2,"The CSA screen is currently sorted in the following manner:" + W !!?9,"Primary Sort: ",$S($G(IBSORT1)'="":$$SD^IBCECSA(IBSORT1),1:"n/a") + W !?7,"Secondary Sort: ",$S($G(IBSORT2)'="":$$SD^IBCECSA(IBSORT2),1:"n/a") + W !?8,"Tertiary Sort: ",$S($G(IBSORT3)'="":$$SD^IBCECSA(IBSORT3),1:"n/a") + ; + W ! + S DIR(0)="Y",DIR("A")="Would you like to change the sort criteria" + S DIR("B")="Yes" D ^DIR K DIR + I 'Y G RESORTX + ; + ; save the old sort criteria + S IBSAVE=$G(IBSORT1)_U_$G(IBSORT2)_U_$G(IBSORT3) + S Z="" F S Z=$O(IBSORTOR(Z)) Q:Z="" S IBSAVE=IBSAVE_U_Z_U_IBSORTOR(Z) + ; + W ! + K IBSORTOR + D SORT^IBCECSA(1,$P(IBSAVE,U,1)) I $G(VALMQUIT) G RES1 + D SORT^IBCECSA(2) I $G(VALMQUIT) G RES1 + I $G(IBSORT2)'="" D SORT^IBCECSA(3) I $G(VALMQUIT) G RES1 +RES1 ; + I $G(IBSORT1)="" S IBSORT1=$P(IBSAVE,U,1) ; need at least one + ; + ; see if the sort criteria changed + S IBCURR=$G(IBSORT1)_U_$G(IBSORT2)_U_$G(IBSORT3) + S Z="" F S Z=$O(IBSORTOR(Z)) Q:Z="" S IBCURR=IBCURR_U_Z_U_IBSORTOR(Z) + I IBSAVE=IBCURR G RESORTX ; no sort changes made at all + ; + ; time to rebuild the list because sorts have changed + I $G(IBDAYS)="" S IBDAYS=0 + I $G(IBSEV)="" S IBSEV="R" + D BLD^IBCECSA1 + S VALMBCK="R",VALMBG=1 + ; +RESORTX ; + Q + ; +MCS ; Link to the Multiple CSA Message Management option + NEW IBCSAMCS S IBCSAMCS=1 + D FULL^VALM1 S VALMBCK="R" + I '$$KCHK^XUSRB("IB MESSAGE MANAGEMENT") D G MCSX + . W !!?5,"You must hold the IB MESSAGE MANAGEMENT key to access this option." + . D PAUSE^VALM1 + . Q + ; + D ; call the MCS screen + . NEW IBSORT1,IBSORT2,IBSORT3,IBDAYS,IBSEV ; protect CSA vars + . D EN^IBCEMCL + . Q + ; + I $G(IBCSAMCS)=2 D BLD^IBCECSA1 S VALMBG=1 ; rebuild CSA + S VALMBCK="R" +MCSX ; + Q + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCECSA4.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCECSA4.m index fc2c3cc1..6b9e6115 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCECSA4.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCECSA4.m @@ -1,223 +1,222 @@ -IBCECSA4 ;ALB/CXW - IB CLAIMS STATUS AWAITING RESOLUTION SCREEN ;5-AUG-1999 - ;;2.0;INTEGRATED BILLING;**137,155,320,371**;21-MAR-1994;Build 57 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -SMSG ;select message - N IBCOM,IBX,IBDAX,IBA - D SEL(.IBDAX,1) - I $O(IBDAX(""))="" G SMSGQ - S IBDAX=+$O(IBDAX(0)),IBA=$G(IBDAX(IBDAX)) - S IBX=$G(^TMP("IBCECSB",$J,$P(IBA,U,3),$P(IBA,U,4),$P(IBA,U,6),$P(IBA,U,2))) - I IBX'="" D - . Q:'$$LOCK^IBCEU0(361,$P(IBA,U,2)) - . D EN^VALM("IBCEM CSA MSG") - . D UNLOCK^IBCEU0(361,$P(IBA,U,2)) -SMSGQ S VALMBCK="R" - I $G(IBFASTXT) S VALMBCK="Q" K IBDAX - D:$O(IBDAX(0)) BLD^IBCECSA1 - Q - ; -COB ; COB management link from CSA - N IBA,IBX - ;IBX,IBA are killed during cancel execution - D FULL^VALM1 - D EN^IBCECOB - I $D(IBFASTXT) K IBFASTXT - S VALMBCK="R" - Q - ; -EDI ;History detail display - N IBIFN,IBX,IBA - D FULL^VALM1 - S IBDAX=$O(IBDAX(0)),IBIFN=+$G(IBDAX(IBDAX)) - D EDI2^IBCECOB2(IBIFN) - S VALMBCK="R" - Q -EOB ;View an EOB - N IBIFN,IBA,IBX - D FULL^VALM1 - S IBDAX=$O(IBDAX(0)),IBIFN=+$G(IBDAX(IBDAX)) - D EN^VALM("IBCEM VIEW EOB") - Q - ; -TPJI ;Third Party joint Inquiry - N IBIFN,IBX,IBA - D FULL^VALM1 - S IBDAX=$O(IBDAX(0)),IBIFN=+$G(IBDAX(IBDAX)) - D TPJI1^IBCECOB2(IBIFN) - S VALMBCK="R" - Q - ; -PBILL ;Print bill - not for resubmit - ; IB*320 - allow action for MRA request claims - N IBIFN,IBX,IBA,IBRESUB - D FULL^VALM1 - S IBDAX=$O(IBDAX(0)),IBIFN=+$G(IBDAX(+IBDAX)) - I "234"'[$P($G(^DGCR(399,IBIFN,0)),U,13) W !!,"Bill status must be REQUEST MRA, AUTHORIZED or PRNT/TX to print the bill." D PAUSE^VALM1 G PB1 - ; - ; don't update review status for MRA's - I $P($G(^DGCR(399,IBIFN,0)),U,13)=2 S IBRESUB=1 - E S IBRESUB=$$RESUB(IBIFN,1,"PX") - I IBRESUB'>0 W !,*7,"This is not a transmittable bill or review not needed" D PAUSE^VALM1 G PB1 - I IBRESUB=2 D G PB1 - . N IB364 - . S IB364=+$P($G(IBDAX(IBDAX)),U,5) - . D PRINT1^IBCEM03(IBIFN,.IBDAX,IB364) - D PBILL1^IBCECOB2(IBIFN) -PB1 ; - S VALMBCK="R" - Q - ; -CANCEL ;Cancel bill - N IBIFN,IB364,IBX,IBA,MRACHK - ; IBX,IBA will be killed during execution - need to protect them - D FULL^VALM1 - S IBDAX=$O(IBDAX(0)),IBIFN=+$G(IBDAX(+IBDAX)) - ; Check for security key - I '$$KCHK^XUSRB("IB AUTHORIZE") D G CANCELQ - . W !!?5,"You don't hold the proper security key to access this function." - . W !?5,"The necessary key is IB AUTHORIZE. Please see your manager." - . D PAUSE^VALM1 - . Q - D MRACHK I MRACHK G CANCELQ - S IB364=+$P($G(IBDAX(IBDAX)),U,5) - D CANCEL^IBCEM3(.IBDAX,IBIFN,IB364) -CANCELQ S VALMBCK="R" - Q - ; -CLONE ;'Copy/cancel bill' protocol action - N IBX,IBA,IB364,MRACHK,IBIFN - ; IBX,IBA will be killed during execution - need to protect them - D FULL^VALM1 - S IBDAX=$O(IBDAX("")),IBIFN=+$P($G(IBDAX(IBDAX)),U) - I IBDAX="" G CLONEQ - ; Check for security key - I '$$KCHK^XUSRB("IB AUTHORIZE") D G CLONEQ - . W !!?5,"You don't hold the proper security key to access this function." - . W !?5,"The necessary key is IB AUTHORIZE. Please see your manager." - . D PAUSE^VALM1 - . Q - D MRACHK I MRACHK G CLONEQ - S IB364=+$P($G(IBDAX(IBDAX)),U,5) - D COPYCLON^IBCECOB2(+$G(IBDAX(IBDAX)),IB364,.IBDAX) -CLONEQ S VALMBCK="R" - Q - ; -PRO ; Copy for secondary/tertiary bill - N IBIFNH,IBIFN,IB364,IBX,IBA,Z,IBCBASK,IBCBCOPY,IBCAN - D FULL^VALM1 - ;IBDAX - array from selection of message - S IBA=$G(IBDAX(+$G(IBDAX))) - G:'IBA PROQ - S IBX=$G(^TMP("IBCECSB",$J,$P(IBA,U,3),$P(IBA,U,4),$P(IBA,U,6),$P(IBA,U,2))),IBIFN=$P(IBA,U) - S IB364=+$P(IBA,U,5) - G:'IBIFN PROQ - ; - I $P($G(^DGCR(399,IBIFN,0)),U,13)=2 D G PROQ - . W !!?4,"This bill is in a status of REQUEST MRA." - . I $$CHK^IBCEMU1(IBIFN) W !?4,"MRA EOBs must be processed from the MRA management worklist." - . E W !?4,"There are no MRA EOBs on file." - . D PAUSE^VALM1 - . Q - ; - D COBCOPY^IBCECOB2(IBIFN,IB364,1,$P(IBA,U,2),"INIT^IBCECSA2") -PROQ S VALMBCK="R" - Q - ; -RES ;Resubmit bill by print - N IBTMP,IB364,IBIFN,IBX,IBA - D FULL^VALM1 - S (IBTMP,IBDAX)=$O(IBDAX(0)),IBTMP(IBTMP)=IBDAX(IBDAX) - S IBIFN=$P($G(IBDAX(+IBDAX)),U) - S IB364=+$P($G(IBDAX(IBDAX)),U,5) - I IBIFN D PRINT1^IBCEM03(IBIFN,.IBDAX,IB364),PAUSE^VALM1,INIT^IBCECSA2 - S IBDAX(IBTMP)=IBTMP(IBTMP) - S VALMBCK="R" - Q - ; -EBI ;Edit bill - N IBFLG,IBIFN,IB364,IBX,IBA - K ^TMP($J,"IBBILL") - D FULL^VALM1 - S IBDAX=$O(IBDAX("")) - I IBDAX="" G EDITQ - S IBIFN=$P(IBDAX(IBDAX),U) - S IBFLG=1 D I IBFLG S IBDAX="" D PAUSE^VALM1 G EDITQ - . I $P($G(^DGCR(399,IBIFN,0)),U,13)>2 W !,*7,"An authorized bill can not be edited." Q - . I '$D(^XUSEC("IB EDIT",DUZ)) W !,*7,"You are not authorized to edit a bill" Q - . S IBFLG=0 - S IBIFN=+$G(IBDAX(IBDAX)) - S IB364=+$P($G(IBDAX(IBDAX)),U,5) - D EBILL^IBCEM3(.IBDAX,IBIFN,IB364) -EDITQ S VALMBCK="R" - Q - ; -SEL(IBDA,ONE) ; Select entry(s) from list - ; IBDA = array returned if selections made - ; IBDAX(n)=ien of bill selected (file 399) - ; ONE = if set to 1, only one selection can be made at a time - N IB - K IBDA - D EN^VALM2($G(XQORNOD(0)),$S('$G(ONE):"",1:"S")) - S IBDA=0 F S IBDA=$O(VALMY(IBDA)) Q:'IBDA D - . S IBDA(IBDA)=$P($G(^TMP("IBCECSA",$J,IBDA)),U,2,7) - Q - ; -RESUB(IBIFN,TXMT,IBFUNC,IBTBA) ; Function asks if resubmit as resolution to a - ; message is the intention - ; IBIFN = ien of bill in file 399 - ; TXMT = flag if = 1, assume it's transmittable, don't have to check - ; IBFUNC = code to say where the code is called from - ; 'E'=edit/authorize 'P'=print 'PX'= print/not to resubmit 'C'=cancel - ; IBTBA = transmit bill array returned to calling routine. Optional - ; parameter to be passed by reference. - ; IBTBA(364ptr)="" - ; - ; Returns: - ; -1 = ^ or timeout at prompt - ; 0 = not a transmittable bill or review not needed - ; 1 = don't update the review status (user choice) - ; 2 = Yes, update the review status (user choice), or resubmit by print - ; - NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,STAT - KILL IBTBA - I '$G(TXMT),'$$TXMT^IBCEF4(IBIFN) S Y=0 G RESUB1 ; not transmittable - ; - ; Check for any messages or EOB's needing review - S STAT=$$STATUS^IBCEF4(IBIFN) - I '$TR(STAT,U) S Y=0 G RESUB1 ; no unreviewed items - I $P(STAT,U,1) S IBTBA($P(STAT,U,1))="" ; 364 ien for 361 data - I $P(STAT,U,2) S IBTBA($P(STAT,U,2))="" ; 364 ien for 361.1 data - ; - I IBFUNC'="P" D - . S DIR(0)="YA",DIR("A",1)="",DIR("A",2)="This bill is in need of review due to receipt of a status msg or EOB",DIR("A")="OK to update the review status to 'REVIEW COMPLETE' based on this action?: ",DIR("B")="NO" - . S DIR("?",1)="You have just "_$S(IBFUNC="E":"requested re-transmission of",IBFUNC="C":"cancelled",1:"")_" the bill" - . S DIR("?",2)="You can update the review status of the unreviewed message to ",DIR("?",3)=" 'REVIEW COMPLETE' if you say YES here" - . S DIR("?")="Press ENTER to continue " - . D ^DIR K DIR - . I $D(DTOUT)!$D(DUOUT) S Y=-1 Q - . S Y=Y+1 - E D - . W !,"The review status of this message will be updated to 'REVIEW COMPLETE'",!," based on this action" - . S Y=2 - ; -RESUB1 Q +Y - ; -RETXMT ; - N IB364,IBIFN - D FULL^VALM1 - S IBDAX=$O(IBDAX(0)),IB364=+$P($G(IBDAX(IBDAX)),U,5),IBIFN=+$P($G(IBDAX(IBDAX)),U) - I 'IB364!('IBIFN) G RETXMTQ - D MRACHK I MRACHK G RETXMTQ - D RESUB^IBCE(IB364) -RETXMTQ S VALMBCK="R" - Q - ; -MRACHK ; Restrict access to process REQUEST MRA claims - S MRACHK=0 - ; At least one MRA EOB appears on the MRA management worklist - I $P($G(^DGCR(399,IBIFN,0)),U,13)=2,$$MRAWL^IBCEMU2(IBIFN) S MRACHK=1 D D PAUSE^VALM1 - . W !,?4,"This bill is in a status of REQUEST MRA and it does appear on" - . W !,?4,"the MRA Management Worklist. Please use the MRA Management Menu" - . W !,?4,"options for all processing related to this bill." - Q +IBCECSA4 ;ALB/CXW - IB CLAIMS STATUS AWAITING RESOLUTION SCREEN ;5-AUG-1999 + ;;2.0;INTEGRATED BILLING;**137,155,320**;21-MAR-1994 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; +SMSG ;select message + N IBCOM,IBX,IBDAX,IBA + D SEL(.IBDAX,1) + I $O(IBDAX(""))="" G SMSGQ + S IBDAX=+$O(IBDAX(0)),IBA=$G(IBDAX(IBDAX)) + S IBX=$G(^TMP("IBCECSB",$J,$P(IBA,U,3),$P(IBA,U,4),$P(IBA,U,6),$P(IBA,U,2))) + I IBX'="" D + . Q:'$$LOCK^IBCEU0(361,$P(IBA,U,2)) + . D EN^VALM("IBCEM CSA MSG") + . D UNLOCK^IBCEU0(361,$P(IBA,U,2)) +SMSGQ S VALMBCK="R" + D:$O(IBDAX(0)) BLD^IBCECSA1 + Q + ; +COB ; COB management link from CSA + N IBA,IBX + ;IBX,IBA are killed during cancel execution + D FULL^VALM1 + D EN^IBCECOB + I $D(IBFASTXT) K IBFASTXT + S VALMBCK="R" + Q + ; +EDI ;History detail display + N IBIFN,IBX,IBA + D FULL^VALM1 + S IBDAX=$O(IBDAX(0)),IBIFN=+$G(IBDAX(IBDAX)) + D EDI2^IBCECOB2(IBIFN) + S VALMBCK="R" + Q +EOB ;View an EOB + N IBIFN,IBA,IBX + D FULL^VALM1 + S IBDAX=$O(IBDAX(0)),IBIFN=+$G(IBDAX(IBDAX)) + D EN^VALM("IBCEM VIEW EOB") + Q + ; +TPJI ;Third Party joint Inquiry + N IBIFN,IBX,IBA + D FULL^VALM1 + S IBDAX=$O(IBDAX(0)),IBIFN=+$G(IBDAX(IBDAX)) + D TPJI1^IBCECOB2(IBIFN) + S VALMBCK="R" + Q + ; +PBILL ;Print bill - not for resubmit + ; IB*320 - allow action for MRA request claims + N IBIFN,IBX,IBA,IBRESUB + D FULL^VALM1 + S IBDAX=$O(IBDAX(0)),IBIFN=+$G(IBDAX(+IBDAX)) + I "234"'[$P($G(^DGCR(399,IBIFN,0)),U,13) W !!,"Bill status must be REQUEST MRA, AUTHORIZED or PRNT/TX to print the bill." D PAUSE^VALM1 G PB1 + ; + ; don't update review status for MRA's + I $P($G(^DGCR(399,IBIFN,0)),U,13)=2 S IBRESUB=1 + E S IBRESUB=$$RESUB(IBIFN,1,"PX") + I IBRESUB'>0 W !,*7,"This is not a transmittable bill or review not needed" D PAUSE^VALM1 G PB1 + I IBRESUB=2 D G PB1 + . N IB364 + . S IB364=+$P($G(IBDAX(IBDAX)),U,5) + . D PRINT1^IBCEM03(IBIFN,.IBDAX,IB364) + D PBILL1^IBCECOB2(IBIFN) +PB1 ; + S VALMBCK="R" + Q + ; +CANCEL ;Cancel bill + N IBIFN,IB364,IBX,IBA,MRACHK + ; IBX,IBA will be killed during execution - need to protect them + D FULL^VALM1 + S IBDAX=$O(IBDAX(0)),IBIFN=+$G(IBDAX(+IBDAX)) + ; Check for security key + I '$$KCHK^XUSRB("IB AUTHORIZE") D G CANCELQ + . W !!?5,"You don't hold the proper security key to access this function." + . W !?5,"The necessary key is IB AUTHORIZE. Please see your manager." + . D PAUSE^VALM1 + . Q + D MRACHK I MRACHK G CANCELQ + S IB364=+$P($G(IBDAX(IBDAX)),U,5) + D CANCEL^IBCEM3(.IBDAX,IBIFN,IB364) +CANCELQ S VALMBCK="R" + Q + ; +CLONE ;'Copy/cancel bill' protocol action + N IBX,IBA,IB364,MRACHK,IBIFN + ; IBX,IBA will be killed during execution - need to protect them + D FULL^VALM1 + S IBDAX=$O(IBDAX("")),IBIFN=+$P($G(IBDAX(IBDAX)),U) + I IBDAX="" G CLONEQ + ; Check for security key + I '$$KCHK^XUSRB("IB AUTHORIZE") D G CLONEQ + . W !!?5,"You don't hold the proper security key to access this function." + . W !?5,"The necessary key is IB AUTHORIZE. Please see your manager." + . D PAUSE^VALM1 + . Q + D MRACHK I MRACHK G CLONEQ + S IB364=+$P($G(IBDAX(IBDAX)),U,5) + D COPYCLON^IBCECOB2(+$G(IBDAX(IBDAX)),IB364,.IBDAX) +CLONEQ S VALMBCK="R" + Q + ; +PRO ; Copy for secondary/tertiary bill + N IBIFNH,IBIFN,IB364,IBX,IBA,Z,IBCBASK,IBCBCOPY,IBCAN + D FULL^VALM1 + ;IBDAX - array from selection of message + S IBA=$G(IBDAX(+$G(IBDAX))) + G:'IBA PROQ + S IBX=$G(^TMP("IBCECSB",$J,$P(IBA,U,3),$P(IBA,U,4),$P(IBA,U,6),$P(IBA,U,2))),IBIFN=$P(IBA,U) + S IB364=+$P(IBA,U,5) + G:'IBIFN PROQ + ; + I $P($G(^DGCR(399,IBIFN,0)),U,13)=2 D G PROQ + . W !!?4,"This bill is in a status of REQUEST MRA." + . I $$CHK^IBCEMU1(IBIFN) W !?4,"MRA EOBs must be processed from the MRA management worklist." + . E W !?4,"There are no MRA EOBs on file." + . D PAUSE^VALM1 + . Q + ; + D COBCOPY^IBCECOB2(IBIFN,IB364,1,$P(IBA,U,2),"INIT^IBCECSA2") +PROQ S VALMBCK="R" + Q + ; +RES ;Resubmit bill by print + N IBTMP,IB364,IBIFN,IBX,IBA + D FULL^VALM1 + S (IBTMP,IBDAX)=$O(IBDAX(0)),IBTMP(IBTMP)=IBDAX(IBDAX) + S IBIFN=$P($G(IBDAX(+IBDAX)),U) + S IB364=+$P($G(IBDAX(IBDAX)),U,5) + I IBIFN D PRINT1^IBCEM03(IBIFN,.IBDAX,IB364),PAUSE^VALM1,INIT^IBCECSA2 + S IBDAX(IBTMP)=IBTMP(IBTMP) + S VALMBCK="R" + Q + ; +EBI ;Edit bill + N IBFLG,IBIFN,IB364,IBX,IBA + K ^TMP($J,"IBBILL") + D FULL^VALM1 + S IBDAX=$O(IBDAX("")) + I IBDAX="" G EDITQ + S IBIFN=$P(IBDAX(IBDAX),U) + S IBFLG=1 D I IBFLG S IBDAX="" D PAUSE^VALM1 G EDITQ + . I $P($G(^DGCR(399,IBIFN,0)),U,13)>2 W !,*7,"An authorized bill can not be edited." Q + . I '$D(^XUSEC("IB EDIT",DUZ)) W !,*7,"You are not authorized to edit a bill" Q + . S IBFLG=0 + S IBIFN=+$G(IBDAX(IBDAX)) + S IB364=+$P($G(IBDAX(IBDAX)),U,5) + D EBILL^IBCEM3(.IBDAX,IBIFN,IB364) +EDITQ S VALMBCK="R" + Q + ; +SEL(IBDA,ONE) ; Select entry(s) from list + ; IBDA = array returned if selections made + ; IBDAX(n)=ien of bill selected (file 399) + ; ONE = if set to 1, only one selection can be made at a time + N IB + K IBDA + D EN^VALM2($G(XQORNOD(0)),$S('$G(ONE):"",1:"S")) + S IBDA=0 F S IBDA=$O(VALMY(IBDA)) Q:'IBDA D + . S IBDA(IBDA)=$P($G(^TMP("IBCECSA",$J,IBDA)),U,2,7) + Q + ; +RESUB(IBIFN,TXMT,IBFUNC,IBTBA) ; Function asks if resubmit as resolution to a + ; message is the intention + ; IBIFN = ien of bill in file 399 + ; TXMT = flag if = 1, assume it's transmittable, don't have to check + ; IBFUNC = code to say where the code is called from + ; 'E'=edit/authorize 'P'=print 'PX'= print/not to resubmit 'C'=cancel + ; IBTBA = transmit bill array returned to calling routine. Optional + ; parameter to be passed by reference. + ; IBTBA(364ptr)="" + ; + ; Returns: + ; -1 = ^ or timeout at prompt + ; 0 = not a transmittable bill or review not needed + ; 1 = don't update the review status (user choice) + ; 2 = Yes, update the review status (user choice), or resubmit by print + ; + NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,STAT + KILL IBTBA + I '$G(TXMT),'$$TXMT^IBCEF4(IBIFN) S Y=0 G RESUB1 ; not transmittable + ; + ; Check for any messages or EOB's needing review + S STAT=$$STATUS^IBCEF4(IBIFN) + I '$TR(STAT,U) S Y=0 G RESUB1 ; no unreviewed items + I $P(STAT,U,1) S IBTBA($P(STAT,U,1))="" ; 364 ien for 361 data + I $P(STAT,U,2) S IBTBA($P(STAT,U,2))="" ; 364 ien for 361.1 data + ; + I IBFUNC'="P" D + . S DIR(0)="YA",DIR("A",1)="",DIR("A",2)="This bill is in need of review due to receipt of a status msg or EOB",DIR("A")="OK to update the review status to 'REVIEW COMPLETE' based on this action?: ",DIR("B")="NO" + . S DIR("?",1)="You have just "_$S(IBFUNC="E":"requested re-transmission of",IBFUNC="C":"cancelled",1:"")_" the bill" + . S DIR("?",2)="You can update the review status of the unreviewed message to ",DIR("?",3)=" 'REVIEW COMPLETE' if you say YES here" + . S DIR("?")="Press ENTER to continue " + . D ^DIR K DIR + . I $D(DTOUT)!$D(DUOUT) S Y=-1 Q + . S Y=Y+1 + E D + . W !,"The review status of this message will be updated to 'REVIEW COMPLETE'",!," based on this action" + . S Y=2 + ; +RESUB1 Q +Y + ; +RETXMT ; + N IB364,IBIFN + D FULL^VALM1 + S IBDAX=$O(IBDAX(0)),IB364=+$P($G(IBDAX(IBDAX)),U,5),IBIFN=+$P($G(IBDAX(IBDAX)),U) + I 'IB364!('IBIFN) G RETXMTQ + D MRACHK I MRACHK G RETXMTQ + D RESUB^IBCE(IB364) +RETXMTQ S VALMBCK="R" + Q + ; +MRACHK ; Restrict access to process REQUEST MRA claims + S MRACHK=0 + ; At least one MRA EOB appears on the MRA management worklist + I $P($G(^DGCR(399,IBIFN,0)),U,13)=2,$$MRAWL^IBCEMU2(IBIFN) S MRACHK=1 D D PAUSE^VALM1 + . W !,?4,"This bill is in a status of REQUEST MRA and it does appear on" + . W !,?4,"the MRA Management Worklist. Please use the MRA Management Menu" + . W !,?4,"options for all processing related to this bill." + Q diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF.m index 8d501d22..2b402a32 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF.m @@ -1,253 +1,247 @@ -IBCEF ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS ;22-JAN-96 - ;;2.0;INTEGRATED BILLING;**52,80,51,137,288,296,361,371**;21-MAR-94;Build 57 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ;IBIFN = bill ien throughout this routine -COB(IBIFN) ; Bill seq - N A - S A=$P($G(^DGCR(399,IBIFN,0)),U,21) S:A="" A="P" - Q A - ; -COBN(IBIFN,A) ; Return seq # of selected payer - ; A = 'PST' or null to get current bill payer seq # - I $G(A)="" S A=$$COB(IBIFN) S:"PST"'[A A="P" - I 'A S A=$F("PST",A)-1 S:A<1 A=1 - Q A - ; -POLICY(IBIFN,IBPC,IBCOBN) ; Return raw data from policy info on bill - ; IBPC = pc # of data element in policy (optional) - ; if null, 0-node is returned - ; IBCOBN = bill designation 1-3 or 'PST' (optional) - ; if null, default to current - N IBI - I "PST"[$G(IBCOBN) S IBCOBN=$$COBN(IBIFN,$G(IBCOBN)) - S IBI=$G(^DGCR(399,IBIFN,"I"_IBCOBN)) - I $G(IBPC) S IBI=$P(IBI,U,IBPC) -POLICYQ Q IBI - ; -INSADDR(IBIFN,IBCOB) ; Return insured's address in 7 pieces: - ; ALL STREET ADDRESSES^CITY^STATE ABBREVIATION^ZIP^STREET ADDRESS 1^ - ; STREET ADDRESS 2^STREET ADDRESS 3 - ; IBIFN = bill ien - ; IBCOB = bill designation (P)rimary, (S)econdary, (T)ertiary - ; or 1-2-3. If not defined or null, return current - ; If insured is patient or spouse, take from patient file top level - ; fields, then if top-level street addresses are blank and policy - ; level fields are not, use policy level - ; If insured is other than patient/spouse, use policy level fields only - N A,B,IBADDR,IBI,DFN,VAPA,VATEST - S:$G(IBCOB)="" IBCOB="" - I 'IBCOB S IBCOB=$$COBN(IBIFN,$G(IBCOB)) - S IBI=+$$POLICY(IBIFN,16,IBCOB) ; pt relationship to insured - S DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2) - I $S('IBI:1,1:"12"'[IBI) S IBADDR="" G INSADDQ - ; insured's address (patient/spouse) same as patient's - S VATEST("ADD",9)=+$G(^DGCR(399,IBIFN,"U")),VATEST("ADD",10)=+$P($G(^("U")),U,2) - D ADD^VADPT - S IBADDR=VAPA(1)_" "_VAPA(2)_" "_VAPA(3)_U_VAPA(4)_U_$P($G(^DIC(5,+VAPA(5),0)),U,2)_U_VAPA(6)_U_VAPA(1)_U_VAPA(2)_U_VAPA(3) -INSADDQ S A=$P($G(^DGCR(399,IBIFN,"M")),U,(11+IBCOB)) - S A=$G(^DPT(DFN,.312,+A,3)) - I $TR($P(IBADDR,U)," ")="" D PI3 - I IBI=2,$$NOPUNCT($P(A,U,6,10),1)'="" D PI3 - Q IBADDR - ; -PI3 ; build IBADDR string from patient insurance 3 node data - S $P(IBADDR,U,1)=$P(A,U,6)_" "_$P(A,U,7) - S $P(IBADDR,U,5,6)=$P(A,U,6,7) - F B=2,4 S $P(IBADDR,U,B)=$P(A,U,B+6) - S $P(IBADDR,U,3)=$P($G(^DIC(5,+$P(A,U,9),0)),U,2) - S $P(IBADDR,U,7)="" ; no street address 3 in file 2.312 - Q - ; -PTADDR(IBIFN,ELE) ;Return part of patient's permanent address - ;IBIFN = bill ien - ;ELE = subscript in ^UTILITY("VAPA", array for element needed - ; - I '$D(^UTILITY("VAPA",$J)) D ; once per pt - .N VAHOW,DFN,VAPA - .S VAHOW=2,DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2),VAPA("P")="" - .D ADD^VADPT - Q $P($G(^UTILITY("VAPA",$J,ELE)),U) - ; -PTDEM(IBIFN,ELE,PC) ;Return part of patient's demographics - ;IBIFN = bill ien - ;ELE = subscript in ^UTILITY("VADM" array for demographic element needed - ;PC = pc of string at subscript ELE to be returned - ; - I '$G(PC) S PC=1 - I '$D(^UTILITY("VADM",$J)) D ; once per pt - .N VAHOW,DFN,VADM - .S VAHOW=2,DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2) - .D DEM^VADPT - Q $P($G(^UTILITY("VADM",$J,ELE)),U,PC) - ; -PTEMPL(IBIFN,ELE,WHOSE,VAOA) ;Return part of pt's or spouse's employer info - ;ELE = subscript in VAOA array for employer element needed - ;WHOSE = 6 if spouse's info needed 5 if pt info needed (DEFAULT) - ; - N DFN - S DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2),VAOA("A")=$S($G(WHOSE):WHOSE,1:5) - D OAD^VADPT - Q $P($G(VAOA(ELE)),U) - ; -INSDEM(IBIFN,IBCOB) ; Return insured's demographics in 6 pieces: - ; DATE OF BIRTH^SEX^PHONE^BRANCH pointer^RANK^SSN(no dashes) - ; IBIFN = bill ien - ; IBCOB = bill designation (P)rimary (default), (S)econdary, (T)ertiary - ; or 1,2,3 ... if not defined or null, return current - ; If insured is patient/spouse, take from patient file top level - ; fields, then if top-level are blank and policy level aren't, - ; use policy level - ; If insured other than patient/spouse, use policy level fields only - N A,B,IBDEM,IBI,DFN,VADM - S:$G(IBCOB)="" IBCOB="" - S:'IBCOB IBCOB=$$COBN(IBIFN,IBCOB) - S IBI=$$WHOSINS(IBIFN,IBCOB) - S DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2) - I $S('IBI:1,1:"12"'[IBI) S IBDEM="" G INSDEM1 - ; If it gets here, assume insured is patient/spouse - S A=$$PTDEM(IBIFN,0),A=$$PTADDR(IBIFN,0) - F A=2,3,5 S VADM(A)=$P($G(^UTILITY("VADM",$J,A)),U) - S VAPA(8)=$P($G(^UTILITY("VAPA",$J,8)),U) - I VADM(5)="",'VADM(3),VAPA(8)="" S IBDEM="" G INSDEM1 - S $P(IBDEM,U,3)=VAPA(8),$P(IBDEM,U,6)=VADM(2) - I IBI=1,VADM(3) S $P(IBDEM,U)=VADM(3) ;Patient's own policy only -INSDEM1 S A=$P($G(^DGCR(399,IBIFN,"M")),U,(11+IBCOB)) - S A=$G(^DPT(DFN,.312,+A,3)) - S:"MF"'[$G(VADM(5)) VADM(5)="" - S $P(IBDEM,U,2)=$S(IBI=1:VADM(5),1:$P(A,U,12)) - S $P(IBDEM,U,4,5)=$P(A,U,2)_U_$P(A,U,3) - S:'$P(IBDEM,U) $P(IBDEM,U)=$P(A,U) - S:$P(IBDEM,U,3)="" $P(IBDEM,U,3)=$P(A,U,11) - S:$P(IBDEM,U,6)="" $P(IBDEM,U,6)=$P(A,U,5) - Q IBDEM - ; -INSEMPL(IBIFN,IBCOB) ; Return insured's employer data in 5 pieces: - ; EMPLOYER NAME^EMPLOYER CITY^EMPLOYER STATE ABBREVIATION^STATE IEN^STREET 1 - ; IBCOB = bill designation (P)rimary-default, (S)econdary, (T)ertiary - ; or 123 - if not defined or null, return current - N A,IBEMPL,IBI,DFN,VAOA - S IBI=$$WHOSINS(IBIFN,$G(IBCOB)) - I $S('IBI:1,1:"12"'[IBI) S IBEMPL="^^" G INSEMPQ - ; insured = pt/spouse - S DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2) - S A=$$PTEMPL(IBIFN,0,IBI+4,.VAOA) - S IBEMPL=VAOA(9)_U_VAOA(4)_U_$P($G(^DIC(5,+VAOA(5),0)),U,2)_U_+VAOA(5)_U_VAOA(1) -INSEMPQ Q IBEMPL - ; -WHOSINS(IBIFN,IBCOB) ; Determine who is insured for bill IBIFN and - ; seq of coverage COB (123 or PST) or if not defined or null, current - N Z,Z0,VAEL,DFN - S Z=+$$POLICY(IBIFN,16,$G(IBCOB)) - I 'Z D - .S Z0=$$POLICY(IBIFN,6,$G(IBCOB)),DFN=$P($G(^DGCR(399,IBIFN,0)),U,2) - .I Z0="v" D ELIG^VADPT I VAEL(4) S Z=1 Q ;vet is pt - .I Z0="s" D ELIG^VADPT I VAEL(4) S Z=2 Q ;vet is pt, so vets spouse is pt's spouse - .S Z=9 ; relationship of insured to pt unknown - Q Z - ; -EMPSTAT(IBIFN,WHOSE) ;Return employment status - ; IBIFN = bill ien - ; WHOSE = v for vet, s for spouse status - N STAT,DFN,VAPD - S STAT="",DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2) - I WHOSE="v" D OPD^VADPT S STAT=$P(VAPD(7),U) - I WHOSE="s" S STAT=$P($G(^DPT(DFN,.25)),U,15) - I STAT="" S STAT=9 - Q STAT - ; -INPAT(IBIFN,OUT) ; Determine if bill is inpatient - ; OUT = optional - if 1, return output value based on - ; inpatient/outpatient from UB-04 type of bill field - ; Return 1 if inpatient, 0 if not inpatient or can't be determined - N INPT,CODE,CODE0,IB0 - S IB0=$G(^DGCR(399,IBIFN,0)) - S OUT=+$G(OUT),CODE=+$P(IB0,U,5) - I 'OUT S INPT=CODE - I OUT D - . S CODE0=$P($G(^DGCR(399.1,+$P(IB0,U,25),0)),U,2) - . I CODE0=8,$P(IB0,U,24)=1 S INPT=$P(IB0,U,5) Q ; 18X - . I CODE0=9,$P(IB0,U,24)=8 S INPT=$P(IB0,U,5) Q ; 89X - . I CODE0=1,$P(IB0,U,24)=8 S INPT=0 Q ; 81X - . I CODE0=1,$P(IB0,U,24)=7 S INPT=0 Q ; 71X - . I CODE0=2,$P(IB0,U,24)=7 S INPT=0 Q ; 72X - . S INPT=CODE0 - Q $S(INPT:INPT'>2,1:0) - ; -INSPRF(IBIFN) ; Function to determine if bill is prof or inst - ; Return 1 if institutional (UB-04) claim, 0 if professional (CMS-1500) claim - N A - S A=$G(^DGCR(399,IBIFN,0)) - I $P(A,U,27)="" S $P(A,U,27)=$S($P(A,U,19)=3:1,1:0) - Q $S($P(A,U,27)=1:1,1:0) - ; -F(FLD,IBXRET,IBXERR1,IBIEN) ;Execute extract for data element FLD and bill IBIEN - ; If IBXDATA array to be returned as data value(s) of fld - ; D F^IBCEF("FLD NAME","IBXDATA","IBXERR") or D F^IBCEF("FLD NAME") - ; Variable ref-ed by IBXERR1 will contain error message if an error - ; @IBXRET always defined on return. It will be null if error - I $G(IBIEN) N IBXIEN S IBXIEN=IBIEN - I $G(IBXERR1)="" S IBXERR1="IBXERR" - N IBXHOLD - S IBXHOLD="" - I $G(IBXRET)=""!($G(IBXRET)="IBXDATA") S IBXHOLD="IBXDATA",IBXRET="IBXRET" - S @IBXERR1="" - ; - N FLDN,OFLD,STOP,Z,IBXERR2,IBXRETX - ; - I '$G(IBXIEN) S @IBXERR1="Invalid entry #" G FQ - I '$D(^IBA(364.5,"B",FLD)) S OFLD=FLD,STOP=0 D I FLD="" S @IBXERR1=OFLD_" Field not found!!" G FQ - .F S FLD=$O(^IBA(364.5,"B",FLD)) D Q:STOP - ..I $E(FLD,1,$L(OFLD))'=OFLD S FLD="" - ..S STOP=1 - ; - S Z=0 - F S Z=$O(^IBA(364.5,"B",FLD,Z)) Q:'Z I $P($G(^IBA(364.5,Z,0)),U,5)=399 Q - I 'Z S @IBXERR1=FLD_" Field not found!!" G FQ - ; - S FLDN(1)=Z D EXTONE^IBCEFG0(IBXIEN,.FLDN,""_IBXRET_"",.IBXERR2) - ; - I $G(IBXERR2)'="" S @IBXERR1=IBXERR2 -FQ S IBXARRY=$S(IBXHOLD="IBXDATA":"IBXDATA",1:""_IBXRET_"") - I @IBXERR1'="" K @IBXARRY S @IBXARRY="" Q - ; - I IBXHOLD="IBXDATA" S IBXRET="IBXRET" - M IBXRETX=@IBXRET K @IBXARRY M @IBXARRY=IBXRETX(1) - S:'($D(@IBXARRY)#2) @IBXARRY="" - Q - ; -SERVDT(IBIFN,LENGTH,FORMAT) ; Return default service date for - ; outpatient/UB-04 lines or X12-837 institutional lines - ; LENGTH = null/8 for 8 digit date, 6 for 6 digit date - ; FORMAT = 1 = X12 format (YYYYMMDD), 2 = FM internal (NNNNNNN), - ; 0 = external (MMDDYY or MMDDYYYY) - N IBZ - G:$$INPAT^IBCEF(IBIFN,1)!($$FT^IBCEF(IBIFN)'=3) SERVDTQ ;Inpatient claim or billed on a CMS-1500 - S LENGTH=$G(LENGTH),FORMAT=$G(FORMAT) - D F("N-STATEMENT COVERS FROM DATE","IBZ",,IBIFN) - I '$G(IBZ)!(FORMAT=2) G SERVDTQ - ; - I FORMAT=1 S IBZ=$$DT^IBCEFG1(IBZ,"",$S(LENGTH'=6:"D8",1:"D6")) G SERVDTQ - S IBZ=$$DATE^IBCF2(IBZ,$S(LENGTH=6:0,1:1),1) - ; -SERVDTQ Q $G(IBZ) - ; -NOPUNCT(X,SPACE,EXC) ; Strip punctuation from data in X - ; SPACE = flag if 1 strip SPACES - ; EXC = list of punctuation not to strip - ; - N PUNCT,Z - S PUNCT=".,-+(){}[]\/><:;?|=_*&%$#@!~`^'""" - I $G(SPACE) S PUNCT=PUNCT_" " - I $G(EXC)'="" F Z=1:1:$L(EXC) S PUNCT=$TR(PUNCT,$E(EXC,Z)) - S X=$TR(X,PUNCT) - Q X - ; -FT(IBIFN) ; Internal code for bill form type - Q +$P($G(^DGCR(399,IBIFN,0)),U,19) - ; -COBCT(IBIFN) ; # of payers on claim - N CT,Z - S CT=0 F Z="I1","I2","I3" Q:'$D(^DGCR(399,IBIFN,Z)) S CT=CT+1 - Q CT - ; +IBCEF ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS ;22-JAN-96 + ;;2.0;INTEGRATED BILLING;**52,80,51,137,288,296,361**;21-MAR-94;Build 9 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; + ;IBIFN = bill ien throughout this routine +COB(IBIFN) ; Bill seq + N A + S A=$P($G(^DGCR(399,IBIFN,0)),U,21) S:A="" A="P" + Q A + ; +COBN(IBIFN,A) ; Return seq # of selected payer + ; A = 'PST' or null to get current bill payer seq # + I $G(A)="" S A=$$COB(IBIFN) S:"PST"'[A A="P" + I 'A S A=$F("PST",A)-1 S:A<1 A=1 + Q A + ; +POLICY(IBIFN,IBPC,IBCOBN) ; Return raw data from policy info on bill + ; IBPC = pc # of data element in policy (optional) + ; if null, 0-node is returned + ; IBCOBN = bill designation 1-3 or 'PST' (optional) + ; if null, default to current + N IBI + I "PST"[$G(IBCOBN) S IBCOBN=$$COBN(IBIFN,$G(IBCOBN)) + S IBI=$G(^DGCR(399,IBIFN,"I"_IBCOBN)) + I $G(IBPC) S IBI=$P(IBI,U,IBPC) +POLICYQ Q IBI + ; +INSADDR(IBIFN,IBCOB) ; Return insured's address in 7 pieces: + ; ALL STREET ADDRESSES^CITY^STATE ABBREVIATION^ZIP^STREET ADDRESS 1^ + ; STREET ADDRESS 2^STREET ADDRESS 3 + ; IBIFN = bill ien + ; IBCOB = bill designation (P)rimary, (S)econdary, (T)ertiary + ; or 1-2-3. If not defined or null, return current + ; If insured is patient or spouse, take from patient file top level + ; fields, then if top-level street addresses are blank and policy + ; level fields are not, use policy level + ; If insured is other than patient/spouse, use policy level fields only + N A,B,IBADDR,IBI,DFN,VAPA,VATEST + S:$G(IBCOB)="" IBCOB="" + I 'IBCOB S IBCOB=$$COBN(IBIFN,$G(IBCOB)) + S IBI=+$$POLICY(IBIFN,16,IBCOB) + S DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2) + I $S('IBI:1,1:"12"'[IBI) S IBADDR="" G INSADDQ + ; insured's address (patient/spouse) same as patient's + S VATEST("ADD",9)=+$G(^DGCR(399,IBIFN,"U")),VATEST("ADD",10)=+$P($G(^("U")),U,2) + D ADD^VADPT + S IBADDR=VAPA(1)_" "_VAPA(2)_" "_VAPA(3)_U_VAPA(4)_U_$P($G(^DIC(5,+VAPA(5),0)),U,2)_U_VAPA(6)_U_VAPA(1)_U_VAPA(2)_U_VAPA(3) +INSADDQ S A=$P($G(^DGCR(399,IBIFN,"M")),U,(11+IBCOB)) + S A=$G(^DPT(DFN,.312,+A,3)) + I $TR($P(IBADDR,U)," ")="" D + .S $P(IBADDR,U)=$P(A,U,6)_" "_$P(A,U,7),$P(IBADDR,U,5,6)=$P(A,U,6,7) + .F B=2,4 S $P(IBADDR,U,B)=$P(A,U,B+6) + .S $P(IBADDR,U,3)=$P($G(^DIC(5,+$P(A,U,9),0)),U,2) + Q IBADDR + ; +PTADDR(IBIFN,ELE) ;Return part of patient's permanent address + ;IBIFN = bill ien + ;ELE = subscript in ^UTILITY("VAPA", array for element needed + ; + I '$D(^UTILITY("VAPA",$J)) D ; once per pt + .N VAHOW,DFN,VAPA + .S VAHOW=2,DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2),VAPA("P")="" + .D ADD^VADPT + Q $P($G(^UTILITY("VAPA",$J,ELE)),U) + ; +PTDEM(IBIFN,ELE,PC) ;Return part of patient's demographics + ;IBIFN = bill ien + ;ELE = subscript in ^UTILITY("VADM" array for demographic element needed + ;PC = pc of string at subscript ELE to be returned + ; + I '$G(PC) S PC=1 + I '$D(^UTILITY("VADM",$J)) D ; once per pt + .N VAHOW,DFN,VADM + .S VAHOW=2,DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2) + .D DEM^VADPT + Q $P($G(^UTILITY("VADM",$J,ELE)),U,PC) + ; +PTEMPL(IBIFN,ELE,WHOSE,VAOA) ;Return part of pt's or spouse's employer info + ;ELE = subscript in VAOA array for employer element needed + ;WHOSE = 6 if spouse's info needed 5 if pt info needed (DEFAULT) + ; + N DFN + S DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2),VAOA("A")=$S($G(WHOSE):WHOSE,1:5) + D OAD^VADPT + Q $P($G(VAOA(ELE)),U) + ; +INSDEM(IBIFN,IBCOB) ; Return insured's demographics in 6 pieces: + ; DATE OF BIRTH^SEX^PHONE^BRANCH pointer^RANK^SSN(no dashes) + ; IBIFN = bill ien + ; IBCOB = bill designation (P)rimary (default), (S)econdary, (T)ertiary + ; or 1,2,3 ... if not defined or null, return current + ; If insured is patient/spouse, take from patient file top level + ; fields, then if top-level are blank and policy level aren't, + ; use policy level + ; If insured other than patient/spouse, use policy level fields only + N A,B,IBDEM,IBI,DFN,VADM + S:$G(IBCOB)="" IBCOB="" + S:'IBCOB IBCOB=$$COBN(IBIFN,IBCOB) + S IBI=$$WHOSINS(IBIFN,IBCOB) + S DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2) + I $S('IBI:1,1:"12"'[IBI) S IBDEM="" G INSDEM1 + ; If it gets here, assume insured is patient/spouse + S A=$$PTDEM(IBIFN,0),A=$$PTADDR(IBIFN,0) + F A=2,3,5 S VADM(A)=$P($G(^UTILITY("VADM",$J,A)),U) + S VAPA(8)=$P($G(^UTILITY("VAPA",$J,8)),U) + I VADM(5)="",'VADM(3),VAPA(8)="" S IBDEM="" G INSDEM1 + S $P(IBDEM,U,3)=VAPA(8),$P(IBDEM,U,6)=VADM(2) + I IBI=1,VADM(3) S $P(IBDEM,U)=VADM(3) ;Patient's own policy only +INSDEM1 S A=$P($G(^DGCR(399,IBIFN,"M")),U,(11+IBCOB)) + S A=$G(^DPT(DFN,.312,+A,3)) + S:"MF"'[$G(VADM(5)) VADM(5)="" + S $P(IBDEM,U,2)=$S(IBI=1:VADM(5),1:$P(A,U,12)) + S $P(IBDEM,U,4,5)=$P(A,U,2)_U_$P(A,U,3) + S:'$P(IBDEM,U) $P(IBDEM,U)=$P(A,U) + S:$P(IBDEM,U,3)="" $P(IBDEM,U,3)=$P(A,U,11) + S:$P(IBDEM,U,6)="" $P(IBDEM,U,6)=$P(A,U,5) + Q IBDEM + ; +INSEMPL(IBIFN,IBCOB) ; Return insured's employer data in 5 pieces: + ; EMPLOYER NAME^EMPLOYER CITY^EMPLOYER STATE ABBREVIATION^STATE IEN^STREET 1 + ; IBCOB = bill designation (P)rimary-default, (S)econdary, (T)ertiary + ; or 123 - if not defined or null, return current + N A,IBEMPL,IBI,DFN,VAOA + S IBI=$$WHOSINS(IBIFN,$G(IBCOB)) + I $S('IBI:1,1:"12"'[IBI) S IBEMPL="^^" G INSEMPQ + ; insured = pt/spouse + S DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2) + S A=$$PTEMPL(IBIFN,0,IBI+4,.VAOA) + S IBEMPL=VAOA(9)_U_VAOA(4)_U_$P($G(^DIC(5,+VAOA(5),0)),U,2)_U_+VAOA(5)_U_VAOA(1) +INSEMPQ Q IBEMPL + ; +WHOSINS(IBIFN,IBCOB) ; Determine who is insured for bill IBIFN and + ; seq of coverage COB (123 or PST) or if not defined or null, current + N Z,Z0,VAEL,DFN + S Z=+$$POLICY(IBIFN,16,$G(IBCOB)) + I 'Z D + .S Z0=$$POLICY(IBIFN,6,$G(IBCOB)),DFN=$P($G(^DGCR(399,IBIFN,0)),U,2) + .I Z0="v" D ELIG^VADPT I VAEL(4) S Z=1 Q ;vet is pt + .I Z0="s" D ELIG^VADPT I VAEL(4) S Z=2 Q ;vet is pt, so vets spouse is pt's spouse + .S Z=9 ; relationship of insured to pt unknown + Q Z + ; +EMPSTAT(IBIFN,WHOSE) ;Return employment status + ; IBIFN = bill ien + ; WHOSE = v for vet, s for spouse status + N STAT,DFN,VAPD + S STAT="",DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2) + I WHOSE="v" D OPD^VADPT S STAT=$P(VAPD(7),U) + I WHOSE="s" S STAT=$P($G(^DPT(DFN,.25)),U,15) + I STAT="" S STAT=9 + Q STAT + ; +INPAT(IBIFN,OUT) ; Determine if bill is inpatient + ; OUT = optional - if 1, return output value based on + ; inpatient/outpatient from UB-04 type of bill field + ; Return 1 if inpatient, 0 if not inpatient or can't be determined + N INPT,CODE,CODE0,IB0 + S IB0=$G(^DGCR(399,IBIFN,0)) + S OUT=+$G(OUT),CODE=+$P(IB0,U,5) + I 'OUT S INPT=CODE + I OUT D + . S CODE0=$P($G(^DGCR(399.1,+$P(IB0,U,25),0)),U,2) + . I CODE0=8,$P(IB0,U,24)=1 S INPT=$P(IB0,U,5) Q ; 18X + . I CODE0=9,$P(IB0,U,24)=8 S INPT=$P(IB0,U,5) Q ; 89X + . I CODE0=1,$P(IB0,U,24)=8 S INPT=0 Q ; 81X + . I CODE0=1,$P(IB0,U,24)=7 S INPT=0 Q ; 71X + . I CODE0=2,$P(IB0,U,24)=7 S INPT=0 Q ; 72X + . S INPT=CODE0 + Q $S(INPT:INPT'>2,1:0) + ; +INSPRF(IBIFN) ; Function to determine if bill is prof or inst + ; Return 1 if institutional (UB-04) claim, 0 if professional (CMS-1500) claim + N A + S A=$G(^DGCR(399,IBIFN,0)) + I $P(A,U,27)="" S $P(A,U,27)=$S($P(A,U,19)=3:1,1:0) + Q $S($P(A,U,27)=1:1,1:0) + ; +F(FLD,IBXRET,IBXERR1,IBIEN) ;Execute extract for data element FLD and bill IBIEN + ; If IBXDATA array to be returned as data value(s) of fld + ; D F^IBCEF("FLD NAME","IBXDATA","IBXERR") or D F^IBCEF("FLD NAME") + ; Variable ref-ed by IBXERR1 will contain error message if an error + ; @IBXRET always defined on return. It will be null if error + I $G(IBIEN) N IBXIEN S IBXIEN=IBIEN + I $G(IBXERR1)="" S IBXERR1="IBXERR" + N IBXHOLD + S IBXHOLD="" + I $G(IBXRET)=""!($G(IBXRET)="IBXDATA") S IBXHOLD="IBXDATA",IBXRET="IBXRET" + S @IBXERR1="" + ; + N FLDN,OFLD,STOP,Z,IBXERR2,IBXRETX + ; + I '$G(IBXIEN) S @IBXERR1="Invalid entry #" G FQ + I '$D(^IBA(364.5,"B",FLD)) S OFLD=FLD,STOP=0 D I FLD="" S @IBXERR1=OFLD_" Field not found!!" G FQ + .F S FLD=$O(^IBA(364.5,"B",FLD)) D Q:STOP + ..I $E(FLD,1,$L(OFLD))'=OFLD S FLD="" + ..S STOP=1 + ; + S Z=0 + F S Z=$O(^IBA(364.5,"B",FLD,Z)) Q:'Z I $P($G(^IBA(364.5,Z,0)),U,5)=399 Q + I 'Z S @IBXERR1=FLD_" Field not found!!" G FQ + ; + S FLDN(1)=Z D EXTONE^IBCEFG0(IBXIEN,.FLDN,""_IBXRET_"",.IBXERR2) + ; + I $G(IBXERR2)'="" S @IBXERR1=IBXERR2 +FQ S IBXARRY=$S(IBXHOLD="IBXDATA":"IBXDATA",1:""_IBXRET_"") + I @IBXERR1'="" K @IBXARRY S @IBXARRY="" Q + ; + I IBXHOLD="IBXDATA" S IBXRET="IBXRET" + M IBXRETX=@IBXRET K @IBXARRY M @IBXARRY=IBXRETX(1) + S:'($D(@IBXARRY)#2) @IBXARRY="" + Q + ; +SERVDT(IBIFN,LENGTH,FORMAT) ; Return default service date for + ; outpatient/UB-04 lines or X12-837 institutional lines + ; LENGTH = null/8 for 8 digit date, 6 for 6 digit date + ; FORMAT = 1 = X12 format (YYYYMMDD), 2 = FM internal (NNNNNNN), + ; 0 = external (MMDDYY or MMDDYYYY) + N IBZ + G:$$INPAT^IBCEF(IBIFN,1)!($$FT^IBCEF(IBIFN)'=3) SERVDTQ ;Inpatient claim or billed on a CMS-1500 + S LENGTH=$G(LENGTH),FORMAT=$G(FORMAT) + D F("N-STATEMENT COVERS FROM DATE","IBZ",,IBIFN) + I '$G(IBZ)!(FORMAT=2) G SERVDTQ + ; + I FORMAT=1 S IBZ=$$DT^IBCEFG1(IBZ,"",$S(LENGTH'=6:"D8",1:"D6")) G SERVDTQ + S IBZ=$$DATE^IBCF2(IBZ,$S(LENGTH=6:0,1:1),1) + ; +SERVDTQ Q $G(IBZ) + ; +NOPUNCT(X,SPACE,EXC) ; Strip punctuation from data in X + ; SPACE = flag if 1 strip SPACES + ; EXC = list of punctuation not to strip + ; + N PUNCT,Z + S PUNCT=".,-+(){}[]\/><:;?|=_*&%$#@!~`^'""" + I $G(SPACE) S PUNCT=PUNCT_" " + I $G(EXC)'="" F Z=1:1:$L(EXC) S PUNCT=$TR(PUNCT,$E(EXC,Z)) + S X=$TR(X,PUNCT) + Q X + ; +FT(IBIFN) ; Internal code for bill form type + Q +$P($G(^DGCR(399,IBIFN,0)),U,19) + ; +COBCT(IBIFN) ; # of payers on claim + N CT,Z + S CT=0 F Z="I1","I2","I3" Q:'$D(^DGCR(399,IBIFN,Z)) S CT=CT+1 + Q CT + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF1.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF1.m index 0fada18d..ff04fd0d 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF1.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF1.m @@ -1,221 +1,215 @@ -IBCEF1 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS - CONT ;30-JAN-96 - ;;2.0;INTEGRATED BILLING;**52,124,51,137,210,155,349,371**;21-MAR-94;Build 57 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -OCC(IBIFN,REL,TEXT) ;Sets up an arrays of occurrence codes for various cks - ;RETURNS 1^additional data for entry IBXSAVE("OCC",n) if REL or TEXT - ; parameters have been met or null if conditions not met - ;If no REL or TEXT parameters sent, just extract codes array - ; IBIFN = bill ien - ; REL = 'OCC RELATED TO' value to check for - ; TEXT = text to check for the .01 field of 399.1 entry pointed to - ; by the occurrence code - N OCC,SORT,ARR,N,DATA,CODE,CT - I '$D(IBXSAVE("OCC")),'$D(IBXSAVE("OCCS")) D - .N IBI,Z,CT1,CT2,Z0 S (IBI,CT1,CT2)=0 - .F S IBI=$O(^DGCR(399,IBIFN,"OC",IBI)) Q:'IBI S Z=$G(^(IBI,0)) D - ..S Z0=$G(^DGCR(399.1,+Z,0)) - ..Q:'$P(Z0,U,10)&'$P(Z0,U,4) ;Not an occurrence code - ..I $P(Z0,U,10) S CT2=CT2+1,IBXSAVE("OCCS",CT2)=$S($P(Z0,U,4):$P(Z0,U,2)_U_$P(Z,U,2),1:U)_U_$P(Z,U,4)_U_$P(Z0,U)_U_$P(Z0,U,9)_U_$P(Z,U,3)_U_$P(Z,U,2) - ..I '$P(Z0,U,10) S CT1=CT1+1,IBXSAVE("OCC",CT1)=$S($P(Z0,U,4):$P(Z0,U,2)_U_$P(Z,U,2),1:U)_U_U_$P(Z0,U)_U_$P(Z0,U,9)_U_$P(Z,U,3)_U_$P(Z,U,2) - I '$D(IBXSAVE("OCC"))&'$D(IBXSAVE("OCCS")) S IBXSAVE("OCC")="" G OCCQ - ; - ; esg - IB*2*349 - order the occurrence codes - ; Build the SORT array sorted by the occ code - F ARR="OCC","OCCS" S N=0 F S N=$O(IBXSAVE(ARR,N)) Q:'N S DATA=$G(IBXSAVE(ARR,N)) I $P(DATA,U,1)'="" S CODE=" "_$P(DATA,U,1),SORT(ARR,CODE,N)=DATA - ; Loop thru the SORT array and re-build the IBXSAVE array - F ARR="OCC","OCCS" K IBXSAVE(ARR) S CODE="",CT=0 F S CODE=$O(SORT(ARR,CODE)) Q:CODE="" S N=0 F S N=$O(SORT(ARR,CODE,N)) Q:'N S CT=CT+1,IBXSAVE(ARR,CT)=SORT(ARR,CODE,N) - ; - I $G(REL)'=""!($G(TEXT)'="") D OCC1("",.OCC,$G(REL),$G(TEXT)) D:'$D(OCC) OCC1("S",.OCC,$G(REL),$G(TEXT)) -OCCQ Q $G(OCC) - ; -OCC1(ARR,OCC,REL,TEXT) ; Search thru local array for parameters met - ; ARR = null to search OCC subscript, "S" to search OCCS subscript - N Z - S ARR="OCC"_ARR,Z=0 - F S Z=$O(IBXSAVE(ARR,Z)) Q:'Z D - .I $G(REL)'="",$P(IBXSAVE(ARR,Z),U,5)=REL S OCC="1"_$S(REL=2:U_$P(IBXSAVE(ARR,Z),U,6),1:"") Q - .I $G(TEXT)'="",$P(IBXSAVE(ARR,Z),U,4)=TEXT S OCC="1^"_$P(IBXSAVE(ARR,Z),U,7) - Q - ; -RX(IBIFN) ; Format billable prescription data for refills for 837 - N Z,IBXDATA,CT - I '$D(IBXSAVE("BOX24")) D B24^IBCEF3(.IBXSAVE,IBIFN,1) - S Z="",CT=0 - F S Z=$O(IBXSAVE("BOX24",Z)) Q:Z="" I $D(IBXSAVE("BOX24",Z,"RX")) S CT=CT+1,IBXDATA(Z)=IBXSAVE("BOX24",Z,"RX") -RXQ Q CT - ; -OTHPAY(IBIFN,SEQ) ; Return the other insurance payment amount for bill - ; IBIFN and payer sequence SEQ (1-3) - N AMT,IBIFN1 - S IBIFN1=$P($G(^DGCR(399,IBIFN,"M1")),U,SEQ+4) - I IBIFN1 D - . I $$MCRWNR^IBEFUNC(+$G(^DGCR(399,IBIFN,"I"_SEQ))) S AMT=$$MCRPAY^IBCEU0(IBIFN) Q - . S AMT=+$$TPR^PRCAFN(IBIFN1) Q:AMT ; A/R amount - . S AMT=+$P($G(^DGCR(399,IBIFN,"U2")),U,SEQ+3) ; amount on bill - Q $G(AMT) - ; -OUTPT(IBIFN,IBPRINT) ; Moved for space - D OUTPT^IBCEF11(IBIFN,$G(IBPRINT)) - Q - ; -OCC92 ;Reformats IBXSAVE("OCC") and IBXSAVE("OCCS") to fit blocks on UB-04 - ; Set up IBXSAVE(32-36) arrays - N IBPG,IB32,IB33,IB34,IB35,IB36,IBFL,Z,Z0,PG - S IBPG=0 - F Z=32:1:36 K IBFL(Z) S IBFL(Z)=0 - M IB32=IBXSAVE("OCC"),IB36=IBXSAVE("OCCS") - S IB32=$O(IB32(""),-1),IB36=$O(IB36(""),-1),PG=1 - D OCC^IBCF32 - F Z=32:1:36 S Z0="" F S Z0=$O(IBFL(Z,Z0)) Q:'Z0 S IBXSAVE("OC92",Z,Z0)=$P(IBFL(Z,Z0),U,1,3) - Q - ; -BATCH() ; Moved for space IB*2*349 - Q $$BATCH^IBCEF11() - ; -PROC(T,TYPE) ; Find procedure code, strip '.' Function returns result - ; T = Procedure internal entry #;file reference - ; TYPE = "CPT" for only CPT/HCPCS valid - ; "ICD" for only ICD9 valid or null for either - N Q,S - S Q="",S="^"_$P($P(T,";",2),"(") - I $G(TYPE)="" D - . I $E(S,2,3)="IC" S Q=$P($$PRCD(T),U) Q - . I T["DIC(81.3" S Q=$$MOD^ICPTMOD(+T,"I") S Q=$S(Q>0:$P(Q,U,4),1:"") - I $G(TYPE)="CPT",$E(S,2,3)="IC" S Q=$$PRCD(T) Q - I $G(TYPE)="ICD",T["ICD0" S Q=$P($$ICD0^IBACSV(+T),U) - Q $TR(Q,".") - ; -FACILITY(IBIFN) ;return the Facility (Institution pointer-#4) for a bill - ; the institution of the Bill Division (399,.22) if defined, otherwise the Facility Name (350.9,.02) - ; - N IB0,IBIN S IBIN=0 - S IB0=$G(^DGCR(399,+$G(IBIFN),0)) I +$P(IB0,U,22) S IBIN=$$SITE^VASITE(+$P(IB0,U,3),+$P(IB0,U,22)) - I IBIN'>0 S IBIN=+$P($G(^IBE(350.9,1,0)),U,2) - Q +IBIN - ; -ISRX(IBIFN) ; Function to determine if bill is a prescription refill bill - ; Returns 0 if no Rx on bill or 1 if there is. - ; - N IBRX - I $D(^IBA(362.4,"AIFN"_IBIFN)) S IBRX=1 - Q +$G(IBRX) - ; -ISPROS(IBIFN) ; Function to determine if bill is a prosthetics bill - ; Returns 0 if no Prosthetics on bill or 1 if there is. - ; - N IBPROS - I $D(^IBA(362.5,"AIFN"_IBIFN)) S IBPROS=1 - Q +$G(IBPROS) - ; -FINDINS(IBIFN,IBSEQ) ; Returns the internal entry number of the insurance - ; company for bill ien IBIFN for payer sequence IBSEQ (or current if - ; IBSEQ is null) - Q $P($G(^DGCR(399,IBIFN,"I"_$$COBN^IBCEF(IBIFN,$G(IBSEQ)))),U) - ; -TOB(IBIFN) ; Returns UB-04 type of bill from data in the output formatter - N IBTOB,IBZ1,IBZ2,IBZ3 - D F^IBCEF("N-UB-04 LOCATION OF CARE","IBZ1",,IBIFN) - D F^IBCEF("N-UB-04 BILL CLASSIFICATION","IBZ2",,IBIFN) - D F^IBCEF("N-UB-04 TIMEFRAME OF BILL","IBZ3",,IBIFN) - S IBTOB=IBZ1_IBZ2_IBZ3 - Q IBTOB - ; -PRCD(PRIEN,ALL,EDT) ; Function returns the code that corresponds to the variable - ; pointer data in PRIEN (ien;file) - ; ALL = if ALL=1, returns the entire $$CPT^ICPTCOD for CPT or - ; ^code^name format for ICD result - ; or null if lookup fails - ; EDT = Effective date to check (not used if +$G(ALL)=0) - N CODE,IBX - S CODE="" - ;Modified for Code Set Versioning - I PRIEN["ICPT" S IBX=$$CPT^ICPTCOD(+PRIEN,$G(EDT)) G:IBX'>0 PRCDQ S CODE=$S($G(ALL):IBX,1:$P(IBX,U,2)) - I PRIEN["ICD0" S IBX=$$ICD0^IBACSV(+PRIEN,$G(EDT)) G:IBX="" PRCDQ S CODE=$S($G(ALL):U_$P(IBX,U)_U_$P(IBX,U,4),1:$P(IBX,U)) -PRCDQ Q CODE - ; -NFT(FT,IBIFN) ; Returns 1 if bill IBIFN is not of form type FT (internal) - ; so the data element should not be required - S FT=$S($$FT^IBCEF(IBIFN)=FT:0,1:1) - Q FT - ; -REQ(FT,INP,IBIFN) ; Determine if bill IBIFN is of form type FT and - ; Inpatient (I) or Outpatient (O) status INP [or either if (null)] - ; - ;Returns 1 if both conditions FT and INP match for the bill - ; or 0 if either of these conditions are not true - ; I $$REQ^IBCEF1(2,"I",1) would mean if bill entry #1 is - ; CMS-1500/inpatient the data would be required - ; I '$$REQ^IBCEF1(2,"I",1) would mean if bill entry #1 is anything but - ; CMS-1500/inpatient, the data would not be - ; required - N Z - S Z=1 - S:$$NFT(FT,IBIFN) Z=0 ; Not the form type for requirement - I Z,$G(INP)'="" D - . S Z0=$$INPAT^IBCEF(IBIFN,1),INP=$G(INP) - . S Z=$S(Z0:INP="I",1:INP="O") ;Check if I/O matches required state - Q Z - ; -SET1(IBIFN,A,IBZ,IBXDATA,IBXNOREQ) ; Utility to set variables for output - ; formatter for professional EDI - ; Returns values of A, IBXDATA, IBZ, IBXNOREQ - N Z,CT - S A="^TMP($J,""IBLCT"")" - S (Z,CT)=0 - F S Z=$O(IBXDATA(Z)) Q:'Z D ; Don't transmit 0-charges - . I $P(IBXDATA(Z),U,9),$P(IBXDATA(Z),U,8) S CT=CT+1 M IBZ(CT)=IBXDATA(Z) - K IBXDATA - S IBXNOREQ='$$REQ(2,"O",IBIFN) - Q - ; -CIADDR(IBXDATA,IBXSAVE,LINE,FORM) ; Format current ins co address line LINE for FORM - ; FORM = 1 for CMS-1500, 2 for UB-04 - ; Called from output formatter - both IBXDATA, IBXSAVE parameters are - ; passed by reference - ; - K IBXDATA - I $G(FORM)'=1 D - . ; - . ; esg - 11/17/06 - IB*2*349 - UB-04 FL-38 contains the payer name - . ; and address on 4 lines within this 5 line box. All 5 lines - . ; are formatted here into the IBXDATA array. This is the - . ; address that shows through the envelope window. - . ; - . ; esg - 9/13/07 - IB*2*371 - Line 1 of this box contains the print - . ; status (i.e. copy, 2nd notice, 3rd notice, MRA needed). - . ; - . N Z,Z1,LM,Q,ADDR,X,IBPSTAT - . S LM=$P($G(^IBE(350.9,1,1)),U,31) ; UB address column parameter - . S Z="" - . I LM S $P(Z," ",LM)="" ; beginning spaces indent - . S ADDR=$G(IBXSAVE("CADR")) ; address data string - . ; - . D F^IBCEF("N-PRINT BILL SUBMIT STATUS","IBPSTAT",,+$G(IBXIEN)) - . S Z1=Z I Z1="" S Z1=" " ; line 1 can't start in column 1 - . S IBXDATA(1)=Z1_$G(IBPSTAT),Q=1 ; line 1 print status - . S Q=Q+1 - . S IBXDATA(Q)=Z_$G(IBXSAVE("CADR_NAME")) ; line 2 payer name - . S X=$P(ADDR,U,1) - . I X'="" S Q=Q+1,IBXDATA(Q)=Z_X ; address line 1 - . S X=$P(ADDR,U,2) - . I X'="" S Q=Q+1,IBXDATA(Q)=Z_X D ; address line 2 - .. S X=$P(ADDR,U,3) - .. I X'="" S IBXDATA(Q)=IBXDATA(Q)_" "_X ; address line 3 - .. Q - . S Q=Q+1 ; city,st,zip on last line - . S IBXDATA(Q)=Z_$P(ADDR,U,4)_", "_$$STATE^IBCEFG1($P(ADDR,U,5))_" "_$P(ADDR,U,6) - . KILL IBXSAVE("CADR_NAME"),IBXSAVE("CADR") ; cleanup - . Q - ; - I $G(FORM)=1 D ; CMS-1500 - . N CT,X,Z - . S:'$D(IBXSAVE("INDENT")) Z="",$P(Z," ",+$P($G(^IBE(350.9,1,1)),U,27)+1)="",IBXSAVE("INDENT")=Z - . S CT=0 - . S X=$P(IBXSAVE("CADR"),U) S:X'="" CT=CT+1,IBXDATA(CT)=IBXSAVE("INDENT")_X - . S X=$S($P(IBXSAVE("CADR"),U,2)'="":$P(IBXSAVE("CADR"),U,2),1:"")_$S($P(IBXSAVE("CADR"),U,2)'="":" ",1:"")_$P(IBXSAVE("CADR"),U,3) S:X'="" CT=CT+1,IBXDATA(CT)=IBXSAVE("INDENT")_X - . S CT=CT+1,IBXDATA(CT)=IBXSAVE("INDENT")_$P(IBXSAVE("CADR"),U,4)_", "_$$STATE^IBCEFG1($P(IBXSAVE("CADR"),U,5))_" "_$P(IBXSAVE("CADR"),U,6) - . Q - ; - Q - ; +IBCEF1 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS - CONT ;30-JAN-96 + ;;2.0;INTEGRATED BILLING;**52,124,51,137,210,155,349**;21-MAR-94;Build 46 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; +OCC(IBIFN,REL,TEXT) ;Sets up an arrays of occurrence codes for various cks + ;RETURNS 1^additional data for entry IBXSAVE("OCC",n) if REL or TEXT + ; parameters have been met or null if conditions not met + ;If no REL or TEXT parameters sent, just extract codes array + ; IBIFN = bill ien + ; REL = 'OCC RELATED TO' value to check for + ; TEXT = text to check for the .01 field of 399.1 entry pointed to + ; by the occurrence code + N OCC,SORT,ARR,N,DATA,CODE,CT + I '$D(IBXSAVE("OCC")),'$D(IBXSAVE("OCCS")) D + .N IBI,Z,CT1,CT2,Z0 S (IBI,CT1,CT2)=0 + .F S IBI=$O(^DGCR(399,IBIFN,"OC",IBI)) Q:'IBI S Z=$G(^(IBI,0)) D + ..S Z0=$G(^DGCR(399.1,+Z,0)) + ..Q:'$P(Z0,U,10)&'$P(Z0,U,4) ;Not an occurrence code + ..I $P(Z0,U,10) S CT2=CT2+1,IBXSAVE("OCCS",CT2)=$S($P(Z0,U,4):$P(Z0,U,2)_U_$P(Z,U,2),1:U)_U_$P(Z,U,4)_U_$P(Z0,U)_U_$P(Z0,U,9)_U_$P(Z,U,3)_U_$P(Z,U,2) + ..I '$P(Z0,U,10) S CT1=CT1+1,IBXSAVE("OCC",CT1)=$S($P(Z0,U,4):$P(Z0,U,2)_U_$P(Z,U,2),1:U)_U_U_$P(Z0,U)_U_$P(Z0,U,9)_U_$P(Z,U,3)_U_$P(Z,U,2) + I '$D(IBXSAVE("OCC"))&'$D(IBXSAVE("OCCS")) S IBXSAVE("OCC")="" G OCCQ + ; + ; esg - IB*2*349 - order the occurrence codes + ; Build the SORT array sorted by the occ code + F ARR="OCC","OCCS" S N=0 F S N=$O(IBXSAVE(ARR,N)) Q:'N S DATA=$G(IBXSAVE(ARR,N)) I $P(DATA,U,1)'="" S CODE=" "_$P(DATA,U,1),SORT(ARR,CODE,N)=DATA + ; Loop thru the SORT array and re-build the IBXSAVE array + F ARR="OCC","OCCS" K IBXSAVE(ARR) S CODE="",CT=0 F S CODE=$O(SORT(ARR,CODE)) Q:CODE="" S N=0 F S N=$O(SORT(ARR,CODE,N)) Q:'N S CT=CT+1,IBXSAVE(ARR,CT)=SORT(ARR,CODE,N) + ; + I $G(REL)'=""!($G(TEXT)'="") D OCC1("",.OCC,$G(REL),$G(TEXT)) D:'$D(OCC) OCC1("S",.OCC,$G(REL),$G(TEXT)) +OCCQ Q $G(OCC) + ; +OCC1(ARR,OCC,REL,TEXT) ; Search thru local array for parameters met + ; ARR = null to search OCC subscript, "S" to search OCCS subscript + N Z + S ARR="OCC"_ARR,Z=0 + F S Z=$O(IBXSAVE(ARR,Z)) Q:'Z D + .I $G(REL)'="",$P(IBXSAVE(ARR,Z),U,5)=REL S OCC="1"_$S(REL=2:U_$P(IBXSAVE(ARR,Z),U,6),1:"") Q + .I $G(TEXT)'="",$P(IBXSAVE(ARR,Z),U,4)=TEXT S OCC="1^"_$P(IBXSAVE(ARR,Z),U,7) + Q + ; +RX(IBIFN) ; Format billable prescription data for refills for 837 + N Z,IBXDATA,CT + I '$D(IBXSAVE("BOX24")) D B24^IBCEF3(.IBXSAVE,IBIFN,1) + S Z="",CT=0 + F S Z=$O(IBXSAVE("BOX24",Z)) Q:Z="" I $D(IBXSAVE("BOX24",Z,"RX")) S CT=CT+1,IBXDATA(Z)=IBXSAVE("BOX24",Z,"RX") +RXQ Q CT + ; +OTHPAY(IBIFN,SEQ) ; Return the other insurance payment amount for bill + ; IBIFN and payer sequence SEQ (1-3) + N AMT,IBIFN1 + S IBIFN1=$P($G(^DGCR(399,IBIFN,"M1")),U,SEQ+4) + I IBIFN1 D + . I $$MCRWNR^IBEFUNC(+$G(^DGCR(399,IBIFN,"I"_SEQ))) S AMT=$$MCRPAY^IBCEU0(IBIFN) Q + . S AMT=+$$TPR^PRCAFN(IBIFN1) Q:AMT ; A/R amount + . S AMT=+$P($G(^DGCR(399,IBIFN,"U2")),U,SEQ+3) ; amount on bill + Q $G(AMT) + ; +OUTPT(IBIFN,IBPRINT) ; Moved for space + D OUTPT^IBCEF11(IBIFN,$G(IBPRINT)) + Q + ; +OCC92 ;Reformats IBXSAVE("OCC") and IBXSAVE("OCCS") to fit blocks on UB-04 + ; Set up IBXSAVE(32-36) arrays + N IBPG,IB32,IB33,IB34,IB35,IB36,IBFL,Z,Z0,PG + S IBPG=0 + F Z=32:1:36 K IBFL(Z) S IBFL(Z)=0 + M IB32=IBXSAVE("OCC"),IB36=IBXSAVE("OCCS") + S IB32=$O(IB32(""),-1),IB36=$O(IB36(""),-1),PG=1 + D OCC^IBCF32 + F Z=32:1:36 S Z0="" F S Z0=$O(IBFL(Z,Z0)) Q:'Z0 S IBXSAVE("OC92",Z,Z0)=$P(IBFL(Z,Z0),U,1,3) + Q + ; +BATCH() ; Moved for space IB*2*349 + Q $$BATCH^IBCEF11() + ; +PROC(T,TYPE) ; Find procedure code, strip '.' Function returns result + ; T = Procedure internal entry #;file reference + ; TYPE = "CPT" for only CPT/HCPCS valid + ; "ICD" for only ICD9 valid or null for either + N Q,S + S Q="",S="^"_$P($P(T,";",2),"(") + I $G(TYPE)="" D + . I $E(S,2,3)="IC" S Q=$P($$PRCD(T),U) Q + . I T["DIC(81.3" S Q=$$MOD^ICPTMOD(+T,"I") S Q=$S(Q>0:$P(Q,U,4),1:"") + I $G(TYPE)="CPT",$E(S,2,3)="IC" S Q=$$PRCD(T) Q + I $G(TYPE)="ICD",T["ICD0" S Q=$P($$ICD0^IBACSV(+T),U) + Q $TR(Q,".") + ; +FACILITY(IBIFN) ;return the Facility (Institution pointer-#4) for a bill + ; the institution of the Bill Division (399,.22) if defined, otherwise the Facility Name (350.9,.02) + ; + N IB0,IBIN S IBIN=0 + S IB0=$G(^DGCR(399,+$G(IBIFN),0)) I +$P(IB0,U,22) S IBIN=$$SITE^VASITE(+$P(IB0,U,3),+$P(IB0,U,22)) + I IBIN'>0 S IBIN=+$P($G(^IBE(350.9,1,0)),U,2) + Q +IBIN + ; +ISRX(IBIFN) ; Function to determine if bill is a prescription refill bill + ; Returns 0 if no Rx on bill or 1 if there is. + ; + N IBRX + I $D(^IBA(362.4,"AIFN"_IBIFN)) S IBRX=1 + Q +$G(IBRX) + ; +ISPROS(IBIFN) ; Function to determine if bill is a prosthetics bill + ; Returns 0 if no Prosthetics on bill or 1 if there is. + ; + N IBPROS + I $D(^IBA(362.5,"AIFN"_IBIFN)) S IBPROS=1 + Q +$G(IBPROS) + ; +FINDINS(IBIFN,IBSEQ) ; Returns the internal entry number of the insurance + ; company for bill ien IBIFN for payer sequence IBSEQ (or current if + ; IBSEQ is null) + Q $P($G(^DGCR(399,IBIFN,"I"_$$COBN^IBCEF(IBIFN,$G(IBSEQ)))),U) + ; +TOB(IBIFN) ; Returns UB-04 type of bill from data in the output formatter + N IBTOB,IBZ1,IBZ2,IBZ3 + D F^IBCEF("N-UB-04 LOCATION OF CARE","IBZ1",,IBIFN) + D F^IBCEF("N-UB-04 BILL CLASSIFICATION","IBZ2",,IBIFN) + D F^IBCEF("N-UB-04 TIMEFRAME OF BILL","IBZ3",,IBIFN) + S IBTOB=IBZ1_IBZ2_IBZ3 + Q IBTOB + ; +PRCD(PRIEN,ALL,EDT) ; Function returns the code that corresponds to the variable + ; pointer data in PRIEN (ien;file) + ; ALL = if ALL=1, returns the entire $$CPT^ICPTCOD for CPT or + ; ^code^name format for ICD result + ; or null if lookup fails + ; EDT = Effective date to check (not used if +$G(ALL)=0) + N CODE,IBX + S CODE="" + ;Modified for Code Set Versioning + I PRIEN["ICPT" S IBX=$$CPT^ICPTCOD(+PRIEN,$G(EDT)) G:IBX'>0 PRCDQ S CODE=$S($G(ALL):IBX,1:$P(IBX,U,2)) + I PRIEN["ICD0" S IBX=$$ICD0^IBACSV(+PRIEN,$G(EDT)) G:IBX="" PRCDQ S CODE=$S($G(ALL):U_$P(IBX,U)_U_$P(IBX,U,4),1:$P(IBX,U)) +PRCDQ Q CODE + ; +NFT(FT,IBIFN) ; Returns 1 if bill IBIFN is not of form type FT (internal) + ; so the data element should not be required + S FT=$S($$FT^IBCEF(IBIFN)=FT:0,1:1) + Q FT + ; +REQ(FT,INP,IBIFN) ; Determine if bill IBIFN is of form type FT and + ; Inpatient (I) or Outpatient (O) status INP [or either if (null)] + ; + ;Returns 1 if both conditions FT and INP match for the bill + ; or 0 if either of these conditions are not true + ; I $$REQ^IBCEF1(2,"I",1) would mean if bill entry #1 is + ; CMS-1500/inpatient the data would be required + ; I '$$REQ^IBCEF1(2,"I",1) would mean if bill entry #1 is anything but + ; CMS-1500/inpatient, the data would not be + ; required + N Z + S Z=1 + S:$$NFT(FT,IBIFN) Z=0 ; Not the form type for requirement + I Z,$G(INP)'="" D + . S Z0=$$INPAT^IBCEF(IBIFN,1),INP=$G(INP) + . S Z=$S(Z0:INP="I",1:INP="O") ;Check if I/O matches required state + Q Z + ; +SET1(IBIFN,A,IBZ,IBXDATA,IBXNOREQ) ; Utility to set variables for output + ; formatter for professional EDI + ; Returns values of A, IBXDATA, IBZ, IBXNOREQ + N Z,CT + S A="^TMP($J,""IBLCT"")" + S (Z,CT)=0 + F S Z=$O(IBXDATA(Z)) Q:'Z D ; Don't transmit 0-charges + . I $P(IBXDATA(Z),U,9),$P(IBXDATA(Z),U,8) S CT=CT+1 M IBZ(CT)=IBXDATA(Z) + K IBXDATA + S IBXNOREQ='$$REQ(2,"O",IBIFN) + Q + ; +CIADDR(IBXDATA,IBXSAVE,LINE,FORM) ; Format current ins co address line LINE for FORM + ; FORM = 1 for CMS-1500, 2 for UB-04 + ; Called from output formatter - both IBXDATA, IBXSAVE parameters are + ; passed by reference + ; + K IBXDATA + I $G(FORM)'=1 D + . ; + . ; esg - 11/17/06 - IB*2*349 - UB-04 FL-38 contains the payer name + . ; and address on 4 lines within this 5 line box. All 5 lines + . ; are formatted here into the IBXDATA array. This is the + . ; address that shows through the envelope window. + . ; + . N Z,LM,Q,ADDR,X + . S LM=$P($G(^IBE(350.9,1,1)),U,31) ; UB address column parameter + . S Z="" + . I LM S $P(Z," ",LM)="" ; beginning spaces indent + . S ADDR=$G(IBXSAVE("CADR")) ; address data string + . S IBXDATA(1)="",Q=1 ; line 1 is blank + . S Q=Q+1 + . S IBXDATA(Q)=Z_$G(IBXSAVE("CADR_NAME")) ; line 2 payer name + . S X=$P(ADDR,U,1) + . I X'="" S Q=Q+1,IBXDATA(Q)=Z_X ; address line 1 + . S X=$P(ADDR,U,2) + . I X'="" S Q=Q+1,IBXDATA(Q)=Z_X D ; address line 2 + .. S X=$P(ADDR,U,3) + .. I X'="" S IBXDATA(Q)=IBXDATA(Q)_" "_X ; address line 3 + .. Q + . S Q=Q+1 ; city,st,zip on last line + . S IBXDATA(Q)=Z_$P(ADDR,U,4)_", "_$$STATE^IBCEFG1($P(ADDR,U,5))_" "_$P(ADDR,U,6) + . KILL IBXSAVE("CADR_NAME"),IBXSAVE("CADR") ; cleanup + . Q + ; + I $G(FORM)=1 D ; CMS-1500 + . N CT,X,Z + . S:'$D(IBXSAVE("INDENT")) Z="",$P(Z," ",+$P($G(^IBE(350.9,1,1)),U,27)+1)="",IBXSAVE("INDENT")=Z + . S CT=0 + . S X=$P(IBXSAVE("CADR"),U) S:X'="" CT=CT+1,IBXDATA(CT)=IBXSAVE("INDENT")_X + . S X=$S($P(IBXSAVE("CADR"),U,2)'="":$P(IBXSAVE("CADR"),U,2),1:"")_$S($P(IBXSAVE("CADR"),U,2)'="":" ",1:"")_$P(IBXSAVE("CADR"),U,3) S:X'="" CT=CT+1,IBXDATA(CT)=IBXSAVE("INDENT")_X + . S CT=CT+1,IBXDATA(CT)=IBXSAVE("INDENT")_$P(IBXSAVE("CADR"),U,4)_", "_$$STATE^IBCEFG1($P(IBXSAVE("CADR"),U,5))_" "_$P(IBXSAVE("CADR"),U,6) + . Q + ; + Q + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF11.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF11.m index a1138e29..8fe00053 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF11.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF11.m @@ -1,198 +1,185 @@ -IBCEF11 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS - CONT ;30-JAN-96 - ;;2.0;INTEGRATED BILLING;**51,137,155,309,335,348,349,371**;21-MAR-94;Build 57 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -BOX24D(A,IB) ; Returns the lines for boxes 19-24 of the CMS-1500 display - ; IB = flag is 1 if only box 24 is needed - Q $S('$G(IB):"36",1:"44")_"^55" - ; -RCBOX() ; Returns the lines for revenue code boxes of the UB-04 display - Q "19^41" - ; -OUTPT(IBIFN,IBPRINT) ; Returns an array of service line data from - ; CMS-1500 box 24. Output is in IBXDATA(n) - ; IBPRINT = print flag 1: return print fields - ; 0: return EDI fields - ; Uses diagnosis array ^TMP("IBXSAVE",$J,"DX",IBIFN,DIAG CODE)=SEQ # - ; if it already exists. If not, it builds it from N-DIAGNOSES element - ; - ; For EDI call: Returns IBXDATA(n)= - ; begin date(YYYYMMDD)^end date(YYYYMMDD)^pos^tos^ - ; proc code/revenue code - if no procedure (not the pointers)^ - ; type of code^dx pointer(s)^unit charge^units^modifiers separated by; - ; ^purchased charge amount ^anesthesia minutes^emergency indicator^ - ; lab-type service flag. - ; - ; Also Returns IBXDATA(IBI,"COB",COB,m) with COB data for each line - ; item found in an accepted EOB for the bill and = the reference - ; line in the first '^' piece followed by the '0' node data of file - ; 361.115 (LINE LEVEL ADJUSTMENTS) - ; COB = COB sequence # of adjustment's ins co, m = seq # - ; -- AND -- - ; IBXDATA(IBI,"COB",COB,m,z,p)= - ; the data on the '0' node for each subordinate entry of file - ; 361.11511 (REASONS) (Only first 3 pieces for 837 output) - ; z = group code, sometimes preceeded by a space p = seq # - ; - ; For Print call: Returns begin date(DDMMYYYY)^end date(DDMMYYYY) or - ; null if equal to begin date^pos^tos^bedsection name(if no procedure) - ; or procedure code(not the pointer)^ ... refer to EDI call results - ; Also, IBXDATA(n,"TEXT")=the text to print on first line of box 24, - ; If no procedure code, returns IBXDATA(n,"A")=rev code abbrev - ; - ; For both calls, returns IBXDATA(n,item type,item ptr)="" - ; -- AND -- - ; IBXDATA(n,"RX")=RX#^drug name^NDC^refill #^(re)fill date^qty^days - ; ^chrge^ien of file 362.4^NDC format - ; If line references a prescription - ; -- AND -- - ; If no revenue code for a prescription, returns IBXDATA(n,"ARX")="" - ; -- AND -- - ; IBXDATA(n,"AUX")='AUX' node of the procedure entry - ; - N IB,IBI,IBJ,IBFLD,IBDXI,IBXIEN,Z,IBXTRA,IBRX,IBRX0,IBRX1,Z0,Z1 - ; - K ^TMP($J,"IBITEM") - S ^TMP($J,"IBITEM")="" - ; Build diagnosis array if not already built - I $O(^TMP("IBXSAVE",$J,"DX",IBIFN,""))="",$O(^IBA(362.3,"AIFN"_IBIFN,"")) D - .N Z,IBXDATA D F^IBCEF("N-DIAGNOSES",,,IBIFN) - .S Z="" F S Z=$O(IBXDATA(Z)) K:$O(IBXDATA(0))=""&(Z="") IBXDATA Q:Z="" S:$P(IBXDATA(Z),U,2) ^TMP("IBXSAVE",$J,"DX",IBIFN,$P(IBXDATA(Z),U,2))=Z - ; - S IB(0)=$G(^DGCR(399,IBIFN,0)),IB("U")=$G(^("U")),IB("U1")=$G(^("U1")) - S IBI="" F S IBI=$O(^TMP("IBXSAVE",$J,"DX",IBIFN,IBI)) Q:IBI="" S IBDXI(IBI)=^(IBI) - I '$G(IBPRINT) D RVCE^IBCF23(IBIFN,IBIFN) - I $G(IBPRINT) D RVCE^IBCF23(,IBIFN) - ; Returns IBFLD(24) = begin date^end date^pos^tos^ - ; proc/bedsection/revenue code^dx pointer^unit charge^ - ; units^modifiers^ purchased charge amount ^anesthesia minutes^ - ; emergency indicator ^ AND - ; IBFLD(24,n,type,item)="" - ; IBFLD(24,n_"A") = revenue code abbreviation if no procedure - ; IBFLD(24,n,"AUX") = 'AUX' node of line item - ; IBFLD(24,n,"RX") = soft pointer to file 362.4 from 'item' fld - ; (can be null) - ; - D SET^IBCSC5A(IBIFN,.IBRX) ;prescriptions - ; IBRX1(ien 362.4)=RX#^drug ien^NDC^refil #^(re)fil date^qty^days^chrge - I IBRX S IBRX="" F S IBRX=$O(IBRX(IBRX)) Q:IBRX="" S IBRX0=0 F S IBRX0=$O(IBRX(IBRX,IBRX0)) Q:'IBRX0 D - . N IBRXH - . S IBRXH=IBRX(IBRX,IBRX0) - . S IBRX1(+IBRXH)=IBRX_U_$P(IBRXH,U,2)_U_$P(IBRXH,U,5)_U_$P(IBRXH,U,7)_U_IBRX0_U_$P(IBRXH,U,4)_U_$P(IBRXH,U,3)_U_$P(IBRXH,U,6)_U_+IBRXH_U_$P(IBRXH,U,8) - K IBRX - ; - ; for EDI, remove any $0 line items from the IBFLD array before - ; dropping down into the next loop (IB*2*371) - I '$G(IBPRINT) D - . NEW IBZ,IBI,Z - . M IBZ=IBFLD K IBFLD - . S (IBI,Z)=0 - . F S IBI=$O(IBZ(24,IBI)) Q:IBI'=+IBI D - .. I $P(IBZ(24,IBI),U,7)*$P(IBZ(24,IBI),U,8)'>0 Q - .. S Z=Z+1 - .. M IBFLD(24,Z)=IBZ(24,IBI) - .. S IBFLD(24)=Z - .. Q - . Q - ; - S IBI=0 - F S IBI=$O(IBFLD(24,IBI)) Q:IBI'=+IBI D - . S IBRX1=0 - . S IBXDATA(IBI)=$P(IBFLD(24,IBI),U)_U_$P(IBFLD(24,IBI),U,$S($P(IBFLD(24,IBI),U,2)=""&'$G(IBPRINT):1,1:2)) - . S $P(IBXDATA(IBI),U,3,5)=$P(IBFLD(24,IBI),U,3,5) - . S $P(IBXDATA(IBI),U,6)=$S($D(IBFLD(24,IBI_"X")):"CJ",1:"HC") - . S $P(IBXDATA(IBI),U,7,13)=$P(IBFLD(24,IBI),U,6,12) - . S $P(IBXDATA(IBI),U,14)=+$$ISLAB(IBXDATA(IBI)) - . ; - . I $D(IBFLD(24,IBI,"RX")) D ;Rx - .. S IBRX1=1 - .. I $P($G(IBFLD(24,IBI,"AUX")),U,8)'="" S $P(IBFLD(24,IBI,"AUX"),U,8)="",$P(IBFLD(24,IBI,"AUX"),U,9)="" ;No free text allowed for rx's - .. I $D(IBRX1(+IBFLD(24,IBI,"RX"))) D Q ;Soft link exists - ...D ZERO^IBRXUTL(+$P(IBRX1(+IBFLD(24,IBI,"RX")),U,2)) - ... S IBXDATA(IBI,"RX")=IBRX1(+IBFLD(24,IBI,"RX")),$P(IBXDATA(IBI,"RX"),U,2)=$E($G(^TMP($J,"IBDRUG",+$P(IBRX1(+IBFLD(24,IBI,"RX")),U,2),.01)),1,30) - ... K IBRX1(+IBFLD(24,IBI,"RX")) - ... ; No soft link - must find the first Rx with the same charge - .. S IBRX="" F S IBRX=$O(IBRX1(IBRX)) Q:'IBRX I +$P(IBRX1(IBRX),U,8)=+$P(IBXDATA(IBI),U,8) D Q - ... D ZERO^IBRXUTL(+$P(IBRX1(IBRX),U,2)) - ... S IBXDATA(IBI,"RX")=IBRX1(IBRX),$P(IBXDATA(IBI,"RX"),U,2)=$E($G(^TMP($J,"IBDRUG",+$P(IBRX1(IBRX),U,2),.01)),1,30) K IBRX1(IBRX) Q - ... Q - .. Q - . ; - . I $G(IBFLD(24,IBI,"AUX"))'="" D - .. I $G(IBPRINT),$P(IBFLD(24,IBI,"AUX"),U,8)'="" S IBXDATA(IBI,"TEXT")=$P(IBFLD(24,IBI,"AUX"),U,8),$P(IBFLD(24,IBI,"AUX"),U,8)="" - .. S IBXDATA(IBI,"AUX")=IBFLD(24,IBI,"AUX") - .. Q - . ; - . I $G(IBPRINT) D - .. I '$P(IBXDATA(IBI),U,8),'$G(IBXDATA(IBI,"RX")) D Q - ... I $G(IBNOSHOW) Q ; don't show errors/warnings - ... S IBXDATA(IBI,"TEXT")="Warning:** REV CODE UNITS < #PROCEDURES, THEY MUST BE =" - ... I $D(IBXDATA(IBI,"AUX")) S $P(IBXDATA(IBI,"AUX"),U,9)="" - ... Q - .. ; - .. I $G(IBFLD(24,IBI_"A"))'="" D Q - ... S IBXDATA(IBI,"A")=IBFLD(24,IBI_"A") - ... I $G(IBNOSHOW) Q ; don't show errors/warnings - ... S IBXDATA(IBI,"TEXT")="Warning:** REV CODE UNITS > #PROCEDURES, THEY MUST BE=: "_IBFLD(24,IBI_"A") - ... I $D(IBXDATA(IBI,"AUX")) S $P(IBXDATA(IBI,"AUX"),U,9)="" - ... Q - .. ; - .. S IBRX=$G(IBXDATA(IBI,"RX")) - .. I IBRX'="" D ;Format Rx detail - ... N Z - ... S Z=$P(IBRX,U) - ... S Z=$S(Z'="":"Rx#"_Z_" ",1:"RX: ") - ... S IBXDATA(IBI,"TEXT")=Z_$S($P(IBRX,U,3)'="":"NDC: "_$P(IBRX,U,3),1:"NOC: "_$P(IBRX,U,2))_" Qty: "_$P(IBRX,U,6)_" Days: "_$P(IBRX,U,7) - ... S $P(IBXDATA(IBI,"AUX"),U,9)="N4" ; service line comment qualifier for RX's - ... Q - .. Q - . ; - . I '$G(IBPRINT) D COBLINE^IBCEU6(IBIFN,IBI,.IBXDATA,,.IBXTRA) - . Q - ; - I $G(IBPRINT) D - . S IBRX=0 F S IBRX=$O(IBRX1(IBRX)) Q:'IBRX D - .. S IBI=+$O(IBXDATA(""),-1)+1 - .. S IBXDATA(IBI)=$$DATE($P(IBRX1(IBRX),U,5)) - .. S IBXDATA(IBI,"TEXT")="**** ERROR - NO PROC LINK TO REV CODE FOR DRUG: RX#: "_$P(IBRX1(IBRX),U)_" NDC #: "_$P(IBRX1(IBRX),U,3) - .. I $D(IBXDATA(IBI,"AUX")) S $P(IBXDATA(IBI,"AUX"),U,9)="" - .. S IBXDATA(IBI,"ARX")="" - .. D ZERO^IBRXUTL(+$P(IBRX1(IBRX),U,2)) - .. S IBXDATA(IBI,"RX")=IBRX1(IBRX),$P(IBXDATA(IBI,"RX"),U,2)=$E($G(^TMP($J,"IBDRUG",+$P(IBRX1(IBRX),U,2),.01)),1,30) K IBRX1(IBRX) - .. Q - . Q - ; - I '$G(IBPRINT),$D(IBXTRA) D COMBO^IBCEU2(.IBXDATA,.IBXTRA,0) ;Handle bundled/unbundled lines - K ^TMP($J,"IBDRUG") - Q - ; -ISLAB(LDATA) ; Returns 0/1 if line item data indicates the item is a lab (1) - ; 'LAB' is defined here as type of service = 5 - Q $E($P(LDATA,U,4))="5" - ; -FMT(DATA,DLEN,FLEN) ; Returns a string in DATA with a max length of DLEN - ; and a field length of FLEN - Q $E($E(DATA,1,DLEN)_$J("",FLEN),1,FLEN) - ; -DATE(X,DEL) ; Returns FM date in X as MMxDDxYYYY where x=DEL - S DEL=$G(DEL) - S X=$$DATE^IBCF2(X,1,1) - I X'="" S X=$E(X,1,2)_DEL_$E(X,3,4)_DEL_$E(X,5,8) - Q X - ; -BATCH() ; Sets up record for and stores/returns the next batch number - N NUM,FAC,DO,DD,DLAYGO,DIC,X,Y - ;Keep latest batch number for view/print edi bill extract data option - I $D(IBVNUM) S NUM=IBVNUM G BATCHQ - ;Check for batch resubmit - if yes, use same number as original batch - I $P($G(^TMP("IBRESUBMIT",$J)),U,3)=1 S NUM=$P(^($J),U) G BATCHQ - L +^IBA(364.1,0):5 I '$T Q 0 - S FAC=+$P($$SITE^VASITE(),U,3),NUM=$O(^IBA(364.1,"B",""),-1) - I $D(^IBA(364.1,+NUM,0)),$P(^(0),U,2)="" F D Q:'NUM!($P($G(^IBA(364.1,+NUM,0)),U,2)'="") - . I $D(^IBA(364.1,NUM,0)) S DA=NUM,DIK="^IBA(364.1," D ^DIK - . S NUM=$O(^IBA(364.1,"B",""),-1) - F S NUM=$S($P(NUM,FAC,2)'="":NUM+1,1:FAC_"0000001") Q:'$D(^IBA(364.1,"B",NUM)) - K DO,DD S DIC="^IBA(364.1,",DLAYGO=364.1,DIC(0)="L",X=NUM D FILE^DICN K DD,DO I Y'>0 S NUM=0 - L -^IBA(364.1,0) -BATCHQ Q NUM - ; +IBCEF11 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS - CONT ;30-JAN-96 + ;;2.0;INTEGRATED BILLING;**51,137,155,309,335,348,349**;21-MAR-94;Build 46 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; +BOX24D(A,IB) ; Returns the lines for boxes 19-24 of the CMS-1500 display + ; IB = flag is 1 if only box 24 is needed + Q $S('$G(IB):"36",1:"44")_"^55" + ; +RCBOX() ; Returns the lines for revenue code boxes of the UB-04 display + Q "19^41" + ; +OUTPT(IBIFN,IBPRINT) ; Returns an array of service line data from + ; CMS-1500 box 24. Output is in IBXDATA(n) + ; IBPRINT = print flag 1: return print fields + ; 0: return EDI fields + ; Uses diagnosis array ^TMP("IBXSAVE",$J,"DX",IBIFN,DIAG CODE)=SEQ # + ; if it already exists. If not, it builds it from N-DIAGNOSES element + ; + ; For EDI call: Returns IBXDATA(n)= + ; begin date(YYYYMMDD)^end date(YYYYMMDD)^pos^tos^ + ; proc code/revenue code - if no procedure (not the pointers)^ + ; type of code^dx pointer(s)^unit charge^units^modifiers separated by; + ; ^purchased charge amount ^anesthesia minutes^emergency indicator^ + ; lab-type service flag. + ; + ; Also Returns IBXDATA(IBI,"COB",COB,m) with COB data for each line + ; item found in an accepted EOB for the bill and = the reference + ; line in the first '^' piece followed by the '0' node data of file + ; 361.115 (LINE LEVEL ADJUSTMENTS) + ; COB = COB sequence # of adjustment's ins co, m = seq # + ; -- AND -- + ; IBXDATA(IBI,"COB",COB,m,z,p)= + ; the data on the '0' node for each subordinate entry of file + ; 361.11511 (REASONS) (Only first 3 pieces for 837 output) + ; z = group code, sometimes preceeded by a space p = seq # + ; + ; For Print call: Returns begin date(DDMMYYYY)^end date(DDMMYYYY) or + ; null if equal to begin date^pos^tos^bedsection name(if no procedure) + ; or procedure code(not the pointer)^ ... refer to EDI call results + ; Also, IBXDATA(n,"TEXT")=the text to print on first line of box 24, + ; If no procedure code, returns IBXDATA(n,"A")=rev code abbrev + ; + ; For both calls, returns IBXDATA(n,item type,item ptr)="" + ; -- AND -- + ; IBXDATA(n,"RX")=RX#^drug name^NDC^refill #^(re)fill date^qty^days + ; ^chrge^ien of file 362.4^NDC format + ; If line references a prescription + ; -- AND -- + ; If no revenue code for a prescription, returns IBXDATA(n,"ARX")="" + ; -- AND -- + ; IBXDATA(n,"AUX")='AUX' node of the procedure entry + ; + N IB,IBI,IBJ,IBFLD,IBDXI,IBXIEN,Z,IBXTRA,IBRX,IBRX0,IBRX1,Z0,Z1 + ; + K ^TMP($J,"IBITEM") + S ^TMP($J,"IBITEM")="" + ; Build diagnosis array if not already built + I $O(^TMP("IBXSAVE",$J,"DX",IBIFN,""))="",$O(^IBA(362.3,"AIFN"_IBIFN,"")) D + .N Z,IBXDATA D F^IBCEF("N-DIAGNOSES",,,IBIFN) + .S Z="" F S Z=$O(IBXDATA(Z)) K:$O(IBXDATA(0))=""&(Z="") IBXDATA Q:Z="" S:$P(IBXDATA(Z),U,2) ^TMP("IBXSAVE",$J,"DX",IBIFN,$P(IBXDATA(Z),U,2))=Z + ; + S IB(0)=$G(^DGCR(399,IBIFN,0)),IB("U")=$G(^("U")),IB("U1")=$G(^("U1")) + S IBI="" F S IBI=$O(^TMP("IBXSAVE",$J,"DX",IBIFN,IBI)) Q:IBI="" S IBDXI(IBI)=^(IBI) + I '$G(IBPRINT) D RVCE^IBCF23(IBIFN,IBIFN) + I $G(IBPRINT) D RVCE^IBCF23(,IBIFN) + ; Returns IBFLD(24) = begin date^end date^pos^tos^ + ; proc/bedsection/revenue code^dx pointer^unit charge^ + ; units^modifiers^ purchased charge amount ^anesthesia minutes^ + ; emergency indicator ^ AND + ; IBFLD(24,n,type,item)="" + ; IBFLD(24,n_"A") = revenue code abbreviation if no procedure + ; IBFLD(24,n,"AUX") = 'AUX' node of line item + ; IBFLD(24,n,"RX") = soft pointer to file 362.4 from 'item' fld + ; (can be null) + ; + D SET^IBCSC5A(IBIFN,.IBRX) ;prescriptions + ; IBRX1(ien 362.4)=RX#^drug ien^NDC^refil #^(re)fil date^qty^days^chrge + I IBRX S IBRX="" F S IBRX=$O(IBRX(IBRX)) Q:IBRX="" S IBRX0=0 F S IBRX0=$O(IBRX(IBRX,IBRX0)) Q:'IBRX0 D + . N IBRXH + . S IBRXH=IBRX(IBRX,IBRX0) + . S IBRX1(+IBRXH)=IBRX_U_$P(IBRXH,U,2)_U_$P(IBRXH,U,5)_U_$P(IBRXH,U,7)_U_IBRX0_U_$P(IBRXH,U,4)_U_$P(IBRXH,U,3)_U_$P(IBRXH,U,6)_U_+IBRXH_U_$P(IBRXH,U,8) + K IBRX + ; + S IBI=0 + F S IBI=$O(IBFLD(24,IBI)) Q:IBI'=+IBI D + . S IBRX1=0 + . I '$G(IBPRINT) Q:$P(IBFLD(24,IBI),U,7)*$P(IBFLD(24,IBI),U,8)'>0 ; For EDI, ignore 0-charge line items + . S IBXDATA(IBI)=$P(IBFLD(24,IBI),U)_U_$P(IBFLD(24,IBI),U,$S($P(IBFLD(24,IBI),U,2)=""&'$G(IBPRINT):1,1:2)) + . S $P(IBXDATA(IBI),U,3,5)=$P(IBFLD(24,IBI),U,3,5) + . S $P(IBXDATA(IBI),U,6)=$S($D(IBFLD(24,IBI_"X")):"CJ",1:"HC") + . S $P(IBXDATA(IBI),U,7,13)=$P(IBFLD(24,IBI),U,6,12) + . S $P(IBXDATA(IBI),U,14)=+$$ISLAB(IBXDATA(IBI)) + . ; + . I $D(IBFLD(24,IBI,"RX")) D ;Rx + .. S IBRX1=1 + .. I $P($G(IBFLD(24,IBI,"AUX")),U,8)'="" S $P(IBFLD(24,IBI,"AUX"),U,8)="",$P(IBFLD(24,IBI,"AUX"),U,9)="" ;No free text allowed for rx's + .. I $D(IBRX1(+IBFLD(24,IBI,"RX"))) D Q ;Soft link exists + ...D ZERO^IBRXUTL(+$P(IBRX1(+IBFLD(24,IBI,"RX")),U,2)) + ... S IBXDATA(IBI,"RX")=IBRX1(+IBFLD(24,IBI,"RX")),$P(IBXDATA(IBI,"RX"),U,2)=$E($G(^TMP($J,"IBDRUG",+$P(IBRX1(+IBFLD(24,IBI,"RX")),U,2),.01)),1,30) + ... K IBRX1(+IBFLD(24,IBI,"RX")) + ... ; No soft link - must find the first Rx with the same charge + .. S IBRX="" F S IBRX=$O(IBRX1(IBRX)) Q:'IBRX I +$P(IBRX1(IBRX),U,8)=+$P(IBXDATA(IBI),U,8) D Q + ... D ZERO^IBRXUTL(+$P(IBRX1(IBRX),U,2)) + ... S IBXDATA(IBI,"RX")=IBRX1(IBRX),$P(IBXDATA(IBI,"RX"),U,2)=$E($G(^TMP($J,"IBDRUG",+$P(IBRX1(IBRX),U,2),.01)),1,30) K IBRX1(IBRX) Q + ... Q + .. Q + . ; + . I $G(IBFLD(24,IBI,"AUX"))'="" D + .. I $G(IBPRINT),$P(IBFLD(24,IBI,"AUX"),U,8)'="" S IBXDATA(IBI,"TEXT")=$P(IBFLD(24,IBI,"AUX"),U,8),$P(IBFLD(24,IBI,"AUX"),U,8)="" + .. S IBXDATA(IBI,"AUX")=IBFLD(24,IBI,"AUX") + .. Q + . ; + . I $G(IBPRINT) D + .. I '$P(IBXDATA(IBI),U,8),'$G(IBXDATA(IBI,"RX")) D Q + ... I $G(IBNOSHOW) Q ; don't show errors/warnings + ... S IBXDATA(IBI,"TEXT")="Warning:** REV CODE UNITS < #PROCEDURES, THEY MUST BE =" + ... I $D(IBXDATA(IBI,"AUX")) S $P(IBXDATA(IBI,"AUX"),U,9)="" + ... Q + .. ; + .. I $G(IBFLD(24,IBI_"A"))'="" D Q + ... S IBXDATA(IBI,"A")=IBFLD(24,IBI_"A") + ... I $G(IBNOSHOW) Q ; don't show errors/warnings + ... S IBXDATA(IBI,"TEXT")="Warning:** REV CODE UNITS > #PROCEDURES, THEY MUST BE=: "_IBFLD(24,IBI_"A") + ... I $D(IBXDATA(IBI,"AUX")) S $P(IBXDATA(IBI,"AUX"),U,9)="" + ... Q + .. ; + .. S IBRX=$G(IBXDATA(IBI,"RX")) + .. I IBRX'="" D ;Format Rx detail + ... N Z + ... S Z=$P(IBRX,U) + ... S Z=$S(Z'="":"Rx#"_Z_" ",1:"RX: ") + ... S IBXDATA(IBI,"TEXT")=Z_$S($P(IBRX,U,3)'="":"NDC: "_$P(IBRX,U,3),1:"NOC: "_$P(IBRX,U,2))_" Qty: "_$P(IBRX,U,6)_" Days: "_$P(IBRX,U,7) + ... S $P(IBXDATA(IBI,"AUX"),U,9)="N4" ; service line comment qualifier for RX's + ... Q + .. Q + . ; + . I '$G(IBPRINT) D COBLINE^IBCEU6(IBIFN,IBI,.IBXDATA,,.IBXTRA) + . Q + ; + I $G(IBPRINT) D + . S IBRX=0 F S IBRX=$O(IBRX1(IBRX)) Q:'IBRX D + .. S IBI=+$O(IBXDATA(""),-1)+1 + .. S IBXDATA(IBI)=$$DATE($P(IBRX1(IBRX),U,5)) + .. S IBXDATA(IBI,"TEXT")="**** ERROR - NO PROC LINK TO REV CODE FOR DRUG: RX#: "_$P(IBRX1(IBRX),U)_" NDC #: "_$P(IBRX1(IBRX),U,3) + .. I $D(IBXDATA(IBI,"AUX")) S $P(IBXDATA(IBI,"AUX"),U,9)="" + .. S IBXDATA(IBI,"ARX")="" + .. D ZERO^IBRXUTL(+$P(IBRX1(IBRX),U,2)) + .. S IBXDATA(IBI,"RX")=IBRX1(IBRX),$P(IBXDATA(IBI,"RX"),U,2)=$E($G(^TMP($J,"IBDRUG",+$P(IBRX1(IBRX),U,2),.01)),1,30) K IBRX1(IBRX) + .. Q + . Q + ; + I '$G(IBPRINT),$D(IBXTRA) D COMBO^IBCEU2(.IBXDATA,.IBXTRA,0) ;Handle bundled/unbundled lines + K ^TMP($J,"IBDRUG") + Q + ; +ISLAB(LDATA) ; Returns 0/1 if line item data indicates the item is a lab (1) + ; 'LAB' is defined here as type of service = 5 + Q $E($P(LDATA,U,4))="5" + ; +FMT(DATA,DLEN,FLEN) ; Returns a string in DATA with a max length of DLEN + ; and a field length of FLEN + Q $E($E(DATA,1,DLEN)_$J("",FLEN),1,FLEN) + ; +DATE(X,DEL) ; Returns FM date in X as MMxDDxYYYY where x=DEL + S DEL=$G(DEL) + S X=$$DATE^IBCF2(X,1,1) + I X'="" S X=$E(X,1,2)_DEL_$E(X,3,4)_DEL_$E(X,5,8) + Q X + ; +BATCH() ; Sets up record for and stores/returns the next batch number + N NUM,FAC,DO,DD,DLAYGO,DIC,X,Y + ;Keep latest batch number for view/print edi bill extract data option + I $D(IBVNUM) S NUM=IBVNUM G BATCHQ + ;Check for batch resubmit - if yes, use same number as original batch + I $P($G(^TMP("IBRESUBMIT",$J)),U,3)=1 S NUM=$P(^($J),U) G BATCHQ + L +^IBA(364.1,0):5 I '$T Q 0 + S FAC=+$P($$SITE^VASITE(),U,3),NUM=$O(^IBA(364.1,"B",""),-1) + I $D(^IBA(364.1,+NUM,0)),$P(^(0),U,2)="" F D Q:'NUM!($P($G(^IBA(364.1,+NUM,0)),U,2)'="") + . I $D(^IBA(364.1,NUM,0)) S DA=NUM,DIK="^IBA(364.1," D ^DIK + . S NUM=$O(^IBA(364.1,"B",""),-1) + F S NUM=$S($P(NUM,FAC,2)'="":NUM+1,1:FAC_"0000001") Q:'$D(^IBA(364.1,"B",NUM)) + K DO,DD S DIC="^IBA(364.1,",DLAYGO=364.1,DIC(0)="L",X=NUM D FILE^DICN K DD,DO I Y'>0 S NUM=0 + L -^IBA(364.1,0) +BATCHQ Q NUM + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF21.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF21.m index ac72d62c..6b3221b1 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF21.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF21.m @@ -1,149 +1,78 @@ -IBCEF21 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS CONTINUED ;06-FEB-96 - ;;2.0;INTEGRATED BILLING;**51,296,371,389**;21-MAR-94;Build 6 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -COID(IBIFN) ; Claim office ID - N IBCOID,IBCOID1,IBIN - S IBIN=$$CURR^IBCEF2(IBIFN),IBCOID1="",IBCOID=$P($$ADDRESS^IBCNSC0(IBIN,.11,5),U,11) - ; - I IBIN D - . I $D(^IBA(364.2,"C",IBIFN)) S IBCOID1=$P($$ADDRESS^IBCNSC0(IBIN,.18,5),U,11) Q ;Rx - . I $P($G(^DGCR(399,IBIFN,0)),U,5)<3 S IBCOID1=$P($$ADDRESS^IBCNSC0(IBIN,.12,5),U,11) Q ;Inpt - . I $P($G(^DGCR(399,IBIFN,0)),U,5)'<3 S IBCOID1=$P($$ADDRESS^IBCNSC0(IBIN,.16,5),U,11) Q ;Outpt - ; - Q $S(IBCOID1'="":IBCOID1,1:IBCOID) - ; -ESGHPST(IBIFN,COB) ; return insureds employment status if the bill policy defined by COB is an Employer Sponsored Group Health Plan - ; ESGHP FLAG (2.312,2.1) ^ the employment status (2.312,2.11) - ; - N PPOL,DFN,X,Y S Y="" - S PPOL=$$PPOL^IBCEF2($G(IBIFN),$G(COB)),DFN=$P($G(^DGCR(399,+$G(IBIFN),0)),U,2) - I +PPOL,+DFN S X=$G(^DPT(DFN,.312,+PPOL,2)) S Y=+$P(X,U,10)_U_$P(X,U,11) - Q Y - ; -ESGHPNL(IBIFN,COB) ; return employer name and location if the bill policy defined by COB is an Employer Sponsored Group Health Plan - ; ESGHP FLAG (2.312,2.1) ^ employer name (2.312,2.015) ^ employer city (2.312,2.05) - ; ^ employer state abbr (2.312,2.06) ^ employer state ifn (2.312,2.06) - ; - N PPOL,DFN,X,Y S Y="" - S PPOL=$$PPOL^IBCEF2($G(IBIFN),$G(COB)),DFN=$P($G(^DGCR(399,+$G(IBIFN),0)),U,2) - I +PPOL,+DFN S X=$G(^DPT(DFN,.312,+PPOL,2)) S Y=+$P(X,U,10)_U_$P(X,U,9)_U_$P(X,U,5)_U_$P($G(^DIC(5,+$P(X,U,6),0)),U,2)_U_$P(X,U,6) - Q Y - ; -REMARKS(IBIFN) ; Compile array of bill remarks - ;IBIFN = bill ien - N Z,Z0,Z1,IBARRAY,IBSM - S Z=0 - ;S:$P($G(^DGCR(399,IBIFN,"U1")),U,2) Z=Z+1,Z0=$P(^("U1"),U,2),IBXDATA(Z)="OFFSET AMOUNT: "_"$"_+$P(Z0,".")_"."_$E($P(Z0,".",2)_"00",1,2) - S:$P($G(^DGCR(399,IBIFN,"U1")),U,8)'="" Z=Z+1,IBXDATA(Z)=$P(^("U1"),U,8) ;Bill comment on bill - S Z0=$G(^DGCR(399,IBIFN,0)),Z1=$G(^DGCR(399.3,+$P(Z0,U,7),0)) - D SET^IBCSC5B(IBIFN,.IBARRAY) - I $P($G(IBARRAY),U,2) D ;Prosthetics - . S Z0=0 F S Z0=$O(IBARRAY(Z0)) Q:Z0="" S Z1=0 F S Z1=$O(IBARRAY(Z0,Z1)) Q:'Z1 S Z=Z+1,IBXDATA(Z)="Prosthetic: "_$E($$PINB^IBCSC5B(+IBARRAY(Z0,Z1)),1,39)_" "_$E(Z0,4,5)_"/"_$E(Z0,6,7)_"/"_$E(Z0,1,2) - Q - ; -CREM(IBIFN) ; Compile array of bill remarks common to every bill - ;IBIFN = bill ien - N Z - S Z=0 - S:$P($G(^IBE(350.9,1,1)),U,4)'="" Z=Z+1,IBXDATA(Z)=$P(^(1),U,4) ;Site specific 'every bill' comment - Q - ; -ADMDT(IBIFN,NOOUTCK) ; Calculate admission/start of care date/time - ; IBIFN = bill ien - ; NOOUTCK = flag that will: - ; (1) no check for inpt episode overlap for outpt - ; (0 or null) performs check for inpt episode overlap for outpt - ; - ; Returns IBXDATA = fileman date format - N Z,Z0,Z1 - S Z=$G(^DGCR(399,IBIFN,0)),Z1=$P($G(^("U")),U,20),Z0=$$INPAT^IBCEF(IBIFN,1) - S IBXDATA=$S(Z0&$P(Z,U,8):$P($G(^DGPT(+$P(Z,U,8),0)),U,2),1:"") - S:'IBXDATA IBXDATA=$P(Z,U,3)_$S(Z0&(Z1<25):"."_$E("0",$L(Z1))_Z1,1:"") - ; Check to see if outpt episode (date in event date) overlaps inpt - ; episode - use admit date if it does - I 'Z0,IBXDATA,'$G(NOOUTCK) D - . N VAINDT,VAIN,DFN - . S VAINDT=IBXDATA,DFN=$P($G(^DGCR(399,IBIFN,0)),U) - . D INP^VADPT S IBXDATA=+VAIN(7) S:'IBXDATA IBXDATA="" - I 'IBXDATA,'Z0 S IBXDATA=$$SERVDT^IBCEF(IBIFN,,2) - Q - ; -DISDT(IBIFN) ; Calculate discharge date - ; IBIFN = bill ien - N Z,Z0 - S Z=$$INPAT^IBCEF(IBIFN,1),Z0=$G(^DGCR(399,IBIFN,0)) - I Z S IBXDATA=+$G(^DGPT(+$P(Z0,U,8),70)) S:'IBXDATA IBXDATA=$P(Z0,U,16) - I 'Z N VAINDT,VAIN,DFN S DFN=$P($G(^DGCR(399,IBIFN,0)),U,2) D INP^VADPT I VAIN(1) S IBXDATA=+$G(^DGPM(+$P($G(^DGPM(+VAIN(1),0)),U,17),0)) - Q - ; -INSSECID(IBIFN,TYPE,SEQ) ; Extract subscriber and patient prim/sec ID's - ; IBIFN required - ; TYPE is either "PAT" or "SUB" to indicate we need to extract either - ; patient or subscriber ID information. Default="SUB". - ; SEQ is the insurance sequence# (1,2,3). Default is current ins seq#. - ; - ; Output: - ; Function returns an 8-piece string as follows. - ; [1] primary qualifier - ; [2] primary ID - ; [3] secondary qual(1) - ; [4] secondary ID(1) - ; [5] secondary qual(2) - ; [6] secondary ID(2) - ; [7] secondary qual(3) - ; [8] secondary ID(3) - ; - NEW DATA,DFN,POL,IB0,IB5,REL - S DATA="" - S IBIFN=+$G(IBIFN) I 'IBIFN G INSSX - I $G(TYPE)="" S TYPE="SUB" ; default type of ID's to get - I '$F(".PAT.SUB.","."_TYPE_".") G INSSX - I '$G(SEQ) S SEQ=$$COBN^IBCEF(IBIFN) ; default current ins seq# - I '$F(".1.2.3.","."_SEQ_".") G INSSX - S DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2) I 'DFN G INSSX - S POL=+$P($G(^DGCR(399,IBIFN,"M")),U,SEQ+11) I 'POL G INSSX - S IB0=$G(^DPT(DFN,.312,POL,0)) I IB0="" G INSSX - S IB5=$G(^DPT(DFN,.312,POL,5)) - S REL=+$P(IB0,U,16) ; pat rel to insured - S $P(DATA,U,1)="MI" - S $P(DATA,U,2)=$P(IB0,U,2) ; subscriber primary ID - S $P(DATA,U,3,8)=$P(IB5,U,2,7) ; subscriber secondary data - I TYPE="PAT",REL'=1 D - . S $P(DATA,U,2)=$P(IB5,U,1) ; patient primary ID - . S $P(DATA,U,3,8)=$P(IB5,U,8,13) ; patient secondary data - . Q - ; - S DATA=$$SCRUB(DATA) ; scrub the data -INSSX ; - Q DATA - ; -SCRUB(DATA) ; Scrub the 8-piece string gathered above - NEW PCE - ; - ; make sure you can't have an ID without a qualifier or a qualifier - ; without an ID. Check all 4 pairs. - F PCE=1,3,5,7 D - . I $P(DATA,U,PCE)'="",$P(DATA,U,PCE+1)'="" Q - . S ($P(DATA,U,PCE),$P(DATA,U,PCE+1))="" - . Q - ; - ; fill in secondary gaps. If Set1 and Set2 are blank, but Set3 exists - ; then move Set3 to Set1 and delete Set3. - I $P(DATA,U,3)="",$P(DATA,U,5)="",$P(DATA,U,7)'="" D - . S $P(DATA,U,3)=$P(DATA,U,7),$P(DATA,U,4)=$P(DATA,U,8) - . S ($P(DATA,U,7),$P(DATA,U,8))="" - . Q - ; - ; fill in secondary gaps more generically. - ; If Set(n) is blank, but Set(n+1) exists, then move it up. - F PCE=3,5 D - . I $P(DATA,U,PCE)="",$P(DATA,U,PCE+2)'="" D - .. S $P(DATA,U,PCE)=$P(DATA,U,PCE+2) - .. S $P(DATA,U,PCE+1)=$P(DATA,U,PCE+3) - .. S ($P(DATA,U,PCE+2),$P(DATA,U,PCE+3))="" - .. Q - . Q - ; - Q DATA - ; +IBCEF21 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS CONTINUED ;06-FEB-96 + ;;2.0;INTEGRATED BILLING;**51,296**;21-MAR-94 + ; +COID(IBIFN) ; Claim office ID + N IBCOID,IBCOID1,IBIN + S IBIN=$$CURR^IBCEF2(IBIFN),IBCOID1="",IBCOID=$P($$ADDRESS^IBCNSC0(IBIN,.11,5),U,11) + ; + I IBIN D + . I $D(^IBA(364.2,"C",IBIFN)) S IBCOID1=$P($$ADDRESS^IBCNSC0(IBIN,.18,5),U,11) Q ;Rx + . I $P($G(^DGCR(399,IBIFN,0)),U,5)<3 S IBCOID1=$P($$ADDRESS^IBCNSC0(IBIN,.12,5),U,11) Q ;Inpt + . I $P($G(^DGCR(399,IBIFN,0)),U,5)'<3 S IBCOID1=$P($$ADDRESS^IBCNSC0(IBIN,.16,5),U,11) Q ;Outpt + ; + Q $S(IBCOID1'="":IBCOID1,1:IBCOID) + ; +ESGHPST(IBIFN,COB) ; return insureds employment status if the bill policy defined by COB is an Employer Sponsored Group Health Plan + ; ESGHP FLAG (2.312,2.1) ^ the employment status (2.312,2.11) + ; + N PPOL,DFN,X,Y S Y="" + S PPOL=$$PPOL^IBCEF2($G(IBIFN),$G(COB)),DFN=$P($G(^DGCR(399,+$G(IBIFN),0)),U,2) + I +PPOL,+DFN S X=$G(^DPT(DFN,.312,+PPOL,2)) S Y=+$P(X,U,10)_U_$P(X,U,11) + Q Y + ; +ESGHPNL(IBIFN,COB) ; return employer name and location if the bill policy defined by COB is an Employer Sponsored Group Health Plan + ; ESGHP FLAG (2.312,2.1) ^ employer name (2.312,2.015) ^ employer city (2.312,2.05) + ; ^ employer state abbr (2.312,2.06) ^ employer state ifn (2.312,2.06) + ; + N PPOL,DFN,X,Y S Y="" + S PPOL=$$PPOL^IBCEF2($G(IBIFN),$G(COB)),DFN=$P($G(^DGCR(399,+$G(IBIFN),0)),U,2) + I +PPOL,+DFN S X=$G(^DPT(DFN,.312,+PPOL,2)) S Y=+$P(X,U,10)_U_$P(X,U,9)_U_$P(X,U,5)_U_$P($G(^DIC(5,+$P(X,U,6),0)),U,2)_U_$P(X,U,6) + Q Y + ; +REMARKS(IBIFN) ; Compile array of bill remarks + ;IBIFN = bill ien + N Z,Z0,Z1,IBARRAY,IBSM + S Z=0 + ;S:$P($G(^DGCR(399,IBIFN,"U1")),U,2) Z=Z+1,Z0=$P(^("U1"),U,2),IBXDATA(Z)="OFFSET AMOUNT: "_"$"_+$P(Z0,".")_"."_$E($P(Z0,".",2)_"00",1,2) + S:$P($G(^DGCR(399,IBIFN,"U1")),U,8)'="" Z=Z+1,IBXDATA(Z)=$P(^("U1"),U,8) ;Bill comment on bill + S Z0=$G(^DGCR(399,IBIFN,0)),Z1=$G(^DGCR(399.3,+$P(Z0,U,7),0)) + D SET^IBCSC5B(IBIFN,.IBARRAY) + I $P($G(IBARRAY),U,2) D ;Prosthetics + . S Z0=0 F S Z0=$O(IBARRAY(Z0)) Q:Z0="" S Z1=0 F S Z1=$O(IBARRAY(Z0,Z1)) Q:'Z1 S Z=Z+1,IBXDATA(Z)="Prosthetic: "_$E($P($$PIN^IBCSC5B(Z1),U,2),1,39)_" "_$E(Z0,4,5)_"/"_$E(Z0,6,7)_"/"_$E(Z0,1,2) + Q + ; +CREM(IBIFN) ; Compile array of bill remarks common to every bill + ;IBIFN = bill ien + N Z + S Z=0 + S:$P($G(^IBE(350.9,1,1)),U,4)'="" Z=Z+1,IBXDATA(Z)=$P(^(1),U,4) ;Site specific 'every bill' comment + Q + ; +ADMDT(IBIFN,NOOUTCK) ; Calculate admission/start of care date/time + ; IBIFN = bill ien + ; NOOUTCK = flag that will: + ; (1) no check for inpt episode overlap for outpt + ; (0 or null) performs check for inpt episode overlap for outpt + ; + ; Returns IBXDATA = fileman date format + N Z,Z0,Z1 + S Z=$G(^DGCR(399,IBIFN,0)),Z1=$P($G(^("U")),U,20),Z0=$$INPAT^IBCEF(IBIFN,1) + S IBXDATA=$S(Z0&$P(Z,U,8):$P($G(^DGPT(+$P(Z,U,8),0)),U,2),1:"") + S:'IBXDATA IBXDATA=$P(Z,U,3)_$S(Z0&(Z1<25):"."_$E("0",$L(Z1))_Z1,1:"") + ; Check to see if outpt episode (date in event date) overlaps inpt + ; episode - use admit date if it does + I 'Z0,IBXDATA,'$G(NOOUTCK) D + . N VAINDT,VAIN,DFN + . S VAINDT=IBXDATA,DFN=$P($G(^DGCR(399,IBIFN,0)),U) + . D INP^VADPT S IBXDATA=+VAIN(7) S:'IBXDATA IBXDATA="" + I 'IBXDATA,'Z0 S IBXDATA=$$SERVDT^IBCEF(IBIFN,,2) + Q + ; +DISDT(IBIFN) ; Calculate discharge date + ; IBIFN = bill ien + N Z,Z0 + S Z=$$INPAT^IBCEF(IBIFN,1),Z0=$G(^DGCR(399,IBIFN,0)) + I Z S IBXDATA=+$G(^DGPT(+$P(Z0,U,8),70)) S:'IBXDATA IBXDATA=$P(Z0,U,16) + I 'Z N VAINDT,VAIN,DFN S DFN=$P($G(^DGCR(399,IBIFN,0)),U,2) D INP^VADPT I VAIN(1) S IBXDATA=+$G(^DGPM(+$P($G(^DGPM(+VAIN(1),0)),U,17),0)) + Q + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF22.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF22.m index 2e5d9b37..c2571b3e 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF22.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF22.m @@ -1,129 +1,129 @@ -IBCEF22 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS ;06-FEB-96 - ;;2.0;INTEGRATED BILLING;**51,137,135,155,309,349,389**;21-MAR-94;Build 6 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ; OVERFLOW FROM ROUTINE IBCEF2 -HOS(IBIFN) ; Extract rev codes for episode billed on a UB-04 into IBXDATA - ; IBIFN = bill ien - ; Format: IBXDATA(n) = - ; rev cd ptr ^ CPT CODE ptr ^ unit chg ^ units ^ tot charge - ; ^ tot uncov^ FL49 value ^ ien of rev code multiple entry(s) - ; (separated by ";") - ; ^ modifiers specific to rev code/proc (separated by ",") - ; ^ rev code date, if it can be determined by a corresponding proc - ; - ; Also Returns IBXDATA(IBI,"COB",COB,m) with COB data for each line - ; item found in an accepted EOB for the bill and = the reference - ; line in the first '^' piece followed by the '0' node of file - ; 361.115 (LINE LEVEL ADJUSTMENTS) - ; COB = COB seq # of adjustment's ins co, m = seq # - ; -- AND -- - ; IBXDATA(IBI,"COB",COB,m,z,p)= - ; the '0' node for each subordinate entry of file - ; 361.11511 (REASONS) (Only first 3 pieces for 837) - ; z = group code, sometimes preceeded by a space p = seq # - ; - N IBDA,IBCOMB,IBINPAT,IBLN,IBX,IBY,IBZ,IBS,IBSS,IBXTRA,IBX1,IBXS,IBP,IBPO,IBP1,IBDEF,Z,Z0,Z1,ZX,QQ,IBMOD - S IBINPAT=$$INPAT^IBCEF(IBIFN,1) - I 'IBINPAT D F^IBCEF("N-STATEMENT COVERS FROM DATE","IBZ",,IBIFN) - S IBDEF=$G(IBZ) - ; loop through all proc codes - sort by procedure, modifiers and print order - S IBDA=0 F S IBDA=$O(^DGCR(399,IBIFN,"CP",IBDA)) Q:'IBDA S IBZ=$G(^(IBDA,0)) I IBZ D - . S IBP(+$P(IBZ,U)_U_$$GETMOD^IBEFUNC(IBIFN,IBDA,1),$S($P(IBZ,U,4):$P(IBZ,U,4),1:999),IBDA)=$P(IBZ,U,2) - ; loop through all rev codes - sort by rev code - S IBDA=0 F S IBDA=$O(^DGCR(399,IBIFN,"RC",IBDA)) Q:'IBDA S IBZ=$G(^(IBDA,0)) I IBZ S IBMOD="" D - . S IBX=$G(^DGCR(399.2,+IBZ,0)),IBX1="",IBPO=0 - . ; Auto-added procedure charge - . I $P(IBZ,U,10)=4,$P(IBZ,U,11) D ; Soft link to proc - .. S Z=$G(^DGCR(399,IBIFN,"CP",$P(IBZ,U,11),0)) - .. Q:Z="" - .. S ZX=+Z_U_$$GETMOD^IBEFUNC(IBIFN,$P(IBZ,U,11),1) - .. Q:'$O(IBP(ZX,0))&'$O(IBP1(ZX,0)) - .. I $P(IBZ,U,6) Q:$S($P(Z,U)'["ICPT":1,1:+$P(Z,U)'=$P(IBZ,U,6)) - .. S Z0=$S($D(IBP(ZX)):$O(IBP(ZX,0)),1:$O(IBP1(ZX,0))) - .. S:'Z0 Z0=999 - .. Q:'$D(IBP(ZX,+Z0,$P(IBZ,U,11)))&'$D(IBP1(ZX,+Z0,$P(IBZ,U,11))) - .. I '$D(IBP1(ZX,+Z0,$P(IBZ,U,11))) S IBP1(ZX,+Z0,$P(IBZ,U,11))=IBP(ZX,+Z0,$P(IBZ,U,11)) K IBP(ZX,+Z0,$P(IBZ,U,11)) - .. S IBX1=$P(Z,U,2),IBPO=+Z0,IBMOD=$P(ZX,U,2) - . ; Manually added charge with a procedure - . I $P(IBZ,U,6),$S($P(IBZ,U,10)=4:'$P(IBZ,U,11),1:1),+$O(IBP($P(IBZ,U,6)))=$P(IBZ,U,6) D - .. ; No direct link, but a proc exists on rev code and in procedure mult without and then with modifiers - .. S ZX=$O(IBP($P(IBZ,U,6))) - .. F QQ=1,2 Q:IBPO S Z="" F S Z=$O(IBP(ZX,Z),-1) Q:'Z!(IBPO) S Z0=0 F S Z0=$O(IBP(ZX,Z,Z0)) Q:'Z0 S Z1=$G(^DGCR(399,IBIFN,"CP",Z0,0)) D Q:IBPO - ... ; Ignore if not a CPT or a modifier exists and this is first pass - ... S IBMOD=$$GETMOD^IBEFUNC(IBIFN,Z0,1) - ... Q:$S($P(Z1,U)'["ICPT":1,QQ=1:IBMOD'="",1:0) - ... S IBPO=+$P(Z1,U,4),IBX1=$P(Z1,U,2) - ... K IBP(+Z1_U_IBMOD,Z,Z0) - . ; - . I IBX'="" D ; revenue code is valid - .. F Z=900:1 S Z0=$S(IBPO:IBPO,$D(IBX(" "_$P(IBX,U),Z)):0,1:Z) I Z0 S IBPO=Z0 Q - .. S IBX(" "_$P(IBX,U),IBPO,IBDA)=IBX,IBX(" "_$P(IBX,U),IBPO,IBDA,"DT")=$S(IBX1:IBX1,1:IBDEF),IBX(" "_$P(IBX,U),IBPO,IBDA,"MOD")=IBMOD - ; - S IBS="" F S IBS=$O(IBX(IBS)) Q:IBS="" S IBPO=0 F S IBPO=$O(IBX(IBS,IBPO)) Q:'IBPO D - . S IBDA=0 F S IBDA=$O(IBX(IBS,IBPO,IBDA)) Q:'IBDA S IBX=$G(IBX(IBS,IBPO,IBDA)),IBZ=$G(^DGCR(399,IBIFN,"RC",IBDA,0)) I IBX'="" D - .. ;S IBXS=$P(IBZ,U,2)_U_$P(IBZ,U,6)_U_$G(IBX(IBS,IBPO,IBDA,"MOD")) - .. S IBXS=U_$P(IBZ,U,6)_U_$G(IBX(IBS,IBPO,IBDA,"MOD")) ;combine same proc and modifiers regardless of rate - .. S:IBPO'<900&'$$ACCRV($P(IBS," ",2))&$S(IBINPAT:$P(IBZ,U,6),1:1) IBCOMB(IBS,IBXS,IBPO)=IBDA - .. S:'$D(IBX1(IBS,IBPO,IBXS,1)) IBX1(IBS,IBPO,IBXS,1)=IBX,IBX1(IBS,IBPO,IBXS,2)=IBZ - .. S $P(IBX1(IBS,IBPO,IBXS),U)=$P($G(IBX1(IBS,IBPO,IBXS)),U)+$P(IBZ,U,3) - .. S $P(IBX1(IBS,IBPO,IBXS),U,2)=$P($G(IBX1(IBS,IBPO,IBXS)),U,2)+$P(IBZ,U,4) - .. S IBX1(IBS,IBPO,IBXS,"DT")=$G(IBX(IBS,IBPO,IBDA,"DT")),IBX1(IBS,IBPO,IBXS,"IEN")=$G(IBX1(IBS,IBPO,IBXS,"IEN"))_$S($G(IBX1(IBS,IBPO,IBXS,"IEN")):";",1:"")_IBDA - ; - S IBS="" F S IBS=$O(IBX1(IBS)) Q:IBS="" S IBPO=899 F S IBPO=$O(IBX1(IBS,IBPO)) Q:'IBPO D ; Check to combine like rev codes without print order - . N Q,Q0,Q1,Z,Z0,Z1,Z2,IBZ1,IBZ2 - . S Z="" - . N IBACC - . F S Z=$O(IBX1(IBS,IBPO,Z)) Q:Z="" S Q=IBPO F S Q=$O(IBCOMB(IBS,Z,Q)) Q:'Q I Q'=IBPO S IBZ1=$G(IBX1(IBS,IBPO,Z,1)),IBZ2=$G(IBX1(IBS,IBPO,Z,2)) D - .. Q:$G(IBX1(IBS,IBPO,Z,1))'=$G(IBX1(IBS,Q,Z,1)) - .. S Q1=1,IBACC=$$ACCRV(+$P(IBS," ",2)) - .. F Q0=1,5:1:7,10:1:13,15 D Q:'Q1 - ... I IBACC Q:Q0=5!(Q0>6) - ... I (Q0=11!(Q0=15))&($P($G(IBX1(IBS,Q,Z,2)),U,10)=3) Q - ... I Q0=5,'IBINPAT Q - ... I $P($G(IBX1(IBS,IBPO,Z,2)),U,Q0)'=$P($G(IBX1(IBS,Q,Z,2)),U,Q0) S Q1=0 - .. Q:'Q1 - .. S $P(IBX1(IBS,IBPO,Z,2),U,3)=$P(IBX1(IBS,IBPO,Z,2),U,3)+$P(IBX1(IBS,Q,Z,2),U,3) - .. S $P(IBX1(IBS,IBPO,Z,2),U,4)=$P(IBX1(IBS,IBPO,Z,2),U,4)+$P(IBX1(IBS,Q,Z,2),U,4) - .. S $P(IBX1(IBS,IBPO,Z,2),U,9)=$P(IBX1(IBS,IBPO,Z,2),U,9)+$P(IBX1(IBS,Q,Z,2),U,9) - .. S IBX1(IBS,IBPO,Z)=$P(IBX1(IBS,IBPO,Z,2),U,3)_U_$P(IBX1(IBS,IBPO,Z,2),U,4) - .. S IBX1(IBS,IBPO,Z,"IEN")=IBX1(IBS,IBPO,Z,"IEN")_";"_IBX1(IBS,Q,Z,"IEN") - .. K IBX1(IBS,Q,Z) - ; - S IBS="",IBLN=0 - F S IBS=$O(IBX1(IBS)) Q:IBS="" S IBPO=0 F S IBPO=$O(IBX1(IBS,IBPO)) Q:'IBPO S IBSS="" F S IBSS=$O(IBX1(IBS,IBPO,IBSS)) Q:IBSS="" D - . S IBX=$G(IBX1(IBS,IBPO,IBSS,1)),IBZ=$G(IBX1(IBS,IBPO,IBSS,2)) - . S IBLN=$G(IBLN)+1,IBXDATA(IBLN)=$P(IBX,U)_U_$P(IBZ,U,6)_U_$P(IBZ,U,2)_U_+IBX1(IBS,IBPO,IBSS)_U_+$P(IBX1(IBS,IBPO,IBSS),U,2),$P(IBXDATA(IBLN),U,10)=$G(IBX1(IBS,IBPO,IBSS,"DT")) - . S $P(IBXDATA(IBLN),U,6)=$P(IBZ,U,9),$P(IBXDATA(IBLN),U,7)=$P(IBZ,U,13),$P(IBXDATA(IBLN),U,8)=$G(IBX1(IBS,IBPO,IBSS,"IEN")),$P(IBXDATA(IBLN),U,9)=$P($P(IBSS,U,3),",",1,2) - . ; Extract line lev COB data for sec or tert bill - . I $$COBN^IBCEF(IBIFN)>1 D COBLINE^IBCEU6(IBIFN,IBLN,.IBXDATA,,.IBXTRA) I $D(IBXTRA) D COMBO^IBCEU2(.IBXDATA,.IBXTRA,1) ;Handle bundled/unbundled - I $D(^IBA(362.4,"AIFN"_IBIFN))!$D(^IBA(362.5,"AIFN"_IBIFN)) D - . N IBARRAY,IBX,IBZ,IBRX,IBLCNT - . S IBLCNT=0 - . ; Print prescriptions, prosthetics on front of UB-04 - . D SET^IBCSC5A(IBIFN,.IBARRAY) - . I $P(IBARRAY,U,2) D - .. S IBX=+$P(IBARRAY,U,2)+2 - .. S IBLCNT=IBLCNT+1,IBXSAVE("RX-UB-04",IBLCNT)="" - .. S IBLCNT=IBLCNT+1,IBXSAVE("RX-UB-04",IBLCNT)="PRESCRIPTION REFILLS:",IBLCNT=2 - .. S IBX=0 F S IBX=$O(IBARRAY(IBX)) Q:IBX="" S IBY=0 F S IBY=$O(IBARRAY(IBX,IBY)) Q:'IBY S IBRX=IBARRAY(IBX,IBY) D - ... D ZERO^IBRXUTL(+$P(IBRX,U,2)) - ... S IBLCNT=IBLCNT+1,IBXSAVE("RX-UB-04",IBLCNT)=IBX_$J(" ",(11-$L(IBX)))_" "_$J($S($P(IBRX,U,6):"$"_$FN($P(IBRX,U,6),",",2),1:""),10)_" "_$J($$FMTE^XLFDT(IBY,2),8)_" "_$G(^TMP($J,"IBDRUG",+$P(IBRX,U,2),.01)) - ... S IBZ=$S(+$P(IBRX,U,4):"QTY: "_$P(IBRX,U,4)_" ",1:"")_$S(+$P(IBRX,U,3):"for "_$P(IBRX,U,3)_" days supply ",1:"") I IBZ'="" S IBLCNT=IBLCNT+1,IBXSAVE("RX-UB-04",IBLCNT)=$J(" ",35)_IBZ - ... S IBZ=$S($P(IBRX,U,5)'="":"NDC #: "_$P(IBRX,U,5),1:"") I IBZ'="" S IBLCNT=IBLCNT+1,IBXSAVE("RX-UB-04",IBLCNT)=$J(" ",35)_IBZ - ... K ^TMP($J,"IBDRUG") - ... Q - . ; - . D SET^IBCSC5B(IBIFN,.IBARRAY) - . I $P(IBARRAY,U,2) D - .. S IBLCNT=0 - .. S IBX=+$P(IBARRAY,U,2)+2 - .. S IBLCNT=IBLCNT+1,IBXSAVE("PROS-UB-04",IBLCNT)="" - .. S IBLCNT=IBLCNT+1,IBXSAVE("PROS-UB-04",IBLCNT)="PROSTHETIC REFILLS:",IBLCNT=2 - .. S IBX=0 F S IBX=$O(IBARRAY(IBX)) Q:IBX="" S IBY=0 F S IBY=$O(IBARRAY(IBX,IBY)) Q:'IBY D - ... S IBLCNT=IBLCNT+1,IBXSAVE("PROS-UB-04",IBLCNT)=$$FMTE^XLFDT(IBX,2)_" "_$J($S($P(IBARRAY(IBX,IBY),U,2):"$"_$FN($P(IBARRAY(IBX,IBY),U,2),",",2),1:""),10)_" "_$E($$PINB^IBCSC5B(+IBARRAY(IBX,IBY)),1,54) - Q - ; -ACCRV(X) ; Returns 1 if X is an accomodation RC, 0 if not - Q ((X'<100&(X'>219))!(X=224)) - ; +IBCEF22 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS ;06-FEB-96 + ;;2.0;INTEGRATED BILLING;**51,137,135,155,309,349**;21-MAR-94;Build 46 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; + ; OVERFLOW FROM ROUTINE IBCEF2 +HOS(IBIFN) ; Extract rev codes for episode billed on a UB-04 into IBXDATA + ; IBIFN = bill ien + ; Format: IBXDATA(n) = + ; rev cd ptr ^ CPT CODE ptr ^ unit chg ^ units ^ tot charge + ; ^ tot uncov^ FL49 value ^ ien of rev code multiple entry(s) + ; (separated by ";") + ; ^ modifiers specific to rev code/proc (separated by ",") + ; ^ rev code date, if it can be determined by a corresponding proc + ; + ; Also Returns IBXDATA(IBI,"COB",COB,m) with COB data for each line + ; item found in an accepted EOB for the bill and = the reference + ; line in the first '^' piece followed by the '0' node of file + ; 361.115 (LINE LEVEL ADJUSTMENTS) + ; COB = COB seq # of adjustment's ins co, m = seq # + ; -- AND -- + ; IBXDATA(IBI,"COB",COB,m,z,p)= + ; the '0' node for each subordinate entry of file + ; 361.11511 (REASONS) (Only first 3 pieces for 837) + ; z = group code, sometimes preceeded by a space p = seq # + ; + N IBDA,IBCOMB,IBINPAT,IBLN,IBX,IBY,IBZ,IBS,IBSS,IBXTRA,IBX1,IBXS,IBP,IBPO,IBP1,IBDEF,Z,Z0,Z1,ZX,QQ,IBMOD + S IBINPAT=$$INPAT^IBCEF(IBIFN,1) + I 'IBINPAT D F^IBCEF("N-STATEMENT COVERS FROM DATE","IBZ",,IBIFN) + S IBDEF=$G(IBZ) + ; loop through all proc codes - sort by procedure, modifiers and print order + S IBDA=0 F S IBDA=$O(^DGCR(399,IBIFN,"CP",IBDA)) Q:'IBDA S IBZ=$G(^(IBDA,0)) I IBZ D + . S IBP(+$P(IBZ,U)_U_$$GETMOD^IBEFUNC(IBIFN,IBDA,1),$S($P(IBZ,U,4):$P(IBZ,U,4),1:999),IBDA)=$P(IBZ,U,2) + ; loop through all rev codes - sort by rev code + S IBDA=0 F S IBDA=$O(^DGCR(399,IBIFN,"RC",IBDA)) Q:'IBDA S IBZ=$G(^(IBDA,0)) I IBZ S IBMOD="" D + . S IBX=$G(^DGCR(399.2,+IBZ,0)),IBX1="",IBPO=0 + . ; Auto-added procedure charge + . I $P(IBZ,U,10)=4,$P(IBZ,U,11) D ; Soft link to proc + .. S Z=$G(^DGCR(399,IBIFN,"CP",$P(IBZ,U,11),0)) + .. Q:Z="" + .. S ZX=+Z_U_$$GETMOD^IBEFUNC(IBIFN,$P(IBZ,U,11),1) + .. Q:'$O(IBP(ZX,0))&'$O(IBP1(ZX,0)) + .. I $P(IBZ,U,6) Q:$S($P(Z,U)'["ICPT":1,1:+$P(Z,U)'=$P(IBZ,U,6)) + .. S Z0=$S($D(IBP(ZX)):$O(IBP(ZX,0)),1:$O(IBP1(ZX,0))) + .. S:'Z0 Z0=999 + .. Q:'$D(IBP(ZX,+Z0,$P(IBZ,U,11)))&'$D(IBP1(ZX,+Z0,$P(IBZ,U,11))) + .. I '$D(IBP1(ZX,+Z0,$P(IBZ,U,11))) S IBP1(ZX,+Z0,$P(IBZ,U,11))=IBP(ZX,+Z0,$P(IBZ,U,11)) K IBP(ZX,+Z0,$P(IBZ,U,11)) + .. S IBX1=$P(Z,U,2),IBPO=+Z0,IBMOD=$P(ZX,U,2) + . ; Manually added charge with a procedure + . I $P(IBZ,U,6),$S($P(IBZ,U,10)=4:'$P(IBZ,U,11),1:1),+$O(IBP($P(IBZ,U,6)))=$P(IBZ,U,6) D + .. ; No direct link, but a proc exists on rev code and in procedure mult without and then with modifiers + .. S ZX=$O(IBP($P(IBZ,U,6))) + .. F QQ=1,2 Q:IBPO S Z="" F S Z=$O(IBP(ZX,Z),-1) Q:'Z!(IBPO) S Z0=0 F S Z0=$O(IBP(ZX,Z,Z0)) Q:'Z0 S Z1=$G(^DGCR(399,IBIFN,"CP",Z0,0)) D Q:IBPO + ... ; Ignore if not a CPT or a modifier exists and this is first pass + ... S IBMOD=$$GETMOD^IBEFUNC(IBIFN,Z0,1) + ... Q:$S($P(Z1,U)'["ICPT":1,QQ=1:IBMOD'="",1:0) + ... S IBPO=+$P(Z1,U,4),IBX1=$P(Z1,U,2) + ... K IBP(+Z1_U_IBMOD,Z,Z0) + . ; + . I IBX'="" D ; revenue code is valid + .. F Z=900:1 S Z0=$S(IBPO:IBPO,$D(IBX(" "_$P(IBX,U),Z)):0,1:Z) I Z0 S IBPO=Z0 Q + .. S IBX(" "_$P(IBX,U),IBPO,IBDA)=IBX,IBX(" "_$P(IBX,U),IBPO,IBDA,"DT")=$S(IBX1:IBX1,1:IBDEF),IBX(" "_$P(IBX,U),IBPO,IBDA,"MOD")=IBMOD + ; + S IBS="" F S IBS=$O(IBX(IBS)) Q:IBS="" S IBPO=0 F S IBPO=$O(IBX(IBS,IBPO)) Q:'IBPO D + . S IBDA=0 F S IBDA=$O(IBX(IBS,IBPO,IBDA)) Q:'IBDA S IBX=$G(IBX(IBS,IBPO,IBDA)),IBZ=$G(^DGCR(399,IBIFN,"RC",IBDA,0)) I IBX'="" D + .. ;S IBXS=$P(IBZ,U,2)_U_$P(IBZ,U,6)_U_$G(IBX(IBS,IBPO,IBDA,"MOD")) + .. S IBXS=U_$P(IBZ,U,6)_U_$G(IBX(IBS,IBPO,IBDA,"MOD")) ;combine same proc and modifiers regardless of rate + .. S:IBPO'<900&'$$ACCRV($P(IBS," ",2))&$S(IBINPAT:$P(IBZ,U,6),1:1) IBCOMB(IBS,IBXS,IBPO)=IBDA + .. S:'$D(IBX1(IBS,IBPO,IBXS,1)) IBX1(IBS,IBPO,IBXS,1)=IBX,IBX1(IBS,IBPO,IBXS,2)=IBZ + .. S $P(IBX1(IBS,IBPO,IBXS),U)=$P($G(IBX1(IBS,IBPO,IBXS)),U)+$P(IBZ,U,3) + .. S $P(IBX1(IBS,IBPO,IBXS),U,2)=$P($G(IBX1(IBS,IBPO,IBXS)),U,2)+$P(IBZ,U,4) + .. S IBX1(IBS,IBPO,IBXS,"DT")=$G(IBX(IBS,IBPO,IBDA,"DT")),IBX1(IBS,IBPO,IBXS,"IEN")=$G(IBX1(IBS,IBPO,IBXS,"IEN"))_$S($G(IBX1(IBS,IBPO,IBXS,"IEN")):";",1:"")_IBDA + ; + S IBS="" F S IBS=$O(IBX1(IBS)) Q:IBS="" S IBPO=899 F S IBPO=$O(IBX1(IBS,IBPO)) Q:'IBPO D ; Check to combine like rev codes without print order + . N Q,Q0,Q1,Z,Z0,Z1,Z2,IBZ1,IBZ2 + . S Z="" + . N IBACC + . F S Z=$O(IBX1(IBS,IBPO,Z)) Q:Z="" S Q=IBPO F S Q=$O(IBCOMB(IBS,Z,Q)) Q:'Q I Q'=IBPO S IBZ1=$G(IBX1(IBS,IBPO,Z,1)),IBZ2=$G(IBX1(IBS,IBPO,Z,2)) D + .. Q:$G(IBX1(IBS,IBPO,Z,1))'=$G(IBX1(IBS,Q,Z,1)) + .. S Q1=1,IBACC=$$ACCRV(+$P(IBS," ",2)) + .. F Q0=1,5:1:7,10:1:13,15 D Q:'Q1 + ... I IBACC Q:Q0=5!(Q0>6) + ... I (Q0=11!(Q0=15))&($P($G(IBX1(IBS,Q,Z,2)),U,10)=3) Q + ... I Q0=5,'IBINPAT Q + ... I $P($G(IBX1(IBS,IBPO,Z,2)),U,Q0)'=$P($G(IBX1(IBS,Q,Z,2)),U,Q0) S Q1=0 + .. Q:'Q1 + .. S $P(IBX1(IBS,IBPO,Z,2),U,3)=$P(IBX1(IBS,IBPO,Z,2),U,3)+$P(IBX1(IBS,Q,Z,2),U,3) + .. S $P(IBX1(IBS,IBPO,Z,2),U,4)=$P(IBX1(IBS,IBPO,Z,2),U,4)+$P(IBX1(IBS,Q,Z,2),U,4) + .. S $P(IBX1(IBS,IBPO,Z,2),U,9)=$P(IBX1(IBS,IBPO,Z,2),U,9)+$P(IBX1(IBS,Q,Z,2),U,9) + .. S IBX1(IBS,IBPO,Z)=$P(IBX1(IBS,IBPO,Z,2),U,3)_U_$P(IBX1(IBS,IBPO,Z,2),U,4) + .. S IBX1(IBS,IBPO,Z,"IEN")=IBX1(IBS,IBPO,Z,"IEN")_";"_IBX1(IBS,Q,Z,"IEN") + .. K IBX1(IBS,Q,Z) + ; + S IBS="",IBLN=0 + F S IBS=$O(IBX1(IBS)) Q:IBS="" S IBPO=0 F S IBPO=$O(IBX1(IBS,IBPO)) Q:'IBPO S IBSS="" F S IBSS=$O(IBX1(IBS,IBPO,IBSS)) Q:IBSS="" D + . S IBX=$G(IBX1(IBS,IBPO,IBSS,1)),IBZ=$G(IBX1(IBS,IBPO,IBSS,2)) + . S IBLN=$G(IBLN)+1,IBXDATA(IBLN)=$P(IBX,U)_U_$P(IBZ,U,6)_U_$P(IBZ,U,2)_U_+IBX1(IBS,IBPO,IBSS)_U_+$P(IBX1(IBS,IBPO,IBSS),U,2),$P(IBXDATA(IBLN),U,10)=$G(IBX1(IBS,IBPO,IBSS,"DT")) + . S $P(IBXDATA(IBLN),U,6)=$P(IBZ,U,9),$P(IBXDATA(IBLN),U,7)=$P(IBZ,U,13),$P(IBXDATA(IBLN),U,8)=$G(IBX1(IBS,IBPO,IBSS,"IEN")),$P(IBXDATA(IBLN),U,9)=$P($P(IBSS,U,3),",",1,2) + . ; Extract line lev COB data for sec or tert bill + . I $$COBN^IBCEF(IBIFN)>1 D COBLINE^IBCEU6(IBIFN,IBLN,.IBXDATA,,.IBXTRA) I $D(IBXTRA) D COMBO^IBCEU2(.IBXDATA,.IBXTRA,1) ;Handle bundled/unbundled + I $D(^IBA(362.4,"AIFN"_IBIFN))!$D(^IBA(362.5,"AIFN"_IBIFN)) D + . N IBARRAY,IBX,IBZ,IBRX,IBLCNT + . S IBLCNT=0 + . ; Print prescriptions, prosthetics on front of UB-04 + . D SET^IBCSC5A(IBIFN,.IBARRAY) + . I $P(IBARRAY,U,2) D + .. S IBX=+$P(IBARRAY,U,2)+2 + .. S IBLCNT=IBLCNT+1,IBXSAVE("RX-UB-04",IBLCNT)="" + .. S IBLCNT=IBLCNT+1,IBXSAVE("RX-UB-04",IBLCNT)="PRESCRIPTION REFILLS:",IBLCNT=2 + .. S IBX=0 F S IBX=$O(IBARRAY(IBX)) Q:IBX="" S IBY=0 F S IBY=$O(IBARRAY(IBX,IBY)) Q:'IBY S IBRX=IBARRAY(IBX,IBY) D + ... D ZERO^IBRXUTL(+$P(IBRX,U,2)) + ... S IBLCNT=IBLCNT+1,IBXSAVE("RX-UB-04",IBLCNT)=IBX_$J(" ",(11-$L(IBX)))_" "_$J($S($P(IBRX,U,6):"$"_$FN($P(IBRX,U,6),",",2),1:""),10)_" "_$J($$FMTE^XLFDT(IBY,2),8)_" "_$G(^TMP($J,"IBDRUG",+$P(IBRX,U,2),.01)) + ... S IBZ=$S(+$P(IBRX,U,4):"QTY: "_$P(IBRX,U,4)_" ",1:"")_$S(+$P(IBRX,U,3):"for "_$P(IBRX,U,3)_" days supply ",1:"") I IBZ'="" S IBLCNT=IBLCNT+1,IBXSAVE("RX-UB-04",IBLCNT)=$J(" ",35)_IBZ + ... S IBZ=$S($P(IBRX,U,5)'="":"NDC #: "_$P(IBRX,U,5),1:"") I IBZ'="" S IBLCNT=IBLCNT+1,IBXSAVE("RX-UB-04",IBLCNT)=$J(" ",35)_IBZ + ... K ^TMP($J,"IBDRUG") + ... Q + . ; + . D SET^IBCSC5B(IBIFN,.IBARRAY) + . I $P(IBARRAY,U,2) D + .. S IBLCNT=0 + .. S IBX=+$P(IBARRAY,U,2)+2 + .. S IBLCNT=IBLCNT+1,IBXSAVE("PROS-UB-04",IBLCNT)="" + .. S IBLCNT=IBLCNT+1,IBXSAVE("PROS-UB-04",IBLCNT)="PROSTHETIC REFILLS:",IBLCNT=2 + .. S IBX=0 F S IBX=$O(IBARRAY(IBX)) Q:IBX="" S IBY=0 F S IBY=$O(IBARRAY(IBX,IBY)) Q:'IBY D + ... S IBLCNT=IBLCNT+1,IBXSAVE("PROS-UB-04",IBLCNT)=$$FMTE^XLFDT(IBX,2)_" "_$J($S($P(IBARRAY(IBX,IBY),U,2):"$"_$FN($P(IBARRAY(IBX,IBY),U,2),",",2),1:""),10)_" "_$E($P($$PIN^IBCSC5B(IBY),U,2),1,54) + Q + ; +ACCRV(X) ; Returns 1 if X is an accomodation RC, 0 if not + Q ((X'<100&(X'>219))!(X=224)) + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF3.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF3.m index 95306ed4..d56c6ea7 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF3.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF3.m @@ -1,239 +1,239 @@ -IBCEF3 ;ALB/TMP - FORMATTER SPECIFIC BILL FLD FUNCTIONS ;17-JUNE-96 - ;;2.0;INTEGRATED BILLING;**52,84,121,51,152,210,155,348,349,389**;21-MAR-94;Build 6 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -MPG(PG,FLDS,FORM) ; Set static flds on pages after page 1 - ; for either 1500 or UB - ; PG = page # - ; FORM= 1 for UB, otherwise for 1500 - ; FLDS: array passed by reference and containing lines OR - ; line/column from pg 1 to repeat on subsequent pages - ; Format: FLDS(LINE,COL) or FLDS(LINE) for whole line - ; CMS-1500: LINES 1-5,7-43,57 from col 1 to 50, 58-63 - ; UB: see CKPGUB for lines and columns - ; - N Z,Z0,Z1,LPG - S FORM=$S($G(FORM)=1:3,1:2) - I FORM=2 D ; print page # on each pg, totals on last page of 1500 - . S LPG=+$O(^TMP("IBXDATA",$J,IBXREC,""),-1) - . S Z="[Page "_PG_" of "_LPG_"]" - . S Z=$$FO^IBCNEUT1(Z,17,"R") - . D SETGBL^IBCEFG(PG,6,61,Z,.IBXSIZE) - . I PG=2 S Z=$P(Z,"[",1)_"[Page 1 of "_LPG_"]" D SETGBL^IBCEFG(1,6,61,Z,.IBXSIZE) - . I LPG=PG D - .. ; - .. ; esg - IB*2*348 - update dollar format for last page of 1500 - .. ; - .. D SETGBL^IBCEFG(PG,57,51,$$DOL^IBCEF77($G(IBXSAVE("TOT")),9),.IBXSIZE) - .. D SETGBL^IBCEFG(PG,57,62,$$DOL^IBCEF77($G(IBXSAVE("PAID")),8),.IBXSIZE) - .. D SETGBL^IBCEFG(PG,57,71,$$DOL^IBCEF77($G(IBXSAVE("BDUE")),8),.IBXSIZE) - .. K IBXSAVE("PTOT"),IBXSAVE("TOT"),IBXSAVE("BDUE"),IBXSAVE("PAID") - ; - S Z=0 F S Z=$O(FLDS(Z)) Q:'Z D - . I $O(FLDS(Z,""))="" D Q ;repeats line - .. S Z0=0 F S Z0=$O(^TMP("IBXDATA",$J,IBXREC,1,Z,Z0)) Q:'Z0 S Z1=$G(^(Z0)) I Z1'="" D SETGBL^IBCEFG(PG,Z,Z0,Z1,.IBXSIZE) - . S Z0=0 F S Z0=$O(FLDS(Z,Z0)) Q:'Z0 S Z1=$G(^TMP("IBXDATA",$J,IBXREC,1,Z,Z0)) I Z1'="" D SETGBL^IBCEFG(PG,Z,Z0,Z1,.IBXSIZE) - . I FORM=2,LPG'=PG D - .. D SETGBL^IBCEFG(PG,57,51,"",.IBXSIZE) - .. D SETGBL^IBCEFG(PG,57,71,"",.IBXSIZE) - Q - ; -NONSERV(Z,Z0) ; Set variable if non-service/non-text data is present for box - ; 24 of CMS-1500 - ; Z = sequence of IBXSAVE being processed - ; Z0 = sequnce within IBXDATA to indicate actual line # - I $P(IBXSAVE("BOX24",Z),U)="" S IBXSAVE("NON-SERV",Z0)="" - Q - ; -PG(VAL,LNCT) ;Set next pg for CMS-1500 lines - ;VAL = value of fld - ;LNCT = line # from IBXSAVE("BOX24") array - N IBP,IBL - S IBP=LNCT\12+(LNCT#12>0),IBL=LNCT-(12*(IBP-1))-1 - I IBL'<0 S VAL=$$FORMAT(VAL,$G(IBXLOOP("IBX0")),$G(IBXDA)) D SETGBL^IBCEFG(IBP,IBXLN+IBL,IBXCOL,VAL,.IBXSIZE) - K IBXDATA(LNCT) - Q - ; -MPGUB(PG,OFFSET,VAL,IBLN,IBCOL,NOFORM) ; Set up pages > 1 for UB overflows - ; PG = Page # to set (REQUIRED) - ; OFFSET = offset from first line this should be extracted into - ; 0 = first line (REQUIRED) - ; VAL = value to set (REQUIRED) - ; IBLN = line to set data at (if null, uses IBXLN) - ; IBCOL = column to set data at (if null, uses IBXCOL) - ; NOFORM = don't format, just output data as passed - ; Assumes formatter IBXLN,IBXCOL variables exist - ; - I $G(IBLN)="" S IBLN=IBXLN - I $G(IBCOL)="" S IBCOL=IBXCOL - S:'$G(NOFORM) VAL=$$FORMAT(VAL,$G(IBXLOOP("IBX0")),$G(IBXDA)) - D SETGBL^IBCEFG(PG,IBLN+OFFSET,IBCOL,VAL,.IBXSIZE) - Q - ; -CKREV(CT,VAL) ; Check too many rev code lines to fit on page - ; This procedure is only called when CT>22 (i.e. 23 or more) - ; - D MPGUB((CT-1)\22+1,CT-1#22,VAL) ; 22 codes on a single page - Q - ; -CKPGUB ; Check to see if multiple UB pages are needed then populate - ; static flds from page 1, add page numbers - ; - N FLDS,LPG,IBPG,IBP,Z,Z0,TOT1,TOT2 - ; - S LPG=$O(^TMP("IBXDATA",$J,IBXREC,""),-1),IBP=0 - S Z="" F S Z=$O(^TMP("IBXDATA",$J,IBXREC,LPG,Z),-1) Q:'Z S Z0=0 F S Z0=$O(^TMP("IBXDATA",$J,IBXREC,LPG,Z,Z0)) Q:'Z0 I $G(^(Z0))'="" S IBP=1 Q - I 'IBP K ^TMP("IBXDATA",$J,IBXREC,LPG) S LPG=$O(^TMP("IBXDATA",$J,IBXREC,""),-1) Q:LPG=1 - ; - ; Static flds - F Z=2:1:7 S FLDS(Z)="" ; FL-1 thru FL-9 - F Z=1,10,13,19,22,25,28,31 S FLDS(9,Z)="" ; FL-10 thru FL-17 - F Z=13:1:17 S FLDS(Z,1)="" ; payer address in FL-38 - S FLDS(41,46)="" ; creation date - F Z=42,43,44,45,47,48,49,51,52,53 S FLDS(Z)="" ; FL-50 thru FL-65 - F Z=57,59,61,63 S (FLDS(Z,59),FLDS(Z,72),FLDS(Z,74))="" ; FL-76-79 ID's - F Z=58,60,62,64 S (FLDS(Z,53),FLDS(Z,71))="" ; FL-76-79 Names - ; - F IBPG=1:1:LPG D - . ; Add pg # to last line of rev codes if multiple pages - . N IB,IBP - . S IB=$G(^TMP("IBXDATA",$J,IBXREC,IBPG,41,6)) - . D MPGUB(IBPG,0,IBPG,41,10,1) - . D MPGUB(IBPG,0,LPG,41,16,1) - . D:IBPG>1 MPG(IBPG,.FLDS,1) - . Q - ; print totals on line 41 of the last page - S (TOT1,TOT2)=0 - F Z=1:1 Q:'$D(^TMP($J,"IBC-RC",Z)) S Z0=^(Z) I +Z0=1 S TOT1=TOT1+$P(Z0,U,7),TOT2=TOT2+$P(Z0,U,8) - D MPGUB(IBPG,0,"0001",41,1,1) - D MPGUB(IBPG,0,$$DOL^IBCEF77(TOT1,9),41,61,1) - D MPGUB(IBPG,0,$$DOL^IBCEF77(TOT2,9),41,71,1) - ; - Q - ; -HCPC(R) ;FORMAT HCPC fld FOR UB (returns formatted value) - ; R = flag for type of fld (1/2/3) being printed in rev code block - Q R ;No longer used as of patch IB*2.0*51 - ; -PROS(IBIFN) ; Extract billable prosthetics for 837 - N IBARRAY,Z,Z0,CT,PROS - D SET^IBCSC5B(IBIFN,.IBARRAY) - I '$P(IBARRAY,U,2) S CT="" G PROSQ - S Z="",CT=0 - F S Z=$O(IBARRAY(Z)) Q:Z="" S Z0="" F S Z0=$O(IBARRAY(Z,Z0)) Q:Z0="" S CT=CT+1 D - .S PROS=$$PINB^IBCSC5B(+IBARRAY(Z,Z0)) ; P389 removed p2 - item ptr file 661 - .;date^^short descr^entry # in file 362.5 - .S IBXDATA(CT)=Z_U_U_PROS_U_+IBARRAY(Z,Z0) -PROSQ Q CT - ; -B24(IBXSV,IBIFN,IBNOSHOW) ; Code to execute to set up IBXSV("BOX24") for - ; print or IBXSAVE("OUTPT") for transmit - called by output formatter - ; IBNOSHOW = 1 if not to show error/warning text lines - ; Pass IBXSV by reference - N IBSUB - S IBSUB=$S('$G(^TMP("IBTX",$J,IBIFN)):"BOX24",1:"OUTPT") - K IBXSV(IBSUB) - I '$D(IBIFN) S IBIFN=$G(IBXIEN) - I IBIFN D F^IBCEF("N-HCFA 1500 SERVICE"_$S(IBSUB["24":"S (PRINT",1:" LINE (EDI")_")",,,IBIFN) - I $S(IBSUB'["24":1,1:'$G(IBNOSHOW)) D - . M IBXSV(IBSUB)=IBXDATA - E D - . N Z,CT - . S (Z,CT)=0 F S Z=$O(IBXDATA(Z)) Q:'Z I '$D(IBXDATA(Z,"ARX")) S CT=CT+1 M IBXSV(IBSUB,CT)=IBXDATA(Z) - Q - ; - ; esg - 11/14/03 - Moved the below functions due to space constraints - ; -ALLTYP(IBIFN) Q $$ALLTYP^IBCEF31(IBIFN) -INSTYP(IBIFN,SEQ) Q $$INSTYP^IBCEF31(IBIFN,$G(SEQ)) -POLTYP(IBIFN,IBSEQ) Q $$POLTYP^IBCEF31(IBIFN,$G(IBSEQ)) -ALLPTYP(IBIFN) Q $$ALLPTYP^IBCEF31(IBIFN) - ; -FILL(Z) ; - Q - ; - ; ***** - ; The following code performs the multi-page set up for - ; printing overflow data on the UB - ; ***** - ; -XPROC(DATA,CT) ; Output any UB procedures after 6 on new page(s) - ; DATA = output data from IBXSAVE("PROC",CT) - ; CT = array sequence # of the procedure being output - ; Only used for local prints - N OFFSET,PG,COL,PRCODE,Q - S Q=(CT-1)\3#2,OFFSET=$S('Q:0,1:2) - S PG=(CT-1)\6+1,COL=1+(CT-1#3*15) - D MPGUB(PG,OFFSET,$P(DATA,U,1),58,COL) - D MPGUB(PG,OFFSET,$P(DATA,U,2),58,COL+9) - Q - ; -XDIAG(DATA,CT) ; Output any UB other diagnoses after 8 on new page(s) - ; DATA = output data from IBXSAVE("DX",CT) - ; CT = array sequence # of the diagnosis being output - ; Only used for local prints - N COL,PG - S PG=(CT-1)\8+1,COL=8+(CT-1#9*7) - S DATA=$P($$ICD9^IBACSV(+DATA),U,1) - D MPGUB(PG,0,DATA,56,COL) - Q - ; -XVAL(DATA,CT) ; Output any UB value codes after 12 on new page(s) - ; DATA = output data from IBXSAVE("VC",CT) - ; CT = array sequence # of the value code being output - ; - N COL,PG,OFFSET - S PG=(CT-1)\12+1,COL=44+(CT-1#3*13),OFFSET=(CT-(12*(PG-1))-1)\3 - D MPGUB(PG,OFFSET,$P(DATA,U,1),14,COL) - D MPGUB(PG,OFFSET,$P(DATA,U,2),14,COL+3) - Q - ; -XCC(DATA,CT) ; Output any UB condition codes after 11 on new page(s) - ; 11 condition codes per page, starting columns 34 thru 64 - ; DATA = output data from IBXSAVE("CC",CT) - ; CT = array sequence # of the condition code being output - ; - N COL,PG - S PG=(CT-1)\11+1,COL=34+(CT-1#11*3) - D MPGUB(PG,0,DATA,9,COL) - Q - ; -XOCC(DATA,CT,FL) ; Output any UB occurrence codes after 8 (2 per form - ; locators 31-34) on new page(s) - ; DATA = data from IBXSAVE("OCC",z) to be output - ; CT = array sequence # of occurrence code being output - ; FL = # of form locator being populated with the occ code - ; - N COL,PG,OFFSET - S PG=(CT-1)\2+1,COL=1+((FL-31)*10),OFFSET=$S(CT#2:0,1:1) - D MPGUB(PG,OFFSET,$P(DATA,U,1),11,COL) - D MPGUB(PG,OFFSET,$P(DATA,U,2),11,COL+4) - Q - ; -XOCCS(DATA,CT,FL) ; Output any UB occurrence span codes after 4 on new page(s) - ; DATA = data from IBXSAVE("OCCS",z) to be output - ; CT = array sequence # of occurrence span code being output - ; FL = # of form locator being populated (either FL 35 or 36) - ; - N COL,PG,OFFSET - S PG=(CT-1)\2+1,OFFSET=$S(CT#2:0,1:1) - S COL=41+((FL-35)*17) - D MPGUB(PG,OFFSET,$P(DATA,U,1),11,COL) - D MPGUB(PG,OFFSET,$P(DATA,U,2),11,COL+4) - D MPGUB(PG,OFFSET,$P(DATA,U,3),11,COL+11) - Q - ; -FORMAT(VAL,IBX0,IBXDA) ; - I IBX0'="",IBXDA S VAL=$$FORMAT^IBCEFG(VAL,$P($G(^IBA(364.6,+IBXDA,0)),U,9),$P(IBX0,U,7),IBX0) - Q VAL - ; -OUTPDT(IBIFN,IBXSAVE,IBXDATA) ; Returns outpatient service to date - ; formatted CCYYMMDD for UB 837 - ; IBIFN = ien of bill (file 399) - ; IBXSAVE = pass by reference for IBXSAVE("INPT") and IBXSAVE("DATE") - ; IBXDATA = array with formatted date or each line item - CCYYMMDD - N Z - S Z=0 F S Z=$O(IBXSAVE("INPT",Z)) Q:'Z S IBXDATA(Z)=$S($P(IBXSAVE("INPT",Z),U,10):$$DT^IBCEFG1($P(IBXSAVE("INPT",Z),U,10),,"D8"),1:IBXSAVE("DATE")) - K IBXSAVE("DATE") - Q - ; +IBCEF3 ;ALB/TMP - FORMATTER SPECIFIC BILL FLD FUNCTIONS ;17-JUNE-96 + ;;2.0;INTEGRATED BILLING;**52,84,121,51,152,210,155,348,349**;21-MAR-94;Build 46 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; +MPG(PG,FLDS,FORM) ; Set static flds on pages after page 1 + ; for either 1500 or UB + ; PG = page # + ; FORM= 1 for UB, otherwise for 1500 + ; FLDS: array passed by reference and containing lines OR + ; line/column from pg 1 to repeat on subsequent pages + ; Format: FLDS(LINE,COL) or FLDS(LINE) for whole line + ; CMS-1500: LINES 1-5,7-43,57 from col 1 to 50, 58-63 + ; UB: see CKPGUB for lines and columns + ; + N Z,Z0,Z1,LPG + S FORM=$S($G(FORM)=1:3,1:2) + I FORM=2 D ; print page # on each pg, totals on last page of 1500 + . S LPG=+$O(^TMP("IBXDATA",$J,IBXREC,""),-1) + . S Z="[Page "_PG_" of "_LPG_"]" + . S Z=$$FO^IBCNEUT1(Z,17,"R") + . D SETGBL^IBCEFG(PG,6,61,Z,.IBXSIZE) + . I PG=2 S Z=$P(Z,"[",1)_"[Page 1 of "_LPG_"]" D SETGBL^IBCEFG(1,6,61,Z,.IBXSIZE) + . I LPG=PG D + .. ; + .. ; esg - IB*2*348 - update dollar format for last page of 1500 + .. ; + .. D SETGBL^IBCEFG(PG,57,51,$$DOL^IBCEF77($G(IBXSAVE("TOT")),9),.IBXSIZE) + .. D SETGBL^IBCEFG(PG,57,62,$$DOL^IBCEF77($G(IBXSAVE("PAID")),8),.IBXSIZE) + .. D SETGBL^IBCEFG(PG,57,71,$$DOL^IBCEF77($G(IBXSAVE("BDUE")),8),.IBXSIZE) + .. K IBXSAVE("PTOT"),IBXSAVE("TOT"),IBXSAVE("BDUE"),IBXSAVE("PAID") + ; + S Z=0 F S Z=$O(FLDS(Z)) Q:'Z D + . I $O(FLDS(Z,""))="" D Q ;repeats line + .. S Z0=0 F S Z0=$O(^TMP("IBXDATA",$J,IBXREC,1,Z,Z0)) Q:'Z0 S Z1=$G(^(Z0)) I Z1'="" D SETGBL^IBCEFG(PG,Z,Z0,Z1,.IBXSIZE) + . S Z0=0 F S Z0=$O(FLDS(Z,Z0)) Q:'Z0 S Z1=$G(^TMP("IBXDATA",$J,IBXREC,1,Z,Z0)) I Z1'="" D SETGBL^IBCEFG(PG,Z,Z0,Z1,.IBXSIZE) + . I FORM=2,LPG'=PG D + .. D SETGBL^IBCEFG(PG,57,51,"",.IBXSIZE) + .. D SETGBL^IBCEFG(PG,57,71,"",.IBXSIZE) + Q + ; +NONSERV(Z,Z0) ; Set variable if non-service/non-text data is present for box + ; 24 of CMS-1500 + ; Z = sequence of IBXSAVE being processed + ; Z0 = sequnce within IBXDATA to indicate actual line # + I $P(IBXSAVE("BOX24",Z),U)="" S IBXSAVE("NON-SERV",Z0)="" + Q + ; +PG(VAL,LNCT) ;Set next pg for CMS-1500 lines + ;VAL = value of fld + ;LNCT = line # from IBXSAVE("BOX24") array + N IBP,IBL + S IBP=LNCT\12+(LNCT#12>0),IBL=LNCT-(12*(IBP-1))-1 + I IBL'<0 S VAL=$$FORMAT(VAL,$G(IBXLOOP("IBX0")),$G(IBXDA)) D SETGBL^IBCEFG(IBP,IBXLN+IBL,IBXCOL,VAL,.IBXSIZE) + K IBXDATA(LNCT) + Q + ; +MPGUB(PG,OFFSET,VAL,IBLN,IBCOL,NOFORM) ; Set up pages > 1 for UB overflows + ; PG = Page # to set (REQUIRED) + ; OFFSET = offset from first line this should be extracted into + ; 0 = first line (REQUIRED) + ; VAL = value to set (REQUIRED) + ; IBLN = line to set data at (if null, uses IBXLN) + ; IBCOL = column to set data at (if null, uses IBXCOL) + ; NOFORM = don't format, just output data as passed + ; Assumes formatter IBXLN,IBXCOL variables exist + ; + I $G(IBLN)="" S IBLN=IBXLN + I $G(IBCOL)="" S IBCOL=IBXCOL + S:'$G(NOFORM) VAL=$$FORMAT(VAL,$G(IBXLOOP("IBX0")),$G(IBXDA)) + D SETGBL^IBCEFG(PG,IBLN+OFFSET,IBCOL,VAL,.IBXSIZE) + Q + ; +CKREV(CT,VAL) ; Check too many rev code lines to fit on page + ; This procedure is only called when CT>22 (i.e. 23 or more) + ; + D MPGUB((CT-1)\22+1,CT-1#22,VAL) ; 22 codes on a single page + Q + ; +CKPGUB ; Check to see if multiple UB pages are needed then populate + ; static flds from page 1, add page numbers + ; + N FLDS,LPG,IBPG,IBP,Z,Z0,TOT1,TOT2 + ; + S LPG=$O(^TMP("IBXDATA",$J,IBXREC,""),-1),IBP=0 + S Z="" F S Z=$O(^TMP("IBXDATA",$J,IBXREC,LPG,Z),-1) Q:'Z S Z0=0 F S Z0=$O(^TMP("IBXDATA",$J,IBXREC,LPG,Z,Z0)) Q:'Z0 I $G(^(Z0))'="" S IBP=1 Q + I 'IBP K ^TMP("IBXDATA",$J,IBXREC,LPG) S LPG=$O(^TMP("IBXDATA",$J,IBXREC,""),-1) Q:LPG=1 + ; + ; Static flds + F Z=2:1:7 S FLDS(Z)="" ; FL-1 thru FL-9 + F Z=1,10,13,19,22,25,28,31 S FLDS(9,Z)="" ; FL-10 thru FL-17 + F Z=13:1:17 S FLDS(Z,1)="" ; payer address in FL-38 + S FLDS(41,46)="" ; creation date + F Z=42,43,44,45,47,48,49,51,52,53 S FLDS(Z)="" ; FL-50 thru FL-65 + F Z=57,59,61,63 S (FLDS(Z,59),FLDS(Z,72),FLDS(Z,74))="" ; FL-76-79 ID's + F Z=58,60,62,64 S (FLDS(Z,53),FLDS(Z,71))="" ; FL-76-79 Names + ; + F IBPG=1:1:LPG D + . ; Add pg # to last line of rev codes if multiple pages + . N IB,IBP + . S IB=$G(^TMP("IBXDATA",$J,IBXREC,IBPG,41,6)) + . D MPGUB(IBPG,0,IBPG,41,10,1) + . D MPGUB(IBPG,0,LPG,41,16,1) + . D:IBPG>1 MPG(IBPG,.FLDS,1) + . Q + ; print totals on line 41 of the last page + S (TOT1,TOT2)=0 + F Z=1:1 Q:'$D(^TMP($J,"IBC-RC",Z)) S Z0=^(Z) I +Z0=1 S TOT1=TOT1+$P(Z0,U,7),TOT2=TOT2+$P(Z0,U,8) + D MPGUB(IBPG,0,"0001",41,1,1) + D MPGUB(IBPG,0,$$DOL^IBCEF77(TOT1,9),41,61,1) + D MPGUB(IBPG,0,$$DOL^IBCEF77(TOT2,9),41,71,1) + ; + Q + ; +HCPC(R) ;FORMAT HCPC fld FOR UB (returns formatted value) + ; R = flag for type of fld (1/2/3) being printed in rev code block + Q R ;No longer used as of patch IB*2.0*51 + ; +PROS(IBIFN) ; Extract billable prosthetics for 837 + N IBARRAY,Z,Z0,CT,PROS + D SET^IBCSC5B(IBIFN,.IBARRAY) + I '$P(IBARRAY,U,2) S CT="" G PROSQ + S Z="",CT=0 + F S Z=$O(IBARRAY(Z)) Q:Z="" S Z0="" F S Z0=$O(IBARRAY(Z,Z0)) Q:Z0="" S CT=CT+1 D + .S PROS=$P($$PIN^IBCSC5B(+$P($G(^IBA(362.5,+IBARRAY(Z,Z0),0)),U,3)),U,2) + .;date^item ptr file 661^short descr from file 441^entry # in file 362.5 + .S IBXDATA(CT)=Z_U_Z0_U_PROS_U_+IBARRAY(Z,Z0) +PROSQ Q CT + ; +B24(IBXSV,IBIFN,IBNOSHOW) ; Code to execute to set up IBXSV("BOX24") for + ; print or IBXSAVE("OUTPT") for transmit - called by output formatter + ; IBNOSHOW = 1 if not to show error/warning text lines + ; Pass IBXSV by reference + N IBSUB + S IBSUB=$S('$G(^TMP("IBTX",$J,IBIFN)):"BOX24",1:"OUTPT") + K IBXSV(IBSUB) + I '$D(IBIFN) S IBIFN=$G(IBXIEN) + I IBIFN D F^IBCEF("N-HCFA 1500 SERVICE"_$S(IBSUB["24":"S (PRINT",1:" LINE (EDI")_")",,,IBIFN) + I $S(IBSUB'["24":1,1:'$G(IBNOSHOW)) D + . M IBXSV(IBSUB)=IBXDATA + E D + . N Z,CT + . S (Z,CT)=0 F S Z=$O(IBXDATA(Z)) Q:'Z I '$D(IBXDATA(Z,"ARX")) S CT=CT+1 M IBXSV(IBSUB,CT)=IBXDATA(Z) + Q + ; + ; esg - 11/14/03 - Moved the below functions due to space constraints + ; +ALLTYP(IBIFN) Q $$ALLTYP^IBCEF31(IBIFN) +INSTYP(IBIFN,SEQ) Q $$INSTYP^IBCEF31(IBIFN,$G(SEQ)) +POLTYP(IBIFN,IBSEQ) Q $$POLTYP^IBCEF31(IBIFN,$G(IBSEQ)) +ALLPTYP(IBIFN) Q $$ALLPTYP^IBCEF31(IBIFN) + ; +FILL(Z) ; + Q + ; + ; ***** + ; The following code performs the multi-page set up for + ; printing overflow data on the UB + ; ***** + ; +XPROC(DATA,CT) ; Output any UB procedures after 6 on new page(s) + ; DATA = output data from IBXSAVE("PROC",CT) + ; CT = array sequence # of the procedure being output + ; Only used for local prints + N OFFSET,PG,COL,PRCODE,Q + S Q=(CT-1)\3#2,OFFSET=$S('Q:0,1:2) + S PG=(CT-1)\6+1,COL=1+(CT-1#3*15) + D MPGUB(PG,OFFSET,$P(DATA,U,1),58,COL) + D MPGUB(PG,OFFSET,$P(DATA,U,2),58,COL+9) + Q + ; +XDIAG(DATA,CT) ; Output any UB other diagnoses after 8 on new page(s) + ; DATA = output data from IBXSAVE("DX",CT) + ; CT = array sequence # of the diagnosis being output + ; Only used for local prints + N COL,PG + S PG=(CT-1)\8+1,COL=8+(CT-1#9*7) + S DATA=$P($$ICD9^IBACSV(+DATA),U,1) + D MPGUB(PG,0,DATA,56,COL) + Q + ; +XVAL(DATA,CT) ; Output any UB value codes after 12 on new page(s) + ; DATA = output data from IBXSAVE("VC",CT) + ; CT = array sequence # of the value code being output + ; + N COL,PG,OFFSET + S PG=(CT-1)\12+1,COL=44+(CT-1#3*13),OFFSET=(CT-(12*(PG-1))-1)\3 + D MPGUB(PG,OFFSET,$P(DATA,U,1),14,COL) + D MPGUB(PG,OFFSET,$P(DATA,U,2),14,COL+3) + Q + ; +XCC(DATA,CT) ; Output any UB condition codes after 11 on new page(s) + ; 11 condition codes per page, starting columns 34 thru 64 + ; DATA = output data from IBXSAVE("CC",CT) + ; CT = array sequence # of the condition code being output + ; + N COL,PG + S PG=(CT-1)\11+1,COL=34+(CT-1#11*3) + D MPGUB(PG,0,DATA,9,COL) + Q + ; +XOCC(DATA,CT,FL) ; Output any UB occurrence codes after 8 (2 per form + ; locators 31-34) on new page(s) + ; DATA = data from IBXSAVE("OCC",z) to be output + ; CT = array sequence # of occurrence code being output + ; FL = # of form locator being populated with the occ code + ; + N COL,PG,OFFSET + S PG=(CT-1)\2+1,COL=1+((FL-31)*10),OFFSET=$S(CT#2:0,1:1) + D MPGUB(PG,OFFSET,$P(DATA,U,1),11,COL) + D MPGUB(PG,OFFSET,$P(DATA,U,2),11,COL+4) + Q + ; +XOCCS(DATA,CT,FL) ; Output any UB occurrence span codes after 4 on new page(s) + ; DATA = data from IBXSAVE("OCCS",z) to be output + ; CT = array sequence # of occurrence span code being output + ; FL = # of form locator being populated (either FL 35 or 36) + ; + N COL,PG,OFFSET + S PG=(CT-1)\2+1,OFFSET=$S(CT#2:0,1:1) + S COL=41+((FL-35)*17) + D MPGUB(PG,OFFSET,$P(DATA,U,1),11,COL) + D MPGUB(PG,OFFSET,$P(DATA,U,2),11,COL+4) + D MPGUB(PG,OFFSET,$P(DATA,U,3),11,COL+11) + Q + ; +FORMAT(VAL,IBX0,IBXDA) ; + I IBX0'="",IBXDA S VAL=$$FORMAT^IBCEFG(VAL,$P($G(^IBA(364.6,+IBXDA,0)),U,9),$P(IBX0,U,7),IBX0) + Q VAL + ; +OUTPDT(IBIFN,IBXSAVE,IBXDATA) ; Returns outpatient service to date + ; formatted CCYYMMDD for UB 837 + ; IBIFN = ien of bill (file 399) + ; IBXSAVE = pass by reference for IBXSAVE("INPT") and IBXSAVE("DATE") + ; IBXDATA = array with formatted date or each line item - CCYYMMDD + N Z + S Z=0 F S Z=$O(IBXSAVE("INPT",Z)) Q:'Z S IBXDATA(Z)=$S($P(IBXSAVE("INPT",Z),U,10):$$DT^IBCEFG1($P(IBXSAVE("INPT",Z),U,10),,"D8"),1:IBXSAVE("DATE")) + K IBXSAVE("DATE") + Q + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF73.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF73.m index 004851ef..4b8e501b 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF73.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF73.m @@ -1,274 +1,267 @@ -IBCEF73 ;WOIFO/SS - FORMATTER AND EXTRACTOR SPECIFIC BILL FUNCTIONS ;8/6/03 10:56am - ;;2.0;INTEGRATED BILLING;**232,320,358,349,377**;21-MAR-94;Build 23 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ;check qualifier - ;IBFRM 0-both, 1=UB,2=1500 - ;IBPROV - function in #399 (1-referring, 2-operating,etc) - ;IBTYPE - "C"-current insurance, "O"-other insurance - ;IBVAL - value to check -CHCKSEC(IBFRM,IBPROV,IBTYPE,IBVAL) ; - I IBFRM=0 Q:$$CHSEC(1,IBPROV,IBTYPE,IBVAL) 1 Q $$CHSEC(2,IBPROV,IBTYPE,IBVAL) - Q $$CHSEC(IBFRM,IBPROV,IBTYPE,IBVAL) - ; -CHSEC(IBFRM,IBPROV,IBTYPE,IBVAL) ; - N IBSTR S IBSTR="" - ;referring - I IBPROV=1 S IBSTR=$S(IBTYPE="C":$$OPR5(IBFRM),IBTYPE="O":$$OP4(IBFRM),1:"") - ;operating - I IBPROV=2 S IBSTR=$S(IBTYPE="C":$$OPR3(IBFRM),IBTYPE="O":$$OP2(IBFRM),1:"") - ;rendering - I IBPROV=3 S IBSTR=$S(IBTYPE="C":$$OPR2(IBFRM),IBTYPE="O":$$OP1(IBFRM),1:"") - ;attending - I IBPROV=4 S IBSTR=$S(IBTYPE="C":$$OPR2(IBFRM),IBTYPE="O":$$OP1(IBFRM),1:"") - ;supervising - I IBPROV=5 S IBSTR=$S(IBTYPE="C":$$OPR8(IBFRM),IBTYPE="O":$$OP8(IBFRM),1:"") - ;other - I IBPROV=9 S IBSTR=$S(IBTYPE="C":$$OPR4(IBFRM),IBTYPE="O":$$OP9(IBFRM),1:"") - Q:IBPROV=0!(IBSTR="") 1 ;if "" or facility id always return 1 - Q IBSTR[("^"_IBVAL_"^") - ; - ;Filter invalid qualifier entries for records SUB1,SUB2,OP6,OP7,OP3 - ; Rebuild the IBXSAVE("PROVINF" or IBXSAVE("PROVINF_FAC" array with - ; only ids that have valid qualifiers - ;IBFRM 0-both, 1=UB,2=1500 - ;IBREC record ID whose ids are being filtered (SUB1,SUB2,etc) - ;IBFAC - 1 if facility check, 0 if attending/rendering check - ;IBTYPE - "C"-current insurance, "O"-other insurance - ;IBXSAVE - the array of provider ids extracted, returned filtered - - ; passed by reference -CHCKSUB(IBFRM,IBREC,IBFAC,IBTYPE,IBXSAVE) ; - N Z,Z0,Z1,Z2,CT,IBSAVE - S Z="PROVINF"_$P("^_FAC",U,$G(IBFAC)+1) - I '$G(IBXSAVE(Z,IBXIEN)) D - . D F^IBCEF("N-ALL "_$S($G(IBFAC):"OUTSIDE FAC PROVIDER INF",1:"CUR/OTH PROVIDER INFO")) - M IBSAVE(Z,IBXIEN,IBTYPE)=IBXSAVE(Z,IBXIEN,IBTYPE) K IBXSAVE(Z,IBXIEN,IBTYPE) - S Z0=0 F S Z0=$O(IBSAVE(Z,IBXIEN,IBTYPE,Z0)) Q:'Z0 S Z1="" F S Z1=$O(IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1)) Q:Z1="" S (Z2,CT)=0 F S Z2=$O(IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,Z2)) Q:'Z2 D - . N IBVAL - . S IBVAL=$P(IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,Z2),U,3) - . I IBFRM=0 D Q - .. I $S($$CHSUB(1,IBREC,IBVAL):1,1:$$CHSUB(2,IBPROV,IBTYPE,IBVAL)) D - ... S CT=CT+1,IBXSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,CT)=IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,Z2) - ... I $G(IBXSAVE(Z,IBXIEN,IBTYPE,Z0))="",$G(IBSAVE(Z,IBXIEN,IBTYPE,Z0))'="" S IBXSAVE(Z,IBXIEN,IBTYPE,Z0)=IBSAVE(Z,IBXIEN,IBTYPE,Z0) - . I $$CHSUB(IBFRM,IBREC,IBVAL) D - .. S CT=CT+1,IBXSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,CT)=IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,Z2) - .. I $G(IBXSAVE(Z,IBXIEN,IBTYPE,Z0))="",$G(IBSAVE(Z,IBXIEN,IBTYPE,Z0))'="" S IBXSAVE(Z,IBXIEN,IBTYPE,Z0)=IBSAVE(Z,IBXIEN,IBTYPE,Z0) - Q - ; - ; Check if valid qualifier - ;IBFRM 0-both, 1=UB,2=1500 - ;IBREC record ID whose ids are being filtered (SUB1,SUB2,etc) - ;IBVAL - value to check -CHSUB(IBFRM,IBREC,IBVAL) ; - N IBSTR - I IBREC="SUB1" S IBSTR=$$SUB1(IBFRM) - I IBREC="SUB2" S IBSTR=$$SUB2(IBFRM) - I IBREC="OP7" S IBSTR=$$OP7(IBFRM) - I IBREC="OP3" S IBSTR=$$OP3(IBFRM) - I IBREC="OP6" S IBSTR=$$OP6(IBFRM) - Q:$G(IBSTR)="" 1 ;if "" always return 1 - Q IBSTR[("^"_IBVAL_"^") - ; - ;IBFRM 0-both, 1=UB,2=1500 -OPR2(IBFRM) ; - Q:IBFRM=1 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^" - Q:IBFRM=2 "^0B^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^" - Q "" - ; - ;IBFRM 0-both, 1=UB,2=1500 -OP1(IBFRM) ; - Q:IBFRM=1 "^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^" - Q:IBFRM=2 "^1B^1C^1D^EI^G2^LU^N5^" - Q "" - ; - ;IBFRM 0-both, 1=UB,2=1500 -OPR3(IBFRM) ; - Q:IBFRM=1 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^" - Q "" - ; - ;IBFRM 0-both, 1=UB,2=1500 -OP2(IBFRM) ; - Q:IBFRM=1 "^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^" - Q "" - ; - ;IBFRM 0-both, 1=UB,2=1500 -SUB1(IBFRM) ; - Q:IBFRM=1 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^" - Q:IBFRM=2 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^U3^SY^X5^" - Q "" - ; - ;IBFRM 0-both, 1=UB,2=1500 -OPR4(IBFRM) ; - Q:IBFRM=1 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^" - Q "" - ; - ;IBFRM 0-both, 1=UB,2=1500 -OP9(IBFRM) ; - Q:IBFRM=1 "^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^" - Q "" - ; - ;IBFRM 0-both, 1=UB,2=1500 -SUB2(IBFRM) ; - Q:IBFRM=1 "^0B^1A^1B^1C^1G^1H^1J^EI^FH^G2^G5^LU^N5^X5^TJ^B3^BQ^SY^U3^" - Q:IBFRM=2 "^0B^X4^1A^1B^1C^1G^1H^G2^LU^X5^TJ^B3^BQ^SY^U3^" - Q "" - ; - ;IBFRM 0-both, 1=UB,2=1500 -OP3(IBFRM) ; - Q:IBFRM=1 "^1B^1C^EI^G2^LU^N5^" - Q "" - ; - ;IBFRM 0-both, 1=UB,2=1500 -OPR5(IBFRM) ; - Q:IBFRM=2 "^0B^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^" - Q "" - ; - ;IBFRM 0-both, 1=UB,2=1500 -OPR8(IBFRM) ; - Q:IBFRM=2 "^0B^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^" - Q "" - ; - ;IBFRM 0-both, 1=UB,2=1500 -OP4(IBFRM) ; - Q:IBFRM=2 "^1B^1C^1D^EI^G2^LU^N5^" - Q "" - ; - ;IBFRM 0-both, 1=UB,2=1500 -OP8(IBFRM) ; - Q:IBFRM=2 "^1B^1C^1D^EI^G2^N5^" - Q "" - ; - ;IBFRM 0-both, 1=UB,2=1500 -OP6(IBFRM) ; - Q:IBFRM=2 "^1A^1B^1C^G2^LU^N5^" - Q "" - ; - ;IBFRM 0-both, 1=UB,2=1500 -OP7(IBFRM) ; - Q:IBFRM=2 "^1A^1B^1C^G2^LU^N5^" - Q "" - ; - ;check qualifier for PRV1 - ;IBFRM 0-both, 1=UB,2=1500 - ;IBVAL - value to check -CHCKPRV1(IBFRM,IBVAL) ; - I IBFRM=0 Q:$$CHPRV1(1,IBVAL) 1 Q $$CHPRV1(2,IBVAL) - Q $$CHPRV1(IBFRM,IBVAL) - ;IBFRM 0-both, 1=UB,2=1500 -CHPRV1(IBFRM,IBVAL) ; - N IBSTR S IBSTR="" - S IBSTR=$$PRV1(IBFRM) - Q:IBSTR="" 1 - Q IBSTR[("^"_IBVAL_"^") - ; -PRV1(IBFRM) ; - Q:IBFRM=1 "^1A^1C^1D^1G^1H^1J^B3^BQ^EI^FH^G2^G5^LU^SY^X5^" - Q:IBFRM=2 "^1B^1C^1D^1G^1H^1J^B3^BQ^EI^FH^G2^G5^LU^U3^SY^X5^" - Q "" - ; -PTSELF ;This tag is for the CI2 segment. If the IBXSAVE("IADR") is empty - ;check to see if the relationship to pt is 18 (self) if so pull info - ;from PT1 calls - ;See if relationship to insured is 18 if not or if "" quit - N IBZ - D F^IBCEF("N-ALL INSURED PT RELATION","IBZ",,IBXIEN) - S IBZ=$G(IBZ(+$$COBN^IBCEF(IBXIEN))) - S IBZ=$$PRELCNV^IBCNSP1(IBZ,1) - I IBZ'="18" S IBXDATA="" Q - N IBZ D F^IBCEF("N-PATIENT STREET ADDRESS 1-3","IBZ",,IBXIEN) - S IBXDATA="18" - Q - ; -NOPUNCT(X,SPACE,EXC) ; Strip punctuation from data in X - ; SPACE = flag if 1 strip SPACES - ; EXC = list of punct not to strip - ; - N PUNCT,Z - S PUNCT=".,-+(){}[]\/><:;?|=_*&%$#@!~`^'""" - I $G(SPACE) S PUNCT=PUNCT_" " - I $G(EXC)'="" S PUNCT=$TR(PUNCT,EXC) - N L S L="" - F S L=$O(X(L)) Q:L="" D - . S X(L)=$TR(X(L),PUNCT) - I $G(X)'="" D - . S X=$TR(X,PUNCT) - Q - ; -PROVID(IBXIEN) ;This modified version of prov id call is to acquire the SSN - ;first, if the ssn is not available then we need to get the tax id. - ;we also need to provide the modifier for which value it is - Q:+$G(IBXIEN)=0 "" - S IBXSAVE("ID")="" - S IBXSAVE="" - S IBXSAVE=$$PROVSSN^IBCEF7(IBXIEN) - N I - F I=1:1:9 D - . I $P(IBXSAVE,"^",I)]"" S $P(IBXSAVE("ID"),U,I)="34" - ;If no ibxdata go look in 355.97 for 24 - N IBRETVAL S IBRETVAL="" - N IBPTR,IBFT - F IBFT=1:1:9 D - . Q:$P(IBXSAVE,U,IBFT)]"" - . S IBPTR=$$PROVPTR^IBCEF7(IBXIEN,IBFT) - . S $P(IBRETVAL,"^",IBFT)=$$TAX3559(IBPTR) - . I $P(IBRETVAL,U,IBFT)]"" D - . . S $P(IBXSAVE,U,IBFT)=$P(IBRETVAL,U,IBFT) - . . S $P(IBXSAVE("ID"),U,IBFT)="24" - Q IBXSAVE - ; -TAX3559(IBPROV) ; - I $P(IBPROV,";",2)'["IBA(355.9" Q "" - N IB2,IB3559,IBIDTYP,IBID,IBQFL - S (IB3559,IBQFL)=0 - S IBID="" - Q:+$G(IBPROV)=0 "" - F IB2=1:1 S IB3559=$O(^IBA(355.9,"B",IBPROV,IB3559)) Q:IB3559=""!IBQFL D - . S IBIDTYP=+$P($G(^IBA(355.9,IB3559,0)),"^",6) ;provider ID type, ptr to #355.97 - . S IBIDTYP=$P($G(^IBE(355.97,IBIDTYP,0)),"^",3) - . S:IBIDTYP="EI" IBID=$P($G(^IBA(355.9,IB3559,0)),"^",7),IBQFL=1 - ; if nothing found yet, look in file 355.93 for Facility Default ID - I IBID="",IBPROV["IBA(355.93" D - .N IB0,IBFID,IBQ - .S IB0=$G(^IBA(355.93,+IBPROV,0)) Q:IB0=""!($P(IB0,U,2)'=1) ; not a facility - bail out - .S IBFID=$P(IB0,U,9) Q:IBFID="" ; no default id on file - bail out - .S IBQ=$P(IB0,U,13) I +IBQ>0,$P($G(^IBE(355.97,IBQ,0)),U,3)=24 S IBID=IBFID - .Q - Q $$NOPUNCT^IBCEF(IBID) - ; - ;IBFULL-full name - ;IBEL - Name element : "FAMILY","GIVEN","MIDDLE","SUFFIX" - ; -SSN200(IBPTR) ; - I $P(IBPTR,";",2)'="VA(200," Q "" - Q $$NOPUNCT^IBCEF($$GET1^DIQ(200,+$P(IBPTR,";")_",",9)) - ; - ;Input: - ; IBIEN399 - ien in #399 - ;Output: - ; returns a string with "^" delimiters that contains SSNs (if any) - ; in the position that equal to FUNCTION number - ; i.e. if RENDERING function # is 3 then SSN will be - ; in $P(return value,"^",3), etc. - ; -SSN3559(IBPROV) ; - N IB2,IB3559,IBIDTYP,IBID,IBQFL - S (IB3559,IBQFL)=0 - S IBID="" - Q:+$G(IBPROV)=0 "" - F IB2=1:1 S IB3559=$O(^IBA(355.9,"B",IBPROV,IB3559)) Q:IB3559=""!IBQFL D - . S IBIDTYP=+$P($G(^IBA(355.9,IB3559,0)),"^",6) - . S IBIDTYP=$P($G(^IBE(355.97,IBIDTYP,0)),"^",3) - . S:IBIDTYP="SY" IBID=$P($G(^IBA(355.9,IB3559,0)),"^",7),IBQFL=1 - Q $$NOPUNCT^IBCEF(IBID) - ; - ;IBIDTYP-provider ID type, ptr to #355.97 - ;IBFULL-full name - ;IBEL - Name element : "FAMILY","GIVEN","MIDDLE","SUFFIX" - ; -PRV1FMT(P) ;FORMAT CODE FOR PRV1 SEGMENT THAT WON'T FIT ON LINE - K IBXDATA - S:'$D(IBXSAVE("BIL-PROV-SEC")) IBXSAVE("BIL-PROV-SEC")=$$PRV1^IBCEF7(IBXIEN) - S IBXDATA=$P($G(IBXSAVE("BIL-PROV-SEC")),"^",P) - I $G(IBXDATA)'="" S IBXDATA=$$NOPUNCT^IBCEF(IBXDATA,1) - Q - ; +IBCEF73 ;WOIFO/SS - FORMATTER AND EXTRACTOR SPECIFIC BILL FUNCTIONS ;8/6/03 10:56am + ;;2.0;INTEGRATED BILLING;**232,320,358,349**;21-MAR-94;Build 46 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; + ;check qualifier + ;IBFRM 0-both, 1=UB,2=1500 + ;IBPROV - function in #399 (1-referring, 2-operating,etc) + ;IBTYPE - "C"-current insurance, "O"-other insurance + ;IBVAL - value to check +CHCKSEC(IBFRM,IBPROV,IBTYPE,IBVAL) ; + I IBFRM=0 Q:$$CHSEC(1,IBPROV,IBTYPE,IBVAL) 1 Q $$CHSEC(2,IBPROV,IBTYPE,IBVAL) + Q $$CHSEC(IBFRM,IBPROV,IBTYPE,IBVAL) + ; +CHSEC(IBFRM,IBPROV,IBTYPE,IBVAL) ; + N IBSTR S IBSTR="" + ;referring + I IBPROV=1 S IBSTR=$S(IBTYPE="C":$$OPR5(IBFRM),IBTYPE="O":$$OP4(IBFRM),1:"") + ;operating + I IBPROV=2 S IBSTR=$S(IBTYPE="C":$$OPR3(IBFRM),IBTYPE="O":$$OP2(IBFRM),1:"") + ;rendering + I IBPROV=3 S IBSTR=$S(IBTYPE="C":$$OPR2(IBFRM),IBTYPE="O":$$OP1(IBFRM),1:"") + ;attending + I IBPROV=4 S IBSTR=$S(IBTYPE="C":$$OPR2(IBFRM),IBTYPE="O":$$OP1(IBFRM),1:"") + ;supervising + I IBPROV=5 S IBSTR=$S(IBTYPE="C":$$OPR8(IBFRM),IBTYPE="O":$$OP8(IBFRM),1:"") + ;other + I IBPROV=9 S IBSTR=$S(IBTYPE="C":$$OPR4(IBFRM),IBTYPE="O":$$OP9(IBFRM),1:"") + Q:IBPROV=0!(IBSTR="") 1 ;if "" or facility id always return 1 + Q IBSTR[("^"_IBVAL_"^") + ; + ;Filter invalid qualifier entries for records SUB1,SUB2,OP6,OP7,OP3 + ; Rebuild the IBXSAVE("PROVINF" or IBXSAVE("PROVINF_FAC" array with + ; only ids that have valid qualifiers + ;IBFRM 0-both, 1=UB,2=1500 + ;IBREC record ID whose ids are being filtered (SUB1,SUB2,etc) + ;IBFAC - 1 if facility check, 0 if attending/rendering check + ;IBTYPE - "C"-current insurance, "O"-other insurance + ;IBXSAVE - the array of provider ids extracted, returned filtered - + ; passed by reference +CHCKSUB(IBFRM,IBREC,IBFAC,IBTYPE,IBXSAVE) ; + N Z,Z0,Z1,Z2,CT,IBSAVE + S Z="PROVINF"_$P("^_FAC",U,$G(IBFAC)+1) + I '$G(IBXSAVE(Z,IBXIEN)) D + . D F^IBCEF("N-ALL "_$S($G(IBFAC):"OUTSIDE FAC PROVIDER INF",1:"CUR/OTH PROVIDER INFO")) + M IBSAVE(Z,IBXIEN,IBTYPE)=IBXSAVE(Z,IBXIEN,IBTYPE) K IBXSAVE(Z,IBXIEN,IBTYPE) + S Z0=0 F S Z0=$O(IBSAVE(Z,IBXIEN,IBTYPE,Z0)) Q:'Z0 S Z1="" F S Z1=$O(IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1)) Q:Z1="" S (Z2,CT)=0 F S Z2=$O(IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,Z2)) Q:'Z2 D + . N IBVAL + . S IBVAL=$P(IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,Z2),U,3) + . I IBFRM=0 D Q + .. I $S($$CHSUB(1,IBREC,IBVAL):1,1:$$CHSUB(2,IBPROV,IBTYPE,IBVAL)) D + ... S CT=CT+1,IBXSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,CT)=IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,Z2) + ... I $G(IBXSAVE(Z,IBXIEN,IBTYPE,Z0))="",$G(IBSAVE(Z,IBXIEN,IBTYPE,Z0))'="" S IBXSAVE(Z,IBXIEN,IBTYPE,Z0)=IBSAVE(Z,IBXIEN,IBTYPE,Z0) + . I $$CHSUB(IBFRM,IBREC,IBVAL) D + .. S CT=CT+1,IBXSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,CT)=IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,Z2) + .. I $G(IBXSAVE(Z,IBXIEN,IBTYPE,Z0))="",$G(IBSAVE(Z,IBXIEN,IBTYPE,Z0))'="" S IBXSAVE(Z,IBXIEN,IBTYPE,Z0)=IBSAVE(Z,IBXIEN,IBTYPE,Z0) + Q + ; + ; Check if valid qualifier + ;IBFRM 0-both, 1=UB,2=1500 + ;IBREC record ID whose ids are being filtered (SUB1,SUB2,etc) + ;IBVAL - value to check +CHSUB(IBFRM,IBREC,IBVAL) ; + N IBSTR + I IBREC="SUB1" S IBSTR=$$SUB1(IBFRM) + I IBREC="SUB2" S IBSTR=$$SUB2(IBFRM) + I IBREC="OP7" S IBSTR=$$OP7(IBFRM) + I IBREC="OP3" S IBSTR=$$OP3(IBFRM) + I IBREC="OP6" S IBSTR=$$OP6(IBFRM) + Q:$G(IBSTR)="" 1 ;if "" always return 1 + Q IBSTR[("^"_IBVAL_"^") + ; + ;IBFRM 0-both, 1=UB,2=1500 +OPR2(IBFRM) ; + Q:IBFRM=1 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^" + Q:IBFRM=2 "^0B^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^" + Q "" + ; + ;IBFRM 0-both, 1=UB,2=1500 +OP1(IBFRM) ; + Q:IBFRM=1 "^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^" + Q:IBFRM=2 "^1B^1C^1D^EI^G2^LU^N5^" + Q "" + ; + ;IBFRM 0-both, 1=UB,2=1500 +OPR3(IBFRM) ; + Q:IBFRM=1 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^" + Q "" + ; + ;IBFRM 0-both, 1=UB,2=1500 +OP2(IBFRM) ; + Q:IBFRM=1 "^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^" + Q "" + ; + ;IBFRM 0-both, 1=UB,2=1500 +SUB1(IBFRM) ; + Q:IBFRM=1 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^" + Q:IBFRM=2 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^U3^SY^X5^" + Q "" + ; + ;IBFRM 0-both, 1=UB,2=1500 +OPR4(IBFRM) ; + Q:IBFRM=1 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^" + Q "" + ; + ;IBFRM 0-both, 1=UB,2=1500 +OP9(IBFRM) ; + Q:IBFRM=1 "^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^" + Q "" + ; + ;IBFRM 0-both, 1=UB,2=1500 +SUB2(IBFRM) ; + Q:IBFRM=1 "^0B^1A^1B^1C^1G^1H^1J^EI^FH^G2^G5^LU^N5^X5^TJ^B3^BQ^SY^U3^" + Q:IBFRM=2 "^0B^X4^1A^1B^1C^1G^1H^G2^LU^X5^TJ^B3^BQ^SY^U3^" + Q "" + ; + ;IBFRM 0-both, 1=UB,2=1500 +OP3(IBFRM) ; + Q:IBFRM=1 "^1B^1C^EI^G2^LU^N5^" + Q "" + ; + ;IBFRM 0-both, 1=UB,2=1500 +OPR5(IBFRM) ; + Q:IBFRM=2 "^0B^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^" + Q "" + ; + ;IBFRM 0-both, 1=UB,2=1500 +OPR8(IBFRM) ; + Q:IBFRM=2 "^0B^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^" + Q "" + ; + ;IBFRM 0-both, 1=UB,2=1500 +OP4(IBFRM) ; + Q:IBFRM=2 "^1B^1C^1D^EI^G2^LU^N5^" + Q "" + ; + ;IBFRM 0-both, 1=UB,2=1500 +OP8(IBFRM) ; + Q:IBFRM=2 "^1B^1C^1D^EI^G2^N5^" + Q "" + ; + ;IBFRM 0-both, 1=UB,2=1500 +OP6(IBFRM) ; + Q:IBFRM=2 "^1A^1B^1C^G2^LU^N5^" + Q "" + ; + ;IBFRM 0-both, 1=UB,2=1500 +OP7(IBFRM) ; + Q:IBFRM=2 "^1A^1B^1C^G2^LU^N5^" + Q "" + ; + ;check qualifier for PRV1 + ;IBFRM 0-both, 1=UB,2=1500 + ;IBVAL - value to check +CHCKPRV1(IBFRM,IBVAL) ; + I IBFRM=0 Q:$$CHPRV1(1,IBVAL) 1 Q $$CHPRV1(2,IBVAL) + Q $$CHPRV1(IBFRM,IBVAL) + ;IBFRM 0-both, 1=UB,2=1500 +CHPRV1(IBFRM,IBVAL) ; + N IBSTR S IBSTR="" + S IBSTR=$$PRV1(IBFRM) + Q:IBSTR="" 1 + Q IBSTR[("^"_IBVAL_"^") + ; +PRV1(IBFRM) ; + Q:IBFRM=1 "^1A^1C^1D^1G^1H^1J^B3^BQ^EI^FH^G2^G5^LU^SY^X5^" + Q:IBFRM=2 "^1B^1C^1D^1G^1H^1J^B3^BQ^EI^FH^G2^G5^LU^U3^SY^X5^" + Q "" + ; +PTSELF ;This tag is for the CI2 segment. If the IBXSAVE("IADR") is empty + ;check to see if the relationship to pt is 18 (self) if so pull info + ;from PT1 calls + ;See if relationship to insured is 18 if not or if "" quit + N IBZ + D F^IBCEF("N-ALL INSURED PT RELATION","IBZ",,IBXIEN) + S IBZ=$G(IBZ(+$$COBN^IBCEF(IBXIEN))) + S IBZ=$$RELATION^IBCEFG1(IBZ) + I IBZ'="18" S IBXDATA="" Q + N IBZ D F^IBCEF("N-PATIENT STREET ADDRESS 1-3","IBZ",,IBXIEN) + S IBXDATA="18" + Q + ; +NOPUNCT(X,SPACE,EXC) ; Strip punctuation from data in X + ; SPACE = flag if 1 strip SPACES + ; EXC = list of punct not to strip + ; + N PUNCT,Z + S PUNCT=".,-+(){}[]\/><:;?|=_*&%$#@!~`^'""" + I $G(SPACE) S PUNCT=PUNCT_" " + I $G(EXC)'="" S PUNCT=$TR(PUNCT,EXC) + N L S L="" + F S L=$O(X(L)) Q:L="" D + . S X(L)=$TR(X(L),PUNCT) + I $G(X)'="" D + . S X=$TR(X,PUNCT) + Q + ; +PROVID(IBXIEN) ;This modified version of prov id call is to acquire the SSN + ;first, if the ssn is not available then we need to get the tax id. + ;we also need to provide the modifier for which value it is + Q:+$G(IBXIEN)=0 "" + S IBXSAVE("ID")="" + S IBXSAVE="" + S IBXSAVE=$$PROVSSN^IBCEF7(IBXIEN) + N I + F I=1:1:9 D + . I $P(IBXSAVE,"^",I)]"" S $P(IBXSAVE("ID"),U,I)="34" + ;If no ibxdata go look in 355.97 for 24 + N IBRETVAL S IBRETVAL="" + N IBPTR,IBFT + F IBFT=1:1:9 D + . Q:$P(IBXSAVE,U,IBFT)]"" + . S IBPTR=$$PROVPTR^IBCEF7(IBXIEN,IBFT) + . S $P(IBRETVAL,"^",IBFT)=$$TAX3559(IBPTR) + . I $P(IBRETVAL,U,IBFT)]"" D + . . S $P(IBXSAVE,U,IBFT)=$P(IBRETVAL,U,IBFT) + . . S $P(IBXSAVE("ID"),U,IBFT)="24" + Q IBXSAVE + ; +TAX3559(IBPROV) ; + I $P(IBPROV,";",2)'["IBA(355.9" Q "" + N IB2,IB3559,IBIDTYP,IBID,IBQFL + S (IB3559,IBQFL)=0 + S IBID="" + Q:+$G(IBPROV)=0 "" + F IB2=1:1 S IB3559=$O(^IBA(355.9,"B",IBPROV,IB3559)) Q:IB3559=""!IBQFL D + . S IBIDTYP=+$P($G(^IBA(355.9,IB3559,0)),"^",6) ;provider ID type, ptr to #355.97 + . S IBIDTYP=$P($G(^IBE(355.97,IBIDTYP,0)),"^",3) + . S:IBIDTYP="EI" IBID=$P($G(^IBA(355.9,IB3559,0)),"^",7),IBQFL=1 + Q $$NOPUNCT^IBCEF(IBID) + ; + ;IBFULL-full name + ;IBEL - Name element : "FAMILY","GIVEN","MIDDLE","SUFFIX" + ; +SSN200(IBPTR) ; + I $P(IBPTR,";",2)'="VA(200," Q "" + Q $$NOPUNCT^IBCEF($$GET1^DIQ(200,+$P(IBPTR,";")_",",9)) + ; + ;Input: + ; IBIEN399 - ien in #399 + ;Output: + ; returns a string with "^" delimiters that contains SSNs (if any) + ; in the position that equal to FUNCTION number + ; i.e. if RENDERING function # is 3 then SSN will be + ; in $P(return value,"^",3), etc. + ; +SSN3559(IBPROV) ; + N IB2,IB3559,IBIDTYP,IBID,IBQFL + S (IB3559,IBQFL)=0 + S IBID="" + Q:+$G(IBPROV)=0 "" + F IB2=1:1 S IB3559=$O(^IBA(355.9,"B",IBPROV,IB3559)) Q:IB3559=""!IBQFL D + . S IBIDTYP=+$P($G(^IBA(355.9,IB3559,0)),"^",6) + . S IBIDTYP=$P($G(^IBE(355.97,IBIDTYP,0)),"^",3) + . S:IBIDTYP="SY" IBID=$P($G(^IBA(355.9,IB3559,0)),"^",7),IBQFL=1 + Q $$NOPUNCT^IBCEF(IBID) + ; + ;IBIDTYP-provider ID type, ptr to #355.97 + ;IBFULL-full name + ;IBEL - Name element : "FAMILY","GIVEN","MIDDLE","SUFFIX" + ; +PRV1FMT(P) ;FORMAT CODE FOR PRV1 SEGMENT THAT WON'T FIT ON LINE + K IBXDATA + S:'$D(IBXSAVE("BIL-PROV-SEC")) IBXSAVE("BIL-PROV-SEC")=$$PRV1^IBCEF7(IBXIEN) + S IBXDATA=$P($G(IBXSAVE("BIL-PROV-SEC")),"^",P) + I $G(IBXDATA)'="" S IBXDATA=$$NOPUNCT^IBCEF(IBXDATA,1) + Q + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF73A.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF73A.m index f3b146c0..e72f8c20 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF73A.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF73A.m @@ -1,157 +1,129 @@ -IBCEF73A ;ALB/KJH - FORMATTER AND EXTRACTOR SPECIFIC (NPI) BILL FUNCTIONS ;30 Aug 2006 10:38 AM - ;;2.0;INTEGRATED BILLING;**343,374,395,391**;21-MAR-94;Build 39 - ;; Per VHA Directive 10-93-142, this routine should not be modified. - ; -PROVNPI(IBIEN399,IBNONPI) ; - ;Retrieves NPIs from #200 or 355.93 - ; Input: - ; IBIEN399 - IEN of record in BILL/CLAIMS file 399 - ; IBNONPI - variable to pass info on missing NPI to calling routine. Pass by reference - ; Output: - ; NPI codes for all providers - ; IBNONPI - U-delimited list of provider types with missing NPIs - N IBRETVAL,IBPTR,IBFT - S IBRETVAL="",IBNONPI="" - F IBFT=1:1:9 D - . S IBPTR=$$PROVPTR^IBCEF7(IBIEN399,IBFT) - . I IBPTR S $P(IBRETVAL,"^",IBFT)=$$GETNPI(IBPTR) - Q IBRETVAL -GETNPI(IBPTR) ;look for NPI in #200 or #355.93 - ;Input: IBPTR from 399.0222, field .02 - ;Output: NPI - ;if in file #200 - N NPI - S NPI="" - ;if in 200 then get it from 200 - I $P(IBPTR,";",2)="VA(200," S NPI=$P($$NPI^XUSNPI("Individual_ID",$P(IBPTR,";")),U) S:NPI<1 NPI="" - ;if in 355.93 then use 355.93 - I $P(IBPTR,";",2)="IBA(355.93," S NPI=$$NPIGET^IBCEP81($P(IBPTR,";")) - I NPI="",$D(IBNONPI) S IBNONPI=$S(IBNONPI="":IBFT,1:IBNONPI_U_IBFT) - Q NPI - ; -SPECTAX(IBIEN399,IBNOSPEC) ; - ;Retrieves Specialty Codes from Current Taxonomy entries for a claim from #399 - ; Input: - ; IBIEN399 - IEN of record in BILL/CLAIMS file 399 - ; IBNOSPEC - variable to pass info on missing taxonomies to calling routine. Pass by reference - ; Output: - ; Taxonomy Specialty Codes for all providers - ; IBNOSPEC - U-delimited list of provider types with missing Taxonomy Specialty codes - N IBRETVAL,IBN,IBFT,IBSPEC,SPEC - S IBRETVAL="",IBNOSPEC="" - I $G(IBIEN399)="" Q "" - F IBFT=1:1:9 D - . S IBN=$O(^DGCR(399,IBIEN399,"PRV","B",IBFT,0)) - . I +IBN=0 Q - . S IBSPEC=$P($G(^DGCR(399,IBIEN399,"PRV",+IBN,0)),"^",15) - . S SPEC=$$GET1^DIQ(8932.1,IBSPEC,"SPECIALTY CODE") - . S $P(IBRETVAL,"^",IBFT)=SPEC - . I SPEC="",$D(IBNOSPEC) S IBNOSPEC=$S(IBNOSPEC="":IBFT,1:IBNOSPEC_U_IBFT) - Q IBRETVAL - ; -PROVTAX(IBIEN399,IBNOTAX) ; - ;Retrieves Current Taxonomy entries for a claim from #399 - ; Input: - ; IBIEN399 - IEN of record in BILL/CLAIMS file 399 - ; IBNOTAX - variable to pass info on missing taxonomies to calling routine. Pass by reference - ; Output: - ; Taxonomy X12 codes for all providers - ; IBNOTAX - U-delimited list of provider types with missing Taxonomy X12 codes - N IBRETVAL,IBN,IBFT,IBTAX,TAX - S IBRETVAL="",IBNOTAX="" - I $G(IBIEN399)="" Q "" - F IBFT=1:1:9 D - . S IBN=$O(^DGCR(399,IBIEN399,"PRV","B",IBFT,0)) - . I +IBN=0 Q - . S IBTAX=$P($G(^DGCR(399,IBIEN399,"PRV",+IBN,0)),"^",15) - . S TAX=$$GET1^DIQ(8932.1,IBTAX,"X12 CODE") - . S $P(IBRETVAL,"^",IBFT)=TAX - . I TAX="",$D(IBNOTAX) S IBNOTAX=$S(IBNOTAX="":IBFT,1:IBNOTAX_U_IBFT) - Q IBRETVAL -GETTAX(IBPTR) ;look for Taxonomy in #200 or #355.93 - ;Input: IBPTR from 399.0222, field .02 - ;Output: Taxonomy X12 code_"^"_IEN - N TAX - S TAX="^" - ;if in 200 then get it from 200 - I $P(IBPTR,";",2)="VA(200," S TAX=$$TAXIND^XUSTAX($P(IBPTR,";")) - ;if in 355.93 then use 355.93 - I $P(IBPTR,";",2)="IBA(355.93," S TAX=$$TAXGET^IBCEP81($P(IBPTR,";")) - Q TAX - ; -ORGNPI(IBIEN399,IBNONPI) ; Extract NPIs for organizations on this claim - ; Input - ; IBIEN399 - Claim IEN in file 399 - ; IBNONPI - Variable to pass info on missing NPI back to calling routine. Pass by reference. - ; Output - NPI codes for facilities - ; Piece 1) Division (Responsible Institution) NPI code - ; Piece 2) Non-VA Service Facility NPI code - ; Piece 3) Billing Provider NPI code (main VA division) - N IBRETVAL,IBORG,IBEVDT,IBDIV,NPI - S IBNONPI="" - I $G(IBIEN399)="" Q "" - S IBRETVAL="" - S IBEVDT=$$GET1^DIQ(399,IBIEN399_",",.03,"I") - I IBEVDT="" S IBEVDT=DT - S IBDIV=$$GET1^DIQ(399,IBIEN399_",",.22,"I") - I IBDIV="" S IBDIV=$$PRIM^VASITE(IBEVDT) - S IBORG=$P($$SITE^VASITE(IBEVDT,IBDIV),U),NPI="" - I IBORG S NPI=$P($$NPI^XUSNPI("Organization_ID",IBORG),U) S:NPI>0 $P(IBRETVAL,U)=NPI - I NPI<1,$D(IBNONPI) S IBNONPI=1 - S IBORG=$$GET1^DIQ(399,IBIEN399_",",232,"I") - I IBORG S NPI=$$NPIGET^IBCEP81(IBORG),$P(IBRETVAL,U,2)=NPI I 'NPI,$D(IBNONPI) S IBNONPI=$S(IBNONPI="":2,1:IBNONPI_U_2) - S IBORG=$P($$SITE^VASITE,U),NPI="" - I IBORG S NPI=$P($$NPI^XUSNPI("Organization_ID",IBORG),U) S:NPI>0 $P(IBRETVAL,U,3)=NPI - I NPI<1,$D(IBNONPI) S IBNONPI=$S(IBNONPI="":3,1:IBNONPI_U_3) - I $$ISRX^IBCEF1(IBIEN399) S IBORG=$$RXSITE(IBIEN399) I IBORG S NPI=$P($$NPI^XUSNPI("Organization_ID",IBORG),U) S:NPI>0 $P(IBRETVAL,U,3)=NPI - Q IBRETVAL - ; -ORGTAX(IBIEN399,IBNOTAX) ; Extract Taxonomies for organizations on this claim - ; Input - ; IBIEN399 - Claim IEN in file 399 - ; IBNOTAX - Variable to pass info on missing taxonomies back to calling routine. Pass by reference. - ; Output - Taxonomy X12 codes for facilities - ; Piece 1) Division (Responsible Institution) Taxonomy X12 code - ; Piece 2) Non-VA Service Facility Taxonomy X12 code - ; Piece 3) Billing Provider Taxonomy X12 code (main VA division) - N IBRETVAL,IBTAX,TAX - S IBTAX=$$GET1^DIQ(399,IBIEN399_",",243,"I") - S TAX=$$GET1^DIQ(8932.1,IBTAX,"X12 CODE") - S $P(IBRETVAL,U)=TAX - I '$L(TAX),$D(IBNOTAX) S IBNOTAX=1 - S IBTAX=$$GET1^DIQ(399,IBIEN399_",",244,"I") - S TAX=$$GET1^DIQ(8932.1,IBTAX,"X12 CODE") - S $P(IBRETVAL,U,2)=TAX - I '$L(TAX),$$GET1^DIQ(399,IBIEN399_",",232,"I"),$D(IBNOTAX) S IBNOTAX=$S(IBNOTAX="":2,1:IBNOTAX_U_2) - S IBORG=$P($$SITE^VASITE,U) - S TAX=$P($$TAXORG^XUSTAX(IBORG),U) - S $P(IBRETVAL,U,3)=TAX - I '$L(TAX),$D(IBNOTAX) S IBNOTAX=$S(IBNOTAX="":3,1:IBNOTAX_U_3) - Q IBRETVAL - ; -RXSITE(IBIEN399,IBLIST) ; returns prescription organization (file 4) pointer - ; for the given bill. If IBLIST passed by reference, then a list of - ; the possible organizations are returned for a bill, since a bill may - ; have more than one prescription. If more than one rx on the bill, the - ; $$ return is the pointer of the last prescription found. - ; IBLIST(rx ien,fill date)=ORGINATION (file 4 pointer) - ; - N IBX,IBDATA,IBORG,IBRX,IBDT,IBY,IBRXN,DFN - K ^TMP($J,"IBCEF73A") - S IBORG=0,DFN=$P($G(^DGCR(399,IBIEN399,0)),"^",2),IBLIST="IBCEF73A" - S IBRXN=0 F S IBRXN=$O(^IBA(362.4,"AIFN"_IBIEN399,IBRXN)) Q:'IBRXN S IBX=0 F S IBX=$O(^IBA(362.4,"AIFN"_IBIEN399,IBRXN,IBX)) Q:'IBX D - . S IBDATA=$G(^IBA(362.4,IBX,0)) - . S IBRX=$P(IBDATA,"^",5),IBDT=$P(IBDATA,"^",3) Q:'IBRX!('IBDT) - . D RX^PSO52API(DFN,IBLIST,IBRX,,"0,2,R") - . I IBDT=+$G(^TMP($J,"IBCEF73A",DFN,IBRX,22)) S (IBORG,IBLIST(IBRX,IBDT))=$$PSONPI(+$G(^TMP($J,"IBCEF73A",DFN,IBRX,20))) Q - . S IBY=0 F S IBY=$O(^TMP($J,"IBCEF73A",DFN,IBRX,"RF",IBY)) Q:'IBY I IBDT=+$G(^TMP($J,"IBCEF73A",DFN,IBRX,"RF",IBY,.01)) S (IBORG,IBLIST(IBRX,IBDT))=$$PSONPI(+$G(^TMP($J,"IBCEF73A",DFN,IBRX,"RF",IBY,8))) Q - K ^TMP($J,"IBCEF73A") - Q IBORG - ; -PSONPI(IB59IEN) ; returns institution ien for a file 59 ien - N IB4IEN - K ^TMP($J,"IBCEF59") - D PSS^PSO59(IB59IEN,,"IBCEF59") - S IB4IEN=+$G(^TMP($J,"IBCEF59",IB59IEN,101)) - K ^TMP($J,"IBCEF59") - Q IB4IEN +IBCEF73A ;ALB/KJH - FORMATTER AND EXTRACTOR SPECIFIC (NPI) BILL FUNCTIONS ; 30 Aug 2006 10:38 AM + ;;2.0;INTEGRATED BILLING;**343,374**;21-MAR-94;Build 16 + ;; Per VHA Directive 10-93-142, this routine should not be modified. + ; +PROVNPI(IBIEN399,IBNONPI) ; + ;Retrieves NPIs from #200 or 355.93 + ; Input: + ; IBIEN399 - IEN of record in BILL/CLAIMS file 399 + ; IBNONPI - variable to pass info on missing NPI to calling routine. Pass by reference + ; Output: + ; NPI codes for all providers + ; IBNONPI - U-delimited list of provider types with missing NPIs + N IBRETVAL,IBPTR,IBFT + S IBRETVAL="",IBNONPI="" + F IBFT=1:1:9 D + . S IBPTR=$$PROVPTR^IBCEF7(IBIEN399,IBFT) + . I IBPTR S $P(IBRETVAL,"^",IBFT)=$$GETNPI(IBPTR) + Q IBRETVAL +GETNPI(IBPTR) ;look for NPI in #200 or #355.93 + ;Input: IBPTR from 399.0222, field .02 + ;Output: NPI + ;if in file #200 + N NPI + S NPI="" + ;if in 200 then get it from 200 + I $P(IBPTR,";",2)="VA(200," S NPI=$P($$NPI^XUSNPI("Individual_ID",$P(IBPTR,";")),U) S:NPI=-1 NPI="" + ;if in 355.93 then use 355.93 + I $P(IBPTR,";",2)="IBA(355.93," S NPI=$$NPIGET^IBCEP81($P(IBPTR,";")) + I NPI="",$D(IBNONPI) S IBNONPI=$S(IBNONPI="":IBFT,1:IBNONPI_U_IBFT) + Q NPI + ; +SPECTAX(IBIEN399,IBNOSPEC) ; + ;Retrieves Specialty Codes from Current Taxonomy entries for a claim from #399 + ; Input: + ; IBIEN399 - IEN of record in BILL/CLAIMS file 399 + ; IBNOSPEC - variable to pass info on missing taxonomies to calling routine. Pass by reference + ; Output: + ; Taxonomy Specialty Codes for all providers + ; IBNOSPEC - U-delimited list of provider types with missing Taxonomy Specialty codes + N IBRETVAL,IBN,IBFT,IBSPEC,SPEC + S IBRETVAL="",IBNOSPEC="" + I $G(IBIEN399)="" Q "" + F IBFT=1:1:9 D + . S IBN=$O(^DGCR(399,IBIEN399,"PRV","B",IBFT,0)) + . I +IBN=0 Q + . S IBSPEC=$P($G(^DGCR(399,IBIEN399,"PRV",+IBN,0)),"^",15) + . S SPEC=$$GET1^DIQ(8932.1,IBSPEC,"SPECIALTY CODE") + . S $P(IBRETVAL,"^",IBFT)=SPEC + . I SPEC="",$D(IBNOSPEC) S IBNOSPEC=$S(IBNOSPEC="":IBFT,1:IBNOSPEC_U_IBFT) + Q IBRETVAL + ; +PROVTAX(IBIEN399,IBNOTAX) ; + ;Retrieves Current Taxonomy entries for a claim from #399 + ; Input: + ; IBIEN399 - IEN of record in BILL/CLAIMS file 399 + ; IBNOTAX - variable to pass info on missing taxonomies to calling routine. Pass by reference + ; Output: + ; Taxonomy X12 codes for all providers + ; IBNOTAX - U-delimited list of provider types with missing Taxonomy X12 codes + N IBRETVAL,IBN,IBFT,IBTAX,TAX + S IBRETVAL="",IBNOTAX="" + I $G(IBIEN399)="" Q "" + F IBFT=1:1:9 D + . S IBN=$O(^DGCR(399,IBIEN399,"PRV","B",IBFT,0)) + . I +IBN=0 Q + . S IBTAX=$P($G(^DGCR(399,IBIEN399,"PRV",+IBN,0)),"^",15) + . S TAX=$$GET1^DIQ(8932.1,IBTAX,"X12 CODE") + . S $P(IBRETVAL,"^",IBFT)=TAX + . I TAX="",$D(IBNOTAX) S IBNOTAX=$S(IBNOTAX="":IBFT,1:IBNOTAX_U_IBFT) + Q IBRETVAL +GETTAX(IBPTR) ;look for Taxonomy in #200 or #355.93 + ;Input: IBPTR from 399.0222, field .02 + ;Output: Taxonomy X12 code_"^"_IEN + N TAX + S TAX="^" + ;if in 200 then get it from 200 + I $P(IBPTR,";",2)="VA(200," S TAX=$$TAXIND^XUSTAX($P(IBPTR,";")) + ;if in 355.93 then use 355.93 + I $P(IBPTR,";",2)="IBA(355.93," S TAX=$$TAXGET^IBCEP81($P(IBPTR,";")) + Q TAX + ; +ORGNPI(IBIEN399,IBNONPI) ; Extract NPIs for organizations on this claim + ; Input + ; IBIEN399 - Claim IEN in file 399 + ; IBNONPI - Variable to pass info on missing NPI back to calling routine. Pass by reference. + ; Output - NPI codes for facilities + ; Piece 1) Division (Responsible Institution) NPI code + ; Piece 2) Non-VA Service Facility NPI code + ; Piece 3) Billing Provider NPI code (main VA division) + N IBRETVAL,IBORG,IBEVDT,IBDIV,NPI + S IBNONPI="" + I $G(IBIEN399)="" Q "" + S IBRETVAL="" + S IBEVDT=$$GET1^DIQ(399,IBIEN399_",",.03,"I") + I IBEVDT="" S IBEVDT=DT + S IBDIV=$$GET1^DIQ(399,IBIEN399_",",.22,"I") + I IBDIV="" S IBDIV=$$PRIM^VASITE(IBEVDT) + S IBORG=$P($$SITE^VASITE(IBEVDT,IBDIV),U),NPI="" + I IBORG S NPI=$P($$NPI^XUSNPI("Organization_ID",IBORG),U) S:NPI'=-1 $P(IBRETVAL,U)=NPI + I NPI<1,$D(IBNONPI) S IBNONPI=1 + S IBORG=$$GET1^DIQ(399,IBIEN399_",",232,"I") + I IBORG S NPI=$$NPIGET^IBCEP81(IBORG),$P(IBRETVAL,U,2)=NPI I 'NPI,$D(IBNONPI) S IBNONPI=$S(IBNONPI="":2,1:IBNONPI_U_2) + S IBORG=$P($$SITE^VASITE,U),NPI="" + I IBORG S NPI=$P($$NPI^XUSNPI("Organization_ID",IBORG),U) S:NPI'=-1 $P(IBRETVAL,U,3)=NPI + I NPI<1,$D(IBNONPI) S IBNONPI=$S(IBNONPI="":3,1:IBNONPI_U_3) + Q IBRETVAL + ; +ORGTAX(IBIEN399,IBNOTAX) ; Extract Taxonomies for organizations on this claim + ; Input + ; IBIEN399 - Claim IEN in file 399 + ; IBNOTAX - Variable to pass info on missing taxonomies back to calling routine. Pass by reference. + ; Output - Taxonomy X12 codes for facilities + ; Piece 1) Division (Responsible Institution) Taxonomy X12 code + ; Piece 2) Non-VA Service Facility Taxonomy X12 code + ; Piece 3) Billing Provider Taxonomy X12 code (main VA division) + N IBRETVAL,IBTAX,TAX + S IBTAX=$$GET1^DIQ(399,IBIEN399_",",243,"I") + S TAX=$$GET1^DIQ(8932.1,IBTAX,"X12 CODE") + S $P(IBRETVAL,U)=TAX + I '$L(TAX),$D(IBNOTAX) S IBNOTAX=1 + S IBTAX=$$GET1^DIQ(399,IBIEN399_",",244,"I") + S TAX=$$GET1^DIQ(8932.1,IBTAX,"X12 CODE") + S $P(IBRETVAL,U,2)=TAX + I '$L(TAX),$$GET1^DIQ(399,IBIEN399_",",232,"I"),$D(IBNOTAX) S IBNOTAX=$S(IBNOTAX="":2,1:IBNOTAX_U_2) + S IBORG=$P($$SITE^VASITE,U) + S TAX=$P($$TAXORG^XUSTAX(IBORG),U) + S $P(IBRETVAL,U,3)=TAX + I '$L(TAX),$D(IBNOTAX) S IBNOTAX=$S(IBNOTAX="":3,1:IBNOTAX_U_3) + Q IBRETVAL diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF74A.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF74A.m index 55affdd9..7b6b2ac3 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF74A.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF74A.m @@ -1,122 +1,121 @@ -IBCEF74A ;ALB/ESG - Provider ID maint ?ID continuation ;7 Mar 2006 - ;;2.0;INTEGRATED BILLING;**320,343,349,395**;21-MAR-94;Build 3 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - Q - ; -EN(IBIFN,IBQUIT) ; Display billing provider and service provider IDs as part - ; of the ?ID display/help in the billing screens. - ; Called from DISPID^IBCEF74. - NEW IBID,IBX,Z,ZI,ZN,SEQ,PSIN,DATA,QUALNM,IDNUM,FACNAME,IBZ,IBXIEN,IBSSFI,ORGNPI - ; - D ALLIDS^IBCEF75(IBIFN,.IBID) - ; - ; Re-sort array by insurance sequence (P/S/T) - K IBX - F Z="BILLING PRV","LAB/FAC" F ZI="C","O" S ZN=0 F S ZN=$O(IBID(Z,IBIFN,ZI,ZN)) Q:'ZN D - . S SEQ=$P($G(IBID(Z,IBIFN,ZI,ZN)),U,1) Q:SEQ="" - . S IBX(Z,SEQ,ZI,ZN)="" - . Q - ; - ; Display billing provider secondary ID's (current ins only) - I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX - S Z="BILLING PRV" - ; PRXM/KJH - Removed "I $D(IBX(Z))" from next line. Caused header to not display even though there would be a "None Found' message. - W !!,"Billing Provider Secondary IDs (VistA Record CI1A):" - D SECID(Z,.IBQUIT) - I IBQUIT G EX - ; - ; Now display the lab or facility primary and secondary IDs - ; This is the service facility information - ; - ; Facility name, same code as found in SUB-2 - I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX - W !!,"Service Facility Name and ID Information" - S IBXIEN=IBIFN - D F^IBCEF("N-RENDERING INSTITUTION","IBZ",,IBIFN) - I $$ISRX^IBCEF1(IBIFN) S Z=$$RXSITE^IBCEF73A(IBIFN) I Z S $P(IBZ,"^")=+Z - S FACNAME=$$GETFAC^IBCEP8(+IBZ,+$P(IBZ,U,2),0,"SUB") - S Z="LAB/FAC" - ; - ; determine if flag to suppress lab/fac data is set - D VAMCFD^IBCEF75(IBIFN,.IBSSFI) - I $D(IBSSFI),'$G(IBSSFI("C",1)) D I IBQUIT G EX - . I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() Q:IBQUIT - . W !!,"Note: Service Facility Data not sent for Current Insurance" - . W !," 'Send VA Lab/Facility IDs or Facility Data for VAMC?' is set to NO",! - . Q - ; - ; facility name - I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX - I FACNAME="" S FACNAME="n/a" - W !,"Facility: ",FACNAME - ; - ; PRXM/KJH - Add NPI to display for patch 343. - S ORGNPI=$$ORGNPI^IBCEF73A(IBIFN) - S DATA=$S($$ISRX^IBCEF1(IBIFN):$P(ORGNPI,U,3),$P($G(IBZ),U,2)=1:$P(ORGNPI,U,2),$P($G(IBZ),U,2)=0:$P(ORGNPI,U,1),1:$P(ORGNPI,U,3)) - I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX - W !?5,"Lab or Facility NPI:" - W !?12,$S(DATA'="":DATA,1:"***MISSING***") - ; primary ID - S DATA=$G(IBID(Z,IBIFN,"C",1,0)) ; lab/facility current ins primary - S QUALNM=$$QUAL($P(DATA,U,1),$$FT^IBCEF(IBIFN)) - S IDNUM=$P(DATA,U,2) - I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX - W !?5,"Lab or Facility Primary ID (VistA Record SUB):" - I DATA'="" W !?8,"(",$P($G(IBID(Z,IBIFN,"C",1)),U,1),") ",QUALNM,?40,IDNUM - I DATA="" W !?8,"(-) None Found" - ; - ; secondary IDs - I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX - W !?5,"Lab or Facility Secondary IDs (VistA Records SUB1,SUB2,OP3,OP6,OP7):" - D SECID(Z,.IBQUIT) - I IBQUIT G EX - ; -EX ; - Q - ; -QUAL(Z,FORMTYPE) ; turn the qualifier code into a qualifier description - NEW QUAL,IEN - S QUAL="" - I $G(Z)="" G QUALX - I Z="1C" D G QUALX ; qualifier for Medicare Part ? - . I $G(FORMTYPE)=2 S QUAL="MEDICARE PART B" ; 1500 - . I $G(FORMTYPE)=3 S QUAL="MEDICARE PART A" ; ub - . Q - I Z=34 S Z="SY" ; qualifier for SSN - S IEN=+$O(^IBE(355.97,"C",Z,"")) I 'IEN G QUALX - S QUAL=$P($G(^IBE(355.97,IEN,0)),U,1) -QUALX ; - Q QUAL - ; -SECID(Z,IBQUIT) ; Display secondary ID and qualifier information - ; Z is the type of IDs passed in; either BILLING PRV or LAB/FAC - ; IBQUIT is returned if passed by reference - NEW SEQ,ZI,ZN,PSIN,DATA,QUALNM,IDNUM,NODATA - S IBQUIT=0,NODATA=1 - F SEQ="P","S","T" D Q:IBQUIT - . ; - . ; current ins only for billing provider secondary IDs - . I Z="BILLING PRV",SEQ'=$$COB^IBCEF(IBIFN) Q - . S ZI="" - . F S ZI=$O(IBX(Z,SEQ,ZI)) Q:ZI="" D Q:IBQUIT - .. S ZN=0 - .. F S ZN=$O(IBX(Z,SEQ,ZI,ZN)) Q:'ZN D Q:IBQUIT - ... S PSIN=0 ; start at 0 to skip primary IDs - ... F S PSIN=$O(IBID(Z,IBIFN,ZI,ZN,PSIN)) Q:PSIN="" D Q:IBQUIT - .... S DATA=$G(IBID(Z,IBIFN,ZI,ZN,PSIN)) - .... S QUALNM=$$QUAL($P(DATA,U,1),$$FT^IBCEF(IBIFN)) - .... S IDNUM=$P(DATA,U,2) - .... I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() Q:IBQUIT - .... S NODATA=0 - .... W !?8,"(",SEQ,") ",QUALNM,?40,IDNUM - .... I Z="LAB/FAC",$D(^DGCR(399,IBIFN,"I2")),SEQ=$$COB^IBCEF(IBIFN) W ?54,"<<IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX + S Z="BILLING PRV" + ; PRXM/KJH - Removed "I $D(IBX(Z))" from next line. Caused header to not display even though there would be a "None Found' message. + W !!,"Billing Provider Secondary IDs (VistA Record CI1A):" + D SECID(Z,.IBQUIT) + I IBQUIT G EX + ; + ; Now display the lab or facility primary and secondary IDs + ; This is the service facility information + ; + ; Facility name, same code as found in SUB-2 + I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX + W !!,"Service Facility Name and ID Information" + S IBXIEN=IBIFN + D F^IBCEF("N-RENDERING INSTITUTION","IBZ",,IBIFN) + S FACNAME=$$GETFAC^IBCEP8(+IBZ,+$P(IBZ,U,2),0,"SUB") + S Z="LAB/FAC" + ; + ; determine if flag to suppress lab/fac data is set + D VAMCFD^IBCEF75(IBIFN,.IBSSFI) + I $D(IBSSFI),'$G(IBSSFI("C",1)) D I IBQUIT G EX + . I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() Q:IBQUIT + . W !!,"Note: Service Facility Data not sent for Current Insurance" + . W !," 'Send VA Lab/Facility IDs or Facility Data for VAMC?' is set to NO",! + . Q + ; + ; facility name + I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX + I FACNAME="" S FACNAME="n/a" + W !,"Facility: ",FACNAME + ; + ; PRXM/KJH - Add NPI to display for patch 343. + S ORGNPI=$$ORGNPI^IBCEF73A(IBIFN) + S DATA=$S($P($G(IBZ),U,2)=1:$P(ORGNPI,U,2),$P($G(IBZ),U,2)=0:$P(ORGNPI,U,1),1:$P(ORGNPI,U,3)) + I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX + W !?5,"Lab or Facility NPI:" + W !?12,$S(DATA'="":DATA,1:"***MISSING***") + ; primary ID + S DATA=$G(IBID(Z,IBIFN,"C",1,0)) ; lab/facility current ins primary + S QUALNM=$$QUAL($P(DATA,U,1),$$FT^IBCEF(IBIFN)) + S IDNUM=$P(DATA,U,2) + I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX + W !?5,"Lab or Facility Primary ID (VistA Record SUB):" + I DATA'="" W !?8,"(",$P($G(IBID(Z,IBIFN,"C",1)),U,1),") ",QUALNM,?40,IDNUM + I DATA="" W !?8,"(-) None Found" + ; + ; secondary IDs + I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX + W !?5,"Lab or Facility Secondary IDs (VistA Records SUB1,SUB2,OP3,OP6,OP7):" + D SECID(Z,.IBQUIT) + I IBQUIT G EX + ; +EX ; + Q + ; +QUAL(Z,FORMTYPE) ; turn the qualifier code into a qualifier description + NEW QUAL,IEN + S QUAL="" + I $G(Z)="" G QUALX + I Z="1C" D G QUALX ; qualifier for Medicare Part ? + . I $G(FORMTYPE)=2 S QUAL="MEDICARE PART B" ; 1500 + . I $G(FORMTYPE)=3 S QUAL="MEDICARE PART A" ; ub + . Q + I Z=34 S Z="SY" ; qualifier for SSN + S IEN=+$O(^IBE(355.97,"C",Z,"")) I 'IEN G QUALX + S QUAL=$P($G(^IBE(355.97,IEN,0)),U,1) +QUALX ; + Q QUAL + ; +SECID(Z,IBQUIT) ; Display secondary ID and qualifier information + ; Z is the type of IDs passed in; either BILLING PRV or LAB/FAC + ; IBQUIT is returned if passed by reference + NEW SEQ,ZI,ZN,PSIN,DATA,QUALNM,IDNUM,NODATA + S IBQUIT=0,NODATA=1 + F SEQ="P","S","T" D Q:IBQUIT + . ; + . ; current ins only for billing provider secondary IDs + . I Z="BILLING PRV",SEQ'=$$COB^IBCEF(IBIFN) Q + . S ZI="" + . F S ZI=$O(IBX(Z,SEQ,ZI)) Q:ZI="" D Q:IBQUIT + .. S ZN=0 + .. F S ZN=$O(IBX(Z,SEQ,ZI,ZN)) Q:'ZN D Q:IBQUIT + ... S PSIN=0 ; start at 0 to skip primary IDs + ... F S PSIN=$O(IBID(Z,IBIFN,ZI,ZN,PSIN)) Q:PSIN="" D Q:IBQUIT + .... S DATA=$G(IBID(Z,IBIFN,ZI,ZN,PSIN)) + .... S QUALNM=$$QUAL($P(DATA,U,1),$$FT^IBCEF(IBIFN)) + .... S IDNUM=$P(DATA,U,2) + .... I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() Q:IBQUIT + .... S NODATA=0 + .... W !?8,"(",SEQ,") ",QUALNM,?40,IDNUM + .... I Z="LAB/FAC",$D(^DGCR(399,IBIFN,"I2")),SEQ=$$COB^IBCEF(IBIFN) W ?54,"<<IBLIMIT - . S DAT=$G(^IBA(355.92,IEN,0)) - . Q:$P(DAT,U,8)'="A" ; only allow additional IDs - . Q:$P(DAT,U,7)="" ; No Provider ID - . Q:$P(DAT,U,6)="" ; No ID Qualifier - . I IBFRMTYP=1 Q:$P(DAT,U,4)=2 - . I IBFRMTYP=2 Q:$P(DAT,U,4)=1 - . ; - . ; Check if we already have one of these - . S QUAL=$$STRIP^IBCEF76($P(DAT,U,6),1,,IBSTRIP) - . S QUAL=$P($G(^IBE(355.97,QUAL,0)),U,3) - . Q:QUAL="" - . Q:$D(USED(QUAL)) - . ; - . S IDS("BILLING PRV",IBIFN,SORT1,SORT2,CNT)=QUAL_U_$$STRIP^IBCEF76($P(DAT,U,7),1,,IBSTRIP) - . S CNT=CNT+1,USED(QUAL)="" - ; - Q - ; -OLDWAY(IBIFN,COB) ; Figure out the qualifier the old way if it's not stored with the claim. - ; It's based on the plan type. This is used for Billing Provider Secondary ID #2 - N PLANTYPE - S PLANTYPE=$$POLTYP^IBCEF3(IBIFN,COB) - Q $$SOP^IBCEP2B(IBIFN,PLANTYPE) - ; -BPSID1(DIV) ; Return the Billing Provider Secondary ID #1 and qualifier which Emdeon uses to sort IBIFNs - N DATA - S DATA=$P($$SITE^VASITE(DT,$S(DIV:DIV,1:+$$SITE^VASITE())),U,3) - S DATA=$E("0000",1,7-$L(DATA))_$E(DATA,4,7) - Q "G5"_U_DATA - ; -TAXID() ; Return the Billing Provider Primary ID and qualifier which is the TAXID for the site and also the qualifier - N DATA - S DATA=$P($G(^IBE(350.9,1,1)),U,5) - S DATA=$$NOPUNCT^IBCEF(DATA,1) - Q 24_U_DATA - ; -VAMCFD(IBIFN,IBRET) ; - ; - ; This procedure returns data based on flag in insurance company file which is set in the insurance co editor - ; Send VA Lab/Facility IDs or Facility Data for VAMC? - ; The return value will be set to 1 (yes) if the division in the claim is not the main division (VAMC) or - ; if the flag in the dictionary for that insurance company says to send the data. - ; - ; Input - IBFN - IEN 399 - ; Output - IBRET(IBSORT1,IBSORT2)=FLAG - ; IBSORT1 = "C"urrent or "O"ther insurance - ; IBSORT2 = order with IBSORT1 - ; FLAG = 0 No or 1 Yes - ; - N IBDIV,MAIN,IBCCOB,IBSORT1,IBSORT2,DAT,IBINS,COB,OUTFAC - S IBDIV=+$P($G(^DGCR(399,IBIFN,0)),U,22) - S MAIN=$$MAIN^IBCEP2B() ; get the IEN for main Division - S IBCCOB=$$COBN^IBCEF(IBIFN) - F COB=1:1:3 D - . S IBSORT1=$S(COB=IBCCOB:"C",1:"O") - . S IBSORT2=$S(IBSORT1="C":1,COB=1:1,COB=2&(IBCCOB=1):1,1:2) - . S IBINS=+$G(^DGCR(399,IBIFN,"I"_COB)) - . Q:'IBINS - . S IBRET(IBSORT1,IBSORT2)=1 - . S OUTFAC=$P($G(^DGCR(399,IBIFN,"U2")),U,10) - . Q:OUTFAC]"" - . Q:IBDIV'=MAIN - . ; [7] Send VA Lab/Facility IDs or Facility Data for VAMC?(0 - NO, 1 - YES) - . S DAT(3647)=$P($G(^DIC(36,IBINS,4)),U,7) - . I DAT(3647) Q - . S IBRET(IBSORT1,IBSORT2)=0 - Q - ; -CLEANUP(IBXSAVE) ; Clean up - K IBXSAVE("PROVINF") - K IBXSAVE("LAB/FAC") - K IBXSAVE("BILLING PRV") - K IBXSAVE("ID") - Q +IBCEF75 ;ALB/WCJ - Provider ID functions ;13 Feb 2006 + ;;2.0;INTEGRATED BILLING;**320**;21-MAR-94 + ;; Per VHA Directive 10-93-142, this routine should not be modified. + ; + G AWAY +AWAY Q + ; +ALLIDS(IBIFN,IBXSAVE,IBSTRIP,SEG) ; Return all of the Provider IDS + I '$D(IBSTRIP) S IBSTRIP=0 + I '$D(SEG) S SEG="" + N IBXIEN,ARINFO,ARID,ARQ,IBFRMTYP,ARIEN,ARINS,Z0,DAT,I,SORT1,SORT2,SORT3,COB,IBCCOB + ; + S IBXIEN=IBIFN + D ALLPROV^IBCEF7 ; Get the Person ID's (Returns IBXSAVE) + S DAT=$$PROVID^IBCEF73(IBIFN) + S DAT("QUAL")=IBXSAVE("ID") ; this value was also passed back by above function + S SORT1="" F S SORT1=$O(IBXSAVE("PROVINF",IBIFN,SORT1)) Q:SORT1="" D + . S SORT2=0 F S SORT2=$O(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2)) Q:SORT2="" D + .. S SORT3=0 F S SORT3=$O(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3)) Q:SORT3="" D + ... S IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3,0)="PRIMARY"_U_U_$$STRIP^IBCEF76($P(DAT("QUAL"),U,SORT3)_U_$P(DAT,U,SORT3),1,U,IBSTRIP) + ... F I=1:1 Q:'$D(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3,I)) D + .... S $P(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3,I),U,3,4)=$$STRIP^IBCEF76($P(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3,I),U,3,4),1,U,IBSTRIP) + ; + D LFIDS^IBCEF76(IBIFN,.IBXSAVE,IBSTRIP,SEG) ; Get the Lab/Facility IDs + ; + S IBFRMTYP=$$FT^IBCEF(IBIFN) + S ARIEN=$S(IBFRMTYP=2:3,1:4) + S IBCCOB=$$COBN^IBCEF(IBIFN) ; Current Insurance + F COB=1:1:3 D + . S SORT1=$S(COB=IBCCOB:"C",1:"O") + . S SORT2=$S(SORT1="C":1,COB=1:1,COB=2&(IBCCOB=1):1,1:2) + . S ARINFO=$G(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,ARIEN,1)) + . ; + . D BPIDS(IBIFN,.IBXSAVE,SORT1,SORT2,COB,IBSTRIP,SEG) + Q + ; +BPIDS(IBIFN,IDS,SORT1,SORT2,COB,IBSTRIP,SEG) ; Get all the billing provider IDs and qualifiers from the claim and file 355.92 + N DAT,IBFRMTYP,IBCARE,IBDIV,IBINS,MAIN,IBCCOB,USED,PLANTYPE,I,CNT,QUAL,ARF,M1,DEF,IDDIV,IBLIMIT,IEN,ID,IB2 + ; + S DAT=$G(^DGCR(399,IBIFN,0)) + S IBFRMTYP=$$FT^IBCEF(IBIFN),IBFRMTYP=$S(IBFRMTYP=2:2,IBFRMTYP=3:1,1:0) + S IBCARE=$S($$ISRX^IBCEF1(IBIFN):3,1:0) ;if an Rx refill bill + S:IBCARE=0 IBCARE=$$INPAT^IBCEF(IBIFN,1) S:'IBCARE IBCARE=2 ;1-inp,2-out + S IBDIV=+$P(DAT,U,22) + S MAIN=$$MAIN^IBCEP2B() ; get the IEN for main Division + S IBCCOB=$$COBN^IBCEF(IBIFN) ; Current Insurance + S IBINS=$P($G(^DGCR(399,IBIFN,"I"_COB)),U) + Q:IBINS="" + ; + S IDS("BILLING PRV",IBIFN,SORT1,SORT2)=$E("PST",COB) + ; + ; Primary ID + S IDS("BILLING PRV",IBIFN,SORT1,SORT2,0)=$$STRIP^IBCEF76($$TAXID(),1,U,IBSTRIP) + S USED($P(IDS("BILLING PRV",IBIFN,SORT1,SORT2,0),U))="" + ; + ; Secondary #1 - This is the ID Emdeon uses for sorting + S IDS("BILLING PRV",IBIFN,SORT1,SORT2,1)=$$STRIP^IBCEF76($$BPSID1(IBDIV),1,U,IBSTRIP) + S USED($P(IDS("BILLING PRV",IBIFN,SORT1,SORT2,1),U))="" + ; + ; Check if this is a plan type which gets no secondary IDs + S M1=$G(^DGCR(399,IBIFN,"M1")) + ; the following check is the current value of the flag, not when the claim was created. + S PLANTYPE=$$POLTYP^IBCEF3(IBIFN,COB) + I PLANTYPE]"",$D(^DIC(36,IBINS,13,"B",PLANTYPE)) Q + ; + ; Secondary #2 + ; If there is a ID send with quailifer (stored or computed) + I $P(M1,U,COB+1)]"" D + . S QUAL="" + . S DAT=$P(M1,U,COB+9) + . I DAT S QUAL=$$STRIP^IBCEF76($P($G(^IBE(355.97,DAT,0)),U,3),1,,IBSTRIP) + . ; the null check is needed to be backwards compatible + . I QUAL=""!(QUAL="1J") S QUAL=$$STRIP^IBCEF76($$OLDWAY(IBIFN,COB),1,,IBSTRIP) + . S IB2=QUAL_U_$$STRIP^IBCEF76($P(M1,U,COB+1),1,,IBSTRIP) + ; + I $P(M1,U,COB+1)="" S IB2=$$STRIP^IBCEF76($$OLDWAY(IBIFN,COB),1,,IBSTRIP)_U_$$STRIP^IBCEF76($$GET1^DIQ(350.9,1,1.05),1,,IBSTRIP) + ; + S IDS("BILLING PRV",IBIFN,SORT1,SORT2,2)=IB2 + S IDS("BILLING PRV",IBIFN,SORT1,SORT2,2,"PTQ")=$$OLDWAY(IBIFN,COB) + S USED($P(IB2,U))="" + ; + S CNT=$S('$D(IDS("BILLING PRV",IBIFN,SORT1,SORT2,2)):2,1:3) + S IBLIMIT=8 + S IEN=0 F S IEN=$O(^IBA(355.92,"B",IBINS,IEN)) Q:IEN="" D Q:CNT>IBLIMIT + . S DAT=$G(^IBA(355.92,IEN,0)) + . Q:$P(DAT,U,8)'="A" ; only allow additional IDs + . Q:$P(DAT,U,7)="" ; No Provider ID + . Q:$P(DAT,U,6)="" ; No ID Qualifier + . I IBFRMTYP=1 Q:$P(DAT,U,4)=2 + . I IBFRMTYP=2 Q:$P(DAT,U,4)=1 + . ; + . ; Check if we already have one of these + . S QUAL=$$STRIP^IBCEF76($P(DAT,U,6),1,,IBSTRIP) + . S QUAL=$P($G(^IBE(355.97,QUAL,0)),U,3) + . Q:QUAL="" + . Q:$D(USED(QUAL)) + . ; + . S IDS("BILLING PRV",IBIFN,SORT1,SORT2,CNT)=QUAL_U_$$STRIP^IBCEF76($P(DAT,U,7),1,,IBSTRIP) + . S CNT=CNT+1,USED(QUAL)="" + ; + Q + ; +OLDWAY(IBIFN,COB) ; Figure out the qualifier the old way if it's not stored with the claim. + ; It's based on the plan type. This is used for Billing Provider Secondary ID #2 + N PLANTYPE + S PLANTYPE=$$POLTYP^IBCEF3(IBIFN,COB) + Q $$SOP^IBCEP2B(IBIFN,PLANTYPE) + ; +BPSID1(DIV) ; Return the Billing Provider Secondary ID #1 and qualifier which Emdeon uses to sort IBIFNs + N DATA + S DATA=$P($$SITE^VASITE(DT,$S(DIV:DIV,1:+$$SITE^VASITE())),U,3) + S DATA=$E("0000",1,7-$L(DATA))_$E(DATA,4,7) + Q "G5"_U_DATA + ; +TAXID() ; Return the Billing Provider Primary ID and qualifier which is the TAXID for the site and also the qualifier + N DATA + S DATA=$P($G(^IBE(350.9,1,1)),U,5) + S DATA=$$NOPUNCT^IBCEF(DATA,1) + Q 24_U_DATA + ; +VAMCFD(IBIFN,IBRET) ; + ; + ; This procedure returns data based on flag in insurance company file which is set in the insurance co editor + ; Send VA Lab/Facility IDs or Facility Data for VAMC? + ; The return value will be set to 1 (yes) if the division in the claim is not the main division (VAMC) or + ; if the flag in the dictionary for that insurance company says to send the data. + ; + ; Input - IBFN - IEN 399 + ; Output - IBRET(IBSORT1,IBSORT2)=FLAG + ; IBSORT1 = "C"urrent or "O"ther insurance + ; IBSORT2 = order with IBSORT1 + ; FLAG = 0 No or 1 Yes + ; + N IBDIV,MAIN,IBCCOB,IBSORT1,IBSORT2,DAT,IBINS,COB,OUTFAC + S IBDIV=+$P($G(^DGCR(399,IBIFN,0)),U,22) + S MAIN=$$MAIN^IBCEP2B() ; get the IEN for main Division + S IBCCOB=$$COBN^IBCEF(IBIFN) + F COB=1:1:3 D + . S IBSORT1=$S(COB=IBCCOB:"C",1:"O") + . S IBSORT2=$S(IBSORT1="C":1,COB=1:1,COB=2&(IBCCOB=1):1,1:2) + . S IBINS=+$G(^DGCR(399,IBIFN,"I"_COB)) + . Q:'IBINS + . S IBRET(IBSORT1,IBSORT2)=1 + . S OUTFAC=$P($G(^DGCR(399,IBIFN,"U2")),U,10) + . Q:OUTFAC]"" + . Q:IBDIV'=MAIN + . ; [7] Send VA Lab/Facility IDs or Facility Data for VAMC?(0 - NO, 1 - YES) + . S DAT(3647)=$P($G(^DIC(36,IBINS,4)),U,7) + . I DAT(3647) Q + . S IBRET(IBSORT1,IBSORT2)=0 + Q + ; +CLEANUP(IBXSAVE) ; Clean up + K IBXSAVE("PROVINF") + K IBXSAVE("LAB/FAC") + K IBXSAVE("BILLING PRV") + K IBXSAVE("ID") + Q diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEFG1.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEFG1.m index c3ff51e8..7f013b35 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEFG1.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEFG1.m @@ -1,128 +1,135 @@ -IBCEFG1 ;ALB/TMP - OUTPUT FORMATTER DATA DEFINITION UTILITIES ;18-JAN-96 - ;;2.0;INTEGRATED BILLING;**52,51,137,181,197,232,288,349,371,377**;21-MAR-94;Build 23 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -EDIBILL(IBXFORM,IBXDA,IBINS,IBTYP) ; Find element associated with form fld - ; IBXFORM = (REQUIRED) actual form being extracted (in file 353) - ; IBXDA = (REQUIRED) form definition file (364.6) entry to use to find - ; extract data element definition entry (in file 364.7) - ; IBINS = (REQUIRED) insurance co. ien for the current insurance on bill - ; IBTYP = (REQUIRED) bill type (I/O) - ; - ; Returns ien of the entry in file 364.7 if a match on override criteria - ; was found. Returns -1 if a screen form and the criteria fails for a - ; field without an override - ; - N IBX,IBPARFM,IBSCREEN,IBNMATCH,EDIQ,IB1 - I $G(IBXDA)=""!($G(IBXFORM)="") G EDIQ - S EDIQ=0 - S IBPARFM=$P($G(^IBE(353,IBXFORM,2)),U,5) S:'IBPARFM IBPARFM=IBXFORM - S IBSCREEN=($P($G(^IBE(353,+IBXFORM,2)),U,2)="S") - S IB1=(IBPARFM=IBXFORM) ; Not a local field that is not a parent - ; - I $G(IBINS)'="",$G(IBTYP)'="" D:$O(^IBA(364.7,"AINTYP",IBXDA,""))'="" G:EDIQ EDIQ - . I '$D(^IBA(364.7,"AINTYP",IBXDA,IBINS,IBTYP)) S IBNMATCH=1 Q - . S IBX=+$O(^IBA(364.7,"AINTYP",IBXDA,IBINS,IBTYP,"")),EDIQ=1 S:IBX IBNMATCH=0 ;by ins co and type of bill - ; - I $G(IBINS)'="" D:$O(^IBA(364.7,"AINS",IBXDA,""))'="" G:EDIQ EDIQ - . I '$D(^IBA(364.7,"AINS",IBXDA,IBINS)) S IBNMATCH=1 Q - . S IBX=+$O(^IBA(364.7,"AINS",IBXDA,IBINS,"")),EDIQ=1 S:IBX IBNMATCH=0 ;ins co only - ; - I $G(IBTYP)'="" D:$O(^IBA(364.7,"ATYPE",IBXDA,""))'="" G:EDIQ EDIQ - . I '$D(^IBA(364.7,"ATYPE",IBXDA,IBTYP)) S IBNMATCH=1 Q - . S IBX=+$O(^IBA(364.7,"ATYPE",IBXDA,IBTYP,"")),EDIQ=1 S:IBX IBNMATCH=0 ;type of bill only - ; - I IBXFORM,$S(IBXFORM'=IBPARFM:1,1:IBSCREEN) D G EDIQ - . S IBX=+$O(^IBA(364.7,"ALL",IBXDA,"")) ; Check for all ins co and types - . I IBX,+$O(^IBA(364.7,"ALL",IBXDA,IBX)) D ; Find override for 'ALL' - .. N Z - .. S Z=0 F S Z=$O(^IBA(364.7,"ALL",IBXDA,Z)) Q:'Z I $P($G(^IBA(364.7,Z,0)),U)'=IBXDA S IBX=Z Q - . I 'IBX,+$O(^IBA(364.7,"B",IBXDA,"")) S IBX=$O(^("")) - . S:IBX IBNMATCH=0 - ; - I IBXFORM,$O(^IBA(364.6,"APAR",IBXFORM,IBXDA,"")) S IBX=+$O(^("")),IBX=+$O(^IBA(364.7,"B",IBX,0)) I IBX G EDIQ - S IBX=+$O(^IBA(364.7,"B",IBXDA,"")) -EDIQ I IBSCREEN,$G(IBNMATCH) S IBX=-1 - Q $G(IBX) - ; -DT(DATE1,DATE2,FORMAT) ; Return date in DATE1 (and optionally DATE2) - ; (input in Fileman format) converted to X12 format - ; FORMAT (required) - ; DATE1,DATE2 in FILEMAN date format - N DATE S DATE="" - I DATE1=0 S DATE1="" - I $E(FORMAT)="D" D G DTQ - .S DATE=$E(DATE1,2,7) Q:$P(FORMAT,"D",2)=6 ;YYMMDD - .S:DATE1 DATE=($E(DATE1)+17)_DATE ;CCYYMMDD - I $E(FORMAT)="R" D - .S:DATE1 DATE=$E(DATE1,2,7)_"-"_$E($S($G(DATE2):DATE2,1:DATE1),2,7) ;YYMMDD-YYMMDD - .Q:FORMAT["6" - .S DATE=($E(DATE1)+17)_DATE,$P(DATE,"-",2)=($E($S($G(DATE2):DATE2,1:DATE1))+17)_$P(DATE,"-",2) ;CCYYMMDD-CCYYMMDD -DTQ Q DATE - ; -NAME(IBNM1,COMB) ; Parse person's nm into 5 pieces LAST^FIRST^MIDDLE^CRED^SUFFIX - ; IBNM1 = NAME in LAST,FIRST MIDDLE^vp file ien (200 or 355.93)^bill ien^prv type - ; OR FIRST MIDDLE LAST^vp file ien (200 or 355.93)^bill ien^prv type - ; COMB = if set to 1, then combine the first and middle name - ; if set to 2, combine the last and middle names - N PC,IBIEN,IBCRED,IBNM,IBNMC,IBPIEN - S IBIEN=$P(IBNM1,U,2),IBNMC=$P(IBNM1,U) - S IBPIEN=+$O(^DGCR(399,+$P(IBNM1,U,3),"PRV","B",+$P(IBNM1,U,4),0)) - S IBCRED=$$CRED^IBCEU(IBIEN,+$P(IBNM1,U,3),IBPIEN) ;Degree - I IBNMC="DEPT VETERANS AFFAIRS" S IBNMC="VETERANS AFFAIRS,DEPT" - I IBNMC["," D G NAMEQ - . S IBNMC=$TR(IBNMC,".") D NAMECOMP^XLFNAME(.IBNMC) - . S IBNM=$G(IBNMC("FAMILY"))_U_$G(IBNMC("GIVEN"))_U_$G(IBNMC("MIDDLE"))_U_IBCRED_U_$G(IBNMC("SUFFIX")) - D STDNAME^XLFNAME(.IBNMC,"C") - S IBNM=$G(IBNMC("FAMILY"))_U_$G(IBNMC("GIVEN"))_U_$G(IBNMC("MIDDLE"))_U_IBCRED_U_$G(IBNMC("SUFFIX")) - I $P(IBNM1,U,2)["355.93",$P($G(^IBA(355.93,+$P(IBNM1,U,2),0)),U,2)=1 D G NAMEQ ; group performing provider - . S IBNM=$P(IBNM1,U)_U_U_U_IBCRED_U - I $G(COMB)=1,$G(IBNMC("MIDDLE"))'="" S IBNM=$P(IBNM,U)_U_$P(IBNM,U,2)_" "_$P(IBNM,U,3)_U_IBCRED_U_$P(IBNM,U,5) - I $G(COMB)=2,$G(IBNMC("MIDDLE"))'="" S IBNM=$P(IBNM,U)_" "_$P(IBNM,U,3)_U_$P(IBNM,U,2)_U_IBCRED_U_$P(IBNM,U,5) - ; -NAMEQ Q IBNM - ; -DOLLAR(AMT) ; Format amount in AMT so it is numeric including cents, without - ; the decimal and commas. - N DOLR,CENT - I AMT'="" S AMT=$TR(AMT,","),DOLR=$P(AMT,"."),CENT=$E($P(AMT,".",2)_"00",1,2),AMT=DOLR_CENT - Q AMT - ; -STATE(CODE) ;Return state code from state pointer - Q $P($G(^DIC(5,+CODE,0)),U,2) - ; -SEX(CODE) ;Return the X12 code for sex - ; CODE = DHCP code for sex - Q $S(CODE="":"U","MF"[$E(CODE):$E(CODE),1:"U") - ; -EMPLST(CODE) ;Return the X12 code for employment status - ; CODE = DHCP code for employment status - N X12 - S X12="" - S:CODE'="" X12=$P($P("1;FT^2;PT^3;NE^4;SE^5;RT^6;AU^9;UK",CODE_";",2),U) - S:X12="" X12="UK" - Q X12 - ; -MARITAL(CODE) ;Return the X12 code for marital status - ; CODE = ien of code for marital status - N X12 - S X12=$P($G(^DIC(11,+CODE,0)),U,3) - I X12'="" S X12=$P($P("D;D^M;M^N;I^S;X^W;W^U;K",X12_";",2),U) - Q X12 - ; -TOS(CODE) ;Return the X12 code for type of service - ; CODE = DHCP code for type of service - N X12 - S X12=$S(CODE>0&(CODE<10):CODE,1:$P($P("0;10^A;11^B;13^H;45^L;18^M;15^N;63^V;19^Y;20^Z;21^43;96^53;96",CODE_";",2),U)) S:X12="" X12=CODE - Q X12 - ; -FIXLEN(DATA,LEN) ; Create a fixed length field from data DATA length LEN - Q $E(DATA_$J("",LEN),1,LEN) - ; -RCDT(IBXSAVE,IBXDATA,IBDT) ; Format date for multiple revenue code transmission) - ;IBXSAVE = array containing the extracted service line data for the UB format bill - ;IBXDATA = array returned with service line dates formatted in YYYYMMDD format - ;IBDT = the default date for the revenue codes on the bill - N Q,W - S Q=0 F S Q=$O(IBXSAVE("INPT",Q)) Q:'Q S W=$$DT($P(IBXSAVE("INPT",1),U,10),,"D8"),IBXDATA(Q)=$S(W:W,1:IBDT) - Q +IBCEFG1 ;ALB/TMP - OUTPUT FORMATTER DATA DEFINITION UTILITIES ;18-JAN-96 + ;;2.0;INTEGRATED BILLING;**52,51,137,181,197,232,288,349**;21-MAR-94;Build 46 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; +EDIBILL(IBXFORM,IBXDA,IBINS,IBTYP) ; Find element associated with form fld + ; IBXFORM = (REQUIRED) actual form being extracted (in file 353) + ; IBXDA = (REQUIRED) form definition file (364.6) entry to use to find + ; extract data element definition entry (in file 364.7) + ; IBINS = (REQUIRED) insurance co. ien for the current insurance on bill + ; IBTYP = (REQUIRED) bill type (I/O) + ; + ; Returns ien of the entry in file 364.7 if a match on override criteria + ; was found. Returns -1 if a screen form and the criteria fails for a + ; field without an override + ; + N IBX,IBPARFM,IBSCREEN,IBNMATCH,EDIQ,IB1 + I $G(IBXDA)=""!($G(IBXFORM)="") G EDIQ + S EDIQ=0 + S IBPARFM=$P($G(^IBE(353,IBXFORM,2)),U,5) S:'IBPARFM IBPARFM=IBXFORM + S IBSCREEN=($P($G(^IBE(353,+IBXFORM,2)),U,2)="S") + S IB1=(IBPARFM=IBXFORM) ; Not a local field that is not a parent + ; + I $G(IBINS)'="",$G(IBTYP)'="" D:$O(^IBA(364.7,"AINTYP",IBXDA,""))'="" G:EDIQ EDIQ + . I '$D(^IBA(364.7,"AINTYP",IBXDA,IBINS,IBTYP)) S IBNMATCH=1 Q + . S IBX=+$O(^IBA(364.7,"AINTYP",IBXDA,IBINS,IBTYP,"")),EDIQ=1 S:IBX IBNMATCH=0 ;by ins co and type of bill + ; + I $G(IBINS)'="" D:$O(^IBA(364.7,"AINS",IBXDA,""))'="" G:EDIQ EDIQ + . I '$D(^IBA(364.7,"AINS",IBXDA,IBINS)) S IBNMATCH=1 Q + . S IBX=+$O(^IBA(364.7,"AINS",IBXDA,IBINS,"")),EDIQ=1 S:IBX IBNMATCH=0 ;ins co only + ; + I $G(IBTYP)'="" D:$O(^IBA(364.7,"ATYPE",IBXDA,""))'="" G:EDIQ EDIQ + . I '$D(^IBA(364.7,"ATYPE",IBXDA,IBTYP)) S IBNMATCH=1 Q + . S IBX=+$O(^IBA(364.7,"ATYPE",IBXDA,IBTYP,"")),EDIQ=1 S:IBX IBNMATCH=0 ;type of bill only + ; + I IBXFORM,$S(IBXFORM'=IBPARFM:1,1:IBSCREEN) D G EDIQ + . S IBX=+$O(^IBA(364.7,"ALL",IBXDA,"")) ; Check for all ins co and types + . I IBX,+$O(^IBA(364.7,"ALL",IBXDA,IBX)) D ; Find override for 'ALL' + .. N Z + .. S Z=0 F S Z=$O(^IBA(364.7,"ALL",IBXDA,Z)) Q:'Z I $P($G(^IBA(364.7,Z,0)),U)'=IBXDA S IBX=Z Q + . I 'IBX,+$O(^IBA(364.7,"B",IBXDA,"")) S IBX=$O(^("")) + . S:IBX IBNMATCH=0 + ; + I IBXFORM,$O(^IBA(364.6,"APAR",IBXFORM,IBXDA,"")) S IBX=+$O(^("")),IBX=+$O(^IBA(364.7,"B",IBX,0)) I IBX G EDIQ + S IBX=+$O(^IBA(364.7,"B",IBXDA,"")) +EDIQ I IBSCREEN,$G(IBNMATCH) S IBX=-1 + Q $G(IBX) + ; +DT(DATE1,DATE2,FORMAT) ; Return date in DATE1 (and optionally DATE2) + ; (input in Fileman format) converted to X12 format + ; FORMAT (required) + ; DATE1,DATE2 in FILEMAN date format + N DATE S DATE="" + I DATE1=0 S DATE1="" + I $E(FORMAT)="D" D G DTQ + .S DATE=$E(DATE1,2,7) Q:$P(FORMAT,"D",2)=6 ;YYMMDD + .S:DATE1 DATE=($E(DATE1)+17)_DATE ;CCYYMMDD + I $E(FORMAT)="R" D + .S:DATE1 DATE=$E(DATE1,2,7)_"-"_$E($S($G(DATE2):DATE2,1:DATE1),2,7) ;YYMMDD-YYMMDD + .Q:FORMAT["6" + .S DATE=($E(DATE1)+17)_DATE,$P(DATE,"-",2)=($E($S($G(DATE2):DATE2,1:DATE1))+17)_$P(DATE,"-",2) ;CCYYMMDD-CCYYMMDD +DTQ Q DATE + ; +NAME(IBNM1,COMB) ; Parse person's nm into 5 pieces LAST^FIRST^MIDDLE^CRED^SUFFIX + ; IBNM1 = NAME in LAST,FIRST MIDDLE^vp file ien (200 or 355.93)^bill ien^prv type + ; OR FIRST MIDDLE LAST^vp file ien (200 or 355.93)^bill ien^prv type + ; COMB = if set to 1, then combine the first and middle name + ; if set to 2, combine the last and middle names + N PC,IBIEN,IBCRED,IBNM,IBNMC,IBPIEN + S IBIEN=$P(IBNM1,U,2),IBNMC=$P(IBNM1,U) + S IBPIEN=+$O(^DGCR(399,+$P(IBNM1,U,3),"PRV","B",+$P(IBNM1,U,4),0)) + S IBCRED=$$CRED^IBCEU(IBIEN,+$P(IBNM1,U,3),IBPIEN) ;Degree + I IBNMC="DEPT VETERANS AFFAIRS" S IBNMC="VETERANS AFFAIRS,DEPT" + I IBNMC["," D G NAMEQ + . S IBNMC=$TR(IBNMC,".") D NAMECOMP^XLFNAME(.IBNMC) + . S IBNM=$G(IBNMC("FAMILY"))_U_$G(IBNMC("GIVEN"))_U_$G(IBNMC("MIDDLE"))_U_IBCRED_U_$G(IBNMC("SUFFIX")) + D STDNAME^XLFNAME(.IBNMC,"C") + S IBNM=$G(IBNMC("FAMILY"))_U_$G(IBNMC("GIVEN"))_U_$G(IBNMC("MIDDLE"))_U_IBCRED_U_$G(IBNMC("SUFFIX")) + I $P(IBNM1,U,2)["355.93",$P($G(^IBA(355.93,+$P(IBNM1,U,2),0)),U,2)=1 D G NAMEQ ; group performing provider + . S IBNM=$P(IBNM1,U)_U_U_U_IBCRED_U + I $G(COMB)=1,$G(IBNMC("MIDDLE"))'="" S IBNM=$P(IBNM,U)_U_$P(IBNM,U,2)_" "_$P(IBNM,U,3)_U_IBCRED_U_$P(IBNM,U,5) + I $G(COMB)=2,$G(IBNMC("MIDDLE"))'="" S IBNM=$P(IBNM,U)_" "_$P(IBNM,U,3)_U_$P(IBNM,U,2)_U_IBCRED_U_$P(IBNM,U,5) + ; +NAMEQ Q IBNM + ; +DOLLAR(AMT) ; Format amount in AMT so it is numeric including cents, without + ; the decimal and commas. + N DOLR,CENT + I AMT'="" S DOLR=$P(AMT,"."),CENT=$E($P(AMT,".",2)_"00",1,2),AMT=DOLR_CENT + Q $TR(AMT,",") + ; +STATE(CODE) ;Return state code from state pointer + Q $P($G(^DIC(5,+CODE,0)),U,2) + ; +SEX(CODE) ;Return the X12 code for sex + ; CODE = DHCP code for sex + Q $S(CODE="":"U","MF"[$E(CODE):$E(CODE),1:"U") + ; +RELATION(CODE) ;Return the X12 code for relationship + ; CODE = DHCP code for relationship + N X12 + S X12="" + S:CODE'="" X12=$P($S(CODE="01":"18^SELF",CODE="02":"01^SPOUSE",CODE="03":"19^NATURAL CHILD",CODE="08":"20^EMPLOYEE",CODE="32":"32^MOTHER",CODE="33":"33^FATHER",CODE="11":"39^ORGAN DONOR",CODE="15":"41^INJURED PLAINTIFF",1:""),U) + Q X12 + ; +EMPLST(CODE) ;Return the X12 code for employment status + ; CODE = DHCP code for employment status + N X12 + S X12="" + S:CODE'="" X12=$P($P("1;FT^2;PT^3;NE^4;SE^5;RT^6;AU^9;UK",CODE_";",2),U) + S:X12="" X12="UK" + Q X12 + ; +MARITAL(CODE) ;Return the X12 code for marital status + ; CODE = ien of code for marital status + N X12 + S X12=$P($G(^DIC(11,+CODE,0)),U,3) + I X12'="" S X12=$P($P("D;D^M;M^N;I^S;X^W;W^U;K",X12_";",2),U) + Q X12 + ; +TOS(CODE) ;Return the X12 code for type of service + ; CODE = DHCP code for type of service + N X12 + S X12=$S(CODE>0&(CODE<10):CODE,1:$P($P("0;10^A;11^B;13^H;45^L;18^M;15^N;63^V;19^Y;20^Z;21^43;96^53;96",CODE_";",2),U)) S:X12="" X12=CODE + Q X12 + ; +FIXLEN(DATA,LEN) ; Create a fixed length field from data DATA length LEN + Q $E(DATA_$J("",LEN),1,LEN) + ; +RCDT(IBXSAVE,IBXDATA,IBDT) ; Format date for multiple revenue code transmission) + ;IBXSAVE = array containing the extracted service line data for the UB format bill + ;IBXDATA = array returned with service line dates formatted in YYYYMMDD format + ;IBDT = the default date for the revenue codes on the bill + N Q,W + S Q=0 F S Q=$O(IBXSAVE("INPT",Q)) Q:'Q S W=$$DT($P(IBXSAVE("INPT",1),U,10),,"D8"),IBXDATA(Q)=$S(W:W,1:IBDT) + Q diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEM.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEM.m index 9f2f3dbd..8702d926 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEM.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEM.m @@ -1,189 +1,188 @@ -IBCEM ;ALB/TMP - 837 EDI RETURN MESSAGE PROCESSING ;17-APR-96 - ;;2.0;INTEGRATED BILLING;**137,191,155,371**;21-MAR-94;Build 57 - ;;Per VHA Directive 2004-038, this routine should not be modified. - Q - ; -UPD ; Update messages manually from messages list - N IBDA,IBOK,IBTDA,ZTSK,IBTSK,IBTYP,IBU,IBU1,IB0 - D FULL^VALM1 - D SEL(.IBDA,1) - S IBDA=$O(IBDA("")) - I IBDA="" G UPDQ - S IBTDA=+IBDA(IBDA) - I '$$LOCK(IBTDA) G UPDQ - S IB0=$G(^IBA(364.2,IBTDA,0)) - ; - I IB0="" D G UPDQ - . W !,*7,"Message ",IBDA," is no longer in return message file" S IBOK="" - . D PAUSE^VALM1 - I $P(IB0,U,11) S IBOK=1 D G:'IBOK UPDQ - . N ZTSK - . S ZTSK=$P(IB0,U,11) D STAT^%ZTLOAD Q:ZTSK(0)=0 ;Task not scheduled - . I "12"[ZTSK(1) W *7,!,"This message has already been scheduled for update. Task # is: ",$P(IB0,U,11) S IBOK="" D PAUSE^VALM1 - ; - I $P(IB0,U,6)=""!("UP"'[$P(IB0,U,6)) D G UPDQ - . W !,*7,"Message status ("_$$EXPAND^IBTRE(364.2,.06,$P(IB0,U,6))_") is not appropriate for this action" - . D PAUSE^VALM1 - ; - S IBTYP=$P($G(^IBE(364.3,+$P(IB0,U,2),0)),U) - S IBU=$S(IBTYP="REPORT":"MAILIT^IBCESRV2",IBTYP["837REC":"CON837^IBCESRV2",IBTYP["837REJ":"REJ837^IBCESRV2",IBTYP["835EOB":"EOB835^IBCESRV3",1:""),IBU1=$S(IBTYP["837":$E(IBTYP,$L(IBTYP)),1:2) - I IBU="" W !,*7,"This message has an invalid message type - can't update" D PAUSE^VALM1 G UPDQ - S IBTSK=$$TASK(IBU,$P(IB0,U,4),IBTDA,IBU1) - I IBTSK W !,"Update has been tasked (#",IBTSK,")" - I 'IBTSK W !,*7,"Update could not be tasked. Please try again later!!!" - D PAUSE^VALM1 - ; - D BLD^IBCEM1 -UPDQ I $G(IBTDA) L -^IBA(364.2,IBTDA,0) - S VALMBCK="R" - Q - ; -VP ; View/Print Return Messages - N DHD,DIC,FLDS,BY,FR,TO,DIR,Y,L,IBDA,IBTDA,IBBILLS - D FULL^VALM1,SEL(.IBDA,1) - S IBDA=$O(IBDA("")) - G:'IBDA VPQ - S IBTDA=$G(IBDA(IBDA)),IBBILLS="" - I $P($G(^IBA(364.2,IBTDA,0)),U,4),'$P(^(0),U,5) D - .S DIR(0)="YA",DIR("B")="NO",DIR("A")="Do you want to list all bills for this batch?: " D ^DIR K DIR - .I Y S IBBILLS=1 - S DHD=$S(IBBILLS:"[IBCEM MESSAGE LIST HDR]",1:""),DIC="^IBA(364.2,",FLDS=$S(IBBILLS:"[IBCEM MESSAGE LIST]",1:"[CAPTIONED]"),BY="@NUMBER",(FR,TO)=$G(IBDA(IBDA)),L=0 D EN1^DIP - D PAUSE^VALM1 -VPQ S VALMBCK="R" - Q - ; -SEL(IBDA,ONE) ; Select entry(s) from list - ; IBDA = array returned if selections made - ; IBDA(n)=ien of bill selected in file 399 - ; ONE = if set to 1, only one selection can be made at a time - N IB - K IBDA - D EN^VALM2($G(XQORNOD(0)),$S('$G(ONE):"",1:"S")) - S IBDA=0 F S IBDA=$O(VALMY(IBDA)) Q:'IBDA S IB=$G(^TMP("IBCEM-837DX",$J,IBDA)),IBDA(IBDA)=+$P(IB,U,2) - Q - ; -UPDEDI(IBDA,FUNC,NOCT) ; Update EDI files - cancel/resubmit/print as - ; resolution to message - ; IBDA = transmit bill ien # for bill - ; FUNC = "E" for edit/resubmit, "C" for cancel, "R" for resubmit not - ; from edit, "P" for print, "Z" for COB processed , "N" for no - ; further action needed-close record - ; NOCT = 1 if not necessary to update batch count, 0 if update needed - ; - N IB0,IBBA,IBBDA,IBCT,IBM,IBTDA,IBNEW,DA,DIE,DR,Z,IBTEXT,IBZ,IBIFN,IBSTAT - S IB0=$G(^IBA(364,+IBDA,0)),IBBA=$P(IB0,U,2) - Q:IB0="" S IBIFN=+IB0 - ; - S IBNEW=$S(FUNC="E"!(FUNC="R"):+$P($G(^IBA(364,+$$LAST364^IBCEF4(+IB0),0)),U,2),1:"") S:IBNEW=IBBA IBNEW="" - ; - S IBSTAT=$P(IB0,U,3) ; current status in file 364 - I '$F(".C.R.E.Z.","."_IBSTAT_".") D ; don't update if in final status - . S DR=".03////"_$S(FUNC="E":"R","NP"'[FUNC:FUNC,1:"Z")_";.04///NOW" S:FUNC="E"!(FUNC="R") DR=DR_$S(IBNEW:";.06////"_IBNEW,1:"") - . S DA=+IBDA,DIE="^IBA(364," D ^DIE ;Update the transmit bill record - . Q - ; - I IBBA D CKRES^IBCESRV2(IBBA) ;Update completely resubmitted flags - ; - I IBBA,(FUNC="P"!(IBNEW&'$G(NOCT))) D CTDOWN^IBCEM02(IBBA,1) ;If resubmitted in a new batch or printed, update old batch - ; - S IBTEXT(1)=" UPDATED BY: "_$$EXTERNAL^DILFD(361.02,.02,,+$G(DUZ)) - S IBTEXT(2)="ACTION USED: "_$S(FUNC="E":"BILL EDITED/RESUBMITTED",FUNC="C":"BILL CANCELED",FUNC="R":"BILL RESUBMITTED WITHOUT EDIT",FUNC="P":"PRINT BILL",FUNC="Z":"PROCESS COB",1:"") - S IBTEXT(2)=$S(IBTEXT(2)="":"UNSPECIFIED",1:IBTEXT(2)_" - REVIEW MARKED AS COMPLETE") - S IBTEXT=2 - ; - ; Update file 361 - S IBZ=0 F S IBZ=$O(^IBM(361,"AERR",+IBDA,IBZ)) Q:'IBZ I $D(^IBM(361,IBZ,0)),$P(^(0),U,10)="",$P(^(0),U,9)<2 D - . S DIE="^IBM(361,",DR=".09////2;.1////"_$TR(FUNC,"RCEIBZPN","RCROOFOO"),DA=IBZ D ^DIE - . I FUNC'="","ECRPIBZ"[FUNC D ; Update review status, notes for message - .. D NOTECHG^IBCECSA2(IBZ,1,.IBTEXT) - ; - ; Update file 361.1 with the Cancel Status, to cancel All EOB's on file - I FUNC="C" D STAT^IBCEMU2(IBIFN,9,0) - ; - Q - ; -DEL ; Delete messages from messages list - locked with IB SUPERVISOR key - N IBDA,IBOK,IBTDA,IBTYP,IBU,IBU1,IB0,DIR,IBT,IBE,Z,X,Y,XMSUBJ,XMTO,XMBODY,XMDUZ - D FULL^VALM1 - S IBTDA=0 - I '$D(^XUSEC("IB SUPERVISOR",DUZ)) D G DELQ - . W !,"You don't have authority to use this action. See your supervisr for assistance" - . D PAUSE^VALM1 - D SEL(.IBDA,1) - S IBDA=$O(IBDA("")) - I IBDA="" G DELQ - W ! - S DIR(0)="YA",DIR("A",1)="This action will PERMANENTLY delete a return message from your system",DIR("A",2)="A bulletin will be sent to report the deletion",DIR("A",3)=" " - S DIR("A")="ARE YOU SURE YOU WANT TO CONTINUE? ",DIR("B")="NO" - D ^DIR K DIR - G:Y'=1 DELQ - S IBTDA=+IBDA(IBDA) - I '$$LOCK(IBTDA) G DELQ - S IB0=$G(^IBA(364.2,IBTDA,0)) - ; - I $P(IB0,U,11) S IBOK=1 D G:'IBOK DELQ - . N ZTSK - . S ZTSK=$P(IB0,U,11) D STAT^%ZTLOAD Q:ZTSK(0)=0 ;Task not scheduled - . I "12"[ZTSK(1) W *7,!,"This message is currently scheduled for update. Task # is: ",$P(IB0,U,11) S IBOK="" D PAUSE^VALM1 - ; - I $P(IB0,U,6)=""!("UP"'[$P(IB0,U,6)) D G DELQ - . W !,*7,"Message status ("_$$EXPAND^IBTRE(364.2,.06,$P(IB0,U,6))_") is not appropriate for this action" - . D PAUSE^VALM1 - ; - S DIR(0)="YA",DIR("A",1)=" ",DIR("A",2)="",$P(DIR("A",2),"*",54)="",DIR("A",3)="* This message is about to be PERMANENTLY deleted!! *",DIR("A",4)=DIR("A",2),DIR("A",5)=" " - S DIR("A")="ARE YOU STILL SURE YOU WANT TO CONTINUE? ",DIR("B")="NO" - W ! D ^DIR W ! K DIR - I Y'=1 W !!,"Nothing deleted" D PAUSE^VALM1 G DELQ - ; - K ^TMP("IBMSG",$J) - M ^TMP("IBMSG",$J)=^IBA(364.2,IBTDA) - D DELMSG^IBCESRV2(IBTDA) - I $D(^IBA(364.2,IBTDA)) D G DELQ - . W !,"Message not deleted - problem with delete" D PAUSE^VALM1 - ; - S IBT(1)="EDI return message #"_$P(IB0,U)_" has been deleted" - S IBT(2)=" " - S IBT(3)="DELETED BY: "_$P($G(^VA(200,+$G(DUZ),0)),U)_" "_$$FMTE^XLFDT($$NOW^XLFDT,2) - S Z=$$EXPAND^IBTRE(364.2,.06,$P(IB0,U,6)) S:Z="" Z="??" - S IBT(4)=" STATUS: "_$E(Z_$J("",11),1,11)_" MESSAGE TYPE: "_$P($G(^IBE(364.3,+$P(IB0,U,2),0)),U,5) - S IBT(5)=" MESSAGE #: "_$E($P(IB0,U)_$J("",11),1,11)_" STATUS DATE: "_$$FMTE^XLFDT($P($G(^TMP("IBMSG",$J,1)),U,3)) - S IBT(6)=" BATCH #: "_$E($P($G(^IBA(364.1,+$P(IB0,U,4),0)),U)_$J("",11),1,11)_" BILL #: "_$$EXPAND^IBTRE(364.2,.05,$P(IB0,U,5)) - S IBT(7)=" " - S IBT(8)="MESSAGE TEXT:",IBE=8 - S Z=0 F S Z=$O(^TMP("IBMSG",$J,2,Z)) Q:'Z S IBE=IBE+1,IBT(IBE)=$G(^(Z,0)) - S XMSUBJ="EDI MESSAGE DELETED",XMBODY="IBT",XMDUZ="",XMTO("I:G.IB EDI")="" - D SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO,,.XMZ) - ; - K ^TMP("IBMSG",$J) - ; - W !,"A bulletin has been sent to report this deletion",! - D PAUSE^VALM1 - ; - D BLD^IBCEM1 -DELQ L -^IBA(364.2,IBTDA,0) - S VALMBCK="R" - Q - ; -TASK(IBRTN,IBBDA,IBTDA,IBTYP) ; Schedule the task to update data base from message - ; IBRTN = routine to task - ; IBBDA = batch # associated with the message (OPTIONAL) - ; IBTDA = internal entry of message - ; IBTYP = the number that is the last digit in the message type - ; - N ZTSK,ZTDESC,ZTIO,ZTDTH,ZTSAVE,DA,DR,DIE - S ZTIO="",ZTDTH=$H,ZTDESC="UPDATE DATA BASE FROM EDI RETURN MESSAGE",ZTSAVE("IB*")="",ZTRTN=IBRTN - D ^%ZTLOAD - I $G(ZTSK),$G(^IBA(364.2,IBTDA,0)) S DIE="^IBA(364.2,",DR=".11////"_ZTSK_";.06////U",DA=IBTDA D ^DIE - Q $G(ZTSK) - ; -LOCK(IBTDA) ; Attempt to lock message file entry IBTDA - ; Return 1 if successful, 0 if not able to lock - ; - N OK - S OK=1 - L +^IBA(364.2,IBTDA,0):5 - I '$T D - . I '$D(DIQUIET) W !,*7,"Another user is editing this entry ... try again later" D PAUSE^VALM1 - . S IBDA="",OK=0 - Q OK - ; +IBCEM ;ALB/TMP - 837 EDI RETURN MESSAGE PROCESSING ;17-APR-96 + ;;2.0;INTEGRATED BILLING;**137,191,155**;21-MAR-94 + Q + ; +UPD ; Update messages manually from messages list + N IBDA,IBOK,IBTDA,ZTSK,IBTSK,IBTYP,IBU,IBU1,IB0 + D FULL^VALM1 + D SEL(.IBDA,1) + S IBDA=$O(IBDA("")) + I IBDA="" G UPDQ + S IBTDA=+IBDA(IBDA) + I '$$LOCK(IBTDA) G UPDQ + S IB0=$G(^IBA(364.2,IBTDA,0)) + ; + I IB0="" D G UPDQ + . W !,*7,"Message ",IBDA," is no longer in return message file" S IBOK="" + . D PAUSE^VALM1 + I $P(IB0,U,11) S IBOK=1 D G:'IBOK UPDQ + . N ZTSK + . S ZTSK=$P(IB0,U,11) D STAT^%ZTLOAD Q:ZTSK(0)=0 ;Task not scheduled + . I "12"[ZTSK(1) W *7,!,"This message has already been scheduled for update. Task # is: ",$P(IB0,U,11) S IBOK="" D PAUSE^VALM1 + ; + I $P(IB0,U,6)=""!("UP"'[$P(IB0,U,6)) D G UPDQ + . W !,*7,"Message status ("_$$EXPAND^IBTRE(364.2,.06,$P(IB0,U,6))_") is not appropriate for this action" + . D PAUSE^VALM1 + ; + S IBTYP=$P($G(^IBE(364.3,+$P(IB0,U,2),0)),U) + S IBU=$S(IBTYP="REPORT":"MAILIT^IBCESRV2",IBTYP["837REC":"CON837^IBCESRV2",IBTYP["837REJ":"REJ837^IBCESRV2",IBTYP["835EOB":"EOB835^IBCESRV3",1:""),IBU1=$S(IBTYP["837":$E(IBTYP,$L(IBTYP)),1:2) + I IBU="" W !,*7,"This message has an invalid message type - can't update" D PAUSE^VALM1 G UPDQ + S IBTSK=$$TASK(IBU,$P(IB0,U,4),IBTDA,IBU1) + I IBTSK W !,"Update has been tasked (#",IBTSK,")" + I 'IBTSK W !,*7,"Update could not be tasked. Please try again later!!!" + D PAUSE^VALM1 + ; + D BLD^IBCEM1 +UPDQ I $G(IBTDA) L -^IBA(364.2,IBTDA,0) + S VALMBCK="R" + Q + ; +VP ; View/Print Return Messages + N DHD,DIC,FLDS,BY,FR,TO,DIR,Y,L,IBDA,IBTDA,IBBILLS + D FULL^VALM1,SEL(.IBDA,1) + S IBDA=$O(IBDA("")) + G:'IBDA VPQ + S IBTDA=$G(IBDA(IBDA)),IBBILLS="" + I $P($G(^IBA(364.2,IBTDA,0)),U,4),'$P(^(0),U,5) D + .S DIR(0)="YA",DIR("B")="NO",DIR("A")="Do you want to list all bills for this batch?: " D ^DIR K DIR + .I Y S IBBILLS=1 + S DHD=$S(IBBILLS:"[IBCEM MESSAGE LIST HDR]",1:""),DIC="^IBA(364.2,",FLDS=$S(IBBILLS:"[IBCEM MESSAGE LIST]",1:"[CAPTIONED]"),BY="@NUMBER",(FR,TO)=$G(IBDA(IBDA)),L=0 D EN1^DIP + D PAUSE^VALM1 +VPQ S VALMBCK="R" + Q + ; +SEL(IBDA,ONE) ; Select entry(s) from list + ; IBDA = array returned if selections made + ; IBDA(n)=ien of bill selected in file 399 + ; ONE = if set to 1, only one selection can be made at a time + N IB + K IBDA + D EN^VALM2($G(XQORNOD(0)),$S('$G(ONE):"",1:"S")) + S IBDA=0 F S IBDA=$O(VALMY(IBDA)) Q:'IBDA S IB=$G(^TMP("IBCEM-837DX",$J,IBDA)),IBDA(IBDA)=+$P(IB,U,2) + Q + ; +UPDEDI(IBDA,FUNC,NOCT) ; Update EDI files - cancel/resubmit/print as + ; resolution to message + ; IBDA = transmit bill ien # for bill + ; FUNC = "E" for edit/resubmit, "C" for cancel, "R" for resubmit not + ; from edit, "P" for print, "Z" for COB processed , "N" for no + ; further action needed-close record + ; NOCT = 1 if not necessary to update batch count, 0 if update needed + ; + N IB0,IBBA,IBBDA,IBCT,IBM,IBTDA,IBNEW,DA,DIE,DR,Z,IBTEXT,IBZ,IBIFN,IBSTAT + S IB0=$G(^IBA(364,+IBDA,0)),IBBA=$P(IB0,U,2) + Q:IB0="" S IBIFN=+IB0 + ; + S IBNEW=$S(FUNC="E"!(FUNC="R"):+$P($G(^IBA(364,+$$LAST364^IBCEF4(+IB0),0)),U,2),1:"") S:IBNEW=IBBA IBNEW="" + ; + S IBSTAT=$P(IB0,U,3) ; current status in file 364 + I '$F(".C.R.E.Z.","."_IBSTAT_".") D ; don't update if in final status + . S DR=".03////"_$S(FUNC="E":"R","NP"'[FUNC:FUNC,1:"Z")_";.04///NOW" S:FUNC="E"!(FUNC="R") DR=DR_$S(IBNEW:";.06////"_IBNEW,1:"") + . S DA=+IBDA,DIE="^IBA(364," D ^DIE ;Update the transmit bill record + . Q + ; + I IBBA D CKRES^IBCESRV2(IBBA) ;Update completely resubmitted flags + ; + I IBBA,(FUNC="P"!(IBNEW&'$G(NOCT))) D CTDOWN^IBCEM02(IBBA,1) ;If resubmitted in a new batch or printed, update old batch + ; + S IBTEXT(1)=" UPDATED BY: "_$$EXTERNAL^DILFD(361.02,.02,,+$G(DUZ)) + S IBTEXT(2)="ACTION USED: "_$S(FUNC="E":"BILL EDITED/RESUBMITTED",FUNC="C":"BILL CANCELED",FUNC="R":"BILL RESUBMITTED WITHOUT EDIT)",FUNC="P":"PRINT BILL",FUNC="Z":"PROCESS COB",1:"") + S IBTEXT(2)=$S(IBTEXT(2)="":"UNSPECIFIED",1:IBTEXT(2)_" - REVIEW MARKED AS COMPLETE") + S IBTEXT=2 + ; + ; Update file 361 + S IBZ=0 F S IBZ=$O(^IBM(361,"AERR",+IBDA,IBZ)) Q:'IBZ I $D(^IBM(361,IBZ,0)),$P(^(0),U,10)="",$P(^(0),U,9)<2 D + . S DIE="^IBM(361,",DR=".09////2;.1////"_$TR(FUNC,"RCEIBZPN","RCROOFOO"),DA=IBZ D ^DIE + . I FUNC'="","ECRPIBZ"[FUNC D ; Update review status, notes for message + .. D NOTECHG^IBCECSA2(IBZ,1,.IBTEXT) + ; + ; Update file 361.1 with the Cancel Status, to cancel All EOB's on file + I FUNC="C" D STAT^IBCEMU2(IBIFN,9,0) + ; + Q + ; +DEL ; Delete messages from messages list - locked with IB SUPERVISOR key + N IBDA,IBOK,IBTDA,IBTYP,IBU,IBU1,IB0,DIR,IBT,IBE,Z,X,Y,XMSUBJ,XMTO,XMBODY,XMDUZ + D FULL^VALM1 + S IBTDA=0 + I '$D(^XUSEC("IB SUPERVISOR",DUZ)) D G DELQ + . W !,"You don't have authority to use this action. See your supervisr for assistance" + . D PAUSE^VALM1 + D SEL(.IBDA,1) + S IBDA=$O(IBDA("")) + I IBDA="" G DELQ + W ! + S DIR(0)="YA",DIR("A",1)="This action will PERMANENTLY delete a return message from your system",DIR("A",2)="A bulletin will be sent to report the deletion",DIR("A",3)=" " + S DIR("A")="ARE YOU SURE YOU WANT TO CONTINUE? ",DIR("B")="NO" + D ^DIR K DIR + G:Y'=1 DELQ + S IBTDA=+IBDA(IBDA) + I '$$LOCK(IBTDA) G DELQ + S IB0=$G(^IBA(364.2,IBTDA,0)) + ; + I $P(IB0,U,11) S IBOK=1 D G:'IBOK DELQ + . N ZTSK + . S ZTSK=$P(IB0,U,11) D STAT^%ZTLOAD Q:ZTSK(0)=0 ;Task not scheduled + . I "12"[ZTSK(1) W *7,!,"This message is currently scheduled for update. Task # is: ",$P(IB0,U,11) S IBOK="" D PAUSE^VALM1 + ; + I $P(IB0,U,6)=""!("UP"'[$P(IB0,U,6)) D G DELQ + . W !,*7,"Message status ("_$$EXPAND^IBTRE(364.2,.06,$P(IB0,U,6))_") is not appropriate for this action" + . D PAUSE^VALM1 + ; + S DIR(0)="YA",DIR("A",1)=" ",DIR("A",2)="",$P(DIR("A",2),"*",54)="",DIR("A",3)="* This message is about to be PERMANENTLY deleted!! *",DIR("A",4)=DIR("A",2),DIR("A",5)=" " + S DIR("A")="ARE YOU STILL SURE YOU WANT TO CONTINUE? ",DIR("B")="NO" + W ! D ^DIR W ! K DIR + I Y'=1 W !!,"Nothing deleted" D PAUSE^VALM1 G DELQ + ; + K ^TMP("IBMSG",$J) + M ^TMP("IBMSG",$J)=^IBA(364.2,IBTDA) + D DELMSG^IBCESRV2(IBTDA) + I $D(^IBA(364.2,IBTDA)) D G DELQ + . W !,"Message not deleted - problem with delete" D PAUSE^VALM1 + ; + S IBT(1)="EDI return message #"_$P(IB0,U)_" has been deleted" + S IBT(2)=" " + S IBT(3)="DELETED BY: "_$P($G(^VA(200,+$G(DUZ),0)),U)_" "_$$FMTE^XLFDT($$NOW^XLFDT,2) + S Z=$$EXPAND^IBTRE(364.2,.06,$P(IB0,U,6)) S:Z="" Z="??" + S IBT(4)=" STATUS: "_$E(Z_$J("",11),1,11)_" MESSAGE TYPE: "_$P($G(^IBE(364.3,+$P(IB0,U,2),0)),U,5) + S IBT(5)=" MESSAGE #: "_$E($P(IB0,U)_$J("",11),1,11)_" STATUS DATE: "_$$FMTE^XLFDT($P($G(^TMP("IBMSG",$J,1)),U,3)) + S IBT(6)=" BATCH #: "_$E($P($G(^IBA(364.1,+$P(IB0,U,4),0)),U)_$J("",11),1,11)_" BILL #: "_$$EXPAND^IBTRE(364.2,.05,$P(IB0,U,5)) + S IBT(7)=" " + S IBT(8)="MESSAGE TEXT:",IBE=8 + S Z=0 F S Z=$O(^TMP("IBMSG",$J,2,Z)) Q:'Z S IBE=IBE+1,IBT(IBE)=$G(^(Z,0)) + S XMSUBJ="EDI MESSAGE DELETED",XMBODY="IBT",XMDUZ="",XMTO("I:G.IB EDI")="" + D SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO,,.XMZ) + ; + K ^TMP("IBMSG",$J) + ; + W !,"A bulletin has been sent to report this deletion",! + D PAUSE^VALM1 + ; + D BLD^IBCEM1 +DELQ L -^IBA(364.2,IBTDA,0) + S VALMBCK="R" + Q + ; +TASK(IBRTN,IBBDA,IBTDA,IBTYP) ; Schedule the task to update data base from message + ; IBRTN = routine to task + ; IBBDA = batch # associated with the message (OPTIONAL) + ; IBTDA = internal entry of message + ; IBTYP = the number that is the last digit in the message type + ; + N ZTSK,ZTDESC,ZTIO,ZTDTH,ZTSAVE,DA,DR,DIE + S ZTIO="",ZTDTH=$H,ZTDESC="UPDATE DATA BASE FROM EDI RETURN MESSAGE",ZTSAVE("IB*")="",ZTRTN=IBRTN + D ^%ZTLOAD + I $G(ZTSK),$G(^IBA(364.2,IBTDA,0)) S DIE="^IBA(364.2,",DR=".11////"_ZTSK_";.06////U",DA=IBTDA D ^DIE + Q $G(ZTSK) + ; +LOCK(IBTDA) ; Attempt to lock message file entry IBTDA + ; Return 1 if successful, 0 if not able to lock + ; + N OK + S OK=1 + L +^IBA(364.2,IBTDA,0):5 + I '$T D + . I '$D(DIQUIET) W !,*7,"Another user is editing this entry ... try again later" D PAUSE^VALM1 + . S IBDA="",OK=0 + Q OK + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEM4.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEM4.m index 88b737d8..d2ab05df 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEM4.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEM4.m @@ -1,146 +1,146 @@ -IBCEM4 ;ALB/TMP - IB ELECTRONIC MESSAGE SCREEN TEXT MAINT ;19-APR-2001 - ;;2.0;INTEGRATED BILLING;**137,368**;21-MAR-1994;Build 21 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -EN ; entry point for maintenance - D EN^VALM("IBCE MESSAGE TEXT MAIN") - Q - ; -HDR ; Header code - K VALMHDR - Q - ; -INIT ; Build list of text entries - N Z,Z0 - S (IBCNT,VALMCNT)=0,VALMBG=1 - K ^TMP("IBCEMSGT",$J) - S Z="" F S Z=$O(^IBE(361.3,"AC",Z),-1) Q:Z="" D SET(Z) S Z0="" F S Z0=$O(^IBE(361.3,"AC",Z,Z0)) Q:Z0="" D SET(Z,Z0) - Q - ; -EXIT ; -- Clean up list - K ^TMP("IBCEMSGT",$J) - D CLEAN^VALM10 - Q - ; -SET(Z,Z0) ; Set data into display global - N X,IB - S IBCNT=IBCNT+1,X="",IB="" - S:$G(Z0)'="" Z0=" "_Z0 - I $G(Z0)="" D - . S Z0=$S('Z:"*** DO NOT REQUIRE REVIEW ***",1:"*** REQUIRE REVIEW ***"),IB=$J("",(80-$L(Z0))\2),Z0=IB_Z0 - . I 'Z D SET(Z," ") - I Z0'="" S X=$$SETFLD^VALM1(Z0,X,"TEXT") - S VALMCNT=VALMCNT+1,^TMP("IBCEMSGT",$J,VALMCNT,0)=X - S ^TMP("IBCEMSGT",$J,"IDX",VALMCNT,IBCNT)="" - I IB'="" D CNTRL^VALM10(VALMCNT,2+$L(IB),$L(Z0)-$L(IB),IORVON,IORVOFF) - Q -EDIT ; Add/edit message text - N DA,DIC,DLAYGO,DIE,DR,DIR,X,Y,IBUPD,IBSTOP,IBY - D FULL^VALM1 - S (IBSTOP,IBUPD)=0 - F D Q:IBSTOP - . S DIC(0)="AELMQ",DLAYGO=361.3,DIC="^IBE(361.3,",DIC("DR")="@1;.02;I X="""" W !,""MUST HAVE A VALUE FOR THIS FIELD"" S Y=""@1""" W ! D ^DIC - . S IBY=Y - . I IBY'>0 S IBSTOP=1 Q - . I $P(IBY,U,3) S IBUPD=1 Q - . S DIC="^IBE(361.3,",DA=+IBY W ! D EN^DIQ W ! - . S DIE="^IBE(361.3,",DA=+IBY,DR=".01" D ^DIE ; edit - . I '$D(^IBE(361.3,+IBY,0)) S IBUPD=1 Q - . I $P(IBY,U,2)'=$P(^IBE(361.3,+IBY,0),U) S IBUPD=1,DIE="^IBE(361.3,",DR=".05////"_$G(DUZ)_";.06///^S X=""NOW""" D ^DIE - D:IBUPD INIT - S VALMBCK="R" - Q - ; -CKREVU(IBTEXT,IBNR,IBSKIP,IBREV) ; Check IBTEXT contains 'no review - ; needed' text - ; IBNR = returned if passed by reference - 'no review needed' text found - ; IBSKIP = 1 if no check needed for 'always review' - ; IBREV = returned if passed by reference and 'review always needed' - ; text found - ; - N T,Y,Z,Z0 - S (IBREV,Y)=0,Z="",IBTEXT=$$UP^XLFSTR($G(IBTEXT)) - I '$G(IBSKIP) F S Z=$O(^IBE(361.3,"AC",1,Z)) Q:Z="" I IBTEXT[$$UP^XLFSTR(Z) S IBREV=1 Q ; Always review messages with this text - I 'IBREV S Z="" F S Z=$O(^IBE(361.3,"AC",0,Z)) Q:Z="" I IBTEXT[$$UP^XLFSTR(Z) S Y=1,IBNR=Z Q ; Message contains text to make review unnecessary - Q Y - ; -REPORT ; Produce a report of messages filed without review by user-selected - ; date range for date received and sort by either bill# or message text - N IBFR,IBTO,IBSORT,DIR,DA,DR,X,Y,ZTSAVE,ZTRTN,ZTDESC,ZTREQ -R1 S DIR("A")="FROM DATE RECEIVED: ",DIR(0)="DA^:"_DT_"::PAXE" D ^DIR K DIR - Q:$D(DTOUT)!$D(DUOUT) - S IBFR=Y W " ",$G(Y(0)) -R2 S DIR("A")="TO DATE RECEIVED: ",DIR(0)="DAO^"_IBFR_":"_DT_"::PAE" D ^DIR K DIR - Q:$D(DTOUT)!$D(DUOUT) - I Y'>0 W ! G R1 - S IBTO=Y W " ",$G(Y(0)) - S DIR("A")="SORT BY",DIR(0)="SXBO^B:Bill #;M:Message Screen Text",DIR("B")="B" D ^DIR K DIR - Q:$D(DTOUT)!$D(DUOUT) - I (Y="")!("BM"'[Y) W ! G R2 - S IBSORT=Y - S %ZIS="QM" D ^%ZIS Q:POP - I $D(IO("Q")) K IO("Q") S ZTRTN="ENRPT^IBCEM4",ZTSAVE("IB*")="",ZTDESC="IB - MESSAGES FILED WITHOUT REVIEW REPORT" D ^%ZTLOAD K ZTSK D HOME^%ZIS Q - U IO -ENRPT ; Queued job entrypoint - N IB,IB0,IBDA,IB00,IB1,IBS1,IBPAGE,IBLINES,IBHDRDT,IBSB,IBSTOP,DIR,Y,X,Z - W:$E(IOST,1,2)["C-" @IOF ;Only initial form feed for print to screen - K ^TMP($J,"IBSORT") - S IB=IBFR-.000001 - F S IB=$O(^IBM(361,"ARD",IB)) Q:'IB!$G(ZTSTOP) S IBDA=0 F S IBDA=$O(^IBM(361,"ARD",IB,IBDA)) Q:'IBDA!$G(ZTSTOP) S IB0=$G(^IBM(361,IBDA,0)) Q:IB0=""!'$P(IB0,U,14) D - . I $D(ZTQUEUED) Q:$$STOP(.ZTREQ,.ZTSTOP) - . S IBS1="" - . I IBSORT="M" D ; Find text that caused auto-file - .. S Z=0 F S Z=$O(^IBM(361,IBDA,1,Z)) Q:'Z I $$CKREVU($G(^IBM(361,IBDA,1,Z,0)),.IBS1,1) Q - .. I IBS1="" S IBS1="??" - . I IBSORT="B" S IBS1=$P($G(^DGCR(399,+IB0,0)),U) - . I IBS1'="" S ^TMP($J,"IBSORT",IBS1,IBDA)=IB0 - S IBHDRDT=$$FMTE^XLFDT($$NOW^XLFDT(),"2P") - S (IBSTOP,IBLINES,IBPAGE)=0 - S IB1=1,IB="" F S IB=$O(^TMP($J,"IBSORT",IB)) Q:IB=""!$G(ZTSTOP) D Q:IBSTOP - . S IBSB=$S(IBSORT="M":"MESSAGE SCREEN TEXT: "_IB,1:"") - . I IBSB'="" S IBSB=$J("",(80-$L(IBSB)\2))_IBSB - . D:IB1 RHDR(IBSB,.IBSTOP) Q:IBSTOP - . I 'IB1,IBSORT="M" D Q:IBSTOP - .. I IBLINES>(IOSL-5) D RHDR(IBSB,.IBSTOP) Q - .. W !!,IBSB,! S IBLINES=IBLINES+3 - . S (IB1,IBDA)=0 F S IBDA=$O(^TMP($J,"IBSORT",IB,IBDA)) Q:'IBDA!$G(ZTSTOP) D Q:IBSTOP - .. I $D(ZTQUEUED),$$STOP(.ZTREQ,.ZTSTOP) W !,"*********** REPORT STOPPED BEFORE IT COMPLETED!!! ***********" Q - .. S IB0=$G(^TMP($J,"IBSORT",IB,IBDA)),IB00=$G(^DGCR(399,+IB0,0)) - .. I $G(IBLINES)>(IOSL-5) D RHDR("",.IBSTOP) Q:IBSTOP - .. W !,$E($$BN1^PRCAFN(+IB0)_$J("",10),1,10)," ",$E($P($G(^DPT(+$P(IB00,U,2),0)),U)_$J("",25),1,25)_" "_$E($$FMTE^XLFDT($P(IB00,U,3),"2D")_$J("",8),1,8)_" "_$E($$FMTE^XLFDT($P(IB0,U,2),"2D")_$J("",8),1,8)_" " - .. W $E($P($G(^DIC(36,+$$POLICY^IBCEF(+IB0,1,$P(IB0,U,7)),0)),U),1,20) - .. S IBLINES=IBLINES+1 - .. I $G(IBLINES)>(IOSL-5) D RHDR("",.IBSTOP) Q:IBSTOP - .. S Z=0 F S Z=$O(^IBM(361,IBDA,1,Z)) Q:'Z D Q:IBSTOP - ... N Z0,Z1 - ... S Z0=$G(^IBM(361,IBDA,1,Z,0)) - ... F Z1=1:75:$L(Z0) D:$G(IBLINES)>(IOSL-5) RHDR("",.IBSTOP) Q:IBSTOP W !,?5,$E(Z0,Z1,Z1+74) S IBLINES=IBLINES+1 - G:IBSTOP!$G(ZTSTOP) ENSTOP - I $G(IB1) D RHDR("") W !,"NO RECORDS MATCHING SEARCH CRITERIA WERE FOUND",! - ; - I $E(IOST,1,2)["C-" K DIR S DIR(0)="E" D ^DIR K DIR -ENSTOP I '$D(ZTQUEUED) D ^%ZISC - I $D(ZTQUEUED),'$G(ZTSTOP) S ZTREQ="@" - K ^TMP($J,"IBSORT") - Q - ; -RHDR(IBSB,IBSTOP) ; Report header - ; IBSB'="" if sub header should print - N Z,DIR,X,Y - S IBPAGE=IBPAGE+1 - I IBPAGE>1,$E(IOST,1,2)["C-" S DIR(0)="E" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S IBSTOP=1 G RHDRQ - W !,@IOF - W !,?22,"MESSAGES FILED WITHOUT REVIEW REPORT",?65,"PAGE: ",IBPAGE - S Z="RUN DATE: "_IBHDRDT W !,?(80-$L(Z)\2),Z - S Z="DATE RECEIVED RANGE: "_$$FMTE^XLFDT(IBFR,"2D")_"-"_$$FMTE^XLFDT(IBTO,"2D") W !,?(80-$L(Z)\2),Z,! - W !,$J("",40),"EVENT DATE" - W !,"BILL # PATIENT NAME"_$J("",15)_" DATE RECEIVED INSURANCE CO",! - S Z="",$P(Z,"-",81)="" W Z - S IBLINES=7 - I $G(IBSB)'="" W !,IBSB,! S IBLINES=IBLINES+2 -RHDRQ Q - ; -STOP(IBSTOP,IBREQ) ; Check for job being stopped - I $$S^%ZTLOAD S IBSTOP=1 K IBREQ - Q $G(IBSTOP) - ; +IBCEM4 ;ALB/TMP - IB ELECTRONIC MESSAGE SCREEN TEXT MAINT ;19-APR-2001 + ;;2.0;INTEGRATED BILLING;**137**;21-MAR-1994 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; +EN ; entry point for maintenance + D EN^VALM("IBCE MESSAGE TEXT MAIN") + Q + ; +HDR ; Header code + K VALMHDR + Q + ; +INIT ; Build list of text entries + N Z,Z0 + S (IBCNT,VALMCNT)=0,VALMBG=1 + K ^TMP("IBCEMSGT",$J) + S Z="" F S Z=$O(^IBE(361.3,"AC",Z),-1) Q:Z="" D SET(Z) S Z0="" F S Z0=$O(^IBE(361.3,"AC",Z,Z0)) Q:Z0="" D SET(Z,Z0) + Q + ; +EXIT ; -- Clean up list + K ^TMP("IBCEMSGT",$J) + D CLEAN^VALM10 + Q + ; +SET(Z,Z0) ; Set data into display global + N X,IB + S IBCNT=IBCNT+1,X="",IB="" + S:$G(Z0)'="" Z0=" "_Z0 + I $G(Z0)="" D + . S Z0=$S('Z:"*** DO NOT REQUIRE REVIEW ***",1:"*** REQUIRE REVIEW ***"),IB=$J("",(80-$L(Z0))\2),Z0=IB_Z0 + . I 'Z D SET(Z," ") + I Z0'="" S X=$$SETFLD^VALM1(Z0,X,"TEXT") + S VALMCNT=VALMCNT+1,^TMP("IBCEMSGT",$J,VALMCNT,0)=X + S ^TMP("IBCEMSGT",$J,"IDX",VALMCNT,IBCNT)="" + I IB'="" D CNTRL^VALM10(VALMCNT,2+$L(IB),$L(Z0)-$L(IB),IORVON,IORVOFF) + Q +EDIT ; Add/edit message text + N DA,DIC,DLAYGO,DIE,DR,DIR,X,Y,IBUPD,IBSTOP,IBY + D FULL^VALM1 + S (IBSTOP,IBUPD)=0 + F D Q:IBSTOP + . S DIC(0)="AELMQ",DLAYGO=361.3,DIC="^IBE(361.3,",DIC("DR")="@1;.02;I X="""" W !,""MUST HAVE A VALUE FOR THIS FIELD"" S Y=""@1""" W ! D ^DIC + . S IBY=Y + . I IBY'>0 S IBSTOP=1 Q + . I $P(IBY,U,3) S IBUPD=1 Q + . S DIC="^IBE(361.3,",DA=+IBY W ! D EN^DIQ W ! + . S DIE="^IBE(361.3,",DA=+IBY,DR=".01" D ^DIE ; edit + . I '$D(^IBE(361.3,+IBY,0)) S IBUPD=1 Q + . I $P(IBY,U,2)'=$P(^IBE(361.3,+IBY,0),U) S IBUPD=1,DIE="^IBE(361.3,",DR=".05////"_$G(DUZ)_";.06///^S X=""NOW""" D ^DIE + D:IBUPD INIT + S VALMBCK="R" + Q + ; +CKREVU(IBTEXT,IBNR,IBSKIP,IBREV) ; Check IBTEXT contains 'no review + ; needed' text + ; IBNR = returned if passed by reference - 'no review needed' text found + ; IBSKIP = 1 if no check needed for 'always review' + ; IBREV = returned if passed by reference and 'review always needed' + ; text found + ; + N T,Y,Z,Z0 + S (IBREV,Y)=0,Z="" + I '$G(IBSKIP) F S Z=$O(^IBE(361.3,"AC",1,Z)) Q:Z="" I IBTEXT[Z S IBREV=1 Q ; Always review messages with this text + I 'IBREV S Z="" F S Z=$O(^IBE(361.3,"AC",0,Z)) Q:Z="" I IBTEXT[Z S Y=1,IBNR=Z Q ; Message contains text to make review unnecessary + Q Y + ; +REPORT ; Produce a report of messages filed without review by user-selected + ; date range for date received and sort by either bill# or message text + N IBFR,IBTO,IBSORT,DIR,DA,DR,X,Y,ZTSAVE,ZTRTN,ZTDESC,ZTREQ +R1 S DIR("A")="FROM DATE RECEIVED: ",DIR(0)="DA^:"_DT_"::PAXE" D ^DIR K DIR + Q:$D(DTOUT)!$D(DUOUT) + S IBFR=Y W " ",$G(Y(0)) +R2 S DIR("A")="TO DATE RECEIVED: ",DIR(0)="DAO^"_IBFR_":"_DT_"::PAE" D ^DIR K DIR + Q:$D(DTOUT)!$D(DUOUT) + I Y'>0 W ! G R1 + S IBTO=Y W " ",$G(Y(0)) + S DIR("A")="SORT BY",DIR(0)="SXBO^B:Bill #;M:Message Screen Text",DIR("B")="B" D ^DIR K DIR + Q:$D(DTOUT)!$D(DUOUT) + I (Y="")!("BM"'[Y) W ! G R2 + S IBSORT=Y + S %ZIS="QM" D ^%ZIS Q:POP + I $D(IO("Q")) K IO("Q") S ZTRTN="ENRPT^IBCEM4",ZTSAVE("IB*")="",ZTDESC="IB - MESSAGES FILED WITHOUT REVIEW REPORT" D ^%ZTLOAD K ZTSK D HOME^%ZIS Q + U IO +ENRPT ; Queued job entrypoint + N IB,IB0,IBDA,IB00,IB1,IBS1,IBPAGE,IBLINES,IBHDRDT,IBSB,IBSTOP,DIR,Y,X,Z + W:$E(IOST,1,2)["C-" @IOF ;Only initial form feed for print to screen + K ^TMP($J,"IBSORT") + S IB=IBFR-.000001 + F S IB=$O(^IBM(361,"ARD",IB)) Q:'IB!$G(ZTSTOP) S IBDA=0 F S IBDA=$O(^IBM(361,"ARD",IB,IBDA)) Q:'IBDA!$G(ZTSTOP) S IB0=$G(^IBM(361,IBDA,0)) Q:IB0=""!'$P(IB0,U,14) D + . I $D(ZTQUEUED) Q:$$STOP(.ZTREQ,.ZTSTOP) + . S IBS1="" + . I IBSORT="M" D ; Find text that caused auto-file + .. S Z=0 F S Z=$O(^IBM(361,IBDA,1,Z)) Q:'Z I $$CKREVU($G(^IBM(361,IBDA,1,Z,0)),.IBS1,1) Q + .. I IBS1="" S IBS1="??" + . I IBSORT="B" S IBS1=$P($G(^DGCR(399,+IB0,0)),U) + . I IBS1'="" S ^TMP($J,"IBSORT",IBS1,IBDA)=IB0 + S IBHDRDT=$$FMTE^XLFDT($$NOW^XLFDT(),"2P") + S (IBSTOP,IBLINES,IBPAGE)=0 + S IB1=1,IB="" F S IB=$O(^TMP($J,"IBSORT",IB)) Q:IB=""!$G(ZTSTOP) D Q:IBSTOP + . S IBSB=$S(IBSORT="M":"MESSAGE SCREEN TEXT: "_IB,1:"") + . I IBSB'="" S IBSB=$J("",(80-$L(IBSB)\2))_IBSB + . D:IB1 RHDR(IBSB,.IBSTOP) Q:IBSTOP + . I 'IB1,IBSORT="M" D Q:IBSTOP + .. I IBLINES>(IOSL-5) D RHDR(IBSB,.IBSTOP) Q + .. W !!,IBSB,! S IBLINES=IBLINES+3 + . S (IB1,IBDA)=0 F S IBDA=$O(^TMP($J,"IBSORT",IB,IBDA)) Q:'IBDA!$G(ZTSTOP) D Q:IBSTOP + .. I $D(ZTQUEUED),$$STOP(.ZTREQ,.ZTSTOP) W !,"*********** REPORT STOPPED BEFORE IT COMPLETED!!! ***********" Q + .. S IB0=$G(^TMP($J,"IBSORT",IB,IBDA)),IB00=$G(^DGCR(399,+IB0,0)) + .. I $G(IBLINES)>(IOSL-5) D RHDR("",.IBSTOP) Q:IBSTOP + .. W !,$E($$BN1^PRCAFN(+IB0)_$J("",10),1,10)," ",$E($P($G(^DPT(+$P(IB00,U,2),0)),U)_$J("",25),1,25)_" "_$E($$FMTE^XLFDT($P(IB00,U,3),"2D")_$J("",8),1,8)_" "_$E($$FMTE^XLFDT($P(IB0,U,2),"2D")_$J("",8),1,8)_" " + .. W $E($P($G(^DIC(36,+$$POLICY^IBCEF(+IB0,1,$P(IB0,U,7)),0)),U),1,20) + .. S IBLINES=IBLINES+1 + .. I $G(IBLINES)>(IOSL-5) D RHDR("",.IBSTOP) Q:IBSTOP + .. S Z=0 F S Z=$O(^IBM(361,IBDA,1,Z)) Q:'Z D Q:IBSTOP + ... N Z0,Z1 + ... S Z0=$G(^IBM(361,IBDA,1,Z,0)) + ... F Z1=1:75:$L(Z0) D:$G(IBLINES)>(IOSL-5) RHDR("",.IBSTOP) Q:IBSTOP W !,?5,$E(Z0,Z1,Z1+74) S IBLINES=IBLINES+1 + G:IBSTOP!$G(ZTSTOP) ENSTOP + I $G(IB1) D RHDR("") W !,"NO RECORDS MATCHING SEARCH CRITERIA WERE FOUND",! + ; + I $E(IOST,1,2)["C-" K DIR S DIR(0)="E" D ^DIR K DIR +ENSTOP I '$D(ZTQUEUED) D ^%ZISC + I $D(ZTQUEUED),'$G(ZTSTOP) S ZTREQ="@" + K ^TMP($J,"IBSORT") + Q + ; +RHDR(IBSB,IBSTOP) ; Report header + ; IBSB'="" if sub header should print + N Z,DIR,X,Y + S IBPAGE=IBPAGE+1 + I IBPAGE>1,$E(IOST,1,2)["C-" S DIR(0)="E" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S IBSTOP=1 G RHDRQ + W !,@IOF + W !,?22,"MESSAGES FILED WITHOUT REVIEW REPORT",?65,"PAGE: ",IBPAGE + S Z="RUN DATE: "_IBHDRDT W !,?(80-$L(Z)\2),Z + S Z="DATE RECEIVED RANGE: "_$$FMTE^XLFDT(IBFR,"2D")_"-"_$$FMTE^XLFDT(IBTO,"2D") W !,?(80-$L(Z)\2),Z,! + W !,$J("",40),"EVENT DATE" + W !,"BILL # PATIENT NAME"_$J("",15)_" DATE RECEIVED INSURANCE CO",! + S Z="",$P(Z,"-",81)="" W Z + S IBLINES=7 + I $G(IBSB)'="" W !,IBSB,! S IBLINES=IBLINES+2 +RHDRQ Q + ; +STOP(IBSTOP,IBREQ) ; Check for job being stopped + I $$S^%ZTLOAD S IBSTOP=1 K IBREQ + Q $G(IBSTOP) + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEMCA2.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEMCA2.m index d3ee1c25..ab1020b6 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEMCA2.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEMCA2.m @@ -1,122 +1,113 @@ -IBCEMCA2 ;ALB/ESG - Multiple CSA Message Management - Actions ;20-SEP-2005 - ;;2.0;INTEGRATED BILLING;**320,377**;21-MAR-1994;Build 23 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - Q - ; -CANCEL ; mass claim cancel - NEW NS,IBIFN,NSC,DIR,X,Y,DUOUT,DTOUT,DIRUT,DIROUT,IBDA,IB364,DISP,IBCE - NEW IBMCSRSC,IBMCSRNB,IBMCSCNT,IBMCSTOT,IBMCSTOP,IBMCSCAN,MRACHK,IBCAN,IBMCSCAC - D FULL^VALM1 - ; - I '$$KCHK^XUSRB("IB AUTHORIZE") D G CANCELX - . W !!?5,"You don't hold the proper security key to access this option." - . W !?5,"The necessary key is IB AUTHORIZE. Please see your manager." - . D PAUSE^VALM1 - . Q - ; - S NS=+$G(^TMP($J,"IBCEMCL",4)) - I 'NS D G CANCELX - . W !!?5,"There are no selected messages." D PAUSE^VALM1 - . Q - ; - ; count number of claims too - S IBIFN=0 F NSC=0:1 S IBIFN=$O(^TMP($J,"IBCEMCL",4,2,IBIFN)) Q:'IBIFN - ; - W !!?5,"Number of messages selected: ",NS - W !?7,"Number of claims selected: ",NSC - W !!,"In order to cancel " - W $S(NSC=1:"this claim",1:"these claims") - W ", a Reason Cancelled and a Reason Not Billable" - W !,"are required. You may also provide an optional CT Additional Comment." - W !,"These will be used as the default responses for " - W $S(NSC=1:"this claim",1:"all claims") - W "." - ; -CANQ1 ; reader call for the Reason Cancelled field - W ! - S DIR(0)="399,19" - S DIR("A")="Reason Cancelled" - D ^DIR K DIR - I X="",Y="" W *7,!,"This is a required response. Enter '^' to exit." G CANQ1 - I $D(DIRUT) G CANCELX - M IBMCSRSC=Y ; save the entered text for reason cancelled - ; -CANQ2 ; reader call for the reason not billable field - W ! - S DIR(0)="356,.19" - S DIR("A")="Reason Not Billable" - D ^DIR K DIR - I X="",Y="" W *7,!,"This is a required response. Enter '^' to exit." G CANQ2 - I $D(DIRUT) G CANCELX - M IBMCSRNB=Y ; save the reason not billable code/desc - ; -CANQ3 ; reader call for the Claims Tracking Additional Comment field - W ! - S DIR(0)="356,1.08O" - S DIR("A")="CT Additional Comment" - D ^DIR K DIR - I $D(DIRUT) G CANCELX - M IBMCSCAC=Y - ; - W ! - S DIR(0)="YO" - S DIR("A")="OK to proceed into the cancel claim loop",DIR("B")="No" - D ^DIR K DIR - I Y'=1 G CANCELX - ; - S IBIFN=0,IBMCSCNT=0,IBMCSTOT=NSC,IBMCSTOP=0 - F S IBIFN=$O(^TMP($J,"IBCEMCL",4,2,IBIFN)) Q:'IBIFN D Q:IBMCSTOP - . S IBMCSCNT=IBMCSCNT+1 - . S IBDA=+$O(^TMP($J,"IBCEMCL",4,2,IBIFN,""),-1) ; most recent 361 ien - . S IB364=+$P($G(^IBM(361,IBDA,0)),U,11) ; transmit bill 364 ien - . W !!," *** Processing MCS claim# ",IBMCSCNT," of ",IBMCSTOT," ***" - . S DISP=$$DISP^IBCEM3(IBIFN,"cancel","",1,.DIRUT) - . ; - . I $D(DIRUT) D Q ; up arrow or time-out - .. N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT - .. S DIR(0)="YO" - .. S DIR("A")="Do you want to Exit this MCS cancel claim loop" - .. S DIR("B")="Yes" - .. W ! D ^DIR K DIR - .. I Y=1 S IBMCSTOP=1 ; Yes, exit out altogether - .. Q - . ; - . I 'DISP Q ; user said No to cancel - . ; - . I 'IBDA!'IB364 D Q - .. W !?4,"Cannot determine the EDI transmission record." - .. W !?4,"This claim can't be cancelled here." - .. D PAUSE^VALM1 - .. Q - . ; - . D MRACHK^IBCECSA4 I MRACHK Q - . ; - . ; set-up required variables for main call to cancel this claim - . S IBCAN=1,IBMCSCAN=1 - . S IBCE("EDI")=1 - . S Y=IBIFN - . D - .. ; protect variables to be restored after call to IBCC and - .. ; leftover junk variables from IBCC - .. NEW IBIFN,IBMCSTOP,IBMCSCNT,IBMCSTOT,IBCSAMCS - .. NEW IBCCCC,IBCCR,IBQUIT,NAME,POP,RDATES,COL,CTRLCOL,FINISH - .. D NOPTF^IBCC - .. Q - . Q - ; - I IBMCSTOP W !!?5,"MCS cancel loop aborted." - I 'IBMCSTOP W !!?5,"Done with MCS cancel loop!" - D PAUSE^VALM1 - ; - ; rebuild the list - KILL ^TMP($J,"IBCEMCA"),VALMHDR - S VALMBG=1 - D UNLOCK^IBCEMCL - D INIT^IBCEMCL - I $G(IBCSAMCS)=1 S IBCSAMCS=2 ; flag to rebuild CSA - ; -CANCELX ; - S VALMBCK="R" - Q - ; +IBCEMCA2 ;ALB/ESG - Multiple CSA Message Management - Actions ;20-SEP-2005 + ;;2.0;INTEGRATED BILLING;**320**;21-MAR-1994 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; + Q + ; +CANCEL ; mass claim cancel + NEW NS,IBIFN,NSC,DIR,X,Y,DUOUT,DTOUT,DIRUT,DIROUT,IBDA,IB364,DISP,IBCE + NEW IBMCSRSC,IBMCSRNB,IBMCSCNT,IBMCSTOT,IBMCSTOP,IBMCSCAN,MRACHK,IBCAN + D FULL^VALM1 + ; + I '$$KCHK^XUSRB("IB AUTHORIZE") D G CANCELX + . W !!?5,"You don't hold the proper security key to access this option." + . W !?5,"The necessary key is IB AUTHORIZE. Please see your manager." + . D PAUSE^VALM1 + . Q + ; + S NS=+$G(^TMP($J,"IBCEMCL",4)) + I 'NS D G CANCELX + . W !!?5,"There are no selected messages." D PAUSE^VALM1 + . Q + ; + ; count number of claims too + S IBIFN=0 F NSC=0:1 S IBIFN=$O(^TMP($J,"IBCEMCL",4,2,IBIFN)) Q:'IBIFN + ; + W !!?5,"Number of messages selected: ",NS + W !?7,"Number of claims selected: ",NSC + W !!,"In order to cancel " + W $S(NSC=1:"this claim",1:"these claims") + W ", you must supply the Reason Cancelled and" + W !,"the Reason Not Billable. These will be the default responses for " + W $S(NSC=1:"this claim",1:"all claims") + W "." + ; +CANQ1 ; reader call for the Reason Cancelled field + W ! + S DIR(0)="399,19" + S DIR("A")="Reason Cancelled" + D ^DIR K DIR + I X="",Y="" W *7,!,"This is a required response. Enter '^' to exit." G CANQ1 + I $D(DIRUT) G CANCELX + M IBMCSRSC=Y ; save the entered text for reason cancelled + ; +CANQ2 ; reader call for the reason not billable field + W ! + S DIR(0)="356,.19" + S DIR("A")="Reason Not Billable" + D ^DIR K DIR + I X="",Y="" W *7,!,"This is a required response. Enter '^' to exit." G CANQ2 + I $D(DIRUT) G CANCELX + M IBMCSRNB=Y ; save the reason not billable code/desc + ; + W ! + S DIR(0)="YO" + S DIR("A")="OK to proceed into the cancel claim loop",DIR("B")="No" + D ^DIR K DIR + I Y'=1 G CANCELX + ; + S IBIFN=0,IBMCSCNT=0,IBMCSTOT=NSC,IBMCSTOP=0 + F S IBIFN=$O(^TMP($J,"IBCEMCL",4,2,IBIFN)) Q:'IBIFN D Q:IBMCSTOP + . S IBMCSCNT=IBMCSCNT+1 + . S IBDA=+$O(^TMP($J,"IBCEMCL",4,2,IBIFN,""),-1) ; most recent 361 ien + . S IB364=+$P($G(^IBM(361,IBDA,0)),U,11) ; transmit bill 364 ien + . W !!," *** Processing MCS claim# ",IBMCSCNT," of ",IBMCSTOT," ***" + . S DISP=$$DISP^IBCEM3(IBIFN,"cancel","",1,.DIRUT) + . ; + . I $D(DIRUT) D Q ; up arrow or time-out + .. N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT + .. S DIR(0)="YO" + .. S DIR("A")="Do you want to Exit this MCS cancel claim loop" + .. S DIR("B")="Yes" + .. W ! D ^DIR K DIR + .. I Y=1 S IBMCSTOP=1 ; Yes, exit out altogether + .. Q + . ; + . I 'DISP Q ; user said No to cancel + . ; + . I 'IBDA!'IB364 D Q + .. W !?4,"Cannot determine the EDI transmission record." + .. W !?4,"This claim can't be cancelled here." + .. D PAUSE^VALM1 + .. Q + . ; + . D MRACHK^IBCECSA4 I MRACHK Q + . ; + . ; set-up required variables for main call to cancel this claim + . S IBCAN=1,IBMCSCAN=1 + . S IBCE("EDI")=1 + . S Y=IBIFN + . D + .. ; protect variables to be restored after call to IBCC and + .. ; leftover junk variables from IBCC + .. NEW IBIFN,IBMCSTOP,IBMCSCNT,IBMCSTOT,IBCSAMCS + .. NEW IBCCCC,IBCCR,IBQUIT,NAME,POP,RDATES,COL,CTRLCOL,FINISH + .. D NOPTF^IBCC + .. Q + . Q + ; + I IBMCSTOP W !!?5,"MCS cancel loop aborted." + I 'IBMCSTOP W !!?5,"Done with MCS cancel loop!" + D PAUSE^VALM1 + ; + ; rebuild the list + KILL ^TMP($J,"IBCEMCA"),VALMHDR + S VALMBG=1 + D UNLOCK^IBCEMCL + D INIT^IBCEMCL + I $G(IBCSAMCS)=1 S IBCSAMCS=2 ; flag to rebuild CSA + ; +CANCELX ; + S VALMBCK="R" + Q + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEOB.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEOB.m index f164ff38..99489dfb 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEOB.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEOB.m @@ -1,249 +1,264 @@ -IBCEOB ;ALB/TMP - 835 EDI EOB MESSAGE PROCESSING ;20-JAN-99 - ;;2.0;INTEGRATED BILLING;**137,135,265,155,377**;21-MAR-94;Build 23 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - Q - ; -UPDEOB(IBTDA) ; Update EXPLANATION OF BENEFITS file (#361.1) from return msg - ; IBTDA = ien of return message - ; Function returns ien of EOB file entry or "" if errors found - ; the data. Any errors found are - ; stored in array ^TMP("IBCERR-EOB",$J,n) in text format - ; n = seq # and are stored with the EOB in a wp field - ; - N IB0,IB100,IBBTCH,IBE,IBMNUM,IBT,DLAYGO,DIC,DD,DO,X,Y,Z,Z0,Z1,IBEOB,IBBAD,IBOK,IB,IBA1,IBIFN,IBFILE - K ^TMP($J),^TMP("IBCERR-EOB",$J) - ; - S (IBBAD,IBEOB)="" - S IB0=$G(^IBA(364.2,IBTDA,0)) - S IBMNUM=+$P(IB0,U) - S X=+$G(^IBA(364,+$P(IB0,U,5),0)) - ; - G:$S(IBMNUM=""!(X=""):1,1:$D(^IBM(361.1,"AC",IBMNUM))) UPDQ - ; - ; Duplicate EOB Check - S IBFILE="^IBA(364.2,"_IBTDA_",2)" - I $$DUP(IBFILE,X) D DELMSG^IBCESRV2(IBTDA) G UPDQ - ; - I '$$LOCK^IBCEM(IBTDA) G UPDQ ;Lock msg file 364.2 - S IBEOB=+$$ADD3611(IBMNUM,$P(IB0,U,5),$P(IB0,U,4),X,0,IBFILE) - L -^IBA(364.2,IBTDA,0) - ; - I IBEOB<0 S IBEOB="" G UPDQ - D UPD3611(IBEOB,IBTDA,0) - ; -UPDQ I IBEOB,$O(^TMP("IBCERR-EOB",$J,0)) D ERRUPD(IBEOB,"IBCERR-EOB") - K ^TMP($J),^TMP("IBCERR-EOB",$J) - D CLEAN^DILF - Q +IBEOB - ; - ; - ; NOTE: **** For all variables IB0,IBEGBL,IBEOB below: - ; IB0 = raw data received for this record type on the 835 flat file - ; IBEGBL = subscript to use in error global - ; IBEOB = ien in file 361.1 for this EOB - ; -835(IB0,IBEGBL,IBEOB) ; Store header - ; - Q $$HDR^IBCEOB1(IB0,IBEGBL,IBEOB) - ; -5(IB0,IBEGBL,IBEOB) ; Record '05' - ; - N IBOK,DA,DR,DIE,X,Y - K IBZDATA - S DR=";",IBOK=1 - S DIE="^IBM(361.1,",DA=IBEOB - ; - I $P(IB0,U,9) S DR=DR_"1.1///"_$$DATE^IBCEU($P(IB0,U,9))_";" ; statement start date - I $P(IB0,U,10) S DR=DR_"1.11///"_$$DATE^IBCEU($P(IB0,U,10))_";" ; statement end date - S DR=$P(DR,";",2,$L(DR,";")-1) - I DR'="" D ^DIE S IBOK=$D(Y)=0 - I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad record 5 data" - Q IBOK - ; -6(IB0,IBEGBL,IBEOB) ; Record '06' - corrected patient name and/or ID# - ; This data is not going to be filed into file 361.1 so the value of this function will always be a 1 so as to - ; not interrupt the filing process of the EOB/MRA data into file 361.1. - ; - ; perform overall integrity checks on the incoming 06 record. If anything is out of place, don't update anything - ; and report the problem and get out. - NEW CLM,SITE,IBM,IBIFN,IBIFN1,DFN,SEQ,DIE,DA,DR - S DIE=361.1,DA=IBEOB,DR="61.01////^S X=IB0" D ^DIE ; archive the raw 06 record data - S CLM=$P(IB0,U,2),SITE=+CLM,CLM=$P(CLM,"-",2) I CLM="" D MSG(IBEOB,"The claim# in piece 2 is invalid.") G Q6 - S IBM=$G(^IBM(361.1,IBEOB,0)) - I $P(IBM,U,4)'=1 D MSG(IBEOB,"This is a non-Medicare EOB.") G Q6 - S IBIFN=+$P(IBM,U,1) ; claim# from MRA - S IBIFN1=+$O(^DGCR(399,"B",CLM,"")) ; claim# from 06 record - I IBIFN'=IBIFN1 D MSG(IBEOB,"Claim mismatch error."_IBIFN_","_IBIFN1_","_CLM_".") G Q6 - I $P($$SITE^VASITE,U,3)'=SITE D MSG(IBEOB,"Invalid station# mismatch."_$P($$SITE^VASITE,U,3)_","_SITE_".") G Q6 - S SEQ=$$COBN^IBCEF(IBIFN) ; current payer sequence# on claim - I '$$WNRBILL^IBEFUNC(IBIFN,SEQ) D MSG(IBEOB,"The current payer on this claim is not MEDICARE (WNR).") G Q6 - S DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2) ; patient ien - I 'DFN D MSG(IBEOB,"The patient DFN cannot be determined.") G Q6 - ; - D UPD^IBCEOB01(IB0,IBEOB,IBIFN,DFN,SEQ) ; update patient insurance policy data - ; -Q6 ; exit point for $$6 function - Q 1 - ; -10(IB0,IBEGBL,IBEOB) ; Record '10' - ; - N DA,DR,DIE,X,Y,VAL,IBOK - S DIE="^IBM(361.1,",DA=IBEOB - S DR=".13////"_$S($P(IB0,U,3)="Y":1,$P(IB0,U,4)="Y":2,$P(IB0,U,5)="Y":3,$P(IB0,U,6)="Y":4,1:5)_";.21////"_$P(IB0,U,7) - S DR=DR_";2.04////"_$$DOLLAR($P(IB0,U,10))_";1.01////"_$$DOLLAR($P(IB0,U,11))_$S($P(IB0,U,12)'="":";.14///"_$P(IB0,U,12),1:"") - S DR=DR_$S($P(IB0,U,13)'="":";.1///"_$P(IB0,U,13),1:"")_";.11///"_($P(IB0,U,14)/10000)_";.12///"_($P(IB0,U,15)/100) - I $P(IB0,U,8)'="" S DR=DR_";.08////"_$P(IB0,U,8)_$S($P(IB0,U,9)'="":";.09///"_$P(IB0,U,9),1:"") - ; - D ^DIE - S IBOK=($D(Y)=0) - I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad record 10 data" G Q10 - ; - ; File ICN in Bill - D ICN^IBCEOB00(IBEOB,$P(IB0,U,12),$P($G(^IBM(361.1,IBEOB,0)),U,15),.IBOK) - ; -Q10 Q IBOK - ; -15(IB0,IBEGBL,IBEOB) ; Record '15' - ; Moved due to space constraints -Q15 Q $$15^IBCEOB00(IB0,IBEGBL,IBEOB) - ; -17(IB0,IBEGBL,IBEOB) ; Record '17' - N A,IBOK - S A="3;25.01;0;1;0^4;25.02;0;1;0^5;25.03;0;1;0^6;25.04;0;1;0^7;25.05;0;1;0^8;25.06;0;1;0^9;25.07;0;1;0" - S IBOK=$$STORE^IBCEOB1(A,IB0,IBEOB) - I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad record 17 data" -Q17 Q IBOK - ; -20(IB0,IBEGBL,IBEOB) ; Record '20' - ; Moved due to space constraints -Q20 Q $$20^IBCEOB00(IB0,IBEGBL,IBEOB) - ; -30(IB0,IBEGBL,IBEOB) ; Record '30' - ; - N IBOK - D 30^IBCEOB0(IB0,IBEOB,.IBOK) -Q30 Q $G(IBOK) - ; -35(IB0,IBEGBL,IBEOB) ; Record '35' - ; Moved due to space constraints -Q35 Q $$35^IBCEOB00(IB0,IBEGBL,IBEOB) - ; -37(IB0,IBEGBL,IBEOB) ; Record '37' - ; Moved due to space constraints -Q37 Q $$37^IBCEOB00(IB0,IBEGBL,IBEOB) - ; -40(IB0,IBEGBL,IBEOB) ; Record '40' - ; - N IBOK - D 40^IBCEOB0(IB0,IBEOB,.IBOK) -Q40 Q $G(IBOK) - ; -41(IB0,IBEGBL,IBEOB) ; Record '41' - ; - N IBOK - D 41^IBCEOB0(IB0,IBEOB,.IBOK) -Q41 Q $G(IBOK) - ; -42(IB0,IBEGBL,IBEOB) ; Record '42' - ; - N IBOK - D 42^IBCEOB0(IB0,IBEOB,.IBOK) -Q42 Q $G(IBOK) - ; -45(IB0,IBEGBL,IBEOB) ; Record '45' - ; - N IBOK - D 45^IBCEOB0(IB0,IBEOB,.IBOK) - Q $G(IBOK) - ; -MSG(IBEOB,MSG) ; procedure to file message into field 6.03 - ; Results of processing of the "06" record type - N DIE,DA,DR,Z - S DIE=361.1,DA=+$G(IBEOB) - I $G(MSG)="" G MSGX - S Z=$P($G(^IBM(361.1,DA,6)),U,3) ; already existing message - I Z'="" S MSG=Z_" "_MSG ; append new message to existing message - S MSG=$E(MSG,1,190) - S DR="6.03///^S X=MSG" - D ^DIE -MSGX ; - Q - ; -DOLLAR(X) ; Convert value in X to dollar format XXX.XX - Q $S(+X:$J(X/100,$L(+X),2),1:0) - ; -ADD3611(IBMNUM,IBTBILL,IBBATCH,X,IBAR,IBFILE) ; Add stub record to file 361.1 - ; X = the ien of the referenced bill in file 399 - ; IBTBILL = ien of transmitted bill (optional) - ; IBBATCH = ien of batch # the transmitted bill was in (optional) - ; IBMNUM = the message # from which this record originally came - ; IBAR = 1 only if called from AR - ; IBFILE = array reference of raw EOB data - ; - N DIC,DA,DR,DO,DD,DLAYGO,Y,REVSTAT,BS,MMI - F L +^IBM(361.1,0):10 Q:$T - ; - ; default proper review status - S BS=$P($G(^DGCR(399,X,0)),U,13) ; bill status - S REVSTAT=$S(BS=7:9,BS=3:3,BS=4:3,1:0) - S MMI=$$NET^XMRENT(IBMNUM) ; MailMan header info - S DIC(0)="L",DIC="^IBM(361.1,",DLAYGO=361.1 - S DIC("DR")=".16////"_REVSTAT_";.17////0"_";100.02////"_IBMNUM_$S('$G(IBAR):";.19////"_+IBTBILL_";100.01////"_IBBATCH,1:"") - S DIC("DR")=DIC("DR")_";100.05////"_$$CHKSUM^IBCEMU1(IBFILE)_";62.01////^S X=MMI" - D FILE^DICN - L -^IBM(361.1,0) - Q +Y - ; -UPD3611(IBEOB,IBTDA,IBAR) ; From flat file 835 format, add EOB record - ; IBEOB = the ien of the entry in file 361.1 being updated - ; IBTDA = the ien in the source file - ; IBAR = 1 if being called from AR - N IBA1,IBFILE,IBEGBL,Z,IBREC,Q - S IBFILE=$S('$G(IBAR):"^IBA(364.2,"_IBTDA_",2)",1:"^TMP("_$J_",""RCDP-EOB"","_IBTDA_")") - S IBEGBL=$S('$G(IBAR):"IBCERR-EOB",1:"RCDPERR-EOB") - I $G(IBAR),'$$HDR^IBCEOB1($G(^TMP($J,"RCDPEOB","HDR")),IBEGBL,IBEOB) Q - S IBA1=0 - F S IBA1=$O(@IBFILE@(IBA1)) Q:'IBA1 S IB0=$S('$G(IBAR):$P($G(^(IBA1,0)),"##RAW DATA: ",2),1:$G(@IBFILE@(IBA1,0))) I IB0'="" D - . S IBREC=+IB0 - . I IBREC'=37 K ^TMP($J,37) - . I IBREC S IB="S IBOK=$$"_IBREC_"(IB0,IBEGBL,IBEOB)",Q=IBREC_"^IBCEOB" I $T(@Q)'="" X IB S:'IBOK ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)=$S('$G(IBAR):" ##RAW DATA: ",1:"")_IB0 - ; - Q - ; -ERRUPD(IBEOB,IBEGBL) ; Update error text in entry, if needed - D WP^DIE(361.1,IBEOB_",",20,"","^TMP(IBEGBL,$J)","") - Q - ; - ; -DUP(IBARRAY,IBIFN) ; Duplicate Check - ; This function determines if the EOB data already exists in file - ; 361.1 by comparing the checksums of the raw 835 data. - ; - ; IBARRAY = Literal array reference where the raw 835 data exists. - ; The data exists at @IBARRAY@(n,0), where n is the seq#. - ; For example, IBARRAY = "^IBA(364.2,IBIEN,2)" - ; - ; IBIFN = the bill # (ptr to 399). The checksums of the EOB's on - ; file for this bill will be compared to the checksum of the - ; 835 raw data in the IBARRAY reference. - ; - ; This function returns 0 if the entry is not found (no duplicate), - ; Otherwise, the IEN of the entry in file 361.1 is returned if this - ; is a duplicate EOB. - ; - NEW DUP,IBEOB,CHKSUM1,CHKSUM2 - S DUP=0,IBIFN=+$G(IBIFN) - I $G(IBARRAY)=""!'IBIFN G DUPX - I '$D(^IBM(361.1,"B",IBIFN)) G DUPX ; no EOB's on file yet - S CHKSUM1=$$CHKSUM^IBCEMU1(IBARRAY) ; checksum of current EOB - I 'CHKSUM1 G DUPX ; must be able to be calculated - S IBEOB=0 - F S IBEOB=$O(^IBM(361.1,"B",IBIFN,IBEOB)) Q:'IBEOB D Q:DUP - . S CHKSUM2=+$P($G(^IBM(361.1,IBEOB,100)),U,5) ; checksum of old EOB - . I 'CHKSUM2 Q - . I CHKSUM1=CHKSUM2 S DUP=IBEOB Q ; comparison - . Q -DUPX ; - Q DUP - ; +IBCEOB ;ALB/TMP - 835 EDI EOB MESSAGE PROCESSING ;20-JAN-99 + ;;2.0;INTEGRATED BILLING;**137,135,265,155**;21-MAR-94 + Q + ; +UPDEOB(IBTDA) ; Update EXPLANATION OF BENEFITS file (#361.1) from return msg + ; IBTDA = ien of return message + ; Function returns ien of EOB file entry or "" if errors found + ; the data. Any errors found are + ; stored in array ^TMP("IBCERR-EOB",$J,n) in text format + ; n = seq # and are stored with the EOB in a wp field + ; + N IB0,IB100,IBBTCH,IBE,IBMNUM,IBT,DLAYGO,DIC,DD,DO,X,Y,Z,Z0,Z1,IBEOB,IBBAD,IBOK,IB,IBA1,IBIFN,IBFILE + K ^TMP($J),^TMP("IBCERR-EOB",$J) + ; + S (IBBAD,IBEOB)="" + S IB0=$G(^IBA(364.2,IBTDA,0)) + S IBMNUM=+$P(IB0,U) + S X=+$G(^IBA(364,+$P(IB0,U,5),0)) + ; + G:$S(IBMNUM=""!(X=""):1,1:$D(^IBM(361.1,"AC",IBMNUM))) UPDQ + ; + ; Duplicate EOB Check + S IBFILE="^IBA(364.2,"_IBTDA_",2)" + I $$DUP(IBFILE,X) G UPDQ + ; + I '$$LOCK^IBCEM(IBTDA) G UPDQ ;Lock msg file 364.2 + S IBEOB=+$$ADD3611(IBMNUM,$P(IB0,U,5),$P(IB0,U,4),X,0,IBFILE) + L -^IBA(364.2,IBTDA,0) + ; + I IBEOB<0 S IBEOB="" G UPDQ + D UPD3611(IBEOB,IBTDA,0) + ; +UPDQ I IBEOB,$O(^TMP("IBCERR-EOB",$J,0)) D ERRUPD(IBEOB,"IBCERR-EOB") + K ^TMP($J),^TMP("IBCERR-EOB",$J) + D CLEAN^DILF + Q +IBEOB + ; + ; + ; NOTE: **** For all variables IB0,IBEGBL,IBEOB below: + ; IB0 = raw data received for this record type on the 835 flat file + ; IBEGBL = subscript to use in error global + ; IBEOB = ien in file 361.1 for this EOB + ; +835(IB0,IBEGBL,IBEOB) ; Store header + ; + Q $$HDR^IBCEOB1(IB0,IBEGBL,IBEOB) + ; +5(IB0,IBEGBL,IBEOB) ; Record '05' + ; + N IBOK,IBBULL,DA,DR,DIE,X,Y + K IBZDATA + S DR=";",IBOK=1 + S DIE="^IBM(361.1,",DA=IBEOB + ; + S IBBULL="" + I $$UPDNM^IBCEOB00(IBEOB,IB0,.IBBULL,.DR)!$$UPDID^IBCEOB00(IBEOB,IB0,.IBBULL,.DR) D ; New insured's name and/or HIC # found + . D CHGBULL^IBCEOB3(IBEOB,IBBULL) ;Send a bulletin reporting change + ; + I $P(IB0,U,9) S DR=DR_"1.1///"_$$DATE^IBCEU($P(IB0,U,9))_";" + I $P(IB0,U,10) S DR=DR_"1.11///"_$$DATE^IBCEU($P(IB0,U,10))_";" + S DR=$P(DR,";",2,$L(DR,";")-1) + I DR'="" D ^DIE S IBOK=$D(Y)=0 + I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad record 5 data" + Q IBOK + ; +10(IB0,IBEGBL,IBEOB) ; Record '10' + ; + N DA,DR,DIE,X,Y,VAL,IBOK + S DIE="^IBM(361.1,",DA=IBEOB + S DR=".13////"_$S($P(IB0,U,3)="Y":1,$P(IB0,U,4)="Y":2,$P(IB0,U,5)="Y":3,$P(IB0,U,6)="Y":4,1:5)_";.21////"_$P(IB0,U,7) + S DR=DR_";2.04////"_$$DOLLAR($P(IB0,U,10))_";1.01////"_$$DOLLAR($P(IB0,U,11))_$S($P(IB0,U,12)'="":";.14///"_$P(IB0,U,12),1:"") + S DR=DR_$S($P(IB0,U,13)'="":";.1///"_$P(IB0,U,13),1:"")_";.11///"_($P(IB0,U,14)/10000)_";.12///"_($P(IB0,U,15)/100) + I $P(IB0,U,8)'="" S DR=DR_";.08////"_$P(IB0,U,8)_$S($P(IB0,U,9)'="":";.09///"_$P(IB0,U,9),1:"") + ; + D ^DIE + S IBOK=($D(Y)=0) + I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad record 10 data" G Q10 + ; + ; File ICN in Bill + D ICN^IBCEOB00(IBEOB,$P(IB0,U,12),$P($G(^IBM(361.1,IBEOB,0)),U,15),.IBOK) + ; +Q10 Q IBOK + ; +15(IB0,IBEGBL,IBEOB) ; Record '15' + ; + N A,IBOK + ; + S A="3;1.03;1;0;0^4;1.04;1;0;0^5;1.05;1;0;0^6;1.07;1;0;0^7;1.08;1;0;0^8;1.09;1;0;0^9;1.02;1;0;0^10;2.05;1;0;0" + ; + S IBOK=$$STORE^IBCEOB1(A,IB0,IBEOB) + I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad record 15 data" G Q15 + ; + ; For Medicare MRA's only: + ; If the Covered Amount is present (15 record, piece 3), then file + ; a claim level adjustment with Group code=OA, Reason code=AB3. + ; + I $P($G(^IBM(361.1,IBEOB,0)),U,4)=1,+$P(IB0,U,3) D + . N IB20 + . S IB20=20_U_$P(IB0,U,2)_U_"OA"_U_"AB3"_U_$P(IB0,U,3)_U_"0000000000" + . S IB20=IB20_U_"Covered Amount" + . S IBOK=$$20(IB20,IBEGBL,IBEOB) + . I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Could not file the OA-AB3 claim level adjustment for the Covered Amount" + . K ^TMP($J,20) + . Q + ; +Q15 Q IBOK + ; +17(IB0,IBEGBL,IBEOB) ; Record '17' + N A,IBOK + S A="3;25.01;0;1;0^4;25.02;0;1;0^5;25.03;0;1;0^6;25.04;0;1;0^7;25.05;0;1;0^8;25.06;0;1;0^9;25.07;0;1;0" + S IBOK=$$STORE^IBCEOB1(A,IB0,IBEOB) + I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad record 17 data" +Q17 Q IBOK + ; +20(IB0,IBEGBL,IBEOB) ; Record '20' + ; + N A,LEVEL,IBGRP,IBDA,IBOK + ; + S IBGRP=$P(IB0,U,3) + I IBGRP'="" S ^TMP($J,20)=IBGRP + I IBGRP="" S IBGRP=$G(^TMP($J,20)) + I IBGRP="" S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Missing claim level adjustment group code" G Q20 + ; + S IBDA(1)=$O(^IBM(361.1,IBEOB,10,"B",IBGRP,0)) + ; + I 'IBDA(1) D ;Needs a new entry at group level + . N X,Y,DA,DD,DO,DIC,DLAYGO + . S DIC="^IBM(361.1,"_IBEOB_",10,",DIC(0)="L",DLAYGO=361.11,DA(1)=IBEOB + . S DIC("P")=$$GETSPEC^IBEFUNC(361.1,10) + . S X=IBGRP + . D FILE^DICN K DIC,DO,DD,DLAYGO + . I Y<0 K IBDA S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Adjustment group code could not be added" Q + . S IBDA(1)=+Y + ; + I $G(IBDA(1)) D ;Add a new entry at the reason code level + . S DIC="^IBM(361.1,"_IBEOB_",10,"_IBDA(1)_",1,",DIC(0)="L",DLAYGO=361.111,DA(2)=IBEOB,DA(1)=IBDA(1) + . S DIC("P")=$$GETSPEC^IBEFUNC(361.11,1) + . S X=$P(IB0,U,4) + . D FILE^DICN K DIC,DO,DD,DLAYGO + . I Y<0 K IBDA S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Adjustment reason code could not be added" Q + . S IBDA=+Y + ; + I $G(IBDA) D + . S LEVEL=10,LEVEL("DIE")="^IBM(361.1,"_IBEOB_",10,"_IBDA(1)_",1," + . S LEVEL(0)=IBDA,LEVEL(1)=IBDA(1),LEVEL(2)=IBEOB + . S A="5;.02;1;0;0^6;.03;0;1;1^7;.04;0;1;0" + . S IBOK=$$STORE^IBCEOB1(A,IB0,IBEOB,.LEVEL) + . I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad adjustment reason code ("_$P(IB0,U,4)_") data" Q +Q20 Q $G(IBOK) + ; +30(IB0,IBEGBL,IBEOB) ; Record '30' + ; + N IBOK + D 30^IBCEOB0(IB0,IBEOB,.IBOK) +Q30 Q $G(IBOK) + ; +35(IB0,IBEGBL,IBEOB) ; Record '35' + ; Moved due to space constraints +Q35 Q $$35^IBCEOB00(IB0,IBEGBL,IBEOB) + ; +37(IB0,IBEGBL,IBEOB) ; Record '37' + ; Moved due to space constraints +Q37 Q $$37^IBCEOB00(IB0,IBEGBL,IBEOB) + ; +40(IB0,IBEGBL,IBEOB) ; Record '40' + ; + N IBOK + D 40^IBCEOB0(IB0,IBEOB,.IBOK) +Q40 Q $G(IBOK) + ; +41(IB0,IBEGBL,IBEOB) ; Record '41' + ; + N IBOK + D 41^IBCEOB0(IB0,IBEOB,.IBOK) +Q41 Q $G(IBOK) + ; +42(IB0,IBEGBL,IBEOB) ; Record '42' + ; + N IBOK + D 42^IBCEOB0(IB0,IBEOB,.IBOK) +Q42 Q $G(IBOK) + ; +45(IB0,IBEGBL,IBEOB) ; Record '45' + ; + N IBOK + D 45^IBCEOB0(IB0,IBEOB,.IBOK) + Q $G(IBOK) + ; +DOLLAR(X) ; Convert value in X to dollar format XXX.XX + Q $S(+X:$J(X/100,$L(+X),2),1:0) + ; +ADD3611(IBMNUM,IBTBILL,IBBATCH,X,IBAR,IBFILE) ; Add stub record to file 361.1 + ; X = the ien of the referenced bill in file 399 + ; IBTBILL = ien of transmitted bill (optional) + ; IBBATCH = ien of batch # the transmitted bill was in (optional) + ; IBMNUM = the message # from which this record originally came + ; IBAR = 1 only if called from AR + ; IBFILE = array reference of raw EOB data + ; + N DIC,DA,DR,DO,DD,DLAYGO,Y,REVSTAT,BS + F L +^IBM(361.1,0):10 Q:$T + ; + ; default proper review status + S BS=$P($G(^DGCR(399,X,0)),U,13) ; bill status + S REVSTAT=$S(BS=7:9,BS=3:3,BS=4:3,1:0) + S DIC(0)="L",DIC="^IBM(361.1,",DLAYGO=361.1 + S DIC("DR")=".16////"_REVSTAT_";.17////0"_";100.02////"_IBMNUM_$S('$G(IBAR):";.19////"_+IBTBILL_";100.01////"_IBBATCH,1:"") + S DIC("DR")=DIC("DR")_";100.05////"_$$CHKSUM^IBCEMU1(IBFILE) + D FILE^DICN + L -^IBM(361.1,0) + Q +Y + ; +UPD3611(IBEOB,IBTDA,IBAR) ; From flat file 835 format, add EOB record + ; IBEOB = the ien of the entry in file 361.1 being updated + ; IBTDA = the ien in the source file + ; IBAR = 1 if being called from AR + N IBA1,IBFILE,IBEGBL,Z,IBREC,Q + S IBFILE=$S('$G(IBAR):"^IBA(364.2,"_IBTDA_",2)",1:"^TMP("_$J_",""RCDP-EOB"","_IBTDA_")") + S IBEGBL=$S('$G(IBAR):"IBCERR-EOB",1:"RCDPERR-EOB") + I $G(IBAR),'$$HDR^IBCEOB1($G(^TMP($J,"RCDPEOB","HDR")),IBEGBL,IBEOB) Q + S IBA1=0 + F S IBA1=$O(@IBFILE@(IBA1)) Q:'IBA1 S IB0=$S('$G(IBAR):$P($G(^(IBA1,0)),"##RAW DATA: ",2),1:$G(@IBFILE@(IBA1,0))) I IB0'="" D + . S IBREC=+IB0 + . I IBREC'=37 K ^TMP($J,37) + . I IBREC S IB="S IBOK=$$"_IBREC_"(IB0,IBEGBL,IBEOB)",Q=IBREC_"^IBCEOB" I $T(@Q)'="" X IB S:'IBOK ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)=$S('$G(IBAR):" ##RAW DATA: ",1:"")_IB0 + ; + Q + ; +ERRUPD(IBEOB,IBEGBL) ; Update error text in entry, if needed + D WP^DIE(361.1,IBEOB_",",20,"","^TMP(IBEGBL,$J)","") + Q + ; + ; +DUP(IBARRAY,IBIFN) ; Duplicate Check + ; This function determines if the EOB data already exists in file + ; 361.1 by comparing the checksums of the raw 835 data. + ; + ; IBARRAY = Literal array reference where the raw 835 data exists. + ; The data exists at @IBARRAY@(n,0), where n is the seq#. + ; For example, IBARRAY = "^IBA(364.2,IBIEN,2)" + ; + ; IBIFN = the bill # (ptr to 399). The checksums of the EOB's on + ; file for this bill will be compared to the checksum of the + ; 835 raw data in the IBARRAY reference. + ; + ; This function returns 0 if the entry is not found (no duplicate), + ; Otherwise, the IEN of the entry in file 361.1 is returned if this + ; is a duplicate EOB. + ; + NEW DUP,IBEOB,CHKSUM1,CHKSUM2 + S DUP=0,IBIFN=+$G(IBIFN) + I $G(IBARRAY)=""!'IBIFN G DUPX + I '$D(^IBM(361.1,"B",IBIFN)) G DUPX ; no EOB's on file yet + S CHKSUM1=$$CHKSUM^IBCEMU1(IBARRAY) ; checksum of current EOB + I 'CHKSUM1 G DUPX ; must be able to be calculated + S IBEOB=0 + F S IBEOB=$O(^IBM(361.1,"B",IBIFN,IBEOB)) Q:'IBEOB D Q:DUP + . S CHKSUM2=+$P($G(^IBM(361.1,IBEOB,100)),U,5) ; checksum of old EOB + . I 'CHKSUM2 Q + . I CHKSUM1=CHKSUM2 S DUP=IBEOB Q ; comparison + . Q +DUPX ; + Q DUP + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEOB00.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEOB00.m index 705371b9..ddf9a0ab 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEOB00.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEOB00.m @@ -1,224 +1,221 @@ -IBCEOB00 ;ALB/ESG - 835 EDI EOB MSG PROCESSING CONT ;30-JUN-2003 - ;;2.0;INTEGRATED BILLING;**155,349,377**;21-MAR-94;Build 23 - ;;Per VHA Directive 2004-038, this routine should not be modified. - Q - ; -RCRU(IBZDATA,IB0,IBLN) ; Revenue Code Roll-up procedure check - - ; Total up outbound line items by revenue code and compare with - ; incoming EOB 40 record to see if it has been rolled up - ; - ; IBZDATA - UB output formatter array, passed by reference - ; IB0 - 40 record data - ; IBLN - output parameter, passed by reference - ; - NEW Z,LN,REV,UN,CH,RUD,RUD2,UCH,MRAUCH - I $P(IB0,U,4)="" G RCRUX - S IBLN="",Z=0 - F S Z=$O(IBZDATA(Z)) Q:'Z S LN=IBZDATA(Z) D - . S REV=$P(LN,U,1),UN=$P(LN,U,4),CH=$P(LN,U,5),UCH=+$P(LN,U,3) - . I REV="" Q - . ; - . S RUD=$G(RUD(REV)) ; roll up data array for rev code - . S $P(RUD,U,1)=$P(RUD,U,1)+CH ; total charges - . S $P(RUD,U,2)=$P(RUD,U,2)+UN ; total units - . S $P(RUD,U,3)=$P(RUD,U,3)+1 ; total line items - . S RUD(REV)=RUD - . S RUD(REV,Z)="" - . ; - . S RUD2=$G(RUD2(REV,UCH)) ; roll up data array for rev code - . S $P(RUD2,U,1)=$P(RUD2,U,1)+CH ; total charges - . S $P(RUD2,U,2)=$P(RUD2,U,2)+UN ; total units - . S $P(RUD2,U,3)=$P(RUD2,U,3)+1 ; total line items - . S RUD2(REV,UCH)=RUD2 - . S RUD2(REV,UCH,Z)="" - . ; - . Q - ; - I '$D(RUD),'$D(RUD2) G RCRUX - ; - ; delete the revenue code roll-up, if only 1 line item. - S REV="" ; this is not a roll up situation - F S REV=$O(RUD(REV)) Q:REV="" I $P(RUD(REV),U,3)=1 KILL RUD(REV) - ; - S (REV,UCH)="" - F S REV=$O(RUD2(REV)) Q:REV="" F S UCH=$O(RUD2(REV,UCH)) Q:UCH="" I $P(RUD2(REV,UCH),U,3)=1 KILL RUD2(REV,UCH) - ; - I '$D(RUD),'$D(RUD2) G RCRUX - ; - S RUD=$G(RUD($P(IB0,U,4))) ; compare with 40 record data - I RUD="" G RCRU2 ; make sure it exists - I $P(RUD,U,1)'=+$$DOLLAR^IBCEOB($P(IB0,U,15)) G RCRU2 ; charges - I $P(RUD,U,2)'=$P(IB0,U,16) G RCRU2 ; units - S IBLN=$O(RUD($P(IB0,U,4),"")) ; use the first line# found - G RCRUX - ; -RCRU2 ; check roll-up data by rev code and unit charge - S MRAUCH=0 - I $P(IB0,U,16) S MRAUCH=+$$DOLLAR^IBCEOB($P(IB0,U,15))/$P(IB0,U,16) - S RUD2=$G(RUD2($P(IB0,U,4),MRAUCH)) ; compare with 40 record data - I RUD2="" G RCRUX ; make sure it exists - I $P(RUD2,U,1)'=+$$DOLLAR^IBCEOB($P(IB0,U,15)) G RCRUX ; charges - I $P(RUD2,U,2)'=$P(IB0,U,16) G RCRUX ; units - S IBLN=$O(RUD2($P(IB0,U,4),MRAUCH,"")) ; use the first line# found - ; -RCRUX ; - Q - ; -ICN(IBEOB,ICN,COBN,IBOK) ; File the 835 ICN into the Bill - ; - ; Input parameters - ; IBEOB - ien to file 361.1 - ; ICN - the ICN# from the 835 transmission - ; COBN - the insurance sequence# - ; - ; Output parameter - ; IBOK - returns as 0 if we get a filing error here - ; - ; The field in file 399 depends on the current payer sequence - ; 399,453 - primary ICN - ; 399,454 - secondary ICN - ; 399,455 - tertiary ICN - ; - NEW IBIFN,FIELD,D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y - S IBEOB=+$G(IBEOB),COBN=+$G(COBN) - I 'IBEOB!'COBN G ICNX - S IBIFN=+$P($G(^IBM(361.1,IBEOB,0)),U,1) - I '$D(^DGCR(399,IBIFN)) G ICNX - I $G(ICN)="" G ICNX - I '$F(".1.2.3.","."_COBN_".") G ICNX - ; - S FIELD=452+COBN - S DIE=399,DA=IBIFN,DR=FIELD_"////"_ICN D ^DIE - S IBOK=($D(Y)=0) - I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Error in filing the ICN into the Bill/Claims file" -ICNX ; - Q - ; -15(IB0,IBEGBL,IBEOB) ; Record '15' - ; - N A,IBOK - ; - S A="3;1.03;1;0;0^4;1.04;1;0;0^5;1.05;1;0;0^6;1.07;1;0;0^7;1.08;1;0;0^8;1.09;1;0;0^9;1.02;1;0;0^10;2.05;1;0;0" - ; - S IBOK=$$STORE^IBCEOB1(A,IB0,IBEOB) - I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad record 15 data" G Q15 - ; - ; For Medicare MRA's only: - ; If the Covered Amount is present (15 record, piece 3), then file - ; a claim level adjustment with Group code=OA, Reason code=AB3. - ; - I $P($G(^IBM(361.1,IBEOB,0)),U,4)=1,+$P(IB0,U,3) D - . N IB20 - . S IB20=20_U_$P(IB0,U,2)_U_"OA"_U_"AB3"_U_$P(IB0,U,3)_U_"0000000000" - . S IB20=IB20_U_"Covered Amount" - . S IBOK=$$20(IB20,IBEGBL,IBEOB) - . I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Could not file the OA-AB3 claim level adjustment for the Covered Amount" - . K ^TMP($J,20) - . Q - ; -Q15 Q IBOK - ; -20(IB0,IBEGBL,IBEOB) ; Record '20' - ; - N A,LEVEL,IBGRP,IBDA,IBOK - ; - S IBGRP=$P(IB0,U,3) - I IBGRP'="" S ^TMP($J,20)=IBGRP - I IBGRP="" S IBGRP=$G(^TMP($J,20)) - I IBGRP="" S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Missing claim level adjustment group code" G Q20 - ; - S IBDA(1)=$O(^IBM(361.1,IBEOB,10,"B",IBGRP,0)) - ; - I 'IBDA(1) D ;Needs a new entry at group level - . N X,Y,DA,DD,DO,DIC,DLAYGO - . S DIC="^IBM(361.1,"_IBEOB_",10,",DIC(0)="L",DLAYGO=361.11,DA(1)=IBEOB - . S DIC("P")=$$GETSPEC^IBEFUNC(361.1,10) - . S X=IBGRP - . D FILE^DICN K DIC,DO,DD,DLAYGO - . I Y<0 K IBDA S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Adjustment group code could not be added" Q - . S IBDA(1)=+Y - ; - I $G(IBDA(1)) D ;Add a new entry at the reason code level - . S DIC="^IBM(361.1,"_IBEOB_",10,"_IBDA(1)_",1,",DIC(0)="L",DLAYGO=361.111,DA(2)=IBEOB,DA(1)=IBDA(1) - . S DIC("P")=$$GETSPEC^IBEFUNC(361.11,1) - . S X=$P(IB0,U,4) - . D FILE^DICN K DIC,DO,DD,DLAYGO - . I Y<0 K IBDA S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Adjustment reason code could not be added" Q - . S IBDA=+Y - ; - I $G(IBDA) D - . S LEVEL=10,LEVEL("DIE")="^IBM(361.1,"_IBEOB_",10,"_IBDA(1)_",1," - . S LEVEL(0)=IBDA,LEVEL(1)=IBDA(1),LEVEL(2)=IBEOB - . S A="5;.02;1;0;0^6;.03;0;1;1^7;.04;0;1;0" - . S IBOK=$$STORE^IBCEOB1(A,IB0,IBEOB,.LEVEL) - . I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad adjustment reason code ("_$P(IB0,U,4)_") data" Q -Q20 Q $G(IBOK) - ; -35(IB0,IBEGBL,IBEOB) ; Record '35' - ; - N A,IBOK - ; - S A="3;4.12;1;0;0^4;4.13;1;0;0^5;4.14;0;1;1^6;4.15;1;0;0^7;4.16;1;0;0^8;4.17;1;0;0^9;4.18;1;0;0^10;4.04;1;0;0^11;3.01;0;1;1^12;3.02;1;0;0^13;3.08;1;0;0^14;3.09;1;0;0" - ; - S IBOK=$$STORE^IBCEOB1(A,IB0,IBEOB) - I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad MEDICARE Inpt Adjudication data" -Q35 Q $G(IBOK) - ; -37(IB0,IBEGBL,IBEOB) ; Record '37' - ; - N IBOK,IBCT - S IBCT=$G(^TMP($J,37))+1 - I IBCT>5 S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Too many Medicare Claim Level Adjudication Remarks" G Q37 ; Max 5 allowed - S A="4;"_$S($P(IB0,U,3)="O":"3.0"_(IBCT+2),1:"5.0"_IBCT)_";0;0;0^5;5.0"_IBCT_"1;0;0;0" - S IBOK=$$STORE^IBCEOB1(A,IB0,IBEOB) - I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad Medicare Claim Level Adjudication Remarks data" - ; - ; 4/22/03 - esg - If claim level remark code MA15 is reported, then - ; this is a split EOB and we need to change the REVIEW STATUS - ; of this EOB to be ACCEPTED-INTERIM EOB. - ; - I $P(IB0,U,4)["MA15" D - . N DA,DIE,DR,DIC - . S DA=IBEOB,DIE=361.1,DR=".16////2" D ^DIE S IBOK=($D(Y)=0) - . I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Split EOB, but review status was not updated correctly" - . Q - ; -Q37 S ^TMP($J,37)=$G(^TMP($J,37))+1 ; Saves the # of entries for 37 records - Q $G(IBOK) - ; - ; -DET40(IB0,ARRAY) ; Format important details of record 40 for error - ; IB0 = data on 40 record (some pieces pre-formatted) - ; ARRAY(n)=formatted line is returned if passed by ref - N Q - S ARRAY(1)="Payer reported the following was billed to them:" - S ARRAY(2)=" "_$S($P(IB0,U,21)="NU":"Rev Cd",1:"Proc")_": "_$S($P(IB0,U,10)'="":$P(IB0,U,10),1:"Same as adjudicated")_" Chg: "_$J($P(IB0,U,15)/100,"",2)_" Units: "_$S($P(IB0,U,16):$P(IB0,U,16),1:1) - S ARRAY(3)=" Svc Date(s): "_$S($P(IB0,U,19)'="":$$FDT($P(IB0,U,19)),1:"??")_$S($P(IB0,U,20)'="":"-"_$$FDT($P(IB0,U,20)),1:"") - I $P(IB0,U,11)'="" S ARRAY(3)=ARRAY(3)_" Mods: " F Q=11:1:14 I $P(IB0,U,Q)'="" S ARRAY(3)=ARRAY(3)_$P(IB0,U,Q)_$S(Q=14:"",$P(IB0,U,Q+1)'="":",",1:"") - S ARRAY(4)="Payer reported adjudication on:" - S ARRAY(5)=" "_$S($P(IB0,U,21)="NU":"Rev Cd",1:"Proc")_": "_$S($P(IB0,U,3)'="":$P(IB0,U,3),1:$P(IB0,U,4)) - S ARRAY(5)=ARRAY(5)_" Type: "_$P(IB0,U,21)_$S($P(IB0,U,21)'="NU":" Rev Cd: "_$P(IB0,U,4),1:"")_" Units: "_$S($P(IB0,U,18):$P(IB0,U,18)/100,1:1)_" Amt: "_$J($P(IB0,U,17)/100,"",2) - I $P(IB0,U,5)'="" S ARRAY(5)=ARRAY(5)_" Mods: " F Q=5:1:8 I $P(IB0,U,Q)'="" S ARRAY(5)=ARRAY(5)_$P(IB0,U,Q)_$S(Q=8:"",$P(IB0,U,Q+1)'="":",",1:"") - Q - ; -DET4X(RECID,IB0,ARRAY) ; Format important details of record 41-45 for error - ; RECID = 41,42,45 - ; IB0 = data on RECID record - ; ARRAY(n)=formatted line is returned if passed by ref - N CT,Q - I RECID=41 D Q - . S ARRAY(1)="Allowed Amt: "_$J($P(IB0,U,3)/100,"",2)_" Per Diem Amt: "_$J($P(IB0,U,4)/100,"",2) - ; - I RECID=42 D Q - . S ARRAY(1)="Line Item Remark Code: "_$P(IB0,U,3) - . I $P(IB0,U,4)'="" S CT=1 F Q=0:80:190 I $E($P(IB0,U,4),Q+1,Q+80)'="" S CT=CT+1,ARRAY(CT)=$E($P(IB0,U,4),Q+1,Q+80) - ; - I RECID=45 D - . S ARRAY(1)="Adj Group Cd: "_$P(IB0,U,3)_" Reason Cd: "_$P(IB0,U,4)_" Amt: "_$J($P(IB0,U,5)/100,"",2)_" Quantity: "_+$P(IB0,U,6) - . I $P(IB0,U,7)'="" S CT=1 F Q=0:80:190 I $E($P(IB0,U,7),Q+1,Q+80)'="" S CT=CT+1,ARRAY(CT)=$E($P(IB0,U,7),Q+1,Q+80) - Q - ; -FDT(X) ; Format date in X (YYYYMMDD) to MM/DD/YYYY - S:X'="" X=$E(X,5,6)_"/"_$E(X,7,8)_"/"_$E(X,1,4) - Q X - ; +IBCEOB00 ;ALB/ESG - 835 EDI EOB MSG PROCESSING CONT ;30-JUN-2003 + ;;2.0;INTEGRATED BILLING;**155,349**;21-MAR-94;Build 46 + ;;Per VHA Directive 2004-038, this routine should not be modified. + Q + ; +RCRU(IBZDATA,IB0,IBLN) ; Revenue Code Roll-up procedure check - + ; Total up outbound line items by revenue code and compare with + ; incoming EOB 40 record to see if it has been rolled up + ; + ; IBZDATA - UB output formatter array, passed by reference + ; IB0 - 40 record data + ; IBLN - output parameter, passed by reference + ; + NEW Z,LN,REV,UN,CH,RUD,RUD2,UCH,MRAUCH + I $P(IB0,U,4)="" G RCRUX + S IBLN="",Z=0 + F S Z=$O(IBZDATA(Z)) Q:'Z S LN=IBZDATA(Z) D + . S REV=$P(LN,U,1),UN=$P(LN,U,4),CH=$P(LN,U,5),UCH=+$P(LN,U,3) + . I REV="" Q + . ; + . S RUD=$G(RUD(REV)) ; roll up data array for rev code + . S $P(RUD,U,1)=$P(RUD,U,1)+CH ; total charges + . S $P(RUD,U,2)=$P(RUD,U,2)+UN ; total units + . S $P(RUD,U,3)=$P(RUD,U,3)+1 ; total line items + . S RUD(REV)=RUD + . S RUD(REV,Z)="" + . ; + . S RUD2=$G(RUD2(REV,UCH)) ; roll up data array for rev code + . S $P(RUD2,U,1)=$P(RUD2,U,1)+CH ; total charges + . S $P(RUD2,U,2)=$P(RUD2,U,2)+UN ; total units + . S $P(RUD2,U,3)=$P(RUD2,U,3)+1 ; total line items + . S RUD2(REV,UCH)=RUD2 + . S RUD2(REV,UCH,Z)="" + . ; + . Q + ; + I '$D(RUD),'$D(RUD2) G RCRUX + ; + ; delete the revenue code roll-up, if only 1 line item. + S REV="" ; this is not a roll up situation + F S REV=$O(RUD(REV)) Q:REV="" I $P(RUD(REV),U,3)=1 KILL RUD(REV) + ; + S (REV,UCH)="" + F S REV=$O(RUD2(REV)) Q:REV="" F S UCH=$O(RUD2(REV,UCH)) Q:UCH="" I $P(RUD2(REV,UCH),U,3)=1 KILL RUD2(REV,UCH) + ; + I '$D(RUD),'$D(RUD2) G RCRUX + ; + S RUD=$G(RUD($P(IB0,U,4))) ; compare with 40 record data + I RUD="" G RCRU2 ; make sure it exists + I $P(RUD,U,1)'=+$$DOLLAR^IBCEOB($P(IB0,U,15)) G RCRU2 ; charges + I $P(RUD,U,2)'=$P(IB0,U,16) G RCRU2 ; units + S IBLN=$O(RUD($P(IB0,U,4),"")) ; use the first line# found + G RCRUX + ; +RCRU2 ; check roll-up data by rev code and unit charge + S MRAUCH=0 + I $P(IB0,U,16) S MRAUCH=+$$DOLLAR^IBCEOB($P(IB0,U,15))/$P(IB0,U,16) + S RUD2=$G(RUD2($P(IB0,U,4),MRAUCH)) ; compare with 40 record data + I RUD2="" G RCRUX ; make sure it exists + I $P(RUD2,U,1)'=+$$DOLLAR^IBCEOB($P(IB0,U,15)) G RCRUX ; charges + I $P(RUD2,U,2)'=$P(IB0,U,16) G RCRUX ; units + S IBLN=$O(RUD2($P(IB0,U,4),MRAUCH,"")) ; use the first line# found + ; +RCRUX ; + Q + ; +ICN(IBEOB,ICN,COBN,IBOK) ; File the 835 ICN into the Bill + ; + ; Input parameters + ; IBEOB - ien to file 361.1 + ; ICN - the ICN# from the 835 transmission + ; COBN - the insurance sequence# + ; + ; Output parameter + ; IBOK - returns as 0 if we get a filing error here + ; + ; The field in file 399 depends on the current payer sequence + ; 399,453 - primary ICN + ; 399,454 - secondary ICN + ; 399,455 - tertiary ICN + ; + NEW IBIFN,FIELD,D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y + S IBEOB=+$G(IBEOB),COBN=+$G(COBN) + I 'IBEOB!'COBN G ICNX + S IBIFN=+$P($G(^IBM(361.1,IBEOB,0)),U,1) + I '$D(^DGCR(399,IBIFN)) G ICNX + I $G(ICN)="" G ICNX + I '$F(".1.2.3.","."_COBN_".") G ICNX + ; + S FIELD=452+COBN + S DIE=399,DA=IBIFN,DR=FIELD_"////"_ICN D ^DIE + S IBOK=($D(Y)=0) + I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Error in filing the ICN into the Bill/Claims file" +ICNX ; + Q + ; +35(IB0,IBEGBL,IBEOB) ; Record '35' + ; + N A,IBOK + ; + S A="3;4.12;1;0;0^4;4.13;1;0;0^5;4.14;0;1;1^6;4.15;1;0;0^7;4.16;1;0;0^8;4.17;1;0;0^9;4.18;1;0;0^10;4.04;1;0;0^11;3.01;0;1;1^12;3.02;1;0;0^13;3.08;1;0;0^14;3.09;1;0;0" + ; + S IBOK=$$STORE^IBCEOB1(A,IB0,IBEOB) + I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad MEDICARE Inpt Adjudication data" +Q35 Q $G(IBOK) + ; +37(IB0,IBEGBL,IBEOB) ; Record '37' + ; + N IBOK,IBCT + S IBCT=$G(^TMP($J,37))+1 + I IBCT>5 S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Too many Medicare Claim Level Adjudication Remarks" G Q37 ; Max 5 allowed + S A="4;"_$S($P(IB0,U,3)="O":"3.0"_(IBCT+2),1:"5.0"_IBCT)_";0;0;0^5;5.0"_IBCT_"1;0;0;0" + S IBOK=$$STORE^IBCEOB1(A,IB0,IBEOB) + I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad Medicare Claim Level Adjudication Remarks data" + ; + ; 4/22/03 - esg - If claim level remark code MA15 is reported, then + ; this is a split EOB and we need to change the REVIEW STATUS + ; of this EOB to be ACCEPTED-INTERIM EOB. + ; + I $P(IB0,U,4)["MA15" D + . N DA,DIE,DR,DIC + . S DA=IBEOB,DIE=361.1,DR=".16////2" D ^DIE S IBOK=($D(Y)=0) + . I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Split EOB, but review status was not updated correctly" + . Q + ; +Q37 S ^TMP($J,37)=$G(^TMP($J,37))+1 ; Saves the # of entries for 37 records + Q $G(IBOK) + ; + ; +DET40(IB0,ARRAY) ; Format important details of record 40 for error + ; IB0 = data on 40 record (some pieces pre-formatted) + ; ARRAY(n)=formatted line is returned if passed by ref + N Q + S ARRAY(1)="Payer reported the following was billed to them:" + S ARRAY(2)=" "_$S($P(IB0,U,21)="NU":"Rev Cd",1:"Proc")_": "_$S($P(IB0,U,10)'="":$P(IB0,U,10),1:"Same as adjudicated")_" Chg: "_$J($P(IB0,U,15)/100,"",2)_" Units: "_$S($P(IB0,U,16):$P(IB0,U,16),1:1) + S ARRAY(3)=" Svc Date(s): "_$S($P(IB0,U,19)'="":$$FDT($P(IB0,U,19)),1:"??")_$S($P(IB0,U,20)'="":"-"_$$FDT($P(IB0,U,20)),1:"") + I $P(IB0,U,11)'="" S ARRAY(3)=ARRAY(3)_" Mods: " F Q=11:1:14 I $P(IB0,U,Q)'="" S ARRAY(3)=ARRAY(3)_$P(IB0,U,Q)_$S(Q=14:"",$P(IB0,U,Q+1)'="":",",1:"") + S ARRAY(4)="Payer reported adjudication on:" + S ARRAY(5)=" "_$S($P(IB0,U,21)="NU":"Rev Cd",1:"Proc")_": "_$S($P(IB0,U,3)'="":$P(IB0,U,3),1:$P(IB0,U,4)) + S ARRAY(5)=ARRAY(5)_" Type: "_$P(IB0,U,21)_$S($P(IB0,U,21)'="NU":" Rev Cd: "_$P(IB0,U,4),1:"")_" Units: "_$S($P(IB0,U,18):$P(IB0,U,18)/100,1:1)_" Amt: "_$J($P(IB0,U,17)/100,"",2) + I $P(IB0,U,5)'="" S ARRAY(5)=ARRAY(5)_" Mods: " F Q=5:1:8 I $P(IB0,U,Q)'="" S ARRAY(5)=ARRAY(5)_$P(IB0,U,Q)_$S(Q=8:"",$P(IB0,U,Q+1)'="":",",1:"") + Q + ; +DET4X(RECID,IB0,ARRAY) ; Format important details of record 41-45 for error + ; RECID = 41,42,45 + ; IB0 = data on RECID record + ; ARRAY(n)=formatted line is returned if passed by ref + N CT,Q + I RECID=41 D Q + . S ARRAY(1)="Allowed Amt: "_$J($P(IB0,U,3)/100,"",2)_" Per Diem Amt: "_$J($P(IB0,U,4)/100,"",2) + ; + I RECID=42 D Q + . S ARRAY(1)="Line Item Remark Code: "_$P(IB0,U,3) + . I $P(IB0,U,4)'="" S CT=1 F Q=0:80:190 I $E($P(IB0,U,4),Q+1,Q+80)'="" S CT=CT+1,ARRAY(CT)=$E($P(IB0,U,4),Q+1,Q+80) + ; + I RECID=45 D + . S ARRAY(1)="Adj Group Cd: "_$P(IB0,U,3)_" Reason Cd: "_$P(IB0,U,4)_" Amt: "_$J($P(IB0,U,5)/100,"",2)_" Quantity: "_+$P(IB0,U,6) + . I $P(IB0,U,7)'="" S CT=1 F Q=0:80:190 I $E($P(IB0,U,7),Q+1,Q+80)'="" S CT=CT+1,ARRAY(CT)=$E($P(IB0,U,7),Q+1,Q+80) + Q + ; +FDT(X) ; Format date in X (YYYYMMDD) to MM/DD/YYYY + S:X'="" X=$E(X,5,6)_"/"_$E(X,7,8)_"/"_$E(X,1,4) + Q X + ; +UPDNM(IBEOB,IB0,IBBULL,IBDR) ; Update name on claim if it comes back changed + ; IBEOB = the internal entry # of the entry in file 361.1 + ; IB0 = the raw data returned from the 835 flat file + ; IBBULL = holds result of name change check in piece 1 - if name + ; changed, first '^' piece is 1, 3rd '^' piece is the old + ; insured's name + ; IBDR = returned as the updated 'DR' string with the name changed + ; fields to use to update the EOB file (361.1) - pass by reference + ; + N IBCHGED,IBIFN,IBNEW,IBCOB,DIE,DR,X,Y + I $P(IB0,U,7) D + . S IBNEW=$P(IB0,U,3)_","_$P(IB0,U,4)_$S($P(IB0,U,5)'="":" "_$P(IB0,U,5),1:""),$P(IBBULL,U)=1 + . S IBCOB=+$P($G(^IBM(361.1,IBEOB,0)),U,15) + . S IBIFN=+$G(^IBM(361.1,+IBEOB,0)) + . S IB=$G(^DGCR(399,IBIFN,"I"_IBCOB)) + . ; + . I IB'="",$P(IB,U,17)'=IBNEW D + .. ; Update the claim data only + .. S $P(IBBULL,U,3)=$P(IB,U,17) ; save old value + .. S $P(IB,U,17)=IBNEW + .. S DIE="^DGCR(399,",DA=IBIFN,DR="30"_IBCOB_"////"_IB + .. D:DA ^DIE + .. S IBCHGED=1 + . S IBDR=$G(IBDR)_"6.01////"_$P(IB0,U,3)_","_$P(IB0,U,4)_" "_$P(IB0,U,5)_";" + ; + Q $G(IBCHGED) + ; +UPDID(IBEOB,IB0,IBBULL,IBDR) ; Update id # on claim and policy if it comes back + ; changed + ; IBEOB = the internal entry # of the entry in file 361.1 + ; IB0 = the raw data returned from the 835 flat file + ; IBBULL = holds result of id change check in piece 2 - if id changed, + ; second '^' piece = 1,4th '^' piece is the old insured's id + ; IBDR = returned as the updated 'DR' string with the id changed fields + ; to use to update the EOB file (361.1) - pass by reference + ; + N IBCHGED,IBNEW,IBCOB,IB,DIE,DR,DA,X,Y + I $P(IB0,U,8) D + . S IBNEW=$P(IB0,U,6),$P(IBBULL,U,2)=1 + . S IBIFN=+$G(^IBM(361.1,+IBEOB,0)) + . S IBCOB=+$P($G(^IBM(361.1,IBEOB,0)),U,15) + . S IB=$G(^DGCR(399,IBIFN,"I"_IBCOB)) + . ; + . I IB'="",$P(IB,U,2)'=IBNEW D + .. ; Update the claim + .. S $P(IBBULL,U,4)=$P(IB,U,2) ; save old value + .. S $P(IB,U,2)=IBNEW + .. S DIE="^DGCR(399,",DA=IBIFN,DR="30"_IBCOB_"////"_IB D ^DIE + .. ; + .. ; Update the policy + .. S DA(1)=$P($G(^DGCR(399,IBIFN,0)),U,2),DA=$P($G(^("M")),U,(11+IBCOB)),DR="1////"_IBNEW,DIE="^DPT("_DA(1)_",.312," + .. I DA(1),DA D ^DIE + .. S IBCHGED=1 + . S IBDR=$G(IBDR)_"6.02////"_$P(IB0,U,6)_";" + ; + Q $G(IBCHGED) + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP0.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP0.m index 87dfd16e..c6d83a9e 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP0.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP0.m @@ -1,216 +1,204 @@ -IBCEP0 ;ALB/TMP - Functions for PROVIDER ID MAINTENANCE ;13-DEC-99 - ;;2.0;INTEGRATED BILLING;**137,191,239,232,320,348,349,377**;21-MAR-94;Build 23 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -EN ; -- main entry point for IBCE PRV INS ID - N IBINS,IBDSP,IBSORT,IBPRV ; Variables should be available throughout actions - K IBFASTXT - D FULL^VALM1 - D EN^VALM("IBCE PRVINS ID") - Q - ; -EN1(IBINS) ; Entrypoint from insurance co maintenance - N IBDSP,IBSORT ; Variables should be available throughout actions - D FULL^VALM1 - D EN^VALM("IBCE PRVINS ID FROM INS MAINT") - Q - ; -HDR ; -- header code - N Z,Z0,Z1,IBCT,IBPPTYP,IBEMCTYP - S IBCT=1 - K VALMHDR - I $G(IBINS) D - . N PCF,PCDISP - . S PCF=$P($G(^DIC(36,+IBINS,3)),U,13) - . S PCDISP=$S(PCF="C":"(Child)",PCF="P":"(Parent)",1:"") - . S VALMHDR(1)="Insurance Co: "_$P($G(^DIC(36,+IBINS,0)),U)_" "_PCDISP - . ; Get performing provider id type for insurance co - . S IBPPTYP=$$PPTYP(IBINS) - . ; Get ien of EMC ID from file 355.97 - . S IBEMCTYP=+$$EMCID^IBCEP() - . I $G(IBSORT)="ALL"!($G(IBDSP)="I")!($G(IBSORT)=IBPPTYP)!($G(IBSORT)=IBEMCTYP) D - .. ; Look for care unit in either of these id types - if there, report on line 2 of header - .. I $G(IBSORT)=IBPPTYP S IBEMCTYP=0 - .. I $G(IBSORT)=IBEMCTYP S IBPPTYP=0 - .. F Z0=IBPPTYP_"P",IBEMCTYP_"E" S Z1="" F S Z1=$O(^IBA(355.96,"D",+IBINS,+Z0,Z1)) Q:Z1="" I Z1'="*N/A*" S Z($E(Z0,$L(Z0)))=1 Q - .. I $D(Z("P"))!$D(Z("E")) D - ... S IBCT=IBCT+1 - ... S VALMHDR(IBCT)=" "_$S($D(Z("P")):"PERFORMING PROV ID"_$S($D(Z("E")):" AND ",1:""),1:"")_$S($D(Z("E")):"EMC PROV ID",1:"")_" MAY REQUIRE CARE UNIT" - . I $D(Z("P"))!$D(Z("E")) S IBCT=IBCT+1,VALMHDR(IBCT)=" " - . S IBCT=IBCT+1,VALMHDR(IBCT)=" PROVIDER "_$S($G(IBDSP)="I":"ID TYPE",1:"NAME ")_$J("",6)_"FORM CARE TYPE CARE UNIT ID#" - Q - ; -INIT ; Initialization - K ^TMP("IB_EDITED_IDS",$J) ; This will be to keep track of ID's edited during this session - D INSID(.IBINS,.IBDSP,.IBSORT) - I $G(IBDSP)="I",$G(IBSORT) S IBPRV=IBSORT - I '$G(IBINS) S VALMQUIT=1 - Q - ; -INSID(IBINS,IBDSP,IBSORT) ; - N DIC,DIR,DA,X,Y,IBOK,DTOUT,DUOUT - S IBOK=1 - I '$G(IBINS) D - . S DIC(0)="AEMQ",DIC="^DIC(36," D ^DIC - . I Y'>0 S IBOK=0 Q - . S IBINS=+Y - I '$G(IBINS) S IBOK=0 - I 'IBOK G INSIDQ - ; - S DIR(0)="SA^D:INSURANCE CO DEFAULT IDS;I:INDIVIDUAL PROVIDER IDS FURNISHED BY THE INS CO;A:ALL IDS FURNISHED BY THE INS CO BY PROVIDER TYPE" - S DIR("A")="SELECT DISPLAY CONTENT: ",DIR("B")="A" - S DIR("?",1)="(D) DISPLAY CONTAINS ONLY THOSE IDS ASSIGNED AS DEFAULTS TO THE FACILITY BY",DIR("?",2)=" THE INSURANCE COMPANY" - S DIR("?",3)="(I) DISPLAY CONTAINS ONLY THOSE IDS ASSIGNED TO INDIVIDUAL PROVIDERS BY THE",DIR("?",4)=" INSURANCE COMPANY" - S DIR("?",5)="(A) DISPLAY CONTAINS ALL IDS ASSIGNED BY THE INSURANCE COMPANY FOR ONE OR ALL",DIR("?")=" PROVIDER ID TYPES" - W ! D ^DIR K DIR W ! - I $D(DTOUT)!$D(DUOUT)!("DIA"'[Y) S IBOK=0 G INSIDQ - S IBDSP=Y,IBSORT="" - I IBDSP="A"!(IBDSP="I") F D Q:'IBOK!(IBSORT'="") - . ; - . I IBDSP="A" D - .. S DIR("A")="Display only IDs with a specific ID Qualifier?: " - .. S DIR("?",1)="Answer Yes to select a specific ID Qualifier by which to display IDs." - .. S DIR("?")="Answer No to display all IDs." - .. Q - . ; - . I IBDSP="I" D - .. S DIR("A")="Display IDs for a specific Provider?: " - .. S DIR("?",1)="Answer Yes to select a specific Provider." - .. S DIR("?")="Answer No to display all Providers." - .. Q - . ; - . S DIR("B")="NO",DIR(0)="YA" - . W ! D ^DIR K DIR W ! - . I $D(DTOUT)!$D(DUOUT) S IBOK=0 Q - . I Y'=1 S IBSORT="ALL" Q - . ; - . I IBDSP="A" D Q - .. S DIC(0)="AEMQ",DIC="^IBE(355.97,",DIC("S")="I $S('$P(^(0),U,2):1,1:$P(^(0),U,2)=3)" - .. S DIC("A")="Select type of ID Qualifier: " - .. D ^DIC K DIC - .. I Y>0 S IBSORT=+Y Q - .. I $D(DTOUT)!$D(DUOUT) S IBOK=0 - . ; - . I IBDSP="I" D Q - .. N DA - .. S DIR(0)="399.0222,.02A",DIR("A")="SELECT PROVIDER: " - .. W ! D ^DIR K DIR W ! - .. I Y>0 S IBSORT=Y Q - .. I $D(DTOUT)!$D(DUOUT) S IBOK=0 Q - . S IBOK=0 Q - ; - G:'IBOK INSIDQ - D BLD(IBINS,IBDSP,IBSORT) -INSIDQ I 'IBOK S VALMQUIT=1 - Q - ; -BLD(IBINS,IBDSP,IBSORT) ; Build display for Insurance co level provider ID's - N IB,IBENT,IBLCT,IBCT,IBPRV,IBSRT1,IBSRT2,IBOSRT1,IBOSRT2,CU,FT,PT,CT,Z,Z0 - K ^TMP("IBPRV_INS_ID",$J),^TMP("IBPRV_INS_SORT",$J) - ; - S (IBENT,IBCT,IBLCT)=0 - ; - I "DA"[$G(IBDSP) D - . S CU="" F S CU=$O(^IBA(355.91,"AUNIQ",IBINS,CU)) Q:CU="" S FT="" F S FT=$O(^IBA(355.91,"AUNIQ",IBINS,CU,FT)) Q:FT="" D - .. S CT="" F S CT=$O(^IBA(355.91,"AUNIQ",IBINS,CU,FT,CT)) Q:CT="" S PT=0 F S PT=$S(IBDSP="A"&IBSORT:IBSORT,1:$O(^IBA(355.91,"AUNIQ",IBINS,CU,FT,CT,PT))) Q:'PT D Q:IBDSP="A"&IBSORT - ... S Z=0 F S Z=$O(^IBA(355.91,"AUNIQ",IBINS,CU,FT,CT,PT,Z)) Q:'Z S IB=$G(^IBA(355.91,Z,0)) S ^TMP("IBPRV_INS_SORT",$J,PT,"^<>",FT,CT,CU,Z)=$P(IB,U,7)_U - ; - I "IA"[$G(IBDSP) D - . S IBPRV="" - . N IB1,IB2 - . F S IBPRV=$O(^IBA(355.9,"AE",IBINS,IBPRV)) Q:'IBPRV S Z=0 F S Z=$O(^IBA(355.9,"AE",IBINS,IBPRV,Z)) Q:'Z S IB=$G(^IBA(355.9,Z,0)) D - .. Q:$P(IB,U,4)=""!($P(IB,U,5)="")!($P(IB,U,6)="")!($P(IB,U,16)="") - .. I IBSORT,$S(IBDSP="I":IBPRV'=IBSORT,1:$P(IB,U,6)'=IBSORT) Q - .. S IB1=$S(IBDSP="A":$P(IB,U,6),1:U_$$EXPAND^IBTRE(355.9,.01,IBPRV)_U_IBPRV) - .. S IB2=$S(IBDSP="I":$P(IB,U,6),1:U_$$EXPAND^IBTRE(355.9,.01,IBPRV)_U_IBPRV) - .. S ^TMP("IBPRV_INS_SORT",$J,IB1,IB2,$P(IB,U,4),$P(IB,U,5),$P(IB,U,16),Z)=$P(IB,U,7)_U_IBPRV - ; - S IBOSRT1="" - S IBSRT1="" F S IBSRT1=$O(^TMP("IBPRV_INS_SORT",$J,IBSRT1)) Q:IBSRT1="" D - . S IBSRT2="",IBOSRT2="" - . F S IBSRT2=$O(^TMP("IBPRV_INS_SORT",$J,IBSRT1,IBSRT2)) Q:IBSRT2="" D - .. I IBOSRT1'=IBSRT1 D - ... I IBOSRT1'="" S IBLCT=IBLCT+1 D SET^VALM10(IBLCT," ",IBCT+1) - ... S IBLCT=IBLCT+1 D SET^VALM10(IBLCT,$S(IBDSP'="I":"ID Qualifier",1:"Provider")_": "_$S(IBDSP'="I":$$EXPAND^IBTRE(355.91,.06,IBSRT1),1:$P(IBSRT1,U,2_$S($P(IBSRT2,U,3)["VA(200":" (VA)",1:"(NON-VA)"))),IBCT+1) - ... S IBOSRT1=IBSRT1 - .. ; - .. S FT="" F S FT=$O(^TMP("IBPRV_INS_SORT",$J,IBSRT1,IBSRT2,FT)) Q:FT="" S CT="" F S CT=$O(^TMP("IBPRV_INS_SORT",$J,IBSRT1,IBSRT2,FT,CT)) Q:CT="" D - ... S CU="" F S CU=$O(^TMP("IBPRV_INS_SORT",$J,IBSRT1,IBSRT2,FT,CT,CU)) Q:CU="" S Z=0 F S Z=$O(^TMP("IBPRV_INS_SORT",$J,IBSRT1,IBSRT2,FT,CT,CU,Z)) Q:'Z S IB=$G(^(Z)) D - .... S IBLCT=IBLCT+1,IBCT=IBCT+1 - .... S Z0=$E(IBCT_$J("",4),1,4)_" " - .... I IBDSP'="I" S Z0=Z0_$E($S(IBOSRT2'=IBSRT2:$P(IBSRT2,U,2),1:"")_$J("",20),1,20) - .... I IBDSP="I" S Z0=Z0_$E($S(IBOSRT2'=IBSRT2:$$EXPAND^IBTRE(355.9,.06,IBSRT2),1:"")_$J("",20),1,20) - .... S IBOSRT2=IBSRT2 - .... S Z0=Z0_" "_$S(FT=1:"UB-04",FT=2:"1500 ",1:"BOTH ")_" "_$E($S(CT=3:"RX",CT=1:"INPT",CT=2:"OUTPT",1:"INPT/OUTPT")_$J("",11),1,11)_" "_$E($S(CU'="*N/A*":$P($G(^IBA(355.95,+$P($G(^IBA(355.96,+CU,0)),U),0)),U),1:"")_$J("",15),1,15) - .... D SET^VALM10(IBLCT,Z0_" "_$P(IB,U),IBCT) - .... S ^TMP("IBPRV_INS_ID",$J,"ZIDX",IBCT)=Z,^(IBCT,"PRV")=$P(IB,U,2) - .... I '$D(^TMP("IBPRV_INS_ID",$J,$S(IBDSP="I":"ZXPRV",1:"ZXPTYP"),IBSRT1)) S ^(IBSRT1)=IBLCT-1 - K ^TMP("IBPRV_INS_SORT",$J) - ; - I IBLCT=0 D G BLDQ ; No entries found - . D SET^VALM10(1," ") - . S Z=" No "_$S(IBDSP="D":"default ",1:"") - . S Z=Z_"ID's found for "_$S(IBDSP="I":"provider "_$S(IBSORT:"("_$$EXPAND^IBTRE(355.9,.01,IBSORT)_") ",1:"")_"and ",IBDSP="A":"provider type "_$S(IBSORT:"("_$$EXPAND^IBTRE(355.9,.06,IBSORT)_") ",1:"")_"and ",1:"")_"insurance co" - . D SET^VALM10(2,Z) - . S IBLCT=2 - ; -BLDQ S VALMCNT=IBLCT,VALMBG=1 - Q - ; -EXPND ; - Q - ; -HELP ; - Q - ; -EXIT ; - K IBFASTXT - D COPYPROV^IBCEP5A(IBINS) - K ^TMP("IBPRV_INS_ID",$J) - D CLEAN^VALM10 - Q - ; -SEL(IBDA,MANY) ; Select from provider id list - ; IBDA is passed by reference and IBDA(1) returned containing - ; ien's of the provider id records selected (file 355.9). - ; If > 1 entry can be selected, MANY is set to 1 - N Z - S IBDA=0 - D EN^VALM2($G(XQORNOD(0)),$S($G(MANY):"",1:"S")) - S Z=0 F S Z=$O(VALMY(Z)) Q:'Z S IBDA=IBDA+1,IBDA(IBDA)=+$G(^TMP("IBPRV_INS_ID",$J,"ZIDX",Z))_U_$G(^(Z,"PRV")) - Q - ; -ENX(IBINS1) ; Insurance co level defaults for all providers or - ; for all providers by care unit - N DIC,DIE,DR,DA,X,Y,DLAYGO - I '$G(IBINS1) D G:'$G(IBINS1) ENQ - . S DIC="^IBA(355.91,",DIC(0)="AELMQ",DLAYGO=355.91 D ^DIC - . I Y>0 S IBINS1=+Y - S DIE="^IBA(355.91,",DA=IBINS1,DR=".01;.06;.04;.05;.03;.07" D ^DIE - ; -ENQ Q - ; -PPTYP(IBINS) ; Returns the ien of the default performing provider type for - ; insurance company IBINS (ien file 36) - Q +$G(^DIC(36,+IBINS,4)) - ; -SCREEN(WHICH) ; This screen is used the menu protocol to screen out the ID functions if it is a child ins co - Q:'$G(DA) 0 - Q:'$G(DA(1)) 0 - N FILE,IENS,FIELD,FLAG,TARGET - S FILE=101.01,IENS=DA_","_DA(1),FIELD=".01",FLAG="I" - D GETS^DIQ(FILE,IENS,FIELD,FLAG,"TARGET") - Q:'$D(TARGET) 0 - N IEN - S IEN=$G(TARGET(FILE,IENS_",",FIELD,FLAG)) - Q:'+IEN 0 - S FILE=101,FIELD=1,FLAG="E" - K TARGET - D GETS^DIQ(FILE,IEN,FIELD,FLAG,"TARGET") - Q:'$D(TARGET) 0 - I $G(TARGET(FILE,IEN_",",FIELD,FLAG))'[WHICH Q 1 - Q:'$G(IBINS) 0 - N PCF - S PCF=$P($G(^DIC(36,+IBINS,3)),U,13) - I PCF="C" Q 0 - Q 1 +IBCEP0 ;ALB/TMP - Functions for PROVIDER ID MAINTENANCE ;13-DEC-99 + ;;2.0;INTEGRATED BILLING;**137,191,239,232,320,348,349**;21-MAR-94;Build 46 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; +EN ; -- main entry point for IBCE PRV INS ID + N IBINS,IBDSP,IBSORT,IBPRV ; Variables should be available throughout actions + K IBFASTXT + D FULL^VALM1 + D EN^VALM("IBCE PRVINS ID") + Q + ; +EN1(IBINS) ; Entrypoint from insurance co maintenance + N IBDSP,IBSORT ; Variables should be available throughout actions + D FULL^VALM1 + D EN^VALM("IBCE PRVINS ID FROM INS MAINT") + Q + ; +HDR ; -- header code + N Z,Z0,Z1,IBCT,IBPPTYP,IBEMCTYP + S IBCT=1 + K VALMHDR + I $G(IBINS) D + . N PCF,PCDISP + . S PCF=$P($G(^DIC(36,+IBINS,3)),U,13) + . S PCDISP=$S(PCF="C":"(Child)",PCF="P":"(Parent)",1:"") + . S VALMHDR(1)="Insurance Co: "_$P($G(^DIC(36,+IBINS,0)),U)_" "_PCDISP + . ; Get performing provider id type for insurance co + . S IBPPTYP=$$PPTYP(IBINS) + . ; Get ien of EMC ID from file 355.97 + . S IBEMCTYP=+$$EMCID^IBCEP() + . I $G(IBSORT)="ALL"!($G(IBDSP)="I")!($G(IBSORT)=IBPPTYP)!($G(IBSORT)=IBEMCTYP) D + .. ; Look for care unit in either of these id types - if there, report on line 2 of header + .. I $G(IBSORT)=IBPPTYP S IBEMCTYP=0 + .. I $G(IBSORT)=IBEMCTYP S IBPPTYP=0 + .. F Z0=IBPPTYP_"P",IBEMCTYP_"E" S Z1="" F S Z1=$O(^IBA(355.96,"D",+IBINS,+Z0,Z1)) Q:Z1="" I Z1'="*N/A*" S Z($E(Z0,$L(Z0)))=1 Q + .. I $D(Z("P"))!$D(Z("E")) D + ... S IBCT=IBCT+1 + ... S VALMHDR(IBCT)=" "_$S($D(Z("P")):"PERFORMING PROV ID"_$S($D(Z("E")):" AND ",1:""),1:"")_$S($D(Z("E")):"EMC PROV ID",1:"")_" MAY REQUIRE CARE UNIT" + . I $D(Z("P"))!$D(Z("E")) S IBCT=IBCT+1,VALMHDR(IBCT)=" " + . S IBCT=IBCT+1,VALMHDR(IBCT)=" PROVIDER "_$S($G(IBDSP)="I":"ID TYPE",1:"NAME ")_$J("",6)_"FORM CARE TYPE CARE UNIT ID#" + Q + ; +INIT ; Initialization + K ^TMP("IB_EDITED_IDS",$J) ; This will be to keep track of ID's edited during this session + D INSID(.IBINS,.IBDSP,.IBSORT) + I $G(IBDSP)="I",$G(IBSORT) S IBPRV=IBSORT + I '$G(IBINS) S VALMQUIT=1 + Q + ; +INSID(IBINS,IBDSP,IBSORT) ; + N DIC,DIR,DA,X,Y,IBOK,DTOUT,DUOUT + S IBOK=1 + I '$G(IBINS) D + . S DIC(0)="AEMQ",DIC="^DIC(36," D ^DIC + . I Y'>0 S IBOK=0 Q + . S IBINS=+Y + I '$G(IBINS) S IBOK=0 + I 'IBOK G INSIDQ + ; + S DIR(0)="SA^D:INSURANCE CO DEFAULT IDS;I:INDIVIDUAL PROVIDER IDS FURNISHED BY THE INS CO;A:ALL IDS FURNISHED BY THE INS CO BY PROVIDER TYPE" + S DIR("A")="SELECT DISPLAY CONTENT: ",DIR("B")="A" + S DIR("?",1)="(D) DISPLAY CONTAINS ONLY THOSE IDS ASSIGNED AS DEFAULTS TO THE FACILITY BY",DIR("?",2)=" THE INSURANCE COMPANY" + S DIR("?",3)="(I) DISPLAY CONTAINS ONLY THOSE IDS ASSIGNED TO INDIVIDUAL PROVIDERS BY THE",DIR("?",4)=" INSURANCE COMPANY" + S DIR("?",5)="(A) DISPLAY CONTAINS ALL IDS ASSIGNED BY THE INSURANCE COMPANY FOR ONE OR ALL",DIR("?")=" PROVIDER ID TYPES" + W ! D ^DIR K DIR W ! + I $D(DTOUT)!$D(DUOUT)!("DIA"'[Y) S IBOK=0 G INSIDQ + S IBDSP=Y,IBSORT="" + I IBDSP="A"!(IBDSP="I") F D Q:'IBOK!(IBSORT'="") + . N Z + . S Z=$S(IBDSP="I":"",1:" ID TYPE") + . S DIR("A")="DO YOU WANT TO DISPLAY IDS FOR A SPECIFIC PROVIDER"_Z_"?: ",DIR("B")="NO",DIR(0)="YA" + . S DIR("?",1)="IF YOU ANSWER YES TO THIS QUESTION, YOU MAY SELECT A SPECIFIC PROVIDER"_Z,DIR("?")=" TO DISPLAY, OTHERWISE, ALL PROVIDER"_Z_"S FOUND WILL BE DISPLAYED" + . W ! D ^DIR K DIR W ! + . I $D(DTOUT)!$D(DUOUT) S IBOK=0 Q + . I Y'=1 S IBSORT="ALL" Q + . ; + . I IBDSP="A" D Q + .. S DIC(0)="AEMQ",DIC="^IBE(355.97,",DIC("S")="I $S('$P(^(0),U,2):1,1:$P(^(0),U,2)=3)" D ^DIC K DIC + .. I Y>0 S IBSORT=+Y Q + .. I $D(DTOUT)!$D(DUOUT) S IBOK=0 + . ; + . I IBDSP="I" D Q + .. N DA + .. S DIR(0)="399.0222,.02A",DIR("A")="SELECT PROVIDER: " + .. W ! D ^DIR K DIR W ! + .. I Y>0 S IBSORT=Y Q + .. I $D(DTOUT)!$D(DUOUT) S IBOK=0 Q + . S IBOK=0 Q + ; + G:'IBOK INSIDQ + D BLD(IBINS,IBDSP,IBSORT) +INSIDQ I 'IBOK S VALMQUIT=1 + Q + ; +BLD(IBINS,IBDSP,IBSORT) ; Build display for Insurance co level provider ID's + N IB,IBENT,IBLCT,IBCT,IBPRV,IBSRT1,IBSRT2,IBOSRT1,IBOSRT2,CU,FT,PT,CT,Z,Z0 + K ^TMP("IBPRV_INS_ID",$J),^TMP("IBPRV_INS_SORT",$J) + ; + S (IBENT,IBCT,IBLCT)=0 + ; + I "DA"[$G(IBDSP) D + . S CU="" F S CU=$O(^IBA(355.91,"AUNIQ",IBINS,CU)) Q:CU="" S FT="" F S FT=$O(^IBA(355.91,"AUNIQ",IBINS,CU,FT)) Q:FT="" D + .. S CT="" F S CT=$O(^IBA(355.91,"AUNIQ",IBINS,CU,FT,CT)) Q:CT="" S PT=0 F S PT=$S(IBDSP="A"&IBSORT:IBSORT,1:$O(^IBA(355.91,"AUNIQ",IBINS,CU,FT,CT,PT))) Q:'PT D Q:IBDSP="A"&IBSORT + ... S Z=0 F S Z=$O(^IBA(355.91,"AUNIQ",IBINS,CU,FT,CT,PT,Z)) Q:'Z S IB=$G(^IBA(355.91,Z,0)) S ^TMP("IBPRV_INS_SORT",$J,PT,"^<>",FT,CT,CU,Z)=$P(IB,U,7)_U + ; + I "IA"[$G(IBDSP) D + . S IBPRV="" + . N IB1,IB2 + . F S IBPRV=$O(^IBA(355.9,"AE",IBINS,IBPRV)) Q:'IBPRV S Z=0 F S Z=$O(^IBA(355.9,"AE",IBINS,IBPRV,Z)) Q:'Z S IB=$G(^IBA(355.9,Z,0)) D + .. Q:$P(IB,U,4)=""!($P(IB,U,5)="")!($P(IB,U,6)="")!($P(IB,U,16)="") + .. I IBSORT,$S(IBDSP="I":IBPRV'=IBSORT,1:$P(IB,U,6)'=IBSORT) Q + .. S IB1=$S(IBDSP="A":$P(IB,U,6),1:U_$$EXPAND^IBTRE(355.9,.01,IBPRV)_U_IBPRV) + .. S IB2=$S(IBDSP="I":$P(IB,U,6),1:U_$$EXPAND^IBTRE(355.9,.01,IBPRV)_U_IBPRV) + .. S ^TMP("IBPRV_INS_SORT",$J,IB1,IB2,$P(IB,U,4),$P(IB,U,5),$P(IB,U,16),Z)=$P(IB,U,7)_U_IBPRV + ; + S IBOSRT1="" + S IBSRT1="" F S IBSRT1=$O(^TMP("IBPRV_INS_SORT",$J,IBSRT1)) Q:IBSRT1="" D + . S IBSRT2="",IBOSRT2="" + . F S IBSRT2=$O(^TMP("IBPRV_INS_SORT",$J,IBSRT1,IBSRT2)) Q:IBSRT2="" D + .. I IBOSRT1'=IBSRT1 D + ... I IBOSRT1'="" S IBLCT=IBLCT+1 D SET^VALM10(IBLCT," ",IBCT+1) + ... S IBLCT=IBLCT+1 D SET^VALM10(IBLCT,$S(IBDSP'="I":"ID Qualifier",1:"Provider")_": "_$S(IBDSP'="I":$$EXPAND^IBTRE(355.91,.06,IBSRT1),1:$P(IBSRT1,U,2_$S($P(IBSRT2,U,3)["VA(200":" (VA)",1:"(NON-VA)"))),IBCT+1) + ... S IBOSRT1=IBSRT1 + .. ; + .. S FT="" F S FT=$O(^TMP("IBPRV_INS_SORT",$J,IBSRT1,IBSRT2,FT)) Q:FT="" S CT="" F S CT=$O(^TMP("IBPRV_INS_SORT",$J,IBSRT1,IBSRT2,FT,CT)) Q:CT="" D + ... S CU="" F S CU=$O(^TMP("IBPRV_INS_SORT",$J,IBSRT1,IBSRT2,FT,CT,CU)) Q:CU="" S Z=0 F S Z=$O(^TMP("IBPRV_INS_SORT",$J,IBSRT1,IBSRT2,FT,CT,CU,Z)) Q:'Z S IB=$G(^(Z)) D + .... S IBLCT=IBLCT+1,IBCT=IBCT+1 + .... S Z0=$E(IBCT_$J("",4),1,4)_" " + .... I IBDSP'="I" S Z0=Z0_$E($S(IBOSRT2'=IBSRT2:$P(IBSRT2,U,2),1:"")_$J("",20),1,20) + .... I IBDSP="I" S Z0=Z0_$E($S(IBOSRT2'=IBSRT2:$$EXPAND^IBTRE(355.9,.06,IBSRT2),1:"")_$J("",20),1,20) + .... S IBOSRT2=IBSRT2 + .... S Z0=Z0_" "_$S(FT=1:"UB-04",FT=2:"1500 ",1:"BOTH ")_" "_$E($S(CT=3:"RX",CT=1:"INPT",CT=2:"OUTPT",1:"INPT/OUTPT")_$J("",11),1,11)_" "_$E($S(CU'="*N/A*":$P($G(^IBA(355.95,+$P($G(^IBA(355.96,+CU,0)),U),0)),U),1:"")_$J("",15),1,15) + .... D SET^VALM10(IBLCT,Z0_" "_$P(IB,U),IBCT) + .... S ^TMP("IBPRV_INS_ID",$J,"ZIDX",IBCT)=Z,^(IBCT,"PRV")=$P(IB,U,2) + .... I '$D(^TMP("IBPRV_INS_ID",$J,$S(IBDSP="I":"ZXPRV",1:"ZXPTYP"),IBSRT1)) S ^(IBSRT1)=IBLCT-1 + K ^TMP("IBPRV_INS_SORT",$J) + ; + I IBLCT=0 D G BLDQ ; No entries found + . D SET^VALM10(1," ") + . S Z=" No "_$S(IBDSP="D":"default ",1:"") + . S Z=Z_"ID's found for "_$S(IBDSP="I":"provider "_$S(IBSORT:"("_$$EXPAND^IBTRE(355.9,.01,IBSORT)_") ",1:"")_"and ",IBDSP="A":"provider type "_$S(IBSORT:"("_$$EXPAND^IBTRE(355.9,.06,IBSORT)_") ",1:"")_"and ",1:"")_"insurance co" + . D SET^VALM10(2,Z) + . S IBLCT=2 + ; +BLDQ S VALMCNT=IBLCT,VALMBG=1 + Q + ; +EXPND ; + Q + ; +HELP ; + Q + ; +EXIT ; + K IBFASTXT + D COPYPROV^IBCEP5A(IBINS) + K ^TMP("IBPRV_INS_ID",$J) + D CLEAN^VALM10 + Q + ; +SEL(IBDA,MANY) ; Select from provider id list + ; IBDA is passed by reference and IBDA(1) returned containing + ; ien's of the provider id records selected (file 355.9). + ; If > 1 entry can be selected, MANY is set to 1 + N Z + S IBDA=0 + D EN^VALM2($G(XQORNOD(0)),$S($G(MANY):"",1:"S")) + S Z=0 F S Z=$O(VALMY(Z)) Q:'Z S IBDA=IBDA+1,IBDA(IBDA)=+$G(^TMP("IBPRV_INS_ID",$J,"ZIDX",Z))_U_$G(^(Z,"PRV")) + Q + ; +ENX(IBINS1) ; Insurance co level defaults for all providers or + ; for all providers by care unit + N DIC,DIE,DR,DA,X,Y,DLAYGO + I '$G(IBINS1) D G:'$G(IBINS1) ENQ + . S DIC="^IBA(355.91,",DIC(0)="AELMQ",DLAYGO=355.91 D ^DIC + . I Y>0 S IBINS1=+Y + S DIE="^IBA(355.91,",DA=IBINS1,DR=".01;.06;.04;.05;.03;.07" D ^DIE + ; +ENQ Q + ; +PPTYP(IBINS) ; Returns the ien of the default performing provider type for + ; insurance company IBINS (ien file 36) + Q +$G(^DIC(36,+IBINS,4)) + ; +SCREEN(WHICH) ; This screen is used the menu protocol to screen out the ID functions if it is a child ins co + Q:'$G(DA) 0 + Q:'$G(DA(1)) 0 + N FILE,IENS,FIELD,FLAG,TARGET + S FILE=101.01,IENS=DA_","_DA(1),FIELD=".01",FLAG="I" + D GETS^DIQ(FILE,IENS,FIELD,FLAG,"TARGET") + Q:'$D(TARGET) 0 + N IEN + S IEN=$G(TARGET(FILE,IENS_",",FIELD,FLAG)) + Q:'+IEN 0 + S FILE=101,FIELD=1,FLAG="E" + K TARGET + D GETS^DIQ(FILE,IEN,FIELD,FLAG,"TARGET") + Q:'$D(TARGET) 0 + I $G(TARGET(FILE,IEN_",",FIELD,FLAG))'[WHICH Q 1 + Q:'$G(IBINS) 0 + N PCF + S PCF=$P($G(^DIC(36,+IBINS,3)),U,13) + I PCF="C" Q 0 + Q 1 diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP0A.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP0A.m index d0aebc0d..e88cea41 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP0A.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP0A.m @@ -1,182 +1,180 @@ -IBCEP0A ;ALB/TMP - EDI UTILITIES for insurance assigned provider ID ;01-NOV-00 - ;;2.0;INTEGRATED BILLING;**137,232,320,377**;21-MAR-94;Build 23 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -NEW(IBINS,IBPRV,IBPTYP,IBDEF) ; Add new insurance co assigned id - ; IBDEF = flag sent as 1 if only insurance co defaults are being added - N DIC,DIR,X,Y,Z,DA,DR,DIE,DO,DD,DLAYGO,IBQ,IBIEN,IBCUND,DTOUT,DUOUT - D FULL^VALM1 - S IBQ=0 - I $G(IBDEF)="D" W !!,"YOU ARE ADDING A PROVIDER ID THAT WILL BE THE INSURANCE CO DEFAULT",! - I '$G(IBPRV),$G(IBDEF)'="D" D G:IBQ NEWQ - . N DA,IBO - . S IBO=($G(IBDSP)'="I") - . S DIR(0)="355.9,.01A"_$S(IBO:"O",1:""),DIR("A")="Select PROVIDER"_$S(IBO:" (optional)",1:"")_": " - . S DIR("?")="Select the PROVIDER to be assigned a provider ID" - . I IBO S DIR("?",1)=DIR("?"),DIR("?")="Or Press ENTER to add an insurance co level default id (all providers)" - . W ! D ^DIR K DIR W ! - . I $D(DTOUT)!$D(DUOUT) S IBQ=1 Q - . S IBPRV=$S(Y>0:$P(Y,U),1:"") - . Q:IBPRV - . S DIR(0)="YA",DIR("B")="YES",DIR("A",1)="YOU ARE ADDING A PROVIDER ID THAT WILL BE THE INSURANCE CO DEFAULT",DIR("A")="IS THIS OK?: " - . W ! D ^DIR K DIR W ! - . I $D(DTOUT)!$D(DUOUT)!(Y'=1) S IBQ=1 - . Q - ; - I '$G(IBPTYP) D G:IBQ NEWQ - . S DIR(0)="PAr^355.97:AEMQ",DIR("A")="Select Provider ID Qualifier: " - . S DIR("?")="Enter a Qualifier to identify the type of ID number you are entering." - . S DIR("S")="I $$RAINS^IBCEPU(Y)" ; Rendering/Attending IDs provided by ins - . S DA=0 - . W ! D ^DIR K DIR W ! - . I $D(DTOUT)!$D(DUOUT)!'Y S IBQ=1 Q - . S IBPTYP=+Y - ; - S IBQ=$$ADDID(IBINS,IBPRV,IBPTYP) - ; -NEWQ D:'$G(IBQ) BLD^IBCEP0($G(IBINS),$G(IBDSP),$G(IBSORT)) - S VALMBCK="R" - Q - ; -DEL1 ; Delete Insurance Co assigned provider ID's - ; IBPRV = vp ien of provider if editing entry in file 355.9 - ; otherwise, null - N IB1,IBDA,IBFILE - D FULL^VALM1 - D SEL^IBCEP0(.IBDA) - G:'$O(IBDA(0)) DEL1Q - S IBDA=+$O(IBDA("")),IBDA=$G(IBDA(IBDA)) - G:'IBDA DEL1Q - S IB1=$P(IBDA,U,2),IBDA=+IBDA - S IBFILE=$S(IB1:355.9,1:355.91) - I IBDA>0 D DEL^IBCEP5B(IBFILE,IBDA,1),BLD^IBCEP0($G(IBINS),$G(IBDSP),$G(IBSORT)) - ; -DEL1Q S VALMBCK="R" - Q - ; -CHG1 ; Edit Provider ID's - N IBDA,IB1,IBFILE - D FULL^VALM1 - D SEL^IBCEP0(.IBDA) - G:'$O(IBDA(0)) CHG1Q - S IBDA=+$O(IBDA("")),IBDA=$G(IBDA(IBDA)) - G:'IBDA CHG1Q - S IB1=$P(IBDA,U,2),IBDA=+IBDA - S IBFILE=$S(IB1:355.9,1:355.91) - I IBDA>0 D - . I IBFILE=355.9 W !!,"PROVIDER: ",$$EXPAND^IBTRE(355.9,.01,IB1) - . I IBFILE'=355.9 W !!," <>" - . D CHG^IBCEP5B(IBFILE,IBDA),BLD^IBCEP0($G(IBINS),$G(IBDSP),$G(IBSORT)) - ; -CHG1Q S VALMBCK="R" - Q - ; -PRVJMP(IBDSP) ; Navigate to a specific sort level in current LM list - ; (from insurance co option) - ; IBDSP = 'I', 'A' or 'D' to indicate format selected for display - ; ([P]ROVIDER, PROVIDER [T]YPE OR [I]NSURANCE DEFAULT) - ; Sets VALMBG = LINE # if a provider in list selected - ; - I $G(IBDSP)="I" D PRVNJMP(.VALMBG) - I $G(IBDSP)="D"!($G(IBDSP)="A") D PRVTJMP(.VALMBG) - S VALMBCK="R" - Q - ; -PRVNJMP(VALMBG) ; Navigate to a specific provider name (from insurance co - ; option) - ; - N DIR,X,Y,DA - D FULL^VALM1 - S DIR(0)="355.9,.01AO^^I '$D(^TMP(""IBPRV_INS_ID"",$J,""ZXPRV"",U_$$EXPAND^IBTRE(355.9,.01,Y)_U_$P(Y,U))) K X" - S DIR("?",1)="*** YOU MAY ONLY SELECT PROVIDERS INCLUDED IN THE CURRENT LIST ***",DIR("?",2)=" ",DIR("?",3)="SELECTING A PROVIDER WILL FORCE THE DISPLAY TO SKIP TO THE DATA FOR THAT",DIR("?")=" PROVIDER" - S DIR("A")="SELECT PROVIDER: " - S DIR("S")="N Z S Z=$P(^(0),U) I $D(^TMP(""IBPRV_INS_ID"",$J,""ZXPRV"",U_$$EXPAND^IBTRE(355.9,.01,Z)_U_Z))" - W ! D ^DIR K DIR W ! - I Y>0,'$D(DTOUT),'$D(DUOUT) D - . N Z - . S Z=$G(^TMP("IBPRV_INS_ID",$J,"ZXPRV",U_$$EXPAND^IBTRE(355.9,.01,$P(Y,U))_U_$P(Y,U))) - . I Z S VALMBG=Z Q - . S DIR(0)="EA",DIR("A",1)="THIS PROVIDER DOES NOT EXIST IN THE CURRENT DISPLAY",DIR("A")="PRESS THE ENTER KEY TO CONTINUE" - . W ! D ^DIR K DIR W ! - Q - ; -PRVTJMP(VALMBG) ; Navigate to a specific type of ID qualifier (from ins co option) - ; - N DIR,X,Y - D FULL^VALM1 - S DIR(0)="PAO^355.97:AEMQ",DIR("A")="Select type of ID Qualifier: " - S DIR("?")="Select a type of ID Qualifier to display the IDs of that type." - S DIR("S")="I $D(^TMP(""IBPRV_INS_ID"",$J,""ZXPTYP"",+Y))" - W ! D ^DIR K DIR W ! - I Y>0,'$D(DTOUT),'$D(DUOUT) D - . N Z - . S Z=$G(^TMP("IBPRV_INS_ID",$J,"ZXPTYP",+Y)) - . I Z S VALMBG=Z Q - . S DIR(0)="EA",DIR("A",1)="This type of ID Qualifier does not exist in the current display",DIR("A")="Press the Enter key to continue" - . W ! D ^DIR K DIR W ! - Q - ; -CHGINS ; Change insurance co being displayed, using the same or new params - ; Assumes IBINS exists = IEN of insurance co (file 36) - N IBINEW,IBSAVE,DIC,DA,Y,X,DIR - D FULL^VALM1 - S DIC="^DIC(36,",DIC(0)="AEMQ" D ^DIC - S IBINEW=+Y - ; - I IBINEW>0,IBINS'=IBINEW D - . D COPYPROV^IBCEP5A(IBINS) - . S DIR(0)="YA",DIR("?")="IF YOU WANT TO CHANGE THE FORMAT OF THE DISPLAY, RESPOND NO HERE" - . S DIR("A")="DO YOU WANT TO DISPLAY THE NEW INS. CO IDS USING THE CURRENT DISPLAY FORMAT?: ",DIR("B")="YES" W ! D ^DIR W ! K DIR - . Q:Y'=1 - . S IBSAVE("IBINS")=IBINS - . K ^TMP("IBPRV_INS_ID",$J),VALMHDR S VALMBG=1,IBINS=IBINEW - . I Y=1 D BLD^IBCEP0($G(IBINS),$G(IBDSP),$G(IBSORT)) Q - . D INIT^IBCEP0 - . I '$G(VALMQUIT) Q - . S IBINS=IBSAVE("IBINS") D BLD^IBCEP0($G(IBINS),$G(IBDSP),$G(IBSORT)) - S VALMBCK="R" - Q - ; -CHGFMT ; Change format parameters for display - N IBSAVE - S IBSAVE("IBINS")=$G(IBINS) - D INIT^IBCEP0 - I '$G(VALMQUIT) G CHGFMTQ - S IBINS=IBSAVE("IBINS") D BLD^IBCEP0($G(IBINS),$G(IBDSP),$G(IBSORT)) -CHGFMTQ S VALMBCK="R" - Q - ; -IPARAM ; Display Insurance co parameters and care unit requirements - ; Assumes IBINS exists = IEN of insurance co - N IBDSP,IBSORT,IBHOLD - D FULL^VALM1 - S IBHOLD("IBINS")=$G(IBINS) - D EN^VALM("IBCE PRVINS PARAM DISPLAY") - S:$G(IBHOLD("IBINS"))'="" IBINS=IBHOLD("IBINS") - K VALMQUIT - S VALMBCK="R" - Q - ; -ADDID(IBINS,IBPRV,IBPTYP) ; Adds a new ID for the provider and/or ins co - ; IBINS = ien of file 36 - ; IBPRV = vp ien of file 355.9 - ; IBPTYP = ien of file 355.97 - ; FUNCTION returns 1 if record not added, 0 if filed OK - N IBIEN,IBQ,DIC,DA,DO,DD,DLAYGO,X,Y - S IBQ=0 - I $G(IBPRV) D G:IBQ ADDIDQ - . ; Provider specific for insurance co - add to file 355.9 - . S DIC(0)="L",DLAYGO=355.9,DIC="^IBA(355.9,",X=IBPRV - . S:$G(IBINS) DIC("DR")=".02////"_IBINS - . D FILE^DICN K DIC,DLAYGO,DD,DO - . I Y'>0!$D(DUOUT)!$D(DTOUT) S IBIEN=0,IBQ=1 Q - . S IBIEN=+Y - . D NEWID^IBCEP5B(355.9,IBINS,IBPRV,IBPTYP,IBIEN,"") - E D - . ; Insurance co default - add to file 355.91 - . S DIC(0)="L",DLAYGO=355.91,DIC="^IBA(355.91,",X=IBINS - . D FILE^DICN K DIC,DLAYGO,DD,DO - . I Y'>0!$D(DUOUT)!$D(DTOUT) S IBIEN=0,IBQ=1 Q - . S IBIEN=+Y - . D NEWID^IBCEP5B(355.91,IBINS,"",IBPTYP,IBIEN,1) -ADDIDQ Q IBQ +IBCEP0A ;ALB/TMP - EDI UTILITIES for insurance assigned provider ID ;01-NOV-00 + ;;2.0;INTEGRATED BILLING;**137,232,320**;21-MAR-94 + ; +NEW(IBINS,IBPRV,IBPTYP,IBDEF) ; Add new insurance co assigned id + ; IBDEF = flag sent as 1 if only insurance co defaults are being added + N DIC,DIR,X,Y,Z,DA,DR,DIE,DO,DD,DLAYGO,IBQ,IBIEN,IBCUND,DTOUT,DUOUT + D FULL^VALM1 + S IBQ=0 + I $G(IBDEF)="D" W !!,"YOU ARE ADDING A PROVIDER ID THAT WILL BE THE INSURANCE CO DEFAULT",! + I '$G(IBPRV),$G(IBDEF)'="D" D G:IBQ NEWQ + . N DA,IBO + . S IBO=($G(IBDSP)'="I") + . S DIR(0)="355.9,.01A"_$S(IBO:"O",1:""),DIR("A")="Select PROVIDER"_$S(IBO:" (optional)",1:"")_": " + . S DIR("?")="Select the PROVIDER to be assigned a provider ID" + . I IBO S DIR("?",1)=DIR("?"),DIR("?")="Or Press ENTER to add an insurance co level default id (all providers)" + . W ! D ^DIR K DIR W ! + . I $D(DTOUT)!$D(DUOUT) S IBQ=1 Q + . S IBPRV=$S(Y>0:$P(Y,U),1:"") + . Q:IBPRV + . S DIR(0)="YA",DIR("B")="YES",DIR("A",1)="YOU ARE ADDING A PROVIDER ID THAT WILL BE THE INSURANCE CO DEFAULT",DIR("A")="IS THIS OK?: " + . W ! D ^DIR K DIR W ! + . I $D(DTOUT)!$D(DUOUT)!(Y'=1) S IBQ=1 + . Q + ; + I '$G(IBPTYP) D G:IBQ NEWQ + . S DIR(0)="PAr^355.97:AEMQ",DIR("A")="Select Provider ID Qualifier: " + . S DIR("?")="Enter a Qualifier to indentify the type of ID number you are entering." + . S DIR("S")="I $$RAINS^IBCEPU(Y)" ; Rendering/Attending IDs provided by ins + . S DA=0 + . W ! D ^DIR K DIR W ! + . I $D(DTOUT)!$D(DUOUT)!'Y S IBQ=1 Q + . S IBPTYP=+Y + ; + S IBQ=$$ADDID(IBINS,IBPRV,IBPTYP) + ; +NEWQ D:'$G(IBQ) BLD^IBCEP0($G(IBINS),$G(IBDSP),$G(IBSORT)) + S VALMBCK="R" + Q + ; +DEL1 ; Delete Insurance Co assigned provider ID's + ; IBPRV = vp ien of provider if editing entry in file 355.9 + ; otherwise, null + N IB1,IBDA,IBFILE + D FULL^VALM1 + D SEL^IBCEP0(.IBDA) + G:'$O(IBDA(0)) DEL1Q + S IBDA=+$O(IBDA("")),IBDA=$G(IBDA(IBDA)) + G:'IBDA DEL1Q + S IB1=$P(IBDA,U,2),IBDA=+IBDA + S IBFILE=$S(IB1:355.9,1:355.91) + I IBDA>0 D DEL^IBCEP5B(IBFILE,IBDA,1),BLD^IBCEP0($G(IBINS),$G(IBDSP),$G(IBSORT)) + ; +DEL1Q S VALMBCK="R" + Q + ; +CHG1 ; Edit Provider ID's + N IBDA,IB1,IBFILE + D FULL^VALM1 + D SEL^IBCEP0(.IBDA) + G:'$O(IBDA(0)) CHG1Q + S IBDA=+$O(IBDA("")),IBDA=$G(IBDA(IBDA)) + G:'IBDA CHG1Q + S IB1=$P(IBDA,U,2),IBDA=+IBDA + S IBFILE=$S(IB1:355.9,1:355.91) + I IBDA>0 D + . I IBFILE=355.9 W !!,"PROVIDER: ",$$EXPAND^IBTRE(355.9,.01,IB1) + . I IBFILE'=355.9 W !!," <>" + . D CHG^IBCEP5B(IBFILE,IBDA),BLD^IBCEP0($G(IBINS),$G(IBDSP),$G(IBSORT)) + ; +CHG1Q S VALMBCK="R" + Q + ; +PRVJMP(IBDSP) ; Navigate to a specific sort level in current LM list + ; (from insurance co option) + ; IBDSP = 'I', 'A' or 'D' to indicate format selected for display + ; ([P]ROVIDER, PROVIDER [T]YPE OR [I]NSURANCE DEFAULT) + ; Sets VALMBG = LINE # if a provider in list selected + ; + I $G(IBDSP)="I" D PRVNJMP(.VALMBG) + I $G(IBDSP)="D"!($G(IBDSP)="A") D PRVTJMP(.VALMBG) + S VALMBCK="R" + Q + ; +PRVNJMP(VALMBG) ; Navigate to a specific provider name (from insurance co + ; option) + ; + N DIR,X,Y,DA + D FULL^VALM1 + S DIR(0)="355.9,.01AO^^I '$D(^TMP(""IBPRV_INS_ID"",$J,""ZXPRV"",U_$$EXPAND^IBTRE(355.9,.01,Y)_U_$P(Y,U))) K X" + S DIR("?",1)="*** YOU MAY ONLY SELECT PROVIDERS INCLUDED IN THE CURRENT LIST ***",DIR("?",2)=" ",DIR("?",3)="SELECTING A PROVIDER WILL FORCE THE DISPLAY TO SKIP TO THE DATA FOR THAT",DIR("?")=" PROVIDER" + S DIR("A")="SELECT PROVIDER: " + S DIR("S")="N Z S Z=$P(^(0),U) I $D(^TMP(""IBPRV_INS_ID"",$J,""ZXPRV"",U_$$EXPAND^IBTRE(355.9,.01,Z)_U_Z))" + W ! D ^DIR K DIR W ! + I Y>0,'$D(DTOUT),'$D(DUOUT) D + . N Z + . S Z=$G(^TMP("IBPRV_INS_ID",$J,"ZXPRV",U_$$EXPAND^IBTRE(355.9,.01,$P(Y,U))_U_$P(Y,U))) + . I Z S VALMBG=Z Q + . S DIR(0)="EA",DIR("A",1)="THIS PROVIDER DOES NOT EXIST IN THE CURRENT DISPLAY",DIR("A")="PRESS THE ENTER KEY TO CONTINUE" + . W ! D ^DIR K DIR W ! + Q + ; +PRVTJMP(VALMBG) ; Navigate to a specific provider id type (from ins co option) + ; + N DIR,X,Y + D FULL^VALM1 + S DIR(0)="PAO^355.97:AEMQ",DIR("A")="SELECT PROVIDER ID TYPE: ",DIR("?",1)="SELECTING A PROVIDER ID TYPE WILL FORCE THE DISPLAY TO SKIP TO THE DATA FOR ",DIR("?")=" THAT PROVIDER ID TYPE" + S DIR("S")="I $D(^TMP(""IBPRV_INS_ID"",$J,""ZXPTYP"",+Y))" + W ! D ^DIR K DIR W ! + I Y>0,'$D(DTOUT),'$D(DUOUT) D + . N Z + . S Z=$G(^TMP("IBPRV_INS_ID",$J,"ZXPTYP",+Y)) + . I Z S VALMBG=Z Q + . S DIR(0)="EA",DIR("A",1)="THIS PROVIDER ID TYPE DOES NOT EXIST IN THE CURRENT DISPLAY",DIR("A")="PRESS THE ENTER KEY TO CONTINUE" + . W ! D ^DIR K DIR W ! + Q + ; +CHGINS ; Change insurance co being displayed, using the same or new params + ; Assumes IBINS exists = IEN of insurance co (file 36) + N IBINEW,IBSAVE,DIC,DA,Y,X,DIR + D FULL^VALM1 + S DIC="^DIC(36,",DIC(0)="AEMQ" D ^DIC + S IBINEW=+Y + ; + I IBINEW>0,IBINS'=IBINEW D + . D COPYPROV^IBCEP5A(IBINS) + . S DIR(0)="YA",DIR("?")="IF YOU WANT TO CHANGE THE FORMAT OF THE DISPLAY, RESPOND NO HERE" + . S DIR("A")="DO YOU WANT TO DISPLAY THE NEW INS. CO IDS USING THE CURRENT DISPLAY FORMAT?: ",DIR("B")="YES" W ! D ^DIR W ! K DIR + . Q:Y'=1 + . S IBSAVE("IBINS")=IBINS + . K ^TMP("IBPRV_INS_ID",$J),VALMHDR S VALMBG=1,IBINS=IBINEW + . I Y=1 D BLD^IBCEP0($G(IBINS),$G(IBDSP),$G(IBSORT)) Q + . D INIT^IBCEP0 + . I '$G(VALMQUIT) Q + . S IBINS=IBSAVE("IBINS") D BLD^IBCEP0($G(IBINS),$G(IBDSP),$G(IBSORT)) + S VALMBCK="R" + Q + ; +CHGFMT ; Change format parameters for display + N IBSAVE + S IBSAVE("IBINS")=$G(IBINS) + D INIT^IBCEP0 + I '$G(VALMQUIT) G CHGFMTQ + S IBINS=IBSAVE("IBINS") D BLD^IBCEP0($G(IBINS),$G(IBDSP),$G(IBSORT)) +CHGFMTQ S VALMBCK="R" + Q + ; +IPARAM ; Display Insurance co parameters and care unit requirements + ; Assumes IBINS exists = IEN of insurance co + N IBDSP,IBSORT,IBHOLD + D FULL^VALM1 + S IBHOLD("IBINS")=$G(IBINS) + D EN^VALM("IBCE PRVINS PARAM DISPLAY") + S:$G(IBHOLD("IBINS"))'="" IBINS=IBHOLD("IBINS") + K VALMQUIT + S VALMBCK="R" + Q + ; +ADDID(IBINS,IBPRV,IBPTYP) ; Adds a new ID for the provider and/or ins co + ; IBINS = ien of file 36 + ; IBPRV = vp ien of file 355.9 + ; IBPTYP = ien of file 355.97 + ; FUNCTION returns 1 if record not added, 0 if filed OK + N IBIEN,IBQ,DIC,DA,DO,DD,DLAYGO,X,Y + S IBQ=0 + I $G(IBPRV) D G:IBQ ADDIDQ + . ; Provider specific for insurance co - add to file 355.9 + . S DIC(0)="L",DLAYGO=355.9,DIC="^IBA(355.9,",X=IBPRV + . S:$G(IBINS) DIC("DR")=".02////"_IBINS + . D FILE^DICN K DIC,DLAYGO,DD,DO + . I Y'>0!$D(DUOUT)!$D(DTOUT) S IBIEN=0,IBQ=1 Q + . S IBIEN=+Y + . D NEWID^IBCEP5B(355.9,IBINS,IBPRV,IBPTYP,IBIEN,"") + E D + . ; Insurance co default - add to file 355.91 + . S DIC(0)="L",DLAYGO=355.91,DIC="^IBA(355.91,",X=IBINS + . D FILE^DICN K DIC,DLAYGO,DD,DO + . I Y'>0!$D(DUOUT)!$D(DTOUT) S IBIEN=0,IBQ=1 Q + . S IBIEN=+Y + . D NEWID^IBCEP5B(355.91,IBINS,"",IBPTYP,IBIEN,1) +ADDIDQ Q IBQ diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP4.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP4.m index a6c45988..1caca012 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP4.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP4.m @@ -1,128 +1,128 @@ -IBCEP4 ;ALB/TMP - EDI UTILITIES for provider ID ;29-SEP-00 - ;;2.0;INTEGRATED BILLING;**137,320,348,349,377**;21-MAR-94;Build 23 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -EN ; -- main entry point - N IBINS,IBALL,IB95 - D ENX - Q - ; -EN1(IBINS) ; -- Entry point from provider number maintenence - N IBPRV,IBALL,IB95 - S VALMBCK="R" - D ENX - Q - ; -ENX ; Common call to list template for dual entry points - N IBSLEV,DIR,Y - K IBFASTXT - D FULL^VALM1 - S DIR(0)="SA^1:Performing Provider Care Units;2:Billing Provider Care Units" - S DIR("A")="Enter Type of Care Unit: ",DIR("B")=$P($P(DIR(0),":",2),";",1) - W ! D ^DIR K DIR W ! - I Y'>0 Q - S IBSLEV=+Y - I IBSLEV=2 D EN^VALM("IBCE 2ND PRVID CARE UNIT MAINT") Q - D EN^VALM("IBCE PRVCARE UNIT MAINT") - Q - ; -HDR ; -- header - K VALMHDR - S VALMHDR(1)=" " - S VALMHDR(2)="Insurance Co: "_$S('$G(IBALL)&$G(IBINS):$P($G(^DIC(36,+IBINS,0)),U),1:"ALL") - Q - ; -INIT ; -- init variables, list array - N Z,IB,IBLCT,IBENT,IBNM,IB0,Z0,Z1,IBQ,DIR,Y,X - I $G(IBINS) S Y=IBINS ; For entrypoint from provider number maintenance - ; - I '$G(IBINS) D - . S DIR(0)="PA^DIC(36,:AEMQ",DIR("A")="Select INSURANCE CO: ",DIR("?")="Select an INSURANCE CO to display its care units" - . D ^DIR K DIR - . I $D(DTOUT)!$D(DUOUT) S Y=-2 Q - . I Y>0 S IBINS=+Y Q - ; - I Y'=-2 D - . D BLD - E D - . S VALMQUIT=1 - Q - ; -BLD ; Bld display - IBINS must = ien of file 36 - K ^TMP("IBPRV_CU",$J) - ; - I $G(IBSLEV)=2 Q - ; - S (IBENT,IBLCT)=0,IBNM="" - F S IBNM=$O(^IBA(355.95,"C",IBINS,IBNM)) Q:IBNM="" S Z=0 F S Z=$O(^IBA(355.95,"C",IBINS,IBNM,Z)) Q:'Z S IB=$G(^IBA(355.95,Z,0)) I IB'="",$P(IB,U,4)="" D - . S IBLCT=IBLCT+1,IBENT=IBENT+1 - . I '$D(^IBA(355.96,"AUNIQ",IBINS,Z)) D SET^VALM10(IBLCT,$E(IBENT_" ",1,4)_$E($P(IB,U)_$J("",30),1,30)_" "_$E($P(IB,U,2)_$J("",20),1,20)_" (NO COMBINATIONS FOUND)",IBENT) Q - . D SET^VALM10(IBLCT,$E(IBENT_" ",1,4)_$E($P(IB,U)_$J("",30),1,30)_" "_$E($P(IB,U,2)_$J("",20),1,20),IBENT) - . S ^TMP("IBPRV_CU",$J,"ZIDX",IBENT)=Z - . S Z0=0 F S Z0=$O(^IBA(355.96,"AE",Z,Z0)) Q:'Z0 S Z1=0 F S Z1=$O(^IBA(355.96,"AE",Z,Z0,Z1)) Q:'Z1 S IB0=$G(^IBA(355.96,Z1,0)) I IB0'="" D - .. S IBLCT=IBLCT+1 - .. S IBQ=$J("",28)_"o "_$E($$EXPAND^IBTRE(355.96,.06,+$P(IB0,U,6))_$J("",20),1,20) - .. S IBQ=IBQ_" "_$E($P("Both form types^UB-04 Only^CMS-1500 Only",U,$P(IB0,U,4)+1)_$J("",15),1,15)_" "_$E($P("Inpt/Outpt^Inpt Only^Outpt Only^RX Only",U,+$P(IB0,U,5)+1)_$J("",10),1,10) - .. D SET^VALM10(IBLCT,IBQ,IBENT) - ; - I 'IBLCT D SET^VALM10(1,"No CARE UNITs Found"_$S('$G(IBINS):"",1:" for Insurance Co")) S IBLCT=1 - S VALMCNT=IBLCT,VALMBG=1 - Q - ; -HELP ; -- help - ; - I $G(IBSLEV)=2 Q - ; - S X="?" D DISP^XQORM1 W !! - Q - ; -EXIT ; -- exit - D CLEAN^VALM10 - K ^TMP("IBPRV_CU",$J),IBINS,IBALL - Q - ; -EXPND ; - Q - ; -SEL(IBDA,MANY) ; Select from care unit list - ; IBDA is passed by reference and IBDA(1) returned containing - ; ien's of the care unit selected (file 355.95). - ; If > 1 entry can be selected, MANY is set to 1 - N Z - S IBDA=0 - D EN^VALM2($G(XQORNOD(0)),$S($G(MANY):"",1:"S")) - S Z=0 F S Z=$O(VALMY(Z)) Q:'Z S IBDA=IBDA+1,IBDA(IBDA)=+$G(^TMP("IBPRV_CU",$J,"ZIDX",Z)) - Q - ; -DISP(IBVAR,IBINS,IBPTYP,IBFT,IBCT,START,END) ; Set up display array for - ; provider id - N Z - S START=$S($G(START):START,1:1) - S (Z,END)=$G(START) - S @IBVAR@(START)="INSURANCE: "_$S(IBINS:$P($G(^DIC(36,+IBINS,0)),U),1:"ALL INSURANCE") - S @IBVAR@(START+1)="PROV TYPE: "_$$EXPAND^IBTRE(355.96,.06,IBPTYP) - S @IBVAR@(START+2)="FORM TYPE: "_$$EXPAND^IBTRE(355.96,.04,IBFT) - S @IBVAR@(START+3)="CARE TYPE: "_$$EXPAND^IBTRE(355.96,.05,IBCT) - S END=$G(START)+3 - Q - ; -CAREUOK(IBIFN,IBCU,IBTYPE,IBSEQ) ; Returns 1 if care unit is appropriate - ; for bill based on provider type, care type, bill type and insurance co - ; IBIFN = ien of bill (file 399) - ; IBCU = the ien of the care unit (file 355.96) - ; IBTYPE = type of ID being checked (1=performing, 2=EMC) - ; IBSEQ = the COB seq being checked (1-3) - N Z,IBOK,IBINS,IBCT,IBFT,IBPTYP,IBRX - S IBOK=0 - S IBINS=+$$FINDINS^IBCEF1(IBIFN,+IBSEQ),IBFT=$S($$FT^IBCEF(IBIFN)=2:2,1:1) - S IBPTYP=+$S(IBTYPE=1:$$PPTYP^IBCEP0(IBINS),1:$$EMCID^IBCEP()) - S IBRX=$$ISRX^IBCEF1(IBIFN) - S IBCT=$S('IBRX:$S($$INPAT^IBCEF(IBIFN,1):1,1:2),1:3) - ;Check from most general to most specific - I $D(^IBA(355.96,"AD",IBINS,0,0,IBPTYP,IBCU)) S IBOK=1 G CAREOKQ - I 'IBRX,$D(^IBA(355.96,"AD",IBINS,IBFT,0,IBPTYP,IBCU)) S IBOK=1 G CAREOKQ - I $D(^IBA(355.96,"AD",IBINS,0,IBCT,IBPTYP,IBCU)) S IBOK=1 G CAREOKQ - I $D(^IBA(355.96,"AD",IBINS,IBFT,IBCT,IBPTYP,IBCU)) S IBOK=1 G CAREOKQ - ; -CAREOKQ Q IBOK - ; +IBCEP4 ;ALB/TMP - EDI UTILITIES for provider ID ;29-SEP-00 + ;;2.0;INTEGRATED BILLING;**137,320,348,349**;21-MAR-94;Build 46 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; +EN ; -- main entry point + N IBINS,IBALL,IB95 + D ENX + Q + ; +EN1(IBINS) ; -- Entry point from provider number maintenence + N IBPRV,IBALL,IB95 + D ENX + Q + ; +ENX ; Common call to list template for dual entry points + N IBSLEV,DIR,Y + K IBFASTXT + D FULL^VALM1 + S DIR(0)="SA^1:Care Units for Performing Provider IDs;2:Care Units for Billing Provider Secondary IDs" + S DIR("A")="Enter Type of Care Unit: ",DIR("B")=$P($P(DIR(0),":",2),";") + W ! D ^DIR K DIR W ! + I Y'>0 Q + S IBSLEV=+Y + I IBSLEV=2 D EN^VALM("IBCE 2ND PRVID CARE UNIT MAINT") Q + D EN^VALM("IBCE PRVCARE UNIT MAINT") + Q + ; +HDR ; -- header + K VALMHDR + S VALMHDR(1)=" " + S VALMHDR(2)="Insurance Co: "_$S('$G(IBALL)&$G(IBINS):$P($G(^DIC(36,+IBINS,0)),U),1:"ALL") + Q + ; +INIT ; -- init variables, list array + N Z,IB,IBLCT,IBENT,IBNM,IB0,Z0,Z1,IBQ,DIR,Y,X + I $G(IBINS) S Y=IBINS ; For entrypoint from provider number maintenance + ; + I '$G(IBINS) D + . S DIR(0)="PA^DIC(36,:AEMQ",DIR("A")="Select INSURANCE CO: ",DIR("?")="Select an INSURANCE CO to display its care units" + . D ^DIR K DIR + . I $D(DTOUT)!$D(DUOUT) S Y=-2 Q + . I Y>0 S IBINS=+Y Q + ; + I Y'=-2 D + . D BLD + E D + . S VALMQUIT=1 + Q + ; +BLD ; Bld display - IBINS must = ien of file 36 + K ^TMP("IBPRV_CU",$J) + ; + I $G(IBSLEV)=2 Q + ; + S (IBENT,IBLCT)=0,IBNM="" + F S IBNM=$O(^IBA(355.95,"C",IBINS,IBNM)) Q:IBNM="" S Z=0 F S Z=$O(^IBA(355.95,"C",IBINS,IBNM,Z)) Q:'Z S IB=$G(^IBA(355.95,Z,0)) I IB'="",$P(IB,U,4)="" D + . S IBLCT=IBLCT+1,IBENT=IBENT+1 + . I '$D(^IBA(355.96,"AUNIQ",IBINS,Z)) D SET^VALM10(IBLCT,$E(IBENT_" ",1,4)_$E($P(IB,U)_$J("",30),1,30)_" "_$E($P(IB,U,2)_$J("",20),1,20)_" (NO COMBINATIONS FOUND)",IBENT) Q + . D SET^VALM10(IBLCT,$E(IBENT_" ",1,4)_$E($P(IB,U)_$J("",30),1,30)_" "_$E($P(IB,U,2)_$J("",20),1,20),IBENT) + . S ^TMP("IBPRV_CU",$J,"ZIDX",IBENT)=Z + . S Z0=0 F S Z0=$O(^IBA(355.96,"AE",Z,Z0)) Q:'Z0 S Z1=0 F S Z1=$O(^IBA(355.96,"AE",Z,Z0,Z1)) Q:'Z1 S IB0=$G(^IBA(355.96,Z1,0)) I IB0'="" D + .. S IBLCT=IBLCT+1 + .. S IBQ=$J("",28)_"o "_$E($$EXPAND^IBTRE(355.96,.06,+$P(IB0,U,6))_$J("",20),1,20) + .. S IBQ=IBQ_" "_$E($P("Both form types^UB-04 Only^CMS-1500 Only",U,$P(IB0,U,4)+1)_$J("",15),1,15)_" "_$E($P("Inpt/Outpt^Inpt Only^Outpt Only^RX Only",U,+$P(IB0,U,5)+1)_$J("",10),1,10) + .. D SET^VALM10(IBLCT,IBQ,IBENT) + ; + I 'IBLCT D SET^VALM10(1,"No CARE UNITs Found"_$S('$G(IBINS):"",1:" for Insurance Co")) + S VALMCNT=IBLCT,VALMBG=1 + Q + ; +HELP ; -- help + ; + I $G(IBSLEV)=2 Q + ; + S X="?" D DISP^XQORM1 W !! + Q + ; +EXIT ; -- exit + K IBFASTXT + D CLEAN^VALM10 + K ^TMP("IBPRV_CU",$J),IBINS,IBALL + Q + ; +EXPND ; + Q + ; +SEL(IBDA,MANY) ; Select from care unit list + ; IBDA is passed by reference and IBDA(1) returned containing + ; ien's of the care unit selected (file 355.95). + ; If > 1 entry can be selected, MANY is set to 1 + N Z + S IBDA=0 + D EN^VALM2($G(XQORNOD(0)),$S($G(MANY):"",1:"S")) + S Z=0 F S Z=$O(VALMY(Z)) Q:'Z S IBDA=IBDA+1,IBDA(IBDA)=+$G(^TMP("IBPRV_CU",$J,"ZIDX",Z)) + Q + ; +DISP(IBVAR,IBINS,IBPTYP,IBFT,IBCT,START,END) ; Set up display array for + ; provider id + N Z + S START=$S($G(START):START,1:1) + S (Z,END)=$G(START) + S @IBVAR@(START)="INSURANCE: "_$S(IBINS:$P($G(^DIC(36,+IBINS,0)),U),1:"ALL INSURANCE") + S @IBVAR@(START+1)="PROV TYPE: "_$$EXPAND^IBTRE(355.96,.06,IBPTYP) + S @IBVAR@(START+2)="FORM TYPE: "_$$EXPAND^IBTRE(355.96,.04,IBFT) + S @IBVAR@(START+3)="CARE TYPE: "_$$EXPAND^IBTRE(355.96,.05,IBCT) + S END=$G(START)+3 + Q + ; +CAREUOK(IBIFN,IBCU,IBTYPE,IBSEQ) ; Returns 1 if care unit is appropriate + ; for bill based on provider type, care type, bill type and insurance co + ; IBIFN = ien of bill (file 399) + ; IBCU = the ien of the care unit (file 355.96) + ; IBTYPE = type of ID being checked (1=performing, 2=EMC) + ; IBSEQ = the COB seq being checked (1-3) + N Z,IBOK,IBINS,IBCT,IBFT,IBPTYP,IBRX + S IBOK=0 + S IBINS=+$$FINDINS^IBCEF1(IBIFN,+IBSEQ),IBFT=$S($$FT^IBCEF(IBIFN)=2:2,1:1) + S IBPTYP=+$S(IBTYPE=1:$$PPTYP^IBCEP0(IBINS),1:$$EMCID^IBCEP()) + S IBRX=$$ISRX^IBCEF1(IBIFN) + S IBCT=$S('IBRX:$S($$INPAT^IBCEF(IBIFN,1):1,1:2),1:3) + ;Check from most general to most specific + I $D(^IBA(355.96,"AD",IBINS,0,0,IBPTYP,IBCU)) S IBOK=1 G CAREOKQ + I 'IBRX,$D(^IBA(355.96,"AD",IBINS,IBFT,0,IBPTYP,IBCU)) S IBOK=1 G CAREOKQ + I $D(^IBA(355.96,"AD",IBINS,0,IBCT,IBPTYP,IBCU)) S IBOK=1 G CAREOKQ + I $D(^IBA(355.96,"AD",IBINS,IBFT,IBCT,IBPTYP,IBCU)) S IBOK=1 G CAREOKQ + ; +CAREOKQ Q IBOK + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP4A.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP4A.m index 3d91cb40..01351724 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP4A.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP4A.m @@ -1,175 +1,161 @@ -IBCEP4A ;ALB/TMP - EDI UTILITIES for provider ID ;29-SEP-00 - ;;2.0;INTEGRATED BILLING;**137,232,280,349,377**;21-MAR-94;Build 23 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -NEW(IB) ; Add care unit - ; Assumes IBINS is defined as ins co ien (file 36) - ; IB = 0 or null if called from list manager, 1 if not - N DIC,DIR,X,Y,Z,DA,DR,DIE,DO,DD,DLAYGO,IB95,IBADD,IBOK - I '$G(IB) D FULL^VALM1 - ; - ; Add an entry - either new care unit/ins co or a combination for - ; existing care unit/ins co - S DIC("A")="SELECT CARE UNIT FOR THE INSURANCE CO: ",DIC="^IBA(355.95,",DIC("S")="I $P(^(0),U,3)=+$G(IBINS)",DIC(0)="AELMQ",DIC("DR")=".03////"_+$G(IBINS)_";.02",DLAYGO=355.95 D ^DIC K DIC,DLAYGO - G:Y'>0 NEWQ - S IB95=3,IB95("IBCU")=+Y - D INSASS(IBINS,.IB95) - I '$G(IB) D BLD^IBCEP4 -NEWQ I '$G(IB) S VALMBCK="R" - Q - ; -CHANGE(IB) ; Edit a care unit name or combination for ins co IBINS - ; Assumes IBINS is defined as ins co ien (file 36) - ; IB = 0 or null if called from list manager, 1 if not - N DIC,DIK,DIR,X,Y,Z,DA,DR,DIE,DO,DD,DLAYGO,IB95,IBOK,IBZ,IB0,IBEDIT,IBCK,IBDA,IBCHG,IBDELETE,Z100,DTOUT,DUOUT - I '$G(IB) D FULL^VALM1 S Y=$$SEL() - I $G(IB) S DIC("A")="CARE UNIT NAME: ",DIC(0)="AEMQ",DIC("S")="I $P(^(0),U,3)=+$G(IBINS)",DIC="^IBA(355.95," W ! D ^DIC K DIC - I Y'>0 G CHGQ - S IB95("IBCU")=+Y,IBDELETE=0,IBDELETE(0)=$G(^IBA(355.95,0)),IBDELETE(1)=$G(^(1)) - ; Edit fields outside of FM to assure uniqueness of combos is maintained - W ! S DIR("A")="CARE UNIT NAME: ",DIR("B")=$P($G(^IBA(355.95,+IB95("IBCU"),0)),U),DIR(0)="355.95,.01AO",DIR("S")="I $P(^(0),U,3)=IBINS" D ^DIR K DIR - I $D(DTOUT)!$D(DUOUT) G CHGQ - I X="@" S DIR(0)="EA",DIR("A")="NOTHING DELETED - PRESS ENTER TO CONTINUE" D ^DIR K DIR G CHGQ - I $P($G(^IBA(355.95,IB95("IBCU"),0)),U)'=Y S DIE="^IBA(355.95,",DR=".01///"_Y,DA=IB95("IBCU") D ^DIE ; File the name change - S DR=".02",DIE="^IBA(355.95,",DA=IB95("IBCU") D ^DIE - I $D(Y) G CHGQ - ; - I $O(^IBA(355.96,"ACARE",IB95("IBCU"),""))="" S IB95=3 D INSASS(IBINS,.IB95) G CHGQ - ; only 1 combination found for ins/care unit - I $O(^IBA(355.96,"ACARE",IB95("IBCU"),""),-1)=$O(^IBA(355.96,"ACARE",IB95("IBCU"),0)) D - . S IBDA=$O(^IBA(355.96,"ACARE",IB95("IBCU"),0)) - ; - ; Choose the combination to edit - more than 1 exists - E D - . W !,"SELECT ONE OF THE FOLLOWING CARE UNIT COMBINATIONS:" - . S DIC="^IBA(355.96,",DIC(0)="EMQ",DIC("S")="I $D(^IBA(355.96,""ACARE"","_IB95("IBCU")_",Y))",X=IBINS D ^DIC K DIC S IBDA=+Y - ; - I IBDA>0 D - . N IBDA0,Q,Q0 - . S IBDA0=$G(^IBA(355.96,IBDA,0)) - . Q:IBDA0="" - . W !!,"*** CARE UNIT COMBINATION FOR: ",$P($G(^IBA(355.95,+IB95("IBCU"),0)),U)," ***" - . D DISP^IBCEP4("Q",IBINS,$P(IBDA0,U,6),$P(IBDA0,U,4),$P(IBDA0,U,5),1,.Q0) - . S Z=0 F S Z=$O(Q(Z)) Q:'Z W !,Q(Z) - . I $P(IBDA0,U,7) W !,"EXP DATE: ",$$FMTE^XLFDT($P(IBDA0,U,7),"2D") - . W !,"CARE UNIT: ",$P($G(^IBA(355.95,+IBDA0,0)),U),! - . W ! S DIR(0)="SA^E:EDIT;D:DELETE",DIR("B")="EDIT",DIR("A")="EDIT OR DELETE THIS CARE UNIT COMBINATION?: " D ^DIR K DIR - . I $D(DTOUT)!$D(DUOUT) Q - . I Y="D" D Q - .. S DIR(0)="YA",DIR("A")="ARE YOU SURE YOU WANT TO DELETE THIS CARE UNIT COMBINATION?: ",DIR("B")="NO" D ^DIR K DIR - .. I Y=1 S DIK="^IBA(355.96,",DA=IBDA,IBCHG=1 D ^DIK - . S (IBCK,IBCHG)=0,(IBEDIT,IBOK)=1 - . F Q:'IBEDIT S IBEDIT=0,IB0=$G(^IBA(355.96,+IBDA,0)) K IBZ F Z=.01,.03,.06,.04,.05 D Q:'IBOK!IBEDIT - .. S Z100=Z*100 - .. I Z100=1 W !,"CARE UNIT: ",$P($G(^IBA(355.95,IB95("IBCU"),0)),U) S IBZ(.01)=$P(IB0,U) Q - .. I Z100=3 W !,"INSURANCE COMPANY: ",$$EXPAND^IBTRE(355.96,.03,$P(IB0,U,3)) S IBZ(.03)=$P(IB0,U) Q - .. I Z100=5 S IBCK=1 - .. S IBZ(Z)=$$EDIT(Z,IB0,+IBDA,IBCK),IBCK=0 - .. I '$P(IBZ(Z),U,2) D Q - ... I $P(IB0,U,Z100)'=IBZ(Z) S IBCHG=1 - ... S $P(IB0,U,Z100)=IBZ(Z) - .. S (IBOK,IBCHG)=0 - .. I $P(IBZ(Z),U,2)=2 D - ... S DIR(0)="YA",DIR("A",1)="This entry already exists",DIR("A")="Do you want to re-edit?: " W ! D ^DIR K DIR W ! - ... I Y=1 S (IBOK,IBEDIT)=1 - . I IBOK Q:'IBCHG S DIE="^IBA(355.96,",DR=".03////"_IBZ(.03)_";.04////"_IBZ(.04)_";.05////"_IBZ(.05)_";.06////"_IBZ(.06)_";.07",DA=+IBDA D ^DIE,BLD^IBCEP4 Q - ; - I '$G(IB) D BLD^IBCEP4 -CHGQ I '$G(IB) S VALMBCK="R" - Q - ; -INSASS(IBINSZ,IB95) ; Assign care unit to or delete from an ins co - ; IBINSZ = ien of ins co (file 36) - ; IB95 = flag ("IBCU")=care unit - ; can have subscripts to send in pre-entered data - N DIR,DIC,DA,DR,X,Y,Z,IBFT,IBCT,IBPTYP,IBCU,IBCHG,IBINS,IBDA,IBPXDT,IBDICS - S IBINS=IBINSZ - S IBCHG=0,IBCU=$G(IB95("IBCU")) - D FULL^VALM1 - I '$G(IBINSZ) K IB95 G INSQ - W ! - F Z=.06,.04,.05,.07,.03 D G:Z="" INSQ - . ; - . I $S(Z=.04:'$D(IB95("IBFT")),Z=.05:'$D(IB95("IBCT")),Z=.06:'$D(IB95("IBPTYP")),Z=.03:'$D(IB95("IBCU")),1:1) D - .. N DA - .. K IBDICS - .. I Z=.04 D - ... I $P($G(^IBE(355.97,+$G(IB95("IBPTYP")),0)),U,3)="1A" S IBDICS="I Y'=1 K X",DIR("B")="UB-04",DIR("?")="ONLY UB-04 IS VALID FOR A BLUE CROSS ID" - .. S DIR(0)="355.96,"_Z_$S($G(IBDICS)="":"",1:"^^"_IBDICS) D ^DIR K DIR - . I $D(DTOUT)!$D(DUOUT) S VALMBCK="R",Z="" K:$G(IB95)=2 IB95 Q - . ; - . I Z=.04 S IBFT=$S($G(IB95("IBFT"))="":+Y,1:IB95("IBFT")) S IB95("IBFT")=IBFT Q - . ; - . I Z=.05 S IBCT=$S($G(IB95("IBCT"))="":+Y,1:IB95("IBCT")) S IB95("IBCT")=IBCT Q - . ; - . I Z=.06 S IBPTYP=$S($G(IB95("IBPTYP"))="":+Y,1:IB95("IBPTYP")) S IB95("IBPTYP")=IBPTYP Q - . ; - . I Z=.07 S IBPXDT=$S('$G(IB95("IBEXPDT")):+Y,1:IB95("IBEXPDT")) S IB95("IBEXPDT")=IBPXDT Q - . ; - . I Z=.03,$G(IB95)=3,$G(IB95("IBCU"))'="" D Q:Z="" - .. N Q ; Assign from add care type - .. S IBCT=0 - .. W !,"CARE UNIT: "_$$EXPAND^IBTRE(355.96,.01,IB95("IBCU")) - .. S IB95("IBINS")=+IBINSZ - .. I $D(^IBA(355.96,"AUNIQ",IBINSZ,IB95("IBCU"),IB95("IBFT"),IB95("IBCT"),IB95("IBPTYP"))) D Q - ... S DIR(0)="EA",DIR("A",1)="This combination already exists - NOT ADDED",DIR("A")="Press ENTER to continue" W ! D ^DIR K DIR W ! - .. S IBCT=1 S Y=$$ADDCU(IBINSZ,IB95("IBCU"),IB95("IBFT"),IB95("IBCT"),IB95("IBPTYP")) - .. I Y<0 W ! S DIR("A",1)=" >> Care Unit NOT completely filed",DIR("A")="PRESS ENTER TO CONTINUE ",DIR(0)="EA" D ^DIR K DIR Q - .. W ! S DIR(0)="EA",DIR("A",1)=" >> CARE UNIT COMBINATION FILED FOR THE INSURANCE CO",IBCT=1,IBCHG=1,DIR("A")="PRESS ENTER TO CONTINUE ",DIR(0)="EA" D ^DIR K DIR - I $G(IBCHG) D BLD^IBCEP4 -INSQ S VALMBCK="R" - Q - ; -EDIT(IBFLD,IB0,IBIEN,IBCK1) ; Allow addition/edit of fields in file 355.96 - ; without direct Fileman call so uniqueness can be checked - ; IBFLD = field # in file 355.96 - ; IB0 = current 0-node of data in the entry in file 355.96 - ; IBIEN = ien of entry being edited in file 355.96 - ; IBCK1 = flag ... if 1, checks for uniqueness after field changed - ; - ; FUNCTION RETURNS: value of field if field is OK, second piece is null - ; If not good, 2nd piece = 1 : no data or ^ entered - ; = 2 : record not unique - N DIR,DA,Y,X,IBNEW,IBINS,IBVAL - S IBINS=+IB0,IBNEW="",IBVAL=$$EXPAND^IBTRE(355.96,IBFLD,$P(IB0,U,(IBFLD*100))) - S DIR(0)="355.96,"_IBFLD - S:IBVAL'="" DIR("B")=IBVAL - D ^DIR K DIR - I Y=""!$D(DTOUT)!$D(DUOUT) S IBNEW="^1" G EDITQ - S IBNEW=$P(Y,U) - I $G(IBCK1) D - . N X1,X2,X3,X4,X5 - . S X1=$S(IBFLD'=.03:IBINS,1:IBNEW),X2=$S(IBFLD'=.01:$P(IB0,U),1:IBNEW),X3=$S(IBFLD'=.04:$P(IB0,U,4),1:IBNEW),X4=$S(IBFLD'=.05:$P(IB0,U,5),1:IBNEW),X5=$S(IBFLD'=.06:$P(IB0,U,6),1:IBNEW) - . I $S(X1=""!(X2="")!(X3="")!(X4="")!(X5=""):1,$O(^IBA(355.96,"AUNIQ",X1,X2,X3,X4,X5,0)):$O(^(0))'=IBIEN,1:0) S IBNEW=IBNEW_"^2" - ; -EDITQ Q IBNEW - ; -ADDCU(IBINSZ,IBCU,IBFT,IBCT,IBPTYP) ; Add a new care unit record to file 355.96 - ; Same parameter definitions as EDIT - N DIC,DA,X,Y,DLAYGO - S DIC(0)="L",DLAYGO=355.96,DIC="^IBA(355.96,",DIC("DR")=".03////"_IBINSZ_";.04////"_IBFT_";.05////"_IBCT_";.06////"_IBPTYP,X=IBCU - D FILE^DICN - Q Y - ; -DELETE(IB) ; delete a care unit name - ; IB = 0 or null if called from list manager, 1 if not - N DIR,X,Y - I '$G(IB) D FULL^VALM1 S Y=$$SEL() I Y'>0 G DELETEQ - S:'$G(IB) IB95("IBCU")=+Y - S DIR("A",1)="THIS WILL DELETE THE CARE UNIT NAME AND ALL ITS COMBINATIONS",DIR("A")="ARE YOU SURE THIS IS WHAT YOU WANT TO DO?: ",DIR(0)="YA",DIR("B")="NO" D ^DIR K DIR - I Y'=1 S IB95("IBCU")="" Q ; Changed their mind - don't delete - S Z=0 F S Z=$O(^IBA(355.96,"B",IB95("IBCU"),Z)) Q:'Z S DIK="^IBA(355.96,",DA=Z D ^DIK - S DA=IB95("IBCU"),DIK="^IBA(355.95," D ^DIK - W ! S DIR(0)="EA",DIR("A",1)="CARE UNIT AND ALL ITS COMBINATIONS WERE DELETED",DIR("A")="PRESS ENTER TO CONTINUE " D ^DIR K DIR D BLD^IBCEP4 -DELETEQ ; - S:'$G(IB) VALMBCK="R" - Q - ; -SEL() ; Select entry from list - ; returns ien in file 355.95 for selected entry - N VALMY,SEL - D EN^VALM2($G(XQORNOD(0)),"S") - S SEL=+$O(VALMY("")) - I SEL'>0 Q 0 - Q +$G(^TMP("IBPRV_CU",$J,"ZIDX",SEL)) - ; +IBCEP4A ;ALB/TMP - EDI UTILITIES for provider ID ;29-SEP-00 + ;;2.0;INTEGRATED BILLING;**137,232,280,349**;21-MAR-94;Build 46 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; +NEW(IB) ; Add care unit + ; Assumes IBINS is defined as ins co ien (file 36) + ; IB = 0 or null if called from list manager, 1 if not + N DIC,DIR,X,Y,Z,DA,DR,DIE,DO,DD,DLAYGO,IB95,IBADD,IBOK + I '$G(IB) D FULL^VALM1 + ; + ; Add an entry - either new care unit/ins co or a combination for + ; existing care unit/ins co + S DIC("A")="SELECT CARE UNIT FOR THE INSURANCE CO: ",DIC="^IBA(355.95,",DIC("S")="I $P(^(0),U,3)=+$G(IBINS)",DIC(0)="AELMQ",DIC("DR")=".03////"_+$G(IBINS)_";.02",DLAYGO=355.95 D ^DIC K DIC,DLAYGO + G:Y'>0 NEWQ + S IB95=3,IB95("IBCU")=+Y + D INSASS(IBINS,.IB95) + I '$G(IB) D BLD^IBCEP4 +NEWQ I '$G(IB) S VALMBCK="R" + Q + ; +CHANGE(IB) ; Edit a care unit name or combination for ins co IBINS + ; Assumes IBINS is defined as ins co ien (file 36) + ; IB = 0 or null if called from list manager, 1 if not + N DIC,DIK,DIR,X,Y,Z,DA,DR,DIE,DO,DD,DLAYGO,IB95,IBOK,IBZ,IB0,IBEDIT,IBCK,IBDA,IBCHG,IBDELETE,Z100,DTOUT,DUOUT + I '$G(IB) D FULL^VALM1 + S DIC("A")="CARE UNIT NAME: ",DIC(0)="AEMQ",DIC("S")="I $P(^(0),U,3)=+$G(IBINS)",DIC="^IBA(355.95," W ! D ^DIC K DIC + I Y'>0 G CHGQ + S IB95("IBCU")=+Y,IBDELETE=0,IBDELETE(0)=$G(^IBA(355.95,0)),IBDELETE(1)=$G(^(1)) + ; Edit fields outside of FM to assure uniqueness of combos is maintained + W ! S DIR("A")="CARE UNIT NAME: ",DIR("B")=$P($G(^IBA(355.95,+IB95("IBCU"),0)),U),DIR(0)="355.95,.01AO",DIR("S")="I $P(^(0),U,3)=IBINS" D ^DIR K DIR + I $D(DTOUT)!$D(DUOUT) G CHGQ + ; + ; Care unit name was deleted + I X="@" D G CHGQ + . S DIR("A",1)="THIS WILL DELETE THE CARE UNIT NAME AND ALL ITS COMBINATIONS",DIR("A")="ARE YOU SURE THIS IS WHAT YOU WANT TO DO?: ",DIR(0)="YA",DIR("B")="NO" D ^DIR K DIR + . I Y'=1 S IB95("IBCU")="" Q ; Changed their mind - don't delete + . S Z=0 F S Z=$O(^IBA(355.96,"B",IB95("IBCU"),Z)) Q:'Z S DIK="^IBA(355.96,",DA=Z D ^DIK + . S DA=IB95("IBCU"),DIK="^IBA(355.95," D ^DIK + . W ! S DIR(0)="EA",DIR("A",1)="CARE UNIT AND ALL ITS COMBINATIONS WERE DELETED",DIR("A")="PRESS ENTER TO CONTINUE " D ^DIR K DIR D BLD^IBCEP4 + ; + I $P($G(^IBA(355.95,IB95("IBCU"),0)),U)'=Y S DIE="^IBA(355.95,",DR=".01///"_Y,DA=IB95("IBCU") D ^DIE ; File the name change + S DR=".02",DIE="^IBA(355.95,",DA=IB95("IBCU") D ^DIE + I $D(Y) G CHGQ + ; + I $O(^IBA(355.96,"ACARE",IB95("IBCU"),""))="" S IB95=3 D INSASS(IBINS,.IB95) G CHGQ + ; only 1 combination found for ins/care unit + I $O(^IBA(355.96,"ACARE",IB95("IBCU"),""),-1)=$O(^IBA(355.96,"ACARE",IB95("IBCU"),0)) D + . S IBDA=$O(^IBA(355.96,"ACARE",IB95("IBCU"),0)) + ; + ; Choose the combination to edit - more than 1 exists + E D + . W !,"SELECT ONE OF THE FOLLOWING CARE UNIT COMBINATIONS:" + . S DIC="^IBA(355.96,",DIC(0)="EMQ",DIC("S")="I $D(^IBA(355.96,""ACARE"","_IB95("IBCU")_",Y))",X=IBINS D ^DIC K DIC S IBDA=+Y + ; + I IBDA>0 D + . N IBDA0,Q,Q0 + . S IBDA0=$G(^IBA(355.96,IBDA,0)) + . Q:IBDA0="" + . W !!,"*** CARE UNIT COMBINATION FOR: ",$P($G(^IBA(355.95,+IB95("IBCU"),0)),U)," ***" + . D DISP^IBCEP4("Q",IBINS,$P(IBDA0,U,6),$P(IBDA0,U,4),$P(IBDA0,U,5),1,.Q0) + . S Z=0 F S Z=$O(Q(Z)) Q:'Z W !,Q(Z) + . I $P(IBDA0,U,7) W !,"EXP DATE: ",$$FMTE^XLFDT($P(IBDA0,U,7),"2D") + . W !,"CARE UNIT: ",$P($G(^IBA(355.95,+IBDA0,0)),U),! + . W ! S DIR(0)="SA^E:EDIT;D:DELETE",DIR("B")="EDIT",DIR("A")="EDIT OR DELETE THIS CARE UNIT COMBINATION?: " D ^DIR K DIR + . I $D(DTOUT)!$D(DUOUT) Q + . I Y="D" D Q + .. S DIR(0)="YA",DIR("A")="ARE YOU SURE YOU WANT TO DELETE THIS CARE UNIT COMBINATION?: ",DIR("B")="NO" D ^DIR K DIR + .. I Y=1 S DIK="^IBA(355.96,",DA=IBDA,IBCHG=1 D ^DIK + . S (IBCK,IBCHG)=0,(IBEDIT,IBOK)=1 + . F Q:'IBEDIT S IBEDIT=0,IB0=$G(^IBA(355.96,+IBDA,0)) K IBZ F Z=.01,.03,.06,.04,.05 D Q:'IBOK!IBEDIT + .. S Z100=Z*100 + .. I Z100=1 W !,"CARE UNIT: ",$P($G(^IBA(355.95,IB95("IBCU"),0)),U) S IBZ(.01)=$P(IB0,U) Q + .. I Z100=3 W !,"INSURANCE COMPANY: ",$$EXPAND^IBTRE(355.96,.03,$P(IB0,U,3)) S IBZ(.03)=$P(IB0,U) Q + .. I Z100=5 S IBCK=1 + .. S IBZ(Z)=$$EDIT(Z,IB0,+IBDA,IBCK),IBCK=0 + .. I '$P(IBZ(Z),U,2) D Q + ... I $P(IB0,U,Z100)'=IBZ(Z) S IBCHG=1 + ... S $P(IB0,U,Z100)=IBZ(Z) + .. S (IBOK,IBCHG)=0 + .. I $P(IBZ(Z),U,2)=2 D + ... S DIR(0)="YA",DIR("A",1)="This entry already exists",DIR("A")="Do you want to re-edit?: " W ! D ^DIR K DIR W ! + ... I Y=1 S (IBOK,IBEDIT)=1 + . I IBOK Q:'IBCHG S DIE="^IBA(355.96,",DR=".03////"_IBZ(.03)_";.04////"_IBZ(.04)_";.05////"_IBZ(.05)_";.06////"_IBZ(.06)_";.07",DA=+IBDA D ^DIE,BLD^IBCEP4 Q + ; + I '$G(IB) D BLD^IBCEP4 +CHGQ I '$G(IB) S VALMBCK="R" + Q + ; +INSASS(IBINSZ,IB95) ; Assign care unit to or delete from an ins co + ; IBINSZ = ien of ins co (file 36) + ; IB95 = flag ("IBCU")=care unit + ; can have subscripts to send in pre-entered data + N DIR,DIC,DA,DR,X,Y,Z,IBFT,IBCT,IBPTYP,IBCU,IBCHG,IBINS,IBDA,IBPXDT,IBDICS + S IBINS=IBINSZ + S IBCHG=0,IBCU=$G(IB95("IBCU")) + D FULL^VALM1 + I '$G(IBINSZ) K IB95 G INSQ + W ! + F Z=.06,.04,.05,.07,.03 D G:Z="" INSQ + . ; + . I $S(Z=.04:'$D(IB95("IBFT")),Z=.05:'$D(IB95("IBCT")),Z=.06:'$D(IB95("IBPTYP")),Z=.03:'$D(IB95("IBCU")),1:1) D + .. N DA + .. K IBDICS + .. I Z=.04 D + ... I $P($G(^IBE(355.97,+$G(IB95("IBPTYP")),0)),U,3)="1A" S IBDICS="I Y'=1 K X",DIR("B")="UB-04",DIR("?")="ONLY UB-04 IS VALID FOR A BLUE CROSS ID" + .. S DIR(0)="355.96,"_Z_$S($G(IBDICS)="":"",1:"^^"_IBDICS) D ^DIR K DIR + . I $D(DTOUT)!$D(DUOUT) S VALMBCK="R",Z="" K:$G(IB95)=2 IB95 Q + . ; + . I Z=.04 S IBFT=$S($G(IB95("IBFT"))="":+Y,1:IB95("IBFT")) S IB95("IBFT")=IBFT Q + . ; + . I Z=.05 S IBCT=$S($G(IB95("IBCT"))="":+Y,1:IB95("IBCT")) S IB95("IBCT")=IBCT Q + . ; + . I Z=.06 S IBPTYP=$S($G(IB95("IBPTYP"))="":+Y,1:IB95("IBPTYP")) S IB95("IBPTYP")=IBPTYP Q + . ; + . I Z=.07 S IBPXDT=$S('$G(IB95("IBEXPDT")):+Y,1:IB95("IBEXPDT")) S IB95("IBEXPDT")=IBPXDT Q + . ; + . I Z=.03,$G(IB95)=3,$G(IB95("IBCU"))'="" D Q:Z="" + .. N Q ; Assign from add care type + .. S IBCT=0 + .. W !,"CARE UNIT: "_$$EXPAND^IBTRE(355.96,.01,IB95("IBCU")) + .. S IB95("IBINS")=+IBINSZ + .. I $D(^IBA(355.96,"AUNIQ",IBINSZ,IB95("IBCU"),IB95("IBFT"),IB95("IBCT"),IB95("IBPTYP"))) D Q + ... S DIR(0)="EA",DIR("A",1)="This combination already exists - NOT ADDED",DIR("A")="Press ENTER to continue" W ! D ^DIR K DIR W ! + .. S IBCT=1 S Y=$$ADDCU(IBINSZ,IB95("IBCU"),IB95("IBFT"),IB95("IBCT"),IB95("IBPTYP")) + .. I Y<0 W ! S DIR("A",1)=" >> Care Unit NOT completely filed",DIR("A")="PRESS ENTER TO CONTINUE ",DIR(0)="EA" D ^DIR K DIR Q + .. W ! S DIR(0)="EA",DIR("A",1)=" >> CARE UNIT COMBINATION FILED FOR THE INSURANCE CO",IBCT=1,IBCHG=1,DIR("A")="PRESS ENTER TO CONTINUE ",DIR(0)="EA" D ^DIR K DIR + I $G(IBCHG) D BLD^IBCEP4 +INSQ S VALMBCK="R" + Q + ; +EDIT(IBFLD,IB0,IBIEN,IBCK1) ; Allow addition/edit of fields in file 355.96 + ; without direct Fileman call so uniqueness can be checked + ; IBFLD = field # in file 355.96 + ; IB0 = current 0-node of data in the entry in file 355.96 + ; IBIEN = ien of entry being edited in file 355.96 + ; IBCK1 = flag ... if 1, checks for uniqueness after field changed + ; + ; FUNCTION RETURNS: value of field if field is OK, second piece is null + ; If not good, 2nd piece = 1 : no data or ^ entered + ; = 2 : record not unique + N DIR,DA,Y,X,IBNEW,IBINS,IBVAL + S IBINS=+IB0,IBNEW="",IBVAL=$$EXPAND^IBTRE(355.96,IBFLD,$P(IB0,U,(IBFLD*100))) + S DIR(0)="355.96,"_IBFLD + S:IBVAL'="" DIR("B")=IBVAL + D ^DIR K DIR + I Y=""!$D(DTOUT)!$D(DUOUT) S IBNEW="^1" G EDITQ + S IBNEW=$P(Y,U) + I $G(IBCK1) D + . N X1,X2,X3,X4,X5 + . S X1=$S(IBFLD'=.03:IBINS,1:IBNEW),X2=$S(IBFLD'=.01:$P(IB0,U),1:IBNEW),X3=$S(IBFLD'=.04:$P(IB0,U,4),1:IBNEW),X4=$S(IBFLD'=.05:$P(IB0,U,5),1:IBNEW),X5=$S(IBFLD'=.06:$P(IB0,U,6),1:IBNEW) + . I $S(X1=""!(X2="")!(X3="")!(X4="")!(X5=""):1,$O(^IBA(355.96,"AUNIQ",X1,X2,X3,X4,X5,0)):$O(^(0))'=IBIEN,1:0) S IBNEW=IBNEW_"^2" + ; +EDITQ Q IBNEW + ; +ADDCU(IBINSZ,IBCU,IBFT,IBCT,IBPTYP) ; Add a new care unit record to file 355.96 + ; Same parameter definitions as EDIT + N DIC,DA,X,Y,DLAYGO + S DIC(0)="L",DLAYGO=355.96,DIC="^IBA(355.96,",DIC("DR")=".03////"_IBINSZ_";.04////"_IBFT_";.05////"_IBCT_";.06////"_IBPTYP,X=IBCU + D FILE^DICN + Q Y + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP5.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP5.m index e8c9b0b2..6ddf3810 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP5.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP5.m @@ -1,160 +1,161 @@ -IBCEP5 ;ALB/TMP - EDI UTILITIES for provider ID ;29-SEP-00 - ;;2.0;INTEGRATED BILLING;**137,232,320,348,349,377**;21-MAR-94;Build 23 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -EN ; -- main entry point for IBCE PRV MAINT - N IBPRV,IBINS -EN1 ; Entrypoint for non-VA provider ID maintenance hook - N IBSLEV,DIR,Y,X,IBPRMPT,IBNVAFL,IBIF - K IBFASTXT - S IBIF="" I $G(IBPRV) S IBIF=$$GET1^DIQ(355.93,IBPRV,.02,"I") - D FULL^VALM1 - S IBPRMPT=$S(IBIF=1:"LAB OR FACILITY",1:"PROVIDER") - S DIR(0)="SA^1:"_IBPRMPT_"'S OWN IDS;2:"_IBPRMPT_" IDS FURNISHED BY AN INSURANCE COMPANY" - S DIR("A")="SELECT SOURCE OF ID: ",DIR("B")=$P($P(DIR(0),":",2),";") - W ! D ^DIR K DIR W ! - I Y'>0 Q - S IBSLEV=+Y - D EN^VALM("IBCE PRVPRV MAINT") - Q - ; -HDR ; -- header code - N IBC,Z,IBIF - S IBIF="" I $G(IBNPRV) S IBIF=$$GET1^DIQ(355.93,IBNPRV,.02,"I") - K VALMHDR - S IBC=1 - S IBPRMPT=$S(IBIF=1:"Lab or Facility",1:"Performing Provider") - S Z="** "_$S($G(IBSLEV)=1:IBPRMPT_"'s Own IDs (No Specific Insurance Co)",1:IBPRMPT_" IDs from Insurance Co")_" **" - S VALMHDR(IBC)=$J("",80-$L(Z)\2)_Z,IBC=IBC+1 - I $G(IBPRV),'+IBIF S VALMHDR(IBC)="PROVIDER : "_$$EXPAND^IBTRE(355.9,.01,IBPRV)_$S(IBPRV["VA(200":" (VA PROVIDER)",1:" (NON-VA PROVIDER)"),IBC=IBC+1 - I $G(IBPRV),+IBIF S VALMHDR(IBC)="Provider: "_$$EXPAND^IBTRE(355.9,.01,IBPRV)_$S(IBIF=1:"(Non-VA Lab or Facility)",1:""),IBC=IBC+1 - I $G(IBINS) D - . N PCF,PCDISP - . S PCF=$P($G(^DIC(36,+IBINS,3)),"^",13) - . S PCDISP=$S($G(IBSLEV)'=2!($G(IBPRV)'["VA(200,"):"",PCF="C":"(Child)",PCF="P":"(Parent)",1:"") - . S VALMHDR(IBC)=$S(IBIF:"Insurance Co: ",1:"INSURANCE CO: ")_$P($G(^DIC(36,+IBINS,0)),U)_" "_PCDISP - Q - ; -INIT ; -- init variables and list array - N IBFILE,DIR,DIC,Y,X,DTOUT,DUOUT,IBIF,AGAIN - ; - K ^TMP("IB_EDITED_IDS",$J) ; This will be to keep track of ID's edited during this session - S IBIF="" I $G(IBNPRV) S IBIF=$$GET1^DIQ(355.93,IBNPRV,.02,"I") - ; - ; Removing Care Unit under certain conditions - ; This list is used for multiple purposes and not all have Care Units Associated with them - ; Also, a different protocol menu is used with these - ; IBNPRV is a non VA provider - ; IBIF = 1 means this is a group or facility, not an individual. - ; - I $G(IBNPRV),$G(IBIF)=1 D - . S VALM("TITLE")="Secondary Provider ID" - . K VALMDDF("CAREUNIT") - . I VALMCAP["Care Unit" S VALMCAP=$P(VALMCAP,"Care Unit")_" "_$P(VALMCAP,"Care Unit",2) - . K VALM("PROTOCOL") - . S Y=$$FIND1^DIC(101,,,"IBCE PRVNVA LOF MAINT") - . I Y S VALM("PROTOCOL")=+Y_";ORD(101," - ; - I $G(IBPRV) S IBFILE="IBA(355.93,",IBPRV=+IBPRV_";"_IBFILE - I '$G(IBPRV) D G:$G(VALMQUIT) INITQ - . S DIR(0)="SAO^V:VA PROVIDER;N:NON-VA PROVIDER",DIR("A")="(V)A or (N)on-VA provider: ",DIR("B")="V" - . D ^DIR K DIR - . I "NV"'[Y!(Y="") S VALMQUIT=1 Q - . S IBFILE=$S(Y="V":"VA(200,",1:"IBA(355.93,") - . S DIC=U_IBFILE,DIC(0)="AEMQ"_$S(IBFILE["355.93":"L",1:"") - . S DIC("A")="Select "_$S(IBFILE["355.93":"NON-",1:"")_"V.A. PROVIDER NAME: " - . S:IBFILE["355.93" DIC("DR")=".02////2;.03;.04" - . F D I $G(IBPRV)!$G(VALMQUIT) K DIC Q - .. D ^DIC - .. I $D(DTOUT)!$D(DUOUT) S VALMQUIT=1 Q - .. I Y'>0 W !,*7,"This is a required response. Enter '^' to exit" Q - .. S IBPRV=+Y_";"_IBFILE - ; -AGAIN I $G(IBSLEV)=2 D G:$G(AGAIN) AGAIN G:$G(VALMQUIT) INITQ - . S AGAIN=0 - . S DIR(0)="PA^DIC(36,:AEMQ",DIR("A")="Select INSURANCE CO: ",DIR("?",1)="Select an INSURANCE CO to display its provider ID's" - . D ^DIR K DIR - . I $D(DTOUT)!$D(DUOUT) S VALMQUIT=1 Q - . S IBINS=$S(Y>0:+Y,1:"NO") - . I $G(IBPRV)'["VA(200," Q ; Only VA providers - . I $P($G(^DIC(36,+IBINS,3)),"^",13)="C" D S AGAIN=1 Q - .. W !,*7,"This is a Child Insurance Company. Editing IDs is not permitted." - ; - E D - . S IBINS="NO" - D BLD -INITQ Q - ; -BLD ; Build initial display - ; Assumes IBPRV = the variable ptr for prov id file (355.9) - ; IBINS = the ien of the ins co or if null, ALL is assumed - ; IBSLEV = 1 to display only provider default ids - ; = 2 to display all provider/insurance co ids - N IB,IBLCT,IBCT,CT,PT,CU,INS,FT,Z,IBENT,IB1,IBIF - ; - S IBIF="" I $G(IBPRV)[355.93 S IBIF=$$GET1^DIQ(355.93,+IBPRV,.02,"I") - ; - K ^TMP("IBPRV_",$J),^TMP("IBPRV_SORT",$J) - K Z0 - S (IBENT,IBCT,IBLCT)=0,INS="",IB1=1 - F S INS=$S($G(IBINS):IBINS,IBSLEV=1:"*ALL*",1:$O(^IBA(355.9,"AUNIQ",IBPRV,INS))) Q:$S(INS="":1,$G(IBINS)!(IBSLEV=1):$D(CU),1:0) S CU="",IB1=0 F S CU=$O(^IBA(355.9,"AUNIQ",IBPRV,INS,CU)) Q:CU="" D - . S FT="" F S FT=$O(^IBA(355.9,"AUNIQ",IBPRV,INS,CU,FT)) Q:FT="" S CT="" F S CT=$O(^IBA(355.9,"AUNIQ",IBPRV,INS,CU,FT,CT)) Q:CT="" S PT=0 F S PT=$O(^IBA(355.9,"AUNIQ",IBPRV,INS,CU,FT,CT,PT)) Q:'PT D - .. S Z=0 F S Z=$O(^IBA(355.9,"AUNIQ",IBPRV,INS,CU,FT,CT,PT,Z)) Q:'Z S IB=$G(^IBA(355.9,Z,0)) D - ... S ^TMP("IBPRV_SORT",$J,$S(INS:$P($G(^DIC(36,+INS,0)),U)_" ",1:" ALL"),PT,FT,CT,CU,Z)=$P(IB,U,7) - ; - I IBSLEV=1,IBPRV["IBA(355.93",$P($G(^IBA(355.93,+IBPRV,0)),U,12)'="" S ^TMP("IBPRV_SORT",$J," ALL",+$$STLIC^IBCEP8(),0,0,"*N/A*",0)=$P(^IBA(355.93,+IBPRV,0),U,12) - S INS="" F S INS=$O(^TMP("IBPRV_SORT",$J,INS)) Q:INS="" D - . I '$G(IBINS),'IBIF D:IBLCT SET^VALM10(IBLCT+1," ",IBCT) S IBLCT=$S(IBLCT:IBLCT+2,1:1) D SET^VALM10(IBLCT,"INSURANCE CO: "_$S($E(INS)=" ":"ALL INSURANCE",1:INS),$S(IBCT:IBCT,1:1)) - . S PT="" - . F S PT=$O(^TMP("IBPRV_SORT",$J,INS,PT)) Q:PT="" S FT="" F S FT=$O(^TMP("IBPRV_SORT",$J,INS,PT,FT)) Q:FT="" S CT="" F S CT=$O(^TMP("IBPRV_SORT",$J,INS,PT,FT,CT)) Q:CT="" D - .. S CU="" F S CU=$O(^TMP("IBPRV_SORT",$J,INS,PT,FT,CT,CU)) Q:CU="" S Z="" F S Z=$O(^TMP("IBPRV_SORT",$J,INS,PT,FT,CT,CU,Z)) Q:Z="" S IB=$G(^(Z)) D - ... S IBLCT=IBLCT+1,IBCT=IBCT+1 - ... S Z0=$E(IBCT_" ",1,4)_" "_$E($$EXPAND^IBTRE(355.9,.06,PT)_$S(PT=$$STLIC^IBCEP8():"("_$P($G(^DIC(5,+$P($G(^IBA(355.93,+IBPRV,0)),U,7),0)),U,2)_")",1:"")_$J("",20),1,20)_" "_$S(FT=1:"UB-04",FT=2:"1500 ",1:"BOTH ") - ... S Z0=Z0_" "_$E($S(CT=3:"RX",CT=1:"INPT",CT=2:"OUTPT",1:"INPT/OUTPT")_$J("",11),1,11) - ... S Z0=Z0_" "_$E($S(CU'="*N/A*":$P($G(^IBA(355.95,+$G(^IBA(355.96,CU,0)),0)),U),1:"")_$J("",15),1,15) I Z0["MEDICINE" X "*" - ... D SET^VALM10(IBLCT,Z0_" "_IB,IBCT) - ... S ^TMP("IBPRV_",$J,"ZIDX",IBCT)=$S(Z'=0:Z,1:"LIC^"_IBPRV) - I IBSLEV=1,IBPRV["VA(200" D - . N IBP - . S IBP=+IBPRV - . Q:'$$GETLIC^IBCEP5D(.IBP) - . I IBCT S IBLCT=IBLCT+1 D SET^VALM10(IBLCT," ",IBCT) - . S Z=0 F S Z=$O(IBP(Z)) Q:'Z D - .. S IBLCT=IBLCT+1,IBCT=IBCT+1 - .. D SET^VALM10(IBLCT,$E(IBCT_" ",1,4)_$E($P($G(^DIC(5,+Z,0)),U,2)_" STATE LICENSE #"_$J("",20),1,20)_$J("",39)_IBP(Z),IBCT) - .. S ^TMP("IBPRV_",$J,"ZIDX",IBCT)="LIC^"_+IBPRV - K ^TMP("IBPRV_SORT",$J) - ; - I IBLCT=0 D G BLDQ ; No entries for ins co selected - . D SET^VALM10(1," ") - . D SET^VALM10(2," No ID's found for provider "_$S('$G(IBINS):"",1:"and selected insurance co")) - . S IBLCT=2 - ; -BLDQ K VALMCNT,VALMBG - S VALMCNT=IBLCT,VALMBG=1 - Q - ; -HELP ; -- help code - S X="?" D DISP^XQORM1 W !! - Q - ; -EXIT ; -- exit code - D COPYPROV^IBCEP5A(IBINS) - K IBPRV - D CLEAN^VALM10 - K ^TMP("IBPRV_",$J),^TMP("IBPRV_SORT",$J),IBINS,IBALL - Q - ; -EXPND ; -- expand code - Q - ; -SEL(IBDA,MANY) ; Select from provider id list - ; IBDA is passed by reference and IBDA(1) returned containing - ; ien's of the provider id records selected (file 355.9). - ; If > 1 entry can be selected, MANY is set to 1 - N Z - S IBDA=0 - D EN^VALM2($G(XQORNOD(0)),$S($G(MANY):"",1:"S")) - S Z=0 F S Z=$O(VALMY(Z)) Q:'Z S IBDA=IBDA+1,IBDA(IBDA)=$G(^TMP("IBPRV_",$J,"ZIDX",Z)) - Q - ; +IBCEP5 ;ALB/TMP - EDI UTILITIES for provider ID ;29-SEP-00 + ;;2.0;INTEGRATED BILLING;**137,232,320,348,349**;21-MAR-94;Build 46 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; +EN ; -- main entry point for IBCE PRV MAINT + N IBPRV,IBINS +EN1 ; Entrypoint for non-VA provider ID maintenance hook + N IBSLEV,DIR,Y,X,IBPRMPT,IBNVAFL,IBIF + K IBFASTXT + S IBIF="" I $G(IBPRV) S IBIF=$$GET1^DIQ(355.93,IBPRV,.02,"I") + D FULL^VALM1 + S IBPRMPT=$S(IBIF=1:"LAB OR FACILITY",1:"PROVIDER") + S DIR(0)="SA^1:"_IBPRMPT_"'S OWN IDS;2:"_IBPRMPT_" IDS FURNISHED BY AN INSURANCE COMPANY" + S DIR("A")="SELECT SOURCE OF ID: ",DIR("B")=$P($P(DIR(0),":",2),";") + W ! D ^DIR K DIR W ! + I Y'>0 Q + S IBSLEV=+Y + D EN^VALM("IBCE PRVPRV MAINT") + Q + ; +HDR ; -- header code + N IBC,Z,IBIF + S IBIF="" I $G(IBNPRV) S IBIF=$$GET1^DIQ(355.93,IBNPRV,.02,"I") + K VALMHDR + S IBC=1 + S IBPRMPT=$S(IBIF=1:"Lab or Facility",1:"Performing Provider") + S Z="** "_$S($G(IBSLEV)=1:IBPRMPT_"'s Own IDs (No Specific Insurance Co)",1:IBPRMPT_" IDs from Insurance Co")_" **" + S VALMHDR(IBC)=$J("",80-$L(Z)\2)_Z,IBC=IBC+1 + I $G(IBPRV),'+IBIF S VALMHDR(IBC)="PROVIDER : "_$$EXPAND^IBTRE(355.9,.01,IBPRV)_$S(IBPRV["VA(200":" (VA PROVIDER)",1:" (NON-VA PROVIDER)"),IBC=IBC+1 + I $G(IBPRV),+IBIF S VALMHDR(IBC)="Provider: "_$$EXPAND^IBTRE(355.9,.01,IBPRV)_$S(IBIF=1:"(Non-VA Lab or Facility)",1:""),IBC=IBC+1 + I $G(IBINS) D + . N PCF,PCDISP + . S PCF=$P($G(^DIC(36,+IBINS,3)),"^",13) + . S PCDISP=$S($G(IBSLEV)'=2!($G(IBPRV)'["VA(200,"):"",PCF="C":"(Child)",PCF="P":"(Parent)",1:"") + . S VALMHDR(IBC)=$S(IBIF:"Insurance Co: ",1:"INSURANCE CO: ")_$P($G(^DIC(36,+IBINS,0)),U)_" "_PCDISP + Q + ; +INIT ; -- init variables and list array + N IBFILE,DIR,DIC,Y,X,DTOUT,DUOUT,IBIF,AGAIN + ; + K ^TMP("IB_EDITED_IDS",$J) ; This will be to keep track of ID's edited during this session + S IBIF="" I $G(IBNPRV) S IBIF=$$GET1^DIQ(355.93,IBNPRV,.02,"I") + ; + ; Removing Care Unit under certain conditions + ; This list is used for multiple purposes and not all have Care Units Associated with them + ; Also, a different protocol menu is used with these + ; IBNPRV is a non VA provider + ; IBIF = 1 means this is a group or facility, not an individual. + ; + I $G(IBNPRV),$G(IBIF)=1 D + . S VALM("TITLE")="Secondary Provider ID" + . K VALMDDF("CAREUNIT") + . I VALMCAP["Care Unit" S VALMCAP=$P(VALMCAP,"Care Unit")_" "_$P(VALMCAP,"Care Unit",2) + . K VALM("PROTOCOL") + . S Y=$$FIND1^DIC(101,,,"IBCE PRVNVA LOF MAINT") + . I Y S VALM("PROTOCOL")=+Y_";ORD(101," + ; + I $G(IBPRV) S IBFILE="IBA(355.93,",IBPRV=+IBPRV_";"_IBFILE + I '$G(IBPRV) D G:$G(VALMQUIT) INITQ + . S DIR(0)="SAO^V:VA PROVIDER;N:NON-VA PROVIDER",DIR("A")="(V)A or (N)on-VA provider: ",DIR("B")="V" + . D ^DIR K DIR + . I "NV"'[Y!(Y="") S VALMQUIT=1 Q + . S IBFILE=$S(Y="V":"VA(200,",1:"IBA(355.93,") + . S DIC=U_IBFILE,DIC(0)="AEMQ"_$S(IBFILE["355.93":"L",1:"") + . S DIC("A")="Select "_$S(IBFILE["355.93":"NON-",1:"")_"V.A. PROVIDER NAME: " + . S:IBFILE["355.93" DIC("DR")=".02////2;.03;.04" + . F D I $G(IBPRV)!$G(VALMQUIT) K DIC Q + .. D ^DIC + .. I $D(DTOUT)!$D(DUOUT) S VALMQUIT=1 Q + .. I Y'>0 W !,*7,"This is a required response. Enter '^' to exit" Q + .. S IBPRV=+Y_";"_IBFILE + ; +AGAIN I $G(IBSLEV)=2 D G:$G(AGAIN) AGAIN G:$G(VALMQUIT) INITQ + . S AGAIN=0 + . S DIR(0)="PA^DIC(36,:AEMQ",DIR("A")="Select INSURANCE CO: ",DIR("?",1)="Select an INSURANCE CO to display its provider ID's" + . D ^DIR K DIR + . I $D(DTOUT)!$D(DUOUT) S VALMQUIT=1 Q + . S IBINS=$S(Y>0:+Y,1:"NO") + . I $G(IBPRV)'["VA(200," Q ; Only VA providers + . I $P($G(^DIC(36,+IBINS,3)),"^",13)="C" D S AGAIN=1 Q + .. W !,*7,"This is a Child Insurance Company. Editing IDs is not permitted." + ; + E D + . S IBINS="NO" + D BLD +INITQ Q + ; +BLD ; Build initial display + ; Assumes IBPRV = the variable ptr for prov id file (355.9) + ; IBINS = the ien of the ins co or if null, ALL is assumed + ; IBSLEV = 1 to display only provider default ids + ; = 2 to display all provider/insurance co ids + N IB,IBLCT,IBCT,CT,PT,CU,INS,FT,Z,IBENT,IB1,IBIF + ; + S IBIF="" I $G(IBPRV)[355.93 S IBIF=$$GET1^DIQ(355.93,+IBPRV,.02,"I") + ; + K ^TMP("IBPRV_",$J),^TMP("IBPRV_SORT",$J) + K Z0 + S (IBENT,IBCT,IBLCT)=0,INS="",IB1=1 + F S INS=$S($G(IBINS):IBINS,IBSLEV=1:"*ALL*",1:$O(^IBA(355.9,"AUNIQ",IBPRV,INS))) Q:$S(INS="":1,$G(IBINS)!(IBSLEV=1):$D(CU),1:0) S CU="",IB1=0 F S CU=$O(^IBA(355.9,"AUNIQ",IBPRV,INS,CU)) Q:CU="" D + . S FT="" F S FT=$O(^IBA(355.9,"AUNIQ",IBPRV,INS,CU,FT)) Q:FT="" S CT="" F S CT=$O(^IBA(355.9,"AUNIQ",IBPRV,INS,CU,FT,CT)) Q:CT="" S PT=0 F S PT=$O(^IBA(355.9,"AUNIQ",IBPRV,INS,CU,FT,CT,PT)) Q:'PT D + .. S Z=0 F S Z=$O(^IBA(355.9,"AUNIQ",IBPRV,INS,CU,FT,CT,PT,Z)) Q:'Z S IB=$G(^IBA(355.9,Z,0)) D + ... S ^TMP("IBPRV_SORT",$J,$S(INS:$P($G(^DIC(36,+INS,0)),U)_" ",1:" ALL"),PT,FT,CT,CU,Z)=$P(IB,U,7) + ; + I IBSLEV=1,IBPRV["IBA(355.93",$P($G(^IBA(355.93,+IBPRV,0)),U,12)'="" S ^TMP("IBPRV_SORT",$J," ALL",+$$STLIC^IBCEP8(),0,0,"*N/A*",0)=$P(^IBA(355.93,+IBPRV,0),U,12) + S INS="" F S INS=$O(^TMP("IBPRV_SORT",$J,INS)) Q:INS="" D + . I '$G(IBINS),'IBIF D:IBLCT SET^VALM10(IBLCT+1," ",IBCT) S IBLCT=$S(IBLCT:IBLCT+2,1:1) D SET^VALM10(IBLCT,"INSURANCE CO: "_$S($E(INS)=" ":"ALL INSURANCE",1:INS),$S(IBCT:IBCT,1:1)) + . S PT="" + . F S PT=$O(^TMP("IBPRV_SORT",$J,INS,PT)) Q:PT="" S FT="" F S FT=$O(^TMP("IBPRV_SORT",$J,INS,PT,FT)) Q:FT="" S CT="" F S CT=$O(^TMP("IBPRV_SORT",$J,INS,PT,FT,CT)) Q:CT="" D + .. S CU="" F S CU=$O(^TMP("IBPRV_SORT",$J,INS,PT,FT,CT,CU)) Q:CU="" S Z="" F S Z=$O(^TMP("IBPRV_SORT",$J,INS,PT,FT,CT,CU,Z)) Q:Z="" S IB=$G(^(Z)) D + ... S IBLCT=IBLCT+1,IBCT=IBCT+1 + ... S Z0=$E(IBCT_" ",1,4)_" "_$E($$EXPAND^IBTRE(355.9,.06,PT)_$S(PT=$$STLIC^IBCEP8():"("_$P($G(^DIC(5,+$P($G(^IBA(355.93,+IBPRV,0)),U,7),0)),U,2)_")",1:"")_$J("",20),1,20)_" "_$S(FT=1:"UB-04",FT=2:"1500 ",1:"BOTH ") + ... S Z0=Z0_" "_$E($S(CT=3:"RX",CT=1:"INPT",CT=2:"OUTPT",1:"INPT/OUTPT")_$J("",11),1,11) + ... S Z0=Z0_" "_$E($S(CU'="*N/A*":$P($G(^IBA(355.95,+$G(^IBA(355.96,CU,0)),0)),U),1:"")_$J("",15),1,15) I Z0["MEDICINE" X "*" + ... D SET^VALM10(IBLCT,Z0_" "_IB,IBCT) + ... S ^TMP("IBPRV_",$J,"ZIDX",IBCT)=$S(Z'=0:Z,1:"LIC^"_IBPRV) + I IBSLEV=1,IBPRV["VA(200" D + . N IBP + . S IBP=+IBPRV + . Q:'$$GETLIC^IBCEP5D(.IBP) + . I IBCT S IBLCT=IBLCT+1 D SET^VALM10(IBLCT," ",IBCT) + . S Z=0 F S Z=$O(IBP(Z)) Q:'Z D + .. S IBLCT=IBLCT+1,IBCT=IBCT+1 + .. D SET^VALM10(IBLCT,$E(IBCT_" ",1,4)_$E($P($G(^DIC(5,+Z,0)),U,2)_" STATE LICENSE #"_$J("",20),1,20)_$J("",39)_IBP(Z),IBCT) + .. S ^TMP("IBPRV_",$J,"ZIDX",IBCT)="LIC^"_+IBPRV + K ^TMP("IBPRV_SORT",$J) + ; + I IBLCT=0 D G BLDQ ; No entries for ins co selected + . D SET^VALM10(1," ") + . D SET^VALM10(2," No ID's found for provider "_$S('$G(IBINS):"",1:"and selected insurance co")) + . S IBLCT=2 + ; +BLDQ K VALMCNT,VALMBG + S VALMCNT=IBLCT,VALMBG=1 + Q + ; +HELP ; -- help code + S X="?" D DISP^XQORM1 W !! + Q + ; +EXIT ; -- exit code + K IBFASTXT + D COPYPROV^IBCEP5A(IBINS) + K IBPRV + D CLEAN^VALM10 + K ^TMP("IBPRV_",$J),^TMP("IBPRV_SORT",$J),IBINS,IBALL + Q + ; +EXPND ; -- expand code + Q + ; +SEL(IBDA,MANY) ; Select from provider id list + ; IBDA is passed by reference and IBDA(1) returned containing + ; ien's of the provider id records selected (file 355.9). + ; If > 1 entry can be selected, MANY is set to 1 + N Z + S IBDA=0 + D EN^VALM2($G(XQORNOD(0)),$S($G(MANY):"",1:"S")) + S Z=0 F S Z=$O(VALMY(Z)) Q:'Z S IBDA=IBDA+1,IBDA(IBDA)=$G(^TMP("IBPRV_",$J,"ZIDX",Z)) + Q + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP6.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP6.m index 0ebcb0a6..246954cd 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP6.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP6.m @@ -1,145 +1,90 @@ -IBCEP6 ;ALB/TMP - PROVIDER ID MAINT menu and INS CO EDIT hook ;11-02-00 - ;;2.0;INTEGRATED BILLING;**137,232,320,377**;21-MAR-94;Build 23 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -EN ; -- main entry point - N IBRESP - D FULL^VALM1 - F Q:'$$MENU(.IBRESP) D @IBRESP -ENQ ; - Q - ; -EN1 ; Provider maintenance from the billing screen 8 - N DIR,X,Y,IBEDIT - W ! - I '$D(^XUSEC("IB PROVIDER EDIT",DUZ)) S DIR(0)="EA",DIR("A")="Press ENTER to continue: ",DIR("A",1)="YOU LACK THE SECURITY KEY FOR THIS ACTION" D ^DIR K DIR Q - D EN - Q - ; -PO ; provider's own IDs - N IBPRV,IBINS - N IBSLEV,DIR,Y,X,IBPRMPT,IBNVAFL,IBIF - K IBFASTXT - S IBIF="" - S IBPRMPT="PROVIDER" - D FULL^VALM1 - S IBSLEV=1 - D EN^VALM("IBCE PRVPRV MAINT") -POX ; - Q - ; -PI ; provider's IDs provided by an insurance company - N IBPRV,IBINS - N IBSLEV,DIR,Y,X,IBPRMPT,IBNVAFL,IBIF - K IBFASTXT - S IBIF="" - S IBPRMPT="PROVIDER" - D FULL^VALM1 - S IBSLEV=2 - D EN^VALM("IBCE PRVPRV MAINT") -PIX ; - Q - ; -BI ; Insurance company batch ID entry - D EN^IBCEP9 -BIX ; - Q - ; -II ; Insurance company IDs - D EN^IBCEP0 -IIX ; - Q - ; -CP ; Care Unit maintenance - performing providers - N IBINS,IBALL,IB95 - N IBSLEV,DIR,Y - K IBFASTXT - D FULL^VALM1 - S IBSLEV=1 - D EN^VALM("IBCE PRVCARE UNIT MAINT") -CPX ; - Q - ; -CB ; Care Unit maintenance - billing provider - N IBINS,IBALL,IB95 - N IBSLEV,DIR,Y - K IBFASTXT - D FULL^VALM1 - S IBSLEV=2 - D EN^VALM("IBCE 2ND PRVID CARE UNIT MAINT") -CBX ; - Q - ; -NP ; non-VA individual provider information - N IBNVPMIF - S IBNVPMIF="I" - D EN^IBCEP8 -NPX ; - Q - ; -NF ; non-VA facility provider information - N IBNVPMIF - S IBNVPMIF="F" - D EN^IBCEP8 -NFX ; - Q - ; -MENU(IBSEL) ; display main provider ID maintenance menu and receive response from user - ; function value returns 0 if user exits from menu or "^" out - ; function value returns 1 otherwise - ; IBSEL is the internal value of the user's selection if any (pass by reference) - N IBQ,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,C,Z - N IORESET,IORVON,IORVOFF,IOUON,IOUOFF,IOINHI,IOINLOW,IOINORM - S IBQ=1,IBSEL="" - S X="IORESET;IORVON;IORVOFF;IOUON;IOUOFF;IOINHI;IOINLOW;IOINORM" - D ENDR^%ZISS - ; - S $P(DIR(0),U,1)="SOA" - S $P(Z,";",1)="PO:Provider Own IDs" - S $P(Z,";",2)="PI:Provider Insurance IDs" - S $P(Z,";",3)="BI:Batch ID Entry" - S $P(Z,";",4)="II:Insurance Co IDs" - S $P(Z,";",5)="CP:Care Units for Providers" - S $P(Z,";",6)="CB:Care Units for Billing Provider" - S $P(Z,";",7)="NP:Non-VA Provider" - S $P(Z,";",8)="NF:Non-VA Facility" - ; - S $P(DIR(0),U,2)=Z - ; - S DIR("L",1)=" "_IOINHI_"Provider IDs"_IOINORM - S DIR("L",2)=" "_$P($P(Z,";",1),":",1)_" "_$P($P(Z,";",1),":",2) - S DIR("L",3)=" "_$P($P(Z,";",2),":",1)_" "_$P($P(Z,";",2),":",2) - S DIR("L",4)="" - S DIR("L",5)=" "_IOINHI_"Insurance IDs"_IOINORM - S DIR("L",6)=" "_$P($P(Z,";",3),":",1)_" "_$P($P(Z,";",3),":",2) - S DIR("L",7)=" "_$P($P(Z,";",4),":",1)_" "_$P($P(Z,";",4),":",2) - S DIR("L",8)="" - S DIR("L",9)=" "_IOINHI_"Care Units"_IOINORM - S DIR("L",10)=" "_$P($P(Z,";",5),":",1)_" "_$P($P(Z,";",5),":",2) - S DIR("L",11)=" "_$P($P(Z,";",6),":",1)_" "_$P($P(Z,";",6),":",2) - S DIR("L",12)="" - S DIR("L",13)=" "_IOINHI_"Non-VA Items"_IOINORM - S DIR("L",14)=" "_$P($P(Z,";",7),":",1)_" "_$P($P(Z,";",7),":",2) - S DIR("L")=" "_$P($P(Z,";",8),":",1)_" "_$P($P(Z,";",8),":",2) - ; - S DIR("?")="^D MENH^IBCEP6" - S DIR("A")=" Select Provider ID Maintenance Option: " - ; - ; paint the screen and display menu first time in - D MENH - W ! - S C=0 F S C=$O(DIR("L",C)) Q:'C W !,DIR("L",C) - W !,DIR("L"),! - D ^DIR K DIR W ! - I $D(DIRUT) S IBQ=0 G MENUX - S IBSEL=Y - I IBSEL="" S IBQ=0 -MENUX ; - Q IBQ - ; -MENH ; menu help - W @IOF,!?4,"Provider ID Maintenance Main Menu" - W !!?4,"Enter a code from the list." -MENHX ; - Q - ; +IBCEP6 ;ALB/TMP - PROVIDER ID MAINT menu and INS CO EDIT hook ;11-02-00 + ;;2.0;INTEGRATED BILLING;**137,232,320**;21-MAR-94 + ; +EN ; -- main entry point for IBCE PRV INS PARAMS + D FULL^VALM1 + D EN^VALM("IBCE PRVMAINT") +ENQ Q + ; +HDR ; -- header code + K VALMHDR + Q + ; +INIT ; Initialization + N IBLCT,IBCT,Z,Z0 + S (IBLCT,IBCT)=0,XQORM("B")="Select" + K ^TMP("IBCE_PRVMAINT_MENU",$J) + F Z=1:1:2 S Z0=$J("",10) D SET1(.IBLCT,Z0,1) + S Z0=$J("",17)_"-- PROVIDER ID EDITS --" D SET1(.IBLCT,Z0,1),CNTRL^VALM10(IBLCT,18,23,IORVON,IORVOFF) + S Z0=$J("",10)_"1 > PROVIDER SPECIFIC IDS" D SET1(.IBLCT,Z0,1) + S Z0=$J("",14)_"o PROVIDER'S OWN IDS" D SET1(.IBLCT,Z0,1) + S Z0=$J("",14)_"o PROVIDER IDS FURNISHED BY INSURANCE CO" D SET1(.IBLCT,Z0,1) + S Z0=$J("",10)_"2 > INSURANCE CO IDS" D SET1(.IBLCT,Z0,2) + ;S Z0=$J("",10)_"3 > FACILITY IDS" D SET1(.IBLCT,Z0,3) ;WCJ removed + S Z0=$J("",10)_"4 > CARE UNIT MAINTENANCE" D SET1(.IBLCT,Z0,4) + S Z0=$J("",14)_"o Care Units for Performing Provider IDs" D SET1(.IBLCT,Z0,1) + S Z0=$J("",14)_"o Care Units for Billing Provider Secondary IDs" D SET1(.IBLCT,Z0,1) + S Z0=$J("",10)_"5 > INS CO BATCH ID ENTRY" D SET1(.IBLCT,Z0,5) + F Z=1:1:2 S Z0=$J("",10) D SET1(.IBLCT,Z0,6) + S Z0=$J("",14)_"-- NON/OTHER VA ENTITY EDITS --" D SET1(.IBLCT,Z0,6),CNTRL^VALM10(IBLCT,15,31,IORVON,IORVOFF) + S Z0=$J("",10)_"6 > NON/OTHER VA PROVIDER ID INFORMATION" D SET1(.IBLCT,Z0,6) + K VALMBG,VALMCNT + S VALMBG=1,VALMCNT=IBLCT + Q + ; +SET1(IBLCT,Z0,IBCT) ; + S IBLCT=IBLCT+1 D SET^VALM10(IBLCT,Z0,$G(IBCT)) + Q + ; +EXPND ; + Q + ; +HELP ; + Q + ; +EXIT ; + K ^TMP("IBCE_PRVMAINT_MENU",$J) + D CLEAN^VALM10 + Q + ; +SEL ; + N Z,Z1,DIR + D FULL^VALM1 + D EN^VALM2($G(XQORNOD(0)),"OS") + S Z=+$O(VALMY(0)) + I Z,Z<6,'$D(^XUSEC("IB PROVIDER EDIT",DUZ)) S DIR(0)="EA",DIR("A",1)="YOU ARE NOT AUTHORIZED TO EDIT PROVIDER IDS",DIR("A")="Press ENTER to continue" W ! D ^DIR K DIR W ! G SELQ + I Z=3 D G SELQ + . S DIR(0)="EA",DIR("A",1)="This Action is no longer available",DIR("A")="Press ENTER to continue" + . D ^DIR K DIR + I Z S Z1=$P($T(ACT+Z),U,2,3) I Z1'="" D @Z1 +SELQ K VALMBCK,XQORM("B") + S VALMBCK="R",XQORM("B")="Quit" + Q + ; +EN1 ; Provider maintenance from the billing screen 8 + N DIR,X,Y,IBEDIT + ;S IBEDIT=1 + W ! + ;S DIR(0)="YA",DIR("B")="NO",DIR("A",1)="WANT TO ATTEMPT TO RESET ALL PROVIDER IDS TO THE CALCULATED",DIR("A")="DEFAULTS FOR THIS BILL?: " D ^DIR K DIR + ;Q:$D(DTOUT)!$D(DUOUT) + ;I Y=1 S IBEDIT=0 D RECALCA^IBCEP2A(IBIFN) W ! + ; + I '$D(^XUSEC("IB PROVIDER EDIT",DUZ)) S DIR(0)="EA",DIR("A")="Press ENTER to continue: ",DIR("A",1)="YOU LACK THE SECURITY KEY FOR THIS ACTION" D ^DIR K DIR Q + ;I 'IBEDIT D + ;. S DIR(0)="YA",DIR("A")="WANT TO CONTINUE WITH GENERAL PROVIDER ID MAINTENANCE?: ",DIR("B")="NO" D ^DIR K DIR + ;. I $D(DTOUT)!$D(DUOUT)!'Y Q + ;. S IBEDIT=1 + D EN + Q + ; +ACT ; Actions available + ;;PROVIDER LEVEL ID EDIT^EN^IBCEP5 + ;;INS CO LEVEL ID EDIT^EN^IBCEP0 + ;; + ;;CARE UNIT EDIT^EN^IBCEP4 + ;;BATCH ID ENTRY BY INS CO^EN^IBCEP9 + ;;NON-VA PROVIDER EDIT^EN^IBCEP8 + ; + ; + ; + ;;SITE LEVEL ID EDIT^EN^IBCEP7 diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP8.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP8.m index 34772377..86d45db9 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP8.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP8.m @@ -1,226 +1,277 @@ -IBCEP8 ;ALB/TMP - Functions for NON-VA PROVIDER ;11-07-00 - ;;2.0;INTEGRATED BILLING;**51,137,232,288,320,343,374,377,391**;21-MAR-94;Build 39 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -EN ; -- main entry point - N IBNPRV - K IBFASTXT - D FULL^VALM1 - D EN^VALM("IBCE PRVNVA MAINT") - Q - ; -HDR ; -- header code - K VALMHDR - Q - ; -INIT ; Initialization - N DIC,DA,X,Y,DLAYGO,IBIF,DIR,DTOUT,DUOUT - K ^TMP("IBCE_PRVNVA_MAINT",$J) - ; - ; if coming in from main routine ^IBCEP6 this special variable IBNVPMIF is set already - I $G(IBNVPMIF)'="" S IBIF=IBNVPMIF G INIT1 - ; - S DIR("A")="(I)NDIVIDUAL OR (F)ACILITY?: ",DIR(0)="SA^I:INDIVIDUAL;F:FACILITY" D ^DIR K DIR - I $D(DUOUT)!$D(DTOUT) S VALMQUIT=1 G INITQ - S IBIF=Y - ; -INIT1 ; - ; - I IBIF="F" D - . S VALM("TITLE")="Non-VA Lab or Facility Info" - . K VALM("PROTOCOL") - . S Y=$$FIND1^DIC(101,,,"IBCE PRVNVA NONIND MAINT") - . I Y S VALM("PROTOCOL")=+Y_";ORD(101," - ; - S DIC="^IBA(355.93,",DIC("DR")=".02///"_$S(IBIF'="F":2,1:1) - S DIC("S")="I $P(^(0),U,2)="_$S(IBIF'="F":2,1:1) - S DLAYGO=355.93,DIC(0)="AELMQ",DIC("A")="Select a NON"_$S(IBIF="I":"-",1:"/OTHER ")_"VA PROVIDER: " - D ^DIC K DIC,DLAYGO - I Y'>0 S VALMQUIT=1 G INITQ - S IBNPRV=+Y - D BLD^IBCEP8B(IBNPRV) -INITQ Q - ; -EXPND ; - Q - ; -HELP ; - Q - ; -EXIT ; - K ^TMP("IBCE_PRVNVA_MAINT",$J) - D CLEAN^VALM10 - K IBFASTXT - Q - ; -EDIT1(IBNPRV,IBNOLM) ; Edit non-VA provider/facility demographics - ; IBNPRV = ien of entry in file 355.93 - ; IBNOLM = 1 if not called from list manager - ; - N DA,X,Y,DIE,DR,IBP - I '$G(IBNOLM) D FULL^VALM1 - I IBNPRV D - . I '$G(IBNOLM) D CLEAR^VALM1 - . S DIE="^IBA(355.93,",DA=IBNPRV,IBP=($P($G(^IBA(355.93,IBNPRV,0)),U,2)=2) - . ; PRXM/KJH - Added NPI and Taxonomy to the list of fields to be edited. Put a "NO^" around the Taxonomy multiple (#42) since some of the sub-field entries are 'required'. - . S DR=".01;"_$S(IBP:".03;.04",1:".05;.1;.06;.07;.08;.13///24;W !,""ID Qualifier: 24 - EMPLOYER'S IDENTIFICATION #"";.09Lab or Facility Primary ID;.11;.15")_";D PRENPI^IBCEP81(IBNPRV);D EN^IBCEP82(IBNPRV);S DIE(""NO^"")="""";42;K DIE(""NO^"")" - . D ^DIE - . Q:$G(IBNOLM) - . D BLD^IBCEP8B(IBNPRV) - I '$G(IBNOLM) K VALMBCK S VALMBCK="R" - Q - ; -EDITID(IBNPRV,IBSLEV) ; Link from this list template to maintain provider-specific ids - ; This entry point is called by 4 action protocols. - ; IBNPRV = ien of entry in file 355.93 (can be either an individual or a facility) (required) - ; IBSLEV = 1 for facility/provider own ID's - ; IBSLEV = 2 for facility/provider ID's furnished by an insurance company - ; - Q:'$G(IBNPRV) - Q:'$G(IBSLEV) - N IBPRV,IBIF - D FULL^VALM1 ; set full scrolling region - D CLEAR^VALM1 ; clear screen - S IBPRV=IBNPRV - ; - K IBFASTXT - S IBIF=$$GET1^DIQ(355.93,IBPRV,.02,"I") ; 1=facility/group 2=individual - D EN^VALM("IBCE PRVPRV MAINT") - ; - K VALMQUIT - S VALMBCK=$S($G(IBFASTXT)'="":"Q",1:"R") - Q - ; -NVAFAC ; Enter/edit Non-VA facility information - ; This entry point is called by the menu system for option IBCE PRVNVA FAC EDIT - N X,Y,DA,DIC,IBNPRV,DLAYGO - S DIC="^IBA(355.93,",DIC("S")="I $P(^(0),U,2)=1",DIC("DR")=".02///1" - S DLAYGO=355.93,DIC(0)="AELMQ",DIC("A")="Select a NON/Other VA FACILITY: " - D ^DIC K DIC,DLAYGO - I Y'>0 S VALMQUIT=1 G NVAFACQ - S IBNPRV=+Y - D EDIT1(IBNPRV,1) - ; -NVAFACQ Q - ; -GETFAC(IB,IBFILE,IBELE,IBSFD) ; Returns facility name,address lines or city-state-zip - ; IB = ien of entry in file - ; IBFILE = 0 for retrieval from file 4, 1 for retrieval from file 355.93 - ; If IBELE=0, returns name - ; =1, returns address line 1 - ; =2, returns address line 2 - ; =3, returns city, state zip - ; = "3C", returns city = "3S", state = "3Z", zip - ; IBSFD (optional) = Output formatter segment name if the output needs - ; to be screened thru the VAMCFD^IBCEF75 procedure for the flag - ; in the insurance company file - ; - N Z,IBX,IBZ - S IBX="" - ; - I $G(IBSFD)="SUB" D VAMCFD^IBCEF75(+$G(IBXIEN),.IBZ) I $D(IBZ),'$G(IBZ("C",1)) G GETFACX - ; - S Z=$S('IBFILE:$G(^DIC(4,+IB,1)),1:$G(^IBA(355.93,+IB,0))) - I +IBELE=0 S IBX=$S('IBFILE:$P($G(^DIC(4,+IB,0)),U),1:$P($G(^IBA(355.93,+IB,0)),U)) - I IBELE=1!(IBELE=12) S IBX=$S('IBFILE:$P(Z,U),1:$P(Z,U,5)) - I IBELE=2!(IBELE=12) S IBX=$S(IBELE=12:IBX_" ",1:"")_$S('IBFILE:$P(Z,U,2),1:$P(Z,U,10)) - ; - I +IBELE=3,'IBFILE D - . S:IBELE=3!(IBELE["C") IBX=$P(Z,U,3) Q:IBELE["C" - . S:IBELE=3 IBX=IBX_$S(IBX'="":", ",1:"") S:IBELE=3!(IBELE["S") IBX=IBX_$$STATE^IBCEFG1($P($G(^DIC(4,+IB,0)),U,2)) Q:IBELE["S" - . S:IBELE=3 IBX=IBX_" " S:IBELE=3!(IBELE["Z") IBX=IBX_$P(Z,U,4) - . Q - ; - I +IBELE=3,IBFILE D - . S:IBELE=3!(IBELE["C") IBX=$P(Z,U,6) Q:IBELE["C" - . S:IBELE=3 IBX=IBX_$S(IBX'="":", ",1:"") S:IBELE=3!(IBELE["S") IBX=IBX_$$STATE^IBCEFG1($P(Z,U,7)) - . S:IBELE=3 IBX=IBX_" " S:IBELE=3!(IBELE["Z") IBX=IBX_$P(Z,U,8) - . Q -GETFACX ; - Q IBX - ; -ALLID(IBPRV,IBPTYP,IBZ) ; Returns array IBZ for all ids for provider IBPRV - ; for all provider id types or for id type in IBPTYP - ; IBPRV = vp ien of provider - ; IBPTYP = ien of provider id type to return or "" for all - ; IBZ = array returned with internal data: - ; IBZ(file 355.9 ien)=ID type^ID#^ins co^form type^bill care type^care un^X12 code for id type - N Z,Z0 - K IBZ - G:'$G(IBPRV) ALLIDQ - S IBPTYP=$G(IBPTYP) - S Z=0 F S Z=$O(^IBA(355.9,"B",IBPRV,Z)) Q:'Z S Z0=$G(^IBA(355.9,Z,0)) D - . I $S(IBPTYP="":1,1:($P(Z0,U,6)=IBPTYP)) S IBZ(Z)=($P(Z0,U,6)_U_$P(Z0,U,7)_U_$P(Z0,U,2)_U_$P(Z0,U,4)_U_$P(Z0,U,5)_U_$P(Z0,U,3))_U_$P($G(^IBE(355.97,+$P(Z0,U,6),0)),U,3) - ; -ALLIDQ Q - ; -CLIA() ; Returns ien of CLIA # provider id type - N Z,IBZ - S (IBZ,Z)=0 F S Z=$O(^IBE(355.97,Z)) Q:'Z I $P($G(^(Z,0)),U,3)="X4",$P(^(0),U)["CLIA" S IBZ=Z Q - Q IBZ - ; -STLIC() ; Returns ien of STLIC# provider id type - N Z,IBZ - S (IBZ,Z)=0 F S Z=$O(^IBE(355.97,Z)) Q:'Z I $P($G(^(Z,1)),U,3) S IBZ=Z Q - Q IBZ - ; -TAXID() ; Returns ien of Fed tax id provider id type - N Z,IBZ - S (IBZ,Z)=0 F S Z=$O(^IBE(355.97,Z)) Q:'Z I $P($G(^(Z,1)),U,4) S IBZ=Z Q - Q IBZ - ; -CLIANVA(IBIFN) ; Returns CLIA # for a non-VA facility on bill ien IBIFN - N IBCLIA,IBZ,IBNVA,Z - S IBCLIA="",IBZ=$$CLIA() - I IBZ D - . S IBNVA=$P($G(^DGCR(399,IBIFN,"U2")),U,10) Q:'IBNVA - . S IBCLIA=$$IDFIND^IBCEP2(IBIFN,IBZ,IBNVA_";IBA(355.93,","",1) - Q IBCLIA - ; -VALFAC(X) ; Function returns 1 if format is valid for X12 facility name - ; Alpha/numeric/certain punctuation valid. Must start with an Alpha - N OK,VAL - S OK=1 - S VAL("A")="",VAL("N")="",VAL=",.- " - I $E(X)'?1A!'$$VALFMT(X,.VAL) S OK=0 - Q OK - ; -VALFMT(X,VAL) ; Returns 1 if format of X is valid, 0 if not - ; X = data to be examined - ; VAL = a 'string' of valid characters AND/OR (passed by reference) - ; if VAL("A") defined ==> Alpha - ; if VAL("A") defined ==> Numeric valid - ; if VAL("A") defined ==> Punctuation valid - ; any other character included in the string is checked individually - N Z - I $D(VAL("A")) D - . N Z0 - . F Z=1:1:$L(X) I $E(X,Z)?1A S Z0(Z)="" - . S Z0="" F S Z0=$O(Z0(Z0),-1) Q:'Z0 S $E(X,Z0)="" - I $D(VAL("N")) D - . N Z0 - . F Z=1:1:$L(X) I $E(X,Z)?1N S Z0(Z)="" - . S Z0="" F S Z0=$O(Z0(Z0),-1) Q:'Z0 S $E(X,Z0)="" - I $D(VAL("P")) D - . N Z0 - . F Z=1:1:$L(X) I $E(X,Z)?1P S Z0(Z)="" - . S Z0="" F S Z0=$O(Z0(Z0),-1) Q:'Z0 S $E(X,Z0)="" - I $G(VAL)'="" S X=$TR(X,VAL,"") - Q (X="") - ; -PS(IBXSAVE) ; Returns 1 if IBXSAVE("PSVC") indicates the svc was non-lab - ; - Q $S($G(IBXSAVE("PSVC"))="":0,1:"13"[IBXSAVE("PSVC")) - ; - ; Pass in the Internal Entry number to File 355.93 - ; Return the Primary ID and Qualifier (ID Type) from 355.9 -PRIMID(IEN35593) ; Return External Primary ID and ID Quailier - N INDXVAL,LIST,MSG,IDCODE - S INDXVAL=IEN35593_";IBA(355.93," - N SCREEN S SCREEN="I $P(^(0),U,8)" - D FIND^DIC(355.9,,"@;.06EI;.07","Q",INDXVAL,,,SCREEN,,"LIST","MSG") - I '+$G(LIST("DILIST",0)) Q "" ; No Primary ID - I +$G(LIST("DILIST",0))>1 Q "***ERROR***^***ERROR***" ; Bad. More than one. - ; Found just one - S IDCODE=$$GET1^DIQ(355.97,LIST("DILIST","ID",1,.06,"I"),.03) - Q $G(LIST("DILIST","ID",1,.07))_U_IDCODE_" - "_$G(LIST("DILIST","ID",1,.06,"E")) +IBCEP8 ;ALB/TMP - Functions for NON-VA PROVIDER ;11-07-00 + ;;2.0;INTEGRATED BILLING;**51,137,232,288,320,343,374**;21-MAR-94;Build 16 + ; +EN ; -- main entry point + N IBNPRV + K IBFASTXT + D FULL^VALM1 + D EN^VALM("IBCE PRVNVA MAINT") + Q + ; +HDR ; -- header code + K VALMHDR + Q + ; +INIT ; Initialization + N DIC,DA,X,Y,DLAYGO,IBIF,DIR,DTOUT,DUOUT + K ^TMP("IBCE_PRVNVA_MAINT",$J) + S DIR("A")="(I)NDIVIDUAL OR (F)ACILITY?: ",DIR(0)="SA^I:INDIVIDUAL;F:FACILITY" D ^DIR K DIR + I $D(DUOUT)!$D(DTOUT) S VALMQUIT=1 G INITQ + S IBIF=Y + ; + I IBIF="F" D + . S VALM("TITLE")="Non-VA Lab or Facility Info" + . K VALM("PROTOCOL") + . S Y=$$FIND1^DIC(101,,,"IBCE PRVNVA NONIND MAINT") + . I Y S VALM("PROTOCOL")=+Y_";ORD(101," + ; + S DIC="^IBA(355.93,",DIC("DR")=".02////"_$S(IBIF'="F":2,1:1) + S DIC("S")="I $P(^(0),U,2)="_$S(IBIF'="F":2,1:1) + S DLAYGO=355.93,DIC(0)="AELMQ",DIC("A")="Select a NON"_$S(IBIF="I":"-",1:"/OTHER ")_"VA PROVIDER: " + D ^DIC K DIC,DLAYGO + I Y'>0 S VALMQUIT=1 G INITQ + S IBNPRV=+Y + D BLD +INITQ Q + ; +BLD ; Build/Rebuild display + N IBLCT,IBCT,IBLST,IBPRI,IBIEN,Z,Z1,Z2 + K @VALMAR + S (IBLCT,IBCT)=0,Z=$G(^IBA(355.93,IBNPRV,0)) + S IBCT=IBCT+1 + S Z1=$J("Name: ",15)_$P(Z,U) D SET1(.IBLCT,Z1,IBCT) + I $P(Z,U,2)=2 D + . S IBCT=IBCT+1 + . S Z1=$J("Type: ",15)_$S($P(Z,U,2)=2:"INDIVIDUAL PROVIDER",1:"OUTSIDE OR OTHER VA FACILITY") D SET1(.IBLCT,Z1,IBCT) + . S IBCT=IBCT+1 + . S Z1=$J("Credentials: ",15)_$P(Z,U,3) D SET1(.IBLCT,Z1,IBCT) + . S IBCT=IBCT+1 + . S Z1=$J("Specialty: ",15)_$P(Z,U,4) D SET1(.IBLCT,Z1,IBCT) + . S IBCT=IBCT+1 + . S Z1=$J("NPI: ",15)_$$NPIGET^IBCEP81(IBNPRV) D SET1(.IBLCT,Z1,IBCT) + . S IBCT=IBCT+1 + . S IBPRI=$$TAXGET^IBCEP81(IBNPRV,.IBLST) + . S Z1=$J("Taxonomy Code: ",15)_$P(IBPRI,U) + . I $D(IBLST) S Z1=Z1_" ("_$S($P(IBLST(IBLST),U,3)=1:"Primary",1:"Secondary")_")" + . D SET1(.IBLCT,Z1,IBCT) + . S IBIEN="" + . F S IBIEN=$O(IBLST(IBIEN)) Q:IBIEN="" D + .. I IBIEN=IBLST Q + .. S IBCT=IBCT+1 + .. S Z1=$J("",15)_$P(IBLST(IBIEN),U)_" ("_$S($P(IBLST(IBIEN),U,3)=1:"Primary",1:"Secondary")_")" + .. D SET1(.IBLCT,Z1,IBCT) + E D + . S IBCT=IBCT+1 + . S Z1=$J("Address: ",15)_$P(Z,U,5) D SET1(.IBLCT,Z1,IBCT) + . I $P(Z,U,10) D + .. S IBCT=IBCT+1 + .. S Z1=$J("",15)_$P(Z,U,10) + . S IBCT=IBCT+1 + . S Z1=$J("",15)_$P(Z,U,6)_$S($P(Z,U,6)'="":", ",1:"")_$S($P(Z,U,7):$$EXTERNAL^DILFD(355.93,.07,"",$P(Z,U,7))_" ",1:"")_$P(Z,U,8) + . D SET1(.IBLCT,Z1,IBCT) + . S IBCT=IBCT+1 + . S Z1=" " D SET1(.IBLCT,Z1,IBCT) + . S IBCT=IBCT+1 + . S Z1=$J("Type of Facility: ",30)_$$EXTERNAL^DILFD(355.93,.11,,$P(Z,U,11)) + . D SET1(.IBLCT,Z1,IBCT) + . S IBCT=IBCT+1 + . S Z1=$J("Primary ID: ",30)_$P(Z,U,9) + . D SET1(.IBLCT,Z1,IBCT) + . S IBCT=IBCT+1 + . S Z1=$J("ID Qualifier: ",30)_$$GET1^DIQ(355.97,$P(Z,U,13),.03) I $P(Z,U,13)]"" S Z1=Z1_" - "_$$GET1^DIQ(355.97,$P(Z,U,13),.01) + . D SET1(.IBLCT,Z1,IBCT) + . S IBCT=IBCT+1 + . S Z1=$J("Mammography Certification #: ",30)_$P(Z,U,15) + . D SET1(.IBLCT,Z1,IBCT) + . S IBCT=IBCT+1 + . S Z1=$J("NPI: ",30)_$$NPIGET^IBCEP81(IBNPRV) D SET1(.IBLCT,Z1,IBCT) + . S IBCT=IBCT+1 + . S IBPRI=$$TAXGET^IBCEP81(IBNPRV,.IBLST) + . S Z1=$J("Taxonomy Code: ",30)_$P(IBPRI,U) + . I $D(IBLST) S Z1=Z1_" ("_$S($P(IBLST(IBLST),U,3)=1:"Primary",1:"Secondary")_")" + . D SET1(.IBLCT,Z1,IBCT) + . S IBIEN="" + . F S IBIEN=$O(IBLST(IBIEN)) Q:IBIEN="" D + .. I IBIEN=IBLST Q + .. S IBCT=IBCT+1 + .. S Z1=$J("",30)_$P(IBLST(IBIEN),U)_" ("_$S($P(IBLST(IBIEN),U,3)=1:"Primary",1:"Secondary")_")" + .. D SET1(.IBLCT,Z1,IBCT) + K VALMBG,VALMCNT + S VALMBG=1,VALMCNT=IBLCT + Q + ; +SET1(IBLCT,TEXT,IBCT) ; + S IBLCT=IBLCT+1 D SET^VALM10(IBLCT,TEXT,$G(IBCT)) + Q +EXPND ; + Q + ; +HELP ; + Q + ; +EXIT ; + K ^TMP("IBCE_PRVNVA_MAINT",$J) + D CLEAN^VALM10 + K IBFASTXT + Q + ; +EDIT1(IBNPRV,IBNOLM) ; Edit non-VA provider/facility demographics + ; IBNPRV = ien of entry in file 355.93 + ; IBNOLM = 1 if not called from list manager + ; + N DA,X,Y,DIE,DR,IBP + I '$G(IBNOLM) D FULL^VALM1 + I IBNPRV D + . I '$G(IBNOLM) D CLEAR^VALM1 + . S DIE="^IBA(355.93,",DA=IBNPRV,IBP=($P($G(^IBA(355.93,IBNPRV,0)),U,2)=2) + . ; PRXM/KJH - Added NPI and Taxonomy to the list of fields to be edited. Put a "NO^" around the Taxonomy multiple (#42) since some of the sub-field entries are 'required'. + . S DR=".01;"_$S(IBP:".03;.04",1:".05;.1;.06;.07;.08;.13///24;W !,""ID Qualifier: 24 - EMPLOYER'S IDENTIFICATION #"";.09Lab or Facility Primary ID;.11;.15")_";D EN^IBCEP82;S DIE(""NO^"")="""";42;K DIE(""NO^"")" + . D ^DIE + . Q:$G(IBNOLM) + . D BLD + I '$G(IBNOLM) K VALMBCK S VALMBCK="R" + Q + ; +EDITID(IBNPRV) ; Link from this list template to maintain provider-specific ids + ; IBNPRV = ien of entry in file 355.93 + N IBPRV + D FULL^VALM1 + D CLEAR^VALM1 + S IBPRV=IBNPRV + D EN1^IBCEP5 + K VALMQUIT + S VALMBCK="R" + Q + ; +NVAFAC ; Enter/edit Non-VA facility information + N X,Y,DA,DIC,IBNPRV,DLAYGO + S DIC="^IBA(355.93,",DIC("S")="I $P(^(0),U,2)=1",DIC("DR")=".02////1" + S DLAYGO=355.93,DIC(0)="AELMQ",DIC("A")="Select a NON/Other VA FACILITY: " + D ^DIC K DIC,DLAYGO + I Y'>0 S VALMQUIT=1 G NVAFACQ + S IBNPRV=+Y + D EDIT1(IBNPRV,1) + ; +NVAFACQ Q + ; +GETFAC(IB,IBFILE,IBELE,IBSFD) ; Returns facility name,address lines or city-state-zip + ; IB = ien of entry in file + ; IBFILE = 0 for retrieval from file 4, 1 for retrieval from file 355.93 + ; If IBELE=0, returns name + ; =1, returns address line 1 + ; =2, returns address line 2 + ; =3, returns city, state zip + ; = "3C", returns city = "3S", state = "3Z", zip + ; IBSFD (optional) = Output formatter segment name if the output needs + ; to be screened thru the VAMCFD^IBCEF75 procedure for the flag + ; in the insurance company file + ; + N Z,IBX,IBZ + S IBX="" + ; + I $G(IBSFD)="SUB" D VAMCFD^IBCEF75(+$G(IBXIEN),.IBZ) I $D(IBZ),'$G(IBZ("C",1)) G GETFACX + ; + S Z=$S('IBFILE:$G(^DIC(4,+IB,1)),1:$G(^IBA(355.93,+IB,0))) + I +IBELE=0 S IBX=$S('IBFILE:$P($G(^DIC(4,+IB,0)),U),1:$P($G(^IBA(355.93,+IB,0)),U)) + I IBELE=1!(IBELE=12) S IBX=$S('IBFILE:$P(Z,U),1:$P(Z,U,5)) + I IBELE=2!(IBELE=12) S IBX=$S(IBELE=12:IBX_" ",1:"")_$S('IBFILE:$P(Z,U,2),1:$P(Z,U,10)) + ; + I +IBELE=3,'IBFILE D + . S:IBELE=3!(IBELE["C") IBX=$P(Z,U,3) Q:IBELE["C" + . S:IBELE=3 IBX=IBX_$S(IBX'="":", ",1:"") S:IBELE=3!(IBELE["S") IBX=IBX_$$STATE^IBCEFG1($P($G(^DIC(4,+IB,0)),U,2)) Q:IBELE["S" + . S:IBELE=3 IBX=IBX_" " S:IBELE=3!(IBELE["Z") IBX=IBX_$P(Z,U,4) + . Q + ; + I +IBELE=3,IBFILE D + . S:IBELE=3!(IBELE["C") IBX=$P(Z,U,6) Q:IBELE["C" + . S:IBELE=3 IBX=IBX_$S(IBX'="":", ",1:"") S:IBELE=3!(IBELE["S") IBX=IBX_$$STATE^IBCEFG1($P(Z,U,7)) + . S:IBELE=3 IBX=IBX_" " S:IBELE=3!(IBELE["Z") IBX=IBX_$P(Z,U,8) + . Q +GETFACX ; + Q IBX + ; +ALLID(IBPRV,IBPTYP,IBZ) ; Returns array IBZ for all ids for provider IBPRV + ; for all provider id types or for id type in IBPTYP + ; IBPRV = vp ien of provider + ; IBPTYP = ien of provider id type to return or "" for all + ; IBZ = array returned with internal data: + ; IBZ(file 355.9 ien)=ID type^ID#^ins co^form type^bill care type^care un^X12 code for id type + N Z,Z0 + K IBZ + G:'$G(IBPRV) ALLIDQ + S IBPTYP=$G(IBPTYP) + S Z=0 F S Z=$O(^IBA(355.9,"B",IBPRV,Z)) Q:'Z S Z0=$G(^IBA(355.9,Z,0)) D + . I $S(IBPTYP="":1,1:($P(Z0,U,6)=IBPTYP)) S IBZ(Z)=($P(Z0,U,6)_U_$P(Z0,U,7)_U_$P(Z0,U,2)_U_$P(Z0,U,4)_U_$P(Z0,U,5)_U_$P(Z0,U,3))_U_$P($G(^IBE(355.97,+$P(Z0,U,6),0)),U,3) + ; +ALLIDQ Q + ; +CLIA() ; Returns ien of CLIA # provider id type + N Z,IBZ + S (IBZ,Z)=0 F S Z=$O(^IBE(355.97,Z)) Q:'Z I $P($G(^(Z,0)),U,3)="X4",$P(^(0),U)["CLIA" S IBZ=Z Q + Q IBZ + ; +STLIC() ; Returns ien of STLIC# provider id type + N Z,IBZ + S (IBZ,Z)=0 F S Z=$O(^IBE(355.97,Z)) Q:'Z I $P($G(^(Z,1)),U,3) S IBZ=Z Q + Q IBZ + ; +TAXID() ; Returns ien of Fed tax id provider id type + N Z,IBZ + S (IBZ,Z)=0 F S Z=$O(^IBE(355.97,Z)) Q:'Z I $P($G(^(Z,1)),U,4) S IBZ=Z Q + Q IBZ + ; +CLIANVA(IBIFN) ; Returns CLIA # for a non-VA facility on bill ien IBIFN + N IBCLIA,IBZ,IBNVA,Z + S IBCLIA="",IBZ=$$CLIA() + I IBZ D + . S IBNVA=$P($G(^DGCR(399,IBIFN,"U2")),U,10) Q:'IBNVA + . S IBCLIA=$$IDFIND^IBCEP2(IBIFN,IBZ,IBNVA_";IBA(355.93,","",1) + Q IBCLIA + ; +VALFAC(X) ; Function returns 1 if format is valid for X12 facility name + ; Alpha/numeric/certain punctuation valid. Must start with an Alpha + N OK,VAL + S OK=1 + S VAL("A")="",VAL("N")="",VAL=",.- " + I $E(X)'?1A!'$$VALFMT(X,.VAL) S OK=0 + Q OK + ; +VALFMT(X,VAL) ; Returns 1 if format of X is valid, 0 if not + ; X = data to be examined + ; VAL = a 'string' of valid characters AND/OR (passed by reference) + ; if VAL("A") defined ==> Alpha + ; if VAL("A") defined ==> Numeric valid + ; if VAL("A") defined ==> Punctuation valid + ; any other character included in the string is checked individually + N Z + I $D(VAL("A")) D + . N Z0 + . F Z=1:1:$L(X) I $E(X,Z)?1A S Z0(Z)="" + . S Z0="" F S Z0=$O(Z0(Z0),-1) Q:'Z0 S $E(X,Z0)="" + I $D(VAL("N")) D + . N Z0 + . F Z=1:1:$L(X) I $E(X,Z)?1N S Z0(Z)="" + . S Z0="" F S Z0=$O(Z0(Z0),-1) Q:'Z0 S $E(X,Z0)="" + I $D(VAL("P")) D + . N Z0 + . F Z=1:1:$L(X) I $E(X,Z)?1P S Z0(Z)="" + . S Z0="" F S Z0=$O(Z0(Z0),-1) Q:'Z0 S $E(X,Z0)="" + I $G(VAL)'="" S X=$TR(X,VAL,"") + Q (X="") + ; +PS(IBXSAVE) ; Returns 1 if IBXSAVE("PSVC") indicates the svc was non-lab + ; + Q $S($G(IBXSAVE("PSVC"))="":0,1:"13"[IBXSAVE("PSVC")) + ; + ; Pass in the Internal Entry number to File 355.93 + ; Return the Primary ID and Qualifier (ID Type) from 355.9 +PRIMID(IEN35593) ; Return External Primary ID and ID Quailier + N INDXVAL,LIST,MSG,IDCODE + S INDXVAL=IEN35593_";IBA(355.93," + N SCREEN S SCREEN="I $P(^(0),U,8)" + D FIND^DIC(355.9,,"@;.06EI;.07","Q",INDXVAL,,,SCREEN,,"LIST","MSG") + I '+$G(LIST("DILIST",0)) Q "" ; No Primary ID + I +$G(LIST("DILIST",0))>1 Q "***ERROR***^***ERROR***" ; Bad. More than one. + ; Found just one + S IDCODE=$$GET1^DIQ(355.97,LIST("DILIST","ID",1,.06,"I"),.03) + Q $G(LIST("DILIST","ID",1,.07))_U_IDCODE_" - "_$G(LIST("DILIST","ID",1,.06,"E")) diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP81.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP81.m index 2a058e25..1aebfa51 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP81.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP81.m @@ -1,199 +1,140 @@ -IBCEP81 ;ALB/KJH - NPI and Taxonomy Functions ;19 Apr 2008 5:17 PM - ;;2.0;INTEGRATED BILLING;**343,391**;21-MAR-94;Build 39 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ; Must call at an entry point - Q - ; - ; NPIREQ - Extrinsic function that will return a flag indicating - ; if the NPI 'drop dead date' has passed. - ; Input - ; IBDT - Date to check (internal Fileman format) - ; Output - ; 1 - On or after the May 23, 2008 drop dead date - ; 0 - Prior to the May 23, 2008 drop dead date -NPIREQ(IBDT) ; Check NPI drop dead date - N IBCHKDT - S IBCHKDT=3080523 - Q $S(IBDT0,IBNPI=IBOLDNPI,$D(^VA(200,"ANPI",IBOLDNPI)) Q 1 - I IBNPI="" Q "" - S DUP=$$DUP(IBNPI) - ;Duplicate in 355.93 - I DUP'="",DUP'=IBIEN Q 11 - ;Replacing an NPI that is associated to NEW PERSON file with another NPI that is associated with the NEW PERSON file - I $G(IBOLDNPI)>0,$D(^VA(200,"ANPI",IBOLDNPI)),$D(^VA(200,"ANPI",IBNPI)) Q 14 - ;Already an inactive NPI - S IBIEN2=$O(^IBA(355.93,"NPIHISTORY",IBNPI,"")) D:$G(IBIEN2)'="" - . S IBIEN1=$O(^IBA(355.93,IBIEN2,"NPISTATUS","C",IBNPI,""),-1) - I $G(IBIEN1)'="",$D(^IBA(355.93,IBIEN2,"NPISTATUS","NPISTATUS",0,IBIEN1)) Q 12 - ;Check for existence in New Person - ;file (#200) and/or Institution file (#4) - S IBVA200=$$QI^XUSNPI(IBNPI) - I $E($P(IBVA200,U,4),1,8)="Inactive" Q 13 - I $P(IBVA200,U)="Individual_ID",$P(IBVA200,U,4)["Active" Q 1 - I $P(IBVA200,U)="Organization_ID",$P(IBVA200,U,4)["Active" Q 9 - I $D(^DIC(4,"ANPI",IBNPI)) Q 9 - Q 0 - ; -PRENPI(IBIEN) ;Pre-NPI edit messages - N IBNPI,IBVA200 - Q:$G(IBIEN)="" - S IBNPI=$P($G(^IBA(355.93,IBIEN,0)),U,14) - Q:$G(IBNPI)="" - S IBVA200=$$QI^XUSNPI(IBNPI) - ;NPI that exists in 355.93 also is used in 200 - I $P(IBVA200,U,1)="Individual_ID",$P(IBVA200,U,4)["Active" D - . W !!,"The NPI of ",IBNPI," is also associated with the INDIVIDUAL provider ",!,$$GET1^DIQ(200,$P(IBVA200,U,2),.01)," in the NEW PERSON file." - . W !!,"You are updating ",$S($$GET1^DIQ(355.93,IBIEN,.02,"I")=1:"a FACILITY/GROUP",$$GET1^DIQ(355.93,IBIEN,.02,"I")=2:"an INDIVIDUAL",1:"a")," provider in the" - . W !,"IB NON/OTHER VA BILLING PROVIDER file.",! - ;The NPI used in 355.93 is inactive in 200 - I $P(IBVA200,U,1)="Individual_ID",$P(IBVA200,U,4)["Inactive" D - . W !!,"The NPI of ",IBNPI," is also associated with the INDIVIDUAL provider ",!,$$GET1^DIQ(200,$P(IBVA200,U,2),.01)," as INACTIVE in the NEW PERSON file." - . W !!,"You are updating ",$S($$GET1^DIQ(355.93,IBIEN,.02,"I")=1:"a FACILITY/GROUP",$$GET1^DIQ(355.93,IBIEN,.02,"I")=2:"an INDIVIDUAL",1:"a")," provider in the" - . W !,"IB NON/OTHER VA BILLING PROVIDER file.",! - Q +IBCEP81 ;ALB/KJH - NPI and Taxonomy Functions ; 12 Jul 2006 6:56 PM + ;;2.0;INTEGRATED BILLING;**343**;21-MAR-94;Build 16 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; + ; Must call at an entry point + Q + ; + ; NPIREQ - Extrinsic function that will return a flag indicating + ; if the NPI 'drop dead date' has passed. + ; Input + ; IBDT - Date to check (internal Fileman format) + ; Output + ; 1 - On or after the May 23, 2008 drop dead date + ; 0 - Prior to the May 23, 2008 drop dead date +NPIREQ(IBDT) ; Check NPI drop dead date + N IBCHKDT + S IBCHKDT=3080523 + Q $S(IBDT0 D ROLLBACK - Q - ; -DELNPI(IEN,OIEN) ;DELETE-INVALID removes NPI from file. - NEW DIE,DIK,DIC,DA,DR,D,D0,DI,DIC,DQ,X - NEW DP,DM,DK,DL,DIEL - S DIE="^IBA(355.93,",DA=IEN,DR="41.01////@" - D ^DIE - S DA(1)=IEN,DIK="^IBA(355.93,"_DA(1)_",""NPISTATUS"",",DA=OIEN - D ^DIK - Q - ; -INACT ;INACTIVATE AN ENTRY - ;This subroutine makes two entries in the NPI multiple field: - ;one for the deactivation of the old NPI and the second - ;for the activation of a new NPI. - S DA(1)=IBIEN,DIC="^IBA(355.93,"_DA(1)_",""NPISTATUS"",",DIC(0)="L",X=$$NOW^XLFDT() - S DIC("DR")=".02////^S X=0;.03////^S X=IBOLDNPI;.04////^S X=DUZ" - D FILE^DICN - S ^IBA(355.93,"NPIHISTORY",IBOLDNPI,DA(1))="" - K ^IBA(355.93,"NPI",IBOLDNPI,DA(1)) - S $P(^IBA(355.93,IBIEN,0),U,14)="" - I $G(IBCHECK)<2 D - .D ACTI - .S ^IBA(355.93,"NPIHISTORY",IBNPI,DA(1))="" - .D WARNR(IBIEN,IBOLDNPI,IBKEY) - Q - ; -ROLLBACK ;Rollback or delete NPI - S IBRBNPI=$P(^IBA(355.93,IBIEN,"NPISTATUS",IBRB,0),U,3) - NEW DIE,DIK,DIC,DA,DR,D,D0,DI,DIC,DQ,X - NEW DP,DM,DK,DL,DIEL - S DA(1)=IBIEN,DIK="^IBA(355.93,"_DA(1)_",""NPISTATUS"",",DA=IBRB - D ^DIK - S $P(^IBA(355.93,IBIEN,0),U,14)=IBRBNPI,^IBA(355.93,"NPI",IBRBNPI,IBIEN)="" - Q - ; -XIT ;CLEAN AND EXIT - Q - ; -XR ;Set the primary taxonomy code cross reference for field 42 - N ATAX S ATAX="" - I $D(^IBA(355.93,DA(1),"TAXONOMY","D")) D:X=1 - . F S ATAX=$O(^IBA(355.93,DA(1),"TAXONOMY","D",1,ATAX)) Q:ATAX="" D - .. K ^IBA(355.93,DA(1),"TAXONOMY","D",1,ATAX) - .. I ATAX'=DA S $P(^IBA(355.93,DA(1),"TAXONOMY",ATAX,0),U,2)=0,^IBA(355.93,DA(1),"TAXONOMY","D",0,ATAX)="" - S ^IBA(355.93,DA(1),"TAXONOMY","D",X,DA)="" - Q - ; -KXR ;Kill primary taxonomy code cross reference for field 42 - N K - F K=0,1 K ^IBA(355.93,DA(1),"TAXONOMY","D",K,DA) - Q - ; -WARNR(IBIEN,IBOLDNPI,IBKEY) ;Warn user that the old NPI that was replaced is currently used by an entry in the New Person file (#200) - N IBIEN200 - Q:$G(IBOLDNPI)="" - S IBIEN200=$O(^VA(200,"ANPI",IBOLDNPI,"")) - Q:IBIEN200="" - W !!,"WARNING: NPI ",IBOLDNPI," is also associated with Provider ",$$GET1^DIQ(200,IBIEN200,.01),".",! - I $O(^XUSEC(IBKEY,""))="" W !!,"There are no holders of the ",IBKEY," security key on the VistA system. Contact your IRM department for further direction." Q - W !,"A MailMan message has been sent to holders of the "_""""_IBKEY_""""_" security key." - D MAILR(IBIEN,IBKEY,IBIEN200,IBOLDNPI) - Q - ; -WARND(IBIEN,IBOLDNPI,IBKEY) ;Warn user that the old NPI that was deleted is currently used by an entry in the New Person file (#200) - N IBIEN200 - Q:$G(IBOLDNPI)="" - S IBIEN200=$O(^VA(200,"ANPI",IBOLDNPI,"")) - Q:IBIEN200="" - W !!,"WARNING: NPI ",IBOLDNPI," is also associated with VA Provider ",$$GET1^DIQ(200,IBIEN200,.01),".",! - I $O(^XUSEC(IBKEY,""))="" W !!,"There are no holders of the ",IBKEY," security key on the VistA system. Contact your IRM department for further direction." Q - W !,"A MailMan message has been sent to holders of the "_""""_IBKEY_""""_" security key." - D MAILD(IBIEN,IBKEY,IBIEN200,IBOLDNPI) - Q - ; -MAILR(IBIEN,IBKEY,IBIEN200,IBOLDNPI) ;Send mailman message for replacement of NPI - ;This subroutine is supported by IA# 10070 - ;Lookups in NEW PERSON file (#200) are supported by IA#10076 - N IBIEN2,XMDUZ,XMSUB,XMTEXT,XMY,IBMSG,XMZ,XMMG - S IBIEN2=0 F S IBIEN2=$O(^XUSEC(IBKEY,IBIEN2)) Q:IBIEN2="" S XMY(IBIEN2)="" - S XMDUZ=$S($G(DUZ):DUZ,1:.5),XMSUB="NPI Replacement" - S IBMSG(1)="The NPI "_IBOLDNPI_" was changed to "_IBNPI_" for" - S IBMSG(2)=$$GET1^DIQ(355.93,IBIEN,.01)_" in the IB NON/OTHER VA BILLING PROVIDER" - S IBMSG(3)="file. The NPI "_IBOLDNPI_" is also associated with" - S IBMSG(4)=$$GET1^DIQ(200,IBIEN200,.01)_" in the NEW PERSON file." - S IBMSG(5)="" - S IBMSG(6)="The same change may need to be made to the NEW PERSON file using the" - S IBMSG(7)="Add/Edit NPI values for Providers option." - S XMTEXT="IBMSG(" D ^XMD - Q - ; -MAILD(IBIEN,IBKEY,IBIEN200,IBOLDNPI) ;Send mailman message for deletion of an NPI - ;This subroutine is supported by IA# 10070 - ;Lookups in NEW PERSON file (#200) are supported by IA#10076 - N IBIEN2,XMDUZ,XMSUB,XMTEXT,XMY,IBMSG,XMZ,XMMG - S IBIEN2=0 F S IBIEN2=$O(^XUSEC(IBKEY,IBIEN2)) Q:IBIEN2="" S XMY(IBIEN2)="" - S XMDUZ=$S($G(DUZ):DUZ,1:.5),XMSUB="NPI Deletion" - S IBMSG(1)="The NPI "_IBOLDNPI_" was deleted for "_$$GET1^DIQ(355.93,IBIEN,.01) - S IBMSG(2)="in the IB NON/OTHER VA BILLING PROVIDER file. The NPI "_IBOLDNPI_" is also" - S IBMSG(3)="associated with "_$$GET1^DIQ(200,IBIEN200,.01)_" in the NEW PERSON file." - S IBMSG(4)="" - S IBMSG(5)="The same change may need to be made to the NEW PERSON file using the" - S IBMSG(6)="Add/Edit NPI values for Providers option." - S XMTEXT="IBMSG(" D ^XMD - Q +IBCEP82 ;ALB/CLT, Special cross references and data entry for fields in file 355.93 ; 14 Apr 2006 9:41 AM + ;;2.0;INTEGRATED BILLING;**343,374**;21-MAR-94;Build 16 + ; + ; Call at tags only + Q + ;This routine will ask for the NPI, check for duplicate entries, and check for proper + ;format using the double-add-double formula. If the NPI is being deleted it will ask + ;the user why it is being deleted. + ;If it is being deleted because of an erroneous entry it will be completely deleted. + ;If it is a valid NPI being deleted because of possible inappropriate usage it will be + ;maintained in the history cross reference to preclude anyone from using this NPI again. + ; +EN ;Routine primary entry point + N DTOUT,DUOUT,DIR,DIE,DIC,DR,X,Y + N IBIEN,IBNPI,IBCHECK,IBOLDNPI,IBRBNPI,IBRB + S IBIEN=DA,IBOLDNPI="" +EN1 ; + K DIR + S DIR(0)="FO^10:10",DIR("A")="NPI",DIR("?")="Enter a 10 digit National Provider Identifier" + I $G(DA) S:$P($G(^IBA(355.93,DA,0)),U,14)'="" (DIR("B"),IBOLDNPI)=$P($G(^IBA(355.93,DA,0)),U,14) + D ^DIR S IBCHECK=0 + I X="^" W *7,!," EXIT NOT ALLOWED ??" G EN1 + I $E(X)="^" W *7,!," JUMPING NOT ALLOWED ??" G EN1 + I X="@" G:IBOLDNPI'="" DEL W *7,"??" G EN1 + I $G(DUOUT)!$G(DTOUT)!(X="")!(Y=IBOLDNPI) G XIT + S IBNPI=Y + I '$$CHKDGT^XUSNPI(IBNPI) W !,*7,"Not a valid NPI. Please try again.",! G EN1 + I $$NPIUSED^IBCEP81(IBNPI) G EN1 + S IBCHECK=1 + I IBOLDNPI="" D ACTI + I IBOLDNPI'="" D:IBNPI'=IBOLDNPI INACT + S $P(^IBA(355.93,IBIEN,0),U,14)=IBNPI,^IBA(355.93,"NPI",IBNPI,IBIEN)="",^IBA(355.93,"NPIHISTORY",IBNPI,IBIEN)="" + G XIT + ; +ACTI ;CREATE AN ACTIVATED ENTRY IN MULTIPLE NPISTATUS FIELD + S DA(1)=IBIEN,DIC="^IBA(355.93,"_DA(1)_",""NPISTATUS"",",DIC(0)="L",X=$$NOW^XLFDT() + S DIC("DR")=".02////^S X=1;.03////^S X=IBNPI;.04////^S X=DUZ" + D FILE^DICN + S $P(^IBA(355.93,IBIEN,0),U,14)=IBNPI + Q + ; +DEL ;NPI HAS BEEN DELETED + ;If the user deletes the NPI this subroutine will determine why it was deleted and if it was because it was found + ;in a false identity situation will mark it in history to never be used again. + S IBNPI=DIR("B") + K DIR + S DIR(0)="Y" + S DIR("A")="Are you sure you wish to delete this NPI" + S DIR("?")="You have indicated you wish to delete the NPI. This is a second chance check." + D ^DIR + G:Y(0)="NO" XIT + S DIR(0)="S^E:ERROR;V:VALID",DIR("A")="Was this a Valid NPI or an NPI entered in Error" + S DIR("?",1)="An example of an NPI entered in error is if the entry person transposed numbers," + S DIR("?",2)="or if the NPI for one provider is accidentally assigned to a different provider." + S DIR("?")="Enter an 'E' for Error or a 'V' for Valid." + D ^DIR + I Y="E" D COMP W !,"The NPI has been deleted.",! + I Y="V" S IBCHECK=2 D INACT W !,"The NPI is now inactive.",! + Q + ; +COMP ;COMPLETELY DELETE THE NPI + ;This subroutine will delete the NPI from the file 355.93. + S OIEN=$O(^IBA(355.93,IBIEN,"NPISTATUS","C",IBOLDNPI,"A"),-1) + D DELNPI(IBIEN,OIEN) + K ^IBA(355.93,"NPI",IBOLDNPI,DA),^IBA(355.93,"NPIHISTORY",IBOLDNPI,DA) + S IBRB=0 + D ; Find the most recent status '0' (inactive) NPI entry in the list. + . N IBRBLST,IBRBTMP + . ; Don't want to roll back to the same number you are deleting. + . S IBRBLST(IBOLDNPI)="" + . S IBRBTMP="A" + . ; Go through each entry in reverse order + . F S IBRBTMP=$O(^IBA(355.93,IBIEN,"NPISTATUS",IBRBTMP),-1) Q:'IBRBTMP D Q:IBRB'=0 + .. S IBRBLST=^IBA(355.93,IBIEN,"NPISTATUS",IBRBTMP,0) + .. ; If this is an 'active' entry then ignore it. + .. I $P(IBRBLST,U,2)=1 Q + .. ; If this entry does not have an NPI then ignore it. + .. I $P(IBRBLST,U,3)="" Q + .. ;If this is an inactive entry then report it. + .. I $P(IBRBLST,U,2)=0 S IBRB=IBRBTMP Q + .. Q + . Q + I IBRB>0 D ROLLBACK + Q + ; +DELNPI(IEN,OIEN) ;DELETE-INVALID removes NPI from file. + NEW DIE,DIK,DIC,DA,DR,D,D0,DI,DIC,DQ,X + NEW DP,DM,DK,DL,DIEL + S DIE="^IBA(355.93,",DA=IEN,DR="41.01////@" + D ^DIE + S DA(1)=IEN,DIK="^IBA(355.93,"_DA(1)_",""NPISTATUS"",",DA=OIEN + D ^DIK + Q + ; +INACT ;INACTIVATE AN ENTRY + ;This subroutine makes two entries in the NPI multiple field. + ;One for the deactivation of the old NPI and the second + ;for the activation of a new NPI. + S DA(1)=IBIEN,DIC="^IBA(355.93,"_DA(1)_",""NPISTATUS"",",DIC(0)="L",X=$$NOW^XLFDT() + S DIC("DR")=".02////^S X=0;.03////^S X=IBOLDNPI;.04////^S X=DUZ" + D FILE^DICN + S ^IBA(355.93,"NPIHISTORY",IBOLDNPI,DA(1))="" + K ^IBA(355.93,"NPI",IBOLDNPI,DA(1)) + S $P(^IBA(355.93,IBIEN,0),U,14)="" + I $G(IBCHECK)<2 D ACTI + S ^IBA(355.93,"NPIHISTORY",IBNPI,DA(1))="" + Q + ; +ROLLBACK ;Rollback or delete NPI + S IBRBNPI=$P(^IBA(355.93,IBIEN,"NPISTATUS",IBRB,0),U,3) + NEW DIE,DIK,DIC,DA,DR,D,D0,DI,DIC,DQ,X + NEW DP,DM,DK,DL,DIEL + S DA(1)=IBIEN,DIK="^IBA(355.93,"_DA(1)_",""NPISTATUS"",",DA=IBRB + D ^DIK + S $P(^IBA(355.93,IBIEN,0),U,14)=IBRBNPI,^IBA(355.93,"NPI",IBRBNPI,IBIEN)="" + Q + ; +XIT ;CLEAN AND EXIT + Q + ; +XR ;Set the primary taxonomy code cross reference for field 42 + N ATAX S ATAX="" + I $D(^IBA(355.93,DA(1),"TAXONOMY","D")) D:X=1 + . F S ATAX=$O(^IBA(355.93,DA(1),"TAXONOMY","D",1,ATAX)) Q:ATAX="" D + .. K ^IBA(355.93,DA(1),"TAXONOMY","D",1,ATAX) + .. I ATAX'=DA S $P(^IBA(355.93,DA(1),"TAXONOMY",ATAX,0),U,2)=0,^IBA(355.93,DA(1),"TAXONOMY","D",0,ATAX)="" + S ^IBA(355.93,DA(1),"TAXONOMY","D",X,DA)="" + Q + ; +KXR ;Kill primary taxonomy code cross reference for field 42 + N K + F K=0,1 K ^IBA(355.93,DA(1),"TAXONOMY","D",K,DA) + Q diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEPA.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEPA.m index e6160de6..3688342c 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEPA.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEPA.m @@ -1,260 +1,247 @@ -IBCEPA ;ALB/WCJ - Provider ID functions - Care Units ;21-OCT-2005 - ;;2.0;INTEGRATED BILLING;**320,348,377**;21-MAR-94;Build 23 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -EN ; -- main entry point for IBCE 2ND PRVID CARE UNIT MAINT - D EN^VALM("IBCE 2ND PRVID CARE UNIT MAINT") - Q - ; -HDR ; -- header code - K VALMHDR - S VALMHDR(1)=" " - S VALMHDR(2)="Insurance Co: "_$S('$G(IBALL)&$G(IBINS):$P($G(^DIC(36,+IBINS,0)),U),1:"ALL") - Q - ; -INIT ; -- init variables and list array - N DIR,Y - I '$G(IBINS) D I +Y<0 S VALMQUIT=1 Q - . S DIR(0)="PA^DIC(36,:AEMQ",DIR("A")="Select INSURANCE CO: ",DIR("?")="Select an INSURANCE CO to display its care units" - . D ^DIR K DIR - . I $D(DTOUT)!$D(DUOUT) S Y=-2 Q - . I Y>0 S IBINS=+Y Q - ; - D BLD - Q - ; -BLD ; - D CLEAN^VALM10 - K ^TMP("IBPRV_CU",$J) - N TAR,MSG,I,D0,IBCT,Z,DIV,SCREEN - ; - S VALMBG=1 - ; - ; Get all care units for this insurance company that have a division - ; If there is no division, then it is part of the other care units code (IBCEP4) - ; - S SCREEN="I $P(^(0),U,4)'="""",$P(^(0),U,3)=IBINS" - D LIST^DIC(355.95,,"@;.01;.02;.04",,,,,,SCREEN,,"TAR") - ; - I '+TAR("DILIST",0) D - . D SET^VALM10(1,"No CARE UNITs found for this Insurance Company") - ; - I +TAR("DILIST",0) D - . S IBCT=0 - . F VALMCNT=1:1:+TAR("DILIST",0) D - .. S ^TMP("IBPRV_CU",$J,"SORT",TAR("DILIST","ID",VALMCNT,.04),TAR("DILIST",2,VALMCNT))=VALMCNT - . S DIV="" F S DIV=$O(^TMP("IBPRV_CU",$J,"SORT",DIV)) Q:DIV="" D - .. S Z="Division: "_DIV - .. S IBCT=IBCT+1 - .. D SET^VALM10(IBCT,Z) - .. S D0=0 F S D0=$O(^TMP("IBPRV_CU",$J,"SORT",DIV,D0)) Q:'D0 D - ... S IN=^TMP("IBPRV_CU",$J,"SORT",DIV,D0) - ... S Z=$J("",2) - ... S Z=Z_$E(IN_" ",1,4)_$E(TAR("DILIST","ID",IN,.01),1,36) - ... S Z=Z_$J("",40-$L(Z)) - ... S Z=Z_$E(TAR("DILIST","ID",IN,.02),1,38) - ... S IBCT=IBCT+1 - ... D SET^VALM10(IBCT,Z) - ; - ; correct the VALMCNT variable - number of lines in the list (not entries) - S VALMCNT=+$O(@VALMAR@(""),-1) - Q - ; -HELP ; -- help code - S X="?" D DISP^XQORM1 W !! - Q - ; -EXIT ; -- exit code - D CLEAN^VALM10 - K ^TMP("IBPRV_CU",$J) - Q - ; -EXPND ; -- expand code - Q - ; -NEW ; Add care unit - ; Assumes IBINS is defined as ins co ien (file 36) - ; IB = 0 or null if called from list manager, 1 if not - N DIC,DIR,X,Y,Z,D,DA,DR,DIE,DO,DD,DLAYGO,IB95,IBADD,IBOK,IBDIV,MAIN,IBDIVNM - ; - D FULL^VALM1 - ; Add an entry - either new care unit/ins co or a combination for - ; existing care unit/ins co - ; - S MAIN=$$MAIN^IBCEP2B() - S MAIN=$$EXTERNAL^DILFD(355.92,.05,"",MAIN) - S DIC=40.8,DIC("A")="Enter the Division for this Care Unit: ",DIC("B")=MAIN,DIC(0)="AEMQ" - S D="B^C" - D MIX^DIC1 - I Y'>0 G NEWQ - S IBDIV=+Y - S IBDIVNM=$$EXTERNAL^DILFD(355.92,.05,"",IBDIV) - ; - N SCREEN,TAR,MESS,I - S SCREEN="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)=+$G(IBDIV)" - D LIST^DIC(355.95,,.01,,,,,,SCREEN,,"TAR") - ; -ACU K DIR - S I=0 - I $G(TAR("DILIST",0)) D - . S DIR("?",1)="Current Entries are:" - . F I=2:1 Q:'$D(TAR("DILIST",1,I-1)) S DIR("?",I)=" "_TAR("DILIST",1,I-1) - . S DIR("?",I)=" " - ; - S DIR("?",I+1)="You may enter the name of a new Care Unit for this Insurance Company." - S DIR("?",I+2)="You can then define a Billing Provider Secondary ID - Billing Screen 3 - for" - S DIR("?")="this Care Unit and Insurance Company using the Insurance Company Editor." - S DIR("A")="Enter the Care Unit name" - S DIR(0)="FO^1:30" - D ^DIR - I X=""!$G(DUOUT)!$G(DTOUT)!$G(DIROUT) G NEWQ - S CAREUNIT=X - ; - ; At this point, we have X and it'a not a ? or ^ - ; - K DIC - S DIC="^IBA(355.95,",DIC("S")="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)=+$G(IBDIV)",DIC(0)="EX" - D ^DIC - ; - ; Check if we have an exisitng entry and if so, get out of Dodge (This option was for new care units) - I Y>0 D G ACU - . D DISPMESS("This action is for adding new entries, not editing existing entries.") - ; - ; New entry , validate field - N TAR2 - D FIELD^DID(355.95,.01,"N","INPUT TRANSFORM","TAR2") - S X=CAREUNIT - X TAR2("INPUT TRANSFORM") - I '$D(X) D G ACU ; Failed input transform - . D DISPMESS("Invalid Format.") - ; - K DIR - S DIR("A")="Are you adding '"_X_"' as a new Care Unit for '"_IBDIVNM_"'" - S DIR("B")="N" - S DIR(0)="Y" - D ^DIR - I Y=0 G ACU - I Y["^" G NEWQ - ; - ; If it got this far, we have an exact match or a new entry. - S X=CAREUNIT - S DIC="^IBA(355.95,",DIC("S")="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)=+$G(IBDIV)",DIC(0)="XL",DLAYGO=355.95 - S DIC("DR")=".03////"_+$G(IBINS)_";.04////"_$G(IBDIV) - D ^DIC - I Y>0 D - . S DA=+Y,DIE="^IBA(355.95," - . S DR=".02Enter the Care Unit Description" - . D ^DIE - D BLD - ; -NEWQ S VALMBCK="R" - Q - ; -CHANGE ; Edit care unit - ; Assumes IBINS is defined as ins co ien (file 36) - ; - D FULL^VALM1 - ; - N X,Y,Z,D,DA,DD,DIC,DIK,DIR,IBDIV,CAREUNIT,SCREEN,TAR,DIVISION,I - ; - S SCREEN="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)]""""" - D LIST^DIC(355.95,,".01;.04",,,,,,SCREEN,,"TAR") - ; - I '+$G(TAR("DILIST",0)) D G CHANGEQ - .D DISPMESS("No Care Units Defined for this insurance company.") - ; - ; Store all Divisons with at least one care unit in DIVISION array - F I=1:1 Q:'$D(TAR("DILIST","ID",I,.04)) D - . S DIVISION(TAR("DILIST","ID",I,.04))="" - ; - ; Only allow divisions that have care units to be selected - S DIC=40.8 - S DIC("A")="Enter the Division for this Care Unit: " - S DIC(0)="AEMQ" - S DIC("S")="I $D(DIVISION($P(^(0),U)))" - S D="B^C" - D MIX^DIC1 - I Y'>0 G CHANGEQ - S IBDIV=+Y - S DA=$$SEL($P(Y,U,2)) I 'DA G CHANGEQ - S DIE=355.95 - S DR=".01Care Unit;.04Division;.02Description" - D ^DIE - ; - D BLD - ; -CHANGEQ S VALMBCK="R" - Q - ; -DEL ; Delete a Care Unit - ; Assumes IBINS is defined as ins co ien (file 36) - ; - D FULL^VALM1 - N X,Y,Z,D,DA,DD,DIC,DIK,DIR,IBDIV,CAREUNIT,SCREEN,TAR,DIVISION - ; - S SCREEN="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)]""""" - D LIST^DIC(355.95,,".01;.04",,,,,,SCREEN,,"TAR") - ; - I '+$G(TAR("DILIST",0)) D G DELQ - .D DISPMESS("No Care Units Defined for this insurance company.") - ; - ; Store all Divisons with at least one care unit in DIVISION array - F I=1:1 Q:'$D(TAR("DILIST","ID",I,.04)) D - . S DIVISION(TAR("DILIST","ID",I,.04))="" - ; - ; Only allow divisions that have care units to be selected - S DIC=40.8 - S DIC("A")="Enter the Division for this Care Unit: " - S DIC(0)="AEMQ" - S DIC("S")="I $D(DIVISION($P(^(0),U)))" - S D="B^C" - D MIX^DIC1 - I Y'>0 G DELQ - S IBDIV=+Y - S CAREUNIT=$$SEL($P(Y,U,2)) I 'CAREUNIT G DELQ - ; - I $D(^IBA(355.92,"AC",+Y)) D G DELQ - . S DIR(0)="EA" - . S DIR("A",1)="IDs that are assigned to the Care Unit in the Insurance Company Editor must be" - . S DIR("A",2)="deleted before deleting the Care Unit." - . S DIR("A")="Press return to continue " - . W ! D ^DIR K DIR - ; - S DIR("A")="OK to Delete: " - S DIR("B")="No" - S DIR(0)="YAO" - D ^DIR - I '$G(Y) G DELQ - K DIR - ; - S DA=CAREUNIT - S DIK="^IBA("_355.95_"," - D ^DIK - ; - D BLD - ; -DELQ S VALMBCK="R" - Q - ; -DISPMESS(MESS) ; - N DIR,X,Y - S DIR(0)="EA",DIR("A",1)=MESS - S DIR("A")="PRESS ENTER to continue " - D ^DIR - Q - ; -SEL(DIV) ; select care unit for a given division - ; DIV - name of division - ; returns ien of selected care unit, or 0 if nothing is selected - N DIR,I,IEN,MIN,MAX,X,Y - I $G(DIV)="" Q 0 - S IEN=0 - S I=$O(^TMP("IBPRV_CU",$J,"SORT",DIV,"")),MIN=$G(^TMP("IBPRV_CU",$J,"SORT",DIV,I)) - S I=$O(^TMP("IBPRV_CU",$J,"SORT",DIV,""),-1),MAX=$G(^TMP("IBPRV_CU",$J,"SORT",DIV,I)) - I MIN=MAX S IEN=I - I MIN'=MAX D - .S DIR("A")="Select CARE UNITS",DIR(0)="N^"_MIN_":"_MAX_":0" D ^DIR - .Q:$D(DTOUT)!$D(DUOUT) - .S I="" F S I=$O(^TMP("IBPRV_CU",$J,"SORT",DIV,I)) Q:I=""!(IEN>0) S:$G(^TMP("IBPRV_CU",$J,"SORT",DIV,I))=Y IEN=I - .Q - Q IEN +IBCEPA ;ALB/WCJ - Provider ID functions - Care Units ;21-OCT-2005 + ;;2.0;INTEGRATED BILLING;**320,348**;21-MAR-94;Build 5 +EN ; -- main entry point for IBCE 2ND PRVID CARE UNIT MAINT + D EN^VALM("IBCE 2ND PRVID CARE UNIT MAINT") + Q + ; +HDR ; -- header code + K VALMHDR + S VALMHDR(1)=" " + S VALMHDR(2)="Insurance Co: "_$S('$G(IBALL)&$G(IBINS):$P($G(^DIC(36,+IBINS,0)),U),1:"ALL") + Q + ; +INIT ; -- init variables and list array + N DIR,Y + I '$G(IBINS) D I +Y<0 S VALMQUIT=1 Q + . S DIR(0)="PA^DIC(36,:AEMQ",DIR("A")="Select INSURANCE CO: ",DIR("?")="Select an INSURANCE CO to display its care units" + . D ^DIR K DIR + . I $D(DTOUT)!$D(DUOUT) S Y=-2 Q + . I Y>0 S IBINS=+Y Q + ; + D BLD + Q + ; +BLD ; + D CLEAN^VALM10 + K ^TMP("IBPRV_CU",$J) + N TAR,MSG,I,D0,IBLCT,Z,DIV,SCREEN + ; + S VALMBG=1 + ; + ; Get all care units for this insurance company that have a division + ; If there is no division, then it is part of the other care units code (IBCEP4) + ; + S SCREEN="I $P(^(0),U,4)'="""",$P(^(0),U,3)=IBINS" + D LIST^DIC(355.95,,"@;.01;.02;.04",,,,,,SCREEN,,"TAR") + ; + I '+TAR("DILIST",0) D + . D SET^VALM10(1,"No CARE UNITs found for this Insurance Company") + ; + I +TAR("DILIST",0) D + . S IBCT=0 + . F VALMCNT=1:1:+TAR("DILIST",0) D + .. S ^TMP("IBPRV_CU",$J,"SORT",TAR("DILIST","ID",VALMCNT,.04),TAR("DILIST",2,VALMCNT))=VALMCNT + . S DIV="" F S DIV=$O(^TMP("IBPRV_CU",$J,"SORT",DIV)) Q:DIV="" D + .. S Z="Division: "_DIV + .. S IBCT=IBCT+1 + .. D SET^VALM10(IBCT,Z) + .. S D0=0 F S D0=$O(^TMP("IBPRV_CU",$J,"SORT",DIV,D0)) Q:'D0 D + ... S IN=^TMP("IBPRV_CU",$J,"SORT",DIV,D0) + ... S Z=$J("",2) + ... S Z=Z_$E(TAR("DILIST","ID",IN,.01),1,36) + ... S Z=Z_$J("",40-$L(Z)) + ... S Z=Z_$E(TAR("DILIST","ID",IN,.02),1,38) + ... S IBCT=IBCT+1 + ... D SET^VALM10(IBCT,Z) + Q + ; +HELP ; -- help code + S X="?" D DISP^XQORM1 W !! + Q + ; +EXIT ; -- exit code + D CLEAN^VALM10 + Q + ; +EXPND ; -- expand code + Q + ; +NEW ; Add care unit + ; Assumes IBINS is defined as ins co ien (file 36) + ; IB = 0 or null if called from list manager, 1 if not + N DIC,DIR,X,Y,Z,DA,DR,DIE,DO,DD,DLAYGO,IB95,IBADD,IBOK,IBDIV,MAIN,IBDIVNM + ; + D FULL^VALM1 + ; Add an entry - either new care unit/ins co or a combination for + ; existing care unit/ins co + ; + S MAIN=$$MAIN^IBCEP2B() + S MAIN=$$EXTERNAL^DILFD(355.92,.05,"",MAIN) + S DIC=40.8,DIC("A")="Enter the Division for this Care Unit: ",DIC("B")=MAIN,DIC(0)="AEMQ" + D ^DIC + I Y'>0 G NEWQ + S IBDIV=+Y + S IBDIVNM=$$EXTERNAL^DILFD(355.92,.05,"",IBDIV) + ; + N SCREEN,TAR,MESS,I + S SCREEN="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)=+$G(IBDIV)" + D LIST^DIC(355.95,,.01,,,,,,SCREEN,,"TAR") + ; +ACU K DIR + S I=0 + I $G(TAR("DILIST",0)) D + . S DIR("?",1)="Current Entries are:" + . F I=2:1 Q:'$D(TAR("DILIST",1,I-1)) S DIR("?",I)=" "_TAR("DILIST",1,I-1) + . S DIR("?",I)=" " + ; + S DIR("?",I+1)="You may enter the name of a new Care Unit for this Insurance Company." + S DIR("?",I+2)="You can then define a Billing Provider Secondary ID - Billing Screen 3 - for" + S DIR("?")="this Care Unit and Insurance Company using the Insurance Company Editor." + S DIR("A")="Enter the Care Unit name" + S DIR(0)="FO^1:30" + D ^DIR + I X=""!$G(DUOUT)!$G(DTOUT)!$G(DIROUT) G NEWQ + S CAREUNIT=X + ; + ; At this point, we have X and it'a not a ? or ^ + ; + K DIC + S DIC="^IBA(355.95,",DIC("S")="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)=+$G(IBDIV)",DIC(0)="EX" + D ^DIC + ; + ; Check if we have an exisitng entry and if so, get out of Dodge (This option was for new care units) + I Y>0 D G ACU + . D DISPMESS("This action is for adding new entries, not editing existing entries.") + ; + ; New entry , validate field + N TAR2 + D FIELD^DID(355.95,.01,"N","INPUT TRANSFORM","TAR2") + S X=CAREUNIT + X TAR2("INPUT TRANSFORM") + I '$D(X) D G ACU ; Failed input transform + . D DISPMESS("Invalid Format.") + ; + K DIR + S DIR("A")="Are you adding '"_X_"' as a new Care Unit for '"_IBDIVNM_"'" + S DIR("B")="N" + S DIR(0)="Y" + D ^DIR + I Y=0 G ACU + I Y["^" G NEWQ + ; + ; If it got this far, we have an exact match or a new entry. + S X=CAREUNIT + S DIC="^IBA(355.95,",DIC("S")="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)=+$G(IBDIV)",DIC(0)="XL",DLAYGO=355.95 + S DIC("DR")=".03////"_+$G(IBINS)_";.04////"_$G(IBDIV) + D ^DIC + I Y>0 D + . S DA=+Y,DIE="^IBA(355.95," + . S DR=".02Enter the Care Unit Description" + . D ^DIE + D BLD + ; +NEWQ S VALMBCK="R" + Q + ; +CHANGE ; Edit care unit + ; Assumes IBINS is defined as ins co ien (file 36) + ; + D FULL^VALM1 + ; + N X,Y,Z,DA,DD,DIC,DIK,DIR,IBDIV,CAREUNIT,SCREEN,TAR,DIVISION + ; + S SCREEN="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)]""""" + D LIST^DIC(355.95,,".01;.04",,,,,,SCREEN,,"TAR") + ; + I '+$G(TAR("DILIST",0)) D G CHANGEQ + .D DISPMESS("No Care Units Defined for this insurance company.") + ; + ; Store all Divisons with at least one care unit in DIVISION array + F I=1:1 Q:'$D(TAR("DILIST","ID",I,.04)) D + . S DIVISION(TAR("DILIST","ID",I,.04))="" + ; + ; Only allow divisions that have care units to be selected + S DIC=40.8 + S DIC("A")="Enter the Division for this Care Unit: " + S DIC(0)="AEMQ" + S DIC("S")="I $D(DIVISION($P(^(0),U)))" + D ^DIC + I Y'>0 G CHANGEQ + S IBDIV=+Y + ; + S DIC("A")="Enter the Care Unit name: " + S DIC=355.95,DIC("S")="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)=+$G(IBDIV)",DIC(0)="AEMQ" + D ^DIC + I Y<1 G CHANGEQ + ; + S DA=+Y,DIE=355.95 + S DR=".01Care Unit;.04Division;.02Description" + D ^DIE + ; + D BLD + ; +CHANGEQ S VALMBCK="R" + Q + ; +DEL ; Delete a Care Unit + ; Assumes IBINS is defined as ins co ien (file 36) + ; + D FULL^VALM1 + N X,Y,Z,DA,DD,DIC,DIK,DIR,IBDIV,CAREUNIT,SCREEN,TAR,DIVISION + ; + S SCREEN="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)]""""" + D LIST^DIC(355.95,,".01;.04",,,,,,SCREEN,,"TAR") + ; + I '+$G(TAR("DILIST",0)) D G DELQ + .D DISPMESS("No Care Units Defined for this insurance company.") + ; + ; Store all Divisons with at least one care unit in DIVISION array + F I=1:1 Q:'$D(TAR("DILIST","ID",I,.04)) D + . S DIVISION(TAR("DILIST","ID",I,.04))="" + ; + ; Only allow divisions that have care units to be selected + S DIC=40.8 + S DIC("A")="Enter the Division for this Care Unit: " + S DIC(0)="AEMQ" + S DIC("S")="I $D(DIVISION($P(^(0),U)))" + D ^DIC + I Y'>0 G DELQ + S IBDIV=+Y + ; + K DIC + S DIC("A")="Enter the Care Unit name: " + S DIC=355.95,DIC("S")="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)=+$G(IBDIV)",DIC(0)="AEMQ" + D ^DIC + I Y<1 G DELQ + S CAREUNIT=+Y + ; + I $D(^IBA(355.92,"AC",+Y)) D G DELQ + . S DIR(0)="EA" + . S DIR("A",1)="IDs that are assigned to the Care Unit in the Insurance Company Editor must be" + . S DIR("A",2)="deleted before deleting the Care Unit." + . S DIR("A")="Press return to continue " + . W ! D ^DIR K DIR + ; + S DIR("A")="OK to Delete: " + S DIR("B")="No" + S DIR(0)="YAO" + D ^DIR + I '$G(Y) G DELQ + K DIR + ; + S DA=CAREUNIT + S DIK="^IBA("_355.95_"," + D ^DIK + ; + D BLD + ; +DELQ S VALMBCK="R" + Q + ; +DISPMESS(MESS) ; + N DIR,X,Y + S DIR(0)="EA",DIR("A",1)=MESS + S DIR("A")="PRESS ENTER to continue " + D ^DIR + Q + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCERP3.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCERP3.m index 494d88a9..31fda943 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCERP3.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCERP3.m @@ -1,134 +1,58 @@ -IBCERP3 ;ALB/TMP - EDI BATCHES WAITING MORE THAN 1 DAY REPORT ;30-SEP-96 - ;;2.0;INTEGRATED BILLING;**137,296,377**;21-MAR-94;Build 23 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - Q - ; -PENDING ; Report of batches not sent after the day the bills in it were extracted - report entry point - ; - NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,IBCLM - I '$O(^IBA(364.1,"ASTAT","P",0)) W !!,"There are no batches that are Pending Austin Receipt.",! S DIR(0)="E" D ^DIR K DIR G EX - ; - ; Ask user if they want to include claim level detail - S DIR(0)="Y",DIR("A")="Include Claims in each Batch",DIR("B")="Yes" - W ! D ^DIR K DIR - I $D(DIRUT) G EX - S IBCLM=+Y - ; - D DEVICE -EX ; - Q - ; -DEVICE ; selection of device on which to print report - NEW ZTRTN,ZTDESC,ZTSAVE,POP - W !!,"This report is 80 characters wide." - S ZTRTN="COMPILE^IBCERP3" - S ZTDESC="REPORT OF BILL BATCHES WAITING AUSTIN RECEIPT AFTER 1 DAY" - S ZTSAVE("IBCLM")="" - D EN^XUTMDEVQ(ZTRTN,ZTDESC,.ZTSAVE,"QM") -DEVICEX ; - Q - ; -COMPILE ; Queued job entrypoint - N IBBA,IB0,IB1,IEN,IBZ,IBIFN,IB399,CLM,BALDUE,IBSTAT,ARSTAT,IB - ; - K ^TMP($J,"IBSORT") - S IBBA=0 - F S IBBA=$O(^IBA(364.1,"ASTAT","P",IBBA)) Q:'IBBA D - . I $$BCHCHK^IBCEBUL(IBBA) Q ; Batch check function - . S IB0=$G(^IBA(364.1,IBBA,0)),IB1=$G(^(1)) - . S:$P(IB0,U,7)="" $P(IB0,U,7)="~" - . S ^TMP($J,"IBSORT",$P(IB0,U,7),$P(IB0,U,1),IBBA)=$P(IB1,U,6)_U_$P(IB0,U,4) - . ; - . I 'IBCLM Q ; include claim data flag - . ; - . ; gather the EDI claim data for this batch - . S IEN=0 F S IEN=$O(^IBA(364,"C",IBBA,IEN)) Q:'IEN D - .. S IBZ=$G(^IBA(364,IEN,0)),IBIFN=+IBZ,IB399=$G(^DGCR(399,IBIFN,0)) - .. S CLM=$P(IB399,U,1) S:CLM="" CLM="~" - .. S BALDUE=$G(^DGCR(399,IBIFN,"U1")),BALDUE=$P(BALDUE,U,1)-$P(BALDUE,U,2) - .. S IBSTAT=$$EXTERNAL^DILFD(399,.13,,$P(IB399,U,13)) - .. S ARSTAT=$$EXTERNAL^DILFD(430,8,,+$P($$BILL^RCJIBFN2(IBIFN),U,2)) - .. S IB=$P(IBZ,U,8)_U_BALDUE_U_$P(IBZ,U,3)_U_IBSTAT_U_ARSTAT - .. S ^TMP($J,"IBSORT",$P(IB0,U,7),$P(IB0,U,1),IBBA,CLM,IEN)=IB - .. Q - . Q - ; - D PRINT ; print report - D ^%ZISC ; close the device - K ^TMP($J,"IBSORT") ; clean up scratch global - I $D(ZTQUEUED) S ZTREQ="@" ; purge the task record - ; -COMPX ; - Q - ; -PRINT ; print the report to the specified device - ; - NEW CRT,IBPAGE,IBSTOP,IBCT,IBTYP,IBBAT,IBBA,IBV,CLM,IEN,DIR,X,Y,Z - I IOST["C-" S CRT=1 - E S CRT=0 - ; - S IBPAGE=0 - I '$D(^TMP($J,"IBSORT")) D HDR1 W !,?3,"No batches found Pending Austin Receipt for >1 day." - S (IBSTOP,IBCT)=0 - ; - S IBTYP="" - F S IBTYP=$O(^TMP($J,"IBSORT",IBTYP)) Q:IBTYP="" D Q:IBSTOP - . D HDR1 - . S IBBAT="" - . F S IBBAT=$O(^TMP($J,"IBSORT",IBTYP,IBBAT)) Q:'IBBAT!(IBSTOP) S IBBA=0 F S IBBA=$O(^TMP($J,"IBSORT",IBTYP,IBBAT,IBBA)) Q:'IBBA!IBSTOP S IBV=$G(^(IBBA)) D Q:IBSTOP - .. D:$Y>(IOSL-4) HDR1 Q:IBSTOP - .. W !,?2,IBBAT,?16,$$FMTE^XLFDT($P(IBV,U,1),"5Z"),?42,$P(IBV,U,2) - .. S IBCT=IBCT+1 - .. I 'IBCLM Q ; no claim level detail - .. I $O(^TMP($J,"IBSORT",IBTYP,IBBAT,IBBA,""))="" Q ; no claim data - .. ; - .. D:$Y>(IOSL-4) HDR1 Q:IBSTOP - .. W !!?5,"Claim",?14,"Seq",?22,"Bal Due",?32,"EDI Stat",?43,"IB Status",?57,"AR Status" - .. S CLM="" F S CLM=$O(^TMP($J,"IBSORT",IBTYP,IBBAT,IBBA,CLM)) Q:CLM=""!IBSTOP S IEN=0 F S IEN=$O(^TMP($J,"IBSORT",IBTYP,IBBAT,IBBA,CLM,IEN)) Q:'IEN!IBSTOP D Q:IBSTOP - ... S IBV=$G(^TMP($J,"IBSORT",IBTYP,IBBAT,IBBA,CLM,IEN)) - ... D:$Y>(IOSL-4) HDR1 Q:IBSTOP - ... W !,?5,CLM,?15,$P(IBV,U,1),?19,$J($FN($P(IBV,U,2),"",2),10),?35,$P(IBV,U,3),?43,$E($P(IBV,U,4),1,11),?57,$E($P(IBV,U,5),1,16) - ... Q - .. ; - .. Q:IBSTOP - .. D:$Y>(IOSL-4) HDR1 Q:IBSTOP - .. W ! - .. Q - . Q - ; - I IBSTOP G PRINTX - D:$Y>(IOSL-4) HDR1 G:IBSTOP PRINTX - W !!,"Total Number of Batches: ",IBCT - D:$Y>(IOSL-4) HDR1 G:IBSTOP PRINTX - W !!?5,"*** End of Report ***" - I CRT,'$D(ZTQUEUED) S DIR(0)="E" D ^DIR K DIR -PRINTX ; - Q - ; -HDR1 ; Report header - ; - ; if screen output and page# already exists, do a page break - I IBPAGE,CRT D I IBSTOP G HDR1X - . S DIR(0)="E" D ^DIR K DIR - . I 'Y S IBSTOP=1 - . Q - ; - ; if screen output OR page# already exists, do a form feed - I IBPAGE!CRT W @IOF - ; - S IBPAGE=IBPAGE+1 - ; - W !,"EDI Batches Pending Austin Receipt After 1 Day",?70,"Page: ",IBPAGE - W !,"Run Date: ",$$FMTE^XLFDT($$NOW^XLFDT,"5Z") - W !!?2,"Batch #",?16,"Transmission Date",?42,"Mail Message #" - S Z="",$P(Z,"-",79)="" W !?1,Z - ; - ; check for a TaskManager stop request - I $D(ZTQUEUED),$$S^%ZTLOAD() D G HDR1X - . S (ZTSTOP,IBSTOP)=1 - . W !!!?5,"*** Report Halted by TaskManager Request ***" - . Q -HDR1X ; - Q - ; +IBCERP3 ;ALB/TMP - EDI BATCHES WAITING MORE THAN 1 DAY REPORT ;30-SEP-96 + ;;2.0;INTEGRATED BILLING;**137,296**;21-MAR-94 + Q + ; +PENDING ;Report of batches not sent after the day the bills in it were extracted + W ! + S %ZIS="QM" D ^%ZIS Q:POP + I $D(IO("Q")) K IO("Q") S ZTRTN="EN^IBCERP3",ZTDESC="REPORT OF BILL BATCHES WAITING AUSTIN RECEIPT AFTER 1 DAY" D ^%ZTLOAD K ZTSK D HOME^%ZIS Q + U IO +EN ; Queued job entrypoint + N IBPAGE,IBHDRDT,IBLINE,IBSTOP,IBBA,IBBAT,IBCT,IBTYP,IBTYPN,IBV,DIR,Y,IB0,IB1 + ; + K ^TMP($J,"IBSORT") + S (IBPAGE,IBBA)=0 + ; + ; esg - 5/12/05 - IB*2*296 - Additional check to make sure there are + ; bills in the batch in file 364 before including it. Similar to + ; existing functionality in routine ^IBCEBUL. + ; + F S IBBA=$O(^IBA(364.1,"ASTAT","P",IBBA)) Q:'IBBA S IB0=$G(^IBA(364.1,IBBA,0)),IB1=$G(^(1)) I DT-($P(IB1,U,6)\1)'<1,$P(IB0,U,7)'="",$O(^IBA(364,"C",IBBA,0)) S ^TMP($J,"IBSORT",$P(IB0,U,7),$P(IB0,U),IBBA)=$P(IB1,U,6)_U_$P(IB0,U,4) + ; + W:$E(IOST,1,2)["C-" @IOF ;Only initial form feed for print to screen + I '$D(^TMP($J,"IBSORT")) D HDR1("") W !,?3,"No data found for this report" + S (IBSTOP,IBCT)=0 + ; + S IBTYP="" + F S IBTYP=$O(^TMP($J,"IBSORT",IBTYP)) Q:IBTYP="" D G:IBSTOP STOP + . S IBTYPN=$$EXPAND^IBTRE(364.1,.07,IBTYP) + . D HDR1(IBTYPN) + . S IBBAT="" + . F S IBBAT=$O(^TMP($J,"IBSORT",IBTYP,IBBAT)) Q:'IBBAT!(IBSTOP) S IBBA=0 F S IBBA=$O(^TMP($J,"IBSORT",IBTYP,IBBAT,IBBA)) Q:'IBBA S IBV=$G(^(IBBA)) D Q:IBSTOP + .. D:IBLINE>(IOSL-5) HDR1(IBTYPN) Q:IBSTOP + .. W !,?6,IBBAT,?20,$$FMTE^XLFDT($P(IBV,U),1),?46,$P(IBV,U,2) + .. S IBCT=IBCT+1,IBLINE=IBLINE+1 + ; + W !!,"TOTAL # OF BATCHES: ",IBCT + ; + I $E(IOST,1,2)["C-" K DIR S DIR(0)="E" D ^DIR K DIR +STOP I '$D(ZTQUEUED) D ^%ZISC + I $D(ZTQUEUED) S ZTREQ="@" + K ^TMP($J,"IBSORT") + Q + ; +HDR1(IB) ; Report header + ; IB = the text for the type of batch + N Z,DIR,Y + I 'IBPAGE S IBHDRDT=$$HTE^XLFDT($H,2) + I IBPAGE D Q:IBSTOP + . I $E(IOST,1,2)["C-" K DIR S DIR(0)="E" D ^DIR K DIR S IBSTOP=('Y) Q:IBSTOP + . W @IOF + S IBPAGE=IBPAGE+1 + W !,?14,"REPORT OF BATCHES STILL WAITING AUSTIN RECEIPT AFTER 1 DAY",?70,"PAGE: ",IBPAGE,!,?((68-$L(IB))\2),"BATCH TYPE: "_IB + W !,?26,"RUN DATE: ",IBHDRDT,! + W !,?6,"BATCH #",?20,"WAITING SINCE",?46,"MAIL MESSAGE #",! + S Z="",$P(Z,"-",76)="" W ?2,Z,! + S IBLINE=6 + Q + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEST.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEST.m index 330d2aae..57fd58da 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEST.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEST.m @@ -1,225 +1,217 @@ -IBCEST ;ALB/TMP - 837 EDI STATUS MESSAGE PROCESSING ;17-APR-96 - ;;2.0;INTEGRATED BILLING;**137,189,197,135,283,320,368,397**;21-MAR-94;Build 3 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; IA 4043 for call to AUDITX^PRCAUDT - Q - ; -UPD361(IBTDA) ; Update IB BILL STATUS MESSAGES file - ; IBTDA = ien of return message in file 364.2 - ; - N IB,IB0,IBSEQ,IB00,IBBILL,IBBTCH,IBMNUM - ; - I '$$LOCK^IBCEM(IBTDA) G UPDQ ;Lock message in file 364.2 - ; - S IB0=$G(^IBA(364.2,IBTDA,0)) - S IBMNUM=$P(IB0,U) ; Message number - S IB00=$G(^IBA(364,+$P(IB0,U,5),0)) ; Transmit bill entry - S IBBILL=+IB00 ; Actual bill ien in file 399 - S IBBTCH=$P(IB0,U,4) ; Batch # - ; - ; Auto-audit bills based on status code on '10' record of status msg - ; flat file - I IBBILL,$P($T(PRCAUDT+1^PRCAUDT),"**",2)[",173" D - . N Z,Z0,Z1,OK - . Q:+$$STA^PRCAFN(IBBILL)'=104 - . S (Z,OK)=0 - . F S Z=$O(^IBA(364.2,IBTDA,2,Z)) Q:'Z S Z0=$P($G(^(Z,0)),"##RAW DATA: ",2) I +Z0=10 S Z0=$P(Z0,U,5) D Q:OK - .. ; Strip leading spaces - .. S Z0=$$TRIM^XLFSTR(Z0) - .. Q:Z0="" - .. I $$SCODE^IBCEST1(Z0),$P($G(^DGCR(399.3,+$P($G(^DGCR(399,IBBILL,0)),U,7),0)),U,11) D AUDITX^PRCAUDT(IBBILL) S OK=1 ; IA 4043 - ; - I $S(IBMNUM="":1,1:'IBBILL&(IBBTCH="")) D DELMSG^IBCESRV2(IBTDA) G UPDQ - ; - ; Individual bill - I IBBILL D G UPDQ - . N IBA1,IBMSG0,IBPID - . S IBPID="",IBA1=0 - . F S IBA1=$O(^IBA(364.2,IBTDA,2,IBA1)) Q:'IBA1 S IBMSG0=$P($G(^(IBA1,0)),"##RAW DATA: ",2) I +IBMSG0=277,$P(IBMSG0,U,5)="N" S IBPID=$P(IBMSG0,U,11) Q - . S IBSEQ=$P(IB00,U,8) S:IBSEQ="" IBSEQ="P" - . D STORE(IB0,IBBTCH,IBMNUM,IBTDA,IBBILL,IBSEQ,IBPID,1) - ; - ; Batch - update each bill separately - S IBBILL="" - F S IBBILL=$O(^IBA(364,"ABABI",+IBBTCH,IBBILL)) Q:'IBBILL D - . Q:$D(^TMP("IBCONF",$J,IBBILL)) ;Bill was rejected - . S IB=$O(^IBA(364,"ABABI",+IBBTCH,IBBILL,0)) Q:'IB - . S IBSEQ=$P($G(^IBA(364,IB,0)),U,8) S:IBSEQ="" IBSEQ="P" - . D STORE(IB0,IBBTCH,IBMNUM,IBTDA,IBBILL,IBSEQ,"",0) - ; - Q - ; -STORE(IB0,IBBTCH,IBMNUM,IBTDA,IBBILL,IBSEQ,IBPID,IB1) ; - ; - ; IB0 = 0-node of message in file 364.2 - ; IBBTCH = ien of batch in file 364.1 - ; IBMNUM = actual message number - ; IBTDA = ien of message in file 364.2 - ; IBBILL = ien of bill in 399 - ; IBSEQ = P/S/T/ for COB sequence related to message - ; IBPID = the payer id returned from clearinghouse for the claim - ; IB1 = flag that says if the message was for a single bill or a batch. - ; Batch statuses have an additional standard text entry. - ; 1 = single bill 0 = batch - ; - N DA,DIK,DIE,DIC,X,Y,DR,DO,DD,DLAYGO,Z,Z0,Z1,Z2,Z3,IBT,IBDUP,IBFLDS,IBY,IBAUTO,IBLN - ; - S X=IBBILL,IBDUP=0 - ; - I $D(^IBM(361,"AC",IBMNUM\1)) D ; Message already there for bill - . S Z=0 F S Z=$O(^IBM(361,"AC",IBMNUM\1,Z)) Q:'Z I +$G(^IBM(361,Z,0))=IBBILL S IBDUP=Z Q - ; - S IBFLDS=".02////"_$P(IB0,U,3) - S IBFLDS=IBFLDS_";.03////"_$S($$EXTERNAL^DILFD(364.2,.02,"U",$P(IB0,U,2))["REJ":"R",1:"I")_";.05////"_IBBTCH_";.06////"_IBMNUM_";.04////"_+$P(IB0,U,8)_";.07////"_IBSEQ_$S($P(IB0,U,5):";.11////"_$P(IB0,U,5),1:"") - S IBFLDS=IBFLDS_";.12////"_$P(IB0,U,10)_";.09////0" - S IBFLDS=IBFLDS_";.15////"_$$CHKSUM^IBCEST1("^IBA(364.2,"_IBTDA_",2)") - I IBPID'="" D - . S IBPID("TYPE")=$S($$FT^IBCEF(IBBILL)=2:"P",1:"I") - . D UPDINS(.IBPID,$$POLICY^IBCEF(IBBILL,1,$TR(IBSEQ,"PST","123")),IBBILL) - ; - I IBDUP D I $D(Y) G UPDQ - . ; Stuff fields into existing entry - . ; (may be needed for reprocessing of aborted updates) - . S DIE="^IBM(361,",DA=IBDUP,DR=IBFLDS_";1///@" - . D ^DIE - . I $D(Y) S IBY=-1 Q ;Update not successful - . S IBY=IBDUP - ; - K IBT - I 'IBDUP D ; Create new entry and stuff fields - . S DIC(0)="L",DIC="^IBM(361,",DLAYGO=361 - . S DIC("DR")=IBFLDS - . D FILE^DICN - . K DO,DD,DLAYGO,DIC - . S IBY=+Y - . Q:IBY'>0 - . ; - . ; IB*2*320 - Check for duplicate status message - . NEW IBNEW,IBOLD,PCE,Z,DIK,DA - . S IBNEW="" - . F PCE=3,4,5,7,8,11,15 S IBNEW=IBNEW_$P($G(^IBM(361,IBY,0)),U,PCE)_U - . S Z=0 - . F S Z=$O(^IBM(361,"B",IBBILL,Z)) Q:'Z I Z'=IBY D Q:IBY'>0 - .. S IBOLD="" - .. F PCE=3,4,5,7,8,11,15 S IBOLD=IBOLD_$P($G(^IBM(361,Z,0)),U,PCE)_U - .. I IBNEW'=IBOLD Q ; no duplicate so get the next one - .. S DIK="^IBM(361,",DA=IBY,IBY=-1 D ^DIK D DELMSG^IBCESRV2(IBTDA) - .. Q - . Q - ; - I IBY>0 D ;Move text over - . K IBT - . ; - . D BLDMSG(IB1,IBTDA,.IBT,.IBAUTO) - . ; - . ; IB*2*368 - ymg - 2Q,RE,RP messages will be filed as informational - . ; Z0 is the flag for 2Q code - . ; Z1 is the flag for RE code - . ; Z2 is the flag for RP code - . ; Z3 is the flag for autofiling the message - . I $P($G(^IBM(361,+IBY,0)),U,3)="R" D - .. S Z="",(Z0,Z1,Z2,Z3)=0 F S Z=$O(IBT(Z)) Q:Z=""!(Z3=1) D - ... S IBLN=$$UP^XLFSTR($G(IBT(Z))) - ... I (Z0!Z1!Z2)=0 D - .... S:IBLN?.E1"CODE:".P1"2Q".E Z0=1 - .... S:IBLN?.E1"CODE:".P1"RE".E Z1=1 - .... S:IBLN?.E1"CODE:".P1"RP".E Z2=1 - ... I Z0=1 S:IBLN?.P1"CLAIM".P1"REJECTED".P1"BY".P1"CLEARINGHOUSE".E Z3=1 - ... I Z1=1 S:IBLN?.P1"ELECTRONIC".P1"CLAIM".P1"REJECTED".P1"BY".P1"EMDEON".E Z3=1 - ... I Z2=1 S:IBLN?.P1"PAPER".P1"CLAIM".P1"REJECTED".P1"BY".P1"EMDEON".E Z3=1 - .. I Z3=1 S IBAUTO=1,DIE=361,DA=+IBY,DR=".03////I" D ^DIE - .. Q - . ; - . ; if info msg, ck for no review needed based on first line of text - . I $G(IBAUTO),$P($G(^IBM(361,+IBY,0)),U,3)="I" D - .. S DIE="^IBM(361,",DR=".09////2;.14////1;.1////F",DA=+IBY D ^DIE - .. I IB1,$P($G(^IBM(361,+IBY,0)),U,11) S Z="",Z0=0 F S Z=$O(IBT(Z)) Q:Z=""!(Z0=1) D - ... S Z0=$$PRINTUPD^IBCEU0($$UP^XLFSTR($G(IBT(Z))),$P($G(^IBM(361,+IBY,0)),U,11)) - . ; - . D MSGLNSZ(.IBT) ; Convert Message Lines in IBT to be no longer than 70 chars - . D WP^DIE(361,+IBY_",",1,"A","IBT") ; file message text - . ; - . ; Delete message after it successfully updates the database. - . D DELMSG^IBCESRV2(IBTDA) - . Q - ; -UPDQ L -^IBA(364.2,IBTDA,0) - Q - ; -BLDMSG(IB1,IBTDA,IBT,IBAUTO) ; Builds message text - ; IB1 = flag for batch message - ; IBTDA = ien of entry in file 364.2 - ; IBT = array returned with message text - ; IBAUTO = if passed by reference, returns 1 if text indicates review - ; not needed - N IBDATA,IBCK,IBZ,IBZ0,IBZ1,Z - S (IBZ,IBZ0,IBDATA,IBAUTO,IBCK)=0 - I 'IB1 S IBT(1)="Status message received for batch "_$P($G(^IBA(364.1,IBBTCH,0)),U)_" dated "_$$FMTE^XLFDT($P($G(^IBA(364.2,IBTDA,0)),U,10),2),IBZ0=1 - ; Don't move the raw data over, just move the text of the message - F S IBZ=$O(^IBA(364.2,IBTDA,2,IBZ)) Q:'IBZ S IBZ1=$G(^(IBZ,0)) S IBDATA=($E(IBZ1,1,2)="##") Q:IBDATA S IBZ0=IBZ0+1,IBT(IBZ0)=IBZ1 I 'IBCK S Z=$$CKREVU^IBCEM4(IBZ1,,,.IBCK),IBAUTO=$S(IBCK:0,Z:1,1:IBAUTO) - Q - ; -UPDINS(IBPID,IBINS,IBIFN) ; Update the insurance id or the bill printed at - ; the EDI contractor's print shop and mailed to the ins co. - ; IBPID = the id returned from the EDI contractor for the ins co - ; ("TYPE") = P if professional id or I if institutional id - ; IBINS = the ien of the insurance co it was sent to (file 36) - ; IBIFN = the ien of the claim (file 399) - ; - N IBID,IBIDFLD,IBPRT,IBLOOK,DA,DR,DIE,X,Y,Z - ; - Q:'$G(IBINS)!($G(IBPID)="") - ; - ; Strip spaces off the end of data - S IBLOOK="" - I $L(IBPID) F Z=$L(IBPID):-1:1 I $E(IBPID,Z)'=" " S IBLOOK=$E(IBPID,1,Z) Q - ; - S IBPRT=($E(IBLOOK,2,5)="PRNT") - I IBPRT D ; Set printed via EDI field on bill - . S DA=IBIFN,DIE="^DGCR(399,",DR="26////1" D ^DIE - ; - S IBLOOK=$E($S('IBPRT:$P(IBLOOK,"PAYID=",2),1:""),1,5) - Q:IBLOOK=""!($E(IBLOOK,2,5)="PRNT") - S IBIDFLD="3.0"_$S($G(IBPID("TYPE"))="I":4,1:2) - S IBID=$P($G(^DIC(36,+IBINS,3)),U,IBIDFLD*100#100) - Q:IBID=IBLOOK - I IBID="" D G UPDINSQ ; Update insurance co electronic id # if blank - . S DIE="^DIC(36,",DR=IBIDFLD_"////"_IBLOOK,DA=IBINS D ^DIE - I IBID'="",IBLOOK'="" D ; Bulletin that the id on file and id returned - . ; are different - . N XMTO,XMDUZ,XMBODY,IBXM,XMSUBJ,XMZ - . S XMTO("I:G.IB EDI")="" - . S XMDUZ="",XMBODY="IBXM",XMSUBJ="PAYER ID RETURNED IS DIFFERENT THAN PAYER ID ON FILE" - . S IBXM(1)="BILL # : "_$P($G(^DGCR(399,IBIFN,0)),U) - . S IBXM(2)="PAYER : "_$P($G(^DIC(36,+IBINS,0)),U) - . S IBXM(3)="BILL TYPE : "_$S($G(IBPID("TYPE"))="I":"INSTITUT",1:"PROFESS")_"IONAL" - . S IBXM(4)="ID ON FILE : "_IBID - . S IBXM(5)="ID RETURNED: "_IBLOOK - . S IBXM(6)=" ",IBXM(7)=" Please determine which id number is correct and correct the id in the",IBXM(8)="insurance file for this payer, if needed" - . D SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO,,.XMZ) - ; -UPDINSQ Q - ; -MSGLNSZ(MSG) ; Change Input Message Lines to be no more than 70 characters long each - ; - ; Input/Output: MSG - array of Input Message Lines; this is also the Output Message - ; which is an array of Converted Message Lines (with lines no more than 70 chars each) - ; - N LN,XARY,XARYLN,CNT,OUTMSG,TMPMSG,LDNGSP,LDNGSPN - S LN="",CNT=0 F S LN=$O(MSG(LN)) Q:LN="" D ; - . ; Find any leading spaces in original message line, - . ; to be used if line got split below - . S TMPMSG=$$TRIM^XLFSTR(MSG(LN),"L"," ") ;Trim Leading Spaces - . S LDNGSP=$P(MSG(LN),TMPMSG,1) ;get leading spaces if any - . S LDNGSPN=$L(LDNGSP) S:LDNGSPN>30 LDNGSP=$E(LDNGSP,1,30) ;make sure there are no more than 30 leading spaces - . ; Converts a single line to multiple lines with a maximum width of 70 each - . ; If line is 70 chars or less, this call returns the exact line - . K XARY D FSTRNG^IBJU1(TMPMSG,70-LDNGSPN,.XARY) - . ; Scan lines and merge them into the final output array (OUTMSG) - . ; On lines 2 and higher, add Leading Spaces found above, if any. - . S XARYLN="" F S XARYLN=$O(XARY(XARYLN)) Q:XARYLN="" S CNT=CNT+1,OUTMSG(CNT)=LDNGSP_XARY(XARYLN) - ; - ; Move the final Message Lines (OUTMSG) into MSG array to be returned - K MSG M MSG=OUTMSG - Q - ; +IBCEST ;ALB/TMP - 837 EDI STATUS MESSAGE PROCESSING ;17-APR-96 + ;;2.0;INTEGRATED BILLING;**137,189,197,135,283,320**;21-MAR-94 + ; IA 4042 for call to AUDITX^PRCAUDT + Q + ; +UPD361(IBTDA) ; Update IB BILL STATUS MESSAGES file + ; IBTDA = ien of return message in file 364.2 + ; + N IB,IB0,IBSEQ,IB00,IBBILL,IBBTCH,IBMNUM + ; + I '$$LOCK^IBCEM(IBTDA) G UPDQ ;Lock message in file 364.2 + ; + S IB0=$G(^IBA(364.2,IBTDA,0)) + S IBMNUM=$P(IB0,U) ; Message number + S IB00=$G(^IBA(364,+$P(IB0,U,5),0)) ; Transmit bill entry + S IBBILL=+IB00 ; Actual bill ien in file 399 + S IBBTCH=$P(IB0,U,4) ; Batch # + ; + ; Auto-audit bills based on status code on '10' record of status msg + ; flat file + I IBBILL,$P($T(PRCAUDT+1^PRCAUDT),"**",2)[",173" D + . N Z,Z0,Z1,OK + . Q:+$$STA^PRCAFN(IBBILL)'=104 + . S (Z,OK)=0 + . F S Z=$O(^IBA(364.2,IBTDA,2,Z)) Q:'Z S Z0=$P($G(^(Z,0)),"##RAW DATA: ",2) I +Z0=10 S Z0=$P(Z0,U,5) D Q:OK + .. ; Strip leading spaces + .. F S Z0=$P(Z0," ",2,99) Q:$E(Z0)'=" " + .. Q:Z0="" + .. I "A3^AC^A7^A8^AA^2P^10^11"[Z0,$P($G(^DGCR(399.3,+$P($G(^DGCR(399,IBBILL,0)),U,7),0)),U,11) D AUDITX^PRCAUDT(IBBILL) S OK=1 ; IA 4042 + ; + I $S(IBMNUM="":1,1:'IBBILL&(IBBTCH="")) D DELMSG^IBCESRV2(IBTDA) G UPDQ + ; + ; Individual bill + I IBBILL D G UPDQ + . N IBA1,IBMSG0,IBPID + . S IBPID="",IBA1=0 + . F S IBA1=$O(^IBA(364.2,IBTDA,2,IBA1)) Q:'IBA1 S IBMSG0=$P($G(^(IBA1,0)),"##RAW DATA: ",2) I +IBMSG0=277,$P(IBMSG0,U,5)="N" S IBPID=$P(IBMSG0,U,11) Q + . S IBSEQ=$P(IB00,U,8) S:IBSEQ="" IBSEQ="P" + . D STORE(IB0,IBBTCH,IBMNUM,IBTDA,IBBILL,IBSEQ,IBPID,1) + ; + ; Batch - update each bill separately + S IBBILL="" + F S IBBILL=$O(^IBA(364,"ABABI",+IBBTCH,IBBILL)) Q:'IBBILL D + . Q:$D(^TMP("IBCONF",$J,IBBILL)) ;Bill was rejected + . S IB=$O(^IBA(364,"ABABI",+IBBTCH,IBBILL,0)) Q:'IB + . S IBSEQ=$P($G(^IBA(364,IB,0)),U,8) S:IBSEQ="" IBSEQ="P" + . D STORE(IB0,IBBTCH,IBMNUM,IBTDA,IBBILL,IBSEQ,"",0) + ; + Q + ; +STORE(IB0,IBBTCH,IBMNUM,IBTDA,IBBILL,IBSEQ,IBPID,IB1) ; + ; + ; IB0 = 0-node of message in file 364.2 + ; IBBTCH = ien of batch in file 364.1 + ; IBMNUM = actual message number + ; IBTDA = ien of message in file 364.2 + ; IBBILL = ien of bill in 399 + ; IBSEQ = P/S/T/ for COB sequence related to message + ; IBPID = the payer id returned from clearinghouse for the claim + ; IB1 = flag that says if the message was for a single bill or a batch. + ; Batch statuses have an additional standard text entry. + ; 1 = single bill 0 = batch + ; + N DA,DIK,DIE,DIC,X,Y,DR,DO,DD,DLAYGO,Z,Z0,Z1,IBT,IBDUP,IBFLDS,IBY,IBAUTO + ; + S X=IBBILL,IBDUP=0 + ; + I $D(^IBM(361,"AC",IBMNUM\1)) D ; Message already there for bill + . S Z=0 F S Z=$O(^IBM(361,"AC",IBMNUM\1,Z)) Q:'Z I +$G(^IBM(361,Z,0))=IBBILL S IBDUP=Z Q + ; + S IBFLDS=".02////"_$P(IB0,U,3) + S IBFLDS=IBFLDS_";.03////"_$S($$EXTERNAL^DILFD(364.2,.02,"U",$P(IB0,U,2))["REJ":"R",1:"I")_";.05////"_IBBTCH_";.06////"_IBMNUM_";.04////"_+$P(IB0,U,8)_";.07////"_IBSEQ_$S($P(IB0,U,5):";.11////"_$P(IB0,U,5),1:"") + S IBFLDS=IBFLDS_";.12////"_$P(IB0,U,10)_";.09////0" + S IBFLDS=IBFLDS_";.15////"_$$CHKSUM^IBCEST1("^IBA(364.2,"_IBTDA_",2)") + I IBPID'="" D + . S IBPID("TYPE")=$S($$FT^IBCEF(IBBILL)=2:"P",1:"I") + . D UPDINS(.IBPID,$$POLICY^IBCEF(IBBILL,1,$TR(IBSEQ,"PST","123")),IBBILL) + ; + I IBDUP D I $D(Y) G UPDQ + . ; Stuff fields into existing entry + . ; (may be needed for reprocessing of aborted updates) + . S DIE="^IBM(361,",DA=IBDUP,DR=IBFLDS_";1///@" + . D ^DIE + . I $D(Y) S IBY=-1 Q ;Update not successful + . S IBY=IBDUP + ; + K IBT + I 'IBDUP D ; Create new entry and stuff fields + . S DIC(0)="L",DIC="^IBM(361,",DLAYGO=361 + . S DIC("DR")=IBFLDS + . D FILE^DICN + . K DO,DD,DLAYGO,DIC + . S IBY=+Y + . Q:IBY'>0 + . ; + . ; IB*2*320 - Check for duplicate status message + . NEW IBNEW,IBOLD,PCE,Z,DIK,DA + . S IBNEW="" + . F PCE=3,4,5,7,8,11,15 S IBNEW=IBNEW_$P($G(^IBM(361,IBY,0)),U,PCE)_U + . S Z=0 + . F S Z=$O(^IBM(361,"B",IBBILL,Z)) Q:'Z I Z'=IBY D Q:IBY'>0 + .. S IBOLD="" + .. F PCE=3,4,5,7,8,11,15 S IBOLD=IBOLD_$P($G(^IBM(361,Z,0)),U,PCE)_U + .. I IBNEW'=IBOLD Q ; no duplicate so get the next one + .. S DIK="^IBM(361,",DA=IBY,IBY=-1 D ^DIK D DELMSG^IBCESRV2(IBTDA) + .. Q + . Q + ; + I IBY>0 D ;Move text over + . K IBT + . ; + . D BLDMSG(IB1,IBTDA,.IBT,.IBAUTO) + . ; + . ; IB*2*320 - esg - 2Q messages will be filed as informational + . I $P($G(^IBM(361,+IBY,0)),U,3)="R",$G(IBT(1))["2Q CLAIM REJECTED BY CLEARINGHOUSE" D + .. S IBAUTO=1 + .. S DIE=361,DA=+IBY,DR=".03////I" D ^DIE + .. Q + . ; + . ; if info msg, ck for no review needed based on first line of text + . I $G(IBAUTO),$P($G(^IBM(361,+IBY,0)),U,3)="I" D + .. S DIE="^IBM(361,",DR=".09////2;.14////1;.1////F",DA=+IBY D ^DIE + .. I IB1,$P($G(^IBM(361,+IBY,0)),U,11),$$PRINTUPD^IBCEU0($G(IBT(1)),$P($G(^IBM(361,+IBY,0)),U,11)) + . ; + . D WP^DIE(361,+IBY_",",1,"A","IBT") ; file message text + . ; + . ; Delete message after it successfully updates the database. + . D DELMSG^IBCESRV2(IBTDA) + . Q + ; +UPDQ L -^IBA(364.2,IBTDA,0) + Q + ; +BLDMSG(IB1,IBTDA,IBT,IBAUTO) ; Builds message text + ; IB1 = flag for batch message + ; IBTDA = ien of entry in file 364.2 + ; IBT = array returned with message text + ; IBAUTO = if passed by reference, returns 1 if text indicates review + ; not needed + N IBDATA,IBCK,IBZ,IBZ0,IBZ1,Z + S (IBZ,IBZ0,IBDATA,IBAUTO,IBCK)=0 + I 'IB1 S IBT(1)="Status message received for batch "_$P($G(^IBA(364.1,IBBTCH,0)),U)_" dated "_$$FMTE^XLFDT($P($G(^IBA(364.2,IBTDA,0)),U,10),2),IBZ0=1 + ; Don't move the raw data over, just move the text of the message + F S IBZ=$O(^IBA(364.2,IBTDA,2,IBZ)) Q:'IBZ S IBZ1=$G(^(IBZ,0)) S IBDATA=($E(IBZ1,1,2)="##") Q:IBDATA S IBZ0=IBZ0+1,IBT(IBZ0)=IBZ1 I 'IBCK S Z=$$CKREVU^IBCEM4(IBZ1,,,.IBCK),IBAUTO=$S(IBCK:0,Z:1,1:IBAUTO) + ; + ; Convert Message Lines in IBT to be no longer than 70 chars + D MSGLNSZ(.IBT) + Q + ; +UPDINS(IBPID,IBINS,IBIFN) ; Update the insurance id or the bill printed at + ; the EDI contractor's print shop and mailed to the ins co. + ; IBPID = the id returned from the EDI contractor for the ins co + ; ("TYPE") = P if professional id or I if institutional id + ; IBINS = the ien of the insurance co it was sent to (file 36) + ; IBIFN = the ien of the claim (file 399) + ; + N IBID,IBIDFLD,IBPRT,IBLOOK,DA,DR,DIE,X,Y,Z + ; + Q:'$G(IBINS)!($G(IBPID)="") + ; + ; Strip spaces off the end of data + S IBLOOK="" + I $L(IBPID) F Z=$L(IBPID):-1:1 I $E(IBPID,Z)'=" " S IBLOOK=$E(IBPID,1,Z) Q + ; + S IBPRT=($E(IBLOOK,2,5)="PRNT") + I IBPRT D ; Set printed via EDI field on bill + . S DA=IBIFN,DIE="^DGCR(399,",DR="26////1" D ^DIE + ; + S IBLOOK=$E($S('IBPRT:$P(IBLOOK,"PAYID=",2),1:""),1,5) + Q:IBLOOK=""!($E(IBLOOK,2,5)="PRNT") + S IBIDFLD="3.0"_$S($G(IBPID("TYPE"))="I":4,1:2) + S IBID=$P($G(^DIC(36,+IBINS,3)),U,IBIDFLD*100#100) + Q:IBID=IBLOOK + I IBID="" D G UPDINSQ ; Update insurance co electronic id # if blank + . S DIE="^DIC(36,",DR=IBIDFLD_"////"_IBLOOK,DA=IBINS D ^DIE + I IBID'="",IBLOOK'="" D ; Bulletin that the id on file and id returned + . ; are different + . N XMTO,XMDUZ,XMBODY,IBXM,XMSUBJ,XMZ + . S XMTO("I:G.IB EDI")="" + . S XMDUZ="",XMBODY="IBXM",XMSUBJ="PAYER ID RETURNED IS DIFFERENT THAN PAYER ID ON FILE" + . S IBXM(1)="BILL # : "_$P($G(^DGCR(399,IBIFN,0)),U) + . S IBXM(2)="PAYER : "_$P($G(^DIC(36,+IBINS,0)),U) + . S IBXM(3)="BILL TYPE : "_$S($G(IBPID("TYPE"))="I":"INSTITUT",1:"PROFESS")_"IONAL" + . S IBXM(4)="ID ON FILE : "_IBID + . S IBXM(5)="ID RETURNED: "_IBLOOK + . S IBXM(6)=" ",IBXM(7)=" Please determine which id number is correct and correct the id in the",IBXM(8)="insurance file for this payer, if needed" + . D SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO,,.XMZ) + ; +UPDINSQ Q + ; +MSGLNSZ(MSG) ; Change Input Message Lines to be no more than 70 characters long each + ; + ; Input/Output: MSG - array of Input Message Lines; this is also the Output Message + ; which is an array of Converted Message Lines (with lines no more than 70 chars each) + ; + N LN,XARY,XARYLN,CNT,OUTMSG,TMPMSG,LDNGSP + S LN="",CNT=0 + F S LN=$O(MSG(LN)) Q:LN="" D ; + . ; + . ; Find any leading spaces in original message line, + . ; to be used if line got split below + . S TMPMSG=$$TRIM^XLFSTR(MSG(LN),"L"," ") ;Trim Leading Spaces + . S LDNGSP=$P(MSG(LN),TMPMSG,1) ;get leading spaces if any + . ; + . ; Converts a single line to multiple lines with a maximum width of 70 each + . ; If line is 70 chars or less, this call returns the exact line + . K XARY D FSTRNG^IBJU1(MSG(LN),70,.XARY) + . ; + . ; Scan lines and merge them into the final output array (OUTMSG) + . ; On lines 2 and higher, add Leading Spaces found above, if any. + . S XARYLN="" + . F S XARYLN=$O(XARY(XARYLN)) Q:XARYLN="" S CNT=CNT+1,OUTMSG(CNT)=$S(XARYLN=1:XARY(XARYLN),1:LDNGSP_XARY(XARYLN)) + ; + ; Move the final Message Lines (OUTMSG) into MSG array to be returned + K MSG M MSG=OUTMSG + Q ;MSGLNSZ + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEST1.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEST1.m index 2e16f3b2..c9afb166 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEST1.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEST1.m @@ -1,48 +1,33 @@ -IBCEST1 ;ALB/ESG - IB 837 EDI Status Message Processing Cont ;18-JUL-2005 - ;;2.0;INTEGRATED BILLING;**320,397**;21-MAR-94;Build 3 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - Q - ; -CHKSUM(IBARRAY) ; Incoming 277STAT status message checksum calculation - ; This function calculates the checksum of the raw 277stat data from - ; the data in array IBARRAY. This is done to prevent duplicates. - ; Input parameter IBARRAY is the array reference where the data exists - ; at @IBARRAY@(n,0) where n is a sequential # - ; For file 364.2, IBARRAY = "^IBA(364.2,IBTDA,2)" where IBTDA = the ien - ; of the entry in file 364.2 being evaluated - ; - NEW Y,LN,DATA,IBREC,POS,STSFLG - S Y=0,STSFLG=0 - S LN=0 - F S LN=$O(@IBARRAY@(LN)) Q:'LN D - . S DATA=$$EXT($G(@IBARRAY@(LN,0))) Q:DATA="" - . S IBREC=$P(DATA,U,1) - . I IBREC="277STAT" S STSFLG=1 Q ; set the STS flag - . I IBREC<1 Q ; rec# too low - . I IBREC'<99 Q ; rec# too high - . F POS=1:1:$L(DATA) S Y=Y+($A(DATA,POS)*POS) - . Q - ; - I 'STSFLG S Y=0 ; if this array is not a 277stat message - Q Y - ; -EXT(DATA) ; Extracts from the text in DATA if the text contains - ; "##RAW DATA: " - Q $S(DATA["##RAW DATA: ":$P(DATA,"##RAW DATA: ",2,99),1:DATA) - ; -SCODE(Z0) ; status code for message - N IBFD,IBI,IBRD S IBFD=0 - F IBI=1:1 S IBRD=$P($T(CODE+IBI),";;",2,999) Q:IBRD=""!IBFD D - . I IBRD[Z0 S IBFD=1 - Q IBFD - ; -CODE ; *397 - ;;A3^AC^A7^A8^AA^2P^10^11 - ;;19^20^21^30^40^221^960^1AE^1AF^1AG^1AI^1AJ^1AK^1AL^1AS^1BS^1BV^1BY - ;;2B^2D^2H^2M^2U^3A^3C^3E^3F^3G^3I^3K^3L^3N^3P^3S - ;;4B^4C^4D^4E^4H^4I^4J^4P^4S^4T^4U^4X^4Y^7A^7D^7I^7U^7V - ;;A0^A9^ACCEPT^ACCEPTED^AE^AP^APPROVE^C01^CI^CP^CTRL!99001^INQUIRY - ;;OA7^OAH^OAI^OAK^OAT^OAV^OAY^OAZ^OB9^OBX^OCU^PG^PN5 - ;;TE^W!00000117^Z3^ZAI^ZAN - ; +IBCEST1 ;ALB/ESG - IB 837 EDI Status Message Processing Cont ;18-JUL-2005 + ;;2.0;INTEGRATED BILLING;**320**;21-MAR-94 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; + Q + ; +CHKSUM(IBARRAY) ; Incoming 277STAT status message checksum calculation + ; This function calculates the checksum of the raw 277stat data from + ; the data in array IBARRAY. This is done to prevent duplicates. + ; Input parameter IBARRAY is the array reference where the data exists + ; at @IBARRAY@(n,0) where n is a sequential # + ; For file 364.2, IBARRAY = "^IBA(364.2,IBTDA,2)" where IBTDA = the ien + ; of the entry in file 364.2 being evaluated + ; + NEW Y,LN,DATA,IBREC,POS,STSFLG + S Y=0,STSFLG=0 + S LN=0 + F S LN=$O(@IBARRAY@(LN)) Q:'LN D + . S DATA=$$EXT($G(@IBARRAY@(LN,0))) Q:DATA="" + . S IBREC=$P(DATA,U,1) + . I IBREC="277STAT" S STSFLG=1 Q ; set the STS flag + . I IBREC<1 Q ; rec# too low + . I IBREC'<99 Q ; rec# too high + . F POS=1:1:$L(DATA) S Y=Y+($A(DATA,POS)*POS) + . Q + ; + I 'STSFLG S Y=0 ; if this array is not a 277stat message + Q Y + ; +EXT(DATA) ; Extracts from the text in DATA if the text contains + ; "##RAW DATA: " + Q $S(DATA["##RAW DATA: ":$P(DATA,"##RAW DATA: ",2,99),1:DATA) + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEU1.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEU1.m index 8c62727a..cf0773f7 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEU1.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEU1.m @@ -1,189 +1,185 @@ -IBCEU1 ;ALB/TMP - EDI UTILITIES FOR EOB PROCESSING ;10-FEB-99 - ;;2.0;INTEGRATED BILLING;**137,155,296,349,371**;21-MAR-94;Build 57 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -CCOB1(IBIFN,NODE,SEQ) ; Extract Claim level COB data - ; for a bill IBIFN - ; NODE = the file 361.1 node(s) to be returned, separated by commas - ; SEQ = the specific insurance sequence you want returned. If not = - ; 1, 2, or 3, all are returned - ; Returns IBXDATA(COB,n,node) where COB = COB insurance sequence, - ; n is the entry number in file 361.1 and node is the node requested - ; = the requested node's data - ; - N IB,IBN,IBBILL,IBS,A,B,C - ; - K IBXDATA - ; - S:$G(NODE)="" NODE=1 - S IB=$P($G(^DGCR(399,IBIFN,"M1")),U,5,7) - S:"123"'[$G(SEQ) SEQ="" - ; - F B=1:1:3 S IBBILL=$P(IB,U,B) I IBBILL S C=0 F S C=$O(^IBM(361.1,"B",IBBILL,C)) Q:'C D - . I '$$EOBELIG(C) Q ; eob not eligible for secondary claim - . S IBS=$P($G(^IBM(361.1,C,0)),U,15) ; insurance sequence - . I $S('$G(SEQ):1,1:SEQ=IBS) D - .. F Z=1:1:$L(NODE,",") D - ... S A=$P(NODE,",",Z) - ... Q:A="" - ... S IBN=$G(^IBM(361.1,C,A)) - ... I $TR(IBN,U)'="" S IBXDATA(IBS,C,A)=IBN - ; - Q - ; -CCAS1(IBIFN,SEQ) ; Extract all MEDICARE COB claim level adjustment data - ; for a bill IBIFN (subfile 361.11 in file 361.1) - ; SEQ = the specific insurance sequence you want returned. If not = - ; 1, 2, or 3, all are returned - ; Returns IBXDATA(COB,n) where COB = COB insurance sequence, - ; n is the entry number in file 361.1 and - ; = the 0-node of the subfile entry (361.11) - ; and IBXDATA(COB,n,m) where m is a sequential # and - ; = this level's 0-node - N IB,IBA,IBS,IB0,IB00,IBBILL,B,C,D,E - ; - S IB=$P($G(^DGCR(399,IBIFN,"M1")),U,5,7) - S:"123"'[$G(SEQ) SEQ="" - ; - F B=1:1:3 S IBBILL=$P(IB,U,B) I IBBILL S C=0 F S C=$O(^IBM(361.1,"B",IBBILL,C)) Q:'C D - . I '$$EOBELIG(C) Q ; eob not eligible for secondary claim - . S IBS=$P($G(^IBM(361.1,C,0)),U,15) ; insurance sequence - . I $S('$G(SEQ):1,1:SEQ=IBS) D - .. S (IBA,D)=0 F S D=$O(^IBM(361.1,C,10,D)) Q:'D S IB0=$G(^(D,0)) D - ... S IBXDATA(IBS,D)=IB0 - ... S (IBA,E)=0 - ... F S E=$O(^IBM(361.1,C,10,D,1,E)) Q:'E S IB00=$G(^(E,0)) D - .... S IBA=IBA+1 - .... I $TR(IB00,U)'="" S IBXDATA(IBS,D,IBA)=IB00 - ; - Q - ; -SEQ(A) ; Translate sequence # A into corresponding letter representation - S A=$E("PST",A) - I $S(A'="":"PST"'[A,1:1) S A="P" - Q A - ; -EOBTOT(IBIFN,IBCOBN) ; Total all EOB's for a bill's COB sequence - ; Function returns the total of all EOB's for a specific COB seq - ; IBIFN = ien of bill in file 399 - ; IBCOBN = the # of the COB sequence you want EOB/MRA total for (1-3) - ; - N Z,Z0,IBTOT - S IBTOT=0 - I $O(^IBM(361.1,"ABS",IBIFN,IBCOBN,0)) D - . ; Set up prior payment field here from MRA/EOB(s) - . S (IBTOT,Z)=0 - . F S Z=$O(^IBM(361.1,"ABS",IBIFN,IBCOBN,Z)) Q:'Z D - .. ; HD64841 IB*2*371 - total up the payer paid amounts - .. S IBTOT=IBTOT+$P($G(^IBM(361.1,Z,1)),U,1) - Q IBTOT - ; - ; -LCOBOUT(IBXSAVE,IBXDATA,COL) ; Output the line adjustment reasons COB - ; line # data for an electronic claim - ; IBXSAVE,IBXDATA = arrays holding formatter information for claim - - ; pass by reference - ; COL = the column in the 837 flat file being output for LCAS record - N LINE,COBSEQ,RECCT,GRPCD,SEQ,RCCT,RCPC,DATA,RCREC,SEQLINE K IBXDATA - S (LINE,RECCT)=0 - S RCPC=(COL#3) S:'RCPC RCPC=3 - S RCREC=$S(COL'<4:COL-1\3,1:0) - ;S RCREC=$S(COL'<4:COL+5\6-1,1:0) - F S LINE=$O(IBXSAVE("LCOB",LINE)) Q:'LINE D - . S COBSEQ=0 - . F S COBSEQ=$O(IBXSAVE("LCOB",LINE,"COB",COBSEQ)) Q:'COBSEQ S SEQLINE=0 F S SEQLINE=$O(IBXSAVE("LCOB",LINE,"COB",COBSEQ,SEQLINE)) Q:'SEQLINE S GRPCD="" F S GRPCD=$O(IBXSAVE("LCOB",LINE,"COB",COBSEQ,SEQLINE,GRPCD)) Q:GRPCD="" D - .. S RECCT=RECCT+1 - .. I COL=2 S IBXDATA(RECCT)=LINE,DATA=LINE D:RECCT>1 ID^IBCEF2(RECCT,"LCAS") - .. I COL=3 S IBXDATA(RECCT)=$TR(GRPCD," ") - .. S (SEQ,RCCT)=0 - .. F S SEQ=$O(IBXSAVE("LCOB",LINE,"COB",COBSEQ,SEQLINE,GRPCD,SEQ)) Q:'SEQ I $TR($G(IBXSAVE("LCOB",LINE,"COB",COBSEQ,SEQLINE,GRPCD,SEQ)),U)'="" D - ... S RCCT=RCCT+1 - ... Q:COL'<4&(RCCT'=RCREC)&(RCCT'>6) - ... S DATA=$S(COL=2:LINE,COL=3:$TR(GRPCD," "),1:$P($G(IBXSAVE("LCOB",LINE,"COB",COBSEQ,SEQLINE,GRPCD,SEQ)),U,RCPC)) - ... I COL'<4,RCCT=RCREC S:DATA'="" IBXDATA(RECCT)=DATA Q - ... I RCCT>6 S RCCT=1,RECCT=RECCT+1 D:COL=2 ID^IBCEF2(RECCT,"LCAS") I DATA'="",$S(COL'>3:1,1:RCCT=RCREC) S IBXDATA(RECCT)=DATA - Q - ; -CCOBOUT(IBXSAVE,IBXDATA,COL) ; Output the claim adjustment reasons COB - ; data for an electronic claim - ; IBXSAVE,IBXDATA = arrays holding formatter information for claim - - ; pass by reference - ; COL = the column in the 837 flat file being output for CCAS record - N COBSEQ,RECCT,GRPSEQ,SEQ,RCPC,RCCT,RCREC,DATA K IBXDATA - S RECCT=0 - S RCPC=(COL#3) S:'RCPC RCPC=3 - S RCREC=$S(COL'<4:COL+5\6-1,1:0) - S COBSEQ=0 - F S COBSEQ=$O(IBXSAVE("CCAS",COBSEQ)) Q:'COBSEQ S GRPSEQ="" F S GRPSEQ=$O(IBXSAVE("CCAS",COBSEQ,GRPSEQ)) Q:GRPSEQ="" D - . S RECCT=RECCT+1 - . I COL=2 S IBXDATA(RECCT)=COBSEQ D:RECCT>1 ID^IBCEF2(RECCT,"CCAS") - . I COL=3 S IBXDATA(RECCT)=$P($G(IBXSAVE("CCAS",COBSEQ,GRPSEQ)),U) - . S (SEQ,RCCT)=0 - . F S SEQ=$O(IBXSAVE("CCAS",COBSEQ,GRPSEQ,SEQ)) Q:'SEQ I $TR($G(IBXSAVE("CCAS",COBSEQ,GRPSEQ,SEQ)),U)'="" D - .. S RCCT=RCCT+1 - .. Q:COL'<4&(RCCT'=RCREC)&(RCCT'>6) - .. S DATA=$S(COL=2:COBSEQ,COL=3:$P($G(IBXSAVE("CCAS",COBSEQ,GRPSEQ)),U),1:$P($G(IBXSAVE("CCAS",COBSEQ,GRPSEQ,SEQ)),U,RCPC)) - .. I COL'<4,RCCT=RCREC S:DATA'="" IBXDATA(RECCT)=DATA Q - .. I RCCT>6 S RCCT=1,RECCT=RECCT+1 D:COL=2 ID^IBCEF2(RECCT,"CCAS") I DATA'="",$S(COL'>3:1,1:RCCT=RCREC) S IBXDATA(RECCT)=DATA - Q - ; -COBOUT(IBXSAVE,IBXDATA,CL) ; build LCOB segment data - ; The IBXSAVE array used here is built by INS-2, then LCOB-1.9 - ; This is basically the 361.115, but all the piece numbers here in this - ; local array are one higher than the pieces in subfile 361.115. - N Z,M,N,P,PCCL - S (N,Z,P)=0 F S Z=$O(IBXSAVE("LCOB",Z)) Q:'Z D - . S N=N+1 - . S M=$O(IBXSAVE("LCOB",Z,"COB",""),-1) Q:'M - . S P=$O(IBXSAVE("LCOB",Z,"COB",M,""),-1) Q:'P - . S PCCL=$P($G(IBXSAVE("LCOB",Z,"COB",M,P)),U,CL) - . S:PCCL'="" IBXDATA(N)=PCCL - . Q - Q - ; -COBPYRID(IBXIEN,IBXSAVE,IBXDATA) ; cob insurance company payer id - N CT,N,NUM - K IBXDATA - I '$D(IBXSAVE("LCOB")) G COBPYRX - D ALLPAYID^IBCEF2(IBXIEN,.NUM,1) - S NUM=$G(NUM(1)) - S NUM=$E(NUM_$J("",5),1,5) - S (CT,N)=0 - F S N=$O(IBXSAVE("LCOB",N)) Q:'N S CT=CT+1,IBXDATA(CT)=NUM -COBPYRX ; - Q - ; -EOBELIG(IBEOB) ; EOB eligibility for secondary claim - ; Function to decide if EOB entry in file 361.1 (ien=IBEOB) is - ; eligible to be included for secondary claim creation process - ; The EOB is not eligible if the review status is not 3, or if there - ; is no insurance sequence indicator, or if the EOB has been DENIED - ; and the patient responsibility for that EOB is $0 and that EOB is - ; not a split EOB. Split EOB's need to be included (IB*2*371). - ; - NEW ELIG,IBDATA,PTRESP - S ELIG=0 - I '$G(IBEOB) G EOBELIGX - S IBDATA=$G(^IBM(361.1,IBEOB,0)) - I $P(IBDATA,U,4)'=1 G EOBELIGX ; Only MRA EOB's for now - I $D(^IBM(361.1,IBEOB,"ERR")) G EOBELIGX ; filing error - I $P(IBDATA,U,16)'=3 G EOBELIGX ; review status - accepted-complete - I '$P(IBDATA,U,15) G EOBELIGX ; insurance sequence must exist - S PTRESP=$P($G(^IBM(361.1,IBEOB,1)),U,2) ; Pt Resp Amount for 1500s - I $$FT^IBCEF(+IBDATA)=3 S PTRESP=$$PTRESPI^IBCECOB1(IBEOB) ; for UBs - I PTRESP'>0,$P(IBDATA,U,13)=2,'$$SPLIT^IBCEMU1(IBEOB) G EOBELIGX ; Denied & No Pt. Resp. & not a split MRA - ; - S ELIG=1 -EOBELIGX ; - Q ELIG - ; -EOBCNT(IBIFN) ; This function counts up the number of EOBs that are eligible - ; for the secondary claim creation process for a given bill#. - NEW CNT,IEN - S (CNT,IEN)=0 - F S IEN=$O(^IBM(361.1,"B",+$G(IBIFN),IEN)) Q:'IEN D - . I $$EOBELIG(IEN) S CNT=CNT+1 - . Q -EOBCNTX ; - Q CNT - ; +IBCEU1 ;ALB/TMP - EDI UTILITIES FOR EOB PROCESSING ;10-FEB-99 + ;;2.0;INTEGRATED BILLING;**137,155,296,349**;21-MAR-94;Build 46 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; +CCOB1(IBIFN,NODE,SEQ) ; Extract Claim level COB data + ; for a bill IBIFN + ; NODE = the file 361.1 node(s) to be returned, separated by commas + ; SEQ = the specific insurance sequence you want returned. If not = + ; 1, 2, or 3, all are returned + ; Returns IBXDATA(COB,n,node) where COB = COB insurance sequence, + ; n is the entry number in file 361.1 and node is the node requested + ; = the requested node's data + ; + N IB,IBN,IBBILL,IBS,A,B,C + ; + K IBXDATA + ; + S:$G(NODE)="" NODE=1 + S IB=$P($G(^DGCR(399,IBIFN,"M1")),U,5,7) + S:"123"'[$G(SEQ) SEQ="" + ; + F B=1:1:3 S IBBILL=$P(IB,U,B) I IBBILL S C=0 F S C=$O(^IBM(361.1,"B",IBBILL,C)) Q:'C D + . I '$$EOBELIG(C) Q ; eob not eligible for secondary claim + . S IBS=$P($G(^IBM(361.1,C,0)),U,15) ; insurance sequence + . I $S('$G(SEQ):1,1:SEQ=IBS) D + .. F Z=1:1:$L(NODE,",") D + ... S A=$P(NODE,",",Z) + ... Q:A="" + ... S IBN=$G(^IBM(361.1,C,A)) + ... I $TR(IBN,U)'="" S IBXDATA(IBS,C,A)=IBN + ; + Q + ; +CCAS1(IBIFN,SEQ) ; Extract all MEDICARE COB claim level adjustment data + ; for a bill IBIFN (subfile 361.11 in file 361.1) + ; SEQ = the specific insurance sequence you want returned. If not = + ; 1, 2, or 3, all are returned + ; Returns IBXDATA(COB,n) where COB = COB insurance sequence, + ; n is the entry number in file 361.1 and + ; = the 0-node of the subfile entry (361.11) + ; and IBXDATA(COB,n,m) where m is a sequential # and + ; = this level's 0-node + N IB,IBA,IBS,IB0,IB00,IBBILL,B,C,D,E + ; + S IB=$P($G(^DGCR(399,IBIFN,"M1")),U,5,7) + S:"123"'[$G(SEQ) SEQ="" + ; + F B=1:1:3 S IBBILL=$P(IB,U,B) I IBBILL S C=0 F S C=$O(^IBM(361.1,"B",IBBILL,C)) Q:'C D + . I '$$EOBELIG(C) Q ; eob not eligible for secondary claim + . S IBS=$P($G(^IBM(361.1,C,0)),U,15) ; insurance sequence + . I $S('$G(SEQ):1,1:SEQ=IBS) D + .. S (IBA,D)=0 F S D=$O(^IBM(361.1,C,10,D)) Q:'D S IB0=$G(^(D,0)) D + ... S IBXDATA(IBS,D)=IB0 + ... S (IBA,E)=0 + ... F S E=$O(^IBM(361.1,C,10,D,1,E)) Q:'E S IB00=$G(^(E,0)) D + .... S IBA=IBA+1 + .... I $TR(IB00,U)'="" S IBXDATA(IBS,D,IBA)=IB00 + ; + Q + ; +SEQ(A) ; Translate sequence # A into corresponding letter representation + S A=$E("PST",A) + I $S(A'="":"PST"'[A,1:1) S A="P" + Q A + ; +EOBTOT(IBIFN,IBCOBN) ; Total all EOB's for a bill's COB sequence + ; Function returns the total of all EOB's for a specific COB seq + ; IBIFN = ien of bill in file 399 + ; IBCOBN = the # of the COB sequence you want EOB/MRA total for (1-3) + ; + N Z,Z0,IBTOT + S IBTOT=0 + I $O(^IBM(361.1,"ABS",IBIFN,IBCOBN,0)) D + . ; Set up prior payment field here from MRA/EOB(s) + . S (IBTOT,Z)=0 + . F S Z=$O(^IBM(361.1,"ABS",IBIFN,IBCOBN,Z)) Q:'Z D + .. S IBTOT=IBTOT+$P($G(^IBM(361.1,Z,1)),U,2) + Q IBTOT + ; + ; +LCOBOUT(IBXSAVE,IBXDATA,COL) ; Output the line adjustment reasons COB + ; line # data for an electronic claim + ; IBXSAVE,IBXDATA = arrays holding formatter information for claim - + ; pass by reference + ; COL = the column in the 837 flat file being output for LCAS record + N LINE,COBSEQ,RECCT,GRPCD,SEQ,RCCT,RCPC,DATA,RCREC,SEQLINE K IBXDATA + S (LINE,RECCT)=0 + S RCPC=(COL#3) S:'RCPC RCPC=3 + S RCREC=$S(COL'<4:COL-1\3,1:0) + ;S RCREC=$S(COL'<4:COL+5\6-1,1:0) + F S LINE=$O(IBXSAVE("LCOB",LINE)) Q:'LINE D + . S COBSEQ=0 + . F S COBSEQ=$O(IBXSAVE("LCOB",LINE,"COB",COBSEQ)) Q:'COBSEQ S SEQLINE=0 F S SEQLINE=$O(IBXSAVE("LCOB",LINE,"COB",COBSEQ,SEQLINE)) Q:'SEQLINE S GRPCD="" F S GRPCD=$O(IBXSAVE("LCOB",LINE,"COB",COBSEQ,SEQLINE,GRPCD)) Q:GRPCD="" D + .. S RECCT=RECCT+1 + .. I COL=2 S IBXDATA(RECCT)=LINE,DATA=LINE D:RECCT>1 ID^IBCEF2(RECCT,"LCAS") + .. I COL=3 S IBXDATA(RECCT)=$TR(GRPCD," ") + .. S (SEQ,RCCT)=0 + .. F S SEQ=$O(IBXSAVE("LCOB",LINE,"COB",COBSEQ,SEQLINE,GRPCD,SEQ)) Q:'SEQ I $TR($G(IBXSAVE("LCOB",LINE,"COB",COBSEQ,SEQLINE,GRPCD,SEQ)),U)'="" D + ... S RCCT=RCCT+1 + ... Q:COL'<4&(RCCT'=RCREC)&(RCCT'>6) + ... S DATA=$S(COL=2:LINE,COL=3:$TR(GRPCD," "),1:$P($G(IBXSAVE("LCOB",LINE,"COB",COBSEQ,SEQLINE,GRPCD,SEQ)),U,RCPC)) + ... I COL'<4,RCCT=RCREC S:DATA'="" IBXDATA(RECCT)=DATA Q + ... I RCCT>6 S RCCT=1,RECCT=RECCT+1 D:COL=2 ID^IBCEF2(RECCT,"LCAS") I DATA'="",$S(COL'>3:1,1:RCCT=RCREC) S IBXDATA(RECCT)=DATA + Q + ; +CCOBOUT(IBXSAVE,IBXDATA,COL) ; Output the claim adjustment reasons COB + ; data for an electronic claim + ; IBXSAVE,IBXDATA = arrays holding formatter information for claim - + ; pass by reference + ; COL = the column in the 837 flat file being output for CCAS record + N COBSEQ,RECCT,GRPSEQ,SEQ,RCPC,RCCT,RCREC,DATA K IBXDATA + S RECCT=0 + S RCPC=(COL#3) S:'RCPC RCPC=3 + S RCREC=$S(COL'<4:COL+5\6-1,1:0) + S COBSEQ=0 + F S COBSEQ=$O(IBXSAVE("CCAS",COBSEQ)) Q:'COBSEQ S GRPSEQ="" F S GRPSEQ=$O(IBXSAVE("CCAS",COBSEQ,GRPSEQ)) Q:GRPSEQ="" D + . S RECCT=RECCT+1 + . I COL=2 S IBXDATA(RECCT)=COBSEQ D:RECCT>1 ID^IBCEF2(RECCT,"CCAS") + . I COL=3 S IBXDATA(RECCT)=$P($G(IBXSAVE("CCAS",COBSEQ,GRPSEQ)),U) + . S (SEQ,RCCT)=0 + . F S SEQ=$O(IBXSAVE("CCAS",COBSEQ,GRPSEQ,SEQ)) Q:'SEQ I $TR($G(IBXSAVE("CCAS",COBSEQ,GRPSEQ,SEQ)),U)'="" D + .. S RCCT=RCCT+1 + .. Q:COL'<4&(RCCT'=RCREC)&(RCCT'>6) + .. S DATA=$S(COL=2:COBSEQ,COL=3:$P($G(IBXSAVE("CCAS",COBSEQ,GRPSEQ)),U),1:$P($G(IBXSAVE("CCAS",COBSEQ,GRPSEQ,SEQ)),U,RCPC)) + .. I COL'<4,RCCT=RCREC S:DATA'="" IBXDATA(RECCT)=DATA Q + .. I RCCT>6 S RCCT=1,RECCT=RECCT+1 D:COL=2 ID^IBCEF2(RECCT,"CCAS") I DATA'="",$S(COL'>3:1,1:RCCT=RCREC) S IBXDATA(RECCT)=DATA + Q + ; +COBOUT(IBXSAVE,IBXDATA,CL) ; + N Z,M,N,P,PCCL + S (N,Z,P)=0 F S Z=$O(IBXSAVE("LCOB",Z)) Q:'Z D + . S N=N+1 + . S M=$O(IBXSAVE("LCOB",Z,"COB",""),-1) Q:'M + . S P=$O(IBXSAVE("LCOB",Z,"COB",M,""),-1) Q:'P + . S PCCL=$P($G(IBXSAVE("LCOB",Z,"COB",M,P)),U,CL) + . S:PCCL'="" IBXDATA(N)=PCCL + . Q + Q + ; +COBPYRID(IBXIEN,IBXSAVE,IBXDATA) ; cob insurance company payer id + N CT,Z,N,NUM + K IBXDATA + I '$D(IBXSAVE("LCOB")) G COBPYRX + D ALLPAYID^IBCEF2(IBXIEN,.NUM,1) + S Z=$$COID^IBCEF2(IBXIEN),NUM=$G(NUM(1)) + S:Z="" Z="0000" + S NUM=$E(NUM_$J("",5),1,5)_$E(Z_$J("",4),1,4) + S (CT,N)=0 + F S N=$O(IBXSAVE("LCOB",N)) Q:'N S CT=CT+1,IBXDATA(CT)=NUM +COBPYRX ; + Q + ; +EOBELIG(IBEOB) ; EOB eligibility for secondary claim + ; Function to decide if EOB entry in file 361.1 (ien=IBEOB) is + ; eligible to be included for secondary claim creation process + ; The EOB is not eligible if the review status is not 3, or if there + ; is no insurance sequence indicator, or if the EOB has been DENIED + ; and the patient responsibility for that EOB is $0. + ; + NEW ELIG,IBDATA,PTRESP + S ELIG=0 + I '$G(IBEOB) G EOBELIGX + S IBDATA=$G(^IBM(361.1,IBEOB,0)) + I $P(IBDATA,U,4)'=1 G EOBELIGX ; Only MRA EOB's for now + I $P(IBDATA,U,16)'=3 G EOBELIGX ; review status - accepted-complete + I '$P(IBDATA,U,15) G EOBELIGX ; insurance sequence must exist + S PTRESP=$P($G(^IBM(361.1,IBEOB,1)),U,2) ; Pt Resp Amount for 1500s + I $$FT^IBCEF(+IBDATA)=3 S PTRESP=$$PTRESPI^IBCECOB1(IBEOB) ; for UBs + I PTRESP'>0,$P(IBDATA,U,13)=2 G EOBELIGX ; Denied & No Pt. Resp. + I $D(^IBM(361.1,IBEOB,"ERR")) G EOBELIGX ; filing error + ; + S ELIG=1 +EOBELIGX ; + Q ELIG + ; +EOBCNT(IBIFN) ; This function counts up the number of EOBs that are eligible + ; for the secondary claim creation process for a given bill#. + NEW CNT,IEN + S (CNT,IEN)=0 + F S IEN=$O(^IBM(361.1,"B",+$G(IBIFN),IEN)) Q:'IEN D + . I $$EOBELIG(IEN) S CNT=CNT+1 + . Q +EOBCNTX ; + Q CNT + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEU3.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEU3.m index da1b1ccb..fdeea2fb 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEU3.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEU3.m @@ -1,217 +1,220 @@ -IBCEU3 ;ALB/TMP - EDI UTILITIES FOR 1500 CLAIM FORM ;12/29/05 9:58am - ;;2.0;INTEGRATED BILLING;**51,137,155,323,348,371**;21-MAR-94;Build 57 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -BOX19(IBIFN) ; Returns the text that should print in box 19 of the CMS-1500 - ; for bill ien IBIFN - ; Data is derived from a combo of data throughout - ; the system and is limited to 80 characters. The hierarchy for - ; including data is as follows (until 80 characters have been used): - ; DATE LAST SEEN and REFERRING PHYSICIAN ID# (physical therapy) - ; specialty codes = 025,065,073,067,048 - ; LAST X-RAY DATE (chiropractic) specialty code = 35 - ; HOMEBOUND INDICATOR (independent lab renders an EKG or obtains - ; a specimen from a homebound patient) - ; NO ASSIGNMENT OF BENEFITS (if no assignment of benefits indicated) - ; Hearing aid testing (if applicable) - ; ATTENDING PHYSICIAN NOT HOSPICE EMPLOYEE (if applicable) - ; SPECIAL PROGRAM indicator if Medicare demonstration project for - ; lung volume reduction surgery study is set - ; COMMENTS FOUND IN BOX 19 DATA FIELD FOR THE CLAIM - ; REMARKS FOUND IN BILL COMMENT FOR THE CLAIM, INCLUDING PROSTHETICS - ; DETAIL - ; - N IBGO,IBHOSP,IBID,IBLSDT,IBXDATA,IB19,IBHAID,IBXRAY,IBSPEC,Z,Z0,IBSUB,IBPRT,IBREM - S IB19="",IBGO=1 - S IBSUB=$S('$G(^TMP("IBTX",$J,IBIFN)):"BOX24",1:"OUTPT") - I $D(IBXSAVE(IBSUB)) N IBXSAVE - S IBPRT=(IBSUB["24") - ; - S IBSPEC=$$BILLSPEC(IBIFN) - G:'IBPRT NPRT - ; Check for chiropractic services - I $P($G(^DGCR(399,IBIFN,"U3")),U,5)'="" S:$P($G(^DGCR(399,IBIFN,"U3")),U,4)'="" IBGO=$$LENOK("Last X-ray: "_$TR($$DATE^IBCF2($P(^DGCR(399,IBIFN,"U3"),U,4))," ","/"),.IB19) - G:'IBGO BOX19Q - ; - I "^25^65^73^67^48^"[(U_IBSPEC_U) D - . K IBXDATA D F^IBCEF("N-DATE LAST SEEN",,,IBIFN) - . I IBXDATA'="" S IBID="",IBLSDT=$$DATE^IBCF2(IBXDATA,0,1) D I IBLSDT'="" S IBGO=$$LENOK("Date Last Seen:"_IBLSDT_IBID,.IB19) - .. ; Only print if specialty is OT or PT or proc for routine foot care - .. D F^IBCEF("N-REFERRING PROVIDER ID",,,IBIFN) I IBXDATA'="" S IBID=" By:"_IBXDATA - ; - G:'IBGO BOX19Q - K IBXDATA D F^IBCEF("N-HOMEBOUND",,,IBIFN) - I IBXDATA G:'$$LENOK("Homebound",.IB19) BOX19Q - ; - K IBXDATA D F^IBCEF("N-ASSIGN OF BENEFITS INDICATOR",,,IBIFN) - I "Nn0"[IBXDATA&(IBXDATA'="") G:'$$LENOK("Patient refuses to assign benefits",.IB19) BOX19Q - ; - I '$D(IBXSAVE(IBSUB)) D B24^IBCEF3(.IBXSAVE,IBIFN,$S($G(IBNOSHOW)=0:0,1:1)) - ; - S (IBHAID,IBHOSP,IBXRAY)=0 - ; - S Z=0 F S Z=$O(IBXSAVE(IBSUB,Z)) Q:'Z D G:'IBGO BOX19Q - . I $D(IBXSAVE(IBSUB,Z,"RX")),$P(IBXSAVE(IBSUB,Z,"RX"),U,3)="" S IBGO=$$LENOK("NOC Drug:"_$P(IBXSAVE(IBSUB,Z,"RX"),U,2)_" Units:"_+$P(IBXSAVE(IBSUB,Z,"RX"),U,6),.IB19) - . ; - . Q:'IBGO - . I 'IBHAID,$P(IBXSAVE(IBSUB,Z),U,5)="V5010",$$COBCT^IBCEF(IBIFN)>1 D Q - .. S IBHAID=1,IBGO=$$LENOK("Testing for hearing aid",.IB19) Q - . ; - . Q:'IBGO - . I 'IBHOSP,$P($G(IBXSAVE(IBSUB,Z,"AUX")),U,3) S IBHOSP=1,IBGO=$$LENOK("Attending physician,not hospice employee",.IB19) Q - G:'IBGO BOX19Q - K IBXDATA D F^IBCEF("N-SPECIAL PROGRAM",,,IBIFN) - I IBXDATA=30 G:'$$LENOK("Medicare demonstration project for lung volume reduction surgery study",.IB19) BOX19Q - ; - G:'IBGO BOX19Q -NPRT K IBXDATA D F^IBCEF("N-HCFA 1500 BOX 19 RAW DATA",,,IBIFN) - S IBREM=0 - I IBXDATA'="" G:'$$LENOK("Remarks:"_IBXDATA,.IB19) BOX19Q S IBREM=1 - K IBXDATA D F^IBCEF("N-BILL REMARKS",,,IBIFN) - I IBXDATA'="" G:'$$LENOK($S('IBREM:"Remarks:",1:"")_IBXDATA,.IB19) BOX19Q - ; -BOX19Q Q IB19 - ; -LENOK(IBDATA,IB19) ; Add text IBDATA to box 19 string (IB19 passed by ref) - ; Check length of box 19 data - truncate at 96 (max length) - ; Returns 0 if max length reached or exceeded, otherwise, 1 - N OK - S OK=1 - S IB19=IB19_$S(IB19'="":" ",1:"")_$G(IBDATA) - I $L(IB19)'<96 S OK=0,IB19=$E(IB19,1,96) G LENOKQ -LENOKQ Q OK - ; -ASK19(IBIFN) ; Ask to display CMS-1500 box 19 data for current IBIFN - N DIR,DIC,X,Y,DIE,DR,Z - S DIR(0)="YA",DIR("B")="NO",DIR("A")="DISPLAY THE FULL CMS-1500 BOX 19?: " - D ^DIR - I Y=1 S Z=$$BOX19(IBIFN) W !!,?4,"19",?20,$E(Z,1,32) W:$L(Z)>32 !,?4,$E(Z,33,80),! - Q - ; -ONLAB(IBIFN) ; Functions returns 1 if the bill IBIFN is outside non-lab - N IBP,IBPUR - S IBP=0 - S IBPUR=$P($G(^DGCR(399,IBIFN,"U2")),U,11) - I IBPUR,"13"[IBPUR S IBP=1 - Q IBP - ; -TEXT24(FLD,IBXSAVE,IBXDATA,IBSUB) ; Format the text line of box 24 by fld - ; INPUT: - ; FLD = the letter of the field in box 24 (A-J) - ; IBXSAVE = passed by reference = extracted data for the box 24 lines - ; IBSUB = the subscript of the IBXSAVE array to use. - ; If null, use "BOX24" - ; OUTPUT: - ; IBXDATA = passed by reference, set to the correct part of the - ; text that will print in the field's positions - ; - ; esg - 8/14/06 - modified for the new cms-1500 form - IB*2*348 - ; - N Z,IBLINE,IBVAL,IBS,IBE,IBTEXT,IBAUX,IBDAT,IBZ,IBREN,IBRENQ,IBRENNPI,IBRENSID - K IBXDATA - S (IBLINE,Z)=0 S:$G(IBSUB)="" IBSUB="BOX24" - ; - I FLD="I"!(FLD="J") D ; extract the Rendering provider data - . I '$G(IBXIEN) Q ; assume that the claim# exists - . S IBREN=$$CFIDS^IBCEF77(IBXIEN) - . S IBRENQ=$P(IBREN,U,1) ; qual - . S IBRENSID=$P(IBREN,U,2) ; id - . S IBRENNPI=$P(IBREN,U,3) ; npi - . Q - ; - F S Z=$O(IBXSAVE(IBSUB,Z)) Q:'Z D - . S IBDAT=$G(IBXSAVE(IBSUB,Z)) - . S IBAUX=$G(IBXSAVE(IBSUB,Z,"AUX")) - . S IBTEXT=$G(IBXSAVE(IBSUB,Z,"TEXT")) - . S IBZ=$P(IBAUX,U,9) - . I IBZ="" S IBZ=" " - . S IBTEXT=IBZ_IBTEXT - . ; - . I $S($G(IBAC)=4:$S($D(IBXSAVE(IBSUB,Z,"ARX")):1,1:$D(IBXSAVE(IBSUB,Z,"A"))),$D(IBXSAVE(IBSUB,Z,"RX")):0,1:$G(IBNOSHOW)) S IBTEXT="" - . ; - . I FLD="AF" S IBVAL=$P(IBDAT,U),IBS=1,IBE=9 D ; From date of service - .. S IBVAL=$E(IBVAL,1,2)_" "_$E(IBVAL,3,4)_" "_$E(IBVAL,7,8) - .. Q - . ; - . I FLD="AT" S IBVAL=$S($P(IBDAT,U,2):$P(IBDAT,U,2),1:$P(IBDAT,U)),IBS=10,IBE=18 D ; To date of service - .. S IBVAL=$E(IBVAL,1,2)_" "_$E(IBVAL,3,4)_" "_$E(IBVAL,7,8) - .. Q - . ; - . I FLD="B" S IBVAL=$P(IBDAT,U,3),IBS=19,IBE=21 ; place of service - . I FLD="C" S IBVAL=$S($P(IBDAT,U,13)=1:"Y",1:""),IBS=22,IBE=24 ; emergency indicator - . I FLD="D" S IBVAL=$P(IBDAT,U,5),IBS=25,IBE=44 D ; procedures and modifiers - .. N M S M=$$MODLST^IBEFUNC($P(IBDAT,U,10)) ; modifier list - .. S IBVAL=$$FO^IBCNEUT1(IBVAL,6)_" " ; procedure code - .. S IBVAL=IBVAL_$$FO^IBCNEUT1($P(M,",",1),3) ; mod#1 - .. S IBVAL=IBVAL_$$FO^IBCNEUT1($P(M,",",2),3) ; mod#2 - .. S IBVAL=IBVAL_$$FO^IBCNEUT1($P(M,",",3),3) ; mod#3 - .. S IBVAL=IBVAL_$$FO^IBCNEUT1($P(M,",",4),3) ; mod#4 - .. Q - . ; - . I FLD="E" S IBVAL=$TR($P(IBDAT,U,7),","),IBS=45,IBE=48 ; diagnosis pointer - . I FLD="F" S IBVAL=$P(IBDAT,U,8)*$P(IBDAT,U,9),IBS=49,IBE=57 D - .. ; total charges - .. S IBVAL=$$DOL^IBCEF77(IBVAL,9) - .. Q - . ; - . I FLD="G" S IBVAL=$S($P(IBDAT,U,12):$P(IBDAT,U,12),1:$P(IBDAT,U,9)),IBS=58,IBE=61 D - .. ; days or units or anesthesia minutes - .. S IBVAL=$J(+IBVAL,4) - .. Q - . ; - . ; columns H,I,J don't have any free text supplemental information - . ; - . I FLD="H" D ; epsdt family plan - .. S IBVAL=$P(IBAUX,U,7),IBS=0,IBE=0,IBTEXT="" ; line 1 blank - .. I IBVAL S IBVAL="Y" - .. Q - . I FLD="I" D ; ID qualifier for rendering provider - .. S IBVAL="",IBS=1,IBE=2 ; line 2 blank - .. S IBTEXT=$G(IBRENQ) ; qualifier on line 1 - .. Q - . I FLD="J" D ; rendering provider ID and NPI - .. S IBTEXT=$G(IBRENSID),IBS=1,IBE=11 ; secondary ID line 1 - .. S IBVAL=$G(IBRENNPI) ; NPI# line 2 - .. Q - . ; - . S IBLINE=IBLINE+1 ; top line - . S IBXDATA(IBLINE)=$E(IBTEXT,IBS,IBE) ; text in shaded area (top) - . S IBLINE=IBLINE+1 ; bottom line - . S IBXDATA(IBLINE)=IBVAL ; field value in unshaded area (bottom) - . Q - ; - Q - ; -BILLSPEC(IBIFN,IBPRV) ; Returns the specialty of the provider on bill IBIFN - ; If IBPRV is supplied, returns the data for that provider, otherwise, - ; returns the specialty of the 'main/required' provider on the bill. - ; Default = 99 if no valid code found - ; IBPRV = vp of provider (file 200 or 355.93) - N Z,IBSPEC,IBINS,IBDT - S IBSPEC="",IBPRV=$G(IBPRV) - S IBDT=$P($G(^DGCR(399,+IBIFN,"U")),U,1) ; use statement from date - ; - I $G(IBPRV) D G SPECQ - . S IBSPEC=$$SPEC^IBCEU(IBPRV,IBDT) - ; - ;Get rendering for professional, attending for institutional, - S IBINS=($$FT^IBCEF(IBIFN)=3) - D GETPRV^IBCEU(IBIFN,"ALL",.IBPRV) - S Z=$S('IBINS:3,1:4) - I $G(IBPRV(Z,1))'="" D - . I $P(IBPRV(Z,1),U,3) S IBSPEC=$$SPEC^IBCEU($P($G(IBPRV(Z,1)),U,3),IBDT) Q:IBSPEC'="" - . S Z0=+$O(^DGCR(399,IBIFN,"PRV","B",Z,0)) - . I Z0,$P($G(^DGCR(399,IBIFN,"PRV",Z0,0)),U,8)'="" S IBSPEC=$P(^(0),U,8) - ; -SPECQ I IBSPEC="" S IBSPEC="99" - Q IBSPEC - ; -CHAMPVA(IBIFN) ; Returns 1 if the bill IBIFN has a CHAMPVA rate type - Q $E($P($G(^DGCR(399.3,+$P($G(^DGCR(399,IBIFN,0)),U,7),0)),U),1,7)="CHAMPVA" - ; -FAC(IBIFN) ; Is facility always to print in box 32 for bill ien IBIFN? - ; Returns 1 if yes, 0 if no - Q $S($P($G(^DGCR(399,IBIFN,"UF2")),U,2):1,1:$P($G(^IBE(350.9,1,2)),U,12)) - ; -MCR24K(IBIFN) ;Function returns MEDICARE id# for professional (CMS-1500) box 24k for bill IBIFN if appropriate - Q $S($$FT^IBCEF(IBIFN)=2&$$MCRONBIL^IBEFUNC(IBIFN):"V"_$$MCRSPEC^IBCEU4(IBIFN,1)_$P($$SITE^VASITE,U,3),1:"") +IBCEU3 ;ALB/TMP - EDI UTILITIES FOR 1500 CLAIM FORM ; 12/29/05 9:58am + ;;2.0;INTEGRATED BILLING;**51,137,155,323,348**;21-MAR-94;Build 5 + ; +BOX19(IBIFN) ; Returns the text that should print in box 19 of the CMS-1500 + ; for bill ien IBIFN + ; Data is derived from a combo of data throughout + ; the system and is limited to 80 characters. The hierarchy for + ; including data is as follows (until 80 characters have been used): + ; DATE LAST SEEN and REFERRING PHYSICIAN ID# (physical therapy) + ; specialty codes = 025,065,073,067,048 + ; LAST X-RAY DATE (chiropractic) specialty code = 35 + ; HOMEBOUND INDICATOR (independent lab renders an EKG or obtains + ; a specimen from a homebound patient) + ; NO ASSIGNMENT OF BENEFITS (if no assignment of benefits indicated) + ; Hearing aid testing (if applicable) + ; ATTENDING PHYSICIAN NOT HOSPICE EMPLOYEE (if applicable) + ; SPECIAL PROGRAM indicator if Medicare demonstration project for + ; lung volume reduction surgery study is set + ; COMMENTS FOUND IN BOX 19 DATA FIELD FOR THE CLAIM + ; REMARKS FOUND IN BILL COMMENT FOR THE CLAIM, INCLUDING PROSTHETICS + ; DETAIL + ; + N IBGO,IBHOSP,IBID,IBLSDT,IBXDATA,IB19,IBHAID,IBXRAY,IBSPEC,Z,Z0,IBSUB,IBPRT,IBREM + S IB19="",IBGO=1 + S IBSUB=$S('$G(^TMP("IBTX",$J,IBIFN)):"BOX24",1:"OUTPT") + I $D(IBXSAVE(IBSUB)) N IBXSAVE + S IBPRT=(IBSUB["24") + ; + S IBSPEC=$$BILLSPEC(IBIFN) + G:'IBPRT NPRT + I "^25^65^73^67^48^"[(U_IBSPEC_U) D + . K IBXDATA D F^IBCEF("N-DATE LAST SEEN",,,IBIFN) + . I IBXDATA'="" S IBID="",IBLSDT=$$DATE^IBCF2(IBXDATA,0,1) D I IBLSDT'="" S IBGO=$$LENOK("Date Last Seen:"_IBLSDT_IBID,.IB19) + .. ; Only print if specialty is OT or PT or proc for routine foot care + .. D F^IBCEF("N-REFERRING PROVIDER ID",,,IBIFN) I IBXDATA'="" S IBID=" By:"_IBXDATA + ; + G:'IBGO BOX19Q + K IBXDATA D F^IBCEF("N-HOMEBOUND",,,IBIFN) + I IBXDATA G:'$$LENOK("Homebound",.IB19) BOX19Q + ; + K IBXDATA D F^IBCEF("N-ASSIGN OF BENEFITS INDICATOR",,,IBIFN) + I "Nn0"[IBXDATA&(IBXDATA'="") G:'$$LENOK("Patient refuses to assign benefits",.IB19) BOX19Q + ; + I '$D(IBXSAVE(IBSUB)) D B24^IBCEF3(.IBXSAVE,IBIFN,$S($G(IBNOSHOW)=0:0,1:1)) + ; + S (IBHAID,IBHOSP,IBXRAY)=0 + ; + S Z=0 F S Z=$O(IBXSAVE(IBSUB,Z)) Q:'Z D G:'IBGO BOX19Q + . I $D(IBXSAVE(IBSUB,Z,"RX")),$P(IBXSAVE(IBSUB,Z,"RX"),U,3)="" S IBGO=$$LENOK("NOC Drug:"_$P(IBXSAVE(IBSUB,Z,"RX"),U,2)_" Units:"_+$P(IBXSAVE(IBSUB,Z,"RX"),U,6),.IB19) + . ; + . Q:'IBGO + . I 'IBHAID,$P(IBXSAVE(IBSUB,Z),U,5)="V5010",$$COBCT^IBCEF(IBIFN)>1 D Q + .. S IBHAID=1,IBGO=$$LENOK("Testing for hearing aid",.IB19) Q + . ; + . Q:'IBGO + . I 'IBHOSP,$P($G(IBXSAVE(IBSUB,Z,"AUX")),U,3) D Q + .. S IBHOSP=1,IBGO=$$LENOK("Attending physician,not hospice employee",.IB19) + . ; + . Q:'IBGO + . I 'IBXRAY,IBSPEC=35,$G(IBXSAVE(IBSUB,Z,"AUX"))'="" D Q + .. ; Check for chiropratic services in claim type or specialty + .. S IBXRAY=1 + .. S IBGO=$$LENOK($S($P(IBXSAVE(IBSUB,Z,"AUX"),U,2):"Last Xray:"_$$DATE^IBCF2($P(IBXSAVE(IBSUB,Z,"AUX"),U,2),0,1)_" ",1:"")_$S($P(IBXSAVE(IBSUB,Z,"AUX"),U,4)'="":"Level of Sublux:"_$P(IBXSAVE(IBSUB,Z,"AUX"),U,4),1:""),.IB19) + ; + G:'IBGO BOX19Q + K IBXDATA D F^IBCEF("N-SPECIAL PROGRAM",,,IBIFN) + I IBXDATA=30 G:'$$LENOK("Medicare demonstration project for lung volume reduction surgery study",.IB19) BOX19Q + ; + G:'IBGO BOX19Q +NPRT K IBXDATA D F^IBCEF("N-HCFA 1500 BOX 19 RAW DATA",,,IBIFN) + S IBREM=0 + I IBXDATA'="" G:'$$LENOK("Remarks:"_IBXDATA,.IB19) BOX19Q S IBREM=1 + K IBXDATA D F^IBCEF("N-BILL REMARKS",,,IBIFN) + I IBXDATA'="" G:'$$LENOK($S('IBREM:"Remarks:",1:"")_IBXDATA,.IB19) BOX19Q + ; +BOX19Q Q IB19 + ; +LENOK(IBDATA,IB19) ; Add text IBDATA to box 19 string (IB19 passed by ref) + ; Check length of box 19 data - truncate at 96 (max length) + ; Returns 0 if max length reached or exceeded, otherwise, 1 + N OK + S OK=1 + S IB19=IB19_$S(IB19'="":" ",1:"")_$G(IBDATA) + I $L(IB19)'<96 S OK=0,IB19=$E(IB19,1,96) G LENOKQ +LENOKQ Q OK + ; +ASK19(IBIFN) ; Ask to display CMS-1500 box 19 data for current IBIFN + N DIR,DIC,X,Y,DIE,DR,Z + S DIR(0)="YA",DIR("B")="NO",DIR("A")="DISPLAY THE FULL CMS-1500 BOX 19?: " + D ^DIR + I Y=1 S Z=$$BOX19(IBIFN) W !!,?4,"19",?20,$E(Z,1,32) W:$L(Z)>32 !,?4,$E(Z,33,80),! + Q + ; +ONLAB(IBIFN) ; Functions returns 1 if the bill IBIFN is outside non-lab + N IBP,IBPUR + S IBP=0 + S IBPUR=$P($G(^DGCR(399,IBIFN,"U2")),U,11) + I IBPUR,"13"[IBPUR S IBP=1 + Q IBP + ; +TEXT24(FLD,IBXSAVE,IBXDATA,IBSUB) ; Format the text line of box 24 by fld + ; INPUT: + ; FLD = the letter of the field in box 24 (A-J) + ; IBXSAVE = passed by reference = extracted data for the box 24 lines + ; IBSUB = the subscript of the IBXSAVE array to use. + ; If null, use "BOX24" + ; OUTPUT: + ; IBXDATA = passed by reference, set to the correct part of the + ; text that will print in the field's positions + ; + ; esg - 8/14/06 - modified for the new cms-1500 form - IB*2*348 + ; + N Z,IBLINE,IBVAL,IBS,IBE,IBTEXT,IBAUX,IBDAT,IBZ,IBREN,IBRENQ,IBRENNPI,IBRENSID + K IBXDATA + S (IBLINE,Z)=0 S:$G(IBSUB)="" IBSUB="BOX24" + ; + I FLD="I"!(FLD="J") D ; extract the Rendering provider data + . I '$G(IBXIEN) Q ; assume that the claim# exists + . S IBREN=$$CFIDS^IBCEF77(IBXIEN) + . S IBRENQ=$P(IBREN,U,1) ; qual + . S IBRENSID=$P(IBREN,U,2) ; id + . S IBRENNPI=$P(IBREN,U,3) ; npi + . Q + ; + F S Z=$O(IBXSAVE(IBSUB,Z)) Q:'Z D + . S IBDAT=$G(IBXSAVE(IBSUB,Z)) + . S IBAUX=$G(IBXSAVE(IBSUB,Z,"AUX")) + . S IBTEXT=$G(IBXSAVE(IBSUB,Z,"TEXT")) + . S IBZ=$P(IBAUX,U,9) + . I IBZ="" S IBZ=" " + . S IBTEXT=IBZ_IBTEXT + . ; + . I $S($G(IBAC)=4:$S($D(IBXSAVE(IBSUB,Z,"ARX")):1,1:$D(IBXSAVE(IBSUB,Z,"A"))),$D(IBXSAVE(IBSUB,Z,"RX")):0,1:$G(IBNOSHOW)) S IBTEXT="" + . ; + . I FLD="AF" S IBVAL=$P(IBDAT,U),IBS=1,IBE=9 D ; From date of service + .. S IBVAL=$E(IBVAL,1,2)_" "_$E(IBVAL,3,4)_" "_$E(IBVAL,7,8) + .. Q + . ; + . I FLD="AT" S IBVAL=$S($P(IBDAT,U,2):$P(IBDAT,U,2),1:$P(IBDAT,U)),IBS=10,IBE=18 D ; To date of service + .. S IBVAL=$E(IBVAL,1,2)_" "_$E(IBVAL,3,4)_" "_$E(IBVAL,7,8) + .. Q + . ; + . I FLD="B" S IBVAL=$P(IBDAT,U,3),IBS=19,IBE=21 ; place of service + . I FLD="C" S IBVAL=$S($P(IBDAT,U,13)=1:"Y",1:""),IBS=22,IBE=24 ; emergency indicator + . I FLD="D" S IBVAL=$P(IBDAT,U,5),IBS=25,IBE=44 D ; procedures and modifiers + .. N M S M=$$MODLST^IBEFUNC($P(IBDAT,U,10)) ; modifier list + .. S IBVAL=$$FO^IBCNEUT1(IBVAL,6)_" " ; procedure code + .. S IBVAL=IBVAL_$$FO^IBCNEUT1($P(M,",",1),3) ; mod#1 + .. S IBVAL=IBVAL_$$FO^IBCNEUT1($P(M,",",2),3) ; mod#2 + .. S IBVAL=IBVAL_$$FO^IBCNEUT1($P(M,",",3),3) ; mod#3 + .. S IBVAL=IBVAL_$$FO^IBCNEUT1($P(M,",",4),3) ; mod#4 + .. Q + . ; + . I FLD="E" S IBVAL=$TR($P(IBDAT,U,7),","),IBS=45,IBE=48 ; diagnosis pointer + . I FLD="F" S IBVAL=$P(IBDAT,U,8)*$P(IBDAT,U,9),IBS=49,IBE=57 D + .. ; total charges + .. S IBVAL=$$DOL^IBCEF77(IBVAL,9) + .. Q + . ; + . I FLD="G" S IBVAL=$S($P(IBDAT,U,12):$P(IBDAT,U,12),1:$P(IBDAT,U,9)),IBS=58,IBE=61 D + .. ; days or units or anesthesia minutes + .. S IBVAL=$J(+IBVAL,4) + .. Q + . ; + . ; columns H,I,J don't have any free text supplemental information + . ; + . I FLD="H" D ; epsdt family plan + .. S IBVAL=$P(IBAUX,U,7),IBS=0,IBE=0,IBTEXT="" ; line 1 blank + .. I IBVAL S IBVAL="Y" + .. Q + . I FLD="I" D ; ID qualifier for rendering provider + .. S IBVAL="",IBS=1,IBE=2 ; line 2 blank + .. S IBTEXT=$G(IBRENQ) ; qualifier on line 1 + .. Q + . I FLD="J" D ; rendering provider ID and NPI + .. S IBTEXT=$G(IBRENSID),IBS=1,IBE=11 ; secondary ID line 1 + .. S IBVAL=$G(IBRENNPI) ; NPI# line 2 + .. Q + . ; + . S IBLINE=IBLINE+1 ; top line + . S IBXDATA(IBLINE)=$E(IBTEXT,IBS,IBE) ; text in shaded area (top) + . S IBLINE=IBLINE+1 ; bottom line + . S IBXDATA(IBLINE)=IBVAL ; field value in unshaded area (bottom) + . Q + ; + Q + ; +BILLSPEC(IBIFN,IBPRV) ; Returns the specialty of the provider on bill IBIFN + ; If IBPRV is supplied, returns the data for that provider, otherwise, + ; returns the specialty of the 'main/required' provider on the bill. + ; Default = 99 if no valid code found + ; IBPRV = vp of provider (file 200 or 355.93) + N Z,IBSPEC,IBINS,IBDT + S IBSPEC="",IBPRV=$G(IBPRV) + S IBDT=$P($G(^DGCR(399,+IBIFN,"U")),U,1) ; use statement from date + ; + I $G(IBPRV) D G SPECQ + . S IBSPEC=$$SPEC^IBCEU(IBPRV,IBDT) + ; + ;Get rendering for professional, attending for institutional, + S IBINS=($$FT^IBCEF(IBIFN)=3) + D GETPRV^IBCEU(IBIFN,"ALL",.IBPRV) + S Z=$S('IBINS:3,1:4) + I $G(IBPRV(Z,1))'="" D + . I $P(IBPRV(Z,1),U,3) S IBSPEC=$$SPEC^IBCEU($P($G(IBPRV(Z,1)),U,3),IBDT) Q:IBSPEC'="" + . S Z0=+$O(^DGCR(399,IBIFN,"PRV","B",Z,0)) + . I Z0,$P($G(^DGCR(399,IBIFN,"PRV",Z0,0)),U,8)'="" S IBSPEC=$P(^(0),U,8) + ; +SPECQ I IBSPEC="" S IBSPEC="99" + Q IBSPEC + ; +CHAMPVA(IBIFN) ; Returns 1 if the bill IBIFN has a CHAMPVA rate type + Q $E($P($G(^DGCR(399.3,+$P($G(^DGCR(399,IBIFN,0)),U,7),0)),U),1,7)="CHAMPVA" + ; +FAC(IBIFN) ; Is facility always to print in box 32 for bill ien IBIFN? + ; Returns 1 if yes, 0 if no + Q $S($P($G(^DGCR(399,IBIFN,"UF2")),U,2):1,1:$P($G(^IBE(350.9,1,2)),U,12)) + ; +MCR24K(IBIFN) ;Function returns MEDICARE id# for professional (CMS-1500) box 24k for bill IBIFN if appropriate + Q $S($$FT^IBCEF(IBIFN)=2&$$MCRONBIL^IBEFUNC(IBIFN):"V"_$$MCRSPEC^IBCEU4(IBIFN,1)_$P($$SITE^VASITE,U,3),1:"") diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEU6.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEU6.m index ba0680c2..6ddf53db 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEU6.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEU6.m @@ -1,78 +1,77 @@ -IBCEU6 ;ALB/ESG - EDI UTILITIES FOR EOB PROCESSING ;29-JUL-2003 - ;;2.0;INTEGRATED BILLING;**155,371**;21-MAR-94;Build 57 - ;;Per VHA Directive 2004-038, this routine should not be modified. - Q - ; -COBLINE(IBIFN,IBI,IBXDATA,SORT,IBXTRA) ; Extract all COB data for line item - ; from file 361.1 (EOB), subfile 15 into IBXDATA(IBI,"COB",n) - ; - ; IBIFN = bill entry # - ; IBI = VistA outbound line item # - ; IBXDATA = array returned with COB line item data/pass by reference - ; SORT = flag that determines whether the data should be sorted for - ; output for the 837 record ('PR' group always there and has - ; a reason code for deductible first and co-insurance second - - ; even if they are 0). - ; 1 = sort, 0 = no sort needed - ; - ; Returns IBXDATA(IBI,"COB",COB,n) with COB data for each line item - ; found in an accepted EOB for the bill and = the '0' node data of - ; file 361.115 (LINE LEVEL ADJUSTMENTS) - ; -- AND -- - ; IBXDATA(IBI,"COB",COB,n,z,p)= - ; the data on the '0' node for each subordinate entry of file - ; 361.11511 (REASONS) (Only first 3 pieces for 837 output) - ; z = this is either piece 1 of the 0-node for subfile - ; 361.1151 (ADJUSTMENTS) - ; OR - ; for the 837 COB 'sorted' output, this will be ' PR' - ; for the forced/extracted entries for deductible - ; and co-insurance so they are always output first - ; The space needs to be stripped off on output - ; -- AND -- - ; IBXTRA = array returned if passed by reference if line is found - ; associated with line IBI due to bundling/unbundling - ; IBXTRA("ALL",x,paid procedure)=COB SEQ ^ seq # corresponding - ; to subscript n in IBXDATA(,"COB",COB,n - ; (x = line #-original proc-service dt) - ; - N A,B,B1,C,D,IBDATA,IB0,IB00,IBA,IBB,IBDED,IBCOI,IBS,IBN,IBDT - ; - ; If multiple EOB's reference this line for the same COB sequence, - ; extract only the last one marked accepted containing this line item. - ; - S A=0 - F S A=$O(^IBM(361.1,"B",IBIFN,A)) Q:'A D - . I '$$EOBELIG^IBCEU1(A) Q ; eob not eligible for secondary claim - . I '$D(^IBM(361.1,A,15,"AC",IBI)) Q ; this EOB does not reference VistA line# IBI - . S IBA=0 - . S IBDATA=$G(^IBM(361.1,A,0)) - . S IBS=$P(IBDATA,U,15) ; insurance sequence# - . S IBN=+$O(IBXDATA(IBI,"COB",IBS,0)) - . I IBN D Q:IBN ; check for later EOB - .. I $G(IBDT(IBI,IBS)),IBDT(IBI,IBS)<$P(IBDATA,U,6) K IBDT(IBI,IBS),IBXDATA(IBI,"COB",IBS) S IBN=0 - . ; - . S IBDT(IBI,IBS)=$P(IBDATA,U,6) - . S B=0 - . F S B=$O(^IBM(361.1,A,15,"AC",IBI,B)) Q:'B S IB0=$G(^IBM(361.1,A,15,B,0)),IB0=IB0_U_IBDT(IBI,IBS) D - .. Q:$TR(IB0,U)="" - .. S IBA=IBA+1,IBXDATA(IBI,"COB",IBS,IBA)=IBI_U_IB0 - .. ; - .. ; capture the modifiers (361.1152) - .. I $D(^IBM(361.1,A,15,B,2)) M IBXDATA(IBI,"COBMOD")=^IBM(361.1,A,15,B,2) - .. I $P(IB0,U,15)'="" D ;Line involved in bundling/unbundling - ... N Z0 S Z0=IBI_"-"_$P(IB0,U,15)_"-"_$P(IB0,U,16) - ... S IBXTRA("ALL",Z0,$P(IB0,U,4))=IBS_U_IBA,$P(IBXDATA(IBI,"COB",IBS,IBA),U)="" - .. S C=0,(IBDED(IBA),IBCOI(IBA))="0^0" ;Assume 0 if not found in list - .. F S C=$O(^IBM(361.1,A,15,B,1,C)) Q:'C S IB0=$G(^(C,0)) D - ... S D=0 - ... F S D=$O(^IBM(361.1,A,15,B,1,C,1,D)) Q:'D S IB00=$S($G(SORT):$P($G(^(D,0)),U,1,3),1:$G(^(D,0))) D - .... I $G(SORT),$P(IB0,U)="PR" D ;Check for deductible or co-ins - ..... I 'IBDED(IBA),$P(IB00,U)=1 S IBDED(IBA)=IB00,IB00="" Q - ..... I 'IBCOI(IBA),$P(IB00,U)=2 S IBCOI(IBA)=IB00,IB00="" Q - .... I $TR(IB00,U)'="" S IBB=$O(IBXDATA(IBI,"COB",IBS,IBA,$P(IB0,U),""),-1)+1,IBXDATA(IBI,"COB",IBS,IBA,$P(IB0,U),IBB)=IB00 - .. Q:'$G(SORT) - .. S IBXDATA(IBI,"COB",IBS,IBA," PR",1)=IBDED(IBA) - .. S IBXDATA(IBI,"COB",IBS,IBA," PR",2)=IBCOI(IBA) - Q - ; +IBCEU6 ;ALB/ESG - EDI UTILITIES FOR EOB PROCESSING ;29-JUL-2003 + ;;2.0;INTEGRATED BILLING;**155**;21-MAR-94 + ; + Q + ; +COBLINE(IBIFN,IBI,IBXDATA,SORT,IBXTRA) ; Extract all COB data for line item + ; from file 361.1 (EOB), subfile 15 into IBXDATA(IBI,"COB",n) + ; + ; IBIFN = bill entry # + ; IBI = VistA outbound line item # + ; IBXDATA = array returned with COB line item data/pass by reference + ; SORT = flag that determines whether the data should be sorted for + ; output for the 837 record ('PR' group always there and has + ; a reason code for deductible first and co-insurance second - + ; even if they are 0). + ; 1 = sort, 0 = no sort needed + ; + ; Returns IBXDATA(IBI,"COB",COB,n) with COB data for each line item + ; found in an accepted EOB for the bill and = the '0' node data of + ; file 361.115 (LINE LEVEL ADJUSTMENTS) + ; -- AND -- + ; IBXDATA(IBI,"COB",COB,n,z,p)= + ; the data on the '0' node for each subordinate entry of file + ; 361.11511 (REASONS) (Only first 3 pieces for 837 output) + ; z = this is either piece 1 of the 0-node for subfile + ; 361.1151 (ADJUSTMENTS) + ; OR + ; for the 837 COB 'sorted' output, this will be ' PR' + ; for the forced/extracted entries for deductible + ; and co-insurance so they are always output first + ; The space needs to be stripped off on output + ; -- AND -- + ; IBXTRA = array returned if passed by reference if line is found + ; associated with line IBI due to bundling/unbundling + ; IBXTRA("ALL",x,paid procedure)=COB SEQ ^ seq # corresponding + ; to subscript n in IBXDATA(,"COB",COB,n + ; (x = line #-original proc-service dt) + ; + N A,B,B1,C,D,IBDATA,IB0,IB00,IBA,IBB,IBDED,IBCOI,IBS,IBN,IBDT + ; + ; If multiple EOB's reference this line for the same COB sequence, + ; extract only the last one marked accepted containing this line item. + ; + S A=0 + F S A=$O(^IBM(361.1,"B",IBIFN,A)) Q:'A D + . I '$$EOBELIG^IBCEU1(A) Q ; eob not eligible for secondary claim + . S IBA=0 + . S IBDATA=$G(^IBM(361.1,A,0)) + . S IBS=$P(IBDATA,U,15) ; insurance sequence# + . S IBN=+$O(IBXDATA(IBI,"COB",IBS,0)) + . I IBN D Q:IBN ; check for later EOB + .. I $G(IBDT(IBI,IBS)),IBDT(IBI,IBS)<$P(IBDATA,U,6) K IBDT(IBI,IBS),IBXDATA(IBI,"COB",IBS) S IBN=0 + . ; + . S IBDT(IBI,IBS)=$P(IBDATA,U,6) + . S B=0 + . F S B=$O(^IBM(361.1,A,15,"AC",IBI,B)) Q:'B S IB0=$G(^IBM(361.1,A,15,B,0)),IB0=IB0_U_IBDT(IBI,IBS) D + .. Q:$TR(IB0,U)="" + .. S IBA=IBA+1,IBXDATA(IBI,"COB",IBS,IBA)=IBI_U_IB0 + .. ; + .. ; capture the modifiers (361.1152) + .. I $D(^IBM(361.1,A,15,B,2)) M IBXDATA(IBI,"COBMOD")=^IBM(361.1,A,15,B,2) + .. I $P(IB0,U,15)'="" D ;Line involved in bundling/unbundling + ... N Z0 S Z0=IBI_"-"_$P(IB0,U,15)_"-"_$P(IB0,U,16) + ... S IBXTRA("ALL",Z0,$P(IB0,U,4))=IBS_U_IBA,$P(IBXDATA(IBI,"COB",IBS,IBA),U)="" + .. S C=0,(IBDED(IBA),IBCOI(IBA))="0^0" ;Assume 0 if not found in list + .. F S C=$O(^IBM(361.1,A,15,B,1,C)) Q:'C S IB0=$G(^(C,0)) D + ... S D=0 + ... F S D=$O(^IBM(361.1,A,15,B,1,C,1,D)) Q:'D S IB00=$S($G(SORT):$P($G(^(D,0)),U,1,3),1:$G(^(D,0))) D + .... I $G(SORT),$P(IB0,U)="PR" D ;Check for deductible or co-ins + ..... I 'IBDED(IBA),$P(IB00,U)=1 S IBDED(IBA)=IB00,IB00="" Q + ..... I 'IBCOI(IBA),$P(IB00,U)=2 S IBCOI(IBA)=IB00,IB00="" Q + .... I $TR(IB00,U)'="" S IBB=$O(IBXDATA(IBI,"COB",IBS,IBA,$P(IB0,U),""),-1)+1,IBXDATA(IBI,"COB",IBS,IBA,$P(IB0,U),IBB)=IB00 + .. Q:'$G(SORT) + .. S IBXDATA(IBI,"COB",IBS,IBA," PR",1)=IBDED(IBA) + .. S IBXDATA(IBI,"COB",IBS,IBA," PR",2)=IBCOI(IBA) + Q + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEXTRP.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEXTRP.m index 2da75637..c73558e3 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEXTRP.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEXTRP.m @@ -1,173 +1,107 @@ -IBCEXTRP ;ALB/JEH - VIEW/PRINT EDI EXTRACT DATA ;4/22/03 9:59am - ;;2.0;INTEGRATED BILLING;**137,197,211,348,349,377**;21-MAR-94;Build 23 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -EN ; -INIT ; - W !!,"This option will display the EDI extract data for a bill.",! - N IBREC1,IBIEN,IBINC,DIC,X,Y,DIR,IB364IEN,IBVNUM,IBSEG,STOP,POP,DTOUT,DUOUT - ; - N DPTNOFZY S DPTNOFZY=1 ; Suppress PATIENT file fuzzy lookups - S DIC="^DGCR(399,",DIC(0)="AEMQ",DIC("S")="I 234[$P(^(0),U,13)" D ^DIC - I Y<1 G EXITQ - S IBIEN=+Y,IBREC1=$G(^DGCR(399,IBIEN,0)) - S IB364IEN=$$LAST364^IBCEF4(IBIEN) I +$G(IB364IEN)=0 D G EXITQ - . W !,"There is no entry in the EDI Transmit Bill file for this bill number." - S IBVNUM=$P($G(^IBA(364,IB364IEN,0)),U,2) I +$G(IBVNUM)=0 D G EXITQ - . W !!,"There is no batch # for this bill. It has not been transmitted." - S IBVNUM=$P($G(^IBA(364.1,IBVNUM,0)),U) - S DIR("A")="Include Fields With No Data?: ",DIR("B")="NO",DIR(0)="YA" - W ! D ^DIR K DIR - I $D(DTOUT)!$D(DUOUT) G EXITQ - S IBINC=+Y - ; - ; IB*2*377 - esg - Ask for specific EDI segments to view - ; - W ! - S DIR(0)="SA^A:All EDI Segments;S:Selected EDI Segments" - S DIR("A")="Include (A)ll or (S)elected EDI Segments?: " - S DIR("B")="All EDI Segments" - D ^DIR K DIR - I $D(DTOUT)!$D(DUOUT) G EXITQ - I Y="A" G DEV ; all segments, skip to device prompt - ; - W ! - K IBSEG - S STOP=0 - F D Q:STOP - . S DIR(0)="FO^3:4" - . S DIR("A")=" Select EDI Segment" - . I $D(IBSEG) S DIR("A")="Another EDI Segment" - . S DIR("?")="Enter the name of the EDI segment to include." - . D ^DIR K DIR - . I $D(DTOUT)!$D(DUOUT) S STOP=1 Q - . S Y=$$UP^XLFSTR(Y),Y=$$TRIM^XLFSTR(Y) ; uppercase/trim spaces - . I Y="" S STOP=1 Q - . S IBSEG(Y)="" - . Q - I $D(DTOUT)!$D(DUOUT) G EXITQ - ; -DEV ; - Select device - N %ZIS,ZTRTN,ZTSAVE,ZTDESC - W ! - S %ZIS="QM" D ^%ZIS G:POP EXITQ - I $D(IO("Q")) D G EXITQ - . S ZTRTN="LIST^IBCEXTRP",ZTDESC="Transmitted Bill Extract Data" - . S ZTSAVE("IB*")="" - . D ^%ZTLOAD - . W !!,$S($D(ZTSK):"Your task number "_ZTSK_" has been queued.",1:"Unable to queue this job.") - .K ZTSK,IO("Q") D HOME^%ZIS - U IO - ; -LIST ; - set up array and print data - N IBPG,IBSEQ,IBPC,IBDA,IBREC,IBQUIT,IBILL,IBLINE,IBXDATA,IBERR,IBXERR,Z,Z0,Z1 - D EXTRACT(IBIEN,IBVNUM,8,1) - S (IBPG,IBQUIT,IBSEQ,IBPC,IBDA,IBLINE)=0 - K ^TMP($J,"IBLINES") - ;IB*2.0*211 - rely on form type instead of bill charge type - N IBFMTYP S IBFMTYP=$$FT^IBCEF(IBIEN) - S IBFMTYP=$S(IBFMTYP=2:"CMS-1500",IBFMTYP=3:"UB-04",1:"OTHER"_"("_IBFMTYP_")") - S IBILL=$S($$INPAT^IBCEF(IBIEN,1):"Inpt",1:"Oupt")_"/"_IBFMTYP - ; - I $D(^TMP("IBXERR",$J)) D G EXITQ - . S IBERR=0 F S IBERR=$O(^TMP("IBXERR",$J,IBERR)) Q:'IBERR W !,$G(^TMP("IBXERR",$J,IBERR)) - . Q - ; - F S IBSEQ=$O(^IBA(364.6,"ASEQ",8,IBSEQ)) Q:'IBSEQ I $$INCLUDE(IBSEQ) F S IBPC=$O(^IBA(364.6,"ASEQ",8,IBSEQ,1,IBPC)) Q:'IBPC F S IBDA=$O(^IBA(364.6,"ASEQ",8,IBSEQ,1,IBPC,IBDA)) Q:'IBDA D - . N IBOK,Z,IBMULT,DSP,IBDATA,PCD,SN - . S IBREC=$G(^IBA(364.6,IBDA,0)) - . I $P(IBREC,U,11)=1 Q ; calculate only field - . ; - . ; processing for piece 1 of this EDI segment to see if there is any - . ; other data that exists in this segment - . I IBPC=1 S IBOK=0 D - .. S Z=1 F S Z=$O(^TMP("IBXDATA",$J,1,IBSEQ,1,Z)) Q:'Z I $G(^(Z))'="" S IBOK=1 Q - .. I IBOK Q ; data exists so include segment normally - .. S SN=$P($G(^TMP("IBXDATA",$J,1,IBSEQ,1,1)),U,1) ; segment name - .. I SN="" S SN=$P($P(IBREC,U,10),"'",2) - .. S SN=SN_" (No Data - Record Not Sent)" - .. S $P(^TMP("IBXDATA",$J,1,IBSEQ,1,1),U,1)=SN - .. Q - . ; - . ; loop thru all multiple occurrences of this segment - . S IBMULT=0 F S IBMULT=$O(^TMP("IBXDATA",$J,1,IBSEQ,IBMULT)) Q:'IBMULT D - .. ; - .. ; field with no data; check user preference - .. I '$G(IBINC),$P($G(^TMP("IBXDATA",$J,1,IBSEQ,IBMULT,IBPC)),U,1)="" Q - .. ; - .. ; build display data - .. S PCD="["_IBPC_"] " ; piece# - .. S DSP=$P(IBREC,U,10) ; short description field - .. S IBDATA=$P($G(^TMP("IBXDATA",$J,1,IBSEQ,IBMULT,IBPC)),U,1) ; data - .. S DSP=$J(PCD,5)_$$FO^IBCNEUT1(DSP,40)_": "_IBDATA - .. S ^TMP($J,"IBLINES",IBSEQ,IBMULT,IBPC)=DSP - .. Q - . Q - ; - S IBQUIT=0 - W:$E(IOST,1,2)["C-" @IOF ; initial form feed for screen print - N IBFMTYP S IBFMTYP=$$FT^IBCEF(IBIEN) - S IBFMTYP=$S(IBFMTYP=2:"CMS-1500",IBFMTYP=3:"UB-04",1:"OTHER"_"("_IBFMTYP_")") - S IBILL=$S($$INPAT^IBCEF(IBIEN,1):"Inpt",1:"Oupt")_"/"_IBFMTYP - D HDR - S Z=0 F S Z=$O(^TMP($J,"IBLINES",Z)) Q:'Z!IBQUIT S Z0=0 F S Z0=$O(^TMP($J,"IBLINES",Z,Z0)) Q:'Z0!IBQUIT S Z1=0 F S Z1=$O(^TMP($J,"IBLINES",Z,Z0,Z1)) Q:'Z1!IBQUIT D Q:IBQUIT - . I IBLINE>(IOSL-3) D HDR Q:IBQUIT - . W !,^TMP($J,"IBLINES",Z,Z0,Z1) - . S IBLINE=IBLINE+1 - . I IBLINE>(IOSL-3) D HDR Q:IBQUIT - . ; - . ; end of segment add an extra line feed - . I '$O(^TMP($J,"IBLINES",Z,Z0,Z1)) W ! S IBLINE=IBLINE+1 - . Q - ; - K ^TMP($J,"IBLINES") - G EXITQ - ; - ; -HDR ; - Report header - N DIR,Y - I IBPG D Q:IBQUIT - . I $E(IOST,1,2)["C-" K DIR S DIR(0)="E" D ^DIR K DIR S IBQUIT=('Y) Q:IBQUIT - . W @IOF - ; - S IBPG=IBPG+1 - W !,?25,"EDI Transmitted Bill Extract Data",!,"Bill #",?11,"Type",?27,"Patient Name",?52,"SSN",?57,$$FMTE^XLFDT(DT),?71,"Page: "_IBPG - W !,$TR($J("",IOM)," ","=") - W !,$P(IBREC1,U)_" "_"("_IBILL_")",?27,$P($G(^DPT(+$P(IBREC1,U,2),0)),U),?52,$P($G(^DPT($P(IBREC1,U,2),0)),U,9),! - S IBLINE=6 - Q - ; -EXITQ ; - clean up and exit - I $E(IOST,1,2)["C-",'$G(IBQUIT) K DIR S DIR(0)="E" W ! D ^DIR K DIR - K ^TMP("IBXERR",$J),^TMP("IBXDATA",$J),IBXERR - D CLEAN^DILF - Q - ; -EXTRACT(IBIFN,IBBATCH,IBFORM,IBLOCAL) ; Extracts transmitted form data into global - ; ^TMP("IBXDATA",$J). Errors are in ^TMP("IBXERR",$J,err_num)=text. - ; IBBATCH = Batch # of bill (if known), otherwise, set to 1. This - ; variable must be > 0 to prevent a new batch from being added - ; IBFORM = the ien of the form in file 353 - ; IBLOCAL = 1 if OK to use local form, 0 if not - N IBVNUM,IBL,IBINC,IBSEG - D FORMPRE^IBCFP1 - S IBVNUM=$G(IBBATCH) - S IBL=$S('$G(IBLOCAL):IBFORM,1:"") ; No local form ... set = main form - ; Get local form associated with parent, if any - I IBL="" S IBL=$S($P($G(^IBE(353,+IBFORM,2)),U,8):$P(^(2),U,8),1:IBFORM) - D SETUP^IBCE837(1) - D ROUT^IBCFP1(IBFORM,1,IBIFN,0,IBL) - Q - ; -INCLUDE(IBSEQ) ; Function to determine if segment should be included or not - N OK,LZ,SEGNAME - S OK=1 ; default is to include it - I '$D(IBSEG) G INCLX ; if nothing in array, then include all - I '$D(^TMP("IBXDATA",$J,1,IBSEQ)) S OK=0 G INCLX ; no data there - S LZ=+$O(^TMP("IBXDATA",$J,1,IBSEQ,"")) ; first line# found in data - S SEGNAME=$P($G(^TMP("IBXDATA",$J,1,IBSEQ,LZ,1)),U,1) ; piece 1 - S SEGNAME=$$TRIM^XLFSTR(SEGNAME) - I SEGNAME'="",'$D(IBSEG(SEGNAME)) S OK=0 ; don't include -INCLX ; - Q OK - ; +IBCEXTRP ;ALB/JEH - VIEW/PRINT EDI EXTRACT DATA ; 4/22/03 9:59am + ;;2.0;INTEGRATED BILLING;**137,197,211,348,349**;21-MAR-94;Build 46 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; +EN ; +INIT ; + W !!,"This option will display the EDI extract data for a bill.",! + N IBREC1,IBIEN,IBINC,DIC,X,Y,DIR,IB364IEN,IBVNUM + ; + N DPTNOFZY S DPTNOFZY=1 ; Suppress PATIENT file fuzzy lookups + S DIC="^DGCR(399,",DIC(0)="AEMQ",DIC("S")="I 234[$P(^(0),U,13)" D ^DIC + I Y<1 G EXITQ + S IBIEN=+Y,IBREC1=$G(^DGCR(399,IBIEN,0)) + S IB364IEN=$$LAST364^IBCEF4(IBIEN) I +$G(IB364IEN)=0 D G EXITQ + . W !,"There is no entry in the EDI Transmit Bill file for this bill number." + S IBVNUM=$P($G(^IBA(364,IB364IEN,0)),U,2) I +$G(IBVNUM)=0 D G EXITQ + . W !!,"There is no batch # for this bill. It has not been transmitted." + S IBVNUM=$P($G(^IBA(364.1,IBVNUM,0)),U) + S DIR("A")="INCLUDE FIELDS WITH NO DATA?: ",DIR("B")="NO",DIR(0)="YA" D ^DIR K DIR + I $D(DTOUT)!$D(DUOUT) G EXITQ + S IBINC=+Y +DEV ; - Select device + N %ZIS,ZTRTN,ZTSAVE,ZTDESC + S %ZIS="QM" D ^%ZIS G:POP EXITQ + I $D(IO("Q")) D G EXITQ + . S ZTRTN="LIST^IBCEXTRP",ZTDESC="Transmitted Bill Extract Data" + . S ZTSAVE("IB*")="" + . D ^%ZTLOAD + . W !!,$S($D(ZTSK):"Your task number "_ZTSK_" has been queued.",1:"Unable to queue this job.") + .K ZTSK,IO("Q") D HOME^%ZIS + U IO + ; +LIST ; - set up array and print data + N IBPG,IBSEQ,IBPC,IBDA,IBREC,IBQUIT,IBILL,IBLINE,IBXDATA,IBERR,IBXERR,Z,Z0,Z1 + D EXTRACT(IBIEN,IBVNUM,8,1) + S (IBPG,IBQUIT,IBSEQ,IBPC,IBDA,IBLINE)=0 + K ^TMP($J,"IBLINES") + ;IB*2.0*211 - rely on form type instead of bill charge type + N IBFMTYP S IBFMTYP=$$FT^IBCEF(IBIEN) + S IBFMTYP=$S(IBFMTYP=2:"CMS-1500",IBFMTYP=3:"UB-04",1:"OTHER"_"("_IBFMTYP_")") + S IBILL=$S($$INPAT^IBCEF(IBIEN,1):"Inpt",1:"Oupt")_"/"_IBFMTYP + I $D(^TMP("IBXERR",$J)) D G EXITQ + . S IBERR=0 F S IBERR=$O(^TMP("IBXERR",$J,IBERR)) Q:'IBERR W !,$G(^TMP("IBXERR",$J,IBERR)) + F S IBSEQ=$O(^IBA(364.6,"ASEQ",8,IBSEQ)) Q:'IBSEQ!(IBQUIT) F S IBPC=$O(^IBA(364.6,"ASEQ",8,IBSEQ,1,IBPC)) Q:'IBPC!(IBQUIT) F S IBDA=$O(^IBA(364.6,"ASEQ",8,IBSEQ,1,IBPC,IBDA)) Q:'IBDA!(IBQUIT) S IBREC=$G(^IBA(364.6,IBDA,0)) D Q:IBQUIT + . N IBOK,Z,IBMULT + . I $P(IBREC,U,11)=1 Q + . I IBPC=1 S IBOK=0 D + .. S Z=1 F S Z=$O(^TMP("IBXDATA",$J,1,IBSEQ,1,Z)) Q:'Z I $G(^(Z))'="" S IBOK=1 Q + .. I 'IBOK S $P(^TMP("IBXDATA",$J,1,IBSEQ,1,1),U)=$P($G(^TMP("IBXDATA",$J,1,IBSEQ,1,1)),U)_" (NO DATA - RECORD NOT SENT)" + . S IBMULT=0 F S IBMULT=$O(^TMP("IBXDATA",$J,1,IBSEQ,IBMULT)) Q:'IBMULT D + .. I '$G(IBINC),$P($G(^TMP("IBXDATA",$J,1,IBSEQ,IBMULT,IBPC)),U)="" Q + .. S ^TMP($J,"IBLINES",IBSEQ,IBMULT,IBPC)=$E($P(IBREC,U,10)_$J("",30),1,30)_": "_$P($G(^TMP("IBXDATA",$J,1,IBSEQ,IBMULT,IBPC)),U) + . + W:$E(IOST,1,2)["C-" @IOF ; initial form feed for screen print + N IBFMTYP S IBFMTYP=$$FT^IBCEF(IBIEN) + S IBFMTYP=$S(IBFMTYP=2:"CMS-1500",IBFMTYP=3:"UB-04",1:"OTHER"_"("_IBFMTYP_")") + S IBILL=$S($$INPAT^IBCEF(IBIEN,1):"Inpt",1:"Oupt")_"/"_IBFMTYP + D HDR + S Z=0 F S Z=$O(^TMP($J,"IBLINES",Z)) Q:'Z S Z0=0 F S Z0=$O(^TMP($J,"IBLINES",Z,Z0)) Q:'Z0 S Z1=0 F S Z1=$O(^TMP($J,"IBLINES",Z,Z0,Z1)) Q:'Z1 D G:IBQUIT Q1 + . D:IBLINE>(IOSL-5) HDR Q:IBQUIT + . W !,^TMP($J,"IBLINES",Z,Z0,Z1) + . S IBLINE=IBLINE+1 +Q1 K ^TMP($J,"IBLINES") + Q + ; +HDR ; - Report header + N DIR,Y + I IBPG D Q:IBQUIT + . I $E(IOST,1,2)["C-" K DIR S DIR(0)="E" D ^DIR K DIR S IBQUIT=('Y) Q:IBQUIT + . W @IOF + ; + S IBPG=IBPG+1 + W !!,?25,"EDI Transmitted Bill Extract Data",!,"Bill #",?11,"Type",?27,"Patient Name",?52,"SSN",?57,$$FMTE^XLFDT(DT),?71,"Page: "_IBPG + W !,$TR($J("",IOM)," ","=") + W !,$P(IBREC1,U)_" "_"("_IBILL_")",?27,$P($G(^DPT(+$P(IBREC1,U,2),0)),U),?52,$P($G(^DPT($P(IBREC1,U,2),0)),U,9),! + S IBLINE=5 + Q + ; +ASK ; + I $E(IOST,1,2)'["C-" Q + N DIR,DIROUT,DIRUT,DTOUT,DUOUT + S DIR(0)="E" D ^DIR + I ($D(DIRUT))!($D(DUOUT)) S IBQUIT=1 + Q + ; +EXITQ ; - clean up and exit + I $E(IOST,1,2)["C-" K DIR S DIR(0)="E" W ! D ^DIR K DIR + K ^TMP("IBXERR",$J),^TMP("IBXDATA",$J),IBXERR + D CLEAN^DILF + Q + ; +EXTRACT(IBIFN,IBBATCH,IBFORM,IBLOCAL) ; Extracts transmitted form data into global + ; ^TMP("IBXDATA",$J). Errors are in ^TMP("IBXERR",$J,err_num)=text. + ; IBBATCH = Batch # of bill (if known), otherwise, set to 1. This + ; variable must be > 0 to prevent a new batch from being added + ; IBFORM = the ien of the form in file 353 + ; IBLOCAL = 1 if OK to use local form, 0 if not + N IBVNUM,IBL + D FORMPRE^IBCFP1 + S IBVNUM=$G(IBBATCH) + S IBL=$S('$G(IBLOCAL):IBFORM,1:"") ; No local form ... set = main form + ; Get local form associated with parent, if any + I IBL="" S IBL=$S($P($G(^IBE(353,+IBFORM,2)),U,8):$P(^(2),U,8),1:IBFORM) + D SETUP^IBCE837(1) + D ROUT^IBCFP1(IBFORM,1,IBIFN,0,IBL) + Q + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCF331.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCF331.m index 5c57a872..725c0889 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCF331.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCF331.m @@ -1,39 +1,39 @@ -IBCF331 ;ALB/ARH - UB92 HCFA-1450 (GATHER CODES CONT) ;25-AUG-1993 - ;;2.0;INTEGRATED BILLING;**52,210,309,389**; 21-MAR-94;Build 6 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ; -DX ;additional dx codes (ie more than 9 on bill) - D SET^IBCSC4D(IBIFN,"",.IBARRAY) G:$P(IBARRAY,U,2)'>9 RX - S IBX=+$P(IBARRAY,U,2)-9+2 D SPACE - S IBZ="" D SET2 - S IBZ="ADDITIONAL DIAGNOSIS CODES:" D SET2 - S IBX=0 F IBI=1:1 S IBX=$O(IBARRAY(IBX)) Q:IBX="" I IBI>9 D - . S IBY=$$ICD9^IBACSV(+$G(IBARRAY(IBX)),$$BDATE^IBACSV(+IBIFN)) Q:IBY="" - . S IBZ=$P(IBY,U)_$J(" ",(10-$L($P(IBY,U))))_$P(IBY,U,3) D SET2 - ; -RX ;add rx refills - D SET^IBCSC5A(IBIFN,.IBARRAY) G:'$P(IBARRAY,U,2) PD - S IBX=+$P(IBARRAY,U,2)+2 D SPACE - S IBZ="" D SET2 - S IBZ="PRESCRIPTION REFILLS:" D SET2 - S IBX=0 F S IBX=$O(IBARRAY(IBX)) Q:IBX="" S IBY=0 F S IBY=$O(IBARRAY(IBX,IBY)) Q:'IBY S IBLN=IBARRAY(IBX,IBY) D - . D ZERO^IBRXUTL(+$P(IBLN,U,2)) - . S IBZ=IBX_$J(" ",(11-$L(IBX)))_" "_$J($S($P(IBLN,U,6):"$"_$FN($P(IBLN,U,6),",",2),1:""),10)_" "_$J($$FMTE^XLFDT(IBY,2),8)_" "_$G(^TMP($J,"IBDRUG",+$P(IBLN,U,2),.01)) D SET2 - . S IBZ="",IBZ=$S(+$P(IBLN,U,4):"QTY: "_$P(IBLN,U,4)_" ",1:"")_$S(+$P(IBLN,U,3):"for "_$P(IBLN,U,3)_" days supply ",1:"") I IBZ'="" S IBZ=$J(" ",35)_IBZ D SET2 - . S IBZ="",IBZ=$S($P(IBLN,U,5)'="":"NDC #: "_$P(IBLN,U,5),1:"") I IBZ'="" S IBZ=$J(" ",35)_IBZ D SET2 - . K ^TMP($J,"IBDRUG") - . Q - ; -PD ;add prosthetic items - D SET^IBCSC5B(IBIFN,.IBARRAY) G:'$P(IBARRAY,U,2) END - S IBX=+$P(IBARRAY,U,2)+2 D SPACE - S IBZ="" D SET2 - S IBZ="PROSTHETIC ITEMS:" D SET2 - S IBX=0 F S IBX=$O(IBARRAY(IBX)) Q:IBX="" S IBY=0 F S IBY=$O(IBARRAY(IBX,IBY)) Q:'IBY D - . S IBZ=$$FMTE^XLFDT(IBX,2)_" "_$J($S($P(IBARRAY(IBX,IBY),U,2):"$"_$FN($P(IBARRAY(IBX,IBY),U,2),",",2),1:""),10)_" "_$E($$PINB^IBCSC5B(+IBARRAY(IBX,IBY)),1,54) D SET2 - ; -END Q - ; -SET2 D SET2^IBCF33 Q -SPACE D SPACE^IBCF33 Q +IBCF331 ;ALB/ARH - UB92 HCFA-1450 (GATHER CODES CONT) ;25-AUG-1993 + ;;2.0;INTEGRATED BILLING;**52,210,309**; 21-MAR-94 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; + ; +DX ;additional dx codes (ie more than 9 on bill) + D SET^IBCSC4D(IBIFN,"",.IBARRAY) G:$P(IBARRAY,U,2)'>9 RX + S IBX=+$P(IBARRAY,U,2)-9+2 D SPACE + S IBZ="" D SET2 + S IBZ="ADDITIONAL DIAGNOSIS CODES:" D SET2 + S IBX=0 F IBI=1:1 S IBX=$O(IBARRAY(IBX)) Q:IBX="" I IBI>9 D + . S IBY=$$ICD9^IBACSV(+$G(IBARRAY(IBX)),$$BDATE^IBACSV(+IBIFN)) Q:IBY="" + . S IBZ=$P(IBY,U)_$J(" ",(10-$L($P(IBY,U))))_$P(IBY,U,3) D SET2 + ; +RX ;add rx refills + D SET^IBCSC5A(IBIFN,.IBARRAY) G:'$P(IBARRAY,U,2) PD + S IBX=+$P(IBARRAY,U,2)+2 D SPACE + S IBZ="" D SET2 + S IBZ="PRESCRIPTION REFILLS:" D SET2 + S IBX=0 F S IBX=$O(IBARRAY(IBX)) Q:IBX="" S IBY=0 F S IBY=$O(IBARRAY(IBX,IBY)) Q:'IBY S IBLN=IBARRAY(IBX,IBY) D + . D ZERO^IBRXUTL(+$P(IBLN,U,2)) + . S IBZ=IBX_$J(" ",(11-$L(IBX)))_" "_$J($S($P(IBLN,U,6):"$"_$FN($P(IBLN,U,6),",",2),1:""),10)_" "_$J($$FMTE^XLFDT(IBY,2),8)_" "_$G(^TMP($J,"IBDRUG",+$P(IBLN,U,2),.01)) D SET2 + . S IBZ="",IBZ=$S(+$P(IBLN,U,4):"QTY: "_$P(IBLN,U,4)_" ",1:"")_$S(+$P(IBLN,U,3):"for "_$P(IBLN,U,3)_" days supply ",1:"") I IBZ'="" S IBZ=$J(" ",35)_IBZ D SET2 + . S IBZ="",IBZ=$S($P(IBLN,U,5)'="":"NDC #: "_$P(IBLN,U,5),1:"") I IBZ'="" S IBZ=$J(" ",35)_IBZ D SET2 + . K ^TMP($J,"IBDRUG") + . Q + ; +PD ;add prosthetic items + D SET^IBCSC5B(IBIFN,.IBARRAY) G:'$P(IBARRAY,U,2) END + S IBX=+$P(IBARRAY,U,2)+2 D SPACE + S IBZ="" D SET2 + S IBZ="PROSTHETIC ITEMS:" D SET2 + S IBX=0 F S IBX=$O(IBARRAY(IBX)) Q:IBX="" S IBY=0 F S IBY=$O(IBARRAY(IBX,IBY)) Q:'IBY D + . S IBZ=$$FMTE^XLFDT(IBX,2)_" "_$J($S($P(IBARRAY(IBX,IBY),U,2):"$"_$FN($P(IBARRAY(IBX,IBY),U,2),",",2),1:""),10)_" "_$E($P($$PIN^IBCSC5B(IBY),U,2),1,54) D SET2 + ; +END Q + ; +SET2 D SET2^IBCF33 Q +SPACE D SPACE^IBCF33 Q diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCF4.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCF4.m index 87de82dd..68455c76 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCF4.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCF4.m @@ -1,105 +1,105 @@ -IBCF4 ;ALB/ARH - PRINT BILL ADDENDUM ;12-JAN-94 - ;;2.0;INTEGRATED BILLING;**52,137,199,309,389**;21-MAR-94;Build 6 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -PRXA ;get bill number then print rx refill addendums for bills - S DIC("S")="I $D(^IBA(362.4,""AIFN""_+Y))!($D(^IBA(362.5,""AIFN""_+Y)))" - N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy lookups - S DIC="^DGCR(399,",DIC(0)="AEMQ" D ^DIC K DIC G:+Y'>0 EXIT S IBBILL=$P(Y,U,2),IBIFN=+Y - ; - I $D(^IBA(364,"ABDT",IBIFN)),+$$TXMT^IBCEF4(IBIFN)=1 D G:'IBTXOK PRXA - .S IBTXOK=0 - .N IBLDT,IBX - .S IBLDT=$O(^IBA(364,"ABDT",IBIFN,""),-1),IBX=$O(^IBA(364,"B",IBIFN,+IBLDT,""),-1) - .I "X"[$P($G(^IBA(364,+IBX,0)),U,3) W !!,*7,"Transmittable Bill can NOT be printed until transmitted" Q - .W !!,"This is a Transmittable Bill that has already been transmitted" - .W !!,"WANT TO PRINT THIS BILL ADDENDUM ANYWAY" S %=2 D YN^DICN - .Q:'(%+1#3) ;-1 or 2 - .S IBTXOK=1 - ; -DEV ;get the device - W !!,"Report requires 132 columns." - S %ZIS="QM",%ZIS("A")="OUTPUT DEVICE: " D ^%ZIS G:POP EXIT - I $D(IO("Q")) S ZTRTN="EN^IBCF4",ZTDESC="BILL ADDENDUM FOR "_IBBILL,ZTSAVE("IB*")="" D ^%ZTLOAD K IO("Q"),ZTSK G EXIT - U IO D EN - ; -EXIT ;clean up and quit - I $D(ZTQUEUED) S ZTREQ="@" Q - K IBQUIT,IBIFN,IBBILL,IBTXOK,X,Y,DTOUT,DUOUT,DIRUT,DIROUT D ^%ZISC - Q - ; -EN ;ENTRY POINT IF QUEUED, print all rx refills for a bill - S IBY=$G(^DGCR(399,+IBIFN,0)) Q:IBY="" S IBXREF="AIFN"_IBIFN - S (IBQUIT,IBPGN,IBRX)=0,IBHDR="BILL ADDENDUM FOR "_$P($G(^DPT(+$P(IBY,U,2),0)),U,1)_" - "_$P(IBY,U,1) D HDR -RX I '$D(^IBA(362.4,IBXREF)) G PROS - W !!,"PRESCRIPTION REFILLS:",! - K IBRC - D RCITEM^IBCSC5A(IBIFN,"IBRC",3) - S IBRX=0 F S IBRX=$O(^IBA(362.4,IBXREF,IBRX)) Q:IBRX=""!IBQUIT S IBRIFN=0 F S IBRIFN=$O(^IBA(362.4,IBXREF,IBRX,IBRIFN)) Q:'IBRIFN!IBQUIT D - .S IBY=$G(^IBA(362.4,IBRIFN,0)) Q:IBY="" - .S IBYC=$$CHG(IBRIFN,3,.IBRC) - .; - . D ZERO^IBRXUTL(+$P(IBY,U,4)) - . W !,$P(IBY,U,1),?13,$$FMTE^XLFDT(+$P(IBY,U,3),2),?22,$J($S(IBYC:"$"_$FN(IBYC,",",2),1:""),10),?34,$G(^TMP($J,"IBDRUG",+$P(IBY,U,4),.01)) - . K ^TMP($J,"IBDRUG") - . I $P(IBY,U,6)'="" W ?77,"QTY: ",$P(IBY,U,7) - . I $P(IBY,U,7)'="" W ?87,"DAYS SUPPLY: ",$P(IBY,U,6) - . I $P(IBY,U,8)'="" W ?105,"NDC #: ",$P(IBY,U,8) - . S IBLN=IBLN+1 I IBLN>(IOSL-7) D PAUSE,HDR - K IBRC - ; -PROS I '$D(^IBA(362.5,IBXREF)) G END - W !!!,"PROSTHETIC ITEMS:",! - K IBRC - D RCITEM^IBCSC5A(IBIFN,"IBRC",5) - S IBPI=0 F S IBPI=$O(^IBA(362.5,IBXREF,IBPI)) Q:IBPI=""!IBQUIT S IBPIFN=0 F S IBPIFN=$O(^IBA(362.5,IBXREF,IBPI,IBPIFN)) Q:'IBPIFN!IBQUIT D - . S IBY=$G(^IBA(362.5,IBPIFN,0)),IBYC="" Q:IBY="" - . S IBYC=$$CHG(IBPIFN,5,.IBRC) - . W !,$$FMTE^XLFDT(+$P(IBY,U,1),2),?11,$J($S(IBYC:"$"_$FN(IBYC,",",2),1:""),10),?24,$E($P(IBY,U,5),1,55) - . S IBLN=IBLN+1 I IBLN>(IOSL-7) D PAUSE,HDR - D:'IBQUIT PAUSE -END K IBX,IBY,IBPGN,IBRX,IBHDR,IBRIFN,IBLN,IBCDT,IBI,IBXREF,IBPI,IBPIFN,IBRC,IBYC - Q - ; -CHG(IBY,IBTYP,IBRC) ; Return charge for item entry IBY or null if no charge - ; IBRC = the array containing the revenue code items and their units and charges - ; IBTYP = the type of item being priced - N IBZ,IBYC - S IBRC=$S($D(IBRC(IBTYP,IBY)):IBY,1:0),IBYC="" - F IBRC=IBRC,0 Q:'$D(IBRC(IBTYP,IBRC)) S IBZ="" D Q:IBZ'=""!(IBRC=0) - .F S IBZ=$O(IBRC(IBTYP,IBRC,IBZ)) Q:IBZ="" I IBRC(IBTYP,IBRC,IBZ) S $P(IBRC(IBTYP,IBRC,IBZ),U)=IBRC(IBTYP,IBRC,IBZ)-1,IBYC=$P(IBRC(IBTYP,IBRC,IBZ),U,2) K:'IBRC(IBTYP,IBRC,IBZ) IBRC(IBTYP,IBRC,IBZ) Q - Q IBYC - ; -HDR ;print the report header - S IBQUIT=$$STOP Q:IBQUIT S IBPGN=IBPGN+1,IBLN=5 - D NOW^%DTC S Y=$E(%,1,12) D DD^%DT S IBCDT=$P(Y,"@",1)_" "_$P(Y,"@",2) - I IBPGN>1!($E(IOST,1,2)["C-") W @IOF - W IBHDR W:IOM<85 ! W ?(IOM-30),IBCDT,?(IOM-8),"PAGE ",IBPGN,! - ;W !,"RX #",?13,"REFILL DATE",?28,"DRUG",?70,"DAYS SUPPLY",?83,"QTY",?90,"NDC #",! - F IBI=1:1:IOM W "-" - W ! - Q - ; -PAUSE ;pause at end of screen if being displayed on a terminal - Q:$E(IOST,1,2)'["C-" - S DIR(0)="E" D ^DIR K DIR - I $D(DUOUT)!($D(DIRUT)) S IBQUIT=1 - Q - ; -STOP() ;determine if user has requested the queued report to stop - I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ I +$G(IBPGN) W !,"***TASK STOPPED BY USER***" - Q +$G(ZTSTOP) - ; -RXDISP ;displays all rx refills bills - ;N IBX,IBY,IBZ,IBC,X,Y S Y=1,IBC=0,IBX="AIFN" - ;F S IBX=$O(^IBA(362.4,IBX)) Q:IBX="" S IBY=$E(IBX,5,999),IBZ=$G(^DGCR(399,+IBY,0)) I IBZ'="" D Q:'Y - ;. W !,$P(IBZ,U,1),?10,$E($P($G(^DPT(+$P(IBZ,U,2),0)),U,1),1,20),?32,$$DATE(+$P(IBZ,U,3)),?42,$S(+$P(IBZ,U,5)<3:"INPT",1:"OUTPT") - ;. W ?49,$P($G(^DGCR(399.3,+$P(IBZ,U,7),0)),U,4),?59,$E($$EXSET^IBEFUNC(+$P(IBZ,U,13),399,.13),1,7),?68,$E($P($G(^IBE(353,+$P(IBZ,U,19),0)),U,1),1,11) - ;. S IBC=IBC+1 I '(IBC#10) S DIR(0)="E" D ^DIR K DIR - ;Q - ; -DATE(X) Q $E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3) - ; -BILLAD(IFN) ;returns true if bill has either rx refills or prosthetics so addendum should print - N IBX S IBX=0,IFN=+$G(IFN) S:+$O(^IBA(362.4,"AIFN"_IFN,0)) IBX=1 S:+$O(^IBA(362.5,"AIFN"_IFN,0)) IBX=IBX+2 - Q IBX +IBCF4 ;ALB/ARH - PRINT BILL ADDENDUM ;12-JAN-94 + ;;2.0;INTEGRATED BILLING;**52,137,199,309**;21-MAR-94 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; +PRXA ;get bill number then print rx refill addendums for bills + S DIC("S")="I $D(^IBA(362.4,""AIFN""_+Y))!($D(^IBA(362.5,""AIFN""_+Y)))" + N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy lookups + S DIC="^DGCR(399,",DIC(0)="AEMQ" D ^DIC K DIC G:+Y'>0 EXIT S IBBILL=$P(Y,U,2),IBIFN=+Y + ; + I $D(^IBA(364,"ABDT",IBIFN)),+$$TXMT^IBCEF4(IBIFN)=1 D G:'IBTXOK PRXA + .S IBTXOK=0 + .N IBLDT,IBX + .S IBLDT=$O(^IBA(364,"ABDT",IBIFN,""),-1),IBX=$O(^IBA(364,"B",IBIFN,+IBLDT,""),-1) + .I "X"[$P($G(^IBA(364,+IBX,0)),U,3) W !!,*7,"Transmittable Bill can NOT be printed until transmitted" Q + .W !!,"This is a Transmittable Bill that has already been transmitted" + .W !!,"WANT TO PRINT THIS BILL ADDENDUM ANYWAY" S %=2 D YN^DICN + .Q:'(%+1#3) ;-1 or 2 + .S IBTXOK=1 + ; +DEV ;get the device + W !!,"Report requires 132 columns." + S %ZIS="QM",%ZIS("A")="OUTPUT DEVICE: " D ^%ZIS G:POP EXIT + I $D(IO("Q")) S ZTRTN="EN^IBCF4",ZTDESC="BILL ADDENDUM FOR "_IBBILL,ZTSAVE("IB*")="" D ^%ZTLOAD K IO("Q"),ZTSK G EXIT + U IO D EN + ; +EXIT ;clean up and quit + I $D(ZTQUEUED) S ZTREQ="@" Q + K IBQUIT,IBIFN,IBBILL,IBTXOK,X,Y,DTOUT,DUOUT,DIRUT,DIROUT D ^%ZISC + Q + ; +EN ;ENTRY POINT IF QUEUED, print all rx refills for a bill + S IBY=$G(^DGCR(399,+IBIFN,0)) Q:IBY="" S IBXREF="AIFN"_IBIFN + S (IBQUIT,IBPGN,IBRX)=0,IBHDR="BILL ADDENDUM FOR "_$P($G(^DPT(+$P(IBY,U,2),0)),U,1)_" - "_$P(IBY,U,1) D HDR +RX I '$D(^IBA(362.4,IBXREF)) G PROS + W !!,"PRESCRIPTION REFILLS:",! + K IBRC + D RCITEM^IBCSC5A(IBIFN,"IBRC",3) + S IBRX=0 F S IBRX=$O(^IBA(362.4,IBXREF,IBRX)) Q:IBRX=""!IBQUIT S IBRIFN=0 F S IBRIFN=$O(^IBA(362.4,IBXREF,IBRX,IBRIFN)) Q:'IBRIFN!IBQUIT D + .S IBY=$G(^IBA(362.4,IBRIFN,0)) Q:IBY="" + .S IBYC=$$CHG(IBRIFN,3,.IBRC) + .; + . D ZERO^IBRXUTL(+$P(IBY,U,4)) + . W !,$P(IBY,U,1),?13,$$FMTE^XLFDT(+$P(IBY,U,3),2),?22,$J($S(IBYC:"$"_$FN(IBYC,",",2),1:""),10),?34,$G(^TMP($J,"IBDRUG",+$P(IBY,U,4),.01)) + . K ^TMP($J,"IBDRUG") + . I $P(IBY,U,6)'="" W ?77,"QTY: ",$P(IBY,U,7) + . I $P(IBY,U,7)'="" W ?87,"DAYS SUPPLY: ",$P(IBY,U,6) + . I $P(IBY,U,8)'="" W ?105,"NDC #: ",$P(IBY,U,8) + . S IBLN=IBLN+1 I IBLN>(IOSL-7) D PAUSE,HDR + K IBRC + ; +PROS I '$D(^IBA(362.5,IBXREF)) G END + W !!!,"PROSTHETIC ITEMS:",! + K IBRC + D RCITEM^IBCSC5A(IBIFN,"IBRC",5) + S IBPI=0 F S IBPI=$O(^IBA(362.5,IBXREF,IBPI)) Q:IBPI=""!IBQUIT S IBPIFN=0 F S IBPIFN=$O(^IBA(362.5,IBXREF,IBPI,IBPIFN)) Q:'IBPIFN!IBQUIT D + . S IBY=$G(^IBA(362.5,IBPIFN,0)),IBYC="" Q:IBY="" + . S IBYC=$$CHG(IBPIFN,5,.IBRC) + . W !,$$FMTE^XLFDT(+$P(IBY,U,1),2),?11,$J($S(IBYC:"$"_$FN(IBYC,",",2),1:""),10),?24,$P($$PIN^IBCSC5B(+$P(IBY,U,3)),U,2) + . S IBLN=IBLN+1 I IBLN>(IOSL-7) D PAUSE,HDR + D:'IBQUIT PAUSE +END K IBX,IBY,IBPGN,IBRX,IBHDR,IBRIFN,IBLN,IBCDT,IBI,IBXREF,IBPI,IBPIFN,IBRC,IBYC + Q + ; +CHG(IBY,IBTYP,IBRC) ; Return charge for item entry IBY or null if no charge + ; IBRC = the array containing the revenue code items and their units and charges + ; IBTYP = the type of item being priced + N IBZ,IBYC + S IBRC=$S($D(IBRC(IBTYP,IBY)):IBY,1:0),IBYC="" + F IBRC=IBRC,0 Q:'$D(IBRC(IBTYP,IBRC)) S IBZ="" D Q:IBZ'=""!(IBRC=0) + .F S IBZ=$O(IBRC(IBTYP,IBRC,IBZ)) Q:IBZ="" I IBRC(IBTYP,IBRC,IBZ) S $P(IBRC(IBTYP,IBRC,IBZ),U)=IBRC(IBTYP,IBRC,IBZ)-1,IBYC=$P(IBRC(IBTYP,IBRC,IBZ),U,2) K:'IBRC(IBTYP,IBRC,IBZ) IBRC(IBTYP,IBRC,IBZ) Q + Q IBYC + ; +HDR ;print the report header + S IBQUIT=$$STOP Q:IBQUIT S IBPGN=IBPGN+1,IBLN=5 + D NOW^%DTC S Y=$E(%,1,12) D DD^%DT S IBCDT=$P(Y,"@",1)_" "_$P(Y,"@",2) + I IBPGN>1!($E(IOST,1,2)["C-") W @IOF + W IBHDR W:IOM<85 ! W ?(IOM-30),IBCDT,?(IOM-8),"PAGE ",IBPGN,! + ;W !,"RX #",?13,"REFILL DATE",?28,"DRUG",?70,"DAYS SUPPLY",?83,"QTY",?90,"NDC #",! + F IBI=1:1:IOM W "-" + W ! + Q + ; +PAUSE ;pause at end of screen if being displayed on a terminal + Q:$E(IOST,1,2)'["C-" + S DIR(0)="E" D ^DIR K DIR + I $D(DUOUT)!($D(DIRUT)) S IBQUIT=1 + Q + ; +STOP() ;determine if user has requested the queued report to stop + I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ I +$G(IBPGN) W !,"***TASK STOPPED BY USER***" + Q +$G(ZTSTOP) + ; +RXDISP ;displays all rx refills bills + ;N IBX,IBY,IBZ,IBC,X,Y S Y=1,IBC=0,IBX="AIFN" + ;F S IBX=$O(^IBA(362.4,IBX)) Q:IBX="" S IBY=$E(IBX,5,999),IBZ=$G(^DGCR(399,+IBY,0)) I IBZ'="" D Q:'Y + ;. W !,$P(IBZ,U,1),?10,$E($P($G(^DPT(+$P(IBZ,U,2),0)),U,1),1,20),?32,$$DATE(+$P(IBZ,U,3)),?42,$S(+$P(IBZ,U,5)<3:"INPT",1:"OUTPT") + ;. W ?49,$P($G(^DGCR(399.3,+$P(IBZ,U,7),0)),U,4),?59,$E($$EXSET^IBEFUNC(+$P(IBZ,U,13),399,.13),1,7),?68,$E($P($G(^IBE(353,+$P(IBZ,U,19),0)),U,1),1,11) + ;. S IBC=IBC+1 I '(IBC#10) S DIR(0)="E" D ^DIR K DIR + ;Q + ; +DATE(X) Q $E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3) + ; +BILLAD(IFN) ;returns true if bill has either rx refills or prosthetics so addendum should print + N IBX S IBX=0,IFN=+$G(IFN) S:+$O(^IBA(362.4,"AIFN"_IFN,0)) IBX=1 S:+$O(^IBA(362.5,"AIFN"_IFN,0)) IBX=IBX+2 + Q IBX diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNADD.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNADD.m index a69fac6a..82f4d18e 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNADD.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNADD.m @@ -1,75 +1,60 @@ -IBCNADD ;ALB/AAS - ADDRESS RETRIEVAL ENGINE FOR FILE 399 ; 29-AUG-93 - ;;2.0;INTEGRATED BILLING;**52,80,377**;21-MAR-94;Build 23 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -ADD(DA,IBCOB) ; -- Retrieve correct billing address for a bill, mailing address of Bill Payer - ; assumes that new policy field points to valid ins. policy - ; DA = ien to file 399 - ; IBCOB = payer sequence PST or 123 (optional) - ; - N X,Y,I,J,IB01,IB02,IBTYP,DFN,IBCNS,IBCDFN,IBCNT,IBAGAIN,IBFND,IBBILLTY,IBCHRGTY - S IB02="" - S DFN=$P($G(^DGCR(399,DA,0)),"^",2) - S IBBILLTY=$P($G(^DGCR(399,DA,0)),"^",5),IBCHRGTY=$P($$CHGTYPE^IBCU(DA),"^;",1) - ; - S IBCNS=+$P($G(^DGCR(399,DA,"MP")),U,1) - S IBCDFN=$P($G(^DGCR(399,DA,"MP")),U,2) - ; - ; If a specific payer sequence was passed in, get the ins. company and the policy ptr - ; No address returned for Medicare - I $G(IBCOB)'="" D I $$MCRWNR^IBEFUNC(IBCNS) G MAINQ - . S IBCOB=$TR(IBCOB,"PST","123") - . S IBCNS=+$P($G(^DGCR(399,DA,"I"_IBCOB)),U,1) - . S IBCDFN=+$P($G(^DGCR(399,DA,"M")),U,IBCOB+11) - . Q - ; - I 'IBCNS G MAINQ - I IBCDFN S IBCNS=+$G(^DPT(+DFN,.312,+IBCDFN,0)) - I '$D(^DIC(36,+IBCNS,0)) G MAINQ - ; - ; -- if send bill to employer and state is filled in use this - I +$G(^DPT(DFN,.312,+IBCDFN,2)),+$P(^(2),"^",6) S IB02=$P(^(2),"^",2,99) G MAINQ - ; -MAIN ; -- determine address for company for type bill - ; - ; -- get main address - S IB02=$S($D(^DIC(36,+IBCNS,.11)):^(.11),1:"") - S IBCNT=$G(IBCNT)+1 - ; - ; -- if process the same co. more than once you are in an infinite loop - I $D(IBCNT(IBCNS)) G MAINQ ;already processed this company use main add - S IBCNT(IBCNS)="" - ; - ; -- type of charges: Rx charges - if ins company has an rx address use it, otherwise use opt address - I IBCHRGTY=3 S IBTYP="R" D @IBTYP G:$D(IBFND) MAINQ I $D(IBAGAIN) K IBAGAIN G MAIN - ; - ; -- type of bill: inpatient<3, outpatient>2 - S IBTYP=$S(IBBILLTY<3:"I",1:"O") - D @IBTYP I $D(IBAGAIN) K IBAGAIN G MAIN - ; - ; -- return address -MAINQ Q IB02 - ; -I ; -- see if there is an inpatient address - ; -- use if state is there - I $P($G(^DIC(36,+IBCNS,.12)),"^",5) S IB02=$P($G(^(.12)),"^",1,6) - ; - ; -- if other company processes claims start again - I $P($G(^DIC(36,+IBCNS,.12)),"^",7) S IBCNS=$P($G(^DIC(36,+IBCNS,.12)),"^",7) S IBAGAIN=1 - Q - ; -O ; -- see if there is an outpatient address - ; -- use if state is there - I $P($G(^DIC(36,+IBCNS,.16)),"^",5) S IB02=$P($G(^(.16)),"^",1,6) - ; - ; -- if other company processes claims start again - I $P($G(^DIC(36,+IBCNS,.16)),"^",7) S IBCNS=$P($G(^DIC(36,+IBCNS,.16)),"^",7) S IBAGAIN=1 - Q - ; -R ; -- see if there is an Rx address - ; -- use if state is there - I $P($G(^DIC(36,+IBCNS,.18)),"^",5) S IB02=$P($G(^(.18)),"^",1,6) S IBFND=1 - ; - ; -- if other company processes claims start again - I $P($G(^DIC(36,+IBCNS,.18)),"^",7) S IBCNS=$P($G(^DIC(36,+IBCNS,.18)),"^",7) S IBAGAIN=1 K IBFND - Q +IBCNADD ;ALB/AAS - ADDRESS RETRIEVAL ENGINE FOR FILE 399 ; 29-AUG-93 + ;;2.0;INTEGRATED BILLING;**52,80**;21-MAR-94 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; +ADD(DA) ; -- Retrive correct billing address for a bill, mailing address of Bill Payer + ; assumes that new policy field points to valid ins. policy + N X,Y,I,J,IB01,IB02,IBTYP,DFN,IBCNS,IBCDFN,IBCNT,IBAGAIN,IBFND,IBBILLTY,IBCHRGTY + S IB02="" + S DFN=$P($G(^DGCR(399,DA,0)),"^",2) + S IBCNS=+$P($G(^DGCR(399,DA,"MP")),U,1) G:'IBCNS MAINQ + S IBCDFN=$P($G(^DGCR(399,DA,"MP")),"^",2) I IBCDFN S IBCNS=+$G(^DPT(+DFN,.312,+IBCDFN,0)) + S IBBILLTY=$P($G(^DGCR(399,DA,0)),"^",5),IBCHRGTY=$P($$CHGTYPE^IBCU(DA),"^;",1) + I '$D(^DIC(36,+IBCNS,0)) G MAINQ + ; + ; -- if send bill to employer and state is filled in use this + I +$G(^DPT(DFN,.312,+IBCDFN,2)),+$P(^(2),"^",6) S IB02=$P(^(2),"^",2,99) G MAINQ + ; +MAIN ; -- determine address for company for type bill + ; + ; -- get main address + S IB02=$S($D(^DIC(36,+IBCNS,.11)):^(.11),1:"") + S IBCNT=$G(IBCNT)+1 + ; + ; -- if process the same co. more than once you are in an infinite loop + I $D(IBCNT(IBCNS)) G MAINQ ;already processed this company use main add + S IBCNT(IBCNS)="" + ; + ; -- type of charges: Rx charges - if ins company has an rx address use it, otherwise use opt address + I IBCHRGTY=3 S IBTYP="R" D @IBTYP G:$D(IBFND) MAINQ I $D(IBAGAIN) K IBAGAIN G MAIN + ; + ; -- type of bill: inpatient<3, outpatient>2 + S IBTYP=$S(IBBILLTY<3:"I",1:"O") + D @IBTYP I $D(IBAGAIN) K IBAGAIN G MAIN + ; + ; -- return address +MAINQ Q IB02 + ; +I ; -- see if there is an inpatient address + ; -- use if state is there + I $P($G(^DIC(36,+IBCNS,.12)),"^",5) S IB02=$P($G(^(.12)),"^",1,6) + ; + ; -- if other company processes claims start again + I $P($G(^DIC(36,+IBCNS,.12)),"^",7) S IBCNS=$P($G(^DIC(36,+IBCNS,.12)),"^",7) S IBAGAIN=1 + Q + ; +O ; -- see if there is an outpatient address + ; -- use if state is there + I $P($G(^DIC(36,+IBCNS,.16)),"^",5) S IB02=$P($G(^(.16)),"^",1,6) + ; + ; -- if other company processes claims start again + I $P($G(^DIC(36,+IBCNS,.16)),"^",7) S IBCNS=$P($G(^DIC(36,+IBCNS,.16)),"^",7) S IBAGAIN=1 + Q + ; +R ; -- see if there is an Rx address + ; -- use if state is there + I $P($G(^DIC(36,+IBCNS,.18)),"^",5) S IB02=$P($G(^(.18)),"^",1,6) S IBFND=1 + ; + ; -- if other company processes claims start again + I $P($G(^DIC(36,+IBCNS,.18)),"^",7) S IBCNS=$P($G(^DIC(36,+IBCNS,.18)),"^",7) S IBAGAIN=1 K IBFND + Q diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNBCD.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNBCD.m index 077587a3..08471fcc 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNBCD.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNBCD.m @@ -1,131 +1,130 @@ -IBCNBCD ;ALB/ARH-Ins Buffer: display/compare buffer and existing ins ;1 Jun 97 - ;;2.0;INTEGRATED BILLING;**82,251,361,371**;21-MAR-94;Build 57 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -INS(IBBUFDA,IBINSDA) ; display a buffer entry's insurance company fields and - ; an existing insurance company's fields for comparison - N IBEXTDA,IBFLD1,IBFLD2,X I '$G(IBBUFDA) Q - ; - S IBEXTDA=$G(IBINSDA)_"," - ; - I +$P($G(^DIC(36,+IBEXTDA,0)),U,5) W !,?10,"Selected Insurance Company "_$$GET1^DIQ(36,IBEXTDA,.01)_" is Inactive!",! - ; - W ! D WRTFLD(" Insurance Data: Buffer Data Selected Insurance Company ",0,80,"BU") - S IBFLD1=$$GET1^DIQ(355.33,IBBUFDA,20.01),IBFLD2=$S(+IBEXTDA:$$GET1^DIQ(36,IBEXTDA,.01),1:"") D WRTLN("Company Name:",IBFLD1,IBFLD2,"","","") - S IBFLD1=$$GET1^DIQ(355.33,IBBUFDA,20.05),IBFLD2=$S(+IBEXTDA:$$GET1^DIQ(36,IBEXTDA,1),1:"") D WRTLN("Reimburse?:",IBFLD1,IBFLD2,"","","U") - ; - D DISPLAY(20.02,36,.131,"Phone Number:") - D DISPLAY(20.03,36,.132,"Billing Phone:") - D DISPLAY(20.04,36,.133,"Pre-Cert Phone:") - D DISPLAY(21.01,36,.111,"Street [Line 1]:") - D DISPLAY(21.02,36,.112,"Street [Line 2]:") - D DISPLAY(21.03,36,.113,"Street [Line 3]:") - D DISPLAY(21.04,36,.114,"City:") - D DISPLAY(21.05,36,.115,"State:") - D DISPLAY(21.06,36,.116,"Zip Code:") - ; - S IBFLD1="(bold=accepted on Merge)",IBFLD2="(bold=replaced on Overwrite)" D WRTLN("",IBFLD1,IBFLD2,"","","U") - Q - ; -GRP(IBBUFDA,IBGRPDA) ; display a buffer entry's group insurance fields and an existing group/plan's fields for comparison - N IBEXTDA,IBFLD1,IBFLD2,X I '$G(IBBUFDA) Q - ; - S IBEXTDA=$G(IBGRPDA)_"," - ; - I +$P($G(^IBA(355.3,+IBEXTDA,0)),U,11) W !,?23,"Selected Group/Plan is Inactive!",! - ; - W ! D WRTFLD(" Group/Plan Data: Buffer Data Selected Group/Plan ",0,80,"BU") - S IBFLD1=$$GET1^DIQ(355.33,IBBUFDA,20.01),IBFLD2=$S(+IBEXTDA:$$GET1^DIQ(355.3,IBEXTDA,.01),1:"") D WRTLN("Company Name:",IBFLD1,IBFLD2,"","","") - S IBFLD1=$$GET1^DIQ(355.33,IBBUFDA,40.01),IBFLD2=$S(+IBEXTDA:$$GET1^DIQ(355.3,IBEXTDA,.02),1:"") D WRTLN("Is Group Plan?:",IBFLD1,IBFLD2,"","","U") - ; - D DISPLAY(40.02,355.3,.03,"Group Name:") - D DISPLAY(40.03,355.3,.04,"Group Number:") - D DISPLAY(40.1,355.3,6.02,"BIN:") ;;Daou/EEN - adding BIN and PCN - D DISPLAY(40.11,355.3,6.03,"PCN:") - D DISPLAY(40.04,355.3,.05,"Require UR:") - D DISPLAY(40.05,355.3,.06,"Require Pre-Cert:") - D DISPLAY(40.06,355.3,.12,"Require Amb Cert:") - D DISPLAY(40.07,355.3,.07,"Exclude Pre-Cond:") - D DISPLAY(40.08,355.3,.08,"Benefits Assign:") - D DISPLAY(40.09,355.3,.09,"Type of Plan:") - ; - S IBFLD1="(bold=accepted on merge)",IBFLD2="(bold=replaced on overwrite)" D WRTLN("",IBFLD1,IBFLD2,"","","U") - Q - ; -POLICY(IBBUFDA,IBPOLDA) ; display a buffer entry's patient policy fields and an existing patient policy's fields for comparison - N DFN,IBEXTDA,IBFLD1,IBFLD2,X,Y,DIR,DIRUT I '$G(IBBUFDA) Q - S DFN=+$G(^IBA(355.33,IBBUFDA,60)) - ; - S IBEXTDA=$G(IBPOLDA)_","_DFN_"," - ; - W ! D WRTFLD(" Policy Data: Buffer Data Selected Policy ",0,80,"BU") - S IBFLD1=$$GET1^DIQ(355.33,IBBUFDA,20.01),IBFLD2=$S(+IBEXTDA:$$GET1^DIQ(2.312,IBEXTDA,.01),1:"") D WRTLN("Company Name:",IBFLD1,IBFLD2,"","","") - S IBFLD1=$$GET1^DIQ(355.33,IBBUFDA,40.03),IBFLD2=$S(+IBEXTDA:$$GET1^DIQ(2.312,IBEXTDA,21),1:"") D WRTLN("Group #:",IBFLD1,IBFLD2,"","","") - S IBFLD1=$$GET1^DIQ(355.33,IBBUFDA,60.01),IBFLD2=$S(+IBEXTDA:$$GET1^DIQ(2,DFN,.01),1:"") D WRTLN("Patient Name:",IBFLD1,IBFLD2,"","","") - S IBFLD1=$P($$GET1^DIQ(355.33,IBBUFDA,.1),"@"),IBFLD2=$S(+IBEXTDA:$P($$GET1^DIQ(2.312,IBEXTDA,1.03),"@"),1:"") D WRTLN("Last Verified:",IBFLD1,IBFLD2,"","","U") - ; - D DISPLAY(60.02,2.312,8,"Effective Date:") - D DISPLAY(60.03,2.312,3,"Expiration Date:") - D DISPLAY(60.04,2.312,1,"Subscriber Id:") - D DISPLAY(60.05,2.312,6,"Whose Insurance:") - D DISPLAY(60.06,2.312,16,"Relationship:") - D DISPLAY(60.07,2.312,17,"Name of Insured:") - D DISPLAY(60.08,2.312,3.01,"Insured's DOB:") - D DISPLAY(60.09,2.312,3.05,"Insured's SSN:") - D DISPLAY(60.13,2.312,3.12,"Insured's SEX:") - D DISPLAY(60.1,2.312,4.01,"Primary Provider:") - D DISPLAY(60.11,2.312,4.02,"Provider Phone:") - D DISPLAY(60.12,2.312,.2,"Coor of Benefits:") - D DISPLAY(61.01,2.312,2.1,"Emp Sponsored?:") - D DISPLAY(62.01,2.312,5.01,"Patient Id:") - ; - I +$G(^IBA(355.33,IBBUFDA,61))!($$GET1^DIQ(2.312,IBEXTDA,2.1)="YES") D ESGHP - ; - S IBFLD1="(bold=accepted on merge)",IBFLD2="(bold=replaced on overwrite)" D WRTLN("",IBFLD1,IBFLD2,"","","U") - ; - Q - ; -ESGHP ; display employee sponsored group health plan - W ! S DIR(0)="E",DIR("A")="Enter RETURN to continue" D ^DIR W ! Q:$D(DIRUT) - ; - D DISPLAY(61.02,2.312,2.015,"Employer Name:") - D DISPLAY(61.03,2.312,2.11,"Emp Status:") - D DISPLAY(61.04,2.312,2.12,"Retirement Date:") - D DISPLAY(61.05,2.312,2.01,"Send to Employer:") - D DISPLAY(61.06,2.312,2.02,"Emp Street Ln 1:") - D DISPLAY(61.07,2.312,2.03,"Emp Street Ln 2:") - D DISPLAY(61.08,2.312,2.04,"Emp Street Ln 3:") - D DISPLAY(61.09,2.312,2.05,"Emp City:") - D DISPLAY(61.1,2.312,2.06,"Emp State:") - D DISPLAY(61.11,2.312,2.07,"Emp Zip Code:") - D DISPLAY(61.12,2.312,2.08,"Emp Phone:") - ; - Q - ; -DISPLAY(BFLD,IFILE,IFLD,LABEL) ; extract, compare, write the two corresponding fields; one from buffer, one from ins files - N BUFDATA,EXTDATA,IBOVER,IBMERG S EXTDATA="" - S BUFDATA=$$GET1^DIQ(355.33,IBBUFDA,BFLD) - I +IBEXTDA S EXTDATA=$$GET1^DIQ(IFILE,IBEXTDA,IFLD) - ; - S IBOVER=$S(BUFDATA'=""&(BUFDATA'=EXTDATA):"B",1:""),IBMERG=$S(EXTDATA="":"B",1:"") - ; - D WRTLN(LABEL,BUFDATA,EXTDATA,IBOVER,IBMERG) - Q - ; -WRTLN(LABEL,FLD1,FLD2,OVER,MERG,ATTR) ; write a line of formatted data with label and two fields - S ATTR=$G(ATTR),OVER=ATTR_$G(OVER),MERG=ATTR_$G(MERG) - S LABEL=$J(LABEL,17)_" ",FLD1=FLD1_$J("",29-$L(FLD1)),FLD2=FLD2_$J("",29-$L(FLD2)) - W ! - D WRTFLD(LABEL,0,19,ATTR),WRTFLD(FLD1,19,29,MERG) - D WRTFLD(" | ",48,3,ATTR),WRTFLD(FLD2,51,29,OVER) - Q - ; -WRTFLD(STRING,COL,WD,ATTR) ; write an individual field with display attributes - N ATTRB,ATTRE,DX,DY,X,Y - S ATTRB="",ATTRB=$S(ATTR["B":$G(IOINHI),1:"")_$S(ATTR["U":$G(IOUON),1:"") - S ATTRE="",ATTRE=$S(ATTR["B":$G(IOINORM),1:"")_$S(ATTR["U":$G(IOUOFF),1:"") - ; - S DX=COL,DY=$Y X IOXY - W ATTRB,$E(STRING,1,WD),ATTRE - S DX=(COL+WD),DY=$Y X IOXY - Q +IBCNBCD ;ALB/ARH-Ins Buffer: display/compare buffer and existing ins ;1 Jun 97 + ;;2.0;INTEGRATED BILLING;**82,251,361**;21-MAR-94;Build 9 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; +INS(IBBUFDA,IBINSDA) ; display a buffer entry's insurance company fields and + ; an existing insurance company's fields for comparison + N IBEXTDA,IBFLD1,IBFLD2,X I '$G(IBBUFDA) Q + ; + S IBEXTDA=$G(IBINSDA)_"," + ; + I +$P($G(^DIC(36,+IBEXTDA,0)),U,5) W !,?10,"Selected Insurance Company "_$$GET1^DIQ(36,IBEXTDA,.01)_" is Inactive!",! + ; + W ! D WRTFLD(" Insurance Data: Buffer Data Selected Insurance Company ",0,80,"BU") + S IBFLD1=$$GET1^DIQ(355.33,IBBUFDA,20.01),IBFLD2=$S(+IBEXTDA:$$GET1^DIQ(36,IBEXTDA,.01),1:"") D WRTLN("Company Name:",IBFLD1,IBFLD2,"","","") + S IBFLD1=$$GET1^DIQ(355.33,IBBUFDA,20.05),IBFLD2=$S(+IBEXTDA:$$GET1^DIQ(36,IBEXTDA,1),1:"") D WRTLN("Reimburse?:",IBFLD1,IBFLD2,"","","U") + ; + D DISPLAY(20.02,36,.131,"Phone Number:") + D DISPLAY(20.03,36,.132,"Billing Phone:") + D DISPLAY(20.04,36,.133,"Pre-Cert Phone:") + D DISPLAY(21.01,36,.111,"Street [Line 1]:") + D DISPLAY(21.02,36,.112,"Street [Line 2]:") + D DISPLAY(21.03,36,.113,"Street [Line 3]:") + D DISPLAY(21.04,36,.114,"City:") + D DISPLAY(21.05,36,.115,"State:") + D DISPLAY(21.06,36,.116,"Zip Code:") + ; + S IBFLD1="(bold=accepted on Merge)",IBFLD2="(bold=replaced on Overwrite)" D WRTLN("",IBFLD1,IBFLD2,"","","U") + Q + ; +GRP(IBBUFDA,IBGRPDA) ; display a buffer entry's group insurance fields and an existing group/plan's fields for comparison + N IBEXTDA,IBFLD1,IBFLD2,X I '$G(IBBUFDA) Q + ; + S IBEXTDA=$G(IBGRPDA)_"," + ; + I +$P($G(^IBA(355.3,+IBEXTDA,0)),U,11) W !,?23,"Selected Group/Plan is Inactive!",! + ; + W ! D WRTFLD(" Group/Plan Data: Buffer Data Selected Group/Plan ",0,80,"BU") + S IBFLD1=$$GET1^DIQ(355.33,IBBUFDA,20.01),IBFLD2=$S(+IBEXTDA:$$GET1^DIQ(355.3,IBEXTDA,.01),1:"") D WRTLN("Company Name:",IBFLD1,IBFLD2,"","","") + S IBFLD1=$$GET1^DIQ(355.33,IBBUFDA,40.01),IBFLD2=$S(+IBEXTDA:$$GET1^DIQ(355.3,IBEXTDA,.02),1:"") D WRTLN("Is Group Plan?:",IBFLD1,IBFLD2,"","","U") + ; + D DISPLAY(40.02,355.3,.03,"Group Name:") + D DISPLAY(40.03,355.3,.04,"Group Number:") + D DISPLAY(40.1,355.3,6.02,"BIN:") ;;Daou/EEN - adding BIN and PCN + D DISPLAY(40.11,355.3,6.03,"PCN:") + D DISPLAY(40.04,355.3,.05,"Require UR:") + D DISPLAY(40.05,355.3,.06,"Require Pre-Cert:") + D DISPLAY(40.06,355.3,.12,"Require Amb Cert:") + D DISPLAY(40.07,355.3,.07,"Exclude Pre-Cond:") + D DISPLAY(40.08,355.3,.08,"Benefits Assign:") + D DISPLAY(40.09,355.3,.09,"Type of Plan:") + ; + S IBFLD1="(bold=accepted on merge)",IBFLD2="(bold=replaced on overwrite)" D WRTLN("",IBFLD1,IBFLD2,"","","U") + Q + ; +POLICY(IBBUFDA,IBPOLDA) ; display a buffer entry's patient policy fields and an existing patient policy's fields for comparison + N DFN,IBEXTDA,IBFLD1,IBFLD2,X,Y,DIR,DIRUT I '$G(IBBUFDA) Q + S DFN=+$G(^IBA(355.33,IBBUFDA,60)) + ; + S IBEXTDA=$G(IBPOLDA)_","_DFN_"," + ; + W ! D WRTFLD(" Policy Data: Buffer Data Selected Policy ",0,80,"BU") + S IBFLD1=$$GET1^DIQ(355.33,IBBUFDA,20.01),IBFLD2=$S(+IBEXTDA:$$GET1^DIQ(2.312,IBEXTDA,.01),1:"") D WRTLN("Company Name:",IBFLD1,IBFLD2,"","","") + S IBFLD1=$$GET1^DIQ(355.33,IBBUFDA,40.03),IBFLD2=$S(+IBEXTDA:$$GET1^DIQ(2.312,IBEXTDA,21),1:"") D WRTLN("Group #:",IBFLD1,IBFLD2,"","","") + S IBFLD1=$$GET1^DIQ(355.33,IBBUFDA,60.01),IBFLD2=$S(+IBEXTDA:$$GET1^DIQ(2,DFN,.01),1:"") D WRTLN("Patient Name:",IBFLD1,IBFLD2,"","","") + S IBFLD1=$P($$GET1^DIQ(355.33,IBBUFDA,.1),"@"),IBFLD2=$S(+IBEXTDA:$P($$GET1^DIQ(2.312,IBEXTDA,1.03),"@"),1:"") D WRTLN("Last Verified:",IBFLD1,IBFLD2,"","","U") + ; + D DISPLAY(60.02,2.312,8,"Effective Date:") + D DISPLAY(60.03,2.312,3,"Expiration Date:") + D DISPLAY(60.04,2.312,1,"Subscriber Id:") + D DISPLAY(60.05,2.312,6,"Whose Insurance:") + D DISPLAY(60.06,2.312,16,"Relationship:") + D DISPLAY(60.07,2.312,17,"Name of Insured:") + D DISPLAY(60.08,2.312,3.01,"Insured's DOB:") + D DISPLAY(60.09,2.312,3.05,"Insured's SSN:") + D DISPLAY(60.13,2.312,3.12,"Insured's SEX:") + D DISPLAY(60.1,2.312,4.01,"Primary Provider:") + D DISPLAY(60.11,2.312,4.02,"Provider Phone:") + D DISPLAY(60.12,2.312,.2,"Coor of Benefits:") + D DISPLAY(61.01,2.312,2.1,"Emp Sponsored?:") + ; + I +$G(^IBA(355.33,IBBUFDA,61))!($$GET1^DIQ(2.312,IBEXTDA,2.1)="YES") D ESGHP + ; + S IBFLD1="(bold=accepted on merge)",IBFLD2="(bold=replaced on overwrite)" D WRTLN("",IBFLD1,IBFLD2,"","","U") + ; + Q + ; +ESGHP ; display employee sponsored group health plan + W ! S DIR(0)="E",DIR("A")="Enter RETURN to continue" D ^DIR W ! Q:$D(DIRUT) + ; + D DISPLAY(61.02,2.312,2.015,"Employer Name:") + D DISPLAY(61.03,2.312,2.11,"Emp Status:") + D DISPLAY(61.04,2.312,2.12,"Retirement Date:") + D DISPLAY(61.05,2.312,2.01,"Send to Employer:") + D DISPLAY(61.06,2.312,2.02,"Emp Street Ln 1:") + D DISPLAY(61.07,2.312,2.03,"Emp Street Ln 2:") + D DISPLAY(61.08,2.312,2.04,"Emp Street Ln 3:") + D DISPLAY(61.09,2.312,2.05,"Emp City:") + D DISPLAY(61.1,2.312,2.06,"Emp State:") + D DISPLAY(61.11,2.312,2.07,"Emp Zip Code:") + D DISPLAY(61.12,2.312,2.08,"Emp Phone:") + ; + Q + ; +DISPLAY(BFLD,IFILE,IFLD,LABEL) ; extract, compare, write the two corresponding fields; one from buffer, one from ins files + N BUFDATA,EXTDATA,IBOVER,IBMERG S EXTDATA="" + S BUFDATA=$$GET1^DIQ(355.33,IBBUFDA,BFLD) + I +IBEXTDA S EXTDATA=$$GET1^DIQ(IFILE,IBEXTDA,IFLD) + ; + S IBOVER=$S(BUFDATA'=""&(BUFDATA'=EXTDATA):"B",1:""),IBMERG=$S(EXTDATA="":"B",1:"") + ; + D WRTLN(LABEL,BUFDATA,EXTDATA,IBOVER,IBMERG) + Q + ; +WRTLN(LABEL,FLD1,FLD2,OVER,MERG,ATTR) ; write a line of formatted data with label and two fields + S ATTR=$G(ATTR),OVER=ATTR_$G(OVER),MERG=ATTR_$G(MERG) + S LABEL=$J(LABEL,17)_" ",FLD1=FLD1_$J("",29-$L(FLD1)),FLD2=FLD2_$J("",29-$L(FLD2)) + W ! + D WRTFLD(LABEL,0,19,ATTR),WRTFLD(FLD1,19,29,MERG) + D WRTFLD(" | ",48,3,ATTR),WRTFLD(FLD2,51,29,OVER) + Q + ; +WRTFLD(STRING,COL,WD,ATTR) ; write an individual field with display attributes + N ATTRB,ATTRE,DX,DY,X,Y + S ATTRB="",ATTRB=$S(ATTR["B":$G(IOINHI),1:"")_$S(ATTR["U":$G(IOUON),1:"") + S ATTRE="",ATTRE=$S(ATTR["B":$G(IOINORM),1:"")_$S(ATTR["U":$G(IOUOFF),1:"") + ; + S DX=COL,DY=$Y X IOXY + W ATTRB,$E(STRING,1,WD),ATTRE + S DX=(COL+WD),DY=$Y X IOXY + Q diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNBEE.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNBEE.m index 8a570761..ff69c6a2 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNBEE.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNBEE.m @@ -1,169 +1,169 @@ -IBCNBEE ;ALB/ARH-Ins Buffer: add/edit existing entries in buffer ;1 Jun 97 - ;;2.0;INTEGRATED BILLING;**82,184,252,251,356,361,371,377**;21-MAR-94;Build 23 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -ADD(IBSOURCE) ; add a new buffer file entry (#355.33), sets only status (0) node data - N IBARR,IBERR,IBIFN,IBX I '$G(IBSOURCE) S IBSOURCE=1 - ; - S IBARR(355.33,"+1,",.01)="NOW",IBARR(355.33,"+1,",.03)=IBSOURCE - D UPDATE^DIE("E","IBARR","IBIFN","IBERR") - S IBX=+$G(IBIFN(1)) I $D(IBERR) S $P(IBX,U,2)=$G(IBERR("DIERR",1,"TEXT",1)) - Q IBX - ; -STATUS(IBBUFDA,STATUS,NC,NG,NP) ; edit the status node - ; - N IBX,IBARR,IBIFN Q:'$G(IBBUFDA) S IBIFN=IBBUFDA_"," - D CHK^DIE(355.33,.04,"",$G(STATUS),.IBX) Q:IBX="^" - ; - S IBARR(355.33,IBIFN,.04)=STATUS I STATUS="R" S (NC,NG,NP)=0 - S IBARR(355.33,IBIFN,.07)=+$G(NC),IBARR(355.33,IBIFN,.08)=+$G(NG),IBARR(355.33,IBIFN,.09)=+$G(NP) - D FILE^DIE("E","IBARR") - Q - ; -INS(IBBUFDA,FLDS) ; edit the insurance company portion of a buffer file entry - ; - N DIC,DIE,DA,DR,X,Y,IBCNEXT1 - I $P($G(^IBA(355.33,+$G(IBBUFDA),0)),U,4)'="E" Q - I $G(FLDS)="" S FLDS="MR" - ; - ; ESG - 6/18/02 - SDD 5.1.4 - Usage of Auto Match when editing - ; - the insurance company name in the buffer. Also added an - ; - input transform (see below) to clean up the data coming in. - ; - fetch the current buffer ins co name - ; - I FLDS="MR" S IBCNEXT1=$P($G(^IBA(355.33,IBBUFDA,20)),U,1) - ; - S DR=$P($T(@(FLDS_"INS")+1),";;",2,9999) Q:DR="" - ; - I FLDS="MR" Q:$$INSNAME(IBBUFDA)<0 S DR=$P($T(@(FLDS_"INS")+1),";;",2,9999),DR=$P(DR,";",2,99999) - ; - S DIE="^IBA(355.33,",DA=IBBUFDA D ^DIE K DIE,DA,DR - Q - ; -GRP(IBBUFDA,FLDS) ; edit the group/plan portion of the buffer file entry - ; - N DIC,DIE,DA,DR,X,Y I $P($G(^IBA(355.33,+$G(IBBUFDA),0)),U,4)'="E" Q - I $G(FLDS)="" S FLDS="MR" - ; - S DR=$P($T(@(FLDS_"GRP")+1),";;",2,9999) Q:DR="" - S DIE="^IBA(355.33,",DA=IBBUFDA D ^DIE K DIE,DA,DR - Q - ; -POLICY(IBBUFDA,FLDS) ; edit the patient policy portion of the buffer file entry - ; - N DIC,DIE,DA,DR,X,Y,IBZZ I $P($G(^IBA(355.33,+$G(IBBUFDA),0)),U,4)'="E" Q - I $G(FLDS)="" S FLDS="MR" - ; - S DR=$P($T(@(FLDS_"POL")+1),";;",2,9999) Q:DR="" - S DIE="^IBA(355.33,",DA=IBBUFDA - S DIE("NO^")="BACKOUTOK" D ^DIE K DIE,DA,DR Q:$D(Y) - ; - I FLDS="MR" D ESGHP(IBBUFDA) - Q - ; -ESGHP(IBBUFDA) ; sponsoring employer information - N DIR,DIRUT,DUOUT,DTOUT,VAOA,VAERR,VA,DFN,IB60,IBE,IBEMPST,IBREL - ; - ; if insured is patient or spouse, ask if insured's current employer is the plan's sponsoring employer, if yes auto stuff it - I +$G(^IBA(355.33,IBBUFDA,61)) W ! S IB60=$G(^IBA(355.33,IBBUFDA,60)) D Q:$D(DIRUT) - . ; sponsoring employer is current employer? - . S DFN=+IB60,IBREL=$P(IB60,U,6),VAOA("A")=$S(IBREL="01":5,IBREL="02":6,1:"") I 'DFN!(VAOA("A")="") Q - . D OAD^VADPT I $G(VAOA(9))="" Q - . S DIR("?")="Enter Yes if this plan is sponsored by the "_$S(IBREL="01":"patient's",1:"spouse's")_" current employer." - . S DIR("?",1)="Entering Yes will result in the "_$S(IBREL="01":"patient's",1:"spouse's")_" current employer data being",DIR("?",2)="added to the policy as the Sponsoring Employer data.",DIR("?",3)="" - . S DIR("A")="Current Employer "_VAOA(9)_" Sponsors this Plan",DIR("B")="No",DIR(0)="Y" D ^DIR W ! I Y'=1 Q - . ; - . D DELEMP(IBBUFDA) ; delete any data already contained in these fields - . ; - . ; if the insured's current employer sponsors the plan then stuff that employer's address into the buffer - . S IBE=$S(IBREL="01":.311,1:.25),IBEMPST=$P($G(^DPT(DFN,IBE)),U,15) - . S DR="61.02///"_VAOA(9)_";61.03///"_IBEMPST_";61.06///"_$E(VAOA(1),1,30)_";61.07///"_$E(VAOA(2),1,30) - . S DR=DR_";61.08///"_$E(VAOA(3),1,30)_";61.09///"_$E(VAOA(4),1,20)_";61.1////"_$P(VAOA(5),U,1) - . S DR=DR_";61.11////"_$P(VAOA(11),U,1)_";61.12///"_$E(VAOA(8),1,15) - . S DIE="^IBA(355.33,",DA=IBBUFDA D ^DIE K DIE,DA,DR - ; - ; if employer sponsored plan, edit buffer entry's sponsoring employer info - I +$G(^IBA(355.33,IBBUFDA,61)) S DR="61.02:61.12",DIE="^IBA(355.33,",DA=IBBUFDA D ^DIE K DIE,DA,DR - ; - ; if not employer sponsored plan, delete any existing sponsoring employer data - I $D(^IBA(355.33,IBBUFDA,61)),'$G(^IBA(355.33,IBBUFDA,61)) D DELEMP(IBBUFDA) - Q - ; -DELEMP(IBBUFDA) ; delete sponsoring employer data - N DIC,DIE,DA,DR,X,Y Q:'$D(^IBA(355.33,+$G(IBBUFDA),61)) - S DR="61.02///@;61.03///@;61.04///@;61.05///@;61.06///@;61.07///@;61.08///@;61.09///@;61.10///@;61.11///@;61.12///@" - S DIE="^IBA(355.33,",DA=IBBUFDA D ^DIE K DIE,DA,DR - Q - ; -INSHELP ; - W !!,"------------------------ INSURANCE COMPANY INFORMATION -------------------------",! - Q -GRPHELP ; - W !!,"---------------------------- GROUP/PLAN INFORMATION ----------------------------" - W !," The following data defines a specific Group or Plan provided by an Insurance " - W !," Company. This may be either a group plan with many potential members or an " - W !," individual plan with a single member.",! - Q -POLHELP ; - W !!,"---------------------- POLICY AND SUBSCRIBER INFORMATION -----------------------" - W !," The following data defines the subscriber specific policy information for a " - W !," particular Insurance Plan. The subscriber, the insured, and the policy holder " - W !," all refer to the person who is a member of the plan and therefore holds the " - W !," policy. The patient must be covered under the plan but may not be the policy" - W !," holder.",! - Q - ; -INSNAME(IBBUFDA) ; Reset insurance company name - N DR,DIE,DA,Y,X,IBX,IBNEW,IBNAME - S IBX=-1 - S DR=20.01,DIE="^IBA(355.33,",DA=IBBUFDA - D ^DIE - I '$D(Y) S IBNEW=$$CHECK(IBBUFDA) - I +$G(IBNEW)'<0,$G(IBNEW)'=0,$D(IBNEW) S DR=$P(DR,";",1)_"////"_IBNEW S DIE="^IBA(355.33,",DA=IBBUFDA D ^DIE K DIE,DA,DR I '$D(Y) S IBX=0 - ; BHS - 10/15/03 - If user entered a caret during $$CHECK still set - ; return value to 0 so the user can edit the other - ; INS fields - I $G(IBNEW)=0!($G(IBNEW)=-1) S IBX=0 - Q IBX - ; -CHECK(IBBUFDA) ; Select Insurance Company Name and Automatch - ; Buffer file (#355.33), field# 20.01. - ; ESG - 6/18/02 - SDD 5.1.4 - Usage of Auto Match when editing the - ; insurance company name. Also, display the insurance company - ; name lookup/lister and the Auto Match lookup/lister. - ; - NEW IBNEW,IBNAME,AMLIST - ; - S IBNEW=0,IBNAME=$P($G(^IBA(355.33,$G(IBBUFDA),20)),U,1) - I IBNAME="" G CHECKQ - ; - ; Perform an insurance company lookup/lister - ; BHS - 10/15/03 - Removed quits when user enters a caret to quit the - ; the ins lister or Auto Match lister - S IBNEW=$$DICINS^IBCNBU1(IBNAME,1,10) - I IBNEW=0!(IBNEW<0) D - . I '$$AMLOOK^IBCNEUT1(IBNAME,1,.AMLIST) Q - . S IBNEW=$$AMSEL^IBCNEUT1(.AMLIST) - ; - ; user chose a valid insurance company - possible Auto Match add - I IBNEW'<0,IBNEW'=0 D AMADD^IBCNEUT6(X,IBCNEXT1) - ; -CHECKQ Q IBNEW - ; -MRINS ; Insurance Company fields asked of MCCR users in the Buffer Process options (all buffer ins fields 20.01-21.06) - ;;20.01;20.05;20.02:20.04;21.01;I X="" S Y="@111";21.02;I X="" S Y="@111";21.03;@111;21.04:21.06 - ; -MRGRP ; Group/Plan fields asked of MCCR users in the Buffer Process options (all buffer grp fields 40.01-40.09) ;;Daou/EEN adding BIN and PCN (40.1,40.11) - ;;40.01:40.03;40.1;40.11;40.09;40.04:40.08 - ; -MRPOL ; Patient Policy fields asked of MCCR users in the Buffer Process options (all buffer policy fields except ESGHP,60.05,60.06 60.02-61.01 - ;;60.02;60.03;60.14PT. RELATIONSHIP TO INSURED;S IBZZ=X;60.04T;I IBZZ'="18" S Y="@111";60.07///1;60.08///@;60.09///@;62.01///@;S Y="@112";@111;60.07;60.08;60.13;62.01T;@112;60.1:60.12;.03;61.01 - ; -OTINS ; Insurance Company fields asked of non-MCCR users entering buffer data from options outside IB (20.01-20.04,21.01-21.06) - ;;20.01:20.04;21.01;I X="" S Y="@111";21.02;I X="" S Y="@111";21.03;@111;21.04:21.06 - ; -OTGRP ; Group/Plan fields asked of non-MCCR users entering buffer data from options outside IB (40.02,40.03,40.09) ;;Daou/EEN-adding BIN & PCN (40.1,40.11) - ;;40.02;40.03;40.1;40.11;40.09 - ; -OTPOL ; Patient Policy fields asked of non-MCCR users entering buffer data from options outside IB (60.02-60.08) - ;;60.02;60.03;60.14PT. RELATIONSHIP TO INSURED;S IBZZ=X;60.04T;I IBZZ'="18" S Y="@111";60.07///1;60.08///@;60.09///@;62.01///@;S Y="@112";@111;60.07;60.08;60.13;62.01T;@112 +IBCNBEE ;ALB/ARH-Ins Buffer: add/edit existing entries in buffer ;1 Jun 97 + ;;2.0;INTEGRATED BILLING;**82,184,252,251,356,361**;21-MAR-94;Build 9 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; +ADD(IBSOURCE) ; add a new buffer file entry (#355.33), sets only status (0) node data + N IBARR,IBERR,IBIFN,IBX I '$G(IBSOURCE) S IBSOURCE=1 + ; + S IBARR(355.33,"+1,",.01)="NOW",IBARR(355.33,"+1,",.03)=IBSOURCE + D UPDATE^DIE("E","IBARR","IBIFN","IBERR") + S IBX=+$G(IBIFN(1)) I $D(IBERR) S $P(IBX,U,2)=$G(IBERR("DIERR",1,"TEXT",1)) + Q IBX + ; +STATUS(IBBUFDA,STATUS,NC,NG,NP) ; edit the status node + ; + N IBX,IBARR,IBIFN Q:'$G(IBBUFDA) S IBIFN=IBBUFDA_"," + D CHK^DIE(355.33,.04,"",$G(STATUS),.IBX) Q:IBX="^" + ; + S IBARR(355.33,IBIFN,.04)=STATUS I STATUS="R" S (NC,NG,NP)=0 + S IBARR(355.33,IBIFN,.07)=+$G(NC),IBARR(355.33,IBIFN,.08)=+$G(NG),IBARR(355.33,IBIFN,.09)=+$G(NP) + D FILE^DIE("E","IBARR") + Q + ; +INS(IBBUFDA,FLDS) ; edit the insurance company portion of a buffer file entry + ; + N DIC,DIE,DA,DR,X,Y,IBCNEXT1 + I $P($G(^IBA(355.33,+$G(IBBUFDA),0)),U,4)'="E" Q + I $G(FLDS)="" S FLDS="MR" + ; + ; ESG - 6/18/02 - SDD 5.1.4 - Usage of Auto Match when editing + ; - the insurance company name in the buffer. Also added an + ; - input transform (see below) to clean up the data coming in. + ; - fetch the current buffer ins co name + ; + I FLDS="MR" S IBCNEXT1=$P($G(^IBA(355.33,IBBUFDA,20)),U,1) + ; + S DR=$P($T(@(FLDS_"INS")+1),";;",2,9999) Q:DR="" + ; + I FLDS="MR" Q:$$INSNAME(IBBUFDA)<0 S DR=$P($T(@(FLDS_"INS")+1),";;",2,9999),DR=$P(DR,";",2,99999) + ; + S DIE="^IBA(355.33,",DA=IBBUFDA D ^DIE K DIE,DA,DR + Q + ; +GRP(IBBUFDA,FLDS) ; edit the group/plan portion of the buffer file entry + ; + N DIC,DIE,DA,DR,X,Y I $P($G(^IBA(355.33,+$G(IBBUFDA),0)),U,4)'="E" Q + I $G(FLDS)="" S FLDS="MR" + ; + S DR=$P($T(@(FLDS_"GRP")+1),";;",2,9999) Q:DR="" + S DIE="^IBA(355.33,",DA=IBBUFDA D ^DIE K DIE,DA,DR + Q + ; +POLICY(IBBUFDA,FLDS) ; edit the patient policy portion of the buffer file entry + ; + N DIC,DIE,DA,DR,X,Y,IBZZ I $P($G(^IBA(355.33,+$G(IBBUFDA),0)),U,4)'="E" Q + I $G(FLDS)="" S FLDS="MR" + ; + S DR=$P($T(@(FLDS_"POL")+1),";;",2,9999) Q:DR="" + S DIE="^IBA(355.33,",DA=IBBUFDA + S DIE("NO^")="BACKOUTOK" D ^DIE K DIE,DA,DR Q:$D(Y) + ; + I FLDS="MR" D ESGHP(IBBUFDA) + Q + ; +ESGHP(IBBUFDA) ; sponsoring employer information + N DIR,DIRUT,DUOUT,DTOUT,VAOA,VAERR,VA,DFN,IB60,IBE,IBEMPST,IBREL + ; + ; if insured is patient or spouse, ask if insured's current employer is the plan's sponsoring employer, if yes auto stuff it + I +$G(^IBA(355.33,IBBUFDA,61)) W ! S IB60=$G(^IBA(355.33,IBBUFDA,60)) D Q:$D(DIRUT) + . ; sponsoring employer is current employer? + . S DFN=+IB60,IBREL=$P(IB60,U,6),VAOA("A")=$S(IBREL="01":5,IBREL="02":6,1:"") I 'DFN!(VAOA("A")="") Q + . D OAD^VADPT I $G(VAOA(9))="" Q + . S DIR("?")="Enter Yes if this plan is sponsored by the "_$S(IBREL="01":"patient's",1:"spouse's")_" current employer." + . S DIR("?",1)="Entering Yes will result in the "_$S(IBREL="01":"patient's",1:"spouse's")_" current employer data being",DIR("?",2)="added to the policy as the Sponsoring Employer data.",DIR("?",3)="" + . S DIR("A")="Current Employer "_VAOA(9)_" Sponsors this Plan",DIR("B")="No",DIR(0)="Y" D ^DIR W ! I Y'=1 Q + . ; + . D DELEMP(IBBUFDA) ; delete any data already contained in these fields + . ; + . ; if the insured's current employer sponsors the plan then stuff that employer's address into the buffer + . S IBE=$S(IBREL="01":.311,1:.25),IBEMPST=$P($G(^DPT(DFN,IBE)),U,15) + . S DR="61.02///"_VAOA(9)_";61.03///"_IBEMPST_";61.06///"_$E(VAOA(1),1,30)_";61.07///"_$E(VAOA(2),1,30) + . S DR=DR_";61.08///"_$E(VAOA(3),1,30)_";61.09///"_$E(VAOA(4),1,20)_";61.1////"_$P(VAOA(5),U,1) + . S DR=DR_";61.11////"_$P(VAOA(11),U,1)_";61.12///"_$E(VAOA(8),1,15) + . S DIE="^IBA(355.33,",DA=IBBUFDA D ^DIE K DIE,DA,DR + ; + ; if employer sponsored plan, edit buffer entry's sponsoring employer info + I +$G(^IBA(355.33,IBBUFDA,61)) S DR="61.02:61.12",DIE="^IBA(355.33,",DA=IBBUFDA D ^DIE K DIE,DA,DR + ; + ; if not employer sponsored plan, delete any existing sponsoring employer data + I $D(^IBA(355.33,IBBUFDA,61)),'$G(^IBA(355.33,IBBUFDA,61)) D DELEMP(IBBUFDA) + Q + ; +DELEMP(IBBUFDA) ; delete sponsoring employer data + N DIC,DIE,DA,DR,X,Y Q:'$D(^IBA(355.33,+$G(IBBUFDA),61)) + S DR="61.02///@;61.03///@;61.04///@;61.05///@;61.06///@;61.07///@;61.08///@;61.09///@;61.10///@;61.11///@;61.12///@" + S DIE="^IBA(355.33,",DA=IBBUFDA D ^DIE K DIE,DA,DR + Q + ; +INSHELP ; + W !!,"------------------------ INSURANCE COMPANY INFORMATION -------------------------",! + Q +GRPHELP ; + W !!,"---------------------------- GROUP/PLAN INFORMATION ----------------------------" + W !," The following data defines a specific Group or Plan provided by an Insurance " + W !," Company. This may be either a group plan with many potential members or an " + W !," individual plan with a single member.",! + Q +POLHELP ; + W !!,"---------------------- POLICY AND SUBSCRIBER INFORMATION -----------------------" + W !," The following data defines the subscriber specific policy information for a " + W !," particular Insurance Plan. The subscriber, the insured, and the policy holder " + W !," all refer to the person who is a member of the plan and therefore holds the " + W !," policy. The patient must be covered under the plan but may not be the policy" + W !," holder.",! + Q + ; +INSNAME(IBBUFDA) ; Reset insurance company name + N DR,DIE,DA,Y,X,IBX,IBNEW,IBNAME + S IBX=-1 + S DR=20.01,DIE="^IBA(355.33,",DA=IBBUFDA + D ^DIE + I '$D(Y) S IBNEW=$$CHECK(IBBUFDA) + I +$G(IBNEW)'<0,$G(IBNEW)'=0,$D(IBNEW) S DR=$P(DR,";",1)_"////"_IBNEW S DIE="^IBA(355.33,",DA=IBBUFDA D ^DIE K DIE,DA,DR I '$D(Y) S IBX=0 + ; BHS - 10/15/03 - If user entered a caret during $$CHECK still set + ; return value to 0 so the user can edit the other + ; INS fields + I $G(IBNEW)=0!($G(IBNEW)=-1) S IBX=0 + Q IBX + ; +CHECK(IBBUFDA) ; Select Insurance Company Name and Automatch + ; Buffer file (#355.33), field# 20.01. + ; ESG - 6/18/02 - SDD 5.1.4 - Usage of Auto Match when editing the + ; insurance company name. Also, display the insurance company + ; name lookup/lister and the Auto Match lookup/lister. + ; + NEW IBNEW,IBNAME,AMLIST + ; + S IBNEW=0,IBNAME=$P($G(^IBA(355.33,$G(IBBUFDA),20)),U,1) + I IBNAME="" G CHECKQ + ; + ; Perform an insurance company lookup/lister + ; BHS - 10/15/03 - Removed quits when user enters a caret to quit the + ; the ins lister or Auto Match lister + S IBNEW=$$DICINS^IBCNBU1(IBNAME,1,10) + I IBNEW=0!(IBNEW<0) D + . I '$$AMLOOK^IBCNEUT1(IBNAME,1,.AMLIST) Q + . S IBNEW=$$AMSEL^IBCNEUT1(.AMLIST) + ; + ; user chose a valid insurance company - possible Auto Match add + I IBNEW'<0,IBNEW'=0 D AMADD^IBCNEUT6(X,IBCNEXT1) + ; +CHECKQ Q IBNEW + ; +MRINS ; Insurance Company fields asked of MCCR users in the Buffer Process options (all buffer ins fields 20.01-21.06) + ;;20.01;20.05;20.02:20.04;21.01;I X="" S Y="@111";21.02;I X="" S Y="@111";21.03;@111;21.04:21.06 + ; +MRGRP ; Group/Plan fields asked of MCCR users in the Buffer Process options (all buffer grp fields 40.01-40.09) ;;Daou/EEN adding BIN and PCN (40.1,40.11) + ;;40.01:40.03;40.1;40.11;40.09;40.04:40.08 + ; +MRPOL ; Patient Policy fields asked of MCCR users in the Buffer Process options (all buffer policy fields except ESGHP 60.02-61.01 + ;;60.02;60.03;60.05;60.06//^S X=$S(X="v":"01",X="s":"02",1:"");S IBZZ=X;60.04;I IBZZ'="01" S Y="@111";60.07///1;60.08///@;60.09///@;S Y="@112";@111;60.07:60.09;60.13;@112;60.1:60.12;.03;61.01 + ; +OTINS ; Insurance Company fields asked of non-MCCR users entering buffer data from options outside IB (20.01-20.04,21.01-21.06) + ;;20.01:20.04;21.01;I X="" S Y="@111";21.02;I X="" S Y="@111";21.03;@111;21.04:21.06 + ; +OTGRP ; Group/Plan fields asked of non-MCCR users entering buffer data from options outside IB (40.02,40.03,40.09) ;;Daou/EEN-adding BIN & PCN (40.1,40.11) + ;;40.02;40.03;40.1;40.11;40.09 + ; +OTPOL ; Patient Policy fields asked of non-MCCR users entering buffer data from options outside IB (60.02-60.09) + ;;60.02;60.03;60.05;60.06//^S X=$S(X="v":"01",X="s":"02",1:"");S IBZZ=X;60.04;I IBZZ'="01" S Y="@111";60.07///1;60.08///@;60.09///@;S Y="@112";@111;60.07:60.09;60.13;@112 diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNBLE.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNBLE.m index dff5bf19..6cf0cdc8 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNBLE.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNBLE.m @@ -1,188 +1,187 @@ -IBCNBLE ;ALB/ARH-Ins Buffer: LM buffer entry screen ;1 Jun 97 - ;;2.0;INTEGRATED BILLING;**82,231,184,251,371**;21-MAR-94;Build 57 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -EN ; - main entry point for list manager display - N DFN - D EN^VALM("IBCNB INSURANCE BUFFER ENTRY") - Q - ; -HDR ; - header code for list manager display - N IBX,IB0,VADM,VA,VAERR S IBX="" - I +$G(DFN) D DEM^VADPT S IBX=$E(VADM(1),1,28),IBX=IBX_$J("",35-$L(IBX))_$P(VADM(2),U,2)_" DOB: "_$P(VADM(3),U,2)_" AGE: "_VADM(4) - S VALMHDR(1)=IBX - S IB0=$G(^IBA(355.33,+$G(IBBUFDA),0)) - S IBX=$E($P($G(^VA(200,+$P(IB0,U,2),0)),U,1),1,27)_" ("_$E($$EXPAND^IBTRE(355.33,.03,$P(IB0,U,3)),1,11)_")" - S IBX="Buffer entry created on "_$$DATE(+IB0)_" by "_IBX,IBX=$J("",40-($L(IBX)\2))_IBX - S VALMHDR(2)=IBX - S IBX="" I +$P(IB0,U,10) S IBX="Buffer entry verified on "_$$DATE(+$P(IB0,U,10))_" by "_$E($P($G(^VA(200,+$P(IB0,U,11),0)),U,1),1,27),IBX=$J("",40-($L(IBX)\2))_IBX - S VALMHDR(3)=IBX - Q - ; -INIT ; - initialization of list manager screen, ifn of record to display required IBBUFDA - K ^TMP("IBCNBLE",$J) - I '$G(IBBUFDA) S VALMQUIT="" Q - S DFN=+$G(^IBA(355.33,IBBUFDA,60)) - D BLD - Q - ; -HELP ; - help text for list manager screen - D FULL^VALM1 - W !!,"This screen displays all data in a Buffer File entry." - W !!,"The actions allow editing of all data and verification of coverage." - W !!,"It is not necessary to use the Verify Entry action, this action is optional.",!,"If the Verify Entry action is not used, the policy will be automatically flagged",!,"as verified when it is Accepted and stored in the main Insurance files." - D PAUSE^VALM1 S VALMBCK="R" - Q - ; -EXIT ; - exit list manager screen - K ^TMP("IBCNBLE",$J) - D CLEAR^VALM1 - Q - ; -BLD ; display buffer entry - N IB0,IB20,IB40,IB60,IB61,IB62,IBL,IBLINE,ADDR,IBI,IBY - S VALMCNT=0 - S IB0=$G(^IBA(355.33,IBBUFDA,0)),IB20=$G(^IBA(355.33,IBBUFDA,20)),IB40=$G(^IBA(355.33,IBBUFDA,40)) - S IB60=$G(^IBA(355.33,IBBUFDA,60)),IB61=$G(^IBA(355.33,IBBUFDA,61)),IB62=$G(^IBA(355.33,IBBUFDA,62)) - ; - D SET(" ") S IBY=$J("",26)_"Insurance Company Information" D SET(IBY,"B") S IBLINE="" - S IBL="Name: ",IBY=$P(IB20,U,1) S IBLINE=$$SETL("",IBY,IBL,10,30) - S IBL="Reimburse?: ",IBY=$$EXPAND^IBTRE(355.33,20.05,$P(IB20,U,5)) S IBLINE=$$SETL(IBLINE,IBY,IBL,57,20) - D SET(IBLINE) S IBLINE="" - S IBL="Phone: ",IBY=$P(IB20,U,2) S IBLINE=$$SETL(IBLINE,IBY,IBL,10,20) - S IBL="Billing Phone: ",IBY=$P(IB20,U,3) S IBLINE=$$SETL(IBLINE,IBY,IBL,57,20) - D SET(IBLINE) S IBLINE="" - S IBL="Precert Phone: ",IBY=$P(IB20,U,4) S IBLINE=$$SETL(IBLINE,IBY,IBL,57,20) - D SET(IBLINE) S IBLINE="" - S IBL="Remote Query From: ",IBY=$$EXTERNAL^DILFD(355.33,.14,"",$P(IB0,"^",14)) S IBLINE=$$SETL(IBLINE,IBY,IBL,57,20) - D SET(IBLINE) S IBLINE="" D ADDR(21,1) - S IBL="Address: ",IBY=ADDR(1) S IBLINE=$$SETL(IBLINE,IBY,IBL,10,69) - D SET(IBLINE) S IBLINE="" - F IBI=2:1:9 S IBL="",IBY=$G(ADDR(IBI)) Q:IBY="" S IBLINE=$$SETL(IBLINE,IBY,IBL,10,69) D SET(IBLINE) S IBLINE="" - ; - D SET(" ") S IBY=$J("",29)_"Group/Plan Information" D SET(IBY,"B") S IBLINE="" - S IBL="Group Plan?: ",IBY=$$YN($P(IB40,U,1)) S IBLINE=$$SETL("",IBY,IBL,16,3) - S IBL="Require UR: ",IBY=$$YN($P(IB40,U,4)) S IBLINE=$$SETL(IBLINE,IBY,IBL,63,3) - D SET(IBLINE) S IBLINE="" - S IBL="Group Name: ",IBY=$P(IB40,U,2) S IBLINE=$$SETL("",IBY,IBL,16,20) - S IBL="Require Amb Cert: ",IBY=$$YN($P(IB40,U,6)) S IBLINE=$$SETL(IBLINE,IBY,IBL,63,3) - D SET(IBLINE) S IBLINE="" - S IBL="Group Number: ",IBY=$P(IB40,U,3) S IBLINE=$$SETL("",IBY,IBL,16,17) - S IBL="Require Pre-Cert: ",IBY=$$YN($P(IB40,U,5)) S IBLINE=$$SETL(IBLINE,IBY,IBL,63,3) - ;;Daou/EEN - Adding BIN and PCN - D SET(IBLINE) S IBLINE="" - S IBL="BIN: ",IBY=$P(IB40,U,10) S IBLINE=$$SETL("",IBY,IBL,16,10) - D SET(IBLINE) S IBLINE="" - S IBL="PCN: ",IBY=$P(IB40,U,11) S IBLINE=$$SETL("",IBY,IBL,16,20) - D SET(IBLINE) S IBLINE="" - S IBL="Type of Plan: ",IBY=$P($G(^IBE(355.1,+$P(IB40,U,9),0)),U,1) S IBLINE=$$SETL("",IBY,IBL,16,25) - S IBL="Exclude Pre-Cond: ",IBY=$$YN($P(IB40,U,7)) S IBLINE=$$SETL(IBLINE,IBY,IBL,63,3) - D SET(IBLINE) S IBLINE="" - S IBL="Benefits Assignable: ",IBY=$$YN($P(IB40,U,8)) S IBLINE=$$SETL(IBLINE,IBY,IBL,63,3) - D SET(IBLINE) S IBLINE="" - ; - D SET(" ") S IBY=$J("",26)_"Policy/Subscriber Information" D SET(IBY,"B") S IBLINE="" - S IBL="Whose Insurance: ",IBY=$$EXPAND^IBTRE(355.33,60.05,$P(IB60,U,5)) S IBLINE=$$SETL("",IBY,IBL,18,7) - S IBL="Effective: ",IBY=$$DATE($P(IB60,U,2)) S IBLINE=$$SETL(IBLINE,IBY,IBL,62,8) - D SET(IBLINE) S IBLINE="" - S IBL="Insured's Name: ",IBY=$P(IB60,U,7) S IBLINE=$$SETL("",IBY,IBL,18,30) - S IBL="Expiration: ",IBY=$$DATE($P(IB60,U,3)) S IBLINE=$$SETL(IBLINE,IBY,IBL,62,13) - D SET(IBLINE) S IBLINE="" - S IBL="Subscriber Id: ",IBY=$P(IB60,U,4) S IBLINE=$$SETL("",IBY,IBL,18,20) - S IBL="Primary Provider: ",IBY=$P(IB60,U,10) S IBLINE=$$SETL(IBLINE,IBY,IBL,62,17) - D SET(IBLINE) S IBLINE="" - S IBL="Relationship: ",IBY=$$EXPAND^IBTRE(355.33,60.06,$P(IB60,U,6)) S IBLINE=$$SETL("",IBY,IBL,18,16) - S IBL="Provider Phone: ",IBY=$P(IB60,U,11) S IBLINE=$$SETL(IBLINE,IBY,IBL,62,16) - D SET(IBLINE) S IBLINE="" - I $P(IB60,U,6)'="01"!($P(IB60,U,8)'="") S IBL="Insured's DOB: ",IBY=$$DATE($P(IB60,U,8)) S IBLINE=$$SETL("",IBY,IBL,18,8) - S IBL="Coord of Benefits: ",IBY=$$EXPAND^IBTRE(355.33,60.12,$P(IB60,U,12)) S IBLINE=$$SETL(IBLINE,IBY,IBL,62,16) - D SET(IBLINE) S IBLINE="" - I $P(IB62,U)'="" S IBL="Patient Id: ",IBY=$P(IB62,U) S IBLINE=$$SETL(IBLINE,IBY,IBL,62,13) - I IBLINE'="" D SET(IBLINE) S IBLINE="" - ; - I '$P(IB61,U,1) D SET(" ") S IBL="Employer Sponsored Group Health Plan?: ",IBY=$$YN($P(IB61,U,1)) S IBLINE=$$SETL("",IBY,IBL,40,3) D SET(IBLINE) S IBLINE="" G NXT - ; - D ADDR(61,6) - D SET(" ") S IBY=$J("",24)_"Subscriber's Employer Information" D SET(IBY,"B") S IBLINE="" - S IBL="Employer Sponsored?: ",IBY=$$YN($P(IB61,U,1)) S IBLINE=$$SETL("",IBY,IBL,22,3) - S IBL="Employment Status: ",IBY=$$EXPAND^IBTRE(355.33,61.03,$P(IB61,U,3)) S IBLINE=$$SETL(IBLINE,IBY,IBL,64,15) - D SET(IBLINE) S IBLINE="" - S IBL="Claim to Employer: ",IBY=$$YN($P(IB61,U,5)) S IBLINE=$$SETL("",IBY,IBL,22,3) - S IBL="Retirement Date: ",IBY=$$DATE($P(IB61,U,4)) S IBLINE=$$SETL(IBLINE,IBY,IBL,64,8) - D SET(IBLINE) S IBLINE="" - S IBL="Employer Name: ",IBY=$P(IB61,U,2) S IBLINE=$$SETL("",IBY,IBL,16,30) - S IBL="Employer Phone: ",IBY=$P(IB61,U,12) S IBLINE=$$SETL(IBLINE,IBY,IBL,64,15) - D SET(IBLINE) S IBLINE="" - S IBL="Address: ",IBY=ADDR(1) S IBLINE=$$SETL(IBLINE,IBY,IBL,16,64) - D SET(IBLINE) S IBLINE="" - F IBI=2:1:9 S IBL="",IBY=$G(ADDR(IBI)) Q:IBY="" S IBLINE=$$SETL(IBLINE,IBY,IBL,16,64) D SET(IBLINE) S IBLINE="" - ; -NXT ; - D SET(" ") S IBY=$J("",26)_"Buffer Entry Information" D SET(IBY,"B") S IBLINE="" - S IBL="Date Entered: ",IBY=$$FMTE^XLFDT($P(IB0,U,1),2) S IBLINE=$$SETL("",IBY,IBL,18,17) - S IBL="Date Verified: ",IBY=$$FMTE^XLFDT($P(IB0,U,10),2) S IBLINE=$$SETL(IBLINE,IBY,IBL,62,17) - D SET(IBLINE) S IBLINE="" - S IBL="Entered By: ",IBY=$$EXPAND^IBTRE(355.33,.02,$P(IB0,U,2)) S IBLINE=$$SETL("",IBY,IBL,18,40) - S IBL="Verified By: ",IBY=$$EXPAND^IBTRE(355.33,.11,$P(IB0,U,11)) S IBLINE=$$SETL(IBLINE,IBY,IBL,62,17) - D SET(IBLINE) S IBLINE="" - ; - ; esg - 6/25/02 SDD 5.1.2 - modifications to Expand Entry for IIV - ; move source down one line, eIIV trace # to the left column and add - ; eIIV processed date to the right column - ; - S IBLINE=$$TRACE(IBLINE,IBBUFDA) ; eIIV trace # - S IBL="eIIV Processed Date: ",IBY=$S($P(IB0,U,15)="":"",1:$$FMTE^XLFDT($P(IB0,U,15),"2M")) - S IBLINE=$$SETL(IBLINE,IBY,IBL,62,17) - D SET(IBLINE) S IBLINE="" - S IBL="Source: ",IBY=$$EXPAND^IBTRE(355.33,.03,$P(IB0,U,3)) - S IBLINE=$$SETL("",IBY,IBL,18,17) - D SET(IBLINE) S IBLINE="" - ; - ; Call another routine for continuation of list build - D BLD^IBCNBLE1 - ; -BLDQ Q - ; - ; -SETL(LINE,DATA,LABEL,COL,LNG) ; - S LINE=LINE_$J("",(COL-$L(LABEL)-$L(LINE)))_LABEL_$E(DATA,1,LNG) - Q LINE - ; -SET(LINE,SPEC) ; - S VALMCNT=VALMCNT+1 - S ^TMP("IBCNBLE",$J,VALMCNT,0)=LINE - I $G(SPEC)="B" D CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM) - Q - ; -DATE(X) ; - N Y S Y="" I X?7N.E S Y=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3) - Q Y - ; -YN(X) ; - N Y S X=$G(X),Y=$S(X=1:"Yes",X=0:"No",1:"") - Q Y - ; -ADDR(NODE,FLD) ; format address for output - N IBY,IB0,IBCS,IBST,IBZIP,IBJ,IBZ,IBX K ADDR S ADDR(1)="" - S IB0=$G(^IBA(355.33,IBBUFDA,NODE)) - S IBCS=$P(IB0,U,FLD+3),IBST=$P($G(^DIC(5,+$P(IB0,U,FLD+4),0)),U,2),IBZIP=$P(IB0,U,FLD+5) - S IBZIP=$E(IBZIP,1,5)_$S($E(IBZIP,6,9)'="":"-"_$E(IBZIP,6,9),1:"") - S IBST=IBST_$S(IBST=""!(IBZIP=""):"",1:" ")_IBZIP - S IBCS=IBCS_$S(IBCS=""!(IBST=""):"",1:", ")_IBST - ; - S IBJ=1 F IBY=$P(IB0,U,FLD),$P(IB0,U,(FLD+1)),$P(IB0,U,(FLD+2)),IBCS I IBY'="" S IBX=$G(ADDR(IBJ)),IBZ=", " D - . S:IBX="" IBZ="" S:($L(IBX)+2+$L(IBY))>64 IBZ="",IBJ=IBJ+1 - . S ADDR(IBJ)=$G(ADDR(IBJ))_IBZ_IBY - Q - ; -TRACE(IBLINE,IBBUFDA) ; Add the eIIV Trace Number to the display - NEW RESP,TRACENUM,IBL,IBY - I '$G(IBBUFDA) G TRACEX - S RESP=$O(^IBCN(365,"AF",IBBUFDA,""),-1) ; response ien - S TRACENUM="" - I RESP S TRACENUM=$P($G(^IBCN(365,RESP,0)),U,9) ; trace# field - S IBL="eIIV Trace #: ",IBY=TRACENUM ; field label/data - S IBLINE=$$SETL("",IBY,IBL,18,17) ; add it -TRACEX ; - Q IBLINE - ; +IBCNBLE ;ALB/ARH-Ins Buffer: LM buffer entry screen ;1 Jun 97 + ;;2.0;INTEGRATED BILLING;**82,231,184,251**;21-MAR-94 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; +EN ; - main entry point for list manager display + N DFN + D EN^VALM("IBCNB INSURANCE BUFFER ENTRY") + Q + ; +HDR ; - header code for list manager display + N IBX,IB0,VADM,VA,VAERR S IBX="" + I +$G(DFN) D DEM^VADPT S IBX=$E(VADM(1),1,28),IBX=IBX_$J("",35-$L(IBX))_$P(VADM(2),U,2)_" DOB: "_$P(VADM(3),U,2)_" AGE: "_VADM(4) + S VALMHDR(1)=IBX + S IB0=$G(^IBA(355.33,+$G(IBBUFDA),0)) + S IBX=$E($P($G(^VA(200,+$P(IB0,U,2),0)),U,1),1,27)_" ("_$E($$EXPAND^IBTRE(355.33,.03,$P(IB0,U,3)),1,11)_")" + S IBX="Buffer entry created on "_$$DATE(+IB0)_" by "_IBX,IBX=$J("",40-($L(IBX)\2))_IBX + S VALMHDR(2)=IBX + S IBX="" I +$P(IB0,U,10) S IBX="Buffer entry verified on "_$$DATE(+$P(IB0,U,10))_" by "_$E($P($G(^VA(200,+$P(IB0,U,11),0)),U,1),1,27),IBX=$J("",40-($L(IBX)\2))_IBX + S VALMHDR(3)=IBX + Q + ; +INIT ; - initialization of list manager screen, ifn of record to display required IBBUFDA + K ^TMP("IBCNBLE",$J) + I '$G(IBBUFDA) S VALMQUIT="" Q + S DFN=+$G(^IBA(355.33,IBBUFDA,60)) + D BLD + Q + ; +HELP ; - help text for list manager screen + D FULL^VALM1 + W !!,"This screen displays all data in a Buffer File entry." + W !!,"The actions allow editing of all data and verification of coverage." + W !!,"It is not necessary to use the Verify Entry action, this action is optional.",!,"If the Verify Entry action is not used, the policy will be automatically flagged",!,"as verified when it is Accepted and stored in the main Insurance files." + D PAUSE^VALM1 S VALMBCK="R" + Q + ; +EXIT ; - exit list manager screen + K ^TMP("IBCNBLE",$J) + D CLEAR^VALM1 + Q + ; +BLD ; display buffer entry + N IB0,IB20,IB40,IB60,IB61,IBL,IBLINE,ADDR,IBI,IBY + S VALMCNT=0 + S IB0=$G(^IBA(355.33,IBBUFDA,0)),IB20=$G(^IBA(355.33,IBBUFDA,20)),IB40=$G(^IBA(355.33,IBBUFDA,40)),IB60=$G(^IBA(355.33,IBBUFDA,60)),IB61=$G(^IBA(355.33,IBBUFDA,61)) + ; + D SET(" ") S IBY=$J("",26)_"Insurance Company Information" D SET(IBY,"B") S IBLINE="" + S IBL="Name: ",IBY=$P(IB20,U,1) S IBLINE=$$SETL("",IBY,IBL,10,30) + S IBL="Reimburse?: ",IBY=$$EXPAND^IBTRE(355.33,20.05,$P(IB20,U,5)) S IBLINE=$$SETL(IBLINE,IBY,IBL,57,20) + D SET(IBLINE) S IBLINE="" + S IBL="Phone: ",IBY=$P(IB20,U,2) S IBLINE=$$SETL(IBLINE,IBY,IBL,10,20) + S IBL="Billing Phone: ",IBY=$P(IB20,U,3) S IBLINE=$$SETL(IBLINE,IBY,IBL,57,20) + D SET(IBLINE) S IBLINE="" + S IBL="Precert Phone: ",IBY=$P(IB20,U,4) S IBLINE=$$SETL(IBLINE,IBY,IBL,57,20) + D SET(IBLINE) S IBLINE="" + S IBL="Remote Query From: ",IBY=$$EXTERNAL^DILFD(355.33,.14,"",$P(IB0,"^",14)) S IBLINE=$$SETL(IBLINE,IBY,IBL,57,20) + D SET(IBLINE) S IBLINE="" D ADDR(21,1) + S IBL="Address: ",IBY=ADDR(1) S IBLINE=$$SETL(IBLINE,IBY,IBL,10,69) + D SET(IBLINE) S IBLINE="" + F IBI=2:1:9 S IBL="",IBY=$G(ADDR(IBI)) Q:IBY="" S IBLINE=$$SETL(IBLINE,IBY,IBL,10,69) D SET(IBLINE) S IBLINE="" + ; + D SET(" ") S IBY=$J("",29)_"Group/Plan Information" D SET(IBY,"B") S IBLINE="" + S IBL="Group Plan?: ",IBY=$$YN($P(IB40,U,1)) S IBLINE=$$SETL("",IBY,IBL,16,3) + S IBL="Require UR: ",IBY=$$YN($P(IB40,U,4)) S IBLINE=$$SETL(IBLINE,IBY,IBL,63,3) + D SET(IBLINE) S IBLINE="" + S IBL="Group Name: ",IBY=$P(IB40,U,2) S IBLINE=$$SETL("",IBY,IBL,16,20) + S IBL="Require Amb Cert: ",IBY=$$YN($P(IB40,U,6)) S IBLINE=$$SETL(IBLINE,IBY,IBL,63,3) + D SET(IBLINE) S IBLINE="" + S IBL="Group Number: ",IBY=$P(IB40,U,3) S IBLINE=$$SETL("",IBY,IBL,16,17) + S IBL="Require Pre-Cert: ",IBY=$$YN($P(IB40,U,5)) S IBLINE=$$SETL(IBLINE,IBY,IBL,63,3) + ;;Daou/EEN - Adding BIN and PCN + D SET(IBLINE) S IBLINE="" + S IBL="BIN: ",IBY=$P(IB40,U,10) S IBLINE=$$SETL("",IBY,IBL,16,10) + D SET(IBLINE) S IBLINE="" + S IBL="PCN: ",IBY=$P(IB40,U,11) S IBLINE=$$SETL("",IBY,IBL,16,20) + D SET(IBLINE) S IBLINE="" + S IBL="Type of Plan: ",IBY=$P($G(^IBE(355.1,+$P(IB40,U,9),0)),U,1) S IBLINE=$$SETL("",IBY,IBL,16,25) + S IBL="Exclude Pre-Cond: ",IBY=$$YN($P(IB40,U,7)) S IBLINE=$$SETL(IBLINE,IBY,IBL,63,3) + D SET(IBLINE) S IBLINE="" + S IBL="Benefits Assignable: ",IBY=$$YN($P(IB40,U,8)) S IBLINE=$$SETL(IBLINE,IBY,IBL,63,3) + D SET(IBLINE) S IBLINE="" + ; + D SET(" ") S IBY=$J("",26)_"Policy/Subscriber Information" D SET(IBY,"B") S IBLINE="" + S IBL="Whose Insurance: ",IBY=$$EXPAND^IBTRE(355.33,60.05,$P(IB60,U,5)) S IBLINE=$$SETL("",IBY,IBL,18,7) + S IBL="Effective: ",IBY=$$DATE($P(IB60,U,2)) S IBLINE=$$SETL(IBLINE,IBY,IBL,62,8) + D SET(IBLINE) S IBLINE="" + S IBL="Insured's Name: ",IBY=$P(IB60,U,7) S IBLINE=$$SETL("",IBY,IBL,18,30) + S IBL="Expiration: ",IBY=$$DATE($P(IB60,U,3)) S IBLINE=$$SETL(IBLINE,IBY,IBL,62,13) + D SET(IBLINE) S IBLINE="" + S IBL="Subscriber Id: ",IBY=$P(IB60,U,4) S IBLINE=$$SETL("",IBY,IBL,18,20) + S IBL="Primary Provider: ",IBY=$P(IB60,U,10) S IBLINE=$$SETL(IBLINE,IBY,IBL,62,17) + D SET(IBLINE) S IBLINE="" + S IBL="Relationship: ",IBY=$$EXPAND^IBTRE(355.33,60.06,$P(IB60,U,6)) S IBLINE=$$SETL("",IBY,IBL,18,16) + S IBL="Provider Phone: ",IBY=$P(IB60,U,11) S IBLINE=$$SETL(IBLINE,IBY,IBL,62,16) + D SET(IBLINE) S IBLINE="" + I $P(IB60,U,6)'="01"!($P(IB60,U,8)'="") S IBL="Insured's DOB: ",IBY=$$DATE($P(IB60,U,8)) S IBLINE=$$SETL("",IBY,IBL,18,8) + S IBL="Coord of Benefits: ",IBY=$$EXPAND^IBTRE(355.33,60.12,$P(IB60,U,12)) S IBLINE=$$SETL(IBLINE,IBY,IBL,62,16) + D SET(IBLINE) S IBLINE="" + I $P(IB60,U,6)'="01"!($P(IB60,U,9)'="") S IBL="Insured's SSN: ",IBY=$P(IB60,U,9) S IBLINE=$$SETL("",IBY,IBL,18,13) + I IBLINE'="" D SET(IBLINE) S IBLINE="" + ; + I '$P(IB61,U,1) D SET(" ") S IBL="Employer Sponsored Group Health Plan?: ",IBY=$$YN($P(IB61,U,1)) S IBLINE=$$SETL("",IBY,IBL,40,3) D SET(IBLINE) S IBLINE="" G NXT + ; + D ADDR(61,6) + D SET(" ") S IBY=$J("",24)_"Subscriber's Employer Information" D SET(IBY,"B") S IBLINE="" + S IBL="Employer Sponsored?: ",IBY=$$YN($P(IB61,U,1)) S IBLINE=$$SETL("",IBY,IBL,22,3) + S IBL="Employment Status: ",IBY=$$EXPAND^IBTRE(355.33,61.03,$P(IB61,U,3)) S IBLINE=$$SETL(IBLINE,IBY,IBL,64,15) + D SET(IBLINE) S IBLINE="" + S IBL="Claim to Employer: ",IBY=$$YN($P(IB61,U,5)) S IBLINE=$$SETL("",IBY,IBL,22,3) + S IBL="Retirement Date: ",IBY=$$DATE($P(IB61,U,4)) S IBLINE=$$SETL(IBLINE,IBY,IBL,64,8) + D SET(IBLINE) S IBLINE="" + S IBL="Employer Name: ",IBY=$P(IB61,U,2) S IBLINE=$$SETL("",IBY,IBL,16,30) + S IBL="Employer Phone: ",IBY=$P(IB61,U,12) S IBLINE=$$SETL(IBLINE,IBY,IBL,64,15) + D SET(IBLINE) S IBLINE="" + S IBL="Address: ",IBY=ADDR(1) S IBLINE=$$SETL(IBLINE,IBY,IBL,16,64) + D SET(IBLINE) S IBLINE="" + F IBI=2:1:9 S IBL="",IBY=$G(ADDR(IBI)) Q:IBY="" S IBLINE=$$SETL(IBLINE,IBY,IBL,16,64) D SET(IBLINE) S IBLINE="" + ; +NXT ; + D SET(" ") S IBY=$J("",26)_"Buffer Entry Information" D SET(IBY,"B") S IBLINE="" + S IBL="Date Entered: ",IBY=$$FMTE^XLFDT($P(IB0,U,1),2) S IBLINE=$$SETL("",IBY,IBL,18,17) + S IBL="Date Verified: ",IBY=$$FMTE^XLFDT($P(IB0,U,10),2) S IBLINE=$$SETL(IBLINE,IBY,IBL,62,17) + D SET(IBLINE) S IBLINE="" + S IBL="Entered By: ",IBY=$$EXPAND^IBTRE(355.33,.02,$P(IB0,U,2)) S IBLINE=$$SETL("",IBY,IBL,18,40) + S IBL="Verified By: ",IBY=$$EXPAND^IBTRE(355.33,.11,$P(IB0,U,11)) S IBLINE=$$SETL(IBLINE,IBY,IBL,62,17) + D SET(IBLINE) S IBLINE="" + ; + ; esg - 6/25/02 SDD 5.1.2 - modifications to Expand Entry for IIV + ; move source down one line, eIIV trace # to the left column and add + ; eIIV processed date to the right column + ; + S IBLINE=$$TRACE(IBLINE,IBBUFDA) ; eIIV trace # + S IBL="eIIV Processed Date: ",IBY=$S($P(IB0,U,15)="":"",1:$$FMTE^XLFDT($P(IB0,U,15),"2M")) + S IBLINE=$$SETL(IBLINE,IBY,IBL,62,17) + D SET(IBLINE) S IBLINE="" + S IBL="Source: ",IBY=$$EXPAND^IBTRE(355.33,.03,$P(IB0,U,3)) + S IBLINE=$$SETL("",IBY,IBL,18,17) + D SET(IBLINE) S IBLINE="" + ; + ; Call another routine for continuation of list build + D BLD^IBCNBLE1 + ; +BLDQ Q + ; + ; +SETL(LINE,DATA,LABEL,COL,LNG) ; + S LINE=LINE_$J("",(COL-$L(LABEL)-$L(LINE)))_LABEL_$E(DATA,1,LNG) + Q LINE + ; +SET(LINE,SPEC) ; + S VALMCNT=VALMCNT+1 + S ^TMP("IBCNBLE",$J,VALMCNT,0)=LINE + I $G(SPEC)="B" D CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM) + Q + ; +DATE(X) ; + N Y S Y="" I X?7N.E S Y=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3) + Q Y + ; +YN(X) ; + N Y S X=$G(X),Y=$S(X=1:"Yes",X=0:"No",1:"") + Q Y + ; +ADDR(NODE,FLD) ; format address for output + N IBY,IB0,IBCS,IBST,IBZIP,IBJ,IBZ,IBX K ADDR S ADDR(1)="" + S IB0=$G(^IBA(355.33,IBBUFDA,NODE)) + S IBCS=$P(IB0,U,FLD+3),IBST=$P($G(^DIC(5,+$P(IB0,U,FLD+4),0)),U,2),IBZIP=$P(IB0,U,FLD+5) + S IBZIP=$E(IBZIP,1,5)_$S($E(IBZIP,6,9)'="":"-"_$E(IBZIP,6,9),1:"") + S IBST=IBST_$S(IBST=""!(IBZIP=""):"",1:" ")_IBZIP + S IBCS=IBCS_$S(IBCS=""!(IBST=""):"",1:", ")_IBST + ; + S IBJ=1 F IBY=$P(IB0,U,FLD),$P(IB0,U,(FLD+1)),$P(IB0,U,(FLD+2)),IBCS I IBY'="" S IBX=$G(ADDR(IBJ)),IBZ=", " D + . S:IBX="" IBZ="" S:($L(IBX)+2+$L(IBY))>64 IBZ="",IBJ=IBJ+1 + . S ADDR(IBJ)=$G(ADDR(IBJ))_IBZ_IBY + Q + ; +TRACE(IBLINE,IBBUFDA) ; Add the eIIV Trace Number to the display + NEW RESP,TRACENUM,IBL,IBY + I '$G(IBBUFDA) G TRACEX + S RESP=$O(^IBCN(365,"AF",IBBUFDA,""),-1) ; response ien + S TRACENUM="" + I RESP S TRACENUM=$P($G(^IBCN(365,RESP,0)),U,9) ; trace# field + S IBL="eIIV Trace #: ",IBY=TRACENUM ; field label/data + S IBLINE=$$SETL("",IBY,IBL,18,17) ; add it +TRACEX ; + Q IBLINE + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNBMI.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNBMI.m index 6c8e997a..279bcf77 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNBMI.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNBMI.m @@ -1,181 +1,180 @@ -IBCNBMI ;ALB/ARH-Ins Buffer: move buffer data to insurance files ;09 Mar 2005 11:42 AM - ;;2.0;INTEGRATED BILLING;**82,184,246,251,299,345,361,371**;21-MAR-94;Build 57 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -INS(IBBUFDA,IBINSDA,TYPE) ; move buffer insurance company data (file 355.33) to existing Insurance Company (file 36) - ; - S IBBUFDA=IBBUFDA_",",IBINSDA=$G(IBINSDA)_"," - D SET("INS",IBBUFDA,IBINSDA,TYPE) - Q - ; -GRP(IBBUFDA,IBGRPDA,TYPE) ; move buffer insurance group/plan data (file 355.33) to existing Group/Plan (file 355.33) - ; - S IBBUFDA=IBBUFDA_",",IBGRPDA=$G(IBGRPDA)_"," - D SET("GRP",IBBUFDA,IBGRPDA,TYPE) - D STUFF("GRP",IBGRPDA) - Q - ; -POLICY(IBBUFDA,IBPOLDA,TYPE) ; move buffer insurance policy data (file 355.33) to existing Patient Policy (file 2.312) - ; - N DFN S DFN=+$G(^IBA(355.33,+$G(IBBUFDA),60)) Q:'DFN - ; - S IBBUFDA=IBBUFDA_",",IBPOLDA=$G(IBPOLDA)_","_DFN_"," - D SET("POL",IBBUFDA,IBPOLDA,TYPE) - D STUFF("POL",IBPOLDA) - D POLOTH(IBBUFDA,IBPOLDA) - Q - ; -SET(SET,IBBUFDA,IBEXTDA,TYPE) ; move buffer data to insurance files - ; Input: IBBUFDA - ifn of Buffer File entry to move (#355.33) - ; IBEXTDA - ifn of insurance entry to update (#36,355.3,2) - ; TYPE - 1 = Merge (only buffer data moved to blank fields in ins file, no replace) - ; 2 = Overwrite (all buffer data moved to ins file, replace existing data) - ; 3 = Replace (all buffer data including null move to ins file) - ; 4 = Individually Accept (Skip Blanks) (user accepts - ; individual diffs b/w buffer data and existing file data (excl blanks) - ; to overwrite flds (or addr grp) in existing file) - ; - ; - N IBX,IBFLDS,EXTFILE,DRBUF,DREXT,BUFARR,EXTARR,IBBUFFLD,IBEXTFLD,IBBUFVAL,IBEXTVAL,IBCHNG,IBCHNGN,IBERR - ; - D FIELDS(SET_"FLD") - S IBX=$P($T(@(SET_"DR")+1),";;",2),EXTFILE=+$P(IBX,U,1),DRBUF=$P(IBX,U,2),DREXT=$P(IBX,U,3) - ; - D GETS^DIQ(355.33,IBBUFDA,DRBUF,"E","BUFARR") - D GETS^DIQ(EXTFILE,IBEXTDA,DREXT,"E","EXTARR") - ; - I +$G(TYPE) S IBBUFFLD=0 F S IBBUFFLD=$O(BUFARR(355.33,IBBUFDA,IBBUFFLD)) Q:'IBBUFFLD D - . S IBEXTFLD=$G(IBFLDS(IBBUFFLD)) Q:'IBEXTFLD - . S IBBUFVAL=BUFARR(355.33,IBBUFDA,IBBUFFLD,"E") - . S IBEXTVAL=$G(EXTARR(EXTFILE,IBEXTDA,IBEXTFLD,"E")) - . ; - . I IBBUFVAL=IBEXTVAL Q - . I TYPE=1,IBEXTVAL'="" Q - . I TYPE=2,IBBUFVAL="" Q - . I TYPE=4,'$D(^TMP($J,"IB BUFFER SELECTED",IBBUFFLD)) Q - . ; - . S IBCHNG(EXTFILE,IBEXTDA,IBEXTFLD)=IBBUFVAL - . S IBCHNGN(EXTFILE,IBEXTDA,IBEXTFLD)="" - ; - I $D(IBCHNGN)>9 D FILE^DIE("E","IBCHNGN","IBERR") - I $D(IBCHNG)>9 D FILE^DIE("E","IBCHNG","IBERR") - Q - ; -STUFF(SET,IBEXTDA) ; update fields in insurance files that should be automatically set when an entry is edited - ; Input: IBEXTDA - ifn of insurance entry to update (#36,356,2) - ; - N IBX,IBFLDS,EXTFILE,IBEXTFLD,IBEXTVAL,IBCHNG,IBCHNGN,IBERR - ; - D FIELDS(SET_"A") - S IBX=$P($T(@(SET_"DR")+1),";;",2),EXTFILE=+$P(IBX,U,1) - ; - S IBEXTFLD=0 F S IBEXTFLD=$O(IBFLDS(IBEXTFLD)) Q:'IBEXTFLD D - . S IBEXTVAL=IBFLDS(IBEXTFLD) I IBEXTVAL="DUZ" S IBEXTVAL="`"_DUZ - . S IBCHNG(EXTFILE,IBEXTDA,IBEXTFLD)=IBEXTVAL - . S IBCHNGN(EXTFILE,IBEXTDA,IBEXTFLD)="" - ; - D FILE^DIE("E","IBCHNGN","IBERR") - D FILE^DIE("E","IBCHNG","IBERR") - Q - ; -FIELDS(SET) ; return array of corresponding fields: IBFLDS(Buffer #)=Ins # - N IBI,IBLN,IBB,IBE,IBG K IBFLDS,IBADDS,IBLBLS - F IBI=1:1 S IBLN=$P($T(@(SET)+IBI),";;",2) Q:IBLN="" I $E(IBLN,1)'=" " D - . S IBB=$P(IBLN,U,1),IBE=$P(IBLN,U,2),IBG=$P(IBLN,U,4) - . I IBB'="",IBE'="" D - .. S IBFLDS(IBB)=IBE - .. I SET["FLD" S IBLBLS(IBB)=$P(IBLN,U,3) I +IBG S IBADDS(IBB)=IBE - Q - ; -INSDR ; - ;;36^20.02:20.04;21.01:21.06^.131;.132;.133;.111:.116 -INSFLD ; corresponding fields: Buffer File (355.33) and Insurance Company file (36) - ;;20.02^.131^Phone Number^ ; MM Phone Number - ;;20.03^.132^Billing Phone^ ; Billing Phone Number - ;;20.04^.133^Pre-Cert Phone^ ; Pre-Certification Phone Number - ;;21.01^.111^Street [Line 1]^1 ; MM Street Address [Line 1] - ;;21.02^.112^Street [Line 2]^1 ; MM Street Address [Line 2] - ;;21.03^.113^Street [Line 3]^1 ; MM Street Address [Line 3] - ;;21.04^.114^City^1 ; MM City - ;;21.05^.115^State^1 ; MM State - ;;21.06^.116^Zip^1 ; MM Zip Code - ; -GRPDR ; - ;;355.3^40.02:40.03;40.1;40.11;40.04:40.09;^.03:.04;6.02;6.03;.05:.09;.12 -GRPFLD ;corresponding fields: Buffer File (355.33) and Insurance Group Plan file (355.3) - ;;40.02^.03^Group Name^ ; Group Name - ;;40.03^.04^Group Number^ ; Group Number - ;;40.1^6.02^BIN^ ; BIN ;;Daou/EEN - ;;40.11^6.03^PCN^ ; PCN ;;Daou/EEN - ;;40.04^.05^Require UR^ ; Utilization Review Required - ;;40.05^.06^Require Pre-Cert^ ; Pre-Certification Required - ;;40.06^.12^Require Amb Cert^ ; Ambulatory Care Certification - ;;40.07^.07^Exclude Pre-Cond^ ; Exclude Pre-Existing Conditions - ;;40.08^.08^Benefits Assign^ ; Benefits Assignable - ;;40.09^.09^Type of Plan^ ; Type of Plan - ; -GRPA ; auto set fields - ;;1.05^NOW^ ; Date Last Edited - ;;1.06^DUZ^ ; Last edited By - ; -POLDR ; - ;;2.312^60.02:62.01^8;3;1;6;16;17;3.01;3.05;4.01;4.02;.2;3.12;2.1;2.015;2.11;2.12;2.01:2.08;5.01 -POLFLD ; corresponding fields: Buffer File (355.33) and Insurance Patient Policy file (2.312) - ;;60.02^8^Effective Date^ ; Effective Date - ;;60.03^3^Expiration Date^ ; Expiration Date - ;;60.04^1^Subscriber Id^ ; Subscriber Id - ;;60.05^6^Whose Insurance^ ; Whose Insurance - ;;60.06^16^Relationship^ ; Pt. Relationship to Insured - ;;60.07^17^Name of Insured^ ; Name of Insured - ;;60.08^3.01^Insured's DOB^ ; Insured's DOB - ;;60.09^3.05^Insured's SSN^ ; Insured's SSN - ;;60.1^4.01^Primary Provider^ ; Primary Care Provider - ;;60.11^4.02^Provider Phone^ ; Primary Care Provider Phone - ;;60.12^.2^Coor of Benefits^ ; Coordination of Benefits - ;;60.13^3.12^Insured's Sex^ ; Insured's Sex - ;; - ;;61.01^2.1^Emp Sponsored^ ; ESGHP? - ;;61.02^2.015^Employer Name^ ; Subscriber's Employer Name - ;;61.03^2.11^Emp Status^ ; Employment Status - ;;61.04^2.12^Retirement Date^ ; Retirement Date - ;;61.05^2.01^Send to Employer^ ; Send Bill to Employer? - ;;61.06^2.02^Emp Street Ln 1^1 ; Employer Claims Street Line 1 - ;;61.07^2.03^Emp Street Ln 2^1 ; Employer Claims Street Line 2 - ;;61.08^2.04^Emp Street Ln 3^1 ; Employer Claims Street Line 3 - ;;61.09^2.05^Emp City^1 ; Employer Claims City - ;;61.1^2.06^Emp State^1 ; Employer Claims State - ;;61.11^2.07^Emp Zip Code^1 ; Employer Claims Zip Code - ;;61.12^2.08^Emp Phone^ ; Employer Claims Phone - ;;62.01^5.01^Patient Id^ ; Patient Id - ; -POLA ; auto set fields - ;;1.03^NOW^ ; Date Last Verified (default is person that accepts entry) - ;;1.04^DUZ^ ; Verified By (default is person that accepts entry) - ;;1.05^NOW^ ; Date Last Edited - ;;1.06^DUZ^ ; Last Edited By - ; - ; -POLOTH(IBBUFDA,IBPOLDA) ; other special cases that can not be transferred using the generic code above, usually because of dependencies - N IB0 S IB0=$G(^IBA(355.33,+IBBUFDA,0)) - ; - ; --- if buffer entry was verified before the accept step, then add the correct verifier info to the policy - I +$P(IB0,U,10) D - . S IBCHNG(2.312,IBPOLDA,1.03)=$E($P(IB0,U,10),1,12),IBCHNGN(2.312,IBPOLDA,1.03)="" - . S IBCHNG(2.312,IBPOLDA,1.04)=$P(IB0,U,11),IBCHNGN(2.312,IBPOLDA,1.04)="" - ; - I $D(IBCHNGN)>9 D FILE^DIE("I","IBCHNGN","IBERR") - I $D(IBCHNG)>9 D FILE^DIE("I","IBCHNG","IBERR") - Q - ; -PAT(DFN,IBPOLDA) ; Force DOB, SSN & SEX from Patient file (#2) in to Insurance Patient Policy file (2.312) - N DA,DR,DIE,DOB,SSN,SEX,IENS,WI - S IENS=IBPOLDA_","_DFN_"," - S WI=$$GET1^DIQ(2.312,IENS,6,"I") - I WI'="v" Q ; Only use when Whose Insurance is 'v' - S DOB=$$GET1^DIQ(2,DFN,.03,"I") - S SSN=$$GET1^DIQ(2,DFN,.09,"I") - S SEX=$$GET1^DIQ(2,DFN,.02,"I") - S DIE="^DPT("_DFN_",.312,",DA(1)=DFN,DA=IBPOLDA - S DR="3.01///^S X=DOB;3.05///^S X=SSN;3.12///^S X=SEX" - D ^DIE - Q +IBCNBMI ;ALB/ARH-Ins Buffer: move buffer data to insurance files ; 09 Mar 2005 11:42 AM + ;;2.0;INTEGRATED BILLING;**82,184,246,251,299,345,361**;21-MAR-94;Build 9 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; +INS(IBBUFDA,IBINSDA,TYPE) ; move buffer insurance company data (file 355.33) to existing Insurance Company (file 36) + ; + S IBBUFDA=IBBUFDA_",",IBINSDA=$G(IBINSDA)_"," + D SET("INS",IBBUFDA,IBINSDA,TYPE) + Q + ; +GRP(IBBUFDA,IBGRPDA,TYPE) ; move buffer insurance group/plan data (file 355.33) to existing Group/Plan (file 355.33) + ; + S IBBUFDA=IBBUFDA_",",IBGRPDA=$G(IBGRPDA)_"," + D SET("GRP",IBBUFDA,IBGRPDA,TYPE) + D STUFF("GRP",IBGRPDA) + Q + ; +POLICY(IBBUFDA,IBPOLDA,TYPE) ; move buffer insurance policy data (file 355.33) to existing Patient Policy (file 2.312) + ; + N DFN S DFN=+$G(^IBA(355.33,+$G(IBBUFDA),60)) Q:'DFN + ; + S IBBUFDA=IBBUFDA_",",IBPOLDA=$G(IBPOLDA)_","_DFN_"," + D SET("POL",IBBUFDA,IBPOLDA,TYPE) + D STUFF("POL",IBPOLDA) + D POLOTH(IBBUFDA,IBPOLDA) + Q + ; +SET(SET,IBBUFDA,IBEXTDA,TYPE) ; move buffer data to insurance files + ; Input: IBBUFDA - ifn of Buffer File entry to move (#355.33) + ; IBEXTDA - ifn of insurance entry to update (#36,355.3,2) + ; TYPE - 1 = Merge (only buffer data moved to blank fields in ins file, no replace) + ; 2 = Overwrite (all buffer data moved to ins file, replace existing data) + ; 3 = Replace (all buffer data including null move to ins file) + ; 4 = Individually Accept (Skip Blanks) (user accepts + ; individual diffs b/w buffer data and existing file data (excl blanks) + ; to overwrite flds (or addr grp) in existing file) + ; + ; + N IBX,IBFLDS,EXTFILE,DRBUF,DREXT,BUFARR,EXTARR,IBBUFFLD,IBEXTFLD,IBBUFVAL,IBEXTVAL,IBCHNG,IBCHNGN,IBERR + ; + D FIELDS(SET_"FLD") + S IBX=$P($T(@(SET_"DR")+1),";;",2),EXTFILE=+$P(IBX,U,1),DRBUF=$P(IBX,U,2),DREXT=$P(IBX,U,3) + ; + D GETS^DIQ(355.33,IBBUFDA,DRBUF,"E","BUFARR") + D GETS^DIQ(EXTFILE,IBEXTDA,DREXT,"E","EXTARR") + ; + I +$G(TYPE) S IBBUFFLD=0 F S IBBUFFLD=$O(BUFARR(355.33,IBBUFDA,IBBUFFLD)) Q:'IBBUFFLD D + . S IBEXTFLD=$G(IBFLDS(IBBUFFLD)) Q:'IBEXTFLD + . S IBBUFVAL=BUFARR(355.33,IBBUFDA,IBBUFFLD,"E") + . S IBEXTVAL=$G(EXTARR(EXTFILE,IBEXTDA,IBEXTFLD,"E")) + . ; + . I IBBUFVAL=IBEXTVAL Q + . I TYPE=1,IBEXTVAL'="" Q + . I TYPE=2,IBBUFVAL="" Q + . I TYPE=4,'$D(^TMP($J,"IB BUFFER SELECTED",IBBUFFLD)) Q + . ; + . S IBCHNG(EXTFILE,IBEXTDA,IBEXTFLD)=IBBUFVAL + . S IBCHNGN(EXTFILE,IBEXTDA,IBEXTFLD)="" + ; + I $D(IBCHNGN)>9 D FILE^DIE("E","IBCHNGN","IBERR") + I $D(IBCHNG)>9 D FILE^DIE("E","IBCHNG","IBERR") + Q + ; +STUFF(SET,IBEXTDA) ; update fields in insurance files that should be automatically set when an entry is edited + ; Input: IBEXTDA - ifn of insurance entry to update (#36,356,2) + ; + N IBX,IBFLDS,EXTFILE,IBEXTFLD,IBEXTVAL,IBCHNG,IBCHNGN,IBERR + ; + D FIELDS(SET_"A") + S IBX=$P($T(@(SET_"DR")+1),";;",2),EXTFILE=+$P(IBX,U,1) + ; + S IBEXTFLD=0 F S IBEXTFLD=$O(IBFLDS(IBEXTFLD)) Q:'IBEXTFLD D + . S IBEXTVAL=IBFLDS(IBEXTFLD) I IBEXTVAL="DUZ" S IBEXTVAL="`"_DUZ + . S IBCHNG(EXTFILE,IBEXTDA,IBEXTFLD)=IBEXTVAL + . S IBCHNGN(EXTFILE,IBEXTDA,IBEXTFLD)="" + ; + D FILE^DIE("E","IBCHNGN","IBERR") + D FILE^DIE("E","IBCHNG","IBERR") + Q + ; +FIELDS(SET) ; return array of corresponding fields: IBFLDS(Buffer #)=Ins # + N IBI,IBLN,IBB,IBE,IBG K IBFLDS,IBADDS,IBLBLS + F IBI=1:1 S IBLN=$P($T(@(SET)+IBI),";;",2) Q:IBLN="" I $E(IBLN,1)'=" " D + . S IBB=$P(IBLN,U,1),IBE=$P(IBLN,U,2),IBG=$P(IBLN,U,4) + . I IBB'="",IBE'="" D + .. S IBFLDS(IBB)=IBE + .. I SET["FLD" S IBLBLS(IBB)=$P(IBLN,U,3) I +IBG S IBADDS(IBB)=IBE + Q + ; +INSDR ; + ;;36^20.02:20.04;21.01:21.06^.131;.132;.133;.111:.116 +INSFLD ; corresponding fields: Buffer File (355.33) and Insurance Company file (36) + ;;20.02^.131^Phone Number^ ; MM Phone Number + ;;20.03^.132^Billing Phone^ ; Billing Phone Number + ;;20.04^.133^Pre-Cert Phone^ ; Pre-Certification Phone Number + ;;21.01^.111^Street [Line 1]^1 ; MM Street Address [Line 1] + ;;21.02^.112^Street [Line 2]^1 ; MM Street Address [Line 2] + ;;21.03^.113^Street [Line 3]^1 ; MM Street Address [Line 3] + ;;21.04^.114^City^1 ; MM City + ;;21.05^.115^State^1 ; MM State + ;;21.06^.116^Zip^1 ; MM Zip Code + ; +GRPDR ; + ;;355.3^40.02:40.03;40.1;40.11;40.04:40.09;^.03:.04;6.02;6.03;.05:.09;.12 +GRPFLD ;corresponding fields: Buffer File (355.33) and Insurance Group Plan file (355.3) + ;;40.02^.03^Group Name^ ; Group Name + ;;40.03^.04^Group Number^ ; Group Number + ;;40.1^6.02^BIN^ ; BIN ;;Daou/EEN + ;;40.11^6.03^PCN^ ; PCN ;;Daou/EEN + ;;40.04^.05^Require UR^ ; Utilization Review Required + ;;40.05^.06^Require Pre-Cert^ ; Pre-Certification Required + ;;40.06^.12^Require Amb Cert^ ; Ambulatory Care Certification + ;;40.07^.07^Exclude Pre-Cond^ ; Exclude Pre-Existing Conditions + ;;40.08^.08^Benefits Assign^ ; Benefits Assignable + ;;40.09^.09^Type of Plan^ ; Type of Plan + ; +GRPA ; auto set fields + ;;1.05^NOW^ ; Date Last Edited + ;;1.06^DUZ^ ; Last edited By + ; +POLDR ; + ;;2.312^60.02:61.12^8;3;1;6;16;17;3.01;3.05;4.01;4.02;.2;3.12;2.1;2.015;2.11;2.12;2.01:2.08 +POLFLD ; corresponding fields: Buffer File (355.33) and Insurance Patient Policy file (2.312) + ;;60.02^8^Effective Date^ ; Effective Date + ;;60.03^3^Expiration Date^ ; Expiration Date + ;;60.04^1^Subscriber Id^ ; Subscriber Id + ;;60.05^6^Whose Insurance^ ; Whose Insurance + ;;60.06^16^Relationship^ ; Pt. Relationship to Insured + ;;60.07^17^Name of Insured^ ; Name of Insured + ;;60.08^3.01^Insured's DOB^ ; Insured's DOB + ;;60.09^3.05^Insured's SSN^ ; Insured's SSN + ;;60.1^4.01^Primary Provider^ ; Primary Care Provider + ;;60.11^4.02^Provider Phone^ ; Primary Care Provider Phone + ;;60.12^.2^Coor of Benefits^ ; Coordination of Benefits + ;;60.13^3.12^Insured's Sex^ ; Insured's Sex + ;; + ;;61.01^2.1^Emp Sponsored^ ; ESGHP? + ;;61.02^2.015^Employer Name^ ; Subscriber's Employer Name + ;;61.03^2.11^Emp Status^ ; Employment Status + ;;61.04^2.12^Retirement Date^ ; Retirement Date + ;;61.05^2.01^Send to Employer^ ; Send Bill to Employer? + ;;61.06^2.02^Emp Street Ln 1^1 ; Employer Claims Street Line 1 + ;;61.07^2.03^Emp Street Ln 2^1 ; Employer Claims Street Line 2 + ;;61.08^2.04^Emp Street Ln 3^1 ; Employer Claims Street Line 3 + ;;61.09^2.05^Emp City^1 ; Employer Claims City + ;;61.1^2.06^Emp State^1 ; Employer Claims State + ;;61.11^2.07^Emp Zip Code^1 ; Employer Claims Zip Code + ;;61.12^2.08^Emp Phone^ ; Employer Claims Phone + ; +POLA ; auto set fields + ;;1.03^NOW^ ; Date Last Verified (default is person that accepts entry) + ;;1.04^DUZ^ ; Verified By (default is person that accepts entry) + ;;1.05^NOW^ ; Date Last Edited + ;;1.06^DUZ^ ; Last Edited By + ; + ; +POLOTH(IBBUFDA,IBPOLDA) ; other special cases that can not be transferred using the generic code above, usually because of dependencies + N IB0 S IB0=$G(^IBA(355.33,+IBBUFDA,0)) + ; + ; --- if buffer entry was verified before the accept step, then add the correct verifier info to the policy + I +$P(IB0,U,10) D + . S IBCHNG(2.312,IBPOLDA,1.03)=$E($P(IB0,U,10),1,12),IBCHNGN(2.312,IBPOLDA,1.03)="" + . S IBCHNG(2.312,IBPOLDA,1.04)=$P(IB0,U,11),IBCHNGN(2.312,IBPOLDA,1.04)="" + ; + I $D(IBCHNGN)>9 D FILE^DIE("I","IBCHNGN","IBERR") + I $D(IBCHNG)>9 D FILE^DIE("I","IBCHNG","IBERR") + Q + ; +PAT(DFN,IBPOLDA) ; Force DOB, SSN & SEX from Patient file (#2) in to Insurance Patient Policy file (2.312) + N DA,DR,DIE,DOB,SSN,SEX,IENS,WI + S IENS=IBPOLDA_","_DFN_"," + S WI=$$GET1^DIQ(2.312,IENS,6,"I") + I WI'="v" Q ; Only use when Whose Insurance is 'v' + S DOB=$$GET1^DIQ(2,DFN,.03,"I") + S SSN=$$GET1^DIQ(2,DFN,.09,"I") + S SEX=$$GET1^DIQ(2,DFN,.02,"I") + S DIE="^DPT("_DFN_",.312,",DA(1)=DFN,DA=IBPOLDA + S DR="3.01///^S X=DOB;3.05///^S X=SSN;3.12///^S X=SEX" + D ^DIE + Q diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNEBF.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNEBF.m index 82d8e5a3..3569082a 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNEBF.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNEBF.m @@ -1,173 +1,170 @@ -IBCNEBF ;DAOU/ALA - Create an Entry in the Buffer File ;20-JUN-2002 - ;;2.0;INTEGRATED BILLING;**184,271,361,371**;21-MAR-94;Build 57 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ;**Program Description** - ; This program will create a Buffer entry based upon input values - ; - Q - ; -PT(DFN,IRIEN,SYMBOL,OVRRIDE,ADD,IBERROR) ; Get data - ; from a specific patient and insurance record entry - ; - ; Input Parameters - ; DFN = Patient IEN - ; IRIEN = Patient Insurance Record IEN - ; SYMBOL = IIV Symbol IEN - ; OVRRIDE = Override flag for ins. buffer record (0 or 1) - ; ADD = If defined, then it will add a new Buffer entry - ; IBERROR = If defined, then it will be updated with error info. - ; OPTIONALLY PASSED BY REFERENCE - ; - I DFN=""!(IRIEN="") Q ; * do not require SYMBOL or OVRRIDE - ; - ; - NEW VBUF,IEN,INAME,PNAME,IIEN,GNUMB,GNAME,SUBID,PPHONE,PATID - NEW BPHONE,EFFDT,EXPDT,WHO,REL,IDOB,ISSN,COB,TQIEN,RDATA,ISEX,NAME - NEW MSG,XMSUB,MSGP,INSDATA,PCE,BFD,BFN,INSPCE,ESGHPARR - ; - S IIEN=$P($G(^DPT(DFN,.312,IRIEN,0)),U,1) - S INAME=$$GET1^DIQ(36,IIEN,.01,"E") - S PPHONE=$P($G(^DIC(36,IIEN,.13)),U,3) - S BPHONE=$P($G(^DIC(36,IIEN,.13)),U,2) - S NAME=$P($G(^DPT(DFN,.312,IRIEN,0)),U,17) - S SUBID=$P($G(^DPT(DFN,.312,IRIEN,0)),U,2) - S PATID=$P($G(^DPT(DFN,.312,IRIEN,5)),U,1) - S WHO=$P($G(^DPT(DFN,.312,IRIEN,0)),U,6) - S COB=$P($G(^DPT(DFN,.312,IRIEN,0)),U,20) - S IDOB=$P($G(^DPT(DFN,.312,IRIEN,3)),U,1) - S ISSN=$P($G(^DPT(DFN,.312,IRIEN,3)),U,5) - S ISEX=$P($G(^DPT(DFN,.312,IRIEN,3)),U,12) - S EFFDT=$P(^DPT(DFN,.312,IRIEN,0),U,8) - S EXPDT=$P(^DPT(DFN,.312,IRIEN,0),U,4) - S REL=$P(^DPT(DFN,.312,IRIEN,0),U,16) - ; - S IENS=IRIEN_","_DFN_"," - S GNUMB=$$GET1^DIQ(2.312,IENS,21,"E") - S GNAME=$$GET1^DIQ(2.312,IENS,20,"E") - ; - ; Capture the employer sponsored insurance fields into array - ; ESGHPARR(buffer field number) = data - ; - S INSDATA=$G(^DPT(DFN,.312,IRIEN,2)),PCE=0 - F BFD=5:1:12,2,1,3,4 S PCE=PCE+1,BFN=BFD/100+61,INSPCE=$P(INSDATA,U,PCE) I INSPCE'="" S ESGHPARR(BFN)=INSPCE - ; - D FIL - K ADD - Q - ; -RP(IEN,ADD,BUFF) ; Get data from a specific response record - ; - ; Input Parameter - ; IEN = Internal entry number of the Response - ; ADD = If defined, then it will add a new Buffer entry - ; BUFF = IEN of the Buffer Entry to be updated (optional) - ; - S BUFF=$G(BUFF) ; Initialize optional parameter - ; - NEW PIEN,RSTYPE - S DFN=$P(^IBCN(365,IEN,0),U,2),TQIEN=$P(^IBCN(365,IEN,0),U,5) - S PIEN=$P(^IBCN(365,IEN,0),U,3),RSTYPE=$P(^(0),U,10) - I PIEN'="" S PNAME=$P(^IBE(365.12,PIEN,0),U,1) - I TQIEN'="" S IRIEN=$P($G(^IBCN(365.1,TQIEN,0)),U,13) - I $G(IRIEN)'="" S INAME="" D - . S IIEN=$P($G(^DPT(DFN,.312,IRIEN,0)),U,1) - . I IIEN="" Q - . S INAME=$P(^DIC(36,IIEN,0),U,1) - S RDATA=$G(^IBCN(365,IEN,1)) - S NAME=$P(RDATA,U,1) - S INAME=$S($G(INAME)'=""&(RSTYPE="O"):INAME,1:$G(PNAME)) - S IDOB=$P(RDATA,U,2) - S ISSN=$P(RDATA,U,3) - S ISEX=$P(RDATA,U,4) - S COB=$P(RDATA,U,13) - S SUBID=$P(RDATA,U,5) - S PATID=$P(RDATA,U,18) - S GNAME=$P(RDATA,U,6) - S GNUMB=$P(RDATA,U,7) - S WHO=$P(RDATA,U,8) - S REL=$P(RDATA,U,9) - S EFFDT=$P(RDATA,U,11) - S EXPDT=$P(RDATA,U,12) - S PPHONE="",BPHONE="" - ; - D FIL - K DFN,VBUF,IEN,IRIEN,INAME,PNAME,IIEN,GNUMB,GNAME,SUBID,PPHONE,PATID - K BPHONE,EFFDT,EXPDT,WHO,REL,IDOB,ISSN,COB,TQIEN,RDATA,ISEX,NAME - K ADD,%DT,D0,DG,DIC,DISYS,DIW,IENS - Q - ; -FIL ; File Buffer Data - ; - S MSGP=$$MGRP^IBCNEUT5() - ; - ; Variable IDUZ is optionally set by the calling routine. If it is - ; not defined, it will be set to the specific, non-human user. - ; - I $G(IDUZ)="" S IDUZ=$$FIND1^DIC(200,"","X","INTERFACE,IB IIV") - ; - I $G(ADD) S VBUF(.02)=IDUZ ; Entered By - S VBUF(.12)=$G(SYMBOL) ; Buffer Symbol - S VBUF(.13)=$G(OVRRIDE) ; Override freshness flag - I '$G(ERACT) D ; Only file if not an error - . S VBUF(20.01)=INAME ; Insurance Company/Payer Name - . S VBUF(60.01)=DFN ; Patient IEN - . S VBUF(40.03)=GNUMB ; Group Number - . S VBUF(40.02)=GNAME ; Group Name - . S VBUF(60.07)=NAME ; Name of Insured - . S VBUF(60.04)=SUBID ; Subscriber ID - . S VBUF(62.01)=PATID ; Patient/Member ID - . S VBUF(20.04)=PPHONE ; Precertification Phone - . S VBUF(20.03)=BPHONE ; Billing Phone - . S VBUF(60.02)=EFFDT ; Effective Date - . S VBUF(60.03)=EXPDT ; Expiration Date - . S VBUF(60.05)=WHO ; Whose Insurance - . S VBUF(60.06)=REL ; Patient Relationship - . S VBUF(60.08)=IDOB ; Insured's DOB - . S VBUF(60.09)=ISSN ; Insured's SSN - . S VBUF(60.12)=COB ; Coordination of Benefits - . S VBUF(60.13)=ISEX ; Insured's Sex - . ; - . ; If the employer sponsored insurance array exists, then merge it in - . I $D(ESGHPARR) M VBUF=ESGHPARR - ; - ; Do not overwrite the existing insurance co. name if it already exists - I $G(ADD)="",$G(BUFF)'="" K VBUF(20.01) - ; - ; ** initialize IBERROR - S IBERROR="" - ; - ; If need to add a new Buffer entry ... - ; - ; Variable IBFDA is returned to the calling routine as the IEN of - ; the buffer entry that was just added. - ; - I $G(ADD) D - . S IBFDA=$$ADDSTF^IBCNBES(5,DFN,.VBUF) - . ; Error Message is 2nd piece of result - . S IBERROR=$P(IBFDA,U,2) - . S IBFDA=$P(IBFDA,U,1) - ; - ; If an error, send an email message - I IBERROR'="" D Q - . S MSG(1)="Error returned by $$ADDSTF^IBCNBES:" - . S MSG(2)=IBERROR - . S MSG(3)="Values:" - . S MSG(4)=" Patient DFN = "_$G(DFN) - . S MSG(5)=" Pt Ins Record IEN = "_$G(IRIEN) - . S MSG(6)="Please log a Remedy Ticket for this problem." - . S XMSUB="Error creating Buffer Entry." - . D MSG^IBCNEUT5(MSGP,XMSUB,"MSG(") - . K MSGP,MSG,XMSUB,IBERR - ; - ; If need to update a new Buffer Entry ... - ; - ; Variable BUFF is passed into this routine whenever the buffer - ; entry is known and the ADD flag is off. The existing buffer entry - ; is edited in this case. - ; - I $G(ADD)="" D EDITSTF^IBCNBES(BUFF,.VBUF) - ; - ; If an error occurred in EDITSTF, the error array is not returned - ; - Q +IBCNEBF ;DAOU/ALA - Create an Entry in the Buffer File ;20-JUN-2002 + ;;2.0;INTEGRATED BILLING;**184,271,361**;21-MAR-94;Build 9 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; + ;**Program Description** + ; This program will create a Buffer entry based upon input values + ; + Q + ; +PT(DFN,IRIEN,SYMBOL,OVRRIDE,ADD,IBERROR) ; Get data + ; from a specific patient and insurance record entry + ; + ; Input Parameters + ; DFN = Patient IEN + ; IRIEN = Patient Insurance Record IEN + ; SYMBOL = IIV Symbol IEN + ; OVRRIDE = Override flag for ins. buffer record (0 or 1) + ; ADD = If defined, then it will add a new Buffer entry + ; IBERROR = If defined, then it will be updated with error info. + ; OPTIONALLY PASSED BY REFERENCE + ; + I DFN=""!(IRIEN="") Q ; * do not require SYMBOL or OVRRIDE + ; + ; + NEW VBUF,IEN,INAME,PNAME,IIEN,GNUMB,GNAME,SUBID,PPHONE + NEW BPHONE,EFFDT,EXPDT,WHO,REL,IDOB,ISSN,COB,TQIEN,RDATA,ISEX,NAME + NEW MSG,XMSUB,MSGP,INSDATA,PCE,BFD,BFN,INSPCE,ESGHPARR + ; + S IIEN=$P($G(^DPT(DFN,.312,IRIEN,0)),U,1) + S INAME=$$GET1^DIQ(36,IIEN,.01,"E") + S PPHONE=$P($G(^DIC(36,IIEN,.13)),U,3) + S BPHONE=$P($G(^DIC(36,IIEN,.13)),U,2) + S NAME=$P($G(^DPT(DFN,.312,IRIEN,0)),U,17) + S SUBID=$P($G(^DPT(DFN,.312,IRIEN,0)),U,2) + S WHO=$P($G(^DPT(DFN,.312,IRIEN,0)),U,6) + S COB=$P($G(^DPT(DFN,.312,IRIEN,0)),U,20) + S IDOB=$P($G(^DPT(DFN,.312,IRIEN,3)),U,1) + S ISSN=$P($G(^DPT(DFN,.312,IRIEN,3)),U,5) + S ISEX=$P($G(^DPT(DFN,.312,IRIEN,3)),U,12) + S EFFDT=$P(^DPT(DFN,.312,IRIEN,0),U,8) + S EXPDT=$P(^DPT(DFN,.312,IRIEN,0),U,4) + S REL=$P(^DPT(DFN,.312,IRIEN,0),U,16) + ; + S IENS=IRIEN_","_DFN_"," + S GNUMB=$$GET1^DIQ(2.312,IENS,21,"E") + S GNAME=$$GET1^DIQ(2.312,IENS,20,"E") + ; + ; Capture the employer sponsored insurance fields into array + ; ESGHPARR(buffer field number) = data + ; + S INSDATA=$G(^DPT(DFN,.312,IRIEN,2)),PCE=0 + F BFD=5:1:12,2,1,3,4 S PCE=PCE+1,BFN=BFD/100+61,INSPCE=$P(INSDATA,U,PCE) I INSPCE'="" S ESGHPARR(BFN)=INSPCE + ; + D FIL + K ADD + Q + ; +RP(IEN,ADD,BUFF) ; Get data from a specific response record + ; + ; Input Parameter + ; IEN = Internal entry number of the Response + ; ADD = If defined, then it will add a new Buffer entry + ; BUFF = IEN of the Buffer Entry to be updated (optional) + ; + S BUFF=$G(BUFF) ; Initialize optional parameter + ; + NEW PIEN,RSTYPE + S DFN=$P(^IBCN(365,IEN,0),U,2),TQIEN=$P(^IBCN(365,IEN,0),U,5) + S PIEN=$P(^IBCN(365,IEN,0),U,3),RSTYPE=$P(^(0),U,10) + I PIEN'="" S PNAME=$P(^IBE(365.12,PIEN,0),U,1) + I TQIEN'="" S IRIEN=$P($G(^IBCN(365.1,TQIEN,0)),U,13) + I $G(IRIEN)'="" S INAME="" D + . S IIEN=$P($G(^DPT(DFN,.312,IRIEN,0)),U,1) + . I IIEN="" Q + . S INAME=$P(^DIC(36,IIEN,0),U,1) + S RDATA=$G(^IBCN(365,IEN,1)) + S NAME=$P(RDATA,U,1) + S INAME=$S($G(INAME)'=""&(RSTYPE="O"):INAME,1:$G(PNAME)) + S IDOB=$P(RDATA,U,2) + S ISSN=$P(RDATA,U,3) + S ISEX=$P(RDATA,U,4) + S COB=$P(RDATA,U,13) + S SUBID=$P(RDATA,U,5) + S GNAME=$P(RDATA,U,6) + S GNUMB=$P(RDATA,U,7) + S WHO=$P(RDATA,U,8) + S REL=$P(RDATA,U,9) + S EFFDT=$P(RDATA,U,11) + S EXPDT=$P(RDATA,U,12) + S PPHONE="",BPHONE="" + ; + D FIL + K DFN,VBUF,IEN,IRIEN,INAME,PNAME,IIEN,GNUMB,GNAME,SUBID,PPHONE + K BPHONE,EFFDT,EXPDT,WHO,REL,IDOB,ISSN,COB,TQIEN,RDATA,ISEX,NAME + K ADD,%DT,D0,DG,DIC,DISYS,DIW,IENS + Q + ; +FIL ; File Buffer Data + ; + S MSGP=$$MGRP^IBCNEUT5() + ; + ; Variable IDUZ is optionally set by the calling routine. If it is + ; not defined, it will be set to the specific, non-human user. + ; + I $G(IDUZ)="" S IDUZ=$$FIND1^DIC(200,"","X","INTERFACE,IB IIV") + ; + I $G(ADD) S VBUF(.02)=IDUZ ; Entered By + S VBUF(.12)=$G(SYMBOL) ; Buffer Symbol + S VBUF(.13)=$G(OVRRIDE) ; Override freshness flag + I '$G(ERACT) D ; Only file if not an error + . S VBUF(20.01)=INAME ; Insurance Company/Payer Name + . S VBUF(60.01)=DFN ; Patient IEN + . S VBUF(40.03)=GNUMB ; Group Number + . S VBUF(40.02)=GNAME ; Group Name + . S VBUF(60.07)=NAME ; Name of Insured + . S VBUF(60.04)=SUBID ; Subscriber ID + . S VBUF(20.04)=PPHONE ; Precertification Phone + . S VBUF(20.03)=BPHONE ; Billing Phone + . S VBUF(60.02)=EFFDT ; Effective Date + . S VBUF(60.03)=EXPDT ; Expiration Date + . S VBUF(60.05)=WHO ; Whose Insurance + . S VBUF(60.06)=REL ; Patient Relationship + . S VBUF(60.08)=IDOB ; Insured's DOB + . S VBUF(60.09)=ISSN ; Insured's SSN + . S VBUF(60.12)=COB ; Coordination of Benefits + . S VBUF(60.13)=ISEX ; Insured's Sex + . ; + . ; If the employer sponsored insurance array exists, then merge it in + . I $D(ESGHPARR) M VBUF=ESGHPARR + ; + ; Do not overwrite the existing insurance co. name if it already exists + I $G(ADD)="",$G(BUFF)'="" K VBUF(20.01) + ; + ; ** initialize IBERROR + S IBERROR="" + ; + ; If need to add a new Buffer entry ... + ; + ; Variable IBFDA is returned to the calling routine as the IEN of + ; the buffer entry that was just added. + ; + I $G(ADD) D + . S IBFDA=$$ADDSTF^IBCNBES(5,DFN,.VBUF) + . ; Error Message is 2nd piece of result + . S IBERROR=$P(IBFDA,U,2) + . S IBFDA=$P(IBFDA,U,1) + ; + ; If an error, send an email message + I IBERROR'="" D Q + . S MSG(1)="Error returned by $$ADDSTF^IBCNBES:" + . S MSG(2)=IBERROR + . S MSG(3)="Values:" + . S MSG(4)=" Patient DFN = "_$G(DFN) + . S MSG(5)=" Pt Ins Record IEN = "_$G(IRIEN) + . S MSG(6)="Please log a NOIS for this problem." + . S XMSUB="Error creating Buffer Entry." + . D MSG^IBCNEUT5(MSGP,XMSUB,"MSG(") + . K MSGP,MSG,XMSUB,IBERR + ; + ; If need to update a new Buffer Entry ... + ; + ; Variable BUFF is passed into this routine whenever the buffer + ; entry is known and the ADD flag is off. The existing buffer entry + ; is edited in this case. + ; + I $G(ADD)="" D EDITSTF^IBCNBES(BUFF,.VBUF) + ; + ; If an error occurred in EDITSTF, the error array is not returned + ; + Q diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNQ.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNQ.m index 3689f356..19dff9a3 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNQ.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNQ.m @@ -1,123 +1,127 @@ -IBCNQ ;ALB/MJB - MCCR PATIENT BILLING INQUIRY ;6:13 AM 4 Jan 2009 - ;;2.0;INTEGRATED BILLING;**51,320,377**;21-MAR-94;Build 4;WorldVistA 30-Jan-08 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ;Modified from FOIA VISTA, - ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;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 Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - ; - ;MAP TO DGCRNQ - ; - D HOME^%ZIS -ASKPAT S DIC="^DGCR(399,",DIC(0)="AEMQZ",DIC("A")="Enter BILL NUMBER or PATIENT NAME: " W !! D ^DIC G:X=""!(X["^") Q - ; - S IBIFN=+Y,IBQUIT=0,IBAC=7 -VIEW ; - ;*** - F I=0,"S","U","U1" S IB(I)=$G(^DGCR(399,IBIFN,I)) - S DFN=$P(IB(0),"^",2),IBSTAT=$P(IB(0),"^",13),IBBNO=$$BN^PRCAFN(IBIFN),IBPAGE=0 S:IBBNO=-1 IBBNO=$S($D(IBIL):IBIL,1:$P(IB(0),"^")) - ; - D NOW^%DTC S Y=$E(%,1,12) D D^DIQ S IBNOW=Y,IBPT=$$PT^IBEFUNC(DFN) D HDR1 - ; - S IBUN="UNSPECIFIED",IBUK="UNKNOWN USER" - W !,"Bill Status",?15,": ",$S(IBSTAT=1:"ENTERED/NOT REVIEWED",IBSTAT=2:"MRA REQUESTED",IBSTAT=3:"AUTHORIZED",IBSTAT=4:"PRINTED/TRANSMITTED",IBSTAT=7:"CANCELLED",1:IBUN)," - RECORD IS ",$S(IBSTAT=1:"",1:"UN"),"EDITABLE" - W !,"Rate Type",?15,": ",$S($P(IB(0),"^",7)="":IBUN,'$D(^DGCR(399.3,$P(IB(0),"^",7),0)):IBUN,1:$P(^DGCR(399.3,$P(IB(0),"^",7),0),"^")) - W:+$P(^IBE(350.9,1,1),"^",22) !,"Form Type",?15,": ",$S($P($G(^IBE(353,+$P(IB(0),"^",19),0)),"^")]"":$P(^(0),"^"),1:IBUN) - W:IBSTAT=7 !,"Reason Canceled",?15,": ",$S($P(IB("S"),"^",19)]"":$P(IB("S"),"^",19),1:IBUN) - I $$INPAT^IBCEF(IBIFN) S Y=$P(IB(0),"^",3) D D^DIQ W !!,"Admission Date : ",Y - E D OPDATE - W !!,"Charges",?15,": " S X=$P(IB("U1"),U,1),X2="2$" D:X]"" COMMA^%DTC W $S(X]"":X,1:IBUN) - I $P(IB("U1"),U,2)]"" W !,"LESS Offset",?15,": " S X=$P(IB("U1"),U,2),X2="2$" D COMMA^%DTC W X," [",$P(IB("U1"),U,3),"]",!,"Bill Total",?15,": " S X=($P(IB("U1"),U,1)-$P(IB("U1"),U,2)),X2="2$" D COMMA^%DTC W X - S X=$$TPR^PRCAFN(IBIFN) I X>0 S X2="2$" D COMMA^%DTC W !,"Amount Paid",?15,": ",X - S X=$$STA^PRCAFN(IBIFN) I X>0 W !,"AR Status",?15,": ",$P(X,"^",2) - I $P(IB("U"),U)]"" S Y=$P(IB("U"),U) D D^DIQ W !!,"Statement From",?15,": ",Y S Y=$P(IB("U"),"^",2) D D^DIQ W !,"Statement To",?15,": ",Y,! - I $P(IB("U"),U)']"" W !!,"Statement From",?15,": ",IBUN,!,"Statement To",?15,": ",IBUN,! - D DISP I IBQUIT Q:IBAC[8 G Q - I IBSTAT<5 D NOPTF^IBCB2 I 'IBAC1 D:$Y>(IOSL-6) HDR Q:IBQUIT&(IBAC[8) G Q:IBQUIT D NOPTF1^IBCB2 - D PAUSE,^IBOLK1:$G(IBFULL)&('IBQUIT) Q:IBAC[8 ; Called from Outpatient Visit Date Inquiry - G Q:IBQUIT,ASKPAT - ; -DISP ; The variable IBAC must be defined as input to this sub-routine. - G:'$D(IBAC) DISPQ - S IBUN="UNSPECIFIED",IBUK="UNKNOWN USER" - I IB("S")']"" W !,"Past actions of this billing record unspecified." G DISPQ - S IBX="Entered^^^^^^MRA Requested^^^Authorized^^First Printed^^Last Printed^^^Cancelled" - F I=1,7,10,12,14,17 I $P(IB("S"),U,I)]"" D:IBAC[7&($Y>(IOSL-4)) HDR Q:$S(IBAC'[7:0,1:IBQUIT) D DISP1 - ; - ;Patch 320 - Added call to retrieve claim clone history. - N IBCCR,IBCURR,IBNEXT,IBBCH,IBINDENT - S IBINDENT=0 - D EN^IBCCR(IBIFN,.IBCCR) ; utility to pull cloning history - ; - ; attempt to go one claim forward from the current claim - S IBCURR="IBCCR("_+$P(IB("S"),U,1)_","_IBIFN_")" - S IBNEXT=$Q(@IBCURR) - I IBNEXT'="" D - . N IBX S IBX=@IBNEXT - . W !,"Copied" - . W ?15,": ",$$FMTE^XLFDT($P(IBX,U,1),"1Z")_" by "_$P(IBX,U,3) - . W !,"Copied To",?15,": ",$P(IBX,U,2) - . S IBINDENT=1 - . Q - ; - ; now go backwards for claim cloning history all the way back - S IBBCH=IBCURR - ;WVEHR ;begin change 01/04/2009 - ;F S IBBCH=$Q(@IBBCH,-1) Q:IBBCH="" D - F S IBBCH=$$Q^VWUTIL($NA(@IBBCH),-1) Q:IBBCH="" D - .;WVEHR ;end change - . N IBX,TS1,TS2 S IBX=@IBBCH - . I IBINDENT S TS1=4,TS2=19 ; set tab stops - . E S TS1=0,TS2=15 - . W !?TS1,"Copied",?TS2,": " - . W $$FMTE^XLFDT($P(IBX,U,1),"1Z")_" by "_$P(IBX,U,3) - . W !?TS1,"Copied From",?TS2,": ",$P(IBX,U,2) - . W !?TS1,"Reason Copied",?TS2,": ",$P(IBX,U,4) - . S IBINDENT=1 - . Q - ; - I $D(^DGCR(399,IBIFN,"R","AC",1)) S IB=0 F I=0:0 S IB=$O(^DGCR(399,IBIFN,"R","AC",1,IB)) Q:'IB D:IBAC[7&($Y>(IOSL-4)) HDR Q:$S(IBAC'[7:0,1:IBQUIT) W !,"Returned to AR : " D RETN -DISPQ Q - ; -DISP1 W !,$P(IBX,U,I) S Y=$P(IB("S"),U,I) D D^DIQ W ?15,": ",Y,?28," by " S IBN=$P(IB("S"),U,(I+1)) W $S(IBN']"":IBUK,$D(^VA(200,IBN,0)):$P(^(0),U,1),1:IBUK) - Q - ; -Q K DFN,IB,IBAC,IBBNO,IBN,IBNOW,IBPAGE,IBPT,IBU,IBQUIT,IBUK,IBUN,IBX,IBSTAT,IBAC1,IBIFN,IBOPD,DIC,X,X2,Y - Q - ; -RETN I $D(^DGCR(399,IBIFN,"R",IB,0)) S IBN=^(0),Y=$P($P(IBN,"^"),".") D D^DIQ W Y,?28," by " S IBN=$P(IBN,"^",2) I IBN]"",$D(^VA(200,IBN,0)) W $P(^VA(200,IBN,0),"^") - Q - ; -HDR D PAUSE Q:IBQUIT -HDR1 S L="",$P(L,"=",80)="",IBPAGE=IBPAGE+1 - W:$E(IOST,1,2)["C-"!(IBPAGE>1) @IOF - W $E($P(IBPT,"^"),1,20)," ",$P(IBPT,"^",2),?38,IBBNO,?51,IBNOW,?72,"PAGE: ",IBPAGE,!,L - K L Q - ; -OPDATE ; List Outpatient Visit Dates. - Q:'$O(^DGCR(399,IBIFN,"OP",0)) - W !!,"OP Visit Dates :" S IBOPD=0 - F I=1:1 S IBOPD=$O(^DGCR(399,IBIFN,"OP",IBOPD)) Q:'IBOPD D - . W:'((I-1)#4)&(I>1) ! - . S Y=IBOPD D D^DIQ W ?($S(I#4:I#4,1:4)*14+3),Y - Q - ; -PAUSE Q:$E(IOST,1,2)'="C-" - F I=$Y:1:(IOSL-3) W ! - S DIR(0)="E" D ^DIR K DIR I $D(DIRUT)!($D(DUOUT)) S IBQUIT=1 K DIRUT,DTOUT,DUOUT - Q +IBCNQ ;ALB/MJB - MCCR PATIENT BILLING INQUIRY ;7:37 PM 30 Jan 2008 + ;;2.0;INTEGRATED BILLING;**51,320;VWEHR1**;WorldVistA 30-Jan-08 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; + ;Modified from FOIA VISTA, + ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;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 Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + ;MAP TO DGCRNQ + ; + D HOME^%ZIS +ASKPAT S DIC="^DGCR(399,",DIC(0)="AEMQZ",DIC("A")="Enter BILL NUMBER or PATIENT NAME: " W !! D ^DIC G:X=""!(X["^") Q + ; + S IBIFN=+Y,IBQUIT=0,IBAC=7 +VIEW ; + ;*** + ;S XRTL=$ZU(0),XRTN="IBCNQ-2" D T0^%ZOSV ;start rt clock + F I=0,"S","U","U1" S IB(I)=$G(^DGCR(399,IBIFN,I)) + S DFN=$P(IB(0),"^",2),IBSTAT=$P(IB(0),"^",13),IBBNO=$$BN^PRCAFN(IBIFN),IBPAGE=0 S:IBBNO=-1 IBBNO=$S($D(IBIL):IBIL,1:$P(IB(0),"^")) + ; + D NOW^%DTC S Y=$E(%,1,12) D D^DIQ S IBNOW=Y,IBPT=$$PT^IBEFUNC(DFN) D HDR1 + ; + S IBUN="UNSPECIFIED",IBUK="UNKNOWN USER" + W !,"Bill Status",?15,": ",$S(IBSTAT=1:"ENTERED/NOT REVIEWED",IBSTAT=2:"MRA REQUESTED",IBSTAT=3:"AUTHORIZED",IBSTAT=4:"PRINTED/TRANSMITTED",IBSTAT=7:"CANCELLED",1:IBUN)," - RECORD IS ",$S(IBSTAT<3:"",1:"UN"),"EDITABLE" + W !,"Rate Type",?15,": ",$S($P(IB(0),"^",7)="":IBUN,'$D(^DGCR(399.3,$P(IB(0),"^",7),0)):IBUN,1:$P(^DGCR(399.3,$P(IB(0),"^",7),0),"^")) + W:+$P(^IBE(350.9,1,1),"^",22) !,"Form Type",?15,": ",$S($P($G(^IBE(353,+$P(IB(0),"^",19),0)),"^")]"":$P(^(0),"^"),1:IBUN) + W:IBSTAT=7 !,"Reason Canceled",?15,": ",$S($P(IB("S"),"^",19)]"":$P(IB("S"),"^",19),1:IBUN) + I $$INPAT^IBCEF(IBIFN) S Y=$P(IB(0),"^",3) D D^DIQ W !!,"Admission Date : ",Y + E D OPDATE + W !!,"Charges",?15,": " S X=$P(IB("U1"),U,1),X2="2$" D:X]"" COMMA^%DTC W $S(X]"":X,1:IBUN) + I $P(IB("U1"),U,2)]"" W !,"LESS Offset",?15,": " S X=$P(IB("U1"),U,2),X2="2$" D COMMA^%DTC W X," [",$P(IB("U1"),U,3),"]",!,"Bill Total",?15,": " S X=($P(IB("U1"),U,1)-$P(IB("U1"),U,2)),X2="2$" D COMMA^%DTC W X + S X=$$TPR^PRCAFN(IBIFN) I X>0 S X2="2$" D COMMA^%DTC W !,"Amount Paid",?15,": ",X + S X=$$STA^PRCAFN(IBIFN) I X>0 W !,"AR Status",?15,": ",$P(X,"^",2) + I $P(IB("U"),U)]"" S Y=$P(IB("U"),U) D D^DIQ W !!,"Statement From",?15,": ",Y S Y=$P(IB("U"),"^",2) D D^DIQ W !,"Statement To",?15,": ",Y,! + I $P(IB("U"),U)']"" W !!,"Statement From",?15,": ",IBUN,!,"Statement To",?15,": ",IBUN,! + D DISP I IBQUIT Q:IBAC[8 G Q + I IBSTAT<5 D NOPTF^IBCB2 I 'IBAC1 D:$Y>(IOSL-6) HDR Q:IBQUIT&(IBAC[8) G Q:IBQUIT D NOPTF1^IBCB2 + D PAUSE,^IBOLK1:$G(IBFULL)&('IBQUIT) Q:IBAC[8 ; Called from Outpatient Visit Date Inquiry + G Q:IBQUIT,ASKPAT + ; +DISP ; The variable IBAC must be defined as input to this sub-routine. + G:'$D(IBAC) DISPQ + S IBUN="UNSPECIFIED",IBUK="UNKNOWN USER" + I IB("S")']"" W !,"Past actions of this billing record unspecified." G DISPQ + S IBX="Entered^^^^^^MRA Requested^^^Authorized^^^^Last Printed^^^Cancelled" + F I=1,10,14,17 I $P(IB("S"),U,I)]"" D:IBAC[7&($Y>(IOSL-4)) HDR Q:$S(IBAC'[7:0,1:IBQUIT) D DISP1 + ; + ;Patch 320 - Added call to retrieve claim clone history. + N IBCCR,IBCURR,IBNEXT,IBBCH,IBINDENT + S IBINDENT=0 + D EN^IBCCR(IBIFN,.IBCCR) ; utility to pull cloning history + ; + ; attempt to go one claim forward from the current claim + S IBCURR="IBCCR("_+$P(IB("S"),U,1)_","_IBIFN_")" + S IBNEXT=$Q(@IBCURR) + I IBNEXT'="" D + . N IBX S IBX=@IBNEXT + . W !,"Copied" + . W ?15,": ",$$FMTE^XLFDT($P(IBX,U,1),"1Z")_" by "_$P(IBX,U,3) + . W !,"Copied To",?15,": ",$P(IBX,U,2) + . S IBINDENT=1 + . Q + ; + ; now go backwards for claim cloning history all the way back + S IBBCH=IBCURR + ; + ;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1 + ; + ;F S IBBCH=$Q(@IBBCH,-1) Q:IBBCH="" D + F S IBBCH=$$Q^VWUTIL($NA(@IBBCH),-1) Q:IBBCH="" D + . ; + . ;END CHANGE + . ; + . N IBX,TS1,TS2 S IBX=@IBBCH + . I IBINDENT S TS1=4,TS2=19 ; set tab stops + . E S TS1=0,TS2=15 + . W !?TS1,"Copied",?TS2,": " + . W $$FMTE^XLFDT($P(IBX,U,1),"1Z")_" by "_$P(IBX,U,3) + . W !?TS1,"Copied From",?TS2,": ",$P(IBX,U,2) + . W !?TS1,"Reason Copied",?TS2,": ",$P(IBX,U,4) + . S IBINDENT=1 + . Q + ; + I $D(^DGCR(399,IBIFN,"R","AC",1)) S IB=0 F I=0:0 S IB=$O(^DGCR(399,IBIFN,"R","AC",1,IB)) Q:'IB D:IBAC[7&($Y>(IOSL-4)) HDR Q:$S(IBAC'[7:0,1:IBQUIT) W !,"Returned to AR : " D RETN +DISPQ Q + ; +DISP1 W !,$P(IBX,U,I) S Y=$P(IB("S"),U,I) D D^DIQ W ?15,": ",Y,?28," by " S IBN=$P(IB("S"),U,(I+1)) W $S(IBN']"":IBUK,$D(^VA(200,IBN,0)):$P(^(0),U,1),1:IBUK) + Q + ; +Q K DFN,IB,IBAC,IBBNO,IBN,IBNOW,IBPAGE,IBPT,IBU,IBQUIT,IBUK,IBUN,IBX,IBSTAT,IBAC1,IBIFN,IBOPD,DIC,X,X2,Y + Q + ; +RETN I $D(^DGCR(399,IBIFN,"R",IB,0)) S IBN=^(0),Y=$P($P(IBN,"^"),".") D D^DIQ W Y,?28," by " S IBN=$P(IBN,"^",2) I IBN]"",$D(^VA(200,IBN,0)) W $P(^VA(200,IBN,0),"^") + Q + ; +HDR D PAUSE Q:IBQUIT +HDR1 S L="",$P(L,"=",80)="",IBPAGE=IBPAGE+1 + W:$E(IOST,1,2)["C-"!(IBPAGE>1) @IOF + W $E($P(IBPT,"^"),1,20)," ",$P(IBPT,"^",2),?38,IBBNO,?51,IBNOW,?72,"PAGE: ",IBPAGE,!,L + K L Q + ; +OPDATE ; List Outpatient Visit Dates. + Q:'$O(^DGCR(399,IBIFN,"OP",0)) + W !!,"OP Visit Dates :" S IBOPD=0 + F I=1:1 S IBOPD=$O(^DGCR(399,IBIFN,"OP",IBOPD)) Q:'IBOPD D + . W:'((I-1)#4)&(I>1) ! + . S Y=IBOPD D D^DIQ W ?($S(I#4:I#4,1:4)*14+3),Y + Q + ; +PAUSE Q:$E(IOST,1,2)'="C-" + F I=$Y:1:(IOSL-3) W ! + S DIR(0)="E" D ^DIR K DIR I $D(DIRUT)!($D(DUOUT)) S IBQUIT=1 K DIRUT,DTOUT,DUOUT + Q diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNRDV.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNRDV.m index 3615a188..21de84c4 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNRDV.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNRDV.m @@ -1,205 +1,203 @@ -IBCNRDV ;OAKFO/ELZ - INSURANCE INFORMATION EXCHANGE VIA RDV ;27-MAR-03 - ;;2.0;INTEGRATED BILLING;**214,231,361,371**;21-MAR-94;Build 57 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ; This routine is used to exchange insurance information between - ; facilities. -OPT ; Menu option entry point. This is used to select a patient to request - ; information about from the remote treating facilities. - N DFN,DIC,X,Y,DTOUT,DUOUT,IBT,%,%Y,IBX,VADM,IBB,IBD,IBH,IBI,IBICN,IBR,IBRZ,IBX,IBY,IBZ,IBWAIT,IBL,DO,IBTYPE,IB1 - ; - ; prompt for patient -AGAIN S DIC="^DPT(",DIC(0)="AEMNQ" D ^DIC Q:Y<1 S DFN=+Y - ; -BACKGND ; background/tasked entry point - ; IBTYPE is being used as a flag to indicate this is running in background - ; - ; look up treating facilities - K IBT S IBT=$$TFL^IBARXMU(DFN,.IBT) - I IBT<1,'$D(IBTYPE) W !!,"This patient has no remote treating facilities to query." G AGAIN - I IBT<1 Q - ; - ; display and verify we want to do this - I '$D(IBTYPE) D DEM^VADPT W !!,"The patient ",VADM(1)," has the following ",IBT," remote facilitie(s)",! S IBX=0 F S IBX=$O(IBT(IBX)) Q:IBX<1 W !?10,$P(IBT(IBX),"^",2) - I '$D(IBTYPE) W !!,"Do you want to perform this Remote Query" S %=1 D YN^DICN G:%'=1 AGAIN - ; - ; get ICN - S IBICN=$$ICN^IBARXMU(DFN) I 'IBICN,'$D(IBTYPE) W !!,"No ICN for this patient" G AGAIN - I 'IBICN Q - ; - ; sent off the remote queries and get back handles - S IBX=0 F S IBX=$O(IBT(IBX)) Q:IBX<1 D - . D SEND(.IBH,IBX,IBICN,$S($D(IBTYPE):"IBCN INSURANCE QUERY TASK",1:"IBCN INSURANCE QUERY")) - . X $S(IBH(0)'="":"S $P(IBT(IBX),U,5)=IBH(0)",1:"W:'$D(IBTYPE) !,""No handle returned for "",$P(IBT(IBX),U,2) K IBT(IBX)") - ; - ; no handles returned - I $D(IBT)<9,'$D(IBTYPE) W !!,"Unable to perform any remote queries.",! G AGAIN - I $D(IBT)<9 Q - ; - ; go through every IBT() - S IBP="|",IBX=0 F S IBX=$O(IBT(IBX)) Q:IBX<1!($D(IBT)<9) D - . ; - . ; do I have a return data. - . F IBWAIT=1:1:60 W:'$D(IBTYPE) "." H 1 D CHECK(.IBR,$P(IBT(IBX),"^",5)) I $G(IBR(0))["Done" Q - . I $G(IBR(0))'["Done" W:'$D(IBTYPE) !!,"Unable to communicate with ",$P(IBT(IBX),U,2) Q - . K IBR - . D RETURN(.IBR,$P(IBT(IBX),"^",5)) - . ; - . ; no data returned or error message - . S IBRZ=$S(-1=+$G(IBR):IBR,$G(IBR(0))="":$G(IBR(1)),1:$G(IBR(0))) - . ; - . ; no info to proceed - . I IBRZ<1 W:'$D(IBTYPE) !,"Response from ",$P(IBT(IBX),U,2),!,$P(IBRZ,"^",2) K IBT(IBX) D:IBRZ="-1^No insurance on file" FILE(0) Q - . ; - . ; received insurance info, need to file and display message - . W:'$D(IBTYPE) !,"Received ",$G(IBR(0))," insurance companies from ",$P(IBT(IBX),U,2) D FILE(+IBR(0)) - . ; - . S IBY=0 F S IBY=$O(IBR(IBY)) Q:IBY<1 D - .. F IBL=5:1 S IBT=$P($T(MAP+IBL),";",3) Q:IBT="" D - ... ; - ... ; am I on the right MAP line - ... I $P(IBT,IBP,3)=$S(IBY#6:IBY#6,1:6) S IBZ=$P(IBR(IBY),"^",$P(IBT,IBP,4)) I $L(IBZ) D - .... ; - .... ; xecute code to change external to internal - .... X:$L($P(IBT,IBP,7)) $P(IBT,IBP,7) - .... ; - .... ; put the info in the array for the buffer file - .... S:$D(IBZ) IBB($P(IBT,IBP,5))=IBZ - .. ; - .. ; need to avoid duplicates if possible. - .. I $G(IBB(20.01))["MEDICARE (WNR)" S X=0 F S X=$O(^DPT(DFN,.312,X)) Q:X<1 I $P($G(^DIC(36,+$P($G(^DPT(DFN,.312,X,0)),"^"),0)),"^")["MEDICARE (WNR)" K IBB Q - .. Q:'$D(IBB) - .. ; - .. ; file in the buffer file & where else needed - .. I IBY#6=0 D - ... I $L($G(IBB(20.01))) D - .... S IBB(.14)=$$IEN^XUAF4(+IBT(IBX)) - .... S IBB=$$ADDSTF^IBCNBES($G(IBB(.03),1),DFN,.IBB) - ... I '$D(IB1),$D(IBTYPE),$L($G(IBB(20.01))) D SCH^IBTUTL2(DFN,$G(IBSAVEI),$G(IBSAVEJ)):IBTYPE="TRKR",ADM^IBTUTL($G(IBSAVE1),$G(IBSAVE2),$G(IBSAVE3),$G(IBSAVE4)):IBTYPE="ADM" S IB1=1 - ... W:'$D(IBTYPE)&($L($G(IBB(20.01)))) !,$P($G(IBB),"^")," Buffer File entry for ",$G(IBB(20.01)) - ... K IBB - ; - ; flag so I don't do this patient again within 90 days - S ^IBT(356,"ARDV",DFN,$$FMADD^XLFDT(DT,90))="" - ; - Q - ; -RPC(IBD,IBICN) ; RPC entry for looking up insurance info - N DFN,IBZ,IBX,IBY,IBP,IBI,IBT,IBZ - S DFN=$$DFN^IBARXMU(IBICN) I 'DFN S IBD(0)="-1^ICN Not found" Q - D ALL^IBCNS1(DFN,"IBY",3) - I '$D(IBY) S IBD(0)="-1^No insurance on file" Q - ; set up return format - ; IBD(0) = # of insurance companies - S IBD(0)=$G(IBY(0)) - ; - ; where n starts at 1 and increments to 7 for each insurance company - ; IBD(n) = 355.33, zero node format - ; IBD(n+1) = 355.33, 20 node format - ; IBD(n+2) = 355.33, 21 node format - ; IBD(n+3) = 355.33, 40 node format - ; IBD(n+4) = 355.33, 60 node format - ; IBD(n+5) = 355.33, 61 node format - ; IBD(n+6) = 355.33, 62 node format - ; - S IBP="|" - S IBI=0 F S IBI=$O(IBY(IBI)) Q:IBI<1 F IBL=5:1 S IBT=$P($T(MAP+IBL),";",3) Q:IBT="" D - . S IBZ=$P($G(IBY(IBI,+IBT)),"^",$P(IBT,IBP,2)) ; set the existing data - . I $L($P(IBT,IBP,6)) X $P(IBT,IBP,6) ; output transform - . S $P(IBD(IBI-1*7+$P(IBT,IBP,3)),"^",$P(IBT,IBP,4))=IBZ ; set data IBD - Q - ; -MAP ; this is a mapping of data returned from ALL^IBCNS1 to the buffer file - ; format is: node number | piece | extract node | extract piece - ; | 355.33 field number | format out code (if any) - ; | format in code (if any) - ; the extract nodes will be sequential to match buffer file DD - ;;0|1|2|1|20.01|N Z X "F Z=0,.11,.13 S IBY(IBI,36+Z)=$G(^DIC(36,IBZ,Z))" S IBZ=$P(IBY(IBI,36),"^");ins co name - ;;0|2|5|4|60.04;subscriber id - ;;0|4|5|3|60.03;experation date - ;;0|6|5|5|60.05;who's insurance - ;;0|8|5|2|60.02;effective date - ;;0|16|5|6|60.06;pt relationship to insured - ;;0|17|5|7|60.07;name of insured - ;;0|20|5|12|60.12;coordination of benefits - ;;1|3|1|10|.1||I IBZ<$$FMADD^XLFDT(DT,-180) K IBZ;date (last) verified - ;;1|9|1|3|.03;source of information - ;;2|1|6|5|61.05;send bill to employer - ;;2|2|6|6|61.06;employer claims street address (line 1) - ;;2|3|6|7|61.07;employer claims street address line 2 - ;;2|4|6|8|61.08;employer claims street address line 3 - ;;2|5|6|9|61.09;employer claims city - ;;2|6|6|10|61.1|S IBZ=$$EXTERNAL^DILFD(2.312,2.06,"",IBZ)|N DIC,X,Y S DIC="^DIC(5,",X=IBZ,DIC(0)="OX" D ^DIC K:+Y<1 IBZ S:+Y>0 IBZ=+Y;employer claims state - ;;2|7|6|11|61.11;employer claims zip code - ;;2|8|6|12|61.12;employer claims phone - ;;2|10|6|1|61.01;esghp - ;;2|11|6|3|61.03;employment status - ;;2|12|6|4|61.04;retirement date - ;;3|1|5|8|60.08;insured's dob - ;;3|5|5|9|60.09;insured's ssn - ;;3|12|5|13|60.13;insured's sex - ;;4|1|5|10|60.1;primary care provider - ;;4|2|5|11|60.11;primary provider phone - ;;5|1|7|1|62.01;patient id - ;;355.3|2|4|1|40.01;is this a group policy - ;;355.3|3|4|2|40.02;group name - ;;355.3|4|4|3|40.03;group number - ;;355.3|5|4|4|40.04;(is) utilization required - ;;355.3|6|4|5|40.05;(is) pre-certification required - ;;355.3|7|4|7|40.07;exclude pre-existing condition - ;;355.3|8|4|8|40.08;benefits assignable - ;;355.3|9|4|9|40.09;type of plan - ;;355.3|12|4|6|40.06;ambulatory care certification - ;;36|2|2|5|20.05;reimburse - ;;36.11|1|3|1|21.01;street address line 1 - ;;36.11|2|3|2|21.02;street address line 2 - ;;36.11|3|3|3|21.03;street address line 3 - ;;36.11|4|3|4|21.04;city - ;;36.11|5|3|5|21.05|S IBZ=$$EXTERNAL^DILFD(36,.115,"",IBZ)|N DIC,X,Y S DIC="^DIC(5,",X=IBZ,DIC(0)="OX" D ^DIC K:+Y<1 IBZ S:+Y>0 IBZ=+Y;state - ;;36.11|6|3|6|21.06;zip code - ;;36.13|1|2|2|20.02;phone number - ;;36.13|2|2|3|20.03;billing phone number - ;;36.13|3|2|4|20.04;precertification phone number - ;; - ; -SEND(IBH,IBX,IBICN,IBRPC) ; called to send off queries - D EN1^XWB2HL7(.IBH,IBX,IBRPC,"",IBICN) - Q - ; -CHECK(IBR,IBH) ; called to check the return status of an RPC - D RPCCHK^XWB2HL7(.IBR,IBH) - Q - ; -RETURN(IBR,IBH) ; called to get the return data and clear the broker - N IBZ - D RTNDATA^XWBDRPC(.IBR,IBH),CLEAR^XWBDRPC(.IBZ,IBH) - Q - ; -TASK ; queue off task job - N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSK,ZTSAVE - S ZTRTN="BACKGND^IBCNRDV",ZTDESC="Query Remote Facilities for Insurance",ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT),(ZTIO,ZTSAVE("DFN"),ZTSAVE("IBSAVE*"),ZTSAVE("IBTYPE"))="" D ^%ZTLOAD - Q - ; -TRKR(DFN,IBSAVEI,IBSAVEJ,IBDUZ) ; claims tracking entry - N IBTYPE,IBT - Q:$D(^IBT(356,"ARDV",DFN)) ; have already done recently - Q:'$$TFL^IBARXMU(DFN,.IBT) ; no remote facilities - S IBTYPE="TRKR" D - . I DUZ=.5 N DUZ S DUZ=+$G(IBDUZ),DUZ(2)=+$$SITE^VASITE - . D TASK - Q - ; -ADM(DFN,IBSAVE1,IBSAVE2,IBSAVE3,IBSAVE4) ; admit event entry - N IBTYPE S IBTYPE="ADM" D TASK - Q - ; -FILE(IBX) ; updates data into the log file - ;IBX = number of insurance co's found - N DIC,DA,DIE,IBM,DO,X,Y,IBZ,DR - S IBM=$E($$DT^XLFDT,1,5)_"00",DA=+$O(^IBA(355.34,"B",IBM,0)) - I 'DA K DA L +^IBA(355.34,"B",IBM):10 S X=IBM,DIC="^IBA(355.34,",DIC(0)="F" D FILE^DICN S DA=+Y L -^IBA(355.34,"B",IBM) - L +^IBA(355.34,DA):10 - S IBZ=^IBA(355.34,DA,0),DIE="^IBA(355.34," - S DR=".02///"_($P(IBZ,"^",2)+1)_";.03///"_($P(IBZ,"^",3)+IBX) D ^DIE - L -^IBA(355.34,DA) - Q +IBCNRDV ;OAKFO/ELZ - INSURANCE INFORMATION EXCHANGE VIA RDV;27-MAR-03 + ;;2.0;INTEGRATED BILLING;**214,231,361**;21-MAR-94;Build 9 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; + ; This routine is used to exchange insurance information between + ; facilities. +OPT ; Menu option entry point. This is used to select a patient to request + ; information about from the remote treating facilities. + N DFN,DIC,X,Y,DTOUT,DUOUT,IBT,%,%Y,IBX,VADM,IBB,IBD,IBH,IBI,IBICN,IBR,IBRZ,IBX,IBY,IBZ,IBWAIT,IBL,DO,IBTYPE,IB1 + ; + ; prompt for patient +AGAIN S DIC="^DPT(",DIC(0)="AEMNQ" D ^DIC Q:Y<1 S DFN=+Y + ; +BACKGND ; background/tasked entry point + ; IBTYPE is being used as a flag to indicate this is running in background + ; + ; look up treating facilities + K IBT S IBT=$$TFL^IBARXMU(DFN,.IBT) + I IBT<1,'$D(IBTYPE) W !!,"This patient has no remote treating facilities to query." G AGAIN + I IBT<1 Q + ; + ; display and verify we want to do this + I '$D(IBTYPE) D DEM^VADPT W !!,"The patient ",VADM(1)," has the following ",IBT," remote facilitie(s)",! S IBX=0 F S IBX=$O(IBT(IBX)) Q:IBX<1 W !?10,$P(IBT(IBX),"^",2) + I '$D(IBTYPE) W !!,"Do you want to perform this Remote Query" S %=1 D YN^DICN G:%'=1 AGAIN + ; + ; get ICN + S IBICN=$$ICN^IBARXMU(DFN) I 'IBICN,'$D(IBTYPE) W !!,"No ICN for this patient" G AGAIN + I 'IBICN Q + ; + ; sent off the remote queries and get back handles + S IBX=0 F S IBX=$O(IBT(IBX)) Q:IBX<1 D + . D SEND(.IBH,IBX,IBICN,$S($D(IBTYPE):"IBCN INSURANCE QUERY TASK",1:"IBCN INSURANCE QUERY")) + . X $S(IBH(0)'="":"S $P(IBT(IBX),U,5)=IBH(0)",1:"W:'$D(IBTYPE) !,""No handle returned for "",$P(IBT(IBX),U,2) K IBT(IBX)") + ; + ; no handles returned + I $D(IBT)<9,'$D(IBTYPE) W !!,"Unable to perform any remote queries.",! G AGAIN + I $D(IBT)<9 Q + ; + ; go through every IBT() + S IBP="|",IBX=0 F S IBX=$O(IBT(IBX)) Q:IBX<1!($D(IBT)<9) D + . ; + . ; do I have a return data. + . F IBWAIT=1:1:60 W:'$D(IBTYPE) "." H 1 D CHECK(.IBR,$P(IBT(IBX),"^",5)) I $G(IBR(0))["Done" Q + . I $G(IBR(0))'["Done" W:'$D(IBTYPE) !!,"Unable to communicate with ",$P(IBT(IBX),U,2) Q + . K IBR + . D RETURN(.IBR,$P(IBT(IBX),"^",5)) + . ; + . ; no data returned or error message + . S IBRZ=$S(-1=+$G(IBR):IBR,$G(IBR(0))="":$G(IBR(1)),1:$G(IBR(0))) + . ; + . ; no info to proceed + . I IBRZ<1 W:'$D(IBTYPE) !,"Response from ",$P(IBT(IBX),U,2),!,$P(IBRZ,"^",2) K IBT(IBX) D:IBRZ="-1^No insurance on file" FILE(0) Q + . ; + . ; received insurance info, need to file and display message + . W:'$D(IBTYPE) !,"Received ",$G(IBR(0))," insurance companies from ",$P(IBT(IBX),U,2) D FILE(+IBR(0)) + . ; + . S IBY=0 F S IBY=$O(IBR(IBY)) Q:IBY<1 D + .. F IBL=5:1 S IBT=$P($T(MAP+IBL),";",3) Q:IBT="" D + ... ; + ... ; am I on the right MAP line + ... I $P(IBT,IBP,3)=$S(IBY#6:IBY#6,1:6) S IBZ=$P(IBR(IBY),"^",$P(IBT,IBP,4)) I $L(IBZ) D + .... ; + .... ; xecute code to change external to internal + .... X:$L($P(IBT,IBP,7)) $P(IBT,IBP,7) + .... ; + .... ; put the info in the array for the buffer file + .... S:$D(IBZ) IBB($P(IBT,IBP,5))=IBZ + .. ; + .. ; need to avoid duplicates if possible. + .. I $G(IBB(20.01))["MEDICARE (WNR)" S X=0 F S X=$O(^DPT(DFN,.312,X)) Q:X<1 I $P($G(^DIC(36,+$P($G(^DPT(DFN,.312,X,0)),"^"),0)),"^")["MEDICARE (WNR)" K IBB Q + .. Q:'$D(IBB) + .. ; + .. ; file in the buffer file & where else needed + .. I IBY#6=0 D + ... I $L($G(IBB(20.01))) D + .... S IBB(.14)=$$IEN^XUAF4(+IBT(IBX)) + .... S IBB=$$ADDSTF^IBCNBES($G(IBB(.03),1),DFN,.IBB) + ... I '$D(IB1),$D(IBTYPE),$L($G(IBB(20.01))) D SCH^IBTUTL2(DFN,$G(IBSAVEI),$G(IBSAVEJ)):IBTYPE="TRKR",ADM^IBTUTL($G(IBSAVE1),$G(IBSAVE2),$G(IBSAVE3),$G(IBSAVE4)):IBTYPE="ADM" S IB1=1 + ... W:'$D(IBTYPE)&($L($G(IBB(20.01)))) !,$P($G(IBB),"^")," Buffer File entry for ",$G(IBB(20.01)) + ... K IBB + ; + ; flag so I don't do this patient again within 90 days + S ^IBT(356,"ARDV",DFN,$$FMADD^XLFDT(DT,90))="" + ; + Q + ; +RPC(IBD,IBICN) ; RPC entry for looking up insurance info + N DFN,IBZ,IBX,IBY,IBP,IBI,IBT,IBZ + S DFN=$$DFN^IBARXMU(IBICN) I 'DFN S IBD(0)="-1^ICN Not found" Q + D ALL^IBCNS1(DFN,"IBY",3) + I '$D(IBY) S IBD(0)="-1^No insurance on file" Q + ; set up return format + ; IBD(0) = # of insurance companies + S IBD(0)=$G(IBY(0)) + ; + ; where n starts at 1 and increments 6 for each insurance company + ; IBD(n) = 355.33, zero node format + ; IBD(n+1) = 355.33, 20 node format + ; IBD(n+2) = 355.33, 21 node format + ; IBD(n+3) = 355.33, 40 node format + ; IBD(n+4) = 355.33, 60 node format + ; IBD(n+5) = 355.33, 61 node format + ; + S IBP="|" + S IBI=0 F S IBI=$O(IBY(IBI)) Q:IBI<1 F IBL=5:1 S IBT=$P($T(MAP+IBL),";",3) Q:IBT="" D + . S IBZ=$P($G(IBY(IBI,+IBT)),"^",$P(IBT,IBP,2)) ; set the existing data + . I $L($P(IBT,IBP,6)) X $P(IBT,IBP,6) ; output transform + . S $P(IBD(IBI-1*6+$P(IBT,IBP,3)),"^",$P(IBT,IBP,4))=IBZ ; set data IBD + Q + ; +MAP ; this is a mapping of data returned from ALL^IBCNS1 to the buffer file + ; format is: node number | piece | extract node | extract piece + ; | 355.33 field number | format out code (if any) + ; | format in code (if any) + ; the extract nodes will be sequential to match buffer file DD + ;;0|1|2|1|20.01|N Z X "F Z=0,.11,.13 S IBY(IBI,36+Z)=$G(^DIC(36,IBZ,Z))" S IBZ=$P(IBY(IBI,36),"^");ins co name + ;;0|2|5|4|60.04;subscriber id + ;;0|4|5|3|60.03;experation date + ;;0|6|5|5|60.05;who's insurance + ;;0|8|5|2|60.02;effective date + ;;0|16|5|6|60.06;pt relationship to insured + ;;0|17|5|7|60.07;name of insured + ;;0|20|5|12|60.12;coordination of benefits + ;;1|3|1|10|.1||I IBZ<$$FMADD^XLFDT(DT,-180) K IBZ;date (last) verified + ;;1|9|1|3|.03;source of information + ;;2|1|6|5|61.05;send bill to employer + ;;2|2|6|6|61.06;employer claims street address (line 1) + ;;2|3|6|7|61.07;employer claims street address line 2 + ;;2|4|6|8|61.08;employer claims street address line 3 + ;;2|5|6|9|61.09;employer claims city + ;;2|6|6|10|61.1|S IBZ=$$EXTERNAL^DILFD(2.312,2.06,"",IBZ)|N DIC,X,Y S DIC="^DIC(5,",X=IBZ,DIC(0)="OX" D ^DIC K:+Y<1 IBZ S:+Y>0 IBZ=+Y;employer claims state + ;;2|7|6|11|61.11;employer claims zip code + ;;2|8|6|12|61.12;employer claims phone + ;;2|10|6|1|61.01;esghp + ;;2|11|6|3|61.03;employment status + ;;2|12|6|4|61.04;retirement date + ;;3|1|5|8|60.08;insured's dob + ;;3|5|5|9|60.09;insured's ssn + ;;3|12|5|13|60.13;insured's sex + ;;4|1|5|10|60.1;primary care provider + ;;4|2|5|11|60.11;primary provider phone + ;;355.3|2|4|1|40.01;is this a group policy + ;;355.3|3|4|2|40.02;group name + ;;355.3|4|4|3|40.03;group number + ;;355.3|5|4|4|40.04;(is) utilization required + ;;355.3|6|4|5|40.05;(is) pre-certification required + ;;355.3|7|4|7|40.07;exclude pre-existing condition + ;;355.3|8|4|8|40.08;benefits assignable + ;;355.3|9|4|9|40.09;type of plan + ;;355.3|12|4|6|40.06;ambulatory care certification + ;;36|2|2|5|20.05;reimburse + ;;36.11|1|3|1|21.01;street address line 1 + ;;36.11|2|3|2|21.02;street address line 2 + ;;36.11|3|3|3|21.03;street address line 3 + ;;36.11|4|3|4|21.04;city + ;;36.11|5|3|5|21.05|S IBZ=$$EXTERNAL^DILFD(36,.115,"",IBZ)|N DIC,X,Y S DIC="^DIC(5,",X=IBZ,DIC(0)="OX" D ^DIC K:+Y<1 IBZ S:+Y>0 IBZ=+Y;state + ;;36.11|6|3|6|21.06;zip code + ;;36.13|1|2|2|20.02;phone number + ;;36.13|2|2|3|20.03;billing phone number + ;;36.13|3|2|4|20.04;precertification phone number + ;; + ; +SEND(IBH,IBX,IBICN,IBRPC) ; called to send off queries + D EN1^XWB2HL7(.IBH,IBX,IBRPC,"",IBICN) + Q + ; +CHECK(IBR,IBH) ; called to check the return status of an RPC + D RPCCHK^XWB2HL7(.IBR,IBH) + Q + ; +RETURN(IBR,IBH) ; called to get the return data and clear the broker + N IBZ + D RTNDATA^XWBDRPC(.IBR,IBH),CLEAR^XWBDRPC(.IBZ,IBH) + Q + ; +TASK ; queue off task job + N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSK,ZTSAVE + S ZTRTN="BACKGND^IBCNRDV",ZTDESC="Query Remote Facilities for Insurance",ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT),(ZTIO,ZTSAVE("DFN"),ZTSAVE("IBSAVE*"),ZTSAVE("IBTYPE"))="" D ^%ZTLOAD + Q + ; +TRKR(DFN,IBSAVEI,IBSAVEJ,IBDUZ) ; claims tracking entry + N IBTYPE,IBT + Q:$D(^IBT(356,"ARDV",DFN)) ; have already done recently + Q:'$$TFL^IBARXMU(DFN,.IBT) ; no remote facilities + S IBTYPE="TRKR" D + . I DUZ=.5 N DUZ S DUZ=+$G(IBDUZ),DUZ(2)=+$$SITE^VASITE + . D TASK + Q + ; +ADM(DFN,IBSAVE1,IBSAVE2,IBSAVE3,IBSAVE4) ; admit event entry + N IBTYPE S IBTYPE="ADM" D TASK + Q + ; +FILE(IBX) ; updates data into the log file + ;IBX = number of insurance co's found + N DIC,DA,DIE,IBM,DO,X,Y,IBZ,DR + S IBM=$E($$DT^XLFDT,1,5)_"00",DA=+$O(^IBA(355.34,"B",IBM,0)) + I 'DA K DA L +^IBA(355.34,"B",IBM):10 S X=IBM,DIC="^IBA(355.34,",DIC(0)="F" D FILE^DICN S DA=+Y L -^IBA(355.34,"B",IBM) + L +^IBA(355.34,DA):10 + S IBZ=^IBA(355.34,DA,0),DIE="^IBA(355.34," + S DR=".02///"_($P(IBZ,"^",2)+1)_";.03///"_($P(IBZ,"^",3)+IBX) D ^DIE + L -^IBA(355.34,DA) + Q diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNS1.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNS1.m index 58e10360..c6f49c18 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNS1.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNS1.m @@ -1,213 +1,211 @@ -IBCNS1 ;ALB/AAS - INSURANCE MANAGEMENT SUPPORTED FUNCTIONS ;22-JULY-91 - ;;2.0;INTEGRATED BILLING;**28,60,52,85,107,51,137,240,371**;21-MAR-94;Build 57 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -INSURED(DFN,IBINDT) ; -- Is patient insured - ; --Input DFN = patient - ; IBINDT = (optional) date insured (default = today) - ; -- Output = 0 - not insured - ; = 1 - insured - ; - N J,X,IBINS S IBINS=0,J=0 - I '$G(DFN) G INSQ - I '$G(IBINDT) S IBINDT=DT - F S J=$O(^DPT(DFN,.312,J)) Q:'J S X=$G(^(J,0)) S IBINS=$$CHK(X,IBINDT) Q:IBINS -INSQ Q IBINS - ; -PRE(DFN,IBINDT) ; -- is pre-certification required for patient - N X,Y,J,IBPRE - S IBPRE=0,J=0 - S:'$G(IBINDT) IBINDT=DT - F S J=$O(^DPT(DFN,.312,J)) Q:'J S X=$G(^(J,0)) I $$CHK(X,IBINDT),$P($G(^IBA(355.3,+$P(X,"^",18),0)),"^",6) S IBPRE=1 Q -PREQ Q IBPRE - ; -UR(DFN,IBINDT) ; -- is ur required for patient - N X,Y,J,IBPRE - S IBUR=0,J=0 - S:'$G(IBINDT) IBINDT=DT - F S J=$O(^DPT(DFN,.312,J)) Q:'J S X=$G(^(J,0)) I $$CHK(X,IBINDT),$P($G(^IBA(355.3,+$P(X,"^",18),0)),"^",5) S IBUR=1 Q -URQ Q IBUR - ; -CHK(X,Z,Y) ; -- check one entry for active - ; -- Input X = Zeroth node of entry in insurance multiple (2.312) - ; Z = date to check - ; Y = 2 if want will not reimburse - ; = 3 if want will not reimburse AND indemnity plans - ; = 4 if want will not reimburse, but only if it's - ; MEDICARE - ; -- Output 1 = Insurance Active - ; 0 = Inactive - ; - N Z1,X1 - S Z1=0,Y=$G(Y) - I Y'=3,$$INDEM(X) G CHKQ ; is an indemnity policy or company - S X1=$G(^DIC(36,+X,0)) G:X1="" CHKQ ;insurance company entry doesn't exist - I $P(X,"^",8) G:Z<$P(X,"^",8) CHKQ ;effective date later than care - I $P(X,"^",4) G:Z>$P(X,"^",4) CHKQ ;care after expiration date - I $P($G(^IBA(355.3,+$P(X,"^",18),0)),"^",11) G CHKQ ;plan is inactive - G:$P(X1,"^",5) CHKQ ;insurance company inactive - I Y<2 G:$P(X1,"^",2)="N" CHKQ ;insurance company will not reimburse - I Y=4,$P(X1,"^",2)="N",'$$MCRWNR^IBEFUNC(+X) G CHKQ ;only MEDICARE WNR - S Z1=1 -CHKQ Q Z1 - ; -ACTIVE(IBCIFN) ; -- is this company active for this patient for this date - ; -- called from input transform and x-refs for fields 101,102,103 - ; -- input - N ACTIVE,DFN,IBINDT - S DFN=$P(^DGCR(399,DA,0),"^",2),IBINDT=$S(+$G(^DGCR(399,DA,"U")):+$G(^("U")),1:DT) - ; -ACTIVEQ Q ACTIVE - ; -DD ; - called from input transform and x-refs for field 101,102,103 - ; - input requires da=internal entry number in 399 - ; - outputs IBdd(ins co.) array - N DFN S DFN=$P(^DGCR(399,DA,0),"^",2),IBINDT=$S(+$G(^DGCR(399,DA,"U")):+$G(^("U")),1:DT) - D ALLACT -DDQ K IBINDT Q - ; - ; -ALLACT ; -- return active insurance zeroth nodes in ibdd(ins co,entry in mult) - N X,X1 - S (X1,IBDD)=0 - F S X1=$O(^DPT(DFN,.312,X1)) Q:'X1 S X=$G(^(X,0)) I $$CHK(X,IBINDT) S IBDD(+X,X1)=X - ; -ALLACTQ Q - ; -HDR W !?4,"Insurance Co.",?22,"Policy #",?40,"Group",?52,"Holder",?60,"Effective",?70,"Expires" S X="",$P(X,"=",IOM-4)="" W !?4,X - Q - ; - ; -D1 N X Q:'$D(IBINS) - W !?4,$S($D(^DIC(36,+IBINS,0)):$E($P(^(0),"^",1),1,16),1:"UNKNOWN") - W ?22,$E($P(IBINS,"^",2),1,16) - W ?40,$E($$GRP^IBCNS($P(IBINS,"^",18)),1,10) - S X=$P(IBINS,"^",6) W ?52,$S(X="v":"SELF",X="s":"SPOUSE",1:"OTHER") - W ?60,$$DAT1^IBOUTL($P(IBINS,"^",8)),?70,$$DAT1^IBOUTL($P(IBINS,"^",4)) - Q - ; -ALL(DFN,VAR,ACT,ADT,SOP) ; -- find all insurance data on a patient - ; - ; -- input DFN = patient - ; VAR = variable to output in format of abc - ; or abc(dfn) - ; or ^tmp($j,"Insurance") - ; ACT = 1 if only active ins. desired - ; = 2 if active and will not reimburse desired - ; = 3 if active, will not reimburse, and indemnity are - ; all desired (for the $$INSTYP function below) - ; = 4 if only active and MEDICARE WNR only desired - ; ADT = if ACT=1 or 4, then ADT is the internal date to check - ; active for, default = dt - ; SOP = if SOP=1, then sort policies in COB order - ; - ; -- output var(0) =: number of entries insurance multiple - ; var(x,0) =: ^dpt(dfn,.312,x,0) - ; var(x,1) =: ^dpt(dfn,.312,x,1) - ; var(x,2) =: ^dpt(dfn,.312,x,2) - ; var(x,3) =: ^dpt(dfn,.312,x,3) - ; var(x,4) =: ^dpt(dfn,.312,x,4) - ; var(x,5) =: ^dpt(dfn,.312,x,5) - ; var(x,355.3) =: ^iba(355.3,$p(var(x,0),"^",18),0) - ; var("S",COB sequence,x) =: (null) as an xref for COB - ; - N X,IBMRA,IBSP - S X=0 I $G(ACT),$E($G(ADT),1,7)'?7N S ADT=DT - S (IBMRA,IBSP)=0 ;Flag to say if pt has medicare wnr, spouse has policy - F S X=$O(^DPT(DFN,.312,X)) Q:'X I $D(^(X,0)) D - .I $G(ACT),'$$CHK(^DPT(DFN,.312,X,0),ADT,$G(ACT)) Q - .S @VAR@(0)=$G(@VAR@(0))+1 - .S @VAR@(X,0)=$$ZND(DFN,X) - .S @VAR@(X,1)=$G(^DPT(DFN,.312,X,1)) - .S @VAR@(X,2)=$G(^DPT(DFN,.312,X,2)) - .S @VAR@(X,3)=$G(^DPT(DFN,.312,X,3)) - .S @VAR@(X,4)=$G(^DPT(DFN,.312,X,4)) - .S @VAR@(X,5)=$G(^DPT(DFN,.312,X,5)) - .S @VAR@(X,355.3)=$G(^IBA(355.3,+$P($G(^DPT(DFN,.312,X,0)),"^",18),0)) - .I $G(SOP) D - ..N COB,WHO - ..S COB=$P(@VAR@(X,0),U,20) - ..S WHO=$P(@VAR@(X,0),U,6) S:WHO="s" IBSP=1 - ..I $$MCRWNR^IBEFUNC(+@VAR@(X,0)) D - ... S COB=.5,IBMRA=1 - ... - ..S COB=$S(COB'="":COB,WHO="v":1,WHO="s":$S(IBMRA:1,1:2),1:3) - ..S @VAR@("S",COB,X)="" - ..Q - ; Ck for spouse's insurance, move it before any MEDICARE WNR if sorting - I $G(SOP),IBMRA,IBSP D - . ; Shuffle Medicare WNR, if necessary - . S X=0 F S X=$O(@VAR@("S",.5,X)) Q:'X S @VAR@("S",2,X)="" K @VAR@("S",.5,X) - . S X=0 F S X=$O(@VAR@("S",2,X)) Q:'X I $P(@VAR@(X,0),U,6)="s",'$P(@VAR@(X,0),U,20) S @VAR@("S",1,X)="" K @VAR@("S",2,X) -ALLQ Q - ; -ALLWNR(DFN,VAR,ADT) ; Returns 'all active and MEDICARE WNR' - D ALL(DFN,VAR,4,ADT) - Q - ; -ZND(DFN,NODE) ; -- set group number and group name back into zeroth node of ins. type - N X,Y S (X,Y)="" - I '$G(DFN)!('$G(NODE)) G ZNDQ - S X=$G(^DPT(+DFN,.312,+NODE,0)) - S Y=$G(^IBA(355.3,+$P(X,"^",18),0)) I Y="" G ZNDQ - S $P(X,"^",3)=$P(Y,"^",4) ; move group number - S $P(X,"^",15)=$P(Y,"^",3) ; move group name - ; -ZNDQ Q X - ; -INDEM(X) ; -- is this an indemnity plan - ; -- input zeroth node if insurance type field - N IBINDEM,IBCTP - S IBINDEM=1 - I $P($G(^DIC(36,+X,0)),"^",13)=15 G INDEMQ ; company is indemnity co. - S IBCTP=$P($G(^IBA(355.3,+$P(X,"^",18),0)),"^",9) - I IBCTP,$P($G(^IBE(355.1,+IBCTP,0)),"^",3)=9 G INDEMQ ; plan is an indemnity plan - S IBINDEM=0 -INDEMQ Q IBINDEM - ; - ; -INSTYP(DFN,DATE) ; -- return type of insurance policy for patient - ; - ; -- input dfn := pointer to patient file (required) - ; date := date of insurance (optional, default = today) - ; - ; -- output Major Category of type of Plan (file 355.1, field .03) - ; for policy which would be billed first (cob) - ; null no insurance found - ; 1 MAJOR MEDICAL (default) - ; 2 DENTAL - ; 3 HMO - ; 4 PPO - ; 5 MEDICARE - ; 6 MEDICAID - ; 7 TRICARE - ; 8 WORKMANS COMP - ; 9 INDEMNITY - ; 10 PRESCRIPTION - ; 11 MEDICARE SUPPLEMENTAL - ; 12 ALL OTHER - ; - N TYPE,POL,IBCPOL - S TYPE="" - I '$G(DFN) G INSTYPQ - I '$G(DATE) S DATE=DT - D ALL(DFN,"POL",3,DATE) - I $G(POL(0))<1 G INSTYPQ - I $G(POL(0))=1 S IBCPOL=+$O(POL(0)) - I $G(POL(0))>1 S IBCPOL=$$COB(.POL) - ; - I IBCPOL S TYPE=$P($G(^IBE(355.1,+$P($G(POL(IBCPOL,355.3)),"^",9),0)),"^",3) - I TYPE="" S TYPE=1 ;default is major medical - ; -INSTYPQ Q TYPE - ; -COB(POL) ; -- find policy with high coordination of benefits - N I,X,IBC,COB,WHO,IBCOB - ; - S IBC="" - S I=0 F S I=$O(POL(I)) Q:'I D - .S WHO=$P($G(POL(I,0)),"^",6),COB=$P($G(POL(I,0)),"^",20) - .S X=$S(COB'="":COB,WHO="v":1,WHO="s":2,1:3) - .I 'IBC S IBC=I,IBCOB=X Q - .I X$P(X,"^",4) CHKQ ;care after expiration date + I $P($G(^IBA(355.3,+$P(X,"^",18),0)),"^",11) G CHKQ ;plan is inactive + G:$P(X1,"^",5) CHKQ ;insurance company inactive + I Y<2 G:$P(X1,"^",2)="N" CHKQ ;insurance company will not reimburse + I Y=4,$P(X1,"^",2)="N",'$$MCRWNR^IBEFUNC(+X) G CHKQ ;only MEDICARE WNR + S Z1=1 +CHKQ Q Z1 + ; +ACTIVE(IBCIFN) ; -- is this company active for this patient for this date + ; -- called from input transform and x-refs for fields 101,102,103 + ; -- input + N ACTIVE,DFN,IBINDT + S DFN=$P(^DGCR(399,DA,0),"^",2),IBINDT=$S(+$G(^DGCR(399,DA,"U")):+$G(^("U")),1:DT) + ; +ACTIVEQ Q ACTIVE + ; +DD ; - called from input transform and x-refs for field 101,102,103 + ; - input requires da=internal entry number in 399 + ; - outputs IBdd(ins co.) array + N DFN S DFN=$P(^DGCR(399,DA,0),"^",2),IBINDT=$S(+$G(^DGCR(399,DA,"U")):+$G(^("U")),1:DT) + D ALLACT +DDQ K IBINDT Q + ; + ; +ALLACT ; -- return active insurance zeroth nodes in ibdd(ins co,entry in mult) + N X,X1 + S (X1,IBDD)=0 + F S X1=$O(^DPT(DFN,.312,X1)) Q:'X1 S X=$G(^(X,0)) I $$CHK(X,IBINDT) S IBDD(+X,X1)=X + ; +ALLACTQ Q + ; +HDR W !?4,"Insurance Co.",?22,"Policy #",?40,"Group",?52,"Holder",?60,"Effective",?70,"Expires" S X="",$P(X,"=",IOM-4)="" W !?4,X + Q + ; + ; +D1 N X Q:'$D(IBINS) + W !?4,$S($D(^DIC(36,+IBINS,0)):$E($P(^(0),"^",1),1,16),1:"UNKNOWN") + W ?22,$E($P(IBINS,"^",2),1,16) + W ?40,$E($$GRP^IBCNS($P(IBINS,"^",18)),1,10) + S X=$P(IBINS,"^",6) W ?52,$S(X="v":"SELF",X="s":"SPOUSE",1:"OTHER") + W ?60,$$DAT1^IBOUTL($P(IBINS,"^",8)),?70,$$DAT1^IBOUTL($P(IBINS,"^",4)) + Q + ; +ALL(DFN,VAR,ACT,ADT,SOP) ; -- find all insurance data on a patient + ; + ; -- input DFN = patient + ; VAR = variable to output in format of abc + ; or abc(dfn) + ; or ^tmp($j,"Insurance") + ; ACT = 1 if only active ins. desired + ; = 2 if active and will not reimburse desired + ; = 3 if active, will not reimburse, and indemnity are + ; all desired (for the $$INSTYP function below) + ; = 4 if only active and MEDICARE WNR only desired + ; ADT = if ACT=1 or 4, then ADT is the internal date to check + ; active for, default = dt + ; SOP = if SOP=1, then sort policies in COB order + ; + ; -- output var(0) =: number of entries insurance multiple + ; var(x,0) =: ^dpt(dfn,.312,x,0) + ; var(x,1) =: ^dpt(dfn,.312,x,1) + ; var(x,2) =: ^dpt(dfn,.312,x,2) + ; var(x,3) =: ^dpt(dfn,.312,x,3) + ; var(x,4) =: ^dpt(dfn,.312,x,4) + ; var(x,355.3) =: ^iba(355.3,$p(var(x,0),"^",18),0) + ; var("S",COB sequence,x) =: (null) as an xref for COB + ; + N X,IBMRA,IBSP + S X=0 I $G(ACT),$E($G(ADT),1,7)'?7N S ADT=DT + S (IBMRA,IBSP)=0 ;Flag to say if pt has medicare wnr, spouse has policy + F S X=$O(^DPT(DFN,.312,X)) Q:'X I $D(^(X,0)) D + .I $G(ACT),'$$CHK(^DPT(DFN,.312,X,0),ADT,$G(ACT)) Q + .S @VAR@(0)=$G(@VAR@(0))+1 + .S @VAR@(X,0)=$$ZND(DFN,X) + .S @VAR@(X,1)=$G(^DPT(DFN,.312,X,1)) + .S @VAR@(X,2)=$G(^DPT(DFN,.312,X,2)) + .S @VAR@(X,3)=$G(^DPT(DFN,.312,X,3)) + .S @VAR@(X,4)=$G(^DPT(DFN,.312,X,4)) + .S @VAR@(X,355.3)=$G(^IBA(355.3,+$P($G(^DPT(DFN,.312,X,0)),"^",18),0)) + .I $G(SOP) D + ..N COB,WHO + ..S COB=$P(@VAR@(X,0),U,20) + ..S WHO=$P(@VAR@(X,0),U,6) S:WHO="s" IBSP=1 + ..I $$MCRWNR^IBEFUNC(+@VAR@(X,0)) D + ... S COB=.5,IBMRA=1 + ... + ..S COB=$S(COB'="":COB,WHO="v":1,WHO="s":$S(IBMRA:1,1:2),1:3) + ..S @VAR@("S",COB,X)="" + ..Q + ; Ck for spouse's insurance, move it before any MEDICARE WNR if sorting + I $G(SOP),IBMRA,IBSP D + . ; Shuffle Medicare WNR, if necessary + . S X=0 F S X=$O(@VAR@("S",.5,X)) Q:'X S @VAR@("S",2,X)="" K @VAR@("S",.5,X) + . S X=0 F S X=$O(@VAR@("S",2,X)) Q:'X I $P(@VAR@(X,0),U,6)="s",'$P(@VAR@(X,0),U,20) S @VAR@("S",1,X)="" K @VAR@("S",2,X) +ALLQ Q + ; +ALLWNR(DFN,VAR,ADT) ; Returns 'all active and MEDICARE WNR' + D ALL(DFN,VAR,4,ADT) + Q + ; +ZND(DFN,NODE) ; -- set group number and group name back into zeroth node of ins. type + N X,Y S (X,Y)="" + I '$G(DFN)!('$G(NODE)) G ZNDQ + S X=$G(^DPT(+DFN,.312,+NODE,0)) + S Y=$G(^IBA(355.3,+$P(X,"^",18),0)) I Y="" G ZNDQ + S $P(X,"^",3)=$P(Y,"^",4) ; move group number + S $P(X,"^",15)=$P(Y,"^",3) ; move group name + ; +ZNDQ Q X + ; +INDEM(X) ; -- is this an indemnity plan + ; -- input zeroth node if insurance type field + N IBINDEM,IBCTP + S IBINDEM=1 + I $P($G(^DIC(36,+X,0)),"^",13)=15 G INDEMQ ; company is indemnity co. + S IBCTP=$P($G(^IBA(355.3,+$P(X,"^",18),0)),"^",9) + I IBCTP,$P($G(^IBE(355.1,+IBCTP,0)),"^",3)=9 G INDEMQ ; plan is an indemnity plan + S IBINDEM=0 +INDEMQ Q IBINDEM + ; + ; +INSTYP(DFN,DATE) ; -- return type of insurance policy for patient + ; + ; -- input dfn := pointer to patient file (required) + ; date := date of insurance (optional, default = today) + ; + ; -- output Major Category of type of Plan (file 355.1, field .03) + ; for policy which would be billed first (cob) + ; null no insurance found + ; 1 MAJOR MEDICAL (default) + ; 2 DENTAL + ; 3 HMO + ; 4 PPO + ; 5 MEDICARE + ; 6 MEDICAID + ; 7 TRICARE + ; 8 WORKMANS COMP + ; 9 INDEMNITY + ; 10 PRESCRIPTION + ; 11 MEDICARE SUPPLEMENTAL + ; 12 ALL OTHER + ; + N TYPE,POL,IBCPOL + S TYPE="" + I '$G(DFN) G INSTYPQ + I '$G(DATE) S DATE=DT + D ALL(DFN,"POL",3,DATE) + I $G(POL(0))<1 G INSTYPQ + I $G(POL(0))=1 S IBCPOL=+$O(POL(0)) + I $G(POL(0))>1 S IBCPOL=$$COB(.POL) + ; + I IBCPOL S TYPE=$P($G(^IBE(355.1,+$P($G(POL(IBCPOL,355.3)),"^",9),0)),"^",3) + I TYPE="" S TYPE=1 ;default is major medical + ; +INSTYPQ Q TYPE + ; +COB(POL) ; -- find policy with high coordination of benefits + N I,X,IBC,COB,WHO,IBCOB + ; + S IBC="" + S I=0 F S I=$O(POL(I)) Q:'I D + .S WHO=$P($G(POL(I,0)),"^",6),COB=$P($G(POL(I,0)),"^",20) + .S X=$S(COB'="":COB,WHO="v":1,WHO="s":2,1:3) + .I 'IBC S IBC=I,IBCOB=X Q + .I X7:" ...edit to see more...",1:" "_SYN)) - Q - ; +IBCNSC01 ;ALB/NLR - INSURANCE COMPANY EDIT ; 6/1/05 10:06am + ;;2.0;INTEGRATED BILLING;**52,137,191,184,232,320,349**;21-MAR-94;Build 46 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; +PARAM ; -- Insurance company parameters region + N OFFSET,START,IBCNS0,IBCNS03,IBCNS06,IBCNS08,IBCNS13,IBCNS3 + S IBCNS0=$G(^DIC(36,+IBCNS,0)),IBCNS3=$G(^(3)) + S IBCNS03=$P(IBCNS0,"^",3),IBCNS06=$P(IBCNS0,"^",6),IBCNS08=$P(IBCNS0,"^",8) + S IBCNS13=$G(^DIC(36,+IBCNS,.13)) + S START=1,OFFSET=2 + D SET^IBCNSP(START,OFFSET+25," Billing Parameters ",IORVON,IORVOFF) + ; + D SET^IBCNSP(START+1,OFFSET+1,"Signature Required?: "_$S(+IBCNS03:"YES",1:"NO")) + D SET^IBCNSP(START+2,OFFSET+10,"Reimburse?: "_$E($$EXPAND^IBTRE(36,1,$P(IBCNS0,"^",2)),1,21)) + D SET^IBCNSP(START+3,OFFSET+3,"Mult. Bedsections: "_$S(+IBCNS06:"YES",IBCNS06=0:"NO",1:"")) + D SET^IBCNSP(START+4,OFFSET+4,"Diff. Rev. Codes: "_$P(IBCNS0,"^",7)) + D SET^IBCNSP(START+5,OFFSET+6,"One Opt. Visit: "_$S(+IBCNS08:"YES",1:"NO")) + D SET^IBCNSP(START+6,OFFSET+1,"Amb. Sur. Rev. Code: "_$P(IBCNS0,"^",9)) + D SET^IBCNSP(START+7,OFFSET+1,"Rx Refill Rev. Code: "_$P(IBCNS0,"^",15)) + D SET^IBCNSP(START+8,OFFSET+3,"Filing Time Frame: "_$P(IBCNS0,"^",12)) + D SET^IBCNSP(START+9,OFFSET+4,"Type Of Coverage: "_$$EXPAND^IBTRE(36,.13,+$P(IBCNS0,U,13))) + D SET^IBCNSP(START+10,OFFSET+3,"Primary Form Type: "_$$EXPAND^IBTRE(36,.14,$P(IBCNS0,"^",14))) + ; + N START,OFFSET + S START=1,OFFSET=45 + D SET^IBCNSP(START+1,OFFSET+7,"Billing Phone: "_$P(IBCNS13,"^",2)) + D SET^IBCNSP(START+2,OFFSET+2,"Verification Phone: "_$P(IBCNS13,"^",4)) + D SET^IBCNSP(START+3,OFFSET+2,"Precert Comp. Name: "_$P($G(^DIC(36,+$P(IBCNS13,"^",9),0)),"^",1)) + D SET^IBCNSP(START+4,OFFSET+7,"Precert Phone: "_$$PHONE(IBCNS13)) + D SET^IBCNSP(START+5,OFFSET+6," *** EDI Parameters *** ",IOINHI,IOINORM) + D SET^IBCNSP(START+6,OFFSET+11,"Transmit?: "_$S(+IBCNS3=1:"YES-LIVE",+IBCNS3=2:"TEST ONLY",1:"NO")) + D SET^IBCNSP(START+7,OFFSET+7,"Inst Payer ID: "_$P(IBCNS3,U,4)) + D SET^IBCNSP(START+8,OFFSET+7,"Prof Payer ID: "_$P(IBCNS3,U,2)) + D SET^IBCNSP(START+9,OFFSET+6,"Insurance Type: "_$$EXPAND^IBTRE(36,3.09,+$P(IBCNS3,U,9))) + D SET^IBCNSP(START+10,OFFSET+10,"Bin Number: "_$P($G(^DIC(36,+IBCNS,3)),"^",3)) + I +IBCNS3=2 D SET^IBCNSP(START+11,OFFSET,"Max # Test Bills/Day: "_$P(IBCNS3,U,6)) + Q + ; +PHONE(IBCNS13) ; -- Compute precert company phone + N IBX,IBSAVE,IBCNT S IBX="" + I '$P(IBCNS13,"^",9) S IBX=$P(IBCNS13,"^",3) G PHONEQ +REDOX S IBSAVE=+$P(IBCNS13,"^",9) + S IBCNT=$G(IBCNT)+1 + ; -- if you process the same co. more than once you are in an infinite loop + I $D(IBCNT(IBCNS)) G PHONEQ + S IBCNT(IBCNS)="" + S IBCNS13=$G(^DIC(36,+$P(IBCNS13,"^",9),.13)) + S IBX=$P(IBCNS13,"^") S:$L($P(IBCNS13,"^",3)) IBX=$P(IBCNS13,"^",3) + ; -- if process the same co. more than once you are in an infinite loop + I $P(IBCNS13,"^",9),$P(IBCNS13,"^",9)'=IBSAVE G REDOX +PHONEQ Q IBX + ; +MAIN ; -- Insurance company main address + N OFFSET,START,IBCNS11,IBCNS13,IBADD + S IBCNS11=$G(^DIC(36,+IBCNS,.11)) + S IBCNS13=$G(^DIC(36,+IBCNS,.13)) + S START=15,OFFSET=25 + D SET^IBCNSP(START,OFFSET," Main Mailing Address ",IORVON,IORVOFF) + N OFFSET S OFFSET=2 + D SET^IBCNSP(START+1,OFFSET," Street: "_$P(IBCNS11,"^",1)) S IBADD=1 + D SET^IBCNSP(START+2,OFFSET," Street 2: "_$P(IBCNS11,"^",2)) S IBADD=2 + D SET^IBCNSP(START+3,OFFSET," Street 3: "_$P(IBCNS11,"^",3)) S IBADD=3 + ; D SET^IBCNSP(START+4,OFFSET,"Claim Off. ID: "_$P(IBCNS11,U,11)) + N OFFSET S OFFSET=45 + D SET^IBCNSP(START+1,OFFSET," City/State: "_$E($P(IBCNS11,"^",4),1,15)_$S($P(IBCNS11,"^",4)="":"",1:", ")_$P($G(^DIC(5,+$P(IBCNS11,"^",5),0)),"^",2)_" "_$E($P(IBCNS11,"^",6),1,5)) + D SET^IBCNSP(START+2,OFFSET," Phone: "_$P(IBCNS13,"^",1)) + D SET^IBCNSP(START+3,OFFSET," Fax: "_$P(IBCNS11,"^",9)) + Q + ; + ; +PAYER ; This procedure builds the display for the payer associated with + ; this insurance company. + ; ESG - 7/29/02 - IIV project + ; + NEW PAYERIEN,PAYR,APPDATA,APP,DATA,APPNAME,A1,A2,A3,A4,A5,A6,A7,A8 + NEW START,TITLE,OFFSET,IBLINE + S PAYERIEN=$P($G(^DIC(36,+IBCNS,3)),U,10),PAYR="",APPDATA=0 + I PAYERIEN D + . S PAYR=$G(^IBE(365.12,PAYERIEN,0)) + . S APP=0 + . F S APP=$O(^IBE(365.12,PAYERIEN,1,APP)) Q:'APP D + .. S DATA=$G(^IBE(365.12,PAYERIEN,1,APP,0)) + .. S APPNAME=$$EXTERNAL^DILFD(365.121,.01,"",$P(DATA,U,1)) + .. I APPNAME="" Q + .. I $D(APPDATA(APPNAME)) Q + .. S (A1,A2,A3,A4,A5,A6,A7)="NO",A8="" + .. I $P(DATA,U,2) S A1="YES" ; national active + .. I $P(DATA,U,3) S A2="YES" ; local active + .. I $P(DATA,U,7) S A3="YES" ; auto-accept + .. I $P(DATA,U,8) S A4="YES" ; ident inquiries require subscr ID + .. I $P(DATA,U,9) S A5="YES" ; use SSN for subscriber ID + .. I $P(DATA,U,10) S A6="YES" ; transmit SSN + .. I $P(DATA,U,11) S A7="YES" ; deactivated? + .. ; A8 = deactivation date + .. I $P(DATA,U,12) S A8=$P($$FMTE^XLFDT($P(DATA,U,12),"5Z"),"@",1) + .. S APPDATA(APPNAME)=A1_U_A2_U_A3_U_A4_U_A5_U_A6_U_A7_U_A8 + .. S APPDATA=APPDATA+1 + .. Q + . Q + ; + S START=$O(^TMP("IBCNSC",$J,""),-1)+1 + S IB1ST("PAYER")=START + S TITLE=" Payer Information/Electronic Insurance Verification " + S OFFSET=(40-($L(TITLE)/2))\1+1 + D SET^IBCNSP(START,OFFSET,TITLE,IORVON,IORVOFF) + D SET^IBCNSP(START+1,9,"Payer Name: "_$P(PAYR,U,1)) + D SET^IBCNSP(START+2,5,"VA National ID: "_$P(PAYR,U,2)) + D SET^IBCNSP(START+2,51,"CMS National ID: "_$P(PAYR,U,3)) + S IBLINE=START+2 + ; + ; Handle the case where no application data is defined + I 'APPDATA D G PAYERX + . S IBLINE=IBLINE+1 + . D SET^IBCNSP(IBLINE,2," ") ; blank line + . S IBLINE=IBLINE+1 + . D SET^IBCNSP(IBLINE,16,"Payer Application data is not defined!") + . Q + ; + ; Display all the applications + S APPNAME="" + F S APPNAME=$O(APPDATA(APPNAME)) Q:APPNAME="" D + . S IBLINE=IBLINE+1 + . D SET^IBCNSP(IBLINE,2," ") ; blank line + . ; + . S IBLINE=IBLINE+1 + . D SET^IBCNSP(IBLINE,2,"Payer Application: "_APPNAME) + . D SET^IBCNSP(IBLINE,50,"Auto-Accept Info: "_$P(APPDATA(APPNAME),U,3)) + . ; + . S IBLINE=IBLINE+1 + . D SET^IBCNSP(IBLINE,4,"National Active: "_$P(APPDATA(APPNAME),U,1)) + . D SET^IBCNSP(IBLINE,47,"Ident Req Subscr ID: "_$P(APPDATA(APPNAME),U,4)) + . ; + . S IBLINE=IBLINE+1 + . D SET^IBCNSP(IBLINE,7,"Local Active: "_$P(APPDATA(APPNAME),U,2)) + . D SET^IBCNSP(IBLINE,51,"SSN = Subscr ID: "_$P(APPDATA(APPNAME),U,5)) + . ; + . S IBLINE=IBLINE+1 + . D SET^IBCNSP(IBLINE,8,"Deactivated: "_$P(APPDATA(APPNAME),U,7)) + . D SET^IBCNSP(IBLINE,54,"Transmit SSN: "_$P(APPDATA(APPNAME),U,6)) + . ; + . ; If no deactivated date, then exit + . I $P(APPDATA(APPNAME),U,8)="" Q + . ; + . S IBLINE=IBLINE+1 + . D SET^IBCNSP(IBLINE,13,"D-Date: "_$P(APPDATA(APPNAME),U,8)) + . ; + . Q +PAYERX ; + ; Two trailing blank lines after payer information display + S IBLINE=IBLINE+1 + D SET^IBCNSP(IBLINE,2," ") ; blank line + S IBLINE=IBLINE+1 + D SET^IBCNSP(IBLINE,2," ") ; blank line + Q + ; + ; +REMARKS ; + ; + N OFFSET,START,IBLCNT,IBI + S START=$O(^TMP("IBCNSC",$J,""),-1)+1,OFFSET=2 + S IB1ST("REM")=START + ; + D SET^IBCNSP(START,OFFSET," Remarks ",IORVON,IORVOFF) + S (IBLCNT,IBI)=0 F S IBI=$O(^DIC(36,+IBCNS,11,IBI)) Q:IBI<1 D + . S IBLCNT=IBLCNT+1 + . D SET^IBCNSP(START+IBLCNT,OFFSET," "_$E($G(^DIC(36,+IBCNS,11,IBI,0)),1,80)) + . Q + D SET^IBCNSP(START+IBLCNT+1,OFFSET," ") ; blank line after remarks + Q + ; +SYN ; + N OFFSET,START,SYN,SYNOI + S START=$O(^TMP("IBCNSC",$J,""),-1)+1,OFFSET=2 + S IB1ST("SYN")=START + D SET^IBCNSP(START,OFFSET," Synonyms ",IORVON,IORVOFF) + S SYN="" F SYNOI=1:1:8 S SYN=$O(^DIC(36,+IBCNS,10,"B",SYN)) Q:SYN="" D SET^IBCNSP(START+SYNOI,OFFSET,$S(SYNOI>7:" ...edit to see more...",1:" "_SYN)) + Q + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSC02.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSC02.m index cabf3bcb..cd9a28c6 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSC02.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSC02.m @@ -1,254 +1,254 @@ -IBCNSC02 ;ALB/ESG - Insurance Company parent/child management ;01-NOV-2005 - ;;2.0;INTEGRATED BILLING;**320,371**;21-MAR-94;Build 57 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - Q - ; -DISP ; entry point for display of parent/child companies - NEW PCFLG,PARENT,PCDESC,TITLE,START,IBLINE,OFFSET,INSDATA,CNT,TXT - S PCFLG=$P($G(^DIC(36,+IBCNS,3)),U,13),PARENT="" - I PCFLG="C" S PARENT=$P($G(^DIC(36,+IBCNS,3)),U,14),PCDESC="Child" - I PCFLG="P" S PCDESC="Parent" - S TITLE=" Associated Insurance Companies " - S (START,IBLINE)=62 - S OFFSET=(40-($L(TITLE)/2))\1+1 - D SET^IBCNSP(START,OFFSET,TITLE,IORVON,IORVOFF) - ; - ; no link - display this and get out - I PCFLG="" D G DISPX - . S IBLINE=IBLINE+1 - . D SET^IBCNSP(IBLINE,3,"This insurance company is not defined as either a Parent or a Child.") - . Q - ; - ; display for either parent or child - S IBLINE=IBLINE+1 - D SET^IBCNSP(IBLINE,3,"This insurance company is defined as a "_PCDESC_" Insurance Company.") - ; - ; child display - I PCFLG="C" D G DISPX - . S IBLINE=IBLINE+1 - . D SET^IBCNSP(IBLINE,3,"It is associated with the following Parent Insurance Company:") - . S IBLINE=IBLINE+1 - . D SET^IBCNSP(IBLINE,2," ") ; blank line - . S INSDATA="" - . I 'PARENT S INSDATA="*** Parent Insurance Company not defined ***" - . I PARENT D - .. N AD S AD=$$INSADD(PARENT) ; get parent ins co data - .. S INSDATA=$P(AD,U,1)_" "_$P(AD,U,2)_" "_$P(AD,U,6) - .. Q - . S IBLINE=IBLINE+1 - . D SET^IBCNSP(IBLINE,8,INSDATA) - . Q - ; - ; parent display - S CNT=$$PCNT(IBCNS) ; count # of children - S TXT="There are "_CNT_" Child Insurance Companies" - I CNT=1 S TXT="There is 1 Child Insurance Company" - S TXT=TXT_" associated with it." - S IBLINE=IBLINE+1 - D SET^IBCNSP(IBLINE,3,TXT) - S IBLINE=IBLINE+1 - D SET^IBCNSP(IBLINE,3,"Select the ""AC Associate Companies"" action to enter/edit the children.") - ; -DISPX ; end with 2 blank lines - S IBLINE=IBLINE+1 - D SET^IBCNSP(IBLINE,2," ") ; blank line - S IBLINE=IBLINE+1 - D SET^IBCNSP(IBLINE,2," ") ; blank line - Q - ; -PARENT(IBCNS) ; Insurance company parent/child management - ; Calls ListMan screen for parent insurance companies - NEW PCFLG - I '$G(IBCNS) G PARENTX - S PCFLG=$P($G(^DIC(36,IBCNS,3)),U,13) - ; - ; special check to remove 3.13 field if 3.14 field is nil - I PCFLG="C",'$P($G(^DIC(36,IBCNS,3)),U,14) D - . N DIE,DA,DR S DIE=36,DA=IBCNS,DR="3.13////@" D ^DIE - . Q - ; - ; get out if not a parent insurance company - I PCFLG'="P" G PARENTX - ; - ; call ListMan for parent/children management - D EN^VALM("IBCNS ASSOCIATIONS LIST") - KILL ^TMP($J,"IBCNSL") -PARENTX ; - Q - ; -HDR ; List header info - S VALMHDR(1)="Parent Insurance Company:" - S VALMHDR(2)=" "_$$INSCO(IBCNS) - S VALMHDR(3)="" -HDRX ; - Q - ; -BLD ; Build list contents - NEW C,INSDATA,INSNAME,STCITY,ENTRY,NM,ST,IEN,X - KILL ^TMP($J,"IBCNSL") - S C=0 - F S C=$O(^DIC(36,"APC",IBCNS,C)) Q:'C D - . S INSDATA=$$INSADD(C) - . S INSNAME=$P(INSDATA,U,1) - . I INSNAME="" S INSNAME="~UNKNOWN" - . S STCITY=$P(INSDATA,U,7) - . I STCITY="" S STCITY="~UNKNOWN" - . S ^TMP($J,"IBCNSL",1,INSNAME,STCITY,C)="" - . Q - ; - I '$D(^TMP($J,"IBCNSL",1)) D G BLDX - . ; no children insurance companies found - . S ^TMP($J,"IBCNSL",2,1,0)="" - . S ^TMP($J,"IBCNSL",2,2,0)=" No Children Insurance Companies Found" - . S VALMCNT=2 - . Q - ; - S VALMCNT=0,ENTRY=0 - S NM="" - F S NM=$O(^TMP($J,"IBCNSL",1,NM)) Q:NM="" D - . S ST="" - . F S ST=$O(^TMP($J,"IBCNSL",1,NM,ST)) Q:ST="" D - .. S IEN=0 - .. F S IEN=$O(^TMP($J,"IBCNSL",1,NM,ST,IEN)) Q:'IEN D - ... S VALMCNT=VALMCNT+1,ENTRY=ENTRY+1 - ... S X=$$FO^IBCNEUT1($J(ENTRY,3),5)_$$INSCO(IEN) - ... S ^TMP($J,"IBCNSL",2,VALMCNT,0)=X - ... S ^TMP($J,"IBCNSL",2,"IDX",VALMCNT,ENTRY)="" - ... S ^TMP($J,"IBCNSL",3,ENTRY)=IEN_U_VALMCNT - ... Q - .. Q - . Q -BLDX ; - Q - ; -LINK ; action protocol IBCNSL LINK used to associate children insurance - ; companies to the current parent ins co for the list - NEW DIC,X,Y,DIE,DR,DA,NEWINS,IBSTOP,PAR,DIR,DIRUT,DTOUT,DUOUT,DIROUT - D FULL^VALM1 - I '$$KCHK^XUSRB("IB EDI INSURANCE EDIT") D G LINKX - . W !!?5,"You must hold the IB EDI INSURANCE EDIT key to access this option." - . D PAUSE^VALM1 - . Q - ; - ; lookup ins company - W ! - S DIC=36,DIC(0)="AEMQ",DIC("A")="Select Insurance Company: " - S DIC("W")="D INSLIST^IBCNSC02(Y)" - ; screen - ins co Y is not a parent and also it is not already in the list of children - S DIC("S")="I $P($G(^DIC(36,Y,3)),U,13)'=""P""&'$D(^DIC(36,""APC"",IBCNS,Y))" - D ^DIC K DIC - I +Y'>0 G LINKX - S NEWINS=+Y - ; - ; check to see if this selected insurance company is already a child - ; for some other parent - S PAR=+$P($G(^DIC(36,NEWINS,3)),U,14),IBSTOP=0 - I PAR,PAR'=IBCNS D - . W ! - . S DIR(0)="YO",DIR("B")="No" - . S DIR("A",1)="Please Note: The insurance company you selected is currently identified" - . S DIR("A",2)="as a Child insurance company associated with the following Parent:" - . S DIR("A",3)="" - . S DIR("A",4)=" "_$$INSCO(PAR) - . S DIR("A",5)="" - . S DIR("A")="OK to proceed and make this switch" - . D ^DIR K DIR - . I Y'=1 S IBSTOP=1 Q - . Q - I IBSTOP G LINKX - ; - ; lock the potential new child ins company - L +^DIC(36,NEWINS):0 I '$T D LOCKED^IBTRCD1 G LINKX - ; - ; update selected child - S DIE=36,DA=NEWINS,DR="3.13////C;3.14////"_IBCNS D ^DIE - ; - ; Copy the IDs from the parent - D COPY^IBCEPCID(NEWINS) - ; - ; unlock - L -^DIC(36,NEWINS) - ; - D BLD ; rebuild list of children -LINKX ; - S VALMBCK="R" - Q - ; -UNLINK ; action protocol IBCNSL UNLINK used to disassociate selected children - ; insurance companies from the list. - NEW DIR,X,Y,DIRUT,DTOUT,DUOUT,DIROUT,IBLST,IBSUB,IBPCE,IBSEL,DA,DIE,DR - D FULL^VALM1 - I '$$KCHK^XUSRB("IB EDI INSURANCE EDIT") D G UNLINKX - . W !!?5,"You must hold the IB EDI INSURANCE EDIT key to access this option." - . D PAUSE^VALM1 - . Q - ; - I '$D(^TMP($J,"IBCNSL",3)) D G UNLINKX - . W !!?5,"There are no insurance companies to select." D PAUSE^VALM1 - . Q - S DIR(0)="LO^1:"_+$O(^TMP($J,"IBCNSL",3,""),-1) - S DIR("A")="Select Insurance Company(s)" - W ! D ^DIR K DIR - I $D(DIRUT) G UNLINKX - M IBLST=Y - ; - W ! - S DIR(0)="YO" - S DIR("A")="OK to proceed",DIR("B")="No" - D ^DIR K DIR - I Y'=1 G UNLINKX - ; - F IBSUB=0:1 Q:'$D(IBLST(IBSUB)) F IBPCE=1:1 S IBSEL=$P(IBLST(IBSUB),",",IBPCE) Q:'IBSEL D - . S DA=+$G(^TMP($J,"IBCNSL",3,IBSEL)) I 'DA Q - . S DIE=36,DR="3.13////@;3.14////@" D ^DIE - . Q - ; - D BLD ; rebuild list of children -UNLINKX ; - S VALMBCK="R" - Q - ; -PCNT(Z) ; count number of children for parent ins co Z - NEW C,CNT - S C=0,Z=+$G(Z) - F CNT=0:1 S C=$O(^DIC(36,"APC",Z,C)) Q:'C - Q CNT - ; -INSADD(Z) ; function to return ins co address components - NEW INSDATA,AD,NM,L1,CITY,ST,ZIP,CITYST,STCITY - S INSDATA="" - S AD=$G(^DIC(36,+$G(Z),.11)) - S NM=$P($G(^DIC(36,Z,0)),U,1) - S L1=$P(AD,U,1),CITY=$P(AD,U,4),ST=$P(AD,U,5),ZIP=$P(AD,U,6) - I ST S ST=$P($G(^DIC(5,ST,0)),U,2) - S CITYST=$E(CITY,1,15)_" "_ST - I CITY'="",ST'="" S CITYST=$E(CITY,1,15)_","_ST - ; - S $P(STCITY,"|",1)=ST - I ST="" S $P(STCITY,"|",1)="~~" - S $P(STCITY,"|",2)=CITY - I CITY="" S $P(STCITY,"|",2)="~~~~" - ; - S INSDATA=NM_U_L1_U_CITY_U_ST_U_ZIP_U_CITYST_U_STCITY - ; 1 2 3 4 5 6 7 -INSADDX ; - Q INSDATA - ; -INSCO(Z) ; return display data for ins co Z - NEW X,Y - S Y=$$INSADD(Z) - S X=$$FO^IBCNEUT1($P(Y,U,1),27) - S X=X_$$FO^IBCNEUT1($P(Y,U,2),26) - S X=X_$$FO^IBCNEUT1($P(Y,U,6),18) -INSCOX ; - Q X - ; -INSLIST(INS) ; insurance company lister for ^DIC call - NEW Z - S Z=$$INSADD(INS) - W ?27,$E($P(Z,U,2),1,20) ; address line 1 - W ?47," ",$P(Z,U,6) ; city, state -INSLISTX ; - Q - ; +IBCNSC02 ;ALB/ESG - Insurance Company parent/child management ;01-NOV-2005 + ;;2.0;INTEGRATED BILLING;**320**;21-MAR-1994 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; + Q + ; +DISP ; entry point for display of parent/child companies + NEW PCFLG,PARENT,PCDESC,TITLE,START,IBLINE,OFFSET,INSDATA,CNT,TXT + S PCFLG=$P($G(^DIC(36,+IBCNS,3)),U,13),PARENT="" + I PCFLG="C" S PARENT=$P($G(^DIC(36,+IBCNS,3)),U,14),PCDESC="Child" + I PCFLG="P" S PCDESC="Parent" + S TITLE=" Associated Insurance Companies " + S (START,IBLINE)=54 + S OFFSET=(40-($L(TITLE)/2))\1+1 + D SET^IBCNSP(START,OFFSET,TITLE,IORVON,IORVOFF) + ; + ; no link - display this and get out + I PCFLG="" D G DISPX + . S IBLINE=IBLINE+1 + . D SET^IBCNSP(IBLINE,3,"This insurance company is not defined as either a Parent or a Child.") + . Q + ; + ; display for either parent or child + S IBLINE=IBLINE+1 + D SET^IBCNSP(IBLINE,3,"This insurance company is defined as a "_PCDESC_" Insurance Company.") + ; + ; child display + I PCFLG="C" D G DISPX + . S IBLINE=IBLINE+1 + . D SET^IBCNSP(IBLINE,3,"It is associated with the following Parent Insurance Company:") + . S IBLINE=IBLINE+1 + . D SET^IBCNSP(IBLINE,2," ") ; blank line + . S INSDATA="" + . I 'PARENT S INSDATA="*** Parent Insurance Company not defined ***" + . I PARENT D + .. N AD S AD=$$INSADD(PARENT) ; get parent ins co data + .. S INSDATA=$P(AD,U,1)_" "_$P(AD,U,2)_" "_$P(AD,U,6) + .. Q + . S IBLINE=IBLINE+1 + . D SET^IBCNSP(IBLINE,8,INSDATA) + . Q + ; + ; parent display + S CNT=$$PCNT(IBCNS) ; count # of children + S TXT="There are "_CNT_" Child Insurance Companies" + I CNT=1 S TXT="There is 1 Child Insurance Company" + S TXT=TXT_" associated with it." + S IBLINE=IBLINE+1 + D SET^IBCNSP(IBLINE,3,TXT) + S IBLINE=IBLINE+1 + D SET^IBCNSP(IBLINE,3,"Select the ""AC Associate Companies"" action to enter/edit the children.") + ; +DISPX ; end with 2 blank lines + S IBLINE=IBLINE+1 + D SET^IBCNSP(IBLINE,2," ") ; blank line + S IBLINE=IBLINE+1 + D SET^IBCNSP(IBLINE,2," ") ; blank line + Q + ; +PARENT(IBCNS) ; Insurance company parent/child management + ; Calls ListMan screen for parent insurance companies + NEW PCFLG + I '$G(IBCNS) G PARENTX + S PCFLG=$P($G(^DIC(36,IBCNS,3)),U,13) + ; + ; special check to remove 3.13 field if 3.14 field is nil + I PCFLG="C",'$P($G(^DIC(36,IBCNS,3)),U,14) D + . N DIE,DA,DR S DIE=36,DA=IBCNS,DR="3.13////@" D ^DIE + . Q + ; + ; get out if not a parent insurance company + I PCFLG'="P" G PARENTX + ; + ; call ListMan for parent/children management + D EN^VALM("IBCNS ASSOCIATIONS LIST") + KILL ^TMP($J,"IBCNSL") +PARENTX ; + Q + ; +HDR ; List header info + S VALMHDR(1)="Parent Insurance Company:" + S VALMHDR(2)=" "_$$INSCO(IBCNS) + S VALMHDR(3)="" +HDRX ; + Q + ; +BLD ; Build list contents + NEW C,INSDATA,INSNAME,STCITY,ENTRY,NM,ST,IEN,X + KILL ^TMP($J,"IBCNSL") + S C=0 + F S C=$O(^DIC(36,"APC",IBCNS,C)) Q:'C D + . S INSDATA=$$INSADD(C) + . S INSNAME=$P(INSDATA,U,1) + . I INSNAME="" S INSNAME="~UNKNOWN" + . S STCITY=$P(INSDATA,U,7) + . I STCITY="" S STCITY="~UNKNOWN" + . S ^TMP($J,"IBCNSL",1,INSNAME,STCITY,C)="" + . Q + ; + I '$D(^TMP($J,"IBCNSL",1)) D G BLDX + . ; no children insurance companies found + . S ^TMP($J,"IBCNSL",2,1,0)="" + . S ^TMP($J,"IBCNSL",2,2,0)=" No Children Insurance Companies Found" + . S VALMCNT=2 + . Q + ; + S VALMCNT=0,ENTRY=0 + S NM="" + F S NM=$O(^TMP($J,"IBCNSL",1,NM)) Q:NM="" D + . S ST="" + . F S ST=$O(^TMP($J,"IBCNSL",1,NM,ST)) Q:ST="" D + .. S IEN=0 + .. F S IEN=$O(^TMP($J,"IBCNSL",1,NM,ST,IEN)) Q:'IEN D + ... S VALMCNT=VALMCNT+1,ENTRY=ENTRY+1 + ... S X=$$FO^IBCNEUT1($J(ENTRY,3),5)_$$INSCO(IEN) + ... S ^TMP($J,"IBCNSL",2,VALMCNT,0)=X + ... S ^TMP($J,"IBCNSL",2,"IDX",VALMCNT,ENTRY)="" + ... S ^TMP($J,"IBCNSL",3,ENTRY)=IEN_U_VALMCNT + ... Q + .. Q + . Q +BLDX ; + Q + ; +LINK ; action protocol IBCNSL LINK used to associate children insurance + ; companies to the current parent ins co for the list + NEW DIC,X,Y,DIE,DR,DA,NEWINS,IBSTOP,PAR,DIR,DIRUT,DTOUT,DUOUT,DIROUT + D FULL^VALM1 + I '$$KCHK^XUSRB("IB EDI INSURANCE EDIT") D G LINKX + . W !!?5,"You must hold the IB EDI INSURANCE EDIT key to access this option." + . D PAUSE^VALM1 + . Q + ; + ; lookup ins company + W ! + S DIC=36,DIC(0)="AEMQ",DIC("A")="Select Insurance Company: " + S DIC("W")="D INSLIST^IBCNSC02(Y)" + ; screen - ins co Y is not a parent and also it is not already in the list of children + S DIC("S")="I $P($G(^DIC(36,Y,3)),U,13)'=""P""&'$D(^DIC(36,""APC"",IBCNS,Y))" + D ^DIC K DIC + I +Y'>0 G LINKX + S NEWINS=+Y + ; + ; check to see if this selected insurance company is already a child + ; for some other parent + S PAR=+$P($G(^DIC(36,NEWINS,3)),U,14),IBSTOP=0 + I PAR,PAR'=IBCNS D + . W ! + . S DIR(0)="YO",DIR("B")="No" + . S DIR("A",1)="Please Note: The insurance company you selected is currently identified" + . S DIR("A",2)="as a Child insurance company associated with the following Parent:" + . S DIR("A",3)="" + . S DIR("A",4)=" "_$$INSCO(PAR) + . S DIR("A",5)="" + . S DIR("A")="OK to proceed and make this switch" + . D ^DIR K DIR + . I Y'=1 S IBSTOP=1 Q + . Q + I IBSTOP G LINKX + ; + ; lock the potential new child ins company + L +^DIC(36,NEWINS):0 I '$T D LOCKED^IBTRCD1 G LINKX + ; + ; update selected child + S DIE=36,DA=NEWINS,DR="3.13////C;3.14////"_IBCNS D ^DIE + ; + ; Copy the IDs from the parent + D COPY^IBCEPCID(NEWINS) + ; + ; unlock + L -^DIC(36,NEWINS) + ; + D BLD ; rebuild list of children +LINKX ; + S VALMBCK="R" + Q + ; +UNLINK ; action protocol IBCNSL UNLINK used to disassociate selected children + ; insurance companies from the list. + NEW DIR,X,Y,DIRUT,DTOUT,DUOUT,DIROUT,IBLST,IBSUB,IBPCE,IBSEL,DA,DIE,DR + D FULL^VALM1 + I '$$KCHK^XUSRB("IB EDI INSURANCE EDIT") D G UNLINKX + . W !!?5,"You must hold the IB EDI INSURANCE EDIT key to access this option." + . D PAUSE^VALM1 + . Q + ; + I '$D(^TMP($J,"IBCNSL",3)) D G UNLINKX + . W !!?5,"There are no insurance companies to select." D PAUSE^VALM1 + . Q + S DIR(0)="LO^1:"_+$O(^TMP($J,"IBCNSL",3,""),-1) + S DIR("A")="Select Insurance Company(s)" + W ! D ^DIR K DIR + I $D(DIRUT) G UNLINKX + M IBLST=Y + ; + W ! + S DIR(0)="YO" + S DIR("A")="OK to proceed",DIR("B")="No" + D ^DIR K DIR + I Y'=1 G UNLINKX + ; + F IBSUB=0:1 Q:'$D(IBLST(IBSUB)) F IBPCE=1:1 S IBSEL=$P(IBLST(IBSUB),",",IBPCE) Q:'IBSEL D + . S DA=+$G(^TMP($J,"IBCNSL",3,IBSEL)) I 'DA Q + . S DIE=36,DR="3.13////@;3.14////@" D ^DIE + . Q + ; + D BLD ; rebuild list of children +UNLINKX ; + S VALMBCK="R" + Q + ; +PCNT(Z) ; count number of children for parent ins co Z + NEW C,CNT + S C=0,Z=+$G(Z) + F CNT=0:1 S C=$O(^DIC(36,"APC",Z,C)) Q:'C + Q CNT + ; +INSADD(Z) ; function to return ins co address components + NEW INSDATA,AD,NM,L1,CITY,ST,ZIP,CITYST,STCITY + S INSDATA="" + S AD=$G(^DIC(36,+$G(Z),.11)) + S NM=$P($G(^DIC(36,Z,0)),U,1) + S L1=$P(AD,U,1),CITY=$P(AD,U,4),ST=$P(AD,U,5),ZIP=$P(AD,U,6) + I ST S ST=$P($G(^DIC(5,ST,0)),U,2) + S CITYST=$E(CITY,1,15)_" "_ST + I CITY'="",ST'="" S CITYST=$E(CITY,1,15)_","_ST + ; + S $P(STCITY,"|",1)=ST + I ST="" S $P(STCITY,"|",1)="~~" + S $P(STCITY,"|",2)=CITY + I CITY="" S $P(STCITY,"|",2)="~~~~" + ; + S INSDATA=NM_U_L1_U_CITY_U_ST_U_ZIP_U_CITYST_U_STCITY + ; 1 2 3 4 5 6 7 +INSADDX ; + Q INSDATA + ; +INSCO(Z) ; return display data for ins co Z + NEW X,Y + S Y=$$INSADD(Z) + S X=$$FO^IBCNEUT1($P(Y,U,1),27) + S X=X_$$FO^IBCNEUT1($P(Y,U,2),26) + S X=X_$$FO^IBCNEUT1($P(Y,U,6),18) +INSCOX ; + Q X + ; +INSLIST(INS) ; insurance company lister for ^DIC call + NEW Z + S Z=$$INSADD(INS) + W ?27,$E($P(Z,U,2),1,20) ; address line 1 + W ?47," ",$P(Z,U,6) ; city, state +INSLISTX ; + Q + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSC1.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSC1.m index 1f26a35c..f8b3899e 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSC1.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSC1.m @@ -1,231 +1,206 @@ -IBCNSC1 ;ALB/NLR - IBCNS INSURANCE COMPANY ;23-MAR-93 - ;;2.0;INTEGRATED BILLING;**62,137,232,291,320,348,349,371**;21-MAR-94;Build 57 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -% G EN^IBCNSC - ; -AI ; -- (In)Activate Company - D FULL^VALM1 W !! - I '$D(^XUSEC("IB INSURANCE SUPERVISOR",DUZ)) D SORRY G EXIT - D ^IBCNSC2 - G EXIT -CC ; -- Change Insurance Company - D FULL^VALM1 W !! - S IBCNS1=IBCNS K IBCNS D INSCO^IBCNSC - I '$D(IBCNS) S IBCNS=IBCNS1 - K IBCNS1,VALMQUIT - G EXIT -EA ; -- Billing,Claims,Appeals,Inquiry,Telephone,Main,Remarks,Synonyms - D FULL^VALM1 - ; - ; IB*2*320 - check key for associate company action - I $G(IBY)=",13,",'$$KCHK^XUSRB("IB EDI INSURANCE EDIT") D G EXIT - . W !!?5,"You must hold the IB EDI INSURANCE EDIT key to access this option." - . D PAUSE^VALM1 - . Q - ; - W !! - D MAIN - ; - ; -- was company deleted - I '$D(^DIC(36,IBCNS)) W !!,"",!! S VALMQUIT="" Q - ; -EXIT ; - D HDR^IBCNSC,BLD^IBCNSC - S VALMBCK="R" - Q -MAIN ; -- Call edit template - N IBEDIKEY,Z - L +^DIC(36,+IBCNS):5 I '$T D LOCKED^IBTRCD1 G MAINQ - I $G(IBY)=",12," D FACID - F Z=1,2,4,9,13,14 S IBEDIKEY(Z)=$P($G(^DIC(36,+IBCNS,3)),U,Z) ; save EDI data fields - F Z=1:1:8 S IBEDIKEY(Z,6)=$P($G(^DIC(36,+IBCNS,6)),U,Z) ; save EDI data fields - I $G(IBY)'=",12," N DIE,DA,DR S DIE="^DIC(36,",(DA,Y)=IBCNS,DR="[IBEDIT INS CO1]" D ^DIE K DIE S:$D(Y) IB("^")=1 D:$TR($P($G(^DIC(36,IBCNS,6)),U,1,8),U)]"" CUIDS(IBCNS) - I $G(IBY)=",12," D EDITID^IBCEP(+IBCNS) - I $F(",6,13,",$G(IBY)) D PARENT^IBCNSC02(+IBCNS) ; parent/child management - L -^DIC(36,+IBCNS) -MAINQ Q - ; -FACID ; -- Edit facility ids - D FACID^IBCEP2B(+IBCNS,"E") - Q - ; -SORRY ; -- can't inactivate, don't have key - W !!,"You do not have access to Inactivate entries. See your application coordinator.",! D PAUSE^VALM1 - Q -PRESCR ; - N OFFSET,START,IBCNS18,IBADD - S IBCNS18=$$ADDRESS^IBCNSC0(IBCNS,.18,11) - S START=41,OFFSET=2 - D SET^IBCNSP(START,OFFSET+19," Prescription Claims Office Information ",IORVON,IORVOFF) - D SET^IBCNSP(START+1,OFFSET," Company Name: "_$P($G(^DIC(36,+$P(IBCNS18,"^",7),0)),"^",1)) - D SET^IBCNSP(START+2,OFFSET," Street: "_$P(IBCNS18,"^",1)) - D SET^IBCNSP(START+3,OFFSET," Street 2: "_$P(IBCNS18,"^",2)) - ; D SET^IBCNSP(START+4,OFFSET,"Claim Off. ID: "_$P(IBCNS18,"^",11)) - N OFFSET S OFFSET=45 - D SET^IBCNSP(START+1,OFFSET," Street 3: "_$P(IBCNS18,"^",3)) S IBADD=1 - D SET^IBCNSP(START+1+IBADD,OFFSET," City/State: "_$E($P(IBCNS18,"^",4),1,15)_$S($P(IBCNS18,"^",4)="":"",1:", ")_$P($G(^DIC(5,+$P(IBCNS18,"^",5),0)),"^",2)_" "_$E($P(IBCNS18,"^",6),1,5)) - D SET^IBCNSP(START+2+IBADD,OFFSET," Phone: "_$P(IBCNS18,"^",8)) - D SET^IBCNSP(START+3+IBADD,OFFSET," Fax: "_$P(IBCNS18,"^",9)) - Q - ; -PROVID N OFFSET,START,IBCNS4,IBCNS3,IBDISP,Z,LINE - S START=$O(^TMP("IBCNSC",$J,""),-1)+1 - S (IB1ST("PROVID"),LINE)=START - S OFFSET=2,IBCNS4=$G(^DIC(36,IBCNS,4)),IBCNS3=$G(^(3)) - ; - D SET^IBCNSP(LINE,OFFSET+25,"Provider IDs",IORVON,IORVOFF) - N OFFSET - S LINE=LINE+1,OFFSET=1 - D SET^IBCNSP(LINE,OFFSET,"Billing Provider Secondary ID") - ; - N Z,Z0,Z1,IBS,I,DIV,FT,CU,CUF,DIVISION,FORMTYPE,PIDT - S Z=0 F S Z=$O(^IBA(355.92,"B",+IBCNS,Z)) Q:'Z D - . S Z0=$G(^IBA(355.92,Z,0)) - . Q:'$P(Z0,U,6)!($P(Z0,U,7)="") ; Quit if no provider id or id type - . Q:'($P(Z0,U,8)="E") - . S IBS(+$P(Z0,U,5),+$P(Z0,U,3),+$P(Z0,U,4))=$P(Z0,U,6)_U_$P(Z0,U,7) - ; - S DIV="" F S DIV=$O(IBS(DIV)) Q:DIV="" D - . S DIVISION=$$DIV^IBCEP7(DIV) - . S CU="",CUF=0 F S CU=$O(IBS(DIV,CU)) Q:CU="" D - .. S FT="" F S FT=$O(IBS(DIV,CU,FT)) Q:FT="" D - ... S FORMTYPE=$S(FT=1:"UB-04",FT=2:"1500",1:"UNKNOWN") - ... S LINE=LINE+1 - ... I 'CUF,+CU S CUF=1 S TEXT=$P(DIVISION,"/")_" Care Units :",OFFSET=5 D SET^IBCNSP(LINE,OFFSET,TEXT) S LINE=LINE+1 - ... I CU=0 S TEXT=DIVISION_"/"_FORMTYPE_": "_$$GET1^DIQ(355.97,$P(IBS(DIV,CU,FT),U),.03,"E")_" "_$P(IBS(DIV,CU,FT),U,2),OFFSET=2 - ... I +CU S TEXT=$$EXPAND^IBTRE(355.92,.03,CU)_"/"_FORMTYPE_": "_$$GET1^DIQ(355.97,$P(IBS(DIV,CU,FT),U),.03,"E")_" "_$P(IBS(DIV,CU,FT),U,2),OFFSET=5 - ... D SET^IBCNSP(LINE,OFFSET,TEXT) - ; - S LINE=LINE+1 D SET^IBCNSP(LINE,2," ") - ; - K IBS - S OFFSET=1,LINE=LINE+1 - D SET^IBCNSP(LINE,OFFSET,"Additional Billing Provider Secondary IDs") - S Z=0 F S Z=$O(^IBA(355.92,"B",+IBCNS,Z)) Q:'Z D - . S Z0=$G(^IBA(355.92,Z,0)) - . Q:'$P(Z0,U,6)!($P(Z0,U,7)="") ; Quit if no provider id or id type - . Q:'($P(Z0,U,8)="A") - . ; IBS(DIVISION,FORMTYPE,IDTYPE)=ID - . S IBS(+$P(Z0,U,5),+$P(Z0,U,4),+$P(Z0,U,6))=$P(Z0,U,7) - ; - S DIVISION=$$DIV^IBCEP7(0) - S DIV="" F S DIV=$O(IBS(DIV)) Q:DIV="" D - . S FT="" F S FT=$O(IBS(DIV,FT)) Q:FT="" D - .. S FORMTYPE=$S(FT=1:"UB-04",FT=2:"1500",1:"UNKNOWN") - .. S TEXT=DIVISION_"/"_FORMTYPE_": " - .. S LINE=LINE+1,OFFSET=2 - .. D SET^IBCNSP(LINE,OFFSET,TEXT) - .. S PIDT="" F S PIDT=$O(IBS(DIV,FT,PIDT)) Q:PIDT="" D - ... S LINE=LINE+1 - ... S TEXT=$$GET1^DIQ(355.97,PIDT,.03,"E")_" "_IBS(DIV,FT,PIDT),OFFSET=5 - ... D SET^IBCNSP(LINE,OFFSET,TEXT) - ; - S LINE=LINE+1 D SET^IBCNSP(LINE,2," ") - ; - K IBS - S OFFSET=1,LINE=LINE+1 - D SET^IBCNSP(LINE,OFFSET,"VA-Laboratory or Facility Secondary IDs") - S Z=0 F S Z=$O(^IBA(355.92,"B",+IBCNS,Z)) Q:'Z D - . S Z0=$G(^IBA(355.92,Z,0)) - . Q:'$P(Z0,U,6)!($P(Z0,U,7)="") ; Quit if no provider id or id type - . Q:'($P(Z0,U,8)="LF") - . ; IBS(DIVISION,FORMTYPE,IDTYPE)=ID - . S IBS(+$P(Z0,U,5),+$P(Z0,U,4),+$P(Z0,U,6))=$P(Z0,U,7) - ; - S DIVISION=$$DIV^IBCEP7(0) - S DIV="" F S DIV=$O(IBS(DIV)) Q:DIV="" D - . S FT="" F S FT=$O(IBS(DIV,FT)) Q:FT="" D - .. S FORMTYPE=$S(FT=1:"UB-04",FT=2:"1500",1:"UNKNOWN") - .. S TEXT=DIVISION_"/"_FORMTYPE_": " - .. S LINE=LINE+1,OFFSET=2 - .. D SET^IBCNSP(LINE,OFFSET,TEXT) - .. S PIDT="" F S PIDT=$O(IBS(DIV,FT,PIDT)) Q:PIDT="" D - ... S LINE=LINE+1 - ... ;S TEXT=$$EXPAND^IBTRE(355.92,.06,PIDT)_" "_IBS(DIV,FT,PIDT),OFFSET=5 - ... S TEXT=$$GET1^DIQ(355.97,PIDT,.03,"E")_" "_IBS(DIV,FT,PIDT),OFFSET=5 - ... D SET^IBCNSP(LINE,OFFSET,TEXT) - ; - ; - S LINE=LINE+1 D SET^IBCNSP(LINE,2," ") - S LINE=LINE+1 D SET^IBCNSP(LINE,2," ") - S OFFSET=2 - S LINE=LINE+1 D SET^IBCNSP(LINE,OFFSET+25,"ID Parameters",IORVON,IORVOFF) - ; - S IBCNS4=$G(^DIC(36,IBCNS,4)),IBCNS3=$G(^(3)),OFFSET=1 - S TEXT="Attending/Rendering Provider Secondary ID Qualifier (1500): "_$$EXPAND^IBTRE(36,4.01,+$P(IBCNS4,U)) - S LINE=LINE+1 - D SET^IBCNSP(LINE,OFFSET,TEXT) - ; - S TEXT="Attending/Rendering Provider Secondary ID Qualifier (UB-04): "_$$EXPAND^IBTRE(36,4.02,+$P(IBCNS4,U,2)) - S LINE=LINE+1 - D SET^IBCNSP(LINE,OFFSET,TEXT) - ; - S TEXT="Attending/Rendering Secondary ID Requirement: "_$$EXPAND^IBTRE(36,4.03,+$P(IBCNS4,U,3)) - S LINE=LINE+1 - D SET^IBCNSP(LINE,OFFSET,TEXT) - ; - S TEXT="Referring Provider Secondary ID Qualifier (1500): "_$$EXPAND^IBTRE(36,4.04,+$P(IBCNS4,U,4)) - S LINE=LINE+1 - D SET^IBCNSP(LINE,OFFSET,TEXT) - ; - S TEXT="Referring Provider Secondary ID Requirement: "_$$EXPAND^IBTRE(36,4.05,+$P(IBCNS4,U,5)) - S LINE=LINE+1 - D SET^IBCNSP(LINE,OFFSET,TEXT) - ; - S TEXT="Use Att/Rend ID as Billing Provider Sec. ID (1500): "_$$EXPAND^IBTRE(36,4.06,+$P(IBCNS4,U,6)) - S LINE=LINE+1 - D SET^IBCNSP(LINE,OFFSET,TEXT) - ; - S TEXT="Use Att/Rend ID as Billing Provider Sec. ID (UB-04): "_$$EXPAND^IBTRE(36,4.08,+$P(IBCNS4,U,8)) - S LINE=LINE+1 - D SET^IBCNSP(LINE,OFFSET,TEXT) - ; - S TEXT="Send VA Lab/Facility IDs or Facility Data for VAMC?: "_$$EXPAND^IBTRE(36,4.07,+$P(IBCNS4,U,7)) - S LINE=LINE+1 - D SET^IBCNSP(LINE,OFFSET,TEXT) - ; - S TEXT="Transmit no Billing Provider Sec. ID for the Electronic Plan Types: " - S LINE=LINE+1 - D SET^IBCNSP(LINE,OFFSET,TEXT) - ; - N TAR,ERR,IBCT - D LIST^DIC(36.013,","_IBCNS_",",".01",,10,,,,,,"TAR","ERR") - F IBCT=1:1:+$G(TAR("DILIST",0)) D - . S TEXT=TAR("DILIST",1,IBCT) - . S LINE=LINE+1 - . D SET^IBCNSP(LINE,OFFSET,TEXT) - ; - S LINE=LINE+1 D SET^IBCNSP(LINE,2," ") - S LINE=LINE+1 D SET^IBCNSP(LINE,2," ") - Q - ; -INSDEF(IBINS,IBPTYP) ; Returns the default id # for an ins co, if possible - N X - S X="" - I IBINS,IBPTYP S X=$P($G(^IBA(355.91,+$O(^IBA(355.91,"AC",IBINS,IBPTYP,"*N/A*","")),0)),U,7) - Q X - ; -CUIDS(IBCNS) ; - N DIE,DA,DR,PIECE,DAT6,Y - S DAT6=$P(^DIC(36,IBCNS,6),U,1,8) ; get the Payer IDs - ; - ; Make sure each qualifier has an ID and vice versa - F PIECE=1,3,5,7 D - . I $TR($P(DAT6,U,PIECE,PIECE+1),U)="" Q ; both blank - . I $P(DAT6,U,PIECE)]"",$P(DAT6,U,PIECE+1)]"" Q ; both have data - . S DIE="^DIC(36,",(DA,Y)=IBCNS,DR="6.0"_$S($P(DAT6,U,PIECE)]"":PIECE,1:PIECE+1)_"////@" - . D ^DIE K DIE - ; - S DAT6=$P($G(^DIC(36,IBCNS,6)),U,1,8) ; get the Payer IDs again since they may have changed above. - ; - ; Make sure the first pair of ID/Qual are populated if the 2nd pair is. If not, move em over. - ; This is done for institutional then professional - F PIECE=1,5 D - . I $P(DAT6,U,PIECE)]"" Q ; already has set one - . I $P(DAT6,U,PIECE+2)="" Q ; has no second set - . S DIE="^DIC(36,",(DA,Y)=IBCNS - . ; deleting the qualifier triggers deletion of the ID - . S DR="6.0"_PIECE_"////"_$P(DAT6,U,PIECE+2)_";6.0"_(PIECE+1)_"////"_$P(DAT6,U,PIECE+3)_";6.0"_(PIECE+2)_"////@" - . D ^DIE K DIE - Q +IBCNSC1 ;ALB/NLR - IBCNS INSURANCE COMPANY ;23-MAR-93 + ;;2.0;INTEGRATED BILLING;**62,137,232,291,320,348,349**;21-MAR-94;Build 46 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; +% G EN^IBCNSC + ; +AI ; -- (In)Activate Company + D FULL^VALM1 W !! + I '$D(^XUSEC("IB INSURANCE SUPERVISOR",DUZ)) D SORRY G EXIT + D ^IBCNSC2 + G EXIT +CC ; -- Change Insurance Company + D FULL^VALM1 W !! + S IBCNS1=IBCNS K IBCNS D INSCO^IBCNSC + I '$D(IBCNS) S IBCNS=IBCNS1 + K IBCNS1,VALMQUIT + G EXIT +EA ; -- Billing,Claims,Appeals,Inquiry,Telephone,Main,Remarks,Synonyms + D FULL^VALM1 + ; + ; IB*2*320 - check key for associate company action + I $G(IBY)=",13,",'$$KCHK^XUSRB("IB EDI INSURANCE EDIT") D G EXIT + . W !!?5,"You must hold the IB EDI INSURANCE EDIT key to access this option." + . D PAUSE^VALM1 + . Q + ; + W !! + D MAIN + ; + ; -- was company deleted + I '$D(^DIC(36,IBCNS)) W !!,"",!! S VALMQUIT="" Q + ; +EXIT ; + D HDR^IBCNSC,BLD^IBCNSC + S VALMBCK="R" + Q +MAIN ; -- Call edit template + N IBEDIKEY,Z + L +^DIC(36,+IBCNS):5 I '$T D LOCKED^IBTRCD1 G MAINQ + I $G(IBY)=",12," D FACID + F Z=1,2,4,9,13,14 S IBEDIKEY(Z)=$P($G(^DIC(36,+IBCNS,3)),U,Z) ; save EDI data fields + I $G(IBY)'=",12," N DIE,DA,DR S DIE="^DIC(36,",(DA,Y)=IBCNS,DR="[IBEDIT INS CO1]" D ^DIE K DIE I $D(Y) S IB("^")=1 + I $G(IBY)=",12," D EDITID^IBCEP(+IBCNS) + I $F(",6,13,",$G(IBY)) D PARENT^IBCNSC02(+IBCNS) ; parent/child management + L -^DIC(36,+IBCNS) +MAINQ Q + ; +FACID ; -- Edit facility ids + D FACID^IBCEP2B(+IBCNS,"E") + Q + ; +SORRY ; -- can't inactivate, don't have key + W !!,"You do not have access to Inactivate entries. See your application coordinator.",! D PAUSE^VALM1 + Q +PRESCR ; + N OFFSET,START,IBCNS18,IBADD + S IBCNS18=$$ADDRESS^IBCNSC0(IBCNS,.18,11) + S START=34,OFFSET=2 + D SET^IBCNSP(START,OFFSET+19," Prescription Claims Office Information ",IORVON,IORVOFF) + D SET^IBCNSP(START+1,OFFSET," Company Name: "_$P($G(^DIC(36,+$P(IBCNS18,"^",7),0)),"^",1)) + D SET^IBCNSP(START+2,OFFSET," Street: "_$P(IBCNS18,"^",1)) + D SET^IBCNSP(START+3,OFFSET," Street 2: "_$P(IBCNS18,"^",2)) + ; D SET^IBCNSP(START+4,OFFSET,"Claim Off. ID: "_$P(IBCNS18,"^",11)) + N OFFSET S OFFSET=45 + D SET^IBCNSP(START+1,OFFSET," Street 3: "_$P(IBCNS18,"^",3)) S IBADD=1 + D SET^IBCNSP(START+1+IBADD,OFFSET," City/State: "_$E($P(IBCNS18,"^",4),1,15)_$S($P(IBCNS18,"^",4)="":"",1:", ")_$P($G(^DIC(5,+$P(IBCNS18,"^",5),0)),"^",2)_" "_$E($P(IBCNS18,"^",6),1,5)) + D SET^IBCNSP(START+2+IBADD,OFFSET," Phone: "_$P(IBCNS18,"^",8)) + D SET^IBCNSP(START+3+IBADD,OFFSET," Fax: "_$P(IBCNS18,"^",9)) + Q + ; +PROVID N OFFSET,START,IBCNS4,IBCNS3,IBDISP,Z,LINE + S START=$O(^TMP("IBCNSC",$J,""),-1)+1 + S (IB1ST("PROVID"),LINE)=START + S OFFSET=2,IBCNS4=$G(^DIC(36,IBCNS,4)),IBCNS3=$G(^(3)) + ; + D SET^IBCNSP(LINE,OFFSET+25,"Provider IDs",IORVON,IORVOFF) + N OFFSET + S LINE=LINE+1,OFFSET=1 + D SET^IBCNSP(LINE,OFFSET,"Billing Provider Secondary ID") + ; + N Z,Z0,Z1,IBS,I,DIV,FT,CU,CUF,DIVISION,FORMTYPE,PIDT + S Z=0 F S Z=$O(^IBA(355.92,"B",+IBCNS,Z)) Q:'Z D + . S Z0=$G(^IBA(355.92,Z,0)) + . Q:'$P(Z0,U,6)!($P(Z0,U,7)="") ; Quit if no provider id or id type + . Q:'($P(Z0,U,8)="E") + . S IBS(+$P(Z0,U,5),+$P(Z0,U,3),+$P(Z0,U,4))=$P(Z0,U,6)_U_$P(Z0,U,7) + ; + S DIV="" F S DIV=$O(IBS(DIV)) Q:DIV="" D + . S DIVISION=$$DIV^IBCEP7(DIV) + . S CU="",CUF=0 F S CU=$O(IBS(DIV,CU)) Q:CU="" D + .. S FT="" F S FT=$O(IBS(DIV,CU,FT)) Q:FT="" D + ... S FORMTYPE=$S(FT=1:"UB-04",FT=2:"1500",1:"UNKNOWN") + ... S LINE=LINE+1 + ... I 'CUF,+CU S CUF=1 S TEXT=$P(DIVISION,"/")_" Care Units :",OFFSET=5 D SET^IBCNSP(LINE,OFFSET,TEXT) S LINE=LINE+1 + ... I CU=0 S TEXT=DIVISION_"/"_FORMTYPE_": "_$$GET1^DIQ(355.97,$P(IBS(DIV,CU,FT),U),.03,"E")_" "_$P(IBS(DIV,CU,FT),U,2),OFFSET=2 + ... I +CU S TEXT=$$EXPAND^IBTRE(355.92,.03,CU)_"/"_FORMTYPE_": "_$$GET1^DIQ(355.97,$P(IBS(DIV,CU,FT),U),.03,"E")_" "_$P(IBS(DIV,CU,FT),U,2),OFFSET=5 + ... D SET^IBCNSP(LINE,OFFSET,TEXT) + ; + S LINE=LINE+1 D SET^IBCNSP(LINE,2," ") + ; + K IBS + S OFFSET=1,LINE=LINE+1 + D SET^IBCNSP(LINE,OFFSET,"Additional Billing Provider Secondary IDs") + S Z=0 F S Z=$O(^IBA(355.92,"B",+IBCNS,Z)) Q:'Z D + . S Z0=$G(^IBA(355.92,Z,0)) + . Q:'$P(Z0,U,6)!($P(Z0,U,7)="") ; Quit if no provider id or id type + . Q:'($P(Z0,U,8)="A") + . ; IBS(DIVISION,FORMTYPE,IDTYPE)=ID + . S IBS(+$P(Z0,U,5),+$P(Z0,U,4),+$P(Z0,U,6))=$P(Z0,U,7) + ; + S DIVISION=$$DIV^IBCEP7(0) + S DIV="" F S DIV=$O(IBS(DIV)) Q:DIV="" D + . S FT="" F S FT=$O(IBS(DIV,FT)) Q:FT="" D + .. S FORMTYPE=$S(FT=1:"UB-04",FT=2:"1500",1:"UNKNOWN") + .. S TEXT=DIVISION_"/"_FORMTYPE_": " + .. S LINE=LINE+1,OFFSET=2 + .. D SET^IBCNSP(LINE,OFFSET,TEXT) + .. S PIDT="" F S PIDT=$O(IBS(DIV,FT,PIDT)) Q:PIDT="" D + ... S LINE=LINE+1 + ... S TEXT=$$GET1^DIQ(355.97,PIDT,.03,"E")_" "_IBS(DIV,FT,PIDT),OFFSET=5 + ... D SET^IBCNSP(LINE,OFFSET,TEXT) + ; + S LINE=LINE+1 D SET^IBCNSP(LINE,2," ") + ; + K IBS + S OFFSET=1,LINE=LINE+1 + D SET^IBCNSP(LINE,OFFSET,"VA-Laboratory or Facility Secondary IDs") + S Z=0 F S Z=$O(^IBA(355.92,"B",+IBCNS,Z)) Q:'Z D + . S Z0=$G(^IBA(355.92,Z,0)) + . Q:'$P(Z0,U,6)!($P(Z0,U,7)="") ; Quit if no provider id or id type + . Q:'($P(Z0,U,8)="LF") + . ; IBS(DIVISION,FORMTYPE,IDTYPE)=ID + . S IBS(+$P(Z0,U,5),+$P(Z0,U,4),+$P(Z0,U,6))=$P(Z0,U,7) + ; + S DIVISION=$$DIV^IBCEP7(0) + S DIV="" F S DIV=$O(IBS(DIV)) Q:DIV="" D + . S FT="" F S FT=$O(IBS(DIV,FT)) Q:FT="" D + .. S FORMTYPE=$S(FT=1:"UB-04",FT=2:"1500",1:"UNKNOWN") + .. S TEXT=DIVISION_"/"_FORMTYPE_": " + .. S LINE=LINE+1,OFFSET=2 + .. D SET^IBCNSP(LINE,OFFSET,TEXT) + .. S PIDT="" F S PIDT=$O(IBS(DIV,FT,PIDT)) Q:PIDT="" D + ... S LINE=LINE+1 + ... ;S TEXT=$$EXPAND^IBTRE(355.92,.06,PIDT)_" "_IBS(DIV,FT,PIDT),OFFSET=5 + ... S TEXT=$$GET1^DIQ(355.97,PIDT,.03,"E")_" "_IBS(DIV,FT,PIDT),OFFSET=5 + ... D SET^IBCNSP(LINE,OFFSET,TEXT) + ; + ; + S LINE=LINE+1 D SET^IBCNSP(LINE,2," ") + S LINE=LINE+1 D SET^IBCNSP(LINE,2," ") + S OFFSET=2 + S LINE=LINE+1 D SET^IBCNSP(LINE,OFFSET+25,"ID Parameters",IORVON,IORVOFF) + ; + S IBCNS4=$G(^DIC(36,IBCNS,4)),IBCNS3=$G(^(3)),OFFSET=1 + S TEXT="Attending/Rendering Provider Secondary ID Qualifier (1500): "_$$EXPAND^IBTRE(36,4.01,+$P(IBCNS4,U)) + S LINE=LINE+1 + D SET^IBCNSP(LINE,OFFSET,TEXT) + ; + S TEXT="Attending/Rendering Provider Secondary ID Qualifier (UB-04): "_$$EXPAND^IBTRE(36,4.02,+$P(IBCNS4,U,2)) + S LINE=LINE+1 + D SET^IBCNSP(LINE,OFFSET,TEXT) + ; + S TEXT="Attending/Rendering Secondary ID Requirement: "_$$EXPAND^IBTRE(36,4.03,+$P(IBCNS4,U,3)) + S LINE=LINE+1 + D SET^IBCNSP(LINE,OFFSET,TEXT) + ; + S TEXT="Referring Provider Secondary ID Qualifier (1500): "_$$EXPAND^IBTRE(36,4.04,+$P(IBCNS4,U,4)) + S LINE=LINE+1 + D SET^IBCNSP(LINE,OFFSET,TEXT) + ; + S TEXT="Referring Provider Secondary ID Requirement: "_$$EXPAND^IBTRE(36,4.05,+$P(IBCNS4,U,5)) + S LINE=LINE+1 + D SET^IBCNSP(LINE,OFFSET,TEXT) + ; + S TEXT="Use Att/Rend ID as Billing Provider Sec. ID (1500): "_$$EXPAND^IBTRE(36,4.06,+$P(IBCNS4,U,6)) + S LINE=LINE+1 + D SET^IBCNSP(LINE,OFFSET,TEXT) + ; + S TEXT="Use Att/Rend ID as Billing Provider Sec. ID (UB-04): "_$$EXPAND^IBTRE(36,4.08,+$P(IBCNS4,U,8)) + S LINE=LINE+1 + D SET^IBCNSP(LINE,OFFSET,TEXT) + ; + S TEXT="Send VA Lab/Facility IDs or Facility Data for VAMC?: "_$$EXPAND^IBTRE(36,4.07,+$P(IBCNS4,U,7)) + S LINE=LINE+1 + D SET^IBCNSP(LINE,OFFSET,TEXT) + ; + S TEXT="Transmit no Billing Provider Sec. ID for the Electronic Plan Types: " + S LINE=LINE+1 + D SET^IBCNSP(LINE,OFFSET,TEXT) + ; + N TAR,ERR,IBCT + D LIST^DIC(36.013,","_IBCNS_",",".01",,10,,,,,,"TAR","ERR") + F IBCT=1:1:+$G(TAR("DILIST",0)) D + . S TEXT=TAR("DILIST",1,IBCT) + . S LINE=LINE+1 + . D SET^IBCNSP(LINE,OFFSET,TEXT) + ; + S LINE=LINE+1 D SET^IBCNSP(LINE,2," ") + S LINE=LINE+1 D SET^IBCNSP(LINE,2," ") + Q + ; +INSDEF(IBINS,IBPTYP) ; Returns the default id # for an ins co, if possible + N X + S X="" + I IBINS,IBPTYP S X=$P($G(^IBA(355.91,+$O(^IBA(355.91,"AC",IBINS,IBPTYP,"*N/A*","")),0)),U,7) + Q X diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSEH.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSEH.m index 39860e8c..cf600b22 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSEH.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSEH.m @@ -1,38 +1,43 @@ -IBCNSEH ;ALB/AAS - EXTENDED HELP FOR INSURANCE MANAGEMENT ;28-MAY-93 - ;;2.0;INTEGRATED BILLING;**6,28,371**;21-MAR-94;Build 57 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -INS ; -- Help for Insurance Type - Q:'$G(IBCNSEH) - W !!,"The way we store and think about patient insurance information has been" - W !,"dramatically changed. We are separating out information that is specific" - W !,"to an insurance company, specific to the patient, specific to the group plan," - W !,"specific to the annual benefits available, and the annual benefits already" - W !,"used." - W !!,"To start, you must select the insurance company for the patient's policy.",! - Q -PAT ; -- Help for entering patient specific information - Q:'$G(IBCNSEH) - W !!,"Now you may enter the patient specific policy information.",! - Q -POL ; -- Help for policy specific information - Q:'$G(IBCNSEH) - W !!,"You can now edit information specific to the PLAN. Remember, updating" - W !,"PLAN information will affect all patients with this plan, if it is a" - W !,"group plan, and not just the current patient.",! - Q - ; -SEL ; -- help for selecting a new HIP - Q:'$G(IBCNSEH) - W !!,"Each Insurance policy entry for a patient must be associated with an" - W !,"Insurance Plan offered by the Insurance company you just selected." - W !,"You will be given a choice of selecting previously entered Group Plans or" - W !,"you may enter a new one. If you enter a new Insurance Plan you" - W !,"must enter whether or not this is a group or individual plan.",! - Q -AB ; - Q:'$G(IBCNSEH) - Q -BU ; - Q:'$G(IBCNSEH) - Q +IBCNSEH ;ALB/AAS - EXTENDED HELP FOR INSURANCE MANAGEMENT - 28-MAY-93 + ;;Version 2.0 ; INTEGRATED BILLING ;**6,28**; 21-MAR-94 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; +INS ; -- Help for Insurance Type + Q:'$G(IBCNSEH) + W !!,"The way we store and think about patient insurance information has been" + W !,"dramatically changed. We are separating out information that is specific" + W !,"to an insurance company, specific to the patient, specific to the group plan," + W !,"specific to the annual benefits available, and the annual benefits already" + W !,"used." + W !!,"To start, you must select the insurance company for the patient's policy.",! + Q +PAT ; -- Help for entering patient specific information + Q:'$G(IBCNSEH) + W !!,"Now you may enter the patient specific policy information." + W !,"Most of these fields will be familiar to experienced users. The field" + W !,"'SUBSCRIBER ID' used to be called 'INSURANCE NUMBER' and " + W !,"has been modified to allow entering just 'SS' to retrieve" + W !,"the patients SSN. This field is the identifier for the policy or patient" + W !,"that the carrier uses. See the new help.",! + Q +POL ; -- Help for policy specific information + Q:'$G(IBCNSEH) + W !!,"You can now edit information specific to the PLAN. Remember, updating" + W !,"PLAN information will affect all patients with this plan, if it is a" + W !,"group plan, and not just the current patient.",! + Q + ; +SEL ; -- help for selecting a new HIP + Q:'$G(IBCNSEH) + W !!,"Each Insurance policy entry for a patient must be associated with an" + W !,"Insurance Plan offered by the Insurance company you just selected." + W !,"You will be given a choice of selecting previously entered Group Plans or" + W !,"you may enter a new one. If you enter a new Insurance Plan you" + W !,"must enter whether or not this is a group or individual plan.",! + Q +AB ; + Q:'$G(IBCNSEH) + Q +BU ; + Q:'$G(IBCNSEH) + Q diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSM32.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSM32.m index b61cf889..8b364af1 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSM32.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSM32.m @@ -1,109 +1,111 @@ -IBCNSM32 ;ALB/AAS - INSURANCE MANAGEMENT - POLICY EDIT ;23-JAN-95 - ;;2.0;INTEGRATED BILLING;**28,40,52,85,103,133,361,371**;21-MAR-94;Build 57 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -PATPOL(IBCDFN) ; -- edit patient specific policy info - I '$G(IBCDFN) G PATPOLQ - D SAVEPT^IBCNSP3(DFN,IBCDFN) - D POL^IBCNSU41(DFN) - ; - ; -- give warning if expired or inactive co. - I $P(^DPT(DFN,.312,IBCDFN,0),"^",4),$P(^(0),"^",4)'>DT W !,"WARNING: This appears to be an expired policy!",! - I $P(^DIC(36,+$P(^DPT(DFN,.312,IBCDFN,0),"^"),0),"^",5) W !,*7,"WARNING: This insurance company is INACTIVE!",! - ; - N IBAD,IBDIF,DA,DR,DIC,DIE,DGSENFLG S DGSENFLG=1 - L +^DPT(DFN,.312,+IBCDFN):5 I '$T D LOCKED^IBTRCD1 G PATPOLQ - ; - D EDIT^IBCNSP1(DFN,IBCDFN,.IBQUIT) ; IB*371 edit 2.312 subfile data - ; - ; If the 2.312 subfile entry was deleted then unlock and get out - I '$D(^DPT(DFN,.312,IBCDFN,0)) L -^DPT(DFN,.312,+IBCDFN) G PATPOLQ - ; - ; -- if the company was changed, change the policy plan - I $G(IBREG),$G(IBCNS),+$G(^DPT(DFN,.312,IBCDFN,0))'=IBCNS D CHPL - ; - K IBFUTUR - D COMPPT^IBCNSP3(DFN,IBCDFN) - I IBDIF D UPDATPT^IBCNSP3(DFN,IBCDFN) - L -^DPT(DFN,.312,+IBCDFN) - ; - D FUTURE^IBCNSM31 K Y,IBFUTUR -PATPOLQ Q - ; -CHPL ; Change policy plan if the policy company differs from plan company. - ; Required variable input: - ; DFN -- pointer to the patient in file #2 - ; IBCDFN -- pointer to the policy in file #2.312 - ; IBCNS -- pointer to the plan company in file #36 - ; - N IBBU,IBCNS1,IBCPOL1,IBNEWP1,IBPLAN,IBIP,IBT,X - S X=$G(^DPT(DFN,.312,IBCDFN,0)),IBCNS1=+X - S IBPLAN=$P(X,"^",18),IBIP='$P($G(^IBA(355.3,IBPLAN,0)),"^",2) - W !!,"Since you have changed the Insurance Company to ",$E($P($G(^DIC(36,IBCNS1,0)),"^"),1,25),"," - W !,"you must now change the Insurance Plan to which this veteran" - W !,"is subscribing to one which is offered by this company!",! - ; - ; - warn about benefits used - D BU^IBCNSJ21 I $O(IBBU(0)) D - .W !,"The current policy plan has Benefits Used associated with it!" - .W !,"If you add or select another plan to associate with this policy," - .W !,"these Benefits Used will be deleted!",! - ; - ; - warn about Individual Plans - I IBIP D - .W !," *** Please note: Since the veteran's current plan is an Individual Plan," - .W !?21,"this plan will be deleted if you add or select a new" - .W !?21,"plan to associate with this policy.",! - ; - ; - select or add a new plan - S IBCPOL1=$$LK^IBCNSM31(IBCNS1) - I 'IBCPOL1 D NEW^IBCNSJ3(IBCNS1,.IBCPOL1) S:IBCPOL1 IBNEWP1=1 - I 'IBCPOL1 D G CHPLQ - .W !!,"A new plan was not added or selected!" - .W !,"Changing the policy company back to ",$E($P($G(^DIC(36,IBCNS,0)),"^"),1,25),"..." - .S DIE="^DPT(DFN,.312,",DA(1)=DFN,DA=IBCDFN,DR=".01////"_IBCNS_";1.05///NOW;1.06////"_DUZ D ^DIE K DA,DIE,DR - ; - W !!,"Changing the policy plan..." - S DIE="^DPT(DFN,.312,",DA(1)=DFN,DA=IBCDFN,DR=".18////"_IBCPOL1_";1.05///NOW;1.06////"_DUZ D ^DIE K DA,DIE,DR - I IBIP!$G(IBNEWP) W !!,"Deleting the ",$S(IBIP:"current Individual",1:"previously-added")," plan for ",$E($P($G(^DIC(36,IBCNS,0)),"^"),1,25),"..." D DEL^IBCNSJ(IBPLAN) - ; - ; - delete any dangling benefits used - I $O(IBBU(0)) D - .N IBDAT - .W !!,"Deleting current Benefits Used... " - .S IBDAT="" F S IBDA=$O(IBBU(IBDAT)) Q:IBDAT="" D DBU^IBCNSJ(IBBU(IBDAT)) - ; - ; - repoint all Insurance Reviews to new company - I $$IR^IBCNSJ21(DFN,IBCDFN) D - .W !!,"Repointing all Insurance Reviews to ",$E($P($G(^DIC(36,IBCNS1,0)),"^"),1,25),"... " - .S IBT=0 F S IBT=$O(^IBT(356.2,"D",DFN,IBT)) Q:'IBT I $P($G(^IBT(356.2,IBT,1)),"^",5)=IBCDFN,$P($G(^(0)),"^",8)'=IBCNS1 S DA=IBT,DR=".08////"_IBCNS1,DIE="^IBT(356.2," D ^DIE K DA,DR,DIE W "." - ; - S IBCNS=IBCNS1,IBNEWP=$G(IBNEWP1) -CHPLQ Q - ; -PLAN(DFN,IBCDFN,IBCNS) ; Fix policies when identified. - ; - ; This function is invoked from Inactivate Plan or Change Policy Plan, - ; when it is recognized that the policy and plan companies are out - ; of synch. If the user doesn't select a new plan to associate with - ; the policy, the policy company will be changed to the plan company. - ; - ; The input parameters are defined above. - ; - N IBNEWP - I '$G(DFN)!'$G(IBCDFN)!'$G(IBCNS) G PLANQ - W !!,*7,"The policy company and plan company are not the same!!" - W !,"This inconsistency probably occurred in the past when changing" - W !,"the policy company through Screen 5 of Registration." - W !!,"You must resolve this inconsistency. If you do not choose a new plan" - W !,"offered by the policy company, the policy company will be changed to" - W !,"the plan company (",$P($G(^DIC(36,IBCNS,0)),"^"),") ...." - D CHPL -PLANQ Q -HLP ; -- help text for subscriber id - W !,?5,"Enter Medicare Claim Number (Subscriber ID) exactly as it" - W !,?5,"appears on the Medicare Insurance Card including All Characters." - W !,?5,"Valid HICN formats are: 1-3 alpha characters followed by 6 or 9 digits, " - W !,?5,"or 9 digits followed by 1 alpha character optionally followed by another " - W !,?5,"alpha character or 1 digit." - Q +IBCNSM32 ;ALB/AAS - INSURANCE MANAGEMENT - POLICY EDIT ; 23-JAN-95 + ;;2.0;INTEGRATED BILLING;**28,40,52,85,103,133,361**;21-MAR-94;Build 9 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; +PATPOL(IBCDFN) ; -- edit patient specific policy info + I '$G(IBCDFN) G PATPOLQ + D SAVEPT^IBCNSP3(DFN,IBCDFN) + D POL^IBCNSU41(DFN) + ; + ; -- give warning if expired or inactive co. + I $P(^DPT(DFN,.312,IBCDFN,0),"^",4),$P(^(0),"^",4)'>DT W !,"WARNING: This appears to be an expired policy!",! + I $P(^DIC(36,+$P(^DPT(DFN,.312,IBCDFN,0),"^"),0),"^",5) W !,*7,"WARNING: This insurance company is INACTIVE!",! + ; + N IBAD,IBDIF,DA,DR,DIC,DIE,DGSENFLG S DGSENFLG=1 + S DIE="^DPT("_DFN_",.312,",DA(1)=DFN,DA=IBCDFN + S DR="S IBAD="""";8;@333;3;D FUTURE^IBCNSM31;6;S IBAD=X;K X I '$$VET^IBCNSU1() S Y=""@10"";17///^S X=$P(^DPT(DFN,0),U);16///^S X=""01""" + ;S DR="S IBAD="""";8;@333;3;D FUTURE^IBCNSM31;6;S IBAD=X;I IBAD'=""v"" S Y=""@10"";17"_$S($$VET^IBCNSU1():"///^S X="""_$P(^DPT(DFN,0),U,1)_"""",1:"//"_);16///^S X=""01""" + S DR=DR_";S Y=""@20"";@10;17;16//^S X=$S(IBAD=""s"":""02"",1:"""");@20;1;3.01;3.12;1.09//;I $G(IBREG) S Y=""@99"";.2;4.01;4.02;@99" + I $G(IBREG),$D(^XUSEC("IB INSURANCE SUPERVISOR",DUZ)) S DR=".01//;"_DR + L +^DPT(DFN,.312,+IBCDFN):5 I '$T D LOCKED^IBTRCD1 G PATPOLQ + D ^DIE I $D(Y)!($D(DTOUT)) S IBQUIT=1 + I '$D(DA) S IBQUIT=1 G PATPOLQ + ; + ; -- if the company was changed, change the policy plan + I $G(IBREG),$G(IBCNS),+$G(^DPT(DFN,.312,IBCDFN,0))'=IBCNS D CHPL + ; + K IBFUTUR + D COMPPT^IBCNSP3(DFN,IBCDFN) + I IBDIF D UPDATPT^IBCNSP3(DFN,IBCDFN) + L -^DPT(DFN,.312,+IBCDFN) + ; + D FUTURE^IBCNSM31 K Y,IBFUTUR +PATPOLQ Q + ; +CHPL ; Change policy plan if the policy company differs from plan company. + ; Required variable input: + ; DFN -- pointer to the patient in file #2 + ; IBCDFN -- pointer to the policy in file #2.312 + ; IBCNS -- pointer to the plan company in file #36 + ; + N IBBU,IBCNS1,IBCPOL1,IBNEWP1,IBPLAN,IBIP,IBT,X + S X=$G(^DPT(DFN,.312,IBCDFN,0)),IBCNS1=+X + S IBPLAN=$P(X,"^",18),IBIP='$P($G(^IBA(355.3,IBPLAN,0)),"^",2) + W !!,"Since you have changed the Insurance Company to ",$E($P($G(^DIC(36,IBCNS1,0)),"^"),1,25),"," + W !,"you must now change the Insurance Plan to which this veteran" + W !,"is subscribing to one which is offered by this company!",! + ; + ; - warn about benefits used + D BU^IBCNSJ21 I $O(IBBU(0)) D + .W !,"The current policy plan has Benefits Used associated with it!" + .W !,"If you add or select another plan to associate with this policy," + .W !,"these Benefits Used will be deleted!",! + ; + ; - warn about Individual Plans + I IBIP D + .W !," *** Please note: Since the veteran's current plan is an Individual Plan," + .W !?21,"this plan will be deleted if you add or select a new" + .W !?21,"plan to associate with this policy.",! + ; + ; - select or add a new plan + S IBCPOL1=$$LK^IBCNSM31(IBCNS1) + I 'IBCPOL1 D NEW^IBCNSJ3(IBCNS1,.IBCPOL1) S:IBCPOL1 IBNEWP1=1 + I 'IBCPOL1 D G CHPLQ + .W !!,"A new plan was not added or selected!" + .W !,"Changing the policy company back to ",$E($P($G(^DIC(36,IBCNS,0)),"^"),1,25),"..." + .S DIE="^DPT(DFN,.312,",DA(1)=DFN,DA=IBCDFN,DR=".01////"_IBCNS_";1.05///NOW;1.06////"_DUZ D ^DIE K DA,DIE,DR + ; + W !!,"Changing the policy plan..." + S DIE="^DPT(DFN,.312,",DA(1)=DFN,DA=IBCDFN,DR=".18////"_IBCPOL1_";1.05///NOW;1.06////"_DUZ D ^DIE K DA,DIE,DR + I IBIP!$G(IBNEWP) W !!,"Deleting the ",$S(IBIP:"current Individual",1:"previously-added")," plan for ",$E($P($G(^DIC(36,IBCNS,0)),"^"),1,25),"..." D DEL^IBCNSJ(IBPLAN) + ; + ; - delete any dangling benefits used + I $O(IBBU(0)) D + .N IBDAT + .W !!,"Deleting current Benefits Used... " + .S IBDAT="" F S IBDA=$O(IBBU(IBDAT)) Q:IBDAT="" D DBU^IBCNSJ(IBBU(IBDAT)) + ; + ; - repoint all Insurance Reviews to new company + I $$IR^IBCNSJ21(DFN,IBCDFN) D + .W !!,"Repointing all Insurance Reviews to ",$E($P($G(^DIC(36,IBCNS1,0)),"^"),1,25),"... " + .S IBT=0 F S IBT=$O(^IBT(356.2,"D",DFN,IBT)) Q:'IBT I $P($G(^IBT(356.2,IBT,1)),"^",5)=IBCDFN,$P($G(^(0)),"^",8)'=IBCNS1 S DA=IBT,DR=".08////"_IBCNS1,DIE="^IBT(356.2," D ^DIE K DA,DR,DIE W "." + ; + S IBCNS=IBCNS1,IBNEWP=$G(IBNEWP1) +CHPLQ Q + ; +PLAN(DFN,IBCDFN,IBCNS) ; Fix policies when identified. + ; + ; This function is invoked from Inactivate Plan or Change Policy Plan, + ; when it is recognized that the policy and plan companies are out + ; of synch. If the user doesn't select a new plan to associate with + ; the policy, the policy company will be changed to the plan company. + ; + ; The input parameters are defined above. + ; + N IBNEWP + I '$G(DFN)!'$G(IBCDFN)!'$G(IBCNS) G PLANQ + W !!,*7,"The policy company and plan company are not the same!!" + W !,"This inconsistency probably occurred in the past when changing" + W !,"the policy company through Screen 5 of Registration." + W !!,"You must resolve this inconsistency. If you do not choose a new plan" + W !,"offered by the policy company, the policy company will be changed to" + W !,"the plan company (",$P($G(^DIC(36,IBCNS,0)),"^"),") ...." + D CHPL +PLANQ Q +HLP ; -- help text for subscriber id + W !,?5,"Enter Medicare Claim Number (Subscriber ID) exactly as it" + W !,?5,"appears on the Medicare Insurance Card including All Characters." + W !,?5,"Valid HICN formats are: 1-3 alpha characters followed by 6 or 9 digits, " + W !,?5,"or 9 digits followed by 1 alpha character optionally followed by another " + W !,?5,"alpha character or 1 digit." + Q diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP.m index 15180097..7a3d3040 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP.m @@ -1,163 +1,132 @@ -IBCNSP ;ALB/AAS - INSURANCE MANAGEMENT - EXPANDED POLICY ;05-MAR-1993 - ;;2.0;INTEGRATED BILLING;**6,28,43,52,85,251,363,371**;21-MAR-94;Build 57 - ;;Per VHA Directive 2004-038, this routine should not be modified. -% ; -EN ; -- main entry point for IBCNS EXPANDED POLICY - N IB1ST - K VALMQUIT,IBPPOL - S IBTOP="IBCNSP" - D EN^VALM("IBCNS EXPANDED POLICY") - Q - ; -HDR ; -- header code - N W,X,Y,Z - S VALMHDR(1)="Expanded Policy Information for: "_$E($P(^DPT(DFN,0),U),1,20)_" "_$P($$PT^IBEFUNC(DFN),U,2) - S Z=$G(^DPT(DFN,.312,+$P(IBPPOL,U,4),0)) - S W=$P($G(^IBA(355.3,+$P(Z,U,18),0)),U,11) - S Y=$E($P($G(^DIC(36,+Z,0)),U),1,20)_" Insurance Company" - S X="** Plan Currently "_$S(W:"Ina",1:"A")_"ctive **" - S VALMHDR(2)=$$SETSTR^VALM1(X,Y,48,29) - Q - ; -INIT ; -- init variables and list array - K VALMQUIT - S VALMCNT=0,VALMBG=1 - I '$D(IBPPOL) D PPOL Q:$D(VALMQUIT) - K ^TMP("IBCNSVP",$J) - D BLD,HDR - Q - ; -BLD ; -- list builder - K ^TMP("IBCNSVP",$J),^TMP("IBCNSVPDX",$J) - D KILL^VALM10() - F I=1:1:20 D BLANK(.I) ; start with 20 blank lines - N IBCDFND,IBCDFND1,IBCDFND2,IBCDFND4,IBCDFND5 - S IBCDFND=$G(^DPT(DFN,.312,$P(IBPPOL,U,4),0)),IBCDFND1=$G(^(1)),IBCDFND2=$G(^(2)),IBCDFND4=$G(^(4)),IBCDFND5=$G(^(5)) - S IBCPOL=+$P(IBCDFND,U,18),IBCNS=+IBCDFND,IBCDFN=$P(IBPPOL,U,4) - S IBCPOLD=$G(^IBA(355.3,+$P(IBCDFND,U,18),0)),IBCPOLD1=$G(^(1)) - S IBCPOLD2=$G(^IBA(355.3,+$G(IBCPOL),6)) ;; Daou/EEN adding BIN and PCN - ; - D POLICY^IBCNSP0 ; plan information - D INS^IBCNSP0 ; insurance company - D UR ; utilization review info - D EFFECT ; effective dates & source of info - D SUBSC^IBCNSP01 ; subscriber info - D EMP ; subscriber's employer info - D SPON^IBCNSP0 ; insured person's info - D ID^IBCNSP01 ; ins co ID numbers (IB*2*371) - D PLIM ; plan coverage limitations - D VER^IBCNSP01 ; user/verifier/editor info - D CONTACT^IBCNSP0 ; last insurance contact - D COMMENT ; comments - policy & plan - D RIDER^IBCNSP01 ; policy rider info - ; - S VALMCNT=+$O(^TMP("IBCNSVP",$J,""),-1) - Q - ; -COMMENT ; -- Comment region - N START,OFFSET,IBL,IBI - S (START,IBL)=$O(^TMP("IBCNSVP",$J,""),-1)+1,OFFSET=2 - S IB1ST("COMMENT")=START - D SET(START,OFFSET," Comment -- Patient Policy ",IORVON,IORVOFF) - S IBL=IBL+1 - D SET(IBL,OFFSET,$S($P(IBCDFND1,U,8)="":"None",1:$P(IBCDFND1,U,8))) - S IBL=IBL+1 - D SET(IBL,OFFSET," ") - S IBL=IBL+1 - D SET(IBL,OFFSET," Comment -- Group Plan ",IORVON,IORVOFF) - S IBI=0 F S IBI=$O(^IBA(355.3,+IBCPOL,11,IBI)) Q:IBI<1 D - . S IBL=IBL+1 - . D SET(IBL,OFFSET," "_$E($G(^IBA(355.3,+IBCPOL,11,IBI,0)),1,80)) - . Q - S IBL=IBL+1 D SET(IBL,OFFSET," ") - S IBL=IBL+1 D SET(IBL,OFFSET," ") - Q - ; -EFFECT ; -- Effective date region - N START,OFFSET - S START=16,OFFSET=45 - D SET(START,OFFSET-4," Effective Dates & Source ",IORVON,IORVOFF) - D SET(START+1,OFFSET," Effective Date: "_$$DAT1^IBOUTL($P(IBCDFND,U,8))) - D SET(START+2,OFFSET,"Expiration Date: "_$$DAT1^IBOUTL($P(IBCDFND,U,4))) - D SET(START+3,OFFSET," Source of Info: "_$$EXPAND^IBTRE(2.312,1.09,$P($G(IBCDFND1),U,9))) - D SET(START+4,OFFSET-4,"Policy Not Billable: "_$S($P($G(^DPT(DFN,.312,IBCDFN,3)),"^",4):"YES",1:"NO")) - Q - ; -UR ; -- UR of insurance region - N START,OFFSET - S START=16,OFFSET=2 - D SET(START,OFFSET," Utilization Review Info ",IORVON,IORVOFF) - D SET(START+1,OFFSET," Require UR: "_$$EXPAND^IBTRE(355.3,.05,$P(IBCPOLD,U,5))) - D SET(START+2,OFFSET," Require Amb Cert: "_$$EXPAND^IBTRE(355.3,.12,$P(IBCPOLD,U,12))) - D SET(START+3,OFFSET," Require Pre-Cert: "_$$EXPAND^IBTRE(355.3,.06,$P(IBCPOLD,U,6))) - D SET(START+4,OFFSET," Exclude Pre-Cond: "_$$EXPAND^IBTRE(355.3,.07,$P(IBCPOLD,U,7))) - D SET(START+5,OFFSET,"Benefits Assignable: "_$$EXPAND^IBTRE(355.3,.08,$P(IBCPOLD,U,8))) - Q -EMP ; -- Insurance Employer Region - N OFFSET,START,IBADD - S START=24,OFFSET=40 - D SET(START,OFFSET," Subscriber's Employer Information ",IORVON,IORVOFF) - D SET(START+1,OFFSET,"Emp Sponsored Plan: "_$S(+$P(IBCDFND2,U,10):"Yes",1:"No")) - D SET(START+2,OFFSET," Employer: "_$P(IBCDFND2,U,9)) - D SET(START+3,OFFSET," Employment Status: "_$$EXPAND^IBTRE(2.312,2.11,$P(IBCDFND2,U,11))) - D SET(START+4,OFFSET," Retirement Date: "_$$DAT1^IBOUTL($P(IBCDFND2,U,12))) - D SET(START+5,OFFSET,"Claims to Employer: "_$S(+IBCDFND2:"Yes, Send to Employer",1:"No, Send to Insurance Company")) - ; - D SET(START+6,OFFSET," Street: "_$P(IBCDFND2,U,2)) S IBADD=1 - I $P(IBCDFND2,U,3)'="" D SET(START+7,OFFSET," Street 2: "_$P(IBCDFND2,U,3)) S IBADD=2 - I $P(IBCDFND2,U,4)'="" D SET(START+8,OFFSET," Street 3: "_$P(IBCDFND2,U,4)) S IBADD=3 - D SET(START+6+IBADD,OFFSET," City/State: "_$E($P(IBCDFND2,U,5),1,15)_$S($P(IBCDFND2,U,5)="":"",1:", ")_$P($G(^DIC(5,+$P(IBCDFND2,U,6),0)),U,2)_" "_$E($P(IBCDFND2,U,7),1,5)) - D SET(START+7+IBADD,OFFSET," Phone: "_$P(IBCDFND2,U,8)) - ; - ; couple of blank lines to end this section - D SET(START+8+IBADD,2," ") - D SET(START+9+IBADD,2," ") - ; -EMPQ Q - ; -PLIM ; plan coverage limitations/plan limitation category display - N START,END S START=$O(^TMP("IBCNSVP",$J,""),-1)+1 - S IB1ST("PLIM")=START - D LIMBLD^IBCNSC41(START,2) - S END=$O(^TMP("IBCNSVP",$J,""),-1) ; last line constructed - D SET(END+1,2," ") ; 2 blank lines to end this section - D SET(END+2,2," ") -PLIMX ; - Q - ; -HELP ; -- help code - S X="?" D DISP^XQORM1 W !! - Q - ; -EXIT ; -- exit code - K IBPPOL,VALMQUIT,IBCNS,IBCPOL,IBCPOLD,IBCPOLD1,IBCPOLD2,IBCDFND,IBCDFND1,IBCDFND2 - D CLEAN^VALM10,CLEAR^VALM1 - Q - ; -EXPND ; -- expand code - Q - ; -PPOL ; -- select patient, select policy - I '$D(DFN) D G:$D(VALMQUIT) PPOLQ - .S DIC="^DPT(",DIC(0)="AEQMN" D ^DIC - .S DFN=+Y - I $G(DFN)<1 S VALMQUIT="" G PPOLQ - ; - I '$O(^DPT(DFN,.312,0)) W !!,"Patient doesn't have Insurance" K DFN G PPOL - ; - S DIC="^DPT("_DFN_",.312,",DIC(0)="AEQMN",DIC("A")="Select Patient Policy: " - D ^DIC I +Y<1 S VALMQUIT="" - G:$D(VALMQUIT) PPOLQ - S IBPPOL="^2^"_DFN_U_+Y_U_$G(^DPT(DFN,.312,+Y,0)) -PPOLQ K DIC Q - ; -BLANK(LINE) ; -- Build blank line - D SET^VALM10(.LINE,$J("",80)) - Q - ; -SET(LINE,COL,TEXT,ON,OFF) ; -- set display info in array - I '$D(@VALMAR@(LINE,0)) D BLANK(.LINE) S VALMCNT=$G(VALMCNT)+1 - D SET^VALM10(.LINE,$$SETSTR^VALM1(.TEXT,@VALMAR@(LINE,0),.COL,$L(TEXT))) - D:$G(ON)]""!($G(OFF)]"") CNTRL^VALM10(.LINE,.COL,$L(TEXT),$G(ON),$G(OFF)) - W:'(LINE#5) "." - Q +IBCNSP ;ALB/AAS - INSURANCE MANAGEMENT - EXPANDED POLICY ;05-MAR-1993 + ;;2.0;INTEGRATED BILLING;**6,28,43,52,85,251,363**;21-MAR-94;Build 35 + ;;Per VHA Directive 2004-038, this routine should not be modified. +% ; +EN ; -- main entry point for IBCNS EXPANDED POLICY + K VALMQUIT,IBPPOL + S IBTOP="IBCNSP" + D EN^VALM("IBCNS EXPANDED POLICY") + Q + ; +HDR ; -- header code + N W,X,Y,Z + S VALMHDR(1)="Expanded Policy Information for: "_$E($P(^DPT(DFN,0),U),1,20)_" "_$P($$PT^IBEFUNC(DFN),U,2) + S Z=$G(^DPT(DFN,.312,+$P(IBPPOL,U,4),0)) + S W=$P($G(^IBA(355.3,+$P(Z,U,18),0)),U,11) + S Y=$E($P($G(^DIC(36,+Z,0)),U),1,20)_" Insurance Company" + S X="** Plan Currently "_$S(W:"Ina",1:"A")_"ctive **" + S VALMHDR(2)=$$SETSTR^VALM1(X,Y,48,29) + Q + ; +INIT ; -- init variables and list array + K VALMQUIT + S VALMCNT=0,VALMBG=1 + I '$D(IBPPOL) D PPOL Q:$D(VALMQUIT) + K ^TMP("IBCNSVP",$J) + D BLD,HDR + Q + ; +BLD ; -- list builder + K ^TMP("IBCNSVP",$J),^TMP("IBCNSVPDX",$J) + D KILL^VALM10() + F I=1:1:50 D BLANK(.I) + S VALMCNT=50 + N IBCDFND,IBCDFND1,IBCDFND2,IBCDFND4 + S IBCDFND=$G(^DPT(DFN,.312,$P(IBPPOL,U,4),0)),IBCDFND1=$G(^(1)),IBCDFND2=$G(^(2)),IBCDFND4=$G(^(4)) + S IBCPOL=+$P(IBCDFND,U,18),IBCNS=+IBCDFND,IBCDFN=$P(IBPPOL,U,4) + S IBCPOLD=$G(^IBA(355.3,+$P(IBCDFND,U,18),0)),IBCPOLD1=$G(^(1)) + S IBCPOLD2=$G(^IBA(355.3,+$G(IBCPOL),6)) ;; Daou/EEN adding BIN and PCN + S IBLCNT=0 + D POLICY^IBCNSP0,INS^IBCNSP0,SPON^IBCNSP0,LIMBLD^IBCNSC41(36,2,.IBLCNT) + D CONTACT^IBCNSP0,EFFECT,UR,EMP,VER^IBCNSP01,COMMENT,^IBCNSP01 + Q + ; +COMMENT ; -- Comment region + N START,OFFSET,IBL,IBI + S START=49+$G(IBLCNT),OFFSET=2,IBL=0 + I '$D(@VALMAR@(START-1)) D SET(START-1,OFFSET," ") + D SET(START,OFFSET," Comment -- Patient Policy ",IORVON,IORVOFF) + D SET(START+1,OFFSET,$S($P(IBCDFND1,U,8)="":"None",1:$P(IBCDFND1,U,8))) + I '$D(@VALMAR@(START+2)) D SET(START+2,OFFSET," ") + D SET(START+3,OFFSET," Comment -- Group Plan ",IORVON,IORVOFF) + S IBI=0 F S IBI=$O(^IBA(355.3,+IBCPOL,11,IBI)) Q:IBI<1 D + .S IBL=IBL+1 + .D SET(START+IBL+3,OFFSET," "_$E($G(^IBA(355.3,+IBCPOL,11,IBI,0)),1,80)) + S IBLCNT=$G(IBLCNT)+IBL+1 D SET(START+IBL+4,OFFSET," ") + Q + ; +EFFECT ; -- Effective date region + N START,OFFSET + S START=14,OFFSET=45 + D SET(START,OFFSET-4," Effective Dates & Source ",IORVON,IORVOFF) + D SET(START+1,OFFSET," Effective Date: "_$$DAT1^IBOUTL($P(IBCDFND,U,8))) + D SET(START+2,OFFSET,"Expiration Date: "_$$DAT1^IBOUTL($P(IBCDFND,U,4))) + D SET(START+3,OFFSET," Source of Info: "_$$EXPAND^IBTRE(2.312,1.09,$P($G(IBCDFND1),U,9))) + D SET(START+4,OFFSET-4,"Policy Not Billable: "_$S($P($G(^DPT(DFN,.312,IBCDFN,3)),"^",4):"YES",1:"NO")) + Q + ; +UR ; -- UR of insurance region + N START,OFFSET + S START=14,OFFSET=2 + D SET(START,OFFSET," Utilization Review Info ",IORVON,IORVOFF) + D SET(START+1,OFFSET," Require UR: "_$$EXPAND^IBTRE(355.3,.05,$P(IBCPOLD,U,5))) + D SET(START+2,OFFSET," Require Amb Cert: "_$$EXPAND^IBTRE(355.3,.12,$P(IBCPOLD,U,12))) + D SET(START+3,OFFSET," Require Pre-Cert: "_$$EXPAND^IBTRE(355.3,.06,$P(IBCPOLD,U,6))) + D SET(START+4,OFFSET," Exclude Pre-Cond: "_$$EXPAND^IBTRE(355.3,.07,$P(IBCPOLD,U,7))) + D SET(START+5,OFFSET,"Benefits Assignable: "_$$EXPAND^IBTRE(355.3,.08,$P(IBCPOLD,U,8))) + Q +EMP ; -- Insurance Employer Region + N OFFSET,START,IBADD + S START=19,OFFSET=40 + D SET(START,OFFSET," Subscriber's Employer Information ",IORVON,IORVOFF) + D SET(START+1,OFFSET,"Emp Sponsored Plan: "_$S(+$P(IBCDFND2,U,10):"Yes",1:"No")) + D SET(START+2,OFFSET," Employer: "_$P(IBCDFND2,U,9)) + D SET(START+3,OFFSET," Employment Status: "_$$EXPAND^IBTRE(2.312,2.11,$P(IBCDFND2,U,11))) + D SET(START+4,OFFSET," Retirement Date: "_$$DAT1^IBOUTL($P(IBCDFND2,U,12))) + D SET(START+5,OFFSET,"Claims to Employer: "_$S(+IBCDFND2:"Yes, Send to Employer",1:"No, Send to Insurance Company")) + ;I +IBCDFND2 W !!,"If ROI applies, make sure current consent is signed.",!! D PAUSE^VALM1 + ; + D SET(START+6,OFFSET," Street: "_$P(IBCDFND2,U,2)) S IBADD=1 + I $P(IBCDFND2,U,3)'="" D SET(START+7,OFFSET," Street 2: "_$P(IBCDFND2,U,3)) S IBADD=2 + I $P(IBCDFND2,U,4)'="" D SET(START+8,OFFSET," Street 3: "_$P(IBCDFND2,U,4)) S IBADD=3 + D SET(START+6+IBADD,OFFSET," City/State: "_$E($P(IBCDFND2,U,5),1,15)_$S($P(IBCDFND2,U,5)="":"",1:", ")_$P($G(^DIC(5,+$P(IBCDFND2,U,6),0)),U,2)_" "_$E($P(IBCDFND2,U,7),1,5)) + D SET(START+7+IBADD,OFFSET," Phone: "_$P(IBCDFND2,U,8)) + ; +EMPQ Q + ; +HELP ; -- help code + S X="?" D DISP^XQORM1 W !! + Q + ; +EXIT ; -- exit code + K IBPPOL,VALMQUIT,IBCNS,IBCPOL,IBCPOLD,IBCPOLD1,IBCPOLD2,IBCDFND,IBCDFND1,IBCDFND2 + D CLEAN^VALM10,CLEAR^VALM1 + Q + ; +EXPND ; -- expand code + Q + ; +PPOL ; -- select patient, select policy + I '$D(DFN) D G:$D(VALMQUIT) PPOLQ + .S DIC="^DPT(",DIC(0)="AEQMN" D ^DIC + .S DFN=+Y + I $G(DFN)<1 S VALMQUIT="" G PPOLQ + ; + I '$O(^DPT(DFN,.312,0)) W !!,"Patient doesn't have Insurance" K DFN G PPOL + ; + S DIC="^DPT("_DFN_",.312,",DIC(0)="AEQMN",DIC("A")="Select Patient Policy: " + D ^DIC I +Y<1 S VALMQUIT="" + G:$D(VALMQUIT) PPOLQ + S IBPPOL="^2^"_DFN_U_+Y_U_$G(^DPT(DFN,.312,+Y,0)) +PPOLQ K DIC Q + ; +BLANK(LINE) ; -- Build blank line + D SET^VALM10(.LINE,$J("",80)) + Q + ; +SET(LINE,COL,TEXT,ON,OFF) ; -- set display info in array + I '$D(@VALMAR@(LINE,0)) D BLANK(.LINE) S VALMCNT=$G(VALMCNT)+1 + D SET^VALM10(.LINE,$$SETSTR^VALM1(.TEXT,@VALMAR@(LINE,0),.COL,$L(TEXT))) + D:$G(ON)]""!($G(OFF)]"") CNTRL^VALM10(.LINE,.COL,$L(TEXT),$G(ON),$G(OFF)) + W:'(LINE#5) "." + Q diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP0.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP0.m index 3c494c3a..4051fa50 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP0.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP0.m @@ -1,132 +1,118 @@ -IBCNSP0 ;ALB/AAS - INSURANCE MANAGEMENT - EXPANDED POLICY ;05-MAR-1993 - ;;2.0;INTEGRATED BILLING;**28,43,52,85,93,103,137,229,251,363,371**;21-MAR-94;Build 57 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ; -CONTACT ; -- Insurance Contact Information - N OFFSET,START - ; - ; The start of this section is designed to start on the same line - ; as the User Information section (see VER^IBCNSP01). - ; - S START=$O(^TMP("IBCNSVP",$J,""),-1)-8 - S IB1ST("CONTACT")=START - S OFFSET=42 - N IBTRC,IBTRCD,IBTCOD - S IBTCOD=$O(^IBE(356.11,"ACODE",85,0)) - ; - S IBTRC=0,IBTRCD="" - F S IBTRC=$O(^IBT(356.2,"D",DFN,IBTRC)) Q:'IBTRC D - .Q:$P($G(^IBT(356.2,+IBTRC,1)),"^",5)'=IBCDFN ; must be same policy - .Q:$P($G(^IBT(356.2,+IBTRC,0)),"^",4)'=IBTCOD ; must be ins. ver. type - .S IBTRCD=$G(^IBT(356.2,+IBTRC,0)) - ; - D SET(START,OFFSET," Insurance Contact (last) ",IORVON,IORVOFF) - D SET(START+1,OFFSET," Person Contacted: "_$$EXPAND^IBTRE(356.2,.06,$P(IBTRCD,"^",6))) - D SET(START+2,OFFSET,"Method of Contact: "_$$EXPAND^IBTRE(356.2,.17,$P(IBTRCD,"^",17))) - D SET(START+3,OFFSET," Contact's Phone: "_$$EXPAND^IBTRE(356.2,.07,$P(IBTRCD,"^",7))) - D SET(START+4,OFFSET," Call Ref. No.: "_$$EXPAND^IBTRE(356.2,.09,$P(IBTRCD,"^",9))) - D SET(START+5,OFFSET," Contact Date: "_$$EXPAND^IBTRE(356.2,.01,$P(IBTRCD,"^"))) - ; no blank lines here because the User Information section is on the - ; left and it is bigger than this section - Q - ; -POLICY ; -- Policy Region - ; -- if pointer to policy file exists get data from policy file - N OFFSET,START,IBP,IBX,IBPLNID,IBPLNNM,IBPLNNA,IBPLNLA - S (IBPLNID,IBPLNNM,IBPLNNA,IBPLNLA)="" - S START=1,OFFSET=2 - D GPLAN(+IBCPOLD2) - D SET(START,OFFSET," Plan Information ",IORVON,IORVOFF) - D SET(START+1,OFFSET," Is Group Plan: "_$S($P(IBCPOLD,"^",2)=1:"YES",1:"NO")) - D SET(START+2,OFFSET," Group Name: "_$P(IBCPOLD,"^",3)) - D SET(START+3,OFFSET," Group Number: "_$P(IBCPOLD,"^",4)) - D SET(START+4,OFFSET," BIN: "_$P(IBCPOLD2,"^",2)) ;;Daou/EEN - D SET(START+5,OFFSET," PCN: "_$P(IBCPOLD2,"^",3)) ;;04/09/04 - D SET(START+6,OFFSET," Type of Plan: "_$E($P($G(^IBE(355.1,+$P(IBCPOLD,"^",9),0)),"^"),1,23)) - S IBX=7 - I $P(IBCPOLD,U,14)]"" D - . D SET(START+IBX,OFFSET," Plan Category: "_$$EXPAND^IBTRE(355.3,.14,$P(IBCPOLD,"^",14))) S IBX=IBX+1 - I $P(IBCPOLD,U,15)]"" D - . D SET(START+IBX,OFFSET," Electronic Type: "_$$EXPAND^IBTRE(355.3,.15,$P(IBCPOLD,"^",15))) S IBX=IBX+1 - D SET(START+IBX,OFFSET," Plan Filing TF: "_$P(IBCPOLD,"^",13)) S IBX=IBX+1 - ; - D SET(START+IBX,OFFSET," ePharmacy Plan ID: "_IBPLNID) S IBX=IBX+1 - D SET(START+IBX,OFFSET," ePharmacy Plan Name: "_IBPLNNM) S IBX=IBX+1 - D SET(START+IBX,OFFSET," ePharmacy Natl Status: "_IBPLNNA) S IBX=IBX+1 - D SET(START+IBX,OFFSET," ePharmacy Local Status: "_IBPLNLA) S IBX=IBX+1 - ; - ; -- in case pointer is missing - I '$G(^IBA(355.3,+$P(IBCDFND,"^",18),0)) D - .D SET(START+1,OFFSET,"Insurance Number: "_$P(IBCDFND,"^",2)) - .D SET(START+2,OFFSET," Group Name: "_$P(IBCDFND,"^",15)) - .D SET(START+3,OFFSET," Group Number: "_$P(IBCDFND,"^",3)) - .Q - Q - ; -INS ; -- Insurance Co. Region - N OFFSET,START,IBADD,IBCDFNDA,IBCDFNDB - S START=1,OFFSET=45 - D SET(START,OFFSET," Insurance Company ",IORVON,IORVOFF) - D SET(START+1,OFFSET," Company: "_$P($G(^DIC(36,+IBCDFND,0)),"^")) - S IBCDFNDA=$G(^DIC(36,+IBCDFND,.11)),IBCDFNDB=$G(^(.13)) - G:IBCDFNDA="" INSQ - D SET(START+2,OFFSET," Street: "_$P(IBCDFNDA,"^")) S IBADD=1 - I $P(IBCDFNDA,"^",2)'="" D SET(START+3,OFFSET," Street 2: "_$P(IBCDFNDA,"^",2)) S IBADD=2 - I $P(IBCDFNDA,"^",3)'="" D SET(START+4,OFFSET," Street 3: "_$P(IBCDFNDA,"^",3)) S IBADD=3 - D SET(START+2+IBADD,OFFSET,"City/State: "_$E($P(IBCDFNDA,"^",4),1,15)_$S($P(IBCDFNDA,"^",4)="":"",1:", ")_$P($G(^DIC(5,+$P(IBCDFNDA,"^",5),0)),"^",2)_" "_$E($P(IBCDFNDA,"^",6),1,5)) - D SET(START+3+IBADD,OFFSET,"Billing Ph: "_$P(IBCDFNDB,"^",2)) - D SET(START+4+IBADD,OFFSET,"Precert Ph: "_$$PHONE^IBCNSC01(IBCDFNDB)) - ; -INSQ Q - ; -SPON ; -- Sponsor (Insured Person) Region - N IBC3,IBZIP,START,OFFSET,IBA,DA,DR,DIC,DIQ - S IBC3=$G(^DPT(DFN,.312,IBCDFN,3)) - S DA=+$P(IBC3,"^",2),DR=.01,DIQ(0)="E",DIC="^DIC(23,",DIQ="IBA" D EN^DIQ1 - S START=$O(^TMP("IBCNSVP",$J,""),-1)+1,OFFSET=4 - D SET(START,OFFSET," Insured Person's Information (use Subscriber Update Action) ",IORVON,IORVOFF) - D SET(START+1,OFFSET," Insured's DOB: "_$$DAT3^IBOUTL($P(IBC3,"^"))) - D SET(START+2,OFFSET," Insured's Sex: "_$$EXTERNAL^DILFD(2.312,3.12,,$P(IBC3,U,12))) - D SET(START+3,OFFSET," Insured's Branch: "_$G(IBA(23,DA,.01,"E"))) - D SET(START+4,OFFSET," Insured's Rank: "_$P(IBC3,"^",3)) - ; - S OFFSET=43 - S Y=$P(IBC3,"^",10) D ZIPOUT^VAFADDR S IBZIP=Y - D SET(START+1,OFFSET," Str 1: "_$P(IBC3,"^",6)) - D SET(START+2,OFFSET," Str 2: "_$P(IBC3,"^",7)) - D SET(START+3,OFFSET," City: "_$P(IBC3,"^",8)) - D SET(START+4,OFFSET,"St/Zip: "_$P($G(^DIC(5,+$P(IBC3,"^",9),0)),"^",2)_" "_IBZIP) - D SET(START+5,OFFSET," Phone: "_$P(IBC3,"^",11)) - ; - ; blank lines at end of section - D SET(START+6,2," ") - D SET(START+7,2," ") - Q - ; -BLANK(LINE) ; -- Build blank line - D SET^VALM10(.LINE,$J("",80)) - Q - ; -SET(LINE,COL,TEXT,ON,OFF) ; -- set display info in array - D:'$D(@VALMAR@(LINE,0)) BLANK(.LINE) - D SET^VALM10(.LINE,$$SETSTR^VALM1(.TEXT,@VALMAR@(LINE,0),.COL,$L(TEXT))) - D:$G(ON)]""!($G(OFF)]"") CNTRL^VALM10(.LINE,.COL,$L(TEXT),$G(ON),$G(OFF)) - W:'(LINE#5) "." - Q - ; -GPLAN(IBPLDA) ; get data from PLAN file (#366.03) related to the - ; GROUP INSURANCE PLAN file (#355.3) and the INSURANCE COMPANY file (#36) - ; that is associated with the PATIENT - ; input - IBPLDA - ien of the PLAN file (#366.03) - N IBPLN0,IBAIEN,IBAPIEN,IBAP0 - S IBPLN0=$G(^IBCNR(366.03,IBPLDA,0)) ;; Q:'$P(IBPLN0,"^",3) ;quit if payer not defined - S IBPLNID=$P(IBPLN0,"^"),IBPLNNM=$P(IBPLN0,"^",2) - S IBAIEN=$O(^IBCNR(366.13,"B","E-PHARM","")) Q:'IBAIEN - S IBAPIEN=$O(^IBCNR(366.03,IBPLDA,3,"B",IBAIEN,"")) Q:'IBAPIEN - S IBAP0=$G(^IBCNR(366.03,IBPLDA,3,IBAPIEN,0)) - S IBPLNNA=$S($P(IBAP0,"^",2)=0:"NOT ACTIVE",1:"ACTIVE") - S IBPLNLA=$S($P(IBAP0,"^",3)=0:"NOT ACTIVE",1:"ACTIVE") - Q - ; - ;IBCNSP0 +IBCNSP0 ;ALB/AAS - INSURANCE MANAGEMENT - EXPANDED POLICY ;05-MAR-1993 + ;;2.0;INTEGRATED BILLING;**28,43,52,85,93,103,137,229,251,363**;21-MAR-94;Build 35 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; + ; +CONTACT ; -- Insurance Contact Information + N OFFSET,START + S START=41+$G(IBLCNT),OFFSET=42 + N IBTRC,IBTRCD,IBTCOD + S IBTCOD=$O(^IBE(356.11,"ACODE",85,0)) + ; + S IBTRC=0,IBTRCD="" + F S IBTRC=$O(^IBT(356.2,"D",DFN,IBTRC)) Q:'IBTRC D + .Q:$P($G(^IBT(356.2,+IBTRC,1)),"^",5)'=IBCDFN ; must be same policy + .Q:$P($G(^IBT(356.2,+IBTRC,0)),"^",4)'=IBTCOD ; must be ins. ver. type + .S IBTRCD=$G(^IBT(356.2,+IBTRC,0)) + ; + I '$D(@VALMAR@(START-1)) D SET(START-1,OFFSET," ") + D SET(START,OFFSET," Insurance Contact (last) ",IORVON,IORVOFF) + D SET(START+1,OFFSET," Person Contacted: "_$$EXPAND^IBTRE(356.2,.06,$P(IBTRCD,"^",6))) + D SET(START+2,OFFSET,"Method of Contact: "_$$EXPAND^IBTRE(356.2,.17,$P(IBTRCD,"^",17))) + D SET(START+3,OFFSET," Contact's Phone: "_$$EXPAND^IBTRE(356.2,.07,$P(IBTRCD,"^",7))) + D SET(START+4,OFFSET," Call Ref. No.: "_$$EXPAND^IBTRE(356.2,.09,$P(IBTRCD,"^",9))) + D SET(START+5,OFFSET," Contact Date: "_$$EXPAND^IBTRE(356.2,.01,$P(IBTRCD,"^"))) + Q + ; +POLICY ; -- Policy Region + ; -- if pointer to policy file exists get data from policy file + N OFFSET,START,IBP,IBX,IBPLNID,IBPLNNM,IBPLNNA,IBPLNLA + S (IBPLNID,IBPLNNM,IBPLNNA,IBPLNLA)="" + S START=1,OFFSET=2 + D GPLAN(+IBCPOLD2) + D SET(START,OFFSET," Plan Information ",IORVON,IORVOFF) + D SET(START+1,OFFSET," Is Group Plan: "_$S($P(IBCPOLD,"^",2)=1:"YES",1:"NO")) + D SET(START+2,OFFSET," Group Name: "_$P(IBCPOLD,"^",3)) + D SET(START+3,OFFSET," Group Number: "_$P(IBCPOLD,"^",4)) + D SET(START+4,OFFSET," BIN: "_$P(IBCPOLD2,"^",2)) ;;Daou/EEN + D SET(START+5,OFFSET," PCN: "_$P(IBCPOLD2,"^",3)) ;;04/09/04 + D SET(START+6,OFFSET," Type of Plan: "_$E($P($G(^IBE(355.1,+$P(IBCPOLD,"^",9),0)),"^"),1,23)) + S IBX=7 + I $P(IBCPOLD,U,14)]"" D + . D SET(START+IBX,OFFSET," Plan Category: "_$$EXPAND^IBTRE(355.3,.14,$P(IBCPOLD,"^",14))) S IBX=IBX+1 + I $P(IBCPOLD,U,15)]"" D + . D SET(START+IBX,OFFSET," Electronic Type: "_$$EXPAND^IBTRE(355.3,.15,$P(IBCPOLD,"^",15))) S IBX=IBX+1 + D SET(START+IBX,OFFSET," Plan Filing TF: "_$P(IBCPOLD,"^",13)) S IBX=IBX+1 + ; -- in case pointer is missing + D SET(START+IBX,OFFSET," ePharmacy Plan ID: "_IBPLNID) S IBX=IBX+1 + D SET(START+IBX,OFFSET," ePharmacy Plan Name: "_IBPLNNM) S IBX=IBX+1 + D SET(START+IBX,OFFSET," ePharmacy Natl Status: "_IBPLNNA) S IBX=IBX+1 + D SET(START+IBX,OFFSET," ePharmacy Local Status: "_IBPLNLA) S IBX=IBX+1 + I '$G(^IBA(355.3,+$P(IBCDFND,"^",18),0)) D + .D SET(START+1,OFFSET,"Insurance Number: "_$P(IBCDFND,"^",2)) + .D SET(START+2,OFFSET," Group Name: "_$P(IBCDFND,"^",15)) + .D SET(START+3,OFFSET," Group Number: "_$P(IBCDFND,"^",3)) + .Q + Q + ; +INS ; -- Insurance Co. Region + N OFFSET,START,IBADD,IBCDFNDA,IBCDFNDB + S START=1,OFFSET=45 + D SET(START,OFFSET," Insurance Company ",IORVON,IORVOFF) + D SET(START+1,OFFSET," Company: "_$P($G(^DIC(36,+IBCDFND,0)),"^")) + S IBCDFNDA=$G(^DIC(36,+IBCDFND,.11)),IBCDFNDB=$G(^(.13)) + G:IBCDFNDA="" INSQ + D SET(START+2,OFFSET," Street: "_$P(IBCDFNDA,"^")) S IBADD=1 + I $P(IBCDFNDA,"^",2)'="" D SET(START+3,OFFSET," Street 2: "_$P(IBCDFNDA,"^",2)) S IBADD=2 + I $P(IBCDFNDA,"^",3)'="" D SET(START+4,OFFSET," Street 3: "_$P(IBCDFNDA,"^",3)) S IBADD=3 + D SET(START+2+IBADD,OFFSET,"City/State: "_$E($P(IBCDFNDA,"^",4),1,15)_$S($P(IBCDFNDA,"^",4)="":"",1:", ")_$P($G(^DIC(5,+$P(IBCDFNDA,"^",5),0)),"^",2)_" "_$E($P(IBCDFNDA,"^",6),1,5)) + D SET(START+3+IBADD,OFFSET,"Billing Ph: "_$P(IBCDFNDB,"^",2)) + D SET(START+4+IBADD,OFFSET,"Precert Ph: "_$$PHONE^IBCNSC01(IBCDFNDB)) + ; +INSQ Q + ; +SPON ; -- Sponsor (Insured Person) Region + N IBC3,IBSSN,IBZIP,START,OFFSET,IBA,DA,DR,DIC,DIQ + S IBC3=$G(^DPT(DFN,.312,IBCDFN,3)),IBSSN=$P(IBC3,"^",5) + S DA=+$P(IBC3,"^",2),DR=.01,DIQ(0)="E",DIC="^DIC(23,",DIQ="IBA" D EN^DIQ1 + S START=30,OFFSET=4 + D SET(START,OFFSET," Insured Person's Information (use Subscriber Update action) ",IORVON,IORVOFF) + D SET(START+1,OFFSET," Insured's DOB: "_$$DAT3^IBOUTL($P(IBC3,"^"))) + D SET(START+2,OFFSET," Insured's Branch: "_$G(IBA(23,DA,.01,"E"))) + D SET(START+3,OFFSET," Insured's Rank: "_$P(IBC3,"^",3)) + D SET(START+4,OFFSET," Insured's SSN: "_$S(IBSSN]"":$E(IBSSN,1,3)_"-"_$E(IBSSN,4,5)_"-"_$E(IBSSN,6,9),1:"")) + ; + S OFFSET=43 + S Y=$P(IBC3,"^",10) D ZIPOUT^VAFADDR S IBZIP=Y + D SET(START+1,OFFSET," Str 1: "_$P(IBC3,"^",6)) + D SET(START+2,OFFSET," Str 2: "_$P(IBC3,"^",7)) + D SET(START+3,OFFSET," City: "_$P(IBC3,"^",8)) + D SET(START+4,OFFSET,"St/Zip: "_$P($G(^DIC(5,+$P(IBC3,"^",9),0)),"^",2)_" "_IBZIP) + D SET(START+5,OFFSET," Phone: "_$P(IBC3,"^",11)) + Q + ; +BLANK(LINE) ; -- Build blank line + D SET^VALM10(.LINE,$J("",80)) + Q + ; +SET(LINE,COL,TEXT,ON,OFF) ; -- set display info in array + D:'$D(@VALMAR@(LINE,0)) BLANK(.LINE) + D SET^VALM10(.LINE,$$SETSTR^VALM1(.TEXT,@VALMAR@(LINE,0),.COL,$L(TEXT))) + D:$G(ON)]""!($G(OFF)]"") CNTRL^VALM10(.LINE,.COL,$L(TEXT),$G(ON),$G(OFF)) + W:'(LINE#5) "." + Q +GPLAN(IBPLDA) ; get data from PLAN file (#366.03) related to the + ; GROUP INSURANCE PLAN file (#355.3) and the INSURANCE COMPANY file (#36) + ; that is associated with the PATIENT + ; input - IBPLDA - ien of the PLAN file (#366.03) + N IBPLN0,IBAIEN,IBAPIEN,IBAP0 + S IBPLN0=$G(^IBCNR(366.03,IBPLDA,0)) ;; Q:'$P(IBPLN0,"^",3) ;quit if payer not defined + S IBPLNID=$P(IBPLN0,"^"),IBPLNNM=$P(IBPLN0,"^",2) + S IBAIEN=$O(^IBCNR(366.13,"B","E-PHARM","")) Q:'IBAIEN + S IBAPIEN=$O(^IBCNR(366.03,IBPLDA,3,"B",IBAIEN,"")) Q:'IBAPIEN + S IBAP0=$G(^IBCNR(366.03,IBPLDA,3,IBAPIEN,0)) + S IBPLNNA=$S($P(IBAP0,"^",2)=0:"NOT ACTIVE",1:"ACTIVE") + S IBPLNLA=$S($P(IBAP0,"^",3)=0:"NOT ACTIVE",1:"ACTIVE") + Q + ; + ;IBCNSP0 diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP01.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP01.m index 65fa0bc6..88b0cad3 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP01.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP01.m @@ -1,128 +1,89 @@ -IBCNSP01 ;ALB/AAS - INSURANCE MANAGEMENT - EXPANDED POLICY ;05-MAR-1993 - ;;2.0;INTEGRATED BILLING;**43,52,85,251,371,377**;21-MAR-94;Build 23 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ; -% D SUBSC,RIDER - Q - ; -SUBSC ; -- subscriber region - N OFFSET,START - S START=24,OFFSET=2 - D SET^IBCNSP(START,OFFSET," Subscriber Information ",IORVON,IORVOFF) - S Y=$P(IBCDFND,"^",6),C=$P(^DD(2.312,6,0),"^",2) D Y^DIQ - D SET^IBCNSP(START+1,OFFSET," Whose Insurance: "_Y) - D SET^IBCNSP(START+2,OFFSET," Subscriber Name: "_$P(IBCDFND,"^",17)) - S Y=$P(IBCDFND4,"^",3),C=$P(^DD(2.312,4.03,0),"^",2) D Y^DIQ - D SET^IBCNSP(START+3,OFFSET," Relationship: "_Y) - D SET^IBCNSP(START+4,OFFSET," Primary ID: "_$P(IBCDFND,"^",2)) - S Y=$P(IBCDFND,"^",20),C=$P(^DD(2.312,.2,0),"^",2) D Y^DIQ - D SET^IBCNSP(START+5,OFFSET,"Coord. Benefits: "_Y) - D SET^IBCNSP(START+6,OFFSET,"Primary Provider: "_$P(IBCDFND4,"^",1)) - D SET^IBCNSP(START+7,OFFSET," Prim Prov Phone: "_$P(IBCDFND4,"^",2)) - Q - ; -VER ; -- Entered/Verfied Region - N OFFSET,START - S START=$O(^TMP("IBCNSVP",$J,""),-1)+1,OFFSET=2 - S IB1ST("VERIFY")=START - D SET^IBCNSP(START,OFFSET," User Information ",IORVON,IORVOFF) - D SET^IBCNSP(START+1,OFFSET," Entered By: "_$E($P($G(^VA(200,+$P(IBCDFND1,"^",2),0)),"^",1),1,20)) - D SET^IBCNSP(START+2,OFFSET," Entered On: "_$$DAT1^IBOUTL(+IBCDFND1)) - D SET^IBCNSP(START+3,OFFSET,"Last Verified By: "_$E($P($G(^VA(200,+$P(IBCDFND1,"^",4),0)),"^",1),1,20)) - D SET^IBCNSP(START+4,OFFSET,"Last Verified On: "_$$DAT1^IBOUTL(+$P(IBCDFND1,"^",3))) - D SET^IBCNSP(START+5,OFFSET," Last Updated By: "_$E($P($G(^VA(200,+$P(IBCDFND1,"^",6),0)),"^",1),1,20)) - D SET^IBCNSP(START+6,OFFSET," Last Updated On: "_$$DAT1^IBOUTL(+$P(IBCDFND1,"^",5))) - D SET^IBCNSP(START+7,2," ") ; 2 blank lines to end section - D SET^IBCNSP(START+8,2," ") -VERQ Q - ; -ID ; Subscriber and patient primary and secondary ID's and qualifiers - NEW START,OFFSET,IBL,G,PCE,QUAL,QUAL1 - S G=IBCDFND5 - S (START,IBL)=$O(^TMP("IBCNSVP",$J,""),-1)+1,OFFSET=2 - S IB1ST("ID")=START - D SET^IBCNSP(START,OFFSET," Insurance Company ID Numbers (use Subscriber Update Action) ",IORVON,IORVOFF) - S IBL=IBL+1 - D SET^IBCNSP(IBL,OFFSET," Subscriber Primary ID: "_$P(IBCDFND,U,2)) - ; - F PCE=3,5,7 D ; subscriber secondary IDs - . I $P(G,U,PCE)="" Q ; no secondary ID# - . S QUAL=$P(G,U,PCE-1) ; internal qualifier code - . S QUAL1=$S(QUAL="23":"Client#",QUAL="IG":"Ins. Policy#",QUAL="SY":"SSN",1:"Unknown") - . S IBL=IBL+1 - . D SET^IBCNSP(IBL,OFFSET,"Subscriber Secondary ID: "_$P(G,U,PCE)) - . D SET^IBCNSP(IBL,52,"ID Qual: "_QUAL_" ("_QUAL1_")") - . Q - ; - ; patient=subscriber so skip over patient ID# display - I +$P(IBCDFND,U,16)=1 G ID1 - ; - S IBL=IBL+1 D SET^IBCNSP(IBL,2," ") ; blank line - S IBL=IBL+1 - D SET^IBCNSP(IBL,OFFSET," Patient Primary ID: "_$P(G,U,1)) - ; - F PCE=9,11,13 D ; patient secondary IDs - . I $P(G,U,PCE)="" Q ; no secondary ID# - . S QUAL=$P(G,U,PCE-1) ; internal qualifier code - . S QUAL1=$S(QUAL="23":"Client#",QUAL="IG":"Ins. Policy#",QUAL="SY":"SSN",1:"Unknown") - . S IBL=IBL+1 - . D SET^IBCNSP(IBL,OFFSET," Patient Secondary ID: "_$P(G,U,PCE)) - . D SET^IBCNSP(IBL,52,"ID Qual: "_QUAL_" ("_QUAL1_")") - . Q - ; -ID1 ; end of section - 2 blank lines - S IBL=IBL+1 D SET^IBCNSP(IBL,2," ") - S IBL=IBL+1 D SET^IBCNSP(IBL,2," ") -IDQ ; - Q - ; -RIDER ; -- Personal policy riders - N OFFSET,START,IBI,IBL,IBPR,IBPRD - S START=$O(^TMP("IBCNSVP",$J,""),-1)+1,OFFSET=2,IBL=0 - D SET^IBCNSP(START,OFFSET," Personal Riders ",IORVON,IORVOFF) - S IBI="" F S IBI=$O(^IBA(355.7,"APP",DFN,IBCDFN,IBI)) Q:'IBI S IBPR=$O(^(IBI,0)),IBPRD=+$G(^IBA(355.7,IBPR,0)),IBL=IBL+1 D - . D SET^IBCNSP(START+IBL,OFFSET," Rider #"_IBL_": "_$$EXPAND^IBTRE(355.7,.01,IBPRD)) - . Q - S IBL=IBL+1 D SET^IBCNSP(START+IBL,OFFSET," ") - S IBL=IBL+1 D SET^IBCNSP(START+IBL,OFFSET," ") - Q - ; -AI ; -- Add ins. verification entry - ; called from ai^ibcnsp1 - ; - ; -- see if current inpatient - D INP^VADPT I +VAIN(1) D - .S IBTRN=$O(^IBT(356,"AD",+VAIN(1),0)) - ; - S IBXIFN=$O(^IBE(356.11,"ACODE",85,0)) - ; - ; -- if not tracking id allow selecting - I '$G(IBTRN) D G:IBQUIT AIQ - .W !,"You can now enter a contact and relate it to a Claims Tracking Admission entry." - .S DIC("A")="Select RELATED ADMISSION DATE: " - .S DIC="^IBT(356,",DIC(0)="AEQ",D="ADFN"_DFN,DIC("S")="I $P(^(0),U,5)" - .D IX^DIC K DA,DR,DIC,DIE I $D(DUOUT)!($D(DTOUT)) S IBQUIT=1 Q - .I +Y>1 S IBTRN=+Y - ; - I '$G(IBTRN) W !!,"Warning: This contact is not associated with any care in Claims Tracking.",!,"You may only edit or view this contact using this action.",! - ; - ; -- select date - S IBOK=0,IBI=0 F S IBI=$O(^IBT(356.2,"D",DFN,IBI)) Q:'IBI I $P($G(^IBT(356.2,+IBI,0)),"^",4)=IBXIFN,$P($G(^(1)),"^",5)=IBCDFN S IBOK=1 - I IBOK D G:IBQUIT AIQ - .S DIC="^IBT(356.2,",DIC("A")="Select Contact Date: " - .S X="??",DIC(0)="EQ",DIC("S")="I $P($G(^(1)),U,5)=IBCDFN,$P(^(0),U,4)=IBXIFN" ;,DLAYGO=356.2 - .S D="ADFN"_DFN - .D IX^DIC K DIC,DR,DA,DIE,D I $D(DUOUT)!($D(DTOUT)) S IBQUIT=1 - ; - S DIC="^IBT(356.2,",DIC("A")="Select Contact Date: ",DIC("B")="TODAY" - S DIC("DR")=".02////"_$G(IBTRN)_";.04////"_IBXIFN_";.05////"_DFN_";.19////1;1.01///NOW;1.02////"_DUZ_";1.05////"_IBCDFN - S DIC(0)="AEQL",DIC("S")="I $P(^(0),U,5)=DFN,$P($G(^(1)),U,5)=IBCDFN,$P(^(0),U,4)=IBXIFN",DLAYGO=356.2 - D ^DIC K DIC - I $D(DTOUT)!($D(DUOUT))!(+Y<1) G AIQ - S IBTRC=+Y - I $G(IBTRC),$G(IBTRN),'$P(^IBT(356.2,+IBTRC,0),"^",2) S DA=IBTRC,DIE="^IBT(356.2,",DR=".02////"_$G(IBTRN) D ^DIE - ; - ; -- edit ins ver type - D EDIT^IBTRCD1("[IBT INS VERIFICATION]",1) -AIQ Q +IBCNSP01 ;ALB/AAS - INSURANCE MANAGEMENT - EXPANDED POLICY ; 05-MAR-1993 + ;;2.0;INTEGRATED BILLING;**43,52,85,251**;21-MAR-94 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; + ; +% D SUBSC,RIDER + Q + ; +SUBSC ; -- subscriber region + N OFFSET,START + S START=19,OFFSET=2 + D SET^IBCNSP(START,OFFSET," Subscriber Information ",IORVON,IORVOFF) + S Y=$P(IBCDFND,"^",6),C=$P(^DD(2.312,6,0),"^",2) D Y^DIQ + D SET^IBCNSP(START+1,OFFSET," Whose Insurance: "_Y) + D SET^IBCNSP(START+2,OFFSET," Subscriber Name: "_$P(IBCDFND,"^",17)) + S Y=$P(IBCDFND,"^",16),C=$P(^DD(2.312,16,0),"^",2) D Y^DIQ + D SET^IBCNSP(START+3,OFFSET," Relationship: "_Y) + D SET^IBCNSP(START+4,OFFSET,"Insurance Number: "_$P(IBCDFND,"^",2)) + S Y=$P(IBCDFND,"^",20),C=$P(^DD(2.312,.2,0),"^",2) D Y^DIQ + D SET^IBCNSP(START+5,OFFSET,"Coord. Benefits: "_Y) + D SET^IBCNSP(START+6,OFFSET,"Primary Provider: "_$P(IBCDFND4,"^",1)) + D SET^IBCNSP(START+7,OFFSET," Prim Prov Phone: "_$P(IBCDFND4,"^",2)) + Q + ; +VER ; -- Entered/Verfied Region + N OFFSET,START + S START=41+$G(IBLCNT),OFFSET=2 + I '$D(@VALMAR@(START-1)) D SET^IBCNSP(START-1,OFFSET," ") + D SET^IBCNSP(START,OFFSET," User Information ",IORVON,IORVOFF) + I IBCDFND1="" D SET^IBCNSP(START+1,OFFSET,"No User Information") G VERQ + D SET^IBCNSP(START+1,OFFSET," Entered By: "_$E($P($G(^VA(200,+$P(IBCDFND1,"^",2),0)),"^",1),1,20)) + D SET^IBCNSP(START+2,OFFSET," Entered On: "_$$DAT1^IBOUTL(+IBCDFND1)) + D SET^IBCNSP(START+3,OFFSET,"Last Verified By: "_$E($P($G(^VA(200,+$P(IBCDFND1,"^",4),0)),"^",1),1,20)) + D SET^IBCNSP(START+4,OFFSET,"Last Verified On: "_$$DAT1^IBOUTL(+$P(IBCDFND1,"^",3))) + D SET^IBCNSP(START+5,OFFSET," Last Updated By: "_$E($P($G(^VA(200,+$P(IBCDFND1,"^",6),0)),"^",1),1,20)) + D SET^IBCNSP(START+6,OFFSET," Last Updated On: "_$$DAT1^IBOUTL(+$P(IBCDFND1,"^",5))) +VERQ Q + ; +RIDER ; -- Personal policy riders + N OFFSET,START,IBI,IBL,IBPR,IBPRD + S START=53+$G(IBLCNT),OFFSET=2,IBL=0 + I '$D(@VALMAR@(START-1)) D SET^IBCNSP(START-1,OFFSET," ") + D SET^IBCNSP(START,OFFSET," Personal Riders ",IORVON,IORVOFF) + S IBI="" F S IBI=$O(^IBA(355.7,"APP",DFN,IBCDFN,IBI)) Q:'IBI S IBPR=$O(^(IBI,0)),IBPRD=+$G(^IBA(355.7,IBPR,0)),IBL=IBL+1 D + .D SET^IBCNSP(START+IBL,OFFSET," Rider #"_IBL_": "_$$EXPAND^IBTRE(355.7,.01,IBPRD)) + S IBLCNT=$G(IBLCNT)+IBL + Q + ; +AI ; -- Add ins. verification entry + ; called from ai^ibcnsp1 + ;N X,Y,I,J,DA,DR,DIC,DIE,DR,DD,DO,VA,VAIN,VAERR,IBQUIT,IBXIFN,IBTRN,DUOUT,IBX,IBQUIT,DTOUT + ;Q:'$G(DFN) + ;Q:'$G(IBCDFN) S IBQUIT=0 + ; + ; -- see if current inpatient + D INP^VADPT I +VAIN(1) D + .S IBTRN=$O(^IBT(356,"AD",+VAIN(1),0)) + ; + S IBXIFN=$O(^IBE(356.11,"ACODE",85,0)) + ; + ; -- if not tracking id allow selecting + I '$G(IBTRN) D G:IBQUIT AIQ + .W !,"You can now enter a contact and relate it to a Claims Tracking Admission entry." + .S DIC("A")="Select RELATED ADMISSION DATE: " + .S DIC="^IBT(356,",DIC(0)="AEQ",D="ADFN"_DFN,DIC("S")="I $P(^(0),U,5)" + .D IX^DIC K DA,DR,DIC,DIE I $D(DUOUT)!($D(DTOUT)) S IBQUIT=1 Q + .I +Y>1 S IBTRN=+Y + ; + I '$G(IBTRN) W !!,"Warning: This contact is not associated with any care in Claims Tracking.",!,"You may only edit or view this contact using this action.",! + ; + ; -- select date + S IBOK=0,IBI=0 F S IBI=$O(^IBT(356.2,"D",DFN,IBI)) Q:'IBI I $P($G(^IBT(356.2,+IBI,0)),"^",4)=IBXIFN,$P($G(^(1)),"^",5)=IBCDFN S IBOK=1 + I IBOK D G:IBQUIT AIQ + .S DIC="^IBT(356.2,",DIC("A")="Select Contact Date: " + .S X="??",DIC(0)="EQ",DIC("S")="I $P($G(^(1)),U,5)=IBCDFN,$P(^(0),U,4)=IBXIFN" ;,DLAYGO=356.2 + .S D="ADFN"_DFN + .D IX^DIC K DIC,DR,DA,DIE,D I $D(DUOUT)!($D(DTOUT)) S IBQUIT=1 + ; + S DIC="^IBT(356.2,",DIC("A")="Select Contact Date: ",DIC("B")="TODAY" + S DIC("DR")=".02////"_$G(IBTRN)_";.04////"_IBXIFN_";.05////"_DFN_";.19////1;1.01///NOW;1.02////"_DUZ_";1.05////"_IBCDFN + S DIC(0)="AEQL",DIC("S")="I $P(^(0),U,5)=DFN,$P($G(^(1)),U,5)=IBCDFN,$P(^(0),U,4)=IBXIFN",DLAYGO=356.2 + D ^DIC K DIC + I $D(DTOUT)!($D(DUOUT))!(+Y<1) G AIQ + S IBTRC=+Y + I $G(IBTRC),$G(IBTRN),'$P(^IBT(356.2,+IBTRC,0),"^",2) S DA=IBTRC,DIE="^IBT(356.2,",DR=".02////"_$G(IBTRN) D ^DIE + ; + ; -- edit ins ver type + D EDIT^IBTRCD1("[IBT INS VERIFICATION]",1) +AIQ Q diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP1.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP1.m index 14219233..21a99ca9 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP1.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP1.m @@ -1,243 +1,119 @@ -IBCNSP1 ;ALB/AAS - INSURANCE MANAGEMENT - policy actions ;22-OCT-92 - ;;2.0;INTEGRATED BILLING;**6,28,40,43,52,85,103,361,371,377**;21-MAR-94;Build 23 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ;;ICR#5002 for read of ^DIE input template data - ; -% G EN^IBCNSP - ; -EA ; -- Edit all - N IBCDFN,IBTRC,IBTRN - D FULL^VALM1 W !! - S IBCDFN=$P($G(IBPPOL),"^",4) I 'IBCDFN W !!,"Can't identify the policy!" G EAQ - S IBCNSEH=1 D PAT^IBCNSEH - ; - D BEFORE^IBCNSEVT - D PATPOL^IBCNSM32(IBCDFN) - D AFTER^IBCNSEVT,^IBCNSEVT - ; - ; -- edit policy data - D POL^IBCNSEH - D EDPOL^IBCNSM3(IBCDFN) - ; - W !! D AI - ; -EAQ D:$G(IBTRC) AIP^IBCNSP02(IBTRC) - D BLD^IBCNSP - S VALMBCK="R" - Q - ; -AB ; -- Annual Benefits - S X=+$P($G(IBPPOL),"^",4),IBCNS=+$G(^DPT(DFN,.312,X,0)),IBCPOL=+$P($G(^(0)),"^",18) - I 'IBCPOL W !!,"Can't identify the plan!" S VALMBCK="" G ABQ - D FULL^VALM1 W !! - D EN^VALM("IBCNS ANNUAL BENEFITS") - S VALMBCK="R" -ABQ Q - ; -BU ; -- Benefits Used - S IBCDFN=+$P($G(IBPPOL),"^",4),IBCNS=+$G(^DPT(DFN,.312,IBCDFN,0)),IBCPOL=+$P($G(^(0)),"^",18) - I 'IBCPOL W !!,"Can't identify the plan!" S VALMBCK="" G BUQ - D FULL^VALM1 W !! - D EN^VALM("IBCNS BENEFITS USED BY DATE") - S VALMBCK="R" -BUQ Q - ; -IT ; -- edit insurance type info from patient policy and plan edit - D FULL^VALM1 W !! - N IBCDFN - S IBCDFN=+$P($G(IBPPOL),"^",4),IBCPOL=+$P($G(^DPT(DFN,.312,IBCDFN,0)),"^",18) - I 'IBCPOL W !!,"Can't identify the plan!" S VALMBCK="" G ITQ - D ITEDIT(IBCPOL,IBCDFN) -ITQ S VALMBCK="R" Q - ; -IT1 ; -- edit insurance type info from patient policy - D ITEDIT(IBCPOL) - S VALMBCK="R" - Q - ; -ITEDIT(IBCPOL,IBCDFN) ;Edit insurance type info once you have plan (IBCPOL) - ; IBCDFN = the ifn of the policy multiple for pt in ^DPT, node .312 - ; only defined for editing via patient policy - G:'$G(IBCPOL) ITEDITQ - D SAVE^IBCNSP3(IBCPOL) - L +^IBA(355.3,+IBCPOL):5 I '$T D LOCKED^IBTRCD1 G ITEDITQ - I $G(IBCDFN) S IBCNSEH=+$G(^IBE(350.9,1,4)) D POL^IBCNSEH - I $P($G(^IBA(355.3,IBCPOL,0)),"^",11) W !?2,*7,"Please note that this plan is inactive!",! - S DA=IBCPOL,DIE="^IBA(355.3,",DR=".05;.12;.06;.07;.08" - D ^DIE K DIC,DIE,DA,DR - D COMP^IBCNSP3(IBCPOL) - I IBDIF D UPDATE^IBCNSP3(IBCPOL) D:$G(IBCDFN) UPDATPT^IBCNSP3(DFN,IBCDFN),BLD^IBCNSP D:'$G(IBCDFN) INIT^IBCNSC4 - L -^IBA(355.3,+IBCPOL) -ITEDITQ Q - ; -ED ; -- Edit effective dates - D FULL^VALM1 W !! - N IBDIF,DA,DR,DIE,DIC - D BEFORE^IBCNSEVT - D SAVEPT^IBCNSP3(DFN,IBCDFN) - L +^DPT(DFN,.312,+$P($G(IBPPOL),"^",4)):5 I '$T D LOCKED^IBTRCD1 G EDQ - D VARS^IBCNSP3 - S DR="8;3;1.09//;3.04" - D ^DIE K DIC,DIE,DA,DR - D COMPPT^IBCNSP3(DFN,IBCDFN) I IBDIF D UPDATPT^IBCNSP3(DFN,IBCDFN),UPDCLM(DFN,IBCDFN),AFTER^IBCNSEVT,^IBCNSEVT,BLD^IBCNSP - L -^DPT(DFN,.312,+$P($G(IBPPOL),"^",4)) -EDQ S VALMBCK="R" Q - ; -VC ; -- Verify Coverage - D FULL^VALM1 W !! - D VFY^IBCNSM2 - D BLD^IBCNSP - S VALMBCK="R" Q - ; -SU ; -- Subscriber Update - D FULL^VALM1 W !! - ;Patch 40 - N IBDIF,DA,DR,DIC,DIE,DGSENFLG - S DGSENFLG=1 - D SAVEPT^IBCNSP3(DFN,IBCDFN) - D VARS^IBCNSP3 - L +^DPT(DFN,.312,+$P($G(IBPPOL),"^",4)):5 I '$T D LOCKED^IBTRCD1 G SUQ - ; - D EDIT(DFN,IBCDFN) ; IB*371 - edit pat ins 2.312 subfile fields - ; - D COMPPT^IBCNSP3(DFN,IBCDFN) - I IBDIF D UPDATPT^IBCNSP3(DFN,IBCDFN),BLD^IBCNSP - L -^DPT(DFN,.312,+$P($G(IBPPOL),"^",4)) -SUQ S VALMBCK="R" Q - ; -IC ; -- Insurance Contact Information - D FULL^VALM1 W !! - N IBDIF,DA,DR,DIC,DIE,IBTRC,DIR,DUOUT,DTOUT,DIRUT,IBTRN - D AI - D:$G(IBTRC) AIP^IBCNSP02(IBTRC),BLD^IBCNSP - S VALMBCK="R" Q - Q -AI ; -- Add ins. verification entry - N X,Y,I,J,DA,DR,DIC,DIE,DR,DD,DO,VA,VAIN,VAERR,IBQUIT,IBXIFN,IBTRN,DUOUT,IBX,IBQUIT,DTOUT - Q:'$G(DFN) - Q:'$G(IBCDFN) S IBQUIT=0 - D AI^IBCNSP02 - Q - ; -PIDEF(IBREL,FLD,IBDFN,SPDEF) ; Function to return patient file defaults - ; Called from input template IBCN PATIENT INSURANCE - ; IBREL = value from 2.312,4.03 field (PT. RELATIONSHIP - HIPAA) - ; FLD = field# in file 2.312 - ; IBDFN = patient ien to file 2 - ; SPDEF = spouse default flag =1 if this field should be defaulted - ; when the spouse is the policy holder - ; - ; The purpose is to provide a default value for the field when the - ; patient and the ins. subscriber are the same. - ; - NEW VAL - S VAL="" - I +$G(IBREL)'=1,+$G(IBREL)'=18 G PIDEFX ; patient not the insured or spouse, get out - I +$G(IBREL)=1,'$G(SPDEF) G PIDEFX ; not a field for spouse default - I '$G(FLD) G PIDEFX ; no field# passed in - I '$G(IBDFN) G PIDEFX ; no patient passed in - ; - ; Build the patient demographics area - I '$D(^UTILITY("VADM",$J)) D - . N VAHOW,DFN,VADM - . S VAHOW=2,DFN=IBDFN D DEM^VADPT - . Q - ; - ; Build the patient address area - I '$D(^UTILITY("VAPA",$J)) D - . N VAHOW,DFN,VAPA - . S VAHOW=2,DFN=IBDFN,VAPA("P")="" D ADD^VADPT - . Q - ; - I FLD=17 S VAL=$P($G(^UTILITY("VADM",$J,1)),U,1) G PIDEFX ; Name - I FLD=3.01 S VAL=$$FMTE^XLFDT($P($G(^UTILITY("VADM",$J,3)),U,1),"5Z") G PIDEFX ; Date of Birth - I FLD=3.02 S VAL=$$EXTERNAL^DILFD(2,.325,,$P($G(^DPT(IBDFN,.32)),U,5)) G PIDEFX ; Branch - I FLD=3.05 S VAL=$P($G(^UTILITY("VADM",$J,2)),U,2) G PIDEFX ; SSN - I FLD=3.06 S VAL=$P($G(^UTILITY("VAPA",$J,1)),U,1) G PIDEFX ; Street Address 1 - I FLD=3.07 S VAL=$P($G(^UTILITY("VAPA",$J,2)),U,1) G PIDEFX ; Street Address 2 - I FLD=3.08 S VAL=$P($G(^UTILITY("VAPA",$J,4)),U,1) G PIDEFX ; City - I FLD=3.09 S VAL=$P($G(^UTILITY("VAPA",$J,5)),U,2) G PIDEFX ; State - I FLD=3.1 S VAL=$P($G(^UTILITY("VAPA",$J,11)),U,2) G PIDEFX ; Zipcode - I FLD=3.11 S VAL=$P($G(^UTILITY("VAPA",$J,8)),U,1) G PIDEFX ; Phone# - I FLD=3.12 S VAL=$P($G(^UTILITY("VADM",$J,5)),U,2) G PIDEFX ; Sex -PIDEFX ; - Q VAL - ; -ASK(QUES,DEFLT) ; Function to ask Yes/No Question - ; Returns 1 (yes), 0 (no, up-arrow, or timeout) - NEW X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT - S DIR(0)="Y",DIR("A")=$G(QUES) - S DIR("B")=$S($G(DEFLT):"Yes",1:"No") - W ! D ^DIR W:Y ! - I $D(DIRUT) S Y=0 -ASKX ; - Q Y - ; -EDIT(IBDFN,IBCDFN,IBQUIT) ; Main call to edit data in 2.312 pat ins subfile - ; IBDFN - patient DFN - ; IBCDFN - ien for patient insurance policy in subfile 2.312 - ; IBQUIT - Output variable. Pass by reference. Will be set to 1 if - ; the user entered an up-arrow, timed-out, or deleted the - ; 2.312 subfile entry by entering "@" at the .01 field - ; - NEW DA,DR,DIE,IBZ,IBY,X,Y,DTOUT - NEW IDS,SUB,PAT,PCE,SUB1,PAT1 - S DA(1)=+$G(IBDFN) ; patient IEN - S DA=+$G(IBCDFN) ; patient insurance IEN - I 'DA!'DA(1) G EDITX - S DIE="^DPT("_IBDFN_",.312," - ; - ; Find the input template IEN for the [IBCN PATIENT INSURANCE] template - S IBY=+$$FIND1^DIC(.402,,"X","IBCN PATIENT INSURANCE") - I 'IBY G EDITX - ; - ; Build the DR array/string - ICR# 5002 - M DR(1)=^DIE(IBY,"DR",2) - S DR=$G(DR(1,2.312)) - I DR="" G EDITX - ; - S $P(^DIE(IBY,0),U,7)=DT ; see TEM+2^DIE ICR# 5002 - ; - D ^DIE ; edit subfile data - ; - ; If the user entered an up-arrow, or timed-out, or deleted the entry, - ; then set the output variable IBQUIT - I $D(Y)!$D(DTOUT)!'$D(DA) S IBQUIT=1 - ; - F IBZ="VADM","VAPA" K ^UTILITY(IBZ,$J) ; cleanup scratch global - ; - D UPDCLM(IBDFN,IBCDFN) ; update editable claims - ; - ; Cleanup any problems in the secondary ID area - S IDS=$G(^DPT(IBDFN,.312,IBCDFN,5)) ; whole 5 node - S (SUB,PAT)="" - F PCE=3:1:8 S $P(SUB,U,PCE)=$P(IDS,U,PCE-1) ; subscriber sec ID/qual - F PCE=3:1:8 S $P(PAT,U,PCE)=$P(IDS,U,PCE+5) ; patient sec ID/qual - ; SUB and PAT are 8-piece strings with pieces 1 and 2 being nil - S SUB1=$$SCRUB^IBCEF21(SUB) ; scrub 8-piece string - S PAT1=$$SCRUB^IBCEF21(PAT) ; scrub 8-piece string - I SUB'=SUB1 S $P(^DPT(IBDFN,.312,IBCDFN,5),U,2,7)=$P(SUB1,U,3,8) - I PAT'=PAT1 S $P(^DPT(IBDFN,.312,IBCDFN,5),U,8,13)=$P(PAT1,U,3,8) - ; -EDITX ; - Q - ; -UPDCLM(IBDFN,IBCDFN) ; Update the Insurance nodes of claims that are still editable - NEW IBIFN - S IBIFN=0 F S IBIFN=$O(^DGCR(399,"C",IBDFN,IBIFN)) Q:'IBIFN D UPDCLM^IBCNSP2(IBIFN,IBDFN,IBCDFN) - ; -UPDCLMX ; - Q - ; -PRELCNV(CODE,FLG) ; conversion between X12, NCPDP and VistA pt. relationship codes - ; CODE - code for pt. relationship to convert - ; FLG - 0 for X12 -> VistA conversion, 1 for VistA -> X12 conversion, 2 - for VistA -> NCPDP conversion - ; returns converted code for pt. relationship, or null if no match found - N I,RES,VSTR,X12STR - S VSTR="01^02^03^08^11^15^32^33^34^35^36" - S X12STR="18^01^19^20^39^41^32^33^29^53^G8" - S RES="" - I FLG=0 F I=1:1:11 S:$P(X12STR,U,I)=CODE RES=$P(VSTR,U,I) Q:RES'="" - I FLG=1 F I=1:1:11 S:$P(VSTR,U,I)=CODE RES=$P(X12STR,U,I) Q:RES'="" - I FLG=2,+CODE>0 S RES=$S(+CODE>3:"04",1:CODE) - Q RES +IBCNSP1 ;ALB/AAS - INSURANCE MANAGEMENT - policy actions ; 22-OCT-92 + ;;2.0;INTEGRATED BILLING;**6,28,40,43,52,85,103,361**;21-MAR-94;Build 9 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; +% G EN^IBCNSP + ; +EA ; -- Edit all + N IBCDFN,IBTRC,IBTRN + D FULL^VALM1 W !! + S IBCDFN=$P($G(IBPPOL),"^",4) I 'IBCDFN W !!,"Can't identify the policy!" G EAQ + S IBCNSEH=1 D PAT^IBCNSEH + ; + D BEFORE^IBCNSEVT + D PATPOL^IBCNSM32(IBCDFN) + D AFTER^IBCNSEVT,^IBCNSEVT + ; + ; -- edit policy data + D POL^IBCNSEH + D EDPOL^IBCNSM3(IBCDFN) + ; + W !! D AI + ; +EAQ D:$G(IBTRC) AIP^IBCNSP02(IBTRC) + D BLD^IBCNSP + S VALMBCK="R" + Q + ; +AB ; -- Annual Benefits + S X=+$P($G(IBPPOL),"^",4),IBCNS=+$G(^DPT(DFN,.312,X,0)),IBCPOL=+$P($G(^(0)),"^",18) + I 'IBCPOL W !!,"Can't identify the plan!" S VALMBCK="" G ABQ + D FULL^VALM1 W !! + D EN^VALM("IBCNS ANNUAL BENEFITS") + S VALMBCK="R" +ABQ Q + ; +BU ; -- Benefits Used + S IBCDFN=+$P($G(IBPPOL),"^",4),IBCNS=+$G(^DPT(DFN,.312,IBCDFN,0)),IBCPOL=+$P($G(^(0)),"^",18) + I 'IBCPOL W !!,"Can't identify the plan!" S VALMBCK="" G BUQ + D FULL^VALM1 W !! + D EN^VALM("IBCNS BENEFITS USED BY DATE") + S VALMBCK="R" +BUQ Q + ; +IT ; -- edit insurance type info from patient policy and plan edit + D FULL^VALM1 W !! + N IBCDFN + S IBCDFN=+$P($G(IBPPOL),"^",4),IBCPOL=+$P($G(^DPT(DFN,.312,IBCDFN,0)),"^",18) + I 'IBCPOL W !!,"Can't identify the plan!" S VALMBCK="" G ITQ + D ITEDIT(IBCPOL,IBCDFN) +ITQ S VALMBCK="R" Q + ; +IT1 ; -- edit insurance type info from patient policy + D ITEDIT(IBCPOL) + S VALMBCK="R" + Q + ; +ITEDIT(IBCPOL,IBCDFN) ;Edit insurance type info once you have plan (IBCPOL) + ; IBCDFN = the ifn of the policy multiple for pt in ^DPT, node .312 + ; only defined for editing via patient policy + G:'$G(IBCPOL) ITEDITQ + D SAVE^IBCNSP3(IBCPOL) + L +^IBA(355.3,+IBCPOL):5 I '$T D LOCKED^IBTRCD1 G ITEDITQ + I $G(IBCDFN) S IBCNSEH=+$G(^IBE(350.9,1,4)) D POL^IBCNSEH + I $P($G(^IBA(355.3,IBCPOL,0)),"^",11) W !?2,*7,"Please note that this plan is inactive!",! + S DA=IBCPOL,DIE="^IBA(355.3,",DR=".05;.12;.06;.07;.08" + D ^DIE K DIC,DIE,DA,DR + D COMP^IBCNSP3(IBCPOL) + I IBDIF D UPDATE^IBCNSP3(IBCPOL) D:$G(IBCDFN) UPDATPT^IBCNSP3(DFN,IBCDFN),BLD^IBCNSP D:'$G(IBCDFN) INIT^IBCNSC4 + L -^IBA(355.3,+IBCPOL) +ITEDITQ Q + ; +ED ; -- Edit effective dates + D FULL^VALM1 W !! + N IBDIF,DA,DR,DIE,DIC + D BEFORE^IBCNSEVT + D SAVEPT^IBCNSP3(DFN,IBCDFN) + L +^DPT(DFN,.312,+$P($G(IBPPOL),"^",4)):5 I '$T D LOCKED^IBTRCD1 G EDQ + D VARS^IBCNSP3 + S DR="8;3;1.09//;3.04" + D ^DIE K DIC,DIE,DA,DR + D COMPPT^IBCNSP3(DFN,IBCDFN) I IBDIF D UPDATPT^IBCNSP3(DFN,IBCDFN),AFTER^IBCNSEVT,^IBCNSEVT,BLD^IBCNSP + L -^DPT(DFN,.312,+$P($G(IBPPOL),"^",4)) +EDQ S VALMBCK="R" Q + ; +VC ; -- Verify Coverage + D FULL^VALM1 W !! + D VFY^IBCNSM2 + D BLD^IBCNSP + S VALMBCK="R" Q + ; +SU ; -- Subscriber Update + D FULL^VALM1 W !! + ;Patch 40 + N IBDIF,DA,DR,DIC,DIE,DGSENFLG + S DGSENFLG=1 + D SAVEPT^IBCNSP3(DFN,IBCDFN) + D VARS^IBCNSP3 + L +^DPT(DFN,.312,+$P($G(IBPPOL),"^",4)):5 I '$T D LOCKED^IBTRCD1 G SUQ + S DR="6;S IBAD=X;K X I '$$VET^IBCNSU1() S Y=""@10"";17///^S X=$P(^DPT(DFN,0),U);16///^S X=""01""" + S DR=DR_";S Y=""@20"";@10;17;16//^S X=$S(IBAD=""s"":""02"",1:"""");@20;1;.2;4.01;4.02;3.01;3.12;3.02;3.03;3.05:3.11" + D ^DIE K DIC,DIE,DA,DR + D COMPPT^IBCNSP3(DFN,IBCDFN) + I IBDIF D UPDATPT^IBCNSP3(DFN,IBCDFN),BLD^IBCNSP + L -^DPT(DFN,.312,+$P($G(IBPPOL),"^",4)) +SUQ S VALMBCK="R" Q + ; +IC ; -- Insurance Contact Information + D FULL^VALM1 W !! + N IBDIF,DA,DR,DIC,DIE,IBTRC,DIR,DUOUT,DTOUT,DIRUT,IBTRN + D AI + D:$G(IBTRC) AIP^IBCNSP02(IBTRC),BLD^IBCNSP + S VALMBCK="R" Q + Q +AI ; -- Add ins. verification entry + N X,Y,I,J,DA,DR,DIC,DIE,DR,DD,DO,VA,VAIN,VAERR,IBQUIT,IBXIFN,IBTRN,DUOUT,IBX,IBQUIT,DTOUT + Q:'$G(DFN) + Q:'$G(IBCDFN) S IBQUIT=0 + D AI^IBCNSP02 + Q diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP2.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP2.m index 058973da..3734c35d 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP2.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP2.m @@ -1,127 +1,120 @@ -IBCNSP2 ;ALB/AAS - PATIENT INSURANCE INTERFACE FOR REGISTRATION ;21-JUNE-93 - ;;2.0;INTEGRATED BILLING;**6,28,75,82,155,371**;21-MAR-94;Build 57 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -% ; -REG ; --Edit Patient insurance from registration, fee and mccr, allow new entries - ; only edit policy if new policy - ; call event driver if adding a new policy - ; - ; -- Input DFN = patient - ; - I $G(DGPRFLG) D PREG^IBCNBME(DFN) Q - D REG^IBCNBME(DFN) - Q - ; - N DIC,DIE,DE,DQ,DIR,DA,DR,DIC,DIV,X,Y,I,J,L,D,DIH,DIY,IBSEL,IBDD,IBD,IBNEW,IBNEWP,IBDT,IBQUIT,IBCNS,IBCDFN,IBCNSEH,IBCNP,IBCPOL,IBOK,VALMQUIT,IBCNT,IBEVT1,IBEVTA,VAERR,IBCOVP - S IBCNP=1 - I '$D(DFN) D G:$D(VALMQUIT) REGQ - .S DIC="^DPT(",DIC(0)="AEQMN" D ^DIC - .S DFN=+Y - I $G(DFN)<1 S IBQUIT=1,VALMQUIT="" G REGQ - ; - I '$$ASKCOVD(DFN,.IBCOV,.IBCOVP) S IBQUIT=1 G REGQ - ; -R1 S (IBNEW,IBNEWP,IBQUIT)=0 - S DIC="^DPT("_DFN_",.312,",DIC(0)="AEQLM",DIC("A")="Select INSURANCE COMPANY: " - S DIC("W")="N IBD S IBD=$G(^DPT(DFN,.312,+Y,0)) W "" Group: ""_$$GRP^IBCNS($P(IBD,U,18))_"" Whose: ""_$$EXPAND^IBTRE(2.312,6,$P(IBD,U,6))" - I IBCNP=1 S X=$P($G(^DIC(36,+$G(^DPT(DFN,.312,+$P($G(^DPT(DFN,.312,0)),"^",3),0)),0)),"^") I X'="" S DIC("B")=X - S DA(1)=DFN - I $G(^DPT(DFN,.312,0))="" S ^DPT(DFN,.312,0)="^2.312PAI^^" - D ^DIC K DIC I +Y<1 S IBQUIT=1,VALMQUIT="" G REGQ - S IBCDFN=+Y,IBCNS=$P(Y,"^",2) - I $P(Y,"^",3) S IBNEW=1 I $$DUPCO^IBCNSOK1(DFN,IBCNS,IBCDFN,1) - D BEFORE^IBCNSEVT - S IBCNSEH=$P($G(^IBE(350.9,1,4)),"^",1) - S IBCNP=IBCNP+1 - I 'IBNEW,$P($G(^DPT(DFN,.312,+IBCDFN,0)),"^",18)="" D G REGQ - .I '$P($G(^IBE(350.9,1,3)),"^",18) W !,"Insurance conversion not complete, NO EDITING ALLOWED",!! S IBQUIT=1 H 3 Q - .I $P($G(^IBE(350.9,1,3)),"^",18) W !,"INVALID ENTRY, DELETE AND RE-ENTER, NO EDITING ALLOWED",!! S IBQUIT=1 H 3 Q - ; - I $G(IBFEE),'$G(IBNEW) G REGQ ; fee users can add but not edit existing info - I $G(IBNEW) D G:$G(IBQUIT) REGQ - .D SEL^IBCNSEH - .S IBCPOL=$$LK^IBCNSM31(IBCNS) - .I IBCPOL<1 D NEW^IBCNSJ3(IBCNS,.IBCPOL) S:IBCPOL<1 IBQUIT=1 Q:IBQUIT S IBNEWP=1 - .; dgprflg is a 1 if called from pre-registration, set default 4 - .; for pre-reg, otherwise set the default to 1 for interview - .S DR=".18////"_IBCPOL_";1.09////"_$S($G(DGPRFLG):4,1:1)_";1.05///NOW;1.06////"_DUZ - .S DA=IBCDFN,DA(1)=DFN,DIE="^DPT("_DFN_",.312," D ^DIE - .K DIE,DA,DR,DIC - ; - ; -- edit patient ins. data - S IBREG=1 G:$G(IBQUIT) REGQ - D PAT^IBCNSEH,PATPOL^IBCNSM32(IBCDFN),UPDCLM(+$G(IBIFN),DFN,IBCDFN) - ; - ; -- edit policy specific data if new or have key - I $G(IBNEWP)!($D(^XUSEC("IB INSURANCE SUPERVISOR",DUZ))) D:'$G(IBQUIT) POL^IBCNSEH,EDPOL^IBCNSM3(IBCDFN) - K IBREG S IBQUIT=0 - ; -REGQ ; -- exit logic and checks - ; -- if no policy pointer delete - I $G(IBNEW),$G(IBCDFN),$P($G(^DPT(DFN,.312,+IBCDFN,0)),"^",18)="" D - .D DP1^IBCNSM1 W !," GROUP INSURANCE PLAN REQUIRED BUT NOT ENTERED" K IBNEW - ; - ; -- call event driver - I $G(IBCDFN),$P($G(^DPT(DFN,.312,+$G(IBCDFN),0)),"^",18) D - .K IBNEW - .D AFTER^IBCNSEVT,^IBCNSEVT - ; - K IBCNS,IBCDFN,IBNEW,IBNEWP - I '$G(IBQUIT) W ! G R1 - D COVERED^IBCNSM31(DFN,$G(IBCOVP)) - K IBQUIT - Q - ; -FEE ; -- fee entry point to add patient insurance. - D FEE^IBCNBME(DFN) - Q - ; -MCCR ; -- called from screen 3 of the edit bill option in mccr - N DLAYGO,DIC,DIE,DE,DQ,DIR,DA,DR,DIC,DIV,X,Y,I,J,L,D,DIH,DIY,IBSEL,IBDD,IBD,IBNEW,IBNEWP,IBDT,IBQUIT,IBCNS,IBCDFN,IBCNSEH,IBCNP,IBCPOL,IBOK,VALMQUIT,IBMCR - ; - S IBCNP=1,IBMCR=$$WNRBILL^IBEFUNC(IBIFN) - S DIE="^DGCR(399,",DA=IBIFN,DR="[IB SCREEN3]" D ^DIE K DIC,DIE,DA,DR - ; - I $G(IBADI)=1 D R1 S IBCNRTN=1 K IBADI G MCCR - I 'IBMCR,$$WNRBILL^IBEFUNC(IBIFN) S DGRVRCAL=1 - K IBCNRTN - Q - ; -UPDCLM(IBIFN,DFN,IBCDFN) ; Update the claim's insurance nodes when edits are made - ; to the patient insurance file. - ; This procedure is called when a claim is being edited from IB billing - ; screen#3 and also when the patient insurance is being edited directly. - ; - I '$G(IBIFN)!'$G(DFN)!'$G(IBCDFN) Q ; missing something - I $P($G(^DGCR(399,IBIFN,0)),U,2)'=DFN Q ; mismatch of claim and DFN - I $P($G(^DGCR(399,IBIFN,0)),U,13)'=1 Q ; claim not editable - I '$D(^DPT(DFN,.312,IBCDFN,0)) Q ; missing pat ins data - NEW X,Z,NODE - S X=IBCDFN - F Z=1:1:3 I $P($G(^DGCR(399,IBIFN,"M")),U,11+Z)=IBCDFN D Q - . S NODE="I"_Z - . D IX^IBCNS2(IBIFN,NODE) - . Q - Q - ; -DISP ; -- Display Patient insurance policy information for registrations - Q:'$D(DFN) - D DISP^IBCNS -DISPQ Q - ; -ASKCOVD(DFN,IBCOV,IBCOVP) ; ask user if patient covered by insurance (2,.3192), returns true if answered yes - ; - N IBX,IBINSD,DIC,DIE,DA,DR,X,Y,DTOUT - ; - S IBCOV=$P($G(^DPT(DFN,.31)),"^",11),IBINSD=$$INSURED^IBCNS1(DFN),IBX=1 W ! - ; - ; -- if covered by ins but none currently active so indicate - I IBCOV="Y",'IBINSD W !!,"Covered By Health Insurance indicates 'YES' but none currently Active.",!,"Please Review!",!! - ; - ; -- ask if covered by insurance - S DIE="^DPT(",DR=".3192",DA=DFN D ^DIE K DIC,DIE,DA,DR I $D(Y)!($D(DTOUT)) S IBX=0 - ; - S IBCOVP=$P($G(^DPT(DFN,.31)),"^",11) I +IBX,IBCOVP'="Y",'IBINSD S IBX=0 - ; - Q IBX +IBCNSP2 ;ALB/AAS - PATIENT INSURANCE INTERFACE FOR REGISTRATION ;21-JUNE-93 + ;;2.0;INTEGRATED BILLING;**6,28,75,82,155**;21-MAR-94 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; +% ; +REG ; --Edit Patient insurance from registration, fee and mccr, allow new entries + ; only edit policy if new policy + ; call event driver if adding a new policy + ; + ; -- Input DFN = patient + ; + I $G(DGPRFLG) D PREG^IBCNBME(DFN) Q + D REG^IBCNBME(DFN) + Q + ; + N DIC,DIE,DE,DQ,DIR,DA,DR,DIC,DIV,X,Y,I,J,L,D,DIH,DIY,IBSEL,IBDD,IBD,IBNEW,IBNEWP,IBDT,IBQUIT,IBCNS,IBCDFN,IBCNSEH,IBCNP,IBCPOL,IBOK,VALMQUIT,IBCNT,IBEVT1,IBEVTA,VAERR,IBCOVP + S IBCNP=1 + I '$D(DFN) D G:$D(VALMQUIT) REGQ + .S DIC="^DPT(",DIC(0)="AEQMN" D ^DIC + .S DFN=+Y + I $G(DFN)<1 S IBQUIT=1,VALMQUIT="" G REGQ + ; + I '$$ASKCOVD(DFN,.IBCOV,.IBCOVP) S IBQUIT=1 G REGQ + ; -- of covered by ins but none currently active so indicate + ;S IBCOV=$P($G(^DPT(DFN,.31)),"^",11) + ;I IBCOV="Y",'$$INSURED^IBCNS1(DFN) W !!,"Covered By Health Insurance indicates 'YES' but none currently Active.",!,"Please Review!",!! + ; + ;; -- ask if covered by insuracnce + ;S DIE="^DPT(",DR=".3192",DA=DFN D ^DIE K DIC,DIE,DA,DR + ;S IBCOVP=$P($G(^DPT(DFN,.31)),"^",11) + ;I $D(Y)!($D(DTOUT)) S IBQUIT=1 G REGQ + ;I $P($G(^DPT(DFN,.31)),"^",11)'="Y",'$$INSURED^IBCNS1(DFN) S IBQUIT=1 G REGQ + ; +R1 S (IBNEW,IBNEWP,IBQUIT)=0 + S DIC="^DPT("_DFN_",.312,",DIC(0)="AEQLM",DIC("A")="Select INSURANCE COMPANY: " + S DIC("W")="N IBD S IBD=$G(^DPT(DFN,.312,+Y,0)) W "" Group: ""_$$GRP^IBCNS($P(IBD,U,18))_"" Whose: ""_$$EXPAND^IBTRE(2.312,6,$P(IBD,U,6))" + I IBCNP=1 S X=$P($G(^DIC(36,+$G(^DPT(DFN,.312,+$P($G(^DPT(DFN,.312,0)),"^",3),0)),0)),"^") I X'="" S DIC("B")=X + S DA(1)=DFN + I $G(^DPT(DFN,.312,0))="" S ^DPT(DFN,.312,0)="^2.312PAI^^" + D ^DIC K DIC I +Y<1 S IBQUIT=1,VALMQUIT="" G REGQ + S IBCDFN=+Y,IBCNS=$P(Y,"^",2) + I $P(Y,"^",3) S IBNEW=1 I $$DUPCO^IBCNSOK1(DFN,IBCNS,IBCDFN,1) + D BEFORE^IBCNSEVT + S IBCNSEH=$P($G(^IBE(350.9,1,4)),"^",1) + S IBCNP=IBCNP+1 + I 'IBNEW,$P($G(^DPT(DFN,.312,+IBCDFN,0)),"^",18)="" D G REGQ + .I '$P($G(^IBE(350.9,1,3)),"^",18) W !,"Insurance conversion not complete, NO EDITING ALLOWED",!! S IBQUIT=1 H 3 Q + .I $P($G(^IBE(350.9,1,3)),"^",18) W !,"INVALID ENTRY, DELETE AND RE-ENTER, NO EDITING ALLOWED",!! S IBQUIT=1 H 3 Q + ; + I $G(IBFEE),'$G(IBNEW) G REGQ ; fee users can add but not edit existing info + I $G(IBNEW) D G:$G(IBQUIT) REGQ + .D SEL^IBCNSEH + .S IBCPOL=$$LK^IBCNSM31(IBCNS) + .I IBCPOL<1 D NEW^IBCNSJ3(IBCNS,.IBCPOL) S:IBCPOL<1 IBQUIT=1 Q:IBQUIT S IBNEWP=1 + .; dgprflg is a 1 if called from pre-registration, set default 4 + .; for pre-reg, otherwise set the default to 1 for interview + .S DR=".18////"_IBCPOL_";1.09////"_$S($G(DGPRFLG):4,1:1)_";1.05///NOW;1.06////"_DUZ + .S DA=IBCDFN,DA(1)=DFN,DIE="^DPT("_DFN_",.312," D ^DIE + .K DIE,DA,DR,DIC + ; + ; -- edit patient ins. data + S IBREG=1 G:$G(IBQUIT) REGQ + D PAT^IBCNSEH,PATPOL^IBCNSM32(IBCDFN) + ; + ; -- edit policy specific data if new or have key + I $G(IBNEWP)!($D(^XUSEC("IB INSURANCE SUPERVISOR",DUZ))) D:'$G(IBQUIT) POL^IBCNSEH,EDPOL^IBCNSM3(IBCDFN) + K IBREG S IBQUIT=0 + ; +REGQ ; -- exit logic and checks + ; -- if no policy pointer delete + I $G(IBNEW),$G(IBCDFN),$P($G(^DPT(DFN,.312,+IBCDFN,0)),"^",18)="" D + .D DP1^IBCNSM1 W !," GROUP INSURANCE PLAN REQUIRED BUT NOT ENTERED" K IBNEW + ; + ; -- call event driver + I $G(IBCDFN),$P($G(^DPT(DFN,.312,+$G(IBCDFN),0)),"^",18) D + .K IBNEW + .D AFTER^IBCNSEVT,^IBCNSEVT + ; + K IBCNS,IBCDFN,IBNEW,IBNEWP + I '$G(IBQUIT) W ! G R1 + D COVERED^IBCNSM31(DFN,$G(IBCOVP)) + K IBQUIT + Q + ; +FEE ; -- fee entry point to add patient insurance. + ;N IBFEE S IBFEE=1 D REG + D FEE^IBCNBME(DFN) + Q + ; +MCCR ; -- called from screen 3 of the edit bill option in mccr + N DLAYGO,DIC,DIE,DE,DQ,DIR,DA,DR,DIC,DIV,X,Y,I,J,L,D,DIH,DIY,IBSEL,IBDD,IBD,IBNEW,IBNEWP,IBDT,IBQUIT,IBCNS,IBCDFN,IBCNSEH,IBCNP,IBCPOL,IBOK,VALMQUIT,IBMCR + ; + S IBCNP=1,IBMCR=$$WNRBILL^IBEFUNC(IBIFN) + S DIE="^DGCR(399,",DA=IBIFN,DR="[IB SCREEN3]" D ^DIE K DIC,DIE,DA,DR + ; + I $G(IBADI)=1 D R1 S IBCNRTN=1 K IBADI G MCCR + I 'IBMCR,$$WNRBILL^IBEFUNC(IBIFN) S DGRVRCAL=1 + K IBCNRTN + Q + ; +DISP ; -- Display Patient insurance policy information for registrations + Q:'$D(DFN) + D DISP^IBCNS +DISPQ Q + ; +ASKCOVD(DFN,IBCOV,IBCOVP) ; ask user if patient covered by insurance (2,.3192), returns true if answered yes + ; + N IBX,IBINSD,DIC,DIE,DA,DR,X,Y,DTOUT + ; + S IBCOV=$P($G(^DPT(DFN,.31)),"^",11),IBINSD=$$INSURED^IBCNS1(DFN),IBX=1 W ! + ; + ; -- if covered by ins but none currently active so indicate + I IBCOV="Y",'IBINSD W !!,"Covered By Health Insurance indicates 'YES' but none currently Active.",!,"Please Review!",!! + ; + ; -- ask if covered by insurance + S DIE="^DPT(",DR=".3192",DA=DFN D ^DIE K DIC,DIE,DA,DR I $D(Y)!($D(DTOUT)) S IBX=0 + ; + S IBCOVP=$P($G(^DPT(DFN,.31)),"^",11) I +IBX,IBCOVP'="Y",'IBINSD S IBX=0 + ; + Q IBX diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP3.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP3.m index 1ea8f266..e530482e 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP3.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP3.m @@ -1,165 +1,163 @@ -IBCNSP3 ;ALB/AAS - INSURANCE MANAGEMENT EDIT ;06-JUL-93 - ;;2.0;INTEGRATED BILLING;**28,52,85,251,371**;21-MAR-94;Build 57 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -% G ^IBCNSM4 - ; -SAVEPT(DFN,DA) ; -- Save the global before editing - K ^TMP($J,"IBCNSPT") - S ^TMP($J,"IBCNSPT",2.312,DFN,+DA,0)=$G(^DPT(DFN,.312,+DA,0)) - S ^TMP($J,"IBCNSPT",2.312,DFN,+DA,1)=$G(^DPT(DFN,.312,+DA,1)) - S ^TMP($J,"IBCNSPT",2.312,DFN,+DA,2)=$G(^DPT(DFN,.312,+DA,2)) - S ^TMP($J,"IBCNSPT",2.312,DFN,+DA,3)=$G(^DPT(DFN,.312,+DA,3)) - S ^TMP($J,"IBCNSPT",2.312,DFN,+DA,4)=$G(^DPT(DFN,.312,+DA,4)) - S ^TMP($J,"IBCNSPT",2.312,DFN,+DA,5)=$G(^DPT(DFN,.312,+DA,5)) - Q - ; -COMPPT(DFN,DA) ; -- Compare before editing with globals - S IBDIF=0 - I $G(^DPT(DFN,.312,+DA,0))'=$G(^TMP($J,"IBCNSPT",2.312,DFN,+DA,0)) S IBDIF=1 G COMPPTQ - I $G(^DPT(DFN,.312,+DA,1))'=$G(^TMP($J,"IBCNSPT",2.312,DFN,+DA,1)) S IBDIF=1 G COMPPTQ - I $G(^DPT(DFN,.312,+DA,2))'=$G(^TMP($J,"IBCNSPT",2.312,DFN,+DA,2)) S IBDIF=1 G COMPPTQ - I $G(^DPT(DFN,.312,+DA,3))'=$G(^TMP($J,"IBCNSPT",2.312,DFN,+DA,3)) S IBDIF=1 G COMPPTQ - I $G(^DPT(DFN,.312,+DA,4))'=$G(^TMP($J,"IBCNSPT",2.312,DFN,+DA,4)) S IBDIF=1 G COMPPTQ - I $G(^DPT(DFN,.312,+DA,5))'=$G(^TMP($J,"IBCNSPT",2.312,DFN,+DA,5)) S IBDIF=1 G COMPPTQ - ; -COMPPTQ I IBDIF D:'$D(IBCOVP) COVERED^IBCNSM31(DFN,$P($G(^DPT(DFN,.31)),"^",11)) - Q - ; -UPDATPT(DFN,DA) ; -- enter date and user if editing has taken place - N DR,DIE,DIC - S DIE="^DPT("_DFN_",.312,",DA(1)=DFN - S DR="1.05///NOW;1.06////"_DUZ - D ^DIE - Q - ; -EM ; -- Employer for claims update - D FULL^VALM1 W !! - N IBDIF,DA,DR,DIC,DIE - D SAVEPT(DFN,IBCDFN) - D VARS - L +^DPT(DFN,.312,+$P($G(IBPPOL),"^",4)):5 I '$T D LOCKED^IBTRCD1 G EMQ - ; - ;S DR="2.01;S:'$P($G(^DPT(DFN,.312,+$G(DA),2)),U) Y=""@999"";W !!,""*** If ROI applies, make sure current consent is signed! ***"",!;2.015;2.02;2.03;2.04;2.05;2.06;2.07;2.08;2.09;@999" - ; - S DR="2.1" D ^DIE K DIE,DR - ; - I +$P($G(^DPT(DFN,.312,+$G(DA),2)),U,10),$P($G(^DPT(DFN,.312,+$G(DA),2)),U,9)="" D EMPSET(DFN,$G(DA)) ; curr emp - ; - I +$P($G(^DPT(DFN,.312,+$G(DA),2)),U,10) D VARS S DR="2.015;2.11;2.12;2.01;W:+X !!,""*** If ROI applies, make sure current consent is signed! ***"",!!;2.02;2.03;2.04;2.05;2.06;2.07;2.08;@999" D ^DIE K DIE,DR - ; - ;I '$P($G(^DPT(DFN,.312,+$G(DA),2)),U) D VARS S DR="2.015///@;2.02///@;2.03///@;2.04///@;2.05///@;2.06///@;2.07///@;2.08///@" D ^DIE - ; - I '$P($G(^DPT(DFN,.312,+$G(DA),2)),U,10) D VARS S DR="2.01///@;2.015///@;2.02///@;2.03///@;2.04///@;2.05///@;2.06///@;2.07///@;2.08///@;2.11///@;2.12///@" D ^DIE - ; - D COMPPT(DFN,IBCDFN) - I IBDIF D UPDATPT(DFN,IBCDFN),BLD^IBCNSP - L -^DPT(DFN,.312,+$P($G(IBPPOL),"^",4)) -EMQ S VALMBCK="R" Q - ; -AC ; -- Add Comment - D FULL^VALM1 W !! - N IBDIF,DA,DR,DIE,DIC,X,Y - D SAVEPT(DFN,IBCDFN) - W !!,"You may now enter a brief comment about this patient's policy" - D VARS - L +^DPT(DFN,.312,+$P($G(IBPPOL),"^",4)):5 I '$T D LOCKED^IBTRCD1 G ACQ - S DR="1.08" D ^DIE - D COMPPT(DFN,IBCDFN) I IBDIF D UPDATPT(DFN,IBCDFN) - L -^DPT(DFN,.312,+$P($G(IBPPOL),"^",4)) - W !!,"You may now enter comments about this Group Plan that pertains to all Patients" - L +^IBA(355.3,+IBCPOL):5 I '$T D LOCKED^IBTRCD1 G ACQ - S DIE="^IBA(355.3,",DA=IBCPOL,DR="11" D ^DIE - D BLD^IBCNSP - L -^IBA(355.3,+IBCPOL) -ACQ S VALMBCK="R" Q - ; -BLS(X,Y) ; -- blank a section of lines - N I - F I=X:1:Y D BLANK^IBCNSP(.I) - Q - ; -VARS ; -- set vars for call to die for .312 node - S DA(1)=DFN,DA=$P(IBPPOL,"^",4) - S DIE="^DPT("_DA(1)_",.312," - Q - ; -SAVE(IBCPOL) ; -- Save the global before editing - K ^TMP($J,"IBCNSP") - S ^TMP($J,"IBCNSP",355.3,+IBCPOL,0)=$G(^IBA(355.3,+IBCPOL,0)) - S ^TMP($J,"IBCNSP",355.3,+IBCPOL,1)=$G(^IBA(355.3,+IBCPOL,1)) - ;;Daou/EEN - adding BIN and PCN - S ^TMP($J,"IBCNSP",355.3,+IBCPOL,6)=$G(^IBA(355.3,+IBCPOL,6)) - Q - ; -COMP(IBCPOL) ; -- Compare before editing with globals - S IBDIF=0 - I $G(^IBA(355.3,+IBCPOL,0))'=$G(^TMP($J,"IBCNSP",355.3,+IBCPOL,0)) S IBDIF=1 Q - I $G(^IBA(355.3,+IBCPOL,1))'=$G(^TMP($J,"IBCNSP",355.3,+IBCPOL,1)) S IBDIF=1 Q - ;;Daou/EEN - adding BIN and PCN - I $G(^IBA(355.3,+IBCPOL,6))'=$G(^TMP($J,"IBCNSP",355.3,+IBCPOL,6)) S IBDIF=1 Q - Q - ; -UPDATE(IBCPOL) ; -- Update last edited by - N DA,DIC,DIE,DR - S DIE="^IBA(355.3,",DA=IBCPOL,DR="1.05///NOW;1.06////"_DUZ - D ^DIE - Q - ; -RIDERS ; -- add/edit personal riders - ; - D FULL^VALM1 - N IBDIF,DA,DR,DIE,DIC,X,Y,IBCDFN,IBPRD,IBPRY - S IBCDFN=$P(IBPPOL,"^",4) - W ! D DISPR W ! - ; -R1 S DIC="^IBA(355.7,",DIC(0)="AEQML",DLAYGO=355.7 - S DIC("DR")=".02////"_DFN_";.03////"_IBCDFN - S DIC("S")="I $P(^(0),U,2)=DFN,$P(^(0),U,3)=IBCDFN" - I $D(IBPRD) S DIC("B")=IBPRD - D ^DIC K DIC,IBPRD - I +Y<1 G RIDERQ - S IBPRY=+Y - L +^IBA(355.7,IBPRY):5 I '$T D LOCKED^IBTRCD1 G RIDERQ - S DIE="^IBA(355.7,",DA=+Y,DR=".01",DIDEL=355.7 - D ^DIE K DA,DR,DIE,DIC,DIDEL - L -^IBA(355.7,IBPRY) - W ! G R1 -RIDERQ S VALMBCK="R" - Q - ; -RD ; -- Add riders/ for multiple policies - D FULL^VALM1 - N I,J,IBXX,VALMY - D EN^VALM2($G(XQORNOD(0))) - I $D(VALMY) S IBXX=0 F S IBXX=$O(VALMY(IBXX)) Q:'IBXX D - .S IBPPOL=$G(^TMP("IBNSMDX",$J,$O(^TMP("IBNSM",$J,"IDX",IBXX,0)))) - .Q:IBPPOL="" - .D RIDERS - .Q - D BLD^IBCNSM - S VALMBCK="R" - Q - ; -DISPR ; -- Display riders - N IBPR,I,J - S I=0 - I '$G(IBCDFN)!('$G(DFN)) G DISPRQ - W !,"Current Personal Riders: " - F S I=$O(^IBA(355.7,"APP",DFN,IBCDFN,I)) Q:'I S J=$O(^(I,0)),IBPR=$G(^IBA(355.7,+J,0)) D - .S IBPRD=$$EXPAND^IBTRE(355.7,.01,+IBPR) - .W !?5,IBPRD - I '$D(IBPRD) W !?5,"None Indicated" -DISPRQ Q - ; -EMPSET(DFN,IBCPOL) ; insert patient or spouses current employer as ESGHP address if that employer sponsors this plan - N IBWHOS,VAOA,DIR,IBE,IBEMPST,DR,X,Y - I +$G(DFN) S IBWHOS=$P($G(^DPT(DFN,.312,+$G(IBCPOL),0)),U,6) S VAOA("A")=$S(IBWHOS="v":5,IBWHOS="s":6,1:"") - I $G(VAOA("A"))'="" D OAD^VADPT I $G(VAOA(9))'="" D - . ; - . S DIR("A")="Current Employer "_VAOA(9)_" Sponsors this Plan",DIR("B")="No",DIR(0)="Y" W ! D ^DIR W ! Q:'Y W "...." - . D VARS S IBE=$S(IBWHOS="v":.311,1:.25),IBEMPST=$P($G(^DPT(DFN,IBE)),U,15) - . ; - . S DR="2.015///"_VAOA(9)_";2.02///"_VAOA(1)_";2.03///"_VAOA(2)_";2.04///"_VAOA(3)_";2.05///"_VAOA(4) D ^DIE - . S DR="2.06////"_$P(VAOA(5),U,1)_";2.07////"_$P(VAOA(11),U,1)_";2.08///"_$E(VAOA(8),1,15)_";2.11////"_IBEMPST D ^DIE - Q +IBCNSP3 ;ALB/AAS - INSURANCE MANAGEMENT EDIT ; 06-JUL-93 + ;;2.0;INTEGRATED BILLING;**28,52,85,251**;21-MAR-94 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; +% G ^IBCNSM4 + ; +SAVEPT(DFN,DA) ; -- Save the global before editing + K ^TMP($J,"IBCNSPT") + S ^TMP($J,"IBCNSPT",2.312,DFN,+DA,0)=$G(^DPT(DFN,.312,+DA,0)) + S ^TMP($J,"IBCNSPT",2.312,DFN,+DA,1)=$G(^DPT(DFN,.312,+DA,1)) + S ^TMP($J,"IBCNSPT",2.312,DFN,+DA,2)=$G(^DPT(DFN,.312,+DA,2)) + S ^TMP($J,"IBCNSPT",2.312,DFN,+DA,3)=$G(^DPT(DFN,.312,+DA,3)) + S ^TMP($J,"IBCNSPT",2.312,DFN,+DA,4)=$G(^DPT(DFN,.312,+DA,4)) + Q + ; +COMPPT(DFN,DA) ; -- Compare before editing with globals + S IBDIF=0 + I $G(^DPT(DFN,.312,+DA,0))'=$G(^TMP($J,"IBCNSPT",2.312,DFN,+DA,0)) S IBDIF=1 G COMPPTQ + I $G(^DPT(DFN,.312,+DA,1))'=$G(^TMP($J,"IBCNSPT",2.312,DFN,+DA,1)) S IBDIF=1 G COMPPTQ + I $G(^DPT(DFN,.312,+DA,2))'=$G(^TMP($J,"IBCNSPT",2.312,DFN,+DA,2)) S IBDIF=1 G COMPPTQ + I $G(^DPT(DFN,.312,+DA,3))'=$G(^TMP($J,"IBCNSPT",2.312,DFN,+DA,3)) S IBDIF=1 G COMPPTQ + I $G(^DPT(DFN,.312,+DA,4))'=$G(^TMP($J,"IBCNSPT",2.312,DFN,+DA,4)) S IBDIF=1 G COMPPTQ + ; +COMPPTQ I IBDIF D:'$D(IBCOVP) COVERED^IBCNSM31(DFN,$P($G(^DPT(DFN,.31)),"^",11)) + Q + ; +UPDATPT(DFN,DA) ; -- enter date and user if editing has taken place + N DR,DIE,DIC + S DIE="^DPT("_DFN_",.312,",DA(1)=DFN + S DR="1.05///NOW;1.06////"_DUZ + D ^DIE + Q + ; +EM ; -- Employer for claims update + D FULL^VALM1 W !! + N IBDIF,DA,DR,DIC,DIE + D SAVEPT(DFN,IBCDFN) + D VARS + L +^DPT(DFN,.312,+$P($G(IBPPOL),"^",4)):5 I '$T D LOCKED^IBTRCD1 G EMQ + ; + ;S DR="2.01;S:'$P($G(^DPT(DFN,.312,+$G(DA),2)),U) Y=""@999"";W !!,""*** If ROI applies, make sure current consent is signed! ***"",!;2.015;2.02;2.03;2.04;2.05;2.06;2.07;2.08;2.09;@999" + ; + S DR="2.1" D ^DIE K DIE,DR + ; + I +$P($G(^DPT(DFN,.312,+$G(DA),2)),U,10),$P($G(^DPT(DFN,.312,+$G(DA),2)),U,9)="" D EMPSET(DFN,$G(DA)) ; curr emp + ; + I +$P($G(^DPT(DFN,.312,+$G(DA),2)),U,10) D VARS S DR="2.015;2.11;2.12;2.01;W:+X !!,""*** If ROI applies, make sure current consent is signed! ***"",!!;2.02;2.03;2.04;2.05;2.06;2.07;2.08;@999" D ^DIE K DIE,DR + ; + ;I '$P($G(^DPT(DFN,.312,+$G(DA),2)),U) D VARS S DR="2.015///@;2.02///@;2.03///@;2.04///@;2.05///@;2.06///@;2.07///@;2.08///@" D ^DIE + ; + I '$P($G(^DPT(DFN,.312,+$G(DA),2)),U,10) D VARS S DR="2.01///@;2.015///@;2.02///@;2.03///@;2.04///@;2.05///@;2.06///@;2.07///@;2.08///@;2.11///@;2.12///@" D ^DIE + ; + D COMPPT(DFN,IBCDFN) + I IBDIF D UPDATPT(DFN,IBCDFN),BLD^IBCNSP + L -^DPT(DFN,.312,+$P($G(IBPPOL),"^",4)) +EMQ S VALMBCK="R" Q + ; +AC ; -- Add Comment + D FULL^VALM1 W !! + N IBDIF,DA,DR,DIE,DIC,X,Y + D SAVEPT(DFN,IBCDFN) + W !!,"You may now enter a brief comment about this patient's policy" + D VARS + L +^DPT(DFN,.312,+$P($G(IBPPOL),"^",4)):5 I '$T D LOCKED^IBTRCD1 G ACQ + S DR="1.08" D ^DIE + D COMPPT(DFN,IBCDFN) I IBDIF D UPDATPT(DFN,IBCDFN) + L -^DPT(DFN,.312,+$P($G(IBPPOL),"^",4)) + W !!,"You may now enter comments about this Group Plan that pertains to all Patients" + L +^IBA(355.3,+IBCPOL):5 I '$T D LOCKED^IBTRCD1 G ACQ + S DIE="^IBA(355.3,",DA=IBCPOL,DR="11" D ^DIE + D BLD^IBCNSP + L -^IBA(355.3,+IBCPOL) +ACQ S VALMBCK="R" Q + ; +BLS(X,Y) ; -- blank a section of lines + N I + F I=X:1:Y D BLANK^IBCNSP(.I) + Q + ; +VARS ; -- set vars for call to die for .312 node + S DA(1)=DFN,DA=$P(IBPPOL,"^",4) + S DIE="^DPT("_DA(1)_",.312," + Q + ; +SAVE(IBCPOL) ; -- Save the global before editing + K ^TMP($J,"IBCNSP") + S ^TMP($J,"IBCNSP",355.3,+IBCPOL,0)=$G(^IBA(355.3,+IBCPOL,0)) + S ^TMP($J,"IBCNSP",355.3,+IBCPOL,1)=$G(^IBA(355.3,+IBCPOL,1)) + ;;Daou/EEN - adding BIN and PCN + S ^TMP($J,"IBCNSP",355.3,+IBCPOL,6)=$G(^IBA(355.3,+IBCPOL,6)) + Q + ; +COMP(IBCPOL) ; -- Compare before editing with globals + S IBDIF=0 + I $G(^IBA(355.3,+IBCPOL,0))'=$G(^TMP($J,"IBCNSP",355.3,+IBCPOL,0)) S IBDIF=1 Q + I $G(^IBA(355.3,+IBCPOL,1))'=$G(^TMP($J,"IBCNSP",355.3,+IBCPOL,1)) S IBDIF=1 Q + ;;Daou/EEN - adding BIN and PCN + I $G(^IBA(355.3,+IBCPOL,6))'=$G(^TMP($J,"IBCNSP",355.3,+IBCPOL,6)) S IBDIF=1 Q + Q + ; +UPDATE(IBCPOL) ; -- Update last edited by + N DA,DIC,DIE,DR + S DIE="^IBA(355.3,",DA=IBCPOL,DR="1.05///NOW;1.06////"_DUZ + D ^DIE + Q + ; +RIDERS ; -- add/edit personal riders + ; + D FULL^VALM1 + N IBDIF,DA,DR,DIE,DIC,X,Y,IBCDFN,IBPRD,IBPRY + S IBCDFN=$P(IBPPOL,"^",4) + W ! D DISPR W ! + ; +R1 S DIC="^IBA(355.7,",DIC(0)="AEQML",DLAYGO=355.7 + S DIC("DR")=".02////"_DFN_";.03////"_IBCDFN + S DIC("S")="I $P(^(0),U,2)=DFN,$P(^(0),U,3)=IBCDFN" + I $D(IBPRD) S DIC("B")=IBPRD + D ^DIC K DIC,IBPRD + I +Y<1 G RIDERQ + S IBPRY=+Y + L +^IBA(355.7,IBPRY):5 I '$T D LOCKED^IBTRCD1 G RIDERQ + S DIE="^IBA(355.7,",DA=+Y,DR=".01",DIDEL=355.7 + D ^DIE K DA,DR,DIE,DIC,DIDEL + L -^IBA(355.7,IBPRY) + W ! G R1 +RIDERQ S VALMBCK="R" + Q + ; +RD ; -- Add riders/ for multiple policies + D FULL^VALM1 + N I,J,IBXX,VALMY + D EN^VALM2($G(XQORNOD(0))) + I $D(VALMY) S IBXX=0 F S IBXX=$O(VALMY(IBXX)) Q:'IBXX D + .S IBPPOL=$G(^TMP("IBNSMDX",$J,$O(^TMP("IBNSM",$J,"IDX",IBXX,0)))) + .Q:IBPPOL="" + .D RIDERS + .Q + D BLD^IBCNSM + S VALMBCK="R" + Q + ; +DISPR ; -- Display riders + N IBPR,I,J + S I=0 + I '$G(IBCDFN)!('$G(DFN)) G DISPRQ + W !,"Current Personal Riders: " + F S I=$O(^IBA(355.7,"APP",DFN,IBCDFN,I)) Q:'I S J=$O(^(I,0)),IBPR=$G(^IBA(355.7,+J,0)) D + .S IBPRD=$$EXPAND^IBTRE(355.7,.01,+IBPR) + .W !?5,IBPRD + I '$D(IBPRD) W !?5,"None Indicated" +DISPRQ Q + ; +EMPSET(DFN,IBCPOL) ; insert patient or spouses current employer as ESGHP address if that employer sponsors this plan + N IBWHOS,VAOA,DIR,IBE,IBEMPST,DR,X,Y + I +$G(DFN) S IBWHOS=$P($G(^DPT(DFN,.312,+$G(IBCPOL),0)),U,6) S VAOA("A")=$S(IBWHOS="v":5,IBWHOS="s":6,1:"") + I $G(VAOA("A"))'="" D OAD^VADPT I $G(VAOA(9))'="" D + . ; + . S DIR("A")="Current Employer "_VAOA(9)_" Sponsors this Plan",DIR("B")="No",DIR(0)="Y" W ! D ^DIR W ! Q:'Y W "...." + . D VARS S IBE=$S(IBWHOS="v":.311,1:.25),IBEMPST=$P($G(^DPT(DFN,IBE)),U,15) + . ; + . S DR="2.015///"_VAOA(9)_";2.02///"_VAOA(1)_";2.03///"_VAOA(2)_";2.04///"_VAOA(3)_";2.05///"_VAOA(4) D ^DIE + . S DR="2.06////"_$P(VAOA(5),U,1)_";2.07////"_$P(VAOA(11),U,1)_";2.08///"_$E(VAOA(8),1,15)_";2.11////"_IBEMPST D ^DIE + Q diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSU.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSU.m index 847d2ae0..cde09461 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSU.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSU.m @@ -1,208 +1,187 @@ -IBCNSU ;ALB/AAS - INSURANCE UTILITY ROUTINE ;19-MAY-93 - ;;2.0;INTEGRATED BILLING;**28,103,371**; 21-MAR-94;Build 57 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -AB(IBCPOL,IBYR,IBASK) ; -- Return entry in Annual Benefits file - ; Input: IBCPOL = pointer to health insurance policy file - ; IBYR = fileman internal date, Default = dt - ; IBASK = 1 if want to ask okay to add new entry - ; - ; Output: IBCAB = pointer to Annual Benefits file if added, else null - ; - N DIR,IBCAB - S IBCAB="" - I $G(IBCPOL)="" G ABQ - I $G(IBYR)="" S IBYR=DT - ;S IBYR=$E(IBYR,1,3)_"0000" - ; - ; -- try to find entry for policy for year - S IBCAB=$O(^IBA(355.4,"APY",IBCPOL,-IBYR,0)) - ; - ; -- if no match add new entry - I 'IBCAB D - .I $G(IBASK) S DIR(0)="Y",DIR("A")="Are you adding a new Annual Benefits YEAR",DIR("B")="YES" D ^DIR I $D(DIRUT)!(Y<1) S VALMQUIT="" Q - .S IBCAB=$$ADDB(IBCPOL,IBYR) - .Q -ABQ Q IBCAB - ; -ADDB(IBCPOL,IBYR) ; -- add entries to Annual Benefits file - ; Input: IBCPOL = pointer to health insurance policy file - ; IBYR = fileman internal date, Default = dt - ; - ; Output: IBCAB = pointer to Annual Benefits file if added, else null - ; - N %DT,IBN1,IBCAB,DIC,DIE,DR,DA,DLAYGO,DO,DD - S IBCAB="" - I $G(IBCPOL)="" G ADDBQ - I $G(IBYR)="" S IBYR=DT - K DD,DO,DIC,DR S DIC="^IBA(355.4,",DIC(0)="L",DLAYGO=355.4 - ; - ;S X=$E(IBYR,1,3)_"0000" - S X=IBYR D FILE^DICN I +Y<0 G ADDBQ - S (IBCAB,DA)=+Y,DIE="^IBA(355.4,",DR=".02////"_IBCPOL - D ^DIE K DIC,DIE,DA,DR -ADDBQ Q IBCAB - ; -CHIP(IBCDFND) ; -- convert node with no hip pointer to one with hip pointer - ; Input: IBCDFND = zeroth node of insurance type multiple - ; = ^dpt(dfn,.312,ibcdfn,0) - ; - ; Output: IBCPOL = pointer to policy file - ; - N IBCNS,IBGRP,IBGRNA,IBGRNU - S IBCNS=+IBCDFND,IBGRNA=$P(IBCDFND,"^",15),IBGRNU=$P(IBCDFND,"^",3),IBGRP=0 - I IBGRNA'=""!(IBGRNU'="") S IBGRP=1 - S IBCPOL=$$HIP(IBCNS,IBGRP,IBGRNA,IBGRNU) -CHIPQ Q IBCPOL - ; -HIP(IBCNS,IBGRP,IBGRNA,IBGRNU) ; -- find internal entry number in policy file - ; Input: IBCNS = pointer to ins co file - ; IBGRP = 1 if group policy, 0 if not - ; IBGRNA = group name - ; IBGRNU = group number - ; - ; Output: IBCPOL = pointer to policy file - ; - N %DT - S IBCPOL="" - I $G(^DIC(36,+$G(IBCNS),0))="" G HIPQ - S IBGRP=+$G(IBGRP) ; if undefine, is not a group policy - I 'IBGRP S IBCPOL=$$ADDH(IBCNS,IBGRP) G HIPQ - ; - S:$G(IBGRNU)="" IBGRNU="IB ZZZZZ" - I IBGRNU'="IB ZZZZZ" S IBCPOL=$O(^IBA(355.3,"AGNU",IBCNS,IBGRNU,0)) - I IBCPOL,$P($G(^IBA(355.3,+IBCPOL,0)),"^",3)=IBGRNA G HIPQ ; match both - ; - S:$G(IBGRNA)="" IBGRNA="IB ZZZZZ" - S IBCPOL=$O(^IBA(355.3,"AGNA",IBCNS,IBGRNA,0)) - I IBCPOL,$P($G(^IBA(355.3,+IBCPOL,0)),"^",4)=IBGRNU G HIPQ ; match both - ; - I 'IBCPOL S IBCPOL=$$ADDH(IBCNS,IBGRP) D - .I IBGRNA="",IBGRNU="" Q - .S:IBGRNA="IB ZZZZZ" IBGRNA="" S:IBGRNU="IB ZZZZZ" IBGRNU="" - .S DA=IBCPOL,DIE="^IBA(355.3,",DR=".03////"_$$STRIP(IBGRNA,";")_";.04////"_$$STRIP(IBGRNU,";") - .D ^DIE K DA,DR,DIC,DIE -HIPQ Q IBCPOL - ; -ADDH(IBCNS,IBGRP,IBGNA,IBGNU) ; -- add entries to health insurance policy file (355.3) - ; Input: IBCNS = pointer to ins co file - ; IBGRP = 1 if group policy, 0 if no - ; - ; Output: IBCPOL = pointer to policy file, if added else null - ; - N %DT,IBN1,IBCAB,DIC,DIE,DR,DA,DLAYGO,DO,DD - S IBCPOL="" - I $G(IBCNS)="" G ADDHQ - K DD,DO,DIC,DR S DIC="^IBA(355.3,",DIC(0)="L",DLAYGO=355.3 - ; - S X=IBCNS D FILE^DICN I +Y<0 G ADDHQ - S (DA,IBCPOL)=+Y,DIE="^IBA(355.3,",DR=".02////"_+$G(IBGRP) - I IBGRP=0,$G(DFN) S DR=DR_";.1////"_DFN - I $D(IBGNU) S DR=DR_";.04///^S X=IBGNU" - I $D(IBGNA) S DR=DR_";.03///^S X=IBGNA" - D ^DIE K DA,DR,DIE,DIC - I $G(IBCNTP)'="" S IBCNTP=IBCNTP+1 -ADDHQ Q IBCPOL - ; -ODELP(DFN,INS) ; -- can an insurance policy be deleted - ; -- called by ^dd(2.312,0,"del",.01) and by ibcnsm - ; -- input dfn: ien of patient in file 2. - ; ins: ien of ins. co in file 36 - ; - ; -- output 1 if no deletion allowed - ; 0 if deletion allowed - N I,X,Y S X=0 - ; - ; -- do not delete if any uncancelled bills - S J=0 F S J=$O(^DGCR(399,"AE",DFN,INS,J)) Q:'J I $P(^DGCR(399,J,"S"),"^",17)="" S X=1 Q -ODELPQ Q X - ; -STRIP(X,X1) ; -- strip characters from string - ; input: x = string - ; x1 = character to strip (default is ";" - N I,X2 - S X2="" S:$G(X1)="" X1=";" - S X1=$E(X1) - F I=1:1 S X2=X2_$P(X,X1,I) Q:($P(X,X1,I+1,999)'[X1) - Q X2 - ; - ; -DELP(DFN,INS,IBC) ; -- can an insurance policy be deleted - ; -- called by ^dd(2.312,0,"del",.01) and by ibcnsm - ; -- input dfn: ien of patient in file 2. - ; ins: ien of ins. co in file 36 - ; ibc: ien of policy in file 2.312 to do a match - ; - ; -- output 1 if no deletion allowed - ; 0 if deletion allowed - ; - N ARR,J,ONEPOL,X - ; - ; - check input - I '$G(DFN)!'$G(INS) S X=1 G DELPQ - ; - ; - see if vet has more than one policy with carrier; set flag - ; - also, if no policy is passed, assume the patient has one policy - I $G(IBC) D - .S J=0 F S J=$O(^DPT("AB",IBC,DFN,J)) Q:'J S ARR(J)=$G(^DPT(DFN,.312,J,0)) - .S (J,ONEPOL)=0 S J=$O(ARR(J)) I J,'$O(ARR(J)) S ONEPOL=1 - E S ONEPOL=1 - ; - ; - ; -- do not delete if any uncancelled bills - S (J,X)=0 F S J=$O(^DGCR(399,"AE",DFN,INS,J)) Q:'J D Q:X - .; - .N ARRP,POL,K,L,M,MP,S,Z - .S Z=$G(^DGCR(399,J,0)),M=$G(^("M")),MP=$G(^("MP")),S=$G(^("S")) - .; - .; - skip cancelled bills - .I $P(S,"^",17)'="" Q - .; - .; - set flag if the patient has just one policy with the company - .I ONEPOL S X=1 Q - .; - .; - if there are no policy pointers in the claim, - .I '$P(M,"^",12),'$P(M,"^",13),'$P(M,"^",14),'$P(MP,"^",2) D Q - ..; - ..; - find all policies effective on the event date - ..S K=0 F S K=$O(ARR(K)) Q:'K S POL=ARR(K) D - ...I $P(POL,"^",8) Q:$P(Z,"^",3)<$P(POL,"^",8) - ...I $P(POL,"^",4) Q:$P(Z,"^",3)>$P(POL,"^",4) - ...S ARRP(K)="" - ..; - ..; - if there are two such policies, trust user judgement and assume - ..; - policy is not related to this claim. - ..S L=$O(ARRP(0)) I L,$O(ARR(L)) Q - ..; - ..; - if there is just one policy, and it is the same as the one - ..; - passed in, do not allow deletion. - ..I L=IBC S X=1 - .; - .; - if one of the claim policy pointers is the same as the policy - .; - passed in, do not allow deletion. - .I $P(MP,"^",2)=IBC S X=1 Q - .I $P(M,"^",12)=IBC!($P(M,"^",13)=IBC)!($P(M,"^",14)=IBC) S X=1 - ; - ; -DELPQ Q X - ; -DUPADDRL(DATA,IBCNS,FLD1,FLD2) ; Insurance address lines can not be duplicated - ; DATA - Value being compared - ; FLD1 - First field to check against - ; FLD2 - Second field to check against (OPTIONAL) - ; - ; Returns 1 if this field is a duplicate of another field. - ; - N Z1,Z2 - Q:$G(DATA)="" 0 ; should not happen because this is invoked as an input transform - Q:'$G(IBCNS) 1 ; stop from editing through fileman - S DATA=$$UP^XLFSTR($G(DATA)),DATA=$$TRIM^XLFSTR(DATA) - S Z1=$$GET1^DIQ(36,+$G(IBCNS),+$G(FLD1),"I") - S Z1=$$UP^XLFSTR(Z1),Z1=$$TRIM^XLFSTR(Z1) - S Z2=$$GET1^DIQ(36,+$G(IBCNS),+$G(FLD2),"I") - S Z2=$$UP^XLFSTR(Z2),Z2=$$TRIM^XLFSTR(Z2) - I DATA=Z1 D CLEAN^DILF Q 1 - I DATA=Z2 D CLEAN^DILF Q 1 - D CLEAN^DILF - Q 0 - ; +IBCNSU ;ALB/AAS - INSURANCE UTILITY ROUTINE ; 19-MAY-93 + ;;2.0;INTEGRATED BILLING;**28,103**; 21-MAR-94 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; +AB(IBCPOL,IBYR,IBASK) ; -- Return entry in Annual Benefits file + ; Input: IBCPOL = pointer to health insurance policy file + ; IBYR = fileman internal date, Default = dt + ; IBASK = 1 if want to ask okay to add new entry + ; + ; Output: IBCAB = pointer to Annual Benefits file if added, else null + ; + N DIR,IBCAB + S IBCAB="" + I $G(IBCPOL)="" G ABQ + I $G(IBYR)="" S IBYR=DT + ;S IBYR=$E(IBYR,1,3)_"0000" + ; + ; -- try to find entry for policy for year + S IBCAB=$O(^IBA(355.4,"APY",IBCPOL,-IBYR,0)) + ; + ; -- if no match add new entry + I 'IBCAB D + .I $G(IBASK) S DIR(0)="Y",DIR("A")="Are you adding a new Annual Benefits YEAR",DIR("B")="YES" D ^DIR I $D(DIRUT)!(Y<1) S VALMQUIT="" Q + .S IBCAB=$$ADDB(IBCPOL,IBYR) + .Q +ABQ Q IBCAB + ; +ADDB(IBCPOL,IBYR) ; -- add entries to Annual Benefits file + ; Input: IBCPOL = pointer to health insurance policy file + ; IBYR = fileman internal date, Default = dt + ; + ; Output: IBCAB = pointer to Annual Benefits file if added, else null + ; + N %DT,IBN1,IBCAB,DIC,DIE,DR,DA,DLAYGO,DO,DD + S IBCAB="" + I $G(IBCPOL)="" G ADDBQ + I $G(IBYR)="" S IBYR=DT + K DD,DO,DIC,DR S DIC="^IBA(355.4,",DIC(0)="L",DLAYGO=355.4 + ; + ;S X=$E(IBYR,1,3)_"0000" + S X=IBYR D FILE^DICN I +Y<0 G ADDBQ + S (IBCAB,DA)=+Y,DIE="^IBA(355.4,",DR=".02////"_IBCPOL + D ^DIE K DIC,DIE,DA,DR +ADDBQ Q IBCAB + ; +CHIP(IBCDFND) ; -- convert node with no hip pointer to one with hip pointer + ; Input: IBCDFND = zeroth node of insurance type multiple + ; = ^dpt(dfn,.312,ibcdfn,0) + ; + ; Output: IBCPOL = pointer to policy file + ; + N IBCNS,IBGRP,IBGRNA,IBGRNU + S IBCNS=+IBCDFND,IBGRNA=$P(IBCDFND,"^",15),IBGRNU=$P(IBCDFND,"^",3),IBGRP=0 + I IBGRNA'=""!(IBGRNU'="") S IBGRP=1 + S IBCPOL=$$HIP(IBCNS,IBGRP,IBGRNA,IBGRNU) +CHIPQ Q IBCPOL + ; +HIP(IBCNS,IBGRP,IBGRNA,IBGRNU) ; -- find internal entry number in policy file + ; Input: IBCNS = pointer to ins co file + ; IBGRP = 1 if group policy, 0 if not + ; IBGRNA = group name + ; IBGRNU = group number + ; + ; Output: IBCPOL = pointer to policy file + ; + N %DT + S IBCPOL="" + I $G(^DIC(36,+$G(IBCNS),0))="" G HIPQ + S IBGRP=+$G(IBGRP) ; if undefine, is not a group policy + I 'IBGRP S IBCPOL=$$ADDH(IBCNS,IBGRP) G HIPQ + ; + S:$G(IBGRNU)="" IBGRNU="IB ZZZZZ" + I IBGRNU'="IB ZZZZZ" S IBCPOL=$O(^IBA(355.3,"AGNU",IBCNS,IBGRNU,0)) + I IBCPOL,$P($G(^IBA(355.3,+IBCPOL,0)),"^",3)=IBGRNA G HIPQ ; match both + ; + S:$G(IBGRNA)="" IBGRNA="IB ZZZZZ" + S IBCPOL=$O(^IBA(355.3,"AGNA",IBCNS,IBGRNA,0)) + I IBCPOL,$P($G(^IBA(355.3,+IBCPOL,0)),"^",4)=IBGRNU G HIPQ ; match both + ; + I 'IBCPOL S IBCPOL=$$ADDH(IBCNS,IBGRP) D + .I IBGRNA="",IBGRNU="" Q + .S:IBGRNA="IB ZZZZZ" IBGRNA="" S:IBGRNU="IB ZZZZZ" IBGRNU="" + .S DA=IBCPOL,DIE="^IBA(355.3,",DR=".03////"_$$STRIP(IBGRNA,";")_";.04////"_$$STRIP(IBGRNU,";") + .D ^DIE K DA,DR,DIC,DIE +HIPQ Q IBCPOL + ; +ADDH(IBCNS,IBGRP,IBGNA,IBGNU) ; -- add entries to health insurance policy file (355.3) + ; Input: IBCNS = pointer to ins co file + ; IBGRP = 1 if group policy, 0 if no + ; + ; Output: IBCPOL = pointer to policy file, if added else null + ; + N %DT,IBN1,IBCAB,DIC,DIE,DR,DA,DLAYGO,DO,DD + S IBCPOL="" + I $G(IBCNS)="" G ADDHQ + K DD,DO,DIC,DR S DIC="^IBA(355.3,",DIC(0)="L",DLAYGO=355.3 + ; + S X=IBCNS D FILE^DICN I +Y<0 G ADDHQ + S (DA,IBCPOL)=+Y,DIE="^IBA(355.3,",DR=".02////"_+$G(IBGRP) + I IBGRP=0,$G(DFN) S DR=DR_";.1////"_DFN + I $D(IBGNU) S DR=DR_";.04///^S X=IBGNU" + I $D(IBGNA) S DR=DR_";.03///^S X=IBGNA" + D ^DIE K DA,DR,DIE,DIC + I $G(IBCNTP)'="" S IBCNTP=IBCNTP+1 +ADDHQ Q IBCPOL + ; +ODELP(DFN,INS) ; -- can an insurance policy be deleted + ; -- called by ^dd(2.312,0,"del",.01) and by ibcnsm + ; -- input dfn: ien of patient in file 2. + ; ins: ien of ins. co in file 36 + ; + ; -- output 1 if no deletion allowed + ; 0 if deletion allowed + N I,X,Y S X=0 + ; + ; -- do not delete if any uncancelled bills + S J=0 F S J=$O(^DGCR(399,"AE",DFN,INS,J)) Q:'J I $P(^DGCR(399,J,"S"),"^",17)="" S X=1 Q +ODELPQ Q X + ; +STRIP(X,X1) ; -- strip characters from string + ; input: x = string + ; x1 = character to strip (default is ";" + N I,X2 + S X2="" S:$G(X1)="" X1=";" + S X1=$E(X1) + F I=1:1 S X2=X2_$P(X,X1,I) Q:($P(X,X1,I+1,999)'[X1) + Q X2 + ; + ; +DELP(DFN,INS,IBC) ; -- can an insurance policy be deleted + ; -- called by ^dd(2.312,0,"del",.01) and by ibcnsm + ; -- input dfn: ien of patient in file 2. + ; ins: ien of ins. co in file 36 + ; ibc: ien of policy in file 2.312 to do a match + ; + ; -- output 1 if no deletion allowed + ; 0 if deletion allowed + ; + N ARR,J,ONEPOL,X + ; + ; - check input + I '$G(DFN)!'$G(INS) S X=1 G DELPQ + ; + ; - see if vet has more than one policy with carrier; set flag + ; - also, if no policy is passed, assume the patient has one policy + I $G(IBC) D + .S J=0 F S J=$O(^DPT("AB",IBC,DFN,J)) Q:'J S ARR(J)=$G(^DPT(DFN,.312,J,0)) + .S (J,ONEPOL)=0 S J=$O(ARR(J)) I J,'$O(ARR(J)) S ONEPOL=1 + E S ONEPOL=1 + ; + ; + ; -- do not delete if any uncancelled bills + S (J,X)=0 F S J=$O(^DGCR(399,"AE",DFN,INS,J)) Q:'J D Q:X + .; + .N ARRP,POL,K,L,M,MP,S,Z + .S Z=$G(^DGCR(399,J,0)),M=$G(^("M")),MP=$G(^("MP")),S=$G(^("S")) + .; + .; - skip cancelled bills + .I $P(S,"^",17)'="" Q + .; + .; - set flag if the patient has just one policy with the company + .I ONEPOL S X=1 Q + .; + .; - if there are no policy pointers in the claim, + .I '$P(M,"^",12),'$P(M,"^",13),'$P(M,"^",14),'$P(MP,"^",2) D Q + ..; + ..; - find all policies effective on the event date + ..S K=0 F S K=$O(ARR(K)) Q:'K S POL=ARR(K) D + ...I $P(POL,"^",8) Q:$P(Z,"^",3)<$P(POL,"^",8) + ...I $P(POL,"^",4) Q:$P(Z,"^",3)>$P(POL,"^",4) + ...S ARRP(K)="" + ..; + ..; - if there are two such policies, trust user judgement and assume + ..; - policy is not related to this claim. + ..S L=$O(ARRP(0)) I L,$O(ARR(L)) Q + ..; + ..; - if there is just one policy, and it is the same as the one + ..; - passed in, do not allow deletion. + ..I L=IBC S X=1 + .; + .; - if one of the claim policy pointers is the same as the policy + .; - passed in, do not allow deletion. + .I $P(MP,"^",2)=IBC S X=1 Q + .I $P(M,"^",12)=IBC!($P(M,"^",13)=IBC)!($P(M,"^",14)=IBC) S X=1 + ; + ; +DELPQ Q X diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSU1.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSU1.m index 6cfd3951..fb0bfd2a 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSU1.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSU1.m @@ -1,155 +1,117 @@ -IBCNSU1 ;ALB/AAS - INSURANCE UTILITY ROUTINE ;19-MAY-93 - ;;2.0;INTEGRATED BILLING;**103,133,244,371**;21-MAR-94;Build 57 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -RCHK(X) ; -- Input transform for different revenue codes in file 36 - ; Returns 1 if passes, 0 if not pass input transform - ; - N I,Y,RC,NO S Y=0 - I $G(X)="" G RCHKQ - F I=1:1 S RC=$P(X,",",I) Q:RC="" I $S(RC?3N:0,RC?5N:0,1:1) S NO=1 Q - I '$G(NO) S Y=1 -RCHKQ Q Y - ; -BU(DFN,IBCPOL,IBYR,IBCDFN,IBASK) ; -- Return entry in Benefits Used file - ; Input: IBCDFN = pointer to patient file policy (2.312) - ; DFN = patient pointer - ; IBCPOL = pointer to health insurance policy file - ; IBYR = fileman internal date, year will be calendar - ; year of the internal date, Default = dt - ; IBASK = 1 if want to ask okay to add new entry - ; - ; Output: IBCBU = pointer to Benefits Used file if added, - ; else null - ; - N DIR,IBCBU - S IBCBU="" - I $G(IBCPOL)="" G BUQ - I $G(IBYR)="" S IBYR=DT - ; - ;if no match display message - I '$O(^IBA(355.4,"APY",IBCPOL,-IBYR,0)) W !!,"You cannot add a new Benefits Used BENEFIT YEAR",!! G BUQ - ; - ; -- try to find entry for policy for year - S IBCBU=$O(^IBA(355.5,"APPY",DFN,IBCPOL,-IBYR,IBCDFN,0)) - ; - ; -- if no match add new entry - I 'IBCBU D - .I $G(IBASK) S DIR(0)="Y",DIR("A")="Are you adding a new Benefits Used YEAR",DIR("B")="YES" D ^DIR I $D(DIRUT)!(Y<1) S VALMQUIT="" Q - .S IBCBU=$$ADDBU(DFN,IBCPOL,IBYR,IBCDFN) - .Q - ; -BUQ Q IBCBU - ; -ADDBU(DFN,IBCPOL,IBYR,IBCDFN) ; -- add entries to Benefits Used file - ; Input: DFN = pointer to patient file - ; IBCDFN = point to patient policy (2.312) - ; IBCPOL = pointer to health insurance policy file - ; IBYR = fileman internal date, year will be calendar - ; year of the internal date, Default = dt - ; - ; Output: IBCBU = pointer to Benefits Used file if added, - ; else null - ; - N %DT,IBN1,IBCBU,DIC,DIE,DR,DA,DLAYGO,DO,DD - S IBCBU="" - I $G(IBCDFN)="" G ADDBUQ - I $G(IBCPOL)="" G ADDBUQ - I $G(IBYR)="" S IBYR=DT - K DD,DO,DIC,DR S DIC="^IBA(355.5,",DIC(0)="L",DLAYGO=355.5 - ; - ;S IBYR=$E(IBYR,1,3)_"0000" - S X=IBCPOL D FILE^DICN I +Y<0 G ADDBUQ - S (IBCBU,DA)=+Y,DIE="^IBA(355.5,",DR=".02////"_DFN_";.03////"_IBYR_";.17////"_IBCDFN_";1.01///NOW;1.02////"_DUZ - D ^DIE K DIC,DIE,DA,DR -ADDBUQ Q IBCBU - ; -VET() ; -- Input Transform for sub-file 2.312, Name of Insured (#17) - ; Quit 1 to stuff Patient Name - ; Quit 0 to not stuff and allow editing - ; - N IBY,IB0 S IBY=0 - G VETQ ; IB*2*371 - Allow edits to the patient name in all cases - S IB0=$G(^DPT(+$G(DA(1)),.312,+$G(DA),0)) - I $P(IB0,"^",6)'="v" G VETQ - I +IB0'=+$$GETWNR^IBCNSMM1 S IBY=1 G VETQ - I '$D(X),$P(IB0,"^",17)="" S IBY=1 -VETQ Q IBY - ; - ; -SUBID ; -- Input Transform for sub-file #2.312, Subscriber ID (#1) - N NODE,L,R,CHAR,X1 - S CHAR="~`!@#$%^&*()_-+={}[]|\/?.,<>;:' """ - S NODE=^DPT(DA(1),.312,DA,0) - ; - ; - if the policy is a Medicare policy, make sure the subscriber ID - ; is a valid HICN number - I $P(NODE,U)=+$$GETWNR^IBCNSMM1 S X=$TR(X,"-","") I '$$VALHIC^IBCNSMM(X) D HLP^IBCNSM32 K X Q - ; - S R=$P(NODE,U,16) - S L=$TR($P(^DPT(DA(1),0),U,9),CHAR,"") - S R=$S(R="01":1,R="":1,1:0) - ; - ; - if subscriber ID is the SSN of patient, remove all extraneous - ; characters - S X1=$TR(X,CHAR,"") I X1?9N,X1=L S X=X1 - ; - K:$L(X)>20!($L(X)<3) X - Q - ; - ; -HICN(DFN) ; -- return Patient's Medicare HIC number - ; Return HICN of Medicare WNR Part A or Part B - ; Return -1 if none exits - ; - N IBWNR,IBX,IBY,IB0 - S IBWNR=$$GETWNR^IBCNSMM1,IBY="" - I '$O(^DPT(DFN,.312,"B",+IBWNR,0)) S IBY=-1 G HICNQ - S IBX=0 F S IBX=$O(^DPT(DFN,.312,"B",+IBWNR,IBX)) Q:('IBX)!(IBY]"") D - .S IB0=$G(^DPT(DFN,.312,IBX,0)) - .I $P(IB0,U,18)'=$P(IBWNR,U,3),$P(IB0,U,18)'=$P(IBWNR,U,5) Q - .; 8/18/2003 - Added translation code to remove hyphens if they exist. - .I $P(IB0,U,2)]"" S IBY=$TR($P(IB0,U,2),"- ","") - S:IBY="" IBY=-1 -HICNQ Q IBY - ; -CHKQUAL(DFN,IEN,QUAL,PC1,PC2) ; check for duplicate qualifiers for patient - ; and subscriber secondary ID's. All parameters required. - ; - ; DFN - internal patient# - ; IEN - ien of 2.312 subfile - ; QUAL - passed in response of the user (this is what is being - ; checked to see if it is valid) - ; PC1 - this is the piece# for one of the other qualifiers - ; PC2 - this is the piece# for one of the other qualifiers - ; - ; Function returns 1 if the entered qualifier is OK. - ; Function returns 0 if the entered qualifier is not OK. It is either - ; a duplicate or is otherwise invalid. - ; - NEW OK,DATA,INS - S OK=1 - I $G(QUAL)="" G CHKQUALX - S DATA=$G(^DPT(+$G(DFN),.312,+$G(IEN),5)) - I $G(QUAL)=$P(DATA,U,+$G(PC1)) D CQ1 G CHKQUALX ; duplicate - I $G(QUAL)=$P(DATA,U,+$G(PC2)) D CQ1 G CHKQUALX ; duplicate - ; - ; prevent the SSN qualifier when Medicare is the payer - S INS=+$G(^DPT(+$G(DFN),.312,+$G(IEN),0)) - I $G(QUAL)="SY",$$MCRWNR^IBEFUNC(INS) D CQ2 G CHKQUALX - ; -CHKQUALX ; - Q OK - ; -CQ1 ; specific error message#1 - S OK=0 - D EN^DDIOL("You cannot use the same qualifier more than once.",,"!!") - D EN^DDIOL("",,"!!?5") - Q - ; -CQ2 ; specific error message#2 - S OK=0 - D EN^DDIOL("You cannot use qualifier 'SY' for Medicare.",,"!!") - D EN^DDIOL("",,"!!?5") - Q - ; +IBCNSU1 ;ALB/AAS - INSURANCE UTILITY ROUTINE ; 19-MAY-93 + ;;2.0;INTEGRATED BILLING;**103,133,244**;21-MAR-94 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; +RCHK(X) ; -- Input transform for different revenue codes in file 36 + ; Returns 1 if passes, 0 if not pass input transform + ; + N I,Y,RC,NO S Y=0 + I $G(X)="" G RCHKQ + F I=1:1 S RC=$P(X,",",I) Q:RC="" I $S(RC?3N:0,RC?5N:0,1:1) S NO=1 Q + I '$G(NO) S Y=1 +RCHKQ Q Y + ; +BU(DFN,IBCPOL,IBYR,IBCDFN,IBASK) ; -- Return entry in Benefits Used file + ; Input: IBCDFN = pointer to patient file policy (2.312) + ; DFN = patient pointer + ; IBCPOL = pointer to health insurance policy file + ; IBYR = fileman internal date, year will be calendar + ; year of the internal date, Default = dt + ; IBASK = 1 if want to ask okay to add new entry + ; + ; Output: IBCBU = pointer to Benefits Used file if added, + ; else null + ; + N DIR,IBCBU + S IBCBU="" + I $G(IBCPOL)="" G BUQ + I $G(IBYR)="" S IBYR=DT + ; + ;if no match display message + I '$O(^IBA(355.4,"APY",IBCPOL,-IBYR,0)) W !!,"You cannot add a new Benefits Used BENEFIT YEAR",!! G BUQ + ; + ; -- try to find entry for policy for year + S IBCBU=$O(^IBA(355.5,"APPY",DFN,IBCPOL,-IBYR,IBCDFN,0)) + ; + ; -- if no match add new entry + I 'IBCBU D + .I $G(IBASK) S DIR(0)="Y",DIR("A")="Are you adding a new Benefits Used YEAR",DIR("B")="YES" D ^DIR I $D(DIRUT)!(Y<1) S VALMQUIT="" Q + .S IBCBU=$$ADDBU(DFN,IBCPOL,IBYR,IBCDFN) + .Q + ; +BUQ Q IBCBU + ; +ADDBU(DFN,IBCPOL,IBYR,IBCDFN) ; -- add entries to Benefits Used file + ; Input: DFN = pointer to patient file + ; IBCDFN = point to patient policy (2.312) + ; IBCPOL = pointer to health insurance policy file + ; IBYR = fileman internal date, year will be calendar + ; year of the internal date, Default = dt + ; + ; Output: IBCBU = pointer to Benefits Used file if added, + ; else null + ; + N %DT,IBN1,IBCBU,DIC,DIE,DR,DA,DLAYGO,DO,DD + S IBCBU="" + I $G(IBCDFN)="" G ADDBUQ + I $G(IBCPOL)="" G ADDBUQ + I $G(IBYR)="" S IBYR=DT + K DD,DO,DIC,DR S DIC="^IBA(355.5,",DIC(0)="L",DLAYGO=355.5 + ; + ;S IBYR=$E(IBYR,1,3)_"0000" + S X=IBCPOL D FILE^DICN I +Y<0 G ADDBUQ + S (IBCBU,DA)=+Y,DIE="^IBA(355.5,",DR=".02////"_DFN_";.03////"_IBYR_";.17////"_IBCDFN_";1.01///NOW;1.02////"_DUZ + D ^DIE K DIC,DIE,DA,DR +ADDBUQ Q IBCBU + ; +VET() ; -- Input Transform for sub-file 2.312, Name of Insured (#17) + ; Quit 1 to stuff Patient Name + ; Quit 0 to not stuff and allow editing + ; + N IBY,IB0 S IBY=0 + S IB0=$G(^DPT(+$G(DA(1)),.312,+$G(DA),0)) + I $P(IB0,"^",6)'="v" G VETQ + I +IB0'=+$$GETWNR^IBCNSMM1 S IBY=1 G VETQ + I '$D(X),$P(IB0,"^",17)="" S IBY=1 +VETQ Q IBY + ; + ; +SUBID ; -- Input Transform for sub-file #2.312, Subscriber ID (#1) + N NODE,L,R,CHAR,X1 + S CHAR="~`!@#$%^&*()_-+={}[]|\/?.,<>;:' """ + S NODE=^DPT(DA(1),.312,DA,0) + ; + ; - if the policy is a Medicare policy, make sure the subscriber ID + ; is a valid HICN number + I $P(NODE,U)=+$$GETWNR^IBCNSMM1 S X=$TR(X,"-","") I '$$VALHIC^IBCNSMM(X) D HLP^IBCNSM32 K X Q + ; + S R=$P(NODE,U,16) + S L=$TR($P(^DPT(DA(1),0),U,9),CHAR,"") + S R=$S(R="01":1,R="":1,1:0) + ; + ; - if subscriber ID is the SSN of patient, remove all extraneous + ; characters + S X1=$TR(X,CHAR,"") I X1?9N,X1=L S X=X1 + ; + ; - if "SS" is entered, and the policy belongs to the patient, + ; convert that string to the patient's SSN + I R=1,X="SS" W " ",L S X=L + ; + K:$L(X)>20!($L(X)<3) X + Q + ; + ; +HICN(DFN) ; -- return Patient's Medicare HIC number + ; Return HICN of Medicare WNR Part A or Part B + ; Return -1 if none exits + ; + N IBWNR,IBX,IBY,IB0 + S IBWNR=$$GETWNR^IBCNSMM1,IBY="" + I '$O(^DPT(DFN,.312,"B",+IBWNR,0)) S IBY=-1 G HICNQ + S IBX=0 F S IBX=$O(^DPT(DFN,.312,"B",+IBWNR,IBX)) Q:('IBX)!(IBY]"") D + .S IB0=$G(^DPT(DFN,.312,IBX,0)) + .I $P(IB0,U,18)'=$P(IBWNR,U,3),$P(IB0,U,18)'=$P(IBWNR,U,5) Q + .; 8/18/2003 - Added translation code to remove hyphens if they exist. + .I $P(IB0,U,2)]"" S IBY=$TR($P(IB0,U,2),"- ","") + S:IBY="" IBY=-1 +HICNQ Q IBY diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBC.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBC.m index f6ecef90..b97ad0aa 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBC.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBC.m @@ -1,179 +1,182 @@ -IBCRBC ;ALB/ARH - RATES: BILL CALCULATION OF CHARGES ; 22-MAY-1996 - ;;2.0;INTEGRATED BILLING;**52,80,106,51,137,245,370**;21-MAR-94;Build 5 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ; Variable DGPTUPDT may be defined on entry/exit for inpt bills so the PTF will only be updated once per session - ; Charges may be filed on the bill and if IBRSARR is passed but does not exist it may be updated - ; otherwise there are no other outputs/results of this call. - ; -BILL(IBIFN,IBRSARR) ; given a bill number calculate and store all charges - ; if IBRSARR is defined it will be used to create charges rather than the standard set for the bills Rate Type - ; - N IB0,IBU,IBBRT,IBBTYPE,IBCTYPE,DFN,PTF,IBDGPT,IBRS,IBCS,IBBEVNT Q:'$G(IBIFN) - K ^TMP($J,"IBCRCC"),^TMP($J,"IBCRCS") - ; - S IB0=$G(^DGCR(399,+IBIFN,0)) Q:IB0="" S IBU=$G(^DGCR(399,+IBIFN,"U")) Q:'IBU - S IBBRT=+$P(IB0,U,7),IBBTYPE=$S($$INPAT^IBCEF(IBIFN):1,1:3),IBCTYPE=+$P(IB0,U,27),DFN=$P(IB0,U,2) Q:'DFN - ; - ; if who's responsible is insurer, but bill has no insurer defined quit - I $P(IB0,U,11)="i",'$G(^DGCR(399,+IBIFN,"MP")),'$$MCRWNR^IBEFUNC(+$$CURR^IBCEF2(IBIFN)) Q - ; - ; if inpt bill, PTF Status is Open, not a Fee Basis record and not previously done then Update the PTF record - I IBBTYPE<3,'$D(DGPTUPDT) S PTF=$P(IB0,U,8) Q:'PTF S IBDGPT=$G(^DGPT(+PTF,0)) Q:IBDGPT="" D - . I '$P(IBDGPT,U,6),'$P(IBDGPT,U,4) D UPDT^DGPTUTL S DGPTUPDT="" - ; - ; - D DSPDL^IBCRBC3,DELALLRC^IBCRBF(IBIFN) ; delete all existing auto charges on the bill - ; - ; get standard set of all rate schedules and charge sets available for entire date range of the bill - I '$D(IBRSARR) D RT^IBCRU3(IBBRT,IBBTYPE,$P(IBU,U,1,2),.IBRSARR,"",IBCTYPE) I 'IBRSARR G END - ; - ; process charge sets - set all charges for the bill into array - S IBRS=0 F S IBRS=$O(IBRSARR(IBRS)) Q:'IBRS D - . S IBCS=0 F S IBCS=$O(IBRSARR(IBRS,IBCS)) Q:'IBCS I +IBRSARR(IBRS,IBCS) D - .. S IBBEVNT=+$P($G(^IBE(363.1,+IBCS,0)),U,3) Q:'IBBEVNT S IBBEVNT=$$EMUTL^IBCRU1(IBBEVNT) Q:IBBEVNT="" - .. ; - .. I IBBEVNT["INPATIENT BEDSECTION STAY" D INPTBS^IBCRBC1(IBIFN,IBRS,IBCS) - .. I IBBEVNT["INPATIENT DRG" D INPTDRG^IBCRBC11(IBIFN,IBRS,IBCS) - .. I IBBEVNT["OUTPATIENT VISIT DATE" D OPTVST^IBCRBC1(IBIFN,IBRS,IBCS) - .. I IBBEVNT["PRESCRIPTION" D RX^IBCRBC1(IBIFN,IBRS,IBCS) - .. I IBBEVNT["PROSTHETICS" D PI^IBCRBC1(IBIFN,IBRS,IBCS) - .. I IBBEVNT["PROCEDURE" D CPT^IBCRBC1(IBIFN,IBRS,IBCS) - ; - I '$D(^TMP($J,"IBCRCC")) G END - ; - D SORTCI^IBCRBC3 I '$D(^TMP($J,"IBCRCS")) G END - ; - D ADDBCHGS^IBCRBC3(IBIFN) - ; - D MAILADD(IBIFN,IBBTYPE) - ; -END I $D(^TMP("IBCRRX",$J)) D CLEANRX^IBCRBC3(IBIFN) - K ^TMP($J,"IBCRCC"),^TMP($J,"IBCRCS") - Q - ; -MAILADD(IBIFN,BTYPE) ; update the bill mailing address: it may be based on the types of charges - ; an outpatient bill may go to either the opt or rx mailing addresses depending on the types of charges - N DA,IB01,IB02 - I $G(BTYPE)>2,+$G(IBIFN),$D(^IBA(362.4,"C",+IBIFN)),+$$CHGTYPE^IBCU(+IBIFN)=3 S DA=IBIFN D MAILA^IBCU5 D - . I '$D(ZTQUEUED),'$G(IBAUTO) W !!,"Updating Bill Mailing Address" - Q - ; -BILLITEM(IBIFN,IBITMARR) ; add selected unassociated item charges to the bill - N IBRS,IBCS,IBBEVNT K ^TMP($J,"IBCRCC"),^TMP($J,"IBCRCS") - ; - S IBRS=0 F S IBRS=$O(IBITMARR(IBRS)) Q:'IBRS D - . S IBCS=0 F S IBCS=$O(IBITMARR(IBRS,IBCS)) Q:'IBCS D - .. S IBBEVNT=+$P($G(^IBE(363.1,+IBCS,0)),U,3) Q:'IBBEVNT S IBBEVNT=$$EMUTL^IBCRU1(IBBEVNT) Q:IBBEVNT="" - .. ; - .. I IBBEVNT["UNASSOCIATED" D UNASSOC^IBCRBC11(IBIFN,IBRS,IBCS,.IBITMARR) - ; - I $D(^TMP($J,"IBCRCC")) D SORTCI^IBCRBC3 - ; - I $D(^TMP($J,"IBCRCS")) D ADDBCHGS^IBCRBC3(IBIFN) - ; - K ^TMP($J,"IBCRCC"),^TMP($J,"IBCRCS") - Q - ; - ; - ; - ; There are 3 types of charges/items: - ; - ITEM: charge for an individual item: specific item has one or more charge entries in 363.2 - ; for the charge to be applied to the bill the specific item must be found on the bill - ; - ; - EVENT: charge for an event, not an item: items are defined in 363.2 - ; all charge items active on a date in the set define the charge for the event - ; the item does not need to be defined on the bill for the charge to be applied to the bill - ; the charge set on a date becomes the events charge, so effective date cuts across item and applies to event - ; all charge items with the same effective date are used to calculate the event charge for that date - ; each charge item effective date in the set overrides all previous entries in the set regardless of item - ; - ; - VA COST: charge for an individual item but no entries in 363.2 - ; instead the charge is calculated/obtained when it is needed from an interface with the source package - ; - ; - ; Auto calculation and filing of a bills charges - ; - ; IBCRBC (BILL) - determine if charges can be calculated and which rates (RS/CS) should be used - ; then find billable items/events, calculate and store the charges - ; called anytime a bills charges need to be updated - ; - ; IBCRBC1 (event) - gather billable items/events for each billable event type - ; then accumulate all charges for the bill for each billable event/item - ; - ; IBCRCGx (event) - pull billable items/events from the bill - ; IBCRBC2 (BITMCHRG) - calculate charges for billable item/event - ; - ; IBCRBC3 (SORTCI) - sort accumulated charges into order to store on bill, combine if possible - ; IBCRBC3 (ADDBCHRGS) - store the sorted accumulated charges on the bill - ; - ; - ; The Billable Event of the Charge Set is directly related to the Type of charge assigned - ; to the charges calculated for that Charge Set. So, Billable Event (363.1,.03) <-> Type (399,42,.1) - ; - ; - ; ^TMP($J,"IBCRCC") - array containing raw charges for a bill and related data, created in IBRCBC2 - ; ^TMP($J,"IBCRCC",X) = 1 charge item ifn - ; 2 charge set ifn - ; 3 rate schedule ifn - ; 4 item ptr (to source) - ; 5 cpt modifier ptr - ; 6 revenue code ptr - ; 7 billable bedsection (bill) - ; 8 event date (visit or st from or admission) - ; 9 charge per unit/qty - ; 10 units/qty (qty of item) - ; 11 total charge per unit/qty - ; 12 adjusted total charge per unit/qty - ; 13 units (# item on bill) - ; 14 CPT ptr - ; 15 division ptr - ; 16 item type (source) - ; 17 item ptr (to source) - ; 18 charge component - ; 19 billable bedsection (for item) - ; 20 procedure provider - ; 21 procedures associated clinic - ; 22 procedures Outpatient Encounter, pointer to #409.68 - ; 23 list of all the procedures modifiers, separated by ',' - ; - ; ^TMP($J,"IBCRCC",X,"CC",x) = comments explaining charge adjustements - ; - ; ^TMP($J,"IBCRCS") - array of charges from IBCRCC in sorted order and with only data needed to save on bill - ; ^TMP($J,"IBCRCS", BS, RV, X) = 1 revenue code ptr - ; 2 bedsection ptr - ; 3 charge per units (adjusted total charge) - ; 4 units (# item on bill) - ; 5 CPT ptr - ; 6 division ptr - ; 7 item type - ; 8 item ptr - ; 9 charge component - ; - ; - ; - ; Inpatient Bill Dates use follow rules: - ; - admission date is counted as billable - ; - the discharge date is not billable and is not counted - ; - ; - if admission movement is found in the Patient Movement file then the dates of admission and discharge - ; will be used as the outside limits of the LOS, even if date range of the bill is longer (LOS^IBCU64) - ; - ; - a day is counted as billable to the bedsection the patient was in at the end of the day (ie. counted - ; in LOS of next movement after midnight) - ; - if there is a movement on any given date that date is included in the LOS of the bedsection the patient - ; moved into (same as admission date) - ; - if there is a movement on any given date that date is NOT included in the LOS of the bedsection the - ; patient moved out of (same as discharge date) - ; - ; - if the time frame of the bill is: - ; - either interim-first or interim-continuous the last date on the bill should be billed - ; - if the last date is counted it is added to the LOS of the bedsection the patient was in at the end - ; of the day - ; - either NOT interim-first or interim-continuous (final bills) the last date on the bill - ; should NOT be billed (i.e. this is considered the discharge date) - ; - ; - start with first bedsection after begin date, day is counted in the bedsection the patient is in at midnight - ; - continuous: last bedsection counted is the bedsection the patient is in at midnight of the end date - ; - final:last bedsection counted is the bedsection the patient is in at midnight of the day before the end date - ; +IBCRBC ;ALB/ARH - RATES: BILL CALCULATION OF CHARGES ; 22-MAY-1996 + ;;2.0;INTEGRATED BILLING;**52,80,106,51,137,245**;21-MAR-94 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; + ; Variable DGPTUPDT may be defined on entry/exit for inpt bills so the PTF will only be updated once per session + ; Charges may be filed on the bill and if IBRSARR is passed but does not exist it may be updated + ; otherwise there are no other outputs/results of this call. + ; +BILL(IBIFN,IBRSARR) ; given a bill number calculate and store all charges + ; if IBRSARR is defined it will be used to create charges rather than the standard set for the bills Rate Type + ; + N IB0,IBU,IBBRT,IBBTYPE,IBCTYPE,DFN,PTF,IBDGPT,IBRS,IBCS,IBBEVNT Q:'$G(IBIFN) + K ^TMP($J,"IBCRCC"),^TMP($J,"IBCRCS") + ; + S IB0=$G(^DGCR(399,+IBIFN,0)) Q:IB0="" S IBU=$G(^DGCR(399,+IBIFN,"U")) Q:'IBU + S IBBRT=+$P(IB0,U,7),IBBTYPE=$S($$INPAT^IBCEF(IBIFN):1,1:3),IBCTYPE=+$P(IB0,U,27),DFN=$P(IB0,U,2) Q:'DFN + ; + ; if who's responsible is insurer, but bill has no insurer defined quit + I $P(IB0,U,11)="i",'$G(^DGCR(399,+IBIFN,"MP")),'$$MCRWNR^IBEFUNC(+$$CURR^IBCEF2(IBIFN)) Q + ; + ; if inpt bill, PTF Status is Open, not a Fee Basis record and not previously done then Update the PTF record + I IBBTYPE<3,'$D(DGPTUPDT) S PTF=$P(IB0,U,8) Q:'PTF S IBDGPT=$G(^DGPT(+PTF,0)) Q:IBDGPT="" D + . I '$P(IBDGPT,U,6),'$P(IBDGPT,U,4) D UPDT^DGPTUTL S DGPTUPDT="" + ; + ; + D DSPDL^IBCRBC3,DELALLRC^IBCRBF(IBIFN) ; delete all existing auto charges on the bill + ; + ; get standard set of all rate schedules and charge sets available for entire date range of the bill + I '$D(IBRSARR) D RT^IBCRU3(IBBRT,IBBTYPE,$P(IBU,U,1,2),.IBRSARR,"",IBCTYPE) I 'IBRSARR G END + ; + ; process charge sets - set all charges for the bill into array + S IBRS=0 F S IBRS=$O(IBRSARR(IBRS)) Q:'IBRS D + . S IBCS=0 F S IBCS=$O(IBRSARR(IBRS,IBCS)) Q:'IBCS I +IBRSARR(IBRS,IBCS) D + .. S IBBEVNT=+$P($G(^IBE(363.1,+IBCS,0)),U,3) Q:'IBBEVNT S IBBEVNT=$$EMUTL^IBCRU1(IBBEVNT) Q:IBBEVNT="" + .. ; + .. I IBBEVNT["INPATIENT BEDSECTION STAY" D INPTBS^IBCRBC1(IBIFN,IBRS,IBCS) + .. I IBBEVNT["INPATIENT DRG" D INPTDRG^IBCRBC11(IBIFN,IBRS,IBCS) + .. I IBBEVNT["OUTPATIENT VISIT DATE" D OPTVST^IBCRBC1(IBIFN,IBRS,IBCS) + .. I IBBEVNT["PRESCRIPTION" D RX^IBCRBC1(IBIFN,IBRS,IBCS) + .. I IBBEVNT["PROSTHETICS" D PI^IBCRBC1(IBIFN,IBRS,IBCS) + .. I IBBEVNT["PROCEDURE" D CPT^IBCRBC1(IBIFN,IBRS,IBCS) + ; + I '$D(^TMP($J,"IBCRCC")) G END + ; + D MULTCPT^IBCRBCA1 ; adjust charges for Multiple Surgical Procedure Discount + D PSB^IBCRBCA2 ; adjust charges for Primary/Secondary Bundling + D MODADJ^IBCRBCA3 ; adjust charges for Modifier Adjustment + ; + D SORTCI^IBCRBC3 I '$D(^TMP($J,"IBCRCS")) G END + ; + D ADDBCHGS^IBCRBC3(IBIFN) + ; + D MAILADD(IBIFN,IBBTYPE) + ; +END I $D(^TMP("IBCRRX",$J)) D CLEANRX^IBCRBC3(IBIFN) + K ^TMP($J,"IBCRCC"),^TMP($J,"IBCRCS") + Q + ; +MAILADD(IBIFN,BTYPE) ; update the bill mailing address: it may be based on the types of charges + ; an outpatient bill may go to either the opt or rx mailing addresses depending on the types of charges + N DA,IB01,IB02 + I $G(BTYPE)>2,+$G(IBIFN),$D(^IBA(362.4,"C",+IBIFN)),+$$CHGTYPE^IBCU(+IBIFN)=3 S DA=IBIFN D MAILA^IBCU5 D + . I '$D(ZTQUEUED),'$G(IBAUTO) W !!,"Updating Bill Mailing Address" + Q + ; +BILLITEM(IBIFN,IBITMARR) ; add selected unassociated item charges to the bill + N IBRS,IBCS,IBBEVNT K ^TMP($J,"IBCRCC"),^TMP($J,"IBCRCS") + ; + S IBRS=0 F S IBRS=$O(IBITMARR(IBRS)) Q:'IBRS D + . S IBCS=0 F S IBCS=$O(IBITMARR(IBRS,IBCS)) Q:'IBCS D + .. S IBBEVNT=+$P($G(^IBE(363.1,+IBCS,0)),U,3) Q:'IBBEVNT S IBBEVNT=$$EMUTL^IBCRU1(IBBEVNT) Q:IBBEVNT="" + .. ; + .. I IBBEVNT["UNASSOCIATED" D UNASSOC^IBCRBC11(IBIFN,IBRS,IBCS,.IBITMARR) + ; + I $D(^TMP($J,"IBCRCC")) D SORTCI^IBCRBC3 + ; + I $D(^TMP($J,"IBCRCS")) D ADDBCHGS^IBCRBC3(IBIFN) + ; + K ^TMP($J,"IBCRCC"),^TMP($J,"IBCRCS") + Q + ; + ; + ; + ; There are 3 types of charges/items: + ; - ITEM: charge for an individual item: specific item has one or more charge entries in 363.2 + ; for the charge to be applied to the bill the specific item must be found on the bill + ; + ; - EVENT: charge for an event, not an item: items are defined in 363.2 + ; all charge items active on a date in the set define the charge for the event + ; the item does not need to be defined on the bill for the charge to be applied to the bill + ; the charge set on a date becomes the events charge, so effective date cuts across item and applies to event + ; all charge items with the same effective date are used to calculate the event charge for that date + ; each charge item effective date in the set overrides all previous entries in the set regardless of item + ; + ; - VA COST: charge for an individual item but no entries in 363.2 + ; instead the charge is calculated/obtained when it is needed from an interface with the source package + ; + ; + ; Auto calculation and filing of a bills charges + ; + ; IBCRBC (BILL) - determine if charges can be calculated and which rates (RS/CS) should be used + ; then find billable items/events, calculate and store the charges + ; called anytime a bills charges need to be updated + ; + ; IBCRBC1 (event) - gather billable items/events for each billable event type + ; then accumulate all charges for the bill for each billable event/item + ; + ; IBCRCGx (event) - pull billable items/events from the bill + ; IBCRBC2 (BITMCHRG) - calculate charges for billable item/event + ; + ; IBCRBC3 (SORTCI) - sort accumulated charges into order to store on bill, combine if possible + ; IBCRBC3 (ADDBCHRGS) - store the sorted accumulated charges on the bill + ; + ; + ; The Billable Event of the Charge Set is directly related to the Type of charge assigned + ; to the charges calculated for that Charge Set. So, Billable Event (363.1,.03) <-> Type (399,42,.1) + ; + ; + ; ^TMP($J,"IBCRCC") - array containing raw charges for a bill and related data, created in IBRCBC2 + ; ^TMP($J,"IBCRCC",X) = 1 charge item ifn + ; 2 charge set ifn + ; 3 rate schedule ifn + ; 4 item ptr (to source) + ; 5 cpt modifier ptr + ; 6 revenue code ptr + ; 7 billable bedsection (bill) + ; 8 event date (visit or st from or admission) + ; 9 charge per unit/qty + ; 10 units/qty (qty of item) + ; 11 total charge per unit/qty + ; 12 adjusted total charge per unit/qty + ; 13 units (# item on bill) + ; 14 CPT ptr + ; 15 division ptr + ; 16 item type (source) + ; 17 item ptr (to source) + ; 18 charge component + ; 19 billable bedsection (for item) + ; 20 procedure provider + ; 21 procedures associated clinic + ; 22 procedures Outpatient Encounter, pointer to #409.68 + ; + ; ^TMP($J,"IBCRCC",X,"CC",x) = comments explaining charge adjustements + ; + ; ^TMP($J,"IBCRCS") - array of charges from IBCRCC in sorted order and with only data needed to save on bill + ; ^TMP($J,"IBCRCS", BS, RV, X) = 1 revenue code ptr + ; 2 bedsection ptr + ; 3 charge per units (adjusted total charge) + ; 4 units (# item on bill) + ; 5 CPT ptr + ; 6 division ptr + ; 7 item type + ; 8 item ptr + ; 9 charge component + ; + ; + ; + ; Inpatient Bill Dates use follow rules: + ; - admission date is counted as billable + ; - the discharge date is not billable and is not counted + ; + ; - if admission movement is found in the Patient Movement file then the dates of admission and discharge + ; will be used as the outside limits of the LOS, even if date range of the bill is longer (LOS^IBCU64) + ; + ; - a day is counted as billable to the bedsection the patient was in at the end of the day (ie. counted + ; in LOS of next movement after midnight) + ; - if there is a movement on any given date that date is included in the LOS of the bedsection the patient + ; moved into (same as admission date) + ; - if there is a movement on any given date that date is NOT included in the LOS of the bedsection the + ; patient moved out of (same as discharge date) + ; + ; - if the time frame of the bill is: + ; - either interim-first or interim-continuous the last date on the bill should be billed + ; - if the last date is counted it is added to the LOS of the bedsection the patient was in at the end + ; of the day + ; - either NOT interim-first or interim-continuous (final bills) the last date on the bill + ; should NOT be billed (i.e. this is considered the discharge date) + ; + ; - start with first bedsection after begin date, day is counted in the bedsection the patient is in at midnight + ; - continuous: last bedsection counted is the bedsection the patient is in at midnight of the end date + ; - final:last bedsection counted is the bedsection the patient is in at midnight of the day before the end date + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBC1.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBC1.m index 822c0aaa..1e432cac 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBC1.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBC1.m @@ -1,178 +1,178 @@ -IBCRBC1 ;ALB/ARH - RATES: BILL CALCULATION BILLABLE EVENTS ; 22 MAY 96 - ;;2.0;INTEGRATED BILLING;**52,80,106,138,51,148,245,270,370**;21-MAR-94;Build 5 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ; For each type of Billable Event, search for items on the bill and calculate the charges - ; 1) search the bill for items of the billable event type - ; 2) determine how the charges should be calculated, based on Billable Item and Charge Method of the Set's Rate - ; 3) calculate charges - ; For per diem Billing Rates, no item pointers are passed since all items have a standard charge - ; The Insurance Company Different Revenue Codes to Use (36,.07) is passed so standard rev codes can be replaced - ; The Charge Type (363.1,.04) is passed so it can be added to the charge on the bill if it is defined for a Set - ; Output: ^TMP($J,"IBCRCC")= ..., (created in IBCRBC2 based on charge items found here) - ; -INPTBS(IBIFN,RS,CS) ; Determine charges for INPATIENT BEDSECTION STAY billable events - ; - the billable events are billable bedsections based on the patient movement treating specialties, - ; these are pulled from the PTF record each time the charges are calculated (INPTPTF^IBCRCG) - ; - each day of billable care is calculated separately in case a rate becomes inactive - ; - N IBX,IBBLITEM,IBCHGMTH,IBEVDT,IBIDRC,IBBDIV,IBITM,IBDIV,IBTYPE,IBCMPNT,IBSAVE I '$G(IBIFN)!'$G(CS) Q - ; - D INPTPTF^IBCRBG(IBIFN,CS) - ; - S IBTYPE=1,IBCMPNT=$P($G(^IBE(363.1,+CS,0)),U,4),IBX=$$CSBR^IBCRU3(CS),IBBLITEM=$P(IBX,U,4),IBCHGMTH=$P(IBX,U,5) - S IBIDRC=+$G(^DGCR(399,+IBIFN,"MP")) - I 'IBIDRC,$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)) S IBIDRC=$$CURR^IBCEF2(IBIFN) - S IBIDRC=$G(^DIC(36,+IBIDRC,0)),IBIDRC=$P(IBIDRC,U,7) - ; - S IBBDIV=$P($G(^DGCR(399,+IBIFN,0)),U,22) ; bill's default division - ; - I IBBLITEM=1,IBCHGMTH=1 D ; inpt/bedsection/per diem - . S IBEVDT="" F S IBEVDT=$O(^TMP($J,"IBCRC-INDT",IBEVDT)) Q:'IBEVDT D - .. S IBX=$G(^TMP($J,"IBCRC-INDT",IBEVDT)),IBITM=+$P(IBX,U,2),IBDIV=$P(IBX,U,5) - .. ; - .. I $$CSDV^IBCRU3(CS,IBDIV,IBBDIV)<0 Q ; check division - .. ; - .. S IBSAVE="1^^"_IBDIV_"^"_IBTYPE_"^^"_IBCMPNT - .. D BITMCHG^IBCRBC2(RS,CS,IBITM,IBEVDT,1,"","",IBIDRC,IBSAVE) - K ^TMP($J,"IBCRC-INDT") - Q - ; -OPTVST(IBIFN,RS,CS) ; Determine charges for OUTPATIENT VISIT DATE billable events - ; - the billable event is the outpatient visit date(s) on the bill (399,43) - ; - N IBX,IBBLITEM,IBCHGMTH,IBIDRC,IBOPVARR,IBI,IBEVDT,IBTYPE,IBCMPNT,IBSAVE I '$G(IBIFN)!'$G(CS) Q - ; - D OPTVD^IBCRBG1(IBIFN,.IBOPVARR) Q:'IBOPVARR - ; - S IBTYPE=2,IBCMPNT=$P($G(^IBE(363.1,+CS,0)),U,4),IBX=$$CSBR^IBCRU3(CS),IBBLITEM=$P(IBX,U,4),IBCHGMTH=$P(IBX,U,5) - S IBIDRC=+$G(^DGCR(399,+IBIFN,"MP")) - I 'IBIDRC,$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)) S IBIDRC=$$CURR^IBCEF2(IBIFN) - S IBIDRC=$G(^DIC(36,+IBIDRC,0)),IBIDRC=$P(IBIDRC,U,7) - ; - I IBBLITEM=1,IBCHGMTH=1 D ; opt vst/bedsection/per diem - . S IBI="" F S IBI=$O(IBOPVARR(IBI)) Q:IBI="" D - .. S IBEVDT=IBOPVARR(IBI) - .. S IBSAVE="1^^^"_IBTYPE_"^^"_IBCMPNT - .. D ALLBEDS^IBCRBC2(RS,CS,IBEVDT,"",IBIDRC,IBSAVE) - Q - ; -RX(IBIFN,RS,CS) ; Determine charges for PRESCRIPTION billable events - ; - the billable event is an rx that has been added to the bill (362.4) - ; - the insurance company Prescription Refill Rev Code (36,.15) is passed to the calculator to be used as - ; the rev code for all Rx charges, all types, this overrides the rev codes for the set or item - ; - on HCFA 1500, the site parameter Default Rx Refill CPT (350.9,1.3) is added as the CPT to all Rx RC entries - ; - N IBX,IBBLITEM,IBCHGMTH,IBRXCPT,IBIDRC,IBIRC,IBRXARR,IBRX,IBEVDT,IBUNIT,IBITM,IBNDC,IBTYPE,IBCMPNT,IBSAVE - I '$G(IBIFN)!'$G(CS) Q - ; - D SET^IBCSC5A(IBIFN,.IBRXARR) Q:'$P(IBRXARR,U,2) - ; - S IBTYPE=3,IBCMPNT=$P($G(^IBE(363.1,+CS,0)),U,4),IBX=$$CSBR^IBCRU3(CS),IBBLITEM=$P(IBX,U,4),IBCHGMTH=$P(IBX,U,5) - S IBIDRC=+$G(^DGCR(399,+IBIFN,"MP")) - I 'IBIDRC,$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)) S IBIDRC=$$CURR^IBCEF2(IBIFN) - S IBIDRC=$G(^DIC(36,+IBIDRC,0)),IBIRC=$P(IBIDRC,U,15),IBIDRC=$P(IBIDRC,U,7) - ; - S IBRXCPT="" I $$FT^IBCU3(IBIFN)=2 S IBRXCPT=$P($G(^IBE(350.9,1,1)),U,30) - ; - I IBBLITEM=1,IBCHGMTH=1 D ; rx refill/bedsection/per diem - . S IBRX="" F S IBRX=$O(IBRXARR(IBRX)) Q:IBRX="" D - .. S IBEVDT=0 F S IBEVDT=$O(IBRXARR(IBRX,IBEVDT)) Q:'IBEVDT D - ... ; - ... S IBSAVE="1^"_IBRXCPT_"^^"_IBTYPE_"^"_+IBRXARR(IBRX,IBEVDT)_"^"_IBCMPNT - ... D ALLBEDS^IBCRBC2(RS,CS,IBEVDT,IBIRC,IBIDRC,IBSAVE) - ; - I IBBLITEM=3,IBCHGMTH=3 D ; ndc/quantity - . S IBRX="" F S IBRX=$O(IBRXARR(IBRX)) Q:IBRX="" D - .. S IBEVDT=0 F S IBEVDT=$O(IBRXARR(IBRX,IBEVDT)) Q:'IBEVDT D - ... S IBX=IBRXARR(IBRX,IBEVDT),IBITM=+IBX,IBUNIT=$P(IBX,U,4),IBNDC=$P(IBX,U,5) Q:IBNDC="" - ... S IBNDC=$O(^IBA(363.21,"B",IBNDC,0)) Q:'IBNDC - ... S IBSAVE="1^"_IBRXCPT_"^^"_IBTYPE_"^"_IBITM_"^"_IBCMPNT - ... D BITMCHG^IBCRBC2(RS,CS,IBNDC,IBEVDT,IBUNIT,"",IBIRC,IBIDRC,IBSAVE) - ; - I IBCHGMTH=2 D ; va cost - . S IBRX="" F S IBRX=$O(IBRXARR(IBRX)) Q:IBRX="" D - .. S IBEVDT=0 F S IBEVDT=$O(IBRXARR(IBRX,IBEVDT)) Q:'IBEVDT D - ... S IBX=IBRXARR(IBRX,IBEVDT),IBITM=+IBX,IBUNIT=$P(IBX,U,4) Q:'IBITM - ... S IBSAVE="1^"_IBRXCPT_"^^"_IBTYPE_"^"_IBITM_"^"_IBCMPNT - ... D BITMCHG^IBCRBC2(RS,CS,IBITM,IBEVDT,IBUNIT,"",IBIRC,IBIDRC,IBSAVE) - ; - Q - ; -CPT(IBIFN,RS,CS) ; Determine charges for PROCEDURE billable events - ; - the billable event is a CPT procedure from the bill (399,304) - ; - the item to be billed is a CPT, this may include Modifier - ; - for each CPT found on the bill that has a modifier, will first check to see if that CPT-modifier - ; combination is billable (ie. is defined as a charge item for the Billing Rate, does not have to be active) - ; if it does not then assumes the charge should be the CPT charge - ; - if the charge set is limited by region then either the CPT's division or if no CPT division then the bill's - ; Default Division must be contained in the sets region - ; - the billable CPT is added as the CPT of the charge entry, Division is also added if defined for the CPT - ; - the procedures provider may affect the charges due to a provider discount - ; - if an inpatient bill then the bedsection on date of procedure will be used as the default bedsection - ; - different sets of charges apply to SNF and Inpatient care although the bill is defined as inpatient - ; - the Default Rx CPT should not be billed the CPT charge, instead the Rx is charged - ; - N IBX,IBBLITEM,IBCHGMTH,IBBR,IBBDIV,IBIDRC,IBCPTARR,IBCPT,IBCPTFN,IBEVDT,IBMOD,IBDIV,IBTYPE,IBCMPNT - N IBPPRV,IBBS,IBCLIN,IBOE,IBSAVE,IBUNIT,IBCPTRX,IBMODS I '$G(IBIFN)!'$G(CS) Q - ; - D CPT^IBCRBG1(IBIFN,.IBCPTARR) Q:'IBCPTARR - ; - S IBTYPE=4,IBCMPNT=$P($G(^IBE(363.1,+CS,0)),U,4),IBX=$$CSBR^IBCRU3(CS),IBBLITEM=$P(IBX,U,4),IBCHGMTH=$P(IBX,U,5) - S IBIDRC=+$G(^DGCR(399,+IBIFN,"MP")) - I 'IBIDRC,$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)) S IBIDRC=$$CURR^IBCEF2(IBIFN) - S IBIDRC=$G(^DIC(36,+IBIDRC,0)),IBIDRC=$P(IBIDRC,U,7) - S IBBR=$P(IBX,U,3) S IBCPTRX="" I $O(^IBA(362.4,"C",IBIFN,0)) S IBCPTRX=+$P($G(^IBE(350.9,1,1)),U,30) - ; - S IBBDIV=$P($G(^DGCR(399,+IBIFN,0)),U,22) ; bill's default division - D INPTPTF^IBCRBG(IBIFN,CS) ; get inpatient bedsections - ; - I IBBLITEM=2 D ; cpt/count/minutes/miles/hours - . S IBCPT=0 F S IBCPT=$O(IBCPTARR(IBCPT)) Q:'IBCPT D - .. S IBCPTFN=0 F S IBCPTFN=$O(IBCPTARR(IBCPT,IBCPTFN)) Q:'IBCPTFN D - ... S IBX=IBCPTARR(IBCPT,IBCPTFN),IBEVDT=$P(IBX,U,1),(IBMOD,IBMODS)=$P(IBX,U,2) - ... S IBDIV=$P(IBX,U,3),IBPPRV=$P(IBX,U,4),IBCLIN=$P(IBX,U,5),IBOE=$P(IBX,U,6) - ... ; - ... I '$$CHGOTH^IBCRBC2(IBIFN,RS,IBEVDT) Q - ... I +IBCPTRX,'IBOE,IBCPT=IBCPTRX Q ; site parameter rx procedure - ... ; - ... S IBUNIT=$$CPTUNITS^IBCRBC2(CS,IBCHGMTH,IBX) Q:'IBUNIT - ... ; - ... S IBBS=$P($G(^TMP($J,"IBCRC-INDT",IBEVDT)),U,2) ; get inpatient bedsection - ... I 'IBBS S IBX=$O(^TMP($J,"IBCRC-INDT",IBEVDT),-1) I +IBX S IBBS=$P($G(^TMP($J,"IBCRC-INDT",IBX)),U,2) - ... ; - ... I '$P($$CPT^ICPTCOD(+IBCPT,+IBEVDT),U,7) Q ; check is a valid active CPT - ... I $$CSDV^IBCRU3(CS,IBDIV,IBBDIV)<0 Q ; check division - ... I +IBMOD S IBMOD=$P($$CPTMOD^IBCRCU1(CS,IBCPT,IBMOD,IBEVDT),",",1) ; check CPT-MODs for billable combination - ... ; - ... S IBSAVE="1^"_IBCPT_U_IBDIV_U_IBTYPE_U_IBCPTFN_U_IBCMPNT_U_IBBS_U_IBPPRV_U_IBCLIN_U_IBOE_U_IBMODS - ... D BITMCHG^IBCRBC2(RS,CS,IBCPT,IBEVDT,IBUNIT,IBMOD,"",IBIDRC,IBSAVE) - K ^TMP($J,"IBCRC-INDT") - Q - ; -PI(IBIFN,RS,CS) ; Determine charges for PROSTHETICS billable events - ; - the billable event is a prosthetic item that has been added to the bill (362.5) - ; - N IBX,IBBLITEM,IBCHGMTH,IBPIARR,IBIDRC,IBEVDT,IBPI,IBITM,IBTYPE,IBCMPNT,IBSAVE I '$G(IBIFN)!'$G(CS) Q - ; - D SET^IBCSC5B(IBIFN,.IBPIARR) Q:'$P(IBPIARR,U,2) - ; - S IBTYPE=5,IBCMPNT=$P($G(^IBE(363.1,+CS,0)),U,4),IBX=$$CSBR^IBCRU3(CS),IBBLITEM=$P(IBX,U,4),IBCHGMTH=$P(IBX,U,5) - S IBIDRC=+$G(^DGCR(399,+IBIFN,"MP")) - I 'IBIDRC,$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)) S IBIDRC=$$CURR^IBCEF2(IBIFN) - S IBIDRC=$G(^DIC(36,+IBIDRC,0)),IBIDRC=$P(IBIDRC,U,7) - ; - I IBBLITEM=1,IBCHGMTH=1 D ; pros/bedsection/per diem - . S IBEVDT="" F S IBEVDT=$O(IBPIARR(IBEVDT)) Q:'IBEVDT D - .. S IBPI=0 F S IBPI=$O(IBPIARR(IBEVDT,IBPI)) Q:'IBPI D - ... S IBSAVE="1^^^"_IBTYPE_"^^"_IBCMPNT - ... D ALLBEDS^IBCRBC2(RS,CS,IBEVDT,"",IBIDRC,IBSAVE) - ; - I IBCHGMTH=2 D ; va cost - . S IBEVDT="" F S IBEVDT=$O(IBPIARR(IBEVDT)) Q:'IBEVDT D - .. S IBPI=0 F S IBPI=$O(IBPIARR(IBEVDT,IBPI)) Q:'IBPI D - ... S IBITM=IBPIARR(IBEVDT,IBPI) Q:'IBITM - ... S IBSAVE="1^^^"_IBTYPE_"^"_+IBITM_"^"_IBCMPNT - ... D BITMCHG^IBCRBC2(RS,CS,+IBITM,IBEVDT,1,"","",IBIDRC,IBSAVE) - ; - Q +IBCRBC1 ;ALB/ARH - RATES: BILL CALCULATION BILLABLE EVENTS ; 22 MAY 96 + ;;2.0;INTEGRATED BILLING;**52,80,106,138,51,148,245,270**;21-MAR-94 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; + ; For each type of Billable Event, search for items on the bill and calculate the charges + ; 1) search the bill for items of the billable event type + ; 2) determine how the charges should be calculated, based on Billable Item and Charge Method of the Set's Rate + ; 3) calculate charges + ; For per diem Billing Rates, no item pointers are passed since all items have a standard charge + ; The Insurance Company Different Revenue Codes to Use (36,.07) is passed so standard rev codes can be replaced + ; The Charge Type (363.1,.04) is passed so it can be added to the charge on the bill if it is defined for a Set + ; Output: ^TMP($J,"IBCRCC")= ..., (created in IBCRBC2 based on charge items found here) + ; +INPTBS(IBIFN,RS,CS) ; Determine charges for INPATIENT BEDSECTION STAY billable events + ; - the billable events are billable bedsections based on the patient movement treating specialties, + ; these are pulled from the PTF record each time the charges are calculated (INPTPTF^IBCRCG) + ; - each day of billable care is calculated separately in case a rate becomes inactive + ; + N IBX,IBBLITEM,IBCHGMTH,IBEVDT,IBIDRC,IBBDIV,IBITM,IBDIV,IBTYPE,IBCMPNT,IBSAVE I '$G(IBIFN)!'$G(CS) Q + ; + D INPTPTF^IBCRBG(IBIFN,CS) + ; + S IBTYPE=1,IBCMPNT=$P($G(^IBE(363.1,+CS,0)),U,4),IBX=$$CSBR^IBCRU3(CS),IBBLITEM=$P(IBX,U,4),IBCHGMTH=$P(IBX,U,5) + S IBIDRC=+$G(^DGCR(399,+IBIFN,"MP")) + I 'IBIDRC,$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)) S IBIDRC=$$CURR^IBCEF2(IBIFN) + S IBIDRC=$G(^DIC(36,+IBIDRC,0)),IBIDRC=$P(IBIDRC,U,7) + ; + S IBBDIV=$P($G(^DGCR(399,+IBIFN,0)),U,22) ; bill's default division + ; + I IBBLITEM=1,IBCHGMTH=1 D ; inpt/bedsection/per diem + . S IBEVDT="" F S IBEVDT=$O(^TMP($J,"IBCRC-INDT",IBEVDT)) Q:'IBEVDT D + .. S IBX=$G(^TMP($J,"IBCRC-INDT",IBEVDT)),IBITM=+$P(IBX,U,2),IBDIV=$P(IBX,U,5) + .. ; + .. I $$CSDV^IBCRU3(CS,IBDIV,IBBDIV)<0 Q ; check division + .. ; + .. S IBSAVE="1^^"_IBDIV_"^"_IBTYPE_"^^"_IBCMPNT + .. D BITMCHG^IBCRBC2(RS,CS,IBITM,IBEVDT,1,"","",IBIDRC,IBSAVE) + K ^TMP($J,"IBCRC-INDT") + Q + ; +OPTVST(IBIFN,RS,CS) ; Determine charges for OUTPATIENT VISIT DATE billable events + ; - the billable event is the outpatient visit date(s) on the bill (399,43) + ; + N IBX,IBBLITEM,IBCHGMTH,IBIDRC,IBOPVARR,IBI,IBEVDT,IBTYPE,IBCMPNT,IBSAVE I '$G(IBIFN)!'$G(CS) Q + ; + D OPTVD^IBCRBG1(IBIFN,.IBOPVARR) Q:'IBOPVARR + ; + S IBTYPE=2,IBCMPNT=$P($G(^IBE(363.1,+CS,0)),U,4),IBX=$$CSBR^IBCRU3(CS),IBBLITEM=$P(IBX,U,4),IBCHGMTH=$P(IBX,U,5) + S IBIDRC=+$G(^DGCR(399,+IBIFN,"MP")) + I 'IBIDRC,$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)) S IBIDRC=$$CURR^IBCEF2(IBIFN) + S IBIDRC=$G(^DIC(36,+IBIDRC,0)),IBIDRC=$P(IBIDRC,U,7) + ; + I IBBLITEM=1,IBCHGMTH=1 D ; opt vst/bedsection/per diem + . S IBI="" F S IBI=$O(IBOPVARR(IBI)) Q:IBI="" D + .. S IBEVDT=IBOPVARR(IBI) + .. S IBSAVE="1^^^"_IBTYPE_"^^"_IBCMPNT + .. D ALLBEDS^IBCRBC2(RS,CS,IBEVDT,"",IBIDRC,IBSAVE) + Q + ; +RX(IBIFN,RS,CS) ; Determine charges for PRESCRIPTION billable events + ; - the billable event is an rx that has been added to the bill (362.4) + ; - the insurance company Prescription Refill Rev Code (36,.15) is passed to the calculator to be used as + ; the rev code for all Rx charges, all types, this overrides the rev codes for the set or item + ; - on HCFA 1500, the site parameter Default Rx Refill CPT (350.9,1.3) is added as the CPT to all Rx RC entries + ; + N IBX,IBBLITEM,IBCHGMTH,IBRXCPT,IBIDRC,IBIRC,IBRXARR,IBRX,IBEVDT,IBUNIT,IBITM,IBNDC,IBTYPE,IBCMPNT,IBSAVE + I '$G(IBIFN)!'$G(CS) Q + ; + D SET^IBCSC5A(IBIFN,.IBRXARR) Q:'$P(IBRXARR,U,2) + ; + S IBTYPE=3,IBCMPNT=$P($G(^IBE(363.1,+CS,0)),U,4),IBX=$$CSBR^IBCRU3(CS),IBBLITEM=$P(IBX,U,4),IBCHGMTH=$P(IBX,U,5) + S IBIDRC=+$G(^DGCR(399,+IBIFN,"MP")) + I 'IBIDRC,$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)) S IBIDRC=$$CURR^IBCEF2(IBIFN) + S IBIDRC=$G(^DIC(36,+IBIDRC,0)),IBIRC=$P(IBIDRC,U,15),IBIDRC=$P(IBIDRC,U,7) + ; + S IBRXCPT="" I $$FT^IBCU3(IBIFN)=2 S IBRXCPT=$P($G(^IBE(350.9,1,1)),U,30) + ; + I IBBLITEM=1,IBCHGMTH=1 D ; rx refill/bedsection/per diem + . S IBRX="" F S IBRX=$O(IBRXARR(IBRX)) Q:IBRX="" D + .. S IBEVDT=0 F S IBEVDT=$O(IBRXARR(IBRX,IBEVDT)) Q:'IBEVDT D + ... ; + ... S IBSAVE="1^"_IBRXCPT_"^^"_IBTYPE_"^"_+IBRXARR(IBRX,IBEVDT)_"^"_IBCMPNT + ... D ALLBEDS^IBCRBC2(RS,CS,IBEVDT,IBIRC,IBIDRC,IBSAVE) + ; + I IBBLITEM=3,IBCHGMTH=3 D ; ndc/quantity + . S IBRX="" F S IBRX=$O(IBRXARR(IBRX)) Q:IBRX="" D + .. S IBEVDT=0 F S IBEVDT=$O(IBRXARR(IBRX,IBEVDT)) Q:'IBEVDT D + ... S IBX=IBRXARR(IBRX,IBEVDT),IBITM=+IBX,IBUNIT=$P(IBX,U,4),IBNDC=$P(IBX,U,5) Q:IBNDC="" + ... S IBNDC=$O(^IBA(363.21,"B",IBNDC,0)) Q:'IBNDC + ... S IBSAVE="1^"_IBRXCPT_"^^"_IBTYPE_"^"_IBITM_"^"_IBCMPNT + ... D BITMCHG^IBCRBC2(RS,CS,IBNDC,IBEVDT,IBUNIT,"",IBIRC,IBIDRC,IBSAVE) + ; + I IBCHGMTH=2 D ; va cost + . S IBRX="" F S IBRX=$O(IBRXARR(IBRX)) Q:IBRX="" D + .. S IBEVDT=0 F S IBEVDT=$O(IBRXARR(IBRX,IBEVDT)) Q:'IBEVDT D + ... S IBX=IBRXARR(IBRX,IBEVDT),IBITM=+IBX,IBUNIT=$P(IBX,U,4) Q:'IBITM + ... S IBSAVE="1^"_IBRXCPT_"^^"_IBTYPE_"^"_IBITM_"^"_IBCMPNT + ... D BITMCHG^IBCRBC2(RS,CS,IBITM,IBEVDT,IBUNIT,"",IBIRC,IBIDRC,IBSAVE) + ; + Q + ; +CPT(IBIFN,RS,CS) ; Determine charges for PROCEDURE billable events + ; - the billable event is a CPT procedure from the bill (399,304) + ; - the item to be billed is a CPT, this may include Modifier + ; - for each CPT found on the bill that has a modifier, will first check to see if that CPT-modifier + ; combination is billable (ie. is defined as a charge item for the Billing Rate, does not have to be active) + ; if it does not then assumes the charge should be the CPT charge + ; - if the charge set is limited by region then either the CPT's division or if no CPT division then the bill's + ; Default Division must be contained in the sets region + ; - the billable CPT is added as the CPT of the charge entry, Division is also added if defined for the CPT + ; - the procedures provider may affect the charges due to a provider discount + ; - if an inpatient bill then the bedsection on date of procedure will be used as the default bedsection + ; - different sets of charges apply to SNF and Inpatient care although the bill is defined as inpatient + ; - the Default Rx CPT should not be billed the CPT charge, instead the Rx is charged + ; + N IBX,IBBLITEM,IBCHGMTH,IBBR,IBBDIV,IBIDRC,IBCPTARR,IBCPT,IBCPTFN,IBEVDT,IBMOD,IBDIV,IBTYPE,IBCMPNT + N IBPPRV,IBBS,IBCLIN,IBOE,IBSAVE,IBUNIT,IBCPTRX I '$G(IBIFN)!'$G(CS) Q + ; + D CPT^IBCRBG1(IBIFN,.IBCPTARR) Q:'IBCPTARR + ; + S IBTYPE=4,IBCMPNT=$P($G(^IBE(363.1,+CS,0)),U,4),IBX=$$CSBR^IBCRU3(CS),IBBLITEM=$P(IBX,U,4),IBCHGMTH=$P(IBX,U,5) + S IBIDRC=+$G(^DGCR(399,+IBIFN,"MP")) + I 'IBIDRC,$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)) S IBIDRC=$$CURR^IBCEF2(IBIFN) + S IBIDRC=$G(^DIC(36,+IBIDRC,0)),IBIDRC=$P(IBIDRC,U,7) + S IBBR=$P(IBX,U,3) S IBCPTRX="" I $O(^IBA(362.4,"C",IBIFN,0)) S IBCPTRX=+$P($G(^IBE(350.9,1,1)),U,30) + ; + S IBBDIV=$P($G(^DGCR(399,+IBIFN,0)),U,22) ; bill's default division + D INPTPTF^IBCRBG(IBIFN,CS) ; get inpatient bedsections + ; + I IBBLITEM=2 D ; cpt/count/minutes/miles/hours + . S IBCPT=0 F S IBCPT=$O(IBCPTARR(IBCPT)) Q:'IBCPT D + .. S IBCPTFN=0 F S IBCPTFN=$O(IBCPTARR(IBCPT,IBCPTFN)) Q:'IBCPTFN D + ... S IBX=IBCPTARR(IBCPT,IBCPTFN),IBEVDT=$P(IBX,U,1),IBMOD=$P(IBX,U,2) + ... S IBDIV=$P(IBX,U,3),IBPPRV=$P(IBX,U,4),IBCLIN=$P(IBX,U,5),IBOE=$P(IBX,U,6) + ... ; + ... I '$$CHGOTH^IBCRBC2(IBIFN,RS,IBEVDT) Q + ... I +IBCPTRX,'IBOE,IBCPT=IBCPTRX Q ; site parameter rx procedure + ... ; + ... S IBUNIT=$$CPTUNITS^IBCRBC2(CS,IBCHGMTH,IBX) Q:'IBUNIT + ... ; + ... S IBBS=$P($G(^TMP($J,"IBCRC-INDT",IBEVDT)),U,2) ; get inpatient bedsection + ... I 'IBBS S IBX=$O(^TMP($J,"IBCRC-INDT",IBEVDT),-1) I +IBX S IBBS=$P($G(^TMP($J,"IBCRC-INDT",IBX)),U,2) + ... ; + ... I '$P($$CPT^ICPTCOD(+IBCPT,+IBEVDT),U,7) Q ; check is a valid active CPT + ... I $$CSDV^IBCRU3(CS,IBDIV,IBBDIV)<0 Q ; check division + ... I +IBMOD S IBMOD=$P($$CPTMOD^IBCRCU1(CS,IBCPT,IBMOD,IBEVDT),",",1) ; check CPT-MODs for billable combination + ... ; + ... S IBSAVE="1^"_IBCPT_U_IBDIV_U_IBTYPE_U_IBCPTFN_U_IBCMPNT_U_IBBS_U_IBPPRV_U_IBCLIN_U_IBOE + ... D BITMCHG^IBCRBC2(RS,CS,IBCPT,IBEVDT,IBUNIT,IBMOD,"",IBIDRC,IBSAVE) + K ^TMP($J,"IBCRC-INDT") + Q + ; +PI(IBIFN,RS,CS) ; Determine charges for PROSTHETICS billable events + ; - the billable event is a prosthetic item that has been added to the bill (362.5) + ; + N IBX,IBBLITEM,IBCHGMTH,IBPIARR,IBIDRC,IBEVDT,IBPI,IBITM,IBTYPE,IBCMPNT,IBSAVE I '$G(IBIFN)!'$G(CS) Q + ; + D SET^IBCSC5B(IBIFN,.IBPIARR) Q:'$P(IBPIARR,U,2) + ; + S IBTYPE=5,IBCMPNT=$P($G(^IBE(363.1,+CS,0)),U,4),IBX=$$CSBR^IBCRU3(CS),IBBLITEM=$P(IBX,U,4),IBCHGMTH=$P(IBX,U,5) + S IBIDRC=+$G(^DGCR(399,+IBIFN,"MP")) + I 'IBIDRC,$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)) S IBIDRC=$$CURR^IBCEF2(IBIFN) + S IBIDRC=$G(^DIC(36,+IBIDRC,0)),IBIDRC=$P(IBIDRC,U,7) + ; + I IBBLITEM=1,IBCHGMTH=1 D ; pros/bedsection/per diem + . S IBEVDT="" F S IBEVDT=$O(IBPIARR(IBEVDT)) Q:'IBEVDT D + .. S IBPI=0 F S IBPI=$O(IBPIARR(IBEVDT,IBPI)) Q:'IBPI D + ... S IBSAVE="1^^^"_IBTYPE_"^^"_IBCMPNT + ... D ALLBEDS^IBCRBC2(RS,CS,IBEVDT,"",IBIDRC,IBSAVE) + ; + I IBCHGMTH=2 D ; va cost + . S IBEVDT="" F S IBEVDT=$O(IBPIARR(IBEVDT)) Q:'IBEVDT D + .. S IBPI=0 F S IBPI=$O(IBPIARR(IBEVDT,IBPI)) Q:'IBPI D + ... S IBITM=IBPIARR(IBEVDT,IBPI) Q:'IBITM + ... S IBSAVE="1^^^"_IBTYPE_"^"_+IBITM_"^"_IBCMPNT + ... D BITMCHG^IBCRBC2(RS,CS,+IBITM,IBEVDT,1,"","",IBIDRC,IBSAVE) + ; + Q diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBC2.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBC2.m index 47f43780..cdd623e7 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBC2.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBC2.m @@ -1,139 +1,136 @@ -IBCRBC2 ;ALB/ARH - RATES: BILL CALCULATION OF ITEM CHARGE ; 22-MAY-1996 - ;;2.0;INTEGRATED BILLING;**52,106,138,148,245,370**;21-MAR-94;Build 5 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ; Input: RS - rate schedule necessary to calculated modified charges - ; CS - required, charge set which defines the charges to calculate - ; ITEM - required, ptr to source item to be billed, type defined by billable item of the rate - ; EVDT - date of event, to be used when searching for a charge effective date, default=DT - ; UNITS - required, used only for Quantity: # of units of Charge Item Charge for each Item - ; MOD - CPT Modifier if any - ; INSRC - special revenue code to use (from ins comp), if any (overrides set and item rv cd) - ; IDFRC - different revenue codes to use, these replace the standard set in CM (DRC:SRC,DRC:SRC) - ; SAVE - serveral data items not needed here but passed on to next step (store) in TMP array: - ; TUNITS - required to add charge to bill, total # of the Item on the bill - ; CPT - default CPT to be added to the bill for the charge - ; DIV - division charges apply to - ; TYPE - type of item being billed - defines the source of the item on the bill - ; ITMPTR - soft pointer to the item on the bill: may be a multiple or file IFN - ; CMPNT - what component of the total charge: institutional or professional - ; BEDS - billable bedsection to use if not a bedsection item, if null uses set default - ; PROV - procedure provider - ; CLINIC - procedures associated clinic - ; IBOE - Outpatient Encounter, pointer to #408.69 - ; MODS - list of all modifiers define for the procedure, separated by ',' - ; - ; Total charge is calculated: X = UNITS * UNIT CHARGE of the item (per unit charge (un-adjusted)) - ; Y = X modified by Rate Schedule Adjustment (per unit charge (adjusted)) - ; the Units are used to calculate the per item charge: 30 pills for an rx, 1 bs per bs - ; and the Tunits are the number of that Item on the bill: 1 rx of 30 pills, 11 days of bs stay - ; - ; Output: TMP($J,"IBCRCC", containing all chargable items and all related info needed to file them on the bill - ; each charge will have it's own entry, nothing combined (12 = per unit charge (adjusted), p13 = Tunits) - ; TMP is not killed on entry so each items charges are compiled and added to existing charges - ; -BITMCHG(RS,CS,ITEM,EVDT,UNITS,MOD,INSRC,IDFRC,SAVE) ; get bill charges for a specific item, rate schedule and charge set and date set into temp array - ; - N IBCS0,IBDRVCD,IBBS,IBCHGARR,IBI,IBCNT,IBLN,IBCI,IBRVCD,IBPPRV,IBCHRG,IBTCHRG,IBRCHRG,IBPCHRG,IBACHRG - N IBMCHRG,IBMODS,IBBASE,IBCOM I '$G(ITEM)!'$G(CS)!'$G(UNITS) Q - ; - S RS=$G(RS),EVDT=$S(+$G(EVDT):+EVDT\1,1:DT),MOD=$G(MOD),INSRC=$G(INSRC),IDFRC=$G(IDFRC),SAVE=$G(SAVE) - S IBCS0=$G(^IBE(363.1,+CS,0)),IBDRVCD=$P(IBCS0,U,5),IBPPRV=$P(SAVE,U,8),IBMODS=$P(SAVE,U,11) - S IBBS=+ITEM I $P($G(^IBE(363.3,+$P(IBCS0,U,2),0)),U,4)'=1 S IBBS=$P(SAVE,U,7) I 'IBBS S IBBS=$P(IBCS0,U,6) - I 'IBBS Q - ; - D ITMCHG^IBCRCC(CS,ITEM,EVDT,MOD,.IBCHGARR) - ; - S IBCNT=+$G(^TMP($J,"IBCRCC")) - S IBI=0 F S IBI=$O(IBCHGARR(IBI)) Q:'IBI D - . S IBLN=IBCHGARR(IBI),IBCI=+IBLN,IBCHRG=$P(IBLN,U,3),(IBPCHRG,IBRCHRG)="" Q:'IBCHRG S IBBASE=$P(IBLN,U,4) - . S IBRVCD=INSRC I 'IBRVCD S IBRVCD=$P(IBLN,U,2) - . I 'IBRVCD S IBRVCD=$P($$RVLNK^IBCRU6(+ITEM,"",+CS),U,2) I 'IBRVCD S IBRVCD=IBDRVCD Q:'IBRVCD - . I +IDFRC,+$P(IDFRC,IBRVCD_":",2) S IBRVCD=+$P(IDFRC,IBRVCD_":",2) Q:IBRVCD'?3N - . ; - . S IBCHRG=IBCHRG*UNITS - . S IBCHRG=IBCHRG+IBBASE - . S IBPCHRG=IBCHRG I +IBPPRV S IBPCHRG=$$PRVCHG^IBCRCC(CS,IBCHRG,IBPPRV,EVDT,ITEM) - . S IBMCHRG=+IBPCHRG I +IBMODS S IBMCHRG=$$MODCHG^IBCRCC(CS,IBPCHRG,IBMODS) - . S (IBCHRG,IBTCHRG)=+IBMCHRG - . S IBACHRG=IBTCHRG I +RS,+IBTCHRG S IBRCHRG=$$RATECHG^IBCRCC(RS,IBTCHRG,EVDT),IBACHRG=+IBRCHRG - . ; - . S IBCNT=IBCNT+1,^TMP($J,"IBCRCC")=IBCNT - . S ^TMP($J,"IBCRCC",IBCNT)=IBCI_U_CS_U_RS_U_ITEM_U_MOD_U_IBRVCD_U_IBBS_U_EVDT_U_IBCHRG_U_UNITS_U_IBTCHRG_U_IBACHRG_U_$G(SAVE) - . ; - . I (UNITS>1)!(+IBBASE) S IBCOM=$$COMMUB(CS,UNITS,IBBASE) I IBCOM'="" D COMMENT(IBCNT,IBCOM) - . I $P(IBPCHRG,U,2)'="" S IBCOM=$P(IBPCHRG,U,2) I IBCOM'="" D COMMENT(IBCNT,IBCOM) - . I $P(IBMCHRG,U,2)'="" S IBCOM=$P(IBMCHRG,U,2) I IBCOM'="" D COMMENT(IBCNT,IBCOM) - . I $P(IBRCHRG,U,2)'="" S IBCOM=$P(IBRCHRG,U,2) I IBCOM'="" D COMMENT(IBCNT,IBCOM) - Q - ; -COMMENT(LINE,COMM) ; set comment into charge array for a particular line item - I +$D(^TMP($J,"IBCRCC",+$G(LINE))) N IBX D - . S IBX=$O(^TMP($J,"IBCRCC",+LINE,"CC",9999),-1) S IBX=IBX+1 - . S ^TMP($J,"IBCRCC",+LINE,"CC",IBX)=$G(COMM) - Q - ; -COMMUB(CS,UNITS,BASE) ; return comment for special units and base - N IBX,IBY,IBCM S IBX="",IBY="Charge calculated" - S IBCM=$P($G(^IBE(363.1,+CS,0)),U,2),IBCM=$P($G(^IBE(363.3,+IBCM,0)),U,5) - S IBCM=$S(IBCM=4:"Miles",IBCM=5:"SubUnits",IBCM=6:"Hours",1:"") - I +$G(UNITS) S IBX=IBY_" for "_UNITS_" "_IBCM,IBY="" - I +$G(BASE) S IBX=IBY_IBX_" with a Base Charge="_$J(BASE,0,2) - Q IBX - ; -ALLBEDS(RS,CS,EVDT,RC,DFRC,SAVE) ; get charges for all bedsections active on date of visit - ; each effective date supercedes all previous effective date, regardless of the item - ; used for per diem rates where the charges are associated with a bedsection, but the item being billed is not - ; a bedsection, so the count of the item on the bill is found and applied as the units to all bedsections active - ; on the event date (the 3 opt visit dates on a bill are the units for the Outpatient Visit bedsection charge) - ; - N IBITM,IBITEMS I '$G(CS)!'$G(EVDT) Q - ; - D CSALL^IBCRCU1(CS,EVDT,.IBITEMS) - ; - I +IBITEMS S IBITM="" F S IBITM=$O(IBITEMS(IBITM)) Q:'IBITM D - . D BITMCHG($G(RS),CS,IBITM,EVDT,1,"",$G(RC),$G(DFRC),$G(SAVE)) - Q - ; - ; -CPTUNITS(CS,CHGMTH,ITLINE) ; return CPT units based on Charge Method and CPT data - ; Input: CS is the related Charge Set - ; CHGMTH is the Rate Schedule Charge Method (363.3, .05) - ; ITLINE is item data from CPT^IBCRBG1 - ; Output: calculated units for CPT, 1 or calculated for miles/minutes/hours - N IBUNIT S IBUNIT=1,CHGMTH=$G(CHGMTH),ITLINE=$G(ITLINE),CS=$G(CS) - I CHGMTH=4 S IBUNIT=+$P(ITLINE,U,8) ; miles - I CHGMTH=5 S IBUNIT=+$P(ITLINE,U,7) ; minutes - I CHGMTH=6 S IBUNIT=+$P(ITLINE,U,9) ; hours - S IBUNIT=$$CPTUNITS^IBCRCU1(CS,IBUNIT) - Q IBUNIT - ; -CHGOTH(IBIFN,RS,EVDT) ; check if the Rate Schedule charges are applicable to the event date for the bill - ; this is relevent to RC v2.0 and type of care of Other - ; both Rate Schedule is SNF and event date is SNF care or neither can be otherwise no charge - ; SNF charges can't be used for non-SNF care and non-SNF charges can't be used for SNF care - ; Output: returns true if charges and bill date are of same type, SNF or non-SNF - N IBOK,IBRSTY,IBDTTY S (IBRSTY,IBDTTY)=0,IBOK=1 - I $G(EVDT)<$$VERSDT^IBCRU8(2) G CHGOTHQ - I '$G(IBIFN)!'$G(RS) G CHGOTHQ - ; - S IBRSTY=$$RSOTHER^IBCRU8(RS) ; are charges for other type of care - S IBDTTY=$$BOTHER^IBCU3(IBIFN,EVDT) ; is date other type of care - ; - I +IBRSTY,'IBDTTY S IBOK=0 - I 'IBRSTY,+IBDTTY S IBOK=0 - ; -CHGOTHQ Q IBOK - ; -CHGICU(CS,BS) ; check if charge and bedsection match relative to ICU RC 2.0+, compares Charge Set Name and Bedsection - ; both the charge set and the bedsection have to be ICU or neither of them can be ICU otherwise no charge - ; ICU charges can't be used with non-ICU bedsections and non-ICU charges can't be used with ICU bedsection - ; Output: returns true if charges and bedsection are of same type, ICU or non-ICU - N IBCSICU,IBCSN,IBICU,IBOK S (IBOK,IBCSICU)=0,BS=+$G(BS) - S IBICU=$$MCCRUTL^IBCRU1("ICU",5) - S IBCSN=$G(^IBE(363.1,+$G(CS),0)) I $E(IBCSN,1,2)'="RC" S IBOK=1 - I $P(IBCSN,U,1)["ICU" S IBCSICU=1 ; charge set is icu - ; - I BS=IBICU,+IBCSICU S IBOK=1 ; both bedsection and charge set are icu - I BS'=IBICU,'IBCSICU S IBOK=1 ; niether bedsection nor charge set are icu - Q IBOK +IBCRBC2 ;ALB/ARH - RATES: BILL CALCULATION OF ITEM CHARGE ; 22-MAY-1996 + ;;2.0;INTEGRATED BILLING;**52,106,138,148,245**;21-MAR-94 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; + ; Input: RS - rate schedule necessary to calculated modified charges + ; CS - required, charge set which defines the charges to calculate + ; ITEM - required, ptr to source item to be billed, type defined by billable item of the rate + ; EVDT - date of event, to be used when searching for a charge effective date, default=DT + ; UNITS - required, used only for Quantity: # of units of Charge Item Charge for each Item + ; MOD - CPT Modifier if any + ; INSRC - special revenue code to use (from ins comp), if any (overrides set and item rv cd) + ; IDFRC - different revenue codes to use, these replace the standard set in CM (DRC:SRC,DRC:SRC) + ; SAVE - serveral data items not needed here but passed on to next step (store) in TMP array: + ; TUNITS - required to add charge to bill, total # of the Item on the bill + ; CPT - default CPT to be added to the bill for the charge + ; DIV - division charges apply to + ; TYPE - type of item being billed - defines the source of the item on the bill + ; ITMPTR - soft pointer to the item on the bill: may be a multiple or file IFN + ; CMPNT - what component of the total charge: institutional or professional + ; BEDS - billable bedsection to use if not a bedsection item, if null uses set default + ; PROV - procedure provider + ; CLINIC - procedures associated clinic + ; IBOE - Outpatient Encounter, pointer to #408.69 + ; + ; Total charge is calculated: X = UNITS * UNIT CHARGE of the item (per unit charge (un-adjusted)) + ; Y = X modified by Rate Schedule Adjustment (per unit charge (adjusted)) + ; the Units are used to calculate the per item charge: 30 pills for an rx, 1 bs per bs + ; and the Tunits are the number of that Item on the bill: 1 rx of 30 pills, 11 days of bs stay + ; + ; Output: TMP($J,"IBCRCC", containing all chargable items and all related info needed to file them on the bill + ; each charge will have it's own entry, nothing combined (12 = per unit charge (adjusted), p13 = Tunits) + ; TMP is not killed on entry so each items charges are compiled and added to existing charges + ; +BITMCHG(RS,CS,ITEM,EVDT,UNITS,MOD,INSRC,IDFRC,SAVE) ; get bill charges for a specific item, rate schedule and charge set and date set into temp array + ; + N IBCS0,IBDRVCD,IBBS,IBCHGARR,IBI,IBCNT,IBLN,IBCI,IBRVCD,IBPPRV,IBCHRG,IBTCHRG,IBRCHRG,IBPCHRG,IBACHRG,IBBASE,IBCOM + I '$G(ITEM)!'$G(CS)!'$G(UNITS) Q + ; + S RS=$G(RS),EVDT=$S(+$G(EVDT):+EVDT\1,1:DT),MOD=$G(MOD),INSRC=$G(INSRC),IDFRC=$G(IDFRC),SAVE=$G(SAVE) + S IBCS0=$G(^IBE(363.1,+CS,0)),IBDRVCD=$P(IBCS0,U,5),IBPPRV=$P(SAVE,U,8) + S IBBS=+ITEM I $P($G(^IBE(363.3,+$P(IBCS0,U,2),0)),U,4)'=1 S IBBS=$P(SAVE,U,7) I 'IBBS S IBBS=$P(IBCS0,U,6) + I 'IBBS Q + ; + D ITMCHG^IBCRCC(CS,ITEM,EVDT,MOD,.IBCHGARR) + ; + S IBCNT=+$G(^TMP($J,"IBCRCC")) + S IBI=0 F S IBI=$O(IBCHGARR(IBI)) Q:'IBI D + . S IBLN=IBCHGARR(IBI),IBCI=+IBLN,IBCHRG=$P(IBLN,U,3),(IBPCHRG,IBRCHRG)="" Q:'IBCHRG S IBBASE=$P(IBLN,U,4) + . S IBRVCD=INSRC I 'IBRVCD S IBRVCD=$P(IBLN,U,2) + . I 'IBRVCD S IBRVCD=$P($$RVLNK^IBCRU6(+ITEM,"",+CS),U,2) I 'IBRVCD S IBRVCD=IBDRVCD Q:'IBRVCD + . I +IDFRC,+$P(IDFRC,IBRVCD_":",2) S IBRVCD=+$P(IDFRC,IBRVCD_":",2) Q:IBRVCD'?3N + . ; + . S IBCHRG=IBCHRG*UNITS + . S IBCHRG=IBCHRG+IBBASE + . S IBPCHRG=IBCHRG I +IBPPRV S IBPCHRG=$$PRVCHG^IBCRCC(CS,IBCHRG,IBPPRV,EVDT,ITEM) + . S (IBCHRG,IBTCHRG)=+IBPCHRG + . S IBACHRG=IBTCHRG I +RS,+IBTCHRG S IBRCHRG=$$RATECHG^IBCRCC(RS,IBTCHRG,EVDT),IBACHRG=+IBRCHRG + . ; + . S IBCNT=IBCNT+1,^TMP($J,"IBCRCC")=IBCNT + . S ^TMP($J,"IBCRCC",IBCNT)=IBCI_U_CS_U_RS_U_ITEM_U_MOD_U_IBRVCD_U_IBBS_U_EVDT_U_IBCHRG_U_UNITS_U_IBTCHRG_U_IBACHRG_U_$G(SAVE) + . ; + . I (UNITS>1)!(+IBBASE) S IBCOM=$$COMMUB(CS,UNITS,IBBASE) I IBCOM'="" D COMMENT(IBCNT,IBCOM) + . I $P(IBPCHRG,U,2)'="" S IBCOM=$P(IBPCHRG,U,2) I IBCOM'="" D COMMENT(IBCNT,IBCOM) + . I $P(IBRCHRG,U,2)'="" S IBCOM=$P(IBRCHRG,U,2) I IBCOM'="" D COMMENT(IBCNT,IBCOM) + Q + ; +COMMENT(LINE,COMM) ; set comment into charge array for a particular line item + I +$D(^TMP($J,"IBCRCC",+$G(LINE))) N IBX D + . S IBX=$O(^TMP($J,"IBCRCC",+LINE,"CC",9999),-1) S IBX=IBX+1 + . S ^TMP($J,"IBCRCC",+LINE,"CC",IBX)=$G(COMM) + Q + ; +COMMUB(CS,UNITS,BASE) ; return comment for special units and base + N IBX,IBY,IBCM S IBX="",IBY="Charge calculated" + S IBCM=$P($G(^IBE(363.1,+CS,0)),U,2),IBCM=$P($G(^IBE(363.3,+IBCM,0)),U,5) + S IBCM=$S(IBCM=4:"Miles",IBCM=5:"SubUnits",IBCM=6:"Hours",1:"") + I +$G(UNITS) S IBX=IBY_" for "_UNITS_" "_IBCM,IBY="" + I +$G(BASE) S IBX=IBY_IBX_" with a Base Charge="_$J(BASE,0,2) + Q IBX + ; +ALLBEDS(RS,CS,EVDT,RC,DFRC,SAVE) ; get charges for all bedsections active on date of visit + ; each effective date supercedes all previous effective date, regardless of the item + ; used for per diem rates where the charges are associated with a bedsection, but the item being billed is not + ; a bedsection, so the count of the item on the bill is found and applied as the units to all bedsections active + ; on the event date (the 3 opt visit dates on a bill are the units for the Outpatient Visit bedsection charge) + ; + N IBITM,IBITEMS I '$G(CS)!'$G(EVDT) Q + ; + D CSALL^IBCRCU1(CS,EVDT,.IBITEMS) + ; + I +IBITEMS S IBITM="" F S IBITM=$O(IBITEMS(IBITM)) Q:'IBITM D + . D BITMCHG($G(RS),CS,IBITM,EVDT,1,"",$G(RC),$G(DFRC),$G(SAVE)) + Q + ; + ; +CPTUNITS(CS,CHGMTH,ITLINE) ; return CPT units based on Charge Method and CPT data + ; Input: CS is the related Charge Set + ; CHGMTH is the Rate Schedule Charge Method (363.3, .05) + ; ITLINE is item data from CPT^IBCRBG1 + ; Output: calculated units for CPT, 1 or calculated for miles/minutes/hours + N IBUNIT S IBUNIT=1,CHGMTH=$G(CHGMTH),ITLINE=$G(ITLINE),CS=$G(CS) + I CHGMTH=4 S IBUNIT=+$P(ITLINE,U,8) ; miles + I CHGMTH=5 S IBUNIT=+$P(ITLINE,U,7) ; minutes + I CHGMTH=6 S IBUNIT=+$P(ITLINE,U,9) ; hours + S IBUNIT=$$CPTUNITS^IBCRCU1(CS,IBUNIT) + Q IBUNIT + ; +CHGOTH(IBIFN,RS,EVDT) ; check if the Rate Schedule charges are applicable to the event date for the bill + ; this is relevent to RC v2.0 and type of care of Other + ; both Rate Schedule is SNF and event date is SNF care or neither can be otherwise no charge + ; SNF charges can't be used for non-SNF care and non-SNF charges can't be used for SNF care + ; Output: returns true if charges and bill date are of same type, SNF or non-SNF + N IBOK,IBRSTY,IBDTTY S (IBRSTY,IBDTTY)=0,IBOK=1 + I $G(EVDT)<$$VERSDT^IBCRU8(2) G CHGOTHQ + I '$G(IBIFN)!'$G(RS) G CHGOTHQ + ; + S IBRSTY=$$RSOTHER^IBCRU8(RS) ; are charges for other type of care + S IBDTTY=$$BOTHER^IBCU3(IBIFN,EVDT) ; is date other type of care + ; + I +IBRSTY,'IBDTTY S IBOK=0 + I 'IBRSTY,+IBDTTY S IBOK=0 + ; +CHGOTHQ Q IBOK + ; +CHGICU(CS,BS) ; check if charge and bedsection match relative to ICU RC 2.0+, compares Charge Set Name and Bedsection + ; both the charge set and the bedsection have to be ICU or neither of them can be ICU otherwise no charge + ; ICU charges can't be used with non-ICU bedsections and non-ICU charges can't be used with ICU bedsection + ; Output: returns true if charges and bedsection are of same type, ICU or non-ICU + N IBCSICU,IBCSN,IBICU,IBOK S (IBOK,IBCSICU)=0,BS=+$G(BS) + S IBICU=$$MCCRUTL^IBCRU1("ICU",5) + S IBCSN=$G(^IBE(363.1,+$G(CS),0)) I $E(IBCSN,1,2)'="RC" S IBOK=1 + I $P(IBCSN,U,1)["ICU" S IBCSICU=1 ; charge set is icu + ; + I BS=IBICU,+IBCSICU S IBOK=1 ; both bedsection and charge set are icu + I BS'=IBICU,'IBCSICU S IBOK=1 ; niether bedsection nor charge set are icu + Q IBOK diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBG.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBG.m index 63909153..5429f0ca 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBG.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBG.m @@ -1,180 +1,163 @@ -IBCRBG ;ALB/ARH - RATES: BILL SOURCE EVENTS (INPT) ; 21 MAY 96 - ;;2.0;INTEGRATED BILLING;**52,80,106,51,142,159,210,245,382,389**;21-MAR-94;Build 6 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -INPTPTF(IBIFN,CS) ; search PTF record for billable bedsections, transfer DRGs, and length of stay - ; - screens out days for pass, leave and SC treatment - ; - adds charges for only one BS if the ins company does not allow multiple bedsections per bill (36,.06) - ; Output: ^TMP($J,"IBCRC-INDT", BILLABLE DATE) = MOVE DT/TM ^ BILL BS ^ SC FLAG ^ DRG ^ DIV ^ SPECIALTY ^ MOVE # - ; - N IB0,DFN,PTF,IBU,IBBDT,IBEDT,IBTF,IBADM,IBX,IBINSMBS - K ^TMP($J,"IBCRC-PTF"),^TMP($J,"IBCRC-DIV"),^TMP($J,"IBCRC-INDT") - ; - S IB0=$G(^DGCR(399,+$G(IBIFN),0)),DFN=$P(IB0,U,2) Q:'DFN - S IBTF=$P(IB0,U,6),PTF="" S:$P(IB0,U,5)<3 PTF=$P(IB0,U,8) Q:'PTF - S IBINSMBS=0,IBX=+$G(^DGCR(399,+IBIFN,"MP")) - I 'IBX,$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)) S IBX=$$CURR^IBCEF2(IBIFN) - I $P($G(^DIC(36,+IBX,0)),U,6)=0 S IBINSMBS=1 ; 1 bs per bill - ; - S IBU=$G(^DGCR(399,+IBIFN,"U")) Q:'IBU - S IBBDT=+IBU,IBEDT=$P(IBU,U,2) Q:'IBEDT - ; - S IBADM=$O(^DGPM("APTF",PTF,0)) ; find corresponding admission - ; - D PTF(PTF) ; get movements and bedsections - D PTFDV(PTF) ; reset movements and bedsections for ward/division - D PTFFY(PTF,IBBDT,IBEDT) ; reset movements for FY DRG change - ; - D BSLOS(IBBDT,IBEDT,IBTF,IBADM,IBINSMBS) ; calculate days in bedsections within timeframe of the bill - ; - K ^TMP($J,"IBCRC-PTF"),^TMP($J,"IBCRC-DIV") - ; - D INPTRSET^IBCRBG2(IBIFN,$G(CS)) - Q - ; -PTF(PTF) ; find all movements in PTF for the admission by date and billing bedsection (501 movement) - ; the movement date is the date the patient left the bedsection - ; Output: ^TMP($J,"IBCRC-PTF", MOVE DT/TM)=MOVE DT/TM ^ BILL BED ^ SC FLAG ^ TRANSFER DRG ^ ^ SPECIALTY ^ MOVE # - ; - N IBMOVE,IBMVLN,IBBILLBS,IBENDDT,IBMSC,IBMDRG S PTF=+$G(PTF) - S IBMOVE=0 F S IBMOVE=$O(^DGPT(PTF,"M",IBMOVE)) Q:'IBMOVE D - . S IBMVLN=^DGPT(PTF,"M",IBMOVE,0) - . S IBBILLBS=+$$SPBB($P(IBMVLN,U,2)) ; billable bedsection - . S IBENDDT=+$P(IBMVLN,U,10) I 'IBENDDT S IBENDDT=DT ; movement date (last date in bedsection) - . S IBMSC="" I +$P(IBMVLN,U,18)=1 S IBMSC=1 ; sc movement - . S IBMDRG=$$MVDRG(PTF,IBMOVE) ; movement DRG - . S ^TMP($J,"IBCRC-PTF",IBENDDT)=IBENDDT_U_IBBILLBS_U_IBMSC_U_IBMDRG_U_U_+$P(IBMVLN,U,2)_U_IBMOVE - Q - ; -SPBB(SPCLTY) ; find the billable bedsection for a Specialty (42.4) - ; returns billable bedsection IFN ^ billable bedsection name - N IBX,IBY,IBZ S IBZ=0 - S IBX=$P($G(^DIC(42.4,+$G(SPCLTY),0)),U,5) - I IBX'="" S IBY=$O(^DGCR(399.1,"B",IBX,0)) I +IBY S IBZ=IBY_U_IBX - Q IBZ - ; -BSLOS(IBBDT,IBEDT,IBTF,IBADM,IBINSMBS) ; from the array of PTF movments get all bedsections and their LOS covered by date range of the bill - ; adds all days for first cronological bs if ins comp wants only a single bs per bill, even if not sequential - ; the movement date is the date the patient left the bedsection, so admission date is not in PTF array - ; - ; Input: ^TMP($J,"IBCRC-PTF", MOVE DT/TM) = MOVE DT/TM ^ BILL BS ^ SC FLAG ^ DRG ^ DIV ^ SPECIALTY ^ MOVE # - ; Output: ^TMP($J,"IBCRC-INDT", BILLABLE DATE) = MOVE DT/TM ^ BILL BS ^ SC FLAG ^ DRG ^ DIV ^ SPECIALTY ^ MOVE # - ; - N IBSBDT,IBSEDT,IBS,IBLASTDT,IBX - S IBSBDT=IBBDT+.3 ; discount any movements ending on or before the begin date - S IBSEDT=IBEDT\1 - ; - I ",2,3,"'[IBTF S IBSEDT=IBSEDT-.01 ; final bill, do not count last day - ; - I +$G(IBADM) S IBX=$$AD^IBCU64(IBADM) I +IBX,($P(IBX,U,1)\1)=($P(IBX,U,2)\1) S IBSBDT=IBBDT ; reset 1 day stays - ; - S IBS=IBSBDT-.01 F S IBS=$O(^TMP($J,"IBCRC-PTF",IBS)) Q:'IBS D SET S IBLASTDT=IBS Q:(IBLASTDT\1)>IBSEDT - ; - Q - ; -SET ; checks a specific movement to determine if it should be billed and what the length of stay is - ; setting of the movement date determines how many days are counted in the bedsection - N IBMVLN,IBMBDT,IBMEDT,IBMTF,IBMLOS,IBI,IBCHGDT - S IBMVLN=$G(^TMP($J,"IBCRC-PTF",IBS)) - I '$P(IBMVLN,U,2) Q ; non-billable bedsection - I +$P(IBMVLN,U,3) Q ; sc movement - I +IBINSMBS,+$G(IBLASTDT) Q ; ins does not allow multiple bs - ; - S IBMBDT=$S(IBBDT>$G(IBLASTDT):IBBDT,1:IBLASTDT),IBMBDT=IBMBDT\1 ; start cnt on begin dt or last move dt - S IBMEDT=$S(IBS10 Q - . F IBYR=IBYRB:1:IBYRE S IBFY=IBYR_"1001" I IBBEGDTIBFY D - .. S IBMVLN=$G(^TMP($J,"IBCRC-PTF",IBENDDT)),IBMVDRG=$P(IBMVLN,U,4),IBMOVE=$P(IBMVLN,U,7) - .. S IBFYDRG=$$MVDRG(PTF,IBMOVE,IBYR_"0930") - .. I IBMVDRG'=IBFYDRG S $P(IBMVLN,U,4)=IBFYDRG S ^TMP($J,"IBCRC-PTF",IBFY)=IBMVLN - Q - ; -MVDRG(PTF,M,CDATE) ; Return the DRG for a specific PTF Movememt (M=move ifn) - ; CDATE is optional, used if need to calculate DRG for some day within the move, not at the end date - N DPT0,PTF0,PTFM0,PTF70,IBBEG,IBEND,IBDSST,IBDX,IBPRC0,IBPRC,IBDRG,IBI,IBJ,IBP - N SEX,AGE,ICDDX,ICDPRC,ICDEXP,ICDDMS,ICDTRS,ICDDRG,ICDMDC,ICDRTC,ICDDATE - S IBDRG="" - ; - S PTF0=$G(^DGPT(+$G(PTF),0)),DPT0=$G(^DPT(+$P(PTF0,U,1),0)) I DPT0="" G MVDRGQ - S PTFM0=$G(^DGPT(+PTF,"M",+$G(M),0)) I 'PTFM0 G MVDRGQ - S PTF70=$G(^DGPT(+PTF,70)),IBDSST=+$P(PTF70,U,3) - ; - S IBEND=+$P(PTFM0,U,10) I 'IBEND S IBEND=DT+.9 - S IBBEG=$O(^DGPT(+PTF,"M","AM",IBEND),-1) I 'IBBEG S IBBEG=$P(PTF0,U,2) - ; - S SEX=$P(DPT0,U,2) - S AGE=$P(DPT0,U,3),AGE=$$FMDIFF^XLFDT(IBEND,AGE)\365.25 - ; - S (ICDEXP,ICDDMS,ICDTRS)=0 I +PTF70,+PTF70=$P(PTFM0,U,10) D - . I IBDSST>5 S ICDEXP=1 ; patient expired - . I IBDSST=4 S ICDDMS=1 ; patient left against medical advice - . I IBDSST=5,+$P(PTF70,U,13) S ICDTRS=1 ; patient transfered to another facility - ; - S IBJ=0 F IBI=5:1:9 S IBDX=$P(PTFM0,U,IBI) I +IBDX,($$ICD9^IBACSV(+IBDX)'="") S IBJ=IBJ+1,ICDDX(IBJ)=IBDX - ; - I '$O(ICDDX(0)) G MVDRGQ - ; - S IBJ=0 - S IBP=0 F S IBP=$O(^DGPT(+PTF,"S",IBP)) Q:'IBP D ; surguries - . S IBPRC0=$G(^DGPT(+PTF,"S",IBP,0)) Q:'IBPRC0 - . I +IBPRC0'IBEND D - .. F IBI=8:1:12 S IBPRC=$P(IBPRC0,U,IBI) I +IBPRC,($$ICD0^IBACSV(+IBPRC)'="") S IBJ=IBJ+1,ICDPRC(IBJ)=+IBPRC - ; - S IBP=0 F S IBP=$O(^DGPT(+PTF,"P",IBP)) Q:'IBP D ; procedures - . S IBPRC0=$G(^DGPT(+PTF,"P",IBP,0)) Q:'IBPRC0 - . I +IBPRC0'IBEND D - .. F IBI=5:1:9 S IBPRC=$P(IBPRC0,U,IBI) I +IBPRC,($$ICD0^IBACSV(+IBPRC)'="") S IBJ=IBJ+1,ICDPRC(IBJ)=+IBPRC - ; - S ICDDATE=$S(+$G(CDATE):CDATE,+$P(PTFM0,U,10):+$P(PTFM0,U,10),1:DT) ; date for the DRG Grouper versioning - D ^ICDDRG S IBDRG=$G(ICDDRG) - ; -MVDRGQ Q IBDRG +IBCRBG ;ALB/ARH - RATES: BILL SOURCE EVENTS (INPT) ; 21 MAY 96 + ;;2.0;INTEGRATED BILLING;**52,80,106,51,142,159,210,245**;21-MAR-94 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; +INPTPTF(IBIFN,CS) ; search PTF record for billable bedsections, transfer DRGs, and length of stay + ; - screens out days for pass, leave and SC treatment + ; - adds charges for only one BS if the ins company does not allow multiple bedsections per bill (36,.06) + ; Output: ^TMP($J,"IBCRC-INDT", BILLABLE DATE) = MOVE DT/TM ^ BILL BS ^ SC FLAG ^ DRG ^ DIVISION ^ SPECIALTY + ; + N IB0,DFN,PTF,IBU,IBBDT,IBEDT,IBTF,IBADM,IBX,IBINSMBS + K ^TMP($J,"IBCRC-PTF"),^TMP($J,"IBCRC-DIV"),^TMP($J,"IBCRC-INDT") + ; + S IB0=$G(^DGCR(399,+$G(IBIFN),0)),DFN=$P(IB0,U,2) Q:'DFN + S IBTF=$P(IB0,U,6),PTF="" S:$P(IB0,U,5)<3 PTF=$P(IB0,U,8) Q:'PTF + S IBINSMBS=0,IBX=+$G(^DGCR(399,+IBIFN,"MP")) + I 'IBX,$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)) S IBX=$$CURR^IBCEF2(IBIFN) + I $P($G(^DIC(36,+IBX,0)),U,6)=0 S IBINSMBS=1 ; 1 bs per bill + ; + S IBU=$G(^DGCR(399,+IBIFN,"U")) Q:'IBU + S IBBDT=+IBU,IBEDT=$P(IBU,U,2) Q:'IBEDT + ; + S IBADM=$O(^DGPM("APTF",PTF,0)) ; find corresponding admission + ; + D PTF(PTF) ; get movements and bedsections + D PTFDV(PTF) ; reset movements and bedsections for ward/division + ; + D BSLOS(IBBDT,IBEDT,IBTF,IBADM,IBINSMBS) ; calculate days in bedsections within timeframe of the bill + ; + K ^TMP($J,"IBCRC-PTF"),^TMP($J,"IBCRC-DIV") + ; + D INPTRSET^IBCRBG2(IBIFN,$G(CS)) + Q + ; +PTF(PTF) ; find all movements in PTF for the admission by date and billing bedsection (501 movement) + ; the movement date is the date the patient left the bedsection + ; Output: ^TMP($J,"IBCRC-PTF", MOVE DT/TM)=MOVE DT/TM ^ BILL BEDSECTION ^ SC FLAG ^ TRANSFER DRG ^ ^ SPECIALTY + ; + N IBMOVE,IBMVLN,IBBILLBS,IBENDDT,IBMSC,IBMDRG S PTF=+$G(PTF) + S IBMOVE=0 F S IBMOVE=$O(^DGPT(PTF,"M",IBMOVE)) Q:'IBMOVE D + . S IBMVLN=^DGPT(PTF,"M",IBMOVE,0) + . S IBBILLBS=+$$SPBB($P(IBMVLN,U,2)) ; billable bedsection + . S IBENDDT=+$P(IBMVLN,U,10) I 'IBENDDT S IBENDDT=DT ; movement date (last date in bedsection) + . S IBMSC="" I +$P(IBMVLN,U,18)=1 S IBMSC=1 ; sc movement + . S IBMDRG=$$MVDRG(PTF,IBMOVE) ; movement DRG + . S ^TMP($J,"IBCRC-PTF",IBENDDT)=IBENDDT_U_IBBILLBS_U_IBMSC_U_IBMDRG_U_U_+$P(IBMVLN,U,2) + Q + ; +SPBB(SPCLTY) ; find the billable bedsection for a Specialty (42.4) + ; returns billable bedsection IFN ^ billable bedsection name + N IBX,IBY,IBZ S IBZ=0 + S IBX=$P($G(^DIC(42.4,+$G(SPCLTY),0)),U,5) + I IBX'="" S IBY=$O(^DGCR(399.1,"B",IBX,0)) I +IBY S IBZ=IBY_U_IBX + Q IBZ + ; +BSLOS(IBBDT,IBEDT,IBTF,IBADM,IBINSMBS) ; from the array of PTF movments get all bedsections and their LOS covered by date range of the bill + ; adds all days for first cronological bs if ins comp wants only a single bs per bill, even if not sequential + ; the movement date is the date the patient left the bedsection, so admission date is not in PTF array + ; + ; Input: ^TMP($J,"IBCRC-PTF", MOVE DT/TM) = MOVE DT/TM ^ BILL BS ^ SC FLAG ^ DRG ^ DIVISION ^ SPECIALTY + ; Output: ^TMP($J,"IBCRC-INDT", BILLABLE DATE) = MOVE DT/TM ^ BILL BS ^ SC FLAG ^ DRG ^ DIVISION ^ SPECIALTY + ; + N IBSBDT,IBSEDT,IBS,IBLASTDT,IBX + S IBSBDT=IBBDT+.3 ; discount any movements ending on or before the begin date + S IBSEDT=IBEDT\1 + ; + I ",2,3,"'[IBTF S IBSEDT=IBSEDT-.01 ; final bill, do not count last day + ; + I +$G(IBADM) S IBX=$$AD^IBCU64(IBADM) I +IBX,($P(IBX,U,1)\1)=($P(IBX,U,2)\1) S IBSBDT=IBBDT ; reset 1 day stays + ; + S IBS=IBSBDT-.01 F S IBS=$O(^TMP($J,"IBCRC-PTF",IBS)) Q:'IBS D SET S IBLASTDT=IBS Q:(IBLASTDT\1)>IBSEDT + ; + Q + ; +SET ; checks a specific movement to determine if it should be billed and what the length of stay is + ; setting of the movement date determines how many days are counted in the bedsection + N IBMVLN,IBMBDT,IBMEDT,IBMTF,IBMLOS,IBI,IBCHGDT + S IBMVLN=$G(^TMP($J,"IBCRC-PTF",IBS)) + I '$P(IBMVLN,U,2) Q ; non-billable bedsection + I +$P(IBMVLN,U,3) Q ; sc movement + I +IBINSMBS,+$G(IBLASTDT) Q ; ins does not allow multiple bs + ; + S IBMBDT=$S(IBBDT>$G(IBLASTDT):IBBDT,1:IBLASTDT),IBMBDT=IBMBDT\1 ; start cnt on begin dt or last move dt + S IBMEDT=$S(IBS5 S ICDEXP=1 ; patient expired + . I IBDSST=4 S ICDDMS=1 ; patient left against medical advice + . I IBDSST=5,+$P(PTF70,U,13) S ICDTRS=1 ; patient transfered to another facility + ; + S IBJ=0 F IBI=5:1:9 S IBDX=$P(PTFM0,U,IBI) I +IBDX,($$ICD9^IBACSV(+IBDX)'="") S IBJ=IBJ+1,ICDDX(IBJ)=IBDX + ; + I '$O(ICDDX(0)) G MVDRGQ + ; + S IBJ=0 + S IBP=0 F S IBP=$O(^DGPT(+PTF,"S",IBP)) Q:'IBP D ; surguries + . S IBPRC0=$G(^DGPT(+PTF,"S",IBP,0)) Q:'IBPRC0 + . I +IBPRC0'IBEND D + .. F IBI=8:1:12 S IBPRC=$P(IBPRC0,U,IBI) I +IBPRC,($$ICD0^IBACSV(+IBPRC)'="") S IBJ=IBJ+1,ICDPRC(IBJ)=+IBPRC + ; + S IBP=0 F S IBP=$O(^DGPT(+PTF,"P",IBP)) Q:'IBP D ; procedures + . S IBPRC0=$G(^DGPT(+PTF,"P",IBP,0)) Q:'IBPRC0 + . I +IBPRC0'IBEND D + .. F IBI=5:1:9 S IBPRC=$P(IBPRC0,U,IBI) I +IBPRC,($$ICD0^IBACSV(+IBPRC)'="") S IBJ=IBJ+1,ICDPRC(IBJ)=+IBPRC + ; + S ICDDATE=$P(PTFM0,U,10) ; use the movement date for the DRG Grouper versioning + D ^ICDDRG S IBDRG=$G(ICDDRG) + ; +MVDRGQ Q IBDRG diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBH1.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBH1.m index 5abe2ec6..940edb43 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBH1.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBH1.m @@ -1,189 +1,195 @@ -IBCRBH1 ;ALB/ARH - RATES: BILL HELP DISPLAYS - CHARGES ; 10-OCT-1998 - ;;2.0;INTEGRATED BILLING;**106,245,370**;21-MAR-94;Build 5 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -DISPCHG(IBIFN) ; display a bills items and their charges, display only, does not change the charges on the bill - ; - D BILL(IBIFN,1),SORTCI(IBIFN),DSPCHRG(1) ; display auto add charges - K ^TMP($J,"IBCRCC"),^TMP($J,"IBCRCSX"),^TMP($J,"IBCRCSXR"),^TMP($J,"IBCRCSXN") - D BILL(IBIFN,""),SORTCI(IBIFN),DSPCHRG("") ; display non-auto add charges - K ^TMP($J,"IBCRCC"),^TMP($J,"IBCRCSX"),^TMP($J,"IBCRCSXR"),^TMP($J,"IBCRCSXN") - D NOTES(IBIFN,1) - Q - ; -BILL(IBIFN,IBAA,IBRSARR) ; given a bill number calculate charges using schedules that match the auto add flag - ; if IBRSARR is defined it will be used to create charges rather than the standard set for the bills Rate Type - ; Output: ^TMP($J,"IBCRCC" - same as would be calculated if the charges were being added to bill - ; - N IB0,IBU,IBBRT,IBBTYPE,IBCTYPE,IBRS,IBCS,IBBEVNT Q:'$G(IBIFN) - K ^TMP($J,"IBCRCC") - ; - S IB0=$G(^DGCR(399,+IBIFN,0)) Q:IB0="" S IBU=$G(^DGCR(399,+IBIFN,"U")) Q:'IBU - S IBBRT=+$P(IB0,U,7),IBBTYPE=$S($P(IB0,U,5)<3:1,1:3),IBCTYPE=+$P(IB0,U,27) - ; - ; get standard set of all rate schedules and charge sets available for the bill - I '$D(IBRSARR) D RT^IBCRU3(IBBRT,IBBTYPE,$P(IBU,U,1,2),.IBRSARR,"",IBCTYPE) I 'IBRSARR G END - ; - ; process charge sets - set all charges for the bill into array - S IBRS=0 F S IBRS=$O(IBRSARR(IBRS)) Q:'IBRS D - . S IBCS=0 F S IBCS=$O(IBRSARR(IBRS,IBCS)) Q:'IBCS I IBRSARR(IBRS,IBCS)=IBAA D - .. S IBBEVNT=+$P($G(^IBE(363.1,+IBCS,0)),U,3) Q:'IBBEVNT S IBBEVNT=$$EMUTL^IBCRU1(IBBEVNT) Q:IBBEVNT="" - .. ; - .. I IBBEVNT["INPATIENT BEDSECTION STAY" D INPTBS^IBCRBC1(IBIFN,IBRS,IBCS) - .. I IBBEVNT["INPATIENT DRG" D INPTDRG^IBCRBC11(IBIFN,IBRS,IBCS) - .. I IBBEVNT["OUTPATIENT VISIT DATE" D OPTVST^IBCRBC1(IBIFN,IBRS,IBCS) - .. I IBBEVNT["PRESCRIPTION" D RX^IBCRBC1(IBIFN,IBRS,IBCS) - .. I IBBEVNT["PROSTHETICS" D PI^IBCRBC1(IBIFN,IBRS,IBCS) - .. I IBBEVNT["PROCEDURE" D CPT^IBCRBC1(IBIFN,IBRS,IBCS) - ; -END Q - ; - ; -SORTCI(IBIFN) ; process charge array - create new array in sorted order with items combined, if possible - ; if bs, rv cd, charge, cpt, div, item type, item ptr and component all match then charge is combined - ; Input: TMP($J,"IBCRCC",X) = ... (from IBCRBC2) - ; Output: TMP($J,"IBCRCSX",X) = - ; RV CD ^ BS ^ CHG ^ UNITS ^ CPT ^ DIV ^ ITM TYPE ^ ITM PTR ^ CHRG CMPNT ^ CHRG SET ^ EVNT DT ^ ITM NAME - ; TMP($J,"IBCRCSX",X,"CC",Y) = charge adjustment messages - ; TMP($J,"IBCRCSXR",BS,RV CD,X) = "" - ; TMP($J,"IBCRCSXN",DATE,ITEM NAME,X) = "" - ; - N IBI,IBLN,IBRVCD,IBBS,IBCHG,IBUNITS,IBCPT,IBDV,IBIT,IBIP,IBCMPT,IBCS,IBDT,IBNM,IBTUNITS,IBK,IBJ,IBX,IBY - K ^TMP($J,"IBCRCSX"),^TMP($J,"IBCRCSXR"),^TMP($J,"IBCRCSXN") - ; - S IBI=0 F S IBI=$O(^TMP($J,"IBCRCC",IBI)) Q:'IBI D - . ; - . S IBLN=^TMP($J,"IBCRCC",IBI) - . S IBRVCD=$P(IBLN,U,6),IBBS=$P(IBLN,U,7),IBCHG=+$FN($P(IBLN,U,12),"",2),IBUNITS=$P(IBLN,U,13) - . S IBCPT=$P(IBLN,U,14),IBDV=$P(IBLN,U,15),IBIT=$P(IBLN,U,16),IBIP=$P(IBLN,U,17),IBCMPT=$P(IBLN,U,18) - . S IBCS=$P(IBLN,U,2),IBDT=$P(IBLN,U,8),IBNM=$$ITMNM($G(IBIFN),IBBS,IBIT,IBIP,IBCPT) - . ; - . ; combine like charges, unless there are comments - . S (IBTUNITS,IBK,IBJ)=0 F S IBJ=$O(^TMP($J,"IBCRCSXR",+IBBS,+IBRVCD,IBJ)) Q:'IBJ S IBK=IBJ D Q:+IBTUNITS - .. I $D(^TMP($J,"IBCRCC",IBI,"CC")) Q - .. S IBX=$G(^TMP($J,"IBCRCSX",IBJ)) - .. I IBCHG=$P(IBX,U,3),IBCPT=$P(IBX,U,5),IBDV=$P(IBX,U,6),IBIT=$P(IBX,U,7),IBIP=$P(IBX,U,8),IBCMPT=$P(IBX,U,9) D - ... S IBTUNITS=$P(IBX,U,4),IBDT=$P(IBX,U,11) - . ; - . I 'IBTUNITS S IBK=IBI ; no combination, new line item charge - . S IBTUNITS=IBTUNITS+IBUNITS - . ; - . S ^TMP($J,"IBCRCSXR",+IBBS,+IBRVCD,IBK)="" - . S ^TMP($J,"IBCRCSXN",IBDT_" ",IBNM_" ",IBK)="" - . S ^TMP($J,"IBCRCSX",IBK)=IBRVCD_U_+IBBS_U_IBCHG_U_IBTUNITS_U_IBCPT_U_IBDV_U_IBIT_U_IBIP_U_IBCMPT_U_IBCS_U_IBDT_U_IBNM - . S IBY=0 F S IBY=$O(^TMP($J,"IBCRCC",IBI,"CC",IBY)) Q:'IBY S ^TMP($J,"IBCRCSX",IBK,"CC",IBY)=^TMP($J,"IBCRCC",IBI,"CC",IBY) - Q - ; -DSPCHRG(AA) ; display charges - ; Input: TMP($J,"IBCRCSx",...) = ... (from SORTCI) - ; - N IBX,IBI,IBJ,IBK,IBLN,IBCNT,IBRVCD,IBCHG,IBUNITS,IBDV,IBCMPT,IBCS,IBDT,IBNM,IBTOTAL,IBQUIT,IBY S (IBTOTAL,IBQUIT)=0 - ; - D DSPHDR(AA) S IBCNT=4 - ; - S IBI="" F S IBI=$O(^TMP($J,"IBCRCSXN",IBI)) Q:IBI="" D Q:IBQUIT - . S IBJ="" F S IBJ=$O(^TMP($J,"IBCRCSXN",IBI,IBJ)) Q:IBJ="" D Q:IBQUIT - .. S IBK=0 F S IBK=$O(^TMP($J,"IBCRCSXN",IBI,IBJ,IBK)) Q:'IBK D Q:IBQUIT - ... S IBLN=$G(^TMP($J,"IBCRCSX",IBK)) Q:IBLN="" - ... ; - ... ; add charges to RC multiple - ... S IBRVCD=$P(IBLN,U,1),IBCHG=$P(IBLN,U,3),IBUNITS=$P(IBLN,U,4),IBDV=$P(IBLN,U,6) - ... S IBCMPT=$P(IBLN,U,9),IBCS=$P(IBLN,U,10),IBDT=$P(IBLN,U,11),IBNM=$P(IBLN,U,12) - ... S IBTOTAL=IBTOTAL+(IBCHG*IBUNITS),IBCNT=IBCNT+1 - ... ; - ... S IBX=IBRVCD_U_IBCHG_U_IBUNITS_U_IBCMPT_U_IBCS_U_IBDT_U_IBDV_U_IBNM D DSPLN(IBX) - ... ; - ... S IBY=0 F S IBY=$O(^TMP($J,"IBCRCSX",IBK,"CC",IBY)) Q:'IBY D - .... S IBX=$G(^TMP($J,"IBCRCSX",IBK,"CC",IBY)) I IBX'="" D DISPLNC(IBX) S IBCNT=IBCNT+1 - ... I $O(^TMP($J,"IBCRCSX",IBK,"CC",0)) D DISPLNC("") S IBCNT=IBCNT+1 - ... ; - ... I IBCNT>20 S IBQUIT=$$PAUSE(IBCNT) Q:IBQUIT D DSPHDR(AA) S IBCNT=4 - ; - I +IBTOTAL W !,?72,"--------",!,?70,$J(IBTOTAL,10,2) S IBCNT=IBCNT+2 - I 'IBQUIT S IBQUIT=$$PAUSE(IBCNT) - Q - ; -DSPHDR(AA) ; - W @IOF,!,"Items and Charges on this Bill ("_$S('AA:"NOT ",1:"")_"Auto Add)" - W !,"Item",?18,"Date",?28,"Charge Set",?40,"Div",?47,"Type",?52,"RvCd",?57,"Units",?64,"Charge",?75,"Total" - W !,"--------------------------------------------------------------------------------" - Q - ; -DSPLN(LN) ; - N CS,DIV,CMP,RVCD,ITM,CHG,UNIT S LN=$G(LN) - S CS=$P(LN,U,5) I +CS S CS=$P($G(^IBE(363.1,+$P(LN,U,5),0)),U,1) - S DIV=$P($G(^DG(40.8,+$P(LN,U,7),0)),U,2) - S CMP=$S($P(LN,U,4)=1:"INST",$P(LN,U,4)=2:"PROF",1:"") - S RVCD=$P($G(^DGCR(399.2,+LN,0)),U,1) - S ITM=$P(LN,U,8),CHG=+$P(LN,U,2),UNIT=$P(LN,U,3) - W !,$E(ITM,1,15),?18,$$DATE($P(LN,U,6)),?28,$E(CS,1,7),?40,DIV,?47,CMP,?52,RVCD,?57,$J(UNIT,3),?62,$J(CHG,8,2),?71,$J((UNIT*CHG),9,2) - Q - ; -DISPLNC(LN) ; display charge adjustment commenmts - W !,?18,$G(LN) - Q - ; -DATE(X) ; - S X=$G(X),X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3) - Q X - ; -PAUSE(CNT) ; - N IBI F IBI=CNT:1:22 W ! - N DIR,DUOUT,DTOUT,DIRUT,IBX,X,Y S IBX=0,DIR(0)="E" D ^DIR K DIR I $D(DIRUT) S IBX=1 - Q IBX - ; -ITMNM(IBIFN,IBBS,IBIT,IBIP,IBCPT) ; return external form of the item name - N ITM S ITM="",IBBS=$G(IBBS),IBIT=$G(IBIT),IBIP=$G(IBIP),IBCPT=$G(IBCPT) - I +IBIP S ITM=$$NAME^IBCSC61(IBIT,IBIP) - I ITM="",+IBIT=4,+$G(IBIFN) S ITM=$$CPTNM(IBIFN,IBIT,IBIP) - I ITM="",+IBCPT S ITM=$P($$CPT^ICPTCOD(+IBCPT,DT),U,2) - I ITM="" S ITM=$$EMUTL^IBCRU1(IBBS) - Q ITM - ; -CPTNM(IBIFN,TYPE,ITEM) ; retrurn external name of the charge item if it is a CPT item (type=399,42,.1) - N IBX,NAME S IBX=0,NAME="" - I +$G(TYPE)=4 S IBX=$G(^DGCR(399,+$G(IBIFN),"CP",+$G(ITEM),0)) - I +IBX S NAME=$P($$CPT^ICPTCOD(+$P(IBX,U,1),DT),U,2) - I +IBX S IBX=$$GETMOD^IBEFUNC(+$G(IBIFN),+$G(ITEM),1) I IBX'="" S NAME=NAME_"-"_IBX - Q NAME - ; - ; - ; - ; -NOTES(IBIFN,PAUSE) ; compile and print charge notes for a bill - ; - ; Current Checks are for those Treating Specialties that should not be billed using DRG: - ; - Inpatient Institutional Reasonable Charges bill contains SNF Treating Specialty - ; - Inpatient Institutional Reasonable Charges bill contains Observation Treating Specialty - ; - I $D(ZTQUEUED)!(+$G(IBAUTO)) Q - N IB0,IBU,PTF,BEG,END,IBMVLN,IBENDDT,IBMDRG,IBFND,IBMSG,IBX S IBFND=0 K ^TMP($J,"IBCRC-PTF") - S IB0=$G(^DGCR(399,+$G(IBIFN),0)) Q:IB0="" S IBU=$G(^DGCR(399,+$G(IBIFN),"U")) Q:'IBU - ; - I '$$BILLRATE^IBCRU3($P(IB0,U,7),$P(IB0,U,5),$P(IB0,U,3),"RC") Q ; not Reasonable Charges bill - ; - ; Outpatient Freestanding bill: display message if this is a non-provider based freestanding bill - I $P(IB0,U,5)=3,$P(IB0,U,3)'<$$VERSDT^IBCRU8(2),$P($$RCDV^IBCRU8(+$P(IB0,U,22)),U,3)=3 D - . S IBFND=IBFND+1,IBX=">>> Bill Division is Freestanding Non-Provider with Professional Charges only.",IBMSG(IBFND)=IBX - ; - ; Inpatient Institutional bill: check for treating specialties that should not be billed by DRG - I +$P(IB0,U,8),$P(IB0,U,5)<3,$P(IB0,U,27)<2 D - . ; - . S PTF=+$P(IB0,U,8),BEG=+$P(IBU,U,1)\1,END=$S(+$P(IBU,U,2):+$P(IBU,U,2)\1,1:DT) - . ; - . D PTF^IBCRBG(PTF) - . ; - . S IBENDDT=BEG F S IBENDDT=$O(^TMP($J,"IBCRC-PTF",IBENDDT)) Q:'IBENDDT D I IBENDDT>END Q - .. I (IBENDDT\1)=BEG,BEG'=END Q - .. ; - .. S IBMVLN=$G(^TMP($J,"IBCRC-PTF",IBENDDT)),IBMVLN=+$P(IBMVLN,U,6) Q:'IBMVLN - .. S IBMDRG=$$NODRG^IBCRBG2(IBMVLN) Q:'IBMDRG - .. ; - .. S IBFND=IBFND+1,IBX=">>> "_$P(IBMDRG,U,2)_" ("_$$FMTE^XLFDT(IBENDDT,2)_") not billed using DRG" - .. S:IBMDRG["Nursing" IBX=IBX_", use SNF." S:IBMDRG["Observa" IBX=IBX_", use Procedures." - .. S IBMSG(IBFND)=$G(IBX) - ; - I +IBFND D I +$G(PAUSE) S IBFND=$$PAUSE(21) - . W ! S IBX="" F S IBX=$O(IBMSG(IBX)) Q:IBX="" W !,IBMSG(IBX) - K ^TMP($J,"IBCRC-PTF") - Q +IBCRBH1 ;ALB/ARH - RATES: BILL HELP DISPLAYS - CHARGES ; 10-OCT-1998 + ;;2.0;INTEGRATED BILLING;**106,245**;21-MAR-94 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; +DISPCHG(IBIFN) ; display a bills items and their charges, display only, does not change the charges on the bill + ; + D BILL(IBIFN,1),SORTCI(IBIFN),DSPCHRG(1) ; display auto add charges + K ^TMP($J,"IBCRCC"),^TMP($J,"IBCRCSX"),^TMP($J,"IBCRCSXR"),^TMP($J,"IBCRCSXN") + D BILL(IBIFN,""),SORTCI(IBIFN),DSPCHRG("") ; display non-auto add charges + K ^TMP($J,"IBCRCC"),^TMP($J,"IBCRCSX"),^TMP($J,"IBCRCSXR"),^TMP($J,"IBCRCSXN") + D NOTES(IBIFN,1) + Q + ; +BILL(IBIFN,IBAA,IBRSARR) ; given a bill number calculate charges using schedules that match the auto add flag + ; if IBRSARR is defined it will be used to create charges rather than the standard set for the bills Rate Type + ; Output: ^TMP($J,"IBCRCC" - same as would be calculated if the charges were being added to bill + ; + N IB0,IBU,IBBRT,IBBTYPE,IBCTYPE,IBRS,IBCS,IBBEVNT Q:'$G(IBIFN) + K ^TMP($J,"IBCRCC") + ; + S IB0=$G(^DGCR(399,+IBIFN,0)) Q:IB0="" S IBU=$G(^DGCR(399,+IBIFN,"U")) Q:'IBU + S IBBRT=+$P(IB0,U,7),IBBTYPE=$S($P(IB0,U,5)<3:1,1:3),IBCTYPE=+$P(IB0,U,27) + ; + ; get standard set of all rate schedules and charge sets available for the bill + I '$D(IBRSARR) D RT^IBCRU3(IBBRT,IBBTYPE,$P(IBU,U,1,2),.IBRSARR,"",IBCTYPE) I 'IBRSARR G END + ; + ; process charge sets - set all charges for the bill into array + S IBRS=0 F S IBRS=$O(IBRSARR(IBRS)) Q:'IBRS D + . S IBCS=0 F S IBCS=$O(IBRSARR(IBRS,IBCS)) Q:'IBCS I IBRSARR(IBRS,IBCS)=IBAA D + .. S IBBEVNT=+$P($G(^IBE(363.1,+IBCS,0)),U,3) Q:'IBBEVNT S IBBEVNT=$$EMUTL^IBCRU1(IBBEVNT) Q:IBBEVNT="" + .. ; + .. I IBBEVNT["INPATIENT BEDSECTION STAY" D INPTBS^IBCRBC1(IBIFN,IBRS,IBCS) + .. I IBBEVNT["INPATIENT DRG" D INPTDRG^IBCRBC11(IBIFN,IBRS,IBCS) + .. I IBBEVNT["OUTPATIENT VISIT DATE" D OPTVST^IBCRBC1(IBIFN,IBRS,IBCS) + .. I IBBEVNT["PRESCRIPTION" D RX^IBCRBC1(IBIFN,IBRS,IBCS) + .. I IBBEVNT["PROSTHETICS" D PI^IBCRBC1(IBIFN,IBRS,IBCS) + .. I IBBEVNT["PROCEDURE" D CPT^IBCRBC1(IBIFN,IBRS,IBCS) + ; + I '$D(^TMP($J,"IBCRCC")) G END + ; + D MULTCPT^IBCRBCA1 + D PSB^IBCRBCA2 + D MODADJ^IBCRBCA3 + ; +END Q + ; + ; +SORTCI(IBIFN) ; process charge array - create new array in sorted order with items combined, if possible + ; if bs, rv cd, charge, cpt, div, item type, item ptr and component all match then charge is combined + ; Input: TMP($J,"IBCRCC",X) = ... (from IBCRBC2) + ; Output: TMP($J,"IBCRCSX",X) = + ; RV CD ^ BS ^ CHG ^ UNITS ^ CPT ^ DIV ^ ITM TYPE ^ ITM PTR ^ CHRG CMPNT ^ CHRG SET ^ EVNT DT ^ ITM NAME + ; TMP($J,"IBCRCSX",X,"CC",Y) = charge adjustment messages + ; TMP($J,"IBCRCSXR",BS,RV CD,X) = "" + ; TMP($J,"IBCRCSXN",DATE,ITEM NAME,X) = "" + ; + N IBI,IBLN,IBRVCD,IBBS,IBCHG,IBUNITS,IBCPT,IBDV,IBIT,IBIP,IBCMPT,IBCS,IBDT,IBNM,IBTUNITS,IBK,IBJ,IBX,IBY + K ^TMP($J,"IBCRCSX"),^TMP($J,"IBCRCSXR"),^TMP($J,"IBCRCSXN") + ; + S IBI=0 F S IBI=$O(^TMP($J,"IBCRCC",IBI)) Q:'IBI D + . ; + . S IBLN=^TMP($J,"IBCRCC",IBI) + . S IBRVCD=$P(IBLN,U,6),IBBS=$P(IBLN,U,7),IBCHG=+$FN($P(IBLN,U,12),"",2),IBUNITS=$P(IBLN,U,13) + . S IBCPT=$P(IBLN,U,14),IBDV=$P(IBLN,U,15),IBIT=$P(IBLN,U,16),IBIP=$P(IBLN,U,17),IBCMPT=$P(IBLN,U,18) + . S IBCS=$P(IBLN,U,2),IBDT=$P(IBLN,U,8),IBNM=$$ITMNM($G(IBIFN),IBBS,IBIT,IBIP,IBCPT) + . ; + . ; combine like charges, unless there are comments + . S (IBTUNITS,IBK,IBJ)=0 F S IBJ=$O(^TMP($J,"IBCRCSXR",+IBBS,+IBRVCD,IBJ)) Q:'IBJ S IBK=IBJ D Q:+IBTUNITS + .. I $D(^TMP($J,"IBCRCC",IBI,"CC")) Q + .. S IBX=$G(^TMP($J,"IBCRCSX",IBJ)) + .. I IBCHG=$P(IBX,U,3),IBCPT=$P(IBX,U,5),IBDV=$P(IBX,U,6),IBIT=$P(IBX,U,7),IBIP=$P(IBX,U,8),IBCMPT=$P(IBX,U,9) D + ... S IBTUNITS=$P(IBX,U,4),IBDT=$P(IBX,U,11) + . ; + . I 'IBTUNITS S IBK=IBI ; no combination, new line item charge + . S IBTUNITS=IBTUNITS+IBUNITS + . ; + . S ^TMP($J,"IBCRCSXR",+IBBS,+IBRVCD,IBK)="" + . S ^TMP($J,"IBCRCSXN",IBDT_" ",IBNM_" ",IBK)="" + . S ^TMP($J,"IBCRCSX",IBK)=IBRVCD_U_+IBBS_U_IBCHG_U_IBTUNITS_U_IBCPT_U_IBDV_U_IBIT_U_IBIP_U_IBCMPT_U_IBCS_U_IBDT_U_IBNM + . S IBY=0 F S IBY=$O(^TMP($J,"IBCRCC",IBI,"CC",IBY)) Q:'IBY S ^TMP($J,"IBCRCSX",IBK,"CC",IBY)=^TMP($J,"IBCRCC",IBI,"CC",IBY) + Q + ; +DSPCHRG(AA) ; display charges + ; Input: TMP($J,"IBCRCSx",...) = ... (from SORTCI) + ; + N IBX,IBI,IBJ,IBK,IBLN,IBCNT,IBRVCD,IBCHG,IBUNITS,IBDV,IBCMPT,IBCS,IBDT,IBNM,IBTOTAL,IBQUIT,IBY S (IBTOTAL,IBQUIT)=0 + ; + D DSPHDR(AA) S IBCNT=4 + ; + S IBI="" F S IBI=$O(^TMP($J,"IBCRCSXN",IBI)) Q:IBI="" D Q:IBQUIT + . S IBJ="" F S IBJ=$O(^TMP($J,"IBCRCSXN",IBI,IBJ)) Q:IBJ="" D Q:IBQUIT + .. S IBK=0 F S IBK=$O(^TMP($J,"IBCRCSXN",IBI,IBJ,IBK)) Q:'IBK D Q:IBQUIT + ... S IBLN=$G(^TMP($J,"IBCRCSX",IBK)) Q:IBLN="" + ... ; + ... ; add charges to RC multiple + ... S IBRVCD=$P(IBLN,U,1),IBCHG=$P(IBLN,U,3),IBUNITS=$P(IBLN,U,4),IBDV=$P(IBLN,U,6) + ... S IBCMPT=$P(IBLN,U,9),IBCS=$P(IBLN,U,10),IBDT=$P(IBLN,U,11),IBNM=$P(IBLN,U,12) + ... S IBTOTAL=IBTOTAL+(IBCHG*IBUNITS),IBCNT=IBCNT+1 + ... ; + ... S IBX=IBRVCD_U_IBCHG_U_IBUNITS_U_IBCMPT_U_IBCS_U_IBDT_U_IBDV_U_IBNM D DSPLN(IBX) + ... ; + ... S IBY=0 F S IBY=$O(^TMP($J,"IBCRCSX",IBK,"CC",IBY)) Q:'IBY D + .... S IBX=$G(^TMP($J,"IBCRCSX",IBK,"CC",IBY)) I IBX'="" D DISPLNC(IBX) S IBCNT=IBCNT+1 + ... I $O(^TMP($J,"IBCRCSX",IBK,"CC",0)) D DISPLNC("") S IBCNT=IBCNT+1 + ... ; + ... I IBCNT>20 S IBQUIT=$$PAUSE(IBCNT) Q:IBQUIT D DSPHDR(AA) S IBCNT=4 + ; + I +IBTOTAL W !,?72,"--------",!,?70,$J(IBTOTAL,10,2) S IBCNT=IBCNT+2 + I 'IBQUIT S IBQUIT=$$PAUSE(IBCNT) + Q + ; +DSPHDR(AA) ; + W @IOF,!,"Items and Charges on this Bill ("_$S('AA:"NOT ",1:"")_"Auto Add)" + W !,"Item",?18,"Date",?28,"Charge Set",?40,"Div",?47,"Type",?52,"RvCd",?57,"Units",?64,"Charge",?75,"Total" + W !,"--------------------------------------------------------------------------------" + Q + ; +DSPLN(LN) ; + N CS,DIV,CMP,RVCD,ITM,CHG,UNIT S LN=$G(LN) + S CS=$P(LN,U,5) I +CS S CS=$P($G(^IBE(363.1,+$P(LN,U,5),0)),U,1) + S DIV=$P($G(^DG(40.8,+$P(LN,U,7),0)),U,2) + S CMP=$S($P(LN,U,4)=1:"INST",$P(LN,U,4)=2:"PROF",1:"") + S RVCD=$P($G(^DGCR(399.2,+LN,0)),U,1) + S ITM=$P(LN,U,8),CHG=+$P(LN,U,2),UNIT=$P(LN,U,3) + W !,$E(ITM,1,15),?18,$$DATE($P(LN,U,6)),?28,$E(CS,1,7),?40,DIV,?47,CMP,?52,RVCD,?57,$J(UNIT,3),?62,$J(CHG,8,2),?71,$J((UNIT*CHG),9,2) + Q + ; +DISPLNC(LN) ; display charge adjustment commenmts + W !,?18,$G(LN) + Q + ; +DATE(X) ; + S X=$G(X),X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3) + Q X + ; +PAUSE(CNT) ; + N IBI F IBI=CNT:1:22 W ! + N DIR,DUOUT,DTOUT,DIRUT,IBX,X,Y S IBX=0,DIR(0)="E" D ^DIR K DIR I $D(DIRUT) S IBX=1 + Q IBX + ; +ITMNM(IBIFN,IBBS,IBIT,IBIP,IBCPT) ; return external form of the item name + N ITM S ITM="",IBBS=$G(IBBS),IBIT=$G(IBIT),IBIP=$G(IBIP),IBCPT=$G(IBCPT) + I +IBIP S ITM=$$NAME^IBCSC61(IBIT,IBIP) + I ITM="",+IBIT=4,+$G(IBIFN) S ITM=$$CPTNM(IBIFN,IBIT,IBIP) + I ITM="",+IBCPT S ITM=$P($$CPT^ICPTCOD(+IBCPT,DT),U,2) + I ITM="" S ITM=$$EMUTL^IBCRU1(IBBS) + Q ITM + ; +CPTNM(IBIFN,TYPE,ITEM) ; retrurn external name of the charge item if it is a CPT item (type=399,42,.1) + N IBX,NAME S IBX=0,NAME="" + I +$G(TYPE)=4 S IBX=$G(^DGCR(399,+$G(IBIFN),"CP",+$G(ITEM),0)) + I +IBX S NAME=$P($$CPT^ICPTCOD(+$P(IBX,U,1),DT),U,2) + I +IBX S IBX=$$GETMOD^IBEFUNC(+$G(IBIFN),+$G(ITEM),1) I IBX'="" S NAME=NAME_"-"_IBX + Q NAME + ; + ; + ; + ; +NOTES(IBIFN,PAUSE) ; compile and print charge notes for a bill + ; + ; Current Checks are for those Treating Specialties that should not be billed using DRG: + ; - Inpatient Institutional Reasonable Charges bill contains SNF Treating Specialty + ; - Inpatient Institutional Reasonable Charges bill contains Observation Treating Specialty + ; + I $D(ZTQUEUED)!(+$G(IBAUTO)) Q + N IB0,IBU,PTF,BEG,END,IBMVLN,IBENDDT,IBMDRG,IBFND,IBMSG,IBX S IBFND=0 K ^TMP($J,"IBCRC-PTF") + S IB0=$G(^DGCR(399,+$G(IBIFN),0)) Q:IB0="" S IBU=$G(^DGCR(399,+$G(IBIFN),"U")) Q:'IBU + ; + I '$$BILLRATE^IBCRU3($P(IB0,U,7),$P(IB0,U,5),$P(IB0,U,3),"RC") Q ; not Reasonable Charges bill + ; + ; Outpatient Freestanding bill: display message if this is a non-provider based freestanding bill + I $P(IB0,U,5)=3,$P(IB0,U,3)'<$$VERSDT^IBCRU8(2),$P($$RCDV^IBCRU8(+$P(IB0,U,22)),U,3)=3 D + . S IBFND=IBFND+1,IBX=">>> Bill Division is Freestanding Non-Provider with Professional Charges only.",IBMSG(IBFND)=IBX + ; + ; Inpatient Institutional bill: check for treating specialties that should not be billed by DRG + I +$P(IB0,U,8),$P(IB0,U,5)<3,$P(IB0,U,27)<2 D + . ; + . S PTF=+$P(IB0,U,8),BEG=+$P(IBU,U,1)\1,END=$S(+$P(IBU,U,2):+$P(IBU,U,2)\1,1:DT) + . ; + . D PTF^IBCRBG(PTF) + . ; + . S IBENDDT=BEG F S IBENDDT=$O(^TMP($J,"IBCRC-PTF",IBENDDT)) Q:'IBENDDT D I IBENDDT>END Q + .. I (IBENDDT\1)=BEG,BEG'=END Q + .. ; + .. S IBMVLN=$G(^TMP($J,"IBCRC-PTF",IBENDDT)),IBMVLN=+$P(IBMVLN,U,6) Q:'IBMVLN + .. S IBMDRG=$$NODRG^IBCRBG2(IBMVLN) Q:'IBMDRG + .. ; + .. S IBFND=IBFND+1,IBX=">>> "_$P(IBMDRG,U,2)_" ("_$$FMTE^XLFDT(IBENDDT,2)_") not billed using DRG" + .. S:IBMDRG["Nursing" IBX=IBX_", use SNF." S:IBMDRG["Observa" IBX=IBX_", use Procedures." + .. S IBMSG(IBFND)=$G(IBX) + ; + I +IBFND D I +$G(PAUSE) S IBFND=$$PAUSE(21) + . W ! S IBX="" F S IBX=$O(IBMSG(IBX)) Q:IBX="" W !,IBMSG(IBX) + K ^TMP($J,"IBCRC-PTF") + Q diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRCC.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRCC.m index cbb97d67..f508a09f 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRCC.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRCC.m @@ -1,125 +1,106 @@ -IBCRCC ;ALB/ARH - RATES: CALCULATION OF ITEM CHARGE ;22-MAY-1996 - ;;2.0;INTEGRATED BILLING;**52,80,106,138,245,223,309,347,370**;21-MAR-94;Build 5 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ; ITMCHG and RATECHG are basic item/set/rate charge functions, IBCRCI contains more standard callable functions - ; -ITMCHG(CS,ITEM,EVDT,MOD,ARR) ; get the base unit charges for a specific item, given a charge set, item and date - ; this is the primary function to get an item charge and works for all Charge Methods, given an Item - ; returns ARR = count of items in array ^ total charge for item ^ total base charge - ; ARR(x) = charge item IFN (if any) ^ rev code (if any) ^ $ charge ^ $ base charge - ; checks Item effective and inactive dates, modifier match, and only sets array if the charge is non-zero - ; each item will be passed back separately in the array, no combination of charges - ; - N IBCSBR,IBEVDT,IBEFDT,IBXREF,IBITEM,IBDA,IBLN,IBCHRG,IBITMFND K ARR S ARR=0 - S CS=+$G(CS),IBEVDT=$S(+$G(EVDT):+EVDT,1:DT),IBITEM=+$G(ITEM),MOD=$G(MOD) I 'CS!'IBITEM Q - S IBCSBR=$$CSBR^IBCRU3(CS) - ; - ; va cost - I $P(IBCSBR,U,5)=2 D Q ; va cost - . I $P(IBCSBR,U,1)["PROSTHETICS" S IBCHRG=$$PICOST(IBITEM) I +IBCHRG D SETARR(0,0,+IBCHRG,.ARR) Q - . I $P(IBCSBR,U,1)["PRESCRIPTION" S IBCHRG=$$RXCOST(IBITEM) I +IBCHRG D SETARR(0,0,+IBCHRG,.ARR) Q - ; - ; all others - have Charge Item entries - ; - ; find most recent Charge Item for the item, search until modifiers match (only BI=CPT should have mods defined) - S IBXREF="AIVDTS"_CS,IBITMFND=0 - S IBEFDT=-(IBEVDT+.01) F S IBEFDT=$O(^IBA(363.2,IBXREF,IBITEM,IBEFDT)) Q:'IBEFDT D Q:IBITMFND - . S IBDA=0 F S IBDA=$O(^IBA(363.2,IBXREF,IBITEM,IBEFDT,IBDA)) Q:'IBDA D - .. S IBLN=$G(^IBA(363.2,IBDA,0)) - .. I +$P(IBLN,U,7)'=+MOD Q ; charge item modifier does not match modifier passed in - .. S IBITMFND=1 ; item found - .. I +$P(IBLN,U,4),+$P(IBLN,U,4)EVDT!(+IBINADT&(IBINADT79999,ITEM<90000 S (CS,PRV)="" - I +$G(CS) S IBSGFN=+$$CSSG^IBCRU6(+CS,"",2,.IBSG) - I +$G(PRV),+IBSGFN S IBPC=$$GET^XUA4A72(PRV,EVDT) - ; - S IBI=0 F S IBI=$O(IBSG(IBI)) Q:'IBI S IBSGFN=+IBSG(IBI) I +IBSGFN D - . S IBPDFN=0 F S IBPDFN=$O(^IBE(363.34,"C",+IBSGFN,IBPDFN)) Q:'IBPDFN D Q:IBPDTY'="" - .. I '$O(^IBE(363.34,+IBPDFN,11,"B",+IBPC,0)) Q - .. S IBPD0=$G(^IBE(363.34,+IBPDFN,0)),IBY=$P(IBPD0,U,3) Q:IBY="" - .. S IBY=+IBY/100,IBX=IBY*IBX - .. S IBPDTY=U_$P($G(^VA(200,+PRV,0)),U,1)_" - "_$P(IBPD0,U,1)_" "_$P(IBPD0,U,3)_"% of "_$J(CHG,0,2)_U_+IBY - Q IBX_IBPDTY - ; -MODCHG(CS,CHG,MODS) ; return adjusted amount due to RC modifier adjustment - ; straight adjustment for RC Physician charges by modifier, if no modifier adjustment returns original amount - ; Input: Charge Set, Procedure Charge, Modifiers - list with modifier IEN's separated by ',' - ; Output: discounted amount ^ comment (if discounted) ^ percent discount - ; - N IBCS0,IBBR0,IBMOD,IBMODS,IBMODE,IBDSCNT,IBPDTY,IBI,IBX,IBY - S CHG=+$G(CHG),MODS=$G(MODS),(IBBR0,IBPDTY,IBMODS)="",IBDSCNT=1,IBX=+CHG - I +$G(CS) S IBCS0=$G(^IBE(363.1,+CS,0)),IBBR0=$G(^IBE(363.3,+$P(IBCS0,U,2),0)) - I $P(IBBR0,U,1)'["RC PHYSICIAN" S MODS="" ; professional charge only - I $P(IBBR0,U,4)'=2 S MODS="" ; CPT item only - I 'CHG S MODS="" - ; - I +MODS F IBI=1:1 S IBMOD=$P(MODS,",",IBI) Q:'IBMOD S IBY=0 D - . I IBMOD=3 S IBMODE=22,IBY=1.2,IBX=IBX*IBY ; modifier 22 at 120% adjustment - . I IBMOD=10 S IBMODE=50,IBY=1.54,IBX=IBX*IBY ; modifier 50 at 154% adjustment - . I +IBY S IBMODS=IBMODS_$S(IBMODS="":"",1:",")_IBMODE,IBDSCNT=IBDSCNT*IBY ; allow for multiple discounts - I IBMODS'="" S IBPDTY=U_"Modifier "_IBMODS_" Adjustment "_(IBDSCNT*100)_"% of "_$J(CHG,0,2)_U_+IBDSCNT - Q IBX_IBPDTY - ; -HRUNIT(HRS) ; returns Hour Units based on the Hours passed in - ; Hour Units are the hours rounded to the nearest whole hour (less than 30 minutes is 0 units) - N IBX S IBX=0 I +$G(HRS) S IBX=$J(HRS,0,0) - Q IBX - ; -MLUNIT(MLS) ; returns Miles Units based on the Miles passed in - ; Mile Units are the miles rounded to the nearest whole mile - N IBX S IBX=0 I +$G(MLS) S IBX=$J(MLS,0,0) I 'IBX S IBX=1 - Q IBX - ; -MNUNIT(MNS) ; return Minute Units based on the Minutes passed in - ; Minute Units are 15 minute intervals, rounded up after any minutes - N IBX S IBX=0 I +$G(MNS) S IBX=(MNS\15) S:+(MNS#15) IBX=IBX+1 I 'IBX S IBX=1 - Q IBX +IBCRCC ;ALB/ARH - RATES: CALCULATION OF ITEM CHARGE ;22-MAY-1996 + ;;2.0;INTEGRATED BILLING;**52,80,106,138,245,223,309,347**;21-MAR-94;Build 24 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; + ; ITMCHG and RATECHG are basic item/set/rate charge functions, IBCRCI contains more standard callable functions + ; +ITMCHG(CS,ITEM,EVDT,MOD,ARR) ; get the base unit charges for a specific item, given a charge set, item and date + ; this is the primary function to get an item charge and works for all Charge Methods, given an Item + ; returns ARR = count of items in array ^ total charge for item ^ total base charge + ; ARR(x) = charge item IFN (if any) ^ rev code (if any) ^ $ charge ^ $ base charge + ; checks Item effective and inactive dates, modifier match, and only sets array if the charge is non-zero + ; each item will be passed back separately in the array, no combination of charges + ; + N IBCSBR,IBEVDT,IBEFDT,IBXREF,IBITEM,IBDA,IBLN,IBCHRG,IBITMFND K ARR S ARR=0 + S CS=+$G(CS),IBEVDT=$S(+$G(EVDT):+EVDT,1:DT),IBITEM=+$G(ITEM),MOD=$G(MOD) I 'CS!'IBITEM Q + S IBCSBR=$$CSBR^IBCRU3(CS) + ; + ; va cost + I $P(IBCSBR,U,5)=2 D Q ; va cost + . I $P(IBCSBR,U,1)["PROSTHETICS" S IBCHRG=$$PICOST(IBITEM) I +IBCHRG D SETARR(0,0,+IBCHRG,.ARR) Q + . I $P(IBCSBR,U,1)["PRESCRIPTION" S IBCHRG=$$RXCOST(IBITEM) I +IBCHRG D SETARR(0,0,+IBCHRG,.ARR) Q + ; + ; all others - have Charge Item entries + ; + ; find most recent Charge Item for the item, search until modifiers match (only BI=CPT should have mods defined) + S IBXREF="AIVDTS"_CS,IBITMFND=0 + S IBEFDT=-(IBEVDT+.01) F S IBEFDT=$O(^IBA(363.2,IBXREF,IBITEM,IBEFDT)) Q:'IBEFDT D Q:IBITMFND + . S IBDA=0 F S IBDA=$O(^IBA(363.2,IBXREF,IBITEM,IBEFDT,IBDA)) Q:'IBDA D + .. S IBLN=$G(^IBA(363.2,IBDA,0)) + .. I +$P(IBLN,U,7)'=+MOD Q ; charge item modifier does not match modifier passed in + .. S IBITMFND=1 ; item found + .. I +$P(IBLN,U,4),+$P(IBLN,U,4)EVDT!(+IBINADT&(IBINADT79999,ITEM<90000 S (CS,PRV)="" + I +$G(CS) S IBSGFN=+$$CSSG^IBCRU6(+CS,"",2,.IBSG) + I +$G(PRV),+IBSGFN S IBPC=$$GET^XUA4A72(PRV,EVDT) + ; + S IBI=0 F S IBI=$O(IBSG(IBI)) Q:'IBI S IBSGFN=+IBSG(IBI) I +IBSGFN D + . S IBPDFN=0 F S IBPDFN=$O(^IBE(363.34,"C",+IBSGFN,IBPDFN)) Q:'IBPDFN D Q:IBPDTY'="" + .. I '$O(^IBE(363.34,+IBPDFN,11,"B",+IBPC,0)) Q + .. S IBPD0=$G(^IBE(363.34,+IBPDFN,0)),IBY=$P(IBPD0,U,3) Q:IBY="" + .. S IBY=+IBY/100,IBX=IBY*IBX + .. S IBPDTY=U_$P($G(^VA(200,+PRV,0)),U,1)_" - "_$P(IBPD0,U,1)_" "_$P(IBPD0,U,3)_"% of "_$J(CHG,0,2)_U_+IBY + Q IBX_IBPDTY + ; +HRUNIT(HRS) ; returns Hour Units based on the Hours passed in + ; Hour Units are the hours rounded to the nearest whole hour (less than 30 minutes is 0 units) + N IBX S IBX=0 I +$G(HRS) S IBX=$J(HRS,0,0) + Q IBX + ; +MLUNIT(MLS) ; returns Miles Units based on the Miles passed in + ; Mile Units are the miles rounded to the nearest whole mile + N IBX S IBX=0 I +$G(MLS) S IBX=$J(MLS,0,0) I 'IBX S IBX=1 + Q IBX + ; +MNUNIT(MNS) ; return Minute Units based on the Minutes passed in + ; Minute Units are 15 minute intervals, rounded down for less than 5 minutes + N IBX S IBX=0 I +$G(MNS) S IBX=(MNS\15) S:(MNS#15)>4 IBX=IBX+1 I 'IBX S IBX=1 + Q IBX diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRHBRV.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRHBRV.m index 307effe6..6b0534b4 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRHBRV.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRHBRV.m @@ -1,177 +1,181 @@ -IBCRHBRV ;ALB/ARH - RATES: UPLOAD (RC) VERSION FUNCTIONS ; 14-FEB-01 - ;;2.0;INTEGRATED BILLING;**148,169,245,270,285,298,325,334,355,360,365,382,390**;21-MAR-94;Build 2 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ; RC functions related to Version. Update VLIST with new versions. Update FTYPE if new types of files. - ; -SELVERS() ; get version to upload from user - N DIR,DIRUT,DTOUT,DUOUT,IBVLIST,IBQUIT,IBVERS,IBI,IBJ,IBX,X,Y - ; - S IBVLIST=$$VERSTR(),IBQUIT=0,IBVERS=0 - ; - W !!,"Select the version of Reasonable Charges to upload." - S DIR("?",1)="Enter the code from the list corresponding to the version of Reasonable Charges" - S DIR("?",2)="to upload. There are no version 1.3, 2.2, or 2.10 (ten) RC charges." S DIR("?",3)=" " - S DIR("?",4)="Versions: "_IBVLIST S DIR("?",5)=" " S DIR("?")="Enter version number to upload." - ; - F IBI=1:1 D I +IBQUIT Q - . W !!,?5,"Select one of the following:",! - . F IBJ=1:1 S IBX=$P(IBVLIST,",",IBJ) Q:'IBX W !,?10,IBX,?20,"Reasonable Charges version ",IBX - . ; - . W ! S DIR("A")="Enter Version" S DIR(0)="FO^1:5" D ^DIR I $D(DIRUT) S IBQUIT=1 - . I Y>0,(","_IBVLIST_",")[(","_Y_",") S IBVERS=Y,IBQUIT=1 W " Reasonable Charges version ",IBVERS - ; - Q IBVERS - ; -VERSION() ; return currently loaded version of RC files (1, 1.1, ...) - N IBX S IBX=$G(^XTMP("IBCR RC SITE","VERSION")) - Q IBX - ; -VERSDT(VERS) ; return Effective Date of a version of RC files, either version passed in or currently loaded version - N IBI,LINE,IBX S IBX="" S VERS=+$G(VERS) I 'VERS S VERS=$$VERSION - I +VERS F IBI=1:1 S LINE=$P($T(VLIST+IBI),";;",2,99) Q:'LINE I VERS=+LINE S IBX=$P(LINE,U,3) - Q IBX - ; -VERSEDT(VERS) ; return Inactive Date of a version of RC files, either version passed in or currently loaded version - N IBI,LINE,IBX S IBX="" S VERS=+$G(VERS) I 'VERS S VERS=$$VERSION - I +VERS F IBI=1:1 S LINE=$P($T(VLIST+IBI),";;",2,99) Q:'LINE I VERS=+LINE S IBX=$P(LINE,U,4) - Q IBX - ; -VERSALL() ; return all RC versions and corresponding effective date 'VERS;EFFDT^VERS;EFFDT^...' - N IBI,LINE,IBX,IBC S IBX="",IBC="" - F IBI=1:1 S LINE=$P($T(VLIST+IBI),";;",2,99) Q:'LINE S IBX=IBX_IBC_+LINE_";"_$P(LINE,U,3),IBC=U - Q IBX - ; -VERSEND() ; return all RC versions and corresponding inactive date 'VERS;INACTIVE DT^VERS;INACTIVE DT^...' - N IBI,LINE,IBX,IBC S IBX="",IBC="" - F IBI=1:1 S LINE=$P($T(VLIST+IBI),";;",2,99) Q:'LINE I $P(LINE,U,4) S IBX=IBX_IBC_+LINE_";"_$P(LINE,U,4),IBC=U - Q IBX - ; -VERSITE(SITE) ; returns the list of versions loaded for a particular site - ; *** uses 99201 in the RC PHYSICIAN set to check which versions/dates are loaded - ; *** so 99201 must have a pro charge in all versions, if not it must be replaced with an item that does - N IBCS,IBXRF,IBITM,IBVERS,IBCSFN,IBI,IBV,IBX,IBY,IBC - S IBVERS=$$VERSALL,IBITM=99201 - ; - I $G(SITE)'="" S IBCS="RC-PHYSICIAN" F S IBCS=$O(^IBE(363.1,"B",IBCS)) Q:IBCS'["RC-PHYSICIAN" D - . S IBV=$L(IBCS," ") I $P(IBCS," ",IBV)'=SITE Q - . S IBCSFN=$O(^IBE(363.1,"B",IBCS,0)) Q:'IBCSFN S IBXRF="AIVDTS"_IBCSFN - . F IBI=1:1 S IBV=$P(IBVERS,U,IBI) Q:'IBV I $O(^IBA(363.2,IBXRF,IBITM,-$P(IBV,";",2),0)) S IBY(+IBV)="" - ; - S (IBX,IBC)="" F IBI=1:1 S IBV=+$P(IBVERS,U,IBI) Q:'IBV I $D(IBY(IBV)) S IBX=IBX_IBC_IBV S IBC="," - ; - Q IBX - ; -MSGSITE(SITE) ; display a message indicating which versions are loaded for a site - N IBVERS Q:'$G(SITE) - S IBVERS=$$VERSITE(SITE) - I 'IBVERS W !!,?12,"There appear to be no RC charges already loaded for "_SITE_"." - I +IBVERS W !!,?12,"RC versions "_IBVERS_" appear to be already loaded for "_SITE_"." - Q - ; -MSGVERS(SITE) ; check if versions are being loaded in the correct order, should be loaded in date order - ; - if loading a version that has already been loaded for the site - ; - if loading a version when any future versions have already been loaded for the site - ; - if loading a version when the last version has not yet been loaded for the site - ; *** uses 99201 in the RC PHYSICIAN set to check which versions/dates are loaded - ; *** so 99201 must have a pro charge in all versions, if not it must be replaced with an item that does - N IBVERS,IBVDTC,IBVERSIN,IBVERSC,IBVERSO,IBI,VERSTR Q:'$G(SITE) - ; - S IBVERS=$$VERSION Q:'IBVERS S IBVDTC=$$VERSDT,IBVERSIN=","_$$VERSITE(SITE)_",",IBVERSC=","_IBVERS_"," - ; - ; check if loading a version that has already been loaded - I IBVERSIN[IBVERSC D - . W !!,?5,"*** It appears version RC v",IBVERS," has already been loaded for this site ***" - ; - ; check if loading a version when any future versions have already been loaded - S VERSTR=","_$$VERSTR()_",",VERSTR=$P(VERSTR,IBVERSC,2) ; all versions after current version - F IBI=1:1 S IBVERSO=$P(VERSTR,",",IBI) Q:'IBVERSO I IBVERSIN[(","_IBVERSO_",") D - . W !!,?5,">>> Currently trying to load RC v"_IBVERS_" but RC v"_IBVERSO_" appears to be already",!,?9,"loaded for this site. The versions should be loaded in date order." - ; - ; check if loading a version when the last version has not yet been loaded - S VERSTR=","_$$VERSTR(1)_",",VERSTR=$P(VERSTR,IBVERSC,2) ; all versions before current version, reverse order - S IBVERSO=$P(VERSTR,",",1) I +IBVERSO,IBVERSIN'[(","_IBVERSO_",") D - . W !!,?5,"*** Currently trying to load RC v"_IBVERS_" but RC v"_IBVERSO_" does not appear to be",!,?9,"loaded for this site. The versions should be loaded in date order." - . W !!,?5,">>> Continue only if there will never be a need to bill events before ",!,?9,$$FMTE^XLFDT(IBVDTC,2)," for this site. If RC v"_IBVERSO_" will be needed for this site then",!,?9,"load it first." - ; - Q - ; -VERSTR(RVRS) ; returns string containing list of all Reasonable Charges versions with charges, separated by "," - ; RVRS - if set, returns the list of versions in reverse order - N IBI,LINE,IBS,IBR,IBC,IBX S (IBS,IBR,IBC,IBX)="" - F IBI=1:1 S LINE=$P($T(VLIST+IBI),";;",2,99) Q:'LINE S IBS=IBS_IBC_+LINE,IBR=+LINE_IBC_IBR S IBC="," - S IBX=IBS I +$G(RVRS) S IBX=IBR - Q IBX - ; - ; - ; - ; - ; - ; - ; - ; File Names: 'IBRCyymmx.TXT' w/ yymm - year month of version release (except v1) - ; 'IBRCyymm', file version identifier prefix, from VLIST text version description - ; x=A-I/F, single character file identifier, from FTYPE text file description - ; -FILES(IBFILES,VERS) ; returns array of source Host Files and data for version requested, pass IBFILES by reference - N IBI,LINE,IBTYPE,IBFILE,IBNAME,IBDESC S VERS=+$G(VERS) I 'VERS S VERS=1 - ; - ; get requested versions data - F IBI=1:1 S LINE=$P($T(VLIST+IBI),";;",2,99) Q:'LINE I VERS=+LINE S IBTYPE=$P(LINE,U,2),IBFILE=$P(LINE,U,5) Q - ; - ; get requested versions files - I +$G(IBTYPE) F IBI=1:1 S LINE=$P($T(@("FT"_IBTYPE)+IBI),";;",2,99) Q:LINE="" D - . S IBNAME=IBFILE_$P(LINE,":",1)_".TXT",IBDESC="RC v"_+VERS_" "_$P(LINE,":",2,99) - . S IBFILES(IBNAME)=IBDESC - Q - ; - ; - ; versions and their critical data, add new versions here -VLIST ; version ^ file type/version ^ effective date ^ inactive date ^ file prefix - ;;1.0^1^2990901^3001101^IBRCV - ;;1.1^1^3001102^3010507^IBRC0011 - ;;1.2^1^3010508^3030428^IBRC0105 - ;;1.4^1^3030429^3031218^IBRC0304 - ;;2.0^2^3031219^3040414^IBRC0312 - ;;2.1^2^3040415^3041231^IBRC0404 - ;;2.3^2^3050101^3050410^IBRC0501 - ;;2.4^2^3050411^3050930^IBRC0504 - ;;2.5^2^3051001^3051231^IBRC0510 - ;;2.6^2^3060101^3060824^IBRC0601 - ;;2.7^2^3060825^3060930^IBRC0608 - ;;2.8^2^3061001^3061231^IBRC0610 - ;;2.9^2^3070101^3070930^IBRC0701 - ;;2.11^2^3071001^3071231^IBRC0710 - ;;3.1^2^3080101^^IBRC0801 - ;; - ; - ; - ; - ; - ; - ; - ; -FTYPE ; file type/versions and relevant data - ; file identifer is used with XTMP subscript 'IBCR RC ' and routine label to parse file - ; file identifier : file name/description ^ file identifier ^ number of columns (for v2+) - ; -FT1 ; Reasonable Charge File Type 1 files - ;;A:Inpatient Facility Charges^A - ;;B:Inpatient Facility Area Factors^B - ;;C:Outpatient Facility Charges^C - ;;D:Outpatient Facility Area Factors^D - ;;E:Physician Charges E^E - ;;F:Physician Charges F^F - ;;G:Physician Charges G^G - ;;H:Physician Area Factors^H - ;;I:Physician Unit Area Factors^I - ;; - ; -FT2 ; Reasonable Charges File Type 2 files - ;;A:Inpatient Facility Charges^A^10 - ;;B:Outpatient Facility Charges^B^14 - ;;C:Professional Charges^C^23 - ;;D:Service Category Codes^D^4 - ;;E:Area Factors^E^41 - ;;F:VA Sites and Zip Codes^F^4 - ;; +IBCRHBRV ;ALB/ARH - RATES: UPLOAD (RC) VERSION FUNCTIONS ; 14-FEB-01 + ;;2.0;INTEGRATED BILLING;**148,169,245,270,285,298,325,334,355,360,365**;21-MAR-94;Build 2 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; + ; RC functions related to Version, most have to be updated when a new version is to be exported + ; +SELVERS() ; get version to upload from user + N DIR,DIRUT,DTOUT,DUOUT,X,Y,IB,IBV,IBVP,IBX + S IBV="1.0^1.1^1.2^1.4^2.0^2.1^2.3^2.4^2.5^2.6^2.7^2.8^2.9" ; List of valid version numbers + S IBX=0 + W !!,"Select the version of Reasonable Charges to upload.",! + S DIR("?")="Enter a code from the list corresponding to the version of Reasonable Charges to upload. There was no version 1.3 nor 2.2 of Reasonable Charges." + S DIR(0)="SO^" + F IB=1:1:$L(IBV,U) S IBVP=$P(IBV,U,IB),DIR(0)=DIR(0)_+IBVP_":Reasonable Charges version "_IBVP_";" + D ^DIR K DIR S:$L(Y)=1 Y=Y_".0" S IBX=+$S(IBV[Y:Y,1:0) + Q IBX + ; +VERSION() ; return currently loaded version of RC files (1, 1.1, ...) + N IBX S IBX=$G(^XTMP("IBCR RC SITE","VERSION")) + Q IBX + ; +VERSDT(VERS) ; return Effective Date of a version of RC files, either version passed in or currently loaded version + N IBX S:'$G(VERS) VERS=$$VERSION + S IBX=$S(VERS=1:2990901,VERS=1.1:3001102,VERS=1.2:3010508,VERS=1.4:3030429,VERS=2:3031219,VERS=2.1:3040415,VERS=2.3:3050101,VERS=2.4:3050411,VERS=2.5:3051001,VERS=2.6:3060101,VERS=2.7:3060825,VERS=2.8:3061001,VERS=2.9:3070101,1:"") + Q IBX + ; +VERSEDT(VERS) ; return Inactive Date of a version of RC files, either version passed in or currently loaded version + N IBX S:'$G(VERS) VERS=$$VERSION + S IBX=$S(VERS=1:3001101,VERS=1.1:3010507,VERS=1.2:3030428,VERS=1.4:3031218,VERS=2:3040414,VERS=2.1:3041231,VERS=2.3:3050410,VERS=2.4:3050930,VERS=2.5:3051231,VERS=2.6:3060824,VERS=2.7:3060930,VERS=2.8:3061231,1:"") + Q IBX + ; +VERSALL() ; returns all RC versions and corresponding effective date + N IBX S IBX="1;2990901^1.1;3001102^1.2;3010508^1.4;3030429^2;3031219^2.1;3040415^2.3;3050101^2.4;3050411^2.5;3051001^2.6;3060101^2.7;3060825^2.8;3061001^2.9;3070101" + Q IBX + ; +VERSEND() ; returns all RC versions and corresponding inactive dates + N IBX S IBX="1;3001101^1.1;3010507^1.2;3030428^1.4;3031218^2;3040414^2.1;3041231^2.3;3050410^2.4;3050930^2.5;3051231^2.6;3060824^2.7;3060930^2.8;3061231" + Q IBX + ; + ; +VERSITE(SITE) ; returns the list of versions loaded for a particular site + ; *** uses 99201 in the RC PHYSICIAN set to check which versions/dates are loaded + ; *** so 99201 must have a pro charge in all versions, if not it must be replaced with an item that does + N IBCS,IBXRF,IBITM,IBVERS,IBCSFN,IBI,IBV,IBX,IBY S IBX="" + S IBVERS=$$VERSALL,IBITM=99201 + ; + I $G(SITE)'="" S IBCS="RC-PHYSICIAN" F S IBCS=$O(^IBE(363.1,"B",IBCS)) Q:IBCS'["RC-PHYSICIAN" D + . S IBV=$L(IBCS," ") I $P(IBCS," ",IBV)'=SITE Q + . S IBCSFN=$O(^IBE(363.1,"B",IBCS,0)) Q:'IBCSFN S IBXRF="AIVDTS"_IBCSFN + . F IBI=1:1 S IBV=$P(IBVERS,U,IBI) Q:'IBV I $O(^IBA(363.2,IBXRF,IBITM,-$P(IBV,";",2),0)) S IBY(+IBV)="" + S IBV="" F S IBV=$O(IBY(IBV)) Q:'IBV S IBX=IBX_IBV_"," + ; + I $E(IBX,$L(IBX))="," S IBX=$E(IBX,1,$L(IBX)-1) + Q IBX + ; +MSGSITE(SITE) ; display a message indicating which versions are loaded for a site + N IBVERS Q:'$G(SITE) + S IBVERS=$$VERSITE(SITE) + I 'IBVERS W !!,?12,"There appear to be no RC charges already loaded for "_SITE_"." + I +IBVERS W !!,?12,"RC versions "_IBVERS_" appear to be already loaded for "_SITE_"." + Q + ; +MSGVERS(SITE) ; check if versions are being loaded in the correct order, should be loaded in date order + ; displays messages to the user: + ; - if loading a version that has already been loaded for the site + ; - if loading a version when any future versions have already been loaded for the site + ; - if loading a version when the last version has not yet been loaded for the site + ; *** uses 99201 in the RC PHYSICIAN set to check which versions/dates are loaded + ; *** so 99201 must have a pro charge in all versions, if not it must be replaced with an item that does + N IBVERS,IBVDTC,IBVERSIN,IBVERSO Q:'$G(SITE) + ; + S IBVERS=$$VERSION Q:'IBVERS S IBVDTC=$$VERSDT,IBVERSIN=","_$$VERSITE(SITE)_"," + ; + ; check if loading a version that has already been loaded + I IBVERSIN[(","_IBVERS_",") D + . W !!,?5,"*** It appears version RC v",IBVERS," has already been loaded for this site ***" + ; + ; check if loading a version when any future versions have already been loaded + F IBVERSO=1,1.1,1.2,1.4,2,2.1,2.3,2.4,2.5,2.6,2.7,2.8,2.9 I IBVERSO>IBVERS D + . I IBVERSIN[(","_IBVERSO_",") D + .. W !!,?5,">>> Currently trying to load RC v"_IBVERS_" but RC v"_IBVERSO_" appears to be already",!,?9,"loaded for this site. The versions should be loaded in date order." + ; + ; check if loading a version when the last version has not yet been loaded + F IBVERSO=2.9,2.8,2.7,2.6,2.5,2.4,2.3,2.1,2,1.4,1.2,1.1,1 I IBVERS>IBVERSO D Q + . I IBVERSIN'[(","_IBVERSO_",") D + .. W !!,?5,"*** Currently trying to load RC v"_IBVERS_" but RC v"_IBVERSO_" does not appear to be",!,?9,"loaded for this site. The versions should be loaded in date order." + .. W !!,?5,">>> Continue only if there will never be a need to bill events before ",!,?9,$$FMTE^XLFDT(IBVDTC,2)," for this site. If RC v"_IBVERSO_" will be needed for this site then",!,?9,"load it first." + ; + Q + ; +FILES(IBFILES,VERS) ; source Host file name, description, and routine label that parses the file + ; the subscript used for the file in XTMP is 'IBCR RC '_X w/ X=the routine label that parses the file + ; + I $G(VERS)=1.1 G FBREAL + I $G(VERS)=1.2 G FCREAL + I $G(VERS)=1.4 G FDREAL + I $G(VERS)=2 G FEREAL + I $G(VERS)=2.1 G FFREAL + I $G(VERS)=2.3 G FGREAL + I $G(VERS)=2.4 G FHREAL + I $G(VERS)=2.5 G FIREAL^IBCRHBV1 + I $G(VERS)=2.6 G FJREAL^IBCRHBV1 + I $G(VERS)=2.7 G FKREAL^IBCRHBV1 + I $G(VERS)=2.8 G FLREAL^IBCRHBV1 + I $G(VERS)=2.9 G FMREAL^IBCRHBV1 + ; +FREAL S IBFILES("IBRCVA.TXT")="RC v1 Inpatient Facility Charges^A" + S IBFILES("IBRCVB.TXT")="RC v1 Inpatient Facility Area Factors^B" + S IBFILES("IBRCVC.TXT")="RC v1 Outpatient Facility Charges^C" + S IBFILES("IBRCVD.TXT")="RC v1 Outpatient Facility Area Factors^D" + S IBFILES("IBRCVE.TXT")="RC v1 Physician Charges E^E" + S IBFILES("IBRCVF.TXT")="RC v1 Physician Charges F^F" + S IBFILES("IBRCVG.TXT")="RC v1 Physician Charges G^G" + S IBFILES("IBRCVH.TXT")="RC v1 Physician Area Factors^H" + S IBFILES("IBRCVI.TXT")="RC v1 Physician Unit Area Factors^I" + Q + ; +FBREAL S IBFILES("IBRC0011A.TXT")="RC v1.1 Inpatient Facility Charges^A" + S IBFILES("IBRC0011B.TXT")="RC v1.1 Inpatient Facility Area Factors^B" + S IBFILES("IBRC0011C.TXT")="RC v1.1 Outpatient Facility Charges^C" + S IBFILES("IBRC0011D.TXT")="RC v1.1 Outpatient Facility Area Factors^D" + S IBFILES("IBRC0011E.TXT")="RC v1.1 Physician Charges E^E" + S IBFILES("IBRC0011F.TXT")="RC v1.1 Physician Charges F^F" + S IBFILES("IBRC0011G.TXT")="RC v1.1 Physician Charges G^G" + S IBFILES("IBRC0011H.TXT")="RC v1.1 Physician Area Factors^H" + S IBFILES("IBRC0011I.TXT")="RC v1.1 Physician Unit Area Factors^I" + Q + ; +FCREAL S IBFILES("IBRC0105A.TXT")="RC v1.2 Inpatient Facility Charges^A" + S IBFILES("IBRC0105B.TXT")="RC v1.2 Inpatient Facility Area Factors^B" + S IBFILES("IBRC0105C.TXT")="RC v1.2 Outpatient Facility Charges^C" + S IBFILES("IBRC0105D.TXT")="RC v1.2 Outpatient Facility Area Factors^D" + S IBFILES("IBRC0105E.TXT")="RC v1.2 Physician Charges E^E" + S IBFILES("IBRC0105F.TXT")="RC v1.2 Physician Charges F^F" + S IBFILES("IBRC0105G.TXT")="RC v1.2 Physician Charges G^G" + S IBFILES("IBRC0105H.TXT")="RC v1.2 Physician Area Factors^H" + S IBFILES("IBRC0105I.TXT")="RC v1.2 Physician Unit Area Factors^I" + Q + ; +FDREAL S IBFILES("IBRC0304A.TXT")="RC v1.4 Inpatient Facility Charges^A" + S IBFILES("IBRC0304B.TXT")="RC v1.4 Inpatient Facility Area Factors^B" + S IBFILES("IBRC0304C.TXT")="RC v1.4 Outpatient Facility Charges^C" + S IBFILES("IBRC0304D.TXT")="RC v1.4 Outpatient Facility Area Factors^D" + S IBFILES("IBRC0304E.TXT")="RC v1.4 Physician Charges E^E" + S IBFILES("IBRC0304F.TXT")="RC v1.4 Physician Charges F^F" + S IBFILES("IBRC0304G.TXT")="RC v1.4 Physician Charges G^G" + S IBFILES("IBRC0304H.TXT")="RC v1.4 Physician Area Factors^H" + S IBFILES("IBRC0304I.TXT")="RC v1.4 Physician Unit Area Factors^I" + Q + ; +FEREAL S IBFILES("IBRC0312A.TXT")="RC v2.0 Inpatient Facility Charges^A^10" + S IBFILES("IBRC0312B.TXT")="RC v2.0 Outpatient Facility Charges^B^14" + S IBFILES("IBRC0312C.TXT")="RC v2.0 Professional Charges^C^23" + S IBFILES("IBRC0312D.TXT")="RC v2.0 Service Category Codes^D^4" + S IBFILES("IBRC0312E.TXT")="RC v2.0 Area Factors^E^41" + S IBFILES("IBRC0312F.TXT")="RC v2.0 VA Sites and Zip Codes^F^4" + Q + ; +FFREAL S IBFILES("IBRC0404A.TXT")="RC v2.1 Inpatient Facility Charges^A^10" + S IBFILES("IBRC0404B.TXT")="RC v2.1 Outpatient Facility Charges^B^14" + S IBFILES("IBRC0404C.TXT")="RC v2.1 Professional Charges^C^23" + S IBFILES("IBRC0404D.TXT")="RC v2.1 Service Category Codes^D^4" + S IBFILES("IBRC0404E.TXT")="RC v2.1 Area Factors^E^41" + S IBFILES("IBRC0404F.TXT")="RC v2.1 VA Sites and Zip Codes^F^4" + Q + ; +FGREAL S IBFILES("IBRC0501A.TXT")="RC v2.3 Inpatient Facility Charges^A^10" + S IBFILES("IBRC0501B.TXT")="RC v2.3 Outpatient Facility Charges^B^14" + S IBFILES("IBRC0501C.TXT")="RC v2.3 Professional Charges^C^23" + S IBFILES("IBRC0501D.TXT")="RC v2.3 Service Category Codes^D^4" + S IBFILES("IBRC0501E.TXT")="RC v2.3 Area Factors^E^41" + S IBFILES("IBRC0501F.TXT")="RC v2.3 VA Sites and Zip Codes^F^4" + Q + ; +FHREAL S IBFILES("IBRC0504A.TXT")="RC v2.4 Inpatient Facility Charges^A^10" + S IBFILES("IBRC0504B.TXT")="RC v2.4 Outpatient Facility Charges^B^14" + S IBFILES("IBRC0504C.TXT")="RC v2.4 Professional Charges^C^23" + S IBFILES("IBRC0504D.TXT")="RC v2.4 Service Category Codes^D^4" + S IBFILES("IBRC0504E.TXT")="RC v2.4 Area Factors^E^41" + S IBFILES("IBRC0504F.TXT")="RC v2.4 VA Sites and Zip Codes^F^4" + Q diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRHBS8.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRHBS8.m index eb49e274..1f11c845 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRHBS8.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRHBS8.m @@ -1,190 +1,189 @@ -IBCRHBS8 ;ALB/ARH - RATES: UPLOAD (RC 2+) CALCULATIONS CHARGE ; 10-OCT-03 - ;;2.0;INTEGRATED BILLING;**245,382**;21-MAR-94;Build 2 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ; -ISA(SITE,ITLINE) ; Return Inpatient DRG Standard Ancillary Charge - N IBCHG,IBZIP,IBAA,IBCTI,IBCTIAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4) - I $P(ITLINE,U,2)'="DRG" G ISAQ - ; - S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G ISAQ - S IBCTI=$P($G(ITLINE),U,4),IBCTIAAP=$S(IBCTI="S":3,IBCTI="N":5,1:0) I 'IBCTIAAP G ISAQ - ; - S IBCHG=$P(ITLINE,U,6)*$P(IBAA,U,IBCTIAAP) S IBCHG=$J(IBCHG,0,2) - ; -ISAQ Q IBCHG - ; -ISR(SITE,ITLINE) ; Return Inpatient DRG Standard Room & Board Charge - N IBCHG,IBZIP,IBAA,IBCTI,IBCTIAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4) - I $P(ITLINE,U,2)'="DRG" G ISRQ - ; - S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G ISRQ - S IBCTI=$P($G(ITLINE),U,4),IBCTIAAP=$S(IBCTI="S":2,IBCTI="N":4,1:0) I 'IBCTIAAP G ISRQ - ; - S IBCHG=$P(ITLINE,U,5)*$P(IBAA,U,IBCTIAAP) S IBCHG=$J(IBCHG,0,2) - ; -ISRQ Q IBCHG - ; -IIA(SITE,ITLINE) ; Return Inpatient DRG ICU Ancillary Charge - N IBCHG,IBZIP,IBAA,IBCTI,IBCTIAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4) - I $P(ITLINE,U,2)'="DRG" G IIAQ - ; - S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G IIAQ - S IBCTI=$P($G(ITLINE),U,4),IBCTIAAP=$S(IBCTI="S":3,IBCTI="N":5,1:0) I 'IBCTIAAP G IIAQ - ; - S IBCHG=$P(ITLINE,U,8)*$P(IBAA,U,IBCTIAAP) S IBCHG=$J(IBCHG,0,2) - ; -IIAQ Q IBCHG - ; -IIR(SITE,ITLINE) ; Return Inpatient DRG ICU Room & Board Charge - N IBCHG,IBZIP,IBAA,IBCTI,IBCTIAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4) - I $P(ITLINE,U,2)'="DRG" G IIRQ - ; - S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G IIRQ - S IBCTI=$P($G(ITLINE),U,4),IBCTIAAP=$S(IBCTI="S":2,IBCTI="N":4,1:0) I 'IBCTIAAP G IIRQ - ; - S IBCHG=$P(ITLINE,U,7)*$P(IBAA,U,IBCTIAAP) S IBCHG=$J(IBCHG,0,2) - ; -IIRQ Q IBCHG - ; -ISNF(SITE,ITLINE) ; Return Inpatient Skilled Nursing Facility Per Diem - N IBCHG,IBZIP,IBAA S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4) - I $P(ITLINE,U,2)'="SNF" G ISNFQ - I $P(ITLINE,U,1)'="999",$P(ITLINE,U,1)'="000" G ISNFQ - ; - S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G ISNFQ - ; - S IBCHG=$P(ITLINE,U,5)*$P(IBAA,U,6) S IBCHG=$J(IBCHG,0,2) - ; -ISNFQ Q IBCHG - ; - ; -FAC(SITE,ITLINE) ; Return Facility Charge (Table B) for All Charge and Unit Types - ; each line record contains 1 charge that may be calculated in multiple ways - N IBCHG,IBUT S IBCHG=0,SITE=$G(SITE),ITLINE=$G(ITLINE) - ; - S IBUT=$P(ITLINE,U,10) - ; - I IBUT=1 S IBCHG=$$FSTD(SITE,ITLINE) G FACQ - I IBUT=4 S IBCHG=$$FSTD(SITE,ITLINE) G FACQ - I IBUT=2 S IBCHG=$$FHRS(SITE,ITLINE) G FACQ - ; -FACQ Q IBCHG - ; -FSTD(SITE,ITLINE) ; Return Facility Charge of Unit Type = 1 or 4 (Standard and Miles) - N IBCHG,IBZIP,IBUT,IBAA,IBSCC,IBSCCAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4) - S IBUT=$P(ITLINE,U,10) I IBUT'=1,IBUT'=4 G FSTDQ - ; - S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G FSTDQ - S IBSCC=$$GETSCC($P(ITLINE,U,5)),IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G FSTDQ - ; - S IBCHG=$P(ITLINE,U,8)*$P(IBAA,U,IBSCCAAP) S IBCHG=$J(IBCHG,0,2) - ; -FSTDQ Q IBCHG - ; -FHRS(SITE,ITLINE) ; Return Facility Charge of Unit Type = 2 (Hours) - N IBCHG,IBCHGB,IBZIP,IBUT,IBAA,IBSCC,IBSCCAAP S (IBCHG,IBCHGB)=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4) - S IBUT=$P(ITLINE,U,10) I IBUT'=2 G FHRSQ - ; - S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G FHRSQ - S IBSCC=$$GETSCC($P(ITLINE,U,5)),IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G FHRSQ - ; - S IBCHG=$P(ITLINE,U,8)*$P(IBAA,U,IBSCCAAP) S IBCHG=$J(IBCHG,0,2) - S IBCHGB=$P(ITLINE,U,9)*$P(IBAA,U,IBSCCAAP) S IBCHGB=$J(IBCHGB,0,2) - ; -FHRSQ Q IBCHG_U_IBCHGB - ; - ; -PROF(SITE,ITLINE) ; Return Professional Charge (Table C) for All Charge and Unit Types - ; each line record contains 1 charge that may be calculated in multiple ways - N IBCHG,IBCT,IBUT S IBCHG=0,SITE=$G(SITE),ITLINE=$G(ITLINE) - ; - S IBCT=$P(ITLINE,U,8) - S IBUT=$P(ITLINE,U,16) - ; - I IBUT=1,IBCT="RBRVS" S IBCHG=$$PRBRVS(SITE,ITLINE) G PROFQ - I IBUT=1,IBCT="TotalUnits" S IBCHG=$$PTRVU(SITE,ITLINE) G PROFQ - I IBUT=1,IBCT="NW" S IBCHG=$$PNW(SITE,ITLINE) G PROFQ - I IBUT=3,IBCT="Anesth" S IBCHG=$$PANES(SITE,ITLINE) G PROFQ - ; -PROFQ Q IBCHG - ; -PRBRVS(SITE,ITLINE) ; Return Professional RBRVS Based Charge - N IBCHG,IBZIP,IBCTI,IBUT,IBAA,IBSCC,IBSCCAAP,IBPEP,IBWE,IBPE,IBCF S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4) - S IBCTI=$P(ITLINE,U,8) I IBCTI'="RBRVS" G PRBRVSQ - S IBUT=$P(ITLINE,U,16) I IBUT'=1 G PRBRVSQ - ; - S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G PRBRVSQ - S IBSCC=$$GETSCC($P(ITLINE,U,6)) S IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G PRBRVSQ - ; - S IBPEP=$S($P(SITE,U,5)=3:11,1:10) ; provider/non-provider site - ; - S IBWE=$P(ITLINE,U,9)*$P(IBAA,U,7) - S IBPE=$P(ITLINE,U,IBPEP)*$P(IBAA,U,8) - S IBCF=$P(IBSCC,U,3)*$P(IBAA,U,IBSCCAAP) - ; - S IBCHG=(IBWE+IBPE)*IBCF S IBCHG=$J(IBCHG,0,2) - ; -PRBRVSQ Q IBCHG - ; - ; -PTRVU(SITE,ITLINE) ; Return Professional Total RVU Charge - N IBCHG,IBZIP,IBCTI,IBUT,IBAA,IBSCC,IBSCCAAP,IBUN,IBCF S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4) - S IBCTI=$P(ITLINE,U,8) I IBCTI'="TotalUnits" G PTRVUQ - S IBUT=$P(ITLINE,U,16) I IBUT'=1 G PTRVUQ - ; - S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G PTRVUQ - S IBSCC=$$GETSCC($P(ITLINE,U,6)) S IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G PTRVUQ - ; - S IBUN=$P(ITLINE,U,12)*$P(IBAA,U,9) - S IBCF=$P(IBSCC,U,3)*$P(IBAA,U,IBSCCAAP) - ; - S IBCHG=IBUN*IBCF S IBCHG=$J(IBCHG,0,2) - ; -PTRVUQ Q IBCHG - ; -PNW(SITE,ITLINE) ; Return Professional Nationwide Charge - N IBCHG,IBZIP,IBCTI,IBUT,IBAA,IBSCC,IBSCCAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4) - S IBCTI=$P(ITLINE,U,8) I IBCTI'="NW" G PNWQ - S IBUT=$P(ITLINE,U,16) I IBUT'=1 G PNWQ - ; - S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G PNWQ - S IBSCC=$$GETSCC($P(ITLINE,U,6)) S IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G PNWQ - ; - S IBCHG=$P(ITLINE,U,14)*$P(IBAA,U,IBSCCAAP) S IBCHG=$J(IBCHG,0,2) - ; -PNWQ Q IBCHG - ; -PANES(SITE,ITLINE) ; Return Professional Anesthesia Charge - N IBCHG,IBCHGB,IBZIP,IBCTI,IBUT,IBAA,IBSCC,IBSCCAAP,IBCF S (IBCHG,IBCHGB)=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4) - S IBCTI=$P(ITLINE,U,8) I IBCTI'="Anesth" G PANESQ - S IBUT=$P(ITLINE,U,16) I IBUT'=3 G PANESQ - ; - S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G PANESQ - S IBSCC=$$GETSCC($P(ITLINE,U,6)) S IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G PANESQ - ; - S IBCF=$P(IBSCC,U,3)*$P(IBAA,U,IBSCCAAP) - ; - S IBCHG=$P(ITLINE,U,14)*IBCF S IBCHG=$J(IBCHG,0,2) - S IBCHGB=$P(ITLINE,U,13)*IBCF S IBCHGB=$J(IBCHGB,0,2) - ; -PANESQ Q IBCHG_U_IBCHGB - ; - ; - ; - ; -GETAA(ZIP) ; return Area Factor entry for Zip from Table E - N IBTMPAA,IBAALN,IBDIV,IBDIVLN S IBAALN="",IBTMPAA="IBCR RC E",IBDIV="" - ; - I $G(ZIP)?3N S IBDIV=$O(^XTMP(IBTMPAA,"A",ZIP,0)) - I +IBDIV S IBDIVLN=$G(^XTMP(IBTMPAA,IBDIV)) I $P(IBDIVLN,U,1)=ZIP S IBAALN=IBDIVLN - ; - Q IBAALN - ; -GETSCC(SCC) ; return Service Category Code entry from Table D - N IBTMPSCC,IBSCC,IBSCCLN,IBLN S IBSCCLN="",IBTMPSCC="IBCR RC D",IBSCC="" - ; - I +$G(SCC) S IBSCC=$O(^XTMP(IBTMPSCC,"A",SCC,0)) - I +IBSCC S IBLN=$G(^XTMP(IBTMPSCC,IBSCC)) I $P(IBLN,U,1)=SCC S IBSCCLN=IBLN - ; - Q IBSCCLN +IBCRHBS8 ;ALB/ARH - RATES: UPLOAD (RC 2+) CALCULATIONS CHARGE ; 10-OCT-03 + ;;2.0;INTEGRATED BILLING;**245**;21-MAR-94 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; + ; +ISA(SITE,ITLINE) ; Return Inpatient DRG Standard Ancillary Charge + N IBCHG,IBZIP,IBAA,IBCTI,IBCTIAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4) + I $P(ITLINE,U,2)'="DRG" G ISAQ + ; + S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G ISAQ + S IBCTI=$P($G(ITLINE),U,4),IBCTIAAP=$S(IBCTI="S":3,IBCTI="N":5,1:0) I 'IBCTIAAP G ISAQ + ; + S IBCHG=$P(ITLINE,U,6)*$P(IBAA,U,IBCTIAAP) S IBCHG=$J(IBCHG,0,2) + ; +ISAQ Q IBCHG + ; +ISR(SITE,ITLINE) ; Return Inpatient DRG Standard Room & Board Charge + N IBCHG,IBZIP,IBAA,IBCTI,IBCTIAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4) + I $P(ITLINE,U,2)'="DRG" G ISRQ + ; + S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G ISRQ + S IBCTI=$P($G(ITLINE),U,4),IBCTIAAP=$S(IBCTI="S":2,IBCTI="N":4,1:0) I 'IBCTIAAP G ISRQ + ; + S IBCHG=$P(ITLINE,U,5)*$P(IBAA,U,IBCTIAAP) S IBCHG=$J(IBCHG,0,2) + ; +ISRQ Q IBCHG + ; +IIA(SITE,ITLINE) ; Return Inpatient DRG ICU Ancillary Charge + N IBCHG,IBZIP,IBAA,IBCTI,IBCTIAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4) + I $P(ITLINE,U,2)'="DRG" G IIAQ + ; + S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G IIAQ + S IBCTI=$P($G(ITLINE),U,4),IBCTIAAP=$S(IBCTI="S":3,IBCTI="N":5,1:0) I 'IBCTIAAP G IIAQ + ; + S IBCHG=$P(ITLINE,U,8)*$P(IBAA,U,IBCTIAAP) S IBCHG=$J(IBCHG,0,2) + ; +IIAQ Q IBCHG + ; +IIR(SITE,ITLINE) ; Return Inpatient DRG ICU Room & Board Charge + N IBCHG,IBZIP,IBAA,IBCTI,IBCTIAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4) + I $P(ITLINE,U,2)'="DRG" G IIRQ + ; + S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G IIRQ + S IBCTI=$P($G(ITLINE),U,4),IBCTIAAP=$S(IBCTI="S":2,IBCTI="N":4,1:0) I 'IBCTIAAP G IIRQ + ; + S IBCHG=$P(ITLINE,U,7)*$P(IBAA,U,IBCTIAAP) S IBCHG=$J(IBCHG,0,2) + ; +IIRQ Q IBCHG + ; +ISNF(SITE,ITLINE) ; Return Inpatient Skilled Nursing Facility Per Diem + N IBCHG,IBZIP,IBAA S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4) I $P(ITLINE,U,2)'="SNF" G ISNFQ + I $P(ITLINE,U,1)'="999" G ISNFQ + ; + S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G ISNFQ + ; + S IBCHG=$P(ITLINE,U,5)*$P(IBAA,U,6) S IBCHG=$J(IBCHG,0,2) + ; +ISNFQ Q IBCHG + ; + ; +FAC(SITE,ITLINE) ; Return Facility Charge (Table B) for All Charge and Unit Types + ; each line record contains 1 charge that may be calculated in multiple ways + N IBCHG,IBUT S IBCHG=0,SITE=$G(SITE),ITLINE=$G(ITLINE) + ; + S IBUT=$P(ITLINE,U,10) + ; + I IBUT=1 S IBCHG=$$FSTD(SITE,ITLINE) G FACQ + I IBUT=4 S IBCHG=$$FSTD(SITE,ITLINE) G FACQ + I IBUT=2 S IBCHG=$$FHRS(SITE,ITLINE) G FACQ + ; +FACQ Q IBCHG + ; +FSTD(SITE,ITLINE) ; Return Facility Charge of Unit Type = 1 or 4 (Standard and Miles) + N IBCHG,IBZIP,IBUT,IBAA,IBSCC,IBSCCAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4) + S IBUT=$P(ITLINE,U,10) I IBUT'=1,IBUT'=4 G FSTDQ + ; + S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G FSTDQ + S IBSCC=$$GETSCC($P(ITLINE,U,5)),IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G FSTDQ + ; + S IBCHG=$P(ITLINE,U,8)*$P(IBAA,U,IBSCCAAP) S IBCHG=$J(IBCHG,0,2) + ; +FSTDQ Q IBCHG + ; +FHRS(SITE,ITLINE) ; Return Facility Charge of Unit Type = 2 (Hours) + N IBCHG,IBCHGB,IBZIP,IBUT,IBAA,IBSCC,IBSCCAAP S (IBCHG,IBCHGB)=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4) + S IBUT=$P(ITLINE,U,10) I IBUT'=2 G FHRSQ + ; + S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G FHRSQ + S IBSCC=$$GETSCC($P(ITLINE,U,5)),IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G FHRSQ + ; + S IBCHG=$P(ITLINE,U,8)*$P(IBAA,U,IBSCCAAP) S IBCHG=$J(IBCHG,0,2) + S IBCHGB=$P(ITLINE,U,9)*$P(IBAA,U,IBSCCAAP) S IBCHGB=$J(IBCHGB,0,2) + ; +FHRSQ Q IBCHG_U_IBCHGB + ; + ; +PROF(SITE,ITLINE) ; Return Professional Charge (Table C) for All Charge and Unit Types + ; each line record contains 1 charge that may be calculated in multiple ways + N IBCHG,IBCT,IBUT S IBCHG=0,SITE=$G(SITE),ITLINE=$G(ITLINE) + ; + S IBCT=$P(ITLINE,U,8) + S IBUT=$P(ITLINE,U,16) + ; + I IBUT=1,IBCT="RBRVS" S IBCHG=$$PRBRVS(SITE,ITLINE) G PROFQ + I IBUT=1,IBCT="TotalUnits" S IBCHG=$$PTRVU(SITE,ITLINE) G PROFQ + I IBUT=1,IBCT="NW" S IBCHG=$$PNW(SITE,ITLINE) G PROFQ + I IBUT=3,IBCT="Anesth" S IBCHG=$$PANES(SITE,ITLINE) G PROFQ + ; +PROFQ Q IBCHG + ; +PRBRVS(SITE,ITLINE) ; Return Professional RBRVS Based Charge + N IBCHG,IBZIP,IBCTI,IBUT,IBAA,IBSCC,IBSCCAAP,IBPEP,IBWE,IBPE,IBCF S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4) + S IBCTI=$P(ITLINE,U,8) I IBCTI'="RBRVS" G PRBRVSQ + S IBUT=$P(ITLINE,U,16) I IBUT'=1 G PRBRVSQ + ; + S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G PRBRVSQ + S IBSCC=$$GETSCC($P(ITLINE,U,6)) S IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G PRBRVSQ + ; + S IBPEP=$S($P(SITE,U,5)=3:11,1:10) ; provider/non-provider site + ; + S IBWE=$P(ITLINE,U,9)*$P(IBAA,U,7) + S IBPE=$P(ITLINE,U,IBPEP)*$P(IBAA,U,8) + S IBCF=$P(IBSCC,U,3)*$P(IBAA,U,IBSCCAAP) + ; + S IBCHG=(IBWE+IBPE)*IBCF S IBCHG=$J(IBCHG,0,2) + ; +PRBRVSQ Q IBCHG + ; + ; +PTRVU(SITE,ITLINE) ; Return Professional Total RVU Charge + N IBCHG,IBZIP,IBCTI,IBUT,IBAA,IBSCC,IBSCCAAP,IBUN,IBCF S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4) + S IBCTI=$P(ITLINE,U,8) I IBCTI'="TotalUnits" G PTRVUQ + S IBUT=$P(ITLINE,U,16) I IBUT'=1 G PTRVUQ + ; + S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G PTRVUQ + S IBSCC=$$GETSCC($P(ITLINE,U,6)) S IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G PTRVUQ + ; + S IBUN=$P(ITLINE,U,12)*$P(IBAA,U,9) + S IBCF=$P(IBSCC,U,3)*$P(IBAA,U,IBSCCAAP) + ; + S IBCHG=IBUN*IBCF S IBCHG=$J(IBCHG,0,2) + ; +PTRVUQ Q IBCHG + ; +PNW(SITE,ITLINE) ; Return Professional Nationwide Charge + N IBCHG,IBZIP,IBCTI,IBUT,IBAA,IBSCC,IBSCCAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4) + S IBCTI=$P(ITLINE,U,8) I IBCTI'="NW" G PNWQ + S IBUT=$P(ITLINE,U,16) I IBUT'=1 G PNWQ + ; + S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G PNWQ + S IBSCC=$$GETSCC($P(ITLINE,U,6)) S IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G PNWQ + ; + S IBCHG=$P(ITLINE,U,14)*$P(IBAA,U,IBSCCAAP) S IBCHG=$J(IBCHG,0,2) + ; +PNWQ Q IBCHG + ; +PANES(SITE,ITLINE) ; Return Professional Anesthesia Charge + N IBCHG,IBCHGB,IBZIP,IBCTI,IBUT,IBAA,IBSCC,IBSCCAAP,IBCF S (IBCHG,IBCHGB)=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4) + S IBCTI=$P(ITLINE,U,8) I IBCTI'="Anesth" G PANESQ + S IBUT=$P(ITLINE,U,16) I IBUT'=3 G PANESQ + ; + S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G PANESQ + S IBSCC=$$GETSCC($P(ITLINE,U,6)) S IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G PANESQ + ; + S IBCF=$P(IBSCC,U,3)*$P(IBAA,U,IBSCCAAP) + ; + S IBCHG=$P(ITLINE,U,14)*IBCF S IBCHG=$J(IBCHG,0,2) + S IBCHGB=$P(ITLINE,U,13)*IBCF S IBCHGB=$J(IBCHGB,0,2) + ; +PANESQ Q IBCHG_U_IBCHGB + ; + ; + ; + ; +GETAA(ZIP) ; return Area Factor entry for Zip from Table E + N IBTMPAA,IBAALN,IBDIV,IBDIVLN S IBAALN="",IBTMPAA="IBCR RC E",IBDIV="" + ; + I $G(ZIP)?3N S IBDIV=$O(^XTMP(IBTMPAA,"A",ZIP,0)) + I +IBDIV S IBDIVLN=$G(^XTMP(IBTMPAA,IBDIV)) I $P(IBDIVLN,U,1)=ZIP S IBAALN=IBDIVLN + ; + Q IBAALN + ; +GETSCC(SCC) ; return Service Category Code entry from Table D + N IBTMPSCC,IBSCC,IBSCCLN,IBLN S IBSCCLN="",IBTMPSCC="IBCR RC D",IBSCC="" + ; + I +$G(SCC) S IBSCC=$O(^XTMP(IBTMPSCC,"A",SCC,0)) + I +IBSCC S IBLN=$G(^XTMP(IBTMPSCC,IBSCC)) I $P(IBLN,U,1)=SCC S IBSCCLN=IBLN + ; + Q IBSCCLN diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC3.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC3.m index 5b6ff66b..84971d56 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC3.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC3.m @@ -1,104 +1,99 @@ -IBCSC3 ;ALB/MJB - MCCR SCREEN 3 (PAYER/MAILING ADDRESS) ;27 MAY 88 10:15 - ;;2.0;INTEGRATED BILLING;**8,43,52,80,82,51,137,232,320,377**;21-MAR-94;Build 23 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ;MAP TO DGCRSC3 - ; -EN N IB,IBX,IBINS,Y,Z - I $D(DGRVRCAL) D ^IBCU6 K DGRVRCAL - D ^IBCSCU S IBSR=3,IBSR1="",IBV1="000" I IBV S IBV1="111" - D H^IBCSCU - D:$D(^DGCR(399,IBIFN,"AIC")) 3^IBCVA0 - D:'$D(^DGCR(399,IBIFN,"AIC")) 123^IBCVA - D POL^IBCNSU41(DFN) - F I=0,"M","M1","U","U2" S IB(I)=$S($D(^DGCR(399,IBIFN,I)):(^(I)),1:"") - S IBOUTP=2,IBINDT=$S(+$G(IB("U")):+IB("U"),1:DT) - ; - S X=" Rate Type : "_$S($P(IB(0),U,7)']"":IBU,$D(^DGCR(399.3,$P(IB(0),U,7),0)):$P(^(0),U),1:IBUN) - S Z=1,IBW=1 X IBWW W X - I +$P($G(^IBE(350.9,1,1)),U,22) W $J("",(42-$L(X))),"Form Type: ",$P($G(^IBE(353,+$P(IB(0),U,19),0)),U,1) - W !?4,"Responsible: ",$S($P(IB(0),U,11)']"":IBU,$P(IB(0),U,11)="p":"PATIENT",$P(IB(0),U,11)="i":"INSURER",1:"OTHER") - W ?45,"Payer Sequence: " S IBX=$P(IB(0),U,21) W $S(IBX="P":"Primary",IBX="S":"Secondary",IBX="T":"Tertiary",IBX="A":"Patient",1:"") - I $P(IB(0),U,11)="i" D - . W !?4,"Bill Payer : " S X=$G(^DGCR(399,IBIFN,"MP")) - . W $S(+X:$P($G(^DIC(36,+X,0)),U,1),$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)):"MRA NEEDED FROM MEDICARE",1:IBU) - . W ?45,"Transmit: " S Z=0,X=$$TXMT^IBCEF4(IBIFN,.Z) - . W $S(X:"Yes",1:"No-"_$S(Z=1:"Forced to print local",Z=2&($$WNRBILL^IBEFUNC(IBIFN)):"MRA not active",Z=2:"EDI not active",Z=3:"Rate typ transmit off",Z=4:"Ins. co transmit off",Z=5:"Failed RULE #"_$G(Z(0)),Z=6:"Invalid NDC code type",1:"??")) - I $P(IB(0),U,11)']"" G MAIL - I $P(IB(0),U,11)="p" G MAIL - I $P(IB(0),U,11)="o" W !?4,"Inst. Name : ",$S($P(IB("M"),U,11)']"":IBU,$D(^DIC(4,$P(IB("M"),U,11),0)):$P(^(0),U,1),1:"UNKNOWN INSTITUTION") G MAIL - I $P(IB(0),U,11)="i" I $D(IBDD)>1,$D(^DGCR(399,IBIFN,"AIC")) G SHW - D UP G LST:$D(IBDD)>1 W !?4,"Insurance : NO REIMBURSABLE INSURANCE INFORMATION ON FILE",!?17,"[Add Insurance Information by entering '1' at the prompt below]" G MAIL - ; -LST N IBDTIN,IBICT - S IBDTIN=+$G(IB("U")),IBICT=0 - W ! D HDR^IBCNS - S I=0 F S I=$O(IBDD("S",I)) Q:'I D Q:IBICT'<5 - .S IBX=0 F S IBX=$O(IBDD("S",I,IBX)) Q:'IBX S IBINS=$G(IBDD(IBX,0)) I IBINS'="" S IBICT=IBICT+1 D:IBICT<5 D1^IBCNS I IBICT'<5 W !,?1,"**Patient has additional insurance - use ?INS to see the entire list" Q - G MAIL -LST1 W !?4,$S($D(^DIC(36,+IBDD(IBX,0),0)):$E($P(^(0),"^",1),1,20),1:"UNKNOWN") S X=$P(IBDD(IBX,0),"^",6) W ?26,$S(X="v":"VETERAN",X="s":"SPOUSE",1:"OTHER") S X=$P(IBDD(IBX,0),"^",16) - S X=$S(+X=1:"PATIENT",+X=2:"SPOUSE",+X=3:"CHILD",+X=8:"EMPLOYEE",+X=11:"ORGAN DONOR",+X=18:"PARENT",+X=15:"PLANTIFF",1:"UNKNOWN") - I X="UNKNOWN" S X1=$S($D(IBDD(IBX,0)):$P(IBDD(IBX,0),"^",6),1:""),X=$S(X1="v":"PATIENT",X1="s":"SPOUSE",1:X) - W ?37,X,?49 S Y=$P(IBDD(IBX,0),"^",8) X ^DD("DD") W Y,?64 S Y=$P(IBDD(IBX,0),"^",4) X ^DD("DD") W Y - Q -SHW I $D(IBDD) S I="" F S I=$O(IBDD(I)) Q:'I D SHW1 -MAIL I $$BUFFER^IBCNBU1(DFN) W !!,?17,"*** Patient has Insurance Buffer entries ***" - ; - S IB("M")=$S($D(^DGCR(399,IBIFN,"M")):^("M"),1:""),IB("M1")=$S($D(^DGCR(399,IBIFN,"M1")):^("M1"),1:""),IB(0)=^DGCR(399,IBIFN,0) - S Z=2,IBW=1 W ! X IBWW - N IBRAMS S IBRAMS=4.06 - I $$FT^IBCEF(IBIFN)=3 S IBRAMS=4.08 - S IB("RAFLAG",1)=$S($P(IB("M"),U,1)="":0,1:$$GET1^DIQ(36,$P(IB("M"),U,1),IBRAMS,"I")) - S IB("RAFLAG",2)=$S($P(IB("M"),U,2)="":0,1:$$GET1^DIQ(36,$P(IB("M"),U,2),IBRAMS,"I")) - S IB("RAFLAG",3)=$S($P(IB("M"),U,3)="":0,1:$$GET1^DIQ(36,$P(IB("M"),U,3),IBRAMS,"I")) - S X=0 - I $P(IB("M1"),U,2)="",'IB("RAFLAG",1),$P(IB("M1"),U,3)="",'IB("RAFLAG",2),$P(IB("M1"),U,4)="",'IB("RAFLAG",3) S X=1 - W " Billing Provider Secondary IDs: " - I X W IBUN ; no data found, unspecified not required - I 'X D ; data found, display below - . W !?5,"Primary Payer: ",$S($P(IB("M1"),U,2)]"":$P(IB("M1"),U,2),IB("RAFLAG",1):"ATT/REND ID",1:"") - . W !?5,"Secondary Payer: ",$S($P(IB("M1"),U,3)]"":$P(IB("M1"),U,3),IB("RAFLAG",2):"ATT/REND ID",1:"") - . W ?46,"Tertiary Payer: ",$S($P(IB("M1"),U,4)]"":$P(IB("M1"),U,4),IB("RAFLAG",3):"ATT/REND ID",1:"") - . Q - ; - S Z=3,IBW=1 W ! X IBWW - W " Mailing Address : " - S X=+$G(^DGCR(399,IBIFN,"MP")) - I 'X,$$MCRWNR^IBEFUNC(+$$CURR^IBCEF2(IBIFN)) S X=+$$CURR^IBCEF2(IBIFN) - I X,+$G(^DIC(36,X,3)) S I=$P(^(3),U,$S($$FT^IBCEF(IBIFN)=2:2,1:4)) W ?56,"Electronic ID: ",$S(I'="":I,1:"") - S X="" I IB("M")]"" F I=4:1:9 Q:X]"" S X=$P(IB("M"),"^",I) - I X']"" W !?4,"NO MAILING ADDRESS HAS BEEN SPECIFIED!",?45,$$UP1,!?4,"Send Bill to PAYER listed above." G ENDSCR - S X=IB("M") W !,?4,$S($P(X,"^",4)]"":$P(X,"^",4),1:"'MAIL TO' PERSON/PLACE UNSPECIFIED"),?45,$$UP1 - W !?4,$S($P(X,"^",5)]"":$P(X,"^",5),1:"STREET ADDRESS UNSPECIFIED") W:$P(X,"^",6)]"" ", ",$P(X,"^",6) - W ! W:$P(IB("M1"),"^",1)]"" ?4,$P(IB("M1"),"^",1),", " - W ?4,$S($P(X,"^",7)]"":$P(X,"^",7),1:"CITY UNSPECIFIED"),", ",$S($D(^DIC(5,+$P(X,"^",8),0)):$P(^(0),"^",2),1:"STATE UNSPECIFIED")," ",$S($P(X,"^",9)]"":$P(X,"^",9),1:"ZIP UNSPECIFIED") - ; -ENDSCR K IBADI,IBDD,IBOUTP,IBINDT,I,X,X1 - G ^IBCSCP - ; -SHW1 S X=IBDD(I,0),Z=$G(^DIC(36,+X,0)) - W !!?4,"Ins ",I,": " W $E($S($P(Z,U,1)'="":$P(Z,U,1),1:IBU),1,16) - I $P(Z,U,2)="N" W ?30,"WILL NOT REIMBURSE" - W ?51,"Policy #: ",$E($S($P(X,"^",2)]"":$P(X,"^",2),1:IBU),1,18) - W !?4,"Grp #: ",$E($S($P(X,"^",3)]"":$P(X,"^",3),1:IBU),1,16) - W ?30,"Whose: ",$S($P(X,"^",6)="v":"VETERAN",$P(X,"^",6)="s":"SPOUSE",1:"OTHER") - W ?51,"Rel to Insd: ",IBIR(I) - W !?4,"Grp Nm: ",$E($S($P(X,"^",15)]"":$P(X,"^",15),1:IBU),1,16) - W ?30,"Insd Sex: ",$S($D(IBISEX(I)):IBISEX(I),1:IBU) - W ?51,"Insured: ",$E($P(X,"^",17),1,19) - Q - ; -UP K IBDD D ALL^IBCNS1(DFN,"IBDD",2,IBINDT,1) - I $D(IBDD("S",.5)) D ; At least 1 MCR WNR insurance policy exists - . ;try to put correct part (A for institution and B for facility) - . N Z,IBAB - . S IBAB=$S($$FT^IBCEF(IBIFN)=3:"A",1:"B") - . S Z=0 F S Z=$O(IBDD("S",.5,Z)) Q:'Z D - .. I $P($G(IBDD(Z,355.3)),U,14)=IBAB S IBDD("S",.1,Z,0)="" K IBDD("S",.5,Z) - Q - ; -UP1() ;check if patient has medicare so can print a flag for the user - N IBDD,IBX,IBY S IBY="" D ALL^IBCNS1(DFN,"IBDD",2,IBINDT) - S IBX=0 F S IBX=$O(IBDD(IBX)) Q:'IBX I $P($G(IBDD(IBX,355.3)),U,9)=33 S IBY="(Patient has Medicare)" - Q IBY - ;IBCSC3 +IBCSC3 ;ALB/MJB - MCCR SCREEN 3 (PAYER/MAILING ADDRESS) ;27 MAY 88 10:15 + ;;2.0;INTEGRATED BILLING;**8,43,52,80,82,51,137,232,320**;21-MAR-94 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; + ;MAP TO DGCRSC3 + ; +EN N IB,IBX,IBINS,Y,Z + I $D(DGRVRCAL) D ^IBCU6 K DGRVRCAL + D ^IBCSCU S IBSR=3,IBSR1="",IBV1="000" I IBV S IBV1="111" + D H^IBCSCU + D:$D(^DGCR(399,IBIFN,"AIC")) 3^IBCVA0 + D:'$D(^DGCR(399,IBIFN,"AIC")) 123^IBCVA + D POL^IBCNSU41(DFN) + F I=0,"M","M1","U","U2" S IB(I)=$S($D(^DGCR(399,IBIFN,I)):(^(I)),1:"") + S IBOUTP=2,IBINDT=$S(+$G(IB("U")):+IB("U"),1:DT) + ;S Z=1,IBW=1 X IBWW W " Rate Type : ",$S($P(IB(0),U,7)']"":IBU,$D(^DGCR(399.3,$P(IB(0),U,7),0)):$P(^(0),U),1:IBUN) + ; + S X=" Rate Type : "_$S($P(IB(0),U,7)']"":IBU,$D(^DGCR(399.3,$P(IB(0),U,7),0)):$P(^(0),U),1:IBUN) + S Z=1,IBW=1 X IBWW W X + I +$P($G(^IBE(350.9,1,1)),U,22) W $J("",(42-$L(X))),"Form Type: ",$P($G(^IBE(353,+$P(IB(0),U,19),0)),U,1) + W !?4,"Responsible: ",$S($P(IB(0),U,11)']"":IBU,$P(IB(0),U,11)="p":"PATIENT",$P(IB(0),U,11)="i":"INSURER",1:"OTHER") + W ?45,"Payer Sequence: " S IBX=$P(IB(0),U,21) W $S(IBX="P":"Primary",IBX="S":"Secondary",IBX="T":"Tertiary",IBX="A":"Patient",1:"") + I $P(IB(0),U,11)="i" D + . W !?4,"Bill Payer : " S X=$G(^DGCR(399,IBIFN,"MP")) + . W $S(+X:$P($G(^DIC(36,+X,0)),U,1),$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)):"MRA NEEDED FROM MEDICARE",1:IBU) + . W ?45,"Transmit: " S Z=0,X=$$TXMT^IBCEF4(IBIFN,.Z) + . W $S(X:"Yes",1:"No-"_$S(Z=1:"Forced to print local",Z=2&($$WNRBILL^IBEFUNC(IBIFN)):"MRA not active",Z=2:"EDI not active",Z=3:"Rate typ transmit off",Z=4:"Ins. co transmit off",Z=5:"Failed RULE #"_$G(Z(0)),Z=6:"Invalid NDC code type",1:"??")) + I $P(IB(0),U,11)']"" G MAIL + I $P(IB(0),U,11)="p" G MAIL + I $P(IB(0),U,11)="o" W !?4,"Inst. Name : ",$S($P(IB("M"),U,11)']"":IBU,$D(^DIC(4,$P(IB("M"),U,11),0)):$P(^(0),U,1),1:"UNKNOWN INSTITUTION") G MAIL + I $P(IB(0),U,11)="i" I $D(IBDD)>1,$D(^DGCR(399,IBIFN,"AIC")) G SHW + D UP G LST:$D(IBDD)>1 W !?4,"Insurance : NO REIMBURSABLE INSURANCE INFORMATION ON FILE",!?17,"[Add Insurance Information by entering '1' at the prompt below]" G MAIL + ;W !?4,"Insurance Carrier",?40,"Whose",?66,"Relationship" S X="",$P(X,"=",81)="" W !,X +LST N IBDTIN,IBICT + S IBDTIN=+$G(IB("U")),IBICT=0 + W ! D HDR^IBCNS + S I=0 F S I=$O(IBDD("S",I)) Q:'I D Q:IBICT'<5 + .S IBX=0 F S IBX=$O(IBDD("S",I,IBX)) Q:'IBX S IBINS=$G(IBDD(IBX,0)) I IBINS'="" S IBICT=IBICT+1 D:IBICT<5 D1^IBCNS I IBICT'<5 W !,?1,"**Patient has additional insurance - use ?INS to see the entire list" Q + G MAIL +LST1 W !?4,$S($D(^DIC(36,+IBDD(IBX,0),0)):$E($P(^(0),"^",1),1,20),1:"UNKNOWN") S X=$P(IBDD(IBX,0),"^",6) W ?26,$S(X="v":"VETERAN",X="s":"SPOUSE",1:"OTHER") S X=$P(IBDD(IBX,0),"^",16) + S X=$S(+X=1:"PATIENT",+X=2:"SPOUSE",+X=3:"CHILD",+X=8:"EMPLOYEE",+X=11:"ORGAN DONOR",+X=18:"PARENT",+X=15:"PLANTIFF",1:"UNKNOWN") + I X="UNKNOWN" S X1=$S($D(IBDD(IBX,0)):$P(IBDD(IBX,0),"^",6),1:""),X=$S(X1="v":"PATIENT",X1="s":"SPOUSE",1:X) + W ?37,X,?49 S Y=$P(IBDD(IBX,0),"^",8) X ^DD("DD") W Y,?64 S Y=$P(IBDD(IBX,0),"^",4) X ^DD("DD") W Y + Q +SHW I $D(IBDD) S I="" F S I=$O(IBDD(I)) Q:'I D SHW1 +MAIL I $$BUFFER^IBCNBU1(DFN) W !!,?17,"*** Patient has Insurance Buffer entries ***" + S IB("M")=$S($D(^DGCR(399,IBIFN,"M")):^("M"),1:""),IB("M1")=$S($D(^DGCR(399,IBIFN,"M1")):^("M1"),1:""),IB(0)=^DGCR(399,IBIFN,0) + S Z=2,IBW=1 W ! X IBWW + N IBRAMS S IBRAMS=4.06 + I $$FT^IBCEF(IBIFN)=3 S IBRAMS=4.08 + S IB("RAFLAG",1)=$S($P(IB("M"),U,1)="":0,1:$$GET1^DIQ(36,$P(IB("M"),U,1),IBRAMS,"I")) + S IB("RAFLAG",2)=$S($P(IB("M"),U,2)="":0,1:$$GET1^DIQ(36,$P(IB("M"),U,2),IBRAMS,"I")) + S IB("RAFLAG",3)=$S($P(IB("M"),U,3)="":0,1:$$GET1^DIQ(36,$P(IB("M"),U,3),IBRAMS,"I")) + S X=0 I $P(IB("M1"),U,2)="",'IB("RAFLAG",1),$P(IB("M1"),U,3)="",'IB("RAFLAG",2),$P(IB("M1"),U,4)="",'IB("RAFLAG",3) S X=1 W " Facility ID #s: ",IBUN + I 'X D + . W " Primary Payer: ",$S($P(IB("M1"),U,2)]"":$P(IB("M1"),U,2),IB("RAFLAG",1):"ATT/REND ID",1:"") + . W !?4,"Secondary Payer: ",$S($P(IB("M1"),U,3)]"":$P(IB("M1"),U,3),IB("RAFLAG",2):"ATT/REND ID",1:"") + . W ?45,"Tertiary Payer: ",$S($P(IB("M1"),U,4)]"":$P(IB("M1"),U,4),IB("RAFLAG",3):"ATT/REND ID",1:"") + S Z=3,IBW=1 W ! X IBWW + W " Mailing Address : " + S X=+$G(^DGCR(399,IBIFN,"MP")) + I 'X,$$MCRWNR^IBEFUNC(+$$CURR^IBCEF2(IBIFN)) S X=+$$CURR^IBCEF2(IBIFN) + I X,+$G(^DIC(36,X,3)) S I=$P(^(3),U,$S($$FT^IBCEF(IBIFN)=2:2,1:4)) W ?56,"Electronic ID: ",$S(I'="":I,1:"") + S X="" I IB("M")]"" F I=4:1:9 Q:X]"" S X=$P(IB("M"),"^",I) + I X']"" W !?4,"NO MAILING ADDRESS HAS BEEN SPECIFIED!",?45,$$UP1,!?4,"Send Bill to PAYER listed above." G ENDSCR + S X=IB("M") W !,?4,$S($P(X,"^",4)]"":$P(X,"^",4),1:"'MAIL TO' PERSON/PLACE UNSPECIFIED"),?45,$$UP1 + W !?4,$S($P(X,"^",5)]"":$P(X,"^",5),1:"STREET ADDRESS UNSPECIFIED") W:$P(X,"^",6)]"" ", ",$P(X,"^",6) + W ! W:$P(IB("M1"),"^",1)]"" ?4,$P(IB("M1"),"^",1),", " + W ?4,$S($P(X,"^",7)]"":$P(X,"^",7),1:"CITY UNSPECIFIED"),", ",$S($D(^DIC(5,+$P(X,"^",8),0)):$P(^(0),"^",2),1:"STATE UNSPECIFIED")," ",$S($P(X,"^",9)]"":$P(X,"^",9),1:"ZIP UNSPECIFIED") + ; +ENDSCR K IBADI,IBDD,IBOUTP,IBINDT,I,X,X1 + G ^IBCSCP + ; +SHW1 S X=IBDD(I,0),Z=$G(^DIC(36,+X,0)) + W !!?4,"Ins ",I,": " W $E($S($P(Z,U,1)'="":$P(Z,U,1),1:IBU),1,16) + I $P(Z,U,2)="N" W ?30,"WILL NOT REIMBURSE" + W ?51,"Policy #: ",$E($S($P(X,"^",2)]"":$P(X,"^",2),1:IBU),1,18) + W !?4,"Grp #: ",$E($S($P(X,"^",3)]"":$P(X,"^",3),1:IBU),1,16) + W ?30,"Whose: ",$S($P(X,"^",6)="v":"VETERAN",$P(X,"^",6)="s":"SPOUSE",1:"OTHER") + W ?51,"Rel to Insd: ",IBIR(I) + W !?4,"Grp Nm: ",$E($S($P(X,"^",15)]"":$P(X,"^",15),1:IBU),1,16) + W ?30,"Insd Sex: ",$S($D(IBISEX(I)):IBISEX(I),1:IBU) + W ?51,"Insured: ",$E($P(X,"^",17),1,19) + Q + ; +UP K IBDD D ALL^IBCNS1(DFN,"IBDD",2,IBINDT,1) + I $D(IBDD("S",.5)) D ; At least 1 MCR WNR insurance policy exists + . ;try to put correct part (A for institution and B for facility) + . N Z,IBAB + . S IBAB=$S($$FT^IBCEF(IBIFN)=3:"A",1:"B") + . S Z=0 F S Z=$O(IBDD("S",.5,Z)) Q:'Z D + .. I $P($G(IBDD(Z,355.3)),U,14)=IBAB S IBDD("S",.1,Z,0)="" K IBDD("S",.5,Z) + Q + ; +UP1() ;check if patient has medicare so can print a flag for the user + N IBDD,IBX,IBY S IBY="" D ALL^IBCNS1(DFN,"IBDD",2,IBINDT) + S IBX=0 F S IBX=$O(IBDD(IBX)) Q:'IBX I $P($G(IBDD(IBX,355.3)),U,9)=33 S IBY="(Patient has Medicare)" + Q IBY + ;IBCSC3 diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC5.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC5.m index 3686d780..70bd7374 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC5.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC5.m @@ -1,72 +1,73 @@ -IBCSC5 ;ALB/MJB - MCCR SCREEN 5 (OPT. EOC) ;27 MAY 88 10:15 - ;;2.0;INTEGRATED BILLING;**52,125,51,210,266,288,287,309,389**;21-MAR-94;Build 6 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ;MAP TO DGCRSC5 - ; -EN I $$INPAT^IBCEF(IBIFN) G ^IBCSC4 - I $D(IBASKCOD) K IBASKCOD D CODMUL^IBCU7 I $$BILLCPT^IBCRU4(IBIFN) D ASK^IBCU7A(IBIFN) S DGRVRCAL=1 - I $D(DGRVRCAL) D ^IBCU6 K DGRVRCAL - L ^DGCR(399,IBIFN):1 - D ^IBCSCU S IBSR=5,IBSR1="",IBV1="10000000"_$S($$FT^IBCEF(IBIFN)'=2:0,1:1) F I="U",0 S IB(I)=$S($D(^DGCR(399,IBIFN,I)):^(I),1:"") S:IBV IBV1="111111111" - D H^IBCSCU - S IBPTF=$P(IB(0),U,8),IBBT=$P(IB(0),"^",4)_$P(IB(0),"^",5)_$P(IB(0),"^",6) - D EN4^IBCVA1 - S Z=1,IBW=1 X IBWW W " Event Date : " S Y=$P(IB(0),U,3) D DT^DIQ - N IBPOARR,IBDATE - D SET^IBCSC4D(IBIFN,"",.IBPOARR) - S IBDATE=$$BDATE^IBACSV(IBIFN) ; Event date - S Z=2,IBW=1 X IBWW W " Prin. Diag.: " S Y=$$DX^IBCSC4(0,IBDATE) W $S(Y'="":$P(Y,U,4)_" - "_$P(Y,U,2),$$DXREQ^IBCSC4(IBIFN):IBU,1:IBUN) - F I=1:1:4 S Y=$$DX^IBCSC4(+Y,IBDATE) Q:Y="" W !?4,"Other Diag.: ",$P(Y,U,4)_" - "_$P(Y,U,2) - I +Y S Y=$$DX^IBCSC4(+Y,IBDATE) I +Y W !?4,"***There are more diagnoses associated with this bill.***" -OP S Z=3,IBW=1 X IBWW W " OP Visits : " F I=0:0 S I=$O(^DGCR(399,IBIFN,"OP",I)) Q:'I S Y=I X ^DD("DD") W:$X>67 !?17 W Y_", " - S:$D(^DGCR(399,"OP")) DGOPV=1 I '$O(^DGCR(399,IBIFN,"OP",0)) W IBU - S Z=4,IBW=1 X IBWW W " Cod. Method: ",$S($P(IB(0),U,9)="":IBUN,$P(IB(0),U,9)=9:"ICD-9-CM",$P(IB(0),U,9)=4:"CPT-4",1:"HCPCS") - D WRT:$D(IBPROC) - S Z=5,IBW=1 X IBWW W " Rx. Refills: " S Y=$$RX I 'Y W IBUN -OCC G OCC^IBCSC4 - W !?4,"Opt. Code : ",IBUN - G OCC^IBCSC4 - Q -MORE W !?4,*7,"***There are more procedures associated with this bill.***" S I=0 - Q -WRT ; -write out procedures codes on screen - N IBDATE - S J=0 F I=1:1 S J=$O(IBPROC(J)) Q:'J D I I>6 D MORE Q - .S IBDATE=$P(IBPROC(J),U,2) I 'IBDATE S IBDATE=$$BDATE^IBACSV($G(IBIFN)) - .S X=$$PRCD^IBCEF1($P(IBPROC(J),U),1,IBDATE) - .I IBPROC(J)["ICD" W !?4,"ICD Code : ",$E($P(X,U,3),1,28)_" - "_$P(X,U,2) - .I IBPROC(J)["CPT" W !?4,"CPT Code : " D - .. N Z - .. S Z=$P(X,"^",3)_" "_$P(X,"^",2)_$S($P(IBPROC(J),U,15):"-"_$$MODLST^IBEFUNC2($P(IBPROC(J),U,15)),1:"") - .. I $L(Z)>40 S Z=" "_$P(X,"^",2)_$S($P(IBPROC(J),U,15):"-"_$$MODLST^IBEFUNC2($P(IBPROC(J),U,15)),1:""),Z=$E($P(X,U,3),1,40-$L(Z))_Z - .. W Z - .I $P(IB(0),U,19)=2 S Y=+$P(IBPROC(J),U,11) S:+Y Y=+$G(^IBA(362.3,+Y,0)) W ?58,$P($$ICD9^IBACSV(Y,IBDATE),U) S Y=$P(IBPROC(J),U,2) D D^DIQ W ?67,Y Q - .S Y=$P(IBPROC(J),"^",2) D D^DIQ W ?67,Y - Q - ; -MOD(IBM,PUNC) ; Returns modifier list from comma delimited ien's in string IBM - ; PUNC = Punctuation to use as first character of output - N IBMOD,Q - S IBMOD="" - F Q=1:1:$L(IBM,",") I $P(IBM,",",Q)'="" S IBMOD=IBMOD_$S(IBMOD'="":",",1:"")_$P($$MOD^ICPTMOD($P(IBM,",",Q),"I"),U,2) - I IBMOD'="" S IBMOD=$G(PUNC)_IBMOD - Q IBMOD - ; -PD() ;prints prosthetic device in external form, returns 0 if there are none - N IBX,IBY,IBZ,IBN,X S X=0 S IBX=0 F S IBX=$O(^IBA(362.5,"AIFN"_IBIFN,IBX)) Q:'IBX D Q:X>5 - . S IBY=0 F S IBY=$O(^IBA(362.5,"AIFN"_IBIFN,IBX,IBY)) Q:'IBY S IBZ=$G(^IBA(362.5,IBY,0)) I IBZ'="" D Q:X>5 - .. S X=X+1 I X>5 W !,?17,"*** There are more Pros. Items associated with this bill.***" Q - .. W:X'=1 ! W ?17,$E($P(IBZ,U,5),1,40),?67,$$FMTE^XLFDT(+IBZ) - Q X - ; -RX() ;prints RX REFILLS in external form, returns 0 if there are none - N IBX,IBY,IBZ,IBN,X S X=0 S IBX="" F S IBX=$O(^IBA(362.4,"AIFN"_IBIFN,IBX)) Q:IBX="" D Q:X>5 - . S IBY=0 F S IBY=$O(^IBA(362.4,"AIFN"_IBIFN,IBX,IBY)) Q:'IBY S IBZ=$G(^IBA(362.4,IBY,0)) I IBZ'="" D Q:X>5 - .. S X=X+1 I X>5 W !,?17,"*** There are more Rx. Refills associated with this bill.***" Q - ..D ZERO^IBRXUTL(+$P(IBZ,U,4)) - .. S IBN=$G(^TMP($J,"IBDRUG",+$P(IBZ,U,4),.01)) W:X'=1 ! W ?17,IBN,?65,$$FMTE^XLFDT(+$P(IBZ,U,3)) - K ^TMP($J,"IBDRUG") - Q X - ; - ;IBCSC5 +IBCSC5 ;ALB/MJB - MCCR SCREEN 5 (OPT. EOC) ;27 MAY 88 10:15 + ;;2.0;INTEGRATED BILLING;**52,125,51,210,266,288,287,309**;21-MAR-94 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; + ;MAP TO DGCRSC5 + ; +EN I $$INPAT^IBCEF(IBIFN) G ^IBCSC4 + I $D(IBASKCOD) K IBASKCOD D CODMUL^IBCU7 I $$BILLCPT^IBCRU4(IBIFN) D ASK^IBCU7A(IBIFN) S DGRVRCAL=1 + I $D(DGRVRCAL) D ^IBCU6 K DGRVRCAL + L ^DGCR(399,IBIFN):1 + D ^IBCSCU S IBSR=5,IBSR1="",IBV1="10000000"_$S($$FT^IBCEF(IBIFN)'=2:0,1:1) F I="U",0 S IB(I)=$S($D(^DGCR(399,IBIFN,I)):^(I),1:"") S:IBV IBV1="111111111" + D H^IBCSCU + S IBPTF=$P(IB(0),U,8),IBBT=$P(IB(0),"^",4)_$P(IB(0),"^",5)_$P(IB(0),"^",6) + D EN4^IBCVA1 + S Z=1,IBW=1 X IBWW W " Event Date : " S Y=$P(IB(0),U,3) D DT^DIQ + N IBPOARR,IBDATE + D SET^IBCSC4D(IBIFN,"",.IBPOARR) + S IBDATE=$$BDATE^IBACSV(IBIFN) ; Event date + S Z=2,IBW=1 X IBWW W " Prin. Diag.: " S Y=$$DX^IBCSC4(0,IBDATE) W $S(Y'="":$P(Y,U,4)_" - "_$P(Y,U,2),$$DXREQ^IBCSC4(IBIFN):IBU,1:IBUN) + F I=1:1:4 S Y=$$DX^IBCSC4(+Y,IBDATE) Q:Y="" W !?4,"Other Diag.: ",$P(Y,U,4)_" - "_$P(Y,U,2) + I +Y S Y=$$DX^IBCSC4(+Y,IBDATE) I +Y W !?4,"***There are more diagnoses associated with this bill.***" +OP S Z=3,IBW=1 X IBWW W " OP Visits : " F I=0:0 S I=$O(^DGCR(399,IBIFN,"OP",I)) Q:'I S Y=I X ^DD("DD") W:$X>67 !?17 W Y_", " + S:$D(^DGCR(399,"OP")) DGOPV=1 I '$O(^DGCR(399,IBIFN,"OP",0)) W IBU + S Z=4,IBW=1 X IBWW W " Cod. Method: ",$S($P(IB(0),U,9)="":IBUN,$P(IB(0),U,9)=9:"ICD-9-CM",$P(IB(0),U,9)=4:"CPT-4",1:"HCPCS") + D WRT:$D(IBPROC) + S Z=5,IBW=1 X IBWW W " Rx. Refills: " S Y=$$RX I 'Y W IBUN +OCC G OCC^IBCSC4 + W !?4,"Opt. Code : ",IBUN + G OCC^IBCSC4 + Q +MORE W !?4,*7,"***There are more procedures associated with this bill.***" S I=0 + Q +WRT ; -write out procedures codes on screen + N IBDATE + S J=0 F I=1:1 S J=$O(IBPROC(J)) Q:'J D I I>6 D MORE Q + .S IBDATE=$P(IBPROC(J),U,2) I 'IBDATE S IBDATE=$$BDATE^IBACSV($G(IBIFN)) + .S X=$$PRCD^IBCEF1($P(IBPROC(J),U),1,IBDATE) + .I IBPROC(J)["ICD" W !?4,"ICD Code : ",$E($P(X,U,3),1,28)_" - "_$P(X,U,2) + .I IBPROC(J)["CPT" W !?4,"CPT Code : " D + .. N Z + .. S Z=$P(X,"^",3)_" "_$P(X,"^",2)_$S($P(IBPROC(J),U,15):"-"_$$MODLST^IBEFUNC2($P(IBPROC(J),U,15)),1:"") + .. I $L(Z)>40 S Z=" "_$P(X,"^",2)_$S($P(IBPROC(J),U,15):"-"_$$MODLST^IBEFUNC2($P(IBPROC(J),U,15)),1:""),Z=$E($P(X,U,3),1,40-$L(Z))_Z + .. W Z + .I $P(IB(0),U,19)=2 S Y=+$P(IBPROC(J),U,11) S:+Y Y=+$G(^IBA(362.3,+Y,0)) W ?58,$P($$ICD9^IBACSV(Y,IBDATE),U) S Y=$P(IBPROC(J),U,2) D D^DIQ W ?67,Y Q + .S Y=$P(IBPROC(J),"^",2) D D^DIQ W ?67,Y + Q + ; +MOD(IBM,PUNC) ; Returns modifier list from comma delimited ien's in string IBM + ; PUNC = Punctuation to use as first character of output + N IBMOD,Q + S IBMOD="" + F Q=1:1:$L(IBM,",") I $P(IBM,",",Q)'="" S IBMOD=IBMOD_$S(IBMOD'="":",",1:"")_$P($$MOD^ICPTMOD($P(IBM,",",Q),"I"),U,2) + I IBMOD'="" S IBMOD=$G(PUNC)_IBMOD + Q IBMOD + ; +PD() ;prints prosthetic device in external form, returns 0 if there are none + N IBX,IBY,IBZ,IBN,X S X=0 S IBX=0 F S IBX=$O(^IBA(362.5,"AIFN"_IBIFN,IBX)) Q:'IBX D Q:X>5 + . S IBY=0 F S IBY=$O(^IBA(362.5,"AIFN"_IBIFN,IBX,IBY)) Q:'IBY S IBZ=$G(^IBA(362.5,IBY,0)) I IBZ'="" D Q:X>5 + .. S X=X+1 I X>5 W !,?17,"*** There are more Pros. Items associated with this bill.***" Q + .. ;S IBN=$G(^RMPR(661,+$P(IBZ,U,3),0)) W:X'=1 ! W ?17,$E($$PIN^IBCSC5B(+IBN),1,35)," - ",$P(IBN,U,1),?65,$$FMTE^XLFDT(+IBZ) + .. S IBN=$$PIN^IBCSC5B(+$P(IBZ,U,3)) W:X'=1 ! W ?17,$E($P(IBN,U,2),1,35)," - ",$P(IBN,U,1),?65,$$FMTE^XLFDT(+IBZ) + Q X + ; +RX() ;prints RX REFILLS in external form, returns 0 if there are none + N IBX,IBY,IBZ,IBN,X S X=0 S IBX="" F S IBX=$O(^IBA(362.4,"AIFN"_IBIFN,IBX)) Q:IBX="" D Q:X>5 + . S IBY=0 F S IBY=$O(^IBA(362.4,"AIFN"_IBIFN,IBX,IBY)) Q:'IBY S IBZ=$G(^IBA(362.4,IBY,0)) I IBZ'="" D Q:X>5 + .. S X=X+1 I X>5 W !,?17,"*** There are more Rx. Refills associated with this bill.***" Q + ..D ZERO^IBRXUTL(+$P(IBZ,U,4)) + .. S IBN=$G(^TMP($J,"IBDRUG",+$P(IBZ,U,4),.01)) W:X'=1 ! W ?17,IBN,?65,$$FMTE^XLFDT(+$P(IBZ,U,3)) + K ^TMP($J,"IBDRUG") + Q X + ; + ;IBCSC5 diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC5B.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC5B.m index 3848e6dd..7017b662 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC5B.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC5B.m @@ -1,167 +1,104 @@ -IBCSC5B ;ALB/ARH - ADD/ENTER PROSTHETIC ITEMS ;12/28/93 - ;;2.0;INTEGRATED BILLING;**4,52,260,339,389**;21-MAR-94;Build 6 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ; -EN ; add/edit prosthetic items for a bill, IBIFN required - N IBX,DFN,IBDT1,IBDT2,IBACTION,BIFN,APROS,ALPROS,ABILL,ALBILL - S IBX=$$BILL(IBIFN) Q:'IBIFN S DFN=+IBX,IBDT1=$P(IBX,U,2),IBDT2=$P(IBX,U,3) - ; -EN1 D PISET(DFN,IBDT1,IBDT2,.APROS,.ALPROS) D SET(IBIFN,.ABILL,.ALBILL,+$G(APROS)) - D PIDISP(.APROS,.ALPROS,.ABILL) D DISP(.ABILL,.ALBILL) S BIFN="" - ; - S IBACTION=$$SELECT(.ALPROS,.ALBILL) Q:'IBACTION - I +IBACTION=1 S BIFN=$$ADD(IBIFN,$P(IBACTION,U,2),$P(IBACTION,U,3)) G EN1 - I +IBACTION=2 S BIFN=+$G(ABILL(+$P(IBACTION,U,2),$P(IBACTION,U,3))) - I +IBACTION=3 S IBX=$$ASKITM(IBDT1,IBDT2) I +IBX S BIFN=$$ADD(IBIFN,+IBX,,$P(IBX,U,2)) - I +BIFN D EDIT(BIFN) - ; - G EN1 - Q - ; -SELECT(ALPROS,ALBILL) ; get which item to add/edit, select from Patient Prosthetics, Bill Items, or add a new one - ; returns 1 ^ PD DEL DATE ^ PI IFN - ALPROS(selected item) if item from Prosthetics selected - ; 2 ^ PD DEL DATE ^ X - ALBILL(selected item) if item existing on bill selected - ; 3 if add new item, "" if exit, -1 if redo - N IBX,IBY,IBZ,DIR,DTOUT,DUOUT,DIRUT,X,Y S IBY="" - S DIR("?")="Select the Prosthetics Item to Add or Edit." - S DIR("?",1)="Enter the number preceding the Item to Add or Edit." - S DIR("?",2)="Or enter the Item name to add an item not in the list and not in Prosthetics.",DIR("?",3)=" " - ; - S DIR("A")="Select Prosthetics Item",DIR(0)="FO^1:20^K:X?1N1P.NP X" D ^DIR S IBX=Y I $D(DIRUT) G SELECTQ - ; - S IBZ=$G(ALPROS(IBX)) I +IBZ W " adding ",IBX S IBY="1^"_IBZ G SELECTQ - S IBZ=$G(ALBILL(IBX)) I +IBZ W " editing ",IBX S IBY="2^"_IBZ G SELECTQ - ; - S DIR(0)="YO",DIR("A")="Add a New Item",DIR("B")="YES" D ^DIR K DIR S IBY=-1 I Y=1,'$D(DIRUT) S IBY=3 - ; -SELECTQ Q IBY - ; -ASKITM(IBDT1,IBDT2) ; Ask for new item data when adding an item not in Prosthetics - ; returns: delivery date ^ prosthetic item name (from 661.1, .02) - N DIR,DIC,DIE,DTOUT,DUOUT,DIRUT,X,Y,IBX,IBY S (IBX,IBY)="" I '$G(IBDT1)!'$G(IBDT2) G ASKITMQ - ; - W !!,"Enter a Prosthetics Item that does not have a Prosthetics Patient record.",! - S DIR("A")="Select ITEM DELIVERY DATE",DIR(0)="DO^"_IBDT1_":"_IBDT2_":EX" D ^DIR S IBX=Y I Y'?7N G ASKITMQ - ; - S DIC="^RMPR(661.1,",DIC(0)="AENOQMZ",DIC("S")="I +$P(^(0),U,5)",DIC("A")="Select PROSTHETICS ITEM: " D ^DIC - ; - I +Y>0,+IBX S IBY=IBX_U_$P($G(Y(0)),U,2) - ; -ASKITMQ Q IBY - ; -ADD(IBIFN,IBDT,PIFN,IBPNAME) ; Add new Item to Bill (#362.5) - N IBX,IBY,IBDX,IBHCPCS,DIC,DIE,DA,DR,DLAYGO,X,Y S IBY=0,PIFN=+$G(PIFN) I ($G(IBDT)'?7N)!('$G(IBIFN)) G ADDQ - ; - I $G(PIFN),$$ONBILLPI(IBIFN,PIFN) G ADDQ ; don't add duplicates - I $G(IBPNAME)="" S IBPNAME=$P($$PIN(PIFN),U,2) I IBPNAME="" G ADDQ - ; - S DIC="^IBA(362.5,",DIC(0)="AQL",DLAYGO=362.5,X=IBDT K DA,DO D FILE^DICN K DA,DO,X - I Y>0 S (IBY,DA)=+Y,DIE=DIC,DR=".02////"_IBIFN_";.04////"_+PIFN_";.05///^S X=IBPNAME" D ^DIE K DIE,DA,DR W "... ADDED" - ; - ;add dx if known - I +IBY,+PIFN F IBX=1:1:4 S IBDX=+$G(^RMPR(660,PIFN,"BA"_IBX)) I IBDX,'$O(^IBA(362.3,"AIFN"_IBIFN,IBDX)) D - . S DIC="^IBA(362.3,",DIC(0)="L",DLAYGO=362.3,X=IBDX,DIC("DR")=".02////"_IBIFN K DD,DO D FILE^DICN S IBDX(+Y)="" - ;add hcpcs if known ;S IBHCPCS=$P($G(^RMPR(660,PIEN,0)),"^",22) I IBHCPCS - ; -ADDQ Q IBY - ; -EDIT(BIFN) ; - N DIDEL,DIE,DIC,DR,DA,X,Y Q:'$G(BIFN) W ! S DIDEL=362.5,DIE="^IBA(362.5,",DR=".01;.05",DA=BIFN D ^DIE - Q - ; -SET(IBIFN,ARRB,ARRBL,PICNT) ; setup array of all prosthetic devices on bill (#362.5), array names should be passed by reference - ; input: PICNT - the number of items found in prosthetics (PISET) - ; output: ARRB(PD DELIV DATE, X) = PD IFN (362.5 ptr) ^ Cost, ARRB = BILL IFN ^ count of items on bill - ; ARRBL(PICNT + count of item on bill) = PD DELIV DATE ^ X - ; where X is the IFN of the Patient Item (660 ptr) or if not defined then a number_"Z" - N CNT,IBX,IBY,BIFN,RIFN,IBC,IBRC K ARRB,ARRBL S IBC="AIFN"_$G(IBIFN),ARRB="^0" Q:'$G(IBIFN) - D RCITEM^IBCSC5A(IBIFN,"IBRC",5) S CNT=0 - ; - S IBX=0 F S IBX=$O(^IBA(362.5,IBC,IBX)) Q:'IBX S BIFN=0 F S BIFN=$O(^IBA(362.5,IBC,IBX,BIFN)) Q:'BIFN D - . S IBY=$G(^IBA(362.5,BIFN,0)) Q:IBY="" S CNT=CNT+1,RIFN=+$P(IBY,U,4),RIFN=$S(+RIFN:+RIFN,1:CNT_"Z") - . S ARRB(+IBY,RIFN)=BIFN_U_$$CHG^IBCF4(BIFN,5,.IBRC),ARRB=$G(ARRB)+1 - S ARRB=IBIFN_U_+$G(ARRB) - ; - S CNT=+$G(PICNT),IBX=0 F S IBX=$O(ARRB(IBX)) Q:'IBX S IBY=0 F S IBY=$O(ARRB(IBX,IBY)) Q:'IBY S CNT=CNT+1,ARRBL(CNT)=IBX_U_IBY - Q - ; -DISP(ABILL,ALBILL) ;screen display of existing prosthetic devices for a bill, arrays should be passed by reference - ; input: ABILL (from SET) list of bill items - ; ALBILL (from SET) list of bill items, in count order - N IBC,IBI,BIFN,BIFN0,DDT - ; - W !!,?5,"----------------- Existing Prosthetic Items for Bill -----------------",! - S IBC=0 F S IBC=$O(ALBILL(IBC)) Q:'IBC D - . S DDT=+ALBILL(IBC),IBI=$P(ALBILL(IBC),U,2),BIFN=+$G(ABILL(DDT,IBI)),BIFN0=$G(^IBA(362.5,BIFN,0)) - . W !,?1,$J(IBC,2),")",?6,$$DATE(DDT),?16,$E($P(BIFN0,U,5),1,60) - W ! - Q - ; -PISET(DFN,DT1,DT2,ARRP,ARRPL) ; get all prosthetic items (660) for a patient and date range, arrays should pass by ref. - ; input: DFN = patient, DT1-DT2 range of dates to search for items - ; output: ARRP(PD DEL DATE (660,10), PI IFN (660 ptr)) = PI IFN (660 ptr), ARRP = count of items - ; ARRPL(count) = PD DEL DATE (660,10) ^ PI IFN (660 ptr) - ; - N PIFN,DDT,IBX,IBY,CNT K ARRP,ARRPL Q:'$G(DFN) S DT1=$G(DT1)-.0001,DT2=$G(DT2) S:'DT2 DT2=9999999 - S PIFN=0 F S PIFN=$O(^RMPR(660,"C",DFN,PIFN)) Q:'PIFN D - . S IBX=$G(^RMPR(660,PIFN,0)) Q:IBX="" S DDT=+$P(IBX,U,12)\1 I (DDTDT2) Q - . S ARRP(DDT,PIFN)=PIFN,ARRP=+$G(ARRP)+1 - ; - S (CNT,IBX)=0 F S IBX=$O(ARRP(IBX)) Q:'IBX S IBY=0 F S IBY=$O(ARRP(IBX,IBY)) Q:'IBY S CNT=CNT+1,ARRPL(CNT)=IBX_U_IBY - Q - ; -PIDISP(APROS,ALPROS,ABILL) ; display all prosthetic items (#660) for a patient and date range, arrays passed by reference, not changed - ; input: APROS (from PISET) patient's prosthetic items - ; ALPROS (from PISET) patient's prosthetics items, in count order - ; ABILL (from SET) list of bill's prosthetics items, only to check if item on bill - N IBC,DDT,PIFN,PNAME,IBY,IBX,IBICD,IBP,IBEX - ; - W @IOF,?33,"PROSTHETICS SCREEN" - W !,"================================================================================",! - S IBC=0 F S IBC=$O(ALPROS(IBC)) Q:'IBC D - . S DDT=+ALPROS(IBC),PIFN=$P(ALPROS(IBC),U,2) - . S PNAME=$$PIN(PIFN),IBY=$G(^RMPR(660,PIFN,"AM")),IBX=$G(^RMPR(660,PIFN,0)) K IBEX - . ; - . F IBICD=1:1:4 Q:$D(IBEX) I $D(^RMPR(660,PIFN,"BA"_IBICD)) F IBP=2:1:8 I $P(^RMPR(660,PIFN,"BA"_IBICD),"^",IBP) S IBEX="("_$P($T(EXEMPT+(IBP-1)),";",3)_")" Q ; look for exemption info - . ; - . W !,$S($D(ABILL(+DDT,PIFN)):"*",1:"") - . W ?1,$J(IBC,2),")",?6,$$DATE(DDT),?16,$E($P(PNAME,U,2),1,27),?45,"("_$P(PNAME,U,3),")",?53,$G(IBEX),?59,$E($$EXSET^IBEFUNC($P(IBX,U,14),660,12),1,4),?64,$$EXSET^IBEFUNC($P(IBY,U,3),660,62),?71,$J(+$P(IBX,U,16),8,2) - Q - ; -PIN(P660,P6611) ; given Prosthetic record (#660) or PSAS HCPCS (#661.1) return Item Name - ; returns PSAS HCPSC ptr (661.1) ^ SHORT DESCRIPTION (661.1, .02) ^ HCPCS (661.1, .01) - N IBX,IBY S IBY="" - I +$G(P660) S P6611=+$P($G(^RMPR(660,+P660,1)),U,4) - I +$G(P6611) S IBX=$G(^RMPR(661.1,+P6611,0)) I IBX'="" S IBY=P6611_U_$P(IBX,U,2)_U_$P(IBX,U,1) - Q IBY - ; -PINB(P3625) ; given the bill prosthetics item (#362.5) return Item Name (.05) - N IBY S IBY=$P($G(^IBA(362.5,+$G(P3625),0)),U,5) - Q IBY - ; -BILL(IBIFN) ; get bill data: returns DFN ^ Statement Covers From ^ Statement Covers To - N IBX,IBY S IBIFN=+$G(IBIFN) S IBX=$G(^DGCR(399,IBIFN,0)),IBY=$P(IBX,U,2) - S IBX=$G(^DGCR(399,IBIFN,"U")),$P(IBY,U,2)=+IBX,$P(IBY,U,3)=+$P(IBX,U,2) - Q IBY - ; -ONBILLPI(IBIFN,PIFN) ; return Bill Item ptr (#362.5) if the Prosthetics Item (#660) is already assigned to the bill - ; input: PIFN = Patient Prosthetics Item (ptr to 660) - ; output: BIFN = Bill Prosthetics Item (ptr to 362.5) or null if not found - N IBC,IBX,IBY,BIFN S IBY="" S IBC="AIFN"_$G(IBIFN) - S IBX=0 F S IBX=$O(^IBA(362.5,IBC,IBX)) Q:'IBX S BIFN=0 F S BIFN=$O(^IBA(362.5,IBC,IBX,BIFN)) Q:'BIFN D - . I +$G(PIFN),$P($G(^IBA(362.5,BIFN,0)),U,4)=PIFN S IBY=BIFN - Q IBY - ; -DATE(X) ; - Q $E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3) - ; -EXEMPT ; exemption reasons - ;;AO - ;;IR - ;;SC - ;;SWA - ;;MST - ;;HNC - ;;CV - ; +IBCSC5B ;ALB/ARH - ADD/ENTER PROSTHETIC ITEMS ;12/28/93 + ;;2.0;INTEGRATED BILLING;**4,52,260,339**;21-MAR-94;Build 2 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; + ; +EN ;add/edit prosthetic items for a bill, IBIFN required + S IBX=$$BILL(IBIFN) Q:'IBIFN S DFN=+IBX,IBDT1=$P(IBX,U,2),IBDT2=$P(IBX,U,3) + D SET(IBIFN,.IBPDA),PIDISP(DFN,IBDT1,IBDT2,.IBPDE,.IBPDA),DISP(.IBPDA) +E1 S IBPIFN=0,IBDT=$$ASKDT(IBDT1,IBDT2) G:'IBDT EXIT + S IBPD=$O(IBPDA(IBDT,0)) S:'IBPD IBPD=$O(IBPDE(IBDT,0)) S IBPD=$$ASKPD(IBPD) G:'IBPD E1 + S IBPIFN=$G(IBPDA(IBDT,+IBPD)) I 'IBPIFN S IBPIFN=$$ADD(IBDT,IBIFN,+IBPD,+$G(IBPDE(IBDT,+IBPD))) I 'IBPIFN W " ??" G E1 + I '$D(IBPDE(IBDT,+IBPD)) W !,"This prosthetic item does not exist in this patients prosthetics record.",! + D EDIT(+IBPIFN) D SET(IBIFN,.IBPDA) W ! G E1 + ; +EXIT K IBPIFN,IBX,IBDT1,IBDT2,IBPDA,IBPDE,IBPD,IBDT + Q + ; +ASKDT(IBDT1,IBDT2,IBDT) ; + I +$G(IBIFN) S DIR("?")="Enter the date the item was delivered to the patient",DIR("??")="^D HELP^IBCSC5B("_IBIFN_")" + S DIR("A")="Select ITEM DELIVERY DATE",DIR(0)="DO^"_IBDT1_":"_IBDT2_":EX" D ^DIR K DIR,DTOUT,DIRUT + Q $S(Y?7N:Y,1:0) + ; +ASKPD(PD) ; + N X,Y + S DIR("A")="Select PROSTHETIC ITEM",DIR(0)="660,4O" S:+$G(PD) DIR("B")=+$G(^RMPR(661,+$G(PD),0)) D ^DIR S:$D(DIRUT)!(Y'>0) Y="" K DIR,DIRUT + Q Y + ; +ADD(IBDT,IFN,IBPD,PIFN) ; + N IBX,IBY,IBDX,IBHCPCS S IBX=0,DIC="^IBA(362.5,",DIC(0)="AQL",X=IBDT K DA,DO D FILE^DICN K DA,DO,X + I Y>0 S DIE=DIC,(IBX,DA)=+Y,DR=".02////"_IFN_";.03////"_IBPD_";.04////"_PIFN D ^DIE K DIE,DIC,DA,DR W "... ADDED" + ;add dx if known + F IBY=1:1:4 S IBDX=+$G(^RMPR(660,PIFN,"BA"_IBY)) I IBDX,'$O(^IBA(362.3,"AIFN"_IFN,IBDX)) D + . S DIC="^IBA(362.3,",DIC(0)="L",DLAYGO=362.3,X=IBDX,DIC("DR")=".02////"_IFN K DD,DO D FILE^DICN S IBDX(+Y)="" + ;add hcpcs if known + ;S IBHCPCS=$P($G(^RMPR(660,PIEN,0)),"^",22) I IBHCPCS + ; + Q IBX + ; +EDIT(PIFN) ; + S DIDEL=362.5,DIE="^IBA(362.5,",DR=".01;.03",DA=PIFN D ^DIE K DIE,DR,DA,DIC,DIDEL + Q + ; +SET(IFN,PDARR) ;setup array of all prosthetic devices for bill, array name should be passed by reference + ;returns: PDARR(PD DELIV DATE, PD ITEM (661 ptr))=PD IFN (362.5 ptr), PDARR=BILL IFN ^ PD count + N CNT,IBX,IBY,PIFN,IBC,IBRC K PDARR S IBC="AIFN"_$G(IFN) + D RCITEM^IBCSC5A(IBIFN,"IBRC",5) + S (CNT,IBX)=0 F S IBX=$O(^IBA(362.5,IBC,IBX)) Q:'IBX S PIFN=0 F S PIFN=$O(^IBA(362.5,IBC,IBX,PIFN)) Q:'PIFN D + . S IBY=$G(^IBA(362.5,PIFN,0)) Q:IBY="" S CNT=CNT+1,PDARR(+IBY,$P(IBY,U,3))=PIFN_U_$$CHG^IBCF4(PIFN,5,.IBRC) + S PDARR=$G(IFN)_"^"_CNT + Q + ; +DISP(PDARR) ;screen display of existing prosthetic devices for a bill, + ;input should be array returned by SET^IBCSC5B: PDARR(PD DT, PD ITEM)=PD IFN (362.5), pass by reference + N IBX,IBY,IBZ + W !!,?5,"----------------- Existing Prosthetic Items for Bill -----------------",! + S IBX=0 F S IBX=$O(PDARR(IBX)) Q:IBX="" S IBY=0 F S IBY=$O(PDARR(IBX,IBY)) Q:'IBY D + . S IBZ=$$PIN(IBY) W !,$$DATE(IBX),?12,$P(IBZ,U,1),?20,$P(IBZ,U,2) + W ! + Q + ; +HELP(IFN) ;called for help from prosthetics enter to display existing devices, displays devices from 660 and 399 + I +$G(IFN) N IBX,IBPDA S IBX=$$BILL(IFN) I +IBX D SET(IFN,.IBPDA),PIDISP($P(IBX,U,1),$P(IBX,U,2),$P(IBX,U,3),"",.IBPDA),DISP(.IBPDA) + Q + ; +PIDISP(DFN,DT1,DT2,ARRAY,PDARR) ; display all prosthetic items (660) for a patient and date range + ;PDARR (as defined by SET^IBCSC5B) passed by ref. only to check if pros. item is on the bill, not necessary, not changed + ;returns ARRAY(PD DEL DATE (660,10), PD ITEM (660,4=661 ptr))=RECORD (660 ptr), should pass by ref. if desired + N PIFN,IBX,IBY,PNAME,DDT,PI,IBICD,IBEX,IBP + K ARRAY S DT1=$G(DT1)-.0001,DT2=$G(DT2) S:'DT2 DT2=9999999 Q:'$G(DFN) + S PIFN=0 F S PIFN=$O(^RMPR(660,"C",DFN,PIFN)) Q:'PIFN D + . S IBX=$G(^RMPR(660,PIFN,0)),DDT=+$P(IBX,U,12)\1 I (DDTDT2) Q + . S ARRAY(DDT,+$P(IBX,U,6))=PIFN + ; + W @IOF,?33,"PROSTHETICS SCREEN",!,"================================================================================",! + S DDT=0 F S DDT=$O(ARRAY(DDT)) Q:'DDT S PI=0 F S PI=$O(ARRAY(DDT,PI)) Q:'PI D + . S PIFN=ARRAY(DDT,PI),PNAME=$$PIN(PI),IBY=$G(^RMPR(660,PIFN,"AM")),IBX=$G(^RMPR(660,PIFN,0)) K IBEX + . ; look for exemption info + . F IBICD=1:1:4 Q:$D(IBEX) I $D(^RMPR(660,PIFN,"BA"_IBICD)) F IBP=2:1:8 I $P(^RMPR(660,PIFN,"BA"_IBICD),"^",IBP) S IBEX="("_$P($T(EXEMPT+(IBP-1)),";",3)_")" Q + . W !,$S($D(PDARR(+DDT,PI)):"*",1:"") + . W ?2,$$DATE(DDT),?12,$P(PNAME,U,1),$G(IBEX),?20,$E($P(PNAME,U,2),1,30),?55,$E($$EXSET^IBEFUNC($P(IBX,U,14),660,12),1,4),?62,$$EXSET^IBEFUNC($P(IBY,U,3),660,62),?70,$J(+$P(IBX,U,16),9,2) + Q + ; +PIN(PITEM) ;given the pros item IFN (661 ptr) returns name for printing (661,.01^441,.05) + N IBX,IBY S IBY="" I +$G(PITEM) S IBX=+$G(^RMPR(661,+PITEM,0)) I +IBX S IBY=IBX_U_$$DESCR^PRCPUX1(0,+IBX) + Q IBY + ; +BILL(IBIFN) ; display all existing prescription refills (52) for a patient and date range + ; (call is a short cut to calling rxdisp if have bill number) + N IBX,IBY S IBX=$G(^DGCR(399,+$G(IBIFN),0)),IBY=$P(IBX,U,2) + S IBX=$G(^DGCR(399,+IBIFN,"U")),$P(IBY,U,2)=+IBX,$P(IBY,U,3)=+$P(IBX,U,2) + Q IBY + ; +DATE(X) ; + Q $E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3) + ; +EXEMPT ; exemption reasons + ;;AO + ;;IR + ;;SC + ;;SWA + ;;MST + ;;HNC + ;;CV + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC61.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC61.m index eda51c45..4de0a277 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC61.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC61.m @@ -1,41 +1,41 @@ -IBCSC61 ;ALB/MJB - MCCR SCREEN UTILITY ;20 JUN 88 10:58 - ;;2.0;INTEGRATED BILLING;**52,80,106,51,210,230,309,389**;21-MAR-94;Build 6 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ;MAP TO IBCSC61 - ; -REV I I>1 W !?4,"Rev. Code",?16,": " - N IBNAME S IBNAME=$E($$NAME($P(IBREVC(I),U,10),$P(IBREVC(I),U,11)),1,17) - S DGRCD=$S($D(^DGCR(399.2,+IBREVC(I),0)):^(0),1:""),DGRCD=$P(DGRCD,"^",1)_"-"_$S(IBNAME'="":IBNAME,1:$E($P(DGRCD,"^",2),1,17)) - I $P(IBREVC(I),"^",6) S DGRCD=DGRCD_$J("",21-$L(DGRCD))_" "_$P($$CPT^ICPTCOD(+$P(IBREVC(I),"^",6)),U,2) - I '$P(IBREVC(I),U,6),$P(IBREVC,U,11) S DGRCD=DGRCD_$J("",21-$L(DGRCD))_" *"_$P($$CPT^ICPTCOD(+$P(IBREVC(I),"^",11)),U,2) - S DGRCD=DGRCD_$J("",28-$L(DGRCD)) - I (+$P(IBREVC(I),"^",3)>1)!($P(IBREVC(I),U,10)'=4) S DGRCD=DGRCD_$J($P(IBREVC(I),"^",3),3) - S X=$S($P(IBREVC(I),"^",4)]"":$P(IBREVC(I),"^",4),1:IBU) I X'=IBU S X2="2$" D COMMA^%DTC - W DGRCD,$J("",32-$L(DGRCD)),X - I $P(IBREVC(I),"^",5)]"",$D(^DGCR(399.1,$P(IBREVC(I),"^",5),0)) W ?60," ",$E($P(^DGCR(399.1,$P(IBREVC(I),"^",5),0),"^"),1,16) - I IBREVC<10,$P(IBREVC(I),U,9)'="",$$FT^IBCEF(IBIFN)=3 S X=$P(IBREVC(I),U,9),X2="2$" D COMMA^%DTC W !,?50,X S IBREVC=IBREVC+1 W ?64,"(Non-Covered)" - Q - ; -CHARGE S (IBCH,IBUCH)=0 F I=1:1 Q:'$D(IBREVC(I)) S IBCH=IBCH+($P(IBREVC(I),U,4)),IBUCH=IBUCH+$P(IBREVC(I),U,9) - I IB("U1")]"" S X=$P(IB("U1"),"^",1),X1=$P(IB("U1"),"^",2),IBCH=X - Q - ; -OFFSET S IBOFFC="" W !?4,"OFFSET",?16,": " S X=$S(IB("U1")']"":0,1:+$P(IB("U1"),U,2)),X2="2$" S:X IBOFFC=$P(IB("U1"),U,3) D COMMA^%DTC - W X," [",$S($L(IBOFFC):IBOFFC,'$P(X,"$",2):"NO OFFSET RECORDED",1:"OFFSET DESCRIPTION UNSPECIFIED"),"]" - D CHARGE W !?4,"BILL TOTAL",?16,": " S X=$S('$D(IBCH):0,1:+IBCH),X2="2$" D COMMA^%DTC W X - K IBOFFC - Q - ; -NAME(TYPE,ITEM) ; if rx or pros or DRG or unassociated return name of the item - N IBNAME S IBNAME="" - I $G(TYPE)=3,+$G(ITEM) D - .D ZERO^IBRXUTL($P($G(^IBA(362.4,+ITEM,0)),U,4)) - .S IBNAME=$G(^TMP($J,"IBDRUG",+$P($G(^IBA(362.4,+ITEM,0)),U,4),.01)) - .K ^TMP($J,"IBDRUG") - .Q - I $G(TYPE)=5,+$G(ITEM) S IBNAME=$P($G(^IBA(362.5,+ITEM,0)),U,5) - I $G(TYPE)=6,+$G(ITEM) S IBNAME=$P($$DRG^IBACSV(+ITEM),U,1) - I $G(TYPE)=9,+$G(ITEM) S IBNAME=$P($G(^IBA(363.21,+ITEM,0)),U,1) - Q IBNAME - ;IBCSC61 +IBCSC61 ;ALB/MJB - MCCR SCREEN UTILITY ;20 JUN 88 10:58 + ;;2.0;INTEGRATED BILLING;**52,80,106,51,210,230,309**;21-MAR-94 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; + ;MAP TO IBCSC61 + ; +REV I I>1 W !?4,"Rev. Code",?16,": " + N IBNAME S IBNAME=$E($$NAME($P(IBREVC(I),U,10),$P(IBREVC(I),U,11)),1,17) + S DGRCD=$S($D(^DGCR(399.2,+IBREVC(I),0)):^(0),1:""),DGRCD=$P(DGRCD,"^",1)_"-"_$S(IBNAME'="":IBNAME,1:$E($P(DGRCD,"^",2),1,17)) + I $P(IBREVC(I),"^",6) S DGRCD=DGRCD_$J("",21-$L(DGRCD))_" "_$P($$CPT^ICPTCOD(+$P(IBREVC(I),"^",6)),U,2) + I '$P(IBREVC(I),U,6),$P(IBREVC,U,11) S DGRCD=DGRCD_$J("",21-$L(DGRCD))_" *"_$P($$CPT^ICPTCOD(+$P(IBREVC(I),"^",11)),U,2) + S DGRCD=DGRCD_$J("",28-$L(DGRCD)) + I (+$P(IBREVC(I),"^",3)>1)!($P(IBREVC(I),U,10)'=4) S DGRCD=DGRCD_$J($P(IBREVC(I),"^",3),3) + S X=$S($P(IBREVC(I),"^",4)]"":$P(IBREVC(I),"^",4),1:IBU) I X'=IBU S X2="2$" D COMMA^%DTC + W DGRCD,$J("",32-$L(DGRCD)),X + I $P(IBREVC(I),"^",5)]"",$D(^DGCR(399.1,$P(IBREVC(I),"^",5),0)) W ?60," ",$E($P(^DGCR(399.1,$P(IBREVC(I),"^",5),0),"^"),1,16) + I IBREVC<10,$P(IBREVC(I),U,9)'="",$$FT^IBCEF(IBIFN)=3 S X=$P(IBREVC(I),U,9),X2="2$" D COMMA^%DTC W !,?50,X S IBREVC=IBREVC+1 W ?64,"(Non-Covered)" + Q + ; +CHARGE S (IBCH,IBUCH)=0 F I=1:1 Q:'$D(IBREVC(I)) S IBCH=IBCH+($P(IBREVC(I),U,4)),IBUCH=IBUCH+$P(IBREVC(I),U,9) + I IB("U1")]"" S X=$P(IB("U1"),"^",1),X1=$P(IB("U1"),"^",2),IBCH=X + Q + ; +OFFSET S IBOFFC="" W !?4,"OFFSET",?16,": " S X=$S(IB("U1")']"":0,1:+$P(IB("U1"),U,2)),X2="2$" S:X IBOFFC=$P(IB("U1"),U,3) D COMMA^%DTC + W X," [",$S($L(IBOFFC):IBOFFC,'$P(X,"$",2):"NO OFFSET RECORDED",1:"OFFSET DESCRIPTION UNSPECIFIED"),"]" + D CHARGE W !?4,"BILL TOTAL",?16,": " S X=$S('$D(IBCH):0,1:+IBCH),X2="2$" D COMMA^%DTC W X + K IBOFFC + Q + ; +NAME(TYPE,ITEM) ; if rx or pros or DRG or unassociated return name of the item + N IBNAME S IBNAME="" + I $G(TYPE)=3,+$G(ITEM) D + .D ZERO^IBRXUTL($P($G(^IBA(362.4,+ITEM,0)),U,4)) + .S IBNAME=$G(^TMP($J,"IBDRUG",+$P($G(^IBA(362.4,+ITEM,0)),U,4),.01)) + .K ^TMP($J,"IBDRUG") + .Q + I $G(TYPE)=5,+$G(ITEM) S IBNAME=$P($$PIN^IBCSC5B(+$P($G(^IBA(362.5,+ITEM,0)),U,3)),U,2) + I $G(TYPE)=6,+$G(ITEM) S IBNAME=$P($$DRG^IBACSV(+ITEM),U,1) + I $G(TYPE)=9,+$G(ITEM) S IBNAME=$P($G(^IBA(363.21,+ITEM,0)),U,1) + Q IBNAME + ;IBCSC61 diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC8H.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC8H.m index 181346a2..6040b14b 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC8H.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC8H.m @@ -1,122 +1,119 @@ -IBCSC8H ;ALB/ARH - MCCR SCREEN 8 (BILL SPECIFIC INFO) CMS-1500 ;4/21/92 - ;;2.0;INTEGRATED BILLING;**51,137,207,210,232,155,320,343,349,371**;21-MAR-94;Build 57 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; CMS-1500 screen 8 - ; - ; MAP TO DGCRSC8H - ; -EN N I,IB,Y,Z - D ^IBCSCU S IBSR=8,IBSR1="H",IBV1="00000000" S:IBV IBV1="11111111" F I="U","U1","UF2","UF3","U2","M","TX",0,"U3" S IB(I)=$G(^DGCR(399,IBIFN,I)) - N IBZ,IBPRV,IBDATE,IBREQ,IBMRASEC,IBZ1 - ; - S IBDATE=$$BDATE^IBACSV(IBIFN) ; Date of service for the bill - S IBPRV="" - D GETPRV^IBCEU(IBIFN,"ALL",.IBPRV) - K IB("PRV") - S IBZ=0 F S IBZ=$O(IBPRV(IBZ)) Q:'IBZ I $O(IBPRV(IBZ,0))!$D(IBPRV(IBZ,"NOTOPT")) M IB("PRV",IBZ)=IBPRV(IBZ) - ; - D H^IBCSCU - S Z=1,IBW=1 X IBWW W " Unable To Work From: " S Y=$P(IB("U"),U,16) X ^DD("DD") W $S(Y'="":Y,1:IBUN) - W !?4,"Unable To Work To : " S Y=$P(IB("U"),U,17) X ^DD("DD") W $S(Y'="":Y,1:IBUN) - S Z=2,IBW=1 X IBWW W " Admitting Dx : " S IBZ=$$ICD9^IBACSV(+IB("U2"),IBDATE) W $S(IBZ'="":$P(IBZ,U)_" - "_$P(IBZ,U,3),1:IBUN) - S IBZ="",IBZ=$S($P(IB("UF3"),U,4)]"":"Pri: "_$P(IB("UF3"),U,4),1:"")_$S($P(IB("UF3"),U,5)'="":" Sec: "_$P(IB("UF3"),U,5),1:"")_$S($P(IB("UF3"),U,6)'="":" Ter: "_$P(IB("UF3"),U,6),1:"") - S:IBZ="" IBZ=IBUN - W !,?4,"ICN/DCN(s) : ",IBZ - S IBZ=$$CKPROV^IBCEU(IBIFN,3) - S IBZ="",IBZ=$S($P(IB("U"),U,13)]"":"Pri: "_$P(IB("U"),U,13),1:"")_$S($P(IB("U2"),U,8)'="":" Sec: "_$P(IB("U2"),U,8),1:"")_$S($P(IB("U2"),U,9)'="":" Ter: "_$P(IB("U2"),U,9),1:"") - S:IBZ="" IBZ=IBUN - W !?4,"Tx Auth. Code(s) : ",IBZ - S Z=3,IBW=1 X IBWW - W " Providers : ",$S('$O(IB("PRV",0)):IBU,1:"") - I $D(IB("PRV")) D ; at least 1 provider found - . N IBQ,A,A1,IBARR,IBTAX,IBNOTAX,IBSPEC,IBNOSPEC - . S IBZ=0 - . D DEFSEC^IBCEF74(IBIFN,.IBARR) - . ; PRXM/KJH - Add Taxonomy code to display for patch 343. Moved secondary IDs slightly (below). - . S IBTAX=$$PROVTAX^IBCEF73A(IBIFN,.IBNOTAX) - . S IBSPEC=$$SPECTAX^IBCEF73A(IBIFN,.IBNOSPEC) - . F S IBZ=$O(IB("PRV",IBZ)) Q:'IBZ D - .. S IBQ="" - .. W !,?5,"- " - .. S A=$$EXPAND^IBTRE(399.0222,.01,IBZ) - .. I $P($G(IB("PRV",IBZ,1)),U,4)'="" S A1=" ("_$E($P(IB("PRV",IBZ,1),U,4),1,3)_")",A=$E(A,1,16-$L(A1))_A1 - .. W $E(A_$J("",16),1,16),": " - .. I '$P($G(IB("PRV",IBZ,1)),U,3),$P($G(IB("PRV",IBZ,1)),U)="" W IBU Q - .. I $P($G(IB("PRV",IBZ,1)),U)'="" W:'$G(IB("PRV",IBZ)) $E($P(IB("PRV",IBZ,1),U)_$J("",16),1,16) W:$G(IB("PRV",IBZ)) "(OLD BOX 31 DATA) "_$P(IB("PRV",IBZ,1),U) - .. I $P($G(IB("PRV",IBZ,1)),U)="",$P($G(IB("PRV",IBZ)),U)'="" W $E($P(IB("PRV",IBZ),U)_$J("",16),1,16) - .. W " Taxonomy: ",$S($P(IBTAX,U,IBZ)'="":$P(IBTAX,U,IBZ),1:IBU),$S($P(IBSPEC,U,IBZ)'="":" ("_$P(IBSPEC,U,IBZ)_")",1:"") - .. F A=1:1:3 I $G(IBARR(IBZ,A))'="" S IBQ=IBQ_"["_$E("PST",A)_"]"_IBARR(IBZ,A)_" " - .. I $L(IBQ) W !,?30,$E(IBQ,1,49) - ; - K IB("PRV") - ; - S Z=4,IBW=1 X IBWW - W " Other Facility (VA/non): " S IBZ=$$EXPAND^IBTRE(399,232,+$P(IB("U2"),U,10)) - W $S(IBZ'="":$E(IBZ,1,23),$$PSRV^IBCEU(IBIFN):IBU,1:IBUN) - I IBZ'="" D - . ; PRXM/KJH - Add Taxonomy code to display for patch 343. - . W ?53,"Taxonomy: " - . S IBZ=$$GET1^DIQ(8932.1,+$P(IB("U3"),U,3),"X12 CODE") W $S(IBZ'="":IBZ,1:IBU) - . S IBZ=$$GET1^DIQ(8932.1,+$P(IB("U3"),U,3),"SPECIALTY CODE") W $S(IBZ'="":" ("_IBZ_")",1:"") - . Q - ; - ; clia# display - IB patch 320 - S (IBZ,IBZ1)=$P(IB("U2"),U,13) ; retrieve CLIA# from database - ; - I IBZ="" D - . NEW CLIAREQ,DEFCLIA,DIE,DA,DR - . S CLIAREQ=$$CLIAREQ^IBCEP8A(IBIFN) - . I 'CLIAREQ S IBZ1=IBUN Q ; clia# not needed - . S DEFCLIA=$$CLIA^IBCEP8A(IBIFN) ; default clia# for claim - . I DEFCLIA="" S IBZ1=IBU Q ; no default found - . I $G(IBMDOTCN) K IBMDOTCN S IBZ1=IBU Q ; user @-deleted clia# - . S IBZ1=DEFCLIA ; display and stuff default clia# - . S DIE=399,DA=IBIFN,DR="235///"_DEFCLIA D ^DIE ; stuff in default - . Q - ; - W !,?4,"Lab CLIA # : ",IBZ1 - ; - ; Mammo# display IB patch 320 - S (IBZ,IBZ1)=$P(IB("U3"),U,1) ; retrieve mammo# from database - ; - ; If mammo# is there, but should not be, then blank it out - I IBZ'="",'$$XRAY^IBCEP8A(IBIFN) D - . NEW DIE,DA,DR - . S IBZ1=IBUN ; mammo# not needed - . S DIE=399,DA=IBIFN,DR="242////@" D ^DIE - . Q - ; - I IBZ="" S IBZ1=IBUN - W !?4,"Mammography Cert # : ",IBZ1 - ; - S Z=5,IBW=1 X IBWW - W " Chiropractic Data : " S Y=$P(IB("U3"),U,5) X ^DD("DD") W $S(Y'="":"INITIAL TREATMENT ON "_Y,1:IBUN) - ; - S Z=6,IBW=1 X IBWW - W " Form Locator 19 : " S IBZ=$P($G(^DGCR(399,IBIFN,"UF31")),U,3) W $S(IBZ'="":IBZ,1:IBUN) - I $P(IB("U2"),U,14)'="" W !,?4,"Homebound : ",$$EXPAND^IBTRE(399,236,$P(IB("U2"),U,14)) - I $P(IB("U2"),U,15)'="" W !,?4,"Date Last Seen : ",$$EXPAND^IBTRE(399,237,$P(IB("U2"),U,15)) - I $P(IB("U2"),U,16)'="" W !,?4,"Spec Prog Indicator: " S IBZ=$$EXPAND^IBTRE(399,238,$P(IB("U2"),U,16)) W $S(IBZ'="":IBZ,$$WNRBILL^IBEFUNC(IBIFN):"31",1:"") - ; - S Z=7,IBW=1 X IBWW - S IBREQ=+$$REQMRA^IBEFUNC(IBIFN) S:IBREQ IBREQ=1 - S IBMRASEC=$$MRASEC^IBCEF4(IBIFN) - W " ",$S('IBREQ:"Force To Print? : ",1:"Force MRA Sec Prt? : ") - S IBZ=$$EXTERNAL^DILFD(399,27+IBREQ,,+$P(IB("TX"),U,8+IBREQ)) - I IBMRASEC,'$P(IB("TX"),U,8),$P(IB("TX"),U,9) S IBZ="FORCED TO PRINT BY MRA PRIMARY",$P(IB("TX"),U,8)=0 - W $S(IBZ'=""&($P(IB("TX"),U,8+IBREQ)'=""):IBZ,'$$TXMT^IBCEF4(IBIFN):"[NOT APPLICABLE - NOT TRANSMITTABLE]",IBREQ:"NO FORCED PRINT",1:IBZ) - ; - S Z=8,IBW=1 X IBWW - W " Provider ID Maint : (Edit Provider ID information)",! - G ^IBCSCP -Q Q - ; -WRT1(IBCRED) ; Write credentials mismatch - W !,*7," **Warning** Credentials differ from those found in NEW PERSON or IB NON VA",!,$J("",14),"BILLING PROVIDER file (",$S(IBCRED="":"none",1:IBCRED),")" - W !,$J("",14),"Changes will print local, but only credentials on file transmit" - Q - ; -NSAME(DA) ; Returns 1 if div on bill is not the default billing facility - Q ($P($G(^IBE(350.9,1,0)),U,2)'=$P($G(^DG(40.8,+$P(^DGCR(399,DA,0),U,22),0)),U,7)) - ; - ;IBCSC8H +IBCSC8H ;ALB/ARH - MCCR SCREEN 8 (BILL SPECIFIC INFO) CMS-1500 ;4/21/92 + ;;2.0;INTEGRATED BILLING;**51,137,207,210,232,155,320,343,349**;21-MAR-94;Build 46 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; CMS-1500 screen 8 + ; + ; MAP TO DGCRSC8H + ; +EN N I,IB,Y,Z + D ^IBCSCU S IBSR=8,IBSR1="H",IBV1="0000000" S:IBV IBV1="1111111" F I="U","U1","UF2","UF3","U2","M","TX",0,"U3" S IB(I)=$G(^DGCR(399,IBIFN,I)) + N IBZ,IBPRV,IBDATE,IBREQ,IBMRASEC,IBZ1 + ; + S IBDATE=$$BDATE^IBACSV(IBIFN) ; Date of service for the bill + S IBPRV="" + D GETPRV^IBCEU(IBIFN,"ALL",.IBPRV) + K IB("PRV") + S IBZ=0 F S IBZ=$O(IBPRV(IBZ)) Q:'IBZ I $O(IBPRV(IBZ,0))!$D(IBPRV(IBZ,"NOTOPT")) M IB("PRV",IBZ)=IBPRV(IBZ) + ; + D H^IBCSCU + S Z=1,IBW=1 X IBWW W " Unable To Work From: " S Y=$P(IB("U"),U,16) X ^DD("DD") W $S(Y'="":Y,1:IBUN) + W !?4,"Unable To Work To : " S Y=$P(IB("U"),U,17) X ^DD("DD") W $S(Y'="":Y,1:IBUN) + S Z=2,IBW=1 X IBWW W " Admitting Dx : " S IBZ=$$ICD9^IBACSV(+IB("U2"),IBDATE) W $S(IBZ'="":$P(IBZ,U)_" - "_$P(IBZ,U,3),1:IBUN) + S IBZ="",IBZ=$S($P(IB("UF3"),U,4)]"":"Pri: "_$P(IB("UF3"),U,4),1:"")_$S($P(IB("UF3"),U,5)'="":" Sec: "_$P(IB("UF3"),U,5),1:"")_$S($P(IB("UF3"),U,6)'="":" Ter: "_$P(IB("UF3"),U,6),1:"") + S:IBZ="" IBZ=IBUN + W !,?4,"ICN/DCN(s) : ",IBZ + S IBZ=$$CKPROV^IBCEU(IBIFN,3) + S IBZ="",IBZ=$S($P(IB("U"),U,13)]"":"Pri: "_$P(IB("U"),U,13),1:"")_$S($P(IB("U2"),U,8)'="":" Sec: "_$P(IB("U2"),U,8),1:"")_$S($P(IB("U2"),U,9)'="":" Ter: "_$P(IB("U2"),U,9),1:"") + S:IBZ="" IBZ=IBUN + W !?4,"Tx Auth. Code(s) : ",IBZ + S Z=3,IBW=1 X IBWW + W " Providers : ",$S('$O(IB("PRV",0)):IBU,1:"") + I $D(IB("PRV")) D ; at least 1 provider found + . N IBQ,A,A1,IBARR,IBTAX,IBNOTAX,IBSPEC,IBNOSPEC + . S IBZ=0 + . D DEFSEC^IBCEF74(IBIFN,.IBARR) + . ; PRXM/KJH - Add Taxonomy code to display for patch 343. Moved secondary IDs slightly (below). + . S IBTAX=$$PROVTAX^IBCEF73A(IBIFN,.IBNOTAX) + . S IBSPEC=$$SPECTAX^IBCEF73A(IBIFN,.IBNOSPEC) + . F S IBZ=$O(IB("PRV",IBZ)) Q:'IBZ D + .. S IBQ="" + .. W !,?5,"- " + .. S A=$$EXPAND^IBTRE(399.0222,.01,IBZ) + .. I $P($G(IB("PRV",IBZ,1)),U,4)'="" S A1=" ("_$E($P(IB("PRV",IBZ,1),U,4),1,3)_")",A=$E(A,1,16-$L(A1))_A1 + .. W $E(A_$J("",16),1,16),": " + .. I '$P($G(IB("PRV",IBZ,1)),U,3),$P($G(IB("PRV",IBZ,1)),U)="" W IBU Q + .. I $P($G(IB("PRV",IBZ,1)),U)'="" W:'$G(IB("PRV",IBZ)) $E($P(IB("PRV",IBZ,1),U)_$J("",16),1,16) W:$G(IB("PRV",IBZ)) "(OLD BOX 31 DATA) "_$P(IB("PRV",IBZ,1),U) + .. I $P($G(IB("PRV",IBZ,1)),U)="",$P($G(IB("PRV",IBZ)),U)'="" W $E($P(IB("PRV",IBZ),U)_$J("",16),1,16) + .. W " Taxonomy: ",$S($P(IBTAX,U,IBZ)'="":$P(IBTAX,U,IBZ),1:IBU),$S($P(IBSPEC,U,IBZ)'="":" ("_$P(IBSPEC,U,IBZ)_")",1:"") + .. F A=1:1:3 I $G(IBARR(IBZ,A))'="" S IBQ=IBQ_"["_$E("PST",A)_"]"_IBARR(IBZ,A)_" " + .. I $L(IBQ) W !,?30,$E(IBQ,1,49) + ; + K IB("PRV") + ; + S Z=4,IBW=1 X IBWW + W " Other Facility (VA/non): " S IBZ=$$EXPAND^IBTRE(399,232,+$P(IB("U2"),U,10)) + W $S(IBZ'="":$E(IBZ,1,23),$$PSRV^IBCEU(IBIFN):IBU,1:IBUN) + I IBZ'="" D + . ; PRXM/KJH - Add Taxonomy code to display for patch 343. + . W ?53,"Taxonomy: " + . S IBZ=$$GET1^DIQ(8932.1,+$P(IB("U3"),U,3),"X12 CODE") W $S(IBZ'="":IBZ,1:IBU) + . S IBZ=$$GET1^DIQ(8932.1,+$P(IB("U3"),U,3),"SPECIALTY CODE") W $S(IBZ'="":" ("_IBZ_")",1:"") + . Q + ; + ; clia# display - IB patch 320 + S (IBZ,IBZ1)=$P(IB("U2"),U,13) ; retrieve CLIA# from database + ; + I IBZ="" D + . NEW CLIAREQ,DEFCLIA,DIE,DA,DR + . S CLIAREQ=$$CLIAREQ^IBCEP8A(IBIFN) + . I 'CLIAREQ S IBZ1=IBUN Q ; clia# not needed + . S DEFCLIA=$$CLIA^IBCEP8A(IBIFN) ; default clia# for claim + . I DEFCLIA="" S IBZ1=IBU Q ; no default found + . I $G(IBMDOTCN) K IBMDOTCN S IBZ1=IBU Q ; user @-deleted clia# + . S IBZ1=DEFCLIA ; display and stuff default clia# + . S DIE=399,DA=IBIFN,DR="235///"_DEFCLIA D ^DIE ; stuff in default + . Q + ; + W !,?4,"Lab CLIA # : ",IBZ1 + ; + ; Mammo# display IB patch 320 + S (IBZ,IBZ1)=$P(IB("U3"),U,1) ; retrieve mammo# from database + ; + ; If mammo# is there, but should not be, then blank it out + I IBZ'="",'$$XRAY^IBCEP8A(IBIFN) D + . NEW DIE,DA,DR + . S IBZ1=IBUN ; mammo# not needed + . S DIE=399,DA=IBIFN,DR="242////@" D ^DIE + . Q + ; + I IBZ="" S IBZ1=IBUN + W !?4,"Mammography Cert # : ",IBZ1 + ; + S Z=5,IBW=1 X IBWW + W " Form Locator 19 : " S IBZ=$P($G(^DGCR(399,IBIFN,"UF31")),U,3) W $S(IBZ'="":IBZ,1:IBUN) + I $P(IB("U2"),U,14)'="" W !,?4,"Homebound : ",$$EXPAND^IBTRE(399,236,$P(IB("U2"),U,14)) + I $P(IB("U2"),U,15)'="" W !,?4,"Date Last Seen : ",$$EXPAND^IBTRE(399,237,$P(IB("U2"),U,15)) + I $P(IB("U2"),U,16)'="" W !,?4,"Spec Prog Indicator: " S IBZ=$$EXPAND^IBTRE(399,238,$P(IB("U2"),U,16)) W $S(IBZ'="":IBZ,$$WNRBILL^IBEFUNC(IBIFN):"31",1:"") + ; + S Z=6,IBW=1 X IBWW + S IBREQ=+$$REQMRA^IBEFUNC(IBIFN) S:IBREQ IBREQ=1 + S IBMRASEC=$$MRASEC^IBCEF4(IBIFN) + W " ",$S('IBREQ:"Force To Print? : ",1:"Force MRA Sec Prt? : ") + S IBZ=$$EXTERNAL^DILFD(399,27+IBREQ,,+$P(IB("TX"),U,8+IBREQ)) + I IBMRASEC,'$P(IB("TX"),U,8),$P(IB("TX"),U,9) S IBZ="FORCED TO PRINT BY MRA PRIMARY",$P(IB("TX"),U,8)=0 + W $S(IBZ'=""&($P(IB("TX"),U,8+IBREQ)'=""):IBZ,'$$TXMT^IBCEF4(IBIFN):"[NOT APPLICABLE - NOT TRANSMITTABLE]",IBREQ:"NO FORCED PRINT",1:IBZ) + ; + S Z=7,IBW=1 X IBWW + W " Provider ID Maint : (Edit Provider ID information)",! + G ^IBCSCP +Q Q + ; +WRT1(IBCRED) ; Write credentials mismatch + W !,*7," **Warning** Credentials differ from those found in NEW PERSON or IB NON VA",!,$J("",14),"BILLING PROVIDER file (",$S(IBCRED="":"none",1:IBCRED),")" + W !,$J("",14),"Changes will print local, but only credentials on file transmit" + Q + ; +NSAME(DA) ; Returns 1 if div on bill is not the default billing facility + Q ($P($G(^IBE(350.9,1,0)),U,2)'=$P($G(^DG(40.8,+$P(^DGCR(399,DA,0),U,22),0)),U,7)) + ; + ;IBCSC8H diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSCE.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSCE.m index d04d34b2..771b7d67 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSCE.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSCE.m @@ -1,86 +1,85 @@ -IBCSCE ;ALB/MRL,MJB - MCCR SCREEN EDITS ;07 JUN 88 14:35 - ;;2.0;INTEGRATED BILLING;**52,80,91,106,51,137,236,245,287,349,371**;21-MAR-94;Build 57 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ;MAP TO DGCRSCE - ; always do procedures last because they are edited upon return to screen routine - I IBDR20["54," S IBDR20=$P(IBDR20,"54,",1)_$P(IBDR20,"54,",2)_"54," - I IBDR20["44," S IBDR20=$P(IBDR20,"44,",1)_$P(IBDR20,"44,",2)_"44," -LOOP N IBDRLP,IBDRL S IBDRLP=IBDR20 F IBDRL=1:1 S IBDR20=$P(IBDRLP,",",IBDRL) Q:IBDR20="" D EDIT - Q -EDIT N IBQUERY - I (IBDR20["31") D MCCR^IBCNSP2 G ENQ - I (IBDR20["43")!(IBDR20["52") D ^IBCSC4D G ENQ - I (IBDR20["74")!(IBDR20["53") K DR N I D ^IBCOPV S (DA,Y)=IBIFN G TMPL - I (IBDR20["54"),$P($G(^IBE(350.9,1,1)),"^",17) K DR N I D EN1^IBCCPT(.IBQUERY) D CLOSE^IBSDU(.IBQUERY) G TMPL ; - I (IBDR20["55") D ^IBCSC5A G ENQ - I (IBDR20["45")!(IBDR20["56") D ^IBCSC5B G ENQ - I (IBDR20["66")!(IBDR20["76") D EDIT^IBCRBE(IBIFN) D ASKCMB^IBCU65(IBIFN) G ENQ - I IBDR20["85",$$FT^IBCEF(IBIFN)=2 D ^IBCSC8A G ENQ ; chiropractic data - I IBDR20["84",$$FT^IBCEF(IBIFN)=3 D EN1^IBCEP6 G ENQ ;UB-04 - I IBDR20["88",$$FT^IBCEF(IBIFN)=2 D EN1^IBCEP6 G ENQ ;CMS-1500 - F Q=1:1:9 I IBDR20[("9"_Q) D EDIT^IBCSC9 G ENQ -TMPL N IBFLIAE S IBFLIAE=1 ;to invoke EN^DGREGAED from [IB SCREEN1] - S DR="[IB SCREEN"_IBSR_IBSR1_"]",(DA,Y)=IBIFN,DIE="^DGCR(399," - D ^DIE K DIE,DR,DLAYGO - I (IBDR20["61")!(IBDR20["71") I +$G(DGRVRCAL) D PROC^IBCU7A(IBIFN,1) -ENQ K DIE,DR,IBDR1,IBDR20,DGDRD,DGDRS,DGDRS1,DA Q - ; - ; W I "^11^12^13^15^14^21^22^23^"[("^"_J_"^") G W1 - ; I "^44^"[("^"_J_"^") S DR(2,399.0304)=".01;1;I $D(IBIP),X<$P(IBIP,""^"",2)!($P(IBIP,""^"",6)&(X>$P(IBIP,""^"",6))) K X" - ; I "^64^"[("^"_J_"^") S DR(2,399.042)=".01:.03;" - ; I $T(@J) S DGDRD=$P($T(@J),";;",2) D S S K=(J*10) I $T(@K) S DGDRD=$P($T(@K),";;",2) D S - ; D ^IBCSCE1:("^31^")[("^"_J_"^") Q - ; W1 I @DGDRS["^2^DPT(^^D SET^IBCSCE;" D ^IBCSCE1 Q - ; S DGDRD="^2^DPT(^^D SET^IBCSCE;" D S,^IBCSCE1 Q - ; S I $L(@DGDRS)+$L(DGDRD)<241 S @DGDRS=@DGDRS_DGDRD Q - ; S DGCT=DGCT+1,DGDRS="DR(1,399,"_DGCT_")",@DGDRS=DGDRD Q - ; Q -16 ;;.18; -31 ;;.07;S X=$P(^DGCR(399,DA,0),U,11);S Y="@"_$S(X']"":31,X="p":31,X="o":311,1:310);@310;D 1^IBCSCH1 S Y="@"_$S(IBADI=-1:31,'IBADI:312,1:313);@313;^2^DPT(^^D SET^IBCSCE;D UPDT^IBCSCE;@312; -310 ;;101;102;103;S Y="@31";@311;D INST^IBCU;111;K DIC("DR"),DLAYGO;@31; -32 ;;104;105;106;121;107;108;109 -41 ;;S:IBPTF Y="@411";159.5;@411;160;159;158; -42 ;;162; -43 ;;I IBPTF S Y="@943";64;65;66;67;68;S Y="@43";@943;D DX^IBCSC4B;@43; -44 ;;S IBZ20=$P(^DGCR(399,DA,0),U,9);.09;D PRO^IBCSC4B;S IBASKCOD=1 -45 ;;41; -46 ;;40; -51 ;;.03; -999 ;;64;65;66;67;68; -52 ;;64;S:X="" Y="@99";65;S:X="" Y="@99";66;S:X="" Y="@99";67;S:X="" Y="@99";68;@99; -53 ;;;;same as 74 -54 ;;S IBZ20=$P(^DGCR(399,DA,0),U,9);.09;S IBASKCOD=1 -55 ;;41; -56 ;;40; -61 ;;.06;164; -62 ;;155;S:X=0 Y=156;157;156;S:'$D(IBOX) Y="@62";153;@62; -63 ;;151;152; -64 ;;161;165; -65 ;;D RCD^IBCU1;42;202;S:'X Y=201;203;201;I $P(^DGCR(399,DA,"U1"),"^",11)']"" S Y="@65";210;@65; -71 ;;.06;164; -72 ;;155;S:X=0 Y=156;157;156;S:'$D(IBOX) Y="@72";153;@72; -73 ;;151;152; -74 ;;S:$D(IBOUT) Y="@999";43;@999;K IBOUT; -75 ;;D RCD^IBCU1;42;202;S:'X Y=201;203;201;I $P(^DGCR(399,DA,"U1"),"^",11)']"" S Y="@75";210;@75; -81 ;;208; -82 ;;204; -83 ;;205; -84 ;;206; -85 ;;207; -86 ;;163; - ; AD S X=$S($D(^DPT(DA,.11)):^(.11),1:""),IBPHO=$S($D(^(.13)):$P(^(.13),U,1),1:""),Y=$S($D(^(IBADD)):^(IBADD),1:""),^(IBADD)=$P(Y,U,1)_U_$P(Y,U,2)_U_$P(X,U,1,6)_U_IBPHO_U_$P(Y,U,10) K IBADD,IBPHO Q - ; SET S I(0,0)=D0,Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:""),X=$P(Y(1),"^",2),D(0)=X,X=$S(D(0)>0:D(0),1:"") Q - ;called by screen 3 (input template) -UPDT F IBDD=0:0 S IBDD=$O(^DPT(DFN,.312,IBDD)) Q:IBDD'>0 S IBI1=^DPT(DFN,.312,IBDD,0) I $D(^DIC(36,+IBI1,0)),$P(^(0),"^",2)'="N" S IBDD(+IBI1)=IBI1 - F IBAIC=0:0 S IBAIC=$O(^DGCR(399,IBIFN,"AIC",IBAIC)) Q:IBAIC'>0 I $D(IBDD(IBAIC)) F IBI1="I1","I2","I3" I $D(^DGCR(399,IBIFN,IBI1)),+^(IBI1)=IBAIC,^(IBI1)'=IBDD(IBAIC) S ^DGCR(399,IBIFN,IBI1)=IBDD(IBAIC) - K IBAIC,IBDD,IBI1 Q - ; - ;Edit patient's address using DGREGAED API -EDADDR(IBDFN) ; - I $G(IBFLIAE)'=1!(IBDFN=0) Q 0 - N IBFL S IBFL(1)=1 - N X,Y,DIE,DA,DR,DIDEL,DIW,DIEDA,DG,DICR - D EN^DGREGAED(IBDFN,.IBFL) - Q 1 - ;IBCSCE +IBCSCE ;ALB/MRL,MJB - MCCR SCREEN EDITS ;07 JUN 88 14:35 + ;;2.0;INTEGRATED BILLING;**52,80,91,106,51,137,236,245,287,349**;21-MAR-94;Build 46 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; + ;MAP TO DGCRSCE + ; always do procedures last because they are edited upon return to screen routine + I IBDR20["54," S IBDR20=$P(IBDR20,"54,",1)_$P(IBDR20,"54,",2)_"54," + I IBDR20["44," S IBDR20=$P(IBDR20,"44,",1)_$P(IBDR20,"44,",2)_"44," +LOOP N IBDRLP,IBDRL S IBDRLP=IBDR20 F IBDRL=1:1 S IBDR20=$P(IBDRLP,",",IBDRL) Q:IBDR20="" D EDIT + Q +EDIT N IBQUERY + I (IBDR20["31") D MCCR^IBCNSP2 G ENQ + I (IBDR20["43")!(IBDR20["52") D ^IBCSC4D G ENQ + I (IBDR20["74")!(IBDR20["53") K DR N I D ^IBCOPV S (DA,Y)=IBIFN G TMPL + I (IBDR20["54"),$P($G(^IBE(350.9,1,1)),"^",17) K DR N I D EN1^IBCCPT(.IBQUERY) D CLOSE^IBSDU(.IBQUERY) G TMPL ; + I (IBDR20["55") D ^IBCSC5A G ENQ + I (IBDR20["45")!(IBDR20["56") D ^IBCSC5B G ENQ + I (IBDR20["66")!(IBDR20["76") D EDIT^IBCRBE(IBIFN) D ASKCMB^IBCU65(IBIFN) G ENQ + I IBDR20["84",$$FT^IBCEF(IBIFN)=3 D EN1^IBCEP6 G ENQ ;UB-04 + I IBDR20["87",$$FT^IBCEF(IBIFN)=2 D EN1^IBCEP6 G ENQ ;CMS-1500 + F Q=1:1:9 I IBDR20[("9"_Q) D EDIT^IBCSC9 G ENQ +TMPL N IBFLIAE S IBFLIAE=1 ;to invoke EN^DGREGAED from [IB SCREEN1] + S DR="[IB SCREEN"_IBSR_IBSR1_"]",(DA,Y)=IBIFN,DIE="^DGCR(399," + D ^DIE K DIE,DR,DLAYGO + I (IBDR20["61")!(IBDR20["71") I +$G(DGRVRCAL) D PROC^IBCU7A(IBIFN,1) +ENQ K DIE,DR,IBDR1,IBDR20,DGDRD,DGDRS,DGDRS1,DA Q + ; + ; W I "^11^12^13^15^14^21^22^23^"[("^"_J_"^") G W1 + ; I "^44^"[("^"_J_"^") S DR(2,399.0304)=".01;1;I $D(IBIP),X<$P(IBIP,""^"",2)!($P(IBIP,""^"",6)&(X>$P(IBIP,""^"",6))) K X" + ; I "^64^"[("^"_J_"^") S DR(2,399.042)=".01:.03;" + ; I $T(@J) S DGDRD=$P($T(@J),";;",2) D S S K=(J*10) I $T(@K) S DGDRD=$P($T(@K),";;",2) D S + ; D ^IBCSCE1:("^31^")[("^"_J_"^") Q + ; W1 I @DGDRS["^2^DPT(^^D SET^IBCSCE;" D ^IBCSCE1 Q + ; S DGDRD="^2^DPT(^^D SET^IBCSCE;" D S,^IBCSCE1 Q + ; S I $L(@DGDRS)+$L(DGDRD)<241 S @DGDRS=@DGDRS_DGDRD Q + ; S DGCT=DGCT+1,DGDRS="DR(1,399,"_DGCT_")",@DGDRS=DGDRD Q + ; Q +16 ;;.18; +31 ;;.07;S X=$P(^DGCR(399,DA,0),U,11);S Y="@"_$S(X']"":31,X="p":31,X="o":311,1:310);@310;D 1^IBCSCH1 S Y="@"_$S(IBADI=-1:31,'IBADI:312,1:313);@313;^2^DPT(^^D SET^IBCSCE;D UPDT^IBCSCE;@312; +310 ;;101;102;103;S Y="@31";@311;D INST^IBCU;111;K DIC("DR"),DLAYGO;@31; +32 ;;104;105;106;121;107;108;109 +41 ;;S:IBPTF Y="@411";159.5;@411;160;159;158; +42 ;;162; +43 ;;I IBPTF S Y="@943";64;65;66;67;68;S Y="@43";@943;D DX^IBCSC4B;@43; +44 ;;S IBZ20=$P(^DGCR(399,DA,0),U,9);.09;D PRO^IBCSC4B;S IBASKCOD=1 +45 ;;41; +46 ;;40; +51 ;;.03; +999 ;;64;65;66;67;68; +52 ;;64;S:X="" Y="@99";65;S:X="" Y="@99";66;S:X="" Y="@99";67;S:X="" Y="@99";68;@99; +53 ;;;;same as 74 +54 ;;S IBZ20=$P(^DGCR(399,DA,0),U,9);.09;S IBASKCOD=1 +55 ;;41; +56 ;;40; +61 ;;.06;164; +62 ;;155;S:X=0 Y=156;157;156;S:'$D(IBOX) Y="@62";153;@62; +63 ;;151;152; +64 ;;161;165; +65 ;;D RCD^IBCU1;42;202;S:'X Y=201;203;201;I $P(^DGCR(399,DA,"U1"),"^",11)']"" S Y="@65";210;@65; +71 ;;.06;164; +72 ;;155;S:X=0 Y=156;157;156;S:'$D(IBOX) Y="@72";153;@72; +73 ;;151;152; +74 ;;S:$D(IBOUT) Y="@999";43;@999;K IBOUT; +75 ;;D RCD^IBCU1;42;202;S:'X Y=201;203;201;I $P(^DGCR(399,DA,"U1"),"^",11)']"" S Y="@75";210;@75; +81 ;;208; +82 ;;204; +83 ;;205; +84 ;;206; +85 ;;207; +86 ;;163; + ; AD S X=$S($D(^DPT(DA,.11)):^(.11),1:""),IBPHO=$S($D(^(.13)):$P(^(.13),U,1),1:""),Y=$S($D(^(IBADD)):^(IBADD),1:""),^(IBADD)=$P(Y,U,1)_U_$P(Y,U,2)_U_$P(X,U,1,6)_U_IBPHO_U_$P(Y,U,10) K IBADD,IBPHO Q + ; SET S I(0,0)=D0,Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:""),X=$P(Y(1),"^",2),D(0)=X,X=$S(D(0)>0:D(0),1:"") Q + ;called by screen 3 (input template) +UPDT F IBDD=0:0 S IBDD=$O(^DPT(DFN,.312,IBDD)) Q:IBDD'>0 S IBI1=^DPT(DFN,.312,IBDD,0) I $D(^DIC(36,+IBI1,0)),$P(^(0),"^",2)'="N" S IBDD(+IBI1)=IBI1 + F IBAIC=0:0 S IBAIC=$O(^DGCR(399,IBIFN,"AIC",IBAIC)) Q:IBAIC'>0 I $D(IBDD(IBAIC)) F IBI1="I1","I2","I3" I $D(^DGCR(399,IBIFN,IBI1)),+^(IBI1)=IBAIC,^(IBI1)'=IBDD(IBAIC) S ^DGCR(399,IBIFN,IBI1)=IBDD(IBAIC) + K IBAIC,IBDD,IBI1 Q + ; + ;Edit patient's address using DGREGAED API +EDADDR(IBDFN) ; + I $G(IBFLIAE)'=1!(IBDFN=0) Q 0 + N IBFL S IBFL(1)=1 + N X,Y,DIE,DA,DR,DIDEL,DIW,DIEDA,DG,DICR + D EN^DGREGAED(IBDFN,.IBFL) + Q 1 + ;IBCSCE diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSCH.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSCH.m index e62360a2..30ae4a5c 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSCH.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSCH.m @@ -1,143 +1,141 @@ -IBCSCH ;ALB/MJB - MCCR HELP ROUTINE ;03 JUN 88 15:25 - ;;2.0;INTEGRATED BILLING;**52,80,106,124,138,51,148,137,161,245,232,287,348,349,374,371,395**;21-MAR-94;Build 3 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ;MAP TO DGCRSCH - ; - N I,C,IBSCNNZ,IBQ,IBPRNT,Z S IBSCNNZ=$$UP^XLFSTR($G(IBSCNN)),IBQ=0 - I '$D(IBPAR) D Q:IBQ - . I $F(".?1500.?HCFA.","."_$G(IBSCNNZ)_"."),$$FT^IBCEF(IBIFN)=2 S IBQ=1,IBPRNT=2 D BL24(IBIFN,0) Q - . I $G(IBSCNNZ)="?SC" S IBQ=1 D DISPSC(IBIFN) Q - . I $G(IBSCNNZ)="?INS" S IBQ=1 D INSDSPL(IBIFN) Q - . I $G(IBSCNNZ)="?INX" S IBQ=1 D INSDSPLX(IBIFN) Q - . I $G(IBSCNNZ)="?PRV" S IBQ=1 D DISPROPT(IBIFN) Q - . I $G(IBSCNNZ)="?CHG" S IBQ=1 D DISPCHG^IBCRBH1(IBIFN) Q - . I $G(IBSCNNZ)="?PRC" S IBQ=1 D DISPPRC^IBCSCH1(IBIFN) Q - . I $G(IBSCNNZ)="?CPT" S IBQ=1 D BCPTCHG^IBCRBH2(IBIFN) Q - . I $G(IBSCNNZ)="?INC" S IBQ=1 D EDIT^IBCBB(IBIFN) Q - . I $G(IBSCNNZ)="?CLA",$$CK0^IBCIUT1() S IBQ=1 D CLA^IBCISC(IBIFN) Q - . I $G(IBSCNNZ)="?MRA",$$MCRONBIL^IBEFUNC(IBIFN),$T(SCR^IBCEMVU)'="" S IBQ=1 D SCR^IBCEMVU(IBIFN) Q - . I $G(IBSCNNZ)="?ID" S IBQ=1 D DISPID^IBCEF74(IBIFN) Q - . I $G(IBSCNNZ)="?RX" S IBQ=1 D DISPRX^IBCSCH1(IBIFN) Q - . Q - ; - S IBH("HELP")="" D ^IBCSCU,H^IBCSCU K IBH("HELP") W !,"Enter '^' to stop the display ",$S(IBV:"",1:"and edit "),"of data," - W:'$D(IBPAR) " '^N' to jump to screen #N (see",!,"listing below), to continue on to the next available screen" I IBV W "." G M - W " or enter",!,"the field group number(s) you wish to edit using commas and dashes as",!,"delimiters. Those groups enclosed in brackets ""[]"" are editable while those" - W !,"enclosed in arrows ""<>"" are not." - G:$D(IBPAR) M1 -M W " Special help screens:" - W !,?5,"Enter '?SC' to view SC Status and Rated Disabilities." - W !,?5,"Enter '?INS' to view the patients insurance policies." - W !,?5,"Enter '?INX' to view the patients insurance policies with comments." - W !,?5,"Enter '?PRV' to view provider specific information." - W !,?5,"Enter '?PRC' to view all procedures on the bill and related data." - W !,?5,"Enter '?CHG' to view all items on the bill with potential charges." - W !,?5,"Enter '?CPT' to view all charges for selected CPT codes and bill type." - I $$FT^IBCEF(IBIFN)=2 W !,?5,"Enter '?1500' to view how block 24 will print on a CMS-1500." - W !,?5,"Enter '?INC' to execute the edits & view the bill inconsistencies." - I $$CK0^IBCIUT1() W !?5,"Enter '?CLA' to view the ClaimsManager options." - I $$MCRONBIL^IBEFUNC(IBIFN) W !?5,"Enter '?MRA' to view Medicare Remittance Advice EOB's on file." - W !,?5,"Enter '?ID' to view all IDs to be electronically transmitted on this claim." - W !,?5,"Enter '?RX' to view all prescriptions on this claim." - ; - I +IBSR'=9 S Z="DATA GROUPS ON SCREEN "_+IBSR W ! X IBWW D @(IBSR1_IBSR) D W - D S W ! F I=$Y:1:20 W ! - S Z="PRESS KEY" X IBWW W " to RETURN to SCREEN ",+IBSR R X:DTIME Q -M1 N I,Z S Z="DATA GROUPS ON PARAMETER SCREEN" W !! X IBWW D @(IBSR1_IBSR) D W W ! F I=$Y:1:20 W ! - S Z="PRESS KEY" X IBWW W " to RETURN to PARAMETER SCREEN" R X:DTIME Q -1 S X="DOB^Alias Name^Sex, Marital Status^Veteran Status, Eligibility^Address, Temporary Address^SC at Time of Care" Q -2 S X="Patient Employer Name, Address^Spouse Employer Name, Address" Q -3 S X="Payer Information^Provider Numbers^Mailing Address" Q -4 S X="Admission Information^Discharge Information^Diagnosis Code(s)^Coding Method, Inpt Proc Code(s)^Occurrence Code(s)^Condition Code(s)^Value Code(s)" Q -5 S X="Event Date^Outpatient Diagnosis^Outpatient Visits^Coding Method, Opt. Pro. Code(s)^Occurrence Code(s)^Condition Code(s)" Q -6 S X="Bill Type, Covered/Non-Covered Days^R.O.I., Assignment of Benefits^Statement Covers Period^Bedsection, Length of Stay^Revenue Code(s), Offset, Total^Rate Schedule(s)^Prior Payments/Claims" Q -7 S X="Bill Type, Covered/Non-Covered Days^R.O.I., Assignment of Benefits^Statement Covers Period^Outpatient Visits^Revenue Code(s), Offset, Total^Rate Schedule(s)^Prior Payments/Claims" Q -8 S X="Bill Remark^Form Locator 2^Form Locator 9^Form Locator 27^Form Locator 45^Form Locator 92^Form Locator 93^Tx Auth. Code" Q -9 S X="Locally defined fields" Q -28 S X="Bill Remark, ICN/DCN's, Tx Auth. Code, Admit Diagnosis/Source ^Providers^Force to Print^Provider ID Maintenance^Other Facility (VA/non)" Q -H8 S X="Period Unable to Work^Admit Dx, ICN/DCN, Tx/Prior Auth. Code^Providers^Non-VA Facility^Chiropractic Data^Form Locator 19^Force to Print^Provider ID Maintenance" Q -PAR S X="Fed Tax #, BC/BS #, MAS Svc Pointer^Bill Signer, Billing Supervisor^Security Parameters, Outpatient CPT parameters ^Remarks, Mailgroups^Agent Cashier Address/Phone" Q -S N C,I,Z,J W !! S Z="AVAILABLE SCREENS" X IBWW - S X="Demographic^Employment^Payer^Inpatient Event^Outpatient Event^Inpatient Billing - General^Outpatient Billing - General^Billing - Specific^Locally Defined" - S C=0 F I=1:1 S J=$P(X,"^",I) Q:J="" I '$E(IBVV,I) S C=C+1,Z="^"_I,IBW=(C#2) W:'(C#2) ?41 X IBWW S Z=$S(I?1N:" ",1:" ")_J_" Data" W Z - Q -W N I,J,Z - F I=1:1 S J=$P(X,"^",I) Q:J="" S Z=I,IBW=(I#2) W:'(I#2) ?42 X IBWW W " "_J - W:'(I-1)#2 ! Q - Q - ;IBCSCH - ; - ; -BL24(IBIFN,IBNOSHOW) ; display block 24 of CMS-1500 - ; IBNOSHOW = 1 for not to show error/warning text line - N X,Y,DIR,IBPG,IBLN,IBCOL,IBX,IBQ,IBLC,IBLIN,IBPFORM,IBD,IBC1,Z,Z0,IBXDATA,IBXSAVE,IBNXPG - K ^TMP("IBXSAVE",$J) - S IBQ=0,IBLC=9 Q:'$G(IBIFN) K ^TMP("IBXDISP",$J) - ; - S IBLIN=$$BOX24D^IBCEF11() - S IBPFORM=$S($P($G(^IBE(353,2,2)),U,8):$P(^(2),U,8),1:2) - S IBX=$$BILLN^IBCEFG0(0,"1^99",IBLIN,+IBIFN,IBPFORM) - ; - W @IOF,!,"Example of diagnoses, procedures and charges printing on the CMS-1500" - W !,"--------------------------------------------------------------------------------" - ; - ; box 19 - lines 36-37 - F Z=+IBLIN,IBLIN+1 I $D(^TMP("IBXDISP",$J,1,Z)) S Z0=$G(^TMP("IBXDISP",$J,1,Z,+$O(^TMP("IBXDISP",$J,1,Z,20),-1))) I Z0'="" S:Z=+IBLIN Z0="BOX 19 DATA: "_Z0 W !,Z0 - ; - ; box 21 - lines 39-41 - W !,"21. diagnosis" - I $D(^TMP("IBXDISP",$J,2,IBLIN+3)) W ?16,"(1st 4 only)" - W !,?5,"1. ",$G(^TMP("IBXDISP",$J,1,IBLIN+3,3)),?25,"3. ",$G(^TMP("IBXDISP",$J,1,IBLIN+3,30)) - W !,?5,"2. ",$G(^TMP("IBXDISP",$J,1,IBLIN+5,3)),?25,"4. ",$G(^TMP("IBXDISP",$J,1,IBLIN+5,30)) - ; - ; box 24 - lines 44-55 - D PG - S IBPG=0 F S IBPG=$O(^TMP("IBXDISP",$J,IBPG)) Q:'IBPG D Q:IBQ - . I '$D(^TMP("IBXDISP",$J,IBPG,IBLIN+9)) Q ; no line's on this page - . F IBLN=IBLIN+8:1:+$P(IBLIN,U,2) S IBCOL=$O(^TMP("IBXDISP",$J,IBPG,IBLN,0)) Q:'IBCOL&'$O(^TMP("IBXDISP",$J,IBPG,IBLN)) S IBLC=IBLC+1 I IBCOL D Q:IBQ - .. S IBCOL=0,IBC1=1 F S IBCOL=$O(^TMP("IBXDISP",$J,IBPG,IBLN,IBCOL)) Q:'IBCOL I $TR($G(^(IBCOL))," ")'="" D - ... W:IBC1 ! S IBC1=0 W ?(IBCOL-1),$G(^TMP("IBXDISP",$J,IBPG,IBLN,IBCOL)) - . S IBNXPG=$O(^TMP("IBXDISP",$J,IBPG)) ; next page - . I 'IBQ,IBNXPG,$D(^TMP("IBXDISP",$J,IBNXPG,IBLIN+9)) S IBLIN=$$BOX24D^IBCEF11(),IBQ=$$PAUSE^IBCSCH1(IBLC) Q:IBQ S IBLC=9 W @IOF D PG - . Q - ; - W !,"--------------------------------------------------------------------------------" - I 'IBPG,'IBQ S IBQ=$$PAUSE^IBCSCH1(IBLC) - K ^TMP("IBXDISP",$J),^TMP("IBXSAVE",$J) - Q - ; -PG ; Display box 24 letters at top of charge list - W !,"24. A B C D E F G H I J" - W !,"--------------------------------------------------------------------------------" - Q - ; -INSDSPL(IBIFN) ; Display patient's policies - N DIR,X,Y,IBX,DFN,IBDTIN,IBCOVEXT W @IOF - S IBX=$G(^DGCR(399,+$G(IBIFN),0)),DFN=$P(IBX,U,2),IBDTIN=$P(IBX,U,3),IBCOVEXT=1 - I +DFN D DISPDT^IBCNS W ! S DIR("A")="Press RETURN to continue",DIR(0)="E" D ^DIR K DIR - Q - ; -INSDSPLX(IBIFN) ; Display patient's policies extended (?INX) - N IBX,DFN,IBDATE S IBX=$G(^DGCR(399,+$G(IBIFN),0)),DFN=$P(IBX,U,2),IBDATE=$P(IBX,U,3) D DISP^IBCNS3(DFN,IBDATE,123) - Q - ; -DISPSC(IBIFN) ; display patients SC Status and Rated Disabilities - N IB0,DFN,IBSC,IBX,VAEL,VAERR - S IB0=$G(^DGCR(399,+$G(IBIFN),0)),DFN=$P(IB0,U,2),IBSC=$P(IB0,U,18) - W !,@IOF,!,"SC Status and Rated Disabilities for ",$P($G(^DPT(+$G(DFN),0)),U,1) - W !,"--------------------------------------------------------------------------------",! - I +$G(IBIFN) W !," SC At Time Of Care: ",$S(IBSC=1:"Yes",IBSC=0:"No",1:"") - I +$G(DFN) D ELIG^VADPT D DIS^DGRPDB - W !!,"--------------------------------------------------------------------------------" - S IBX=$$PAUSE^IBCSCH1(19) - Q - ; -DISPROPT(IBIFN) ; prompt for VA or Non-VA provider. - N X,Y,DIR - S DIR(0)="SAO^V:VA PROVIDER;N:NON-VA PROVIDER",DIR("A")="(V)A or (N)on-VA Provider: ",DIR("B")="V" - D ^DIR - I Y="V" D DISPPRV^IBCSCH2(IBIFN) Q - I Y="N" D DISPNVA^IBCSCH2(IBIFN) - Q - ; +IBCSCH ;ALB/MJB - MCCR HELP ROUTINE ;03 JUN 88 15:25 + ;;2.0;INTEGRATED BILLING;**52,80,106,124,138,51,148,137,161,245,232,287,348,349,374**;21-MAR-94;Build 16 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; + ;MAP TO DGCRSCH + ; + N I,C,IBSCNNZ,IBQ,IBPRNT,Z S IBSCNNZ=$$UP^XLFSTR($G(IBSCNN)),IBQ=0 + I '$D(IBPAR) D Q:IBQ + . I $F(".?1500.?HCFA.","."_$G(IBSCNNZ)_"."),$$FT^IBCEF(IBIFN)=2 S IBQ=1,IBPRNT=2 D BL24(IBIFN,0) Q + . I $G(IBSCNNZ)="?SC" S IBQ=1 D DISPSC(IBIFN) Q + . I $G(IBSCNNZ)="?INS" S IBQ=1 D INSDSPL(IBIFN) Q + . I $G(IBSCNNZ)="?INX" S IBQ=1 D INSDSPLX(IBIFN) Q + . I $G(IBSCNNZ)="?PRV" S IBQ=1 D DISPROPT(IBIFN) Q + . I $G(IBSCNNZ)="?CHG" S IBQ=1 D DISPCHG^IBCRBH1(IBIFN) Q + . I $G(IBSCNNZ)="?PRC" S IBQ=1 D DISPPRC^IBCSCH1(IBIFN) Q + . I $G(IBSCNNZ)="?CPT" S IBQ=1 D BCPTCHG^IBCRBH2(IBIFN) Q + . I $G(IBSCNNZ)="?INC" S IBQ=1 D EDIT^IBCBB(IBIFN) Q + . I $G(IBSCNNZ)="?CLA",$$CK0^IBCIUT1() S IBQ=1 D CLA^IBCISC(IBIFN) Q + . I $G(IBSCNNZ)="?MRA",$$MCRONBIL^IBEFUNC(IBIFN),$T(SCR^IBCEMVU)'="" S IBQ=1 D SCR^IBCEMVU(IBIFN) Q + . I $G(IBSCNNZ)="?ID" S IBQ=1 D DISPID^IBCEF74(IBIFN) Q + . Q + ; + S IBH("HELP")="" D ^IBCSCU,H^IBCSCU K IBH("HELP") W !,"Enter '^' to stop the display ",$S(IBV:"",1:"and edit "),"of data," + W:'$D(IBPAR) " '^N' to jump to screen #N (see",!,"listing below), to continue on to the next available screen" I IBV W "." G M + W " or enter",!,"the field group number(s) you wish to edit using commas and dashes as",!,"delimiters. Those groups enclosed in brackets ""[]"" are editable while those" + W !,"enclosed in arrows ""<>"" are not." + G:$D(IBPAR) M1 +M W " Special help screens:" + W !,?5,"Enter '?SC' to view SC Status and Rated Disabilities." + W !,?5,"Enter '?INS' to view the patients insurance policies." + W !,?5,"Enter '?INX' to view the patients insurance policies with comments." + W !,?5,"Enter '?PRV' to view provider specific information." + W !,?5,"Enter '?PRC' to view all procedures on the bill and related data." + W !,?5,"Enter '?CHG' to view all items on the bill with potential charges." + W !,?5,"Enter '?CPT' to view all charges for selected CPT codes and bill type." + I $$FT^IBCEF(IBIFN)=2 W !,?5,"Enter '?1500' to view how block 24 will print on a CMS-1500." + W !,?5,"Enter '?INC' to execute the edits & view the bill inconsistencies." + I $$CK0^IBCIUT1() W !?5,"Enter '?CLA' to view the ClaimsManager options." + I $$MCRONBIL^IBEFUNC(IBIFN) W !?5,"Enter '?MRA' to view Medicare Remittance Advice EOB's on file." + W !,?5,"Enter '?ID' to view all IDs to be electronically transmitted on this claim." + ; + I +IBSR'=9 S Z="DATA GROUPS ON SCREEN "_+IBSR W ! X IBWW D @(IBSR1_IBSR) D W + D S W ! F I=$Y:1:20 W ! + S Z="PRESS KEY" X IBWW W " to RETURN to SCREEN ",+IBSR R X:DTIME Q +M1 N I,Z S Z="DATA GROUPS ON PARAMETER SCREEN" W !! X IBWW D @(IBSR1_IBSR) D W W ! F I=$Y:1:20 W ! + S Z="PRESS KEY" X IBWW W " to RETURN to PARAMETER SCREEN" R X:DTIME Q +1 S X="DOB^Alias Name^Sex, Marital Status^Veteran Status, Eligibility^Address, Temporary Address^SC at Time of Care" Q +2 S X="Patient Employer Name, Address^Spouse Employer Name, Address" Q +3 S X="Payer Information^Provider Numbers^Mailing Address" Q +4 S X="Admission Information^Discharge Information^Diagnosis Code(s)^Coding Method, Inpt Proc Code(s)^Occurrence Code(s)^Condition Code(s)^Value Code(s)" Q +5 S X="Event Date^Outpatient Diagnosis^Outpatient Visits^Coding Method, Opt. Pro. Code(s)^Occurrence Code(s)^Condition Code(s)" Q +6 S X="Bill Type, Covered/Non-Covered Days^R.O.I., Assignment of Benefits^Statement Covers Period^Bedsection, Length of Stay^Revenue Code(s), Offset, Total^Rate Schedule(s)^Prior Payments/Claims" Q +7 S X="Bill Type, Covered/Non-Covered Days^R.O.I., Assignment of Benefits^Statement Covers Period^Outpatient Visits^Revenue Code(s), Offset, Total^Rate Schedule(s)^Prior Payments/Claims" Q +8 S X="Bill Remark^Form Locator 2^Form Locator 9^Form Locator 27^Form Locator 45^Form Locator 92^Form Locator 93^Tx Auth. Code" Q +9 S X="Locally defined fields" Q +28 S X="Bill Remark, ICN/DCN's, Tx Auth. Code, Admit Diagnosis/Source ^Providers^Force to Print^Provider ID Maintenance^Other Facility (VA/non)" Q +H8 S X="Period Unable to Work^Admit Dx, ICN/DCN, Tx/Prior Auth. Code^Providers^Non-VA Facility^Form Locator 19^Force to Print" Q +PAR S X="Fed Tax #, BC/BS #, MAS Svc Pointer^Bill Signer, Billing Supervisor^Security Parameters, Outpatient CPT parameters ^Remarks, Mailgroups^Agent Cashier Address/Phone" Q +S N C,I,Z,J W !! S Z="AVAILABLE SCREENS" X IBWW + S X="Demographic^Employment^Payer^Inpatient Event^Outpatient Event^Inpatient Billing - General^Outpatient Billing - General^Billing - Specific^Locally Defined" + S C=0 F I=1:1 S J=$P(X,"^",I) Q:J="" I '$E(IBVV,I) S C=C+1,Z="^"_I,IBW=(C#2) W:'(C#2) ?41 X IBWW S Z=$S(I?1N:" ",1:" ")_J_" Data" W Z + Q +W N I,J,Z + F I=1:1 S J=$P(X,"^",I) Q:J="" S Z=I,IBW=(I#2) W:'(I#2) ?42 X IBWW W " "_J + W:'(I-1)#2 ! Q + Q + ;IBCSCH + ; + ; +BL24(IBIFN,IBNOSHOW) ; display block 24 of CMS-1500 + ; IBNOSHOW = 1 for not to show error/warning text line + N X,Y,DIR,IBPG,IBLN,IBCOL,IBX,IBQ,IBLC,IBLIN,IBPFORM,IBD,IBC1,Z,Z0,IBXDATA,IBXSAVE,IBNXPG + K ^TMP("IBXSAVE",$J) + S IBQ=0,IBLC=9 Q:'$G(IBIFN) K ^TMP("IBXDISP",$J) + ; + S IBLIN=$$BOX24D^IBCEF11() + S IBPFORM=$S($P($G(^IBE(353,2,2)),U,8):$P(^(2),U,8),1:2) + S IBX=$$BILLN^IBCEFG0(0,"1^99",IBLIN,+IBIFN,IBPFORM) + ; + W @IOF,!,"Example of diagnoses, procedures and charges printing on the CMS-1500" + W !,"--------------------------------------------------------------------------------" + ; + ; box 19 - lines 36-37 + F Z=+IBLIN,IBLIN+1 I $D(^TMP("IBXDISP",$J,1,Z)) S Z0=$G(^TMP("IBXDISP",$J,1,Z,+$O(^TMP("IBXDISP",$J,1,Z,20),-1))) I Z0'="" S:Z=+IBLIN Z0="BOX 19 DATA: "_Z0 W !,Z0 + ; + ; box 21 - lines 39-41 + W !,"21. diagnosis" + I $D(^TMP("IBXDISP",$J,2,IBLIN+3)) W ?16,"(1st 4 only)" + W !,?5,"1. ",$G(^TMP("IBXDISP",$J,1,IBLIN+3,3)),?25,"3. ",$G(^TMP("IBXDISP",$J,1,IBLIN+3,30)) + W !,?5,"2. ",$G(^TMP("IBXDISP",$J,1,IBLIN+5,3)),?25,"4. ",$G(^TMP("IBXDISP",$J,1,IBLIN+5,30)) + ; + ; box 24 - lines 44-55 + D PG + S IBPG=0 F S IBPG=$O(^TMP("IBXDISP",$J,IBPG)) Q:'IBPG D Q:IBQ + . I '$D(^TMP("IBXDISP",$J,IBPG,IBLIN+9)) Q ; no line's on this page + . F IBLN=IBLIN+8:1:+$P(IBLIN,U,2) S IBCOL=$O(^TMP("IBXDISP",$J,IBPG,IBLN,0)) Q:'IBCOL&'$O(^TMP("IBXDISP",$J,IBPG,IBLN)) S IBLC=IBLC+1 I IBCOL D Q:IBQ + .. S IBCOL=0,IBC1=1 F S IBCOL=$O(^TMP("IBXDISP",$J,IBPG,IBLN,IBCOL)) Q:'IBCOL I $TR($G(^(IBCOL))," ")'="" D + ... W:IBC1 ! S IBC1=0 W ?(IBCOL-1),$G(^TMP("IBXDISP",$J,IBPG,IBLN,IBCOL)) + . S IBNXPG=$O(^TMP("IBXDISP",$J,IBPG)) ; next page + . I 'IBQ,IBNXPG,$D(^TMP("IBXDISP",$J,IBNXPG,IBLIN+9)) S IBLIN=$$BOX24D^IBCEF11(),IBQ=$$PAUSE^IBCSCH1(IBLC) Q:IBQ S IBLC=9 W @IOF D PG + . Q + ; + W !,"--------------------------------------------------------------------------------" + I 'IBPG,'IBQ S IBQ=$$PAUSE^IBCSCH1(IBLC) + K ^TMP("IBXDISP",$J),^TMP("IBXSAVE",$J) + Q + ; +PG ; Display box 24 letters at top of charge list + W !,"24. A B C D E F G H I J" + W !,"--------------------------------------------------------------------------------" + Q + ; +INSDSPL(IBIFN) ; Display patient's policies + N DIR,X,Y,IBX,DFN,IBDTIN,IBCOVEXT W @IOF + S IBX=$G(^DGCR(399,+$G(IBIFN),0)),DFN=$P(IBX,U,2),IBDTIN=$P(IBX,U,3),IBCOVEXT=1 + I +DFN D DISPDT^IBCNS W ! S DIR("A")="Press RETURN to continue",DIR(0)="E" D ^DIR K DIR + Q + ; +INSDSPLX(IBIFN) ; Display patient's policies extended (?INX) + N IBX,DFN,IBDATE S IBX=$G(^DGCR(399,+$G(IBIFN),0)),DFN=$P(IBX,U,2),IBDATE=$P(IBX,U,3) D DISP^IBCNS3(DFN,IBDATE,123) + Q + ; +DISPSC(IBIFN) ; display patients SC Status and Rated Disabilities + N IB0,DFN,IBSC,IBX,VAEL,VAERR + S IB0=$G(^DGCR(399,+$G(IBIFN),0)),DFN=$P(IB0,U,2),IBSC=$P(IB0,U,18) + W !,@IOF,!,"SC Status and Rated Disabilities for ",$P($G(^DPT(+$G(DFN),0)),U,1) + W !,"--------------------------------------------------------------------------------",! + I +$G(IBIFN) W !," SC At Time Of Care: ",$S(IBSC=1:"Yes",IBSC=0:"No",1:"") + I +$G(DFN) D ELIG^VADPT D DIS^DGRPDB + W !!,"--------------------------------------------------------------------------------" + S IBX=$$PAUSE^IBCSCH1(19) + Q + ; +DISPROPT(IBIFN) ; prompt for VA or Non-VA provider. + N X,Y,DIR + S DIR(0)="SAO^V:VA PROVIDER;N:NON-VA PROVIDER",DIR("A")="(V)A or (N)on-VA Provider: ",DIR("B")="V" + D ^DIR + I Y="V" D DISPPRV^IBCSCH2(IBIFN) Q + I Y="N" D DISPNVA^IBCSCH2(IBIFN) + Q + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSCH1.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSCH1.m index abfdbdcb..95e98fe2 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSCH1.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSCH1.m @@ -1,103 +1,70 @@ -IBCSCH1 ;ALB/MRL - BILLING HELPS (CONTINUED) ; 01 JUN 88 12:00 - ;;2.0;INTEGRATED BILLING;**106,125,51,245,266,395**;21-MAR-94;Build 3 - ;;Per VHA Directive 10-93-142, this routine should not be modified. - ; - ;MAP TO DGCRSCH1 - ; -1 W !!,"DO YOU WISH TO ADD/EDIT INSURANCE COMPANY DATA FOR THIS PATIENT" S %=2 D YN^DICN S IBADI=$S(%=1!(%=-1):%,1:0) - I '% W !!?4,"YES - And I'll prompt you so that you may add insurance data to the PATIENT",!?9,"file for this patient.",!?4,"NO - To bypass this editing of the PATIENT file." G 1 - Q - ; -2 W !!,"If you updated insurance information for any policy which is already specified",!,"as either a PRIMARY, SECONDARY or TERIARY for this billing episode, you will" - W !,"need to press the key through the following prompts in order to insure",!,"that these new values are properly stored. If you fail to do so, i.e.," - W !,"enter an up-arrow, the new values will not be stored as part of this billing",!,"record." Q -3 I '$D(IBIFN),$D(DA) S IBIFN=DA - W !,"If a procedure is linked as a prescription to a rev code, it cannot be deleted",! - W:$P(^DGCR(399,IBIFN,0),"^",5)<3 !!?4," - Enter the alphanumeric designation of your choice from",!?7,"the display (e.g. 'A1') to input one of the codes shown",!?7,"above into this billing record." - I $P(^IBE(350.9,1,1),U,15)'=1 G 4 - S DGCODMET=$P(^DGCR(399,IBIFN,0),"^",9),DGCODMET=$S(DGCODMET=9:"ICD",DGCODMET="":"",1:"CPT") - W !!?4," - Enter the name or code number of an ",$S($D(IBPY):"ICD DIAGNOSIS ",1:DGCODMET_" PROCEDURE "),"CODE",!?7,"not displayed above to input a ",$S($D(IBPY):"DIAGNOSIS",1:"PROCEDURE")," code" - I $P(^DGCR(399,IBIFN,0),"^",5)>2 W "." G 4 - W " not found",!?7,"in the PTF record into this billing record, or '??' for ",!?7,"a list of all ",$S($D(IBPY):"ICD DIAGNOSIS ",1:DGCODMET_" PROCEDURE "),"CODES." -4 W !!?4," - Enter to accept the default ",$S($D(IBPY):"DIAGNOSIS ",1:"PROCEDURE "),"code, or",!?7,"'^' to abort.",!! - K DGCODMET - Q - ; -DISPPRC(IBIFN) ; display procedures - N IBHDR,IBHDR1,IBD,IBN,IBI,IBX,IBQ,IBLN,IBPR,IBPRD,IBDT,IBDV,IBCL,IBPV,IBLC,PRCARR,IBMOD,IBSUS,IBDATE - S IBQ=0 - ; - I '$O(^DGCR(399,+$G(IBIFN),"CP",0)) W !!?5,"No Codes Entered!",! D PAUSE^VALM1 Q - ; - S IBDATE=$$BDATE^IBACSV(IBIFN) - S IBHDR="W @IOF,!,""Procedures Assigned to this Bill"",!,""Code"",?10,""Procedure"",?35,""PO"",?38,""Date"",?48,""Div"",?55,""Clinic"",?68,""Provider"" X IBHDR1" - S IBHDR1="W !,""--------------------------------------------------------------------------------"" S IBLC=2" - ; - X IBHDR D PRCDT^IBCU71(+IBIFN,.PRCARR) - S IBD="" F S IBD=$O(PRCARR(IBD)) Q:IBD="" D Q:IBQ - . S IBN="" F S IBN=$O(PRCARR(IBD,IBN)) Q:IBN="" D Q:IBQ - .. S IBI=0 F S IBI=$O(PRCARR(IBD,IBN,IBI)) Q:'IBI D I IBLC>19 S IBQ=$$PAUSE(IBLC) Q:IBQ X IBHDR - ... S IBLN=$G(PRCARR(IBD,IBN,IBI)),(IBPR,IBPRD,IBDT,IBDV,IBCL,IBPV,IBSUS)="",IBLC=IBLC+1 - ... S IBX=$$PRCNM($P(IBLN,U,1),IBD),IBPR=$P(IBX,U,1),IBPRD=$P(IBX,U,2) - ... S IBDT=$P(IBLN,U,2),IBDT=$E(IBDT,4,5)_"/"_$E(IBDT,6,7)_"/"_$E(IBDT,2,3) - ... I +$P(IBLN,U,6) S IBDV=$P($G(^DG(40.8,+$P(IBLN,U,6),0)),U,2) - ... I +$P(IBLN,U,7) S IBCL=$P($G(^SC(+$P(IBLN,U,7),0)),U,1) - ... I +$P(IBLN,U,18) S IBPV=$P($G(^VA(200,+$P(IBLN,U,18),0)),U,1) - ... I +$P(IBLN,U,16) S IBSUS=$P(IBLN,U,16)_"mn" - ... I +$P(IBLN,U,21) S IBSUS=$P(IBLN,U,21)_"ml" - ... I +$P(IBLN,U,22) S IBSUS=$P(IBLN,U,22)_"hr" - ... ; - ... W !,$E(IBPR,1,6),?7,$E(IBPRD,1,20),?29,IBSUS,?35,$P(IBLN,U,4),?38,IBDT,?48,IBDV,?55,$E(IBCL,1,11),?68,$E(IBPV,1,12) - ... S IBX=$$MODLST^IBEFUNC2($$GETMOD^IBEFUNC(IBIFN,IBI),1,.IBX,IBD) - ... I IBX'="" F IBMOD=1:1:$L(IBX,",") W !,?10,$P(IBX,",",IBMOD),?15,$P($G(IBX(1)),",",IBMOD) S IBLC=IBLC+1 - I 'IBI,'IBQ S IBQ=$$PAUSE(IBLC) - Q - ; -PRCNM(PRC,EFDT) ; return procedure name, input first piece of CP node - - ; (in variable pointer format) - ; output: code ^ name - N IBNM - S IBNM=$$PRCD^IBCEF1($G(PRC),1,$G(EFDT)) - I $TR(IBNM,U)="" D - . S IBNM="NO ENTRY FOUND^" - E D - . S IBNM=$P(IBNM,U,2,3) - Q IBNM - ; -PAUSE(CNT) ; - N IBI F IBI=CNT:1:20 W ! - N DIR,DUOUT,DTOUT,DIRUT,IBX,X,Y S IBX=0,DIR(0)="E" D ^DIR K DIR I $D(DIRUT) S IBX=1 - Q IBX - ; -DISPRX(IBIFN) ; display prescriptions - N IBHDR,IBHDR1,IBX,IBZ,IBRXL,IBNPI,IBRX,IBQ,IBORG - S IBQ=0 - ; - I '$O(^IBA(362.4,"AIFN"_IBIFN,0)) W !!?5,"No Prescriptions Entered!",! D PAUSE^VALM1 Q - ; - ; get NPIs - S IBX=$$RXSITE^IBCEF73A(IBIFN,.IBRXL) - ; - S IBHDR="W @IOF,!,""Prescriptions Assigned to this Bill"" X IBHDR1" - S IBHDR1="W !,""--------------------------------------------------------------------------------"" " - ; - X IBHDR - S IBRX=0 F S IBRX=$O(^IBA(362.4,"AIFN"_IBIFN,IBRX)) Q:'IBRX!(IBQ) S IBX=0 F S IBX=$O(^IBA(362.4,"AIFN"_IBIFN,IBRX,IBX)) Q:'IBX!(IBQ) D - . S IBZ=$G(^IBA(362.4,IBX,0)) - . W !?5,"RX #: ",$P(IBZ,"^") - . W ?50,"DATE: ",$$FMTE^XLFDT($P(IBZ,"^",3)) - . W !?5,"DRUG: ",$$EXTERNAL^DILFD(362.4,.04,"",$P(IBZ,"^",4)) - . W ?50,"NDC: ",$P(IBZ,"^",8) - . W !?5,"DAYS SUPPLY: ",$P(IBZ,"^",6) - . W ?50,"QUANTITY: ",$P(IBZ,"^",7) - . S IBORG=$G(IBRXL(+$P(IBZ,"^",5),+$P(IBZ,"^",3))) - . ; ia #4532 - . S IBNPI=$S(IBORG:$P($$NPI^XUSNPI("Organization_ID",IBORG),U),1:"") - . W !?5,"NPI INSTITUTION: ",$S(IBORG:$$EXTERNAL^DILFD(350.9,.02,"",IBORG),1:"") - . W ?50,"RX NPI: ",$S(IBNPI>0:IBNPI,1:"") - . W !?5,"PROVIDER: ",$S($P(IBZ,"^",5):$$RXAPI1^IBNCPUT1($P(IBZ,"^",5),4),1:""),! - . I $Y+7>IOSL S IBQ=$$PAUSE(0) - D PAUSE^VALM1 - ; - Q - ; +IBCSCH1 ;ALB/MRL - BILLING HELPS (CONTINUED) ; 01 JUN 88 12:00 + ;;2.0;INTEGRATED BILLING;**106,125,51,245,266**;21-MAR-94 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; + ;MAP TO DGCRSCH1 + ; +1 W !!,"DO YOU WISH TO ADD/EDIT INSURANCE COMPANY DATA FOR THIS PATIENT" S %=2 D YN^DICN S IBADI=$S(%=1!(%=-1):%,1:0) + I '% W !!?4,"YES - And I'll prompt you so that you may add insurance data to the PATIENT",!?9,"file for this patient.",!?4,"NO - To bypass this editing of the PATIENT file." G 1 + Q + ; +2 W !!,"If you updated insurance information for any policy which is already specified",!,"as either a PRIMARY, SECONDARY or TERIARY for this billing episode, you will" + W !,"need to press the key through the following prompts in order to insure",!,"that these new values are properly stored. If you fail to do so, i.e.," + W !,"enter an up-arrow, the new values will not be stored as part of this billing",!,"record." Q +3 I '$D(IBIFN),$D(DA) S IBIFN=DA + W !,"If a procedure is linked as a prescription to a rev code, it cannot be deleted",! + W:$P(^DGCR(399,IBIFN,0),"^",5)<3 !!?4," - Enter the alphanumeric designation of your choice from",!?7,"the display (e.g. 'A1') to input one of the codes shown",!?7,"above into this billing record." + I $P(^IBE(350.9,1,1),U,15)'=1 G 4 + S DGCODMET=$P(^DGCR(399,IBIFN,0),"^",9),DGCODMET=$S(DGCODMET=9:"ICD",DGCODMET="":"",1:"CPT") + W !!?4," - Enter the name or code number of an ",$S($D(IBPY):"ICD DIAGNOSIS ",1:DGCODMET_" PROCEDURE "),"CODE",!?7,"not displayed above to input a ",$S($D(IBPY):"DIAGNOSIS",1:"PROCEDURE")," code" + I $P(^DGCR(399,IBIFN,0),"^",5)>2 W "." G 4 + W " not found",!?7,"in the PTF record into this billing record, or '??' for ",!?7,"a list of all ",$S($D(IBPY):"ICD DIAGNOSIS ",1:DGCODMET_" PROCEDURE "),"CODES." +4 W !!?4," - Enter to accept the default ",$S($D(IBPY):"DIAGNOSIS ",1:"PROCEDURE "),"code, or",!?7,"'^' to abort.",!! + K DGCODMET + Q + ; +DISPPRC(IBIFN) ; display procedures + N IBHDR,IBHDR1,IBD,IBN,IBI,IBX,IBQ,IBLN,IBPR,IBPRD,IBDT,IBDV,IBCL,IBPV,IBLC,PRCARR,IBMOD,IBSUS,IBDATE + S IBQ=0 + ; + I '$O(^DGCR(399,+$G(IBIFN),"CP",0)) W !!?5,"No Codes Entered!",! D PAUSE^VALM1 Q + ; + S IBDATE=$$BDATE^IBACSV(IBIFN) + S IBHDR="W @IOF,!,""Procedures Assigned to this Bill"",!,""Code"",?10,""Procedure"",?35,""PO"",?38,""Date"",?48,""Div"",?55,""Clinic"",?68,""Provider"" X IBHDR1" + S IBHDR1="W !,""--------------------------------------------------------------------------------"" S IBLC=2" + ; + X IBHDR D PRCDT^IBCU71(+IBIFN,.PRCARR) + S IBD="" F S IBD=$O(PRCARR(IBD)) Q:IBD="" D Q:IBQ + . S IBN="" F S IBN=$O(PRCARR(IBD,IBN)) Q:IBN="" D Q:IBQ + .. S IBI=0 F S IBI=$O(PRCARR(IBD,IBN,IBI)) Q:'IBI D I IBLC>19 S IBQ=$$PAUSE(IBLC) Q:IBQ X IBHDR + ... S IBLN=$G(PRCARR(IBD,IBN,IBI)),(IBPR,IBPRD,IBDT,IBDV,IBCL,IBPV,IBSUS)="",IBLC=IBLC+1 + ... S IBX=$$PRCNM($P(IBLN,U,1),IBD),IBPR=$P(IBX,U,1),IBPRD=$P(IBX,U,2) + ... S IBDT=$P(IBLN,U,2),IBDT=$E(IBDT,4,5)_"/"_$E(IBDT,6,7)_"/"_$E(IBDT,2,3) + ... I +$P(IBLN,U,6) S IBDV=$P($G(^DG(40.8,+$P(IBLN,U,6),0)),U,2) + ... I +$P(IBLN,U,7) S IBCL=$P($G(^SC(+$P(IBLN,U,7),0)),U,1) + ... I +$P(IBLN,U,18) S IBPV=$P($G(^VA(200,+$P(IBLN,U,18),0)),U,1) + ... I +$P(IBLN,U,16) S IBSUS=$P(IBLN,U,16)_"mn" + ... I +$P(IBLN,U,21) S IBSUS=$P(IBLN,U,21)_"ml" + ... I +$P(IBLN,U,22) S IBSUS=$P(IBLN,U,22)_"hr" + ... ; + ... W !,$E(IBPR,1,6),?7,$E(IBPRD,1,20),?29,IBSUS,?35,$P(IBLN,U,4),?38,IBDT,?48,IBDV,?55,$E(IBCL,1,11),?68,$E(IBPV,1,12) + ... S IBX=$$MODLST^IBEFUNC2($$GETMOD^IBEFUNC(IBIFN,IBI),1,.IBX,IBD) + ... I IBX'="" F IBMOD=1:1:$L(IBX,",") W !,?10,$P(IBX,",",IBMOD),?15,$P($G(IBX(1)),",",IBMOD) S IBLC=IBLC+1 + I 'IBI,'IBQ S IBQ=$$PAUSE(IBLC) + Q + ; +PRCNM(PRC,EFDT) ; return procedure name, input first piece of CP node - + ; (in variable pointer format) + ; output: code ^ name + N IBNM + S IBNM=$$PRCD^IBCEF1($G(PRC),1,$G(EFDT)) + I $TR(IBNM,U)="" D + . S IBNM="NO ENTRY FOUND^" + E D + . S IBNM=$P(IBNM,U,2,3) + Q IBNM + ; +PAUSE(CNT) ; + N IBI F IBI=CNT:1:20 W ! + N DIR,DUOUT,DTOUT,DIRUT,IBX,X,Y S IBX=0,DIR(0)="E" D ^DIR K DIR I $D(DIRUT) S IBX=1 + Q IBX diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCU4.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCU4.m index 09d4c7ad..3ef8fcb4 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCU4.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCU4.m @@ -1,119 +1,112 @@ -IBCU4 ;ALB/AAS - BILLING UTILITY ROUTINE (CONTINUED) ;12-FEB-90 - ;;2.0;INTEGRATED BILLING;**109,122,137,245,349,371**;21-MAR-94;Build 57 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ;MAP TO DGCRU4 - ; -DDAT ;Input transform for Statement Covers From field - I '$D(DA) G TO - S IB00=+$P(^DGCR(399,+DA,0),"^",3) I +X<$P(IB00,".",1) W !?4,"Cannot precede the 'EVENT DATE'!",*7 K X G DDAT4 - I +X>(DT_".2359") W !?4,"Cannot bill for future treatment!",*7 K X G DDAT4 - D PROCDT - I DGPRDTB,X>DGPRDTB K X W !?4,"Can't be greater than date of specified Procedures!",*7 G DDAT4 - G DDAT4 -DDAT1 ;Input transform for Statement covers to - I '$D(DA) G FROM - S IB00=$S($D(^DGCR(399,+DA,"U")):$P(^("U"),"^",1),1:"") I 'IB00 W !?4,"'Start Date' must be specified first!",*7 K X G DDAT4 - I +X>DT W !?4,"Cannot bill for future treatment!",*7 K X G DDAT4 - I +X$P(IB00,"^",2) W !?4,*7,"Can't enter a visit date later than 'End Date'..." K X G DDAT4 - ;I $P(^DGCR(399,IBIFN,0),"^",19)'=2,$D(^DGCR(399,"ASC2",IBIFN)),$O(^DGCR(399,IBIFN,"OP",0)) W !?4,*7,"Only 1 visit date allowed on bills with Amb. Surg. Codes!" K X G DDAT4 - ;D APPT^IBCU3,DUPCHK^IBCU3 - G DDAT4 - ; -DDAT3 ; - x-ref call for to and from dates, REPLACED BY TRIGGERS ON .08, 151, 152 ON 10/18/93 - ;if inpatient bill return DGNEWLOS to cause recalc of los in IBSC6 - G DDAT4:'$D(X) - I $D(^DGCR(399,DA,0)),$P(^(0),"^",5)<3 S DGNEWLOS=1 - S IB00=$S($D(^DGCR(399,+DA,"U")):^("U"),1:"") I IB00']"" K X G DDAT4 - S IB02=$S(+$E(IB00,4,5)<10:$E(IB00,2,3),1:$E(IB00,2,3)+1),IB01=$E(IB00,1)_IB02_"0930",$P(^DGCR(399,DA,"U1"),"^",9)=IB02 ;,$P(^DGCR(399,DA,"U1"),"^",11)=$S($P(IB00,"^",2)>IB01:IB02+1,1:"") - ;I $P(^DGCR(399,DA,"U1"),"^",11)="" S $P(^("U1"),"^",12)="" - ; -DDAT4 K IB00,IB01,IB02,IB03,DGX,DGNOAP,DGJ,DGPROC,DGPRDT,DGPRDTE,DGPRDTB Q - ; -OTDAT ; Input transform for Other Care Start Date (399,48,.02) - I ('$G(DA(1)))!('$G(X)) Q - N IBX S IBX=$G(^DGCR(399,DA(1),"U")) - I +X<+IBX W !,?4,"Can Not Precede Bill Start Date!",!,*7 K X Q - I +X>+$P(IBX,U,2) W !,?4,"Can not be after Bill End Date!",!,*7 K X Q - Q - ; -CHDAT ; Input transform for chiropractics-related dates (399/245,246,247) - ; Make sure that date entered is not after end date of the bill - Q:'$D(X) - N IBX,Y - S IBX=$P($G(^DGCR(399,+DA,"U")),U,2) - I IBX="" W !?4,*7,"No end date of the bill on file - can't enter chiropractics-related dates " K X Q - I X>+IBX S Y=IBX D DD^%DT W !,?4,*7,"This date can not be after the end date of the claim ("_Y_") " K X Q - Q - ; -TO ;151 pseudo input x-form - I +X_.9(DT_".2359") W !?4,"Cannot bill for future treatment!",*7 K X - Q -FROM ;152 pseudo input x-form - I '$D(IBIDS(151)) W !?4,"'Start Date' must be specified first!",*7 K X Q - I +XDGPRDT) S DGPRDTB=DGPRDT - . I DGPRDTE=0!(DGPRDTE(DT_".2359") W !?4,"Cannot bill for future treatment!",*7 K X G DDAT4 + D PROCDT + I DGPRDTB,X>DGPRDTB K X W !?4,"Can't be greater than date of specified Procedures!",*7 G DDAT4 + G DDAT4 +DDAT1 ;Input transform for Statement covers to + I '$D(DA) G FROM + S IB00=$S($D(^DGCR(399,+DA,"U")):$P(^("U"),"^",1),1:"") I 'IB00 W !?4,"'Start Date' must be specified first!",*7 K X G DDAT4 + I +X>DT W !?4,"Cannot bill for future treatment!",*7 K X G DDAT4 + I +X$P(IB00,"^",2) W !?4,*7,"Can't enter a visit date later than 'End Date'..." K X G DDAT4 + ;I $P(^DGCR(399,IBIFN,0),"^",19)'=2,$D(^DGCR(399,"ASC2",IBIFN)),$O(^DGCR(399,IBIFN,"OP",0)) W !?4,*7,"Only 1 visit date allowed on bills with Amb. Surg. Codes!" K X G DDAT4 + ;D APPT^IBCU3,DUPCHK^IBCU3 + G DDAT4 + ; +DDAT3 ; - x-ref call for to and from dates, REPLACED BY TRIGGERS ON .08, 151, 152 ON 10/18/93 + ;if inpatient bill return DGNEWLOS to cause recalc of los in IBSC6 + G DDAT4:'$D(X) + I $D(^DGCR(399,DA,0)),$P(^(0),"^",5)<3 S DGNEWLOS=1 + S IB00=$S($D(^DGCR(399,+DA,"U")):^("U"),1:"") I IB00']"" K X G DDAT4 + S IB02=$S(+$E(IB00,4,5)<10:$E(IB00,2,3),1:$E(IB00,2,3)+1),IB01=$E(IB00,1)_IB02_"0930",$P(^DGCR(399,DA,"U1"),"^",9)=IB02 ;,$P(^DGCR(399,DA,"U1"),"^",11)=$S($P(IB00,"^",2)>IB01:IB02+1,1:"") + ;I $P(^DGCR(399,DA,"U1"),"^",11)="" S $P(^("U1"),"^",12)="" + ; +DDAT4 K IB00,IB01,IB02,IB03,DGX,DGNOAP,DGJ,DGPROC,DGPRDT,DGPRDTE,DGPRDTB Q + ; +OTDAT ; Input transform for Other Care Start Date (399,48,.02) + I ('$G(DA(1)))!('$G(X)) Q + N IBX S IBX=$G(^DGCR(399,DA(1),"U")) + I +X<+IBX W !,?4,"Can Not Precede Bill Start Date!",!,*7 K X Q + I +X>+$P(IBX,U,2) W !,?4,"Can not be after Bill End Date!",!,*7 K X Q + Q + ; + ; + ; +TO ;151 pseudo input x-form + I +X_.9(DT_".2359") W !?4,"Cannot bill for future treatment!",*7 K X + Q +FROM ;152 pseudo input x-form + I '$D(IBIDS(151)) W !?4,"'Start Date' must be specified first!",*7 K X Q + I +XDGPRDT) S DGPRDTB=DGPRDT + . I DGPRDTE=0!(DGPRDTE$P(DGNODUU,"^",2)) DTMESQ - W *7,!!?3,"Date must be within STATEMENT COVERS FROM and STATEMENT COVERS TO period." - S Y=$P(DGNODUU,"^") X ^DD("DD") - W !?3,"Enter a date between ",Y," and " S Y=$P(DGNODUU,"^",2) X ^DD("DD") W Y,! - K X,Y -DTMESQ K DGNODUU Q - ; -CODHLP ;Display Additional Procedure codes - N I,J,Y,IBMOD - I '$O(^DGCR(399,IBIFN,"CP",0)) W !!?5,"No Codes Entered!",! Q - F I=0:0 S I=$O(^DGCR(399,IBIFN,"CP",I)) Q:'I S Y=$G(^(I,0)) S Z=$$PRCNM^IBCSCH1($P(Y,"^",1),$P(Y,"^",2)) W !?5,$E($P(Z,"^",2),1,28),?35,"- ",$P(Z,"^") D - . N IBY - . S IBY=$P(Y,U,2) - . S IBMOD=$$GETMOD^IBEFUNC(IBIFN,I,1) - . I IBMOD'="" S IBMOD="/"_IBMOD W IBMOD - . W ?60,"Date: " S Y=IBY D DT^DIQ - ; - K Z Q - ; -DICV I $D(IBIFN),$D(^DGCR(399,IBIFN,0)),$P(^(0),U,9) S DIC("V")=$S($P(^(0),U,9)=9:"I +Y(0)=80.1",$P(^(0),U,9)=4!($P(^(0),U,9)=5):"I +Y(0)=81",1:"") - Q - ; -DEFDIV(IBIFN) ; Find default division for bill IBIFN - Q $P($G(^DG(40.8,+$P($G(^DGCR(399,IBIFN,0)),U,22),0)),U) - ; -ADDTNL(IBIFN,DA) ; - N DR,IBOK,X,Y,DIR - S IBOK=1 - S DR="19;50.09;50.08" D ^DIE - I $D(Y) S IBOK=0 G ADDTNLQ - S DIR("B")="NO",DIR("A")="EDIT CMS-1500 SPECIAL PROGRAM FIELDS and BOX 19?: ",DIR("A",1)=" ",DIR(0)="YA" - S DIR("?",1)="Respond YES only if you need to add/edit data for chiropractic visits," - S DIR("?")="EPSDT care, or if billing for HOSPICE and attending is not a hospice employee." - D ^DIR K DIR - I Y'=1 S IBOK=0 G ADDTNLQ - S DR="W !,"" <>"";50.07;W !!,"" <>"";50.03" - D ^DIE - W ! -ADDTNLQ Q IBOK - ; -XTRA1(Y) ; - K Y - Q - ; -SPCUNIT(IBIFN,DA) ; return fields for special units if applicable, in DR form - N IB0,IBCPT,IBDR,IBCT,IBFT,DFN S IBDR="" - S IB0=$G(^DGCR(399,+$G(IBIFN),0)),IBCT=$P(IB0,U,27),IBFT=$P(IB0,U,19),DFN=$P(IB0,U,2) - S IBCPT=$G(^DGCR(399,+$G(IBIFN),"CP",+$G(DA),0)) I IBCPT'["ICPT" G SPCUNTQ - I +$$ITMUNIT^IBCRU4(+IBCPT,5,IBCT) S IBDR="15;" D SROMIN^IBCU74(IBIFN,DA) G SPCUNTQ ; minutes - I +$$ITMUNIT^IBCRU4(+IBCPT,4,IBCT) S IBDR="21;" G SPCUNTQ ; miles - I +$$ITMUNIT^IBCRU4(+IBCPT,6,IBCT) S IBDR="22//"_$$OBSHOUR^IBCU74(DFN,$P(IBCPT,U,2))_";" G SPCUNTQ ; hours - I +IBFT=2,$P($G(^IBE(353.2,+$P(IBCPT,U,10),0)),U,2)="ANESTHESIA" S IBDR="15;" ; minutes -SPCUNTQ Q IBDR +IBCU7 ;ALB/AAS - INTERCEPT SCREEN INPUT OF PROCEDURE CODES ;29-OCT-91 + ;;2.0;INTEGRATED BILLING;**62,52,106,125,51,137,210,245,228,260,348**;21-MAR-94;Build 5 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; + ;MAP TO DGCRU7 + ; +CHKX ; -interception of input x from Additional Procedure input + G:X=" " CHKXQ + I $$INPAT^IBCEF(DA(1)),'$P($G(^IBE(350.9,1,1)),"^",15),X'?1A1N D G CHKXQ + . K X + . D EN^DDIOL("Site param does not allow entry of non-PTF procedures") ;Fileman error here will be: The previous error occurred when performing an action specified in a Pre-lookup transform (7.5 node). + G:'$D(^UTILITY($J,"IB")) CHKXQ + S M=($A($E(X,1))-64),S=+$E(X,2) Q:'$G(^UTILITY($J,"IB",M,S)) S X="`"_+^(S) + I $D(DGPROCDT),DGPROCDT'=$P($G(^UTILITY($J,"IB",M,1)),"^",2) S DGPROCDT=$P(^(1),"^",2) W !!,"Procedure Date: " S Y=DGPROCDT X ^DD("DD") W Y,! +CHKXQ Q + ; +CODMUL ;Date oriented entry of procedure +DELASK I $D(IBZ20),IBZ20,IBZ20'=$P(^DGCR(399,IBIFN,0),U,9) S %=2 W !,"SINCE THE PROCEDURE CODING METHOD HAS BEEN CHANGED, DO YOU WANT TO DELETE ALL",!,"PROCEDURE CODES IN THIS BILL" + I D YN^DICN Q:%=-1 D:%=1 DELADD I %Y?1."?" W !!,"If you answer 'Yes', all procedure codes will be DELETED from this bill.",! G DELASK + K %,%Y,DA,IBZ20,DIK ;W !,"Procedure Entry:" + ; +CODDT I $D(IBIFN),$D(^DGCR(399,IBIFN,0)),$P(^(0),U,9) S DIC("V")=$S($P(^(0),U,9)=9:"I +Y(0)=80.1",$P(^(0),U,9)=4!($P(^(0),U,9)=5):"I +Y(0)=81",1:"") + I $P($G(^DGCR(399,IBIFN,0)),"^",5)<3 S IBZTYPE=1 I $P($G(^UTILITY($J,"IB",1,1)),"^",2) S DGPROCDT=$P(^(1),"^",2) D ASKCOD + S X=$$PRCDIV^IBCU71(IBIFN) I +X W !!,$P(X,U,2),! + N Z,Z0 S Z=$G(^DGCR(399,IBIFN,"U")),Z0=$$FMTE^XLFDT($P(Z,U),"2D")_"-"_$$FMTE^XLFDT($P(Z,U,2),"2D") + W !,"Select PROCEDURE DATE"_$S($TR(Z0,"-")'="":" ("_Z0_")",1:"")_": " R X:DTIME G:'$T!("^"[X) CODQ D:X["?" CODHLP + S IBEX=0 D ; Get procedure date + . I X=" ",$D(DGPROCDT),DGPROCDT?7N S Y=DGPROCDT D D^DIQ W " (",Y,")" Q + . I X=" ",+$P($G(^DGCR(399,IBIFN,"OP",0)),"^",4) S (DGPROCDT,Y)=$O(^DGCR(399,IBIFN,"OP",0)) D D^DIQ W " (",Y,")" Q + . S %DT="EXP",%DT(0)=-DT D ^%DT K %DT I Y<1 S IBEX=1 Q + . I '$$OPV2^IBCU41(Y,IBIFN,1) S IBEX=1 Q + . S:'$G(IBZTYPE) X=$$OPV^IBCU41(Y,IBIFN) S DGPROCDT=Y + I 'IBEX D ASKCOD,ADDCPT^IBCU71:$D(DGCPT) + K IBEX + G CODDT + ; +ASKCOD N Z,Z0,DA,IBACT,IBQUIT + K DGCPT + S DGCPT=0,DGCPTUP=$P($G(^IBE(350.9,1,1)),"^",19),DGADDVST=0,IBFT=$P($G(^DGCR(399,IBIFN,0)),"^",19) + I '$D(^DGCR(399,IBIFN,"CP",0)) S ^DGCR(399,IBIFN,"CP",0)=U_$$GETSPEC^IBEFUNC(399,304) + ; + F S IBQUIT=0 D Q:IBQUIT + . S DIC("A")=" Select PROCEDURE: " + . S DIC="^DGCR(399,"_IBIFN_",""CP""," + . S DIC(0)="AEQMNL" + . S DIC("S")="I '$D(DIV(""S""))&($P(^(0),U,2)=DGPROCDT)" + . S DIC("DR")="1///^S X=DGPROCDT" + . S DA(1)=IBIFN,DLAYGO=399 + . W ! D ^DIC I Y<1 S IBQUIT=1 Q + . ; If we just added inactive code - it must be deleted. + . S IBACT=0 ; Active flag + . I Y["ICD0" S IBACT=$$ICD0ACT^IBACSV(+$P(Y,U,2),DGPROCDT) + . I Y["ICPT" S IBACT=$$CPTACT^IBACSV(+$P(Y,U,2),DGPROCDT) + . S DGCPTNEW=$P(Y,"^",3) ;Was the procedure just added? + . I DGCPTNEW,'IBACT D DELPROC Q + . I 'IBACT W !,*7,"Warning: Procedure code is inactive on this date",! + . I DGCPTNEW,$D(^UTILITY($J,"IB")),$$INPAT^IBCEF(IBIFN),Y["ICPT(" D DATA^IBCU74(Y) + . S DGADDVST=$S(DGCPTNEW:1,$D(DGADDVST):DGADDVST,1:0) + . N IBPRV,IBPRVO,IBPRVN + . S IBPRVO=$$MAINPRV^IBCEU(IBIFN),IBPRV=$P(IBPRVO,U,3),IBPRVN=(IBPRVO["IBA(355.93,"),IBPRV=$S(IBPRV="":"",'IBPRVN:$P(IBPRVO,U),1:"") + . I IBPRV="",'IBPRVN D + .. S IBPRV=0 F S IBPRV=$O(^DGCR(399,IBIFN,"CP",IBPRV)) S:'IBPRV IBPRV="" Q:'IBPRV S Z=$P($G(^(IBPRV,0)),U,18) I Z S IBPRV=$P($G(^VA(200,Z,0)),U) Q + . S DR="" I Y["ICPT" S DR="16"_$S(IBPRVN:";18///@",1:";18//"_IBPRV)_";6;5//"_$$DEFDIV(IBIFN)_";" + . S DR=".01;"_DR_$S(IBFT=2:"8;9;17//NO;",1:"")_3,DIE=DIC,(IBPROCP,DA)=+Y D ^DIE Q:'$D(DA)!($E($G(Y))=U) + . ; + . S DR=$$SPCUNIT(IBIFN,IBPROCP) I DR'="" D ^DIE ; miles/minutes/hours + . ; + . I IBFT=2 D + .. D DX^IBCU72(IBIFN,IBPROCP) + .. S X=$$ADDTNL(IBIFN,.DA) + . Q:$$INPAT^IBCEF(IBIFN) ;only outpatient bills + . ;add procedures to array for download to PCE: dgcpt(assoc clinic,cpt,'provider^first dx^modifiers',cnt)="" + . S DGPROC=$G(^DGCR(399,IBIFN,"CP",+DA,0)) + . S X=$P(DGPROC,U,18)_U_+$G(^IBA(362.3,+$P(DGPROC,U,11),0))_U_$P(DGPROC,U,15) + . I 'DGCPTNEW,$P(DGPROC,"^",7)="" S DGCPTNEW=2 + . I DGCPTUP,DGCPTNEW S DGCPT=DGCPT+1 I $P(DGPROC,"^",7) S DGCPT($P(DGPROC,"^",7),+DGPROC,X,DGCPT)="" + . ; add visit date to bill + . I DGADDVST S (X,DINUM)=DGPROCDT D VFILE1^IBCOPV1 K DINUM,X,DGNOADD,DGADDVST + ; Delete modifers with only a sequence #, no code + S Z=0 F S Z=$O(^DGCR(399,IBIFN,"CP",Z)) Q:'Z S Z0=0 F S Z0=$O(^DGCR(399,IBIFN,"CP",Z,"MOD",Z0)) Q:'Z0 I $P($G(^(Z0,0)),U,2)="" S DA(2)=IBIFN,DA(1)=Z,DA=Z0,DIK="^DGCR(399,"_DA(2)_",""CP"","_DA(1)_",""MOD""," D ^DIK + Q +CODQ K %DT,DGPROC,DIC,DIE,DR,DGPROCDT,IBPROCP,DLAYGO + K IBFT,DGNOADD,DGADDVST,DGCPT,DGCPTUP,IBZTYPE,DGCPTNEW + Q + ; +DELPROC ; Remove the selected procedure, because of inactive status (cancel selection) + W !!,*7,"The Procedure code is inactive on ",$$DAT1^IBOUTL(DGPROCDT),"." + W !,"Please select another Procedure." + S DA(1)=IBIFN,DA=+Y,DIK="^DGCR(399,"_IBIFN_",""CP""," + D ^DIK + Q + ; +DELADD N Z,Z0,DA,DIK,X,Y + S DA(1)=IBIFN + ;Delete references to proc on rev codes + S Z=0 F S Z=$O(^DGCR(399,IBIFN,"RC",Z)) Q:'Z S Z0=$G(^(Z,0)) I Z0'="",$P(Z0,U,15)!$S($P(Z0,U,10)=3:$P(Z0,U,11),1:0) S DIE="^DGCR(399,"_DA(1)_",""RC"",",DA=Z,DR=".11///@;.15///@"_$S($P(Z0,U,8):"",1:";.08////1") D ^DIE + S DIK="^DGCR(399,"_DA(1)_",""CP""," F DA=0:0 S DA=$O(^DGCR(399,DA(1),"CP",DA)) Q:'DA D ^DIK + S DGRVRCAL=1 + Q + ; +DTMES ;Message if procedure date not in date range + Q:'$D(IBIFN) Q:'$D(^DGCR(399,IBIFN,"U")) S DGNODUU=^("U") + G:X'<$P(DGNODUU,"^")&(X'>$P(DGNODUU,"^",2)) DTMESQ + W *7,!!?3,"Date must be within STATEMENT COVERS FROM and STATEMENT COVERS TO period." + S Y=$P(DGNODUU,"^") X ^DD("DD") + W !?3,"Enter a date between ",Y," and " S Y=$P(DGNODUU,"^",2) X ^DD("DD") W Y,! + K X,Y +DTMESQ K DGNODUU Q + ; +CODHLP ;Display Additional Procedure codes + N I,J,Y,IBMOD + I '$O(^DGCR(399,IBIFN,"CP",0)) W !!?5,"No Codes Entered!",! Q + F I=0:0 S I=$O(^DGCR(399,IBIFN,"CP",I)) Q:'I S Y=$G(^(I,0)) S Z=$$PRCNM^IBCSCH1($P(Y,"^",1),$P(Y,"^",2)) W !?5,$E($P(Z,"^",2),1,28),?35,"- ",$P(Z,"^") D + . N IBY + . S IBY=$P(Y,U,2) + . S IBMOD=$$GETMOD^IBEFUNC(IBIFN,I,1) + . I IBMOD'="" S IBMOD="/"_IBMOD W IBMOD + . W ?60,"Date: " S Y=IBY D DT^DIQ + ; + K Z Q + ; +DICV I $D(IBIFN),$D(^DGCR(399,IBIFN,0)),$P(^(0),U,9) S DIC("V")=$S($P(^(0),U,9)=9:"I +Y(0)=80.1",$P(^(0),U,9)=4!($P(^(0),U,9)=5):"I +Y(0)=81",1:"") + Q + ; +DEFDIV(IBIFN) ; Find default division for bill IBIFN + Q $P($G(^DG(40.8,+$P($G(^DGCR(399,IBIFN,0)),U,22),0)),U) + ; +ADDTNL(IBIFN,DA) ; + N DR,IBOK,X,Y,DIR + S IBOK=1 + S DR="19;50.09;50.08" D ^DIE + I $D(Y) S IBOK=0 G ADDTNLQ + S DIR("B")="NO",DIR("A")="EDIT CMS-1500 SPECIAL PROGRAM FIELDS and BOX 19?: ",DIR("A",1)=" ",DIR(0)="YA" + S DIR("?",1)="Respond YES only if you need to add/edit data for chiropractic visits," + S DIR("?")="EPSDT care, or if billing for HOSPICE and attending is not a hospice employee." + D ^DIR K DIR + I Y'=1 S IBOK=0 G ADDTNLQ + S DR="W !,"" <>"";50.07;W !!,"" <>"";50.03;W !!,"" <>"";50.04;50.02;50.05;50.06" + D ^DIE + W ! +ADDTNLQ Q IBOK + ; +XTRA1(Y) ; + K Y + Q + ; +SPCUNIT(IBIFN,DA) ; return fields for special units if applicable, in DR form + N IB0,IBCPT,IBDR,IBCT,IBFT,DFN S IBDR="" + S IB0=$G(^DGCR(399,+$G(IBIFN),0)),IBCT=$P(IB0,U,27),IBFT=$P(IB0,U,19),DFN=$P(IB0,U,2) + S IBCPT=$G(^DGCR(399,+$G(IBIFN),"CP",+$G(DA),0)) I IBCPT'["ICPT" G SPCUNTQ + I +$$ITMUNIT^IBCRU4(+IBCPT,5,IBCT) S IBDR="15;" D SROMIN^IBCU74(IBIFN,DA) G SPCUNTQ ; minutes + I +$$ITMUNIT^IBCRU4(+IBCPT,4,IBCT) S IBDR="21;" G SPCUNTQ ; miles + I +$$ITMUNIT^IBCRU4(+IBCPT,6,IBCT) S IBDR="22//"_$$OBSHOUR^IBCU74(DFN,$P(IBCPT,U,2))_";" G SPCUNTQ ; hours + I +IBFT=2,$P($G(^IBE(353.2,+$P(IBCPT,U,10),0)),U,2)="ANESTHESIA" S IBDR="15;" ; minutes +SPCUNTQ Q IBDR diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCVA0.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCVA0.m index 8f7497d7..cdc15856 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCVA0.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCVA0.m @@ -1,42 +1,43 @@ -IBCVA0 ;ALB/MJB - SET MCCR VARIABLES CONT. ;04 AUG 88 03:02 - ;;2.0;INTEGRATED BILLING;**52,361,371**;21-MAR-94;Build 57 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ;MAP TO DGCRVA0 - ; - Q -ALL I $D(DFN) S IBDPT=^DPT(DFN,0) D ADDR ;I IBADD1]"",$L(IBADD1)'>47 S DIE="^DGCR(399,",(DA,Y)=+IBIFN,DR="110///"_IBADD1 D ^DIE K DIE,DR,DA - ;I $D(^DPT(DFN,.11)) S IBST=$P(^(.11),U,5),IBST=$S(IBST'="":$P(^DIC(5,IBST,0),U,2),1:"") - S IBBNO=$P(IB(0),"^"),IBDT=$P(IB(0),"^",3) - D 2^VADPT - ;I $P(IB(0),U,5)<3 S Y=0 F I=1:1 S Y=$O(^DGPM("APTT1",DFN,Y)) Q:'Y S:$E(Y,1,7)=IBDT IBDA=Y - Q -1 ;Demographic variables set - D Q1^IBCVA -EN1 Q:'$D(DFN) S IBMAR=$S($P(IBDPT,U,5)'="":$P(IBDPT,U,5),1:"U") I IBMAR'="U" S IBMAR=$S(IBMAR=6:"S",IBMAR=2:"M",IBMAR=1:"D",IBMAR=4:"W",IBMAR=5:"X",1:"U") - I $D(^DPT(DFN,.121)) S IBTADD=^DPT(DFN,.121),IBTST=$P(IBTADD,U,5),IBTST=$S(IBTST'="":$P(^DIC(5,IBTST,0),U,2),1:"") I $P(IBTADD,U)="" S IBT1="NO TEMPORARY ADDRESS" - Q -2 ;Employment variables set - D Q1^IBCVA,Q2^IBCVA -EN2 S:'$D(^DPT(DFN,.311)) IBEMPD="" I $D(^DPT(DFN,.311)) I ^DPT(DFN,.311)'="" S IBEMPD=$P(^(.311),U)_"^"_$P(^(.311),U,6)_"^"_$S($P(^(.311),U,7)'="":$P(^(.311),U,7),1:"")_"^"_$P($G(^DPT(DFN,.22)),U,5)_"^"_$P(IB(0),U,9)_"^"_$P(IB(0),U,8) - I $D(IBEMPD) S:IBEMPD'="" IBEC=$P(^DPT(DFN,.311),"^",15) - I $D(^DPT(DFN,.25)) S:$P(^DPT(DFN,.25),U,6)'="" IBSEST=$P(^(.25),U,6),IBSEST=$P(^DIC(5,IBSEST,0),U,2) - Q -3 ;Insurance variables set -EN3 D 123^IBCVA -EN31 ; -IBdd(i) = value of ins node in dpt - I '$D(^DGCR(399,IBIFN,"AIC")) S IBINDT=$S(+$G(IB("U")):+IB("U"),+$G(^DGCR(399,IBIFN,"U")):+$G(^("U")),1:DT) D ALL^IBCNS1(DFN,"IBDD",1,IBINDT) S I="" F S I=$O(IBDD(I)) Q:'I D INS - I $D(^DGCR(399,IBIFN,"AIC")) S IBIN="I" F I=1:1:3 S IBIN=$O(^DGCR(399,IBIFN,IBIN)) Q:IBIN'?1"I".N S IBDD(I,0)=^DGCR(399,IBIFN,IBIN) D INS - Q -INS I $P(IBDD(I,0),U,6)="v" S IBISEX(I)=$P(^DPT(DFN,0),U,2) - E S IBISEX(I)=$P($G(^DPT(DFN,.312,+$P($G(^DGCR(399,IBIFN,"M")),U,I+11),3)),U,12) ; *361 replaces old calculation of insured's sex - S IBISEX(I)=$S(IBISEX(I)="M":"MALE",IBISEX(I)="F":"FEMALE",1:"UNSPECIFIED") - S IBIRN(I)=$P(IBDD(I,0),U,16) - S IBIR(I)=$$EXTERNAL^DILFD(2.312,16,,IBIRN(I)) - Q -ADDR ;SET ADDRESS - S IBADD1="" I $D(^DGCR(399,IBIFN,"M")),$P(^("M"),"^",10)]"" Q - S X=$S($D(^DPT(DFN,.11)):^(.11),1:"") F I=1:1:4 I $P(X,"^",I)]"" S IBADD1=IBADD1_$P(X,"^",I)_"," - I $D(^DIC(5,+$P(X,"^",5),0)) S IBADD1=IBADD1_$P(^(0),"^",2),IBST=$P(^(0),"^",2) - S:$P(X,"^",12)]"" IBADD1=IBADD1_" "_$P(X,"^",12) Q - ;IBCVA0 +IBCVA0 ;ALB/MJB - SET MCCR VARIABLES CONT. ;04 AUG 88 03:02 + ;;2.0;INTEGRATED BILLING;**52,361**;21-MAR-94;Build 9 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; + ;MAP TO DGCRVA0 + ; + Q +ALL I $D(DFN) S IBDPT=^DPT(DFN,0) D ADDR ;I IBADD1]"",$L(IBADD1)'>47 S DIE="^DGCR(399,",(DA,Y)=+IBIFN,DR="110///"_IBADD1 D ^DIE K DIE,DR,DA + ;I $D(^DPT(DFN,.11)) S IBST=$P(^(.11),U,5),IBST=$S(IBST'="":$P(^DIC(5,IBST,0),U,2),1:"") + S IBBNO=$P(IB(0),"^"),IBDT=$P(IB(0),"^",3) + D 2^VADPT + ;I $P(IB(0),U,5)<3 S Y=0 F I=1:1 S Y=$O(^DGPM("APTT1",DFN,Y)) Q:'Y S:$E(Y,1,7)=IBDT IBDA=Y + Q +1 ;Demographic variables set + D Q1^IBCVA +EN1 Q:'$D(DFN) S IBMAR=$S($P(IBDPT,U,5)'="":$P(IBDPT,U,5),1:"U") I IBMAR'="U" S IBMAR=$S(IBMAR=6:"S",IBMAR=2:"M",IBMAR=1:"D",IBMAR=4:"W",IBMAR=5:"X",1:"U") + I $D(^DPT(DFN,.121)) S IBTADD=^DPT(DFN,.121),IBTST=$P(IBTADD,U,5),IBTST=$S(IBTST'="":$P(^DIC(5,IBTST,0),U,2),1:"") I $P(IBTADD,U)="" S IBT1="NO TEMPORARY ADDRESS" + Q +2 ;Employment variables set + D Q1^IBCVA,Q2^IBCVA +EN2 S:'$D(^DPT(DFN,.311)) IBEMPD="" I $D(^DPT(DFN,.311)) I ^DPT(DFN,.311)'="" S IBEMPD=$P(^(.311),U)_"^"_$P(^(.311),U,6)_"^"_$S($P(^(.311),U,7)'="":$P(^(.311),U,7),1:"")_"^"_$P($G(^DPT(DFN,.22)),U,5)_"^"_$P(IB(0),U,9)_"^"_$P(IB(0),U,8) + I $D(IBEMPD) S:IBEMPD'="" IBEC=$P(^DPT(DFN,.311),"^",15) + I $D(^DPT(DFN,.25)) S:$P(^DPT(DFN,.25),U,6)'="" IBSEST=$P(^(.25),U,6),IBSEST=$P(^DIC(5,IBSEST,0),U,2) + Q +3 ;Insurance variables set +EN3 D 123^IBCVA +EN31 ; -IBdd(i) = value of ins node in dpt + I '$D(^DGCR(399,IBIFN,"AIC")) S IBINDT=$S(+$G(IB("U")):+IB("U"),+$G(^DGCR(399,IBIFN,"U")):+$G(^("U")),1:DT) D ALL^IBCNS1(DFN,"IBDD",1,IBINDT) S I="" F S I=$O(IBDD(I)) Q:'I D INS + I $D(^DGCR(399,IBIFN,"AIC")) S IBIN="I" F I=1:1:3 S IBIN=$O(^DGCR(399,IBIFN,IBIN)) Q:IBIN'?1"I".N S IBDD(I,0)=^DGCR(399,IBIFN,IBIN) D INS + Q +INS I $P(IBDD(I,0),U,6)="v" S IBISEX(I)=$P(^DPT(DFN,0),U,2) + E S IBISEX(I)=$P($G(^DPT(DFN,.312,+$P($G(^DGCR(399,IBIFN,"M")),U,I+11),3)),U,12) ; *361 replaces old calculation of insured's sex + S IBISEX(I)=$S(IBISEX(I)="M":"MALE",IBISEX(I)="F":"FEMALE",1:"UNSPECIFIED") + S IBIRN(I)=$P(IBDD(I,0),U,16),IBIR(I)=$S(IBIRN(I)="01":"PATIENT",IBIRN(I)="02":"SPOUSE",IBIRN(I)="03":"CHILD",IBIRN(I)="08":"EMPLOYEE",IBIRN(I)="11":"ORGAN DONOR",IBIRN(I)="18":"PARENT",IBIRN(I)=15:"PLANTIFF",1:"UNKNOWN") + I IBIR(I)="UNKNOWN" S IBIR(I)=$S('$D(IBDD(I,0)):"UNKNOWN",$P(IBDD(I,0),U,6)="v":"PATIENT",$P(IBDD(I,0),U,6)="s":"SPOUSE",1:"UNKNOWN") + ;S IBIUTL(I)=IBDD(I,0)_"^"_IBISEX(I)_"^"_IBIRN(I) + Q +ADDR ;SET ADDRESS + S IBADD1="" I $D(^DGCR(399,IBIFN,"M")),$P(^("M"),"^",10)]"" Q + S X=$S($D(^DPT(DFN,.11)):^(.11),1:"") F I=1:1:4 I $P(X,"^",I)]"" S IBADD1=IBADD1_$P(X,"^",I)_"," + I $D(^DIC(5,+$P(X,"^",5),0)) S IBADD1=IBADD1_$P(^(0),"^",2),IBST=$P(^(0),"^",2) + S:$P(X,"^",12)]"" IBADD1=IBADD1_" "_$P(X,"^",12) Q + ;IBCVA0 diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCVA1.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCVA1.m index 9cdfdd75..4cc7df71 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCVA1.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCVA1.m @@ -1,111 +1,111 @@ -IBCVA1 ;ALB/MJB - SET MCCR VARIABLES CONT. ;09 JUN 88 14:49 - ;;2.0;INTEGRATED BILLING;**52,80,109,51,137,210,349,371**;21-MAR-94;Build 57 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ;MAP TO DGCRVA1 - ; - Q -4 ;Event variables set - D 1234^IBCVA - Q:'$D(IBBT) -EN4 I $E(IBBT,2)>2 G OCC -INP D INP^IBCSC4 - ;NOTE (12/1/93): IBDI AND IBDIN ARRAYS WERE NOT UPDATED WITH NEW DX LOCATIONS BECAUSE THEY DO NOT SEEM TO BE USED ANYWHERE -OCC I $D(^DGCR(399,IBIFN,"C")) D - . N IBDATE,IBC - . S IBDATE=$$BDATE^IBACSV(IBIFN) ; The date of service - . S IBC=^DGCR(399,IBIFN,"C") - . F I=14:1:18 S IBDI(I)=$P(IBC,U,I) Q:IBDI(I)="" D - .. S IBDIN(I)=IBDI(I) - .. S IBDI(I)=$P($$ICD9^IBACSV(IBDI(I),IBDATE),U,3) - K IBO S:'$D(^DGCR(399,IBIFN,"OC")) IBO="" G:$D(IBO) COND S IBNO=$P(^DGCR(399,IBIFN,"OC",0),U,3),IBOC=0 - S C=0 F I=0:1 S IBOC=$O(^DGCR(399,IBIFN,"OC",I)) Q:IBOC'?1N.N!(C=5) I $D(^DGCR(399,IBIFN,"OC",I)) S C=C+1 D SOCC - ; -COND S IBCC=0,D=0 F I=0:0 S IBCC=$O(^DGCR(399,IBIFN,"CC",IBCC)) Q:IBCC=""!(D=5) I $D(^DGCR(399,IBIFN,"CC",IBCC,0)) S D=D+1,IBCC(D)=$P(^DGCR(399,IBIFN,"CC",IBCC,0),"^",1) D CONDN - ; - D PROC - ; - ;Q:'$D(^DGCR(399,IBIFN,"C")) F I=0,"C" S IB(I)=$S($D(^DGCR(399,IBIFN,I)):^(I),1:"") - ;I $P(IB(0),"^",9)=4 F I=1:1:3 S:$P(IB("C"),"^",I)'="" IBCPT(I)=$P(IB("C"),"^",I) - ;I $P(IB(0),"^",9)=9 F I=4:1:6 S:$P(IB("C"),"^",I)'="" IBICD(I)=$P(IB("C"),"^",I) - ;I $P(IB(0),"^",9)=5 F I=7:1:9 S:$P(IB("C"),"^",I)]"" IBHC(I)=$P(IB("C"),"^",I),IBHCN(I)=$S($D(^ICPT(IBHC(I),0)):$P(^(0),"^",1),1:"") - Q - ; -5 ;Billing variables set - D 123^IBCVA -EN5 I '$D(IBIP) G REVC - S IBLS=$S($P(IB("U"),U,15)]"":$P(IB("U"),U,15),1:0),IBBS=$S($P(IB("U"),U,11)]"":$P(IB("U"),U,11),1:IBU) I IBBS'=IBU S IBBS=$P(^DGCR(399.1,IBBS,0),"^",1) -REVC S IBREV=0 F I=1:1 S IBREV=$O(^DGCR(399,IBIFN,"RC",IBREV)) Q:IBREV'?1.N S IBREVC(I)=^DGCR(399,IBIFN,"RC",IBREV,0) - S IBTF=$P(IB(0),U,26),IBTF=$S(IBTF=1:"ADMIT THRU DISCHARGE",IBTF=2:"FIRST CLAIM",IBTF=3:"CONTINUING CLAIM",IBTF=4:"LAST CLAIM",IBTF=5:"LATE CHARGE(S)",IBTF=6:"ADJUSTMENT",IBTF=7:"REPLACEMENT",IBTF=8:"CANCEL",IBTF=0:"ZERO CLAIM",1:"") - S IBBTP1=$E($$EXPAND^IBTRE(399,.24,$P(IB(0),U,24)),1,29) - S IBBTP2=$E($$EXPAND^IBTRE(399,.25,+$P(IB(0),U,25)),1,26) - S IBBTP3=IBTF - Q -SOCC S IBO(C)=$P(^DGCR(399,IBIFN,"OC",IBOC,0),"^",1),IBO(C)=$P(^DGCR(399.1,IBO(C),0),"^",2),IBOCN(C)=$P(^(0),"^",1) - S IBOCD(C)=$P(^DGCR(399,IBIFN,"OC",IBOC,0),"^",2),IBOCD2(C)=$P(^DGCR(399,IBIFN,"OC",IBOC,0),"^",4) Q - Q - ; -CONDN S IBCC(D)=$P($G(^DGCR(399.1,+IBCC(D),0)),U,2),IBCCN(D)=$P($G(^(0)),U,1) - Q - ; -PROCX ; Entrypoint from output formatter - N IBIFN,IBZ - S IBIFN=$G(IBXIEN) - D PROC - D F^IBCEF("N-PROCEDURE CODING METHD","IBZ",,IBIFN) - I IBZ="" K IBPROC S IBPROC=0 Q - S Z=0 F S Z=$O(IBPROC(Z)) Q:'Z I $P(IBPROC(Z),U)'[$S(IBZ=9:";ICD",1:";ICP") K IBPROC(Z) S IBPROC=IBPROC-1 - Q - ; -PROC ; -build array of procedures in IBPROC - N IBHCFA,IBMOD,I,J,X,X1 - S IBHCFA=($$FT^IBCEF(IBIFN)=2) - K IBPROC S IBPROC=0 - I '$D(IB("C")) S IB("C")=$G(^DGCR(399,IBIFN,"C")) - S:'$D(IB(0)) IB(0)=$G(^DGCR(399,IBIFN,0)) S J=$P($G(IB(0)),"^",9) - I IB("C")'="" F I=1:1:9 I $P(IB("C"),"^",I)'="" S IBPROC(I)=$P(IB("C"),"^",I)_";"_$S(I<4:"ICPT(",I<7:"ICD0(",1:"ICPT(")_"^"_$P(IB("C"),"^",$S(I#3:10+(I#3),1:13)),IBPROC=IBPROC+1 - I $D(^DGCR(399,IBIFN,"CP")) S X=0 F I=100:1 S X=$O(^DGCR(399,IBIFN,"CP",X)) Q:'X S X1=$G(^(X,0)) Q:'X1 D - . S IBMOD=$$GETMOD^IBEFUNC(IBIFN,X) - . I $TR(IBMOD,",")'="" S $P(X1,U,15)=IBMOD - . S IBPROC($S($P(X1,"^",4):$P(X1,"^",4),1:I))=X1 - . I IBHCFA S IBPROC($S($P(X1,"^",4):$P(X1,"^",4),1:I),"AUX")=$G(^DGCR(399,IBIFN,"CP",X,"AUX")) - . S IBPROC=IBPROC+1 -PROCQ Q - ; -ALLPROC(IBIFN,IBPROC) ; Returns all procedures for bill IBIFN in array IBPROC - ; IBPROC = # of procedures found - ; IBPROC(prnt order)=0-node of 'CP' entry with piece 15 = the - ; modifiers separated by commas - ; IBPROC(prnt order,"AUX")="AUX" node of 'CP' entry for CMS-1500 forms - ; Pass IBPROC by reference - ; - N IB - K IBPROC - D PROC - Q - ; -VC ;returns a bills value codes, IBIFN must be defined: IBVC=count,IBVC(VIFN)=CODE ^ NAME ^ VALUE ^ $$? - N IBY,IBX,IBZ S IBVC=0 Q:'$D(^DGCR(399,IBIFN,"CV")) - S IBX=0 F S IBX=$O(^DGCR(399,IBIFN,"CV",IBX)) Q:'IBX S IBY=$G(^DGCR(399,IBIFN,"CV",IBX,0)) I +IBY D - . S IBVC=IBVC+1,IBZ=$G(^DGCR(399.1,+IBY,0)) Q:IBZ="" - . S IBVC(+IBY)=$P(IBZ,U,2)_U_$P(IBZ,U,1)_U_$S($P(IBY,U,2)="":"",+$P(IBZ,U,12):$J($P(IBY,U,2),0,2),1:$P(IBY,U,2))_U_$P(IBZ,U,12) - Q - ; -SETMODS(IBMOD,IBZ,IBXSAVE) ; Set modifiers into IBXSAVE - ; IBMOD = the list of modifier iens for the proc, separated by commas - ; IBZ = the line counter to return the data in - ; - ; Output Formatter utility - ; - ; Variables passed by reference, returned - ; IBXSAVE("PROCMODS",IBZ) = Formatter 'save' array for modifiers - ; - N Q,IBQ - I $L(IBMOD) F Q=1:1:$L(IBMOD,",") I $P(IBMOD,",",Q)'="" D - . S IBQ=$$MOD^ICPTMOD(+$P(IBMOD,",",Q),"I") - . S IBXSAVE("PROCMODS",IBZ)=$G(IBXSAVE("PROCMODS",IBZ))_$P(IBQ,U,2)_"," - S Q=$L($G(IBXSAVE("PROCMODS",IBZ))) - I 'Q S IBXSAVE("PROCMODS",IBZ)="" - I Q S IBXSAVE("PROCMODS",IBZ)=$E(IBXSAVE("PROCMODS",IBZ),1,Q-1) - Q - ; +IBCVA1 ;ALB/MJB - SET MCCR VARIABLES CONT. ;09 JUN 88 14:49 + ;;2.0;INTEGRATED BILLING;**52,80,109,51,137,210,349**;21-MAR-94;Build 46 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; + ;MAP TO DGCRVA1 + ; + Q +4 ;Event variables set + D 1234^IBCVA + Q:'$D(IBBT) +EN4 I $E(IBBT,2)>2 G OCC +INP D INP^IBCSC4 + ;NOTE (12/1/93): IBDI AND IBDIN ARRAYS WERE NOT UPDATED WITH NEW DX LOCATIONS BECAUSE THEY DO NOT SEEM TO BE USED ANYWHERE +OCC I $D(^DGCR(399,IBIFN,"C")) D + . N IBDATE,IBC + . S IBDATE=$$BDATE^IBACSV(IBIFN) ; The date of service + . S IBC=^DGCR(399,IBIFN,"C") + . F I=14:1:18 S IBDI(I)=$P(IBC,U,I) Q:IBDI(I)="" D + .. S IBDIN(I)=IBDI(I) + .. S IBDI(I)=$P($$ICD9^IBACSV(IBDI(I),IBDATE),U,3) + K IBO S:'$D(^DGCR(399,IBIFN,"OC")) IBO="" G:$D(IBO) COND S IBNO=$P(^DGCR(399,IBIFN,"OC",0),U,3),IBOC=0 + S C=0 F I=0:1 S IBOC=$O(^DGCR(399,IBIFN,"OC",I)) Q:IBOC'?1N.N!(C=5) I $D(^DGCR(399,IBIFN,"OC",I)) S C=C+1 D SOCC + ; +COND S IBCC=0,D=0 F I=0:0 S IBCC=$O(^DGCR(399,IBIFN,"CC",IBCC)) Q:IBCC=""!(D=5) I $D(^DGCR(399,IBIFN,"CC",IBCC,0)) S D=D+1,IBCC(D)=$P(^DGCR(399,IBIFN,"CC",IBCC,0),"^",1) D CONDN + ; + D PROC + ; + ;Q:'$D(^DGCR(399,IBIFN,"C")) F I=0,"C" S IB(I)=$S($D(^DGCR(399,IBIFN,I)):^(I),1:"") + ;I $P(IB(0),"^",9)=4 F I=1:1:3 S:$P(IB("C"),"^",I)'="" IBCPT(I)=$P(IB("C"),"^",I) + ;I $P(IB(0),"^",9)=9 F I=4:1:6 S:$P(IB("C"),"^",I)'="" IBICD(I)=$P(IB("C"),"^",I) + ;I $P(IB(0),"^",9)=5 F I=7:1:9 S:$P(IB("C"),"^",I)]"" IBHC(I)=$P(IB("C"),"^",I),IBHCN(I)=$S($D(^ICPT(IBHC(I),0)):$P(^(0),"^",1),1:"") + Q + ; +5 ;Billing variables set + D 123^IBCVA +EN5 I '$D(IBIP) G REVC + S IBLS=$S($P(IB("U"),U,15)]"":$P(IB("U"),U,15),1:0),IBBS=$S($P(IB("U"),U,11)]"":$P(IB("U"),U,11),1:IBU) I IBBS'=IBU S IBBS=$P(^DGCR(399.1,IBBS,0),"^",1) +REVC S IBREV=0 F I=1:1 S IBREV=$O(^DGCR(399,IBIFN,"RC",IBREV)) Q:IBREV'?1.N S IBREVC(I)=^DGCR(399,IBIFN,"RC",IBREV,0) + S IBTF=$P(IB(0),U,26),IBTF=$S(IBTF=1:"ADMIT THRU DISCHARGE",IBTF=2:"FIRST CLAIM",IBTF=3:"CONTINUING CLAIM",IBTF=4:"LAST CLAIM",IBTF=5:"LATE CHARGE(S)",IBTF=6:"ADJUSTMENT",IBTF=7:"REPLACEMENT",IBTF=8:"CANCEL",IBTF=0:"ZERO CLAIM",1:"") + S IBBTP1=$E($$EXPAND^IBTRE(399,.24,$P(IB(0),U,24)),1,29) + S IBBTP2=$E($$EXPAND^IBTRE(399,.25,+$P(IB(0),U,25)),1,26) + S IBBTP3=IBTF + Q +SOCC S IBO(C)=$P(^DGCR(399,IBIFN,"OC",IBOC,0),"^",1),IBO(C)=$P(^DGCR(399.1,IBO(C),0),"^",2),IBOCN(C)=$P(^(0),"^",1) + S IBOCD(C)=$P(^DGCR(399,IBIFN,"OC",IBOC,0),"^",2),IBOCD2(C)=$P(^DGCR(399,IBIFN,"OC",IBOC,0),"^",4) Q + Q + ; +CONDN S IBCC(D)=$P($G(^DGCR(399.1,+IBCC(D),0)),U,2),IBCCN(D)=$P($G(^(0)),U,1) + Q + ; +PROCX ; Entrypoint from output formatter + N IBIFN,IBZ + S IBIFN=$G(IBXIEN) + D PROC + D F^IBCEF("N-PROCEDURE CODING METHD","IBZ",,IBIFN) + I IBZ="" K IBPROC S IBPROC=0 Q + S Z=0 F S Z=$O(IBPROC(Z)) Q:'Z I $P(IBPROC(Z),U)'[$S(IBZ=9:";ICD",1:";ICP") K IBPROC(Z) S IBPROC=IBPROC-1 + Q + ; +PROC ; -build array of procedures in IBPROC + N IBHCFA,IBMOD,I,J,X,X1 + S IBHCFA=($$FT^IBCEF(IBIFN)=2) + K IBPROC S IBPROC=0 + I '$D(IB("C")) S IB("C")=$G(^DGCR(399,IBIFN,"C")) + S:'$D(IB(0)) IB(0)=$G(^DGCR(399,IBIFN,0)) S J=$P($G(IB(0)),"^",9) + I IB("C")'="" F I=1:1:9 I $P(IB("C"),"^",I)'="" S IBPROC(I)=$P(IB("C"),"^",I)_";"_$S(I<4:"ICPT(",I<7:"ICD0(",1:"ICPT(")_"^"_$P(IB("C"),"^",$S(I#3:10+(I#3),1:13)),IBPROC=IBPROC+1 + I $D(^DGCR(399,IBIFN,"CP")) S X=0 F I=100:1 S X=$O(^DGCR(399,IBIFN,"CP",X)) Q:'X S X1=$G(^(X,0)) Q:'X1 D + . S IBMOD=$$GETMOD^IBEFUNC(IBIFN,X) + . I $TR(IBMOD,",")'="" S $P(X1,U,15)=IBMOD + . S IBPROC($S($P(X1,"^",4):$P(X1,"^",4),1:I))=X1 + . I IBHCFA S IBPROC($S($P(X1,"^",4):$P(X1,"^",4),1:I),"AUX")=$G(^DGCR(399,IBIFN,"CP",X,"AUX")) + . S IBPROC=IBPROC+1 +PROCQ Q + ; +ALLPROC(IBIFN,IBPROC) ; Returns all procedures for bill IBIFN in array IBPROC + ; IBPROC = # of procedures found + ; IBPROC(prnt order)=0-node of 'CP' entry with piece 15 = the + ; modifiers separated by commas + ; IBPROC(prnt order,"AUX")="AUX" node of 'CP' entry for CMS-1500 forms + ; Pass IBPROC by reference + ; + N IB + K IBPROC + D PROC + Q + ; +VC ;returns a bills value codes, IBIFN must be defined: IBVC=count,IBVC(VIFN)=CODE ^ NAME ^ VALUE ^ $$? + N IBY,IBX,IBZ S IBVC=0 Q:'$D(^DGCR(399,IBIFN,"CV")) + S IBX=0 F S IBX=$O(^DGCR(399,IBIFN,"CV",IBX)) Q:'IBX S IBY=$G(^DGCR(399,IBIFN,"CV",IBX,0)) I +IBY D + . S IBVC=IBVC+1,IBZ=$G(^DGCR(399.1,+IBY,0)) Q:IBZ="" + . S IBVC(+IBY)=$P(IBZ,U,2)_U_$P(IBZ,U,1)_U_$S(+$P(IBZ,U,12):$J($P(IBY,U,2),0,2),1:$P(IBY,U,2))_U_$P(IBZ,U,12) + Q + ; +SETMODS(IBMOD,IBZ,IBXSAVE) ; Set modifiers into IBXSAVE + ; IBMOD = the list of modifier iens for the proc, separated by commas + ; IBZ = the line counter to return the data in + ; + ; Output Formatter utility + ; + ; Variables passed by reference, returned + ; IBXSAVE("PROCMODS",IBZ) = Formatter 'save' array for modifiers + ; + N Q,IBQ + I $L(IBMOD) F Q=1:1:$L(IBMOD,",") I $P(IBMOD,",",Q)'="" D + . S IBQ=$$MOD^ICPTMOD(+$P(IBMOD,",",Q),"I") + . S IBXSAVE("PROCMODS",IBZ)=$G(IBXSAVE("PROCMODS",IBZ))_$P(IBQ,U,2)_"," + S Q=$L($G(IBXSAVE("PROCMODS",IBZ))) + I 'Q S IBXSAVE("PROCMODS",IBZ)="" + I Q S IBXSAVE("PROCMODS",IBZ)=$E(IBXSAVE("PROCMODS",IBZ),1,Q-1) + Q + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJDB1.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJDB1.m index d960e1b3..c31a3ae9 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJDB1.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJDB1.m @@ -1,113 +1,113 @@ -IBJDB1 ;ALB/CPM - BILLING LAG TIME REPORT ; 27-DEC-96 - ;;2.0;INTEGRATED BILLING;**69,80,100,118,165**;21-MAR-94 - ; -EN ; - Option entry point. - ; - W !!,"This report measures the amount of time between significant" - W !,"milestones which occur from the time treatment has been provided" - W !,"to the time that the claim to the insurer for that treatment has" - W !,"been closed out.",! - ; -DATE D DATE^IBOUTL I IBBDT=""!(IBEDT="") G ENQ - ; - ; - Sort by division. - S DIR(0)="Y",DIR("B")="NO" - S DIR("A")="Do you wish to sort this report by division" - S DIR("?")="^D HLP1^IBJDB1" W ! - D ^DIR K DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) G ENQ - S IBSORT=+Y K DIROUT,DTOUT,DUOUT,DIRUT - ; - ; - Issue prompt for division. - I IBSORT D PSDR^IBODIV G:Y<0 ENQ - ; - ; - Select a Detailed or Summary report. -DS D DS^IBJD I "^"[IBRPT G ENQ - I IBRPT="S" S IBSEL=",1,2,3,4,5,6,7,8,9,10,11," G DEV - ; -SEL ; - Select main report or line item reports. - W ! S DIR(0)="LO^1:11^K:+$P(X,""-"",2)>11 X" - F X=1:1:11 S DIR("A",X)=$S(X<10:" ",1:"")_X_" - Print "_$$TITLE(X,1) - S DIR("A",12)="",DIR("A")="Select",DIR("B")=1 - S DIR("?")="^D HLP2^IBJDB1" D ^DIR K DIR G:Y["^" ENQ S IBSEL=Y - S DIR(0)="Y",DIR("A",1)="You have selected" - I IBSEL="1,2,3,4,5,6,7,8,9,10,11," D - .S DIR("A",1)=DIR("A",1)_" ALL the above reports." - E F X=1:1 S X1=$P(IBSEL,",",X) Q:'X1 S DIR("A",X+1)=" "_$$TITLE(X1,1) - S DIR("A")="Are you sure",DIR("B")="NO" - W ! D ^DIR K DIR G ENQ:Y["^",SEL:'Y S IBSEL=","_IBSEL - ; -DEV W !!,"This report only requires an 80 column printer." - ; - W !!,"Note: This report searches through all Reimb. Insurance claims." - W !?6,"You should queue this report to run after normal business hours." - ; - ; - Select a device. - W ! S %ZIS="QM" D ^%ZIS G:POP ENQ - I $D(IO("Q")) D G ENQ - .S ZTRTN="DQ^IBJDB1",ZTDESC="IB - BILLING LAG TIME REPORT" - .F X="IB*","VAUTD","VAUTD(" S ZTSAVE(X)="" - .D ^%ZTLOAD W !!,$S($D(ZTSK):"This job has been queued. The task number is "_ZTSK_".",1:"Unable to queue this job.") - .K ZTSK,IO("Q") D HOME^%ZIS - ; - U IO - ; -DQ ; - Tasked entry point. - ; - I $G(IBXTRACT) D E^IBJDE(10,1) ; Change extract status. - ; - K IBCT,IBTL,^TMP("IBJDB1",$J) - S IBQ=0 D ^IBJDB11 I IBQ G ENQ ; Compile data for reports. - ; - ; - Extract summary data. - I $G(IBXTRACT) D G ENQ - .S X=0 F Y=1:1:4,9,10,11,"2I","3I","4I" D - ..S X=X+1,IB(X)=$J($S('IBCT(0,"OP",Y):0,1:IBTL(0,"OP",Y)/IBCT(0,"OP",Y)),0,2) - .F Y=5:1:11,"6I","7I","8I" D - ..S X=X+1,IB(X)=$J($S('IBCT(0,"IN",Y):0,1:IBTL(0,"IN",Y)/IBCT(0,"IN",Y)),0,2) - .D E^IBJDE(10,0) - ; - ; - Print the reports. - S IBQ=0 - S IBDIV="" F S IBDIV=$S(IBRPT="D":$O(^TMP("IBJDB1",$J,IBDIV)),1:$O(IBCT(IBDIV))) Q:IBDIV="" D Q:IBQ - .S IBPAG=0 D NOW^%DTC S IBRUN=$$DAT2^IBOUTL(%) - .I IBRPT="D" D OPT^IBJDB12 I 'IBQ D INP^IBJDB13 - .I IBRPT="S" D SUM^IBJDB12 - ; -ENQ K ^TMP("IBJDB1",$J) - I $D(ZTQUEUED) S ZTREQ="@" G ENQ1 - ; - D ^%ZISC -ENQ1 K IB,IBBDT,IBBN,IBEDT,IBCK,IBN,IBN0,IBRPT,IBPAG,IBQ,IBRUN,IBX,IBX1,IBX2 - K IBX3,IBAUTH,IBDAT,IBDFN,IBNU,IBPTF,IBPOL,IBPOL1,IBTY,IBS,IBSEL,IBSEL1 - K IBCT,IBDIV,IBSORT,IBTL,IBCHK,IBDCHK,DFN,POP,VAUTD,ZTDESC,ZTRTN,ZTSAVE - K IBDR,IBH,DIROUT,DTOUT,DUOUT,DIRUT,%,%ZIS,D,X,X1,X2,Y,Y1,Z,Z1,Z2,Z3 - Q - ; -HLP1 ; - 'Sort by Division?' prompt. - W !?1,"Enter a to print the report without regard to division," - W !?1,"or 'Y' to select those divisions for which a separate report" - W !?1,"should be created. To quit this option, enter '^'." - Q - ; -HLP2 ; - Line item report prompt. - W !?1,"Select '1-11' (Response can be a single number, list or range," - W !?1,"e.g.: 1,3,5 or 2-6,10) to print up to 11 lag time reports based" - W !?1,"on the line items of the lag time summary reports. To quit this" - W !?1,"option, enter '^'." - Q - ; -TITLE(X,Y) ; - Display/print report titles. - Q $P($T(TITLE1+X),";;",2)_$S(Y:$P($T(TITLE1+X),";;",3),1:"") - ; -TITLE1 ; - Line item titles. - ;;Date of Care to Date of Check Out;; (Outpatient claims) - ;;Date of Check Out to Date Claim Authorized;; (Outpatient claims) - ;;Date of Care to Date of First Payment;; (Outpatient claims) - ;;Date of Care to Date Receivable Closed;; (Outpatient claims) - ;;Date of Discharge to Date PTF Transmitted;; (Inpatient claims) - ;;Date PTF Transmitted to Date Claim Authorized;; (Inpatient claims) - ;;Date of Discharge to Date of First Payment;; (Inpatient claims) - ;;Date of Discharge to Date Receivable Closed;; (Inpatient claims) - ;;Date Claim Authorized to Date Claim Activated - ;;Date Claim Activated to Date of First Payment - ;;Date of First Payment to Date Receivable Closed +IBJDB1 ;ALB/CPM - BILLING LAG TIME REPORT ; 27-DEC-96 + ;;2.0;INTEGRATED BILLING;**69,80,100,118**;21-MAR-94 + ; +EN ; - Option entry point. + ; + W !!,"This report measures the amount of time between significant" + W !,"milestones which occur from the time treatment has been provided" + W !,"to the time that the claim to the insurer for that treatment has" + W !,"been closed out.",! + ; +DATE D DATE^IBOUTL I IBBDT=""!(IBEDT="") G ENQ + ; + ; - Sort by division. + S DIR(0)="Y",DIR("B")="NO" + S DIR("A")="Do you wish to sort this report by division" + S DIR("?")="^D HLP1^IBJDB1" W ! + D ^DIR K DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) G ENQ + S IBSORT=+Y K DIROUT,DTOUT,DUOUT,DIRUT + ; + ; - Issue prompt for division. + I IBSORT D PSDR^IBODIV G:Y<0 ENQ + ; + ; - Select a Detailed or Summary report. +DS D DS^IBJD I "^"[IBRPT G ENQ + I IBRPT="S" S IBSEL=",1,2,3,4,5,6,7,8,9,10,11," G DEV + ; +SEL ; - Select main report or line item reports. + W ! S DIR(0)="LO^1:11^K:+$P(X,""-"",2)>11 X" + F X=1:1:11 S DIR("A",X)=$S(X<10:" ",1:"")_X_" - Print "_$$TITLE(X,1) + S DIR("A",12)="",DIR("A")="Select",DIR("B")=1 + S DIR("?")="^D HLP2^IBJDB1" D ^DIR K DIR G:Y["^" ENQ S IBSEL=Y + S DIR(0)="Y",DIR("A",1)="You have selected" + I IBSEL="1,2,3,4,5,6,7,8,9,10,11," D + .S DIR("A",1)=DIR("A",1)_" ALL the above reports." + E F X=1:1 S X1=$P(IBSEL,",",X) Q:'X1 S DIR("A",X+1)=" "_$$TITLE(X1,1) + S DIR("A")="Are you sure",DIR("B")="NO" + W ! D ^DIR K DIR G ENQ:Y["^",SEL:'Y S IBSEL=","_IBSEL + ; +DEV W !!,"This report only requires an 80 column printer." + ; + W !!,"Note: This report searches through all Reimb. Insurance claims." + W !?6,"You should queue this report to run after normal business hours." + ; + ; - Select a device. + W ! S %ZIS="QM" D ^%ZIS G:POP ENQ + I $D(IO("Q")) D G ENQ + .S ZTRTN="DQ^IBJDB1",ZTDESC="IB - BILLING LAG TIME REPORT" + .F X="IB*","VAUTD","VAUTD(" S ZTSAVE(X)="" + .D ^%ZTLOAD W !!,$S($D(ZTSK):"This job has been queued. The task number is "_ZTSK_".",1:"Unable to queue this job.") + .K ZTSK,IO("Q") D HOME^%ZIS + ; + U IO + ; +DQ ; - Tasked entry point. + ; + I $G(IBXTRACT) D E^IBJDE(10,1) ; Change extract status. + ; + K IBCT,IBTL,^TMP("IBJDB1",$J) + S IBQ=0 D ^IBJDB11 I IBQ G ENQ ; Compile data for reports. + ; + ; - Extract summary data. + I $G(IBXTRACT) D G ENQ + .S X=0 F Y=1:1:4,9,10,11,"2I","3I","4I" D + ..S X=X+1,IB(X)=$J($S('IBCT(0,"OP",Y):0,1:IBTL(0,"OP",Y)/IBCT(0,"OP",Y)),0,2) + .F Y=5:1:11,"6I","7I","8I" D + ..S X=X+1,IB(X)=$J($S('IBCT(0,"IN",Y):0,1:IBTL(0,"IN",Y)/IBCT(0,"IN",Y)),0,2) + .D E^IBJDE(10,0) + ; + ; - Print the reports. + S IBQ=0 + S IBDIV="" F S IBDIV=$S(IBRPT="D":$O(^TMP("IBJDB1",$J,IBDIV)),1:$O(IBCT(IBDIV))) Q:IBDIV="" D Q:IBQ + .S IBPAG=0 D NOW^%DTC S IBRUN=$$DAT2^IBOUTL(%) + .I IBRPT="D" D OPT^IBJDB12 I 'IBQ D INP^IBJDB13 + .I IBRPT="S" D SUM^IBJDB12 + ; +ENQ K ^TMP("IBJDB1",$J) + I $D(ZTQUEUED) S ZTREQ="@" G ENQ1 + ; + D ^%ZISC +ENQ1 K IB,IBBDT,IBEDT,IBCK,IBN,IBN0,IBRPT,IBPAG,IBQ,IBRUN,IBX,IBX1,IBX2,IBX3 + K IBAUTH,IBDAT,IBDFN,IBNU,IBPTF,IBPOL,IBPOL1,IBTY,IBS,IBSEL,IBSEL1,IBCT + K IBDIV,IBSORT,IBTL,IBCHK,IBDCHK,DFN,POP,VAUTD,ZTDESC,ZTRTN,ZTSAVE + K DIROUT,DTOUT,DUOUT,DIRUT,%,%ZIS,D,X,X1,X2,Y,Y1,Z,Z1,Z2,Z3 + Q + ; +HLP1 ; - 'Sort by Division?' prompt. + W !?1,"Enter a to print the report without regard to division," + W !?1,"or 'Y' to select those divisions for which a separate report" + W !?1,"should be created. To quit this option, enter '^'." + Q + ; +HLP2 ; - Line item report prompt. + W !?1,"Select '1-11' (Response can be a single number, list or range," + W !?1,"e.g.: 1,3,5 or 2-6,10) to print up to 11 lag time reports based" + W !?1,"on the line items of the lag time summary reports. To quit this" + W !?1,"option, enter '^'." + Q + ; +TITLE(X,Y) ; - Display/print report titles. + Q $P($T(TITLE1+X),";;",2)_$S(Y:$P($T(TITLE1+X),";;",3),1:"") + ; +TITLE1 ; - Line item titles. + ;;Date of Care to Date of Check Out;; (Outpatient claims) + ;;Date of Check Out to Date Claim Authorized;; (Outpatient claims) + ;;Date of Care to Date of First Payment;; (Outpatient claims) + ;;Date of Care to Date Receivable Closed;; (Outpatient claims) + ;;Date of Discharge to Date PTF Transmitted;; (Inpatient claims) + ;;Date PTF Transmitted to Date Claim Authorized;; (Inpatient claims) + ;;Date of Discharge to Date of First Payment;; (Inpatient claims) + ;;Date of Discharge to Date Receivable Closed;; (Inpatient claims) + ;;Date Claim Authorized to Date Claim Activated + ;;Date Claim Activated to Date of First Payment + ;;Date of First Payment to Date Receivable Closed diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJDB11.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJDB11.m index bd87b348..2cf23aea 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJDB11.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJDB11.m @@ -1,189 +1,168 @@ -IBJDB11 ;ALB/CPM - BILLING LAG TIME REPORT (COMPILE) ; 27-DEC-96 - ;;2.0;INTEGRATED BILLING;**69,100,118,165**;21-MAR-94 - ; -EN ; - Entry point from IBJDB1. - ; - ; - - I IBRPT="D" F X=2,3,4,6,7,8 S:IBSEL[X IBSEL=IBSEL_X_"I," - I 'IBSORT D INIT(0) G REV - S X=0 F S X=$S('VAUTD:$O(VAUTD(X)),1:$O(^DG(40.8,X))) Q:'X D INIT(X) - ; -REV ; - Review all claims in file #399. - S IBN=0 F S IBN=$O(^DGCR(399,IBN)) Q:'IBN S IBN0=$G(^(IBN,0)) D Q:IBQ - .I IBN#100=0 S IBQ=$$STOP^IBOUTL("Billing Lag Time Report") Q:IBQ - .; - .I $P($G(^PRCA(430,IBN,0)),U,2)'=9 Q ; Not an RI claim. - .I $P(IBN0,U,13)<3 Q ; Not authorized. - .I $P(IBN0,U,13)=7 Q ; Cancelled in IB. - .S X=$P($G(^PRCA(430,IBN,0)),U,8) I X=26!(X=39) Q ; Cancelled in AR. - .; - .; - Does claim meet report criteria? - .S IBAUTH=$$AUTH(IBN) I 'IBAUTH Q - .; - .; - Get division, if necessary. - .I 'IBSORT S IBDIV=0 - .E S IBDIV=$$DIV^IBJDF2(IBN) I 'IBDIV S IBDIV=+$$PRIM^VASITE() - .I IBSORT,'VAUTD,'$D(VAUTD(IBDIV)) Q ; Not a selected division. - .; - .S IBTY=$S($P(IBN0,U,5)<3:"IN",1:"OP") ; Inpatient or outpatient claim? - .; - .;- Get date PTF transmitted. - .S IBPTF="" I IBTY="IN" S IBPTF=$$PTF($P(IBN0,U,8)) Q:'IBPTF - .; - .; - Get other claim info and build date line. - .S IBDAT=$P(IBAUTH,U,2,5),DFN=+$P(IBN0,U,2),IBDFN=$G(^DPT(DFN,0)) - .S IBPOL=+$G(^DPT(DFN,.312,+$P($G(^DGCR(399,IBN,"MP")),U,2),1)) - .; - .; - Get care dates; quit if there are none. - .K IBDR S IBNU=$G(^DGCR(399,IBN,"U")) D - ..I IBTY="IN" S X=+$P(IBNU,U,2) S:'X X=+IBNU S:X IBDR(X)="" Q - ..I '$D(^DGCR(399,IBN,"OP")) D Q - ...S X=+$P(IBNU,U,2) S:X IBDR(X)="" S:+IBNU&(+IBNU'=X) IBDR(+IBNU)="" - ..S X=0 F S X=$O(^DGCR(399,IBN,"OP",X)) Q:'X S IBDR(X)="" - .I '$D(IBDR) Q - .; - .; - Calculate statistics for each care date. - .S IBX=0 F S IBX=$O(IBDR(IBX)) Q:'IBX D - ..; - ..; - Get discharge date. - ..I IBTY="IN" D - ...S IBX1=+$G(^DGPT(+$P(IBN0,U,8),70))\1 I IBX1 Q - ...S IBX1=+$O(^DGPM("APTT3",DFN,(IBX-.0001)))\1 I 'IBX1 S IBX1=IBX - ..; - ..; - Get most recent check out date that has not been marked as non - ..; billable by Claims Tracking; quit if there isn't one. - ..I IBTY="OP" D K IBCL,IBCL1 Q:'IBCHK - ...D CL(IBN) ;GET LIST OF CLINICS FOR THIS BILL - ...S IBCHK=0,IBX1=IBX-.0001 - ...F S IBX1=$O(^SCE("ADFN",DFN,IBX1)) Q:'IBX1!((IBX1\1)>IBX) D - ....S IBX2=0 F S IBX2=$O(^SCE("ADFN",DFN,IBX1,IBX2)) Q:'IBX2 D - .....; - .....;CHECK TO SEE IF CLINICS MATCH - .....S IBCL1=+$P($G(^SCE(IBX2,0)),U,4) Q:'$D(IBCL(IBCL1)) - .....I $P($G(^IBT(356,+$O(^IBT(356,"ASCE",IBX2,0)),0)),U,19) Q - .....S IBX3=$P($G(^SCE(IBX2,0)),U,7)\1 I IBX3,IBX3'>$P(IBAUTH,U,2) D - ...... S:IBX3>IBCHK IBCHK=IBX3 Q - ..; - ..S X=$S(IBTY="IN":IBX1_U_+IBPTF,1:IBX_U_IBCHK)_U_IBDAT - ..S IBPOL1=$S(IBPOL>+X:1,1:0) ; Policy found after treatment. - ..; - ..; - Check date line for at least one date within the user specified - ..; range; quit if there isn't any. - ..S IBDCHK=0 F Y=2:1:6 I $$DL(0,$P(X,U,Y)) S IBDCHK=1 Q - ..I 'IBDCHK Q - ..; - ..K D,Y,Z S IBSEL1="" - ..F Y=1:1:5 S Z(1)=$P(X,U,Y),Z(2)=$P(X,U,Y+1) D - ...; - ...; - Check out date/PTF transmission date. - ...I Y=1 D:Z(2) Q - ....S D(0)=$$FMDIFF^XLFDT(Z(2),Z(1)),Z=$S(IBTY="IN":5,1:1) - ....I $$DL(Z,Z(2)) S IBSEL1=IBSEL1_Z_",",Y(Z)=$S(IBRPT="D":Z(1)_U_Z(2)_U_D(0),1:D(0)) - ...; - ...; - Date authorized. - ...I Y=2 D:Z(1) Q - ....S D(1)=$$FMDIFF^XLFDT(Z(2),Z(1)),Z=$S(IBTY="IN":6,1:2) - ....I $$DL(Z,Z(2)) D - .....S Z1=$S(IBPOL1:Z_"I",1:Z),IBSEL1=IBSEL1_Z1_",",Y(Z1)=$S(IBRPT="D":Z(1)_U_Z(2)_U_D(1),1:D(1)) - .....I Z1=Z D - ......S Z2=Z_"I",IBSEL1=IBSEL1_Z2_",",Y(Z2)=$S(IBRPT="D":Z(1)_U_Z(2)_U_D(1),1:D(1)) - ...; - ...; - Date activated. - ...I Y=3 D:Z(2) Q - ....S D(2)=$$FMDIFF^XLFDT(Z(2),Z(1)) I $$DL(9,Z(2)) S IBSEL1=IBSEL1_"9,",Y(9)=$S(IBRPT="D":Z(1)_U_Z(2)_U_D(2),1:D(2)) - ...; - ...; - Payment date. - ...I Y=4 D:Z(2) Q - ....S D(3)=$$FMDIFF^XLFDT(Z(2),Z(1)),D(6)=$$FMDIFF^XLFDT(Z(2),+X) - ....F Z=$S(IBTY="IN":7,1:3),10 I $$DL(Z,Z(2)) D - .....S Z1=$S(IBPOL1&(Z<10):Z_"I",1:Z),Z2=$S(Z<10:6,1:3) - .....S IBSEL1=IBSEL1_Z1_",",Y(Z1)=$S(IBRPT="D":$S(Z2=3:Z(1),1:+X)_U_Z(2)_U_D(Z2),1:D(Z2)) - .....I Z1=Z,Z<10 S Z3=Z_"I",IBSEL1=IBSEL1_Z3_",",Y(Z3)=$S(IBRPT="D":$S(Z2=3:Z(1),1:+X)_U_Z(2)_U_D(Z2),1:D(Z2)) - ...; - ...; - Date closed. - ...I Z(2) D - ....S D(4)=$$FMDIFF^XLFDT(Z(2),Z(1)),D(5)=$$FMDIFF^XLFDT(Z(2),+X) - ....F Z=$S(IBTY="IN":8,1:4),11 I $$DL(Z,Z(2)) D - .....S Z1=$S(IBPOL1&(Z<11):Z_"I",1:Z),Z2=$S(Z<11:5,1:4) - .....S IBSEL1=IBSEL1_Z1_",",Y(Z1)=$S(IBRPT="D":$S(Z2=4:Z(1),1:+X)_U_Z(2)_U_D(Z2),1:D(Z2)) - .....I Z1=Z,Z<11 S Z3=Z_"I",IBSEL1=IBSEL1_Z3_",",Y(Z3)=$S(IBRPT="D":$S(Z2=4:Z(1),1:+X)_U_Z(2)_U_D(Z2),1:D(Z2)) - ..; - ..; - Save data for detail or summary report(s). - ..F Y=1:1 S Z=$P(IBSEL1,",",Y) Q:'Z D - ...I IBRPT="D" D - ....S IBBN=$P(IBN0,U) S:IBPOL1 IBBN=IBBN_"*" - ....S Y(Z)=IBBN_U_Y(Z),Y1(Z)=$G(Y1(Z))+1 - ....S ^TMP("IBJDB1",$J,IBDIV,IBTY,Z,$P(IBDFN,U)_"@@"_$P(IBDFN,U,9),Y1(Z))=Y(Z) - ...E S IBCT(IBDIV,IBTY,Z)=IBCT(IBDIV,IBTY,Z)+1,IBTL(IBDIV,IBTY,Z)=IBTL(IBDIV,IBTY,Z)+Y(Z) - ; - Q - ; -INIT(X) ; - Initialize summary accumulators/detail division nodes. - I IBRPT="D" S ^TMP("IBJDB1",$J,X)="" Q - F Y=1:1:4,9,10,11,"2I","3I","4I" S (IBCT(X,"OP",Y),IBTL(X,"OP",Y))=0 - F Y=5:1:11,"6I","7I","8I" S (IBCT(X,"IN",Y),IBTL(X,"IN",Y))=0 - Q - ; -AUTH(IBN) ; - Is this an authorized claim? - ; Input: IBN=Pointer to the AR in file #430 - ; Output: VAL=1^2^3^4^5, where: - ; 1=1-Authorized claim - ; 0-Not an authorized claim - ; 2=Date AR was authorized - ; 3=Date AR was activated - ; 4=AR first payment date - ; 5=Date AR was closed - ; - N IBPAY,IBT,IBT0,IBT1,VAL,X - S VAL=0 I '$G(IBN) G AUTHQ - ; - ; - Get date authorized (required). - S X=$P($G(^DGCR(399,IBN,"S")),U,10) G:'X AUTHQ S VAL="1^"_X - ; - ; - Get date activated, if available. - S X=$P($G(^PRCA(430,IBN,6)),U,21) I X S $P(VAL,U,3)=X\1 G FP - S X=$P($G(^PRCA(430,IBN,9)),U,3) I X S $P(VAL,U,3)=X\1 G FP - S X=$P($G(^PRCA(430,IBN,0)),U,10) I X S $P(VAL,U,3)=X\1 - ; -FP ; - Get first payment date, if available. - I '$P($G(^PRCA(430,IBN,7)),U,7) G DC ; No payments made. - S (IBPAY,IBT)=0 F S IBT=$O(^PRCA(433,"C",IBN,IBT)) Q:'IBT D Q:IBPAY - .S IBT0=$G(^PRCA(433,IBT,0)),IBT1=$G(^(1)) - .I $P(IBT0,U,4)'=2 Q ; Not complete. - .I $P(IBT1,U,2)'=2,$P(IBT1,U,2)'=34 Q ; Not a payment. - .S X=$S(+IBT1:+IBT1,1:$P(IBT1,U,9)\1),$P(VAL,U,4)=X,IBPAY=1 - ; -DC ; - Get date AR closed. - S X=$$CLO^PRCAFN(IBN) I X>0 S $P(VAL,U,5)=X - ; - ; - Is there a payment date AND a closed date for this claim? - I '$P(VAL,U,4),$P(VAL,U,5) S $P(VAL,U)=0 - ; -AUTHQ Q VAL - ; -DL(X,X1) ; - Is line item date valid for report? - ; Input: X=Line item number (or 0), X1=Line item date - ; Output: 1=valid, 0=invalid - ; *Requires pre-defined variables IBBDT, IBEDT, and IBSEL - S X2=0 I 'X1 G DLQ - I 'X S:X1'IBEDT) X2=1 G DLQ - I IBSEL[(","_X_","),X1'IBEDT S X2=1 -DLQ Q X2 - ; - ; -PTF(X) ; - Get most recent PTF transmission date. - ; Input: X=IEN of PTF file entry. - ; Output: Y=PTF date. - N I,K,Y - S Y=0 G:'$O(^DGP(45.83,"C",+X,0)) PTFQ - S I=0 F S I=$O(^DGP(45.83,"C",X,I)) Q:'I D - .S J=$P($G(^DGP(45.83,I,0)),U,2)\1 Q:J>$P(IBAUTH,U,2) S:J K(J)="" - S I=0 F S I=$O(K(I)) Q:'I S Y=I - ; -PTFQ Q Y - ; -CL(IBN) ; - Get the clinics for bill. - N I,J K IBCL ; IBCL=Bill clinic array. - S I=0 F S I=$O(^DGCR(399,IBN,"CP",I)) Q:I="" D - .S J=$P($G(^DGCR(399,IBN,"CP",I,0)),U,7) S:J IBCL(J)="" - Q +IBJDB11 ;ALB/CPM - BILLING LAG TIME REPORT (COMPILE) ; 27-DEC-96 + ;;2.0;INTEGRATED BILLING;**69,100,118**;21-MAR-94 + ; +EN ; - Entry point from IBJDB1. + ; + ; - + I IBRPT="D" F X=2,3,4,6,7,8 S:IBSEL[X IBSEL=IBSEL_X_"I," + I 'IBSORT D INIT(0) G REV + S X=0 F S X=$S('VAUTD:$O(VAUTD(X)),1:$O(^DG(40.8,X))) Q:'X D INIT(X) + ; +REV ; - Review all claims in file #399. + S IBN=0 F S IBN=$O(^DGCR(399,IBN)) Q:'IBN S IBN0=$G(^(IBN,0)) D Q:IBQ + .I IBN#100=0 S IBQ=$$STOP^IBOUTL("Billing Lag Time Report") Q:IBQ + .; + .I $P($G(^PRCA(430,IBN,0)),U,2)'=9 Q ; Not an RI claim. + .I $P(IBN0,U,13)<3 Q ; Not authorized. + .I $P(IBN0,U,13)=7 Q ; Cancelled in IB. + .S X=$P($G(^PRCA(430,IBN,0)),U,8) I X=26!(X=39) Q ; Cancelled in AR. + .; + .; - Does claim meet report criteria? + .S IBAUTH=$$AUTH(IBN) I 'IBAUTH Q + .; + .; - Get division, if necessary. + .I 'IBSORT S IBDIV=0 + .E S IBDIV=$$DIV^IBJDF2(IBN) I 'IBDIV S IBDIV=+$$PRIM^VASITE() + .I IBSORT,'VAUTD,'$D(VAUTD(IBDIV)) Q ; Not a selected division. + .; + .S IBTY=$S($P(IBN0,U,5)<3:"IN",1:"OP") ; Inpatient or outpatient claim? + .; + .; - Get most recent date PTF transmitted. + .I IBTY="IN" D Q:'IBPTF!('IBPTF&($P(IBAUTH,U,2))) + ..S IBPTF=$P(IBN0,U,8) I 'IBPTF Q + ..S IBPTF=$O(^DGP(45.83,"C",IBPTF,9999999),-1)\1 I IBPTF Q + ..S IBPTF=$P($G(^DGP(45.83,IBPTF,0)),U,2)\1 + .; + .; - Get other claim info and build date line. + .S IBDAT=$P(IBAUTH,U,2,5),DFN=+$P(IBN0,U,2),IBDFN=$G(^DPT(DFN,0)) + .S IBPOL=+$G(^DPT(DFN,.312,+$P($G(^DGCR(399,IBN,"MP")),U,2),1)) + .; + .; - Get care dates; quit if there are none. + .K IBDR S IBNU=$G(^DGCR(399,IBN,"U")) D + ..I IBTY="IN" S X=+$P(IBNU,U,2) S:'X X=+IBNU S:X IBDR(X)="" Q + ..I '$D(^DGCR(399,IBN,"OP")) D Q + ...S X=+$P(IBNU,U,2) S:X IBDR(X)="" S:+IBNU&(+IBNU'=X) IBDR(+IBNU)="" + ..S X=0 F S X=$O(^DGCR(399,IBN,"OP",X)) Q:'X S IBDR(X)="" + .I '$D(IBDR) Q + .; + .; - Calculate statistics for each care date. + .S IBX=0 F S IBX=$O(IBDR(IBX)) Q:'IBX D + ..; + ..; - Get discharge date. + ..I IBTY="IN" D + ...S IBX1=+$G(^DGPT(+$P(IBN0,U,8),70))\1 I IBX1 Q + ...S IBX1=+$O(^DGPM("APTT3",DFN,(IBX-.0001)))\1 I 'IBX1 S IBX1=IBX + ..; + ..; - Get most recent check out date that has not been marked as non + ..; billable by Claims Tracking; quit if there isn't one. + ..I IBTY="OP" D Q:'IBCHK + ...S IBCHK=0,IBX1=IBX-.0001 + ...F S IBX1=$O(^SCE("ADFN",DFN,IBX1)) Q:'IBX1!((IBX1\1)>IBX) D + ....S IBX2=0 F S IBX2=$O(^SCE("ADFN",DFN,IBX1,IBX2)) Q:'IBX2 D + .....I $P($G(^IBT(356,+$O(^IBT(356,"ASCE",IBX2,0)),0)),U,19) Q + .....S IBX3=$P($G(^SCE(IBX2,0)),U,7)\1 I IBX3 S IBCHK=IBX3 + ..; + ..S X=$S(IBTY="IN":IBX1_U_IBPTF,1:IBX_U_IBCHK)_U_IBDAT + ..S IBPOL1=$S(IBPOL>+X:1,1:0) ; Policy found after treatment. + ..; + ..; - Check date line for at least one date within the user specified + ..; range; quit if there isn't any. + ..S IBDCHK=0 F Y=2:1:6 I $$DL(0,$P(X,U,Y)) S IBDCHK=1 Q + ..I 'IBDCHK Q + ..; + ..K D,Y,Z S IBSEL1="" + ..F Y=1:1:5 S Z(1)=$P(X,U,Y),Z(2)=$P(X,U,Y+1) D + ...; + ...; - Check out date/PTF transmission date. + ...I Y=1 D:Z(2) Q + ....S D(0)=$$FMDIFF^XLFDT(Z(2),Z(1)),Z=$S(IBTY="IN":5,1:1) + ....I $$DL(Z,Z(2)) S IBSEL1=IBSEL1_Z_",",Y(Z)=$S(IBRPT="D":Z(1)_U_Z(2)_U_D(0),1:D(0)) + ...; + ...; - Date authorized. + ...I Y=2 D:Z(1) Q + ....S D(1)=$$FMDIFF^XLFDT(Z(2),Z(1)),Z=$S(IBTY="IN":6,1:2) + ....I $$DL(Z,Z(2)) D + .....S Z1=$S(IBPOL1:Z_"I",1:Z),IBSEL1=IBSEL1_Z1_",",Y(Z1)=$S(IBRPT="D":Z(1)_U_Z(2)_U_D(1),1:D(1)) + .....I Z1=Z D + ......S Z2=Z_"I",IBSEL1=IBSEL1_Z2_",",Y(Z2)=$S(IBRPT="D":Z(1)_U_Z(2)_U_D(1),1:D(1)) + ...; + ...; - Date activated. + ...I Y=3 D:Z(2) Q + ....S D(2)=$$FMDIFF^XLFDT(Z(2),Z(1)) I $$DL(9,Z(2)) S IBSEL1=IBSEL1_"9,",Y(9)=$S(IBRPT="D":Z(1)_U_Z(2)_U_D(2),1:D(2)) + ...; + ...; - Payment date. + ...I Y=4 D:Z(2) Q + ....S D(3)=$$FMDIFF^XLFDT(Z(2),Z(1)),D(6)=$$FMDIFF^XLFDT(Z(2),+X) + ....F Z=$S(IBTY="IN":7,1:3),10 I $$DL(Z,Z(2)) D + .....S Z1=$S(IBPOL1&(Z<10):Z_"I",1:Z),Z2=$S(Z<10:6,1:3) + .....S IBSEL1=IBSEL1_Z1_",",Y(Z1)=$S(IBRPT="D":$S(Z2=3:Z(1),1:+X)_U_Z(2)_U_D(Z2),1:D(Z2)) + .....I Z1=Z,Z<10 S Z3=Z_"I",IBSEL1=IBSEL1_Z3_",",Y(Z3)=$S(IBRPT="D":$S(Z2=3:Z(1),1:+X)_U_Z(2)_U_D(Z2),1:D(Z2)) + ...; + ...; - Date closed. + ...I Z(2) D + ....S D(4)=$$FMDIFF^XLFDT(Z(2),Z(1)),D(5)=$$FMDIFF^XLFDT(Z(2),+X) + ....F Z=$S(IBTY="IN":8,1:4),11 I $$DL(Z,Z(2)) D + .....S Z1=$S(IBPOL1&(Z<11):Z_"I",1:Z),Z2=$S(Z<11:5,1:4) + .....S IBSEL1=IBSEL1_Z1_",",Y(Z1)=$S(IBRPT="D":$S(Z2=4:Z(1),1:+X)_U_Z(2)_U_D(Z2),1:D(Z2)) + .....I Z1=Z,Z<11 S Z3=Z_"I",IBSEL1=IBSEL1_Z3_",",Y(Z3)=$S(IBRPT="D":$S(Z2=4:Z(1),1:+X)_U_Z(2)_U_D(Z2),1:D(Z2)) + ..; + ..; - Save data for detail or summary report(s). + ..F Y=1:1 S Z=$P(IBSEL1,",",Y) Q:'Z D + ...I IBRPT="D" D + ....S Y(Z)=$P(IBN0,U)_U_Y(Z)_U_$S(IBPOL1:"*",1:""),Y1(Z)=$G(Y1(Z))+1 + ....S ^TMP("IBJDB1",$J,IBDIV,IBTY,Z,$P(IBDFN,U)_"@@"_$P(IBDFN,U,9),Y1(Z))=Y(Z) + ...E S IBCT(IBDIV,IBTY,Z)=IBCT(IBDIV,IBTY,Z)+1,IBTL(IBDIV,IBTY,Z)=IBTL(IBDIV,IBTY,Z)+Y(Z) + ; + Q + ; +INIT(X) ; - Initialize summary accumulators/detail division nodes. + I IBRPT="D" S ^TMP("IBJDB1",$J,X)="" Q + F Y=1:1:4,9,10,11,"2I","3I","4I" S (IBCT(X,"OP",Y),IBTL(X,"OP",Y))=0 + F Y=5:1:11,"6I","7I","8I" S (IBCT(X,"IN",Y),IBTL(X,"IN",Y))=0 + Q + ; +AUTH(IBN) ; - Is this an authorized claim? + ; Input: IBN=Pointer to the AR in file #430 + ; Output: VAL=1^2^3^4^5, where: + ; 1=1-Authorized claim + ; 0-Not an authorized claim + ; 2=Date AR was authorized + ; 3=Date AR was activated + ; 4=AR first payment date + ; 5=Date AR was closed + ; + N IBPAY,IBT,IBT0,IBT1,VAL,X + S VAL=0 I '$G(IBN) G AUTHQ + ; + ; - Get date authorized (required). + S X=$P($G(^DGCR(399,IBN,"S")),U,10) G:'X AUTHQ S VAL="1^"_X + ; + ; - Get date activated, if available. + S X=$P($G(^PRCA(430,IBN,6)),U,21) I X S $P(VAL,U,3)=X\1 G FP + S X=$P($G(^PRCA(430,IBN,9)),U,3) I X S $P(VAL,U,3)=X\1 G FP + S X=$P($G(^PRCA(430,IBN,0)),U,10) I X S $P(VAL,U,3)=X\1 + ; +FP ; - Get first payment date, if available. + I '$P($G(^PRCA(430,IBN,7)),U,7) G CL ; No payments made. + S (IBPAY,IBT)=0 F S IBT=$O(^PRCA(433,"C",IBN,IBT)) Q:'IBT D Q:IBPAY + .S IBT0=$G(^PRCA(433,IBT,0)),IBT1=$G(^(1)) + .I $P(IBT0,U,4)'=2 Q ; Not complete. + .I $P(IBT1,U,2)'=2,$P(IBT1,U,2)'=34 Q ; Not a payment. + .S X=$S(+IBT1:+IBT1,1:$P(IBT1,U,9)\1),$P(VAL,U,4)=X,IBPAY=1 + ; +CL ; - Get date AR closed. + S X=$$CLO^PRCAFN(IBN) I X>0 S $P(VAL,U,5)=X + ; + ; - Is there a payment date AND a closed date for this claim? + I '$P(VAL,U,4),$P(VAL,U,5) S $P(VAL,U)=0 + ; +AUTHQ Q VAL + ; +DL(X,X1) ; - Is line item date valid for report? + ; Input: X=Line item number (or 0), X1=Line item date + ; Output: 1=valid, 0=invalid + ; *Requires pre-defined variables IBBDT, IBEDT, and IBSEL + S X2=0 I 'X1 G DLQ + I 'X S:X1'IBEDT) X2=1 G DLQ + I IBSEL[(","_X_","),X1'IBEDT S X2=1 +DLQ Q X2 diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJPS.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJPS.m index e101c1ce..a5f67575 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJPS.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJPS.m @@ -1,66 +1,66 @@ -IBJPS ;ALB/MAF,ARH - IBSP IB SITE PARAMETER SCREEN ;22-DEC-1995 - ;;2.0;INTEGRATED BILLING;**39,52,70,115,143,51,137,161,155,320,348,349,377**;21-MAR-94;Build 23 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -EN ; -- main entry point for IBJP IB SITE PARAMETERS, display IB site parameters - D EN^VALM("IBJP IB SITE PARAMETERS") - Q - ; -HDR ; -- header code - S VALMHDR(1)="Only authorized persons may edit this data." - Q - ; -INIT ; -- init variables and list array - K ^TMP("IBJPS",$J),^TMP("IBJPSAX",$J) - D BLD^IBJPS1 - Q - ; -HELP ; -- help code - S X="?" D DISP^XQORM1 W !! - Q - ; -EXIT ; -- exit code - K ^TMP("IBJPS",$J),^TMP("IBJPSAX",$J) - D CLEAR^VALM1 - Q - ; -NXEDIT ; -- IBJP IB SITE PARAMETER EDIT ACTION (EP): Select data set to edit, do edit - N VALMY,IBSELN,IBSET - D EN^VALM2($G(XQORNOD(0))) - I $D(VALMY) S IBSELN=0 F S IBSELN=$O(VALMY(IBSELN)) Q:'IBSELN D - . S IBSET=$P($G(^TMP("IBJPSAX",$J,IBSELN)),U,1) Q:'IBSET - . D EDIT(IBSET) - S VALMBCK="R" - Q - ; -EDIT(IBSET) ; edit IB Site Parameters - D FULL^VALM1 - I IBSET'="" S DR=$P($T(@IBSET),";;",2,999) - I DR'="" S DIE="^IBE(350.9,",DA=1 D ^DIE K DA,DR,DIE,DIC,X,Y - D INIT^IBJPS S VALMBCK="R" - Q - ; -1 ;;.09;.13;.14 -2 ;;1.2;.15;.11;.12;7.04 -3 ;;1.09;1.07;2.07 -4 ;;4.04;6.25;6.24 -5 ;;.02;1.14;1.25;1.08 -6 ;;1.23;1.16;1.22;1.19;1.15;1.17 -7 ;;1.33;1.32;1.31;1.27 -8 ;;1.29;1.3;1.18;1.28 -9 ;;1.01;1.02;1.05 -10 ;;2.12;2.1;2.02;2.03;2.04;2.05;2.06;2.01 -11 ;;2.08;2.09 -12 ;;9.01;9.02;9.03;9.11;9.12;9.13;9.14;9.15 -13 ;;10.02;10.03;10.04;10.05;D INIT^IBATFILE -14 ;;2.11;8.01;8.09;8.03;8.06;8.04;8.07;8.02;8.12T;8.11T -15 ;;50.01;50.02;50.05;50.06;50.03;50.04;50.07 - ; - ; -ADD(IBLN,LNG,ARR) ; output array of address in X, line length=LNG - N IBCNT,IBI,IBY,IBX,IBZ K ARR S IBCNT=1 - F IBI=2:1:4 S IBY=$P(IBLN,U,IBI) I IBY'="" D S ARR(IBCNT)=IBY - . S IBX=$G(ARR(IBCNT)) I IBI=4 S IBY=$P($G(^DIC(5,+IBY,0)),U,2)_" "_$P(IBLN,U,5) - . S IBZ=$S(IBX'="":IBX_", ",1:"")_IBY I $L(IBZ)'>LNG S IBY=IBZ Q - . S IBCNT=IBCNT+1 - Q +IBJPS ;ALB/MAF,ARH - IBSP IB SITE PARAMETER SCREEN ;22-DEC-1995 + ;;2.0;INTEGRATED BILLING;**39,52,70,115,143,51,137,161,155,320,348,349**;21-MAR-94;Build 46 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; +EN ; -- main entry point for IBJP IB SITE PARAMETERS, display IB site parameters + D EN^VALM("IBJP IB SITE PARAMETERS") + Q + ; +HDR ; -- header code + S VALMHDR(1)="Only authorized persons may edit this data." + Q + ; +INIT ; -- init variables and list array + K ^TMP("IBJPS",$J),^TMP("IBJPSAX",$J) + D BLD^IBJPS1 + Q + ; +HELP ; -- help code + S X="?" D DISP^XQORM1 W !! + Q + ; +EXIT ; -- exit code + K ^TMP("IBJPS",$J),^TMP("IBJPSAX",$J) + D CLEAR^VALM1 + Q + ; +NXEDIT ; -- IBJP IB SITE PARAMETER EDIT ACTION (EP): Select data set to edit, do edit + N VALMY,IBSELN,IBSET + D EN^VALM2($G(XQORNOD(0))) + I $D(VALMY) S IBSELN=0 F S IBSELN=$O(VALMY(IBSELN)) Q:'IBSELN D + . S IBSET=$P($G(^TMP("IBJPSAX",$J,IBSELN)),U,1) Q:'IBSET + . D EDIT(IBSET) + S VALMBCK="R" + Q + ; +EDIT(IBSET) ; edit IB Site Parameters + D FULL^VALM1 + I IBSET'="" S DR=$P($T(@IBSET),";;",2,999) + I DR'="" S DIE="^IBE(350.9,",DA=1 D ^DIE K DA,DR,DIE,DIC,X,Y + D INIT^IBJPS S VALMBCK="R" + Q + ; +1 ;;.09;.13;.14 +2 ;;1.2;.15;.11;.12;7.04 +3 ;;1.09;1.07;2.07 +4 ;;4.04;6.25;6.24 +5 ;;.02;1.14;1.25;1.08 +6 ;;1.23;1.16;1.22;1.19;1.15;1.17 +7 ;;1.33;1.32;1.31;1.27 +8 ;;1.29;1.3;1.18;1.28 +9 ;;1.01;1.02;1.05;1.04 +10 ;;2.12;2.1;2.02;2.03;2.04;2.05;2.06;2.01 +11 ;;2.08;2.09 +12 ;;9.01;9.02;9.03;9.11;9.12;9.13;9.14;9.15 +13 ;;10.02;10.03;10.04;10.05;D INIT^IBATFILE +14 ;;2.11;8.01;8.09;8.03;8.06;8.04;8.07;8.02;8.12T;8.11T +15 ;;50.01;50.02;50.05;50.06;50.03;50.04;50.07 + ; + ; +ADD(IBLN,LNG,ARR) ; output array of address in X, line length=LNG + N IBCNT,IBI,IBY,IBX,IBZ K ARR S IBCNT=1 + F IBI=2:1:4 S IBY=$P(IBLN,U,IBI) I IBY'="" D S ARR(IBCNT)=IBY + . S IBX=$G(ARR(IBCNT)) I IBI=4 S IBY=$P($G(^DIC(5,+IBY,0)),U,2)_" "_$P(IBLN,U,5) + . S IBZ=$S(IBX'="":IBX_", ",1:"")_IBY I $L(IBZ)'>LNG S IBY=IBZ Q + . S IBCNT=IBCNT+1 + Q diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJPS2.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJPS2.m index 2ec845d7..240aeb9f 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJPS2.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJPS2.m @@ -1,147 +1,150 @@ -IBJPS2 ;ALB/MAF,ARH - IBSP IB SITE PARAMETER BUILD (cont) ;22-DEC-1995 - ;;2.0;INTEGRATED BILLING;**39,52,115,143,51,137,161,155,320,348,349,377**;21-MAR-94;Build 23 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -BLD2 ; - continue build screen array for IB parameters - ; - N Z,Z0 - D RIGHT(1,1,1) ; - facility/med center (new line for each) - S IBLN=$$SET("Medical Center",$$EXSET^IBJU1($P(IBPD0,U,2),350.9,.02),IBLN,IBLR,IBSEL) - S IBLN=$$SET("MAS Service",$$EXSET^IBJU1($P(IBPD1,U,14),350.9,1.14),IBLN,IBLR,IBSEL) - ; - D LEFT(2) - S IBLN=$$SET("Default Division",$$EXSET^IBJU1($P(IBPD1,U,25),350.9,1.25),IBLN,IBLR,IBSEL) - S IBLN=$$SET("Billing Supervisor",$$EXSET^IBJU1($P(IBPD1,U,8),350.9,1.08),IBLN,IBLR,IBSEL) - ; - D RIGHT(1,1,1) - S IBLN=$$SET("Initiator Authorize",$$YN(+$P(IBPD1,U,23)),IBLN,IBLR,IBSEL) - S IBLN=$$SET("Ask HINQ in MCCR",$$YN(+$P(IBPD1,U,16)),IBLN,IBLR,IBSEL) - S IBLN=$$SET("Multiple Form Types",$$YN(+$P(IBPD1,U,22)),IBLN,IBLR,IBSEL) - ; - D LEFT(2) - S IBLN=$$SET("Xfer Proc to Sched",$$YN(+$P(IBPD1,U,19)),IBLN,IBLR,IBSEL) - S IBLN=$$SET("Use Non-PTF Codes",$$YN(+$P(IBPD1,U,15)),IBLN,IBLR,IBSEL) - S IBLN=$$SET("Use OP CPT screen",$$YN(+$P(IBPD1,U,17)),IBLN,IBLR,IBSEL) - ; - ; IB patch 349 for UB-04 claim form and parameters - D RIGHT(1,1,1) - S IBLN=$$SET("UB-04 Print IDs",$$EXSET^IBJU1($P(IBPD1,U,33),350.9,1.33),IBLN,IBLR,IBSEL) - S IBLN=$$SET("CMS-1500 Print IDs",$$EXSET^IBJU1($P(IBPD1,U,32),350.9,1.32),IBLN,IBLR,IBSEL) - ; - D LEFT(2) - S IBLN=$$SET("UB-04 Address Col",$P(IBPD1,U,31),IBLN,IBLR,IBSEL) - S IBLN=$$SET("CMS-1500 Addr Col",$P(IBPD1,U,27),IBLN,IBLR,IBSEL) - ; - D RIGHT(1,1,1) - S IBLN=$$SET("Default RX DX Cd",$$EXSET^IBJU1($P(IBPD1,U,29),350.9,1.29),IBLN,IBLR,IBSEL) - S IBLN=$$SET("Default RX CPT Cd",$$EXSET^IBJU1($P(IBPD1,U,30),350.9,1.30),IBLN,IBLR,IBSEL) - ; - D LEFT(2) - S IBLN=$$SET("Default ASC Rev Cd",$$EXSET^IBJU1($P(IBPD1,U,18),350.9,1.18),IBLN,IBLR,IBSEL) - S IBLN=$$SET("Default RX Rev Cd",$$EXSET^IBJU1($P(IBPD1,U,28),350.9,1.28),IBLN,IBLR,IBSEL) - ; - D RIGHT(1,1,1) - S IBLN=$$SET("Bill Signer Name","",IBLN,IBLR,IBSEL) - S IBLN=$$SET("Bill Signer Title","",IBLN,IBLR,IBSEL) - ; - D LEFT(2) - S IBLN=$$SET("Federal Tax #",$P(IBPD1,U,5),IBLN,IBLR,IBSEL) - ; - D RIGHT(3,1,1) ; - Remittance/Agent Cashier Address - S IBLN=$$SET("Billing Facility is Another Facility",$$EXPAND^IBTRE(350.9,2.12,+$P(IBPD2,U,12)),IBLN,IBLR,IBSEL) - S IBLN=$$SET("Billing Facility Name",$P(IBPD2,U,10),IBLN,IBLR,IBSEL) - D ADD^IBJPS(IBPD2,IBSW(3),.IBX) D K IBX - . S IBT="Remittance Address",IBX=0 F S IBX=$O(IBX(IBX)) Q:'IBX D - .. S IBLN=$$SET(IBT,IBX(IBX),IBLN,IBLR,IBSEL),IBT="" - S IBLN=$$SET("Phone",$P(IBPD2,U,6),IBLN,IBLR,IBSEL) - ; - D RIGHT(3,1,1) - S IBLN=$$SET("Inpt Health Summary",$$EXSET^IBJU1($P(IBPD2,U,8),350.9,2.08),IBLN,IBLR,IBSEL) - S IBLN=$$SET("Opt Health Summary",$$EXSET^IBJU1($P(IBPD2,U,9),350.9,2.09),IBLN,IBLR,IBSEL) - ; - D RIGHT(5,1,1) - S IBLN=$$SET("Rx Billing Port",$P(IBPD9,U),IBLN,IBLR,IBSEL) - S IBLN=$$SET("AWP Update Port",$P(IBPD9,U,2),IBLN,IBLR,IBSEL) - S IBLN=$$SET("TCP/IP Address",$P(IBPD9,U,3),IBLN,IBLR,IBSEL) - S IBLN=$$SET("Task UCI/VOL",$P(IBPD9,U,11),IBLN,IBLR,IBSEL) - S IBLN=$$SET("AWP Charge Set",$$EXSET^IBJU1($P(IBPD9,U,12),350.9,9.12),IBLN,IBLR,IBSEL) - S IBLN=$$SET("Prescriber ID",$P(IBPD9,U,13),IBLN,IBLR,IBSEL) - S IBLN=$$SET("DEA vs Presc.ID",$$YN($P(IBPD9,U,14)),IBLN,IBLR,IBSEL) - S IBLN=$$SET("Calc comp code",$$YN($P(IBPD9,U,15)),IBLN,IBLR,IBSEL) - ; - D LEFT(6) - S IBLN=$$SET("Prim Billing Task",$P(IBPD9,U,4),IBLN,IBLR,IBSEL) - S IBLN=$$SET("Sec Billing Task",$P(IBPD9,U,5),IBLN,IBLR,IBSEL) - S IBLN=$$SET("Prim AWP Upd Task",$P(IBPD9,U,6),IBLN,IBLR,IBSEL) - S IBLN=$$SET("Sec AWP Upd Task",$P(IBPD9,U,7),IBLN,IBLR,IBSEL) - S IBLN=$$SET("Task Started",$$DAT1^IBOUTL($P(IBPD9,U,8),1),IBLN,IBLR,IBSEL) - S IBLN=$$SET("Task Last Ran",$$DAT1^IBOUTL($P(IBPD9,U,9),1),IBLN,IBLR,IBSEL) - S IBLN=$$SET("Shutdown Tasks?",$$YN($P(IBPD9,U,10)),IBLN,IBLR,IBSEL) - ; - ; transfer pricing - D RIGHT(1,1,1) - S IBLN=$$SET("Inpatient TP Active ",$$YN(+$P(IBPD10,U,2)),IBLN,IBLR,IBSEL) - S IBLN=$$SET("Outpatient TP Active",$$YN(+$P(IBPD10,U,3)),IBLN,IBLR,IBSEL) - S IBLN=$$SET("Pharmacy TP Active ",$$YN(+$P(IBPD10,U,4)),IBLN,IBLR,IBSEL) - S IBLN=$$SET("Prosthetic TP Active",$$YN(+$P(IBPD10,U,5)),IBLN,IBLR,IBSEL) - ; - ; EDI/MRA parameters - D RIGHT(7,1,1) - N IBZ S IBZ=$P(IBPD8,U,3) - S IBLN=$$SET(" EDI/MRA Activated",$$EXSET^IBJU1(+$P(IBPD8,U,10),350.9,8.1),IBLN,IBLR,IBSEL) - S IBLN=$$SET(" EDI Contact Phone",$P(IBPD2,U,11),IBLN,IBLR,IBSEL) - S IBLN=$$SET(" EDI 837 Live Transmit Queue",$P(IBPD8,U),IBLN,IBLR,IBSEL) - S IBLN=$$SET(" EDI 837 Test Transmit Queue",$P(IBPD8,U,9),IBLN,IBLR,IBSEL) - S IBLN=$$SET(" Auto-Txmt Bill Frequency",$S(IBZ:"Every"_$S(IBZ>1:" "_$P(IBPD8,U,3),1:""),1:"")_$S(IBZ:" Day"_$S(IBZ=1:"",1:"s"),1:"Never Run"),IBLN,IBLR,IBSEL) - S IBLN=$$SET(" Hours To Auto-Transmit",$P(IBPD8,U,6),IBLN,IBLR,IBSEL) - S IBLN=$$SET(" Max # Bills Per Batch",$P(IBPD8,U,4),IBLN,IBLR,IBSEL) - S IBLN=$$SET(" Only Allow 1 Ins Co/Claim Batch?",$$EXPAND^IBTRE(350.9,8.07,+$P(IBPD8,U,7)),IBLN,IBLR,IBSEL) - S IBLN=$$SET(" Last Auto-Txmt Run Date",$$DATE^IBJU1($P(IBPD8,U,5)),IBLN,IBLR,IBSEL) - S IBLN=$$SET(" Days To Wait To Purge Msgs",$P(IBPD8,U,2),IBLN,IBLR,IBSEL) - S IBLN=$$SET(" Allow MRA Processing?",$$YN(+$P(IBPD8,U,12)),IBLN,IBLR,IBSEL) - S IBLN=$$SET(" Enable Automatic MRA Processing?",$$YN(+$P(IBPD8,U,11)),IBLN,IBLR,IBSEL) - ; - ; Ingenix ClaimsManager Information - D RIGHT(9,1,1) - S IBLN=$$SET("Are we using ClaimsManager?",$$YN(+$P(IBPD50,U,1)),IBLN,IBLR,IBSEL) - S IBLN=$$SET("Is ClaimsManager working OK?",$$YN(+$P(IBPD50,U,2)),IBLN,IBLR,IBSEL) - S IBLN=$$SET("ClaimsManager TCP/IP Address",$P(IBPD50,U,5),IBLN,IBLR,IBSEL) - S IBCISOCK=$O(^IBE(350.9,1,50.06,"B","")) - S IBLN=$$SET("ClaimsManager TCP/IP Ports",IBCISOCK,IBLN,IBLR,IBSEL) - F S IBCISOCK=$O(^IBE(350.9,1,50.06,"B",IBCISOCK)) Q:IBCISOCK="" D - . S IBLN=$$SET("",IBCISOCK,IBLN,IBLR,IBSEL) - . Q - S IBLN=$$SET("General Error MailGroup",$$EXSET^IBJU1($P(IBPD50,U,3),350.9,50.03),IBLN,IBLR,IBSEL) - S IBLN=$$SET("Communication Error MailGroup",$$EXSET^IBJU1($P(IBPD50,U,4),350.9,50.04),IBLN,IBLR,IBSEL) - S IBCIMFLG=$$EXTERNAL^DILFD(350.9,50.07,"",$P(IBPD50,U,7)) - I IBCIMFLG="" S IBCIMFLG="PRIORITY" - S IBLN=$$SET("MailMan Messages",IBCIMFLG,IBLN,IBLR,IBSEL) - ; - Q - ; -SET(TTL,DATA,LN,LR,SEL,HDR) ; - N IBY,IBX,IBC S IBC=": " I TTL="" S IBC=" " - S IBY=TTL_$J("",(IBTW(LR)-$L(TTL)-2))_$S('$G(HDR):IBC_DATA,1:""),IBX=$G(^TMP("IBJPS",$J,LN,0)) - S IBX=$$SETSTR^VALM1(IBY,IBX,IBTC(LR),(IBTW(LR)+IBSW(LR))) - D SET1(IBX,LN,SEL) - S LN=LN+1 - Q LN - ; -SET1(STR,LN,SEL,HI) ; set up TMP array with screen data - S ^TMP("IBJPS",$J,LN,0)=STR - S ^TMP("IBJPS",$J,"IDX",LN,SEL)="" - S ^TMP("IBJPSAX",$J,SEL)=SEL - I $G(HI)'="" D CNTRL^VALM10(LN,1,4,IOINHI,IOINORM) - ;I $G(RV) D CNTRL^VALM10(LN,6,19,IOUON,IOUOFF) - Q - ; -YN(X) Q $S(+X:"YES",1:"NO") - ; -RIGHT(LR,SEL,BL) ; - reset control variables for right side of screen - S IBLN=$S(IBLN>IBGRPE:IBLN,1:IBGRPE) I $G(BL) S IBLN=$$SET("","",IBLN,IBLR,IBSEL) - S IBLR=$G(LR),IBGRPB=IBLN I +$G(SEL) S IBSEL=IBSEL+1 D SET1("["_IBSEL_"]",IBLN,IBSEL,1) - Q - ; -LEFT(LR) ; - reset control variables for left side of screen - S IBLR=$G(LR),IBGRPE=IBLN,IBLN=IBGRPB - Q +IBJPS2 ;ALB/MAF,ARH - IBSP IB SITE PARAMETER BUILD (cont) ;22-DEC-1995 + ;;2.0;INTEGRATED BILLING;**39,52,115,143,51,137,161,155,320,348,349**;21-MAR-94;Build 46 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; +BLD2 ; - continue build screen array for IB parameters + ; + N Z,Z0 + D RIGHT(1,1,1) ; - facility/med center (new line for each) + S IBLN=$$SET("Medical Center",$$EXSET^IBJU1($P(IBPD0,U,2),350.9,.02),IBLN,IBLR,IBSEL) + S IBLN=$$SET("MAS Service",$$EXSET^IBJU1($P(IBPD1,U,14),350.9,1.14),IBLN,IBLR,IBSEL) + ; + D LEFT(2) + S IBLN=$$SET("Default Division",$$EXSET^IBJU1($P(IBPD1,U,25),350.9,1.25),IBLN,IBLR,IBSEL) + S IBLN=$$SET("Billing Supervisor",$$EXSET^IBJU1($P(IBPD1,U,8),350.9,1.08),IBLN,IBLR,IBSEL) + ; + D RIGHT(1,1,1) + S IBLN=$$SET("Initiator Authorize",$$YN(+$P(IBPD1,U,23)),IBLN,IBLR,IBSEL) + S IBLN=$$SET("Ask HINQ in MCCR",$$YN(+$P(IBPD1,U,16)),IBLN,IBLR,IBSEL) + S IBLN=$$SET("Multiple Form Types",$$YN(+$P(IBPD1,U,22)),IBLN,IBLR,IBSEL) + ; + D LEFT(2) + S IBLN=$$SET("Xfer Proc to Sched",$$YN(+$P(IBPD1,U,19)),IBLN,IBLR,IBSEL) + S IBLN=$$SET("Use Non-PTF Codes",$$YN(+$P(IBPD1,U,15)),IBLN,IBLR,IBSEL) + S IBLN=$$SET("Use OP CPT screen",$$YN(+$P(IBPD1,U,17)),IBLN,IBLR,IBSEL) + ; + ; IB patch 349 for UB-04 claim form and parameters + D RIGHT(1,1,1) + S IBLN=$$SET("UB-04 Print IDs",$$EXSET^IBJU1($P(IBPD1,U,33),350.9,1.33),IBLN,IBLR,IBSEL) + S IBLN=$$SET("CMS-1500 Print IDs",$$EXSET^IBJU1($P(IBPD1,U,32),350.9,1.32),IBLN,IBLR,IBSEL) + ; + D LEFT(2) + S IBLN=$$SET("UB-04 Address Col",$P(IBPD1,U,31),IBLN,IBLR,IBSEL) + S IBLN=$$SET("CMS-1500 Addr Col",$P(IBPD1,U,27),IBLN,IBLR,IBSEL) + ; + D RIGHT(1,1,1) + S IBLN=$$SET("Default RX DX Cd",$$EXSET^IBJU1($P(IBPD1,U,29),350.9,1.29),IBLN,IBLR,IBSEL) + S IBLN=$$SET("Default RX CPT Cd",$$EXSET^IBJU1($P(IBPD1,U,30),350.9,1.30),IBLN,IBLR,IBSEL) + ; + D LEFT(2) + S IBLN=$$SET("Default ASC Rev Cd",$$EXSET^IBJU1($P(IBPD1,U,18),350.9,1.18),IBLN,IBLR,IBSEL) + S IBLN=$$SET("Default RX Rev Cd",$$EXSET^IBJU1($P(IBPD1,U,28),350.9,1.28),IBLN,IBLR,IBSEL) + ; + D RIGHT(1,1,1) + S IBLN=$$SET("Bill Signer Name","",IBLN,IBLR,IBSEL) + S IBLN=$$SET("Bill Signer Title","",IBLN,IBLR,IBSEL) + ; + D LEFT(2) + S IBLN=$$SET("Federal Tax #",$P(IBPD1,U,5),IBLN,IBLR,IBSEL) + ; + D RIGHT(3,"","") + S IBLN=$$SET("Remark on Each Bill",$P(IBPD1,U,4),IBLN,IBLR,IBSEL) + ; + D RIGHT(3,1,1) ; - Remittance/Agent Cashier Address + S IBLN=$$SET("Billing Facility is Another Facility",$$EXPAND^IBTRE(350.9,2.12,+$P(IBPD2,U,12)),IBLN,IBLR,IBSEL) + S IBLN=$$SET("Billing Facility Name",$P(IBPD2,U,10),IBLN,IBLR,IBSEL) + D ADD^IBJPS(IBPD2,IBSW(3),.IBX) D K IBX + . S IBT="Remittance Address",IBX=0 F S IBX=$O(IBX(IBX)) Q:'IBX D + .. S IBLN=$$SET(IBT,IBX(IBX),IBLN,IBLR,IBSEL),IBT="" + S IBLN=$$SET("Phone",$P(IBPD2,U,6),IBLN,IBLR,IBSEL) + ; + D RIGHT(3,1,1) + S IBLN=$$SET("Inpt Health Summary",$$EXSET^IBJU1($P(IBPD2,U,8),350.9,2.08),IBLN,IBLR,IBSEL) + S IBLN=$$SET("Opt Health Summary",$$EXSET^IBJU1($P(IBPD2,U,9),350.9,2.09),IBLN,IBLR,IBSEL) + ; + D RIGHT(5,1,1) + S IBLN=$$SET("Rx Billing Port",$P(IBPD9,U),IBLN,IBLR,IBSEL) + S IBLN=$$SET("AWP Update Port",$P(IBPD9,U,2),IBLN,IBLR,IBSEL) + S IBLN=$$SET("TCP/IP Address",$P(IBPD9,U,3),IBLN,IBLR,IBSEL) + S IBLN=$$SET("Task UCI/VOL",$P(IBPD9,U,11),IBLN,IBLR,IBSEL) + S IBLN=$$SET("AWP Charge Set",$$EXSET^IBJU1($P(IBPD9,U,12),350.9,9.12),IBLN,IBLR,IBSEL) + S IBLN=$$SET("Prescriber ID",$P(IBPD9,U,13),IBLN,IBLR,IBSEL) + S IBLN=$$SET("DEA vs Presc.ID",$$YN($P(IBPD9,U,14)),IBLN,IBLR,IBSEL) + S IBLN=$$SET("Calc comp code",$$YN($P(IBPD9,U,15)),IBLN,IBLR,IBSEL) + ; + D LEFT(6) + S IBLN=$$SET("Prim Billing Task",$P(IBPD9,U,4),IBLN,IBLR,IBSEL) + S IBLN=$$SET("Sec Billing Task",$P(IBPD9,U,5),IBLN,IBLR,IBSEL) + S IBLN=$$SET("Prim AWP Upd Task",$P(IBPD9,U,6),IBLN,IBLR,IBSEL) + S IBLN=$$SET("Sec AWP Upd Task",$P(IBPD9,U,7),IBLN,IBLR,IBSEL) + S IBLN=$$SET("Task Started",$$DAT1^IBOUTL($P(IBPD9,U,8),1),IBLN,IBLR,IBSEL) + S IBLN=$$SET("Task Last Ran",$$DAT1^IBOUTL($P(IBPD9,U,9),1),IBLN,IBLR,IBSEL) + S IBLN=$$SET("Shutdown Tasks?",$$YN($P(IBPD9,U,10)),IBLN,IBLR,IBSEL) + ; + ; transfer pricing + D RIGHT(1,1,1) + S IBLN=$$SET("Inpatient TP Active ",$$YN(+$P(IBPD10,U,2)),IBLN,IBLR,IBSEL) + S IBLN=$$SET("Outpatient TP Active",$$YN(+$P(IBPD10,U,3)),IBLN,IBLR,IBSEL) + S IBLN=$$SET("Pharmacy TP Active ",$$YN(+$P(IBPD10,U,4)),IBLN,IBLR,IBSEL) + S IBLN=$$SET("Prosthetic TP Active",$$YN(+$P(IBPD10,U,5)),IBLN,IBLR,IBSEL) + ; + ; EDI/MRA parameters + D RIGHT(7,1,1) + N IBZ S IBZ=$P(IBPD8,U,3) + S IBLN=$$SET(" EDI/MRA Activated",$$EXSET^IBJU1(+$P(IBPD8,U,10),350.9,8.1),IBLN,IBLR,IBSEL) + S IBLN=$$SET(" EDI Contact Phone",$P(IBPD2,U,11),IBLN,IBLR,IBSEL) + S IBLN=$$SET(" EDI 837 Live Transmit Queue",$P(IBPD8,U),IBLN,IBLR,IBSEL) + S IBLN=$$SET(" EDI 837 Test Transmit Queue",$P(IBPD8,U,9),IBLN,IBLR,IBSEL) + S IBLN=$$SET(" Auto-Txmt Bill Frequency",$S(IBZ:"Every"_$S(IBZ>1:" "_$P(IBPD8,U,3),1:""),1:"")_$S(IBZ:" Day"_$S(IBZ=1:"",1:"s"),1:"Never Run"),IBLN,IBLR,IBSEL) + S IBLN=$$SET(" Hours To Auto-Transmit",$P(IBPD8,U,6),IBLN,IBLR,IBSEL) + S IBLN=$$SET(" Max # Bills Per Batch",$P(IBPD8,U,4),IBLN,IBLR,IBSEL) + S IBLN=$$SET(" Only Allow 1 Ins Co/Claim Batch?",$$EXPAND^IBTRE(350.9,8.07,+$P(IBPD8,U,7)),IBLN,IBLR,IBSEL) + S IBLN=$$SET(" Last Auto-Txmt Run Date",$$DATE^IBJU1($P(IBPD8,U,5)),IBLN,IBLR,IBSEL) + S IBLN=$$SET(" Days To Wait To Purge Msgs",$P(IBPD8,U,2),IBLN,IBLR,IBSEL) + S IBLN=$$SET(" Allow MRA Processing?",$$YN(+$P(IBPD8,U,12)),IBLN,IBLR,IBSEL) + S IBLN=$$SET(" Enable Automatic MRA Processing?",$$YN(+$P(IBPD8,U,11)),IBLN,IBLR,IBSEL) + ; + ; Ingenix ClaimsManager Information + D RIGHT(9,1,1) + S IBLN=$$SET("Are we using ClaimsManager?",$$YN(+$P(IBPD50,U,1)),IBLN,IBLR,IBSEL) + S IBLN=$$SET("Is ClaimsManager working OK?",$$YN(+$P(IBPD50,U,2)),IBLN,IBLR,IBSEL) + S IBLN=$$SET("ClaimsManager TCP/IP Address",$P(IBPD50,U,5),IBLN,IBLR,IBSEL) + S IBCISOCK=$O(^IBE(350.9,1,50.06,"B","")) + S IBLN=$$SET("ClaimsManager TCP/IP Ports",IBCISOCK,IBLN,IBLR,IBSEL) + F S IBCISOCK=$O(^IBE(350.9,1,50.06,"B",IBCISOCK)) Q:IBCISOCK="" D + . S IBLN=$$SET("",IBCISOCK,IBLN,IBLR,IBSEL) + . Q + S IBLN=$$SET("General Error MailGroup",$$EXSET^IBJU1($P(IBPD50,U,3),350.9,50.03),IBLN,IBLR,IBSEL) + S IBLN=$$SET("Communication Error MailGroup",$$EXSET^IBJU1($P(IBPD50,U,4),350.9,50.04),IBLN,IBLR,IBSEL) + S IBCIMFLG=$$EXTERNAL^DILFD(350.9,50.07,"",$P(IBPD50,U,7)) + I IBCIMFLG="" S IBCIMFLG="PRIORITY" + S IBLN=$$SET("MailMan Messages",IBCIMFLG,IBLN,IBLR,IBSEL) + ; + Q + ; +SET(TTL,DATA,LN,LR,SEL,HDR) ; + N IBY,IBX,IBC S IBC=": " I TTL="" S IBC=" " + S IBY=TTL_$J("",(IBTW(LR)-$L(TTL)-2))_$S('$G(HDR):IBC_DATA,1:""),IBX=$G(^TMP("IBJPS",$J,LN,0)) + S IBX=$$SETSTR^VALM1(IBY,IBX,IBTC(LR),(IBTW(LR)+IBSW(LR))) + D SET1(IBX,LN,SEL) + S LN=LN+1 + Q LN + ; +SET1(STR,LN,SEL,HI) ; set up TMP array with screen data + S ^TMP("IBJPS",$J,LN,0)=STR + S ^TMP("IBJPS",$J,"IDX",LN,SEL)="" + S ^TMP("IBJPSAX",$J,SEL)=SEL + I $G(HI)'="" D CNTRL^VALM10(LN,1,4,IOINHI,IOINORM) + ;I $G(RV) D CNTRL^VALM10(LN,6,19,IOUON,IOUOFF) + Q + ; +YN(X) Q $S(+X:"YES",1:"NO") + ; +RIGHT(LR,SEL,BL) ; - reset control variables for right side of screen + S IBLN=$S(IBLN>IBGRPE:IBLN,1:IBGRPE) I $G(BL) S IBLN=$$SET("","",IBLN,IBLR,IBSEL) + S IBLR=$G(LR),IBGRPB=IBLN I +$G(SEL) S IBSEL=IBSEL+1 D SET1("["_IBSEL_"]",IBLN,IBSEL,1) + Q + ; +LEFT(LR) ; - reset control variables for left side of screen + S IBLR=$G(LR),IBGRPE=IBLN,IBLN=IBGRPB + Q diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTA1.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTA1.m index 76b94c11..364f0bdc 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTA1.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTA1.m @@ -1,97 +1,86 @@ -IBJTA1 ;ALB/ARH - TPI ACTIONS ;2/14/95 - ;;2.0;INTEGRATED BILLING;**39,137,377**;21-MAR-94;Build 23 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -CP ; -- IBJT CHANGE PATIENT action: change patient, only available on AL screen - ; user selects new patient, then Active Bills screen rebuilt with that patients active bills - N VALMQUIT,IBDFN - D FULL^VALM1 - S IBDFN=DFN S DFN=+$$PAT^IBJTU2 I 'DFN S DFN=IBDFN - K ^TMP("IBJTLA",$J),^TMP("IBJTLAX",$J) - D BLDA^IBJTLA1,HDR^IBJTLA - S VALMBCK="R",VALMBG=1 -CPQ Q - ; -CB ; -- IBJT CHANGE BILL action: change bill, only available on CI screen - ; user enters new bill number then Claim Info screen rebuilt/redisplayed for that bill - ; if option entered through Active List screen then only allows bills for current patient - N VALMQUIT,IBIFN1,IBDFN1 - D FULL^VALM1 - S IBDFN1=DFN,IBIFN1=IBIFN - I $D(^TMP("IBJTLA",$J)) S DIC("S")="I $P(^(0),U,2)="_DFN - S IBIFN=+$$BILL^IBJTU2 I 'IBIFN S IBIFN=IBIFN1 - S DFN=$P(^DGCR(399,+IBIFN,0),U,2) - D CLEAN^VALM10 K IBXSAVE,IBXDATA D BLD^IBJTCA1,HDR^IBJTCA - S VALMBCK="R",VALMBG=1 -CBQ Q - ; -CDI ; -- IBJT CHANGE DATES INACTIVE action: Change Date range for Inactive screen - ; user enters end date for search for inactive bills for a patient, Inactive Bills screen then rebuilt with - ; inactive bills for the patient and new date range, IBEND passed to screen build - ; if IBBEG is defined the day before is used as the default end date, otherwise, today - ; this way the defaults will work backwards until end of bills, then restarts with today - D FULL^VALM1 - S DIR("?",1)="Enter most recent date to include in list." - S DIR("?")="A search for inactive bills for this patient will begin on the date entered and go back at least 6 months into the past. If the patient has few bills then the search may span more than six months." - S DIR("B")=$S(+$G(IBBEG):$$DATE^IBJU1($$FMADD^XLFDT(IBBEG,-1)),1:"TODAY") - S DIR(0)="DO^::EX",DIR("A")="End Date" - D ^DIR K DIR I 'Y!($D(DIRUT))!(Y=$G(IBEND)) S VALMSG="Date range was not changed." G CDIQ - K ^TMP("IBJTLB",$J),^TMP("IBJTLBX",$J) - S IBEND=Y D BLDA^IBJTLB1,HDR^IBJTLB -CDIQ S VALMBCK="R",VALMBG=1 - K VALMB,VALMBEG,VALMEND,DIRUT - Q - ; -ARCA ; -- IBJT AR COMMENT ADD action: add a comment transaction to the AR account, IBIFN required - ; IBARCOMM set to indicate AR Profile screen needs to be rebuilt when it is reentered - ; will cause the AR screen to be rebuilt including the new information if the AR screen is already open - N AUTHDT,MRADT,STATUS,VALMQUIT,DIR - D FULL^VALM1 - S STATUS=$P($G(^DGCR(399,IBIFN,0)),U,13) - S AUTHDT=$P($G(^DGCR(399,IBIFN,"S")),U,10) - S MRADT=$P($G(^DGCR(399,IBIFN,"S")),U,7) - ; if claim status is "NOT REVIEWED" or claim status is "CANCELLED" with neither MRA request date - ; nor Authorization date present, display an error and bail out. - I STATUS=1!(STATUS=7&(MRADT="")&(AUTHDT="")) D G ARCAQ - .S DIR(0)="EA",DIR("A",1)="A comment can not be added for an incomplete or cancelled while incomplete claim.",DIR("A")="Press RETURN to continue: " D ^DIR K DIR - ; if claim status is "REQUEST MRA" or claim status is "CANCELLED" with MRA request date present, - ; but no Authorization date, enter MRA comments. - I STATUS=2!(STATUS=7&(MRADT'="")&(AUTHDT="")) D:$G(IBIFN) CMNT^IBCECOB6 G ARCAR - ; otherwise, enter AR comments. - D ADJUST^RCJIBFN3(IBIFN) - I $D(^TMP("IBJTTA",$J)) S IBARCOMM=1 - K ^TMP("IBJTTC",$J) -ARCAR ; rebuild comments screen - D BLD^IBJTTC,HDR^IBJTTC -ARCAQ S VALMBCK="R",VALMBG=1 - Q - ; -HS ; -- IBJT HS HEALTH SUMMARY action: health summary (inpt (350.9,2.08), outpt (350.9,2.09)) - ; if a Health Summary has been defined for the type of care (Inpt/Outpt) it is printed to the screen - ; type of care is taken from the current bill if there is one otherwise the user is asked - ; requires HS 2.5 or greater, if 2.7 is available then a date range can be used - ; if date range used it is taken from the current bill if available otherwise askes user - N X,Y,IBX,IBHS,DIR,DIRUT,IBIOPT,IBDT1,IBDT2,IBHSVER - S (IBIOPT,IBHS)=0,IBHSVER=$$VERSION^XPDUTL("HEALTH SUMMARY") - I IBHSVER<2.5 S VALMSG="Health Summary package not available." G HSQ - D FULL^VALM1 - I +$G(IBIFN) D I 'IBIOPT G HSQ - . S IBX=$G(^DGCR(399,+IBIFN,0)) I '$G(DFN) S DFN=$P(IBX,U,2) I 'DFN Q - . S IBIOPT=$S($P(IBX,U,5)<1:0,$P(IBX,U,5)<3:1,1:2) - . S IBDT1=$G(^DGCR(399,+IBIFN,"U")),IBDT2=$P(IBDT1,U,2),IBDT1=+IBDT1 - ; - I '$G(IBIFN) D I 'IBIOPT G HSQ - . S DIR(0)="SOB^I:Inpatient;O:Outpatient",DIR("A")="Inpatient or Outpatient Health Summary?" D ^DIR K DIR - . S IBIOPT=$S(Y="I":1,Y="O":2,1:0) Q:'IBIOPT - . ; - . Q:IBHSVER<2.7 - . W !!,"Enter the date range the Health Summary should cover." - . S IBDT1=$$DR^IBJTU2($$FMADD^XLFDT(DT,-365),DT),IBDT2=$P(IBDT1,U,2),IBDT1=+IBDT1 - ; - S IBX=$G(^IBE(350.9,1,2)),IBHS=$S(IBIOPT=1:$P(IBX,U,8),1:$P(IBX,U,9)) - ; - I 'IBHS S VALMSG="No Health Summary Type chosen for "_$S(IBIOPT=1:"In",1:"Out")_"patient." G HSQ - I IBHSVER<2.7 D ENX^GMTSDVR(DFN,IBHS) G HSQ - D ENX^GMTSDVR(DFN,IBHS,IBDT1,IBDT2) -HSQ S VALMBCK="R" - Q +IBJTA1 ;ALB/ARH - TPI ACTIONS ;2/14/95 + ;;2.0;INTEGRATED BILLING;**39,137**;21-MAR-94 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; +CP ; -- IBJT CHANGE PATIENT action: change patient, only available on AL screen + ; user selects new patient, then Active Bills screen rebuilt with that patients active bills + N VALMQUIT,IBDFN + D FULL^VALM1 + S IBDFN=DFN S DFN=+$$PAT^IBJTU2 I 'DFN S DFN=IBDFN + K ^TMP("IBJTLA",$J),^TMP("IBJTLAX",$J) + D BLDA^IBJTLA1,HDR^IBJTLA + S VALMBCK="R",VALMBG=1 +CPQ Q + ; +CB ; -- IBJT CHANGE BILL action: change bill, only available on CI screen + ; user enters new bill number then Claim Info screen rebuilt/redisplayed for that bill + ; if option entered through Active List screen then only allows bills for current patient + N VALMQUIT,IBIFN1,IBDFN1 + D FULL^VALM1 + S IBDFN1=DFN,IBIFN1=IBIFN + I $D(^TMP("IBJTLA",$J)) S DIC("S")="I $P(^(0),U,2)="_DFN + S IBIFN=+$$BILL^IBJTU2 I 'IBIFN S IBIFN=IBIFN1 + S DFN=$P(^DGCR(399,+IBIFN,0),U,2) + D CLEAN^VALM10 K IBXSAVE,IBXDATA D BLD^IBJTCA1,HDR^IBJTCA + S VALMBCK="R",VALMBG=1 +CBQ Q + ; +CDI ; -- IBJT CHANGE DATES INACTIVE action: Change Date range for Inactive screen + ; user enters end date for search for inactive bills for a patient, Inactive Bills screen then rebuilt with + ; inactive bills for the patient and new date range, IBEND passed to screen build + ; if IBBEG is defined the day before is used as the default end date, otherwise, today + ; this way the defaults will work backwards until end of bills, then restarts with today + D FULL^VALM1 + S DIR("?",1)="Enter most recent date to include in list." + S DIR("?")="A search for inactive bills for this patient will begin on the date entered and go back at least 6 months into the past. If the patient has few bills then the search may span more than six months." + S DIR("B")=$S(+$G(IBBEG):$$DATE^IBJU1($$FMADD^XLFDT(IBBEG,-1)),1:"TODAY") + S DIR(0)="DO^::EX",DIR("A")="End Date" + D ^DIR K DIR I 'Y!($D(DIRUT))!(Y=$G(IBEND)) S VALMSG="Date range was not changed." G CDIQ + K ^TMP("IBJTLB",$J),^TMP("IBJTLBX",$J) + S IBEND=Y D BLDA^IBJTLB1,HDR^IBJTLB +CDIQ S VALMBCK="R",VALMBG=1 + K VALMB,VALMBEG,VALMEND,DIRUT + Q + ; +ARCA ; -- IBJT AR COMMENT ADD action: add a comment transaction to the AR account, IBIFN required + ; IBARCOMM set to indicate AR Profile screen needs to be rebuilt when it is reentered + ; will cause the AR screen to be rebuilt including the new information if the AR screen is already open + N VALMQUIT,DIR + D FULL^VALM1 + I $P($G(^DGCR(399,IBIFN,0)),U,13)=2 D G ARCAQ + . S DIR(0)="EA",DIR("A",1)="A/R comments cannot be added for a bill awaiting an MRA request",DIR("A")="Press RETURN to continue: " D ^DIR K DIR + D ADJUST^RCJIBFN3(IBIFN) + I $D(^TMP("IBJTTA",$J)) S IBARCOMM=1 + K ^TMP("IBJTTC",$J) D BLD^IBJTTC,HDR^IBJTTC +ARCAQ S VALMBCK="R",VALMBG=1 + Q + ; +HS ; -- IBJT HS HEALTH SUMMARY action: health summary (inpt (350.9,2.08), outpt (350.9,2.09)) + ; if a Health Summary has been defined for the type of care (Inpt/Outpt) it is printed to the screen + ; type of care is taken from the current bill if there is one otherwise the user is asked + ; requires HS 2.5 or greater, if 2.7 is available then a date range can be used + ; if date range used it is taken from the current bill if available otherwise askes user + N X,Y,IBX,IBHS,DIR,DIRUT,IBIOPT,IBDT1,IBDT2,IBHSVER + S (IBIOPT,IBHS)=0,IBHSVER=$$VERSION^XPDUTL("HEALTH SUMMARY") + I IBHSVER<2.5 S VALMSG="Health Summary package not available." G HSQ + D FULL^VALM1 + I +$G(IBIFN) D I 'IBIOPT G HSQ + . S IBX=$G(^DGCR(399,+IBIFN,0)) I '$G(DFN) S DFN=$P(IBX,U,2) I 'DFN Q + . S IBIOPT=$S($P(IBX,U,5)<1:0,$P(IBX,U,5)<3:1,1:2) + . S IBDT1=$G(^DGCR(399,+IBIFN,"U")),IBDT2=$P(IBDT1,U,2),IBDT1=+IBDT1 + ; + I '$G(IBIFN) D I 'IBIOPT G HSQ + . S DIR(0)="SOB^I:Inpatient;O:Outpatient",DIR("A")="Inpatient or Outpatient Health Summary?" D ^DIR K DIR + . S IBIOPT=$S(Y="I":1,Y="O":2,1:0) Q:'IBIOPT + . ; + . Q:IBHSVER<2.7 + . W !!,"Enter the date range the Health Summary should cover." + . S IBDT1=$$DR^IBJTU2($$FMADD^XLFDT(DT,-365),DT),IBDT2=$P(IBDT1,U,2),IBDT1=+IBDT1 + ; + S IBX=$G(^IBE(350.9,1,2)),IBHS=$S(IBIOPT=1:$P(IBX,U,8),1:$P(IBX,U,9)) + ; + I 'IBHS S VALMSG="No Health Summary Type chosen for "_$S(IBIOPT=1:"In",1:"Out")_"patient." G HSQ + I IBHSVER<2.7 D ENX^GMTSDVR(DFN,IBHS) G HSQ + D ENX^GMTSDVR(DFN,IBHS,IBDT1,IBDT2) +HSQ S VALMBCK="R" + Q diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTBA.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTBA.m index 7a7f69e3..634ccb80 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTBA.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTBA.m @@ -1,167 +1,167 @@ -IBJTBA ;ALB/ARH - TPI BILL CHARGE INFO SCREEN ;01-MAR-1995 - ;;2.0;INTEGRATED BILLING;**39,80,51,137,135,309,349,389**;21-MAR-94;Build 6 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -EN ; -- main entry point for IBJ TP BILL CHARGES - D EN^VALM("IBJT BILL CHARGES") - Q - ; -HDR ; -- header code - D HDR^IBJTU1(+IBIFN,+DFN,12) - Q - ; -INIT ; -- init variables and list array - N IBOK,IBEOBDET - K ^TMP("IBJTBA",$J) N IBFT - I '$G(DFN)!'$G(IBIFN) S VALMQUIT="" G INITQ - S IBFT=+$P($G(^DGCR(399,+IBIFN,0)),U,19),IBOK=1 - I $D(^IBM(361.1,"B",IBIFN))!$D(^IBM(361.1,"C",IBIFN)) D G:'IBOK INITQ - . S DIR("A")="DO YOU WANT ALL EEOB DETAILS?: ",DIR("B")="NO",DIR(0)="YA" - . D FULL^VALM1 W ! D ^DIR K DIR - . I $D(DTOUT)!$D(DUOUT) S IBOK=0 Q - . S IBEOBDET=+Y - D BLD -INITQ Q - ; -MRA ; -- mra/eob - N IBI,Z,IBSTR,IBSHEOB,IBCT - S IBCT=0 - S IBI=0 F S IBI=$O(^IBM(361.1,"B",IBIFN,IBI)) Q:'IBI S Z=+$O(^IBM(361.1,IBI,8,0)) I '$O(^(Z)) S IBCT=IBCT+1,IBSHEOB(IBI)=0 ; Entire EOB belongs to the bill - S IBI=0 F S IBI=$O(^IBM(361.1,"C",IBIFN,IBI)) Q:'IBI S IBCT=IBCT+1,IBSHEOB(IBI)=1 ; EOB has been reapportioned at the site - I 'IBCT D - . S IBSTR=$$SETLN("No EEOB/MRA Information","",1,79) - . S IBLN=$$SET(IBSTR,IBLN) - I IBCT D - . S Z=0 - . S IBI=0 F S IBI=$O(IBSHEOB(IBI)) Q:'IBI S Z=Z+1 D SHEOB^IBJTBA1(IBI,+IBSHEOB(IBI),Z,IBCT) - ; - Q - ; -HELP ; -- help code - S X="?" D DISP^XQORM1 W !! - Q - ; -EXIT ; -- exit code - K ^TMP("IBJTBA",$J) - D CLEAR^VALM1 - Q - ; -BLD ; charges, as they would display on the bill - N IBXDATA,IBXSAVE - I $P($G(^DGCR(399,+IBIFN,0)),U,19)=2 D H1500 Q - D UB04 - K ^TMP("IBXSAVE",$J) - Q - ; -H1500 ; block 24 - N X,IBI,IBJ,IBLN,IBX,IBSTR,IBLKLN,IBPFORM,IBLIN - K ^TMP("IBXSAVE",$J) - S IBLIN=$$BOX24D^IBCEF11("",1),IBLKLN=0,IBLN=1 - Q:'$G(IBIFN) K ^TMP("IBXDISP",$J) - S IBPFORM=$S($P($G(^IBE(353,2,2)),U,8):$P(^(2),U,8),1:2),IBLN=1 - S IBX=$$BILLN^IBCEFG0(1,"1^99",IBLIN,+IBIFN,IBPFORM) - S IBI=$O(^TMP("IBXDISP",$J,""),-1) - S IBJ="" F S IBJ=$O(^TMP("IBXDISP",$J,IBI,IBJ),-1) Q:$S('IBJ:1,1:$TR($G(^(IBJ))," ")'="") K ^TMP("IBXDISP",$J,IBI,IBJ) - I '$O(^TMP("IBXDISP",$J,IBI,0)) S VALMSG="No charges or procedures defined.",VALMQUIT="" G H1500Q - S IBI="" F S IBI=$O(^TMP("IBXDISP",$J,IBI)) Q:'IBI S IBJ=0 F S IBJ=$O(^TMP("IBXDISP",$J,IBI,IBJ)) Q:'IBJ D - . S IBX=$G(^TMP("IBXDISP",$J,IBI,IBJ)),IBLN=$$SET(IBX,IBLN) - K ^TMP("IBXDISP",$J) - D COB,MRA - I $$ISRX^IBCEF1(IBIFN) D RX - I $$ISPROS^IBCEF1(IBIFN) D PROS - S VALMCNT=IBLN-1 -H1500Q Q - ; -UB04 ;form locator 42-49, IBIFN required - N X,Y,DIR,IBI,IBJ,IBX,IBLN,IBLC,IBLIN,IBPFORM,IBSTATE,IBCBILL,IBINPAT,IBQ,Z,Z0 - K ^TMP("IBXSAVE",$J) - S IBLIN=$$RCBOX^IBCEF11() - S IBQ=0,IBLC=9 Q:'$G(IBIFN) K ^TMP("IBXDISP",$J) - S IBPFORM=$S($P($G(^IBE(353,3,2)),U,8):$P(^(2),U,8),1:3) - S IBX=$$BILLN^IBCEFG0(1,"1^99",IBLIN,+IBIFN,IBPFORM) - I '$O(^TMP("IBXDISP",$J,0)) S VALMSG="No charges defined.",VALMQUIT="" G UB04Q - S Z="" F S Z=$O(^TMP("IBXDISP",$J,1,Z),-1) Q:Z="" S Z0=$G(^(Z)) Q:$TR(Z0," ")'="" K ^(Z) - S:Z ^TMP("IBXDISP",$J,1,Z+1)=" " - S IBINPAT=$$INPAT^IBCEF(IBIFN,1) - S IBSTATE=$G(^DGCR(399,IBIFN,"U")),IBCBILL=$G(^DGCR(399,IBIFN,0)) - ; - S (VALMCNT,IBLN)=1,IBLKLN=0 - I +IBINPAT D S IBLN=$$SET(IBSTR,IBLN) - . S IBX=$P(IBSTATE,U,15),IBSTR=+IBX_" DAY"_$S(IBX'=1:"S",1:"")_" INPATIENT CARE" - . S IBX=$$LOS^IBCU64(+IBSTATE,+$P(IBSTATE,U,2),+$P(IBCBILL,U,6)),IBX=IBX-$$LOS1^IBCU64(IBIFN) I IBX>0 S IBSTR=IBSTR_$J("Pass Days: "_IBX,55) - ; - S IBI="" F S IBI=$O(^TMP("IBXDISP",$J,IBI)) Q:'IBI S IBJ=0 F S IBJ=$O(^TMP("IBXDISP",$J,IBI,IBJ)) Q:'IBJ D - . S IBX=$G(^TMP("IBXDISP",$J,IBI,IBJ)),IBLN=$$SET(IBX,IBLN) - . I $E(IBX,1,3)="001" D COB - ; - K ^TMP("IBXDISP",$J) - ; - D MRA - S VALMCNT=IBLN-1 -UB04Q Q - ; -SETLN(STR,IBX,COL,WD) ; - S IBX=$$SETSTR^VALM1(STR,IBX,COL,WD) - Q IBX - ; -SET(STR,LN) ; set up TMP array with screen data (allows 2 blank lines, if not at end of array) - N IBX,IBI I STR?80" " S IBLKLN=IBLKLN+1 G SETQ - F IBI=1:1:IBLKLN D SET^VALM10(LN," ") S LN=LN+1 Q:IBI>1 - D SET^VALM10(LN,STR) - S LN=LN+1,IBLKLN=0 -SETQ Q LN - ; -COB ; if there is an offset or a secondary/tertiary payer add it to the display, with ins co, and prior bill # - ; IBIFN and IBLN must exist upon entry, IBLN is updated with new line count - N IBM,IBM1,IBI,IBJ,IBD,IBSTR,IBCU2,IBCU1 Q:'$G(IBIFN) - S IBM=$G(^DGCR(399,IBIFN,"M")),IBM1=$G(^DGCR(399,IBIFN,"M1")) - S IBCU2=$G(^DGCR(399,IBIFN,"U2")),IBCU1=$G(^DGCR(399,IBIFN,"U1")) - S IBJ=$P($G(^DGCR(399,IBIFN,0)),U,21),IBJ=$S(IBJ="P":3,IBJ="S":3,IBJ="T":3,1:0),IBSTR="" - I +$P(IBM,U,2)!(+$P(IBM,U,3)) F IBI=1:1:IBJ I +$P(IBM,U,IBI) D S IBLN=$$SET(IBSTR,IBLN) - . I IBSTR="" S IBLN=$$SET("",IBLN) - . S IBD=$S(IBI=1:"Primary",IBI=2:"Secondary",1:"Tertiary")_": " S IBSTR=$$SETLN(IBD,"",5,11) - . S IBD=$P($G(^DIC(36,+$P(IBM,U,IBI),0)),U,1) S IBSTR=$$SETLN(IBD,IBSTR,17,25) - . I $P(IBCU2,U,(IBI+3))'="" S IBD=$J(+$P(IBCU2,U,(IBI+3)),9,2) S IBSTR=$$SETLN(IBD,IBSTR,44,11) - . I $P(IBM1,U,(IBI+4))'="" S IBD=$$BN1^PRCAFN(+$P(IBM1,U,(IBI+4))) S IBSTR=$$SETLN(IBD,IBSTR,60,11) - I +$P(IBCU1,U,2) D S IBLN=$$SET(IBSTR,IBLN) - . I IBSTR="" S IBLN=$$SET("",IBLN) - . S IBD="Offset: " S IBSTR=$$SETLN(IBD,"",5,11) - . S IBD=$P(IBCU1,U,3) S IBSTR=$$SETLN(IBD,IBSTR,17,25) - . S IBD=$J($P(IBCU1,U,2),9,2) S IBSTR=$$SETLN(IBD,IBSTR,44,11) - . S IBD=$P(IBCU1,U,1)-$P(IBCU1,U,2),IBD="Billed: "_$J(IBD,0,2) S IBSTR=$$SETLN(IBD,IBSTR,60,17) - Q - ; -RX ;RX refill info for CMS-1500 TPJI display - N Z,Z0,Z1,IBSPC,IBD,IBI,IBSTR,IBARRAY,IBRXX - S IBLN=IBLN+1 - S IBSPC=$J("",5) - D SET^IBCSC5A(IBIFN,.IBARRAY) - I $D(IBARRAY) D - . S (Z,Z0)=0 F S Z0=$O(IBARRAY(Z0)) Q:Z0="" S Z1=0 F S Z1=$O(IBARRAY(Z0,Z1)) Q:'Z1 S Z=Z+1 S IBXDATA(Z)=$$DAT1^IBOUTL(Z1)_U_$G(IBARRAY(Z0,Z1)) - S IBD=$$SET("",IBLN) - S IBD="PRESCRIPTION REFILLS: (For TPJI display only)" - S IBSTR=$$SETLN(IBD,"",1,79),IBLN=$$SET(IBSTR,IBLN) - S IBI=0 F S IBI=$O(IBXDATA(IBI)) Q:IBI="" D - . S IBRXX=$G(IBXDATA(IBI)) - . D ZERO^IBRXUTL($P(IBRXX,U,3)) - . S IBD=$J($P(IBRXX,U,7),9,2)_IBSPC_$P(IBRXX,U)_IBSPC_$G(^TMP($J,"IBDRUG",+$P(IBRXX,U,3),.01)) - . K ^TMP($J,"IBDRUG") - . S IBSTR=$$SETLN(IBD,"",1,79),IBLN=$$SET(IBSTR,IBLN) - . S IBD="QTY: "_$P(IBRXX,U,5)_" for "_$P(IBRXX,U,4)_" days supply "_"NDC# "_$P(IBRXX,U,6) - . S IBSTR=$$SETLN(IBD,"",23,79),IBLN=$$SET(IBSTR,IBLN) - Q - ; -PROS ;prosthetic info for CMS-1500 TPJI display - N Z,Z0,Z1,IBARRAY,IBSPC,IBD,IBI,IBSTR - S IBSPC=$J("",10),IBLN=IBLN+1 - D SET^IBCSC5B(IBIFN,.IBARRAY) - I $D(IBARRAY) D - . S (Z,Z0)=0 F S Z0=$O(IBARRAY(Z0)) Q:Z0="" S Z1=0 F S Z1=$O(IBARRAY(Z0,Z1)) Q:'Z1 S Z=Z+1,IBXDATA(Z)=$$DAT1^IBOUTL(Z0)_U_$E($$PINB^IBCSC5B(+IBARRAY(Z0,Z1)),1,39) - S IBD=$$SET("",IBLN) - S IBD="PROSTHETIC REFILLS: (For TPJI display only)" - S IBSTR=$$SETLN(IBD,"",1,79),IBLN=$$SET(IBSTR,IBLN) - S IBI=0 F S IBI=$O(IBXDATA(IBI)) Q:IBI="" D - . S IBD=$P(IBXDATA(IBI),U)_IBSPC_$P(IBXDATA(IBI),U,2) - . S IBSTR=$$SETLN(IBD,"",1,79),IBLN=$$SET(IBSTR,IBLN) - Q - ; +IBJTBA ;ALB/ARH - TPI BILL CHARGE INFO SCREEN ;01-MAR-1995 + ;;2.0;INTEGRATED BILLING;**39,80,51,137,135,309,349**;21-MAR-94;Build 46 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; +EN ; -- main entry point for IBJ TP BILL CHARGES + D EN^VALM("IBJT BILL CHARGES") + Q + ; +HDR ; -- header code + D HDR^IBJTU1(+IBIFN,+DFN,12) + Q + ; +INIT ; -- init variables and list array + N IBOK,IBEOBDET + K ^TMP("IBJTBA",$J) N IBFT + I '$G(DFN)!'$G(IBIFN) S VALMQUIT="" G INITQ + S IBFT=+$P($G(^DGCR(399,+IBIFN,0)),U,19),IBOK=1 + I $D(^IBM(361.1,"B",IBIFN))!$D(^IBM(361.1,"C",IBIFN)) D G:'IBOK INITQ + . S DIR("A")="DO YOU WANT ALL EEOB DETAILS?: ",DIR("B")="NO",DIR(0)="YA" + . D FULL^VALM1 W ! D ^DIR K DIR + . I $D(DTOUT)!$D(DUOUT) S IBOK=0 Q + . S IBEOBDET=+Y + D BLD +INITQ Q + ; +MRA ; -- mra/eob + N IBI,Z,IBSTR,IBSHEOB,IBCT + S IBCT=0 + S IBI=0 F S IBI=$O(^IBM(361.1,"B",IBIFN,IBI)) Q:'IBI S Z=+$O(^IBM(361.1,IBI,8,0)) I '$O(^(Z)) S IBCT=IBCT+1,IBSHEOB(IBI)=0 ; Entire EOB belongs to the bill + S IBI=0 F S IBI=$O(^IBM(361.1,"C",IBIFN,IBI)) Q:'IBI S IBCT=IBCT+1,IBSHEOB(IBI)=1 ; EOB has been reapportioned at the site + I 'IBCT D + . S IBSTR=$$SETLN("No EEOB/MRA Information","",1,79) + . S IBLN=$$SET(IBSTR,IBLN) + I IBCT D + . S Z=0 + . S IBI=0 F S IBI=$O(IBSHEOB(IBI)) Q:'IBI S Z=Z+1 D SHEOB^IBJTBA1(IBI,+IBSHEOB(IBI),Z,IBCT) + ; + Q + ; +HELP ; -- help code + S X="?" D DISP^XQORM1 W !! + Q + ; +EXIT ; -- exit code + K ^TMP("IBJTBA",$J) + D CLEAR^VALM1 + Q + ; +BLD ; charges, as they would display on the bill + N IBXDATA,IBXSAVE + I $P($G(^DGCR(399,+IBIFN,0)),U,19)=2 D H1500 Q + D UB04 + K ^TMP("IBXSAVE",$J) + Q + ; +H1500 ; block 24 + N X,IBI,IBJ,IBLN,IBX,IBSTR,IBLKLN,IBPFORM,IBLIN + K ^TMP("IBXSAVE",$J) + S IBLIN=$$BOX24D^IBCEF11("",1),IBLKLN=0,IBLN=1 + Q:'$G(IBIFN) K ^TMP("IBXDISP",$J) + S IBPFORM=$S($P($G(^IBE(353,2,2)),U,8):$P(^(2),U,8),1:2),IBLN=1 + S IBX=$$BILLN^IBCEFG0(1,"1^99",IBLIN,+IBIFN,IBPFORM) + S IBI=$O(^TMP("IBXDISP",$J,""),-1) + S IBJ="" F S IBJ=$O(^TMP("IBXDISP",$J,IBI,IBJ),-1) Q:$S('IBJ:1,1:$TR($G(^(IBJ))," ")'="") K ^TMP("IBXDISP",$J,IBI,IBJ) + I '$O(^TMP("IBXDISP",$J,IBI,0)) S VALMSG="No charges or procedures defined.",VALMQUIT="" G H1500Q + S IBI="" F S IBI=$O(^TMP("IBXDISP",$J,IBI)) Q:'IBI S IBJ=0 F S IBJ=$O(^TMP("IBXDISP",$J,IBI,IBJ)) Q:'IBJ D + . S IBX=$G(^TMP("IBXDISP",$J,IBI,IBJ)),IBLN=$$SET(IBX,IBLN) + K ^TMP("IBXDISP",$J) + D COB,MRA + I $$ISRX^IBCEF1(IBIFN) D RX + I $$ISPROS^IBCEF1(IBIFN) D PROS + S VALMCNT=IBLN-1 +H1500Q Q + ; +UB04 ;form locator 42-49, IBIFN required + N X,Y,DIR,IBI,IBJ,IBX,IBLN,IBLC,IBLIN,IBPFORM,IBSTATE,IBCBILL,IBINPAT,IBQ,Z,Z0 + K ^TMP("IBXSAVE",$J) + S IBLIN=$$RCBOX^IBCEF11() + S IBQ=0,IBLC=9 Q:'$G(IBIFN) K ^TMP("IBXDISP",$J) + S IBPFORM=$S($P($G(^IBE(353,3,2)),U,8):$P(^(2),U,8),1:3) + S IBX=$$BILLN^IBCEFG0(1,"1^99",IBLIN,+IBIFN,IBPFORM) + I '$O(^TMP("IBXDISP",$J,0)) S VALMSG="No charges defined.",VALMQUIT="" G UB04Q + S Z="" F S Z=$O(^TMP("IBXDISP",$J,1,Z),-1) Q:Z="" S Z0=$G(^(Z)) Q:$TR(Z0," ")'="" K ^(Z) + S:Z ^TMP("IBXDISP",$J,1,Z+1)=" " + S IBINPAT=$$INPAT^IBCEF(IBIFN,1) + S IBSTATE=$G(^DGCR(399,IBIFN,"U")),IBCBILL=$G(^DGCR(399,IBIFN,0)) + ; + S (VALMCNT,IBLN)=1,IBLKLN=0 + I +IBINPAT D S IBLN=$$SET(IBSTR,IBLN) + . S IBX=$P(IBSTATE,U,15),IBSTR=+IBX_" DAY"_$S(IBX'=1:"S",1:"")_" INPATIENT CARE" + . S IBX=$$LOS^IBCU64(+IBSTATE,+$P(IBSTATE,U,2),+$P(IBCBILL,U,6)),IBX=IBX-$$LOS1^IBCU64(IBIFN) I IBX>0 S IBSTR=IBSTR_$J("Pass Days: "_IBX,55) + ; + S IBI="" F S IBI=$O(^TMP("IBXDISP",$J,IBI)) Q:'IBI S IBJ=0 F S IBJ=$O(^TMP("IBXDISP",$J,IBI,IBJ)) Q:'IBJ D + . S IBX=$G(^TMP("IBXDISP",$J,IBI,IBJ)),IBLN=$$SET(IBX,IBLN) + . I $E(IBX,1,3)="001" D COB + ; + K ^TMP("IBXDISP",$J) + ; + D MRA + S VALMCNT=IBLN-1 +UB04Q Q + ; +SETLN(STR,IBX,COL,WD) ; + S IBX=$$SETSTR^VALM1(STR,IBX,COL,WD) + Q IBX + ; +SET(STR,LN) ; set up TMP array with screen data (allows 2 blank lines, if not at end of array) + N IBX,IBI I STR?80" " S IBLKLN=IBLKLN+1 G SETQ + F IBI=1:1:IBLKLN D SET^VALM10(LN," ") S LN=LN+1 Q:IBI>1 + D SET^VALM10(LN,STR) + S LN=LN+1,IBLKLN=0 +SETQ Q LN + ; +COB ; if there is an offset or a secondary/tertiary payer add it to the display, with ins co, and prior bill # + ; IBIFN and IBLN must exist upon entry, IBLN is updated with new line count + N IBM,IBM1,IBI,IBJ,IBD,IBSTR,IBCU2,IBCU1 Q:'$G(IBIFN) + S IBM=$G(^DGCR(399,IBIFN,"M")),IBM1=$G(^DGCR(399,IBIFN,"M1")) + S IBCU2=$G(^DGCR(399,IBIFN,"U2")),IBCU1=$G(^DGCR(399,IBIFN,"U1")) + S IBJ=$P($G(^DGCR(399,IBIFN,0)),U,21),IBJ=$S(IBJ="P":3,IBJ="S":3,IBJ="T":3,1:0),IBSTR="" + I +$P(IBM,U,2)!(+$P(IBM,U,3)) F IBI=1:1:IBJ I +$P(IBM,U,IBI) D S IBLN=$$SET(IBSTR,IBLN) + . I IBSTR="" S IBLN=$$SET("",IBLN) + . S IBD=$S(IBI=1:"Primary",IBI=2:"Secondary",1:"Tertiary")_": " S IBSTR=$$SETLN(IBD,"",5,11) + . S IBD=$P($G(^DIC(36,+$P(IBM,U,IBI),0)),U,1) S IBSTR=$$SETLN(IBD,IBSTR,17,25) + . I $P(IBCU2,U,(IBI+3))'="" S IBD=$J(+$P(IBCU2,U,(IBI+3)),9,2) S IBSTR=$$SETLN(IBD,IBSTR,44,11) + . I $P(IBM1,U,(IBI+4))'="" S IBD=$$BN1^PRCAFN(+$P(IBM1,U,(IBI+4))) S IBSTR=$$SETLN(IBD,IBSTR,60,11) + I +$P(IBCU1,U,2) D S IBLN=$$SET(IBSTR,IBLN) + . I IBSTR="" S IBLN=$$SET("",IBLN) + . S IBD="Offset: " S IBSTR=$$SETLN(IBD,"",5,11) + . S IBD=$P(IBCU1,U,3) S IBSTR=$$SETLN(IBD,IBSTR,17,25) + . S IBD=$J($P(IBCU1,U,2),9,2) S IBSTR=$$SETLN(IBD,IBSTR,44,11) + . S IBD=$P(IBCU1,U,1)-$P(IBCU1,U,2),IBD="Billed: "_$J(IBD,0,2) S IBSTR=$$SETLN(IBD,IBSTR,60,17) + Q + ; +RX ;RX refill info for CMS-1500 TPJI display + N Z,Z0,Z1,IBSPC,IBD,IBI,IBSTR,IBARRAY,IBRXX + S IBLN=IBLN+1 + S IBSPC=$J("",5) + D SET^IBCSC5A(IBIFN,.IBARRAY) + I $D(IBARRAY) D + . S (Z,Z0)=0 F S Z0=$O(IBARRAY(Z0)) Q:Z0="" S Z1=0 F S Z1=$O(IBARRAY(Z0,Z1)) Q:'Z1 S Z=Z+1 S IBXDATA(Z)=$$DAT1^IBOUTL(Z1)_U_$G(IBARRAY(Z0,Z1)) + S IBD=$$SET("",IBLN) + S IBD="PRESCRIPTION REFILLS: (For TPJI display only)" + S IBSTR=$$SETLN(IBD,"",1,79),IBLN=$$SET(IBSTR,IBLN) + S IBI=0 F S IBI=$O(IBXDATA(IBI)) Q:IBI="" D + . S IBRXX=$G(IBXDATA(IBI)) + . D ZERO^IBRXUTL($P(IBRXX,U,3)) + . S IBD=$J($P(IBRXX,U,7),9,2)_IBSPC_$P(IBRXX,U)_IBSPC_$G(^TMP($J,"IBDRUG",+$P(IBRXX,U,3),.01)) + . K ^TMP($J,"IBDRUG") + . S IBSTR=$$SETLN(IBD,"",1,79),IBLN=$$SET(IBSTR,IBLN) + . S IBD="QTY: "_$P(IBRXX,U,5)_" for "_$P(IBRXX,U,4)_" days supply "_"NDC# "_$P(IBRXX,U,6) + . S IBSTR=$$SETLN(IBD,"",23,79),IBLN=$$SET(IBSTR,IBLN) + Q + ; +PROS ;prosthetic info for CMS-1500 TPJI display + N Z,Z0,Z1,IBARRAY,IBSPC,IBD,IBI,IBSTR + S IBSPC=$J("",10),IBLN=IBLN+1 + D SET^IBCSC5B(IBIFN,.IBARRAY) + I $D(IBARRAY) D + . S (Z,Z0)=0 F S Z0=$O(IBARRAY(Z0)) Q:Z0="" S Z1=0 F S Z1=$O(IBARRAY(Z0,Z1)) Q:'Z1 S Z=Z+1,IBXDATA(Z)=$$DAT1^IBOUTL(Z0)_U_$E($P($$PIN^IBCSC5B(Z1),U,2),1,39) + S IBD=$$SET("",IBLN) + S IBD="PROSTHETIC REFILLS: (For TPJI display only)" + S IBSTR=$$SETLN(IBD,"",1,79),IBLN=$$SET(IBSTR,IBLN) + S IBI=0 F S IBI=$O(IBXDATA(IBI)) Q:IBI="" D + . S IBD=$P(IBXDATA(IBI),U)_IBSPC_$P(IBXDATA(IBI),U,2) + . S IBSTR=$$SETLN(IBD,"",1,79),IBLN=$$SET(IBSTR,IBLN) + Q + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTCA2.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTCA2.m index 904011ba..0cc0b881 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTCA2.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTCA2.m @@ -1,127 +1,127 @@ -IBJTCA2 ;ALB/ARH - TPI CLAIMS INFO BUILD (CONT) ;7:39 PM 30 Jan 2008 - ;;2.0;INTEGRATED BILLING;**39,80,155,320,VWEHR1**;WorldVistA 30-Jan-08;Build 4 - ;;Per VHA Directive 10-93-142, this routine should not be modified. - ; - ;Modified from FOIA VISTA, - ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;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 Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; -CONT ; Continuation of Claim Information Screen Build - ; reason cancelled - I $P(IBD0,U,13)=7 D - . S (IBNC(1),IBTC(1))=2,(IBNC(2),IBTC(2))=0,IBNC(3)=28,IBTW(1)=29,IBTW(2)=0,IBSW(1)=49,IBSW(2)=0 - . S (IBT,IBD)="" S IBLN=$$SET(IBT,IBD,IBLN,1) - . ; - . S IBGRPB=IBLN,IBLR=1 - . K IBY D RCANC^IBJTU2(IBIFN,.IBY,50) - . S IBT="Reason Cancelled by ("_$P(IBY,U,3)_"): " - . S IBI=0 F S IBI=$O(IBY(IBI)) Q:'IBI S IBD=IBY(IBI) S IBLN=$$SET(IBT,IBD,IBLN,IBLR),IBT="" - ; - S (IBLN,VALMCNT)=$S(IBLN>IBGRPE:IBLN,1:IBGRPE) - S (IBNC(1),IBTC(1))=2,IBTW(1)=16,IBSW(1)=50 - S (IBT,IBD)="" S IBLN=$$SET(IBT,IBD,IBLN,IBLR) - ; - S IBGRPB=IBLN,IBLR=1 - ; - I +$P(IBDS,U,1) S IBT="Entered: ",IBD=$$EXT(IBDS,1,2) S IBLN=$$SET(IBT,IBD,IBLN,IBLR) - I +$P(IBDS,U,4) S IBT="Initial Review: ",IBD=$$EXT(IBDS,4,5) S IBLN=$$SET(IBT,IBD,IBLN,IBLR) - I +$P(IBDS,U,7) S IBT="MRA Request: ",IBD=$$EXT(IBDS,7,8) S IBLN=$$SET(IBT,IBD,IBLN,IBLR) - I +$P(IBDS,U,10) S IBT="Authorized: ",IBD=$$EXT(IBDS,10,11) S IBLN=$$SET(IBT,IBD,IBLN,IBLR) - I +$P(IBDS,U,12) S IBT="First Printed: ",IBD=$$EXT(IBDS,12,13) S IBLN=$$SET(IBT,IBD,IBLN,IBLR) - I $P(IBDS,U,14)>$P(IBDS,U,12) S IBT="Last Printed: ",IBD=$$EXT(IBDS,14,15) S IBLN=$$SET(IBT,IBD,IBLN,IBLR) - I +$P(IBDS,U,17) S IBT="Cancelled: ",IBD=$$EXT(IBDS,17,18) S IBLN=$$SET(IBT,IBD,IBLN,IBLR) - ; - ; Patch 320 - added bill cloning history to TPJI report. - N IBCCR,IBCURR,IBNEXT,IBBCH,IBINDENT - S IBINDENT=0 - D EN^IBCCR(IBIFN,.IBCCR) ; utility to pull cloning history - ; - ; attempt to go one claim forward from the current claim - S IBCURR="IBCCR("_+$P(IBDS,U,1)_","_IBIFN_")" - S IBNEXT=$Q(@IBCURR) - I IBNEXT'="" D - . N IBX S IBX=@IBNEXT - . S IBT="Copied: " - . S IBD=$$FMTE^XLFDT($P(IBX,U,1),"2Z")_" by "_$P(IBX,U,3) - . S IBLN=$$SET(IBT,IBD,IBLN,IBLR) - . S IBT="Copied To: ",IBD=$P(IBX,U,2),IBLN=$$SET(IBT,IBD,IBLN,IBLR) - . S IBINDENT=1 - . Q - ; - ; now go backwards for claim cloning history all the way back - S IBBCH=IBCURR - ; - ;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1 - ; - ;F S IBBCH=$Q(@IBBCH,-1) Q:IBBCH="" D - F S IBBCH=$$Q^VWUTIL($NA(@IBBCH),-1) Q:IBBCH="" D - . ; - . ;END CHANGE - . ; - . N IBX S IBX=@IBBCH - . S IBT="Copied: " I IBINDENT S IBT=" "_IBT - . S IBD=$$FMTE^XLFDT($P(IBX,U,1),"2Z")_" by "_$P(IBX,U,3) - . S IBLN=$$SET(IBT,IBD,IBLN,IBLR) - . S IBT="Copied From: " I IBINDENT S IBT=" "_IBT - . S IBD=$P(IBX,U,2),IBLN=$$SET(IBT,IBD,IBLN,IBLR) - . S IBT="Reason Copied: " I IBINDENT S IBT=" "_IBT - . S IBD=$P(IBX,U,4),IBLN=$$SET(IBT,IBD,IBLN,IBLR) - . S IBINDENT=1 - . Q - ; - I $D(^DGCR(399,IBIFN,"R","AC",1)) S IBT="Returned to AR: ",X=0 F S X=$O(^DGCR(399,IBIFN,"R","AC",1,X)) Q:'X D - . S IBY=$G(^DGCR(399,IBIFN,"R",X,0)),IBD=$$EXT(IBY,1,2) S IBLN=$$SET(IBT,IBD,IBLN,IBLR) - ; - N IBCOB,IBX,IBY,IBI,IBJ,IBK D BCOB^IBCU3(IBIFN,.IBCOB) I $O(IBCOB(0)) D - . S IBTC(1)=2,IBTW(1)=12,IBSW(1)=68,IBLR=1,IBNC(1)=26 - . S (IBT,IBD)="" S IBLN=$$SET(IBT,IBD,IBLN,1) - . S IBT="Payers and Related Bills" S IBLN=$$SETN^IBJTCA1(IBT,IBLN,IBLR,1) - . S (IBT,IBD)="" S IBLN=$$SET(IBT,IBD,IBLN,1) - . S IBT="",IBD="Insurance Co. Bill # Status Original Collected Balance" - . S IBLN=$$SET(IBT,IBD,IBLN,IBLR) D CNTRL^VALM10(IBLN-1,(IBTC(1)+IBTW(1)),IBSW(1),IOUON,IOUOFF) - . S IBI=0 F S IBI=$O(IBCOB(IBI)) Q:'IBI D - .. S IBT=$S(IBI=1:"Primary",IBI=2:"Secondary",IBI=3:"Tertiary",1:"Other")_": " - .. S IBJ=0 F S IBJ=$O(IBCOB(IBI,IBJ)) Q:'IBJ S IBK="" F S IBK=$O(IBCOB(IBI,IBJ,IBK)) Q:IBK="" D - ... S IBD="",IBY=$$BILL^RCJIBFN2(IBK) - ... S IBX=$P($G(^DIC(36,+IBJ,0)),U,1) S IBD=$$SLINE(IBD,IBX,0,15) - ... I +IBK D - .... S IBX=$P($G(^DGCR(399,+IBK,0)),U,1) S IBD=$$SLINE(IBD,IBX,17,10) - .... S IBX=$P($$STNO^RCJIBFN2(+$P(IBY,U,2)),U,2) ;bill status - .... ; if MRA active & bill pyr seq >1 & dsply'g prmry & prmry ins is WNR - .... I $$EDIACTV^IBCEF4(2),$$COBN^IBCEF(+IBK)>1,IBI=1,$$MCRWNR^IBEFUNC(+IBJ) D - ..... S IBX=" ",IBY="0^^0^0^0" ;blank out status & reset WNR amounts - .... S IBD=$$SLINE(IBD,IBX,30,3) - .... S IBX=$J($P(IBY,U,1),10,2) S IBD=$$SLINE(IBD,IBX,35,10) - .... S IBX=$J($P(IBY,U,4),10,2) S IBD=$$SLINE(IBD,IBX,46,10) - .... S IBX=$J($P(IBY,U,3),10,2) S IBD=$$SLINE(IBD,IBX,57,10) - ... S IBLN=$$SET(IBT,IBD,IBLN,IBLR),IBT="" - Q - ; -EXT(STR,DT,USER) ; returns external form of user and date, given their position in the string - N X,Y S Y="",STR=$G(STR),DT=+$G(DT),USER=+$G(USER) - S X=$P(STR,U,DT),DT="" I +X S DT=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3) - S X=$P(STR,U,USER),USER="" I +X S USER=$P($G(^VA(200,+X,0)),U,1) - S Y=DT_" by "_$S(USER="":"UNKNOWN",1:USER) - Q Y - ; -SET(IBT,IBD,IBLN,IBLR) ; - N LN S LN=$$SET^IBJTCA1(IBT,IBD,IBLN,IBLR) - Q LN - ; -SLINE(IBD,DATA,COL,WD) ; format a single line with multiple data fields - S IBD=$E(IBD,1,(COL-1)),IBD=IBD_$J("",(COL-$L(IBD))),IBD=IBD_$E(DATA,1,WD) - Q IBD +IBJTCA2 ;ALB/ARH - TPI CLAIMS INFO BUILD (CONT) ;7:39 PM 30 Jan 2008 + ;;2.0;INTEGRATED BILLING;**39,80,155,320,VWEHR1**;WorldVistA 30-Jan-08 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; + ;Modified from FOIA VISTA, + ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;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 Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; +CONT ; Continuation of Claim Information Screen Build + ; reason cancelled + I $P(IBD0,U,13)=7 D + . S (IBNC(1),IBTC(1))=2,(IBNC(2),IBTC(2))=0,IBNC(3)=28,IBTW(1)=29,IBTW(2)=0,IBSW(1)=49,IBSW(2)=0 + . S (IBT,IBD)="" S IBLN=$$SET(IBT,IBD,IBLN,1) + . ; + . S IBGRPB=IBLN,IBLR=1 + . K IBY D RCANC^IBJTU2(IBIFN,.IBY,50) + . S IBT="Reason Cancelled by ("_$P(IBY,U,3)_"): " + . S IBI=0 F S IBI=$O(IBY(IBI)) Q:'IBI S IBD=IBY(IBI) S IBLN=$$SET(IBT,IBD,IBLN,IBLR),IBT="" + ; + S (IBLN,VALMCNT)=$S(IBLN>IBGRPE:IBLN,1:IBGRPE) + S (IBNC(1),IBTC(1))=2,IBTW(1)=16,IBSW(1)=50 + S (IBT,IBD)="" S IBLN=$$SET(IBT,IBD,IBLN,IBLR) + ; + S IBGRPB=IBLN,IBLR=1 + ; + I +$P(IBDS,U,1) S IBT="Entered: ",IBD=$$EXT(IBDS,1,2) S IBLN=$$SET(IBT,IBD,IBLN,IBLR) + I +$P(IBDS,U,4) S IBT="Initial Review: ",IBD=$$EXT(IBDS,4,5) S IBLN=$$SET(IBT,IBD,IBLN,IBLR) + I +$P(IBDS,U,7) S IBT="MRA Request: ",IBD=$$EXT(IBDS,7,8) S IBLN=$$SET(IBT,IBD,IBLN,IBLR) + I +$P(IBDS,U,10) S IBT="Authorized: ",IBD=$$EXT(IBDS,10,11) S IBLN=$$SET(IBT,IBD,IBLN,IBLR) + I +$P(IBDS,U,12) S IBT="First Printed: ",IBD=$$EXT(IBDS,12,13) S IBLN=$$SET(IBT,IBD,IBLN,IBLR) + I $P(IBDS,U,14)>$P(IBDS,U,12) S IBT="Last Printed: ",IBD=$$EXT(IBDS,14,15) S IBLN=$$SET(IBT,IBD,IBLN,IBLR) + I +$P(IBDS,U,17) S IBT="Cancelled: ",IBD=$$EXT(IBDS,17,18) S IBLN=$$SET(IBT,IBD,IBLN,IBLR) + ; + ; Patch 320 - added bill cloning history to TPJI report. + N IBCCR,IBCURR,IBNEXT,IBBCH,IBINDENT + S IBINDENT=0 + D EN^IBCCR(IBIFN,.IBCCR) ; utility to pull cloning history + ; + ; attempt to go one claim forward from the current claim + S IBCURR="IBCCR("_+$P(IBDS,U,1)_","_IBIFN_")" + S IBNEXT=$Q(@IBCURR) + I IBNEXT'="" D + . N IBX S IBX=@IBNEXT + . S IBT="Copied: " + . S IBD=$$FMTE^XLFDT($P(IBX,U,1),"2Z")_" by "_$P(IBX,U,3) + . S IBLN=$$SET(IBT,IBD,IBLN,IBLR) + . S IBT="Copied To: ",IBD=$P(IBX,U,2),IBLN=$$SET(IBT,IBD,IBLN,IBLR) + . S IBINDENT=1 + . Q + ; + ; now go backwards for claim cloning history all the way back + S IBBCH=IBCURR + ; + ;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1 + ; + ;F S IBBCH=$Q(@IBBCH,-1) Q:IBBCH="" D + F S IBBCH=$$Q^VWUTIL($NA(@IBBCH),-1) Q:IBBCH="" D + . ; + . ;END CHANGE + . ; + . N IBX S IBX=@IBBCH + . S IBT="Copied: " I IBINDENT S IBT=" "_IBT + . S IBD=$$FMTE^XLFDT($P(IBX,U,1),"2Z")_" by "_$P(IBX,U,3) + . S IBLN=$$SET(IBT,IBD,IBLN,IBLR) + . S IBT="Copied From: " I IBINDENT S IBT=" "_IBT + . S IBD=$P(IBX,U,2),IBLN=$$SET(IBT,IBD,IBLN,IBLR) + . S IBT="Reason Copied: " I IBINDENT S IBT=" "_IBT + . S IBD=$P(IBX,U,4),IBLN=$$SET(IBT,IBD,IBLN,IBLR) + . S IBINDENT=1 + . Q + ; + I $D(^DGCR(399,IBIFN,"R","AC",1)) S IBT="Returned to AR: ",X=0 F S X=$O(^DGCR(399,IBIFN,"R","AC",1,X)) Q:'X D + . S IBY=$G(^DGCR(399,IBIFN,"R",X,0)),IBD=$$EXT(IBY,1,2) S IBLN=$$SET(IBT,IBD,IBLN,IBLR) + ; + N IBCOB,IBX,IBY,IBI,IBJ,IBK D BCOB^IBCU3(IBIFN,.IBCOB) I $O(IBCOB(0)) D + . S IBTC(1)=2,IBTW(1)=12,IBSW(1)=68,IBLR=1,IBNC(1)=26 + . S (IBT,IBD)="" S IBLN=$$SET(IBT,IBD,IBLN,1) + . S IBT="Payers and Related Bills" S IBLN=$$SETN^IBJTCA1(IBT,IBLN,IBLR,1) + . S (IBT,IBD)="" S IBLN=$$SET(IBT,IBD,IBLN,1) + . S IBT="",IBD="Insurance Co. Bill # Status Original Collected Balance" + . S IBLN=$$SET(IBT,IBD,IBLN,IBLR) D CNTRL^VALM10(IBLN-1,(IBTC(1)+IBTW(1)),IBSW(1),IOUON,IOUOFF) + . S IBI=0 F S IBI=$O(IBCOB(IBI)) Q:'IBI D + .. S IBT=$S(IBI=1:"Primary",IBI=2:"Secondary",IBI=3:"Tertiary",1:"Other")_": " + .. S IBJ=0 F S IBJ=$O(IBCOB(IBI,IBJ)) Q:'IBJ S IBK="" F S IBK=$O(IBCOB(IBI,IBJ,IBK)) Q:IBK="" D + ... S IBD="",IBY=$$BILL^RCJIBFN2(IBK) + ... S IBX=$P($G(^DIC(36,+IBJ,0)),U,1) S IBD=$$SLINE(IBD,IBX,0,15) + ... I +IBK D + .... S IBX=$P($G(^DGCR(399,+IBK,0)),U,1) S IBD=$$SLINE(IBD,IBX,17,10) + .... S IBX=$P($$STNO^RCJIBFN2(+$P(IBY,U,2)),U,2) ;bill status + .... ; if MRA active & bill pyr seq >1 & dsply'g prmry & prmry ins is WNR + .... I $$EDIACTV^IBCEF4(2),$$COBN^IBCEF(+IBK)>1,IBI=1,$$MCRWNR^IBEFUNC(+IBJ) D + ..... S IBX=" ",IBY="0^^0^0^0" ;blank out status & reset WNR amounts + .... S IBD=$$SLINE(IBD,IBX,30,3) + .... S IBX=$J($P(IBY,U,1),10,2) S IBD=$$SLINE(IBD,IBX,35,10) + .... S IBX=$J($P(IBY,U,4),10,2) S IBD=$$SLINE(IBD,IBX,46,10) + .... S IBX=$J($P(IBY,U,3),10,2) S IBD=$$SLINE(IBD,IBX,57,10) + ... S IBLN=$$SET(IBT,IBD,IBLN,IBLR),IBT="" + Q + ; +EXT(STR,DT,USER) ; returns external form of user and date, given their position in the string + N X,Y S Y="",STR=$G(STR),DT=+$G(DT),USER=+$G(USER) + S X=$P(STR,U,DT),DT="" I +X S DT=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3) + S X=$P(STR,U,USER),USER="" I +X S USER=$P($G(^VA(200,+X,0)),U,1) + S Y=DT_" by "_$S(USER="":"UNKNOWN",1:USER) + Q Y + ; +SET(IBT,IBD,IBLN,IBLR) ; + N LN S LN=$$SET^IBJTCA1(IBT,IBD,IBLN,IBLR) + Q LN + ; +SLINE(IBD,DATA,COL,WD) ; format a single line with multiple data fields + S IBD=$E(IBD,1,(COL-1)),IBD=IBD_$J("",(COL-$L(IBD))),IBD=IBD_$E(DATA,1,WD) + Q IBD diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTRA1.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTRA1.m index eef984aa..39278685 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTRA1.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTRA1.m @@ -1,66 +1,66 @@ -IBJTRA1 ;ALB/AAS,ARH - TPI CT INSURANCE COMMUNICATIONS BUILD ; 4/1/95 - ;;2.0;INTEGRATED BILLING;**39,91,347,389**;21-MAR-94;Build 6 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ; copyed from IBTRC with modifications to show reviews for multiple events - ; - ; -BLD ; -- Build list of Insurance contacts, including reviews, appeals, and denials - K ^TMP("IBJTRA",$J),^TMP("IBJTRADX",$J),IBJTA1,IBJTA2 - N X,IBI,IBJ,J,IBTRC,IBTRCD,IBTRCD1,IBJTEVNT,IBCNT,IBTRN,IBTRND,IBETYP,IBBEG - S VALMSG=$$MSG^IBTUTL3(DFN) - S (IBTRC,IBCNT,VALMCNT)=0,IBI="" - D IFNTRN^IBJTU5(IBIFN,.IBJTA1,.IBJTA2) - I 'IBJTA1 S IBCNT=1 D SET1(" ") S IBCNT=2 D SET1("No Claims Tracking Entries.") G BLDQ - S IBJ=0 F S IBJ=$O(IBJTA2(IBJ)) Q:'IBJ S IBTRN=IBJTA2(IBJ) D - .S IBTRND=$G(^IBT(356,IBTRN,0)) - .S IBJTEVNT=" "_$$EVNT(IBTRND) - .F S IBI=$O(^IBT(356.2,"ATIDT",IBTRN,IBI)) Q:'IBI S IBTRC=0 F S IBTRC=$O(^IBT(356.2,"ATIDT",IBTRN,IBI,IBTRC)) Q:'IBTRC D - ..S IBTRCD=$G(^IBT(356.2,+IBTRC,0)) - ..S IBTRCD1=$G(^IBT(356.2,+IBTRC,1)) - ..Q:'+$P(IBTRCD,"^",19) ;quit if inactive - ..S IBCNT=IBCNT+1 - ..I IBJTEVNT'="" D SET(" ",0),SET(IBJTEVNT,0) S IBJTEVNT="" - ..S IBETYP=$G(^IBE(356.11,+$P(IBTRCD,"^",4),0)) - ..W "." - ..S X="" - ..S X=$$SETFLD^VALM1(IBCNT,X,"NUMBER") - ..S X=$$SETFLD^VALM1($P($$DAT1^IBOUTL(+IBTRCD,"2P")," "),X,"DATE") - ..S X=$$SETFLD^VALM1($P($G(^DIC(36,+$P(IBTRCD,"^",8),0)),"^"),X,"INS CO") - ..S X=$$SETFLD^VALM1($$EXPAND^IBTRE(356.2,.11,$P(IBTRCD,"^",11)),X,"ACTION") - ..; - ..S X=$$SETFLD^VALM1($P(IBETYP,"^",3),X,"TYPE") - ..S X=$$SETFLD^VALM1($P(IBTRCD,"^",28),X,"PRE-CERT") - ..I $P(IBTRCD,"^",13) S X=$$SETFLD^VALM1($J($$DAY^IBTUTL3($P(IBTRCD,"^",12),$P(IBTRCD,"^",13),IBTRN),3),X,"DAYS") - ..I $P($G(^IBE(356.7,+$P(IBTRCD,"^",11),0)),"^",3)=20 S X=$$SETFLD^VALM1($J($$DAY^IBTUTL3($P(IBTRCD,"^",15),$P(IBTRCD,"^",16),IBTRN),3),X,"DAYS") - ..I $P(IBTRCD1,"^",7)!($P(IBTRCD1,"^",8)) S X=$$SETFLD^VALM1("ALL",X,"DAYS") - ..S X=$$SETFLD^VALM1($P(IBTRCD,"^",6),X,"CONTACT") - ..S X=$$SETFLD^VALM1($P(IBTRCD,"^",7),X,"PHONE") - ..S X=$$SETFLD^VALM1($P(IBTRCD,"^",9),X,"REF NO") - ..I $P(IBETYP,"^",2)=60!($P(IBETYP,"^",2)=65) D APPEAL^IBTRC3 - ..D SET(X,1) - I 'IBCNT S IBCNT=1 D SET1(" ") S IBCNT=2 D SET1("No Insurance Reviews for Episodes on this Bill.") G BLDQ -BLDQ K IBJTA1,IBJTA2 - Q - ; -SET1(X) ; set array (no selection) - S VALMCNT=VALMCNT+1 - S ^TMP("IBJTRA",$J,VALMCNT,0)=X - Q - ; -SET(X,Y) ; -- set arrays - S VALMCNT=VALMCNT+1 - S ^TMP("IBJTRA",$J,VALMCNT,0)=X - S ^TMP("IBJTRA",$J,"IDX",VALMCNT,IBCNT)="" - I +$G(Y) S ^TMP("IBJTRADX",$J,IBCNT)=VALMCNT_"^"_IBTRC - Q - ; -EVNT(IBTRND) ; return line for display on event - N X,Y,IBTYP S X="" I $G(IBTRND)="" G EVNTQ - S IBTYP=+$P(IBTRND,U,18) - S X=$$EXSET^IBJU1(IBTYP,356,.18) - I IBTYP=2 S X=X_" of "_$P($G(^DIC(40.7,+$$SCE^IBSDU(+$P(IBTRND,U,4),3),0)),U,1) - I IBTYP=3 S X=X_" of "_$P($$PIN^IBCSC5B(+$P(IBTRND,U,9)),U,2) - I IBTYP=4 S X=X_" of "_$$FILE^IBRXUTL(+$P(IBTRND,U,8),.01) - S X=X_" on "_$$DAT1^IBOUTL($P(IBTRND,U,6),"2P") -EVNTQ Q X +IBJTRA1 ;ALB/AAS,ARH - TPI CT INSURANCE COMMUNICATIONS BUILD ; 4/1/95 + ;;2.0;INTEGRATED BILLING;**39,91,347**;21-MAR-94;Build 24 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; + ; copyed from IBTRC with modifications to show reviews for multiple events + ; + ; +BLD ; -- Build list of Insurance contacts, including reviews, appeals, and denials + K ^TMP("IBJTRA",$J),^TMP("IBJTRADX",$J),IBJTA1,IBJTA2 + N X,IBI,IBJ,J,IBTRC,IBTRCD,IBTRCD1,IBJTEVNT,IBCNT,IBTRN,IBTRND,IBETYP,IBBEG + S VALMSG=$$MSG^IBTUTL3(DFN) + S (IBTRC,IBCNT,VALMCNT)=0,IBI="" + D IFNTRN^IBJTU5(IBIFN,.IBJTA1,.IBJTA2) + I 'IBJTA1 S IBCNT=1 D SET1(" ") S IBCNT=2 D SET1("No Claims Tracking Entries.") G BLDQ + S IBJ=0 F S IBJ=$O(IBJTA2(IBJ)) Q:'IBJ S IBTRN=IBJTA2(IBJ) D + .S IBTRND=$G(^IBT(356,IBTRN,0)) + .S IBJTEVNT=" "_$$EVNT(IBTRND) + .F S IBI=$O(^IBT(356.2,"ATIDT",IBTRN,IBI)) Q:'IBI S IBTRC=0 F S IBTRC=$O(^IBT(356.2,"ATIDT",IBTRN,IBI,IBTRC)) Q:'IBTRC D + ..S IBTRCD=$G(^IBT(356.2,+IBTRC,0)) + ..S IBTRCD1=$G(^IBT(356.2,+IBTRC,1)) + ..Q:'+$P(IBTRCD,"^",19) ;quit if inactive + ..S IBCNT=IBCNT+1 + ..I IBJTEVNT'="" D SET(" ",0),SET(IBJTEVNT,0) S IBJTEVNT="" + ..S IBETYP=$G(^IBE(356.11,+$P(IBTRCD,"^",4),0)) + ..W "." + ..S X="" + ..S X=$$SETFLD^VALM1(IBCNT,X,"NUMBER") + ..S X=$$SETFLD^VALM1($P($$DAT1^IBOUTL(+IBTRCD,"2P")," "),X,"DATE") + ..S X=$$SETFLD^VALM1($P($G(^DIC(36,+$P(IBTRCD,"^",8),0)),"^"),X,"INS CO") + ..S X=$$SETFLD^VALM1($$EXPAND^IBTRE(356.2,.11,$P(IBTRCD,"^",11)),X,"ACTION") + ..; + ..S X=$$SETFLD^VALM1($P(IBETYP,"^",3),X,"TYPE") + ..S X=$$SETFLD^VALM1($P(IBTRCD,"^",28),X,"PRE-CERT") + ..I $P(IBTRCD,"^",13) S X=$$SETFLD^VALM1($J($$DAY^IBTUTL3($P(IBTRCD,"^",12),$P(IBTRCD,"^",13),IBTRN),3),X,"DAYS") + ..I $P($G(^IBE(356.7,+$P(IBTRCD,"^",11),0)),"^",3)=20 S X=$$SETFLD^VALM1($J($$DAY^IBTUTL3($P(IBTRCD,"^",15),$P(IBTRCD,"^",16),IBTRN),3),X,"DAYS") + ..I $P(IBTRCD1,"^",7)!($P(IBTRCD1,"^",8)) S X=$$SETFLD^VALM1("ALL",X,"DAYS") + ..S X=$$SETFLD^VALM1($P(IBTRCD,"^",6),X,"CONTACT") + ..S X=$$SETFLD^VALM1($P(IBTRCD,"^",7),X,"PHONE") + ..S X=$$SETFLD^VALM1($P(IBTRCD,"^",9),X,"REF NO") + ..I $P(IBETYP,"^",2)=60!($P(IBETYP,"^",2)=65) D APPEAL^IBTRC3 + ..D SET(X,1) + I 'IBCNT S IBCNT=1 D SET1(" ") S IBCNT=2 D SET1("No Insurance Reviews for Episodes on this Bill.") G BLDQ +BLDQ K IBJTA1,IBJTA2 + Q + ; +SET1(X) ; set array (no selection) + S VALMCNT=VALMCNT+1 + S ^TMP("IBJTRA",$J,VALMCNT,0)=X + Q + ; +SET(X,Y) ; -- set arrays + S VALMCNT=VALMCNT+1 + S ^TMP("IBJTRA",$J,VALMCNT,0)=X + S ^TMP("IBJTRA",$J,"IDX",VALMCNT,IBCNT)="" + I +$G(Y) S ^TMP("IBJTRADX",$J,IBCNT)=VALMCNT_"^"_IBTRC + Q + ; +EVNT(IBTRND) ; return line for display on event + N X,Y,IBTYP S X="" I $G(IBTRND)="" G EVNTQ + S IBTYP=+$P(IBTRND,U,18) + S X=$$EXSET^IBJU1(IBTYP,356,.18) + I IBTYP=2 S X=X_" of "_$P($G(^DIC(40.7,+$$SCE^IBSDU(+$P(IBTRND,U,4),3),0)),U,1) + I IBTYP=3 S Y=+$P($G(^RMPR(660,+$P(IBTRND,U,9),0)),U,6),X=X_" of "_$$EXSET^IBJU1(Y,660,4) + I IBTYP=4 S X=X_" of "_$$FILE^IBRXUTL(+$P(IBTRND,U,8),.01) + S X=X_" on "_$$DAT1^IBOUTL($P(IBTRND,U,6),"2P") +EVNTQ Q X diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTTC.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTTC.m index d1f15543..a5c605d4 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTTC.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTTC.m @@ -1,113 +1,88 @@ -IBJTTC ;ALB/ARH - TPI AR COMMENT HISTORY ; 06-MAR-1995 - ;;2.0;INTEGRATED BILLING;**39,377**;21-MAR-94;Build 23 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ; AR Profile of Comments: This screen prints the following Comments: - ; Bill Comments (430,98) - entered during auditing - ; For each COMMENT Transaction: - ; Brief Comment (433,5.02) - ; Transaction Comment (433,86) - ; Comment (433,41) - ; -EN ; -- main entry point for IBJT AR COMMENT HISTORY - D EN^VALM("IBJT AR COMMENT HISTORY") - Q - ; -HDR ; -- header code - D HDR^IBJTU1(+IBIFN,+DFN,13) - Q - ; -INIT ; -- init variables and list array - K ^TMP("IBJTTC",$J) - I '$G(DFN)!'$G(IBIFN) S VALMQUIT="" G INITQ - D BLD -INITQ Q - ; -HELP ; -- help code - S X="?" D DISP^XQORM1 W !! - Q - ; -EXIT ; -- exit code - K ^TMP("IBJTTC",$J) - D CLEAR^VALM1 - Q - ; -BLD ; - N CMLN,CMSTR,X,IBCNT,IBZ,IB0,IBI,IBX,IBD,IBDATE,IBDUZ,IBRCT5,IBLN,IBSTR,IBK,IBJ,DIWL,DIWR,DIWF,COM - ; - S VALMCNT=0,IBLN=0 - ; - ; Bill Comments (430,98) - K COM,^UTILITY($J,"W") D BCOM^RCJIBFN2(IBIFN) I $D(COM)>10 D - . S IBSTR="",IBD="AR BILL COMMENTS:" S IBSTR=$$SETLN(IBD,IBSTR,25,54),IBLN=$$SET(IBSTR,IBLN) - . ; - . S IBJ="" F S IBJ=$O(COM(IBJ)) Q:'IBJ S X=$G(COM(IBJ)) I X'="" S DIWL=1,DIWR=54,DIWF="" D ^DIWP - . ; - . I $D(^UTILITY($J,"W")) S (IBK,IBCNT)=0 F S IBK=$O(^UTILITY($J,"W",1,IBK)) Q:'IBK D - .. S IBD=$G(^UTILITY($J,"W",1,IBK,0)) S IBSTR=$$SETLN(IBD,IBSTR,25,54),IBLN=$$SET(IBSTR,IBLN),IBSTR="" - . K ^UTILITY($J,"W") - ; - ; AR profile of comment transactions (433: 5.02, 41, 86) - K ^TMP("RCJIB",$J),^UTILITY($J,"W") D TRN^RCJIBFN2(IBIFN) - I $D(^TMP("RCJIB",$J)) S IBI="" F S IBI=$O(^TMP("RCJIB",$J,IBI)) Q:'IBI D - . S IBX=$G(^TMP("RCJIB",$J,IBI)) I $$STNO^RCJIBFN2(+$P(IBX,U,3))'["COMMENT" Q - . S IBRCT5=$$N5^RCJIBFN1(IBI) - . S IBSTR="",IBLN=$$SET(IBSTR,IBLN) - . S IBD=$P(IBX,U,1) S IBSTR=$$SETLN(IBD,IBSTR,2,8) - . S IBD=$$DATE(+$P(IBX,U,2)) S IBSTR=$$SETLN(IBD,IBSTR,14,8) - . S IBD=$P(IBRCT5,U,1) S IBSTR=$$SETLN(IBD,IBSTR,25,30) - . S IBD="FOLLOW-UP DT: "_$$DATE(+$P(IBRCT5,U,2)) S IBSTR=$$SETLN(IBD,IBSTR,57,22) - . S IBLN=$$SET(IBSTR,IBLN),IBSTR="" - . ; - . ; -- transaction comments (86) - . S X=$P($G(^TMP("RCJIB",$J,IBI)),U,6) I X'="" S DIWL=1,DIWR=54,DIWF="" D ^DIWP - . ; - . ; -- comments (86 & 41) - . K COM D N7^RCJIBFN1(IBI) I $D(COM)>2 D - .. S IBJ="" F S IBJ=$O(COM(IBJ)) Q:'IBJ S X=$G(COM(IBJ)) I X'="" S DIWL=1,DIWR=54,DIWF="" D ^DIWP - . ; - . I $D(^UTILITY($J,"W")) S (IBK,IBCNT)=0 F S IBK=$O(^UTILITY($J,"W",1,IBK)) Q:'IBK D - .. S IBD=$G(^UTILITY($J,"W",1,IBK,0)) S IBSTR=$$SETLN(IBD,IBSTR,25,54),IBLN=$$SET(IBSTR,IBLN),IBSTR="" - . K ^UTILITY($J,"W") - K ^TMP("RCJIB",$J),^UTILITY($J,"W") - ; MRA comments - ; check if we have any comments to display - I $D(^DGCR(399,IBIFN,"TXC","B")) D - .S IBLN=$$SET("",IBLN) - .S IBSTR="",IBSTR=$$SETLN("MRA REQUEST CLAIM COMMENTS",IBSTR,25,54),IBLN=$$SET(IBSTR,IBLN) - .S IBSTR="",IBSTR=$$SETLN("--------------------------",IBSTR,25,54),IBLN=$$SET(IBSTR,IBLN) - .; loop through all available comments - .S IBDATE="" F S IBDATE=$O(^DGCR(399,IBIFN,"TXC","B",IBDATE),-1) Q:IBDATE="" D - ..S IBZ=$O(^DGCR(399,IBIFN,"TXC","B",IBDATE,"")),IB0=^DGCR(399,IBIFN,"TXC",IBZ,0),IBDUZ=$P(IB0,U,2) - ..S IBLN=$$SET("",IBLN) - ..S IBSTR="" - ..S IBSTR=$$SETLN($$FMTE^XLFDT(IBDATE,"2Z"),IBSTR,14,8) - ..S IBSTR=$$SETLN($J("Entered by "_$$GET1^DIQ(200,IBDUZ,.01),54),IBSTR,25,54) - ..S IBLN=$$SET(IBSTR,IBLN),IBSTR="" - ..; loop through comment lines - ..S CMLN=0 F S CMLN=$O(^DGCR(399,IBIFN,"TXC",IBZ,1,CMLN)) Q:CMLN="" D - ...S X=^DGCR(399,IBIFN,"TXC",IBZ,1,CMLN,0) I X'="" S DIWL=1,DIWR=54,DIWF="" D ^DIWP - ...Q - ..I $D(^UTILITY($J,"W")) S IBK=0 F S IBK=$O(^UTILITY($J,"W",1,IBK)) Q:'IBK D - ...S CMSTR=$G(^UTILITY($J,"W",1,IBK,0)) S IBSTR=$$SETLN(CMSTR,IBSTR,25,54),IBLN=$$SET(IBSTR,IBLN),IBSTR="" - ...Q - ..K ^UTILITY($J,"W") - ..Q - .D CLEAN^DILF - .Q - ; - I IBLN=0 S IBLN=$$SET("",IBLN),IBLN=$$SET("No Comment Transactions Exist For This Account.",IBLN) - S VALMCNT=IBLN - Q - ; -DATE(X) ; date in external format - N Y S Y="" I +X S Y=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3) - Q Y - ; -SETLN(STR,IBX,COL,WD) ; - S IBX=$$SETSTR^VALM1(STR,IBX,COL,WD) - Q IBX - ; -SET(STR,LN) ; set up TMP array with screen data - S LN=LN+1 D SET^VALM10(LN,STR) -SETQ Q LN +IBJTTC ;ALB/ARH - TPI AR COMMENT HISTORY ; 06-MAR-1995 + ;;Version 2.0 ; INTEGRATED BILLING ;**39**; 21-MAR-94 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; + ; AR Profile of Comments: This screen prints the following Comments: + ; Bill Comments (430,98) - entered during auditing + ; For each COMMENT Transaction: + ; Brief Comment (433,5.02) + ; Transaction Comment (433,86) + ; Comment (433,41) + ; +EN ; -- main entry point for IBJT AR COMMENT HISTORY + D EN^VALM("IBJT AR COMMENT HISTORY") + Q + ; +HDR ; -- header code + D HDR^IBJTU1(+IBIFN,+DFN,13) + Q + ; +INIT ; -- init variables and list array + K ^TMP("IBJTTC",$J) + I '$G(DFN)!'$G(IBIFN) S VALMQUIT="" G INITQ + D BLD +INITQ Q + ; +HELP ; -- help code + S X="?" D DISP^XQORM1 W !! + Q + ; +EXIT ; -- exit code + K ^TMP("IBJTTC",$J) + D CLEAR^VALM1 + Q + ; +BLD ; + N X,IBCNT,IBI,IBX,IBD,IBRCT5,IBLN,IBSTR,IBK,IBJ,DIWL,DIWR,DIWF,COM + ; + S VALMCNT=0,IBLN=0 + ; + ; Bill Comments (430,98) + K COM,^UTILITY($J,"W") D BCOM^RCJIBFN2(IBIFN) I $D(COM)>10 D + . S IBSTR="",IBD="AR BILL COMMENTS:" S IBSTR=$$SETLN(IBD,IBSTR,25,54),IBLN=$$SET(IBSTR,IBLN) + . ; + . S IBJ="" F S IBJ=$O(COM(IBJ)) Q:'IBJ S X=$G(COM(IBJ)) I X'="" S DIWL=1,DIWR=54,DIWF="" D ^DIWP + . ; + . I $D(^UTILITY($J,"W")) S (IBK,IBCNT)=0 F S IBK=$O(^UTILITY($J,"W",1,IBK)) Q:'IBK D + .. S IBD=$G(^UTILITY($J,"W",1,IBK,0)) S IBSTR=$$SETLN(IBD,IBSTR,25,54),IBLN=$$SET(IBSTR,IBLN),IBSTR="" + . K ^UTILITY($J,"W") + ; + ; AR profile of comment transactions (433: 5.02, 41, 86) + K ^TMP("RCJIB",$J),^UTILITY($J,"W") D TRN^RCJIBFN2(IBIFN) + I $D(^TMP("RCJIB",$J)) S IBI="" F S IBI=$O(^TMP("RCJIB",$J,IBI)) Q:'IBI D + . S IBX=$G(^TMP("RCJIB",$J,IBI)) I $$STNO^RCJIBFN2(+$P(IBX,U,3))'["COMMENT" Q + . S IBRCT5=$$N5^RCJIBFN1(IBI) + . S IBSTR="",IBLN=$$SET(IBSTR,IBLN) + . S IBD=$P(IBX,U,1) S IBSTR=$$SETLN(IBD,IBSTR,2,8) + . S IBD=$$DATE(+$P(IBX,U,2)) S IBSTR=$$SETLN(IBD,IBSTR,14,8) + . S IBD=$P(IBRCT5,U,1) S IBSTR=$$SETLN(IBD,IBSTR,25,30) + . S IBD="FOLLOW-UP DT: "_$$DATE(+$P(IBRCT5,U,2)) S IBSTR=$$SETLN(IBD,IBSTR,57,22) + . S IBLN=$$SET(IBSTR,IBLN),IBSTR="" + . ; + . ; -- transaction comments (86) + . S X=$P($G(^TMP("RCJIB",$J,IBI)),U,6) I X'="" S DIWL=1,DIWR=54,DIWF="" D ^DIWP + . ; + . ; -- comments (86 & 41) + . K COM D N7^RCJIBFN1(IBI) I $D(COM)>2 D + .. S IBJ="" F S IBJ=$O(COM(IBJ)) Q:'IBJ S X=$G(COM(IBJ)) I X'="" S DIWL=1,DIWR=54,DIWF="" D ^DIWP + . ; + . I $D(^UTILITY($J,"W")) S (IBK,IBCNT)=0 F S IBK=$O(^UTILITY($J,"W",1,IBK)) Q:'IBK D + .. S IBD=$G(^UTILITY($J,"W",1,IBK,0)) S IBSTR=$$SETLN(IBD,IBSTR,25,54),IBLN=$$SET(IBSTR,IBLN),IBSTR="" + . K ^UTILITY($J,"W") + K ^TMP("RCJIB",$J),^UTILITY($J,"W") + ; + I IBLN=0 S IBLN=$$SET("",IBLN),IBLN=$$SET("No Comment Transactions Exist For This Account.",IBLN) + S VALMCNT=IBLN + Q + ; +DATE(X) ; date in external format + N Y S Y="" I +X S Y=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3) + Q Y + ; +SETLN(STR,IBX,COL,WD) ; + S IBX=$$SETSTR^VALM1(STR,IBX,COL,WD) + Q IBX + ; +SET(STR,LN) ; set up TMP array with screen data + S LN=LN+1 D SET^VALM10(LN,STR) +SETQ Q LN diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBRFN3.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBRFN3.m index dd21caab..d9fce697 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBRFN3.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBRFN3.m @@ -1,143 +1,143 @@ -IBRFN3 ;ALB/ARH - PASS BILL/CLAIM TO AR ;3/18/96 - ;;2.0;INTEGRATED BILLING;**61,133,210,309,389**;21-MAR-94;Build 6 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ; Returns information on the bill passed in, all data returned in external format, for AR's RC project - ; - ; If the bill can not be found then returns ARRAY=0 (should be called with ARRAY passed by reference) - ; Otherwise ARRAY=1 and the following array elements may be defined - ; these array elements will only be defined is there is data to return - ; those elements that have multiple entries will be in the form ARRAY("SUB",X) where X=1:1:... - ; - ; ARRAY("BN") = BILL NUMBER - ; ARRAY("SR") = SENSITIVE RECORD? (Y or N) - ; ARRAY("STF") = STATEMENT COVERS FROM DATE - first date covered by bill - ; ARRAY("STT") = STATEMENT COVERS TO DATE - last date covered by bill - ; ARRAY("TCG") = TOTAL CHARGES^OFFSET AMT (PRIOR PAYMENTS)^OFFSET DESC - ; ARRAY("TOC") = BILL TYPE (INPATIENT OR OUTPATIENT) - ; ARRAY("TCF") = BILL FORM TYPE - ; ARRAY("DFP") = DATE FIRST PRINTED - ; ARRAY("TAX") = FEDERAL TAX NUMBER - for facility, a site parameter - ; - ; ARRAY("PIN") = DEBTOR INSURANCE NAME ^ HOSPITAL PROVIDER NUMBER ^ GROUP NAME ^ GROUP NUMBER ^ - ; NAME OF INSURED ^ SUBSCRIBER ID ^ RELATIONSHIP TO INSURED - ; - ; ARRAY("PIN","MMA") = DEBTOR MAILING STREET ADDRESS [LINE 1] ^ - ; MAILING STREET ADDRESS [LINE 2] ^ MAILING STREET ADDRESS [LINE 3] ^ CITY ^ - ; STATE (ABBREVIATED) ^ ZIP ^ PHONE NUMBER - ; - ; ARRAY("RVC") = NUMBER OF REVENUE CODES ON BILL - ; ARRAY("RVC",X) = REVENUE CODE ^ REVENUE CODE DESCRIPTION ^ CHARGE (PER UNIT) ^ UNITS ^ - ; TOTAL CHARGE FOR REV CODE - ; - ; ARRAY("OPV") = NUMBER OF OUTPATIENT VISIT DATES ON BILL - ; ARRAY("OPV",X) = OUTPATIENT VISIT DATE - ; - ; ARRAY("PRC") = NUMBER OF PROCEDURES ON BILL - ; ARRAY("PRC",X) = PROCEDURE CODE ^ PROCEDURE DESCRIPTION ^ PROCEDURE DATE ^ - ; PLACE OF SERVICE CODE ^ PLACE OF SERVICE ^ TYPE OF SERVICE CODE ^ TYPE OF SERVICE - ; - ; ARRAY("DXS") = NUMBER OF DIAGNOSIS ON BILL - ; ARRAY("DXS,X) = DIAGNOSIS CODE ^ DIAGNOSIS - ; - ; ARRAY("RXF") = NUMBER OF PRESCRIPTION REFILLS ON BILL - ; ARRAY("RXF",X) = PRESCRIPTION # ^ REFILL DATE ^ DRUG NAME ^ DAYS SUPPLY ^ QUANTITY ^ NDC # - ; - ; ARRAY("PRD") = NUMBER OF PROSTHETIC ITEMS ON BILL - ; ARRAY("PRD",X) = PROSTHETIC DEVICE ^ DELIVERY DATE - ; - ; IF CONDITION RELATED TO EMPLOYMENT: ARRAY("CRE") = "EMPLOYMENT" - ; IF CONDITION RELATED TO AN AUTO ACCIDENT: ARRAY("CRA") = "AUTO ACCIDENT" ^ STATE (ABBREVIATION) - ; IF CONDITION RELATED TO AN OTHER ACCIDENT: ARRAY("CRO") = "OTHER ACCIDENT" - ; -BILL(IBIFN,ARRAY) ; returns array of information on a specific bill, based on RC requirements - ; - N IBI,IBJ,IBK,IBX,IBY,IBTMP,IBD0,IBDU,IBDU1,IBDI1,IBDS,IBDATE - K ARRAY S ARRAY=1 I '$G(IBIFN)!($G(^DGCR(399,+$G(IBIFN),0))="") S ARRAY=0 Q - F IBI=0,"U","U1","S" S @("IBD"_IBI)=$G(^DGCR(399,IBIFN,IBI)) - S IBX=$P(IBD0,U,21),IBX=$S(IBX="P":"I1",IBX="S":"I2",IBX="T":"I3",1:" ") - S IBDI1=$G(^DGCR(399,IBIFN,IBX)) - ; - S ARRAY("TCG")=$P(IBDU1,U,1,3) - S ARRAY("BN")=$P(IBD0,U,1) - S ARRAY("SR")=$S($P(IBDU,U,5)=1:"Y",1:"N") - S ARRAY("STF")=$P(IBDU,U,1) - S ARRAY("STT")=$P(IBDU,U,2) - S ARRAY("TOC")=$S($P(IBD0,U,5)<3:"INPATIENT",1:"OUTPATIENT") - S ARRAY("TCF")=$$FTN^IBCU3($$FT^IBCU3(IBIFN)) - S ARRAY("DFP")=$P(IBDS,U,12) - S ARRAY("TAX")=$P($G(^IBE(350.9,1,1)),U,5) - ; -INS ; insurance information - S IBX=$G(^DGCR(399,+IBIFN,"M")) - S ARRAY("PIN")=$P(IBX,U,4)_U_$P($G(^DIC(36,+IBDI1,0)),U,11)_U_$P(IBDI1,U,15)_U_$P(IBDI1,U,3)_U_$P(IBDI1,U,17)_U_$P(IBDI1,U,2)_U_$$RTI($P(IBDI1,U,16)) - S ARRAY("PIN","MMA")=$P(IBX,U,5)_U_$P(IBX,U,6)_U_$P($G(^DGCR(399,+IBIFN,"M1")),U,1)_U_$P(IBX,U,7)_U_$$STATE($P(IBX,U,8)) - S ARRAY("PIN","MMA")=ARRAY("PIN","MMA")_U_$$ZIP($P(IBX,U,9))_U_$P($G(^DIC(36,+IBDI1,.13)),U,1) - ; -RC ; revenue codes - S (IBI,IBJ)=0,ARRAY("RVC")=IBJ F S IBI=$O(^DGCR(399,IBIFN,"RC",IBI)) Q:'IBI D - . S IBX=$G(^DGCR(399,IBIFN,"RC",IBI,0)) Q:IBX="" S IBY=$G(^DGCR(399.2,+IBX,0)) - . S IBJ=IBJ+1,ARRAY("RVC")=IBJ - . S ARRAY("RVC",IBJ)=$P(IBY,U,1)_U_$P(IBY,U,2)_U_$P(IBX,U,2)_U_$P(IBX,U,3)_U_$P(IBX,U,4) - ; -OPV ; outpatient visit dates - S (IBI,IBJ)=0,ARRAY("OPV")=IBJ F S IBI=$O(^DGCR(399,IBIFN,"OP",IBI)) Q:'IBI D - . S IBX=$G(^DGCR(399,IBIFN,"OP",IBI,0)) Q:'IBX - . S IBJ=IBJ+1,ARRAY("OPV")=IBJ - . S ARRAY("OPV",IBJ)=+IBX - ; -PRC ; procedure codes - S (IBI,IBJ)=0,ARRAY("PRC")=IBJ F S IBI=$O(^DGCR(399,IBIFN,"CP",IBI)) Q:'IBI D - . S IBX=$G(^DGCR(399,IBIFN,"CP",IBI,0)),IBY="" - . S IBDATE=$P(IBX,U,2) I 'IBDATE S IBDATE=$$BDATE^IBACSV(IBIFN) - . S IBY=$P($$PRCD^IBCEF1($P(IBX,U),1,IBDATE),U,2,3) - . Q:$P(IBY,U)="" - . S IBJ=IBJ+1,ARRAY("PRC")=IBJ - . S ARRAY("PRC",IBJ)=IBY_U_$P(IBX,U,2) - . S IBY=$G(^IBE(353.1,+$P(IBX,U,9),0)),ARRAY("PRC",IBJ)=ARRAY("PRC",IBJ)_U_$P(IBY,U)_U_$P(IBY,U,3) - . S IBY=$G(^IBE(353.2,+$P(IBX,U,10),0)),ARRAY("PRC",IBJ)=ARRAY("PRC",IBJ)_U_$P(IBY,U)_U_$P(IBY,U,3) - ; -DX ; diagnosis codes - K IBTMP D SET^IBCSC4D(IBIFN,"",.IBTMP) - S IBDATE=$$BDATE^IBACSV(IBIFN) - S (IBI,IBJ)=0,ARRAY("DXS")=IBJ F S IBI=$O(IBTMP(IBI)) Q:'IBI D - . S IBX=IBTMP(IBI),IBY=$$ICD9^IBACSV(+IBX,IBDATE) Q:IBY="" - . S IBJ=IBJ+1,ARRAY("DXS")=IBJ - . S ARRAY("DXS",IBJ)=$P(IBY,U)_U_$P(IBY,U,3) - ; -RX ; prescription refills - K IBTMP D SET^IBCSC5A(IBIFN,.IBTMP) - S (IBI,IBJ)=0,ARRAY("RXF")=IBJ F S IBI=$O(IBTMP(IBI)) Q:'IBI D - . S IBK=0 F S IBK=$O(IBTMP(IBI,IBK)) Q:'IBK D - .. S IBX=IBTMP(IBI,IBK) D ZERO^IBRXUTL(+$P(IBX,U,2)) S IBY=$G(^TMP($J,"IBDRUG",+$P(IBX,U,2),.01)) - .. S IBJ=IBJ+1,ARRAY("RXF")=IBJ - .. S ARRAY("RXF",IBJ)=IBI_U_IBK_U_IBY_U_$P(IBX,U,3)_U_$P(IBX,U,4)_U_$P(IBX,U,5) - .. K ^TMP($J,"IBDRUG") - .. Q - ; -PD ; prosthetic items - K IBTMP D SET^IBCSC5B(IBIFN,.IBTMP) - S (IBI,IBJ)=0,ARRAY("PRD")=IBJ F S IBI=$O(IBTMP(IBI)) Q:'IBI D - . S IBK=0 F S IBK=$O(IBTMP(IBI,IBK)) Q:'IBK D - .. S IBX=IBTMP(IBI,IBK) - .. S IBJ=IBJ+1,ARRAY("PRD")=IBJ - .. S ARRAY("PRD",IBJ)=$$PINB^IBCSC5B(+IBX)_U_IBI - ; -CC ; condition related to employment, auto accident (place), other accident - S IBI=0 F S IBI=$O(^DGCR(399,IBIFN,"CC",IBI)) Q:'IBI I $G(^(IBI,0))="02" S ARRAY("CRE")="EMPLOYMENT" - S IBI=0 F S IBI=$O(^DGCR(399,IBIFN,"OC",IBI)) Q:'IBI S IBX=$G(^(IBI,0)) I +IBX D - . S IBY=$G(^DGCR(399.1,+IBX,0)) Q:IBY="" - . I $P(IBY,U,9)=1 S ARRAY("CRE")="EMPLOYMENT" - . I $P(IBY,U,9)=2 S ARRAY("CRA")="AUTO ACCIDENT"_U_$$STATE($P(IBX,U,3)) - . I $P(IBY,U,9)=3 S ARRAY("CRO")="OTHER ACCIDENT" - Q - ; -STATE(X) ; returns 2 letter abbreviation for state - Q $P($G(^DIC(5,+X,0)),U,2) -ZIP(X) ; returns zip in external form - S X=$E(X,1,5)_$S($E(X,6,9)]"":"-"_$E(X,6,9),1:"") - Q X -RTI(X) ; returns external form of relationship to insured - I X'="" S X=$S(X="01":"PATIENT",X="02":"SPOUSE",X="03":"NATURAL CHILD",X="08":"EMPLOYEE",X="09":"UNKNOWN",X="11":"ORGAN DONOR",X="15":"INJURED PLANTIFF",X="18":"PARENT",1:"") - Q X - ;IBRFN3 +IBRFN3 ;ALB/ARH - PASS BILL/CLAIM TO AR ;3/18/96 + ;;2.0;INTEGRATED BILLING;**61,133,210,309**;21-MAR-94 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; + ; Returns information on the bill passed in, all data returned in external format, for AR's RC project + ; + ; If the bill can not be found then returns ARRAY=0 (should be called with ARRAY passed by reference) + ; Otherwise ARRAY=1 and the following array elements may be defined + ; these array elements will only be defined is there is data to return + ; those elements that have multiple entries will be in the form ARRAY("SUB",X) where X=1:1:... + ; + ; ARRAY("BN") = BILL NUMBER + ; ARRAY("SR") = SENSITIVE RECORD? (Y or N) + ; ARRAY("STF") = STATEMENT COVERS FROM DATE - first date covered by bill + ; ARRAY("STT") = STATEMENT COVERS TO DATE - last date covered by bill + ; ARRAY("TCG") = TOTAL CHARGES^OFFSET AMT (PRIOR PAYMENTS)^OFFSET DESC + ; ARRAY("TOC") = BILL TYPE (INPATIENT OR OUTPATIENT) + ; ARRAY("TCF") = BILL FORM TYPE + ; ARRAY("DFP") = DATE FIRST PRINTED + ; ARRAY("TAX") = FEDERAL TAX NUMBER - for facility, a site parameter + ; + ; ARRAY("PIN") = DEBTOR INSURANCE NAME ^ HOSPITAL PROVIDER NUMBER ^ GROUP NAME ^ GROUP NUMBER ^ + ; NAME OF INSURED ^ SUBSCRIBER ID ^ RELATIONSHIP TO INSURED + ; + ; ARRAY("PIN","MMA") = DEBTOR MAILING STREET ADDRESS [LINE 1] ^ + ; MAILING STREET ADDRESS [LINE 2] ^ MAILING STREET ADDRESS [LINE 3] ^ CITY ^ + ; STATE (ABBREVIATED) ^ ZIP ^ PHONE NUMBER + ; + ; ARRAY("RVC") = NUMBER OF REVENUE CODES ON BILL + ; ARRAY("RVC",X) = REVENUE CODE ^ REVENUE CODE DESCRIPTION ^ CHARGE (PER UNIT) ^ UNITS ^ + ; TOTAL CHARGE FOR REV CODE + ; + ; ARRAY("OPV") = NUMBER OF OUTPATIENT VISIT DATES ON BILL + ; ARRAY("OPV",X) = OUTPATIENT VISIT DATE + ; + ; ARRAY("PRC") = NUMBER OF PROCEDURES ON BILL + ; ARRAY("PRC",X) = PROCEDURE CODE ^ PROCEDURE DESCRIPTION ^ PROCEDURE DATE ^ + ; PLACE OF SERVICE CODE ^ PLACE OF SERVICE ^ TYPE OF SERVICE CODE ^ TYPE OF SERVICE + ; + ; ARRAY("DXS") = NUMBER OF DIAGNOSIS ON BILL + ; ARRAY("DXS,X) = DIAGNOSIS CODE ^ DIAGNOSIS + ; + ; ARRAY("RXF") = NUMBER OF PRESCRIPTION REFILLS ON BILL + ; ARRAY("RXF",X) = PRESCRIPTION # ^ REFILL DATE ^ DRUG NAME ^ DAYS SUPPLY ^ QUANTITY ^ NDC # + ; + ; ARRAY("PRD") = NUMBER OF PROSTHETIC ITEMS ON BILL + ; ARRAY("PRD",X) = PROSTHETIC DEVICE ^ DELIVERY DATE + ; + ; IF CONDITION RELATED TO EMPLOYMENT: ARRAY("CRE") = "EMPLOYMENT" + ; IF CONDITION RELATED TO AN AUTO ACCIDENT: ARRAY("CRA") = "AUTO ACCIDENT" ^ STATE (ABBREVIATION) + ; IF CONDITION RELATED TO AN OTHER ACCIDENT: ARRAY("CRO") = "OTHER ACCIDENT" + ; +BILL(IBIFN,ARRAY) ; returns array of information on a specific bill, based on RC requirements + ; + N IBI,IBJ,IBK,IBX,IBY,IBTMP,IBD0,IBDU,IBDU1,IBDI1,IBDS,IBDATE + K ARRAY S ARRAY=1 I '$G(IBIFN)!($G(^DGCR(399,+$G(IBIFN),0))="") S ARRAY=0 Q + F IBI=0,"U","U1","S" S @("IBD"_IBI)=$G(^DGCR(399,IBIFN,IBI)) + S IBX=$P(IBD0,U,21),IBX=$S(IBX="P":"I1",IBX="S":"I2",IBX="T":"I3",1:" ") + S IBDI1=$G(^DGCR(399,IBIFN,IBX)) + ; + S ARRAY("TCG")=$P(IBDU1,U,1,3) + S ARRAY("BN")=$P(IBD0,U,1) + S ARRAY("SR")=$S($P(IBDU,U,5)=1:"Y",1:"N") + S ARRAY("STF")=$P(IBDU,U,1) + S ARRAY("STT")=$P(IBDU,U,2) + S ARRAY("TOC")=$S($P(IBD0,U,5)<3:"INPATIENT",1:"OUTPATIENT") + S ARRAY("TCF")=$$FTN^IBCU3($$FT^IBCU3(IBIFN)) + S ARRAY("DFP")=$P(IBDS,U,12) + S ARRAY("TAX")=$P($G(^IBE(350.9,1,1)),U,5) + ; +INS ; insurance information + S IBX=$G(^DGCR(399,+IBIFN,"M")) + S ARRAY("PIN")=$P(IBX,U,4)_U_$P($G(^DIC(36,+IBDI1,0)),U,11)_U_$P(IBDI1,U,15)_U_$P(IBDI1,U,3)_U_$P(IBDI1,U,17)_U_$P(IBDI1,U,2)_U_$$RTI($P(IBDI1,U,16)) + S ARRAY("PIN","MMA")=$P(IBX,U,5)_U_$P(IBX,U,6)_U_$P($G(^DGCR(399,+IBIFN,"M1")),U,1)_U_$P(IBX,U,7)_U_$$STATE($P(IBX,U,8)) + S ARRAY("PIN","MMA")=ARRAY("PIN","MMA")_U_$$ZIP($P(IBX,U,9))_U_$P($G(^DIC(36,+IBDI1,.13)),U,1) + ; +RC ; revenue codes + S (IBI,IBJ)=0,ARRAY("RVC")=IBJ F S IBI=$O(^DGCR(399,IBIFN,"RC",IBI)) Q:'IBI D + . S IBX=$G(^DGCR(399,IBIFN,"RC",IBI,0)) Q:IBX="" S IBY=$G(^DGCR(399.2,+IBX,0)) + . S IBJ=IBJ+1,ARRAY("RVC")=IBJ + . S ARRAY("RVC",IBJ)=$P(IBY,U,1)_U_$P(IBY,U,2)_U_$P(IBX,U,2)_U_$P(IBX,U,3)_U_$P(IBX,U,4) + ; +OPV ; outpatient visit dates + S (IBI,IBJ)=0,ARRAY("OPV")=IBJ F S IBI=$O(^DGCR(399,IBIFN,"OP",IBI)) Q:'IBI D + . S IBX=$G(^DGCR(399,IBIFN,"OP",IBI,0)) Q:'IBX + . S IBJ=IBJ+1,ARRAY("OPV")=IBJ + . S ARRAY("OPV",IBJ)=+IBX + ; +PRC ; procedure codes + S (IBI,IBJ)=0,ARRAY("PRC")=IBJ F S IBI=$O(^DGCR(399,IBIFN,"CP",IBI)) Q:'IBI D + . S IBX=$G(^DGCR(399,IBIFN,"CP",IBI,0)),IBY="" + . S IBDATE=$P(IBX,U,2) I 'IBDATE S IBDATE=$$BDATE^IBACSV(IBIFN) + . S IBY=$P($$PRCD^IBCEF1($P(IBX,U),1,IBDATE),U,2,3) + . Q:$P(IBY,U)="" + . S IBJ=IBJ+1,ARRAY("PRC")=IBJ + . S ARRAY("PRC",IBJ)=IBY_U_$P(IBX,U,2) + . S IBY=$G(^IBE(353.1,+$P(IBX,U,9),0)),ARRAY("PRC",IBJ)=ARRAY("PRC",IBJ)_U_$P(IBY,U)_U_$P(IBY,U,3) + . S IBY=$G(^IBE(353.2,+$P(IBX,U,10),0)),ARRAY("PRC",IBJ)=ARRAY("PRC",IBJ)_U_$P(IBY,U)_U_$P(IBY,U,3) + ; +DX ; diagnosis codes + K IBTMP D SET^IBCSC4D(IBIFN,"",.IBTMP) + S IBDATE=$$BDATE^IBACSV(IBIFN) + S (IBI,IBJ)=0,ARRAY("DXS")=IBJ F S IBI=$O(IBTMP(IBI)) Q:'IBI D + . S IBX=IBTMP(IBI),IBY=$$ICD9^IBACSV(+IBX,IBDATE) Q:IBY="" + . S IBJ=IBJ+1,ARRAY("DXS")=IBJ + . S ARRAY("DXS",IBJ)=$P(IBY,U)_U_$P(IBY,U,3) + ; +RX ; prescription refills + K IBTMP D SET^IBCSC5A(IBIFN,.IBTMP) + S (IBI,IBJ)=0,ARRAY("RXF")=IBJ F S IBI=$O(IBTMP(IBI)) Q:'IBI D + . S IBK=0 F S IBK=$O(IBTMP(IBI,IBK)) Q:'IBK D + .. S IBX=IBTMP(IBI,IBK) D ZERO^IBRXUTL(+$P(IBX,U,2)) S IBY=$G(^TMP($J,"IBDRUG",+$P(IBX,U,2),.01)) + .. S IBJ=IBJ+1,ARRAY("RXF")=IBJ + .. S ARRAY("RXF",IBJ)=IBI_U_IBK_U_IBY_U_$P(IBX,U,3)_U_$P(IBX,U,4)_U_$P(IBX,U,5) + .. K ^TMP($J,"IBDRUG") + .. Q + ; +PD ; prosthetic items + K IBTMP D SET^IBCSC5B(IBIFN,.IBTMP) + S (IBI,IBJ)=0,ARRAY("PRD")=IBJ F S IBI=$O(IBTMP(IBI)) Q:'IBI D + . S IBK=0 F S IBK=$O(IBTMP(IBI,IBK)) Q:'IBK D + .. S IBX=IBTMP(IBI,IBK) + .. S IBJ=IBJ+1,ARRAY("PRD")=IBJ + .. S ARRAY("PRD",IBJ)=$P($$PIN^IBCSC5B(IBK),U,2)_U_IBI + ; +CC ; condition related to employment, auto accident (place), other accident + S IBI=0 F S IBI=$O(^DGCR(399,IBIFN,"CC",IBI)) Q:'IBI I $G(^(IBI,0))="02" S ARRAY("CRE")="EMPLOYMENT" + S IBI=0 F S IBI=$O(^DGCR(399,IBIFN,"OC",IBI)) Q:'IBI S IBX=$G(^(IBI,0)) I +IBX D + . S IBY=$G(^DGCR(399.1,+IBX,0)) Q:IBY="" + . I $P(IBY,U,9)=1 S ARRAY("CRE")="EMPLOYMENT" + . I $P(IBY,U,9)=2 S ARRAY("CRA")="AUTO ACCIDENT"_U_$$STATE($P(IBX,U,3)) + . I $P(IBY,U,9)=3 S ARRAY("CRO")="OTHER ACCIDENT" + Q + ; +STATE(X) ; returns 2 letter abbreviation for state + Q $P($G(^DIC(5,+X,0)),U,2) +ZIP(X) ; returns zip in external form + S X=$E(X,1,5)_$S($E(X,6,9)]"":"-"_$E(X,6,9),1:"") + Q X +RTI(X) ; returns external form of relationship to insured + I X'="" S X=$S(X="01":"PATIENT",X="02":"SPOUSE",X="03":"NATURAL CHILD",X="08":"EMPLOYEE",X="09":"UNKNOWN",X="11":"ORGAN DONOR",X="15":"INJURED PLANTIFF",X="18":"PARENT",1:"") + Q X + ;IBRFN3 diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBRFN4.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBRFN4.m index 602310d8..01e24abf 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBRFN4.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBRFN4.m @@ -1,142 +1,142 @@ -IBRFN4 ;ALB/TMK - Supported functions for AR/IB DATA EXTRACT ;15-FEB-2005 - ;;2.0;INTEGRATED BILLING;**301,305,389**;21-MAR-94;Build 6 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -IBAREXT(IBIFN,IBD) ; Returns data for claim IBIFN for IB/AR Extract - ; Data returned (pieces): - ; 1-MEDICARE Status (0=not MRA secondary, 1=MRA secondary) - ; 2-Last MRA requested date "S";7 (7 - INTERNAL) - ; 3-Last Electronic extract date "TX";2 (21 - INTERNAL) - ; 4-Printed via EDI "TX";7 (26 - EXTERNAL) - ; 5-Force Claim to Print "TX";8 (27 - EXTERNAL) - ; 6-Claim MRA Status "TX";5 (24 - EXTERNAL) - ; 7-MRA recorded date "TX";3 (22 - INTERNAL) - ; 8-Bill cancelled date "S";17 (17 - INTERNAL) - ; 9-form type 0;19 (.19 - EXTERNAL) - ; 10-Current Payer $$CURR^IBCEF2(IBIFN) returns IEN;NAME (file 36) - ; 11-DRG 0;8==> file 45 (9 - EXTERNAL) - ; 12-ECME # "M1";8 (460 - EXTERNAL) - ; 13-NON-VA Facility - ; 14-#Days Site Not Responsible for MRA ($$DAYS(IBIFN)) - ; 15-National VA id number for Ins Verification (365.12;.02 - INTERNAL) - ; 16-Payer name (file 365.12;.01) - ; 17-Offset Amount (202-INTERNAL) - ; - ; IBD("PRD",seq #)=prosthetic item name^date^bill ien - ; IBD("IN")= TYPE OF PLAN NAME ^ GROUP NUMBER ^ RELATIONSHIP TO INSURED - ; ^ SOURCE OF INFO ^ EDI ID NUMBER - INST ^ EDI ID NUMBER - PROF - ; ^ INSURANCE REIMBURSE - ; IBD("IN","MMA")= MAILING STREET ADDRESS [LINE 1] ^ - ; ^ MAILING STREET ADDRESS [LINE 2] ^ CITY ^ STATE NAME ^ ZIP - ; - N IB,IBI,IBJ,IBK,IBX,IBNODE,IBTMP,IBIN,Z - F IBNODE=0,"S","TX","M","U1" S IB(IBNODE)=$G(^DGCR(399,IBIFN,IBNODE)) - S IBD=$S($$MRASEC^IBCEF4(IBIFN):1,1:0) - S $P(IBD,U,2)=$P(IB("S"),U,7),$P(IBD,U,3)=$P(IB("TX"),U,2) - S $P(IBD,U,4)=$$GET1^DIQ(399,IBIFN_",",26,"E"),$P(IBD,U,5)=$$GET1^DIQ(399,IBIFN_",",27,"E") - S $P(IBD,U,6)=$$GET1^DIQ(399,IBIFN_",",24,"E"),$P(IBD,U,7)=$P(IB("TX"),U,3) - S $P(IBD,U,8)=$P(IB("S"),U,17),$P(IBD,U,9)=$$GET1^DIQ(399,IBIFN_",",.19,"E") - S Z=$$CURR^IBCEF2(IBIFN),$P(IBD,U,10)=Z_$S(Z:";"_$P($G(^DIC(36,Z,0)),U),1:"") - S Z=$P($G(^DIC(36,+Z,3)),U,10),$P(IBD,U,15)=$P($G(^IBE(365.12,+Z,0)),U,2),$P(IBD,U,16)=$P($G(^(0)),U) - S Z=$P(IB(0),U,8),$P(IBD,U,11)=$S(Z:$$GET1^DIQ(45,Z_",",9,"E"),1:"") - S $P(IBD,U,12)=$$GET1^DIQ(399,IBIFN_",",460,"E") - S Z=$P($G(^DGCR(399,IBIFN,"U2")),U,10),$P(IBD,U,13)=$S(Z:$P($G(^IBA(355.93,Z,0)),U,1),1:"") - ; - S $P(IBD,U,14)=$$DAYS(IBIFN) - S $P(IBD,U,17)=$P(IB("U1"),U,2) - ; - K IBTMP D SET^IBCSC5B(IBIFN,.IBTMP) - S (IBI,IBJ)=0 F S IBI=$O(IBTMP(IBI)) Q:'IBI D - . S IBK=0 F S IBK=$O(IBTMP(IBI,IBK)) Q:'IBK D - .. S IBX=IBTMP(IBI,IBK) - .. S IBJ=IBJ+1 - .. S IBD("PRD",IBJ)=$$PINB^IBCSC5B(+IBX)_U_IBI_U_+IBTMP - ; - S Z=" ",IBD("IN")="",DFN=+$P(IB(0),U,2) - F S Z=$O(^DPT(DFN,.312,Z),-1) Q:Z="" D Q:Z="" - . S IBIN=$G(^DPT(DFN,.312,Z,0)) - . I +IB("M")=+IBIN D - .. N IBQ,IBP - .. S IBP=+$P(IBIN,U,18),IBQ=$G(^IBA(355.3,+IBP,0)) - .. S IBD("IN")=$S($P(IBQ,U,9):$$GET1^DIQ(355.3,IBP_",",.09,"E"),1:"")_U_$P(IBQ,U,4)_U_$P(IBIN,U,6)_U_$P($G(^DPT(DFN,.312,Z,1)),U,9) - .. S Z="" - ; - S Z=$G(^DIC(36,+IB("M"),3)) - S $P(IBD("IN"),U,5)=$P(Z,U,4),$P(IBD("IN"),U,6)=$P(Z,U,2) - S $P(IBD("IN"),U,7)=$$GET1^DIQ(36,+IB("M")_",",1,"I") - S Z=$G(^DIC(36,+IB("M"),.11)) - S IBD("IN","MMA")=$P(Z,U,1)_U_$P(Z,U,2)_U_$P(Z,U,4)_U_$S($P(Z,U,5):$P($G(^DIC(5,$P(Z,U,5),0)),U,1),1:"")_U_$P(Z,U,6) - ; - Q IBD - ; -IBACT(IBIFN,IBARRY) ; Returns IB actions for bill ien IBIFN - ;IBARRY should be passed by reference and returns: - ; - ; IBARRY(seq)=AR bill #^reference #^external STATUS^IB ACTION TYPE NAME - ; ^UNITS^TOTAL CHARGE^DT BILLD FROM^DT BILLD TO^AR BILL IEN - ; ^DT ENTRY ADDED^PATIENT SSN^EVENT DATE^RESULTING FROM - ; ^INSTITUTION IEN - ; - N IBNA,IB,IB0,DFN,IBCT,Z - S IBNA=$$BN1^PRCAFN(IBIFN),IB="",IBCT=0 - F S IB=$O(^IB("ABIL",IBNA,IB)) Q:IB="" D - . S IBCT=IBCT+1 - . S IB0=$G(^IB(IB,0)) - . I $G(DFN)="" S DFN=$P(IB0,U,2) - . ; - . S IBARRY=IBNA_U_$P(IB0,U,1)_U_$$GET1^DIQ(350,IB_",",.05,"E") - . S Z=$P(IB0,U,3) - . S IBARRY=IBARRY_U_$S(Z'="":$P($G(^IBE(350.1,Z,0)),U,1),1:"") - . S IBARRY=IBARRY_U_$P(IB0,U,6) ; UNITS - . S IBARRY=IBARRY_U_$P(IB0,U,7) ; TOTAL CHARGE - . S IBARRY=IBARRY_U_$P(IB0,U,14) ; DT BILLD FROM - . S IBARRY=IBARRY_U_$P(IB0,U,15) ; DT BILLD TO - . S IBARRY=IBARRY_U_$P(IB0,U,11) ; AR BILL # - . S IBARRY=IBARRY_U_$P($P($G(^IB(IB,1)),U,2),".",1) ; DT ENTRY ADDED - . S IBARRY=IBARRY_U_$P(^DPT(DFN,0),U,9) ; SSN - . S IBARRY=IBARRY_U_$P(IB0,U,17) ; EVENT DT - . S IBARRY=IBARRY_U_$P(IB0,U,4) ;RESULTING FROM - . S IBARRY=IBARRY_U_$P(IB0,U,13) ; Institution - . S IBARRY(IBCT)=IBARRY,IBARRY="" - Q - ; -PREREG(IBBDT,IBEDT) ;Returns Pre-registration data - N IBDATA - S IBDATA=$$IBAR^IBJDIPR(IBBDT,IBEDT) - Q IBDATA - ; -BUFFER(IBBDT,IBEDT) ;Returns Buffer data - N IBDATA - S IBDATA=$$IBAR^IBCNBOA(IBBDT,IBEDT) - Q IBDATA - ; -DAYS(IBIFN) ; Returns # days site not responsible for MRA - N X,X1,X2,D0 - S X="" ;No. of days - G:'$P(IBD,U,2) DAYSQ - S X2=$P(IBD,U,2) ;MRA Request Date - S X1=$P(IBD,U,7) ;MRA Recorded Date - G:'$$MRASEC^IBCEF4(IBIFN) DAYSQ ; Not MEDICARE secondary - I 'X1!(X1 file 45 (9 - EXTERNAL) + ; 12-ECME # "M1";8 (460 - EXTERNAL) + ; 13-NON-VA Facility + ; 14-#Days Site Not Responsible for MRA ($$DAYS(IBIFN)) + ; 15-National VA id number for Ins Verification (365.12;.02 - INTERNAL) + ; 16-Payer name (file 365.12;.01) + ; 17-Offset Amount (202-INTERNAL) + ; + ; IBD("PRD",seq #)=prosthetic item name^date^bill ien + ; IBD("IN")= TYPE OF PLAN NAME ^ GROUP NUMBER ^ RELATIONSHIP TO INSURED + ; ^ SOURCE OF INFO ^ EDI ID NUMBER - INST ^ EDI ID NUMBER - PROF + ; ^ INSURANCE REIMBURSE + ; IBD("IN","MMA")= MAILING STREET ADDRESS [LINE 1] ^ + ; ^ MAILING STREET ADDRESS [LINE 2] ^ CITY ^ STATE NAME ^ ZIP + ; + N IB,IBI,IBJ,IBK,IBX,IBNODE,IBTMP,IBIN,Z + F IBNODE=0,"S","TX","M","U1" S IB(IBNODE)=$G(^DGCR(399,IBIFN,IBNODE)) + S IBD=$S($$MRASEC^IBCEF4(IBIFN):1,1:0) + S $P(IBD,U,2)=$P(IB("S"),U,7),$P(IBD,U,3)=$P(IB("TX"),U,2) + S $P(IBD,U,4)=$$GET1^DIQ(399,IBIFN_",",26,"E"),$P(IBD,U,5)=$$GET1^DIQ(399,IBIFN_",",27,"E") + S $P(IBD,U,6)=$$GET1^DIQ(399,IBIFN_",",24,"E"),$P(IBD,U,7)=$P(IB("TX"),U,3) + S $P(IBD,U,8)=$P(IB("S"),U,17),$P(IBD,U,9)=$$GET1^DIQ(399,IBIFN_",",.19,"E") + S Z=$$CURR^IBCEF2(IBIFN),$P(IBD,U,10)=Z_$S(Z:";"_$P($G(^DIC(36,Z,0)),U),1:"") + S Z=$P($G(^DIC(36,+Z,3)),U,10),$P(IBD,U,15)=$P($G(^IBE(365.12,+Z,0)),U,2),$P(IBD,U,16)=$P($G(^(0)),U) + S Z=$P(IB(0),U,8),$P(IBD,U,11)=$S(Z:$$GET1^DIQ(45,Z_",",9,"E"),1:"") + S $P(IBD,U,12)=$$GET1^DIQ(399,IBIFN_",",460,"E") + S Z=$P($G(^DGCR(399,IBIFN,"U2")),U,10),$P(IBD,U,13)=$S(Z:$P($G(^IBA(355.93,Z,0)),U,1),1:"") + ; + S $P(IBD,U,14)=$$DAYS(IBIFN) + S $P(IBD,U,17)=$P(IB("U1"),U,2) + ; + K IBTMP D SET^IBCSC5B(IBIFN,.IBTMP) + S (IBI,IBJ)=0 F S IBI=$O(IBTMP(IBI)) Q:'IBI D + . S IBK=0 F S IBK=$O(IBTMP(IBI,IBK)) Q:'IBK D + .. S IBX=IBTMP(IBI,IBK) + .. S IBJ=IBJ+1 + .. S IBD("PRD",IBJ)=$P($$PIN^IBCSC5B(IBK),U,2)_U_IBI_U_+IBTMP + ; + S Z=" ",IBD("IN")="",DFN=+$P(IB(0),U,2) + F S Z=$O(^DPT(DFN,.312,Z),-1) Q:Z="" D Q:Z="" + . S IBIN=$G(^DPT(DFN,.312,Z,0)) + . I +IB("M")=+IBIN D + .. N IBQ,IBP + .. S IBP=+$P(IBIN,U,18),IBQ=$G(^IBA(355.3,+IBP,0)) + .. S IBD("IN")=$S($P(IBQ,U,9):$$GET1^DIQ(355.3,IBP_",",.09,"E"),1:"")_U_$P(IBQ,U,4)_U_$P(IBIN,U,6)_U_$P($G(^DPT(DFN,.312,Z,1)),U,9) + .. S Z="" + ; + S Z=$G(^DIC(36,+IB("M"),3)) + S $P(IBD("IN"),U,5)=$P(Z,U,4),$P(IBD("IN"),U,6)=$P(Z,U,2) + S $P(IBD("IN"),U,7)=$$GET1^DIQ(36,+IB("M")_",",1,"I") + S Z=$G(^DIC(36,+IB("M"),.11)) + S IBD("IN","MMA")=$P(Z,U,1)_U_$P(Z,U,2)_U_$P(Z,U,4)_U_$S($P(Z,U,5):$P($G(^DIC(5,$P(Z,U,5),0)),U,1),1:"")_U_$P(Z,U,6) + ; + Q IBD + ; +IBACT(IBIFN,IBARRY) ; Returns IB actions for bill ien IBIFN + ;IBARRY should be passed by reference and returns: + ; + ; IBARRY(seq)=AR bill #^reference #^external STATUS^IB ACTION TYPE NAME + ; ^UNITS^TOTAL CHARGE^DT BILLD FROM^DT BILLD TO^AR BILL IEN + ; ^DT ENTRY ADDED^PATIENT SSN^EVENT DATE^RESULTING FROM + ; ^INSTITUTION IEN + ; + N IBNA,IB,IB0,DFN,IBCT,Z + S IBNA=$$BN1^PRCAFN(IBIFN),IB="",IBCT=0 + F S IB=$O(^IB("ABIL",IBNA,IB)) Q:IB="" D + . S IBCT=IBCT+1 + . S IB0=$G(^IB(IB,0)) + . I $G(DFN)="" S DFN=$P(IB0,U,2) + . ; + . S IBARRY=IBNA_U_$P(IB0,U,1)_U_$$GET1^DIQ(350,IB_",",.05,"E") + . S Z=$P(IB0,U,3) + . S IBARRY=IBARRY_U_$S(Z'="":$P($G(^IBE(350.1,Z,0)),U,1),1:"") + . S IBARRY=IBARRY_U_$P(IB0,U,6) ; UNITS + . S IBARRY=IBARRY_U_$P(IB0,U,7) ; TOTAL CHARGE + . S IBARRY=IBARRY_U_$P(IB0,U,14) ; DT BILLD FROM + . S IBARRY=IBARRY_U_$P(IB0,U,15) ; DT BILLD TO + . S IBARRY=IBARRY_U_$P(IB0,U,11) ; AR BILL # + . S IBARRY=IBARRY_U_$P($P($G(^IB(IB,1)),U,2),".",1) ; DT ENTRY ADDED + . S IBARRY=IBARRY_U_$P(^DPT(DFN,0),U,9) ; SSN + . S IBARRY=IBARRY_U_$P(IB0,U,17) ; EVENT DT + . S IBARRY=IBARRY_U_$P(IB0,U,4) ;RESULTING FROM + . S IBARRY=IBARRY_U_$P(IB0,U,13) ; Institution + . S IBARRY(IBCT)=IBARRY,IBARRY="" + Q + ; +PREREG(IBBDT,IBEDT) ;Returns Pre-registration data + N IBDATA + S IBDATA=$$IBAR^IBJDIPR(IBBDT,IBEDT) + Q IBDATA + ; +BUFFER(IBBDT,IBEDT) ;Returns Buffer data + N IBDATA + S IBDATA=$$IBAR^IBCNBOA(IBBDT,IBEDT) + Q IBDATA + ; +DAYS(IBIFN) ; Returns # days site not responsible for MRA + N X,X1,X2,D0 + S X="" ;No. of days + G:'$P(IBD,U,2) DAYSQ + S X2=$P(IBD,U,2) ;MRA Request Date + S X1=$P(IBD,U,7) ;MRA Recorded Date + G:'$$MRASEC^IBCEF4(IBIFN) DAYSQ ; Not MEDICARE secondary + I 'X1!(X1IOSL D HDR^IBTOBI Q:IBQUIT - .I IBCNT>1 W ! - .W !?TAB," Ins. Co "_IBCNT_": ",$E($P($G(^DIC(36,+IBINS,0)),"^"),1,23) - .S X=$G(^DIC(36,+IBINS,.13)) - .S PHON=$S($P(X,"^",3)'="":$P(X,"^",3),1:$P(X,"^")) - .S PHON2=$S($P(X,"^",2)'="":$P(X,"^",2),1:$P(X,"^")) - .S P=$S($P(IBETYP,"^",3)=1:5,$P(IBETYP,"^",3)=2:6,$P(IBETYP,"^",3)=3:11,1:1) - .S PHON3=$S($P(X,"^",P)'="":$P(X,"^",P),1:$P(X,"^")) - .W ?TAB2,"Pre-Cert Phone: ",PHON - .W !?TAB," Subsc.: ",$P(IBINS,"^",17) - .W ?TAB2," Type: ",$E($P($G(^IBE(355.1,+$P($G(^IBA(355.3,+$P(IBINS,"^",18),0)),"^",9),0)),"^"),1,18) - .W !?TAB," Subsc. ID: ",$P(IBINS,"^",2) - .W ?TAB2," Group: ",$$GRP^IBCNS($P(IBINS,"^",18)) - .W !?TAB," Coord Ben: ",$E($$EXPAND^IBTRE(2.312,.2,$P(IBINS,"^",20)),1,18) - .W ?TAB2," Billing Phone: ",PHON2 - .W !,?TAB,"Filing Time Fr: ",$$EXPAND^IBTRE(36,.12,$P($G(^DIC(36,+IBINS,0)),"^",12)) - .W ?TAB2," Claims Phone: ",PHON3 - .S X=$P($G(IBINS(IBI,1)),"^",8) I X'="" W !," Policy Comment: " W:($L(X)+23)>IOM ! W " ",X - .D COMM(+$P(IBINS,"^",18)) - .Q:IBQUIT - .W !?30,"-----------------------------------" - W:'IBQUIT !?4,$TR($J(" ",IOM-8)," ","-"),! -INSQ Q - ; -BI ; -- print billing information - Q:$D(IBCTHDR) - I ($Y+8)>IOSL D HDR^IBTOBI Q:IBQUIT -BI1 W !," Billing Information " - N IBDGCR,IBDGCRU1,IBDGCRU,IBAMNT,IBD,I,IBIFN,IBLN,IBECME - S IBIFN=+$P(IBTRND,"^",11) - S IBDGCR=$G(^DGCR(399,IBIFN,0)),IBDGCRU1=$G(^("U1")),IBDGCRU=$G(^("U")) - S IBECME=$P($P($G(^DGCR(399,IBIFN,"M1")),U,8),";") - S IBAMNT=$$BILLD^IBTRED1(IBTRN) - S IBLN=0 - S IBLN=IBLN+1,IBD(IBLN,1)=" Initial Bill: "_$P(IBDGCR,U,1) - I IBECME D - . S IBD(IBLN,1)=IBD(IBLN,1)_"e" - . S IBLN=IBLN+1,IBD(IBLN,1)=" ECME Number: "_IBECME - S IBLN=IBLN+1,IBD(IBLN,1)=" Bill Status: "_$E($$EXPAND^IBTRE(399,.13,$P(IBDGCR,U,13)),1,14) - S IBLN=IBLN+1,IBD(IBLN,1)=" Total Charges: $ "_$J($P(IBAMNT,"^"),8) - S IBLN=IBLN+1,IBD(IBLN,1)=" Amount Paid: $ "_$J($P(IBAMNT,"^",2),8) - ; - I $P(IBTRND,U,19) D - . S IBLN=IBLN+1,IBD(IBLN,1)="Reason Not Billable: "_$$EXPAND^IBTRE(356,.19,$P(IBTRND,U,19)) - . S IBLN=IBLN+1,IBD(IBLN,1)="Additional Comment: "_$P(IBTRND1,U,8) - . Q - ; - I '$P(IBTRND,U,19),$L($P(IBTRND1,U,8))>0 S IBLN=IBLN+1,IBD(IBLN,1)="Additional Comment: "_$P(IBTRND1,U,8) - ; - S IBD(1,2)="Estimated Recv (Pri): $ "_$J($P(IBTRND,"^",21),8) - S IBD(2,2)="Estimated Recv (Sec): $ "_$J($P(IBTRND,"^",22),8) - S IBD(3,2)="Estimated Recv (ter): $ "_$J($P(IBTRND,"^",23),8) - S IBD(4,2)=" Means Test Charges: $ "_$J($P(IBTRND,"^",28),8) - ; - S I=0 F S I=$O(IBD(I)) Q:'I W !,$G(IBD(I,1)),?39,$E($G(IBD(I,2)),1,36) - W:'IBQUIT !,?4,$TR($J(" ",IOM-8)," ","-") - Q - ; -SC ; -- print SC information - I ($Y+7)>IOSL D HDR^IBTOBI Q:IBQUIT - N VAEL,TAB,IBTRCSC - D ELIG^VADPT - W !!," Eligibility Information" - W !," Primary Eligibility: "_$P(VAEL(1),"^",2) - W !," Means Test Status: "_$P(VAEL(9),"^",2) - W !," Service Connected Percent: "_$S(+VAEL(3):+$P(VAEL(3),"^",2)_"%",1:"") - I 'VAEL(3) W "Patient Not Service Connected",!! G SCQ - S TAB=5,IBTRCSC=1 D SC^IBTOAT2 -SCQ W:'IBQUIT !?4,$TR($J(" ",IOM-8)," ","-"),! - Q - ; -COMM(DA) ; -- print comments from GROUP plans. - Q:IBQUIT - W !,"Group Plan Comments: " - Q:'$D(^IBA(355.3,DA,11)) - K ^UTILITY($J,"W") - S DIWL=10,DIWR=IOM-12,DIWF="W" - S IBJ=0 F S IBJ=$O(^IBA(355.3,DA,11,IBJ)) Q:'IBJ S X=^(IBJ,0) D ^DIWP I IOSL<($Y+3) Q:IBQUIT D HDR^IBTOBI - Q:IBQUIT - D ^DIWW - K ^UTILITY($J,"W") - Q +IBTOBI1 ;ALB/AAS - CLAIMS TRACKING BILLING INFORMATION PRINT ;27-OCT-93 + ;;2.0;INTEGRATED BILLING;**276**;21-MAR-94 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; +% ; + F IBTAG="INS","BI","SC","CLIN^IBTOBI4","IR^IBTOBI2","HR^IBTOBI3" D @IBTAG Q:IBQUIT + Q + ; +INS ; -- print ins. stuff + N TAB,TAB2,IBALLIN,IBDT,IBINS,IBCNT,I,X,IBI,PHON,PHON2,PHON3,P,IBI + S TAB=5,TAB2=45,IBALLIN=1 + S IBDT=$P(IBTRND,"^",6) + I '$G(IBDT) S IBDT=DT + W !," Insurance Information " + ; + D ALL^IBCNS1(DFN,"IBINS",1,IBDT) + I $G(IBINS(0))<1 W !,?TAB,"No Insurance Information",!!! G INSQ + S IBI=0,IBCNT=0 F S IBI=$O(IBINS(IBI)) Q:'IBI!(IBQUIT) S IBINS=IBINS(IBI,0) D Q:IBQUIT + .S IBCNT=IBCNT+1 + .I ($Y+8)>IOSL D HDR^IBTOBI Q:IBQUIT + .I IBCNT>1 W ! + .W !?TAB," Ins. Co "_IBCNT_": ",$E($P($G(^DIC(36,+IBINS,0)),"^"),1,23) + .S X=$G(^DIC(36,+IBINS,.13)) + .S PHON=$S($P(X,"^",3)'="":$P(X,"^",3),1:$P(X,"^")) + .S PHON2=$S($P(X,"^",2)'="":$P(X,"^",2),1:$P(X,"^")) + .S P=$S($P(IBETYP,"^",3)=1:5,$P(IBETYP,"^",3)=2:6,$P(IBETYP,"^",3)=3:11,1:1) + .S PHON3=$S($P(X,"^",P)'="":$P(X,"^",P),1:$P(X,"^")) + .W ?TAB2,"Pre-Cert Phone: ",PHON + .W !?TAB," Subsc.: ",$P(IBINS,"^",17) + .W ?TAB2," Type: ",$E($P($G(^IBE(355.1,+$P($G(^IBA(355.3,+$P(IBINS,"^",18),0)),"^",9),0)),"^"),1,18) + .W !?TAB," Subsc. ID: ",$P(IBINS,"^",2) + .W ?TAB2," Group: ",$$GRP^IBCNS($P(IBINS,"^",18)) + .W !?TAB," Coord Ben: ",$E($$EXPAND^IBTRE(2.312,.2,$P(IBINS,"^",20)),1,18) + .W ?TAB2," Billing Phone: ",PHON2 + .W !,?TAB,"Filing Time Fr: ",$$EXPAND^IBTRE(36,.12,$P($G(^DIC(36,+IBINS,0)),"^",12)) + .W ?TAB2," Claims Phone: ",PHON3 + .S X=$P($G(IBINS(IBI,1)),"^",8) I X'="" W !," Policy Comment: " W:($L(X)+23)>IOM ! W " ",X + .D COMM(+$P(IBINS,"^",18)) + .Q:IBQUIT + .W !?30,"-----------------------------------" + W:'IBQUIT !?4,$TR($J(" ",IOM-8)," ","-"),! +INSQ Q + ; +BI ; -- print billing information + Q:$D(IBCTHDR) + I ($Y+8)>IOSL D HDR^IBTOBI Q:IBQUIT +BI1 W !," Billing Information " + N IBDGCR,IBDGCRU1,IBDGCRU,IBAMNT,IBD,I,IBIFN,IBADD,IBECME + S IBIFN=+$P(IBTRND,"^",11) + S IBDGCR=$G(^DGCR(399,IBIFN,0)),IBDGCRU1=$G(^("U1")),IBDGCRU=$G(^("U")) + S IBECME=$P($P($G(^DGCR(399,IBIFN,"M1")),U,8),";") + S IBAMNT=$$BILLD^IBTRED1(IBTRN) + S IBADD=0 + S IBD(1,1)=" Initial Bill: "_$P(IBDGCR,"^") + I IBECME D + . S IBADD=1 + . S IBD(1,1)=IBD(1,1)_"e" + . S IBD(2,1)=" ECME Number: "_IBECME + S IBD(2+IBADD,1)=" Bill Status: "_$E($$EXPAND^IBTRE(399,.13,$P(IBDGCR,"^",13)),1,14) + S IBD(3+IBADD,1)=" Total Charges: $ "_$J($P(IBAMNT,"^"),8) + S IBD(4+IBADD,1)=" Amount Paid: $ "_$J($P(IBAMNT,"^",2),8) + ; + I $P(IBTRND,"^",19) S IBD(5,1)="Reason Not Billable: "_$$EXPAND^IBTRE(356,.19,$P(IBTRND,"^",19)),IBD(6,1)="Additional Comment: "_$P(IBTRND1,"^",8) + ; + S IBD(1,2)="Estimated Recv (Pri): $ "_$J($P(IBTRND,"^",21),8) + S IBD(2,2)="Estimated Recv (Sec): $ "_$J($P(IBTRND,"^",22),8) + S IBD(3,2)="Estimated Recv (ter): $ "_$J($P(IBTRND,"^",23),8) + S IBD(4,2)=" Means Test Charges: $ "_$J($P(IBTRND,"^",28),8) + I $L($P($G(^IBT(356,IBTRN,1)),U,8))>0 S IBD(5,1)="Additional Comment: "_$P($G(^IBT(356,IBTRN,1)),U,8) + S I=0 F S I=$O(IBD(I)) Q:'I W !,$G(IBD(I,1)),?39,$E($G(IBD(I,2)),1,36) + W:'IBQUIT !,?4,$TR($J(" ",IOM-8)," ","-") + Q + ; +SC ; -- print SC information + I ($Y+7)>IOSL D HDR^IBTOBI Q:IBQUIT + N VAEL,TAB,IBTRCSC + D ELIG^VADPT + W !!," Eligibility Information" + W !," Primary Eligibility: "_$P(VAEL(1),"^",2) + W !," Means Test Status: "_$P(VAEL(9),"^",2) + W !," Service Connected Percent: "_$S(+VAEL(3):+$P(VAEL(3),"^",2)_"%",1:"") + I 'VAEL(3) W "Patient Not Service Connected",!! G SCQ + S TAB=5,IBTRCSC=1 D SC^IBTOAT2 +SCQ W:'IBQUIT !?4,$TR($J(" ",IOM-8)," ","-"),! + Q + ; +COMM(DA) ; -- print comments from GROUP plans. + Q:IBQUIT + W !,"Group Plan Comments: " + Q:'$D(^IBA(355.3,DA,11)) + K ^UTILITY($J,"W") + S DIWL=10,DIWR=IOM-12,DIWF="W" + S IBJ=0 F S IBJ=$O(^IBA(355.3,DA,11,IBJ)) Q:'IBJ S X=^(IBJ,0) D ^DIWP I IOSL<($Y+3) Q:IBQUIT D HDR^IBTOBI + Q:IBQUIT + D ^DIWW + K ^UTILITY($J,"W") + Q diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBTOBI4.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBTOBI4.m index 2074dc41..187b635e 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBTOBI4.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBTOBI4.m @@ -1,106 +1,106 @@ -IBTOBI4 ;ALB/AAS - CLAIMS TRACKING BILLING INFORMATION PRINT ;27-OCT-93 - ;;2.0;INTEGRATED BILLING;**91,125,51,210,266,389**;21-MAR-94;Build 6 - ; -CLIN ; -- output clinical information - N IBOE,DGPM - Q:$D(IBCTHDR) - ; - I $P(IBETYP,"^",3)=1 S DGPM=$P(^IBT(356,+IBTRN,0),"^",5) I 'DGPM Q - I $P(IBETYP,"^",3)=2 S IBOE=$P(^IBT(356,+IBTRN,0),"^",4) - F IBTAG="DIAG","PROC","PROV" D @IBTAG Q:IBQUIT - Q - ; -DIAG ; -- print diagnosis information - I '$G(DGPM),('$G(IBOE)) Q - Q:$P(IBETYP,"^",3)>2 - I ($Y+9)>IOSL D HDR^IBTOBI Q:IBQUIT -DIAG1 W !," Diagnosis Information " - N IBXY,SDDXY,ICDVDT - I $G(DGPM) D SET^IBTRE3(+IBTRN) W:'$D(IBXY) !?6,"Nothing on File" D:$D(IBXY) LIST^IBTRE3(.IBXY) - I $G(IBOE) D SET^SDCO4(IBOE) W:'$D(SDDXY) !?6,"Nothing on File" I $D(SDDXY) S ICDVDT=$$TRNDATE^IBACSV(+IBTRN) D LIST^SDCO4(.SDDXY) - ; - D:$G(DGPM) DRG - W:'IBQUIT !?4,$TR($J(" ",IOM-8)," ","-"),! - Q - ; -PROC ; -- print procedure information - Q:$P(IBETYP,"^",3)>2 - I ($Y+9)>IOSL D HDR^IBTOBI Q:IBQUIT -PROC1 W !," Procedure Information " - ; - N IBXY,IBCNT,IBVAL,IBCBK S IBCNT=0 - I $G(DGPM) D SET^IBTRE4(+IBTRN) W:'$D(IBXY) !?6,"Nothing on File" D:$D(IBXY) LIST^IBTRE4(.IBXY) - I '$G(DGPM) D W:'$D(IBXY) !?6,"Nothing on File" D:$D(IBXY) LIST(.IBXY) - .S IBDT=$P($P(IBTRND,"^",6),".") - .; - .S IBVAL("DFN")=DFN,IBVAL("BDT")=IBDT-.000001,IBVAL("EDT")=IBDT\1_".99" - .; Only want to extract procedures from parent encounters to avoid dups - .S IBCBK="I '$P(Y0,U,6) D GETPROC^IBTOBI4(Y,Y0,.IBCNT,.IBXY)" - .D SCAN^IBSDU("PATIENT/DATE",.IBVAL,"",IBCBK) K ^TMP("DIERR",$J) - ; - W:'IBQUIT !?4,$TR($J(" ",IOM-8)," ","-"),! - Q - ; -GETPROC(IBOE,IBOE0,IBCNT,IBXY) ; output: IBXY(cnt) = CPT IFN ^ DT/TM ^ Mod,Mod ^ Encounter Provider (#1204) - N I2,IBCPT,IBCPTS,IBZERR,IBM,IBMODS - D GETCPT^SDOE(IBOE,"IBCPTS","IBZERR") - Q:'$O(IBCPTS(0)) ;No procedures for this encounter - S I2=0 - F S I2=$O(IBCPTS(I2)) Q:'I2 F Z=1:1:$P(IBCPTS(I2),U,16) D - . S IBMODS="",IBM=0 - . F S IBM=$O(IBCPTS(I2,1,IBM)) Q:'IBM S IBMODS=$S(IBMODS="":"",1:",")_$G(IBCPTS(I2,1,IBM,0)) - . S IBCNT=IBCNT+1,IBXY(IBCNT)=$P(IBCPTS(I2),U)_U_+IBOE0_U_IBMODS_U_$P($G(IBCPTS(I2,12)),U,4) - Q - ; -PROV ; -- print provider information - I '$G(DGPM),('$G(IBOE)) Q - Q:$P(IBETYP,"^",3)>2 - I ($Y+9)>IOSL D HDR^IBTOBI Q:IBQUIT -PROV1 W !," Provider Information " - N IBXY,SDPRY - I $G(DGPM) D SET^IBTRE5(+IBTRN) W:'$D(IBXY) !?6,"Nothing on File" D:$D(IBXY) LIST^IBTRE5(.IBXY) - I $G(IBOE) D SET^SDCO3(IBOE) W:'$D(SDPRY) !?6,"Nothing on File" D:$D(SDPRY) LIST^SDCO3(.SDPRY) - W:'IBQUIT !?4,$TR($J(" ",IOM-8)," ","-"),! - Q - ; -LIST(IBXY) ; -- list procedures array - ; Input -- IBXY Diagnosis Array Subscripted by a Number - ; Output -- List Diagnosis Array - N I,IBXD,IBMODS,J,IBM,IBDATE - W ! - S I=0 F S I=$O(IBXY(I)) Q:'I D - . S IBDATE=$P(IBXY(I),U,2) - . S IBXD=$$PRCD^IBCEF1(+IBXY(I)_";ICPT(",1,IBDATE) - . W !?2,I," ",$P(IBXD,U,2),?15,$E($P(IBXD,U,3),1,40),?60,$$DAT1^IBOUTL(IBDATE,"2P") - . S IBMODS=$$MODLST^IBEFUNC2($P(IBXY(I),U,3),1,.IBMODS,IBDATE) - . I IBMODS'="" F J=1:1:$L(IBMODS,",") W !,?15,$P(IBMODS,",",J),?20,$P($G(IBMODS(1)),",",J) - Q - ; -DRG ; -- print drgs. - I '$G(DGPM) Q - Q:$P(IBETYP,"^",3)>1 - I ($Y+9)>IOSL D HDR^IBTOBI Q:IBQUIT -DRG1 W !!," Associated Interim DRG Information " - N IBX,IBDTE,IBDRG - I $G(DGPM) D - .I '$O(^IBT(356.93,"AMVD",DGPM,0)) W !?6,"Nothing on File" Q - .S IBDTE=0 F S IBDTE=$O(^IBT(356.93,"AMVD",DGPM,IBDTE)) Q:'IBDTE S IBDRG=0 F S IBDRG=$O(^IBT(356.93,"AMVD",DGPM,IBDTE,IBDRG)) Q:'IBDRG D - ..S IBX=$G(^IBT(356.93,IBDRG,0)) Q:IBX="" - ..W !?5,$$DAT1^IBOUTL($P(IBX,"^",3)),?16,+IBX," - ",$$DRGTD^IBACSV(+IBX,$P(IBX,"^",3)) - ..W !?21," Estimate ALOS: "_$J($P(IBX,"^",4),4,1) - ..W ?45," Days Remaining: "_$J($P(IBX,"^",5),2) - Q - ; -4 ; -- Visit region for prosthetics - N IBDA,IBRMPR S IBDA=$P(IBTRND,"^",9) D PRODATA^IBTUTL1(IBDA) - S IBD(2,1)=" Item: "_$P($$PIN^IBCSC5B(+IBDA),U,2) - S IBD(3,1)=" Description: "_$G(IBRMPR(660,+IBDA,24,"E")) - S IBD(4,1)=" Quantity: "_$J($G(IBRMPR(660,+IBDA,5,"E")),4) - S IBD(5,1)=" Total Cost: $"_$G(IBRMPR(660,+IBDA,14,"E")) - S IBD(6,1)=" Transaction: "_$G(IBRMPR(660,+IBDA,2,"E")) - S IBD(7,1)=" Vendor: "_$G(IBRMPR(660,+IBDA,7,"E")) - S IBD(8,1)=" Source: "_$G(IBRMPR(660,+IBDA,12,"E")) - S IBD(9,1)=" Delivery Date: "_$G(IBRMPR(660,+IBDA,10,"E")) - S IBD(10,1)=" Remarks: "_$G(IBRMPR(660,+IBDA,16,"E")) - S IBD(11,1)=" Return Status: "_$G(IBRMPR(660,+IBDA,17,"E")) - Q +IBTOBI4 ;ALB/AAS - CLAIMS TRACKING BILLING INFORMATION PRINT ;27-OCT-93 + ;;2.0;INTEGRATED BILLING;**91,125,51,210,266**;21-MAR-94 + ; +CLIN ; -- output clinical information + N IBOE,DGPM + Q:$D(IBCTHDR) + ; + I $P(IBETYP,"^",3)=1 S DGPM=$P(^IBT(356,+IBTRN,0),"^",5) I 'DGPM Q + I $P(IBETYP,"^",3)=2 S IBOE=$P(^IBT(356,+IBTRN,0),"^",4) + F IBTAG="DIAG","PROC","PROV" D @IBTAG Q:IBQUIT + Q + ; +DIAG ; -- print diagnosis information + I '$G(DGPM),('$G(IBOE)) Q + Q:$P(IBETYP,"^",3)>2 + I ($Y+9)>IOSL D HDR^IBTOBI Q:IBQUIT +DIAG1 W !," Diagnosis Information " + N IBXY,SDDXY,ICDVDT + I $G(DGPM) D SET^IBTRE3(+IBTRN) W:'$D(IBXY) !?6,"Nothing on File" D:$D(IBXY) LIST^IBTRE3(.IBXY) + I $G(IBOE) D SET^SDCO4(IBOE) W:'$D(SDDXY) !?6,"Nothing on File" I $D(SDDXY) S ICDVDT=$$TRNDATE^IBACSV(+IBTRN) D LIST^SDCO4(.SDDXY) + ; + D:$G(DGPM) DRG + W:'IBQUIT !?4,$TR($J(" ",IOM-8)," ","-"),! + Q + ; +PROC ; -- print procedure information + Q:$P(IBETYP,"^",3)>2 + I ($Y+9)>IOSL D HDR^IBTOBI Q:IBQUIT +PROC1 W !," Procedure Information " + ; + N IBXY,IBCNT,IBVAL,IBCBK S IBCNT=0 + I $G(DGPM) D SET^IBTRE4(+IBTRN) W:'$D(IBXY) !?6,"Nothing on File" D:$D(IBXY) LIST^IBTRE4(.IBXY) + I '$G(DGPM) D W:'$D(IBXY) !?6,"Nothing on File" D:$D(IBXY) LIST(.IBXY) + .S IBDT=$P($P(IBTRND,"^",6),".") + .; + .S IBVAL("DFN")=DFN,IBVAL("BDT")=IBDT-.000001,IBVAL("EDT")=IBDT\1_".99" + .; Only want to extract procedures from parent encounters to avoid dups + .S IBCBK="I '$P(Y0,U,6) D GETPROC^IBTOBI4(Y,Y0,.IBCNT,.IBXY)" + .D SCAN^IBSDU("PATIENT/DATE",.IBVAL,"",IBCBK) K ^TMP("DIERR",$J) + ; + W:'IBQUIT !?4,$TR($J(" ",IOM-8)," ","-"),! + Q + ; +GETPROC(IBOE,IBOE0,IBCNT,IBXY) ; output: IBXY(cnt) = CPT IFN ^ DT/TM ^ Mod,Mod ^ Encounter Provider (#1204) + N I2,IBCPT,IBCPTS,IBZERR,IBM,IBMODS + D GETCPT^SDOE(IBOE,"IBCPTS","IBZERR") + Q:'$O(IBCPTS(0)) ;No procedures for this encounter + S I2=0 + F S I2=$O(IBCPTS(I2)) Q:'I2 F Z=1:1:$P(IBCPTS(I2),U,16) D + . S IBMODS="",IBM=0 + . F S IBM=$O(IBCPTS(I2,1,IBM)) Q:'IBM S IBMODS=$S(IBMODS="":"",1:",")_$G(IBCPTS(I2,1,IBM,0)) + . S IBCNT=IBCNT+1,IBXY(IBCNT)=$P(IBCPTS(I2),U)_U_+IBOE0_U_IBMODS_U_$P($G(IBCPTS(I2,12)),U,4) + Q + ; +PROV ; -- print provider information + I '$G(DGPM),('$G(IBOE)) Q + Q:$P(IBETYP,"^",3)>2 + I ($Y+9)>IOSL D HDR^IBTOBI Q:IBQUIT +PROV1 W !," Provider Information " + N IBXY,SDPRY + I $G(DGPM) D SET^IBTRE5(+IBTRN) W:'$D(IBXY) !?6,"Nothing on File" D:$D(IBXY) LIST^IBTRE5(.IBXY) + I $G(IBOE) D SET^SDCO3(IBOE) W:'$D(SDPRY) !?6,"Nothing on File" D:$D(SDPRY) LIST^SDCO3(.SDPRY) + W:'IBQUIT !?4,$TR($J(" ",IOM-8)," ","-"),! + Q + ; +LIST(IBXY) ; -- list procedures array + ; Input -- IBXY Diagnosis Array Subscripted by a Number + ; Output -- List Diagnosis Array + N I,IBXD,IBMODS,J,IBM,IBDATE + W ! + S I=0 F S I=$O(IBXY(I)) Q:'I D + . S IBDATE=$P(IBXY(I),U,2) + . S IBXD=$$PRCD^IBCEF1(+IBXY(I)_";ICPT(",1,IBDATE) + . W !?2,I," ",$P(IBXD,U,2),?15,$E($P(IBXD,U,3),1,40),?60,$$DAT1^IBOUTL(IBDATE,"2P") + . S IBMODS=$$MODLST^IBEFUNC2($P(IBXY(I),U,3),1,.IBMODS,IBDATE) + . I IBMODS'="" F J=1:1:$L(IBMODS,",") W !,?15,$P(IBMODS,",",J),?20,$P($G(IBMODS(1)),",",J) + Q + ; +DRG ; -- print drgs. + I '$G(DGPM) Q + Q:$P(IBETYP,"^",3)>1 + I ($Y+9)>IOSL D HDR^IBTOBI Q:IBQUIT +DRG1 W !!," Associated Interim DRG Information " + N IBX,IBDTE,IBDRG + I $G(DGPM) D + .I '$O(^IBT(356.93,"AMVD",DGPM,0)) W !?6,"Nothing on File" Q + .S IBDTE=0 F S IBDTE=$O(^IBT(356.93,"AMVD",DGPM,IBDTE)) Q:'IBDTE S IBDRG=0 F S IBDRG=$O(^IBT(356.93,"AMVD",DGPM,IBDTE,IBDRG)) Q:'IBDRG D + ..S IBX=$G(^IBT(356.93,IBDRG,0)) Q:IBX="" + ..W !?5,$$DAT1^IBOUTL($P(IBX,"^",3)),?16,+IBX," - ",$$DRGTD^IBACSV(+IBX,$P(IBX,"^",3)) + ..W !?21," Estimate ALOS: "_$J($P(IBX,"^",4),4,1) + ..W ?45," Days Remaining: "_$J($P(IBX,"^",5),2) + Q + ; +4 ; -- Visit region for prosthetics + N IBDA,IBRMPR S IBDA=$P(IBTRND,"^",9) D PRODATA^IBTUTL1(IBDA) + S IBD(2,1)=" Item: "_$G(IBRMPR(660,+IBDA,4,"E")) + S IBD(3,1)=" Description: "_$G(IBRMPR(660,+IBDA,24,"E")) + S IBD(4,1)=" Quantity: "_$J($G(IBRMPR(660,+IBDA,5,"E")),4) + S IBD(5,1)=" Total Cost: $"_$G(IBRMPR(660,+IBDA,14,"E")) + S IBD(6,1)=" Transaction: "_$G(IBRMPR(660,+IBDA,2,"E")) + S IBD(7,1)=" Vendor: "_$G(IBRMPR(660,+IBDA,7,"E")) + S IBD(8,1)=" Source: "_$G(IBRMPR(660,+IBDA,12,"E")) + S IBD(9,1)=" Delivery Date: "_$G(IBRMPR(660,+IBDA,10,"E")) + S IBD(10,1)=" Remarks: "_$G(IBRMPR(660,+IBDA,16,"E")) + S IBD(11,1)=" Return Status: "_$G(IBRMPR(660,+IBDA,17,"E")) + Q diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBTRED01.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBTRED01.m index 8198e477..832b89eb 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBTRED01.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBTRED01.m @@ -1,81 +1,81 @@ -IBTRED01 ;ALB/AAS - EXPAND/EDIT CLAIMS TRACKING ENTRY - CONT; 01-JUL-1993 - ;;2.0;INTEGRATED BILLING;**389**;21-MAR-94;Build 6 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -% I '$G(IBTRN)!($G(IORVON)="") G ^IBTRED - D UR,REVIEW,SC - Q -REVIEW ; -- List Reviews done - N OFFSET,START,IBTRV,IDT,IBTRVD,IBTRTP - S START=24,OFFSET=2,IBLCNT=0 - D SET^IBCNSP(START,OFFSET," Hospital Reviews Entered ",IORVON,IORVOFF) - S IDT="" F S IDT=$O(^IBT(356.1,"ATIDT",IBTRN,IDT)) Q:'IDT S IBTRV="" F S IBTRV=$O(^IBT(356.1,"ATIDT",IBTRN,IDT,IBTRV)) Q:'IBTRV D - .S IBLCNT=$G(IBLCNT)+1 - .S IBTRVD=$G(^IBT(356.1,IBTRV,0)) - .S IBTRTP=$P($G(^IBE(356.11,+$P(IBTRVD,"^",22),0)),"^") - .;D SET^IBCNSP(START+IBLCNT,OFFSET,$J(IBLCNT,2)_". "_$E(IBTRTP_" ",1,28)_" on "_$E($$DAT1^IBOUTL($P(IBTRVD,"^"),"2P")_" ",1,8)_" Status: "_$$EXPAND^IBTRE(356.1,.21,$P(IBTRVD,"^",21))) - .S IBTEXT=$E(IBTRTP_" Status: "_$$EXPAND^IBTRE(356.1,.21,$P(IBTRVD,"^",21))_" ",1,50) - .D SET^IBCNSP(START+IBLCNT,OFFSET,$J(IBLCNT,2)_". "_IBTEXT_" on "_$$DAT1^IBOUTL($P(IBTRVD,"^"),"2P")) - .Q - D COMM - Q -COMM ; -- List Communication Entries - N OFFSET,START,IDT,IBTRCD,IBCNT - S START=26+$G(IBLCNT),OFFSET=2 - D SET^IBCNSP(START,OFFSET," Insurance Reviews Entered ",IORVON,IORVOFF) - S IDT="" F S IDT=$O(^IBT(356.2,"ATIDT",IBTRN,IDT)) Q:'IDT S IBTRC="" F S IBTRC=$O(^IBT(356.2,"ATIDT",IBTRN,IDT,IBTRC)) Q:'IBTRC D - .S IBLCNT=$G(IBLCNT)+1,IBCNT=$G(IBCNT)+1 - .S IBTRCD=$G(^IBT(356.2,IBTRC,0)) - .S IBTEXT=$E($$EXPAND^IBTRE(356.2,.04,$P(IBTRCD,"^",4))_" Contact "_$$EXPAND^IBTRE(356.2,.11,$P(IBTRCD,"^",11))_" ",1,50) - .D SET^IBCNSP(START+IBCNT,OFFSET,$J(IBCNT,2)_". "_IBTEXT_" on "_$$DAT1^IBOUTL(+IBTRCD,"2P")) - .Q - Q - ; -SC ; -- Show eligibility/sc conditions - N OFFSET,START,IDT,IBTRCD,IBCNT,I1,I2,I3 - S START=28+$G(IBLCNT),OFFSET=2 -SC1 D SET^IBCNSP(START,OFFSET," Service Connected Conditions: ",IORVON,IORVOFF) - D ELIG^VADPT - S IBLCNT=$G(IBLCNT)+1,IBCNT=$G(IBCNT)+1,I3=0 - ; - D SET^IBCNSP(START+IBCNT,OFFSET,"Service Connected: "_$S('$G(VAEL(3)):"NO",1:$P(VAEL(3),"^",2)_"%")) - ; - F I=0:0 S I=$O(^DPT(DFN,.372,I)) Q:'I D - .S I1=^DPT(DFN,.372,I,0) - .Q:'$P(I1,"^",3) - .S I2=$G(^DIC(31,+I1,0)) - .S:$P(I2,"^",4)'="" I2=$P(I2,"^",4) - .S I2=$P(I2,"^") - .S IBLCNT=$G(IBLCNT)+1,IBCNT=$G(IBCNT)+1 - .D SET^IBCNSP(START+IBCNT,OFFSET,$J(IBCNT-1,2)_". "_$E(I2_" ",1,45)_$J($P(I1,"^",2),3)_"%") - .S I3=I3+1 - .Q - I 'I3 S IBLCNT=$G(IBLCNT)+1,IBCNT=$G(IBCNT)+1 D SET^IBCNSP(START+IBCNT,OFFSET,$S('$O(^DPT(DFN,.372,0)):"NONE STATED",1:"NO SC DISABILITIES LISTED")) S I3=1 -SCQ Q - ; -UR ; -- ur information region - N OFFSET,START - S START=7,OFFSET=51 - D SET^IBCNSP(START,OFFSET," Review Information ",IORVON,IORVOFF) - D SET^IBCNSP(START+1,OFFSET," Insurance Claim: "_$$EXPAND^IBTRE(356,.24,$P(IBTRND,"^",24))) - D SET^IBCNSP(START+2,OFFSET," Follow-up Type: "_$$EXPAND^IBTRE(356,1.07,$P(IBTRND1,"^",7))) - D SET^IBCNSP(START+3,OFFSET," Random Sample: "_$$EXPAND^IBTRE(356,.25,$P(IBTRND,"^",25))) - D SET^IBCNSP(START+4,OFFSET,"Special Condition: "_$$EXPAND^IBTRE(356,.26,$P(IBTRND,"^",26))) - D SET^IBCNSP(START+5,OFFSET," Local Addition: "_$$EXPAND^IBTRE(356,.27,$P(IBTRND,"^",27))) - D SET^IBCNSP(START+6,OFFSET," Ins. Reviewer: "_$$EXPAND^IBTRE(356,1.06,$P(IBTRND1,"^",6))) - D SET^IBCNSP(START+7,OFFSET,"Hospital Reviewer: "_$$EXPAND^IBTRE(356,1.05,$P(IBTRND1,"^",5))) - Q - ; -4 ; -- Visit region for prosthetics - N IBDA,IBRMPR S IBDA=$P(IBTRND,"^",9) D PRODATA^IBTUTL1(IBDA) - D SET^IBCNSP(START+2,OFFSET," Item: "_$P($$PIN^IBCSC5B(+IBDA),U,2)) - D SET^IBCNSP(START+3,OFFSET," Description: "_$G(IBRMPR(660,+IBDA,24,"E"))) - D SET^IBCNSP(START+4,OFFSET," Quantity: "_$J($G(IBRMPR(660,+IBDA,5,"E")),$L($G(IBRMPR(660,+IBDA,14,"E"))))) - D SET^IBCNSP(START+5,OFFSET," Total Cost: $"_$G(IBRMPR(660,+IBDA,14,"E"))) - D SET^IBCNSP(START+6,OFFSET," Transaction: "_$G(IBRMPR(660,+IBDA,2,"E"))) - D SET^IBCNSP(START+7,OFFSET," Vendor: "_$G(IBRMPR(660,+IBDA,7,"E"))) - D SET^IBCNSP(START+8,OFFSET," Source: "_$G(IBRMPR(660,+IBDA,12,"E"))) - D SET^IBCNSP(START+9,OFFSET," Delivery Date: "_$G(IBRMPR(660,+IBDA,10,"E"))) - D SET^IBCNSP(START+10,OFFSET," Remarks: "_$G(IBRMPR(660,+IBDA,16,"E"))) - D SET^IBCNSP(START+11,OFFSET," Return Status: "_$G(IBRMPR(660,+IBDA,17,"E"))) - Q +IBTRED01 ;ALB/AAS - EXPAND/EDIT CLAIMS TRACKING ENTRY - CONT; 01-JUL-1993 + ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; +% I '$G(IBTRN)!($G(IORVON)="") G ^IBTRED + D UR,REVIEW,SC + Q +REVIEW ; -- List Reviews done + N OFFSET,START,IBTRV,IDT,IBTRVD,IBTRTP + S START=24,OFFSET=2,IBLCNT=0 + D SET^IBCNSP(START,OFFSET," Hospital Reviews Entered ",IORVON,IORVOFF) + S IDT="" F S IDT=$O(^IBT(356.1,"ATIDT",IBTRN,IDT)) Q:'IDT S IBTRV="" F S IBTRV=$O(^IBT(356.1,"ATIDT",IBTRN,IDT,IBTRV)) Q:'IBTRV D + .S IBLCNT=$G(IBLCNT)+1 + .S IBTRVD=$G(^IBT(356.1,IBTRV,0)) + .S IBTRTP=$P($G(^IBE(356.11,+$P(IBTRVD,"^",22),0)),"^") + .;D SET^IBCNSP(START+IBLCNT,OFFSET,$J(IBLCNT,2)_". "_$E(IBTRTP_" ",1,28)_" on "_$E($$DAT1^IBOUTL($P(IBTRVD,"^"),"2P")_" ",1,8)_" Status: "_$$EXPAND^IBTRE(356.1,.21,$P(IBTRVD,"^",21))) + .S IBTEXT=$E(IBTRTP_" Status: "_$$EXPAND^IBTRE(356.1,.21,$P(IBTRVD,"^",21))_" ",1,50) + .D SET^IBCNSP(START+IBLCNT,OFFSET,$J(IBLCNT,2)_". "_IBTEXT_" on "_$$DAT1^IBOUTL($P(IBTRVD,"^"),"2P")) + .Q + D COMM + Q +COMM ; -- List Communication Entries + N OFFSET,START,IDT,IBTRCD,IBCNT + S START=26+$G(IBLCNT),OFFSET=2 + D SET^IBCNSP(START,OFFSET," Insurance Reviews Entered ",IORVON,IORVOFF) + S IDT="" F S IDT=$O(^IBT(356.2,"ATIDT",IBTRN,IDT)) Q:'IDT S IBTRC="" F S IBTRC=$O(^IBT(356.2,"ATIDT",IBTRN,IDT,IBTRC)) Q:'IBTRC D + .S IBLCNT=$G(IBLCNT)+1,IBCNT=$G(IBCNT)+1 + .S IBTRCD=$G(^IBT(356.2,IBTRC,0)) + .S IBTEXT=$E($$EXPAND^IBTRE(356.2,.04,$P(IBTRCD,"^",4))_" Contact "_$$EXPAND^IBTRE(356.2,.11,$P(IBTRCD,"^",11))_" ",1,50) + .D SET^IBCNSP(START+IBCNT,OFFSET,$J(IBCNT,2)_". "_IBTEXT_" on "_$$DAT1^IBOUTL(+IBTRCD,"2P")) + .Q + Q + ; +SC ; -- Show eligibility/sc conditions + N OFFSET,START,IDT,IBTRCD,IBCNT,I1,I2,I3 + S START=28+$G(IBLCNT),OFFSET=2 +SC1 D SET^IBCNSP(START,OFFSET," Service Connected Conditions: ",IORVON,IORVOFF) + D ELIG^VADPT + S IBLCNT=$G(IBLCNT)+1,IBCNT=$G(IBCNT)+1,I3=0 + ; + D SET^IBCNSP(START+IBCNT,OFFSET,"Service Connected: "_$S('$G(VAEL(3)):"NO",1:$P(VAEL(3),"^",2)_"%")) + ; + F I=0:0 S I=$O(^DPT(DFN,.372,I)) Q:'I D + .S I1=^DPT(DFN,.372,I,0) + .Q:'$P(I1,"^",3) + .S I2=$G(^DIC(31,+I1,0)) + .S:$P(I2,"^",4)'="" I2=$P(I2,"^",4) + .S I2=$P(I2,"^") + .S IBLCNT=$G(IBLCNT)+1,IBCNT=$G(IBCNT)+1 + .D SET^IBCNSP(START+IBCNT,OFFSET,$J(IBCNT-1,2)_". "_$E(I2_" ",1,45)_$J($P(I1,"^",2),3)_"%") + .S I3=I3+1 + .Q + I 'I3 S IBLCNT=$G(IBLCNT)+1,IBCNT=$G(IBCNT)+1 D SET^IBCNSP(START+IBCNT,OFFSET,$S('$O(^DPT(DFN,.372,0)):"NONE STATED",1:"NO SC DISABILITIES LISTED")) S I3=1 +SCQ Q + ; +UR ; -- ur information region + N OFFSET,START + S START=7,OFFSET=51 + D SET^IBCNSP(START,OFFSET," Review Information ",IORVON,IORVOFF) + D SET^IBCNSP(START+1,OFFSET," Insurance Claim: "_$$EXPAND^IBTRE(356,.24,$P(IBTRND,"^",24))) + D SET^IBCNSP(START+2,OFFSET," Follow-up Type: "_$$EXPAND^IBTRE(356,1.07,$P(IBTRND1,"^",7))) + D SET^IBCNSP(START+3,OFFSET," Random Sample: "_$$EXPAND^IBTRE(356,.25,$P(IBTRND,"^",25))) + D SET^IBCNSP(START+4,OFFSET,"Special Condition: "_$$EXPAND^IBTRE(356,.26,$P(IBTRND,"^",26))) + D SET^IBCNSP(START+5,OFFSET," Local Addition: "_$$EXPAND^IBTRE(356,.27,$P(IBTRND,"^",27))) + D SET^IBCNSP(START+6,OFFSET," Ins. Reviewer: "_$$EXPAND^IBTRE(356,1.06,$P(IBTRND1,"^",6))) + D SET^IBCNSP(START+7,OFFSET,"Hospital Reviewer: "_$$EXPAND^IBTRE(356,1.05,$P(IBTRND1,"^",5))) + Q + ; +4 ; -- Visit region for prosthetics + N IBDA,IBRMPR S IBDA=$P(IBTRND,"^",9) D PRODATA^IBTUTL1(IBDA) + D SET^IBCNSP(START+2,OFFSET," Item: "_$G(IBRMPR(660,+IBDA,4,"E"))) + D SET^IBCNSP(START+3,OFFSET," Description: "_$G(IBRMPR(660,+IBDA,24,"E"))) + D SET^IBCNSP(START+4,OFFSET," Quantity: "_$J($G(IBRMPR(660,+IBDA,5,"E")),$L($G(IBRMPR(660,+IBDA,14,"E"))))) + D SET^IBCNSP(START+5,OFFSET," Total Cost: $"_$G(IBRMPR(660,+IBDA,14,"E"))) + D SET^IBCNSP(START+6,OFFSET," Transaction: "_$G(IBRMPR(660,+IBDA,2,"E"))) + D SET^IBCNSP(START+7,OFFSET," Vendor: "_$G(IBRMPR(660,+IBDA,7,"E"))) + D SET^IBCNSP(START+8,OFFSET," Source: "_$G(IBRMPR(660,+IBDA,12,"E"))) + D SET^IBCNSP(START+9,OFFSET," Delivery Date: "_$G(IBRMPR(660,+IBDA,10,"E"))) + D SET^IBCNSP(START+10,OFFSET," Remarks: "_$G(IBRMPR(660,+IBDA,16,"E"))) + D SET^IBCNSP(START+11,OFFSET," Return Status: "_$G(IBRMPR(660,+IBDA,17,"E"))) + Q diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBTRKR5.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBTRKR5.m index b55910ef..93e7b9fc 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBTRKR5.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBTRKR5.m @@ -1,136 +1,136 @@ -IBTRKR5 ;ALB/AAS - CLAIMS TRACKING - ADD/TRACK PROSTHETICS ;13-JAN-94 - ;;2.0;INTEGRATED BILLING;**13,260,312,339,389**;21-MAR-94;Build 6 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -% ; -- entry point for nightly background job - N IBTSBDT,IBTSEDT - S IBTSBDT=$$FMADD^XLFDT(DT,-30)-.1 - S IBTSEDT=$$FMADD^XLFDT(DT,-3)+.9 - D EN1 - Q - ; -EN ; -- entry point to ask date range - N IBSWINFO S IBSWINFO=$$SWSTAT^IBBAPI() ;IB*2.0*312 - N IBBDT,IBEDT,IBTSBDT,IBTSEDT,IBTALK - S IBTALK=1 - I '$P($G(^IBE(350.9,1,6)),"^",4) W !!,"I'm sorry, Tracking of Prosthetics is currently turned off." G ENQ - W !!!,"Select the Date Range of Prosthetics to Add to Claims Tracking.",! - D DATE^IBOUTL - I IBBDT<1!(IBEDT<1) G ENQ - S IBTSBDT=IBBDT,IBTSEDT=IBEDT - ; - ; -- check selected dates ;IB*2.0*312 - ; Do NOT PROCESS on VistA if Start or End>=Switch Eff Dt ;CCR-930 - I +IBSWINFO,((IBTSBDT+1)>$P(IBSWINFO,"^",2))!((IBTSEDT+1)>$P(IBSWINFO,"^",2)) D G EN - .W !!,"The Begin OR End Date CANNOT be on or after the PFSS Effective date" - .W ": ",$$FMTE^XLFDT($P(IBSWINFO,"^",2)) - ; - S IBTRKR=$G(^IBE(350.9,1,6)) - ; start date can't be before parameters - I +IBTRKR,IBTSBDT<+IBTRKR S IBTSBDT=IBTRKR W !!,"Begin date is before Claims Tracking Start Date, changed to ",$$DAT1^IBOUTL(IBTSBDT) - ; -- end date into future - I IBTSEDT>$$FMADD^XLFDT(DT,-3) W !!,"I'll automatically change the end date to 3 days prior to the date queued to run." - ; - W !!!,"I'm going to automatically queue this off and send you a" - W !,"mail message when complete.",! - S ZTIO="",ZTRTN="EN1^IBTRKR5",ZTSAVE("IB*")="",ZTDESC="IB - Add Prosthetics to Claims Tracking" - D ^%ZTLOAD I $G(ZTSK) K ZTSK W !,"Request Queued" -ENQ K ZTSK,ZTIO,ZTSAVE,ZTDESC,ZTRTN - D HOME^%ZIS - Q - ; -EN1 ; -- add prostethics to claims tracking file - N I,J,X,Y,IBTRKR,IBDT,DFN,IBDATA,IBCNT,IBCNT1,IBCNT2,IBDTS - N IBSWINFO S IBSWINFO=$$SWSTAT^IBBAPI() ;IB*2.0*312 - ; - ; -- check parameters - S IBTRKR=$G(^IBE(350.9,1,6)) - G:'$P(IBTRKR,"^",5) EN1Q ; quit if prothetics tracking off - I +IBTRKR,IBTSBDT<+IBTRKR S IBTSBDT=IBTRKR ; start date can't be before parameters - ; - ; -- users can queue into future, make sure dates not after date run - I IBTSEDT>$$FMADD^XLFDT(DT,-3) S IBMESS="(Selected end date of "_$$DAT1^IBOUTL(IBTSEDT)_" automatically changed to "_$$DAT1^IBOUTL($$FMADD^XLFDT(DT,-3))_".)",IBTSEDT=$$FMADD^XLFDT(DT,-3) - ; - ;S IBPRTYP=$O(^IBE(356.6,"AC",3,0)) ; this is the event type pointer for prosthetics - ; - ; -- cnt= total count, cnt1=count added nsc, cnt2=count of pending - S (IBCNT,IBCNT1,IBCNT2)=0 - S (IBDTS,IBDT)=IBTSBDT-.0001 - ; - ; loop twice, once for shipmnet date (new search), and once for - ; delivery date (old search) for backward compatibility. - F S IBDT=$O(^RMPR(660,"AF",IBDT)) Q:'IBDT!(IBDT>IBTSEDT) D - .; Do NOT PROCESS on VistA if IBDT>=Switch Eff Date ;CCR-930 - .I +IBSWINFO,(IBDT+1)>$P(IBSWINFO,"^",2) Q ;IB*2.0*312 - .S IBDA=0 F S IBDA=$O(^RMPR(660,"AF",IBDT,IBDA)) Q:'IBDA D PRCHK - ; - ; reset date and do old check - S IBDT=IBDTS - F S IBDT=$O(^RMPR(660,"CT",IBDT)) Q:'IBDT!(IBDT>IBTSEDT) D - .; Do NOT PROCESS on VistA if IBDT>=Switch Eff Date ;CCR-930 - .I +IBSWINFO,(IBDT+1)>$P(IBSWINFO,"^",2) Q ;IB*2.0*312 - .S IBDA="" F S IBDA=$O(^RMPR(660,"CT",IBDT,IBDA)) Q:'IBDA D PRCHK - ; - I $G(IBTALK) D BULL ;^IBTRKR51 -EN1Q I $D(ZTQUEUED) S ZTREQ="@" - Q - ; -PRCHK ; -- check and add item - N IBE,IBP,IBDX,IBRMARK,IBARR,IBT - S IBCNT=IBCNT+1,IBRMARK="" - I '$D(ZTQUEUED),($G(IBTALK)) W "." - ; - S IBDATA=$G(^RMPR(660,+IBDA,0)) Q:IBDATA="" - S DFN=$P(IBDATA,"^",2) Q:'DFN - D CL^SDCO21(DFN,IBDT,"",.IBARR) - ; - ; -- checks copied from rmprbil v2.0 /feb 2, 1994 - Q:'$D(^RMPR(660,+IBDA,"AM")) - Q:$P(^RMPR(660,+IBDA,0),U,9)=""!($P(^(0),U,12)="")!($P(^(0),U,14)="V")!($P(^(0),U,2)="")!($P(^(0),U,15)="*") - ;Q:($P(^RMPR(660,+IBDA,"AM"),U,3)=2)!($P(^("AM"),U,3)=3) - ; - ; - I $O(^IBT(356,"APRO",IBDA,0)) G PRCHKQ ; already in claims tracking - ; - ; -- see if tracking only insured and pt is insured - I $P(IBTRKR,"^",5)=1,'$$INSURED^IBCNS1(DFN,IBDT) G PRCHKQ ; patient not insure - ; - ; -- if clasifications required, check exemptions - I '$D(IBARR) G CLQ - S IBE=0 F IBP=1:1:4 S IBDX(IBP)=$G(^RMPR(660,+IBDA,"BA"_IBP)) I IBDX(IBP) S IBE=1 - I 'IBE S IBRMARK="NEEDS SC DETERMINATION" G CLQ ; no ICD node in RMPR, use old method of determining status - S IBE=0 F S IBE=$O(IBARR(IBE)) Q:'IBE!($L($G(IBRMARK))) F IBP=1:1:4 Q:$L($G(IBRMARK)) I IBDX(IBP) S IBRMARK=$S($P(IBDX(IBP),"^",IBE+1):$P($T(CLTXT+IBE),";",3),$P(IBDX(IBP),"^",IBE+1)=0:"",1:"NEEDS SC DETERMINATION") - ; - ; -CLQ ; -- ok to add to tracking module - D PRO^IBTUTL1(DFN,IBDT,IBDA,$G(IBRMARK)) I '$D(ZTQUEUED),$G(IBTALK) W "+" - I $G(IBRMARK)'="" S IBCNT2=IBCNT2+1 - I $G(IBRMARK)="" S IBCNT1=IBCNT1+1 - K VAEL,VA,IBDATA,DFN,X,Y -PRCHKQ Q - ; -BULL ; -- send bulletin - ; - S XMSUB="Prosthetic Items added to Claims Tracking Complete" - S IBT(1)="The process to automatically add Prosthetic Items has successfully completed." - S IBT(1.1)="" - S IBT(2)=" Start Date: "_$$DAT1^IBOUTL(IBTSBDT) - S IBT(3)=" End Date: "_$$DAT1^IBOUTL(IBTSEDT) - I $D(IBMESS) S IBT(3.1)=IBMESS - S IBT(4)="" - S IBT(5)=" Total Prosthetics Items checked: "_$G(IBCNT) - S IBT(6)="Total NSC Prosthetic Items Added: "_$G(IBCNT1) - S IBT(7)=" Total SC Prosthetic Items Added: "_$G(IBCNT2) - S IBT(8)="" - S IBT(9)="*The items added as SC require determination and editing to be billed" - D SEND^IBTRKR31 -BULLQ Q - ; -CLTXT ; classification text for reason not billable - ;;AGENT ORANGE - ;;IONIZING RADIATION - ;;SC TREATMENT - ;;SOUTHWEST ASIA - ;;MILITARY SEXUAL TRAUMA - ;;HEAD/NECK CANCER - ;;COMBAT VETERAN +IBTRKR5 ;ALB/AAS - CLAIMS TRACKING - ADD/TRACK PROSTHETICS ;13-JAN-94 + ;;2.0;INTEGRATED BILLING;**13,260,312,339**;21-MAR-94;Build 2 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; +% ; -- entry point for nightly background job + N IBTSBDT,IBTSEDT + S IBTSBDT=$$FMADD^XLFDT(DT,-30)-.1 + S IBTSEDT=$$FMADD^XLFDT(DT,-3)+.9 + D EN1 + Q + ; +EN ; -- entry point to ask date range + N IBSWINFO S IBSWINFO=$$SWSTAT^IBBAPI() ;IB*2.0*312 + N IBBDT,IBEDT,IBTSBDT,IBTSEDT,IBTALK + S IBTALK=1 + I '$P($G(^IBE(350.9,1,6)),"^",4) W !!,"I'm sorry, Tracking of Prosthetics is currently turned off." G ENQ + W !!!,"Select the Date Range of Prosthetics to Add to Claims Tracking.",! + D DATE^IBOUTL + I IBBDT<1!(IBEDT<1) G ENQ + S IBTSBDT=IBBDT,IBTSEDT=IBEDT + ; + ; -- check selected dates ;IB*2.0*312 + ; Do NOT PROCESS on VistA if Start or End>=Switch Eff Dt ;CCR-930 + I +IBSWINFO,((IBTSBDT+1)>$P(IBSWINFO,"^",2))!((IBTSEDT+1)>$P(IBSWINFO,"^",2)) D G EN + .W !!,"The Begin OR End Date CANNOT be on or after the PFSS Effective date" + .W ": ",$$FMTE^XLFDT($P(IBSWINFO,"^",2)) + ; + S IBTRKR=$G(^IBE(350.9,1,6)) + ; start date can't be before parameters + I +IBTRKR,IBTSBDT<+IBTRKR S IBTSBDT=IBTRKR W !!,"Begin date is before Claims Tracking Start Date, changed to ",$$DAT1^IBOUTL(IBTSBDT) + ; -- end date into future + I IBTSEDT>$$FMADD^XLFDT(DT,-3) W !!,"I'll automatically change the end date to 3 days prior to the date queued to run." + ; + W !!!,"I'm going to automatically queue this off and send you a" + W !,"mail message when complete.",! + S ZTIO="",ZTRTN="EN1^IBTRKR5",ZTSAVE("IB*")="",ZTDESC="IB - Add Prosthetics to Claims Tracking" + D ^%ZTLOAD I $G(ZTSK) K ZTSK W !,"Request Queued" +ENQ K ZTSK,ZTIO,ZTSAVE,ZTDESC,ZTRTN + D HOME^%ZIS + Q + ; +EN1 ; -- add prostethics to claims tracking file + N I,J,X,Y,IBTRKR,IBDT,DFN,IBDATA,IBCNT,IBCNT1,IBCNT2,IBDTS + N IBSWINFO S IBSWINFO=$$SWSTAT^IBBAPI() ;IB*2.0*312 + ; + ; -- check parameters + S IBTRKR=$G(^IBE(350.9,1,6)) + G:'$P(IBTRKR,"^",5) EN1Q ; quit if prothetics tracking off + I +IBTRKR,IBTSBDT<+IBTRKR S IBTSBDT=IBTRKR ; start date can't be before parameters + ; + ; -- users can queue into future, make sure dates not after date run + I IBTSEDT>$$FMADD^XLFDT(DT,-3) S IBMESS="(Selected end date of "_$$DAT1^IBOUTL(IBTSEDT)_" automatically changed to "_$$DAT1^IBOUTL($$FMADD^XLFDT(DT,-3))_".)",IBTSEDT=$$FMADD^XLFDT(DT,-3) + ; + ;S IBPRTYP=$O(^IBE(356.6,"AC",3,0)) ; this is the event type pointer for prosthetics + ; + ; -- cnt= total count, cnt1=count added nsc, cnt2=count of pending + S (IBCNT,IBCNT1,IBCNT2)=0 + S (IBDTS,IBDT)=IBTSBDT-.0001 + ; + ; loop twice, once for shipmnet date (new search), and once for + ; delivery date (old search) for backward compatibility. + F S IBDT=$O(^RMPR(660,"AF",IBDT)) Q:'IBDT!(IBDT>IBTSEDT) D + .; Do NOT PROCESS on VistA if IBDT>=Switch Eff Date ;CCR-930 + .I +IBSWINFO,(IBDT+1)>$P(IBSWINFO,"^",2) Q ;IB*2.0*312 + .S IBDA=0 F S IBDA=$O(^RMPR(660,"AF",IBDT,IBDA)) Q:'IBDA D PRCHK + ; + ; reset date and do old check + S IBDT=IBDTS + F S IBDT=$O(^RMPR(660,"CT",IBDT)) Q:'IBDT!(IBDT>IBTSEDT) D + .; Do NOT PROCESS on VistA if IBDT>=Switch Eff Date ;CCR-930 + .I +IBSWINFO,(IBDT+1)>$P(IBSWINFO,"^",2) Q ;IB*2.0*312 + .S IBDA="" F S IBDA=$O(^RMPR(660,"CT",IBDT,IBDA)) Q:'IBDA D PRCHK + ; + I $G(IBTALK) D BULL ;^IBTRKR51 +EN1Q I $D(ZTQUEUED) S ZTREQ="@" + Q + ; +PRCHK ; -- check and add item + N IBE,IBP,IBDX,IBRMARK,IBARR,IBT + S IBCNT=IBCNT+1,IBRMARK="" + I '$D(ZTQUEUED),($G(IBTALK)) W "." + ; + S IBDATA=$G(^RMPR(660,+IBDA,0)) Q:IBDATA="" + S DFN=$P(IBDATA,"^",2) + D CL^SDCO21(DFN,IBDT,"",.IBARR) + ; + ; -- checks copied from rmprbil v2.0 /feb 2, 1994 + Q:'$D(^RMPR(660,+IBDA,"AM")) + Q:$P(^RMPR(660,+IBDA,0),U,9)=""!($P(^(0),U,12)="")!($P(^(0),U,6)="")!($P(^(0),U,14)="V")!($P(^(0),U,2)="")!($P(^(0),U,15)="*") + ;Q:($P(^RMPR(660,+IBDA,"AM"),U,3)=2)!($P(^("AM"),U,3)=3) + ; + ; + I $O(^IBT(356,"APRO",IBDA,0)) G PRCHKQ ; already in claims tracking + ; + ; -- see if tracking only insured and pt is insured + I $P(IBTRKR,"^",5)=1,'$$INSURED^IBCNS1(DFN,IBDT) G PRCHKQ ; patient not insure + ; + ; -- if clasifications required, check exemptions + I '$D(IBARR) G CLQ + S IBE=0 F IBP=1:1:4 S IBDX(IBP)=$G(^RMPR(660,+IBDA,"BA"_IBP)) I IBDX(IBP) S IBE=1 + I 'IBE S IBRMARK="NEEDS SC DETERMINATION" G CLQ ; no ICD node in RMPR, use old method of determining status + S IBE=0 F S IBE=$O(IBARR(IBE)) Q:'IBE!($L($G(IBRMARK))) F IBP=1:1:4 Q:$L($G(IBRMARK)) I IBDX(IBP) S IBRMARK=$S($P(IBDX(IBP),"^",IBE+1):$P($T(CLTXT+IBE),";",3),$P(IBDX(IBP),"^",IBE+1)=0:"",1:"NEEDS SC DETERMINATION") + ; + ; +CLQ ; -- ok to add to tracking module + D PRO^IBTUTL1(DFN,IBDT,IBDA,$G(IBRMARK)) I '$D(ZTQUEUED),$G(IBTALK) W "+" + I $G(IBRMARK)'="" S IBCNT2=IBCNT2+1 + I $G(IBRMARK)="" S IBCNT1=IBCNT1+1 + K VAEL,VA,IBDATA,DFN,X,Y +PRCHKQ Q + ; +BULL ; -- send bulletin + ; + S XMSUB="Prosthetic Items added to Claims Tracking Complete" + S IBT(1)="The process to automatically add Prosthetic Items has successfully completed." + S IBT(1.1)="" + S IBT(2)=" Start Date: "_$$DAT1^IBOUTL(IBTSBDT) + S IBT(3)=" End Date: "_$$DAT1^IBOUTL(IBTSEDT) + I $D(IBMESS) S IBT(3.1)=IBMESS + S IBT(4)="" + S IBT(5)=" Total Prosthetics Items checked: "_$G(IBCNT) + S IBT(6)="Total NSC Prosthetic Items Added: "_$G(IBCNT1) + S IBT(7)=" Total SC Prosthetic Items Added: "_$G(IBCNT2) + S IBT(8)="" + S IBT(9)="*The items added as SC require determination and editing to be billed" + D SEND^IBTRKR31 +BULLQ Q + ; +CLTXT ; classification text for reason not billable + ;;AGENT ORANGE + ;;IONIZING RADIATION + ;;SC TREATMENT + ;;SOUTHWEST ASIA + ;;MILITARY SEXUAL TRAUMA + ;;HEAD/NECK CANCER + ;;COMBAT VETERAN diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXBCR2.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXBCR2.m index b0a843f5..d510dfec 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXBCR2.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXBCR2.m @@ -1,4 +1,4 @@ -IBXBCR2 ; GENERATED FROM 'IB BILLING CLOCK HEADER' PRINT TEMPLATE (#242) ; 12/13/08 ; (FILE 351, MARGIN=80) +IBXBCR2 ; GENERATED FROM 'IB BILLING CLOCK HEADER' PRINT TEMPLATE (#242) ; 10/03/99 ; (FILE 351, MARGIN=80) G BEGIN N W ! T W:$X ! I '$D(DIOT(2)),DN,$D(IOSL),$S('$D(DIWF):1,$P(DIWF,"B",2):$P(DIWF,"B",2),1:1)+$Y'0 Q:'DN W ?0 S Y=$P(X,U,2) S Y=$S(Y="":Y,$D(^DPT(Y,0))#2:$P(^(0),U),1:Y) W $E(Y,1,20) + S X=$G(^IBE(351,D0,0)) D N:$X>0 Q:'DN W ?0 S Y=$P(X,U,2) S Y=$S(Y="":Y,$D(^DPT(Y,0))#2:$P(^(0),U,1),1:Y) W $E(Y,1,20) S I(100)="^DPT(",J(100)=2 S I(0,0)=D0 S DIP(1)=$S($D(^IBE(351,D0,0)):^(0),1:"") S X=$P(DIP(1),U,2),X=X S D(0)=+X S D0=D(0) I D0>0 D A1 G A1R A1 ; D N:$X>24 Q:'DN W ?24 X DXS(1,9) K DIP K:DN Y W $E(X,1,12) S X=$G(^DPT(D0,0)) D N:$X>40 Q:'DN W ?40 S Y=$P(X,U,3) S Y(0)=Y S X=Y(0) S:X X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_(1700+$E(X,1,3)) S Y=X W $E(Y,1,12) - S X=$G(^DPT(D0,"TYPE")) D N:$X>56 Q:'DN W ?56 S Y=$P(X,U,1) S Y=$S(Y="":Y,$D(^DG(391,Y,0))#2:$P(^(0),U),1:Y) W $E(Y,1,22) + S X=$G(^DPT(D0,"TYPE")) D N:$X>56 Q:'DN W ?56 S Y=$P(X,U,1) S Y=$S(Y="":Y,$D(^DG(391,Y,0))#2:$P(^(0),U,1),1:Y) W $E(Y,1,22) Q A1R ; K J(100),I(100) S:$D(I(0,0)) D0=I(0,0) diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC1.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC1.m index 5d6dfc65..653fe3fb 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC1.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC1.m @@ -1,4 +1,4 @@ -IBXSC1 ; GENERATED FROM 'IB SCREEN1' INPUT TEMPLATE(#508), FILE 399;12/13/08 +IBXSC1 ; GENERATED FROM 'IB SCREEN1' INPUT TEMPLATE(#508), FILE 399;12/27/07 D DE G BEGIN DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))="" I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,18) S:%]"" DE(4)=% diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC11.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC11.m index 63cedfcd..e3ef33dc 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC11.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC11.m @@ -1,8 +1,7 @@ -IBXSC11 ; ;12/13/08 +IBXSC11 ; ;12/27/07 D DE G BEGIN DE S DIE="^DPT(",DIC=DIE,DP=2,DL=2,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))="" I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,2) S:%]"" DE(8)=% S %=$P(%Z,U,3) S:%]"" DE(2)=% S %=$P(%Z,U,5) S:%]"" DE(9)=% - I $D(^(.11)) S %Z=^(.11) S %=$P(%Z,U,1) S:%]"" DE(17)=% I $D(^(.36)) S %Z=^(.36) S %=$P(%Z,U,1) S:%]"" DE(13)=% I $D(^("VET")) S %Z=^("VET") S %=$P(%Z,U,1) S:%]"" DE(12)=% K %Z Q @@ -178,38 +177,14 @@ X9 Q 11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 X11 S:IBDR20'["14" Y="@15" Q -12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW="VET;1",DV="SXa",DU="",DLB="VETERAN (Y/N)?",DIFLD=1901 +12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW="VET;1",DV="RSXa",DU="",DLB="VETERAN (Y/N)?",DIFLD=1901 S DE(DW)="C12^IBXSC11" S DU="Y:YES;N:NO;" G RE C12 G C12S:$D(DE(12))[0 K DB - S X=DE(12),DIC=DIE - S DFN=DA D EN^DGMTCOR K DGMTCOR - S X=DE(12),DIC=DIE - S DFN=DA D EN^DGRP7CC - S X=DE(12),DIC=DIE - ; - S X=DE(12),DIC=DIE - D AUTOUPD^DGENA2(DA) - S X=DE(12),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF="1901;" D AVAFC^VAFCDD01(DA) - S X=DE(12),DIC=DIE - D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) - S X=DE(12),DIIX=2_U_DIFLD D AUDIT^DIET + D ^IBXSC13 C12S S X="" G:DG(DQ)=X C12F1 K DB - S X=DG(DQ),DIC=DIE - S DFN=DA D EN^DGMTCOR K DGMTCOR - S X=DG(DQ),DIC=DIE - S DFN=DA D EN^DGRP7CC - S X=DG(DQ),DIC=DIE - X ^DD(2,1901,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV S X="N" X ^DD(2,1901,1,3,1.4) - S X=DG(DQ),DIC=DIE - D AUTOUPD^DGENA2(DA) - S X=DG(DQ),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF="1901;" D AVAFC^VAFCDD01(DA) - S X=DG(DQ),DIC=DIE - D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) - I $D(DE(12))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET + D ^IBXSC14 C12F1 Q X12 I $D(X) S:'$D(DPTX) DFN=DA D:'$D(^XUSEC("DG ELIGIBILITY",DUZ)) VAGE^DGLOCK:X="Y" I $D(X) D:$D(DFN) EV^DGLOCK Q @@ -219,19 +194,9 @@ X12 I $D(X) S:'$D(DPTX) DFN=DA D:'$D(^XUSEC("DG ELIGIBILITY",DUZ)) VAGE^DGLOCK:X S DU="DIC(8," G RE C13 G C13S:$D(DE(13))[0 K DB - S X=DE(13),DIC=DIE - ; - S X=DE(13),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,2.2) I DIV(1)>0 S DIK(0)=DA,DIK="^DPT(DIV(0),""E"",",DA(1)=DIV(0),DA=DIV(1) D ^DIK S DA=DIK(0) K DIK - S X=DE(13),DIC=DIE - X "I $S('$D(^DIC(8,+X,0)):0,$P(^(0),""^"",1)[""DOM"":0,'$D(^DPT(DA,.36)):1,'$D(^DIC(8,+^(.36),0)):1,$P(^(0),""^"",1)'[""DOM"":1,1:0) S DGXRF=.361 D ^DGDDC Q" - S X=DE(13),DIC=DIE - K ^DPT("AEL",DA,+X) - S X=DE(13),DIC=DIE - D AUTOUPD^DGENA2(DA) - S X=DE(13),DIIX=2_U_DIFLD D AUDIT^DIET + D ^IBXSC15 C13S S X="" G:DG(DQ)=X C13F1 K DB - D ^IBXSC13 + D ^IBXSC16 C13F1 Q X13 S DFN=DA D EV^DGLOCK I $D(X) D ECD^DGLOCK1 Q @@ -243,29 +208,4 @@ X15 S:IBDR20'["15" Y="@16" 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 X16 S:$$EDADDR^IBCSCE(+$G(DFN)) Y="@155" Q -17 D:$D(DG)>9 F^DIE17,DE S DQ=17,DW=".11;1",DV="Fa",DU="",DLB="STREET ADDRESS [LINE 1]",DIFLD=.111 - S DE(DW)="C17^IBXSC11",DE(DW,"INDEX")=1 - G RE -C17 G C17S:$D(DE(17))[0 K DB - D ^IBXSC14 -C17S S X="" G:DG(DQ)=X C17F1 K DB - D ^IBXSC15 -C17F1 N X,X1,X2 S DIXR=230 D C17X1(U) K X2 M X2=X D C17X1("O") K X1 M X1=X - D - . D FC^DGFCPROT(.DA,2,.111,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q - K X M X=X2 D - . D FC^DGFCPROT(.DA,2,.111,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q - G C17F2 -C17X1(DION) K X - S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.111,DION),$P($G(^DPT(DA,.11)),U,1)) - S X=$G(X(1)) - Q -C17F2 Q -X17 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>35!($L(X)<3) X - I $D(X),X'?.ANP K X - Q - ; -18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X18 S:X="" Y=.114 - Q -19 D:$D(DG)>9 F^DIE17 G ^IBXSC16 +17 D:$D(DG)>9 F^DIE17 G ^IBXSC17 diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC110.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC110.m index 48e45ae0..7fc7136f 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC110.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC110.m @@ -1,14 +1,14 @@ -IBXSC110 ; ;12/13/08 - S X=DG(DQ),DIC=DIE - D SET^DGREGDD1(DA,.116,.11,6,$E(X,1,5)) - S X=DG(DQ),DIC=DIE +IBXSC110 ; ;12/27/07 + S X=DE(6),DIC=DIE + S A1B2TAG="PAT" D ^A1B2XFR + S X=DE(6),DIC=DIE D EVENT^IVMPLOG(DA) - S X=DG(DQ),DIC=DIE + S X=DE(6),DIC=DIE K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR - S X=DG(DQ),DIC=DIE + S X=DE(6),DIC=DIE S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX - S X=DG(DQ),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".1112;" D AVAFC^VAFCDD01(DA) - S X=DG(DQ),DIC=DIE + S X=DE(6),DIC=DIE + I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".114;" D AVAFC^VAFCDD01(DA) + S X=DE(6),DIC=DIE D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) - I $D(DE(6))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET + S X=DE(6),DIIX=2_U_DIFLD D AUDIT^DIET diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC111.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC111.m index 7a9884f2..04679e66 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC111.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC111.m @@ -1,10 +1,14 @@ -IBXSC111 ; ;12/13/08 - S X=DE(7),DIC=DIE +IBXSC111 ; ;12/27/07 + S X=DG(DQ),DIC=DIE S A1B2TAG="PAT" D ^A1B2XFR - S X=DE(7),DIC=DIE + S X=DG(DQ),DIC=DIE D EVENT^IVMPLOG(DA) - S X=DE(7),DIC=DIE + S X=DG(DQ),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR + S X=DG(DQ),DIC=DIE S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX - S X=DE(7),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".117;" D AVAFC^VAFCDD01(DA) - S X=DE(7),DIIX=2_U_DIFLD D AUDIT^DIET + S X=DG(DQ),DIC=DIE + I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".114;" D AVAFC^VAFCDD01(DA) + S X=DG(DQ),DIC=DIE + D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) + I $D(DE(6))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC112.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC112.m index 3f628811..0b1b41ee 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC112.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC112.m @@ -1,10 +1,16 @@ -IBXSC112 ; ;12/13/08 - S X=DG(DQ),DIC=DIE +IBXSC112 ; ;12/27/07 + S X=DE(7),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:""),Y=$P(Y(1),U,7) X:$D(^DD(2,.117,2)) ^(2) S X=Y S DIU=X K Y S X=DIV S X="" X ^DD(2,.115,1,1,2.4) + S X=DE(7),DIC=DIE S A1B2TAG="PAT" D ^A1B2XFR - S X=DG(DQ),DIC=DIE + S X=DE(7),DIC=DIE D EVENT^IVMPLOG(DA) - S X=DG(DQ),DIC=DIE + S X=DE(7),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR + S X=DE(7),DIC=DIE S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX - S X=DG(DQ),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".117;" D AVAFC^VAFCDD01(DA) - I $D(DE(7))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET + S X=DE(7),DIC=DIE + I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".115;" D AVAFC^VAFCDD01(DA) + S X=DE(7),DIC=DIE + D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) + S X=DE(7),DIIX=2_U_DIFLD D AUDIT^DIET diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC113.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC113.m index 2de60773..c166a2cc 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC113.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC113.m @@ -1,245 +1,16 @@ -IBXSC113 ; ;12/13/08 - D DE G BEGIN -DE S DIE="^DPT(",DIC=DIE,DP=2,DL=2,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))="" - I $D(^(.121)) S %Z=^(.121) S %=$P(%Z,U,1) S:%]"" DE(8)=% S %=$P(%Z,U,2) S:%]"" DE(10)=% S %=$P(%Z,U,3) S:%]"" DE(12)=% S %=$P(%Z,U,4) S:%]"" DE(13)=% S %=$P(%Z,U,5) S:%]"" DE(14)=% S %=$P(%Z,U,7) S:%]"" DE(5)=% S %=$P(%Z,U,8) S:%]"" DE(7)=% - I S %=$P(%Z,U,9) S:%]"" DE(3)=% S %=$P(%Z,U,10) S:%]"" DE(16)=% S %=$P(%Z,U,12) S:%]"" DE(15)=% - I $D(^(.13)) S %Z=^(.13) S %=$P(%Z,U,1) S:%]"" DE(1)=% - K %Z Q +IBXSC113 ; ;12/27/07 + S X=DG(DQ),DIC=DIE ; -W W !?DL+DL-2,DLB_": " - Q -O D W W Y W:$X>45 !?9 - I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 - W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q -TR R X:DTIME E S (DTOUT,X)=U W $C(7) - Q -A K DQ(DQ) S DQ=DQ+1 -B G @DQ -RE G PR:$D(DE(DQ)) D W,TR -N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A -RD G QS:X?."?" I X["^" D D G ^DIE17 - I X="@" D D G Z^DIE2 - I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X -T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V - K DDER G X -P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 - G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z - I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X -V D @("X"_DQ) K YS -Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A -X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 - S X="?BAD" -QS S DZ=X D D,QQ^DIEQ G B -D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q -Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N -PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP -R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R - I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R - X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% -RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 -I I DV'["I",DV'["#" G RD - D E^DIE0 G RD:$D(X),PR - Q -SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 - I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 - D ^DIR I 'DDER S %=Y(0),X=Y - Q -SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) - I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" - E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") - Q -NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS -KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") -BEGIN S DNM="IBXSC113",DQ=1 -1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".13;1",DV="Fa",DU="",DLB="PHONE NUMBER [RESIDENCE]",DIFLD=.131 - S DE(DW)="C1^IBXSC113" - G RE -C1 G C1S:$D(DE(1))[0 K DB - S X=DE(1),DIC=DIE - D EVENT^IVMPLOG(DA) - S X=DE(1),DIC=DIE - S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX - S X=DE(1),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".131;" D AVAFC^VAFCDD01(DA) - S X=DE(1),DIC=DIE - D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) - S X=DE(1),DIC=DIE - X "N % S %=$E($TR(X,""ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!@#$%^&*()-_=+[]{}<>,./?:;'\|""),1,30) K:%'="""" ^DPT(""AZVWVOE"",%,DA)" - S X=DE(1),DIIX=2_U_DIFLD D AUDIT^DIET -C1S S X="" G:DG(DQ)=X C1F1 K DB + S X=DG(DQ),DIC=DIE + S A1B2TAG="PAT" D ^A1B2XFR S X=DG(DQ),DIC=DIE D EVENT^IVMPLOG(DA) S X=DG(DQ),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR + S X=DG(DQ),DIC=DIE S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX S X=DG(DQ),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".131;" D AVAFC^VAFCDD01(DA) + I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".115;" D AVAFC^VAFCDD01(DA) S X=DG(DQ),DIC=DIE D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) - S X=DG(DQ),DIC=DIE - X "N % S %=$E($TR(X,""ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!@#$%^&*()-_=+[]{}<>,./?:;'\|""),1,30) S:%'="""" ^DPT(""AZVWVOE"",%,DA)=""""" - I $D(DE(1))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET -C1F1 Q -X1 K:$L(X)>20!($L(X)<4) X - I $D(X),X'?.ANP K X - Q - ; -2 S DQ=3 ;@155 -3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW=".121;9",DV="RSX",DU="",DLB="TEMPORARY ADDRESS ACTIVE?",DIFLD=.12105 - S DE(DW)="C3^IBXSC113",DE(DW,"INDEX")=1 - S DU="Y:YES;N:NO;" - G RE -C3 G C3S:$D(DE(3))[0 K DB - S X=DE(3),DIC=DIE - X "S DGXRF=.12105 D ^DGDDC Q" -C3S S X="" G:DG(DQ)=X C3F1 K DB - S X=DG(DQ),DIC=DIE - ; -C3F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE))) - F DIXR=600 S DIEZRXR(2,DIXR)="" - Q -X3 S DFN=DA I X="N" D TADD^DGLOCK - Q - ; -4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X4 S:X="N" Y="@915" S:X="Y" DIE("NO^")="" - Q -5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW=".121;7",DV="DX",DU="",DLB="TEMPORARY ADDRESS START DATE",DIFLD=.1217 - S DE(DW)="C5^IBXSC113",DE(DW,"INDEX")=1 - G RE -C5 G C5S:$D(DE(5))[0 K DB - S X=DE(5),DIC=DIE - ; -C5S S X="" G:DG(DQ)=X C5F1 K DB - S X=DG(DQ),DIC=DIE - ; -C5F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE))) - F DIXR=600 S DIEZRXR(2,DIXR)="" - Q -X5 S %DT="E" D ^%DT S X=Y K:Y<1 X I $D(X) S DFN=DA D TAD^DGLOCK - Q - ; -6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X6 I X']"" W !?4,*7,"But I need a Start Date for this Temporary Address." S Y=.12105 - Q -7 D:$D(DG)>9 F^DIE17,DE S DQ=7,DW=".121;8",DV="DX",DU="",DLB="TEMPORARY ADDRESS END DATE",DIFLD=.1218 - S DE(DW)="C7^IBXSC113",DE(DW,"INDEX")=1 - G RE -C7 G C7S:$D(DE(7))[0 K DB -C7S S X="" G:DG(DQ)=X C7F1 K DB -C7F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE))) - F DIXR=600 S DIEZRXR(2,DIXR)="" - Q -X7 S %DT="E" D ^%DT S X=Y K:Y<1 X I $D(X) S DFN=DA D TAD^DGLOCK I $D(X),(X<$P(^DPT(DFN,.121),"^",7)) K X - Q - ; -8 D:$D(DG)>9 F^DIE17,DE S DQ=8,DW=".121;1",DV="FX",DU="",DLB="TEMPORARY STREET [LINE 1]",DIFLD=.1211 - S DE(DW)="C8^IBXSC113",DE(DW,"INDEX")=1 - G RE -C8 G C8S:$D(DE(8))[0 K DB - S X=DE(8),DIC=DIE - X "S DGXRF=.1211 D ^DGDDC Q" -C8S S X="" G:DG(DQ)=X C8F1 K DB - S X=DG(DQ),DIC=DIE - ; -C8F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE))) - F DIXR=600 S DIEZRXR(2,DIXR)="" - Q -X8 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<2) X I $D(X) S DFN=DA D TAD^DGLOCK - I $D(X),X'?.ANP K X - Q - ; -9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X9 I X']"" W !?4,*7,"But I need at least one line of a Temporary address." S Y=.12105 - Q -10 D:$D(DG)>9 F^DIE17,DE S DQ=10,DW=".121;2",DV="FX",DU="",DLB="TEMPORARY STREET [LINE 2]",DIFLD=.1212 - S DE(DW)="C10^IBXSC113",DE(DW,"INDEX")=1 - G RE -C10 G C10S:$D(DE(10))[0 K DB - S X=DE(10),DIC=DIE - X "S DGXRF=.1212 D ^DGDDC Q" -C10S S X="" G:DG(DQ)=X C10F1 K DB - S X=DG(DQ),DIC=DIE - ; -C10F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE))) - F DIXR=600 S DIEZRXR(2,DIXR)="" - Q -X10 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<2) X I $D(X) S DFN=DA D TAD^DGLOCK - I $D(X),X'?.ANP K X - Q - ; -11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X11 S:X']"" Y=.1214 - Q -12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW=".121;3",DV="FX",DU="",DLB="TEMPORARY STREET [LINE 3]",DIFLD=.1213 - S DE(DW)="C12^IBXSC113",DE(DW,"INDEX")=1 - G RE -C12 G C12S:$D(DE(12))[0 K DB -C12S S X="" G:DG(DQ)=X C12F1 K DB -C12F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE))) - F DIXR=600 S DIEZRXR(2,DIXR)="" - Q -X12 K:$L(X)>30!($L(X)<2) X I $D(X) S DFN=DA D TAD^DGLOCK - I $D(X),X'?.ANP K X - Q - ; -13 D:$D(DG)>9 F^DIE17,DE S DQ=13,DW=".121;4",DV="FX",DU="",DLB="TEMPORARY CITY",DIFLD=.1214 - S DE(DW)="C13^IBXSC113",DE(DW,"INDEX")=1 - G RE -C13 G C13S:$D(DE(13))[0 K DB -C13S S X="" G:DG(DQ)=X C13F1 K DB -C13F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE))) - F DIXR=600 S DIEZRXR(2,DIXR)="" - Q -X13 K:$L(X)>30!($L(X)<2) X I $D(X) S DFN=DA D TAD^DGLOCK - I $D(X),X'?.ANP K X - Q - ; -14 D:$D(DG)>9 F^DIE17,DE S DQ=14,DW=".121;5",DV="P5'X",DU="",DLB="TEMPORARY STATE",DIFLD=.1215 - S DE(DW)="C14^IBXSC113",DE(DW,"INDEX")=1 - S DU="DIC(5," - G RE -C14 G C14S:$D(DE(14))[0 K DB -C14S S X="" G:DG(DQ)=X C14F1 K DB -C14F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE))) - F DIXR=600 S DIEZRXR(2,DIXR)="" - Q -X14 S DFN=DA D TAD^DGLOCK Q - Q - ; -15 D:$D(DG)>9 F^DIE17,DE S DQ=15,DW=".121;12",DV="FOX",DU="",DLB="TEMPORARY ZIP+4",DIFLD=.12112 - S DQ(15,2)="S Y(0)=Y D ZIPOUT^VAFADDR" - S DE(DW)="C15^IBXSC113",DE(DW,"INDEX")=1 - G RE -C15 G C15S:$D(DE(15))[0 K DB - S X=DE(15),DIC=DIE - D KILL^DGREGDD1(DA,.1216,.121,6,$E(X,1,5)) -C15S S X="" G:DG(DQ)=X C15F1 K DB - S X=DG(DQ),DIC=DIE - D SET^DGREGDD1(DA,.1216,.121,6,$E(X,1,5)) -C15F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE))) - F DIXR=600 S DIEZRXR(2,DIXR)="" - Q -X15 K:X[""""!($A(X)=45) X I $D(X) S DFN=DA D TAD^DGLOCK I $D(X) K:$L(X)>20!($L(X)<5) X I $D(X) D ZIPIN^VAFADDR - I $D(X),X'?.ANP K X - Q - ; -16 D:$D(DG)>9 F^DIE17,DE S DQ=16,DW=".121;10",DV="FX",DU="",DLB="TEMPORARY PHONE NUMBER",DIFLD=.1219 - S DE(DW)="C16^IBXSC113" - G RE -C16 G C16S:$D(DE(16))[0 K DB - S X=DE(16),DIC=DIE - D EVENT^IVMPLOG(DA) -C16S S X="" G:DG(DQ)=X C16F1 K DB - S X=DG(DQ),DIC=DIE - D EVENT^IVMPLOG(DA) -C16F1 Q -X16 K:$L(X)>20!($L(X)<4) X I $D(X) S DFN=DA D TAD^DGLOCK - I $D(X),X'?.ANP K X - Q - ; -17 S DQ=18 ;@915 -18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X18 K DIE("NO^") - Q -19 S DQ=20 ;@16 -20 G 1^DIE17 + I $D(DE(7))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC114.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC114.m index c1897be5..75a85f43 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC114.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC114.m @@ -1,21 +1,210 @@ -IBXSC114 ; ;12/13/08 - ;; -1 N X,X1,X2 S DIXR=600 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X - D - . D TEMP^DGDDDTTM - K X M X=X2 D - . D TEMP^DGDDDTTM +IBXSC114 ; ;12/27/07 + D DE G BEGIN +DE S DIE="^DPT(",DIC=DIE,DP=2,DL=2,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))="" + I $D(^(.11)) S %Z=^(.11) S %=$P(%Z,U,7) S:%]"" DE(2)=% S %=$P(%Z,U,12) S:%]"" DE(1)=% + I $D(^(.121)) S %Z=^(.121) S %=$P(%Z,U,7) S:%]"" DE(7)=% S %=$P(%Z,U,9) S:%]"" DE(5)=% + I $D(^(.13)) S %Z=^(.13) S %=$P(%Z,U,1) S:%]"" DE(3)=% + K %Z Q + ; +W W !?DL+DL-2,DLB_": " Q -X1(DION) K X - S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.1211,DION),$P($G(^DPT(DA,.121)),U,1)) - S X(2)=$G(@DIEZTMP@("V",2,DIIENS,.1212,DION),$P($G(^DPT(DA,.121)),U,2)) - S X(3)=$G(@DIEZTMP@("V",2,DIIENS,.1213,DION),$P($G(^DPT(DA,.121)),U,3)) - S X(4)=$G(@DIEZTMP@("V",2,DIIENS,.1214,DION),$P($G(^DPT(DA,.121)),U,4)) - S X(5)=$G(@DIEZTMP@("V",2,DIIENS,.1215,DION),$P($G(^DPT(DA,.121)),U,5)) - S X(6)=$G(@DIEZTMP@("V",2,DIIENS,.1216,DION),$P($G(^DPT(DA,.121)),U,6)) - S X(7)=$G(@DIEZTMP@("V",2,DIIENS,.1217,DION),$P($G(^DPT(DA,.121)),U,7)) - S X(8)=$G(@DIEZTMP@("V",2,DIIENS,.1218,DION),$P($G(^DPT(DA,.121)),U,8)) - S X(9)=$G(@DIEZTMP@("V",2,DIIENS,.12105,DION),$P($G(^DPT(DA,.121)),U,9)) - S X(10)=$G(@DIEZTMP@("V",2,DIIENS,.12112,DION),$P($G(^DPT(DA,.121)),U,12)) +O D W W Y W:$X>45 !?9 + I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 + W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q +TR R X:DTIME E S (DTOUT,X)=U W $C(7) + Q +A K DQ(DQ) S DQ=DQ+1 +B G @DQ +RE G PR:$D(DE(DQ)) D W,TR +N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A +RD G QS:X?."?" I X["^" D D G ^DIE17 + I X="@" D D G Z^DIE2 + I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X +T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V + K DDER G X +P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 + G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z + I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X +V D @("X"_DQ) K YS +Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A +X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 + S X="?BAD" +QS S DZ=X D D,QQ^DIEQ G B +D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q +Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N +PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP +R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R + I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R + X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% +RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 +I I DV'["I",DV'["#" G RD + D E^DIE0 G RD:$D(X),PR + Q +SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 + I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 + D ^DIR I 'DDER S %=Y(0),X=Y + Q +SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) + I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" + E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") + Q +NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS +KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") +BEGIN S DNM="IBXSC114",DQ=1 +1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".11;12",DV="FXOa",DU="",DLB="ZIP+4",DIFLD=.1112 + S DQ(1,2)="S Y(0)=Y D ZIPOUT^VAFADDR" + S DE(DW)="C1^IBXSC114",DE(DW,"INDEX")=1 + G RE +C1 G C1S:$D(DE(1))[0 K DB + S X=DE(1),DIC=DIE + D KILL^DGREGDD1(DA,.116,.11,6,$E(X,1,5)) + S X=DE(1),DIC=DIE + D EVENT^IVMPLOG(DA) + S X=DE(1),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR + S X=DE(1),DIC=DIE + S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX + S X=DE(1),DIC=DIE + I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".1112;" D AVAFC^VAFCDD01(DA) + S X=DE(1),DIC=DIE + D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) + S X=DE(1),DIIX=2_U_DIFLD D AUDIT^DIET +C1S S X="" G:DG(DQ)=X C1F1 K DB + S X=DG(DQ),DIC=DIE + D SET^DGREGDD1(DA,.116,.11,6,$E(X,1,5)) + S X=DG(DQ),DIC=DIE + D EVENT^IVMPLOG(DA) + S X=DG(DQ),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR + S X=DG(DQ),DIC=DIE + S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX + S X=DG(DQ),DIC=DIE + I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".1112;" D AVAFC^VAFCDD01(DA) + S X=DG(DQ),DIC=DIE + D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) + I $D(DE(1))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET +C1F1 N X,X1,X2 S DIXR=185 D C1X1(U) K X2 M X2=X D C1X1("O") K X1 M X1=X + D + . N DIEXARR M DIEXARR=X S DIEZCOND=1 + . I X1(1)'=X2(1) + . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND + . K EASDO2 + G C1F2 +C1X1(DION) K X + S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.1112,DION),$P($G(^DPT(DA,.11)),U,12)) + S:('$G(EASDO2)&($D(EASZIPLK))) X=$$ZIP^DGREGDD1(DA,X(1)) + S:$D(X)#2 X(2)=X S X=$G(X(1)) Q +C1F2 S DIXR=231 D C1X2(U) K X2 M X2=X D C1X2("O") K X1 M X1=X + D + . D FC^DGFCPROT(.DA,2,.1112,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q + K X M X=X2 D + . D FC^DGFCPROT(.DA,2,.1112,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q + G C1F3 +C1X2(DION) K X + S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.1112,DION),$P($G(^DPT(DA,.11)),U,12)) + S X=$G(X(1)) + Q +C1F3 Q +X1 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>20!($L(X)<5) X I $D(X) D ZIPIN^VAFADDR + I $D(X),X'?.ANP K X + Q + ; +2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW=".11;7",DV="NJ3,0XOa",DU="",DLB="COUNTY",DIFLD=.117 + S DQ(2,2)="S Y(0)=Y Q:Y']"""" S Z0=$S($D(^DPT(D0,.11)):+$P(^(.11),""^"",5),1:"""") Q:'Z0 S Y=$P($S($D(^DIC(5,Z0,1,Y,0)):^(0),1:""""),""^"",3)" + S DE(DW)="C2^IBXSC114" + G RE +C2 G C2S:$D(DE(2))[0 K DB + S X=DE(2),DIC=DIE + S A1B2TAG="PAT" D ^A1B2XFR + S X=DE(2),DIC=DIE + D EVENT^IVMPLOG(DA) + S X=DE(2),DIC=DIE + S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX + S X=DE(2),DIC=DIE + I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".117;" D AVAFC^VAFCDD01(DA) + S X=DE(2),DIIX=2_U_DIFLD D AUDIT^DIET +C2S S X="" G:DG(DQ)=X C2F1 K DB + S X=DG(DQ),DIC=DIE + S A1B2TAG="PAT" D ^A1B2XFR + S X=DG(DQ),DIC=DIE + D EVENT^IVMPLOG(DA) + S X=DG(DQ),DIC=DIE + S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX + S X=DG(DQ),DIC=DIE + I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".117;" D AVAFC^VAFCDD01(DA) + I $D(DE(2))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET +C2F1 Q +X2 S Z0=$S($D(^DPT(D0,.11)):+$P(^(.11),"^",5),1:0) K:'Z0 X Q:'Z0!'$D(^DIC(5,Z0,1,0)) S DIC="^DIC(5,Z0,1,",DIC(0)="QEM" D ^DIC S X=+Y K:Y'>0 X K Z0,DIC + Q + ; +3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW=".13;1",DV="Fa",DU="",DLB="PHONE NUMBER [RESIDENCE]",DIFLD=.131 + S DE(DW)="C3^IBXSC114" + G RE +C3 G C3S:$D(DE(3))[0 K DB + S X=DE(3),DIC=DIE + D EVENT^IVMPLOG(DA) + S X=DE(3),DIC=DIE + S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX + S X=DE(3),DIC=DIE + I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".131;" D AVAFC^VAFCDD01(DA) + S X=DE(3),DIC=DIE + D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) + S X=DE(3),DIC=DIE + X "K ^DPT(""AZVWVOE"",$E($TR(X,""ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!@#$%^&*()-_=+[]{}<>,./?:;'\|""),1,30),DA)" + S X=DE(3),DIIX=2_U_DIFLD D AUDIT^DIET +C3S S X="" G:DG(DQ)=X C3F1 K DB + S X=DG(DQ),DIC=DIE + D EVENT^IVMPLOG(DA) + S X=DG(DQ),DIC=DIE + S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX + S X=DG(DQ),DIC=DIE + I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".131;" D AVAFC^VAFCDD01(DA) + S X=DG(DQ),DIC=DIE + D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) + S X=DG(DQ),DIC=DIE + X "S ^DPT(""AZVWVOE"",$E($TR(X,""ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!@#$%^&*()-_=+[]{}<>,./?:;'\|""),1,30),DA)=""""" + I $D(DE(3))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET +C3F1 Q +X3 K:$L(X)>20!($L(X)<4) X + I $D(X),X'?.ANP K X + Q + ; +4 S DQ=5 ;@155 +5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW=".121;9",DV="RSX",DU="",DLB="TEMPORARY ADDRESS ACTIVE?",DIFLD=.12105 + S DE(DW)="C5^IBXSC114",DE(DW,"INDEX")=1 + S DU="Y:YES;N:NO;" + G RE +C5 G C5S:$D(DE(5))[0 K DB + S X=DE(5),DIC=DIE + X "S DGXRF=.12105 D ^DGDDC Q" +C5S S X="" G:DG(DQ)=X C5F1 K DB + S X=DG(DQ),DIC=DIE + ; +C5F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE))) + F DIXR=600 S DIEZRXR(2,DIXR)="" + Q +X5 S DFN=DA I X="N" D TADD^DGLOCK + Q + ; +6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X6 S:X="N" Y="@915" S:X="Y" DIE("NO^")="" + Q +7 D:$D(DG)>9 F^DIE17,DE S DQ=7,DW=".121;7",DV="DX",DU="",DLB="TEMPORARY ADDRESS START DATE",DIFLD=.1217 + S DE(DW)="C7^IBXSC114",DE(DW,"INDEX")=1 + G RE +C7 G C7S:$D(DE(7))[0 K DB + D ^IBXSC115 +C7S S X="" G:DG(DQ)=X C7F1 K DB + D ^IBXSC116 +C7F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE))) + F DIXR=600 S DIEZRXR(2,DIXR)="" + Q +X7 S %DT="E" D ^%DT S X=Y K:Y<1 X I $D(X) S DFN=DA D TAD^DGLOCK + Q + ; +8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X8 I X']"" W !?4,*7,"But I need a Start Date for this Temporary Address." S Y=.12105 + Q +9 D:$D(DG)>9 F^DIE17 G ^IBXSC117 diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC12.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC12.m index b44aae8c..fc5e724a 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC12.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC12.m @@ -1,4 +1,4 @@ -IBXSC12 ; ;12/13/08 +IBXSC12 ; ;12/27/07 D DE G BEGIN DE S DIE="^DPT(D0,.01,",DIC=DIE,DP=2.01,DL=3,DIEL=1,DU="" K DG,DE,DB Q:$O(^DPT(D0,.01,DA,""))="" I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% S %=$P(%Z,U,2) S:%]"" DE(2)=% diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC13.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC13.m index cd96db9e..682fbc8b 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC13.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC13.m @@ -1,12 +1,14 @@ -IBXSC13 ; ;12/13/08 - S X=DG(DQ),DIC=DIE - X "S DFN=DA D EN^DGMTR K DGREQF" - S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,89.4) S Y(102)=$S($D(^DPT(D0,"E",D1,0)):^(0),1:"") S X=$S('$D(^DIC(8,+$P(Y(102),U,1),0)):"",1:$P(^(0),U,1)) S D0=I(0,0) S D1=I(1,0) S DIU=X K Y S X=DIV S X=DIV,X=X X ^DD(2,.361,1,2,1.4) - S X=DG(DQ),DIC=DIE +IBXSC13 ; ;12/27/07 + S X=DE(12),DIC=DIE + S DFN=DA D EN^DGMTCOR K DGMTCOR + S X=DE(12),DIC=DIE + S DFN=DA D EN^DGRP7CC + S X=DE(12),DIC=DIE ; - S X=DG(DQ),DIC=DIE - S ^DPT("AEL",DA,+X)="" - S X=DG(DQ),DIC=DIE + S X=DE(12),DIC=DIE D AUTOUPD^DGENA2(DA) - I $D(DE(13))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET + S X=DE(12),DIC=DIE + I ($T(AVAFC^VAFCDD01)'="") S VAFCF="1901;" D AVAFC^VAFCDD01(DA) + S X=DE(12),DIC=DIE + D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) + S X=DE(12),DIIX=2_U_DIFLD D AUDIT^DIET diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC14.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC14.m index d504409c..ac5aa7f7 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC14.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC14.m @@ -1,16 +1,14 @@ -IBXSC14 ; ;12/13/08 - S X=DE(17),DIC=DIE - X "S DGXRF=.111 D ^DGDDC Q" - S X=DE(17),DIC=DIE - S A1B2TAG="PAT" D ^A1B2XFR - S X=DE(17),DIC=DIE - D EVENT^IVMPLOG(DA) - S X=DE(17),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR - S X=DE(17),DIC=DIE - S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX - S X=DE(17),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".111;" D AVAFC^VAFCDD01(DA) - S X=DE(17),DIC=DIE +IBXSC14 ; ;12/27/07 + S X=DG(DQ),DIC=DIE + S DFN=DA D EN^DGMTCOR K DGMTCOR + S X=DG(DQ),DIC=DIE + S DFN=DA D EN^DGRP7CC + S X=DG(DQ),DIC=DIE + X ^DD(2,1901,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV S X="N" X ^DD(2,1901,1,3,1.4) + S X=DG(DQ),DIC=DIE + D AUTOUPD^DGENA2(DA) + S X=DG(DQ),DIC=DIE + I ($T(AVAFC^VAFCDD01)'="") S VAFCF="1901;" D AVAFC^VAFCDD01(DA) + S X=DG(DQ),DIC=DIE D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) - S X=DE(17),DIIX=2_U_DIFLD D AUDIT^DIET + I $D(DE(12))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC15.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC15.m index 97d214d1..1920b7dc 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC15.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC15.m @@ -1,16 +1,12 @@ -IBXSC15 ; ;12/13/08 - S X=DG(DQ),DIC=DIE +IBXSC15 ; ;12/27/07 + S X=DE(13),DIC=DIE ; - S X=DG(DQ),DIC=DIE - S A1B2TAG="PAT" D ^A1B2XFR - S X=DG(DQ),DIC=DIE - D EVENT^IVMPLOG(DA) - S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR - S X=DG(DQ),DIC=DIE - S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX - S X=DG(DQ),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".111;" D AVAFC^VAFCDD01(DA) - S X=DG(DQ),DIC=DIE - D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) - I $D(DE(17))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET + S X=DE(13),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,2.2) I DIV(1)>0 S DIK(0)=DA,DIK="^DPT(DIV(0),""E"",",DA(1)=DIV(0),DA=DIV(1) D ^DIK S DA=DIK(0) K DIK + S X=DE(13),DIC=DIE + X "I $S('$D(^DIC(8,+X,0)):0,$P(^(0),""^"",1)[""DOM"":0,'$D(^DPT(DA,.36)):1,'$D(^DIC(8,+^(.36),0)):1,$P(^(0),""^"",1)'[""DOM"":1,1:0) S DGXRF=.361 D ^DGDDC Q" + S X=DE(13),DIC=DIE + K ^DPT("AEL",DA,+X) + S X=DE(13),DIC=DIE + D AUTOUPD^DGENA2(DA) + S X=DE(13),DIIX=2_U_DIFLD D AUDIT^DIET diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC16.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC16.m index e2201266..ee07b6a6 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC16.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC16.m @@ -1,265 +1,12 @@ -IBXSC16 ; ;12/13/08 - D DE G BEGIN -DE S DIE="^DPT(",DIC=DIE,DP=2,DL=2,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))="" - I $D(^(.11)) S %Z=^(.11) S %=$P(%Z,U,2) S:%]"" DE(1)=% S %=$P(%Z,U,3) S:%]"" DE(3)=% S %=$P(%Z,U,4) S:%]"" DE(4)=% S %=$P(%Z,U,5) S:%]"" DE(5)=% S %=$P(%Z,U,7) S:%]"" DE(7)=% S %=$P(%Z,U,12) S:%]"" DE(6)=% - K %Z Q - ; -W W !?DL+DL-2,DLB_": " - Q -O D W W Y W:$X>45 !?9 - I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 - W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q -TR R X:DTIME E S (DTOUT,X)=U W $C(7) - Q -A K DQ(DQ) S DQ=DQ+1 -B G @DQ -RE G PR:$D(DE(DQ)) D W,TR -N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A -RD G QS:X?."?" I X["^" D D G ^DIE17 - I X="@" D D G Z^DIE2 - I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X -T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V - K DDER G X -P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 - G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z - I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X -V D @("X"_DQ) K YS -Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A -X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 - S X="?BAD" -QS S DZ=X D D,QQ^DIEQ G B -D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q -Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N -PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP -R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R - I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R - X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% -RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 -I I DV'["I",DV'["#" G RD - D E^DIE0 G RD:$D(X),PR - Q -SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 - I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 - D ^DIR I 'DDER S %=Y(0),X=Y - Q -SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) - I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" - E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") - Q -NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS -KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") -BEGIN S DNM="IBXSC16",DQ=1 -1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".11;2",DV="Fa",DU="",DLB="STREET ADDRESS [LINE 2]",DIFLD=.112 - S DE(DW)="C1^IBXSC16",DE(DW,"INDEX")=1 - G RE -C1 G C1S:$D(DE(1))[0 K DB - S X=DE(1),DIC=DIE - X "S DGXRF=.112 D ^DGDDC Q" - S X=DE(1),DIC=DIE - S A1B2TAG="PAT" D ^A1B2XFR - S X=DE(1),DIC=DIE - D EVENT^IVMPLOG(DA) - S X=DE(1),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR - S X=DE(1),DIC=DIE - S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX - S X=DE(1),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".112;" D AVAFC^VAFCDD01(DA) - S X=DE(1),DIC=DIE - D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) - S X=DE(1),DIIX=2_U_DIFLD D AUDIT^DIET -C1S S X="" G:DG(DQ)=X C1F1 K DB +IBXSC16 ; ;12/27/07 + S X=DG(DQ),DIC=DIE + X "S DFN=DA D EN^DGMTR K DGREQF" + S X=DG(DQ),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,89.4) S Y(102)=$S($D(^DPT(D0,"E",D1,0)):^(0),1:"") S X=$S('$D(^DIC(8,+$P(Y(102),U,1),0)):"",1:$P(^(0),U,1)) S D0=I(0,0) S D1=I(1,0) S DIU=X K Y S X=DIV S X=DIV,X=X X ^DD(2,.361,1,2,1.4) S X=DG(DQ),DIC=DIE ; S X=DG(DQ),DIC=DIE - S A1B2TAG="PAT" D ^A1B2XFR + S ^DPT("AEL",DA,+X)="" S X=DG(DQ),DIC=DIE - D EVENT^IVMPLOG(DA) - S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR - S X=DG(DQ),DIC=DIE - S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX - S X=DG(DQ),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".112;" D AVAFC^VAFCDD01(DA) - S X=DG(DQ),DIC=DIE - D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) - I $D(DE(1))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET -C1F1 N X,X1,X2 S DIXR=232 D C1X1(U) K X2 M X2=X D C1X1("O") K X1 M X1=X - D - . D FC^DGFCPROT(.DA,2,.112,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q - K X M X=X2 D - . D FC^DGFCPROT(.DA,2,.112,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q - G C1F2 -C1X1(DION) K X - S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.112,DION),$P($G(^DPT(DA,.11)),U,2)) - S X=$G(X(1)) - Q -C1F2 Q -X1 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3) X D:$D(X) UP^DGHELP - I $D(X),X'?.ANP K X - Q - ; -2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X2 S:X="" Y=.114 - Q -3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW=".11;3",DV="Fa",DU="",DLB="STREET ADDRESS [LINE 3]",DIFLD=.113 - S DE(DW)="C3^IBXSC16",DE(DW,"INDEX")=1 - G RE -C3 G C3S:$D(DE(3))[0 K DB - S X=DE(3),DIC=DIE - S A1B2TAG="PAT" D ^A1B2XFR - S X=DE(3),DIC=DIE - D EVENT^IVMPLOG(DA) - S X=DE(3),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR - S X=DE(3),DIC=DIE - S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX - S X=DE(3),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".113;" D AVAFC^VAFCDD01(DA) - S X=DE(3),DIC=DIE - D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) - S X=DE(3),DIIX=2_U_DIFLD D AUDIT^DIET -C3S S X="" G:DG(DQ)=X C3F1 K DB - S X=DG(DQ),DIC=DIE - S A1B2TAG="PAT" D ^A1B2XFR - S X=DG(DQ),DIC=DIE - D EVENT^IVMPLOG(DA) - S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR - S X=DG(DQ),DIC=DIE - S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX - S X=DG(DQ),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".113;" D AVAFC^VAFCDD01(DA) - S X=DG(DQ),DIC=DIE - D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) - I $D(DE(3))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET -C3F1 N X,X1,X2 S DIXR=233 D C3X1(U) K X2 M X2=X D C3X1("O") K X1 M X1=X - D - . D FC^DGFCPROT(.DA,2,.113,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q - K X M X=X2 D - . D FC^DGFCPROT(.DA,2,.113,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q - G C3F2 -C3X1(DION) K X - S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.113,DION),$P($G(^DPT(DA,.11)),U,3)) - S X=$G(X(1)) - Q -C3F2 Q -X3 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3) X - I $D(X),X'?.ANP K X - Q - ; -4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW=".11;4",DV="Fa",DU="",DLB="CITY",DIFLD=.114 - S DE(DW)="C4^IBXSC16",DE(DW,"INDEX")=1 - G RE -C4 G C4S:$D(DE(4))[0 K DB - S X=DE(4),DIC=DIE - S A1B2TAG="PAT" D ^A1B2XFR - S X=DE(4),DIC=DIE - D EVENT^IVMPLOG(DA) - S X=DE(4),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR - S X=DE(4),DIC=DIE - S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX - S X=DE(4),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".114;" D AVAFC^VAFCDD01(DA) - S X=DE(4),DIC=DIE - D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) - S X=DE(4),DIIX=2_U_DIFLD D AUDIT^DIET -C4S S X="" G:DG(DQ)=X C4F1 K DB - S X=DG(DQ),DIC=DIE - S A1B2TAG="PAT" D ^A1B2XFR - S X=DG(DQ),DIC=DIE - D EVENT^IVMPLOG(DA) - S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR - S X=DG(DQ),DIC=DIE - S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX - S X=DG(DQ),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".114;" D AVAFC^VAFCDD01(DA) - S X=DG(DQ),DIC=DIE - D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) - I $D(DE(4))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET -C4F1 N X,X1,X2 S DIXR=234 D C4X1(U) K X2 M X2=X D C4X1("O") K X1 M X1=X - D - . D FC^DGFCPROT(.DA,2,.114,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q - K X M X=X2 D - . D FC^DGFCPROT(.DA,2,.114,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q - G C4F2 -C4X1(DION) K X - S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.114,DION),$P($G(^DPT(DA,.11)),U,4)) - S X=$G(X(1)) - Q -C4F2 Q -X4 K:$L(X)>15!($L(X)<2) X - I $D(X),X'?.ANP K X - Q - ; -5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW=".11;5",DV="P5'a",DU="",DLB="STATE",DIFLD=.115 - S DE(DW)="C5^IBXSC16",DE(DW,"INDEX")=1 - S DU="DIC(5," - G RE -C5 G C5S:$D(DE(5))[0 K DB - D ^IBXSC17 -C5S S X="" G:DG(DQ)=X C5F1 K DB - D ^IBXSC18 -C5F1 N X,X1,X2 S DIXR=235 D C5X1(U) K X2 M X2=X D C5X1("O") K X1 M X1=X - D - . D FC^DGFCPROT(.DA,2,.115,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q - K X M X=X2 D - . D FC^DGFCPROT(.DA,2,.115,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q - G C5F2 -C5X1(DION) K X - S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.115,DION),$P($G(^DPT(DA,.11)),U,5)) - S X=$G(X(1)) - Q -C5F2 Q -X5 Q -6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW=".11;12",DV="FXOa",DU="",DLB="ZIP+4",DIFLD=.1112 - S DQ(6,2)="S Y(0)=Y D ZIPOUT^VAFADDR" - S DE(DW)="C6^IBXSC16",DE(DW,"INDEX")=1 - G RE -C6 G C6S:$D(DE(6))[0 K DB - D ^IBXSC19 -C6S S X="" G:DG(DQ)=X C6F1 K DB - D ^IBXSC110 -C6F1 N X,X1,X2 S DIXR=185 D C6X1(U) K X2 M X2=X D C6X1("O") K X1 M X1=X - D - . N DIEXARR M DIEXARR=X S DIEZCOND=1 - . I X1(1)'=X2(1) - . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND - . K EASDO2 - G C6F2 -C6X1(DION) K X - S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.1112,DION),$P($G(^DPT(DA,.11)),U,12)) - S:('$G(EASDO2)&($D(EASZIPLK))) X=$$ZIP^DGREGDD1(DA,X(1)) - S:$D(X)#2 X(2)=X - S X=$G(X(1)) - Q -C6F2 S DIXR=231 D C6X2(U) K X2 M X2=X D C6X2("O") K X1 M X1=X - D - . D FC^DGFCPROT(.DA,2,.1112,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q - K X M X=X2 D - . D FC^DGFCPROT(.DA,2,.1112,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q - G C6F3 -C6X2(DION) K X - S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.1112,DION),$P($G(^DPT(DA,.11)),U,12)) - S X=$G(X(1)) - Q -C6F3 Q -X6 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>20!($L(X)<5) X I $D(X) D ZIPIN^VAFADDR - I $D(X),X'?.ANP K X - Q - ; -7 D:$D(DG)>9 F^DIE17,DE S DQ=7,DW=".11;7",DV="NJ3,0XOa",DU="",DLB="COUNTY",DIFLD=.117 - S DQ(7,2)="S Y(0)=Y Q:Y']"""" S Z0=$S($D(^DPT(D0,.11)):+$P(^(.11),""^"",5),1:"""") Q:'Z0 S Y=$P($S($D(^DIC(5,Z0,1,Y,0)):^(0),1:""""),""^"",3)" - S DE(DW)="C7^IBXSC16" - G RE -C7 G C7S:$D(DE(7))[0 K DB - D ^IBXSC111 -C7S S X="" G:DG(DQ)=X C7F1 K DB - D ^IBXSC112 -C7F1 Q -X7 S Z0=$S($D(^DPT(D0,.11)):+$P(^(.11),"^",5),1:0) K:'Z0 X Q:'Z0!'$D(^DIC(5,Z0,1,0)) S DIC="^DIC(5,Z0,1,",DIC(0)="QEM" D ^DIC S X=+Y K:Y'>0 X K Z0,DIC - Q - ; -8 D:$D(DG)>9 F^DIE17 G ^IBXSC113 + D AUTOUPD^DGENA2(DA) + I $D(DE(13))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC17.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC17.m index 338ddd52..d7f95622 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC17.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC17.m @@ -1,16 +1,222 @@ -IBXSC17 ; ;12/13/08 - S X=DE(5),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:""),Y=$P(Y(1),U,7) X:$D(^DD(2,.117,2)) ^(2) S X=Y S DIU=X K Y S X=DIV S X="" X ^DD(2,.115,1,1,2.4) - S X=DE(5),DIC=DIE +IBXSC17 ; ;12/27/07 + D DE G BEGIN +DE S DIE="^DPT(",DIC=DIE,DP=2,DL=2,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))="" + I $D(^(.11)) S %Z=^(.11) S %=$P(%Z,U,1) S:%]"" DE(1)=% S %=$P(%Z,U,2) S:%]"" DE(3)=% S %=$P(%Z,U,3) S:%]"" DE(5)=% S %=$P(%Z,U,4) S:%]"" DE(6)=% S %=$P(%Z,U,5) S:%]"" DE(7)=% + K %Z Q + ; +W W !?DL+DL-2,DLB_": " + Q +O D W W Y W:$X>45 !?9 + I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 + W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q +TR R X:DTIME E S (DTOUT,X)=U W $C(7) + Q +A K DQ(DQ) S DQ=DQ+1 +B G @DQ +RE G PR:$D(DE(DQ)) D W,TR +N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A +RD G QS:X?."?" I X["^" D D G ^DIE17 + I X="@" D D G Z^DIE2 + I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X +T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V + K DDER G X +P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 + G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z + I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X +V D @("X"_DQ) K YS +Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A +X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 + S X="?BAD" +QS S DZ=X D D,QQ^DIEQ G B +D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q +Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N +PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP +R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R + I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R + X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% +RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 +I I DV'["I",DV'["#" G RD + D E^DIE0 G RD:$D(X),PR + Q +SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 + I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 + D ^DIR I 'DDER S %=Y(0),X=Y + Q +SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) + I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" + E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") + Q +NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS +KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") +BEGIN S DNM="IBXSC17",DQ=1 +1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".11;1",DV="Fa",DU="",DLB="STREET ADDRESS [LINE 1]",DIFLD=.111 + S DE(DW)="C1^IBXSC17",DE(DW,"INDEX")=1 + G RE +C1 G C1S:$D(DE(1))[0 K DB + S X=DE(1),DIC=DIE + X "S DGXRF=.111 D ^DGDDC Q" + S X=DE(1),DIC=DIE S A1B2TAG="PAT" D ^A1B2XFR - S X=DE(5),DIC=DIE + S X=DE(1),DIC=DIE D EVENT^IVMPLOG(DA) - S X=DE(5),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR - S X=DE(5),DIC=DIE + S X=DE(1),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR + S X=DE(1),DIC=DIE S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX - S X=DE(5),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".115;" D AVAFC^VAFCDD01(DA) - S X=DE(5),DIC=DIE + S X=DE(1),DIC=DIE + I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".111;" D AVAFC^VAFCDD01(DA) + S X=DE(1),DIC=DIE D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) - S X=DE(5),DIIX=2_U_DIFLD D AUDIT^DIET + S X=DE(1),DIIX=2_U_DIFLD D AUDIT^DIET +C1S S X="" G:DG(DQ)=X C1F1 K DB + S X=DG(DQ),DIC=DIE + ; + S X=DG(DQ),DIC=DIE + S A1B2TAG="PAT" D ^A1B2XFR + S X=DG(DQ),DIC=DIE + D EVENT^IVMPLOG(DA) + S X=DG(DQ),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR + S X=DG(DQ),DIC=DIE + S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX + S X=DG(DQ),DIC=DIE + I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".111;" D AVAFC^VAFCDD01(DA) + S X=DG(DQ),DIC=DIE + D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) + I $D(DE(1))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET +C1F1 N X,X1,X2 S DIXR=230 D C1X1(U) K X2 M X2=X D C1X1("O") K X1 M X1=X + D + . D FC^DGFCPROT(.DA,2,.111,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q + K X M X=X2 D + . D FC^DGFCPROT(.DA,2,.111,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q + G C1F2 +C1X1(DION) K X + S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.111,DION),$P($G(^DPT(DA,.11)),U,1)) + S X=$G(X(1)) + Q +C1F2 Q +X1 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>35!($L(X)<3) X + I $D(X),X'?.ANP K X + Q + ; +2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X2 S:X="" Y=.114 + Q +3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW=".11;2",DV="Fa",DU="",DLB="STREET ADDRESS [LINE 2]",DIFLD=.112 + S DE(DW)="C3^IBXSC17",DE(DW,"INDEX")=1 + G RE +C3 G C3S:$D(DE(3))[0 K DB + S X=DE(3),DIC=DIE + X "S DGXRF=.112 D ^DGDDC Q" + S X=DE(3),DIC=DIE + S A1B2TAG="PAT" D ^A1B2XFR + S X=DE(3),DIC=DIE + D EVENT^IVMPLOG(DA) + S X=DE(3),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR + S X=DE(3),DIC=DIE + S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX + S X=DE(3),DIC=DIE + I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".112;" D AVAFC^VAFCDD01(DA) + S X=DE(3),DIC=DIE + D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) + S X=DE(3),DIIX=2_U_DIFLD D AUDIT^DIET +C3S S X="" G:DG(DQ)=X C3F1 K DB + S X=DG(DQ),DIC=DIE + ; + S X=DG(DQ),DIC=DIE + S A1B2TAG="PAT" D ^A1B2XFR + S X=DG(DQ),DIC=DIE + D EVENT^IVMPLOG(DA) + S X=DG(DQ),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR + S X=DG(DQ),DIC=DIE + S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX + S X=DG(DQ),DIC=DIE + I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".112;" D AVAFC^VAFCDD01(DA) + S X=DG(DQ),DIC=DIE + D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) + I $D(DE(3))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET +C3F1 N X,X1,X2 S DIXR=232 D C3X1(U) K X2 M X2=X D C3X1("O") K X1 M X1=X + D + . D FC^DGFCPROT(.DA,2,.112,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q + K X M X=X2 D + . D FC^DGFCPROT(.DA,2,.112,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q + G C3F2 +C3X1(DION) K X + S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.112,DION),$P($G(^DPT(DA,.11)),U,2)) + S X=$G(X(1)) + Q +C3F2 Q +X3 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3) X D:$D(X) UP^DGHELP + I $D(X),X'?.ANP K X + Q + ; +4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X4 S:X="" Y=.114 + Q +5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW=".11;3",DV="Fa",DU="",DLB="STREET ADDRESS [LINE 3]",DIFLD=.113 + S DE(DW)="C5^IBXSC17",DE(DW,"INDEX")=1 + G RE +C5 G C5S:$D(DE(5))[0 K DB + D ^IBXSC18 +C5S S X="" G:DG(DQ)=X C5F1 K DB + D ^IBXSC19 +C5F1 N X,X1,X2 S DIXR=233 D C5X1(U) K X2 M X2=X D C5X1("O") K X1 M X1=X + D + . D FC^DGFCPROT(.DA,2,.113,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q + K X M X=X2 D + . D FC^DGFCPROT(.DA,2,.113,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q + G C5F2 +C5X1(DION) K X + S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.113,DION),$P($G(^DPT(DA,.11)),U,3)) + S X=$G(X(1)) + Q +C5F2 Q +X5 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3) X + I $D(X),X'?.ANP K X + Q + ; +6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW=".11;4",DV="Fa",DU="",DLB="CITY",DIFLD=.114 + S DE(DW)="C6^IBXSC17",DE(DW,"INDEX")=1 + G RE +C6 G C6S:$D(DE(6))[0 K DB + D ^IBXSC110 +C6S S X="" G:DG(DQ)=X C6F1 K DB + D ^IBXSC111 +C6F1 N X,X1,X2 S DIXR=234 D C6X1(U) K X2 M X2=X D C6X1("O") K X1 M X1=X + D + . D FC^DGFCPROT(.DA,2,.114,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q + K X M X=X2 D + . D FC^DGFCPROT(.DA,2,.114,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q + G C6F2 +C6X1(DION) K X + S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.114,DION),$P($G(^DPT(DA,.11)),U,4)) + S X=$G(X(1)) + Q +C6F2 Q +X6 K:$L(X)>15!($L(X)<2) X + I $D(X),X'?.ANP K X + Q + ; +7 D:$D(DG)>9 F^DIE17,DE S DQ=7,DW=".11;5",DV="P5'a",DU="",DLB="STATE",DIFLD=.115 + S DE(DW)="C7^IBXSC17",DE(DW,"INDEX")=1 + S DU="DIC(5," + G RE +C7 G C7S:$D(DE(7))[0 K DB + D ^IBXSC112 +C7S S X="" G:DG(DQ)=X C7F1 K DB + D ^IBXSC113 +C7F1 N X,X1,X2 S DIXR=235 D C7X1(U) K X2 M X2=X D C7X1("O") K X1 M X1=X + D + . D FC^DGFCPROT(.DA,2,.115,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q + K X M X=X2 D + . D FC^DGFCPROT(.DA,2,.115,"SET",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q + G C7F2 +C7X1(DION) K X + S X(1)=$G(@DIEZTMP@("V",2,DIIENS,.115,DION),$P($G(^DPT(DA,.11)),U,5)) + S X=$G(X(1)) + Q +C7F2 Q +X7 Q +8 D:$D(DG)>9 F^DIE17 G ^IBXSC114 diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC18.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC18.m index bc48036a..9302789b 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC18.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC18.m @@ -1,16 +1,14 @@ -IBXSC18 ; ;12/13/08 - S X=DG(DQ),DIC=DIE - ; - S X=DG(DQ),DIC=DIE +IBXSC18 ; ;12/27/07 + S X=DE(5),DIC=DIE S A1B2TAG="PAT" D ^A1B2XFR - S X=DG(DQ),DIC=DIE + S X=DE(5),DIC=DIE D EVENT^IVMPLOG(DA) - S X=DG(DQ),DIC=DIE + S X=DE(5),DIC=DIE K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR - S X=DG(DQ),DIC=DIE + S X=DE(5),DIC=DIE S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX - S X=DG(DQ),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".115;" D AVAFC^VAFCDD01(DA) - S X=DG(DQ),DIC=DIE + S X=DE(5),DIC=DIE + I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".113;" D AVAFC^VAFCDD01(DA) + S X=DE(5),DIC=DIE D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) - I $D(DE(5))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET + S X=DE(5),DIIX=2_U_DIFLD D AUDIT^DIET diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC19.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC19.m index 6d43a9e2..2e2fd7f0 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC19.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC19.m @@ -1,14 +1,14 @@ -IBXSC19 ; ;12/13/08 - S X=DE(6),DIC=DIE - D KILL^DGREGDD1(DA,.116,.11,6,$E(X,1,5)) - S X=DE(6),DIC=DIE +IBXSC19 ; ;12/27/07 + S X=DG(DQ),DIC=DIE + S A1B2TAG="PAT" D ^A1B2XFR + S X=DG(DQ),DIC=DIE D EVENT^IVMPLOG(DA) - S X=DE(6),DIC=DIE + S X=DG(DQ),DIC=DIE K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$NOW^XLFDT() S DIH=$G(^DPT(DIV(0),.11)),DIV=X S $P(^(.11),U,13)=DIV,DIH=2,DIG=.118 D ^DICR - S X=DE(6),DIC=DIE + S X=DG(DQ),DIC=DIE S IVMX=X,X="IVMPXFR" X ^%ZOSF("TEST") D:$T DPT^IVMPXFR S X=IVMX K IVMX - S X=DE(6),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".1112;" D AVAFC^VAFCDD01(DA) - S X=DE(6),DIC=DIE + S X=DG(DQ),DIC=DIE + I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".113;" D AVAFC^VAFCDD01(DA) + S X=DG(DQ),DIC=DIE D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) - S X=DE(6),DIIX=2_U_DIFLD D AUDIT^DIET + I $D(DE(5))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC3.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC3.m index a7e1cf7b..75e94e7d 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC3.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC3.m @@ -1,4 +1,4 @@ -IBXSC3 ; GENERATED FROM 'IB SCREEN3' INPUT TEMPLATE(#574), FILE 399;12/13/08 +IBXSC3 ; GENERATED FROM 'IB SCREEN3' INPUT TEMPLATE(#574), FILE 399;12/27/07 D DE G BEGIN DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))="" I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,7) S:%]"" DE(3)=% S %=$P(%Z,U,19) S:%]"" DE(7)=%,DE(11)=% diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC31.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC31.m index 2eceb322..bc548a7e 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC31.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC31.m @@ -1,4 +1,4 @@ -IBXSC31 ; ;12/13/08 +IBXSC31 ; ;12/27/07 S X=DE(22),DIC=DIE K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M")):^("M"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(399,112,1,1,2.4) S X=DE(22),DIC=DIE diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC32.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC32.m index 7eea9068..a6a9e29d 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC32.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC32.m @@ -1,4 +1,4 @@ -IBXSC32 ; ;12/13/08 +IBXSC32 ; ;12/27/07 S X=DG(DQ),DIC=DIE K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M")):^("M"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y X ^DD(399,112,1,1,1.1) X ^DD(399,112,1,1,1.4) S X=DG(DQ),DIC=DIE diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC33.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC33.m index 29930de8..bd86e291 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC33.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC33.m @@ -1,4 +1,4 @@ -IBXSC33 ; ;12/13/08 +IBXSC33 ; ;12/27/07 D DE G BEGIN DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))="" I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,21) S:%]"" DE(11)=% @@ -154,7 +154,7 @@ X12 S:IBDR20'["32" Y="@33" 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 X14 I '$$SUPPPT^IBCEP7B(DA,1) S Y="@3212" Q -15 D:$D(DG)>9 F^DIE17,DE S DQ=15,DW="M1;2",DV="FX",DU="",DLB="PRIMARY PROVIDER #",DIFLD=122 +15 D:$D(DG)>9 F^DIE17,DE S DQ=15,DW="M1;2",DV="F",DU="",DLB="PRIMARY PROVIDER #",DIFLD=122 S DE(DW)="C15^IBXSC33" S Y="@" S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) @@ -165,7 +165,7 @@ C15S S X="" G:DG(DQ)=X C15F1 K DB S X=DG(DQ),DIC=DIE ; C15F1 Q -X15 K:$L(X)>13!($L(X)<3)!($TR(X," ")="") X +X15 K:$L(X)>13!($L(X)<3) X I $D(X),X'?.ANP K X Q ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC34.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC34.m index 72a27e35..d0213ad1 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC34.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC34.m @@ -1,4 +1,4 @@ -IBXSC34 ; ;12/13/08 +IBXSC34 ; ;12/27/07 S X=DG(DQ),DIC=DIE K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$BPP^IBCNS2(DA) X ^DD(399,.21,1,1,1.4) S X=DG(DQ),DIC=DIE diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC35.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC35.m index a2d65b77..3fa737d6 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC35.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC35.m @@ -1,3 +1,3 @@ -IBXSC35 ; ;12/13/08 +IBXSC35 ; ;12/27/07 S X=DE(15),DIC=DIE K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,2)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X="" X ^DD(399,122,1,1,2.4) diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC36.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC36.m index c2e0946d..468adfc7 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC36.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC36.m @@ -1,4 +1,4 @@ -IBXSC36 ; ;12/13/08 +IBXSC36 ; ;12/27/07 D DE G BEGIN DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))="" I $D(^("M1")) S %Z=^("M1") S %=$P(%Z,U,2) S:%]"" DE(1)=%,DE(7)=% S %=$P(%Z,U,3) S:%]"" DE(19)=% S %=$P(%Z,U,10) S:%]"" DE(2)=%,DE(11)=%,DE(14)=% S %=$P(%Z,U,11) S:%]"" DE(20)=% @@ -49,7 +49,7 @@ SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$ NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") BEGIN S DNM="IBXSC36",DQ=1 -1 S DW="M1;2",DV="FX",DU="",DLB="PRIMARY PROVIDER #",DIFLD=122 +1 S DW="M1;2",DV="F",DU="",DLB="PRIMARY PROVIDER #",DIFLD=122 S DE(DW)="C1^IBXSC36" S Y="@" S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) @@ -61,7 +61,7 @@ C1S S X="" G:DG(DQ)=X C1F1 K DB S X=DG(DQ),DIC=DIE ; C1F1 Q -X1 K:$L(X)>13!($L(X)<3)!($TR(X," ")="") X +X1 K:$L(X)>13!($L(X)<3) X I $D(X),X'?.ANP K X Q ; @@ -81,7 +81,7 @@ X3 S DIE("NO^")=1 X5 S IBPSIDO=$P($G(^DGCR(399,DA,"M1")),U,2),IBPSQO=$P($G(^DGCR(399,DA,"M1")),U,10) Q 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 G A -7 S DW="M1;2",DV="FX",DU="",DLB="PRIMARY PROVIDER #",DIFLD=122 +7 S DW="M1;2",DV="F",DU="",DLB="PRIMARY PROVIDER #",DIFLD=122 S DE(DW)="C7^IBXSC36" S X="IBPSID" Q:X Q:$NA(@X)[U S X=$G(@X) S Y=X @@ -93,7 +93,7 @@ C7S S X="" G:DG(DQ)=X C7F1 K DB S X=DG(DQ),DIC=DIE ; C7F1 Q -X7 K:$L(X)>13!($L(X)<3)!($TR(X," ")="") X +X7 K:$L(X)>13!($L(X)<3) X I $D(X),X'?.ANP K X Q ; @@ -131,7 +131,7 @@ X16 K DIE("NO^") 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 X18 I '$$SUPPPT^IBCEP7B(DA,2) S Y="@3222" Q -19 S DW="M1;3",DV="FX",DU="",DLB="SECONDARY PROVIDER #",DIFLD=123 +19 S DW="M1;3",DV="F",DU="",DLB="SECONDARY PROVIDER #",DIFLD=123 S DE(DW)="C19^IBXSC36" S Y="@" S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) @@ -143,7 +143,7 @@ C19S S X="" G:DG(DQ)=X C19F1 K DB S X=DG(DQ),DIC=DIE ; C19F1 Q -X19 K:$L(X)>13!($L(X)<3)!($TR(X," ")="") X +X19 K:$L(X)>13!($L(X)<3) X I $D(X),X'?.ANP K X Q ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC37.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC37.m index 40f3ab6b..df9c81ad 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC37.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC37.m @@ -1,4 +1,4 @@ -IBXSC37 ; ;12/13/08 +IBXSC37 ; ;12/27/07 D DE G BEGIN DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))="" I $D(^("M1")) S %Z=^("M1") S %=$P(%Z,U,3) S:%]"" DE(1)=%,DE(7)=% S %=$P(%Z,U,4) S:%]"" DE(19)=% S %=$P(%Z,U,11) S:%]"" DE(2)=%,DE(11)=%,DE(14)=% S %=$P(%Z,U,12) S:%]"" DE(20)=% @@ -49,7 +49,7 @@ SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$ NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") BEGIN S DNM="IBXSC37",DQ=1 -1 S DW="M1;3",DV="FX",DU="",DLB="SECONDARY PROVIDER #",DIFLD=123 +1 S DW="M1;3",DV="F",DU="",DLB="SECONDARY PROVIDER #",DIFLD=123 S DE(DW)="C1^IBXSC37" S Y="@" S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) @@ -61,7 +61,7 @@ C1S S X="" G:DG(DQ)=X C1F1 K DB S X=DG(DQ),DIC=DIE ; C1F1 Q -X1 K:$L(X)>13!($L(X)<3)!($TR(X," ")="") X +X1 K:$L(X)>13!($L(X)<3) X I $D(X),X'?.ANP K X Q ; @@ -81,7 +81,7 @@ X3 S DIE("NO^")=1 X5 S IBPSIDO=$P($G(^DGCR(399,DA,"M1")),U,3),IBPSQO=$P($G(^DGCR(399,DA,"M1")),U,11) Q 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 G A -7 S DW="M1;3",DV="FX",DU="",DLB="SECONDARY PROVIDER #",DIFLD=123 +7 S DW="M1;3",DV="F",DU="",DLB="SECONDARY PROVIDER #",DIFLD=123 S DE(DW)="C7^IBXSC37" S X="IBPSID" Q:X Q:$NA(@X)[U S X=$G(@X) S Y=X @@ -93,7 +93,7 @@ C7S S X="" G:DG(DQ)=X C7F1 K DB S X=DG(DQ),DIC=DIE ; C7F1 Q -X7 K:$L(X)>13!($L(X)<3)!($TR(X," ")="") X +X7 K:$L(X)>13!($L(X)<3) X I $D(X),X'?.ANP K X Q ; @@ -131,7 +131,7 @@ X16 K DIE("NO^") 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 X18 I '$$SUPPPT^IBCEP7B(DA,3) S Y="@3232" Q -19 S DW="M1;4",DV="FX",DU="",DLB="TERTIARY PROVIDER #",DIFLD=124 +19 S DW="M1;4",DV="F",DU="",DLB="TERTIARY PROVIDER #",DIFLD=124 S DE(DW)="C19^IBXSC37" S Y="@" S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) @@ -143,7 +143,7 @@ C19S S X="" G:DG(DQ)=X C19F1 K DB S X=DG(DQ),DIC=DIE ; C19F1 Q -X19 K:$L(X)>13!($L(X)<3)!($TR(X," ")="") X +X19 K:$L(X)>13!($L(X)<3) X I $D(X),X'?.ANP K X Q ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC38.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC38.m index 677172fe..6dddefa0 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC38.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC38.m @@ -1,4 +1,4 @@ -IBXSC38 ; ;12/13/08 +IBXSC38 ; ;12/27/07 D DE G BEGIN DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))="" I $D(^("M")) S %Z=^("M") S %=$P(%Z,U,4) S:%]"" DE(19)=% S %=$P(%Z,U,5) S:%]"" DE(20)=% S %=$P(%Z,U,6) S:%]"" DE(21)=% S %=$P(%Z,U,7) S:%]"" DE(24)=% S %=$P(%Z,U,8) S:%]"" DE(25)=% S %=$P(%Z,U,9) S:%]"" DE(26)=% @@ -50,7 +50,7 @@ SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$ NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") BEGIN S DNM="IBXSC38",DQ=1 -1 S DW="M1;4",DV="FX",DU="",DLB="TERTIARY PROVIDER #",DIFLD=124 +1 S DW="M1;4",DV="F",DU="",DLB="TERTIARY PROVIDER #",DIFLD=124 S DE(DW)="C1^IBXSC38" S Y="@" S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) @@ -62,7 +62,7 @@ C1S S X="" G:DG(DQ)=X C1F1 K DB S X=DG(DQ),DIC=DIE ; C1F1 Q -X1 K:$L(X)>13!($L(X)<3)!($TR(X," ")="") X +X1 K:$L(X)>13!($L(X)<3) X I $D(X),X'?.ANP K X Q ; @@ -82,7 +82,7 @@ X3 S DIE("NO^")=1 X5 S IBPSIDO=$P($G(^DGCR(399,DA,"M1")),U,4),IBPSQO=$P($G(^DGCR(399,DA,"M1")),U,12) Q 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 G A -7 S DW="M1;4",DV="FX",DU="",DLB="TERTIARY PROVIDER #",DIFLD=124 +7 S DW="M1;4",DV="F",DU="",DLB="TERTIARY PROVIDER #",DIFLD=124 S DE(DW)="C7^IBXSC38" S X="IBPSID" Q:X Q:$NA(@X)[U S X=$G(@X) S Y=X @@ -94,7 +94,7 @@ C7S S X="" G:DG(DQ)=X C7F1 K DB S X=DG(DQ),DIC=DIE ; C7F1 Q -X7 K:$L(X)>13!($L(X)<3)!($TR(X," ")="") X +X7 K:$L(X)>13!($L(X)<3) X I $D(X),X'?.ANP K X Q ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC39.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC39.m index 4fe73393..c913f567 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC39.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC39.m @@ -1,4 +1,4 @@ -IBXSC39 ; ;12/13/08 +IBXSC39 ; ;12/27/07 ;; 1 N X,X1,X2 S DIXR=139 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X D diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC4.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC4.m index 6480a294..ab0b831b 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC4.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC4.m @@ -1,4 +1,4 @@ -IBXSC4 ; GENERATED FROM 'IB SCREEN4' INPUT TEMPLATE(#510), FILE 399;12/13/08 +IBXSC4 ; GENERATED FROM 'IB SCREEN4' INPUT TEMPLATE(#510), FILE 399;12/27/07 D DE G BEGIN DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))="" I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,9) S:%]"" DE(23)=% @@ -163,7 +163,7 @@ X28 S:IBDR20'["48" Y="@49" X29 I $P(^DGCR(399,DA,0),U,19)=2 S Y="@49" Q 30 S D=0 K DE(1) ;47 - S DIFLD=47,DGO="^IBXSC44",DC="2^399.047PA^CV^",DV="399.047M*P399.1'X",DW="0;1",DOW="VALUE CODE",DLB="Select "_DOW S:D DC=DC_D + S DIFLD=47,DGO="^IBXSC44",DC="2^399.047PA^CV^",DV="399.047M*P399.1'",DW="0;1",DOW="VALUE CODE",DLB="Select "_DOW S:D DC=DC_D S DU="DGCR(399.1," G RE:D I $D(DSC(399.047))#2,$P(DSC(399.047),"I $D(^UTILITY(",1)="" X DSC(399.047) S D=$O(^(0)) S:D="" D=-1 G M30 S D=$S($D(^DGCR(399,DA,"CV",0)):$P(^(0),U,3,4),$O(^(0))'="":$O(^(0)),1:-1) diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC41.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC41.m index 661c9fb3..84b6267e 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC41.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC41.m @@ -1,4 +1,4 @@ -IBXSC41 ; ;12/13/08 +IBXSC41 ; ;12/27/07 D DE G BEGIN DE S DIE="^DGCR(399,D0,""OT"",",DIC=DIE,DP=399.048,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"OT",DA,""))="" I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% S %=$P(%Z,U,2) S:%]"" DE(2)=% S %=$P(%Z,U,3) S:%]"" DE(3)=% diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC42.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC42.m index 471210a2..5bbda8d8 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC42.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC42.m @@ -1,4 +1,4 @@ -IBXSC42 ; ;12/13/08 +IBXSC42 ; ;12/27/07 D DE G BEGIN DE S DIE="^DGCR(399,D0,""OC"",",DIC=DIE,DP=399.041,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"OC",DA,""))="" I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% S %=$P(%Z,U,2) S:%]"" DE(2)=% S %=$P(%Z,U,3) S:%]"" DE(4)=% S %=$P(%Z,U,4) S:%]"" DE(8)=% @@ -82,9 +82,9 @@ X5 S Y="@455" 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 X7 I '$P(^DGCR(399.1,+^DGCR(399,DA(1),"OC",DA,0),0),U,10) S Y="@455" Q -8 S DW="0;4",DV="RDX",DU="",DLB="END DATE",DIFLD=.04 +8 S DW="0;4",DV="D",DU="",DLB="END DATE",DIFLD=.04 G RE -X8 S %DT="EX" D ^%DT S X=Y K:X<1 X I $D(X),X<$P($G(^DGCR(399,DA(1),"OC",DA,0)),U,2) K X +X8 S %DT="EX" D ^%DT S X=Y K:Y<1 X Q ; 9 S DQ=10 ;@455 diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC43.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC43.m index 48c5de32..0b03bd67 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC43.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC43.m @@ -1,4 +1,4 @@ -IBXSC43 ; ;12/13/08 +IBXSC43 ; ;12/27/07 D DE G BEGIN DE S DIE="^DGCR(399,D0,""CC"",",DIC=DIE,DP=399.04,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"CC",DA,""))="" I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC44.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC44.m index 2789a58d..3a818f69 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC44.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC44.m @@ -1,4 +1,4 @@ -IBXSC44 ; ;12/13/08 +IBXSC44 ; ;12/27/07 D DE G BEGIN DE S DIE="^DGCR(399,D0,""CV"",",DIC=DIE,DP=399.047,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"CV",DA,""))="" I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% S %=$P(%Z,U,2) S:%]"" DE(2)=% @@ -49,8 +49,8 @@ SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$ NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") BEGIN S DNM="IBXSC44",DQ=1+D G B -1 S DW="0;1",DV="M*P399.1'X",DU="",DLB="VALUE CODE",DIFLD=.01 - S DE(DW)="C1^IBXSC44",DE(DW,"INDEX")=1 +1 S DW="0;1",DV="M*P399.1'",DU="",DLB="VALUE CODE",DIFLD=.01 + S DE(DW)="C1^IBXSC44" S DU="DGCR(399.1," G RE:'D S DQ=2 G 2 C1 G C1S:$D(DE(1))[0 K DB @@ -59,24 +59,13 @@ C1 G C1S:$D(DE(1))[0 K DB C1S S X="" G:DG(DQ)=X C1F1 K DB S X=DG(DQ),DIC=DIE S ^DGCR(399,DA(1),"CV","B",$E(X,1,30),DA)="" -C1F1 N X,X1,X2 S DIXR=215 D C1X1(U) K X2 M X2=X D C1X1("O") K X1 M X1=X - K X M X=X2 D - . N DIEXARR M DIEXARR=X S DIEZCOND=1 - . S X=$$COND^IBCVC(.DA,X1(1),X2(1)) - . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND - . D REMOVE^IBCVC(.DA) - G C1F2 -C1X1(DION) K X - S X(1)=$G(@DIEZTMP@("V",399.047,DIIENS,.01,DION),$P($G(^DGCR(399,DA(1),"CV",DA,0)),U,1)) - S X=$G(X(1)) - Q -C1F2 Q -X1 S DIC("S")="I +$P($G(^DGCR(399.1,+Y,0)),U,11),$$ALLOWVC^IBCVC(DA(1),+Y)" D ^DIC K DIC S DIC=$G(DIE),X=+Y K:Y<0 X +C1F1 Q +X1 S DIC("S")="I +$P($G(^DGCR(399.1,+Y,0)),U,11)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X Q ; -2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW="0;2",DV="FX",DU="",DLB="VALUE",DIFLD=.02 +2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW="0;2",DV="F",DU="",DLB="VALUE",DIFLD=.02 G RE -X2 K:$L(X)>10!($L(X)<1)!'$$FORMCHK^IBCVC(X,.DA) X +X2 K:$L(X)>9!($L(X)<1) X I $D(X),X'?.ANP K X Q ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC5.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC5.m index ec7e3ca2..d5885028 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC5.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC5.m @@ -1,4 +1,4 @@ -IBXSC5 ; GENERATED FROM 'IB SCREEN5' INPUT TEMPLATE(#511), FILE 399;12/13/08 +IBXSC5 ; GENERATED FROM 'IB SCREEN5' INPUT TEMPLATE(#511), FILE 399;04/07/05 D DE G BEGIN DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))="" I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,3) S:%]"" DE(8)=% S %=$P(%Z,U,9) S:%]"" DE(22)=% @@ -154,7 +154,7 @@ X25 S:IBDR20'["59" Y="@999" X26 I $P(^DGCR(399,DA,0),U,19)=2 S Y="@999" Q 27 S D=0 K DE(1) ;47 - S DIFLD=47,DGO="^IBXSC54",DC="2^399.047PA^CV^",DV="399.047M*P399.1'X",DW="0;1",DOW="VALUE CODE",DLB="Select "_DOW S:D DC=DC_D + S DIFLD=47,DGO="^IBXSC54",DC="2^399.047PA^CV^",DV="399.047M*P399.1'",DW="0;1",DOW="VALUE CODE",DLB="Select "_DOW S:D DC=DC_D S DU="DGCR(399.1," G RE:D I $D(DSC(399.047))#2,$P(DSC(399.047),"I $D(^UTILITY(",1)="" X DSC(399.047) S D=$O(^(0)) S:D="" D=-1 G M27 S D=$S($D(^DGCR(399,DA,"CV",0)):$P(^(0),U,3,4),$O(^(0))'="":$O(^(0)),1:-1) diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC51.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC51.m index 448edd75..b866d6a7 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC51.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC51.m @@ -1,4 +1,4 @@ -IBXSC51 ; ;12/13/08 +IBXSC51 ; ;04/07/05 D DE G BEGIN DE S DIE="^DGCR(399,D0,""OP"",",DIC=DIE,DP=399.043,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"OP",DA,""))="" I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC52.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC52.m index 7b44fe8d..a61f1b8f 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC52.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC52.m @@ -1,4 +1,4 @@ -IBXSC52 ; ;12/13/08 +IBXSC52 ; ;04/07/05 D DE G BEGIN DE S DIE="^DGCR(399,D0,""OC"",",DIC=DIE,DP=399.041,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"OC",DA,""))="" I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% S %=$P(%Z,U,2) S:%]"" DE(2)=% S %=$P(%Z,U,3) S:%]"" DE(4)=% S %=$P(%Z,U,4) S:%]"" DE(8)=% @@ -82,9 +82,9 @@ X5 S Y="@555" 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 X7 I '$P(^DGCR(399.1,+^DGCR(399,DA(1),"OC",DA,0),0),U,10) S Y="@555" Q -8 S DW="0;4",DV="RDX",DU="",DLB="END DATE",DIFLD=.04 +8 S DW="0;4",DV="D",DU="",DLB="END DATE",DIFLD=.04 G RE -X8 S %DT="EX" D ^%DT S X=Y K:X<1 X I $D(X),X<$P($G(^DGCR(399,DA(1),"OC",DA,0)),U,2) K X +X8 S %DT="EX" D ^%DT S X=Y K:Y<1 X Q ; 9 S DQ=10 ;@555 diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC53.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC53.m index a0e0b994..39a31302 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC53.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC53.m @@ -1,4 +1,4 @@ -IBXSC53 ; ;12/13/08 +IBXSC53 ; ;04/07/05 D DE G BEGIN DE S DIE="^DGCR(399,D0,""CC"",",DIC=DIE,DP=399.04,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"CC",DA,""))="" I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC54.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC54.m index 24d6d979..756c694c 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC54.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC54.m @@ -1,4 +1,4 @@ -IBXSC54 ; ;12/13/08 +IBXSC54 ; ;04/07/05 D DE G BEGIN DE S DIE="^DGCR(399,D0,""CV"",",DIC=DIE,DP=399.047,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"CV",DA,""))="" I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% S %=$P(%Z,U,2) S:%]"" DE(2)=% @@ -49,8 +49,8 @@ SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$ NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") BEGIN S DNM="IBXSC54",DQ=1+D G B -1 S DW="0;1",DV="M*P399.1'X",DU="",DLB="VALUE CODE",DIFLD=.01 - S DE(DW)="C1^IBXSC54",DE(DW,"INDEX")=1 +1 S DW="0;1",DV="M*P399.1'",DU="",DLB="VALUE CODE",DIFLD=.01 + S DE(DW)="C1^IBXSC54" S DU="DGCR(399.1," G RE:'D S DQ=2 G 2 C1 G C1S:$D(DE(1))[0 K DB @@ -59,24 +59,13 @@ C1 G C1S:$D(DE(1))[0 K DB C1S S X="" G:DG(DQ)=X C1F1 K DB S X=DG(DQ),DIC=DIE S ^DGCR(399,DA(1),"CV","B",$E(X,1,30),DA)="" -C1F1 N X,X1,X2 S DIXR=215 D C1X1(U) K X2 M X2=X D C1X1("O") K X1 M X1=X - K X M X=X2 D - . N DIEXARR M DIEXARR=X S DIEZCOND=1 - . S X=$$COND^IBCVC(.DA,X1(1),X2(1)) - . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND - . D REMOVE^IBCVC(.DA) - G C1F2 -C1X1(DION) K X - S X(1)=$G(@DIEZTMP@("V",399.047,DIIENS,.01,DION),$P($G(^DGCR(399,DA(1),"CV",DA,0)),U,1)) - S X=$G(X(1)) - Q -C1F2 Q -X1 S DIC("S")="I +$P($G(^DGCR(399.1,+Y,0)),U,11),$$ALLOWVC^IBCVC(DA(1),+Y)" D ^DIC K DIC S DIC=$G(DIE),X=+Y K:Y<0 X +C1F1 Q +X1 S DIC("S")="I +$P($G(^DGCR(399.1,+Y,0)),U,11)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X Q ; -2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW="0;2",DV="FX",DU="",DLB="VALUE",DIFLD=.02 +2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW="0;2",DV="F",DU="",DLB="VALUE",DIFLD=.02 G RE -X2 K:$L(X)>10!($L(X)<1)!'$$FORMCHK^IBCVC(X,.DA) X +X2 K:$L(X)>9!($L(X)<1) X I $D(X),X'?.ANP K X Q ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC6.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC6.m index f2d058d2..5a1c224e 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC6.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC6.m @@ -1,4 +1,4 @@ -IBXSC6 ; GENERATED FROM 'IB SCREEN6' INPUT TEMPLATE(#512), FILE 399;12/13/08 +IBXSC6 ; GENERATED FROM 'IB SCREEN6' INPUT TEMPLATE(#512), FILE 399;12/27/07 D DE G BEGIN DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))="" I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,22) S:%]"" DE(17)=% S %=$P(%Z,U,24) S:%]"" DE(5)=% S %=$P(%Z,U,25) S:%]"" DE(7)=% S %=$P(%Z,U,26) S:%]"" DE(11)=% S %=$P(%Z,U,27) S:%]"" DE(20)=% diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC61.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC61.m index b5a4cc80..9569d793 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC61.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC61.m @@ -1,4 +1,4 @@ -IBXSC61 ; ;12/13/08 +IBXSC61 ; ;12/27/07 S X=DG(DQ),DIC=DIE K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,"",1) X ^DD(399,.22,1,1,1.4) S X=DG(DQ),DIC=DIE diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC610.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC610.m index 46fb0eaa..8009b57b 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC610.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC610.m @@ -1,4 +1,4 @@ -IBXSC610 ; ;12/13/08 +IBXSC610 ; ;12/27/07 S X=DE(22),DIC=DIE K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU-X X ^DD(399,220,1,1,2.4) S X=DE(22),DIC=DIE diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC611.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC611.m index 46736a3d..6deb12a9 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC611.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC611.m @@ -1,4 +1,4 @@ -IBXSC611 ; ;12/13/08 +IBXSC611 ; ;12/27/07 S X=DG(DQ),DIC=DIE K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,220,1,1,1.4) S X=DG(DQ),DIC=DIE diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC612.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC612.m index 2b90a7c7..c7eb3622 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC612.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC612.m @@ -1,4 +1,4 @@ -IBXSC612 ; ;12/13/08 +IBXSC612 ; ;12/27/07 S X=DE(12),DIC=DIE K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(1)=$S($D(^DGCR(399,D0,"RC",D1,0)):^(0),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X="" X ^DD(399.042,.1,1,1,2.4) S X=DE(12),DIC=DIE diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC62.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC62.m index e3f7816b..c5109824 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC62.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC62.m @@ -1,4 +1,4 @@ -IBXSC62 ; ;12/13/08 +IBXSC62 ; ;12/27/07 D DE G BEGIN DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))="" I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,19) S:%]"" DE(1)=%,DE(5)=% diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC63.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC63.m index 951f2455..2d7370b1 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC63.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC63.m @@ -1,4 +1,4 @@ -IBXSC63 ; ;12/13/08 +IBXSC63 ; ;12/27/07 S X=DG(DQ),DIC=DIE K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$$LOS1^IBCU64(DA) X ^DD(399,151,1,1,1.4) S X=DG(DQ),DIC=DIE diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC64.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC64.m index 5eb42423..5c0decc2 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC64.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC64.m @@ -1,4 +1,4 @@ -IBXSC64 ; ;12/13/08 +IBXSC64 ; ;12/27/07 S X=DG(DQ),DIC=DIE K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$$LOS1^IBCU64(DA) X ^DD(399,152,1,1,1.4) S X=DG(DQ),DIC=DIE diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC65.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC65.m index 45d0065d..892b85fa 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC65.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC65.m @@ -1,3 +1,3 @@ -IBXSC65 ; ;12/13/08 +IBXSC65 ; ;12/27/07 S X=DE(23),DIC=DIE ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC66.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC66.m index cf08155e..539fe5e0 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC66.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC66.m @@ -1,3 +1,3 @@ -IBXSC66 ; ;12/13/08 +IBXSC66 ; ;12/27/07 S X=DG(DQ),DIC=DIE X ^DD(399,161,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV D DIS^IBCU S X=X S DIH=$G(^DGCR(399,DIV(0),"U")),DIV=X S $P(^("U"),U,12)=DIV,DIH=399,DIG=162 D ^DICR diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC67.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC67.m index 8ec3ba13..1095b4b1 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC67.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC67.m @@ -1,4 +1,4 @@ -IBXSC67 ; ;12/13/08 +IBXSC67 ; ;12/27/07 D DE G BEGIN DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))="" I $D(^("U")) S %Z=^("U") S %=$P(%Z,U,15) S:%]"" DE(1)=% diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC68.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC68.m index 2eaa8c6e..b45f17f2 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC68.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC68.m @@ -1,4 +1,4 @@ -IBXSC68 ; ;12/13/08 +IBXSC68 ; ;12/27/07 D DE G BEGIN DE S DIE="^DGCR(399,D0,""RC"",",DIC=DIE,DP=399.042,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"RC",DA,""))="" I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% S %=$P(%Z,U,2) S:%]"" DE(2)=% S %=$P(%Z,U,3) S:%]"" DE(3)=% S %=$P(%Z,U,4) S:%]"" DE(4)=% S %=$P(%Z,U,5) S:%]"" DE(5)=% S %=$P(%Z,U,6) S:%]"" DE(7)=% S %=$P(%Z,U,7) S:%]"" DE(9)=% diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC69.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC69.m index 515a7db5..e3db6e5b 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC69.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC69.m @@ -1,4 +1,4 @@ -IBXSC69 ; ;12/13/08 +IBXSC69 ; ;12/27/07 S X=DG(DQ),DIC=DIE K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,219,1,1,1.4) S X=DG(DQ),DIC=DIE diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC7.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC7.m index a934ce31..65a431d2 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC7.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC7.m @@ -1,7 +1,7 @@ -IBXSC7 ; GENERATED FROM 'IB SCREEN7' INPUT TEMPLATE(#513), FILE 399;01/03/09 +IBXSC7 ; GENERATED FROM 'IB SCREEN7' INPUT TEMPLATE(#513), FILE 399;12/27/07 D DE G BEGIN DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))="" - I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,19) S:%]"" DE(29)=% S %=$P(%Z,U,22) S:%]"" DE(21)=% S %=$P(%Z,U,24) S:%]"" DE(11)=% S %=$P(%Z,U,25) S:%]"" DE(13)=% S %=$P(%Z,U,26) S:%]"" DE(17)=% S %=$P(%Z,U,27) S:%]"" DE(24)=% + I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,22) S:%]"" DE(21)=% S %=$P(%Z,U,24) S:%]"" DE(11)=% S %=$P(%Z,U,25) S:%]"" DE(13)=% S %=$P(%Z,U,26) S:%]"" DE(17)=% S %=$P(%Z,U,27) S:%]"" DE(24)=% I $D(^("U")) S %Z=^("U") S %=$P(%Z,U,12) S:%]"" DE(20)=% I $D(^("U2")) S %Z=^("U2") S %=$P(%Z,U,2) S:%]"" DE(18)=% S %=$P(%Z,U,3) S:%]"" DE(19)=% I $D(^("U3")) S %Z=^("U3") S %=$P(%Z,U,2) S:%]"" DE(22)=% @@ -180,11 +180,9 @@ X23 D DISPTAX^IBCEP81($P($G(^DGCR(399,DA,"U3")),U,2),"Default Division") S DU="1:INSTITUTIONAL;2:PROFESSIONAL;" G RE C24 G C24S:$D(DE(24))[0 K DB - S X=DE(24),DIC=DIE - ; + D ^IBXSC73 C24S S X="" G:DG(DQ)=X C24F1 K DB - S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,19),X=X S DIU=X K Y S X=DIV S X=$$FT^IBCU3(DA,1) X ^DD(399,.27,1,1,1.4) + D ^IBXSC74 C24F1 Q X24 Q 25 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=25 D X25 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 @@ -197,34 +195,4 @@ X26 S DIPA("FT1")=$P($G(^DGCR(399,DA,0)),U,19) X27 D CKFT^IBCIUT1(IBIFN) Q 28 S DQ=29 ;@714 -29 D:$D(DG)>9 F^DIE17,DE S DQ=29,DW="0;19",DV="R*P353'",DU="",DLB="FORM TYPE",DIFLD=.19 - S DE(DW)="C29^IBXSC7" - S DU="IBE(353," - G RE -C29 G C29S:$D(DE(29))[0 K DB - S X=DE(29),DIC=DIE - ; - S X=DE(29),DIC=DIE - S DGRVRCAL=2 - S X=DE(29),DIC=DIE - D ALLID^IBCEP3(DA,.19,2) - S X=DE(29),DIC=DIE - ; - S X=DE(29),DIC=DIE - D ATTREND^IBCU1(DA,"","") -C29S S X="" G:DG(DQ)=X C29F1 K DB - D ^IBXSC73 -C29F1 Q -X29 S DIC("S")="N Z S Z=$G(^IBE(353,Y,2)) I $P(Z,U,2)=""P"",$P(Z,U,4)" D ^DIC K DIC S DIC=$G(DIE),X=+Y K:Y<0 X - Q - ; -30 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=30 D X30 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X30 S DIPA("FT")=$P($G(^DGCR(399,DA,0)),U,19) - Q -31 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=31 D X31 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X31 I $P($G(^IBE(353,+DIPA("FT"),2)),U,2)="P",$P($G(^(2)),U,4) S DIPA("FT1")=DIPA("FT") D CKFT^IBCIUT1(IBIFN) S Y="@715" - Q -32 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=32 D X32 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X32 W !,*7,"Must be a printable national form type" - Q -33 D:$D(DG)>9 F^DIE17 G ^IBXSC74 +29 D:$D(DG)>9 F^DIE17 G ^IBXSC75 diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC71.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC71.m index 7923e3d4..4240dd2d 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC71.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC71.m @@ -1,4 +1,4 @@ -IBXSC71 ; ;01/03/09 +IBXSC71 ; ;12/27/07 D DE G BEGIN DE S DIE="^DGCR(399,D0,""OP"",",DIC=DIE,DP=399.043,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"OP",DA,""))="" I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC710.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC710.m index f07ea386..b7219b19 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC710.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC710.m @@ -1,4 +1,4 @@ -IBXSC710 ; ;12/13/08 +IBXSC710 ; ;12/27/07 S X=DG(DQ),DIC=DIE K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,220,1,1,1.4) S X=DG(DQ),DIC=DIE diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC711.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC711.m index b14c54c6..ecf2001d 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC711.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC711.m @@ -1,4 +1,4 @@ -IBXSC711 ; ;12/13/08 +IBXSC711 ; ;12/27/07 S X=DE(11),DIC=DIE K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(1)=$S($D(^DGCR(399,D0,"RC",D1,0)):^(0),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X="" X ^DD(399.042,.1,1,1,2.4) S X=DE(11),DIC=DIE diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC712.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC712.m index 8a4d395a..f0e2bda7 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC712.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC712.m @@ -1,4 +1,4 @@ -IBXSC712 ; ;12/13/08 +IBXSC712 ; ;12/27/07 D DE G BEGIN DE S DIE="^DGCR(399,D0,""RC"",",DIC=DIE,DP=399.042,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"RC",DA,""))="" I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,15) S:%]"" DE(1)=% diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC72.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC72.m index 5177b181..386ecd5e 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC72.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC72.m @@ -1,4 +1,4 @@ -IBXSC72 ; ;01/03/09 +IBXSC72 ; ;12/27/07 S X=DG(DQ),DIC=DIE K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,"",1) X ^DD(399,.22,1,1,1.4) S X=DG(DQ),DIC=DIE diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC73.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC73.m index 3a51e8b7..81fd1f08 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC73.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC73.m @@ -1,11 +1,3 @@ -IBXSC73 ; ;01/03/09 - S X=DG(DQ),DIC=DIE - X ^DD(399,.19,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,9),X=X S DIU=X K Y S X=DIV S X=5 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,9)=DIV,DIH=399,DIG=.09 D ^DICR - S X=DG(DQ),DIC=DIE - S DGRVRCAL=1 - S X=DG(DQ),DIC=DIE - D ALLID^IBCEP3(DA,.19,1) - S X=DG(DQ),DIC=DIE - D BILLPNS^IBCU(DA) - S X=DG(DQ),DIC=DIE - D ATTREND^IBCU1(DA,"","") +IBXSC73 ; ;12/27/07 + S X=DE(24),DIC=DIE + ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC74.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC74.m index 06386c9a..0c25d0ee 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC74.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC74.m @@ -1,250 +1,3 @@ -IBXSC74 ; ;01/03/09 - D DE G BEGIN -DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))="" - I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,19) S:%]"" DE(1)=% - I $D(^("U")) S %Z=^("U") S %=$P(%Z,U,1) S:%]"" DE(15)=% S %=$P(%Z,U,2) S:%]"" DE(16)=% S %=$P(%Z,U,3) S:%]"" DE(12)=% S %=$P(%Z,U,5) S:%]"" DE(7)=% S %=$P(%Z,U,6) S:%]"" DE(10)=% S %=$P(%Z,U,7) S:%]"" DE(9)=% - I $D(^("U1")) S %Z=^("U1") S %=$P(%Z,U,2) S:%]"" DE(21)=% S %=$P(%Z,U,3) S:%]"" DE(23)=% S %=$P(%Z,U,10) S:%]"" DE(26)=% - I $D(^("U2")) S %Z=^("U2") S %=$P(%Z,U,4) S:%]"" DE(31)=% - K %Z Q - ; -W W !?DL+DL-2,DLB_": " - Q -O D W W Y W:$X>45 !?9 - I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 - W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q -TR R X:DTIME E S (DTOUT,X)=U W $C(7) - Q -A K DQ(DQ) S DQ=DQ+1 -B G @DQ -RE G PR:$D(DE(DQ)) D W,TR -N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A -RD G QS:X?."?" I X["^" D D G ^DIE17 - I X="@" D D G Z^DIE2 - I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X -T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V - K DDER G X -P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 - G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z - I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X -V D @("X"_DQ) K YS -Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A -X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 - S X="?BAD" -QS S DZ=X D D,QQ^DIEQ G B -D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q -Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N -PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP -R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R - I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R - X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% -RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 -I I DV'["I",DV'["#" G RD - D E^DIE0 G RD:$D(X),PR - Q -SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 - I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 - D ^DIR I 'DDER S %=Y(0),X=Y - Q -SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) - I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" - E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") - Q -NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS -KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") -BEGIN S DNM="IBXSC74",DQ=1 -1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="0;19",DV="R*P353'",DU="",DLB="FORM TYPE",DIFLD=.19 - S DE(DW)="C1^IBXSC74" - S DU="IBE(353," - S X=$G(DIPA("FT1")) - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -C1 G C1S:$D(DE(1))[0 K DB - S X=DE(1),DIC=DIE - ; - S X=DE(1),DIC=DIE - S DGRVRCAL=2 - S X=DE(1),DIC=DIE - D ALLID^IBCEP3(DA,.19,2) - S X=DE(1),DIC=DIE - ; - S X=DE(1),DIC=DIE - D ATTREND^IBCU1(DA,"","") -C1S S X="" G:DG(DQ)=X C1F1 K DB +IBXSC74 ; ;12/27/07 S X=DG(DQ),DIC=DIE - X ^DD(399,.19,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,9),X=X S DIU=X K Y S X=DIV S X=5 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,9)=DIV,DIH=399,DIG=.09 D ^DICR - S X=DG(DQ),DIC=DIE - S DGRVRCAL=1 - S X=DG(DQ),DIC=DIE - D ALLID^IBCEP3(DA,.19,1) - S X=DG(DQ),DIC=DIE - D BILLPNS^IBCU(DA) - S X=DG(DQ),DIC=DIE - D ATTREND^IBCU1(DA,"","") -C1F1 Q -X1 S DIC("S")="N Z S Z=$G(^IBE(353,Y,2)) I $P(Z,U,2)=""P"",$P(Z,U,4)" D ^DIC K DIC S DIC=$G(DIE),X=+Y K:Y<0 X - Q - ; -2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X2 S Y="@714" - Q -3 S DQ=4 ;@715 -4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X4 D FTPRV^IBCEU5(DA) - Q -5 S DQ=6 ;@72 -6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X6 S:IBDR20'["72" Y="@73" - Q -7 D:$D(DG)>9 F^DIE17,DE S DQ=7,DW="U;5",DV="RFOX",DU="",DLB="IS THIS A SENSITIVE RECORD?",DIFLD=155 - S DQ(7,2)="S Y(0)=Y S Y=$S(Y:""YES"",Y=0:""NO"",1:"""")" - G RE -X7 I $D(X) D YN^IBCU - I $D(X),X'?.ANP K X - Q - ; -8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X8 S:X=0 Y=156 - Q -9 S DW="U;7",DV="FOX",DU="",DLB="R.O.I. FORM(S) COMPLETED?",DIFLD=157 - S DQ(9,2)="S Y(0)=Y S Y=$S(Y:""YES"",Y=0:""NO"",1:"""")" - G RE -X9 I $D(X) D YN^IBCU - I $D(X),X'?.ANP K X - Q - ; -10 S DW="U;6",DV="RFOX",DU="",DLB="ASSIGNMENT OF BENEFITS",DIFLD=156 - S DQ(10,2)="S Y(0)=Y S Y=$S(Y="""":"""",""Yy1""[Y:""YES"",""Nn0""[Y:""NO"",1:"""")" - G RE -X10 I $D(X) D YN^IBCU I $D(X) X:X=0 ^DD(399,156,9.3) K IBRATY - I $D(X),X'?.ANP K X - Q - ; -11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X11 S:'$D(IBOX) Y="@73" - Q -12 S DW="U;3",DV="RFOX",DU="",DLB="POWER OF ATTORNEY COMPLETED?",DIFLD=153 - S DQ(12,2)="S Y(0)=Y S Y=$S(Y:""YES"",Y=0:""NO"",1:"""")" - G RE -X12 I $D(X) D YN^IBCU - I $D(X),X'?.ANP K X - Q - ; -13 S DQ=14 ;@73 -14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X14 S:IBDR20'["73" Y="@75" - Q -15 S DW="U;1",DV="RDX",DU="",DLB="STATEMENT COVERS FROM",DIFLD=151 - S DE(DW)="C15^IBXSC74" - G RE -C15 G C15S:$D(DE(15))[0 K DB - S X=DE(15),DIC=DIE - ; - S X=DE(15),DIC=DIE - S DGRVRCAL=2 - S X=DE(15),DIC=DIE - ; - S X=DE(15),DIC=DIE - K:$P(^DGCR(399,DA,0),"^",2) ^DGCR(399,"APDS",$P(^(0),U,2),-X,DA) -C15S S X="" G:DG(DQ)=X C15F1 K DB - S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$$LOS1^IBCU64(DA) X ^DD(399,151,1,1,1.4) - S X=DG(DQ),DIC=DIE - S DGRVRCAL=1 - S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I +$G(^DGCR(399,DA,"U1"))=0 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV S X=0 X ^DD(399,151,1,3,1.4) - S X=DG(DQ),DIC=DIE - S:$P(^DGCR(399,DA,0),"^",2) ^DGCR(399,"APDS",$P(^(0),U,2),-X,DA)="" -C15F1 Q -X15 S %DT="ETP" D ^%DT S X=Y K:Y<1 X I $D(X) D DDAT^IBCU4 K IB00 - Q - ; -16 D:$D(DG)>9 F^DIE17,DE S DQ=16,DW="U;2",DV="RDX",DU="",DLB="STATEMENT COVERS TO",DIFLD=152 - S DE(DW)="C16^IBXSC74" - G RE -C16 G C16S:$D(DE(16))[0 K DB - S X=DE(16),DIC=DIE - ; - S X=DE(16),DIC=DIE - S DGRVRCAL=2 -C16S S X="" G:DG(DQ)=X C16F1 K DB - S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$$LOS1^IBCU64(DA) X ^DD(399,152,1,1,1.4) - S X=DG(DQ),DIC=DIE - S DGRVRCAL=1 -C16F1 Q -X16 S %DT="ETP" D ^%DT S X=Y K:Y<1 X I $D(X) D DDAT1^IBCU4 K IB00 - Q - ; -17 S DQ=18 ;@75 -18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X18 S:IBDR20'["75" Y="@76" - Q -19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X19 D RCD^IBCU1 - Q -20 D:$D(DG)>9 F^DIE17,DE S DQ=20,D=0 K DE(1) ;42 - S DIFLD=42,DGO="^IBXSC75",DC="15^399.042IPA^RC^",DV="399.042MR*P399.2'",DW="0;1",DOW="REVENUE CODE",DLB="Select "_DOW S:D DC=DC_D - S DU="DGCR(399.2," - G RE:D I $D(DSC(399.042))#2,$P(DSC(399.042),"I $D(^UTILITY(",1)="" X DSC(399.042) S D=$O(^(0)) S:D="" D=-1 G M20 - S D=$S($D(^DGCR(399,DA,"RC",0)):$P(^(0),U,3,4),$O(^(0))'="":$O(^(0)),1:-1) -M20 I D>0 S DC=DC_D I $D(^DGCR(399,DA,"RC",+D,0)) S DE(20)=$P(^(0),U,1) - G RE -R20 D DE - S D=$S($D(^DGCR(399,DA,"RC",0)):$P(^(0),U,3,4),1:1) G 20+1 - ; -21 S DW="U1;2",DV="NJ8,2",DU="",DLB="OFFSET AMOUNT",DIFLD=202 - S DE(DW)="C21^IBXSC74" - G RE -C21 G C21S:$D(DE(21))[0 K DB - S X=DE(21),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" X ^DD(399,202,1,1,2.4) -C21S S X="" G:DG(DQ)=X C21F1 K DB - S X=DG(DQ),DIC=DIE - ; -C21F1 Q -X21 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999)!(X<0) X - Q - ; -22 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=22 D X22 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X22 S:'X Y="@757" - Q -23 D:$D(DG)>9 F^DIE17,DE S DQ=23,DW="U1;3",DV="FX",DU="",DLB="OFFSET DESCRIPTION",DIFLD=203 - G RE -X23 K:$L(X)>24!($L(X)<3) X - I $D(X),X'?.ANP K X - Q - ; -24 S DQ=25 ;@757 -25 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=25 D X25 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X25 I $P(^DGCR(399,DA,"U1"),"^",11)']"" S Y="@76" - Q -26 S DW="U1;10",DV="RNJ10,2",DU="",DLB="*FY 1 CHARGES",DIFLD=210 - G RE -X26 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>9999999)!(X<0) X - Q - ; -27 S DQ=28 ;@76 -28 S DQ=29 ;@77 -29 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=29 D X29 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X29 S:IBDR20'["77" Y="@78" - Q -30 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=30 D X30 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X30 S:'$D(^DGCR(399,DA,"I1")) Y="@772" - Q -31 S DW="U2;4",DV="NJ11,2",DU="",DLB="PRIMARY PRIOR PAYMENT",DIFLD=218 - S DE(DW)="C31^IBXSC74" - G RE -C31 G C31S:$D(DE(31))[0 K DB - D ^IBXSC76 -C31S S X="" G:DG(DQ)=X C31F1 K DB - D ^IBXSC77 -C31F1 Q -X31 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999999)!(X<0) X - Q - ; -32 S DQ=33 ;@772 -33 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=33 D X33 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X33 S:'$D(^DGCR(399,DA,"I2")) Y="@773" - Q -34 D:$D(DG)>9 F^DIE17 G ^IBXSC78 + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,19),X=X S DIU=X K Y S X=DIV S X=$$FT^IBCU3(DA,1) X ^DD(399,.27,1,1,1.4) diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC75.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC75.m index 9aae067c..cd54ba28 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC75.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC75.m @@ -1,8 +1,8 @@ -IBXSC75 ; ;01/03/09 +IBXSC75 ; ;12/27/07 D DE G BEGIN -DE S DIE="^DGCR(399,D0,""RC"",",DIC=DIE,DP=399.042,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"RC",DA,""))="" - I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% S %=$P(%Z,U,2) S:%]"" DE(2)=% S %=$P(%Z,U,3) S:%]"" DE(3)=% S %=$P(%Z,U,4) S:%]"" DE(4)=% S %=$P(%Z,U,5) S:%]"" DE(5)=% S %=$P(%Z,U,6) S:%]"" DE(7)=% S %=$P(%Z,U,7) S:%]"" DE(9)=% - I S %=$P(%Z,U,9) S:%]"" DE(6)=% S %=$P(%Z,U,10) S:%]"" DE(12)=% S %=$P(%Z,U,12) S:%]"" DE(13)=% S %=$P(%Z,U,15) S:%]"" DE(18)=% +DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))="" + I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,19) S:%]"" DE(1)=%,DE(5)=% + I $D(^("U")) S %Z=^("U") S %=$P(%Z,U,1) S:%]"" DE(19)=% S %=$P(%Z,U,2) S:%]"" DE(20)=% S %=$P(%Z,U,3) S:%]"" DE(16)=% S %=$P(%Z,U,5) S:%]"" DE(11)=% S %=$P(%Z,U,6) S:%]"" DE(14)=% S %=$P(%Z,U,7) S:%]"" DE(13)=% K %Z Q ; W W !?DL+DL-2,DLB_": " @@ -49,197 +49,165 @@ SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$ Q NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") -BEGIN S DNM="IBXSC75",DQ=1+D G B -1 S DW="0;1",DV="MR*P399.2'",DU="",DLB="REVENUE CODE",DIFLD=.01 - S DE(DW)="C1^IBXSC75",DE(DW,"INDEX")=1 - S DU="DGCR(399.2," - G RE:'D S DQ=2 G 2 +BEGIN S DNM="IBXSC75",DQ=1 +1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="0;19",DV="R*P353'",DU="",DLB="FORM TYPE",DIFLD=.19 + S DE(DW)="C1^IBXSC75" + S DU="IBE(353," + G RE C1 G C1S:$D(DE(1))[0 K DB S X=DE(1),DIC=DIE - K ^DGCR(399,DA(1),"RC","B",$E(X,1,30),DA) + ; S X=DE(1),DIC=DIE - I $P(^DGCR(399,DA(1),"RC",DA,0),U,5) K ^DGCR(399,DA(1),"RC","ABS",$P(^DGCR(399,DA(1),"RC",DA,0),U,5),$E(X,1,30),DA) + S DGRVRCAL=2 + S X=DE(1),DIC=DIE + D ALLID^IBCEP3(DA,.19,2) + S X=DE(1),DIC=DIE + ; + S X=DE(1),DIC=DIE + D ATTREND^IBCU1(DA,"","") C1S S X="" G:DG(DQ)=X C1F1 K DB S X=DG(DQ),DIC=DIE - S ^DGCR(399,DA(1),"RC","B",$E(X,1,30),DA)="" + X ^DD(399,.19,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,9),X=X S DIU=X K Y S X=DIV S X=5 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,9)=DIV,DIH=399,DIG=.09 D ^DICR S X=DG(DQ),DIC=DIE - I $P(^DGCR(399,DA(1),"RC",DA,0),U,5) S ^DGCR(399,DA(1),"RC","ABS",$P(^DGCR(399,DA(1),"RC",DA,0),U,5),$E(X,1,30),DA)="" -C1F1 N X,X1,X2 S DIXR=53 D C1X1(U) K X2 M X2=X D C1X1("O") K X1 M X1=X - I $G(X(1))]"" D - . I X(2)'=""&'$D(^TMP("IBCRRX",$J)) D DELPR^IBCU1(DA(1),X(2)) - G C1F2 -C1X1(DION) K X - S X(1)=$G(@DIEZTMP@("V",399.042,DIIENS,.01,DION),$P($G(^DGCR(399,DA(1),"RC",DA,0)),U,1)) - S X(2)=$G(@DIEZTMP@("V",399.042,DIIENS,.15,DION),$P($G(^DGCR(399,DA(1),"RC",DA,0)),U,15)) - S X=$G(X(1)) - Q -C1F2 Q -X1 S DIC("S")="I +$P(^(0),U,3)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X + S DGRVRCAL=1 + S X=DG(DQ),DIC=DIE + D ALLID^IBCEP3(DA,.19,1) + S X=DG(DQ),DIC=DIE + D BILLPNS^IBCU(DA) + S X=DG(DQ),DIC=DIE + D ATTREND^IBCU1(DA,"","") +C1F1 Q +X1 S DIC("S")="N Z S Z=$G(^IBE(353,Y,2)) I $P(Z,U,2)=""P"",$P(Z,U,4)" D ^DIC K DIC S DIC=$G(DIE),X=+Y K:Y<0 X Q ; -2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW="0;2",DV="RNJ8,2",DU="",DLB="CHARGES",DIFLD=.02 - S DE(DW)="C2^IBXSC75" - G RE -C2 G C2S:$D(DE(2))[0 K DB - S X=DE(2),DIC=DIE - D 22^IBCU2 -C2S S X="" G:DG(DQ)=X C2F1 K DB - S X=DG(DQ),DIC=DIE - D 21^IBCU2 -C2F1 Q -X2 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999)!(X<0) X +2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X2 S DIPA("FT")=$P($G(^DGCR(399,DA,0)),U,19) Q - ; -3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW="0;3",DV="RNJ6,0X",DU="",DLB="UNITS OF SERVICE",DIFLD=.03 - S DE(DW)="C3^IBXSC75" - G RE -C3 G C3S:$D(DE(3))[0 K DB - S X=DE(3),DIC=DIE - D 32^IBCU2 -C3S S X="" G:DG(DQ)=X C3F1 K DB - S X=DG(DQ),DIC=DIE - D 31^IBCU2 -C3F1 Q -X3 K:X'?1.N X I $D(X) S:X=0 X=1 +3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X3 I $P($G(^IBE(353,+DIPA("FT"),2)),U,2)="P",$P($G(^(2)),U,4) S DIPA("FT1")=DIPA("FT") D CKFT^IBCIUT1(IBIFN) S Y="@715" Q - ; -4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW="0;4",DV="RNJ9,2XI",DU="",DLB="TOTAL",DIFLD=.04 - S DE(DW)="C4^IBXSC75" - G RE -C4 G C4S:$D(DE(4))[0 K DB - S X=DE(4),DIC=DIE - S DGXRF=2 D TC^IBCU2 K DGXRF -C4S S X="" G:DG(DQ)=X C4F1 K DB - S X=DG(DQ),DIC=DIE - S DGXRF=1 D TC^IBCU2 K DGXRF -C4F1 Q -X4 K:X?1.10N.1".".2N X +4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X4 W !,*7,"Must be a printable national form type" Q - ; -5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW="0;5",DV="R*P399.1'",DU="",DLB="BEDSECTION",DIFLD=.05 +5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW="0;19",DV="R*P353'",DU="",DLB="FORM TYPE",DIFLD=.19 S DE(DW)="C5^IBXSC75" - S DU="DGCR(399.1," - G RE + S DU="IBE(353," + S X=$G(DIPA("FT1")) + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD C5 G C5S:$D(DE(5))[0 K DB S X=DE(5),DIC=DIE - K ^DGCR(399,DA(1),"RC","ABS",$E(X,1,30),+^DGCR(399,DA(1),"RC",DA,0),DA) + ; + S X=DE(5),DIC=DIE + S DGRVRCAL=2 + S X=DE(5),DIC=DIE + D ALLID^IBCEP3(DA,.19,2) + S X=DE(5),DIC=DIE + ; + S X=DE(5),DIC=DIE + D ATTREND^IBCU1(DA,"","") C5S S X="" G:DG(DQ)=X C5F1 K DB S X=DG(DQ),DIC=DIE - S ^DGCR(399,DA(1),"RC","ABS",$E(X,1,30),+^DGCR(399,DA(1),"RC",DA,0),DA)="" + X ^DD(399,.19,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,9),X=X S DIU=X K Y S X=DIV S X=5 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,9)=DIV,DIH=399,DIG=.09 D ^DICR + S X=DG(DQ),DIC=DIE + S DGRVRCAL=1 + S X=DG(DQ),DIC=DIE + D ALLID^IBCEP3(DA,.19,1) + S X=DG(DQ),DIC=DIE + D BILLPNS^IBCU(DA) + S X=DG(DQ),DIC=DIE + D ATTREND^IBCU1(DA,"","") C5F1 Q -X5 S DIC("S")="I $P(^(0),U,5)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X +X5 S DIC("S")="N Z S Z=$G(^IBE(353,Y,2)) I $P(Z,U,2)=""P"",$P(Z,U,4)" D ^DIC K DIC S DIC=$G(DIE),X=+Y K:Y<0 X Q ; -6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW="0;9",DV="NJ8,2",DU="",DLB="NON-COVERED CHARGE",DIFLD=.09 - G RE -X6 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999)!(X<0)!(X?.E1"."3.N) X +6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X6 S Y="@714" Q - ; -7 S DW="0;6",DV="*P81'",DU="",DLB="PROCEDURE",DIFLD=.06 - S DE(DW)="C7^IBXSC75" - S DU="ICPT(" - G RE -C7 G C7S:$D(DE(7))[0 K DB - S X=DE(7),DIC=DIE - K ^DGCR(399,"ASC1",$E(X,1,30),DA(1),DA) - S X=DE(7),DIC=DIE - K ^DGCR(399,"ASC2",DA(1),$E(X,1,30),DA) -C7S S X="" G:DG(DQ)=X C7F1 K DB - S X=DG(DQ),DIC=DIE - I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC1",$E(X,1,30),DA(1),DA)="" - S X=DG(DQ),DIC=DIE - I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC2",DA(1),$E(X,1,30),DA)="" -C7F1 Q -X7 S ICPTVDT=$$BDATE^IBACSV($G(DA(1))),DIC("S")="I $$CPTACT^IBACSV(+Y,ICPTVDT)",DIC("W")="D EN^DDIOL("" ""_$P($$CPT^IBACSV(+Y,ICPTVDT),U,2),,""?0"")" D ^DIC K DIC S DIC=$G(DIE),X=+Y K:Y<0 X - Q - ; +7 S DQ=8 ;@715 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X8 I '$P(^DGCR(399,DA(1),"RC",DA,0),U,6) S Y="@758" +X8 D FTPRV^IBCEU5(DA) Q -9 D:$D(DG)>9 F^DIE17,DE S DQ=9,DW="0;7",DV="P40.8'X",DU="",DLB="DIVISION",DIFLD=.07 - S DE(DW)="C9^IBXSC75" - S DU="DG(40.8," - S X=$$DEFDIV^IBCU7(DA(1)) - S Y=X - G Y -C9 G C9S:$D(DE(9))[0 K DB - S X=DE(9),DIC=DIE - K ^DGCR(399,"ASC1",+$P(^DGCR(399,DA(1),"RC",DA,0),U,6),DA(1),DA) - S X=DE(9),DIC=DIE - K ^DGCR(399,"ASC2",DA(1),+$P(^DGCR(399,DA(1),"RC",DA,0),U,6),DA) -C9S S X="" G:DG(DQ)=X C9F1 K DB - S X=DG(DQ),DIC=DIE - I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC1",$P(^DGCR(399,DA(1),"RC",DA,0),U,6),DA(1),DA)="" - S X=DG(DQ),DIC=DIE - I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC2",DA(1),$P(^DGCR(399,DA(1),"RC",DA,0),U,6),DA)="" -C9F1 Q -X9 Q -10 S DQ=11 ;@758 -11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X11 I +$P(^DGCR(399,DA(1),"RC",DA,0),U,8) W !," AUTO ADDED CHARGE - NO CHANGE TO TYPE/COMPONENT" S Y="@759" +9 S DQ=10 ;@72 +10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X10 S:IBDR20'["72" Y="@73" Q -12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW="0;10",DV="S",DU="",DLB="TYPE",DIFLD=.1 - S DE(DW)="C12^IBXSC75" - S DU="1:INPT BS;2:OPT VST DT;3:RX;4:CPT;5:PROS;6:DRG;9:UNASSOCIATED;" +11 D:$D(DG)>9 F^DIE17,DE S DQ=11,DW="U;5",DV="RFOX",DU="",DLB="IS THIS A SENSITIVE RECORD?",DIFLD=155 + S DQ(11,2)="S Y(0)=Y S Y=$S(Y:""YES"",Y=0:""NO"",1:"""")" G RE -C12 G C12S:$D(DE(12))[0 K DB - S X=DE(12),DIC=DIE - K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(1)=$S($D(^DGCR(399,D0,"RC",D1,0)):^(0),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X="" X ^DD(399.042,.1,1,1,2.4) - S X=DE(12),DIC=DIE - X ^DD(399.042,.1,1,2,2.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"RC",D1,0)):^(0),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X="" S DIH=$G(^DGCR(399,DIV(0),"RC",DIV(1),0)),DIV=X S $P(^(0),U,15)=DIV,DIH=399.042,DIG=.15 D ^DICR -C12S S X="" G:DG(DQ)=X C12F1 K DB - S X=DG(DQ),DIC=DIE - ; - S X=DG(DQ),DIC=DIE - ; -C12F1 Q -X12 Q -13 D:$D(DG)>9 F^DIE17,DE S DQ=13,DW="0;12",DV="S",DU="",DLB="COMPONENT",DIFLD=.12 - S DU="1:INSTITUTIONAL;2:PROFESSIONAL;" - G RE -X13 Q -14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X14 I $S($P($G(^DGCR(399,DA(1),"RC",DA,0)),U,10)=3:0,1:$P($G(^(0)),U,10)'=4)!$P($G(^(0)),U,8) S Y="@759" - Q -15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X15 I $P($G(^DGCR(399,DA(1),"RC",DA,0)),U,10)=4 S Y="@7581" - Q -16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X16 S DGRVRCAL=1 - Q -17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X17 D LINKRX^IBCEU5(DA(1),DA) - Q -18 S DW="0;15",DV="FXO",DU="",DLB="RX PROCEDURE",DIFLD=.15 - S DQ(18,2)="S Y(0)=Y S Y=Y_"" - ""_$P($$PRCNM^IBCSCH1($P($G(^DGCR(399,D0,""CP"",+Y,0)),U)),U)" - S DE(DW)="C18^IBXSC75",DE(DW,"INDEX")=1 - G RE -C18 G C18S:$D(DE(18))[0 K DB - S X=DE(18),DIC=DIE - K ^DGCR(399,DA(1),"RC","ACP",$E(X,1,30),DA) -C18S S X="" G:DG(DQ)=X C18F1 K DB - S X=DG(DQ),DIC=DIE - S ^DGCR(399,DA(1),"RC","ACP",$E(X,1,30),DA)="" -C18F1 N X,X1,X2 S DIXR=53 D C18X1(U) K X2 M X2=X D C18X1("O") K X1 M X1=X - I $G(X(1))]"" D - . I X(2)'=""&'$D(^TMP("IBCRRX",$J)) D DELPR^IBCU1(DA(1),X(2)) - G C18F2 -C18X1(DION) K X - S X(1)=$G(@DIEZTMP@("V",399.042,DIIENS,.01,DION),$P($G(^DGCR(399,DA(1),"RC",DA,0)),U,1)) - S X(2)=$G(@DIEZTMP@("V",399.042,DIIENS,.15,DION),$P($G(^DGCR(399,DA(1),"RC",DA,0)),U,15)) - S X=$G(X(1)) - Q -C18F2 Q -X18 S X=$$RXPRLOOK^IBCEU4(X) K:'X X +X11 I $D(X) D YN^IBCU I $D(X),X'?.ANP K X Q ; -19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X19 S Y="@759" +12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X12 S:X=0 Y=156 Q -20 S DQ=21 ;@7581 -21 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=21 D X21 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X21 D LINKCPT^IBCEU5(DA(1),DA) +13 S DW="U;7",DV="FOX",DU="",DLB="R.O.I. FORM(S) COMPLETED?",DIFLD=157 + S DQ(13,2)="S Y(0)=Y S Y=$S(Y:""YES"",Y=0:""NO"",1:"""")" + G RE +X13 I $D(X) D YN^IBCU + I $D(X),X'?.ANP K X Q -22 S DQ=23 ;@759 -23 G 1^DIE17 + ; +14 S DW="U;6",DV="RFOX",DU="",DLB="ASSIGNMENT OF BENEFITS",DIFLD=156 + S DQ(14,2)="S Y(0)=Y S Y=$S(Y="""":"""",""Yy1""[Y:""YES"",""Nn0""[Y:""NO"",1:"""")" + G RE +X14 I $D(X) D YN^IBCU I $D(X) X:X=0 ^DD(399,156,9.3) K IBRATY + I $D(X),X'?.ANP K X + Q + ; +15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X15 S:'$D(IBOX) Y="@73" + Q +16 S DW="U;3",DV="RFOX",DU="",DLB="POWER OF ATTORNEY COMPLETED?",DIFLD=153 + S DQ(16,2)="S Y(0)=Y S Y=$S(Y:""YES"",Y=0:""NO"",1:"""")" + G RE +X16 I $D(X) D YN^IBCU + I $D(X),X'?.ANP K X + Q + ; +17 S DQ=18 ;@73 +18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X18 S:IBDR20'["73" Y="@75" + Q +19 S DW="U;1",DV="RDX",DU="",DLB="STATEMENT COVERS FROM",DIFLD=151 + S DE(DW)="C19^IBXSC75" + G RE +C19 G C19S:$D(DE(19))[0 K DB + S X=DE(19),DIC=DIE + ; + S X=DE(19),DIC=DIE + S DGRVRCAL=2 + S X=DE(19),DIC=DIE + ; + S X=DE(19),DIC=DIE + K:$P(^DGCR(399,DA,0),"^",2) ^DGCR(399,"APDS",$P(^(0),U,2),-X,DA) +C19S S X="" G:DG(DQ)=X C19F1 K DB + D ^IBXSC76 +C19F1 Q +X19 S %DT="ETP" D ^%DT S X=Y K:Y<1 X I $D(X) D DDAT^IBCU4 K IB00 + Q + ; +20 D:$D(DG)>9 F^DIE17,DE S DQ=20,DW="U;2",DV="RDX",DU="",DLB="STATEMENT COVERS TO",DIFLD=152 + S DE(DW)="C20^IBXSC75" + G RE +C20 G C20S:$D(DE(20))[0 K DB + S X=DE(20),DIC=DIE + ; + S X=DE(20),DIC=DIE + S DGRVRCAL=2 +C20S S X="" G:DG(DQ)=X C20F1 K DB + D ^IBXSC77 +C20F1 Q +X20 S %DT="ETP" D ^%DT S X=Y K:Y<1 X I $D(X) D DDAT1^IBCU4 K IB00 + Q + ; +21 S DQ=22 ;@75 +22 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=22 D X22 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X22 S:IBDR20'["75" Y="@76" + Q +23 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=23 D X23 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X23 D RCD^IBCU1 + Q +24 D:$D(DG)>9 F^DIE17 G ^IBXSC78 diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC76.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC76.m index 8ac6d069..31355423 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC76.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC76.m @@ -1,5 +1,9 @@ -IBXSC76 ; ;01/03/09 - S X=DE(31),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU-X X ^DD(399,218,1,1,2.4) - S X=DE(31),DIC=DIE - ; +IBXSC76 ; ;12/27/07 + S X=DG(DQ),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$$LOS1^IBCU64(DA) X ^DD(399,151,1,1,1.4) + S X=DG(DQ),DIC=DIE + S DGRVRCAL=1 + S X=DG(DQ),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I +$G(^DGCR(399,DA,"U1"))=0 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV S X=0 X ^DD(399,151,1,3,1.4) + S X=DG(DQ),DIC=DIE + S:$P(^DGCR(399,DA,0),"^",2) ^DGCR(399,"APDS",$P(^(0),U,2),-X,DA)="" diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC77.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC77.m index 08d73835..36ac7312 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC77.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC77.m @@ -1,5 +1,5 @@ -IBXSC77 ; ;01/03/09 +IBXSC77 ; ;12/27/07 S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,218,1,1,1.4) + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$$LOS1^IBCU64(DA) X ^DD(399,152,1,1,1.4) S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X="PRIOR PAYMENT(S)" X ^DD(399,218,1,2,1.4) + S DGRVRCAL=1 diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC78.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC78.m index bdad5901..9b7a5589 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC78.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC78.m @@ -1,7 +1,8 @@ -IBXSC78 ; ;01/03/09 +IBXSC78 ; ;12/27/07 D DE G BEGIN DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))="" - I $D(^("U2")) S %Z=^("U2") S %=$P(%Z,U,5) S:%]"" DE(1)=% S %=$P(%Z,U,6) S:%]"" DE(4)=% + I $D(^("U1")) S %Z=^("U1") S %=$P(%Z,U,2) S:%]"" DE(2)=% S %=$P(%Z,U,3) S:%]"" DE(4)=% S %=$P(%Z,U,10) S:%]"" DE(7)=% + I $D(^("U2")) S %Z=^("U2") S %=$P(%Z,U,4) S:%]"" DE(12)=% S %=$P(%Z,U,5) S:%]"" DE(15)=% S %=$P(%Z,U,6) S:%]"" DE(18)=% K %Z Q ; W W !?DL+DL-2,DLB_": " @@ -49,46 +50,113 @@ SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$ NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") BEGIN S DNM="IBXSC78",DQ=1 -1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="U2;5",DV="NJ11,2",DU="",DLB="SECONDARY PRIOR PAYMENT",DIFLD=219 - S DE(DW)="C1^IBXSC78" +1 D:$D(DG)>9 F^DIE17,DE S DQ=1,D=0 K DE(1) ;42 + S DIFLD=42,DGO="^IBXSC79",DC="15^399.042IPA^RC^",DV="399.042MR*P399.2'",DW="0;1",DOW="REVENUE CODE",DLB="Select "_DOW S:D DC=DC_D + S DU="DGCR(399.2," + G RE:D I $D(DSC(399.042))#2,$P(DSC(399.042),"I $D(^UTILITY(",1)="" X DSC(399.042) S D=$O(^(0)) S:D="" D=-1 G M1 + S D=$S($D(^DGCR(399,DA,"RC",0)):$P(^(0),U,3,4),$O(^(0))'="":$O(^(0)),1:-1) +M1 I D>0 S DC=DC_D I $D(^DGCR(399,DA,"RC",+D,0)) S DE(1)=$P(^(0),U,1) G RE -C1 G C1S:$D(DE(1))[0 K DB - S X=DE(1),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU-X X ^DD(399,219,1,1,2.4) - S X=DE(1),DIC=DIE +R1 D DE + S D=$S($D(^DGCR(399,DA,"RC",0)):$P(^(0),U,3,4),1:1) G 1+1 ; -C1S S X="" G:DG(DQ)=X C1F1 K DB +2 S DW="U1;2",DV="NJ8,2",DU="",DLB="OFFSET AMOUNT",DIFLD=202 + S DE(DW)="C2^IBXSC78" + G RE +C2 G C2S:$D(DE(2))[0 K DB + S X=DE(2),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" X ^DD(399,202,1,1,2.4) +C2S S X="" G:DG(DQ)=X C2F1 K DB + S X=DG(DQ),DIC=DIE + ; +C2F1 Q +X2 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999)!(X<0) X + Q + ; +3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X3 S:'X Y="@757" + Q +4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW="U1;3",DV="FX",DU="",DLB="OFFSET DESCRIPTION",DIFLD=203 + G RE +X4 K:$L(X)>24!($L(X)<3) X + I $D(X),X'?.ANP K X + Q + ; +5 S DQ=6 ;@757 +6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X6 I $P(^DGCR(399,DA,"U1"),"^",11)']"" S Y="@76" + Q +7 S DW="U1;10",DV="RNJ10,2",DU="",DLB="*FY 1 CHARGES",DIFLD=210 + G RE +X7 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>9999999)!(X<0) X + Q + ; +8 S DQ=9 ;@76 +9 S DQ=10 ;@77 +10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X10 S:IBDR20'["77" Y="@78" + Q +11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X11 S:'$D(^DGCR(399,DA,"I1")) Y="@772" + Q +12 S DW="U2;4",DV="NJ11,2",DU="",DLB="PRIMARY PRIOR PAYMENT",DIFLD=218 + S DE(DW)="C12^IBXSC78" + G RE +C12 G C12S:$D(DE(12))[0 K DB + S X=DE(12),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU-X X ^DD(399,218,1,1,2.4) + S X=DE(12),DIC=DIE + ; +C12S S X="" G:DG(DQ)=X C12F1 K DB + S X=DG(DQ),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,218,1,1,1.4) + S X=DG(DQ),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X="PRIOR PAYMENT(S)" X ^DD(399,218,1,2,1.4) +C12F1 Q +X12 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999999)!(X<0) X + Q + ; +13 S DQ=14 ;@772 +14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X14 S:'$D(^DGCR(399,DA,"I2")) Y="@773" + Q +15 D:$D(DG)>9 F^DIE17,DE S DQ=15,DW="U2;5",DV="NJ11,2",DU="",DLB="SECONDARY PRIOR PAYMENT",DIFLD=219 + S DE(DW)="C15^IBXSC78" + G RE +C15 G C15S:$D(DE(15))[0 K DB + S X=DE(15),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU-X X ^DD(399,219,1,1,2.4) + S X=DE(15),DIC=DIE + ; +C15S S X="" G:DG(DQ)=X C15F1 K DB S X=DG(DQ),DIC=DIE K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,219,1,1,1.4) S X=DG(DQ),DIC=DIE K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X="PRIOR PAYMENT(S)" X ^DD(399,219,1,2,1.4) -C1F1 Q -X1 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999999)!(X<0) X +C15F1 Q +X15 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999999)!(X<0) X Q ; -2 S DQ=3 ;@773 -3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X3 S:'$D(^DGCR(399,DA,"I3")) Y="@78" +16 S DQ=17 ;@773 +17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X17 S:'$D(^DGCR(399,DA,"I3")) Y="@78" Q -4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW="U2;6",DV="NJ11,2",DU="",DLB="TERTIARY PRIOR PAYMENT",DIFLD=220 - S DE(DW)="C4^IBXSC78" +18 D:$D(DG)>9 F^DIE17,DE S DQ=18,DW="U2;6",DV="NJ11,2",DU="",DLB="TERTIARY PRIOR PAYMENT",DIFLD=220 + S DE(DW)="C18^IBXSC78" G RE -C4 G C4S:$D(DE(4))[0 K DB - S X=DE(4),DIC=DIE +C18 G C18S:$D(DE(18))[0 K DB + S X=DE(18),DIC=DIE K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU-X X ^DD(399,220,1,1,2.4) - S X=DE(4),DIC=DIE + S X=DE(18),DIC=DIE ; -C4S S X="" G:DG(DQ)=X C4F1 K DB - S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,220,1,1,1.4) - S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X="PRIOR PAYMENT(S)" X ^DD(399,220,1,2,1.4) -C4F1 Q -X4 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999999)!(X<0) X +C18S S X="" G:DG(DQ)=X C18F1 K DB + D ^IBXSC710 +C18F1 Q +X18 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999999)!(X<0) X Q ; -5 S DQ=6 ;@78 -6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X6 K DIE("NO^") +19 S DQ=20 ;@78 +20 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=20 D X20 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X20 K DIE("NO^") Q -7 G 0^DIE17 +21 G 0^DIE17 diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC79.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC79.m index 44feeb25..9156b821 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC79.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC79.m @@ -1,4 +1,4 @@ -IBXSC79 ; ;12/13/08 +IBXSC79 ; ;12/27/07 D DE G BEGIN DE S DIE="^DGCR(399,D0,""RC"",",DIC=DIE,DP=399.042,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"RC",DA,""))="" I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% S %=$P(%Z,U,2) S:%]"" DE(2)=% S %=$P(%Z,U,3) S:%]"" DE(3)=% S %=$P(%Z,U,4) S:%]"" DE(4)=% S %=$P(%Z,U,5) S:%]"" DE(5)=% S %=$P(%Z,U,6) S:%]"" DE(6)=% S %=$P(%Z,U,7) S:%]"" DE(8)=% diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX.m index 39ca5573..514bc3cd 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX.m @@ -1,4 +1,4 @@ -IBXX ; DRIVER FOR COMPILED XREFS FOR FILE #399 ; 01/03/09 +IBXX ; DRIVER FOR COMPILED XREFS FOR FILE #399 ; 12/27/07 ; N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2 I '$D(DIKSAT) S DIKLK=DIK_DA_")" L +@DIKLK:10 K:'$T DIKLK @@ -6,9 +6,9 @@ IBXX ; DRIVER FOR COMPILED XREFS FOR FILE #399 ; 01/03/09 G Q DI S DIKM1=0,DIKUM=0,DA(0)="",DV=0 F S DV=$O(DA(DV)) Q:DV'>0 S DIKUM=DIKUM+1,DIKUP(DV)=DA(DV) S:DV="" DV=-1 S DH(1)=399,DIKUP=DA - I $D(DIKKS) D:DIKZ1=DH(1) ^IBXX1 S DA=DIKUP D:DIKZ1=DH(1) ^IBXX15 D:DIKZ1'=DH(1) KILL D:DIKZ1'=DH(1) DA D:DIKZ1'=DH(1) SET D DA Q + I $D(DIKKS) D:DIKZ1=DH(1) ^IBXX1 S DA=DIKUP D:DIKZ1=DH(1) ^IBXX14 D:DIKZ1'=DH(1) KILL D:DIKZ1'=DH(1) DA D:DIKZ1'=DH(1) SET D DA Q I $D(DIKIL) D:DIKZ1=DH(1) ^IBXX1 S:DIKZ1=DH(1) DIKM1=1 D:DIKZ1'=DH(1) KILL S DA=DIKUP D:DIKM1>0 KIL1 D DA Q - I $D(DIKST) D:DIKZ1=DH(1) ^IBXX15 D:DIKZ1'=DH(1) SET D DA Q + I $D(DIKST) D:DIKZ1=DH(1) ^IBXX14 D:DIKZ1'=DH(1) SET D DA Q I $D(DIKSAT) D SET1 D DA Q Q DA K DA F DV=1:1 Q:'$D(DIKUP(DV)) S DA(DV)=DIKUP(DV) @@ -16,14 +16,14 @@ DA K DA F DV=1:1 Q:'$D(DIKUP(DV)) S DA(DV)=DIKUP(DV) SET1 S (DA,DCNT)=0 S DU=$E(DIK,1,$L(DIK)-1),DIKLK=$S(DIK[",":DU_")",1:DU) L +@DIKLK:10 K:'$T DIKLK C I @("$O("_DIK_"DA))'>0") S DA=$$C1(DA),^(0)=$P(@(DIK_"0)"),U,1,2)_U_DA_U_DCNT K DCNT L:$D(DIKLK) -@DIKLK Q - S (DIKY,DA)=$O(^(DA)) G C:$P($G(^(DA,0)),U)']"" S DU=1,DCNT=DCNT+1 S:DA="" (DIKY,DA)=-1 D:DIKZ1=DH(1) ^IBXX15 D:DIKZ1'=DH(1) SET D:DIKZ1'=DH(1) DA K DB(0) S DA=DIKY G C + S (DIKY,DA)=$O(^(DA)) G C:$P($G(^(DA,0)),U)']"" S DU=1,DCNT=DCNT+1 S:DA="" (DIKY,DA)=-1 D:DIKZ1=DH(1) ^IBXX14 D:DIKZ1'=DH(1) SET D:DIKZ1'=DH(1) DA K DB(0) S DA=DIKY G C Q C1(A) Q:$P($G(@(DIK_"A,0)")),U)]"" A F S @("A=+$O("_DIK_"A),-1)") Q:$P($G(@(DIK_"A,0)")),U)]""!(A'>0) Q A KILL S DIKILL=1,DIKZK=2 I DIKZ1=399.0222,DIKUM'<1 S DIKM1=1 D A1^IBXX3 Q - I DIKZ1=399.0304,DIKUM'<1 S DIKM1=1 D A1^IBXX4,A1^IBXX14 Q + I DIKZ1=399.0304,DIKUM'<1 S DIKM1=1 D A1^IBXX4,A1^IBXX13 Q I DIKZ1=399.041,DIKUM'<1 S DIKM1=1 D A1^IBXX5 Q I DIKZ1=399.042,DIKUM'<1 S DIKM1=1 D A1^IBXX6 Q I DIKZ1=399.043,DIKUM'<1 S DIKM1=1 D A1^IBXX7 Q @@ -32,12 +32,11 @@ KILL S DIKILL=1,DIKZK=2 I DIKZ1=399.046,DIKUM'<1 S DIKM1=1 D A1^IBXX10 Q I DIKZ1=399.047,DIKUM'<1 S DIKM1=1 D A1^IBXX11 Q I DIKZ1=399.048,DIKUM'<1 S DIKM1=1 D A1^IBXX12 Q - I DIKZ1=399.077,DIKUM'<1 S DIKM1=1 D A1^IBXX13 Q - I DIKZ1=399.30416,DIKUM'<2 S DIKM1=2 D A1^IBXX14 Q + I DIKZ1=399.30416,DIKUM'<2 S DIKM1=2 D A1^IBXX13 Q Q SET S DISET=1,DIKZK=1 K DIKPUSH I DIKZ1=399.0222,DIKUM'<1 S DIKM1=1 D A1^IBXX18 Q - I DIKZ1=399.0304,DIKUM'<1 S DIKM1=1 D A1^IBXX19,A1^IBXX29 Q + I DIKZ1=399.0304,DIKUM'<1 S DIKM1=1 D A1^IBXX19,A1^IBXX28 Q I DIKZ1=399.041,DIKUM'<1 S DIKM1=1 D A1^IBXX20 Q I DIKZ1=399.042,DIKUM'<1 S DIKM1=1 D A1^IBXX21 Q I DIKZ1=399.043,DIKUM'<1 S DIKM1=1 D A1^IBXX22 Q @@ -46,8 +45,7 @@ SET S DISET=1,DIKZK=1 K DIKPUSH I DIKZ1=399.046,DIKUM'<1 S DIKM1=1 D A1^IBXX25 Q I DIKZ1=399.047,DIKUM'<1 S DIKM1=1 D A1^IBXX26 Q I DIKZ1=399.048,DIKUM'<1 S DIKM1=1 D A1^IBXX27 Q - I DIKZ1=399.077,DIKUM'<1 S DIKM1=1 D A1^IBXX28 Q - I DIKZ1=399.30416,DIKUM'<2 S DIKM1=2 D A1^IBXX29 Q + I DIKZ1=399.30416,DIKUM'<2 S DIKM1=2 D A1^IBXX28 Q Q KIL1 K @(DIK_"DA)") Q:'$D(^(0)) S Y=^(0),DH=$S($O(^(0))'>0:0,1:$P(Y,U,4)-1),X=$P($P(Y,U,3),U,DH>0) D 3:X=DA diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX1.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX1.m index af3719c3..bdff7c25 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX1.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX1.m @@ -1,4 +1,4 @@ -IBXX1 ; COMPILED XREF FOR FILE #399 ; 01/03/09 +IBXX1 ; COMPILED XREF FOR FILE #399 ; 12/27/07 ; S DIKZK=2 S DIKZ(0)=$G(^DGCR(399,DA,0)) @@ -170,50 +170,4 @@ IBXX1 ; COMPILED XREF FOR FILE #399 ; 01/03/09 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" X ^DD(399,202,1,1,2.4) S DIKZ("U2")=$G(^DGCR(399,DA,"U2")) S X=$P(DIKZ("U2"),U,4) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU-X X ^DD(399,218,1,1,2.4) - S DIKZ("U2")=$G(^DGCR(399,DA,"U2")) - S X=$P(DIKZ("U2"),U,5) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU-X X ^DD(399,219,1,1,2.4) - S DIKZ("U2")=$G(^DGCR(399,DA,"U2")) - S X=$P(DIKZ("U2"),U,6) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU-X X ^DD(399,220,1,1,2.4) - S DIKZ("U2")=$G(^DGCR(399,DA,"U2")) - S X=$P(DIKZ("U2"),U,10) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X="" X ^DD(399,232,1,1,2.4) - S X=$P(DIKZ("U2"),U,10) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X="" X ^DD(399,232,1,2,2.4) - S X=$P(DIKZ("U2"),U,10) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$CLIAREQ^IBCEP8A(DA) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$CLIA^IBCEP8A(DA) X ^DD(399,232,1,3,2.4) - S X=$P(DIKZ("U2"),U,10) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U3")):^("U3"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" S DIH=$G(^DGCR(399,DIV(0),"U3")),DIV=X S $P(^("U3"),U,3)=DIV,DIH=399,DIG=244 D ^DICR - S DIKZ("M1")=$G(^DGCR(399,DA,"M1")) - S X=$P(DIKZ("M1"),U,8) - I X'="" K ^DGCR(399,"AG",$E(X,1,30),DA) - S DIKZ(0)=$G(^DGCR(399,DA,0)) - S X=$P(DIKZ(0),U,1) - I X'="" K ^DGCR(399,"B",$E(X,1,30),DA) -CR1 S DIXR=139 - K X - S DIKZ("M")=$G(^DGCR(399,DA,"M")) - S X(1)=$P(DIKZ("M"),U,1) - S X(2)=$P(DIKZ("M"),U,2) - S X(3)=$P(DIKZ("M"),U,3) - S X(4)=$P(DIKZ("M"),U,13) - S X(5)=$P(DIKZ("M"),U,12) - S X(6)=$P(DIKZ("M"),U,14) - S X=$G(X(1)) END G ^IBXX2 diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX10.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX10.m index 38813fe6..de9201ff 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX10.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX10.m @@ -1,4 +1,4 @@ -IBXX10 ; COMPILED XREF FOR FILE #399.046 ; 01/03/09 +IBXX10 ; COMPILED XREF FOR FILE #399.046 ; 12/27/07 ; S DA=0 A1 ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX11.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX11.m index 9bfb8ab8..90a8a267 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX11.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX11.m @@ -1,4 +1,4 @@ -IBXX11 ; COMPILED XREF FOR FILE #399.047 ; 01/03/09 +IBXX11 ; COMPILED XREF FOR FILE #399.047 ; 12/27/07 ; S DA=0 A1 ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX12.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX12.m index e48e03b1..c2105850 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX12.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX12.m @@ -1,4 +1,4 @@ -IBXX12 ; COMPILED XREF FOR FILE #399.048 ; 01/03/09 +IBXX12 ; COMPILED XREF FOR FILE #399.048 ; 12/27/07 ; S DA=0 A1 ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX13.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX13.m index 140fd092..b3ca3f55 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX13.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX13.m @@ -1,13 +1,16 @@ -IBXX13 ; COMPILED XREF FOR FILE #399.077 ; 01/03/09 +IBXX13 ; COMPILED XREF FOR FILE #399.30416 ; 12/27/07 ; - S DA=0 + S DA(2)=DA(1) S DA(1)=0 S DA=0 A1 ; - I $D(DIKILL) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1 -0 ; -A S DA=$O(^DGCR(399,DA(1),"TXC",DA)) I DA'>0 S DA=0 G END + I $D(DIKILL) K DIKLM S:DIKM1=2 DIKLM=1 S:DIKM1'=2&'$G(DIKPUSH(2)) DIKPUSH(2)=1,DA(2)=DA(1),DA(1)=DA,DA=0 G @DIKM1 +A S DA(1)=$O(^DGCR(399,DA(2),"CP",DA(1))) I DA(1)'>0 S DA(1)=0 G END 1 ; - S DIKZ(0)=$G(^DGCR(399,DA(1),"TXC",DA,0)) +B S DA=$O(^DGCR(399,DA(2),"CP",DA(1),"MOD",DA)) I DA'>0 S DA=0 Q:DIKM1=1 G A +2 ; + S DIKZ(0)=$G(^DGCR(399,DA(2),"CP",DA(1),"MOD",DA,0)) + S X=$P(DIKZ(0),U,2) + I X'="" K ^DGCR(399,DA(2),"CP",DA(1),"MOD","C",$E(X,1,30),DA) S X=$P(DIKZ(0),U,1) - I X'="" K ^DGCR(399,DA(1),"TXC","B",$E(X,1,30),DA) - G:'$D(DIKLM) A Q:$D(DIKILL) -END G ^IBXX14 + I X'="" K ^DGCR(399,DA(2),"CP",DA(1),"MOD","B",$E(X,1,30),DA) + G:'$D(DIKLM) B Q:$D(DIKILL) +END Q diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX14.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX14.m index 1dd8db63..e04314d6 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX14.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX14.m @@ -1,16 +1,157 @@ -IBXX14 ; COMPILED XREF FOR FILE #399.30416 ; 01/03/09 +IBXX14 ; COMPILED XREF FOR FILE #399 ; 12/27/07 ; - S DA(2)=DA(1) S DA(1)=0 S DA=0 -A1 ; - I $D(DIKILL) K DIKLM S:DIKM1=2 DIKLM=1 S:DIKM1'=2&'$G(DIKPUSH(2)) DIKPUSH(2)=1,DA(2)=DA(1),DA(1)=DA,DA=0 G @DIKM1 -A S DA(1)=$O(^DGCR(399,DA(2),"CP",DA(1))) I DA(1)'>0 S DA(1)=0 G END -1 ; -B S DA=$O(^DGCR(399,DA(2),"CP",DA(1),"MOD",DA)) I DA'>0 S DA=0 Q:DIKM1=1 G A -2 ; - S DIKZ(0)=$G(^DGCR(399,DA(2),"CP",DA(1),"MOD",DA,0)) - S X=$P(DIKZ(0),U,2) - I X'="" K ^DGCR(399,DA(2),"CP",DA(1),"MOD","C",$E(X,1,30),DA) + S DIKZK=1 + S DIKZ(0)=$G(^DGCR(399,DA,0)) S X=$P(DIKZ(0),U,1) - I X'="" K ^DGCR(399,DA(2),"CP",DA(1),"MOD","B",$E(X,1,30),DA) - G:'$D(DIKLM) B Q:$D(DIKILL) -END Q + I X'="" S ^DGCR(399,"B",$E(X,1,30),DA)="" + S X=$P(DIKZ(0),U,1) + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,1)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,.01,1,3,1.4) + S X=$P(DIKZ(0),U,1) + I X'="" D + .N DIK,DIV,DIU,DIN + .X ^DD(399,.01,1,4,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$S(($D(DUZ)#2):DUZ,1:"") X ^DD(399,.01,1,4,1.4) + S X=$P(DIKZ(0),U,1) + I X'="" D + .N DIK,DIV,DIU,DIN + .X ^DD(399,.01,1,5,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,14),X=X S DIU=X K Y S X=DIV S X=$S($D(^IBE(350.9,1,1)):$P(^(1),U,6),1:"") X ^DD(399,.01,1,5,1.4) + S X=$P(DIKZ(0),U,1) + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=1 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,13)=DIV,DIH=399,DIG=.13 D ^DICR + S X=$P(DIKZ(0),U,1) + I X'="" D + .N DIK,DIV,DIU,DIN + .X ^DD(399,.01,1,7,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,19),X=X S DIU=X K Y S X=DIV S X=3 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,19)=DIV,DIH=399,DIG=.19 D ^DICR + S DIKZ(0)=$G(^DGCR(399,DA,0)) + S X=$P(DIKZ(0),U,2) + I X'="" S ^DGCR(399,"C",$E(X,1,30),DA)="" + S X=$P(DIKZ(0),U,3) + I X'="" S ^DGCR(399,"D",$E(X,1,30),DA)="" + S X=$P(DIKZ(0),U,3) + I X'="" S IBN=$P(^DGCR(399,DA,0),"^",2) S:$D(IBN) ^DGCR(399,"APDT",IBN,DA,9999999-X)="" K IBN + S X=$P(DIKZ(0),U,3) + I X'="" S ^DGCR(399,"ABNDT",DA,9999999-X)="" + S X=$P(DIKZ(0),U,4) + I X'="" D + .N DIK,DIV,DIU,DIN + .X ^DD(399,.04,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,24),X=X S DIU=X K Y S X=DIV S X=DIV,X=X S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,24)=DIV,DIH=399,DIG=.24 D ^DICR + S DIKZ(0)=$G(^DGCR(399,DA,0)) + S X=$P(DIKZ(0),U,5) + I X'="" S ^DGCR(399,"ABT",$E(X,1,30),DA)="" + S X=$P(DIKZ(0),U,5) + I X'="" D + .N DIK,DIV,DIU,DIN + .X ^DD(399,.05,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,25),X=X S DIU=X K Y S X=DIV S X=$$TRIG05^IBCU4(X,D0) S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,25)=DIV,DIH=399,DIG=.25 D ^DICR + S DIKZ(0)=$G(^DGCR(399,DA,0)) + S X=$P(DIKZ(0),U,6) + I X'="" D + .N DIK,DIV,DIU,DIN + .X ^DD(399,.06,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,26),X=X S DIU=X K Y S X=DIV S X=DIV,X=X S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,26)=DIV,DIH=399,DIG=.26 D ^DICR + S DIKZ(0)=$G(^DGCR(399,DA,0)) + S X=$P(DIKZ(0),U,7) + I X'="" D + .N DIK,DIV,DIU,DIN + .X ^DD(399,.07,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X=DIV S X=1 X ^DD(399,.07,1,1,1.4) + S X=$P(DIKZ(0),U,7) + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X=DIV S X=$P(^DGCR(399.3,$P(^DGCR(399,DA,0),U,7),0),U,7) X ^DD(399,.07,1,2,1.4) + S X=$P(DIKZ(0),U,7) + I X'="" S ^DGCR(399,"AD",$E(X,1,30),DA)="" + S DIKZ(0)=$G(^DGCR(399,DA,0)) + S X=$P(DIKZ(0),U,8) + I X'="" D + .N DIK,DIV,DIU,DIN + .X ^DD(399,.08,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,9),X=X S DIU=X K Y S X=DIV S X=2 X ^DD(399,.08,1,1,1.4) + S X=$P(DIKZ(0),U,8) + I X'="" D + .N DIK,DIV,DIU,DIN + .X ^DD(399,.08,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X=DIV S X=2 X ^DD(399,.08,1,2,1.4) + S X=$P(DIKZ(0),U,8) + I X'="" D + .N DIK,DIV,DIU,DIN + .X ^DD(399,.08,1,4,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV D DIS^IBCU S X=X X ^DD(399,.08,1,4,1.4) + S X=$P(DIKZ(0),U,8) + I X'="" S ^DGCR(399,"APTF",$E(X,1,30),DA)="" + S X=$P(DIKZ(0),U,8) + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=+$$LOS1^IBCU64(DA) X ^DD(399,.08,1,6,1.4) + S DIKZ(0)=$G(^DGCR(399,DA,0)) + S X=$P(DIKZ(0),U,11) + I X'="" D + .N DIK,DIV,DIU,DIN + .X ^DD(399,.11,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"M")):^("M"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV D EN1^IBCU5 X ^DD(399,.11,1,1,1.4) + S X=$P(DIKZ(0),U,11) + I X'="" D EN^IBCU5 + S X=$P(DIKZ(0),U,11) + I X'="" S DGRVRCAL=1 + S X=$P(DIKZ(0),U,11) + I X'="" D + .N DIK,DIV,DIU,DIN + .X ^DD(399,.11,1,4,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,21),X=X S DIU=X K Y X ^DD(399,.11,1,4,1.1) X ^DD(399,.11,1,4,1.4) + S DIKZ(0)=$G(^DGCR(399,DA,0)) + S X=$P(DIKZ(0),U,13) + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,14),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,.13,1,1,1.4) + S X=$P(DIKZ(0),U,13) + I X'="" I X>0,X<3,$P(^DGCR(399,DA,0),U,2) S ^DGCR(399,"AOP",$P(^(0),U,2),DA)="" + S X=$P(DIKZ(0),U,13) + I X'="" I +X=3 S ^DGCR(399,"AST",+X,DA)="" + S X=$P(DIKZ(0),U,13) + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=Y(0),X=X S X=X=2 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X=DIV S X="1N" X ^DD(399,.13,1,4,1.4) + S DIKZ(0)=$G(^DGCR(399,DA,0)) + S X=$P(DIKZ(0),U,14) + I X'="" D BC^IBJVDEQ + S X=$P(DIKZ(0),U,17) + I X'="" S ^DGCR(399,"AC",$E(X,1,30),DA)="" + S X=$P(DIKZ(0),U,19) + I X'="" D + .N DIK,DIV,DIU,DIN + .X ^DD(399,.19,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,9),X=X S DIU=X K Y S X=DIV S X=5 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,9)=DIV,DIH=399,DIG=.09 D ^DICR + S X=$P(DIKZ(0),U,19) + I X'="" S DGRVRCAL=1 + S X=$P(DIKZ(0),U,19) + I X'="" D ALLID^IBCEP3(DA,.19,1) + S X=$P(DIKZ(0),U,19) + I X'="" D BILLPNS^IBCU(DA) + S X=$P(DIKZ(0),U,19) + I X'="" D ATTREND^IBCU1(DA,"","") + S DIKZ(0)=$G(^DGCR(399,DA,0)) + S X=$P(DIKZ(0),U,20) + I X'="" D + .N DIK,DIV,DIU,DIN + .X ^DD(399,.2,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=.5 X ^DD(399,.2,1,1,1.4) + S DIKZ(0)=$G(^DGCR(399,DA,0)) + S X=$P(DIKZ(0),U,21) + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$BPP^IBCNS2(DA) X ^DD(399,.21,1,1,1.4) + S X=$P(DIKZ(0),U,21) + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=('$$REQMRA^IBEFUNC(DA)&$$NEEDMRA^IBEFUNC(DA)) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X=DIV S X=0 X ^DD(399,.21,1,2,1.4) + S X=$P(DIKZ(0),U,21) + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$S($$WNRBILL^IBEFUNC(DA,X):1,1:0) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X="" X ^DD(399,.21,1,3,1.4) + S DIKZ(0)=$G(^DGCR(399,DA,0)) + S X=$P(DIKZ(0),U,22) + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,"",1) X ^DD(399,.22,1,1,1.4) + S X=$P(DIKZ(0),U,22) + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,"",2) X ^DD(399,.22,1,2,1.4) + S X=$P(DIKZ(0),U,22) + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,"",3) X ^DD(399,.22,1,3,1.4) + S X=$P(DIKZ(0),U,22) +END G ^IBXX15 diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX15.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX15.m index 1faff87a..aea85445 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX15.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX15.m @@ -1,159 +1,5 @@ -IBXX15 ; COMPILED XREF FOR FILE #399 ; 01/03/09 +IBXX15 ; COMPILED XREF FOR FILE #399.0222 ; 12/27/07 ; - S DIKZK=1 - S DIKZ(0)=$G(^DGCR(399,DA,0)) - S X=$P(DIKZ(0),U,1) - I X'="" S ^DGCR(399,"B",$E(X,1,30),DA)="" - S X=$P(DIKZ(0),U,1) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,1)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,.01,1,3,1.4) - S X=$P(DIKZ(0),U,1) - I X'="" D - .N DIK,DIV,DIU,DIN - .X ^DD(399,.01,1,4,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$S(($D(DUZ)#2):DUZ,1:"") X ^DD(399,.01,1,4,1.4) - S X=$P(DIKZ(0),U,1) - I X'="" D - .N DIK,DIV,DIU,DIN - .X ^DD(399,.01,1,5,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,14),X=X S DIU=X K Y S X=DIV S X=$S($D(^IBE(350.9,1,1)):$P(^(1),U,6),1:"") X ^DD(399,.01,1,5,1.4) - S X=$P(DIKZ(0),U,1) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=1 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,13)=DIV,DIH=399,DIG=.13 D ^DICR - S X=$P(DIKZ(0),U,1) - I X'="" D - .N DIK,DIV,DIU,DIN - .X ^DD(399,.01,1,7,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,19),X=X S DIU=X K Y S X=DIV S X=3 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,19)=DIV,DIH=399,DIG=.19 D ^DICR - S DIKZ(0)=$G(^DGCR(399,DA,0)) - S X=$P(DIKZ(0),U,2) - I X'="" S ^DGCR(399,"C",$E(X,1,30),DA)="" - S X=$P(DIKZ(0),U,3) - I X'="" S ^DGCR(399,"D",$E(X,1,30),DA)="" - S X=$P(DIKZ(0),U,3) - I X'="" S IBN=$P(^DGCR(399,DA,0),"^",2) S:$D(IBN) ^DGCR(399,"APDT",IBN,DA,9999999-X)="" K IBN - S X=$P(DIKZ(0),U,3) - I X'="" S ^DGCR(399,"ABNDT",DA,9999999-X)="" - S X=$P(DIKZ(0),U,4) - I X'="" D - .N DIK,DIV,DIU,DIN - .X ^DD(399,.04,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,24),X=X S DIU=X K Y S X=DIV S X=DIV,X=X S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,24)=DIV,DIH=399,DIG=.24 D ^DICR - S DIKZ(0)=$G(^DGCR(399,DA,0)) - S X=$P(DIKZ(0),U,5) - I X'="" S ^DGCR(399,"ABT",$E(X,1,30),DA)="" - S X=$P(DIKZ(0),U,5) - I X'="" D - .N DIK,DIV,DIU,DIN - .X ^DD(399,.05,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,25),X=X S DIU=X K Y S X=DIV S X=$$TRIG05^IBCU4(X,D0) S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,25)=DIV,DIH=399,DIG=.25 D ^DICR - S DIKZ(0)=$G(^DGCR(399,DA,0)) - S X=$P(DIKZ(0),U,6) - I X'="" D - .N DIK,DIV,DIU,DIN - .X ^DD(399,.06,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,26),X=X S DIU=X K Y S X=DIV S X=DIV,X=X S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,26)=DIV,DIH=399,DIG=.26 D ^DICR - S DIKZ(0)=$G(^DGCR(399,DA,0)) - S X=$P(DIKZ(0),U,7) - I X'="" D - .N DIK,DIV,DIU,DIN - .X ^DD(399,.07,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X=DIV S X=1 X ^DD(399,.07,1,1,1.4) - S X=$P(DIKZ(0),U,7) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X=DIV S X=$P(^DGCR(399.3,$P(^DGCR(399,DA,0),U,7),0),U,7) X ^DD(399,.07,1,2,1.4) - S X=$P(DIKZ(0),U,7) - I X'="" S ^DGCR(399,"AD",$E(X,1,30),DA)="" - S DIKZ(0)=$G(^DGCR(399,DA,0)) - S X=$P(DIKZ(0),U,8) - I X'="" D - .N DIK,DIV,DIU,DIN - .X ^DD(399,.08,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,9),X=X S DIU=X K Y S X=DIV S X=2 X ^DD(399,.08,1,1,1.4) - S X=$P(DIKZ(0),U,8) - I X'="" D - .N DIK,DIV,DIU,DIN - .X ^DD(399,.08,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X=DIV S X=2 X ^DD(399,.08,1,2,1.4) - S X=$P(DIKZ(0),U,8) - I X'="" D - .N DIK,DIV,DIU,DIN - .X ^DD(399,.08,1,4,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV D DIS^IBCU S X=X X ^DD(399,.08,1,4,1.4) - S X=$P(DIKZ(0),U,8) - I X'="" S ^DGCR(399,"APTF",$E(X,1,30),DA)="" - S X=$P(DIKZ(0),U,8) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=+$$LOS1^IBCU64(DA) X ^DD(399,.08,1,6,1.4) - S DIKZ(0)=$G(^DGCR(399,DA,0)) - S X=$P(DIKZ(0),U,11) - I X'="" D - .N DIK,DIV,DIU,DIN - .X ^DD(399,.11,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"M")):^("M"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV D EN1^IBCU5 X ^DD(399,.11,1,1,1.4) - S X=$P(DIKZ(0),U,11) - I X'="" D EN^IBCU5 - S X=$P(DIKZ(0),U,11) - I X'="" S DGRVRCAL=1 - S X=$P(DIKZ(0),U,11) - I X'="" D - .N DIK,DIV,DIU,DIN - .X ^DD(399,.11,1,4,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,21),X=X S DIU=X K Y X ^DD(399,.11,1,4,1.1) X ^DD(399,.11,1,4,1.4) - S DIKZ(0)=$G(^DGCR(399,DA,0)) - S X=$P(DIKZ(0),U,13) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,14),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,.13,1,1,1.4) - S X=$P(DIKZ(0),U,13) - I X'="" I X>0,X<3,$P(^DGCR(399,DA,0),U,2) S ^DGCR(399,"AOP",$P(^(0),U,2),DA)="" - S X=$P(DIKZ(0),U,13) - I X'="" I +X=3 S ^DGCR(399,"AST",+X,DA)="" - S X=$P(DIKZ(0),U,13) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=Y(0),X=X S X=X=2 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X=DIV S X="1N" X ^DD(399,.13,1,4,1.4) - S DIKZ(0)=$G(^DGCR(399,DA,0)) - S X=$P(DIKZ(0),U,14) - I X'="" D BC^IBJVDEQ - S X=$P(DIKZ(0),U,17) - I X'="" S ^DGCR(399,"AC",$E(X,1,30),DA)="" - S X=$P(DIKZ(0),U,19) - I X'="" D - .N DIK,DIV,DIU,DIN - .X ^DD(399,.19,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,9),X=X S DIU=X K Y S X=DIV S X=5 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,9)=DIV,DIH=399,DIG=.09 D ^DICR - S X=$P(DIKZ(0),U,19) - I X'="" S DGRVRCAL=1 - S X=$P(DIKZ(0),U,19) - I X'="" D ALLID^IBCEP3(DA,.19,1) - S X=$P(DIKZ(0),U,19) - I X'="" D BILLPNS^IBCU(DA) - S X=$P(DIKZ(0),U,19) - I X'="" D ATTREND^IBCU1(DA,"","") - S DIKZ(0)=$G(^DGCR(399,DA,0)) - S X=$P(DIKZ(0),U,20) - I X'="" D - .N DIK,DIV,DIU,DIN - .X ^DD(399,.2,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=.5 X ^DD(399,.2,1,1,1.4) - S DIKZ(0)=$G(^DGCR(399,DA,0)) - S X=$P(DIKZ(0),U,21) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$BPP^IBCNS2(DA) X ^DD(399,.21,1,1,1.4) - S X=$P(DIKZ(0),U,21) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=('$$REQMRA^IBEFUNC(DA)&$$NEEDMRA^IBEFUNC(DA)) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X=DIV S X=0 X ^DD(399,.21,1,2,1.4) - S X=$P(DIKZ(0),U,21) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$S($$WNRBILL^IBEFUNC(DA,X):1,1:0) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X="" X ^DD(399,.21,1,3,1.4) - S DIKZ(0)=$G(^DGCR(399,DA,0)) - S X=$P(DIKZ(0),U,22) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,"",1) X ^DD(399,.22,1,1,1.4) - S X=$P(DIKZ(0),U,22) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,"",2) X ^DD(399,.22,1,2,1.4) - S X=$P(DIKZ(0),U,22) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,"",3) X ^DD(399,.22,1,3,1.4) - S X=$P(DIKZ(0),U,22) I X'="" D .N DIK,DIV,DIU,DIN .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X=DIV S X=$$PRVQUAL^IBCU(DA,"",1) X ^DD(399,.22,1,4,1.4) @@ -189,4 +35,101 @@ IBXX15 ; COMPILED XREF FOR FILE #399 ; 01/03/09 S X=$P(DIKZ("S"),U,1) I X'="" S ^DGCR(399,"APD",$E(X,1,30),DA)="" S X=$P(DIKZ("S"),U,3) + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,4)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,3,1,1,1.4) + S X=$P(DIKZ("S"),U,3) + I X'="" D + .N DIK,DIV,DIU,DIN + .X ^DD(399,3,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X=DIV S X=DUZ X ^DD(399,3,1,2,1.4) + S DIKZ("S")=$G(^DGCR(399,DA,"S")) + S X=$P(DIKZ("S"),U,7) + I X'="" S ^DGCR(399,"APM",$E(X,1,30),DA)="" + S X=$P(DIKZ("S"),U,9) + I X'="" D + .N DIK,DIV,DIU,DIN + .X ^DD(399,9,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,9,1,1,1.4) + S X=$P(DIKZ("S"),U,9) + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(399,9,1,2,69.2) S X=X="YES",Y=X,X=Y(2),X=X&Y I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X=DIV S X=DUZ X ^DD(399,9,1,2,1.4) + S X=$P(DIKZ("S"),U,9) + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y=Y(0) X:$D(^DD(399,9,2)) ^(2) S X=Y="YES" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=3 X ^DD(399,9,1,3,1.4) + S X=$P(DIKZ("S"),U,9) + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$EXTERNAL^DIDU(399,9,"",Y(0))="YES" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X="" X ^DD(399,9,1,4,1.4) + S DIKZ("S")=$G(^DGCR(399,DA,"S")) + S X=$P(DIKZ("S"),U,10) + I X'="" S ^DGCR(399,"APD3",$E(X,1,30),DA)="" + S X=$P(DIKZ("S"),U,12) + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,14)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,14),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,12,1,1,1.4) + S X=$P(DIKZ("S"),U,12) + I X'="" D + .N DIK,DIV,DIU,DIN + .X ^DD(399,12,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=DUZ S DIH=$G(^DGCR(399,DIV(0),"S")),DIV=X S $P(^("S"),U,15)=DIV,DIH=399,DIG=15 D ^DICR + S X=$P(DIKZ("S"),U,12) + I X'="" D + .N DIK,DIV,DIU,DIN + .X ^DD(399,12,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=DUZ S DIH=$G(^DGCR(399,DIV(0),"S")),DIV=X S $P(^("S"),U,13)=DIV,DIH=399,DIG=13 D ^DICR + S X=$P(DIKZ("S"),U,12) + I X'="" S ^DGCR(399,"AP",$E(X,1,30),DA)="" + S DIKZ("S")=$G(^DGCR(399,DA,"S")) + S X=$P(DIKZ("S"),U,14) + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=4 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,13)=DIV,DIH=399,DIG=.13 D ^DICR + S X=$P(DIKZ("S"),U,14) + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=DUZ S DIH=$G(^DGCR(399,DIV(0),"S")),DIV=X S $P(^("S"),U,15)=DIV,DIH=399,DIG=15 D ^DICR + S DIKZ("S")=$G(^DGCR(399,DA,"S")) + S X=$P(DIKZ("S"),U,16) + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$EXTERNAL^DIDU(399,16,"",Y(0))="YES" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,17),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,16,1,1,1.4) + S X=$P(DIKZ("S"),U,16) + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$EXTERNAL^DIDU(399,16,"",Y(0))="YES" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,18),X=X S DIU=X K Y S X=DIV S X=DUZ X ^DD(399,16,1,2,1.4) + S DIKZ("S")=$G(^DGCR(399,DA,"S")) + S X=$P(DIKZ("S"),U,17) + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,16),X=X S X=X=1 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=7 X ^DD(399,17,1,1,1.4) + S DIKZ("TX")=$G(^DGCR(399,DA,"TX")) + S X=$P(DIKZ("TX"),U,2) + I X'="" S ^DGCR(399,"ALEX",$E(X,1,30),DA)="" + S X=$P(DIKZ("TX"),U,5) + I X'="" D + .N DIK,DIV,DIU,DIN + .X ^DD(399,24,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,24,1,1,1.4) + S DIKZ("TX")=$G(^DGCR(399,DA,"TX")) + S X=$P(DIKZ("TX"),U,6) + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=Y(0),X=X S X=X=1 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=2 X ^DD(399,25,1,1,1.4) + S X=$P(DIKZ("TX"),U,6) + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(399,25,1,2,69.2) S X=X S X=X="",Y=X,X=Y(2),X=X&Y I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X=DIV S X=DUZ X ^DD(399,25,1,2,1.4) + S X=$P(DIKZ("TX"),U,6) + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(399,25,1,3,69.2) S X=X S X=X="",Y=X,X=Y(2),X=X&Y I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,7),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,25,1,3,1.4) + S DIKZ("C")=$G(^DGCR(399,DA,"C")) + S X=$P(DIKZ("C"),U,14) + I X'="" D + .N DIK,DIV,DIU,DIN + .X ^DD(399,64,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"C")):^("C"),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X=DIV S X=$P(^ICD9(+X,0),"^",3) X ^DD(399,64,1,1,1.4) + S DIKZ("M")=$G(^DGCR(399,DA,"M")) + S X=$P(DIKZ("M"),U,1) + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,X,1) X ^DD(399,101,1,1,1.4) + S X=$P(DIKZ("M"),U,1) END G ^IBXX16 diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX16.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX16.m index c35a14e3..729746f7 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX16.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX16.m @@ -1,102 +1,5 @@ -IBXX16 ; COMPILED XREF FOR FILE #399.0222 ; 01/03/09 +IBXX16 ; COMPILED XREF FOR FILE #399.0222 ; 12/27/07 ; -END G ^IBXX16 - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,4)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,3,1,1,1.4) - S X=$P(DIKZ("S"),U,3) - I X'="" D - .N DIK,DIV,DIU,DIN - .X ^DD(399,3,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X=DIV S X=DUZ X ^DD(399,3,1,2,1.4) - S DIKZ("S")=$G(^DGCR(399,DA,"S")) - S X=$P(DIKZ("S"),U,7) - I X'="" S ^DGCR(399,"APM",$E(X,1,30),DA)="" - S X=$P(DIKZ("S"),U,9) - I X'="" D - .N DIK,DIV,DIU,DIN - .X ^DD(399,9,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,9,1,1,1.4) - S X=$P(DIKZ("S"),U,9) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(399,9,1,2,69.2) S X=X="YES",Y=X,X=Y(2),X=X&Y I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X=DIV S X=DUZ X ^DD(399,9,1,2,1.4) - S X=$P(DIKZ("S"),U,9) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y=Y(0) X:$D(^DD(399,9,2)) ^(2) S X=Y="YES" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=3 X ^DD(399,9,1,3,1.4) - S X=$P(DIKZ("S"),U,9) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$EXTERNAL^DIDU(399,9,"",Y(0))="YES" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X="" X ^DD(399,9,1,4,1.4) - S DIKZ("S")=$G(^DGCR(399,DA,"S")) - S X=$P(DIKZ("S"),U,10) - I X'="" S ^DGCR(399,"APD3",$E(X,1,30),DA)="" - S X=$P(DIKZ("S"),U,12) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,14)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,14),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,12,1,1,1.4) - S X=$P(DIKZ("S"),U,12) - I X'="" D - .N DIK,DIV,DIU,DIN - .X ^DD(399,12,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=DUZ S DIH=$G(^DGCR(399,DIV(0),"S")),DIV=X S $P(^("S"),U,15)=DIV,DIH=399,DIG=15 D ^DICR - S X=$P(DIKZ("S"),U,12) - I X'="" D - .N DIK,DIV,DIU,DIN - .X ^DD(399,12,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=DUZ S DIH=$G(^DGCR(399,DIV(0),"S")),DIV=X S $P(^("S"),U,13)=DIV,DIH=399,DIG=13 D ^DICR - S X=$P(DIKZ("S"),U,12) - I X'="" S ^DGCR(399,"AP",$E(X,1,30),DA)="" - S DIKZ("S")=$G(^DGCR(399,DA,"S")) - S X=$P(DIKZ("S"),U,14) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=4 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,13)=DIV,DIH=399,DIG=.13 D ^DICR - S X=$P(DIKZ("S"),U,14) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=DUZ S DIH=$G(^DGCR(399,DIV(0),"S")),DIV=X S $P(^("S"),U,15)=DIV,DIH=399,DIG=15 D ^DICR - S DIKZ("S")=$G(^DGCR(399,DA,"S")) - S X=$P(DIKZ("S"),U,16) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$EXTERNAL^DIDU(399,16,"",Y(0))="YES" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,17),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,16,1,1,1.4) - S X=$P(DIKZ("S"),U,16) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$EXTERNAL^DIDU(399,16,"",Y(0))="YES" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,18),X=X S DIU=X K Y S X=DIV S X=DUZ X ^DD(399,16,1,2,1.4) - S DIKZ("S")=$G(^DGCR(399,DA,"S")) - S X=$P(DIKZ("S"),U,17) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,16),X=X S X=X=1 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=7 X ^DD(399,17,1,1,1.4) - S DIKZ("TX")=$G(^DGCR(399,DA,"TX")) - S X=$P(DIKZ("TX"),U,2) - I X'="" S ^DGCR(399,"ALEX",$E(X,1,30),DA)="" - S X=$P(DIKZ("TX"),U,5) - I X'="" D - .N DIK,DIV,DIU,DIN - .X ^DD(399,24,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,24,1,1,1.4) - S DIKZ("TX")=$G(^DGCR(399,DA,"TX")) - S X=$P(DIKZ("TX"),U,6) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=Y(0),X=X S X=X=1 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=2 X ^DD(399,25,1,1,1.4) - S X=$P(DIKZ("TX"),U,6) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(399,25,1,2,69.2) S X=X S X=X="",Y=X,X=Y(2),X=X&Y I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X=DIV S X=DUZ X ^DD(399,25,1,2,1.4) - S X=$P(DIKZ("TX"),U,6) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(399,25,1,3,69.2) S X=X S X=X="",Y=X,X=Y(2),X=X&Y I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,7),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,25,1,3,1.4) - S DIKZ("C")=$G(^DGCR(399,DA,"C")) - S X=$P(DIKZ("C"),U,14) - I X'="" D - .N DIK,DIV,DIU,DIN - .X ^DD(399,64,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"C")):^("C"),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X=DIV S X=$P(^ICD9(+X,0),"^",3) X ^DD(399,64,1,1,1.4) - S DIKZ("M")=$G(^DGCR(399,DA,"M")) - S X=$P(DIKZ("M"),U,1) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,X,1) X ^DD(399,101,1,1,1.4) - S X=$P(DIKZ("M"),U,1) I X'="" D .N DIK,DIV,DIU,DIN .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $$COBN^IBCEF(DA)=1 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y X ^DD(399,101,1,2,1.1) X ^DD(399,101,1,2,1.4) @@ -173,4 +76,74 @@ END G ^IBXX16 .X ^DD(399,114,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$BPP^IBCNS2(DA) X ^DD(399,114,1,3,1.4) S DIKZ("MP")=$G(^DGCR(399,DA,"MP")) S X=$P(DIKZ("MP"),U,1) + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,19),X=X S DIU=X K Y S X=DIV S X=$$FT^IBCU3(DA,1) X ^DD(399,135,1,2,1.4) + S X=$P(DIKZ("MP"),U,1) + I X'="" D MAILA^IBCU5 + S X=$P(DIKZ("MP"),U,1) + I X'="" S DGRVRCAL=1 + S DIKZ("MP")=$G(^DGCR(399,DA,"MP")) + S X=$P(DIKZ("MP"),U,2) + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$WNRBILL^IBEFUNC(DA) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y X ^DD(399,136,1,1,1.1) X ^DD(399,136,1,1,1.4) + S DIKZ("U")=$G(^DGCR(399,DA,"U")) + S X=$P(DIKZ("U"),U,1) + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$$LOS1^IBCU64(DA) X ^DD(399,151,1,1,1.4) + S X=$P(DIKZ("U"),U,1) + I X'="" S DGRVRCAL=1 + S X=$P(DIKZ("U"),U,1) + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I +$G(^DGCR(399,DA,"U1"))=0 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV S X=0 X ^DD(399,151,1,3,1.4) + S X=$P(DIKZ("U"),U,1) + I X'="" S:$P(^DGCR(399,DA,0),"^",2) ^DGCR(399,"APDS",$P(^(0),U,2),-X,DA)="" + S DIKZ("U")=$G(^DGCR(399,DA,"U")) + S X=$P(DIKZ("U"),U,2) + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$$LOS1^IBCU64(DA) X ^DD(399,152,1,1,1.4) + S X=$P(DIKZ("U"),U,2) + I X'="" S DGRVRCAL=1 + S DIKZ("U")=$G(^DGCR(399,DA,"U")) + S X=$P(DIKZ("U"),U,11) + I X'="" D + .N DIK,DIV,DIU,DIN + .X ^DD(399,161,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV D DIS^IBCU S X=X S DIH=$G(^DGCR(399,DIV(0),"U")),DIV=X S $P(^("U"),U,12)=DIV,DIH=399,DIG=162 D ^DICR + S DIKZ("U")=$G(^DGCR(399,DA,"U")) + S X=$P(DIKZ("U"),U,15) + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=($P($G(^DGCR(399,DA,"U2")),U,2)=""&$$INPAT^IBCEF(DA,1)) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIV X ^DD(399,165,1,1,1.4) + S X=$P(DIKZ("U"),U,15) + I X'="" D + .N DIK,DIV,DIU,DIN + .X ^DD(399,165,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV N Z S X=$$LOS1^IBCU64(DA,.Z),X=+$G(Z) X ^DD(399,165,1,2,1.4) + S DIKZ("U2")=$G(^DGCR(399,DA,"U2")) + S X=$P(DIKZ("U2"),U,4) + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,218,1,1,1.4) + S X=$P(DIKZ("U2"),U,4) + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X="PRIOR PAYMENT(S)" X ^DD(399,218,1,2,1.4) + S DIKZ("U2")=$G(^DGCR(399,DA,"U2")) + S X=$P(DIKZ("U2"),U,5) + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,219,1,1,1.4) + S X=$P(DIKZ("U2"),U,5) + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X="PRIOR PAYMENT(S)" X ^DD(399,219,1,2,1.4) + S DIKZ("U2")=$G(^DGCR(399,DA,"U2")) + S X=$P(DIKZ("U2"),U,6) + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,220,1,1,1.4) + S X=$P(DIKZ("U2"),U,6) END G ^IBXX17 diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX17.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX17.m index d6e477b6..0fa08155 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX17.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX17.m @@ -1,75 +1,5 @@ -IBXX17 ; COMPILED XREF FOR FILE #399.0222 ; 01/03/09 +IBXX17 ; COMPILED XREF FOR FILE #399.0222 ; 12/27/07 ; -END G ^IBXX17 - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,19),X=X S DIU=X K Y S X=DIV S X=$$FT^IBCU3(DA,1) X ^DD(399,135,1,2,1.4) - S X=$P(DIKZ("MP"),U,1) - I X'="" D MAILA^IBCU5 - S X=$P(DIKZ("MP"),U,1) - I X'="" S DGRVRCAL=1 - S DIKZ("MP")=$G(^DGCR(399,DA,"MP")) - S X=$P(DIKZ("MP"),U,2) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$WNRBILL^IBEFUNC(DA) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y X ^DD(399,136,1,1,1.1) X ^DD(399,136,1,1,1.4) - S DIKZ("U")=$G(^DGCR(399,DA,"U")) - S X=$P(DIKZ("U"),U,1) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$$LOS1^IBCU64(DA) X ^DD(399,151,1,1,1.4) - S X=$P(DIKZ("U"),U,1) - I X'="" S DGRVRCAL=1 - S X=$P(DIKZ("U"),U,1) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I +$G(^DGCR(399,DA,"U1"))=0 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV S X=0 X ^DD(399,151,1,3,1.4) - S X=$P(DIKZ("U"),U,1) - I X'="" S:$P(^DGCR(399,DA,0),"^",2) ^DGCR(399,"APDS",$P(^(0),U,2),-X,DA)="" - S DIKZ("U")=$G(^DGCR(399,DA,"U")) - S X=$P(DIKZ("U"),U,2) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$$LOS1^IBCU64(DA) X ^DD(399,152,1,1,1.4) - S X=$P(DIKZ("U"),U,2) - I X'="" S DGRVRCAL=1 - S DIKZ("U")=$G(^DGCR(399,DA,"U")) - S X=$P(DIKZ("U"),U,11) - I X'="" D - .N DIK,DIV,DIU,DIN - .X ^DD(399,161,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV D DIS^IBCU S X=X S DIH=$G(^DGCR(399,DIV(0),"U")),DIV=X S $P(^("U"),U,12)=DIV,DIH=399,DIG=162 D ^DICR - S DIKZ("U")=$G(^DGCR(399,DA,"U")) - S X=$P(DIKZ("U"),U,15) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=($P($G(^DGCR(399,DA,"U2")),U,2)=""&$$INPAT^IBCEF(DA,1)) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIV X ^DD(399,165,1,1,1.4) - S X=$P(DIKZ("U"),U,15) - I X'="" D - .N DIK,DIV,DIU,DIN - .X ^DD(399,165,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV N Z S X=$$LOS1^IBCU64(DA,.Z),X=+$G(Z) X ^DD(399,165,1,2,1.4) - S DIKZ("U2")=$G(^DGCR(399,DA,"U2")) - S X=$P(DIKZ("U2"),U,4) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,218,1,1,1.4) - S X=$P(DIKZ("U2"),U,4) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X="PRIOR PAYMENT(S)" X ^DD(399,218,1,2,1.4) - S DIKZ("U2")=$G(^DGCR(399,DA,"U2")) - S X=$P(DIKZ("U2"),U,5) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,219,1,1,1.4) - S X=$P(DIKZ("U2"),U,5) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X="PRIOR PAYMENT(S)" X ^DD(399,219,1,2,1.4) - S DIKZ("U2")=$G(^DGCR(399,DA,"U2")) - S X=$P(DIKZ("U2"),U,6) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,220,1,1,1.4) - S X=$P(DIKZ("U2"),U,6) I X'="" D .N DIK,DIV,DIU,DIN .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X="PRIOR PAYMENT(S)" X ^DD(399,220,1,2,1.4) diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX18.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX18.m index a7ae52fd..3303d7ca 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX18.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX18.m @@ -1,4 +1,4 @@ -IBXX18 ; COMPILED XREF FOR FILE #399.0222 ; 01/03/09 +IBXX18 ; COMPILED XREF FOR FILE #399.0222 ; 12/27/07 ; S DA(1)=DA S DA=0 A1 ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX19.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX19.m index 98ff0ffd..5b7efda0 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX19.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX19.m @@ -1,4 +1,4 @@ -IBXX19 ; COMPILED XREF FOR FILE #399.0304 ; 01/03/09 +IBXX19 ; COMPILED XREF FOR FILE #399.0304 ; 12/27/07 ; S DA=0 A1 ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX2.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX2.m index c30cc843..1ff8131f 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX2.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX2.m @@ -1,6 +1,52 @@ -IBXX2 ; COMPILED XREF FOR FILE #399.0222 ; 01/03/09 +IBXX2 ; COMPILED XREF FOR FILE #399.0222 ; 12/27/07 ; -END G ^IBXX2 + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU-X X ^DD(399,218,1,1,2.4) + S DIKZ("U2")=$G(^DGCR(399,DA,"U2")) + S X=$P(DIKZ("U2"),U,5) + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU-X X ^DD(399,219,1,1,2.4) + S DIKZ("U2")=$G(^DGCR(399,DA,"U2")) + S X=$P(DIKZ("U2"),U,6) + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU-X X ^DD(399,220,1,1,2.4) + S DIKZ("U2")=$G(^DGCR(399,DA,"U2")) + S X=$P(DIKZ("U2"),U,10) + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X="" X ^DD(399,232,1,1,2.4) + S X=$P(DIKZ("U2"),U,10) + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X="" X ^DD(399,232,1,2,2.4) + S X=$P(DIKZ("U2"),U,10) + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$CLIAREQ^IBCEP8A(DA) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$CLIA^IBCEP8A(DA) X ^DD(399,232,1,3,2.4) + S X=$P(DIKZ("U2"),U,10) + I X'="" D + .N DIK,DIV,DIU,DIN + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U3")):^("U3"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" S DIH=$G(^DGCR(399,DIV(0),"U3")),DIV=X S $P(^("U3"),U,3)=DIV,DIH=399,DIG=244 D ^DICR + S DIKZ("M1")=$G(^DGCR(399,DA,"M1")) + S X=$P(DIKZ("M1"),U,8) + I X'="" K ^DGCR(399,"AG",$E(X,1,30),DA) + S DIKZ(0)=$G(^DGCR(399,DA,0)) + S X=$P(DIKZ(0),U,1) + I X'="" K ^DGCR(399,"B",$E(X,1,30),DA) +CR1 S DIXR=139 + K X + S DIKZ("M")=$G(^DGCR(399,DA,"M")) + S X(1)=$P(DIKZ("M"),U,1) + S X(2)=$P(DIKZ("M"),U,2) + S X(3)=$P(DIKZ("M"),U,3) + S X(4)=$P(DIKZ("M"),U,13) + S X(5)=$P(DIKZ("M"),U,12) + S X(6)=$P(DIKZ("M"),U,14) + S X=$G(X(1)) + D . K X1,X2 M X1=X,X2=X . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5),X2(6))="" . N DIKXARR M DIKXARR=X S DIKCOND=1 diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX20.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX20.m index 04841707..591a7f19 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX20.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX20.m @@ -1,4 +1,4 @@ -IBXX20 ; COMPILED XREF FOR FILE #399.041 ; 01/03/09 +IBXX20 ; COMPILED XREF FOR FILE #399.041 ; 12/27/07 ; S DA=0 A1 ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX21.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX21.m index 5e6ee81e..9127e025 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX21.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX21.m @@ -1,4 +1,4 @@ -IBXX21 ; COMPILED XREF FOR FILE #399.042 ; 01/03/09 +IBXX21 ; COMPILED XREF FOR FILE #399.042 ; 12/27/07 ; S DA=0 A1 ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX22.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX22.m index 335b814f..7f42dd36 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX22.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX22.m @@ -1,4 +1,4 @@ -IBXX22 ; COMPILED XREF FOR FILE #399.043 ; 01/03/09 +IBXX22 ; COMPILED XREF FOR FILE #399.043 ; 12/27/07 ; S DA=0 A1 ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX23.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX23.m index 4edb779c..6cdd346a 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX23.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX23.m @@ -1,4 +1,4 @@ -IBXX23 ; COMPILED XREF FOR FILE #399.044 ; 01/03/09 +IBXX23 ; COMPILED XREF FOR FILE #399.044 ; 12/27/07 ; S DA=0 A1 ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX24.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX24.m index 6cebfe91..d905f781 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX24.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX24.m @@ -1,4 +1,4 @@ -IBXX24 ; COMPILED XREF FOR FILE #399.045 ; 01/03/09 +IBXX24 ; COMPILED XREF FOR FILE #399.045 ; 12/27/07 ; S DA=0 A1 ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX25.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX25.m index 8f83d096..eb9beb0d 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX25.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX25.m @@ -1,4 +1,4 @@ -IBXX25 ; COMPILED XREF FOR FILE #399.046 ; 01/03/09 +IBXX25 ; COMPILED XREF FOR FILE #399.046 ; 12/27/07 ; S DA=0 A1 ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX26.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX26.m index 0117d8e4..49d9f5fe 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX26.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX26.m @@ -1,4 +1,4 @@ -IBXX26 ; COMPILED XREF FOR FILE #399.047 ; 01/03/09 +IBXX26 ; COMPILED XREF FOR FILE #399.047 ; 12/27/07 ; S DA=0 A1 ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX27.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX27.m index 22efea6b..222f4e29 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX27.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX27.m @@ -1,4 +1,4 @@ -IBXX27 ; COMPILED XREF FOR FILE #399.048 ; 01/03/09 +IBXX27 ; COMPILED XREF FOR FILE #399.048 ; 12/27/07 ; S DA=0 A1 ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX28.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX28.m index 162cf034..7c6b09ec 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX28.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX28.m @@ -1,17 +1,16 @@ -IBXX28 ; COMPILED XREF FOR FILE #399.077 ; 01/03/09 +IBXX28 ; COMPILED XREF FOR FILE #399.30416 ; 12/27/07 ; - S DA=0 + S DA(2)=DA(1) S DA(1)=0 S DA=0 A1 ; - I $D(DISET) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1 -0 ; -A S DA=$O(^DGCR(399,DA(1),"TXC",DA)) I DA'>0 S DA=0 G END + I $D(DISET) K DIKLM S:DIKM1=2 DIKLM=1 S:DIKM1'=2&'$G(DIKPUSH(2)) DIKPUSH(2)=1,DA(2)=DA(1),DA(1)=DA,DA=0 G @DIKM1 +A S DA(1)=$O(^DGCR(399,DA(2),"CP",DA(1))) I DA(1)'>0 S DA(1)=0 G END 1 ; - S DIKZ(0)=$G(^DGCR(399,DA(1),"TXC",DA,0)) +B S DA=$O(^DGCR(399,DA(2),"CP",DA(1),"MOD",DA)) I DA'>0 S DA=0 Q:DIKM1=1 G A +2 ; + S DIKZ(0)=$G(^DGCR(399,DA(2),"CP",DA(1),"MOD",DA,0)) S X=$P(DIKZ(0),U,1) - I X'="" S ^DGCR(399,DA(1),"TXC","B",$E(X,1,30),DA)="" - S X=$P(DIKZ(0),U,1) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(1)=$S($D(^DGCR(399,D0,"TXC",D1,0)):^(0),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DUZ X ^DD(399.077,.01,1,2,1.4) - G:'$D(DIKLM) A Q:$D(DISET) -END G ^IBXX29 + I X'="" S ^DGCR(399,DA(2),"CP",DA(1),"MOD","B",$E(X,1,30),DA)="" + S X=$P(DIKZ(0),U,2) + I X'="" S ^DGCR(399,DA(2),"CP",DA(1),"MOD","C",$E(X,1,30),DA)="" + G:'$D(DIKLM) B Q:$D(DISET) +END Q diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX3.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX3.m index 5aa61b42..a74535ef 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX3.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX3.m @@ -1,4 +1,4 @@ -IBXX3 ; COMPILED XREF FOR FILE #399.0222 ; 01/03/09 +IBXX3 ; COMPILED XREF FOR FILE #399.0222 ; 12/27/07 ; S DA(1)=DA S DA=0 A1 ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX4.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX4.m index 11668d89..0c22e500 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX4.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX4.m @@ -1,4 +1,4 @@ -IBXX4 ; COMPILED XREF FOR FILE #399.0304 ; 01/03/09 +IBXX4 ; COMPILED XREF FOR FILE #399.0304 ; 12/27/07 ; S DA=0 A1 ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX5.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX5.m index f3c1b315..800850b7 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX5.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX5.m @@ -1,4 +1,4 @@ -IBXX5 ; COMPILED XREF FOR FILE #399.041 ; 01/03/09 +IBXX5 ; COMPILED XREF FOR FILE #399.041 ; 12/27/07 ; S DA=0 A1 ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX6.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX6.m index ed50801e..8a0536d4 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX6.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX6.m @@ -1,4 +1,4 @@ -IBXX6 ; COMPILED XREF FOR FILE #399.042 ; 01/03/09 +IBXX6 ; COMPILED XREF FOR FILE #399.042 ; 12/27/07 ; S DA=0 A1 ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX7.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX7.m index 7fd6cb14..e1a95bb2 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX7.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX7.m @@ -1,4 +1,4 @@ -IBXX7 ; COMPILED XREF FOR FILE #399.043 ; 01/03/09 +IBXX7 ; COMPILED XREF FOR FILE #399.043 ; 12/27/07 ; S DA=0 A1 ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX8.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX8.m index daa06852..62267c81 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX8.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX8.m @@ -1,4 +1,4 @@ -IBXX8 ; COMPILED XREF FOR FILE #399.044 ; 01/03/09 +IBXX8 ; COMPILED XREF FOR FILE #399.044 ; 12/27/07 ; S DA=0 A1 ; diff --git a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX9.m b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX9.m index b3b4e6e2..70287393 100644 --- a/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX9.m +++ b/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX9.m @@ -1,4 +1,4 @@ -IBXX9 ; COMPILED XREF FOR FILE #399.045 ; 01/03/09 +IBXX9 ; COMPILED XREF FOR FILE #399.045 ; 12/27/07 ; S DA=0 A1 ; diff --git a/r/INTEGRATED_PATIENT_FUNDS-PRPF-PFXIP/PRPFED2.m b/r/INTEGRATED_PATIENT_FUNDS-PRPF-PFXIP/PRPFED2.m index 79adb891..ead874ab 100644 --- a/r/INTEGRATED_PATIENT_FUNDS-PRPF-PFXIP/PRPFED2.m +++ b/r/INTEGRATED_PATIENT_FUNDS-PRPF-PFXIP/PRPFED2.m @@ -1,15 +1,15 @@ -PRPFED2 ;ALTOONA/CTB MISCELLANEOUS EDIT OPTIONS ;11/22/96 4:38 PM -V ;;3.0;PATIENT FUNDS;**6,18**;JUNE 1, 1989;Build 9 -LONGREG S DIC(0)="AEQLM",DIC=470,DLAYGO=470 D ^DIC G:Y<0 OUT^PRPFED S DA=+Y,DIE=DIC,DR="[PRPF LONG REGISTRATION]" D ^DIE G LONGREG - ; -SELDATA S DIC(0)="AEQM",DIC=470 W !! D ^DIC G OUT^PRPFED:Y<0 S DA=$P(Y,U,1),DIE=DIC,DR="[PRPF SELECTED DATA EDIT]" D ^DIE G SELDATA - ; -SHORTREG S DIC(0)="AEQLM",DIC=470,DLAYGO=470 W !! D ^DIC G:Y<0 OUT^PRPFED S DA=+Y,DIE=DIC,DR="[PRPF SHORT REGISTRATION]" D ^DIE G SHORTREG - ; -ADDRESS S DIC=470,DIC(0)="AEMN" D ^DIC G:Y<0 OUT^PRPFED S DA=+Y,DIE="^DPT(",DR=".111;.112;.113;.114;.115;.116;.131;.132" D ^DIE G ADDRESS - ; -GUARDIAN S DIC=2,DIC(0)="AEMN" D ^DIC G:Y<0 OUT^PRPFED S DA=+Y,DIE="^DPT(",DR=".291;.2912;.2914;.2915;.2916;.2917;.2918;.2919;.292;.2922;.2923;.2924;.2925;.2926;.2927;.2928;.2929" D ^DIE G GUARDIAN - ; -INACT ;EDIT ACCOUNT STATUS - S DIC=470,DIC(0)="AEMNQO" D ^DIC I Y>0 S DA=+Y,DIE=DIC,DR="[PRPF INACTIVE/ACTIVE]" D ^DIE W ! G INACT - K %,%W,%X,%Y,C,D0,DA,DI,DIYS,DIC,DIE,DQ,DR,I,K,POP,S,X,Y Q +PRPFED2 ;ALTOONA/CTB MISCELLANEOUS EDIT OPTIONS ;11/22/96 4:38 PM +V ;;3.0;PATIENT FUNDS;**6**;JUNE 1, 1989 +LONGREG S DIC(0)="AEQLM",DIC=470,DLAYGO=470 D ^DIC G:Y<0 OUT^PRPFED S DA=+Y,DIE=DIC,DR="[PRPF LONG REGISTRATION]" D ^DIE G LONGREG + ; +SELDATA S DIC(0)="AEQM",DIC=470 W !! D ^DIC G OUT^PRPFED:Y<0 S DA=$P(Y,U,1),DIE=DIC,DR="[PRPF SELECTED DATA EDIT]" D ^DIE G SELDATA + ; +SHORTREG S DIC(0)="AEQLM",DIC=470,DLAYGO=470 W !! D ^DIC G:Y<0 OUT^PRPFED S DA=+Y,DIE=DIC,DR="[PRPF SHORT REGISTRATION]" D ^DIE G SHORTREG + ; +ADDRESS S DIC=470,DIC(0)="AEMN" D ^DIC G:Y<0 OUT^PRPFED S DA=+Y,DIE="^DPT(",DR=".111;.112;.113;.114;.115;.116;.131;.132" D ^DIE G ADDRESS + ; +GUARDIAN S DIC=470,DIC(0)="AEMN" D ^DIC G:Y<0 OUT^PRPFED S DA=+Y,DIE="^DPT(",DR=".291;.2912;.2914;.2915;.2916;.2917;.2918;.2919;.292;.2922;.2923;.2924;.2925;.2926;.2927;.2928;.2929" D ^DIE G GUARDIAN + ; +INACT ;EDIT ACCOUNT STATUS + S DIC=470,DIC(0)="AEMNQO" D ^DIC I Y>0 S DA=+Y,DIE=DIC,DR="[PRPF INACTIVE/ACTIVE]" D ^DIE W ! G INACT + K %,%W,%X,%Y,C,D0,DA,DI,DIYS,DIC,DIE,DQ,DR,I,K,POP,S,X,Y Q diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XGKB.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XGKB.m index b5f37960..4b35b24a 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XGKB.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XGKB.m @@ -1,64 +1,64 @@ -XGKB ;SFISC/VYD - Read with Escape Processing ;10/23/2006 - ;;8.0;KERNEL;**34,244,365**;Jul 10, 1995;Build 5 - ;;Special thanks to MELDRUM.KEVIN@ISC-SLC.VA.GOV - ; -INIT(XGTRM) ;turn escape processing on and passed terminator string if any - N %,%OS S %OS=^%ZOSF("OS") - I %OS["VAX DSM" U $I:(NOLINE:ESCAPE) D:'$D(^XUTL("XGKB")) VAXDSM^XGKB1 - I %OS["MSM" U $I:(0::::64) D:'$D(^XUTL("XGKB")) MSM^XGKB1 - I %OS["DTM" U $I:(VT=1:ESCAPE=1) D:'$D(^XUTL("XGKB")) DTM^XGKB1 - I %OS["OpenM" U $I:(:"CT") D:'$D(^XUTL("XGKB")) DTM^XGKB1 S:$G(XGTRM)="*" XGTRM="" - I %OS["GT.M" U $I:(ESCAPE) D:'$D(^XUTL("XGKB")) GTM^XGKB1 - I $G(XGTRM)="*" X ^%ZOSF("TRMON") I 1 ;turn all on - E I $L($G(XGTRM)) S %=$$SETTRM^%ZOSV(XGTRM) ;turn on passed terminators - S XGRT="" - Q - ; - ; -EXIT ; Reset device (disable escape processing, turn terminators off) - N %OS S %OS=^%ZOSF("OS") - I %OS["VAX DSM" U $I:(LINE:NOESCAPE) - I %OS["MSM" U $I:(0:::::64) - I %OS["DTM" U $I:(ESCAPE=0) - I %OS["GT.M" U $I:(NOESCAPE) - X ^%ZOSF("TRMOFF") - K XGRT - Q - ; - ; -ACTION(XGKEY,XGACTION) ;add or remove key-action - ;XGKEY:key mnemonic ("F10","NEXT",etc.) - ;XGACTION:M executable string - ;if action is passed ADD mode is assumed otherwise REMOVE - I $D(XGACTION) S ^TMP("XGKEY",$J,XGKEY)=XGACTION - E K ^TMP("XGKEY",$J,XGKEY) - Q - ; - ; -READ(XGCHARS,XGTO) ; read XGCHARS using escape processing. XGTO timeout (optional). Result returned. - ; Char that terminated the read will be in XGRT - N S,XGW1,XGT1,XGSEQ ;string,window,timer,timer sequence - K DTOUT - S XGRT="" - D:$G(XGTO)="" ;set timeout value if one wasn't passed - . I $D(XGT) D Q ;if timers are defined - . . S XGTO=$O(XGT(0,"")) ;get shortest time left of all timers - . . S XGW1=$P(XGT(0,XGTO,$O(XGT(0,XGTO,"")),"ID"),U,1) ;get timer's window - . . S XGT1=$P(XGT(0,XGTO,$O(XGT(0,XGTO,"")),"ID"),U,3) ;get timer's name - . I $D(XGW) S XGTO=99999999 Q ;in emulation read forever - . S XGTO=$G(DTIME,600) - ; - I $G(XGCHARS)>0 R S#XGCHARS:XGTO S:'$T DTOUT=1 I 1 ;fixed length read - E R S:XGTO S:'$T DTOUT=1 I 1 ;read as many as possible - S:$G(DTOUT)&('$D(XGT1)) S=U ;stuff ^ - ; - S:$L($ZB) XGRT=$G(^XUTL("XGKB",$ZB)) ;get terminator if any - I $G(DTOUT),$D(XGT1),$D(^TMP("XGW",$J,XGW1,"T",XGT1,"EVENT","TIMER")) D I 1 ;if timed out - . D E^XGEVNT1(XGW1,"T",XGT1,"","TIMER") - E I $L(XGRT),$D(^TMP("XGKEY",$J,XGRT)) X ^(XGRT) ;do some action - ; this really should be handled by keyboard mapping -- later - Q S - ; - ; -TEST F S X=$$READ Q:X["^" W ?20,X,?40,XGRT,?60,$ZB,! - Q +XGKB ;SFISC/VYD - Read with Escape Processing ;07/10/2002 10:58 + ;;8.0;KERNEL;**34,244**;Jul 10, 1995 + ;;Special thanks to MELDRUM.KEVIN@ISC-SLC.VA.GOV + ; +INIT(XGTRM) ;turn escape processing on and passed terminator string if any + N %,%OS S %OS=^%ZOSF("OS") + I %OS["VAX DSM" U $I:(NOLINE:ESCAPE) D:'$D(^XUTL("XGKB")) VAXDSM^XGKB1 + I %OS["MSM" U $I:(0::::64) D:'$D(^XUTL("XGKB")) MSM^XGKB1 + I %OS["DTM" U $I:(VT=1:ESCAPE=1) D:'$D(^XUTL("XGKB")) DTM^XGKB1 + I %OS["OpenM" U $I:(:"CT") D:'$D(^XUTL("XGKB")) DTM^XGKB1 + I %OS["GT.M" U $I:(ESCAPE) D:'$D(^XUTL("XGKB")) GTM^XGKB1 + I $G(XGTRM)="*" X ^%ZOSF("TRMON") I 1 ;turn all on + E I $L($G(XGTRM)) S %=$$SETTRM^%ZOSV(XGTRM) ;turn on passed terminators + S XGRT="" + Q + ; + ; +EXIT ; Reset device (disable escape processing, turn terminators off) + N %OS S %OS=^%ZOSF("OS") + I %OS["VAX DSM" U $I:(LINE:NOESCAPE) + I %OS["MSM" U $I:(0:::::64) + I %OS["DTM" U $I:(ESCAPE=0) + I %OS["GT.M" U $I:(NOESCAPE) + X ^%ZOSF("TRMOFF") + K XGRT + Q + ; + ; +ACTION(XGKEY,XGACTION) ;add or remove key-action + ;XGKEY:key mnemonic ("F10","NEXT",etc.) + ;XGACTION:M executable string + ;if action is passed ADD mode is assumed otherwise REMOVE + I $D(XGACTION) S ^TMP("XGKEY",$J,XGKEY)=XGACTION + E K ^TMP("XGKEY",$J,XGKEY) + Q + ; + ; +READ(XGCHARS,XGTO) ; read XGCHARS using escape processing. XGTO timeout (optional). Result returned. + ; Char that terminated the read will be in XGRT + N S,XGW1,XGT1,XGSEQ ;string,window,timer,timer sequence + K DTOUT + S XGRT="" + D:$G(XGTO)="" ;set timeout value if one wasn't passed + . I $D(XGT) D Q ;if timers are defined + . . S XGTO=$O(XGT(0,"")) ;get shortest time left of all timers + . . S XGW1=$P(XGT(0,XGTO,$O(XGT(0,XGTO,"")),"ID"),U,1) ;get timer's window + . . S XGT1=$P(XGT(0,XGTO,$O(XGT(0,XGTO,"")),"ID"),U,3) ;get timer's name + . I $D(XGW) S XGTO=99999999 Q ;in emulation read forever + . S XGTO=$G(DTIME,600) + ; + I $G(XGCHARS)>0 R S#XGCHARS:XGTO S:'$T DTOUT=1 I 1 ;fixed length read + E R S:XGTO S:'$T DTOUT=1 I 1 ;read as many as possible + S:$G(DTOUT)&('$D(XGT1)) S=U ;stuff ^ + ; + S:$L($ZB) XGRT=$G(^XUTL("XGKB",$ZB)) ;get terminator if any + I $G(DTOUT),$D(XGT1),$D(^TMP("XGW",$J,XGW1,"T",XGT1,"EVENT","TIMER")) D I 1 ;if timed out + . D E^XGEVNT1(XGW1,"T",XGT1,"","TIMER") + E I $L(XGRT),$D(^TMP("XGKEY",$J,XGRT)) X ^(XGRT) ;do some action + ; this really should be handled by keyboard mapping -- later + Q S + ; + ; +TEST F S X=$$READ Q:X["^" W ?20,X,?40,XGRT,?60,$ZB,! + Q diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDDP.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDDP.m index c138b280..a2277d52 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDDP.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDDP.m @@ -1,227 +1,147 @@ -XPDDP ;SFISC/RSD - Display a package ;03/18/2008 - ;;8.0;KERNEL;**21,28,44,68,100,108,229,304,346,463,488**;Jul 10, 1995;Build 6 - ; Per VHA Directive 2004-038, this routine should not be modified. - ; Options: XPD PRINT BUILD calls EN1 - ; XPD PRINT INSTALL calls EN2 -EN1 ; Print from Build file - N DIC,D0,XPD,XPDT,XPDST,Y - S XPDST=$$LOOK^XPDB1 Q:XPDST<0 - S XPD("XPDT(")="" - D EN^XUTMDEVQ("LST1^XPDDP","Build File Print",.XPD) - Q -EN2 ; Print from Distribution - N D0,DIC,POP,XPD,XPDA,XPDNM,XPDT,XPDST,Y,Z,%ZIS - S XPDST=$$LOOK^XPDI1("I $D(^XTMP(""XPDI"",Y))",1) - S D0=$O(^XTMP("XPDI",XPDST,"BLD",0)) Q:'D0 - S XPD("XPDT(")="" - D EN^XUTMDEVQ("LST2^XPDDP","Transport Global Print",.XPD) - Q -LST1 ; Print from Build file - K DIRUT N XPDIT,XPDCNT S (XPDIT,XPDCNT)=0 - F S XPDIT=$O(XPDT(XPDIT)) Q:$D(DIRUT)!(XPDIT'>0) D Q:$D(DIRUT) - . I XPDCNT Q:'$$CONT - . S XPDCNT=XPDCNT+1 - . S D0=+XPDT(XPDIT) D PNT("XPD(9.6,D0)") - D WAIT - Q -LST2 ; Print from XPDT array - K DIRUT N XPDIT,XPDCNT S (XPDIT,XPDCNT)=0 - F S XPDIT=$O(XPDT(XPDIT)) Q:$D(DIRUT)!(XPDIT'>0) D Q:$D(DIRUT) - . I XPDCNT Q:'$$CONT - . S XPDCNT=XPDCNT+1 - . S XPDA=+XPDT(XPDIT),D0=$O(^XTMP("XPDI",XPDA,"BLD",0)) D PNT("XTMP(""XPDI"",XPDA,""BLD"",D0)") - D WAIT - Q -WAIT ; Pause on last page or not? It depends on whether there's enough room - ; left on the page to display the KIDS menu. - Q:$E($G(IOST),1,2)'="C-" - Q:$D(DIRUT) - ; DUZ("AUTO")=1 means show menu option choices - I IOSL-$Y<$S($G(DUZ("AUTO")):14,1:3) D WAIT^XMXUTIL - Q -PNT(XPDGR) ; Print a package, XPDGR=global root - ;XPDFL=0 - Build - ^XPD(9.7 global root - ; 1 - Install - ^XTMP global root - ; 2 - Packman - ^TMP($J, global root - N I,J,K,X,XPD,XPDDT,XPDI,XPD0,XPDFL,XPDPG,XPDUL,XPDTYPE,XPDTRACK,XPDTXT - Q:$G(XPDGR)="" S XPDGR="^"_XPDGR - Q:'$D(@XPDGR@(0)) - D ID ; Package Identification - D DESCR Q:$D(DIRUT) ; Description - I XPDTYPE=1 D MULT Q ; Multi-Package - D PREPOST Q:$D(DIRUT) ; Environment check & Pre/Post Routines - I XPDTYPE=2 D GLOBAL Q ; Global Package - D FILES Q:$D(DIRUT) ; Files/DDs - D COMP Q:$D(DIRUT) ; Build Components - Q:XPDFL=2 ; Packman message, called from XMP2 - Summarize - D QUESTS Q:$D(DIRUT) ; Install Questions - D ALFABETA Q:$D(DIRUT) ; Alpha/Beta Testing - D NAMESP Q:$D(DIRUT) ; Include/Exclude Namespaces - D REQDBLD Q:$D(DIRUT) ; Required Builds - Q -ID ; Identify the package - S XPD0=^(0),XPDPG=1,XPDFL=$S($E(XPDGR,1,5)="^TMP(":2,1:$E(XPDGR,1,5)="^XTMP"),$P(XPDUL,"-",IOM)="",XPDDT=$$HTE^XLFDT($H,"1PM"),XPDTYPE=+$P(XPD0,U,3),XPDTRACK=$P(XPD0,U,5) - W:$E(IOST,1,2)="C-" @IOF D HDR W !,XPDUL - W !,"TYPE: ",$$EXTERNAL^DILFD(9.6,2,"",XPDTYPE) - W ?51,"TRACK NATIONALLY: ",$$EXTERNAL^DILFD(9.6,5,"",XPDTRACK) - W !,"NATIONAL PACKAGE: ",$P($G(^DIC(9.4,+$P(XPD0,U,2),0),$P(XPD0,U,2)),U) - W ?49,"ALPHA/BETA TESTING: ",$S($P($G(@XPDGR@("ABPKG")),U)="y":"YES",1:"NO") - Q -DESCR ; Show patch description - W !!,"DESCRIPTION:" - S XPDI=0 - F S XPDI=$O(@XPDGR@(1,XPDI)) Q:'XPDI S XPDTXT=$G(^(XPDI,0)) D Q:$D(DIRUT) - . I $L(XPDTXT)'1:$E(XPDTXT,1,IOM-1),1:XPDTXT) - Q -PREPOST ; Environment check and pre/post routines - Q:$$CHK(3) - W !!,"ENVIRONMENT CHECK: ",$G(@XPDGR@("PRE")) - W ?49,"DELETE ENV ROUTINE: " I $G(@XPDGR@("PRE"))]"" W $S($P($G(@XPDGR@("INID")),U)="y":"Yes",1:"No") - I 'XPDTYPE D Q:$D(DIRUT) - . Q:$$CHK(2) - . W !," PRE-INIT ROUTINE: ",$G(@XPDGR@("INI")) - . W ?44,"DELETE PRE-INIT ROUTINE: " I $G(@XPDGR@("INI"))]"" W $S($P($G(@XPDGR@("INID")),U,3)="y":"Yes",1:"No") - Q:$$CHK(2) - W !,"POST-INIT ROUTINE: ",$G(@XPDGR@("INIT")) - W ?43,"DELETE POST-INIT ROUTINE: " I $G(@XPDGR@("INIT"))]"" W $S($P($G(@XPDGR@("INID")),U,2)="y":"Yes",1:"No") - I 'XPDTYPE Q:$$CHK(2) W !,"PRE-TRANSPORT RTN: ",$G(@XPDGR@("PRET")) - Q -FILES ; Show files/DDs - Q:'$O(@XPDGR@(4,0)) ; Quit if no files - S I=$$CHK(8,1) Q:I I '$P(I,"^",2) D HDR1 W !,XPDUL - S XPDI=0 - F S XPDI=$O(@XPDGR@(4,XPDI)) Q:'XPDI S XPD=$G(^(XPDI,222)) Q:$$CHK(3,1) D - . ;file number, file name, partial DD - . W !!,XPDI,?12,$S('XPDFL:$P($G(^DIC(XPDI,0),"**unknown**"),U),1:$G(^XTMP("XPDI",XPDA,"FIA",XPDI))) - . ; update DD, send security code, data comes with file - . W ?43,$$EXTERNAL^DILFD(9.64,222.1,"",$P(XPD,U)),?49,$$EXTERNAL^DILFD(9.64,222.2,"",$P(XPD,U,2)),?55,$$EXTERNAL^DILFD(9.64,222.7,"",$P(XPD,U,7)) - . ; override site data, resolve pointers, user override - . W ?63,$E($$EXTERNAL^DILFD(9.64,222.8,"",$P(XPD,U,8)),1,4),?69,$$EXTERNAL^DILFD(9.64,222.5,"",$P(XPD,U,5)),?75,$$EXTERNAL^DILFD(9.64,222.9,"",$P(XPD,U,9)) - . I $P(XPD,U,3)="p" D Q:$D(DIRUT) - . . ; Print partial DD information - . . N XPDSUB,XPDFLD - . . Q:$$CHK(2,1) - . . W !,"Partial DD:" - . . S (J,XPDSUB)=0 - . . F S J=$O(@XPDGR@(4,"APDD",XPDI,J)) Q:'J D Q:$D(DIRUT) - . . . I XPDSUB Q:$$CHK(2,1) W ! - . . . W ?12,"subDD: ",J - . . . S XPDSUB=1,(I,XPDFLD)=0 - . . . F S I=$O(@XPDGR@(4,"APDD",XPDI,J,I)) Q:'I D Q:$D(DIRUT) - . . . . I XPDFLD Q:$$CHK(2,1) W ! - . . . . W ?30,"fld: ",I S XPDFLD=1 - . I " "'[$G(@XPDGR@(4,XPDI,223)) Q:$$CHK(2,1) W !,?2,"DD SCREEN : ",^(223) - . I " "'[$G(@XPDGR@(4,XPDI,224)) Q:$$CHK(2,1) W !,?2,"DATA SCREEN: ",^(224) - Q -COMP ; Print Build components - S I=0,XPD=$P(^DD(9.68,.03,0),U,3) - F S I=$O(@XPDGR@("KRN",I)) Q:'I D Q:$D(DIRUT) - . Q:'$D(@XPDGR@("KRN",I,"NM","B")) - . Q:$$CHK(4) - . W !!,$S($D(^DIC(I,0)):$P(^(0),U),XPDFL:$G(^XTMP("XPDI",XPDA,"FIA",I),"UNKNOWN"),1:"UNKNOWN")_":",?47,"ACTION:" - . S J="" - . F S J=$O(@XPDGR@("KRN",I,"NM","B",J)) Q:J="" S X=$O(^(J,0)) D Q:$D(DIRUT) - . . Q:'X - . . S X=$G(@XPDGR@("KRN",I,"NM",X,0)) Q:X="" - . . Q:$$CHK(2) - . . ;write the entry name and write the action - . . W !,?3,$P(X,U),?50,$P($P(XPD,";",$P(X,U,3)+1),":",2) - Q -QUESTS ; Show Install Questions - I '$O(@XPDGR@("QUES",0)),'($D(@XPDGR@("QDEF"))#2) Q - Q:$$CHK(6) - W !!,"INSTALL QUESTIONS: " - S I=0 - F S I=$O(@XPDGR@("QUES",I)) Q:'I S X=$P(^(I,0),U),J=$G(^(1)),K=$G(^("A")) D Q:$D(DIRUT) - . Q:$$CHK(4) - . W !!?5,"SUBSCRIPT: ",X - . W !,"DIR(0)=",J - . S J=0 - . F S J=$O(@XPDGR@("QUES",I,"A1",J)) Q:'J Q:$$CHK(2) W !,"DIR(""A"",",J,")=",^(J,0) - . I K]"" Q:$$CHK(2) W !,"DIR(""A"")=",K - . I $G(@XPDGR@("QUES",I,"B"))]"" Q:$$CHK(2) W !,"DIR(""B"")=",^("B") - . S J=0 - . F S J=$O(@XPDGR@("QUES",I,"Q1",J)) Q:'J Q:$$CHK(2) W !,"DIR(""?"",",J,")=",^(J,0) - . I $G(@XPDGR@("QUES",I,"Q"))]"" Q:$$CHK(2) W !,"DIR(""?"")=",^("Q") - . I $G(@XPDGR@("QUES",I,"QQ"))]"" Q:$$CHK(2) W !,"DIR(""??"")=",^("QQ") - . I $G(@XPDGR@("QUES",I,"M"))]"" Q:$$CHK(2) W !,"M CODE: ",^("M") - Q:$D(DIRUT) - ;Show new Defaults for KIDS questions. p463 - S X=$G(@XPDGR@("QDEF")) Q:X="" - I '$L($P(X,U,9)),'$L($P(X,U,5)),'$L($P(X,U,11)) Q - Q:$$CHK(3) W ! - I $L($P(X,U,9)) Q:$$CHK(2) W !," Default Rebuild Menu Trees Upon Completion of Install: ",$P(X,U,9) - I $L($P(X,U,5)) Q:$$CHK(2) W !," Default INHIBIT LOGONs during the install: ",$P(X,U,5) - I $L($P(X,U,11)) Q:$$CHK(2) W !," Default DISABLE Scheduled Options, Menu Options, and Protocols: ",$P(X,U,11) - Q -ALFABETA ; Alpha/Beta Testing - S XPD=$G(@XPDGR@("ABPKG")) Q:XPD="" - Q:$P(XPD,U)'="y" - Q:$$CHK(4) - W !!,"ALPHA/BETA TESTING: ",$$EXTERNAL^DILFD(9.6,20,"",$P(XPD,U)),?47,"INSTALLATION MESSAGE: ",$$EXTERNAL^DILFD(9.6,21,"",$P(XPD,U,2)) - W !,"ADDRESS: ",$P(XPD,U,3) - Q -NAMESP ; Namespaces - Q:'$O(@XPDGR@("ABNS",0)) - Q:$$CHK(4) - W !!,"INCLUDE NAMESPACE:",?47,"EXCLUDE NAMESPACE:" - S I=0 - F S I=$O(@XPDGR@("ABNS",I)) Q:'I Q:$$CHK(2) W !?3,^(I,0) D Q:$D(DIRUT) - . N XPDNMSP,XPDLF - . S (J,XPDLF)=0 - . F S J=$O(@XPDGR@("ABNS",I,1,J)) Q:'J S XPDNMSP=^(J,0) D Q:$D(DIRUT) - . . I XPDLF Q:$$CHK(2) W ! - . . W ?50,XPDNMSP - . . S XPDLF=1 - Q -REQDBLD ; Required Builds - Q:'$O(@XPDGR@("REQB",0)) - Q:$$CHK(4) - W !!,"REQUIRED BUILDS:",?47,"ACTION:" - S XPDI=0 - F S XPDI=$O(@XPDGR@("REQB",XPDI)) Q:'XPDI S XPD=$G(^(XPDI,0)) Q:$$CHK(2) D - . W !?3,$P(XPD,U),?50,$$EXTERNAL^DILFD(9.611,1,"",$P(XPD,U,2)) - Q -GLOBAL ; Global Package - Q:$$CHK(4) - W !!,"GLOBAL:",?47,"KILL GLOBAL BEFORE INSTALL:" - S XPDI=0 - F S XPDI=$O(@XPDGR@("GLO",XPDI)) Q:'XPDI S XPD=$G(^(XPDI,0)) Q:$$CHK(2) D - . W !?3,$P(XPD,U),?50,$$EXTERNAL^DILFD(9.65,1,"",$P(XPD,U,2)) - Q -MULT ; Multi-Package - Q:$$CHK(4) - W !!,"SEQUENCE OF BUILDS:" - S XPDI=0 - F S XPDI=$O(@XPDGR@(10,XPDI)) Q:'XPDI S XPD=$G(^(XPDI,0)) Q:$$CHK(2) D - . W !?2,XPDI,?8,$E($P(XPD,U),1,44),?54,$S($P(XPD,U,2)=1:"",1:"Not ")_"Required to Continue" - Q -CHK(Y,XPD) ;Y=excess lines XPD=1 print file header, return 1 to exit - ;return 0 if header was not written, else "0^1" - Q:$Y<(IOSL-Y) 0 - Q:'$$CONT 1 - S XPD=$G(XPD),XPDPG=XPDPG+1 - W @IOF D HDR,HDR1:XPD - W !,XPDUL - Q "0^1" -CONT() ; Press Return to continue; ^ to exit. - Q:$D(DIRUT) 0 - Q:$E(IOST,1,2)'="C-" 1 - N DIR,I,J,K,X,Y - S DIR(0)="E" D ^DIR - Q Y -XMP2(X,D0) ;called from ^XMP2 - N XPDA S XPDA=-1 - D PNT(X) - Q -HDR ; - W "PACKAGE: ",$P(XPD0,U)," ",XPDDT,?70,$$RJ^XLFSTR("PAGE "_XPDPG,9) - Q -HDR1 ; - W !!,?43,"UP SEND DATA USER" - W !,?43,"DATE SEC. COMES SITE RSLV OVER" - W !,"FILE #",?12,"FILE NAME",?43,"DD CODE W/FILE DATA PTRS RIDE" - Q +XPDDP ;SFISC/RSD - Display a package ;6/21/07 09:44 + ;;8.0;KERNEL;**21,28,44,68,100,108,229,304,346,463**;Jul 10, 1995;Build 4 +EN1 ;print from Build file + N DIC,D0,XPD,XPDT,XPDST,Y,Z + S XPDST=$$LOOK^XPDB1 Q:XPDST<0 + S XPD("XPDT(")="",Y="LST1^XPDDP",Z="Build File Print" + D EN^XUTMDEVQ(Y,Z,.XPD) + Q +EN2 ;print from Distribution + N D0,DIC,POP,XPD,XPDA,XPDNM,XPDT,XPDST,Y,Z,%ZIS + S XPDST=$$LOOK^XPDI1("I $D(^XTMP(""XPDI"",Y))",1) + S XPD("XPDT(")="",Y="LST2^XPDDP",Z="Transport Global Print",D0=$O(^XTMP("XPDI",XPDST,"BLD",0)) + Q:'D0 + D EN^XUTMDEVQ(Y,Z,.XPD) + Q + ; +LST1 ; + K DIRUT N XPDIT S XPDIT=0 + F S XPDIT=$O(XPDT(XPDIT)) Q:$D(DIRUT)!(XPDIT'>0) D + . S D0=+XPDT(XPDIT) D PNT("XPD(9.6,D0)") + Q + ; +LST2 ;Print from XPDT array + K DIRUT N XPDIT S XPDIT=0 + F S XPDIT=$O(XPDT(XPDIT)) Q:$D(DIRUT)!(XPDIT'>0) D + . S XPDA=+XPDT(XPDIT),D0=$O(^XTMP("XPDI",XPDA,"BLD",0)) D PNT("XTMP(""XPDI"",XPDA,""BLD"",D0)") + Q + ; +PNT(XPDGR) ;print a package, XPDGR=global root + ;XPDFL=0 - Build - ^XPD(9.7 global root, 1 - Install - ^XTMP global root + ;2 - Packman ^TMP($J, global root + N I,J,K,X,XPD,XPDDT,XPDI,XPD0,XPDFL,XPDPG,XPDUL,XPDTYPE,XPDTRACK,XPDTXT,XPDOUT + Q:$G(XPDGR)="" S XPDGR="^"_XPDGR + Q:'$D(@XPDGR@(0)) + S XPD0=^(0),XPDPG=1,XPDFL=$S($E(XPDGR,1,5)="^TMP(":2,1:$E(XPDGR,1,5)="^XTMP"),$P(XPDUL,"-",IOM)="",XPDDT=$$HTE^XLFDT($H,"1PM"),XPDTYPE=+$P(XPD0,U,3),XPDTRACK=$P(XPD0,U,5) + W:$E(IOST,1,2)="C-" @IOF D HDR W XPDUL,! + W "TYPE: ",$$EXTERNAL^DILFD(9.6,2,"",XPDTYPE) + W !,"TRACK NATIONALLY: ",$$EXTERNAL^DILFD(9.6,5,"",XPDTRACK) + W !,"NATIONAL PACKAGE: ",$P($G(^DIC(9.4,+$P(XPD0,U,2),0),$P(XPD0,U,2)),U) + W !,"ALPHA/BETA TESTING: ",$S($P($G(@XPDGR@("ABPKG")),U)="y":"YES",1:"NO") ; new line added. + W !,"DESCRIPTION:" + S (XPDI,XPDOUT)=0 + F S XPDI=$O(@XPDGR@(1,XPDI)) Q:'XPDI S XPDTXT=$G(^(XPDI,0)) D Q:XPDOUT + . I $L(XPDTXT)'1:$E(XPDTXT,1,IOM-1),1:XPDTXT),! + . . S XPDOUT=$$CHK(2) + Q:$D(DIRUT) G:XPDTYPE=1 MULT + W !,"ENVIRONMENT CHECK : ",$G(@XPDGR@("PRE")) + W ?47,"DELETE ENV ROUTINE: ",$S($P($G(@XPDGR@("INID")),U)="y":"Yes",1:"No") + W ! + I 'XPDTYPE D + . W " PRE-INIT ROUTINE : ",$G(@XPDGR@("INI")) + . W ?42,"DELETE PRE-INIT ROUTINE: ",$S($P($G(@XPDGR@("INID")),U,3)="y":"Yes",1:"No") + . W ! + Q:$$CHK(4) W "POST-INIT ROUTINE : ",$G(@XPDGR@("INIT")) + W ?41,"DELETE POST-INIT ROUTINE: ",$S($P($G(@XPDGR@("INID")),U,2)="y":"Yes",1:"No") + W ! + W:'XPDTYPE "PRE-TRANSPORT RTN : ",$G(@XPDGR@("PRET")),! + G:XPDTYPE=2 GLOBAL + I '$O(@XPDGR@(4,0)) Q:$$CHK(4) G COMP + S I=$$CHK(10,1) Q:I I '$P(I,"^",2) W !! D HDR1 W XPDUL,! +PNT2 S XPDI=0 F S XPDI=$O(@XPDGR@(4,XPDI)) Q:'XPDI S XPD=$G(^(XPDI,222)) Q:$$CHK(4,1) D + .;file number, file name, partial DD + .W !,XPDI,?12,$S('XPDFL:$P($G(^DIC(XPDI,0),"**unknown**"),U),1:$G(^XTMP("XPDI",XPDA,"FIA",XPDI))) + .W ?41,$$EXTERNAL^DILFD(9.64,222.1,"",$P(XPD,U)),?47,$$EXTERNAL^DILFD(9.64,222.2,"",$P(XPD,U,2)),?53,$$EXTERNAL^DILFD(9.64,222.7,"",$P(XPD,U,7)) + .W ?60,$E($$EXTERNAL^DILFD(9.64,222.8,"",$P(XPD,U,8)),1,4),?67,$$EXTERNAL^DILFD(9.64,222.5,"",$P(XPD,U,5)),?73,$$EXTERNAL^DILFD(9.64,222.9,"",$P(XPD,U,9)),! + .;print partial DD information + .I $P(XPD,U,3)="p" S J=0 D + ..W "Partial DD:" + ..F S J=$O(@XPDGR@(4,"APDD",XPDI,J)) Q:'J W ?12,"subDD: ",J D Q:$$CHK(4,1) + ...I '$O(@XPDGR@(4,"APDD",XPDI,J,0)) W ! Q + ...S I=0 F S I=$O(@XPDGR@(4,"APDD",XPDI,J,I)) Q:'I W ?30,"fld: ",I,! + .I $D(@XPDGR@(4,XPDI,223)) W ?2,"DD SCREEN : ",^(223),! + .I $D(@XPDGR@(4,XPDI,224)) W ?2,"DATA SCREEN: ",^(224),! +COMP Q:$D(DIRUT) W ! Q:$$CHK(3) S I=0,XPD=$P(^DD(9.68,.03,0),U,3) + ;print build components + F S I=$O(@XPDGR@("KRN",I)),K=0,J="" Q:$D(DIRUT)!'I F S J=$O(@XPDGR@("KRN",I,"NM","B",J)) Q:J="" S X=$O(^(J,0)) Q:$$CHK(4) D:X + .S X=$G(@XPDGR@("KRN",I,"NM",X,0)) Q:X="" + .;K is flag to write type of component + .I 'K W !,$S($D(^DIC(I,0)):$P(^(0),U),XPDFL:$G(^XTMP("XPDI",XPDA,"FIA",I),"UNKNOWN"),1:"UNKNOWN")_":",! S K=1 + .;write the entry name and write the action + .W ?3,$P(X,U),?50,$P($P(XPD,";",$P(X,U,3)+1),":",2),! + Q:XPDFL=2 + ;XPDFL=2 this is a Packman message, called from XMP2 - Summarize + ;XPDFL=1 this is a Install, the call backs are already Build Components + Q:$D(DIRUT) Q:$$CHK(3) + I $O(@XPDGR@("QUES",0))!($D(@XPDGR@("QDEF"))#2) W !,"INSTALL QUESTIONS: " S I=0 D + .F S I=$O(@XPDGR@("QUES",I)) Q:'I S X=$P(^(I,0),U),J=$G(^(1)),K=$G(^("A")) Q:$$CHK(5) D + ..W !?5,"SUBSCRIPT: ",X,!,"DIR(0)=",J W:K]"" !,"DIR(""A"")=",K,! + ..F J=1:1 Q:'$D(@XPDGR@("QUES",I,"A1",J,0)) W "DIR(""A"",",J,")=",^(0),! + ..I $G(@XPDGR@("QUES",I,"B"))]"" W "DIR(""B"")=",^("B"),! + ..I $G(@XPDGR@("QUES",I,"Q"))]"" W "DIR(""?"")=",^("Q"),! + ..F J=1:1 Q:'$D(@XPDGR@("QUES",I,"Q1",J,0)) W "DIR(""?"",",J,")=",^(0),! + ..I $G(@XPDGR@("QUES",I,"QQ"))]"" W "DIR(""??"")=",^("QQ"),! + ..I $G(@XPDGR@("QUES",I,"M"))]"" W "M CODE: ",^("M"),! + . Q:$D(DIRUT) Q:$$CHK(3) + . ;Show new Defaults for KIDS questions. p463 + . I $D(@XPDGR@("QDEF"))#2 S X=$G(@XPDGR@("QDEF")) D + . . W:$X>1 ! + . . I $L($P(X,U,9)) W " Default Rebuild Menu Trees Upon Completion of Install: ",$P(X,U,9),! + . . I $L($P(X,U,5)) W " Default INHIBIT LOGONs during the install: ",$P(X,U,5),! + . . I $L($P(X,U,11)) W " Default DISABLE Scheduled Options, Menu Options, and Protocols: ",$P(X,U,11) + . . Q + . Q + Q:$D(DIRUT) Q:$$CHK(3) + I $L($G(@XPDGR@("ABPKG"))) S XPD=^("ABPKG") D:$P(XPD,U)="y" + .W !,"ALPHA/BETA TESTING:",$$EXTERNAL^DILFD(9.6,20,"",$P(XPD,U)),?40,"INSTALLATION MESSAGE: ",$$EXTERNAL^DILFD(9.6,21,"",$P(XPD,U,2)) + .W !,"ADDRESS: ",$P(XPD,U,3),!!,"INCLUDE NAMESPACE",?30,"EXCLUDE NAMESPACE" S I=0 + .F S I=$O(@XPDGR@("ABNS",I)),J=0 Q:'I W !?5,^(I,0) F S J=$O(@XPDGR@("ABNS",I,1,J)) Q:'J W ?35,^(J,0),! Q:$$CHK(3) +REQB Q:$D(DIRUT) Q:$$CHK(4) + I $O(@XPDGR@("REQB",0)) W !,"REQUIRED BUILDS:",?50,"ACTION:" D + .S XPDI=0 F S XPDI=$O(@XPDGR@("REQB",XPDI)) Q:'XPDI S XPD=$G(^(XPDI,0)) Q:$$CHK(4,1) D + ..W !?3,$P(XPD,U),?50,$$EXTERNAL^DILFD(9.611,1,"",$P(XPD,U,2)) + Q +GLOBAL ;globals listing + S I=$$CHK(8,1) Q:I I '$P(I,"^",2) W !!,"GLOBAL:",?20,"KILL GLOBAL BEFORE INSTALL:" + S XPDI=0 F S XPDI=$O(@XPDGR@("GLO",XPDI)) Q:'XPDI S XPD=$G(^(XPDI,0)) Q:$$CHK(4,1) D + .W !?3,$P(XPD,U),?33,$$EXTERNAL^DILFD(9.65,1,"",$P(XPD,U,2)) + W ! Q + ; +MULT ;multiple-package + S I=$$CHK(10,1) Q:I I '$P(I,"^",2) W !,"SEQUENCE OF BUILDS:" + S XPDI=0 F S XPDI=$O(@XPDGR@(10,XPDI)) Q:'XPDI S XPD=$G(^(XPDI,0)) Q:$$CHK(4,1) D + .W !?2,XPDI,?8,$E($P(XPD,U),1,44),?54,$S($P(XPD,U,2)=1:"",1:"Not ")_"Required to Continue" + W ! Q + ; + ;return 0 if header was not written, else "0^1" +CHK(Y,XPD) ;Y=excess lines XPD=1 print file header, return 1 to exit + Q:$Y<(IOSL-Y) 0 + I $E(IOST,1,2)="C-" D Q:'Y 1 + .N DIR,I,J,K,X + .S DIR(0)="E" D ^DIR + S XPD=$G(XPD),XPDPG=XPDPG+1 + W @IOF D HDR,HDR1:XPD + W XPDUL,! + Q "0^1" + ; +XMP2(X,D0) ;called from ^XMP2 + N XPDA S XPDA=-1 + D PNT(X) Q + ; +HDR W !,"PACKAGE: ",$P(XPD0,U)," ",XPDDT,?70,"PAGE ",XPDPG,! + Q +HDR1 W ?41,"UP",?47,"SEND",?53,"DATA",?73,"USER",!,?41,"DATE",?47,"SEC.",?53,"COMES",?60,"SITE",?67,"RSLV",?73,"OVER" + W !,"FILE #",?12,"NAME",?41,"DD",?47,"CODE",?53,"W/FILE",?60,"DATA",?67,"PTS",?73,"RIDE",! + Q diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDIA3.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDIA3.m index b0e12dee..941e0b63 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDIA3.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDIA3.m @@ -1,90 +1,84 @@ -XPDIA3 ;SFISC/RWF - Install Pre/Post Actions for Kernel files cont. ;6/22/06 09:13 - ;;8.0;KERNEL;**201,302,393,498**;Jul 10, 1995;Build 13 - ;Per VHA Directive 2004-038, this routine should not be modified. - Q - ;^XTMP("XPDI",,XPDA,"KRN",XPDFILE,OLDA) is the global root - ;XPDNM=package name, XPDA=ien in ^XPD(9.6, - ;DA=ien in file, OLDA= ien in ^XTMP - ; -PAR0F2 ;PARAMETER file 8989.5: post. This is a fake entry called from the post of file 8989.51 - ;Now load any entries from 8989.5 - N XP1,XP2,XP3,DIK,OLDA,DA,ERR,PN,PE,PT,ROOT - S XP1=$O(^XTMP("XPDI",XPDA,"PKG",0)) ;Get the package - Q:'XP1 S PN=$G(^XTMP("XPDI",XPDA,"PKG",XP1,0)) - S PE=$$FIND1^DIC(9.4,,"MX",$P(PN,U,2)) ;Get the IEN of the package - S OLDA=0,ROOT=$NA(^XTMP("XPDI",XPDA,"KRN",8989.5)) - F S OLDA=$O(@ROOT@(OLDA)) Q:'OLDA D - . S XP1=@ROOT@(OLDA,0) - . S $P(XP1,U,1)=PE_";DIC(9.4," ;entity - . S $P(XP1,U,2)=$$LK^XPDIA($NA(^XTV(8989.51)),$P(XP1,U,2)) - . S DA=$$LKPAR($P(XP1,U),$P(XP1,U,2),$P(XP1,U,3)) - . ;Remove the current entry if we have one - . I DA>0 S DIK="^XTV(8989.5," D ^DIK - . ;Otherwise Add the zero node, See that we have a IEN - . I DA'>0 D ADDPAR($P(XP1,U),$P(XP1,U,2),$P(XP1,U,3)) S DA=$$LKPAR($P(XP1,U),$P(XP1,U,2),$P(XP1,U,3)) - . Q:'DA ;don't have a entry - . ;Merge the date ;with IHS fix - . M ^XTV(8989.5,DA)=^XTMP("XPDI",XPDA,"KRN",8989.5,OLDA) - . S ^XTV(8989.5,DA,0)=XP1 ;zero node with new pointers - . ;Get Definition and check if Data Type is pointer, then get pointed to global ref. - . S PT=$G(^XTV(8989.51,+$P(XP1,U,2),1)) D:$P(PT,U)="P" - . . S XP3=$G(^XTV(8989.5,DA,1)),PT=$P(PT,U,2) - . . S:PT $P(XP3,U)=$$FIND1^DIC(PT,"","X",$P(XP3,U)) ;resolve pointer value - . . S:$P(XP3,U) ^XTV(8989.5,DA,1)=XP3 - . ;X-ref it - . S DIK="^XTV(8989.5," D IX1^DIK - Q - ; -LKPAR(ENT,PAR,INST) ;Lookup an entry - Q $O(^XTV(8989.5,"AC",PAR,ENT,INST,0)) - ; -ADDPAR(ENT,PAR,INST) ;Add a parameter instance - N FDA,FDAIEN,DIERR - S FDA(8989.5,"+1,",.01)=ENT - S FDA(8989.5,"+1,",.02)=PAR - S FDA(8989.5,"+1,",.03)=INST - D UPDATE^DIE("","FDA","FDAIEN","DIERR") - Q - ; -PAR1F1 ;PARAMETER File 8989.51: file Pre - Q -PAR1E1 ;PARAMETER file 8989.51: entry pre - N XP1,XP2,XP3 - S ^TMP($J,"XPD",DA)="" - ;if there is a new Description, kill the old Description - K:$O(^XTMP("XPDI",XPDA,"KRN",8989.51,OLDA,20,0)) ^XTV(8989.51,DA,20) - ;Kill any old Allowable entries - K:$O(^XTMP("XPDI",XPDA,"KRN",8989.51,OLDA,30,0)) ^XTV(8989.51,DA,30) - Q -PAR1F2 ;PARAMETER file 8989.51: file post - N XPD,DIK,DA - S DA=0 - F S DA=$O(^TMP($J,"XPD",DA)) Q:'DA D - . S DIK="^XTV(8989.51," D IX1^DIK - D PAR0F2 ;Go load the entries from 8989.5 - Q -PAR1DEL(RT) ;Delete Parameter Def entries - D DELPTR^XPDUTL1(8989.51,RT) ;Cleanup pointers - D DELIEN^XPDUTL1(8989.51,RT) ;Cleanup entries - Q - ; -PAR2F1 ;PARAMETER File 8989.52: file Pre - K ^TMP($J,"XPD") - Q -PAR2E1 ;PARAMETER file 8989.52: entry Pre - N XP1,XP2,ROOT - S ROOT=$NA(^XTMP("XPDI",XPDA,"KRN",8989.52)) - S XP2=$P(@ROOT@(OLDA,0),U,4) ;Use instance of - ;Because we change the transport global see that a restart will work - I $L(XP2),XP2?1A.E S $P(@ROOT@(OLDA,0),U,4)=$$LK^XPDIA($NA(^XTV(8989.51)),XP2) - S XP1=0 - F S XP1=$O(@ROOT@(OLDA,10,XP1)),XP2="" Q:'XP1 D - . S XP2=$P(@ROOT@(OLDA,10,XP1,0),U,2) ;Parameter - . I $L(XP2),XP2?1A.E S $P(@ROOT@(OLDA,10,XP1,0),U,2)=$$LK^XPDIA($NA(^XTV(8989.51)),XP2) - . Q - Q -PAR2F2 ;PARAMETER file 8989.52: file Post - Q -PAR2DEL(RT) ;Delete Parameter Templates - D DELIEN^XPDUTL1(8989.52,RT) - Q +XPDIA3 ;SFISC/RWF - Install Pre/Post Actions for Kernel files cont. ;6/22/06 09:13 + ;;8.0;KERNEL;**201,302,393**;Jul 10, 1995;Build 12 + Q + ;^XTMP("XPDI",,XPDA,"KRN",XPDFILE,OLDA) is the global root + ;XPDNM=package name, XPDA=ien in ^XPD(9.6, + ;DA=ien in file, OLDA= ien in ^XTMP + ; +PAR0F2 ;PARAMETER file 8989.5: post. This is a fake entry called from the post of file 8989.51 + ;Now load any entries from 8989.5 + N XP1,XP2,DIK,OLDA,DA,ERR,PN,PE,ROOT + S XP1=$O(^XTMP("XPDI",XPDA,"PKG",0)) ;Get the package + Q:'XP1 S PN=$G(^XTMP("XPDI",XPDA,"PKG",XP1,0)) + S PE=$$FIND1^DIC(9.4,,"MX",$P(PN,U,2)) ;Get the IEN of the package + S OLDA=0,ROOT=$NA(^XTMP("XPDI",XPDA,"KRN",8989.5)) + F S OLDA=$O(@ROOT@(OLDA)) Q:'OLDA D + . S XP1=@ROOT@(OLDA,0) + . S $P(XP1,U,1)=PE_";DIC(9.4," ;entity + . S $P(XP1,U,2)=$$LK^XPDIA($NA(^XTV(8989.51)),$P(XP1,U,2)) + . S DA=$$LKPAR($P(XP1,U),$P(XP1,U,2),$P(XP1,U,3)) + . ;Remove the current entry if we have one + . I DA>0 S DIK="^XTV(8989.5," D ^DIK + . ;Otherwise Add the zero node, See that we have a IEN + . I DA'>0 D ADDPAR($P(XP1,U),$P(XP1,U,2),$P(XP1,U,3)) S DA=$$LKPAR($P(XP1,U),$P(XP1,U,2),$P(XP1,U,3)) + . Q:'DA ;don't have a entry + . ;Merge the date ;with IHS fix + . M ^XTV(8989.5,DA)=^XTMP("XPDI",XPDA,"KRN",8989.5,OLDA) + . S ^XTV(8989.5,DA,0)=XP1 ;zero node with new pointers + . ;X-ref it + . S DIK="^XTV(8989.5," D IX1^DIK + Q + ; +LKPAR(ENT,PAR,INST) ;Lookup an entry + Q $O(^XTV(8989.5,"AC",PAR,ENT,INST,0)) + ; +ADDPAR(ENT,PAR,INST) ;Add a parameter instance + N FDA,FDAIEN,DIERR + S FDA(8989.5,"+1,",.01)=ENT + S FDA(8989.5,"+1,",.02)=PAR + S FDA(8989.5,"+1,",.03)=INST + D UPDATE^DIE("","FDA","FDAIEN","DIERR") + Q + ; +PAR1F1 ;PARAMETER File 8989.51: file Pre + Q +PAR1E1 ;PARAMETER file 8989.51: entry pre + N XP1,XP2,XP3 + S ^TMP($J,"XPD",DA)="" + ;if there is a new Description, kill the old Description + K:$O(^XTMP("XPDI",XPDA,"KRN",8989.51,OLDA,20,0)) ^XTV(8989.51,DA,20) + ;Kill any old Allowable entries + K:$O(^XTMP("XPDI",XPDA,"KRN",8989.51,OLDA,30,0)) ^XTV(8989.51,DA,30) + Q +PAR1F2 ;PARAMETER file 8989.51: file post + N XPD,DIK,DA + S DA=0 + F S DA=$O(^TMP($J,"XPD",DA)) Q:'DA D + . S DIK="^XTV(8989.51," D IX1^DIK + D PAR0F2 ;Go load the entries from 8989.5 + Q +PAR1DEL(RT) ;Delete Parameter Def entries + D DELPTR^XPDUTL1(8989.51,RT) ;Cleanup pointers + D DELIEN^XPDUTL1(8989.51,RT) ;Cleanup entries + Q + ; +PAR2F1 ;PARAMETER File 8989.52: file Pre + K ^TMP($J,"XPD") + Q +PAR2E1 ;PARAMETER file 8989.52: entry Pre + N XP1,XP2,ROOT + S ROOT=$NA(^XTMP("XPDI",XPDA,"KRN",8989.52)) + S XP2=$P(@ROOT@(OLDA,0),U,4) ;Use instance of + ;Because we change the transport global see that a restart will work + I $L(XP2),XP2?1A.E S $P(@ROOT@(OLDA,0),U,4)=$$LK^XPDIA($NA(^XTV(8989.51)),XP2) + S XP1=0 + F S XP1=$O(@ROOT@(OLDA,10,XP1)),XP2="" Q:'XP1 D + . S XP2=$P(@ROOT@(OLDA,10,XP1,0),U,2) ;Parameter + . I $L(XP2),XP2?1A.E S $P(@ROOT@(OLDA,10,XP1,0),U,2)=$$LK^XPDIA($NA(^XTV(8989.51)),XP2) + . Q + Q +PAR2F2 ;PARAMETER file 8989.52: file Post + Q +PAR2DEL(RT) ;Delete Parameter Templates + D DELIEN^XPDUTL1(8989.52,RT) + Q diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDIST.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDIST.m index fb90a9f8..51dd963f 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDIST.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDIST.m @@ -1,91 +1,91 @@ -XPDIST ;SFISC/RSD - site tracking; 06/01/2006 ;03/05/2008 - ;;8.0;KERNEL;**66,108,185,233,350,393,486**;Jul 10, 1995;Build 5 - ; Per VHA Directive 2004-038, this routine should not be modified. - ;Returns ""=failed, XMZ=sent - ;D0=ien in file 9.7, XPY=national site tracking^address(optional) -EN(D0,XPY) ;send message - N %,DIFROM,XPD,XPD0,XPD1,XPD2,XPDV,XPZ,X,X1,Z,Y,XPD6,XPDTRACK - ;Get data needed - I '$D(^XPD(9.7,$G(D0),0)) D BMES^XPDUTL(" INSTALL file entry missing") Q "" - ;p350 -add node 6 for the Test# and Seq#. -REM - S XPD0=^XPD(9.7,D0,0),XPD1=$G(^(1)),XPD2=$G(^(2)),XPD6=$G(^(6)) - I '$P(XPD0,U,2) D BMES^XPDUTL(" No link to PACKAGE file") Q "" - S XPD=$P($G(^DIC(9.4,+$P(XPD0,U,2),0)),U),XPDV=$$VER^XPDUTL($P(XPD0,U)) - I XPD="" D BMES^XPDUTL(" PACKAGE file entry missing") Q "" - ;XPZ(1)=start, XPZ(2)=completion date/time, XPZ(3)=run time - S XPZ(1)=$P(XPD1,U),XPZ(2)=$P(XPD1,U,3),XPZ(3)=$$FMDIFF^XLFDT(XPZ(2),XPZ(1),3),XPZ(1)=$$FMTE^XLFDT(XPZ(1)),XPZ(2)=$$FMTE^XLFDT(XPZ(2)) - D LOCAL - S XPDTRACK=$$TRACK - D REMEDY ;p350 -REM - Q $$FORUM() -LOCAL ;Send a message to local mail group - N XMY,XPDTEXT,XMTEXT,XMDUZ,XMSUB,XMZ - K ^TMP($J) - S X=$$MAILGRP^XPDUTL(XPD) Q:X="" - S XMY(X)="" D GETENV^%ZOSV - ;Message for users - S XPDTEXT(1,0)="PACKAGE INSTALL" - S XPDTEXT(2,0)="SITE: "_$G(^XMB("NETNAME")) - S XPDTEXT(3,0)="PACKAGE: "_XPD - S XPDTEXT(4,0)="VERSION: "_XPDV - S XPDTEXT(5,0)="Start time: "_XPZ(1) - S XPDTEXT(6,0)="Completion time: "_XPZ(2) - S XPDTEXT(7,0)="Environment: "_Y - S XPDTEXT(8,0)="Installed by: "_$P($G(^VA(200,+$P(XPD0,U,11),0)),U) - S XPDTEXT(9,0)="Install Name: "_$P(XPD0,U) - S XPDTEXT(10,0)="Distribution Date: "_$$FMTE^XLFDT($P(XPD1,U,4)) - S XMDUZ=$S($P(XPD0,U,11):+$P(XPD0,U,11),1:.5),XMTEXT="XPDTEXT(",XMSUB=$P(XPD0,U)_" INSTALLATION" - D ^XMD - Q -TRACK() ; Should VA track the installation of this patch at a national level? - Q:$G(XPY)="" 0 ; No - National site tracking was not requested - ;Quit if not VA production primary domain - I $G(^XMB("NETNAME"))'[".VA.GOV" D BMES^XPDUTL(" Not a VA primary domain") Q 0 - ;X ^%ZOSF("UCI") S %=^%ZOSF("PROD") - ;S:%'["," Y=$P(Y,",") - ;I Y'=% D BMES^XPDUTL(" Not a production UCI") Q "" - ; 486/GMB Replaced the above 3 lines with the following line: - I '$$PROD^XUPROD D BMES^XPDUTL(" Not a production UCI") Q 0 - Q 1 -REMEDY ;Send to Remedy Server - ESSRESOURCE@MED.VA.GOV *p350 -REM - Q:'XPDTRACK - N XMY,XPDTEXT,XMTEXT,XMDUZ,XMSUB,XMZ - K ^TMP($J) - S:XPY XMY("ESSRESOURCE@MED.VA.GOV")="" - S:$L($P(XPY,U,2)) XMY($P(XPY,U,2))="" - ;Message for server (all in one string) - ;XMTEXT=Type(1),Domain(2-65),Pkg(66-95),Version(96-125), - ; StartTime(126-147),CompleteTime(148-169),RunTime(170-177), - ; Date(178-199),InstalledBy(200-229),InstallName(230-259), - ; DistributionDate(260-281),Seq#(282-286), - ; PatchTestVersion(287-317) - ; - S X1=1_$G(^XMB("NETNAME")) ;Type is always "1"(1=patch,0=pkg). - S $E(X1,66,95)=XPD,$E(X1,96,125)=XPDV,$E(X1,126,147)=XPZ(1),$E(X1,148,169)=XPZ(2),$E(X1,170,177)=XPZ(3),$E(X1,178,199)=DT - S $E(X1,200,229)=$P($G(^VA(200,+$P(XPD0,U,11),0)),U),$E(X1,230,259)=$P(XPD0,U),$E(X1,260,281)=$P(XPD1,U,4),$E(X1,282,286)=$P(XPD6,U,2),$E(X1,287,317)=$P(XPD6,U) - S XPDTEXT(1,0)=X1 - S XMDUZ=$S($P(XPD0,U,11):+$P(XPD0,U,11),1:.5),XMTEXT="XPDTEXT(",XMSUB="KIDS-"_$P(XPD0,U)_" INSTALLATION" - D ^XMD - Q -FORUM() ;send to Server on FORUM - Q:'XPDTRACK "" - N XMY,XPDTEXT,XMTEXT,XMDUZ,XMSUB,XMZ - K ^TMP($J) - S:XPY XMY("S.A5CSTS@FORUM.VA.GOV")="" - S:$L($P(XPY,U,2)) XMY($P(XPY,U,2))="" - ;Message for server - S XPDTEXT(1,0)="PACKAGE INSTALL" - S XPDTEXT(2,0)="SITE: "_$G(^XMB("NETNAME")) - S XPDTEXT(3,0)="PACKAGE: "_XPD - S XPDTEXT(4,0)="VERSION: "_XPDV - S XPDTEXT(5,0)="Start time: "_XPZ(1) - S XPDTEXT(6,0)="Completion time: "_XPZ(2) - S XPDTEXT(7,0)="Run time: "_XPZ(3) - S XPDTEXT(8,0)="DATE: "_DT - S XPDTEXT(9,0)="Installed by: "_$P($G(^VA(200,+$P(XPD0,U,11),0)),U) - S XPDTEXT(10,0)="Install Name: "_$P(XPD0,U) - S XPDTEXT(11,0)="Distribution Date: "_$P(XPD1,U,4) - S XPDTEXT(12,0)=XPD2 - S XMDUZ=$S($P(XPD0,U,11):+$P(XPD0,U,11),1:.5),XMTEXT="XPDTEXT(",XMSUB=$P(XPD0,U)_" INSTALLATION" - D ^XMD - Q "#"_$G(XMZ) +XPDIST ;SFISC/RSD - site tracking; 06/01/2006 + ;;8.0;KERNEL;**66,108,185,233,350,393**;Jul 10, 1995;Build 12 + ;Returns ""=failed, XMZ=sent + ;D0=ien in file 9.7, XPY=national site tracking^address(optional) +EN(D0,XPY) ;send message + N %,DIFROM,XPD,XPD0,XPD1,XPD2,XPDV,XPDTEXT,XPZ,XMDUZ,XMSUB,XMTEXT,XMY,XMZ,X,X1,Z,Y,XPD6 + ;Get data needed + I '$D(^XPD(9.7,$G(D0),0)) D BMES^XPDUTL(" INSTALL file entry missing") Q "" + ;p350 -add node 6 for the Test# and Seq#. -REM + S XPD0=^XPD(9.7,D0,0),XPD1=$G(^(1)),XPD2=$G(^(2)),XPD6=$G(^(6)) + I '$P(XPD0,U,2) D BMES^XPDUTL(" No link to PACKAGE file") Q "" + S XPD=$P($G(^DIC(9.4,+$P(XPD0,U,2),0)),U),XPDV=$$VER^XPDUTL($P(XPD0,U)) + I XPD="" D BMES^XPDUTL(" PACKAGE file entry missing") Q "" + ;XPZ(1)=start, XPZ(2)=completion date/time, XPZ(3)=run time + S XPZ(1)=$P(XPD1,U),XPZ(2)=$P(XPD1,U,3),XPZ(3)=$$FMDIFF^XLFDT(XPZ(2),XPZ(1),3),XPZ(1)=$$FMTE^XLFDT(XPZ(1)),XPZ(2)=$$FMTE^XLFDT(XPZ(2)) + D LOCAL + D REMEDY ;p350 -REM + Q $$FORUM() + ; + ; +FORUM() ;send to Server on FORUM + K XMY,XPDTEXT ;393 + Q:$G(XPY)="" "" + S:XPY XMY("S.A5CSTS@FORUM.VA.GOV")="" ;,XMY("ESSRESOURCE@MED.VA.GOV")="" + S:$L($P(XPY,U,2)) XMY($P(XPY,U,2))="" + K ^TMP($J) + ;Quit if not VA production primary domain + I $G(^XMB("NETNAME"))'[".VA.GOV" D BMES^XPDUTL(" Not a VA primary domain") Q "" + X ^%ZOSF("UCI") S %=^%ZOSF("PROD") + S:%'["," Y=$P(Y,",") + I Y'=% D BMES^XPDUTL(" Not a production UCI") Q "" + ;Message for server + S XPDTEXT(1,0)="PACKAGE INSTALL" + S XPDTEXT(2,0)="SITE: "_$G(^XMB("NETNAME")) + S XPDTEXT(3,0)="PACKAGE: "_XPD + S XPDTEXT(4,0)="VERSION: "_XPDV + S XPDTEXT(5,0)="Start time: "_XPZ(1) + S XPDTEXT(6,0)="Completion time: "_XPZ(2) + S XPDTEXT(7,0)="Run time: "_XPZ(3) + S XPDTEXT(8,0)="DATE: "_DT + S XPDTEXT(9,0)="Installed by: "_$P($G(^VA(200,+$P(XPD0,U,11),0)),U) + S XPDTEXT(10,0)="Install Name: "_$P(XPD0,U) + S XPDTEXT(11,0)="Distribution Date: "_$P(XPD1,U,4) + S XPDTEXT(12,0)=XPD2 + S XMDUZ=$S($P(XPD0,U,11):+$P(XPD0,U,11),1:.5),XMTEXT="XPDTEXT(",XMSUB=$P(XPD0,U)_" INSTALLATION" + D ^XMD + Q "#"_$G(XMZ) + ; +LOCAL ;Send a message to local mail group + K ^TMP($J),XMY,XPDTEXT,XMTEXT + S X=$$MAILGRP^XPDUTL(XPD) Q:X="" + S XMY(X)="" D GETENV^%ZOSV + ;Message for users + S XPDTEXT(1,0)="PACKAGE INSTALL" + S XPDTEXT(2,0)="SITE: "_$G(^XMB("NETNAME")) + S XPDTEXT(3,0)="PACKAGE: "_XPD + S XPDTEXT(4,0)="VERSION: "_XPDV + S XPDTEXT(5,0)="Start time: "_XPZ(1) + S XPDTEXT(6,0)="Completion time: "_XPZ(2) + S XPDTEXT(7,0)="Environment: "_Y + S XPDTEXT(8,0)="Installed by: "_$P($G(^VA(200,+$P(XPD0,U,11),0)),U) + S XPDTEXT(9,0)="Install Name: "_$P(XPD0,U) + S XPDTEXT(10,0)="Distribution Date: "_$$FMTE^XLFDT($P(XPD1,U,4)) + S XMDUZ=$S($P(XPD0,U,11):+$P(XPD0,U,11),1:.5),XMTEXT="XPDTEXT(",XMSUB=$P(XPD0,U)_" INSTALLATION" + D ^XMD + Q + ; +REMEDY ;Send to Remedy Server - ESSRESOURCE@MED.VA.GOV *p350 -REM + K ^TMP($J),XMY,XPDTEXT,XMTEXT ;393 + Q:$G(XPY)="" + S:XPY XMY("ESSRESOURCE@MED.VA.GOV")="" + S:$L($P(XPY,U,2)) XMY($P(XPY,U,2))="" + ;Quit if not VA production primary domain + I $G(^XMB("NETNAME"))'[".VA.GOV" D BMES^XPDUTL(" Not a VA primary domain") Q + X ^%ZOSF("UCI") S %=^%ZOSF("PROD") + S:%'["," Y=$P(Y,",") + I Y'=% D BMES^XPDUTL(" Not a production UCI") Q + ;Message for server (all in one string) + ;XMTEXT=Type(1),Domain(2-65),Pkg(66-95),Version(96-125), + ; StartTime(126-147),CompleteTime(148-169),RunTime(170-177), + ; Date(178-199),InstalledBy(200-229),InstallName(230-259), + ; DistributionDate(260-281),Seq#(282-286), + ; PatchTestVersion(287-317) + ; + S X1=1_$G(^XMB("NETNAME")) ;Type is always "1"(1=patch,0=pkg). + S $E(X1,66,95)=XPD,$E(X1,96,125)=XPDV,$E(X1,126,147)=XPZ(1),$E(X1,148,169)=XPZ(2),$E(X1,170,177)=XPZ(3),$E(X1,178,199)=DT + S $E(X1,200,229)=$P($G(^VA(200,+$P(XPD0,U,11),0)),U),$E(X1,230,259)=$P(XPD0,U),$E(X1,260,281)=$P(XPD1,U,4),$E(X1,282,286)=$P(XPD6,U,2),$E(X1,287,317)=$P(XPD6,U) + S XPDTEXT(1,0)=X1 + S XMDUZ=$S($P(XPD0,U,11):+$P(XPD0,U,11),1:.5),XMTEXT="XPDTEXT(",XMSUB="KIDS-"_$P(XPD0,U)_" INSTALLATION" + D ^XMD + Q diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDTA.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDTA.m index 21b2dc01..57bb1a59 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDTA.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDTA.m @@ -1,147 +1,135 @@ -XPDTA ;SFISC/RSD - Build Actions for Kernel Files ;02/14/2006 - ;;8.0;KERNEL;**15,44,58,131,229,393,498**;Jul 10, 1995;Build 13 - ;Per VHA Directive 2004-038, this routine should not be modified. - Q - ;^XTMP("XPDT",XPDA,"KRN",FILE,DA) is the global root - ;DA=ien in ^XTMP,XPDNM=package name, XPDA=package ien in ^XPD(9.6, -OPT ;options - N %,%1,%2 - ;if link, kill everything and just process the menu items - I XPDFL=2 D G OPTT - .S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",19,DA,%)) Q:'% K:%'=10 ^(%) - ;resolve Package (0;12), remove Creator (0;5) - S %=^XTMP("XPDT",XPDA,"KRN",19,DA,0),$P(%,U,12)=$$PT("^DIC(9.4)",$P(%,U,12)),$P(%,U,5)="" - ;resolve Help Frame (0;7), kill Permitted Devices (3.96;0) & queue node (200) - S $P(%,U,7)=$$PT("^DIC(9.2)",$P(%,U,7)),^XTMP("XPDT",XPDA,"KRN",19,DA,0)=% K ^(3.96),^(200) - ;resolve Server Bulletin (220;1), Server Mailgroup (220;3) - I $D(^XTMP("XPDT",XPDA,"KRN",19,DA,220)) S %=^(220),$P(%,U)=$$PT("^XMB(3.6)",+%),$P(%,U,3)=$$PT("^XMB(3.8)",$P(%,U,3)),^XTMP("XPDT",XPDA,"KRN",19,DA,220)=% - ;resolve RPC (RPC;0), must be type Broker - I $D(^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC")) K:$P(^(0),U,4)'="B" ^("RPC") D - .;kill "B"=name x-ref, it will be re-indexed when installed - .K ^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC","B") - .;loop thru RPCs and resolve (RPC;1) - .S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC",%)) Q:'% S %1=$G(^(%,0)) D - ..S %2=$$PT("^XWB(8994)",+%1) - ..;if can't resolve then delete - ..I %2="" K ^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC",%,0) Q - ..;save the RPC name - ..S $P(^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC",%,0),U)=%2 - .Q -OPTT ;Menus can only exist for options of type: menu,protocol,protocol menu, - ;extended action, limited, window suite - I "LMOQXZ"'[$P(^XTMP("XPDT",XPDA,"KRN",19,DA,0),U,4) K ^(10) Q - ;kill "B"=name, "C"=synonyms x-ref, it will be re-indexed when installed - K ^XTMP("XPDT",XPDA,"KRN",19,DA,10,"B"),^("C") - ;loop thru 10=Menus and resolve Menu (10;1), kill if it doesn't resolve - S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",19,DA,10,%)) Q:'% S %1=$G(^(%,0)) D - .S %2=$$PT("^DIC(19)",+%1) - .;items must be sent by themselves, check "B" x-ref - .I $L(%2),$D(^XPD(9.6,XPDA,"KRN",19,"NM","B",%2)) S ^XTMP("XPDT",XPDA,"KRN",19,DA,10,%,U)=%2 Q - .;if I couldn't resolve this option, then kill it - .K ^XTMP("XPDT",XPDA,"KRN",19,DA,10,%) - Q - ; -PRO ;protocols - N %,%1,%2 - ;if link, kill everything and just process the menu items - I XPDFL=2 D G PROT - .S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",101,DA,%)) Q:'% K:%'=10 ^(%) - ;resolve Package (0;12), remove Creator (0;5) - S %=^XTMP("XPDT",XPDA,"KRN",101,DA,0),$P(%,U,12)=$$PT("^DIC(9.4)",$P(%,U,12)),$P(%,U,5)="" - ;kill under Menus (10), "B"=name, "C"=synonyms - S ^XTMP("XPDT",XPDA,"KRN",101,DA,0)=% - ;resolve File Link (5;1), its a variable pointer - S %=$P($G(^XTMP("XPDT",XPDA,"KRN",101,DA,5)),U),%1=$P(%,";",2) - I %,$D(@("^"_%1_+%_",0)")) S $P(^XTMP("XPDT",XPDA,"KRN",101,DA,5),U)=$P(^(0),U)_";"_%1 - ;resolve HL7 fields, node 770 - S %=$G(^XTMP("XPDT",XPDA,"KRN",101,DA,770)) I $L(%) D S ^XTMP("XPDT",XPDA,"KRN",101,DA,770)=% - .S $P(%,U)=$$PT("^HL(771)",$P(%,U)),$P(%,U,2)=$$PT("^HL(771)",$P(%,U,2)) - .S $P(%,U,3)=$$PT("^HL(771.2)",$P(%,U,3)),$P(%,U,11)=$$PT("^HL(771.2)",$P(%,U,11)) - .S $P(%,U,4)=$$PT("^HL(779.001)",$P(%,U,4)),$P(%,U,7)=$$PT("^HLCS(870)",$P(%,U,7)) - .S $P(%,U,8)=$$PT("^HL(779.003)",$P(%,U,8)),$P(%,U,9)=$$PT("^HL(779.003)",$P(%,U,9)) - .S $P(%,U,10)=$$PT("^HL(771.5)",$P(%,U,10)) -PROT ;loop thru 10=Menus and resolve Menu (10;1), kill if it doesn't resolve - ;kill under Menus (10), "B"=name, "C"=synonyms - I $D(^XTMP("XPDT",XPDA,"KRN",101,DA,10,0)) K ^("B"),^("C") - S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",101,DA,10,%)) Q:'% S %1=$G(^(%,0)) D - .;%2=.01 of Menu(protocol) - .S %2=$$PT("^ORD(101)",+%1) - .;Menu must also be sent by itself, check "B" x-ref - .I $L(%2),$D(^XPD(9.6,XPDA,"KRN",101,"NM","B",%2)) S ^XTMP("XPDT",XPDA,"KRN",101,DA,10,%,U)=%2,$P(^XTMP("XPDT",XPDA,"KRN",101,DA,10,%,0),U,4)=$$PT("^ORD(101)",$P(%1,U,4)) Q - .K ^XTMP("XPDT",XPDA,"KRN",101,DA,10,%) - ;If type is Event Driver and sending Subscribers (775) - I $P(^XTMP("XPDT",XPDA,"KRN",101,DA,0),U,4)="E" D - . ;kill Menu multiple and Subscriber x-ref "B"=name - . K ^XTMP("XPDT",XPDA,"KRN",101,DA,10),^(775,"B") - . ;loop thru 775=Subscribers and resolve pointer (775;1) - . S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",101,DA,775,%)) Q:'% S %1=$G(^(%,0)) D - .. ;%2=.01 of subscriber(protocol) - .. S %2=$$PT("^ORD(101)",+%1) - .. ;protocol must also be sent by itself, check "B" x-ref - .. I $L(%2),$D(^XPD(9.6,XPDA,"KRN",101,"NM","B",%2)) S ^XTMP("XPDT",XPDA,"KRN",101,DA,775,%,U)=%2 Q - .. K ^XTMP("XPDT",XPDA,"KRN",101,DA,775,%) - ;quit if no Access multiple - Q:'$D(^XTMP("XPDT",XPDA,"KRN",101,DA,3,0)) K ^("B") - ;loop thru Access and resolve (3;1), kill if it doesn't resolve - S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",101,DA,3,%)) Q:'% S %1=$G(^(%,0)) D - .;%2=.01 of Menu(protocol) - .S %2=$$PT("^DIC(19.1)",+%1) - .I $L(%2) S ^XTMP("XPDT",XPDA,"KRN",101,DA,3,%,0)=%2 Q - .K ^XTMP("XPDT",XPDA,"KRN",101,DA,3,%) - Q - ; -RTNE ;routine entry build action - N %,X,XPD - ;move routine to ^XTMP("XPDT",DPK1,"RTN",routine name - ;routines will have the checksum in XTMP("XPDT",XPDA,"RTN",X) & in - ;Build file - S X=$P(^XTMP("XPDT",XPDA,"KRN",9.8,DA,0),U),XPD=^(-1) - Q:X="" S %=$$LOAD(X,XPD),$P(^XPD(9.6,XPDA,"KRN",9.8,"NM",+$P(XPD,U,2),0),U,4)=% - K ^XTMP("XPDT",XPDA,"KRN",9.8,DA) - Q - ; -RTNF ;routine file build action - N X,Y,% S Y=0 - ;the routines that are left in XTMP("XPDT",XPDA,"KRN",9.8) are to be - ;deleted at site, move name field to RTN node - F S Y=$O(^XTMP("XPDT",XPDA,"KRN",9.8,Y)) Q:'Y S %=^(Y,-1),X=^(0) D - .I +%=1 S ^XTMP("XPDT",XPDA,"RTN",X)=%,^("RTN")=$G(^XTMP("XPDT",XPDA,"RTN"))+1 - ;kill everything - K ^XTMP("XPDT",XPDA,"KRN",9.8) - Q - ; -PT(GR,DA) ;GR=file global ref, DA=ien, return .01 value - Q:'DA "" - Q:GR="" "" - I $D(@GR@(+DA,0))#2 Q $P(^(0),U) - Q "" - ; -GR(FN) ;returns closed global root, FN=file number - N Y - Q:'$G(FN) "" - S Y=$G(^DIC(FN,0,"GL")) Q:Y="" "" - Q $E(Y,1,($L(Y)-1))_$S($L(Y,",")>1:")",1:"") - ; -LOAD(X,XPD) ;load routine X, XPD=action^ien in Build file - ;XPD = 0-load, 1-delete, 2-skip, returns checksum - ;quit if routine is already saved - Q:$D(^XTMP("XPDT",XPDA,"RTN",X)) $P(^(X),U,3) - N DIF,XCNP,%N,%A,FDA,IEN,LN2 - S DIF="^XTMP(""XPDT"",XPDA,""RTN"",X,",XCNP=0 - X ^%ZOSF("LOAD") - S $P(^XTMP("XPDT",XPDA,"RTN",X,2,0),";",7)="Build "_(+^XPD(9.6,XPDA,6.3)),LN2=^XTMP("XPDT",XPDA,"RTN",X,2,0) - S IEN=$$FIND1^DIC(9.8,"","X",X) - ;^XTMP("XPDT",XPDA,"RTN",X)=action^ien in Build^checksum - S %N="B"_$$SUMB^XPDRSUM($NA(^XTMP("XPDT",XPDA,"RTN",X))) - S $P(XPD,"^",3)=%N ;Make sure the Checksum is in the 3rd piece - S ^XTMP("XPDT",XPDA,"RTN",X)=XPD - ;update count node - S ^("RTN")=$G(^XTMP("XPDT",XPDA,"RTN"))+1 - N XUA,XUB S (XUA,XUB)="" - ;Update Dev Patch field in Routine file - I IEN D - . S XUB=$P(XPDT(XPDT),U,2) S:XUB["*" $P(XUB,"*",2)=+$P(XUB,"*",2) - . S IEN="?+2,"_IEN_",",FDA(9.819,IEN,.01)=XUB - . S FDA(9.819,IEN,2)=%N,FDA(9.819,IEN,3)=$P(LN2,";",5) - . D UPDATE^DIE("","FDA","IEN") - Q %N +XPDTA ;SFISC/RSD - Build Actions for Kernel Files ;02/14/2006 + ;;8.0;KERNEL;**15,44,58,131,229,393**;Jul 10, 1995;Build 12 + Q + ;^XTMP("XPDT",XPDA,"KRN",FILE,DA) is the global root + ;DA=ien in ^XTMP,XPDNM=package name, XPDA=package ien in ^XPD(9.6, +OPT ;options + N %,%1,%2 + ;if link, kill everything and just process the menu items + I XPDFL=2 D G OPTT + .S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",19,DA,%)) Q:'% K:%'=10 ^(%) + ;resolve Package (0;12), remove Creator (0;5) + S %=^XTMP("XPDT",XPDA,"KRN",19,DA,0),$P(%,U,12)=$$PT("^DIC(9.4)",$P(%,U,12)),$P(%,U,5)="" + ;resolve Help Frame (0;7), kill Permitted Devices (3.96;0) & queue node (200) + S $P(%,U,7)=$$PT("^DIC(9.2)",$P(%,U,7)),^XTMP("XPDT",XPDA,"KRN",19,DA,0)=% K ^(3.96),^(200) + ;resolve Server Bulletin (220;1), Server Mailgroup (220;3) + I $D(^XTMP("XPDT",XPDA,"KRN",19,DA,220)) S %=^(220),$P(%,U)=$$PT("^XMB(3.6)",+%),$P(%,U,3)=$$PT("^XMB(3.8)",$P(%,U,3)),^XTMP("XPDT",XPDA,"KRN",19,DA,220)=% + ;resolve RPC (RPC;0), must be type Broker + I $D(^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC")) K:$P(^(0),U,4)'="B" ^("RPC") D + .;kill "B"=name x-ref, it will be re-indexed when installed + .K ^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC","B") + .;loop thru RPCs and resolve (RPC;1) + .S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC",%)) Q:'% S %1=$G(^(%,0)) D + ..S %2=$$PT("^XWB(8994)",+%1) + ..;if can't resolve then delete + ..I %2="" K ^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC",%,0) Q + ..;save the RPC name + ..S $P(^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC",%,0),U)=%2 + .Q +OPTT ;Menus can only exist for options of type: menu,protocol,protocol menu, + ;extended action, limited, window suite + I "LMOQXZ"'[$P(^XTMP("XPDT",XPDA,"KRN",19,DA,0),U,4) K ^(10) Q + ;kill "B"=name, "C"=synonyms x-ref, it will be re-indexed when installed + K ^XTMP("XPDT",XPDA,"KRN",19,DA,10,"B"),^("C") + ;loop thru 10=Menus and resolve Menu (10;1), kill if it doesn't resolve + S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",19,DA,10,%)) Q:'% S %1=$G(^(%,0)) D + .S %2=$$PT("^DIC(19)",+%1) + .;items must be sent by themselves, check "B" x-ref + .I $L(%2),$D(^XPD(9.6,XPDA,"KRN",19,"NM","B",%2)) S ^XTMP("XPDT",XPDA,"KRN",19,DA,10,%,U)=%2 Q + .;if I couldn't resolve this option, then kill it + .K ^XTMP("XPDT",XPDA,"KRN",19,DA,10,%) + Q +PRO ;protocols + N %,%1,%2 + ;if link, kill everything and just process the menu items + I XPDFL=2 D G PROT + .S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",101,DA,%)) Q:'% K:%'=10 ^(%) + ;resolve Package (0;12), remove Creator (0;5) + S %=^XTMP("XPDT",XPDA,"KRN",101,DA,0),$P(%,U,12)=$$PT("^DIC(9.4)",$P(%,U,12)),$P(%,U,5)="" + ;kill under Menus (10), "B"=name, "C"=synonyms + S ^XTMP("XPDT",XPDA,"KRN",101,DA,0)=% + ;resolve File Link (5;1), its a variable pointer + S %=$P($G(^XTMP("XPDT",XPDA,"KRN",101,DA,5)),U),%1=$P(%,";",2) + I %,$D(@("^"_%1_+%_",0)")) S $P(^XTMP("XPDT",XPDA,"KRN",101,DA,5),U)=$P(^(0),U)_";"_%1 + ;resolve HL7 fields, node 770 + S %=$G(^XTMP("XPDT",XPDA,"KRN",101,DA,770)) I $L(%) D S ^XTMP("XPDT",XPDA,"KRN",101,DA,770)=% + .S $P(%,U)=$$PT("^HL(771)",$P(%,U)),$P(%,U,2)=$$PT("^HL(771)",$P(%,U,2)) + .S $P(%,U,3)=$$PT("^HL(771.2)",$P(%,U,3)),$P(%,U,11)=$$PT("^HL(771.2)",$P(%,U,11)) + .S $P(%,U,4)=$$PT("^HL(779.001)",$P(%,U,4)),$P(%,U,7)=$$PT("^HLCS(870)",$P(%,U,7)) + .S $P(%,U,8)=$$PT("^HL(779.003)",$P(%,U,8)),$P(%,U,9)=$$PT("^HL(779.003)",$P(%,U,9)) + .S $P(%,U,10)=$$PT("^HL(771.5)",$P(%,U,10)) +PROT ;loop thru 10=Menus and resolve Menu (10;1), kill if it doesn't resolve + ;kill under Menus (10), "B"=name, "C"=synonyms + I $D(^XTMP("XPDT",XPDA,"KRN",101,DA,10,0)) K ^("B"),^("C") + S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",101,DA,10,%)) Q:'% S %1=$G(^(%,0)) D + .;%2=.01 of Menu(protocol) + .S %2=$$PT("^ORD(101)",+%1) + .;Menu must also be sent by itself, check "B" x-ref + .I $L(%2),$D(^XPD(9.6,XPDA,"KRN",101,"NM","B",%2)) S ^XTMP("XPDT",XPDA,"KRN",101,DA,10,%,U)=%2,$P(^XTMP("XPDT",XPDA,"KRN",101,DA,10,%,0),U,4)=$$PT("^ORD(101)",$P(%1,U,4)) Q + .K ^XTMP("XPDT",XPDA,"KRN",101,DA,10,%) + ;If type is Event Driver and sending Subscribers (775) + I $P(^XTMP("XPDT",XPDA,"KRN",101,DA,0),U,4)="E" D + . ;kill Menu multiple and Subscriber x-ref "B"=name + . K ^XTMP("XPDT",XPDA,"KRN",101,DA,10),^(775,"B") + . ;loop thru 775=Subscribers and resolve pointer (775;1) + . S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",101,DA,775,%)) Q:'% S %1=$G(^(%,0)) D + .. ;%2=.01 of subscriber(protocol) + .. S %2=$$PT("^ORD(101)",+%1) + .. ;protocol must also be sent by itself, check "B" x-ref + .. I $L(%2),$D(^XPD(9.6,XPDA,"KRN",101,"NM","B",%2)) S ^XTMP("XPDT",XPDA,"KRN",101,DA,775,%,U)=%2 Q + .. K ^XTMP("XPDT",XPDA,"KRN",101,DA,775,%) + ;quit if no Access multiple + Q:'$D(^XTMP("XPDT",XPDA,"KRN",101,DA,3,0)) K ^("B") + ;loop thru Access and resolve (3;1), kill if it doesn't resolve + S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",101,DA,3,%)) Q:'% S %1=$G(^(%,0)) D + .;%2=.01 of Menu(protocol) + .S %2=$$PT("^DIC(19.1)",+%1) + .I $L(%2) S ^XTMP("XPDT",XPDA,"KRN",101,DA,3,%,0)=%2 Q + .K ^XTMP("XPDT",XPDA,"KRN",101,DA,3,%) + Q +RTNE ;routine entry build action + N %,X,XPD + ;move routine to ^XTMP("XPDT",DPK1,"RTN",routine name + ;routines will have the checksum in XTMP("XPDT",XPDA,"RTN",X) & in + ;Build file + S X=$P(^XTMP("XPDT",XPDA,"KRN",9.8,DA,0),U),XPD=^(-1) + Q:X="" S %=$$LOAD(X,XPD),$P(^XPD(9.6,XPDA,"KRN",9.8,"NM",+$P(XPD,U,2),0),U,4)=% + K ^XTMP("XPDT",XPDA,"KRN",9.8,DA) + Q +RTNF ;routine file build action + N X,Y,% S Y=0 + ;the routines that are left in XTMP("XPDT",XPDA,"KRN",9.8) are to be + ;deleted at site, move name field to RTN node + F S Y=$O(^XTMP("XPDT",XPDA,"KRN",9.8,Y)) Q:'Y S %=^(Y,-1),X=^(0) D + .I +%=1 S ^XTMP("XPDT",XPDA,"RTN",X)=%,^("RTN")=$G(^XTMP("XPDT",XPDA,"RTN"))+1 + ;kill everything + K ^XTMP("XPDT",XPDA,"KRN",9.8) + Q +PT(GR,DA) ;GR=file global ref, DA=ien, return .01 value + Q:'DA "" + I $D(@GR@(+DA,0))#2 Q $P(^(0),U) + Q "" + ; +LOAD(X,XPD) ;load routine X, XPD=action^ien in Build file + ;XPD = 0-load, 1-delete, 2-skip, returns checksum + ;quit if routine is already saved + Q:$D(^XTMP("XPDT",XPDA,"RTN",X)) $P(^(X),U,3) + N DIF,XCNP,%N,%A,FDA,IEN,LN2 + S DIF="^XTMP(""XPDT"",XPDA,""RTN"",X,",XCNP=0 + X ^%ZOSF("LOAD") + S $P(^XTMP("XPDT",XPDA,"RTN",X,2,0),";",7)="Build "_(+^XPD(9.6,XPDA,6.3)),LN2=^XTMP("XPDT",XPDA,"RTN",X,2,0) + S IEN=$$FIND1^DIC(9.8,"","X",X) + ;^XTMP("XPDT",XPDA,"RTN",X)=action^ien in Build^checksum + S %N="B"_$$SUMB^XPDRSUM($NA(^XTMP("XPDT",XPDA,"RTN",X))) + S $P(XPD,"^",3)=%N ;Make sure the Checksum is in the 3rd piece + S ^XTMP("XPDT",XPDA,"RTN",X)=XPD + ;update count node + S ^("RTN")=$G(^XTMP("XPDT",XPDA,"RTN"))+1 + N XUA,XUB S (XUA,XUB)="" + ;Update Dev Patch field in Routine file + I IEN D + . S XUB=$P(XPDT(XPDT),U,2) S:XUB["*" $P(XUB,"*",2)=+$P(XUB,"*",2) + . S IEN="?+2,"_IEN_",",FDA(9.819,IEN,.01)=XUB + . S FDA(9.819,IEN,2)=%N,FDA(9.819,IEN,3)=$P(LN2,";",5) + . D UPDATE^DIE("","FDA","IEN") + Q %N diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDTA2.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDTA2.m index d6e5c8d2..44f734d4 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDTA2.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDTA2.m @@ -1,52 +1,48 @@ -XPDTA2 ;SFISC/RWF - Build Actions for Kernel Files Cont. ;08/09/2001 12:36 - ;;8.0;KERNEL;**201,498**;Jul 10, 1995;Build 13 - ;Per VHA Directive 2004-038, this routine should not be modified. - Q - ;^XTMP("XPDT",XPDA,"KRN",XPDFILE,DA) is the global root - ;DA=ien in ^XTMP,XPDNM=package name, XPDA=package ien in ^XPD(9.6, - ; -PAR1E1 ;PARAMETER file 8989.51: entry post - N XP,XP1,XP2,XP3,XP4,VP,PN,PT,ROOT - S ROOT=$NA(^XTMP("XPDT",XPDA,"KRN")) - D PAR51(DA) ;Handle the entry from 8989.51 - S PT=$S($E($G(^XTV(8989.51,DA,1)))="P":$P(^(1),U,2),1:"") ;Data Type & Value - check if pointer in for loop - S:PT]"" PT=$S(PT:$$GR^XPDTA(PT),1:"") ;PT=file # of pointed to file from parm def. - ;Now find any entrys in 8989.5 to transport, because we point to them - S XP=0,XP3=$P(^XPD(9.6,XPDA,0),U,2),VP=XP3_";DIC(9.4,",PN=$$PT^XPDTA("^DIC(9.4)",XP3) - Q:'XP3 ;No package file link - F S XP=$O(^XTV(8989.5,"AC",DA,VP,XP)),XP1=0 Q:'XP D ;Instance - . F S XP1=$O(^XTV(8989.5,"AC",DA,VP,XP,XP1)) Q:'XP1 D ;entry - . . M ^XTMP("XPDT",XPDA,"KRN",8989.5,XP1)=^XTV(8989.5,XP1) - . . S XP3=^XTV(8989.5,XP1,0),XP4=$G(^(1)) ;param def. - . . S $P(@ROOT@(8989.5,XP1,0),U,2)=$$PT^XPDTA("^XTV(8989.51)",$P(XP3,U,2)) - . . I PT]"",XP4>0 S $P(@ROOT@(8989.5,XP1,1),U)=$$PT^XPDTA(PT,XP4) ;Data Type pointer - resolve - . . Q ;Will redo the ENT at other end. - Q - ; -PAR51(DA) ;Fix one 8989.51 entry in transport global - ;Called from both PAR1E1 and PAR2E1 - N XP,XP1,XP2,XP3,VP,PN,ROOT - S ROOT=$NA(^XTMP("XPDT",XPDA,"KRN")) - ;Don't bring X-ref - K @ROOT@(8989.51,DA,30,"B"),^("AG") - S XP=0 - ;Entries in the file will be maintained by Toolkit patches. - Q - ; -PAR2E1 ;PARAMETER file 8989.52 entry post - N XP1,XP2,XP3,ROOT - S ROOT=$NA(^XTMP("XPDT",XPDA,"KRN")) - ;Resolve USE INSTANCE OF - S XP2=$P(^XTV(8989.52,DA,0),U,4),XP3="" I XP2 S XP3=$$PT^XPDTA($NA(^XTV(8989.51)),XP2) - I $L(XP3) S $P(@ROOT@(8989.52,DA,0),U,4)=XP3 - ;Resolve PARAMETERS - S XP1=0 K ^XTMP("XPDT",XPDA,"KRN",8989.52,DA,10,"B") ;Drop X-ref - F S XP1=$O(^XTV(8989.52,DA,10,XP1)),XP3="" Q:'XP1 D - . S XP2=$P(^XTV(8989.52,DA,10,XP1,0),U,2) - . I XP2 S XP3=$$PT^XPDTA($NA(^XTV(8989.51)),XP2) - . I '$L(XP3) K @ROOT@(8989.52,DA,10,XP1) - . S $P(^XTMP("XPDT",XPDA,"KRN",8989.52,DA,10,XP1,0),U,2)=XP3 - . ;Now to move the entries this points to. - . I '$D(@ROOT@(8989.51,XP2)) M @ROOT@(8989.51,XP2)=^XTV(8989.51,XP2) D PAR51(XP2) - . Q - Q +XPDTA2 ;SFISC/RWF - Build Actions for Kernel Files Cont. ;08/09/2001 12:36 + ;;8.0;KERNEL;**201**;Jul 10, 1995 + Q + ;^XTMP("XPDT",XPDA,"KRN",XPDFILE,DA) is the global root + ;DA=ien in ^XTMP,XPDNM=package name, XPDA=package ien in ^XPD(9.6, + ; +PAR1E1 ;PARAMETER file 8989.51: entry post + N XP,XP1,XP2,XP3,VP,PN,ROOT + S ROOT=$NA(^XTMP("XPDT",XPDA,"KRN")) + D PAR51(DA) ;Handle the entry from 8989.51 + ;Now find any entrys in 8989.5 to transport, because we point to them + S XP=0,XP3=$P(^XPD(9.6,XPDA,0),U,2),VP=XP3_";DIC(9.4,",PN=$$PT^XPDTA("^DIC(9.4)",XP3) + Q:'XP3 ;No package file link + F S XP=$O(^XTV(8989.5,"AC",DA,VP,XP)),XP1=0 Q:'XP D ;Instance + . F S XP1=$O(^XTV(8989.5,"AC",DA,VP,XP,XP1)) Q:'XP1 D ;entry + . . M ^XTMP("XPDT",XPDA,"KRN",8989.5,XP1)=^XTV(8989.5,XP1) + . . S XP3=^XTV(8989.5,XP1,0) ;param def. + . . S $P(@ROOT@(8989.5,XP1,0),U,2)=$$PT^XPDTA("^XTV(8989.51)",$P(XP3,U,2)) + . . Q ;Will redo the ENT at other end. + Q + ; +PAR51(DA) ;Fix one 8989.51 entry in transport global + ;Called from both PAR1E1 and PAR2E1 + N XP,XP1,XP2,XP3,VP,PN,ROOT + S ROOT=$NA(^XTMP("XPDT",XPDA,"KRN")) + ;Don't bring X-ref + K @ROOT@(8989.51,DA,30,"B"),^("AG") + S XP=0 + ;Entries in the file will be maintained by Toolkit patches. + Q + ; +PAR2E1 ;PARAMETER file 8989.52 entry post + N XP1,XP2,XP3,ROOT + S ROOT=$NA(^XTMP("XPDT",XPDA,"KRN")) + ;Resolve USE INSTANCE OF + S XP2=$P(^XTV(8989.52,DA,0),U,4),XP3="" I XP2 S XP3=$$PT^XPDTA($NA(^XTV(8989.51)),XP2) + I $L(XP3) S $P(@ROOT@(8989.52,DA,0),U,4)=XP3 + ;Resolve PARAMETERS + S XP1=0 K ^XTMP("XPDT",XPDA,"KRN",8989.52,DA,10,"B") ;Drop X-ref + F S XP1=$O(^XTV(8989.52,DA,10,XP1)),XP3="" Q:'XP1 D + . S XP2=$P(^XTV(8989.52,DA,10,XP1,0),U,2) + . I XP2 S XP3=$$PT^XPDTA($NA(^XTV(8989.51)),XP2) + . I '$L(XP3) K @ROOT@(8989.52,DA,10,XP1) + . S $P(^XTMP("XPDT",XPDA,"KRN",8989.52,DA,10,XP1,0),U,2)=XP3 + . ;Now to move the entries this points to. + . I '$D(@ROOT@(8989.51,XP2)) M @ROOT@(8989.51,XP2)=^XTV(8989.51,XP2) D PAR51(XP2) + . Q + Q diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQ3.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQ3.m index 21193c12..bcb9d61a 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQ3.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQ3.m @@ -1,108 +1,83 @@ -XQ3 ;LL/THM,SF/GJL,SEA/JLI - CLEANUP DANGLING POINTERS IN OPTION OR HELP FRAME FILES ;04/30/08 17:06 - ;;8.0;KERNEL;**80,501**;Jul 10, 1995;Build 1 - Q -ENASK ;Ask to fix up dirty OPTION/HELP FRAME File - N IX,XUT,J,K,XQFL,X - I '$D(%) W !,$C(7),"ENTRY MUST BE WITH THE VARIABLE '%' SET TO INDICATE DESIRED FILE.",$C(7),! Q - S XQFL=$S(%=1:"OPTION",%=2:"PROTOCOL",1:"HELP FRAME") - W !,"Do you want to remove any 'Dangling Pointers' from your ",XQFL," File? Y// " R X:$S($D(DTIME):DTIME,1:300) I '$T Q - W ! I X="" S X="Y" - I X["?" G SYNTAX - I X["^" S X="^" Q -STRIP I X'="",X'?1A.E S X=$E(X,2,256) G STRIP - S X=$E(X,1) I X="" G SYNTAX - I "Nn"[X S X="N" Q - I "Yy"[X W !,"PLEASE WAIT while I check this out . . . " G REMOVE -SYNTAX W ! I X'["?" W ?11,"I'm sorry, but I don't understand your answer. Please" - W !,"Enter: YES (or press the RETURN key) if you want me to remove from" - W !,?11,"your ",XQFL," File any pointers left over from incompletely" - W !,?11,"deleted ",XQFL,". If such pointers do exist and are not" - W !,?11,"removed, the ",XQFL," File (i.e. the menus) could become" - W !,?11,"messed up by an INIT." - W !!,"Enter: NO or ^ to continue on without effecting the ",XQFL," File." - W ! G ENASK -REMOVE D:%=1 OPFIX D:%=2 PFIX D:'% HFFIX W !,"Your ",XQFL," File is OK " I 'XUT W "(no bad pointers)." - E W "now (",XUT," pointer" W:XUT>1 "s" W " fixed)." - W ! S X="Y" - Q -OPFIX ;Kill any dangling pointers in the OPTION File (#19) - N %,IX,J,XQ3 - S (IX,XUT)=0 ;XUT=Total Deletions - F S IX=$O(^DIC(19,IX)) Q:'IX W:'(IX#100) ". " S (XQ3,J)=0 D L2 ;Loop through Options - D NPF - Q -L2 ;One Option - I '$D(^DIC(19,IX,10,0)) Q ;Not a Menu - K ^DIC(19,IX,10,"B") ;Rebuild "B" X-ref - F S J=$O(^DIC(19,IX,10,J)) Q:'J D ITEM ;Loop through menu items - S (K,J)=0 F S J=$O(^DIC(19,IX,10,J)) Q:J'>0 S K=J ;K=Last item - S J=^DIC(19,IX,10,0),^(0)=$P(J,"^",1,2)_"^"_K_"^"_XQ3 ;fix counters - Q - ; -ITEM ;One Menu item - N DA,DIK - S K=+^DIC(19,IX,10,J,0) - I $D(^DIC(19,K,0)) S XQ3=XQ3+1,^DIC(19,IX,10,"B",K,J)="" Q ;Y=No. of items - W !,"Option ",$P(^DIC(19,IX,0),U,1)," points to missing option ",K - ;S XUT=XUT+1 K ^DIC(19,IX,10,J) ;Kill invalid menu item - S XUT=XUT+1,DIK="^DIC(19,DA(1),10,",DA=J,DA(1)=IX D ^DIK ;Trigger Menu-rebuild - Q - ; -NPF ;Fix the New Person File Option Pointers - N IX,I2,J,P,DIK,DIE,DR,DA,XUT - S (XUT,IX)=0 - F S IX=$O(^VA(200,IX)) Q:'IX D - . S P=+$G(^VA(200,IX,201)) - . I P,'$D(^DIC(19,P,0)) D - . . W !,"User: ",$P(^VA(200,IX,0),U),", Primary Menu points to missing option ",P - . . S XUT=XUT+1,DIE="^VA(200,",DA=IX,DR="201///@" D ^DIE - . . Q - . S I2=0 - . F S I2=$O(^VA(200,IX,203,I2)) Q:'I2 D - . . S P=+$G(^VA(200,IX,203,I2,0)) - . . I P,'$D(^DIC(19,P,0)) D - . . . W !,"User: ",$P(^VA(200,IX,0),U),", Secondary Menu points to missing option ",P - . . . S XUT=XUT+1,DIK="^VA(200,DA(1),203,",DA=I2,DA(1)=IX D ^DIK - . . . Q - . . Q - . Q - I XUT W !,"Menu pointers fixed." - Q -HFFIX ; Fix dangling pointers on help frame file - N % - S (XUT,IX)=0 F S IX=$O(^DIC(9.2,IX)) Q:IX'>0 I $D(^(IX,2)) D HF1,HF2,HF3 - Q -HF1 S (Y,J)=0 F S J=$O(^DIC(9.2,IX,2,J)) Q:J'>0 I $D(^(J,0)) S K=$P(^(0),U,2),Y=Y+1 I $L(K),'$D(^DIC(9.2,K)) S Y=Y-1,XUT=XUT+1 K ^DIC(9.2,IX,2,J,0) - Q -HF2 S (K,J)=0 F S J=$O(^DIC(9.2,IX,2,J)) Q:J'>0 S K=J - S J=^DIC(9.2,IX,2,0),^(0)=$P(J,U,1,2)_U_K_U_Y - Q -HF3 S K=":" F S K=$O(^DIC(9.2,IX,2,K)) Q:K="" S J=-1 F S J=$O(^DIC(9.2,IX,2,K,J)) Q:J="" D HF4 - Q -HF4 S JJ=0 F S JJ=$O(^DIC(9.2,IX,2,K,J,JJ)) Q:JJ'>0 I '$D(^DIC(9.2,IX,2,JJ,0)) K ^DIC(9.2,IX,2,K,J,JJ) - Q -PFIX ;Kill any dangling pointers in the PROTOCOL File (#101) - N % - S (IX,XUT)=0 ;XUT=Total Deletions -P1 S IX=$O(^ORD(101,IX)) I IX>0 S (Y,J)=0 G P2 ;Loop through protocols - Q -P2 S J=$O(^ORD(101,IX,10,J)) I J>0 G PITEM ;Loop through items - I '$D(^ORD(101,IX,10,0)) G P1 - S (K,J)=0 F L=1:1 S J=$O(^ORD(101,IX,10,J)) Q:J'>0 S K=J ;K=Last item - S J=^ORD(101,IX,10,0),^(0)=$P(J,"^",1,2)_"^"_K_"^"_Y ;fix counters - G PXREFS -PITEM S K=+^ORD(101,IX,10,J,0) I $D(^ORD(101,K,0)) S Y=Y+1 G P2 ;Y=No. of items - W !,"Protocol ",$P(^ORD(101,IX,0),U,1)," points to missing protocol ",K - ;S XUT=XUT+1 K ^ORD(101,IX,10,J) ;Kill invalid menu item - S XUT=XUT+1,DIK="^ORD(101,IX,10,",DA=J,DA(1)=IX D ^DIK ;Delete invalid menu item - G P2 -PXREFS S K=":" -P3 S K=$O(^ORD(101,IX,10,K)) I K="" G P1 ;Loop through cross references - S L=-1 -P4 S L=$O(^ORD(101,IX,10,K,L)) I L="" G P3 - S J=0 -P5 S J=$O(^ORD(101,IX,10,K,L,J)) I J'>0 G P4 - I '$D(^ORD(101,IX,10,J,0)) G PKILLXR ;kill xref to invalid item -P6 S M=^ORD(101,IX,10,J,0) I (M=L)!(M[L_"^") G P5 -PKILLXR K ^ORD(101,IX,10,K,L,J) I $O(^ORD(101,IX,10,K,L,-1))="" K ^ORD(101,IX,10,K,L) - G P5 +XQ3 ;LL/THM,SF/GJL,SEA/JLI - CLEANUP DANGLING POINTERS IN OPTION OR HELP FRAME FILES ;04/21/98 13:20 + ;;8.0;KERNEL;**80**;Jul 10, 1995 + Q +ENASK ;Ask to fix up dirty OPTION/HELP FRAME File + I '$D(%) W !,$C(7),"ENTRY MUST BE WITH THE VARIABLE '%' SET TO INDICATE DESIRED FILE.",$C(7),! Q + S XQFL=$S(%=1:"OPTION",%=2:"PROTOCOL",1:"HELP FRAME") + W !,"Do you want to remove any 'Dangling Pointers' from your ",XQFL," File? Y// " R X:$S($D(DTIME):DTIME,1:300) I '$T Q + W ! I X="" S X="Y" + I X["?" G SYNTAX + I X["^" S X="^" Q +STRIP I X'="",X'?1A.E S X=$E(X,2,256) G STRIP + S X=$E(X,1) I X="" G SYNTAX + I "Nn"[X S X="N" Q + I "Yy"[X W !,"PLEASE WAIT while I check this out . . . " G REMOVE +SYNTAX W ! I X'["?" W ?11,"I'm sorry, but I don't understand your answer. Please" + W !,"Enter: YES (or press the RETURN key) if you want me to remove from" + W !,?11,"your ",XQFL," File any pointers left over from incompletely" + W !,?11,"deleted ",XQFL,". If such pointers do exist and are not" + W !,?11,"removed, the ",XQFL," File (i.e. the menus) could become" + W !,?11,"messed up by an INIT." + W !!,"Enter: NO or ^ to continue on without effecting the ",XQFL," File." + W ! G ENASK +REMOVE D:%=1 ENFIX D:%=2 PFIX D:'% HFFIX W !,"Your ",XQFL," File is OK " I 'X W "(no bad pointers)." + E W "now (",X," pointer" W:X>1 "s" W " fixed)." + W ! S X="Y" Q +ENFIX ;Kill any dangling pointers in the OPTION File (#19) + S (I,X)=0 ;X=Total Deletions +L1 S I=$O(^DIC(19,I)) I I>0 S (Y,J)=0 G L2 ;Loop through menus + Q +L2 S J=$O(^DIC(19,I,10,J)) I J>0 G ITEM ;Loop through menu items + I '$D(^DIC(19,I,10,0)) G L1 + S (K,J)=0 F L=1:1 S J=$O(^DIC(19,I,10,J)) Q:J'>0 S K=J ;K=Last item + S J=^DIC(19,I,10,0),^(0)=$P(J,"^",1,2)_"^"_K_"^"_Y ;fix counters + G XREFS +ITEM S K=+^DIC(19,I,10,J,0) I $D(^DIC(19,K,0)) S Y=Y+1 G L2 ;Y=No. of items + W !,"Option ",$P(^DIC(19,I,0),U,1)," points to missing option ",K + S X=X+1 K ^DIC(19,I,10,J) ;Kill invalid menu item + G L2 +XREFS S K=":" +L3 S K=$O(^DIC(19,I,10,K)) I K="" G L1 ;Loop through cross references + S L=-1 +L4 S L=$O(^DIC(19,I,10,K,L)) I L="" G L3 + S J=0 +L5 S J=$O(^DIC(19,I,10,K,L,J)) I J'>0 G L4 + I '$D(^DIC(19,I,10,J,0)) G KILLXR ;kill xref to invalid item +L6 S M=^DIC(19,I,10,J,0) I (M=L)!(M[L_"^") G L5 +KILLXR K ^DIC(19,I,10,K,L,J) I $O(^DIC(19,I,10,K,L,-1))="" K ^DIC(19,I,10,K,L) + G L5 +HFFIX ; Fix dangling pointers on help frame file + S (X,I)=0 F S I=$O(^DIC(9.2,I)) Q:I'>0 I $D(^(I,2)) D HF1,HF2,HF3 + Q +HF1 S (Y,J)=0 F S J=$O(^DIC(9.2,I,2,J)) Q:J'>0 I $D(^(J,0)) S K=$P(^(0),U,2),Y=Y+1 I $L(K),'$D(^DIC(9.2,K)) S Y=Y-1,X=X+1 K ^DIC(9.2,I,2,J,0) + Q +HF2 S (K,J)=0 F S J=$O(^DIC(9.2,I,2,J)) Q:J'>0 S K=J + S J=^DIC(9.2,I,2,0),^(0)=$P(J,U,1,2)_U_K_U_Y + Q +HF3 S K=":" F S K=$O(^DIC(9.2,I,2,K)) Q:K="" S J=-1 F S J=$O(^DIC(9.2,I,2,K,J)) Q:J="" D HF4 + Q +HF4 S JJ=0 F S JJ=$O(^DIC(9.2,I,2,K,J,JJ)) Q:JJ'>0 I '$D(^DIC(9.2,I,2,JJ,0)) K ^DIC(9.2,I,2,K,J,JJ) + Q +PFIX ;Kill any dangling pointers in the PROTOCOL File (#101) + S (I,X)=0 ;X=Total Deletions +P1 S I=$O(^ORD(101,I)) I I>0 S (Y,J)=0 G P2 ;Loop through protocols + Q +P2 S J=$O(^ORD(101,I,10,J)) I J>0 G PITEM ;Loop through items + I '$D(^ORD(101,I,10,0)) G P1 + S (K,J)=0 F L=1:1 S J=$O(^ORD(101,I,10,J)) Q:J'>0 S K=J ;K=Last item + S J=^ORD(101,I,10,0),^(0)=$P(J,"^",1,2)_"^"_K_"^"_Y ;fix counters + G PXREFS +PITEM S K=+^ORD(101,I,10,J,0) I $D(^ORD(101,K,0)) S Y=Y+1 G P2 ;Y=No. of items + W !,"Option ",$P(^ORD(101,I,0),U,1)," points to missing option ",K + S X=X+1 K ^ORD(101,I,10,J) ;Kill invalid menu item + G P2 +PXREFS S K=":" +P3 S K=$O(^ORD(101,I,10,K)) I K="" G P1 ;Loop through cross references + S L=-1 +P4 S L=$O(^ORD(101,I,10,K,L)) I L="" G P3 + S J=0 +P5 S J=$O(^ORD(101,I,10,K,L,J)) I J'>0 G P4 + I '$D(^ORD(101,I,10,J,0)) G PKILLXR ;kill xref to invalid item +P6 S M=^ORD(101,I,10,J,0) I (M=L)!(M[L_"^") G P5 +PKILLXR K ^ORD(101,I,10,K,L,J) I $O(^ORD(101,I,10,K,L,-1))="" K ^ORD(101,I,10,K,L) + G P5 diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQ5.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQ5.m index ab6649a6..e741848b 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQ5.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQ5.m @@ -1,102 +1,95 @@ -XQ5 ;SF/GFT,MJM,KLD - Menu edit utilities [XUEDITOPT] ;01/30/2008 - ;;8.0;KERNEL;**44,130,484**;Jul 10, 1995;Build 2 - ; Per VHA Directive 2004-038, this routine should not be modified. - ; Option & Input Template: XUEDITOPT -DIP ; - K DIC S DIC=.4,DIC(0)="AEQMZ" I $D(^DIC(19,DA,63)),^(63)?1"[".E1"]" S DIC("B")=$E(^(63),2,$L(^(63))-1) - S DUZ0=$S(DUZ(0)="@"!$D(^XUSEC("XUMGR",DUZ)):1,1:0) G:DUZ0 DIP1 S DIC("S")="I 1 Q:'$D(^DIC(+$P(^(0),U,4),0,""RD"")) F %=1:1:$L(^(""RD"")) I DUZ(0)[$E(^(""RD""),%) Q" -DIP1 ; - D:$G(DUZ0) PRNT - D ^DIC K DIC G:Y<0&(DUZ(0)'="@") Q G:Y<0&(DUZ0) Q1 S XQDIC=+$P(Y(0),U,4) G:XQDIC'>1 Q S XQ=$P(^DIC(XQDIC,0),U,1)_U_XQDIC,XQ(63)="["_$P(Y,U,2)_"]",XQ(60)=$P(^(0,"GL"),U,2),XQ(62)=0 -BY ; - D:$G(DUZ0) SORT - K DIC S DIC=.401,DIC(0)="AEQMZ" I $D(^DIC(19,DA,64)),^(64)?1"[".E1"]" S DIC("B")=$E(^(64),2,$L(^(64))-1) - S DIC("S")="I $P(^(0),U,4)=XQDIC" G:DUZ0 BY1 S DIC("S")=DIC("S")_" Q:'$D(^DIC(+$P(^(0),U,4),0,""RD"")) F %=1:1:$L(^(""RD"")) I DUZ(0)[$E(^(""RD""),%) Q" -BY1 ; - D ^DIC K DIC G TEM:X="",Q:Y<0 S XQDIC=+$P(Y(0),U,4),XQ=$P(^DIC(XQDIC,0),U,1)_U_XQDIC,XQ(64)="["_$P(Y,U,2)_"]" G FR -TEM ; - I +X=X,'$D(^DD(+$P(XQ,U,2),X,0)) W *7,"NO SUCH FIELD NUMBER" K X G BY - S XQ(64)=X -FR K X S Y=$S($D(^DIC(19,DA,65)):^(65),1:"") W !,"START WITH: ",$S(Y]"":Y,1:"FIRST")_"// " R X:DTIME G:X=U Q S:X="" X=Y W:X="?" !?4,"ENTER IN 'FR' FORMAT" G:X="?" FR K:X="@" X,^DIC(19,DA,65) W:'$D(X) *7," DELETED!" S:$D(X) XQ(65)=X -TO K X S Y=$S($D(^DIC(19,DA,66)):^(66),1:"") W !,"GO TO: ",$S(Y]"":Y,1:"LAST")_"// " R X:DTIME G:X=U Q S:X="" X=Y W:X="?" !?4,"ENTER IN 'TO' FORMAT" G:X="?" TO K:X="@" X,^DIC(19,DA,66) W:'$D(X) *7," DELETED!" S:$D(X) XQ(66)=X - D PUT G Q1 -DIE ; - S DUZ0=$S(DUZ(0)="@"!$D(^XUSEC("XUMGR",DUZ)):1,1:0) - K DIC,XQ S DIC=.402,DIC(0)="AQEMZ" I $D(^DIC(19,DA,51)),^(51)?1"[".E1"]" S DIC("B")=$E(^(51),2,$L(^(51))-1) - G:DUZ0 DIE1 S DIC("S")="I 1 Q:'$D(^DIC(+$P(^(0),U,4),0,""WR"")) F %=1:1:$L(^(""WR"")) I DUZ(0)[$E(^(""WR""),%) Q" -DIE1 ; - D ^DIC K DIC G:Y<0&(DUZ(0)'="@") Q G:Y<0&(DUZ0) Q1 S XQDIC="",XQDIC=+$P(Y(0),U,4) G:'XQDIC Q S XQ(51)="["_$P(Y,U,2)_"]" D DIC S XQ(50)=XQ(30) D PUT G Q1 -PUT S X=0 F S X=$O(XQ(X)) Q:X'>0 S ^DIC(19,DA,X)=XQ(X) - Q - ; -Q W *7,!,"NO CHANGE MADE TO OPTION LOGIC" -Q1 K XQDIC,XQ,Y S DIC=DIE Q - ; -DIC S XQ=$P(^DIC(XQDIC,0),U,1),XQ(30)=$P(^(0,"GL"),U,2) - S XQ(31)=$G(^DIC(19,DA,31)) S:XQ(31)="" XQ(31)="AEMQ" - I $D(^DIC(XQDIC,0,"LAYGO")),DUZ(0)'="@" S Y=$L(^("LAYGO")) I Y F %=1:1 I DUZ(0)[$E(^("LAYGO"),%) G A:%>Y Q - W !,"WHEN USER SELECTS AN ENTRY IN THE '"_XQ_"' FILE,",!,"WILL ADDING A NEW ENTRY AT THAT TIME ('LAYGO') BE ALLOWED" - S %=$S(XQ(31)["L":0,1:2) D YN^DICN - I %=1 I XQ(31)'["L" S XQ(31)=XQ(31)_"L" - I %=2 I XQ(31)["L" S XQ(31)=$TR(XQ(31),"L") -A Q - ; -DIQ ; - S DUZ0=$S(DUZ(0)="@"!$D(^XUSEC("XUMGR",DUZ)):1,1:0) - K DIC,XQ S DIC=1,DIC(0)="AEQMZ",DIC("A")="INQUIRE TO WHAT FILE: " - I $D(^DIC(19,DA,30)),^(30)["(",@("$D(^"_^(30)_"0))") S DIC("B")=+$P(^(0),U,2) - G:DUZ0 DIQ1 S DIC("S")="I 1 Q:'$D(^(0,""RD"")) F %=1:1:$L(^(""RD"")) I DUZ(0)[$E(^(""RD""),%) Q" -DIQ1 ; - D ^DIC K DIC G:Y<0 Q S (XQ(80),XQ(30))=$P(^(0,"GL"),U,2) - S XQ(31)=$G(^DIC(19,DA,31)) S:XQ(31)="" XQ(31)="AEMQ" - D PUT G Q1 - ; -NAME ; - I $E(X,1)="A"!($E(X,1)="Z") S %=1,%1="Local" Q - F %=4:-1:2 G:$D(^DIC(9.4,"C",$E(X,1,%))) NAMEOK - I 0 - Q -NAMEOK S %1=$O(^DIC(9.4,"C",$E(X,1,%),0)) S:%1="" %1=-1 S:$D(^DIC(9.4,%1,0)) %1=$P(^(0),U,1),XQPK=%1 I 1 Q - ; -CHKNAME ;Called from the input transform of the .01 field of the Option File - Q:$D(DIFROM)!($D(ZTQUEUED)) K XQPK - I $D(DIC(0))#2,DIC(0)'["E" Q - D NAME E D EN^DDIOL("Not a known package or a local namespace.") Q - D EN^DDIOL(" Located in the "_$E(X,1,%)_" ("_%1_") namespace.") Q - ; -PRNT W !,?16,"*** IMPORTANT PLEASE READ ***",! - W !,"By selecting a new Print/Sort Template below, your defaults will" - W !,"be changed. Your defaults are currently set as follows (see below)." - W !,"Should you desire to keep the defaults as they are, or to revise" - W !,"one or more, enter an '^' up-arrow, without selecting a new" - W !,"template name." - W !!,?23,"Default Values",!,?23,"==============",! - W !,?5,"DIC {DIP}: "_$$GET1^DIQ(19,DA,60) - W ?40,"L.: "_$$GET1^DIQ(19,DA,62) - W !,?5,"FLDS: "_$$GET1^DIQ(19,DA,63) - W ?40,"BY: "_$$GET1^DIQ(19,DA,64) - W !,?5,"FR: "_$$GET1^DIQ(19,DA,65) - W ?40,"TO: "_$$GET1^DIQ(19,DA,66),!! - Q - ; -SORT W !,?16,"*** IMPORTANT PLEASE READ ***",! - W !,"By selecting a new Sort Template below, your defaults will be" - W !,"changed. Your defaults are currently set as follows (see below)." - W !,"Should you desire to keep the defaults as they are, or to revise" - W !,"one or more, enter an '^' up-arrow, without selecting a new Sort" - W !,"Template." - W !!,?23,"Default Values",!,?23,"==============",! - W ?5,"BY: "_$$GET1^DIQ(19,DA,64) - W !,?5,"FR: "_$$GET1^DIQ(19,DA,65) - W ?40,"TO: "_$$GET1^DIQ(19,DA,66),!! - Q -TEST W !,"Enter a name, and the computer will respond with the namespace to which",!,"that name belongs. It does this by looking at the package file.",!! -T1 R !,"NAME: ",X:DTIME," " Q:X="" D CHKNAME G T1 -CLEAR ;Clear fields not used by this option. - I "EMPRSOQ"[X X "F %="_$S("M"[X:"25,27:1:82","QO"[X:"25,31:1:82","RS"[X:"10,30:1:82","E"[X:"10,25,60:1:82","P"[X:"10,25,27:1:54,80:1:82")_" I $D(^DIC(19,DA,%)) D:%=10 CLEAR1 K ^DIC(19,DA,%)" - I "AI"[X X "F %="_$S("A"[X:"10,25,30:1:82","I"[X:"10,25,36:1:62,64:1:73")_" I $D(^DIC(19,DA,%)) D:%=10 CLEAR1 K ^DIC(19,DA,%)" - I "OQ"'[X F %=100,100.1,100.2 I $D(^DIC(19,DA,%)) K ^DIC(19,DA,%) - Q -CLEAR1 S XQI=0 F S XQI=$O(^DIC(19,DA,%,XQI)) Q:XQI'>0 S XQJ=$P(^(XQI,0),U) K ^DIC(19,"AD",$E(XQJ,1,30),DA,XQI) - K XQI,XQJ - Q +XQ5 ;SF/GFT,MJM,KLD - Menu edit utilities [XUEDITOPT] ;09/20/96 15:33 + ;;8.0;KERNEL;**44,130**;Jul 10, 1995 +DIP ; + K DIC S DIC=.4,DIC(0)="AEQMZ" I $D(^DIC(19,DA,63)),^(63)?1"[".E1"]" S DIC("B")=$E(^(63),2,$L(^(63))-1) + S DUZ0=$S(DUZ(0)="@"!$D(^XUSEC("XUMGR",DUZ)):1,1:0) G:DUZ0 DIP1 S DIC("S")="I 1 Q:'$D(^DIC(+$P(^(0),U,4),0,""RD"")) F %=1:1:$L(^(""RD"")) I DUZ(0)[$E(^(""RD""),%) Q" +DIP1 ; + D:$G(DUZ0) PRNT + D ^DIC K DIC G:Y<0&(DUZ(0)'="@") Q G:Y<0&(DUZ0) Q1 S XQDIC=+$P(Y(0),U,4) G:XQDIC'>1 Q S XQ=$P(^DIC(XQDIC,0),U,1)_U_XQDIC,XQ(63)="["_$P(Y,U,2)_"]",XQ(60)=$P(^(0,"GL"),U,2),XQ(62)=0 +BY ; + D:$G(DUZ0) SORT + K DIC S DIC=.401,DIC(0)="AEQMZ" I $D(^DIC(19,DA,64)),^(64)?1"[".E1"]" S DIC("B")=$E(^(64),2,$L(^(64))-1) + S DIC("S")="I $P(^(0),U,4)=XQDIC" G:DUZ0 BY1 S DIC("S")=DIC("S")_" Q:'$D(^DIC(+$P(^(0),U,4),0,""RD"")) F %=1:1:$L(^(""RD"")) I DUZ(0)[$E(^(""RD""),%) Q" +BY1 ; + D ^DIC K DIC G TEM:X="",Q:Y<0 S XQDIC=+$P(Y(0),U,4),XQ=$P(^DIC(XQDIC,0),U,1)_U_XQDIC,XQ(64)="["_$P(Y,U,2)_"]" G FR +TEM ; + I +X=X,'$D(^DD(+$P(XQ,U,2),X,0)) W *7,"NO SUCH FIELD NUMBER" K X G BY + S XQ(64)=X +FR K X S Y=$S($D(^DIC(19,DA,65)):^(65),1:"") W !,"START WITH: ",$S(Y]"":Y,1:"FIRST")_"// " R X:DTIME G:X=U Q S:X="" X=Y W:X="?" !?4,"ENTER IN 'FR' FORMAT" G:X="?" FR K:X="@" X,^DIC(19,DA,65) W:'$D(X) *7," DELETED!" S:$D(X) XQ(65)=X +TO K X S Y=$S($D(^DIC(19,DA,66)):^(66),1:"") W !,"GO TO: ",$S(Y]"":Y,1:"LAST")_"// " R X:DTIME G:X=U Q S:X="" X=Y W:X="?" !?4,"ENTER IN 'TO' FORMAT" G:X="?" TO K:X="@" X,^DIC(19,DA,66) W:'$D(X) *7," DELETED!" S:$D(X) XQ(66)=X + D PUT G Q1 +DIE ; + S DUZ0=$S(DUZ(0)="@"!$D(^XUSEC("XUMGR",DUZ)):1,1:0) + K DIC,XQ S DIC=.402,DIC(0)="AQEMZ" I $D(^DIC(19,DA,51)),^(51)?1"[".E1"]" S DIC("B")=$E(^(51),2,$L(^(51))-1) + G:DUZ0 DIE1 S DIC("S")="I 1 Q:'$D(^DIC(+$P(^(0),U,4),0,""WR"")) F %=1:1:$L(^(""WR"")) I DUZ(0)[$E(^(""WR""),%) Q" +DIE1 ; + D ^DIC K DIC G:Y<0&(DUZ(0)'="@") Q G:Y<0&(DUZ0) Q1 S XQDIC="",XQDIC=+$P(Y(0),U,4) G:'XQDIC Q S XQ(51)="["_$P(Y,U,2)_"]" D DIC S XQ(50)=XQ(30) D PUT G Q1 +PUT S X=0 F S X=$O(XQ(X)) Q:X'>0 S ^DIC(19,DA,X)=XQ(X) + Q + ; +Q W *7,!,"NO CHANGE MADE TO OPTION LOGIC" +Q1 K XQDIC,XQ,Y S DIC=DIE Q + ; +DIC S XQ=$P(^DIC(XQDIC,0),U,1),XQ(30)=$P(^(0,"GL"),U,2),XQ(31)="AEMQ" + I $D(^DIC(XQDIC,0,"LAYGO")),DUZ(0)'="@" S Y=$L(^("LAYGO")) I Y F %=1:1 I DUZ(0)[$E(^("LAYGO"),%) G A:%>Y Q + W !,"WHEN USER SELECTS AN ENTRY IN THE '"_XQ_"' FILE,",!,"WILL ADDING A NEW ENTRY AT THAT TIME ('LAYGO') BE ALLOWED" + S %=$S($D(^DIC(19,DA,31)):^(31)'["L"+1,1:0) D YN^DICN I %=1 S XQ(31)="AEMQL" +A Q + ; +DIQ ; + S DUZ0=$S(DUZ(0)="@"!$D(^XUSEC("XUMGR",DUZ)):1,1:0) + K DIC,XQ S DIC=1,DIC(0)="AEQMZ",DIC("A")="INQUIRE TO WHAT FILE: " + I $D(^DIC(19,DA,30)),^(30)["(",@("$D(^"_^(30)_"0))") S DIC("B")=+$P(^(0),U,2) + G:DUZ0 DIQ1 S DIC("S")="I 1 Q:'$D(^(0,""RD"")) F %=1:1:$L(^(""RD"")) I DUZ(0)[$E(^(""RD""),%) Q" +DIQ1 ; + D ^DIC K DIC G:Y<0 Q S XQ(31)="AEMQ",(XQ(80),XQ(30))=$P(^(0,"GL"),U,2) D PUT G Q1 + ; +NAME ; + I $E(X,1)="A"!($E(X,1)="Z") S %=1,%1="Local" Q + F %=4:-1:2 G:$D(^DIC(9.4,"C",$E(X,1,%))) NAMEOK + I 0 + Q +NAMEOK S %1=$O(^DIC(9.4,"C",$E(X,1,%),0)) S:%1="" %1=-1 S:$D(^DIC(9.4,%1,0)) %1=$P(^(0),U,1),XQPK=%1 I 1 Q + ; +CHKNAME ;Called from the input transform of the .01 field of the Option File + Q:$D(DIFROM)!($D(ZTQUEUED)) K XQPK + I $D(DIC(0))#2,DIC(0)'["E" Q + D NAME E D EN^DDIOL("Not a known package or a local namespace.") Q + D EN^DDIOL(" Located in the "_$E(X,1,%)_" ("_%1_") namespace.") Q + ; +PRNT W !,?16,"*** IMPORTANT PLEASE READ ***",! + W !,"By selecting a new Print/Sort Template below, your defaults will" + W !,"be changed. Your defaults are currently set as follows(see below)." + W !,"Should you desire to keep the defaults as they are, or to revise" + W !,"one or more, enter an '^' up-arrow, without selecting a new" + W !,"template name." + W !!,?23,"Default Values",!,?23,"==============",! + W !,?17,"DIC {DIP}: "_$$GET1^DIQ(19,DA,60) + W ?40,"L.: "_$$GET1^DIQ(19,DA,62) + W !,?17,"FLDS: "_$$GET1^DIQ(19,DA,63) + W ?40,"BY: "_$$GET1^DIQ(19,DA,64) + W !,?17,"FR: "_$$GET1^DIQ(19,DA,65) + W ?40,"TO: "_$$GET1^DIQ(19,DA,66),!! + Q + ; +SORT W !,?16,"*** IMPORTANT PLEASE READ ***",! + W !,"By selecting a new Sort Template below, your defaults will be" + W !,"changed. Your defaults are currently set as follow(see below)." + W !,"Should you desire to keep the defaults as they are, or to revise" + W !,"one or more, enter an '^' up-arrow, without selecting a new Sort" + W !,"Template." + W !!,?23,"Default Values",!,?23,"==============",! + W ?17,"BY: "_$$GET1^DIQ(19,DA,64) + W !,?17,"FR: "_$$GET1^DIQ(19,DA,65) + W ?40,"TO: "_$$GET1^DIQ(19,DA,66),!! + Q +TEST W !,"Enter a name, and the computer will respond with the namespace to which",!,"that name belongs. It does this by looking at the package file.",!! +T1 R !,"NAME: ",X:DTIME," " Q:X="" D CHKNAME G T1 +CLEAR ;Clear fields not used by this option. + I "EMPRSOQ"[X X "F %="_$S("M"[X:"25,27:1:82","QO"[X:"25,31:1:82","RS"[X:"10,30:1:82","E"[X:"10,25,60:1:82","P"[X:"10,25,27:1:54,80:1:82")_" I $D(^DIC(19,DA,%)) D:%=10 CLEAR1 K ^DIC(19,DA,%)" + I "AI"[X X "F %="_$S("A"[X:"10,25,30:1:82","I"[X:"10,25,36:1:62,64:1:73")_" I $D(^DIC(19,DA,%)) D:%=10 CLEAR1 K ^DIC(19,DA,%)" + I "OQ"'[X F %=100,100.1,100.2 I $D(^DIC(19,DA,%)) K ^DIC(19,DA,%) + Q +CLEAR1 S XQI=0 F S XQI=$O(^DIC(19,DA,%,XQI)) Q:XQI'>0 S XQJ=$P(^(XQI,0),U) K ^DIC(19,"AD",$E(XQJ,1,30),DA,XQI) + K XQI,XQJ + Q diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQ55.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQ55.m index ff15657e..28717e9c 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQ55.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQ55.m @@ -1,112 +1,90 @@ -XQ55 ; SEA/AMF,MJM,JLI - SEARCH FOR USERS ACCESS TO AN OPTION; - ;;8.0;KERNEL;**140,342,483,508**;Jul 10, 1995;Build 1 - ;;Per VHA Directive 2004-038, this routine should not be modified -INIT ; - S XQDSH="-------------------------------------------------------------------------------" - D ^XQDATE S XQDT=%Y -OPT W ! S DIC=19,DIC(0)="AEQM" D ^DIC G:Y=-1 OUT S XQOPT=+Y -MPAT W !!,"Show menu paths" S %=2 D YN^DICN G:%<0 OUT S XQMP=2-% I '% W !!,"If you answer 'YES', the listing will include the menu path(s) each user has",!,"to access the specified option." G MPAT - K ^TMP($J),XQR,XQP - S K=^DIC(19,XQOPT,0),XQHDR="Access to '"_$P(K,U,2)_"' ["_$P(K,U,1)_"]",XQSCD=0,XQCOM=0,XQNOPRNT=0 -LOOP1 S K=XQOPT,(L,X(0))=0,XQD=K K XQR,XQA,XQK,XQRV S XQR(K)="" I '$L($P(^DIC(19,K,0),U,3)) D TREE1 - G LOOP2 - Q -TREE S X(L)=$O(^DIC(19,"AD",XQD,X(L))) Q:X(L)'>0 S K=X(L) G:$D(XQR(K)) TREE S XQR(K)="" -TREE1 ; - S Y(0)=^DIC(19,K,0) G:$L($P(Y(0),U,3)) TREE S:$L($P(Y(0),U,6)) XQK(L)=$P(Y(0),U,6) S XQA(L)=K I $P(Y(0),U,16) S XQRV(L)=^DIC(19,K,3) - D SETGLO S L=L+1,X(L)=0,(XQD,XQD(L))=K D TREE - Q:L=1 K XQR(XQD(L)) S L=L-1 K XQA(L),XQK(L),XQRV(L) S XQD=XQD(L) G TREE - Q -SETGLO ; - S XQK="" F I=L:-1:0 I $D(XQK(I)),$L(XQK(I)) S XQK=XQK_XQK(I)_"," - S XQRV="" F I=L:-1:0 I $D(XQRV(I)),$L(XQRV(I)) S XQRV=XQRV_XQRV(I)_"," - S XQA="" F I=L:-1:1 I $D(XQA(I)) S XQA=XQA_XQA(I)_"," - S XQA=XQA_XQOPT,J=0 S:$D(^TMP($J,K,0)) J=^(0) S J=J+1,^(0)=J,^TMP($J,K,J)=XQK_U_XQA_U_XQRV - Q -LOOP2 ; - S XQPA(0)=0,XQP=0 F S XQP=$O(^TMP($J,XQP)) Q:XQP="" S XQN=^TMP($J,XQP,0) S XQPS="AP" D USERS S XQPS="AD" D USERS - D USERS1 I XQNOPRNT G MUS ; 080115 - add in options from the common menu - G LOOP3 -USERS ; - S XQU=0 F S XQU=$O(^VA(200,XQPS,XQP,XQU)) Q:XQU'>0 I $D(^VA(200,XQU,.1)),+$$ACTIVE^XUSER(XQU) D EACHU - Q -USERS1 ; 080115 code added to handle options on the COMMON (XUCOMMAND) menu - N XUCOMMON - S XUCOMMON=$O(^DIC(19,"B","XUCOMMAND",0)) - S XQP=0 F S XQP=$O(^TMP($J,XQP)) Q:XQP="" S XQN=^TMP($J,XQP,0) F J=1:1:XQN Q:'$D(^TMP($J,XQP,J)) I $P($P(^TMP($J,XQP,J),U,2),",")=XUCOMMON D - . D Q:'Y - . . W !,"***" - . . W !,"*** This option is available from the 'SYSTEM COMMAND OPTIONS' ***" - . . W !,"*** (XUCOMMAND) menu available to all active users unless ***" - . . W !,"*** protected by a KEY - DO YOU REALLY WANT THE ENTIRE LIST ***" - . . W !,"*** OF THESE USERS??? ***",! - . . N DIR S DIR(0)="Y" D ^DIR S:'Y XQNOPRNT=1 Q:'Y - . . Q - . S XQU=0,XQPS="(C)" F S XQU=$O(^VA(200,XQU)) Q:XQU'>0 I $D(^VA(200,XQU,.1)),+$$ACTIVE^XUSER(XQU),$$KEYCHECK() S II=1 D SETU - Q - ; -EACHU ; - S II=1 - F J=1:1:XQN Q:'$D(^TMP($J,XQP,J)) I $$KEYCHECK() D SETU ; 080115 - Q - ; -KEYCHECK() ; 080115 extracted common code - ; returns 1 if user has access to the option, 0 if the user does not have access - S XQK=$P(^TMP($J,XQP,J),U,1),XX=$L(XQK,",")-1,XQGO=1 - I XX F X=1:1:XX S Y=$P(XQK,",",X) I Y'="",('$D(^XUSEC(Y,XQU))) S XQGO=0 - S XQK=$P(^TMP($J,XQP,J),U,3),XX=$L(XQK,",")-1 - I XX F X=1:1:XX S Y=$P(XQK,",",X) I Y'="",($D(^XUSEC(Y,XQU))) S XQGO=0 - Q XQGO - ; -SETU ; - S XQPA=$P(^TMP($J,XQP,J),U,2) - I '$D(XQPA(XQPA)) S I=XQPA(0)+1,XQPA(0)=I,XQPA(0,I)=XQPA,XQPA(XQPA)=I - S XQPA=XQPA(XQPA) S:XQPS="AD" XQPA=XQPA_"(S)",XQSCD=1 S:XQPS="(C)" XQPA=XQPA_"(C)",XQCOM=1 ; 080115 - S I=$P(^VA(200,XQU,0),U,1)_U_XQU S:$D(^TMP($J,0,I)) II=$O(^TMP($J,0,I,"A"),-1)+1 S ^TMP($J,0,I,II)=XQPA - Q -LOOP3 ; - I $O(^TMP($J,0,0))="" W !!,"** NO USERS CAN ACCESS THIS OPTION **" G OUT - S %ZIS="MFQ" D ^%ZIS G OUT:POP I $D(IO("Q")) K IO("Q") S ZTRTN="DQ^XQ55",ZTDESC="OPTION ACCESS BY USER",ZTSAVE("XQ*")="",ZTSAVE("^TMP($J,")="" D ^%ZTLOAD K ZTSK,ZTRTN,ZTSAVE,ZTDESC G OUT - ; -DQ ;Entry point for queued job - U IO - S:'XQMP XQPA(0)=-4 S XQPG=0,XQUI=0 D NEWPG G:XQUI MUS - S XQU=0 F S XQU=$O(^TMP($J,0,XQU)) Q:XQU="" D PRTU G:XQUI MUS - D:XQMP MENUPAT G MUS -NEWPG ; - S X="" I XQPG,$E(IOST,1)="C" D CON S XQUI=(X="^") Q:XQUI - D HDR Q -CON ; - W !!,"Press return to continue or '^' to escape " R X:DTIME S:'$T X=U - Q -HDR ; - W @IOF S XQPG=XQPG+1 - W "Page ",XQPG,?62,XQDT,!! S XQTAB=(76-$L(XQHDR))/2 W ?XQTAB,XQHDR - W !!,"USER NAME",?27,"LAST ON",?37,"PRIMARY MENU" W:XQMP ?63,"PATH(S)" - W !,$E(XQDSH,1,25),?27,$E(XQDSH,1,8),?37,$E(XQDSH,1,$S(XQMP:24,1:40)) W:XQMP ?63,$E(XQDSH,1,14) - Q -PRTU ; - I $Y>(IOSL-XQPA(0)-8) D:XQMP MENUPAT D NEWPG Q:XQUI - S J=$P(XQU,U,2),K="" S:$D(^VA(200,J,1.1)) K=$P(^(1.1),"^") S:$L(K) K=$E(K,4,5)_"/"_$E(K,6,7)_"/"_$E(K,2,3) W !,$E($P(XQU,U,1),1,27),?27,K - I $D(^VA(200,J,201)) S K=+^(201) I K>0,$D(^DIC(19,K,0)) W ?37,$E($P(^(0),U,1),1,24) - I XQMP D - .W ?63,"" - .S JJ=$O(^TMP($J,0,XQU,"A"),-1) - .F II=1:1:JJ W $G(^TMP($J,0,XQU,II)) I II'=JJ W "," - I 'XQMP D - .S II=0 F S II=$O(^TMP($J,0,XQU,II)) Q:II'>0 D - ..I ^TMP($J,0,XQU,II)["(S)" W " (Secondary menu)" S II="A" - Q -MENUPAT ; - W !!,$E(XQDSH,1,27)," MENU PATH(S) ",$E(XQDSH,1,29),! - F I=1:1:XQPA(0) S K=XQPA(0,I) W !,I,".",?4 F N=1:1 Q:'$L($P(K,",",N)) W:N>1 " ... " W $P(^DIC(19,$P(K,",",N),0),U,1) - I XQSCD W !,"(S) - secondary menu pathway" - I XQCOM W !,"(C) - SYSTEM COMMAND OPTIONS (XUCOMMAND) menu pathway" - Q -MUS G:X="^" OUT I $G(XQPG),$E(IOST,1)="C" W !!,"Press return when finished viewing " R X:DTIME W @IOF G OUT - I $D(ZTSK) K ^%ZTSK(ZTSK) -OUT ; - D ^%ZISC -KILL K XQDT,XQGO,XQN,XQP,XQR,XQRV,XQOPT,XQPA,XQUI,XQSCD,XQDSH,XQU,N,K,J,X,XQA,XQD,XQHDR,XQK,XQP,XQPS,XQMP,XQPG,XX - K DIC,I,II,JJ,L,POP,Y,XQNOPRNT I $D(ZTQUEUED),$D(ZTSK),ZTSK>0 K ^%ZTSK(ZTSK) - Q +XQ55 ; SEA/AMF,MJM,JLI - SEARCH FOR USERS ACCESS TO AN OPTION [4/12/04 4:36am] + ;;8.0;KERNEL;**140,342**;Jul 10, 1995 +INIT ; + S XQDSH="-------------------------------------------------------------------------------" + D ^XQDATE S XQDT=%Y +OPT W ! S DIC=19,DIC(0)="AEQM" D ^DIC G:Y=-1 OUT S XQOPT=+Y +MPAT W !!,"Show menu paths" S %=2 D YN^DICN G:%<0 OUT S XQMP=2-% I '% W !!,"If you answer 'YES', the listing will include the menu path(s) each user has",!,"to access the specified option." G MPAT + K ^TMP($J),XQR,XQP + S K=^DIC(19,XQOPT,0),XQHDR="Access to '"_$P(K,U,2)_"' ["_$P(K,U,1)_"]",XQSCD=0 +LOOP1 S K=XQOPT,(L,X(0))=0,XQD=K K XQR,XQA,XQK,XQRV S XQR(K)="" I '$L($P(^DIC(19,K,0),U,3)) D TREE1 + G LOOP2 + Q +TREE S X(L)=$O(^DIC(19,"AD",XQD,X(L))) Q:X(L)'>0 S K=X(L) G:$D(XQR(K)) TREE S XQR(K)="" +TREE1 ; + S Y(0)=^DIC(19,K,0) G:$L($P(Y(0),U,3)) TREE S:$L($P(Y(0),U,6)) XQK(L)=$P(Y(0),U,6) S XQA(L)=K I $P(Y(0),U,16) S XQRV(L)=^DIC(19,K,3) + D SETGLO S L=L+1,X(L)=0,(XQD,XQD(L))=K D TREE + Q:L=1 K XQR(XQD(L)) S L=L-1 K XQA(L),XQK(L),XQRV(L) S XQD=XQD(L) G TREE + Q +SETGLO ; + S XQK="" F I=L:-1:0 I $D(XQK(I)),$L(XQK(I)) S XQK=XQK_XQK(I)_"," + S XQRV="" F I=L:-1:0 I $D(XQRV(I)),$L(XQRV(I)) S XQRV=XQRV_XQRV(I)_"," + S XQA="" F I=L:-1:1 I $D(XQA(I)) S XQA=XQA_XQA(I)_"," + S XQA=XQA_XQOPT,J=0 S:$D(^TMP($J,K,0)) J=^(0) S J=J+1,^(0)=J,^TMP($J,K,J)=XQK_U_XQA_U_XQRV + Q +LOOP2 ; + S XQPA(0)=0,XQP=0 F S XQP=$O(^TMP($J,XQP)) Q:XQP="" S XQN=^TMP($J,XQP,0) S XQPS="AP" D USERS S XQPS="AD" D USERS + G LOOP3 +USERS ; + S XQU=0 F S XQU=$O(^VA(200,XQPS,XQP,XQU)) Q:XQU'>0 I $D(^VA(200,XQU,.1)),+$$ACTIVE^XUSER(XQU) D EACHU + Q +EACHU ; + S II=1 + F J=1:1:XQN Q:'$D(^TMP($J,XQP,J)) D + .S XQK=$P(^TMP($J,XQP,J),U,1),XX=$L(XQK,",")-1,XQGO=1 + .I XX F X=1:1:XX S Y=$P(XQK,",",X) I Y'="",('$D(^XUSEC(Y,XQU))) S XQGO=0 + .S XQK=$P(^TMP($J,XQP,J),U,3),XX=$L(XQK,",")-1 + .I XX F X=1:1:XX S Y=$P(XQK,",",X) I Y'="",($D(^XUSEC(Y,XQU))) S XQGO=0 + .D:XQGO SETU + Q +SETU ; + S XQPA=$P(^TMP($J,XQP,J),U,2) + I '$D(XQPA(XQPA)) S I=XQPA(0)+1,XQPA(0)=I,XQPA(0,I)=XQPA,XQPA(XQPA)=I + S XQPA=XQPA(XQPA) S:XQPS="AD" XQPA=XQPA_"(S)",XQSCD=1 + S I=$P(^VA(200,XQU,0),U,1)_U_XQU S:$D(^TMP($J,0,I)) II=$O(^TMP($J,0,I,"A"),-1)+1 S ^TMP($J,0,I,II)=XQPA + Q +LOOP3 ; + I $O(^TMP($J,0,0))="" W !!,"** NO USERS CAN ACCESS THIS OPTION **" G OUT + S %ZIS="MFQ" D ^%ZIS G OUT:POP I $D(IO("Q")) K IO("Q") S ZTRTN="DQ^XQ55",ZTDESC="OPTION ACCESS BY USER",ZTSAVE("XQ*")="",ZTSAVE("^TMP($J,")="" D ^%ZTLOAD K ZTSK,ZTRTN,ZTSAVE,ZTDESC G OUT + ; +DQ ;Entry point for queued job + U IO + S:'XQMP XQPA(0)=-4 S XQPG=0,XQUI=0 D NEWPG G:XQUI MUS + S XQU=0 F S XQU=$O(^TMP($J,0,XQU)) Q:XQU="" D PRTU G:XQUI MUS + D:XQMP MENUPAT G MUS +NEWPG ; + S X="" I XQPG,$E(IOST,1)="C" D CON S XQUI=(X="^") Q:XQUI + D HDR Q +CON ; + W !!,"Press return to continue or '^' to escape " R X:DTIME S:'$T X=U + Q +HDR ; + W @IOF S XQPG=XQPG+1 + W "Page ",XQPG,?62,XQDT,!! S XQTAB=(76-$L(XQHDR))/2 W ?XQTAB,XQHDR + W !!,"USER NAME",?27,"LAST ON",?37,"PRIMARY MENU" W:XQMP ?63,"PATH(S)" + W !,$E(XQDSH,1,25),?27,$E(XQDSH,1,8),?37,$E(XQDSH,1,$S(XQMP:24,1:40)) W:XQMP ?63,$E(XQDSH,1,14) + Q +PRTU ; + I $Y>(IOSL-XQPA(0)-8) D:XQMP MENUPAT D NEWPG Q:XQUI + S J=$P(XQU,U,2),K="" S:$D(^VA(200,J,1.1)) K=$P(^(1.1),"^") S:$L(K) K=$E(K,4,5)_"/"_$E(K,6,7)_"/"_$E(K,2,3) W !,$E($P(XQU,U,1),1,27),?27,K + I $D(^VA(200,J,201)) S K=+^(201) I K>0,$D(^DIC(19,K,0)) W ?37,$E($P(^(0),U,1),1,24) + I XQMP D + .W ?63,"" + .S JJ=$O(^TMP($J,0,XQU,"A"),-1) + .F II=1:1:JJ W $G(^TMP($J,0,XQU,II)) I II'=JJ W "," + I 'XQMP D + .S II=0 F S II=$O(^TMP($J,0,XQU,II)) Q:II'>0 D + ..I ^TMP($J,0,XQU,II)["(S)" W " (Secondary menu)" S II="A" + Q +MENUPAT ; + W !!,$E(XQDSH,1,27)," MENU PATH(S) ",$E(XQDSH,1,29),! + F I=1:1:XQPA(0) S K=XQPA(0,I) W !,I,".",?4 F N=1:1 Q:'$L($P(K,",",N)) W:N>1 " ... " W $P(^DIC(19,$P(K,",",N),0),U,1) + I XQSCD W !,"(S) - secondary menu pathway" + Q +MUS G:X="^" OUT I XQPG,$E(IOST,1)="C" W !!,"Press return when finished viewing " R X:DTIME W @IOF G OUT + I $D(ZTSK) K ^%ZTSK(ZTSK) +OUT ; + D ^%ZISC +KILL K XQDT,XQGO,XQN,XQP,XQR,XQRV,XQOPT,XQPA,XQUI,XQSCD,XQDSH,XQU,N,K,J,X,XQA,XQD,XQHDR,XQK,XQP,XQPS,XQMP,XQPG,XX + K DIC,I,II,JJ,L,POP,Y I $D(ZTQUEUED),$D(ZTSK),ZTSK>0 K ^%ZTSK(ZTSK) + Q diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQ81.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQ81.m index dae73b34..a6a26b25 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQ81.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQ81.m @@ -1,256 +1,252 @@ -XQ81 ;SEA/AMF/LUKE,SF/RWF - Build menu trees ;12/10/07 - ;;8.0;KERNEL;**81,116,157,253,478**;Jul 10, 1995;Build 3 -BUILD ; - ; -RD2 N XQSTAT S XQSTAT=$$STATUS() - I 'XQSTAT W !!,"Some one else is rebuilding menus. Sorry." Q - K ZTSK - D MICRO ;Turn off micro surgery for now - ; - S XQSTART=$$HTE^XLFDT($H) - K XQFG W !!,"This option will build menu trees for each primary and secondary menu.",!,"You may build all the trees, or build them selectively, using 'verify'.",!,"Note that the 'compiled menus' will only be built into ^XUTL on this CPU.",! - S DIR(0)="Y",DIR("A")="Do you wish to verify each primary menu",DIR("B")="NO",DIR("??")="XQBUILDTREE-VER" D ^DIR K DIR G:$D(DIRUT) BLDEND1 S XQVE=(Y=1) - S DIR(0)="Y",DIR("A")="Would you like to build secondary menu trees too",DIR("B")="YES",DIR("??")="XQBUILDTREE-SEC" D ^DIR G:$D(DIRUT) BLDEND1 S XQBSEC=(Y=1) - ; - I 'XQVE S DIR(0)="Y",DIR("A")="Would you like to queue this job",DIR("B")="YES" D ^DIR K DIR G:$D(DIRUT) BLDEND1 I Y=1 D - .S ZTRTN="QUE^XQ81",ZTIO="" - .S ZTSAVE("XQVE")="",ZTSAVE("XQBSEC")="",ZTSAVE("XQSTART")="" - .S ZTDESC="Build menu trees in ^DIC(19,""AXQ"")" - .D ^%ZTLOAD - .I $D(ZTSK),'XQVE W !!,"Task #: ",ZTSK,! - .Q - ; - I $D(ZTSK) K ^DIC(19,"AXQ","P0") S XQALLDON="" G BLDEND - E S ^DIC(19,"AXQ","P0")=$H L +^DIC(19,"AXQ","P0") - ; - I 'XQVE S DIR(0)="Y",DIR("A")="Do you really wish to run this DIRECTLY (it may take some time)",DIR("B")="NO" D ^DIR K DIR G:$D(DIRUT) BLDEND1 G:Y'=1 RD2 - ; -KIDS ;Entry from KIDS - I '$D(XQSTAT),$D(^DIC(19,"AXQ","P0")) S XQSTAT=$$STATUS I 'XQSTAT W !!," Some one else is building menus. Sorry." K XQSTAT Q - I '$D(^DIC(19,"AXQ","P0","STOP")) D MICRO - I '$D(^DIC(19,"AXQ","P0")) S ^DIC(19,"AXQ","P0")=$H L +^DIC(19,"AXQ","P0") - I '$D(XQVE) S XQFG=0,XQBSEC=1,XQVE=0 - N XQNTREE,XQNDONE S (XQNTREE,XQNDONE)=0 - ; - ;Set up the error trap so we can clear the screen if it blows - I $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERR^XQ81" - E S X="ERR^XQ81",@^%ZOSF("TRAP") - ; - ;Set up the bar graph and window if not from KIDS - I '$D(XPDNM) D INIT^XPDID - I XPDIDVT D - .I $D(XPDIDTOT) S XQSAVTOT=XPDIDTOT - .S X="Rebuilding Menus" D TITLE^XPDID(X) - .S XPDIDTOT=50 ;Number of divisions in bar graph - .D UPDATE^XPDID(0) - .Q - ; - S XQSTART=$$HTE^XLFDT($H) - W !!,"Starting Menu Rebuild: ",XQSTART - S XQFG=0 W !!,"Collecting primary menus in the New Person file..." - ; -DQ ;Entry from taskman Write if $D(XQFG) - K ZTREQ - I '$D(XQSTART) S XQSTART=$$HTE^XLFDT($H) - N XQNOW,XQ8FLG,XQTASK - S XQ8FLG=0 - S:'$D(XQNOW) XQNOW=$H - S ^DIC(19,"AXQ","P0")=XQNOW - S ^DIC(19,"AXQ","P0","STOP")=XQNOW ;Stop micro surgery if it's running - ; - S XQSEC=1,XQ81T="" I 'XQVE H 1 - S XQI="" F XQK=0:0 S XQI=$O(^TMP("XQO",$J,XQI)) Q:XQI'=+XQI!(XQI="") I $D(^TMP("XQO",$J,XQI,0))#2 S $P(^(0),U,2)="" - S XQI="U" F XQK=0:0 S XQI=$O(^TMP("XQO",$J,XQI)) Q:"U"'[$E(XQI)!(XQI="") I $D(^TMP("XQO",$J,XQI,0))#2 S $P(^(0),U,2)="" - S XQI="P" F XQK=0:0 S XQI=$O(^TMP("XQO",$J,XQI)) Q:"P"'[$E(XQI)!(XQI="") I $D(^TMP("XQO",$J,XQI,0))#2,$L(^(0)) S XQ81T=^(0) Q - S:XQ81T="" XQ81T="Unknown" - S XQI="P" F XQK=0:0 S XQI=$O(^TMP("XQO",$J,XQI)) Q:"P"'[$E(XQI)!(XQI="") I "P"[$E(XQI),XQI'="P0" K ^TMP("XQO",$J,XQI) - ; - ;Find the various trees and put them into ^TMP($J), and count them - S:'$D(XQH) XQH=$H K ^TMP($J) S XQI=.5 F XQK=0:0 S XQI=$O(^VA(200,XQI)) Q:XQI'=+XQI I $D(^VA(200,XQI,0)),$L($P(^VA(200,XQI,0),U,3)) D SET - ; - S (XQNTREE,%)=0 F S %=$O(^TMP($J,%)) Q:%="" S XQNTREE=XQNTREE+1 - S %=0 F S %=$O(^TMP($J,"SEC",%)) Q:%="" S XQNTREE=XQNTREE+1 - ; - W:$D(XQFG) !!?20,"Primary menus found in the New Person file",!?20,"------------------------------------------" - W:$D(XQFG) !!,"OPTION NAME MENU TEXT",?49,"# OF",?62,"LAST",?71,"LAST",!?49,"USERS",?62,"USED",?71,"BUILT",! - S X="" F XQBLD=0:0 S XQBLD=$O(^TMP($J,XQBLD)) Q:XQBLD'>0!(X=U) I $D(^DIC(19,XQBLD,0)) S XQJ=^DIC(19,XQBLD,0) D VER - S XQSEC=0 I $D(XQFG),XQBSEC W !!,"Building secondary menu trees...." - I XQBSEC S X="" F XQBLD=0:0 S XQBLD=$O(^TMP($J,"SEC",XQBLD)) Q:XQBLD'>0 D SEC - I 'XQVE S XQK="P" F XQBLD=0:0 S XQK=$O(^TMP("XQO",$J,XQK)) Q:XQK'["P" S ^(XQK,0)=XQH - G BLDEND - ; -SEC S XQL="P"_XQBLD Q:$D(^TMP("XQO",$J,XQL)) D RD3 Q - S XQL="P" F XQN=0:0 S XQL=$O(^TMP("XQO",$J,XQL)) Q:$E(XQL)'="P" I $D(^TMP("XQO",$J,XQL,"^",XQBLD)) Q - D:$E(XQL)'="P" RD3 - Q - ; -VER I $D(XQFG) D - .N XQMT,XQOPNM - .S XQK=$P(^TMP($J,XQBLD),U,2) - .S:$L(XQK) XQK=$E(XQK,4,5)_"/"_$E(XQK,6,7)_"/"_$E(XQK,2,3) - .S XQOPNM=$P(XQJ,U) - .S XQMT=$P(XQJ,U,2) I $L(XQMT)>28 S XQMT=$E(XQMT,1,25)_"..." - .W !,$P(XQJ,U,1) - .W:($L(XQOPNM)>20) ! - .W ?20,XQMT,?49,+^TMP($J,XQBLD),?60,XQK - .Q - ; - I $D(XQFG) S:$D(^DIC(19,"AXQ","P"_XQBLD,0)) XQ81T=+^(0) I $L(XQ81T) S %H=XQ81T D YMD^%DTC S XQK=X W ?71,$E(XQK,4,5),"/",$E(XQK,6,7),"/",$E(XQK,2,3) - ; -RD3 ;Update counter an rebuild it if necessary - I $D(XQFG),XPDIDVT D - .N % - .S XQNDONE=XQNDONE+1 - .S %=(XQNDONE/XQNTREE)*XPDIDTOT - .D UPDATE^XPDID(%) - .Q - ; - S XQDIC="P"_XQBLD D CHK^XQ8 I XQRE W:$D(XQFG) !,"SOMEONE ELSE IS CURRENTLY REBUILDING THIS MENU" Q - I XQVE,XQSEC S DIR(0)="Y",DIR("A")="Rebuild",DIR("B")="YES" D ^DIR Q:$D(DIRUT) W ! Q:Y'=1 - S XQFG1=1 D PM2^XQ8 - I $D(ZTQUEUED) S ZTREQ="@" - Q - ; -SET G:'$D(^VA(200,XQI,201)) SET1 S XQK=+^(201) Q:'$L(XQK) ;I $D(XQFG) W:'(XQI#10) "." - S XQR="" S:$D(^VA(200,XQI,1.1)) XQR=$P(^(1.1),".",1) S XQP=1_U_XQR - I $D(^TMP($J,XQK)) S XQP=^TMP($J,XQK) S XQP=XQP+1_U_$S(XQR>$P(XQP,U,2):XQR,1:$P(XQP,U,2)) - I $D(^DIC(19,XQK,0)),$P(^(0),U,4)="M" S ^TMP($J,XQK)=XQP - ; -SET1 I XQBSEC F XQN=0:0 S XQN=$O(^VA(200,XQI,203,XQN)) Q:XQN'>0 S XQL=+^(XQN,0) I $D(^DIC(19,XQL,0)),$P(^(0),U,4)="M" S ^TMP($J,"SEC",XQL)="" - Q - ; -QUE ;Entry point for the option XQBUILDTREEQUE, and XQBUILDALL - ;Also called by CHEK^XQ83 - S XQVE=0,XQBSEC=1 K XQFG - S XQSTART=$$HTE^XLFDT($H) - G DQ - ; -BLDEND ;File a report, cleanup, and quit. - ; - K %,%H,%TG,C,D,DIC,DIR,I,J,K,L,V,XQBSEC,X,Y,Z,XQL,XQN,XQRE,XQK,XQI,XQII,UU,XQH,XQPX,XQSAV,XQXUF,XQ81T,XQDATE,XQSEC,XQVE,XQBLD,XQP,XQR,XQJ - ; - I $D(XQALLDON) K XQALLDON Q ;Quit here if we're just creating a task - ; - D MERGET - D CLEAN - D MERGEX - ; - K ^TMP($J),^TMP("XQO",$J) - ; - ;Clear the flags and locks. - K ^XUTL("XQMERGED") ;Menues merged since last rebuild REACT^XQ84 - K ^DIC(19,"AT") ;Micro message nodes - S ^XUTL("XQ","MICRO")=0 ;Number of Micro instances since last build - K ^DIC(19,"AXQ","P0","STOP") ;Allow Micro surgery to start up - K ^DIC(19,"AXQ","P0") ;Clear the rebuild flag (redundant, I know) - L -^DIC(19,"AXQ","P0") ;Unlock the rebuild flag, everybody's good to go - ; - S %=$S($D(XPDNM):"KIDS",$D(ZTSK):"QUEUED",1:"LIVE") - D REPORT^XQ84(%) - K XQSTART,ZTSK - ; - I '$D(XPDIDVT) K XQFG Q - ; - I $D(XQFG),XPDIDVT F %=((XQNDONE/XQNTREE)*XPDIDTOT):1:XPDIDTOT D UPDATE^XPDID(%) H .25 - I $D(XQFG),XPDIDVT D UPDATE^XPDID(XPDIDTOT) - I $D(XQFG) W !!,"Menu Rebuild Complete: ",$$HTE^XLFDT($H) - ; - ; - H 2 - ;If we're not from KIDS then clean it up, otherwise let kids do it. - I '$D(XPDNM) D - .D EXIT^XPDID() - .K XPDIDVT,XPDIDTOT - .Q - ; - I $D(XQSAVTOT) S XPDIDTOT=XQSAVTOT - K %,VALMCOFF,VALMCON,VALMIOXY,VALMSGR,VALMWD,XQFG,XQNDONE,XQNTREE,XQSAVTOT - Q - ; - ;================================Subroutines========================== - ; -MERGET ;Merge ^TMP("XQO",$J) into ^DIC(19,"AXQ") - N Q,X,XQFLAG,Y S X="P",XQFLAG=0,Q="""" - I $D(XQFG) W !!,"Merging...." - F S X=$O(^TMP("XQO",$J,X)) Q:X="" D - .L +^DIC(19,"AXQ",X):2 I '$T S XQFLAG=1 Q - .S %X="^TMP(""XQO"","_$J_","_Q_X_Q_"," - .S %Y="^DIC(19,""AXQ"","_Q_X_Q_"," - .K ^DIC(19,"AXQ",X) - .;M ^DIC(19,"AXQ",X)=^TMP("XQO",$J,X) - .D %XY^%RCR - .L -^DIC(19,"AXQ",X) - .K %X,%Y - .Q - ; - I XQFLAG,$D(XQFG) D - .N %,Y - .S Y=$P(X,"P",2) Q:Y="" - .S %=$G(^DIC(19,Y,0)) Q:%="" - .S Y=$P(%,"^",2) Q:%="" - .W !,?12,"Could not merge menu: "_Y - .Q - Q - ; -CLEAN ;Clean out unused menu trees from ^DIC(19,"AXQ") - N X,Y S X="P" - F S X=$O(^DIC(19,"AXQ",X)) Q:X="" D - .I X'="PXU" D - ..S Y=$E(X,2,99) - ..I '$D(^TMP($J,Y))&('$D(^TMP($J,"SEC",Y))) K ^DIC(19,"AXQ",X),^XUTL("XQO",X) - ..Q - .Q - Q - ; -MERGEX ;Merge ^DIC(19,"AXQ") into ^XUTL("XQO") - N Q,X,XQFLAG,Y S X="P",XQFLAG=0,Q="""" - F S X=$O(^DIC(19,"AXQ",X)) Q:X="" D - .L +^XUTL("XQO",X):2 I '$T S XQFLAG=1 Q - .S %X="^DIC(19,""AXQ"","_Q_X_Q_"," - .S %Y="^XUTL(""XQO"","_Q_X_Q_"," - .K ^XUTL("XQO",X) - .;M ^XUTL("XQO",X)=^DIC(19,"AXQ",X) - .D %XY^%RCR - .L -^XUTL("XQO",X) - .K %X,%Y - .Q - ; - I XQFLAG,$D(XQFG) D - .N %,Y - .S Y=$P(X,"P",2) Q:Y="" - .S %=$G(^DIC(19,Y,0)) Q:%="" - .S Y=$P(%,"^",2) Q:%="" - .W !,?12,"Could not merge menu: "_Y - .Q - ; - I 'XQFLAG,$D(XQFG) W " done." - Q - ; -STATUS() ;Are the menus being rebuilt even as we speak? - N %,XQTHEN - S %=$G(^DIC(19,"AXQ","P0")) I %="" Q 1 ;It finished. Never mind. - L +^DIC(19,"AXQ","P0"):0 ;If job is still running we can't lock it - I $T L -^DIC(19,"AXQ","P0") K ^("P0") Q 1 ;Job must have failed - Q 0 - ; - ; -MICRO ;Turn off micro surgery - I $D(^DIC(19,"AXQ","P0","MICRO")) D - .S ^DIC(19,"AXQ","P0","STOP")=$H ;Turn off micro-surgery - .K ^DIC(19,"AXQ","P0","MICRO") - .H 2 - .Q - Q - ; - ; -ERR ;Come here on error - N XQERROR - S XQERROR=$$EC^%ZOSV - D ^%ZTER - D EXIT^XPDID() - G UNWIND^%ZTER - Q - ; -BLDEND1 ;Quit and clean - K %,%H,%TG,C,D,DIC,DIR,I,J,K,L,V,XQBSEC,X,Y,Z,XQL,XQN,XQRE,XQK,XQI,XQII,UU,XQH,XQPX,XQSAV,XQXUF,XQ81T,XQDATE,XQSEC,XQVE,XQBLD,XQP,XQR,XQJ - Q +XQ81 ;SEA/AMF/LUKE,SF/RWF - Build menu trees ;03/03/2003 10:00 + ;;8.0;KERNEL;**81,116,157,253**;Jul 10, 1995 +BUILD ; + ; +RD2 N XQSTAT S XQSTAT=$$STATUS() + I 'XQSTAT W !!,"Some one else is rebuilding menus. Sorry." Q + K ZTSK + D MICRO ;Turn off micro surgery for now + ; + S XQSTART=$$HTE^XLFDT($H) + K XQFG W !!,"This option will build menu trees for each primary and secondary menu.",!,"You may build all the trees, or build them selectively, using 'verify'.",!,"Note that the 'compiled menus' will only be built into ^XUTL on this CPU.",! + S DIR(0)="Y",DIR("A")="Do you wish to verify each primary menu",DIR("B")="NO",DIR("??")="XQBUILDTREE-VER" D ^DIR K DIR G:$D(DIRUT) BLDEND S XQVE=(Y=1) + S DIR(0)="Y",DIR("A")="Would you like to build secondary menu trees too",DIR("B")="YES",DIR("??")="XQBUILDTREE-SEC" D ^DIR G:$D(DIRUT) BLDEND S XQBSEC=(Y=1) + ; + I 'XQVE S DIR(0)="Y",DIR("A")="Would you like to queue this job",DIR("B")="YES" D ^DIR K DIR G:$D(DIRUT) BLDEND I Y=1 D + .S ZTRTN="QUE^XQ81",ZTIO="" + .S ZTSAVE("XQVE")="",ZTSAVE("XQBSEC")="",ZTSAVE("XQSTART")="" + .S ZTDESC="Build menu trees in ^DIC(19,""AXQ"")" + .D ^%ZTLOAD + .I $D(ZTSK),'XQVE W !!,"Task #: ",ZTSK,! + .Q + ; + I $D(ZTSK) K ^DIC(19,"AXQ","P0") S XQALLDON="" G BLDEND + E S ^DIC(19,"AXQ","P0")=$H L +^DIC(19,"AXQ","P0") + ; + I 'XQVE S DIR(0)="Y",DIR("A")="Do you really wish to run this DIRECTLY (it may take some time)",DIR("B")="NO" D ^DIR K DIR G:$D(DIRUT) BLDEND G:Y'=1 RD2 + ; +KIDS ;Entry from KIDS + I '$D(XQSTAT),$D(^DIC(19,"AXQ","P0")) S XQSTAT=$$STATUS I 'XQSTAT W !!," Some one else is building menus. Sorry." K XQSTAT Q + I '$D(^DIC(19,"AXQ","P0","STOP")) D MICRO + I '$D(^DIC(19,"AXQ","P0")) S ^DIC(19,"AXQ","P0")=$H L +^DIC(19,"AXQ","P0") + I '$D(XQVE) S XQFG=0,XQBSEC=1,XQVE=0 + N XQNTREE,XQNDONE S (XQNTREE,XQNDONE)=0 + ; + ;Set up the error trap so we can clear the screen if it blows + I $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERR^XQ81" + E S X="ERR^XQ81",@^%ZOSF("TRAP") + ; + ;Set up the bar graph and window if not from KIDS + I '$D(XPDNM) D INIT^XPDID + I XPDIDVT D + .I $D(XPDIDTOT) S XQSAVTOT=XPDIDTOT + .S X="Rebuilding Menus" D TITLE^XPDID(X) + .S XPDIDTOT=50 ;Number of divisions in bar graph + .D UPDATE^XPDID(0) + .Q + ; + S XQSTART=$$HTE^XLFDT($H) + W !!,"Starting Menu Rebuild: ",XQSTART + S XQFG=0 W !!,"Collecting primary menus in the New Person file..." + ; +DQ ;Entry from taskman Write if $D(XQFG) + K ZTREQ + I '$D(XQSTART) S XQSTART=$$HTE^XLFDT($H) + N XQNOW,XQ8FLG,XQTASK + S XQ8FLG=0 + S:'$D(XQNOW) XQNOW=$H + S ^DIC(19,"AXQ","P0")=XQNOW + S ^DIC(19,"AXQ","P0","STOP")=XQNOW ;Stop micro surgery if it's running + ; + S XQSEC=1,XQ81T="" I 'XQVE H 1 + S XQI="" F XQK=0:0 S XQI=$O(^TMP("XQO",$J,XQI)) Q:XQI'=+XQI!(XQI="") I $D(^TMP("XQO",$J,XQI,0))#2 S $P(^(0),U,2)="" + S XQI="U" F XQK=0:0 S XQI=$O(^TMP("XQO",$J,XQI)) Q:"U"'[$E(XQI)!(XQI="") I $D(^TMP("XQO",$J,XQI,0))#2 S $P(^(0),U,2)="" + S XQI="P" F XQK=0:0 S XQI=$O(^TMP("XQO",$J,XQI)) Q:"P"'[$E(XQI)!(XQI="") I $D(^TMP("XQO",$J,XQI,0))#2,$L(^(0)) S XQ81T=^(0) Q + S:XQ81T="" XQ81T="Unknown" + S XQI="P" F XQK=0:0 S XQI=$O(^TMP("XQO",$J,XQI)) Q:"P"'[$E(XQI)!(XQI="") I "P"[$E(XQI),XQI'="P0" K ^TMP("XQO",$J,XQI) + ; + ;Find the various trees and put them into ^TMP($J), and count them + S:'$D(XQH) XQH=$H K ^TMP($J) S XQI=.5 F XQK=0:0 S XQI=$O(^VA(200,XQI)) Q:XQI'=+XQI I $D(^VA(200,XQI,0)),$L($P(^VA(200,XQI,0),U,3)) D SET + ; + S (XQNTREE,%)=0 F S %=$O(^TMP($J,%)) Q:%="" S XQNTREE=XQNTREE+1 + S %=0 F S %=$O(^TMP($J,"SEC",%)) Q:%="" S XQNTREE=XQNTREE+1 + ; + W:$D(XQFG) !!?20,"Primary menus found in the New Person file",!?20,"------------------------------------------" + W:$D(XQFG) !!,"OPTION NAME MENU TEXT",?49,"# OF",?62,"LAST",?71,"LAST",!?49,"USERS",?62,"USED",?71,"BUILT",! + S X="" F XQBLD=0:0 S XQBLD=$O(^TMP($J,XQBLD)) Q:XQBLD'>0!(X=U) I $D(^DIC(19,XQBLD,0)) S XQJ=^DIC(19,XQBLD,0) D VER + S XQSEC=0 I $D(XQFG),XQBSEC W !!,"Building secondary menu trees...." + I XQBSEC S X="" F XQBLD=0:0 S XQBLD=$O(^TMP($J,"SEC",XQBLD)) Q:XQBLD'>0 D SEC + I 'XQVE S XQK="P" F XQBLD=0:0 S XQK=$O(^TMP("XQO",$J,XQK)) Q:XQK'["P" S ^(XQK,0)=XQH + G BLDEND + ; +SEC S XQL="P"_XQBLD Q:$D(^TMP("XQO",$J,XQL)) D RD3 Q + S XQL="P" F XQN=0:0 S XQL=$O(^TMP("XQO",$J,XQL)) Q:$E(XQL)'="P" I $D(^TMP("XQO",$J,XQL,"^",XQBLD)) Q + D:$E(XQL)'="P" RD3 + Q + ; +VER I $D(XQFG) D + .N XQMT,XQOPNM + .S XQK=$P(^TMP($J,XQBLD),U,2) + .S:$L(XQK) XQK=$E(XQK,4,5)_"/"_$E(XQK,6,7)_"/"_$E(XQK,2,3) + .S XQOPNM=$P(XQJ,U) + .S XQMT=$P(XQJ,U,2) I $L(XQMT)>28 S XQMT=$E(XQMT,1,25)_"..." + .W !,$P(XQJ,U,1) + .W:($L(XQOPNM)>20) ! + .W ?20,XQMT,?49,+^TMP($J,XQBLD),?60,XQK + .Q + ; + I $D(XQFG) S:$D(^DIC(19,"AXQ","P"_XQBLD,0)) XQ81T=+^(0) I $L(XQ81T) S %H=XQ81T D YMD^%DTC S XQK=X W ?71,$E(XQK,4,5),"/",$E(XQK,6,7),"/",$E(XQK,2,3) + ; +RD3 ;Update counter an rebuild it if necessary + I $D(XQFG),XPDIDVT D + .N % + .S XQNDONE=XQNDONE+1 + .S %=(XQNDONE/XQNTREE)*XPDIDTOT + .D UPDATE^XPDID(%) + .Q + ; + S XQDIC="P"_XQBLD D CHK^XQ8 I XQRE W:$D(XQFG) !,"SOMEONE ELSE IS CURRENTLY REBUILDING THIS MENU" Q + I XQVE,XQSEC S DIR(0)="Y",DIR("A")="Rebuild",DIR("B")="YES" D ^DIR Q:$D(DIRUT) W ! Q:Y'=1 + S XQFG1=1 D PM2^XQ8 + I $D(ZTQUEUED) S ZTREQ="@" + Q + ; +SET G:'$D(^VA(200,XQI,201)) SET1 S XQK=+^(201) Q:'$L(XQK) ;I $D(XQFG) W:'(XQI#10) "." + S XQR="" S:$D(^VA(200,XQI,1.1)) XQR=$P(^(1.1),".",1) S XQP=1_U_XQR + I $D(^TMP($J,XQK)) S XQP=^TMP($J,XQK) S XQP=XQP+1_U_$S(XQR>$P(XQP,U,2):XQR,1:$P(XQP,U,2)) + I $D(^DIC(19,XQK,0)),$P(^(0),U,4)="M" S ^TMP($J,XQK)=XQP + ; +SET1 I XQBSEC F XQN=0:0 S XQN=$O(^VA(200,XQI,203,XQN)) Q:XQN'>0 S XQL=+^(XQN,0) I $D(^DIC(19,XQL,0)),$P(^(0),U,4)="M" S ^TMP($J,"SEC",XQL)="" + Q + ; +QUE ;Entry point for the option XQBUILDTREEQUE, and XQBUILDALL + ;Also called by CHEK^XQ83 + S XQVE=0,XQBSEC=1 K XQFG + S XQSTART=$$HTE^XLFDT($H) + G DQ + ; +BLDEND ;File a report, cleanup, and quit. + ; + K %,%H,%TG,C,D,DIC,DIR,I,J,K,L,V,XQBSEC,X,Y,Z,XQL,XQN,XQRE,XQK,XQI,XQII,UU,XQH,XQPX,XQSAV,XQXUF,XQ81T,XQDATE,XQSEC,XQVE,XQBLD,XQP,XQR,XQJ + ; + I $D(XQALLDON) K XQALLDON Q ;Quit here if we're just creating a task + ; + D MERGET + D CLEAN + D MERGEX + ; + K ^TMP($J),^TMP("XQO",$J) + ; + ;Clear the flags and locks. + K ^XUTL("XQMERGED") ;Menues merged since last rebuild REACT^XQ84 + K ^DIC(19,"AT") ;Micro message nodes + S ^XUTL("XQ","MICRO")=0 ;Number of Micro instances since last build + K ^DIC(19,"AXQ","P0","STOP") ;Allow Micro surgery to start up + K ^DIC(19,"AXQ","P0") ;Clear the rebuild flag (redundant, I know) + L -^DIC(19,"AXQ","P0") ;Unlock the rebuild flag, everybody's good to go + ; + S %=$S($D(XPDNM):"KIDS",$D(ZTSK):"QUEUED",1:"LIVE") + D REPORT^XQ84(%) + K XQSTART,ZTSK + ; + I '$D(XPDIDVT) K XQFG Q + ; + I $D(XQFG),XPDIDVT F %=((XQNDONE/XQNTREE)*XPDIDTOT):1:XPDIDTOT D UPDATE^XPDID(%) H .25 + I $D(XQFG),XPDIDVT D UPDATE^XPDID(XPDIDTOT) + I $D(XQFG) W !!,"Menu Rebuild Complete: ",$$HTE^XLFDT($H) + ; + ; + H 2 + ;If we're not from KIDS then clean it up, otherwise let kids do it. + I '$D(XPDNM) D + .D EXIT^XPDID() + .K XPDIDVT,XPDIDTOT + .Q + ; + I $D(XQSAVTOT) S XPDIDTOT=XQSAVTOT + K %,VALMCOFF,VALMCON,VALMIOXY,VALMSGR,VALMWD,XQFG,XQNDONE,XQNTREE,XQSAVTOT + Q + ; + ;================================Subroutines========================== + ; +MERGET ;Merge ^TMP("XQO",$J) into ^DIC(19,"AXQ") + N Q,X,XQFLAG,Y S X="P",XQFLAG=0,Q="""" + I $D(XQFG) W !!,"Merging...." + F S X=$O(^TMP("XQO",$J,X)) Q:X="" D + .L +^DIC(19,"AXQ",X):2 I '$T S XQFLAG=1 Q + .S %X="^TMP(""XQO"","_$J_","_Q_X_Q_"," + .S %Y="^DIC(19,""AXQ"","_Q_X_Q_"," + .K ^DIC(19,"AXQ",X) + .;M ^DIC(19,"AXQ",X)=^TMP("XQO",$J,X) + .D %XY^%RCR + .L -^DIC(19,"AXQ",X) + .K %X,%Y + .Q + ; + I XQFLAG,$D(XQFG) D + .N %,Y + .S Y=$P(X,"P",2) Q:Y="" + .S %=$G(^DIC(19,Y,0)) Q:%="" + .S Y=$P(%,"^",2) Q:%="" + .W !,?12,"Could not merge menu: "_Y + .Q + Q + ; +CLEAN ;Clean out unused menu trees from ^DIC(19,"AXQ") + N X,Y S X="P" + F S X=$O(^DIC(19,"AXQ",X)) Q:X="" D + .I X'="PXU" D + ..S Y=$E(X,2,99) + ..I '$D(^TMP($J,Y))&('$D(^TMP($J,"SEC",Y))) K ^DIC(19,"AXQ",X),^XUTL("XQO",X) + ..Q + .Q + Q + ; +MERGEX ;Merge ^DIC(19,"AXQ") into ^XUTL("XQO") + N Q,X,XQFLAG,Y S X="P",XQFLAG=0,Q="""" + F S X=$O(^DIC(19,"AXQ",X)) Q:X="" D + .L +^XUTL("XQO",X):2 I '$T S XQFLAG=1 Q + .S %X="^DIC(19,""AXQ"","_Q_X_Q_"," + .S %Y="^XUTL(""XQO"","_Q_X_Q_"," + .K ^XUTL("XQO",X) + .;M ^XUTL("XQO",X)=^DIC(19,"AXQ",X) + .D %XY^%RCR + .L -^XUTL("XQO",X) + .K %X,%Y + .Q + ; + I XQFLAG,$D(XQFG) D + .N %,Y + .S Y=$P(X,"P",2) Q:Y="" + .S %=$G(^DIC(19,Y,0)) Q:%="" + .S Y=$P(%,"^",2) Q:%="" + .W !,?12,"Could not merge menu: "_Y + .Q + ; + I 'XQFLAG,$D(XQFG) W " done." + Q + ; +STATUS() ;Are the menus being rebuilt even as we speak? + N %,XQTHEN + S %=$G(^DIC(19,"AXQ","P0")) I %="" Q 1 ;It finished. Never mind. + L +^DIC(19,"AXQ","P0"):0 ;If job is still running we can't lock it + I $T L -^DIC(19,"AXQ","P0") K ^("P0") Q 1 ;Job must have failed + Q 0 + ; + ; +MICRO ;Turn off micro surgery + I $D(^DIC(19,"AXQ","P0","MICRO")) D + .S ^DIC(19,"AXQ","P0","STOP")=$H ;Turn off micro-surgery + .K ^DIC(19,"AXQ","P0","MICRO") + .H 2 + .Q + Q + ; + ; +ERR ;Come here on error + N XQERROR + S XQERROR=$$EC^%ZOSV + D ^%ZTER + D EXIT^XPDID() + G UNWIND^%ZTER + Q diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALDATA.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALDATA.m index 94672815..bc2eba5d 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALDATA.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALDATA.m @@ -1,56 +1,54 @@ -XQALDATA ;ISC-SF/JLI - PROVIDE DATA ON ALERTS ;4/9/07 13:39 - ;;8.0;KERNEL;**207,285,443**;Jul 10, 1995;Build 4 - Q -GETUSER(ROOT,XQAUSER,FRSTDATE,LASTDATE) ; - N XREF,XVAL,X,X2,X3,I,NCNT ; P443 - S:$G(XQAUSER)'>0 XQAUSER=DUZ - S:$G(FRSTDATE)'>0 FRSTDATE=0 - S:$G(LASTDATE)'>0 LASTDATE=0 - S NCNT=0 K @ROOT - I FRSTDATE=0 D Q - . F I=0:0 S I=$O(^XTV(8992,XQAUSER,"XQA",I)) Q:I'>0 S X=^(I,0),X3=$G(^(3)),X2=$G(^(2)) D - . . S NCNT=NCNT+1 - . . S @ROOT@(NCNT)=$S($P(X3,U)'="":"G ",$P(X,U,7,8)="^ ":"I ",1:" ")_$P(X,U,3)_U_$P(X,U,2)_$S($P(X2,U,3)'="":U_$P(X2,U,3),1:"") ; P443 - . S @ROOT=NCNT - S XREF="R" - S XVAL=XQAUSER - D CHKTRAIL - Q -GETPAT(ROOT,PATIENT,FRSTDATE,LASTDATE) ; - N XREF,XVAL,NCNT - S NCNT=0 K @ROOT - I $G(PATIENT)'>0 S @ROOT=0 Q - S XREF="C" - S XVAL=PATIENT - D CHKTRAIL - Q -CHKTRAIL ; - N XQ1,X,X1,X2,X3 - ; ZEXCEPT: FRSTDATE,LASTDATE,NCNT,ROOT,XREF,XVAL -- from GETPAT or GETUSER - F XQ1=0:0 S XQ1=$O(^XTV(8992.1,XREF,XVAL,XQ1)) Q:XQ1'>0 D - . S X=$G(^XTV(8992.1,XQ1,0)),X1=$G(^(1)),X3=$G(^(3)),X2=$G(^(2)) Q:X="" - . I FRSTDATE'>0,'$D(^XTV(8992,"AXQA",$P(X,U))) Q - . I FRSTDATE>0,$P(X,U,2)0,LASTDATE>0,$P(X,U,2)>LASTDATE Q - . S NCNT=NCNT+1 - . S @ROOT@(NCNT)=$S($P(X3,U)'="":"G ",$P(X1,U,2,3)="^":"I ",$P(X1,U,2,3)="":"I ",1:" ")_$P(X1,U)_U_$P(X,U)_$S($P(X2,U,3)'="":U_$P(X2,U,3),1:"") ; P443 - S @ROOT=NCNT - Q -GETUSER1(ROOT,XQAUSER,FRSTDATE,LASTDATE) ; - N NCNT,KEY - S:$G(XQAUSER)'>0 XQAUSER=DUZ - S:$G(FRSTDATE)'>0 FRSTDATE=0 - S:$G(LASTDATE)'>0 LASTDATE=0 - S NCNT=0 K @ROOT - I FRSTDATE=0 D Q - . N X,X2,X3,X4,I S I="" F S I=$O(^XTV(8992,XQAUSER,"XQA",I),-1) Q:I'>0 S X=^(I,0),X2=$G(^(2)),X3=$G(^(3)),X4=$D(^(4)) D - . . I $P(X,U,4)'="" S $P(^XTV(8992,XQAUSER,"XQA",I,0),U,4)="" ; MARK SEEN - . . S NCNT=NCNT+1 - . . S KEY=$S($P(X3,U)'="":"G ",X4>1:"L ",$P(X,U,7,8)="^ ":"I ",1:"R "),@ROOT@(NCNT)=KEY_$P(X,U,3)_U_$P(X,U,2) - . . I X2'="" D - . . . S NCNT=NCNT+1,@ROOT@(NCNT)=KEY_"-----Forwarded by: "_$$GET1^DIQ(200,($P(X2,U)_","),.01)_" Generated: "_$$DAT8^XQALERT($P(X2,U,2),1)_U_$P(X,U,2) - . . . I $P(X2,U,3)'="" S NCNT=NCNT+1,@ROOT@(NCNT)=KEY_"-----"_$P(X2,U,3)_U_$P(X,U,2) - . . . Q - . S @ROOT=NCNT - . Q - Q +XQALDATA ;ISC-SF/JLI - PROVIDE DATA ON ALERTS ;9/9/03 15:13 + ;;8.0;KERNEL;**207,285**;Jul 10, 1995 + Q +GETUSER(ROOT,XQAUSER,FRSTDATE,LASTDATE) ; + N XREF,XVAL + S:$G(XQAUSER)'>0 XQAUSER=DUZ + S:$G(FRSTDATE)'>0 FRSTDATE=0 + S:$G(LASTDATE)'>0 LASTDATE=0 + S NCNT=0 K @ROOT + I FRSTDATE=0 D Q + . F I=0:0 S I=$O(^XTV(8992,XQAUSER,"XQA",I)) Q:I'>0 S X=^(I,0),X3=$G(^(3)) D + . . S NCNT=NCNT+1 + . . S @ROOT@(NCNT)=$S($P(X3,U)'="":"G ",$P(X,U,7,8)="^ ":"I ",1:" ")_$P(X,U,3)_U_$P(X,U,2) + . S @ROOT=NCNT + S XREF="R" + S XVAL=XQAUSER + D CHKTRAIL + Q +GETPAT(ROOT,PATIENT,FRSTDATE,LASTDATE) ; + N XREF,XVAL + S NCNT=0 K @ROOT + I $G(PATIENT)'>0 S @ROOT=0 Q + S XREF="C" + S XVAL=PATIENT + D CHKTRAIL + Q +CHKTRAIL ; + F XQ1=0:0 S XQ1=$O(^XTV(8992.1,XREF,XVAL,XQ1)) Q:XQ1'>0 D + . S X=$G(^XTV(8992.1,XQ1,0)),X1=$G(^(1)),X3=$G(^(3)) Q:X="" + . I FRSTDATE'>0,'$D(^XTV(8992,"AXQA",$P(X,U))) Q + . I FRSTDATE>0,$P(X,U,2)0,LASTDATE>0,$P(X,U,2)>LASTDATE Q + . S NCNT=NCNT+1 + . S @ROOT@(NCNT)=$S($P(X3,U)'="":"G ",$P(X1,U,2,3)="^":"I ",$P(X1,U,2,3)="":"I ",1:" ")_$P(X1,U)_U_$P(X,U) + S @ROOT=NCNT + Q +GETUSER1(ROOT,XQAUSER,FRSTDATE,LASTDATE) ; + N NCNT,KEY + S:$G(XQAUSER)'>0 XQAUSER=DUZ + S:$G(FRSTDATE)'>0 FRSTDATE=0 + S:$G(LASTDATE)'>0 LASTDATE=0 + S NCNT=0 K @ROOT + I FRSTDATE=0 D Q + . N X,X2,X3,X4,I S I="" F S I=$O(^XTV(8992,XQAUSER,"XQA",I),-1) Q:I'>0 S X=^(I,0),X2=$G(^(2)),X3=$G(^(3)),X4=$D(^(4)) D + . . I $P(X,U,4)'="" S $P(^XTV(8992,XQAUSER,"XQA",I,0),U,4)="" ; MARK SEEN + . . S NCNT=NCNT+1 + . . S KEY=$S($P(X3,U)'="":"G ",X4>1:"L ",$P(X,U,7,8)="^ ":"I ",1:"R "),@ROOT@(NCNT)=KEY_$P(X,U,3)_U_$P(X,U,2) + . . I X2'="" D + . . . S NCNT=NCNT+1,@ROOT@(NCNT)=KEY_"-----Forwarded by: "_$$GET1^DIQ(200,($P(X2,U)_","),.01)_" Generated: "_$$DAT8^XQALERT($P(X2,U,2),1)_U_$P(X,U,2) + . . . I $P(X2,U,3)'="" S NCNT=NCNT+1,@ROOT@(NCNT)=KEY_"-----"_$P(X2,U,3)_U_$P(X,U,2) + . . . Q + . S @ROOT=NCNT + . Q + Q diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALDEL.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALDEL.m index d9a6236e..b9fb6662 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALDEL.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALDEL.m @@ -1,175 +1,175 @@ -XQALDEL ;ISC-SF.SEA/JLI - DELETE ALERTS ;4/9/07 15:13 - ;;8.0;KERNEL;**6,24,65,114,174,285,443**;Jul 10, 1995;Build 4 - ;; - Q - ; -DELETE ; - N XQAFOUND,XQADAT,XQX,XQK,XQXX,XQXY,XQJ,XQAID1 - Q:'$D(XQAID) Q:XQAID="" S:'$D(XQAKILL) XQAKILL=0 S:$P(XQAID,";")="NO-ID" XQAKILL=1 - S XQADAT=$$NOW^XLFDT() - I '$D(XQAUSER) N XQAUSER S XQAUSER=DUZ - S XQAFOUND=0 D - . S XQX=XQAUSER F XQK=0:0 S XQK=$O(^XTV(8992,XQAUSER,"XQA",XQK)) Q:XQK'>0 I $P(^(XQK,0),U,2)=XQAID S XQAFOUND=1 Q - S XQXX=$O(^XTV(8992.1,"B",XQAID,0)) I XQXX>0 S XQXY=$O(^XTV(8992.1,XQXX,20,"B",XQAUSER,0)) I XQXY>0,XQAFOUND,'$G(XQAUSERD) S $P(^XTV(8992.1,XQXX,20,XQXY,0),U,4)=XQADAT - K XQXX,XQXY - I '$D(^XTV(8992,"AXQA",XQAID,XQAUSER)) D KILLOC - F XQX=0:0 S XQX=$O(^XTV(8992,"AXQA",XQAID,XQX)) Q:XQX'>0 D Q:XQAKILL - . I XQAKILL S XQX=XQAUSER ; Make sure XQAKILL gets only XQAUSER - . F XQK=0:0 S XQK=$O(^XTV(8992,"AXQA",XQAID,XQX,XQK)) Q:XQK'>0 K ^(XQK),^XTV(8992,"AXQAN",$P(XQAID,";"),XQX,XQK) S XQAID1=XQAID D:$D(^XTV(8992,XQX,"XQA",XQK,0)) DELA S XQAID=XQAID1 - K XQAID,XQX,XQJ,XQK,XQAID1,XQAKILL - Q - ; -DELETEA ; - N XQA1,XQADAT,XQAFOUND,XQX,XQXX,XQXY,XQK,XQJ - Q:'$D(XQAID) Q:XQAID="" S XQA1=$P(XQAID,";") - S XQADAT=$$NOW^XLFDT() - I '$D(XQAUSER) N XQAUSER S XQAUSER=DUZ - S:'$D(XQAKILL) XQAKILL=0 G:$P(XQAID,";")="NO-ID" DELETE - S XQAFOUND=0 D - . S XQX=XQAUSER F XQK=0:0 S XQK=$O(^XTV(8992,XQAUSER,"XQA",XQK)) Q:XQK'>0 I $P($G(^(XQK,0)),U,2)=XQAID S XQAFOUND=1 Q - S XQXX=$O(^XTV(8992.1,"B",XQAID,0)) I XQXX>0 S XQXY=$O(^XTV(8992.1,XQXX,20,"B",XQAUSER,0)) I XQXY>0,XQAFOUND,'$G(XQAUSERD) S $P(^XTV(8992.1,XQXX,20,XQXY,0),U,4)=XQADAT - I '$D(^XTV(8992,"AXQAN",XQA1,XQAUSER)) D KILLOC - I $P(XQAID,",",2)'=""!($P(XQAID,";",2)="") F XQX=0:0 S XQX=$O(^XTV(8992,"AXQAN",XQA1,XQX)) Q:XQX'>0 D Q:XQAKILL - . I XQAKILL S XQX=XQAUSER - . F XQK=0:0 S XQK=$O(^XTV(8992,"AXQAN",XQA1,XQX,XQK)) Q:XQK'>0 K ^(XQK) I $D(^XTV(8992,XQX,"XQA",XQK,0)) D DELA - I $P(XQAID,",",2)=""&($P(XQAID,";",2)'="") F XQX=0:0 S XQX=$O(^XTV(8992,"AXQA",XQAID,XQX)) Q:XQX'>0 D Q:XQAKILL - . I XQAKILL S XQX=XQAUSER - . S XQK=$O(^XTV(8992,"AXQA",XQAID,XQX,0)) Q:XQK'>0 K ^(XQK),^XTV(8992,"AXQAN",XQA1,XQX,XQK) I $D(^XTV(8992,XQX,"XQA",XQK,0)) D DELA - K XQAID,XQA1,XQX,XQK,XQAKILL - Q -DELA ; - N XQDEL11 S XQAID=$P($G(^XTV(8992,XQX,"XQA",XQK,0)),U,2),XQDEL11=$P($G(^(0)),U) K ^XTV(8992,XQX,"XQA",XQK) K:XQAID'="" ^XTV(8992,"AXQA",XQAID,XQX,XQK) - D COUNT(-1,XQX) - K:XQAID'="" ^XTV(8992,"AXQAN",$P(XQAID,";"),XQX,XQK) K:XQDEL11'="" ^XTV(8992,XQX,"XQA","B",XQDEL11,XQK) - S XQXX=$S(XQAID'="":$O(^XTV(8992.1,"B",XQAID,0)),1:0) I XQXX>0 S XQXY=$O(^XTV(8992.1,XQXX,20,"B",XQX,0)) I XQXY>0,$P(^XTV(8992.1,XQXX,20,XQXY,0),U,5)'>0 S $P(^(0),U,5)=XQADAT I $G(XQAUSERD) S $P(^(0),U,9)=DUZ - K XQXX,XQXY - Q - ; -COUNT(%1,%2) ;Change the count on the zero node, (amount, user) - Q:$G(%2)'>0 - L +^XTV(8992,%2):10 - I %1 S %=$P($G(^XTV(8992,%2,"XQA",0)),U,4)+%1 S:%'<0 $P(^(0),U,4)=% - I '%1 D - . N % S %1=0,%=0 F S %=$O(^XTV(8992,%2,"XQA",%)) Q:%'>0 S %1=%1+1 - . S $P(^XTV(8992,%2,"XQA",0),U,4)=%1 - L -^XTV(8992,%2) - Q -KILLOC ; - N XQX,XQK - S XQX=XQAUSER F XQK=0:0 S XQK=$O(^XTV(8992,XQAUSER,"XQA",XQK)) Q:XQK'>0 I $P(^(XQK,0),U,2)=XQAID D - . N XQAID D DELA - Q - ; -OLDDEL ; - N XQADAT,X2,XQDAT,XQDEL1 - S XQADAT=$$NOW^XLFDT() - S X2=-15 I $G(ZTQPARAM)>0 S X2=-ZTQPARAM - S XQDAT=$$FMADD^XLFDT(DT,X2) - ;Loop thru users (XQDEL1) levels - F XQDEL1=0:0 S XQDEL1=$O(^XTV(8992,XQDEL1)) Q:XQDEL1'>0 D OLDDEL1 - D KILLARCH - K X1,X2,X,XQDEL1,XQDEL2,XQDAT,XQA,XQADAT - Q -OLDDEL1 ;Loop thru the Alert (XQDEL2) level - L +^XTV(8992,XQDEL1):10 - N XQAGLOB,KILLOLD,XQAZERO,XQAUSER,XQLIST,Y,XQAV,XQPRAMTY,XQDEL2,XQA - S XQAGLOB=$NA(^XTV(8992,XQDEL1,"XQA")),XQAUSER=XQDEL1 - F XQDEL2=0:0 S XQDEL2=$O(@XQAGLOB@(XQDEL2)) Q:XQDEL2'>0 S XQAZERO=^(XQDEL2,0) D - . ; CHECK FOR BACKUP REVIEWER TO FORWARD ALERTS NEEDING ACTION -- P174 - . I $P(XQAZERO,U,15)>0 I $$FMADD^XLFDT(+XQAZERO,+$P(XQAZERO,U,15))\1=DT D Q:$D(KILLOLD) ; changed '>DT to =DT so only send once without killing - . . N XQA D GETBKUP(.XQA,XQDEL1) - . . I $D(XQA) S XQALTYPE="BACKUP REVIEWER" D FORWARD^XQALFWD($P(XQAZERO,U,2),.XQA,"A","ALERT NOT PROCESSED BY "_$$GET1^DIQ(200,XQDEL1_",",.01)) S KILLOLD=1 - . . Q ; End of Backup Reviewer Code -- P174 - . I $P(XQAZERO,U,13)>0 I $$FMADD^XLFDT(+XQAZERO,+$P(XQAZERO,U,13))\1=DT D Q:$D(KILLOLD) ; P174 - . . N XQA,I F I=0:0 S I=$O(^XMB(3.7,XQAUSER,9,I)) Q:I'>0 S XQAV=+^(I,0),XQA(XQAV)=XQAV - . . I $D(XQA) S XQALTYPE="EMAIL SURROGATE" D FORWARD^XQALFWD($P(XQAZERO,U,2),.XQA,"A","ALERT NOT PROCESSED BY "_$$GET1^DIQ(200,XQDEL1_",",.01)) S KILLOLD=1 - . . Q - . I $P(XQAZERO,U,14)>0 I $$FMADD^XLFDT(+XQAZERO,+$P(XQAZERO,U,14))\1=DT D Q:$D(KILLOLD) ; P174 - . . N XQA,I S I=$P($G(^VA(200,XQAUSER,5)),U) I I>0 S I=$P($G(^DIC(49,+I,0)),U,3) I I>0,$D(^VA(200,+I,0)) S XQA(+I)=+I - . . I $D(XQA) S XQALTYPE="CHIEF/SUPERVISOR" D FORWARD^XQALFWD($P(XQAZERO,U,2),.XQA,"A","ALERT NOT PROCESSED BY "_$$GET1^DIQ(200,XQDEL1_",",.01)) S KILLOLD=1 - . . Q - . I XQDEL2'>XQDAT D OLDDEL2 - . Q - K:$O(^XTV(8992,XQDEL1,"XQA",0))="" ^XTV(8992,XQDEL1,"XQA") - L -^XTV(8992,XQDEL1) - Q - ; -OLDDEL2 ; - N XQA,XQXX,XQXY - S XQA=$P(^XTV(8992,XQDEL1,"XQA",XQDEL2,0),U,2) K ^XTV(8992,XQDEL1,"XQA",XQDEL2) K:XQA'="" ^XTV(8992,"AXQA",XQA,XQDEL1),^XTV(8992,"AXQAN",$P(XQA,";"),XQDEL1) - D COUNT(-1,XQDEL1) - I XQA'="" S XQXX=$O(^XTV(8992.1,"B",XQA,0)) I XQXX>0 S XQXY=$O(^XTV(8992.1,XQXX,20,"B",XQDEL1,0)) I XQXY>0 S $P(^XTV(8992.1,XQXX,20,XQXY,0),U,6)=XQADAT - Q - ; -KILLARCH ; - ; Q ; turn off deletion from ALERT TRACKING file ; remove from XU*8*285 JLI 040624 - N DA,DIK,XQDAT,XQDEL1,X1,X2,DA,DIK - S XQDAT=$$FMADD^XLFDT(DT,-30) - F XQDEL1=0:0 S XQDEL1=$O(^XTV(8992.1,XQDEL1)) Q:XQDEL1'>0 D - . S X1=$P($G(^XTV(8992.1,XQDEL1,0)),U,2),X2=$P($G(^(0)),U,8) - . S DA=XQDEL1 I X2="",X1>XQDAT Q - . I X2>0,DT0 S XQAUSER=+Y - S XQALDELE=1 - K XQX1 - D DOIT^XQALERT1 - K XQALDELE S XQAUSERD=1 - I $D(XQX1),XQX1>0 D - . F Q:XQX1="" S DA=+XQX1,XQX1=$P(XQX1,",",2,99) D I XQX1="" S Y=$O(XQX1(0)) I Y>0 S XQX1=XQX1(Y) K XQX1(Y) - . . S XQAID=$P(^TMP("XQ",$J,"XQA1",DA),U,2),XQAKILL=1 - . . I XQAID="" K ^XTV(8992,XQAUSER,"XQA",+^TMP("XQ",$J,"XQA1",DA,1)) - . . I XQAID'="" D DELETE - . . K ^TMP("XQ",$J,"XQA1",DA),^TMP("XQ",$J,"XQA",(999999-DA)) - K XQAUSER,XQX1 - Q - ; -GETBKUP(XQA,XQAUSER) ; JLI 030129 - REMOVED TO SEPARATE METHOD - N I,XQORY,XQENTITY,XQPARAM,XQERR,K,XQAV,XQLIST - S XQPARAM="XQAL BACKUP REVIEWER" - D GETLST^XPAR(.XQLIST,"USR.`"_XQAUSER,XQPARAM,"Q",.XQERR) S:$D(XQLIST)>1 XQPRAMTY=200 ; USER - I '($D(XQLIST)>1) S I=$$GET1^DIQ(200,XQAUSER_",",29,"I") I I>0 D GETLST^XPAR(.XQLIST,"SRV.`"_I,XQPARAM,"Q",.XQERR) S:$D(XQLIST)>1 XQPRAMTY=49 ; SERVICE - I '($D(XQLIST)>1) D GETLST^XPAR(.XQLIST,$$DIVENTIT(XQAUSER),XQPARAM,"Q",.XQERR) S:$D(XQLIST)>1 XQPRAMTY=4 ; DIVISION - I '($D(XQLIST)>1) D GETLST^XPAR(.XQLIST,"SYS",XQPARAM,"Q",.XQERR) S:$D(XQLIST)>1 XQPRAMTY=4.2 ; SYSTEM - F I=0:0 S I=$O(XQLIST(I)) Q:I'>0 S XQAV=$P(XQLIST(I),U,2),XQA(XQAV)=XQAV - ; Removed Teams per Curtis Anderson with CPRS - ;I '$D(XQA) D ; NONE UNDER USER - CHECK FOR ENTRIES IN PARAMETER FILE FOR TEAMS - ;. I $T(TEAMPR^ORQPTQ1)]"" D TEAMPR^ORQPTQ1(.XQORY,XQAUSER) K:+$G(XQORY(1))<1 XQORY ; GET TEAM ID'S IF ANY ; CONTROLLED SUBSCRIPTION - ;. S I=0 F S I=$O(XQORY(I)) Q:I'>0 K XQLIST D GETLST^XPAR(.XQLIST,$P(XQORY(I),U,2)_";OR(100.21,",XQPARAM,"Q",.ERR) I $D(XQTEAM) D - ;. . N K F K=0:0 S K=$O(XQLIST(K)) Q:K'>0 S XQAV=$P(XQLIST(K),U,2),XQA(XQAV)=XQAV - ;. . Q` - ;. Q - ;I '$D(XQLIST) D ; NO TEAM ENTRIES, CHECK OTHER ENTITIES (SERVICE,DIVISION,SYSTEM) - ;. S XQENTITY="SYS" - ;. S I=$$GET1^DIQ(200,XQAUSER_",",16,"I") I I>0 S XQENTITY="DIV.`"_I_U_XQENTITY ; DIVISION - ;. S I=$$GET1^DIQ(200,XQAUSER_",",29,"I") I I>0 S XQENTITY="SRV.`"_I_U_XQENTITY ; SERVICE\SECTION - ;. D GETLST^XPAR(.XQLIST,XQENTITY,XQPARAM,"Q",.XQERR) F I=0:0 S I=$O(XQLIST(I)) Q:I'>0 S XQAV=+$P(XQLIST(I),U,2),XQA(XQAV)=XQAV - ;. Q - ;I '$D(XQA) D ; NO PARAMETERS ENTERED - USE LAST RESORT MAIL GROUP - ;. S XQJ="G.XQAL UNPROCESSED ALERTS" D GROUP^XQALSET1 - ;. I '$D(XQA) S XQJ="G.PATCH" D GROUP^XQALSET1 ; REALLY LAST RESORT - ;. F I=0:0 S I=$O(XQA(I)) Q:I'>0 S XQA(I)=I - ;. Q - Q - ; -DIVENTIT(XQAUSER) ; - N ENTITY,NCNT,DIVNAM,I - S ENTITY="" I DUZ=XQAUSER S ENTITY="DIV.`"_DUZ(2) - I ENTITY="" D - . K NCNT,DIVNAM S NCNT=0 F I=0:0 S I=$O(^VA(200,XQAUSER,2,I)) Q:I'>0 S NCNT=NCNT+1,DIVNAM(NCNT)=+^(I,0) I $P(^(0),U,2) S DIVNAM=+^(0) - . I NCNT'>0 Q - . I NCNT=1 S ENTITY="DIV.`"_DIVNAM(1) Q - . I $D(DIVNAM)#2 S ENTITY="DIV.`"_DIVNAM Q - . F I=1:1:NCNT S ENTITY="DIV.`"_DIVNAM(I)_$S(ENTITY'="":U,1:"")_ENTITY - I ENTITY="" S ENTITY="DIV.`"_$$GET1^DIQ(8989.3,"1,",217,"I") - Q ENTITY - ; -BKUPREVW ;OPT - SET BACKUP REVIEWER(S) IN PARAMETER FILE - G BKUPREVW^XQALBUTL - ; +XQALDEL ;ISC-SF.SEA/JLI - DELETE ALERTS ;6/28/04 11:02 + ;;8.0;KERNEL;**6,24,65,114,174,285**;Jul 10, 1995 + ;; + Q + ; +DELETE ; + N XQAFOUND,XQADAT,XQX,XQK,XQXX,XQXY,XQJ,XQAID1 + Q:'$D(XQAID) Q:XQAID="" S:'$D(XQAKILL) XQAKILL=0 S:$P(XQAID,";")="NO-ID" XQAKILL=1 + S XQADAT=$$NOW^XLFDT() + I '$D(XQAUSER) N XQAUSER S XQAUSER=DUZ + S XQAFOUND=0 D + . S XQX=XQAUSER F XQK=0:0 S XQK=$O(^XTV(8992,XQAUSER,"XQA",XQK)) Q:XQK'>0 I $P(^(XQK,0),U,2)=XQAID S XQAFOUND=1 Q + S XQXX=$O(^XTV(8992.1,"B",XQAID,0)) I XQXX>0 S XQXY=$O(^XTV(8992.1,XQXX,20,"B",XQAUSER,0)) I XQXY>0,XQAFOUND,'$G(XQAUSERD) S $P(^XTV(8992.1,XQXX,20,XQXY,0),U,4)=XQADAT + K XQXX,XQXY + I '$D(^XTV(8992,"AXQA",XQAID,XQAUSER)) D KILLOC + F XQX=0:0 S XQX=$O(^XTV(8992,"AXQA",XQAID,XQX)) Q:XQX'>0 D Q:XQAKILL + . I XQAKILL S XQX=XQAUSER ; Make sure XQAKILL gets only XQAUSER + . F XQK=0:0 S XQK=$O(^XTV(8992,"AXQA",XQAID,XQX,XQK)) Q:XQK'>0 K ^(XQK),^XTV(8992,"AXQAN",$P(XQAID,";"),XQX,XQK) S XQAID1=XQAID D:$D(^XTV(8992,XQX,"XQA",XQK,0)) DELA S XQAID=XQAID1 + K XQAID,XQX,XQJ,XQK,XQAID1,XQAKILL + Q + ; +DELETEA ; + N XQA1,XQADAT,XQAFOUND,XQX,XQXX,XQXY,XQK,XQJ + Q:'$D(XQAID) Q:XQAID="" S XQA1=$P(XQAID,";") + S XQADAT=$$NOW^XLFDT() + I '$D(XQAUSER) N XQAUSER S XQAUSER=DUZ + S:'$D(XQAKILL) XQAKILL=0 G:$P(XQAID,";")="NO-ID" DELETE + S XQAFOUND=0 D + . S XQX=XQAUSER F XQK=0:0 S XQK=$O(^XTV(8992,XQAUSER,"XQA",XQK)) Q:XQK'>0 I $P($G(^(XQK,0)),U,2)=XQAID S XQAFOUND=1 Q + S XQXX=$O(^XTV(8992.1,"B",XQAID,0)) I XQXX>0 S XQXY=$O(^XTV(8992.1,XQXX,20,"B",XQAUSER,0)) I XQXY>0,XQAFOUND,'$G(XQAUSERD) S $P(^XTV(8992.1,XQXX,20,XQXY,0),U,4)=XQADAT + I '$D(^XTV(8992,"AXQAN",XQA1,XQAUSER)) D KILLOC + I $P(XQAID,",",2)'=""!($P(XQAID,";",2)="") F XQX=0:0 S XQX=$O(^XTV(8992,"AXQAN",XQA1,XQX)) Q:XQX'>0 D Q:XQAKILL + . I XQAKILL S XQX=XQAUSER + . F XQK=0:0 S XQK=$O(^XTV(8992,"AXQAN",XQA1,XQX,XQK)) Q:XQK'>0 K ^(XQK) I $D(^XTV(8992,XQX,"XQA",XQK,0)) D DELA + I $P(XQAID,",",2)=""&($P(XQAID,";",2)'="") F XQX=0:0 S XQX=$O(^XTV(8992,"AXQA",XQAID,XQX)) Q:XQX'>0 D Q:XQAKILL + . I XQAKILL S XQX=XQAUSER + . S XQK=$O(^XTV(8992,"AXQA",XQAID,XQX,0)) Q:XQK'>0 K ^(XQK),^XTV(8992,"AXQAN",XQA1,XQX,XQK) I $D(^XTV(8992,XQX,"XQA",XQK,0)) D DELA + K XQAID,XQA1,XQX,XQK,XQAKILL + Q +DELA ; + N XQDEL11 S XQAID=$P($G(^XTV(8992,XQX,"XQA",XQK,0)),U,2),XQDEL11=$P($G(^(0)),U) K ^XTV(8992,XQX,"XQA",XQK) K:XQAID'="" ^XTV(8992,"AXQA",XQAID,XQX,XQK) + D COUNT(-1,XQX) + K:XQAID'="" ^XTV(8992,"AXQAN",$P(XQAID,";"),XQX,XQK) K:XQDEL11'="" ^XTV(8992,XQX,"XQA","B",XQDEL11,XQK) + S XQXX=$S(XQAID'="":$O(^XTV(8992.1,"B",XQAID,0)),1:0) I XQXX>0 S XQXY=$O(^XTV(8992.1,XQXX,20,"B",XQX,0)) I XQXY>0,$P(^XTV(8992.1,XQXX,20,XQXY,0),U,5)'>0 S $P(^(0),U,5)=XQADAT I $G(XQAUSERD) S $P(^(0),U,9)=DUZ + K XQXX,XQXY + Q + ; +COUNT(%1,%2) ;Change the count on the zero node, (amount, user) + Q:$G(%2)'>0 + L +^XTV(8992,%2):10 + I %1 S %=$P($G(^XTV(8992,%2,"XQA",0)),U,4)+%1 S:%'<0 $P(^(0),U,4)=% + I '%1 D + . N % S %1=0,%=0 F S %=$O(^XTV(8992,%2,"XQA",%)) Q:%'>0 S %1=%1+1 + . S $P(^XTV(8992,%2,"XQA",0),U,4)=%1 + L -^XTV(8992,%2) + Q +KILLOC ; + N XQX,XQK + S XQX=XQAUSER F XQK=0:0 S XQK=$O(^XTV(8992,XQAUSER,"XQA",XQK)) Q:XQK'>0 I $P(^(XQK,0),U,2)=XQAID D + . N XQAID D DELA + Q + ; +OLDDEL ; + N XQADAT,X2,XQDAT,XQDEL1 + S XQADAT=$$NOW^XLFDT() + S X2=-15 I $G(ZTQPARAM)>0 S X2=-ZTQPARAM + S XQDAT=$$FMADD^XLFDT(DT,X2) + ;Loop thru users (XQDEL1) levels + F XQDEL1=0:0 S XQDEL1=$O(^XTV(8992,XQDEL1)) Q:XQDEL1'>0 D OLDDEL1 + D KILLARCH + K X1,X2,X,XQDEL1,XQDEL2,XQDAT,XQA,XQADAT + Q +OLDDEL1 ;Loop thru the Alert (XQDEL2) level + L +^XTV(8992,XQDEL1):10 + N XQAGLOB,KILLOLD,XQAZERO,XQAUSER,XQLIST,Y,XQAV,XQPRAMTY,XQDEL2,XQA + S XQAGLOB=$NA(^XTV(8992,XQDEL1,"XQA")),XQAUSER=XQDEL1 + F XQDEL2=0:0 S XQDEL2=$O(@XQAGLOB@(XQDEL2)) Q:XQDEL2'>0 S XQAZERO=^(XQDEL2,0) D + . ; CHECK FOR BACKUP REVIEWER TO FORWARD ALERTS NEEDING ACTION -- P174 + . I $P(XQAZERO,U,15)>0 I $$FMADD^XLFDT(+XQAZERO,+$P(XQAZERO,U,15))\1=DT D Q:$D(KILLOLD) ; changed '>DT to =DT so only send once without killing + . . N XQA D GETBKUP(.XQA,XQDEL1) + . . I $D(XQA) S XQALTYPE="BACKUP REVIEWER" D FORWARD^XQALFWD($P(XQAZERO,U,2),.XQA,"A","ALERT NOT PROCESSED BY "_$$GET1^DIQ(200,XQDEL1_",",.01)) S KILLOLD=1 + . . Q ; End of Backup Reviewer Code -- P174 + . I $P(XQAZERO,U,13)>0 I $$FMADD^XLFDT(+XQAZERO,+$P(XQAZERO,U,13))\1=DT D Q:$D(KILLOLD) ; P174 + . . N XQA,I F I=0:0 S I=$O(^XMB(3.7,XQAUSER,9,I)) Q:I'>0 S XQAV=+^(I,0),XQA(XQAV)=XQAV + . . I $D(XQA) S XQALTYPE="EMAIL SURROGATE" D FORWARD^XQALFWD($P(XQAZERO,U,2),.XQA,"A","ALERT NOT PROCESSED BY "_$$GET1^DIQ(200,XQDEL1_",",.01)) S KILLOLD=1 + . . Q + . I $P(XQAZERO,U,14)>0 I $$FMADD^XLFDT(+XQAZERO,+$P(XQAZERO,U,14))\1=DT D Q:$D(KILLOLD) ; P174 + . . N XQA,I S I=$P($G(^VA(200,XQAUSER,5)),U) I I>0 S I=$P($G(^DIC(49,+I,0)),U,3) I I>0,$D(^VA(200,+I,0)) S XQA(+I)=+I + . . I $D(XQA) S XQALTYPE="CHIEF/SUPERVISOR" D FORWARD^XQALFWD($P(XQAZERO,U,2),.XQA,"A","ALERT NOT PROCESSED BY "_$$GET1^DIQ(200,XQDEL1_",",.01)) S KILLOLD=1 + . . Q + . I XQDEL2'>XQDAT D OLDDEL2 + . Q + K:$O(^XTV(8992,XQDEL1,"XQA",0))="" ^XTV(8992,XQDEL1,"XQA") + L -^XTV(8992,XQDEL1) + Q + ; +OLDDEL2 ; + N XQA,XQXX,XQXY + S XQA=$P(^XTV(8992,XQDEL1,"XQA",XQDEL2,0),U,2) K ^XTV(8992,XQDEL1,"XQA",XQDEL2) K:XQA'="" ^XTV(8992,"AXQA",XQA,XQDEL1),^XTV(8992,"AXQAN",$P(XQA,";"),XQDEL1) + D COUNT(-1,XQDEL1) + I XQA'="" S XQXX=$O(^XTV(8992.1,"B",XQA,0)) I XQXX>0 S XQXY=$O(^XTV(8992.1,XQXX,20,"B",XQDEL1,0)) I XQXY>0 S $P(^XTV(8992.1,XQXX,20,XQXY,0),U,6)=XQADAT + Q + ; +KILLARCH ; + ; Q ; turn off deletion from ALERT TRACKING file ; remove from XU*8*285 JLI 040624 + N DA,DIK,XQDAT,XQDEL1,X1,X2,DA,DIK + S XQDAT=$$FMADD^XLFDT(DT,-30) + F XQDEL1=0:0 S XQDEL1=$O(^XTV(8992.1,XQDEL1)) Q:XQDEL1'>0 D + . S X1=$P(^XTV(8992.1,XQDEL1,0),U,2),X2=$P(^(0),U,8) + . S DA=XQDEL1 I X2="",X1>XQDAT Q + . I X2>0,DT0 S XQAUSER=+Y + S XQALDELE=1 + K XQX1 + D DOIT^XQALERT1 + K XQALDELE S XQAUSERD=1 + I $D(XQX1),XQX1>0 D + . F Q:XQX1="" S DA=+XQX1,XQX1=$P(XQX1,",",2,99) D I XQX1="" S Y=$O(XQX1(0)) I Y>0 S XQX1=XQX1(Y) K XQX1(Y) + . . S XQAID=$P(^TMP("XQ",$J,"XQA1",DA),U,2),XQAKILL=1 + . . I XQAID="" K ^XTV(8992,XQAUSER,"XQA",+^TMP("XQ",$J,"XQA1",DA,1)) + . . I XQAID'="" D DELETE + . . K ^TMP("XQ",$J,"XQA1",DA),^TMP("XQ",$J,"XQA",(999999-DA)) + K XQAUSER,XQX1 + Q + ; +GETBKUP(XQA,XQAUSER) ; JLI 030129 - REMOVED TO SEPARATE METHOD + N I,XQORY,XQENTITY,XQPARAM,XQERR,K,XQAV,XQLIST + S XQPARAM="XQAL BACKUP REVIEWER" + D GETLST^XPAR(.XQLIST,"USR.`"_XQAUSER,XQPARAM,"Q",.XQERR) S:$D(XQLIST)>1 XQPRAMTY=200 ; USER + I '($D(XQLIST)>1) S I=$$GET1^DIQ(200,XQAUSER_",",29,"I") I I>0 D GETLST^XPAR(.XQLIST,"SRV.`"_I,XQPARAM,"Q",.XQERR) S:$D(XQLIST)>1 XQPRAMTY=49 ; SERVICE + I '($D(XQLIST)>1) D GETLST^XPAR(.XQLIST,$$DIVENTIT(XQAUSER),XQPARAM,"Q",.XQERR) S:$D(XQLIST)>1 XQPRAMTY=4 ; DIVISION + I '($D(XQLIST)>1) D GETLST^XPAR(.XQLIST,"SYS",XQPARAM,"Q",.XQERR) S:$D(XQLIST)>1 XQPRAMTY=4.2 ; SYSTEM + F I=0:0 S I=$O(XQLIST(I)) Q:I'>0 S XQAV=$P(XQLIST(I),U,2),XQA(XQAV)=XQAV + ; Removed Teams per Curtis Anderson with CPRS + ;I '$D(XQA) D ; NONE UNDER USER - CHECK FOR ENTRIES IN PARAMETER FILE FOR TEAMS + ;. I $T(TEAMPR^ORQPTQ1)]"" D TEAMPR^ORQPTQ1(.XQORY,XQAUSER) K:+$G(XQORY(1))<1 XQORY ; GET TEAM ID'S IF ANY ; CONTROLLED SUBSCRIPTION + ;. S I=0 F S I=$O(XQORY(I)) Q:I'>0 K XQLIST D GETLST^XPAR(.XQLIST,$P(XQORY(I),U,2)_";OR(100.21,",XQPARAM,"Q",.ERR) I $D(XQTEAM) D + ;. . N K F K=0:0 S K=$O(XQLIST(K)) Q:K'>0 S XQAV=$P(XQLIST(K),U,2),XQA(XQAV)=XQAV + ;. . Q` + ;. Q + ;I '$D(XQLIST) D ; NO TEAM ENTRIES, CHECK OTHER ENTITIES (SERVICE,DIVISION,SYSTEM) + ;. S XQENTITY="SYS" + ;. S I=$$GET1^DIQ(200,XQAUSER_",",16,"I") I I>0 S XQENTITY="DIV.`"_I_U_XQENTITY ; DIVISION + ;. S I=$$GET1^DIQ(200,XQAUSER_",",29,"I") I I>0 S XQENTITY="SRV.`"_I_U_XQENTITY ; SERVICE\SECTION + ;. D GETLST^XPAR(.XQLIST,XQENTITY,XQPARAM,"Q",.XQERR) F I=0:0 S I=$O(XQLIST(I)) Q:I'>0 S XQAV=+$P(XQLIST(I),U,2),XQA(XQAV)=XQAV + ;. Q + ;I '$D(XQA) D ; NO PARAMETERS ENTERED - USE LAST RESORT MAIL GROUP + ;. S XQJ="G.XQAL UNPROCESSED ALERTS" D GROUP^XQALSET1 + ;. I '$D(XQA) S XQJ="G.PATCH" D GROUP^XQALSET1 ; REALLY LAST RESORT + ;. F I=0:0 S I=$O(XQA(I)) Q:I'>0 S XQA(I)=I + ;. Q + Q + ; +DIVENTIT(XQAUSER) ; + N ENTITY,NCNT,DIVNAM,I + S ENTITY="" I DUZ=XQAUSER S ENTITY="DIV.`"_DUZ(2) + I ENTITY="" D + . K NCNT,DIVNAM S NCNT=0 F I=0:0 S I=$O(^VA(200,XQAUSER,2,I)) Q:I'>0 S NCNT=NCNT+1,DIVNAM(NCNT)=+^(I,0) I $P(^(0),U,2) S DIVNAM=+^(0) + . I NCNT'>0 Q + . I NCNT=1 S ENTITY="DIV.`"_DIVNAM(1) Q + . I $D(DIVNAM)#2 S ENTITY="DIV.`"_DIVNAM Q + . F I=1:1:NCNT S ENTITY="DIV.`"_DIVNAM(I)_$S(ENTITY'="":U,1:"")_ENTITY + I ENTITY="" S ENTITY="DIV.`"_$$GET1^DIQ(8989.3,"1,",217,"I") + Q ENTITY + ; +BKUPREVW ;OPT - SET BACKUP REVIEWER(S) IN PARAMETER FILE + G BKUPREVW^XQALBUTL + ; diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALERT1.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALERT1.m index c6208232..c5e7b179 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALERT1.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALERT1.m @@ -1,162 +1,161 @@ -XQALERT1 ;ISC-SF.SEA/JLI - ALERT HANDLER ;4/9/07 14:54 - ;;8.0;KERNEL;**20,65,114,123,125,164,173,285,366,443**;Jul 10, 1995;Build 4 - ;; - Q - ; -DOIT I $D(XQX1),XQX1'>0 K XQX1 - I $D(XQAID) D I '$D(XQAID) G EXIT - . N XQACHOIC,REASK S REASK=0 - . I '$D(XQX1),$O(^XTV(8992,XQAUSER,"XQA",+$O(^XTV(8992,XQAUSER,"XQA",0))))'>0,$G(XQAROUX)="^ " S XQAROU="" -AGAIN . S XQACHOIC="Y:YES;N:NO;C:CONTINUE;",XQAQ("?")="Enter Y (or C) to continue, N to exit alert processing" - . S XQACHOIC=$G(XQACHOIC)_"F:FORWARD ALERT;R:RENEW(MAKE NEW AGAIN);" S XQAQ("?",1)="Enter F to forward this alert to someone else",XQAQ("?",2)="Enter R to Renew (Make New) this alert" - . D I REASK=1 G AGAIN - . . S REASK=0 W !! K DIR S DIR(0)="SA^"_XQACHOIC,DIR("A")=$S(XQACHOIC["F:":"Continue (Y/N) or F(orward) or R(enew) ",1:"Continue Processing (Y/N) "),DIR("B")="YES" M DIR("?")=XQAQ("?") D ^DIR K DIR - . . I $D(DUOUT)!$D(DIRUT) S Y="N" K DUOUT,DIRUT - . . I Y="N" D:$D(XQAKILL) DELETEA^XQALERT K XQAID - . . I Y="R" S REASK=REASK+1 K XQAKILL I '$D(^XTV(8992,"AXQA",XQAID,DUZ)) D RESTORE - . . I Y="F" D:'$D(^XTV(8992,"AXQA",XQAID,DUZ)) RESTORE D FRWRDONE S REASK=REASK+1 - . . Q - . Q - I $D(XQAKILL) D DELETEA^XQALERT - S XQAREV=1,XQXOUT=0,XQK=0,XQACNT=0 K XQADATA,XQAID,XQAROU,XQAKILL,XQAROUX - I '$D(XQX1) S XQX1=0 K ^TMP("XQ",$J,"XQA"),^("XQA1"),^("XQA2") I $O(^XTV(8992,XQAUSER,"XQA",0))'>0 K XQX1 D:'$G(^TMP("XQALERT1",$J,"NOTFIRST")) CHKSURO G:$O(^XTV(8992,XQAUSER,"XQA",0))'>0 EXIT S XQX1=0 ; P366 - I $$ACTVSURO^XQALSURO(XQAUSER)'>0 D RETURN^XQALSUR1(XQAUSER) ; P366 - S ^TMP("XQALERT1",$J,"NOTFIRST")=1 ; Added 2/2/99 jli to clear flag for initial entry - ;Sort and remove display only - I 'XQX1 W !!! D - . D SORT - ; Now display them. -SUBLOOP W @IOF - N XQZ1,XQZ - S XQK=0 F XQI=0:0 Q:XQX1!XQXOUT S XQI=$O(^TMP("XQ",$J,"XQA",XQI)) Q:XQI'>0 S XQX=^(XQI),XQII=^(XQI,1),XQZ=^(2),XQZ1=^(3),XQZ4=^(4) D I XQX'="" D DOIT1 - . I '$D(^XTV(8992,XQAUSER,"XQA",XQII)) S XQX="" K ^TMP("XQ",$J,"XQA",XQI),^TMP("XQ",$J,"XQA1",(999999-XQI)) - . Q - S:'$D(XQXOUT) XQXOUT=0 G:XQXOUT EXIT G:XQK'>0&'XQX1 EXIT I 'XQX1 D ASK G:XQXOUT EXIT - G:+XQX1=0 EXIT I XQX1<0 S XQX1=0 G DOIT - I $D(XQALDELE)!$D(XQALFWD) Q - ;D WAIT(+XQX1) G:XQXOUT EXIT - G:XQXOUT EXIT - G EN^XQALDOIT - ; -RESTORE ; Restore a deleted message for use - N ALERTREF,XTVGLOB,ADUZ,X,X0,X1,X2,TIME,MESG,OPT,TAG,ROU,X4,LONG - S XTVGLOB=$NA(^XTV(8992,DUZ,"XQA")) - S ADUZ=$O(^XTV(8992,"AXQA",XQAID,0)) I ADUZ>0 S TIME=$O(^(ADUZ,0)) D I 1 - . M @XTVGLOB@(TIME)=^XTV(8992,ADUZ,"XQA",TIME) K @XTVGLOB@(TIME,2) ; copy alert, kill comment if any - E S ALERTREF=$O(^XTV(8992.1,"B",XQAID,0)) Q:ALERTREF'>0 D ; otherwise rebuild from alert tracking file if possible - . S X0=^XTV(8992.1,ALERTREF,0),X1=$G(^(1)),X2=$G(^(2)),X4=$O(^(4,0)) - . S TIME=$P($P(X0,U),";",3),MESG=$P(X1,U),OPT=$P(X1,U,2),TAG=$P(X1,U,3),ROU=$P(X1,U,4),LONG=(X4>0) - . S X=TIME_U_XQAID_U_MESG_U_U_$S(OPT'=""!(ROU'=""):"R",LONG:"L",1:"I")_U_U_$S(OPT'="":OPT,TAG'="":TAG,1:"")_U_$S(OPT'="":"",ROU'="":ROU,1:" ") - . S @XTVGLOB@(TIME,0)=X I $G(X2)'="" S ^(1)=X2 - S ^XTV(8992,"AXQA",XQAID,DUZ,TIME)="",^XTV(8992,"AXQAN",$E($P(XQAID,";"),1,30),DUZ,TIME)="" - Q - ; -EXIT ; - I $G(XQALAST)="I",$G(DUZ("AUTO")) D WAIT2 - I $D(XQALDELE)!$D(XQALFWD) Q - K ^TMP("XQ",$J,"XQA"),^("XQA1"),^("XQA2"),XQI,XQX,XQJ,XQK,XQX1,XQX2,XQXOUT,XQ1,XQII,XQACNT,XQA1,XQAREV,%ZIS,XQAROU,XQALAST,XQAROUX,XQON,XQOFF,XQ1ON,XQ1OFF,XQOUT,XQAQ - K ^TMP("XQALERT1",$J) - Q - ; - ; CHKSURO added 2/2/99 to give user opportunity to add/remove surrogate if no alerts present -CHKSURO ; If user selects process alerts with no alerts present, give him/her the opportunity to add or delete a surrogate - ; P366 - list currently established surrogates if any - I '$G(^TMP("XQALERT1",$J,"NOTFIRST")) W !!,"You have no alerts for processing.",! - D SURROGAT^XQALSURO ; XU*8*17 - Q - ; -DOIT1 ; - I XQK=0 S XQALINFO=0 I '$D(XQALFWD) W @IOF - S XQON="$C(0)",XQOFF="$C(0)" S XQOUT=$P(XQX,U,3) I ($$UP^XLFSTR(XQOUT)["CRITICAL")!($$UP^XLFSTR(XQOUT)["ABNORMAL IMA") D:'$D(XQ1ON) SETREV^XQALERT S XQON=XQ1ON,XQOFF=XQ1OFF ; P285 - S XQK=XQK+1 W !,$J(XQK,2),".",$S(XQZ4:"L",$P(XQX,U,8)=" ":"I",1:" ")," ",@XQON,$E($P(XQX,U,3),1,70),@XQOFF S:$P(XQX,U,8)=" " XQALINFO=XQALINFO+1 D:XQZ1'="" ; P285 - . W !?8,"Forwarded by: ",$P(^VA(200,+XQZ1,0),U)," Generated: ",$$DAT8^XQALERT(+$P($P(XQX,U,2),";",3),1) - . I $P(XQZ1,U,3)'="" W !?8,$P(XQZ1,U,3) - S ^TMP("XQ",$J,"XQA1",XQK)=XQX,^(XQK,1)=XQII,^(2)=XQZ,^(3)=XQZ1 - I ($Y+6)>IOSL N XQKVALUE S XQKVALUE=XQK D ASK0(XQI) S:'$D(XQK) XQK=XQKVALUE Q:XQX1!(XQXOUT) W @IOF - Q - ; -ASK0(XQI) ;Stack XQI -ASK ; - N XQALNEWF K XQALAST - ;I '$D(XQALDELE)&'$D(XQALFWD) S XQALNEWF=$P(^XTV(8992,XQAUSER,0),U,5) I XQALNEWF<20 D - ;. N XQALFDA - ;. S XQALNEWF=XQALNEWF+1,XQALFDA=(8992,(XQAUSER_","),.05)=XQALNEWF D FILE^DIE("","XQALFDA") - ;. W !,"NEW OPTIONS: S-to add/remove SURROGATE and D-to selectively Delete SOME alerts" - S XQ1=0,XQXOUT=0 W !?10,"Select from 1 to ",XQK W:$D(XQALDELE) " to DELETE" W:$D(XQALFWD) " to FORWARD" - W !?10,"or enter ?, A, " W:'$D(XQALDELE)&'$D(XQALFWD)&(XQALINFO>0) "I, D, " W:'$D(XQALDELE)&'$D(XQALFWD) "F, S, P, M, R, " W "or ^ to exit" I XQI>0,$O(^XTV(8992,XQAUSER,"XQA",XQI))>0 W !?10,"or RETURN to continue" S XQ1=1 - R ": ",XQII:DTIME S:'$T!(XQII[U)!(XQII=""&'XQ1) XQXOUT=1 Q:XQXOUT - I '$D(XQALDELE)&'$D(XQALFWD),"PpMm"[$E(XQII_".") D MORP^XQALDOIT D:"Pp"[$E(XQII_".") PRINT^XQALDOIT D:"Mm"[$E(XQII_".") MAIL^XQALDOIT K ^TMP("XQ",$J,"XQA2") G ASK - I XQII'="",XQII["?" D HELP G ASK - I XQII=""&XQ1 Q - I "IiAaFfRrSsDd"'[$E(XQII_"."),$L(XQII)>31,$E(XQII,1,32)?1N.N W !,$C(7)," ?? Invalid number entered",! G ASK - I "IiAaFfRrSsDd"'[$E(XQII_"."),(XQII<1)!(XQII>XQK) W $C(7)," ??",! G ASK - I '$D(XQALDELE)&'$D(XQALFWD),"Ff"[$E(XQII) D FWRD^XQALFWD S XQX1=-2 Q ; MODIFIED 7-6 - I '$D(XQALDELE)&'$D(XQALFWD),"Ss"[$E(XQII) D CHKSURO S XQX1=-1 Q - I '$D(XQALDELE)&'$D(XQALFWD),"Dd"[$E(XQII) D ASKDEL S XQX1=-2 Q ; MODIFIED 7-6 - I '$D(XQALDELE),"Rr"[$E(XQII) S XQX1=-2 Q - I "Aa"[$E(XQII) S X="1-"_XQACNT,DIR(0)="LV^1:"_XQACNT D ^DIR K DIR,XQX1 M XQX1=Y S XQII="" K Y ;Merge list from Y - I XQII'="","Ii"[$E(XQII) S XQX1(0)="",XQX2=0,XQII="" F XQK=0:0 S XQK=$O(^TMP("XQ",$J,"XQA1",XQK)) S:XQK'>0 XQX1=XQX1(0) Q:XQK'>0 I $P(^(XQK),U,7,8)="^ " S XQX1(XQX2)=XQX1(XQX2)_XQK_"," S:$L(XQX1(XQX2))>240 XQX2=XQX2+1,XQX1(XQX2)="" - I XQII="" Q - S X=XQII,DIR(0)="LV^1:"_XQK D ^DIR I '$D(Y) W $C(7)," ??" D HELP G ASK ;Use of 'LV' is special - K XQX1 M XQX1=Y K Y S Y=XQX1 ;Merge list from Y - Q -WAIT(IFN) ;Wait for user input if last alert is INFO and next isn't. - N X,YY Q:$G(XQXOUT) - S X=$G(^TMP("XQ",$J,"XQA1",IFN)),YY=$P(X,U,7,8),YY=$S(YY="^ ":"I",YY="^":"O",1:"R") - I $G(XQALAST)="I","OR"[YY D WAIT2 - I YY="I",$Y+4>IOSL D WAIT2 W @IOF - S XQALAST=YY - Q -WAIT2 ;Wait for user input before continuing - N DIR,Y,DIROUT,DIRUT S DIR(0)="E",DIR("?")="The next ALERT may cause the loss of info on the screen." - D ^DIR S:$D(DIRUT) XQXOUT=1 - Q - ; -HELP W !!,"YOU MAY ENTER:",!?3,$S(XQK>1:"One or more numbers",1:"A number")," in the range 1 to ",XQK," to select specific alert(s)" - W !?6,"for "_$S($D(XQALDELE):"DELETION.",$D(XQALFWD):"FORWARDING",1:"processing.") W:XQK>1 " This may be a series of numbers, e.g., 2,3,6-9" - W !?3,"A to "_$S($D(XQALDELE):"DELETE",$D(XQALFWD):"FORWARD",1:"process")," all of the pending alerts in the order shown." - W:'$D(XQALDELE)&'$D(XQALFWD) !?3,"I to process all of the INFORMATION ONLY alerts, if any, without further ado." - W:'$D(XQALDELE)&'$D(XQALFWD) !?3,"S to add or remove a surrogate to receive alerts for you" - W:'$D(XQALDELE)&'$D(XQALFWD) !?3,"F to forward one or more specific alerts. Forwarding may be as an ALERT",!,"to specific user(s) and/or mail group(s), or as a MAIL MESSAGE, or to a",!,"specific PRINTER." - W:'$D(XQALDELE)&'$D(XQALFWD) !?3,"D to delete specific alerts (some alerts may not be deleted)" - W:'$D(XQALDELE)&'$D(XQALFWD) !?3,"P to print a copy of the pending alerts on a printer" - W:'$D(XQALDELE)&'$D(XQALFWD) !?3,"M to receive a MailMan message containing a copy of these pending alerts" - W:'$D(XQALDELE) !?3,"R to Redisplay the available alerts" - W !?3,"^ to exit" - I XQI W !?5,"or RETURN to see additional pending ALERTS" - W !! - Q - ; -SORT ;Sort and remove display only - N XQZ,XQZ1,XQZ4,XQI,XQK,XQX,XQJ - F XQI=0:0 S XQI=$O(^XTV(8992,XQAUSER,"XQA",XQI)) Q:XQI'>0 S XQX=^(XQI,0),XQZ=$G(^(1)),XQZ1=$G(^(2)),XQZ4=$O(^(4,0)) S XQJ=$P(XQX,U,7,8) K:XQJ=U ^XTV(8992,XQAUSER,"XQA",XQI) I XQJ'=U D - . S XQACNT=XQACNT+1,XQJ=$S(XQAREV:999999-XQACNT,1:XQACNT),^TMP("XQ",$J,"XQA",XQJ)=XQX,^(XQJ,1)=XQI,^(2)=XQZ,^(3)=XQZ1,^(4)=XQZ4 - S XQK=0 F XQI=0:0 S XQI=$O(^TMP("XQ",$J,"XQA",XQI)) Q:XQI'>0 S XQK=XQK+1 M ^TMP("XQ",$J,"XQA1",XQK)=^TMP("XQ",$J,"XQA",XQI) - Q - ; -ASKDEL ; - N XQALDELE,XQX1COPY,XQAID,DA,XQAKILL,XQXOUT,XQAUSERD,XQALVALU - S XQALDELE=1 - K XQX1 - D DOIT^XQALERT1 - K XQALDELE S XQAUSERD=1 - I $D(XQX1),XQX1>0 D - . M XQX1COPY=XQX1 - . F Q:XQX1="" S DA=+XQX1,XQX1=$P(XQX1,",",2,99) D I XQX1="" S Y=$O(XQX1(0)) I Y>0 S XQX1=XQX1(Y) K XQX1(Y) - . . S XQAID=$P(^TMP("XQ",$J,"XQA1",DA),U,2),XQALVALU=^(DA),XQAKILL=1 - . . I $P(XQALVALU,U,8)=" "!$P(XQALVALU,U,10) D - . . . I XQAID="" K ^XTV(8992,XQAUSER,"XQA",+^TMP("XQ",$J,"XQA1",DA,1)) - . . . I XQAID'="" D DELETE^XQALDEL - . . . K ^TMP("XQ",$J,"XQA1",DA),^TMP("XQ",$J,"XQA",(999999-DA)) - . K XQX1 M XQX1=XQX1COPY S XQAID=0 - . F Q:XQX1="" S DA=+XQX1,XQX1=$P(XQX1,",",2,99) D I XQX1="" S Y=$O(XQX1(0)) I Y>0 S XQX1=XQX1(Y) K XQX1(Y) - . . I $D(^TMP("XQ",$J,"XQA1",DA)) W:'XQAID !!,"Unable to delete alerts which require action: ",DA W:XQAID ",",DA S XQAID=1 - . I XQAID=1 K DIR S DIR(0)="E" D ^DIR K DIR - K XQX1,XQAKILL - Q - ; -FRWRDONE ; - N XQX1,XQALFWDL S XQALFWDL(1)=XQAID - N XQAID - D FWDONE^XQALFWD - Q +XQALERT1 ;ISC-SF.SEA/JLI - ALERT HANDLER ;9/6/05 15:13 + ;;8.0;KERNEL;**20,65,114,123,125,164,173,285,366**;Jul 10, 1995 + ;; + Q + ; +DOIT I $D(XQX1),XQX1'>0 K XQX1 + I $D(XQAID) D I '$D(XQAID) G EXIT + . N XQACHOIC,REASK S REASK=0 + . I '$D(XQX1),$O(^XTV(8992,XQAUSER,"XQA",+$O(^XTV(8992,XQAUSER,"XQA",0))))'>0,$G(XQAROUX)="^ " S XQAROU="" +AGAIN . S XQACHOIC="Y:YES;N:NO;C:CONTINUE;",XQAQ("?")="Enter Y (or C) to continue, N to exit alert processing" + . S XQACHOIC=$G(XQACHOIC)_"F:FORWARD ALERT;R:RENEW(MAKE NEW AGAIN);" S XQAQ("?",1)="Enter F to forward this alert to someone else",XQAQ("?",2)="Enter R to Renew (Make New) this alert" + . D I REASK=1 G AGAIN + . . S REASK=0 W !! K DIR S DIR(0)="SA^"_XQACHOIC,DIR("A")=$S(XQACHOIC["F:":"Continue (Y/N) or F(orward) or R(enew) ",1:"Continue Processing (Y/N) "),DIR("B")="YES" M DIR("?")=XQAQ("?") D ^DIR K DIR + . . I $D(DUOUT)!$D(DIRUT) S Y="N" K DUOUT,DIRUT + . . I Y="N" D:$D(XQAKILL) DELETEA^XQALERT K XQAID + . . I Y="R" S REASK=REASK+1 K XQAKILL I '$D(^XTV(8992,"AXQA",XQAID,DUZ)) D RESTORE + . . I Y="F" D:'$D(^XTV(8992,"AXQA",XQAID,DUZ)) RESTORE D FRWRDONE S REASK=REASK+1 + . . Q + . Q + I $D(XQAKILL) D DELETEA^XQALERT + S XQAREV=1,XQXOUT=0,XQK=0,XQACNT=0 K XQADATA,XQAID,XQAROU,XQAKILL,XQAROUX + I '$D(XQX1) S XQX1=0 K ^TMP("XQ",$J,"XQA"),^("XQA1"),^("XQA2") I $O(^XTV(8992,XQAUSER,"XQA",0))'>0 K XQX1 D:'$G(^TMP("XQALERT1",$J,"NOTFIRST")) CHKSURO G:$O(^XTV(8992,XQAUSER,"XQA",0))'>0 EXIT S XQX1=0 ; P366 + I $$ACTVSURO^XQALSURO(XQAUSER)'>0 D RETURN^XQALSUR1(XQAUSER) ; P366 + S ^TMP("XQALERT1",$J,"NOTFIRST")=1 ; Added 2/2/99 jli to clear flag for initial entry + ;Sort and remove display only + I 'XQX1 W !!! D + . D SORT + ; Now display them. +SUBLOOP W @IOF + N XQZ1,XQZ + S XQK=0 F XQI=0:0 Q:XQX1!XQXOUT S XQI=$O(^TMP("XQ",$J,"XQA",XQI)) Q:XQI'>0 S XQX=^(XQI),XQII=^(XQI,1),XQZ=^(2),XQZ1=^(3) D I XQX'="" D DOIT1 + . I '$D(^XTV(8992,XQAUSER,"XQA",XQII)) S XQX="" K ^TMP("XQ",$J,"XQA",XQI),^TMP("XQ",$J,"XQA1",(999999-XQI)) + . Q + S:'$D(XQXOUT) XQXOUT=0 G:XQXOUT EXIT G:XQK'>0&'XQX1 EXIT I 'XQX1 D ASK G:XQXOUT EXIT + G:+XQX1=0 EXIT I XQX1<0 S XQX1=0 G DOIT + I $D(XQALDELE)!$D(XQALFWD) Q + ;D WAIT(+XQX1) G:XQXOUT EXIT + G:XQXOUT EXIT + G EN^XQALDOIT + ; +RESTORE ; Restore a deleted message for use + N ALERTREF,XTVGLOB,ADUZ,X,X0,X1,X2,TIME,MESG,OPT,TAG,ROU + S XTVGLOB=$NA(^XTV(8992,DUZ,"XQA")) + S ADUZ=$O(^XTV(8992,"AXQA",XQAID,0)) I ADUZ>0 S TIME=$O(^(ADUZ,0)) D I 1 + . M @XTVGLOB@(TIME)=^XTV(8992,ADUZ,"XQA",TIME) K @XTVGLOB@(TIME,2) ; copy alert, kill comment if any + E S ALERTREF=$O(^XTV(8992.1,"B",XQAID,0)) Q:ALERTREF'>0 D ; otherwise rebuild from alert tracking file if possible + . S X0=^XTV(8992.1,ALERTREF,0),X1=$G(^(1)),X2=$G(^(2)) + . S TIME=$P($P(X0,U),";",3),MESG=$P(X1,U),OPT=$P(X1,U,2),TAG=$P(X1,U,3),ROU=$P(X1,U,4) + . S X=TIME_U_XQAID_U_MESG_U_U_$S(OPT'=""!(ROU'=""):"R",1:"I")_U_U_$S(OPT'="":OPT,TAG'="":TAG,1:"")_U_$S(OPT'="":"",ROU'="":ROU,1:" ") + . S @XTVGLOB@(TIME,0)=X I $G(X2)'="" S ^(1)=X2 + S ^XTV(8992,"AXQA",XQAID,DUZ,TIME)="",^XTV(8992,"AXQAN",$E($P(XQAID,";"),1,30),DUZ,TIME)="" + Q + ; +EXIT ; + I $G(XQALAST)="I",$G(DUZ("AUTO")) D WAIT2 + I $D(XQALDELE)!$D(XQALFWD) Q + K ^TMP("XQ",$J,"XQA"),^("XQA1"),^("XQA2"),XQI,XQX,XQJ,XQK,XQX1,XQX2,XQXOUT,XQ1,XQII,XQACNT,XQA1,XQAREV,%ZIS,XQAROU,XQALAST,XQAROUX,XQON,XQOFF,XQ1ON,XQ1OFF,XQOUT,XQAQ + K ^TMP("XQALERT1",$J) + Q + ; + ; CHKSURO added 2/2/99 to give user opportunity to add/remove surrogate if no alerts present +CHKSURO ; If user selects process alerts with no alerts present, give him/her the opportunity to add or delete a surrogate + ; P366 - list currently established surrogates if any + I '$G(^TMP("XQALERT1",$J,"NOTFIRST")) W !!,"You have no alerts for processing.",! + D SURROGAT^XQALSURO ; XU*8*17 + Q + ; +DOIT1 ; + I XQK=0 S XQALINFO=0 I '$D(XQALFWD) W @IOF + S XQON="$C(0)",XQOFF="$C(0)" S XQOUT=$P(XQX,U,3) I ($$UP^XLFSTR(XQOUT)["CRITICAL")!($$UP^XLFSTR(XQOUT)["ABNORMAL IMA") D:'$D(XQ1ON) SETREV^XQALERT S XQON=XQ1ON,XQOFF=XQ1OFF ; P285 + S XQK=XQK+1 W !,$J(XQK,2),".",$S($P(XQX,U,8)=" ":"I",1:" ")," ",@XQON,$E($P(XQX,U,3),1,70),@XQOFF S:$P(XQX,U,8)=" " XQALINFO=XQALINFO+1 D:XQZ1'="" ; P285 + . W !?8,"Forwarded by: ",$P(^VA(200,+XQZ1,0),U)," Generated: ",$$DAT8^XQALERT(+$P($P(XQX,U,2),";",3),1) + . I $P(XQZ1,U,3)'="" W !?8,$P(XQZ1,U,3) + S ^TMP("XQ",$J,"XQA1",XQK)=XQX,^(XQK,1)=XQII,^(2)=XQZ,^(3)=XQZ1 + I ($Y+6)>IOSL N XQKVALUE S XQKVALUE=XQK D ASK0(XQI) S:'$D(XQK) XQK=XQKVALUE Q:XQX1!(XQXOUT) W @IOF + Q + ; +ASK0(XQI) ;Stack XQI +ASK ; + N XQALNEWF K XQALAST + ;I '$D(XQALDELE)&'$D(XQALFWD) S XQALNEWF=$P(^XTV(8992,XQAUSER,0),U,5) I XQALNEWF<20 D + ;. N XQALFDA + ;. S XQALNEWF=XQALNEWF+1,XQALFDA=(8992,(XQAUSER_","),.05)=XQALNEWF D FILE^DIE("","XQALFDA") + ;. W !,"NEW OPTIONS: S-to add/remove SURROGATE and D-to selectively Delete SOME alerts" + S XQ1=0,XQXOUT=0 W !?10,"Select from 1 to ",XQK W:$D(XQALDELE) " to DELETE" W:$D(XQALFWD) " to FORWARD" + W !?10,"or enter ?, A, " W:'$D(XQALDELE)&'$D(XQALFWD)&(XQALINFO>0) "I, D, " W:'$D(XQALDELE)&'$D(XQALFWD) "F, S, P, M, R, " W "or ^ to exit" I XQI>0,$O(^XTV(8992,XQAUSER,"XQA",XQI))>0 W !?10,"or RETURN to continue" S XQ1=1 + R ": ",XQII:DTIME S:'$T!(XQII[U)!(XQII=""&'XQ1) XQXOUT=1 Q:XQXOUT + I '$D(XQALDELE)&'$D(XQALFWD),"PpMm"[$E(XQII_".") D MORP^XQALDOIT D:"Pp"[$E(XQII_".") PRINT^XQALDOIT D:"Mm"[$E(XQII_".") MAIL^XQALDOIT K ^TMP("XQ",$J,"XQA2") G ASK + I XQII'="",XQII["?" D HELP G ASK + I XQII=""&XQ1 Q + I "IiAaFfRrSsDd"'[$E(XQII_"."),$L(XQII)>31,$E(XQII,1,32)?1N.N W !,$C(7)," ?? Invalid number entered",! G ASK + I "IiAaFfRrSsDd"'[$E(XQII_"."),(XQII<1)!(XQII>XQK) W $C(7)," ??",! G ASK + I '$D(XQALDELE)&'$D(XQALFWD),"Ff"[$E(XQII) D FWRD^XQALFWD S XQX1=-2 Q ; MODIFIED 7-6 + I '$D(XQALDELE)&'$D(XQALFWD),"Ss"[$E(XQII) D CHKSURO S XQX1=-1 Q + I '$D(XQALDELE)&'$D(XQALFWD),"Dd"[$E(XQII) D ASKDEL S XQX1=-2 Q ; MODIFIED 7-6 + I '$D(XQALDELE),"Rr"[$E(XQII) S XQX1=-2 Q + I "Aa"[$E(XQII) S X="1-"_XQACNT,DIR(0)="LV^1:"_XQACNT D ^DIR K DIR,XQX1 M XQX1=Y S XQII="" K Y ;Merge list from Y + I XQII'="","Ii"[$E(XQII) S XQX1(0)="",XQX2=0,XQII="" F XQK=0:0 S XQK=$O(^TMP("XQ",$J,"XQA1",XQK)) S:XQK'>0 XQX1=XQX1(0) Q:XQK'>0 I $P(^(XQK),U,7,8)="^ " S XQX1(XQX2)=XQX1(XQX2)_XQK_"," S:$L(XQX1(XQX2))>240 XQX2=XQX2+1,XQX1(XQX2)="" + I XQII="" Q + S X=XQII,DIR(0)="LV^1:"_XQK D ^DIR I '$D(Y) W $C(7)," ??" D HELP G ASK ;Use of 'LV' is special + K XQX1 M XQX1=Y K Y S Y=XQX1 ;Merge list from Y + Q +WAIT(IFN) ;Wait for user input if last alert is INFO and next isn't. + N X,YY Q:$G(XQXOUT) + S X=$G(^TMP("XQ",$J,"XQA1",IFN)),YY=$P(X,U,7,8),YY=$S(YY="^ ":"I",YY="^":"O",1:"R") + I $G(XQALAST)="I","OR"[YY D WAIT2 + I YY="I",$Y+4>IOSL D WAIT2 W @IOF + S XQALAST=YY + Q +WAIT2 ;Wait for user input before continuing + N DIR,Y,DIROUT,DIRUT S DIR(0)="E",DIR("?")="The next ALERT may cause the loss of info on the screen." + D ^DIR S:$D(DIRUT) XQXOUT=1 + Q + ; +HELP W !!,"YOU MAY ENTER:",!?3,$S(XQK>1:"One or more numbers",1:"A number")," in the range 1 to ",XQK," to select specific alert(s)" + W !?6,"for "_$S($D(XQALDELE):"DELETION.",$D(XQALFWD):"FORWARDING",1:"processing.") W:XQK>1 " This may be a series of numbers, e.g., 2,3,6-9" + W !?3,"A to "_$S($D(XQALDELE):"DELETE",$D(XQALFWD):"FORWARD",1:"process")," all of the pending alerts in the order shown." + W:'$D(XQALDELE)&'$D(XQALFWD) !?3,"I to process all of the INFORMATION ONLY alerts, if any, without further ado." + W:'$D(XQALDELE)&'$D(XQALFWD) !?3,"S to add or remove a surrogate to receive alerts for you" + W:'$D(XQALDELE)&'$D(XQALFWD) !?3,"F to forward one or more specific alerts. Forwarding may be as an ALERT",!,"to specific user(s) and/or mail group(s), or as a MAIL MESSAGE, or to a",!,"specific PRINTER." + W:'$D(XQALDELE)&'$D(XQALFWD) !?3,"D to delete specific alerts (some alerts may not be deleted)" + W:'$D(XQALDELE)&'$D(XQALFWD) !?3,"P to print a copy of the pending alerts on a printer" + W:'$D(XQALDELE)&'$D(XQALFWD) !?3,"M to receive a MailMan message containing a copy of these pending alerts" + W:'$D(XQALDELE) !?3,"R to Redisplay the available alerts" + W !?3,"^ to exit" + I XQI W !?5,"or RETURN to see additional pending ALERTS" + W !! + Q + ; +SORT ;Sort and remove display only + F XQI=0:0 S XQI=$O(^XTV(8992,XQAUSER,"XQA",XQI)) Q:XQI'>0 S XQX=^(XQI,0),XQZ=$G(^(1)),XQZ1=$G(^(2)) S XQJ=$P(XQX,U,7,8) K:XQJ=U ^XTV(8992,XQAUSER,"XQA",XQI) I XQJ'=U D + . S XQACNT=XQACNT+1,XQJ=$S(XQAREV:999999-XQACNT,1:XQACNT),^TMP("XQ",$J,"XQA",XQJ)=XQX,^(XQJ,1)=XQI,^(2)=XQZ,^(3)=XQZ1 + S XQK=0 F XQI=0:0 S XQI=$O(^TMP("XQ",$J,"XQA",XQI)) Q:XQI'>0 S XQK=XQK+1 M ^TMP("XQ",$J,"XQA1",XQK)=^TMP("XQ",$J,"XQA",XQI) + Q + ; +ASKDEL ; + N XQALDELE,XQX1COPY,XQAID,DA,XQAKILL,XQXOUT,XQAUSERD,XQALVALU + S XQALDELE=1 + K XQX1 + D DOIT^XQALERT1 + K XQALDELE S XQAUSERD=1 + I $D(XQX1),XQX1>0 D + . M XQX1COPY=XQX1 + . F Q:XQX1="" S DA=+XQX1,XQX1=$P(XQX1,",",2,99) D I XQX1="" S Y=$O(XQX1(0)) I Y>0 S XQX1=XQX1(Y) K XQX1(Y) + . . S XQAID=$P(^TMP("XQ",$J,"XQA1",DA),U,2),XQALVALU=^(DA),XQAKILL=1 + . . I $P(XQALVALU,U,8)=" "!$P(XQALVALU,U,10) D + . . . I XQAID="" K ^XTV(8992,XQAUSER,"XQA",+^TMP("XQ",$J,"XQA1",DA,1)) + . . . I XQAID'="" D DELETE^XQALDEL + . . . K ^TMP("XQ",$J,"XQA1",DA),^TMP("XQ",$J,"XQA",(999999-DA)) + . K XQX1 M XQX1=XQX1COPY S XQAID=0 + . F Q:XQX1="" S DA=+XQX1,XQX1=$P(XQX1,",",2,99) D I XQX1="" S Y=$O(XQX1(0)) I Y>0 S XQX1=XQX1(Y) K XQX1(Y) + . . I $D(^TMP("XQ",$J,"XQA1",DA)) W:'XQAID !!,"Unable to delete alerts which require action: ",DA W:XQAID ",",DA S XQAID=1 + . I XQAID=1 K DIR S DIR(0)="E" D ^DIR K DIR + K XQX1,XQAKILL + Q + ; +FRWRDONE ; + N XQX1,XQALFWDL S XQALFWDL(1)=XQAID + N XQAID + D FWDONE^XQALFWD + Q diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALMAKE.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALMAKE.m index 569575ca..f14454dd 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALMAKE.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALMAKE.m @@ -1,39 +1,33 @@ -XQALMAKE ;ISC-SF.SEA/JLI- HIGH LEVEL SETUP ALERT ;4/9/07 14:03 - ;;8.0;KERNEL;**443**;Jul 10, 1995;Build 4 - ;; -ENTRY ; - W !!,"ALERT GENERATOR" -TEXT K XQA,XQAMSG,XQAOPT,XQAROU,DIC,DIR - R !!,"ON THE NEXT LINE ENTER THE TEXT TO BE DISPLAYED FOR THE ALERT ___",!,X:DTIME G:'$T!(X[U)!(X="") EXIT W !!,X S XQALX=X,DIR(0)="Y",DIR("A")="Is this text OK? ",DIR("B")="YES" D ^DIR K DIR G:'Y TEXT S XQAMSG=XQALX - D LOOP1 G:'$D(XQA) EXIT -ASKOPT S DIR(0)="Y",DIR("A")="Do you want to transfer control to an option when the alert is selected" D ^DIR K DIR I Y D GETOPT G:Y'="" SETIT G ASKOPT -ASKROU S DIR(0)="Y",DIR("A")="Do you want to transfer control to a routine when the alert is selected" D ^DIR K DIR G:'Y SETIT - R !,"Enter ROUTINE name or ENTRY^ROUTINE name: ",X:DTIME S:'$T X=U G:X=U EXIT G:X="" ASKROU S XQAROU=X S X=$S(X'[U:X,1:$P(X,U,2)) G:X="" ASKROU X ^%ZOSF("TEST") I 'Y W !,"Routine '",X,"' not present" G ASKROU -SETIT ; - I '$D(XQAROU),'$D(XQAOPT) S DIR(0)="Y",DIR("A")="Do you want to make a long text info only alert" D ^DIR K DIR I Y D LONGTEXT - W !!,"As currently entered, this alert will display the following text:",!!,XQAMSG - W !!,"The alert is currently to be delivered to:" S XQAX="" F I=1:1 S XQAX=$O(XQA(XQAX)) Q:XQAX="" S X=$S(XQAX>0:$P(^VA(200,XQAX,0),U),1:XQAX) W:(I#2) ! W:'(I#2) ?40 W X - W:$D(XQAROU) !!,"On selection of the alert, the user will run the routine ",XQAROU W:$D(XQAOPT) !!,"On selection of the alert, the user will be taken to the",!,"the option ",XQAOPT W !! - S DIR(0)="Y",DIR("A")="Is this alert what was intended",DIR("B")="YES" D ^DIR K DIR I 'Y G ENTRY - D SETUP^XQALERT - W !!?20,"ALERT IS NOW SET",!! - G ENTRY - ; -GETOPT ; - S DIC=19,DIC(0)="AEQM",DIC("A")="Indicate the desired OPTION: " D ^DIC K DIC S:Y'>0 Y="" S XQAOPT=$P(Y,U,2) - Q - ; -EXIT ; - K XQALDIC,XQALX,XQA,XQAMSG,XQAOPT,XQAROU,DIC,DIR,X,Y - Q -LOOP1 K XQA R !,"Enter a User name or G.mailgroup",!,"as recipient of the Alert: ",X:DTIME S:'$T!(X="") X=U I X'[U D SETONE G:Y'>0 LOOP1 - I X'[U F R !,"Enter another user or G.mailgroup: ",X:DTIME S:'$T X=U Q:X[U!(X="") D SETONE - K:X[U XQA Q -SETONE ; - S XQALDIC=$S("g.G."[$E(X,1,2):3.8,1:200),X=$S(XQALDIC=3.8:$E(X,3,$L(X)),1:X),DIC=XQALDIC,DIC(0)="EMQ" D ^DIC Q:Y'>0 S X=$S(XQALDIC=3.8:"G."_$P(Y,U,2),1:+Y),XQA(X)="" - Q - ; -LONGTEXT ; - W !,"Enter .EXIT to terminate input",! - S COUNT="" F R X:DTIME Q:X=".EXIT" S COUNT=COUNT+1,XQATEXT(COUNT)=X W ! - Q +XQALMAKE ;ISC-SF.SEA/JLI- HIGH LEVEL SETUP ALERT ;9/23/94 13:28 + ;;8.0;KERNEL;;Jul 10, 1995 + ;; +ENTRY ; + W !!,"ALERT GENERATOR" +TEXT K XQA,XQAMSG,XQAOPT,XQAROU,DIC,DIR + R !!,"ON THE NEXT LINE ENTER THE TEXT TO BE DISPLAYED FOR THE ALERT ___",!,X:DTIME G:'$T!(X[U)!(X="") EXIT W !!,X S XQALX=X,DIR(0)="Y",DIR("A")="Is this text OK? ",DIR("B")="YES" D ^DIR K DIR G:'Y TEXT S XQAMSG=XQALX + D LOOP1 G:'$D(XQA) EXIT +ASKOPT S DIR(0)="Y",DIR("A")="Do you want to transfer control to an option when the alert is selected" D ^DIR K DIR I Y D GETOPT G:Y'="" SETIT G ASKOPT +ASKROU S DIR(0)="Y",DIR("A")="Do you want to transfer control to a routine when the alert is selected" D ^DIR K DIR G:'Y SETIT + R !,"Enter ROUTINE name or ENTRY^ROUTINE name: ",X:DTIME S:'$T X=U G:X=U EXIT G:X="" ASKROU S XQAROU=X S X=$S(X'[U:X,1:$P(X,U,2)) G:X="" ASKROU X ^%ZOSF("TEST") I 'Y W !,"Routine '",X,"' not present" G ASKROU +SETIT ; + W !!,"As currently entered, this alert will display the following text:",!!,XQAMSG + W !!,"The alert is currently to be delivered to:" S XQAX="" F I=1:1 S XQAX=$O(XQA(XQAX)) Q:XQAX="" S X=$S(XQAX>0:$P(^VA(200,XQAX,0),U),1:XQAX) W:(I#2) ! W:'(I#2) ?40 W X + W:$D(XQAROU) !!,"On selection of the alert, the user will run the routine ",XQAROU W:$D(XQAOPT) !!,"On selection of the alert, the user will be taken to the",!,"the option ",XQAOPT W !! + S DIR(0)="Y",DIR("A")="Is this alert what was intended",DIR("B")="YES" D ^DIR K DIR I 'Y G ENTRY + D SETUP^XQALERT + W !!?20,"ALERT IS NOW SET",!! + G ENTRY + ; +GETOPT ; + S DIC=19,DIC(0)="AEQM",DIC("A")="Indicate the desired OPTION: " D ^DIC K DIC S:Y'>0 Y="" S XQAOPT=$P(Y,U,2) + Q + ; +EXIT ; + K XQALDIC,XQALX,XQA,XQAMSG,XQAOPT,XQAROU,DIC,DIR,X,Y + Q +LOOP1 K XQA R !,"Enter a User name or G.mailgroup",!,"as recipient of the Alert: ",X:DTIME S:'$T!(X="") X=U I X'[U D SETONE G:Y'>0 LOOP1 + I X'[U F R !,"Enter another user or G.mailgroup: ",X:DTIME S:'$T X=U Q:X[U!(X="") D SETONE + K:X[U XQA Q +SETONE ; + S XQALDIC=$S("g.G."[$E(X,1,2):3.8,1:200),X=$S(XQALDIC=3.8:$E(X,3,$L(X)),1:X),DIC=XQALDIC,DIC(0)="EMQ" D ^DIC Q:Y'>0 S X=$S(XQALDIC=3.8:"G."_$P(Y,U,2),1:+Y),XQA(X)="" + Q diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALSET.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALSET.m index f03e7546..945b290e 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALSET.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALSET.m @@ -1,159 +1,157 @@ -XQALSET ;ISC-SF.SEA/JLI - SETUP ALERTS ;4/10/07 14:06 - ;;8.0;KERNEL;**1,6,65,75,114,125,173,207,285,443**;Jul 10, 1995;Build 4 - ;; - Q - ; Original entry point - throw away return value since no value expected -SETUP ; - N I S I=$$SETUP1() K XQALERR - Q - ; -SETUP1() ; .SR Returns a string beginning with 1 if successful, 0 if not successful, the second piece is the IEN in the Alert Tracking File and the third piece is the value of XQAID. - ; If not successful XQALERR is defined and contains reason for failure. - K XQALERR - I $O(XQA(0))="" S XQALERR="No recipient list in XQA array" Q 0 - I '($D(XQAMSG)#2)!($G(XQAMSG)="") S XQALERR="No valid XQAMSG for display" Q 0 - N X,XQI,XQJ,XQX,XQK,XQACOMNT,XQARESET,DA,XQADA,XQALTYPE - S XQALTYPE="INITIAL RECIPIENT" - S XQAOPT1=$S('($D(XQAROU)#2):U,XQAROU'[U:U_XQAROU,1:XQAROU),XQAOPT1=$S(XQAOPT1'=U:XQAOPT1,$D(XQAOPT)#2:XQAOPT_U,1:XQAOPT1) S:XQAOPT1=U XQAOPT1=U_" " -NOW S XQX=$$NOW^XLFDT() - S:$S('$D(XQAID):1,XQAID="":1,1:0) XQAID="NO-ID" S:XQAID[";" XQAID=$P(XQAID,";") S XQA1=XQAID,XQI=XQX - S XQAID=$$SETIEN(XQA1,XQX),XQADA="" - Q $$REENT() - ; -REENT() ; Entry for forwarding, etc. - N RETVAL S RETVAL=1 - K ^TMP("XQAGROUP",$J) ; P443 - clear location for storage of groups processed - N XQADATIM,XQALIST,XQALIST1,XQNRECIP S XQNRECIP=0 S XQADATIM=$$NOW^XLFDT() - S XQALIN1=$S($D(XQAID)#2:XQAID,1:"")_U_$E(XQAMSG,1,80)_"^1^"_$S(XQAOPT1=U:"D",1:"R")_U_$S($D(XQACTMSG):$E(XQACTMSG,1,40),1:"")_U_XQAOPT1 - S:$D(XQACNDEL) $P(XQALIN1,U,9)=1 S:$D(XQASURO) $P(XQALIN1,U,12)=XQASURO S:$D(XQASUPV) $P(XQALIN1,U,13)=XQASUPV S:$D(XQAREVUE) $P(XQALIN1,U,14)=XQAREVUE - S XQALIN=XQX_U_XQALIN1,XQJ=0 - K XQALIN1 S:$D(XQADATA) XQALIN1=XQADATA -LOOP1 S XQJ=$O(XQA(" ")) I XQJ'="" K:"G.g."'[$E(XQJ_",,",1,2) XQA(XQJ) D:$D(XQA(XQJ)) GROUP^XQALSET1 G LOOP1 -LOOP2 ; RE-ENTRY FOR FORWARDING IF ALL RECIPIENTS ARE UNDELIVERABLE - N:'$D(XQAUSER) XQAUSER M XQALIST=XQA F I=0:0 S I=$O(XQALIST(I)) Q:I'>0 S XQALIST(I,XQALTYPE)="" I '$D(XQAUSER) S XQAUSER=I ; SAVE ORIGINAL LIST OF RECIPIENTS AND REASON - ; The following section of code was added to provide a generalized way to handle surrogates - F XQJ=0:0 S XQJ=$O(XQA(XQJ)) Q:XQJ="" D - . N X S X=$$ACTVSURO^XQALSURO(XQJ) I X>0 D ; Modified to get final surrogate if a sequence of them - . . S XQA(X)="" K XQA(XQJ) ; Add Surrogate to XQA array, delete XQJ entry - . . S XQALIST(X,$O(XQALIST(XQJ,""))_"-SURROGATE")="" ; Add Surrogate to XQALIST with same type as original - . . S XQALIST(X,"z AS_SURO",XQJ)="" ; Mark user as in list as a surrogate, subscript for surrogate to - . . S XQALIST(XQJ,"z TO_SURO",X)="" - . . Q - . Q - ; - S XQJ=0 -LOOP ; - S XQJ=$O(XQA(XQJ)) G:XQJ="" WRAP - ; - I '(+$$ACTIVE^XUSER(XQJ)) K XQA(XQJ) N XX S XX=$O(XQALIST(XQJ,"")) K XQALIST(XQJ,XX) S XQALIST(XQJ,XX_"-UNDELIVERABLE")="" G LOOP ;Don't send to users that can't sign-on - ; - I '$D(^XTV(8992,XQJ,0)) D I '$D(^XTV(8992,XQJ,0)) S ^(0)=XQJ - . N FDA,IENS - . F D Q:'$D(DIERR) Q:'$D(^TMP("DIERR",$J,"E",110))&'$D(^TMP("DIERR",$J,"E",111)) - . . K DIERR,^TMP("DIERR",$J) - . . S FDA=$NA(^TMP($J,"XQALSET")) K @FDA S @FDA@(8992,"+1,",.01)=XQJ - . . S IENS(1)=XQJ - . . D UPDATE^DIE("S",FDA,"IENS") - . . Q - . Q - L +^XTV(8992,XQJ):10 S XQXI=XQX S:'$D(^XTV(8992,XQJ,"XQA",0)) ^(0)="^8992.01DA^" -REP I $D(^XTV(8992,XQJ,"XQA",XQXI,0)) S XQXI=XQXI+.00000001 G REP - S ^XTV(8992,XQJ,"XQA",XQXI,0)=XQALIN S:$D(XQALIN1) ^(1)=XQALIN1 S:$D(XQAGUID)!$D(XQADFN) ^(3)=$G(XQAGUID)_U_$G(XQADFN) S:$D(XQARESET) ^(2)=XQAUSER_U_XQX_U_$G(XQACOMNT) S ^(0)=$P(^XTV(8992,XQJ,"XQA",0),U,1,2)_U_XQXI_U_($P(^(0),U,4)+1) - I $D(XQATEXT) S:($D(XQATEXT)#2) XQATEXT(.1)=XQATEXT D WP^DIE(8992.01,(XQXI_","_XQJ_","),4,"","XQATEXT") ; P443 PUT DATA IN XQATEXT INTO ARRAY - L -^XTV(8992,XQJ) - K XQA(XQJ) S:XQAID'="" ^XTV(8992,"AXQA",XQAID,XQJ,XQXI)="",^XTV(8992,"AXQAN",XQA1,XQJ,XQXI)="" - S XQNRECIP=XQNRECIP+1 - G LOOP - ; -WRAP ; - M XQALIST1=XQALIST - I XQNRECIP=0,'$$SNDNACTV(XQAID) S RETVAL=0,XQALERR="NO ACTIVE RECIPIENTS - OLDER TIU ALERTS" - E I XQNRECIP=0 D I $D(XQA) S XQACOMNT=$E("None of recipients were active users. "_$G(XQACOMNT),1,245),XQNRECIP=1,XQARESET=1 K XQALIST G LOOP2 ; SET NUMBER OF RECIPIENTS TO 1 SO WE WON'T COME HERE AGAIN - . N XQAA,XQJ F XQI=0:0 S XQI=$O(XQALIST(XQI)) Q:XQI'>0 D GETBKUP^XQALDEL(.XQAA,XQI) S XQALTYPE="BACKUP REVIEWER" F XQJ=0:0 S XQJ=$O(XQAA(XQJ)) Q:XQJ'>0 S XQA(XQAA(XQJ))="" - . I $D(XQA) D CHEKACTV^XQALSET1(.XQA) - . I '$D(XQA) S XQJ="G.XQAL UNPROCESSED ALERTS" D GROUP^XQALSET1 S XQALTYPE="UNPROCESSED ALERTS MAIL GROUP" ;D GETMLGRP(.XQA,XQI) ; COULDN'T FIND ANY BACKUP, GET A MAILGROUP AND MEMBERS TO SEND IT TO - . I '$D(XQA) S XQJ="G.PATCHES" D GROUP^XQALSET1 S XQALTYPE="LAST HOPE" ; Last gasp, send it to G.PATCHES - . I '$D(XQA) S XQJ="G.PATCH" D GROUP^XQALSET1 S XQALTYPE="LAST HOPE" ; Last gasp, send it to G.PATCH - . I '$D(XQA) S RETVAL=0,XQALERR="Could not find any active user to send it to" ; Should not get here, this is only if all backups and mail groups tried don't have any active users - . Q - ; END OF JLI 030129 INSERTION P285 - ; moved recording of users in Alert Tracking file to here to include all of them 030220 - ; modified code to use FM calls instead of direct global references - I RETVAL,$G(XQADA)'>0,XQAID'="" D SETTRACK ; moved to here to avoid tracking entries with no users - ; - I RETVAL,$G(XQADA)>0 L +^XTV(8992.1,XQADA):10 D L -^XTV(8992.1,XQADA) ; 030131 - . F XQJ=0:0 S XQJ=$O(XQALIST1(XQJ)) Q:XQJ'>0 D - . . N NCOUNT,SUBSCRPT,SUBSCRPN,KCNT,IENVAL - . . S IENVAL=XQADA_",",KCNT=$$FIND1^DIC(8992.11,","_IENVAL,"Q",XQJ) - . . S FDA=$NA(^TMP($J,"XQALSET")) K @FDA I KCNT=0 S @FDA@(8992.11,"+1,"_IENVAL,.01)=XQJ,KCNT="+1" - . . S IENVAL=","_KCNT_","_IENVAL,NCOUNT=1 S SUBSCRPT="" F S SUBSCRPT=$O(XQALIST1(XQJ,SUBSCRPT)) Q:SUBSCRPT="" I $E(SUBSCRPT,1)'="z" D - . . . S SUBSCRPN=$$FIND1^DIC(8992.2,"","X",SUBSCRPT) I SUBSCRPN'>0 D - . . . . N FDA1,IENROOT S FDA1=$NA(^TMP($J,"XQALSET1")) K @FDA1 S @FDA1@(8992.2,"+1,",.01)=SUBSCRPT D UPDATE^DIE("",FDA1,"IENROOT") S SUBSCRPN=$G(IENROOT(1)) - . . . . Q - . . . S NCOUNT=NCOUNT+1,@FDA@(8992.111,"+"_NCOUNT_IENVAL,.01)=SUBSCRPN,@FDA@(8992.111,"+"_NCOUNT_IENVAL,.04)=XQADATIM - . . . Q - . . I $D(XQALIST1(XQJ,"z TO_SURO")) S @FDA@(8992.111,"+"_NCOUNT_IENVAL,.02)=$O(XQALIST1(XQJ,"z TO_SURO",0)) - . . I $D(XQALIST1(XQJ,"z AS_SURO")) D - . . . S @FDA@(8992.111,"+"_NCOUNT_IENVAL,.03)="Y" - . . . N XQK S NCOUNT=NCOUNT+1 F XQK=0:0 S XQK=$O(XQALIST1(XQJ,"z AS_SURO",XQK)) Q:XQK'>0 S @FDA@(8992.113,"+"_NCOUNT_IENVAL,.01)=XQK,@FDA@(8992.113,"+"_NCOUNT_IENVAL,.02)=XQADATIM - . . . Q - . . S SUBSCRPT=$O(XQALIST1(XQJ,"")) I SUBSCRPT'["INITIAL" S SUBSCRPT=$P(SUBSCRPT,"-") D ; FORWARDING - . . . S SUBSCRPN=$$FIND1^DIC(8992.2,"","X",SUBSCRPT) I SUBSCRPN'>0 D - . . . . N FDA1,IENROOT S FDA1=$NA(^TMP($J,"XQALSET1")) K @FDA1 S @FDA1@(8992.2,"+1,",.01)=SUBSCRPT D UPDATE^DIE("",FDA1,"IENROOT") S SUBSCRPN=$G(IENROOT(1)) - . . . . Q - . . . S NCOUNT=NCOUNT+1,@FDA@(8992.112,"+"_NCOUNT_IENVAL,.01)=XQADATIM,@FDA@(8992.112,"+"_NCOUNT_IENVAL,.02)=SUBSCRPN I $G(XQACOMNT)'="" S @FDA@(8992.112,"+"_NCOUNT_IENVAL,1.01)=XQACOMNT - . . . I $G(XQAUSER)>0 S @FDA@(8992.112,"+"_NCOUNT_IENVAL,.03)=XQAUSER - . . . Q - . . N IENSTR D UPDATE^DIE("",FDA,"IENSTR") - . . Q - . Q - ; - I RETVAL S RETVAL=RETVAL_U_$G(XQADA)_U_XQAID - K:XQAID'="" ^XTV(8992,"AXQA",XQAID,0,0) - K ^TMP("XQAGROUP",$J) ; P443 - clear global used to track processing of groups - K XQA,XQALIN,XQALIN1,XQAMSG,XQAID,XQAFLG,XQAOPT,XQAOPT1,XQAROU,XQADATA,XQI,XQX,XQJ,XQK,XQA1,XQACTMSG,XQJ,XQXI,XQAARCH,XQACNDEL,XQAREVUE,XQASUPV,XQASURO,XQATEXT - Q RETVAL - ; -SNDNACTV(XQAID) ; Determine if we go ahead and send alerts addressed only to inactive users to backup reviewers - N XVAL - I $E(XQAID,1,3)="TIU" S XVAL=$E($P(XQAID,";"),4,99),XVAL=$$GET1^DIQ(8925,XVAL_",",1201,"I") I XVAL>0,$$FMDIFF^XLFDT(DT,XVAL)>60 Q 0 - Q 1 - ; -SETIEN(XQA1,XQI) ; determine unique XQAID value for alert - N XQAID - S:$G(XQA1)="" XQA1="NO-ID" F S XQAID=XQA1_";"_DUZ_";"_XQI L +^XTV(8992,"AXQA",XQAID):10 D L -^XTV(8992,"AXQA",XQAID) Q:XQI="" S XQI=XQI+.00000001 - . I $D(^XTV(8992,"AXQA",XQAID)) Q - . S ^XTV(8992,"AXQA",XQAID,0,0)="",XQI="" - . Q - Q XQAID - ; -SETTRACK ; Setup entry in Alert Tracking file - ; Note: if there are error messages or we can't create an entry for some reason, it simply returns and continues - N FDA,IENS,XQA2,DIERR - S XQADA=0 - S XQA2=XQA1 I XQA2[",",$P(XQA2,",",3)'="" S XQA2=$P(XQA2,",")_","_$P(XQA2,",",3) - F D Q:'$D(DIERR) Q:'$D(^TMP("DIERR",$J,"E",111)) - . K DIERR,^TMP("DIERR",$J) - . S FDA=$NA(^TMP($J,"XQALSET")) K @FDA - . S @FDA@(8992.1,"+1,",.01)=XQAID D UPDATE^DIE("",FDA,"IENS") - . K @FDA - . Q - I $D(DIERR) Q ;S XQDIERR1=DIERR M XQDIERR=^TMP("DIERR",$J) Q - Q:IENS(1)'>0 S (DA,XQADA)=IENS(1) - S IENS=IENS(1)_",",@FDA@(8992.1,IENS,.02)=XQX,^(.03)=XQA2,^(.05)=DUZ,^(1.01)=XQAMSG - I $D(XQAARCH) S X=$$FMADD^XLFDT(DT,XQAARCH) I X>DT S @FDA@(8992.1,IENS,.08)=X - I $P(XQA1,",")="OR",$P(XQA1,",",2)>0 S @FDA@(8992.1,IENS,.04)=$P(XQA1,",",2) - I $D(ZTQUEUED) S @FDA@(8992.1,IENS,.06)=1 - I $D(XQAOPT)#2 S @FDA@(8992.1,IENS,1.02)=XQAOPT - I $D(XQAROU)#2 N XQAXX S XQAXX=$S(XQAROU[U:XQAROU,1:U_XQAROU) I $P(XQAXX,U,2)'="" S:$P(XQAXX,U)'="" @FDA@(8992.1,IENS,1.03)=$P(XQAXX,U) S @FDA@(8992.1,IENS,1.04)=$P(XQAXX,U,2) - I $D(XQACTMSG) S @FDA@(8992.1,IENS,1.05)=XQACTMSG - I $D(XQADATA) S @FDA@(8992.1,IENS,2)=XQADATA - I $D(XQAGUID) S @FDA@(8992.1,IENS,3.01)=XQAGUID - I $D(XQADFN) S @FDA@(8992.1,IENS,.04)=XQADFN - D FILE^DIE("KS",FDA) - I $D(XQATEXT) D WP^DIE(8992.1,IENS,4,"","XQATEXT") - Q - ; -CHEKUSER(XQAUSER) ; .SR Returns 0 if no valid user or surrogate, otherwise returns IEN of user or surrogate - Q $$CHEKUSER^XQALSET1(XQAUSER) - ; +XQALSET ;ISC-SF.SEA/JLI - SETUP ALERTS ;6/24/04 13:46 + ;;8.0;KERNEL;**1,6,65,75,114,125,173,207,285**;Jul 10, 1995 + ;; + Q + ; Original entry point - throw away return value since no value expected +SETUP ; + N I S I=$$SETUP1() K XQALERR + Q + ; +SETUP1() ; .SR Returns a string beginning with 1 if successful, 0 if not successful, the second piece is the IEN in the Alert Tracking File and the third piece is the value of XQAID. + ; If not successful XQALERR is defined and contains reason for failure. + K XQALERR + I $O(XQA(0))="" S XQALERR="No recipient list in XQA array" Q 0 + I '($D(XQAMSG)#2)!($G(XQAMSG)="") S XQALERR="No valid XQAMSG for display" Q 0 + N X,XQI,XQJ,XQX,XQK,XQACOMNT,XQARESET,DA,XQADA,XQALTYPE + S XQALTYPE="INITIAL RECIPIENT" + S XQAOPT1=$S('($D(XQAROU)#2):U,XQAROU'[U:U_XQAROU,1:XQAROU),XQAOPT1=$S(XQAOPT1'=U:XQAOPT1,$D(XQAOPT)#2:XQAOPT_U,1:XQAOPT1) S:XQAOPT1=U XQAOPT1=U_" " +NOW S XQX=$$NOW^XLFDT() + S:$S('$D(XQAID):1,XQAID="":1,1:0) XQAID="NO-ID" S:XQAID[";" XQAID=$P(XQAID,";") S XQA1=XQAID,XQI=XQX + S XQAID=$$SETIEN(XQA1,XQX),XQADA="" + Q $$REENT() + ; +REENT() ; Entry for forwarding, etc. + N RETVAL S RETVAL=1 + N XQADATIM,XQALIST,XQALIST1,XQNRECIP S XQNRECIP=0 S XQADATIM=$$NOW^XLFDT() + S XQALIN1=$S($D(XQAID)#2:XQAID,1:"")_U_$E(XQAMSG,1,80)_"^1^"_$S(XQAOPT1=U:"D",1:"R")_U_$S($D(XQACTMSG):$E(XQACTMSG,1,40),1:"")_U_XQAOPT1 + S:$D(XQACNDEL) $P(XQALIN1,U,9)=1 S:$D(XQASURO) $P(XQALIN1,U,12)=XQASURO S:$D(XQASUPV) $P(XQALIN1,U,13)=XQASUPV S:$D(XQAREVUE) $P(XQALIN1,U,14)=XQAREVUE + S XQALIN=XQX_U_XQALIN1,XQJ=0 + K XQALIN1 S:$D(XQADATA) XQALIN1=XQADATA +LOOP1 S XQJ=$O(XQA(" ")) I XQJ'="" K:"G.g."'[$E(XQJ_",,",1,2) XQA(XQJ) D:$D(XQA(XQJ)) GROUP^XQALSET1 G LOOP1 +LOOP2 ; RE-ENTRY FOR FORWARDING IF ALL RECIPIENTS ARE UNDELIVERABLE + N:'$D(XQAUSER) XQAUSER M XQALIST=XQA F I=0:0 S I=$O(XQALIST(I)) Q:I'>0 S XQALIST(I,XQALTYPE)="" I '$D(XQAUSER) S XQAUSER=I ; SAVE ORIGINAL LIST OF RECIPIENTS AND REASON + ; The following section of code was added to provide a generalized way to handle surrogates + F XQJ=0:0 S XQJ=$O(XQA(XQJ)) Q:XQJ="" D + . N X S X=$$ACTVSURO^XQALSURO(XQJ) I X>0 D ; Modified to get final surrogate if a sequence of them + . . S XQA(X)="" K XQA(XQJ) ; Add Surrogate to XQA array, delete XQJ entry + . . S XQALIST(X,$O(XQALIST(XQJ,""))_"-SURROGATE")="" ; Add Surrogate to XQALIST with same type as original + . . S XQALIST(X,"z AS_SURO",XQJ)="" ; Mark user as in list as a surrogate, subscript for surrogate to + . . S XQALIST(XQJ,"z TO_SURO",X)="" + . . Q + . Q + ; + S XQJ=0 +LOOP ; + S XQJ=$O(XQA(XQJ)) G:XQJ="" WRAP + ; + I '(+$$ACTIVE^XUSER(XQJ)) K XQA(XQJ) N XX S XX=$O(XQALIST(XQJ,"")) K XQALIST(XQJ,XX) S XQALIST(XQJ,XX_"-UNDELIVERABLE")="" G LOOP ;Don't send to users that can't sign-on + ; + I '$D(^XTV(8992,XQJ,0)) D I '$D(^XTV(8992,XQJ,0)) S ^(0)=XQJ + . N FDA,IENS + . F D Q:'$D(DIERR) Q:'$D(^TMP("DIERR",$J,"E",110))&'$D(^TMP("DIERR",$J,"E",111)) + . . K DIERR,^TMP("DIERR",$J) + . . S FDA=$NA(^TMP($J,"XQALSET")) K @FDA S @FDA@(8992,"+1,",.01)=XQJ + . . S IENS(1)=XQJ + . . D UPDATE^DIE("S",FDA,"IENS") + . . Q + . Q + L +^XTV(8992,XQJ):10 S XQXI=XQX S:'$D(^XTV(8992,XQJ,"XQA",0)) ^(0)="^8992.01DA^" +REP I $D(^XTV(8992,XQJ,"XQA",XQXI,0)) S XQXI=XQXI+.00000001 G REP + S ^XTV(8992,XQJ,"XQA",XQXI,0)=XQALIN S:$D(XQALIN1) ^(1)=XQALIN1 S:$D(XQAGUID)!$D(XQADFN) ^(3)=$G(XQAGUID)_U_$G(XQADFN) S:$D(XQARESET) ^(2)=XQAUSER_U_XQX_U_$G(XQACOMNT) S ^(0)=$P(^XTV(8992,XQJ,"XQA",0),U,1,2)_U_XQXI_U_($P(^(0),U,4)+1) + I $D(XQATEXT) D WP^DIE(8992.01,(XQXI_","_XQJ_","),4,"","XQATEXT") + L -^XTV(8992,XQJ) + K XQA(XQJ) S:XQAID'="" ^XTV(8992,"AXQA",XQAID,XQJ,XQXI)="",^XTV(8992,"AXQAN",XQA1,XQJ,XQXI)="" + S XQNRECIP=XQNRECIP+1 + G LOOP + ; +WRAP ; + M XQALIST1=XQALIST + I XQNRECIP=0,'$$SNDNACTV(XQAID) S RETVAL=0,XQALERR="NO ACTIVE RECIPIENTS - OLDER TIU ALERTS" + E I XQNRECIP=0 D I $D(XQA) S XQACOMNT=$E("None of recipients were active users. "_$G(XQACOMNT),1,245),XQNRECIP=1,XQARESET=1 K XQALIST G LOOP2 ; SET NUMBER OF RECIPIENTS TO 1 SO WE WON'T COME HERE AGAIN + . N XQAA,XQJ F XQI=0:0 S XQI=$O(XQALIST(XQI)) Q:XQI'>0 D GETBKUP^XQALDEL(.XQAA,XQI) S XQALTYPE="BACKUP REVIEWER" F XQJ=0:0 S XQJ=$O(XQAA(XQJ)) Q:XQJ'>0 S XQA(XQAA(XQJ))="" + . I $D(XQA) D CHEKACTV^XQALSET1(.XQA) + . I '$D(XQA) S XQJ="G.XQAL UNPROCESSED ALERTS" D GROUP^XQALSET1 S XQALTYPE="UNPROCESSED ALERTS MAIL GROUP" ;D GETMLGRP(.XQA,XQI) ; COULDN'T FIND ANY BACKUP, GET A MAILGROUP AND MEMBERS TO SEND IT TO + . I '$D(XQA) S XQJ="G.PATCHES" D GROUP^XQALSET1 S XQALTYPE="LAST HOPE" ; Last gasp, send it to G.PATCHES + . I '$D(XQA) S XQJ="G.PATCH" D GROUP^XQALSET1 S XQALTYPE="LAST HOPE" ; Last gasp, send it to G.PATCH + . I '$D(XQA) S RETVAL=0,XQALERR="Could not find any active user to send it to" ; Should not get here, this is only if all backups and mail groups tried don't have any active users + . Q + ; END OF JLI 030129 INSERTION P285 + ; moved recording of users in Alert Tracking file to here to include all of them 030220 + ; modified code to use FM calls instead of direct global references + I RETVAL,$G(XQADA)'>0,XQAID'="" D SETTRACK ; moved to here to avoid tracking entries with no users + ; + I RETVAL,$G(XQADA)>0 L +^XTV(8992.1,XQADA):10 D L -^XTV(8992.1,XQADA) ; 030131 + . F XQJ=0:0 S XQJ=$O(XQALIST1(XQJ)) Q:XQJ'>0 D + . . N NCOUNT,SUBSCRPT,SUBSCRPN,KCNT,IENVAL + . . S IENVAL=XQADA_",",KCNT=$$FIND1^DIC(8992.11,","_IENVAL,"Q",XQJ) + . . S FDA=$NA(^TMP($J,"XQALSET")) K @FDA I KCNT=0 S @FDA@(8992.11,"+1,"_IENVAL,.01)=XQJ,KCNT="+1" + . . S IENVAL=","_KCNT_","_IENVAL,NCOUNT=1 S SUBSCRPT="" F S SUBSCRPT=$O(XQALIST1(XQJ,SUBSCRPT)) Q:SUBSCRPT="" I $E(SUBSCRPT,1)'="z" D + . . . S SUBSCRPN=$$FIND1^DIC(8992.2,"","X",SUBSCRPT) I SUBSCRPN'>0 D + . . . . N FDA1,IENROOT S FDA1=$NA(^TMP($J,"XQALSET1")) K @FDA1 S @FDA1@(8992.2,"+1,",.01)=SUBSCRPT D UPDATE^DIE("",FDA1,"IENROOT") S SUBSCRPN=$G(IENROOT(1)) + . . . . Q + . . . S NCOUNT=NCOUNT+1,@FDA@(8992.111,"+"_NCOUNT_IENVAL,.01)=SUBSCRPN,@FDA@(8992.111,"+"_NCOUNT_IENVAL,.04)=XQADATIM + . . . Q + . . I $D(XQALIST1(XQJ,"z TO_SURO")) S @FDA@(8992.111,"+"_NCOUNT_IENVAL,.02)=$O(XQALIST1(XQJ,"z TO_SURO",0)) + . . I $D(XQALIST1(XQJ,"z AS_SURO")) D + . . . S @FDA@(8992.111,"+"_NCOUNT_IENVAL,.03)="Y" + . . . N XQK S NCOUNT=NCOUNT+1 F XQK=0:0 S XQK=$O(XQALIST1(XQJ,"z AS_SURO",XQK)) Q:XQK'>0 S @FDA@(8992.113,"+"_NCOUNT_IENVAL,.01)=XQK,@FDA@(8992.113,"+"_NCOUNT_IENVAL,.02)=XQADATIM + . . . Q + . . S SUBSCRPT=$O(XQALIST1(XQJ,"")) I SUBSCRPT'["INITIAL" S SUBSCRPT=$P(SUBSCRPT,"-") D ; FORWARDING + . . . S SUBSCRPN=$$FIND1^DIC(8992.2,"","X",SUBSCRPT) I SUBSCRPN'>0 D + . . . . N FDA1,IENROOT S FDA1=$NA(^TMP($J,"XQALSET1")) K @FDA1 S @FDA1@(8992.2,"+1,",.01)=SUBSCRPT D UPDATE^DIE("",FDA1,"IENROOT") S SUBSCRPN=$G(IENROOT(1)) + . . . . Q + . . . S NCOUNT=NCOUNT+1,@FDA@(8992.112,"+"_NCOUNT_IENVAL,.01)=XQADATIM,@FDA@(8992.112,"+"_NCOUNT_IENVAL,.02)=SUBSCRPN I $G(XQACOMNT)'="" S @FDA@(8992.112,"+"_NCOUNT_IENVAL,1.01)=XQACOMNT + . . . I $G(XQAUSER)>0 S @FDA@(8992.112,"+"_NCOUNT_IENVAL,.03)=XQAUSER + . . . Q + . . N IENSTR D UPDATE^DIE("",FDA,"IENSTR") + . . Q + . Q + ; + I RETVAL S RETVAL=RETVAL_U_$G(XQADA)_U_XQAID + K:XQAID'="" ^XTV(8992,"AXQA",XQAID,0,0) + K XQA,XQALIN,XQALIN1,XQAMSG,XQAID,XQAFLG,XQAOPT,XQAOPT1,XQAROU,XQADATA,XQI,XQX,XQJ,XQK,XQA1,XQACTMSG,XQJ,XQXI,XQAARCH,XQACNDEL,XQAREVUE,XQASUPV,XQASURO,XQATEXT + Q RETVAL + ; +SNDNACTV(XQAID) ; Determine if we go ahead and send alerts addressed only to inactive users to backup reviewers + N XVAL + I $E(XQAID,1,3)="TIU" S XVAL=$E($P(XQAID,";"),4,99),XVAL=$$GET1^DIQ(8925,XVAL_",",1201,"I") I XVAL>0,$$FMDIFF^XLFDT(DT,XVAL)>60 Q 0 + Q 1 + ; +SETIEN(XQA1,XQI) ; determine unique XQAID value for alert + N XQAID + S:$G(XQA1)="" XQA1="NO-ID" F S XQAID=XQA1_";"_DUZ_";"_XQI L +^XTV(8992,"AXQA",XQAID):10 D L -^XTV(8992,"AXQA",XQAID) Q:XQI="" S XQI=XQI+.00000001 + . I $D(^XTV(8992,"AXQA",XQAID)) Q + . S ^XTV(8992,"AXQA",XQAID,0,0)="",XQI="" + . Q + Q XQAID + ; +SETTRACK ; Setup entry in Alert Tracking file + ; Note: if there are error messages or we can't create an entry for some reason, it simply returns and continues + N FDA,IENS,XQA2,DIERR + S XQADA=0 + S XQA2=XQA1 I XQA2[",",$P(XQA2,",",3)'="" S XQA2=$P(XQA2,",")_","_$P(XQA2,",",3) + F D Q:'$D(DIERR) Q:'$D(^TMP("DIERR",$J,"E",111)) + . K DIERR,^TMP("DIERR",$J) + . S FDA=$NA(^TMP($J,"XQALSET")) K @FDA + . S @FDA@(8992.1,"+1,",.01)=XQAID D UPDATE^DIE("",FDA,"IENS") + . K @FDA + . Q + I $D(DIERR) Q ;S XQDIERR1=DIERR M XQDIERR=^TMP("DIERR",$J) Q + Q:IENS(1)'>0 S (DA,XQADA)=IENS(1) + S IENS=IENS(1)_",",@FDA@(8992.1,IENS,.02)=XQX,^(.03)=XQA2,^(.05)=DUZ,^(1.01)=XQAMSG + I $D(XQAARCH) S X=$$FMADD^XLFDT(DT,XQAARCH) I X>DT S @FDA@(8992.1,IENS,.08)=X + I $P(XQA1,",")="OR",$P(XQA1,",",2)>0 S @FDA@(8992.1,IENS,.04)=$P(XQA1,",",2) + I $D(ZTQUEUED) S @FDA@(8992.1,IENS,.06)=1 + I $D(XQAOPT)#2 S @FDA@(8992.1,IENS,1.02)=XQAOPT + I $D(XQAROU)#2 N XQAXX S XQAXX=$S(XQAROU[U:XQAROU,1:U_XQAROU) I $P(XQAXX,U,2)'="" S:$P(XQAXX,U)'="" @FDA@(8992.1,IENS,1.03)=$P(XQAXX,U) S @FDA@(8992.1,IENS,1.04)=$P(XQAXX,U,2) + I $D(XQACTMSG) S @FDA@(8992.1,IENS,1.05)=XQACTMSG + I $D(XQADATA) S @FDA@(8992.1,IENS,2)=XQADATA + I $D(XQAGUID) S @FDA@(8992.1,IENS,3.01)=XQAGUID + I $D(XQADFN) S @FDA@(8992.1,IENS,.04)=XQADFN + D FILE^DIE("KS",FDA) + I $D(XQATEXT) D WP^DIE(8992.1,IENS,4,"","XQATEXT") + Q + ; +CHEKUSER(XQAUSER) ; .SR Returns 0 if no valid user or surrogate, otherwise returns IEN of user or surrogate + Q $$CHEKUSER^XQALSET1(XQAUSER) + ; diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALSET1.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALSET1.m index 8cec3a43..2cca19ec 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALSET1.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALSET1.m @@ -1,34 +1,33 @@ -XQALSET1 ;ISC-SF.SEA/JLI - SETUP ALERTS (OVERFLOW) ;4/9/07 10:26 - ;;8.0;KERNEL;**285,443**;Jul 10, 1995;Build 4 - ;; - Q -GROUP ; - N XQI,XQL,XQL1,XQL2,XQLIST - S XQL=$E(XQJ,3,$L(XQJ)) ; P443 - changed from code that forced upper case - I $D(^TMP("XQAGROUP",$J,XQL)) Q ; P443 group has already been processed - prevent cycling - S ^TMP("XQAGROUP",$J,XQL)="" ; P443 mark that the group has been seen - S XQI=$$FIND1^DIC(3.8,,"X",XQL) Q:XQI'>0 - N XQLIST D LIST^DIC(3.81,","_XQI_",",".01","I",,,,,,,.XQLIST) I XQLIST("ORDER")>0 D - . N XQI F XQI=0:0 S XQI=$O(@XQLIST@("ID",XQI)) Q:XQI'>0 S XQA(^(XQI,.01))="" - . Q - K @XQLIST,XQLIST D LIST^DIC(3.811,","_XQI_",",".01",,,,,,,,.XQLIST) I XQLIST("ORDER")>0 D - . N XQAGROUP M XQAGROUP=@XQLIST@("ID") ; P443 - store group list data locally so it is not over written by recursive call to LIST^DIC - . N XQI F XQI=0:0 S XQI=$O(XQAGROUP(XQI)) Q:XQI'>0 N XQJ S XQJ="G."_XQAGROUP(XQI,.01) D GROUP ; P443 - change to reference XQAGROUP - . Q - K @XQLIST,XQLIST - K XQA(XQJ) - D CHEKACTV(.XQA) - Q - ; - ; Check and remove any entries in array that don't have active surrogates and aren't active -CHEKACTV(XQARRAY) ; - N XQJ - F XQJ=0:0 S XQJ=$O(XQARRAY(XQJ)) Q:XQJ'>0 I $$CHEKUSER(XQJ)'>0 K XQARRAY(XQJ) - Q - ; -CHEKUSER(XQAUSER) ; Returns 0 if no valid user or surrogate, otherwise returns IEN of user or surrogate - N VALUE - S VALUE=$$ACTVSURO^XQALSURO(XQAUSER) - I VALUE'>0 S VALUE=XQAUSER I '$$ACTIVE^XUSER(XQAUSER) Q 0 - Q VALUE - ; +XQALSET1 ;ISC-SF.SEA/JLI - SETUP ALERTS (OVERFLOW) ;10/20/03 15:03 + ;;8.0;KERNEL;**285**;Jul 10, 1995 + ;; + Q +GROUP ; + N XQI,XQL,XQL1,XQL2,XQLIST + S XQL="" F XQI=3:1:$L(XQJ) S XQL1=$E(XQJ,XQI) S:XQL1?1L XQL1=$C($A(XQL1)-32) S XQL=XQL_XQL1 + ;S XQI=$O(^XMB(3.8,"B",XQL,0)) I XQI'>0 S XQL1=$O(^XMB(3.8,"B",XQL)) I $E(XQL1,1,$L(XQL))=XQL S XQL2=$O(^(XQL1)) I $E(XQL2,1,$L(XQL))'=XQL S XQI=$O(^(XQL1,0)) + ;I XQI>0 F XQL=0:0 S XQL=$O(^XMB(3.8,XQI,1,XQL)) Q:XQL'>0 S XQA(+^(XQL,0))="" + ; Above code replaced to use Fileman calls, also code added to walk through member groups as well 030203 JLI P285 + S XQI=$$FIND1^DIC(3.8,,"X",XQL) Q:XQI'>0 + N XQLIST D LIST^DIC(3.81,","_XQI_",",".01","I",,,,,,,.XQLIST) I XQLIST("ORDER")>0 D + . N XQI F XQI=0:0 S XQI=$O(@XQLIST@("ID",XQI)) Q:XQI'>0 S XQA(^(XQI,.01))="" + . Q + K @XQLIST,XQLIST D LIST^DIC(3.811,","_XQI_",",".01",,,,,,,,.XQLIST) I XQLIST("ORDER")>0 D + . N XQI F XQI=0:0 S XQI=$O(@XQLIST@("ID",XQI)) Q:XQI'>0 N XQJ S XQJ="G."_^(XQI,.01) D GROUP + . Q + K XQA(XQJ) + D CHEKACTV(.XQA) + Q + ; + ; Check and remove any entries in array that don't have active surrogates and aren't active +CHEKACTV(XQARRAY) ; + N XQJ + F XQJ=0:0 S XQJ=$O(XQARRAY(XQJ)) Q:XQJ'>0 I $$CHEKUSER(XQJ)'>0 K XQARRAY(XQJ) + Q + ; +CHEKUSER(XQAUSER) ;SR. Returns 0 if no valid user or surrogate, otherwise returns IEN of user or surrogate + N VALUE + S VALUE=$$ACTVSURO^XQALSURO(XQAUSER) + I VALUE'>0 S VALUE=XQAUSER I '$$ACTIVE^XUSER(XQAUSER) Q 0 + Q VALUE + ; diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALSUR1.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALSUR1.m index 95f55afb..fd534807 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALSUR1.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALSUR1.m @@ -1,168 +1,169 @@ -XQALSUR1 ;ISC-SF.SEA/JLI - SURROGATES FOR ALERTS ;11/21/07 08:35 - ;;8.0;KERNEL;**366,443**;Jul 10, 1995;Build 4 - Q - ; -RETURN(XQAUSER) ; P366 - return alerts to the user - N XQAI,X0,XQASTRT,XQASURO,XQAEND - ; identify periods in the surrogate multiple that haven't been returned - F XQAI=0:0 S XQAI=$O(^XTV(8992,XQAUSER,2,"AC",1,XQAI)) Q:XQAI'>0 S X0=^XTV(8992,XQAUSER,2,XQAI,0) I $P(X0,U,4)=1 D - . S XQASTRT=$P(X0,U) S XQAEND=$P(X0,U,3) - . ; and clear the flag indicating we need to restore these alerts - . N XQAFDA S XQAFDA(8992.02,XQAI_","_XQAUSER_",",.04)="@" D FILE^DIE("","XQAFDA") - . ; restore alerts to intended user, remove from surrogate if completed (i.e., no other surrogates and not intended recipient) - . D PUSHBACK(XQAUSER,XQASTRT,XQAEND) - . Q - Q - ; -PUSHBACK(XQAUSER,XQASTRT,XQAEND) ; P366 - identify alerts in alert tracking file for return and return them - N XQAINIT,XQAI,X0,X30,XNOSURO,XQADT,XQAJ,XQAK,XQAL,XQAOTH,XQASUROP - S XQAINIT=$$FIND1^DIC(8992.2,,"X","INITIAL RECIPIENT") - F XQADT=XQASTRT-.0000001:0 S XQADT=$O(^XTV(8992.1,"AUD",XQAUSER,XQADT)) Q:XQADT'>0 Q:XQADT>XQAEND F XQAI=0:0 S XQAI=$O(^XTV(8992.1,"AUD",XQAUSER,XQADT,XQAI)) Q:XQAI'>0 D - . S XQAJ=$O(^XTV(8992.1,XQAI,20,"B",XQAUSER,0)) Q:XQAJ'>0 - . N XSURO,XNOSURO,XQAID S XNOSURO=0,XQAID=$P(^XTV(8992.1,XQAI,0),U) - . F XQAK=0:0 S XQAK=$O(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK)) Q:XQAK'>0 F XQAL=0:0 S XQAL=$O(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK,XQAL)) Q:XQAL'>0 D - . . S X0=^XTV(8992.1,XQAI,20,XQAJ,1,XQAL,0) S:$P(X0,U,2)>0 XSURO($P(X0,U,2))="" S:$P(X0,U,2)'>0 XNOSURO=1 ; sent to XSURO as surrogate - . . Q - . I 'XNOSURO D - . . N XQA,XQACMNT,XQALTYPE - . . S XQA(XQAUSER)="",XQACMNT="RESTORED FROM SURROGATE",XQALTYPE="RESTORE FROM SURROGATE" - . . N XQAUSER,XQAI S XQAUSER=$O(^XTV(8992,"AXQA",XQAID,0)) Q:XQAUSER'>0 D RESETUP^XQALFWD(XQAID,.XQA,XQACMNT) - . . Q - . ; walk through each of those it was sent to as a surrogate for XQAUSER - . F XQASUROP=0:0 S XQASUROP=$O(XSURO(XQASUROP)) Q:XQASUROP'>0 S XQAJ=$O(^XTV(8992.1,XQAI,20,"B",XQASUROP,0)) D - . . ; and identify each time they were considered a recipient of the alert - . . S XNOSURO=0 F XQAK=0:0 Q:XNOSURO S XQAK=$O(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK)) Q:XQAK'>0 F XQAL=0:0 S XQAL=$O(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK,XQAL)) Q:XQAL'>0 S X0=^XTV(8992.1,XQAI,20,XQAJ,1,XQAL,0) D Q:XNOSURO - . . . I $P(X0,U,3)'="Y" S XNOSURO=1 Q ; this one got it directly as a recipient as well - . . . ; walk through the SURROGATE FOR entries for this user - . . . F XQAOTH=0:0 S XQAOTH=$O(^XTV(8992.1,XQAI,20,XQAJ,3,XQAOTH)) Q:XQAOTH'>0 S X30=^(XQAOTH,0) D Q:XNOSURO - . . . . I +X30=XQAUSER S $P(^XTV(8992.1,XQAI,20,XQAJ,3,XQAOTH,0),U,3)=$$NOW^XLFDT() Q ; mark this user as returned - . . . . I $P(X30,U,3)'>0 S XNOSURO=1 Q ; another surrogate hasn't been returned yet, so leave the alert - . . . . Q - . . . Q - . . I 'XNOSURO D - . . . N XQAKILL,XQAUSER,XQAI S XQAKILL=1,XQAUSER=XQASUROP D DELETE^XQALDEL - . . . Q - . . Q - . Q - Q - ; -SUROLIST(XQAUSER,XQALIST) ; returns for XQAUSER a list of current and/or future surrogates in XQALIST - ; usage D SUROLIST^XQALSUR1(DUZ,.XQALIST) - ; - ; returns XQALIST=count - ; XQALIST(1)=IEN2^NEWPERSON,USER2^STARTDATETIME^ENDDATETIME - ; XQALIST(2)=3^NAME,USER3^3050407.1227^3050406 - ; - N XQA0,XQADATE,XQAIEN,XQAL,XQALCNT,XQALEND,XQANOW,XQASTART,XQASURO,XQAVALU - D CHEKSUBS^XQALSUR2(XQAUSER) - S XQALCNT=$$CURRSURO^XQALSURO(XQAUSER) - S XQANOW=$$NOW^XLFDT(),XQALCNT=0 - S XQADATE="" F S XQADATE=$O(^XTV(8992,XQAUSER,2,"B",XQADATE)) Q:XQADATE'>0 S XQAIEN="" F S XQAIEN=$O(^XTV(8992,XQAUSER,2,"B",XQADATE,XQAIEN)) Q:XQAIEN'>0 D - . S XQA0=^XTV(8992,XQAUSER,2,XQAIEN,0),XQASTART=$P(XQA0,U),XQASURO=$P(XQA0,U,2),XQALEND=$P(XQA0,U,3) I XQALEND>0,XQALEND'>XQANOW Q - . S XQALCNT=XQALCNT+1,XQAVALU=$$GET1^DIQ(200,XQASURO_",",.01),XQAL(XQALCNT)=XQASURO_U_XQAVALU_U_XQASTART_U_XQALEND - . Q - ; now rearrange by earliest to last - K XQALIST S XQALIST=0 - S XQALCNT="" F S XQALCNT=$O(XQAL(XQALCNT)) Q:XQALCNT'>0 D - . ; if end date not specified, and start date follows, set end date to next start date - . I $D(XQAL(XQALCNT+1)),($P(XQAL(XQALCNT),U,4)>$P(XQAL(XQALCNT+1),U,3))!($P(XQAL(XQALCNT),U,4)'>0) S $P(XQAL(XQALCNT),U,4)=$P(XQAL(XQALCNT+1),U,3) - . S XQALIST=XQALIST+1,XQALIST(XQALIST)=XQAL(XQALCNT) - . Q - Q - ; -DCYCLIC(XQALSURO,XQAUSER,XQALSTRT,XQALEND) ; code added to prevent cyclical surrogates - use dates for surrogacy - N XQALNEXT,XQALIST,I,XQALAST - I XQALSURO=XQAUSER Q "This forms a circle which leads back to this user during this period - can't do it!" - S XQALNEXT=$$CURRSURO^XQALSURO(XQALSURO,XQALSTRT,XQALEND) I XQALNEXT>0 D - . F I=1:1 Q:$P(XQALNEXT,U,I)="" S XQALAST=$$DCYCLIC($P(XQALNEXT,U,I),XQAUSER,XQALSTRT,XQALEND) I XQALAST'>0 S XQALSURO=XQALAST Q - . Q - Q XQALSURO - ; -DATESURO(XQAUSER,XQALSTRT,XQALEND) ; returns surrogate(s) for XQAUSER in date range XQALSTRT to XQALEND, may be multiple values ^-separated - N XQALY,XQA0,XQALIEN,XQALS - S XQALY="" I XQALEND'>0 S XQALEND=4000101 - F XQALS=0:0 S XQALS=$O(^XTV(8992,XQAUSER,2,"B",XQALS)) Q:XQALS'>0 Q:XQALS'0 S XQA0=^XTV(8992,XQAUSER,2,XQALIEN,0) Q:$P(XQA0,U,3)'>XQALSTRT S XQALY=XQALY_$S(XQALY="":"",1:U)_$P(XQA0,U,2) - . Q - Q XQALY - ; -SURRO1(XQAUSER) ; - N XQALSURO,XQALSTRT,XQALEND - D CHKREMV^XQALSURO -SURRO11 ; - S XQALSURO=$$NEWDLG() I XQALSURO'>0 Q - I $$CYCLIC^XQALSURO(XQALSURO,XQAUSER)'>0 W $C(7),!,$$CYCLIC^XQALSURO(XQALSURO,XQAUSER),! G SURRO11 - S XQALSTRT=+$$STRTDLG() I XQALSTRT<0 Q - S XQALEND=+$$ENDDLG() I XQALEND<0 Q - D SETSURO^XQALSURO(XQAUSER,XQALSURO,XQALSTRT,XQALEND) - G SURRO11 ; - Q - ; - ; P366 - added OPTIONAL second and third arguments to permit deletion of a specific pending surrogate and start date -REMVSURO(XQAUSER,XQALSURO,XQALSTRT) ; SR - ends the currently active surrogate relationship - I $G(XQAUSER)'>0 Q - S XQALSURO=$G(XQALSURO),XQALSTRT=$G(XQALSTRT) - N XQALFM,XQALXREF,XQALSTR1,XQALSUR1,XQALNOW,XQALEND,XQA0 - D CHEKSUBS^XQALSUR2(XQAUSER) - S XQALSUR1=+$P($G(^XTV(8992,XQAUSER,0)),U,2) S:XQALSURO'>0 XQALSURO=XQALSUR1 - S XQALSTR1=$P($G(^XTV(8992,XQAUSER,0)),U,3) S:XQALSTRT'>0 XQALSTRT=XQALSTR1 - S XQALEND=$P($G(^XTV(8992,XQAUSER,0)),U,4) - S XQALXREF=0 I XQALSTRT>0 F S XQALXREF=$O(^XTV(8992,XQAUSER,2,"B",XQALSTRT,XQALXREF)) Q:XQALXREF'>0 I $P(^XTV(8992,XQAUSER,2,XQALXREF,0),U,2)=XQALSURO D - . S XQALEND=$P(^XTV(8992,XQAUSER,2,XQALXREF,0),U,3) D DELETENT(XQAUSER,XQALXREF,XQALSURO,XQALSTRT,XQALSUR1,XQALSTR1,XQALEND) - . Q - S XQALSURO=$$CURRSURO^XQALSURO(XQAUSER) ; make sure current surrogate is updated if necessary. - Q - ; -DELETENT(XQAUSER,XQALXREF,XQALSURO,XQALSTRT,XQALSUR1,XQALSTR1,XQALEND) ; - N XQALNOW,XQALFM - S XQAUSER=XQAUSER_",",XQALXREF=XQALXREF_","_XQAUSER - I XQALXREF>0 D - . S XQALNOW=$$NOW^XLFDT() - . I XQALSTRT>XQALNOW S XQALFM(8992.02,XQALXREF,.01)=XQALNOW ; if scheduled for later, mark start as now - . I (XQALEND>XQALNOW)!(XQALEND'>0) S XQALFM(8992.02,XQALXREF,.03)=XQALNOW ; update end time for surrogate to now - . I XQALSTRT'>XQALNOW S XQALFM(8992.02,XQALXREF,.04)=1 - . Q - I XQALSUR1=XQALSURO,XQALSTRT=XQALSTR1 D - . S XQALFM(8992,XQAUSER,.02)="@" - . S XQALFM(8992,XQAUSER,.03)="@" - . S XQALFM(8992,XQAUSER,.04)="@" - . Q - I $D(XQALFM) D FILE^DIE("","XQALFM") - ; ZEXCEPT: XTMUNIT (EXTERNAL VALUE - INDICATING UNIT TEST BEING RUN) - I XQALSURO>0,'$D(XTMUNIT) D - . N XQAMESG,XMSUB,XMTEXT - . S XQAMESG(1,0)="You have been REMOVED as a surrogate recipient for alerts for" - . S XQAMESG(2,0)=$$GET1^DIQ(200,XQAUSER,.01,"E")_" (IEN="_$P(XQAUSER,",")_")." - . S XMTEXT="XQAMESG(",XMSUB="Removal as surrogate recipient" - . D SENDMESG^XQALSURO - . Q - Q - ; -NEWDLG() ; new surrogate dialog - N DIR,Y S DIR(0)="Y",DIR("A")="Do you want to SET a new surrogate recipient",DIR("?")="A surrogate will receive your alerts until they are removed as surrogate.",DIR("B")="NO" - S Y=$$ASKDIR(.DIR) I 'Y Q 0 - ; - S DIR(0)="P^200:AEMQ",DIR("A")="Select USER to be SURROGATE" S Y=$$ASKDIR(.DIR) ; COS-0401-41366 - I Y>0 W " ",$P(Y,U,2) - Q +Y - ; -STRTDLG() ; new surrogate start date/time dialog - N DIR - S DIR(0)="DO^::ATEX",DIR("A")="Specify Date/Time SURROGATE becomes active" ; BRX-1000-10427 - S DIR("A",1)="",DIR("A",2)="" - S DIR("A",3)="if no date/time is entered, alerts will start going to" - S DIR("A",4)="the SURROGATE immediately." - Q +$$ASKDIR(.DIR) - ; -ENDDLG() ; new surrogate end date/time dialog - N DIR - S DIR(0)="DO^::AETX",DIR("A")="Specify Date/Time SURROGATE should be removed" ; BRX-1000-10427 - S DIR("A",1)="",DIR("A",2)="" - S DIR("A",3)="if no date/time is entered, YOU must remove the SURROGATE" - S DIR("A",4)="to terminate alerts going to the SURROGATE" - Q +$$ASKDIR(.DIR) - ; -ASKDIR(DIR) ; - N Y,DTOUT,DUOUT - D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S Y=-1 - Q Y +XQALSUR1 ;ISC-SF.SEA/JLI - SURROGATES FOR ALERTS ;9/6/05 14:26 + ;;8.0;KERNEL;**366**;Jul 10, 1995 + Q + ; +RETURN(XQAUSER) ; P366 - return alerts to the user + N XQAI,X0,XQASTRT,XQASURO,XQAEND + ; identify periods in the surrogate multiple that haven't been returned + F XQAI=0:0 S XQAI=$O(^XTV(8992,XQAUSER,2,"AC",1,XQAI)) Q:XQAI'>0 S X0=^XTV(8992,XQAUSER,2,XQAI,0) I $P(X0,U,4)=1 D + . S XQASTRT=$P(X0,U) S XQAEND=$P(X0,U,3) + . ; and clear the flag indicating we need to restore these alerts + . N XQAFDA S XQAFDA(8992.02,XQAI_","_XQAUSER_",",.04)="@" D FILE^DIE("","XQAFDA") + . ; restore alerts to intended user, remove from surrogate if completed (i.e., no other surrogates and not intended recipient) + . D PUSHBACK(XQAUSER,XQASTRT,XQAEND) + . Q + Q + ; +PUSHBACK(XQAUSER,XQASTRT,XQAEND) ; P366 - identify alerts in alert tracking file for return and return them + N XQAINIT,XQAI,X0,X30,XNOSURO,XQADT,XQAJ,XQAK,XQAL,XQAOTH,XQASUROP + S XQAINIT=$$FIND1^DIC(8992.2,,"X","INITIAL RECIPIENT") + F XQADT=XQASTRT-.0000001:0 S XQADT=$O(^XTV(8992.1,"AUD",XQAUSER,XQADT)) Q:XQADT'>0 Q:XQADT>XQAEND F XQAI=0:0 S XQAI=$O(^XTV(8992.1,"AUD",XQAUSER,XQADT,XQAI)) Q:XQAI'>0 D + . S XQAJ=$O(^XTV(8992.1,XQAI,20,"B",XQAUSER,0)) Q:XQAJ'>0 + . N XSURO,XNOSURO,XQAID S XNOSURO=0,XQAID=$P(^XTV(8992.1,XQAI,0),U) + . F XQAK=0:0 S XQAK=$O(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK)) Q:XQAK'>0 F XQAL=0:0 S XQAL=$O(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK,XQAL)) Q:XQAL'>0 D + . . S X0=^XTV(8992.1,XQAI,20,XQAJ,1,XQAL,0) S:$P(X0,U,2)>0 XSURO($P(X0,U,2))="" S:$P(X0,U,2)'>0 XNOSURO=1 ; sent to XSURO as surrogate + . . Q + . I 'XNOSURO D + . . N XQA,XQACMNT,XQALTYPE + . . S XQA(XQAUSER)="",XQACMNT="RESTORED FROM SURROGATE",XQALTYPE="RESTORE FROM SURROGATE" + . . N XQAUSER,XQAI S XQAUSER=$O(^XTV(8992,"AXQA",XQAID,0)) Q:XQAUSER'>0 D RESETUP^XQALFWD(XQAID,.XQA,XQACMNT) + . . Q + . ; walk through each of those it was sent to as a surrogate for XQAUSER + . F XQASUROP=0:0 S XQASUROP=$O(XSURO(XQASUROP)) Q:XQASUROP'>0 S XQAJ=$O(^XTV(8992.1,XQAI,20,"B",XQASUROP,0)) D + . . ; and identify each time they were considered a recipient of the alert + . . S XNOSURO=0 F XQAK=0:0 Q:XNOSURO S XQAK=$O(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK)) Q:XQAK'>0 F XQAL=0:0 S XQAL=$O(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK,XQAL)) Q:XQAL'>0 S X0=^XTV(8992.1,XQAI,20,XQAJ,1,XQAL,0) D Q:XNOSURO + . . . I $P(X0,U,3)'="Y" S XNOSURO=1 Q ; this one got it directly as a recipient as well + . . . ; walk through the SURROGATE FOR entries for this user + . . . F XQAOTH=0:0 S XQAOTH=$O(^XTV(8992.1,XQAI,20,XQAJ,3,XQAOTH)) Q:XQAOTH'>0 S X30=^(XQAOTH,0) D Q:XNOSURO + . . . . I +X30=XQAUSER S $P(^XTV(8992.1,XQAI,20,XQAJ,3,XQAOTH,0),U,3)=$$NOW^XLFDT() Q ; mark this user as returned + . . . . I $P(X30,U,3)'>0 S XNOSURO=1 Q ; another surrogate hasn't been returned yet, so leave the alert + . . . . Q + . . . Q + . . I 'XNOSURO D + . . . N XQAKILL,XQAUSER,XQAI S XQAKILL=1,XQAUSER=XQASUROP D DELETE^XQALDEL + . . . Q + . . Q + . Q + Q + ; +SUROLIST(XQAUSER,XQALIST) ; returns for XQAUSER a list of current and/or future surrogates in XQALIST + ; usage D SUROLIST^XQALSUR1(DUZ,.XQALIST) + ; + ; returns XQALIST=count + ; XQALIST(1)=IEN2^NEWPERSON,USER2^STARTDATETIME^ENDDATETIME + ; XQALIST(2)=3^NAME,USER3^3050407.1227^3050406 + ; + N XQA0,XQADATE,XQAIEN,XQAL,XQALCNT,XQALEND,XQANOW,XQASTART,XQASURO,XQAVALU + D CHEKSUBS^XQALSUR2(XQAUSER) + S XQALCNT=$$CURRSURO^XQALSURO(XQAUSER) + S XQANOW=$$NOW^XLFDT(),XQALCNT=0 + S XQADATE="" F S XQADATE=$O(^XTV(8992,XQAUSER,2,"B",XQADATE)) Q:XQADATE'>0 S XQAIEN="" F S XQAIEN=$O(^XTV(8992,XQAUSER,2,"B",XQADATE,XQAIEN)) Q:XQAIEN'>0 D + . S XQA0=^XTV(8992,XQAUSER,2,XQAIEN,0),XQASTART=$P(XQA0,U),XQASURO=$P(XQA0,U,2),XQALEND=$P(XQA0,U,3) I XQALEND>0,XQALEND'>XQANOW Q + . S XQALCNT=XQALCNT+1,XQAVALU=$$GET1^DIQ(200,XQASURO_",",.01),XQAL(XQALCNT)=XQASURO_U_XQAVALU_U_XQASTART_U_XQALEND + . Q + ; now rearrange by earliest to last + K XQALIST S XQALIST=0 + S XQALCNT="" F S XQALCNT=$O(XQAL(XQALCNT)) Q:XQALCNT'>0 D + . ; if end date not specified, and start date follows, set end date to next start date + . I $D(XQAL(XQALCNT+1)),($P(XQAL(XQALCNT),U,4)>$P(XQAL(XQALCNT+1),U,3))!($P(XQAL(XQALCNT),U,4)'>0) S $P(XQAL(XQALCNT),U,4)=$P(XQAL(XQALCNT+1),U,3) + . S XQALIST=XQALIST+1,XQALIST(XQALIST)=XQAL(XQALCNT) + . Q + Q + ; +DCYCLIC(XQALSURO,XQAUSER,XQALSTRT,XQALEND) ; code added to prevent cyclical surrogates - use dates for surrogacy + N XQALNEXT,XQALIST,I,XQALAST + I XQALSURO=XQAUSER Q "This forms a circle which leads back to this user during this period - can't do it!" + S XQALNEXT=$$CURRSURO^XQALSURO(XQALSURO,XQALSTRT,XQALEND) I XQALNEXT>0 D + . F I=1:1 Q:$P(XQALNEXT,U,I)="" S XQALAST=$$DCYCLIC($P(XQALNEXT,U,I),XQAUSER,XQALSTRT,XQALEND) I XQALAST'>0 S XQALSURO=XQALAST Q + . Q + Q XQALSURO + ; +DATESURO(XQAUSER,XQALSTRT,XQALEND) ; returns surrogate(s) for XQAUSER in date range XQALSTRT to XQALEND, may be multiple values ^-separated + N XQALY,XQA0,XQALIEN,XQALS + S XQALY="" I XQALEND'>0 S XQALEND=4000101 + F XQALS=0:0 S XQALS=$O(^XTV(8992,XQAUSER,2,"B",XQALS)) Q:XQALS'>0 Q:XQALS'0 S XQA0=^XTV(8992,XQAUSER,2,XQALIEN,0) Q:$P(XQA0,U,3)'>XQALSTRT S XQALY=XQALY_$S(XQALY="":"",1:U)_$P(XQA0,U,2) + . Q + Q XQALY + ; +SURRO1(XQAUSER) ; + N XQALSURO,XQALSTRT,XQALEND + D CHKREMV^XQALSURO +SURRO11 ; + S XQALSURO=$$NEWDLG() I XQALSURO'>0 Q + I $$CYCLIC^XQALSURO(XQALSURO,XQAUSER)'>0 W $C(7),!,$$CYCLIC^XQALSURO(XQALSURO,XQAUSER),! G SURRO1 + S XQALSTRT=+$$STRTDLG() I XQALSTRT<0 Q + S XQALEND=+$$ENDDLG() I XQALEND<0 Q + D SETSURO^XQALSURO(XQAUSER,XQALSURO,XQALSTRT,XQALEND) + G SURRO11 ; + Q + ; + ; P366 - added OPTIONAL second and third arguments to permit deletion of a specific pending surrogate and start date +REMVSURO(XQAUSER,XQALSURO,XQALSTRT) ; SR - ends the currently active surrogate relationship + I $G(XQAUSER)'>0 Q + S XQALSURO=$G(XQALSURO),XQALSTRT=$G(XQALSTRT) + N XQALFM,XQALXREF,XQALSTR1,XQALSUR1,XQALNOW,XQALEND,XQA0 + ; ZEXCEPT: XQATEST (EXTERNAL VALUE - INDICATING TEST BEING RUN) + D CHEKSUBS^XQALSUR2(XQAUSER) + S XQALSUR1=+$P($G(^XTV(8992,XQAUSER,0)),U,2) S:XQALSURO'>0 XQALSURO=XQALSUR1 + S XQALSTR1=$P($G(^XTV(8992,XQAUSER,0)),U,3) S:XQALSTRT'>0 XQALSTRT=XQALSTR1 + S XQALEND=$P($G(^XTV(8992,XQAUSER,0)),U,4) + S XQALXREF=0 I XQALSTRT>0 F S XQALXREF=$O(^XTV(8992,XQAUSER,2,"B",XQALSTRT,XQALXREF)) Q:XQALXREF'>0 I $P(^XTV(8992,XQAUSER,2,XQALXREF,0),U,2)=XQALSURO D + . S XQALEND=$P(^XTV(8992,XQAUSER,2,XQALXREF,0),U,3) D DELETENT(XQAUSER,XQALXREF,XQALSURO,XQALSTRT,XQALSUR1,XQALSTR1,XQALEND) + . Q + S XQALSURO=$$CURRSURO^XQALSURO(XQAUSER) ; make sure current surrogate is updated if necessary. + Q + ; +DELETENT(XQAUSER,XQALXREF,XQALSURO,XQALSTRT,XQALSUR1,XQALSTR1,XQALEND) ; + N XQALNOW,XQALFM + ; ZEXCEPT: XQATEST (EXTERNAL VALUE - INDICATING TEST BEING RUN) + S XQAUSER=XQAUSER_",",XQALXREF=XQALXREF_","_XQAUSER + I XQALXREF>0 D + . S XQALNOW=$$NOW^XLFDT() + . I XQALSTRT>XQALNOW S XQALFM(8992.02,XQALXREF,.01)=XQALNOW ; if scheduled for later, mark start as now + . I (XQALEND>XQALNOW)!(XQALEND'>0) S XQALFM(8992.02,XQALXREF,.03)=XQALNOW ; update end time for surrogate to now + . I XQALSTRT'>XQALNOW S XQALFM(8992.02,XQALXREF,.04)=1 + . Q + I XQALSUR1=XQALSURO,XQALSTRT=XQALSTR1 D + . S XQALFM(8992,XQAUSER,.02)="@" + . S XQALFM(8992,XQAUSER,.03)="@" + . S XQALFM(8992,XQAUSER,.04)="@" + . Q + I $D(XQALFM) D FILE^DIE("","XQALFM") + I XQALSURO>0,'$D(XQATEST) D + . N XQAMESG,XMSUB,XMTEXT + . S XQAMESG(1,0)="You have been REMOVED as a surrogate recipient for alerts for" + . S XQAMESG(2,0)=$$GET1^DIQ(200,XQAUSER,.01,"E")_" (IEN="_$P(XQAUSER,",")_")." + . S XMTEXT="XQAMESG(",XMSUB="Removal as surrogate recipient" + . D SENDMESG^XQALSURO + . Q + Q + ; +NEWDLG() ; new surrogate dialog + N DIR,Y S DIR(0)="Y",DIR("A")="Do you want to SET a new surrogate recipient",DIR("?")="A surrogate will receive your alerts until they are removed as surrogate.",DIR("B")="NO" + S Y=$$ASKDIR(.DIR) I 'Y Q 0 + ; + S DIR(0)="P^200:AEMQ",DIR("A")="Select USER to be SURROGATE" S Y=$$ASKDIR(.DIR) ; COS-0401-41366 + I Y>0 W " ",$P(Y,U,2) + Q +Y + ; +STRTDLG() ; new surrogate start date/time dialog + N DIR + S DIR(0)="DO^::ATEX",DIR("A")="Specify Date/Time SURROGATE becomes active" ; BRX-1000-10427 + S DIR("A",1)="",DIR("A",2)="" + S DIR("A",3)="if no date/time is entered, alerts will start going to" + S DIR("A",4)="the SURROGATE immediately." + Q +$$ASKDIR(.DIR) + ; +ENDDLG() ; new surrogate end date/time dialog + N DIR + S DIR(0)="DO^::AETX",DIR("A")="Specify Date/Time SURROGATE should be removed" ; BRX-1000-10427 + S DIR("A",1)="",DIR("A",2)="" + S DIR("A",3)="if no date/time is entered, YOU must remove the SURROGATE" + S DIR("A",4)="to terminate alerts going to the SURROGATE" + Q +$$ASKDIR(.DIR) + ; +ASKDIR(DIR) ; + N Y,DTOUT,DUOUT + D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S Y=-1 + Q Y diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALSURO.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALSURO.m index d7f5e366..b5b952ba 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALSURO.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALSURO.m @@ -1,195 +1,173 @@ -XQALSURO ;ISC-SF.SEA/JLI - SURROGATES FOR ALERTS ;3/17/08 15:20 - ;;8.0;KERNEL;**114,125,173,285,366,443**;Jul 10, 1995;Build 4 - ;; - Q -OTHRSURO ; OPT:- XQALERT SURROGATE SET/REMOVE -- OTHERS SPECIFY SURROGATE FOR SELECTED USER - N XQAUSER,DIR,Y - S DIR(0)="PD^200:AEMQ",DIR("A",1)="SURROGATE related to which" - S DIR("A")="NEW PERSON entry" - D ^DIR K DIR Q:Y'>0 W " ",$P(Y,U,2) - S XQAUSER=+Y - G SURROGAT - Q - ; -SURROGAT ; USER SPECIFICATION OF SURROGATE - I '$D(XQAUSER) N XQAUSER S XQAUSER=DUZ - D SURRO1^XQALSUR1(XQAUSER) - Q -CYCLIC(XQALSURO,XQAUSER,XQASTRT,XQAEND) ; code added to prevent cyclical surrogates - I '$$ACTIVE^XUSER(XQALSURO) Q "You cannot have an INACTIVE USER ("_XQALSURO_") as a surrogate!" ;P443 - I XQALSURO=XQAUSER Q "You cannot specify yourself as your own surrogate!" ; moved in P443 - I $G(XQASTRT)>0 Q $$DCYCLIC^XQALSUR1(XQALSURO,XQAUSER,XQASTRT,$G(XQAEND)) - N XQALSTRT - S XQALSTRT=$$CURRSURO(XQALSURO) I XQALSTRT>0 D - . I XQALSTRT=XQAUSER S XQALSURO="YOU are designated as the surrogate for this user ("_XQALSURO_") - can't do it!" Q - . F S XQALSTRT=$$CURRSURO(XQALSTRT) Q:XQALSTRT'>0 I XQALSTRT=XQAUSER S XQALSURO="This forms a circle which leads back to you - can't do it!" Q - . Q - Q XQALSURO - ; -SETSURO(XQAUSER,XQALSURO,XQALSTRT,XQALEND) ; Use SETSURO1 instead - N XQALVAL ; P443 - S XQALVAL=$$SETSURO1(XQAUSER,XQALSURO,$G(XQALSTRT),$G(XQALEND)) ; P443 - Q - ; -SETSUROX(XQAUSER,XQALSURO,XQALSTRT,XQALEND) ; SETSURO CODE MOVED TO HERE TO PERMIT AN ERROR TO BE GENERATED AT THE OLD ENTRY POINT - N XQALFM,XQALIEN,XQAIENS - I $G(XQAUSER)'>0 Q - I $G(XQALSURO)'>0 Q - I '$D(^XTV(8992,XQAUSER,0)) D - . N XQALFM,XQALFM1 - . S XQALFM1(1)=XQAUSER - . S XQALFM(8992,"+1,",.01)=XQAUSER - . D UPDATE^DIE("","XQALFM","XQALFM1") - . Q - S XQAIENS=XQAUSER_"," - ; P366 - force no start date/time to NOW - ; P366 - change to force anything less than NOW to NOW - 8/22/05 - I $G(XQALSTRT)<$$NOW^XLFDT() S XQALSTRT=$$NOW^XLFDT() - ; P366 - add values to new multiple - S XQALFM(8992.02,"+1,"_XQAIENS,.01)=XQALSTRT - S XQALFM(8992.02,"+1,"_XQAIENS,.02)=XQALSURO - I XQALEND>0 S XQALFM(8992.02,"+1,"_XQAIENS,.03)=XQALEND - K XQALIEN D UPDATE^DIE("","XQALFM","XQALIEN") - ; P366 - if start date time is already in effect - place in old locations to make active - I XQALSTRT'>$$NOW^XLFDT() D ACTIVATE(XQAUSER,XQALIEN(1)) - N XQAMESG,XMSUB,XMTEXT - S XQAMESG(1,0)="You have been specified as a surrogate recipient for alerts for" - S XQAMESG(2,0)=$$GET1^DIQ(200,XQAIENS,.01,"E")_" (IEN="_XQAUSER_") effective "_$$FMTE^XLFDT(XQALSTRT) - I $G(XQALEND)'>0 S XQAMESG(2,0)=XQAMESG(2,0)_"." - E S XQAMESG(3,0)="until "_$$FMTE^XLFDT(XQALEND) - S XMSUB="Surrogate Recipient for "_$$GET1^DIQ(200,XQAIENS,.01,"E") - S XMTEXT="XQAMESG(" - ; ZEXCEPT: XTMUNIT - Defined if unit tests are being run - D:'$D(XTMUNIT) SENDMESG - Q - ; -ACTIVATE(XQAUSER,XQALIEN) ; activates a surrogate - N X0,XQALFM,XQALSURO,XQALSTRT,XQALEND - S X0=$G(^XTV(8992,XQAUSER,2,XQALIEN,0)) Q:X0="" S XQALSTRT=$P(X0,U),XQALSURO=$P(X0,U,2),XQALEND=$P(X0,U,3) - S X0=^XTV(8992,XQAUSER,0) - I $P(X0,U,2)>0,$P(X0,U,3)'>$$NOW^XLFDT() D REMVSURO(XQAUSER) ; If we are activaing a new surrogate, if one exists simply remove. - K XQALFM S XQALFM(8992,XQAUSER_",",.03)=XQALSTRT - S XQALFM(8992,XQAUSER_",",.02)=XQALSURO - S XQALFM(8992,XQAUSER_",",.04)=$S($G(XQALEND)>0:XQALEND,1:"@") - D FILE^DIE("","XQALFM") - Q - ; - ; usage $$SETSURO1(XQAUSER,XQALSURO,XQALSTRT,XQALEND) returns 0 if invalid, otherwise > 0 -SETSURO1(XQAUSER,XQALSURO,XQALSTRT,XQALEND) ; SR. This should be used instead of SETSURO - I $G(XQALSTRT)'>0 S XQALSTRT=$$NOW^XLFDT() - N XQAVAL - S XQAVAL=$$CYCLIC(XQALSURO,XQAUSER,XQALSTRT,$G(XQALEND)) I XQAVAL'>0 Q XQAVAL ; Can't use as surrogate - D SETSUROX(XQAUSER,XQALSURO,XQALSTRT,$G(XQALEND)) ; P443 - Q XQALSURO - ; -CHKREMV ; - N DIR,XQAI,XQASLIST,XQAVAL,YVAL,Y - ; ZEXCEPT: XQAUSER (EXTERNAL VALUE) - D SUROLIST^XQALSUR1(XQAUSER,.XQASLIST) - W !,"Current Surrogate(s):",?35,"START DATE",?60,"END DATE" - F XQAI=0:0 S XQAI=$O(XQASLIST(XQAI)) Q:XQAI'>0 W !,XQAI," ",$P(XQASLIST(XQAI),U,2),?35,$$FMTE^XLFDT($P(XQASLIST(XQAI),U,3)),?60,$$FMTE^XLFDT($P(XQASLIST(XQAI),U,4)) - W ! I XQASLIST'>0 W !," No current surrogates",! Q - S DIR(0)="Y",DIR("A")="Do you want to REMOVE "_$S(XQASLIST>1:"a",1:"THIS")_" surrogate recipient",DIR("?")="A surrogate will receive your alerts until they are removed as surrogate." D ^DIR K DIR Q:Y'>0 - S Y=1 I XQASLIST>1 S DIR(0)="L^1:"_XQASLIST,DIR("A")="Enter a list (comma separated, e.g., 1,2) of the surrogate(s) to remove" D ^DIR K DIR - I Y>0 S YVAL=Y F XQAI=1:1 S XQAVAL=+$P(YVAL,",",XQAI) Q:XQAVAL'>0 D REMVSURO(XQAUSER,$P(XQASLIST(XQAVAL),U),$P(XQASLIST(XQAVAL),U,3)) - Q - ; - ; P366 - added OPTIONAL second and third arguments to permit deletion of a specific pending surrogate and start date -REMVSURO(XQAUSER,XQALSURO,XQALSTRT) ; SR - ends the currently active surrogate relationship - I $G(XQAUSER)'>0 Q - D REMVSURO^XQALSUR1(XQAUSER,$G(XQALSURO),$G(XQALSTRT)) - Q - ; - ; P366 - added OPTIONAL second and third arguments to determine surrogate for specified time range -CURRSURO(XQAUSER,XQASTRT,XQAEND) ;SR. - returns current surrogate for user or -1 usage $$CURRSURO^XQALSURO(DUZ) - N X,ACTIVE,XQANOW,XQASTR1,XQAIVAL,XQA0,XQAI - D CHEKSUBS^XQALSUR2(XQAUSER) - I $G(XQASTRT)>0 Q $$DATESURO^XQALSUR1(XQAUSER,XQASTRT,$G(XQAEND)) ; P366 - check for current in specified date/times - ; - ; P366 - find the latest start time which is now or past or the first one in the future - S XQANOW=$$NOW^XLFDT() D - . S XQAIVAL=0,XQASTR1=0 - . F XQASTRT=0:0 S XQASTRT=$O(^XTV(8992,XQAUSER,2,"B",XQASTRT)) Q:XQASTRT'>0 Q:XQASTRT'0 D - . . S XQAEND=$P(^XTV(8992,XQAUSER,2,XQAI,0),U,3) I (XQAEND="")!(XQAEND>XQANOW) S XQAIVAL=XQAI - . . Q - . ; to be compatible with the past, if there is not a current surrogate, show the next scheduled on the zero node if there is one - . I XQAIVAL=0 S XQASTRT=$O(^XTV(8992,XQAUSER,2,"B",XQASTR1)) Q:XQASTRT="" F XQAI=0:0 S XQAI=$O(^XTV(8992,XQAUSER,2,"B",XQASTRT,XQAI)) Q:XQAI'>0 D Q:XQAIVAL>0 - . . S XQAEND=$P(^XTV(8992,XQAUSER,2,XQAI,0),U,3) I (XQAEND="")!(XQAEND>XQANOW) S XQAIVAL=XQAI - . . Q - . I XQAIVAL>0 S XQA0=^XTV(8992,XQAUSER,2,XQAIVAL,0),XQASTRT=^XTV(8992,XQAUSER,0) I ($P(XQA0,U,2)'=$P(XQASTRT,U,2))!($P(XQA0,U)'=$P(XQASTRT,U,3))!(+$P(XQA0,U,3)'=+$P(XQASTRT,U,4)) D ACTIVATE(XQAUSER,XQAIVAL) - . Q - ; P366 - end - S X=$G(^XTV(8992,XQAUSER,0)) - ; now check for a CURRENT surrogate, already started and not expired or cyclic - I $P(X,U,2)>0,+$P(X,U,3)'>XQANOW D I $P($G(^XTV(8992,XQAUSER,0)),U,2)>0 Q +$P(^XTV(8992,XQAUSER,0),U,2) - . N DATE ; Get Current date/time to check date/times if present - . ; FOLLOWING LINES MODIFIED IN P443 TO ELIMINATE A STACK ERROR WHEN SURROGATE WAS CIRCULAR - . ; Current Date/time past End date for surrogate - . S DATE=$P(X,U,4) I (DATE>0&(DATE0 Q:'$$ISACTIVE(XQASURO) S XQASURO1=XQASURO D - . . I $D(XQALLIST(XQASURO)) D REMVSURO(XQASURO) S XQASURO1=XQAUSER K XQALLIST S XQALLIST(XQAUSER)="" Q - . . S XQALLIST(XQASURO1)="" - . . Q - . ; END OF P443 MODIFICATION - . Q - Q -1 - ; -ISACTIVE(XQAUSER) ; checks for whether a surrogate relationship is active or not (returns 0 or 1) - N DATA - S DATA=$G(^XTV(8992,XQAUSER,0)) Q:$P(DATA,U,2)="" 0 ; NO SURROGATE SPECIFIED - I $P(DATA,U,3)>0,$P(DATA,U,3)>$$NOW^XLFDT() Q 0 ; START DATE/TIME NOT YET - I $P(DATA,U,4)>0,$P(DATA,U,4)<$$NOW^XLFDT() Q 0 ; PAST END DATE/TIME - Q 1 - ; -ACTVSURO(XQAUSER) ;SR. - returns the actual surrogate at this time - N CURRSURO,NEXTSURO,SURODATA,NOW - S NOW=$$NOW^XLFDT() - S CURRSURO=$$CURRSURO(XQAUSER),SURODATA=$$GETSURO(XQAUSER) I (CURRSURO'>0)!(+$P(SURODATA,U,3)>NOW)!('(+$$ACTIVE^XUSER(CURRSURO))) Q -1 - F S NEXTSURO=$$CURRSURO(CURRSURO),SURODATA=$$GETSURO(CURRSURO) Q:NEXTSURO'>0 Q:+$P(SURODATA,U,3)>NOW Q:'(+$$ACTIVE^XUSER(NEXTSURO)) S CURRSURO=NEXTSURO - Q CURRSURO - ; -GETSURO(XQAUSER) ;SR. - returns data for surrogate for user including times - I $$CURRSURO(XQAUSER)'>0 Q "" - N GLOBREF,IENS,X - S IENS=XQAUSER_",",GLOBREF=$NA(^TMP($J,"XQALSURO")) K @GLOBREF - D GETS^DIQ(8992,IENS,".02;.03;.04","IE",GLOBREF) - S GLOBREF=$NA(@GLOBREF@(8992,IENS)) - S X=$G(@GLOBREF@(.02,"I"))_U_$G(@GLOBREF@(.02,"E"))_U_$G(@GLOBREF@(.03,"I"))_U_$G(@GLOBREF@(.04,"I")) - K @GLOBREF - Q X - ; -GETFOR ;OPT. - N XQAUSER,VALUES,XQACNT,DIR,DIRUT,I,Y - S DIR(0)="PD^200:AEMQ",DIR("A",1)="View Users who have selected a specified User as their Surrogate." - S DIR("A")="Select User (NEW PERSON entry)" - D ^DIR K DIR Q:Y'>0 W " ",$P(Y,U,2) - S XQAUSER=+Y - D SUROFOR(.VALUES,XQAUSER) I VALUES'>0 W !,"No entries found.",!! Q - S XQACNT=0 K DIRUT F I=0:0 S I=$O(VALUES(I)) Q:I'>0 D:(XQACNT>(IOSL-4)) Q:$D(DIRUT) W !,?5,$P(VALUES(I),U,2) S XQACNT=XQACNT+1 - . S DIR(0)="E" D ^DIR K DIR - . Q - K DIRUT - Q - ; -SUROLIST(XQAUSER,XQALIST) ; SR. returns list of current and scheduled surrogates for XQAUSER - D SUROLIST^XQALSUR1(XQAUSER,.XQALIST) - Q - ; -SUROFOR(LIST,XQAUSER) ;SR. - returns list of users XQAUSER is acting as a surrogate for - I $G(XQAUSER)="" Q - N I,COUNT S I=0,COUNT=0 F S I=$O(^XTV(8992,"AC",XQAUSER,I)) Q:I'>0 I $$CURRSURO(I)>0 D - . S COUNT=COUNT+1,LIST(COUNT)=I_U_$$GET1^DIQ(200,(I_","),".01","E")_U_$$GET1^DIQ(8992,(I_","),".03","E")_U_$$GET1^DIQ(8992,(I_","),".04","E") - S LIST=COUNT - Q - ; -SENDMESG ; - N XMY,XMDUZ,XMCHAN - ; ZEXCEPT: XQALSURO (EXTERNAL VALUE) - S XMY(XQALSURO)="",XMDUZ=.5 - D ^XMD - Q +XQALSURO ;ISC-SF.SEA/JLI - SURROGATES FOR ALERTS ;9/6/05 15:13 + ;;8.0;KERNEL;**114,125,173,285,366**;Jul 10, 1995 + ;; + Q +OTHRSURO ; OPT:- XQALERT SURROGATE SET/REMOVE -- OTHERS SPECIFY SURROGATE FOR SELECTED USER + N XQAUSER,DIR,Y + S DIR(0)="PD^200:AEMQ",DIR("A",1)="SURROGATE related to which" + S DIR("A")="NEW PERSON entry" + D ^DIR K DIR Q:Y'>0 W " ",$P(Y,U,2) + S XQAUSER=+Y + G SURROGAT + Q + ; +SURROGAT ; USER SPECIFICATION OF SURROGATE + I '$D(XQAUSER) N XQAUSER S XQAUSER=DUZ + D SURRO1^XQALSUR1(XQAUSER) + Q + ; P366 - optional start and end dates added to permit identification of cyclical surrogates in specific times +CYCLIC(XQALSURO,XQAUSER,XQASTRT,XQAEND) ; code added to prevent cyclical surrogates + I $G(XQASTRT)>0 Q $$DCYCLIC^XQALSUR1(XQALSURO,XQAUSER,XQASTRT,$G(XQAEND)) + N XQALSTRT + I XQALSURO=XQAUSER Q "You cannot specify yourself as your own surrogate!" + S XQALSTRT=$$CURRSURO(XQALSURO) I XQALSTRT>0 D + . I XQALSTRT=XQAUSER S XQALSURO="YOU are designated as the surrogate for this user - can't do it!" Q + . F S XQALSTRT=$$CURRSURO(XQALSTRT) Q:XQALSTRT'>0 I XQALSTRT=XQAUSER S XQALSURO="This forms a circle which leads back to you - can't do it!" Q + . Q + Q XQALSURO + ; +SETSURO(XQAUSER,XQALSURO,XQALSTRT,XQALEND) ; SR + N XQALFM,XQALIEN,XQAIENS + I $G(XQAUSER)'>0 Q + I $G(XQALSURO)'>0 Q + I '$D(^XTV(8992,XQAUSER,0)) D + . N XQALFM,XQALFM1 + . S XQALFM1(1)=XQAUSER + . S XQALFM(8992,"+1,",.01)=XQAUSER + . D UPDATE^DIE("","XQALFM","XQALFM1") + . Q + S XQAIENS=XQAUSER_"," + ; P366 - force no start date/time to NOW + ; P366 - change to force anything less than NOW to NOW - 8/22/05 + I $G(XQALSTRT)<$$NOW^XLFDT() S XQALSTRT=$$NOW^XLFDT() + ; P366 - add values to new multiple + S XQALFM(8992.02,"+1,"_XQAIENS,.01)=XQALSTRT + S XQALFM(8992.02,"+1,"_XQAIENS,.02)=XQALSURO + I XQALEND>0 S XQALFM(8992.02,"+1,"_XQAIENS,.03)=XQALEND + K XQALIEN D UPDATE^DIE("","XQALFM","XQALIEN") + ; P366 - if start date time is already in effect - place in old locations to make active + I XQALSTRT'>$$NOW^XLFDT() D ACTIVATE(XQAUSER,XQALIEN(1)) + N XQAMESG,XMSUB,XMTEXT + S XQAMESG(1,0)="You have been specified as a surrogate recipient for alerts for" + S XQAMESG(2,0)=$$GET1^DIQ(200,XQAIENS,.01,"E")_" (IEN="_XQAUSER_") effective "_$$FMTE^XLFDT(XQALSTRT) + I $G(XQALEND)'>0 S XQAMESG(2,0)=XQAMESG(2,0)_"." + E S XQAMESG(3,0)="until "_$$FMTE^XLFDT(XQALEND) + S XMSUB="Surrogate Recipient for "_$$GET1^DIQ(200,XQAIENS,.01,"E") + S XMTEXT="XQAMESG(" + D:'$D(XQATEST) SENDMESG + Q + ; +ACTIVATE(XQAUSER,XQALIEN) ; activates a surrogate + N X0,XQALFM,XQALSURO,XQALSTRT,XQALEND + S X0=$G(^XTV(8992,XQAUSER,2,XQALIEN,0)) Q:X0="" S XQALSTRT=$P(X0,U),XQALSURO=$P(X0,U,2),XQALEND=$P(X0,U,3) + S X0=^XTV(8992,XQAUSER,0) + I $P(X0,U,2)>0,$P(X0,U,3)'>$$NOW^XLFDT() D REMVSURO(XQAUSER) ; If we are activaing a new surrogate, if one exists simply remove. + K XQALFM S XQALFM(8992,XQAUSER_",",.03)=XQALSTRT + S XQALFM(8992,XQAUSER_",",.02)=XQALSURO + S XQALFM(8992,XQAUSER_",",.04)=$S($G(XQALEND)>0:XQALEND,1:"@") + D FILE^DIE("","XQALFM") + Q + ; + ; usage $$SETSURO1(XQAUSER,XQALSURO,XQALSTRT,XQALEND) returns 0 if invalid, otherwise > 0 +SETSURO1(XQAUSER,XQALSURO,XQALSTRT,XQALEND) ; SR. This should be used instead of SETSURO + I $G(XQALSTRT)'>0 S XQALSTRT=$$NOW^XLFDT() + N XQAVAL + S XQAVAL=$$CYCLIC(XQALSURO,XQAUSER,XQALSTRT,$G(XQALEND)) I XQAVAL'>0 Q XQAVAL ; Can't use as surrogate + D SETSURO(XQAUSER,XQALSURO,XQALSTRT,$G(XQALEND)) + Q XQALSURO + ; +CHKREMV ; + N DIR,XQAI,XQASLIST,XQAVAL,YVAL,Y + ; ZEXCEPT: XQAUSER (EXTERNAL VALUE) + D SUROLIST^XQALSUR1(XQAUSER,.XQASLIST) + W !,"Current Surrogate(s):",?35,"START DATE",?60,"END DATE" + F XQAI=0:0 S XQAI=$O(XQASLIST(XQAI)) Q:XQAI'>0 W !,XQAI," ",$P(XQASLIST(XQAI),U,2),?35,$$FMTE^XLFDT($P(XQASLIST(XQAI),U,3)),?60,$$FMTE^XLFDT($P(XQASLIST(XQAI),U,4)) + W ! I XQASLIST'>0 W !," No current surrogates",! Q + S DIR(0)="Y",DIR("A")="Do you want to REMOVE "_$S(XQASLIST>1:"a",1:"THIS")_" surrogate recipient",DIR("?")="A surrogate will receive your alerts until they are removed as surrogate." D ^DIR K DIR Q:Y'>0 + S Y=1 I XQASLIST>1 S DIR(0)="L^1:"_XQASLIST,DIR("A")="Enter a list (comma separated, e.g., 1,2) of the surrogate(s) to remove" D ^DIR K DIR + I Y>0 S YVAL=Y F XQAI=1:1 S XQAVAL=+$P(YVAL,",",XQAI) Q:XQAVAL'>0 D REMVSURO(XQAUSER,$P(XQASLIST(XQAVAL),U),$P(XQASLIST(XQAVAL),U,3)) + Q + ; + ; P366 - added OPTIONAL second and third arguments to permit deletion of a specific pending surrogate and start date +REMVSURO(XQAUSER,XQALSURO,XQALSTRT) ; SR - ends the currently active surrogate relationship + I $G(XQAUSER)'>0 Q + D REMVSURO^XQALSUR1(XQAUSER,$G(XQALSURO),$G(XQALSTRT)) + Q + ; + ; P366 - added OPTIONAL second and third arguments to determine surrogate for specified time range +CURRSURO(XQAUSER,XQASTRT,XQAEND) ;SR. - returns current surrogate for user or -1 usage $$CURRSURO^XQALSURO(DUZ) + N X,ACTIVE,XQANOW,XQASTR1,XQAIVAL,XQA0,XQAI + D CHEKSUBS^XQALSUR2(XQAUSER) + I $G(XQASTRT)>0 Q $$DATESURO^XQALSUR1(XQAUSER,XQASTRT,$G(XQAEND)) ; P366 - check for current in specified date/times + ; + ; P366 - find the latest start time which is now or past or the first one in the future + S XQANOW=$$NOW^XLFDT() + ;I $P($G(^XTV(8992,XQAUSER,0)),U,2)'>0 D + D + . S XQAIVAL=0,XQASTR1=0 + . F XQASTRT=0:0 S XQASTRT=$O(^XTV(8992,XQAUSER,2,"B",XQASTRT)) Q:XQASTRT'>0 Q:XQASTRT'0 D + . . S XQAEND=$P(^XTV(8992,XQAUSER,2,XQAI,0),U,3) I (XQAEND="")!(XQAEND>XQANOW) S XQAIVAL=XQAI + . . Q + . ; to be compatible with the past, if there is not a current surrogate, show the next scheduled on the zero node if there is one + . I XQAIVAL=0 S XQASTRT=$O(^XTV(8992,XQAUSER,2,"B",XQASTR1)) Q:XQASTRT="" F XQAI=0:0 S XQAI=$O(^XTV(8992,XQAUSER,2,"B",XQASTRT,XQAI)) Q:XQAI'>0 D Q:XQAIVAL>0 + . . S XQAEND=$P(^XTV(8992,XQAUSER,2,XQAI,0),U,3) I (XQAEND="")!(XQAEND>XQANOW) S XQAIVAL=XQAI + . . Q + . I XQAIVAL>0 S XQA0=^XTV(8992,XQAUSER,2,XQAIVAL,0),XQASTRT=^XTV(8992,XQAUSER,0) I ($P(XQA0,U,2)'=$P(XQASTRT,U,2))!($P(XQA0,U)'=$P(XQASTRT,U,3))!(+$P(XQA0,U,3)'=+$P(XQASTRT,U,4)) D ACTIVATE(XQAUSER,XQAIVAL) + . Q + ; P366 - end + S X=$G(^XTV(8992,XQAUSER,0)) + ; now check for a CURRENT surrogate, already started and not expired or cyclic + I $P(X,U,2)>0,+$P(X,U,3)'>XQANOW D I $P($G(^XTV(8992,XQAUSER,0)),U,2)>0 Q +$P(^XTV(8992,XQAUSER,0),U,2) + . N DATE ; Get Current date/time to check date/times if present + . ; Current Date/time past End date for surrogate or cyclic relationship remove checks for new surrogate + . S DATE=$P(X,U,4) I (DATE>0&(DATE0)!(+$P(SURODATA,U,3)>NOW)!('(+$$ACTIVE^XUSER(CURRSURO))) Q -1 + F S NEXTSURO=$$CURRSURO(CURRSURO),SURODATA=$$GETSURO(CURRSURO) Q:NEXTSURO'>0 Q:+$P(SURODATA,U,3)>NOW Q:'(+$$ACTIVE^XUSER(NEXTSURO)) S CURRSURO=NEXTSURO + Q CURRSURO + ; +GETSURO(XQAUSER) ;SR. - returns data for surrogate for user including times + I $$CURRSURO(XQAUSER)'>0 Q "" + N GLOBREF,IENS,X + S IENS=XQAUSER_",",GLOBREF=$NA(^TMP($J,"XQALSURO")) K @GLOBREF + D GETS^DIQ(8992,IENS,".02;.03;.04","IE",GLOBREF) + S GLOBREF=$NA(@GLOBREF@(8992,IENS)) + S X=$G(@GLOBREF@(.02,"I"))_U_$G(@GLOBREF@(.02,"E"))_U_$G(@GLOBREF@(.03,"I"))_U_$G(@GLOBREF@(.04,"I")) + K @GLOBREF + Q X + ; +GETFOR ;OPT. + N XQAUSER,VALUES,XQACNT,DIR,DIRUT,I,Y + S DIR(0)="PD^200:AEMQ",DIR("A",1)="View Users who have selected a specified User as their Surrogate." + S DIR("A")="Select User (NEW PERSON entry)" + D ^DIR K DIR Q:Y'>0 W " ",$P(Y,U,2) + S XQAUSER=+Y + D SUROFOR(.VALUES,XQAUSER) I VALUES'>0 W !,"No entries found.",!! Q + S XQACNT=0 K DIRUT F I=0:0 S I=$O(VALUES(I)) Q:I'>0 D:(XQACNT>(IOSL-4)) Q:$D(DIRUT) W !,?5,$P(VALUES(I),U,2) S XQACNT=XQACNT+1 + . S DIR(0)="E" D ^DIR K DIR + . Q + K DIRUT + Q + ; +SUROLIST(XQAUSER,XQALIST) ; SR. returns list of current and scheduled surrogates for XQAUSER + D SUROLIST^XQALSUR1(XQAUSER,.XQALIST) + Q + ; +SUROFOR(LIST,XQAUSER) ;SR. - returns list of users XQAUSER is acting as a surrogate for + I $G(XQAUSER)="" Q + N I,COUNT S I=0,COUNT=0 F S I=$O(^XTV(8992,"AC",XQAUSER,I)) Q:I'>0 I $$CURRSURO(I)>0 D + . S COUNT=COUNT+1,LIST(COUNT)=I_U_$$GET1^DIQ(200,(I_","),".01","E")_U_$$GET1^DIQ(8992,(I_","),".03","E")_U_$$GET1^DIQ(8992,(I_","),".04","E") + S LIST=COUNT + Q + ; +SENDMESG ; + N XMY,XMDUZ,XMCHAN + ; ZEXCEPT: XQALSURO (EXTERNAL VALUE) + S XMY(XQALSURO)="",XMDUZ=.5 + D ^XMD + Q diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQARPRT2.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQARPRT2.m index 342c4cda..31ac2b1f 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQARPRT2.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQARPRT2.m @@ -1,152 +1,149 @@ -XQARPRT2 ;DCN/BUF,JLI/OAK-OIFO - LOOKUP PROVIDER ALERTS ;4/9/07 10:16 - ;;8.0;KERNEL;**316,443**;Jul 10, 1995;Build 4 - ; Based on the original routine AEKALERT - Q -EN ; OPT - interactive lists alerts from start date for a single user based on contents of alert tracking file - N DIR,XQADOC S DIR(0)="PO^200:EMZ" D ^DIR K DIR Q:$D(DIRUT) Q:Y'>0 S XQADOC=+Y -EN1 ; - N XQASDATE,XQAWORDS,XQADISP,%ZIS,ZTRTN,ZTDESC,ZTSAVE,POP,XQAU1N4 - D DATES Q:Y'>0 - D WORDS() Q:$D(DIRUT) K Y - S %ZIS="MQ" D ^%ZIS Q:POP I $D(IO("Q")) K IO("Q") S ZTRTN="DQ1^XQARPRT2",ZTDESC="List of User Alerts",ZTSAVE("*")="" D ^%ZTLOAD W:$G(ZTSK)>0 !,"Task number is ",ZTSK K ZTSK Q -DQ1 ; - N XQANWID,XQAIEN,XQADATE,XQANODE0,XQACTR,HEADERID,XQATOT - S HEADERID="User "_$$GET1^DIQ(200,XQADOC_",",.01)_" (DFN="_XQADOC_")" - U IO - D HEADER(HEADERID,1) - S XQAIEN=$O(^XTV(8992.1,"D",XQASDATE-.0000001)) I XQAIEN>0 S XQAIEN=$O(^(XQAIEN,0)) ; find starting point instead of having to work up through x-ref - I XQAIEN>0 F S XQAIEN=$O(^XTV(8992.1,"R",XQADOC,XQAIEN)) Q:XQAIEN'>0 D Q:$D(DIRUT)!(XQADATE>XQAEDATE) - . S XQANODE0=$G(^XTV(8992.1,XQAIEN,0)),XQADATE=$P(XQANODE0,"^",2) Q:(XQADATEXQAEDATE) - . D PRNTATRK(XQAIEN) - D HEADER(HEADERID,0) - D ^%ZISC - K XQADATE,XQACTR,DATA,DIR,DIRUT,XQADOC,XQAIEN,XQANODE0,XQASDATE,Y - Q - ; -WORDS(TYPE) ; Allow user to select alerts containing only certain words - S DIR(0)="Y",DIR("A")="Do you want to "_$S($G(TYPE)'="":"count",1:"list")_" only alerts containing specific words or phrase(s)" - S DIR("?",1)="You can enter one or more words or phrases which you want to be used to" - S DIR("?",2)="select the alerts to be listed. If you enter NO, all for the selected" - S DIR("?",3)="individual in the selected time period will be selected. If you enter" - S DIR("?",4)="YES, you will be prompted to enter a word or phrase. You will be prompted" - S DIR("?",5)="again, and you may enter as many word or phrase entries as you want." - S DIR("?",6)="Comparisons will NOT be case specific." - S DIR("?",7)="" - S DIR("?",8)="HOWEVER ALL WORDS OR PHRASES ENTERED MUST BE IN THE MESSAGE FOR AN ALERT" - S DIR("?")="TO BE SELECTED." - D ^DIR K DIR Q:Y'>0 - ; - F J=1:1 W:J>1 !?7,"--- OR ---",!,"Enter another set of words or phrases that should",!,"be matched independently of the previous entr"_$S(J>2:"ies",1:"y") D Q:'$D(XQAWORDS(J)) - . W !?10,"ALL words or phrases connected by -AND- must appear in the",!?10,"message for an alert to be selected" - . S DIR("?",1)="Enter a word, at least three characters long, or phrase, without regard to" - . S DIR("?",2)="case, that you want to be required for selection of alerts to be listed." - . S DIR("?",3)="If more than one word or phrase are specified, ALL of them must be in alerts" - . S DIR("?")="which will be listed." - . F I=1:1 S DIR(0)="FO^3:",DIR("A")="Enter "_$S(I=1:"a",1:"another")_" word or phrase" W:I>1 !?10,"-AND-" D ^DIR Q:(Y="")!(Y["^") S XQAWORDS(J,I)=$$UP^XLFSTR(Y) - . K DIR,DIRUT - . Q - ; - I $D(XQAWORDS)>1,$G(TYPE)="" D - . S DIR(0)="SO^1:Both Action and Info Only;2:Action Alerts;3:Info Only Alerts",DIR("?",1)="Select whether alerts listed should be alerts involving actions (2), info",DIR("?")="only or text only alerts (3), or both (1)." - . S DIR("A")="Select Alert Type(s) desired",DIR("B")=1 D ^DIR K DIR S:Y'>0 Y=1 K DIRUT S XQADISP=+Y - . Q - Q - ; -USER ;USER ENTRY POINT - N DIR,XQADOC S XQADOC=DUZ - G EN1 - ; -DATES ; - S DIR(0)="DO^::EX",DIR("B")="TODAY",DIR("A")="START DATE" D ^DIR K DIR Q:Y'>0 S XQASDATE=+Y - I XQASDATE<$$OLDEST() W !?10,"The earliest date in the alert tracking file is ",$$FMTE^XLFDT($$OLDEST(),"D") S XQASDATE=$$OLDEST() - I $D(XQA1U4N) W !,"*** WARNING ***: Do not specify too many days - each entry in the Alert Tracking",!,"file must be checked for the date range specified.",! S DIR("B")=$$FMTE^XLFDT(XQASDATE) - S DIR(0)="DO^"_XQASDATE_":DT",DIR("A")="END DATE" D ^DIR K DIR Q:$D(DIRUT) I Y>0 S XQAEDATE=Y+.24 - Q - ; -PRNTATRK(IEN) ; Print data for an entry from the alert tracking file - N XQANODE0,XQADATE,Y,XQANEN,XQAMSG,XQAOPT,XQAROU,XQAMSGUC - S XQANODE0=$G(^XTV(8992.1,IEN,0)),XQADATE=$P(XQANODE0,"^",2) - S XQAMSG=$G(^XTV(8992.1,IEN,1)),XQAOPT=$P(XQAMSG,U,2),XQAROU=$P(XQAMSG,U,3,4),XQAMSG=$P(XQAMSG,U) - S XQAOPT=$S(XQAOPT>0:" [OPT]",1:"") S XQAROU=$S((XQAROU'="")&(XQAROU'="^"):" [ROU]",1:"") S XQAOPT=$S(XQAOPT'="":XQAOPT,XQAROU'="":XQAROU,1:" ") - I $D(XQAWORDS)>1 S XQAMSGUC=$$UP^XLFSTR(XQAMSG) D Q:XQAMSGUC="" - . N XQAMSG1,J,I S XQAMSG1=XQAMSGUC F J=0:0 S J=$O(XQAWORDS(J)) Q:J'>0 S XQAMSGUC=XQAMSG1 D Q:XQAMSGUC'="" - . . F I=0:0 S I=$O(XQAWORDS(J,I)) Q:I'>0 I XQAMSGUC'[XQAWORDS(J,I) S XQAMSGUC="" Q - . . I XQAMSGUC'="",XQADISP'=1 D - . . . I XQADISP=2,XQAOPT="",XQAROU="" S XQAMSGUC="" - . . . I XQADISP=3,(XQAOPT'="")!(XQAROU'="") S XQAMSGUC="" - . . . Q - . . Q - . Q - S XQANEN=$$FMTE^XLFDT(XQADATE,"5Z")_XQAOPT_" ien="_IEN - W !,$E(XQAMSG,1,IOM-1) W !?35,XQANEN S XQATOT=XQATOT+1 - S XQACTR=XQACTR+2 I XQACTR>(IOSL-4) D Q:$D(DIRUT) S XQACTR=0 - . I $D(ZTQUEUED) W @IOF - . E U IO(0) S DIR(0)="E" D ^DIR K DIR W ! - . U IO - . Q - Q - ; -HEADER(XQANAME,DOFF) ; Output header at start of report XQANAME indicates who report is for - W:DOFF @IOF W:'DOFF ! W $S('DOFF:"Found "_XQATOT_" ",1:""),$S($D(XQAWORDS)>1:"Selected ",1:""),"Alerts for ",XQANAME,!," for dates ",$$FMTE^XLFDT(XQASDATE)," through " - N OUTDATE S OUTDATE=$$FMTE^XLFDT(XQAEDATE,"D") I 'DOFF,$D(XQADATE),XQADATE0 W:I>1 !?10,"--- OR ---" D - . F J=0:0 S J=$O(XQAWORDS(I,J)) Q:J'>0 W !?5,$S(J=1:"Selected alerts containing:",1:" and containing:"),?35,XQAWORDS(I,J) S XQACTR=XQACTR+1 - . Q - Q -DTPT ; OPT - GIVEN DATE AND PATIENT, TAKE A LOOK AT ALL USING 'D' X-REF - ; for one day and for 1 patient list data in alert tracking file related to patient - N DIR,XQANAME,XQADFN,XQA1U4N,XQASDATE,XQAEDATE,XQA1U4NP,XQAWORDS - S DIR(0)="PO^2:EMZ" D ^DIR Q:Y'>0 S XQANAME=$P(Y,"^",2),XQADFN=+Y,XQA1U4N=$$GET1^DIQ(2,XQADFN_",",.0905),XQA1U4NP="("_XQA1U4N_")" - D CHEKSCAN(XQADFN) Q:$D(DIRUT) - D DATES Q:Y'>0 - D WORDS() K Y Q:$D(DIRUT) - S %ZIS="MQ" D ^%ZIS Q:POP I $D(IO("Q")) K IO("Q") S ZTRTN="DTPTDQ^XQARPRT2",ZTDESC="List of Patient Alerts",ZTSAVE("*")="" D ^%ZTLOAD W:$G(ZTSK)>0 !,"Task number is ",ZTSK K ZTSK Q -DTPTDQ ; - N XQANWID,FOUND,ONE,ZERO,XQACTR,XQAIEN,XQATYPE,XQADATE,HEADERID,XQATOT - S HEADERID="Patient "_$$GET1^DIQ(2,XQADFN_",",.01)_" ("_$$GET1^DIQ(2,XQADFN_",",.0905)_")" - D HEADER(HEADERID,1) - S XQADATE=XQASDATE-0.0000001 F S XQADATE=$O(^XTV(8992.1,"D",XQADATE)) Q:(XQADATE'>0)!(XQADATE>XQAEDATE) D Q:$D(DIRUT) - . S XQAIEN=0 F S XQAIEN=$O(^XTV(8992.1,"D",XQADATE,XQAIEN)) Q:XQAIEN="" S ONE=$G(^XTV(8992.1,XQAIEN,1)),ZERO=$G(^(0)),XQATYPE=$E(ZERO,1,3) D Q:$D(DIRUT) - . . S FOUND=0 - . . I (XQATYPE="DVB")!(XQATYPE="OR,") I $P(ZERO,U,4)=XQADFN S FOUND=1 - . . I (XQATYPE="GMA"),$P(ONE,U)[XQANAME S FOUND=1 - . . I (XQATYPE="TIU"),$P(ONE,U)[$E(XQANAME,1,9),$P(ONE,U)[XQA1U4NP S FOUND=1 - . . I FOUND D PRNTATRK(XQAIEN) - . . Q - . Q - D HEADER(HEADERID,0) - Q - ; -CHEKSCAN(XQADFN) ; Output a list of dates when OR, and DVB alerts are found - N DIR,OLDEST,X,Y,XQASDATE,XX,CNT,COL,BASECNT,I - W !!! S DIR(0)="Y",DIR("A")="Do you want to scan for a list of dates that have at least some alerts for this patient",DIR("A",1)="The quick scan method used here will not pick up some alerts," - S DIR("A",2)="but should give an indication of when alerts might be found.",DIR("A",3)="" - D ^DIR K DIR Q:$D(DIRUT) I Y D - . K ^TMP("XQARPRT2",$J) - . N OLDEST S OLDEST=$$FMTE^XLFDT($$OLDEST(),"5DZ") - . S DIR(0)="SO^;1:1 Week ago;2:1 month ago;3:3 months ago;4:6 months ago;5:1 year ago;6:As far back as possible",DIR("A")="Select a period for starting",DIR("A",1)="The oldest entry in your Alert Tracking file is from "_OLDEST,DIR("A",2)="" - . D ^DIR K DIR Q:Y'>0 - . S X=$S(Y=1:"1W",Y=2:"1M",Y=3:"3M",Y=4:"6M",Y=5:"12M",1:"1000M"),X="T-"_X D ^%DT S XQASDATE=Y - . F I=0:0 S I=$O(^XTV(8992.1,"C",XQADFN,I)) Q:I'>0 S ZERO=$P(^XTV(8992.1,I,0),U,2) I ZERO'0 S CNT=CNT+1,XX(CNT)=$G(XX(CNT))_$$FMTE^XLFDT(I,"5DZ")_" ("_^(I)_")"_" " I (CNT-BASECNT)>(IOSL-4) S COL=COL+1 S:'(COL#3) BASECNT=CNT S CNT=BASECNT - . S CNT=2 F I=0:0 S I=$O(^TMP("XQARPRT2",$J,I)) Q:I'>0 S CNT=CNT+1,XX(CNT\3)=$G(XX(CNT\3))_$$FMTE^XLFDT(I,"5DZ")_" ("_^(I)_")"_" " - . F I=0:0 S I=$O(XX(I)) Q:I'>0 W !,XX(I) - . Q - Q - ; -VIEWTRAK ; OPT. View an entry in the Alert Tracking file in Captioned mode - D VIEWTRAK^XQARPRT1 - Q - ; -OLDEST() ; Returns date of oldest entry in alert tracking file - Q $$OLDEST^XQARPRT1() +XQARPRT2 ;DCN/BUF,JLI/OAK-OIFO - LOOKUP PROVIDER ALERTS 25 SEP 98 ;9/3/03 11:15 + ;;8.0;KERNEL;**316**;Jul 10, 1995 + ; Based on the original routine AEKALERT + Q +EN ; OPT - interactive lists alerts from start date for a single user based on contents of alert tracking file + N DIR,XQADOC S DIR(0)="PO^200:EMZ" D ^DIR K DIR Q:$D(DIRUT) Q:Y'>0 S XQADOC=+Y +EN1 ; + N XQASDATE,XQAWORDS,XQADISP,%ZIS,ZTRTN,ZTDESC,ZTSAVE,POP,XQAU1N4 + D DATES Q:Y'>0 + D WORDS() Q:$D(DIRUT) K Y + S %ZIS="MQ" D ^%ZIS Q:POP I $D(IO("Q")) K IO("Q") S ZTRTN="DQ1^XQARPRT2",ZTDESC="List of User Alerts",ZTSAVE("*")="" D ^%ZTLOAD W:$G(ZTSK)>0 !,"Task number is ",ZTSK K ZTSK Q +DQ1 ; + N XQANWID,XQAIEN,XQADATE,XQANODE0,XQACTR,HEADERID,XQATOT + S HEADERID="User "_$$GET1^DIQ(200,XQADOC_",",.01)_" (DFN="_XQADOC_")" + D HEADER(HEADERID,1) + S XQAIEN=$O(^XTV(8992.1,"D",XQASDATE-.0000001)) I XQAIEN>0 S XQAIEN=$O(^(XQAIEN,0)) ; find starting point instead of having to work up through x-ref + I XQAIEN>0 F S XQAIEN=$O(^XTV(8992.1,"R",XQADOC,XQAIEN)) Q:XQAIEN'>0 D Q:$D(DIRUT)!(XQADATE>XQAEDATE) + . S XQANODE0=$G(^XTV(8992.1,XQAIEN,0)),XQADATE=$P(XQANODE0,"^",2) Q:(XQADATEXQAEDATE) + . D PRNTATRK(XQAIEN) + D HEADER(HEADERID,0) + K XQADATE,XQACTR,DATA,DIR,DIRUT,XQADOC,XQAIEN,XQANODE0,XQASDATE,Y + Q + ; +WORDS(TYPE) ; Allow user to select alerts containing only certain words + S DIR(0)="Y",DIR("A")="Do you want to "_$S($G(TYPE)'="":"count",1:"list")_" only alerts containing specific words or phrase(s)" + S DIR("?",1)="You can enter one or more words or phrases which you want to be used to" + S DIR("?",2)="select the alerts to be listed. If you enter NO, all for the selected" + S DIR("?",3)="individual in the selected time period will be selected. If you enter" + S DIR("?",4)="YES, you will be prompted to enter a word or phrase. You will be prompted" + S DIR("?",5)="again, and you may enter as many word or phrase entries as you want." + S DIR("?",6)="Comparisons will NOT be case specific." + S DIR("?",7)="" + S DIR("?",8)="HOWEVER ALL WORDS OR PHRASES ENTERED MUST BE IN THE MESSAGE FOR AN ALERT" + S DIR("?")="TO BE SELECTED." + D ^DIR K DIR Q:Y'>0 + ; + F J=1:1 W:J>1 !?7,"--- OR ---",!,"Enter another set of words or phrases that should",!,"be matched independently of the previous entr"_$S(J>2:"ies",1:"y") D Q:'$D(XQAWORDS(J)) + . W !?10,"ALL words or phrases connected by -AND- must appear in the",!?10,"message for an alert to be selected" + . S DIR("?",1)="Enter a word, at least three characters long, or phrase, without regard to" + . S DIR("?",2)="case, that you want to be required for selection of alerts to be listed." + . S DIR("?",3)="If more than one word or phrase are specified, ALL of them must be in alerts" + . S DIR("?")="which will be listed." + . F I=1:1 S DIR(0)="FO^3:",DIR("A")="Enter "_$S(I=1:"a",1:"another")_" word or phrase" W:I>1 !?10,"-AND-" D ^DIR Q:(Y="")!(Y["^") S XQAWORDS(J,I)=$$UP^XLFSTR(Y) + . K DIR,DIRUT + . Q + ; + I $D(XQAWORDS)>1,$G(TYPE)="" D + . S DIR(0)="SO^1:Both Action and Info Only;2:Action Alerts;3:Info Only Alerts",DIR("?",1)="Select whether alerts listed should be alerts involving actions (2), info",DIR("?")="only or text only alerts (3), or both (1)." + . S DIR("A")="Select Alert Type(s) desired",DIR("B")=1 D ^DIR K DIR S:Y'>0 Y=1 K DIRUT S XQADISP=+Y + . Q + Q + ; +USER ;USER ENTRY POINT + N DIR,XQADOC S XQADOC=DUZ + G EN1 + ; +DATES ; + S DIR(0)="DO^::EX",DIR("B")="TODAY",DIR("A")="START DATE" D ^DIR K DIR Q:Y'>0 S XQASDATE=+Y + I XQASDATE<$$OLDEST() W !?10,"The earliest date in the alert tracking file is ",$$FMTE^XLFDT($$OLDEST(),"D") S XQASDATE=$$OLDEST() + I $D(XQA1U4N) W !,"*** WARNING ***: Do not specify too many days - each entry in the Alert Tracking",!,"file must be checked for the date range specified.",! S DIR("B")=$$FMTE^XLFDT(XQASDATE) + S DIR(0)="DO^"_XQASDATE_":DT",DIR("A")="END DATE" D ^DIR K DIR Q:$D(DIRUT) I Y>0 S XQAEDATE=Y+.24 + Q + ; +PRNTATRK(IEN) ; Print data for an entry from the alert tracking file + N XQANODE0,XQADATE,Y,XQANEN,XQAMSG,XQAOPT,XQAROU,XQAMSGUC + S XQANODE0=$G(^XTV(8992.1,IEN,0)),XQADATE=$P(XQANODE0,"^",2) + S XQAMSG=$G(^XTV(8992.1,IEN,1)),XQAOPT=$P(XQAMSG,U,2),XQAROU=$P(XQAMSG,U,3,4),XQAMSG=$P(XQAMSG,U) + S XQAOPT=$S(XQAOPT>0:" [OPT]",1:"") S XQAROU=$S((XQAROU'="")&(XQAROU'="^"):" [ROU]",1:"") S XQAOPT=$S(XQAOPT'="":XQAOPT,XQAROU'="":XQAROU,1:" ") + I $D(XQAWORDS)>1 S XQAMSGUC=$$UP^XLFSTR(XQAMSG) D Q:XQAMSGUC="" + . N XQAMSG1,J,I S XQAMSG1=XQAMSGUC F J=0:0 S J=$O(XQAWORDS(J)) Q:J'>0 S XQAMSGUC=XQAMSG1 D Q:XQAMSGUC'="" + . . F I=0:0 S I=$O(XQAWORDS(J,I)) Q:I'>0 I XQAMSGUC'[XQAWORDS(J,I) S XQAMSGUC="" Q + . . I XQAMSGUC'="",XQADISP'=1 D + . . . I XQADISP=2,XQAOPT="",XQAROU="" S XQAMSGUC="" + . . . I XQADISP=3,(XQAOPT'="")!(XQAROU'="") S XQAMSGUC="" + . . . Q + . . Q + . Q + S XQANEN=$$FMTE^XLFDT(XQADATE,"5Z")_XQAOPT_" ien="_IEN + W !,$E(XQAMSG,1,IOM-1) W !?35,XQANEN S XQATOT=XQATOT+1 + S XQACTR=XQACTR+2 I XQACTR>(IOSL-4) D Q:$D(DIRUT) S XQACTR=0 + . I $D(ZTQUEUED) W @IOF + . E S DIR(0)="E" D ^DIR K DIR W ! + . Q + Q + ; +HEADER(XQANAME,DOFF) ; Output header at start of report XQANAME indicates who report is for + W:DOFF @IOF W:'DOFF ! W $S('DOFF:"Found "_XQATOT_" ",1:""),$S($D(XQAWORDS)>1:"Selected ",1:""),"Alerts for ",XQANAME,!," for dates ",$$FMTE^XLFDT(XQASDATE)," through " + N OUTDATE S OUTDATE=$$FMTE^XLFDT(XQAEDATE,"D") I 'DOFF,$D(XQADATE),XQADATE0 W:I>1 !?10,"--- OR ---" D + . F J=0:0 S J=$O(XQAWORDS(I,J)) Q:J'>0 W !?5,$S(J=1:"Selected alerts containing:",1:" and containing:"),?35,XQAWORDS(I,J) S XQACTR=XQACTR+1 + . Q + Q +DTPT ; OPT - GIVEN DATE AND PATIENT, TAKE A LOOK AT ALL USING 'D' X-REF + ; for one day and for 1 patient list data in alert tracking file related to patient + N DIR,XQANAME,XQADFN,XQA1U4N,XQASDATE,XQAEDATE,XQA1U4NP,XQAWORDS + S DIR(0)="PO^2:EMZ" D ^DIR Q:Y'>0 S XQANAME=$P(Y,"^",2),XQADFN=+Y,XQA1U4N=$$GET1^DIQ(2,XQADFN_",",.0905),XQA1U4NP="("_XQA1U4N_")" + D CHEKSCAN(XQADFN) Q:$D(DIRUT) + D DATES Q:Y'>0 + D WORDS() K Y Q:$D(DIRUT) + S %ZIS="MQ" D ^%ZIS Q:POP I $D(IO("Q")) K IO("Q") S ZTRTN="DTPTDQ^XQARPRT2",ZTDESC="List of Patient Alerts",ZTSAVE("*")="" D ^%ZTLOAD W:$G(ZTSK)>0 !,"Task number is ",ZTSK K ZTSK Q +DTPTDQ ; + N XQANWID,FOUND,ONE,ZERO,XQACTR,XQAIEN,XQATYPE,XQADATE,HEADERID,XQATOT + S HEADERID="Patient "_$$GET1^DIQ(2,XQADFN_",",.01)_" ("_$$GET1^DIQ(2,XQADFN_",",.0905)_")" + D HEADER(HEADERID,1) + S XQADATE=XQASDATE-0.0000001 F S XQADATE=$O(^XTV(8992.1,"D",XQADATE)) Q:(XQADATE'>0)!(XQADATE>XQAEDATE) D Q:$D(DIRUT) + . S XQAIEN=0 F S XQAIEN=$O(^XTV(8992.1,"D",XQADATE,XQAIEN)) Q:XQAIEN="" S ONE=$G(^XTV(8992.1,XQAIEN,1)),ZERO=$G(^(0)),XQATYPE=$E(ZERO,1,3) D Q:$D(DIRUT) + . . S FOUND=0 + . . I (XQATYPE="DVB")!(XQATYPE="OR,") I $P(ZERO,U,4)=XQADFN S FOUND=1 + . . I (XQATYPE="GMA"),$P(ONE,U)[XQANAME S FOUND=1 + . . I (XQATYPE="TIU"),$P(ONE,U)[$E(XQANAME,1,9),$P(ONE,U)[XQA1U4NP S FOUND=1 + . . I FOUND D PRNTATRK(XQAIEN) + . . Q + . Q + D HEADER(HEADERID,0) + Q + ; +CHEKSCAN(XQADFN) ; Output a list of dates when OR, and DVB alerts are found + N DIR,OLDEST,X,Y,XQASDATE,XX,CNT,COL,BASECNT,I + W !!! S DIR(0)="Y",DIR("A")="Do you want to scan for a list of dates that have at least some alerts for this patient",DIR("A",1)="The quick scan method used here will not pick up some alerts," + S DIR("A",2)="but should give an indication of when alerts might be found.",DIR("A",3)="" + D ^DIR K DIR Q:$D(DIRUT) I Y D + . K ^TMP("XQARPRT2",$J) + . N OLDEST S OLDEST=$$FMTE^XLFDT($$OLDEST(),"5DZ") + . S DIR(0)="SO^;1:1 Week ago;2:1 month ago;3:3 months ago;4:6 months ago;5:1 year ago;6:As far back as possible",DIR("A")="Select a period for starting",DIR("A",1)="The oldest entry in your Alert Tracking file is from "_OLDEST,DIR("A",2)="" + . D ^DIR K DIR Q:Y'>0 + . S X=$S(Y=1:"1W",Y=2:"1M",Y=3:"3M",Y=4:"6M",Y=5:"12M",1:"1000M"),X="T-"_X D ^%DT S XQASDATE=Y + . F I=0:0 S I=$O(^XTV(8992.1,"C",XQADFN,I)) Q:I'>0 S ZERO=$P(^XTV(8992.1,I,0),U,2) I ZERO'0 S CNT=CNT+1,XX(CNT)=$G(XX(CNT))_$$FMTE^XLFDT(I,"5DZ")_" ("_^(I)_")"_" " I (CNT-BASECNT)>(IOSL-4) S COL=COL+1 S:'(COL#3) BASECNT=CNT S CNT=BASECNT + . S CNT=2 F I=0:0 S I=$O(^TMP("XQARPRT2",$J,I)) Q:I'>0 S CNT=CNT+1,XX(CNT\3)=$G(XX(CNT\3))_$$FMTE^XLFDT(I,"5DZ")_" ("_^(I)_")"_" " + . F I=0:0 S I=$O(XX(I)) Q:I'>0 W !,XX(I) + . Q + Q + ; +VIEWTRAK ; OPT. View an entry in the Alert Tracking file in Captioned mode + D VIEWTRAK^XQARPRT1 + Q + ; +OLDEST() ; Returns date of oldest entry in alert tracking file + Q $$OLDEST^XQARPRT1() diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQCHK.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQCHK.m index 88dbbb96..0e90e9cb 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQCHK.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQCHK.m @@ -1,80 +1,238 @@ -XQCHK ; SEA/MJM - Check security on option # XQCY ;5/20/08 - ;;8.0;KERNEL;**47,110,149,303,427,503**;Jul 10, 1995;Build 2 - ;;"Per VHA Directive 2004-038, this routine should not be modified". - ; - Q:'$D(XQCY)!(XQCY<1) S:'$D(XQJMP) XQJMP=0 - I '$D(XQY0) S XQY0=^DIC(19,+XQCY,0) - I '$D(XQCY0) S XQSAV=XQY0,XQY=XQCY D SET Q:XQCY<0 S XQCY0=XQY0,XQY0=XQSAV -CHK I XQCY0="" S XQCY=-1 G OUT - I $P(XQCY0,U,3)'="" S XQCY=-1 G OUT - N XQRT S XQRT=$$CHCKL^XQCHK2(XQCY0,DUZ) I +XQRT S XQCY=-2 G OUT ; add this line to check all Locks - I $L($P(XQCY0,U,6)) S %="" F %XQI=1:1 S %=$P($P(XQCY0,U,6),",",%XQI) Q:%="" I '$D(^XUSEC(%,DUZ)) S XQCY=-2 G OUT ; remove - N XQRT S XQRT=$$CHCKRL^XQCHK2(XQCY0,DUZ) I +XQRT S XQCY=-3 G OUT ; add this line to check all Reversed Locks - I $L($P(XQCY0,U,16)) S %="" F %XQI=1:1 S %=$P($P(XQCY0,U,16),",",%XQI) Q:%="" I $D(^XUSEC(%,DUZ)) S XQCY=-3 G OUT ; remove - I $L($P(XQCY0,U,9)) S XQZ=$P(XQCY0,U,9) D ^XQDATE S X=% D XQO^XQ92 I X="" S XQCY=-4 G OUT - G:$P(XQCY0,U,10)'["y" OUT - S %=0 F %XQI=1:1 S %=$O(^DIC(19,XQCY,3.96,%,0)) Q:%="" I IOS=% G OUT - S XQCY=-5 G OUT - Q - ; -OUT K %,%XQI,XQCY0,%Y,XQZ - Q - ; -JMP ;Check all options in jump path in %XQJP returned as "" if not OK - S XQJMP=1 - F %XQCI=1:1 S XQCY=$P(%XQJP,",",%XQCI) Q:XQCY="" S XQCY0=$G(^XUTL("XQO",XQDIC,"^",XQCY)),XQCY0=$P(XQCY0,U,2,99) D CHK S:XQCY<0 %XQJP="" - K %XQCI,XQCY,XQCY0 - Q - ; -SET ;Produce the same XQY0 as SET1^XQ7 without the synonym - I '$D(^DIC(19,+XQY,0)) S XQY=-1 Q -S1 Q:XQY'>0 S XQY0=^DIC(19,+XQY,0),XQY0=$P(XQY0,U,1,2)_U_$S($P(XQY0,U,3)]"":1,1:"")_U_$P(XQY0,U,4)_U_U_$P(XQY0,U,6,99) - S %="" I $D(^DIC(19,+XQY,3.91)) F %XQI=0:0 S %XQI=$O(^DIC(19,+XQY,3.91,%XQI)) Q:%XQI=""!(%XQI'=+%XQI) I ^(%XQI,0)]"" S %=$S(%'="":%_";",1:"")_$P(^(0),U,1)_$P(^(0),U,2) - I %]"" S XQY0=$P(XQY0,U,1,8)_U_%_U_$P(XQY0,U,10,99) - I $P(XQY0,U,16),$D(^DIC(19,XQY,3)) S %=$P(^(3),U) I %'="" S XQY0=$P(XQY0,U,1,15)_U_%_U_$P(XQY0,U,17,99) - K %,%XQI - Q - ; -MES ;Messages for rejected options from a call to XQCHK - W $C(7) - I XQCY=-1 W !!?5,"==> Sorry, ",$S($D(XQPRMN):"your Primary Menu",1:"this option")," is out of order with the message:",!?10,$P(^DIC(19,XQY,0),U,3) - I XQCY=-2 W !!?5,"==> Sorry, ",$S($D(XQPRMN):"your Primary Menu",1:"this option")," is locked." - I XQCY=-3 W !!?5,"==> Sorry, ",$S($D(XQPRMN):"your Primary Menu",1:"this option")," has a reverse lock on it." - I XQCY=-4 W !!?5,"==> Sorry, ",$S($D(XQPRMN):"your Primary Menu",1:"this option")," not allowed right now." - I XQCY=-5 W !!?5,"==> Sorry, ",$S($D(XQPRMN):"your Primary Menu",1:"this option")," not allowed on this device." - Q - ; -OP ;Find out what option or protocol is in charge right now - ;Returns option or protocol name and text in XQOPT - S U="^",%XQ=0 - I $D(XQORNOD) S %XQ=+XQORNOD,%XQ1=U_$P(XQORNOD,";",2),%XQ=@(%XQ1_%XQ_",0)"),XQOPT=$P(%XQ,U)_U_$P(%XQ,U,2) - I '$D(XQORNOD) S %XQ=$S($D(XQY)#2:XQY,1:0) I %XQ S %XQ1=^DIC(19,+%XQ,0),XQOPT=$P(%XQ1,U)_U_$P(%XQ1,U,2) - I '$D(XQOPT) S XQOPT="-1^Unknown" - K %XQ,%XQ1 - Q - ; -OP1() ;Extrinsic function call returns 3 pieces: 1. "P", "O", or "U" for - ;Protocol, Option, or Unknown. 2: The Option or Protocol's name. 3: - ;3: Text name of the Protocol or Option. For example: - ; - ; O^EVE^System Manager's Menu - ; - N %,%XQ,%XQ1 - S U="^",%XQ=0 - I $D(XQORNOD) S %XQ=+XQORNOD,%XQ1=U_$P(XQORNOD,";",2),%XQ=@(%XQ1_%XQ_",0)"),%="P"_U_$P(%XQ,U)_U_$P(%XQ,U,2) - I '$D(XQORNOD) S %XQ=$S($D(XQY)#2:XQY,1:0) I %XQ S %XQ1=^DIC(19,+%XQ,0),%="O"_U_$P(%XQ1,U)_U_$P(%XQ1,U,2) - I '$D(%) S %="U"_U_"Unknown"_U_"No option or protocol data available" - Q % - ; -ACCESS(%XQUSR,%XQOP) ;Find out if a user has access to a particular option - Q $$ACCESS^XQCHK3(%XQUSR,%XQOP) - ; -OPACCES ;Entry point for the option that checks to see if a user has - ;access to a particular option by calling the above function. - D OPACCES^XQCHK3 - Q - ; -KEYSET(XQU) ;Collect users keys and set them into ^TMP($J) - N %,XQI - S %=0 F XQI=0:1 S %=$O(^VA(200,XQU,51,"B",%)) Q:%="" S:$D(^DIC(19.1,%,0)) ^TMP($J,$P(^DIC(19.1,%,0),U),%)="" - Q +XQCHK ; SEA/MJM - Check security on option # XQCY ; [7/19/06 10:45am] + ;;8.0;KERNEL;**47,110,149,303,427**;Jul 10, 1995;Build 3 + Q:'$D(XQCY)!(XQCY<1) S:'$D(XQJMP) XQJMP=0 + I '$D(XQY0) S XQY0=^DIC(19,+XQCY,0) + I '$D(XQCY0) S XQSAV=XQY0,XQY=XQCY D SET Q:XQCY<0 S XQCY0=XQY0,XQY0=XQSAV +CHK I XQCY0="" S XQCY=-1 G OUT + I $P(XQCY0,U,3)'="" S XQCY=-1 G OUT + N XQRT S XQRT=$$CHCKL^XQCHK2(XQCY0,DUZ) I +XQRT S XQCY=-2 G OUT ; add this line to check all Locks + I $L($P(XQCY0,U,6)) S %="" F %XQI=1:1 S %=$P($P(XQCY0,U,6),",",%XQI) Q:%="" I '$D(^XUSEC(%,DUZ)) S XQCY=-2 G OUT ; remove + N XQRT S XQRT=$$CHCKRL^XQCHK2(XQCY0,DUZ) I +XQRT S XQCY=-3 G OUT ; add this line to check all Reversed Locks + I $L($P(XQCY0,U,16)) S %="" F %XQI=1:1 S %=$P($P(XQCY0,U,16),",",%XQI) Q:%="" I $D(^XUSEC(%,DUZ)) S XQCY=-3 G OUT ; remove + I $L($P(XQCY0,U,9)) S XQZ=$P(XQCY0,U,9) D ^XQDATE S X=% D XQO^XQ92 I X="" S XQCY=-4 G OUT + G:$P(XQCY0,U,10)'["y" OUT + S %=0 F %XQI=1:1 S %=$O(^DIC(19,XQCY,3.96,%,0)) Q:%="" I IOS=% G OUT + S XQCY=-5 G OUT + Q + ; +OUT ;I XQCY=-2 W !,"Locked...Do you have the key "_$P(XQRT,"^",2) + ;I XQCY=-3 W !,"Reversed Locked...Don't you have the key "_$P(XQRT,"^",2) + K %,%XQI,XQCY0,%Y,XQZ + Q + ; +JMP ;Check all options in jump path in %XQJP returned as "" if not OK + S XQJMP=1 + F %XQCI=1:1 S XQCY=$P(%XQJP,",",%XQCI) Q:XQCY="" S XQCY0=$G(^XUTL("XQO",XQDIC,"^",XQCY)),XQCY0=$P(XQCY0,U,2,99) D CHK S:XQCY<0 %XQJP="" + K %XQCI,XQCY,XQCY0 + Q + ; +SET ;Produce the same XQY0 as SET1^XQ7 without the synonym + I '$D(^DIC(19,+XQY,0)) S XQY=-1 Q +S1 Q:XQY'>0 S XQY0=^DIC(19,+XQY,0),XQY0=$P(XQY0,U,1,2)_U_$S($P(XQY0,U,3)]"":1,1:"")_U_$P(XQY0,U,4)_U_U_$P(XQY0,U,6,99) + S %="" I $D(^DIC(19,+XQY,3.91)) F %XQI=0:0 S %XQI=$O(^DIC(19,+XQY,3.91,%XQI)) Q:%XQI=""!(%XQI'=+%XQI) I ^(%XQI,0)]"" S %=$S(%'="":%_";",1:"")_$P(^(0),U,1)_$P(^(0),U,2) + I %]"" S XQY0=$P(XQY0,U,1,8)_U_%_U_$P(XQY0,U,10,99) + I $P(XQY0,U,16),$D(^DIC(19,XQY,3)) S %=$P(^(3),U) I %'="" S XQY0=$P(XQY0,U,1,15)_U_%_U_$P(XQY0,U,17,99) + K %,%XQI + Q + ; +MES ;Messages for rejected options from a call to XQCHK + W $C(7) + I XQCY=-1 W !!?5,"==> Sorry, ",$S($D(XQPRMN):"your Primary Menu",1:"this option")," is out of order with the message:",!?10,$P(^DIC(19,XQY,0),U,3) + I XQCY=-2 W !!?5,"==> Sorry, ",$S($D(XQPRMN):"your Primary Menu",1:"this option")," is locked." + I XQCY=-3 W !!?5,"==> Sorry, ",$S($D(XQPRMN):"your Primary Menu",1:"this option")," has a reverse lock on it." + I XQCY=-4 W !!?5,"==> Sorry, ",$S($D(XQPRMN):"your Primary Menu",1:"this option")," not allowed right now." + I XQCY=-5 W !!?5,"==> Sorry, ",$S($D(XQPRMN):"your Primary Menu",1:"this option")," not allowed on this device." + Q + ; +OP ;Find out what option or protocol is in charge right now + ;Returns option or protocol name and text in XQOPT + S U="^",%XQ=0 + I $D(XQORNOD) S %XQ=+XQORNOD,%XQ1=U_$P(XQORNOD,";",2),%XQ=@(%XQ1_%XQ_",0)"),XQOPT=$P(%XQ,U)_U_$P(%XQ,U,2) + I '$D(XQORNOD) S %XQ=$S($D(XQY)#2:XQY,1:0) I %XQ S %XQ1=^DIC(19,+%XQ,0),XQOPT=$P(%XQ1,U)_U_$P(%XQ1,U,2) + I '$D(XQOPT) S XQOPT="-1^Unknown" + K %XQ,%XQ1 + Q + ; +OP1() ;Extrinsic function call returns 3 pieces: 1. "P", "O", or "U" for + ;Protocol, Option, or Unknown. 2: The Option or Protocol's name. 3: + ;3: Text name of the Protocol or Option. For example: + ; + ; O^EVE^System Manager's Menu + ; + N %,%XQ,%XQ1 + S U="^",%XQ=0 + I $D(XQORNOD) S %XQ=+XQORNOD,%XQ1=U_$P(XQORNOD,";",2),%XQ=@(%XQ1_%XQ_",0)"),%="P"_U_$P(%XQ,U)_U_$P(%XQ,U,2) + I '$D(XQORNOD) S %XQ=$S($D(XQY)#2:XQY,1:0) I %XQ S %XQ1=^DIC(19,+%XQ,0),%="O"_U_$P(%XQ1,U)_U_$P(%XQ1,U,2) + I '$D(%) S %="U"_U_"Unknown"_U_"No option or protocol data available" + Q % + ; + ; +ACCESS(%XQUSR,%XQOP) ;Find out if a user has access to a particular option + ; + ; W $$ACCESS(DUZ,Option IEN) returns: + ; + ;-1:no such user in the New Person File + ;-2: User terminated or has no access code + ;-3: no such option in the Option File + ;0: no access found in any menu tree the user owns + ; + ; All other cases return a 4-piece string stating + ; access ^ menu tree IEN ^ a set of codes ^ key + ; + ;O^tree^codes^key: No access because of locks (see XQCODES below) + ; where 'tree' is the menu where access WOULD be allowed + ; and 'key' is the key preventing access + ;1^OpIEN^^: Access allowed through Primary Menu + ;2^OpIEN^codes^: Access found in the Common Options + ;3^OpIEN^codes^: Access found in top level of secondary option + ;4^OpIEN^codes^: Access through a the secondary menu tree OpIEN. + ; + ;XQCODES can contain: + ; N=No Primary Menu in the User File (warning only) + ; L=Locked and the user does not have the key (forces 0 in first piece) + ; R=Reverse lock and user has the key (forces 0 in first piece) + ; + I '$D(^VA(200,%XQUSR,0)) Q -1 + N %,DT + S DT=$$HTFM^XLFDT($H,1) + S %=^VA(200,%XQUSR,0) I ($P(%,U,3)="")!($L($P(%,U,11))&($P(%,U,11)'>DT)) Q -2 + ; + ;Convert %XQOP to its IEN if the name is passed + I +%XQOP'=%XQOP D + .I $D(^DIC(19,"B",%XQOP))<1 S %XQOP=0 Q + .E S %XQOP=$O(^DIC(19,"B",%XQOP,0)) + .Q + I '%XQOP Q -3 + I '$D(^DIC(19,%XQOP,0)) Q -3 + ; + N XQCODES,XQCOM,XQDIC,XQDONE,XQI,XQJ,XQKEY,XQOK,XQPM,XQRSLT,XQSEC,XQTREE + S (%,XQDONE,XQOK)=0,(XQRSLT,XQCODES,XQTREE)="" + ; + ; + ;Look in the user's primary menu tree + S XQPM=$P($G(^VA(200,%XQUSR,201)),"^") + I 'XQPM S XQCODES=XQCODES_"N" + ; + ; + I XQPM S XQDIC="P"_XQPM I $D(^XUTL("XQO",XQDIC,"^",%XQOP)) D + .D KEYS + .I XQCODES'["L"&(XQCODES'["M") S XQOK=1 + .Q + I XQOK Q "1^"_XQPM_"^"_XQCODES + I XQCODES["L"!(XQCODES["R") S XQRSLT="0^"_XQPM_"^"_XQCODES_"^"_XQKEY + ; + ; Search the common options + S XQCOM=$O(^DIC(19,"B","XUCOMMAND",0)) + S XQDIC="PXU" + I $D(^XUTL("XQO",XQDIC,"^",%XQOP)) D + .D KEYS + .I XQCODES'["L"&(XQCODES'["R") S XQOK=1 + .Q + I XQOK Q "2^"_XQCOM_"^"_XQCODES + I XQRSLT="" I XQCODES["L"!(XQCODES["R") S XQRSLT="0^"_XQCOM_"^"_XQCODES_"^"_XQKEY + ; + ;Check the top level of the secondary options + S XQDIC="U"_%XQUSR + I $D(^VA(200,%XQUSR,203,0)),$P(^(0),U,4)>0 D + .S XQJ=0,XQDONE=0 + .F XQI=1:1 D Q:XQDONE + ..S XQJ=$O(^VA(200,%XQUSR,203,XQJ)) + ..I (XQJ'=+XQJ)!('XQJ) S XQDONE=1 Q + ..S XQSEC(XQI)=+^VA(200,%XQUSR,203,XQJ,0) + ..Q:XQSEC(XQI)'=%XQOP + ..D KEYS + ..I XQCODES'["L"&(XQCODES'["R") S XQOK=1 + ..I XQRSLT="" I XQCODES["L"!(XQCODES["R") S XQRSLT="0^"_XQSEC(XQI)_"^"_XQCODES_"^"_XQKEY + ..Q + .Q + I XQOK Q "3^"_%XQOP_"^"_XQCODES + ; + ;If there are no secondaries quit here + I '$D(XQI)&((XQCODES["L")!(XQCODES["R")) Q XQRSLT + I '$D(XQI) Q 0 + ; + ;Check each secondary menu tree + F XQK=1:1:XQI-1 Q:XQOK D + .S XQDIC="P"_XQSEC(XQK) + .Q:'$D(^XUTL("XQO",XQDIC,"^",%XQOP)) + .S XQTREE=$P(XQDIC,"P",2) + .D KEYS + .I XQCODES'["L"&(XQCODES'["R") S XQOK=1 + .I XQRSLT="" I XQCODES["L"!(XQCODES["R") S XQRSLT="0^"_XQTREE_"^"_XQCODES_"^"_XQKEY + .Q + I XQOK Q "4^"_XQTREE_"^"_XQCODES + I XQRSLT]"" Q XQRSLT + ; + ;We doan find nothing nowhere + Q "0^^"_XQCODES + ; +KEYS ;Check for keys, reverse keys... + N XQK,XQN,XQOPIQ,KFG + D CHCK1^XQCHK1 Q:KFG=1 + I $D(^XUTL("XQO",XQDIC,"^",%XQOP)) S XQOPIQ=^(%XQOP) + E S XQOPIQ=U_^DIC(19,%XQOP,0) + ; + I $L($P(XQOPIQ,U,7)) D + .S %=$P(XQOPIQ,U,7) + .F XQN=1:1 S XQK=$P(%,",",XQN) Q:XQK="" D + ..I '$D(^XUSEC(XQK,%XQUSR)) S XQCODES=XQCODES_"L",XQKEY=XQK + ..Q + .Q + ; + I $L($P(XQOPIQ,U,17)) D + .S %=$P(XQOPIQ,U,17) + .F XQN=1:1 S XQK=$P(%,",",XQN) Q:XQK="" D + ..I $D(^XUSEC(XQK,%XQUSR)) S XQCODES=XQCODES_"R",XQKEY=XQK + ..Q + .Q + Q + ; +OPACCES ;Entry point for the option that checks to see if a user has + ;access to a particular option by calling the above function. + N %,DIC,X,XQANS,XQCODES,XQK,XQKEY,XQOPT,XQOPN,XQPTR,XQRSLT,XQTREE,XQUSER,XQUSN,Y + ; + S DIC(0)="AEMNQ",DIC="^VA(200,",DIC("A")="Please enter the user's name: " D ^DIC + I $D(DUOUT)!($D(DTOUT)) D KILLFM Q + I Y=-1 W !!?5,"Sorry we couldn't find that user in the New Person File.",! + E S XQUSN=+Y,XQUSER=$P(Y,U,2) + I Y=-1 D KILLFM Q + D KILLFM + ; + S DIC(0)="AEMNQ",DIC="^DIC(19,",DIC("A")="Please enter the name of the option: " D ^DIC + I $D(DUOUT)!($D(DTOUT)) D KILLFM Q + I Y=-1 W !!?5,"Sorry we couldn't find that option.",! + E S XQOPN=+Y,XQOPT=$P(Y,U,2) + I Y=-1 D KILLFM Q + D KILLFM + ; + S XQANS=$$ACCESS(XQUSN,XQOPN) + ;W !,XQANS,! + ; + S XQRSLT=+XQANS,XQTREE="" + S XQPTR=$P(XQANS,U,2) I XQPTR>0 S XQTREE=$P(^DIC(19,$P(XQANS,U,2),0),U) + S XQCODES=$P(XQANS,U,3),XQKEY=$P(XQANS,U,4) + ; + I XQRSLT=-1 W !!?5,"User ",XQUSER," is not in the New Person File." + I XQRSLT=-2 W !!?5,"User ",XQUSER," has an active termination date,",!?5,"or no verify code." + I XQRSLT=-3 W !!?5,"Option ",XQOPT," is not in the Option File." + I XQRSLT=0 D + .W !!?5,"User ",XQUSER," does not have access to the option",!?5,XQOPT,"." + .I XQCODES["L" W !!?5,"There is a lock somewhere in the menu tree "_XQTREE,!?5,"and the user does not hold the key "_XQKEY_"." + .I XQCODES["R" W !!?5,"There is a reverse lock somewhere in the menu tree "_XQTREE,!?5,"and the user holds the key "_XQKEY_"." + .Q + I XQRSLT=1 W !!?5,"User ",XQUSER," has access to the option ",XQOPT,!?5,"through the primary menu ",XQTREE," (",$P(^DIC(19,XQPTR,0),U,2),")." + I XQRSLT=2 W !!?5,"User ",XQUSER," has access to the option ",XQOPT,!?5,"through the Common Options (XUCOMMAND)." + I XQRSLT=3 W !!?5,"User ",XQUSER," has access to the option ",XQOPT,!?5,"as a top-level secondary menu option." + I XQRSLT=4 W !!?5,"User ",XQUSER," has access to the option ",XQOPT,!?5,"through the secondary menu tree ",XQTREE," (",$P(^DIC(19,XQPTR,0),U,2),")." + W ! + ;W !!,%," ",XQUSER," ",XQOPT + Q + ; +KILLFM ;Kill off the FileMan variables + K D0,DI,DIC,DIE,DISYS,DQ,DR,DUOUT,DTOUT,X,Y + Q + ; +KEYSET(XQU) ;Collect users keys and set them into ^TMP($J) + N %,XQI + S %=0 F XQI=0:1 S %=$O(^VA(200,XQU,51,"B",%)) Q:%="" S:$D(^DIC(19.1,%,0)) ^TMP($J,$P(^DIC(19.1,%,0),U),%)="" + Q diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQCHK2.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQCHK2.m index f1167f54..bdb20433 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQCHK2.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQCHK2.m @@ -1,67 +1,16 @@ -XQCHK2 ; OAK-BP/BDT - Internal APIs to check Keys for options; 5/20/08 - ;;8.0;KERNEL;**427,503**;Jul 10, 1995;Build 2 - ;;"Per VHA Directive 2004-038, this routine should not be modified". - Q - ;; These Internal Kernel APIs are using in the routine XQCHK - ;; to check Keys for options - ;; -CHCKL(XQCY0,XQDUZ) ;Entry point for checking all Locks for an option - ;; XQCY0 is $P(^XUTL("XQO",XQDIC,"^",%XQOP),"^",2,99) - ;; XQDUZ is IEN of user - ;; Return XQRT: Zero or 1^Key found that user needed for the option - S XQCY0=$G(XQCY0) - N XQI,XQY,XQX,XQRT,XQK S (XQRT,XQX)=0 - ;check Key for the option; p457 - S XQY=$P(XQCY0,"^"),XQX=$$GETIEN(XQY) - I +XQX S XQK=$$GET1^DIQ(19,XQX,3) - I $G(XQK)'="",'$D(^XUSEC(XQK,XQDUZ)) S XQRT=1_"^"_XQK Q XQRT - ;loop through higher menu options. - S XQY=$P(XQCY0,"^",5) - F XQI=1:1 S XQX=$P(XQY,",",XQI) Q:'XQX D - . I +XQX S XQK=$$GET1^DIQ(19,XQX,3) I XQK'="",'$D(^XUSEC(XQK,XQDUZ)) S XQRT=1_"^"_XQK Q - Q XQRT - ; -CHCKRL(XQCY0,XQDUZ) ;Entry point for checking all Reversed Locks for an option - ;; XQCY0 is $P(^XUTL("XQO",XQDIC,"^",%XQOP),"^",2,99) - ;; XQDUZ is IEN of user - ;; Return XQRT: Zero or 1^Reversed Key found that user has - S XQCY0=$G(XQCY0) - N XQI,XQY,XQX,XQRT,XQK S (XQRT,XQX)=0 - ;check Reversed Key for the option; p457 - S XQY=$P(XQCY0,"^"),XQX=$$GETIEN(XQY) - I +XQX S XQK=$$GET1^DIQ(19,XQX,3.01) - I $G(XQK)'="",$D(^XUSEC(XQK,XQDUZ)) S XQRT=1_"^"_XQK Q XQRT - ;loop through higher menu options. - S XQY=$P(XQCY0,"^",5) - F XQI=1:1 S XQX=$P(XQY,",",XQI) Q:'XQX D - . I +XQX S XQK=$$GET1^DIQ(19,XQX,3.01) I XQK'="",$D(^XUSEC(XQK,XQDUZ)) S XQRT=1_"^"_XQK Q - Q XQRT - ; -GETIEN(XQNAME) ;get IEN for an option; 457 - ;; XQNAME is name of an option - ;; Retrun XQIEN: Null or IEN if existed - N XQIEN S XQIEN="" - I $G(XQNAME)="" Q XQIEN - I '$D(^DIC(19,"B",XQNAME)) Q XQIEN - S XQIEN=$O(^DIC(19,"B",XQNAME,XQIEN)) - Q XQIEN - ; -CHKTOPL(XQIEN,XQDUZ) ;Check Lock for the top level of the secondary options - ;this need to be called to check the top level first when check the - ;Locks for lower menu option because the 6th piece of ^XUTL does not - ;contain the IEN of the top menu option. - N XQRT,XQK S XQRT=0 - I XQIEN'=+$G(XQIEN) Q XQRT - S XQK=$$GET1^DIQ(19,XQIEN,3) - I $G(XQK)'="",'$D(^XUSEC(XQK,XQDUZ)) S XQRT=1_"^"_XQK - Q XQRT - ; -CHKTOPRL(XQIEN,XQDUZ) ;Check Reversed Lock the top level of the secondary options - ;this need to be called to check the top level first when check the - ;Reversed Locks for lower menu option because the 6th piece of ^XUTL does not - ;contain the IEN of the top menu option. - N XQRT,XQK S XQRT=0 - I XQIEN'=+$G(XQIEN) Q XQRT - S XQK=$$GET1^DIQ(19,XQIEN,3.01) - I $G(XQK)'="",$D(^XUSEC(XQK,XQDUZ)) S XQRT=1_"^"_XQK - Q XQRT +XQCHK2 ; BP/BDT - GET CALL FROM XQCHK ; [7/19/06 10:45am] + ;;8.0;KERNEL;**427**;Jul 10, 1995;Build 3 + ; Entry point for checking all Locks for a option +CHCKL(XQCY0,DUZ) ; + N XQI,XQY,XQX,XQRT,XQK S (XQRT,XQX)=0 + S XQY=$P(XQCY0,"^",5) + F XQI=1:1 S XQX=$P(XQY,",",XQI) Q:'XQX D + . I +XQX S XQK=$$GET1^DIQ(19,XQX,3) I XQK'="",'$D(^XUSEC(XQK,DUZ)) S XQRT=1_"^"_XQK Q + Q XQRT + ; Entry point for checking all Reversed Locks for a option +CHCKRL(XQCY0,DUZ) ; + N XQI,XQY,XQX,XQRT,XQK S (XQRT,XQX)=0 + S XQY=$P(XQCY0,"^",5) + F XQI=1:1 S XQX=$P(XQY,",",XQI) Q:'XQX D + . I +XQX S XQK=$$GET1^DIQ(19,XQX,3.01) I XQK'="",$D(^XUSEC(XQK,DUZ)) S XQRT=1_"^"_XQK Q + Q XQRT diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQOR.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQOR.m index 05b8cfd0..4e7cc7e9 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQOR.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQOR.m @@ -1,65 +1,65 @@ -XQOR ; SLC/KCM - Prepare to Unwind Options ;4/3/07 16:21 - ;;8.0;KERNEL;**48,56,437**;Jul 10, 1995;Build 23 - ; 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 - S DIC=19,DIC(0)="AEMQ" D ^DIC K DIC Q:Y<0 S X=+Y_";DIC(19," -EN ;Process options/protocols from top - ;From: Anywhere Entry: X,{DIC,XQORFLG} Exit: none - Q:$D(X)[0 K XQORPOP,XQORQUIT - I '$D(XQORS) S XQORS=0 K ^TMP("XQORS",$J) - S XQORS=XQORS+1 ;push - I $D(XQOR("HIJACK")) S X=XQOR("HIJACK"),DIC=101 K XQOR("HIJACK") - I X?1.N1";ORD(101,"!(X?1.N1";DIC(19,") S ^TMP("XQORS",$J,XQORS,"REF")="^"_$P(X,";",2)_+X_",",^TMP("XQORS",$J,XQORS,"VPT")=X - E S:$D(DIC)[0 DIC=19 S DIC(0)="N" D ^DIC S:Y>0 ^TMP("XQORS",$J,XQORS,"REF")=DIC_+Y_",",^TMP("XQORS",$J,XQORS,"VPT")=+Y_";"_$P(DIC,"^",2) K DIC G:Y<0 EX - S XQORNEST(XQORS)=^TMP("XQORS",$J,XQORS,"VPT"),XQORNEST=XQORS - G:'$D(@(^TMP("XQORS",$J,XQORS,"REF")_"0)")) EX S ^TMP("XQORS",$J,XQORS,"FLG")=$P(^(0),"^",4)_"^^" G:$P(^TMP("XQORS",$J,XQORS,"FLG"),"^")'?1A EX - ; LOCAL MOD VWSD SILENTMODE ECHO SDAM EVENTS (VARIABLE XQORMUTE) - I $L($P(@(^TMP("XQORS",$J,XQORS,"REF")_"0)"),"^",3)) W:'$D(ZTSK)&'$D(XQORMUTE) !!,$P(^(0),"^",3),! D:'$D(ZTSK)&'$D(XQORMUTE) READ^XQOR4 G EX - ;I $L($P(@(^TMP("XQORS",$J,XQORS,"REF")_"0)"),"^",3)) W !!,$P(^(0),"^",3),! D READ^XQOR4 G EX - ;END LOCAL MODE - D C19^XQOR4 G:Y<0 EX - S ^TMP("XQORS",$J,0,"FILE")=";"_$P(^TMP("XQORS",$J,XQORS,"VPT"),";",2),^TMP("XQORS",$J,XQORS,"INP")="" - I XQORS>1,$D(^TMP("XQORS",$J,XQORS-1,"ITM")),$D(^TMP("XQORS",$J,XQORS-1,"ITM",^TMP("XQORS",$J,XQORS-1,"ITM"),"IN")) S ^TMP("XQORS",$J,XQORS,"INP")=^TMP("XQORS",$J,XQORS-1,"ITM",^TMP("XQORS",$J,XQORS-1,"ITM"),"IN") - I XQORS>1,$D(XQORFLG("PI")) K XQORFLG("PI") S ^TMP("XQORS",$J,XQORS,"INP")=^TMP("XQORS",$J,XQORS-1,"INP") - S XQORNOD=^TMP("XQORS",$J,XQORS,"VPT"),XQORNOD(0)=^TMP("XQORS",$J,XQORS,"INP") - I XQORS>1,$D(^TMP("XQORS",$J,XQORS-1,"FLG")) S X=^TMP("XQORS",$J,XQORS-1,"FLG"),$P(^TMP("XQORS",$J,XQORS,"FLG"),"^",3)=$S($L($P(X,"^",5)):$P(X,"^",5),1:$P(X,"^",3)) - I ^TMP("XQORS",$J,0,"FILE")=";ORD(101,",$D(@(^TMP("XQORS",$J,XQORS,"REF")_"4)")) S:$P(^(4),"^",3)="Y" $P(^TMP("XQORS",$J,XQORS,"FLG"),"^",2)=1 - I ^TMP("XQORS",$J,0,"FILE")=";DIC(19,",$P(^TMP("XQORS",$J,XQORS,"FLG"),"^")="M" S $P(^TMP("XQORS",$J,XQORS,"FLG"),"^",2)=1 - I $D(XQORFLG) S:$D(XQORFLG("PS")) $P(^TMP("XQORS",$J,XQORS,"FLG"),"^",2)=+XQORFLG("PS") S:$D(XQORFLG("SH")) $P(^TMP("XQORS",$J,XQORS,"FLG"),"^",3)=+XQORFLG("SH") K XQORFLG - I $D(ORITMO) S $P(^TMP("XQORS",$J,XQORS,"FLG"),"^",6)=1 K ORITMO G REDO^XQOR1 - I $P(^TMP("XQORS",$J,XQORS,"FLG"),"^")="D" N XQORDLG - G LOOP^XQOR1 -EX K XQORNEST(XQORS),XQORFLG,XQORNOD,XQORY,^TMP("XQORS",$J,XQORS) S XQORS=XQORS-1,XQORNEST=XQORS ;pop - I XQORS=0 K XQORNEST,XQORS,^TMP("XQORS",$J),XQORSPEW - Q -EN1 ;Process items on option/protocol only (i.e., skip initial actions) - ;From: Anywhere Entry: X,DIC Exit: none - S ORITMO=1 G EN - Q -XQ ;From: Menuman Entry: XQOR Exit: XQOR - S X=+XQOR_";DIC(19," I $D(^DD(19,0,"VR")),^("VR")<5.9 G EN - G EN1 -MSG(X,XQORMSG) ;Event point for HL7 messages - N DIC S DIC=101 - I '$D(XQORHSTK) N XQORHSTK S XQORHSTK=-1 K ^TMP("XQORHSTK",$J) - S XQORHSTK=XQORHSTK+1 - K ^TMP("XQORHSTK",$J,XQORHSTK) M ^TMP("XQORHSTK",$J,XQORHSTK)=XQORMSG - D EN^XQOR - S XQORHSTK=XQORHSTK-1 - I XQORHSTK>-1 K XQORMSG M XQORMSG=^TMP("XQORHSTK",$J,XQORHSTK) - I XQORHSTK=-1 K ^TMP("XQORHSTK",$J) - Q +XQOR ; SLC/KCM - Prepare to Unwind Options ;4/3/07 16:21 + ;;8.0;KERNEL;**48,56,437**;Jul 10, 1995;Build 22 + ; 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 + S DIC=19,DIC(0)="AEMQ" D ^DIC K DIC Q:Y<0 S X=+Y_";DIC(19," +EN ;Process options/protocols from top + ;From: Anywhere Entry: X,{DIC,XQORFLG} Exit: none + Q:$D(X)[0 K XQORPOP,XQORQUIT + I '$D(XQORS) S XQORS=0 K ^TMP("XQORS",$J) + S XQORS=XQORS+1 ;push + I $D(XQOR("HIJACK")) S X=XQOR("HIJACK"),DIC=101 K XQOR("HIJACK") + I X?1.N1";ORD(101,"!(X?1.N1";DIC(19,") S ^TMP("XQORS",$J,XQORS,"REF")="^"_$P(X,";",2)_+X_",",^TMP("XQORS",$J,XQORS,"VPT")=X + E S:$D(DIC)[0 DIC=19 S DIC(0)="N" D ^DIC S:Y>0 ^TMP("XQORS",$J,XQORS,"REF")=DIC_+Y_",",^TMP("XQORS",$J,XQORS,"VPT")=+Y_";"_$P(DIC,"^",2) K DIC G:Y<0 EX + S XQORNEST(XQORS)=^TMP("XQORS",$J,XQORS,"VPT"),XQORNEST=XQORS + G:'$D(@(^TMP("XQORS",$J,XQORS,"REF")_"0)")) EX S ^TMP("XQORS",$J,XQORS,"FLG")=$P(^(0),"^",4)_"^^" G:$P(^TMP("XQORS",$J,XQORS,"FLG"),"^")'?1A EX + ; LOCAL MOD VWSD SILENTMODE ECHO SDAM EVENTS (VARIABLE XQORMUTE) + I $L($P(@(^TMP("XQORS",$J,XQORS,"REF")_"0)"),"^",3)) W:'$D(ZTSK)&'$D(XQORMUTE) !!,$P(^(0),"^",3),! D:'$D(ZTSK)&'$D(XQORMUTE) READ^XQOR4 G EX + ;I $L($P(@(^TMP("XQORS",$J,XQORS,"REF")_"0)"),"^",3)) W !!,$P(^(0),"^",3),! D READ^XQOR4 G EX + ;END LOCAL MODE + D C19^XQOR4 G:Y<0 EX + S ^TMP("XQORS",$J,0,"FILE")=";"_$P(^TMP("XQORS",$J,XQORS,"VPT"),";",2),^TMP("XQORS",$J,XQORS,"INP")="" + I XQORS>1,$D(^TMP("XQORS",$J,XQORS-1,"ITM")),$D(^TMP("XQORS",$J,XQORS-1,"ITM",^TMP("XQORS",$J,XQORS-1,"ITM"),"IN")) S ^TMP("XQORS",$J,XQORS,"INP")=^TMP("XQORS",$J,XQORS-1,"ITM",^TMP("XQORS",$J,XQORS-1,"ITM"),"IN") + I XQORS>1,$D(XQORFLG("PI")) K XQORFLG("PI") S ^TMP("XQORS",$J,XQORS,"INP")=^TMP("XQORS",$J,XQORS-1,"INP") + S XQORNOD=^TMP("XQORS",$J,XQORS,"VPT"),XQORNOD(0)=^TMP("XQORS",$J,XQORS,"INP") + I XQORS>1,$D(^TMP("XQORS",$J,XQORS-1,"FLG")) S X=^TMP("XQORS",$J,XQORS-1,"FLG"),$P(^TMP("XQORS",$J,XQORS,"FLG"),"^",3)=$S($L($P(X,"^",5)):$P(X,"^",5),1:$P(X,"^",3)) + I ^TMP("XQORS",$J,0,"FILE")=";ORD(101,",$D(@(^TMP("XQORS",$J,XQORS,"REF")_"4)")) S:$P(^(4),"^",3)="Y" $P(^TMP("XQORS",$J,XQORS,"FLG"),"^",2)=1 + I ^TMP("XQORS",$J,0,"FILE")=";DIC(19,",$P(^TMP("XQORS",$J,XQORS,"FLG"),"^")="M" S $P(^TMP("XQORS",$J,XQORS,"FLG"),"^",2)=1 + I $D(XQORFLG) S:$D(XQORFLG("PS")) $P(^TMP("XQORS",$J,XQORS,"FLG"),"^",2)=+XQORFLG("PS") S:$D(XQORFLG("SH")) $P(^TMP("XQORS",$J,XQORS,"FLG"),"^",3)=+XQORFLG("SH") K XQORFLG + I $D(ORITMO) S $P(^TMP("XQORS",$J,XQORS,"FLG"),"^",6)=1 K ORITMO G REDO^XQOR1 + I $P(^TMP("XQORS",$J,XQORS,"FLG"),"^")="D" N XQORDLG + G LOOP^XQOR1 +EX K XQORNEST(XQORS),XQORFLG,XQORNOD,XQORY,^TMP("XQORS",$J,XQORS) S XQORS=XQORS-1,XQORNEST=XQORS ;pop + I XQORS=0 K XQORNEST,XQORS,^TMP("XQORS",$J),XQORSPEW + Q +EN1 ;Process items on option/protocol only (i.e., skip initial actions) + ;From: Anywhere Entry: X,DIC Exit: none + S ORITMO=1 G EN + Q +XQ ;From: Menuman Entry: XQOR Exit: XQOR + S X=+XQOR_";DIC(19," I $D(^DD(19,0,"VR")),^("VR")<5.9 G EN + G EN1 +MSG(X,XQORMSG) ;Event point for HL7 messages + N DIC S DIC=101 + I '$D(XQORHSTK) N XQORHSTK S XQORHSTK=-1 K ^TMP("XQORHSTK",$J) + S XQORHSTK=XQORHSTK+1 + K ^TMP("XQORHSTK",$J,XQORHSTK) M ^TMP("XQORHSTK",$J,XQORHSTK)=XQORMSG + D EN^XQOR + S XQORHSTK=XQORHSTK-1 + I XQORHSTK>-1 K XQORMSG M XQORMSG=^TMP("XQORHSTK",$J,XQORHSTK) + I XQORHSTK=-1 K ^TMP("XQORHSTK",$J) + Q diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQOR4.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQOR4.m index b28c863f..15a8adce 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQOR4.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQOR4.m @@ -1,47 +1,47 @@ -XQOR4 ; SLC/KCM - Process "^^" jump ;1/23/07 15:36 - ;;8.0;KERNEL;**56,62,437**;Jul 10, 1995;Build 23 - ; 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 -DJMP ;From: STAK^XQOR1 - Q:'$D(^TMP("XQORS",$J,XQORS,"ITM",^TMP("XQORS",$J,XQORS,"ITM"),"IN")) - I $D(VALMCC) N XQORLMGR S XQORLMGR="" D FULL^VALM1 ; List Mgr Running? - S X=^TMP("XQORS",$J,XQORS,"ITM",^TMP("XQORS",$J,XQORS,"ITM"),"IN") - I '$L($P(X,"^",3)) W !!,"For entry ""^^",$P(X,"^",4),""" -" - S X=$P(X,"^",4,99) D EAT^XQORM1 ;Q:$E(X,1,2)'="^^" - S X=$P(X,"=",1),D="K.ORWARD",DIC="^ORD(101,",DIC(0)="SE" D IX^DIC K DIC,D - I Y<0!('$D(^ORD(101,+Y,0))) W:(X'["^")&(X'["?") !!,">>> ",X," not found or selected. No action taken." D:(X'["^")&(X'["?") READ S X="" G DJMPX - S ORNSV=+Y - K X F I=1:1:XQORS I $P(^TMP("XQORS",$J,XQORS,"VPT"),";",2)="ORD(101,",$D(^ORD(101,+^TMP("XQORS",$J,XQORS,"VPT"),21)) D DJMP1 - S X="" F I=0:0 S X=$O(X(X)) Q:X="" N @X - S X=ORNSV_";ORD(101," K ORNSV - D EN^XQOR -DJMPX I $D(XQORLMGR) S VALMBCK="R" ; Refresh List Mgr - Q -DJMP1 F J=0:0 S J=$O(^ORD(101,+^TMP("XQORS",$J,XQORS,"VPT"),21,J)) Q:J'>0 I $D(^ORD(101,+^TMP("XQORS",$J,XQORS,"VPT"),21,J,0)) S X=^(0) I X?1A.ANP!(X?1"%".ANP) S X(X)="" - Q -SHDR ;Display sub-header - Q:'$D(@(^TMP("XQORS",$J,XQORS,"REF")_"0)")) S X=$P(^(0),"^",2) W:X'?1." " !!?(36-($L(X)\2)),"--- "_X_" ---" - Q - ;VWSD LOCAL MOD STARTED HERE, XQ SILENT MODE . VARIABLE XQORMUTE -READ I '$D(XQORMUTE) W !,"Press RETURN to continue: " R X:$S($D(DTIME):DTIME,1:300) - ;READ W !,"Press RETURN to continue: " R X:$S($D(DTIME):DTIME,1:300) - ;END LOCAL MOD - Q -C19 N X0 S X0=@(^TMP("XQORS",$J,XQORS,"REF")_"0)"),X=$P(X0,"^",6) I $L(X),'$D(^XUSEC(X,DUZ)) W !!,"This option "_$P(X0,"^")_" is locked.",! D READ S Y=-1 Q - S ORNSV=$P(X0,"^",9),X="NOW",%DT="T" D ^%DT S X=$P(Y,".",2) I X>$P(ORNSV,"-"),X<$P(ORNSV,"-",2) W !!,"Not Available: ",ORNSV,! K ORNSV D READ S Y=-1 Q - K ORNSV I "QMOXALDT"'[$P(^TMP("XQORS",$J,XQORS,"FLG"),"^") W !!,"This option type not supported by 'unwinder' routines.",! D READ S Y=-1 Q - S Y=1 Q +XQOR4 ; SLC/KCM - Process "^^" jump ;1/23/07 15:36 + ;;8.0;KERNEL;**56,62,437**;Jul 10, 1995;Build 22 + ; 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 +DJMP ;From: STAK^XQOR1 + Q:'$D(^TMP("XQORS",$J,XQORS,"ITM",^TMP("XQORS",$J,XQORS,"ITM"),"IN")) + I $D(VALMCC) N XQORLMGR S XQORLMGR="" D FULL^VALM1 ; List Mgr Running? + S X=^TMP("XQORS",$J,XQORS,"ITM",^TMP("XQORS",$J,XQORS,"ITM"),"IN") + I '$L($P(X,"^",3)) W !!,"For entry ""^^",$P(X,"^",4),""" -" + S X=$P(X,"^",4,99) D EAT^XQORM1 ;Q:$E(X,1,2)'="^^" + S X=$P(X,"=",1),D="K.ORWARD",DIC="^ORD(101,",DIC(0)="SE" D IX^DIC K DIC,D + I Y<0!('$D(^ORD(101,+Y,0))) W:(X'["^")&(X'["?") !!,">>> ",X," not found or selected. No action taken." D:(X'["^")&(X'["?") READ S X="" G DJMPX + S ORNSV=+Y + K X F I=1:1:XQORS I $P(^TMP("XQORS",$J,XQORS,"VPT"),";",2)="ORD(101,",$D(^ORD(101,+^TMP("XQORS",$J,XQORS,"VPT"),21)) D DJMP1 + S X="" F I=0:0 S X=$O(X(X)) Q:X="" N @X + S X=ORNSV_";ORD(101," K ORNSV + D EN^XQOR +DJMPX I $D(XQORLMGR) S VALMBCK="R" ; Refresh List Mgr + Q +DJMP1 F J=0:0 S J=$O(^ORD(101,+^TMP("XQORS",$J,XQORS,"VPT"),21,J)) Q:J'>0 I $D(^ORD(101,+^TMP("XQORS",$J,XQORS,"VPT"),21,J,0)) S X=^(0) I X?1A.ANP!(X?1"%".ANP) S X(X)="" + Q +SHDR ;Display sub-header + Q:'$D(@(^TMP("XQORS",$J,XQORS,"REF")_"0)")) S X=$P(^(0),"^",2) W:X'?1." " !!?(36-($L(X)\2)),"--- "_X_" ---" + Q + ;VWSD LOCAL MOD STARTED HERE, XQ SILENT MODE . VARIABLE XQORMUTE +READ I '$D(XQORMUTE) W !,"Press RETURN to continue: " R X:$S($D(DTIME):DTIME,1:300) + ;READ W !,"Press RETURN to continue: " R X:$S($D(DTIME):DTIME,1:300) + ;END LOCAL MOD + Q +C19 N X0 S X0=@(^TMP("XQORS",$J,XQORS,"REF")_"0)"),X=$P(X0,"^",6) I $L(X),'$D(^XUSEC(X,DUZ)) W !!,"This option "_$P(X0,"^")_" is locked.",! D READ S Y=-1 Q + S ORNSV=$P(X0,"^",9),X="NOW",%DT="T" D ^%DT S X=$P(Y,".",2) I X>$P(ORNSV,"-"),X<$P(ORNSV,"-",2) W !!,"Not Available: ",ORNSV,! K ORNSV D READ S Y=-1 Q + K ORNSV I "QMOXALDT"'[$P(^TMP("XQORS",$J,XQORS,"FLG"),"^") W !!,"This option type not supported by 'unwinder' routines.",! D READ S Y=-1 Q + S Y=1 Q diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUP.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUP.m index f5800245..4b7e3fed 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUP.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUP.m @@ -1,72 +1,62 @@ -XUP ;SFISC/RWF - Setup enviroment for programmers ;10/12/06 12:45 - ;;8.0;KERNEL;**208,258,284,432**;Jul 10, 1995;Build 3 - W !,"Setting up programmer environment" - S U="^",$ECODE="",$ETRAP="" ;Clear error and error trap - X ^%ZOSF("TYPE-AHEAD") - ;Check if Production and report - W !,"This is a "_$S($$PROD^XUPROD(1):"PRODUCTION",1:"TEST")_" account.",! - ; - K ^UTILITY($J),^XUTL("XQ",$J) D KILL1^XUSCLEAN - S U="^",DT=$$DT^XLFDT - S XUEOFF=^%ZOSF("EOFF"),XUEON=^%ZOSF("EON"),U="^",XUTT=0,XUIOP="" - D GETENV^%ZOSV S XUENV=Y,XUVOL=$P(Y,U,2),XUCI=$P(Y,U,1) - ;Reset DUZ if user "Switched Identities". - I $D(DUZ("SAV")) S DUZ=+DUZ("SAV"),DUZ(0)=$P(DUZ("SAV"),U,2) K DUZ("SAV") - ;Get user info - I $G(DUZ)>.5,$D(^VA(200,DUZ,0))[0 K DUZ W !,"DUZ Must point to a real user." G EXIT ;p432 - I $G(DUZ)>0 D DUZ(DUZ) - I $G(DUZ)'>0!('$D(DUZ(0))) D ASKDUZ G:Y'>0 EXIT - I '$D(XQUSER) S XQUSER=$S($D(^VA(200,DUZ,20)):$P(^(20),"^",2),1:"Unk") - S DTIME=600 ;Set a temp DTIME - S DILOCKTM=+$G(^DD("DILOCKTM"),1) ;p432 - ;Getting Terminal Type -ZIS I XUTT D ENQ^XUS1 G:$D(XUIOP(1)) ZIS2 S Y=0 D TT^XUS3 I Y>0 S XUIOP(1)=$P(XUIOP,";",2) G ZIS2 - S X="`"_+$G(^VA(200,DUZ,1.2)),DIC="^%ZIS(2,",DIC(0)="MQ"_$S(X]"`0":"",1:"AE") D ^DIC G:Y'>0 EXIT - S XUIOP(1)=$P(Y,U,2) I DIC(0)["A",$G(^VA(200,+DUZ,0))]"" S $P(^VA(200,DUZ,1.2),U,1)=+Y -ZIS2 S %ZIS="L",IOP="HOME;"_XUIOP(1) D ^%ZIS G EXIT:POP W !,"Terminal Type set to: ",IOST,! - S DTIME=$$DTIME(DUZ,IOS),DUZ("BUF")=1,XUDEV=IOS - ;Save info, Set last sign-on - D SAVE^XUS1 S $P(^VA(200,DUZ,1.1),"^",1)=$$NOW^XLFDT - ;Check Mail - S Y=$P($G(^XMB(3.7,DUZ,0)),U,6) I Y W !,"You have "_Y_" new message"_$S(Y=1:"",1:"s")_"." - ;Setup error trap - I $$GET^XPAR("USR^SYS","XUS-XUP SET ERROR TRAP",1,"Q") S $ETRAP="D ERR^XUP" - D KILL1^XUSCLEAN S $P(XQXFLG,U,3)="XUP" D ^XQ1 -EXIT ;Clean-up and exit - D KILL1^XUSCLEAN K XQY,XQY0 - I $G(DUZ)>0,$$GET^XPAR("USR^SYS","XUS-XUP VPE",1,"Q"),$D(^%ZVEMS) X ^%ZVEMS ;Run VPE - Q - ; -ASKDUZ ;Ask for Access Code - N X - ;X XUEOFF S DIR(0)="FO",DIR("A")="Access Code" D ^DIR W ! X XUEON I $D(DIRUT) S Y=-1 Q - X XUEOFF W !,"Access Code: " S X=$$ACCEPT^XUS() X XUEON - I X["^"!('$L(X)) S Y=-1 Q - S X=$$UP^XLFSTR(X) S:X[":" XUTT=1,X=$P(X,":",1)_$P(X,":",2) - D ^XUSHSH S Y=$O(^VA(200,"A",X,0)) - K DUZ D DUZ(+Y) - Q - ; -DUZ(DA) ;Build DUZ for a user. Used by Mailman. - ;(p284) Make the setting of several DUZ parts conditional. - N Y - S Y(0)=$G(^VA(200,+DA,0)),Y("XUS")=$G(^XTV(8989.3,1,"XUS")) - S DUZ=DA - S:$G(DUZ(0))'="@" DUZ(0)=$P(Y(0),"^",4) - S DUZ(1)="",DUZ("AG")=$P($G(^XTV(8989.3,1,0)),"^",8) - S:'$G(DUZ(2)) DUZ(2)=$O(^VA(200,DUZ,2,0)) - S:'DUZ(2) DUZ(2)=+$P(Y("XUS"),"^",17) - S:'$L($G(DUZ("LANG"))) DUZ("LANG")=$P(Y("XUS"),"^",7) - Q - ; -DTIME(E,D) ;Return DTIME value for user E, device D. - N P - S P=$P($G(^VA(200,+$G(E),200)),"^",10) S:P="" P=$P($G(^%ZIS(1,+$G(D),"XUS")),"^",10) S:P="" P=$P($G(^XTV(8989.3,1,"XUS")),"^",10) - Q $S(P]"":P,1:300) - ; -ERR ; - N %XUP U $P - W !,"$ECODE=",$ECODE," $STACK=",$STACK - W !,"Location: ",$STACK($STACK-1,"PLACE") - R !!,"Want to record the error: No// ",%XUP:600 I "Yy"[$E(%XUP_"N") D ^%ZTER - D UNWIND^%ZTER ;S:'$ESTACK $ECODE="" S $ETRAP="" Q:$QUIT "" Q +XUP ;SFISC/RWF - Setup enviroment for programmers ;09/21/2004 16:35 + ;;8.0;KERNEL;**208,258,284**;Jul 10, 1995 + W !,"Setting up programmer environment" + N $ESTACK,$ETRAP S $ECODE="",$ETRAP="" ;Clear and error trap + X ^%ZOSF("TYPE-AHEAD") + ;Check if Production and report + W !,"This is a "_$S($$PROD^XUPROD(1):"PRODUCTION",1:"TEST")_" account.",! + ; + K ^UTILITY($J),^XUTL("XQ",$J) D KILL1^XUSCLEAN + S U="^",DT=$$DT^XLFDT + S XUEOFF=^%ZOSF("EOFF"),XUEON=^%ZOSF("EON"),U="^",XUTT=0,XUIOP="" + D GETENV^%ZOSV S XUENV=Y,XUVOL=$P(Y,U,2),XUCI=$P(Y,U,1) + ;Reset DUZ if user "Switched Identities". + I $D(DUZ("SAV")) S DUZ=+DUZ("SAV"),DUZ(0)=$P(DUZ("SAV"),U,2) K DUZ("SAV") + ;Get user info + I $G(DUZ)>0 D DUZ(DUZ) + I $G(DUZ)'>0!('$D(DUZ(0))) D ASKDUZ G:Y'>0 EXIT + I '$D(XQUSER) S XQUSER=$S($D(^VA(200,DUZ,20)):$P(^(20),"^",2),1:"Unk") + S DTIME=600 ;Set a temp DTIME + ;Getting Terminal Type +ZIS I XUTT D ENQ^XUS1 G:$D(XUIOP(1)) ZIS2 S Y=0 D TT^XUS3 I Y>0 S XUIOP(1)=$P(XUIOP,";",2) G ZIS2 + S X="`"_+$G(^VA(200,DUZ,1.2)),DIC="^%ZIS(2,",DIC(0)="MQ"_$S(X]"`0":"",1:"AE") D ^DIC G:Y'>0 EXIT + S XUIOP(1)=$P(Y,U,2) I DIC(0)["A",$G(^VA(200,+DUZ,0))]"" S $P(^VA(200,DUZ,1.2),U,1)=+Y +ZIS2 S %ZIS="L",IOP="HOME;"_XUIOP(1) D ^%ZIS G EXIT:POP W !,"Terminal Type set to: ",IOST,! + S DTIME=$$DTIME(DUZ,IOS),DUZ("BUF")=1,XUDEV=IOS + ;Save info, Set last sign-on + D SAVE^XUS1 S $P(^VA(200,DUZ,1.1),"^",1)=$$NOW^XLFDT + ;Check Mail + S Y=$P($G(^XMB(3.7,DUZ,0)),U,6) I Y W !,"You have "_Y_" new message"_$S(Y=1:"",1:"s")_"." + ;Setup error trap + I $$GET^XPAR("USR^SYS","XUS-XUP SET ERROR TRAP",1,"Q") S $ETRAP="D ERR^XUP" + D KILL1^XUSCLEAN S $P(XQXFLG,U,3)="XUP" D ^XQ1 +EXIT D KILL1^XUSCLEAN K XQY,XQY0 + I $$GET^XPAR("USR^SYS","XUS-XUP VPE",1,"Q"),$D(^%ZVEMS) X ^%ZVEMS ;Run VPE + Q + ; +ASKDUZ X XUEOFF S DIR(0)="FO",DIR("A")="Access Code" D ^DIR W ! X XUEON I $D(DIRUT) S Y=-1 Q + S X=$$UP^XLFSTR(X) S:X[":" XUTT=1,X=$P(X,":",1)_$P(X,":",2) + D ^XUSHSH S Y=$O(^VA(200,"A",X,0)) + K DUZ D DUZ(+Y) Q + ; +DUZ(DA) ;Build DUZ for a user. Used by Mailman. + ;(p284) Make the setting of several DUZ parts conditional. + N Y S Y(0)=$G(^VA(200,+DA,0)),Y("XUS")=$G(^XTV(8989.3,1,"XUS")) + S DUZ=DA + S:$G(DUZ(0))'="@" DUZ(0)=$P(Y(0),"^",4) + S DUZ(1)="",DUZ("AG")=$P($G(^XTV(8989.3,1,0)),"^",8) + S:'$G(DUZ(2)) DUZ(2)=$O(^VA(200,DUZ,2,0)) + S:'DUZ(2) DUZ(2)=+$P(Y("XUS"),U,17) + S:'$L($G(DUZ("LANG"))) DUZ("LANG")=$P(Y("XUS"),U,7) + Q + ; +DTIME(E,D) ;Return DTIME value for user E, device D. + N P S P=$P($G(^VA(200,+$G(E),200)),"^",10) S:P="" P=$P($G(^%ZIS(1,+$G(D),"XUS")),"^",10) S:P="" P=$P($G(^XTV(8989.3,1,"XUS")),"^",10) + Q $S(P]"":P,1:300) + ; +ERR ; + U $P + W !,"$ECODE=",$ECODE," $STACK=",$STACK + R !!,"Want to record the error: No// ",%XUP:600 I "Yy"[$E(%XUP_"N") D ^%ZTER + D UNWIND^%ZTER ;S:'$ESTACK $ECODE="" S $ETRAP="" Q:$QUIT "" Q + ; diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUPROD.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUPROD.m index 082e667c..1a2a9b2e 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUPROD.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUPROD.m @@ -1,52 +1,43 @@ -XUPROD ;ISF/RWF - Is this a PROD account. ;8/23/07 16:47 - ;;8.0;KERNEL;**284,440**;Jul 10, 1995;Build 13 - ; - ;IA# 4440 -PROD(FORCE) ;Return 1 if this is a production account - ;A non-zero flag will force a real check - ;This call just checks a flag in the KSP, Other code will compair - ;with registered ID. - N LC,SID - S SID=$G(^XTV(8989.3,1,"SID")) - I '$L($P(SID,"^",3))!($P(SID,"^",3)'=$G(DT))!$G(FORCE) D - . D CHECK S SID=$G(^XTV(8989.3,1,"SID")) - Q +$P(SID,"^",1) - ; -CHECK ;Check if SID matched stored value, Set field 501 - N CSID,SSID,FDA - L +^XTV(8989.3,1,"SID"):2 - S CSID=$$SID^%ZOSV,SSID=$P($G(^XTV(8989.3,1,"SID")),"^",2) - S FDA(8989.3,"1,",501)=(CSID=SSID),FDA(8989.3,"1,",503)=$$DT^XLFDT - D FILE^DIE("","FDA") - L -^XTV(8989.3,1,"SID") - Q - ; -SSID(SID) ;Set the SID into KSP. - N FDA - S FDA(8989.3,"1,",502)=SID,FDA(8989.3,"1,",503)="@" - L +^XTV(8989.3,1,"SID"):2 - D FILE^DIE("","FDA") - L -^XTV(8989.3,1,"SID") - Q -ASK ;Ask user if this is prod. - N DIR,P S P=$$PROD - S DIR(0)="YO",DIR("A")="Is this a Production Account",DIR("B")="No" - S DIR("A",1)="" - S DIR("A",2)="This is now a "_$S(P:"PRODUCTION",1:"TEST")_" account." - S DIR("A",3)=" " - S DIR("A",4)="Only answer YES if this is the full time Production Account." - S DIR("A",5)="Answer No for all other accounts." - D ^DIR Q:$D(DIRUT) - I Y=1 D SSID($$SID^%ZOSV) - E D SSID("2~TEST~999") - S P=$$PROD - W:P !!,"This is now a PRODUCTION account.",! W:'P !!,"This is now a TEST account.",! - Q - ; -EDIT ;Edit Logical - Physical fields - N DIE,DA,DR - W !!,"This is only valid in a Cache v5.2 client/server configuration." - W !,"This lets you edit the fields that support the" - W !,"LOGICAL to PHYSICAL translation for the System ID.",!! - S DA=1,DIE="^XTV(8989.3,",DR="504;505" D ^DIE - Q +XUPROD ;ISF/RWF - Is this a PROD account. ;06/17/2004 08:13 + ;;8.0;KERNEL;**284**;Jul 10, 1995 + ; + ;IA# 4440 +PROD(FORCE) ;Return 1 if this is a production account + ;A non-zero flag will force a real check + ;This call just checks a flag in the KSP, Other code will compair + ;with registered ID. + N LC,SID + S SID=$G(^XTV(8989.3,1,"SID")) + I '$L($P(SID,"^",3))!($P(SID,"^",3)'=$G(DT))!$G(FORCE) D + . D CHECK S SID=$G(^XTV(8989.3,1,"SID")) + Q +$P(SID,"^",1) + ; +CHECK ;Check if SID matched stored value, Set field 501 + N CSID,SSID,FDA + L +^XTV(8989.3,1,"SID"):2 + S CSID=$$SID^%ZOSV,SSID=$P($G(^XTV(8989.3,1,"SID")),"^",2) + S FDA(8989.3,"1,",501)=(CSID=SSID),FDA(8989.3,"1,",503)=$$DT^XLFDT + D FILE^DIE("","FDA") + L -^XTV(8989.3,1,"SID") + Q + ; +SSID(SID) ;Set the SID into KSP. + N FDA + S FDA(8989.3,"1,",502)=SID,FDA(8989.3,"1,",503)="@" + L +^XTV(8989.3,1,"SID"):2 + D FILE^DIE("","FDA") + L -^XTV(8989.3,1,"SID") + Q +ASK ;Ask user if this is prod. + N DIR,P S P=$$PROD + S DIR(0)="YO",DIR("A")="Is this a Production Account",DIR("B")="No" + S DIR("A",1)="This is now a "_$S(P:"PRODUCTION",1:"TEST")_" account." + S DIR("A",2)=" " + S DIR("A",3)="Only answer YES if this is the full time Production Account." + S DIR("A",4)="Answer No for all other accounts." + D ^DIR Q:$D(DIRUT) + I Y=1 D SSID($$SID^%ZOSV) + E D SSID("2~TEST~999") + S P=$$PROD + W:P !!,"This is now a PRODUCTION account.",! W:'P !!,"This is now a TEST account.",! + Q diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUS.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUS.m index f34a7e48..63740b62 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUS.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUS.m @@ -1,179 +1,174 @@ -XUS ;SFISC/STAFF - SIGNON ;1:27 PM 11 Dec 2008 - ;;8.0;KERNEL;**16,26,49,59,149,180,265,337,419,434,437**;Jul 10, 1995;Build 23 - ; 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 - ; - ;Sign-on message numbers are 30810.51 to 30810.99 - S U="^" D INTRO^XUS1A() - K K ^XUTL("ZISPARAM",$I) - S U="^",XQXFLG("GUI")="^" - W ! S $Y=0 D SET1(1) I POP S XUM=3 G NO ;Sets DUZ("LANG") - S XUSTMP(51)=$$EZBLD^DIALOG(30810.51),XUSTMP(52)=$$EZBLD^DIALOG(30810.52) - W !!,"Volume set: ",$P(XUENV,U,4)," UCI: ",XUCI," Device: ",$I W:$S('$D(IO("ZIO")):0,1:$I'=IO("ZIO")) " (",IO("ZIO"),")" W ! -RESTART ; - S XUM=$$SET2 G:XUM NO - I $P(XU1,U,2)]"" S XUM=$$DEVPAS() I XUM G H:XUM<0,NO - ;S PGM=$P(XOPT,U,8),XUA=$P(PGM,"[",1) I XUA]"" X XUEON G NEXT^XUS1 -A S (XUSER(0),XUSER(1),XQUR)="" - ;Check for locked IP/device. - I $$LKCHECK^XUSTZIP() S XUM=7,XUFAC=$P(XOPT,U,2),XUHALT=1 G NO - ;Auto Sign-on check - S X=$$AUTOXUS^XUS1B() I X>0 S DUZ=X D USER(DUZ) W !!,">> Auto Sign-on: ",$P(XUSER(0),U)," <<<",! G B - X XUEOFF S AV=$$ASKAV() X XUEON I AV="^;^" G H ;Get out - I AV["MAIL-BOX",AV[";XMR" S (XUA,PGM)="XMR",XMCHAN=$P($P(AV,";")," ",2),DUZ=.5 G XMR^XUSCLEAN - S XQUR=$P(AV,";",3) - S DUZ=$$CHECKAV(AV) K AV - S XUM=$$UVALID() G:XUM NO -B K XUF,%1 S XUF=0 X XUEON - I DUZ D USER^XUS1 G:XUM NO - I DUZ D SEC^XUS3:($D(^%ZIS(1,XUDEV,"TIME"))!$D(^(95))) G:XUM NO - G NO:'DUZ - S DTIME=$P(XOPT,U,10),X=$S(DUZ("BUF"):"",1:"NO-")_"TYPE-AHEAD" X:$D(^%ZOSF(X)) ^(X) - D TT^XUS3:$G(XUTT) - D CLRFAC^XUS3($G(IO("IP"))) -PGM ; - S Y=+$G(^%ZIS(1,XUDEV,201)) I Y>0,$$CHK S XQY=Y G OK - S Y=+$G(^VA(200,DUZ,201)) I Y>0,$$CHK S XQY=Y G OK - I $D(DUZ("ASH")) S Y=$O(^DIC(19,"B","XU NOP MENU",0)) I Y>0 S XQY=Y G OK ;rwf 403 - S XUM=16 - G NO - ; -OK D CHEK^XQ83 - S (XUA,PGM)="XQ" - G NEXT^XUS1 - ; -CHK() ;Check that option exeist and LOCK - I $D(^DIC(19,Y,0)),$S($P(^(0),U,6)="":1,1:$D(^XUSEC($P(^(0),U,6),DUZ))) Q 1 - Q 0 - ; -LC S X=$$UP(X) - Q -UP(%) Q $TR(%,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") - ; -FAC ;Failed access - S:'DUZ XUF(.1)=$E(%1) - S:XUF=2 XUF(.2)=XUF(.2)+1,XUF(XUF(.2))=%1 S %1="" Q - Q -NO ;Tell why didn't get on - S X=$$NO^XUS3() G RESTART:'X ;fall into exit -H ;Exit point for all applications -C ;CLOSE - G ^XUSCLEAN - ; -ON X ^%ZOSF("EON") Q - ; -ASKAV(PRE) ;Ask and return Access;Verify code, Turn off echo before calling - N X,Y S PRE=$G(PRE) - F W !,PRE,XUSTMP(51) S X=$$ACCEPT S:X="^" X="^;^" Q:$L(X) - S X=$TR(X,$C(9),";") ;Convert TAB to ; to match GUI. - I $P(X," ")="MAIL-BOX" S X=X_";XMR" - I $E(X,1,7)="~~TOK~~" Q X ;Use CCOW token - I '$L($P(X,";",2)) W !,PRE,XUSTMP(52) S Y=$$ACCEPT S:Y="^" X="^;" S $P(X,";",2)=Y - Q X - ; - ;Timeout used by XUSTZ call. -ACCEPT(TO) ;Read A/V and echo '*' char. - ;Have the Read write to flush the buffer on some systems - N C,A,E K DUOUT S A="",TO=$G(TO,60),E=0 - F D Q:E - . R "",*C:TO S:('$T) DUOUT=1 S:('$T)!(C=94) A="^" - . I (A="^")!(C=13)!($L(A)>60) S E=1 Q - . I C=127 Q:'$L(A) S A=$E(A,1,$L(A)-1) W $C(8,32,8) Q - . S A=A_$C(C) W *42 - . Q - Q A - ; -CHECKAV(X1) ;Check A/V code return DUZ or Zero. (Called from XUSRB) - N %,%1,X,Y,IEN,DA,DIK - S IEN=0 - ;Start CCOW - I $E(X1,1,7)="~~TOK~~" D Q:IEN>0 IEN - . I $E(X1,8,9)="~1" S IEN=$$CHKASH^XUSRB4($E(X1,8,255)) - . I $E(X1,8,9)="~2" S IEN=$$CHKCCOW^XUSRB4($E(X1,8,255)) - . Q - ;End CCOW - ; WV p437 ;Allow case sensitivefor VOE - S X1=$S($$GET^XPAR("SYS","XU VC CASE SENSITIVE"):$$UP($P(X1,";",1))_";"_$P(X1,";",2),1:$$UP(X1)) - ; End WV change - S X1=$$UP(X1) S:X1[":" XUTT=1,X1=$TR(X1,":") - S X=$P(X1,";") Q:X="^" -1 S:XUF %1="Access: "_X - Q:X'?1.20ANP 0 - S X=$$EN^XUSHSH(X) I '$D(^VA(200,"A",X)) D LBAV Q 0 - S %1="",IEN=$O(^VA(200,"A",X,0)),XUF(.3)=IEN D USER(IEN) - S X=$P(X1,";",2) S:XUF %1="Verify: "_X S X=$$EN^XUSHSH(X) - I $P(XUSER(1),"^",2)'=X D LBAV Q 0 - I $G(XUFAC(1)) S DIK="^XUSEC(4,",DA=XUFAC(1) D ^DIK - Q IEN -LBAV ;Log Bad AV - D:XUF FAC - I IEN S X=$P($G(^VA(200,IEN,1.1)),U,2)+1,$P(^(1.1),"^",2)=X - Q - ; -USER(IX) ;Build XUSER - S XUSER(0)=$G(^VA(200,+IX,0)),XUSER(1)=$G(^(.1)),XUSER(1.1)=$G(^(1.1)) - Q - ; -XUVOL ;Setup XUENV, XUCI,XQVOL,XUVOL - S U="^" D GETENV^%ZOSV S XUENV=Y,XUCI=$P(Y,U,1),XQVOL=$P(Y,U,2) - S X=$O(^XTV(8989.3,1,4,"B",XQVOL,0)),XUVOL=$S(X>0:^XTV(8989.3,1,4,X,0),1:XQVOL_"^y^1") - Q - ; -XOPT ;Setup initial XOPT - S XOPT=$S($D(^XTV(8989.3,1,"XUS")):^("XUS"),1:"") - F I=2:1:15 I $P(XOPT,U,I)="" S $P(XOPT,U,I)=$P("^5^900^1^1^^^^1^300^^^^N^90",U,I) - Q - ; -SET1(FLAG) ;Setup parameters (also called from XUSRB) - N % - S U="^",XUEON=^%ZOSF("EON"),XUEOFF=^("EOFF") - D XUVOL,XOPT S DUZ("LANG")=$P(XOPT,U,7) ;S:$P(XUVOL,U,6)="y" XRTL=XUCI_","_XQVOL - K ^XUTL("XQ",$J) S XUF=0,XUDEV=0,DUZ=0,DUZ(0)="@",IOS=0,ION="" - I FLAG S %ZIS="L",IOP="HOME" D ^%ZIS Q:POP - S XUDEV=IOS,XUIOP=ION - D GETFAC^XUS3($G(IO("IP"))) - S %=$P(XOPT,U,14) - I "N"'[% D - . S XUF=(%["R")+1,XUF(.1)="",XUF(.2)=0,XUF(.3)=0 - . I %["D" S:$D(^XTV(8989.3,1,4.33,"B",XUDEV))[0 XUF=0 - S DILOCKTM=+$G(^DD("DILOCKTM"),1) ;p434 IA#4909 - Q -SET2() ;EF. Return error code (also called from XUSRB) - N %,X - S XUNOW=$$HTFM^XLFDT($H),DT=$P(XUNOW,".") - K DUZ,XUSER - S (DUZ,DUZ(2))=0,(DUZ(0),DUZ("AG"),XUSER(0),XUSER(1),XUTT,%UCI)="" - S %=$$INHIBIT^XUSRB() I %>0 Q % - S X=$G(^%ZIS(1,XUDEV,"XUS")),XU1=$G(^(1)) - I $L(X) F I=1:1:15 I $L($P(X,U,I)) S $P(XOPT,U,I)=$P(X,U,I) - S DTIME=600 - I '$P(XOPT,U,11),$D(^%ZIS(1,XUDEV,90)),^(90)>2800000,^(90)'>DT Q 8 - Q 0 - ; -UVALID() ;EF. Is it valid for this user to sign on? - I DUZ'>0 Q 4 - I $P(XUSER(1.1),U,5),$P(XUSER(1.1),U,5)>XUNOW S XUM(0)=$$FMTE^XLFDT($P(XUSER(1.1),U,5),"2PM") Q 18 ;User locked until - I $P(XUSER(0),U,11),$P(XUSER(0),U,11)'>DT Q 11 ;Access Terminated - I $D(DUZ("ASH")) Q 0 ;If auto handle, Allow to sign-on p434 - I $P(XUSER(0),U,7) Q 5 ;Disuser flag set - I '$L($P(XUSER(1),U,2)) Q 21 ;p419, p434 - Q 0 - ; -DEVPAS() ;EF. Ask device password - X XUEOFF W !,"DEVICE PASSWORD: " R X:60 X XUEON - S X=$E(X,1,30) S:'$T X="^" D LC Q:X["^" -1 I $P(XU1,U,2)'=X S:XUF %1="Device: "_X D:XUF FAC Q 6 - Q 0 - ; +XUS ;SFISC/STAFF - SIGNON ;3/19/07 09:15 + ;;8.0;KERNEL;**16,26,49,59,149,180,265,337,419,437**;Jul 10, 1995;Build 22 + ; 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 + ;Sign-on message numbers are 30810.51 to 30810.99 + S U="^" D INTRO^XUS1A() + K K ^XUTL("ZISPARAM",$I) + S U="^",XQXFLG("GUI")="^" + W ! S $Y=0 D SET1(1) I POP S XUM=3 G NO ;Sets DUZ("LANG") + S XUSTMP(51)=$$EZBLD^DIALOG(30810.51),XUSTMP(52)=$$EZBLD^DIALOG(30810.52) + W !!,"Volume set: ",$P(XUENV,U,4)," UCI: ",XUCI," Device: ",$I W:$S('$D(IO("ZIO")):0,1:$I'=IO("ZIO")) " (",IO("ZIO"),")" W ! +RESTART ; + S XUM=$$SET2 G:XUM NO + I $P(XU1,U,2)]"" S XUM=$$DEVPAS() I XUM G H:XUM<0,NO + ;S PGM=$P(XOPT,U,8),XUA=$P(PGM,"[",1) I XUA]"" X XUEON G NEXT^XUS1 +A S (XUSER(0),XUSER(1),XQUR)="" + ;Check for locked IP/device. + I $$LKCHECK^XUSTZIP() S XUM=7,XUFAC=$P(XOPT,U,2),XUHALT=1 G NO + ;Auto Sign-on check + S X=$$AUTOXUS^XUS1B() I X>0 S DUZ=X D USER(DUZ) W !!,">> Auto Sign-on: ",$P(XUSER(0),U)," <<<",! G B + X XUEOFF S AV=$$ASKAV() X XUEON I AV="^;^" G H ;Get out + I AV["MAIL-BOX",AV[";XMR" S (XUA,PGM)="XMR",XMCHAN=$P($P(AV,";")," ",2),DUZ=.5 G XMR^XUSCLEAN + S XQUR=$P(AV,";",3) + S DUZ=$$CHECKAV(AV) K AV + S XUM=$$UVALID() G:XUM NO +B K XUF,%1 S XUF=0 X XUEON + I DUZ D USER^XUS1 G:XUM NO + I DUZ D SEC^XUS3:($D(^%ZIS(1,XUDEV,"TIME"))!$D(^(95))) G:XUM NO + G NO:'DUZ + S DTIME=$P(XOPT,U,10),X=$S(DUZ("BUF"):"",1:"NO-")_"TYPE-AHEAD" X:$D(^%ZOSF(X)) ^(X) + D TT^XUS3:$G(XUTT) + D CLRFAC^XUS3($G(IO("IP"))) +PGM ; + S Y=+$G(^%ZIS(1,XUDEV,201)) I Y>0,$$CHK S XQY=Y G OK + S Y=+$G(^VA(200,DUZ,201)) I Y>0,$$CHK S XQY=Y G OK + I $D(DUZ("ASH")) S Y=$O(^DIC(19,"B","XU NOP MENU",0)) I Y>0 S XQY=Y G OK ;rwf 403 + S XUM=16 + G NO + ; +OK D CHEK^XQ83 + S (XUA,PGM)="XQ" + G NEXT^XUS1 + ; +CHK() ;Check that option exeist and LOCK + I $D(^DIC(19,Y,0)),$S($P(^(0),U,6)="":1,1:$D(^XUSEC($P(^(0),U,6),DUZ))) Q 1 + Q 0 + ; +LC S X=$$UP(X) + Q +UP(%) Q $TR(%,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") + ; +FAC ;Failed access + S:'DUZ XUF(.1)=$E(%1) + S:XUF=2 XUF(.2)=XUF(.2)+1,XUF(XUF(.2))=%1 S %1="" Q + Q +NO ;Tell why didn't get on + S X=$$NO^XUS3() G RESTART:'X ;fall into exit +H ;Exit point for all applications +C ;CLOSE + G ^XUSCLEAN + ; +ON X ^%ZOSF("EON") Q + ; +ASKAV(PRE) ;Ask and return Access;Verify code, Turn off echo before calling + N X,Y S PRE=$G(PRE) + F W !,PRE,XUSTMP(51) S X=$$ACCEPT S:X="^" X="^;^" Q:$L(X) + S X=$TR(X,$C(9),";") ;Convert TAB to ; to match GUI. + I $P(X," ")="MAIL-BOX" S X=X_";XMR" + I $E(X,1,7)="~~TOK~~" Q X ;Use CCOW token + I '$L($P(X,";",2)) W !,PRE,XUSTMP(52) S Y=$$ACCEPT S:Y="^" X="^;" S $P(X,";",2)=Y + Q X + ; + ;Timeout used by XUSTZ call. +ACCEPT(TO) ;Read A/V and echo '*' char. + ;Have the Read write to flush the buffer on some systems + N C,A,E K DUOUT S A="",TO=$G(TO,60),E=0 + F D Q:E + . R "",*C:TO S:('$T) DUOUT=1 S:('$T)!(C=94) A="^" + . I (A="^")!(C=13)!($L(A)>60) S E=1 Q + . I C=127 Q:'$L(A) S A=$E(A,1,$L(A)-1) W $C(8,32,8) Q + . S A=A_$C(C) W *42 + . Q + Q A + ; +CHECKAV(X1) ;Check A/V code return DUZ or Zero. (Called from XUSRB) + N %,%1,X,Y,IEN,DA,DIK + S IEN=0 + ;Start CCOW + I $E(X1,1,7)="~~TOK~~" D Q:IEN>0 IEN + . I $E(X1,8,9)="~1" S IEN=$$CHKASH^XUSRB4($E(X1,8,255)) + . I $E(X1,8,9)="~2" S IEN=$$CHKCCOW^XUSRB4($E(X1,8,255)) + . Q + ;End CCOW + S X1=$S($$GET^XPAR("SYS","XU VC CASE SENSITIVE"):$$UP($P(X1,";",1))_";"_$P(X1,";",2),1:$$UP(X1)) S:X1[":" XUTT=1,X1=$TR(X1,":") ; Allow case sensitive for VOE + S X=$P(X1,";") Q:X="^" -1 S:XUF %1="Access: "_X + Q:X'?1.20ANP 0 + S X=$$EN^XUSHSH(X) I '$D(^VA(200,"A",X)) D LBAV Q 0 ; Case insensitive for Access Code for VOE + S %1="",IEN=$O(^VA(200,"A",X,0)),XUF(.3)=IEN D USER(IEN) + S X=$P(X1,";",2) S:XUF %1="Verify: "_X S X=$$EN^XUSHSH(X) + I $P(XUSER(1),"^",2)'=X D LBAV Q 0 + I $G(XUFAC(1)) S DIK="^XUSEC(4,",DA=XUFAC(1) D ^DIK + Q IEN +LBAV ;Log Bad AV + D:XUF FAC + I IEN S X=$P($G(^VA(200,IEN,1.1)),U,2)+1,$P(^(1.1),"^",2)=X + Q + ; +USER(IX) ;Build XUSER + S XUSER(0)=$G(^VA(200,+IX,0)),XUSER(1)=$G(^(.1)),XUSER(1.1)=$G(^(1.1)) + Q + ; +XUVOL ;Setup XUENV, XUCI,XQVOL,XUVOL + S U="^" D GETENV^%ZOSV S XUENV=Y,XUCI=$P(Y,U,1),XQVOL=$P(Y,U,2) + S X=$O(^XTV(8989.3,1,4,"B",XQVOL,0)),XUVOL=$S(X>0:^XTV(8989.3,1,4,X,0),1:XQVOL_"^y^1") + Q + ; +XOPT ;Setup initial XOPT + S XOPT=$S($D(^XTV(8989.3,1,"XUS")):^("XUS"),1:"") + F I=2:1:15 I $P(XOPT,U,I)="" S $P(XOPT,U,I)=$P("^5^900^1^1^^^^1^300^^^^N^90",U,I) + Q + ; +SET1(FLAG) ;Setup parameters (also called from XUSRB) + N % + S U="^",XUEON=^%ZOSF("EON"),XUEOFF=^("EOFF") + D XUVOL,XOPT S DUZ("LANG")=$P(XOPT,U,7) S:$P(XUVOL,U,6)="y" XRTL=XUCI_","_XQVOL + K ^XUTL("XQ",$J) S XUF=0,XUDEV=0,DUZ=0,DUZ(0)="@",IOS=0,ION="" + I FLAG S %ZIS="L",IOP="HOME" D ^%ZIS Q:POP + S XUDEV=IOS,XUIOP=ION D:$D(XRTL) T0^%ZOSV + D GETFAC^XUS3($G(IO("IP"))) + S %=$P(XOPT,U,14) + I "N"'[% D + . S XUF=(%["R")+1,XUF(.1)="",XUF(.2)=0,XUF(.3)=0 + . I %["D" S:$D(^XTV(8989.3,1,4.33,"B",XUDEV))[0 XUF=0 + Q +SET2() ;EF. Return error code (also called from XUSRB) + N %,X + S XUNOW=$$HTFM^XLFDT($H),DT=$P(XUNOW,".") + K DUZ,XUSER + S (DUZ,DUZ(2))=0,(DUZ(0),DUZ("AG"),XUSER(0),XUSER(1),XUTT,%UCI)="" + S %=$$INHIBIT^XUSRB() I %>0 Q % + S X=$G(^%ZIS(1,XUDEV,"XUS")),XU1=$G(^(1)) + I $L(X) F I=1:1:15 I $L($P(X,U,I)) S $P(XOPT,U,I)=$P(X,U,I) + S DTIME=600 + I '$P(XOPT,U,11),$D(^%ZIS(1,XUDEV,90)),^(90)>2800000,^(90)'>DT Q 8 + I $D(XRT0) S XRTN="XUS" D T1^%ZOSV + Q 0 + ; +UVALID() ;EF. Is it valid for this user to sign on? + I DUZ'>0 Q 4 + I $P(XUSER(1.1),U,5),$P(XUSER(1.1),U,5)>XUNOW S XUM(0)=$$FMTE^XLFDT($P(XUSER(1.1),U,5),"2PM") Q 18 ;User locked until + I $P(XUSER(0),U,11),$P(XUSER(0),U,11)'>DT Q 11 ;Access Terminated + I $P(XUSER(0),U,7) Q 5 ;Disuser flag set + I '$L($P(XUSER(1),U,2)) Q 21 ;419 + Q 0 + ; +DEVPAS() ;EF. Ask device password + X XUEOFF W !,"DEVICE PASSWORD: " R X:60 X XUEON + S X=$E(X,1,30) S:'$T X="^" D LC Q:X["^" -1 I $P(XU1,U,2)'=X S:XUF %1="Device: "_X D:XUF FAC Q 6 + Q 0 + ; diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUS2.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUS2.m index 61af9c4f..b8516732 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUS2.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUS2.m @@ -1,188 +1,188 @@ -XUS2 ;SF/RWF - TO CHECK OR RETURN USER ATTRIBUTES ;2/3/07 19:18 - ;;8.0;KERNEL;**59,180,313,419,437**;Jul 10, 1995;Build 23 - Q - ; 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 - ; -ACCED ; ACCESS CODE EDIT from DD - I "Nn"[$E(X,1) S X="" Q - I "Yy"'[$E(X,1) K X Q - N DIR,DIR0,XUAUTO,XUK - S XUAUTO=($P($G(^XTV(8989.3,1,3)),U,1)="y"),XUH="" -AC1 D CLR,AAUTO:XUAUTO,AASK:'XUAUTO G OUT:$D(DIRUT) D REASK G OUT:$D(DIRUT),AC1:'XUK D CLR,AST(XUH) - G OUT - ; -AASK ;Ask for Access code - N X,XUU,XUEX X ^%ZOSF("EOFF") - S XUEX=0 - F D AASK1 Q:XUEX!($D(DIRUT)) - Q - ; -AASK1 ; - W "Enter a new ACCESS CODE : " D GET Q:$D(DIRUT) - I X="@" D DEL D:Y'=1 DIRUT S XUH="",XUEX=1 Q - I X[$C(34)!(X[";")!(X["^")!(X[":")!(X'?.UNP)!($L(X)>20)!($L(X)<6)!(X="MAIL-BOX") D CLR W $C(7),$$AVHLPTXT(1) D AHELP Q - I 'XUAUTO,((X?6.20A)!(X?6.20N)) D CLR W $C(7),$$AVHLPTXT(1),! Q - S XUU=X,X=$$EN^XUSHSH(X),XUH=X,XMB(1)=$O(^VA(200,"A",XUH,0)) I XMB(1),XMB(1)'=DA S XMB="XUS ACCESS CODE VIOLATION",XMB(1)=$P(^VA(200,XMB(1),0),"^"),XMDUN="Security" D ^XMB - I $D(^VA(200,"AOLD",XUH))!$D(^VA(200,"A",XUH)) D CLR W $C(7),"This has been used previously as an ACCESS CODE.",! Q - S XUEX=1 ;Now we can quit - Q - ; -REASK S XUK=1 Q:XUH="" D CLR X ^%ZOSF("EOFF") - F XUK=3:-1:1 W "Please re-type the new code to show that I have it right: " D GET G:$D(DIRUT) DIRUT D ^XUSHSH Q:(XUH=X) D CLR W "This doesn't match. Try again!",!,$C(7) - S:XUH'=X XUK=0 - Q - ; -AST(XUH) ;Change ACCESS CODE and index. - W "OK, Access code has been changed!" - N FDA,IEN,ERR - S IEN=DA_"," - S FDA(200,IEN,2)=XUH D FILE^DIE("","FDA","ERR") - W !,"The VERIFY CODE has been deleted as a security measure.",!,"You will need to enter a new VERIFY code so the user can sign-on.",$C(7) - D VST("",1) - I $D(^XMB(3.7,DA,0))[0 S Y=DA D NEW^XM ;Make sure has a Mailbox - Q - ; -GET ;Get the user input and convert case. - S X=$$ACCEPT^XUS I (X["^")!('$L(X)) D DIRUT - I '$D(ASKINGVC)!'$$GET^XPAR("SYS","XU VC CASE SENSITIVE") S X=$$UP^XLFSTR(X) ;for VOE allow case sensitive Verify Code - Q - ; -DIRUT S DIRUT=1 - Q - ; -CLR ;New line or Clear screenman area - I '$D(DDS) W ! Q - N DX,DY - D CLRMSG^DDS S DX=0,DY=DDSHBX+1 X IOXY - Q - ; -NEWCODE D REASK I XUK W !,"OK, remember this code for next time!" - G OUT - ; -CVC ;From XUS1 - N DA,X - S DA=DUZ,X="Y" - W !,"You must change your VERIFY CODE at this time." - ;Fall into next code -VERED ; VERIFY CODE EDIT From DD - N DIR,DIR0,XUAUTO,ASKINGVC - I "Nn"[$E(X,1) S X="" Q - I "Yy"'[$E(X,1) K X Q - S ASKINGVC=1,XUH="",XUAUTO=($P($G(^XTV(8989.3,1,3)),U,3)="y") S:DUZ=DA XUAUTO="n" ;Auto only for admin -VC1 D CLR,VASK:'XUAUTO,VAUTO:XUAUTO G OUT:$D(DIRUT) D REASK G OUT:$D(DIRUT),VC1:'XUK D CLR,VST(XUH,1) - D CALL^XUSERP(DA,2) - G OUT - ; -VASK ;Ask for Verify Code - N X,XUU X ^%ZOSF("EOFF") G:'$$CHKCUR() DIRUT D CLR -VASK1 W "Enter a new VERIFY CODE: " D GET Q:$D(DIRUT) - I '$D(XUNC),(X="@") D DEL G:Y'=1 DIRUT S XUH="" Q - D CLR S XUU=X,X=$$EN^XUSHSH(X),XUH=X,Y=$$VCHK(XUU,XUH) I +Y W $C(7),$P(Y,U,2,9),! D:+Y=1 VHELP G VASK1 - Q - ; -VCHK(S,EC) ;Call with String and Encripted versions - ;Updated per VHA directive 6210 Strong Passwords - N PUNC,NA S PUNC="~`!@#$%&*()_-+=|\{}[]'<>,.?/" - S NA("FILE")=200,NA("FIELD")=.01,NA("IENS")=DA_",",NA=$$HLNAME^XLFNAME(.NA) - ; for VOE allow case sensitive Verify Code with S'?.ANP - I ($L(S)<8)!($L(S)>20)!$S($$GET^XPAR("SYS","XU VC CASE SENSITIVE"):S'?.ANP,1:S'?.UNP)!(S[";")!(S["^")!(S[":") Q "1^"_$$AVHLPTXT - I (S?8.20A)!(S?8.20N)!(S?8.20P)!(S?8.20AN)!(S?8.20AP)!(S?8.20NP) Q "2^VERIFY CODE must be a mix of alpha and numerics and punctuation." - I $D(^VA(200,DA,.1)),EC=$P(^(.1),U,2) Q "3^This code is the same as the current one." - I $D(^VA(200,DA,"VOLD",EC)) Q "4^This has been used previously as the VERIFY CODE." - I EC=$P(^VA(200,DA,0),U,3) Q "5^VERIFY CODE must be different than the ACCESS CODE." - I S[$P(NA,"^")!(S[$P(NA,"^",2)) Q "6^Name cannot be part of code." - Q 0 - ; -VST(XUH,%) ; - W:$L(XUH)&% !,"OK, Verify code has been changed!" - N FDA,IEN,ERR S IEN=DA_"," - S:XUH="" XUH="@" ;11.2 get triggerd - S FDA(200,IEN,11)=XUH D FILE^DIE("","FDA","ERR") - I $D(ERR) D ^%ZTER - S:DA=DUZ DUZ("NEWCODE")=XUH Q - ; -DEL ; - X ^%ZOSF("EON") W $C(7) S DIR(0)="Y",DIR("A")="Sure you want to delete" D ^DIR I Y'=1 W:$X>55 !?9 W $C(7)," " - Q - ; -AAUTO ;Auto-get Access codes - N XUK,Y - X ^%ZOSF("EON") F XUK=1:1:3 D AGEN Q:(Y=1)!($D(DIRUT)) - Q - ; -AGEN ;Generate a ACCESS code - S XUU=$$AC^XUS4 S X=$$EN^XUSHSH(XUU),XUH=X I $D(^VA(200,"A",X))!$D(^VA(200,"AOLD",X)) G AGEN - D CLR W "The new ACCESS CODE is: ",XUU," This is ",XUK," of 3 tries." - D YN - Q - ; -AHELP S XUU=$$AC^XUS4 S X=$$EN^XUSHSH(XUU) I $D(^VA(200,"A",X))!$D(^VA(200,"AOLD",X)) G AHELP - W !,"Here is an example of an acceptable Access Code: ",XUU,! - Q - ; -VHELP S XUU=$$VC^XUS4 S X=$$EN^XUSHSH(XUU) I ($P($G(^VA(200,DA,0)),U,3)=X)!$D(^VA(200,DA,"VOLD",X)) G VHELP - W !,"Here is an example of an acceptable Verify Code: ",XUU,! - Q - ; -VAUTO ;Auto-get Access codes - N XUK - X ^%ZOSF("EON") F XUK=1:1:3 D VGEN Q:(Y=1)!($D(DIRUT)) - Q - ; -VGEN ;Generate a VERIFY code - S XUU=$$VC^XUS4 S X=$$EN^XUSHSH(XUU),XUH=X I ($P($G(^VA(200,DA,0)),U,3)=X)!$D(^VA(200,DA,"VOLD",X)) G VGEN - D CLR W "The new VERIFY CODE is: ",XUU," This is ",XUK," of 3 tries." - D YN - Q -YN ;Ask if want to keep - N DIR - S Y=1 Q:XUK=3 S DIR(0)="YA",DIR("A")=" Do you want to keep this one? ",DIR("B")="YES",DIR("?",1)="If you don't like this code, we can auto-generate another.",DIR("?")="Remember you only get 3 tries!" - D ^DIR Q:(Y=1)!$D(DIRUT) D CLR W:XUK=2 "O.K. You'll have to keep the next one!",! - Q - ; -OUT ; - K DUOUT S:$D(DIRUT) DUOUT=1 - X ^%ZOSF("EON") W ! - K DIR,DIRUT,XUKO,XUAUTO,XUU,XUH,XUK,XUI S X="" - Q - ; -CHKCUR() ;Check user knows current code, Return 1 if OK to continue - Q:DA'=DUZ 1 ;Only ask user - Q:$P($G(^VA(200,DA,.1)),U,2)="" 1 ;Must have an old one - S XUK=0 D CLR -CHK1 W "Please enter your CURRENT verify code: " D GET Q:$D(DIRUT) 0 - I $P(^VA(200,DA,.1),U,2)=$$EN^XUSHSH(X) Q 1 - D CLR W "Sorry that is not correct!",! - S XUK=XUK+1 G:XUK<3 CHK1 - Q 0 - ; -BRCVC(XV1,XV2) ;Broker change VC, return 0 if good, '1^msg' if bad. - N XUU,XUH - Q:$G(DUZ)'>0 "1^Bad DUZ" S DA=DUZ,XUH=$$EN^XUSHSH(XV2) - I $P($G(^VA(200,DUZ,.1)),"^",2)'=$$EN^XUSHSH(XV1) Q "1^Sorry that isn't the correct current code" - S Y=$$VCHK(XV2,XUH) Q:Y Y - D VST(XUH,0),CALL^XUSERP(DA,2) - Q 0 - ; -AVHLPTXT(%) ; - Q "Enter "_$S($G(%):"6-20",1:"8-20")_" characters mixed alphanumeric and punctuation (except '^', ';', ':')." - ; - ;Left over code, Don't think it is called anymore. - G XUS2^XUVERIFY ;All check or return user attributes moved to XUVERIFY -USER G USER^XUVERIFY -EDIT G EDIT^XUVERIFY +XUS2 ;SF/RWF - TO CHECK OR RETURN USER ATTRIBUTES ;2/3/07 19:18 + ;;8.0;KERNEL;**59,180,313,419,437**;Jul 10, 1995;Build 22 + Q + ; 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 + ; +ACCED ; ACCESS CODE EDIT from DD + I "Nn"[$E(X,1) S X="" Q + I "Yy"'[$E(X,1) K X Q + N DIR,DIR0,XUAUTO,XUK + S XUAUTO=($P($G(^XTV(8989.3,1,3)),U,1)="y"),XUH="" +AC1 D CLR,AAUTO:XUAUTO,AASK:'XUAUTO G OUT:$D(DIRUT) D REASK G OUT:$D(DIRUT),AC1:'XUK D CLR,AST(XUH) + G OUT + ; +AASK ;Ask for Access code + N X,XUU,XUEX X ^%ZOSF("EOFF") + S XUEX=0 + F D AASK1 Q:XUEX!($D(DIRUT)) + Q + ; +AASK1 ; + W "Enter a new ACCESS CODE : " D GET Q:$D(DIRUT) + I X="@" D DEL D:Y'=1 DIRUT S XUH="",XUEX=1 Q + I X[$C(34)!(X[";")!(X["^")!(X[":")!(X'?.UNP)!($L(X)>20)!($L(X)<6)!(X="MAIL-BOX") D CLR W $C(7),$$AVHLPTXT(1) D AHELP Q + I 'XUAUTO,((X?6.20A)!(X?6.20N)) D CLR W $C(7),$$AVHLPTXT(1),! Q + S XUU=X,X=$$EN^XUSHSH(X),XUH=X,XMB(1)=$O(^VA(200,"A",XUH,0)) I XMB(1),XMB(1)'=DA S XMB="XUS ACCESS CODE VIOLATION",XMB(1)=$P(^VA(200,XMB(1),0),"^"),XMDUN="Security" D ^XMB + I $D(^VA(200,"AOLD",XUH))!$D(^VA(200,"A",XUH)) D CLR W $C(7),"This has been used previously as an ACCESS CODE.",! Q + S XUEX=1 ;Now we can quit + Q + ; +REASK S XUK=1 Q:XUH="" D CLR X ^%ZOSF("EOFF") + F XUK=3:-1:1 W "Please re-type the new code to show that I have it right: " D GET G:$D(DIRUT) DIRUT D ^XUSHSH Q:(XUH=X) D CLR W "This doesn't match. Try again!",!,$C(7) + S:XUH'=X XUK=0 + Q + ; +AST(XUH) ;Change ACCESS CODE and index. + W "OK, Access code has been changed!" + N FDA,IEN,ERR + S IEN=DA_"," + S FDA(200,IEN,2)=XUH D FILE^DIE("","FDA","ERR") + W !,"The VERIFY CODE has been deleted as a security measure.",!,"You will need to enter a new VERIFY code so the user can sign-on.",$C(7) + D VST("",1) + I $D(^XMB(3.7,DA,0))[0 S Y=DA D NEW^XM ;Make sure has a Mailbox + Q + ; +GET ;Get the user input and convert case. + S X=$$ACCEPT^XUS I (X["^")!('$L(X)) D DIRUT + I '$D(ASKINGVC)!'$$GET^XPAR("SYS","XU VC CASE SENSITIVE") S X=$$UP^XLFSTR(X) ;for VOE allow case sensitive Verify Code + Q + ; +DIRUT S DIRUT=1 + Q + ; +CLR ;New line or Clear screenman area + I '$D(DDS) W ! Q + N DX,DY + D CLRMSG^DDS S DX=0,DY=DDSHBX+1 X IOXY + Q + ; +NEWCODE D REASK I XUK W !,"OK, remember this code for next time!" + G OUT + ; +CVC ;From XUS1 + N DA,X + S DA=DUZ,X="Y" + W !,"You must change your VERIFY CODE at this time." + ;Fall into next code +VERED ; VERIFY CODE EDIT From DD + N DIR,DIR0,XUAUTO,ASKINGVC + I "Nn"[$E(X,1) S X="" Q + I "Yy"'[$E(X,1) K X Q + S ASKINGVC=1,XUH="",XUAUTO=($P($G(^XTV(8989.3,1,3)),U,3)="y") S:DUZ=DA XUAUTO="n" ;Auto only for admin +VC1 D CLR,VASK:'XUAUTO,VAUTO:XUAUTO G OUT:$D(DIRUT) D REASK G OUT:$D(DIRUT),VC1:'XUK D CLR,VST(XUH,1) + D CALL^XUSERP(DA,2) + G OUT + ; +VASK ;Ask for Verify Code + N X,XUU X ^%ZOSF("EOFF") G:'$$CHKCUR() DIRUT D CLR +VASK1 W "Enter a new VERIFY CODE: " D GET Q:$D(DIRUT) + I '$D(XUNC),(X="@") D DEL G:Y'=1 DIRUT S XUH="" Q + D CLR S XUU=X,X=$$EN^XUSHSH(X),XUH=X,Y=$$VCHK(XUU,XUH) I +Y W $C(7),$P(Y,U,2,9),! D:+Y=1 VHELP G VASK1 + Q + ; +VCHK(S,EC) ;Call with String and Encripted versions + ;Updated per VHA directive 6210 Strong Passwords + N PUNC,NA S PUNC="~`!@#$%&*()_-+=|\{}[]'<>,.?/" + S NA("FILE")=200,NA("FIELD")=.01,NA("IENS")=DA_",",NA=$$HLNAME^XLFNAME(.NA) + ; for VOE allow case sensitive Verify Code with S'?.ANP + I ($L(S)<8)!($L(S)>20)!$S($$GET^XPAR("SYS","XU VC CASE SENSITIVE"):S'?.ANP,1:S'?.UNP)!(S[";")!(S["^")!(S[":") Q "1^"_$$AVHLPTXT + I (S?8.20A)!(S?8.20N)!(S?8.20P)!(S?8.20AN)!(S?8.20AP)!(S?8.20NP) Q "2^VERIFY CODE must be a mix of alpha and numerics and punctuation." + I $D(^VA(200,DA,.1)),EC=$P(^(.1),U,2) Q "3^This code is the same as the current one." + I $D(^VA(200,DA,"VOLD",EC)) Q "4^This has been used previously as the VERIFY CODE." + I EC=$P(^VA(200,DA,0),U,3) Q "5^VERIFY CODE must be different than the ACCESS CODE." + I S[$P(NA,"^")!(S[$P(NA,"^",2)) Q "6^Name cannot be part of code." + Q 0 + ; +VST(XUH,%) ; + W:$L(XUH)&% !,"OK, Verify code has been changed!" + N FDA,IEN,ERR S IEN=DA_"," + S:XUH="" XUH="@" ;11.2 get triggerd + S FDA(200,IEN,11)=XUH D FILE^DIE("","FDA","ERR") + I $D(ERR) D ^%ZTER + S:DA=DUZ DUZ("NEWCODE")=XUH Q + ; +DEL ; + X ^%ZOSF("EON") W $C(7) S DIR(0)="Y",DIR("A")="Sure you want to delete" D ^DIR I Y'=1 W:$X>55 !?9 W $C(7)," " + Q + ; +AAUTO ;Auto-get Access codes + N XUK,Y + X ^%ZOSF("EON") F XUK=1:1:3 D AGEN Q:(Y=1)!($D(DIRUT)) + Q + ; +AGEN ;Generate a ACCESS code + S XUU=$$AC^XUS4 S X=$$EN^XUSHSH(XUU),XUH=X I $D(^VA(200,"A",X))!$D(^VA(200,"AOLD",X)) G AGEN + D CLR W "The new ACCESS CODE is: ",XUU," This is ",XUK," of 3 tries." + D YN + Q + ; +AHELP S XUU=$$AC^XUS4 S X=$$EN^XUSHSH(XUU) I $D(^VA(200,"A",X))!$D(^VA(200,"AOLD",X)) G AHELP + W !,"Here is an example of an acceptable Access Code: ",XUU,! + Q + ; +VHELP S XUU=$$VC^XUS4 S X=$$EN^XUSHSH(XUU) I ($P($G(^VA(200,DA,0)),U,3)=X)!$D(^VA(200,DA,"VOLD",X)) G VHELP + W !,"Here is an example of an acceptable Verify Code: ",XUU,! + Q + ; +VAUTO ;Auto-get Access codes + N XUK + X ^%ZOSF("EON") F XUK=1:1:3 D VGEN Q:(Y=1)!($D(DIRUT)) + Q + ; +VGEN ;Generate a VERIFY code + S XUU=$$VC^XUS4 S X=$$EN^XUSHSH(XUU),XUH=X I ($P($G(^VA(200,DA,0)),U,3)=X)!$D(^VA(200,DA,"VOLD",X)) G VGEN + D CLR W "The new VERIFY CODE is: ",XUU," This is ",XUK," of 3 tries." + D YN + Q +YN ;Ask if want to keep + N DIR + S Y=1 Q:XUK=3 S DIR(0)="YA",DIR("A")=" Do you want to keep this one? ",DIR("B")="YES",DIR("?",1)="If you don't like this code, we can auto-generate another.",DIR("?")="Remember you only get 3 tries!" + D ^DIR Q:(Y=1)!$D(DIRUT) D CLR W:XUK=2 "O.K. You'll have to keep the next one!",! + Q + ; +OUT ; + K DUOUT S:$D(DIRUT) DUOUT=1 + X ^%ZOSF("EON") W ! + K DIR,DIRUT,XUKO,XUAUTO,XUU,XUH,XUK,XUI S X="" + Q + ; +CHKCUR() ;Check user knows current code, Return 1 if OK to continue + Q:DA'=DUZ 1 ;Only ask user + Q:$P($G(^VA(200,DA,.1)),U,2)="" 1 ;Must have an old one + S XUK=0 D CLR +CHK1 W "Please enter your CURRENT verify code: " D GET Q:$D(DIRUT) 0 + I $P(^VA(200,DA,.1),U,2)=$$EN^XUSHSH(X) Q 1 + D CLR W "Sorry that is not correct!",! + S XUK=XUK+1 G:XUK<3 CHK1 + Q 0 + ; +BRCVC(XV1,XV2) ;Broker change VC, return 0 if good, '1^msg' if bad. + N XUU,XUH + Q:$G(DUZ)'>0 "1^Bad DUZ" S DA=DUZ,XUH=$$EN^XUSHSH(XV2) + I $P($G(^VA(200,DUZ,.1)),"^",2)'=$$EN^XUSHSH(XV1) Q "1^Sorry that isn't the correct current code" + S Y=$$VCHK(XV2,XUH) Q:Y Y + D VST(XUH,0),CALL^XUSERP(DA,2) + Q 0 + ; +AVHLPTXT(%) ; + Q "Enter "_$S($G(%):"6-20",1:"8-20")_" characters mixed alphanumeric and punctuation (except '^', ';', ':')." + ; + ;Left over code, Don't think it is called anymore. + G XUS2^XUVERIFY ;All check or return user attributes moved to XUVERIFY +USER G USER^XUVERIFY +EDIT G EDIT^XUVERIFY diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSCLEAN.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSCLEAN.m index 5e268ed3..b0b076a2 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSCLEAN.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSCLEAN.m @@ -1,89 +1,87 @@ -XUSCLEAN ;SF/STAFF - CLEANUP BEFORE EXIT ;10/26/06 08:12 - ;;8.0;KERNEL;**13,59,165,353,434**;Jul 10, 1995;Build 6 -H ;;Exit point for all R/S applications - LOCK ;Unlock any locks - S U="^" - ;Unwind Exit Actions - I $D(^XUTL("XQ",$J,"T")) S %XQEA=^("T") D - . F %XQEA1=%XQEA:-1:1 I $D(^XUTL("XQ",$J,%XQEA1)),$P(^(%XQEA1),U,16) S %XQEA2=+^(%XQEA1) I $D(^DIC(19,%XQEA2,15)),$L(^(15)) X ^(15) - K %XQEA,%XQEA1,%XQEA2 - ;Jump if the home device was closed - G:$D(IO("C")) H2 - ;Clear the screen - I $S($D(IOST)[0:1,IOST="":1,IOST["C-":1,1:0),'$D(XUERF) W !!!!!!!!!!!!!!!!!!!!!!! - I $D(XQNOLOG) W !!,"==> Sorry, all activity on this volume set is being halted! Try again later.",*7,*7,*7,!!!! - ;W !!,"Halting at " S X=$P($H,",",2),Y=$E(X#3600\60+100,2,3),X=X\3600,Z=0 S:X>11 Z=1 S:'X X=12 S:X>12 X=X-12 W X,":",Y," ",$S(Z:"pm",1:"am") - W !!,"Logged out at "_$$HTE^XLFDT($H,"1FMP") - D:$D(DUZ("NEWCODE")) NEWCODE - ;NON-R/S exit thru here also. -H2 ;No talking after this point - D C,XUTL - ;un-comment the following line if you want FM space recall cleared - ;after each session. - ;K ^DISV($G(DUZ,0)) - S:'($D(XQXFLG)#2) XQXFLG="" I $D(XQCH),XQCH="HALT" S $P(XQXFLG,U,3)="" - I ($D(XQNOHALT)#2)!($D(ZTQUEUED)#2)!($P(XQXFLG,U,3)="XUP") K XQNOHALT,XQXFLG Q ;Return to REST^XQ12, ^XUP or Taskman. - ;This was for modem hang up code. Obsolete now - I $D(^%ZIS("H"))#2 X ^("H") - ;Go to ZU to do final halt. - G HALT^ZU - ; -TOUCH ;SR. API to set the keepalive node, Only set once a day - Q:+$G(^XUTL("XQ",$J,"KEEPALIVE"))=+$H - S ^XUTL("XQ",$J,"KEEPALIVE")=$H - Q - ; -C ;Do device close execute, User exit. - N XUDEV - S XUDEV=$S($D(^XUTL("XQ",$J,"IOS")):^("IOS"),1:"") - D ^%ZISC,BYE - Q - ; - ;Called from Broker, VistaLink, R/S -BYE ;Set flags to show user has left. Called from anyplace the user exits - N DA,DIK,R0,% - I $G(^VA(200,+$G(DUZ),1.1)) S $P(^VA(200,DUZ,1.1),"^",3)=0 - S DA=+$G(^XUTL("XQ",$J,0)) D LOUT(DA) - I $D(^XUSEC(0,DA,0)) D - . S R0=^XUSEC(0,DA,0) - . I $G(IO("IP"))]"",$P(R0,"^",13)]"" S %=$$CMD^XWBCAGNT(.R0,"XWB DELETE HANDLE",$P(R0,"^",13)) - K ^XUTL("XQ",$J) - Q - ; -LOUT(DA) ;Enter log-out time, in Sign-on log - N DIK - I $D(^XUSEC(0,DA,0)) D - . S R0=^(0),$P(^(0),"^",4)=$$NOW^XLFDT,DIK="^XUSEC(0,",DIK(1)="3" D EN1^DIK - Q - ; -XUTL ;Cleanup JOB temporary Globals - N XQN D CLEAN^DILF ;Cleanup FM too. - K ^XUTL($J),^UTILITY($J),^TMP($J) - S XQN=" " F S XQN=$O(^XUTL(XQN)) Q:XQN="" K:"^XQO^XGATR^XGKB^"'[XQN ^XUTL(XQN,$J) - S XQN=" " F S XQN=$O(^TMP(XQN)) Q:XQN="" K ^TMP(XQN,$J) - S XQN=" " F S XQN=$O(^UTILITY(XQN)) Q:XQN="" K:"^ROU^GLO^LRLTR"'[XQN ^UTILITY(XQN,$J) - K ^XUTL("ZISPARAM",$I) - Q - ; -NEWCODE ;Remind user they changed there VC. - W !!,*7,"But, as I recall...",!,"You've changed your VERIFY CODE during this session.",!,"Please remember it for next time." H 4 - Q - ; - ;Entry point to clear symbol table -KILL ;SR. This is what was requested. - K %1,%2,%3 S %3=+$G(^XUTL("XQ",$J,"T")) - ;See if Menu stack has Variable to protect. - F %1=%3:-1:1 S %2=+$G(^XUTL("XQ",$J,%1)),%2=$G(^DIC(19,%2,"NOKILL")) I %2]"" N @%2 - ;Fall into next part of kill. -KILL1 ;To clean up ALL but kernel variables. - I $$BROKER^XWBLIB S %2=$P($T(VARLST^XWBLIB),";;",2) I %2]"" N @%2 ;Protect Broker variables. - N XGWIN,XGDI,XGEVENT ;P434 remove KWAPI - N XQAEXIT,XQAUSER,XQX1,XQAKILL,XQAID - ;p434 add DILOCKTM, remove XRTL, %ZH0 - K (DUZ,DTIME,DILOCKTM,DT,DISYS,IO,IOBS,IOF,IOM,ION,IOSL,IOST,IOT,IOS,IOXY,U,XQVOL,XQY,XQY0,XQDIC,XQPSM,XQPT,XQAUDIT,XQXFLG,ZTSTOP,ZTQUEUED,ZTREQ) - K IO("C"),IO("Q") - Q - ; -XMR ;Entry point from XUS to DO xmr and cleanup after. - N XQXFLG ;p434 - D NEXT^XUS1 S XQXFLG="",XQXFLG("HALT")=1 G H2 +XUSCLEAN ;SF/STAFF - CLEANUP BEFORE EXIT ;05/26/2005 14:28 + ;;8.0;KERNEL;**13,59,165,353**;Jul 10, 1995;Build 1 +H ;;Exit point for all R/S applications + LOCK ;Unlock any locks + S U="^" + ;Unwind Exit Actions + I $D(^XUTL("XQ",$J,"T")) S %XQEA=^("T") D + . F %XQEA1=%XQEA:-1:1 I $D(^XUTL("XQ",$J,%XQEA1)),$P(^(%XQEA1),U,16) S %XQEA2=+^(%XQEA1) I $D(^DIC(19,%XQEA2,15)),$L(^(15)) X ^(15) + K %XQEA,%XQEA1,%XQEA2 + ;Jump if the home device was closed + G:$D(IO("C")) H2 + ;Clear the screen + I $S($D(IOST)[0:1,IOST="":1,IOST["C-":1,1:0),'$D(XUERF) W !!!!!!!!!!!!!!!!!!!!!!! + I $D(XQNOLOG) W !!,"==> Sorry, all activity on this volume set is being halted! Try again later.",*7,*7,*7,!!!! + ;W !!,"Halting at " S X=$P($H,",",2),Y=$E(X#3600\60+100,2,3),X=X\3600,Z=0 S:X>11 Z=1 S:'X X=12 S:X>12 X=X-12 W X,":",Y," ",$S(Z:"pm",1:"am") + W !!,"Logged out at "_$$HTE^XLFDT($H,"1FMP") + D:$D(DUZ("NEWCODE")) NEWCODE + ;NON-R/S exit thru here also. +H2 ;No talking after this point + D C,XUTL + ;un-comment the following line if you want FM space recall cleared + ;after each session. + ;K ^DISV($G(DUZ,0)) + S:'($D(XQXFLG)#2) XQXFLG="" I $D(XQCH),XQCH="HALT" S $P(XQXFLG,U,3)="" + I ($D(XQNOHALT)#2)!($D(ZTQUEUED)#2)!($P(XQXFLG,U,3)="XUP") K XQNOHALT,XQXFLG Q ;Return to REST^XQ12, ^XUP or Taskman. + ;This was for modem hang up code. Obsolete now + I $D(^%ZIS("H"))#2 X ^("H") + ;Go to ZU to do final halt. + G HALT^ZU + ; +TOUCH ;SR. API to set the keepalive node, Only set once a day + Q:+$G(^XUTL("XQ",$J,"KEEPALIVE"))=+$H + S ^XUTL("XQ",$J,"KEEPALIVE")=$H + Q + ; +C ;Do device close execute, User exit. + N XUDEV + S XUDEV=$S($D(^XUTL("XQ",$J,"IOS")):^("IOS"),1:"") + D ^%ZISC,BYE + Q + ; + ;Called from Broker, VistaLink, R/S +BYE ;Set flags to show user has left. Called from anyplace the user exits + N DA,DIK,R0,% + I $G(^VA(200,+$G(DUZ),1.1)) S $P(^VA(200,DUZ,1.1),"^",3)=0 + S DA=+$G(^XUTL("XQ",$J,0)) D LOUT(DA) + I $D(^XUSEC(0,DA,0)) D + . S R0=^XUSEC(0,DA,0) + . I $G(IO("IP"))]"",$P(R0,"^",13)]"" S %=$$CMD^XWBCAGNT(.R0,"XWB DELETE HANDLE",$P(R0,"^",13)) + K ^XUTL("XQ",$J) + Q + ; +LOUT(DA) ;Enter log-out time, in Sign-on log + N DIK + I $D(^XUSEC(0,DA,0)) D + . S R0=^(0),$P(^(0),"^",4)=$$NOW^XLFDT,DIK="^XUSEC(0,",DIK(1)="3" D EN1^DIK + Q + ; +XUTL ;Cleanup JOB temporary Globals + N XQN D CLEAN^DILF ;Cleanup FM too. + K ^XUTL($J),^UTILITY($J),^TMP($J) + S XQN=" " F S XQN=$O(^XUTL(XQN)) Q:XQN="" K:"^XQO^XGATR^XGKB^"'[XQN ^XUTL(XQN,$J) + S XQN=" " F S XQN=$O(^TMP(XQN)) Q:XQN="" K ^TMP(XQN,$J) + S XQN=" " F S XQN=$O(^UTILITY(XQN)) Q:XQN="" K:"^ROU^GLO^LRLTR"'[XQN ^UTILITY(XQN,$J) + K ^XUTL("ZISPARAM",$I) + Q + ; +NEWCODE ;Remind user they changed there VC. + W !!,*7,"But, as I recall...",!,"You've changed your VERIFY CODE during this session.",!,"Please remember it for next time." H 4 + Q + ; + ;Entry point to clear symbol table +KILL ;SR. This is what was requested. + K %1,%2,%3 S %3=+$G(^XUTL("XQ",$J,"T")) + ;See if Menu stack has Variable to protect. + F %1=%3:-1:1 S %2=+$G(^XUTL("XQ",$J,%1)),%2=$G(^DIC(19,%2,"NOKILL")) I %2]"" N @%2 + ;Fall into next part of kill. +KILL1 ;To clean up ALL but kernel variables. + I $$BROKER^XWBLIB S %2=$P($T(VARLST^XWBLIB),";;",2) I %2]"" N @%2 ;Protect Broker variables. + N KWAPI,XGWIN,XGDI,XGEVENT + N XQAEXIT,XQAUSER,XQX1,XQAKILL,XQAID + K (DUZ,DTIME,DT,DISYS,IO,IOBS,IOF,IOM,ION,IOSL,IOST,IOT,IOS,IOXY,U,XRTL,%ZH0,XQVOL,XQY,XQY0,XQDIC,XQPSM,XQPT,XQAUDIT,XQXFLG,ZTSTOP,ZTQUEUED,ZTREQ) + K IO("C"),IO("Q") + Q + ; +XMR ;Entry point from XUS to DO xmr and cleanup after. + D NEXT^XUS1 S XQXFLG="",XQXFLG("HALT")=1 G H2 diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSERBLK.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSERBLK.m index 8045e53e..83ca0a2e 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSERBLK.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSERBLK.m @@ -1,188 +1,174 @@ -XUSERBLK ;SF/RWF - Bulk user (new person) COMPUTER ACCESS ;02/26/2008 - ;;8.0;KERNEL;**20,214,230,289,419,490**;Jul 10, 1995;Build 5 - ; Per VHA Directive 2004-038, this routine should not be modified. - ; Option: XUSERBLK - ; This routine allows the Cloning of one person to a group of others. -A ; - I $G(DUZ)'>0 W !!,"You are not a known user and can't use this option." Q - N DIC,X,Y,XUTMP,DA,DIR,XUTERMDT,XUSER,XUY,%ZIS,XUIOP,XMQUIET - K ^TMP($J) -B1 W @IOF,!?26,"Batch Entry of New Persons" - W !?26,"--------------------------",!!,"Please select a person to copy from" - K DIC S DIC(0)="AEQZ",DIC("A")="Template PERSON: ",DIC="^VA(200," D ^DIC - Q:$D(DTOUT)!$D(DUOUT) - G B1:Y=-1 - ; Show INFO to be copied" - S XUTMP=+Y,XUTMP(0)=$P(Y,U,2),DA=+Y D EN^DIQ - S DIR(0)="Y",DIR("A")="Is this the person whose data you want cloned" D ^DIR Q:$D(DIRUT) G B1:'Y - W !!,"You may enter a date, when the users that are being created/updated",!,"will no longer have access to the system." - S DIR(0)="DAO^DT::AEF" - S DIR("A")="Enter (optional) TERMINATION DATE: " - D ^DIR Q:$D(DTOUT)!$D(DUOUT) - S XUTERMDT=Y - K XUSER S XUSER=0 -B2 ; - W !!,?26,"Batch Entry of New Persons",!,?26,"--------------------------",! - W !,"Clone of: ",XUTMP(0) I XUTERMDT W ?49,"TERMINATION DATE: ",$$FMTE^XLFDT(XUTERMDT) - ;; -B3 F S XUY=$$ADD^XUSERNEW Q:XUY<0 D ;Create new entry - . I '$P(XUY,U,3) D - . . S DIR(0)="Y",DIR("A")=$P(XUY,U,2)_" is an existing user. Do you want to include" D ^DIR I Y'=1 S XUY=-1 Q - . . S DIR(0)="Y",DIR("A")="Clear out KEYS, FILES, SECONDARY MENUS first" D ^DIR - . . S:Y=1 $P(XUY,U,4)=1 - . . Q - . I XUY>0 D - . . S DIR(0)="Y",DIR("A")="Do You Want To Clone PERSON CLASS" D ^DIR - . . S:Y=1 $P(XUY,U,5)=1 - . S:XUY>0 XUSER=XUSER+1,XUSER(XUSER)=XUY W !!,"Next!" - . Q -B4 ; - Q:XUSER'>0 - I XUTERMDT D - . N XUZT - . S XUZT("ZTDTH")=XUTERMDT - . W !!,"Queueing automatic deactivation for ",$$FMTE^XLFDT(XUTERMDT) - . S X=$$NODEV^XUTMDEVQ("CHECK^XUSTERM1",,,.XUZT,1) - W !!,"Where do you want to print the COMPUTER ACCOUNT NOTIFICATION LETTERS?" - S XMQUIET=1 - S %ZIS="NMQ" D ^%ZIS Q:POP ; "N" means don't open device - K XMQUIET - S XUIOP=ION_";"_IOST_";"_IOM_";"_IOSL - D HOME^%ZIS - ;I ION["P-MESSAGE-HFS" G START - I '$D(IO("Q")) G CLONE -START ; - N XUZT - S XUZT("ZTDTH")=$H - S X=$$NODEV^XUTMDEVQ("CLONE^XUSERBLK",,"XUIOP;XUTMP;XUTERMDT;XUSER;XUSER(",.XUZT,1) - Q - ;; -CLONE ;;Do work - N XUTEXT,XU1,%,DA,XUNEW,XUPURGE - S XUTEXT=$O(^DIC(9.2,"B",$$GET^XUPARAM("XUSER COMPUTER ACCOUNT","N"),0)) - F XU1=1:1:XUSER S %=XUSER(XU1),DA=+%,XUNEW=$P(%,U,3),XUPURGE=$P(%,U,4) D C2,UPDATE("ORD",DA) - K ^TMP($J) - Q -C2 ; - N XUU,XUU2,XFDA,XUH,XUH2,XIEN,XERR,Y,XMZ,XMM,XMDT - I '$D(ZTQUEUED) W !!?8,$S(XUNEW:"CREATING A NEW ACCOUNT FOR '"_$P(XUSER(XU1),U,2)_"'",1:"CONVERTING "_$P(XUSER(XU1),U,2)_"'S ACCOUNT OVER"),!!,"One moment please..." - D BLDFDA - I $P(^VA(200,DA,0),U,3)']"" S XUNEW=1 ;if no access code treat as new - I $P($G(^VA(200,DA,.1)),U,2)']"" S XUNEW=1 ;If no verify code treat as new - S (XUU,XUU2)="unchanged",$P(^VA(200,DA,0),U,11)=XUTERMDT - I XUNEW D ACODE S @XFDA@(200,DA_",",2)=XUH D VCODE S @XFDA@(200,DA_",",11)=XUH2 - D UPDATE^DIE("",XFDA,XIEN,"XERR") K @XFDA - I XUNEW,XUTEXT>0 D LET(DA,XUTEXT) - I $D(^XMB(3.7,DA,0))[0 S Y=DA K XMZ D NEW^XM K XMDT,XMM,XMZ - Q - ; -BLDFDA ;Build the FDA - N X2,X3,X4,X5,X6,X7,XUNODE,XU - S XFDA="^TMP($J,""XFDA"")",XIEN="^TMP($J,""XIEN"")" K ^TMP($J) - ;Move piece on nodes from list, Build XU only once - F X2=1:1 S XUNODE=$P($T(DATA+X2),";;",2) Q:XUNODE="" D - . F X3=1:1 S X7=$P(XUNODE,U,X3) Q:X7="" S X4=$$GETDD(200,X7),X5=$P(X4,";"),X6=$P(X4,";",2) D - . . I '$D(XU(2,X5)) S XU(2,X5)=$G(^VA(200,XUTMP,X5)) - . . S:$P(XU(2,X5),U,X6)]"" @XFDA@(200,DA_",",X7)=$P(XU(2,X5),U,X6) - . . Q - . Q - D SUBFILE - Q - ; -GETDD(FI,FE) ;Return node;piece for a field - Q $P($G(^DD(FI,FE,0)),U,4) - ; -DATA ;;field# - ;;3^8^15^29^28 - ;;200.04^200.05^200.06^200.09^200.1^201^ - ;;41^41.1^41.2 - ;;101.01^101.02 - ;;9.21^9.22 - ;; - ; -ACODE ; - N Z - F Z=0:0 S XUU=$$AC^XUS4(),XUH=$$EN^XUSHSH(XUU) Q:'($D(^VA(200,"AOLD",XUH))!$D(^VA(200,"A",XUH))) - Q - ; -VCODE ; - S XUU2=$$VC^XUS4(),XUH2=$$EN^XUSHSH(XUU2) - Q - ; -SUBFILE ;Move subfiles: Subscript, Subfile#, DINUM, Fields - N XCNT S XCNT=0 -KEY D MULTI(51,200.051,1,".01,3") -PATH ;D MULTI(19.8,".01") -FOF D MULTI("FOF",200.032,1,".01,1,2,3,4,5,6") -DIV D MULTI(2,200.02,1,".01") -SEC D MULTI(203,200.03,0,".01,2") -TAB D MULTI("ORD",200.010113,0,".01,.02,.03") -PSCLSS I $P($G(XUSER(XU1)),U,5)=1 D PRSNCL(DA) - Q - ; -MULTI(XSS,XSF,XDN,XDD) ;Build new data - I XUPURGE D CLEAR(DA,XSS) - Q:'$D(^VA(200,XUTMP,XSS,0)) - ;S X=^(0),Y=$S($D(^VA(200,DA,X2,0)):^(0),1:"") - F X1=0:0 S X1=$O(^VA(200,XUTMP,XSS,X1)) Q:X1'>0 S X=^(X1,0) D - . F X2=1:1 S X3=$P(XDD,",",X2) Q:X3="" D - . . I X3'=.01 S @XFDA@(XSF,"?+"_XCNT_","_DA_",",X3)=$$VAL(X,X3,XSF) Q - . . S XCNT=XCNT+1,@XFDA@(XSF,"?+"_XCNT_","_DA_",",.01)=$P(X,U,1) - . . S:XDN @XIEN@(XCNT)=X1 - . . Q - . Q - Q - ; -VAL(V,FE,FI) ;Get value - N % S %=$$GETDD(FI,FE),%=$P(%,";",2) Q $P(V,"^",%) - ; -LET(DA,XUTEXT) ;Write access letter - N DIWF,FR,TO,BY,IOP - S DIWF="^DIC(9.2,"_XUTEXT_",1,",DIWF(1)=200,FR=DA,TO=DA,BY="NUMBER",IOP=XUIOP D EN2^DIWF - Q - ; -CLEAR(X4,X2) ;Clear subfile first, IEN, Subscript - Q:$D(^VA(200,X4,X2,0))[0 N C,XUFN,XDEL,XMSG - S C=",",XDEL=$NA(^TMP($J,"XUBLK2")),XUFN=+$P(^VA(200,X4,X2,0),"^",2) - F X1=0:0 S X1=$O(^VA(200,X4,X2,X1)) Q:X1'>0 D - . I X2=51 S %=$$DEL^XQKEY(X4,X1) Q ;Special case for KEYS - . S @XDEL@(XUFN,X1_C_X4_C,.01)="@" - . Q - I $D(@XDEL)>1 D FILE^DIE("",XDEL,"XMSG") ;I $D(XMSG) ZW XMSG - Q - ; -UPDATE(XX,USRIEN) ;Update effective date - N PC,PC1 - S PC=$O(^VA(200,USRIEN,XX,"A"),-1) Q:PC'>0 - S PC=0 F S PC=$O(^VA(200,USRIEN,XX,PC)) Q:PC'>0 D - .S PC1=$P($G(^VA(200,USRIEN,XX,PC,0)),"^",3) - .I (PC1="")!(PC1' The user is locked. Please try this option again." - S $P(^VA(200,USRIEN,XX,PC,0),"^",2)=DT - L -^VA(200,USRIEN,XX,PC,0) - Q - ; -PRSNCL(USERIEN) ; - N XUDATA,XUPSC,XUEFDA,XUEXDA,ZZ - S XUDATA=$O(^VA(200,XUTMP,"USC1","A"),-1) Q:XUDATA'>0 - S XUDATA=$G(^VA(200,XUTMP,"USC1",XUDATA,0)) Q:XUDATA="" - S XUPSC=$P(XUDATA,"^") - S XUEFDA=$P(XUDATA,"^",2) I XUEFDA'>DT S XUEFDA=DT - S XUEXDA=$P(XUDATA,"^",3) - I XUEXDA0 - S XULDATA=$G(^VA(200,USERIEN,"USC1",XULAST,0)) - S XULDATA=$P(XULDATA,"^",3) - Q:XULDATA'>DT - S $P(^VA(200,USERIEN,"USC1",XULAST,0),"^",3)=DT - Q +XUSERBLK ;SF/RWF - Bulk user (new person) COMPUTER ACCESS ; 5/23/2006 + ;;8.0;KERNEL;**20,214,230,289,419**;Jul 10, 1995;Build 5 + ; This routine allows the Cloning of one person to a group of others. +A ; + I $G(DUZ)'>0 W !!,"You are not a known user and can't use this option." Q + N DIC,DIR,%,L,XUIOP,XUNODE,XU1,X1,X2,X3,X4,X5,X6,XUTEXT,XUNEW,XUSER,XUTMP,XUTERMDT,XUH,XUU,XUU2,M,P,XU + K ^TMP($J) +B1 W @IOF,!?26,"Batch Entry of New Persons" + W !?26,"--------------------------",!!,"Please select a person to copy from" + K DIC S DIC(0)="AEQZ",DIC("A")="Template PERSON: ",DIC="^VA(200," D ^DIC + G QUIT:$D(DTOUT)!$D(DUOUT),B1:Y=-1 + ; Show INFO to be copied" + S XUTMP=+Y,XUTMP(0)=$P(Y,U,2),DA=+Y D EN^DIQ + S DIR(0)="Y",DIR("A")="Is this the person data you want cloned" D ^DIR G B1:'Y + W !,"You may enter a date, when the users that are being created/updated",!,"will no longer have access to the system." + S XUTERMDT="",%DT="AEF",%DT(0)=DT,%DT("A")="Enter (optional) TERMINATION DATE: " D ^%DT S:Y>0 XUTERMDT=Y + K XUSER S XUSER=0 +B2 ; + W !!,?26,"Batch Entry of New Persons",!,?26,"--------------------------",! + W !,"Clone of: ",XUTMP(0) I XUTERMDT W ?50,"TERMINATION DATE: ",$$FMTE^XLFDT(XUTERMDT) + ;; +B3 F S XUY=$$ADD^XUSERNEW Q:XUY<0 D ;Create new entry + . I '$P(XUY,U,3) D + . . S DIR(0)="Y",DIR("A")=$P(XUY,U,2)_" is an existing user. Do you want to include" D ^DIR I Y'=1 S XUY=-1 Q + . . S DIR(0)="Y",DIR("A")="Clear out KEYS, FILES, SECONDARY MENUS first" D ^DIR + . . S:Y=1 $P(XUY,U,4)=1 + . . Q + . I XUY>0 D + . . S DIR(0)="Y",DIR("A")="Do You Want To Clone PERSON CLASS" D ^DIR + . . S:Y=1 $P(XUY,U,5)=1 + . S:XUY>0 XUSER=XUSER+1,XUSER(XUSER)=XUY W !,"Next!",! + . Q +B4 ; + G:XUSER'>0 QUIT + I XUTERMDT>0 S ZTRTN="CHECK^XUSTERM1",ZTIO="",ZTDTH=XUTERMDT D ^%ZTLOAD W !,"Automatic deactivation has been queued for this date.",! + W !!,"Where do you want to print the COMPUTER ACCOUNT NOTIFICATION LETTERS" + S %ZIS="MQ" D ^%ZIS G QUIT:POP + I ION["P-MESSAGE-HFS" G START + I '$D(IO("Q")) G CLONE +START ; + S ZTRTN="CLONE^XUSERBLK" F I="XUTMP","XUTERMDT","XUSER","XUSER(" S ZTSAVE(I)="" + K IO("Q") D ^%ZTLOAD + ;; +QUIT ; + K DIC,DIR,%,L,XUIOP,XUNODE,XU1,X1,X2,X3,X4,X5,X6,XUTEXT,XUNEW,XUSER,XUTMP,XUTERMDT,XUH,XUU,XUU2,M,P,XU + K ^TMP($J) + Q + ;; +CLONE ;;Do work + S XUTEXT=$O(^DIC(9.2,"B",$$GET^XUPARAM("XUSER COMPUTER ACCOUNT","N"),0)),XUIOP=ION_";"_IOST_";"_IOM_";"_IOSL + F XU1=1:1:XUSER S %=XUSER(XU1),DA=+%,XUNEW=$P(%,U,3),XUPURGE=$P(%,U,4) D C2,UPDATE("ORD",DA) + G QUIT + ; +C2 ; + N XUH,XUH2,XUU,XUU2 + I '$D(ZTQUEUED) W !!?8,$S(XUNEW:"CREATING A NEW ACCOUNT FOR '"_$P(XUSER(XU1),U,2)_"'",1:"CONVERTING "_$P(XUSER(XU1),U,2)_"'S ACCOUNT OVER"),!!,"One moment please..." + D BLDFDA + I $P(^VA(200,DA,0),U,3)']"" S XUNEW=1 ;if no access code treat as new + I $P($G(^VA(200,DA,.1)),U,2)']"" S XUNEW=1 ;If no verify code treat as new + S (XUU,XUU2)="unchanged",$P(^VA(200,DA,0),U,11)=XUTERMDT + I XUNEW D ACODE S @XFDA@(200,DA_",",2)=XUH D VCODE S @XFDA@(200,DA_",",11)=XUH2 + D UPDATE^DIE("",XFDA,XIEN,"XERR") K @XFDA + I XUNEW,XUTEXT>0 D LET(DA,XUTEXT) + I $D(^XMB(3.7,DA,0))[0 S Y=DA K XMZ D NEW^XM K XMDT,XMM,XMZ + Q + ; +BLDFDA ;Build the FDA + S XFDA="^TMP($J,""XFDA"")",XIEN="^TMP($J,""XIEN"")" K ^TMP($J) + ;Move piece on nodes from list, Build XU only once + F X2=1:1 S XUNODE=$P($T(DATA+X2),";;",2) Q:XUNODE="" D + . F X3=1:1 S X7=$P(XUNODE,U,X3) Q:X7="" S X4=$$GETDD(200,X7),X5=$P(X4,";"),X6=$P(X4,";",2) D + . . I '$D(XU(2,X5)) S XU(2,X5)=$G(^VA(200,XUTMP,X5)) + . . S:$P(XU(2,X5),U,X6)]"" @XFDA@(200,DA_",",X7)=$P(XU(2,X5),U,X6) + . . Q + . Q + D SUBFILE + Q + ; +GETDD(FI,FE) ;Return node;piece for a field + Q $P($G(^DD(FI,FE,0)),U,4) + ; +DATA ;;field# + ;;3^8^15^29^28 + ;;200.04^200.05^200.06^200.09^200.1^201^ + ;;41^41.1^41.2 + ;;101.01^101.02 + ;;9.21^9.22 + ;; + ; +ACODE ; + F Z=0:0 S XUU=$$AC^XUS4(),XUH=$$EN^XUSHSH(XUU) Q:'($D(^VA(200,"AOLD",XUH))!$D(^VA(200,"A",XUH))) + Q + ; +VCODE ; + S XUU2=$$VC^XUS4(),XUH2=$$EN^XUSHSH(XUU2) + Q + ; +SUBFILE ;Move subfiles: Subscript, Subfile#, DINUM, Fields + N XCNT S XCNT=0 +KEY D MULTI(51,200.051,1,".01,3") +PATH ;D MULTI(19.8,".01") +FOF D MULTI("FOF",200.032,1,".01,1,2,3,4,5,6") +DIV D MULTI(2,200.02,1,".01") +SEC D MULTI(203,200.03,0,".01,2") +TAB D MULTI("ORD",200.010113,0,".01,.02,.03") +PSCLSS I $P($G(XUSER(XU1)),U,5)=1 D PRSNCL(DA) + Q + ; +MULTI(XSS,XSF,XDN,XDD) ;Build new data + I XUPURGE D CLEAR(DA,XSS) + Q:'$D(^VA(200,XUTMP,XSS,0)) + ;S X=^(0),Y=$S($D(^VA(200,DA,X2,0)):^(0),1:"") + F X1=0:0 S X1=$O(^VA(200,XUTMP,XSS,X1)) Q:X1'>0 S X=^(X1,0) D + . F X2=1:1 S X3=$P(XDD,",",X2) Q:X3="" D + . . I X3'=.01 S @XFDA@(XSF,"?+"_XCNT_","_DA_",",X3)=$$VAL(X,X3,XSF) Q + . . S XCNT=XCNT+1,@XFDA@(XSF,"?+"_XCNT_","_DA_",",.01)=$P(X,U,1) + . . S:XDN @XIEN@(XCNT)=X1 + . . Q + . Q + Q + ; +VAL(V,FE,FI) ;Get value + N % S %=$$GETDD(FI,FE),%=$P(%,";",2) Q $P(V,"^",%) + ; +LET(DA,XUTEXT) ;Write access letter + N DIWF,FR,TO,BY + S DIWF="^DIC(9.2,"_XUTEXT_",1,",DIWF(1)=200,FR=DA,TO=DA,BY="NUMBER",IOP=XUIOP D EN2^DIWF + Q + ; +CLEAR(X4,X2) ;Clear subfile first, IEN, Subscript + Q:$D(^VA(200,X4,X2,0))[0 N C,XUFN,XDEL,XMSG + S C=",",XDEL=$NA(^TMP($J,"XUBLK2")),XUFN=+$P(^VA(200,X4,X2,0),"^",2) + F X1=0:0 S X1=$O(^VA(200,X4,X2,X1)) Q:X1'>0 D + . I X2=51 S %=$$DEL^XQKEY(X4,X1) Q ;Special case for KEYS + . S @XDEL@(XUFN,X1_C_X4_C,.01)="@" + . Q + I $D(@XDEL)>1 D FILE^DIE("",XDEL,"XMSG") ;I $D(XMSG) ZW XMSG + Q + ; +UPDATE(XX,USRIEN) ;Update effective date + N PC,PC1 + S PC=$O(^VA(200,USRIEN,XX,"A"),-1) Q:PC'>0 + S PC=0 F S PC=$O(^VA(200,USRIEN,XX,PC)) Q:PC'>0 D + .S PC1=$P($G(^VA(200,USRIEN,XX,PC,0)),"^",3) + .I (PC1="")!(PC1' The user is locked. Please try this option again." + S $P(^VA(200,USRIEN,XX,PC,0),"^",2)=DT + L -^VA(200,USRIEN,XX,PC,0) + Q + ; +PRSNCL(USERIEN) ; + N XUDATA,XUPSC,XUEFDA,XUEXDA,ZZ + S XUDATA=$O(^VA(200,XUTMP,"USC1","A"),-1) Q:XUDATA'>0 + S XUDATA=$G(^VA(200,XUTMP,"USC1",XUDATA,0)) Q:XUDATA="" + S XUPSC=$P(XUDATA,"^") + S XUEFDA=$P(XUDATA,"^",2) I XUEFDA'>DT S XUEFDA=DT + S XUEXDA=$P(XUDATA,"^",3) + I XUEXDA0 + S XULDATA=$G(^VA(200,USERIEN,"USC1",XULAST,0)) + S XULDATA=$P(XULDATA,"^",3) + Q:XULDATA'>DT + S $P(^VA(200,USERIEN,"USC1",XULAST,0),"^",3)=DT + Q diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSERNEW.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSERNEW.m index 3e323083..9f2c6a03 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSERNEW.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSERNEW.m @@ -1,111 +1,105 @@ -XUSERNEW ;SF/RWF - ADD NEW USER ;5/13/08 17:19 - ;;8.0;KERNEL;**16,49,134,208,157,313,351,419,467,480**;Jul 10, 1995;Build 38 - ;;Per VHA Directive 2004-038, this routine should not be modified - ;In the call to NEW^XM for new users the variable XMZ must be undef. - ;on a reactivation XMZ should be set to the current max message number. -EN ;Add - N Y,XUN,DR,DIE,DA,DTOUT,DIWF,XMDT,XMM,XMZ - S Y=$$ADD("","",1) G EXIT:Y'>0,RE:$P(Y,U,3)'=1 - S XUN=+Y ;XU USER ADD called in $$ADD - S DR="["_$$GET^XUPARAM("XUNEW USER","N")_"]" - S DIE=200,DA=XUN D XUDIE^XUS5 G:$D(DTOUT) EXIT - I $$GET1^DIQ(200,XUN_",",11,"I")="" W !,"Without a VERIFY code the user will not be able to sign-on!",$C(7),! - S Y=XUN K XMZ D NEW^XM K XMDT,XMM,XMZ - ;ACCESS LETTER, Also see XUSERBLK - W ! D LETTER(XUN,1) - K DIR,DIWF,XUTEXT - ; - ;Fall in from above, called from REACT -KEYS N DIR,XQHOLD,XQKEY,XQDA,XQAL,XQ6,XQFL - S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do you wish to allocate security keys" D ^DIR G:$D(DIRUT) EXIT - I Y=1 S XQHOLD(XUN)="",XQKEY(0)=0,XQDA=0,XQAL=1,XQ6="",XQFL="" D KEY^XQ6 - ; - ;Check on adding this user to user groups - I $P(^VA(200,XUN,0),U,3)'="" D ;Must have access code & mailbox - .N DIR,Y - .S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do you wish to add this user to mail groups" D ^DIR Q:$D(DIRUT) - .I Y=1 D ENLOCAL1^XMVGRP(XUN) - .K XMDUN,XMDUZ,XMV - .Q - ; -EXIT K D0,DA,DDER,DDSFILE,DIE,DIC,DIR,DI,DICR,DIG,DIH,DISYS,DIU,DIV,DIWT,DLAYGO,DR,DQ,K,I,X,X1,XQHOLD,XQKEY,XUN,XUSOLD,XMB,XMZ,Y,Z,XQ6,XQFL,DTOUT - Q - ; -RE ;Jump from new user to reactivate - S XUN=+Y,DIR("A")="This isn't a new user, Want to reactivate?",DIR(0)="Y",DIR("B")="NO" - D ^DIR - G EXIT:$D(DIRUT)!(Y'=1),RE2 - ;Reactivate a user -REACT ;SEA/WDE-REACTIVATE A USER - N XUN,XUSOLD,DIE,DIC,DA,DR,FDA - S XUN=+$$LOOKUP^XUSER G EXIT:XUN<0 -RE2 S XUSOLD=^VA(200,XUN,0) - S FDA(200,XUN_",",9.2)="@" ;Clear the Termination date - D UPDATE^DIE("E","FDA") - ;Show the screanman form - S DIE=200,DR="["_$$GET^XUPARAM("XUREACT USER","N")_"]",DA=XUN - D XUDIE^XUS5 G:$D(DTOUT) EXIT - I $P(^VA(200,XUN,0),U,3)="" W !!,"No ACCESS CODE has been entered.",$C(7),! - I $P(^VA(200,XUN,0),U,11)>0,$P(^(0),U,11)'>DT W !!,"User is still TERMINATED.",$C(7),! - I $$GET1^DIQ(200,XUN_",",11,"I")="" W !,"Without a VERIFY code the user will not be able to sign-on!",$C(7),! - N DIR - S DIR(0)="Y",DIR("A")="Deny access to old mail messages",DIR("B")="NO",DIR("?")="Enter a 'YES' to restrict access to old mail messages." - D ^DIR G:$D(DIRUT) EXIT - K XMZ S:Y=1 XMZ=+$P(^XMB(3.9,0),"^",3) S Y=XUN D NEW^XM K XMDT,XMM,XMZ - D REACT^XQ84(XUN) ;See if this user's menu trees need to be rebuilt - G KEYS - Q - ; -ADD(NP1,KEYS,NONC) ;Common point to do DIC call for adding a new person. - ;NP1 will be added to the default or what comes from the NPI field or the KSP. - ;KEYS is a list of Keys to give the new person - N DA,DR,DLAYGO,XUITNAME,XUS1,XUS2,DIC,DIE,DIK,NP2,Y - I $G(^XTV(8989.3,1,"NPI"))]"" X ^("NPI") S NP2=DR - S:'$D(NP2) NP2="1;"_$S($D(^XUSEC("XUSPF200",DUZ)):9,1:"9R~")_";4;41.99" - ;";41.99" is for adding National Provider Identifier - S DIC="^VA(200,",DIC(0)="AELMQ",DLAYGO=200,DIC("A")="Enter NEW PERSON's name (Family,Given Middle Suffix): ",DIC("DR")="",XUITNAME=1 - D ^DIC S XUS1=Y G AX:(Y'>0)!($P(Y,U,3)'>0) - S DA=+$G(^VA(200,+XUS1,3.1)) I DA,'$G(NONC) D - . W !,"Name components." - . S DIE="^VA(20,",DR="1;2;3;5" - . L +^VA(20,DA,0):60 D ^DIE L -^VA(20,DA,0) - . I $D(Y)!$D(DTOUT) S DA=+XUS1,XUS1=-1 - . E S $P(XUS1,U,2)=$P(^VA(200,+XUS1,0),U) - D:XUS1>0 - . W !,"Now for the Identifiers." - . S DA=+XUS1,DIE="^VA(200,",DR=NP2_$S($D(NP1):";"_NP1,1:""),DIE("NO^")="OUTOK" - . L +^VA(200,DA,0):60 D ^DIE L -^VA(200,DA,0) - . S:$D(Y)!$D(DTOUT) XUS1=-1 - I XUS1<0 D S XUS1=-1 - . W !?5,"<'",$P(^VA(200,DA,0),U),"' DELETED>" - . S DIK="^VA(200," D ^DIK - . Q:$P($G(^DIC(3,0)),U)'="USER"!'$D(^DD(3,0)) - . S DIK="^DIC(3,",XUS1=$P($G(^DIC(3,DA,0)),U,16) D ^DIK - . Q:'XUS1!($P($G(^DIC(16,0)),U)'="PERSON")!'$D(^DD(16,0)) - . S DIK="^DIC(16,",DA=XUS1 D ^DIK - N XUSNPI S XUSNPI=$P($G(^VA(200,DA,"NPI")),"^") - I XUS1>0,+XUSNPI>0 D - . S XUSNPI=$$ADDNPI^XUSNPI("Individual_ID",DA,XUSNPI,$$NOW^XLFDT(),1) ;add NPI to multiple - . ; Initialize field 41.97 to 1 (YES) - . Q:+XUSNPI'>0 - . N DIE,DR,DA S DIE="^VA(200,",DA=+XUS1,DR="41.97////1" D ^DIE - . Q - I XUS1>0,$D(KEYS) F XUS2=1:1 S Y=$P(KEYS,",",XUS2) Q:'$L(Y) D - . S %=$$ADD^XQKEY(XUS1,Y) I '% W !,"Key '",Y,"' not allocated" - I XUS1>0 D CALL^XUSERP(+XUS1,1) ;XQOR add -AX Q XUS1 - ; -REPRINT ;Reprint letter - S DA=+$$LOOKUP^XUSER G EXIT:DA'>0 - D LETTER(DA) - G EXIT - ; -LETTER(XUN,ASK) ;Print access letter - Q:'$G(XUN) - N DIWF,FR,TO,BY,DIR,XUTEXT - S XUTEXT=$$GET^XUPARAM("XUSER COMPUTER ACCOUNT","N"),XUTEXT=$O(^DIC(9.2,"B",XUTEXT,0)) - S DIR(0)="Y",DIR("A")="Print User Account Access Letter" - I XUTEXT>0 S Y=1 D:$G(ASK) ^DIR I Y=1 D - . S (XUU,XUU2)="________",DIWF="^DIC(9.2,XUTEXT,1,",DIWF(1)=200,FR=XUN,TO=XUN,BY="NUMBER" D EN2^DIWF - . Q - Q +XUSERNEW ;SF/RWF - ADD NEW USER ;6/27/07 + ;;8.0;KERNEL;**16,49,134,208,157,313,351,419,467**;Jul 10, 1995;Build 12 + ;In the call to NEW^XM for new users the variable XMZ must be undef. + ;on a reactivation XMZ should be set to the current max message number. +EN ;Add + N Y,XUN,DR,DIE,DA,DTOUT,DIWF,XMDT,XMM,XMZ + S Y=$$ADD("","",1) G EXIT:Y'>0,RE:$P(Y,U,3)'=1 + S XUN=+Y ;XU USER ADD called in $$ADD + S DR="["_$$GET^XUPARAM("XUNEW USER","N")_"]" + S DIE=200,DA=XUN D XUDIE^XUS5 G:$D(DTOUT) EXIT + I $$GET1^DIQ(200,XUN_",",11,"I")="" W !,"Without a VERIFY code the user will not be able to sign-on!",$C(7),! + S Y=XUN K XMZ D NEW^XM K XMDT,XMM,XMZ + ;ACCESS LETTER, Also see XUSERBLK + W ! D LETTER(XUN,1) + K DIR,DIWF,XUTEXT + ; + ;Fall in from above, called from REACT +KEYS N DIR,XQHOLD,XQKEY,XQDA,XQAL,XQ6,XQFL + S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do you wish to allocate security keys" D ^DIR G:$D(DIRUT) EXIT + I Y=1 S XQHOLD(XUN)="",XQKEY(0)=0,XQDA=0,XQAL=1,XQ6="",XQFL="" D KEY^XQ6 + ; + ;Check on adding this user to user groups + I $P(^VA(200,XUN,0),U,3)'="" D ;Must have access code & mailbox + .N DIR,Y + .S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do you wish to add this user to mail groups" D ^DIR Q:$D(DIRUT) + .I Y=1 D ENLOCAL1^XMVGRP(XUN) + .K XMDUN,XMDUZ,XMV + .Q + ; +EXIT K D0,DA,DDER,DDSFILE,DIE,DIC,DIR,DI,DICR,DIG,DIH,DISYS,DIU,DIV,DIWT,DLAYGO,DR,DQ,K,I,X,X1,XQHOLD,XQKEY,XUN,XUSOLD,XMB,XMZ,Y,Z,XQ6,XQFL,DTOUT + Q + ; +RE ;Jump from new user to reactivate + S XUN=+Y,DIR("A")="This isn't a new user, Want to reactivate?",DIR(0)="Y",DIR("B")="NO" + D ^DIR + G EXIT:$D(DIRUT)!(Y'=1),RE2 + ;Reactivate a user +REACT ;SEA/WDE-REACTIVATE A USER + N XUN,XUSOLD,DIE,DIC,DA,DR,FDA + S XUN=+$$LOOKUP^XUSER G EXIT:XUN<0 +RE2 S XUSOLD=^VA(200,XUN,0) + S FDA(200,XUN_",",9.2)="@" ;Clear the Termination date + D UPDATE^DIE("E","FDA") + ;Show the screanman form + S DIE=200,DR="["_$$GET^XUPARAM("XUREACT USER","N")_"]",DA=XUN + D XUDIE^XUS5 G:$D(DTOUT) EXIT + I $P(^VA(200,XUN,0),U,3)="" W !!,"No ACCESS CODE has been entered.",$C(7),! + I $P(^VA(200,XUN,0),U,11)>0,$P(^(0),U,11)'>DT W !!,"User is still TERMINATED.",$C(7),! + I $$GET1^DIQ(200,XUN_",",11,"I")="" W !,"Without a VERIFY code the user will not be able to sign-on!",$C(7),! + N DIR + S DIR(0)="Y",DIR("A")="Deny access to old mail messages",DIR("B")="NO",DIR("?")="Enter a 'YES' to restrict access to old mail messages." + D ^DIR G:$D(DIRUT) EXIT + K XMZ S:Y=1 XMZ=+$P(^XMB(3.9,0),"^",3) S Y=XUN D NEW^XM K XMDT,XMM,XMZ + D REACT^XQ84(XUN) ;See if this user's menu trees need to be rebuilt + G KEYS + Q + ; +ADD(NP1,KEYS,NONC) ;Common point to do DIC call for adding a new person. + ;NP1 will be added to the default or what comes from the NPI field of the KSP. + ;KEYS is a list of Keys to give the new person + N DA,DR,DLAYGO,XUITNAME,XUS1,XUS2,DIC,DIE,DIK,NP2,Y + I $G(^XTV(8989.3,1,"NPI"))]"" X ^("NPI") S NP2=DR + S:'$D(NP2) NP2="1;"_$S($D(^XUSEC("XUSPF200",DUZ)):9,1:"9R~")_";4;41.99" + ;";41.99" is for adding National Provider Identifier + S DIC="^VA(200,",DIC(0)="AELMQ",DLAYGO=200,DIC("A")="Enter NEW PERSON's name (Family,Given Middle Suffix): ",DIC("DR")="",XUITNAME=1 + D ^DIC S XUS1=Y G AX:(Y'>0)!($P(Y,U,3)'>0) + S DA=+$G(^VA(200,+XUS1,3.1)) I DA,'$G(NONC) D + . W !,"Name components." + . S DIE="^VA(20,",DR="1;2;3;5" + . L +^VA(20,DA,0):60 D ^DIE L -^VA(20,DA,0) + . I $D(Y)!$D(DTOUT) S DA=+XUS1,XUS1=-1 + . E S $P(XUS1,U,2)=$P(^VA(200,+XUS1,0),U) + D:XUS1>0 + . W !,"Now for the Identifiers." + . S DA=+XUS1,DIE="^VA(200,",DR=NP2_$S($D(NP1):";"_NP1,1:""),DIE("NO^")="OUTOK" + . L +^VA(200,DA,0):60 D ^DIE L -^VA(200,DA,0) + . S:$D(Y)!$D(DTOUT) XUS1=-1 + I XUS1<0 D S XUS1=-1 + . W !?5,"<'",$P(^VA(200,DA,0),U),"' DELETED>" + . S DIK="^VA(200," D ^DIK + . Q:$P($G(^DIC(3,0)),U)'="USER"!'$D(^DD(3,0)) + . S DIK="^DIC(3,",XUS1=$P($G(^DIC(3,DA,0)),U,16) D ^DIK + . Q:'XUS1!($P($G(^DIC(16,0)),U)'="PERSON")!'$D(^DD(16,0)) + . S DIK="^DIC(16,",DA=XUS1 D ^DIK + N XUSNPI S XUSNPI=$P($G(^VA(200,DA,"NPI")),"^") + I XUS1>0,+XUSNPI>0 S XUSNPI=$$ADDNPI^XUSNPI("Individual_ID",DA,XUSNPI,$$NOW^XLFDT(),1) ;add NPI + I XUS1>0,$D(KEYS) F XUS2=1:1 S Y=$P(KEYS,",",XUS2) Q:'$L(Y) D + . S %=$$ADD^XQKEY(XUS1,Y) I '% W !,"Key '",Y,"' not allocated" + I XUS1>0 D CALL^XUSERP(+XUS1,1) ;XQOR add +AX Q XUS1 + ; +REPRINT ;Reprint letter + S DA=+$$LOOKUP^XUSER G EXIT:DA'>0 + D LETTER(DA) + G EXIT + ; +LETTER(XUN,ASK) ;Print access letter + Q:'$G(XUN) + N DIWF,FR,TO,BY,DIR,XUTEXT + S XUTEXT=$$GET^XUPARAM("XUSER COMPUTER ACCOUNT","N"),XUTEXT=$O(^DIC(9.2,"B",XUTEXT,0)) + S DIR(0)="Y",DIR("A")="Print User Account Access Letter" + I XUTEXT>0 S Y=1 D:$G(ASK) ^DIR I Y=1 D + . S (XUU,XUU2)="________",DIWF="^DIC(9.2,XUTEXT,1,",DIWF(1)=200,FR=XUN,TO=XUN,BY="NUMBER" D EN2^DIWF + . Q + Q diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPI.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPI.m index d6e044bc..a7c6f117 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPI.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPI.m @@ -1,201 +1,189 @@ -XUSNPI ;OAK_BP/BDT - NATIONAL PROVIDER IDENTIFIER ;6/3/08 13:51 - ;;8.0;KERNEL;**410,416,480**; July 10, 1995;Build 38 - ;;Per VHA Directive 2004-038, this routine should not be modified -ADDNPI(XUSQI,XUSIEN,XUSNPI,XUSDATE,XUSTATUS) ; - ;;============================================================== - ;; Update the Effective Date, Status & NPI trio. - ;; XUSQI : Qualified Identifier, Required. For examble: Individual_ID Or Organization_ID - ;; XUSIEN : Internal Entry Number. Required. - ;; XUSNPI : National Provider Identifier. Required. - ;; XUSDATE : Active Date. Required. - ;; - ;; If successful, return XUSRTN = IEN of new 42 sub-file entry. - ;; Else return XUSRTN = "-1^ErrorMessage". - ;; ============================================================= - ; - ; Check valid inputs. - N XUSROOT,XUSFNB - S XUSROOT=$$GET^XPAR("PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER",XUSQI) - I $E(XUSROOT)'="^" S XUSROOT="^"_XUSROOT - I XUSROOT="^" Q "-1^Invalid Qualified Identifier" - I $$GLCK(XUSROOT)'>0 Q "-1^Invalid Qualified Identifier" - S XUSFNB=+$P(XUSROOT,"(",2) - I 'XUSFNB Q "-1^No File #" - S XUSFNB=XUSFNB_".42" - I $G(XUSIEN)'>0 Q "-1^Invalid IEN" - ;I (XUSIEN?.N)=0 Q "-1^Invalid IEN" - I ((XUSIEN?.N)!(XUSIEN?.N1"."1N.N))=0 Q "-1^Invalid IEN" - N XUIENCK S XUIENCK=XUSROOT_XUSIEN_","_0_")" I '$D(@XUIENCK) Q "-1^Invalid IEN" - I '$$CHKDGT(XUSNPI) Q "-1^Invalid NPI" - I '$$CHKDT(XUSQI,XUSIEN,XUSDATE) Q "-1^Invalid Effective Date" - I $G(XUSTATUS)="" S XUSTATUS=1 - I (XUSTATUS'=0),(XUSTATUS'=1) Q "-1^Invalid Status" - N CHNPI S CHNPI=$$CHKDGT^XUSNPIE1(XUSNPI,XUSIEN,XUSQI) ; check if NPI is being used. - I CHNPI'=1 Q "-1^The NPI is being used." - ; - ;------------------------------------------------------------------ - N ZZ,XUSRTN,ERRMSG,XUSX S ERRMSG="" - S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_")" - ; Update Effective Date #42 multiple fields - S XUSFNB=$P(XUSROOT,"(",2) - S XUSFNB=+$P(XUSFNB,",") I XUSFNB S XUSFNB=XUSFNB_".042" - S ZZ(1,XUSFNB,"+2,"_XUSIEN_",",.01)=XUSDATE - S ZZ(1,XUSFNB,"+2,"_XUSIEN_",",.02)=XUSTATUS - S ZZ(1,XUSFNB,"+2,"_XUSIEN_",",.03)=XUSNPI - D UPDATE^DIE("","ZZ(1)",,ERRMSG) - I $L(ERRMSG) Q "-1^"_$G(ERRMSG) - S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_"""B"""_","_XUSDATE_","_"""A"""_")" - S XUSRTN=$O(@XUSX,-1) - I '+XUSRTN Q "-1^No entry add" - Q XUSRTN - ; -NPI(XUSQI,XUSIEN,XUSDATE) ; Retrieve the NPI value for a qualified identifier entity. - ;;============================================================== - ;; XUSQI : Qualified Identifier, Required. For examble: Individual_ID Or Organization_ID - ;; XUSIEN : Internal Entry Number of file #4 or #200. Required. - ;; XUSDATE : Active Date. Not Required. Default: 'Today'. - ;; - ;; If current NPI exists, return XUSRTN = 'NPI^EffectiveDate^Status' - ;; If invalid XUSQI or XUSIEN, return '-1^ErrorMessage' - ;; Else return 0 - ;; ============================================================= - ; check valid inputs - I $G(XUSIEN)'>0 Q "-1^Invalid IEN" - ;I (XUSIEN?.N)=0 Q "-1^Invalid IEN" - I ((XUSIEN?.N)!(XUSIEN?.N1"."1N.N))=0 Q "-1^Invalid IEN" - I $G(XUSDATE)="" S XUSDATE=$$NOW^XLFDT - N X,Y,%DT S %DT="T",X=XUSDATE D ^%DT I Y'=XUSDATE Q "-1^Invalid Effective Date" - ;----------------------------------- - N XUSDA,XUSI,XUSRTN,XUSROOT,XUSX,XUSTAT S (XUSDA,XUSRTN)="",XUSTAT="Inactive" - ; get global from Parameter file base on Qualified Identifier. - S XUSROOT=$$GET^XPAR("PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER",XUSQI) - I $E(XUSROOT)'="^" S XUSROOT="^"_XUSROOT - I XUSROOT="^" Q "-1^Invalid Qualified Identifier" - N XUIENCK S XUIENCK=XUSROOT_XUSIEN_","_0_")" I '$D(@XUIENCK) Q "-1^Invalid IEN" - I $$GLCK(XUSROOT)'>0 Q "-1^Invalid Qualified Identifier" - S XUSROOT=XUSROOT_XUSIEN_","_"""NPISTATUS""" - S XUSX=XUSROOT_")" I '$D(@XUSX) Q "-1^No NPI found" - S XUSI=0 F S XUSI=$O(@(XUSROOT_","_"""B"""_","_XUSI_")")) Q:XUSI>XUSDATE!'XUSI - I 'XUSI S XUSX=XUSROOT_","_"""B"""_","_"""A"""_")",XUSDA=$O(@XUSX,-1) - I XUSI>XUSDATE S XUSX=XUSROOT_","_"""B"""_","_XUSI_")",XUSDA=$O(@(XUSX),-1) - I XUSDA="" Q 0 - S XUSDA=XUSROOT_","_"""B"""_","_XUSDA_","_"""A"""_")",XUSDA=$O(@XUSDA,-1) - S XUSRTN=XUSROOT_","_XUSDA_","_0_")" - I '$D(@XUSRTN) Q "-1^Invalid IEN" - I $P($G(@XUSRTN),"^",2)=1 S XUSTAT="Active" - Q $P($G(@XUSRTN),"^",3)_"^"_$P($G(@XUSRTN),"^",1)_"^"_XUSTAT - ; -QI(XUSNPI) ; Retrieve the ALL qualified indentifier entity for an NPI value. - ;;================================================ - ;; XUSNPI : National Provider Identifier. Required - ;; - ;; If qualified identified entity exists, return - ;; 'QualifiedIdentifier^IEN^EffectiveDate^Status;' - ;; If more than one records found, they are separated by ";" - ;; Else return 0 - ;;================================================ - ; check valid NPI - I '$$CHKDGT(XUSNPI) Q "0^Invalid NPI" - N ZZ - D GETLST^XPAR(.ZZ,"PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER") - I ZZ'>0 Q 0 - N XUSI,XUSIEN,XUSROOT,XUSQT,XUSX,XUSRTN,XUSRTN1 S (XUSQT,XUSRTN)=0,XUSRTN1="" - S XUSI=0 F S XUSI=$O(ZZ(XUSI)) Q:'XUSI D - . S XUSROOT=$P(ZZ(XUSI),"^",2),XUSROOT="^"_XUSROOT - . I $$GLCK(XUSROOT)'>0 Q ;check valid global root - . I $E(XUSNPI,1,1)=0 S XUSNPI=""""_XUSNPI_"""" - . S XUSX=XUSROOT_"""NPI42"""_","_XUSNPI_")" Q:'$D(@XUSX) - . S XUSIEN=0 F S XUSX=XUSROOT_"""NPI42"""_","_XUSNPI_","_XUSIEN_")",XUSIEN=$O(@XUSX) Q:XUSIEN'>0 D - . . S XUSRTN=$$SRCHNPI(XUSROOT,XUSIEN,XUSNPI) - . . I +XUSRTN S XUSRTN1=XUSRTN1_$P(ZZ(XUSI),"^")_"^"_XUSRTN_";",XUSQT=XUSQT+1 - I XUSRTN1="" S XUSRTN1=0 - Q XUSRTN1 - ; -GLCK(XUSROOT) ; check valid global root - N XUFNB,ZZ - I $G(XUSROOT)="" Q 0 - S XUFNB=$P(XUSROOT,"(",2),XUFNB=$P(XUFNB,",") - D FILE^DID(XUFNB,"","GLOBAL NAME","ZZ") - Q (XUSROOT=$G(ZZ("GLOBAL NAME"))) - ; -SRCHNPI(XUSROOT,XUSIEN,XUSNPI) ; - I $G(XUSIEN)'>0 Q 0 - I (XUSIEN?.N)=0 Q 0 - N XUSX,XUSRTN S XUSRTN=0 - I $E(XUSNPI,1,1)=0 S XUSNPI=""""_XUSNPI_"""" - S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_"""C"""_","_XUSNPI_")" - I '$D(@XUSX) Q 0 - S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_"""C"""_","_XUSNPI_","_"""A"""_")" - S XUSRTN=$O(@XUSX,-1) - I '+XUSRTN Q 0 - S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_XUSRTN_","_0_")" - I '$D(@XUSX) Q 0 - S XUSRTN=$G(@XUSX) I XUSRTN S XUSRTN=XUSIEN_"^"_$P(XUSRTN,"^")_"^"_$P(XUSRTN,"^",2) - I $P(XUSRTN,"^",3)=1 S $P(XUSRTN,"^",3)="Active" - I $P(XUSRTN,"^",3)=0 S $P(XUSRTN,"^",3)="Inactive" - Q XUSRTN - ; -CHKDGT(XUSNPI) ; - ; Function to validate the format of an NPI number. It checks the - ; length of the number, whether the NPI is numeric, and whether - ; the check digit is valid. - ; - ; Input parameter: - ; NPI - 10-digit NPI number to validate. - ; - ; Output parameter: - ; Boolean value indicating whether the NPI has a valid format - ; - ; NPI must be 10 digits long. - I XUSNPI'?10N Q 0 - Q $E(XUSNPI,10)=$$CKDIGIT($E(XUSNPI,1,9)) - ; -CKDIGIT(XUSNPI) ; - ; Function to calculate and return the check digit of an NPI. - ; The check digit is calculated using the Luhn Formula for - ; Modulus 10 "double-add-double" Check Digit. A value of 24 is - ; added to the total to account for the implied USA (80840) prefix. - ; - N XUSCTOT,XUSCN,XUSCDIG,XUSI - S XUSCTOT=24 - F XUSI=9:-2:1 S XUSCN=2*$E(XUSNPI,XUSI),XUSCTOT=XUSCTOT+$E(XUSCN)+$E(XUSCN,2)+$E(XUSNPI,XUSI-1) - S XUSCDIG=150-XUSCTOT - Q $E(XUSCDIG,$L(XUSCDIG)) - ; -CHKDT(XUSQI,XUSIEN,XUSDATE) ; Check Date - ;;============================================================================ - ;; XUSQI : Qualified Identifier. Required. For examble: "Individual_ID" - ;; XUSIEN : Internal Entry Number. Required. - ;; XUSDATE : The Effective Date value to test. Must be FM date. Required. - ;; - ;; If input passes date comparison, return 1. - ;; Else return 0. - ;;============================================================================ - ; - I $G(XUSIEN)'>0 Q "0^Invalid IEN." - ;I (XUSIEN?.N)=0 Q "0^Invalid IEN." - I ((XUSIEN?.N)!(XUSIEN?.N1"."1N.N))=0 Q "-1^Invalid IEN" - N X,Y,%DT S %DT="T",X=$G(XUSDATE) D ^%DT I Y'=XUSDATE Q "0^Invalid Effective Date. Must be FM Date/Time." - ;----------------------------------- - N XUSROOT,XUSDA - N XUSCRDT S XUSCRDT=$$NOW^XLFDT I XUSDATE>XUSCRDT Q 0 - ; get global from Parameter file base on Qualified Identifier. - S XUSROOT=$$GET^XPAR("PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER",XUSQI) - I $E(XUSROOT)'="^" S XUSROOT="^"_XUSROOT - I XUSROOT="^" Q "0^Invalid Qualified Identifier." - I $$GLCK(XUSROOT)'>0 Q "-1^Invalid Qualified Identifier" - N XUIENCK S XUIENCK=XUSROOT_XUSIEN_","_0_")" I $D(@XUIENCK)'>0 Q "0^Invalid IEN." - S XUSROOT=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_"""B"""_","_"""A"""_")",XUSDA=$O(@XUSROOT,-1) - Q (XUSDATE'0)!($P(X,U,3)'="Active") Q "-1^User has no active NPI" - S X=$P($G(^VA(200,XUSIEN,"NPI")),U,3) - S:X="" X=0 - Q X - ; +XUSNPI ;OAK_BP/BDT - NATIONAL PROVIDER IDENTIFIER; 8/10/06 + ;;8.0;KERNEL;**410,416**; July 10, 1997;Build 5 + ;; +ADDNPI(XUSQI,XUSIEN,XUSNPI,XUSDATE,XUSTATUS) ; + ;;============================================================== + ;; Update the Effective Date, Status & NPI trio. + ;; XUSQI : Qualified Identifier, Required. For examble: Individual_ID Or Organization_ID + ;; XUSIEN : Internal Entry Number. Required. + ;; XUSNPI : National Provider Identifier. Required. + ;; XUSDATE : Active Date. Required. + ;; + ;; If successful, return XUSRTN = IEN of new 42 sub-file entry. + ;; Else return XUSRTN = "-1^ErrorMessage". + ;; ============================================================= + ; + ; Check valid inputs. + N XUSROOT,XUSFNB + S XUSROOT=$$GET^XPAR("PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER",XUSQI) + I $E(XUSROOT)'="^" S XUSROOT="^"_XUSROOT + I XUSROOT="^" Q "-1^Invalid Qualified Identifier" + I $$GLCK(XUSROOT)'>0 Q "-1^Invalid Qualified Identifier" + S XUSFNB=+$P(XUSROOT,"(",2) + I 'XUSFNB Q "-1^No File #" + S XUSFNB=XUSFNB_".42" + I $G(XUSIEN)'>0 Q "-1^Invalid IEN" + ;I (XUSIEN?.N)=0 Q "-1^Invalid IEN" + I ((XUSIEN?.N)!(XUSIEN?.N1"."1N.N))=0 Q "-1^Invalid IEN" + N XUIENCK S XUIENCK=XUSROOT_XUSIEN_","_0_")" I '$D(@XUIENCK) Q "-1^Invalid IEN" + I '$$CHKDGT(XUSNPI) Q "-1^Invalid NPI" + I '$$CHKDT(XUSQI,XUSIEN,XUSDATE) Q "-1^Invalid Effective Date" + I $G(XUSTATUS)="" S XUSTATUS=1 + I (XUSTATUS'=0),(XUSTATUS'=1) Q "-1^Invalid Status" + N CHNPI S CHNPI=$$CHKDGT^XUSNPIE1(XUSNPI,XUSIEN,XUSQI) ; check if NPI is being used. + I CHNPI'=1 Q "-1^The NPI is being used." + ; + ;------------------------------------------------------------------ + N ZZ,XUSRTN,ERRMSG,XUSX S ERRMSG="" + S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_")" + ; Update Effective Date #42 multiple fields + S XUSFNB=$P(XUSROOT,"(",2) + S XUSFNB=+$P(XUSFNB,",") I XUSFNB S XUSFNB=XUSFNB_".042" + S ZZ(1,XUSFNB,"+2,"_XUSIEN_",",.01)=XUSDATE + S ZZ(1,XUSFNB,"+2,"_XUSIEN_",",.02)=XUSTATUS + S ZZ(1,XUSFNB,"+2,"_XUSIEN_",",.03)=XUSNPI + D UPDATE^DIE("","ZZ(1)",,ERRMSG) + I $L(ERRMSG) Q "-1^"_$G(ERRMSG) + S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_"""B"""_","_XUSDATE_","_"""A"""_")" + S XUSRTN=$O(@XUSX,-1) + I '+XUSRTN Q "-1^No entry add" + Q XUSRTN + ; +NPI(XUSQI,XUSIEN,XUSDATE) ; Retrieve the NPI value for a qualified identifier entity. + ;;============================================================== + ;; XUSQI : Qualified Identifier, Required. For examble: Individual_ID Or Organization_ID + ;; XUSIEN : Internal Entry Number of file #4 or #200. Required. + ;; XUSDATE : Active Date. Not Required. Default: 'Today'. + ;; + ;; If current NPI exists, return XUSRTN = 'NPI^EffectiveDate^Status' + ;; If invalid XUSQI or XUSIEN, return '-1^ErrorMessage' + ;; Else return 0 + ;; ============================================================= + ; check valid inputs + I $G(XUSIEN)'>0 Q "-1^Invalid IEN" + ;I (XUSIEN?.N)=0 Q "-1^Invalid IEN" + I ((XUSIEN?.N)!(XUSIEN?.N1"."1N.N))=0 Q "-1^Invalid IEN" + I $G(XUSDATE)="" S XUSDATE=$$NOW^XLFDT + N X,Y,%DT S %DT="T",X=XUSDATE D ^%DT I Y'=XUSDATE Q "-1^Invalid Effective Date" + ;----------------------------------- + N XUSDA,XUSI,XUSRTN,XUSROOT,XUSX,XUSTAT S (XUSDA,XUSRTN)="",XUSTAT="Inactive" + ; get global from Parameter file base on Qualified Identifier. + S XUSROOT=$$GET^XPAR("PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER",XUSQI) + I $E(XUSROOT)'="^" S XUSROOT="^"_XUSROOT + I XUSROOT="^" Q "-1^Invalid Qualified Identifier" + N XUIENCK S XUIENCK=XUSROOT_XUSIEN_","_0_")" I '$D(@XUIENCK) Q "-1^Invalid IEN" + I $$GLCK(XUSROOT)'>0 Q "-1^Invalid Qualified Identifier" + S XUSROOT=XUSROOT_XUSIEN_","_"""NPISTATUS""" + S XUSX=XUSROOT_")" I '$D(@XUSX) Q "-1^No NPI found" + S XUSI=0 F S XUSI=$O(@(XUSROOT_","_"""B"""_","_XUSI_")")) Q:XUSI>XUSDATE!'XUSI + I 'XUSI S XUSX=XUSROOT_","_"""B"""_","_"""A"""_")",XUSDA=$O(@XUSX,-1) + I XUSI>XUSDATE S XUSX=XUSROOT_","_"""B"""_","_XUSI_")",XUSDA=$O(@(XUSX),-1) + I XUSDA="" Q 0 + S XUSDA=XUSROOT_","_"""B"""_","_XUSDA_","_"""A"""_")",XUSDA=$O(@XUSDA,-1) + S XUSRTN=XUSROOT_","_XUSDA_","_0_")" + I '$D(@XUSRTN) Q "-1^Invalid IEN" + I $P($G(@XUSRTN),"^",2)=1 S XUSTAT="Active" + Q $P($G(@XUSRTN),"^",3)_"^"_$P($G(@XUSRTN),"^",1)_"^"_XUSTAT + ; +QI(XUSNPI) ; Retrieve the ALL qualified indentifier entity for an NPI value. + ;;================================================ + ;; XUSNPI : National Provider Identifier. Required + ;; + ;; If qualified identified entity exists, return + ;; 'QualifiedIdentifier^IEN^EffectiveDate^Status;' + ;; If more than one records found, they are separated by ";" + ;; Else return 0 + ;;================================================ + ; check valid NPI + I '$$CHKDGT(XUSNPI) Q "0^Invalid NPI" + N ZZ + D GETLST^XPAR(.ZZ,"PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER") + I ZZ'>0 Q 0 + N XUSI,XUSIEN,XUSROOT,XUSQT,XUSX,XUSRTN,XUSRTN1 S (XUSQT,XUSRTN)=0,XUSRTN1="" + S XUSI=0 F S XUSI=$O(ZZ(XUSI)) Q:'XUSI D + . S XUSROOT=$P(ZZ(XUSI),"^",2),XUSROOT="^"_XUSROOT + . I $$GLCK(XUSROOT)'>0 Q ;check valid global root + . I $E(XUSNPI,1,1)=0 S XUSNPI=""""_XUSNPI_"""" + . S XUSX=XUSROOT_"""NPI42"""_","_XUSNPI_")" Q:'$D(@XUSX) + . S XUSIEN=0 F S XUSX=XUSROOT_"""NPI42"""_","_XUSNPI_","_XUSIEN_")",XUSIEN=$O(@XUSX) Q:XUSIEN'>0 D + . . S XUSRTN=$$SRCHNPI(XUSROOT,XUSIEN,XUSNPI) + . . I +XUSRTN S XUSRTN1=XUSRTN1_$P(ZZ(XUSI),"^")_"^"_XUSRTN_";",XUSQT=XUSQT+1 + I XUSRTN1="" S XUSRTN1=0 + Q XUSRTN1 + ; +GLCK(XUSROOT) ; check valid global root + N XUFNB,ZZ + I $G(XUSROOT)="" Q 0 + S XUFNB=$P(XUSROOT,"(",2),XUFNB=$P(XUFNB,",") + D FILE^DID(XUFNB,"","GLOBAL NAME","ZZ") + Q (XUSROOT=$G(ZZ("GLOBAL NAME"))) + ; +SRCHNPI(XUSROOT,XUSIEN,XUSNPI) ; + I $G(XUSIEN)'>0 Q 0 + I (XUSIEN?.N)=0 Q 0 + N XUSX,XUSRTN S XUSRTN=0 + I $E(XUSNPI,1,1)=0 S XUSNPI=""""_XUSNPI_"""" + S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_"""C"""_","_XUSNPI_")" + I '$D(@XUSX) Q 0 + S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_"""C"""_","_XUSNPI_","_"""A"""_")" + S XUSRTN=$O(@XUSX,-1) + I '+XUSRTN Q 0 + S XUSX=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_XUSRTN_","_0_")" + I '$D(@XUSX) Q 0 + S XUSRTN=$G(@XUSX) I XUSRTN S XUSRTN=XUSIEN_"^"_$P(XUSRTN,"^")_"^"_$P(XUSRTN,"^",2) + I $P(XUSRTN,"^",3)=1 S $P(XUSRTN,"^",3)="Active" + I $P(XUSRTN,"^",3)=0 S $P(XUSRTN,"^",3)="Inactive" + Q XUSRTN + ; +CHKDGT(XUSNPI) ; + ; Function to validate the format of an NPI number. It checks the + ; length of the number, whether the NPI is numeric, and whether + ; the check digit is valid. + ; + ; Input parameter: + ; NPI - 10-digit NPI number to validate. + ; + ; Output parameter: + ; Boolean value indicating whether the NPI has a valid format + ; + ; NPI must be 10 digits long. + I XUSNPI'?10N Q 0 + Q $E(XUSNPI,10)=$$CKDIGIT($E(XUSNPI,1,9)) + ; +CKDIGIT(XUSNPI) ; + ; Function to calculate and return the check digit of an NPI. + ; The check digit is calculated using the Luhn Formula for + ; Modulus 10 "double-add-double" Check Digit. A value of 24 is + ; added to the total to account for the implied USA (80840) prefix. + ; + N XUSCTOT,XUSCN,XUSCDIG,XUSI + S XUSCTOT=24 + F XUSI=9:-2:1 S XUSCN=2*$E(XUSNPI,XUSI),XUSCTOT=XUSCTOT+$E(XUSCN)+$E(XUSCN,2)+$E(XUSNPI,XUSI-1) + S XUSCDIG=150-XUSCTOT + Q $E(XUSCDIG,$L(XUSCDIG)) + ; +CHKDT(XUSQI,XUSIEN,XUSDATE) ; Check Date + ;;============================================================================ + ;; XUSQI : Qualified Identifier. Required. For examble: "Individual_ID" + ;; XUSIEN : Internal Entry Number. Required. + ;; XUSDATE : The Effective Date value to test. Must be FM date. Required. + ;; + ;; If input passes date comparison, return 1. + ;; Else return 0. + ;;============================================================================ + ; + I $G(XUSIEN)'>0 Q "0^Invalid IEN." + ;I (XUSIEN?.N)=0 Q "0^Invalid IEN." + I ((XUSIEN?.N)!(XUSIEN?.N1"."1N.N))=0 Q "-1^Invalid IEN" + N X,Y,%DT S %DT="T",X=$G(XUSDATE) D ^%DT I Y'=XUSDATE Q "0^Invalid Effective Date. Must be FM Date/Time." + ;----------------------------------- + N XUSROOT,XUSDA + N XUSCRDT S XUSCRDT=$$NOW^XLFDT I XUSDATE>XUSCRDT Q 0 + ; get global from Parameter file base on Qualified Identifier. + S XUSROOT=$$GET^XPAR("PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER",XUSQI) + I $E(XUSROOT)'="^" S XUSROOT="^"_XUSROOT + I XUSROOT="^" Q "0^Invalid Qualified Identifier." + I $$GLCK(XUSROOT)'>0 Q "-1^Invalid Qualified Identifier" + N XUIENCK S XUIENCK=XUSROOT_XUSIEN_","_0_")" I $D(@XUIENCK)'>0 Q "0^Invalid IEN." + S XUSROOT=XUSROOT_XUSIEN_","_"""NPISTATUS"""_","_"""B"""_","_"""A"""_")",XUSDA=$O(@XUSROOT,-1) + Q (XUSDATE'(XVALTIME_".19"),XVAL<(XVALTIME_".1958") D ; 7 PM TO 7:58 PM ON 1ST OF MONTH - . S OPT=$$FIND1^DIC(19.2,"","","XUS NPI CBO LIST") I OPT'>0 L +^TMP("XUS NPI CBO LOCK"):0 Q:'$T D CBOQUEUE L -^TMP("XUS NPI CBO LOCK") Q - . S DATETIME=$$GET1^DIQ(19.2,OPT_",",2) - . I DATETIME'=$$FMTE^XLFDT(DT_".2") L +^DIC(19.2,OPT):0 Q:'$T D SETQUEUE(OPT,DT_".2") L -^DIC(19.2,OPT) Q - . I '$$GET1^DIQ(19.2,OPT_",",99.1) L +^DIC(19.2,OPT):0 Q:'$T D L -^DIC(19.2,OPT) - . . D SETQUEUE(OPT,"@") - . . D SETQUEUE(OPT,DT_".2") - . . Q - . Q - Q - ; -SETQUEUE(OPT,VALUE) ; - N FDA S FDA(19.2,OPT_",",2)=VALUE D FILE^DIE("","FDA") - Q - ; -POSTINIT ; - N XUGLOB,XUUSER,XIEN,X,ZTDESC,ZTDTH,ZTIO,ZTRTN - ;S XIEN=$$FIND1^DIC(19,"","","XUCOMMAND") I XIEN>0,$$FIND1^DIC(19.01,","_XIEN_",","","XUS NPI PROVIDER SELF ENTRY")'>0 S X=$$ADD^XPDMENU("XUCOMMAND","XUS NPI PROVIDER SELF ENTRY","NPI","") - ;S XIEN=$$FIND1^DIC(19,"","","XU USER SIGN-ON") I XIEN>0,$$FIND1^DIC(19.01,","_XIEN_",","","XUS NPI SIGNON CHECK")'>0 S X=$$ADD^XPDMENU("XU USER SIGN-ON","XUS NPI SIGNON CHECK","","") - ; get global containing Taxonomy values - S XUGLOB=$$CHKGLOB^XUSNPIED() - ; go through file 200 and ma - S XUUSER=0 F S XUUSER=$O(^VA(200,XUUSER)) Q:XUUSER'>0 I $$ACTIVE^XUSER(XUUSER) D DOUSER^XUSNPIED(XUUSER,XUGLOB) - ; and send CBO a starting point list - ;S ZTIO="",ZTDTH=$$NOW^XLFDT(),ZTRTN="CBOLIST^XUSNPIED",ZTDESC="XUS NPI CBOLIST MESSAGE GENERATION" D ^%ZTLOAD - ; set up to generate CBO list monthly - D CBOQUEUE - Q - ; -CBOQUEUE ; - N FDA,XUSVAL - ; check for already queued - S XUSVAL=$$FIND1^DIC(19.2,"","","XUS NPI CBO LIST") I XUSVAL>0 D Q - . S FDA(19.2,XUSVAL_",",2)=$$SETDATE() - . S FDA(19.2,XUSVAL_",",6)="1M(1@2000,15@2000)" - . N ZTQUEUED S ZTQUEUED=1 D FILE^DIE("","FDA") K ZTQUEUED - . Q - ; no set up queued job - S XUSVAL=$$FIND1^DIC(19,"","","XUS NPI CBO LIST") Q:XUSVAL'>0 S FDA(19.2,"+1,",.01)=XUSVAL - S FDA(19.2,"+1,",2)=$$SETDATE() - S FDA(19.2,"+1,",6)="1M(1@2000,15@2000)" - N ZTQUEUED S ZTQUEUED=1 D UPDATE^DIE("","FDA") K ZTQUEUED - Q - ; -SETDATE() ; - Q $S($E($$NOW^XLFDT(),6,10)<1.2:DT,$E($$NOW^XLFDT(),6,10)<15.2:$E(DT,1,5)_"15",$E(DT,4,5)>11:(($E(DT,1,3)+1)_"0101"),1:($E(DT,1,5)+1)_"01")_".2" - ; -CHKOLD1(IEN) ; - D CHKOLD1^XUSNPIE2(IEN) - Q - ; -CLERXMPT ; - D CLERXMPT^XUSNPIE2 - Q - ; -CHKDGT(XUSNPI,XUSDA,XUSQI) ; INPUT TRANSFORM - N XUS S XUS=$$CHKDGT^XUSNPI(XUSNPI) - I XUS'>0 Q 0 - N XUSQIK S XUSQIK=$$QI^XUSNPI(XUSNPI) I XUSQIK=0 Q 1 - ; Check whether NPI is already being used. If so, issue error or warning. - N NPIUSED,XUSRSLT - S NPIUSED=$$NPIUSED^XUSNPI1(XUSNPI,XUSQI,XUSQIK,XUSDA,.XUSRSLT,1) - ; If an error was encountered, quit 0. - I NPIUSED=1 Q 0 - ; If a warning was encountered, quit 1 (Person on file 200 and 355.93 can share NPI) - I NPIUSED=2 Q 1 - ; If current provider previously had this NPI, make sure the NPI being added is the most - ; current one in the EFFECTIVE DATE/TIME multiple (history). - N XUSROOT S XUSROOT=$$GET^XPAR("PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER",XUSQI) - I $E(XUSROOT)'="^" S XUSROOT="^"_XUSROOT - N XUS1 S XUS1=XUSROOT_XUSDA_","_"""NPISTATUS"""_","_"""A"""_")" - N XUS2 S XUS2=$O(@XUS1,-1) I XUS2'>0 Q 1 - S XUS1=XUSROOT_XUSDA_","_"""NPISTATUS"""_","_XUS2_","_0_")" - S XUS2=$G(@XUS1) I $P(XUS2,"^",3)=XUSNPI Q 1 - Q 0 +XUSNPIE1 ;FO-OAKLAND/JLI - NATIONAL PROVIDER IDENTIFIER DATA CAPTURE ;05/02/07 + ;;8.0;KERNEL;**420,410,435,454,462**; July 10, 1995;Build 3 + ; + Q + ; +SET(XUSIEN,XUSNPI) ; + ; set value for NPI field (#41.99) in file #200 + N OLDNPI S OLDNPI=$P($G(^VA(200,XUSIEN,"NPI")),"^") + I OLDNPI K ^VA(200,"ANPI",OLDNPI,XUSIEN) + S ^VA(200,XUSIEN,"NPI")=XUSNPI_U_"D",^VA(200,"ANPI",XUSNPI,XUSIEN)="" + Q + ; +SET1(XUSIEN,XUSNPI) ; + ; set value for NPI field (#41.99) in file #4 + N OLDNPI S OLDNPI=$P($G(^DIC(4,XUSIEN,"NPI")),"^") + I OLDNPI K ^DIC(4,"ANPI",OLDNPI,XUSIEN) + S ^DIC(4,XUSIEN,"NPI")=XUSNPI,^DIC(4,"ANPI",XUSNPI,XUSIEN)="" + Q + ; +SIGNON ; .ACT - run at user sign-on display message if NEEDS AN NPI + N XVAL,DATETIME,OPT,XVALTIME + I $$CHEKNPI^XUSNPIED(DUZ) W !!,"To enter your NPI value enter NPI at a menu prompt to jump to the",!,"edit option.",! H 1 + ; following to insure CBO List is scheduled to run on first day of month + S XVALTIME=$E(DT,6,7) I '((XVALTIME="01")!(XVALTIME="15")) Q + S XVAL=+$E($$NOW^XLFDT(),6,10) I XVAL>(XVALTIME_".19"),XVAL<(XVALTIME_".1958") D ; 7 PM TO 7:58 PM ON 1ST OF MONTH + . S OPT=$$FIND1^DIC(19.2,"","","XUS NPI CBO LIST") I OPT'>0 L +^TMP("XUS NPI CBO LOCK"):0 Q:'$T D CBOQUEUE L -^TMP("XUS NPI CBO LOCK") Q + . S DATETIME=$$GET1^DIQ(19.2,OPT_",",2) + . I DATETIME'=$$FMTE^XLFDT(DT_".2") L +^DIC(19.2,OPT):0 Q:'$T D SETQUEUE(OPT,DT_".2") L -^DIC(19.2,OPT) Q + . I '$$GET1^DIQ(19.2,OPT_",",99.1) L +^DIC(19.2,OPT):0 Q:'$T D L -^DIC(19.2,OPT) + . . D SETQUEUE(OPT,"@") + . . D SETQUEUE(OPT,DT_".2") + . . Q + . Q + Q + ; +SETQUEUE(OPT,VALUE) ; + N FDA S FDA(19.2,OPT_",",2)=VALUE D FILE^DIE("","FDA") + Q + ; +POSTINIT ; + N XUGLOB,XUUSER,XIEN,X,ZTDESC,ZTDTH,ZTIO,ZTRTN + ;S XIEN=$$FIND1^DIC(19,"","","XUCOMMAND") I XIEN>0,$$FIND1^DIC(19.01,","_XIEN_",","","XUS NPI PROVIDER SELF ENTRY")'>0 S X=$$ADD^XPDMENU("XUCOMMAND","XUS NPI PROVIDER SELF ENTRY","NPI","") + ;S XIEN=$$FIND1^DIC(19,"","","XU USER SIGN-ON") I XIEN>0,$$FIND1^DIC(19.01,","_XIEN_",","","XUS NPI SIGNON CHECK")'>0 S X=$$ADD^XPDMENU("XU USER SIGN-ON","XUS NPI SIGNON CHECK","","") + ; get global containing Taxonomy values + S XUGLOB=$$CHKGLOB^XUSNPIED() + ; go through file 200 and ma + S XUUSER=0 F S XUUSER=$O(^VA(200,XUUSER)) Q:XUUSER'>0 I $$ACTIVE^XUSER(XUUSER) D DOUSER^XUSNPIED(XUUSER,XUGLOB) + ; and send CBO a starting point list + ;S ZTIO="",ZTDTH=$$NOW^XLFDT(),ZTRTN="CBOLIST^XUSNPIED",ZTDESC="XUS NPI CBOLIST MESSAGE GENERATION" D ^%ZTLOAD + ; set up to generate CBO list monthly + D CBOQUEUE + Q + ; +CBOQUEUE ; + N FDA,XUSVAL + ; check for already queued + S XUSVAL=$$FIND1^DIC(19.2,"","","XUS NPI CBO LIST") I XUSVAL>0 D Q + . S FDA(19.2,XUSVAL_",",2)=$$SETDATE() + . S FDA(19.2,XUSVAL_",",6)="1M(1@2000,15@2000)" + . N ZTQUEUED S ZTQUEUED=1 D FILE^DIE("","FDA") K ZTQUEUED + . Q + ; no set up queued job + S XUSVAL=$$FIND1^DIC(19,"","","XUS NPI CBO LIST") Q:XUSVAL'>0 S FDA(19.2,"+1,",.01)=XUSVAL + S FDA(19.2,"+1,",2)=$$SETDATE() + S FDA(19.2,"+1,",6)="1M(1@2000,15@2000)" + N ZTQUEUED S ZTQUEUED=1 D UPDATE^DIE("","FDA") K ZTQUEUED + Q + ; +SETDATE() ; + Q $S($E($$NOW^XLFDT(),6,10)<1.2:DT,$E($$NOW^XLFDT(),6,10)<15.2:$E(DT,1,5)_"15",$E(DT,4,5)>11:(($E(DT,1,3)+1)_"0101"),1:($E(DT,1,5)+1)_"01")_".2" + ; +EDITNPI(IEN) ; main entry of NPI value + ; IEN is the internal entry number in file 200 for the provider + ; + N DATEVAL,DESCRIP,DONE,NPIVAL1,NPIVAL2,PROVNAME,XX,Y,CURRNPI + N ODATEVAL,OIEN,OLDNPI,XUSNONED,DIR,ADDNPI,DELETNPI,NOOLDNPI,XUSQI + S ADDNPI=1,DELETNPI=2,NOOLDNPI=0 + S PROVNAME=$$GET1^DIQ(200,IEN_",",.01) + ;I $$ACTIVE^XUSER(IEN) W !,"This user isn't currently active" Q + I $$GETTAXON^XUSNPIED(IEN,.DESCRIP)=-1 W !,"This user doesn't have a Taxonomy Code indicating a need for an NPI." S XUSNONED=1 ; but don't quit on that + I $$NPISTATS^XUSNPIED(IEN)="D" S XUSNONED=1 + I $$NPISTATS^XUSNPIED(IEN)="E" W !,"This provider has been indicated as being EXEMPT from needing an NPI value.",!," Use Exempt option to remove it first" Q + S OLDNPI=NOOLDNPI I $$NPISTATS^XUSNPIED(IEN)="D" D Q:OLDNPI=NOOLDNPI ; exit without changing + . N I,X,DIR + . S CURRNPI=$$GET1^DIQ(200,IEN_",",41.99) I CURRNPI="" Q + . S OIEN=$$SRCHNPI^XUSNPI("^VA(200,",IEN,CURRNPI) I OIEN>0 S ODATEVAL=$P(OIEN,U,2),OIEN=$O(^VA(200,IEN,"NPISTATUS","C",CURRNPI,"A"),-1) + . I '$D(ODATEVAL) S OLDNPI=2 ; can't find entry in multiple, delete entry at top + . W !,"This provider already has an NPI value (",CURRNPI,") entered." + . ;S DIR(0)="Y",DIR("A")="Do you want to ADD a new NPI value as the active one",DIR("B")="NO" D ^DIR S OLDNPI=Y Q:OLDNPI + . ;K DIR S DIR(0)="Y",DIR("A")="Do you REALLY want to **DELETE** this NPI value",DIR("B")="NO" D ^DIR I Y S OLDNPI=2 + . S DIR(0)="S^D:Delete;R:Replace",DIR("A")="Do you want to (D)elete or (R)eplace this NPI value?",DIR("?")="Enter either D or R or ^ to quit with out editing" + . S DIR("?",1)="If the value was entered for the incorrect individual, it should be Deleted.",DIR("?",2)="Otherwise it should be Replaced" + . D ^DIR K DIR Q:"DR"'[Y I Y="R" S OLDNPI=ADDNPI Q + . S DIR(0)="S^V:VALID;E:ERROR",DIR("A",1)="Was the original NPI (V)alid for this provider",DIR("A")="or was it entered in (E)rror?",DIR("?")="Enter either V or E or ^ to quit with out editing" + . S DIR("?",1)="If the NPI value was entered for the incorrect individual, respond E,",DIR("?",2)="otherwise enter V" + . D ^DIR K DIR Q:"EV"'[Y I Y="V" S Y=$$ADDNPI^XUSNPI("Individual_ID",IEN,CURRNPI,$$NOW^XLFDT(),0) D S OLDNPI=NOOLDNPI Q + . . W !,$S(Y>-1:"Entry has been marked inactive.",1:$P(Y,U,2)),! Q:+Y=-1 + . . N XUFDA S XUFDA(200,IEN_",",41.98)="@",XUFDA(200,IEN_",",41.99)="@" D FILE^DIE("","XUFDA") S Y=$$CHEKNPI^XUSNPIED(IEN) + . . Q + . S OLDNPI=DELETNPI + . Q + I $$CHEKNPI^XUSNPIED(IEN)=0,OLDNPI=0 W !,"Need for an NPI value isn't indicated - but you can enter an NPI",$C(7) + I IEN'=DUZ W !,"Provider: ",PROVNAME," ","XXX-XX-"_$E($$GET1^DIQ(200,IEN_",",9),6,9)," DOB: " S XX=$P($G(^VA(200,IEN,1)),U,3) S:XX'="" XX=$$DATE10^XUSNPIED(XX) W XX + ;I IEN'=DUZ W !,"Status: Active" + S DONE=0 I OLDNPI'=DELETNPI F R !,"Enter NPI (10 digits): ",NPIVAL1:DTIME Q:'$T Q:NPIVAL1="" Q:NPIVAL1=U D Q:DONE + . I NPIVAL1'?10N D Q + . . W !,$C(7),"Enter a 10 digit National Provider Identifier which is obtained ",!,"from 'https://nppes.cms.hhs.gov/NPPES/Welcome.do'" + . . Q:$$PROD^XUPROD() W ! K DIR S DIR(0)="Y",DIR("A")="Do you want to generate a test NPI value" D ^DIR Q:'Y + . . R !,"Enter a nine (9) digit number as the base: ",Y:DTIME Q:Y'?9N + . . W !,"The complete NPI value is: ",Y_$$CKDIGIT^XUSNPI(Y),! + . . Q + . S XUSQI=$$QI^XUSNPI(NPIVAL1) I +XUSQI=0,$P(XUSQI,U,2)="Invalid NPI" W !,"NPI values have a specific structure to validate them...",!,"The Checksum for this entry is not valid",! Q + . I XUSQI'=0 N ZZ,DONE1 S DONE1=0 D GETLST^XPAR(.ZZ,"PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER") D Q:DONE1 + . . S ZZ="" F S ZZ=$O(ZZ(ZZ)) Q:ZZ'>0 I $P(ZZ(ZZ),U)=$P(XUSQI,U) W !,"That NPI value is already associated with "_$P(@("^"_$P(ZZ(ZZ),U,2)_$P(XUSQI,U,2)_",0)"),U) S DONE1=1 Q + . . Q + . R !,"Please re-enter NPI : ",NPIVAL2:DTIME Q:'$T I NPIVAL1'=NPIVAL2 W !,"Values do not match!" Q + . S DONE=1 + . Q + I OLDNPI=DELETNPI D + . I $D(ODATEVAL) D S Y=$$CHEKNPI^XUSNPIED(IEN) Q + . . N DIR S DIR(0)="Y",DIR("A")="Confirm that you want to **DELETE** this incorrectly entered NPI",DIR("B")="NO" D ^DIR Q:'Y + . . D DELETNPI^XUSNPIE2(IEN,OIEN,ODATEVAL) + . . D CHKOLD1(IEN) ; check for earlier value, and activate if present + . . W !,"Entry was DELETED..." + . . Q + . D DELETNPI^XUSNPIE2(IEN) ; clean up where no entry in multiple + . W !,"Entry was DELETED..." + . Q + I 'DONE Q + ;N DIR S DIR("A")="Enter the date the provider was issued this number from CMS: ",DIR(0)="D^:"_$$NOW^XLFDT() D ^DIR Q:Y'>0 S DATEVAL=+Y + S DATEVAL=$$NOW^XLFDT() + ; mark previous NPI value as inactive + I OLDNPI=ADDNPI S DONE=$$ADDNPI^XUSNPI("Individual_ID",IEN,CURRNPI,DATEVAL,0) ; set status to INACTIVE + S DONE=$$ADDNPI^XUSNPI("Individual_ID",IEN,NPIVAL1,DATEVAL) I +DONE=-1 W !,"Problem writing that value into the database! -- It was **NOT** recorded.",!,$P(DONE,U,2) Q + W !!,"For provider ",PROVNAME," "_$S('$D(XUSNONED):"(who requires an NPI), ",1:"")_"the NPI ",NPIVAL1,!,"was saved to VistA successfully." + Q + ; +CHKOLD1(IEN) ; + D CHKOLD1^XUSNPIE2(IEN) + Q + ; +CLERXMPT ; + D CLERXMPT^XUSNPIE2 + Q + ; +CHKDGT(XUSNPI,XUSDA,XUSQI) ; INPUT TRANSFORM + N XUS S XUS=$$CHKDGT^XUSNPI(XUSNPI) + I XUS'>0 Q 0 + N XUSQIK S XUSQIK=$$QI^XUSNPI(XUSNPI) I XUSQIK=0 Q 1 + I XUSQIK'=0,$P(XUSQIK,"^",2)'=XUSDA Q 0 ; return zero if the NPI found and not bellong to the current user + N XUSQIK1 S XUSQIK1=$P(XUSQIK,"^") + I XUSQI'=XUSQIK1 Q 0 + I $P($P(XUSQIK,"^",4),";")="Inactive" Q 0 + N XUSROOT S XUSROOT=$$GET^XPAR("PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER",XUSQIK1) + I $E(XUSROOT)'="^" S XUSROOT="^"_XUSROOT + N XUS1 S XUS1=XUSROOT_XUSDA_","_"""NPISTATUS"""_","_"""A"""_")" + N XUS2 S XUS2=$O(@XUS1,-1) I XUS2'>0 Q 1 + S XUS1=XUSROOT_XUSDA_","_"""NPISTATUS"""_","_XUS2_","_0_")" + S XUS2=$G(@XUS1) I $P(XUS2,"^",3)=XUSNPI Q 1 + Q 0 diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIE2.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIE2.m index bf1cb114..2775f349 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIE2.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIE2.m @@ -1,174 +1,143 @@ -XUSNPIE2 ;FO-OAKLAND/JLI - DATA ENTRY FOR INITIAL NPI VALUES ;5/13/08 17:41 - ;;8.0;KERNEL;**410,435,454,462,480**;Jul 10, 1995;Build 38 - ;;Per VHA Directive 2004-038, this routine should not be modified - Q - ; -PRINTOPT ; - N DIR,%ZIS,ION,OPTION,PRNTFRMT,XUSDIV,XUSSORT,XUSRESO,Y,ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK - K IO("Q") - W !,"Select one of the following:",!!,?11,"1",?21,"All providers",!,?11,"2",?21,"All providers without NPI numbers",! - S DIR(0)="N^1:2",DIR("A")="Select a report option",DIR("B")="1" D ^DIR K DIR Q:Y'>0 S OPTION=+Y - S XUSRESO="" D Q:XUSRESO="" - . S DIR(0)="S^P:Providers who are not residents;R:Residents only;B:Both" - . S DIR("B")="P",DIR("A")="Selection: " - . D ^DIR K DIR Q:"PRB"'[Y - . S XUSRESO=Y Q - S DIR(0)="Y",DIR("B")="NO",DIR("A")="Sort by DIVISION" D ^DIR K DIR Q:Y="^" S XUSDIV=+Y - S PRNTFRMT=1 - I XUSDIV S DIR(0)="N^1:2",DIR("A")="Output type (1=Printed text or 2=^-delimited)" D ^DIR K DIR Q:Y'>0 S PRNTFRMT=Y - S DIR(0)="Y",DIR("B")="YES",DIR("A")="Sort by SERVICE/SECTION"_$S(XUSDIV>0:" (as well)",1:"") D ^DIR K DIR Q:Y="^" S XUSSORT=+Y - W !!,">>> Report processing time is approximately 10 minutes." - W !," Recommend text output be queued to a network printer." - W ! - S %ZIS="MQ" D ^%ZIS Q:POP - I $D(IO("Q")) D Q - . S ZTSAVE("OPTION")="",ZTSAVE("XUSSORT")="",ZTSAVE("XUSDIV")="",ZTSAVE("PRNTFRMT")="",ZTSAVE("XUSRESO")="" - . S ZTIO=ION,ZTRTN="DQ^XUSNPIE2",ZTDESC="NPI PRINT JOB FOR OPTION "_OPTION - . D ^%ZTLOAD W:$D(ZTSK) !,"Queued as Task "_ZTSK D HOME^%ZIS Q - ; -DQ ; entry point for queued print job - U IO D PRNTPROV(OPTION,XUSSORT,XUSDIV,PRNTFRMT,XUSRESO) - U IO D ^%ZISC - Q - ; -PRNTPROV(OPTION,XUSSORT,XUSDIV,PRNTFRMT,XUSRESO) ; - ; PRINT PROVIDER INFO - ; - ; OPTION SPECIFIES TYPE OF PRINT - 1=ALL PROVIDERS, 2=NEEDS NPI ONLY - ; XUSSORT INDICATES WHETHER SORTED BY SERVICE/SECTION - ; XUSDIV INDICATES WHETHER SORTED BY DIVISION - ; PRNTFRMT INDICATES TYPE OF OUTPUT, PRINTED OR ^-DELIMITED - ; - ; ZEXCEPT: IOSL - KERNEL VARIABLE - N PAGENUM,LINENUM,PROVNAME,TAXDESCR,TAXONOMY,SERVSECT,DIRUT,DTOUT - N GLOBLOC,IEN,NPI,DATETIME,GLOBVALU,NCOUNT,GLOBLOC1,XUSDIVNM,CNTTOTAL,CNTNONE,CNTEXMPT,CNTDONE,MULTDIV,MULTDIVC - S CNTTOTAL=0,CNTNONE=0,CNTEXMPT=0,CNTDONE=0 - S PAGENUM=0,LINENUM=0 - S DATETIME=$$NOW^XLFDT() - S GLOBLOC1=$$GETDATA(OPTION,XUSSORT,XUSDIV,XUSRESO) - I PRNTFRMT'=1 W !,"PROVIDER_NAME^LAST4^IEN^NPI^TAXONOMY_CODE^TAXONOMY DESCRIPTION"_$S(XUSDIV:"^DIVISION",1:"")_$S(XUSSORT:"^SERVICE/SECTION",1:"") - S GLOBLOC=GLOBLOC1,XUSDIVNM="" F S XUSDIVNM=$O(@GLOBLOC1@(XUSDIVNM)) Q:XUSDIVNM="" D Q:$D(DIRUT)!$D(DTOUT) - . S SERVSECT="" F S SERVSECT=$O(@GLOBLOC1@(XUSDIVNM,SERVSECT)) Q:SERVSECT="" S GLOBLOC=$NA(@GLOBLOC1@(XUSDIVNM,SERVSECT)) D Q:$D(DIRUT)!$D(DTOUT) - . . I PRNTFRMT=1 D HEADER(OPTION,DATETIME,.PAGENUM,.LINENUM,XUSDIV,XUSDIVNM,XUSSORT,SERVSECT,XUSRESO) Q:$D(DIRUT)!$D(DTOUT) - . . S PROVNAME="" F S PROVNAME=$O(@GLOBLOC@(PROVNAME)) Q:PROVNAME="" Q:$D(DIRUT)!$D(DTOUT) S IEN=0 F S IEN=$O(@GLOBLOC@(PROVNAME,IEN)) Q:IEN'>0 D Q:$D(DIRUT)!$D(DTOUT) - . . . S NCOUNT=0 - . . . S TAXDESCR="" F S TAXDESCR=$O(@GLOBLOC@(PROVNAME,IEN,TAXDESCR)) Q:TAXDESCR="" S GLOBVALU=@GLOBLOC@(PROVNAME,IEN,TAXDESCR) D - . . . . S NPI=$P(GLOBVALU,U,3),TAXONOMY=$P(GLOBVALU,U,4) - . . . . I PRNTFRMT=1 S NCOUNT=NCOUNT+1 W:NCOUNT=1 !,PROVNAME,?33,$$ALIGNRGT(IEN,11),?49,NPI W !,?6,TAXONOMY," ",TAXDESCR - . . . . I PRNTFRMT'=1 W !,PROVNAME_U_$E($$GET1^DIQ(200,IEN_",",9),6,9)_U_IEN_U_NPI_U_TAXONOMY_U_TAXDESCR_$S(XUSDIV:U_XUSDIVNM,1:"")_$S(XUSSORT:U_SERVSECT,1:"") - . . . . Q - . . . I PRNTFRMT=1 S LINENUM=LINENUM+NCOUNT+1 I LINENUM>(IOSL-4) D HEADER(OPTION,DATETIME,.PAGENUM,.LINENUM,XUSDIV,XUSDIVNM,XUSSORT,SERVSECT,XUSRESO) Q:$D(DIRUT)!$D(DTOUT) - . . . Q - . . Q - . Q - I '($D(DIRUT)!$D(DTOUT)),PRNTFRMT=1 D - . S PROVNAME="" I $O(@GLOBLOC@(PROVNAME))="" W !,?20,"* * * N O D A T A F O U N D * * *",!! I 1 - . E D - . . N TOTTYP S TOTTYP=$S(XUSRESO="R":"Residents",1:"Billable Providers") - . . W !!,"Total "_TOTTYP_":",?43,CNTTOTAL,!,TOTTYP_" with an NPI:",?43,CNTDONE,!,"EXEMPT "_TOTTYP_":",?43,CNTEXMPT,!,TOTTYP_" Still Needing an NPI:",?43,CNTNONE - . . I $G(MULTDIV)>0 W !!,MULTDIV," Providers were repeated a total of ",MULTDIVC," times",!," due to listing under multiple divisions" - . . Q - . W !!,?27,"*** End of Report ***" - . Q - Q - ; -HEADER(OPTION,DATETIME,PAGNOREF,LINNOREF,XUSDIV,XUSDIVNM,XUSSORT,SERVSECT,XUSRESO) ; - ; ZEXCEPT: IOF,IOST KERNEL IO VARIABLES - ; ZEXCEPT: DIRUT,DTOUT NEWED IN CALLING PRNTPROV - INDICATE QUIT TO PRNTPROV - N TEMPVAL,DIR,X,Y - S PAGNOREF=PAGNOREF+1 - ; Don't page feed on the first page - IF PAGNOREF>1 I $E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR I 'Y S DIRUT=1 Q - IF PAGNOREF>1 W @IOF - W:$E(IOST,1,2)'="C-" ! - W "Active Provider Report ("_$S(XUSRESO="P":"no residents)",XUSRESO="R":"residents only)",1:"includes residents)") - W ?48,$$FMTE^XLFDT(DATETIME)," Page: ",PAGNOREF - W !," Report Option: Provider List Active Providers",$S(OPTION=2:" Without NPI Numbers",1:"") - W !!,"Provider Name",?39,"IEN",?49,$S(OPTION'=2:"NPI",1:"") - W !," Taxonomy" - W !,"--------------------------------------------------------------------------------" - S LINNOREF=6 - I XUSDIV W !,"DIVISION: ",XUSDIVNM," " S LINNOREF=LINNOREF+1 - I XUSSORT W:'XUSDIV ! W "SERVICE/SECTION: ",SERVSECT S:'XUSDIV LINNOREF=LINNOREF+1 - Q - ; -GETDATA(OPTION,XUSSORT,XUSDIV,XUSRESO) ; get data for reports for providers - N NPI,PROVNAME,TAXDESCR,TAXONOMY,XUSDEFLT,XUSDIVCN,XUSDIVN,XUSDIVNM,XUSGLOB,XUSACTV,XUSSKIP - N XUSIEN,XUSSERVC,XUSVAL,CNTCLEAN,X - S XUSRESO=$G(XUSRESO) - ; ZEXCEPT: CNTTOTAL,CNTNONE,CNTEXMPT,CNTDONE - NEWed and initialized in PRNTPROV or killed based on CNTCLEAN - S CNTCLEAN=0 I '$D(CNTTOTAL) S CNTCLEAN=1 - S XUSGLOB=$NA(^TMP($J,"XUSNPIPRNT")) K @XUSGLOB - I 'XUSDIV S XUSDIVNM(1)=" ",XUSDEFLT=" " - I XUSDIV S XUSDEFLT=$$NS^XUAF4($$KSP^XUPARAM("INST")),XUSDEFLT=$P(XUSDEFLT,U) - I 'XUSSORT S XUSSERVC=" " - F XUSIEN=0:0 S XUSIEN=$O(^VA(200,XUSIEN)) Q:XUSIEN'>0 D - . ; Don't report TERMINATED or DISUSERed users - . S XUSACTV=$$ACTIVE^XUSER(XUSIEN) - . I XUSACTV=""!($P(XUSACTV,U)=0) Q - . ; Don't report users with null NPI ENTRY STATUS - . S XUSVAL=$$CHEKNPI^XUSNPIED(XUSIEN),XUSVAL=$$NPISTATS^XUSNPIED(XUSIEN) - . Q:XUSVAL="" - . S PROVNAME=$$GET1^DIQ(200,XUSIEN_",",.01),NPI=$$GETNPI^XUSNPIED(XUSIEN),TAXONOMY=$$GETTAXON^XUSNPIED(XUSIEN,.TAXDESCR) I TAXONOMY=-1 S TAXONOMY=" ",TAXDESCR=" " - . ; Determine whether provider is a resident for local reports. - . I OPTION'=3,XUSRESO'="B" S XUSSKIP=0 D Q:XUSSKIP - . . I XUSRESO="R",TAXONOMY'="390200000X" S XUSSKIP=1 Q - . . I XUSRESO="P",TAXONOMY="390200000X" S XUSSKIP=1 - . . Q - . I NPI="",$$EXMPTNPI^XUSNPIED(XUSIEN) S NPI="EXEMPTED " - . S CNTTOTAL=$G(CNTTOTAL)+1 S:NPI="" CNTNONE=$G(CNTNONE)+1 S:NPI="EXEMPTED " CNTEXMPT=$G(CNTEXMPT)+1 S:NPI?10N CNTDONE=$G(CNTDONE)+1 - . I '((XUSVAL="N")!(OPTION'=2)) Q - . I XUSSORT S XUSSERVC=$$GET1^DIQ(200,XUSIEN_",",29) I XUSSERVC="" S XUSSERVC=" " - . I XUSDIV D - . . K XUSDIVNM S XUSDIVCN=0,XUSDIVNM(1)=XUSDEFLT - . . F XUSDIVN=0:0 S XUSDIVN=$O(^VA(200,XUSIEN,2,XUSDIVN)) Q:XUSDIVN'>0 S XUSDIVCN=XUSDIVCN+1,XUSDIVNM(XUSDIVCN)=$$GET1^DIQ(200.02,XUSDIVN_","_XUSIEN_",",.01) - . . I XUSDIVCN>1 S MULTDIV=$G(MULTDIV)+1,MULTDIVC=$G(MULTDIVC)+XUSDIVCN-1 - . . Q - . F XUSDIVN=0:0 S XUSDIVN=$O(XUSDIVNM(XUSDIVN)) Q:XUSDIVN'>0 D - . . S X=PROVNAME_U_XUSIEN_U_NPI_U_TAXONOMY_U_TAXDESCR - . . S @XUSGLOB@(XUSDIVNM(XUSDIVN),XUSSERVC,PROVNAME,XUSIEN,TAXDESCR)=X - . . Q - . Q - I CNTCLEAN K CNTTOTAL,CNTNONE,CNTEXMPT,CNTDONE - Q XUSGLOB - ; -ALIGNRGT(TEXT,WIDTH) ; align text right in a specified width - N RESULT - S $P(RESULT," ",WIDTH)=" ",RESULT=RESULT_TEXT,RESULT=$E(RESULT,$L(RESULT)-WIDTH+1,$L(RESULT)) - Q RESULT - ; -CHKOLD1(IEN) ; check for earlier value, and activate if present - N IEN1,STATUS,NPI,DATE,XUFDA - S IEN1=$O(^VA(200,IEN,"NPISTATUS"," "),-1) I IEN1>0 D I STATUS=0 D CHKOLD1(IEN) - . S STATUS=^VA(200,IEN,"NPISTATUS",IEN1,0),NPI=$P(STATUS,U,3),DATE=$P(STATUS,U),STATUS=$P(STATUS,U,2) - . I STATUS=0 D DELETNPI(IEN,IEN1,DATE) Q ; entry making it INACTIVE - remove it - . I STATUS=1 D SET^XUSNPIE1(IEN,NPI) - . Q - Q - ; -DELETNPI(IEN,OIEN,ODATEVAL) ; - N XUFDA - I $D(ODATEVAL) S XUFDA(200.042,OIEN_","_IEN_",",.01)="@" D FILE^DIE("","XUFDA") - I $O(^VA(200,IEN,"NPISTATUS",0))>0 Q - N XUFDA - I $$GET1^DIQ(200,IEN_",",41.99) S XUFDA(200,IEN_",",41.99)="@" - I $$GET1^DIQ(200,IEN_",",41.98)'="" S XUFDA(200,IEN_",",41.98)="@" - I $D(XUFDA) D FILE^DIE("","XUFDA") - Q - ; -CLERXMPT ; edit entry indicating whether a provider is exempt from needing an NPI - N DIC,DIR,FDA,IEN,Y - W ! S DIC="^VA(200,",DIC(0)="AEQ" S DIC("A")="select Provider: " D ^DIC Q:Y'>0 S IEN=+Y - I $$HASNPI^XUSNPIED(IEN) W !,"This Provider already has an NPI value. Nothing to do." Q - I '$$CHEKNPI^XUSNPIED(IEN),'$$EXMPTNPI^XUSNPIED(IEN) W !,"This Provider does not appear to need an NPI or Exemption." Q - I $$EXMPTNPI^XUSNPIED(IEN) D Q ; currently marked as Exempt - . S DIR(0)="Y",DIR("A")="Provider is currently EXEMPT from needing an NPI, set to NEEDS an NPI (Y/N)" D ^DIR I 'Y Q - . S FDA(200,IEN_",",41.98)="N" D FILE^DIE("","FDA") - . W !,$S($$NEEDSNPI^XUSNPIED(IEN):"File updated",1:"Ecountered a problem updating file, status NOT set to NEEDS an NPI") - . Q - ; check to make sure provider should be exempt - S DIR(0)="Y",DIR("A")="Confirm that Provider should be Exempt from needing an NPI (Y/N)" D ^DIR I 'Y Q - ; and update file to show as exempt - S FDA(200,IEN_",",41.98)="E" D FILE^DIE("","FDA") - W !,$S($$EXMPTNPI^XUSNPIED(IEN):"File updated",1:"Ecountered a problem updating file, status NOT set to EXEMPT") - Q +XUSNPIE2 ;FO-OAKLAND/JLI - DATA ENTRY FOR INITIAL NPI VALUES ;06/06/07 + ;;8.0;KERNEL;**410,435,454,462**;Jul 10, 1995;Build 3 + Q + ; +PRINTOPT ; + N DIR,%ZIS,ION,OPTION,PRNTFRMT,XUSDIV,XUSSORT,Y,ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK + K IO("Q") + W !,"Select one of the following:",!!,?11,"1",?21,"All providers",!,?11,"2",?21,"All providers without NPI numbers",! + S DIR(0)="N^1:2",DIR("A")="Select a report option",DIR("B")="1" D ^DIR K DIR Q:Y'>0 S OPTION=+Y + S DIR(0)="Y",DIR("B")="NO",DIR("A")="Sort by DIVISION" D ^DIR K DIR Q:Y="^" S XUSDIV=+Y + S PRNTFRMT=1 + I XUSDIV S DIR(0)="N^1:2",DIR("A")="Output type (1=Printed text or 2=^-delimited)" D ^DIR K DIR Q:Y'>0 S PRNTFRMT=Y + S DIR(0)="Y",DIR("B")="YES",DIR("A")="Sort by SERVICE/SECTION"_$S(XUSDIV>0:" (as well)",1:"") D ^DIR K DIR Q:Y="^" S XUSSORT=+Y + W !!,">>> Report processing time is approximately 10 minutes." + W !," Recommend text output be queued to a network printer." + W ! + S %ZIS="MQ" D ^%ZIS Q:POP + I $D(IO("Q")) S ZTSAVE("OPTION")="",ZTSAVE("XUSSORT")="",ZTSAVE("XUSDIV")="",ZTSAVE("PRNTFRMT")="",ZTIO=ION,ZTRTN="DQ^XUSNPIE2",ZTDESC="NPI PRINT JOB FOR OPTION "_OPTION D ^%ZTLOAD W:$D(ZTSK) !,"Queued as Task "_ZTSK D HOME^%ZIS Q + ; +DQ ; entry point for queued print job + U IO D PRNTPROV(OPTION,XUSSORT,XUSDIV,PRNTFRMT) + U IO D ^%ZISC + Q + ; +PRNTPROV(OPTION,XUSSORT,XUSDIV,PRNTFRMT) ; + ; PRINT PROVIDER INFO + ; + ; OPTION SPECIFIES TYPE OF PRINT - 1=ALL PROVIDERS, 2=NEEDS NPI ONLY + ; XUSSORT INDICATES WHETHER SORTED BY SERVICE/SECTION + ; XUSDIV INDICATES WHETHER SORTED BY DIVISION + ; PRNTFRMT INDICATES TYPE OF OUTPUT, PRINTED OR ^-DELIMITED + ; + ; ZEXCEPT: IOSL - KERNEL VARIABLE + N PAGENUM,LINENUM,PROVNAME,TAXDESCR,TAXONOMY,SERVSECT,DIRUT,DTOUT + N GLOBLOC,IEN,NPI,DATETIME,GLOBVALU,NCOUNT,GLOBLOC1,XUSDIVNM,CNTTOTAL,CNTNONE,CNTEXMPT,CNTDONE,MULTDIV,MULTDIVC + S CNTTOTAL=0,CNTNONE=0,CNTEXMPT=0,CNTDONE=0 + S PAGENUM=0,LINENUM=0 + S DATETIME=$$NOW^XLFDT() + S GLOBLOC1=$$GETDATA(OPTION,XUSSORT,XUSDIV) + I PRNTFRMT'=1 W !,"PROVIDER_NAME^LAST4^IEN^NPI^TAXONOMY_CODE^TAXONOMY DESCRIPTION"_$S(XUSDIV:"^DIVISION",1:"")_$S(XUSSORT:"^SERVICE/SECTION",1:"") + S GLOBLOC=GLOBLOC1,XUSDIVNM="" F S XUSDIVNM=$O(@GLOBLOC1@(XUSDIVNM)) Q:XUSDIVNM="" D Q:$D(DIRUT)!$D(DTOUT) + . S SERVSECT="" F S SERVSECT=$O(@GLOBLOC1@(XUSDIVNM,SERVSECT)) Q:SERVSECT="" S GLOBLOC=$NA(@GLOBLOC1@(XUSDIVNM,SERVSECT)) D Q:$D(DIRUT)!$D(DTOUT) + . . I PRNTFRMT=1 D HEADER(OPTION,DATETIME,.PAGENUM,.LINENUM,XUSDIV,XUSDIVNM,XUSSORT,SERVSECT) Q:$D(DIRUT)!$D(DTOUT) + . . S PROVNAME="" F S PROVNAME=$O(@GLOBLOC@(PROVNAME)) Q:PROVNAME="" Q:$D(DIRUT)!$D(DTOUT) S IEN=0 F S IEN=$O(@GLOBLOC@(PROVNAME,IEN)) Q:IEN'>0 D Q:$D(DIRUT)!$D(DTOUT) + . . . S NCOUNT=0 + . . . S TAXDESCR="" F S TAXDESCR=$O(@GLOBLOC@(PROVNAME,IEN,TAXDESCR)) Q:TAXDESCR="" S GLOBVALU=@GLOBLOC@(PROVNAME,IEN,TAXDESCR) D + . . . . S NPI=$P(GLOBVALU,U,3),TAXONOMY=$P(GLOBVALU,U,4) I PRNTFRMT=1 S NCOUNT=NCOUNT+1 W:NCOUNT=1 !,PROVNAME,?33,$$ALIGNRGT(IEN,11),?49,NPI W !,?6,TAXONOMY," ",TAXDESCR + . . . . I PRNTFRMT'=1 W !,PROVNAME_U_$E($$GET1^DIQ(200,IEN_",",9),6,9)_U_IEN_U_NPI_U_TAXONOMY_U_TAXDESCR_$S(XUSDIV:U_XUSDIVNM,1:"")_$S(XUSSORT:U_SERVSECT,1:"") + . . . . Q + . . . I PRNTFRMT=1 S LINENUM=LINENUM+NCOUNT+1 I LINENUM>(IOSL-4) D HEADER(OPTION,DATETIME,.PAGENUM,.LINENUM,XUSDIV,XUSDIVNM,XUSSORT,SERVSECT) Q:$D(DIRUT)!$D(DTOUT) + . . . Q + . . Q + . Q + I '($D(DIRUT)!$D(DTOUT)),PRNTFRMT=1 D + . S PROVNAME="" I $O(@GLOBLOC@(PROVNAME))="" W !,?20,"* * * N O D A T A F O U N D * * *",!! I 1 + . E D + . . W !!,"Total Billable Providers:",?43,CNTTOTAL,!,"Billable Providers with an NPI:",?43,CNTDONE,!,"EXEMPT Billable Providers:",?43,CNTEXMPT,!,"Billable Providers Still Needing an NPI:",?43,CNTNONE + . . I $G(MULTDIV)>0 W !!,MULTDIV," Providers were repeated a total of ",MULTDIVC," times",!," due to listing under multiple divisions" + . . Q + . W !!,?27,"*** End of Report ***" + . Q + Q + ; +HEADER(OPTION,DATETIME,PAGNOREF,LINNOREF,XUSDIV,XUSDIVNM,XUSSORT,SERVSECT) ; + ; ZEXCEPT: IOF,IOST KERNEL IO VARIABLES + ; ZEXCEPT: DIRUT,DTOUT NEWED IN CALLING PRNTPROV - INDICATE QUIT TO PRNTPROV + N TEMPVAL,DIR,X,Y + S PAGNOREF=PAGNOREF+1 + ; Don't page feed on the first page + IF PAGNOREF>1 I $E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR I 'Y S DIRUT=1 Q + IF PAGNOREF>1 W @IOF + W:$E(IOST,1,2)'="C-" ! W "Active Provider Report",?48,$$FMTE^XLFDT(DATETIME)," Page: ",PAGNOREF + W !," Report Option: Provider List Active Providers",$S(OPTION=2:" Without NPI Numbers",1:"") + W !!,"Provider Name",?39,"IEN",?49,$S(OPTION'=2:"NPI",1:"") + W !," Taxonomy" + W !,"--------------------------------------------------------------------------------" + S LINNOREF=6 + I XUSDIV W !,"DIVISION: ",XUSDIVNM," " S LINNOREF=LINNOREF+1 + I XUSSORT W:'XUSDIV ! W "SERVICE/SECTION: ",SERVSECT S:'XUSDIV LINNOREF=LINNOREF+1 + Q + ; +GETDATA(OPTION,XUSSORT,XUSDIV) ; get data for reports for providers + N NPI,PROVNAME,TAXDESCR,TAXONOMY,XUSDEFLT,XUSDIVCN,XUSDIVN,XUSDIVNM,XUSGLOB + N XUSIEN,XUSSERVC,XUSVAL,CNTCLEAN + ; ZEXCEPT: CNTTOTAL,CNTNONE,CNTEXMPT,CNTDONE - NEWed and initialized in PRNTPROV or killed based on CNTCLEAN + S CNTCLEAN=0 I '$D(CNTTOTAL) S CNTCLEAN=1 + S XUSGLOB=$NA(^TMP($J,"XUSNPIPRNT")) K @XUSGLOB + I 'XUSDIV S XUSDIVNM(1)=" ",XUSDEFLT=" " + I XUSDIV S XUSDEFLT=$$NS^XUAF4($$KSP^XUPARAM("INST")),XUSDEFLT=$P(XUSDEFLT,U) + I 'XUSSORT S XUSSERVC=" " + F XUSIEN=0:0 S XUSIEN=$O(^VA(200,XUSIEN)) Q:XUSIEN'>0 I ($$ACTIVE^XUSER(XUSIEN)'=""),($P($$ACTIVE^XUSER(XUSIEN),"^",2)'="TERMINATED") S XUSVAL=$$CHEKNPI^XUSNPIED(XUSIEN),XUSVAL=$$NPISTATS^XUSNPIED(XUSIEN) I XUSVAL'="" D + . S PROVNAME=$$GET1^DIQ(200,XUSIEN_",",.01),NPI=$$GETNPI^XUSNPIED(XUSIEN),TAXONOMY=$$GETTAXON^XUSNPIED(XUSIEN,.TAXDESCR) I TAXONOMY=-1 S TAXONOMY=" ",TAXDESCR=" " + . I NPI="",$$EXMPTNPI^XUSNPIED(XUSIEN) S NPI="EXEMPTED " + . S CNTTOTAL=$G(CNTTOTAL)+1 S:NPI="" CNTNONE=$G(CNTNONE)+1 S:NPI="EXEMPTED " CNTEXMPT=$G(CNTEXMPT)+1 S:NPI?10N CNTDONE=$G(CNTDONE)+1 + . I '((XUSVAL="N")!(OPTION'=2)) Q + . I XUSSORT S XUSSERVC=$$GET1^DIQ(200,XUSIEN_",",29) I XUSSERVC="" S XUSSERVC=" " + . I XUSDIV D + . . K XUSDIVNM S XUSDIVCN=0,XUSDIVNM(1)=XUSDEFLT + . . F XUSDIVN=0:0 S XUSDIVN=$O(^VA(200,XUSIEN,2,XUSDIVN)) Q:XUSDIVN'>0 S XUSDIVCN=XUSDIVCN+1,XUSDIVNM(XUSDIVCN)=$$GET1^DIQ(200.02,XUSDIVN_","_XUSIEN_",",.01) + . . I XUSDIVCN>1 S MULTDIV=$G(MULTDIV)+1,MULTDIVC=$G(MULTDIVC)+XUSDIVCN-1 + . . Q + . F XUSDIVN=0:0 S XUSDIVN=$O(XUSDIVNM(XUSDIVN)) Q:XUSDIVN'>0 S @XUSGLOB@(XUSDIVNM(XUSDIVN),XUSSERVC,PROVNAME,XUSIEN,TAXDESCR)=PROVNAME_U_XUSIEN_U_NPI_U_TAXONOMY_U_TAXDESCR + . Q + I CNTCLEAN K CNTTOTAL,CNTNONE,CNTEXMPT,CNTDONE + Q XUSGLOB + ; +ALIGNRGT(TEXT,WIDTH) ; align text right in a specified width + N RESULT + S $P(RESULT," ",WIDTH)=" ",RESULT=RESULT_TEXT,RESULT=$E(RESULT,$L(RESULT)-WIDTH+1,$L(RESULT)) + Q RESULT + ; +CHKOLD1(IEN) ; check for earlier value, and activate if present + N IEN1,STATUS,NPI,DATE,XUFDA + S IEN1=$O(^VA(200,IEN,"NPISTATUS"," "),-1) I IEN1>0 D I STATUS=0 D CHKOLD1(IEN) + . S STATUS=^VA(200,IEN,"NPISTATUS",IEN1,0),NPI=$P(STATUS,U,3),DATE=$P(STATUS,U),STATUS=$P(STATUS,U,2) + . I STATUS=0 D DELETNPI(IEN,IEN1,DATE) Q ; entry making it INACTIVE - remove it + . I STATUS=1 D SET^XUSNPIE1(IEN,NPI) + . Q + Q + ; +DELETNPI(IEN,OIEN,ODATEVAL) ; + N XUFDA + I $D(ODATEVAL) S XUFDA(200.042,OIEN_","_IEN_",",.01)="@" + S XUFDA(200,IEN_",",41.99)="@",XUFDA(200,IEN_",",41.98)="@" + D FILE^DIE("","XUFDA") + Q + ; +CLERXMPT ; edit entry indicating whether a provider is exempt from needing an NPI + N DIC,DIR,FDA,IEN,Y + W ! S DIC="^VA(200,",DIC(0)="AEQ" S DIC("A")="select Provider: " D ^DIC Q:Y'>0 S IEN=+Y + I $$HASNPI^XUSNPIED(IEN) W !,"This Provider already has an NPI value. Nothing to do." Q + I '$$CHEKNPI^XUSNPIED(IEN),'$$EXMPTNPI^XUSNPIED(IEN) W !,"This Provider does not appear to need an NPI or Exemption." Q + I $$EXMPTNPI^XUSNPIED(IEN) D Q ; currently marked as Exempt + . S DIR(0)="Y",DIR("A")="Provider is currently EXEMPT from needing an NPI, set to NEEDS an NPI (Y/N)" D ^DIR I 'Y Q + . S FDA(200,IEN_",",41.98)="N" D FILE^DIE("","FDA") + . W !,$S($$NEEDSNPI^XUSNPIED(IEN):"File updated",1:"Ecountered a problem updating file, status NOT set to NEEDS an NPI") + . Q + ; check to make sure provider should be exempt + S DIR(0)="Y",DIR("A")="Confirm that Provider should be Exempt from needing an NPI (Y/N)" D ^DIR I 'Y Q + ; and update file to show as exempt + S FDA(200,IEN_",",41.98)="E" D FILE^DIE("","FDA") + W !,$S($$EXMPTNPI^XUSNPIED(IEN):"File updated",1:"Ecountered a problem updating file, status NOT set to EXEMPT") + Q diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIED.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIED.m index 7c796f2a..a47e267c 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIED.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIED.m @@ -1,135 +1,128 @@ -XUSNPIED ;FO-OAKLAND/JLI - DATA ENTRY FOR INITIAL NPI VALUES ;6/3/08 17:19 - ;;8.0;KERNEL;**420,410,435,480**;Jul 10, 1995;Build 38 - ;;Per VHA Directive 2004-038, this routine should not be modified - Q - ; -SIGNON ; run at user sign-on to display message if NPI value is needed. - D SIGNON^XUSNPIE1 - Q - ; -CLEREDIT ; Input editing of NPI value for clerical staff - ask provider - N IEN,DIC,PROVNAME,DATEVAL,DESCRIP,DONE,IENS,NPIVAL1,NPIVAL2,Y,XX - F W ! S DIC="^VA(200,",DIC(0)="AEQ" S DIC("A")="Select Provider: " D ^DIC Q:Y'>0 S IEN=+Y D EDITNPI(IEN) - Q - ; -USEREDIT ; Entry point for provider to enter own data - I $$NPISTATS(DUZ)="" W !,$C(7),"Please see your local NPI facilitator to add the NPI",! H 3 Q - D EDITNPI(DUZ) - Q - ; -EDITNPI(IEN) ; - D EDITNPI^XUSNPIE3(IEN) - Q - ; -EDRLNPI(IEN) ; Edit AUTHORIZES RELEASE OF NPI field - ; NOTE: *** This field is no longer being used, and should always be set to YES 05/13/08 tkw*** - Q:$P($G(^VA(200,+$G(IEN),"NPI")),U,3)=1 - N DIE,DR,DA S DIE="^VA(200,",DA=IEN,DR="41.97////1" D ^DIE - Q - ; -CLERXMPT ; - D CLERXMPT^XUSNPIE1 - Q - ; -CHKGLOB() ; returns global location of TAXONOMY values also rebuilds if they are missing - Q $$CHKGLOB^XUSNPIDA() - ; -DOUSER(XUUSER,XUGLOB) ; check user for needing an NPI status value - N PCLASS,XUDONE,PVAL,CODE,NPISTATS,XUVALUE,D0,EXPIRATN,I,NPIFLD,NPISUBFL - S NPISTATS=41.98,NPISUBFL=200.042,NPIFLD=.03 - I $$GET1^DIQ(200,XUUSER_",",NPISTATS)'="" Q ; user is already flagged - S PCLASS=0,XUDONE=0 F S PCLASS=$O(^VA(200,XUUSER,"USC1",PCLASS)) Q:PCLASS'>0 S D0=^(PCLASS,0) D Q:XUDONE - . S EXPIRATN=$P(D0,U,3)>0 I EXPIRATN Q - . S PVAL=$P(D0,U),CODE=$$GET1^DIQ(8932.1,PVAL_",",6) I CODE'="",$D(@XUGLOB@(CODE)) D S XUDONE=1 Q - . . S XUVALUE="N" N NPIVAL F I=1:1 S NPIVAL=$$GET1^DIQ(NPISUBFL,I_","_XUUSER_",",NPIFLD) Q:NPIVAL="" S XUVALUE="D" Q - . . N XUFDA S XUFDA(200,XUUSER_",",NPISTATS)=XUVALUE - . . D FILE^DIE("","XUFDA") - . . Q - . Q - Q - ; -CBOLIST ; list ^ delimited output to CBO exchange mail group. - N DATE,DOMAIN,ADDRESS,STATNAME,COUNT,GLOBLOC,GLOBOUT - N IEN,NPI,PROVNAME,TAXDESCR,TAXONOMY,STATION,STATUS,OPTION - I '$$PROD^XUPROD() Q ; messages from production systems only - S DATE=(1700+$E(DT,1,3))_"-"_$E(DT,4,5)_"-"_$E(DT,6,7) - S DOMAIN=$G(^XTV(8989.3,1,0)),DOMAIN=$P(DOMAIN,U) - S STATION=$$NS^XUAF4($$KSP^XUPARAM("INST")) - S ADDRESS=$P(STATION,U) ;$$GET1^DIQ(4.2,DOMAIN_",",.01) - S STATION=$P(STATION,U,2) ;$$GET1^DIQ(4.2,DOMAIN_",",5.5) - S OPTION=3 - S GLOBLOC=$$GETDATA(OPTION,0,0) ; get most of data into location specified by GLOBLOC - S COUNT=0,GLOBOUT=$NA(^TMP($J,"XUSNPIOUT")) K @GLOBOUT - S COUNT=1,@GLOBOUT@(COUNT)="--START" - S GLOBLOC=$NA(@GLOBLOC@(" "," ")) - S PROVNAME="" F S PROVNAME=$O(@GLOBLOC@(PROVNAME)) Q:PROVNAME="" S IEN=0 F S IEN=$O(@GLOBLOC@(PROVNAME,IEN)) Q:IEN'>0 D - . S TAXDESCR="" F S TAXDESCR=$O(@GLOBLOC@(PROVNAME,IEN,TAXDESCR)) Q:TAXDESCR="" S TAXONOMY=$P(^(TAXDESCR),U,4),NPI=$P(^(TAXDESCR),U,3) D - . . S STATUS=$$NPISTATS(IEN) - . . S COUNT=COUNT+1,@GLOBOUT@(COUNT)=PROVNAME_U_STATION_U_NPI_U_TAXONOMY_U_TAXDESCR_U_DATE_U_STATUS - . . Q - . Q - S COUNT=COUNT+1,@GLOBOUT@(COUNT)="--END" - ; and generate mail message - N XMTEXT,XMDUZ,XMY,XMSUB - S XMTEXT=$E(GLOBOUT,1,$L(GLOBOUT)-1)_",",XMDUZ=0.5,XMY("VHACONPINPF@VA.GOV")="" - S XMSUB="NPI LIST "_DATE_" FOR "_ADDRESS_" ("_STATION_")" - D ^XMD - Q - ; -PRINTOPT ; - D PRINTOPT^XUSNPIE2 - Q -GETDATA(OPTION,XUSSORT,XUSDIV) ; get data for reports for providers - Q $$GETDATA^XUSNPIE2(OPTION,XUSSORT,XUSDIV) - ; -CHEKNPI(IEN) ; returns whether status is Needs, will check and update if not set - N VALUE,FDA - S VALUE=$E($$GET1^DIQ(200,IEN_",",41.98)) - I VALUE="N" S FDA(200,IEN_",",41.98)="" D FILE^DIE("","FDA") S VALUE="" ; XU*8*435 JLI - I VALUE="",$$CHKTAXON(IEN) K FDA S FDA(200,IEN_",",41.98)="N" D FILE^DIE("","FDA") S VALUE="N" - Q VALUE="N" - ; -NEEDSNPI(IEN) ; returns whether current status is N - Q $$NPISTATS(IEN)="N" - ; -HASNPI(IEN) ; returns whether current status is D (Done) - Q $$NPISTATS(IEN)="D" - ; -EXMPTNPI(IEN) ; returns whether current status is E (Exempt) - Q $$NPISTATS(IEN)="E" - ; -NPISTATS(IEN) ; returns one letter status indicator - N VAL - S VAL=$E($$GET1^DIQ(200,IEN_",",41.98)) - I (VAL="")!(VAL="N") S VAL=$$CHEKNPI(IEN) - Q $E($$GET1^DIQ(200,IEN_",",41.98)) - ; -GETNPI(IEN) ; returns current NPI value - Q $$GET1^DIQ(200,IEN_",",41.99) - ; -GETTAXON(IEN,DESCRREF) ; returns Taxonomy value (X12) and sets description in DESCRREF, otherwise -1 - N I,POINTER,TAXON - S TAXON=-1,DESCRREF=" " - ;F I=0:0 S I=$O(^VA(200,IEN,"USC1",I)) Q:I'>0 I $P(^(I,0),U,3)'>0 S POINTER=+^(0) S TAXON=$$GET1^DIQ(8932.1,POINTER_",",6),DESCRREF=$$GET1^DIQ(8932.1,POINTER_",",1) Q - S POINTER=+$$GET^XUA4A72(IEN) I POINTER>0 S TAXON=$$GET1^DIQ(8932.1,POINTER_",",6),DESCRREF=$$GET1^DIQ(8932.1,POINTER_",",1) ; XU*8*435 make sure active on today - I TAXON="" S TAXON=-1,DESCRREF=" " - Q TAXON - ; -CHKTAXON(IEN,TAXONOMY) ; checks whether taxonomy value (X12) is in list of billable otherwise 0-1 - N DESCRIP,XUSGLOB - I $G(TAXONOMY)="" S TAXONOMY=$$GETTAXON(IEN,.DESCRIP) - S XUSGLOB=$$CHKGLOB() - Q $D(@XUSGLOB@(TAXONOMY)) - ; -DATE10(DATE) ; returns date in mm/dd/yyyyy format - Q $E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_(1700+$E(DATE,1,3)) - ; -POSTINIT ; runs post init - D POSTINIT^XUSNPIE1 - Q - ; -CBOQUEUE ; queues CBO List to run on first day of month - D CBOQUEUE^XUSNPIE1 - Q -ALIGNRGT(TEXT,WIDTH) ; align text right in a specified width - Q $$ALIGNRGT^XUSNPIE2(TEXT,WIDTH) +XUSNPIED ;FO-OAKLAND/JLI - DATA ENTRY FOR INITIAL NPI VALUES ;11/20/06 11:20 + ;;8.0;KERNEL;**420,410,435**;Jul 10, 1995;Build 10 + Q + ; +SIGNON ; run at user sign-on to display message if NPI value is needed. + D SIGNON^XUSNPIE1 + Q + ; +CLEREDIT ; Input editing of NPI value for clerical staff - ask provider + N IEN,DIC,PROVNAME,DATEVAL,DESCRIP,DONE,IENS,NPIVAL1,NPIVAL2,Y,XX + F W ! S DIC="^VA(200,",DIC(0)="AEQ" S DIC("A")="Select Provider: " D ^DIC Q:Y'>0 S IEN=+Y D EDITNPI(IEN) + Q + ; +USEREDIT ; Entry point for provider to enter own data + I $$NPISTATS(DUZ)="" W !,$C(7),"Please see your local NPI facilitator to add the NPI",! H 3 Q + D EDITNPI(DUZ) + Q + ; +EDITNPI(IEN) ; + D EDITNPI^XUSNPIE1(IEN) + Q + ; +CLERXMPT ; + D CLERXMPT^XUSNPIE1 + Q + ; +CHKGLOB() ; returns global location of TAXONOMY values also rebuilds if they are missing + Q $$CHKGLOB^XUSNPIDA() + ; +DOUSER(XUUSER,XUGLOB) ; check user for needing an NPI status value + N PCLASS,XUDONE,PVAL,CODE,NPISTATS,XUVALUE,D0,EXPIRATN,I,NPIFLD,NPISUBFL + S NPISTATS=41.98,NPISUBFL=200.042,NPIFLD=.03 + I $$GET1^DIQ(200,XUUSER_",",NPISTATS)'="" Q ; user is already flagged + S PCLASS=0,XUDONE=0 F S PCLASS=$O(^VA(200,XUUSER,"USC1",PCLASS)) Q:PCLASS'>0 S D0=^(PCLASS,0) D Q:XUDONE + . S EXPIRATN=$P(D0,U,3)>0 I EXPIRATN Q + . S PVAL=$P(D0,U),CODE=$$GET1^DIQ(8932.1,PVAL_",",6) I CODE'="",$D(@XUGLOB@(CODE)) D S XUDONE=1 Q + . . S XUVALUE="N" N NPIVAL F I=1:1 S NPIVAL=$$GET1^DIQ(NPISUBFL,I_","_XUUSER_",",NPIFLD) Q:NPIVAL="" S XUVALUE="D" Q + . . N XUFDA S XUFDA(200,XUUSER_",",NPISTATS)=XUVALUE + . . D FILE^DIE("","XUFDA") + . . Q + . Q + Q + ; +CBOLIST ; list ^ delimited output to CBO exchange mail group. + N DATE,DOMAIN,ADDRESS,STATNAME,COUNT,DOB,GLOBLOC,GLOBOUT + N IEN,NPI,PROVNAME,SSN,TAXDESCR,TAXONOMY,STATION,STATUS,OPTION + I '$$PROD^XUPROD() Q ; messages from production systems only + S DATE=(1700+$E(DT,1,3))_"-"_$E(DT,4,5)_"-"_$E(DT,6,7) + S DOMAIN=$G(^XTV(8989.3,1,0)),DOMAIN=$P(DOMAIN,U) + S STATION=$$NS^XUAF4($$KSP^XUPARAM("INST")) + S ADDRESS=$P(STATION,U) ;$$GET1^DIQ(4.2,DOMAIN_",",.01) + S STATION=$P(STATION,U,2) ;$$GET1^DIQ(4.2,DOMAIN_",",5.5) + S OPTION=3 + S GLOBLOC=$$GETDATA(OPTION,0,0) ; get most of data into location specified by GLOBLOC + S COUNT=0,GLOBOUT=$NA(^TMP($J,"XUSNPIOUT")) K @GLOBOUT + S COUNT=1,@GLOBOUT@(COUNT)="--START" + S GLOBLOC=$NA(@GLOBLOC@(" "," ")) + S PROVNAME="" F S PROVNAME=$O(@GLOBLOC@(PROVNAME)) Q:PROVNAME="" S IEN=0 F S IEN=$O(@GLOBLOC@(PROVNAME,IEN)) Q:IEN'>0 D + . S TAXDESCR="" F S TAXDESCR=$O(@GLOBLOC@(PROVNAME,IEN,TAXDESCR)) Q:TAXDESCR="" S TAXONOMY=$P(^(TAXDESCR),U,4),NPI=$P(^(TAXDESCR),U,3) D + . . S DOB=$P($G(^VA(200,IEN,1)),U,3),SSN=$E($$GET1^DIQ(200,IEN_",",9),6,9) S:DOB'="" DOB=$$DATE10(DOB) S STATUS=$$NPISTATS(IEN) + . . S COUNT=COUNT+1,@GLOBOUT@(COUNT)=PROVNAME_U_STATION_U_NPI_U_SSN_U_DOB_U_TAXONOMY_U_TAXDESCR_U_DATE_U_STATUS + . . Q + . Q + S COUNT=COUNT+1,@GLOBOUT@(COUNT)="--END" + ; and generate mail message + N XMTEXT,XMDUZ,XMY,XMSUB + S XMTEXT=$E(GLOBOUT,1,$L(GLOBOUT)-1)_",",XMDUZ=0.5,XMY("VHACONPINPF@VA.GOV")="" + S XMSUB="NPI LIST "_DATE_" FOR "_ADDRESS_" ("_STATION_")" + D ^XMD + Q + ; +PRINTOPT ; + D PRINTOPT^XUSNPIE2 + Q +GETDATA(OPTION,XUSSORT,XUSDIV) ; get data for reports for providers + Q $$GETDATA^XUSNPIE2(OPTION,XUSSORT,XUSDIV) + ; +CHEKNPI(IEN) ; returns whether status is Needs, will check and update if not set + N VALUE,FDA + S VALUE=$E($$GET1^DIQ(200,IEN_",",41.98)) + I VALUE="N" S FDA(200,IEN_",",41.98)="" D FILE^DIE("","FDA") S VALUE="" ; XU*8*435 JLI + I VALUE="",$$CHKTAXON(IEN) K FDA S FDA(200,IEN_",",41.98)="N" D FILE^DIE("","FDA") S VALUE="N" + Q VALUE="N" + ; +NEEDSNPI(IEN) ; returns whether current status is N + Q $$NPISTATS(IEN)="N" + ; +HASNPI(IEN) ; returns whether current status is D (Done) + Q $$NPISTATS(IEN)="D" + ; +EXMPTNPI(IEN) ; returns whether current status is E (Exempt) + Q $$NPISTATS(IEN)="E" + ; +NPISTATS(IEN) ; returns one letter status indicator + N VAL + S VAL=$E($$GET1^DIQ(200,IEN_",",41.98)) + I (VAL="")!(VAL="N") S VAL=$$CHEKNPI(IEN) + Q $E($$GET1^DIQ(200,IEN_",",41.98)) + ; +GETNPI(IEN) ; returns current NPI value + Q $$GET1^DIQ(200,IEN_",",41.99) + ; +GETTAXON(IEN,DESCRREF) ; returns Taxonomy value (X12) and sets description in DESCRREF, otherwise -1 + N I,POINTER,TAXON + S TAXON=-1,DESCRREF=" " + ;F I=0:0 S I=$O(^VA(200,IEN,"USC1",I)) Q:I'>0 I $P(^(I,0),U,3)'>0 S POINTER=+^(0) S TAXON=$$GET1^DIQ(8932.1,POINTER_",",6),DESCRREF=$$GET1^DIQ(8932.1,POINTER_",",1) Q + S POINTER=+$$GET^XUA4A72(IEN) I POINTER>0 S TAXON=$$GET1^DIQ(8932.1,POINTER_",",6),DESCRREF=$$GET1^DIQ(8932.1,POINTER_",",1) ; XU*8*435 make sure active on today + I TAXON="" S TAXON=-1,DESCRREF=" " + Q TAXON + ; +CHKTAXON(IEN,TAXONOMY) ; checks whether taxonomy value (X12) is in list of billable otherwise 0-1 + N DESCRIP,XUSGLOB + I $G(TAXONOMY)="" S TAXONOMY=$$GETTAXON(IEN,.DESCRIP) + S XUSGLOB=$$CHKGLOB() + Q $D(@XUSGLOB@(TAXONOMY)) + ; +DATE10(DATE) ; returns date in mm/dd/yyyyy format + Q $E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_(1700+$E(DATE,1,3)) + ; +POSTINIT ; runs post init + D POSTINIT^XUSNPIE1 + Q + ; +CBOQUEUE ; queues CBO List to run on first day of month + D CBOQUEUE^XUSNPIE1 + Q +ALIGNRGT(TEXT,WIDTH) ; align text right in a specified width + Q $$ALIGNRGT^XUSNPIE2(TEXT,WIDTH) diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIX1.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIX1.m index 7bb10ec1..87619181 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIX1.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIX1.m @@ -1,273 +1,249 @@ -XUSNPIX1 ;OAK_BP/CMW - NPI EXTRACT REPORT ;11:45 AM 28 Jul 2009 - ;;8.0;KERNEL;**438,452,453,481,WV**; Jul 10, 1995;Build 21 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ; NPI Extract Report - ; - ; Input parameter: N/A - ; - ; Other relevant variables: - ; XUSRTN="XUSNPIX1" (current routine name, used for ^XTMP and ^TMP - ; storage subscript) - ; Storage Global: - ; ^XTMP("XUSNPIX1",0) = Piece 1^Piece 2^Piece 3^Piece 4^Piece 5^Piece 6 - ; where: - ; Piece 1 => Purge Date - 1 year in future - ; Piece 2 => Create Date - Today - ; Piece 3 => Description - ; Piece 4 => Last Date Compiled - ; Piece 5 => $H last run start time - ; Piece 6 => $H last run completion time - ; - ; ^XTMP("XUSNPIX1",1) = DATA - ; - ; XUSNPI => Unique NPI of entry - ; LDT => Last Date Run, VA Fileman Format - ; - ; Entry Point - TASKMAN => Run report in background using TASKMAN - ; - Q - ; -TASKMAN ;TASKMAN ENTRY POINT - ; Process Report - N XUSRTN,DTTM,XUSPROD,XUSVER,INSMAIL - ; - ; Check for required variables - I $G(U)=""!($G(DT)="") G EXIT - S XUSRTN="XUSNPIX1" - S DTTM=$$HTE^XLFDT($H,"2") - ; Check to see if report is in use - L +^XTMP(XUSRTN):5 I '$T G EXIT - ; - ;Reset Summary Scratch Globals - K ^TMP("XUSNPIXS",$J) - K ^TMP("XUSNPIXT",$J) - ; - ; Initialize variables - D INIT(XUSRTN) - ; - ; Pull Station(Institution) data - D INST(XUSRTN,XUSVER,.INSMAIL) - ; - ;Process New Person File - D PROC1(XUSRTN,XUSPROD,XUSVER,DTTM,INSMAIL) - ; - ; Process Institution File - D ENT^XUSNPIX2(XUSPROD,XUSVER) - ; - ; Process Non VA File - D ENT^XUSNPIX3(XUSPROD,XUSVER) - ; - ; Send summary message - D SMAIL^XUSNPIX5("XUSNPIXT",XUSPROD,XUSVER,DTTM) - ; - ;Standard EXIT point -EXIT ; - K DTTM,XUSVER,XUSHDR,XUSPROD,INSMAIL - ; - ;Kill off Scratch Globals - K ^TMP("XUSNPIXS",$J) - K ^TMP("XUSNPIXT",$J) - K ^TMP("XUSNPIXU",$J) - ; Log Run Completion Time - S $P(^XTMP(XUSRTN,0),U,6)=$H - L -^XTMP(XUSRTN) - ; - Q - ; -INIT(XUSRTN) ; check/init variables - N XUSDESC - ; Set to NEXT release version from NPM - S XUSVER="481.5" - ; Get production/test account flag - S XUSPROD=$S($$PROD^XUPROD(1):"PROD",1:"TEST") - ; - ; Reset Temporary Scratch Global - D INIT^XUSNPIXU - K ^TMP(XUSRTN) - S XUSDESC="NPI EXTRACT TYPE 1 - Do Not Delete" - S ^XTMP(XUSRTN,0)=(DT+10000)_U_DT_U_XUSDESC_U_DT_U_$H - ; Generate TMP BCBS Array - D BCBSID^XUSNPIXU - ; - Q - ; -INST(XUSRTN,XUSVER,INSMAIL) ;Pull station and Institution info - N INST,SINFO,DIC4 - ; Pull site info - S SINFO=$$SITE^VASITE - ; Station Number - S SITE=$P(SINFO,U,3) - ; Institution - S INST=$P(SINFO,U) - ; - ; Get institution mailing address - I INST D - . S DIC4=$G(^DIC(4,INST,4)) - . S XUSNP(7)=$P(DIC4,U) - . S XUSNP(8)=$P(DIC4,U,2) - . S XUSNP(9)=$P(DIC4,U,3) - . S XUSNP(10)=$P(DIC4,U,4) - . I XUSNP(10) S XUSNP(10)=$P($G(^DIC(5,XUSNP(10),0)),U,2) - . S XUSNP(11)=$P(DIC4,U,5) - . S INSMAIL=XUSNP(7)_U_XUSNP(8)_U_XUSNP(9)_U_XUSNP(10)_U_XUSNP(11) - S XUSHDR="Station: "_SITE_U_XUSNP(9)_U_XUSNP(10)_U_XUSNP(11)_U_"TYPE 1"_U_XUSVER - ; - Q - ; -PROC1(XUSRTN,XUSPROD,XUSVER,DTTM,INSMAIL) ;Process all New Person records - N XUSNPI,XUSDT,XUSNEW,XUSI,XUSDATA,XUSVA0,XUSVA0,XUSVA1,XUSNAME,XUSDOB,XUSDIV,XUSSTL,XUSSTLN,XUSOPN - N XUSPER,XUSSPC,XUSTAX,XUSTAXID,XUSIZE,NPIEN,DIC4,SPDIV,VA12,VA13,COUNT,MSGCNT,MAXSIZE,TOTREC,XUSEOL - ; - ; Set to 300000 for live - S MAXSIZE=300000 - ; - ; Set end of line character - S XUSEOL="~~" - ; - ; set counter - S COUNT=1,(TOTREC,MSGCNT,XUSIZE)=0 - ; Loop through NEW PERSON NPI records NPI cross ref - S XUSNPI=0 - F S XUSNPI=$O(^VA(200,"ANPI",XUSNPI)) Q:'XUSNPI D - . S NPIEN=$O(^VA(200,"ANPI",XUSNPI,"")) - . ; - . ; Init columns - . F XUSI=1:1:29 S XUSNP(XUSI)="" - . S XUSNP(1)=XUSNPI S XUSDATA1=XUSNP(1) - . ; - . S XUSVA0=$G(^VA(200,NPIEN,0)) - . S XUSVA1=$G(^VA(200,NPIEN,1)) - . S XUSNAME=$P(XUSVA0,U) - . ; BREAK NAME INTO COMPONENTS - . I XUSNAME'="" D - . . ;Begin WorldVistA Change; 07/28/2009 - . . ;S XLFNC=XUSNAME D FORMAT^XLFNAME7(.XLFNC,,,,0) - . . S XLFNC=XUSNAME S XLFNC=$$FORMAT^XLFNAME7(.XLFNC,,,,0) - . . ;End WorldVistA change - . . S XUSNP(2)=XLFNC("GIVEN"),XUSNP(3)=XLFNC("MIDDLE"),XUSNP(4)=XLFNC("FAMILY") - . . I XLFNC("SUFFIX")'="" S XUSNP(4)=XUSNP(4)_" "_XLFNC("SUFFIX") - . . K XLFNC - . S XUSDATA1=XUSDATA1_U_XUSNP(2)_U_XUSNP(3)_U_XUSNP(4) - . S XUSNP(5)=1 ;TYPE - . S XUSDOB=$P(XUSVA1,U,3) - . ; dob formatted as mm/dd/yyyy - . I XUSDOB D - . . S XUSNP(6)=$$FMTE^XLFDT(XUSDOB,5) - . S XUSDATA1=XUSDATA1_U_XUSNP(5)_U_XUSNP(6) - . ; - . ; Pay to Provider Address Use primary institution mailing address NP7-11 - . S XUSDATA1=XUSDATA1_U_INSMAIL - . ; - . ; Servicing Provider Address - . S (XUSDIV)=0 - . ; Loop through Division multiple - . F S XUSDIV=$O(^VA(200,NPIEN,2,XUSDIV)) Q:'XUSDIV D - . . S DIC4=$G(^DIC(4,XUSDIV,4)) - . . S XUSNP(12)=$P(DIC4,U) - . . S XUSNP(13)=$P(DIC4,U,2) - . . S XUSNP(14)=$P(DIC4,U,3) - . . S XUSNP(15)=$P(DIC4,U,4) - . . I XUSNP(15) S XUSNP(15)=$P($G(^DIC(5,XUSNP(15),0)),U,2) - . . S XUSNP(16)=$P(DIC4,U,5) - . . S XUSSTA(XUSDIV)=$P($G(^DIC(4,XUSDIV,99)),U) - . . S SPADR(XUSDIV)=XUSNP(12)_U_XUSNP(13)_U_XUSNP(14)_U_XUSNP(15)_U_XUSNP(16) - . ; If no divisions found - . I '$D(SPADR) D - . . S XUSSTA(9999)="N/A",SPADR(9999)=XUSNP(12)_U_XUSNP(13)_U_XUSNP(14)_U_XUSNP(15)_U_XUSNP(16) - . ; - . ; Office Phone number - . S XUSOPN=$P($G(^VA(200,NPIEN,.13)),U,2) - . I XUSOPN'="" S XUSNP(17)=XUSOPN - . ; - . ; Degree - . S XUSNP(18)=$P($G(^VA(200,NPIEN,3.1)),U,6) - . ; Degree Code (place holder) - . S XUSNP(19)="" - . ; - . ; get taxonomy and specialty - . S XUSPER=0 - . F S XUSPER=$O(^VA(200,NPIEN,"USC1","B",XUSPER)) Q:'XUSPER D - . . S XUSSPC=$P($G(^USC(8932.1,XUSPER,0)),U,9) - . . S XUSTAX=$P($G(^USC(8932.1,XUSPER,0)),U,7) - . . I XUSSPC'="" D - . . . I XUSNP(20)="" S XUSNP(20)=XUSSPC Q - . . . S XUSNP(20)=XUSNP(20)_";"_XUSSPC - . . I XUSTAX'="" D - . . . I XUSNP(21)="" S XUSNP(21)=XUSTAX Q - . . . S XUSNP(21)=XUSNP(21)_";"_XUSTAX - . ; - . ; Tax ID - . S XUSTAXID=$P($G(^VA(200,NPIEN,"TPB")),U,2) - . I XUSTAXID="" S XUSTAXID=$P($G(^VA(200,NPIEN,1)),U,9) - . S XUSNP(22)=XUSTAXID - . ; - . S XUSDATA2=XUSNP(17)_U_XUSNP(18)_U_XUSNP(19)_U_XUSNP(20)_U_XUSNP(21)_U_XUSNP(22) - . ; - . ; Medicare Part A/B - . S XUSNP(23)=670899 - . S XUSNP(24)="VA"_$E(SITE+10000,2,5) - . ; - . ; State License - . S XUSSTL=0 - . F S XUSSTL=$O(^VA(200,NPIEN,"PS1",XUSSTL)) Q:'XUSSTL D - . . S XUSSTLN=$P($G(^VA(200,NPIEN,"PS1",XUSSTL,0)),U,2) - . . I XUSSTLN'="" D - . . . I XUSNP(25)="" S XUSNP(25)=XUSSTLN Q - . . . S XUSNP(25)=XUSNP(25)_";"_XUSSTLN - . ; DEA # - . S XUSNP(26)=$P($G(^VA(200,NPIEN,"PS")),U,2) - . ; - . S XUSDATA2=XUSDATA2_U_XUSNP(23)_U_XUSNP(24)_U_XUSNP(25)_U_XUSNP(26) - . ; - . ; Station # - . S XUSNP(27)="" - . ; - . ; Get BCBS Payer ID Array - . K XUSBXID - . D PRACID^XUSNPIXU(NPIEN,.XUSBXID) - . ; - . ; Save entry to ^TMP and update count - . N XUSB - . S XUSDIV=0 - . F S XUSDIV=$O(SPADR(XUSDIV)) Q:'XUSDIV D - . . S COUNT=COUNT+1,TOTREC=TOTREC+1 - . . S ^TMP(XUSRTN,$J,COUNT)=XUSDATA1_U_SPADR(XUSDIV)_U_XUSDATA2_U_XUSSTA(XUSDIV)_U_XUSEOL - . . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,COUNT)) - . . ; Check BCBS Id array - . . I $D(XUSBXID) D - . . . S XUSB="" - . . . F S XUSB=$O(XUSBXID(XUSB)) Q:XUSB="" D - . . . . S COUNT=COUNT+1,TOTREC=TOTREC+1 - . . . . S ^TMP(XUSRTN,$J,COUNT)=XUSDATA1_U_SPADR(XUSDIV)_U_XUSDATA2_U_XUSSTA(XUSDIV)_U_XUSB_U_XUSEOL - . . . . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,COUNT)) - . K XUSNP,XUSDATA1,XUSDATA2,XUSDATA3,SPADR,XUSBXID,CNT,XUSSTA - . I XUSIZE>MAXSIZE D - . . D EOF(XUSRTN) - . . D EMAIL^XUSNPIX5(XUSRTN) - . . K ^TMP(XUSRTN,$J) - . . S ^TMP("XUSNPIXS",$J,1,MSGCNT)="1^"_(COUNT-2) - . . S ^TMP(XUSRTN,$J,1)=XUSHDR - . . S COUNT=1,XUSIZE=0 - D EOF(XUSRTN) - ; - ; Send the last message (if it has records) - I $G(COUNT)>1 D - .D EMAIL^XUSNPIX5(XUSRTN) - .K ^TMP(XUSRTN,$J) - .S ^TMP("XUSNPIXS",$J,1,MSGCNT)="1^"_(COUNT-2) - ; - ; Set summary totals - S ^XTMP("XUSNPIXT",0)=(DT+10000)_U_DT_U_"NPI EXTRACT SUMMARY TOTALS"_U_DT_U_$H - S ^XTMP("XUSNPIXT","H")=$P(XUSHDR,U,1,4) - S ^XTMP("XUSNPIXT",1)=MSGCNT_U_TOTREC_U_DTTM - K INSMAIL,SITE - Q - ; -EOF(XUSRTN) ; - Q:COUNT=1 - S MSGCNT=MSGCNT+1 - S ^TMP(XUSRTN,$J,1)=XUSHDR_U_"Message Number: "_MSGCNT_U_"Line Count: "_COUNT_U_DTTM_U_$G(XUSPROD)_U_XUSEOL - S COUNT=COUNT+1 - S ^TMP(XUSRTN,$J,COUNT)="END OF FILE"_U_XUSEOL - Q +XUSNPIX1 ;OAK_BP/CMW - NPI EXTRACT REPORT ;01-OCT-06 + ;;8.0;KERNEL;**438,452,453**; Jul 10, 1995;Build 36 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; + ; NPI Extract Report + ; + ; Input parameter: N/A + ; + ; Other relevant variables: + ; XUSRTN="XUSNPIX1" (current routine name, used for ^XTMP and ^TMP + ; storage subscript) + ; Storage Global: + ; ^XTMP("XUSNPIX1",0) = Piece 1^Piece 2^Piece 3^Piece 4^Piece 5^Piece 6 + ; where: + ; Piece 1 => Purge Date - 1 year in future + ; Piece 2 => Create Date - Today + ; Piece 3 => Description + ; Piece 4 => Last Date Compiled + ; Piece 5 => $H last run start time + ; Piece 6 => $H last run completion time + ; + ; ^XTMP("XUSNPIX1",1) = DATA + ; + ; XUSNPI => Unique NPI of entry + ; LDT => Last Date Run, VA Fileman Format + ; + ; Entry Point - TASKMAN => Run report in background using TASKMAN + ; + Q + ; +TASKMAN ;TASKMAN ENTRY POINT + ; Process Report + N XUSRTN,DTTM + ; Check for required variables + I $G(U)=""!($G(DT)="") G EXIT + S XUSRTN="XUSNPIX1" + S DTTM=$$HTE^XLFDT($H,"2") + ; Check to see if report is in use + L +^XTMP(XUSRTN):5 I '$T G EXIT + ; + D INIT(XUSRTN) + ; Pull Station(Institution) data + D INST(XUSRTN) + ; + D PROC1(XUSRTN) + ; Send the message + D EMAIL^XUSNPIX5(XUSRTN) + D VMAIL^XUSNPIX5(XUSRTN) + ; + ; Process Institution File + D ENT^XUSNPIX2 + ; + ; Process Non VA File + D ENT^XUSNPIX3 + ; + ; Send summary message + D SMAIL^XUSNPIX5("XUSNPIXT") + ; + ;Standard EXIT point +EXIT ; + K XUSEOL,DTTM,MAXSIZE,XUSVER,XUSHDR,XUSPROD + K MSGCNT,TOTREC,COUNT + K ^TMP("XUSNPIXU",$J) + ; Log Run Completion Time + S $P(^XTMP(XUSRTN,0),U,6)=$H + L -^XTMP(XUSRTN) + ; + Q + ; +INIT(XUSRTN) ; check/init variables + N XUSDESC + ; Set to NEXT release version from NPM + S XUSVER="453.16" + ; Get production/test account flag + S XUSPROD=$S($$PROD^XUPROD(1):"PROD",1:"TEST") + ; Set end of line character + S XUSEOL="~~" + ; Set to 300000 for live + S MAXSIZE=300000 + ; Reset Temporary Scratch Global + D INIT^XUSNPIXU + K ^TMP(XUSRTN) + S XUSDESC="NPI EXTRACT TYPE 1 - Do Not Delete" + S ^XTMP(XUSRTN,0)=(DT+10000)_U_DT_U_XUSDESC_U_DT_U_$H + ; Generate TMP BCBS Array + D BCBSID^XUSNPIXU + ; + Q + ; +INST(XUSRTN) ;Pull station and Institution info + N INST,SINFO,DIC4 + ; Pull site info + S SINFO=$$SITE^VASITE + ; Station Number + S SITE=$P(SINFO,U,3) + ; Institution + S INST=$P(SINFO,U) + ; + ; Get institution mailing address + I INST D + . S DIC4=$G(^DIC(4,INST,4)) + . S XUSNP(7)=$P(DIC4,U) + . S XUSNP(8)=$P(DIC4,U,2) + . S XUSNP(9)=$P(DIC4,U,3) + . S XUSNP(10)=$P(DIC4,U,4) + . I XUSNP(10) S XUSNP(10)=$P($G(^DIC(5,XUSNP(10),0)),U,2) + . S XUSNP(11)=$P(DIC4,U,5) + . S INSMAIL=XUSNP(7)_U_XUSNP(8)_U_XUSNP(9)_U_XUSNP(10)_U_XUSNP(11) + S XUSHDR="Station: "_SITE_U_XUSNP(9)_U_XUSNP(10)_U_XUSNP(11)_U_"TYPE 1"_U_XUSVER + ; + Q + ; +PROC1(XUSRTN) ;Process all New Person records + N XUSNPI,XUSDT,XUSNEW,XUSI,XUSDATA,XUSVA0,XUSVA0,XUSVA1,XUSNAME,XUSDOB,XUSDIV,XUSSTL,XUSSTLN,XUSOPN + N XUSPER,XUSSPC,XUSTAX,XUSTAXID,XUSIZE,NPIEN,DIC4,SPDIV,VA12,VA13 + ; set counter + S COUNT=1,(TOTREC,MSGCNT,XUSIZE)=0 + ; Loop through NEW PERSON NPI records NPI cross ref + S XUSNPI=0 + F S XUSNPI=$O(^VA(200,"ANPI",XUSNPI)) Q:'XUSNPI D + . S NPIEN=$O(^VA(200,"ANPI",XUSNPI,"")) + . ; + . ; Init columns + . F XUSI=1:1:29 S XUSNP(XUSI)="" + . S XUSNP(1)=XUSNPI S XUSDATA1=XUSNP(1) + . ; + . S XUSVA0=$G(^VA(200,NPIEN,0)) + . S XUSVA1=$G(^VA(200,NPIEN,1)) + . S XUSNAME=$P(XUSVA0,U) + . ; BREAK NAME INTO COMPONENTS + . I XUSNAME'="" D + . . S XLFNC=XUSNAME D FORMAT^XLFNAME7(.XLFNC,,,,0) + . . S XUSNP(2)=XLFNC("GIVEN"),XUSNP(3)=XLFNC("MIDDLE"),XUSNP(4)=XLFNC("FAMILY") + . . I XLFNC("SUFFIX")'="" S XUSNP(4)=XUSNP(4)_" "_XLFNC("SUFFIX") + . . K XLFNC + . S XUSDATA1=XUSDATA1_U_XUSNP(2)_U_XUSNP(3)_U_XUSNP(4) + . S XUSNP(5)=1 ;TYPE + . S XUSDOB=$P(XUSVA1,U,3) + . ; dob formatted as mm/dd/yyyy + . I XUSDOB D + . . S XUSNP(6)=$$FMTE^XLFDT(XUSDOB,5) + . S XUSDATA1=XUSDATA1_U_XUSNP(5)_U_XUSNP(6) + . ; + . ; Pay to Provider Address Use primary institution mailing address NP7-11 + . S XUSDATA1=XUSDATA1_U_INSMAIL + . ; + . ; Servicing Provider Address + . S (XUSDIV)=0 + . ; Loop through Division multiple + . F S XUSDIV=$O(^VA(200,NPIEN,2,XUSDIV)) Q:'XUSDIV D + . . S DIC4=$G(^DIC(4,XUSDIV,4)) + . . S XUSNP(12)=$P(DIC4,U) + . . S XUSNP(13)=$P(DIC4,U,2) + . . S XUSNP(14)=$P(DIC4,U,3) + . . S XUSNP(15)=$P(DIC4,U,4) + . . I XUSNP(15) S XUSNP(15)=$P($G(^DIC(5,XUSNP(15),0)),U,2) + . . S XUSNP(16)=$P(DIC4,U,5) + . . S XUSSTA(XUSDIV)=$P($G(^DIC(4,XUSDIV,99)),U) + . . S SPADR(XUSDIV)=XUSNP(12)_U_XUSNP(13)_U_XUSNP(14)_U_XUSNP(15)_U_XUSNP(16) + . ; If no divisions found + . I '$D(SPADR) D + . . S XUSSTA(9999)="N/A",SPADR(9999)=XUSNP(12)_U_XUSNP(13)_U_XUSNP(14)_U_XUSNP(15)_U_XUSNP(16) + . ; + . ; Office Phone number + . S XUSOPN=$P($G(^VA(200,NPIEN,.13)),U,2) + . I XUSOPN'="" S XUSNP(17)=XUSOPN + . ; + . ; Degree + . S XUSNP(18)=$P($G(^VA(200,NPIEN,3.1)),U,6) + . ; Degree Code (place holder) + . S XUSNP(19)="" + . ; + . ; get taxonomy and specialty + . S XUSPER=0 + . F S XUSPER=$O(^VA(200,NPIEN,"USC1","B",XUSPER)) Q:'XUSPER D + . . S XUSSPC=$P($G(^USC(8932.1,XUSPER,0)),U,9) + . . S XUSTAX=$P($G(^USC(8932.1,XUSPER,0)),U,7) + . . I XUSSPC'="" D + . . . I XUSNP(20)="" S XUSNP(20)=XUSSPC Q + . . . S XUSNP(20)=XUSNP(20)_";"_XUSSPC + . . I XUSTAX'="" D + . . . I XUSNP(21)="" S XUSNP(21)=XUSTAX Q + . . . S XUSNP(21)=XUSNP(21)_";"_XUSTAX + . ; + . ; Tax ID + . S XUSTAXID=$P($G(^VA(200,NPIEN,"TPB")),U,2) + . I XUSTAXID="" S XUSTAXID=$P($G(^VA(200,NPIEN,1)),U,9) + . S XUSNP(22)=XUSTAXID + . ; + . S XUSDATA2=XUSNP(17)_U_XUSNP(18)_U_XUSNP(19)_U_XUSNP(20)_U_XUSNP(21)_U_XUSNP(22) + . ; + . ; Medicare Part A/B + . S XUSNP(23)=670899 + . S XUSNP(24)="VA"_$E(SITE+10000,2,5) + . ; + . ; State License + . S XUSSTL=0 + . F S XUSSTL=$O(^VA(200,NPIEN,"PS1",XUSSTL)) Q:'XUSSTL D + . . S XUSSTLN=$P($G(^VA(200,NPIEN,"PS1",XUSSTL,0)),U,2) + . . I XUSSTLN'="" D + . . . I XUSNP(25)="" S XUSNP(25)=XUSSTLN Q + . . . S XUSNP(25)=XUSNP(25)_";"_XUSSTLN + . ; DEA # + . S XUSNP(26)=$P($G(^VA(200,NPIEN,"PS")),U,2) + . ; + . S XUSDATA2=XUSDATA2_U_XUSNP(23)_U_XUSNP(24)_U_XUSNP(25)_U_XUSNP(26) + . ; + . ; Station # + . S XUSNP(27)="" + . ; + . ; Get BCBS Payer ID Array + . K XUSBXID + . D PRACID^XUSNPIXU(NPIEN,.XUSBXID) + . ; + . ; Save entry to ^TMP and update count + . N XUSB + . S XUSDIV=0 + . F S XUSDIV=$O(SPADR(XUSDIV)) Q:'XUSDIV D + . . S COUNT=COUNT+1,TOTREC=TOTREC+1 + . . S ^TMP(XUSRTN,$J,COUNT)=XUSDATA1_U_SPADR(XUSDIV)_U_XUSDATA2_U_XUSSTA(XUSDIV)_U_XUSEOL + . . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,COUNT)) + . . ; Check BCBS Id array + . . I $D(XUSBXID) D + . . . S XUSB="" + . . . F S XUSB=$O(XUSBXID(XUSB)) Q:XUSB="" D + . . . . S COUNT=COUNT+1,TOTREC=TOTREC+1 + . . . . S ^TMP(XUSRTN,$J,COUNT)=XUSDATA1_U_SPADR(XUSDIV)_U_XUSDATA2_U_XUSSTA(XUSDIV)_U_XUSB_U_XUSEOL + . . . . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,COUNT)) + . K XUSNP,XUSDATA1,XUSDATA2,XUSDATA3,SPADR,XUSBXID,CNT,XUSSTA + . I XUSIZE>MAXSIZE D + . . D EOF(XUSRTN) + . . D EMAIL^XUSNPIX5(XUSRTN) + . . D VMAIL^XUSNPIX5(XUSRTN) + . . S ^TMP(XUSRTN,$J,1)=XUSHDR + . . S COUNT=1,XUSIZE=0 + D EOF(XUSRTN) + ; set summary totals + S ^XTMP("XUSNPIXT",0)=(DT+10000)_U_DT_U_"NPI EXTRACT SUMMARY TOTALS"_U_DT_U_$H + S ^XTMP("XUSNPIXT","H")=$P(XUSHDR,U,1,4) + S ^XTMP("XUSNPIXT",1)=MSGCNT_U_TOTREC_U_DTTM + K INSMAIL,SITE + Q + ; +EOF(XUSRTN) ; + S MSGCNT=MSGCNT+1 + S ^TMP(XUSRTN,$J,1)=XUSHDR_U_"Message Number: "_MSGCNT_U_"Line Count: "_COUNT_U_DTTM_U_$G(XUSPROD)_U_XUSEOL + S COUNT=COUNT+1 + S ^TMP(XUSRTN,$J,COUNT)="END OF FILE"_U_XUSEOL + Q diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIX2.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIX2.m index c61a9756..f33b610d 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIX2.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIX2.m @@ -1,298 +1,301 @@ -XUSNPIX2 ;OAK_BP/CMW - NPI EXTRACT REPORT ;7/7/08 17:17 - ;;8.0;KERNEL;**438,452,453,481**; Jul 10, 1995;Build 21 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ; NPI Extract Report - ; - ; Input parameter: N/A - ; - ; Other relevant variables: - ; XUSRTN="XUSNPIX2" (current routine name, used for ^XTMP and ^TMP - ; storage subscript) - ; Storage Global: - ; ^XTMP("XUSNPIX2",0) = Piece 1^Piece 2^Piece 3^Piece 4^Piece 5^Piece 6 - ; where: - ; Piece 1 => Purge Date - 1 year in future - ; Piece 2 => Create Date - Today - ; Piece 3 => Description - ; Piece 4 => Last Date Compiled - ; Piece 5 => $H last run start time - ; Piece 6 => $H last run completion time - ; - ; ^XTMP("XUSNPIX2",1) = STATION INFO - ; ^XTMP("XUSNPIX2",2) = DATA - ; - ; NPI => Unique NPI of entry - ; LDT => Last Date Run, VA Fileman Format - ; - ; Entry Point - ENT called from XUSNPIX1 - ; - Q - ; -ENT(XUSPROD,XUSVER) ; ENTRY POINT - ; Initialize variables - N XUSRTN - S XUSRTN="XUSNPIX2" - S DTTM2=$$HTE^XLFDT($H,"2") - ; Check to see if report is in use - L +^XTMP(XUSRTN):5 I '$T G EXIT - ; Process Institution File - D INIT(XUSRTN) - ; Pull Station(Institution) data - D STAT(XUSRTN) - ; Process Report - D PROC2(XUSRTN,XUSPROD,DTTM2) - ; - ; Standard EXIT point -EXIT ; - K ^TMP(XUSRTN,$J),^TMP($J,"XUS59"),^TMP("XUSNPIX",$J) - ; Log Run Completion Time - S $P(^XTMP(XUSRTN,0),U,6)=$H - L -^XTMP(XUSRTN) - K P,XUSPT,INST,DTTM2,XUSIZE,XUSHDR,XUSTAXID - Q - ; -INIT(XUSRTN) ; check/init variables - N XUSDESC - ; - ; Reset Temporary Scratch Global - K ^TMP(XUSRTN) - S XUSDESC="NPI EXTRACT TYPE 2 - Do Not Delete" - S ^XTMP(XUSRTN,0)=(DT+10000)_U_DT_U_XUSDESC_U_DT_U_$H - ; - I '$D(^TMP("XUSNPIXU",$J)) D BCBSID^XUSNPIXU - ; - ; Create pharmacy institution ^TMP file - D GETPHARM - Q - ; -STAT(XUSRTN) ; Pull station and Institution info - N SINFO,DIC4,IBSITE,IBFAC,IB0 - ; Pull site info - S SINFO=$$SITE^VASITE - ; Station Number - S SITE=$P(SINFO,U,3) - ; Institution - S INST=$P(SINFO,U) - ; - ; Get Federal Tax Id - S XUSTAXID="" - S IBSITE=0 - F S IBSITE=$O(^IBE(350.9,IBSITE)) Q:'IBSITE!(XUSTAXID'="") D - . S XUSTAXID=$P($G(^IBE(350.9,IBSITE,1)),U,5) - ; - ; Get institution mailing address (PAY TO) - ;ST ADDR 1,ST ADDR 2,CITY,ZIP - I INST D - . S DIC4=$G(^DIC(4,INST,4)) - . S XUSPT(4)=$P(DIC4,U) - . S XUSPT(5)=$P(DIC4,U,2) - . S XUSPT(6)=$P(DIC4,U,3) - . S XUSPT(7)=$P(DIC4,U,4) - . I XUSPT(7) S XUSPT(7)=$P($G(^DIC(5,XUSPT(7),0)),U,2) - . S XUSPT(8)=$P(DIC4,U,5) - . S PTPMAIL=XUSPT(4)_U_XUSPT(5)_U_XUSPT(6)_U_XUSPT(7)_U_XUSPT(8) - S XUSHDR="Station: "_SITE_U_XUSPT(6)_U_XUSPT(7)_U_XUSPT(8)_U_"TYPE 2"_U_XUSVER - ; - Q - ; -PROC2(XUSRTN,XUSPROD,DTTM2) ;Process all Institution records - N XUSNPI,XUSNEW,XUSDT,XUSI,XUSIN,XUSTXY,XUSSPC,XUSTAX,XUPHM - N XUSFCT,XUSFCN,XUSDATA1,XUSDATA2,XUSDATA3,XUSDATA4,XUSDATA5,XUSSTA,XUSEOL - N INIEN,DIC0,DIC1,PSIEN,NPIINS,RELINS,PSSTA,COUNT,TOTREC,MSGCNT,MAXSIZE - ; - ; Set to 300000 for live - S MAXSIZE=300000 - ; - ; Set end of line character - S XUSEOL="~~" - ; - ; set counter - S COUNT=1,(TOTREC,MSGCNT,XUSIZE)=0 - ; Loop through INSTITUTION NPI records NPI xref - S XUSNPI=0 - F S XUSNPI=$O(^DIC(4,"ANPI",XUSNPI)) Q:'XUSNPI D - . S INIEN=$O(^DIC(4,"ANPI",XUSNPI,"")) - . ; - . ; Get Station Number - . S XUSSTA=$P($G(^DIC(4,INIEN,99)),U) - . ; Parent of Association - . I (INIEN'=INST)&('$$POA(INIEN,INST)) Q - . ; Initialize columns - . F XUSI=1:1:24 S XUSIN(XUSI)="" - . ; - . S XUSIN(1)=XUSNPI - . S DIC0=$G(^DIC(4,INIEN,0)) Q:DIC0="" - . ;Organization Name - . S XUSIN(2)=$P($G(DIC0),U) - . S XUSIN(3)=2 - . S XUSDATA1=XUSIN(1)_U_XUSIN(2)_U_XUSIN(3) - . ; - . ; Pay to Provider Address - . S XUSDATA2=PTPMAIL - . ; - . ; Servicing Provider Address - . S DIC1=$G(^DIC(4,INIEN,1)) - . I DIC1'="" D - . . S XUSIN(9)=$P(DIC1,U) - . . S XUSIN(10)=$P(DIC1,U,2) - . . S XUSIN(11)=$P(DIC1,U,3) - . . S XUSIN(12)=$P($G(DIC0),U,2) - . . I XUSIN(12) S XUSIN(12)=$P($G(^DIC(5,XUSIN(12),0)),U,2) - . . S XUSIN(13)=$P(DIC1,U,4) - . S XUSDATA3=XUSIN(9)_U_XUSIN(10)_U_XUSIN(11)_U_XUSIN(12)_U_XUSIN(13) - . ; - . ;Phone number (place holder) - . S XUSIN(14)="" - . ; - . ; Get Taxonomy and Specialty - . S XUSTXY=0 - . F S XUSTXY=$O(^DIC(4,INIEN,"TAXONOMY","B",XUSTXY)) Q:'XUSTXY D - . . S XUSSPC=$P($G(^USC(8932.1,XUSTXY,0)),U,9) - . . S XUSTAX=$P($G(^USC(8932.1,XUSTXY,0)),U,7) - . . I XUSSPC'="" D - . . . I XUSIN(15)="" S XUSIN(15)=XUSSPC Q - . . . S XUSIN(15)=XUSIN(15)_";"_XUSSPC - . . I XUSTAX'="" D - . . . I XUSIN(16)="" S XUSIN(16)=XUSTAX Q - . . . S XUSIN(16)=XUSIN(16)_";"_XUSTAX - . ; - . ; Federal Tax ID - . S XUSIN(17)=$G(XUSTAXID) - . ; - . ; Medicaid Part A/B - . S XUSIN(18)=670899 - . S XUSIN(19)="VA"_$E(SITE+10000,2,5) - . ; - . S XUSDATA4=XUSIN(14)_U_XUSIN(15)_U_XUSIN(16)_U_XUSIN(17)_U_XUSIN(18)_U_XUSIN(19) - . ; - . ; DEA Number - . S XUSIN(20)=$P($G(^DIC(4,INIEN,"DEA")),U) - . ; - . ; get Facility Type and Name - . S XUSFCT=$P($G(^DIC(4,INIEN,3)),U) - . I XUSFCT'="" S XUSFCN=$P($G(^DIC(4.1,XUSFCT,0)),U) - . I $G(XUSFCN)="PHARM" D - . . I $D(^TMP("XUSNPIX",$J,INIEN)) D - . . . S XUPHM=^TMP("XUSNPIX",$J,INIEN) - . . . ; get NCPDP from ^TMP - . . . S XUSIN(21)=$P($G(XUPHM),U) - . . . ; get station number from^TMP - . . . I $P($G(XUPHM),U,2) S XUSSTA=$P(XUPHM,U,2) - . ; - . ; VISN Station Number - . S XUSIN(22)=XUSSTA - . ; - . S XUSDATA5=XUSIN(20)_U_XUSIN(21)_U_XUSIN(22) - . ; - . ; Get BCBS Payer ID Array - . K XUSBXID - . D INSTID^XUSNPIXU(.XUSBXID) - . ; - . ; Update counter and save Entry - . ; - . S COUNT=COUNT+1,TOTREC=TOTREC+1 - . S ^TMP(XUSRTN,$J,COUNT)=XUSDATA1_U_XUSDATA2_U_XUSDATA3_U_XUSDATA4_U_XUSDATA5_U_XUSEOL - . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,COUNT)) - . I $D(XUSBXID) D - . . S XUSB="" - . . F S XUSB=$O(XUSBXID(XUSB)) Q:XUSB="" D - . . . S COUNT=COUNT+1,TOTREC=TOTREC+1 - . . . S ^TMP(XUSRTN,$J,COUNT)=XUSDATA1_U_XUSDATA2_U_XUSDATA3_U_XUSDATA4_U_XUSDATA5_U_XUSB_U_XUSBXID(XUSB)_U_XUSEOL - . . . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,COUNT)) - . K XUSIN,XUSDATA1,XUSDATA2,XUSDATA3,XUSDATA4,XUSDATA5,XUSB,XUSBXID - . I XUSIZE>MAXSIZE D - . . D EOF(XUSRTN) - . . D EMAIL(XUSRTN) - . . K ^TMP(XUSRTN,$J) - . . S ^TMP("XUSNPIXS",$J,2,MSGCNT)="2^"_(COUNT-2) - . . S ^TMP(XUSRTN,$J,1)=XUSHDR - . . S COUNT=1,XUSIZE=0 - ; - D EOF(XUSRTN) - ; - ; Send the last message (if it has records) - I $G(COUNT)>1 D - .D EMAIL(XUSRTN) - .K ^TMP(XUSRTN,$J) - .S ^TMP("XUSNPIXS",$J,2,MSGCNT)="2^"_(COUNT-2) - ; - ; Set Summary totals - S ^XTMP("XUSNPIXT",2)=MSGCNT_U_TOTREC_U_DTTM2 - ; - K XUSPT,PTPMAIL,LDTCMP,SITE,XUSTAXID - Q - ; -EOF(XUSRTN) ; - Q:COUNT=1 - S MSGCNT=MSGCNT+1 - S ^TMP(XUSRTN,$J,1)=XUSHDR_U_"Message Number: "_MSGCNT_U_"Line Count: "_COUNT_U_DTTM2_U_$G(XUSPROD)_U_XUSEOL - S COUNT=COUNT+1 - S ^TMP(XUSRTN,$J,COUNT)="END OF FILE"_U_XUSEOL - Q - ; - ; Email the message -EMAIL(XUSRTN) ; - N XMY - ; Send email to designated recipient for live release - S XMY("XXX@Q-NPS.VA.GOV")="" - D ESEND - Q - ; -ESEND N XMTEXT,XMSUB,XMDUN,XMDUZ,XMZ,XMMG,DIFROM - ; - S XMTEXT="^TMP("""_XUSRTN_""","_$J_"," - S XMSUB=$TR($P($G(^TMP(XUSRTN,$J,1)),U),":")_"("_$G(XUSPROD)_") NPI EXTRACT TYPE 2" - D ^XMD - Q -POA(IEN,INST) ; Check Parent of Association for Institution IEN up to VISN level to see if INST is in the chain - N XUSPOA - I +$G(INST)=0 Q 0 ; No institution - return false -POA1 ; - I $G(IEN)="" Q 0 ; No IEN remaining to check - return false - I $D(XUSPOA(IEN)) Q 0 ; Already reviewed this IEN - possible infinite loop - return false - S XUSPOA(IEN)="" - S XUSPOA=$P($G(^DIC(4,IEN,7,2,0)),U,2) ; Get parent of this institution - I XUSPOA=INST Q 1 ; Found matching institution - return true - I IEN=XUSPOA Q 0 ; Top level reached - return false - S IEN=XUSPOA ; Reset IEN to check next level - G POA1 - ; -GETPHARM ; - ; this subroutine retrieves data from the OUTPATIENT SITE file - ; using the supported Pharmacy API PSS^PSO59. - ; It takes the results and places them into a temporary - ; global array that is accessed when processing data - ; associated with a pharmacy institution. - N D,DIC,XUS59DA,XUSNPIDA,XUSRELDA,PSSTA,Y,X,XUNCP - ; - ;Fix for Remedy Ticket 217164 - ;Quit if Outpatient Site API routine is not loaded - S X="PSO59" X ^%ZOSF("TEST") Q:'$T - ; - K ^TMP($J,"XUS59"),^TMP("XUSNPIX",$J) ; remove any pre-existing nodes - D PSS^PSO59(,"??","XUS59") ;IA#4827 - S XUS59DA=0 - ; gather data from each Outpatient site entry stored in the pharmacy - ; ^TMP global and build 2nd ^TMP global for later processing - F S XUS59DA=$O(^TMP($J,"XUS59",XUS59DA)) Q:'XUS59DA D - . ; - . ;Get Pharmacy NPI institution from API - . S XUSNPIDA=$P($G(^TMP($J,"XUS59",XUS59DA,101)),U) - . Q:XUSNPIDA']"" ; NPI institution does not exist - . ; - . ; Get Pharmacy Related Institution from API - . S XUSRELDA=$P($G(^TMP($J,"XUS59",XUS59DA,100)),U) - . ; get station number off the related institution - . S PSSTA=$P($G(^DIC(4,XUSRELDA,99)),U) - . ; - . ; Get NCPDP number - . S XUNCP="" ;prevent previous values being carried over - . S X=XUSNPIDA S D="C",DIC=9002313.56,DIC(0)="" D IX^DIC - . I +Y>0 S XUNCP=$$GET1^DIQ(9002313.56,+Y,.02) - . S:$G(XUNCP)="" XUNCP=$P($G(^TMP($J,"XUS59",XUS59DA,1008)),U) - . ; - . ; rebuild the ^TMP global by NPI institution - . ; collect necessary data used in the 'PHARM' logic - . S ^TMP("XUSNPIX",$J,XUSNPIDA)=XUNCP_"^"_PSSTA ; ncpdp#^station - Q +XUSNPIX2 ;OAK_BP/CMW - NPI EXTRACT REPORT ; 06 Sep 2007 3:34 PM + ;;8.0;KERNEL;**438,452,453**; Jul 10, 1995;Build 36 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; + ; NPI Extract Report + ; + ; Input parameter: N/A + ; + ; Other relevant variables: + ; XUSRTN="XUSNPIX2" (current routine name, used for ^XTMP and ^TMP + ; storage subscript) + ; Storage Global: + ; ^XTMP("XUSNPIX2",0) = Piece 1^Piece 2^Piece 3^Piece 4^Piece 5^Piece 6 + ; where: + ; Piece 1 => Purge Date - 1 year in future + ; Piece 2 => Create Date - Today + ; Piece 3 => Description + ; Piece 4 => Last Date Compiled + ; Piece 5 => $H last run start time + ; Piece 6 => $H last run completion time + ; + ; ^XTMP("XUSNPIX2",1) = STATION INFO + ; ^XTMP("XUSNPIX2",2) = DATA + ; + ; NPI => Unique NPI of entry + ; LDT => Last Date Run, VA Fileman Format + ; + ; Entry Point - ENT called from XUSNPIX1 + ; + Q + ; +ENT ; ENTRY POINT + ; Initialize variables + N XUSRTN + S XUSRTN="XUSNPIX2" + S DTTM2=$$HTE^XLFDT($H,"2") + ; Check to see if report is in use + L +^XTMP(XUSRTN):5 I '$T G EXIT + ; Process Institution File + D INIT(XUSRTN) + ; Pull Station(Institution) data + D STAT(XUSRTN) + ; Process Report + D PROC2(XUSRTN) + ; Send the message + D EMAIL(XUSRTN) + D VMAIL(XUSRTN) + S ^XTMP("XUSNPIXT",2)=MSGCNT_U_TOTREC_U_DTTM2 + ; + ; Standard EXIT point +EXIT ; + K ^TMP(XUSRTN,$J),^TMP($J,"XUS59"),^TMP("XUSNPIX",$J) + ; Log Run Completion Time + S $P(^XTMP(XUSRTN,0),U,6)=$H + L -^XTMP(XUSRTN) + K P,XUSPT,INST,XUSEOL,DTTM2,MAXSIZE,XUSIZE,MSGCNT,COUNT,TOTREC,XUSHDR,XUSTAXID + Q + ; + ; +INIT(XUSRTN) ; check/init variables + N XUSDESC + ; Set end of line character + S XUSEOL="~~" + ; Set to 300000 for live + S MAXSIZE=300000 + ; Reset Temporary Scratch Global + K ^TMP(XUSRTN) + S XUSDESC="NPI EXTRACT TYPE 2 - Do Not Delete" + S ^XTMP(XUSRTN,0)=(DT+10000)_U_DT_U_XUSDESC_U_DT_U_$H + ; + I '$D(^TMP("XUSNPIXU",$J)) D BCBSID^XUSNPIXU + ; + ; Create pharmacy institution ^TMP file + D GETPHARM + Q + ; +STAT(XUSRTN) ; Pull station and Institution info + N SINFO,DIC4,IBSITE,IBFAC,IB0 + ; Pull site info + S SINFO=$$SITE^VASITE + ; Station Number + S SITE=$P(SINFO,U,3) + ; Institution + S INST=$P(SINFO,U) + ; + ; Get Federal Tax Id + S XUSTAXID="" + S IBSITE=0 + F S IBSITE=$O(^IBE(350.9,IBSITE)) Q:'IBSITE!(XUSTAXID'="") D + . S XUSTAXID=$P($G(^IBE(350.9,IBSITE,1)),U,5) + ; + ; Get institution mailing address (PAY TO) + ;ST ADDR 1,ST ADDR 2,CITY,ZIP + I INST D + . S DIC4=$G(^DIC(4,INST,4)) + . S XUSPT(4)=$P(DIC4,U) + . S XUSPT(5)=$P(DIC4,U,2) + . S XUSPT(6)=$P(DIC4,U,3) + . S XUSPT(7)=$P(DIC4,U,4) + . I XUSPT(7) S XUSPT(7)=$P($G(^DIC(5,XUSPT(7),0)),U,2) + . S XUSPT(8)=$P(DIC4,U,5) + . S PTPMAIL=XUSPT(4)_U_XUSPT(5)_U_XUSPT(6)_U_XUSPT(7)_U_XUSPT(8) + S XUSHDR="Station: "_SITE_U_XUSPT(6)_U_XUSPT(7)_U_XUSPT(8)_U_"TYPE 2"_U_XUSVER + ; + Q + ; +PROC2(XUSRTN) ;Process all Institution records + N XUSNPI,XUSNEW,XUSDT,XUSI,XUSIN,XUSTXY,XUSSPC,XUSTAX,XUPHM + N XUSFCT,XUSFCN,XUSDATA1,XUSDATA2,XUSDATA3,XUSDATA4,XUSDATA5,XUSSTA + N INIEN,DIC0,DIC1,PSIEN,NPIINS,RELINS,PSSTA + ; set counter + S COUNT=1,(TOTREC,MSGCNT,XUSIZE)=0 + ; Loop through INSTITUTION NPI records NPI xref + S XUSNPI=0 + F S XUSNPI=$O(^DIC(4,"ANPI",XUSNPI)) Q:'XUSNPI D + . S INIEN=$O(^DIC(4,"ANPI",XUSNPI,"")) + . ; + . ; Get Station Number + . S XUSSTA=$P($G(^DIC(4,INIEN,99)),U) + . ; Parent of Association + . I (INIEN'=INST)&('$$POA(INIEN,INST)) Q + . ; Initialize columns + . F XUSI=1:1:24 S XUSIN(XUSI)="" + . ; + . S XUSIN(1)=XUSNPI + . S DIC0=$G(^DIC(4,INIEN,0)) Q:DIC0="" + . ;Organization Name + . S XUSIN(2)=$P($G(DIC0),U) + . S XUSIN(3)=2 + . S XUSDATA1=XUSIN(1)_U_XUSIN(2)_U_XUSIN(3) + . ; + . ; Pay to Provider Address + . S XUSDATA2=PTPMAIL + . ; + . ; Servicing Provider Address + . S DIC1=$G(^DIC(4,INIEN,1)) + . I DIC1'="" D + . . S XUSIN(9)=$P(DIC1,U) + . . S XUSIN(10)=$P(DIC1,U,2) + . . S XUSIN(11)=$P(DIC1,U,3) + . . S XUSIN(12)=$P($G(DIC0),U,2) + . . I XUSIN(12) S XUSIN(12)=$P($G(^DIC(5,XUSIN(12),0)),U,2) + . . S XUSIN(13)=$P(DIC1,U,4) + . S XUSDATA3=XUSIN(9)_U_XUSIN(10)_U_XUSIN(11)_U_XUSIN(12)_U_XUSIN(13) + . ; + . ;Phone number (place holder) + . S XUSIN(14)="" + . ; + . ; Get Taxonomy and Specialty + . S XUSTXY=0 + . F S XUSTXY=$O(^DIC(4,INIEN,"TAXONOMY","B",XUSTXY)) Q:'XUSTXY D + . . S XUSSPC=$P($G(^USC(8932.1,XUSTXY,0)),U,9) + . . S XUSTAX=$P($G(^USC(8932.1,XUSTXY,0)),U,7) + . . I XUSSPC'="" D + . . . I XUSIN(15)="" S XUSIN(15)=XUSSPC Q + . . . S XUSIN(15)=XUSIN(15)_";"_XUSSPC + . . I XUSTAX'="" D + . . . I XUSIN(16)="" S XUSIN(16)=XUSTAX Q + . . . S XUSIN(16)=XUSIN(16)_";"_XUSTAX + . ; + . ; Federal Tax ID + . S XUSIN(17)=$G(XUSTAXID) + . ; + . ; Medicaid Part A/B + . S XUSIN(18)=670899 + . S XUSIN(19)="VA"_$E(SITE+10000,2,5) + . ; + . S XUSDATA4=XUSIN(14)_U_XUSIN(15)_U_XUSIN(16)_U_XUSIN(17)_U_XUSIN(18)_U_XUSIN(19) + . ; + . ; DEA Number + . S XUSIN(20)=$P($G(^DIC(4,INIEN,"DEA")),U) + . ; + . ; get Facility Type and Name + . S XUSFCT=$P($G(^DIC(4,INIEN,3)),U) + . I XUSFCT'="" S XUSFCN=$P($G(^DIC(4.1,XUSFCT,0)),U) + . I $G(XUSFCN)="PHARM" D + . . I $D(^TMP("XUSNPIX",$J,INIEN)) D + . . . S XUPHM=^TMP("XUSNPIX",$J,INIEN) + . . . ; get NCPDP from ^TMP + . . . S XUSIN(21)=$P($G(XUPHM),U) + . . . ; get station number from^TMP + . . . I $P($G(XUPHM),U,2) S XUSSTA=$P(XUPHM,U,2) + . ; + . ; VISN Station Number + . S XUSIN(22)=XUSSTA + . ; + . S XUSDATA5=XUSIN(20)_U_XUSIN(21)_U_XUSIN(22) + . ; + . ; Get BCBS Payer ID Array + . K XUSBXID + . D INSTID^XUSNPIXU(.XUSBXID) + . ; + . ; Update counter and save Entry + . ; + . S COUNT=COUNT+1,TOTREC=TOTREC+1 + . S ^TMP(XUSRTN,$J,COUNT)=XUSDATA1_U_XUSDATA2_U_XUSDATA3_U_XUSDATA4_U_XUSDATA5_U_XUSEOL + . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,COUNT)) + . I $D(XUSBXID) D + . . S XUSB="" + . . F S XUSB=$O(XUSBXID(XUSB)) Q:XUSB="" D + . . . S COUNT=COUNT+1,TOTREC=TOTREC+1 + . . . S ^TMP(XUSRTN,$J,COUNT)=XUSDATA1_U_XUSDATA2_U_XUSDATA3_U_XUSDATA4_U_XUSDATA5_U_XUSB_U_XUSBXID(XUSB)_U_XUSEOL + . . . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,COUNT)) + . K XUSIN,XUSDATA1,XUSDATA2,XUSDATA3,XUSDATA4,XUSDATA5,XUSB,XUSBXID + . I XUSIZE>MAXSIZE D + . . D EOF(XUSRTN) + . . D EMAIL(XUSRTN) + . . D VMAIL(XUSRTN) + . . S ^TMP(XUSRTN,$J,1)=XUSHDR + . . S COUNT=1,XUSIZE=0 + ; + D EOF(XUSRTN) + K XUSPT,PTPMAIL,LDTCMP,SITE,XUSTAXID + Q + ; +EOF(XUSRTN) ; + S MSGCNT=MSGCNT+1 + S ^TMP(XUSRTN,$J,1)=XUSHDR_U_"Message Number: "_MSGCNT_U_"Line Count: "_COUNT_U_DTTM2_U_$G(XUSPROD)_U_XUSEOL + S COUNT=COUNT+1 + S ^TMP(XUSRTN,$J,COUNT)="END OF FILE"_U_XUSEOL + Q + ; + ; EMail the message +EMAIL(XUSRTN) ; + N XMY + ; Send email to designated recipient for live release + S XMY("XXX@Q-NPS.VA.GOV")="" + ;S XMY(DUZ)="" ;use for testing - remove before live + D ESEND + Q + ; +VMAIL(XUSRTN) ; verification email + N TMP + S TMP=^TMP(XUSRTN,$J,1) + K ^TMP(XUSRTN,$J) + S ^TMP(XUSRTN,$J,1)=$P(TMP,U,1,4) + S ^TMP(XUSRTN,$J,2)="" + S ^TMP(XUSRTN,$J,3)="TYPE 1 : INSTITUTION FILE (#4)" + S ^TMP(XUSRTN,$J,4)="" + S ^TMP(XUSRTN,$J,5)="Date/Time of Extract: "_$P(TMP,U,9) + S ^TMP(XUSRTN,$J,6)="" + S ^TMP(XUSRTN,$J,7)="Message number: "_MSGCNT_" Total NPI records: "_(COUNT-2) + S ^TMP(XUSRTN,$J,8)="" + S ^TMP(XUSRTN,$J,9)="Programmer Notes: "_XUSVER_" - "_$P(TMP,U,10) + ; Send verification email to local mail group and VA Outlook mail group + S XMY("G.NPI EXTRACT VERIFICATION")="" + D ESEND + K ^TMP(XUSRTN) + Q +ESEND N XMTEXT,XMSUB,XMDUN,XMDUZ,XMZ + ;Q + S XMTEXT="^TMP("""_XUSRTN_""","_$J_"," + S XMSUB=$TR($P($G(^TMP(XUSRTN,$J,1)),U),":")_"("_$G(XUSPROD)_") NPI EXTRACT TYPE 2" + D ^XMD + Q +POA(IEN,INST) ; Check Parent of Association for Institution IEN up to VISN level to see if INST is in the chain + N XUSPOA + I +$G(INST)=0 Q 0 ; No institution - return false +POA1 ; + I $G(IEN)="" Q 0 ; No IEN remaining to check - return false + I $D(XUSPOA(IEN)) Q 0 ; Already reviewed this IEN - possible infinite loop - return false + S XUSPOA(IEN)="" + S XUSPOA=$P($G(^DIC(4,IEN,7,2,0)),U,2) ; Get parent of this institution + I XUSPOA=INST Q 1 ; Found matching institution - return true + I IEN=XUSPOA Q 0 ; Top level reached - return false + S IEN=XUSPOA ; Reset IEN to check next level + G POA1 + ; +GETPHARM ; + ; this subroutine retrieves data from the OUTPATIENT SITE file + ; using the supported Pharmacy API PSS^PSO59. + ; It takes the results and places them into a temporary + ; global array that is accessed when processing data + ; associated with a pharmacy institution. + N XUS59DA,XUSNPIDA,XUSRELDA,PSSTA,Y,X,XUNCP + K ^TMP($J,"XUS59"),^TMP("XUSNPIX",$J) ; remove any pre-existing nodes + D PSS^PSO59(,"??","XUS59") + S XUS59DA=0 + ; gather data from each Outpatient site entry stored in the pharmacy + ; ^TMP global and build 2nd ^TMP global for later processing + F S XUS59DA=$O(^TMP($J,"XUS59",XUS59DA)) Q:'XUS59DA D + . ; + . ;Get Pharmacy NPI institution from API + . S XUSNPIDA=$P($G(^TMP($J,"XUS59",XUS59DA,101)),U) + . Q:XUSNPIDA']"" ; NPI institution does not exist + . ; + . ; Get Pharmacy Related Institution from API + . S XUSRELDA=$P($G(^TMP($J,"XUS59",XUS59DA,100)),U) + . ; get station number off the related institution + . S PSSTA=$P($G(^DIC(4,XUSRELDA,99)),U) + . ; + . ; Get NCPDP number + . S XUNCP="" ;prevent previous values being carried over + . S X=XUSNPIDA S D="C",DIC=9002313.56,DIC(0)="" D IX^DIC + . I +Y>0 S XUNCP=$$GET1^DIQ(9002313.56,+Y,.02) + . S:$G(XUNCP)="" XUNCP=$P($G(^TMP($J,"XUS59",XUS59DA,1008)),U) + . ; + . ; rebuild the ^TMP global by NPI institution + . ; collect necessary data used in the 'PHARM' logic + . S ^TMP("XUSNPIX",$J,XUSNPIDA)=XUNCP_"^"_PSSTA ; ncpdp#^station + Q diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIX3.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIX3.m index 98d4ae26..430aefae 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIX3.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIX3.m @@ -1,146 +1,166 @@ -XUSNPIX3 ;OAK_BP/CMW - NPI EXTRACT REPORT ;01-OCT-06 - ;;8.0;KERNEL;**438,452,453,481**; Jul 10, 1995;Build 21 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ; NPI Extract Report - ; - ; Input parameter: N/A - ; - ; Other relevant variables: - ; XUSRTN="XUSNPIX1NV" (current routine name, used for ^XTMP and ^TMP - ; XUSRTN="XUSNPIX2NV" storage subscript) - ; Storage Global: - ; ^XTMP("XUSNPIX1VA",0) = Piece 1^Piece 2^Piece 3^Piece 4^Piece 5^Piece 6 - ; ^XTMP("XUSNPIX2VA",0) - ; where: - ; Piece 1 => Purge Date - 1 year in future - ; Piece 2 => Create Date - Today - ; Piece 3 => Description - ; Piece 4 => Last Date Compiled - ; Piece 5 => $H last run start time - ; Piece 6 => $H last run completion time - ; - ; Entry Point - ENT called from XUSNPIX1 - ; - Q - ; -ENT(XUSPROD,XUSVER) ; ENTRY POINT - ; init variables - N XUSRTN,XUSEOL,DTTM3 - N XUSNPI,XUSDATA,XUSTYP,XUST - N NVIEN,IBA0,PROTYPE,NPIDT,NPINEW - K ^TMP("XUSNPI",$J) - ; - ; Set end of line character - S XUSEOL="~~" - ; - S DTTM3=$$HTE^XLFDT($H,"2") - ; - S XUST="" - ; Loop through IB NON/OTHER VA BILLING PROVIDER records NPI xref - S XUSNPI=0 - F S XUSNPI=$O(^IBA(355.93,"NPI",XUSNPI)) Q:'XUSNPI D - . S NVIEN=$O(^IBA(355.93,"NPI",XUSNPI,"")) - . S IBA0=$G(^IBA(355.93,NVIEN,0)) - . ; Get Provider Type - . S PROTYPE=$P(IBA0,U,2) - . S XUSTYP=$S(PROTYPE=1:2,1:1) - . ; setup NPI array - . S ^TMP("XUSNPI",$J,XUSTYP,XUSNPI)=NVIEN - . ; - ; If Provider Type is Individual - S XUSRTN="XUSNPIX1NV",NVHEADR=" NPI EXTRACT TYPE 1 (NON VA)",NVTYPE="TYPE 1 (NVA)" - I $D(^TMP("XUSNPI",$J,1)) D I XUST G EXIT - . ; Check to see if report is in use - . L +^XTMP(XUSRTN):5 I '$T S XUST=1 Q - . D INIT(XUSRTN) - . D INST(XUSRTN) - . D TYPE1^XUSNPIX4(DTTM3,PTPMAIL,SITE,XUSPROD,XUSHDR) - . ; - . ; Log Run Completion Time - . S $P(^XTMP(XUSRTN,0),U,6)=$H - . L -^XTMP(XUSRTN) - ; - I '$D(^TMP("XUSNPI",$J,1)) D - . D INIT(XUSRTN) - . D INST(XUSRTN) - . S ^TMP(XUSRTN,$J,1)=XUSHDR_U_"Message Number: "_1_U_"Line Count: "_1_U_DTTM3_U_$G(XUSPROD)_XUSEOL - . S ^XTMP("XUSNPIXT","1NV")=1_U_0_U_DTTM3 - . S ^TMP(XUSRTN,$J,2)="END OF FILE"_U_XUSEOL - . D EMAIL(XUSRTN) - . S ^TMP("XUSNPIXS",$J,3,1)="1 (Non-VA)^0" - ; - ; If Provider Type is Facility/Group - S XUSRTN="XUSNPIX2NV",NVHEADR=" NPI EXTRACT TYPE 2 (NON VA)",NVTYPE="TYPE 2 (NVA)" - I $D(^TMP("XUSNPI",$J,2)) D I XUST G EXIT - . ; Check to see if report is in use - . L +^XTMP(XUSRTN):5 I '$T S XUST=1 Q - . D INIT(XUSRTN) - . D INST(XUSRTN) - . D TYPE2^XUSNPIX4(DTTM3,PTPMAIL,SITE,XUSPROD,XUSHDR) - . ; - . ; Log Run Completion Time - . S $P(^XTMP(XUSRTN,0),U,6)=$H - . L -^XTMP(XUSRTN) - . ; - I '$D(^TMP("XUSNPI",$J,2)) D - . D INIT(XUSRTN) - . D INST(XUSRTN) - . S ^TMP(XUSRTN,$J,1)=XUSHDR_U_"Message Number: "_1_U_"Line Count: "_1_U_DTTM3_U_$G(XUSPROD)_XUSEOL - . S ^XTMP("XUSNPIXT","2NV")=1_U_0_U_DTTM3 - . S ^TMP(XUSRTN,$J,2)="END OF FILE"_U_XUSEOL - . D EMAIL(XUSRTN) - . S ^TMP("XUSNPIXS",$J,4,1)="2 (Non-VA)^0" - ; -EXIT ;Standard EXIT point - K ^TMP("XUSNPI",$J) - K XUSNV,P,LDTCMP,PTPMAIL,SITE,NVHEADR,NVTYPE,XUSEOL,DTTM3 - K XUSHDR - ; - Q - ; -INIT(XUSRTN) ; check/init variables - N XUSDESC - ; - ;Reset Temporary Scratch Global - K ^TMP(XUSRTN) - S XUSDESC="NPI EXTRACT NON VA - Do Not Delete" - S ^XTMP(XUSRTN,0)=(DT+10000)_U_DT_U_XUSDESC_U_DT_U_$H - ; - I '$D(^TMP("XUSNPIXU",$J)) D BCBSID^XUSNPIXU - Q - ; -INST(XUSRTN) ;Pull station and Institution info - N INST,SINFO,DIC4 - ; Pull site info - S SINFO=$$SITE^VASITE - ; Station Number - S SITE=$P(SINFO,U,3) - ; Institution - S INST=$P(SINFO,U) - ; - ; Get institution mailing address - I INST D - . S DIC4=$G(^DIC(4,INST,4)) - . S XUSNV(7)=$P(DIC4,U) - . S XUSNV(8)=$P(DIC4,U,2) - . S XUSNV(9)=$P(DIC4,U,3) - . S XUSNV(10)=$P(DIC4,U,4) - . I XUSNV(10) S XUSNV(10)=$P($G(^DIC(5,XUSNV(10),0)),U,2) - . S XUSNV(11)=$P(DIC4,U,5) - . S PTPMAIL=XUSNV(7)_U_XUSNV(8)_U_XUSNV(9)_U_XUSNV(10)_U_XUSNV(11) - S XUSHDR="Station: "_SITE_U_XUSNV(9)_U_XUSNV(10)_U_XUSNV(11)_U_NVTYPE_U_XUSVER - Q - ; -EMAIL(XUSRTN) ; EMAIL THE MESSAGE - N XMY - ; Send email to designated recipient for live release - S XMY("XXX@Q-NPS.VA.GOV")="" - D ESEND - Q - ; -ESEND N XMTEXT,XMSUB,XMDUN,XMDUZ,XMZ,XMMG,DIFROM - S XMTEXT="^TMP("""_XUSRTN_""","_$J_"," - S XMSUB=$TR($P($G(^TMP(XUSRTN,$J,1)),U),":")_"("_$G(XUSPROD)_") "_NVHEADR - D ^XMD - Q +XUSNPIX3 ;OAK_BP/CMW - NPI EXTRACT REPORT ;01-OCT-06 + ;;8.0;KERNEL;**438,452,453**; Jul 10, 1995;Build 36 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; + ; NPI Extract Report + ; + ; Input parameter: N/A + ; + ; Other relevant variables: + ; XUSRTN="XUSNPIX1NV" (current routine name, used for ^XTMP and ^TMP + ; XUSRTN="XUSNPIX2NV" storage subscript) + ; Storage Global: + ; ^XTMP("XUSNPIX1VA",0) = Piece 1^Piece 2^Piece 3^Piece 4^Piece 5^Piece 6 + ; ^XTMP("XUSNPIX2VA",0) + ; where: + ; Piece 1 => Purge Date - 1 year in future + ; Piece 2 => Create Date - Today + ; Piece 3 => Description + ; Piece 4 => Last Date Compiled + ; Piece 5 => $H last run start time + ; Piece 6 => $H last run completion time + ; + ; Entry Point - ENT called from XUSNPIX1 + ; + Q + ; +ENT ; ENTRY POINT + ; init variables + N XUSRTN + N XUSNPI,XUSDATA,XUSTYP,XUST + N NVIEN,IBA0,PROTYPE,NPIDT,NPINEW + K ^TMP("XUSNPI",$J) + S XUST="",XUSCNT=2,MSGCNT=0 + ; Loop through IB NON/OTHER VA BILLING PROVIDER records NPI xref + S XUSNPI=0 + F S XUSNPI=$O(^IBA(355.93,"NPI",XUSNPI)) Q:'XUSNPI D + . S NVIEN=$O(^IBA(355.93,"NPI",XUSNPI,"")) + . S IBA0=$G(^IBA(355.93,NVIEN,0)) + . ; Get Provider Type + . S PROTYPE=$P(IBA0,U,2) + . S XUSTYP=$S(PROTYPE=1:2,1:1) + . ; setup NPI array + . S ^TMP("XUSNPI",$J,XUSTYP,XUSNPI)=NVIEN + . ; + ; If Provider Type is Individual + S XUSRTN="XUSNPIX1NV",NVHEADR=" NPI EXTRACT TYPE 1 (NON VA)",NVTYPE="TYPE 1 (NVA)" + I $D(^TMP("XUSNPI",$J,1)) D I XUST G EXIT + . ; Check to see if report is in use + . L +^XTMP(XUSRTN):5 I '$T S XUST=1 Q + . D INIT(XUSRTN) + . D INST(XUSRTN) + . D TYPE1^XUSNPIX4 + . D EMAIL(XUSRTN) + . D VMAIL(XUSRTN) + . ; Log Run Completion Time + . S $P(^XTMP(XUSRTN,0),U,6)=$H + . L -^XTMP(XUSRTN) + ; + I '$D(^TMP("XUSNPI",$J,1)) D + . D INIT(XUSRTN) + . D INST(XUSRTN) + . S ^TMP(XUSRTN,$J,1)=XUSHDR_U_"Message Number: "_1_U_"Line Count: "_1_U_DTTM3_U_$G(XUSPROD)_XUSEOL + . S ^XTMP("XUSNPIXT","1NV")=1_U_0_U_DTTM3 + . S ^TMP(XUSRTN,$J,2)="END OF FILE"_U_XUSEOL + . D EMAIL(XUSRTN),VMAIL(XUSRTN) + ; + ; If Provider Type is Facility/Group + S XUSRTN="XUSNPIX2NV",NVHEADR=" NPI EXTRACT TYPE 2 (NON VA)",NVTYPE="TYPE 2 (NVA)" + I $D(^TMP("XUSNPI",$J,2)) D I XUST G EXIT + . ; Check to see if report is in use + . L +^XTMP(XUSRTN):5 I '$T S XUST=1 Q + . D INIT(XUSRTN) + . D INST(XUSRTN) + . D TYPE2^XUSNPIX4 + . D EMAIL(XUSRTN) + . D VMAIL(XUSRTN) + . ; Log Run Completion Time + . S $P(^XTMP(XUSRTN,0),U,6)=$H + . L -^XTMP(XUSRTN) + . ; + I '$D(^TMP("XUSNPI",$J,2)) D + . D INIT(XUSRTN) + . D INST(XUSRTN) + . S ^TMP(XUSRTN,$J,1)=XUSHDR_U_"Message Number: "_1_U_"Line Count: "_1_U_DTTM3_U_$G(XUSPROD)_XUSEOL + . S ^XTMP("XUSNPIXT","2NV")=1_U_0_U_DTTM3 + . S ^TMP(XUSRTN,$J,2)="END OF FILE"_U_XUSEOL + . D EMAIL(XUSRTN),VMAIL(XUSRTN) + ; +EXIT ;Standard EXIT point + K ^TMP("XUSNPI",$J) + K XUSNV,P,LDTCMP,PTPMAIL,SITE,NVHEADR,NVTYPE,XUSEOL,DTTM3 + K MAXSIZE,XUSHDR,XUSCNT,MSGCNT + ; + Q + ; +INIT(XUSRTN) ; check/init variables + N XUSDESC + ; Set end of line character + S XUSEOL="~~" + ; Set to 300000 for live + S MAXSIZE=300000 + S DTTM3=$$HTE^XLFDT($H,"2") + ; + ;Reset Temporary Scratch Global + K ^TMP(XUSRTN) + S XUSDESC="NPI EXTRACT NON VA - Do Not Delete" + S ^XTMP(XUSRTN,0)=(DT+10000)_U_DT_U_XUSDESC_U_DT_U_$H + ; + I '$D(^TMP("XUSNPIXU",$J)) D BCBSID^XUSNPIXU + Q + ; +INST(XUSRTN) ;Pull station and Institution info + N INST,SINFO,DIC4 + ; Pull site info + S SINFO=$$SITE^VASITE + ; Station Number + S SITE=$P(SINFO,U,3) + ; Institution + S INST=$P(SINFO,U) + ; + ; Get institution mailing address + I INST D + . S DIC4=$G(^DIC(4,INST,4)) + . S XUSNV(7)=$P(DIC4,U) + . S XUSNV(8)=$P(DIC4,U,2) + . S XUSNV(9)=$P(DIC4,U,3) + . S XUSNV(10)=$P(DIC4,U,4) + . I XUSNV(10) S XUSNV(10)=$P($G(^DIC(5,XUSNV(10),0)),U,2) + . S XUSNV(11)=$P(DIC4,U,5) + . S PTPMAIL=XUSNV(7)_U_XUSNV(8)_U_XUSNV(9)_U_XUSNV(10)_U_XUSNV(11) + S XUSHDR="Station: "_SITE_U_XUSNV(9)_U_XUSNV(10)_U_XUSNV(11)_U_NVTYPE_U_XUSVER + Q + ; +EMAIL(XUSRTN) ; EMAIL THE MESSAGE + N XMY + ; Send email to designated recipient for live release + S XMY("XXX@Q-NPS.VA.GOV")="" + ;S XMY(DUZ)="" ;use for testing - remove before live + D ESEND + Q + ; +VMAIL(XUSRTN) ; Verification email + N TMP + S TMP=^TMP(XUSRTN,$J,1) + K ^TMP(XUSRTN,$J) + S ^TMP(XUSRTN,$J,1)=$P(TMP,U,1,4) + S ^TMP(XUSRTN,$J,2)="" + S ^TMP(XUSRTN,$J,3)=NVHEADR_" (FILE #355.93)" + S ^TMP(XUSRTN,$J,4)="" + S ^TMP(XUSRTN,$J,5)="Date/Time of Extract: "_$P(TMP,U,9) + S ^TMP(XUSRTN,$J,6)="" + S ^TMP(XUSRTN,$J,7)="Message number: "_$S(MSGCNT>0:MSGCNT,1:1)_" Total NPI records: "_(XUSCNT-2) + S ^TMP(XUSRTN,$J,8)="" + S ^TMP(XUSRTN,$J,9)="Programmer Notes: "_XUSVER_" - "_$P(TMP,U,10) + ; + ; Send verification email to local mail group and VA Outlook mail group + S XMY("G.NPI EXTRACT VERIFICATION")="" + D ESEND + K ^TMP(XUSRTN) + Q + ; +ESEND N XMTEXT,XMSUB,XMDUN,XMDUZ,XMZ + S XMTEXT="^TMP("""_XUSRTN_""","_$J_"," + S XMSUB=$TR($P($G(^TMP(XUSRTN,$J,1)),U),":")_"("_$G(XUSPROD)_") "_NVHEADR + D ^XMD + Q diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIX4.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIX4.m index 9d611f7b..22ddc82b 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIX4.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIX4.m @@ -1,273 +1,236 @@ -XUSNPIX4 ;OAK_BP/CMW - NPI EXTRACT REPORT ;11:47 AM 28 Jul 2009 - ;;8.0;KERNEL;**438,452,453,481,WV**; Jul 10, 1995;Build 21 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ; NPI Extract Report - ; - ; Input parameter: N/A - ; - ; Other relevant variables: - ; XUSRTN="XUSNPIX1NV" (current routine name, used for ^XTMP and ^TMP - ; XUSRTN="XUSNPIX2NV" storage subscript) - ; Storage Global: - ; ^XTMP("XUSNPIX1VA",0) = Piece 1^Piece 2^Piece 3^Piece 4^Piece 5^Piece 6 - ; ^XTMP("XUSNPIX2VA",0) - ; where: - ; Piece 1 => Purge Date - 1 year in future - ; Piece 2 => Create Date - Today - ; Piece 3 => Description - ; Piece 4 => Last Date Compiled - ; Piece 5 => $H last run start time - ; Piece 6 => $H last run completion time - ; - ; Entry Point - ENT called from XUSNPIX1 - ; - Q - ; - ; Individual records -TYPE1(DTTM3,PTPMAIL,SITE,XUSPROD,XUSHDR) ; - N IBA0,NVIEN,XUSNPI,MAXSIZE,XUSEOL,XUSCNT - N XUSI,XUSNM,XUSNV,XLFNC,XUSIZE,XUSDT,XUSNEW - N TOTREC1 - ; - ; Set Maximum Message Size - S MAXSIZE=300000 - ; - ; Set end of line character - S XUSEOL="~~" - ; - S XUSCNT=1,(TOTREC1,MSGCNT,XUSIZE)=0 - S XUSNPI="" - F S XUSNPI=$O(^TMP("XUSNPI",$J,1,XUSNPI)) Q:'XUSNPI D - . S XUSDATA=XUSNPI - . S NVIEN=$G(^TMP("XUSNPI",$J,1,XUSNPI)) - . ; - . F XUSI=1:1:29 S XUSNV(XUSI)="" - . S IBA0=$G(^IBA(355.93,NVIEN,0)) - . S XUSNM=$P(IBA0,U) - . ; Break Name into components - . I XUSNM'="" D - . . ;Begin WorldVistA Change; 07/28/2009 - . . ;S XLFNC=XUSNM D FORMAT^XLFNAME7(.XLFNC,,,,0) - . . S XLFNC=XUSNM S XLFNC=$$FORMAT^XLFNAME7(.XLFNC,,,,0) - . . ;End WorldVistA change - . . S XUSNV(2)=XLFNC("GIVEN"),XUSNV(3)=XLFNC("MIDDLE"),XUSNV(4)=XLFNC("FAMILY") - . . I XLFNC("SUFFIX")'="" S XUSNV(4)=XUSNV(4)_" "_XLFNC("SUFFIX") - . . K XLFNC - . S XUSDATA=XUSDATA_U_XUSNV(2)_U_XUSNV(3)_U_XUSNV(4) - . S XUSNV(5)=1 ;TYPE - . ; - . ; DOB (place holder) - . S XUSNV(6)="" - . S XUSDATA=XUSDATA_U_XUSNV(5)_U_XUSNV(6) - . ; - . ; Pay to Provider Address (7-11) - . S XUSDATA=XUSDATA_U_PTPMAIL - . ; - . ; Servicing Provider Address - . S XUSNV(12)=$P(IBA0,U,5) - . S XUSNV(13)=$P(IBA0,U,10) - . S XUSNV(14)=$P(IBA0,U,6) - . S XUSNV(15)=$P(IBA0,U,7) - . I XUSNV(15) S XUSNV(15)=$P($G(^DIC(5,XUSNV(12),0)),U,2) - . S XUSNV(16)=$P(IBA0,U,8) - . S XUSDATA=XUSDATA_U_XUSNV(12)_U_XUSNV(13)_U_XUSNV(14)_U_XUSNV(15)_U_XUSNV(16) - . ; - . ; Office Phone number (place holder) - . S XUSNV(17)="" - . ; - . ; Degree Description / Degree Code (place holder) - . S XUSNV(18)="" - . S XUSNV(19)="" - . ; - . ; Get Taxonomy and specialty codes - . N NVTX,NVSPC,NVTAX - . S NVTX=0 - . F S NVTX=$O(^IBA(355.93,NVIEN,"TAXONOMY","B",NVTX)) Q:'NVTX D - . . S NVSPC=$P($G(^USC(8932.1,NVTX,0)),U,9) - . . S NVTAX=$P($G(^USC(8932.1,NVTX,0)),U,7) - . . I NVSPC'="" D - . . . I XUSNV(20)="" S XUSNV(20)=NVSPC Q - . . . S XUSNV(20)=XUSNV(20)_";"_NVSPC - . . I NVTAX'="" D - . . . I XUSNV(21)="" S XUSNV(21)=NVTAX Q - . . . S XUSNV(21)=XUSNV(21)_";"_NVTAX - . ; - . ; Fed tax ID - . S XUSNV(22)=$P($G(IBA0),U,9) - . ; - . S XUSDATA=XUSDATA_U_XUSNV(17)_U_XUSNV(18)_U_XUSNV(19)_U_XUSNV(20)_U_XUSNV(21)_U_XUSNV(22) - . ; - . ; Medicare Part A/B - . S XUSNV(23)=670899 - . S XUSNV(24)="VA"_$E(SITE+10000,2,5) - . ; - . ; State Lic and DEA (place holder) - . S XUSNV(25)="" - . S XUSNV(26)="" - . ; - . ; VISN Station - . S XUSNV(27)=SITE - . ; - . S XUSDATA=XUSDATA_U_XUSNV(23)_U_XUSNV(24)_U_XUSNV(25)_U_XUSNV(26)_U_XUSNV(27) - . ; - . ;BCBS info - . K XUSBXID - . D NNVAID^XUSNPIXU(NVIEN,.XUSBXID) - . ; - . ;Update counter and save Entry - . N XUSB - . S XUSCNT=XUSCNT+1,TOTREC1=TOTREC1+1 - . S ^TMP(XUSRTN,$J,XUSCNT)=XUSDATA_U_XUSEOL - . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,XUSCNT)) - . I $D(XUSBXID) D - . . S XUSB="" - . . F S XUSB=$O(XUSBXID(XUSB)) Q:XUSB="" D - . . . S XUSCNT=XUSCNT+1,TOTREC1=TOTREC1+1 - . . . S ^TMP(XUSRTN,$J,XUSCNT)=XUSDATA_U_XUSB_U_XUSEOL - . . . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,XUSCNT)) - . I XUSIZE>MAXSIZE D - . . D EOF1(XUSRTN) - . . D EMAIL^XUSNPIX3(XUSRTN) - . . K ^TMP(XUSRTN,$J) - . . S ^TMP("XUSNPIXS",$J,3,MSGCNT)="1 (Non-VA)^"_(XUSCNT-2) - . . S ^TMP(XUSRTN,$J,1)=XUSHDR - . . S XUSCNT=1,XUSIZE=0 - . K XUSNV,XUSDATA,XUSBXID - ; - D EOF1(XUSRTN) - ; - ; Send last message (if it has records) - I $G(XUSCNT)>1 D - . D EMAIL^XUSNPIX3(XUSRTN) - . K ^TMP(XUSRTN,$J) - . S ^TMP("XUSNPIXS",$J,3,MSGCNT)="1 (Non-VA)^"_($G(XUSCNT)-2) - ; - ; Update Summary - S ^XTMP("XUSNPIXT","1NV")=MSGCNT_U_TOTREC1_U_DTTM3 - Q - ; -EOF1(XUSRTN) ; - Q:$G(XUSCNT)=1 - S MSGCNT=MSGCNT+1 - S ^TMP(XUSRTN,$J,1)=XUSHDR_U_"Message Number: "_MSGCNT_U_"Line Count: "_XUSCNT_U_DTTM3_U_$G(XUSPROD)_U_XUSEOL - S XUSCNT=XUSCNT+1 - S ^TMP(XUSRTN,$J,XUSCNT)="END OF FILE"_U_XUSEOL - Q - ; -TYPE2(DTTM3,PTPMAIL,SITE,XUSPROD,XUSHDR) ;Facility/Group - N IBA0,NVIEN,XUSNPI,MAXSIZE,XUSEOL,XUSCNT - N XUSNV,XUSI,XUSNM,XLFNC,MSGCNT,XUSIZE,XUSDT,XUSNEW,TOTREC2 - ; - ; Set Maximum Message Size - S MAXSIZE=300000 - ; - ; Set end of line character - S XUSEOL="~~" - ; - S XUSNPI="" - S XUSCNT=1,(TOTREC2,MSGCNT,XUSIZE)=0 - F S XUSNPI=$O(^TMP("XUSNPI",$J,2,XUSNPI)) Q:'XUSNPI D - . S XUSDATA=XUSNPI - . S NVIEN=$G(^TMP("XUSNPI",$J,2,XUSNPI)) - . ; - . F XUSI=1:1:24 S XUSNV(XUSI)="" - . S IBA0=$G(^IBA(355.93,NVIEN,0)) - . ;Get Organization name - . S XUSNV(2)=$P(IBA0,U) - . ;Type - . S XUSNV(3)=2 - . ; - . S XUSDATA=XUSDATA_U_XUSNV(2)_U_XUSNV(3) - . ; - . ; Pay to Provider Address (4-8) - . S XUSDATA=XUSDATA_U_PTPMAIL - . ; - . ; Servicing Provider Address - . S XUSNV(9)=$P(IBA0,U,5) - . S XUSNV(10)=$P(IBA0,U,10) - . S XUSNV(11)=$P(IBA0,U,6) - . S XUSNV(12)=$P(IBA0,U,7) - . I XUSNV(12) S XUSNV(12)=$P($G(^DIC(5,XUSNV(12),0)),U,2) - . S XUSNV(13)=$P(IBA0,U,8) - . S XUSDATA=XUSDATA_U_XUSNV(9)_U_XUSNV(10)_U_XUSNV(11)_U_XUSNV(12)_U_XUSNV(13) - . ; - . ;Office Phone number (place holder) - . S XUSNV(14)="" - . ; - . ; get Taxonomy and Specialty - . N NVTX,NVSPC,NVTAX - . S NVTX=0 - . F S NVTX=$O(^IBA(355.93,NVIEN,"TAXONOMY","B",NVTX)) Q:'NVTX D - . . S NVSPC=$P($G(^USC(8932.1,NVTX,0)),U,9) - . . S NVTAX=$P($G(^USC(8932.1,NVTX,0)),U,7) - . . I NVSPC'="" D - . . . I XUSNV(15)="" S XUSNV(15)=NVSPC Q - . . . S XUSNV(15)=XUSNV(15)_";"_NVSPC - . . I NVTAX'="" D - . . . I XUSNV(16)="" S XUSNV(16)=NVTAX Q - . . . S XUSNV(16)=XUSNV(16)_";"_NVTAX - . ; - . ; Fed Tax ID - . S XUSNV(17)=$P($G(IBA0),U,9) - . ; - . ;Medicare A/B - . S XUSNV(18)=670899 - . S XUSNV(19)="VA"_$E(SITE+10000,2,5) - . ; - . S XUSDATA=XUSDATA_U_XUSNV(14)_U_XUSNV(15)_U_XUSNV(16)_U_XUSNV(17)_U_XUSNV(18)_U_XUSNV(19) - . ; - . ;State License Number - . S XUSNV(20)=$P($G(IBA0),U,12) - . ; - . ;DEA Number (place holder) - . S XUSNV(21)="" - . ; - . ;VISN STATION ID - . S XUSNV(22)=SITE - . ; - . S XUSDATA=XUSDATA_U_XUSNV(20)_U_XUSNV(21)_U_XUSNV(22) - . ; - . ;BCBS info - . K XUSBXID - . D NNVAID^XUSNPIXU(NVIEN,.XUSBXID) - . ; - . ;Update counter and save Entry - . N XUSB - . S XUSCNT=XUSCNT+1,TOTREC2=TOTREC2+1 - . S ^TMP(XUSRTN,$J,XUSCNT)=XUSDATA_U_XUSEOL - . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,XUSCNT)) - . I $D(XUSBXID) D - . . S XUSB="" - . . F S XUSB=$O(XUSBXID(XUSB)) Q:XUSB="" D - . . . S XUSCNT=XUSCNT+1,TOTREC2=TOTREC2+1 - . . . S ^TMP(XUSRTN,$J,XUSCNT)=XUSDATA_U_XUSB_U_XUSEOL - . . . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,XUSCNT)) - . I XUSIZE>MAXSIZE D - . . D EOF2(XUSRTN) - . . D EMAIL^XUSNPIX3(XUSRTN) - . . K ^TMP(XUSRTN,$J) - . . S ^TMP("XUSNPIXS",$J,4,MSGCNT)="2 (Non-VA)^"_(XUSCNT-2) - . . S ^TMP(XUSRTN,$J,1)=XUSHDR - . . S XUSCNT=1,XUSIZE=0 - . K XUSNV,XUSDATA,XUSB,XUSBXID - ; - D EOF2(XUSRTN) - ; - ; Send last message (if it has records) - I $G(XUSCNT)>1 D - . D EMAIL^XUSNPIX3(XUSRTN) - . K ^TMP(XUSRTN,$J) - . S ^TMP("XUSNPIXS",$J,4,MSGCNT)="2 (Non-VA)^"_($G(XUSCNT)-2) - ; - ; Update Summary - S ^XTMP("XUSNPIXT","2NV")=MSGCNT_U_TOTREC2_U_DTTM3 - Q - ; -EOF2(XUSRTN) ; - Q:$G(XUSCNT)=1 - S MSGCNT=MSGCNT+1 - S ^TMP(XUSRTN,$J,1)=XUSHDR_U_"Message Number: "_MSGCNT_U_"Line Count: "_XUSCNT_U_DTTM3_U_$G(XUSPROD)_U_XUSEOL - S XUSCNT=XUSCNT+1 - S ^TMP(XUSRTN,$J,XUSCNT)="END OF FILE"_U_XUSEOL - Q +XUSNPIX4 ;OAK_BP/CMW - NPI EXTRACT REPORT ;01-OCT-06 + ;;8.0;KERNEL;**438,452,453**; Jul 10, 1995;Build 36 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; + ; NPI Extract Report + ; + ; Input parameter: N/A + ; + ; Other relevant variables: + ; XUSRTN="XUSNPIX1NV" (current routine name, used for ^XTMP and ^TMP + ; XUSRTN="XUSNPIX2NV" storage subscript) + ; Storage Global: + ; ^XTMP("XUSNPIX1VA",0) = Piece 1^Piece 2^Piece 3^Piece 4^Piece 5^Piece 6 + ; ^XTMP("XUSNPIX2VA",0) + ; where: + ; Piece 1 => Purge Date - 1 year in future + ; Piece 2 => Create Date - Today + ; Piece 3 => Description + ; Piece 4 => Last Date Compiled + ; Piece 5 => $H last run start time + ; Piece 6 => $H last run completion time + ; + ; Entry Point - ENT called from XUSNPIX1 + ; + Q + ; + ; Individual records +TYPE1 ; + N IBA0,NVIEN,XUSNPI + N XUSI,XUSNM,XUSNV,XLFNC,XUSIZE,XUSDT,XUSNEW + N TOTREC1,TOTREC2 + S XUSCNT=1,(TOTREC1,MSGCNT,XUSIZE)=0 + S XUSNPI="" + F S XUSNPI=$O(^TMP("XUSNPI",$J,1,XUSNPI)) Q:'XUSNPI D + . S XUSDATA=XUSNPI + . S NVIEN=$G(^TMP("XUSNPI",$J,1,XUSNPI)) + . ; + . F XUSI=1:1:29 S XUSNV(XUSI)="" + . S IBA0=$G(^IBA(355.93,NVIEN,0)) + . S XUSNM=$P(IBA0,U) + . ; Break Name into components + . I XUSNM'="" D + . . S XLFNC=XUSNM D FORMAT^XLFNAME7(.XLFNC,,,,0) + . . S XUSNV(2)=XLFNC("GIVEN"),XUSNV(3)=XLFNC("MIDDLE"),XUSNV(4)=XLFNC("FAMILY") + . . I XLFNC("SUFFIX")'="" S XUSNV(4)=XUSNV(4)_" "_XLFNC("SUFFIX") + . . K XLFNC + . S XUSDATA=XUSDATA_U_XUSNV(2)_U_XUSNV(3)_U_XUSNV(4) + . S XUSNV(5)=1 ;TYPE + . ; + . ; DOB (place holder) + . S XUSNV(6)="" + . S XUSDATA=XUSDATA_U_XUSNV(5)_U_XUSNV(6) + . ; + . ; Pay to Provider Address (7-11) + . S XUSDATA=XUSDATA_U_PTPMAIL + . ; + . ; Servicing Provider Address + . S XUSNV(12)=$P(IBA0,U,5) + . S XUSNV(13)=$P(IBA0,U,10) + . S XUSNV(14)=$P(IBA0,U,6) + . S XUSNV(15)=$P(IBA0,U,7) + . I XUSNV(15) S XUSNV(15)=$P($G(^DIC(5,XUSNV(12),0)),U,2) + . S XUSNV(16)=$P(IBA0,U,8) + . S XUSDATA=XUSDATA_U_XUSNV(12)_U_XUSNV(13)_U_XUSNV(14)_U_XUSNV(15)_U_XUSNV(16) + . ; + . ; Office Phone number (place holder) + . S XUSNV(17)="" + . ; + . ; Degree Description / Degree Code (place holder) + . S XUSNV(18)="" + . S XUSNV(19)="" + . ; + . ; Get Taxonomy and specialty codes + . N NVTX,NVSPC,NVTAX + . S NVTX=0 + . F S NVTX=$O(^IBA(355.93,NVIEN,"TAXONOMY","B",NVTX)) Q:'NVTX D + . . S NVSPC=$P($G(^USC(8932.1,NVTX,0)),U,9) + . . S NVTAX=$P($G(^USC(8932.1,NVTX,0)),U,7) + . . I NVSPC'="" D + . . . I XUSNV(20)="" S XUSNV(20)=NVSPC Q + . . . S XUSNV(20)=XUSNV(20)_";"_NVSPC + . . I NVTAX'="" D + . . . I XUSNV(21)="" S XUSNV(21)=NVTAX Q + . . . S XUSNV(21)=XUSNV(21)_";"_NVTAX + . ; + . ; Fed tax ID + . S XUSNV(22)=$P($G(IBA0),U,9) + . ; + . S XUSDATA=XUSDATA_U_XUSNV(17)_U_XUSNV(18)_U_XUSNV(19)_U_XUSNV(20)_U_XUSNV(21)_U_XUSNV(22) + . ; + . ; Medicare Part A/B + . S XUSNV(23)=670899 + . S XUSNV(24)="VA"_$E(SITE+10000,2,5) + . ; + . ; State Lic and DEA (place holder) + . S XUSNV(25)="" + . S XUSNV(26)="" + . ; + . ; VISN Station + . S XUSNV(27)=SITE + . ; + . S XUSDATA=XUSDATA_U_XUSNV(23)_U_XUSNV(24)_U_XUSNV(25)_U_XUSNV(26)_U_XUSNV(27) + . ; + . ;BCBS info + . K XUSBXID + . D NNVAID^XUSNPIXU(NVIEN,.XUSBXID) + . ; + . ;Update counter and save Entry + . N XUSB + . S XUSCNT=XUSCNT+1,TOTREC1=TOTREC1+1 + . S ^TMP(XUSRTN,$J,XUSCNT)=XUSDATA_U_XUSEOL + . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,XUSCNT)) + . I $D(XUSBXID) D + . . S XUSB="" + . . F S XUSB=$O(XUSBXID(XUSB)) Q:XUSB="" D + . . . S XUSCNT=XUSCNT+1,TOTREC1=TOTREC1+1 + . . . S ^TMP(XUSRTN,$J,XUSCNT)=XUSDATA_U_XUSB_U_XUSEOL + . . . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,XUSCNT)) + . I XUSIZE>MAXSIZE D + . . D EOF1(XUSRTN) + . . D EMAIL^XUSNPIX3(XUSRTN) + . . D VMAIL^XUSNPIX3(XUSRTN) + . . S ^TMP(XUSRTN,$J,1)=XUSHDR + . . S XUSCNT=1,XUSIZE=0 + . K XUSNV,XUSDATA,XUSBXID + ; + D EOF1(XUSRTN) + S ^XTMP("XUSNPIXT","1NV")=MSGCNT_U_TOTREC1_U_DTTM3 + Q + ; +EOF1(XUSRTN) ; + S MSGCNT=MSGCNT+1 + S ^TMP(XUSRTN,$J,1)=XUSHDR_U_"Message Number: "_MSGCNT_U_"Line Count: "_XUSCNT_U_DTTM3_U_$G(XUSPROD)_U_XUSEOL + S XUSCNT=XUSCNT+1 + S ^TMP(XUSRTN,$J,XUSCNT)="END OF FILE"_U_XUSEOL + Q + ; +TYPE2 ;Facility/Group + N IBA0,NVIEN,XUSNPI + N XUSNV,XUSI,XUSNM,XLFNC,MSGCNT,XUSIZE,XUSDT,XUSNEW + S XUSNPI="" + S XUSCNT=1,(TOTREC2,MSGCNT,XUSIZE)=0 + F S XUSNPI=$O(^TMP("XUSNPI",$J,2,XUSNPI)) Q:'XUSNPI D + . S XUSDATA=XUSNPI + . S NVIEN=$G(^TMP("XUSNPI",$J,2,XUSNPI)) + . ; + . F XUSI=1:1:24 S XUSNV(XUSI)="" + . S IBA0=$G(^IBA(355.93,NVIEN,0)) + . ;Get Organization name + . S XUSNV(2)=$P(IBA0,U) + . ;Type + . S XUSNV(3)=2 + . ; + . S XUSDATA=XUSDATA_U_XUSNV(2)_U_XUSNV(3) + . ; + . ; Pay to Provider Address (4-8) + . S XUSDATA=XUSDATA_U_PTPMAIL + . ; + . ; Servicing Provider Address + . S XUSNV(9)=$P(IBA0,U,5) + . S XUSNV(10)=$P(IBA0,U,10) + . S XUSNV(11)=$P(IBA0,U,6) + . S XUSNV(12)=$P(IBA0,U,7) + . I XUSNV(12) S XUSNV(12)=$P($G(^DIC(5,XUSNV(12),0)),U,2) + . S XUSNV(13)=$P(IBA0,U,8) + . S XUSDATA=XUSDATA_U_XUSNV(9)_U_XUSNV(10)_U_XUSNV(11)_U_XUSNV(12)_U_XUSNV(13) + . ; + . ;Office Phone number (place holder) + . S XUSNV(14)="" + . ; + . ; get Taxonomy and Specialty + . N NVTX,NVSPC,NVTAX + . S NVTX=0 + . F S NVTX=$O(^IBA(355.93,NVIEN,"TAXONOMY","B",NVTX)) Q:'NVTX D + . . S NVSPC=$P($G(^USC(8932.1,NVTX,0)),U,9) + . . S NVTAX=$P($G(^USC(8932.1,NVTX,0)),U,7) + . . I NVSPC'="" D + . . . I XUSNV(15)="" S XUSNV(15)=NVSPC Q + . . . S XUSNV(15)=XUSNV(15)_";"_NVSPC + . . I NVTAX'="" D + . . . I XUSNV(16)="" S XUSNV(16)=NVTAX Q + . . . S XUSNV(16)=XUSNV(16)_";"_NVTAX + . ; + . ; Fed Tax ID + . S XUSNV(17)=$P($G(IBA0),U,9) + . ; + . ;Medicare A/B + . S XUSNV(18)=670899 + . S XUSNV(19)="VA"_$E(SITE+10000,2,5) + . ; + . S XUSDATA=XUSDATA_U_XUSNV(14)_U_XUSNV(15)_U_XUSNV(16)_U_XUSNV(17)_U_XUSNV(18)_U_XUSNV(19) + . ; + . ;State License Number + . S XUSNV(20)=$P($G(IBA0),U,12) + . ; + . ;DEA Number (place holder) + . S XUSNV(21)="" + . ; + . ;VISN STATION ID + . S XUSNV(22)=SITE + . ; + . S XUSDATA=XUSDATA_U_XUSNV(20)_U_XUSNV(21)_U_XUSNV(22) + . ; + . ;BCBS info + . K XUSBXID + . D NNVAID^XUSNPIXU(NVIEN,.XUSBXID) + . ; + . ;Update counter and save Entry + . N XUSB + . S XUSCNT=XUSCNT+1,TOTREC2=TOTREC2+1 + . S ^TMP(XUSRTN,$J,XUSCNT)=XUSDATA_U_XUSEOL + . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,XUSCNT)) + . I $D(XUSBXID) D + . . S XUSB="" + . . F S XUSB=$O(XUSBXID(XUSB)) Q:XUSB="" D + . . . S XUSCNT=XUSCNT+1,TOTREC2=TOTREC2+1 + . . . S ^TMP(XUSRTN,$J,XUSCNT)=XUSDATA_U_XUSB_U_XUSEOL + . . . S XUSIZE=XUSIZE+$L(^TMP(XUSRTN,$J,XUSCNT)) + . I XUSIZE>MAXSIZE D + . . D EOF2(XUSRTN) + . . D EMAIL^XUSNPIX3(XUSRTN) + . . D VMAIL^XUSNPIX3(XUSRTN) + . . S ^TMP(XUSRTN,$J,1)=XUSHDR + . . S XUSCNT=1,XUSIZE=0 + . K XUSNV,XUSDATA,XUSB,XUSBXID + ; + D EOF2(XUSRTN) + S ^XTMP("XUSNPIXT","2NV")=MSGCNT_U_TOTREC2_U_DTTM3 + Q + ; +EOF2(XUSRTN) ; + S MSGCNT=MSGCNT+1 + S ^TMP(XUSRTN,$J,1)=XUSHDR_U_"Message Number: "_MSGCNT_U_"Line Count: "_XUSCNT_U_DTTM3_U_$G(XUSPROD)_U_XUSEOL + S XUSCNT=XUSCNT+1 + S ^TMP(XUSRTN,$J,XUSCNT)="END OF FILE"_U_XUSEOL + Q diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIX5.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIX5.m index 1c148cb8..f1415d1c 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIX5.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSNPIX5.m @@ -1,96 +1,100 @@ -XUSNPIX5 ;OAK_BP/CMW - NPI EXTRACT REPORT ;7/7/08 17:45 - ;;8.0;KERNEL;**453,481**; Jul 10, 1995;Build 21 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ; NPI Extract Report Mailer routine - ; - ; Input parameter: XUSRTN - ; - ; Other relevant variables: - ; XUSRTN="XUSNPIX1" (current routine name, used for ^XTMP and ^TMP - ; storage subscript) - ; Storage Global: - ; ^XTMP("XUSNPIX1",0) = Piece 1^Piece 2^Piece 3^Piece 4^Piece 5^Piece 6 - ; where: - ; Piece 1 => Purge Date - 1 year in future - ; Piece 2 => Create Date - Today - ; Piece 3 => Description - ; Piece 4 => Last Date Compiled - ; Piece 5 => $H last run start time - ; Piece 6 => $H last run completion time - ; - ; ^XTMP("XUSNPIX1",1) = DATA - ; - ; XUSNPI => Unique NPI of entry - ; LDT => Last Date Run, VA Fileman Format - ; - Q - ; -EMAIL(XUSRTN) ; EMAIL THE MESSAGE - ; Add domain name if it does not exist - N XUSFOC,DLAYGO,DA,DIC,DIE,DR,X,Y - I '$$FIND1^DIC(4.2,,"QX","Q-NPS.VA.GOV","B") D - . S XUSFOC=$O(^DIC(4.2,"B","FOC-AUSTIN.VA.GOV",0)) I 'XUSFOC Q - . I XUSFOC=$O(^DIC(4.2,"B","FOC-AUSTIN.VA.GOV",""),-1) D - . . S DIC="^DIC(4.2,",X="Q-NPS.VA.GOV",DIC(0)="L",DLAYGO=4.2 D ^DIC K DLAYGO - . . S DIE=DIC,DA=+Y - . . S DR="1///NS;2///^S X=XUSFOC;1.7///YES;6.2///NPS;" - . . D ^DIE - ; - N XMY - ; Send email to designated recipient for live release - S XMY("XXX@Q-NPS.VA.GOV")="" - D ESEND - Q - ; -SMAIL(XUSRTN,XUSPROD,XUSVER,DTTM) ; Summary email - N HYPHEN,L,M,N,T,TMP,T1,T2,T1NV,T2NV,XMY - K ^TMP(XUSRTN,$J) - S T1=$G(^XTMP(XUSRTN,1)) - S T2=$G(^XTMP(XUSRTN,2)) - S T1NV=$G(^XTMP(XUSRTN,"1NV")) - S T2NV=$G(^XTMP(XUSRTN,"2NV")) - S ^TMP(XUSRTN,$J,1)="SUMMARY" - S ^TMP(XUSRTN,$J,2)="-------" - S ^TMP(XUSRTN,$J,3)=^XTMP(XUSRTN,"H")_" "_DTTM - S ^TMP(XUSRTN,$J,4)="" - S ^TMP(XUSRTN,$J,5)="Type 1 NEW PERSON FILE (#200) "_$J(+$P(T1,U),3)_" Message(s) Totaling "_$J(+$P(T1,U,2),7)_" NPI records." - S ^TMP(XUSRTN,$J,6)="Type 2 INSITUTION FILE (#4) "_$J(+$P(T2,U),3)_" Message(s) Totaling "_$J(+$P(T2,U,2),7)_" NPI records." - S ^TMP(XUSRTN,$J,7)="Type 1 NON VA Individual (#355.93) "_$J(+$P(T1NV,U),3)_" Message(s) Totaling "_$J(+$P(T1NV,U,2),7)_" NPI records." - S ^TMP(XUSRTN,$J,8)="Type 2 NON VA Facility/Group (#355.93) "_$J(+$P(T2NV,U),3)_" Message(s) Totaling "_$J(+$P(T2NV,U,2),7)_" NPI records." - S ^TMP(XUSRTN,$J,9)="" - S ^TMP(XUSRTN,$J,10)="Programmer Notes: "_XUSVER_" - "_$G(XUSPROD) - ; - ;Summary Detail - ; - S HYPHEN="",$P(HYPHEN,"-",84)="-" - ; - S ^TMP(XUSRTN,$J,11)="" - S ^TMP(XUSRTN,$J,12)=HYPHEN - S ^TMP(XUSRTN,$J,13)="" - S ^TMP(XUSRTN,$J,14)="MESSAGE DETAILS" - S ^TMP(XUSRTN,$J,15)="---------------" - S ^TMP(XUSRTN,$J,16)="" - S ^TMP(XUSRTN,$J,17)="TYPE "_$J("MESSAGE NUMBER",20)_$J("RECORD COUNT",20) - S ^TMP(XUSRTN,$J,18)="----------"_$J("--------------",20)_$J("------------",20) - ; - S L=18,T="" F S T=$O(^TMP("XUSNPIXS",$J,T)) Q:'T S M=0 F S M=$O(^TMP("XUSNPIXS",$J,T,M)) Q:'M D - .S N=$G(^TMP("XUSNPIXS",$J,T,M)) - .S L=L+1 - .S ^TMP(XUSRTN,$J,L)=$E($P(N,U)_" ",1,10)_$J(M,16)_$J($P(N,U,2),24) - S L=L+1,^TMP(XUSRTN,$J,L)="" - S L=L+1,^TMP(XUSRTN,$J,L)=HYPHEN - ; Send verification email to local mail group and VA Outlook mail group - S XMY("G.NPI EXTRACT VERIFICATION")="" - N XMTEXT,XMSUB,XMDUN,XMDUZ,XMZ,XMMG,DIFROM - S XMTEXT="^TMP("""_XUSRTN_""","_$J_"," - S XMSUB=$TR($P(^XTMP(XUSRTN,"H"),U),":")_"("_$G(XUSPROD)_") NPI CROSSWALK EXTRACT SUMMARY " - D ^XMD - K ^TMP(XUSRTN,$J) - Q - ; -ESEND N XMTEXT,XMSUB,XMDUN,XMDUZ,XMZ,XMMG,DIFROM - S XMTEXT="^TMP("""_XUSRTN_""","_$J_"," - S XMSUB=$TR($P($G(^TMP(XUSRTN,$J,1)),U),":")_"("_$G(XUSPROD)_") NPI EXTRACT TYPE 1 " - D ^XMD - Q +XUSNPIX5 ;OAK_BP/CMW - NPI EXTRACT REPORT ;01-OCT-06 + ;;8.0;KERNEL;**453**; Jul 10, 1995;Build 36 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; + ; NPI Extract Report Mailer routine + ; + ; Input parameter: XUSRTN + ; + ; Other relevant variables: + ; XUSRTN="XUSNPIX1" (current routine name, used for ^XTMP and ^TMP + ; storage subscript) + ; Storage Global: + ; ^XTMP("XUSNPIX1",0) = Piece 1^Piece 2^Piece 3^Piece 4^Piece 5^Piece 6 + ; where: + ; Piece 1 => Purge Date - 1 year in future + ; Piece 2 => Create Date - Today + ; Piece 3 => Description + ; Piece 4 => Last Date Compiled + ; Piece 5 => $H last run start time + ; Piece 6 => $H last run completion time + ; + ; ^XTMP("XUSNPIX1",1) = DATA + ; + ; XUSNPI => Unique NPI of entry + ; LDT => Last Date Run, VA Fileman Format + ; + Q + ; +EMAIL(XUSRTN) ; EMAIL THE MESSAGE + ; Add domain name if it does not exist + N XUSFOC,DLAYGO,DA,DIC,DIE,DR,X,Y + I '$$FIND1^DIC(4.2,,"QX","Q-NPS.VA.GOV","B") D + . S XUSFOC=$O(^DIC(4.2,"B","FOC-AUSTIN.VA.GOV",0)) I 'XUSFOC Q + . I XUSFOC=$O(^DIC(4.2,"B","FOC-AUSTIN.VA.GOV",""),-1) D + . . S DIC="^DIC(4.2,",X="Q-NPS.VA.GOV",DIC(0)="L",DLAYGO=4.2 D ^DIC K DLAYGO + . . S DIE=DIC,DA=+Y + . . S DR="1///NS;2///^S X=XUSFOC;1.7///YES;6.2///NPS;" + . . D ^DIE + ; + N XMY + ; Send email to designated recipient for live release + S XMY("XXX@Q-NPS.VA.GOV")="" + ;S XMY(DUZ)="" ;use for testing - remove before live + D ESEND + Q + ; +VMAIL(XUSRTN) ; Verification email + N TMP + S TMP=^TMP(XUSRTN,$J,1) + K ^TMP(XUSRTN,$J) + S ^TMP(XUSRTN,$J,1)=$P(TMP,U,1,4) + S ^TMP(XUSRTN,$J,2)="" + S ^TMP(XUSRTN,$J,3)="TYPE 1 : NEW PERSON FILE (#200)" + S ^TMP(XUSRTN,$J,4)="" + S ^TMP(XUSRTN,$J,5)="Date/Time of Extract: "_$P(TMP,U,9) + S ^TMP(XUSRTN,$J,6)="" + S ^TMP(XUSRTN,$J,7)="Message number: "_MSGCNT_" Total NPI records: "_(COUNT-2) + S ^TMP(XUSRTN,$J,8)="" + S ^TMP(XUSRTN,$J,9)="Programmer Notes: "_XUSVER_" - "_$P(TMP,U,10) + ; + ; Send verification email to local mail group and VA Outlook mail group. + S XMY("G.NPI EXTRACT VERIFICATION")="" + D ESEND + K ^TMP(XUSRTN) + Q + ; +SMAIL(XUSRTN) ; Summary email + N TMP,T1,T2,T1NV,T2NV + K ^TMP(XUSRTN,$J) + S T1=$G(^XTMP(XUSRTN,1)) + S T2=$G(^XTMP(XUSRTN,2)) + S T1NV=$G(^XTMP(XUSRTN,"1NV")) + S T2NV=$G(^XTMP(XUSRTN,"2NV")) + S ^TMP(XUSRTN,$J,1)=^XTMP(XUSRTN,"H")_" - SUMMARY for "_DTTM + S ^TMP(XUSRTN,$J,2)="" + S ^TMP(XUSRTN,$J,3)="NEW PERSON FILE (#200) "_+$P(T1,U)_" Message(s) Totaling "_+$P(T1,U,2)_" NPI records." + S ^TMP(XUSRTN,$J,4)="" + S ^TMP(XUSRTN,$J,5)="INSITUTION FILE (#4) "_+$P(T2,U)_" Message(s) Totaling "_+$P(T2,U,2)_" NPI records." + S ^TMP(XUSRTN,$J,6)="" + S ^TMP(XUSRTN,$J,7)="NON VA Individual (#355.93) "_+$P(T1NV,U)_" Message(s) Totaling "_+$P(T1NV,U,2)_" NPI records." + S ^TMP(XUSRTN,$J,8)="" + S ^TMP(XUSRTN,$J,9)="NON VA Facility/Group (#355.93) "_+$P(T2NV,U)_" Message(s) Totaling "_+$P(T2NV,U,2)_" NPI records." + S ^TMP(XUSRTN,$J,10)="" + S ^TMP(XUSRTN,$J,11)="Programmer Notes: "_XUSVER_" - "_$G(XUSPROD) + ; + ; Send verification email to local mail group and VA Outlook mail group + S XMY("G.NPI EXTRACT VERIFICATION")="" + N XMTEXT,XMSUB,XMDUN,XMDUZ,XMZ + S XMTEXT="^TMP("""_XUSRTN_""","_$J_"," + S XMSUB=$TR($P($G(^TMP(XUSRTN,$J,1)),U),":")_"("_$G(XUSPROD)_") NPI EXTRACT SUMMARY " + D ^XMD + Q + K ^TMP(XUSRTN) + Q + ; +ESEND N XMTEXT,XMSUB,XMDUN,XMDUZ,XMZ + S XMTEXT="^TMP("""_XUSRTN_""","_$J_"," + S XMSUB=$TR($P($G(^TMP(XUSRTN,$J,1)),U),":")_"("_$G(XUSPROD)_") NPI EXTRACT TYPE 1 " + D ^XMD + Q diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS.m index f38ba8c3..50765947 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS.m @@ -1,99 +1,91 @@ -%ZIS ;SFISC/AC,RWF -- DEVICE HANDLER ;1/24/08 16:06 - ;;8.0;KERNEL;**18,23,69,112,199,191,275,363,440**;JUL 10, 1995;Build 13 - ;Per VHA Directive 2004-038, this routine should not be modified - N %ZISOS,%ZISV - S U="^",%ZISOS=$G(^%ZOSF("OS")),%ZISV=$G(^%ZOSF("VOL")) - ;Check SPOOLER special case first -INIT I $D(ZTQUEUED),$G(IOT)="SPL",$D(IO)#2,$D(IO(0))#2,IO]"",IO=IO(0),$D(IO(1,IO))#2,%ZISOS["VAX DSM"!(%ZISOS["M/VX"),$G(IOP)[ION!(IOP[IO) K %ZIS,%IS,IOP Q - ; - I '$D(%ZIS),$D(%IS) M %ZIS=%IS - S:'($D(%ZIS)#2) %ZIS="M" M %IS=%ZIS ;update %IS for now - I '$D(^XUTL("XQ",$J,"MIXED OS")) S ^XUTL("XQ",$J,"MIXED OS")=$$PRI^%ZOSV - S %ZIS("PRI")=$G(^XUTL("XQ",$J,"MIXED OS"),1) - ; - I $D(ZTQUEUED) D I '$D(IOP) S POP=1 G EXIT^%ZIS1 - .I $D(ZTIO)#2,ZTIO="" S:%IS'[0 %IS=%IS_"0",%ZIS=%ZIS_"0" - I '$D(ZTQUEUED),%IS["T",$P($G(IOP),";")="Q" S POP=1 G EXIT^%ZIS1 - N %,%A,%E,%H,%I,%X,%XX,%Y,%Z,%Z1,%Z2,%Z9,%Z90,%Z91,%Z95,%ZISB,%ZTIME,%ZTYPE - N %ZHFN,%ZISOLD,DTOUT,DUOUT - ;Save symbols to restore if don't open a device - D SYMBOL^%ZISUTL(0,$NA(%ZISOLD)) -A D CLEAN ;(p363) K IO("CLOSE"),IO("HFSIO") - K IO("P"),IO("Q"),IO("S"),IO("T") -K2 D K2^%ZIS1 - S %ZISB=%ZIS'["N",(%E,%H,POP)=0,%Y="" S:'$D(IO(0)) IO(0)=$I - I %ZISOS["VAX DSM",$I["SYS$INPUT:.;" S:%ZIS'[0 %IS=%IS_"0",%ZIS=%ZIS_"0" - ;I %IS["T"&(%IS["0") S (%H,%E)=0 G ^%ZIS1 - I $D(IOP),IOP=$I!(IOP="HOME")!(0[IOP),$D(^XUTL("XQ",$J,"IO")) D HOME K %IS,%Y,%ZIS,%ZISB,%ZISV,IOP Q - ;Don't worry about HOME if %ZIS[0 - D:%ZIS'[0 GETHOME G EXIT^%ZIS1:POP,^%ZIS1 ;Jump to next part - ; -GETHOME I $D(IO("HOME")),$P(IO("HOME"),"^",2)=IO(0) S (%E,%H)=+IO("HOME") Q - I $D(^XUTL("XQ",$J,"IOS")),$D(^("IO")),IO(0)=^("IO") S (%E,%H)=^("IOS") Q - ;CALL LINEPORT CODE HERE--- - S %=$$LINEPORT^%ZISUTL I % S (%E,%H)=% Q - S %ZISVT=$I D VTLKUP I '%E S %ZISVT=$I D VIRTUAL - I %ZISVT=""!(%E'>0) I %IS'[0 O IO(0)::0 I $T U IO(0) W !,"HOME DEVICE ("_$I_") DOES NOT EXIST IN THE DEVICE FILE",!,"PLEASE CONTACT YOUR SYSTEM MANAGER!",*7 - S %H=%E S:'%H&(%IS'[0) POP=1 S:(%H>0)&('$D(IO("HOME"))) IO("HOME")=%H_"^"_$I - Q -VIRTUAL ;See if a Virtual Terminal (LAT, TELNET) - ;Change the MSM check for telnet to work with v4.4 - I %ZISOS["MSM" X "I $P($ZV,""Version "",2)'<3 S %ZISVT=$ZDE(+%ZISVT) I %ZISVT?.E1""~""4.5N.E S %ZISVT=""TELNET""" - F %ZISI=$L(%ZISVT):-1:0 D:$D(^%ZIS(1,"C",%ZISVT)) Q:$S('%E:0,'$D(^%ZIS(1,%E,"TYPE")):0,^("TYPE")="VTRM":1,1:0) S %ZISVT=$E(%ZISVT,1,%ZISI) - .D VTLKUP Q:$S('%E:0,'$D(^%ZIS(1,%E,"TYPE")):0,^("TYPE")="VTRM":1,1:0) - .S %X=0 F %ZISX=%ZISV,"" Q:%X>0 S %X=0 F S %E=+$O(^%ZIS(1,"CPU",%ZISX_"."_%ZISVT,%X)) S %X=%E Q:%E'>0 I $G(^%ZIS(1,+%E,"TYPE"))="VTRM" Q - Q -VTLKUP F %ZISX=%ZISV,"" S %E=+$O(^%ZIS(1,"G","SYS."_%ZISX_"."_%ZISVT,0)) Q:%E S %E=+$O(^%ZIS(1,"CPU",%ZISX_"."_%ZISVT,0)) Q:%E - Q - ; -CURRENT N POP,%ZIS,%IS,%E,%H - S FF="#",SL=24,BS="*8",RM=80,(SUB,XY)="",%IS=0,%ZISOS=$G(^%ZOSF("OS")),%ZISV=$G(^("VOL")),POP=0 - D GETHOME K %E,%IS,%ZISI,%ZISOS,%ZISV,%ZISVT,%ZISX Q:POP - I $D(^%ZIS(1,%H,"SUBTYPE")) S SUB=+^("SUBTYPE") K %H - I $D(SUB),SUB,$D(^%ZIS(2,SUB,1)) S SUB=$S($D(^(0)):$P(^(0),"^"),1:""),FF=$P(^(1),"^",2),SL=$P(^(1),"^",3),BS=$P(^(1),"^",4),XY=$P(^(1),"^",5),RM=+^(1) - E S SUB="" - I $D(^%ZOSF("RM")) N X S X=RM X ^("RM") K %A - Q -HOME ;Entry point to establish IO* variables for home device. - D CLEAN ;(p363) - N X I '$D(^XUTL("XQ",$J,"IO")) S IOP="HOME" D ^%ZIS Q - D RESETVAR - I '$D(IO("C")),$G(IOM),IO=$I,$D(IO(1,IO)),$D(^%ZOSF("RM")) S X=+IOM X ^("RM") - Q - ;IO("Q") is checked by many routines after a call to ^%ZISC, so only clean on call to %ZIS. -CLEAN ;Cleanup env. Called from %ZISC also. - I $G(IOT)'="SPL" K IO("DOC"),IO("SPOOL") ;(p446) - I $G(IOT)'="HFS" K IO("HFSIO") ;p446 - S (IOPAR,IOUPAR)="" - Q - ; -RESETVAR ;Reset home IO* variables. - I '$D(^XUTL("XQ",$J,"IO")) Q - N % - F %="IO","IOBS","IOF","IOM","ION","IOS","IOSL","IOST","IOST(0)","IOT","IOXY","IOPAR","IOUPAR" I $D(^XUTL("XQ",$J,%))#2 S @%=^(%) - F %="IO(""IP"")","IO(""CLNM"")","IO(""DOC"")","IO(""HFSIO"")","IO(""SPOOL"")" I $D(^XUTL("XQ",$J,%))#2 S @%=^(%) - S POP=0,IO(0)=IO - Q -SAVEVAR ;Save home IO* variables, called from XUS1,%ZTMS3 - N % - F %="IO","IOBS","IOF","IOM","ION","IOS","IOSL","IOST","IOST(0)","IOT","IOXY","IOPAR","IOUPAR" I $D(@%) S ^XUTL("XQ",$J,%)=@% - F %="IO(""IP"")","IO(""CLNM"")","IO(""DOC"")","IO(""HFSIO"")","IO(""SPOOL"")" I $D(@%) S ^XUTL("XQ",$J,%)=@% - Q -ZISLPC Q ;No longer called in Kernel v8. - ; -HLP1 G EN1^%ZIS7 -HLP2 N %E,%H,%X,%ZISV,X S %ZISV=$S($D(^%ZOSF("VOL")):^("VOL"),1:"") G EN2^%ZIS7 - ; -REWIND(IO2,IOT,IOPAR) ;Rewind Device - N %,X,Y,$ES,$ET S $ET="D REWERR^%ZIS Q 0" - S %=$I - I '($D(IO2)#2)!'$D(IOT)!'$D(IOPAR) Q 0 - I "MT^SDP^HFS"'[IOT Q 0 - S @("Y=$$REW"_IOT_"^%ZIS4(IO2,IOPAR)") - U % - Q Y -REWERR ;Error encountered - S IO("ERROR")=$EC - S $EC="",$ET="Q:$ES>1 S $EC="""" Q 0" S $EC=",U1," - Q 0 - ; +%ZIS ;SFISC/AC,RWF -- DEVICE HANDLER ;10/14/2004 08:46 + ;;8.0;KERNEL;**18,23,69,112,199,191,275,363**;JUL 10, 1995 + N %ZISOS,%ZISV + S U="^",%ZISOS=$G(^%ZOSF("OS")),%ZISV=$G(^%ZOSF("VOL")) + ;Check SPOOLER special case first +INIT I $D(ZTQUEUED),$G(IOT)="SPL",$D(IO)#2,$D(IO(0))#2,IO]"",IO=IO(0),$D(IO(1,IO))#2,%ZISOS["VAX DSM"!(%ZISOS["M/VX"),$G(IOP)[ION!(IOP[IO) K %ZIS,%IS,IOP Q + ; + I '$D(%ZIS),$D(%IS) M %ZIS=%IS + S:'($D(%ZIS)#2) %ZIS="M" M %IS=%ZIS ;update %IS for now + ; + I $D(ZTQUEUED) D I '$D(IOP) S POP=1 G EXIT^%ZIS1 + .I $D(ZTIO)#2,ZTIO="" S:%IS'[0 %IS=%IS_"0",%ZIS=%ZIS_"0" + I '$D(ZTQUEUED),%IS["T",$P($G(IOP),";")="Q" S POP=1 G EXIT^%ZIS1 + N %,%A,%E,%H,%I,%X,%XX,%Y,%Z,%Z1,%Z9,%Z90,%Z91,%Z95,%ZISB,%ZTIME,%ZTYPE + N %ZHFN,%ZISOLD,DTOUT,DUOUT + ;Save symbols to restore if don't open a device + D SYMBOL^%ZISUTL(0,$NA(%ZISOLD)) +A D CLEAN ;(p363) K IO("CLOSE"),IO("HFSIO") + K IO("P"),IO("Q"),IO("S"),IO("T") +K2 D K2^%ZIS1 + S %ZISB=%ZIS'["N",(%E,%H,POP)=0,%Y="" S:'$D(IO(0)) IO(0)=$I + I %ZISOS["VAX DSM",$I["SYS$INPUT:.;" S:%ZIS'[0 %IS=%IS_"0",%ZIS=%ZIS_"0" + ;I %IS["T"&(%IS["0") S (%H,%E)=0 G ^%ZIS1 + I $D(IOP),IOP=$I!(IOP="HOME")!(0[IOP),$D(^XUTL("XQ",$J,"IO")) D HOME K %IS,%Y,%ZIS,%ZISB,%ZISV,IOP Q + ;Don't worry about HOME if %ZIS[0 + D:%ZIS'[0 GETHOME G EXIT^%ZIS1:POP,^%ZIS1 ;Jump to next part + ; +GETHOME I $D(IO("HOME")),$P(IO("HOME"),"^",2)=IO(0) S (%E,%H)=+IO("HOME") Q + I $D(^XUTL("XQ",$J,"IOS")),$D(^("IO")),IO(0)=^("IO") S (%E,%H)=^("IOS") Q + ;CALL LINEPORT CODE HERE--- + S %=$$LINEPORT^%ZISUTL I % S (%E,%H)=% Q + S %ZISVT=$I D VTLKUP I '%E S %ZISVT=$I D VIRTUAL + I %ZISVT=""!(%E'>0) I %IS'[0 O IO(0)::0 I $T U IO(0) W !,"HOME DEVICE DOES NOT EXIST IN THE DEVICE FILE",!,"PLEASE CONTACT YOUR SYSTEM MANAGER!",*7 + S %H=%E S:'%H&(%IS'[0) POP=1 S:(%H>0)&('$D(IO("HOME"))) IO("HOME")=%H_"^"_$I + Q +VIRTUAL ;See if a Virtual Terminal (LAT, TELNET) + ;Change the MSM check for telnet to work with v4.4 + I %ZISOS["MSM" X "I $P($ZV,""Version "",2)'<3 S %ZISVT=$ZDE(+%ZISVT) I %ZISVT?.E1""~""4.5N.E S %ZISVT=""TELNET""" + F %ZISI=$L(%ZISVT):-1:0 D:$D(^%ZIS(1,"C",%ZISVT)) Q:$S('%E:0,'$D(^%ZIS(1,%E,"TYPE")):0,^("TYPE")="VTRM":1,1:0) S %ZISVT=$E(%ZISVT,1,%ZISI) + .D VTLKUP Q:$S('%E:0,'$D(^%ZIS(1,%E,"TYPE")):0,^("TYPE")="VTRM":1,1:0) + .S %X=0 F %ZISX=%ZISV,"" Q:%X>0 S %X=0 F S %E=+$O(^%ZIS(1,"CPU",%ZISX_"."_%ZISVT,%X)) S %X=%E Q:%E'>0 I $G(^%ZIS(1,+%E,"TYPE"))="VTRM" Q + Q +VTLKUP F %ZISX=%ZISV,"" S %E=+$O(^%ZIS(1,"G","SYS."_%ZISX_"."_%ZISVT,0)) Q:%E S %E=+$O(^%ZIS(1,"CPU",%ZISX_"."_%ZISVT,0)) Q:%E + Q + ; +CURRENT N POP,%ZIS,%IS,%E,%H + S FF="#",SL=24,BS="*8",RM=80,(SUB,XY)="",%IS=0,%ZISOS=$G(^%ZOSF("OS")),%ZISV=$G(^("VOL")),POP=0 + D GETHOME K %E,%IS,%ZISI,%ZISOS,%ZISV,%ZISVT,%ZISX Q:POP + I $D(^%ZIS(1,%H,"SUBTYPE")) S SUB=+^("SUBTYPE") K %H + I $D(SUB),SUB,$D(^%ZIS(2,SUB,1)) S SUB=$S($D(^(0)):$P(^(0),"^"),1:""),FF=$P(^(1),"^",2),SL=$P(^(1),"^",3),BS=$P(^(1),"^",4),XY=$P(^(1),"^",5),RM=+^(1) + E S SUB="" + I $D(^%ZOSF("RM")) N X S X=RM X ^("RM") K %A + Q +HOME ;Entry point to establish IO* variables for home device. + D CLEAN ;(p363) + N X I '$D(^XUTL("XQ",$J,"IO")) S IOP="HOME" D ^%ZIS Q + D RESETVAR + I '$D(IO("C")),$G(IOM),IO=$I,$D(IO(1,IO)),$D(^%ZOSF("RM")) S X=+IOM X ^("RM") + Q + ;IO("Q") is checked by many routines after a call to ^%ZISC, so only clean on call to %ZIS. +CLEAN ;Cleanup env. Called from %ZISC also. + K IO("DOC"),IO("HFSIO"),IO("SPOOL") ;(p366) + S (IOPAR,IOUPAR)="" + Q + ; +RESETVAR ;Reset home IO* variables. + I '$D(^XUTL("XQ",$J,"IO")) Q + N % F %="IO","IOBS","IOF","IOM","ION","IOS","IOSL","IOST","IOST(0)","IOT","IOXY" I $D(^XUTL("XQ",$J,%))#2 S @%=^(%) + S POP=0,IO(0)=IO,(IOPAR,IOUPAR)="" + Q +SAVEVAR ;Save home IO* variables, called from XUS1 + N % F %="IO","IOBS","IOF","IOM","ION","IOS","IOSL","IOST","IOST(0)","IOT","IOXY" I $D(@%) S ^XUTL("XQ",$J,%)=@% + Q +ZISLPC Q ;No longer called in Kernel v8. + ; +HLP1 G EN1^%ZIS7 +HLP2 N %E,%H,%X,%ZISV,X S %ZISV=$S($D(^%ZOSF("VOL")):^("VOL"),1:"") G EN2^%ZIS7 + ; +REWIND(IO2,IOT,IOPAR) ;Rewind Device + N %,X,Y,$ES,$ET S $ET="D REWERR^%ZIS Q 0" + S %=$I + I '($D(IO2)#2)!'$D(IOT)!'$D(IOPAR) Q 0 + I "MT^SDP^HFS"'[IOT Q 0 + S @("Y=$$REW"_IOT_"^%ZIS4(IO2,IOPAR)") + U % + Q Y +REWERR ;Error encountered + S IO("ERROR")=$EC + S $EC="",$ET="Q:$ES>1 S $EC="""" Q 0" S $EC=",U1," + Q 0 + ; diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS1.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS1.m index b639c046..c98b3e05 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS1.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS1.m @@ -1,102 +1,93 @@ -%ZIS1 ;SFISC/AC,RWF -- DEVICE HANDLER (DEVICE INPUT) ;1/24/08 16:06 - ;;8.0;KERNEL;**18,49,69,104,112,199,391,440**;JUL 10, 1995;Build 13 - ;Per VHA Directive 2004-038, this routine should not be modified -MAIN ;Called from %ZIS with a GO - I '$D(IOP),$D(^%ZIS(1,%E,0)),'$P(^(0),"^",3) S %A=%H,%Z=^(0) D L2^%ZIS2 G EXIT -L1 ;Main Loop - I '$D(IOP),$D(IO("Q")),POP D AQUE^%ZIS3 K:%=2 IO("Q") S:%=2 %ZISB=$S(%IS'["N":2,1:0) I %=-1 S POP=1 G EXIT - S %E=%H,POP=0,%IS=%ZIS ;Reset %IS from %ZIS - I %IS'["Q",$D(XQNOGO) S POP=1 W:'$D(IOP) !,$C(7),"OUTPUT IS NEVER ALLOWED FOR THIS OPTION" G EXIT - D IOP:$D(IOP),R:'$D(IOP) - G EXIT:$D(DTOUT)!$D(DUOUT)!(POP&$D(IOP)),L1:POP&'$D(IOP) - D LKUP I %A'>0 S POP=1 D:'$D(DUOUT) MSG1 K DUOUT - I '$D(^%ZIS(1,%A,0)) D MSG1 K %ZISIOS S POP=1 - I POP G EXIT:$D(IOP),L1:'$D(IOP) - S %E=%A,%Z=^%ZIS(1,%A,0),%Z1=$G(^(1)) - I $D(%ZIS("S")) N Y S Y=%E D XS^ZISX S:'$T POP=1 G G:POP - W:'$D(IOP)&($P(%Z,"^",2)'=$I)&($P(%Z1,"^")]"") " ",$P(%Z1,"^") - D L2^%ZIS2 ;Call -G G L1:POP&'$D(IOP)&'($D(DTOUT)!$D(DUOUT)) ;Didn't get it - ; -EXIT ; - I POP G EX2 ;Did not get the device. - ;For type[TRM reset $X & $Y - I %ZTYPE["TRM",IO]"",$D(IO(1,IO)) U IO S:'(IO=IO(0)&'$D(IO("S"))&'$D(ZTQUEUED)) $X=0,$Y=0 - ;Do count of number of times device opened. Field 51. - I $L($G(IO)),$D(IO(1,IO))#2,$G(%ZISIOS) D - . S $P(^(5),"^",1)=$P($G(^%ZIS(1,%ZISIOS,5)),"^",1)+1 - I %ZIS["H" S IO(0)=IO,IO("HOME")=%ZISIOS_"^"_IO ;Make home device - I '$D(IO("Q")),$D(%ZISLOCK) S ^XUTL("XQ",$J,"lock",%ZISIOS)=%ZISLOCK - I $D(IO)#2,IO]"",$D(IO(1,IO))#2,$D(%Z1),$P(%Z1,"^",11) S IO(1,IO,"NOFF")=1 -EX2 ; - I %IS'[0,$G(IO(0))]"" U IO(0) ;Make sure return with home active - G SETVAR:'POP!(%IS["T"),KILVAR - ; -IOP ;Request with IOP set - S (%ZISVT,%X)=IOP S:%X'?1.UNP %X=$$UP(%X) I %X'="Q" D SETQ Q - S %IS=%IS_%X K IOP W %X D SETQ Q - ;Get ready to ask user for device -R I %IS["Q",$D(XQNOGO) W !,$C(7),"AT THIS TIME, OUTPUT MUST BE QUEUED" - S %A=$S($D(%IS("B")):%IS("B"),1:"HOME") ;Setup default - I %IS["P",%A="HOME",$D(^%ZIS(1,%E,99)),$D(^%ZIS(1,+^(99),0)) S %A=$P(^(0),"^",1) -RD W !,$S($D(%IS("A")):%IS("A"),1:"DEVICE: ") W:%A]"" %A,"// " D SBR S:%X="" %X=%A S %ZISVT=%X - I %X?2"?".E D EN2^%ZIS7 G R - I %X?1"?".E D EN1^%ZIS7 G R - I $D(DTOUT)!$D(DUOUT)!(%X'?.ANP)!($L($P(%X,";"))>31) S:%IS["T" IO="" S POP=1 Q - S:%X'?1.UNP %X=$$UP(%X) D SETQ G R:$T Q -SETQ S %Y=$P(%X,";",2,9),%X=$P(%X,";",1) S:$L(";"_%Y,";/")=2 IO("P")=$P(";"_%Y,";/",2) - I %IS["Q",%X="Q" S %X=%Y,%ZISVT=$P(%ZISVT,";",2,9),%ZISB=0,IO("Q")=1,%IS("A")="DEVICE: " S:$D(IOP) %Y=$P(%X,";",2,9),%X=$P(%X,";",1) - I $T,'$D(IOP) W "UEUE TO PRINT ON" Q ; Return $T value - Q -LKUP S %ZISMY=$P(%ZISVT,";",2,999),%ZISVT=$P(%ZISVT,";") - I %X="H" W:'$D(IOP) "ome" S %X=0 - I 0[%X!(%X="HOME")!(%X=$I) S %A=%H Q - I $E(%ZISVT)="`",$D(IOP) S %A=+$E(%ZISVT,2,999) I $G(^%ZIS(1,%A,0))]"" Q - S %A=0 I "P"[%X Q:$D(IOP)&('$D(^%ZIS(1,%E,99))) I $D(^%ZIS(1,%E,99)) S %A=+^(99) Q - I %X=" ",$D(DUZ)#2,$D(^DISV(+DUZ,"^%ZIS(1,")) S %A=^("^%ZIS(1,") Q - S %A=+$O(^%ZIS(1,"B",%ZISVT,0)) Q:%A>0 ;mixed case lookup - I %X'=%ZISVT S %A=+$O(^%ZIS(1,"B",%X,0)) Q:%A>0 ;uppercase lookup - D VTLKUP^%ZIS S %A=%E Q:%A>0 ;mixed case lookup - I %X'=%ZISVT S %ZISVT=%X D VTLKUP^%ZIS S %A=%E Q:%A>0 ;uppercase lookup - N %XX,%YY S %XX=%X D 1^%ZIS5 S %A=+%YY Q -SBR K DFOUT,DTOUT,DUOUT R %X:$S($D(DTIME)#2:DTIME,1:300) E W $C(7) S DTOUT=1 Q - S:%X="."!(%X="^") DUOUT=1,%X="" Q -LC S %X=$$UP(%X) - Q -LOW(%) Q $TR(%,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz") -UP(%) Q $TR(%,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") - ; - ;Call/Return % = 1 (yes), 2 (no) -1 (^) -YN W "? ",$P("Yes// ^No// ",U,%) -RYN R %X:$S($D(DTIME):DTIME,$D(%ZISDTIM):%ZISDTIM,1:300) E S DTOUT=1,%X=U W $C(7) - S:%X]""!'% %=$A(%X),%=$S(%=89:1,%=121:1,%=78:2,%=110:2,%=94:-1,1:0) - I '%,%X'?."?" W $C(7),"??",!?4,"ANSWER 'Yes' OR 'No': " G RYN - W:$X>73 ! W $P(" (Yes)^ (No)",U,%) - Q -MSG1 I '$D(IOP) W ?20,$C(7)," [DEVICE DOES NOT EXIST]" - Q -SETVAR ;Come here to setup the variables for the selected device - S:$D(IO)[0 IO="" G KILVAR:%IS["T"&(IO="") - I $G(%Z)="" S ION="Unknown device",POP=1 G KILVAR - S:IO'=IO(0)&($D(DUZ)#2) ^DISV(+DUZ,"^%ZIS(1,")=%E - S ION=$P(%Z,"^",1),IOM=+%Z91,IOF=$P(%Z91,"^",2),IOSL=$P(%Z91,"^",3),IOBS=$P(%Z91,"^",4),IOXY=$P(%Z91,"^",5) - I IOSL>65530 S IOSL=65530 ;Cache rolls $Y at 65535 - S IOT=%ZTYPE,IOST(0)=%ZISIOST(0),IOST=%ZISIOST,IOPAR=%ZISOPAR,IOUPAR=%ZISUPAR,IOHG=%ZISHG - S:IOF="" IOF="#" ;See that IOF has something - K IOCPU S:$D(%ZISCPU) IOCPU=%ZISCPU - G KIL - ; -KILVAR ;Come here to restore the calling variables - D SYMBOL^%ZISUTL(1,"%ZISOLD") - S:'$L($G(IOF)) IOF="#" S:'$D(IOST(0)) IOST(0)=0 - ;See that all standard variables are defined - F %I="IO","ION","IOM","IOBS","IOSL","IOST" S:$D(@%I)[0 @%I="" - K IO("HFSIO"),IO("OPEN") I $D(%ZISCPU) S:'$D(IOCPU) IOCPU=%ZISCPU -KIL ;Final exit cleanup - S:'POP IOS=%ZISIOS I POP K:%IS'["T" %ZISIOS I %IS["T" K IOS S:$D(%ZISIOS) IOS=%ZISIOS - S:%IS["T" IO("T")=1 K %ZIS,%IS,%A,%E,%H,%ZISOS,%ZISV,IOP -K2 K %I,%X,%Y,%Z,%Z1,%Z91,%Z95,%ZTYPE,%ZTIME - K %ZISCHK,%ZISCPU,%ZISI,%ZISR,%ZISVT,%ZISB,%ZISX,ZISI,%ZISHGL,%ZISHP,%ZISIO,%ZISIOS,%ZISIOM - K %ZISIOF,%ZISIOSL,%ZISIOBS,%ZISIOST,%ZISIOST(0),%ZISTO,%ZISTP,%ZISHG,%ZISSIO,%ZISOPEN,%ZISOPAR,%ZISUPAR - K %ZISMY,%ZISQUIT,%ZISLOCK - Q +%ZIS1 ;SFISC/AC,RWF -- DEVICE HANDLER (DEVICE INPUT) ;07/07/2005 15:48 + ;;8.0;KERNEL;**18,49,69,104,112,199,391**;JUL 10, 1995 +MAIN ;Called from %ZIS with a GO + I '$D(IOP),$D(^%ZIS(1,%E,0)),'$P(^(0),"^",3) S %A=%H,%Z=^(0) D L2^%ZIS2 G EXIT +L1 ;Main Loop + I '$D(IOP),$D(IO("Q")),POP D AQUE^%ZIS3 K:%=2 IO("Q") S:%=2 %ZISB=$S(%IS'["N":2,1:0) I %=-1 S POP=1 G EXIT + S %E=%H,POP=0,%IS=%ZIS ;Reset %IS from %ZIS + I %IS'["Q",$D(XQNOGO) S POP=1 W:'$D(IOP) !,*7,"OUTPUT IS NEVER ALLOWED FOR THIS OPTION" G EXIT + D IOP:$D(IOP),R:'$D(IOP) + G EXIT:$D(DTOUT)!$D(DUOUT)!(POP&$D(IOP)),L1:POP&'$D(IOP) + D LKUP I %A'>0 S POP=1 D:'$D(DUOUT) MSG1 K DUOUT + I POP G EXIT:$D(IOP),L1:'$D(IOP) + I '$D(^%ZIS(1,%A,0)) D MSG1 K %ZISIOS S POP=1 + I POP G EXIT:$D(IOP),L1:'$D(IOP) + S %E=%A,%Z=^%ZIS(1,%A,0),%Z1=$G(^(1)) + I $D(%ZIS("S")) N Y S Y=%E D XS^ZISX S:'$T POP=1 G G:POP + W:'$D(IOP)&($P(%Z,"^",2)'=$I)&($P(%Z1,"^")]"") " ",$P(%Z1,"^") + D L2^%ZIS2 +G G L1:POP&'$D(IOP)&'($D(DTOUT)!$D(DUOUT)) ;Didn't get it + ;For type[TRM reset $X & $Y + I 'POP,%ZTYPE["TRM",IO]"",$D(IO(1,IO)) U IO S:'(IO=IO(0)&'$D(IO("S"))&'$D(ZTQUEUED)) $X=0,$Y=0 + ; +EXIT I $D(IO)#2,IO]"",$D(IO(1,IO))#2,$D(%Z1),$P(%Z1,"^",11) S IO(1,IO,"NOFF")=1 + ;Do count of number of times device opened. Field 51. + I $L($G(IO)),$D(IO(1,IO))#2,'POP,$G(%ZISIOS) D + . S $P(^(5),"^",1)=$P($G(^%ZIS(1,%ZISIOS,5)),"^",1)+1 + I 'POP,%ZIS["H" S IO(0)=IO,IO("HOME")=%ZISIOS_"^"_IO ;Make home device + I %IS'[0,$G(IO(0))]"" U IO(0) ;Make sure return with home active + G SETVAR:'POP!(%IS["T"),KILVAR + ; +IOP ;Request with IOP set + S (%ZISVT,%X)=IOP S:%X'?1.UNP %X=$$UP(%X) I %X'="Q" D SETQ Q + S %IS=%IS_%X K IOP W %X D SETQ Q + ;Get ready to ask user for device +R I %IS["Q",$D(XQNOGO) W !,*7,"AT THIS TIME, OUTPUT MUST BE QUEUED" + S %A=$S($D(%IS("B")):%IS("B"),1:"HOME") ;Setup default + I %IS["P",%A="HOME",$D(^%ZIS(1,%E,99)),$D(^%ZIS(1,+^(99),0)) S %A=$P(^(0),"^",1) +RD W !,$S($D(%IS("A")):%IS("A"),1:"DEVICE: ") W:%A]"" %A,"// " D SBR S:%X="" %X=%A S %ZISVT=%X + I %X?2"?".E D EN2^%ZIS7 G R + I %X?1"?".E D EN1^%ZIS7 G R + I $D(DTOUT)!$D(DUOUT)!(%X'?.ANP)!($L($P(%X,";"))>31) S:%IS["T" IO="" S POP=1 Q + S:%X'?1.UNP %X=$$UP(%X) D SETQ G R:$T Q +SETQ S %Y=$P(%X,";",2,9),%X=$P(%X,";",1) S:$L(";"_%Y,";/")=2 IO("P")=$P(";"_%Y,";/",2) + I %IS["Q",%X="Q" S %X=%Y,%ZISVT=$P(%ZISVT,";",2,9),%ZISB=0,IO("Q")=1,%IS("A")="DEVICE: " S:$D(IOP) %Y=$P(%X,";",2,9),%X=$P(%X,";",1) + I $T,'$D(IOP) W "UEUE TO PRINT ON" Q ; Return $T value + Q +LKUP S %ZISMY=$P(%ZISVT,";",2,999),%ZISVT=$P(%ZISVT,";") + I %X="H" W:'$D(IOP) "ome" S %X=0 + I 0[%X!(%X="HOME")!(%X=$I) S %A=%H Q + I $E(%ZISVT)="`",$D(IOP) S %A=+$E(%ZISVT,2,999) I $G(^%ZIS(1,%A,0))]"" Q + S %A=0 I "P"[%X Q:$D(IOP)&('$D(^%ZIS(1,%E,99))) I $D(^%ZIS(1,%E,99)) S %A=+^(99) Q + I %X=" ",$D(DUZ)#2,$D(^DISV(+DUZ,"^%ZIS(1,")) S %A=^("^%ZIS(1,") Q + S %A=+$O(^%ZIS(1,"B",%ZISVT,0)) Q:%A>0 ;mixed case lookup + I %X'=%ZISVT S %A=+$O(^%ZIS(1,"B",%X,0)) Q:%A>0 ;uppercase lookup + D VTLKUP^%ZIS S %A=%E Q:%A>0 ;mixed case lookup + I %X'=%ZISVT S %ZISVT=%X D VTLKUP^%ZIS S %A=%E Q:%A>0 ;uppercase lookup + N %XX,%YY S %XX=%X D 1^%ZIS5 S %A=+%YY Q +SBR K DFOUT,DTOUT,DUOUT R %X:$S($D(DTIME)#2:DTIME,1:300) E W *7 S DTOUT=1 Q + S:%X="."!(%X="^") DUOUT=1,%X="" Q +LC S %X=$$UP(%X) + Q +LOW(%) Q $TR(%,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz") +UP(%) Q $TR(%,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") +YN W "? ",$P("YES// ^NO// ",U,%) +RYN R %X:$S($D(DTIME):DTIME,$D(%ZISDTIM):%ZISDTIM,1:300) E S DTOUT=1,%X=U W *7 + S:%X]""!'% %=$A(%X),%=$S(%=89:1,%=121:1,%=78:2,%=110:2,%=94:-1,1:0) + I '%,%X'?."?" W *7,"??",!?4,"ANSWER 'YES' OR 'NO': " G RYN + W:$X>73 ! W $P(" (YES)^ (NO)",U,%) Q +MSG1 I '$D(IOP) W ?20,*7," [DEVICE DOES NOT EXIST]" + Q +SETVAR ;Come here to setup the variables for the selected device + S:$D(IO)[0 IO="" G KILVAR:%IS["T"&(IO="") + I $G(%Z)="" S ION="Unknown device",POP=1 G KILVAR + S:IO'=IO(0)&($D(DUZ)#2) ^DISV(+DUZ,"^%ZIS(1,")=%E + S ION=$P(%Z,"^",1),IOM=+%Z91,IOF=$P(%Z91,"^",2),IOSL=$P(%Z91,"^",3),IOBS=$P(%Z91,"^",4),IOXY=$P(%Z91,"^",5) + I IOSL>65530 S IOSL=65530 ;Cache rolls $Y at 65535 + S IOT=%ZTYPE,IOST(0)=%ZISIOST(0),IOST=%ZISIOST,IOPAR=%ZISOPAR,IOUPAR=%ZISUPAR,IOHG=%ZISHG + S:IOF="" IOF="#" ;See that IOF has something + K IOCPU S:$D(%ZISCPU) IOCPU=%ZISCPU G KIL + ; +KILVAR ;Come here to restore the calling variables + D SYMBOL^%ZISUTL(1,"%ZISOLD") + S:'$L($G(IOF)) IOF="#" S:'$D(IOST(0)) IOST(0)=0 + ;See that all standard variables are defined + F %I="IO","ION","IOM","IOBS","IOSL","IOST" S:$D(@%I)[0 @%I="" + K IO("HFSIO"),IO("OPEN") I $D(%ZISCPU) S:'$D(IOCPU) IOCPU=%ZISCPU +KIL ;Final exit cleanup + S:'POP IOS=%ZISIOS I POP K:%IS'["T" %ZISIOS I %IS["T" K IOS S:$D(%ZISIOS) IOS=%ZISIOS + S:%IS["T" IO("T")=1 K %ZIS,%IS,%A,%E,%H,%ZISOS,%ZISV,IOP +K2 K %I,%X,%Y,%Z,%Z1,%Z91,%Z95,%ZTYPE,%ZTIME + K %ZISCHK,%ZISCPU,%ZISI,%ZISR,%ZISVT,%ZISB,%ZISX,ZISI,%ZISHGL,%ZISHP,%ZISIO,%ZISIOS,%ZISIOM,%ZISIOF,%ZISIOSL,%ZISIOBS,%ZISIOST,%ZISIOST(0),%ZISTO,%ZISTP,%ZISHG,%ZISSIO,%ZISOPEN,%ZISOPAR,%ZISUPAR + K %ZISMY,%ZISQUIT + Q diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS2.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS2.m index 7b58376e..65a5c599 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS2.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS2.m @@ -1,94 +1,90 @@ -%ZIS2 ;SFISC/AC,RWF -- DEVICE HANDLER (CHECKS) ;1/24/08 16:07 - ;;8.0;KERNEL;**69,104,112,118,136,241,440**;JUL 10, 1995;Build 13 - ;Per VHA Directive 2004-038, this routine should not be modified -HUNT S:'$D(%ZISHP) %ZISHP=%E,%ZISHGL=0 S %E=0 - F S %ZISHGL=$O(^%ZIS(1,%ZISHG(0),"HG",%ZISHGL)) Q:%ZISHGL'>0 D Q:%E - . N %1,%2 S %1=$G(^%ZIS(1,%ZISHG(0),"HG",+%ZISHGL,0)),%2=$G(^%ZIS(1,+%1,0)) - . ;Check that HG device is on same VOL. - . I $P(%2,"^",9)=%ZISV!($P(%2,"^",9)="") S %E=+$P(^%ZIS(1,%ZISHG(0),"HG",+%ZISHGL,0),"^") - . Q - G L2:%ZISHGL>0 S %ZISHPOP=1,%E=%ZISHP - ; -L2 ;Entry point from %ZIS1 - I $D(DTOUT)!$D(DUOUT) K %ZISHP,%ZISHPOP Q -CHECK ;Get IO check for secondary $I - K %ZISCPU N %Z2 - S POP=0,%Z=^%ZIS(1,%E,0),%Z2=$S(%ZIS("PRI")=1:"",1:$G(^%ZIS(1,%E,2))) ;Get Primary and secondary IO. - S IO=$S(%ZIS("PRI")=1:$P(%Z,"^",2),$L($P(%Z2,"^")):$P(%Z2,"^"),1:$P(%Z,"^",2)) ; - S:%IS["Q"&'$D(ZTQUEUED)&($P(%Z,"^",12)=1!$D(XQNOGO)) %ZISB=0,IO("Q")=1 ;Forced Queueing - I $P(%Z,"^",12)=2 S %IS=$TR(%IS,"Q") I $D(IO("Q")) D Q - . I '$D(IOP) W !,"Queuing NOT ALLOWED on this device" - . S POP=1 K:$D(IOP) IO("Q") Q - S %Z90=$G(^(90)),%Z95=$G(^(95)),%ZTIME=$G(^("TIME")),%ZTYPE=$G(^("TYPE")),%ZISHG=$O(^%ZIS(1,"AHG",%E,0)) - I %ZISHG,$D(^%ZIS(1,+%ZISHG,0)) S:'$D(%ZISHG(0)) %ZISHG(0)=+%ZISHG S %ZISHG=$P(^(0),"^",1) - E S %ZISHG="" - I %ZTYPE="HG" D OTHCPU("HUNT GROUP") G T:$D(%ZISHG(0))!POP - I %ZTYPE="RES" S %ZISRL=+$P(%Z1,"^",10) G T -VTRM I %ZTYPE="VTRM",'('$D(IO("Q"))&(%A=%H)) W:'$D(IOP)&'$D(%ZISHP) *7," [YOU CAN NOT SELECT A VIRTUAL TERMINAL]" S POP=1 ;Virtual Terminal Check - S:%ZTYPE="VTRM"&'$D(IO("Q"))&(%A=%H) IO=$I - ; -SLAVE I $D(IO("Q")),$P(%Z,"^",2)=0,$P(%Z,"^",8)']"" W:'$D(IOP) *7,!?10," [SLAVE device NOT set up for queuing]" S POP=1 G T -OCPU D OTHCPU("DEVICE") - ; -OOS G T:POP I %Z90,$D(DT)#2,%Z90'>DT S POP=1 ;Out Of Service Check - I $T,'$D(IOP),'$D(%ZISHP) W *7," [Out of Service]" ;I 'POP W " ..OK" S %=2,U="^" D YN^%ZIS1 G:%=0 OOS S:%'=1 POP=1 - ; -PTIME G T:POP!(IO=$I)!(IO=0) - ;Prohibitted Time Check - S %A=$P(%ZTIME,"^") I %ZISB,$L(%A) D I POP,'$D(IOP),'$D(%ZISHP) W *7," [ACCESS PROHIBITED "_%A_"]" ;AT THIS TIME]" - . N %C,%L,%H ;%C is current time, %L is lower limit, %H is upper limit - . S %C=$P($H,",",2),%C=%C\60#60+(%C\3600*100),%H=$P(%A,"-",2),%L=+%A - . I $S(%H'<%L:(%C'>%H&(%C'<%L)),1:(%C'<%L!(%C'>%H))) S POP=1 - . Q -DUZ I 'POP D SEC ;Security Check - ; -T I POP,$D(%ZISHG(0)),%IS'["D",'$D(%ZISHPOP),%ZISB G HUNT - I POP D HGBSY:$D(%ZISHPOP) ;G T2:%IS["T" - ; -TMPVAR K IO("S") S %ZISIOS=%E S:IO=0 IO=$I,IO("S")=%H - S %ZISOPAR=$$IOPAR(%E,"IOPAR") - S %ZISUPAR=$$IOPAR(%E,"IOUPAR"),%ZISTO=+$P(%ZTIME,"^",2) - I $D(IO("S")) D I POP Q - . S IO=$S(%IS["S":$P($G(^%ZIS(1,+$P(%Z,"^",8),0)),"^",2),1:IO) - . I %IS["S",IO]"" S %H=+$P(%Z,"^",8),IO("S")=%H,IO(0)=IO - . S IO("S")=$S($G(^XUTL("XQ",$J,"IOST(0)")):^("IOST(0)"),1:$G(^%ZIS(1,%H,"SUBTYPE"))) - . S:IO="" POP=1 - . Q - S %A=+$G(^%ZIS(1,%E,"SUBTYPE")),%ZISTP=0 ;%A is pointer to subtype - I %E=%H,%ZTYPE["TRM" D I 1 - . I $D(^XUTL("XQ",$J,"IOST(0)")) D ;Use home - . . S %A=+^XUTL("XQ",$J,"IOST(0)"),%Z91="",%ZISTP=1 - . . F %ZISI="IOM","IOF","IOSL","IOBS","IOXY" S %Z91=%Z91_$G(^XUTL("XQ",$J,%ZISI))_"^" - . E S %=$$LNPRTSUB^%ZISUTL I %>0 S %A=%,%Z91="" - E S %Z91=$P($G(^%ZIS(2,%A,1)),"^",1,4),$P(%Z91,"^",5)=$G(^("XY")) - ;I $D(%Z91),%Z91'?1.4"^" ;$P(%Z91,"^")]"",$P(%Z91,"^",2)]"",$P(%Z91,"^",3),$P(%Z91,"^",4)]"" - D ST^%ZIS3(%ZISTP) S:%IS["U" USIO=$P(%Z91,"^",1,4) -T2 I POP S:%IS'["T" IO="" Q - G ^%ZIS3:"^MTRM^VTRM^TRM^SPL^MT^SDP^HFS^RES^OTH^BAR^HG^IMPC^CHAN^"[("^"_%ZTYPE_"^") ;Jump to next part - S POP=1 Q - ; -HGBSY S POP=1 S:%IS'["T" IO="" K %ZISHP,%ZISHPOP Q:$D(IOP) - W:$X>38 !,?5 W *7," All devices in hunt group "_%ZISHG_" are busy!" Q - ; -OTHCPU(%1) ;%1 should be either DEVICE or HUNT GROUP - N %2,X,Y,%ZISMSG S %ZISMSG=0 - F %2="CPU","VOLUME SET" D - .I %2="VOLUME SET" S X=$P($P(%Z,"^",9),":"),Y=%ZISV - .E D GETENV^%ZOSV S X=$P($P(%Z,"^",9),":",2),Y=$P($P(Y,"^",4),":",2) - .I X=Y!(X="") Q:%1="DEVICE" D Q ;Other Vol Set/Cpu Check - ..S %ZISHG(0)=%E,%ZISHG=$P(%Z,"^") - ..I %ZISB S POP=1 - ..E S IO=" " - .I %2="VOLUME SET" S $P(%ZISCPU,":")=X - .E S $P(%ZISCPU,":",2)=X - .I %1="HUNT GROUP" K %ZISHG(0) - .I %IS["Q" S IO("Q")=1,%ZISB=0 S:%1="HUNT GROUP" IO=" " - .E I %ZISB&(%ZTYPE="TRM"&($D(%ZISHG(0))&(%IS'["D"))) S POP=1 - .E W:'$D(IOP)&'%ZISMSG *7," ["_%1_" is on another "_%2_" ('"_X_"')]",! S POP=1,%ZISMSG=1 - Q -IOPAR(%DA,%N) ;Return I/O parameters - Q $S($G(%ZIS(%N))]"":%ZIS(%N),1:$G(^%ZIS(1,%DA,%N))) - ; -SEC I %Z95]"" S %X=$G(DUZ(0)) I %X'="@" S POP=1 F %A=1:1:$L(%X) I %Z95[$E(%X,%A) S POP=0 Q - I POP,'$D(IOP),'$D(%ZISHP) W *7," [Access Prohibited]" - Q +%ZIS2 ;SFISC/AC,RWF -- DEVICE HANDLER (CHECKS) ;06/12/2002 15:41 + ;;8.0;KERNEL;**69,104,112,118,136,241**;JUL 10, 1995 +HUNT S:'$D(%ZISHP) %ZISHP=%E,%ZISHGL=0 S %E=0 + F S %ZISHGL=$O(^%ZIS(1,%ZISHG(0),"HG",%ZISHGL)) Q:%ZISHGL'>0 D Q:%E + . N %1,%2 S %1=$G(^%ZIS(1,%ZISHG(0),"HG",+%ZISHGL,0)),%2=$G(^%ZIS(1,+%1,0)) + . ;Check that HG device is on same VOL. + . I $P(%2,"^",9)=%ZISV!($P(%2,"^",9)="") S %E=+$P(^%ZIS(1,%ZISHG(0),"HG",+%ZISHGL,0),"^") + . Q + G L2:%ZISHGL>0 S %ZISHPOP=1,%E=%ZISHP + ; +L2 ;Entry point from %ZIS1 + I $D(DTOUT)!$D(DUOUT) K %ZISHP,%ZISHPOP Q +CHECK K %ZISCPU S POP=0,%Z=^%ZIS(1,%E,0),IO=$P(%Z,"^",2) + S:%IS["Q"&'$D(ZTQUEUED)&($P(%Z,"^",12)=1!$D(XQNOGO)) %ZISB=0,IO("Q")=1 ;Forced Queueing + I $P(%Z,"^",12)=2 S %IS=$TR(%IS,"Q") I $D(IO("Q")) D Q + . I '$D(IOP) W !,"Queuing NOT ALLOWED on this device" + . S POP=1 K:$D(IOP) IO("Q") Q + S %Z90=$G(^(90)),%Z95=$G(^(95)),%ZTIME=$G(^("TIME")),%ZTYPE=$G(^("TYPE")),%ZISHG=$O(^%ZIS(1,"AHG",%E,0)) + I %ZISHG,$D(^%ZIS(1,+%ZISHG,0)) S:'$D(%ZISHG(0)) %ZISHG(0)=+%ZISHG S %ZISHG=$P(^(0),"^",1) + E S %ZISHG="" + I %ZTYPE="HG" D OTHCPU("HUNT GROUP") G T:$D(%ZISHG(0))!POP + I %ZTYPE="RES" S %ZISRL=+$P(%Z1,"^",10) G T +VTRM I %ZTYPE="VTRM",'('$D(IO("Q"))&(%A=%H)) W:'$D(IOP)&'$D(%ZISHP) *7," [YOU CAN NOT SELECT A VIRTUAL TERMINAL]" S POP=1 ;Virtual Terminal Check + S:%ZTYPE="VTRM"&'$D(IO("Q"))&(%A=%H) IO=$I + ; +SLAVE I $D(IO("Q")),$P(%Z,"^",2)=0,$P(%Z,"^",8)']"" W:'$D(IOP) *7,!?10," [SLAVE device NOT set up for queuing]" S POP=1 G T +OCPU D OTHCPU("DEVICE") + ; +OOS G T:POP I %Z90,$D(DT)#2,%Z90'>DT S POP=1 ;Out Of Service Check + I $T,'$D(IOP),'$D(%ZISHP) W *7," [Out of Service]" ;I 'POP W " ..OK" S %=2,U="^" D YN^%ZIS1 G:%=0 OOS S:%'=1 POP=1 + ; +PTIME G T:POP!(IO=$I)!(IO=0) + ;Prohibitted Time Check + S %A=$P(%ZTIME,"^") I %ZISB,$L(%A) D I POP,'$D(IOP),'$D(%ZISHP) W *7," [ACCESS PROHIBITED "_%A_"]" ;AT THIS TIME]" + . N %C,%L,%H ;%C is current time, %L is lower limit, %H is upper limit + . S %C=$P($H,",",2),%C=%C\60#60+(%C\3600*100),%H=$P(%A,"-",2),%L=+%A + . I $S(%H'<%L:(%C'>%H&(%C'<%L)),1:(%C'<%L!(%C'>%H))) S POP=1 + . Q +DUZ I 'POP D SEC ;Security Check + ; +T I POP,$D(%ZISHG(0)),%IS'["D",'$D(%ZISHPOP),%ZISB G HUNT + I POP D HGBSY:$D(%ZISHPOP) ;G T2:%IS["T" + ; +TMPVAR K IO("S") S %ZISIOS=%E S:IO=0 IO=$I,IO("S")=%H + S %ZISOPAR=$$IOPAR(%E,"IOPAR") + S %ZISUPAR=$$IOPAR(%E,"IOUPAR"),%ZISTO=+$P(%ZTIME,"^",2) + I $D(IO("S")) D I POP Q + . S IO=$S(%IS["S":$P($G(^%ZIS(1,+$P(%Z,"^",8),0)),"^",2),1:IO) + . I %IS["S",IO]"" S %H=+$P(%Z,"^",8),IO("S")=%H,IO(0)=IO + . S IO("S")=$S($G(^XUTL("XQ",$J,"IOST(0)")):^("IOST(0)"),1:$G(^%ZIS(1,%H,"SUBTYPE"))) + . S:IO="" POP=1 + . Q + S %A=+$G(^%ZIS(1,%E,"SUBTYPE")),%ZISTP=0 ;%A is pointer to subtype + I %E=%H,%ZTYPE["TRM" D I 1 + . I $D(^XUTL("XQ",$J,"IOST(0)")) D ;Use home + . . S %A=+^XUTL("XQ",$J,"IOST(0)"),%Z91="",%ZISTP=1 + . . F %ZISI="IOM","IOF","IOSL","IOBS","IOXY" S %Z91=%Z91_$G(^XUTL("XQ",$J,%ZISI))_"^" + . E S %=$$LNPRTSUB^%ZISUTL I %>0 S %A=%,%Z91="" + E S %Z91=$P($G(^%ZIS(2,%A,1)),"^",1,4),$P(%Z91,"^",5)=$G(^("XY")) + ;I $D(%Z91),%Z91'?1.4"^" ;$P(%Z91,"^")]"",$P(%Z91,"^",2)]"",$P(%Z91,"^",3),$P(%Z91,"^",4)]"" + D ST^%ZIS3(%ZISTP) S:%IS["U" USIO=$P(%Z91,"^",1,4) +T2 I POP S:%IS'["T" IO="" Q + G ^%ZIS3:"^MTRM^VTRM^TRM^SPL^MT^SDP^HFS^RES^OTH^BAR^HG^IMPC^CHAN^"[("^"_%ZTYPE_"^") ;Jump to next part + S POP=1 Q + ; +HGBSY S POP=1 S:%IS'["T" IO="" K %ZISHP,%ZISHPOP Q:$D(IOP) + W:$X>38 !,?5 W *7," All devices in hunt group "_%ZISHG_" are busy!" Q + ; +OTHCPU(%1) ;%1 should be either DEVICE or HUNT GROUP + N %2,X,Y,%ZISMSG S %ZISMSG=0 + F %2="CPU","VOLUME SET" D + .I %2="VOLUME SET" S X=$P($P(%Z,"^",9),":"),Y=%ZISV + .E D GETENV^%ZOSV S X=$P($P(%Z,"^",9),":",2),Y=$P($P(Y,"^",4),":",2) + .I X=Y!(X="") Q:%1="DEVICE" D Q ;Other Vol Set/Cpu Check + ..S %ZISHG(0)=%E,%ZISHG=$P(%Z,"^") + ..I %ZISB S POP=1 + ..E S IO=" " + .I %2="VOLUME SET" S $P(%ZISCPU,":")=X + .E S $P(%ZISCPU,":",2)=X + .I %1="HUNT GROUP" K %ZISHG(0) + .I %IS["Q" S IO("Q")=1,%ZISB=0 S:%1="HUNT GROUP" IO=" " + .E I %ZISB&(%ZTYPE="TRM"&($D(%ZISHG(0))&(%IS'["D"))) S POP=1 + .E W:'$D(IOP)&'%ZISMSG *7," ["_%1_" is on another "_%2_" ('"_X_"')]",! S POP=1,%ZISMSG=1 + Q +IOPAR(%DA,%N) ;Return I/O parameters + Q $S($G(%ZIS(%N))]"":%ZIS(%N),1:$G(^%ZIS(1,%DA,%N))) + ; +SEC I %Z95]"" S %X=$G(DUZ(0)) I %X'="@" S POP=1 F %A=1:1:$L(%X) I %Z95[$E(%X,%A) S POP=0 Q + I POP,'$D(IOP),'$D(%ZISHP) W *7," [Access Prohibited]" + Q diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS3.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS3.m index 8a2b1f87..d81b97bc 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS3.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS3.m @@ -1,82 +1,71 @@ -%ZIS3 ;SFISC/AC,RWF -- DEVICE HANDLER(DEVICE TYPES & PARAMETERS) ;1/24/08 13:18 - ;;8.0;KERNEL;**18,36,69,104,391,440**;JUL 10, 1995;Build 13 - ;Per VHA Directive 2004-038, this routine should not be modified - ;Call with a Go from ^%ZIS2 - I %ZIS'["T",$G(^%ZIS(1,+%E,"POX"))]"" D XPOX^ZISX(%E) ;Pre-Open - I $D(%ZISQUIT) S POP=1 K %ZISQUIT - S %ZISCHK=1 - ;I 'POP&(%ZISB)&(%ZTYPE'="RES")&(%ZTYPE'="OTH")&(%ZTYPE'="SDP")&(IO'["::") D DEVOK - ;See if need to lock. - K %ZISLOCK - I %ZIS'["T",+$G(^%ZIS(1,+%E,"GBL")) S %ZISLOCK=$NA(^%ZIS("lock",IO)) - ; - I 'POP G TRM:(%ZTYPE["TRM"),@(%ZTYPE_"^%ZIS6") ;Jump to next part - ; -Q ;%ZIS6 Returns here - ;See if need to un-lock. - I $D(%ZISUOUT) K %ZISUOUT,%ZISHP,%ZISHPOP Q - I $D(%ZISHPOP)&$S(IO="":1,1:'$D(IO(1,IO))) D HGBSY^%ZIS2 Q - I POP S:%ZIS'["T" IO="" I $D(%ZISHG(0)),%ZIS'["D",'$D(%ZISHPOP) G HUNT^%ZIS2 - Q ;Return to %ZIS1 - ; -VTRM ;Virtual terminal type -TRM ;D OPEN^%ZIS4:'POP&(%ZISB&(%ZIS'["T")),MARGN:'POP,SETPAR:'POP ;Terminal type - D MARGN:'POP,SETPAR:'POP ;Terminal type// TEST CHANGE - I 'POP,%ZIS'["T",%ZISB=1,'$D(IOP),IO'=IO(0),'$D(IO("Q")),%ZIS["Q" D AQUE - W:'$D(IOP) ! - I '$D(IO("Q")),'POP,%ZISB,%ZIS'["T" D O^%ZIS4 - G Q -DEVOK N X,Y,X1 ;Not sure this is needed - S X=IO,X1=%ZTYPE - D DEVOK^%ZOSV I Y=-99!(Y=0)!(Y=$J) Q - I Y>0 S POP=1 W:'$D(IOP)&('$D(%ZISHG(0))!(%IS["D")) !,$C(7),"[Device Unavailable]" Q - I Y=-1 S IO="",POP=1 W:'$D(IOP)&('$D(ZISHG(0))!(%IS["D")) !,$C(7),"[Device does not Exist or Unavailable]" Q - Q - ; -MARGN ;Get the margin and page length - S %A=$P(%Y,";",1) - I %A?1A.ANP D SUBIEN(.%A,1) I $D(^%ZIS(2,%A,1)) K %Z91 D ST(1) S %Y=$P(%Y,";",2,9),%ZISMY=$P(%ZISMY,";",2,9) G MARGN - I %A>3 S $P(%Z91,"^")=$S(%A>255:255,1:+%A) - I $P(%Y,";",2) S $P(%Z91,"^",3)=+$S($P(%Y,";",2)>65530:65530,1:$P(%Y,";",2)) ;Cache fix for $Y#65535 wrap - ; -ALTP I '$D(IO("P")) Q:%A>3 G ASKMAR:%ZTYPE["TRM" Q - S %X=$F(IO("P"),"M") I %X S %A=+$E(IO("P"),%X,99),$P(%Z91,"^")=$S(%A>255:255,1:%A) - S %X=$F(IO("P"),"L") I %X S $P(%Z91,"^",3)=+$E(IO("P"),%X,99) - Q:%A>3!(%ZTYPE'["TRM") -ASKMAR I %IS["M",'$D(IOP),$S(%E=%H:+$P(%Z,"^",3),1:1),$P(%Z,"^",4) W " Right Margin: " W:$P(%Z91,"^")]"" +%Z91,"// " - E Q - D SBR^%ZIS1 I '$D(DTOUT)&'$D(DUOUT) S:%X=""&($P(%Z91,"^")]"") %X=+%Z91 G ASKMAR:%X'?1.N S $P(%Z91,"^")=$S(%X>255:255,1:%X) Q - S POP=1 I %ZISB&(%ZTYPE["TRM")&(IO'=IO(0)) C IO K IO(1,IO) Q - Q -SETPAR S:$L(%ZISOPAR)&($E(%ZISOPAR)'="(") %ZISOPAR="("_%ZISOPAR_")" - Q -AQUE ;Ask about Queueing - W ! S %=$S($D(IO("Q")):1,1:2),U="^",%ZISDTIM=60 - I $D(IO("Q")) W !,"Previously, you have selected queueing." - W !,"Do you "_$S($D(IO("Q")):"STILL ",1:"")_"want your output QUEUED" - D YN^%ZIS1 K %ZISDTIM G AQUE:%=0 Q:$D(IO("Q")) - I %=-1 S POP=1,%ZISHPOP=1,%ZISUOUT=1 C IO K IO(1,IO) Q - I %=1 S IO("Q")=1 C IO K IO(1,IO) Q - ;I %=2 K IO("Q") - Q -ST(%ZISTP) ; - S %ZISIOST(0)=%A,%ZISIOST=$P($G(^%ZIS(2,%A,0)),"^") - S:'$D(%Z91) %Z91=$P($G(^%ZIS(2,%A,1),"132^#^60^$C(8)"),"^",1,4),$P(%Z91,"^",5)=$G(^("XY")) - Q:%ZISTP -STP N %B ;%E is a pointer to the Device file - S %B=$G(^%ZIS(1,%E,91)) - S:$P(%B,"^")]"" $P(%Z91,"^")=+%B S:$P(%B,"^",3)]"" $P(%Z91,"^",3)=$P(%B,"^",3) ;S $P(%Z91,"^",5)=$G(^%ZIS(2,%ZISIOST(0),"XY")) - Q -SUBIEN(%1,%) ;Return Subtype ien. %1 is call by Ref. - N %XX,%YY - I $D(^%ZIS(2,"B",%1))>9 S %1=+$O(^%ZIS(2,"B",%1,0)) Q - I '$G(%) S X="" Q - S %XX=%1 D 2^%ZIS5 S %1=+%YY - Q -SUBTYPE(%A) ;Called from %ZISH - N %ZISIOST,%Z91 - S:$G(%A)="" %A="P-OTHER" - D SUBIEN(.%A),ST(1) - S IOM=$P(%Z91,U,1),IOF=$P(%Z91,U,2),IOSL=$P(%Z91,U,3),IOST=%ZISIOST,IOST(0)=%ZISIOST(0),IOBS="$C(8)" - S:IOST="" IOST="P-OTHER",IOST(0)=0 - Q +%ZIS3 ;SFISC/AC,RWF -- DEVICE HANDLER(DEVICE TYPES & PARAMETERS) ;10/06/2005 13:23 + ;;8.0;KERNEL;**18,36,69,104,391**;JUL 10, 1995 + I %ZIS'["T",$G(^%ZIS(1,+%E,"POX"))]"" D XPOX^ZISX(%E) + I $D(%ZISQUIT) S POP=1 K %ZISQUIT + S %ZISCHK=1 + I 'POP&(%ZISB)&(%ZTYPE'="RES")&(%ZTYPE'="OTH")&(%ZTYPE'="SDP")&(IO'["::") D DEVOK + G Q:POP + G @%ZTYPE:(%ZTYPE["TRM"),@(%ZTYPE_"^%ZIS6") ;Jump to next part + ; +Q I $D(%ZISUOUT) K %ZISUOUT,%ZISHP,%ZISHPOP Q + I $D(%ZISHPOP)&$S(IO="":1,1:'$D(IO(1,IO))) D HGBSY^%ZIS2 Q + I POP S:%IS'["T" IO="" I $D(%ZISHG(0)),%IS'["D",'$D(%ZISHPOP) G HUNT^%ZIS2 + Q +VTRM ;Virtual terminal type +TRM D OPEN^%ZIS4:'POP&(%ZISB&(%IS'["T")),MARGN:'POP,SETPAR:'POP ;Terminal type + I 'POP,%IS'["T",%ZISB=1,'$D(IOP),IO'=IO(0),'$D(IO("Q")),%IS["Q" D AQUE + W:'$D(IOP) ! I '$D(IO("Q")) D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) + G Q +DEVOK N X,Y,X1 + S X=IO,X1=%ZTYPE + D DEVOK^%ZOSV I Y=-99!(Y=0)!(Y=$J) Q + I Y>0 S POP=1 W:'$D(IOP)&('$D(%ZISHG(0))!(%IS["D")) !,*7,"[Device Unavailable]" Q + I Y=-1 S IO="",POP=1 W:'$D(IOP)&('$D(ZISHG(0))!(%IS["D")) !,*7,"[Device does not Exist or Unavailable]" Q + Q + ; +MARGN ;Get the margin and page length + S %A=$P(%Y,";",1) + I %A?1A.ANP D SUBIEN(.%A,1) I $D(^%ZIS(2,%A,1)) K %Z91 D ST(1) S %Y=$P(%Y,";",2,9),%ZISMY=$P(%ZISMY,";",2,9) G MARGN + I %A>3 S $P(%Z91,"^")=$S(%A>255:255,1:+%A) + I $P(%Y,";",2) S $P(%Z91,"^",3)=+$S($P(%Y,";",2)>65530:65530,1:$P(%Y,";",2)) ;Cache fix for $Y#65535 wrap + ; +ALTP I '$D(IO("P")) Q:%A>3 G ASKMAR:%ZTYPE["TRM" Q + S %X=$F(IO("P"),"M") I %X S %A=+$E(IO("P"),%X,99),$P(%Z91,"^")=$S(%A>255:255,1:%A) + S %X=$F(IO("P"),"L") I %X S $P(%Z91,"^",3)=+$E(IO("P"),%X,99) + Q:%A>3!(%ZTYPE'["TRM") +ASKMAR I %IS["M",'$D(IOP),$S(%E=%H:+$P(%Z,"^",3),1:1),$P(%Z,"^",4) W " Right Margin: " W:$P(%Z91,"^")]"" +%Z91,"// " + E Q + D SBR^%ZIS1 I '$D(DTOUT)&'$D(DUOUT) S:%X=""&($P(%Z91,"^")]"") %X=+%Z91 G ASKMAR:%X'?1.N S $P(%Z91,"^")=$S(%X>255:255,1:%X) Q + S POP=1 I %ZISB&(%ZTYPE["TRM")&(IO'=IO(0)) C IO K IO(1,IO) Q + Q +SETPAR S:%ZISOPAR]""&($A(%ZISOPAR)-40) %ZISOPAR="("_%ZISOPAR_")" + Q +AQUE W ! S %=$S($D(IO("Q")):1,1:2),U="^",%ZISDTIM=60 + I $D(IO("Q")) W !,"Previously, you have selected queueing." + W !,"Do you "_$S($D(IO("Q")):"STILL ",1:"")_"want your output QUEUED" + D YN^%ZIS1 K %ZISDTIM G AQUE:%=0 Q:$D(IO("Q")) + I %=-1 S POP=1,%ZISHPOP=1,%ZISUOUT=1 C IO K IO(1,IO) Q + I %=1 S IO("Q")=1 C IO K IO(1,IO) Q + Q +ST(%ZISTP) ; + S %ZISIOST(0)=%A,%ZISIOST=$P($G(^%ZIS(2,%A,0)),"^") + S:'$D(%Z91) %Z91=$P($G(^%ZIS(2,%A,1),"132^#^60^$C(8)"),"^",1,4),$P(%Z91,"^",5)=$G(^("XY")) + Q:%ZISTP +STP N %B ;%E is a pointer to the Device file + S %B=$G(^%ZIS(1,%E,91)) + S:$P(%B,"^")]"" $P(%Z91,"^")=+%B S:$P(%B,"^",3)]"" $P(%Z91,"^",3)=$P(%B,"^",3) ;S $P(%Z91,"^",5)=$G(^%ZIS(2,%ZISIOST(0),"XY")) + Q +SUBIEN(%1,%) ;Return Subtype ien. %1 is call by Ref. + N %XX,%YY + I $D(^%ZIS(2,"B",%1))>9 S %1=+$O(^%ZIS(2,"B",%1,0)) Q + I '$G(%) S X="" Q + S %XX=%1 D 2^%ZIS5 S %1=+%YY + Q +SUBTYPE(%A) ;Called from %ZISH + N %ZISIOST,%Z91 + S:$G(%A)="" %A="P-OTHER" + D SUBIEN(.%A),ST(1) + S IOM=$P(%Z91,U,1),IOF=$P(%Z91,U,2),IOSL=$P(%Z91,U,3),IOST=%ZISIOST,IOST(0)=%ZISIOST(0),IOBS="$C(8)" + S:IOST="" IOST="P-OTHER",IOST(0)=0 + Q + diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS4GTM.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS4GTM.m index b097201f..9501daf3 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS4GTM.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS4GTM.m @@ -1,109 +1,103 @@ -%ZIS4 ;ISF/RWF,DW - DEVICE HANDLER SPECIFIC CODE (GT.M for Unix/VMS) ;1/24/08 16:08 - ;;8.0;KERNEL;**275,425,440**;Jul 10, 1995;Build 13 - ;Per VHA Directive 2004-038, this routine should not be modified -OPEN ;From %ZIS3 for TRM - G OPN2:$D(IO(1,IO)) - S POP=0 D OP1 G NOPEN:'$D(IO(1,IO)) -OPN2 ; - I $D(%ZISHP),'$D(IOP) W !,*7," Routing to device "_$P(^%ZIS(1,%E,0),"^",1)_$S($D(^(1)):" "_$P(^(1),"^",1)_" ",1:"") - Q -NOPEN I %IS'["D",$D(%ZISHP)!(%ZISHG]"") S POP=1 Q - I '$D(IOP) W *7," [BUSY]" W " ... RETRY" S %=2,U="^" D YN^%ZIS1 G OPEN:%=1 - S POP=1 Q - Q - ;Why no open paraneters??? -OP1 N $ET S $ET="G OPNERR^%ZIS4" - I $D(%ZISLOCK) L +@%ZISLOCK:5 E S POP=1 Q - O IO::%ZISTO S:$T IO(1,IO)="" S:'$T POP=1 - Q -OPNERR ;Open Error - S POP=1,IO("LASTERR")=$G(IO("ERROR")),IO("ERROR")=$$EC^%ZOSV,$EC="" - Q - ; -O ;From %ZIS6 for all types. - D:%IS["L" ZIO - I $D(IO("S")),$D(^%ZIS(2,IO("S"),10)),^(10)]"" U IO(0) D X10^ZISX ;Open Printer Port -OPAR I $D(IOP),%ZTYPE="HFS",$D(%IS("HFSIO")),$D(%IS("IOPAR")),%IS("HFSIO")]"" S IO=%IS("HFSIO"),%ZISOPAR=%IS("IOPAR") - I %ZTYPE="CHAN" D TCPIP Q:POP G OXECUTE^%ZIS6 - S %A=%ZISOPAR_$S(%ZISOPAR["):":"",1:":"_%ZISTO) - N % S %(IO)="",%=$P($P($NA(%(IO)),"(",2),")") - S %A=%_$E(":",%A]"")_%A - D O1 I POP D Q - .I %ZTYPE="HFS",'$D(IOP),$G(IO("ERROR"))["file not found" W !,?5,*7,"[File Not Found]" Q - .W:'$D(IOP) !,?5,*7,"[DEVICE IS BUSY]" Q - ;S IO(1,IO)="" U IO S:'(IO=IO(0)&'$D(IO("S"))&'$D(ZTQUEUED)) $X=0,$Y=0 I %ZTYPE["TRM" U IO:(WIDTH=+%Z91) - U IO S $X=0,$Y=0 I %ZTYPE["TRM" U IO:(WIDTH=+%Z91) - I %ZISUPAR]"" S %A1=""""_IO_""":"_%ZISUPAR U @%A1 - ;U:%IS'[0 IO(0) - G OXECUTE^%ZIS6 - ; -O1 N $ES,$ET S $ET="G OPNERR^%ZIS4" - I $D(%ZISLOCK) L +@%ZISLOCK:5 E S POP=1 Q - O @%A S:'$T&(%A?.E1":".N) POP=1 S:'POP IO(1,IO)="" - S IO("ERROR")="" Q - ; - ;Need to find out how to get IP address -ZIO N %,%1 S (%,%1)=$ZIO - I $ZV["VMS",%["_TNA" D - . S (%,%1)=$ZGETDVI($I,"TT_ACCPORNAM") - . S %=$S(%["Host:":$P($P(%,"Host: ",2)," ")_":"_$P(%,"Port: ",2),1:%) S:%[" " %=$TR(%," ") - I $ZV'["VMS" D - . S (%,%1)=$ZTRNLNM("REMOTEHOST") S:$L(%) %1="Host:"_% S:'$L(%) %=$ZIO - S IO("ZIO")=% S:(%1["Host:")&'$D(IO("IP")) IO("IP")=$P(%,":") - Q - ; -TCPIP ;For TCP/IP devices, should use ^%ZISTCP - N %S - S %ZISTO=$G(%ZISTO,3) - S %A="IO:"_$S($E(%ZISOPAR)="(":"",1:"(")_%ZISOPAR_$S($E(%ZISOPAR,$L(%ZISOPAR))=")":"",1:")")_":%ZISTO:""SOCKET""" - ;U $P W !,"%A=",%A - O @%A I '$T S POP=1 Q ;D O1 ;Do the open. - U IO:(WIDTH=512:NOWRAP:EXCEPT="G OPNERR^%ZIS4") S %S=$KEY - U $P ;W !,"$KEY=",%S - Q - ; -SPOOL ;%ZDA=pointer to ^XMB(3.51, %ZFN=spool file name. - I $D(ZISDA) W:'$D(IOP) !?5,*7,"You may not Spool the printing of a Spool document" G N - I $D(DUZ)[0 W:'$D(IOP) !,"Must be a valid user." G N -R S %ZY=-1 D NEWDOC^ZISPL1 G N:%ZY'>0 - S %ZDA=+%ZY,%ZFN=$P(%ZY(0),U,2),IO("DOC")=$P(%ZY(0),U,1) G OK:$D(IO("Q")) - G:'%ZISB OK I '$P(%ZY,"^",3),$L(%ZFN) O %ZFN:(append:nowrap):2 G DOC - S %ZFN=IO_"SPOOL_no_"_%ZDA_".TMP" D SPL2 G:%ZFN']"" N S $P(^XMB(3.51,%ZDA,0),U,2)=%ZFN,^XMB(3.51,"C",%ZFN,%ZDA)="" -DOC S IO=%ZFN,IO("SPOOL")=%ZDA,^XUTL("XQ",$J,"SPOOL")=%ZDA,IOF="#" - I $D(^%ZIS(1,%ZISIOS,1)),$P(^(1),"^",8),$O(^("SPL",0)) S ^XUTL("XQ",$J,"ADSPL")=%ZISIOS,ZISPLAD=%ZISIOS -OK K %ZDA,%ZFN Q -N K %ZDA,%ZFN,IO("DOC") S POP=1 Q - ; -SPL2 ;Open for write - O %ZFN:(newversion:noreadonly:nowrap:exception="G SPL4"):2 G:$ZA<0 SPL4 S IO(1,%ZFN)="" Q - ; -SPL3 ;Open for Read - O %ZFN:(readonly:exception="G SPL4"):2 S:'$T ZISPLQ=1 G:'$T SPL4 S IO(1,%ZFN)="" Q -SPL4 W:'$D(IOP)&'$D(ZTQUEUED) !?5,*7,"Couldn't open the spool file." S %ZFN="" Q - ; -CLOSE ;Close out the spool - N %,%1,%Z1,%ZFN,%ZS,%ZDA,XS,%Y,%X - I $L(IO) C IO K IO(1,IO) - D FILE^ZISPL1 I %ZDA'>0 K ZISPLAD Q - S %ZFN=$P(%ZS,"^",2) D SPL3 Q:%ZFN']"" S %ZCR=$C(13),%Y="" - S %Z1=+$G(^XTV(8989.3,1,"SPL")),%=0 - U %ZFN F R %X#255:5 Q:$ZEOF S %2=%X D CL2 Q:%Z1<% -SPLEX C %ZFN:(DELETE) K:%ZFN]"" IO(1,%ZFN) D CLOSE^ZISPL1 K %Y,%X,%1,%ZFN Q - ; -CL2 S %=%+1 I %Z1<% S ^XMBS(3.519,XS,2,%,0)="*** INCOMPLETE REPORT -- SPOOL DOCUMENT LINE LIMIT EXCEEDED ***",$P(^XMB(3.51,%ZDA,0),"^",11)=1 Q - I %2[$C(12) S ^XMBS(3.519,XS,2,%,0)="|TOP|" Q - S ^XMBS(3.519,XS,2,%,0)=%2 Q - ; -HFS G HFS^%ZISF -REWMT(IO,IOPAR) ;Rewind Magtape - S X="REWERR^%ZIS4",@^%ZOSF("TRAP") - U IO W *5 - Q 1 -REWSDP(IO,IOPAR) ;Rewind SDP - G REW1 -REWHFS(IO,IOPAR) ;Rewind Host File. -REW1 S X="REWERR^%ZIS4",@^%ZOSF("TRAP") - U IO:(REWIND) - Q 1 -REWERR ;Error encountered - Q 0 +%ZIS4 ;ISF/RWF,DW - DEVICE HANDLER SPECIFIC CODE (GT.M for Unix/VMS) ;03/07/2007 + ;;8.0;KERNEL;**275,425**;Jul 10, 1995;Build 18 + ; +OPEN ;From %ZIS3 for TRM + G OPN2:$D(IO(1,IO)) + S POP=0 D OP1 G NOPEN:'$D(IO(1,IO)) +OPN2 ; + I $D(%ZISHP),'$D(IOP) W !,*7," Routing to device "_$P(^%ZIS(1,%E,0),"^",1)_$S($D(^(1)):" "_$P(^(1),"^",1)_" ",1:"") + Q +NOPEN I %IS'["D",$D(%ZISHP)!(%ZISHG]"") S POP=1 Q + I '$D(IOP) W *7," [BUSY]" W " ... RETRY" S %=2,U="^" D YN^%ZIS1 G OPEN:%=1 + S POP=1 Q + Q + ;Why no open paraneters??? +OP1 N $ES,$ET S $ET="G OPNERR^%ZIS4" + L:$D(%ZISLOCK) +@%ZISLOCK:60 + O IO::%ZISTO S:$T IO(1,IO)="" S:'$T POP=1 L:$D(%ZISLOCK) -@%ZISLOCK + Q +OPNERR ;Open Error + S POP=1,IO("LASTERR")=$G(IO("ERROR")),IO("ERROR")=$$EC^%ZOSV,$EC="" Q + ; +O ;From %ZIS6 for other types. + D:%IS["L" ZIO +LCKGBL ;Lock Global + I %ZTYPE="CHAN" N % S %=$G(^%ZIS(1,+%E,"GBL")) I $L(%) L @("+^"_%_":0") S:'$T POP=1 I POP W:'$D(IOP) !,?5,*7,"[DEVICE IS BUSY]" Q + I $D(IO("S")),$D(^%ZIS(2,IO("S"),10)),^(10)]"" U IO(0) D X10^ZISX +OPAR I $D(IOP),%ZTYPE="HFS",$D(%IS("HFSIO")),$D(%IS("IOPAR")),%IS("HFSIO")]"" S IO=%IS("HFSIO"),%ZISOPAR=%IS("IOPAR") + I %ZTYPE="CHAN" D TCPIP Q:POP G OXECUTE^%ZIS6 + S %A=%ZISOPAR_$S(%ZISOPAR["):":"",%ZTYPE["CHAN"&($P(%ZTIME,"^",3)="n"):"",1:":"_%ZISTO) + N % S %(IO)="",%=$P($P($NA(%(IO)),"(",2),")") + S %A=%_$E(":",%A]"")_%A + D O1 I POP D Q + .I %ZTYPE="HFS",'$D(IOP),$G(IO("ERROR"))["file not found" W !,?5,*7,"[File Not Found]" Q + .W:'$D(IOP) !,?5,*7,"[DEVICE IS BUSY]" Q + ;S IO(1,IO)="" U IO S:'(IO=IO(0)&'$D(IO("S"))&'$D(ZTQUEUED)) $X=0,$Y=0 I %ZTYPE["TRM" U IO:(WIDTH=+%Z91) + U IO S $X=0,$Y=0 I %ZTYPE["TRM" U IO:(WIDTH=+%Z91) + I %ZISUPAR]"" S %A1=""""_IO_""":"_%ZISUPAR U @%A1 + ;U:%IS'[0 IO(0) + G OXECUTE^%ZIS6 + ; +O1 N $ES,$ET S $ET="G OPNERR^%ZIS4" + L:$D(%ZISLOCK) +@%ZISLOCK:60 + O @%A S:'$T&(%A?.E1":".N) POP=1 S:'POP IO(1,IO)="" L:$D(%ZISLOCK) -@%ZISLOCK + S IO("ERROR")="" Q + ; + ;Need to find out how to get IP address +ZIO N %,%1 S (%,%1)=$ZIO + I $ZV["VMS",%["_TNA" D + . S (%,%1)=$ZGETDVI($I,"TT_ACCPORNAM") + . S %=$S(%["Host:":$P($P(%,"Host: ",2)," ")_":"_$P(%,"Port: ",2),1:%) S:%[" " %=$TR(%," ") + I $ZV'["VMS" D + . S (%,%1)=$ZTRNLNM("REMOTEHOST") S:$L(%) %1="Host:"_% S:'$L(%) %=$ZIO + S IO("ZIO")=% S:(%1["Host:")&'$D(IO("IP")) IO("IP")=$P(%,":") + Q + ; +TCPIP ;For TCP/IP devices + N %S + S %ZISTO=$G(%ZISTO,3) + S %A="IO:"_$S($E(%ZISOPAR)="(":"",1:"(")_%ZISOPAR_$S($E(%ZISOPAR,$L(%ZISOPAR))=")":"",1:")")_":%ZISTO:""SOCKET""" + ;U $P W !,"%A=",%A + O @%A I '$T S POP=1 Q ;D O1 ;Do the open. + U IO:(WIDTH=512:NOWRAP:EXCEPT="G OPNERR^%ZIS4") S %S=$KEY + U $P ;W !,"$KEY=",%S + Q + ; +SPOOL ;%ZDA=pointer to ^XMB(3.51, %ZFN=spool file name. + I $D(ZISDA) W:'$D(IOP) !?5,*7,"You may not Spool the printing of a Spool document" G N + I $D(DUZ)[0 W:'$D(IOP) !,"Must be a valid user." G N +R S %ZY=-1 D NEWDOC^ZISPL1 G N:%ZY'>0 S %ZDA=+%ZY,%ZFN=$P(%ZY(0),U,2),IO("DOC")=$P(%ZY(0),U,1) G OK:$D(IO("Q")) + G:'%ZISB OK I '$P(%ZY,"^",3),%ZFN]"" D SPL3 G N:%ZFN']"",DOC + S %ZFN=IO_"SPOOL_no_"_%ZDA_".TMP" D SPL2 G:%ZFN']"" N S $P(^XMB(3.51,%ZDA,0),U,2)=%ZFN,^XMB(3.51,"C",%ZFN,%ZDA)="" +DOC S IO=%ZFN,IO("SPOOL")=%ZDA,^XUTL("XQ",$J,"SPOOL")=%ZDA,IOF="#" + I $D(^%ZIS(1,%ZISIOS,1)),$P(^(1),"^",8),$O(^("SPL",0)) S ^XUTL("XQ",$J,"ADSPL")=%ZISIOS,ZISPLAD=%ZISIOS +OK K %ZDA,%ZFN Q +N K %ZDA,%ZFN,IO("DOC") S POP=1 Q +SPL2 O %ZFN:(NEWVERSION:WORLD=RWD) G:$ZA<0 SPL4 S IO(1,%ZFN)="" Q +SPL3 N X S X="SPL4^%ZIS4",@^%ZOSF("TRAP") + O %ZFN:READONLY:1 S:'$T ZISPLQ=1 G:$ZA<0!('$T) SPL4 S IO(1,%ZFN)="" Q +SPL4 W:'$D(IOP)&'$D(ZTQUEUED) !?5,*7,"Couldn't open the spool file." S %ZFN="" Q +CLOSE N %Z1 C:IO]"" IO K:IO]"" IO(1,IO) D FILE^ZISPL1 I %ZDA'>0 K ZISPLAD Q + S %ZFN=$P(%ZS,"^",2) D SPL3 Q:%ZFN']"" U %ZFN S %ZCR=$C(13),%Y="",X="SPLEOF^%ZIS4",@^%ZOSF("TRAP") + S %Z1=+$G(^XTV(8989.3,1,"SPL")) + F %=0:0 R %X#255:5 Q:$ZA<0 S %2=%X D CL2 G:%Z1<% SPLEX +SPLEOF I $ZE'["ENDO" Q ;Send error up +SPLEX C %ZFN:(DELETE) K:%ZFN]"" IO(1,%ZFN) D CLOSE^ZISPL1 K %Y,%X,%1,%ZFN Q + ; +CL2 S %=%+1 I %Z1<% S ^XMBS(3.519,XS,2,%,0)="*** INCOMPLETE REPORT -- SPOOL DOCUMENT LINE LIMIT EXCEEDED ***",$P(^XMB(3.51,%ZDA,0),"^",11)=1 Q + I %2[$C(12) S ^XMBS(3.519,XS,2,%,0)="|TOP|" Q + S ^XMBS(3.519,XS,2,%,0)=%2 Q + ; +HFS G HFS^%ZISF +REWMT(IO,IOPAR) ;Rewind Magtape + S X="REWERR^%ZIS4",@^%ZOSF("TRAP") + U IO W *5 + Q 1 +REWSDP(IO,IOPAR) ;Rewind SDP + G REW1 +REWHFS(IO,IOPAR) ;Rewind Host File. +REW1 S X="REWERR^%ZIS4",@^%ZOSF("TRAP") + U IO:(REWIND) + Q 1 +REWERR ;Error encountered + Q 0 diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS4ONT.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS4ONT.m index 9cd7dcb1..f8c6721f 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS4ONT.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS4ONT.m @@ -1,131 +1,127 @@ -%ZIS4 ;SFISC/RWF,AC - DEVICE HANDLER SPOOL SPECIFIC CODE (Cache) ;1/24/08 16:08 - ;;8.0;KERNEL;**34,59,69,191,278,293,440**;Jul 10, 1995;Build 13 - ;Per VHA Directive 2004-038, this routine should not be modified -OPEN ;Called for TRM devices - G OPN2:$D(IO(1,IO)) - S POP=0 D OP1 G NOPEN:'$D(IO(1,IO)) -OPN2 ; - I $D(%ZISHP),'$D(IOP) W !,$C(7)_" Routing to device "_$P(^%ZIS(1,%E,0),"^",1)_$S($D(^(1)):" "_$P(^(1),"^",1)_" ",1:"") - Q -NOPEN ; - I %IS'["D",$D(%ZISHP)!(%ZISHG]"") S POP=1 Q - I '$D(IOP) W $C(7)_" [BUSY]" W " ... RETRY" S %=2,U="^" D YN^%ZIS1 G OPEN:%=1 - S POP=1 Q - Q -OP1 N $ET S $ET="G OPNERR^%ZIS4" - I $D(%ZISLOCK) L +@%ZISLOCK:5 E S POP=1 Q - O IO::%ZISTO S:$T IO(1,IO)="" S:'$T POP=1 - Q -OPNERR S POP=1,IO("LASTERR")=$G(IO("ERROR")),IO("ERROR")=$ZE,$EC="" - Q - ; -O ;Gets called for all devices - N X,%A1 - D:%ZIS["L" ZIO - I $D(IO("S")),$D(^%ZIS(2,IO("S"),10)),^(10)]"" U IO(0) D X10^ZISX ;Open Printer port -OPAR I $D(IOP),%ZTYPE="HFS",$D(%ZIS("HFSIO")),$D(%ZIS("IOPAR")),%ZIS("HFSIO")]"" S IO=%ZIS("HFSIO"),%ZISOPAR=%ZIS("IOPAR") - S %A=$S($L(%ZISOPAR):%ZISOPAR,%ZTYPE'["TRM":"",$E(%ZISIOST,1)="C":"("_+%Z91_":""C"")",$E(%ZISIOST,1,2)="PK":"("_+%Z91_":""P"")",1:+%Z91) - S %A=%A_$S(%A["):":"",%ZTYPE["OTH"&($P(%ZTIME,"^",3)="n"):"",1:":"_%ZISTO),%A=""""_IO_""""_$E(":",%A]"")_%A - D O1 I POP W:'$D(IOP) !,?5,$C(7)_"[Device is BUSY]" Q - ;I %ZTYPE="HFS" U IO S X=IO,IO=IO_";"_$P($ZIO,";",2),IO(1,IO)="" K IO(1,X) - U IO S $X=0,$Y=0 - I $L(%ZISUPAR) S %A1=""""_IO_""":"_%ZISUPAR U @%A1 - ;U:%IS'[0 IO(0) - G OXECUTE^%ZIS6 - ; -O1 N $ET S $ET="G OPNERR^%ZIS4" - I $D(%ZISLOCK) L +@%ZISLOCK:5 E S POP=1 Q - O @%A S:'$T&(%A?.E1":".N) POP=1 S:'POP IO(1,IO)="" - S IO("ERROR")="" - Q - ;Version 3 used ip/port, Version 4 has ip:port|xx -ZIO N %,%1 S %=$ZIO,%1=$$VERSION^%ZOSV - S IO("ZIO")=$S(%1<4:$I,1:$ZIO),%1=$S(%["/":"/",1:":") - ;Drop prefix - S:%["|TNT|" %=$E(%,6,999) S:%["|TNA|" %=$E(%,6,999) - ;Get IP name or number - I '$D(IO("IP")) D - . S:$P(%,%1)["." IO("IP")=$P(%,%1) - Q - ; -SPOOL ;%ZDA=pointer to ^XMB(3.51, %ZFN=spool file Num/Name. - N %ZOS S %ZOS=$$OS^%ZOSV - I '$D(^XMB(3.51,0)) W:'$D(IOP) !?5,"The spooler files are not setup in this account." G NO - I $D(ZISDA) W:'$D(IOP) !?5,$C(7)_"You may not Spool the printing of a Spool document" G NO - I $D(DUZ)[0 W:'$D(IOP) !,"Must be a valid user." G NO - ;Get entry in Spool Doc file -R S %ZY=-1 D NEWDOC^ZISPL1:$D(DUZ)=11 G NO:%ZY'>0 S %ZDA=+%ZY,%ZFN=$P(%ZY(0),U,2),IO("DOC")=$P(%ZY(0),U,1) G OK:$D(IO("Q")) - G:'%ZISB OK I '$P(%ZY,"^",3),%ZFN]"" D SPL3 G NO:%ZFN<0,DOC - I %ZOS="NT" D G:%ZFN>255 NO - . F %ZFN=1:1:260 I '$D(^XMB(3.51,"C",%ZFN))!$D(^(%ZFN,%ZDA)) Q:%ZFN<256 W:'$D(IOP) $C(7)_" DELETE SOME OTHER DOCUMENT!" Q - . Q:%ZFN>255 D SPL2 S $P(^XMB(3.51,%ZDA,0),U,2)=%ZFN,^XMB(3.51,"C",%ZFN,%ZDA)="" - I %ZOS="VMS" D G:%ZFN=-1 NO - . S %ZFN=IO_"SPOOL_no_"_%ZDA_".TMP" D SPL2 Q:%ZFN=-1 S $P(^XMB(3.51,%ZDA,0),U,2)=%ZFN,^XMB(3.51,"C",%ZFN,%ZDA)="",IO=%ZFN -DOC S IO("SPOOL")=%ZDA,^XUTL("XQ",$J,"SPOOL")=%ZDA - I $D(^%ZIS(1,%ZISIOS,1)),$P(^(1),"^",8),$O(^("SPL",0)) S ^XUTL("XQ",$J,"ADSPL")=%ZISIOS,ZISPLAD=%ZISIOS -OK K %ZDA,%ZFN Q -NO K %ZDA,%ZFN,IO("DOC") S POP=1 Q - ; -SPL2 I %ZOS="NT" O IO:(%ZFN:0) S IO(1,IO)="",^SPOOL(0,IO("DOC"),%ZFN)="",^SPOOL(%ZFN,0)=IO("DOC")_"{"_$H Q - ;VMS - O %ZFN:("WNS"):2 G:'$T SPL4 S IO(1,%ZFN)="" Q - ; -SPL3 I %ZOS="NT" G SPL4:'$D(^SPOOL(%ZFN,2147483647)) O IO:(%ZFN:$P(^(2147483647),"{",3)):1 S:'$T ZISPLQ=1 K ^(2147483647) S IO(1,IO)="" Q - ;VMS - N $ETRAP S $ETRAP="S $EC="""" G SPL4^%ZIS4" - O %ZFN:"RV":1 S:'$T ZISPLQ=1 G:$ZA<0!('$T) SPL4 S IO(1,%ZFN)="" Q - ; -SPL4 W:'$D(IOP) !,"Spool file already open" S %ZFN=-1 Q - ; -CLOSE N %ZOS,%Z1,%ZCR,%2,%3,%X,%Y,ZTSK,%ZFN S %ZOS=$$OS^%ZOSV - I %ZOS="NT",IO=2,$D(IO(1,IO)) K IO(1,IO) C IO - I %ZOS="VMS",IO]"",$D(IO(1,IO)) U IO S %ZFN=$ZIO C IO K IO(1,IO) - ;See that ZTSK is set so we will move to the global now. - S ZTSK=$G(ZTSK,1) D FILE^ZISPL1 I %ZDA'>0 K ZISPLAD Q - G:%ZOS="VMS" CLVMS - S %ZFN=$P(%ZS,"^",2),%ZCR=$C(13),%Y="",%=0,%3=$P(^SPOOL(%ZFN,2147483647),"{",3) - S %Z1=+$G(^XTV(8989.3,1,"SPL")) - F %2=1:1:%3 Q:'$D(^SPOOL(%ZFN,%2)) S %X=^SPOOL(%ZFN,%2) D - . I %Z1<% D LIMIT S %2=%3 Q - . I %X[$C(13,12) D:$L($P(%X,$C(13))) ADD($P(%X,$C(13))) D ADD("|TOP|") Q - . D ADD($P(%X,$C(13),1)) - K ^SPOOL(%ZFN),^SPOOL(0,$P(%ZS,U,1)),%Y,%X,%1,%2,%3 D CLOSE^ZISPL1 - Q -ADD(L) S %=%+1,^XMBS(3.519,XS,2,%,0)=L Q -LIMIT D ADD("*** INCOMPLETE REPORT -- SPOOL DOCUMENT LINE LIMIT EXCEEDED ***") S $P(^XMB(3.51,%ZDA,0),"^",11)=1 - Q -CLVMS ;Close for Cache VMS - N $ES,$ET S $ET="D:$EC'[""ENDOF"" ^%ZTER,UNWIND^%ZTER S $EC="""" D SPLEX^%ZIS4,UNWIND^%ZTER" - S %ZA=$ZU(68,40,1) ;Work like DSM - ;%ZFN Could be set at the top - S %ZFN=$S($G(%ZFN)]"":%ZFN,1:$P(%ZS,"^",2)) D SPL3 Q:%ZFN']"" U %ZFN S %ZCR=$C(13),%Y="" - S %Z1=+$G(^XTV(8989.3,1,"SPL")),%=0 - F R %X#255:5 Q:$ZEOF<0 D G:%Z1<% SPLEX - . I %Z1<% D LIMIT Q - . I %X[$C(12) D Q - . . S %Y=$P(%X,$C(12)) D:$L(%Y) ADD(%Y),ADD("|TOP|") - . . S %Y=$P(%X,$C(12),2) D:$L(%Y) ADD(%Y) - . . Q - . D ADD(%X) - . Q -SPLEX C %ZFN:"D" K:%ZFN]"" IO(1,%ZFN) D CLOSE^ZISPL1 K %Y,%X,%1,%ZFN Q - ; - ; -HFS G HFS^%ZISF -REWMT(IO2,IOPAR) ;Rewind Magtape - N $ETRAP S $ET="G REWERR^%ZIS4" - U IO2 W *5 - Q 1 -REWSDP(IO2,IOPAR) ;Rewind SDP - G REW1 -REWHFS(IO2,IOPAR) ;Rewind Host File. -REW1 ;ZIS set % to the current $I so need to update % if = IO - N NIO,OP,$ETRAP - S $ET="G REWERR^%ZIS4" - C IO2 ;You do a rewind to read the file. - S OP=$S($ZV["VMS":"RV",1:"RS") - O IO2:(OP):1 S IO(1,IO2)="" - Q 1 -REWERR ;Error encountered - S IO("ERROR")=$EC,$ECODE="" - Q 0 +%ZIS4 ;SFISC/RWF,AC - DEVICE HANDLER SPOOL SPECIFIC CODE (OpenM/WNT) ;11/03/2003 17:32 + ;;8.0;KERNEL;**34,59,69,191,278,293**;Jul 10, 1995 + ; +OPEN G OPN2:$D(IO(1,IO)) + S POP=0 D OP1 G NOPEN:'$D(IO(1,IO)) +OPN2 I $D(%ZISHP),'$D(IOP) W !,$C(7)_" Routing to device "_$P(^%ZIS(1,%E,0),"^",1)_$S($D(^(1)):" "_$P(^(1),"^",1)_" ",1:"") + Q +NOPEN I %IS'["D",$D(%ZISHP)!(%ZISHG]"") S POP=1 Q + I '$D(IOP) W $C(7)_" [BUSY]" W " ... RETRY" S %=2,U="^" D YN^%ZIS1 G OPEN:%=1 + K:%E'=%H ^XUTL("ZISPARAM",IO) + S POP=1 Q + Q +OP1 N X S X="OPNERR^%ZIS4",@^%ZOSF("TRAP") + L:$D(%ZISLOCK) +@%ZISLOCK:60 + O IO::%ZISTO S:$T IO(1,IO)="" S:'$T POP=1 L:$D(%ZISLOCK) -@%ZISLOCK + Q +OPNERR S POP=1,IO("LASTERR")=$G(IO("ERROR")),IO("ERROR")=$ZE,$EC="" Q + ; +O N X D:%IS["L" ZIO + I $D(IO("S")),$D(^%ZIS(2,IO("S"),10)),^(10)]"" U IO(0) D X10^ZISX ;Open Printer port +OPAR I $D(IOP),%ZTYPE="HFS",$D(%IS("HFSIO")),$D(%IS("IOPAR")),%IS("HFSIO")]"" S IO=%IS("HFSIO"),%ZISOPAR=%IS("IOPAR") + S %A=$S(%ZISOPAR]"":%ZISOPAR,%ZTYPE'["TRM":"",%ZISIOST?1"C".E:"("_+%Z91_":""C"")",%ZISIOST?1"PK".E:"("_+%Z91_":""P"")",1:+%Z91) + S %A=%A_$S(%A["):":"",%ZTYPE["OTH"&($P(%ZTIME,"^",3)="n"):"",1:":"_%ZISTO),%A=""""_IO_""""_$E(":",%A]"")_%A + D O1 I POP W:'$D(IOP) !,?5,$C(7)_"[Device is BUSY]" Q + ;I %ZTYPE="HFS" U IO S X=IO,IO=IO_";"_$P($ZIO,";",2),IO(1,IO)="" K IO(1,X) + U IO S $X=0,$Y=0 + I %ZISUPAR]"" S %A1=""""_IO_""":"_%ZISUPAR U @%A1 + ;U:%IS'[0 IO(0) + G OXECUTE^%ZIS6 + ; +O1 N X S X="OPNERR^%ZIS4",@^%ZOSF("TRAP") + L:$D(%ZISLOCK) +@%ZISLOCK:60 + O @%A S:'$T&(%A?.E1":".N) POP=1 S:'POP IO(1,IO)="" + L:$D(%ZISLOCK) -@%ZISLOCK + S IO("ERROR")="" + Q + ;Version 3 used ip/port, Version 4 has ip:port|xx +ZIO N %,%1 S %=$ZIO,%1=$$VERSION^%ZOSV + S IO("ZIO")=$S(%1<4:$I,1:$ZIO),%1=$S(%["/":"/",1:":") + ;Drop prefix + S:%["|TNT|" %=$E(%,6,999) S:%["|TNA|" %=$E(%,6,999) + ;Get IP name or number + I '$D(IO("IP")) D + . S:$P(%,%1)["." IO("IP")=$P(%,%1) + Q + ; +SPOOL ;%ZDA=pointer to ^XMB(3.51, %ZFN=spool file Num/Name. + N %ZOS S %ZOS=$$OS^%ZOSV + I '$D(^XMB(3.51,0)) W:'$D(IOP) !?5,"The spooler files are not setup in this account." G NO + I $D(ZISDA) W:'$D(IOP) !?5,$C(7)_"You may not Spool the printing of a Spool document" G NO + I $D(DUZ)[0 W:'$D(IOP) !,"Must be a valid user." G NO + ;Get entry in Spool Doc file +R S %ZY=-1 D NEWDOC^ZISPL1:$D(DUZ)=11 G NO:%ZY'>0 S %ZDA=+%ZY,%ZFN=$P(%ZY(0),U,2),IO("DOC")=$P(%ZY(0),U,1) G OK:$D(IO("Q")) + G:'%ZISB OK I '$P(%ZY,"^",3),%ZFN]"" D SPL3 G NO:%ZFN<0,DOC + I %ZOS="NT" D G:%ZFN>255 NO + . F %ZFN=1:1:260 I '$D(^XMB(3.51,"C",%ZFN))!$D(^(%ZFN,%ZDA)) Q:%ZFN<256 W:'$D(IOP) $C(7)_" DELETE SOME OTHER DOCUMENT!" Q + . Q:%ZFN>255 D SPL2 S $P(^XMB(3.51,%ZDA,0),U,2)=%ZFN,^XMB(3.51,"C",%ZFN,%ZDA)="" + I %ZOS="VMS" D G:%ZFN=-1 NO + . S %ZFN=IO_"SPOOL_no_"_%ZDA_".TMP" D SPL2 Q:%ZFN=-1 S $P(^XMB(3.51,%ZDA,0),U,2)=%ZFN,^XMB(3.51,"C",%ZFN,%ZDA)="",IO=%ZFN +DOC S IO("SPOOL")=%ZDA,^XUTL("XQ",$J,"SPOOL")=%ZDA + I $D(^%ZIS(1,%ZISIOS,1)),$P(^(1),"^",8),$O(^("SPL",0)) S ^XUTL("XQ",$J,"ADSPL")=%ZISIOS,ZISPLAD=%ZISIOS +OK K %ZDA,%ZFN Q +NO K %ZDA,%ZFN,IO("DOC") S POP=1 Q + ; +SPL2 I %ZOS="NT" O IO:(%ZFN:0) S IO(1,IO)="",^SPOOL(0,IO("DOC"),%ZFN)="",^SPOOL(%ZFN,0)=IO("DOC")_"{"_$H Q + ;VMS + O %ZFN:("WNS"):2 G:'$T SPL4 S IO(1,%ZFN)="" Q + ; +SPL3 I %ZOS="NT" G SPL4:'$D(^SPOOL(%ZFN,2147483647)) O IO:(%ZFN:$P(^(2147483647),"{",3)):1 S:'$T ZISPLQ=1 K ^(2147483647) S IO(1,IO)="" Q + ;VMS + N $ETRAP S $ETRAP="S $EC="""" G SPL4^%ZIS4" + O %ZFN:"RV":1 S:'$T ZISPLQ=1 G:$ZA<0!('$T) SPL4 S IO(1,%ZFN)="" Q + ; +SPL4 W:'$D(IOP) !,"Spool file already open" S %ZFN=-1 Q + ; +CLOSE N %ZOS,%Z1,%ZCR,%2,%3,%X,%Y,ZTSK,%ZFN S %ZOS=$$OS^%ZOSV + I %ZOS="NT",IO=2,$D(IO(1,IO)) K IO(1,IO) C IO + I %ZOS="VMS",IO]"",$D(IO(1,IO)) U IO S %ZFN=$ZIO C IO K IO(1,IO) + ;See that ZTSK is set so we will move to the global now. + S ZTSK=$G(ZTSK,1) D FILE^ZISPL1 I %ZDA'>0 K ZISPLAD Q + G:%ZOS="VMS" CLVMS + S %ZFN=$P(%ZS,"^",2),%ZCR=$C(13),%Y="",%=0,%3=$P(^SPOOL(%ZFN,2147483647),"{",3) + S %Z1=+$G(^XTV(8989.3,1,"SPL")) + F %2=1:1:%3 Q:'$D(^SPOOL(%ZFN,%2)) S %X=^SPOOL(%ZFN,%2) D + . I %Z1<% D LIMIT S %2=%3 Q + . I %X[$C(13,12) D:$L($P(%X,$C(13))) ADD($P(%X,$C(13))) D ADD("|TOP|") Q + . D ADD($P(%X,$C(13),1)) + K ^SPOOL(%ZFN),^SPOOL(0,$P(%ZS,U,1)),%Y,%X,%1,%2,%3 D CLOSE^ZISPL1 + Q +ADD(L) S %=%+1,^XMBS(3.519,XS,2,%,0)=L Q +LIMIT D ADD("*** INCOMPLETE REPORT -- SPOOL DOCUMENT LINE LIMIT EXCEEDED ***") S $P(^XMB(3.51,%ZDA,0),"^",11)=1 + Q +CLVMS ;Close for Cache VMS + N $ES,$ET S $ET="D:$EC'[""ENDOF"" ^%ZTER,UNWIND^%ZTER S $EC="""" D SPLEX^%ZIS4,UNWIND^%ZTER" + S %ZA=$ZU(68,40,1) ;Work like DSM + ;%ZFN Could be set at the top + S %ZFN=$S($G(%ZFN)]"":%ZFN,1:$P(%ZS,"^",2)) D SPL3 Q:%ZFN']"" U %ZFN S %ZCR=$C(13),%Y="" + S %Z1=+$G(^XTV(8989.3,1,"SPL")),%=0 + F R %X#255:5 Q:$ZEOF<0 D G:%Z1<% SPLEX + . I %Z1<% D LIMIT Q + . I %X[$C(12) D Q + . . S %Y=$P(%X,$C(12)) D:$L(%Y) ADD(%Y),ADD("|TOP|") + . . S %Y=$P(%X,$C(12),2) D:$L(%Y) ADD(%Y) + . . Q + . D ADD(%X) + . Q +SPLEX C %ZFN:"D" K:%ZFN]"" IO(1,%ZFN) D CLOSE^ZISPL1 K %Y,%X,%1,%ZFN Q + ; + ; +HFS G HFS^%ZISF +REWMT(IO2,IOPAR) ;Rewind Magtape + N $ETRAP S $ET="G REWERR^%ZIS4" + U IO2 W *5 + Q 1 +REWSDP(IO2,IOPAR) ;Rewind SDP + G REW1 +REWHFS(IO2,IOPAR) ;Rewind Host File. +REW1 ;ZIS set % to the current $I so need to update % if = IO + N NIO,OP,$ETRAP + S $ET="G REWERR^%ZIS4" + C IO2 ;You do a rewind to read the file. + S OP=$S($ZV["VMS":"RV",1:"RS") + O IO2:(OP):1 S IO(1,IO2)="" + Q 1 +REWERR ;Error encountered + S IO("ERROR")=$EC,$ECODE="" + Q 0 diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS6.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS6.m index b72b6522..347258fe 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS6.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS6.m @@ -1,101 +1,88 @@ -%ZIS6 ;SFISC/AC - DEVICE HANDLER -- RESOURCES ;1/24/08 16:09 - ;;8.0;KERNEL;**24,49,69,118,127,136,440**;JUL 10, 1995;Build 13 - ;Per VHA Directive 2004-038, this routine should not be modified - ;Expect that IO is current device -OXECUTE ;Open Execute - I $D(^%ZIS(2,%ZISIOST(0),2))=1 S %Y=^(2) D 2 -ANSBAK ;Answer Back - I $D(^%ZIS(2,%ZISIOST(0),102)) S %Y=^(102) D 2 E S POP=1 D:'$D(IOP) SAY($C(7)_"[NOT ON LINE]") C:%ZISB IO K IO(1,IO) G QUIT - I $D(%ZISMTR) X ^%ZOSF("MAGTAPE") U IO W:$D(%MT("REW")) @%MT("REW") U IO(0) K %MT - G QUIT:'$D(IO("P")) - I $F(IO("P"),"B"),$D(^%ZIS(2,%ZISIOST(0),7)) S %Y=$P(^(7),"^",1) I %Y]"" W @%Y - S %Y=$F(IO("P"),"P") G QLTY:'%Y S %Y=+$E(IO("P"),%Y,99),%X=$S(%Y=16:12.1,%Y=10!(%Y=12):5,1:"") G QLTY:'%X - S %Y=$S($D(^%ZIS(2,%ZISIOST(0),%X)):$P(^(%X),"^",$S(%Y=12:2,1:1)),1:"") - I %Y]"" W @%Y -QLTY S %Y=$F(IO("P"),"Q") Q:'%Y S %Y=+$E(IO("P"),%Y,99),%X=$S(%Y<0!(%Y>2):0,1:%Y+1) - I %X S %Y=$S($D(^%ZIS(2,%ZISIOST(0),12.2)):$P(^(12.2),"^",%X),1:"") I %Y]"" W @%Y -QUIT U:%IS'[0 IO(0) - Q -2 Q:%Y="" I %IS'[0,$D(^%ZIS(1,+%H,"TYPE")),^("TYPE")["TRM" D OH Q:POP - S %X=$T U IO D %Y^ZISX ;Q:'%X U IO(0) - Q -OH Q:$S($G(IO(0))]"":$D(IO(1,IO(0))),1:0) - N X S X="OPNERR^%ZIS4",@^%ZOSF("TRAP") - O IO(0)::0 S IO(1,IO(0))="" Q ;See that HOME DEVICE is open. - ; -SAY(%SAY) ; - Q:%IS[0 U IO(0) W %SAY U IO - Q -RES1 ;Allocate a resource slot, Release in %ZISC. - N A,L,X,%ZISD0 - S %ZISD0=$O(^%ZISL(3.54,"B",IO,0)) - I '%ZISD0 S %ZISD0=$$RADD(IO) ;New one - L +^%ZISL(3.54,%ZISD0,0):2 I '$T S POP=1 W:'$D(IOP) *7," [NOT Available]" G RESX -RES2 S X=$P(^%ZISL(3.54,%ZISD0,0),"^",2) - I X<1 S POP=1 W:'$D(IOP) *7," [NOT Available]" G RESX - S X=$S(X>0:X-1,1:0),$P(^%ZISL(3.54,%ZISD0,0),"^",2)=X - ; -R1 ;Grab a slot - S IO(1,IO)="RES",A=$G(^%ZISL(3.54,%ZISD0,1,0),"^3.542^^") - F L=1:1:%ZISRL I '$D(^%ZISL(3.54,%ZISD0,1,L,0)) Q - I '$T K IO(1,IO) G RES2 ;No free slots - S ^%ZISL(3.54,%ZISD0,1,L,0)=L_"^"_%ZISV_"^"_$J_"^"_$G(ZTSK)_"^"_$H,^%ZISL(3.54,"AJ",$J,%ZISD0,L)="",^%ZISL(3.54,%ZISD0,1,"B",L,L)="" - S $P(A,"^",3,4)=L_U_($P(A,U,4)+1),^%ZISL(3.54,%ZISD0,1,0)=A -RESX L -^%ZISL(3.54,%ZISD0,0) Q - ; -RADD(X) ;Add Resource - N %1,%2 - S %1=$G(^%ZISL(3.54,0),"RESOURCE^3.54^^"),%2=$P(%1,U,3) - F %2=%2:1 Q:'$D(^%ZISL(3.54,%2,0)) - S $P(^%ZISL(3.54,0),U,3,4)=%2_U_($P(%1,U,4)+1),^%ZISL(3.54,%2,0)=X_"^"_$G(%ZISRL,1),^%ZISL(3.54,"B",X,%2)="" - Q %2 - ; -RESOK ;DEVOK check for RES devices, for all OS's. - N %ZISD0,%ZISD1 - S Y=0,%ZISD0=$O(^%ZISL(3.54,"B",X,0)) - I '%ZISD0 S Y=-1,%ZISD0=$O(^%ZIS(1,"C",X,0)) Q:'%ZISD0 Q:'$D(^%ZIS(1,+%ZISD0,0)) Q:$P(^(0),"^")'=X Q:'$D(^("TYPE")) Q:^("TYPE")'="RES" S Y=0 Q - S X1=$G(^%ZISL(3.54,+%ZISD0,0)) - I $P(X1,"^",2)&(X=$P(X1,"^")) S Y=0 Q - S Y=999 F %ZISD1=0:0 S %ZISD1=$O(^%ZISL(3.54,%ZISD0,1,%ZISD1)) Q:%ZISD1'>0 I $D(^(%ZISD1,0)) S Y=$P(^(0),"^",3) Q - Q - ; -Q G Q^%ZIS3 -HG ; - Q -SPL ;Spool type - N %E,%Z D MARGN^%ZIS3 W:'$D(IOP) ! D SPOOL^%ZIS4:%IS'["T" - G Q -MT D MARGN^%ZIS3,ASKPAR,AMTREW:'POP&'$D(IOP)&%ZISB W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) ;Magtape type - G Q -SDP ;Sequential disk processor type - D MARGN^%ZIS3,ASKPAR W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) - G Q -HFS ;Host File Server type - D MARGN^%ZIS3,HFS^%ZIS4 W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) - G Q -RES ;Resources - G Q:%IS["T" N X,X1 I %IS'["R"!'$D(IOP) S POP=1 W:'$D(IOP) *7," [NOT AVAILABLE]" Q - G Q:$D(IO(1,IO)) I %IS["T" S X=IO,X1="RES" D DEVOK^%ZIS3 S:Y POP=1 G Q:POP - D:%ZISB RES1 G Q -CHAN ;Network Channel type devices -- DecNet or TCP/IP devices. - I IO="SYS$NET",$I="SYS$INPUT:;" S IO(0)=IO U IO ;DECNET Server Device - D MARGN^%ZIS3:'POP,ASKPAR:'POP W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) - G Q -IMPC ;Imaging Work Station -BAR ;Bar Code -OTH ;Other Device type - D MARGN^%ZIS3:'POP,ASKPAR:'POP W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) - G Q - ; -ASKPAR ;Ask Parameters - G SETPAR^%ZIS3:$D(IOP),SETPAR^%ZIS3:'$P(^%ZIS(1,%E,0),"^",4) W " ADDRESS/PARAMETERS: " W:%ZISOPAR]"" %ZISOPAR_"// " D SBR^%ZIS1 D MSG1:%X="?" G ASKPAR:%X="?" S:%X]"" %ZISOPAR=%X I $D(DTOUT)!$D(DUOUT) S POP=1 - I POP,%ZISB&(%ZTYPE["TRM") C IO K IO(1,IO) Q - Q:POP G SETPAR^%ZIS3 - ; -AMTREW ;Mag Tape Rewind - I %ZISB,%ZTYPE="MT",'$D(IOP) W " REWIND" S %=2,U="^",%ZISDTIM=60 D YN^%ZIS1 K %ZISDTIM G AMTREW:%=0 I %=-1 S POP=1 Q - S:%=1 %ZISMTR=1 - Q -MSG1 W !?5,"Enter the desired parameters needed to open the selected device.",!?25 - Q - ; +%ZIS6 ;SFISC/AC - DEVICE HANDLER -- RESOURCES ;02/04/2000 08:14 + ;;8.0;KERNEL;**24,49,69,118,127,136**;JUL 10, 1995 + ;Expect that IO is current device +OXECUTE I $D(^%ZIS(2,%ZISIOST(0),2))=1 S %Y=^(2) D 2 +ANSBAK I $D(^%ZIS(2,%ZISIOST(0),102)) S %Y=^(102) D 2 E S POP=1 D:'$D(IOP) SAY($C(7)_"[NOT ON LINE]") C:%ZISB IO K IO(1,IO) G QUIT + I $D(%ZISMTR) X ^%ZOSF("MAGTAPE") U IO W:$D(%MT("REW")) @%MT("REW") U IO(0) K %MT + G QUIT:'$D(IO("P")) + I $F(IO("P"),"B"),$D(^%ZIS(2,%ZISIOST(0),7)) S %Y=$P(^(7),"^",1) I %Y]"" W @%Y + S %Y=$F(IO("P"),"P") G QLTY:'%Y S %Y=+$E(IO("P"),%Y,99),%X=$S(%Y=16:12.1,%Y=10!(%Y=12):5,1:"") G QLTY:'%X + S %Y=$S($D(^%ZIS(2,%ZISIOST(0),%X)):$P(^(%X),"^",$S(%Y=12:2,1:1)),1:"") + I %Y]"" W @%Y +QLTY S %Y=$F(IO("P"),"Q") Q:'%Y S %Y=+$E(IO("P"),%Y,99),%X=$S(%Y<0!(%Y>2):0,1:%Y+1) + I %X S %Y=$S($D(^%ZIS(2,%ZISIOST(0),12.2)):$P(^(12.2),"^",%X),1:"") I %Y]"" W @%Y +QUIT U:%IS'[0 IO(0) + Q +2 Q:%Y="" I %IS'[0,$D(^%ZIS(1,+%H,"TYPE")),^("TYPE")["TRM" D OH Q:POP + S %X=$T U IO D %Y^ZISX ;Q:'%X U IO(0) + Q +OH Q:$S($G(IO(0))]"":$D(IO(1,IO(0))),1:0) + N X S X="OPNERR^%ZIS4",@^%ZOSF("TRAP") + O IO(0)::0 S IO(1,IO(0))="" Q ;See that HOME DEVICE is open. + ; +SAY(%SAY) ; + Q:%IS[0 U IO(0) W %SAY U IO + Q +RES1 ;Allocate a resource slot, Release in %ZISC. + N A,L,X,%ZISD0 + S %ZISD0=$O(^%ZISL(3.54,"B",IO,0)) + I '%ZISD0 S %ZISD0=$$RADD(IO) ;New one + L +^%ZISL(3.54,%ZISD0,0):2 I '$T S POP=1 W:'$D(IOP) *7," [NOT Available]" G RESX +RES2 S X=$P(^%ZISL(3.54,%ZISD0,0),"^",2) + I X<1 S POP=1 W:'$D(IOP) *7," [NOT Available]" G RESX + S X=$S(X>0:X-1,1:0),$P(^%ZISL(3.54,%ZISD0,0),"^",2)=X + ; +R1 ;Grab a slot + S IO(1,IO)="RES",A=$G(^%ZISL(3.54,%ZISD0,1,0),"^3.542^^") + F L=1:1:%ZISRL I '$D(^%ZISL(3.54,%ZISD0,1,L,0)) Q + I '$T K IO(1,IO) G RES2 ;No free slots + S ^%ZISL(3.54,%ZISD0,1,L,0)=L_"^"_%ZISV_"^"_$J_"^"_$G(ZTSK)_"^"_$H,^%ZISL(3.54,"AJ",$J,%ZISD0,L)="",^%ZISL(3.54,%ZISD0,1,"B",L,L)="" + S $P(A,"^",3,4)=L_U_($P(A,U,4)+1),^%ZISL(3.54,%ZISD0,1,0)=A +RESX L -^%ZISL(3.54,%ZISD0,0) Q + ; +RADD(X) ;Add Resource + N %1,%2 + S %1=$G(^%ZISL(3.54,0),"RESOURCE^3.54^^"),%2=$P(%1,U,3) + F %2=%2:1 Q:'$D(^%ZISL(3.54,%2,0)) + S $P(^%ZISL(3.54,0),U,3,4)=%2_U_($P(%1,U,4)+1),^%ZISL(3.54,%2,0)=X_"^"_$G(%ZISRL,1),^%ZISL(3.54,"B",X,%2)="" + Q %2 + ; +RESOK ;DEVOK check for RES devices, for all OS's. + N %ZISD0,%ZISD1 + S Y=0,%ZISD0=$O(^%ZISL(3.54,"B",X,0)) + I '%ZISD0 S Y=-1,%ZISD0=$O(^%ZIS(1,"C",X,0)) Q:'%ZISD0 Q:'$D(^%ZIS(1,+%ZISD0,0)) Q:$P(^(0),"^")'=X Q:'$D(^("TYPE")) Q:^("TYPE")'="RES" S Y=0 Q + S X1=$G(^%ZISL(3.54,+%ZISD0,0)) + I $P(X1,"^",2)&(X=$P(X1,"^")) S Y=0 Q + S Y=999 F %ZISD1=0:0 S %ZISD1=$O(^%ZISL(3.54,%ZISD0,1,%ZISD1)) Q:%ZISD1'>0 I $D(^(%ZISD1,0)) S Y=$P(^(0),"^",3) Q + Q + ; +Q G Q^%ZIS3 +HG ; + Q +SPL N %E,%Z D MARGN^%ZIS3 W:'$D(IOP) ! D SPOOL^%ZIS4:%IS'["T" ;Spool type + G Q +MT D MARGN^%ZIS3,ASKPAR,AMTREW:'POP&'$D(IOP)&%ZISB W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) ;Magtape type + G Q +SDP D MARGN^%ZIS3,ASKPAR W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) ;Sequential disk processor type + G Q +HFS D MARGN^%ZIS3,HFS^%ZIS4 W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) ;Host File Server type + G Q +RES G Q:%IS["T" N X,X1 I %IS'["R"!'$D(IOP) S POP=1 W:'$D(IOP) *7," [NOT AVAILABLE]" Q ;Resources + G Q:$D(IO(1,IO)) I %IS["T" S X=IO,X1="RES" D DEVOK^%ZIS3 S:Y POP=1 G Q:POP + D:%ZISB RES1 G Q +CHAN ;Network Channel type devices -- DecNet or TCP/IP devices. + I IO="SYS$NET",$I="SYS$INPUT:;" S IO(0)=IO U IO ;DECNET Server Device + D MARGN^%ZIS3:'POP,ASKPAR:'POP W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) + G Q +IMPC ;Imaging Work Station +BAR ;Bar Code +OTH D MARGN^%ZIS3:'POP,ASKPAR:'POP W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) ;Other Device type + G Q + ; +ASKPAR G SETPAR^%ZIS3:$D(IOP),SETPAR^%ZIS3:'$P(^%ZIS(1,%E,0),"^",4) W " ADDRESS/PARAMETERS: " W:%ZISOPAR]"" %ZISOPAR_"// " D SBR^%ZIS1 D MSG1:%X="?" G ASKPAR:%X="?" S:%X]"" %ZISOPAR=%X I $D(DTOUT)!$D(DUOUT) S POP=1 + I POP,%ZISB&(%ZTYPE["TRM") C IO K IO(1,IO) Q + Q:POP G SETPAR^%ZIS3 +AMTREW I %ZISB,%ZTYPE="MT",'$D(IOP) W " REWIND" S %=2,U="^",%ZISDTIM=60 D YN^%ZIS1 K %ZISDTIM G AMTREW:%=0 I %=-1 S POP=1 Q + S:%=1 %ZISMTR=1 Q +MSG1 W !?5,"Enter the desired parameters needed to open the selected device.",!?25 Q + ; diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZISC.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZISC.m index cf0a43b7..5afccd1c 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZISC.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZISC.m @@ -1,130 +1,131 @@ -%ZISC ;SFISC/GFT,AC,MUS - CLOSE LOGIC FOR DEVICES ;1/24/08 16:09 - ;;8.0;KERNEL;**24,36,49,69,199,216,275,409,440**;JUL 10, 1995;Build 13 - ;Per VHA Directive 2004-038, this routine should not be modified -C0 ; - N %,%E,%H,%ZISI,%ZISOS,%ZISX,%ZISV - ;Clear IO var we will use for reporting - K IO("ERROR"),IO("LASTERR"),IO("CLOSE") - ;Protect ourself from calls with incomplete setup. - S:$D(IO)[0 IO=$I S:'$D(IO(0)) IO(0)=$P - S U="^",%ZISOS=$G(^%ZOSF("OS")),%ZISV=$G(^("VOL")) - ;S %=$S(+$G(IOS):IOS,$L($G(ION)):ION,1:IO) - S %=$S($L($G(ION)):ION,1:IO) ;p409 - I (%="")!(IO="") G SETIO:IO(0)]"",END - I $G(IOT)="RES" D RES G SETIO ;Handle a resource device - ; - ;Define subtype info if not already defined. - D SUBTYPE - ; - ;perform close execute - I $G(IOST(0))>0 D - . I $G(^%ZIS(2,+IOST(0),3))]"",$D(IO(1,IO)) D - . . U IO S:$X $X=1 D X3^ZISX:'$D(IO("T")) - ; - ;Incase the Close execute changed IO, Open IO("HOME") or NULL. - I '$L($G(IO)) D Q - . S IOP=$S($L($G(IO("HOME"))):"`"_(+IO("HOME")),1:"NULL") D ^%ZIS - . Q - ; - ;Perform the following if the device is open. - I $D(IO(1,IO)) D - . I $G(IO("P"))["B" D ;Return to normal intensity - . . S %=$P($G(^%ZIS(2,+IOST(0),7)),"^",3) I %]"" W @% - . I $G(IO("P"))["P" D ;Return to default pitch - . . S %=$G(^%ZIS(2,+IOST(0),12.11)) I %]"" W @% - . ; - . W:$$FF @IOF ;Issue form feed at close - . I $$CLOSPP D X11^ZISX:'$D(IO("T")) K IO("S") ;Close printer port - . Q - ; - ;Don't use IOCPU as we now use IO(1,IO) - I (IO'=IO(0)!$D(IO("C"))),$D(IO(1,IO)) D - . U:$S($D(ZTQUEUED):0,'$L($G(IO(0))):0,$D(IO(1,IO(0)))#2:1,1:0) IO(0) - . C IO K IO(1,IO) S IO("CLOSE")=IO ;close device - ;Unlock global used to control access. - S %=$G(^XUTL("XQ",$J,"lock",+$G(IOS))) I $L(%) L -@% K ^XUTL("XQ",$J,"lock",IOS) - ; - I $D(IO("SPOOL")) D CLOSE^%ZIS4 ;Special close for spool device - ; -SETIO ; - ;See if old device has PCX code - I $G(IOS),$G(^%ZIS(1,+IOS,"PCX"))]"" S %ZISPCX=^("PCX") - ;Setup the IO(0) device, should be the home device - S IO=IO(0),(IOPAR,IOUPAR)="" K IO("T") D CIOS(IO(0)) - I 'IOS S IOT="TRM" G END - S ION=$P(^%ZIS(1,IOS,0),"^",1),IOT=$G(^("TYPE")),IOST(0)=$S(IOT["TRM"&($D(^XUTL("XQ",$J,"IOST(0)"))):^("IOST(0)"),1:$G(^%ZIS(1,IOS,"SUBTYPE"))) - I IOT["TRM",$D(^XUTL("XQ",$J,"IO")) D HOME^%ZIS G END - S %="Y" - I IOST(0),$D(^%ZIS(2,IOST(0),1)) S %=^(1),IOM=+%,IOF=$P(%,"^",2),IOSL=$P(%,"^",3),IOBS=$P(%,"^",4) - I $D(^%ZIS(1,IOS,91)) S %=^%ZIS(1,IOS,91) S:+% IOM=+% S:$P(%,"^",3) IOSL=$P(%,"^",3) - ;Don't know the subtype so set some defaults - I %="Y" S IOM=80,IOSL=24,IOF="#",IOST="C-OTHER",IOBS="$C(8)" -S1 S:IOST(0) IOST=$P($G(^%ZIS(2,+IOST(0),0)),"^"),IOXY=$G(^("XY")) - I '$D(ZTQUEUED),'$D(IO("C")),IOT["TRM" D RM:$D(IO(1,IO)) - ;With home device set, Do Post-close execute code of Device closed. -END I '$D(IO("T")),$G(%ZISPCX)]"" S %Y=%ZISPCX D %Y^ZISX - ;See that any extra IO variables are cleaned up - K IO("P"),IO("DOC"),IO("HFSIO"),IO("SPOOL"),IOC,IONOFF - ;IOCPU should not be changed. - Q - ; -SUBTYPE ;Find a subtype - N %S - S IOST=$G(IOST),IOST(0)=+$G(IOST(0)) - I $L(IOST)&$L(IOST(0)) Q ;Have a subtype - S %S=$G(^%ZIS(2,+IOST(0),0)) I $L(%S) S IOST=$P(%S,U) Q - I $L(IOST) S %S=$O(^%ZIS(2,"B",$G(IOST,"X"),0)) I %S>0 S IOST(0)=+%S Q - S IOST="",IOST(0)=0 D CIOS($I) Q:IOS'>0 - S IOST(0)=$G(^%ZIS(1,+IOS,"SUBTYPE")),IOST=$P($G(^%ZIS(2,+IOST(0),0)),"^") - Q - ; -CIOS(%I) ;Find a value for IOS (IEN into device file) - N %ZISVT - I $D(^XUTL("XQ",$J,"IOS")) S IOS=+^("IOS") Q - I $D(%ZISV) S %ZISVT=%I D VTLKUP^%ZIS S IOS=+%E - E S IOS=+$O(^%ZIS(1,"C",%I,0)) - Q:$G(IOS)>0 - S %ZISVT=%I D VIRTUAL^%ZIS - I $D(%ZISVT) S %H=%E I %ZISVT]"",%H>0,$D(^%ZIS(1,%H,0)),$D(^("TYPE")),^("TYPE")="VTRM" S IOS=%H - Q - ; -RM N X S X=+IOM X ^%ZOSF("RM") - Q - ; -RES ;Close resource device. - Q:'$D(IO(1,IO))&'$D(^%ZISL(3.54,"AJ",$J)) - N %ZISJOB,%X,%Y,%ZISD0,%ZISD1,%ZISRES,%ZISRL,%ZISY0,%ZTRTN,ZTSAVE,ZTIO - S %ZISJOB=$J - ; -RES1 G RQ:'$D(IOS),RQ:'$D(^%ZIS(1,+IOS,1)) S %ZISRL=+$P(^(1),"^",10),%ZISRL=$S(%ZISRL:%ZISRL,1:1) - S %X=$O(^%ZISL(3.54,"B",IO,0)) G RQ:'%X - G RQ:'$D(^%ZISL(3.54,+%X,0)) S %ZISD0=+%X,%ZISY0=^(0) - S %X=$O(^%ZISL(3.54,"AJ",%ZISJOB,%ZISD0,0)) S %ZISD1=%X G RQ:'%X - S %Y=$G(^%ZISL(3.54,%ZISD0,1,+%ZISD1,0)) G RQ:$P(%Y,"^",3)'=%ZISJOB - D KILLRES(+%ZISD0,+%ZISD1) -RQ K IO(1,IO) - Q - ; -KILLRES(D0,D1) ;Kill one resource use - Q:(D0'>0)!(D1'>0) - N %X,%Y,%J,%ZISRL - L +^%ZISL(3.54,D0,0) - S %Y=$G(^%ZISL(3.54,D0,0)) G KRX:%Y="" - S %X=$G(^%ZISL(3.54,D0,1,D1,0)),%J=$P(%X,"^",3) S:%J="" %J=" " - K ^%ZISL(3.54,D0,1,D1,0),^%ZISL(3.54,D0,1,"B",D1,D1),^%ZISL(3.54,"AJ",%J,D0,D1) - S %X=$P(%Y,"^",2)+1,$P(^%ZISL(3.54,D0,0),"^",2)=%X - ;I '$D(^%ZISL(3.54,%ZISD0,1,0)) S ^(0)="^3.542A^^" G RQ - S %Y=$G(^%ZISL(3.54,D0,1,0)),%X=$P(%Y,"^",4),$P(^%ZISL(3.54,D0,1,0),"^",3,4)="^"_$S(%X>0:(%X-1),1:0) -KRX L -^%ZISL(3.54,D0,0) - Q - ; -DQCRES ;Tasked entry point to close resource device. - S IO=%ZISRES G RES1 - ; -FF() ;Issue form feed - I $E(IOST,1,2)'["C-",$D(IO(1,IO)),$G(IOT)="TRM"!($G(IOT)="SPL"),'$D(IO("T"))&$Y&'$D(IONOFF)&'$D(IO(1,IO,"NOFF")) Q 1 - Q 0 - ; -CLOSPP() ;Close printer port - I $D(IO("S")),$D(^%ZIS(2,+IO("S"),11))&$D(IO(1,IO)) Q 1 - Q 0 +%ZISC ;SFISC/GFT,AC,MUS - CLOSE LOGIC FOR DEVICES ;01/14/2002 09:06 + ;;8.0;KERNEL;**24,36,49,69,199,216,275,409**;JUL 10, 1995;Build 3 +C0 ; + N %,%E,%H,%ZISI,%ZISOS,%ZISX,%ZISV + ;Clear IO var we will use for reporting + K IO("ERROR"),IO("LASTERR"),IO("CLOSE") + ;Protect ourself from calls with incomplete setup. + S:$D(IO)[0 IO=$I S:'$D(IO(0)) IO(0)=$P + S U="^",%ZISOS=$G(^%ZOSF("OS")),%ZISV=$G(^("VOL")) + ;S %=$S(+$G(IOS):IOS,$L($G(ION)):ION,1:IO) + S %=$S($L($G(ION)):ION,1:IO) ;p409 + I (%="")!(IO="") G SETIO:IO(0)]"",END + I $G(IOT)="RES" D RES G SETIO ;Handle a resource device + ; + ;Define subtype info if not already defined. + D SUBTYPE + ; + ;perform close execute + I $G(IOST(0))>0 D + . I $G(^%ZIS(2,+IOST(0),3))]"",$D(IO(1,IO)) D + . . U IO S:$X $X=1 D X3^ZISX:'$D(IO("T")) + ; + ;Incase the Close execute changed IO, Open IO("HOME") or NULL. + I '$L($G(IO)) D Q + . S IOP=$S($L($G(IO("HOME"))):"`"_(+IO("HOME")),1:"NULL") D ^%ZIS + . Q + ; + ;Perform the following if the device is open. + I $D(IO(1,IO)) D + . I $G(IO("P"))["B" D ;Return to normal intensity + . . S %=$P($G(^%ZIS(2,+IOST(0),7)),"^",3) I %]"" W @% + . I $G(IO("P"))["P" D ;Return to default pitch + . . S %=$G(^%ZIS(2,+IOST(0),12.11)) I %]"" W @% + . ; + . W:$$FF @IOF ;Issue form feed at close + . I $$CLOSPP D X11^ZISX:'$D(IO("T")) K IO("S") ;Close printer port + . Q + ; + ;Don't use IOCPU as we now use IO(1,IO) + I (IO'=IO(0)!$D(IO("C"))),$D(IO(1,IO)) D + . U:$S($D(ZTQUEUED):0,'$L($G(IO(0))):0,$D(IO(1,IO(0)))#2:1,1:0) IO(0) + . C IO K IO(1,IO) S IO("CLOSE")=IO ;close device + ; + ; + I $D(IOT),IOT="CHAN",$D(IOS) D + .S %=$G(^%ZIS(1,+IOS,"GBL")) + .I %]"" L @("-^"_%) ;unlock global used to control access to network channels. + I $D(IO("SPOOL")) D CLOSE^%ZIS4 ;Special close for spool device + ; +SETIO ; + ;See if old device has PCX code + I $G(IOS),$G(^%ZIS(1,+IOS,"PCX"))]"" S %ZISPCX=^("PCX") + ;Setup the IO(0) device, should be the home device + S IO=IO(0),(IOPAR,IOUPAR)="" K IO("T") D CIOS(IO(0)) + I 'IOS S IOT="TRM" G END + S ION=$P(^%ZIS(1,IOS,0),"^",1),IOT=$G(^("TYPE")),IOST(0)=$S(IOT["TRM"&($D(^XUTL("XQ",$J,"IOST(0)"))):^("IOST(0)"),1:$G(^%ZIS(1,IOS,"SUBTYPE"))) + I IOT["TRM",$D(^XUTL("XQ",$J,"IO")) D HOME^%ZIS G END + S %="Y" + I IOST(0),$D(^%ZIS(2,IOST(0),1)) S %=^(1),IOM=+%,IOF=$P(%,"^",2),IOSL=$P(%,"^",3),IOBS=$P(%,"^",4) + I $D(^%ZIS(1,IOS,91)) S %=^%ZIS(1,IOS,91) S:+% IOM=+% S:$P(%,"^",3) IOSL=$P(%,"^",3) + ;Don't know the subtype so set some defaults + I %="Y" S IOM=80,IOSL=24,IOF="#",IOST="C-OTHER",IOBS="$C(8)" +S1 S:IOST(0) IOST=$P($G(^%ZIS(2,+IOST(0),0)),"^"),IOXY=$G(^("XY")) + I '$D(ZTQUEUED),'$D(IO("C")),IOT["TRM" D RM:$D(IO(1,IO)) + ;With home device set, Do Post-close execute code of Device closed. +END I '$D(IO("T")),$G(%ZISPCX)]"" S %Y=%ZISPCX D %Y^ZISX + ;See that any extra IO variables are cleaned up + K IO("P"),IO("DOC"),IO("HFSIO"),IO("SPOOL"),IOC,IONOFF + ;IOCPU should not be changed. + Q + ; +SUBTYPE ;Find a subtype + N %S + S IOST=$G(IOST),IOST(0)=+$G(IOST(0)) + I $L(IOST)&$L(IOST(0)) Q ;Have a subtype + S %S=$G(^%ZIS(2,+IOST(0),0)) I $L(%S) S IOST=$P(%S,U) Q + I $L(IOST) S %S=$O(^%ZIS(2,"B",$G(IOST,"X"),0)) I %S>0 S IOST(0)=+%S Q + S IOST="",IOST(0)=0 D CIOS($I) Q:IOS'>0 + S IOST(0)=$G(^%ZIS(1,+IOS,"SUBTYPE")),IOST=$P($G(^%ZIS(2,+IOST(0),0)),"^") + Q + ; +CIOS(%I) ;Find a value for IOS (IEN into device file) + N %ZISVT + I $D(^XUTL("XQ",$J,"IOS")) S IOS=+^("IOS") Q + I $D(%ZISV) S %ZISVT=%I D VTLKUP^%ZIS S IOS=+%E + E S IOS=+$O(^%ZIS(1,"C",%I,0)) + Q:$G(IOS)>0 + S %ZISVT=%I D VIRTUAL^%ZIS + I $D(%ZISVT) S %H=%E I %ZISVT]"",%H>0,$D(^%ZIS(1,%H,0)),$D(^("TYPE")),^("TYPE")="VTRM" S IOS=%H + Q + ; +RM N X S X=+IOM X ^%ZOSF("RM") + Q + ; +RES ;Close resource device. + Q:'$D(IO(1,IO))&'$D(^%ZISL(3.54,"AJ",$J)) + N %ZISJOB,%X,%Y,%ZISD0,%ZISD1,%ZISRES,%ZISRL,%ZISY0,%ZTRTN,ZTSAVE,ZTIO + S %ZISJOB=$J + ; +RES1 G RQ:'$D(IOS),RQ:'$D(^%ZIS(1,+IOS,1)) S %ZISRL=+$P(^(1),"^",10),%ZISRL=$S(%ZISRL:%ZISRL,1:1) + S %X=$O(^%ZISL(3.54,"B",IO,0)) G RQ:'%X + G RQ:'$D(^%ZISL(3.54,+%X,0)) S %ZISD0=+%X,%ZISY0=^(0) + S %X=$O(^%ZISL(3.54,"AJ",%ZISJOB,%ZISD0,0)) S %ZISD1=%X G RQ:'%X + S %Y=$G(^%ZISL(3.54,%ZISD0,1,+%ZISD1,0)) G RQ:$P(%Y,"^",3)'=%ZISJOB + D KILLRES(+%ZISD0,+%ZISD1) +RQ K IO(1,IO) + Q + ; +KILLRES(D0,D1) ;Kill one resource use + Q:(D0'>0)!(D1'>0) + N %X,%Y,%J,%ZISRL + L +^%ZISL(3.54,D0,0) + S %Y=$G(^%ZISL(3.54,D0,0)) G KRX:%Y="" + S %X=$G(^%ZISL(3.54,D0,1,D1,0)),%J=$P(%X,"^",3) S:%J="" %J=" " + K ^%ZISL(3.54,D0,1,D1,0),^%ZISL(3.54,D0,1,"B",D1,D1),^%ZISL(3.54,"AJ",%J,D0,D1) + S %X=$P(%Y,"^",2)+1,$P(^%ZISL(3.54,D0,0),"^",2)=%X + ;I '$D(^%ZISL(3.54,%ZISD0,1,0)) S ^(0)="^3.542A^^" G RQ + S %Y=$G(^%ZISL(3.54,D0,1,0)),%X=$P(%Y,"^",4),$P(^%ZISL(3.54,D0,1,0),"^",3,4)="^"_$S(%X>0:(%X-1),1:0) +KRX L -^%ZISL(3.54,D0,0) + Q + ; +DQCRES ;Tasked entry point to close resource device. + S IO=%ZISRES G RES1 + ; +FF() ;Issue form feed + I $E(IOST,1,2)'["C-",$D(IO(1,IO)),$G(IOT)="TRM"!($G(IOT)="SPL"),'$D(IO("T"))&$Y&'$D(IONOFF)&'$D(IO(1,IO,"NOFF")) Q 1 + Q 0 + ; +CLOSPP() ;Close printer port + I $D(IO("S")),$D(^%ZIS(2,+IO("S"),11))&$D(IO(1,IO)) Q 1 + Q 0 diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZISEDIT.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZISEDIT.m index eb94ebea..865498ae 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZISEDIT.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZISEDIT.m @@ -1,49 +1,23 @@ -ZISEDIT ;ISF/AC - DEVICE EDIT ;01/17/2008 - ;;8.0;KERNEL;**440**;Jul 10, 1995;Build 13 - ; -TRM ;TRM or VTRM - D EDIT("TRM",,"Select Terminal/Printer Device: ") - Q - ; -LPD ;LPD fields of a TRM device - D EDIT("LPD","TRM","Select LPD (Terminal/Printer) Device: ") - Q - ; -MT ;Mag Tape - D EDIT("MT",,"Select Magtape Device: ") - Q - ; -SDP ; - D EDIT("SDP",,"Select SDP Device: ") - Q - ; -SPL ;Spool - D EDIT("SPL",,"Select Spool Device: ") - Q - ; -HFS ;Host file - D EDIT("HFS",,"Select Host File Device: ") - Q - ; -CHAN ;Network - D EDIT("CHAN",,"Select Network Channel: ") - Q - ; -RES ;Resource - D EDIT("RES",,"Select Resource Device: ") - Q - ; -EDIT(ZISTYPE,ZISSCR,DICA) ; - N Y,DA,DIC,DIE,DR,DDSFILE -ED2 S DIC("A")=DICA,ZISSCR=$G(ZISSCR,ZISTYPE) - S DIC=3.5,DIC(0)="AEMQZL",DIC("S")="I $G(^(""TYPE""))["_""""_ZISSCR_"""" D ^DIC - Q:Y'>0 - S DA=+Y - I $P(Y,"^",3) D - . N DIE,DR - . S DIE=DIC,DR="2///"_ZISTYPE_$S(ZISTYPE["TRM":"",1:";1.95///N") - . D ^DIE - . Q - S DR="[XUDEVICE "_ZISTYPE_"]",DDSFILE=3.5 D ^DDS - G ED2 - Q +ZISEDIT ;SFISC/AC - DEVICE EDIT ;11/9/92 17:00 + ;;8.0;KERNEL;;Jul 10, 1995 + ; +MT S ZISTYPE="MT",DIC("A")="Select Magtape Device: " D EDIT K ZISTYPE + Q + ; +SDP S ZISTYPE="SDP",DIC("A")="Select SDP Device: " D EDIT K ZISTYPE + Q + ; +SPL S ZISTYPE="SPL",DIC("A")="Select Spool Device: " D EDIT K ZISTYPE + Q + ; +HFS S ZISTYPE="HFS",DIC("A")="Select Host File Device: " D EDIT K ZISTYPE + Q + ; +CHAN S ZISTYPE="CHAN",DIC("A")="Select Network Channel: " D EDIT K ZISTYPE + Q + ;;7.1P0;Kernel;; +EDIT S DIC=3.5,DIC(0)="AEMQZL",DIC("S")="I $G(^(""TYPE""))="_""""_ZISTYPE_"""" D ^DIC + I Y'>0 K DIC Q + S DA=+Y I $P(Y,"^",3) S DIE=DIC,DR="2///"_ZISTYPE D ^DIE K DIE,DR + S DR="[XUDEVICE "_ZISTYPE_"]",DDSFILE=3.5 D ^DDS + K DA,DR,DDSFILE Q diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZISHONT.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZISHONT.m index 2624e916..3e39fcff 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZISHONT.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZISHONT.m @@ -1,281 +1,246 @@ -%ZISH ;IHS/PR,SFISC/AC - Host File Control for Cache for VMS/NT/UNIX ;1/24/08 16:11 - ;;8.0;KERNEL;**34,65,84,104,191,306,385,440**;JUL 10, 1995;Build 13 - ;Per VHA Directive 2004-038, this routine should not be modified - ; **MODIFIED VERSION FOR CACHE/VMS -- 9/7/01** - ; -OPEN(X1,X2,X3,X4,X5,X6) ;SR. Open Host File - ;X1=handle name - ;X2=directory name \dir\ - ;X3=file name - ;X4=file access mode e.g.: W for write, R for read, A for append. - ;X5=Max record size for a new file, X6=Subtype - N %,%1,%2,%I,%ZOS,%T,%ZA,%ZISHIO,$ET - S $ET="D OPNERR^%ZISH" - S U="^",%I=$I,%T=0,POP=0,X2=$$DEFDIR($G(X2)),%ZOS=$$OS^%ZOSV M %ZISHIO=IO - I %ZOS'="VMS" S %1=$S(X4["A":"AW",X4["W":"WN",1:"R")_$S(X4["B":"U",1:"S") ;NT & Unix - I %ZOS="VMS" S %1=$S(X4["A":"AW",X4["W":"WN",1:"RH")_$S(X4["B":"U",1:"S") - ;The next line eliminates the error for sequential files for the current process. - S %ZA=$ZUTIL(68,40,1) ;Work like DSM - S %=X2_X3 O %:(%1):2 I '$T S POP=1 Q - ;U % S %ZA=$ZA ;Comment out, $ZA is for READ status - ;I %ZA=-1 U:%I]"" %I C % S POP=1 Q - S IO=%,IO(1,IO)="",IOT="HFS",IOM=80,IOSL=60,POP=0 D SUBTYPE^%ZIS3($G(X6,"P-OTHER")) - I $G(X1)]"" D SAVDEV^%ZISUTL(X1) - U $S(%I]"":%I,1:$P) - Q - ; -OPNERR ;Handle open error - S POP=1,$ECODE="" - U:$P]"" $P - Q - ; -CLOSE(X) ;SR. Close HFS device not opened by %ZIS. - ;X=HANDLE NAME - ;IO=Device - N % - I $G(IO)]"" C IO K IO(1,IO) - I $G(X)]"" D RMDEV^%ZISUTL(X) - ;Only reset home if one setup. - I $D(IO("HOME"))!$D(^XUTL("XQ",$J,"IOS")) D HOME^%ZIS - Q - ; -OPENERR ; - Q 0 - ; -DEL(%ZX1,%ZX2) ;ef,SR. Del files, return 1 if deleted all requested. - ;S Y=$$DEL^%ZISH("dir path",$NA(array)) - ; will invoke an OS command to delete file(s) - ; UNIX: rm -f filespec[ ...] - ; VMS: del filespec[,...] - N %ZARG,%ZXDEL,%ZOS,%ZDELIM,%ZCOMND,%ZLIST - S %ZARG="",%ZXDEL=1 - S %ZX1=$$DEFDIR($G(%ZX1)) - S %ZOS=$$OS^%ZOSV - S %ZDELIM=$S(%ZOS="UNIX":" ",1:",") - S %ZCOMND=$S(%ZOS="UNIX":"rm -f ",1:"del ") - D - . N $ETRAP,$ESTACK S $ETRAP="D DELERR^%ZISH" - . N %,%ZI,%ZISH,%ZX,%ZFOUND S %ZISH="" - . F %ZI=1:1 S %ZISH=$O(@%ZX2@(%ZISH)) Q:%ZISH="" D - . . N $ETRAP,$ESTACK S $ETRAP="D DELERR^%ZISH" - . . I %ZISH["*" S %ZXDEL=0 Q ; Wild card not allowed. - . . S %ZX=$S(%ZISH[%ZX1:%ZISH,1:%ZX1_%ZISH) ; prepend directory path - . . I %ZOS="VMS",%ZX'[";" S %ZX=%ZX_";*" - . . S %ZFOUND=$ZSEARCH(%ZX)]"" ; File exists - . . S:%ZFOUND %ZARG=$S(%ZARG="":%ZX,1:%ZARG_%ZDELIM_%ZX) ; join files - . . I $L(%ZARG)>2000 S %=$ZF(-1,%ZCOMND_%ZARG),%ZARG="" H 1 ; delete files at a time - . ; - . I $L(%ZARG) S %=$ZF(-1,%ZCOMND_%ZARG) ; delete remaining files - ; - I %ZXDEL S %ZXDEL='$$LIST(%ZX1,%ZX2,"%ZLIST") - Q %ZXDEL - ; -DELERR ;Trap any $ETRAP error, unwind and return. - S $ETRAP="D UNWIND^%ZTER" - S %ZXDEL=0,%ZARG="" - D UNWIND^%ZTER - Q - ; -DEL1(%ZX3) ;ef,SR. Delete one file - N %ZI1,%ZI2 - D SPLIT(%ZX3,.%ZI1,.%ZI2) S %ZI2(%ZI2)="" - Q $$DEL(%ZI1,$NA(%ZI2)) - ; -SPLIT(%I,%O1,%O2) ;Split to path,file - N %ZOS,%D,D S %ZOS=$$OS^%ZOSV - I %ZOS["VMS" D Q - . S D=$S(%I["]":"]",1:":") - . S %O1=$P(%I,D,1)_D,%O2=$P(%I,D,2) - . Q - S %D=$S(%ZOS="UNIX":"/",%ZOS="NT":"\",1:""),%O1="",%O2="" Q:%D="" - S D=$L(%I,%D),%O1=$P(%I,%D,1,D-1),%O2=$P(%I,%D,D) - Q - ; -FEXIST(%PATH,%FL) ;Check if files exsist. - ;S Y=$$DTEST("/usr/var",$NA(array)) - N %ZISH,%ZISHY - S %ZISH=$$LIST(%PATH,%FL,"%ZISHY") - Q %ZISH - ; -LIST(%ZX1,%ZX2,%ZX3) ;ef,SR. Create a local array holding file names - ;S Y=$$LIST^%ZISH("\dir\",$NA(array),$NA(return array)) Return 1 if found anything - ; - N %ZISH,%ZISHN,%ZX,%ZISHY,%ZY,%ZOS - S %ZX1=$$DEFDIR($G(%ZX1)),%ZOS=$$OS^%ZOSV - ;S %ZX1=$$TRNLNM(%ZX1) - ;Get fls to act on - S %ZISH="" F S %ZISH=$O(@%ZX2@(%ZISH)) Q:%ZISH="" D - . S %ZISHY=$P(%ZISH,"*") - . I %ZOS="VMS",%ZISH'["." S %ZISH=%ZISH_".*" ;Allways upper - . ;NT, display case, ignore for lookup - . S %ZX=%ZX1_%ZISH - . F %ZISHN=0:1 D Q:(%ZX="") - . . S %ZX=$ZSEARCH($S(%ZISHN:"",1:%ZX)) - . . ;Q:(%ZX="")!($$UP^XLFSTR(%ZX)'[%ZISHY)!(%ZX?.E1.2".") - . . Q:(%ZX="")!(%ZX?.E1.2".") - . . I %ZOS="VMS" S %ZX=$P(%ZX,"]",2),@%ZX3@(%ZX)="" - . . I %ZOS="NT" S %ZY=$P(%ZX,"\",$L(%ZX,"\")),@%ZX3@(%ZY)="" - . . I %ZOS="UNIX" S %ZY=$P(%ZX,"/",$L(%ZX,"/")) Q:%ZX'[%ZISHY S @%ZX3@(%ZY)="" - . . Q - Q $O(@%ZX3@(""))]"" - ; -MV(X1,X2,Y1,Y2) ;ef,SR. Rename a fl - ;S Y=$$MV^ZOSHDOS("\dir\","fl","\dir\","fl") - ;Unix use mv, NT/VMS use COPY and DEL - N %,X,Y,%ZOS,%ZISHX S %ZOS=$$OS^%ZOSV - S X1=$$DEFDIR($G(X1)),Y1=$$DEFDIR($G(Y1)) - S X=$ZSEARCH(X1_X2),Y=Y1_Y2 ;move X to Y - I X="" Q 0 - S %=$ZF(-1,$S(%ZOS="UNIX":"mv ",1:"copy ")_X_" "_Y) ;Use NT/VMS copy - I %ZOS'="UNIX" D - . S X2=$P(X,X1,2),%ZISHX(X2)="" - . S Y=$$DEL^%ZISH(X1,$NA(%ZISHX)) - Q 1 - ; -PWD() ;ef,SR. Print working directory - N Y,%ZOS - S Y=$$DEFDIR(""),%ZOS=$$OS^%ZOSV - I Y="" S Y=$ZSEARCH("*") - Q $S(%ZOS["VMS":Y,1:$P(Y,".",1)) - ; -TRNLNM(PATH) ;ef. Expand logical path - N %ZOS,P1,P2 - S %ZOS=$$OS^%ZOSV,PATH=$G(PATH) - I %ZOS="VMS" D Q PATH - . S P1=PATH_$S(PATH[":":"*.*",1:":*.*") - . S P2=$ZSEARCH(P1) - . S:$L(P2) PATH=$S(P2["]":$P(P2,"]",1)_"]",1:$P(P2,":",1)_":") - . Q - I %ZOS="NT" D Q PATH - . S P1=PATH_$S($E(PATH,$L(PATH))'="\":"\*",1:"*"),P2=$ZSEARCH(P1) - . S:$L(P2) PATH=$P(P2,"\",1,$L(P2,"\")-1)_"\" - . Q - I %ZOS="UNIX" D Q PATH - . S P1=PATH_$S($E(PATH,$L(PATH))'="/":"/*",1:"*"),P2=$ZSEARCH(P1) - . S:$L(P2) PATH=$P(P2,"/",1,$L(P2,"/")-1)_"/" - . Q - Q PATH - ; -DEFDIR(DF) ;ef. Default Dir and frmt - ;Need to handle NT, VMS and Linux - N %ZOS,P1,P2 S %ZOS=$$OS^%ZOSV,DF=$G(DF) - Q:DF="." "" ;Special way to get current dir. - S:DF="" DF=$G(^XTV(8989.3,1,"DEV")),DF=$P(DF,"^",$S($$PRI^%ZOSV<2:1,1:2)) - Q:DF="" "" - ;Check syntax, VMS needs disk:[dir] or logical: - I %ZOS="VMS" D - . I DF[":" S P1=$P(DF,":")_":",P2=$P(DF,":",2) - . E S P1="",P2=DF - . I P1="",P2["$" S P1=P2,P2="" ;Could be a logical - . I $L(P2) S:P2'["[" P2="["_P2 S:P2'["]" P2=P2_"]" - . S DF=P1_P2 S:DF'[":" DF=DF_":" - . Q - ;Check syntax, Unix needs /mnt/fl, ./fl, ~/fl $HOME/fl - I %ZOS="UNIX" D - . S DF=$TR(DF,"\","/") - . S:$E(DF,$L(DF))'="/" DF=DF_"/" - . Q - ;Check syntax, NT needs c:\dir\ - I %ZOS="NT" D - . N P1,P2 - . I DF[":" S P1=$P(DF,":")_":",P2=$P(DF,":",2) - . E S P1="",P2=DF - . S P2=$TR(P2,"/","\") - . I $L(P2) S:".\"'[$E(P2,1) P2="\"_P2 S:$E(P2,$L(P2))'="\" P2=P2_"\" - . S DF=P1_P2 - . Q - S DF=$$TRNLNM(DF) ;Resolve logicals - Q DF - ; -FL(X) ;Fl len - N ZOSHP1,ZOSHP2 - S ZOSHP1=$P(X,"."),ZOSHP2=$P(X,".",2) - I $L(ZOSHP1)>8 S X=4 Q - I $L(ZOSHP2)>3 S X=4 Q - Q - ; -STATUS() ;ef,SR. Return EOF status - U $I - Q $$EOF($ZEOF) - ; -EOF(X) ;Eof flag, pass in $ZEOF - Q (X=-1) - ; -MAKEREF(HF,IX,OVF) ;Internal call to rebuild global ref. - ;Return %ZISHF,%ZISHO,%ZISHI,%ZISUB - N I,F,MX - S OVF=$G(OVF,"%ZISHOF") - S %ZISHI=$QS(HF,IX),MX=$QL(HF) ; - S F=$NA(@HF,IX-1) ;Get first part - I IX=1 S %ZISHF=F_"(%ZISHI" ;Build root, IX=1 - I IX>1 S %ZISHF=$E(F,1,$L(F)-1)_",%ZISHI" ;Build root - S %ZISHO=%ZISHF_","_OVF_",%OVFCNT)" ;Make overflow - F I=IX+1:1:MX S %ZISHF=%ZISHF_",%ZISUB("_I_")",%ZISUB(I)=$QS(HF,I) - S %ZISHF=%ZISHF_")" - Q - ; -READNXT(REC) ;Read any sized record into array. %ZB has terminator - N %,I,X,$ES,$ET S REC="",$ET="D READNX^%ZISH Q" - U IO R X:5 S %ZB=$A($ZB),REC=$E(X,1,255) - Q:$L(X)<256 - S %=256 F I=1:1 Q:$L(X)<% S REC(I)=$E(X,%,%+254),%=%+255 - Q -READNX ;Check for EOF - I $ZE["ENDOFFILE" S %ZA=-1 - S $EC="" - Q - ; -FTG(%ZX1,%ZX2,%ZX3,%ZX4,%ZX5) ;ef,SR. Unload contents of host file into global - ;p1=hostf file directory - ;p2=host file name - ;p3= $NAME REFERENCE INCLUDING STARTING SUBSCRIPT - ;p4=INCREMENT SUBSCRIPT - ;p5=Overflow subscript, defaults to "OVF" - N %ZA,%ZB,%ZC,X,%OVFCNT,%ZISHF,%ZISHO,POP,%ZISUB,$ES,$ET - N I,%ZISH,%ZISH1,%ZISHI,%ZISHL,%ZISHOF,%ZISHOX,%ZISHS,%ZX,%ZISHY - S %ZX1=$$DEFDIR($G(%ZX1)),%ZISHOF=$G(%ZX5,"OVF") - D MAKEREF(%ZX3,%ZX4,"%ZISHOF") - D OPEN^%ZISH(,%ZX1,%ZX2,"R") - I POP Q 0 - S %ZC=1,%ZA=0,$ET="S %ZC=0,%ZA=-1,$EC="""" Q" - U IO F K %XX D READNXT(.%XX) Q:$$EOF($ZEOF)!%ZA D - . S @%ZISHF=%XX - . I $D(%XX)>2 F %OVFCNT=1:1 Q:'$D(%XX(%OVFCNT)) S @%ZISHO=%XX(%OVFCNT) - . S %ZISHI=%ZISHI+1 - . Q - D CLOSE() ;Normal exit - Q %ZC - ; -GTF(%ZX1,%ZX2,%ZX3,%ZX4) ;ef,SR. Load contents of global to host file. - ;p1=$NAME of global reference - ;p2=incrementing subscript - ;p3=host file directory - ;p4=host file name - N %ZISHY,%ZISHOX - S %ZISHY=$$MGTF(%ZX1,%ZX2,%ZX3,%ZX4,"W") - Q %ZISHY - ; -GATF(%ZX1,%ZX2,%ZX3,%ZX4) ;ef,SR. Append to host file. - ; - ;p1=$NAME of global reference - ;p2=incrementing subscript - ;p3=host file directory - ;p4=host file name - N %ZISHY - S %ZISHY=$$MGTF(%ZX1,%ZX2,%ZX3,%ZX4,"A") - Q %ZISHY - ; -MGTF(%ZX1,%ZX2,%ZX3,%ZX4,%ZX5) ; - ;p1=$NAME of global reference - ;p2=incrementing subscript - ;p3=host file directory - ;p4=host file name - N %ZISH,%ZISH1,%ZISHI,%ZISHL,%ZISHS,%ZISHOX,IO,%ZX,Y,%ZC - D MAKEREF(%ZX1,%ZX2) - D OPEN^%ZISH(,$G(%ZX3),%ZX4,%ZX5) ;Default dir set in open - I POP Q 0 - N $ETRAP S $ETRAP="S $EC="""" D CLOSE^%ZISH() Q 0" - F Q:'($D(@%ZISHF)#2) S %ZX=@%ZISHF,%ZISHI=%ZISHI+1 U IO W %ZX,! - D CLOSE() - Q 1 - ; +%ZISH ;IHS\PR,SFISC/AC - Host File Control for OpenM/Cache for NT/VMS ;12/13/2005 + ;;8.0;KERNEL;**34,65,84,104,191,306,385**;JUL 10, 1995;Build 3 + ; + ; **MODIFIED VERSION FOR CACHE/VMS -- 9/7/01** + ; +OPEN(X1,X2,X3,X4,X5,X6) ;SR. Open Host File + ;X1=handle name + ;X2=directory name \dir\ + ;X3=file name + ;X4=file access mode e.g.: W for write, R for read, A for append. + ;X5=Max record size for a new file, X6=Subtype + N %,%1,%2,%I,%ZOS,%T,%ZA,%ZISHIO,$ET + S $ET="D OPNERR^%ZISH" + S U="^",%I=$I,%T=0,POP=0,X2=$$DEFDIR($G(X2)),%ZOS=$$OS^%ZOSV M %ZISHIO=IO + I %ZOS'="VMS" S %1=$S(X4["A":"AW",X4["W":"WN",1:"R")_$S(X4["B":"U",1:"S") ;NT & Unix + I %ZOS="VMS" S %1=$S(X4["A":"AW",X4["W":"WN",1:"RH")_$S(X4["B":"U",1:"S") + ;The next line eliminates the error for sequential files for the current process. + S %ZA=$ZUTIL(68,40,1) ;Work like DSM + S %=X2_X3 O %:(%1):2 I '$T S POP=1 Q + ;U % S %ZA=$ZA ;Comment out, $ZA is for READ status + ;I %ZA=-1 U:%I]"" %I C % S POP=1 Q + S IO=%,IO(1,IO)="",IOT="HFS",IOM=80,IOSL=60,POP=0 D SUBTYPE^%ZIS3($G(X6,"P-OTHER")) + I $G(X1)]"" D SAVDEV^%ZISUTL(X1) + U $S(%I]"":%I,1:$P) + Q + ; +OPNERR ;Handle open error + S POP=1,$ECODE="" + U:$P]"" $P + Q + ; +CLOSE(X) ;SR. Close HFS device not opened by %ZIS. + ;X=HANDLE NAME + ;IO=Device + N % + I $G(IO)]"" C IO K IO(1,IO) + I $G(X)]"" D RMDEV^%ZISUTL(X) + ;Only reset home if one setup. + I $D(IO("HOME"))!$D(^XUTL("XQ",$J,"IOS")) D HOME^%ZIS + Q + ; +OPENERR ; + Q 0 + ; +DEL(%ZX1,%ZX2) ;ef,SR. Del fl(s) + ;S Y=$$DEL^%ZISH("dir path",$NA(array)) + N %,%ZX,%ZXDEL,%ZISH,%ZOS + S %ZX1=$$DEFDIR($G(%ZX1)),%ZOS=$$OS^%ZOSV,%ZXDEL=1,%ZISH="" + F S %ZISH=$O(@%ZX2@(%ZISH)) Q:%ZISH="" D + . N $ETRAP,$ESTACK S $ETRAP="D DELERR^%ZISH" + . I %ZISH["*" S %ZXDEL=0 Q ; Wild card not allowed. + . S %ZX=$S(%ZISH[%ZX1:%ZISH,1:%ZX1_%ZISH) + . I %ZOS="VMS",%ZX'[";" S %ZX=%ZX_";*" + . Q:$ZSEARCH(%ZX)']"" ; File doesn't exist + . S %=$ZF(-1,$S(%ZOS="UNIX":"rm ",1:"del ")_%ZX) + . I $ZSEARCH(%ZX)]"" S %ZXDEL=0 ; Delete was not successful. + Q %ZXDEL + ; +DELERR ;Trap any $ETRAP error, unwind and return. + S $ETRAP="D UNWIND^%ZTER" + S %ZXDEL=0 + D UNWIND^%ZTER + Q + ; +LIST(%ZX1,%ZX2,%ZX3) ;ef,SR. Create a local array holding file names + ;S Y=$$LIST^ZOSHDOS("\dir\",$NA(array),$NA(return array)) Return 1 if found anything + ; + N %ZISH,%ZISHN,%ZX,%ZISHY,%ZY,%ZOS + S %ZX1=$$DEFDIR($G(%ZX1)),%ZOS=$$OS^%ZOSV + ;S %ZX1=$$TRNLNM(%ZX1) + ;Get fls to act on + S %ZISH="" F S %ZISH=$O(@%ZX2@(%ZISH)) Q:%ZISH="" D + . S %ZISHY=$P(%ZISH,"*") + . I %ZOS="VMS",%ZISH'["." S %ZISH=%ZISH_".*" ;Allways upper + . ;NT, display case, ignore for lookup + . S %ZX=%ZX1_%ZISH + . F %ZISHN=0:1 D Q:(%ZX="") + . . S %ZX=$ZSEARCH($S(%ZISHN:"",1:%ZX)) + . . ;Q:(%ZX="")!($$UP^XLFSTR(%ZX)'[%ZISHY)!(%ZX?.E1.2".") + . . Q:(%ZX="")!(%ZX?.E1.2".") + . . I %ZOS="VMS" S %ZX=$P(%ZX,"]",2),@%ZX3@(%ZX)="" + . . I %ZOS="NT" S %ZY=$P(%ZX,"\",$L(%ZX,"\")),@%ZX3@(%ZY)="" + . . I %ZOS="UNIX" S %ZY=$P(%ZX,"/",$L(%ZX,"/")) Q:%ZX'[%ZISHY S @%ZX3@(%ZY)="" + . . Q + Q $O(@%ZX3@(""))]"" + ; +MV(X1,X2,Y1,Y2) ;ef,SR. Rename a fl + ;S Y=$$MV^ZOSHDOS("\dir\","fl","\dir\","fl") + ;Unix use mv, NT/VMS use COPY and DEL + N %,X,Y,%ZOS,%ZISHX S %ZOS=$$OS^%ZOSV + S X1=$$DEFDIR($G(X1)),Y1=$$DEFDIR($G(Y1)) + S X=$ZSEARCH(X1_X2),Y=Y1_Y2 ;move X to Y + I X="" Q 0 + S %=$ZF(-1,$S(%ZOS="UNIX":"mv ",1:"copy ")_X_" "_Y) ;Use NT/VMS copy + I %ZOS'="UNIX" D + . S X2=$P(X,X1,2),%ZISHX(X2)="" + . S Y=$$DEL^%ZISH(X1,$NA(%ZISHX)) + Q 1 + ; +PWD() ;ef,SR. Print working directory + N Y,%ZOS + S Y=$$DEFDIR(""),%ZOS=$$OS^%ZOSV + I Y="" S Y=$ZSEARCH("*") + Q $S(%ZOS["VMS":Y,1:$P(Y,".",1)) + ; +TRNLNM(PATH) ;ef. Expand logical path + N %ZOS,P1,P2 + S %ZOS=$$OS^%ZOSV,PATH=$G(PATH) + I %ZOS="VMS" D Q PATH + . S P1=PATH_$S(PATH[":":"*.*",1:":*.*") + . S P2=$ZSEARCH(P1) + . S:$L(P2) PATH=$S(P2["]":$P(P2,"]",1)_"]",1:$P(P2,":",1)_":") + . Q + I %ZOS="NT" D Q PATH + . S P1=PATH_$S($E(PATH,$L(PATH))'="\":"\*",1:"*"),P2=$ZSEARCH(P1) + . S:$L(P2) PATH=$P(P2,"\",1,$L(P2,"\")-1)_"\" + . Q + I %ZOS="UNIX" D Q PATH + . S P1=PATH_$S($E(PATH,$L(PATH))'="/":"/*",1:"*"),P2=$ZSEARCH(P1) + . S:$L(P2) PATH=$P(P2,"/",1,$L(P2,"/")-1)_"/" + . Q + Q PATH + ; +DEFDIR(DF) ;ef. Default Dir and frmt + ;Need to handle NT, VMS and Linux + N %ZOS,P1,P2 S %ZOS=$$OS^%ZOSV,DF=$G(DF) + Q:DF="." "" ;Special way to get current dir. + S:DF="" DF=$G(^XTV(8989.3,1,"DEV")) + Q:DF="" "" + ;Check syntax, VMS needs disk:[dir] or logical: + I %ZOS="VMS" D + . I DF[":" S P1=$P(DF,":")_":",P2=$P(DF,":",2) + . E S P1="",P2=DF + . I P1="",P2["$" S P1=P2,P2="" ;Could be a logical + . I $L(P2) S:P2'["[" P2="["_P2 S:P2'["]" P2=P2_"]" + . S DF=P1_P2 S:DF'[":" DF=DF_":" + . Q + ;Check syntax, Unix needs /mnt/fl, ./fl + I %ZOS="UNIX" D + . S DF=$TR(DF,"\","/") + . S:$E(DF,$L(DF))'="/" DF=DF_"/" + . Q + ;Check syntax, NT needs c:\dir\ + I %ZOS="NT" D + . N P1,P2 + . I DF[":" S P1=$P(DF,":")_":",P2=$P(DF,":",2) + . E S P1="",P2=DF + . S P2=$TR(P2,"/","\") + . I $L(P2) S:".\"'[$E(P2,1) P2="\"_P2 S:$E(P2,$L(P2))'="\" P2=P2_"\" + . S DF=P1_P2 + . Q + S DF=$$TRNLNM(DF) ;Resolve logicals + Q DF + ; +FL(X) ;Fl len + N ZOSHP1,ZOSHP2 + S ZOSHP1=$P(X,"."),ZOSHP2=$P(X,".",2) + I $L(ZOSHP1)>8 S X=4 Q + I $L(ZOSHP2)>3 S X=4 Q + Q + ; +STATUS() ;ef,SR. Return EOF status + U $I + Q $$EOF($ZEOF) + ; +EOF(X) ;Eof flag, pass in $ZEOF + Q (X=-1) + ; +MAKEREF(HF,IX,OVF) ;Internal call to rebuild global ref. + ;Return %ZISHF,%ZISHO,%ZISHI,%ZISUB + N I,F,MX + S OVF=$G(OVF,"%ZISHOF") + S %ZISHI=$QS(HF,IX),MX=$QL(HF) ; + S F=$NA(@HF,IX-1) ;Get first part + I IX=1 S %ZISHF=F_"(%ZISHI" ;Build root, IX=1 + I IX>1 S %ZISHF=$E(F,1,$L(F)-1)_",%ZISHI" ;Build root + S %ZISHO=%ZISHF_","_OVF_",%OVFCNT)" ;Make overflow + F I=IX+1:1:MX S %ZISHF=%ZISHF_",%ZISUB("_I_")",%ZISUB(I)=$QS(HF,I) + S %ZISHF=%ZISHF_")" + Q + ; +READNXT(REC) ;Read any sized record into array. %ZB has terminator + N %,I,X,$ES,$ET S REC="",$ET="D READNX^%ZISH Q" + U IO R X:5 S %ZB=$A($ZB),REC=$E(X,1,255) + Q:$L(X)<256 + S %=256 F I=1:1 Q:$L(X)<% S REC(I)=$E(X,%,%+254),%=%+255 + Q +READNX ;Check for EOF + I $ZE["ENDOFFILE" S %ZA=-1 + S $EC="" + Q + ; +FTG(%ZX1,%ZX2,%ZX3,%ZX4,%ZX5) ;ef,SR. Unload contents of host file into global + ;p1=hostf file directory + ;p2=host file name + ;p3= $NAME REFERENCE INCLUDING STARTING SUBSCRIPT + ;p4=INCREMENT SUBSCRIPT + ;p5=Overflow subscript, defaults to "OVF" + N %ZA,%ZB,%ZC,X,%OVFCNT,%ZISHF,%ZISHO,POP,%ZISUB,$ES,$ET + N I,%ZISH,%ZISH1,%ZISHI,%ZISHL,%ZISHOF,%ZISHOX,%ZISHS,%ZX,%ZISHY + S %ZX1=$$DEFDIR($G(%ZX1)),%ZISHOF=$G(%ZX5,"OVF") + D MAKEREF(%ZX3,%ZX4,"%ZISHOF") + D OPEN^%ZISH(,%ZX1,%ZX2,"R") + I POP Q 0 + S %ZC=1,%ZA=0,$ET="S %ZC=0,%ZA=-1,$EC="""" Q" + U IO F K %XX D READNXT(.%XX) Q:$$EOF($ZEOF)!%ZA D + . S @%ZISHF=%XX + . I $D(%XX)>2 F %OVFCNT=1:1 Q:'$D(%XX(%OVFCNT)) S @%ZISHO=%XX(%OVFCNT) + . S %ZISHI=%ZISHI+1 + . Q + D CLOSE() ;Normal exit + Q %ZC + ; +GTF(%ZX1,%ZX2,%ZX3,%ZX4) ;ef,SR. Load contents of global to host file. + ;p1=$NAME of global reference + ;p2=incrementing subscript + ;p3=host file directory + ;p4=host file name + N %ZISHY,%ZISHOX + S %ZISHY=$$MGTF(%ZX1,%ZX2,%ZX3,%ZX4,"W") + Q %ZISHY + ; +GATF(%ZX1,%ZX2,%ZX3,%ZX4) ;ef,SR. Append to host file. + ; + ;p1=$NAME of global reference + ;p2=incrementing subscript + ;p3=host file directory + ;p4=host file name + N %ZISHY + S %ZISHY=$$MGTF(%ZX1,%ZX2,%ZX3,%ZX4,"A") + Q %ZISHY + ; +MGTF(%ZX1,%ZX2,%ZX3,%ZX4,%ZX5) ; + ;p1=$NAME of global reference + ;p2=incrementing subscript + ;p3=host file directory + ;p4=host file name + N %ZISH,%ZISH1,%ZISHI,%ZISHL,%ZISHS,%ZISHOX,IO,%ZX,Y,%ZC + D MAKEREF(%ZX1,%ZX2) + D OPEN^%ZISH(,$G(%ZX3),%ZX4,%ZX5) ;Default dir set in open + I POP Q 0 + N $ETRAP S $ETRAP="S $EC="""" D CLOSE^%ZISH() Q 0" + F Q:'($D(@%ZISHF)#2) S %ZX=@%ZISHF,%ZISHI=%ZISHI+1 U IO W %ZX,! + D CLOSE() + Q 1 + ; diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZISS1.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZISS1.m index 63fc0895..e1006a9c 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZISS1.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZISS1.m @@ -1,88 +1,69 @@ -%ZISS1 ;AC/SFISC - Collect screen parameters 5/29/88 2:02 PM ;1/24/08 16:10 - ;;8.0;KERNEL;**69,440**;JUL 10, 1995;Build 13 - ;Per VHA Directive 2004-038, this routine should not be modified -VALID ; - N %ZISI,%ZISNP,ZISCH,ZISEND,ZISNUM,ZISQ,ZISXL,ZISXLN ;p440 - D L - Q - ; -SET2 ; - S %ZISFN="" F %ZISZ=0:0 S %ZISFN=$O(%ZISZ(%ZISFN)) Q:%ZISFN="" I $D(%ZISZ(%ZISFN))#2 S %ZISXX=%ZISZ(%ZISFN) D INDCK - Q -INDCK ; - S %ZISY="" - I "IOEFLD^IOSTBM"[%ZISFN S @%ZISFN=%ZISXX Q - I %ZISXX]"" S @("%ZISY="_%ZISXX) - ;E S @("%ZISY="_"""""") - I $E(%ZISFN,1,2)="IO" S @%ZISFN=%ZISY - E S @("IO"_$E(%ZISFN,1,6))=%ZISY - Q:'$D(%ZIS)#2 Q:%ZIS'["I" Q:'$D(%ZISZ(%ZISFN,1)) - ; -SRAY ; - S %=%ZISY,%ZISY=$A($E(%ZISY,1)) - F %1=2:1:$L(%) S %ZISY=%ZISY_$S($A(%,%1)<32:$A(%,%1),$A(%,%1)=127:127,1:$E(%,%1)) - S IOIS(%ZISY)=%ZISFN - Q -CHECK ;Entry point called from input transforms of fields in DEV/TT files. - N %ZISXX,%ZISYY,%ZISI,%ZISNP,%ZISX1,%ZISX2,ZISCH,ZISNUM,ZISQ,ZISXL,ZISXLN ;p440 - S %ZISXX=X D L S X=%ZISYY - Q -CHECK1 ;Entry point called from input transforms of fields in DEV/TT files. - N %ZISXX,%ZISYY,%ZISI,%ZISNP,%ZISX1,%ZISX2,ZISCH,ZISNUM,ZISQ,ZISXL,ZISXLN ;p440 - S %ZISXX=$S(X?1"W ".E:$E(X,3,$L(X)),1:X) - D L S X=$S(X?1"W ".E:"W "_%ZISYY,1:%ZISYY) - Q -FORM ;Entry point called from input transforms of fields in DEV/TT files. - Q:$L(X,"_")'>1 - N %ZISSI,%ZISSY ;p440 - ;F %ZISSI=1:1:$L(X,"_") S %ZISX1=$P(X,"_",%ZISSI) I %ZISX1]"","#?!"[$E(%ZISX1) S X=$S(%ZISSI=1:"",1:$P(X,"_",1,%ZISSI-1)_",")_%ZISX1_$S(%ZISSI<$L(X,"_"):","_$P(X,"_",%ZISSI+1,255),1:"") W !,%ZISSI_"==>"_X - S %ZISSY="" - F %ZISSI=1:1:$L(X,"_") S %ZISSY=%ZISSY_$P(X,"_",%ZISSI)_$S($P(X,"_",%ZISSI+1)="":"","#?!"[$E($P(X,"_",%ZISSI+1)):",","#?!"[$E($P(X,"_",%ZISSI)):",",1:"_") - S X=%ZISSY - Q - ; -L S ZISQ="""",%ZISNP=0,ZISXLN=$L(%ZISXX) I 'ZISXLN S %ZISYY="" Q - S ZISXL=0,%ZISYY="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) D L1 Q:ZISXL'2,%ZISYY[")_$C(" S %ZISXX=%ZISYY D L2,L3 S %ZISYY=%ZISXX Q - S %ZISXX=%ZISYY D L2,L3 S %ZISYY=%ZISXX - Q -L1 I ZISCH="_"!(ZISCH=",") S %ZISYY=%ZISYY_"_" Q - I ZISCH=ZISQ D QUOTE Q - I ZISCH="$" D DOLR Q - I ZISCH="*" D STAR Q - I ZISCH="(" D PAREN Q - S %ZISYY=%ZISYY_ZISCH - Q -L2 ;Find $C(x)_$C(y) and merge - N I ;p440 - F I=1:1:$L(%ZISXX,"_") S %ZISX1=$P(%ZISXX,"_",I),%ZISX2=$P(%ZISXX,"_",I+1) I $E(%ZISX1,1,3)="$C(",$E(%ZISX2,1,3)="$C(" D S2 - Q -L3 ; - N I - F I=1:1:$L(%ZISXX,"_") I $P(%ZISXX,"_",I)["+","$("'[$E($P(%ZISXX,"_",I)),")"'[$E($P(%ZISXX,"_",I),$L($P(%ZISXX,"_",I))) S $P(%ZISXX,"_",I)="("_$P(%ZISXX,"_",I)_")" - Q -STAR ;S ZISNUM="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) S:ZISCH?1N ZISNUM=ZISNUM_ZISCH I ZISCH=""!(ZISCH=",") S %ZISYY=%ZISYY_"$C("_+ZISNUM_")",ZISXL=ZISXL-1 Q - S ZISNUM="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) S:ZISCH'=""&(ZISCH'=",") ZISNUM=ZISNUM_ZISCH I ZISCH=""!(ZISCH=",") S %ZISYY=%ZISYY_"$C("_ZISNUM_")",ZISXL=ZISXL-1 Q - Q -QUOTE S %ZISYY=%ZISYY_ZISCH F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL),%ZISYY=%ZISYY_ZISCH I ZISCH=ZISQ!(ZISXL'1 + ;F %ZISSI=1:1:$L(X,"_") S %ZISX1=$P(X,"_",%ZISSI) I %ZISX1]"","#?!"[$E(%ZISX1) S X=$S(%ZISSI=1:"",1:$P(X,"_",1,%ZISSI-1)_",")_%ZISX1_$S(%ZISSI<$L(X,"_"):","_$P(X,"_",%ZISSI+1,255),1:"") W !,%ZISSI_"==>"_X + S %ZISSY="" + F %ZISSI=1:1:$L(X,"_") S %ZISSY=%ZISSY_$P(X,"_",%ZISSI)_$S($P(X,"_",%ZISSI+1)="":"","#?!"[$E($P(X,"_",%ZISSI+1)):",","#?!"[$E($P(X,"_",%ZISSI)):",",1:"_") + S X=%ZISSY K %ZISSI,%ZISSY + Q + ; +L S ZISQ="""",%ZISNP=0,ZISXLN=$L(%ZISXX) I 'ZISXLN S %ZISYY="" Q + S (ZISXL)=0,%ZISYY="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) D L1 Q:ZISXL'2,%ZISYY[")_$C(" S %ZISXX=%ZISYY D L2,L3 S %ZISYY=%ZISXX Q + S %ZISXX=%ZISYY D L2,L3 S %ZISYY=%ZISXX + Q +L1 I ZISCH="_"!(ZISCH=",") S %ZISYY=%ZISYY_"_" Q + I ZISCH=ZISQ D QUOTE Q + I ZISCH="$" D DOLR Q + I ZISCH="*" D STAR Q + I ZISCH="(" D PAREN Q + S %ZISYY=%ZISYY_ZISCH Q +L2 F I=1:1:$L(%ZISXX,"_") S %ZISX1=$P(%ZISXX,"_",I),%ZISX2=$P(%ZISXX,"_",I+1) I $E(%ZISX1,1,3)="$C(",$E(%ZISX2,1,3)="$C(" D S2 + Q +L3 F I=1:1:$L(%ZISXX,"_") I $P(%ZISXX,"_",I)["+","$("'[$E($P(%ZISXX,"_",I)),")"'[$E($P(%ZISXX,"_",I),$L($P(%ZISXX,"_",I))) S $P(%ZISXX,"_",I)="("_$P(%ZISXX,"_",I)_")" + Q +STAR ;S ZISNUM="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) S:ZISCH?1N ZISNUM=ZISNUM_ZISCH I ZISCH=""!(ZISCH=",") S %ZISYY=%ZISYY_"$C("_+ZISNUM_")",ZISXL=ZISXL-1 Q + S ZISNUM="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) S:ZISCH'=""&(ZISCH'=",") ZISNUM=ZISNUM_ZISCH I ZISCH=""!(ZISCH=",") S %ZISYY=%ZISYY_"$C("_ZISNUM_")",ZISXL=ZISXL-1 Q + Q +QUOTE S %ZISYY=%ZISYY_ZISCH F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL),%ZISYY=%ZISYY_ZISCH I ZISCH=ZISQ!(ZISXL'5 S ^%ZOSF("GSEL")="K ^CacheTempJ($J),^UTILITY($J) D ^%SYS.GSET M ^UTILITY($J)=CacheTempJ($J)" - W !!,"ALL SET UP",!! Q -Z ;; - ;;ACTJ - ;;S Y=$$ACTJ^%ZOSV() - ;;AVJ - ;;S Y=$$AVJ^%ZOSV() - ;;BRK - ;;U $I:("":"+B") - ;;DEL - ;;X "ZR ZS @X" - ;;EOFF - ;;U $I:("":"+S") - ;;EON - ;;U $I:("":"-S") - ;;EOT - ;;S Y=$ZA\1024#2 - ;;ERRTN - ;;^%ZTER - ;;ETRP - ;;Q - ;;GD - ;;D ^%GD - ;;GSEL;Select Globals - ;;K ^UTILITY($J) D ^%GSET - ;;JOBPARAM - ;;D JOBPAR^%ZOSV - ;;LABOFF - ;;U IO:("":"+S+I-T":$C(13,27)) - ;;LOAD - ;;N %,%N S %N=0 X "ZL @X F XCNP=XCNP+1:1 S %N=%N+1,%=$T(+%N) Q:$L(%)=0 S @(DIF_XCNP_"",0)"")=%" - ;;LPC - ;;S Y=$ZC(X) - ;;MAXSIZ - ;;S $ZS=X+X - ;;MGR - ;;%SYS - ;;MAGTAPE - ;;S %MT("BS")="*-1",%MT("FS")="*-2",%MT("WTM")="*-3",%MT("WB")="*-4",%MT("REW")="*-5",%MT("RB")="*-6",%MT("REL")="*-7",%MT("WHL")="*-8",%MT("WEL")="*-9" - ;;MTBOT - ;;S Y=$ZA\32#2 - ;;MTONLINE - ;;S Y=$ZA\64#2 - ;;MTWPROT - ;;S Y=$ZA\4#2 - ;;MTERR;;MAGTAPE ERROR - ;;S Y=$ZA\32768#2 - ;;NBRK - ;;U $I:("":"-B") - ;;NO-PASSALL - ;;U $I:("":"-I+T") - ;;NO-TYPE-AHEAD - ;;U $I:("":"+F":$C(13,27)) - ;;PASSALL - ;;U $I:("":"+I-T") - ;;PRIINQ;; Priority in current queue - ;;N %PRIO D ^%PRIO S Y=$S('%PRIO:5,%PRIO>0:8,1:3) - ;;PRIORITY;;set priority to X (1=low, 10=high) - ;;D @($S(X>7:"NORMAL",X>3:"NORMAL",1:"LOW")_"^%PRIO") ;Don't do HIGH - ;;PROGMODE - ;;S Y=$ZJOB#2 - ;;PROD - ;;VAH - ;;RD - ;;D ^%RD - ;;RESJOB - ;;N OLD S OLD=$ZNSPACE ZNSPACE "%SYS" D ^RESJOB ZNSPACE OLD Q - ;;RM - ;;I $G(IOT)["TRM" U $I:X - ;;RSEL;;ROUTINE SELECT - ;;K ^UTILITY($J) D KERNEL^%RSET K %ST ;Special entry point for VA - ;;RSUM - ;;N %,%1,%3 ZL @X S Y=0 F %=1,3:1 S %1=$T(+%),%3=$F(%1," ") Q:'%3 S %3=$S($E(%1,%3)'=";":$L(%1),$E(%1,%3+1)=";":$L(%1),1:%3-2) F %2=1:1:%3 S Y=$A(%1,%2)*%2+Y - ;;RSUM1 - ;;N %,%1,%3 ZL @X S Y=0 F %=1,3:1 S %1=$T(+%),%3=$F(%1," ") Q:'%3 S %3=$S($E(%1,%3)'=";":$L(%1),$E(%1,%3+1)=";":$L(%1),1:%3-2) F %2=1:1:%3 S Y=$A(%1,%2)*(%2+%)+Y - ;;SS - ;;D ^%SS - ;;SAVE - ;;N XCS S XCS="F XCM=1:1 S XCN=$O(@(DIE_XCN_"")"")) Q:+XCN'=XCN S %=^(XCN,0) Q:$E(%,1)=""$"" I $E(%,1)'="";"" ZI %" X "ZR X XCS ZS @X" - ;;SIZE - ;;S Y=0 F I=1:1 S %=$T(+I) Q:%="" S Y=Y+$L(%)+2 - ;;TEST - ;;I X?1(1"%",1A).7AN,$D(^$ROUTINE(X)) - ;;TMK;;MAGTAPE MARK - ;;S Y=$ZA\4#2 - ;;TRAP;;S X="^%ET",@^%ZOSF("TRAP"); User $ETRAP - ;;$ZT=X - ;;TRMOFF - ;;U $I:("":"-I-T":$C(13,27)) - ;;TRMON - ;;U $I:("":"+I+T") - ;;TRMRD;;old Y=$A($ZB),Y=$S(Y<32:Y,Y=127:Y,1:0) - ;;S Y=$A($ZB),Y=$S(Y<32:Y,Y=127:Y,1:0) - ;;TYPE-AHEAD - ;;U $I:("":"-F":$C(13,27)) - ;;UCI - ;;D UCI^%ZOSV - ;;UCICHECK - ;;S Y=$$UCICHECK^%ZOSV(X) - ;;UPPERCASE - ;;S Y=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") - ;;XY - ;;S $X=DX,$Y=DY - ;;VOL;;VOLUME SET NAME - ;;ROU - ;;ZD;;$H to external - ;;S Y=$ZD(X) +ZOSFONT ;SFISC/AC - SETS UP ^%ZOSF FOR Open M for NT ;09/29/98 08:26 + ;;8.0;KERNEL;**34,104**;JUL 03, 1995 + S %Y=1 K ^%ZOSF("MASTER"),^%ZOSF("SIGNOFF") + K ZO F I="MGR","PROD","VOL" S:$D(^%ZOSF(I)) ZO(I)=^%ZOSF(I) + F I=1:2 S Z=$P($T(Z+I),";;",2) Q:Z="" S X=$P($T(Z+1+I),";;",2,99) S ^%ZOSF(Z)=$S($D(ZO(Z)):ZO(Z),1:X) +MGR W !,"NAME OF MANAGER'S NAMESPACE: "_^%ZOSF("MGR")_"// " R X:$S($G(DTIME):DTIME,1:9999) I X]"" X ^("UCICHECK") G MGR:Y="" S ^%ZOSF("MGR")=X +PROD W !,"PRODUCTION (SIGN-ON) NAMESPACE: "_^%ZOSF("PROD")_"// " R X:$S($G(DTIME):DTIME,1:9999) I X]"" X ^("UCICHECK") G PROD:Y="" S ^%ZOSF("PROD")=Y +VOL W !,"NAME OF THIS CONFIGURATION: "_^%ZOSF("VOL")_"//" R X:$S($G(DTIME):DTIME,1:9999) I X]"" S:X?1.5U ^%ZOSF("VOL")=X I X'?1.5U W "MUST BE 1-5 uppercase characters." G VOL +OS S $P(^%ZOSF("OS"),"^",1)="OpenM-NT" S:'$P(^%ZOSF("OS"),"^",2) $P(^%ZOSF("OS"),"^",2)=18 + W !!,"ALL SET UP",!! Q +Z ;; + ;;ACTJ + ;;S Y=$$ACTJ^%ZOSV() + ;;AVJ + ;;S Y=$$AVJ^%ZOSV() + ;;BRK + ;;U $I:("":"+B") + ;;DEL + ;;X "ZR ZS @X" K ^UTILITY("ROU",X) + ;;EOFF + ;;U $I:("":"+S") + ;;EON + ;;U $I:("":"-S") + ;;EOT + ;;S Y=$ZA\1024#2 + ;;ERRTN + ;;^%ZTER + ;;ETRP + ;;Q + ;;GD + ;;D ^%GD + ;;JOBPARAM + ;;D JOBPAR^%ZOSV + ;;LABOFF + ;;U IO:("":"+S+I-T":$C(13,27)) + ;;LOAD + ;;S %N=0 X "ZL @X F XCNP=XCNP+1:1 S %N=%N+1,%=$T(+%N) Q:$L(%)=0 S @(DIF_XCNP_"",0)"")=%" + ;;LPC + ;;S Y=$ZC(X) + ;;MAXSIZ + ;;S $ZS=X+X + ;;MGR + ;;%SYS + ;;MAGTAPE + ;;S %MT("BS")="*-1",%MT("FS")="*-2",%MT("WTM")="*-3",%MT("WB")="*-4",%MT("REW")="*-5",%MT("RB")="*-6",%MT("REL")="*-7",%MT("WHL")="*-8",%MT("WEL")="*-9" + ;;MTBOT + ;;S Y=$ZA\32#2 + ;;MTONLINE + ;;S Y=$ZA\64#2 + ;;MTWPROT + ;;S Y=$ZA\4#2 + ;;MTERR;;MAGTAPE ERROR + ;;S Y=$ZA\32768#2 + ;;NBRK + ;;U $I:("":"-B") + ;;NO-PASSALL + ;;U $I:("":"-I+T") + ;;NO-TYPE-AHEAD + ;;U $I:("":"+F":$C(13,27)) + ;;PASSALL + ;;U $I:("":"+I-T") + ;;PRIINQ;; Priority in current queue + ;;N %PRIO D ^%PRIO S Y=$S('%PRIO:5,%PRIO>0:8,1:3) + ;;PRIORITY;;set priority to X (1=low, 10=high) + ;;D @($S(X>7:"NORMAL",X>3:"NORMAL",1:"LOW")_"^%PRIO") ;Don't do HIGH + ;;PROGMODE + ;;S Y=$ZJ#2 + ;;PROD + ;;VAH + ;;RD + ;;D ^%RD + ;;RESJOB + ;;Q:'$D(DUZ) Q:'$D(^XUSEC("XUMGR",+DUZ)) N XQZ S XQZ="^RESJOB[MGR]" D DO^%XUCI + ;;RM + ;;U $I:X + ;;RSEL;;ROUTINE SELECT + ;;K ^UTILITY($J) D KERNEL^%RSET K %ST ;Special entry point for VA + ;;RSUM + ;;ZL @X S Y=0 F %=1,3:1 S %1=$T(+%),%3=$F(%1," ") Q:'%3 S %3=$S($E(%1,%3)'=";":$L(%1),$E(%1,%3+1)=";":$L(%1),1:%3-2) F %2=1:1:%3 S Y=$A(%1,%2)*%2+Y + ;;SS + ;;D ^%SS + ;;SAVE + ;;S XCS="F XCM=1:1 S XCN=$O(@(DIE_XCN_"")"")) Q:+XCN'=XCN S %=^(XCN,0) Q:$E(%,1)=""$"" I $E(%,1)'="";"" ZI %" X "ZR X XCS ZS @X" S ^UTILITY("ROU",X)="" K XCS + ;;SIZE + ;;S Y=0 F I=1:1 S %=$T(+I) Q:%="" S Y=Y+$L(%)+2 + ;;TEST + ;;I X?1(1"%",1A).7AN,$D(^$ROUTINE(X)) + ;;TMK;;MAGTAPE MARK + ;;S Y=$ZA\4#2 + ;;TRAP;;S X="^%ET",@^%ZOSF("TRAP") TO SET ERROR TRAP + ;;$ZT=X + ;;TRMOFF + ;;U $I:("":"-I-T":$C(13,27)) + ;;TRMON + ;;U $I:("":"+I+T") + ;;TRMRD + ;;S Y=$A($ZB),Y=$S(Y<32:Y,Y=127:Y,1:0) + ;;TYPE-AHEAD + ;;U $I:("":"-F":$C(13,27)) + ;;UCI + ;;D UCI^%ZOSV + ;;UCICHECK + ;;S Y=$$UCICHECK^%ZOSV(X) + ;;UPPERCASE + ;;S Y=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") + ;;XY + ;;S $X=DX,$Y=DY + ;;VOL;;VOLUME SET NAME + ;;ROU + ;;ZD + ;;S Y=$ZD(X) diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZOSVONT.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZOSVONT.m index 6e972e5a..5e34d01c 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZOSVONT.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZOSVONT.m @@ -1,169 +1,164 @@ -%ZOSV ;SFISC/AC - $View commands for Open M for NT. ;03/03/2008 - ;;8.0;KERNEL;**34,94,107,118,136,215,293,284,385,425,440**;Jul 10, 1995;Build 13 - ;Per VHA Directive 2004-038, this routine should not be modified -ACTJ() ;# Active jobs - N %,V,Y S V=$$VERSION() - I V<5 D Q Y - . S %=0 F Y=0:1 S %=$ZJOB(%) Q:%="" - S Y=$system.License.LUConsumed() ;Cache 5 up - Q Y -AVJ() ;# available jobs - N %,AVJ,V,ZOSV,$ET - S V=+$$VERSION() - ;Cache 3 and 4 - ;maxpid: from %SS - I V<5 D Q AVJ - . N PORT,T,X,MAXPID,LMFLIM - . S $ET="",MAXPID=$V($ZU(40,2,118),-2,4) - . X "S ZOSV=$ZU(5),%=$ZU(5,""%SYS"") S LMFLIM=$$inquire^LMFCLI,%=$ZU(5,ZOSV)" ;Get the license info - . ;Add together the enterprise and division licenses avaliable - . S X=$P(LMFLIM,";",2)+$P($P(LMFLIM,"|",2),";",2) - . S T=+LMFLIM+$P(LMFLIM,"|",2) ;Check the license total - . S AVJ=$S(T1 S %=ZTSK K ZTSK S ZTSK=% - I ZTSK<1!(ZTSK\1'=ZTSK) S ZTSK="",ZTSK(0)="",ZTSK("E")="IT" G QUIT - S ZTSK(0)="",ZTSK("E")="U",$ET="Q:$ES S $EC="""" G QUIT^%ZTLOAD4" - S %ZTVOL=^%ZOSF("VOL") - I $D(ZTCPU)[0 S ZTCPU=%ZTVOL - I ZTCPU="" S ZTCPU=%ZTVOL - I ZTCPU'=%ZTVOL G THERE - ; -HERE ;lookup task's status on current volume set - L +^%ZTSK(ZTSK):1 - I $D(^%ZTSK(ZTSK,0))[0 S ZTSK("E")="I" G QUIT - S ZTREC=^%ZTSK(ZTSK,0),ZTD=$G(^(.04)) - S ZTSK("DUZ")=$P(ZTREC,U,3),ZTSK("D")=$P(ZTREC,U,6) ;scheduled $H - I ZTD]"",$D(^%ZTSCH(ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT - I ZTD]"",$D(^%ZTSCH("JOB",ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT - ; - S ZT1="" F S ZT1=$O(^%ZTSCH(ZT1)) Q:'ZT1 I $D(^(ZT1,ZTSK))#2 S ZTSK(0)=1 G QUIT - S ZT1="IO",ZT2="" F S ZT2=$O(^%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2="" F S ZT3=$O(^%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3="" I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT - S ZT1="JOB",ZT2="" F S ZT2=$O(^%ZTSCH(ZT1,ZT2)) Q:ZT2="" I $D(^(ZT2,ZTSK))#2 S ZTSK(0)=1 G QUIT - S ZT1="LINK",ZT2="" F S ZT2=$O(^%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2="" F S ZT3=$O(^%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3="" I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT - S ZTSK(0)=0 - ; -QUIT ;cleanup and quit - L:ZTSK -^%ZTSK(ZTSK) ;K %ZTCPU,%ZTM,%ZTM1,%ZTM2,%ZTMAST,%ZTVOL,X,Y,ZT,ZT1,ZT2,ZT3,ZTCPU,ZTD,ZTREC - I ZTSK(0)]"" K ZTSK("E") Q - I ZTSK("E")'="U" Q - S ZTSK("E",0)=$$EC^%ZOSV - Q - ; -THERE ;rest of code looks up task's status on some other volume set - N %ZTCPU,%ZTM,X,Y - ; -FILES ;find TaskMan files on the volume set to be searched - S %ZTCPU=$O(^%ZIS(14.5,"B",ZTCPU,"")) - I %ZTCPU="" S ZTSK("E")="IS" G QUIT - S %ZTM=$P(^%ZOSF("MGR"),",") - S %ZTM=$S($D(^%ZIS(14.5,%ZTCPU,0))[0:%ZTM,$P(^(0),U,6)="":%ZTM,1:$P(^(0),U,6)) - S X=%ZTM,Y=ZTCPU - S ZTSK("E")="LS",ZT=$D(^[X,Y]%ZTSK(0)),ZTSK("E")="U" ; check link - ; -SEARCH ;find out if task is queued on that volume set - I $D(^[X,Y]%ZTSK(ZTSK,0))[0 S ZTSK("E")="I" G QUIT - S ZTREC=^[X,Y]%ZTSK(ZTSK,0),ZTD=$G(^(.04)) - S ZTSK("DUZ")=$P(ZTREC,U,3),ZTSK("D")=$P(ZTREC,U,6) - I ZTD]"",$D(^[X,Y]%ZTSCH(ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT - I ZTD]"",$D(^[X,Y]%ZTSCH("JOB",ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT - ; - S ZT1="" F S ZT1=$O(^[X,Y]%ZTSCH(ZT1)) Q:'ZT1 I $D(^(ZT1,ZTSK))#2 S ZTSK(0)=1 G QUIT - S ZT1="IO",ZT2="" F S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2="" F S ZT3=$O(^[X,Y]%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3="" I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT - S ZT1="JOB",ZT2="" F S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)) Q:ZT2="" I $D(^(ZT2,ZTSK))#2 S ZTSK(0)=1 G QUIT - S ZT1="LINK",ZT2="" F S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2="" F S ZT3=$O(^[X,Y]%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3="" I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT - S ZTSK(0)=0 G QUIT - ; +%ZTLOAD4 ;SEA/RDS-TaskMan: P I: Is Queued? ;7/26/91 11:55 ; + ;;8.0;KERNEL;;JUL 10, 1995 + ;;7.0; + ; +INPUT ;check input parameters for error conditions + I $D(ZTSK)[0 S ZTSK="" + I $D(ZTSK)>1 S ZTLOAD=ZTSK K ZTSK S ZTSK=ZTLOAD K ZTLOAD + I ZTSK<1!(ZTSK\1'=ZTSK) S ZTSK="",ZTSK(0)="",ZTSK("E")="IT" G QUIT + S ZTSK(0)="",ZTSK("E")="U",X="QUIT^%ZTLOAD3",@^%ZOSF("TRAP") + S %ZTVOL=^%ZOSF("VOL") + I $D(ZTCPU)[0 S ZTCPU=%ZTVOL + I ZTCPU="" S ZTCPU=%ZTVOL + I ZTCPU'=%ZTVOL G THERE + ; +HERE ;lookup task's status on current volume set + L +^%ZTSK(ZTSK) I $D(^%ZTSK(ZTSK,0))[0 S ZTSK("E")="I" G QUIT + S ZTREC=^%ZTSK(ZTSK,0),ZTD=$P(ZTREC,U,6) + S ZTSK("DUZ")=$P(ZTREC,U,3),ZTSK("D")=ZTD + I ZTD]"",$D(^%ZTSCH(ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT + I ZTD]"",$D(^%ZTSCH("JOB",ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT + ; + S ZT1="" F ZT=0:0 S ZT1=$O(^%ZTSCH(ZT1)) Q:'ZT1 I $D(^(ZT1,ZTSK))#2 S ZTSK(0)=1 G QUIT + S ZT1="IO",ZT2="" F ZT=0:0 S ZT2=$O(^%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2="" F ZT=0:0 S ZT3=$O(^%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3="" I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT + S ZT1="JOB",ZT2="" F ZT=0:0 S ZT2=$O(^%ZTSCH(ZT1,ZT2)) Q:ZT2="" I $D(^(ZT2,ZTSK))#2 S ZTSK(0)=1 G QUIT + S ZT1="LINK",ZT2="" F ZT=0:0 S ZT2=$O(^%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2="" F ZT=0:0 S ZT3=$O(^%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3="" I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT + S ZTSK(0)=0 + ; +QUIT ;cleanup and quit + L:ZTSK -^%ZTSK(ZTSK) K %ZTCPU,%ZTM,%ZTM1,%ZTM2,%ZTMAST,%ZTVOL,X,Y,ZT,ZT1,ZT2,ZT3,ZTCPU,ZTD,ZTREC + I ZTSK(0)]"" K ZTSK("E") Q + I ZTSK("E")'="U" Q + S ZTSK("E",0)=$$EC^%ZOSV + Q + ; +THERE ;rest of code looks up task's status on some other volume set + ; +FILES ;find TaskMan files on the volume set to be searched + S %ZTCPU=$O(^%ZIS(14.5,"B",ZTCPU,"")) + I %ZTCPU="" S ZTSK("E")="IS" G QUIT + S %ZTM=$P(^%ZOSF("MGR"),",") + S %ZTM=$S($D(^%ZIS(14.5,%ZTCPU,0))[0:%ZTM,$P(^(0),U,6)="":%ZTM,1:$P(^(0),U,6)) + S X=%ZTM,Y=ZTCPU + S ZTSK("E")="LS",ZT=$D(^[X,Y]%ZTSK(0)),ZTSK("E")="U" ; check link + ; +SEARCH ;find out if task is queued on that volume set + I $D(^[X,Y]%ZTSK(ZTSK,0))[0 S ZTSK("E")="I" G QUIT + S ZTREC=^[X,Y]%ZTSK(ZTSK,0),ZTD=$P(ZTREC,U,6) + S ZTSK("DUZ")=$P(ZTREC,U,3),ZTSK("D")=ZTD + I ZTD]"",$D(^[X,Y]%ZTSCH(ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT + I ZTD]"",$D(^[X,Y]%ZTSCH("JOB",ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT + ; + S ZT1="" F ZT=0:0 S ZT1=$O(^[X,Y]%ZTSCH(ZT1)) Q:'ZT1 I $D(^(ZT1,ZTSK))#2 S ZTSK(0)=1 G QUIT + S ZT1="IO",ZT2="" F ZT=0:0 S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2="" F ZT=0:0 S ZT3=$O(^[X,Y]%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3="" I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT + S ZT1="JOB",ZT2="" F ZT=0:0 S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)) Q:ZT2="" I $D(^(ZT2,ZTSK))#2 S ZTSK(0)=1 G QUIT + S ZT1="LINK",ZT2="" F ZT=0:0 S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2="" F ZT=0:0 S ZT3=$O(^[X,Y]%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3="" I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT + S ZTSK(0)=0 G QUIT + ; diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS.m index f38ba8c3..50765947 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS.m @@ -1,99 +1,91 @@ -%ZIS ;SFISC/AC,RWF -- DEVICE HANDLER ;1/24/08 16:06 - ;;8.0;KERNEL;**18,23,69,112,199,191,275,363,440**;JUL 10, 1995;Build 13 - ;Per VHA Directive 2004-038, this routine should not be modified - N %ZISOS,%ZISV - S U="^",%ZISOS=$G(^%ZOSF("OS")),%ZISV=$G(^%ZOSF("VOL")) - ;Check SPOOLER special case first -INIT I $D(ZTQUEUED),$G(IOT)="SPL",$D(IO)#2,$D(IO(0))#2,IO]"",IO=IO(0),$D(IO(1,IO))#2,%ZISOS["VAX DSM"!(%ZISOS["M/VX"),$G(IOP)[ION!(IOP[IO) K %ZIS,%IS,IOP Q - ; - I '$D(%ZIS),$D(%IS) M %ZIS=%IS - S:'($D(%ZIS)#2) %ZIS="M" M %IS=%ZIS ;update %IS for now - I '$D(^XUTL("XQ",$J,"MIXED OS")) S ^XUTL("XQ",$J,"MIXED OS")=$$PRI^%ZOSV - S %ZIS("PRI")=$G(^XUTL("XQ",$J,"MIXED OS"),1) - ; - I $D(ZTQUEUED) D I '$D(IOP) S POP=1 G EXIT^%ZIS1 - .I $D(ZTIO)#2,ZTIO="" S:%IS'[0 %IS=%IS_"0",%ZIS=%ZIS_"0" - I '$D(ZTQUEUED),%IS["T",$P($G(IOP),";")="Q" S POP=1 G EXIT^%ZIS1 - N %,%A,%E,%H,%I,%X,%XX,%Y,%Z,%Z1,%Z2,%Z9,%Z90,%Z91,%Z95,%ZISB,%ZTIME,%ZTYPE - N %ZHFN,%ZISOLD,DTOUT,DUOUT - ;Save symbols to restore if don't open a device - D SYMBOL^%ZISUTL(0,$NA(%ZISOLD)) -A D CLEAN ;(p363) K IO("CLOSE"),IO("HFSIO") - K IO("P"),IO("Q"),IO("S"),IO("T") -K2 D K2^%ZIS1 - S %ZISB=%ZIS'["N",(%E,%H,POP)=0,%Y="" S:'$D(IO(0)) IO(0)=$I - I %ZISOS["VAX DSM",$I["SYS$INPUT:.;" S:%ZIS'[0 %IS=%IS_"0",%ZIS=%ZIS_"0" - ;I %IS["T"&(%IS["0") S (%H,%E)=0 G ^%ZIS1 - I $D(IOP),IOP=$I!(IOP="HOME")!(0[IOP),$D(^XUTL("XQ",$J,"IO")) D HOME K %IS,%Y,%ZIS,%ZISB,%ZISV,IOP Q - ;Don't worry about HOME if %ZIS[0 - D:%ZIS'[0 GETHOME G EXIT^%ZIS1:POP,^%ZIS1 ;Jump to next part - ; -GETHOME I $D(IO("HOME")),$P(IO("HOME"),"^",2)=IO(0) S (%E,%H)=+IO("HOME") Q - I $D(^XUTL("XQ",$J,"IOS")),$D(^("IO")),IO(0)=^("IO") S (%E,%H)=^("IOS") Q - ;CALL LINEPORT CODE HERE--- - S %=$$LINEPORT^%ZISUTL I % S (%E,%H)=% Q - S %ZISVT=$I D VTLKUP I '%E S %ZISVT=$I D VIRTUAL - I %ZISVT=""!(%E'>0) I %IS'[0 O IO(0)::0 I $T U IO(0) W !,"HOME DEVICE ("_$I_") DOES NOT EXIST IN THE DEVICE FILE",!,"PLEASE CONTACT YOUR SYSTEM MANAGER!",*7 - S %H=%E S:'%H&(%IS'[0) POP=1 S:(%H>0)&('$D(IO("HOME"))) IO("HOME")=%H_"^"_$I - Q -VIRTUAL ;See if a Virtual Terminal (LAT, TELNET) - ;Change the MSM check for telnet to work with v4.4 - I %ZISOS["MSM" X "I $P($ZV,""Version "",2)'<3 S %ZISVT=$ZDE(+%ZISVT) I %ZISVT?.E1""~""4.5N.E S %ZISVT=""TELNET""" - F %ZISI=$L(%ZISVT):-1:0 D:$D(^%ZIS(1,"C",%ZISVT)) Q:$S('%E:0,'$D(^%ZIS(1,%E,"TYPE")):0,^("TYPE")="VTRM":1,1:0) S %ZISVT=$E(%ZISVT,1,%ZISI) - .D VTLKUP Q:$S('%E:0,'$D(^%ZIS(1,%E,"TYPE")):0,^("TYPE")="VTRM":1,1:0) - .S %X=0 F %ZISX=%ZISV,"" Q:%X>0 S %X=0 F S %E=+$O(^%ZIS(1,"CPU",%ZISX_"."_%ZISVT,%X)) S %X=%E Q:%E'>0 I $G(^%ZIS(1,+%E,"TYPE"))="VTRM" Q - Q -VTLKUP F %ZISX=%ZISV,"" S %E=+$O(^%ZIS(1,"G","SYS."_%ZISX_"."_%ZISVT,0)) Q:%E S %E=+$O(^%ZIS(1,"CPU",%ZISX_"."_%ZISVT,0)) Q:%E - Q - ; -CURRENT N POP,%ZIS,%IS,%E,%H - S FF="#",SL=24,BS="*8",RM=80,(SUB,XY)="",%IS=0,%ZISOS=$G(^%ZOSF("OS")),%ZISV=$G(^("VOL")),POP=0 - D GETHOME K %E,%IS,%ZISI,%ZISOS,%ZISV,%ZISVT,%ZISX Q:POP - I $D(^%ZIS(1,%H,"SUBTYPE")) S SUB=+^("SUBTYPE") K %H - I $D(SUB),SUB,$D(^%ZIS(2,SUB,1)) S SUB=$S($D(^(0)):$P(^(0),"^"),1:""),FF=$P(^(1),"^",2),SL=$P(^(1),"^",3),BS=$P(^(1),"^",4),XY=$P(^(1),"^",5),RM=+^(1) - E S SUB="" - I $D(^%ZOSF("RM")) N X S X=RM X ^("RM") K %A - Q -HOME ;Entry point to establish IO* variables for home device. - D CLEAN ;(p363) - N X I '$D(^XUTL("XQ",$J,"IO")) S IOP="HOME" D ^%ZIS Q - D RESETVAR - I '$D(IO("C")),$G(IOM),IO=$I,$D(IO(1,IO)),$D(^%ZOSF("RM")) S X=+IOM X ^("RM") - Q - ;IO("Q") is checked by many routines after a call to ^%ZISC, so only clean on call to %ZIS. -CLEAN ;Cleanup env. Called from %ZISC also. - I $G(IOT)'="SPL" K IO("DOC"),IO("SPOOL") ;(p446) - I $G(IOT)'="HFS" K IO("HFSIO") ;p446 - S (IOPAR,IOUPAR)="" - Q - ; -RESETVAR ;Reset home IO* variables. - I '$D(^XUTL("XQ",$J,"IO")) Q - N % - F %="IO","IOBS","IOF","IOM","ION","IOS","IOSL","IOST","IOST(0)","IOT","IOXY","IOPAR","IOUPAR" I $D(^XUTL("XQ",$J,%))#2 S @%=^(%) - F %="IO(""IP"")","IO(""CLNM"")","IO(""DOC"")","IO(""HFSIO"")","IO(""SPOOL"")" I $D(^XUTL("XQ",$J,%))#2 S @%=^(%) - S POP=0,IO(0)=IO - Q -SAVEVAR ;Save home IO* variables, called from XUS1,%ZTMS3 - N % - F %="IO","IOBS","IOF","IOM","ION","IOS","IOSL","IOST","IOST(0)","IOT","IOXY","IOPAR","IOUPAR" I $D(@%) S ^XUTL("XQ",$J,%)=@% - F %="IO(""IP"")","IO(""CLNM"")","IO(""DOC"")","IO(""HFSIO"")","IO(""SPOOL"")" I $D(@%) S ^XUTL("XQ",$J,%)=@% - Q -ZISLPC Q ;No longer called in Kernel v8. - ; -HLP1 G EN1^%ZIS7 -HLP2 N %E,%H,%X,%ZISV,X S %ZISV=$S($D(^%ZOSF("VOL")):^("VOL"),1:"") G EN2^%ZIS7 - ; -REWIND(IO2,IOT,IOPAR) ;Rewind Device - N %,X,Y,$ES,$ET S $ET="D REWERR^%ZIS Q 0" - S %=$I - I '($D(IO2)#2)!'$D(IOT)!'$D(IOPAR) Q 0 - I "MT^SDP^HFS"'[IOT Q 0 - S @("Y=$$REW"_IOT_"^%ZIS4(IO2,IOPAR)") - U % - Q Y -REWERR ;Error encountered - S IO("ERROR")=$EC - S $EC="",$ET="Q:$ES>1 S $EC="""" Q 0" S $EC=",U1," - Q 0 - ; +%ZIS ;SFISC/AC,RWF -- DEVICE HANDLER ;10/14/2004 08:46 + ;;8.0;KERNEL;**18,23,69,112,199,191,275,363**;JUL 10, 1995 + N %ZISOS,%ZISV + S U="^",%ZISOS=$G(^%ZOSF("OS")),%ZISV=$G(^%ZOSF("VOL")) + ;Check SPOOLER special case first +INIT I $D(ZTQUEUED),$G(IOT)="SPL",$D(IO)#2,$D(IO(0))#2,IO]"",IO=IO(0),$D(IO(1,IO))#2,%ZISOS["VAX DSM"!(%ZISOS["M/VX"),$G(IOP)[ION!(IOP[IO) K %ZIS,%IS,IOP Q + ; + I '$D(%ZIS),$D(%IS) M %ZIS=%IS + S:'($D(%ZIS)#2) %ZIS="M" M %IS=%ZIS ;update %IS for now + ; + I $D(ZTQUEUED) D I '$D(IOP) S POP=1 G EXIT^%ZIS1 + .I $D(ZTIO)#2,ZTIO="" S:%IS'[0 %IS=%IS_"0",%ZIS=%ZIS_"0" + I '$D(ZTQUEUED),%IS["T",$P($G(IOP),";")="Q" S POP=1 G EXIT^%ZIS1 + N %,%A,%E,%H,%I,%X,%XX,%Y,%Z,%Z1,%Z9,%Z90,%Z91,%Z95,%ZISB,%ZTIME,%ZTYPE + N %ZHFN,%ZISOLD,DTOUT,DUOUT + ;Save symbols to restore if don't open a device + D SYMBOL^%ZISUTL(0,$NA(%ZISOLD)) +A D CLEAN ;(p363) K IO("CLOSE"),IO("HFSIO") + K IO("P"),IO("Q"),IO("S"),IO("T") +K2 D K2^%ZIS1 + S %ZISB=%ZIS'["N",(%E,%H,POP)=0,%Y="" S:'$D(IO(0)) IO(0)=$I + I %ZISOS["VAX DSM",$I["SYS$INPUT:.;" S:%ZIS'[0 %IS=%IS_"0",%ZIS=%ZIS_"0" + ;I %IS["T"&(%IS["0") S (%H,%E)=0 G ^%ZIS1 + I $D(IOP),IOP=$I!(IOP="HOME")!(0[IOP),$D(^XUTL("XQ",$J,"IO")) D HOME K %IS,%Y,%ZIS,%ZISB,%ZISV,IOP Q + ;Don't worry about HOME if %ZIS[0 + D:%ZIS'[0 GETHOME G EXIT^%ZIS1:POP,^%ZIS1 ;Jump to next part + ; +GETHOME I $D(IO("HOME")),$P(IO("HOME"),"^",2)=IO(0) S (%E,%H)=+IO("HOME") Q + I $D(^XUTL("XQ",$J,"IOS")),$D(^("IO")),IO(0)=^("IO") S (%E,%H)=^("IOS") Q + ;CALL LINEPORT CODE HERE--- + S %=$$LINEPORT^%ZISUTL I % S (%E,%H)=% Q + S %ZISVT=$I D VTLKUP I '%E S %ZISVT=$I D VIRTUAL + I %ZISVT=""!(%E'>0) I %IS'[0 O IO(0)::0 I $T U IO(0) W !,"HOME DEVICE DOES NOT EXIST IN THE DEVICE FILE",!,"PLEASE CONTACT YOUR SYSTEM MANAGER!",*7 + S %H=%E S:'%H&(%IS'[0) POP=1 S:(%H>0)&('$D(IO("HOME"))) IO("HOME")=%H_"^"_$I + Q +VIRTUAL ;See if a Virtual Terminal (LAT, TELNET) + ;Change the MSM check for telnet to work with v4.4 + I %ZISOS["MSM" X "I $P($ZV,""Version "",2)'<3 S %ZISVT=$ZDE(+%ZISVT) I %ZISVT?.E1""~""4.5N.E S %ZISVT=""TELNET""" + F %ZISI=$L(%ZISVT):-1:0 D:$D(^%ZIS(1,"C",%ZISVT)) Q:$S('%E:0,'$D(^%ZIS(1,%E,"TYPE")):0,^("TYPE")="VTRM":1,1:0) S %ZISVT=$E(%ZISVT,1,%ZISI) + .D VTLKUP Q:$S('%E:0,'$D(^%ZIS(1,%E,"TYPE")):0,^("TYPE")="VTRM":1,1:0) + .S %X=0 F %ZISX=%ZISV,"" Q:%X>0 S %X=0 F S %E=+$O(^%ZIS(1,"CPU",%ZISX_"."_%ZISVT,%X)) S %X=%E Q:%E'>0 I $G(^%ZIS(1,+%E,"TYPE"))="VTRM" Q + Q +VTLKUP F %ZISX=%ZISV,"" S %E=+$O(^%ZIS(1,"G","SYS."_%ZISX_"."_%ZISVT,0)) Q:%E S %E=+$O(^%ZIS(1,"CPU",%ZISX_"."_%ZISVT,0)) Q:%E + Q + ; +CURRENT N POP,%ZIS,%IS,%E,%H + S FF="#",SL=24,BS="*8",RM=80,(SUB,XY)="",%IS=0,%ZISOS=$G(^%ZOSF("OS")),%ZISV=$G(^("VOL")),POP=0 + D GETHOME K %E,%IS,%ZISI,%ZISOS,%ZISV,%ZISVT,%ZISX Q:POP + I $D(^%ZIS(1,%H,"SUBTYPE")) S SUB=+^("SUBTYPE") K %H + I $D(SUB),SUB,$D(^%ZIS(2,SUB,1)) S SUB=$S($D(^(0)):$P(^(0),"^"),1:""),FF=$P(^(1),"^",2),SL=$P(^(1),"^",3),BS=$P(^(1),"^",4),XY=$P(^(1),"^",5),RM=+^(1) + E S SUB="" + I $D(^%ZOSF("RM")) N X S X=RM X ^("RM") K %A + Q +HOME ;Entry point to establish IO* variables for home device. + D CLEAN ;(p363) + N X I '$D(^XUTL("XQ",$J,"IO")) S IOP="HOME" D ^%ZIS Q + D RESETVAR + I '$D(IO("C")),$G(IOM),IO=$I,$D(IO(1,IO)),$D(^%ZOSF("RM")) S X=+IOM X ^("RM") + Q + ;IO("Q") is checked by many routines after a call to ^%ZISC, so only clean on call to %ZIS. +CLEAN ;Cleanup env. Called from %ZISC also. + K IO("DOC"),IO("HFSIO"),IO("SPOOL") ;(p366) + S (IOPAR,IOUPAR)="" + Q + ; +RESETVAR ;Reset home IO* variables. + I '$D(^XUTL("XQ",$J,"IO")) Q + N % F %="IO","IOBS","IOF","IOM","ION","IOS","IOSL","IOST","IOST(0)","IOT","IOXY" I $D(^XUTL("XQ",$J,%))#2 S @%=^(%) + S POP=0,IO(0)=IO,(IOPAR,IOUPAR)="" + Q +SAVEVAR ;Save home IO* variables, called from XUS1 + N % F %="IO","IOBS","IOF","IOM","ION","IOS","IOSL","IOST","IOST(0)","IOT","IOXY" I $D(@%) S ^XUTL("XQ",$J,%)=@% + Q +ZISLPC Q ;No longer called in Kernel v8. + ; +HLP1 G EN1^%ZIS7 +HLP2 N %E,%H,%X,%ZISV,X S %ZISV=$S($D(^%ZOSF("VOL")):^("VOL"),1:"") G EN2^%ZIS7 + ; +REWIND(IO2,IOT,IOPAR) ;Rewind Device + N %,X,Y,$ES,$ET S $ET="D REWERR^%ZIS Q 0" + S %=$I + I '($D(IO2)#2)!'$D(IOT)!'$D(IOPAR) Q 0 + I "MT^SDP^HFS"'[IOT Q 0 + S @("Y=$$REW"_IOT_"^%ZIS4(IO2,IOPAR)") + U % + Q Y +REWERR ;Error encountered + S IO("ERROR")=$EC + S $EC="",$ET="Q:$ES>1 S $EC="""" Q 0" S $EC=",U1," + Q 0 + ; diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS1.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS1.m index b639c046..c98b3e05 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS1.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS1.m @@ -1,102 +1,93 @@ -%ZIS1 ;SFISC/AC,RWF -- DEVICE HANDLER (DEVICE INPUT) ;1/24/08 16:06 - ;;8.0;KERNEL;**18,49,69,104,112,199,391,440**;JUL 10, 1995;Build 13 - ;Per VHA Directive 2004-038, this routine should not be modified -MAIN ;Called from %ZIS with a GO - I '$D(IOP),$D(^%ZIS(1,%E,0)),'$P(^(0),"^",3) S %A=%H,%Z=^(0) D L2^%ZIS2 G EXIT -L1 ;Main Loop - I '$D(IOP),$D(IO("Q")),POP D AQUE^%ZIS3 K:%=2 IO("Q") S:%=2 %ZISB=$S(%IS'["N":2,1:0) I %=-1 S POP=1 G EXIT - S %E=%H,POP=0,%IS=%ZIS ;Reset %IS from %ZIS - I %IS'["Q",$D(XQNOGO) S POP=1 W:'$D(IOP) !,$C(7),"OUTPUT IS NEVER ALLOWED FOR THIS OPTION" G EXIT - D IOP:$D(IOP),R:'$D(IOP) - G EXIT:$D(DTOUT)!$D(DUOUT)!(POP&$D(IOP)),L1:POP&'$D(IOP) - D LKUP I %A'>0 S POP=1 D:'$D(DUOUT) MSG1 K DUOUT - I '$D(^%ZIS(1,%A,0)) D MSG1 K %ZISIOS S POP=1 - I POP G EXIT:$D(IOP),L1:'$D(IOP) - S %E=%A,%Z=^%ZIS(1,%A,0),%Z1=$G(^(1)) - I $D(%ZIS("S")) N Y S Y=%E D XS^ZISX S:'$T POP=1 G G:POP - W:'$D(IOP)&($P(%Z,"^",2)'=$I)&($P(%Z1,"^")]"") " ",$P(%Z1,"^") - D L2^%ZIS2 ;Call -G G L1:POP&'$D(IOP)&'($D(DTOUT)!$D(DUOUT)) ;Didn't get it - ; -EXIT ; - I POP G EX2 ;Did not get the device. - ;For type[TRM reset $X & $Y - I %ZTYPE["TRM",IO]"",$D(IO(1,IO)) U IO S:'(IO=IO(0)&'$D(IO("S"))&'$D(ZTQUEUED)) $X=0,$Y=0 - ;Do count of number of times device opened. Field 51. - I $L($G(IO)),$D(IO(1,IO))#2,$G(%ZISIOS) D - . S $P(^(5),"^",1)=$P($G(^%ZIS(1,%ZISIOS,5)),"^",1)+1 - I %ZIS["H" S IO(0)=IO,IO("HOME")=%ZISIOS_"^"_IO ;Make home device - I '$D(IO("Q")),$D(%ZISLOCK) S ^XUTL("XQ",$J,"lock",%ZISIOS)=%ZISLOCK - I $D(IO)#2,IO]"",$D(IO(1,IO))#2,$D(%Z1),$P(%Z1,"^",11) S IO(1,IO,"NOFF")=1 -EX2 ; - I %IS'[0,$G(IO(0))]"" U IO(0) ;Make sure return with home active - G SETVAR:'POP!(%IS["T"),KILVAR - ; -IOP ;Request with IOP set - S (%ZISVT,%X)=IOP S:%X'?1.UNP %X=$$UP(%X) I %X'="Q" D SETQ Q - S %IS=%IS_%X K IOP W %X D SETQ Q - ;Get ready to ask user for device -R I %IS["Q",$D(XQNOGO) W !,$C(7),"AT THIS TIME, OUTPUT MUST BE QUEUED" - S %A=$S($D(%IS("B")):%IS("B"),1:"HOME") ;Setup default - I %IS["P",%A="HOME",$D(^%ZIS(1,%E,99)),$D(^%ZIS(1,+^(99),0)) S %A=$P(^(0),"^",1) -RD W !,$S($D(%IS("A")):%IS("A"),1:"DEVICE: ") W:%A]"" %A,"// " D SBR S:%X="" %X=%A S %ZISVT=%X - I %X?2"?".E D EN2^%ZIS7 G R - I %X?1"?".E D EN1^%ZIS7 G R - I $D(DTOUT)!$D(DUOUT)!(%X'?.ANP)!($L($P(%X,";"))>31) S:%IS["T" IO="" S POP=1 Q - S:%X'?1.UNP %X=$$UP(%X) D SETQ G R:$T Q -SETQ S %Y=$P(%X,";",2,9),%X=$P(%X,";",1) S:$L(";"_%Y,";/")=2 IO("P")=$P(";"_%Y,";/",2) - I %IS["Q",%X="Q" S %X=%Y,%ZISVT=$P(%ZISVT,";",2,9),%ZISB=0,IO("Q")=1,%IS("A")="DEVICE: " S:$D(IOP) %Y=$P(%X,";",2,9),%X=$P(%X,";",1) - I $T,'$D(IOP) W "UEUE TO PRINT ON" Q ; Return $T value - Q -LKUP S %ZISMY=$P(%ZISVT,";",2,999),%ZISVT=$P(%ZISVT,";") - I %X="H" W:'$D(IOP) "ome" S %X=0 - I 0[%X!(%X="HOME")!(%X=$I) S %A=%H Q - I $E(%ZISVT)="`",$D(IOP) S %A=+$E(%ZISVT,2,999) I $G(^%ZIS(1,%A,0))]"" Q - S %A=0 I "P"[%X Q:$D(IOP)&('$D(^%ZIS(1,%E,99))) I $D(^%ZIS(1,%E,99)) S %A=+^(99) Q - I %X=" ",$D(DUZ)#2,$D(^DISV(+DUZ,"^%ZIS(1,")) S %A=^("^%ZIS(1,") Q - S %A=+$O(^%ZIS(1,"B",%ZISVT,0)) Q:%A>0 ;mixed case lookup - I %X'=%ZISVT S %A=+$O(^%ZIS(1,"B",%X,0)) Q:%A>0 ;uppercase lookup - D VTLKUP^%ZIS S %A=%E Q:%A>0 ;mixed case lookup - I %X'=%ZISVT S %ZISVT=%X D VTLKUP^%ZIS S %A=%E Q:%A>0 ;uppercase lookup - N %XX,%YY S %XX=%X D 1^%ZIS5 S %A=+%YY Q -SBR K DFOUT,DTOUT,DUOUT R %X:$S($D(DTIME)#2:DTIME,1:300) E W $C(7) S DTOUT=1 Q - S:%X="."!(%X="^") DUOUT=1,%X="" Q -LC S %X=$$UP(%X) - Q -LOW(%) Q $TR(%,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz") -UP(%) Q $TR(%,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") - ; - ;Call/Return % = 1 (yes), 2 (no) -1 (^) -YN W "? ",$P("Yes// ^No// ",U,%) -RYN R %X:$S($D(DTIME):DTIME,$D(%ZISDTIM):%ZISDTIM,1:300) E S DTOUT=1,%X=U W $C(7) - S:%X]""!'% %=$A(%X),%=$S(%=89:1,%=121:1,%=78:2,%=110:2,%=94:-1,1:0) - I '%,%X'?."?" W $C(7),"??",!?4,"ANSWER 'Yes' OR 'No': " G RYN - W:$X>73 ! W $P(" (Yes)^ (No)",U,%) - Q -MSG1 I '$D(IOP) W ?20,$C(7)," [DEVICE DOES NOT EXIST]" - Q -SETVAR ;Come here to setup the variables for the selected device - S:$D(IO)[0 IO="" G KILVAR:%IS["T"&(IO="") - I $G(%Z)="" S ION="Unknown device",POP=1 G KILVAR - S:IO'=IO(0)&($D(DUZ)#2) ^DISV(+DUZ,"^%ZIS(1,")=%E - S ION=$P(%Z,"^",1),IOM=+%Z91,IOF=$P(%Z91,"^",2),IOSL=$P(%Z91,"^",3),IOBS=$P(%Z91,"^",4),IOXY=$P(%Z91,"^",5) - I IOSL>65530 S IOSL=65530 ;Cache rolls $Y at 65535 - S IOT=%ZTYPE,IOST(0)=%ZISIOST(0),IOST=%ZISIOST,IOPAR=%ZISOPAR,IOUPAR=%ZISUPAR,IOHG=%ZISHG - S:IOF="" IOF="#" ;See that IOF has something - K IOCPU S:$D(%ZISCPU) IOCPU=%ZISCPU - G KIL - ; -KILVAR ;Come here to restore the calling variables - D SYMBOL^%ZISUTL(1,"%ZISOLD") - S:'$L($G(IOF)) IOF="#" S:'$D(IOST(0)) IOST(0)=0 - ;See that all standard variables are defined - F %I="IO","ION","IOM","IOBS","IOSL","IOST" S:$D(@%I)[0 @%I="" - K IO("HFSIO"),IO("OPEN") I $D(%ZISCPU) S:'$D(IOCPU) IOCPU=%ZISCPU -KIL ;Final exit cleanup - S:'POP IOS=%ZISIOS I POP K:%IS'["T" %ZISIOS I %IS["T" K IOS S:$D(%ZISIOS) IOS=%ZISIOS - S:%IS["T" IO("T")=1 K %ZIS,%IS,%A,%E,%H,%ZISOS,%ZISV,IOP -K2 K %I,%X,%Y,%Z,%Z1,%Z91,%Z95,%ZTYPE,%ZTIME - K %ZISCHK,%ZISCPU,%ZISI,%ZISR,%ZISVT,%ZISB,%ZISX,ZISI,%ZISHGL,%ZISHP,%ZISIO,%ZISIOS,%ZISIOM - K %ZISIOF,%ZISIOSL,%ZISIOBS,%ZISIOST,%ZISIOST(0),%ZISTO,%ZISTP,%ZISHG,%ZISSIO,%ZISOPEN,%ZISOPAR,%ZISUPAR - K %ZISMY,%ZISQUIT,%ZISLOCK - Q +%ZIS1 ;SFISC/AC,RWF -- DEVICE HANDLER (DEVICE INPUT) ;07/07/2005 15:48 + ;;8.0;KERNEL;**18,49,69,104,112,199,391**;JUL 10, 1995 +MAIN ;Called from %ZIS with a GO + I '$D(IOP),$D(^%ZIS(1,%E,0)),'$P(^(0),"^",3) S %A=%H,%Z=^(0) D L2^%ZIS2 G EXIT +L1 ;Main Loop + I '$D(IOP),$D(IO("Q")),POP D AQUE^%ZIS3 K:%=2 IO("Q") S:%=2 %ZISB=$S(%IS'["N":2,1:0) I %=-1 S POP=1 G EXIT + S %E=%H,POP=0,%IS=%ZIS ;Reset %IS from %ZIS + I %IS'["Q",$D(XQNOGO) S POP=1 W:'$D(IOP) !,*7,"OUTPUT IS NEVER ALLOWED FOR THIS OPTION" G EXIT + D IOP:$D(IOP),R:'$D(IOP) + G EXIT:$D(DTOUT)!$D(DUOUT)!(POP&$D(IOP)),L1:POP&'$D(IOP) + D LKUP I %A'>0 S POP=1 D:'$D(DUOUT) MSG1 K DUOUT + I POP G EXIT:$D(IOP),L1:'$D(IOP) + I '$D(^%ZIS(1,%A,0)) D MSG1 K %ZISIOS S POP=1 + I POP G EXIT:$D(IOP),L1:'$D(IOP) + S %E=%A,%Z=^%ZIS(1,%A,0),%Z1=$G(^(1)) + I $D(%ZIS("S")) N Y S Y=%E D XS^ZISX S:'$T POP=1 G G:POP + W:'$D(IOP)&($P(%Z,"^",2)'=$I)&($P(%Z1,"^")]"") " ",$P(%Z1,"^") + D L2^%ZIS2 +G G L1:POP&'$D(IOP)&'($D(DTOUT)!$D(DUOUT)) ;Didn't get it + ;For type[TRM reset $X & $Y + I 'POP,%ZTYPE["TRM",IO]"",$D(IO(1,IO)) U IO S:'(IO=IO(0)&'$D(IO("S"))&'$D(ZTQUEUED)) $X=0,$Y=0 + ; +EXIT I $D(IO)#2,IO]"",$D(IO(1,IO))#2,$D(%Z1),$P(%Z1,"^",11) S IO(1,IO,"NOFF")=1 + ;Do count of number of times device opened. Field 51. + I $L($G(IO)),$D(IO(1,IO))#2,'POP,$G(%ZISIOS) D + . S $P(^(5),"^",1)=$P($G(^%ZIS(1,%ZISIOS,5)),"^",1)+1 + I 'POP,%ZIS["H" S IO(0)=IO,IO("HOME")=%ZISIOS_"^"_IO ;Make home device + I %IS'[0,$G(IO(0))]"" U IO(0) ;Make sure return with home active + G SETVAR:'POP!(%IS["T"),KILVAR + ; +IOP ;Request with IOP set + S (%ZISVT,%X)=IOP S:%X'?1.UNP %X=$$UP(%X) I %X'="Q" D SETQ Q + S %IS=%IS_%X K IOP W %X D SETQ Q + ;Get ready to ask user for device +R I %IS["Q",$D(XQNOGO) W !,*7,"AT THIS TIME, OUTPUT MUST BE QUEUED" + S %A=$S($D(%IS("B")):%IS("B"),1:"HOME") ;Setup default + I %IS["P",%A="HOME",$D(^%ZIS(1,%E,99)),$D(^%ZIS(1,+^(99),0)) S %A=$P(^(0),"^",1) +RD W !,$S($D(%IS("A")):%IS("A"),1:"DEVICE: ") W:%A]"" %A,"// " D SBR S:%X="" %X=%A S %ZISVT=%X + I %X?2"?".E D EN2^%ZIS7 G R + I %X?1"?".E D EN1^%ZIS7 G R + I $D(DTOUT)!$D(DUOUT)!(%X'?.ANP)!($L($P(%X,";"))>31) S:%IS["T" IO="" S POP=1 Q + S:%X'?1.UNP %X=$$UP(%X) D SETQ G R:$T Q +SETQ S %Y=$P(%X,";",2,9),%X=$P(%X,";",1) S:$L(";"_%Y,";/")=2 IO("P")=$P(";"_%Y,";/",2) + I %IS["Q",%X="Q" S %X=%Y,%ZISVT=$P(%ZISVT,";",2,9),%ZISB=0,IO("Q")=1,%IS("A")="DEVICE: " S:$D(IOP) %Y=$P(%X,";",2,9),%X=$P(%X,";",1) + I $T,'$D(IOP) W "UEUE TO PRINT ON" Q ; Return $T value + Q +LKUP S %ZISMY=$P(%ZISVT,";",2,999),%ZISVT=$P(%ZISVT,";") + I %X="H" W:'$D(IOP) "ome" S %X=0 + I 0[%X!(%X="HOME")!(%X=$I) S %A=%H Q + I $E(%ZISVT)="`",$D(IOP) S %A=+$E(%ZISVT,2,999) I $G(^%ZIS(1,%A,0))]"" Q + S %A=0 I "P"[%X Q:$D(IOP)&('$D(^%ZIS(1,%E,99))) I $D(^%ZIS(1,%E,99)) S %A=+^(99) Q + I %X=" ",$D(DUZ)#2,$D(^DISV(+DUZ,"^%ZIS(1,")) S %A=^("^%ZIS(1,") Q + S %A=+$O(^%ZIS(1,"B",%ZISVT,0)) Q:%A>0 ;mixed case lookup + I %X'=%ZISVT S %A=+$O(^%ZIS(1,"B",%X,0)) Q:%A>0 ;uppercase lookup + D VTLKUP^%ZIS S %A=%E Q:%A>0 ;mixed case lookup + I %X'=%ZISVT S %ZISVT=%X D VTLKUP^%ZIS S %A=%E Q:%A>0 ;uppercase lookup + N %XX,%YY S %XX=%X D 1^%ZIS5 S %A=+%YY Q +SBR K DFOUT,DTOUT,DUOUT R %X:$S($D(DTIME)#2:DTIME,1:300) E W *7 S DTOUT=1 Q + S:%X="."!(%X="^") DUOUT=1,%X="" Q +LC S %X=$$UP(%X) + Q +LOW(%) Q $TR(%,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz") +UP(%) Q $TR(%,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") +YN W "? ",$P("YES// ^NO// ",U,%) +RYN R %X:$S($D(DTIME):DTIME,$D(%ZISDTIM):%ZISDTIM,1:300) E S DTOUT=1,%X=U W *7 + S:%X]""!'% %=$A(%X),%=$S(%=89:1,%=121:1,%=78:2,%=110:2,%=94:-1,1:0) + I '%,%X'?."?" W *7,"??",!?4,"ANSWER 'YES' OR 'NO': " G RYN + W:$X>73 ! W $P(" (YES)^ (NO)",U,%) Q +MSG1 I '$D(IOP) W ?20,*7," [DEVICE DOES NOT EXIST]" + Q +SETVAR ;Come here to setup the variables for the selected device + S:$D(IO)[0 IO="" G KILVAR:%IS["T"&(IO="") + I $G(%Z)="" S ION="Unknown device",POP=1 G KILVAR + S:IO'=IO(0)&($D(DUZ)#2) ^DISV(+DUZ,"^%ZIS(1,")=%E + S ION=$P(%Z,"^",1),IOM=+%Z91,IOF=$P(%Z91,"^",2),IOSL=$P(%Z91,"^",3),IOBS=$P(%Z91,"^",4),IOXY=$P(%Z91,"^",5) + I IOSL>65530 S IOSL=65530 ;Cache rolls $Y at 65535 + S IOT=%ZTYPE,IOST(0)=%ZISIOST(0),IOST=%ZISIOST,IOPAR=%ZISOPAR,IOUPAR=%ZISUPAR,IOHG=%ZISHG + S:IOF="" IOF="#" ;See that IOF has something + K IOCPU S:$D(%ZISCPU) IOCPU=%ZISCPU G KIL + ; +KILVAR ;Come here to restore the calling variables + D SYMBOL^%ZISUTL(1,"%ZISOLD") + S:'$L($G(IOF)) IOF="#" S:'$D(IOST(0)) IOST(0)=0 + ;See that all standard variables are defined + F %I="IO","ION","IOM","IOBS","IOSL","IOST" S:$D(@%I)[0 @%I="" + K IO("HFSIO"),IO("OPEN") I $D(%ZISCPU) S:'$D(IOCPU) IOCPU=%ZISCPU +KIL ;Final exit cleanup + S:'POP IOS=%ZISIOS I POP K:%IS'["T" %ZISIOS I %IS["T" K IOS S:$D(%ZISIOS) IOS=%ZISIOS + S:%IS["T" IO("T")=1 K %ZIS,%IS,%A,%E,%H,%ZISOS,%ZISV,IOP +K2 K %I,%X,%Y,%Z,%Z1,%Z91,%Z95,%ZTYPE,%ZTIME + K %ZISCHK,%ZISCPU,%ZISI,%ZISR,%ZISVT,%ZISB,%ZISX,ZISI,%ZISHGL,%ZISHP,%ZISIO,%ZISIOS,%ZISIOM,%ZISIOF,%ZISIOSL,%ZISIOBS,%ZISIOST,%ZISIOST(0),%ZISTO,%ZISTP,%ZISHG,%ZISSIO,%ZISOPEN,%ZISOPAR,%ZISUPAR + K %ZISMY,%ZISQUIT + Q diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS2.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS2.m index 7b58376e..65a5c599 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS2.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS2.m @@ -1,94 +1,90 @@ -%ZIS2 ;SFISC/AC,RWF -- DEVICE HANDLER (CHECKS) ;1/24/08 16:07 - ;;8.0;KERNEL;**69,104,112,118,136,241,440**;JUL 10, 1995;Build 13 - ;Per VHA Directive 2004-038, this routine should not be modified -HUNT S:'$D(%ZISHP) %ZISHP=%E,%ZISHGL=0 S %E=0 - F S %ZISHGL=$O(^%ZIS(1,%ZISHG(0),"HG",%ZISHGL)) Q:%ZISHGL'>0 D Q:%E - . N %1,%2 S %1=$G(^%ZIS(1,%ZISHG(0),"HG",+%ZISHGL,0)),%2=$G(^%ZIS(1,+%1,0)) - . ;Check that HG device is on same VOL. - . I $P(%2,"^",9)=%ZISV!($P(%2,"^",9)="") S %E=+$P(^%ZIS(1,%ZISHG(0),"HG",+%ZISHGL,0),"^") - . Q - G L2:%ZISHGL>0 S %ZISHPOP=1,%E=%ZISHP - ; -L2 ;Entry point from %ZIS1 - I $D(DTOUT)!$D(DUOUT) K %ZISHP,%ZISHPOP Q -CHECK ;Get IO check for secondary $I - K %ZISCPU N %Z2 - S POP=0,%Z=^%ZIS(1,%E,0),%Z2=$S(%ZIS("PRI")=1:"",1:$G(^%ZIS(1,%E,2))) ;Get Primary and secondary IO. - S IO=$S(%ZIS("PRI")=1:$P(%Z,"^",2),$L($P(%Z2,"^")):$P(%Z2,"^"),1:$P(%Z,"^",2)) ; - S:%IS["Q"&'$D(ZTQUEUED)&($P(%Z,"^",12)=1!$D(XQNOGO)) %ZISB=0,IO("Q")=1 ;Forced Queueing - I $P(%Z,"^",12)=2 S %IS=$TR(%IS,"Q") I $D(IO("Q")) D Q - . I '$D(IOP) W !,"Queuing NOT ALLOWED on this device" - . S POP=1 K:$D(IOP) IO("Q") Q - S %Z90=$G(^(90)),%Z95=$G(^(95)),%ZTIME=$G(^("TIME")),%ZTYPE=$G(^("TYPE")),%ZISHG=$O(^%ZIS(1,"AHG",%E,0)) - I %ZISHG,$D(^%ZIS(1,+%ZISHG,0)) S:'$D(%ZISHG(0)) %ZISHG(0)=+%ZISHG S %ZISHG=$P(^(0),"^",1) - E S %ZISHG="" - I %ZTYPE="HG" D OTHCPU("HUNT GROUP") G T:$D(%ZISHG(0))!POP - I %ZTYPE="RES" S %ZISRL=+$P(%Z1,"^",10) G T -VTRM I %ZTYPE="VTRM",'('$D(IO("Q"))&(%A=%H)) W:'$D(IOP)&'$D(%ZISHP) *7," [YOU CAN NOT SELECT A VIRTUAL TERMINAL]" S POP=1 ;Virtual Terminal Check - S:%ZTYPE="VTRM"&'$D(IO("Q"))&(%A=%H) IO=$I - ; -SLAVE I $D(IO("Q")),$P(%Z,"^",2)=0,$P(%Z,"^",8)']"" W:'$D(IOP) *7,!?10," [SLAVE device NOT set up for queuing]" S POP=1 G T -OCPU D OTHCPU("DEVICE") - ; -OOS G T:POP I %Z90,$D(DT)#2,%Z90'>DT S POP=1 ;Out Of Service Check - I $T,'$D(IOP),'$D(%ZISHP) W *7," [Out of Service]" ;I 'POP W " ..OK" S %=2,U="^" D YN^%ZIS1 G:%=0 OOS S:%'=1 POP=1 - ; -PTIME G T:POP!(IO=$I)!(IO=0) - ;Prohibitted Time Check - S %A=$P(%ZTIME,"^") I %ZISB,$L(%A) D I POP,'$D(IOP),'$D(%ZISHP) W *7," [ACCESS PROHIBITED "_%A_"]" ;AT THIS TIME]" - . N %C,%L,%H ;%C is current time, %L is lower limit, %H is upper limit - . S %C=$P($H,",",2),%C=%C\60#60+(%C\3600*100),%H=$P(%A,"-",2),%L=+%A - . I $S(%H'<%L:(%C'>%H&(%C'<%L)),1:(%C'<%L!(%C'>%H))) S POP=1 - . Q -DUZ I 'POP D SEC ;Security Check - ; -T I POP,$D(%ZISHG(0)),%IS'["D",'$D(%ZISHPOP),%ZISB G HUNT - I POP D HGBSY:$D(%ZISHPOP) ;G T2:%IS["T" - ; -TMPVAR K IO("S") S %ZISIOS=%E S:IO=0 IO=$I,IO("S")=%H - S %ZISOPAR=$$IOPAR(%E,"IOPAR") - S %ZISUPAR=$$IOPAR(%E,"IOUPAR"),%ZISTO=+$P(%ZTIME,"^",2) - I $D(IO("S")) D I POP Q - . S IO=$S(%IS["S":$P($G(^%ZIS(1,+$P(%Z,"^",8),0)),"^",2),1:IO) - . I %IS["S",IO]"" S %H=+$P(%Z,"^",8),IO("S")=%H,IO(0)=IO - . S IO("S")=$S($G(^XUTL("XQ",$J,"IOST(0)")):^("IOST(0)"),1:$G(^%ZIS(1,%H,"SUBTYPE"))) - . S:IO="" POP=1 - . Q - S %A=+$G(^%ZIS(1,%E,"SUBTYPE")),%ZISTP=0 ;%A is pointer to subtype - I %E=%H,%ZTYPE["TRM" D I 1 - . I $D(^XUTL("XQ",$J,"IOST(0)")) D ;Use home - . . S %A=+^XUTL("XQ",$J,"IOST(0)"),%Z91="",%ZISTP=1 - . . F %ZISI="IOM","IOF","IOSL","IOBS","IOXY" S %Z91=%Z91_$G(^XUTL("XQ",$J,%ZISI))_"^" - . E S %=$$LNPRTSUB^%ZISUTL I %>0 S %A=%,%Z91="" - E S %Z91=$P($G(^%ZIS(2,%A,1)),"^",1,4),$P(%Z91,"^",5)=$G(^("XY")) - ;I $D(%Z91),%Z91'?1.4"^" ;$P(%Z91,"^")]"",$P(%Z91,"^",2)]"",$P(%Z91,"^",3),$P(%Z91,"^",4)]"" - D ST^%ZIS3(%ZISTP) S:%IS["U" USIO=$P(%Z91,"^",1,4) -T2 I POP S:%IS'["T" IO="" Q - G ^%ZIS3:"^MTRM^VTRM^TRM^SPL^MT^SDP^HFS^RES^OTH^BAR^HG^IMPC^CHAN^"[("^"_%ZTYPE_"^") ;Jump to next part - S POP=1 Q - ; -HGBSY S POP=1 S:%IS'["T" IO="" K %ZISHP,%ZISHPOP Q:$D(IOP) - W:$X>38 !,?5 W *7," All devices in hunt group "_%ZISHG_" are busy!" Q - ; -OTHCPU(%1) ;%1 should be either DEVICE or HUNT GROUP - N %2,X,Y,%ZISMSG S %ZISMSG=0 - F %2="CPU","VOLUME SET" D - .I %2="VOLUME SET" S X=$P($P(%Z,"^",9),":"),Y=%ZISV - .E D GETENV^%ZOSV S X=$P($P(%Z,"^",9),":",2),Y=$P($P(Y,"^",4),":",2) - .I X=Y!(X="") Q:%1="DEVICE" D Q ;Other Vol Set/Cpu Check - ..S %ZISHG(0)=%E,%ZISHG=$P(%Z,"^") - ..I %ZISB S POP=1 - ..E S IO=" " - .I %2="VOLUME SET" S $P(%ZISCPU,":")=X - .E S $P(%ZISCPU,":",2)=X - .I %1="HUNT GROUP" K %ZISHG(0) - .I %IS["Q" S IO("Q")=1,%ZISB=0 S:%1="HUNT GROUP" IO=" " - .E I %ZISB&(%ZTYPE="TRM"&($D(%ZISHG(0))&(%IS'["D"))) S POP=1 - .E W:'$D(IOP)&'%ZISMSG *7," ["_%1_" is on another "_%2_" ('"_X_"')]",! S POP=1,%ZISMSG=1 - Q -IOPAR(%DA,%N) ;Return I/O parameters - Q $S($G(%ZIS(%N))]"":%ZIS(%N),1:$G(^%ZIS(1,%DA,%N))) - ; -SEC I %Z95]"" S %X=$G(DUZ(0)) I %X'="@" S POP=1 F %A=1:1:$L(%X) I %Z95[$E(%X,%A) S POP=0 Q - I POP,'$D(IOP),'$D(%ZISHP) W *7," [Access Prohibited]" - Q +%ZIS2 ;SFISC/AC,RWF -- DEVICE HANDLER (CHECKS) ;06/12/2002 15:41 + ;;8.0;KERNEL;**69,104,112,118,136,241**;JUL 10, 1995 +HUNT S:'$D(%ZISHP) %ZISHP=%E,%ZISHGL=0 S %E=0 + F S %ZISHGL=$O(^%ZIS(1,%ZISHG(0),"HG",%ZISHGL)) Q:%ZISHGL'>0 D Q:%E + . N %1,%2 S %1=$G(^%ZIS(1,%ZISHG(0),"HG",+%ZISHGL,0)),%2=$G(^%ZIS(1,+%1,0)) + . ;Check that HG device is on same VOL. + . I $P(%2,"^",9)=%ZISV!($P(%2,"^",9)="") S %E=+$P(^%ZIS(1,%ZISHG(0),"HG",+%ZISHGL,0),"^") + . Q + G L2:%ZISHGL>0 S %ZISHPOP=1,%E=%ZISHP + ; +L2 ;Entry point from %ZIS1 + I $D(DTOUT)!$D(DUOUT) K %ZISHP,%ZISHPOP Q +CHECK K %ZISCPU S POP=0,%Z=^%ZIS(1,%E,0),IO=$P(%Z,"^",2) + S:%IS["Q"&'$D(ZTQUEUED)&($P(%Z,"^",12)=1!$D(XQNOGO)) %ZISB=0,IO("Q")=1 ;Forced Queueing + I $P(%Z,"^",12)=2 S %IS=$TR(%IS,"Q") I $D(IO("Q")) D Q + . I '$D(IOP) W !,"Queuing NOT ALLOWED on this device" + . S POP=1 K:$D(IOP) IO("Q") Q + S %Z90=$G(^(90)),%Z95=$G(^(95)),%ZTIME=$G(^("TIME")),%ZTYPE=$G(^("TYPE")),%ZISHG=$O(^%ZIS(1,"AHG",%E,0)) + I %ZISHG,$D(^%ZIS(1,+%ZISHG,0)) S:'$D(%ZISHG(0)) %ZISHG(0)=+%ZISHG S %ZISHG=$P(^(0),"^",1) + E S %ZISHG="" + I %ZTYPE="HG" D OTHCPU("HUNT GROUP") G T:$D(%ZISHG(0))!POP + I %ZTYPE="RES" S %ZISRL=+$P(%Z1,"^",10) G T +VTRM I %ZTYPE="VTRM",'('$D(IO("Q"))&(%A=%H)) W:'$D(IOP)&'$D(%ZISHP) *7," [YOU CAN NOT SELECT A VIRTUAL TERMINAL]" S POP=1 ;Virtual Terminal Check + S:%ZTYPE="VTRM"&'$D(IO("Q"))&(%A=%H) IO=$I + ; +SLAVE I $D(IO("Q")),$P(%Z,"^",2)=0,$P(%Z,"^",8)']"" W:'$D(IOP) *7,!?10," [SLAVE device NOT set up for queuing]" S POP=1 G T +OCPU D OTHCPU("DEVICE") + ; +OOS G T:POP I %Z90,$D(DT)#2,%Z90'>DT S POP=1 ;Out Of Service Check + I $T,'$D(IOP),'$D(%ZISHP) W *7," [Out of Service]" ;I 'POP W " ..OK" S %=2,U="^" D YN^%ZIS1 G:%=0 OOS S:%'=1 POP=1 + ; +PTIME G T:POP!(IO=$I)!(IO=0) + ;Prohibitted Time Check + S %A=$P(%ZTIME,"^") I %ZISB,$L(%A) D I POP,'$D(IOP),'$D(%ZISHP) W *7," [ACCESS PROHIBITED "_%A_"]" ;AT THIS TIME]" + . N %C,%L,%H ;%C is current time, %L is lower limit, %H is upper limit + . S %C=$P($H,",",2),%C=%C\60#60+(%C\3600*100),%H=$P(%A,"-",2),%L=+%A + . I $S(%H'<%L:(%C'>%H&(%C'<%L)),1:(%C'<%L!(%C'>%H))) S POP=1 + . Q +DUZ I 'POP D SEC ;Security Check + ; +T I POP,$D(%ZISHG(0)),%IS'["D",'$D(%ZISHPOP),%ZISB G HUNT + I POP D HGBSY:$D(%ZISHPOP) ;G T2:%IS["T" + ; +TMPVAR K IO("S") S %ZISIOS=%E S:IO=0 IO=$I,IO("S")=%H + S %ZISOPAR=$$IOPAR(%E,"IOPAR") + S %ZISUPAR=$$IOPAR(%E,"IOUPAR"),%ZISTO=+$P(%ZTIME,"^",2) + I $D(IO("S")) D I POP Q + . S IO=$S(%IS["S":$P($G(^%ZIS(1,+$P(%Z,"^",8),0)),"^",2),1:IO) + . I %IS["S",IO]"" S %H=+$P(%Z,"^",8),IO("S")=%H,IO(0)=IO + . S IO("S")=$S($G(^XUTL("XQ",$J,"IOST(0)")):^("IOST(0)"),1:$G(^%ZIS(1,%H,"SUBTYPE"))) + . S:IO="" POP=1 + . Q + S %A=+$G(^%ZIS(1,%E,"SUBTYPE")),%ZISTP=0 ;%A is pointer to subtype + I %E=%H,%ZTYPE["TRM" D I 1 + . I $D(^XUTL("XQ",$J,"IOST(0)")) D ;Use home + . . S %A=+^XUTL("XQ",$J,"IOST(0)"),%Z91="",%ZISTP=1 + . . F %ZISI="IOM","IOF","IOSL","IOBS","IOXY" S %Z91=%Z91_$G(^XUTL("XQ",$J,%ZISI))_"^" + . E S %=$$LNPRTSUB^%ZISUTL I %>0 S %A=%,%Z91="" + E S %Z91=$P($G(^%ZIS(2,%A,1)),"^",1,4),$P(%Z91,"^",5)=$G(^("XY")) + ;I $D(%Z91),%Z91'?1.4"^" ;$P(%Z91,"^")]"",$P(%Z91,"^",2)]"",$P(%Z91,"^",3),$P(%Z91,"^",4)]"" + D ST^%ZIS3(%ZISTP) S:%IS["U" USIO=$P(%Z91,"^",1,4) +T2 I POP S:%IS'["T" IO="" Q + G ^%ZIS3:"^MTRM^VTRM^TRM^SPL^MT^SDP^HFS^RES^OTH^BAR^HG^IMPC^CHAN^"[("^"_%ZTYPE_"^") ;Jump to next part + S POP=1 Q + ; +HGBSY S POP=1 S:%IS'["T" IO="" K %ZISHP,%ZISHPOP Q:$D(IOP) + W:$X>38 !,?5 W *7," All devices in hunt group "_%ZISHG_" are busy!" Q + ; +OTHCPU(%1) ;%1 should be either DEVICE or HUNT GROUP + N %2,X,Y,%ZISMSG S %ZISMSG=0 + F %2="CPU","VOLUME SET" D + .I %2="VOLUME SET" S X=$P($P(%Z,"^",9),":"),Y=%ZISV + .E D GETENV^%ZOSV S X=$P($P(%Z,"^",9),":",2),Y=$P($P(Y,"^",4),":",2) + .I X=Y!(X="") Q:%1="DEVICE" D Q ;Other Vol Set/Cpu Check + ..S %ZISHG(0)=%E,%ZISHG=$P(%Z,"^") + ..I %ZISB S POP=1 + ..E S IO=" " + .I %2="VOLUME SET" S $P(%ZISCPU,":")=X + .E S $P(%ZISCPU,":",2)=X + .I %1="HUNT GROUP" K %ZISHG(0) + .I %IS["Q" S IO("Q")=1,%ZISB=0 S:%1="HUNT GROUP" IO=" " + .E I %ZISB&(%ZTYPE="TRM"&($D(%ZISHG(0))&(%IS'["D"))) S POP=1 + .E W:'$D(IOP)&'%ZISMSG *7," ["_%1_" is on another "_%2_" ('"_X_"')]",! S POP=1,%ZISMSG=1 + Q +IOPAR(%DA,%N) ;Return I/O parameters + Q $S($G(%ZIS(%N))]"":%ZIS(%N),1:$G(^%ZIS(1,%DA,%N))) + ; +SEC I %Z95]"" S %X=$G(DUZ(0)) I %X'="@" S POP=1 F %A=1:1:$L(%X) I %Z95[$E(%X,%A) S POP=0 Q + I POP,'$D(IOP),'$D(%ZISHP) W *7," [Access Prohibited]" + Q diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS3.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS3.m index 8a2b1f87..d81b97bc 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS3.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS3.m @@ -1,82 +1,71 @@ -%ZIS3 ;SFISC/AC,RWF -- DEVICE HANDLER(DEVICE TYPES & PARAMETERS) ;1/24/08 13:18 - ;;8.0;KERNEL;**18,36,69,104,391,440**;JUL 10, 1995;Build 13 - ;Per VHA Directive 2004-038, this routine should not be modified - ;Call with a Go from ^%ZIS2 - I %ZIS'["T",$G(^%ZIS(1,+%E,"POX"))]"" D XPOX^ZISX(%E) ;Pre-Open - I $D(%ZISQUIT) S POP=1 K %ZISQUIT - S %ZISCHK=1 - ;I 'POP&(%ZISB)&(%ZTYPE'="RES")&(%ZTYPE'="OTH")&(%ZTYPE'="SDP")&(IO'["::") D DEVOK - ;See if need to lock. - K %ZISLOCK - I %ZIS'["T",+$G(^%ZIS(1,+%E,"GBL")) S %ZISLOCK=$NA(^%ZIS("lock",IO)) - ; - I 'POP G TRM:(%ZTYPE["TRM"),@(%ZTYPE_"^%ZIS6") ;Jump to next part - ; -Q ;%ZIS6 Returns here - ;See if need to un-lock. - I $D(%ZISUOUT) K %ZISUOUT,%ZISHP,%ZISHPOP Q - I $D(%ZISHPOP)&$S(IO="":1,1:'$D(IO(1,IO))) D HGBSY^%ZIS2 Q - I POP S:%ZIS'["T" IO="" I $D(%ZISHG(0)),%ZIS'["D",'$D(%ZISHPOP) G HUNT^%ZIS2 - Q ;Return to %ZIS1 - ; -VTRM ;Virtual terminal type -TRM ;D OPEN^%ZIS4:'POP&(%ZISB&(%ZIS'["T")),MARGN:'POP,SETPAR:'POP ;Terminal type - D MARGN:'POP,SETPAR:'POP ;Terminal type// TEST CHANGE - I 'POP,%ZIS'["T",%ZISB=1,'$D(IOP),IO'=IO(0),'$D(IO("Q")),%ZIS["Q" D AQUE - W:'$D(IOP) ! - I '$D(IO("Q")),'POP,%ZISB,%ZIS'["T" D O^%ZIS4 - G Q -DEVOK N X,Y,X1 ;Not sure this is needed - S X=IO,X1=%ZTYPE - D DEVOK^%ZOSV I Y=-99!(Y=0)!(Y=$J) Q - I Y>0 S POP=1 W:'$D(IOP)&('$D(%ZISHG(0))!(%IS["D")) !,$C(7),"[Device Unavailable]" Q - I Y=-1 S IO="",POP=1 W:'$D(IOP)&('$D(ZISHG(0))!(%IS["D")) !,$C(7),"[Device does not Exist or Unavailable]" Q - Q - ; -MARGN ;Get the margin and page length - S %A=$P(%Y,";",1) - I %A?1A.ANP D SUBIEN(.%A,1) I $D(^%ZIS(2,%A,1)) K %Z91 D ST(1) S %Y=$P(%Y,";",2,9),%ZISMY=$P(%ZISMY,";",2,9) G MARGN - I %A>3 S $P(%Z91,"^")=$S(%A>255:255,1:+%A) - I $P(%Y,";",2) S $P(%Z91,"^",3)=+$S($P(%Y,";",2)>65530:65530,1:$P(%Y,";",2)) ;Cache fix for $Y#65535 wrap - ; -ALTP I '$D(IO("P")) Q:%A>3 G ASKMAR:%ZTYPE["TRM" Q - S %X=$F(IO("P"),"M") I %X S %A=+$E(IO("P"),%X,99),$P(%Z91,"^")=$S(%A>255:255,1:%A) - S %X=$F(IO("P"),"L") I %X S $P(%Z91,"^",3)=+$E(IO("P"),%X,99) - Q:%A>3!(%ZTYPE'["TRM") -ASKMAR I %IS["M",'$D(IOP),$S(%E=%H:+$P(%Z,"^",3),1:1),$P(%Z,"^",4) W " Right Margin: " W:$P(%Z91,"^")]"" +%Z91,"// " - E Q - D SBR^%ZIS1 I '$D(DTOUT)&'$D(DUOUT) S:%X=""&($P(%Z91,"^")]"") %X=+%Z91 G ASKMAR:%X'?1.N S $P(%Z91,"^")=$S(%X>255:255,1:%X) Q - S POP=1 I %ZISB&(%ZTYPE["TRM")&(IO'=IO(0)) C IO K IO(1,IO) Q - Q -SETPAR S:$L(%ZISOPAR)&($E(%ZISOPAR)'="(") %ZISOPAR="("_%ZISOPAR_")" - Q -AQUE ;Ask about Queueing - W ! S %=$S($D(IO("Q")):1,1:2),U="^",%ZISDTIM=60 - I $D(IO("Q")) W !,"Previously, you have selected queueing." - W !,"Do you "_$S($D(IO("Q")):"STILL ",1:"")_"want your output QUEUED" - D YN^%ZIS1 K %ZISDTIM G AQUE:%=0 Q:$D(IO("Q")) - I %=-1 S POP=1,%ZISHPOP=1,%ZISUOUT=1 C IO K IO(1,IO) Q - I %=1 S IO("Q")=1 C IO K IO(1,IO) Q - ;I %=2 K IO("Q") - Q -ST(%ZISTP) ; - S %ZISIOST(0)=%A,%ZISIOST=$P($G(^%ZIS(2,%A,0)),"^") - S:'$D(%Z91) %Z91=$P($G(^%ZIS(2,%A,1),"132^#^60^$C(8)"),"^",1,4),$P(%Z91,"^",5)=$G(^("XY")) - Q:%ZISTP -STP N %B ;%E is a pointer to the Device file - S %B=$G(^%ZIS(1,%E,91)) - S:$P(%B,"^")]"" $P(%Z91,"^")=+%B S:$P(%B,"^",3)]"" $P(%Z91,"^",3)=$P(%B,"^",3) ;S $P(%Z91,"^",5)=$G(^%ZIS(2,%ZISIOST(0),"XY")) - Q -SUBIEN(%1,%) ;Return Subtype ien. %1 is call by Ref. - N %XX,%YY - I $D(^%ZIS(2,"B",%1))>9 S %1=+$O(^%ZIS(2,"B",%1,0)) Q - I '$G(%) S X="" Q - S %XX=%1 D 2^%ZIS5 S %1=+%YY - Q -SUBTYPE(%A) ;Called from %ZISH - N %ZISIOST,%Z91 - S:$G(%A)="" %A="P-OTHER" - D SUBIEN(.%A),ST(1) - S IOM=$P(%Z91,U,1),IOF=$P(%Z91,U,2),IOSL=$P(%Z91,U,3),IOST=%ZISIOST,IOST(0)=%ZISIOST(0),IOBS="$C(8)" - S:IOST="" IOST="P-OTHER",IOST(0)=0 - Q +%ZIS3 ;SFISC/AC,RWF -- DEVICE HANDLER(DEVICE TYPES & PARAMETERS) ;10/06/2005 13:23 + ;;8.0;KERNEL;**18,36,69,104,391**;JUL 10, 1995 + I %ZIS'["T",$G(^%ZIS(1,+%E,"POX"))]"" D XPOX^ZISX(%E) + I $D(%ZISQUIT) S POP=1 K %ZISQUIT + S %ZISCHK=1 + I 'POP&(%ZISB)&(%ZTYPE'="RES")&(%ZTYPE'="OTH")&(%ZTYPE'="SDP")&(IO'["::") D DEVOK + G Q:POP + G @%ZTYPE:(%ZTYPE["TRM"),@(%ZTYPE_"^%ZIS6") ;Jump to next part + ; +Q I $D(%ZISUOUT) K %ZISUOUT,%ZISHP,%ZISHPOP Q + I $D(%ZISHPOP)&$S(IO="":1,1:'$D(IO(1,IO))) D HGBSY^%ZIS2 Q + I POP S:%IS'["T" IO="" I $D(%ZISHG(0)),%IS'["D",'$D(%ZISHPOP) G HUNT^%ZIS2 + Q +VTRM ;Virtual terminal type +TRM D OPEN^%ZIS4:'POP&(%ZISB&(%IS'["T")),MARGN:'POP,SETPAR:'POP ;Terminal type + I 'POP,%IS'["T",%ZISB=1,'$D(IOP),IO'=IO(0),'$D(IO("Q")),%IS["Q" D AQUE + W:'$D(IOP) ! I '$D(IO("Q")) D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) + G Q +DEVOK N X,Y,X1 + S X=IO,X1=%ZTYPE + D DEVOK^%ZOSV I Y=-99!(Y=0)!(Y=$J) Q + I Y>0 S POP=1 W:'$D(IOP)&('$D(%ZISHG(0))!(%IS["D")) !,*7,"[Device Unavailable]" Q + I Y=-1 S IO="",POP=1 W:'$D(IOP)&('$D(ZISHG(0))!(%IS["D")) !,*7,"[Device does not Exist or Unavailable]" Q + Q + ; +MARGN ;Get the margin and page length + S %A=$P(%Y,";",1) + I %A?1A.ANP D SUBIEN(.%A,1) I $D(^%ZIS(2,%A,1)) K %Z91 D ST(1) S %Y=$P(%Y,";",2,9),%ZISMY=$P(%ZISMY,";",2,9) G MARGN + I %A>3 S $P(%Z91,"^")=$S(%A>255:255,1:+%A) + I $P(%Y,";",2) S $P(%Z91,"^",3)=+$S($P(%Y,";",2)>65530:65530,1:$P(%Y,";",2)) ;Cache fix for $Y#65535 wrap + ; +ALTP I '$D(IO("P")) Q:%A>3 G ASKMAR:%ZTYPE["TRM" Q + S %X=$F(IO("P"),"M") I %X S %A=+$E(IO("P"),%X,99),$P(%Z91,"^")=$S(%A>255:255,1:%A) + S %X=$F(IO("P"),"L") I %X S $P(%Z91,"^",3)=+$E(IO("P"),%X,99) + Q:%A>3!(%ZTYPE'["TRM") +ASKMAR I %IS["M",'$D(IOP),$S(%E=%H:+$P(%Z,"^",3),1:1),$P(%Z,"^",4) W " Right Margin: " W:$P(%Z91,"^")]"" +%Z91,"// " + E Q + D SBR^%ZIS1 I '$D(DTOUT)&'$D(DUOUT) S:%X=""&($P(%Z91,"^")]"") %X=+%Z91 G ASKMAR:%X'?1.N S $P(%Z91,"^")=$S(%X>255:255,1:%X) Q + S POP=1 I %ZISB&(%ZTYPE["TRM")&(IO'=IO(0)) C IO K IO(1,IO) Q + Q +SETPAR S:%ZISOPAR]""&($A(%ZISOPAR)-40) %ZISOPAR="("_%ZISOPAR_")" + Q +AQUE W ! S %=$S($D(IO("Q")):1,1:2),U="^",%ZISDTIM=60 + I $D(IO("Q")) W !,"Previously, you have selected queueing." + W !,"Do you "_$S($D(IO("Q")):"STILL ",1:"")_"want your output QUEUED" + D YN^%ZIS1 K %ZISDTIM G AQUE:%=0 Q:$D(IO("Q")) + I %=-1 S POP=1,%ZISHPOP=1,%ZISUOUT=1 C IO K IO(1,IO) Q + I %=1 S IO("Q")=1 C IO K IO(1,IO) Q + Q +ST(%ZISTP) ; + S %ZISIOST(0)=%A,%ZISIOST=$P($G(^%ZIS(2,%A,0)),"^") + S:'$D(%Z91) %Z91=$P($G(^%ZIS(2,%A,1),"132^#^60^$C(8)"),"^",1,4),$P(%Z91,"^",5)=$G(^("XY")) + Q:%ZISTP +STP N %B ;%E is a pointer to the Device file + S %B=$G(^%ZIS(1,%E,91)) + S:$P(%B,"^")]"" $P(%Z91,"^")=+%B S:$P(%B,"^",3)]"" $P(%Z91,"^",3)=$P(%B,"^",3) ;S $P(%Z91,"^",5)=$G(^%ZIS(2,%ZISIOST(0),"XY")) + Q +SUBIEN(%1,%) ;Return Subtype ien. %1 is call by Ref. + N %XX,%YY + I $D(^%ZIS(2,"B",%1))>9 S %1=+$O(^%ZIS(2,"B",%1,0)) Q + I '$G(%) S X="" Q + S %XX=%1 D 2^%ZIS5 S %1=+%YY + Q +SUBTYPE(%A) ;Called from %ZISH + N %ZISIOST,%Z91 + S:$G(%A)="" %A="P-OTHER" + D SUBIEN(.%A),ST(1) + S IOM=$P(%Z91,U,1),IOF=$P(%Z91,U,2),IOSL=$P(%Z91,U,3),IOST=%ZISIOST,IOST(0)=%ZISIOST(0),IOBS="$C(8)" + S:IOST="" IOST="P-OTHER",IOST(0)=0 + Q + diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS4.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS4.m index b097201f..9501daf3 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS4.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS4.m @@ -1,109 +1,103 @@ -%ZIS4 ;ISF/RWF,DW - DEVICE HANDLER SPECIFIC CODE (GT.M for Unix/VMS) ;1/24/08 16:08 - ;;8.0;KERNEL;**275,425,440**;Jul 10, 1995;Build 13 - ;Per VHA Directive 2004-038, this routine should not be modified -OPEN ;From %ZIS3 for TRM - G OPN2:$D(IO(1,IO)) - S POP=0 D OP1 G NOPEN:'$D(IO(1,IO)) -OPN2 ; - I $D(%ZISHP),'$D(IOP) W !,*7," Routing to device "_$P(^%ZIS(1,%E,0),"^",1)_$S($D(^(1)):" "_$P(^(1),"^",1)_" ",1:"") - Q -NOPEN I %IS'["D",$D(%ZISHP)!(%ZISHG]"") S POP=1 Q - I '$D(IOP) W *7," [BUSY]" W " ... RETRY" S %=2,U="^" D YN^%ZIS1 G OPEN:%=1 - S POP=1 Q - Q - ;Why no open paraneters??? -OP1 N $ET S $ET="G OPNERR^%ZIS4" - I $D(%ZISLOCK) L +@%ZISLOCK:5 E S POP=1 Q - O IO::%ZISTO S:$T IO(1,IO)="" S:'$T POP=1 - Q -OPNERR ;Open Error - S POP=1,IO("LASTERR")=$G(IO("ERROR")),IO("ERROR")=$$EC^%ZOSV,$EC="" - Q - ; -O ;From %ZIS6 for all types. - D:%IS["L" ZIO - I $D(IO("S")),$D(^%ZIS(2,IO("S"),10)),^(10)]"" U IO(0) D X10^ZISX ;Open Printer Port -OPAR I $D(IOP),%ZTYPE="HFS",$D(%IS("HFSIO")),$D(%IS("IOPAR")),%IS("HFSIO")]"" S IO=%IS("HFSIO"),%ZISOPAR=%IS("IOPAR") - I %ZTYPE="CHAN" D TCPIP Q:POP G OXECUTE^%ZIS6 - S %A=%ZISOPAR_$S(%ZISOPAR["):":"",1:":"_%ZISTO) - N % S %(IO)="",%=$P($P($NA(%(IO)),"(",2),")") - S %A=%_$E(":",%A]"")_%A - D O1 I POP D Q - .I %ZTYPE="HFS",'$D(IOP),$G(IO("ERROR"))["file not found" W !,?5,*7,"[File Not Found]" Q - .W:'$D(IOP) !,?5,*7,"[DEVICE IS BUSY]" Q - ;S IO(1,IO)="" U IO S:'(IO=IO(0)&'$D(IO("S"))&'$D(ZTQUEUED)) $X=0,$Y=0 I %ZTYPE["TRM" U IO:(WIDTH=+%Z91) - U IO S $X=0,$Y=0 I %ZTYPE["TRM" U IO:(WIDTH=+%Z91) - I %ZISUPAR]"" S %A1=""""_IO_""":"_%ZISUPAR U @%A1 - ;U:%IS'[0 IO(0) - G OXECUTE^%ZIS6 - ; -O1 N $ES,$ET S $ET="G OPNERR^%ZIS4" - I $D(%ZISLOCK) L +@%ZISLOCK:5 E S POP=1 Q - O @%A S:'$T&(%A?.E1":".N) POP=1 S:'POP IO(1,IO)="" - S IO("ERROR")="" Q - ; - ;Need to find out how to get IP address -ZIO N %,%1 S (%,%1)=$ZIO - I $ZV["VMS",%["_TNA" D - . S (%,%1)=$ZGETDVI($I,"TT_ACCPORNAM") - . S %=$S(%["Host:":$P($P(%,"Host: ",2)," ")_":"_$P(%,"Port: ",2),1:%) S:%[" " %=$TR(%," ") - I $ZV'["VMS" D - . S (%,%1)=$ZTRNLNM("REMOTEHOST") S:$L(%) %1="Host:"_% S:'$L(%) %=$ZIO - S IO("ZIO")=% S:(%1["Host:")&'$D(IO("IP")) IO("IP")=$P(%,":") - Q - ; -TCPIP ;For TCP/IP devices, should use ^%ZISTCP - N %S - S %ZISTO=$G(%ZISTO,3) - S %A="IO:"_$S($E(%ZISOPAR)="(":"",1:"(")_%ZISOPAR_$S($E(%ZISOPAR,$L(%ZISOPAR))=")":"",1:")")_":%ZISTO:""SOCKET""" - ;U $P W !,"%A=",%A - O @%A I '$T S POP=1 Q ;D O1 ;Do the open. - U IO:(WIDTH=512:NOWRAP:EXCEPT="G OPNERR^%ZIS4") S %S=$KEY - U $P ;W !,"$KEY=",%S - Q - ; -SPOOL ;%ZDA=pointer to ^XMB(3.51, %ZFN=spool file name. - I $D(ZISDA) W:'$D(IOP) !?5,*7,"You may not Spool the printing of a Spool document" G N - I $D(DUZ)[0 W:'$D(IOP) !,"Must be a valid user." G N -R S %ZY=-1 D NEWDOC^ZISPL1 G N:%ZY'>0 - S %ZDA=+%ZY,%ZFN=$P(%ZY(0),U,2),IO("DOC")=$P(%ZY(0),U,1) G OK:$D(IO("Q")) - G:'%ZISB OK I '$P(%ZY,"^",3),$L(%ZFN) O %ZFN:(append:nowrap):2 G DOC - S %ZFN=IO_"SPOOL_no_"_%ZDA_".TMP" D SPL2 G:%ZFN']"" N S $P(^XMB(3.51,%ZDA,0),U,2)=%ZFN,^XMB(3.51,"C",%ZFN,%ZDA)="" -DOC S IO=%ZFN,IO("SPOOL")=%ZDA,^XUTL("XQ",$J,"SPOOL")=%ZDA,IOF="#" - I $D(^%ZIS(1,%ZISIOS,1)),$P(^(1),"^",8),$O(^("SPL",0)) S ^XUTL("XQ",$J,"ADSPL")=%ZISIOS,ZISPLAD=%ZISIOS -OK K %ZDA,%ZFN Q -N K %ZDA,%ZFN,IO("DOC") S POP=1 Q - ; -SPL2 ;Open for write - O %ZFN:(newversion:noreadonly:nowrap:exception="G SPL4"):2 G:$ZA<0 SPL4 S IO(1,%ZFN)="" Q - ; -SPL3 ;Open for Read - O %ZFN:(readonly:exception="G SPL4"):2 S:'$T ZISPLQ=1 G:'$T SPL4 S IO(1,%ZFN)="" Q -SPL4 W:'$D(IOP)&'$D(ZTQUEUED) !?5,*7,"Couldn't open the spool file." S %ZFN="" Q - ; -CLOSE ;Close out the spool - N %,%1,%Z1,%ZFN,%ZS,%ZDA,XS,%Y,%X - I $L(IO) C IO K IO(1,IO) - D FILE^ZISPL1 I %ZDA'>0 K ZISPLAD Q - S %ZFN=$P(%ZS,"^",2) D SPL3 Q:%ZFN']"" S %ZCR=$C(13),%Y="" - S %Z1=+$G(^XTV(8989.3,1,"SPL")),%=0 - U %ZFN F R %X#255:5 Q:$ZEOF S %2=%X D CL2 Q:%Z1<% -SPLEX C %ZFN:(DELETE) K:%ZFN]"" IO(1,%ZFN) D CLOSE^ZISPL1 K %Y,%X,%1,%ZFN Q - ; -CL2 S %=%+1 I %Z1<% S ^XMBS(3.519,XS,2,%,0)="*** INCOMPLETE REPORT -- SPOOL DOCUMENT LINE LIMIT EXCEEDED ***",$P(^XMB(3.51,%ZDA,0),"^",11)=1 Q - I %2[$C(12) S ^XMBS(3.519,XS,2,%,0)="|TOP|" Q - S ^XMBS(3.519,XS,2,%,0)=%2 Q - ; -HFS G HFS^%ZISF -REWMT(IO,IOPAR) ;Rewind Magtape - S X="REWERR^%ZIS4",@^%ZOSF("TRAP") - U IO W *5 - Q 1 -REWSDP(IO,IOPAR) ;Rewind SDP - G REW1 -REWHFS(IO,IOPAR) ;Rewind Host File. -REW1 S X="REWERR^%ZIS4",@^%ZOSF("TRAP") - U IO:(REWIND) - Q 1 -REWERR ;Error encountered - Q 0 +%ZIS4 ;ISF/RWF,DW - DEVICE HANDLER SPECIFIC CODE (GT.M for Unix/VMS) ;03/07/2007 + ;;8.0;KERNEL;**275,425**;Jul 10, 1995;Build 18 + ; +OPEN ;From %ZIS3 for TRM + G OPN2:$D(IO(1,IO)) + S POP=0 D OP1 G NOPEN:'$D(IO(1,IO)) +OPN2 ; + I $D(%ZISHP),'$D(IOP) W !,*7," Routing to device "_$P(^%ZIS(1,%E,0),"^",1)_$S($D(^(1)):" "_$P(^(1),"^",1)_" ",1:"") + Q +NOPEN I %IS'["D",$D(%ZISHP)!(%ZISHG]"") S POP=1 Q + I '$D(IOP) W *7," [BUSY]" W " ... RETRY" S %=2,U="^" D YN^%ZIS1 G OPEN:%=1 + S POP=1 Q + Q + ;Why no open paraneters??? +OP1 N $ES,$ET S $ET="G OPNERR^%ZIS4" + L:$D(%ZISLOCK) +@%ZISLOCK:60 + O IO::%ZISTO S:$T IO(1,IO)="" S:'$T POP=1 L:$D(%ZISLOCK) -@%ZISLOCK + Q +OPNERR ;Open Error + S POP=1,IO("LASTERR")=$G(IO("ERROR")),IO("ERROR")=$$EC^%ZOSV,$EC="" Q + ; +O ;From %ZIS6 for other types. + D:%IS["L" ZIO +LCKGBL ;Lock Global + I %ZTYPE="CHAN" N % S %=$G(^%ZIS(1,+%E,"GBL")) I $L(%) L @("+^"_%_":0") S:'$T POP=1 I POP W:'$D(IOP) !,?5,*7,"[DEVICE IS BUSY]" Q + I $D(IO("S")),$D(^%ZIS(2,IO("S"),10)),^(10)]"" U IO(0) D X10^ZISX +OPAR I $D(IOP),%ZTYPE="HFS",$D(%IS("HFSIO")),$D(%IS("IOPAR")),%IS("HFSIO")]"" S IO=%IS("HFSIO"),%ZISOPAR=%IS("IOPAR") + I %ZTYPE="CHAN" D TCPIP Q:POP G OXECUTE^%ZIS6 + S %A=%ZISOPAR_$S(%ZISOPAR["):":"",%ZTYPE["CHAN"&($P(%ZTIME,"^",3)="n"):"",1:":"_%ZISTO) + N % S %(IO)="",%=$P($P($NA(%(IO)),"(",2),")") + S %A=%_$E(":",%A]"")_%A + D O1 I POP D Q + .I %ZTYPE="HFS",'$D(IOP),$G(IO("ERROR"))["file not found" W !,?5,*7,"[File Not Found]" Q + .W:'$D(IOP) !,?5,*7,"[DEVICE IS BUSY]" Q + ;S IO(1,IO)="" U IO S:'(IO=IO(0)&'$D(IO("S"))&'$D(ZTQUEUED)) $X=0,$Y=0 I %ZTYPE["TRM" U IO:(WIDTH=+%Z91) + U IO S $X=0,$Y=0 I %ZTYPE["TRM" U IO:(WIDTH=+%Z91) + I %ZISUPAR]"" S %A1=""""_IO_""":"_%ZISUPAR U @%A1 + ;U:%IS'[0 IO(0) + G OXECUTE^%ZIS6 + ; +O1 N $ES,$ET S $ET="G OPNERR^%ZIS4" + L:$D(%ZISLOCK) +@%ZISLOCK:60 + O @%A S:'$T&(%A?.E1":".N) POP=1 S:'POP IO(1,IO)="" L:$D(%ZISLOCK) -@%ZISLOCK + S IO("ERROR")="" Q + ; + ;Need to find out how to get IP address +ZIO N %,%1 S (%,%1)=$ZIO + I $ZV["VMS",%["_TNA" D + . S (%,%1)=$ZGETDVI($I,"TT_ACCPORNAM") + . S %=$S(%["Host:":$P($P(%,"Host: ",2)," ")_":"_$P(%,"Port: ",2),1:%) S:%[" " %=$TR(%," ") + I $ZV'["VMS" D + . S (%,%1)=$ZTRNLNM("REMOTEHOST") S:$L(%) %1="Host:"_% S:'$L(%) %=$ZIO + S IO("ZIO")=% S:(%1["Host:")&'$D(IO("IP")) IO("IP")=$P(%,":") + Q + ; +TCPIP ;For TCP/IP devices + N %S + S %ZISTO=$G(%ZISTO,3) + S %A="IO:"_$S($E(%ZISOPAR)="(":"",1:"(")_%ZISOPAR_$S($E(%ZISOPAR,$L(%ZISOPAR))=")":"",1:")")_":%ZISTO:""SOCKET""" + ;U $P W !,"%A=",%A + O @%A I '$T S POP=1 Q ;D O1 ;Do the open. + U IO:(WIDTH=512:NOWRAP:EXCEPT="G OPNERR^%ZIS4") S %S=$KEY + U $P ;W !,"$KEY=",%S + Q + ; +SPOOL ;%ZDA=pointer to ^XMB(3.51, %ZFN=spool file name. + I $D(ZISDA) W:'$D(IOP) !?5,*7,"You may not Spool the printing of a Spool document" G N + I $D(DUZ)[0 W:'$D(IOP) !,"Must be a valid user." G N +R S %ZY=-1 D NEWDOC^ZISPL1 G N:%ZY'>0 S %ZDA=+%ZY,%ZFN=$P(%ZY(0),U,2),IO("DOC")=$P(%ZY(0),U,1) G OK:$D(IO("Q")) + G:'%ZISB OK I '$P(%ZY,"^",3),%ZFN]"" D SPL3 G N:%ZFN']"",DOC + S %ZFN=IO_"SPOOL_no_"_%ZDA_".TMP" D SPL2 G:%ZFN']"" N S $P(^XMB(3.51,%ZDA,0),U,2)=%ZFN,^XMB(3.51,"C",%ZFN,%ZDA)="" +DOC S IO=%ZFN,IO("SPOOL")=%ZDA,^XUTL("XQ",$J,"SPOOL")=%ZDA,IOF="#" + I $D(^%ZIS(1,%ZISIOS,1)),$P(^(1),"^",8),$O(^("SPL",0)) S ^XUTL("XQ",$J,"ADSPL")=%ZISIOS,ZISPLAD=%ZISIOS +OK K %ZDA,%ZFN Q +N K %ZDA,%ZFN,IO("DOC") S POP=1 Q +SPL2 O %ZFN:(NEWVERSION:WORLD=RWD) G:$ZA<0 SPL4 S IO(1,%ZFN)="" Q +SPL3 N X S X="SPL4^%ZIS4",@^%ZOSF("TRAP") + O %ZFN:READONLY:1 S:'$T ZISPLQ=1 G:$ZA<0!('$T) SPL4 S IO(1,%ZFN)="" Q +SPL4 W:'$D(IOP)&'$D(ZTQUEUED) !?5,*7,"Couldn't open the spool file." S %ZFN="" Q +CLOSE N %Z1 C:IO]"" IO K:IO]"" IO(1,IO) D FILE^ZISPL1 I %ZDA'>0 K ZISPLAD Q + S %ZFN=$P(%ZS,"^",2) D SPL3 Q:%ZFN']"" U %ZFN S %ZCR=$C(13),%Y="",X="SPLEOF^%ZIS4",@^%ZOSF("TRAP") + S %Z1=+$G(^XTV(8989.3,1,"SPL")) + F %=0:0 R %X#255:5 Q:$ZA<0 S %2=%X D CL2 G:%Z1<% SPLEX +SPLEOF I $ZE'["ENDO" Q ;Send error up +SPLEX C %ZFN:(DELETE) K:%ZFN]"" IO(1,%ZFN) D CLOSE^ZISPL1 K %Y,%X,%1,%ZFN Q + ; +CL2 S %=%+1 I %Z1<% S ^XMBS(3.519,XS,2,%,0)="*** INCOMPLETE REPORT -- SPOOL DOCUMENT LINE LIMIT EXCEEDED ***",$P(^XMB(3.51,%ZDA,0),"^",11)=1 Q + I %2[$C(12) S ^XMBS(3.519,XS,2,%,0)="|TOP|" Q + S ^XMBS(3.519,XS,2,%,0)=%2 Q + ; +HFS G HFS^%ZISF +REWMT(IO,IOPAR) ;Rewind Magtape + S X="REWERR^%ZIS4",@^%ZOSF("TRAP") + U IO W *5 + Q 1 +REWSDP(IO,IOPAR) ;Rewind SDP + G REW1 +REWHFS(IO,IOPAR) ;Rewind Host File. +REW1 S X="REWERR^%ZIS4",@^%ZOSF("TRAP") + U IO:(REWIND) + Q 1 +REWERR ;Error encountered + Q 0 diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS6.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS6.m index b72b6522..347258fe 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS6.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS6.m @@ -1,101 +1,88 @@ -%ZIS6 ;SFISC/AC - DEVICE HANDLER -- RESOURCES ;1/24/08 16:09 - ;;8.0;KERNEL;**24,49,69,118,127,136,440**;JUL 10, 1995;Build 13 - ;Per VHA Directive 2004-038, this routine should not be modified - ;Expect that IO is current device -OXECUTE ;Open Execute - I $D(^%ZIS(2,%ZISIOST(0),2))=1 S %Y=^(2) D 2 -ANSBAK ;Answer Back - I $D(^%ZIS(2,%ZISIOST(0),102)) S %Y=^(102) D 2 E S POP=1 D:'$D(IOP) SAY($C(7)_"[NOT ON LINE]") C:%ZISB IO K IO(1,IO) G QUIT - I $D(%ZISMTR) X ^%ZOSF("MAGTAPE") U IO W:$D(%MT("REW")) @%MT("REW") U IO(0) K %MT - G QUIT:'$D(IO("P")) - I $F(IO("P"),"B"),$D(^%ZIS(2,%ZISIOST(0),7)) S %Y=$P(^(7),"^",1) I %Y]"" W @%Y - S %Y=$F(IO("P"),"P") G QLTY:'%Y S %Y=+$E(IO("P"),%Y,99),%X=$S(%Y=16:12.1,%Y=10!(%Y=12):5,1:"") G QLTY:'%X - S %Y=$S($D(^%ZIS(2,%ZISIOST(0),%X)):$P(^(%X),"^",$S(%Y=12:2,1:1)),1:"") - I %Y]"" W @%Y -QLTY S %Y=$F(IO("P"),"Q") Q:'%Y S %Y=+$E(IO("P"),%Y,99),%X=$S(%Y<0!(%Y>2):0,1:%Y+1) - I %X S %Y=$S($D(^%ZIS(2,%ZISIOST(0),12.2)):$P(^(12.2),"^",%X),1:"") I %Y]"" W @%Y -QUIT U:%IS'[0 IO(0) - Q -2 Q:%Y="" I %IS'[0,$D(^%ZIS(1,+%H,"TYPE")),^("TYPE")["TRM" D OH Q:POP - S %X=$T U IO D %Y^ZISX ;Q:'%X U IO(0) - Q -OH Q:$S($G(IO(0))]"":$D(IO(1,IO(0))),1:0) - N X S X="OPNERR^%ZIS4",@^%ZOSF("TRAP") - O IO(0)::0 S IO(1,IO(0))="" Q ;See that HOME DEVICE is open. - ; -SAY(%SAY) ; - Q:%IS[0 U IO(0) W %SAY U IO - Q -RES1 ;Allocate a resource slot, Release in %ZISC. - N A,L,X,%ZISD0 - S %ZISD0=$O(^%ZISL(3.54,"B",IO,0)) - I '%ZISD0 S %ZISD0=$$RADD(IO) ;New one - L +^%ZISL(3.54,%ZISD0,0):2 I '$T S POP=1 W:'$D(IOP) *7," [NOT Available]" G RESX -RES2 S X=$P(^%ZISL(3.54,%ZISD0,0),"^",2) - I X<1 S POP=1 W:'$D(IOP) *7," [NOT Available]" G RESX - S X=$S(X>0:X-1,1:0),$P(^%ZISL(3.54,%ZISD0,0),"^",2)=X - ; -R1 ;Grab a slot - S IO(1,IO)="RES",A=$G(^%ZISL(3.54,%ZISD0,1,0),"^3.542^^") - F L=1:1:%ZISRL I '$D(^%ZISL(3.54,%ZISD0,1,L,0)) Q - I '$T K IO(1,IO) G RES2 ;No free slots - S ^%ZISL(3.54,%ZISD0,1,L,0)=L_"^"_%ZISV_"^"_$J_"^"_$G(ZTSK)_"^"_$H,^%ZISL(3.54,"AJ",$J,%ZISD0,L)="",^%ZISL(3.54,%ZISD0,1,"B",L,L)="" - S $P(A,"^",3,4)=L_U_($P(A,U,4)+1),^%ZISL(3.54,%ZISD0,1,0)=A -RESX L -^%ZISL(3.54,%ZISD0,0) Q - ; -RADD(X) ;Add Resource - N %1,%2 - S %1=$G(^%ZISL(3.54,0),"RESOURCE^3.54^^"),%2=$P(%1,U,3) - F %2=%2:1 Q:'$D(^%ZISL(3.54,%2,0)) - S $P(^%ZISL(3.54,0),U,3,4)=%2_U_($P(%1,U,4)+1),^%ZISL(3.54,%2,0)=X_"^"_$G(%ZISRL,1),^%ZISL(3.54,"B",X,%2)="" - Q %2 - ; -RESOK ;DEVOK check for RES devices, for all OS's. - N %ZISD0,%ZISD1 - S Y=0,%ZISD0=$O(^%ZISL(3.54,"B",X,0)) - I '%ZISD0 S Y=-1,%ZISD0=$O(^%ZIS(1,"C",X,0)) Q:'%ZISD0 Q:'$D(^%ZIS(1,+%ZISD0,0)) Q:$P(^(0),"^")'=X Q:'$D(^("TYPE")) Q:^("TYPE")'="RES" S Y=0 Q - S X1=$G(^%ZISL(3.54,+%ZISD0,0)) - I $P(X1,"^",2)&(X=$P(X1,"^")) S Y=0 Q - S Y=999 F %ZISD1=0:0 S %ZISD1=$O(^%ZISL(3.54,%ZISD0,1,%ZISD1)) Q:%ZISD1'>0 I $D(^(%ZISD1,0)) S Y=$P(^(0),"^",3) Q - Q - ; -Q G Q^%ZIS3 -HG ; - Q -SPL ;Spool type - N %E,%Z D MARGN^%ZIS3 W:'$D(IOP) ! D SPOOL^%ZIS4:%IS'["T" - G Q -MT D MARGN^%ZIS3,ASKPAR,AMTREW:'POP&'$D(IOP)&%ZISB W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) ;Magtape type - G Q -SDP ;Sequential disk processor type - D MARGN^%ZIS3,ASKPAR W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) - G Q -HFS ;Host File Server type - D MARGN^%ZIS3,HFS^%ZIS4 W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) - G Q -RES ;Resources - G Q:%IS["T" N X,X1 I %IS'["R"!'$D(IOP) S POP=1 W:'$D(IOP) *7," [NOT AVAILABLE]" Q - G Q:$D(IO(1,IO)) I %IS["T" S X=IO,X1="RES" D DEVOK^%ZIS3 S:Y POP=1 G Q:POP - D:%ZISB RES1 G Q -CHAN ;Network Channel type devices -- DecNet or TCP/IP devices. - I IO="SYS$NET",$I="SYS$INPUT:;" S IO(0)=IO U IO ;DECNET Server Device - D MARGN^%ZIS3:'POP,ASKPAR:'POP W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) - G Q -IMPC ;Imaging Work Station -BAR ;Bar Code -OTH ;Other Device type - D MARGN^%ZIS3:'POP,ASKPAR:'POP W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) - G Q - ; -ASKPAR ;Ask Parameters - G SETPAR^%ZIS3:$D(IOP),SETPAR^%ZIS3:'$P(^%ZIS(1,%E,0),"^",4) W " ADDRESS/PARAMETERS: " W:%ZISOPAR]"" %ZISOPAR_"// " D SBR^%ZIS1 D MSG1:%X="?" G ASKPAR:%X="?" S:%X]"" %ZISOPAR=%X I $D(DTOUT)!$D(DUOUT) S POP=1 - I POP,%ZISB&(%ZTYPE["TRM") C IO K IO(1,IO) Q - Q:POP G SETPAR^%ZIS3 - ; -AMTREW ;Mag Tape Rewind - I %ZISB,%ZTYPE="MT",'$D(IOP) W " REWIND" S %=2,U="^",%ZISDTIM=60 D YN^%ZIS1 K %ZISDTIM G AMTREW:%=0 I %=-1 S POP=1 Q - S:%=1 %ZISMTR=1 - Q -MSG1 W !?5,"Enter the desired parameters needed to open the selected device.",!?25 - Q - ; +%ZIS6 ;SFISC/AC - DEVICE HANDLER -- RESOURCES ;02/04/2000 08:14 + ;;8.0;KERNEL;**24,49,69,118,127,136**;JUL 10, 1995 + ;Expect that IO is current device +OXECUTE I $D(^%ZIS(2,%ZISIOST(0),2))=1 S %Y=^(2) D 2 +ANSBAK I $D(^%ZIS(2,%ZISIOST(0),102)) S %Y=^(102) D 2 E S POP=1 D:'$D(IOP) SAY($C(7)_"[NOT ON LINE]") C:%ZISB IO K IO(1,IO) G QUIT + I $D(%ZISMTR) X ^%ZOSF("MAGTAPE") U IO W:$D(%MT("REW")) @%MT("REW") U IO(0) K %MT + G QUIT:'$D(IO("P")) + I $F(IO("P"),"B"),$D(^%ZIS(2,%ZISIOST(0),7)) S %Y=$P(^(7),"^",1) I %Y]"" W @%Y + S %Y=$F(IO("P"),"P") G QLTY:'%Y S %Y=+$E(IO("P"),%Y,99),%X=$S(%Y=16:12.1,%Y=10!(%Y=12):5,1:"") G QLTY:'%X + S %Y=$S($D(^%ZIS(2,%ZISIOST(0),%X)):$P(^(%X),"^",$S(%Y=12:2,1:1)),1:"") + I %Y]"" W @%Y +QLTY S %Y=$F(IO("P"),"Q") Q:'%Y S %Y=+$E(IO("P"),%Y,99),%X=$S(%Y<0!(%Y>2):0,1:%Y+1) + I %X S %Y=$S($D(^%ZIS(2,%ZISIOST(0),12.2)):$P(^(12.2),"^",%X),1:"") I %Y]"" W @%Y +QUIT U:%IS'[0 IO(0) + Q +2 Q:%Y="" I %IS'[0,$D(^%ZIS(1,+%H,"TYPE")),^("TYPE")["TRM" D OH Q:POP + S %X=$T U IO D %Y^ZISX ;Q:'%X U IO(0) + Q +OH Q:$S($G(IO(0))]"":$D(IO(1,IO(0))),1:0) + N X S X="OPNERR^%ZIS4",@^%ZOSF("TRAP") + O IO(0)::0 S IO(1,IO(0))="" Q ;See that HOME DEVICE is open. + ; +SAY(%SAY) ; + Q:%IS[0 U IO(0) W %SAY U IO + Q +RES1 ;Allocate a resource slot, Release in %ZISC. + N A,L,X,%ZISD0 + S %ZISD0=$O(^%ZISL(3.54,"B",IO,0)) + I '%ZISD0 S %ZISD0=$$RADD(IO) ;New one + L +^%ZISL(3.54,%ZISD0,0):2 I '$T S POP=1 W:'$D(IOP) *7," [NOT Available]" G RESX +RES2 S X=$P(^%ZISL(3.54,%ZISD0,0),"^",2) + I X<1 S POP=1 W:'$D(IOP) *7," [NOT Available]" G RESX + S X=$S(X>0:X-1,1:0),$P(^%ZISL(3.54,%ZISD0,0),"^",2)=X + ; +R1 ;Grab a slot + S IO(1,IO)="RES",A=$G(^%ZISL(3.54,%ZISD0,1,0),"^3.542^^") + F L=1:1:%ZISRL I '$D(^%ZISL(3.54,%ZISD0,1,L,0)) Q + I '$T K IO(1,IO) G RES2 ;No free slots + S ^%ZISL(3.54,%ZISD0,1,L,0)=L_"^"_%ZISV_"^"_$J_"^"_$G(ZTSK)_"^"_$H,^%ZISL(3.54,"AJ",$J,%ZISD0,L)="",^%ZISL(3.54,%ZISD0,1,"B",L,L)="" + S $P(A,"^",3,4)=L_U_($P(A,U,4)+1),^%ZISL(3.54,%ZISD0,1,0)=A +RESX L -^%ZISL(3.54,%ZISD0,0) Q + ; +RADD(X) ;Add Resource + N %1,%2 + S %1=$G(^%ZISL(3.54,0),"RESOURCE^3.54^^"),%2=$P(%1,U,3) + F %2=%2:1 Q:'$D(^%ZISL(3.54,%2,0)) + S $P(^%ZISL(3.54,0),U,3,4)=%2_U_($P(%1,U,4)+1),^%ZISL(3.54,%2,0)=X_"^"_$G(%ZISRL,1),^%ZISL(3.54,"B",X,%2)="" + Q %2 + ; +RESOK ;DEVOK check for RES devices, for all OS's. + N %ZISD0,%ZISD1 + S Y=0,%ZISD0=$O(^%ZISL(3.54,"B",X,0)) + I '%ZISD0 S Y=-1,%ZISD0=$O(^%ZIS(1,"C",X,0)) Q:'%ZISD0 Q:'$D(^%ZIS(1,+%ZISD0,0)) Q:$P(^(0),"^")'=X Q:'$D(^("TYPE")) Q:^("TYPE")'="RES" S Y=0 Q + S X1=$G(^%ZISL(3.54,+%ZISD0,0)) + I $P(X1,"^",2)&(X=$P(X1,"^")) S Y=0 Q + S Y=999 F %ZISD1=0:0 S %ZISD1=$O(^%ZISL(3.54,%ZISD0,1,%ZISD1)) Q:%ZISD1'>0 I $D(^(%ZISD1,0)) S Y=$P(^(0),"^",3) Q + Q + ; +Q G Q^%ZIS3 +HG ; + Q +SPL N %E,%Z D MARGN^%ZIS3 W:'$D(IOP) ! D SPOOL^%ZIS4:%IS'["T" ;Spool type + G Q +MT D MARGN^%ZIS3,ASKPAR,AMTREW:'POP&'$D(IOP)&%ZISB W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) ;Magtape type + G Q +SDP D MARGN^%ZIS3,ASKPAR W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) ;Sequential disk processor type + G Q +HFS D MARGN^%ZIS3,HFS^%ZIS4 W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) ;Host File Server type + G Q +RES G Q:%IS["T" N X,X1 I %IS'["R"!'$D(IOP) S POP=1 W:'$D(IOP) *7," [NOT AVAILABLE]" Q ;Resources + G Q:$D(IO(1,IO)) I %IS["T" S X=IO,X1="RES" D DEVOK^%ZIS3 S:Y POP=1 G Q:POP + D:%ZISB RES1 G Q +CHAN ;Network Channel type devices -- DecNet or TCP/IP devices. + I IO="SYS$NET",$I="SYS$INPUT:;" S IO(0)=IO U IO ;DECNET Server Device + D MARGN^%ZIS3:'POP,ASKPAR:'POP W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) + G Q +IMPC ;Imaging Work Station +BAR ;Bar Code +OTH D MARGN^%ZIS3:'POP,ASKPAR:'POP W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) ;Other Device type + G Q + ; +ASKPAR G SETPAR^%ZIS3:$D(IOP),SETPAR^%ZIS3:'$P(^%ZIS(1,%E,0),"^",4) W " ADDRESS/PARAMETERS: " W:%ZISOPAR]"" %ZISOPAR_"// " D SBR^%ZIS1 D MSG1:%X="?" G ASKPAR:%X="?" S:%X]"" %ZISOPAR=%X I $D(DTOUT)!$D(DUOUT) S POP=1 + I POP,%ZISB&(%ZTYPE["TRM") C IO K IO(1,IO) Q + Q:POP G SETPAR^%ZIS3 +AMTREW I %ZISB,%ZTYPE="MT",'$D(IOP) W " REWIND" S %=2,U="^",%ZISDTIM=60 D YN^%ZIS1 K %ZISDTIM G AMTREW:%=0 I %=-1 S POP=1 Q + S:%=1 %ZISMTR=1 Q +MSG1 W !?5,"Enter the desired parameters needed to open the selected device.",!?25 Q + ; diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZISC.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZISC.m index cf0a43b7..5afccd1c 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZISC.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZISC.m @@ -1,130 +1,131 @@ -%ZISC ;SFISC/GFT,AC,MUS - CLOSE LOGIC FOR DEVICES ;1/24/08 16:09 - ;;8.0;KERNEL;**24,36,49,69,199,216,275,409,440**;JUL 10, 1995;Build 13 - ;Per VHA Directive 2004-038, this routine should not be modified -C0 ; - N %,%E,%H,%ZISI,%ZISOS,%ZISX,%ZISV - ;Clear IO var we will use for reporting - K IO("ERROR"),IO("LASTERR"),IO("CLOSE") - ;Protect ourself from calls with incomplete setup. - S:$D(IO)[0 IO=$I S:'$D(IO(0)) IO(0)=$P - S U="^",%ZISOS=$G(^%ZOSF("OS")),%ZISV=$G(^("VOL")) - ;S %=$S(+$G(IOS):IOS,$L($G(ION)):ION,1:IO) - S %=$S($L($G(ION)):ION,1:IO) ;p409 - I (%="")!(IO="") G SETIO:IO(0)]"",END - I $G(IOT)="RES" D RES G SETIO ;Handle a resource device - ; - ;Define subtype info if not already defined. - D SUBTYPE - ; - ;perform close execute - I $G(IOST(0))>0 D - . I $G(^%ZIS(2,+IOST(0),3))]"",$D(IO(1,IO)) D - . . U IO S:$X $X=1 D X3^ZISX:'$D(IO("T")) - ; - ;Incase the Close execute changed IO, Open IO("HOME") or NULL. - I '$L($G(IO)) D Q - . S IOP=$S($L($G(IO("HOME"))):"`"_(+IO("HOME")),1:"NULL") D ^%ZIS - . Q - ; - ;Perform the following if the device is open. - I $D(IO(1,IO)) D - . I $G(IO("P"))["B" D ;Return to normal intensity - . . S %=$P($G(^%ZIS(2,+IOST(0),7)),"^",3) I %]"" W @% - . I $G(IO("P"))["P" D ;Return to default pitch - . . S %=$G(^%ZIS(2,+IOST(0),12.11)) I %]"" W @% - . ; - . W:$$FF @IOF ;Issue form feed at close - . I $$CLOSPP D X11^ZISX:'$D(IO("T")) K IO("S") ;Close printer port - . Q - ; - ;Don't use IOCPU as we now use IO(1,IO) - I (IO'=IO(0)!$D(IO("C"))),$D(IO(1,IO)) D - . U:$S($D(ZTQUEUED):0,'$L($G(IO(0))):0,$D(IO(1,IO(0)))#2:1,1:0) IO(0) - . C IO K IO(1,IO) S IO("CLOSE")=IO ;close device - ;Unlock global used to control access. - S %=$G(^XUTL("XQ",$J,"lock",+$G(IOS))) I $L(%) L -@% K ^XUTL("XQ",$J,"lock",IOS) - ; - I $D(IO("SPOOL")) D CLOSE^%ZIS4 ;Special close for spool device - ; -SETIO ; - ;See if old device has PCX code - I $G(IOS),$G(^%ZIS(1,+IOS,"PCX"))]"" S %ZISPCX=^("PCX") - ;Setup the IO(0) device, should be the home device - S IO=IO(0),(IOPAR,IOUPAR)="" K IO("T") D CIOS(IO(0)) - I 'IOS S IOT="TRM" G END - S ION=$P(^%ZIS(1,IOS,0),"^",1),IOT=$G(^("TYPE")),IOST(0)=$S(IOT["TRM"&($D(^XUTL("XQ",$J,"IOST(0)"))):^("IOST(0)"),1:$G(^%ZIS(1,IOS,"SUBTYPE"))) - I IOT["TRM",$D(^XUTL("XQ",$J,"IO")) D HOME^%ZIS G END - S %="Y" - I IOST(0),$D(^%ZIS(2,IOST(0),1)) S %=^(1),IOM=+%,IOF=$P(%,"^",2),IOSL=$P(%,"^",3),IOBS=$P(%,"^",4) - I $D(^%ZIS(1,IOS,91)) S %=^%ZIS(1,IOS,91) S:+% IOM=+% S:$P(%,"^",3) IOSL=$P(%,"^",3) - ;Don't know the subtype so set some defaults - I %="Y" S IOM=80,IOSL=24,IOF="#",IOST="C-OTHER",IOBS="$C(8)" -S1 S:IOST(0) IOST=$P($G(^%ZIS(2,+IOST(0),0)),"^"),IOXY=$G(^("XY")) - I '$D(ZTQUEUED),'$D(IO("C")),IOT["TRM" D RM:$D(IO(1,IO)) - ;With home device set, Do Post-close execute code of Device closed. -END I '$D(IO("T")),$G(%ZISPCX)]"" S %Y=%ZISPCX D %Y^ZISX - ;See that any extra IO variables are cleaned up - K IO("P"),IO("DOC"),IO("HFSIO"),IO("SPOOL"),IOC,IONOFF - ;IOCPU should not be changed. - Q - ; -SUBTYPE ;Find a subtype - N %S - S IOST=$G(IOST),IOST(0)=+$G(IOST(0)) - I $L(IOST)&$L(IOST(0)) Q ;Have a subtype - S %S=$G(^%ZIS(2,+IOST(0),0)) I $L(%S) S IOST=$P(%S,U) Q - I $L(IOST) S %S=$O(^%ZIS(2,"B",$G(IOST,"X"),0)) I %S>0 S IOST(0)=+%S Q - S IOST="",IOST(0)=0 D CIOS($I) Q:IOS'>0 - S IOST(0)=$G(^%ZIS(1,+IOS,"SUBTYPE")),IOST=$P($G(^%ZIS(2,+IOST(0),0)),"^") - Q - ; -CIOS(%I) ;Find a value for IOS (IEN into device file) - N %ZISVT - I $D(^XUTL("XQ",$J,"IOS")) S IOS=+^("IOS") Q - I $D(%ZISV) S %ZISVT=%I D VTLKUP^%ZIS S IOS=+%E - E S IOS=+$O(^%ZIS(1,"C",%I,0)) - Q:$G(IOS)>0 - S %ZISVT=%I D VIRTUAL^%ZIS - I $D(%ZISVT) S %H=%E I %ZISVT]"",%H>0,$D(^%ZIS(1,%H,0)),$D(^("TYPE")),^("TYPE")="VTRM" S IOS=%H - Q - ; -RM N X S X=+IOM X ^%ZOSF("RM") - Q - ; -RES ;Close resource device. - Q:'$D(IO(1,IO))&'$D(^%ZISL(3.54,"AJ",$J)) - N %ZISJOB,%X,%Y,%ZISD0,%ZISD1,%ZISRES,%ZISRL,%ZISY0,%ZTRTN,ZTSAVE,ZTIO - S %ZISJOB=$J - ; -RES1 G RQ:'$D(IOS),RQ:'$D(^%ZIS(1,+IOS,1)) S %ZISRL=+$P(^(1),"^",10),%ZISRL=$S(%ZISRL:%ZISRL,1:1) - S %X=$O(^%ZISL(3.54,"B",IO,0)) G RQ:'%X - G RQ:'$D(^%ZISL(3.54,+%X,0)) S %ZISD0=+%X,%ZISY0=^(0) - S %X=$O(^%ZISL(3.54,"AJ",%ZISJOB,%ZISD0,0)) S %ZISD1=%X G RQ:'%X - S %Y=$G(^%ZISL(3.54,%ZISD0,1,+%ZISD1,0)) G RQ:$P(%Y,"^",3)'=%ZISJOB - D KILLRES(+%ZISD0,+%ZISD1) -RQ K IO(1,IO) - Q - ; -KILLRES(D0,D1) ;Kill one resource use - Q:(D0'>0)!(D1'>0) - N %X,%Y,%J,%ZISRL - L +^%ZISL(3.54,D0,0) - S %Y=$G(^%ZISL(3.54,D0,0)) G KRX:%Y="" - S %X=$G(^%ZISL(3.54,D0,1,D1,0)),%J=$P(%X,"^",3) S:%J="" %J=" " - K ^%ZISL(3.54,D0,1,D1,0),^%ZISL(3.54,D0,1,"B",D1,D1),^%ZISL(3.54,"AJ",%J,D0,D1) - S %X=$P(%Y,"^",2)+1,$P(^%ZISL(3.54,D0,0),"^",2)=%X - ;I '$D(^%ZISL(3.54,%ZISD0,1,0)) S ^(0)="^3.542A^^" G RQ - S %Y=$G(^%ZISL(3.54,D0,1,0)),%X=$P(%Y,"^",4),$P(^%ZISL(3.54,D0,1,0),"^",3,4)="^"_$S(%X>0:(%X-1),1:0) -KRX L -^%ZISL(3.54,D0,0) - Q - ; -DQCRES ;Tasked entry point to close resource device. - S IO=%ZISRES G RES1 - ; -FF() ;Issue form feed - I $E(IOST,1,2)'["C-",$D(IO(1,IO)),$G(IOT)="TRM"!($G(IOT)="SPL"),'$D(IO("T"))&$Y&'$D(IONOFF)&'$D(IO(1,IO,"NOFF")) Q 1 - Q 0 - ; -CLOSPP() ;Close printer port - I $D(IO("S")),$D(^%ZIS(2,+IO("S"),11))&$D(IO(1,IO)) Q 1 - Q 0 +%ZISC ;SFISC/GFT,AC,MUS - CLOSE LOGIC FOR DEVICES ;01/14/2002 09:06 + ;;8.0;KERNEL;**24,36,49,69,199,216,275,409**;JUL 10, 1995;Build 3 +C0 ; + N %,%E,%H,%ZISI,%ZISOS,%ZISX,%ZISV + ;Clear IO var we will use for reporting + K IO("ERROR"),IO("LASTERR"),IO("CLOSE") + ;Protect ourself from calls with incomplete setup. + S:$D(IO)[0 IO=$I S:'$D(IO(0)) IO(0)=$P + S U="^",%ZISOS=$G(^%ZOSF("OS")),%ZISV=$G(^("VOL")) + ;S %=$S(+$G(IOS):IOS,$L($G(ION)):ION,1:IO) + S %=$S($L($G(ION)):ION,1:IO) ;p409 + I (%="")!(IO="") G SETIO:IO(0)]"",END + I $G(IOT)="RES" D RES G SETIO ;Handle a resource device + ; + ;Define subtype info if not already defined. + D SUBTYPE + ; + ;perform close execute + I $G(IOST(0))>0 D + . I $G(^%ZIS(2,+IOST(0),3))]"",$D(IO(1,IO)) D + . . U IO S:$X $X=1 D X3^ZISX:'$D(IO("T")) + ; + ;Incase the Close execute changed IO, Open IO("HOME") or NULL. + I '$L($G(IO)) D Q + . S IOP=$S($L($G(IO("HOME"))):"`"_(+IO("HOME")),1:"NULL") D ^%ZIS + . Q + ; + ;Perform the following if the device is open. + I $D(IO(1,IO)) D + . I $G(IO("P"))["B" D ;Return to normal intensity + . . S %=$P($G(^%ZIS(2,+IOST(0),7)),"^",3) I %]"" W @% + . I $G(IO("P"))["P" D ;Return to default pitch + . . S %=$G(^%ZIS(2,+IOST(0),12.11)) I %]"" W @% + . ; + . W:$$FF @IOF ;Issue form feed at close + . I $$CLOSPP D X11^ZISX:'$D(IO("T")) K IO("S") ;Close printer port + . Q + ; + ;Don't use IOCPU as we now use IO(1,IO) + I (IO'=IO(0)!$D(IO("C"))),$D(IO(1,IO)) D + . U:$S($D(ZTQUEUED):0,'$L($G(IO(0))):0,$D(IO(1,IO(0)))#2:1,1:0) IO(0) + . C IO K IO(1,IO) S IO("CLOSE")=IO ;close device + ; + ; + I $D(IOT),IOT="CHAN",$D(IOS) D + .S %=$G(^%ZIS(1,+IOS,"GBL")) + .I %]"" L @("-^"_%) ;unlock global used to control access to network channels. + I $D(IO("SPOOL")) D CLOSE^%ZIS4 ;Special close for spool device + ; +SETIO ; + ;See if old device has PCX code + I $G(IOS),$G(^%ZIS(1,+IOS,"PCX"))]"" S %ZISPCX=^("PCX") + ;Setup the IO(0) device, should be the home device + S IO=IO(0),(IOPAR,IOUPAR)="" K IO("T") D CIOS(IO(0)) + I 'IOS S IOT="TRM" G END + S ION=$P(^%ZIS(1,IOS,0),"^",1),IOT=$G(^("TYPE")),IOST(0)=$S(IOT["TRM"&($D(^XUTL("XQ",$J,"IOST(0)"))):^("IOST(0)"),1:$G(^%ZIS(1,IOS,"SUBTYPE"))) + I IOT["TRM",$D(^XUTL("XQ",$J,"IO")) D HOME^%ZIS G END + S %="Y" + I IOST(0),$D(^%ZIS(2,IOST(0),1)) S %=^(1),IOM=+%,IOF=$P(%,"^",2),IOSL=$P(%,"^",3),IOBS=$P(%,"^",4) + I $D(^%ZIS(1,IOS,91)) S %=^%ZIS(1,IOS,91) S:+% IOM=+% S:$P(%,"^",3) IOSL=$P(%,"^",3) + ;Don't know the subtype so set some defaults + I %="Y" S IOM=80,IOSL=24,IOF="#",IOST="C-OTHER",IOBS="$C(8)" +S1 S:IOST(0) IOST=$P($G(^%ZIS(2,+IOST(0),0)),"^"),IOXY=$G(^("XY")) + I '$D(ZTQUEUED),'$D(IO("C")),IOT["TRM" D RM:$D(IO(1,IO)) + ;With home device set, Do Post-close execute code of Device closed. +END I '$D(IO("T")),$G(%ZISPCX)]"" S %Y=%ZISPCX D %Y^ZISX + ;See that any extra IO variables are cleaned up + K IO("P"),IO("DOC"),IO("HFSIO"),IO("SPOOL"),IOC,IONOFF + ;IOCPU should not be changed. + Q + ; +SUBTYPE ;Find a subtype + N %S + S IOST=$G(IOST),IOST(0)=+$G(IOST(0)) + I $L(IOST)&$L(IOST(0)) Q ;Have a subtype + S %S=$G(^%ZIS(2,+IOST(0),0)) I $L(%S) S IOST=$P(%S,U) Q + I $L(IOST) S %S=$O(^%ZIS(2,"B",$G(IOST,"X"),0)) I %S>0 S IOST(0)=+%S Q + S IOST="",IOST(0)=0 D CIOS($I) Q:IOS'>0 + S IOST(0)=$G(^%ZIS(1,+IOS,"SUBTYPE")),IOST=$P($G(^%ZIS(2,+IOST(0),0)),"^") + Q + ; +CIOS(%I) ;Find a value for IOS (IEN into device file) + N %ZISVT + I $D(^XUTL("XQ",$J,"IOS")) S IOS=+^("IOS") Q + I $D(%ZISV) S %ZISVT=%I D VTLKUP^%ZIS S IOS=+%E + E S IOS=+$O(^%ZIS(1,"C",%I,0)) + Q:$G(IOS)>0 + S %ZISVT=%I D VIRTUAL^%ZIS + I $D(%ZISVT) S %H=%E I %ZISVT]"",%H>0,$D(^%ZIS(1,%H,0)),$D(^("TYPE")),^("TYPE")="VTRM" S IOS=%H + Q + ; +RM N X S X=+IOM X ^%ZOSF("RM") + Q + ; +RES ;Close resource device. + Q:'$D(IO(1,IO))&'$D(^%ZISL(3.54,"AJ",$J)) + N %ZISJOB,%X,%Y,%ZISD0,%ZISD1,%ZISRES,%ZISRL,%ZISY0,%ZTRTN,ZTSAVE,ZTIO + S %ZISJOB=$J + ; +RES1 G RQ:'$D(IOS),RQ:'$D(^%ZIS(1,+IOS,1)) S %ZISRL=+$P(^(1),"^",10),%ZISRL=$S(%ZISRL:%ZISRL,1:1) + S %X=$O(^%ZISL(3.54,"B",IO,0)) G RQ:'%X + G RQ:'$D(^%ZISL(3.54,+%X,0)) S %ZISD0=+%X,%ZISY0=^(0) + S %X=$O(^%ZISL(3.54,"AJ",%ZISJOB,%ZISD0,0)) S %ZISD1=%X G RQ:'%X + S %Y=$G(^%ZISL(3.54,%ZISD0,1,+%ZISD1,0)) G RQ:$P(%Y,"^",3)'=%ZISJOB + D KILLRES(+%ZISD0,+%ZISD1) +RQ K IO(1,IO) + Q + ; +KILLRES(D0,D1) ;Kill one resource use + Q:(D0'>0)!(D1'>0) + N %X,%Y,%J,%ZISRL + L +^%ZISL(3.54,D0,0) + S %Y=$G(^%ZISL(3.54,D0,0)) G KRX:%Y="" + S %X=$G(^%ZISL(3.54,D0,1,D1,0)),%J=$P(%X,"^",3) S:%J="" %J=" " + K ^%ZISL(3.54,D0,1,D1,0),^%ZISL(3.54,D0,1,"B",D1,D1),^%ZISL(3.54,"AJ",%J,D0,D1) + S %X=$P(%Y,"^",2)+1,$P(^%ZISL(3.54,D0,0),"^",2)=%X + ;I '$D(^%ZISL(3.54,%ZISD0,1,0)) S ^(0)="^3.542A^^" G RQ + S %Y=$G(^%ZISL(3.54,D0,1,0)),%X=$P(%Y,"^",4),$P(^%ZISL(3.54,D0,1,0),"^",3,4)="^"_$S(%X>0:(%X-1),1:0) +KRX L -^%ZISL(3.54,D0,0) + Q + ; +DQCRES ;Tasked entry point to close resource device. + S IO=%ZISRES G RES1 + ; +FF() ;Issue form feed + I $E(IOST,1,2)'["C-",$D(IO(1,IO)),$G(IOT)="TRM"!($G(IOT)="SPL"),'$D(IO("T"))&$Y&'$D(IONOFF)&'$D(IO(1,IO,"NOFF")) Q 1 + Q 0 + ; +CLOSPP() ;Close printer port + I $D(IO("S")),$D(^%ZIS(2,+IO("S"),11))&$D(IO(1,IO)) Q 1 + Q 0 diff --git a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZISS1.m b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZISS1.m index 63fc0895..e1006a9c 100644 --- a/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZISS1.m +++ b/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZISS1.m @@ -1,88 +1,69 @@ -%ZISS1 ;AC/SFISC - Collect screen parameters 5/29/88 2:02 PM ;1/24/08 16:10 - ;;8.0;KERNEL;**69,440**;JUL 10, 1995;Build 13 - ;Per VHA Directive 2004-038, this routine should not be modified -VALID ; - N %ZISI,%ZISNP,ZISCH,ZISEND,ZISNUM,ZISQ,ZISXL,ZISXLN ;p440 - D L - Q - ; -SET2 ; - S %ZISFN="" F %ZISZ=0:0 S %ZISFN=$O(%ZISZ(%ZISFN)) Q:%ZISFN="" I $D(%ZISZ(%ZISFN))#2 S %ZISXX=%ZISZ(%ZISFN) D INDCK - Q -INDCK ; - S %ZISY="" - I "IOEFLD^IOSTBM"[%ZISFN S @%ZISFN=%ZISXX Q - I %ZISXX]"" S @("%ZISY="_%ZISXX) - ;E S @("%ZISY="_"""""") - I $E(%ZISFN,1,2)="IO" S @%ZISFN=%ZISY - E S @("IO"_$E(%ZISFN,1,6))=%ZISY - Q:'$D(%ZIS)#2 Q:%ZIS'["I" Q:'$D(%ZISZ(%ZISFN,1)) - ; -SRAY ; - S %=%ZISY,%ZISY=$A($E(%ZISY,1)) - F %1=2:1:$L(%) S %ZISY=%ZISY_$S($A(%,%1)<32:$A(%,%1),$A(%,%1)=127:127,1:$E(%,%1)) - S IOIS(%ZISY)=%ZISFN - Q -CHECK ;Entry point called from input transforms of fields in DEV/TT files. - N %ZISXX,%ZISYY,%ZISI,%ZISNP,%ZISX1,%ZISX2,ZISCH,ZISNUM,ZISQ,ZISXL,ZISXLN ;p440 - S %ZISXX=X D L S X=%ZISYY - Q -CHECK1 ;Entry point called from input transforms of fields in DEV/TT files. - N %ZISXX,%ZISYY,%ZISI,%ZISNP,%ZISX1,%ZISX2,ZISCH,ZISNUM,ZISQ,ZISXL,ZISXLN ;p440 - S %ZISXX=$S(X?1"W ".E:$E(X,3,$L(X)),1:X) - D L S X=$S(X?1"W ".E:"W "_%ZISYY,1:%ZISYY) - Q -FORM ;Entry point called from input transforms of fields in DEV/TT files. - Q:$L(X,"_")'>1 - N %ZISSI,%ZISSY ;p440 - ;F %ZISSI=1:1:$L(X,"_") S %ZISX1=$P(X,"_",%ZISSI) I %ZISX1]"","#?!"[$E(%ZISX1) S X=$S(%ZISSI=1:"",1:$P(X,"_",1,%ZISSI-1)_",")_%ZISX1_$S(%ZISSI<$L(X,"_"):","_$P(X,"_",%ZISSI+1,255),1:"") W !,%ZISSI_"==>"_X - S %ZISSY="" - F %ZISSI=1:1:$L(X,"_") S %ZISSY=%ZISSY_$P(X,"_",%ZISSI)_$S($P(X,"_",%ZISSI+1)="":"","#?!"[$E($P(X,"_",%ZISSI+1)):",","#?!"[$E($P(X,"_",%ZISSI)):",",1:"_") - S X=%ZISSY - Q - ; -L S ZISQ="""",%ZISNP=0,ZISXLN=$L(%ZISXX) I 'ZISXLN S %ZISYY="" Q - S ZISXL=0,%ZISYY="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) D L1 Q:ZISXL'2,%ZISYY[")_$C(" S %ZISXX=%ZISYY D L2,L3 S %ZISYY=%ZISXX Q - S %ZISXX=%ZISYY D L2,L3 S %ZISYY=%ZISXX - Q -L1 I ZISCH="_"!(ZISCH=",") S %ZISYY=%ZISYY_"_" Q - I ZISCH=ZISQ D QUOTE Q - I ZISCH="$" D DOLR Q - I ZISCH="*" D STAR Q - I ZISCH="(" D PAREN Q - S %ZISYY=%ZISYY_ZISCH - Q -L2 ;Find $C(x)_$C(y) and merge - N I ;p440 - F I=1:1:$L(%ZISXX,"_") S %ZISX1=$P(%ZISXX,"_",I),%ZISX2=$P(%ZISXX,"_",I+1) I $E(%ZISX1,1,3)="$C(",$E(%ZISX2,1,3)="$C(" D S2 - Q -L3 ; - N I - F I=1:1:$L(%ZISXX,"_") I $P(%ZISXX,"_",I)["+","$("'[$E($P(%ZISXX,"_",I)),")"'[$E($P(%ZISXX,"_",I),$L($P(%ZISXX,"_",I))) S $P(%ZISXX,"_",I)="("_$P(%ZISXX,"_",I)_")" - Q -STAR ;S ZISNUM="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) S:ZISCH?1N ZISNUM=ZISNUM_ZISCH I ZISCH=""!(ZISCH=",") S %ZISYY=%ZISYY_"$C("_+ZISNUM_")",ZISXL=ZISXL-1 Q - S ZISNUM="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) S:ZISCH'=""&(ZISCH'=",") ZISNUM=ZISNUM_ZISCH I ZISCH=""!(ZISCH=",") S %ZISYY=%ZISYY_"$C("_ZISNUM_")",ZISXL=ZISXL-1 Q - Q -QUOTE S %ZISYY=%ZISYY_ZISCH F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL),%ZISYY=%ZISYY_ZISCH I ZISCH=ZISQ!(ZISXL'1 + ;F %ZISSI=1:1:$L(X,"_") S %ZISX1=$P(X,"_",%ZISSI) I %ZISX1]"","#?!"[$E(%ZISX1) S X=$S(%ZISSI=1:"",1:$P(X,"_",1,%ZISSI-1)_",")_%ZISX1_$S(%ZISSI<$L(X,"_"):","_$P(X,"_",%ZISSI+1,255),1:"") W !,%ZISSI_"==>"_X + S %ZISSY="" + F %ZISSI=1:1:$L(X,"_") S %ZISSY=%ZISSY_$P(X,"_",%ZISSI)_$S($P(X,"_",%ZISSI+1)="":"","#?!"[$E($P(X,"_",%ZISSI+1)):",","#?!"[$E($P(X,"_",%ZISSI)):",",1:"_") + S X=%ZISSY K %ZISSI,%ZISSY + Q + ; +L S ZISQ="""",%ZISNP=0,ZISXLN=$L(%ZISXX) I 'ZISXLN S %ZISYY="" Q + S (ZISXL)=0,%ZISYY="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) D L1 Q:ZISXL'2,%ZISYY[")_$C(" S %ZISXX=%ZISYY D L2,L3 S %ZISYY=%ZISXX Q + S %ZISXX=%ZISYY D L2,L3 S %ZISYY=%ZISXX + Q +L1 I ZISCH="_"!(ZISCH=",") S %ZISYY=%ZISYY_"_" Q + I ZISCH=ZISQ D QUOTE Q + I ZISCH="$" D DOLR Q + I ZISCH="*" D STAR Q + I ZISCH="(" D PAREN Q + S %ZISYY=%ZISYY_ZISCH Q +L2 F I=1:1:$L(%ZISXX,"_") S %ZISX1=$P(%ZISXX,"_",I),%ZISX2=$P(%ZISXX,"_",I+1) I $E(%ZISX1,1,3)="$C(",$E(%ZISX2,1,3)="$C(" D S2 + Q +L3 F I=1:1:$L(%ZISXX,"_") I $P(%ZISXX,"_",I)["+","$("'[$E($P(%ZISXX,"_",I)),")"'[$E($P(%ZISXX,"_",I),$L($P(%ZISXX,"_",I))) S $P(%ZISXX,"_",I)="("_$P(%ZISXX,"_",I)_")" + Q +STAR ;S ZISNUM="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) S:ZISCH?1N ZISNUM=ZISNUM_ZISCH I ZISCH=""!(ZISCH=",") S %ZISYY=%ZISYY_"$C("_+ZISNUM_")",ZISXL=ZISXL-1 Q + S ZISNUM="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) S:ZISCH'=""&(ZISCH'=",") ZISNUM=ZISNUM_ZISCH I ZISCH=""!(ZISCH=",") S %ZISYY=%ZISYY_"$C("_ZISNUM_")",ZISXL=ZISXL-1 Q + Q +QUOTE S %ZISYY=%ZISYY_ZISCH F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL),%ZISYY=%ZISYY_ZISCH I ZISCH=ZISQ!(ZISXL'1 S %=ZTSK K ZTSK S ZTSK=% - I ZTSK<1!(ZTSK\1'=ZTSK) S ZTSK="",ZTSK(0)="",ZTSK("E")="IT" G QUIT - S ZTSK(0)="",ZTSK("E")="U",$ET="Q:$ES S $EC="""" G QUIT^%ZTLOAD4" - S %ZTVOL=^%ZOSF("VOL") - I $D(ZTCPU)[0 S ZTCPU=%ZTVOL - I ZTCPU="" S ZTCPU=%ZTVOL - I ZTCPU'=%ZTVOL G THERE - ; -HERE ;lookup task's status on current volume set - L +^%ZTSK(ZTSK):1 - I $D(^%ZTSK(ZTSK,0))[0 S ZTSK("E")="I" G QUIT - S ZTREC=^%ZTSK(ZTSK,0),ZTD=$G(^(.04)) - S ZTSK("DUZ")=$P(ZTREC,U,3),ZTSK("D")=$P(ZTREC,U,6) ;scheduled $H - I ZTD]"",$D(^%ZTSCH(ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT - I ZTD]"",$D(^%ZTSCH("JOB",ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT - ; - S ZT1="" F S ZT1=$O(^%ZTSCH(ZT1)) Q:'ZT1 I $D(^(ZT1,ZTSK))#2 S ZTSK(0)=1 G QUIT - S ZT1="IO",ZT2="" F S ZT2=$O(^%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2="" F S ZT3=$O(^%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3="" I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT - S ZT1="JOB",ZT2="" F S ZT2=$O(^%ZTSCH(ZT1,ZT2)) Q:ZT2="" I $D(^(ZT2,ZTSK))#2 S ZTSK(0)=1 G QUIT - S ZT1="LINK",ZT2="" F S ZT2=$O(^%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2="" F S ZT3=$O(^%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3="" I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT - S ZTSK(0)=0 - ; -QUIT ;cleanup and quit - L:ZTSK -^%ZTSK(ZTSK) ;K %ZTCPU,%ZTM,%ZTM1,%ZTM2,%ZTMAST,%ZTVOL,X,Y,ZT,ZT1,ZT2,ZT3,ZTCPU,ZTD,ZTREC - I ZTSK(0)]"" K ZTSK("E") Q - I ZTSK("E")'="U" Q - S ZTSK("E",0)=$$EC^%ZOSV - Q - ; -THERE ;rest of code looks up task's status on some other volume set - N %ZTCPU,%ZTM,X,Y - ; -FILES ;find TaskMan files on the volume set to be searched - S %ZTCPU=$O(^%ZIS(14.5,"B",ZTCPU,"")) - I %ZTCPU="" S ZTSK("E")="IS" G QUIT - S %ZTM=$P(^%ZOSF("MGR"),",") - S %ZTM=$S($D(^%ZIS(14.5,%ZTCPU,0))[0:%ZTM,$P(^(0),U,6)="":%ZTM,1:$P(^(0),U,6)) - S X=%ZTM,Y=ZTCPU - S ZTSK("E")="LS",ZT=$D(^[X,Y]%ZTSK(0)),ZTSK("E")="U" ; check link - ; -SEARCH ;find out if task is queued on that volume set - I $D(^[X,Y]%ZTSK(ZTSK,0))[0 S ZTSK("E")="I" G QUIT - S ZTREC=^[X,Y]%ZTSK(ZTSK,0),ZTD=$G(^(.04)) - S ZTSK("DUZ")=$P(ZTREC,U,3),ZTSK("D")=$P(ZTREC,U,6) - I ZTD]"",$D(^[X,Y]%ZTSCH(ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT - I ZTD]"",$D(^[X,Y]%ZTSCH("JOB",ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT - ; - S ZT1="" F S ZT1=$O(^[X,Y]%ZTSCH(ZT1)) Q:'ZT1 I $D(^(ZT1,ZTSK))#2 S ZTSK(0)=1 G QUIT - S ZT1="IO",ZT2="" F S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2="" F S ZT3=$O(^[X,Y]%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3="" I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT - S ZT1="JOB",ZT2="" F S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)) Q:ZT2="" I $D(^(ZT2,ZTSK))#2 S ZTSK(0)=1 G QUIT - S ZT1="LINK",ZT2="" F S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2="" F S ZT3=$O(^[X,Y]%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3="" I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT - S ZTSK(0)=0 G QUIT - ; +%ZTLOAD4 ;SEA/RDS-TaskMan: P I: Is Queued? ;7/26/91 11:55 ; + ;;8.0;KERNEL;;JUL 10, 1995 + ;;7.0; + ; +INPUT ;check input parameters for error conditions + I $D(ZTSK)[0 S ZTSK="" + I $D(ZTSK)>1 S ZTLOAD=ZTSK K ZTSK S ZTSK=ZTLOAD K ZTLOAD + I ZTSK<1!(ZTSK\1'=ZTSK) S ZTSK="",ZTSK(0)="",ZTSK("E")="IT" G QUIT + S ZTSK(0)="",ZTSK("E")="U",X="QUIT^%ZTLOAD3",@^%ZOSF("TRAP") + S %ZTVOL=^%ZOSF("VOL") + I $D(ZTCPU)[0 S ZTCPU=%ZTVOL + I ZTCPU="" S ZTCPU=%ZTVOL + I ZTCPU'=%ZTVOL G THERE + ; +HERE ;lookup task's status on current volume set + L +^%ZTSK(ZTSK) I $D(^%ZTSK(ZTSK,0))[0 S ZTSK("E")="I" G QUIT + S ZTREC=^%ZTSK(ZTSK,0),ZTD=$P(ZTREC,U,6) + S ZTSK("DUZ")=$P(ZTREC,U,3),ZTSK("D")=ZTD + I ZTD]"",$D(^%ZTSCH(ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT + I ZTD]"",$D(^%ZTSCH("JOB",ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT + ; + S ZT1="" F ZT=0:0 S ZT1=$O(^%ZTSCH(ZT1)) Q:'ZT1 I $D(^(ZT1,ZTSK))#2 S ZTSK(0)=1 G QUIT + S ZT1="IO",ZT2="" F ZT=0:0 S ZT2=$O(^%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2="" F ZT=0:0 S ZT3=$O(^%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3="" I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT + S ZT1="JOB",ZT2="" F ZT=0:0 S ZT2=$O(^%ZTSCH(ZT1,ZT2)) Q:ZT2="" I $D(^(ZT2,ZTSK))#2 S ZTSK(0)=1 G QUIT + S ZT1="LINK",ZT2="" F ZT=0:0 S ZT2=$O(^%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2="" F ZT=0:0 S ZT3=$O(^%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3="" I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT + S ZTSK(0)=0 + ; +QUIT ;cleanup and quit + L:ZTSK -^%ZTSK(ZTSK) K %ZTCPU,%ZTM,%ZTM1,%ZTM2,%ZTMAST,%ZTVOL,X,Y,ZT,ZT1,ZT2,ZT3,ZTCPU,ZTD,ZTREC + I ZTSK(0)]"" K ZTSK("E") Q + I ZTSK("E")'="U" Q + S ZTSK("E",0)=$$EC^%ZOSV + Q + ; +THERE ;rest of code looks up task's status on some other volume set + ; +FILES ;find TaskMan files on the volume set to be searched + S %ZTCPU=$O(^%ZIS(14.5,"B",ZTCPU,"")) + I %ZTCPU="" S ZTSK("E")="IS" G QUIT + S %ZTM=$P(^%ZOSF("MGR"),",") + S %ZTM=$S($D(^%ZIS(14.5,%ZTCPU,0))[0:%ZTM,$P(^(0),U,6)="":%ZTM,1:$P(^(0),U,6)) + S X=%ZTM,Y=ZTCPU + S ZTSK("E")="LS",ZT=$D(^[X,Y]%ZTSK(0)),ZTSK("E")="U" ; check link + ; +SEARCH ;find out if task is queued on that volume set + I $D(^[X,Y]%ZTSK(ZTSK,0))[0 S ZTSK("E")="I" G QUIT + S ZTREC=^[X,Y]%ZTSK(ZTSK,0),ZTD=$P(ZTREC,U,6) + S ZTSK("DUZ")=$P(ZTREC,U,3),ZTSK("D")=ZTD + I ZTD]"",$D(^[X,Y]%ZTSCH(ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT + I ZTD]"",$D(^[X,Y]%ZTSCH("JOB",ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT + ; + S ZT1="" F ZT=0:0 S ZT1=$O(^[X,Y]%ZTSCH(ZT1)) Q:'ZT1 I $D(^(ZT1,ZTSK))#2 S ZTSK(0)=1 G QUIT + S ZT1="IO",ZT2="" F ZT=0:0 S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2="" F ZT=0:0 S ZT3=$O(^[X,Y]%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3="" I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT + S ZT1="JOB",ZT2="" F ZT=0:0 S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)) Q:ZT2="" I $D(^(ZT2,ZTSK))#2 S ZTSK(0)=1 G QUIT + S ZT1="LINK",ZT2="" F ZT=0:0 S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2="" F ZT=0:0 S ZT3=$O(^[X,Y]%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3="" I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT + S ZTSK(0)=0 G QUIT + ; diff --git a/r/LAB_SERVICE-LR-LS/LR7OB69.m b/r/LAB_SERVICE-LR-LS/LR7OB69.m index a552b956..b2a0c2a1 100644 --- a/r/LAB_SERVICE-LR-LS/LR7OB69.m +++ b/r/LAB_SERVICE-LR-LS/LR7OB69.m @@ -1,54 +1,55 @@ -LR7OB69 ;slc/dcm/JAH - Get Lab order data from 69 - 68 - 63 ;8/10/04 - ;;5.2;LAB SERVICE;**121,187,224,291,373**;Sep 27, 1994;Build 1 - ; -69(ODT,SN) ;Get data from file 69 - ;ODT=Order Date subscript in file 69 - ;SN=Specimen number subscript in file 69 - ;Y1=Lab order number - ;Y2=Start date - ;Y3=Sample - ;Y4=Collection type/Specimen Action code - ;Y5=Order date - ;Y6=Provider - ;Y7=Routing Location - ;Y8=Lab arrival time - ;Y9=Date/Time Results Available - ;Y10=Specimen - ;Y11=OERR Order # - ;Y12=Entering person - ;^TMP("LRX",$J,69)=Y1^Y2^Y3^Y4^Y5^Y6^Y7^Y8^Y9^Y10^Y11^Y12 - ;^TMP("LRX",$J,69,i)=Test^Urgency^Accession Date^Accession area^Accession #^Combined on order^ORIFN^Panel exploded - ;^TMP("LRX",$J,69,"N",i)=Specimen level comments (6 node) - ;^TMP("LRX",$J,69,i,"N",ifn)=Comments by test - ;^TMP("LRX",$J,69,i,"NC",ifn)=Free text cancel reason - ;^TMP("LRX",$J,69,i,"DGX",ifn)=diagnosis^SC^CV^AO^IR^EC^HNC^MST - ;^TMP("LRX",$J,69,i,63,ifn)= - ;Test subscript^Result^Flag^Units^Ref Range^Result status^Observation Sub ID^Value type^Natl Procedure code^Natl Procedure Name^Natl Coding System^Verified by^^Theraputic flag (T or "")^Print name^Accession^Order #^Link to 63 - ;^TMP("LRX",$J,69,i,63,"N",ifn)=Result Comments - ;^TMP("LRX",$J,69,i,68)=Lab Order #^LRDFN^Accession^Draw Time^Lab Arrival time^DT Results Available^Inverse Date - ;^TMP("LRX",$J,69,i,68,ifn)=Test^Urgency^Technologist^Complete Date - ;^TMP("LRX",$J,69,"N",i)= Ward comments on specimen - N X,X0,XP1,X1,X4,Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8,Y9,Y10,Y11,Y12,IFN,TSTY,NOTE,GOTCOM K ^TMP("LRX",$J,69) - Q:'$D(^LRO(69,+ODT,1,+SN,0)) S X0=^(0),XP1=$G(^(.1)),X1=$G(^(1)),X3=$G(^(3)),X4=$O(^(4,0)) - Q:'$D(^LR(+X0,0)) ;No matching entry in ^LR - S:'$D(DFN) DFN=$P(^LR(+X0,0),"^",3) S:'$D(LRDFN) LRDFN=+X0 S:'$D(LRDPF) LRDPF=$P(^LR(+X0,0),"^",2)_$G(^DIC(+$P(^LR(+X0,0),"^",2),0,"GL")) - S Y1=+XP1,Y2=$S($P(X1,"^"):$P(X1,"^"),1:$P(X0,"^",8)),Y3=$P(X0,"^",3),Y4=$P(X0,"^",4),Y5=$P(X0,"^",5),Y6=$P(X0,"^",6),Y7=$P(X0,"^",9),Y8=$P(X3,"^"),Y9=$P(X3,"^",2),Y11=$P(X0,"^",11),Y12=$P(X0,"^",2) - ;canceled entries are skipped, so calls to this routine from options - ;that are removing tests need to make the call before setting the pieces - ;that cancel the test: $P(^LRO(69,ODT,1,SN,2,IFN,0),"^",11) - ;See DOUT^LRTSTJAN - S IFN=0 F S IFN=$O(^LRO(69,ODT,1,SN,2,IFN)) Q:IFN<1 S X=$G(^(IFN,0)) I X,'$P(X,"^",11) D - . I $G(LRNIFN),$D(LRTMPO("LRIFN",LRNIFN)) Q:+X'=+LRTMPO("LRIFN",LRNIFN) - . S ^TMP("LRX",$J,69,IFN)=X,I=0 - . D GDG1^LRBEBA2(ODT,SN,IFN) - . F S I=$O(^LRO(69,ODT,1,SN,2,IFN,1,I)) Q:I<1 S X=^(I,0) D - .. S ^TMP("LRX",$J,69,IFN,"N",I)=X - . S I=0 F S I=$O(^LRO(69,ODT,1,SN,2,IFN,1.1,I)) Q:I<1 S X=^(I,0) D - .. S ^TMP("LRX",$J,69,IFN,"NC",I)=X - S IFN=0 F S IFN=$O(^LRO(69,ODT,1,SN,6,IFN)) Q:IFN<1 S X=^(IFN,0) D - . Q:X["removed ==>" Q:X["deleted by" - . S ^TMP("LRX",$J,69,"N",IFN)=X - S Y10=$O(^LRO(69,ODT,1,SN,4,0)),Y10=$S(Y10:$P(^(Y10,0),"^"),1:"") - S ^TMP("LRX",$J,69)=Y1_"^"_Y2_"^"_Y3_"^"_Y4_"^"_Y5_"^"_Y6_"^"_Y7_"^"_Y8_"^"_Y9_"^"_Y10_"^"_Y11_"^"_Y12 - S IFN=0 F S IFN=$O(^TMP("LRX",$J,69,IFN)) Q:IFN<1 S X=^TMP("LRX",$J,69,IFN) S X1=$P(X,"^",3),X2=$P(X,"^",4),X3=$P(X,"^",5) K TSTY D EN^LR7OU1(+X,$P(^LAB(60,+X,0),"^",5)) D 68^LR7OB68(IFN,X1,X2,X3,+X) - Q +LR7OB69 ;slc/dcm/JAH - Get Lab order data from 69 - 68 - 63 ;8/10/04 + ;;5.2;LAB SERVICE;**121,187,224,291**;Sep 27, 1994 + ; +69(ODT,SN) ;Get data from file 69 + ;ODT=Order Date subscript in file 69 + ;SN=Specimen number subscript in file 69 + ;Y1=Lab order number + ;Y2=Start date + ;Y3=Sample + ;Y4=Collection type/Specimen Action code + ;Y5=Order date + ;Y6=Provider + ;Y7=Routing Location + ;Y8=Lab arrival time + ;Y9=Date/Time Results Available + ;Y10=Specimen + ;Y11=OERR Order # + ;Y12=Entering person + ;^TMP("LRX",$J,69)=Y1^Y2^Y3^Y4^Y5^Y6^Y7^Y8^Y9^Y10^Y11^Y12 + ;^TMP("LRX",$J,69,i)=Test^Urgency^Accession Date^Accession area^Accession #^Combined on order^ORIFN^Panel exploded + ;^TMP("LRX",$J,69,"N",i)=Specimen level comments (6 node) + ;^TMP("LRX",$J,69,i,"N",ifn)=Comments by test + ;^TMP("LRX",$J,69,i,"NC",ifn)=Free text cancel reason + ;^TMP("LRX",$J,69,i,"DGX",ifn)=diagnosis^SC^CV^AO^IR^EC^HNC^MST + ;^TMP("LRX",$J,69,i,63,ifn)= + ;Test subscript^Result^Flag^Units^Ref Range^Result status^Observation Sub ID^Value type^Natl Procedure code^Natl Procedure Name^Natl Coding System^Verified by^^Theraputic flag (T or "")^Print name^Accession^Order #^Link to 63 + ;^TMP("LRX",$J,69,i,63,"N",ifn)=Result Comments + ;^TMP("LRX",$J,69,i,68)=Lab Order #^LRDFN^Accession^Draw Time^Lab Arrival time^DT Results Available^Inverse Date + ;^TMP("LRX",$J,69,i,68,ifn)=Test^Urgency^Technologist^Complete Date + ;^TMP("LRX",$J,69,"N",i)= Ward comments on specimen + N X,X0,XP1,X1,X4,Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8,Y9,Y10,Y11,Y12,IFN,TSTY,NOTE,GOTCOM K ^TMP("LRX",$J,69) + Q:'$D(^LRO(69,+ODT,1,+SN,0)) S X0=^(0),XP1=$G(^(.1)),X1=$G(^(1)),X3=$G(^(3)),X4=$O(^(4,0)) + Q:'$D(^LR(+X0,0)) ;No matching entry in ^LR + S:'$D(DFN) DFN=$P(^LR(+X0,0),"^",3) S:'$D(LRDFN) LRDFN=+X0 S:'$D(LRDPF) LRDPF=$P(^LR(+X0,0),"^",2)_$G(^DIC(+$P(^LR(+X0,0),"^",2),0,"GL")) + S Y1=+XP1,Y2=$S($P(X1,"^"):$P(X1,"^"),1:$P(X0,"^",8)),Y3=$P(X0,"^",3),Y4=$P(X0,"^",4),Y5=$P(X0,"^",5),Y6=$P(X0,"^",6),Y7=$P(X0,"^",7),Y8=$P(X3,"^"),Y9=$P(X3,"^",2),Y11=$P(X0,"^",11),Y12=$P(X0,"^",2) + S:$L(Y7) Y7=$O(^SC("C",Y7,0)) + ;canceled entries are skipped, so calls to this routine from options + ;that are removing tests need to make the call before setting the pieces + ;that cancel the test: $P(^LRO(69,ODT,1,SN,2,IFN,0),"^",11) + ;See DOUT^LRTSTJAN + S IFN=0 F S IFN=$O(^LRO(69,ODT,1,SN,2,IFN)) Q:IFN<1 S X=$G(^(IFN,0)) I X,'$P(X,"^",11) D + . I $G(LRNIFN),$D(LRTMPO("LRIFN",LRNIFN)) Q:+X'=+LRTMPO("LRIFN",LRNIFN) + . S ^TMP("LRX",$J,69,IFN)=X,I=0 + . D GDG1^LRBEBA2(ODT,SN,IFN) + . F S I=$O(^LRO(69,ODT,1,SN,2,IFN,1,I)) Q:I<1 S X=^(I,0) D + .. S ^TMP("LRX",$J,69,IFN,"N",I)=X + . S I=0 F S I=$O(^LRO(69,ODT,1,SN,2,IFN,1.1,I)) Q:I<1 S X=^(I,0) D + .. S ^TMP("LRX",$J,69,IFN,"NC",I)=X + S IFN=0 F S IFN=$O(^LRO(69,ODT,1,SN,6,IFN)) Q:IFN<1 S X=^(IFN,0) D + . Q:X["removed ==>" Q:X["deleted by" + . S ^TMP("LRX",$J,69,"N",IFN)=X + S Y10=$O(^LRO(69,ODT,1,SN,4,0)),Y10=$S(Y10:$P(^(Y10,0),"^"),1:"") + S ^TMP("LRX",$J,69)=Y1_"^"_Y2_"^"_Y3_"^"_Y4_"^"_Y5_"^"_Y6_"^"_Y7_"^"_Y8_"^"_Y9_"^"_Y10_"^"_Y11_"^"_Y12 + S IFN=0 F S IFN=$O(^TMP("LRX",$J,69,IFN)) Q:IFN<1 S X=^TMP("LRX",$J,69,IFN) S X1=$P(X,"^",3),X2=$P(X,"^",4),X3=$P(X,"^",5) K TSTY D EN^LR7OU1(+X,$P(^LAB(60,+X,0),"^",5)) D 68^LR7OB68(IFN,X1,X2,X3,+X) + Q diff --git a/r/LAB_SERVICE-LR-LS/LR7OGG.m b/r/LAB_SERVICE-LR-LS/LR7OGG.m index cfbd8881..874b7d86 100644 --- a/r/LAB_SERVICE-LR-LS/LR7OGG.m +++ b/r/LAB_SERVICE-LR-LS/LR7OGG.m @@ -1,147 +1,146 @@ -LR7OGG ;DALOI/STAFF- Interim report rpc grid ; Feb 9, 2005 - ;;5.2;LAB SERVICE;**187,290,364**;Sep 27, 1994;Build 3 - ; -TEST ; test use only - N CNT,I K ^TMP("LR7OGX",$J) - S ^TMP("LR7OGX",$J,"INPUT",1)="2^2970202^2920202" - S CNT=1 - ;F I=1:1:10 I $D(^LAB(60,I,0)) S CNT=CNT+1,^TMP("LR7OGX",$J,"INPUT",CNT)=I - F I=7,173,9,1 I $D(^LAB(60,I,0)) S CNT=CNT+1,^TMP("LR7OGX",$J,"INPUT",CNT)=I - D GRIDDATA - S I=0 F S I=$O(^TMP("LR7OGX",$J,"OUTPUT",I)) Q:I<1 W !,^(I) - K ^TMP("LR7OGX",$J) - Q - ; -GRID(ROOT,DFN,DATE1,DATE2,SPEC,TESTS) ; from ORWLRR - N CNT,NUM - K ^TMP("LR7OGX",$J,"INPUT"),^("OUTPUT") - S ROOT=$NA(^TMP("LR7OGX",$J,"OUTPUT")) - S ^TMP("LR7OGX",$J,"INPUT",1)=DFN_U_DATE1_U_DATE2_U_+SPEC - S CNT=1,NUM=0 F S NUM=$O(TESTS(NUM)) Q:NUM<1 D - .S CNT=CNT+1 - .S ^TMP("LR7OGX",$J,"INPUT",CNT)=+TESTS(NUM) - D GRIDDATA - Q - ; -GRIDDATA ; - ; input format - ; ^TMP("LR7OGX",$J,"INPUT",1)=dfn^start date^end date^spec^all tests - ; ^TMP("LR7OGX",$J,"INPUT",#)=test# (tests displayed in this order) - ; (these tests should, be atomic, subscript - ch, type - both or output) - ; - S ^TMP("LR7OGX",$J,"OUTPUT",1)="0^0^0^1" - N ABCNT,ABDCNT,ABLINE,ABTCNT,ABTLINE,ADCNT,ADSEQ,AGE,ATCNT,ATSEQ,CDT,CHSUB,COMCNT,COMMENT,DATACNT,DATESEQ,DFN,EDATE,EDT,FLAG,IDT - N LINE,LRCW,LRDFN,LRX,NUM,ONLYSPEC,OUTCNT,PNM,PRNTCODE,RESULT,SDATE,SEX,SPEC,SPECNAME,TESTNAME,TESTNUM,TESTSEQ,TESTZERO,X,ZERO,INEXACT,DISPDATE - K ^TMP("LR7OG",$J) - S DFN=+^TMP("LR7OGX",$J,"INPUT",1),SDATE=+$P(^(1),U,2),EDATE=+$P(^(1),U,3),ONLYSPEC=+$P(^(1),U,4) - D DEMO^LR7OGU(DFN,.LRDFN,.PNM,.AGE,.SEX) - Q:'DFN Q:'SDATE Q:'EDATE Q:'LRDFN - S OUTCNT=1,(ADCNT,ADSEQ,ATCNT,ATSEQ,COMCNT,DATACNT,DATESEQ,TESTSEQ,TCNT)=0 - S NUM=1 - F S NUM=$O(^TMP("LR7OGX",$J,"INPUT",NUM)) Q:NUM<1 S TESTNUM=+^(NUM) D - . S TESTZERO=$G(^LAB(60,TESTNUM,0)) - . S CHSUB=$P($P(TESTZERO,U,5),";",2) - . I 'CHSUB Q - . S TESTNAME=$P($G(^LAB(60,TESTNUM,.1)),U),PRNTCODE=$P($G(^(.1)),U,3) - . I TESTNAME="" S TESTNAME=$P(TESTZERO,U) - . S TESTSEQ=TESTSEQ+1 - . S LINE=TESTSEQ_U_TESTNUM_U_TESTNAME_U_PRNTCODE - . S ^TMP("LR7OG",$J,"TEST",CHSUB)=LINE - . S OUTCNT=OUTCNT+1 - . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=LINE - S ^TMP("LR7OGX",$J,"OUTPUT",1)=TESTSEQ - S EDATE=EDATE\1 - S IDT=9999999-SDATE,EDT=9999999-EDATE - F S IDT=$O(^LR(LRDFN,"CH",IDT)) Q:IDT<1 Q:IDT>EDT D - . S ZERO=^LR(LRDFN,"CH",IDT,0) - . I '$P(ZERO,U,3) Q - . S CDT=+ZERO,INEXACT=$P(ZERO,U,2),SPEC=+$P(ZERO,U,5),SPECNAME=$P($G(^LAB(61,SPEC,0)),U),COMMENT=$S($O(^LR(LRDFN,"CH",IDT,1,0)):"**",1:"") - . I ONLYSPEC,SPEC'=ONLYSPEC Q - . S CHSUB=1 - . F S CHSUB=$O(^LR(LRDFN,"CH",IDT,CHSUB)) Q:CHSUB="" D - . . I '$D(^TMP("LR7OG",$J,"TEST",CHSUB)) Q - . . I '$D(^TMP("LR7OG",$J,"DATE",IDT)) S ^(IDT)="" D - . . . S DATESEQ=DATESEQ+1 - . . . S OUTCNT=OUTCNT+1 - . . . S DISPDATE=$S(INEXACT:CDT\1,1:CDT) - . . . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=DATESEQ_U_CDT_U_SPEC_U_SPECNAME_U_COMMENT_U_DISPDATE - . . . I COMMENT'="" D - . . . . S COMCNT=COMCNT+1 - . . . . S ^TMP("LR7OG",$J,"COMMENT",COMCNT)=$P($$FMTE^XLFDT(CDT),":",1,2)_" ** Comments:" - . . . . S NUM=0 - . . . . F S NUM=$O(^LR(LRDFN,"CH",IDT,1,NUM)) Q:NUM<1 S LINE=$G(^(NUM,0)) D - . . . . . S COMCNT=COMCNT+1 - . . . . . S ^TMP("LR7OG",$J,"COMMENT",COMCNT)=LINE - . . . . S COMCNT=COMCNT+1 - . . . . S ^TMP("LR7OG",$J,"COMMENT",COMCNT)="" - . . S LRX=$$TSTRES^LRRPU(LRDFN,"CH",IDT,CHSUB,"") - . . S RESULT=$P(LRX,"^"),FLAG=$P(LRX,U,2) - . . S PRNTCODE=$P(^TMP("LR7OG",$J,"TEST",CHSUB),U,4) - . . I PRNTCODE'="" S X=RESULT,LRCW=8 S @("RESULT="_PRNTCODE) - . . E S RESULT=$J(RESULT,8) - . . S RESULT=$$STRIP^LR7OGU(RESULT) - . . I FLAG'="" D - . . . S ABTLINE=^TMP("LR7OG",$J,"TEST",CHSUB) - . . . I '$D(^TMP("LR7OG",$J,"ABTSEQ",+ABTLINE)) S ^(+ABTLINE)=U_$P(ABTLINE,U,2,3) - . . . I '$D(^TMP("LR7OG",$J,"ABDSEQ",IDT)) S ^(IDT)=U_CDT_U_SPEC_U_SPECNAME_U_COMMENT - . . . S ^TMP("LR7OG",$J,"ABDATA",IDT,+ABTLINE)=RESULT_U_FLAG - . . S TESTSEQ=+^TMP("LR7OG",$J,"TEST",CHSUB) - . . S DATACNT=DATACNT+1 - . . S ^TMP("LR7OG",$J,"DATA",DATACNT)=DATESEQ_U_TESTSEQ_U_RESULT_U_FLAG - . . D TESTSPEC(CHSUB,SPEC,SPECNAME,AGE,SEX) - S $P(^TMP("LR7OGX",$J,"OUTPUT",1),U,2,3)=DATESEQ_U_DATACNT - S DATACNT=0 - F S DATACNT=$O(^TMP("LR7OG",$J,"DATA",DATACNT)) Q:DATACNT<1 S LINE=^(DATACNT) D - . S OUTCNT=OUTCNT+1,^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=LINE - S OUTCNT=OUTCNT+1,ABLINE=OUTCNT - S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)="0^0^0" - ; - S (ABTCNT,ATSEQ)=0 - F S ATSEQ=$O(^TMP("LR7OG",$J,"ABTSEQ",ATSEQ)) Q:ATSEQ<1 D - . S ABTCNT=ABTCNT+1 - . S $P(^TMP("LR7OG",$J,"ABTSEQ",ATSEQ),U)=ABTCNT - . S OUTCNT=OUTCNT+1 - . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=^TMP("LR7OG",$J,"ABTSEQ",ATSEQ) - ; - S (ABDCNT,ADSEQ)=0 - F S ADSEQ=$O(^TMP("LR7OG",$J,"ABDSEQ",ADSEQ)) Q:ADSEQ<1 D - . S ABDCNT=ABDCNT+1 - . S $P(^TMP("LR7OG",$J,"ABDSEQ",ADSEQ),U)=ABDCNT - . S OUTCNT=OUTCNT+1 - . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=^TMP("LR7OG",$J,"ABDSEQ",ADSEQ) - ; - S (ABCNT,ADSEQ)=0 - F S ADSEQ=$O(^TMP("LR7OG",$J,"ABDATA",ADSEQ)) Q:ADSEQ<1 D - . S ADCNT=+^TMP("LR7OG",$J,"ABDSEQ",ADSEQ) - . S ATSEQ=0 - . F S ATSEQ=$O(^TMP("LR7OG",$J,"ABDATA",ADSEQ,ATSEQ)) Q:ATSEQ<1 D - . . S ATCNT=+^TMP("LR7OG",$J,"ABTSEQ",ATSEQ) - . . S ABCNT=ABCNT+1 - . . S OUTCNT=OUTCNT+1 - . . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=ADCNT_U_ATCNT_U_^TMP("LR7OG",$J,"ABDATA",ADSEQ,ATSEQ) - ; - S ^TMP("LR7OGX",$J,"OUTPUT",ABLINE)=ABTCNT_U_ABDCNT_U_ABCNT - S $P(^TMP("LR7OGX",$J,"OUTPUT",1),U,4)=OUTCNT - S TESTSEQ=0 - F S TESTSEQ=$O(^TMP("LR7OG",$J,"TESTSPEC",TESTSEQ)) Q:TESTSEQ<1 D - . S SPEC=0 - . F S SPEC=$O(^TMP("LR7OG",$J,"TESTSPEC",TESTSEQ,SPEC)) Q:SPEC<1 S LINE=^(SPEC) D - . . S OUTCNT=OUTCNT+1 - . . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=LINE - S $P(^TMP("LR7OGX",$J,"OUTPUT",1),U,5)=OUTCNT - ; - S NUM=0 - F S NUM=$O(^TMP("LR7OG",$J,"COMMENT",NUM)) Q:NUM<1 S LINE=^(NUM) D - . S OUTCNT=OUTCNT+1 - . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=LINE - K ^TMP("LR7OG",$J) - Q - ; - ; -TESTSPEC(CHSUB,SPEC,SPECNAME,AGE,SEX) ; - N RANGE,TESTNAME,TESTNUM,TESTSEQ,UNITS - S TESTSEQ=+$P(^TMP("LR7OG",$J,"TEST",CHSUB),U),TESTNUM=+$P(^(CHSUB),U,2),TESTNAME=$P(^(CHSUB),U,3) - I $D(^TMP("LR7OG",$J,"TESTSPEC",TESTSEQ,SPEC)) Q - D URANGE^LR7OGU(TESTNUM,SPEC,AGE,SEX,.UNITS,.RANGE) - S ^TMP("LR7OG",$J,"TESTSPEC",TESTSEQ,SPEC)=TESTNUM_U_SPECNAME_U_SPEC_U_UNITS_U_$P(RANGE," - ")_U_$P($P(RANGE," - ",2)," (") - Q +LR7OGG ;DALOI/STAFF- Interim report rpc grid ; Feb 9, 2005 + ;;5.2;LAB SERVICE;**187,290**;Sep 27, 1994 + ; +TEST ; test use only + N CNT,I K ^TMP("LR7OGX",$J) + S ^TMP("LR7OGX",$J,"INPUT",1)="2^2970202^2920202" + S CNT=1 + ;F I=1:1:10 I $D(^LAB(60,I,0)) S CNT=CNT+1,^TMP("LR7OGX",$J,"INPUT",CNT)=I + F I=7,173,9,1 I $D(^LAB(60,I,0)) S CNT=CNT+1,^TMP("LR7OGX",$J,"INPUT",CNT)=I + D GRIDDATA + S I=0 F S I=$O(^TMP("LR7OGX",$J,"OUTPUT",I)) Q:I<1 W !,^(I) + K ^TMP("LR7OGX",$J) + Q + ; +GRID(ROOT,DFN,DATE1,DATE2,SPEC,TESTS) ; from ORWLRR + N CNT,NUM + K ^TMP("LR7OGX",$J,"INPUT"),^("OUTPUT") + S ROOT=$NA(^TMP("LR7OGX",$J,"OUTPUT")) + S ^TMP("LR7OGX",$J,"INPUT",1)=DFN_U_DATE1_U_DATE2_U_+SPEC + S CNT=1,NUM=0 F S NUM=$O(TESTS(NUM)) Q:NUM<1 D + .S CNT=CNT+1 + .S ^TMP("LR7OGX",$J,"INPUT",CNT)=+TESTS(NUM) + D GRIDDATA + Q + ; +GRIDDATA ; + ; input format + ; ^TMP("LR7OGX",$J,"INPUT",1)=dfn^start date^end date^spec^all tests + ; ^TMP("LR7OGX",$J,"INPUT",#)=test# (tests displayed in this order) + ; (these tests should, be atomic, subscript - ch, type - both or output) + ; + S ^TMP("LR7OGX",$J,"OUTPUT",1)="0^0^0^1" + N ABCNT,ABDCNT,ABLINE,ABTCNT,ABTLINE,ADCNT,ADSEQ,AGE,ATCNT,ATSEQ,CDT,CHSUB,COMCNT,COMMENT,DATACNT,DATESEQ,DFN,EDATE,EDT,FLAG,IDT + N LINE,LRCW,LRDFN,LRX,NUM,ONLYSPEC,OUTCNT,PNM,PRNTCODE,RESULT,SDATE,SEX,SPEC,SPECNAME,TESTNAME,TESTNUM,TESTSEQ,TESTZERO,X,ZERO + K ^TMP("LR7OG",$J) + S DFN=+^TMP("LR7OGX",$J,"INPUT",1),SDATE=+$P(^(1),U,2),EDATE=+$P(^(1),U,3),ONLYSPEC=+$P(^(1),U,4) + D DEMO^LR7OGU(DFN,.LRDFN,.PNM,.AGE,.SEX) + Q:'DFN Q:'SDATE Q:'EDATE Q:'LRDFN + S OUTCNT=1,(ADCNT,ADSEQ,ATCNT,ATSEQ,COMCNT,DATACNT,DATESEQ,TESTSEQ,TCNT)=0 + S NUM=1 + F S NUM=$O(^TMP("LR7OGX",$J,"INPUT",NUM)) Q:NUM<1 S TESTNUM=+^(NUM) D + . S TESTZERO=$G(^LAB(60,TESTNUM,0)) + . S CHSUB=$P($P(TESTZERO,U,5),";",2) + . I 'CHSUB Q + . S TESTNAME=$P($G(^LAB(60,TESTNUM,.1)),U),PRNTCODE=$P($G(^(.1)),U,3) + . I TESTNAME="" S TESTNAME=$P(TESTZERO,U) + . S TESTSEQ=TESTSEQ+1 + . S LINE=TESTSEQ_U_TESTNUM_U_TESTNAME_U_PRNTCODE + . S ^TMP("LR7OG",$J,"TEST",CHSUB)=LINE + . S OUTCNT=OUTCNT+1 + . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=LINE + S ^TMP("LR7OGX",$J,"OUTPUT",1)=TESTSEQ + S EDATE=EDATE\1 + S IDT=9999999-SDATE,EDT=9999999-EDATE + F S IDT=$O(^LR(LRDFN,"CH",IDT)) Q:IDT<1 Q:IDT>EDT D + . S ZERO=^LR(LRDFN,"CH",IDT,0) + . I '$P(ZERO,U,3) Q + . S CDT=+ZERO,SPEC=+$P(ZERO,U,5),SPECNAME=$P($G(^LAB(61,SPEC,0)),U),COMMENT=$S($O(^LR(LRDFN,"CH",IDT,1,0)):"**",1:"") + . I ONLYSPEC,SPEC'=ONLYSPEC Q + . S CHSUB=1 + . F S CHSUB=$O(^LR(LRDFN,"CH",IDT,CHSUB)) Q:CHSUB="" D + . . I '$D(^TMP("LR7OG",$J,"TEST",CHSUB)) Q + . . I '$D(^TMP("LR7OG",$J,"DATE",IDT)) S ^(IDT)="" D + . . . S DATESEQ=DATESEQ+1 + . . . S OUTCNT=OUTCNT+1 + . . . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=DATESEQ_U_CDT_U_SPEC_U_SPECNAME_U_COMMENT + . . . I COMMENT'="" D + . . . . S COMCNT=COMCNT+1 + . . . . S ^TMP("LR7OG",$J,"COMMENT",COMCNT)=$P($$FMTE^XLFDT(CDT),":",1,2)_" ** Comments:" + . . . . S NUM=0 + . . . . F S NUM=$O(^LR(LRDFN,"CH",IDT,1,NUM)) Q:NUM<1 S LINE=$G(^(NUM,0)) D + . . . . . S COMCNT=COMCNT+1 + . . . . . S ^TMP("LR7OG",$J,"COMMENT",COMCNT)=LINE + . . . . S COMCNT=COMCNT+1 + . . . . S ^TMP("LR7OG",$J,"COMMENT",COMCNT)="" + . . S LRX=$$TSTRES^LRRPU(LRDFN,"CH",IDT,CHSUB,"") + . . S RESULT=$P(LRX,"^"),FLAG=$P(LRX,U,2) + . . S PRNTCODE=$P(^TMP("LR7OG",$J,"TEST",CHSUB),U,4) + . . I PRNTCODE'="" S X=RESULT,LRCW=8 S @("RESULT="_PRNTCODE) + . . E S RESULT=$J(RESULT,8) + . . S RESULT=$$STRIP^LR7OGU(RESULT) + . . I FLAG'="" D + . . . S ABTLINE=^TMP("LR7OG",$J,"TEST",CHSUB) + . . . I '$D(^TMP("LR7OG",$J,"ABTSEQ",+ABTLINE)) S ^(+ABTLINE)=U_$P(ABTLINE,U,2,3) + . . . I '$D(^TMP("LR7OG",$J,"ABDSEQ",IDT)) S ^(IDT)=U_CDT_U_SPEC_U_SPECNAME_U_COMMENT + . . . S ^TMP("LR7OG",$J,"ABDATA",IDT,+ABTLINE)=RESULT_U_FLAG + . . S TESTSEQ=+^TMP("LR7OG",$J,"TEST",CHSUB) + . . S DATACNT=DATACNT+1 + . . S ^TMP("LR7OG",$J,"DATA",DATACNT)=DATESEQ_U_TESTSEQ_U_RESULT_U_FLAG + . . D TESTSPEC(CHSUB,SPEC,SPECNAME,AGE,SEX) + S $P(^TMP("LR7OGX",$J,"OUTPUT",1),U,2,3)=DATESEQ_U_DATACNT + S DATACNT=0 + F S DATACNT=$O(^TMP("LR7OG",$J,"DATA",DATACNT)) Q:DATACNT<1 S LINE=^(DATACNT) D + . S OUTCNT=OUTCNT+1,^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=LINE + S OUTCNT=OUTCNT+1,ABLINE=OUTCNT + S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)="0^0^0" + ; + S (ABTCNT,ATSEQ)=0 + F S ATSEQ=$O(^TMP("LR7OG",$J,"ABTSEQ",ATSEQ)) Q:ATSEQ<1 D + . S ABTCNT=ABTCNT+1 + . S $P(^TMP("LR7OG",$J,"ABTSEQ",ATSEQ),U)=ABTCNT + . S OUTCNT=OUTCNT+1 + . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=^TMP("LR7OG",$J,"ABTSEQ",ATSEQ) + ; + S (ABDCNT,ADSEQ)=0 + F S ADSEQ=$O(^TMP("LR7OG",$J,"ABDSEQ",ADSEQ)) Q:ADSEQ<1 D + . S ABDCNT=ABDCNT+1 + . S $P(^TMP("LR7OG",$J,"ABDSEQ",ADSEQ),U)=ABDCNT + . S OUTCNT=OUTCNT+1 + . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=^TMP("LR7OG",$J,"ABDSEQ",ADSEQ) + ; + S (ABCNT,ADSEQ)=0 + F S ADSEQ=$O(^TMP("LR7OG",$J,"ABDATA",ADSEQ)) Q:ADSEQ<1 D + . S ADCNT=+^TMP("LR7OG",$J,"ABDSEQ",ADSEQ) + . S ATSEQ=0 + . F S ATSEQ=$O(^TMP("LR7OG",$J,"ABDATA",ADSEQ,ATSEQ)) Q:ATSEQ<1 D + . . S ATCNT=+^TMP("LR7OG",$J,"ABTSEQ",ATSEQ) + . . S ABCNT=ABCNT+1 + . . S OUTCNT=OUTCNT+1 + . . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=ADCNT_U_ATCNT_U_^TMP("LR7OG",$J,"ABDATA",ADSEQ,ATSEQ) + ; + S ^TMP("LR7OGX",$J,"OUTPUT",ABLINE)=ABTCNT_U_ABDCNT_U_ABCNT + S $P(^TMP("LR7OGX",$J,"OUTPUT",1),U,4)=OUTCNT + S TESTSEQ=0 + F S TESTSEQ=$O(^TMP("LR7OG",$J,"TESTSPEC",TESTSEQ)) Q:TESTSEQ<1 D + . S SPEC=0 + . F S SPEC=$O(^TMP("LR7OG",$J,"TESTSPEC",TESTSEQ,SPEC)) Q:SPEC<1 S LINE=^(SPEC) D + . . S OUTCNT=OUTCNT+1 + . . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=LINE + S $P(^TMP("LR7OGX",$J,"OUTPUT",1),U,5)=OUTCNT + ; + S NUM=0 + F S NUM=$O(^TMP("LR7OG",$J,"COMMENT",NUM)) Q:NUM<1 S LINE=^(NUM) D + . S OUTCNT=OUTCNT+1 + . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=LINE + K ^TMP("LR7OG",$J) + Q + ; + ; +TESTSPEC(CHSUB,SPEC,SPECNAME,AGE,SEX) ; + N RANGE,TESTNAME,TESTNUM,TESTSEQ,UNITS + S TESTSEQ=+$P(^TMP("LR7OG",$J,"TEST",CHSUB),U),TESTNUM=+$P(^(CHSUB),U,2),TESTNAME=$P(^(CHSUB),U,3) + I $D(^TMP("LR7OG",$J,"TESTSPEC",TESTSEQ,SPEC)) Q + D URANGE^LR7OGU(TESTNUM,SPEC,AGE,SEX,.UNITS,.RANGE) + S ^TMP("LR7OG",$J,"TESTSPEC",TESTSEQ,SPEC)=TESTNUM_U_SPECNAME_U_SPEC_U_UNITS_U_$P(RANGE," - ")_U_$P($P(RANGE," - ",2)," (") + Q diff --git a/r/LAB_SERVICE-LR-LS/LR7OGMG.m b/r/LAB_SERVICE-LR-LS/LR7OGMG.m index d7788593..e12e0ff1 100644 --- a/r/LAB_SERVICE-LR-LS/LR7OGMG.m +++ b/r/LAB_SERVICE-LR-LS/LR7OGMG.m @@ -1,77 +1,75 @@ -LR7OGMG ;DALOI/STAFF- Interim report rpc memo grid ;July 19, 2006 - ;;5.2;LAB SERVICE;**187,230,286,290,331,364**;Sep 27, 1994;Build 3 - ; -GRID(OUTCNT) ; from LR7OGMC - N ACC,AGE,CDT,CMNT,DATA,DOC,FLAG,IDT,INTP,LINE,LRCW,LRX,MPLS,PLS,PORDER,PRNTCODE,RANGE,SEX,SPEC,SUB,TCNT,TESTNAME,TESTNUM - N UNITS,VALUE,X,ZERO,INEXACT,DISPDATE - ; the variables AGE, SEX, LRCW, and X are used withing the lab's print codes and ref ranges - K ^TMP("LRMPLS",$J) - S AGE=$P(^TMP("LR7OG",$J,"G"),U,4),SEX=$P(^("G"),U,5),LRCW=$P(^("G"),U,6) - S CDT=+$O(^TMP("LR7OG",$J,"TP",0)) Q:'CDT - S IDT=9999999-CDT - S ZERO=$S($D(^TMP("LR7OG",$J,"TP",CDT))#2:^(CDT),1:"") - I '$P(ZERO,U,3) Q - S SPEC=+$P(ZERO,U,5) - S INEXACT=$P(ZERO,U,2),DISPDATE=$S(INEXACT:CDT\1,1:CDT) - S DOC=$$NAME^LR7OGMP(+$P(ZERO,U,10)) - S ACC=$P(ZERO,U,6) - S $P(^TMP("LR7OGX",$J,"OUTPUT",1),U,4,6)=SPEC_U_$P($G(^LAB(61,SPEC,0)),U)_U_ACC_U_DOC - S $P(^TMP("LR7OGX",$J,"OUTPUT",1),U,10)=DISPDATE - S (TCNT,MPLS,PORDER,PLS)=0 - S PLS=$O(^TMP("LRPLS",$J,0)) - I $O(^TMP("LRPLS",$J,PLS)) S MPLS=1 ; multiple performing labs - F S PORDER=$O(^TMP("LR7OG",$J,"TP",CDT,PORDER)) Q:PORDER'>0 S DATA=^(PORDER) D - . I $P(DATA,U,7)="" Q - . S TCNT=TCNT+1 - . S TESTNUM=+DATA,TESTNAME=$P(DATA,U,2),PRNTCODE=$P(DATA,U,5),SUB=$P(DATA,U,6),FLAG=$P(DATA,U,8),X=$P(DATA,U,7),UNITS=$P(DATA,U,9),RANGE=$P(DATA,U,10),PLS=$P(DATA,U,11) - . I MPLS,PLS S ^TMP("LRMPLS",$J,PLS,TESTNAME)="" - . I PRNTCODE="" S VALUE=$J(X,8) - . E S @("VALUE="_PRNTCODE) - . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=TESTNUM_U_TESTNAME_U_VALUE_U_FLAG_U_UNITS_U_RANGE - . S OUTCNT=OUTCNT+1 - S $P(^TMP("LR7OGX",$J,"OUTPUT",1),U)=TCNT - ; - S PORDER=0 - F S PORDER=$O(^TMP("LR7OG",$J,"TP",CDT,PORDER)) Q:PORDER'>0 S DATA=^(PORDER) D - . I $O(^TMP("LR7OG",$J,"TP",CDT,PORDER,0))>0 D - . . S TESTNAME=$P(DATA,U,3) - . . S INTP=0 - . . F S INTP=+$O(^TMP("LR7OG",$J,"TP",CDT,PORDER,INTP)) Q:INTP<1 D - . . . S LINE=TESTNAME_" Eval: "_^TMP("LR7OG",$J,"TP",CDT,PORDER,INTP) - . . . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=LINE - . . . S OUTCNT=OUTCNT+1 - ; - I $D(^TMP("LR7OG",$J,"TP",CDT,"C")) D - . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)="Comment: " - . S OUTCNT=OUTCNT+1,CMNT=0 - . F S CMNT=+$O(^TMP("LR7OG",$J,"TP",CDT,"C",CMNT)) Q:CMNT<1 S LINE=^(CMNT) D - . . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=" "_LINE - . . S OUTCNT=OUTCNT+1 - ; - D PLS - Q - ; - ; -PLS ; List performing laboratories - ; If multiple performing labs then list tests associated with each lab. - ; - N CNT,LINE,LRPLS,X - S (CNT,LRPLS)=0 - F S LRPLS=$O(^TMP("LRPLS",$J,LRPLS)) Q:LRPLS<1 D - . I CNT S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=" ",OUTCNT=OUTCNT+1 - . I $D(^TMP("LRMPLS",$J,LRPLS)) D - . . S TESTNAME="",LINE="For test(s): " - . . F S TESTNAME=$O(^TMP("LRMPLS",$J,LRPLS,TESTNAME)) Q:TESTNAME="" D - . . . I ($L(LINE)+$L(TESTNAME))>240 D - . . . . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=LINE - . . . . S OUTCNT=OUTCNT+1,LINE="" - . . . S LINE=LINE_TESTNAME_", " - . . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=LINE,OUTCNT=OUTCNT+1 - . S LINE=$$NAME^XUAF4(LRPLS) - . S X=$$PADD^XUAF4(LRPLS) - . S LINE=LINE_" "_$P(X,U)_" "_$P(X,U,2)_", "_$P(X,U,3)_" "_$P(X,U,4) - . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)="Performing Lab: "_LINE - . S OUTCNT=OUTCNT+1,CNT=CNT+1 - ; - K ^TMP("LRPLS",$J),^TMP("LRMPLS",$J) - Q +LR7OGMG ;DALOI/STAFF- Interim report rpc memo grid ;July 19, 2006 + ;;5.2;LAB SERVICE;**187,230,286,290,331**;Sep 27, 1994;Build 7 + ; +GRID(OUTCNT) ; from LR7OGMC + N ACC,AGE,CDT,CMNT,DATA,DOC,FLAG,IDT,INTP,LINE,LRCW,LRX,MPLS,PLS,PORDER,PRNTCODE,RANGE,SEX,SPEC,SUB,TCNT,TESTNAME,TESTNUM + N UNITS,VALUE,X,ZERO + ; the variables AGE, SEX, LRCW, and X are used withing the lab's print codes and ref ranges + K ^TMP("LRMPLS",$J) + S AGE=$P(^TMP("LR7OG",$J,"G"),U,4),SEX=$P(^("G"),U,5),LRCW=$P(^("G"),U,6) + S CDT=+$O(^TMP("LR7OG",$J,"TP",0)) Q:'CDT + S IDT=9999999-CDT + S ZERO=$S($D(^TMP("LR7OG",$J,"TP",CDT))#2:^(CDT),1:"") + I '$P(ZERO,U,3) Q + S SPEC=+$P(ZERO,U,5) + S DOC=$$NAME^LR7OGMP(+$P(ZERO,U,10)) + S ACC=$P(ZERO,U,6) + S $P(^TMP("LR7OGX",$J,"OUTPUT",1),U,4,6)=SPEC_U_$P($G(^LAB(61,SPEC,0)),U)_U_ACC_U_DOC + S (TCNT,MPLS,PORDER,PLS)=0 + S PLS=$O(^TMP("LRPLS",$J,0)) + I $O(^TMP("LRPLS",$J,PLS)) S MPLS=1 ; multiple performing labs + F S PORDER=$O(^TMP("LR7OG",$J,"TP",CDT,PORDER)) Q:PORDER'>0 S DATA=^(PORDER) D + . I $P(DATA,U,7)="" Q + . S TCNT=TCNT+1 + . S TESTNUM=+DATA,TESTNAME=$P(DATA,U,2),PRNTCODE=$P(DATA,U,5),SUB=$P(DATA,U,6),FLAG=$P(DATA,U,8),X=$P(DATA,U,7),UNITS=$P(DATA,U,9),RANGE=$P(DATA,U,10),PLS=$P(DATA,U,11) + . I MPLS,PLS S ^TMP("LRMPLS",$J,PLS,TESTNAME)="" + . I PRNTCODE="" S VALUE=$J(X,8) + . E S @("VALUE="_PRNTCODE) + . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=TESTNUM_U_TESTNAME_U_VALUE_U_FLAG_U_UNITS_U_RANGE + . S OUTCNT=OUTCNT+1 + S $P(^TMP("LR7OGX",$J,"OUTPUT",1),U)=TCNT + ; + S PORDER=0 + F S PORDER=$O(^TMP("LR7OG",$J,"TP",CDT,PORDER)) Q:PORDER'>0 S DATA=^(PORDER) D + . I $O(^TMP("LR7OG",$J,"TP",CDT,PORDER,0))>0 D + . . S TESTNAME=$P(DATA,U,3) + . . S INTP=0 + . . F S INTP=+$O(^TMP("LR7OG",$J,"TP",CDT,PORDER,INTP)) Q:INTP<1 D + . . . S LINE=TESTNAME_" Eval: "_^TMP("LR7OG",$J,"TP",CDT,PORDER,INTP) + . . . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=LINE + . . . S OUTCNT=OUTCNT+1 + ; + I $D(^TMP("LR7OG",$J,"TP",CDT,"C")) D + . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)="Comment: " + . S OUTCNT=OUTCNT+1,CMNT=0 + . F S CMNT=+$O(^TMP("LR7OG",$J,"TP",CDT,"C",CMNT)) Q:CMNT<1 S LINE=^(CMNT) D + . . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=" "_LINE + . . S OUTCNT=OUTCNT+1 + ; + D PLS + Q + ; + ; +PLS ; List performing laboratories + ; If multiple performing labs then list tests associated with each lab. + ; + N CNT,LINE,LRPLS,X + S (CNT,LRPLS)=0 + F S LRPLS=$O(^TMP("LRPLS",$J,LRPLS)) Q:LRPLS<1 D + . I CNT S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=" ",OUTCNT=OUTCNT+1 + . I $D(^TMP("LRMPLS",$J,LRPLS)) D + . . S TESTNAME="",LINE="For test(s): " + . . F S TESTNAME=$O(^TMP("LRMPLS",$J,LRPLS,TESTNAME)) Q:TESTNAME="" D + . . . I ($L(LINE)+$L(TESTNAME))>240 D + . . . . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=LINE + . . . . S OUTCNT=OUTCNT+1,LINE="" + . . . S LINE=LINE_TESTNAME_", " + . . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=LINE,OUTCNT=OUTCNT+1 + . S LINE=$$NAME^XUAF4(LRPLS) + . S X=$$PADD^XUAF4(LRPLS) + . S LINE=LINE_" "_$P(X,U)_" "_$P(X,U,2)_", "_$P(X,U,3)_" "_$P(X,U,4) + . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)="Performing Lab: "_LINE + . S OUTCNT=OUTCNT+1,CNT=CNT+1 + ; + K ^TMP("LRPLS",$J),^TMP("LRMPLS",$J) + Q diff --git a/r/LAB_SERVICE-LR-LS/LR7OGMM.m b/r/LAB_SERVICE-LR-LS/LR7OGMM.m index e9be220a..e556bab7 100644 --- a/r/LAB_SERVICE-LR-LS/LR7OGMM.m +++ b/r/LAB_SERVICE-LR-LS/LR7OGMM.m @@ -1,40 +1,33 @@ -LR7OGMM ;SLC/STAFF- Interim report rpc memo micro ;5/20/97 18:52 - ;;5.2;LAB SERVICE;**187,312,364**;Sep 27, 1994;Build 3 - ; -MI(LRDFN,IDT,MICROSUB,ALL,OUTCNT,FORMAT,DONE) ; from LR7OGM - N MISUB,OK,ZERO,INEXACT,DISPDATE,XDT - I '$D(^LR(LRDFN,"MI",IDT)) Q - S OK=ALL - I 'OK S MISUB=0 F S MISUB=+$O(MICROSUB(MISUB)) Q:MISUB<1 I $D(^LR(LRDFN,"MI",IDT,MISUB)) S OK=1 Q - I 'OK Q - I $G(FORMAT) D - .S XDT=9999999-IDT - .S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)="^MI^"_XDT D - ..; determine if collection time is "inexact" and put the - ..; collection day/time that is to be displayed in piece 10 - ..S ZERO=$G(^LR(LRDFN,"MI",IDT,0)) Q:ZERO="" - ..S INEXACT=$P(ZERO,U,2) - ..S DISPDATE=$S(INEXACT:XDT\1,1:XDT) - ..S $P(^TMP("LR7OGX",$J,"OUTPUT",OUTCNT),U,10)=DISPDATE - .S OUTCNT=OUTCNT+1 - .S DONE=1 - D MIC(LRDFN,IDT,.OUTCNT) - Q - ; -MIC(LRDFN,LRIDT,OUTCNT) ; - N AGE,GCNT,GIOM,LINE,LREND,LRONESPC,LRONETST,NUM,SEX - S GCNT=0,GIOM=80,LREND=0,LRONESPC="",LRONETST=0 - S AGE=$P(^TMP("LR7OG",$J,"G"),U,5),SEX=$P(^("G"),U,6) - ; new variables used by LR7OSMZ0 - N %,A,A8,AB,B,B1,B2,B3,C,CCNT,DIC,DZ,I,IA,II,INC,J,K,LR1PASS,LR2ORMOR,LRAA,LRABCNT,LRACC,LRACNT,LRAD,LRADM,LRADX,LRAFS,LRAMT,LRAN,LRAO,LRAX - N LRBN,LRBRR,LRBUG,LRCMNT,LRCOMTAB,LRCS,LRDCOM,LRDOC,LRDRTM1,LRDRTM2,LREF,LRFLAG,LRFMT,LRGRM,LRIFN,LRINT,LRJ02,LRLABKY,LRLLT,LRMYC,LRNS,LRNUM - N LRORG,LRPAR,LRPATLOC,LRPC,LRPG,LRPRE,LRPRINT,LRQU,LRRC,LRRES,LRSB,LRSBC1,LRSBC2,LRSET,LRSIC1,LRSIC2,LRSET,LRSIC1,LRSIC2,LRSPEC,LRSSD,LRST - N LRTA,LRTB,LRTBA,LRTBC,LRTBS,LRTK,LRTS,LRTSTS,LRTUS,LRUS,LRWRD,LRWRDVEW,N,S1,SP,X,X1,Y,Y1 - K DIC,LR1PASS,LRBUG,LRDCOM,LRINT,LRRES,LRTS K ^TMP("LR",$J),^TMP("LRC",$J),^TMP("LRT",$J) - D EN1^LR7OSMZ0 - I '$O(^TMP("LRC",$J,0)) Q - S NUM=0 F S NUM=$O(^TMP("LRC",$J,NUM)) Q:NUM<1 S LINE=^(NUM,0) D - .S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=LINE,OUTCNT=OUTCNT+1 - S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)="===============================================================================",OUTCNT=OUTCNT+1 - K ^TMP("LR",$J),^TMP("LRC",$J),^TMP("LRT",$J) - Q +LR7OGMM ;SLC/STAFF- Interim report rpc memo micro ;5/20/97 18:52 + ;;5.2;LAB SERVICE;**187,312**;Sep 27, 1994 + ; +MI(LRDFN,IDT,MICROSUB,ALL,OUTCNT,FORMAT,DONE) ; from LR7OGM + N MISUB,OK + I '$D(^LR(LRDFN,"MI",IDT)) Q + S OK=ALL + I 'OK S MISUB=0 F S MISUB=+$O(MICROSUB(MISUB)) Q:MISUB<1 I $D(^LR(LRDFN,"MI",IDT,MISUB)) S OK=1 Q + I 'OK Q + I $G(FORMAT) D + .S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)="^MI^"_(9999999-IDT) + .S OUTCNT=OUTCNT+1 + .S DONE=1 + D MIC(LRDFN,IDT,.OUTCNT) + Q + ; +MIC(LRDFN,LRIDT,OUTCNT) ; + N AGE,GCNT,GIOM,LINE,LREND,LRONESPC,LRONETST,NUM,SEX + S GCNT=0,GIOM=80,LREND=0,LRONESPC="",LRONETST=0 + S AGE=$P(^TMP("LR7OG",$J,"G"),U,5),SEX=$P(^("G"),U,6) + ; new variables used by LR7OSMZ0 + N %,A,A8,AB,B,B1,B2,B3,C,CCNT,DIC,DZ,I,IA,II,INC,J,K,LR1PASS,LR2ORMOR,LRAA,LRABCNT,LRACC,LRACNT,LRAD,LRADM,LRADX,LRAFS,LRAMT,LRAN,LRAO,LRAX + N LRBN,LRBRR,LRBUG,LRCMNT,LRCOMTAB,LRCS,LRDCOM,LRDOC,LRDRTM1,LRDRTM2,LREF,LRFLAG,LRFMT,LRGRM,LRIFN,LRINT,LRJ02,LRLABKY,LRLLT,LRMYC,LRNS,LRNUM + N LRORG,LRPAR,LRPATLOC,LRPC,LRPG,LRPRE,LRPRINT,LRQU,LRRC,LRRES,LRSB,LRSBC1,LRSBC2,LRSET,LRSIC1,LRSIC2,LRSET,LRSIC1,LRSIC2,LRSPEC,LRSSD,LRST + N LRTA,LRTB,LRTBA,LRTBC,LRTBS,LRTK,LRTS,LRTSTS,LRTUS,LRUS,LRWRD,LRWRDVEW,N,S1,SP,X,X1,Y,Y1 + K DIC,LR1PASS,LRBUG,LRDCOM,LRINT,LRRES,LRTS K ^TMP("LR",$J),^TMP("LRC",$J),^TMP("LRT",$J) + D EN1^LR7OSMZ0 + I '$O(^TMP("LRC",$J,0)) Q + S NUM=0 F S NUM=$O(^TMP("LRC",$J,NUM)) Q:NUM<1 S LINE=^(NUM,0) D + .S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=LINE,OUTCNT=OUTCNT+1 + S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)="===============================================================================",OUTCNT=OUTCNT+1 + K ^TMP("LR",$J),^TMP("LRC",$J),^TMP("LRT",$J) + Q diff --git a/r/LAB_SERVICE-LR-LS/LR7OSAP2.m b/r/LAB_SERVICE-LR-LS/LR7OSAP2.m index 64f5bccb..5f6042de 100644 --- a/r/LAB_SERVICE-LR-LS/LR7OSAP2.m +++ b/r/LAB_SERVICE-LR-LS/LR7OSAP2.m @@ -1,191 +1,190 @@ -LR7OSAP2 ;ISL/RAB/WTY/KLL - Silent Routine for autopsy report;3/28/2002 - ;;5.2;LAB SERVICE;**230,256,259,317,365**;Sep 27, 1994;Build 9 - ; - ;Reference to ^DD(63 supported by IA #999 - ; -EN(LRDFN) ; - N CCNT,GIOM,XPOS,LR,LRSS,X,I,LRAU,LRS,VERIFIED,LRTEXT,LRPTR,X2 - S XPOS=0,(LRS(5),LR("M"),CCNT)=1,LRSS="AU",GIOM=80 - D EN^LRUA,^LRAPU - S X=$S($D(^LRO(69.2,+Y,0)):^(0),1:""),LRAU(3)=$P(X,"^",3),LRAU(4)=$P(X,"^",4) - D LINE,LN - S ^TMP("LRH",$J,"AUTOPSY")=GCNT,^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(28,CCNT,"---- AUTOPSY ----") - S VERIFIED=$P($G(^LR(LRDFN,"AU")),U,15) - I 'VERIFIED D Q - . D LN - . S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,"Report not verified.") - D TIUCHK^LRAPUTL(.LRPTR,LRDFN,LRSS) - I +$G(LRPTR) D Q - .D MAIN^LR7OSAP3(LRPTR) - D ZZ,LINE - I $D(^LR(LRDFN,84)) D - .D LN - .S LRTEXT="SUPPLEMENTARY REPORT HAS BEEN ADDED" - .S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(14,CCNT,"*+* "_LRTEXT_" *+*") - .D LN - .S LRTEXT="REFER TO BOTTOM OF REPORT" - .S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(19,CCNT,"*+* "_LRTEXT_" *+*") - .D LN - I $D(^LR(LRDFN,81)) D - . D LN - . S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,LRAU(3)) - . D F(81) - I $D(^LR(LRDFN,82)) D - . D LN - . S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,LRAU(4)) - . D F(82) - I $O(^LR(LRDFN,84,0)) D - . S I=0 F S I=$O(^LR(LRDFN,84,I)) Q:'I S X=^(I,0) D - .. ;Don't print supp date and text if supp has not been released - .. S X1=$P(X,"^",1),X2=$P(X,"^",2) - .. Q:'X2 - .. D LINE,LN - .. S LRTEXT="SUPPLEMENTARY REPORT DATE: "_$$FMTE^XLFDT(X1,"1P") - .. S ^TMP("LRC",$J,GCNT,0)=LRTEXT - .. I $O(^LR(LRDFN,84,I,2,0)) D MODSR - .. D WRAP^LR7OSAP1("^LR("_LRDFN_",84,"_I_",1)",79) - Q:'$D(^LR(LRDFN,"AW"))&('$D(^("AY")))&('$D(^("AWI"))) - D WT - D LRAPT3 - ;Removed code that prints SNOMED codes per LR*5.2*259 - Q -MODSR ;Modified Autopsy Supplementary Report Audit Info - N LRTEXT,LRSP1,LRSP2,LRFILE,LRIENS,LRR1,LRR2 - S LRFILE=63.3242 - D LN - S LRTEXT="SUPPLEMENTARY REPORT HAS BEEN ADDED/MODIFIED" - S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(14,CCNT,"*** "_LRTEXT_" ***") - D LN - S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,"(Added/Last modified: ") - S LRIENS=I_","_LRDFN_"," - S LRSP1=0 - F S LRSP1=$O(^LR(LRDFN,84,I,2,LRSP1)) Q:'LRSP1 D - .S LRSP2=LRSP1 - Q:'$D(^LR(LRDFN,84,I,2,LRSP2,0)) - S LRS2=^LR(LRDFN,84,I,2,LRSP2,0),Y=+LRS2,LRS2A=$P(LRS2,"^",2),LRSGN=" typed by " - ;If supp rpt is released, display 'signed by' instead of 'typed by' - I $P(LRS2,"^",3) S Y=$P(LRS2,"^",4),LRS2A=$P(LRS2,"^",3),LRSGN=" signed by " - S LRS2A=$S($D(^VA(200,LRS2A,0)):$P(^(0),"^"),1:LRS2A) - D D^LRU - S LRR1=Y,LRR2=LRS2A - S ^(0)=^TMP("LRC",$J,GCNT,0)_LRR1_LRSGN_LRR2_")" - ;If RELEASED SUPP REPORT MODIFIED set to 1, display "NOT VERIFIED" - I $P(^LR(LRDFN,84,I,0),"^",3) D - .D LN - .S LRTEXT="NOT VERIFIED" - .S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(25,CCNT,"**-* "_LRTEXT_" *-**") - Q -LN ;Increment the counter - S GCNT=GCNT+1,CCNT=1 - Q -LINE ;Fill in the global with bank lines - N X - D LN - S X="",$P(X," ",GIOM)="",^TMP("LRC",$J,GCNT,0)=X - Q -F(NODE) ;; - D WRAP^LR7OSAP1("^LR("_LRDFN_","_NODE_")",79) - Q -D ; - N LRB,M,X - S LRB=0 - F S LRB=$O(^LR(LRDFN,"AY",I,1,LRB)) Q:'LRB S X=^(LRB,0) D LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(5,CCNT,$P(^LAB(61.4,+X,0),"^")) - S LRB=0 - F S LRB=$O(^LR(LRDFN,"AY",I,3,LRB)) Q:'LRB S X=^(LRB,0) D LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(5,CCNT,$P(^LAB(61.3,+X,0),"^")) - S LRB=0 - F S LRB=$O(^LR(LRDFN,"AY",I,4,LRB)) Q:'LRB S X=^(LRB,0) D LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(5,CCNT,$P(^LAB(61.5,+X,0),"^")) - S M=0 - F S M=$O(^LR(LRDFN,"AY",I,2,M)) Q:'M S X=^(M,0) D LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(5,CCNT,$P(^LAB(61.1,+X,0),"^")) D E - Q -E ; - N E - S E=0 - F S E=$O(^LR(LRDFN,"AY",I,2,M,1,E)) Q:'E S X=^(E,0) D LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(7,CCNT,$P(^LAB(61.2,+X,0),"^")) - Q -HD ; - D LINE - D LN - S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,"Organ/tissue:")_$$S^LR7OS(33,CCNT,"SNOMED CODING") - Q -WT ; - N B,X,OUT - I '$D(^LR(LRDFN,"AW")) D - . D LINE,LN - . S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(20,CCNT,"No organ weights entered.") - . D LINE - I $D(^LR(LRDFN,"AW")) S X=^("AW") D - . S B(9)=$P(X,"^",9),B(1)=$P(X,"^",11,99) - . D LINE,LN - . S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,"Rt--Lung--Lt Liver Spleen RT--Kidney--Lt Brain Body Wt(lb) Ht(in)") - I $D(B) D - . D LN - . S OUT=$$S^LR7OS(XPOS,CCNT,$J($P(X,"^",3),4))_$$S^LR7OS(9,CCNT,$J($P(X,"^",4),4))_$$S^LR7OS(15,CCNT,$J($P(X,"^",5),5))_$$S^LR7OS(22,CCNT,$J($P(X,"^",6),5))_$$S^LR7OS(29,CCNT,$J($P(X,"^",7),4))_$$S^LR7OS(39,CCNT,$J($P(X,"^",8),4)) - . S OUT=OUT_$$S^LR7OS(45,CCNT,$J($P(X,"^",10),4))_$$S^LR7OS(55,CCNT,$P(X,"^",2))_$$S^LR7OS(68,CCNT,$P(X,"^")) - . S ^TMP("LRC",$J,GCNT,0)=OUT - D LINE,LN - S ^TMP("LRC",$J,GCNT,0)="" - I $D(B) S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,"Heart(gm)") - I $D(^LR(LRDFN,"AV")) S X=^("AV"),B(2)=$P(X,"^",7,99),^(0)=^TMP("LRC",$J,GCNT,0)_$$S^LR7OS(12,CCNT,"TV(cm) PV(cm) MV(cm) AV(cm) RV(cm) LV(cm)") - D LN - S ^TMP("LRC",$J,GCNT,0)="" - I $D(B(9)) S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,$J(B(9),5)) - I $D(B(2)) D - . S OUT=$$S^LR7OS(12,CCNT,$J($P(X,"^"),4))_$$S^LR7OS(20,CCNT,$J($P(X,"^",2),4))_$$S^LR7OS(28,CCNT,$J($P(X,"^",3),4))_$$S^LR7OS(36,CCNT,$J($P(X,"^",4),4))_$$S^LR7OS(44,CCNT,$J($P(X,"^",5),4))_$$S^LR7OS(52,CCNT,$J($P(X,"^",6),4)) - . S ^(0)=^TMP("LRC",$J,GCNT,0)_OUT - . D LINE,LN - . S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,"Cavities(ml): Rt--Pleural--Lt Pericardial Peritoneal") - . D LN - . S OUT=$$S^LR7OS(14,CCNT,$J($P(B(2),"^",2),4))_$$S^LR7OS(25,CCNT,$J($P(B(2),"^"),4))_$$S^LR7OS(33,CCNT,$J($P(B(2),"^",3),4))_$$S^LR7OS(45,CCNT,$J($P(B(2),"^",4),4)) - . S ^TMP("LRC",$J,GCNT,0)=OUT - I $D(B(1)) F B=1:1:8 D - . I $P(B(1),"^",B) D - .. S X="25."_B - .. D LN - .. S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,$P(^DD(63,X,0),"^")_": "_$P(B(1),"^",B)) - I $D(^LR(LRDFN,"AWI")) S Y=^("AWI") F B=1:1:5 I $P(Y,"^",B) D LN S X=$S(B=1:25.9,1:25.9_(B-1)),^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,$P(^DD(63,X,0),"^")_": "_$P(Y,"^",B)) - Q -ZZ ;; - D LN - N OUT,X,LRLLOC,DA,A,B,C,LR,Y - S:$G(PNM)="" PNM=$P(^DPT(DFN,0),U) ;DBIA #10035 - S OUT=$$S^LR7OS(XPOS,CCNT,"Acc #")_$$S^LR7OS(9,CCNT,"Date/time Died")_$$S^LR7OS(27,CCNT,"Age")_$$S^LR7OS(33,CCNT,"AUTOPSY DATA")_$$S^LR7OS(53,CCNT,"Date/time of Autopsy"),^TMP("LRC",$J,GCNT,0)=OUT - S X=^LR(LRDFN,"AU"),LRLLOC=$P(X,"^",8),DA=LRDFN - D D^LRAUAW - S Y=LR(63,12) - D D^LRU,LN - S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,($P(X,"^",6)_" "_Y))_$$S^LR7OS(26,CCNT,$J($P(X,"^",9),3))_$$S^LR7OS(33,CCNT,$G(PNM)) - S Y=+X - D D^LRU - I Y'[1700 S ^(0)=^TMP("LRC",$J,GCNT,0)_$$S^LR7OS(53,CCNT,Y) - D LN - S ^TMP("LRC",$J,GCNT,0)="" - F X(1)=7,10 D - . S Y=$P(X,"^",X(1)),Y=$S(Y="":Y,$D(^VA(200,Y,0)):$P(^(0),"^"),1:Y) - . I Y]"" S ^TMP("LRC",$J,GCNT,0)=^TMP("LRC",$J,GCNT,0)_$S(X(1)=7:$$S^LR7OS(1,CCNT,"Resident: ")_Y,1:$$S^LR7OS(38,CCNT,"Senior: ")_Y) - Q -LRAPT3 ;COPIED FROM ^LRAPT3 - ;; - N A,C,X,T,F - S (F,A)=0 - F S A=$O(^LR(LRDFN,"AY",A)) Q:'A D - .I $D(^LR(LRDFN,"AY",A,0)) S T=+^(0) D - ..S T(1)=$P($G(^LAB(61,T,0)),"^") - ..S C=0 F S C=$O(^LR(LRDFN,"AY",A,5,C)) Q:'C D - ...S X=^LR(LRDFN,"AY",A,5,C,0) D SP(X) S F=1 - ;Removed code that prints ICD codes per LR*5.2*259 - Q -SP(NODE) ; - N Y,E,X,A1,B - S Y=$P(NODE,"^",2),E=$P(NODE,"^",3),X=$P(NODE,"^")_":",A1=$P($P(LRAU("S"),X,2),";",1) - D D^LRU - S T(2)=Y - I 'F D LINE,LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,T(1)) - D LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,A1_" "_E_" Date: "_T(2)) - D WRAP^LR7OSAP1("^LR("_LRDFN_",""AY"","_A_",5,"_C_",1)",80) - Q -OUT ;Show output - Q:'$D(^TMP("LRC",$J)) - N I - S I=0 - F S I=$O(^TMP("LRC",$J,I)) Q:'I W !,^(I,0) - Q +LR7OSAP2 ;ISL/RAB/WTY/KLL -Silent Routine for autopsy report;3/28/2002 + ;;5.2;LAB SERVICE;**230,256,259,317**;Sep 27, 1994 + ; + ;Reference to ^DD(63 supported by IA #999 + ; +EN(LRDFN) ; + N CCNT,GIOM,XPOS,LR,LRSS,X,I,LRAU,LRS,VERIFIED,LRTEXT,LRPTR,X2 + S XPOS=0,(LRS(5),LR("M"),CCNT)=1,LRSS="AU",GIOM=80 + D EN^LRUA,^LRAPU + S X=$S($D(^LRO(69.2,+Y,0)):^(0),1:""),LRAU(3)=$P(X,"^",3),LRAU(4)=$P(X,"^",4) + D LINE,LN + S ^TMP("LRH",$J,"AUTOPSY")=GCNT,^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(28,CCNT,"---- AUTOPSY ----") + S VERIFIED=$P($G(^LR(LRDFN,"AU")),U,15) + I 'VERIFIED D Q + . D LN + . S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,"Report not verified.") + D TIUCHK^LRAPUTL(.LRPTR,LRDFN,LRSS) + I +$G(LRPTR) D Q + .D MAIN^LR7OSAP3(LRPTR) + D ZZ,LINE + I $D(^LR(LRDFN,84)) D + .D LN + .S LRTEXT="SUPPLEMENTARY REPORT HAS BEEN ADDED" + .S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(14,CCNT,"*+* "_LRTEXT_" *+*") + .D LN + .S LRTEXT="REFER TO BOTTOM OF REPORT" + .S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(19,CCNT,"*+* "_LRTEXT_" *+*") + .D LN + I $D(^LR(LRDFN,81)) D + . D LN + . S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,LRAU(3)) + . D F(81) + I $D(^LR(LRDFN,82)) D + . D LN + . S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,LRAU(4)) + . D F(82) + I $O(^LR(LRDFN,84,0)) D + . S I=0 F S I=$O(^LR(LRDFN,84,I)) Q:'I S X=^(I,0) D + .. ;Don't print supp date and text if supp has not been released + .. S X1=$P(X,"^",1),X2=$P(X,"^",2) + .. Q:'X2 + .. D LINE,LN + .. S LRTEXT="SUPPLEMENTARY REPORT DATE: "_$$FMTE^XLFDT(X1,"1P") + .. S ^TMP("LRC",$J,GCNT,0)=LRTEXT + .. I $O(^LR(LRDFN,84,I,2,0)) D MODSR + .. D WRAP^LR7OSAP1("^LR("_LRDFN_",84,"_I_",1)",79) + Q:'$D(^LR(LRDFN,"AW"))&('$D(^("AY")))&('$D(^("AWI"))) + D WT + D LRAPT3 + ;Removed code that prints SNOMED codes per LR*5.2*259 + Q +MODSR ;Modified Autopsy Supplementary Report Audit Info + N LRTEXT,LRSP1,LRSP2,LRFILE,LRIENS,LRR1,LRR2 + S LRFILE=63.3242 + D LN + S LRTEXT="SUPPLEMENTARY REPORT HAS BEEN ADDED/MODIFIED" + S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(14,CCNT,"*** "_LRTEXT_" ***") + D LN + S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,"(Added/Last modified: ") + S LRIENS=I_","_LRDFN_"," + S LRSP1=0 + F S LRSP1=$O(^LR(LRDFN,84,I,2,LRSP1)) Q:'LRSP1 D + .S LRSP2=LRSP1 + Q:'$D(^LR(LRDFN,84,I,2,LRSP2,0)) + S LRS2=^(0),Y=+LRS2,LRS2A=$P(LRS2,"^",2),LRSGN=" typed by " + ;If supp rpt is released, display 'signed by' instead of 'typed by' + I $P(LRS2,"^",3) S Y=$P(LRS2,"^",4),LRS2A=$P(LRS2,"^",3),LRSGN=" signed by " + S LRS2A=$S($D(^VA(200,LRS2A,0)):$P(^(0),"^"),1:LRS2A) + D D^LRU + S LRR1=Y,LRR2=LRS2A + S ^(0)=^TMP("LRC",$J,GCNT,0)_LRR1_LRSGN_LRR2_")" + ;If RELEASED SUPP REPORT MODIFIED set to 1, display "NOT VERIFIED" + I $P(^LR(LRDFN,84,I,0),"^",3) D + .D LN + .S LRTEXT="NOT VERIFIED" + .S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(25,CCNT,"**-* "_LRTEXT_" *-**") + Q +LN ;Increment the counter + S GCNT=GCNT+1,CCNT=1 + Q +LINE ;Fill in the global with bank lines + N X + D LN + S X="",$P(X," ",GIOM)="",^TMP("LRC",$J,GCNT,0)=X + Q +F(NODE) ;; + D WRAP^LR7OSAP1("^LR("_LRDFN_","_NODE_")",79) + Q +D ; + N LRB,M,X + S LRB=0 + F S LRB=$O(^LR(LRDFN,"AY",I,1,LRB)) Q:'LRB S X=^(LRB,0) D LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(5,CCNT,$P(^LAB(61.4,+X,0),"^")) + S LRB=0 + F S LRB=$O(^LR(LRDFN,"AY",I,3,LRB)) Q:'LRB S X=^(LRB,0) D LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(5,CCNT,$P(^LAB(61.3,+X,0),"^")) + S LRB=0 + F S LRB=$O(^LR(LRDFN,"AY",I,4,LRB)) Q:'LRB S X=^(LRB,0) D LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(5,CCNT,$P(^LAB(61.5,+X,0),"^")) + S M=0 + F S M=$O(^LR(LRDFN,"AY",I,2,M)) Q:'M S X=^(M,0) D LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(5,CCNT,$P(^LAB(61.1,+X,0),"^")) D E + Q +E ; + N E + S E=0 + F S E=$O(^LR(LRDFN,"AY",I,2,M,1,E)) Q:'E S X=^(E,0) D LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(7,CCNT,$P(^LAB(61.2,+X,0),"^")) + Q +HD ; + D LINE + D LN + S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,"Organ/tissue:")_$$S^LR7OS(33,CCNT,"SNOMED CODING") + Q +WT ; + N B,X,OUT + I '$D(^LR(LRDFN,"AW")) D + . D LINE,LN + . S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(20,CCNT,"No organ weights entered.") + . D LINE + I $D(^LR(LRDFN,"AW")) S X=^("AW") D + . S B(9)=$P(X,"^",9),B(1)=$P(X,"^",11,99) + . D LINE,LN + . S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,"Rt--Lung--Lt Liver Spleen RT--Kidney--Lt Brain Body Wt(lb) Ht(in)") + I $D(B) D + . D LN + . S OUT=$$S^LR7OS(XPOS,CCNT,$J($P(X,"^",3),4))_$$S^LR7OS(9,CCNT,$J($P(X,"^",4),4))_$$S^LR7OS(15,CCNT,$J($P(X,"^",5),5))_$$S^LR7OS(22,CCNT,$J($P(X,"^",6),5))_$$S^LR7OS(29,CCNT,$J($P(X,"^",7),4))_$$S^LR7OS(39,CCNT,$J($P(X,"^",8),4)) + . S OUT=OUT_$$S^LR7OS(45,CCNT,$J($P(X,"^",10),4))_$$S^LR7OS(55,CCNT,$P(X,"^",2))_$$S^LR7OS(68,CCNT,$P(X,"^")) + . S ^TMP("LRC",$J,GCNT,0)=OUT + D LINE,LN + S ^TMP("LRC",$J,GCNT,0)="" + I $D(B) S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,"Heart(gm)") + I $D(^LR(LRDFN,"AV")) S X=^("AV"),B(2)=$P(X,"^",7,99),^(0)=^TMP("LRC",$J,GCNT,0)_$$S^LR7OS(12,CCNT,"TV(cm) PV(cm) MV(cm) AV(cm) RV(cm) LV(cm)") + D LN + S ^TMP("LRC",$J,GCNT,0)="" + I $D(B(9)) S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,$J(B(9),5)) + I $D(B(2)) D + . S OUT=$$S^LR7OS(12,CCNT,$J($P(X,"^"),4))_$$S^LR7OS(20,CCNT,$J($P(X,"^",2),4))_$$S^LR7OS(28,CCNT,$J($P(X,"^",3),4))_$$S^LR7OS(36,CCNT,$J($P(X,"^",4),4))_$$S^LR7OS(44,CCNT,$J($P(X,"^",5),4))_$$S^LR7OS(52,CCNT,$J($P(X,"^",6),4)) + . S ^(0)=^TMP("LRC",$J,GCNT,0)_OUT + . D LINE,LN + . S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,"Cavities(ml): Rt--Pleural--Lt Pericardial Peritoneal") + . D LN + . S OUT=$$S^LR7OS(14,CCNT,$J($P(B(2),"^",2),4))_$$S^LR7OS(25,CCNT,$J($P(B(2),"^"),4))_$$S^LR7OS(33,CCNT,$J($P(B(2),"^",3),4))_$$S^LR7OS(45,CCNT,$J($P(B(2),"^",4),4)) + . S ^TMP("LRC",$J,GCNT,0)=OUT + I $D(B(1)) F B=1:1:8 D + . I $P(B(1),"^",B) D + .. S X="25."_B + .. D LN + .. S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,$P(^DD(63,X,0),"^")_": "_$P(B(1),"^",B)) + I $D(^LR(LRDFN,"AWI")) S Y=^("AWI") F B=1:1:5 I $P(Y,"^",B) D LN S X=$S(B=1:25.9,1:25.9_(B-1)),^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,$P(^DD(63,X,0),"^")_": "_$P(Y,"^",B)) + Q +ZZ ;; + D LN + N OUT,X,LRLLOC,DA,A,B,C,LR,Y + S OUT=$$S^LR7OS(XPOS,CCNT,"Acc #")_$$S^LR7OS(9,CCNT,"Date/time Died")_$$S^LR7OS(27,CCNT,"Age")_$$S^LR7OS(33,CCNT,"AUTOPSY DATA")_$$S^LR7OS(53,CCNT,"Date/time of Autopsy"),^TMP("LRC",$J,GCNT,0)=OUT + S X=^LR(LRDFN,"AU"),LRLLOC=$P(X,"^",8),DA=LRDFN + D D^LRAUAW + S Y=LR(63,12) + D D^LRU,LN + S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(XPOS,CCNT,($P(X,"^",6)_" "_Y))_$$S^LR7OS(26,CCNT,$J($P(X,"^",9),3))_$$S^LR7OS(33,CCNT,PNM) + S Y=+X + D D^LRU + I Y'[1700 S ^(0)=^TMP("LRC",$J,GCNT,0)_$$S^LR7OS(53,CCNT,Y) + D LN + S ^TMP("LRC",$J,GCNT,0)="" + F X(1)=7,10 D + . S Y=$P(X,"^",X(1)),Y=$S(Y="":Y,$D(^VA(200,Y,0)):$P(^(0),"^"),1:Y) + . I Y]"" S ^TMP("LRC",$J,GCNT,0)=^TMP("LRC",$J,GCNT,0)_$S(X(1)=7:$$S^LR7OS(1,CCNT,"Resident: ")_Y,1:$$S^LR7OS(38,CCNT,"Senior: ")_Y) + Q +LRAPT3 ;COPIED FROM ^LRAPT3 + ;; + N A,C,X,T,F + S (F,A)=0 + F S A=$O(^LR(LRDFN,"AY",A)) Q:'A D + .I $D(^LR(LRDFN,"AY",A,0)) S T=+^(0) D + ..S T(1)=$P($G(^LAB(61,T,0)),"^") + ..S C=0 F S C=$O(^LR(LRDFN,"AY",A,5,C)) Q:'C D + ...S X=^LR(LRDFN,"AY",A,5,C,0) D SP(X) S F=1 + ;Removed code that prints ICD codes per LR*5.2*259 + Q +SP(NODE) ; + N Y,E,X,A1,B + S Y=$P(NODE,"^",2),E=$P(NODE,"^",3),X=$P(NODE,"^")_":",A1=$P($P(LRAU("S"),X,2),";",1) + D D^LRU + S T(2)=Y + I 'F D LINE,LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,T(1)) + D LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,A1_" "_E_" Date: "_T(2)) + D WRAP^LR7OSAP1("^LR("_LRDFN_",""AY"","_A_",5,"_C_",1)",80) + Q +OUT ;Show output + Q:'$D(^TMP("LRC",$J)) + N I + S I=0 + F S I=$O(^TMP("LRC",$J,I)) Q:'I W !,^(I,0) + Q diff --git a/r/LAB_SERVICE-LR-LS/LRAPBR1.m b/r/LAB_SERVICE-LR-LS/LRAPBR1.m index 74fb13c6..32ce8084 100644 --- a/r/LAB_SERVICE-LR-LS/LRAPBR1.m +++ b/r/LAB_SERVICE-LR-LS/LRAPBR1.m @@ -1,266 +1,252 @@ -LRAPBR1 ;DALOI/WTY/KLL;AP Browser Print Cont.;11/08/01 - ;;5.2;LAB SERVICE;**259,317,363**;Sep 27, 1994;Build 3 - ; - ; -ENTER ;from LRAPBR - N LRCNT,LRTMP,LRA1,LRADESC,LRLENG1,LRLENG2,LRFILE,LRAPMD - N LRFLD,LRV,LRV1,LRV2,LRB1,LRTEXT,LRSPCE,LRIENS,LRAPMR - Q:'$D(^LR(LRDFN,LRSS,LRI,0)) - S:'LRTIU GROOT="^TMP(""LRAPBR"",$J," - S:LRTIU GROOT="^TMP(""TIUP"",$J," - D INP^VADPT S LRPRAC=+VAIN(2) - S:'LRPRAC LRPRAC(1)="" - I LRPRAC S X=LRPRAC D D^LRUA S LRPRAC(1)=X - S LRQ=0 D ^LRUA,HEADER - S LR("F")=1 - D DASH - D:LRTIU GLENTRY("$TEXT",,1) - D GLENTRY("Submitted by: "_LRW(5),"",1) - D GLENTRY("Date obtained: "_LRTK,44) - D:LRA DASH -MAIN ; - D SPEC - D MODCHK - D SUPBNNR - D DIAG - D DOC - D WPFLD - D SUPRPT - D SSJR - Q -SPEC ;List specimens - D GLENTRY("Specimen (Received "_LRTK(1)_"):","",1) - S LRCNT=$P(^LR(LRDFN,LRSS,LRI,.1,0),U,4) - Q:'LRCNT - S LRFILE=+$$GET1^DID(LRSF,.012,"","SPECIFIER") - S LRIENS=LRI_","_LRDFN_"," - S LRCT2=0 - F LRB1=1:1 D Q:LRCT2=LRCNT - .D GETS^DIQ(LRFILE,LRB1_","_LRIENS,.01,"","LRTMP("_LRB1_")") - .I $D(LRTMP(LRB1)) S LRCT2=LRCT2+1 - S LRA1=0 F S LRA1=$O(LRTMP(LRA1)) Q:'LRA1 D - .S LRTEXT=LRTMP(LRA1,LRFILE,LRA1_","_LRIENS,.01) - .D GLENTRY(LRTEXT,"",1) - Q -MODCHK ;Display modified banner if required - S LRAPMR=$$GET1^DIQ(LRSF,LRIENS,.17,"I") - Q:'LRAPMR - S LRAPMD=$$GET1^DIQ(LRSF,LRIENS,.172,"I") - D GLENTRY("","",1) - S LRTEXT="" - F LRCNT=1:1:$S(LRAPMD:14,1:15) D - .S LRTEXT=LRTEXT_"*+" - S LRTEXT=LRTEXT_" MODIFIED " - S LRTEXT=LRTEXT_$S(LRAPMD:"DIAGNOSIS ",1:"REPORT ") - F LRCNT=1:1:$S(LRAPMD:14,1:15) D - .S LRTEXT=LRTEXT_"*+" - D GLENTRY(LRTEXT,"",1) - D GLENTRY("","",1) - Q -SUPBNNR ;Display supplementary report header if one or more has been added - I $P($G(^LR(LRDFN,LRSS,LRI,1.2,0)),U,4) D - .S LRTEXT="*+* SUPPLEMENTARY REPORT HAS BEEN ADDED *+*" - .D GLENTRY($$CJ^XLFSTR(LRTEXT,IOM),"",1) - .S LRTEXT="*+* REFER TO BOTTOM OF REPORT *+*" - .D GLENTRY($$CJ^XLFSTR(LRTEXT,IOM),"",1) - .D GLENTRY("","",1) - Q -DIAG ; - ;Display the Brief Clinical History, Preoperative Diagnosis, - ;Operative Findings, and Postoperative Diagnosis - S LRFILE=LRSF,LRCNT=0,LRIENS=LRI_","_LRDFN_"," - F LRFLD=.013:.001:.016 D - .D:LRA DASH - .S LRCNT=LRCNT+1 - .D GLENTRY($P($T(TEXT1+LRCNT),";",2),"",1) - .D WP - Q -DOC ; - ;Pathologist information - D GLENTRY("","",1) - D GLENTRY("Surgeon/physician: "_LRMD,27,1) - D:LRA GLENTRY(LR("%1"),"",1) - D DASH - D HEADER2 - D:LRA DASH - I LRRC="" D - .D GLENTRY("+*+* REPORT INCOMPLETE *+*+",20,1) - .D GLENTRY("","",1) - D GLENTRY("","",1) - I LRRMD'="" D - .S LRCNT=0 F LRA1="SP","CY","EM" D - ..S LRCNT=LRCNT+1 - ..S LRTMP(LRA1)=$P($T(TEXT2+LRCNT),";",3) - .S LRTMP=LRTMP(LRSS) - .D GLENTRY(LRTMP_" "_LRRMD,31) - Q -WPFLD ; - ;Display Frozen Section, Gross Description, Microscopic Description - ;and Surgical Path Diagnosis - F LRCNT=1:1:4 D - .S X=$T(FIELDS+LRCNT) - .S LRV=$P(X,";",2),LRV1=$P(X,";",3),LRV2=$P(X,";",4) - .D TEXTCHK - .I $P($G(^LR(LRDFN,LRSS,LRI,LRV,0)),U,4) D - ..D GLENTRY("","",1),GLENTRY(LR(69.2,LRV1),"",1) - ..S LRFILE=LRSF,LRIENS=LRI_","_LRDFN_",",LRFLD=LRV - ..I $P($G(^LR(LRDFN,LRSS,LRI,LRV2,0)),U,4) D - ...S LRFILE1=+$$GET1^DID(LRSF,LRV2,"","SPECIFIER") - ...D GLENTRY("*+* MODIFIED REPORT *+*",28,1) - ...D GLENTRY("(Last modified: ","",1) - ...S (LRA1,LRB1)=0 - ...F S LRA1=$O(^LR(LRDFN,LRSS,LRI,LRV2,LRA1)) Q:'LRA1 S LRB1=LRA1 - ...Q:'$D(^LR(LRDFN,LRSS,LRI,LRV2,LRB1,0)) - ...S LRSR1=$$GET1^DIQ(LRFILE1,LRB1_","_LRIENS,.01) - ...S LRSR2=$$GET1^DIQ(LRFILE1,LRB1_","_LRIENS,.02) - ...S LRTEXT=LRSR1_" typed by "_LRSR2_")" - ...D GLENTRY(LRTEXT,BTAB) - ..D WP - Q -SUPRPT ;Supplementary Report - I $P($G(^LR(LRDFN,LRSS,LRI,1.2,0)),U,4) D - .S LRFILE=+$$GET1^DID(LRSF,1.2,"","SPECIFIER") - .S LRIENS1=LRI_","_LRDFN_"," - .D GLENTRY("","",1),GLENTRY("SUPPLEMENTARY REPORT(S):","",1) - .S LRV=0 F S LRV=$O(^LR(LRDFN,LRSS,LRI,1.2,LRV)) Q:'LRV D - ..S LRIENS=LRV_","_LRIENS1 - ..S LRSR1=$$GET1^DIQ(LRFILE,LRIENS,.01) - ..S LRSR2=+$$GET1^DIQ(LRFILE,LRIENS,.02) - ..D GLENTRY("Supplementary Report Date: "_LRSR1,3,1) - ..I $D(LR("R")),'LRSR2 D GLENTRY(" not verified",BTAB) Q - ..I $P($G(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,0)),U,4) D - ...S LRTEXT="*+* SUPPLEMENTARY REPORT HAS BEEN ADDED/MODIFIED *+*" - ...D GLENTRY($$CJ^XLFSTR(LRTEXT,IOM),"",1) - ...D GLENTRY("(Added/Last","",1) - ...S (LRA1,LRB1)=0 - ...F S LRA1=$O(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,LRA1)) Q:'LRA1 D - ....S LRB1=LRA1 - ...Q:'$D(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,LRB1,0)) - ...S LRA2=^(0),Y=+LRA2,LRA2A=$P(LRA2,"^",2),LRSGN=" Typed by ",LRDSC=" modified: " - ...I $P(LRA2,"^",3) S LRSGN=" Signed by ",LRDSC=" released: ",LRA2A=$P(LRA2,"^",3),Y=$P(LRA2,"^",4) - ...S LRA2A=$S($D(^VA(200,LRA2A,0)):$P(^(0),"^"),1:LRA2A) - ...D D^LRU - ...D GLENTRY(LRDSC_Y_LRSGN_LRA2A_")",BTAB) - ..S LRFLD=1 D WP - ..D GLENTRY("","",1) - Q -SSJR ;Print special studies/journal references - D ^LRAPBR3 - S LREFLG=1 - Q -WP ;Display word procesing fields - K LRTMP,^UTILITY($J,"W") - N X,DIWR,DIWL,LRINC - S X=$$GET1^DIQ(LRFILE,LRIENS,LRFLD,"","LRTMP",) - S DIWR=IOM-5,DIWL=5,DIWF="" - S X=+$$GET1^DID(LRFILE,LRFLD,"","SPECIFIER") - I $$GET1^DID(X,.01,"","SPECIFIER")["L" S DIWF="N" - S LRINC=0 - F S LRINC=$O(LRTMP(LRINC)) Q:'LRINC S X=LRTMP(LRINC) D ^DIWP - S LRINC=0 - F S LRINC=$O(^UTILITY($J,"W",DIWL,LRINC)) Q:'LRINC D - .D GLENTRY(^UTILITY($J,"W",DIWL,LRINC,0),DIWL,1) - K ^UTILITY($J,"W") - Q -HEADER ; - D:LRTIU GLENTRY("$APHDR",,1) - D GLENTRY("","",1) - D DASH - D GLENTRY("MEDICAL RECORD |",5,1) - D GLENTRY(LRAA1,40) - D DASH -HEADER2 ; - S LRADESC="Accession No. "_$S(LRQ(8)]"":LRQ(8)_LRW(1)_" "_LRAC,1:LRAC) - S LRLENG1=$L(LRQ(1)),LRLENG2=$L(LRADESC),LRSPCE=IOM-LRLENG2-14 - S:LRLENG1>LRSPCE LRQ(1)=$E(LRQ(1),1,LRSPCE) - D GLENTRY("PATHOLOGY REPORT",30,1) - D GLENTRY("Laboratory: "_LRQ(1),"",1) - D GLENTRY(LRADESC,IOM-LRLENG2-1) - Q -FOOTER ;Footer-called from ^LRAPBR - D:LRTIU GLENTRY("$FTR",,1) - D DASH - S LRTEXT=$S('$D(LR("W")):"",1:"See signed copy in chart") - D GLENTRY(LRTEXT,"",1) - S LRTEXT="("_$S($D(LREFLG):"End of report",1:"See next page")_")" - D GLENTRY(LRTEXT,57) - D GLENTRY(LRPMD,"",1),GLENTRY(LRW(9),52),GLENTRY("| Date "_LRRC,55) - D DASH - D GLENTRY(LRP,"",1) - S LRTEXT=$S('$D(LR("W")):"STANDARD FORM 515",1:"WORK COPY ONLY !!") - D GLENTRY(LRTEXT,50) - D GLENTRY("ID:"_SSN,"",1) - D GLENTRY("SEX:"_SEX,16),GLENTRY(" DOB:"_DOB,BTAB) - I AGE D - .S LRTEXT=$S($G(VADM(6))]"":" AGE AT DEATH: ",1:" AGE: ")_AGE - .D GLENTRY(LRTEXT,BTAB) - D GLENTRY(" LOC:"_LRLLOC,BTAB) - D GLENTRY("","",1) - D:$L(LRADM) GLENTRY("ADM:"_$P(LRADM,"@"),BTAB) - D:$L(LRADX) GLENTRY("DX:"_$E(LRADX,1,26),17) - D GLENTRY("PCP:",46) - D:$L(LRPRAC) GLENTRY($E(LRPRAC(1),1,28),51) - Q -ESIGLN ;Write signature block name, title, and date of signature - D GLENTRY(,,1) - I $D(^VA(200,DUZ,0)) D - .S LRFILE=200,LRFLD=20.2,LRFLD2=20.3 - .S X=$$GET1^DIQ(LRFILE,DUZ,LRFLD) - ;Compare DUZ to pathologist, if different, use proxy signature - S:LRSS="AU" LRPATH=$$GET1^DIQ(63,LRDFN,13.6,"I") - I LRSS'="AU" D - .S LRFL2=$S(LRSS="EM":63.02,LRSS="CY":63.09,LRSS="SP":63.08,1:0) - .S LRIENS=LRI_","_LRDFN_"," - .S LRPATH=$$GET1^DIQ(LRFL2,LRIENS,.02,"I") - S LRPATH2="" - S:LRPATH'=DUZ LRPATH2=" FOR "_$$GET1^DIQ(LRFILE,LRPATH,LRFLD) - S LRTEXT="/es/ "_X_LRPATH2 - ;S LRTEXT="/es/ "_X - D GLENTRY(LRTEXT,,1) - S X=$$GET1^DIQ(LRFILE,DUZ,LRFLD2) - S LRTEXT=X - D GLENTRY(LRTEXT,,1) - S Y=LRNTIME D DD^%DT - S LRTEXT="Signed "_Y - D GLENTRY(LRTEXT,,1) - Q -DASH ;Display a line of dashes - D GLENTRY(LR("%"),"",1) - Q -GLENTRY(LRPR1,LRPR2,LRPR3) ;Write to global - ;LRPR1 = Text to be written to global - ;LRPR2 = Tab position - ;LRPR3 = 1 means start a new line. Othewise, write an current line. - S LRPR1=$G(LRPR1) - S LRPR2=+$G(LRPR2) - S LRPR3=+$G(LRPR3) - D:LRPR3 NEWLN^LRAPUTL(LRPR1,LRPR2) - D:'LRPR3 GLBWRT^LRAPUTL(LRPR1,LRPR2) - Q -TEXT1 ;Text for top of report - ;BRIEF CLINICAL HISTORY: - ;PREOPERATIVE DIAGNOSIS: - ;OPERATIVE FINDINGS: - ;POSTOPERATIVE DIAGNOSIS: -TEXT2 ;Descriptive text based on section - ;SP;Pathology Resident: - ;CY;Screened by: - ;EM;Prepared by: -FIELDS ;Field numbers for word processing fields - ;1.3;.13;6 - ;1;.03;7 - ;1.1;.04;4 - ;1.4;.14;5 -TEXTCHK ; update text line counter if it is missing (Remedy 116253) - N I,X,DATA - S I=0 - K ^TMP("WP",$J) - S X=$G(^LR(LRDFN,LRSS,LRI,LRV,0)) - I X'="",$L(X,"^")=1 D - . F S I=$O(^LR(LRDFN,LRSS,LRI,LRV,I)) Q:I="" D - . . S DATA=$G(^LR(LRDFN,LRSS,LRI,LRV,I,0)) - . . S ^TMP("WP",$J,I,0)=DATA - I $D(^TMP("WP",$J)) D - . D WP^DIE(63.08,LRI_","_LRDFN_",",LRV,"","^TMP(""WP"",$J)") - . K ^TMP("WP",$J) - Q +LRAPBR1 ;DALOI/WTY/KLL;AP Browser Print Cont.;11/08/01 + ;;5.2;LAB SERVICE;**259,317**;Sep 27, 1994 + ; + ; +ENTER ;from LRAPBR + N LRCNT,LRTMP,LRA1,LRADESC,LRLENG1,LRLENG2,LRFILE,LRAPMD + N LRFLD,LRV,LRV1,LRV2,LRB1,LRTEXT,LRSPCE,LRIENS,LRAPMR + Q:'$D(^LR(LRDFN,LRSS,LRI,0)) + S:'LRTIU GROOT="^TMP(""LRAPBR"",$J," + S:LRTIU GROOT="^TMP(""TIUP"",$J," + D INP^VADPT S LRPRAC=+VAIN(2) + S:'LRPRAC LRPRAC(1)="" + I LRPRAC S X=LRPRAC D D^LRUA S LRPRAC(1)=X + S LRQ=0 D ^LRUA,HEADER + S LR("F")=1 + D DASH + D:LRTIU GLENTRY("$TEXT",,1) + D GLENTRY("Submitted by: "_LRW(5),"",1) + D GLENTRY("Date obtained: "_LRTK,44) + D:LRA DASH +MAIN ; + D SPEC + D MODCHK + D SUPBNNR + D DIAG + D DOC + D WPFLD + D SUPRPT + D SSJR + Q +SPEC ;List specimens + D GLENTRY("Specimen (Received "_LRTK(1)_"):","",1) + S LRCNT=$P(^LR(LRDFN,LRSS,LRI,.1,0),U,4) + Q:'LRCNT + S LRFILE=+$$GET1^DID(LRSF,.012,"","SPECIFIER") + S LRIENS=LRI_","_LRDFN_"," + S LRCT2=0 + F LRB1=1:1 D Q:LRCT2=LRCNT + .D GETS^DIQ(LRFILE,LRB1_","_LRIENS,.01,"","LRTMP("_LRB1_")") + .I $D(LRTMP(LRB1)) S LRCT2=LRCT2+1 + S LRA1=0 F S LRA1=$O(LRTMP(LRA1)) Q:'LRA1 D + .S LRTEXT=LRTMP(LRA1,LRFILE,LRA1_","_LRIENS,.01) + .D GLENTRY(LRTEXT,"",1) + Q +MODCHK ;Display modified banner if required + S LRAPMR=$$GET1^DIQ(LRSF,LRIENS,.17,"I") + Q:'LRAPMR + S LRAPMD=$$GET1^DIQ(LRSF,LRIENS,.172,"I") + D GLENTRY("","",1) + S LRTEXT="" + F LRCNT=1:1:$S(LRAPMD:14,1:15) D + .S LRTEXT=LRTEXT_"*+" + S LRTEXT=LRTEXT_" MODIFIED " + S LRTEXT=LRTEXT_$S(LRAPMD:"DIAGNOSIS ",1:"REPORT ") + F LRCNT=1:1:$S(LRAPMD:14,1:15) D + .S LRTEXT=LRTEXT_"*+" + D GLENTRY(LRTEXT,"",1) + D GLENTRY("","",1) + Q +SUPBNNR ;Display supplementary report header if one or more has been added + I $P($G(^LR(LRDFN,LRSS,LRI,1.2,0)),U,4) D + .S LRTEXT="*+* SUPPLEMENTARY REPORT HAS BEEN ADDED *+*" + .D GLENTRY($$CJ^XLFSTR(LRTEXT,IOM),"",1) + .S LRTEXT="*+* REFER TO BOTTOM OF REPORT *+*" + .D GLENTRY($$CJ^XLFSTR(LRTEXT,IOM),"",1) + .D GLENTRY("","",1) + Q +DIAG ; + ;Display the Brief Clinical History, Preoperative Diagnosis, + ;Operative Findings, and Postoperative Diagnosis + S LRFILE=LRSF,LRCNT=0,LRIENS=LRI_","_LRDFN_"," + F LRFLD=.013:.001:.016 D + .D:LRA DASH + .S LRCNT=LRCNT+1 + .D GLENTRY($P($T(TEXT1+LRCNT),";",2),"",1) + .D WP + Q +DOC ; + ;Pathologist information + D GLENTRY("","",1) + D GLENTRY("Surgeon/physician: "_LRMD,27,1) + D:LRA GLENTRY(LR("%1"),"",1) + D DASH + D HEADER2 + D:LRA DASH + I LRRC="" D + .D GLENTRY("+*+* REPORT INCOMPLETE *+*+",20,1) + .D GLENTRY("","",1) + D GLENTRY("","",1) + I LRRMD'="" D + .S LRCNT=0 F LRA1="SP","CY","EM" D + ..S LRCNT=LRCNT+1 + ..S LRTMP(LRA1)=$P($T(TEXT2+LRCNT),";",3) + .S LRTMP=LRTMP(LRSS) + .D GLENTRY(LRTMP_" "_LRRMD,31) + Q +WPFLD ; + ;Display Frozen Section, Gross Description, Microscopic Description + ;and Surgical Path Diagnosis + F LRCNT=1:1:4 D + .S X=$T(FIELDS+LRCNT) + .S LRV=$P(X,";",2),LRV1=$P(X,";",3),LRV2=$P(X,";",4) + .I $P($G(^LR(LRDFN,LRSS,LRI,LRV,0)),U,4) D + ..D GLENTRY("","",1),GLENTRY(LR(69.2,LRV1),"",1) + ..S LRFILE=LRSF,LRIENS=LRI_","_LRDFN_",",LRFLD=LRV + ..I $P($G(^LR(LRDFN,LRSS,LRI,LRV2,0)),U,4) D + ...S LRFILE1=+$$GET1^DID(LRSF,LRV2,"","SPECIFIER") + ...D GLENTRY("*+* MODIFIED REPORT *+*",28,1) + ...D GLENTRY("(Last modified: ","",1) + ...S (LRA1,LRB1)=0 + ...F S LRA1=$O(^LR(LRDFN,LRSS,LRI,LRV2,LRA1)) Q:'LRA1 S LRB1=LRA1 + ...Q:'$D(^LR(LRDFN,LRSS,LRI,LRV2,LRB1,0)) + ...S LRSR1=$$GET1^DIQ(LRFILE1,LRB1_","_LRIENS,.01) + ...S LRSR2=$$GET1^DIQ(LRFILE1,LRB1_","_LRIENS,.02) + ...S LRTEXT=LRSR1_" typed by "_LRSR2_")" + ...D GLENTRY(LRTEXT,BTAB) + ..D WP + Q +SUPRPT ;Supplementary Report + I $P($G(^LR(LRDFN,LRSS,LRI,1.2,0)),U,4) D + .S LRFILE=+$$GET1^DID(LRSF,1.2,"","SPECIFIER") + .S LRIENS1=LRI_","_LRDFN_"," + .D GLENTRY("","",1),GLENTRY("SUPPLEMENTARY REPORT(S):","",1) + .S LRV=0 F S LRV=$O(^LR(LRDFN,LRSS,LRI,1.2,LRV)) Q:'LRV D + ..S LRIENS=LRV_","_LRIENS1 + ..S LRSR1=$$GET1^DIQ(LRFILE,LRIENS,.01) + ..S LRSR2=+$$GET1^DIQ(LRFILE,LRIENS,.02) + ..D GLENTRY("Supplementary Report Date: "_LRSR1,3,1) + ..I $D(LR("R")),'LRSR2 D GLENTRY(" not verified",BTAB) Q + ..I $P($G(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,0)),U,4) D + ...S LRTEXT="*+* SUPPLEMENTARY REPORT HAS BEEN ADDED/MODIFIED *+*" + ...D GLENTRY($$CJ^XLFSTR(LRTEXT,IOM),"",1) + ...D GLENTRY("(Added/Last","",1) + ...S (LRA1,LRB1)=0 + ...F S LRA1=$O(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,LRA1)) Q:'LRA1 D + ....S LRB1=LRA1 + ...Q:'$D(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,LRB1,0)) + ...S LRA2=^(0),Y=+LRA2,LRA2A=$P(LRA2,"^",2),LRSGN=" Typed by ",LRDSC=" modified: " + ...I $P(LRA2,"^",3) S LRSGN=" Signed by ",LRDSC=" released: ",LRA2A=$P(LRA2,"^",3),Y=$P(LRA2,"^",4) + ...S LRA2A=$S($D(^VA(200,LRA2A,0)):$P(^(0),"^"),1:LRA2A) + ...D D^LRU + ...D GLENTRY(LRDSC_Y_LRSGN_LRA2A_")",BTAB) + ..S LRFLD=1 D WP + ..D GLENTRY("","",1) + Q +SSJR ;Print special studies/journal references + D ^LRAPBR3 + S LREFLG=1 + Q +WP ;Display word procesing fields + K LRTMP,^UTILITY($J,"W") + N X,DIWR,DIWL,LRINC + S X=$$GET1^DIQ(LRFILE,LRIENS,LRFLD,"","LRTMP",) + S DIWR=IOM-5,DIWL=5,DIWF="" + S X=+$$GET1^DID(LRFILE,LRFLD,"","SPECIFIER") + I $$GET1^DID(X,.01,"","SPECIFIER")["L" S DIWF="N" + S LRINC=0 + F S LRINC=$O(LRTMP(LRINC)) Q:'LRINC S X=LRTMP(LRINC) D ^DIWP + S LRINC=0 + F S LRINC=$O(^UTILITY($J,"W",DIWL,LRINC)) Q:'LRINC D + .D GLENTRY(^UTILITY($J,"W",DIWL,LRINC,0),DIWL,1) + K ^UTILITY($J,"W") + Q +HEADER ; + D:LRTIU GLENTRY("$APHDR",,1) + D GLENTRY("","",1) + D DASH + D GLENTRY("MEDICAL RECORD |",5,1) + D GLENTRY(LRAA1,40) + D DASH +HEADER2 ; + S LRADESC="Accession No. "_$S(LRQ(8)]"":LRQ(8)_LRW(1)_" "_LRAC,1:LRAC) + S LRLENG1=$L(LRQ(1)),LRLENG2=$L(LRADESC),LRSPCE=IOM-LRLENG2-14 + S:LRLENG1>LRSPCE LRQ(1)=$E(LRQ(1),1,LRSPCE) + D GLENTRY("PATHOLOGY REPORT",30,1) + D GLENTRY("Laboratory: "_LRQ(1),"",1) + D GLENTRY(LRADESC,IOM-LRLENG2-1) + Q +FOOTER ;Footer-called from ^LRAPBR + D:LRTIU GLENTRY("$FTR",,1) + D DASH + S LRTEXT=$S('$D(LR("W")):"",1:"See signed copy in chart") + D GLENTRY(LRTEXT,"",1) + S LRTEXT="("_$S($D(LREFLG):"End of report",1:"See next page")_")" + D GLENTRY(LRTEXT,57) + D GLENTRY(LRPMD,"",1),GLENTRY(LRW(9),52),GLENTRY("| Date "_LRRC,55) + D DASH + D GLENTRY(LRP,"",1) + S LRTEXT=$S('$D(LR("W")):"STANDARD FORM 515",1:"WORK COPY ONLY !!") + D GLENTRY(LRTEXT,50) + D GLENTRY("ID:"_SSN,"",1) + D GLENTRY("SEX:"_SEX,16),GLENTRY(" DOB:"_DOB,BTAB) + I AGE D + .S LRTEXT=$S($G(VADM(6))]"":" AGE AT DEATH: ",1:" AGE: ")_AGE + .D GLENTRY(LRTEXT,BTAB) + D GLENTRY(" LOC:"_LRLLOC,BTAB) + D GLENTRY("","",1) + D:$L(LRADM) GLENTRY("ADM:"_$P(LRADM,"@"),BTAB) + D:$L(LRADX) GLENTRY("DX:"_$E(LRADX,1,26),17) + D GLENTRY("PCP:",46) + D:$L(LRPRAC) GLENTRY($E(LRPRAC(1),1,28),51) + Q +ESIGLN ;Write signature block name, title, and date of signature + D GLENTRY(,,1) + I $D(^VA(200,DUZ,0)) D + .S LRFILE=200,LRFLD=20.2,LRFLD2=20.3 + .S X=$$GET1^DIQ(LRFILE,DUZ,LRFLD) + ;Compare DUZ to pathologist, if different, use proxy signature + S:LRSS="AU" LRPATH=$$GET1^DIQ(63,LRDFN,13.6,"I") + I LRSS'="AU" D + .S LRFL2=$S(LRSS="EM":63.02,LRSS="CY":63.09,LRSS="SP":63.08,1:0) + .S LRIENS=LRI_","_LRDFN_"," + .S LRPATH=$$GET1^DIQ(LRFL2,LRIENS,.02,"I") + S LRPATH2="" + S:LRPATH'=DUZ LRPATH2=" FOR "_$$GET1^DIQ(LRFILE,LRPATH,LRFLD) + S LRTEXT="/es/ "_X_LRPATH2 + ;S LRTEXT="/es/ "_X + D GLENTRY(LRTEXT,,1) + S X=$$GET1^DIQ(LRFILE,DUZ,LRFLD2) + S LRTEXT=X + D GLENTRY(LRTEXT,,1) + S Y=LRNTIME D DD^%DT + S LRTEXT="Signed "_Y + D GLENTRY(LRTEXT,,1) + Q +DASH ;Display a line of dashes + D GLENTRY(LR("%"),"",1) + Q +GLENTRY(LRPR1,LRPR2,LRPR3) ;Write to global + ;LRPR1 = Text to be written to global + ;LRPR2 = Tab position + ;LRPR3 = 1 means start a new line. Othewise, write an current line. + S LRPR1=$G(LRPR1) + S LRPR2=+$G(LRPR2) + S LRPR3=+$G(LRPR3) + D:LRPR3 NEWLN^LRAPUTL(LRPR1,LRPR2) + D:'LRPR3 GLBWRT^LRAPUTL(LRPR1,LRPR2) + Q +TEXT1 ;Text for top of report + ;BRIEF CLINICAL HISTORY: + ;PREOPERATIVE DIAGNOSIS: + ;OPERATIVE FINDINGS: + ;POSTOPERATIVE DIAGNOSIS: +TEXT2 ;Descriptive text based on section + ;SP;Pathology Resident: + ;CY;Screened by: + ;EM;Prepared by: +FIELDS ;Field numbers for word processing fields + ;1.3;.13;6 + ;1;.03;7 + ;1.1;.04;4 + ;1.4;.14;5 diff --git a/r/LAB_SERVICE-LR-LS/LRAPDA.m b/r/LAB_SERVICE-LR-LS/LRAPDA.m index 085f1c5a..1ee7a5d6 100644 --- a/r/LAB_SERVICE-LR-LS/LRAPDA.m +++ b/r/LAB_SERVICE-LR-LS/LRAPDA.m @@ -1,262 +1,251 @@ -LRAPDA ;DALOI/REG/WTY/KLL/CKA - ANATOMIC PATH DATA ENTRY;11/02/01 - ;;5.2;LAB SERVICE;**72,73,91,121,248,259,295,317,365**;Sep 27, 1994;Build 9 - ; - ;Reference to ^%DT supported by IA #10003 - ;Reference to ^DIE supported by IA #10018 - ;Reference to ^VA(200 supported by IA #10060 - ;Reference to EN^DDIOL supported by IA #10142 - ; - W !?20,LRO(68)," (",LRABV,")",! - S:'$D(LRSOP) LRSOP=1 S:'$D(LRD(1)) LRD(1)="0" - S:'$D(^LRO(69.2,LRAA,2,0)) ^(0)="^69.23A^0^0" -SEL K LR(1) - I $D(LR(2)) D G:%<1 END S:%=1 LR(1)=1 - .W !!,"Enter Etiology, Function, Procedure & Disease " - .S %=2 D YN^LRU -AK ;from LRAPD1 - N CORRECT - S:'$D(LRSFLG) LRSFLG="" - W !!,"Data entry for ",LRH(0)," " - S %=1 D YN^LRU G:%<1 END - I %=2 D G:Y<1 END S LRAD=$E(Y,1,3)_"0000",LRH(0)=$E(Y,1,3)+1700 - .S %DT="AE",%DT(0)="-N",%DT("A")="Enter YEAR: " D ^%DT K %DT - I '$O(^LRO(68,LRAA,1,LRAD,1,0)) D Q - .W $C(7),!!,"NO ",LRO(68)," ACCESSIONS IN FILE FOR ",LRH(0),!! -W K X,Y,LR("CK") - R !!,"Select Accession Number/Pt name: ",LRAN:DTIME - G:LRAN=""!(LRAN[U) END - I LRAN["?" D G W - .W !!,"Enter the year ",LRH(0)," ",LRO(68)," accession number to be " - .W "updated" - .W !,"or locate the accession by entering the patient name." - I LRAN'?1N.N D PNAME G:LRAN<1 W D OE1^LR7OB63D,REST,OERR^LR7OB63D G W - D OE1^LR7OB63D,REST S:$D(DR(1))#2 DR=DR(1) D OERR^LR7OB63D G W -REST ; - N LRXSTOP,LRX,LRX1 - W " for ",LRH(0) - I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) D Q - .W $C(7),!!,"Accession # ",LRAN," for ",LRH(0)," not in ",LRO(68),!! - S X=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRLLOC=$P(X,"^",7),LRDFN=+X - Q:'$D(^LR(LRDFN,0)) S X=^(0) D ^LRUP - W !,LRP," ID: ",SSN - S LRI=+$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",5) - I LRSS'="AU",'$D(^LR(LRDFN,LRSS,LRI,0)) D Q - .W $C(7),!,"Inverse date missing or incorrect in Accession Area file " - .W "for",!,LRO(68)," Year: ",$E(LRAD,2,3)," Accession: ",LRAN - I "SPCYEM"[LRSS,$O(^LR(LRDFN,LRSS,LRI,.1,0)) D - .W !,"Specimen(s):" - .S X=0 F S X=$O(^LR(LRDFN,LRSS,LRI,.1,X)) Q:'X D - ..W !,$P($G(^LR(LRDFN,LRSS,LRI,.1,X,0)),"^") - ; - ;Don't allow supp. report to be added to a released report if - ; modifications are being added via MM option - S LRXSTOP=0,(LRX,LRX1)="" - I LRSS'="AU",LRD(1)="S" D - .S LRX=$P($G(^LR(LRDFN,LRSS,LRI,0)),"^",11) ;release date/time - .S LRX1=$P($G(^LR(LRDFN,LRSS,LRI,0)),"^",15) ;orig rel date/time - I LRSS="AU",LRSOP="R" D - .S LRX=$P($G(^LR(LRDFN,"AU")),"^",15) ;release date/time - .S LRX1=$P($G(^LR(LRDFN,"AU")),"^",3) ;date report completed - I 'LRX,LRX1 D - .W $C(7),!!,"This "_$G(LRAA(1))_" report is currently being" - .W !,"modified; it must first be released before Supplementary" - .W !,"report can be added.",! - .S LRXSTOP=1 - Q:LRXSTOP - ; -DIE ;Edit - I LRSS="AU" D AUE Q - N LRRDT1,LRRDT2,LRIENS,LREL,LRQUIT,LRSNO,LRCPT,LRESCPT - S (LREL,LRESCPT,LRQUIT,LRSNO,LRCPT)=0,LRIENS=LRI_","_LRDFN_"," - S LRRDT1=$$GET1^DIQ(LRSF,LRIENS,.11,"I") - S LRRDT2=$$GET1^DIQ(LRSF,LRIENS,.15,"I") - S:LRRDT1!LRRDT2 LREL=1 - ;Determine if CPT activated - I $T(ES^LRCAPES)'="" S LRESCPT=$$ES^LRCAPES() - I LRSOP="G",LREL D Q - .W $C(7),!!,"Report verified. Cannot edit with this option." - I LRSOP'="","ABM"[LRSOP,LREL D Q:LRQUIT - .;Allow SNOMED and CPT coding even after release. - .W $C(7),!!,"Report has been verified. " - .I 'LRESCPT,LRSOP'="B" D Q - ..W "Cannot edit with this option." - ..S LRQUIT=1 - .W "Only " - .I LRESCPT W "CPT " W:LRSOP="B" "and " - .W:LRSOP="B" "SNOMED " - .W "coding permitted.",! - .I LRSOP="B" D - ..K DIR S DIR(0)="Y",DIR("A")="Enter SNOMED coding",DIR("B")="NO" - ..D ^DIR W ! - ..S LRSNO=+Y - .Q:'LRESCPT - .K DIR S DIR(0)="Y",DIR("A")="Enter CPT coding",DIR("B")="NO" - .D ^DIR W ! - .S LRCPT=+Y - .I "AM"[LRSOP,'LRCPT S LRQUIT=1 Q - .I LRSOP="B",'LRCPT,'LRSNO S LRQUIT=1 -RESET ;Reset DR string if altered by prior accession/patient - ;Reset DR to orig value in LRAPD1 - I LRSOP'="","AMBS"[LRSOP,$G(LRD)'="" D @LRD - I LRSFLG="S",$G(LRD)'="" D @LRD ;For CY,EM Supp entry - S:LRSNO DR=10 ;Modify DR string if only SNOMED coding permitted - I 'LRSNO,LRCPT S DR="" ;Set DR string to null in only CPT coding - ;If adding supp rpt to released rpt, remove date rpt completed from DR - I LRRDT1,LRSOP="S"!(LRSFLG="S") S DR=".09///^S X=LRWHO;10" -EDIT ;Call to ^DIE - W ! S LRA=^LR(LRDFN,LRSS,LRI,0),LRRC=$P(LRA,"^",10) - I LRCAPA,"SPCYEM"[LRSS D C^LRAPSWK - S DIE="^LR(LRDFN,LRSS,",DA=LRI,DA(1)=LRDFN - D CK^LRU Q:$D(LR("CK")) - I LRSS="SP",LRSOP="B",$O(^LR(LRDFN,LRSS,LRI,1.3,0)) D - .W $C(7),!!,"This accession has a FROZEN SECTION report." - .W !,"Be sure 'FROZEN SECTION' is entered as a SNOMED code in the " - .W "PROCEDURE field" - .W !,"for the appropriate organ or tissue.",!! - ;Code S LRELSD is in DR string setup in LRAPR - N LRELSD S LRELSD=0 - D ^DIE - S LRAC=$P(LRA,U,6) - I LRELSD D MAIN^LRAPRES1(LRDFN,LRSS,LRI,LRSF,LRP,LRAC) - D UPDATE^LRPXRM(LRDFN,LRSS,LRI) - D:LRSFLG="S"&('$D(Y)) ^LRAPDSR - D FRE^LRU - I LRSOP'="","ABM"[LRSOP D CPTCOD -WKLD ;Capture Workload - I LRSOP="Z","CYSP"[LRSS,LRCAPA D S^LRAPR Q - I LRCAPA,"SPCYEM"[LRSS,LRD(1)'="","MBA"[LRD(1) D C1^LRAPSWK - I LRCAPA,"SPCYEM"[LRSS,LRSOP="G" D C1^LRAPSWK -QUEUES ;Update Queues - S X=$P(^LR(LRDFN,LRSS,LRI,0),"^",4) - I X,$D(^VA(200,X,0)) S LR("TR")=$P(^(0),"^") - I "CYEMSP"[LRSS,$D(LR(6)),LRSOP="G" Q:$D(^LRO(69.2,LRAA,1,LRAN,0)) D Q - .L +^LRO(69.2,LRAA,1):5 I '$T D Q - ..S MSG(1)="The preliminary reports queue is in use by another person." - ..S MSG(1,"F")="!!" - ..S MSG(2)=" You will need to add this accession to the queue later." - ..D EN^DDIOL(.MSG) K MSG - .S ^LRO(69.2,LRAA,1,LRAN,0)=LRDFN_"^"_LRI_"^"_LRH(0) - .S X=^LRO(69.2,LRAA,1,0),^(0)=$P(X,"^",1,2)_"^"_LRAN_"^"_($P(X,"^",4)+1) - .L -^LRO(69.2,LRAA,1) - I "CYEMSP"[LRSS,$D(LR(7)),'$D(^LRO(69.2,LRAA,2,LRAN,0)),LRD(1)'="S" D - .L +^LRO(69.2,LRAA,2):5 I '$T D Q - ..S MSG(1)="The final reports queue is in use by another person. " - ..S MSG(1,"F")="!!" - ..S MSG(2)="You will need to add this accession to the queue later." - ..D EN^DDIOL(.MSG) K MSG - .S ^LRO(69.2,LRAA,2,LRAN,0)=LRDFN_"^"_LRI_"^"_LRH(0) - .S X=^LRO(69.2,LRAA,2,0),^(0)=$P(X,"^",1,2)_"^"_LRAN_"^"_($P(X,"^",4)+1) - .L -^LRO(69.2,LRAA,2) - D:LRSOP="M"!(LRSOP="B") EN^LRSPGD - Q -NM ; - I X'["@"!(X["@"&(Y(Z)="")) D Q - .W $C(7),!?4,"ENTER WHOLE NUMBERS ONLY",! K X - I Y(Z)'="" W $C(7),?40,"OK TO DELETE" S %=2 D YN^LRU I %'=1 K X Q - S Y(Z)="" Q - ; -AUE ;Autopsy Data Entry - W ! - N LREL,LRQUIT,LRSNO,LRESCPT,LRCPT - S (LREL,LRQUIT,LRSNO,LRCPT)=0 - S LREL=+$$GET1^DIQ(63,LRDFN_",",14.7,"I") - ;Determine if CPT activated - I $T(ES^LRCAPES)'="" S LRESCPT=$$ES^LRCAPES() - ; Allow supp report to be added on verified AU - I LRSOP'="","AFIP"[LRSOP,LREL D Q:LRQUIT - .Q:LRESCPT&("AP"[LRSOP) - .W $C(7),!!,"Report verified. Cannot edit with this option!" - .S LRQUIT=1 - I LRSOP'="","ABP"[LRSOP,LREL D Q:LRQUIT - .W $C(7),!!,"Report has been verified. " - .W "Only " - .I LRESCPT W "CPT " W:LRSOP="B" "and " - .W:LRSOP="B" "SNOMED " - .W "coding permitted.",! - .I LRSOP="B" D - ..K DIR S DIR(0)="Y",DIR("A")="Enter SNOMED coding",DIR("B")="NO" - ..D ^DIR W ! - ..S LRSNO=+Y - .Q:'LRESCPT - .K DIR S DIR(0)="Y",DIR("A")="Enter CPT coding",DIR("B")="NO" - .D ^DIR W ! - .S LRCPT=+Y - .I "AP"[LRSOP,'LRCPT S LRQUIT=1 Q - .I LRSOP="B",'LRCPT,'LRSNO S LRQUIT=1 -AURESET ;Reset DR to orig value in LRAUDA - I LRSOP'="","AP"[LRSOP D @(LRSOP_"DR^LRAUDA") - I LRSOP="B" D BDR^LRAUDA - S:LRSNO DR=32 ;Modify DR string if only SNOMED coding permitted - I 'LRSNO,LRCPT S DR="" ;Set DR string to null inf only CPT coding - ; ; - ;Not all of the autopsy fields are within the AU subscript. - ;Therefore, we must lock the entire LRDFN. - L +^LR(LRDFN):5 I '$T D Q - .S MSG="This record is locked by another user. " - .S MSG=MSG_"Please wait and try again." - .D EN^DDIOL(MSG,"","!!") K MSG - I LRSFLG'="S" D - .N LRELSD S LRELSD=0 - .S DIE="^LR(",DA=LRDFN - .D ^DIE - .S LRA=^LR(LRDFN,"AU") - .S LRI=$P(LRA,U) - .S LRAC=$P(LRA,U,6) - .I LRELSD D MAIN^LRAPRES1(LRDFN,LRSS,LRI,LRSF,LRP,LRAC) - D:LRSFLG="S" ^LRAPDSR - D UPDATE^LRPXRM(LRDFN,"AU") - L -^LR(LRDFN) - D:"BAP"[LRSOP AU - D:LRSOP="R" R - I LRSOP'="","ABP"[LRSOP D CPTCOD - Q -AU I '$D(^LRO(69.2,LRAA,2,LRAN,0)) D - .L +^LRO(69.2,LRAA,2):5 I '$T D Q - ..S MSG(1)="The final reports queue is in use by another person. " - ..S MSG(1,"F")="!!" - ..S MSG(2)="You will need to add this accession to the queue later." - ..D EN^DDIOL(.MSG) K MSG - .S ^LRO(69.2,LRAA,2,LRAN,0)=LRDFN - .S X=^LRO(69.2,LRAA,2,0),^(0)=$P(X,"^",1,2)_"^"_LRAN_"^"_($P(X,"^",4)+1) - .L -^LRO(69.2,LRAA,2) - D AU^LRSPGD - Q -R I '$D(^LRO(69.2,LRAA,3,LRAN,0)) D - .L +^LRO(69.2,LRAA,3):5 I '$T D Q - ..S MSG(1)="The interim reports queue is in use by another person. " - ..S MSG(1,"F")="!!" - ..S MSG(2)="You will need to add this accession to the queue later." - ..D EN^DDIOL(.MSG) K MSG - .S ^LRO(69.2,LRAA,3,LRAN,0)=LRDFN - .S X=^LRO(69.2,LRAA,3,0),^(0)=$P(X,"^",1,2)_"^"_LRAN_"^"_($P(X,"^",4)+1) - .L -^LRO(69.2,LRAA,3) - Q -PNAME ;Patient Name Lookup - N LRPFLG ;LRPFLG tells LRUPS to limit accessions to - S X=LRAN,LRPFLG=1 ;the chosen year. - K LRAN,DIC,VADM,VAIN,VA - S DFN=-1,DIC(0)="EQM",(LRX,LRDPF)="" - D:'$D(LRLABKY) LABKEY^LRPARAM - D DPA1^LRDPA - I DFN=-1 S LRAN=-1 Q - D I^LRUPS - Q -CPTCOD ;CPT Coding - N LRPRO - Q:$T(CPT^LRCAPES)="" - Q:LREL&('LRCPT) - I 'LREL D - .K DIR S DIR(0)="Y",DIR("A")="Enter CPT coding",DIR("B")="NO" - .D ^DIR W ! - .S LRCPT=+Y - Q:'LRCPT - ;SET PROVIDER TO CURRENT USER, ALLOW UPDATES - S LRPRO=DUZ - D PROVIDR^LRAPUTL - Q:LRQUIT - D CPT^LRCAPES(LRAA,LRAD,LRAN,LRPRO) - Q -END K LRSFLG - D:$T(CLEAN^LRCAPES)'="" CLEAN^LRCAPES - D V^LRU - Q +LRAPDA ;AVAMC/REG/WTY/KLL - ANATOMIC PATH DATA ENTRY;11/02/01 + ;;5.2;LAB SERVICE;**72,73,91,121,248,259,295,317**;Sep 27, 1994 + ; + ;Reference to ^%DT supported by IA #10003 + ;Reference to ^DIE supported by IA #10018 + ;Reference to ^VA(200 supported by IA #10060 + ;Reference to EN^DDIOL supported by IA #10142 + ; + W !?20,LRO(68)," (",LRABV,")",! + S:'$D(LRSOP) LRSOP=1 S:'$D(LRD(1)) LRD(1)="0" + S:'$D(^LRO(69.2,LRAA,2,0)) ^(0)="^69.23A^0^0" +SEL K LR(1) + I $D(LR(2)) D G:%<1 END S:%=1 LR(1)=1 + .W !!,"Enter Etiology, Function, Procedure & Disease " + .S %=2 D YN^LRU +AK ;from LRAPD1 + N CORRECT + S:'$D(LRSFLG) LRSFLG="" + W !!,"Data entry for ",LRH(0)," " + S %=1 D YN^LRU G:%<1 END + I %=2 D G:Y<1 END S LRAD=$E(Y,1,3)_"0000",LRH(0)=$E(Y,1,3)+1700 + .S %DT="AE",%DT(0)="-N",%DT("A")="Enter YEAR: " D ^%DT K %DT + I '$O(^LRO(68,LRAA,1,LRAD,1,0)) D Q + .W $C(7),!!,"NO ",LRO(68)," ACCESSIONS IN FILE FOR ",LRH(0),!! +W K X,Y,LR("CK") + R !!,"Select Accession Number/Pt name: ",LRAN:DTIME + G:LRAN=""!(LRAN[U) END + I LRAN["?" D G W + .W !!,"Enter the year ",LRH(0)," ",LRO(68)," accession number to be " + .W "updated" + .W !,"or locate the accession by entering the patient name." + I LRAN'?1N.N D PNAME G:LRAN<1 W D OE1^LR7OB63D,REST,OERR^LR7OB63D G W + D OE1^LR7OB63D,REST S:$D(DR(1))#2 DR=DR(1) D OERR^LR7OB63D G W +REST ; + N LRXSTOP,LRX,LRX1 + W " for ",LRH(0) + I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) D Q + .W $C(7),!!,"Accession # ",LRAN," for ",LRH(0)," not in ",LRO(68),!! + S X=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRLLOC=$P(X,"^",7),LRDFN=+X + Q:'$D(^LR(LRDFN,0)) S X=^(0) D ^LRUP + W !,LRP," ID: ",SSN + S LRI=+$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",5) + I LRSS'="AU",'$D(^LR(LRDFN,LRSS,LRI,0)) D Q + .W $C(7),!,"Inverse date missing or incorrect in Accession Area file " + .W "for",!,LRO(68)," Year: ",$E(LRAD,2,3)," Accession: ",LRAN + I "SPCYEM"[LRSS,$O(^LR(LRDFN,LRSS,LRI,.1,0)) D + .W !,"Specimen(s):" + .S X=0 F S X=$O(^LR(LRDFN,LRSS,LRI,.1,X)) Q:'X D + ..W !,$P($G(^LR(LRDFN,LRSS,LRI,.1,X,0)),"^") + ; + ;Don't allow supp. report to be added to a released report if + ; modifications are being added via MM option + S LRXSTOP=0,(LRX,LRX1)="" + I LRSS'="AU",LRD(1)="S" D + .S LRX=$P($G(^LR(LRDFN,LRSS,LRI,0)),"^",11) ;release date/time + .S LRX1=$P($G(^LR(LRDFN,LRSS,LRI,0)),"^",15) ;orig rel date/time + I LRSS="AU",LRSOP="R" D + .S LRX=$P($G(^LR(LRDFN,"AU")),"^",15) ;release date/time + .S LRX1=$P($G(^LR(LRDFN,"AU")),"^",3) ;date report completed + I 'LRX,LRX1 D + .W $C(7),!!,"This "_$G(LRAA(1))_" report is currently being" + .W !,"modified; it must first be released before Supplementary" + .W !,"report can be added.",! + .S LRXSTOP=1 + Q:LRXSTOP + ; +DIE ;Edit + I LRSS="AU" D AUE Q + N LRRDT1,LRRDT2,LRIENS,LREL,LRQUIT,LRSNO,LRCPT,LRESCPT + S (LREL,LRESCPT,LRQUIT,LRSNO,LRCPT)=0,LRIENS=LRI_","_LRDFN_"," + S LRRDT1=$$GET1^DIQ(LRSF,LRIENS,.11,"I") + S LRRDT2=$$GET1^DIQ(LRSF,LRIENS,.15,"I") + S:LRRDT1!LRRDT2 LREL=1 + I $T(ES^LRCAPES)'="" S LRESCPT=$$ES^LRCAPES() + I LRSOP="G",LREL D Q + .W $C(7),!!,"Report verified. Cannot edit with this option." + I LRSOP'="","ABM"[LRSOP,LREL D Q:LRQUIT + .;Allow SNOMED and CPT coding even after release. + .W $C(7),!!,"Report has been verified. " + .I 'LRESCPT,LRSOP'="B" D Q + ..W "Cannot edit with this option." + ..S LRQUIT=1 + .W "Only " + .I LRESCPT W "CPT " W:LRSOP="B" "and " + .W:LRSOP="B" "SNOMED " + .W "coding permitted.",! + .I LRSOP="B" D + ..K DIR S DIR(0)="Y",DIR("A")="Enter SNOMED coding",DIR("B")="NO" + ..D ^DIR W ! + ..S LRSNO=+Y + .Q:'LRESCPT + .K DIR S DIR(0)="Y",DIR("A")="Enter CPT coding",DIR("B")="NO" + .D ^DIR W ! + .S LRCPT=+Y + .I "AM"[LRSOP,'LRCPT S LRQUIT=1 Q + .I LRSOP="B",'LRCPT,'LRSNO S LRQUIT=1 +RESET ;Reset DR string if altered by prior accession/patient + ;Reset DR to orig value in LRAPD1 + I LRSOP'="","AMBS"[LRSOP,$G(LRD)'="" D @LRD + I LRSFLG="S",$G(LRD)'="" D @LRD ;For CY,EM Supp entry + S:LRSNO DR=10 ;Modify DR string if only SNOMED coding permitted + I 'LRSNO,LRCPT S DR="" ;Set DR string to null in only CPT coding + ;If adding supp rpt to released rpt, remove date rpt completed from DR + I LRRDT1,LRSOP="S"!(LRSFLG="S") S DR=".09///^S X=LRWHO;10" +EDIT ;Call to ^DIE + W ! S LRA=^LR(LRDFN,LRSS,LRI,0),LRRC=$P(LRA,"^",10) + I LRCAPA,"SPCYEM"[LRSS D C^LRAPSWK + S DIE="^LR(LRDFN,LRSS,",DA=LRI,DA(1)=LRDFN + D CK^LRU Q:$D(LR("CK")) + I LRSS="SP",LRSOP="B",$O(^LR(LRDFN,LRSS,LRI,1.3,0)) D + .W $C(7),!!,"This accession has a FROZEN SECTION report." + .W !,"Be sure 'FROZEN SECTION' is entered as a SNOMED code in the " + .W "PROCEDURE field" + .W !,"for the appropriate organ or tissue.",!! + D ^DIE + D UPDATE^LRPXRM(LRDFN,LRSS,LRI) + D:LRSFLG="S"&('$D(Y)) ^LRAPDSR + D FRE^LRU + I LRSOP'="","ABM"[LRSOP D CPTCOD +WKLD ;Capture Workload + I LRSOP="Z","CYSP"[LRSS,LRCAPA D S^LRAPR Q + I LRCAPA,"SPCYEM"[LRSS,LRD(1)'="","MBA"[LRD(1) D C1^LRAPSWK + I LRCAPA,"SPCYEM"[LRSS,LRSOP="G" D C1^LRAPSWK +QUEUES ;Update Queues + S X=$P(^LR(LRDFN,LRSS,LRI,0),"^",4) + I X,$D(^VA(200,X,0)) S LR("TR")=$P(^(0),"^") + I "CYEMSP"[LRSS,$D(LR(6)),LRSOP="G" Q:$D(^LRO(69.2,LRAA,1,LRAN,0)) D Q + .L +^LRO(69.2,LRAA,1):5 I '$T D Q + ..S MSG(1)="The preliminary reports queue is in use by another person." + ..S MSG(1,"F")="!!" + ..S MSG(2)=" You will need to add this accession to the queue later." + ..D EN^DDIOL(.MSG) K MSG + .S ^LRO(69.2,LRAA,1,LRAN,0)=LRDFN_"^"_LRI_"^"_LRH(0) + .S X=^LRO(69.2,LRAA,1,0),^(0)=$P(X,"^",1,2)_"^"_LRAN_"^"_($P(X,"^",4)+1) + .L -^LRO(69.2,LRAA,1) + I "CYEMSP"[LRSS,$D(LR(7)),'$D(^LRO(69.2,LRAA,2,LRAN,0)),LRD(1)'="S" D + .L +^LRO(69.2,LRAA,2):5 I '$T D Q + ..S MSG(1)="The final reports queue is in use by another person. " + ..S MSG(1,"F")="!!" + ..S MSG(2)="You will need to add this accession to the queue later." + ..D EN^DDIOL(.MSG) K MSG + .S ^LRO(69.2,LRAA,2,LRAN,0)=LRDFN_"^"_LRI_"^"_LRH(0) + .S X=^LRO(69.2,LRAA,2,0),^(0)=$P(X,"^",1,2)_"^"_LRAN_"^"_($P(X,"^",4)+1) + .L -^LRO(69.2,LRAA,2) + D:LRSOP="M"!(LRSOP="B") EN^LRSPGD + Q +NM ; + I X'["@"!(X["@"&(Y(Z)="")) D Q + .W $C(7),!?4,"ENTER WHOLE NUMBERS ONLY",! K X + I Y(Z)'="" W $C(7),?40,"OK TO DELETE" S %=2 D YN^LRU I %'=1 K X Q + S Y(Z)="" Q + ; +AUE ;Autopsy Data Entry + W ! + N LREL,LRQUIT,LRSNO,LRESCPT,LRCPT + S (LREL,LRQUIT,LRSNO,LRCPT)=0 + S LREL=+$$GET1^DIQ(63,LRDFN_",",14.7,"I") + I $T(ES^LRCAPES)'="" S LRESCPT=$$ES^LRCAPES() + ; Allow supp report to be added on verified AU + I LRSOP'="","AFIP"[LRSOP,LREL D Q:LRQUIT + .Q:LRESCPT&("AP"[LRSOP) + .W $C(7),!!,"Report verified. Cannot edit with this option!" + .S LRQUIT=1 + I LRSOP'="","ABP"[LRSOP,LREL D Q:LRQUIT + .W $C(7),!!,"Report has been verified. " + .W "Only " + .I LRESCPT W "CPT " W:LRSOP="B" "and " + .W:LRSOP="B" "SNOMED " + .W "coding permitted.",! + .I LRSOP="B" D + ..K DIR S DIR(0)="Y",DIR("A")="Enter SNOMED coding",DIR("B")="NO" + ..D ^DIR W ! + ..S LRSNO=+Y + .Q:'LRESCPT + .K DIR S DIR(0)="Y",DIR("A")="Enter CPT coding",DIR("B")="NO" + .D ^DIR W ! + .S LRCPT=+Y + .I "AP"[LRSOP,'LRCPT S LRQUIT=1 Q + .I LRSOP="B",'LRCPT,'LRSNO S LRQUIT=1 +AURESET ;Reset DR to orig value in LRAUDA + I LRSOP'="","AP"[LRSOP D @(LRSOP_"DR^LRAUDA") + I LRSOP="B" D BDR^LRAUDA + S:LRSNO DR=32 ;Modify DR string if only SNOMED coding permitted + I 'LRSNO,LRCPT S DR="" ;Set DR string to null inf only CPT coding + ; ; + ;Not all of the autopsy fields are within the AU subscript. + ;Therefore, we must lock the entire LRDFN. + L +^LR(LRDFN):5 I '$T D Q + .S MSG="This record is locked by another user. " + .S MSG=MSG_"Please wait and try again." + .D EN^DDIOL(MSG,"","!!") K MSG + I LRSFLG'="S" D + .S DIE="^LR(",DA=LRDFN + .D ^DIE + D:LRSFLG="S" ^LRAPDSR + D UPDATE^LRPXRM(LRDFN,"AU") + L -^LR(LRDFN) + D:"BAP"[LRSOP AU + D:LRSOP="R" R + I LRSOP'="","ABP"[LRSOP D CPTCOD + Q +AU I '$D(^LRO(69.2,LRAA,2,LRAN,0)) D + .L +^LRO(69.2,LRAA,2):5 I '$T D Q + ..S MSG(1)="The final reports queue is in use by another person. " + ..S MSG(1,"F")="!!" + ..S MSG(2)="You will need to add this accession to the queue later." + ..D EN^DDIOL(.MSG) K MSG + .S ^LRO(69.2,LRAA,2,LRAN,0)=LRDFN + .S X=^LRO(69.2,LRAA,2,0),^(0)=$P(X,"^",1,2)_"^"_LRAN_"^"_($P(X,"^",4)+1) + .L -^LRO(69.2,LRAA,2) + D AU^LRSPGD + Q +R I '$D(^LRO(69.2,LRAA,3,LRAN,0)) D + .L +^LRO(69.2,LRAA,3):5 I '$T D Q + ..S MSG(1)="The interim reports queue is in use by another person. " + ..S MSG(1,"F")="!!" + ..S MSG(2)="You will need to add this accession to the queue later." + ..D EN^DDIOL(.MSG) K MSG + .S ^LRO(69.2,LRAA,3,LRAN,0)=LRDFN + .S X=^LRO(69.2,LRAA,3,0),^(0)=$P(X,"^",1,2)_"^"_LRAN_"^"_($P(X,"^",4)+1) + .L -^LRO(69.2,LRAA,3) + Q +PNAME ;Patient Name Lookup + N LRPFLG ;LRPFLG tells LRUPS to limit accessions to + S X=LRAN,LRPFLG=1 ;the chosen year. + K LRAN,DIC,VADM,VAIN,VA + S DFN=-1,DIC(0)="EQM",(LRX,LRDPF)="" + D:'$D(LRLABKY) LABKEY^LRPARAM + D DPA1^LRDPA + I DFN=-1 S LRAN=-1 Q + D I^LRUPS + Q +CPTCOD ;CPT Coding + N LRPRO + Q:$T(CPT^LRCAPES)="" + Q:LREL&('LRCPT) + I 'LREL D + .K DIR S DIR(0)="Y",DIR("A")="Enter CPT coding",DIR("B")="NO" + .D ^DIR W ! + .S LRCPT=+Y + Q:'LRCPT + ;SET PROVIDER TO CURRENT USER, ALLOW UPDATES + S LRPRO=DUZ + D PROVIDR^LRAPUTL + Q:LRQUIT + D CPT^LRCAPES(LRAA,LRAD,LRAN,LRPRO) + Q +END K LRSFLG + D:$T(CLEAN^LRCAPES)'="" CLEAN^LRCAPES + D V^LRU + Q diff --git a/r/LAB_SERVICE-LR-LS/LRAPR.m b/r/LAB_SERVICE-LR-LS/LRAPR.m index 633509e5..09797a61 100644 --- a/r/LAB_SERVICE-LR-LS/LRAPR.m +++ b/r/LAB_SERVICE-LR-LS/LRAPR.m @@ -1,299 +1,292 @@ -LRAPR ;DALOI/REG/WTY/KLL/CKA - ANAT RELEASE REPORTS ;10/30/01 - ;;5.2;LAB SERVICE;**72,248,259,317,365**;Sep 27, 1994;Build 9 - ; - N LRESSW - D SWITCH - I +LRESSW D Q - .D ^LRAPRES - .D END - W !!?27,"Release Pathology Reports",!! - D A - I '$D(LRSS) D END Q - I LRCAPA D G:'$D(X) END - .S X=$S(LRSS="CY":"CYTOLOGY REPORTING",LRSS="SP":"SURGICAL PATH REPORTING",1:"") - .D:X]"" X^LRUWK - I LRSS="AU" D B Q - S LRSOP="Z" - S DR="S A=^LR(LRDFN,LRSS,LRI,0),LRZ=$P(A,U,3),LRZ(1)=$P(A,U,13)," - S DR=DR_"LRZ(2)=$P(A,U,11),LRZ(3)=$P(A,U,2);" - S DR=DR_"I 'LRZ W $C(7),!,""No date report completed. " - S DR=DR_"Cannot release."" S Y=0;" - S DR=DR_"I 'LRZ(2) D NMPATH^LRAPR;" - S DR=DR_"I LRZ(2) D RINFO^LRAPR S Y=0;" - ;Perform supp edit regardless if date rept released since supp rpt - ; is added to released report - S DR=DR_"D SUPCHK^LRAPR;" - S DR=DR_"S DIR(0)=""YA"",DIR(""A"")=""Release report? """ - S DR=DR_",DIR(""B"")=""NO"" D ^DIR K:Y Y S:$D(Y) Y=0;" - S DR=DR_".11////^D NOW^%DTC S X=%;.13////^S X=DUZ;" - S DR=DR_"S LRELSD=1 W !!,""Report released...""" - D ^LRAPDA - D END - Q - ; -B ;Autopsy - S LRSOP="Z" - S DR="S A=$G(^LR(LRDFN,""AU"")) I A="""" S Y=0;" - S DR=DR_"S LRZ=$P(A,U,3),LRZ(1)=$P(A,U,16),LRZ(2)=$P(A,U,15)," - ;KLL-LRZ(3)=SR PATHOLOGIST,LRZ(4)=PROVISIONAL DATE - S DR=DR_"LRZ(3)=$P(A,U,10),LRZ(4)=$P(A,U,17);" - ;KLL-PROVISIONAL OR DATE REPORT COMPLETED IS REQUIRED - S DR=DR_"I 'LRZ(4),'LRZ W $C(7),!,""Provisional date or date report completed required. " - S DR=DR_"Cannot release."" S Y=0;" - S DR=DR_"I 'LRZ(2) D NMPATH^LRAPR;" - S DR=DR_"I LRZ(2) D RINFO^LRAPR S Y=0;" - ;Perform supp edit regardless if date rept released since supp rpt - ; is added to released report - S DR=DR_"D SUPCHK^LRAPR;" - S DR=DR_"D RELEASE^LRAPR;" - S DR=DR_"D NOW^%DTC S LRDTE=%;" - S DR=DR_"14.7////^S X=$S(LRZ(2):""@"",1:LRDTE);" - S DR=DR_"14.8////^S X=$S(LRZ(2):""@"",1:DUZ);" - S DR=DR_"S:'LRZ(2) LRELSD=1 " - S DR=DR_"W !!,""Report "" W:LRZ(2) ""un"" W ""released..."";K LRDTE" - D ^LRAPDA - D END - Q -EN ;Supplementary Report Entry Point - N LRESSW - D SWITCH - W !!?20,"Release Supplementary Pathology Reports",! - ;D A - ;Section prompt replaces the line above - S LRQUIT=0 - D SECTION^LRAPRES - I '$D(LRSS) D END Q - ;Verify User ID has access to release supp. reports - S LREND=0 - I LRESSW D CLSSCHK^LRAPRES1(DUZ,.LREND) - Q:LREND - ; - W !!,"Data entry for ",LRH(0)," " - S %=1 D YN^LRU G:%<1 END - I %=2 D G:Y<1 END - .S %DT="AE",%DT(0)="-N",%DT("A")="Enter YEAR: " D ^%DT K %DT - .Q:Y<1 S LRAD=$E(Y,1,3)_"0000",LRH(0)=$E(Y,1,3)+1700 - I '$D(^LRO(68,LRAA,1,LRAD,0)) D Q - .W $C(7),!!,"NO ",LRAA(1)," ACCESIONS IN FILE FOR ",LRH(0),!! -W K X,Y,LR("CK") R !!,"Select Accession Number/Pt name: ",LRAN:DTIME - G:LRAN=""!(LRAN[U) END - I LRAN'?1N.N D G:LRAN<1 END G W - .D PNAME^LRAPDA - .Q:LRAN<1 - .D DIE - D REST - G W -REST W " for ",LRH(0) - I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) D Q - .W $C(7),!!,"Accession # ",LRAN," for ",LRH(0) - .W " not in ACCESSION file",!! - S X=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRLLOC=$P(X,"^",7),LRDFN=+X - Q:'$D(^LR(LRDFN,0)) S X=^(0) D ^LRUP - W !,LRP," ID: ",SSN - I LRSS'="AU" D - .S LRI=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),"^",5) - .W !,"Specimen(s):" - .S X=0 F S X=$O(^LR(LRDFN,LRSS,LRI,.1,X)) Q:'X D - ..I $D(^LR(LRDFN,LRSS,LRI,.1,X,0)),$L(^(0)) W !,^(0) -DIE ;Define default supplementary report - N LRFILE,LRIENS,LRIENS1,LRX,LRRLS,LRFDA,LRLKFL,LRDA,LRQUIT,LRNOSP - N LRMSG,LRSRFL,LRFDA2,LRSRMD,LRRLM - S DIC("B")="",LRNOSP=0 - I LRSS'="AU" D - .S LRFILE=+$$GET1^DID(LRSF,1.2,"","SPECIFIER") - .S LRIENS1=LRI_","_LRDFN_"," - .I '+$P($G(^LR(LRDFN,LRSS,LRI,1.2,0)),"^",4) S LRNOSP=1 Q - .S LRX=0 F S LRX=$O(^LR(LRDFN,LRSS,LRI,1.2,LRX)) Q:'LRX D - ..S LRIENS=LRX_","_LRIENS1 - ..S LRSRFL=$$GET1^DIQ(LRFILE,LRIENS,.02,"I") - ..;LRSRMD-set to 1 if supp rpt modified and requires release - ..S LRSRMD=$$GET1^DIQ(LRFILE,LRIENS,.03,"I") - ..Q:LRSRFL&('LRSRMD) - ..S DIC("B")=$$GET1^DIQ(LRFILE,LRIENS,.01,"I") - I LRSS="AU" D - .S LRFILE=63.324,LRIENS1=LRDFN_"," - .I '+$P($G(^LR(LRDFN,84,0)),"^",4) S LRNOSP=1 Q - .S LRX=0 F S LRX=$O(^LR(LRDFN,84,LRX)) Q:'LRX D - ..S LRIENS=LRX_","_LRIENS1 - ..S LRSRFL=$$GET1^DIQ(LRFILE,LRIENS,.02,"I") - ..;LRSRMD-set to 1 if supp rpt modified and requires release - ..S LRSRMD=$$GET1^DIQ(LRFILE,LRIENS,.03,"I") - ..Q:LRSRFL&('LRSRMD) - ..S DIC("B")=$$GET1^DIQ(LRFILE,LRIENS,.01,"I") - I LRNOSP D Q - .K LRMSG - .S LRMSG=$C(7)_"No supplementary reports exist for this accession." - .D EN^DDIOL(LRMSG,"","!!") - I 'DIC("B") D Q - .K LRMSG - .S LRMSG=$C(7)_"All supplementary reports have been released." - .D EN^DDIOL(LRMSG,"","!!") -DIE1 ; - S (LRQUIT,LRRLM)=0 - F D Q:LRQUIT - .W ! - .S:LRSS="AU" (LRLKFL,DIC)="^LR(LRDFN,84," - .S:LRSS'="AU" (LRLKFL,DIC)="^LR(LRDFN,LRSS,LRI,1.2," - .S DIC("A")="Select SUPPLEMENTARY REPORT DATE: " - .S DIC(0)="AEQM" - .D ^DIC K DIC - .I Y<1 S LRQUIT=1 Q - .S LRDA=+Y - .S LRIENS=LRDA_","_LRIENS1 - .S LRRLS=+$$GET1^DIQ(LRFILE,LRIENS,.02,"I") - .;If E-Sign OFF, must check LRRLM. LRRLM=1 if supp rpt has been - .; modified and requires release - .S LRRLM=+$$GET1^DIQ(LRFILE,LRIENS,.03,"I") - .I LRESSW,LRRLS D Q - ..W !!,"This supplementary report has already been released.",! - .I 'LRESSW,LRRLS D Q:'LRRLM - ..I 'LRRLM W !!,"This supplementary rept has already been released.",! - .W ! - .I LRESSW D Q - ..D ESIG Q:LRQUIT - ..D UPDATE - .S DIR("A")="Release supplementary report",DIR(0)="Y",DIR("B")="NO" - .D ^DIR K DIR - .Q:'Y - .D UPDATE - .;If E-sign switch OFF and orig report released, must verify all - .; supp reports released before release main report. - .I LRCKREL,'LRESSW D CHKSUP^LRAPR1 - Q - ; -A D ^LRAP G:'$D(Y) END - Q -C ; - S LRDICS="SPCYEM" D ^LRAP - G:'$D(Y) END - Q -S ;from LRAPDA - S LRK=$P(^LR(LRDFN,LRSS,LRI,0),"^",11) Q:'LRK S:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0)) ^(0)="^68.04PA^^" - Q:$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0)) S ^(0)=LRT_"^50^^"_DUZ_"^"_LRK,X=^LRO(68,LRAA,1,LRAD,1,LRAN,4,0),^(0)=$P(X,"^",1,2)_"^"_LRT_"^"_($P(X,"^",4)+1) - S:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,0)) ^(0)="^68.14P^^" - S C=0 F S C=$O(LRT(C)) Q:'C D CAP - S ^LRO(68,"AA",LRAA_"|"_LRAD_"|"_LRAN_"|"_LRT)="" - Q - ; -CAP S ^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,C,0)=C_"^1^0^0^^"_LRK_"^"_DUZ_"^"_DUZ(2)_"^"_LRAA_"^"_LRAA_"^"_LRAA - S X=^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,0),^(0)=$P(X,"^",1,2)_"^"_C_"^"_($P(X,"^",4)+1) - Q - ; -SWITCH ;Check to see if electronic signature is enabled - D GETDATA^LRAPESON(.LRESSW) - Q -ESIG ;Prompt for electronic signature - S LRQUIT=0 - D SIG^XUSESIG - I X1="" D - .W " SIGNATURE NOT VERIFIED" - .S LRQUIT=1 - Q -UPDATE ; - S LRLKFL=LRLKFL_LRDA_",0)" - L +@(LRLKFL):5 I '$T D Q - .S LRMSG="This record is locked by another user. " - .S LRMSG=LRMSG_"Please wait and try again." - .D EN^DDIOL(LRMSG,"","!!") - S LRFDA(LRFILE,LRIENS,.02)=1 - S LRFDA2(LRFILE,LRIENS,.02)="@" ;Set but don't file unless unrel needed - ;File signer ID and Date/time of released supp report - D CKSIGNR^LRAPR1 - D FILE^DIE("","LRFDA") - W "...Released" - L -@(LRLKFL) - I LRSS="AU" D - .S LRA=^LR(LRDFN,"AU") - .S LRAC=$$GET1^DIQ(63,LRDFN_",",14,"I") - .S LRI=$P(LRA,U) - I LRSS'="AU" D - .S LRA=^LR(LRDFN,LRSS,LRI,0) - .S LRAC=$$GET1^DIQ(LRSF,LRIENS,.06,"I") - D MAIN^LRAPRES1(LRDFN,LRSS,LRI,LRSF,LRP,LRAC) - ;If all supp reports released, and E-Sign switch is ON, proceed to - ; release main report - S LRCKREL=0 - S:LRSS'="AU" LRCKREL=$P(^LR(LRDFN,LRSS,LRI,0),"^",11) - S:LRSS="AU" LRCKREL=$P(^LR(LRDFN,LRSS),"^",15) - I LRCKREL,LRESSW D RELMN - Q -SUPCHK ;Check for unreleased supplementary reports - N LRSR,LRSR1,LRSR2 - S LRSR=0,LRSR1=1 - I LRSS'="AU" D - .Q:'+$P($G(^LR(LRDFN,LRSS,LRI,1.2,0)),U,4) - .F S LRSR=$O(^LR(LRDFN,LRSS,LRI,1.2,LRSR)) Q:LRSR'>0!('LRSR1) D - ..S LRSR1=+$P(^LR(LRDFN,LRSS,LRI,1.2,LRSR,0),U,2) - ..I 'LRSR1 D - ...S Y=+$P(^LR(LRDFN,LRSS,LRI,1.2,LRSR,0),U) - ...D DD^%DT S LRSR2=Y - I LRSS="AU" D - .Q:'+$P($G(^LR(LRDFN,84,0)),U,4) - .F S LRSR=$O(^LR(LRDFN,84,LRSR)) Q:LRSR'>0!('LRSR1) D - ..S LRSR1=+$P(^LR(LRDFN,84,LRSR,0),U,2) - ..I 'LRSR1 D - ...S Y=+$P(^LR(LRDFN,84,LRSR,0),U) - ...D DD^%DT S LRSR2=Y - I 'LRSR1 D - .W $C(7),!,"Supplementary report "_LRSR2_" has not been released. " - .W "Cannot release." - .S Y=0 - Q -RINFO ;Display release information - W $C(7),!,"Report " - W:LRZ(2)=1 "has already been " - W "released " - S Y=LRZ(2) - D DD^%DT - W:LRZ(2)>1 Y - W:LRZ(1)'="" " by "_$P($G(^VA(200,LRZ(1),0)),U) - K Y - Q -NMPATH ;Check for missing pathologist name - I 'LRZ(3) D - .W $C(7),!,"Pathologist name missing. Cannot release." - .S Y=0 - Q -RELEASE ;Prompt for release/unrelease - W ! S DIR(0)="YA",DIR("B")="NO" - S:LRZ(2) DIR("A")="Unrelease report? " - S:'LRZ(2) DIR("A")="Release report? " - D ^DIR - K:Y Y - I $D(Y) S Y=0 - Q -RELMN ;Allow release of main report as long as all supp reports are - ; released, and signer is same person for main and supp report(s) - ;Make sure all supp reports signed out - S LRQT=0 - D RELCHK^LRAPR1 - Q:LRQT - ; - ;Continue with electronic signature and storage in TIU - S LRAU=$S(LRSS="AU":1,1:0) - I 'LRAU D - .S LRPAT=+$$GET1^DIQ(LRSF,LRIENS1,.02,"I") - .S LRZ=$$GET1^DIQ(LRSF,LRIENS1,.03,"I") - .S LRZ(1)=$$GET1^DIQ(LRSF,LRIENS1,.13,"I") - .S LRZ(1.1)=$$GET1^DIQ(LRSF,LRIENS1,.13) - .S LRZ(2)=$$GET1^DIQ(LRSF,LRIENS1,.11,"I") - I LRAU D - .S LRPAT=+$$GET1^DIQ(63,LRDFN_",",13.6,"I") - .S LRZ=$$GET1^DIQ(63,LRDFN_",",13,"I") - .S LRZ(1)=$$GET1^DIQ(63,LRDFN_",",14.8,"I") - .S LRZ(1.1)=$$GET1^DIQ(63,LRDFN_",",14.8) - .S LRZ(2)=$$GET1^DIQ(63,LRDFN_",",14.7,"I") - W !!,?25,"*** Main Report Release ***",! - D NOW^%DTC S LRNTIME=% - D TIUPREP^LRAPRES - D STORE^LRAPRES - I LRQUIT D FILE^DIE("","LRFDA2") Q - D UNRLSE^LRAPR1 - D RELEASE^LRAPRES - I LRQUIT D FILE^DIE("","LRFDA2") Q - D OERR^LR7OB63D - S LRQUIT=1 - Q -END ; - D V^LRU - Q +LRAPR ;AVAMC/REG/WTY/KLL- ANAT RELEASE REPORTS ;10/30/01 + ;;5.2;LAB SERVICE;**72,248,259,317**;Sep 27, 1994 + ; + N LRESSW + D SWITCH + I +LRESSW D Q + .D ^LRAPRES + .D END + W !!?27,"Release Pathology Reports",!! + D A + I '$D(LRSS) D END Q + I LRCAPA D G:'$D(X) END + .S X=$S(LRSS="CY":"CYTOLOGY REPORTING",LRSS="SP":"SURGICAL PATH REPORTING",1:"") + .D:X]"" X^LRUWK + I LRSS="AU" D B Q + S LRSOP="Z" + S DR="S A=^LR(LRDFN,LRSS,LRI,0),LRZ=$P(A,U,3),LRZ(1)=$P(A,U,13)," + S DR=DR_"LRZ(2)=$P(A,U,11),LRZ(3)=$P(A,U,2);" + S DR=DR_"I 'LRZ W $C(7),!,""No date report completed. " + S DR=DR_"Cannot release."" S Y=0;" + S DR=DR_"I 'LRZ(2) D NMPATH^LRAPR;" + S DR=DR_"I LRZ(2) D RINFO^LRAPR S Y=0;" + ;Perform supp edit regardless if date rept released since supp rpt + ; is added to released report + S DR=DR_"D SUPCHK^LRAPR;" + S DR=DR_"S DIR(0)=""YA"",DIR(""A"")=""Release report? """ + S DR=DR_",DIR(""B"")=""NO"" D ^DIR K:Y Y S:$D(Y) Y=0;" + S DR=DR_".11////^D NOW^%DTC S X=%;.13////^S X=DUZ;" + S DR=DR_"W !!,""Report released...""" + D ^LRAPDA + D END + Q + ; +B ;Autopsy + S LRSOP="Z" + S DR="S A=$G(^LR(LRDFN,""AU"")) I A="""" S Y=0;" + S DR=DR_"S LRZ=$P(A,U,3),LRZ(1)=$P(A,U,16),LRZ(2)=$P(A,U,15)," + ;KLL-LRZ(3)=SR PATHOLOGIST,LRZ(4)=PROVISIONAL DATE + S DR=DR_"LRZ(3)=$P(A,U,10),LRZ(4)=$P(A,U,17);" + ;KLL-PROVISIONAL OR DATE REPORT COMPLETED IS REQUIRED + S DR=DR_"I 'LRZ(4),'LRZ W $C(7),!,""Provisional date or date report completed required. " + S DR=DR_"Cannot release."" S Y=0;" + S DR=DR_"I 'LRZ(2) D NMPATH^LRAPR;" + S DR=DR_"I LRZ(2) D RINFO^LRAPR S Y=0;" + ;Perform supp edit regardless if date rept released since supp rpt + ; is added to released report + S DR=DR_"D SUPCHK^LRAPR;" + S DR=DR_"D RELEASE^LRAPR;" + S DR=DR_"D NOW^%DTC S LRDTE=%;" + S DR=DR_"14.7////^S X=$S(LRZ(2):""@"",1:LRDTE);" + S DR=DR_"14.8////^S X=$S(LRZ(2):""@"",1:DUZ);" + S DR=DR_"W !!,""Report "" W:LRZ(2) ""un"" W ""released..."";K LRDTE" + D ^LRAPDA + D END + Q +EN ;Supplementary Report Entry Point + N LRESSW + D SWITCH + W !!?20,"Release Supplementary Pathology Reports",! + ;D A + ;Section prompt replaces the line above + S LRQUIT=0 + D SECTION^LRAPRES + I '$D(LRSS) D END Q + ;Verify User ID has access to release supp. reports + S LREND=0 + I LRESSW D CLSSCHK^LRAPRES1(DUZ,.LREND) + Q:LREND + ; + W !!,"Data entry for ",LRH(0)," " + S %=1 D YN^LRU G:%<1 END + I %=2 D G:Y<1 END + .S %DT="AE",%DT(0)="-N",%DT("A")="Enter YEAR: " D ^%DT K %DT + .Q:Y<1 S LRAD=$E(Y,1,3)_"0000",LRH(0)=$E(Y,1,3)+1700 + I '$D(^LRO(68,LRAA,1,LRAD,0)) D Q + .W $C(7),!!,"NO ",LRAA(1)," ACCESIONS IN FILE FOR ",LRH(0),!! +W K X,Y,LR("CK") R !!,"Select Accession Number/Pt name: ",LRAN:DTIME + G:LRAN=""!(LRAN[U) END + I LRAN'?1N.N D G:LRAN<1 END G W + .D PNAME^LRAPDA + .Q:LRAN<1 + .D DIE + D REST + G W +REST W " for ",LRH(0) + I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) D Q + .W $C(7),!!,"Accession # ",LRAN," for ",LRH(0) + .W " not in ACCESSION file",!! + S X=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRLLOC=$P(X,"^",7),LRDFN=+X + Q:'$D(^LR(LRDFN,0)) S X=^(0) D ^LRUP + W !,LRP," ID: ",SSN + I LRSS'="AU" D + .S LRI=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),"^",5) + .W !,"Specimen(s):" + .S X=0 F S X=$O(^LR(LRDFN,LRSS,LRI,.1,X)) Q:'X D + ..I $D(^LR(LRDFN,LRSS,LRI,.1,X,0)),$L(^(0)) W !,^(0) +DIE ;Define default supplementary report + N LRFILE,LRIENS,LRIENS1,LRX,LRRLS,LRFDA,LRLKFL,LRDA,LRQUIT,LRNOSP + N LRMSG,LRSRFL,LRFDA2,LRSRMD,LRRLM + S DIC("B")="",LRNOSP=0 + I LRSS'="AU" D + .S LRFILE=+$$GET1^DID(LRSF,1.2,"","SPECIFIER") + .S LRIENS1=LRI_","_LRDFN_"," + .I '+$P($G(^LR(LRDFN,LRSS,LRI,1.2,0)),"^",4) S LRNOSP=1 Q + .S LRX=0 F S LRX=$O(^LR(LRDFN,LRSS,LRI,1.2,LRX)) Q:'LRX D + ..S LRIENS=LRX_","_LRIENS1 + ..S LRSRFL=$$GET1^DIQ(LRFILE,LRIENS,.02,"I") + ..;LRSRMD-set to 1 if supp rpt modified and requires release + ..S LRSRMD=$$GET1^DIQ(LRFILE,LRIENS,.03,"I") + ..Q:LRSRFL&('LRSRMD) + ..S DIC("B")=$$GET1^DIQ(LRFILE,LRIENS,.01,"I") + I LRSS="AU" D + .S LRFILE=63.324,LRIENS1=LRDFN_"," + .I '+$P($G(^LR(LRDFN,84,0)),"^",4) S LRNOSP=1 Q + .S LRX=0 F S LRX=$O(^LR(LRDFN,84,LRX)) Q:'LRX D + ..S LRIENS=LRX_","_LRIENS1 + ..S LRSRFL=$$GET1^DIQ(LRFILE,LRIENS,.02,"I") + ..;LRSRMD-set to 1 if supp rpt modified and requires release + ..S LRSRMD=$$GET1^DIQ(LRFILE,LRIENS,.03,"I") + ..Q:LRSRFL&('LRSRMD) + ..S DIC("B")=$$GET1^DIQ(LRFILE,LRIENS,.01,"I") + I LRNOSP D Q + .K LRMSG + .S LRMSG=$C(7)_"No supplementary reports exist for this accession." + .D EN^DDIOL(LRMSG,"","!!") + I 'DIC("B") D Q + .K LRMSG + .S LRMSG=$C(7)_"All supplementary reports have been released." + .D EN^DDIOL(LRMSG,"","!!") +DIE1 ; + S (LRQUIT,LRRLM)=0 + F D Q:LRQUIT + .W ! + .S:LRSS="AU" (LRLKFL,DIC)="^LR(LRDFN,84," + .S:LRSS'="AU" (LRLKFL,DIC)="^LR(LRDFN,LRSS,LRI,1.2," + .S DIC("A")="Select SUPPLEMENTARY REPORT DATE: " + .S DIC(0)="AEQM" + .D ^DIC K DIC + .I Y<1 S LRQUIT=1 Q + .S LRDA=+Y + .S LRIENS=LRDA_","_LRIENS1 + .S LRRLS=+$$GET1^DIQ(LRFILE,LRIENS,.02,"I") + .;If E-Sign OFF, must check LRRLM. LRRLM=1 if supp rpt has been + .; modified and requires release + .S LRRLM=+$$GET1^DIQ(LRFILE,LRIENS,.03,"I") + .I LRESSW,LRRLS D Q + ..W !!,"This supplementary report has already been released.",! + .I 'LRESSW,LRRLS D Q:'LRRLM + ..I 'LRRLM W !!,"This supplementary rept has already been released.",! + .W ! + .I LRESSW D Q + ..D ESIG Q:LRQUIT + ..D UPDATE + .S DIR("A")="Release supplementary report",DIR(0)="Y",DIR("B")="NO" + .D ^DIR K DIR + .Q:'Y + .D UPDATE + .;If E-sign switch OFF and orig report released, must verify all + .; supp reports released before release main report. + .I LRCKREL,'LRESSW D CHKSUP^LRAPR1 + Q + ; +A D ^LRAP G:'$D(Y) END + Q +C ; + S LRDICS="SPCYEM" D ^LRAP + G:'$D(Y) END + Q +S ;from LRAPDA + S LRK=$P(^LR(LRDFN,LRSS,LRI,0),"^",11) Q:'LRK S:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0)) ^(0)="^68.04PA^^" + Q:$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0)) S ^(0)=LRT_"^50^^"_DUZ_"^"_LRK,X=^LRO(68,LRAA,1,LRAD,1,LRAN,4,0),^(0)=$P(X,"^",1,2)_"^"_LRT_"^"_($P(X,"^",4)+1) + S:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,0)) ^(0)="^68.14P^^" + S C=0 F S C=$O(LRT(C)) Q:'C D CAP + S ^LRO(68,"AA",LRAA_"|"_LRAD_"|"_LRAN_"|"_LRT)="" + Q + ; +CAP S ^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,C,0)=C_"^1^0^0^^"_LRK_"^"_DUZ_"^"_DUZ(2)_"^"_LRAA_"^"_LRAA_"^"_LRAA + S X=^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,0),^(0)=$P(X,"^",1,2)_"^"_C_"^"_($P(X,"^",4)+1) + Q + ; +SWITCH ;Check to see if electronic signature is enabled + D GETDATA^LRAPESON(.LRESSW) + Q +ESIG ;Prompt for electronic signature + S LRQUIT=0 + D SIG^XUSESIG + I X1="" D + .W " SIGNATURE NOT VERIFIED" + .S LRQUIT=1 + Q +UPDATE ; + S LRLKFL=LRLKFL_LRDA_",0)" + L +@(LRLKFL):5 I '$T D Q + .S LRMSG="This record is locked by another user. " + .S LRMSG=LRMSG_"Please wait and try again." + .D EN^DDIOL(LRMSG,"","!!") + S LRFDA(LRFILE,LRIENS,.02)=1 + S LRFDA2(LRFILE,LRIENS,.02)="@" ;Set but don't file unless unrel needed + ;File signer ID and Date/time of released supp report + D CKSIGNR^LRAPR1 + D FILE^DIE("","LRFDA") + W "...Released" + L -@(LRLKFL) + ;If all supp reports released, and E-Sign switch is ON, proceed to + ; release main report + S LRCKREL=0 + S:LRSS'="AU" LRCKREL=$P(^LR(LRDFN,LRSS,LRI,0),"^",11) + S:LRSS="AU" LRCKREL=$P(^LR(LRDFN,LRSS),"^",15) + I LRCKREL,LRESSW D RELMN + Q +SUPCHK ;Check for unreleased supplementary reports + N LRSR,LRSR1,LRSR2 + S LRSR=0,LRSR1=1 + I LRSS'="AU" D + .Q:'+$P($G(^LR(LRDFN,LRSS,LRI,1.2,0)),U,4) + .F S LRSR=$O(^LR(LRDFN,LRSS,LRI,1.2,LRSR)) Q:LRSR'>0!('LRSR1) D + ..S LRSR1=+$P(^LR(LRDFN,LRSS,LRI,1.2,LRSR,0),U,2) + ..I 'LRSR1 D + ...S Y=+$P(^LR(LRDFN,LRSS,LRI,1.2,LRSR,0),U) + ...D DD^%DT S LRSR2=Y + I LRSS="AU" D + .Q:'+$P($G(^LR(LRDFN,84,0)),U,4) + .F S LRSR=$O(^LR(LRDFN,84,LRSR)) Q:LRSR'>0!('LRSR1) D + ..S LRSR1=+$P(^LR(LRDFN,84,LRSR,0),U,2) + ..I 'LRSR1 D + ...S Y=+$P(^LR(LRDFN,84,LRSR,0),U) + ...D DD^%DT S LRSR2=Y + I 'LRSR1 D + .W $C(7),!,"Supplementary report "_LRSR2_" has not been released. " + .W "Cannot release." + .S Y=0 + Q +RINFO ;Display release information + W $C(7),!,"Report " + W:LRZ(2)=1 "has already been " + W "released " + S Y=LRZ(2) + D DD^%DT + W:LRZ(2)>1 Y + W:LRZ(1)'="" " by "_$P($G(^VA(200,LRZ(1),0)),U) + K Y + Q +NMPATH ;Check for missing pathologist name + I 'LRZ(3) D + .W $C(7),!,"Pathologist name missing. Cannot release." + .S Y=0 + Q +RELEASE ;Prompt for release/unrelease + W ! S DIR(0)="YA",DIR("B")="NO" + S:LRZ(2) DIR("A")="Unrelease report? " + S:'LRZ(2) DIR("A")="Release report? " + D ^DIR + K:Y Y + I $D(Y) S Y=0 + Q +RELMN ;Allow release of main report as long as all supp reports are + ; released, and signer is same person for main and supp report(s) + ;Make sure all supp reports signed out + S LRQT=0 + D RELCHK^LRAPR1 + Q:LRQT + ; + ;Continue with electronic signature and storage in TIU + S LRAU=$S(LRSS="AU":1,1:0) + I 'LRAU D + .S LRPAT=+$$GET1^DIQ(LRSF,LRIENS1,.02,"I") + .S LRZ=$$GET1^DIQ(LRSF,LRIENS1,.03,"I") + .S LRZ(1)=$$GET1^DIQ(LRSF,LRIENS1,.13,"I") + .S LRZ(1.1)=$$GET1^DIQ(LRSF,LRIENS1,.13) + .S LRZ(2)=$$GET1^DIQ(LRSF,LRIENS1,.11,"I") + I LRAU D + .S LRPAT=+$$GET1^DIQ(63,LRDFN_",",13.6,"I") + .S LRZ=$$GET1^DIQ(63,LRDFN_",",13,"I") + .S LRZ(1)=$$GET1^DIQ(63,LRDFN_",",14.8,"I") + .S LRZ(1.1)=$$GET1^DIQ(63,LRDFN_",",14.8) + .S LRZ(2)=$$GET1^DIQ(63,LRDFN_",",14.7,"I") + .S LRI="" + W !!,?25,"*** Main Report Release ***",! + D NOW^%DTC S LRNTIME=% + D TIUPREP^LRAPRES + D STORE^LRAPRES + I LRQUIT D FILE^DIE("","LRFDA2") Q + D UNRLSE^LRAPR1 + D RELEASE^LRAPRES + I LRQUIT D FILE^DIE("","LRFDA2") Q + D MAIN^LRAPRES1(LRDFN,LRSS,LRI,LRSF,LRP,LRAC) + D OERR^LR7OB63D + S LRQUIT=1 + Q +END ; + D V^LRU + Q diff --git a/r/LAB_SERVICE-LR-LS/LRAPRES1.m b/r/LAB_SERVICE-LR-LS/LRAPRES1.m index 0cdd3418..d350f0fd 100644 --- a/r/LAB_SERVICE-LR-LS/LRAPRES1.m +++ b/r/LAB_SERVICE-LR-LS/LRAPRES1.m @@ -1,190 +1,190 @@ -LRAPRES1 ;DALOI/WTY/KLL/CKA - AP ESIG RELEASE REPORT/ALERT;11/13/01 - ;;5.2;LAB SERVICE;**259,336,369,365**;Sep 27, 1994;Build 9 - ; - ;Reference to FILE^TIUSRVP supported by IA #3540 - ;Reference to ^TIULQ supported by IA #2693 - ;Reference to ^ORB3LAB supported by IA #4287 - ;Reference to DIC lookup on MAIL GROUP file (#3.8) supported by IA #10111 - ; -MAIN(LRDFN,LRSS,LRI,LRSF,LRP,LRAC) ;Main subroutine - Q:'$D(LRDFN)!('$D(LRSS))!('$D(LRP))!('$D(LRAC)) - N LRDOCS,LRMSG,LRC,LRDOCSN,LRNUM,LRADL,LRMORE,LRQUIT,LRXQA - N DIR,DIRUT,DTOUT,DUOUT,X,Y,DIC,XQA,XQAMSG - S LRQUIT=0 - I $G(LRAU) D - .S LRA=^LR(LRDFN,"AU") - .S LRI=$P(LRA,U) - D DOCS - Q:LRQUIT - D MORE - I LRMORE D LOOKUP - D SEND - Q -DOCS ;GET ORDERING PROVIDER AND PCP TO SEND ALERT - W ! - S:$G(LRSF)="" LRSF=63 - D GETDOCS^LRAPUTL(.LRDOCS,LRDFN,LRSS,$G(LRI),LRSF) - S:LRDOCS(1)=LRDOCS(2) LRDOCS(2)=0 - F LRC=1:1:2 D - .I LRDOCS(LRC) D - ..S LRDOCSN(LRC)=$$NAME^XUSER(LRDOCS(LRC),"F") - ..I LRDOCSN(LRC)'="" S LRXQA(LRDOCS(LRC))="" - S LRNUM=1 - K LRMSG - D - .S LRMSG(LRNUM)="Alert will be sent to:",LRMSG(LRNUM,"F")="!!" - .I LRDOCS(1) D - ..S LRNUM=LRNUM+1,LRMSG(LRNUM)=LRDOCSN(1),LRMSG(LRNUM,"F")="?24" - .I LRDOCS(2) D - ..S LRNUM=LRNUM+1,LRMSG(LRNUM)=LRDOCSN(2) - ..S LRMSG(LRNUM,"F")=$S(LRDOCS(1):"!",1:"")_"?24" - I LRQUIT D - .S LRMSG(LRNUM)="No Ordering Provider or PCP for alert" - .S LRMSG(LRNUM,"F")="!!" - D EN^DDIOL(.LRMSG) - Q -MORE ;Add names or mail groups to the lookup list? - N DIR,DIRUT,DTOUT,DUOUT,X,Y - W ! - S LRMORE=1 - S DIR(0)="Y" - S DIR("A")="Send the alert to additional names or mail groups" - S X=$$GET^XPAR("USR^DIV^PKG","LRAPRES1 AP ALERT",1,"Q") - S X=$S(X=1:"YES",X=0:"NO",1:"NO") - S DIR("B")=X - D ^DIR - I Y=0 S LRMORE=0 Q - I $D(DUOUT)!($D(DTOUT)) S LRQUIT=1,LRMORE=0 - Q -LOOKUP ;Add additional names or mail groups to alert list. - F D Q:LRQUIT - .W ! - .K DIR - .;S DIR(0)="F^3:30^I X'?1""U."".E&(X'?1""G."".E) K X" - .S DIR(0)="FO^3:30^I X["".""&((X'?1""G."".E)&(X'?1""g."".E)) K X" - .S DIR("A")="Enter name or mail group" - .S DIR("?")="Enter lastname,firstname OR G.mailgroup OR ^ to exit" - .D ^DIR - .I $D(DIRUT) S LRQUIT=1 Q - .S X=Y,LRADL="" - .I Y["." S LRADL=$P(Y,"."),X=$P(Y,".",2) - .S Y=$$UP^XLFSTR(Y) - .I LRADL="g" S LRADL="G" - .K DIC - .S DIC(0)="QEZ" - .S DIC=$S(LRADL="G":3.8,1:200) - .D ^DIC - .Q:Y=-1 - .S:LRADL="" XQA($P(Y,"^"))="" - .S:LRADL="G" XQA("G."_$P(Y,"^",2))="" - Q -SEND ;Send the alert - ;S XQAMSG=$E(LRP,1,9)_" ("_$E(LRP,1)_VA("BID")_"): Pathology report signed for "_LRAC_"." - ;D SETUP^XQALERT - M XQA=LRXQA - D LAB^ORB3LAB(DFN,LRDFN,LRI,$G(LRA),LRSS,.XQA) - I $D(LRADL) D - .S LRMSG="Alerts have been sent to the specified additional users." - .D EN^DDIOL(LRMSG,"","!!") - .K LRMSG - Q -AHELP ;Help Frame - K LRMSG - S LRMSG(1)="If answered 'Yes', the alert will notify the primary care" - S LRMSG(1,"F")="!" - S LRMSG(2)="provider and the surgeon/physician that this report has" - S LRMSG(3)="been electronically signed and is now available for" - S LRMSG(4)="viewing. You will also have the opportunity to send the" - S LRMSG(5)="alert to additional names or mail groups." - D EN^DDIOL(.LRMSG) - Q -RETRACT(LRDFN,LRSS,LRI,LRTIUPTR) ; - ;Change prior TIU versions of report to RETRACTED status - N LRROOT,LRIENS,LRFILE,LRTIUP,LRTIUAR,LRERR,LRSTAT,LRTIUX,LREXRR - I LRSS=""!("AUSPEMCY"'[LRSS) S LRPTR=0 Q - I LRSS="AU" D - .S LRROOT="^LR(LRDFN,101,""C""",LRIENS=LRDFN_"," - .S LRFILE=63.101 - I LRSS'="AU" D - .S LRROOT="^LR(LRDFN,LRSS,LRI,.05,""C""" - .S LRIENS=LRI_","_LRDFN_"," - .S LRFILE=$S(LRSS="SP":63.19,LRSS="CY":63.47,LRSS="EM":63.49,1:"") - Q:'$D(@(LRROOT_")")) - S LRTIUP=0,LRTIUX(.05)=15 - F S LRTIUP=$O(@(LRROOT_",LRTIUP)")) Q:LRTIUP'>0!(LRTIUP=LRTIUPTR) D - .K LRTIUAR S (LRSTAT,LRERR)=0 - .D EXTRACT^TIULQ(LRTIUP,"LRTIUAR",.LRERR,".05",,,"I") - .Q:+LRERR - .M LRSTAT=LRTIUAR(LRTIUP,.05,"I") - .Q:LRSTAT'=7 ;Quit if current status is not COMPLETED - .D FILE^TIUSRVP(.LREXRR,LRTIUP,.LRTIUX) - .;Update new TIU version of report with previous TIU pointer value - .N LREXRR,LRTIUX - .S LRTIUX(1406)=LRTIUP - .D FILE^TIUSRVP(.LREXRR,LRTIUPTR,.LRTIUX) - Q -CLSSCHK(DUZ,LREND) ;Determine if user has the proper class settings and - ;PROVIDER key - N LRMSG,LRPRCLSS,LRPCEXP,LRVCDE,LRPCSTR,LRMTCH - ;First, check for PROVIDER key - I '$D(^XUSEC("PROVIDER",DUZ)) D Q - .K LRMSG S LRMSG=$C(7)_"Electronic signature not authorized. Missing " - .S LRMSG=LRMSG_"PROVIDER key." - .D EN^DDIOL(LRMSG,"","!!") - .K LRMSG S LREND=1 - ;Next, check the provider class - S LRPRCLSS=$$GET1^DIQ(200,DUZ_",",53.5) - ;PROVIDER CL MUST CONTAIN PHYSICIAN, OR CYTOTECH ONLY FOR CY SECTION - ;OR DENTIST FOR ORAL AND MAXILLOFACIAL PATHOLOGY - S LRMTCH=0 - I LRPRCLSS'["PHYSICIAN",LRPRCLSS'["DENTIST" D - .I LRPRCLSS'["CYTOTECH" S LRMTCH=1 - .I LRSS'="CY" S LRMTCH=1 - I LRMTCH=1 D Q - .K LRMSG - .S LRMSG(1)=$C(7)_"You are not authorized to electronically sign " - .S LRMSG(1)=LRMSG(1)_"reports." - .S LRMSG(1,"F")="!!" - .S LRMSG(2)="PROVIDER CLASS must include PHYSICIAN," - .S LRMSG(2,"F")="!" - .S LRMSG(3)=" OR CYTOTECHNOLOGIST FOR CY SECTIONS ONLY," - .S LRMSG(3,"F")="!" - .S LRMSG(4)=" OR DENTIST FOR ORAL AND MAXILLOFACIAL PATHOLOGY." - .S LRMSG(4,"F")="!" - .D EN^DDIOL(.LRMSG) K LRMSG - .S LREND=1 - ;Finally, check the person class - S LRPCSTR=$$GET^XUA4A72(DUZ) ;Supported reference #1625 - I LRPCSTR<0 D Q - .K LRMSG - .S LRMSG="PERSON CLASS is inactive or undefined. Electronic signature" - .S LRMSG=LRMSG_" is not authorized." - .D EN^DDIOL(LRMSG,"","!!") - .K LRMSG - .S LREND=1 - S LRPCEXP=+$P(LRPCSTR,"^",6) - I LRPCEXP D Q - .K LRMSG - .S LRMSG="PERSON CLASS has expired. Electronic signature" - .S LRMSG=LRMSG_" is not authorized." - .D EN^DDIOL(LRMSG,"","!!") K LRMSG - .S LREND=1 - S LRVCDE=$P(LRPCSTR,"^",7),LRMTCH=0 - ;CORRECT PERSON CLASS SHOULD MATCH PROVIDER CLASS - I LRPRCLSS["PHYSICIAN" D - .I $E(LRVCDE,1,6)="V11370","123568"[+$E(LRVCDE,7) S LRMTCH=1 - .I $E(LRVCDE,1,6)="V11371","03"[+$E(LRVCDE,7) S LRMTCH=1 - .I $E(LRVCDE,1,6)="V18240","124579"[+$E(LRVCDE,7) S LRMTCH=1 - .I LRVCDE="V182413" S LRMTCH=1 - I LRPRCLSS["CYTOTECH" D - .I LRVCDE="V150113" S LRMTCH=1 - I LRPRCLSS["DENTIST" D - .I LRVCDE="V030503" S LRMTCH=1 - I 'LRMTCH D - .K LRMSG - .S LRMSG="Invalid PERSON CLASS. Electronic Signature is not " - .S LRMSG=LRMSG_"authorized." - .D EN^DDIOL(LRMSG,"","!!") - .K LRMSG - .S LREND=1 - Q +LRAPRES1 ;DALOI/WTY/KLL - AP ESIG RELEASE REPORT/ALERT;11/13/01 + ;;5.2;LAB SERVICE;**259,336,369**;Sep 27, 1994;Build 2 + ; + ;Reference to FILE^TIUSRVP supported by IA #3540 + ;Reference to ^TIULQ supported by IA #2693 + ; +MAIN(LRDFN,LRSS,LRI,LRSF,LRP,LRAC) ;Main subroutine + Q:'$D(LRDFN)!('$D(LRSS))!('$D(LRP))!('$D(LRAC)) + N LRDOCS,LRMSG,XQA,LRC,LRDOCSN,LRNUM,LRADL,LRMORE,LRQUIT + N DIR,DIRUT,DTOUT,DUOUT,X,Y,DIC,XQA,XQAMSG + S LRQUIT=0 + D ASK + Q:LRQUIT + D MORE + Q:LRQUIT + D:LRMORE LOOKUP + D ALERT + Q +ASK ;Ask if alert is to be sent + W ! + S DIR(0)="Y",DIR("B")="NO" + S DIR("A")="Do you wish to send an alert" + S DIR("??")="^D AHELP^LRAPRES1" + D ^DIR + I 'Y S LRQUIT=1 Q + S:$G(LRSF)="" LRSF=63 + D GETDOCS^LRAPUTL(.LRDOCS,LRDFN,LRSS,$G(LRI),LRSF) + S:LRDOCS(1)=LRDOCS(2) LRDOCS(2)=0 + S LRQUIT=1 + F LRC=1:1:2 D + .I LRDOCS(LRC) D + ..S LRQUIT=0 + ..S X=LRDOCS(LRC) D D^LRUA S LRDOCSN(LRC)=X + ..I LRDOCSN(LRC)'="" S XQA(LRDOCS(LRC))="" + ;Q:LRQUIT + S LRNUM=1 + K LRMSG + I 'LRQUIT D + .S LRMSG(LRNUM)="Alert will be sent to:",LRMSG(LRNUM,"F")="!!" + .I LRDOCS(1) D + ..S LRNUM=LRNUM+1,LRMSG(LRNUM)=LRDOCSN(1),LRMSG(LRNUM,"F")="?24" + .I LRDOCS(2) D + ..S LRNUM=LRNUM+1,LRMSG(LRNUM)=LRDOCSN(2) + ..S LRMSG(LRNUM,"F")=$S(LRDOCS(1):"!",1:"")_"?24" + I LRQUIT D + .S LRMSG(LRNUM)="No Physician or PCP selected for alert" + .S LRMSG(LRNUM,"F")="!!" + .S LRQUIT=0 + D EN^DDIOL(.LRMSG) + Q +MORE ;Add names or mail groups to the lookup list? + W ! + S LRMORE=1 + S DIR(0)="Y",DIR("B")="NO" + S DIR("A")="Send the alert to additional names or mail groups" + D ^DIR + I Y=0 S LRMORE=0 Q + I $D(DUOUT)!($D(DTOUT)) S LRQUIT=1 + Q +LOOKUP ;Add additional names or mail groups to alert list. + F D Q:LRQUIT + .W ! + .K DIR + .;S DIR(0)="F^3:30^I X'?1""U."".E&(X'?1""G."".E) K X" + .S DIR(0)="F^3:30^I X["".""&(X'?1""G."".E) K X" + .S DIR("A")="Enter name or mail group" + .S DIR("?")="Enter lastname,firstname OR G.mailgroup OR ^ to exit" + .D ^DIR + .I $D(DUOUT)!($D(DTOUT)) S LRQUIT=1 Q + .S X=Y,LRADL="" + .I Y["." S LRADL=$P(Y,"."),X=$P(Y,".",2) + .K DIC + .S DIC(0)="QEZ" + .S DIC=$S(LRADL="G":3.8,1:200) + .D ^DIC + .Q:Y=-1 + .S:LRADL="" XQA($P(Y,"^"))="" + .S:LRADL="G" XQA("G."_$P(Y,"^",2))="" + .K LRMSG + .S LRMSG=$S(LRADL="G":"Mail group ",1:"User ")_$P(Y,"^",2) + .S LRMSG=LRMSG_" added to alert list." + .D EN^DDIOL(LRMSG,"","!!") + Q +ALERT ;Send the alert + S XQAMSG="Pathology report signed for "_LRAC_" - "_$E(LRP,1,30) + D SETUP^XQALERT + S LRMSG="Alerts have been sent." + D EN^DDIOL(LRMSG,"","!!") + K LRMSG + Q +AHELP ;Help Frame + K LRMSG + S LRMSG(1)="If answered 'Yes', the alert will notify the primary care" + S LRMSG(1,"F")="!" + S LRMSG(2)="provider and the surgeon/physician that this report has" + S LRMSG(3)="been electronically signed and is now available for" + S LRMSG(4)="viewing. You will also have the opportunity to send the" + S LRMSG(5)="alert to additional names or mail groups." + D EN^DDIOL(.LRMSG) + Q +RETRACT(LRDFN,LRSS,LRI,LRTIUPTR) ; + ;Change prior TIU versions of report to RETRACTED status + N LRROOT,LRIENS,LRFILE,LRTIUP,LRTIUAR,LRERR,LRSTAT,LRTIUX,LREXRR + I LRSS=""!("AUSPEMCY"'[LRSS) S LRPTR=0 Q + I LRSS="AU" D + .S LRROOT="^LR(LRDFN,101,""C""",LRIENS=LRDFN_"," + .S LRFILE=63.101 + I LRSS'="AU" D + .S LRROOT="^LR(LRDFN,LRSS,LRI,.05,""C""" + .S LRIENS=LRI_","_LRDFN_"," + .S LRFILE=$S(LRSS="SP":63.19,LRSS="CY":63.47,LRSS="EM":63.49,1:"") + Q:'$D(@(LRROOT_")")) + S LRTIUP=0,LRTIUX(.05)=15 + F S LRTIUP=$O(@(LRROOT_",LRTIUP)")) Q:LRTIUP'>0!(LRTIUP=LRTIUPTR) D + .K LRTIUAR S (LRSTAT,LRERR)=0 + .D EXTRACT^TIULQ(LRTIUP,"LRTIUAR",.LRERR,".05",,,"I") + .Q:+LRERR + .M LRSTAT=LRTIUAR(LRTIUP,.05,"I") + .Q:LRSTAT'=7 ;Quit if current status is not COMPLETED + .D FILE^TIUSRVP(.LREXRR,LRTIUP,.LRTIUX) + .;Update new TIU version of report with previous TIU pointer value + .N LREXRR,LRTIUX + .S LRTIUX(1406)=LRTIUP + .D FILE^TIUSRVP(.LREXRR,LRTIUPTR,.LRTIUX) + Q +CLSSCHK(DUZ,LREND) ;Determine if user has the proper class settings and + ;PROVIDER key + N LRMSG,LRPRCLSS,LRPCEXP,LRVCDE,LRPCSTR,LRMTCH + ;First, check for PROVIDER key + I '$D(^XUSEC("PROVIDER",DUZ)) D Q + .K LRMSG S LRMSG=$C(7)_"Electronic signature not authorized. Missing " + .S LRMSG=LRMSG_"PROVIDER key." + .D EN^DDIOL(LRMSG,"","!!") + .K LRMSG S LREND=1 + ;Next, check the provider class + S LRPRCLSS=$$GET1^DIQ(200,DUZ_",",53.5) + ;PROVIDER CL MUST CONTAIN PHYSICIAN, OR CYTOTECH ONLY FOR CY SECTION + ;OR DENTIST FOR ORAL AND MAXILLOFACIAL PATHOLOGY + S LRMTCH=0 + I LRPRCLSS'["PHYSICIAN",LRPRCLSS'["DENTIST" D + .I LRPRCLSS'["CYTOTECH" S LRMTCH=1 + .I LRSS'="CY" S LRMTCH=1 + I LRMTCH=1 D Q + .K LRMSG + .S LRMSG(1)=$C(7)_"You are not authorized to electronically sign " + .S LRMSG(1)=LRMSG(1)_"reports." + .S LRMSG(1,"F")="!!" + .S LRMSG(2)="PROVIDER CLASS must include PHYSICIAN," + .S LRMSG(2,"F")="!" + .S LRMSG(3)=" OR CYTOTECHNOLOGIST FOR CY SECTIONS ONLY," + .S LRMSG(3,"F")="!" + .S LRMSG(4)=" OR DENTIST FOR ORAL AND MAXILLOFACIAL PATHOLOGY." + .S LRMSG(4,"F")="!" + .D EN^DDIOL(.LRMSG) K LRMSG + .S LREND=1 + ;Finally, check the person class + S LRPCSTR=$$GET^XUA4A72(DUZ) ;Supported reference #1625 + I LRPCSTR<0 D Q + .K LRMSG + .S LRMSG="PERSON CLASS is inactive or undefined. Electronic signature" + .S LRMSG=LRMSG_" is not authorized." + .D EN^DDIOL(LRMSG,"","!!") + .K LRMSG + .S LREND=1 + S LRPCEXP=+$P(LRPCSTR,"^",6) + I LRPCEXP D Q + .K LRMSG + .S LRMSG="PERSON CLASS has expired. Electronic signature" + .S LRMSG=LRMSG_" is not authorized." + .D EN^DDIOL(LRMSG,"","!!") K LRMSG + .S LREND=1 + S LRVCDE=$P(LRPCSTR,"^",7),LRMTCH=0 + ;CORRECT PERSON CLASS SHOULD MATCH PROVIDER CLASS + I LRPRCLSS["PHYSICIAN" D + .I $E(LRVCDE,1,6)="V11370","123568"[+$E(LRVCDE,7) S LRMTCH=1 + .I $E(LRVCDE,1,6)="V11371","03"[+$E(LRVCDE,7) S LRMTCH=1 + .I $E(LRVCDE,1,6)="V18240","124579"[+$E(LRVCDE,7) S LRMTCH=1 + .I LRVCDE="V182413" S LRMTCH=1 + I LRPRCLSS["CYTOTECH" D + .I LRVCDE="V150113" S LRMTCH=1 + I LRPRCLSS["DENTIST" D + .I LRVCDE="V030503" S LRMTCH=1 + I 'LRMTCH D + .K LRMSG + .S LRMSG="Invalid PERSON CLASS. Electronic Signature is not " + .S LRMSG=LRMSG_"authorized." + .D EN^DDIOL(LRMSG,"","!!") + .K LRMSG + .S LREND=1 + Q diff --git a/r/LAB_SERVICE-LR-LS/LRSPT.m b/r/LAB_SERVICE-LR-LS/LRSPT.m index 92d77aff..06a0348a 100644 --- a/r/LAB_SERVICE-LR-LS/LRSPT.m +++ b/r/LAB_SERVICE-LR-LS/LRSPT.m @@ -1,83 +1,83 @@ -LRSPT ;AVAMC/REG/WTY - AP PRELIMINARY REPORTS ;10/16/01 - ;;5.2;LAB SERVICE;**1,72,248,259,373**;Sep 27, 1994;Build 1 - ; - ;Reference to ^%DT supported by IA #10003 - ;Reference to ^DPT supported by IA #918 - ;Reference to ^DIWP suppported by IA #10011 - ;Reference to ^DIWW suppported by IA #10029 - ;Reference to EN^DDIOL supported by IA #10142 - ; - S X="T",%DT="" D ^%DT,D^LRU S LRTOD=Y D EN2^LRUA - W !!,"Preliminary reports for ",LRO(68) - G END:LRAPX=2,SGL:LRAPX=3,CH:LRAPX=4 -GETP D EN1^LRUPS Q:LRAN=-1 - G:$D(^LRO(69.2,LRAA,1,LRAN,0)) GETP - L +^LRO(69.2,LRAA,1):5 I '$T D G GETP - .S MSG(1)="The preliminary reports queue is in use by another person. " - .S MSG(1,"F")="!!" - .S MSG(2)="You will need to add this accession to the queue later." - .D EN^DDIOL(.MSG) K MSG - S ^LRO(69.2,LRAA,1,LRAN,0)=LRDFN_"^"_LRI - S X=^LRO(69.2,LRAA,1,0),^(0)=$P(X,"^",1,2)_"^"_LRAN_"^"_($P(X,"^",4)+1) - L -^LRO(69.2,LRAA,1) - G GETP -CH S LRAPX(1)=1 D EN^LRSPRPT2 Q:%<1 - W !!,"Save preliminary reports for reprinting " - S %=2 D YN^LRU S:%=1 LRSAV=1 - ;Variable LR("DVD") is used to divide reports displayed in the browser - K LR("DVD") - S $P(LR("DVD"),"|",IOM)="" -DEV ; - W ! - S %ZIS="Q" D ^%ZIS - I POP W ! Q - I $D(IO("Q")) D Q - .S ZTDESC="ANAT PATH PRELIM REPORT" - .S ZTSAVE("LR*")="",ZTRTN="QUE^LRSPT" - .D ^%ZTLOAD W:$D(ZTSK) !,"Request Queued, #",ZTSK W ! - .K ZTSK,IO("Q") D HOME^%ZIS -QUE ; - U IO - ;LRSF515=1 means this is generating and SF515. - S:'$D(LRSF515) LRSF515=0 - D L^LRU,L1^LRU,S^LRU,SET^LRUA - S LR("SPSM")=1 ;Set flag to suppress printing of SNOMED codes - S LRS(5)=1,LRQ(2)=1,LRA=$S($D(^LRO(69.2,LRAA,0)):$P(^(0),U,9),1:1) - S:LRA="" LRA=1 - S LR("DIWF")=$S($P(^LRO(69.2,LRAA,0),"^",6)="D":"D",1:"")_"W" - I $D(LRAP) S LRDFN=$P(LRAP,"^"),LRI=$P(LRAP,"^",2) D D G K - S LRAN=0 F S LRAN=$O(^LRO(69.2,LRAA,1,LRAN)) Q:'LRAN!(LR("Q")) D - .S X=^LRO(69.2,LRAA,1,LRAN,0),LRDFN=+X,LRI=$P(X,"^",2) D D - .W:IOST["BROWSER" !!,LR("DVD") -K K:'$D(LRSAV) ^LRO(69.2,LRAA,1) K P,S,LRAN - S ^LRO(69.2,LRAA,1,0)="^69.21A^^" - I 'LR("Q"),$D(LR("F")),IOST?1"C".E D CONT - K LRSAV - W:IOST?1"P-".E @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" - K %,DIR,DTOUT,DUOUT,DIRUT,X,Y - Q -D K ^UTILITY($J) I '$D(^LR(LRDFN,0)) K ^LRO(69.2,LRAA,1,LRAN) Q - N LRPRE S LRPRE=1 ;Notifies EN^LRSPRPT that this is a prelim report - D EN^LRSPRPT Q:LR("Q") - I $P($G(^LR(LRDFN,0)),"^",2)=2 D Q:LR("Q") - .D ^LRAPPOW - G:'$D(^LR(LRDFN,"SP",0))&('$D(^LR(LRDFN,"CY",0)))&('$D(^LR(LRDFN,"EM",0))) AU - D ^LRAPT1 Q:LR("Q") -AU I $D(^LR(LRDFN,"AU")),$L($P(^LR(LRDFN,"AU"),"^")) D ^LRAPT2 Q:LR("Q") - K ^UTILITY($J) S DIWR=IOM-5,DIWF="W",LR("A")=0 - W ! F LRZ=0:1 S LR("A")=$O(^LRO(69.2,LRAA,10,LR("A"))) Q:'LR("A") D - .D:$Y>(IOSL-13) F^LRAPF,H S X=^LRO(69.2,LRAA,10,LR("A"),0) D ^DIWP - D:LRZ ^DIWW - S LRO=1 D F^LRAPF - Q -H ;from LRAPPF1 - D F^LRU W !,"ANATOMIC PATHOLOGY",!,LR("%") Q -END W $C(7),!!,"OK TO DELETE THE ",LRO(68)," PRELIMINARY REPORT LIST" S %=2 D YN^LRU I %=1 K ^LRO(69.2,LRAA,1) S ^LRO(69.2,LRAA,1,0)="^69.21A^0^0" W $C(7),!,"LIST DELETED !" Q - W !!,"FINE, LET'S FORGET IT",! Q - ; -SGL D EN1^LRUPS Q:LRAN=-1 S LRAP=LRDFN_"^"_LRI,LRSAV=1 D EN2^LRUA G DEV -CONT ; - K DIR S DIR(0)="E" - D ^DIR W ! - S:$D(DTOUT)!(X[U) LR("Q")=1 - Q +LRSPT ;AVAMC/REG/WTY - AP PRELIMINARY REPORTS ;10/16/01 + ;;5.2;LAB SERVICE;**1,72,248,259**;Sep 27, 1994 + ; + ;Reference to ^%DT supported by IA #10003 + ;Reference to ^DPT supported by IA #918 + ;Reference to ^DIWP suppported by IA #10011 + ;Reference to ^DIWW suppported by IA #10029 + ;Reference to EN^DDIOL supported by IA #10142 + ; + S X="T",%DT="" D ^%DT,D^LRU S LRTOD=Y D EN2^LRUA + W !!,"Preliminary reports for ",LRO(68) + G END:LRAPX=2,SGL:LRAPX=3,CH:LRAPX=4 +GETP D EN1^LRUPS Q:LRAN=-1 + G:$D(^LRO(69.2,LRAA,1,LRAN,0)) GETP + L +^LRO(69.2,LRAA,1):5 I '$T D G GETP + .S MSG(1)="The preliminary reports queue is in use by another person. " + .S MSG(1,"F")="!!" + .S MSG(2)="You will need to add this accession to the queue later." + .D EN^DDIOL(.MSG) K MSG + S ^LRO(69.2,LRAA,1,LRAN,0)=LRDFN_"^"_LRI + S X=^LRO(69.2,LRAA,1,0),^(0)=$P(X,"^",1,2)_"^"_LRAN_"^"_($P(X,"^",4)+1) + L -^LRO(69.2,LRAA,1) + G GETP +CH S LRAPX(1)=1 D EN^LRSPRPT2 Q:%<1 + W !!,"Save preliminary reports for reprinting " + S %=2 D YN^LRU S:%=1 LRSAV=1 + ;Variable LR("DVD") is used to divide reports displayed in the browser + K LR("DVD") + S $P(LR("DVD"),"|",IOM)="" +DEV ; + W ! + S %ZIS="Q" D ^%ZIS + I POP W ! Q + I $D(IO("Q")) D Q + .S ZTDESC="ANAT PATH PRELIM REPORT" + .S ZTSAVE("LR*")="",ZTRTN="QUE^LRSPT" + .D ^%ZTLOAD W:$D(ZTSK) !,"Request Queued, #",ZTSK W ! + .K ZTSK,IO("Q") D HOME^%ZIS +QUE ; + U IO + ;LRSF515=1 means this is generating and SF515. + S:'$D(LRSF515) LRSF515=0 + D L^LRU,L1^LRU,S^LRU,SET^LRUA + S LR("SPSM")=1 ;Set flag to suppress printing of SNOMED codes + S LRS(5)=1,LRQ(2)=1,LRA=$S($D(^LRO(69.2,LRAA,0)):$P(^(0),U,9),1:1) + S:LRA="" LRA=1 + S LR("DIWF")=$S($P(^LRO(69.2,LRAA,0),"^",6)="D":"D",1:"")_"W" + I $D(LRAP) S LRDFN=$P(LRAP,"^"),LRI=$P(LRAP,"^",2) D D G K + S LRAN=0 F S LRAN=$O(^LRO(69.2,LRAA,1,LRAN)) Q:'LRAN!(LR("Q")) D + .S X=^LRO(69.2,LRAA,1,LRAN,0),LRDFN=+X,LRI=$P(X,"^",2) D D + .W:IOST["BROWSER" !!,LR("DVD") +K K:'$D(LRSAV) ^LRO(69.2,LRAA,1) K P,S,LRAN + S ^LRO(69.2,LRAA,1,0)="^69.21A^^" + I 'LR("Q"),$D(LR("F")),IOST?1"C".E D CONT + K LRSAV + W:IOST?1"P-".E @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" + K %,DIR,DTOUT,DUOUT,DIRUT,X,Y + Q +D K ^UTILITY($J) I '$D(^LR(LRDFN,0)) K ^LRO(69.2,LRAA,1,LRAN) Q + N LRPRE S LRPRE=1 ;Notifies EN^LRSPRPT that this is a prelim report + D EN^LRSPRPT Q:LR("Q") + I $P($G(^LR(LRDFN,0)),"^",2)=2 D Q:LR("Q") + .D ^LRAPPOW + G:'$D(^LR(LRDFN,"SP",0))&('$D(^LR(LRDFN,"CY",0)))&('$D(^LR(LRDFN,"EM",0))) AU + D ^LRAPT1 Q:LR("Q") +AU I $D(^LR(LRDFN,"AU")),$L($P(^LR(LRDFN,"AU"),"^")) D ^LRAPT2 Q:LR("Q") + K ^UTILITY($J) S DIWR=IOM-5,DIWF="W",LR("A")=0 + W ! F LRZ=0:1 S LR("A")=$O(^LRO(69.2,LRAA,10,LR("A"))) Q:'LR("A") D + .D:$Y>(IOSL-6) H S X=^LRO(69.2,LRAA,10,LR("A"),0) D ^DIWP + D:LRZ ^DIWW + S LRO=1 D F^LRAPF + Q +H ;from LRAPPF1 + D F^LRU W !,"ANATOMIC PATHOLOGY",!,LR("%") Q +END W $C(7),!!,"OK TO DELETE THE ",LRO(68)," PRELIMINARY REPORT LIST" S %=2 D YN^LRU I %=1 K ^LRO(69.2,LRAA,1) S ^LRO(69.2,LRAA,1,0)="^69.21A^0^0" W $C(7),!,"LIST DELETED !" Q + W !!,"FINE, LET'S FORGET IT",! Q + ; +SGL D EN1^LRUPS Q:LRAN=-1 S LRAP=LRDFN_"^"_LRI,LRSAV=1 D EN2^LRUA G DEV +CONT ; + K DIR S DIR(0)="E" + D ^DIR W ! + S:$D(DTOUT)!(X[U) LR("Q")=1 + Q diff --git a/r/LAB_SERVICE-LR-LS/LRSRVR6.m b/r/LAB_SERVICE-LR-LS/LRSRVR6.m index 47aa1f05..507c434b 100644 --- a/r/LAB_SERVICE-LR-LS/LRSRVR6.m +++ b/r/LAB_SERVICE-LR-LS/LRSRVR6.m @@ -1,123 +1,122 @@ -LRSRVR6 ;DALIO/JMC - LAB DATA SERVER CONT'D SNOMED EXTRACT ;Aug 17, 2006 - ;;5.2;LAB SERVICE;**346,378**;Sep 27, 1994;Build 1 - ; Produces SNOMED extract via LRLABSERVER option - ; - Q - ; - ; -SERVER ; Server entry Point - N I,LRCNT,LREND,LRL,LRMSUBJ,LRST,LRSTN,LRTXT,LRX,LRY - D BUILD - S LRMSUBJ=LRST_" "_LRSTN_" SNOMED EXTRACT "_$$HTE^XLFDT($H,"1M") - D MAILSEND(LRMSUBJ) - D CLEAN - Q - ; - ; -BUILD ; Build extract - N J,LRCNT,LRCRLF,LRETIME,LRFN,LRLEX,LRNAME,LRQUIT,LRROOT,LRSCT,LRSCTEC,LRSCTVER,LRSCTX,LRSPEC,LRSTIME,LRSTR,LRVAL,LRVUID,LRX,LRY,X,Y - ; - S LRSTIME=$$NOW^XLFDT,LRVAL=$$SITE^VASITE,LRST=$P(LRVAL,"^",3),LRSTN=$P(LRVAL,"^",2),LRSCTVER="" - I LRST="" S LRST="???" - K ^TMP($J,"LRDATA") - S (LRCNT,LRCNT("SCT"))=0,LRCRLF=$C(13,10),LRSTR="" - F I=61,61.1,61.2,61.3,61.4,61.5,61.6,62 S LRCNT(I)=0,LRCNT(I,"SCT")=0 - D HDR - ; - ; Flag to indicate if SNOMED CT is available from LEXICON. - S LRLEX=0 - I $T(CODE^LEXTRAN)'="" S LRLEX=1 - ; - F LRFN=61,61.1,61.2,61.3,61.4,61.5,61.6,62 D - . S LRROOT="^LAB("_LRFN_",""B"")" - . D FILE - ; - S LRETIME=$$NOW^XLFDT - ; Set the final info into the ^TMP message global - S LRNODE=$O(^TMP($J,"LRDATA",""),-1) - I LRSTR'="" S LRNODE=LRNODE+1,^TMP($J,"LRDATA",LRNODE)=$$UUEN^LRSRVR4(LRSTR) - S ^TMP($J,"LRDATA",LRNODE+1)=" " - S ^TMP($J,"LRDATA",LRNODE+2)="end" - ; - S ^TMP($J,"LRDATA",1)=^TMP($J,"LRDATA",1)_" (Run time:"_$$FMDIFF^XLFDT(LRETIME,LRSTIME,3)_")" - S ^TMP($J,"LRDATA",3)="SNOMED CT version......: "_LRSCTVER - S J=6 - S ^TMP($J,"LRDATA",J)="Number of records per file:" - F I=61,61.1,61.2,61.3,61.4,61.5,61.6,62 D - . S J=J+1 - . S ^TMP($J,"LRDATA",J)=" "_$$LJ^XLFSTR($$GET1^DID(I,"","","NAME")_" File (#"_I_")",32,".")_": "_$J(LRCNT(I),5)_" ("_LRCNT(I,"SCT")_" mapped)" - S ^TMP($J,"LRDATA",J+1)=$$LJ^XLFSTR("Total number of records",33,".")_": "_$J(LRCNT,5)_" ("_LRCNT("SCT")_" mapped)" - ; - Q - ; - ; -CLEAN ; - K ^TMP($J,"LR61") - K LRIEN,LRLEN,LRNODE,LRSNM,LRSPECN - D CLEAN^LRSRVR - D ^%ZISC - Q - ; - ; -FILE ; Search file entry and build record. - ; - F S LRROOT=$Q(@LRROOT) Q:LRROOT="" Q:$QS(LRROOT,2)'="B" D - . Q:$G(@LRROOT) - . S LRIEN=$QS(LRROOT,4),LRSPEC="" - . S LRNAME=$P($G(^LAB(LRFN,LRIEN,0)),"^"),LRNAME=$$TRIM^XLFSTR(LRNAME,"RL"," ") - . S X=$P($G(^LAB(LRFN,LRIEN,0)),"^",2) - . S LRSNM=$S(LRFN'=62:X,1:"") - . I LRFN=62 S LRSPEC=X - . I LRSNM'="",LRFN>60.9,LRFN<61.61 S LRX=((LRFN*10)#610)+1,LRSNM=$E("TMEFDPJ",LRX)_"-"_LRSNM - . S LRSCT=$P($G(^LAB(LRFN,LRIEN,"SCT")),"^"),(LRSCTEC,LRSCTX,LRVUID)="" - . I LRLEX,LRSCT'="" D - . . K LRX - . . S LRX=$$CODE^LEXTRAN(LRSCT,"SCT",DT,"LRX") - . . S LRSCTX=$G(LRX("F")),LRSCTEC=$S(LRX<1:$P(LRX,"^",2),1:"") - . . I LRSCTVER="",LRX>0 S LRSCTVER=$P($G(LRX(0)),"^",3) - . S LRSTR=LRSTR_LRST_"-"_LRFN_"-"_LRIEN_"|"_LRNAME_"|"_LRSNM_"|"_LRVUID_"|"_LRSCT_"|"_LRSCTX_"|"_LRSCTEC_"|" - . S LRSPECN="|" - . I LRFN=62,LRSPEC D - . . S LRSPECN=$P($G(^LAB(61,LRSPEC,0)),"^") - . . S LRSPECN=LRSPECN_"|"_LRST_"-61-"_LRSPEC - . S LRSTR=LRSTR_LRSPECN_"|1.1|" - . S LRCNT=LRCNT+1,LRCNT(LRFN)=LRCNT(LRFN)+1 S:LRSCT LRCNT("SCT")=LRCNT("SCT")+1,LRCNT(LRFN,"SCT")=LRCNT(LRFN,"SCT")+1 - . D SETDATA - Q - ; - ; -SETDATA ; Set data into report structure - S LRSTR=LRSTR_LRCRLF - S LRNODE=$O(^TMP($J,"LRDATA",""),-1) - D ENCODE^LRSRVR4(.LRSTR) - Q - ; - ; -HDR ; Set the header information - N LRFILENM - S LRFILENM=$TR(LRSTN," ","_")_"-"_LRSUB_"-"_$P($$FMTHL7^XLFDT(LRSTIME),"-")_".TXT" - S ^TMP($J,"LRDATA",1)="Report Generated.......: "_$$FMTE^XLFDT(LRSTIME)_" at "_LRSTN - S ^TMP($J,"LRDATA",2)="Report requested.......: "_LRSUB - S ^TMP($J,"LRDATA",3)="SNOMED CT version......: " - S ^TMP($J,"LRDATA",4)="Extract version........: 1.1" - F I=5,15,16,18,23 S ^TMP($J,"LRDATA",I)=" " - S ^TMP($J,"LRDATA",17)="Attached file..........: "_LRFILENM - S ^TMP($J,"LRDATA",19)="Legend:" - S X="Station #-File #-IEN|Entry Name|SNOMED I|VUID|SNOMED CT|SNOMED CT TERM|Mapping Exception|Related Specimen|Related Specimen ID|Extract Ver|" - S ^TMP($J,"LRDATA",20)=X - S X=" 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 |" - S ^TMP($J,"LRDATA",21)=X - S ^TMP($J,"LRDATA",22)=$$REPEAT^XLFSTR("-",$L(X)) - S ^TMP($J,"LRDATA",24)=$$UUBEGFN^LRSRVR2A(LRFILENM) - Q - ; - ; -MAILSEND(LRMSUBJ) ; Send extract back to requestor. - ; - N LRINSTR,LRTASK,LRTO,XMERR,XMZ - S LRTO(XQSND)="" - S LRINSTR("ADDR FLAGS")="R" - S LRINSTR("FROM")="LAB_PACKAGE" - S LRMSUBJ=$E(LRMSUBJ,1,65) - D SENDMSG^XMXAPI(.5,LRMSUBJ,"^TMP($J,""LRDATA"")",.LRTO,.LRINSTR,.LRTASK) - Q +LRSRVR6 ;DALIO/JMC - LAB DATA SERVER CONT'D SNOMED EXTRACT ;Aug 17, 2006 + ;;5.2;LAB SERVICE;**346**;Sep 27, 1994;Build 10 + ; Produces SNOMED extract via LRLABSERVER option + ; + Q + ; + ; +SERVER ; Server entry Point + N I,LRCNT,LREND,LRL,LRMSUBJ,LRST,LRSTN,LRTXT,LRX,LRY + D BUILD + S LRMSUBJ=LRST_" "_LRSTN_" SNOMED EXTRACT "_$$HTE^XLFDT($H,"1M") + D MAILSEND(LRMSUBJ) + D CLEAN + Q + ; + ; +BUILD ; Build extract + N J,LRCNT,LRCRLF,LRETIME,LRFN,LRLEX,LRNAME,LRQUIT,LRROOT,LRSCT,LRSCTEC,LRSCTVER,LRSCTX,LRSPEC,LRSTIME,LRSTR,LRVAL,LRVUID,LRX,LRY,X,Y + ; + S LRSTIME=$$NOW^XLFDT,LRVAL=$$SITE^VASITE,LRST=$P(LRVAL,"^",3),LRSTN=$P(LRVAL,"^",2),LRSCTVER="" + I LRST="" S LRST="???" + K ^TMP($J,"LRDATA") + S (LRCNT,LRCNT("SCT"))=0,LRCRLF=$C(13,10),LRSTR="" + F I=61,61.1,61.2,61.3,61.4,61.5,61.6,62 S LRCNT(I)=0,LRCNT(I,"SCT")=0 + D HDR + ; + ; Flag to indicate if SNOMED CT is available from LEXICON. + S LRLEX=0 + I $T(CODE^LEXTRAN)'="" S LRLEX=1 + ; + F LRFN=61,61.1,61.2,61.3,61.4,61.5,61.6,62 D + . S LRROOT="^LAB("_LRFN_",""B"")" + . D FILE + ; + S LRETIME=$$NOW^XLFDT + ; Set the final info into the ^TMP message global + S LRNODE=$O(^TMP($J,"LRDATA",""),-1) + I LRSTR'="" S LRNODE=LRNODE+1,^TMP($J,"LRDATA",LRNODE)=$$UUEN^LRSRVR4(LRSTR) + S ^TMP($J,"LRDATA",LRNODE+1)=" " + S ^TMP($J,"LRDATA",LRNODE+2)="end" + ; + S ^TMP($J,"LRDATA",1)=^TMP($J,"LRDATA",1)_" (Run time:"_$$FMDIFF^XLFDT(LRETIME,LRSTIME,3)_")" + S ^TMP($J,"LRDATA",3)="SNOMED CT version......: "_LRSCTVER + S J=6 + S ^TMP($J,"LRDATA",J)="Number of records per file:" + F I=61,61.1,61.2,61.3,61.4,61.5,61.6,62 D + . S J=J+1 + . S ^TMP($J,"LRDATA",J)=" "_$$LJ^XLFSTR($$GET1^DID(I,"","","NAME")_" File (#"_I_")",32,".")_": "_$J(LRCNT(I),5)_" ("_LRCNT(I,"SCT")_" mapped)" + S ^TMP($J,"LRDATA",J+1)=$$LJ^XLFSTR("Total number of records",33,".")_": "_$J(LRCNT,5)_" ("_LRCNT("SCT")_" mapped)" + ; + Q + ; + ; +CLEAN ; + K ^TMP($J,"LR61") + K LRIEN,LRLEN,LRNODE,LRSNM,LRSPECN + D CLEAN^LRSRVR + D ^%ZISC + Q + ; + ; +FILE ; Search file entry and build record. + ; + F S LRROOT=$Q(@LRROOT) Q:LRROOT="" Q:$QS(LRROOT,2)'="B" D + . Q:$G(@LRROOT) + . S LRIEN=$QS(LRROOT,4),LRSPEC="" + . S LRNAME=$P($G(^LAB(LRFN,LRIEN,0)),"^"),LRNAME=$$TRIM^XLFSTR(LRNAME,"RL"," ") + . S X=$P($G(^LAB(LRFN,LRIEN,0)),"^",2) + . S LRSNM=$S(LRFN'=62:X,1:"") + . I LRFN=62 S LRSPEC=X + . I LRSNM'="",LRFN>60.9,LRFN<61.61 S LRX=((LRFN*10)#610)+1,LRSNM=$E("TMEFDPJ",LRX)_"-"_LRSNM + . S LRSCT=$P($G(^LAB(LRFN,LRIEN,"SCT")),"^"),(LRSCTEC,LRSCTX,LRVUID)="" + . I LRLEX,LRSCT'="" D + . . K LRX + . . S LRX=$$CODE^LEXTRAN(LRSCT,"SCT",DT,"LRX") + . . S LRSCTX=$G(LRX("F")),LRSCTEC=$S(LRX<1:$P(LRX,"^",2),1:"") + . . I LRSCTVER="",LRX>0 S LRSCTVER=$P($G(LRX(0)),"^",3) + . S LRSTR=LRSTR_LRST_"-"_LRFN_"-"_LRIEN_"|"_LRNAME_"|"_LRSNM_"|"_LRVUID_"|"_LRSCT_"|"_LRSCTX_"|"_LRSCTEC_"|" + . S LRSPECN="|" + . I LRFN=62,LRSPEC D + . . S LRSPECN=$P($G(^LAB(61,LRSPEC,0)),"^") + . . S LRSPECN=LRSPECN_"|"_LRST_"-61-"_LRSPEC + . S LRSTR=LRSTR_LRSPECN_"|1.1|" + . S LRCNT=LRCNT+1,LRCNT(LRFN)=LRCNT(LRFN)+1 S:LRSCT LRCNT("SCT")=LRCNT("SCT")+1,LRCNT(LRFN,"SCT")=LRCNT(LRFN,"SCT")+1 + . D SETDATA + Q + ; + ; +SETDATA ; Set data into report structure + S LRSTR=LRSTR_LRCRLF + S LRNODE=$O(^TMP($J,"LRDATA",""),-1) + D ENCODE^LRSRVR4(.LRSTR) + Q + ; + ; +HDR ; Set the header information + N LRFILENM + S LRFILENM=$TR(LRSTN," ","_")_"-"_LRSUB_"-"_$P($$FMTHL7^XLFDT(LRSTIME),"-")_".TXT" + S ^TMP($J,"LRDATA",1)="Report Generated.......: "_$$FMTE^XLFDT(LRSTIME)_" at "_LRSTN + S ^TMP($J,"LRDATA",2)="Report requested.......: "_LRSUB + S ^TMP($J,"LRDATA",3)="SNOMED CT version......: " + S ^TMP($J,"LRDATA",4)="Extract version........: 1.1" + F I=5,15,16,18,23 S ^TMP($J,"LRDATA",I)=" " + S ^TMP($J,"LRDATA",17)="Attached file..........: "_LRFILENM + S ^TMP($J,"LRDATA",19)="Legend:" + S X="Station #-File #-IEN|Entry Name|SNOMED I|VUID|SNOMED CT|SNOMED CT TERM|Mapping Exception|Related Specimen|Related Specimen ID|Extract Ver|" + S ^TMP($J,"LRDATA",20)=X + S X=" 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 |" + S ^TMP($J,"LRDATA",21)=X + S ^TMP($J,"LRDATA",22)=$$REPEAT^XLFSTR("-",$L(X)) + S ^TMP($J,"LRDATA",24)=$$UUBEGFN^LRSRVR2A(LRFILENM) + Q + ; + ; +MAILSEND(LRMSUBJ) ; Send extract back to requestor. + ; + N LRINSTR,LRTASK,LRTO,XMERR,XMZ + S LRTO(XQSND)="" + S LRINSTR("ADDR FLAGS")="R" + S LRINSTR("FROM")="LAB_PACKAGE" + D SENDMSG^XMXAPI(.5,LRMSUBJ,"^TMP($J,""LRDATA"")",.LRTO,.LRINSTR,.LRTASK) + Q diff --git a/r/LAB_SERVICE-LR-LS/LRVER3A.m b/r/LAB_SERVICE-LR-LS/LRVER3A.m index 3fc28323..d83d4689 100644 --- a/r/LAB_SERVICE-LR-LS/LRVER3A.m +++ b/r/LAB_SERVICE-LR-LS/LRVER3A.m @@ -1,95 +1,95 @@ -LRVER3A ;SLC/CJS/DALOI/FHS - DATA VERIFICATION ;5/27/03 14:49 - ;;5.2;LAB SERVICE;**1,5,42,100,121,153,190,221,254,263,266,274,295,373**;Sep 27, 1994;Build 1 - ;Also contains LRORFLG to restrict multiple OERR alerts (VER+2) - ; Reference to ^DIC(42 supported by IA #10039 - ; Reference to ^%ZTLOAD supported by DBIA #10063 - ; Reference to IN5^VADPT supported by DBIA #10061 - ; Reference to $$NOW^XLFDT supported by DBIA #10103 - ; -VER ;Call with L ^LR(LRDFN,LRSS,LRIDT) from LRGV2, LRGVG1, LRSTUF1, LRSTUF2, LRVR3 - Q:'$O(LRSB(0)) - N LRVCHK,LRORTST,LRORFLG,LRT - S LRORU3=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),(LRAOD,LRACD)=$P(^(0),U,3) - S LRACD=$S($D(^LRO(68,LRAA,1,LRAD,1,LRAN,9)):^(9),1:LRACD) - S:'($D(^LRO(68,LRAA,1,LRACD,1,LRAN,0))#2) LRACD=LRAD - S LRAOD=$S($D(^LRO(68,LRAA,1,LRAOD,1,LRAN,0))#2:LRAOD,1:LRAD) - I '$G(LRFIX) S LRNOW=$$NOW^XLFDT,$P(^LR(LRDFN,LRSS,LRIDT,0),U,3,4)=LRNOW_U_$S($G(LRDUZ):LRDUZ,1:DUZ) - K A2 I '$D(PNM) S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX S:PNM="" PNM="NONAME" - N LRT S LRT=0 F S LRT=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT)) Q:LRT<.5 S:$P(^(LRT,0),U,5)="" A2(LRT)=1 I $D(^TMP("LR",$J,"VTO",LRT)) S LRVCHK=+^(LRT) D - . I $S(LRVCHK<1:1,$D(LRSB(LRVCHK))#2:1,1:0) D - . . I $D(LRSB(LRVCHK)) Q:$P(LRSB(LRVCHK),U)="" - . . I LRVCHK<1,$L($P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0),U,6)) Q - . . D - . . . S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0),U,4)=$S($G(LRDUZ):LRDUZ,$G(DUZ):DUZ,1:"") - . . . S:'$P(^(0),U,5) $P(^(0),U,5)=LRNOW - . . . S $P(^(0),U,6)="",$P(^(0),U,8)=$G(LRCDEF) - . . S LRORTST(LRT)="" - . . I LRACD'=LRAD D - . . . Q:'$D(^LRO(68,LRAA,1,LRACD,1,LRAN,4,+LRT,0)) D - . . . . S $P(^LRO(68,LRAA,1,LRACD,1,LRAN,4,+LRT,0),U,4)=$S($G(LRDUZ):LRDUZ,$G(DUZ):DUZ,1:"") - . . . . S:'$P(^(0),U,5) $P(^(0),U,5)=LRNOW - . . . . S $P(^(0),U,6)="",$P(^(0),U,8)=$G(LRCDEF) - . . I $P($G(LRPARAM),U,14),$P($G(^LRO(68,+LRAA,0)),U,16) S ^LRO(68,"AA",LRAA_"|"_LRAD_"|"_LRAN_"|"_LRT)="" - . . K A2(LRT) - . . I +$G(LRDPF)=2,$$VER^LR7OU1<3 D - . . . N I,Y - . . . S Y=LRNOW,I=LRT D V^LROR ;OE/RR 2.5 - ;-K ZZCARE,ZRECORD I $D(^LR(LRDFN,.3)),^LR(LRDFN,.3)'="" D FCS ; CJS/MPLS 12-4-91 LINK TO CIS ; CJS/MPLS 3-16-92 KILL LOCAL VARIABLES - ;-I $P(^LR(LRDFN,0),U,2)=2 I '$D(ZZCARE) S ZRECORD=0,ZRECORD=$O(^SC("C",LRLLOC,ZRECORD)) I ZRECORD'="",$D(^LRTXFCS(5000024,1,618001,"B",ZRECORD)) D FCS ; CJS/MPLS 3-16-92 LINE ADDED TO CHECK IF REQUESTING LOCATION IS CAREVUE SUPPORTED ++RG - S D1=1,X=0 F S X=$O(^TMP("LR",$J,"TMP",X)) Q:X<1 S LRT=+^(X) I $D(LRM(X)) D REQ - I $D(^LRO(69,LRODT,1,LRSN,0)) S ^(3)=$S($D(^(3)):+^(3),1:LRNOW) S:'$P(^(3),U,2) $P(^(3),U,2)=LRNOW - I D1,'$D(A2) S:'$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,4) $P(^(3),U,4)=LRNOW,^LRO(68,LRAA,1,LRAD,1,"AC",LRNOW,LRAN)="" - ; Class I CareVue routine TASKED if CareVue ward - pwc/10-2000 - D - . N I,LR7DLOC D IN5^VADPT S LR7DLOC=$G(^DIC(42,+$P($G(VAIP(5)),"^"),44)) - . Q:'LR7DLOC D:$D(^LAB(62.487,"C",LR7DLOC)) ;good ward location - . . S ZTRTN="^LA7DLOC",ZTDESC="LAB AUTOMATION CAREVUE SUPPORTED WARDS" - . . S ZTIO="",ZTDTH=$H,ZTSAVE("L*")="" D ^%ZTLOAD - . . K ZTSAVE,ZTSK,ZTRTN,ZTIO,ZTDTH,ZTDESC,ZTREQ,ZTQUEUED - ;D ^VEICVLOC ;* PLS 6/3/99 -For HL7 interface - I D1,'$D(A2),LRAD'=LRACD S:'$P(^LRO(68,LRAA,1,LRACD,1,LRAN,3),U,4) $P(^(3),U,4)=LRNOW,^LRO(68,LRAA,1,LRACD,1,"AC",LRNOW,LRAN)="" - D XREF I $D(^LRO(68,LRAA,.2))'[0 X ^(.2) - N CORRECT S:$G(LRCORECT) CORRECT=1 D NEW^LR7OB1(LRODT,LRSN,"RE",,.LRORTST) - L -^LR(LRDFN,LRSS,LRIDT) ;unlock - Q -XREF ;from COM1^LRVER4 and VER^LRVER3A - I +$G(LRDPF)=2,$$VER^LR7OU1<3 D EN^LROR(LRAA,LRAD,LRAN) ;OE/RR 2.5 - I LRDPF=62.3 S ^LRO(68,LRAA,1,LRAD,1,"AD",DT,LRAN)="" Q - S LRPRAC=$$PRAC^LRX($P(^LR(LRDFN,LRSS,LRIDT,0),U,10)) ;get doc name - S ^LRO(68,LRAA,1,LRAD,1,"AD",DT,LRAN)="" - S ^LRO(69,9999999-LRIDT\1,1,"AL",$E(LRLLOC,1,15),$E(PNM,1,20),LRDFN)="" - S ^LRO(69,9999999-LRIDT\1,1,"AP",LRPRAC,$E(PNM,1,20),LRDFN)="" - S ^LRO(69,DT,1,"AN",$E(LRLLOC,1,15),LRDFN,LRIDT)="" - S ^LRO(69,DT,1,"AR",$E(LRLLOC,1,15),$E(PNM,1,20),LRDFN)="" - S ^LRO(69,"AN",$E(LRLLOC,1,20),LRDFN,LRIDT)="" - D CHSET^LRPX(LRDFN,LRIDT) - Q:'$P(LRPARAM,U,3) -TSKM F KK="LRDFN","LRAA","LRAOD","LRAD","LRAN","LRIDT","LRSS","LRLLOC","LRSN","LRODT" S ZTSAVE(KK)="" - N %X S ZTRTN="DQ^LRTP",ZTIO="",ZTDTH=$H,ZTDESC="LAB INTERIM REPORTS" D ^%ZTLOAD - K KK,ZTSK,ZTRTN,ZTDTH,ZTSAVE,ZTIO Q -REQ ; - Q:$P($G(LRSB(X)),U)="comment" - I $D(LRSB(X)),$P(LRSB(X),U)="canc" Q - I $D(LRSB(X)),$P(LRSB(X),U)'["pending" Q - I $L($P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0)),U,6)) Q - S:'$G(LRALERT) LRALERT=$S($G(LROUTINE):LROUTINE,1:9) - S D1=0 N A,LRPPURG - I $D(LRSB(X)),LRSB(X)["pending",$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0))#2 D G REQ1 - . S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0),U,4)="",$P(^(0),U,5,6)="^",$P(^(0),U,9)=+$G(LRM(X,"P")) - I '$D(LRSB(X)),'$L($P($G(^LR(LRDFN,"CH",LRIDT,X)),U)) S $P(^(X),U)="pending" - I '$D(LRSB(X)),$P($G(^LR(LRDFN,"CH",LRIDT,X)),U)'="pending" Q - I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0))#2 S $P(^(0),U,4,5)="^",A=$P(^(0),U,2) I A>49 S $P(^(0),U,2)=$S(A=50:9,1:A-50) - I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0))#2 D - . S ^LRO(68,LRAA,1,LRAD,1,LRAN,4,"B",+LRT,+LRT)="" - . S LRPPURG=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+$G(LRM(X,"P")),0)),U,2) - . S:'LRPPURG LRPPURG=$S($G(LRALERT):+LRALERT,1:9) - . S ^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0)=+LRT_U_LRPPURG,$P(^(0),U,9)=+$G(LRM(X,"P")) - . S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0),U,3)=+LRT,$P(^(0),U,4)=$P(^(0),U,4)+1 Q -REQ1 ; - Q:LRACD=LRAD I $D(^LRO(68,LRAA,1,LRACD,1,LRAN,4,+LRT,0))#2,'$L($P(^(0),U,6)) S ^(0)=$P(^(0),U,1,2),$P(^(0),U,7)=1,$P(^(0),U,9)=+$G(LRM(X,"P")) - K CNT,LRAMC Q -FCS ; SET UP FOR FOREIGN COMPUTER SYSTEM ; CJS/MPLS 12-4-91 LINK TO CIS - ;-S:'$D(ZRECORD) ZZCARE=1 S:$D(ZRECORD) ZTSAVE("LRLLOC")="" ; CJS/MPLS 3-18-92 SET ZZCARE IF PATIENT IN ICU'S, SET ZTSAVE IF TEST REQUESTED FROM PAR/OR - ;-F KK="LRDFN","LRIDT","DFN" S ZTSAVE(KK)="" - ;-S ZTRTN="EN^LAFCCVX2",ZTIO="",ZTDTH=$H D ^%ZTLOAD - ;-Q +LRVER3A ;SLC/CJS/DALOI/FHS - DATA VERIFICATION ;5/27/03 14:49 + ;;5.2;LAB SERVICE;**1,5,42,100,121,153,190,221,254,263,266,274,295**;Sep 27, 1994 + ;Also contains LRORFLG to restrict multiple OERR alerts (VER+2) + ; Reference to ^DIC(42 supported by IA #10039 + ; Reference to ^%ZTLOAD supported by DBIA #10063 + ; Reference to IN5^VADPT supported by DBIA #10061 + ; Reference to $$NOW^XLFDT supported by DBIA #10103 + ; +VER ;Call with L ^LR(LRDFN,LRSS,LRIDT) from LRGV2, LRGVG1, LRSTUF1, LRSTUF2, LRVR3 + Q:'$O(LRSB(0)) + N LRVCHK,LRORTST,LRORFLG,LRT + S LRORU3=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),(LRAOD,LRACD)=$P(^(0),U,3) + S LRACD=$S($D(^LRO(68,LRAA,1,LRAD,1,LRAN,9)):^(9),1:LRACD) + S:'$D(^LRO(68,LRAA,1,LRACD,1,LRAN,0))#2 LRACD=LRAD + S LRAOD=$S($D(^LRO(68,LRAA,1,LRAOD,1,LRAN,0))#2:LRAOD,1:LRAD) + I '$G(LRFIX) S LRNOW=$$NOW^XLFDT,$P(^LR(LRDFN,LRSS,LRIDT,0),U,3,4)=LRNOW_U_$S($G(LRDUZ):LRDUZ,1:DUZ) + K A2 I '$D(PNM) S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX S:PNM="" PNM="NONAME" + N LRT S LRT=0 F S LRT=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT)) Q:LRT<.5 S:$P(^(LRT,0),U,5)="" A2(LRT)=1 I $D(^TMP("LR",$J,"VTO",LRT)) S LRVCHK=+^(LRT) D + . I $S(LRVCHK<1:1,$D(LRSB(LRVCHK))#2:1,1:0) D + . . I $D(LRSB(LRVCHK)) Q:$P(LRSB(LRVCHK),U)="" + . . I LRVCHK<1,$L($P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0),U,6)) Q + . . D + . . . S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0),U,4)=$S($G(LRDUZ):LRDUZ,$G(DUZ):DUZ,1:"") + . . . S:'$P(^(0),U,5) $P(^(0),U,5)=LRNOW + . . . S $P(^(0),U,6)="",$P(^(0),U,8)=$G(LRCDEF) + . . S LRORTST(LRT)="" + . . I LRACD'=LRAD D + . . . Q:'$D(^LRO(68,LRAA,1,LRACD,1,LRAN,4,+LRT,0)) D + . . . . S $P(^LRO(68,LRAA,1,LRACD,1,LRAN,4,+LRT,0),U,4)=$S($G(LRDUZ):LRDUZ,$G(DUZ):DUZ,1:"") + . . . . S:'$P(^(0),U,5) $P(^(0),U,5)=LRNOW + . . . . S $P(^(0),U,6)="",$P(^(0),U,8)=$G(LRCDEF) + . . I $P($G(LRPARAM),U,14),$P($G(^LRO(68,+LRAA,0)),U,16) S ^LRO(68,"AA",LRAA_"|"_LRAD_"|"_LRAN_"|"_LRT)="" + . . K A2(LRT) + . . I +$G(LRDPF)=2,$$VER^LR7OU1<3 D + . . . N I,Y + . . . S Y=LRNOW,I=LRT D V^LROR ;OE/RR 2.5 + ;-K ZZCARE,ZRECORD I $D(^LR(LRDFN,.3)),^LR(LRDFN,.3)'="" D FCS ; CJS/MPLS 12-4-91 LINK TO CIS ; CJS/MPLS 3-16-92 KILL LOCAL VARIABLES + ;-I $P(^LR(LRDFN,0),U,2)=2 I '$D(ZZCARE) S ZRECORD=0,ZRECORD=$O(^SC("C",LRLLOC,ZRECORD)) I ZRECORD'="",$D(^LRTXFCS(5000024,1,618001,"B",ZRECORD)) D FCS ; CJS/MPLS 3-16-92 LINE ADDED TO CHECK IF REQUESTING LOCATION IS CAREVUE SUPPORTED ++RG + S D1=1,X=0 F S X=$O(^TMP("LR",$J,"TMP",X)) Q:X<1 S LRT=+^(X) I $D(LRM(X)) D REQ + S:$D(^LRO(69,LRODT,1,LRSN,0)) ^(3)=$S($D(^(3)):+^(3),1:LRNOW) S:'$P(^(3),U,2) $P(^(3),U,2)=LRNOW + I D1,'$D(A2) S:'$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,4) $P(^(3),U,4)=LRNOW,^LRO(68,LRAA,1,LRAD,1,"AC",LRNOW,LRAN)="" + ; Class I CareVue routine TASKED if CareVue ward - pwc/10-2000 + D + . N I,LR7DLOC D IN5^VADPT S LR7DLOC=$G(^DIC(42,+$P($G(VAIP(5)),"^"),44)) + . Q:'LR7DLOC D:$D(^LAB(62.487,"C",LR7DLOC)) ;good ward location + . . S ZTRTN="^LA7DLOC",ZTDESC="LAB AUTOMATION CAREVUE SUPPORTED WARDS" + . . S ZTIO="",ZTDTH=$H,ZTSAVE("L*")="" D ^%ZTLOAD + . . K ZTSAVE,ZTSK,ZTRTN,ZTIO,ZTDTH,ZTDESC,ZTREQ,ZTQUEUED + ;D ^VEICVLOC ;* PLS 6/3/99 -For HL7 interface + I D1,'$D(A2),LRAD'=LRACD S:'$P(^LRO(68,LRAA,1,LRACD,1,LRAN,3),U,4) $P(^(3),U,4)=LRNOW,^LRO(68,LRAA,1,LRACD,1,"AC",LRNOW,LRAN)="" + D XREF I $D(^LRO(68,LRAA,.2))'[0 X ^(.2) + N CORRECT S:$G(LRCORECT) CORRECT=1 D NEW^LR7OB1(LRODT,LRSN,"RE",,.LRORTST) + L -^LR(LRDFN,LRSS,LRIDT) ;unlock + Q +XREF ;from COM1^LRVER4 and VER^LRVER3A + I +$G(LRDPF)=2,$$VER^LR7OU1<3 D EN^LROR(LRAA,LRAD,LRAN) ;OE/RR 2.5 + I LRDPF=62.3 S ^LRO(68,LRAA,1,LRAD,1,"AD",DT,LRAN)="" Q + S LRPRAC=$$PRAC^LRX($P(^LR(LRDFN,LRSS,LRIDT,0),U,10)) ;get doc name + S ^LRO(68,LRAA,1,LRAD,1,"AD",DT,LRAN)="" + S ^LRO(69,9999999-LRIDT\1,1,"AL",$E(LRLLOC,1,15),$E(PNM,1,20),LRDFN)="" + S ^LRO(69,9999999-LRIDT\1,1,"AP",LRPRAC,$E(PNM,1,20),LRDFN)="" + S ^LRO(69,DT,1,"AN",$E(LRLLOC,1,15),LRDFN,LRIDT)="" + S ^LRO(69,DT,1,"AR",$E(LRLLOC,1,15),$E(PNM,1,20),LRDFN)="" + S ^LRO(69,"AN",$E(LRLLOC,1,20),LRDFN,LRIDT)="" + D CHSET^LRPX(LRDFN,LRIDT) + Q:'$P(LRPARAM,U,3) +TSKM F KK="LRDFN","LRAA","LRAOD","LRAD","LRAN","LRIDT","LRSS","LRLLOC","LRSN","LRODT" S ZTSAVE(KK)="" + N %X S ZTRTN="DQ^LRTP",ZTIO="",ZTDTH=$H,ZTDESC="LAB INTERIM REPORTS" D ^%ZTLOAD + K KK,ZTSK,ZTRTN,ZTDTH,ZTSAVE,ZTIO Q +REQ ; + Q:$P($G(LRSB(X)),U)="comment" + I $D(LRSB(X)),$P(LRSB(X),U)="canc" Q + I $D(LRSB(X)),$P(LRSB(X),U)'["pending" Q + I $L($P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0)),U,6)) Q + S:'$G(LRALERT) LRALERT=$S($G(LROUTINE):LROUTINE,1:9) + S D1=0 N A,LRPPURG + I $D(LRSB(X)),LRSB(X)["pending",$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0))#2 D G REQ1 + . S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0),U,4)="",$P(^(0),U,5,6)="^",$P(^(0),U,9)=+$G(LRM(X,"P")) + I '$D(LRSB(X)),'$L($P($G(^LR(LRDFN,"CH",LRIDT,X)),U)) S $P(^(X),U)="pending" + I '$D(LRSB(X)),$P($G(^LR(LRDFN,"CH",LRIDT,X)),U)'="pending" Q + I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0))#2 S $P(^(0),U,4,5)="^",A=$P(^(0),U,2) I A>49 S $P(^(0),U,2)=$S(A=50:9,1:A-50) + I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0))#2 D + . S ^LRO(68,LRAA,1,LRAD,1,LRAN,4,"B",+LRT,+LRT)="" + . S LRPPURG=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+$G(LRM(X,"P")),0)),U,2) + . S:'LRPPURG LRPPURG=$S($G(LRALERT):+LRALERT,1:9) + . S ^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0)=+LRT_U_LRPPURG,$P(^(0),U,9)=+$G(LRM(X,"P")) + . S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0),U,3)=+LRT,$P(^(0),U,4)=$P(^(0),U,4)+1 Q +REQ1 ; + Q:LRACD=LRAD I $D(^LRO(68,LRAA,1,LRACD,1,LRAN,4,+LRT,0))#2,'$L($P(^(0),U,6)) S ^(0)=$P(^(0),U,1,2),$P(^(0),U,7)=1,$P(^(0),U,9)=+$G(LRM(X,"P")) + K CNT,LRAMC Q +FCS ; SET UP FOR FOREIGN COMPUTER SYSTEM ; CJS/MPLS 12-4-91 LINK TO CIS + ;-S:'$D(ZRECORD) ZZCARE=1 S:$D(ZRECORD) ZTSAVE("LRLLOC")="" ; CJS/MPLS 3-18-92 SET ZZCARE IF PATIENT IN ICU'S, SET ZTSAVE IF TEST REQUESTED FROM PAR/OR + ;-F KK="LRDFN","LRIDT","DFN" S ZTSAVE(KK)="" + ;-S ZTRTN="EN^LAFCCVX2",ZTIO="",ZTDTH=$H D ^%ZTLOAD + ;-Q diff --git a/r/LAB_SERVICE-LR-LS/LRWLST1.m b/r/LAB_SERVICE-LR-LS/LRWLST1.m index 057c7717..577f184e 100644 --- a/r/LAB_SERVICE-LR-LS/LRWLST1.m +++ b/r/LAB_SERVICE-LR-LS/LRWLST1.m @@ -1,325 +1,305 @@ -LRWLST1 ;DALOI/CJS/RWF/FHS - ACCESSION SETUP ; July 19, 2006 - ;;5.2;LAB SERVICE;**48,65,121,153,261,286,331,379**;Sep 27, 1994;Build 2 - ; - ; Reference to ^DIC(42 supported by IA #10039 - ; Reference to ^SC( supported by IA #10040 - ; - S LRWLC=0 - F S LRWLC=$O(LRTSTS(LRWLC)) Q:LRWLC<1 S LRAD=DT D SPLIT - ; - ; If LEDI and comments came with order then copy to order in #69 - I $G(LRORDRR)="R",$G(LR696),$D(^LRO(69.6,LR696,99)) D - . N LRDIE - . D WP^DIE(69.01,LRSN_","_LRODT_",",16,"A","^LRO(69.6,LR696,99)","LRDIE(16)") - ; - K DIC,DLAYGO,DR,DA,DIE,LRIXX - Q:$G(LRORDR)="P" - K LRNM,LRTSTS - K ^TMP("LR",$J,"TMP") - Q - ; -SPLIT ; - N LRAA,LRX - ; Setup regular accessions (LRUNQ=0) - S LRUNQ=0,LREND=0 - I $D(LRTSTS(LRWLC,0)) D - . D GTWLN - . I LREND Q - . S LRAA=0 - . F S LRAA=$O(LRTSTS(LRWLC,0,LRAA)) Q:LRAA<1 D - . . S LRSS=LRTSTS(LRWLC,0,LRAA) - . . D STWLN,ST2,^LRWLST11,EN^LA7ADL(LRUID) - . D SICA^LRWLST11 - ; - ; Setup accessions requiring 'unique' accession numbers (LRUNQ=1) - S LRUNQ=1,LRAA=0 - F S LRAA=$O(LRTSTS(LRWLC,1,LRAA)) Q:LRAA<1 D - . S LRSS=LRTSTS(LRWLC,1,LRAA) - . F D GTWLN Q:LREND D Q:$O(LRTSTS(LRWLC,1,LRAA,0))<1 - . . D STWLN,ST2,^LRWLST11,EN^LA7ADL(LRUID),SICA^LRWLST11 - Q - ; - ; -STWLN ; Set accession number - ; - D GETLOCK(LRAA,LRAD) - D CHECK68(LRAA,LRAD) - ; - S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) - ; - ; Handle 'in common' area that was not setup in GTWLN call. - I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN)) D SETAN(LRAA,LRAD,LRAN) - ; - S LREND=0,LRLBLBP=1-$P(LRSS,U,2),LRSS=$P(LRSS,U) - S LRACC=$P(^LRO(68,LRAA,0),U,11)_" "_$S(LRAD["0000":$E(LRAD,2,3),1:$E(LRAD,4,7))_" "_LRAN - ; - S LRPRAC="" - I $D(^LRO(69,LRODT,1,LRSN,0)) S LRPRAC=$P(^(0),U,6) S:$D(LRNT) ^(3)=LRNT - ; - ; Location type - S LRCAPLOC=$P($G(^SC(+LROLLOC,0)),U,3) - I LRCAPLOC="" S LRCAPLOC="Z" - ; - ; File information in file #68 for this accession - N FDA,LR6802,LRDIE - S LR6802=LRAN_","_LRAD_","_LRAA_"," - S FDA(1,68.02,LR6802,.01)=LRDFN - S FDA(1,68.02,LR6802,1)=LRDPF - S FDA(1,68.02,LR6802,2)=LRAD - S FDA(1,68.02,LR6802,3)=LRODT - S FDA(1,68.02,LR6802,4)=LRSN - S FDA(1,68.02,LR6802,6)=LRLLOC - S X=$G(^LRO(69,LRODT,1,LRSN,.1)) I X'="" S FDA(1,68.02,LR6802,14)=X - ; - ; No ordering provider/location on controls - I LRDPF'=62.3 D - . S FDA(1,68.02,LR6802,6.5)=LRPRAC - . S FDA(1,68.02,LR6802,94)=LROLLOC - ; - ; Only store treating specialty on file #2 patients - ; If no treating specialty then use specialty from file #44 location - I LRDPF=2 D - . S LRTREA=$P($G(^DPT(DFN,.103)),U) - . I 'LRTREA S LRTREA=$P($G(^SC(+LROLLOC,0)),U,20) - . I LRTREA S FDA(1,68.02,LR6802,6.6)=LRTREA - ; - S FDA(1,68.02,LR6802,6.7)=DUZ - S FDA(1,68.02,LR6802,15)=LRACC - S FDA(1,68.02,LR6802,26)=DUZ(2) - S FDA(1,68.02,LR6802,92)=LRCAPLOC - ; - D FILE^DIE("","FDA(1)","LRDIE(1)") - I $D(LRDIE(1)) D MAILALRT - ; - ; If specimen defined then set nodes, force to ien=1 since many lab - ; routines expect the specimen to be record number 1. - I $G(LRSPEC) D - . N FDAIEN - . S FDAIEN(1)=1 - . S FDA(2,68.05,"+1,"_LR6802,.01)=LRSPEC - . S FDA(2,68.05,"+1,"_LR6802,1)=$P(LRSAMP,";",1) - . ; - . ; Modification to prevent lock failures - loop 10 times to give system a chance to get lock - . N LRLOCKOK,LRLOOPCT - . S LRLOCKOK=0 - . F LRLOOPCT=1:1:10 Q:LRLOCKOK D I 'LRLOCKOK H 5 - . . K LRDIE(2) - . . D UPDATE^DIE("","FDA(2)","FDAIEN","LRDIE(2)") - . . S:$D(LRDIE(2))=0 LRLOCKOK=1 - . K LRLOCKOK,LRLOOPCT - . ; - . ;D UPDATE^DIE("","FDA(2)","FDAIEN","LRDIE(2)") - . I $D(LRDIE(2)) D MAILALRT - ; - ; If no specimen defined then use specimen values from file #69. - I $G(LRSPEC)="",$D(^LRO(69,LRODT,1,LRSN,4,0)) D - . N FDA,FDAIEN,LRI,LRX - . S LRI=0 - . F S LRI=$O(^LRO(69,LRODT,1,LRSN,4,LRI)) Q:'LRI D - . . S FDAIEN(1)=LRI,LRX=$G(^LRO(69,LRODT,1,LRSN,4,LRI,0)) - . . S FDA(LRI,68.05,"+1,"_LR6802,.01)=$P(LRX,"^") - . . D UPDATE^DIE("","FDA(LRI)","FDAIEN","LRDIE(LRI)") - . . I $D(LRDIE(LRI)) D MAILALRT - ; - ; Create UID. - S LRUID=$$LRUID^LRX(LRAA,LRAD,LRAN) - ; - I '$D(LRPHSET),('$G(LRQUIET)) W !!,"ACCESSION: ",LRACC," <",LRUID,">" - ; - D UPD696 - ; - L -^LRO(68,LRAA,1,LRAD,1,0) - Q - ; - ; -UPD696 ; Update file #69.6 if LEDI referral patient and no existing entry - K LR696IEN - I $G(LRORDRR)="R" D - . S LR696IEN=0 - . I $G(LRRSITE("SMID"))'="",$G(LRSD("RUID"))'="" S LR696IEN=+$O(^LRO(69.6,"AD",LRRSITE("SMID"),LRSD("RUID"),0)) - . I LR696IEN Q - . I '$G(LRRSTAT(0)) S LRRSTAT(0)=$$FIND1^DIC(64.061,"","OMX","Specimen in process","","I $P(^LAB(64.061,Y,0),U,7)=""U""") - . D PSET^LRPEND(SSN(2),+LRRSITE("RSITE"),LRSD("RUID"),+LRSD("RPSITE"),LRSPEC,LRSAMP,LRRSTAT(0),LRODT,$P(LRCDT,U),LRRSITE("SDT"),LRNT,.LROT) - Q - ; - ; -ST2 ; Find next available node in LR global - ; - N FDA,FDAIEN,LRDIE,LRX,LRXIDT - ; - ; Autopsy ("AU") is not a mulitple - do not attempt to set in ^LR global - I LRSS="AU" S LRIDT=0 Q - ; - S LRIDT=0 - F D Q:LRIDT - . S LRXIDT=9999999-LRCDT - . L +^LR(LRDFN,LRSS,LRXIDT,0):5 - . I '$T S LRCDT=$$FMADD^XLFDT(LRCDT,0,0,0,1) Q - . I '$D(^LR(LRDFN,LRSS,LRXIDT,0)) S LRIDT=LRXIDT Q - . L -^LR(LRDFN,LRSS,LRXIDT,0) - . S LRCDT=$$FMADD^XLFDT(LRCDT,0,0,0,1) - ; - ; Create entry in appropriate subscript in LAB DATA file (#63). - S LRX=$S(LRSS="CH":63.04,LRSS="MI":63.05,LRSS="BB":63.01,LRSS="SP":63.08,LRSS="CY":63.09,LRSS="EM":63.02,1:0) - S FDAIEN(1)=LRIDT - S FDA(63,LRX,"+1,"_LRDFN_",",.01)=LRCDT - S FDA(63,LRX,"+1,"_LRDFN_",",.06)=LRACC - I LRSS'="CH" S FDA(63,LRX,"+1,"_LRDFN_",",.1)=LRNT - I LRSS="CH" S FDA(63,LRX,"+1,"_LRDFN_",",.12)=3 - I LRSS="MI" S FDA(63,LRX,"+1,"_LRDFN_",",38)=3 - I LRX D UPDATE^DIE("","FDA(63)","FDAIEN","LRDIE(63)") - I $D(LRDIE(63)) D MAILALRT - ; - ; Uncomment following code when new field .9 in"MI" subscript is released - ;I LRSS="MI" D - ;. N LRN,ERR,IENS - ;. S IENS=LRIDT_","_LRDFN_",",LRN=0 - ;. F S LRN=$O(^LRO(69,LRODT,1,LRSN,2,LRN)) Q:LRN<1 D - ;. . I '$D(^LRO(69,LRODT,1,LRSN,2,LRN,1,0)) Q - ;. . D WP^DIE(63.05,IENS,.9,"A","^LRO(69,"_LRODT_",1,"_LRSN_",2,"_LRN_",1)","ERR") - ; - L -^LR(LRDFN,LRSS,LRIDT,0) - ; - Q - ; - ; -GTWLN ; - N X - ; - ; Execute accession transform for this area. - S LRAN=0 - S X=$G(^LRO(68,LRWLC,.1)) X:X'="" X - ; - D GETLOCK(LRWLC,LRAD) - D CHECK68(LRWLC,LRAD) - ; - S:'LRAN LRAN=1+$P($G(^LRO(68,LRWLC,1,LRAD,1,0)),U,3) - ; - I "CYEMSP"'[LRSS F Q:'$D(^LRO(68,LRWLC,1,LRAD,1,LRAN)) S LRAN=LRAN+1 - ; - ; check for AP Accessions - I "CYEMSP"[LRSS F Q:'$D(^LRO(68,LRWLC,1,LRAD,1,LRAN))&'$D(^LR("A"_LRSS_"A",$E(LRAD,1,3),LRAN)) S LRAN=LRAN+1 - ; - I '$D(LRPHSET),$D(LRNCWL)!$P(^LAB(69.9,1,0),U,8) D ASK Q:LREND - ; - D SETAN(LRWLC,LRAD,LRAN) - ; - L -^LRO(68,LRWLC,1,LRAD,1,0) - Q - ; - ; -ASK ; - ; Don't ask if tasked or a "silent" call - I $D(ZTQUEUED)!($G(LRQUIET)) Q - ; - N DIR,DIROUT,DIRUT,DTOUT,DUOUT,LROK,LRANX,X,Y - S LROK=0 - F D Q:LREND!(LROK) - . K DIR - . S DIR(0)="NO^1:"_$S($P(LRLABKY,U,2):999999,1:LRAN)_":0" - . S DIR("A")="Force to",DIR("B")=LRAN - . D ^DIR - . I $D(DIRUT) S LREND=1 Q - . S LRANX=Y - . I LRANX<+$P($G(^LRO(68,LRWLC,1,LRAD,1,0)),U,3) D - . . W !,"This accession number may be already assigned either in this " - . . W !,"area or a common accession area." - . I $D(^LRO(68,LRWLC,1,LRAD,1,LRANX,0)) D Q:'LROK - . . N LRDFNX S LRDFNX=LRDFN - . . N DFN,LRDFN,LRDPF,PNM,SSN - . . S LRDFN=+^LRO(68,LRWLC,1,LRAD,1,LRANX,0),LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^LR(LRDFN,0),U,3) - . . D PT^LRX - . . W !,"THIS NUMBER BELONGS TO ",!,PNM," SSN: ",SSN - . . D INF^LRX - . . I LRDFN=LRDFNX S LROK=1 - . K DIR - . S DIR(0)="YO",DIR("A")="Are you sure",DIR("B")="NO" - . D ^DIR - . I $D(DIRUT) S LREND=1 Q - . I Y=1 S LRAN=LRANX,LROK=1 - ; - ; Unlock if aborting. - I LREND L -^LRO(68,LRWLC,1,LRAD,1,0) - ; - Q - ; - ; -CHECK68(LRAA,LRAD) ; Check for/set header node of ^LRO(68) 68.01 subfile. - ; - ; Call with LRAA = ien of entry in file #68 - ; LRAD = accession date in fileman format - ; - ; Set accession date in file #68 for this acession. - ; Check for existence of accession number multiple but not accession date multiple, - ; FileMan DBS call fails when accession number multiple exists but accession date multiple does not. - ; If this condition found then set missing node directly and quit. - ; - I '$D(^LRO(68,LRAA,1,LRAD,0)) D - . N FDA,FDAIEN,LRDIE,X - . S X=$Q(^LRO(68,LRAA,1,LRAD,0)) - . I X'="",$QS(X,4)=LRAD S $P(^LRO(68,LRAA,1,LRAD,0),"^")=LRAD Q - . S (FDAIEN(1),FDA(1,68.01,"+1,"_LRAA_",",.01))=LRAD - . D UPDATE^DIE("","FDA(1)","FDAIEN","LRDIE(1)") - . I $D(LRDIE(1)) D MAILALRT - ; - Q - ; - ; -GETLOCK(LRAA,LRAD) ; Obtain lock on zeroth node of this accession date - ; Call with LRAA = ien of entry in file #68 - ; LRAD = accession date in fileman format - ; - F L +^LRO(68,LRAA,1,LRAD,1,0):10 Q:$T D - . I $D(ZTQUEUED)!($G(LRQUIET)) Q - . W !!?5,"Accession area ",$P(^LRO(68,LRAA,0),"^")," is locked by another user.",!,$C(7) - Q - ; - ; -SETAN(LRAA,LRAD,LRAN) ; Create stub entry in file #68 for this acession. - ; - ; Call with LRAA = ien of entry in file #68 - ; LRAD = accession date in fileman format - ; LRAN = accession number - ; - N FDA,FDAIEN,LR6802,LRDIE - ; - S LR6802=LRAD_","_LRAA_"," - S FDAIEN(1)=LRAN - S FDA(2,68.02,"+1,"_LR6802,.01)=LRDFN - ; - ; Modification to prevent lock failures - loop 10 times to give system a chance to get lock - N LRLOCKOK,LRLOOPCT - S LRLOCKOK=0 - F LRLOOPCT=1:1:10 Q:LRLOCKOK D I 'LRLOCKOK H 5 - . K LRDIE(2) - . D UPDATE^DIE("","FDA(2)","FDAIEN","LRDIE(2)") - . S:$D(LRDIE(2))=0 LRLOCKOK=1 - K LRLOCKOK,LRLOOPCT - ; - ;D UPDATE^DIE("","FDA(2)","FDAIEN","LRDIE(2)") - I $D(LRDIE(2)) D MAILALRT - Q - ; - ; -MAILALRT ; Send mail message alert when FileMan DBS errors returned - ; - N J,LR68,LRCNT,LRMTXT,X,XMINSTR,XMSUB,XMTO - ; - I $D(^LRO(68,LRAA,1,LRAD,1,LRAN)) M LR68=^LRO(68,LRAA,1,LRAD,1,LRAN) - ; - S LRMTXT(1)="The following debugging information is provided to assist" - S LRMTXT(2)="support staff in resolving error during accessioning." - S LRMTXT(3)=" " - S LRCNT=3 - ; - F J="FDA","FDAIEN","LR68","LRAA","LRAD","LRAN","LRDFN","LRDIE","LRSS","LRTSTS","LRUNQ","LRWLC","XQY","XQY0" D - . S X=$G(@J) - . I X'="" S LRCNT=LRCNT+1,LRMTXT(LRCNT)=J_"="_X - . F S J=$Q(@J) Q:J="" S LRCNT=LRCNT+1,LRMTXT(LRCNT)=J_"="_@J - ; - S XMSUB="FileMan DBS call failed during accessioning in routine LRWLST1" - S XMTO("G.LMI")="" - S XMINSTR("FROM")=.5 - S XMINSTR("ADDR FLAGS")="R" - D SENDMSG^XMXAPI(DUZ,XMSUB,"LRMTXT",.XMTO,.XMINSTR) - Q +LRWLST1 ;DALOI/CJS/RWF/FHS - ACCESSION SETUP ; July 19, 2006 + ;;5.2;LAB SERVICE;**48,65,121,153,261,286,331**;Sep 27, 1994;Build 7 + ; + ; Reference to ^DIC(42 supported by IA #10039 + ; Reference to ^SC( supported by IA #10040 + ; + S LRWLC=0 + F S LRWLC=$O(LRTSTS(LRWLC)) Q:LRWLC<1 S LRAD=DT D SPLIT + ; + ; If LEDI and comments came with order then copy to order in #69 + I $G(LRORDRR)="R",$G(LR696),$D(^LRO(69.6,LR696,99)) D + . N LRDIE + . D WP^DIE(69.01,LRSN_","_LRODT_",",16,"A","^LRO(69.6,LR696,99)","LRDIE(16)") + ; + K DIC,DLAYGO,DR,DA,DIE,LRIXX + Q:$G(LRORDR)="P" + K LRNM,LRTSTS + K ^TMP("LR",$J,"TMP") + Q + ; +SPLIT ; + N LRAA,LRX + ; Setup regular accessions (LRUNQ=0) + S LRUNQ=0,LREND=0 + I $D(LRTSTS(LRWLC,0)) D + . D GTWLN + . I LREND Q + . S LRAA=0 + . F S LRAA=$O(LRTSTS(LRWLC,0,LRAA)) Q:LRAA<1 D + . . S LRSS=LRTSTS(LRWLC,0,LRAA) + . . D STWLN,ST2,^LRWLST11,EN^LA7ADL(LRUID) + . D SICA^LRWLST11 + ; + ; Setup accessions requiring 'unique' accession numbers (LRUNQ=1) + S LRUNQ=1,LRAA=0 + F S LRAA=$O(LRTSTS(LRWLC,1,LRAA)) Q:LRAA<1 D + . S LRSS=LRTSTS(LRWLC,1,LRAA) + . F D GTWLN Q:LREND D Q:$O(LRTSTS(LRWLC,1,LRAA,0))<1 + . . D STWLN,ST2,^LRWLST11,EN^LA7ADL(LRUID),SICA^LRWLST11 + Q + ; + ; +STWLN ; Set accession number + ; + D GETLOCK(LRAA,LRAD) + D CHECK68(LRAA,LRAD) + ; + S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) + ; + ; Handle 'in common' area that was not setup in GTWLN call. + I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN)) D SETAN(LRAA,LRAD,LRAN) + ; + S LREND=0,LRLBLBP=1-$P(LRSS,U,2),LRSS=$P(LRSS,U) + S LRACC=$P(^LRO(68,LRAA,0),U,11)_" "_$S(LRAD["0000":$E(LRAD,2,3),1:$E(LRAD,4,7))_" "_LRAN + ; + S LRPRAC="" + I $D(^LRO(69,LRODT,1,LRSN,0)) S LRPRAC=$P(^(0),U,6) S:$D(LRNT) ^(3)=LRNT + ; + ; Location type + S LRCAPLOC=$P($G(^SC(+LROLLOC,0)),U,3) + I LRCAPLOC="" S LRCAPLOC="Z" + ; + ; File information in file #68 for this accession + N FDA,LR6802,LRDIE + S LR6802=LRAN_","_LRAD_","_LRAA_"," + S FDA(1,68.02,LR6802,.01)=LRDFN + S FDA(1,68.02,LR6802,1)=LRDPF + S FDA(1,68.02,LR6802,2)=LRAD + S FDA(1,68.02,LR6802,3)=LRODT + S FDA(1,68.02,LR6802,4)=LRSN + S FDA(1,68.02,LR6802,6)=LRLLOC + S X=$G(^LRO(69,LRODT,1,LRSN,.1)) I X'="" S FDA(1,68.02,LR6802,14)=X + ; + ; No ordering provider/location on controls + I LRDPF'=62.3 D + . S FDA(1,68.02,LR6802,6.5)=LRPRAC + . S FDA(1,68.02,LR6802,94)=LROLLOC + ; + ; Only store treating specialty on file #2 patients + ; If no treating specialty then use specialty from file #44 location + I LRDPF=2 D + . S LRTREA=$P($G(^DPT(DFN,.103)),U) + . I 'LRTREA S LRTREA=$P($G(^SC(+LROLLOC,0)),U,20) + . I LRTREA S FDA(1,68.02,LR6802,6.6)=LRTREA + ; + S FDA(1,68.02,LR6802,6.7)=DUZ + S FDA(1,68.02,LR6802,15)=LRACC + S FDA(1,68.02,LR6802,26)=DUZ(2) + S FDA(1,68.02,LR6802,92)=LRCAPLOC + ; + D FILE^DIE("","FDA(1)","LRDIE(1)") + I $D(LRDIE(1)) D MAILALRT + ; + ; If specimen defined then set nodes, force to ien=1 since many lab + ; routines expect the specimen to be record number 1. + I $G(LRSPEC) D + . N FDAIEN + . S FDAIEN(1)=1 + . S FDA(2,68.05,"+1,"_LR6802,.01)=LRSPEC + . S FDA(2,68.05,"+1,"_LR6802,1)=$P(LRSAMP,";",1) + . D UPDATE^DIE("","FDA(2)","FDAIEN","LRDIE(2)") + . I $D(LRDIE(2)) D MAILALRT + ; + ; If no specimen defined then use specimen values from file #69. + I $G(LRSPEC)="",$D(^LRO(69,LRODT,1,LRSN,4,0)) D + . N FDA,FDAIEN,LRI,LRX + . S LRI=0 + . F S LRI=$O(^LRO(69,LRODT,1,LRSN,4,LRI)) Q:'LRI D + . . S FDAIEN(1)=LRI,LRX=$G(^LRO(69,LRODT,1,LRSN,4,LRI,0)) + . . S FDA(LRI,68.05,"+1,"_LR6802,.01)=$P(LRX,"^") + . . D UPDATE^DIE("","FDA(LRI)","FDAIEN","LRDIE(LRI)") + . . I $D(LRDIE(LRI)) D MAILALRT + ; + ; Create UID. + S LRUID=$$LRUID^LRX(LRAA,LRAD,LRAN) + ; + I '$D(LRPHSET),('$G(LRQUIET)) W !!,"ACCESSION: ",LRACC," <",LRUID,">" + ; + D UPD696 + ; + L -^LRO(68,LRAA,1,LRAD,1,0) + Q + ; + ; +UPD696 ; Update file #69.6 if LEDI referral patient and no existing entry + K LR696IEN + I $G(LRORDRR)="R" D + . S LR696IEN=0 + . I $G(LRRSITE("SMID"))'="",$G(LRSD("RUID"))'="" S LR696IEN=+$O(^LRO(69.6,"AD",LRRSITE("SMID"),LRSD("RUID"),0)) + . I LR696IEN Q + . I '$G(LRRSTAT(0)) S LRRSTAT(0)=$$FIND1^DIC(64.061,"","OMX","Specimen in process","","I $P(^LAB(64.061,Y,0),U,7)=""U""") + . D PSET^LRPEND(SSN(2),+LRRSITE("RSITE"),LRSD("RUID"),+LRSD("RPSITE"),LRSPEC,LRSAMP,LRRSTAT(0),LRODT,$P(LRCDT,U),LRRSITE("SDT"),LRNT,.LROT) + Q + ; + ; +ST2 ; Find next available node in LR global + ; + N FDA,FDAIEN,LRDIE,LRX,LRXIDT + ; + ; Autopsy ("AU") is not a mulitple - do not attempt to set in ^LR global + I LRSS="AU" S LRIDT=0 Q + ; + S LRIDT=0 + F D Q:LRIDT + . S LRXIDT=9999999-LRCDT + . L +^LR(LRDFN,LRSS,LRXIDT,0):5 + . I '$T S LRCDT=$$FMADD^XLFDT(LRCDT,0,0,0,1) Q + . I '$D(^LR(LRDFN,LRSS,LRXIDT,0)) S LRIDT=LRXIDT Q + . L -^LR(LRDFN,LRSS,LRXIDT,0) + . S LRCDT=$$FMADD^XLFDT(LRCDT,0,0,0,1) + ; + ; Create entry in appropriate subscript in LAB DATA file (#63). + S LRX=$S(LRSS="CH":63.04,LRSS="MI":63.05,LRSS="BB":63.01,LRSS="SP":63.08,LRSS="CY":63.09,LRSS="EM":63.02,1:0) + S FDAIEN(1)=LRIDT + S FDA(63,LRX,"+1,"_LRDFN_",",.01)=LRCDT + S FDA(63,LRX,"+1,"_LRDFN_",",.06)=LRACC + I LRSS'="CH" S FDA(63,LRX,"+1,"_LRDFN_",",.1)=LRNT + I LRSS="CH" S FDA(63,LRX,"+1,"_LRDFN_",",.12)=3 + I LRSS="MI" S FDA(63,LRX,"+1,"_LRDFN_",",38)=3 + I LRX D UPDATE^DIE("","FDA(63)","FDAIEN","LRDIE(63)") + I $D(LRDIE(63)) D MAILALRT + ; + ; Uncomment following code when new field .9 in"MI" subscript is released + ;I LRSS="MI" D + ;. N LRN,ERR,IENS + ;. S IENS=LRIDT_","_LRDFN_",",LRN=0 + ;. F S LRN=$O(^LRO(69,LRODT,1,LRSN,2,LRN)) Q:LRN<1 D + ;. . I '$D(^LRO(69,LRODT,1,LRSN,2,LRN,1,0)) Q + ;. . D WP^DIE(63.05,IENS,.9,"A","^LRO(69,"_LRODT_",1,"_LRSN_",2,"_LRN_",1)","ERR") + ; + L -^LR(LRDFN,LRSS,LRIDT,0) + ; + Q + ; + ; +GTWLN ; + N X + ; + ; Execute accession transform for this area. + S LRAN=0 + S X=$G(^LRO(68,LRWLC,.1)) X:X'="" X + ; + D GETLOCK(LRWLC,LRAD) + D CHECK68(LRWLC,LRAD) + ; + S:'LRAN LRAN=1+$P($G(^LRO(68,LRWLC,1,LRAD,1,0)),U,3) + ; + I "CYEMSP"'[LRSS F Q:'$D(^LRO(68,LRWLC,1,LRAD,1,LRAN)) S LRAN=LRAN+1 + ; + ; check for AP Accessions + I "CYEMSP"[LRSS F Q:'$D(^LRO(68,LRWLC,1,LRAD,1,LRAN))&'$D(^LR("A"_LRSS_"A",$E(LRAD,1,3),LRAN)) S LRAN=LRAN+1 + ; + I '$D(LRPHSET),$D(LRNCWL)!$P(^LAB(69.9,1,0),U,8) D ASK Q:LREND + ; + D SETAN(LRWLC,LRAD,LRAN) + ; + L -^LRO(68,LRWLC,1,LRAD,1,0) + Q + ; + ; +ASK ; + ; Don't ask if tasked or a "silent" call + I $D(ZTQUEUED)!($G(LRQUIET)) Q + ; + N DIR,DIROUT,DIRUT,DTOUT,DUOUT,LROK,LRANX,X,Y + S LROK=0 + F D Q:LREND!(LROK) + . K DIR + . S DIR(0)="NO^1:"_$S($P(LRLABKY,U,2):999999,1:LRAN)_":0" + . S DIR("A")="Force to",DIR("B")=LRAN + . D ^DIR + . I $D(DIRUT) S LREND=1 Q + . S LRANX=Y + . I LRANX<+$P($G(^LRO(68,LRWLC,1,LRAD,1,0)),U,3) D + . . W !,"This accession number may be already assigned either in this " + . . W !,"area or a common accession area." + . I $D(^LRO(68,LRWLC,1,LRAD,1,LRANX,0)) D Q:'LROK + . . N LRDFNX S LRDFNX=LRDFN + . . N DFN,LRDFN,LRDPF,PNM,SSN + . . S LRDFN=+^LRO(68,LRWLC,1,LRAD,1,LRANX,0),LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^LR(LRDFN,0),U,3) + . . D PT^LRX + . . W !,"THIS NUMBER BELONGS TO ",!,PNM," SSN: ",SSN + . . D INF^LRX + . . I LRDFN=LRDFNX S LROK=1 + . K DIR + . S DIR(0)="YO",DIR("A")="Are you sure",DIR("B")="NO" + . D ^DIR + . I $D(DIRUT) S LREND=1 Q + . I Y=1 S LRAN=LRANX,LROK=1 + ; + ; Unlock if aborting. + I LREND L -^LRO(68,LRWLC,1,LRAD,1,0) + ; + Q + ; + ; +CHECK68(LRAA,LRAD) ; Check for/set header node of ^LRO(68) 68.01 subfile. + ; + ; Call with LRAA = ien of entry in file #68 + ; LRAD = accession date in fileman format + ; + ; Set accession date in file #68 for this acession. + ; Check for existence of accession number multiple but not accession date multiple, + ; FileMan DBS call fails when accession number multiple exists but accession date multiple does not. + ; If this condition found then set missing node directly and quit. + ; + I '$D(^LRO(68,LRAA,1,LRAD,0)) D + . N FDA,FDAIEN,LRDIE,X + . S X=$Q(^LRO(68,LRAA,1,LRAD,0)) + . I X'="",$QS(X,4)=LRAD S $P(^LRO(68,LRAA,1,LRAD,0),"^")=LRAD Q + . S (FDAIEN(1),FDA(1,68.01,"+1,"_LRAA_",",.01))=LRAD + . D UPDATE^DIE("","FDA(1)","FDAIEN","LRDIE(1)") + . I $D(LRDIE(1)) D MAILALRT + ; + Q + ; + ; +GETLOCK(LRAA,LRAD) ; Obtain lock on zeroth node of this accession date + ; Call with LRAA = ien of entry in file #68 + ; LRAD = accession date in fileman format + ; + F L +^LRO(68,LRAA,1,LRAD,1,0):10 Q:$T D + . I $D(ZTQUEUED)!($G(LRQUIET)) Q + . W !!?5,"Accession area ",$P(^LRO(68,LRAA,0),"^")," is locked by another user.",!,$C(7) + Q + ; + ; +SETAN(LRAA,LRAD,LRAN) ; Create stub entry in file #68 for this acession. + ; + ; Call with LRAA = ien of entry in file #68 + ; LRAD = accession date in fileman format + ; LRAN = accession number + ; + N FDA,FDAIEN,LR6802,LRDIE + ; + S LR6802=LRAD_","_LRAA_"," + S FDAIEN(1)=LRAN + S FDA(2,68.02,"+1,"_LR6802,.01)=LRDFN + D UPDATE^DIE("","FDA(2)","FDAIEN","LRDIE(2)") + I $D(LRDIE(2)) D MAILALRT + Q + ; + ; +MAILALRT ; Send mail message alert when FileMan DBS errors returned + ; + N J,LR68,LRCNT,LRMTXT,X,XMINSTR,XMSUB,XMTO + ; + I $D(^LRO(68,LRAA,1,LRAD,1,LRAN)) M LR68=^LRO(68,LRAA,1,LRAD,1,LRAN) + ; + S LRMTXT(1)="The following debugging information is provided to assist" + S LRMTXT(2)="support staff in resolving error during accessioning." + S LRMTXT(3)=" " + S LRCNT=3 + ; + F J="FDA","FDAIEN","LR68","LRAA","LRAD","LRAN","LRDFN","LRDIE","LRSS","LRTSTS","LRUNQ","LRWLC","XQY","XQY0" D + . S X=$G(@J) + . I X'="" S LRCNT=LRCNT+1,LRMTXT(LRCNT)=J_"="_X + . F S J=$Q(@J) Q:J="" S LRCNT=LRCNT+1,LRMTXT(LRCNT)=J_"="_@J + ; + S XMSUB="FileMan DBS call failed during accessioning in routine LRWLST1" + S XMTO("G.LMI")="" + S XMINSTR("FROM")=.5 + S XMINSTR("ADDR FLAGS")="R" + D SENDMSG^XMXAPI(DUZ,XMSUB,"LRMTXT",.XMTO,.XMINSTR) + Q diff --git a/r/LAB_SERVICE-LR-LS/LRWLST11.m b/r/LAB_SERVICE-LR-LS/LRWLST11.m index aeffb671..f071bc92 100644 --- a/r/LAB_SERVICE-LR-LS/LRWLST11.m +++ b/r/LAB_SERVICE-LR-LS/LRWLST11.m @@ -1,191 +1,191 @@ -LRWLST11 ;DALOI/CJS,RWF/FHS - ACCESSION SETUP ;July 19, 2006 - ;;5.2;LAB SERVICE;**121,128,153,202,286,331,375**;Sep 27, 1994;Build 3 - ; -ST21 ; - S LRTS="",LRIX=0 - F S LRIX=$O(LRTSTS(LRWLC,LRUNQ,LRAA,LRIX)) Q:LRIX<1 D SET Q:LRUNQ - ; - S LRNT=$$NOW^XLFDT - D SCDT,SLRSS - ; -COMMON ; Setup 'in common' accession if not already setup unless it will be - ; when tests are acessioned to the 'in common' area. - I +LRWLC,+LRWLC'=+LRAA,$G(^LRO(68,LRWLC,1,LRAD,1,LRAN,0))=$G(LRDFN) D - . I 'LRUNQ,$D(LRTSTS(LRWLC,LRUNQ,LRWLC)) Q - . Q:$G(^LRO(68,LRWLC,1,LRAD,1,LRAN,.1)) - . N LRAA,LRACC,LRCDTX,LRCOMMON,LREND,LRIDT,LRNODE3,LRORDRR,LRORU3,LRQUIET,LRTJ,LRUID,X,Y - . S (LRQUIET,LRCOMMON)=1,LRAA=+LRWLC,LRORDRR="" - . S X=LRSS,LRCDTX=LRCDT - . N LRCDT,LRSS - . S LRCDT=LRCDTX,LRSS=X_U_(1+$G(LRLBLBP)) - . D STWLN^LRWLST1 Q:$G(LREND) - . D ST2^LRWLST1 Q:$G(LREND) - . D SCDT,SLRSS - ; - Q - ; - ; -SCDT ; Set collection, inverse and lab arrival date/times on accession - N FDA,LR6802,LRDIE - S LR6802=LRAN_","_LRAD_","_LRAA_"," - S FDA(4,68.02,LR6802,9)=LRCDT - S FDA(4,68.02,LR6802,10)=LREAL - I '$D(LRPHSET) S FDA(4,68.02,LR6802,12)=LRNT - S FDA(4,68.02,LR6802,13.5)=LRIDT - D FILE^DIE("","FDA(4)","LRDIE(4)") - I $D(LRDIE(4)) D MAILALRT^LRWLST1 - Q - ; - ; -SLRSS ; - ; - S X=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0)) ; change for AP - S H8=$S($D(LRSPEC):LRSPEC,1:X)_U_$S("CYEMSPAU"[LRSS:LRACC,1:LRACC)_U_$S(LRSS="MI":LRPRAC,1:"")_U_$S(LRSS="MI":LRLLOC,1:"")_"^^"_$S(LRSS="CH":LRPRAC,1:"")_"^"_$S(LRSS="MI":$P(LRSAMP,";",1),LRSS="CH":LRLLOC,1:"") - ; - I $S(LRSS="CH":1,LRSS="MI":1,1:0) D - . I $G(LRORDRR)="R",+$G(LRRSITE("RSITE")) S $P(H8,U,9)=+LRRSITE("RSITE")_";DIC(4," - . I $G(LROLLOC),$G(LRORDRR)'="R" S $P(H8,U,9)=LROLLOC_";SC(" - . S $P(H8,U,10)=$S($G(LRDUZ(2)):LRDUZ(2),1:$G(DUZ(2))) - ; - S ^LR(LRDFN,LRSS,LRIDT,0)=LRCDT_U_LREAL_"^^^"_H8 - I $G(LRORU3)'="" S ^LR(LRDFN,LRSS,LRIDT,"ORU")=LRORU3 - ; -ST3 D ST4:(LRSS="MI"),LRCCOM - ; - S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3),LRPR=1 - S LRRB=0 - I LRDPF=2 S LRRB=$$GET1^DIQ(2,DFN_",",.101),LRRB=$S(LRRB'="":LRRB,1:0) - ; - Q:$G(LRORDR)="P" - ; - I '$D(LRTJ) D Q - . I $G(LRORDRR)="R",LRSS="CH",$G(LRORU3)'="",$P(LRORU3,"^")'=$P(LRORU3,"^",4) Q ; Don't print, use label from sending facility. - . I LRLBLBP,'$G(LRCOMMON) S LRLBL(LRAA,LRAN)=LRSN_U_LRAD_U_LRODT_U_LRRB_U_LRLLOC_U_LRACC_U_$S($D(LRORD):LRORD,1:"") - S I=0 - F S I=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I)) Q:I<.5 S LRTS=^(I,0) D Z - Q - ; - ; -ST4 ; - S $P(^LR(LRDFN,LRSS,LRIDT,0),U,10)=$S($D(LRNT):LRNT,1:""),$P(^(0),U,8)=LRLLOC - ; Used to be LRSPCDSC,63.05,.9 (Word Processing field) replaces 63.05,.99 - S:$D(LRCCOM) ^LR(LRDFN,LRSS,LRIDT,99)=LRCCOM - I '$D(LRPHSET) D - . N DA,DIE,DR - . S DIE="^LR("_LRDFN_",""MI"",",DA=LRIDT,DA(1)=LRDFN - . ;S DR=.9 - . ;I '$G(LRQUIET) W:DR'=.9 !!,"Order comment:" - . S DR=.99_$S($L($G(LRGCOM)):"///"_LRGCOM,$L($G(LRCCOM)):"//"_LRCCOM,1:"") - . I '$G(LRQUIET) W:DR'=.99 !!,"Order comment:" - . D ^DIE - I '$G(LRQUIET),'$D(LRPHSET),'$D(LRGCOM) W !,"Description OK? Y//" D % G ST4:%["N" - K DR,DIC,DIE - Q - ; - ; -ST5 S I("SUBSC")=$S(I("EDIT")[11.5:26,I("EDIT")[15:27,I("EDIT")[19:28,I("EDIT")[23:29,I("EDIT")[34:30,1:-1) Q:I("SUBSC")=-1 - S I("PNTR")=$S(I("EDIT")[11.5:"^63.061A^",I("EDIT")[15:"^63.361A^",I("EDIT")[19:"^63.111A^",I("EDIT")[23:"^63.181A^",1:"^63.432A^") - S I("N")=1+$S($D(^LR(LRDFN,"MI",LRIDT,I("SUBSC"),0)):$P(^(0),U,4),1:0),^(0)=I("PNTR")_I("N")_U_I("N"),^(I("N"),0)=I("TEST") - Q - ; - ; -SET S LRTS=LRTSTS(LRWLC,LRUNQ,LRAA,LRIX),LRIN=$P(LRTS,U,3),LRORIFN=$P(LRTS,U,4),LRTSORU=+$P(LRTS,U,6),LRTS=$P(LRTS,U,1,2),LRBACK=$P(LRTS,U,5) - ; - I '$G(LRQUIET),'$D(LRPHSET) D - . W !,$P(^LAB(60,+LRTS,0),U) - . I $D(LRSPEC),LRSPEC D - . . S I=$S($D(^LAB(61,+LRSPEC,0)):$P(^(0),U),1:""),J=$S($D(^LAB(62,+LRSAMP,0)):$P(^(0),U),1:"") - . . W ?30,J W:I'=J " ",I - ; - I '$G(LRQUIET),'$D(LRPHSET),+LRTS,$O(^LAB(60,+LRTS,7,0))>0 D - . N S - . S DIC="^LAB(60,",DA=+LRTS,DR=7 - . D EN^DIQ H 3 - I '$G(LRQUIET),'$D(LRPHSET),+LRTS D - . N S - . S DIC="^LAB(60,"_(+LRTS)_",3," - . S DA=+$O(^LAB(60,+LRTS,3,"B",+LRSAMP,0)),DR=2 - . I DA>0,$O(^LAB(60,+LRTS,3,DA,2,0))>0 D EN^DIQ H 3 - ; - D ORUT - D CAP^LRWLST12 - K LRTSTS(LRWLC,LRUNQ,LRAA,LRIX) - ; - S ^LRO(69,LRODT,1,LRSN,2,LRIN,0)=LRTS_U_LRAD_U_LRAA_U_LRAN_"^^"_LRORIFN_"^^IP^L^^^^"_LRBACK - S ^LRO(69,LRODT,1,LRSN,2,"B",+LRTS,LRIN)="" - ; - ; When file 63 is enhanced to accept comments per test comments should - ; be put there instead of field 99. - I $O(^LRO(69,LRODT,1,LRSN,2,LRIN,1,0)) D - . I LRSS'="CH"!($D(^LR(LRDFN,LRSS,LRIDT,0))[0) Q - . S X=$S($D(^LR(LRDFN,LRSS,LRIDT,1,0)):$P(^(0),"^",3),1:0),I=0 - . F S I=$O(^LRO(69,LRODT,1,LRSN,2,LRIN,1,I)) Q:I<1 S II=^(I,0) S X=X+1,^LR(LRDFN,LRSS,LRIDT,1,X,0)=II - . S:X ^LR(LRDFN,LRSS,LRIDT,1,0)="^63.041^"_X_U_X - ; -RUID I $G(LRORU3)'="" D - . N DA,DIE,DIC,DLAYGO,DR,X,Y - . S DLAYGO=69 - . S DA=LRIN,DA(1)=LRSN,DA(2)=LRODT,DIC="^LRO(69,"_DA(2)_",1,"_DA(1)_",2," - . S DIE=DIC,DR="13////"_$P(LRORU3,U)_";14////"_$P(LRORU3,U,2)_";15////"_$P(LRORU3,U,3)_";16////"_$P(LRORU3,U,4)_";17////"_$P(LRORU3,U,5) - . D ^DIE - Q - ; - ; -% R %:DTIME Q:%=""!(%["N")!(%["Y") W !,"Answer 'Y' or 'N': " G % - ; - ; -LRCCOM ; - N I,LRCCOM,LRTN,X - S (I,LRTN,LRCCOM)=0 Q:LRSS'="CH"!($D(^LR(LRDFN,LRSS,LRIDT,0))[0) - F S I=$O(^LRO(69,LRODT,1,LRSN,6,I)) Q:I<1 I $D(^(I,0)) S X=^(0),LRCCOM=LRCCOM+1,^LR(LRDFN,LRSS,LRIDT,1,LRCCOM,0)=X - F S LRTN=$O(^LRO(69,LRODT,1,LRSN,2,LRTN)) Q:'LRTN I $D(^(LRTN,0)) S X=^(0) I $P(X,"^",8),'$P(X,"^",3),$O(^(1,0)) D ;Get comments for expanded panels - . S I=0 F S I=$O(^LRO(69,LRODT,1,LRSN,2,LRTN,1,I)) Q:'I I $D(^(I,0)) S X=^(0),LRCCOM=LRCCOM+1,^LR(LRDFN,LRSS,LRIDT,1,LRCCOM,0)=X - S:LRCCOM ^LR(LRDFN,LRSS,LRIDT,1,0)="^63.041^"_LRCCOM_U_LRCCOM - Q - ; - ; -Z L +^LRO(69.1,LRTE) - S LRZ3=$S($D(^LRO(69.1,LRTE,1,0)):$P(^(0),U,3),1:0) -Z1 S LRZ3=LRZ3+1 G:$D(^LRO(69.1,LRTE,1,LRZ3)) Z1 - S LRZO="^LRO(69.1,"_LRTE_",1,",LRZ1="69.11P",LRZB=+LRTS,LRIFN=LRZ3 - D Z^LRWU - S ^LRO(69.1,LRTE,1,LRIFN,0)=+LRTS_"^"_LRLLOC_"^"_LRRB_"^"_LRDFN_"^"_LRSN_"^"_LRTJ_"^"_LRAD_"^"_LRAA_"^"_LRAN_"^"_+LROLLOC - S ^LRO(69.1,"LRPH",LRTE,LRLLOC,LRRB,LRDFN,LRSN)=LRTJ_"^"_LRAD_"^"_LRIFN,^(LRSN,LRAA,LRAN,+LRTS)=+LRTS - L -^LRO(69.1,LRTE) - Q - ; - ; -ORUT Q:'$G(LRTSORU)!($G(LRSS)'="CH") - N LRTT,DLAYGO,DIC,DIE,DR,LRTST,DA,LRURG - S DA=LRIDT,DA(1)=LRDFN - S LRNLT=$$NLT^LRVER1(+LRTSORU) Q:+LRNLT<1 Q:$D(^LR(DA(1),LRSS,DA,"ORUT","B",LRNLT)) - S DR=".35///^S X=LRNLT",DR(1)=".35" - S DR(1,63.04)=".35///^S X=LRNLT" - S DR(1,63.07)=".01///^S X=LRNLT" - S DIC="^LR("_DA(1)_","""_LRSS_"""," - S DIC(0)="MNL",DIE=DIC W:$G(LRDBUG) !,LRNLT - D ^DIE - ; -ORUT2 S LRTST=$P($G(^LAM($O(^LAM("E",LRNLT,0)),0)),U) Q:LRTST=""!('$G(LR696IEN)) - Q:'($D(^LRO(69.6,LR696IEN,0))#2)!($D(^LRO(69.6,LR696IEN,2,"C",LRNLT))) - S:'$D(^LRO(69.6,LR696IEN,2,0)) ^(0)="^69.64A^" - S DLAYGO=69.6 - K DIC,DIE,DA,DR,DA - S DA=LR696IEN - S LRURG="R",LRURG=$S($L($P($G(^LAB(62.05,+$P(LRTS,U,2),0)),U,4)):$P(^(0),U,4),1:LRURG) - S (DIE,DIC)="^LRO(69.6,",DIC(0)="LM" - S DR=20_"///"_LRTST_";",DR(1,69.6)="20///"_LRTST_";" - S DR(2,69.64)=".01///"_LRTST_";1///"_LRNLT_";4///"_LRURG_";5////160;8///"_LRNT_";9///"_LRUID - D ^DIE - Q - ; - ; -SICA ; Check accessions 'in common' and setup reference to this accession - N FDA,LR6802,LRDIE,LRAA - S LRX=$P($G(^LRO(68,LRWLC,1,LRAD,1,LRAN,.2)),"^"),LRAA=0 - F S LRAA=$O(LRTSTS(LRWLC,LRUNQ,LRAA)) Q:LRAA<1 I LRWLC'=LRAA D - . S LR6802=LRAN_","_LRAD_","_LRAA_"," - . S FDA(5,68.02,LR6802,15.1)=LRX - . D FILE^DIE("","FDA(5)","LRDIE(5)") - . I $D(LRDIE(5)) D MAILALRT^LRWLST1 - Q +LRWLST11 ;DALOI/CJS,RWF/FHS - ACCESSION SETUP ;July 19, 2006 + ;;5.2;LAB SERVICE;**121,128,153,202,286,331**;Sep 27, 1994;Build 7 + ; +ST21 ; + S LRTS="",LRIX=0 + F S LRIX=$O(LRTSTS(LRWLC,LRUNQ,LRAA,LRIX)) Q:LRIX<1 D SET Q:LRUNQ + ; + S LRNT=$$NOW^XLFDT + D SCDT,SLRSS + ; +COMMON ; Setup 'in common' accession if not already setup unless it will be + ; when tests are acessioned to the 'in common' area. + I +LRWLC,+LRWLC'=+LRAA,$G(^LRO(68,LRWLC,1,LRAD,1,LRAN,0))=$G(LRDFN) D + . I $D(LRTSTS(LRWLC,LRUNQ,LRWLC)) Q + . Q:$G(^LRO(68,LRWLC,1,LRAD,1,LRAN,.1)) + . N LRAA,LRACC,LRCDTX,LRCOMMON,LREND,LRIDT,LRNODE3,LRORDRR,LRORU3,LRQUIET,LRTJ,LRUID,X,Y + . S (LRQUIET,LRCOMMON)=1,LRAA=+LRWLC,LRORDRR="" + . S X=LRSS,LRCDTX=LRCDT + . N LRCDT,LRSS + . S LRCDT=LRCDTX,LRSS=X_U_(1+$G(LRLBLBP)) + . D STWLN^LRWLST1 Q:$G(LREND) + . D ST2^LRWLST1 Q:$G(LREND) + . D SCDT,SLRSS + ; + Q + ; + ; +SCDT ; Set collection, inverse and lab arrival date/times on accession + N FDA,LR6802,LRDIE + S LR6802=LRAN_","_LRAD_","_LRAA_"," + S FDA(4,68.02,LR6802,9)=LRCDT + S FDA(4,68.02,LR6802,10)=LREAL + I '$D(LRPHSET) S FDA(4,68.02,LR6802,12)=LRNT + S FDA(4,68.02,LR6802,13.5)=LRIDT + D FILE^DIE("","FDA(4)","LRDIE(4)") + I $D(LRDIE(4)) D MAILALRT^LRWLST1 + Q + ; + ; +SLRSS ; + ; + S X=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0)) ; change for AP + S H8=$S($D(LRSPEC):LRSPEC,1:X)_U_$S("CYEMSPAU"[LRSS:LRACC,1:LRACC)_U_$S(LRSS="MI":LRPRAC,1:"")_U_$S(LRSS="MI":LRLLOC,1:"")_"^^"_$S(LRSS="CH":LRPRAC,1:"")_"^"_$S(LRSS="MI":$P(LRSAMP,";",1),LRSS="CH":LRLLOC,1:"") + ; + I $S(LRSS="CH":1,LRSS="MI":1,1:0) D + . I $G(LRORDRR)="R",+$G(LRRSITE("RSITE")) S $P(H8,U,9)=+LRRSITE("RSITE")_";DIC(4," + . I $G(LROLLOC),$G(LRORDRR)'="R" S $P(H8,U,9)=LROLLOC_";SC(" + . S $P(H8,U,10)=$S($G(LRDUZ(2)):LRDUZ(2),1:$G(DUZ(2))) + ; + S ^LR(LRDFN,LRSS,LRIDT,0)=LRCDT_U_LREAL_"^^^"_H8 + I $G(LRORU3)'="" S ^LR(LRDFN,LRSS,LRIDT,"ORU")=LRORU3 + ; +ST3 D ST4:(LRSS="MI"),LRCCOM + ; + S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3),LRPR=1 + S LRRB=0 + I LRDPF=2 S LRRB=$$GET1^DIQ(2,DFN_",",.101),LRRB=$S(LRRB'="":LRRB,1:0) + ; + Q:$G(LRORDR)="P" + ; + I '$D(LRTJ) D Q + . I $G(LRORDRR)="R",LRSS="CH",$G(LRORU3)'="",$P(LRORU3,"^")'=$P(LRORU3,"^",4) Q ; Don't print, use label from sending facility. + . I LRLBLBP,'$G(LRCOMMON) S LRLBL(LRAA,LRAN)=LRSN_U_LRAD_U_LRODT_U_LRRB_U_LRLLOC_U_LRACC_U_$S($D(LRORD):LRORD,1:"") + S I=0 + F S I=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I)) Q:I<.5 S LRTS=^(I,0) D Z + Q + ; + ; +ST4 ; + S $P(^LR(LRDFN,LRSS,LRIDT,0),U,10)=$S($D(LRNT):LRNT,1:""),$P(^(0),U,8)=LRLLOC + ; Used to be LRSPCDSC,63.05,.9 (Word Processing field) replaces 63.05,.99 + S:$D(LRCCOM) ^LR(LRDFN,LRSS,LRIDT,99)=LRCCOM + I '$D(LRPHSET) D + . N DA,DIE,DR + . S DIE="^LR("_LRDFN_",""MI"",",DA=LRIDT,DA(1)=LRDFN + . ;S DR=.9 + . ;I '$G(LRQUIET) W:DR'=.9 !!,"Order comment:" + . S DR=.99_$S($L($G(LRGCOM)):"///"_LRGCOM,$L($G(LRCCOM)):"//"_LRCCOM,1:"") + . I '$G(LRQUIET) W:DR'=.99 !!,"Order comment:" + . D ^DIE + I '$G(LRQUIET),'$D(LRPHSET),'$D(LRGCOM) W !,"Description OK? Y//" D % G ST4:%["N" + K DR,DIC,DIE + Q + ; + ; +ST5 S I("SUBSC")=$S(I("EDIT")[11.5:26,I("EDIT")[15:27,I("EDIT")[19:28,I("EDIT")[23:29,I("EDIT")[34:30,1:-1) Q:I("SUBSC")=-1 + S I("PNTR")=$S(I("EDIT")[11.5:"^63.061A^",I("EDIT")[15:"^63.361A^",I("EDIT")[19:"^63.111A^",I("EDIT")[23:"^63.181A^",1:"^63.432A^") + S I("N")=1+$S($D(^LR(LRDFN,"MI",LRIDT,I("SUBSC"),0)):$P(^(0),U,4),1:0),^(0)=I("PNTR")_I("N")_U_I("N"),^(I("N"),0)=I("TEST") + Q + ; + ; +SET S LRTS=LRTSTS(LRWLC,LRUNQ,LRAA,LRIX),LRIN=$P(LRTS,U,3),LRORIFN=$P(LRTS,U,4),LRTSORU=+$P(LRTS,U,6),LRTS=$P(LRTS,U,1,2),LRBACK=$P(LRTS,U,5) + ; + I '$G(LRQUIET),'$D(LRPHSET) D + . W !,$P(^LAB(60,+LRTS,0),U) + . I $D(LRSPEC),LRSPEC D + . . S I=$S($D(^LAB(61,+LRSPEC,0)):$P(^(0),U),1:""),J=$S($D(^LAB(62,+LRSAMP,0)):$P(^(0),U),1:"") + . . W ?30,J W:I'=J " ",I + ; + I '$G(LRQUIET),'$D(LRPHSET),+LRTS,$O(^LAB(60,+LRTS,7,0))>0 D + . N S + . S DIC="^LAB(60,",DA=+LRTS,DR=7 + . D EN^DIQ H 3 + I '$G(LRQUIET),'$D(LRPHSET),+LRTS D + . N S + . S DIC="^LAB(60,"_(+LRTS)_",3," + . S DA=+$O(^LAB(60,+LRTS,3,"B",+LRSAMP,0)),DR=2 + . I DA>0,$O(^LAB(60,+LRTS,3,DA,2,0))>0 D EN^DIQ H 3 + ; + D ORUT + D CAP^LRWLST12 + K LRTSTS(LRWLC,LRUNQ,LRAA,LRIX) + ; + S ^LRO(69,LRODT,1,LRSN,2,LRIN,0)=LRTS_U_LRAD_U_LRAA_U_LRAN_"^^"_LRORIFN_"^^IP^L^^^^"_LRBACK + S ^LRO(69,LRODT,1,LRSN,2,"B",+LRTS,LRIN)="" + ; + ; When file 63 is enhanced to accept comments per test comments should + ; be put there instead of field 99. + I $O(^LRO(69,LRODT,1,LRSN,2,LRIN,1,0)) D + . I LRSS'="CH"!($D(^LR(LRDFN,LRSS,LRIDT,0))[0) Q + . S X=$S($D(^LR(LRDFN,LRSS,LRIDT,1,0)):$P(^(0),"^",3),1:0),I=0 + . F S I=$O(^LRO(69,LRODT,1,LRSN,2,LRIN,1,I)) Q:I<1 S II=^(I,0) S X=X+1,^LR(LRDFN,LRSS,LRIDT,1,X,0)=II + . S:X ^LR(LRDFN,LRSS,LRIDT,1,0)="^63.041^"_X_U_X + ; +RUID I $G(LRORU3)'="" D + . N DA,DIE,DIC,DLAYGO,DR,X,Y + . S DLAYGO=69 + . S DA=LRIN,DA(1)=LRSN,DA(2)=LRODT,DIC="^LRO(69,"_DA(2)_",1,"_DA(1)_",2," + . S DIE=DIC,DR="13////"_$P(LRORU3,U)_";14////"_$P(LRORU3,U,2)_";15////"_$P(LRORU3,U,3)_";16////"_$P(LRORU3,U,4)_";17////"_$P(LRORU3,U,5) + . D ^DIE + Q + ; + ; +% R %:DTIME Q:%=""!(%["N")!(%["Y") W !,"Answer 'Y' or 'N': " G % + ; + ; +LRCCOM ; + N I,LRCCOM,LRTN,X + S (I,LRTN,LRCCOM)=0 Q:LRSS'="CH"!($D(^LR(LRDFN,LRSS,LRIDT,0))[0) + F S I=$O(^LRO(69,LRODT,1,LRSN,6,I)) Q:I<1 I $D(^(I,0)) S X=^(0),LRCCOM=LRCCOM+1,^LR(LRDFN,LRSS,LRIDT,1,LRCCOM,0)=X + F S LRTN=$O(^LRO(69,LRODT,1,LRSN,2,LRTN)) Q:'LRTN I $D(^(LRTN,0)) S X=^(0) I $P(X,"^",8),'$P(X,"^",3),$O(^(1,0)) D ;Get comments for expanded panels + . S I=0 F S I=$O(^LRO(69,LRODT,1,LRSN,2,LRTN,1,I)) Q:'I I $D(^(I,0)) S X=^(0),LRCCOM=LRCCOM+1,^LR(LRDFN,LRSS,LRIDT,1,LRCCOM,0)=X + S:LRCCOM ^LR(LRDFN,LRSS,LRIDT,1,0)="^63.041^"_LRCCOM_U_LRCCOM + Q + ; + ; +Z L +^LRO(69.1,LRTE) + S LRZ3=$S($D(^LRO(69.1,LRTE,1,0)):$P(^(0),U,3),1:0) +Z1 S LRZ3=LRZ3+1 G:$D(^LRO(69.1,LRTE,1,LRZ3)) Z1 + S LRZO="^LRO(69.1,"_LRTE_",1,",LRZ1="69.11P",LRZB=+LRTS,LRIFN=LRZ3 + D Z^LRWU + S ^LRO(69.1,LRTE,1,LRIFN,0)=+LRTS_"^"_LRLLOC_"^"_LRRB_"^"_LRDFN_"^"_LRSN_"^"_LRTJ_"^"_LRAD_"^"_LRAA_"^"_LRAN_"^"_+LROLLOC + S ^LRO(69.1,"LRPH",LRTE,LRLLOC,LRRB,LRDFN,LRSN)=LRTJ_"^"_LRAD_"^"_LRIFN,^(LRSN,LRAA,LRAN,+LRTS)=+LRTS + L -^LRO(69.1,LRTE) + Q + ; + ; +ORUT Q:'$G(LRTSORU)!($G(LRSS)'="CH") + N LRTT,DLAYGO,DIC,DIE,DR,LRTST,DA,LRURG + S DA=LRIDT,DA(1)=LRDFN + S LRNLT=$$NLT^LRVER1(+LRTSORU) Q:+LRNLT<1 Q:$D(^LR(DA(1),LRSS,DA,"ORUT","B",LRNLT)) + S DR=".35///^S X=LRNLT",DR(1)=".35" + S DR(1,63.04)=".35///^S X=LRNLT" + S DR(1,63.07)=".01///^S X=LRNLT" + S DIC="^LR("_DA(1)_","""_LRSS_"""," + S DIC(0)="MNL",DIE=DIC W:$G(LRDBUG) !,LRNLT + D ^DIE + ; +ORUT2 S LRTST=$P($G(^LAM($O(^LAM("E",LRNLT,0)),0)),U) Q:LRTST=""!('$G(LR696IEN)) + Q:'($D(^LRO(69.6,LR696IEN,0))#2)!($D(^LRO(69.6,LR696IEN,2,"C",LRNLT))) + S:'$D(^LRO(69.6,LR696IEN,2,0)) ^(0)="^69.64A^" + S DLAYGO=69.6 + K DIC,DIE,DA,DR,DA + S DA=LR696IEN + S LRURG="R",LRURG=$S($L($P($G(^LAB(62.05,+$P(LRTS,U,2),0)),U,4)):$P(^(0),U,4),1:LRURG) + S (DIE,DIC)="^LRO(69.6,",DIC(0)="LM" + S DR=20_"///"_LRTST_";",DR(1,69.6)="20///"_LRTST_";" + S DR(2,69.64)=".01///"_LRTST_";1///"_LRNLT_";4///"_LRURG_";5////160;8///"_LRNT_";9///"_LRUID + D ^DIE + Q + ; + ; +SICA ; Check accessions 'in common' and setup reference to this accession + N FDA,LR6802,LRDIE,LRAA + S LRX=$P($G(^LRO(68,LRWLC,1,LRAD,1,LRAN,.2)),"^"),LRAA=0 + F S LRAA=$O(LRTSTS(LRWLC,LRUNQ,LRAA)) Q:LRAA<1 I LRWLC'=LRAA D + . S LR6802=LRAN_","_LRAD_","_LRAA_"," + . S FDA(5,68.02,LR6802,15.1)=LRX + . D FILE^DIE("","FDA(5)","LRDIE(5)") + . I $D(LRDIE(5)) D MAILALRT^LRWLST1 + Q diff --git a/r/LAB_SERVICE-LR-LS/LRWOMEN.m b/r/LAB_SERVICE-LR-LS/LRWOMEN.m index 6b442b33..d8041dc4 100644 --- a/r/LAB_SERVICE-LR-LS/LRWOMEN.m +++ b/r/LAB_SERVICE-LR-LS/LRWOMEN.m @@ -1,40 +1,40 @@ -LRWOMEN ;DALOI/CYM/FT/CKA - LINK TO WOMEN'S HEALTH PROGRAM ;10/22/04 13:14 - ;;5.2;LAB SERVICE;**231,248,311,324,365**;Sep 27, 1994;Build 9 - ; - ;Reference to CREATE^WVLRLINK supported by IA #2772 - ;Reference to DELETE^WVLRLINK supported by IA #2772 - ;Reference to CREATE^WVLABCHK supported by IA #4525 - ; -ADD ; From DD 63.08,.11 and 63.09,.11 - Q:+$G(LRDPF)'=2 - Q:'$D(LRSS) - Q:$P(^LR(LRDFN,LRSS,LRI,0),U,11)']"" - Q:$G(SEX)'["F" - Q:$T(CREATE^WVLRLINK)']"" - D CREATE^WVLRLINK(DFN,LRDFN,LRI,$G(LRA),LRSS) - Q - ; - ; -DEL ; From LRAPM - Q:$G(SEX)'["F" - Q:+$G(LRDPF)'=2 - Q:'$D(LRSS) - Q:$P(^LR(LRDFN,LRSS,LRI,0),U,11)]"" - Q:$T(DELETE^WVLRLINK)']"" - D DELETE^WVLRLINK(DFN,LRDFN,LRI,X,LRSS) - Q - ; - ; -MOVE ; From LRAPMV - ; no longer used after LR*5.2*259 - Q - ; - ; -SNOMED ; From DD 63.08,10 and 63.09,10 - Q:+$G(LRDPF)'=2 - Q:'$D(LRSS) - Q:$P(^LR(LRDFN,LRSS,LRI,0),U,11)="" - Q:$G(SEX)'["F" - Q:$T(CREATE^WVLABCHK)']"" - D CREATE^WVLABCHK(DFN,LRDFN,LRI,$G(LRA),LRSS) - Q +LRWOMEN ;DALOI/CYM/FT - LINK TO WOMEN'S HEALTH PROGRAM ;10/22/04 13:14 + ;;5.2;LAB SERVICE;**231,248,311,324**;Sep 27, 1994 + ; + ;Reference to CREATE^WVLRLINK supported by IA #2772 + ;Reference to DELETE^WVLRLINK supported by IA #2772 + ;Reference to MOVE^WVLRLINK supported by IA #2772 + ;Reference to ^XPDUTL supported by IA #10141 + ;Reference to ^ORB3LAB supported by IA #4287 + ;Reference to CREATE^WVLABCHK supported by IA #4525 + ; +ADD ; From DD 63.08,.11 and 63.09,.11 + Q:+$G(LRDPF)'=2 + Q:'$D(LRSS) + Q:$P(^LR(LRDFN,LRSS,LRI,0),U,11)']"" + I $$PATCH^XPDUTL("OR*3.0*210") D + .Q:$G(LRAPOLDF)=1 + .D LAB^ORB3LAB(DFN,LRDFN,LRI,$G(LRA),LRSS) + Q:$G(SEX)'["F" + Q:$T(CREATE^WVLRLINK)']"" + D CREATE^WVLRLINK(DFN,LRDFN,LRI,$G(LRA),LRSS) + Q +DEL ; From LRAPM + Q:$G(SEX)'["F" + Q:+$G(LRDPF)'=2 + Q:'$D(LRSS) + Q:$P(^LR(LRDFN,LRSS,LRI,0),U,11)]"" + Q:$T(DELETE^WVLRLINK)']"" + D DELETE^WVLRLINK(DFN,LRDFN,LRI,X,LRSS) + Q +MOVE ; From LRAPMV + ; no longer used after LR*5.2*259 + Q +SNOMED ; From DD 63.08,10 and 63.09,10 + Q:+$G(LRDPF)'=2 + Q:'$D(LRSS) + Q:$P(^LR(LRDFN,LRSS,LRI,0),U,11)="" + Q:$G(SEX)'["F" + Q:$T(CREATE^WVLABCHK)']"" + D CREATE^WVLABCHK(DFN,LRDFN,LRI,$G(LRA),LRSS) + Q diff --git a/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YS31ENV.m b/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YS31ENV.m index 3fb9397e..17c38c4f 100644 --- a/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YS31ENV.m +++ b/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YS31ENV.m @@ -1,21 +1,21 @@ -YS31ENV ;DALCIOFO/MJD-YS*5.01*31 PATCH ENVIRONMENT CHECK ROUTINE ;10/30/97 - ;;5.01;MENTAL HEALTH;**31**;Dec 30, 1994 -EN ; Does not prevent loading of the transport global. - ;Environment check is done only during the install. - QUIT:'$G(XPDENV) - D CHECK - ; -EXIT I $G(XPDQUIT) W !!,$$CJ^XLFSTR("Install Environment Check FAILED",80) - I '$G(XPDQUIT) W !!,$$CJ^XLFSTR("Environment Check is Done...",80) - K VER,RN,LN2 - QUIT - ; -CHECK ; - I $S('$G(IOM):1,'$G(IOSL):1,$G(U)'="^":1,1:0) W !,$$CJ^XLFSTR("Terminal Device is not defined",80),!! S XPDQUIT=2 Q - I $S('$G(DUZ):1,$D(DUZ)[0:1,$D(DUZ(0))[0:1,1:0) W !!,$$CJ^XLFSTR("Please Log in to set local DUZ... variables",80),! S XPDQUIT=2 Q - I '$D(^VA(200,$G(DUZ),0))#2 W !,$$CJ^XLFSTR("You are not a valid user on this system",80),! S XPDQUIT=2 Q - S VER=$$VERSION^XPDUTL("MENTAL HEALTH") - I VER'=5.01 W !,$$CJ^XLFSTR("You must have Mental Health V 5.01 Installed",80),! S XPDQUIT=2 Q - QUIT - ; -EOR ;;YS*5.01*31 PATCH ENVIRONMENT CHECK ROUTINE;; +YS31ENV ;DALCIOFO/MJD-YS*5.01*31 PATCH ENVIRONMENT CHECK ROUTINE ;10/30/97 + ;;5.01;MENTAL HEALTH;**31**;Dec 30, 1994 +EN ; Does not prevent loading of the transport global. + ;Environment check is done only during the install. + QUIT:'$G(XPDENV) + D CHECK + ; +EXIT I $G(XPDQUIT) W !!,$$CJ^XLFSTR("Install Environment Check FAILED",80) + I '$G(XPDQUIT) W !!,$$CJ^XLFSTR("Environment Check is Done...",80) + K VER,RN,LN2 + QUIT + ; +CHECK ; + I $S('$G(IOM):1,'$G(IOSL):1,$G(U)'="^":1,1:0) W !,$$CJ^XLFSTR("Terminal Device is not defined",80),!! S XPDQUIT=2 Q + I $S('$G(DUZ):1,$D(DUZ)[0:1,$D(DUZ(0))[0:1,1:0) W !!,$$CJ^XLFSTR("Please Log in to set local DUZ... variables",80),! S XPDQUIT=2 Q + I '$D(^VA(200,$G(DUZ),0))#2 W !,$$CJ^XLFSTR("You are not a valid user on this system",80),! S XPDQUIT=2 Q + S VER=$$VERSION^XPDUTL("MENTAL HEALTH") + I VER'=5.01 W !,$$CJ^XLFSTR("You must have Mental Health V 5.01 Installed",80),! S XPDQUIT=2 Q + QUIT + ; +EOR ;;YS*5.01*31 PATCH ENVIRONMENT CHECK ROUTINE;; diff --git a/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YS31POST.m b/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YS31POST.m index 6bfe158f..37a2de62 100644 --- a/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YS31POST.m +++ b/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YS31POST.m @@ -1,10 +1,10 @@ -YS31POST ;DALCIOFO/MJD-PATCH YS*5.01*31 POST RTN. ;09/23/97 - ;;5.01;MENTAL HEALTH;**31**;Dec 30, 1994 - ; - ; Unless the site has modified this file the zero node - ; for file #601 MH INSTRUMENT should look like: - ; ^YTT(601,0) = MH INSTRUMENT^601^233^88 - S:$P(^YTT(601,0),U,3)="225" $P(^YTT(601,0),U,3)=233 - S $P(^YTT(601,0),U,4)=$P(^YTT(601,0),U,4)+8 - ; - QUIT +YS31POST ;DALCIOFO/MJD-PATCH YS*5.01*31 POST RTN. ;09/23/97 + ;;5.01;MENTAL HEALTH;**31**;Dec 30, 1994 + ; + ; Unless the site has modified this file the zero node + ; for file #601 MH INSTRUMENT should look like: + ; ^YTT(601,0) = MH INSTRUMENT^601^233^88 + S:$P(^YTT(601,0),U,3)="225" $P(^YTT(601,0),U,3)=233 + S $P(^YTT(601,0),U,4)=$P(^YTT(601,0),U,4)+8 + ; + QUIT diff --git a/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSCLSERV.m b/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSCLSERV.m index 9a29ede3..1fc9dbbd 100644 --- a/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSCLSERV.m +++ b/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSCLSERV.m @@ -1,140 +1,137 @@ -YSCLSERV ;DALOI/RLM-Clozapine data server ;24 APR 1990 - ;;5.01;MENTAL HEALTH;**18,22,26,47,61,69,74,90,92**;Dec 30, 1994;Build 7 - ; Reference to ^%ZOSF supported by IA #10096 - ; Reference to ^DPT supported by IA #10035 - ; Reference to ^DD("DD" supported by IA #10017 - ; Reference to ^PS(55 supported by IA #787 - ; Reference to ^PSDRUG supported by IA #25 - ; Reference to ^PSRX supported by IA #780 - ; Reference to ^VA(200 supported by IA #10060 - ; Reference to $$SITE^VASITE supported by IA #10112 - ; Reference to $$FMTE^XLFDT() supported by IA #10103 - ; Reference to ^PSDRUG supported by IA #221 - ; Reference to ^XMD supported by IA #10070 -START ; - K ^TMP($J,"YSCLDATA") - S YSDEBUG=$P(^YSCL(603.03,1,0),"^",3) - S YSCLST=$P($$SITE^VASITE,"^",3) - S YSCLSTN=$P($$SITE^VASITE,"^",2) - ;Determine station number - S X=XQSUB X ^%ZOSF("UPPERCASE") S YSCLSUB=Y - S ^TMP($J,"YSCLDATA",1)=$S(YSDEBUG:"DEBUG ",1:"")_YSCLSUB_" triggered at "_YSCLST_" by "_XMFROM_" on "_XQDATE - ;The first line of the message tells who requested the action and when - D - . S YSACTION=$S(YSCLSUB["REMOVE"!(YSCLSUB["DELETE"):"data deleted",YSCLSUB["REPORT":"report generated",YSCLSUB["REBUILD":"data verified",YSCLSUB["UPDATE":"data updated",YSCLSUB["DATESET":"date set",1:"CONT") - . I YSACTION="CONT" S YSACTION=$S(YSCLSUB["DEMOG RESET":"Demographics Flag Reset",YSCLSUB["DEBUG":"Debug Mode set",YSCLSUB["AUTH":"Authorization",YSCLSUB["LOCK":"Lock",1:"Site Lock") - . S ^TMP($J,"YSCLDATA",2)="No "_$S(YSDEBUG:"DEBUG ",1:"")_YSACTION_" at "_YSCLST - ;The second line tells when the server is activated and no data can be - ;gathered from the MailMan message. This line gets replaced if the - ;server finds something to do. - S YSCLLNT=1 I YSCLSUB["REMOVE"!(YSCLSUB["DELETE") G DELETE - ;If the subject contains the word REMOVE or DELETE delete those entries from the list. - I YSCLSUB["REPORT" G REPORT - ;If the subject contains "REPORT" send a report of the currently registered patients to the Clozapine group on Forum - ;I YSCLSUB["REBUILD" G REBUILD - I YSCLSUB["RESEND" G RESEND - I YSCLSUB["UPDATE" G UPDATE - ;I YSCLSUB["CHECKSUM" G CSUM^YSCLSRV1 - I YSCLSUB["DATESET" G DSET - I YSCLSUB["DEBUG" G DEBUG - I YSCLSUB["PATIENT" G ^YSCLSRV3 - I YSCLSUB["LOCKOUT" G LOCK^YSCLSRV3 - I YSCLSUB="DEMOG RESET" G DEMOG^YSCLSRV3 - I YSCLSUB["AUTHORIZE" G AUTH^YSCLSRV3 - I YSCLSUB="OVERRIDE" G OVRRID^YSCLSRV2 - I YSCLSUB="CLAPI" G CLAPI^YSCLSRV2 - I YSCLSUB="CL1API" G CL1API^YSCLSRV2 - I YSCLSUB["DISCON" G DCON^YSCLSRV2 - F X XMREC Q:XMER<0 S XMRG=$TR(XMRG,"- ","") D - . ;Verify that + of site number matches local site number - . I XMRG'?2U5N1","9N1","1U S YSCLER=" is in error and was not added at " D OUT Q - . I $P(XMRG,",")'?2U5N S YSCLER=" is not a valid Clozapine number " D OUT Q - . I $P(XMRG,",",2)'?9N S YSCLER=" An SSN must be 9 numbers " D OUT Q - . I $P(XMRG,",",3)'="B",$P(XMRG,",",3)'="W",$P(XMRG,",",3)'="M" S YSCLER=" You must specify Weekly, Biweekly, or Monthly " D OUT Q - . ;Validate the format of the data in the message and report the error. - . S DIC="^DPT(",DIC(0)="X",D="SSN",X=$P(XMRG,",",2) I '$D(^DPT("SSN",X)) S YSCLER=" SSN does not exist at " D OUT Q - . ;Do not add data for records where the SSN sent is not in the local database - . I $D(^YSCL(603.01,"B",$P(XMRG,","))) S YSCLX=$O(^YSCL(603.01,"B",$P(XMRG,","),"")) S:YSCLX]"" YSCLX=$P(^YSCL(603.01,YSCLX,0),"^",2),YSCLER=" Clozapine # is in use by "_$P($G(^DPT(YSCLX,0)),"^")_" at " D OUT Q - . D MIX^DIC1 S YSCLPT=+Y I Y=-1 S YSCLER=" could not be added at " D OUT Q - . ;Add the data and report any errors to the Roll-Up group at Forum. - . K DD S DIC="^YSCL(603.01,",X=$P(XMRG,","),DIC("DR")="1////"_YSCLPT_";2////"_$P(XMRG,",",3) K DO D FILE^DICN - . S YSCLX=$O(^YSCL(603.01,"B",$P(XMRG,","),"")) S:YSCLX]"" YSCLX=$P(^YSCL(603.01,YSCLX,0),"^",2),YSCLER=" assigned to "_$P($G(^DPT(YSCLX,0)),"^")_" at " D OUT -EXIT ;If all went well, report that too. - S YSDEBUG=$P(^YSCL(603.03,1,0),"^",3) - S %H=$H D YMD^%DTC S XMDUN="NCCC LOGGER",XMDUZ=".5",XMSUB=$S(YSDEBUG:"DEBUG ",YSCLSUB["DEBUG":"DEBUG ",1:"")_YSCLST_" NCCC ENROLLER ("_X_%_")",XMTEXT="^TMP($J,""YSCLDATA""," - K XMY S XMY("G.CLOZAPINE ROLL-UP@FORUM.VA.GOV")="" - I YSDEBUG!(YSCLSUB["DEBUG") S XMY("G.CLOZAPINE DEBUG@FO-DALLAS.MED.VA.GOV")="" - D ^XMD - ;Mail the errors and successes back to the Roll-Up group at Forum. - K ^TMP($J,"YSCLDATA") - K %,%DT,%H,D,DA,DD,DIC,DIE,DIK,RET,X,XMDUN,XMDUZ,XMER,XMFROM - K XMREC,XMRG,XMSUB,XMTEXT,XMY,XMZ,XQDATE,XQSUB,Y,YSA,YSACTION,YSCLTYPE - K YSCL28,YSCLA,YSCLAA,YSCLB,YSCLC,YSCLDA,YSCLDA1,YSCLDATA,YSCLDEA1 - K YSCLDFN,YSCLDM,YSCLDOC,YSCLDOM,YSCLDR,YSCLDRA,YSCLDRB,YSCLDTA,YSCLERR - K YSCLDUZ,YSCLED,YSCLER,YSCLFDA,YSCLFRQ,YSCLLNT,YSCLNM,YSCLOVR,YSCLSITE - K YSCLPT,YSCLRPT,YSCLSD1,YSCLSDT,YSCLSSN,YSCLST,YSCLSTN,YSCLSUB,YSCLTC - K YSCLRX,YSCLSAND,YSCLWB,YSCLX,YSCLYN,YSDEBUG,YSI,YSOFF,YSPR,ZTQUEUED,ZTSK - Q -DELETE ;Allow the NCCC users to delete clozapine registration at the individual sites - S YSCLLNT=1 F X XMREC Q:XMER<0 S XMRG=$TR(XMRG,"- ","") D - . I XMRG="**++**DELETEALL**++**" D DELALL Q - . I '$D(^YSCL(603.01,"B",$P(XMRG,","))) S YSCLER=" "_$P(XMRG,",")_" is not registered at " D OUT Q - . S YSCLDFN=$O(^DPT("SSN",$P(XMRG,",",2),"")) I YSCLDFN="" S YSCLER=" "_$P(XMRG,",")_" is not a valid SSN at " D OUT Q - . I '$D(^YSCL(603.01,"C",YSCLDFN)) S YSCLER=" "_$P(XMRG,",",2)_" is not registered at " D OUT Q - . S YSCLA=$O(^YSCL(603.01,"B",$P(XMRG,","),"")) I YSCLA="" S YSCLER=" "_$P(XMRG,",")_" is not a valid entry at " D OUT Q - . K ^YSCL(603.01,YSCLA),^YSCL(603.01,"B",$P(XMRG,","),YSCLA),^YSCL(603.01,"C",YSCLDFN,YSCLA) - . S YSCLER=" removed at " D OUT - . ;I $D(^YSCL(603.01,"C",+Y)) K ^YSCL(603.01,YSCLA),^YSCL(603.01,"B",$P(XMRG,","),YSCLA),^YSCL(603.01,"C",YSCLDFN,YSCLA) S YSCLER=" removed at " D OUT Q ;RLM 9-29-99 ADDED QUIT - G EXIT -DELALL ;Delete all patients in file 603.01 - S YSCLA=0 F S YSCLA=$O(^YSCL(603.01,YSCLA)) Q:YSCLA="" D - . I YSCLA S YSCLER=$P(^YSCL(603.01,YSCLA,0),"^",1)_", "_$P(^DPT($P(^YSCL(603.01,YSCLA,0),"^",2),0),"^",9)_", ("_$P(^YSCL(603.01,YSCLA,0),"^",3)_") gdeleted at " D OUT - . K ^YSCL(603.01,YSCLA) - Q -REPORT ;send report of current registrations to the Clozapine group on Forum - D REPORT^YSCLSRV2 G EXIT -OUT S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)=XMRG_YSCLER_YSCLST Q - ;Build the text for the return message here. -REBUILD ; - D REBUILD^YSCLSRV2 G EXIT -UPDATE ;Update record with Monthly, Weekly or Bi-weekly status - F X XMREC Q:XMER<0 S XMRG=$TR(XMRG,"- ","") D - . I XMRG'?2U5N1","9N1","1U S YSCLER=" is in error and was not added at " D OUT Q - . I $P(XMRG,",")'?2U5N S YSCLER=" is not a valid Clozapine number format " D OUT Q - . I $P(XMRG,",",2)'?9N S YSCLER=" An SSN must be 9 numbers " D OUT Q - . I $P(XMRG,",",3)'="B",$P(XMRG,",",3)'="W",$P(XMRG,",",3)'="M" S YSCLER=" You must specify Monthly, Weekly or Biweekly " D OUT Q ;RLM 06/15/05 - . S YSCLNM=$P(XMRG,","),YSCLSSN=$P(XMRG,",",2),YSCLWB=$P(XMRG,",",3) - . I '$D(^YSCL(603.01,"B",YSCLNM)) S YSCLER=" does not exist at " D OUT Q - . S YSCLDA=$O(^DPT("SSN",YSCLSSN,0)) - . I YSCLDA="" S YSCLER=" SSN does not exist at " D OUT Q - . I $O(^YSCL(603.01,"B",YSCLNM,0))="" S YSCLER=" SSN not in Clozapine file " D OUT Q - . I $O(^DPT("SSN",YSCLSSN,YSCLDA)) S YSCLER=" SSN has more than one owner " D OUT Q - . I $O(^YSCL(603.01,"B",YSCLNM,0))'=$O(^YSCL(603.01,"C",YSCLDA,0)) S YSCLER=" SSN ("_YSCLSSN_","_$P(^DPT(YSCLDA,0),"^")_") has multiple Clozapine Numbers at " D OUT - . I $O(^YSCL(603.01,"B",YSCLNM,0))=$O(^YSCL(603.01,"C",YSCLDA,0)) D - . . S YSCLDA1=$O(^YSCL(603.01,"B",YSCLNM,0)) S $P(^YSCL(603.01,YSCLDA1,0),"^",3)=YSCLWB - . . S YSCLER=" "_YSCLNM_" ("_$P(^DPT(YSCLDA,0),"^")_") updated to "_$S(YSCLWB="M":"Monthly",YSCLWB="W":"Weekly",YSCLWB="B":"Bi-weekly",1:"Unknown")_" at " D OUT ;06/15/05 - G EXIT -RESEND ;Trigger retransmission of Clozapine data - X XMREC - K %DT S X=XMRG,%DT="P" D ^%DT I Y=-1 S YSCLER=" is an invalid date, RESEND not triggered at " D OUT G EXIT - S YSCLED=Y,(YSCLSDT,X)=Y D H^%DTC I %H#7'=5 S YSCLER=" is not a Tuesday, RESEND not triggered at " D OUT G EXIT - D SERV^YSCLTST2 - S Y=YSCLSDT X ^DD("DD") S YSCLER=" - Resend triggered (local task #"_$G(ZTSK)_") by "_XMFROM_" for "_Y_" at " D OUT - G EXIT -DSET ;Set the day of the week for the roll-up to run. - X XMREC Q:XMER<0 S X=$TR(XMRG,"- ","") - S YSOFF=$S(X="SUNDAY":0,X="MONDAY":1,X="TUESDAY":2,X="WEDNESDAY":3,X="THURSDAY":4,X="FRIDAY":5,X="SATURDAY":6,1:7) - I YSOFF>6 S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)=X_" isn't a valid day of the week." G EXIT - S $P(^YSCL(603.03,1,0),"^",2)=X - S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="Run day set to "_X - G EXIT - Q -DEBUG ;Turn debug mode on and off. - I YSCLSUB["DEBUG ON" D - . S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="Debug Mode is "_$S(YSDEBUG:"already",1:"now")_" ON at "_YSCLSTN - . S $P(^YSCL(603.03,1,0),"^",3)=1 - I YSCLSUB["DEBUG OFF" D - . S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="Debug Mode is "_$S('YSDEBUG:"already",1:"now")_" OFF at "_YSCLSTN - . S $P(^YSCL(603.03,1,0),"^",3)=0 - G EXIT -ZEOR ;YSCLSERV +YSCLSERV ;DALOI/RLM-Clozapine data server ;24 APR 1990 + ;;5.01;MENTAL HEALTH;**18,22,26,47,61,69,74,90**;Dec 30, 1994;Build 18 + ; Reference to ^%ZOSF supported by IA #10096 + ; Reference to ^DPT supported by IA #10035 + ; Reference to ^DD("DD" supported by IA #10017 + ; Reference to ^PS(55 supported by IA #787 + ; Reference to ^PSDRUG supported by IA #25 + ; Reference to ^PSRX supported by IA #780 + ; Reference to ^VA(200 supported by IA #10060 + ; Reference to $$SITE^VASITE supported by IA #10112 + ; Reference to $$FMTE^XLFDT() supported by IA #10103 + ; Reference to ^PSDRUG supported by IA #221 + ; Reference to ^XMD supported by IA #10070 +START ; + K ^TMP($J,"YSCLDATA") + S YSDEBUG=$P(^YSCL(603.03,1,0),"^",3) + S YSCLST=$P($$SITE^VASITE,"^",3) + S YSCLSTN=$P($$SITE^VASITE,"^",2) + ;Determine station number + S X=XQSUB X ^%ZOSF("UPPERCASE") S YSCLSUB=Y + S ^TMP($J,"YSCLDATA",1)=$S(YSDEBUG:"DEBUG ",1:"")_YSCLSUB_" triggered at "_YSCLST_" by "_XMFROM_" on "_XQDATE + ;The first line of the message tells who requested the action and when + D + . S YSACTION=$S(YSCLSUB["REMOVE"!(YSCLSUB["DELETE"):"data deleted",YSCLSUB["REPORT":"report generated",YSCLSUB["REBUILD":"data verified",YSCLSUB["UPDATE":"data updated",YSCLSUB["DATESET":"date set",1:"CONT") + . I YSACTION="CONT" S YSACTION=$S(YSCLSUB["DEMOG RESET":"Demographics Flag Reset",YSCLSUB["DEBUG":"Debug Mode set",YSCLSUB["AUTH":"Authorization",YSCLSUB["LOCK":"Lock",1:"Site Lock") + . S ^TMP($J,"YSCLDATA",2)="No "_$S(YSDEBUG:"DEBUG ",1:"")_YSACTION_" at "_YSCLST + ;The second line tells when the server is activated and no data can be + ;gathered from the MailMan message. This line gets replaced if the + ;server finds something to do. + S YSCLLNT=1 I YSCLSUB["REMOVE"!(YSCLSUB["DELETE") G DELETE + ;If the subject contains the word REMOVE or DELETE delete those entries from the list. + I YSCLSUB["REPORT" G REPORT + ;If the subject contains "REPORT" send a report of the currently registered patients to the Clozapine group on Forum + ;I YSCLSUB["REBUILD" G REBUILD + I YSCLSUB["RESEND" G RESEND + I YSCLSUB["UPDATE" G UPDATE + I YSCLSUB["CHECKSUM" G CSUM^YSCLSRV1 + I YSCLSUB["DATESET" G DSET + I YSCLSUB["DEBUG" G DEBUG + I YSCLSUB["PATIENT" G ^YSCLSRV3 + I YSCLSUB["LOCKOUT" G LOCK^YSCLSRV3 + I YSCLSUB="DEMOG RESET" G DEMOG^YSCLSRV3 + I YSCLSUB["AUTHORIZE" G AUTH^YSCLSRV3 + I YSCLSUB="OVERRIDE" G OVRRID^YSCLSRV2 + F X XMREC Q:XMER<0 S XMRG=$TR(XMRG,"- ","") D + . ;Verify that + of site number matches local site number + . I XMRG'?2U5N1","9N1","1U S YSCLER=" is in error and was not added at " D OUT Q + . I $P(XMRG,",")'?2U5N S YSCLER=" is not a valid Clozapine number " D OUT Q + . I $P(XMRG,",",2)'?9N S YSCLER=" An SSN must be 9 numbers " D OUT Q + . I $P(XMRG,",",3)'="B",$P(XMRG,",",3)'="W",$P(XMRG,",",3)'="M" S YSCLER=" You must specify Weekly, Biweekly, or Monthly " D OUT Q + . ;Validate the format of the data in the message and report the error. + . S DIC="^DPT(",DIC(0)="X",D="SSN",X=$P(XMRG,",",2) I '$D(^DPT("SSN",X)) S YSCLER=" SSN does not exist at " D OUT Q + . ;Do not add data for records where the SSN sent is not in the local database + . I $D(^YSCL(603.01,"B",$P(XMRG,","))) S YSCLX=$O(^YSCL(603.01,"B",$P(XMRG,","),"")) S:YSCLX]"" YSCLX=$P(^YSCL(603.01,YSCLX,0),"^",2),YSCLER=" Clozapine # is in use by "_$P($G(^DPT(YSCLX,0)),"^")_" at " D OUT Q + . D MIX^DIC1 S YSCLPT=+Y I Y=-1 S YSCLER=" could not be added at " D OUT Q + . ;Add the data and report any errors to the Roll-Up group at Forum. + . K DD S DIC="^YSCL(603.01,",X=$P(XMRG,","),DIC("DR")="1////"_YSCLPT_";2////"_$P(XMRG,",",3) K DO D FILE^DICN + . S YSCLX=$O(^YSCL(603.01,"B",$P(XMRG,","),"")) S:YSCLX]"" YSCLX=$P(^YSCL(603.01,YSCLX,0),"^",2),YSCLER=" assigned to "_$P($G(^DPT(YSCLX,0)),"^")_" at " D OUT +EXIT ;If all went well, report that too. + S YSDEBUG=$P(^YSCL(603.03,1,0),"^",3) + S %H=$H D YMD^%DTC S XMDUN="NCCC LOGGER",XMDUZ=".5",XMSUB=$S(YSDEBUG:"DEBUG ",YSCLSUB["DEBUG":"DEBUG ",1:"")_YSCLST_" NCCC ENROLLER ("_X_%_")",XMTEXT="^TMP($J,""YSCLDATA""," + K XMY S XMY("G.CLOZAPINE ROLL-UP@FORUM.VA.GOV")="" + I YSDEBUG!(YSCLSUB["DEBUG") S XMY("G.CLOZAPINE DEBUG@FO-DALLAS.MED.VA.GOV")="" + D ^XMD + ;Mail the errors and successes back to the Roll-Up group at Forum. + K ^TMP($J,"YSCLDATA") + K %,%DT,%H,D,DA,DD,DIC,DIE,DIK,RET,X,XMDUN,XMDUZ,XMER,XMFROM + K XMREC,XMRG,XMSUB,XMTEXT,XMY,XMZ,XQDATE,XQSUB,Y,YSA,YSACTION + K YSCL28,YSCLA,YSCLAA,YSCLB,YSCLC,YSCLDA,YSCLDA1,YSCLDATA,YSCLDEA1 + K YSCLDFN,YSCLDM,YSCLDOC,YSCLDOM,YSCLDR,YSCLDRA,YSCLDRB,YSCLDTA + K YSCLDUZ,YSCLED,YSCLER,YSCLFDA,YSCLFRQ,YSCLLNT,YSCLNM,YSCLOVR + K YSCLPT,YSCLSD1,YSCLSDT,YSCLSSN,YSCLST,YSCLSTN,YSCLSUB,YSCLTC + K YSCLWB,YSCLX,YSCLYN,YSDEBUG,YSI,YSOFF,YSPR,ZTQUEUED,ZTSK + Q +DELETE ;Allow the NCCC users to delete clozapine registration at the individual sites + S YSCLLNT=1 F X XMREC Q:XMER<0 S XMRG=$TR(XMRG,"- ","") D + . I XMRG="**++**DELETEALL**++**" D DELALL Q + . I '$D(^YSCL(603.01,"B",$P(XMRG,","))) S YSCLER=" "_$P(XMRG,",")_" is not registered at " D OUT Q + . S YSCLDFN=$O(^DPT("SSN",$P(XMRG,",",2),"")) I YSCLDFN="" S YSCLER=" "_$P(XMRG,",")_" is not a valid SSN at " D OUT Q + . I '$D(^YSCL(603.01,"C",YSCLDFN)) S YSCLER=" "_$P(XMRG,",",2)_" is not registered at " D OUT Q + . S YSCLA=$O(^YSCL(603.01,"B",$P(XMRG,","),"")) I YSCLA="" S YSCLER=" "_$P(XMRG,",")_" is not a valid entry at " D OUT Q + . K ^YSCL(603.01,YSCLA),^YSCL(603.01,"B",$P(XMRG,","),YSCLA),^YSCL(603.01,"C",YSCLDFN,YSCLA) + . S YSCLER=" removed at " D OUT + . ;I $D(^YSCL(603.01,"C",+Y)) K ^YSCL(603.01,YSCLA),^YSCL(603.01,"B",$P(XMRG,","),YSCLA),^YSCL(603.01,"C",YSCLDFN,YSCLA) S YSCLER=" removed at " D OUT Q ;RLM 9-29-99 ADDED QUIT + G EXIT +DELALL ;Delete all patients in file 603.01 + S YSCLA=0 F S YSCLA=$O(^YSCL(603.01,YSCLA)) Q:YSCLA="" D + . I YSCLA S YSCLER=$P(^YSCL(603.01,YSCLA,0),"^",1)_", "_$P(^DPT($P(^YSCL(603.01,YSCLA,0),"^",2),0),"^",9)_", ("_$P(^YSCL(603.01,YSCLA,0),"^",3)_") gdeleted at " D OUT + . K ^YSCL(603.01,YSCLA) + Q +REPORT ;send report of current registrations to the Clozapine group on Forum + D REPORT^YSCLSRV2 G EXIT +OUT S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)=XMRG_YSCLER_YSCLST Q + ;Build the text for the return message here. +REBUILD ; + D REBUILD^YSCLSRV2 G EXIT +UPDATE ;Update record with Monthly, Weekly or Bi-weekly status + F X XMREC Q:XMER<0 S XMRG=$TR(XMRG,"- ","") D + . I XMRG'?2U5N1","9N1","1U S YSCLER=" is in error and was not added at " D OUT Q + . I $P(XMRG,",")'?2U5N S YSCLER=" is not a valid Clozapine number format " D OUT Q + . I $P(XMRG,",",2)'?9N S YSCLER=" An SSN must be 9 numbers " D OUT Q + . I $P(XMRG,",",3)'="B",$P(XMRG,",",3)'="W",$P(XMRG,",",3)'="M" S YSCLER=" You must specify Monthly, Weekly or Biweekly " D OUT Q ;RLM 06/15/05 + . S YSCLNM=$P(XMRG,","),YSCLSSN=$P(XMRG,",",2),YSCLWB=$P(XMRG,",",3) + . I '$D(^YSCL(603.01,"B",YSCLNM)) S YSCLER=" does not exist at " D OUT Q + . S YSCLDA=$O(^DPT("SSN",YSCLSSN,0)) + . I YSCLDA="" S YSCLER=" SSN does not exist at " D OUT Q + . I $O(^YSCL(603.01,"B",YSCLNM,0))="" S YSCLER=" SSN not in Clozapine file " D OUT Q + . I $O(^DPT("SSN",YSCLSSN,YSCLDA)) S YSCLER=" SSN has more than one owner " D OUT Q + . I $O(^YSCL(603.01,"B",YSCLNM,0))'=$O(^YSCL(603.01,"C",YSCLDA,0)) S YSCLER=" SSN ("_YSCLSSN_","_$P(^DPT(YSCLDA,0),"^")_") has multiple Clozapine Numbers at " D OUT + . I $O(^YSCL(603.01,"B",YSCLNM,0))=$O(^YSCL(603.01,"C",YSCLDA,0)) D + . . S YSCLDA1=$O(^YSCL(603.01,"B",YSCLNM,0)) S $P(^YSCL(603.01,YSCLDA1,0),"^",3)=YSCLWB + . . S YSCLER=" "_YSCLNM_" ("_$P(^DPT(YSCLDA,0),"^")_") updated to "_$S(YSCLWB="M":"Monthly",YSCLWB="W":"Weekly",YSCLWB="B":"Bi-weekly",1:"Unknown")_" at " D OUT ;06/15/05 + G EXIT +RESEND ;Trigger retransmission of Clozapine data + X XMREC + K %DT S X=XMRG,%DT="P" D ^%DT I Y=-1 S YSCLER=" is an invalid date, RESEND not triggered at " D OUT G EXIT + S YSCLED=Y,(YSCLSDT,X)=Y D H^%DTC I %H#7'=5 S YSCLER=" is not a Tuesday, RESEND not triggered at " D OUT G EXIT + D SERV^YSCLTST2 + S Y=YSCLSDT X ^DD("DD") S YSCLER=" - Resend triggered (local task #"_$G(ZTSK)_") by "_XMFROM_" for "_Y_" at " D OUT + G EXIT +DSET ;Set the day of the week for the roll-up to run. + X XMREC Q:XMER<0 S X=$TR(XMRG,"- ","") + S YSOFF=$S(X="SUNDAY":0,X="MONDAY":1,X="TUESDAY":2,X="WEDNESDAY":3,X="THURSDAY":4,X="FRIDAY":5,X="SATURDAY":6,1:7) + I YSOFF>6 S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)=X_" isn't a valid day of the week." G EXIT + S $P(^YSCL(603.03,1,0),"^",2)=X + S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="Run day set to "_X + G EXIT + Q +DEBUG ;Turn debug mode on and off. + I YSCLSUB["DEBUG ON" D + . S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="Debug Mode is "_$S(YSDEBUG:"already",1:"now")_" ON at "_YSCLSTN + . S $P(^YSCL(603.03,1,0),"^",3)=1 + I YSCLSUB["DEBUG OFF" D + . S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="Debug Mode is "_$S('YSDEBUG:"already",1:"now")_" OFF at "_YSCLSTN + . S $P(^YSCL(603.03,1,0),"^",3)=0 + G EXIT +ZEOR ;YSCLSERV diff --git a/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSCLSRV2.m b/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSCLSRV2.m index 1a06df6e..7d1720a5 100644 --- a/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSCLSRV2.m +++ b/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSCLSRV2.m @@ -1,102 +1,91 @@ -YSCLSRV2 ;DALOI/RLM-Clozapine data server ;APR 24,1990@15:26 - ;;5.01;MENTAL HEALTH;**69,90,92**;Dec 30, 1994;Build 7 - ; Reference to ^%ZOSF supported by IA #10096 - ; Reference to ^DPT supported by IA #10035 - ; Reference to ^DD("DD" supported by IA #10017 - ; Reference to ^PS(55 supported by IA #787 - ; Reference to ^PSDRUG supported by IA #25 - ; Reference to ^PSRX supported by IA #780 - ; Reference to ^VA(200 supported by IA #10060 - ; Reference to $$SITE^VASITE supported by IA #10112 - ; Reference to $$FMTE^XLFDT() supported by IA #10103 - ; Reference to ^PSDRUG supported by IA #221 - ; Reference to ^LAB(60 supported by IA #333 - ; -REPORT ;send report of current registrations to the Clozapine group on Forum - S XMRG="",YSCLA=0 F S YSCLA=$O(^YSCL(603.01,YSCLA)) Q:'YSCLA S YSCLDTA=$G(^YSCL(603.01,YSCLA,0)) D - . I YSCLDTA="" S YSCLER="Clozapine Patient List damaged at " D OUT Q - . S YSCLWB=$P(YSCLDTA,"^",3),YSCLWB=$S(YSCLWB="M":"Monthly",YSCLWB="W":"Weekly",YSCLWB="B":"Bi-weekly",1:"Unknown") - . S YSCLER=$P(YSCLDTA,"^")_" is assigned to "_$P($G(^DPT($P(YSCLDTA,"^",2),0)),"^")_" ("_$P($G(^DPT($P(YSCLDTA,"^",2),0)),"^",9)_") "_YSCLWB_" at " D OUT - S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="==========" - S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)=" Linked Tests:" - S YSCLA=0 F S YSCLA=$O(^YSCL(603.04,1,1,YSCLA)) Q:'YSCLA D - . S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)=$P(^LAB(60,$P(^YSCL(603.04,1,1,YSCLA,0),"^",1),0),"^") - . S YSCLTYPE=$P(^YSCL(603.04,1,1,YSCLA,0),"^",2),YSCLRPT=$P(^YSCL(603.04,1,1,YSCLA,0),"^",3) - . S YSCLTA=" reports "_$S(YSCLTYPE="W":"WHITE BLOOD COUNT",YSCLTYPE="A":"ABSOLUTE NEUTROPHIL COUNT",YSCLTYPE="N":"NEUTROPHIL PERCENT",YSCLTYPE="S":"SEGS %",YSCLTYPE="B":"BANDS %",YSCLTYPE="T":"BANDS A",YSCLTYPE="C":"SEGS A") - . S ^TMP($J,"YSCLDATA",YSCLLNT)=^TMP($J,"YSCLDATA",YSCLLNT)_YSCLTA_" "_$S(YSCLRPT:"K/units",1:"units") - S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="==========" - ;D OPTION^%ZTLOAD("YSCL WEEKLY TRANSMISSION","LIST") D - ; . S ZTSK="" F S ZTSK=$O(LIST(ZTSK)) Q:ZTSK="" D - ; . . D STAT^%ZTLOAD S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="Local Task # "_ZTSK_" is "_$S('ZTSK(0):" not ",1:"")_"defined with a status of "_ZTSK(2) - S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)=" Run day is: "_$P(^YSCL(603.03,1,0),"^",2) - S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)=" Debug Mode is: "_$S($P(^YSCL(603.03,1,0),"^",3):"On.",1:"Off.") - S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="Last Run Date (start) is: "_$$FMTE^XLFDT($P(^YSCL(603.03,1,0),"^",4)) - S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)=" Last Run Date (stop) is: "_$$FMTE^XLFDT($P(^YSCL(603.03,1,0),"^",5)) - S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="Last Demographic date is: "_$$FMTE^XLFDT($P(^YSCL(603.03,1,0),"^",6)) - Q -OUT S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)=XMRG_YSCLER_YSCLST Q - ;Build the text for the return message here. -REBUILD ; - S XMRG="",(YSCLA,YSCLLNT)=1 F S YSCLA=$O(^PS(55,"ASAND1",YSCLA)) W:'$D(ZTQUEUED) "." Q:YSCLA="" D - . S YSCLB=$O(^PS(55,"ASAND1",YSCLA,"")) I YSCLB="" S YSCLER=" record is in error (1) at " D OUT Q - . I '$D(^PS(55,YSCLB,0)) S YSCLER=" record is in error (2) at " D OUT Q - . S YSCLB=$P(^PS(55,YSCLB,0),"^") I YSCLB="" S YSCLER=" record is in error (3) at " D OUT Q - . I '$D(^PS(55,YSCLB,"SAND")) S YSCLER=" record is in error (4) at " D OUT Q - . S DIC="^DPT(",DIC(0)="X",D="SSN",(YSCLSSN,X)=$P(^DPT(YSCLB,0),"^",9) - . I $D(^YSCL(603.01,"B",YSCLA)) S YSCLX=$O(^YSCL(603.01,"B",YSCLA,"")) S:YSCLX]"" YSCLX=$P(^YSCL(603.01,YSCLX,0),"^",2),YSCLER=" Clozapine # "_YSCLA_" is in use by "_$P($G(^DPT(YSCLX,0)),"^")_" at " D OUT Q - . D MIX^DIC1 S YSCLPT=+Y I Y=-1 S YSCLER=" could not be added at " D OUT Q - . K DD S DIC="^YSCL(603.01,",X=YSCLA,DIC("DR")="1////"_YSCLPT K DO D FILE^DICN - . S YSCLX=$O(^YSCL(603.01,"B",YSCLA,"")) S:YSCLX]"" YSCLX=$P(^YSCL(603.01,YSCLX,0),"^",2),YSCLER=","_YSCLSSN_" assigned to "_$P($G(^DPT(YSCLX,0)),"^")_" at " D OUT - Q -OVRRID ;Update record with Monthly, Weekly or Bi-weekly status - F X XMREC Q:XMER<0 S XMRG=$TR(XMRG,"- ","") D - . I XMRG'?2U5N1","9N1",".E S YSCLER=" is in error and was not added at " D OUT Q - . I $P(XMRG,",")'?2U5N S YSCLER=" is not a valid Clozapine number format " D OUT Q - . I $P(XMRG,",",2)'?9N S YSCLER=" An SSN must be 9 numbers " D OUT Q - . K %DT S X=$P(XMRG,",",3),%DT="F" D ^%DT I Y=-1 S YSCLER=" is an invalid date, over-ride authorization not filed at " D OUT Q - . S YSCLOVR=Y - . S YSCLNM=$P(XMRG,","),YSCLSSN=$P(XMRG,",",2),YSCLWB=$P(XMRG,",",3) - . I '$D(^YSCL(603.01,"B",YSCLNM)) S YSCLER=" does not exist at " D OUT Q - . S YSCLDA=$O(^DPT("SSN",YSCLSSN,0)) - . I YSCLDA="" S YSCLER=" SSN does not exist at " D OUT Q - . I $O(^YSCL(603.01,"B",YSCLNM,0))="" S YSCLER=" SSN not in Clozapine file " D OUT Q - . I $O(^DPT("SSN",YSCLSSN,YSCLDA)) S YSCLER=" SSN has more than one owner " D OUT Q - . I $O(^YSCL(603.01,"B",YSCLNM,0))'=$O(^YSCL(603.01,"C",YSCLDA,0)) S YSCLER=" SSN ("_YSCLSSN_","_$P(^DPT(YSCLDA,0),"^")_") has multiple Clozapine Numbers at " D OUT - . I $O(^YSCL(603.01,"B",YSCLNM,0))=$O(^YSCL(603.01,"C",YSCLDA,0)) D - . . S YSCLDA1=$O(^YSCL(603.01,"B",YSCLNM,0)) S $P(^YSCL(603.01,YSCLDA1,0),"^",4)=YSCLOVR - . . S Y=YSCLOVR D DD^%DT S YSCLER=" "_YSCLNM_" ("_$P(^DPT(YSCLDA,0),"^")_") authorized for over-ride on "_Y_" at " D OUT - G EXIT^YSCLSERV - ; -CLAPI ; - F X XMREC Q:XMER<0 S XMRG=$TR(XMRG,"- ","") D - . ;Verify that a valid Clozapine number is listed - . S YSCLDA=$E(XMRG,1,7) - . I YSCLDA'?2U5N S YSCLER=" is not a valid Clozapine number " D OUT Q - . S YSCLDA=$O(^YSCL(603.01,"B",YSCLDA,"")),YSCLDA=$P($G(^YSCL(603.01,YSCLDA,0)),"^",2) - . I 'YSCLDA S YSCLER=" is not in the local database." D OUT Q - . S YSCLNM=$$CL^YSCLTST2(YSCLDA) S YSCLER=" = "_YSCLNM_" at " D OUT - . Q - G EXIT^YSCLSERV -CL1API ; - F X XMREC Q:XMER<0 S XMRG=$TR(XMRG,"- ","") D - . ;Verify that a valid Clozapine number is listed - . S YSA=$P(XMRG,"^",1),YSCLDA=$P(XMRG,"^",2) - . I YSCLDA'?2U5N S YSCLER=" is not a valid Clozapine number " D OUT Q - . S YSCLDA=$O(^YSCL(603.01,"B",YSCLDA,"")),YSCLDA=$P($G(^YSCL(603.01,YSCLDA,0)),"^",2) - . I 'YSCLDA S YSCLER=" is not in the local database." D OUT Q - . D CL1^YSCLTST2(YSCLDA,YSA) D - . . S YSCLDA1="" F S YSCLDA1=$O(^TMP($J,"PSO",YSCLDA1)) Q:'YSCLDA1 S YSCLER=" = "_YSCLDA_"="_(9999999-YSCLDA1)_" = "_^TMP($J,"PSO",YSCLDA1)_" at " D OUT - . Q - G EXIT^YSCLSERV - Q -DCON ; - F X XMREC Q:XMER<0 S XMRG=$TR(XMRG,"- ","") D - . ;Verify that a valid Clozapine number is listed - . S (YSA,YSCLDA)=$E(XMRG,1,7) - . I YSCLDA'?2U5N S YSCLER=" is not a valid Clozapine number " D OUT Q - . S YSCLDA=$O(^YSCL(603.01,"B",YSCLDA,"")),YSCLDA=$P($G(^YSCL(603.01,YSCLDA,0)),"^",2) - . I 'YSCLDA S YSCLER=" is not in the local database." D OUT Q - . I $P(^PS(55,YSCLDA,"SAND"),"^",2)'="D" S YSCLER=YSA_" is not discontinued" D OUT Q - . S YSCLER=YSA_" was "_$P(^PS(55,YSCLDA,"SAND"),"^",2)_" is now ""A""" D OUT - . S $P(^PS(55,YSCLDA,"SAND"),"^",2)="A" -ZEOR ;YSCLSRV2 +YSCLSRV2 ;DALOI/RLM-Clozapine data server ;APR 24,1990@15:26 + ;;5.01;MENTAL HEALTH;**69,90**;Dec 30, 1994;Build 18 + ; Reference to ^%ZOSF supported by IA #10096 + ; Reference to ^DPT supported by IA #10035 + ; Reference to ^DD("DD" supported by IA #10017 + ; Reference to ^PS(55 supported by IA #787 + ; Reference to ^PSDRUG supported by IA #25 + ; Reference to ^PSRX supported by IA #780 + ; Reference to ^VA(200 supported by IA #10060 + ; Reference to $$SITE^VASITE supported by IA #10112 + ; Reference to $$FMTE^XLFDT() supported by IA #10103 + ; Reference to ^PSDRUG supported by IA #221 + ; Reference to ^LAB(60 supported by IA #333 + ; +REPORT ;send report of current registrations to the Clozapine group on Forum + S XMRG="",YSCLA=0 F S YSCLA=$O(^YSCL(603.01,YSCLA)) Q:'YSCLA S YSCLDTA=$G(^YSCL(603.01,YSCLA,0)) D + . I YSCLDTA="" S YSCLER="Clozapine Patient List damaged at " D OUT Q + . S YSCLWB=$P(YSCLDTA,"^",3),YSCLWB=$S(YSCLWB="M":"Monthly",YSCLWB="W":"Weekly",YSCLWB="B":"Bi-weekly",1:"Unknown") + . S YSCLER=$P(YSCLDTA,"^")_" is assigned to "_$P($G(^DPT($P(YSCLDTA,"^",2),0)),"^")_" ("_$P($G(^DPT($P(YSCLDTA,"^",2),0)),"^",9)_") "_YSCLWB_" at " D OUT + I YSCLSUB["+" S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="====" S YSCLA=0 F S YSCLA=$O(^PS(55,"ASAND",YSCLA)) Q:'YSCLA S YSCLER="" D D:YSCLER]"" OUT ;Transmit the most recent for each patient. + . S YSCLDFN=$P(^PS(55,YSCLA,0),"^") ;Find out who we're reporting on + . S YSCLNM=$P(^DPT(YSCLDFN,0),"^") ;Get the patients name + . S YSCLSD1=YSCLNM_"^"_^PS(55,YSCLA,"SAND") ;Add name to data + . S YSCLZZ=YSCLA,$P(YSCLSD1,"^",4)=$P($$CL^YSCLTST2(YSCLDFN),"^",2),YSCLA=YSCLZZ + . S YSCLDOC=$P(YSCLSD1,"^",6) I YSCLDOC K DIERR,YSCL200 D FIND^DIC(200,,".01","X","`"_YSCLDOC,,,,,"YSCL200","YERROR") S $P(YSCLSD1,"^",6)=$G(YSCL200("DILIST",1,1)) + . ;S YSCLDOC=$P(YSCLSD1,"^",6) I YSCLDOC S $P(YSCLSD1,"^",6)=$P($G(^VA(200,YSCLDOC,0)),"^") ;OLD CODE + . S $P(YSCLSD1,"^",7)=$P(YSCLSD1,"^",7) ;Pad it to 7 ^-pieces + . S YSCLB=0 F S YSCLB=$O(^PS(55,YSCLA,"P",YSCLB)) Q:'YSCLB I $D(^PSRX(^PS(55,YSCLA,"P",YSCLB,0),"SAND")) D ;D OUT ;This will transmit them all + . . S YSCLER=YSCLSD1_"^"_$G(^PSRX(^PS(55,YSCLA,"P",YSCLB,0),"SAND"))_"^" + . . S Y=$P(YSCLER,"^",7) I Y]"" X ^DD("DD") S $P(YSCLER,"^",7)=Y + . . S Y=$P(YSCLER,"^",10) I Y]"" X ^DD("DD") S $P(YSCLER,"^",10)=Y + . ;D OUT + S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)=" Linked Tests:" + S YSCLA=0 F S YSCLA=$O(^YSCL(603.04,1,1,YSCLA)) Q:'YSCLA D + . S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)=$P(^LAB(60,$P(^YSCL(603.04,1,1,YSCLA,0),"^",1),0),"^") + . S YSCLTYPE=$P(^YSCL(603.04,1,1,YSCLA,0),"^",2),YSCLRPT=$P(^YSCL(603.04,1,1,YSCLA,0),"^",3) + . S YSCLTA=" reports "_$S(YSCLTYPE="W":"WHITE BLOOD COUNT",YSCLTYPE="A":"ABSOLUTE NEUTROPHIL COUNT",YSCLTYPE="N":"NEUTROPHIL PERCENT",YSCLTYPE="S":"SEGS %",YSCLTYPE="B":"BANDS %",YSCLTYPE="T":"BANDS A",YSCLTYPE="C":"SEGS A") + . S ^TMP($J,"YSCLDATA",YSCLLNT)=^TMP($J,"YSCLDATA",YSCLLNT)_YSCLTA_" "_$S(YSCLRPT:"K/units",1:"units") + ;Old method + ;S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)=" Linked Tests:" + ;S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="WBC = "_$$GET1^DIQ(603.02,1,.01)_", Neut% = "_$$GET1^DIQ(603.02,1,1) + S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)=" Monitored Drug - Monitor Routine - NDC - Lab Test" + S YSPR=0 F S YSPR=$O(^PSDRUG(YSPR)) Q:'YSPR I $P($G(^PSDRUG(YSPR,"CLOZ1")),"^")]"" D + . S YSCLTC=$P($G(^PSDRUG(YSPR,"CLOZ")),"^") I YSCLTC S YSCLTC=$$GET1^DIQ(60,YSCLTC,.01) + . S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)=$P($G(^PSDRUG(YSPR,0)),"^")_" - "_$P(^PSDRUG(YSPR,"CLOZ1"),"^")_" - "_$P($G(^PSDRUG(YSPR,2)),"^",4)_" - "_YSCLTC + S YSCLDR=0 F S YSCLDR=$O(^PSDRUG(YSCLDR)) Q:'YSCLDR I $D(^PSDRUG(YSCLDR,"CLOZ2")) D + . S YSCLDRA=0 F S YSCLDRA=$O(^PSDRUG(YSCLDR,"CLOZ2",YSCLDRA)) Q:'YSCLDRA D + . . S YSCLDRB=^PSDRUG(YSCLDR,"CLOZ2",YSCLDRA,0) + . . S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)=$P(^PSDRUG(YSCLDR,0),"^")_" uses "_$P(^LAB(60,$P(YSCLDRB,"^"),0),"^")_" to indicate "_$S($P(YSCLDRB,"^",4)=1:"White Blood Count",1:"Neutrophil Count") + ;D OPTION^%ZTLOAD("YSCL WEEKLY TRANSMISSION","LIST") D + ; . S ZTSK="" F S ZTSK=$O(LIST(ZTSK)) Q:ZTSK="" D + ; . . D STAT^%ZTLOAD S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="Local Task # "_ZTSK_" is "_$S('ZTSK(0):" not ",1:"")_"defined with a status of "_ZTSK(2) + S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)=" Run day is: "_$P(^YSCL(603.03,1,0),"^",2) + S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)=" Debug Mode is: "_$S($P(^YSCL(603.03,1,0),"^",3):"On.",1:"Off.") + S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="Last Run Date (start) is: "_$$FMTE^XLFDT($P(^YSCL(603.03,1,0),"^",4)) + S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)=" Last Run Date (stop) is: "_$$FMTE^XLFDT($P(^YSCL(603.03,1,0),"^",5)) + S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="Last Demographic date is: "_$$FMTE^XLFDT($P(^YSCL(603.03,1,0),"^",6)) + Q +OUT S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)=XMRG_YSCLER_YSCLST Q + ;Build the text for the return message here. +REBUILD ; + S XMRG="",(YSCLA,YSCLLNT)=1 F S YSCLA=$O(^PS(55,"ASAND1",YSCLA)) W:'$D(ZTQUEUED) "." Q:YSCLA="" D + . S YSCLB=$O(^PS(55,"ASAND1",YSCLA,"")) I YSCLB="" S YSCLER=" record is in error (1) at " D OUT Q + . I '$D(^PS(55,YSCLB,0)) S YSCLER=" record is in error (2) at " D OUT Q + . S YSCLB=$P(^PS(55,YSCLB,0),"^") I YSCLB="" S YSCLER=" record is in error (3) at " D OUT Q + . I '$D(^PS(55,YSCLB,"SAND")) S YSCLER=" record is in error (4) at " D OUT Q + . S DIC="^DPT(",DIC(0)="X",D="SSN",(YSCLSSN,X)=$P(^DPT(YSCLB,0),"^",9) + . I $D(^YSCL(603.01,"B",YSCLA)) S YSCLX=$O(^YSCL(603.01,"B",YSCLA,"")) S:YSCLX]"" YSCLX=$P(^YSCL(603.01,YSCLX,0),"^",2),YSCLER=" Clozapine # "_YSCLA_" is in use by "_$P($G(^DPT(YSCLX,0)),"^")_" at " D OUT Q + . D MIX^DIC1 S YSCLPT=+Y I Y=-1 S YSCLER=" could not be added at " D OUT Q + . K DD S DIC="^YSCL(603.01,",X=YSCLA,DIC("DR")="1////"_YSCLPT K DO D FILE^DICN + . S YSCLX=$O(^YSCL(603.01,"B",YSCLA,"")) S:YSCLX]"" YSCLX=$P(^YSCL(603.01,YSCLX,0),"^",2),YSCLER=","_YSCLSSN_" assigned to "_$P($G(^DPT(YSCLX,0)),"^")_" at " D OUT + Q +OVRRID ;Update record with Monthly, Weekly or Bi-weekly status + F X XMREC Q:XMER<0 S XMRG=$TR(XMRG,"- ","") D + . I XMRG'?2U5N1","9N1",".E S YSCLER=" is in error and was not added at " D OUT Q + . I $P(XMRG,",")'?2U5N S YSCLER=" is not a valid Clozapine number format " D OUT Q + . I $P(XMRG,",",2)'?9N S YSCLER=" An SSN must be 9 numbers " D OUT Q + . K %DT S X=$P(XMRG,",",3),%DT="F" D ^%DT I Y=-1 S YSCLER=" is an invalid date, over-ride authorization not filed at " D OUT Q + . S YSCLOVR=Y + . S YSCLNM=$P(XMRG,","),YSCLSSN=$P(XMRG,",",2),YSCLWB=$P(XMRG,",",3) + . I '$D(^YSCL(603.01,"B",YSCLNM)) S YSCLER=" does not exist at " D OUT Q + . S YSCLDA=$O(^DPT("SSN",YSCLSSN,0)) + . I YSCLDA="" S YSCLER=" SSN does not exist at " D OUT Q + . I $O(^YSCL(603.01,"B",YSCLNM,0))="" S YSCLER=" SSN not in Clozapine file " D OUT Q + . I $O(^DPT("SSN",YSCLSSN,YSCLDA)) S YSCLER=" SSN has more than one owner " D OUT Q + . I $O(^YSCL(603.01,"B",YSCLNM,0))'=$O(^YSCL(603.01,"C",YSCLDA,0)) S YSCLER=" SSN ("_YSCLSSN_","_$P(^DPT(YSCLDA,0),"^")_") has multiple Clozapine Numbers at " D OUT + . I $O(^YSCL(603.01,"B",YSCLNM,0))=$O(^YSCL(603.01,"C",YSCLDA,0)) D + . . S YSCLDA1=$O(^YSCL(603.01,"B",YSCLNM,0)) S $P(^YSCL(603.01,YSCLDA1,0),"^",4)=YSCLOVR + . . S Y=YSCLOVR D DD^%DT S YSCLER=" "_YSCLNM_" ("_$P(^DPT(YSCLDA,0),"^")_") authorized for over-ride on "_Y_" at " D OUT + G EXIT^YSCLSERV +ZEOR ;YSCLSRV2 diff --git a/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSCLSRV3.m b/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSCLSRV3.m index 10487d0e..30ea046e 100644 --- a/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSCLSRV3.m +++ b/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSCLSRV3.m @@ -1,93 +1,93 @@ -YSCLSRV3 ;DALOI/RLM-Clozapine data server ;24 APR 1990 - ;;5.01;MENTAL HEALTH;**74,90,92**;Dec 30, 1994;Build 7 - ; Reference to ^%ZOSF supported by IA #10096 - ; Reference to ^DPT supported by IA #10035 - ; Reference to ^PS(55 supported by IA #787 - ; Reference to ^PSDRUG supported by IA #25 - ; Reference to ^PSRX supported by IA #780 - ; Reference to ^VA(200 supported by IA #10060 - ; Reference to ^XUSEC supported by IA #10076 - ; - S ^TMP($J,"YSCLDATA",1)="This routine will print a list of all active Clozapine prescriptions." - S ^TMP($J,"YSCLDATA",2)="An asterisk in the first column indicates that the prescription is over" - S ^TMP($J,"YSCLDATA",3)="28 days old. The second column is the Patient Name. The third is the" - S ^TMP($J,"YSCLDATA",4)="Issue Date. The fourth column is the Prescription Number. The final" - S ^TMP($J,"YSCLDATA",5)="column is the CLOZAPINE STATUS indicator." - S X1=DT,X2=-28 D C^%DTC S YSCL28=X - S DFN=0,YSCLLN=6 - F K YSCLA S DFN=$O(^PS(55,"ASAND",DFN)),YSCLLD=0 Q:'DFN I $D(^DPT(DFN,0)),$D(^PS(55,DFN,"SAND")) S YSCLSAND=^("SAND"),YSCL=^DPT(DFN,0),YSCLX=$E($P($P(YSCL,"^"),",",2))_$E(YSCL)_"^"_$P(YSCL,"^",9) D - . F YSCL=0:0 S YSCL=$O(^PS(55,DFN,"P",YSCL)) Q:'YSCL I $D(^(YSCL,0)) S YSCL1=^(0) I $D(^PSRX(YSCL1,0)) D ACTIVE I 'YSACT S YSCLRX=^PSRX(YSCL1,0) I $P($G(^PSDRUG(+$P(YSCLRX,"^",6),"CLOZ1")),"^")="PSOCLO1",$D(^("CLOZ")) S YSCLLAB=^("CLOZ") D - . . ;W !,DFN," - ",YSCL1 - . . S ^TMP($J,"YSCLDATA",YSCLLN)=$S(YSCL28>$P(YSCLRX,"^",13):"*",1:" ")_"^"_$P(^DPT($P(YSCLRX,"^",2),0),"^")_"^"_$$FMTE^XLFDT($P(YSCLRX,"^",13))_"^"_$P(YSCLRX,"^")_"^"_$P(YSCLSAND,"^",2) - . . S YSCLLN=YSCLLN+1 - G EXIT^YSCLSERV - Q -ACTIVE ; - S YSACT=$$GET1^DIQ(52,YSCL1_",",100,"I","ERR") - Q -DEMOG ; - S YSCLA=0 F S YSCLA=$O(^YSCL(603.01,"C",YSCLA)) Q:'YSCLA D - . I $D(^PS(55,YSCLA,"SAND")),$P(^PS(55,YSCLA,"SAND"),"^",4)=0 S YSCLC=$G(YSCLC)+1 - . I $D(^PS(55,YSCLA,"SAND")),$P(^PS(55,YSCLA,"SAND"),"^",4) S $P(^PS(55,YSCLA,"SAND"),"^",4)=0,YSCLB=$G(YSCLB)+1 - S ^TMP($J,"YSCLDATA",2)=+$G(YSCLB)_" record"_$S(+$G(YSCLB)=1:"",1:"s")_" reset at ("_YSCLST_") "_YSCLSTN - S ^TMP($J,"YSCLDATA",3)=+$G(YSCLC)_" record"_$S(+$G(YSCLC)=1:"",1:"s")_" not reset at ("_YSCLST_") "_YSCLSTN - G EXIT^YSCLSERV - Q -LOCK ;Lock out ability to dispense Clozapine - X XMREC Q:XMER<0 S X=XMRG - I X="LOCK DOWN ON" S $P(^YSCL(603.03,1,1),"^",1)=1 S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="Clozapine dispensing prohibited at "_YSCLST - I X="LOCK DOWN OFF" S $P(^YSCL(603.03,1,1),"^",1)=0 S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="Clozapine dispensing enabled at "_YSCLST - G EXIT^YSCLSERV - Q -AUTH ;List authorized Clozapine providers - I YSCLSUB["LIST" D G EXIT^YSCLSERV - . S ^TMP($J,"YSCLDATA",1)="The following providers are authorized to override Clozapine lockouts (PSOLOCKCLOZ)" - . S YSCLLN=2 - . S YSCLA="" F S YSCLA=$O(^XUSEC("PSOLOCKCLOZ",YSCLA)) Q:YSCLA="" D - . . Q:'$D(^VA(200,YSCLA,0)) - . . S ^TMP($J,"YSCLDATA",YSCLLN)=$P(^VA(200,YSCLA,0),"^",1)_" "_$S($P(^VA(200,YSCLA,0),"^",7)=1:"Ina",1:"A")_"ctive",YSCLLN=YSCLLN+1 - . S ^TMP($J,"YSCLDATA",YSCLLN)="",YSCLLN=YSCLLN+1 - . S ^TMP($J,"YSCLDATA",YSCLLN)="",YSCLLN=YSCLLN+1 - . S ^TMP($J,"YSCLDATA",YSCLLN)="",YSCLLN=YSCLLN+1 - . S ^TMP($J,"YSCLDATA",YSCLLN)="The following providers are authorized to access the Pharmacy Clozapine Manager Menu (PSZ CLOZAPINE)",YSCLLN=YSCLLN+1 - . S YSCLA="" F S YSCLA=$O(^XUSEC("PSZ CLOZAPINE",YSCLA)) Q:YSCLA="" D - . . Q:'$D(^VA(200,YSCLA,0)) - . . S ^TMP($J,"YSCLDATA",YSCLLN)=$P(^VA(200,YSCLA,0),"^",1)_" "_$S($P(^VA(200,YSCLA,0),"^",7)=1:"Ina",1:"A")_"ctive",YSCLLN=YSCLLN+1 - . S ^TMP($J,"YSCLDATA",YSCLLN)="",YSCLLN=YSCLLN+1 - . S ^TMP($J,"YSCLDATA",YSCLLN)="",YSCLLN=YSCLLN+1 - . S ^TMP($J,"YSCLDATA",YSCLLN)="",YSCLLN=YSCLLN+1 - . S ^TMP($J,"YSCLDATA",YSCLLN)="The following providers are authorized to prescribe Clozapine (YSCL AUTHORIZED)",YSCLLN=YSCLLN+1 - . S YSCLA=0 F S YSCLA=$O(^XUSEC("YSCL AUTHORIZED",YSCLA)) Q:'YSCLA D ;??? Use FileMan lookup on 200 - . . S YSCLDEA=$$DEA^XUSER(1,YSCLA),YSCLYN=1,YSCLSSN=$P(^VA(200,YSCLA,1),"^",9) - . . S ^TMP($J,"YSCLDATA",YSCLLN)=$P($G(^VA(200,YSCLA,0)),"^",1)_" - "_YSCLSSN_" - "_$S(YSCLDEA="":"*NONE*",1:YSCLDEA)_" - "_$S(YSCLYN=1:"Yes",1:"NO"),YSCLLN=YSCLLN+1 - ;Holders of YSCL AUTHORIZED key - ;============================================= - ; - S YSCLLN=1,^TMP($J,"YSCLDATA",YSCLLN)="Clinician Authorization Results at "_YSCLST,YSCLLN=YSCLLN+1 - K ^TMP("DIERR",$J) - F X XMREC Q:XMER<0 S X=XMRG X ^%ZOSF("UPPERCASE") S X=Y D - . S YSCLSSN=$P(X,"^",1),YSCLDEA=$P(X,"^",2),YSCLYN=$P(X,"^",3),YSCLDUZ="",YSCLDEA1="",YSCLIEN="" - . I YSCLLN=""!("YESNO"'[YSCLYN) S ^TMP($J,"YSCLDATA",YSCLLN)="Clinician Authorization instructions invalid ("_YSCLYN_") at "_YSCLST,YSCLLN=YSCLLN+1 - . S YSCLYN=$S(YSCLYN="YES":1,1:0) - . I '$D(^VA(200,"BS5",YSCLSSN)) S ^TMP($J,"YSCLDATA",YSCLLN)="Clinician ("_YSCLSSN_") does not exist at "_YSCLST,YSCLLN=YSCLLN+1 Q - . I $D(^VA(200,"BS5",YSCLSSN)) S YSCLAA="" F S YSCLAA=$O(^VA(200,"BS5",YSCLSSN,YSCLAA)) Q:YSCLAA="" I $$DEA^XUSER(1,YSCLAA)=YSCLDEA S YSCLDUZ=YSCLAA Q - . I YSCLDUZ="" S ^TMP($J,"YSCLDATA",YSCLLN)="Clinician ("_YSCLSSN_") with DEA# "_YSCLDEA_" does not exist at "_YSCLST,YSCLLN=YSCLLN+1 Q - . S YSCLDEA1=$$DEA^XUSER(1,YSCLDUZ) - . I YSCLDEA1="" S ^TMP($J,"YSCLDATA",YSCLLN)="Clinician with DEA# "_YSCLDEA_" does not exist at "_YSCLST,YSCLLN=YSCLLN+1 Q - . I YSCLDEA'=YSCLDEA1 W ^TMP($J,"YSCLDATA",YSCLLN)="Clinician SSN ("_YSCLSSN_") - DEA ("_YSCLDEA_") mismatch at "_YSCLST,YSCLLN=YSCLLN+1 Q - . D OWNSKEY^XUSRB(.RET,"YSCL AUTHORIZED",YSCLDUZ) - . I RET(0),YSCLYN S ^TMP($J,"YSCLDATA",YSCLLN)="Clinician ("_YSCLSSN_") already authorized at "_YSCLST,YSCLLN=YSCLLN+1 Q - . I 'RET(0),'YSCLYN S ^TMP($J,"YSCLDATA",YSCLLN)="Clinician ("_YSCLSSN_") not authorized at "_YSCLST,YSCLLN=YSCLLN+1 Q - . I 'RET(0),YSCLYN S YSCLDUZ(0)=DUZ,DUZ(0)="@" D S DUZ(0)=YSCLDUZ(0) - . . S YSCLFDA(200,"?1,",.01)="`"_YSCLDUZ - . . S YSCLFDA(200.051,"+2,?1,",.01)="YSCL AUTHORIZED" D UPDATE^DIE("E","YSCLFDA",,"YSCLERR") - . . I $D(YSCLERR) S ^TMP($J,"YSCLDATA",YSCLLN)="Clinician SSN "_YSCLSSN_" authorization failed at "_YSCLST,YSCLLN=YSCLLN+1 Q - . . I '$D(YSCLERR) S ^TMP($J,"YSCLDATA",YSCLLN)="Clinician SSN "_YSCLSSN_" authorization set to "_$S(YSCLYN=1:"Yes",1:"No")_" at "_YSCLST,YSCLLN=YSCLLN+1 Q - . I RET(0),'YSCLYN S YSCLDUZ(0)=DUZ,DUZ(0)="@" D S DUZ(0)=YSCLDUZ(0) - . . S DA=$$FIND1^DIC(200.051,","_YSCLDUZ_",","A","YSCL AUTHORIZE") - . . I DA<1 S ^TMP($J,"YSCLDATA",YSCLLN)="Clinician SSN "_YSCLSSN_" authorization removal failed at "_YSCLST,YSCLLN=YSCLLN+1 Q - . . S DA(1)=YSCLDUZ,DIK="^VA(200,"_DA(1)_",51," D ^DIK - . . S ^TMP($J,"YSCLDATA",YSCLLN)="Clinician SSN "_YSCLSSN_" authorization removed at "_YSCLST,YSCLLN=YSCLLN+1 Q - G EXIT^YSCLSERV - Q -ZEOR ;YSCLSRV3 +YSCLSRV3 ;DALOI/RLM-Clozapine data server ;24 APR 1990 + ;;5.01;MENTAL HEALTH;**74,90**;Dec 30, 1994;Build 18 + ; Reference to ^%ZOSF supported by IA #10096 + ; Reference to ^DPT supported by IA #10035 + ; Reference to ^PS(55 supported by IA #787 + ; Reference to ^PSDRUG supported by IA #25 + ; Reference to ^PSRX supported by IA #780 + ; Reference to ^VA(200 supported by IA #10060 + ; Reference to ^XUSEC supported by IA #10076 + ; + S ^TMP($J,"YSCLDATA",1)="This routine will print a list of all active Clozapine prescriptions." + S ^TMP($J,"YSCLDATA",2)="An asterisk in the first column indicates that the prescription is over" + S ^TMP($J,"YSCLDATA",3)="28 days old. The second column is the Patient Name. The third is the" + S ^TMP($J,"YSCLDATA",4)="Issue Date. The fourth column is the Prescription Number. The final" + S ^TMP($J,"YSCLDATA",5)="column is the CLOZAPINE STATUS indicator." + S X1=DT,X2=-28 D C^%DTC S YSCL28=X + S DFN=0,YSCLLN=6 + F K YSCLA S DFN=$O(^PS(55,"ASAND",DFN)),YSCLLD=0 Q:'DFN I $D(^DPT(DFN,0)),$D(^PS(55,DFN,"SAND")) S YSCLSAND=^("SAND"),YSCL=^DPT(DFN,0),YSCLX=$E($P($P(YSCL,"^"),",",2))_$E(YSCL)_"^"_$P(YSCL,"^",9) D + . F YSCL=0:0 S YSCL=$O(^PS(55,DFN,"P",YSCL)) Q:'YSCL I $D(^(YSCL,0)) S YSCL1=^(0) I $D(^PSRX(YSCL1,0)) D ACTIVE I 'YSACT S YSCLRX=^PSRX(YSCL1,0) I $P($G(^PSDRUG(+$P(YSCLRX,"^",6),"CLOZ1")),"^")="PSOCLO1",$D(^("CLOZ")) S YSCLLAB=^("CLOZ") D + . . ;W !,DFN," - ",YSCL1 + . . S ^TMP($J,"YSCLDATA",YSCLLN)=$S(YSCL28>$P(YSCLRX,"^",13):"*",1:" ")_"^"_$P(^DPT($P(YSCLRX,"^",2),0),"^")_"^"_$$FMTE^XLFDT($P(YSCLRX,"^",13))_"^"_$P(YSCLRX,"^")_"^"_$P(YSCLSAND,"^",2) + . . S YSCLLN=YSCLLN+1 + G EXIT^YSCLSERV + Q +ACTIVE ; + S YSACT=$$GET1^DIQ(52,YSCL1_",",100,"I","ERR") + Q +DEMOG ; + S YSCLA=0 F S YSCLA=$O(^YSCL(603.01,"C",YSCLA)) Q:'YSCLA D + . I $D(^PS(55,YSCLA,"SAND")),$P(^PS(55,YSCLA,"SAND"),"^",4)=0 S YSCLC=$G(YSCLC)+1 + . I $D(^PS(55,YSCLA,"SAND")),$P(^PS(55,YSCLA,"SAND"),"^",4) S $P(^PS(55,YSCLA,"SAND"),"^",4)=0,YSCLB=$G(YSCLB)+1 + S ^TMP($J,"YSCLDATA",2)=+$G(YSCLB)_" record"_$S(+$G(YSCLB)=1:"",1:"s")_" reset at ("_YSCLST_") "_YSCLSTN + S ^TMP($J,"YSCLDATA",3)=+$G(YSCLC)_" record"_$S(+$G(YSCLC)=1:"",1:"s")_" not reset at ("_YSCLST_") "_YSCLSTN + G EXIT^YSCLSERV + Q +LOCK ;Lock out ability to dispense Clozapine + X XMREC Q:XMER<0 S X=XMRG + I X="LOCK DOWN ON" S $P(^YSCL(603.03,1,1),"^",1)=1 S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="Clozapine dispensing prohibited at "_YSCLST + I X="LOCK DOWN OFF" S $P(^YSCL(603.03,1,1),"^",1)=0 S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="Clozapine dispensing enabled at "_YSCLST + G EXIT^YSCLSERV + Q +AUTH ;List authorized Clozapine providers + I YSCLSUB["LIST" D G EXIT^YSCLSERV + . S ^TMP($J,"YSCLDATA",1)="The following providers are authorized to override Clozapine lockouts" + . S YSCLLN=2 + . S YSCLA="" F S YSCLA=$O(^XUSEC("PSOLOCKCLOZ",YSCLA)) Q:YSCLA="" D + . . Q:'$D(^VA(200,YSCLA,0)) + . . S ^TMP($J,"YSCLDATA",YSCLLN)=$P(^VA(200,YSCLA,0),"^",1)_" "_$S($P(^VA(200,YSCLA,0),"^",7)=1:"Ina",1:"A")_"ctive",YSCLLN=YSCLLN+1 + . S ^TMP($J,"YSCLDATA",YSCLLN)="",YSCLLN=YSCLLN+1 + . S ^TMP($J,"YSCLDATA",YSCLLN)="",YSCLLN=YSCLLN+1 + . S ^TMP($J,"YSCLDATA",YSCLLN)="",YSCLLN=YSCLLN+1 + . S ^TMP($J,"YSCLDATA",YSCLLN)="The following providers are authorized to access the Pharmacy Clozapine Manager Menu",YSCLLN=YSCLLN+1 + . S YSCLA="" F S YSCLA=$O(^XUSEC("PSZ CLOZAPINE",YSCLA)) Q:YSCLA="" D + . . Q:'$D(^VA(200,YSCLA,0)) + . . S ^TMP($J,"YSCLDATA",YSCLLN)=$P(^VA(200,YSCLA,0),"^",1)_" "_$S($P(^VA(200,YSCLA,0),"^",7)=1:"Ina",1:"A")_"ctive",YSCLLN=YSCLLN+1 + . S ^TMP($J,"YSCLDATA",YSCLLN)="",YSCLLN=YSCLLN+1 + . S ^TMP($J,"YSCLDATA",YSCLLN)="",YSCLLN=YSCLLN+1 + . S ^TMP($J,"YSCLDATA",YSCLLN)="",YSCLLN=YSCLLN+1 + . S ^TMP($J,"YSCLDATA",YSCLLN)="The following providers are authorized to prescribe Clozapine",YSCLLN=YSCLLN+1 + . S YSCLA=0 F S YSCLA=$O(^XUSEC("YSCL AUTHORIZED",YSCLA)) Q:'YSCLA D ;??? Use FileMan lookup on 200 + . . S YSCLDEA=$$DEA^XUSER(1,YSCLA),YSCLYN=1,YSCLSSN=$P(^VA(200,YSCLA,1),"^",9) + . . S ^TMP($J,"YSCLDATA",YSCLLN)=$P($G(^VA(200,YSCLA,0)),"^",1)_" - "_YSCLSSN_" - "_$S(YSCLDEA="":"*NONE*",1:YSCLDEA)_" - "_$S(YSCLYN=1:"Yes",1:"NO"),YSCLLN=YSCLLN+1 + ;Holders of YSCL AUTHORIZED key + ;============================================= + ; + S YSCLLN=1,^TMP($J,"YSCLDATA",YSCLLN)="Clinician Authorization Results at "_YSCLST,YSCLLN=YSCLLN+1 + K ^TMP("DIERR",$J) + F X XMREC Q:XMER<0 S X=XMRG X ^%ZOSF("UPPERCASE") S X=Y D + . S YSCLSSN=$P(X,"^",1),YSCLDEA=$P(X,"^",2),YSCLYN=$P(X,"^",3),YSCLDUZ="",YSCLDEA1="",YSCLIEN="" + . I YSCLLN=""!("YESNO"'[YSCLYN) S ^TMP($J,"YSCLDATA",YSCLLN)="Clinician Authorization instructions invalid ("_YSCLYN_") at "_YSCLST,YSCLLN=YSCLLN+1 + . S YSCLYN=$S(YSCLYN="YES":1,1:0) + . I '$D(^VA(200,"BS5",YSCLSSN)) S ^TMP($J,"YSCLDATA",YSCLLN)="Clinician ("_YSCLSSN_") does not exist at "_YSCLST,YSCLLN=YSCLLN+1 Q + . I $D(^VA(200,"BS5",YSCLSSN)) S YSCLAA="" F S YSCLAA=$O(^VA(200,"BS5",YSCLSSN,YSCLAA)) Q:YSCLAA="" I $$DEA^XUSER(1,YSCLAA)=YSCLDEA S YSCLDUZ=YSCLAA Q + . I YSCLDUZ="" S ^TMP($J,"YSCLDATA",YSCLLN)="Clinician ("_YSCLSSN_") with DEA# "_YSCLDEA_" does not exist at "_YSCLST,YSCLLN=YSCLLN+1 Q + . S YSCLDEA1=$$DEA^XUSER(1,YSCLDUZ) + . I YSCLDEA1="" S ^TMP($J,"YSCLDATA",YSCLLN)="Clinician with DEA# "_YSCLDEA_" does not exist at "_YSCLST,YSCLLN=YSCLLN+1 Q + . I YSCLDEA'=YSCLDEA1 W ^TMP($J,"YSCLDATA",YSCLLN)="Clinician SSN ("_YSCLSSN_") - DEA ("_YSCLDEA_") mismatch at "_YSCLST,YSCLLN=YSCLLN+1 Q + . D OWNSKEY^XUSRB(.RET,"YSCL AUTHORIZED",YSCLDUZ) + . I RET(0),YSCLYN S ^TMP($J,"YSCLDATA",YSCLLN)="Clinician ("_YSCLSSN_") already authorized at "_YSCLST,YSCLLN=YSCLLN+1 Q + . I 'RET(0),'YSCLYN S ^TMP($J,"YSCLDATA",YSCLLN)="Clinician ("_YSCLSSN_") not authorized at "_YSCLST,YSCLLN=YSCLLN+1 Q + . I 'RET(0),YSCLYN S YSCLDUZ(0)=DUZ,DUZ(0)="@" D S DUZ(0)=YSCLDUZ(0) + . . S YSCLFDA(200,"?1,",.01)="`"_YSCLDUZ + . . S YSCLFDA(200.051,"+2,?1,",.01)="YSCL AUTHORIZED" D UPDATE^DIE("E","YSCLFDA",,"YSCLERR") + . . I $D(YSCLERR) S ^TMP($J,"YSCLDATA",YSCLLN)="Clinician SSN "_YSCLSSN_" authorization failed at "_YSCLST,YSCLLN=YSCLLN+1 Q + . . I '$D(YSCLERR) S ^TMP($J,"YSCLDATA",YSCLLN)="Clinician SSN "_YSCLSSN_" authorization set to "_$S(YSCLYN=1:"Yes",1:"No")_" at "_YSCLST,YSCLLN=YSCLLN+1 Q + . I RET(0),'YSCLYN S YSCLDUZ(0)=DUZ,DUZ(0)="@" D S DUZ(0)=YSCLDUZ(0) + . . S DA=$$FIND1^DIC(200.051,","_YSCLDUZ_",","A","YSCL AUTHORIZE") + . . I DA<1 S ^TMP($J,"YSCLDATA",YSCLLN)="Clinician SSN "_YSCLSSN_" authorization removal failed at "_YSCLST,YSCLLN=YSCLLN+1 Q + . . S DA(1)=YSCLDUZ,DIK="^VA(200,"_DA(1)_",51," D ^DIK + . . S ^TMP($J,"YSCLDATA",YSCLLN)="Clinician SSN "_YSCLSSN_" authorization removed at "_YSCLST,YSCLLN=YSCLLN+1 Q + G EXIT^YSCLSERV + Q +ZEOR ;YSCLSRV3 diff --git a/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSCLTST2.m b/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSCLTST2.m index 30396a51..c3eed48b 100644 --- a/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSCLTST2.m +++ b/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSCLTST2.m @@ -1,111 +1,142 @@ -YSCLTST2 ;DALOI/LB/RLM-TRANSMIT RX AND lAB DATA FOR CLOZAPINE ;19 Feb 93 - ;;5.01;MENTAL HEALTH;**18,22,26,47,61,69,74,90,92**;Dec 30, 1994;Build 7 - ; Reference to ^LAB(60 supported by IA #333 - ; Reference to ^PSDRUG supported by IA #25 - ; Reference to ^XMD supported by IA #10070 - ; -TRANSMIT ; send remote and local, kill and quit - K XMZ S %DT="T",X="NOW" D ^%DT S YSCLNOW=$P(Y,".",2),YSCLSITE=$P($$SITE^VASITE,"^",2) - S $P(YSSTOP,",",7)=7 I $$S^%ZTLOAD D ABORT^YSCLTEST G END - I YSCLLN D - . K XMY - . S XMY("S.RUCLRXLAB@FO-HINES.MED.VA.GOV")="" - . I YSDEBUG K XMY S XMY("G.CLOZAPINE DEBUG@FO-DALLAS.MED.VA.GOV")="",XMY("G.RUCLRXLAB@FO-DALLAS.MED.VA.GOV")="" - . S XMDUZ="Clozapine MONITOR",XMTEXT="^TMP($J,",XMSUB=$S(YSDEBUG:"DEBUG ",1:"")_"Clozapine lab data @ "_YSCLSITE_" on "_DT_" at "_YSCLNOW D ^XMD - K XMY - S XMY("G.CLOZAPINE ROLL-UP@FORUM.VA.GOV")="" - I YSDEBUG K XMY S XMY("G.CLOZAPINE DEBUG@FO-DALLAS.MED.VA.GOV")="" - S XMY("G.PSOCLOZ")="" - S XMSUB=$S(YSDEBUG:"DEBUG ",1:"")_"Clozapine lab data @ "_YSCLSITE_" on "_DT_" at "_YSCLNOW - S ^TMP("YSCL",$J,2,0)=" ",^TMP("YSCL",$J,3,0)="In message # "_$S($D(XMZ):XMZ,1:"no data sent") - K XMZ S XMDUZ="Clozapine MONITOR",^TMP("YSCL",$J,1,0)="Clozapine lab data was transmitted, "_(YSCLLLN-3)_" records were sent",XMTEXT="^TMP(""YSCL"",$J," D ^XMD - S $P(^YSCL(603.03,1,0),"^",5)=$$NOW^XLFDT -END ; - G END1^YSCLTST3 - Q -REXMIT ; retransmit lab and RX data - ; must be a tuesday - S DIR(0)="Y",DIR("A")="Are you sure you wish to retransmit lab data" - D ^DIR K DIR I Y'=1 K Y Q -DATE S %DT="AEXP",%DT(0)=-DT,%DT("A")="Ending date for data collection (must be a tuesday )" - D ^%DT K %DT G END:X="^",END:X="^" I Y=-1 G DATE -SERV S YSCLED=Y,X=Y D H^%DTC I %H#7'=5 W !,"MUST BE A TUESDAY" G DATE - S ZTDESC="Server triggered retransmission" - S ZTSAVE("YSCLED")="",ZTIO="",ZTRTN="REXMIT^YSCLTEST",ZTDTH=$H D ^%ZTLOAD G END -FLSET ;Set up file 603.02 - W @IOF,"This option specifies the blood tests associated with the Clozapine" - W !,"reporting software. Two tests must be defined. The first is the White" - W !,"Blood Count. The second is the Granulocyte (or Neutrophil) percentage." - K DIR W !! S DIR(0)="PA^64:EMZ",DIR("A",1)="Enter the test that will be used to record the White Blood Count for the",DIR("A")="Clozapine patients: " D ^DIR - Q:Y=-1!($D(DUOUT))!($D(DTOUT))!($D(DIRUT))!($D(DIROUT)) - S YSCLWBC=+Y - K DIR W !! S DIR(0)="PA^64:EMZ",DIR("A",1)="Enter the test that will be used to record the Neutrophil Count (percentage)",DIR("A")=" for the Clozapine patients: " D ^DIR - Q:Y=-1!($D(DUOUT))!($D(DTOUT))!($D(DIRUT))!($D(DIROUT)) - S YSCLGRN=+Y - I YSCLWBC,YSCLGRN S ^YSCL(603.02,1,0)=YSCLWBC_"^"_YSCLGRN,$P(^YSCL(603.02,0),"^",3,4)="1^1" - ;Only one entry is allowed. - K DIR,X,Y,YSCLWBC,YSCLGRN,ZTDESC - Q -EN(DRG) ; - K LAB I $P($G(^PSDRUG(DRG,"CLOZ1")),"^")'="PSOCLO1" S LAB("NOT")=0 Q - I $P($G(^PSDRUG(DRG,"CLOZ1")),"^")="PSOCLO1" D - . S (CNT,I)=0 F S I=$O(^PSDRUG(DRG,"CLOZ2",I)) Q:'I S CNT=$G(CNT)+1 - . I CNT'=2 S LAB("BAD TEST")=0 K CNT Q - . K CNT F I=0:0 S I=$O(^PSDRUG(DRG,"CLOZ2",I)) Q:'I D - . . S LABT=$S($P(^PSDRUG(DRG,"CLOZ2",I,0),"^",4)=1:"WBC",1:"ANC"),LAB(LABT)=$P(^PSDRUG(DRG,"CLOZ2",I,0),"^")_"^"_$P(^(0),"^",3)_"^"_$P(^(0),"^",4) - K LABT,I - Q -CL1(DFN,DAYS) ;The routine was split due to size - G CL1^YSCLTST4 - Q - ; -CL(DFN) ; - K ^TMP("LRRR",$J) N RESULTS,YSCLYWBC,YSCLRANC,YSCLXWBC,YSCLRWBC,YSCLFRQ - I 'DFN Q "-1^-1^-1^-1^-1^-1^-1" - S YSCLFRQ=$O(^YSCL(603.01,"C",DFN,"")) I YSCLFRQ]"" S YSCLFRQ=$P(^YSCL(603.01,YSCLFRQ,0),"^",3) - I $G(^YSCL(603.03,1,1))=1!(YSCLFRQ="") Q "-1^0^0^0^0^0^"_YSCLFRQ - S X1=DT,X2="-7" D C^%DTC S YSCLSD=X - S YSCLA=0 F S YSCLA=$O(^YSCL(603.04,1,1,YSCLA)) Q:'YSCLA S YSCLTLS=^YSCL(603.04,1,1,YSCLA,0),YSCLTLS($P(YSCLTLS,"^",2),$P(YSCLTLS,"^",1))=$P(YSCLTLS,"^",3) - S YSCLTL="" F S YSCLTL=$O(^YSCL(603.04,1,1,"B",YSCLTL)) Q:'YSCLTL D - . D RR^LR7OR1(DFN,,YSCLSD,DT,,YSCLTL,"L") - . S YSCLSB1="" F S YSCLSB1=$O(^TMP("LRRR",$J,DFN,YSCLSB1)) Q:YSCLSB1="" D - . . S YSCLTDT="" F S YSCLTDT=$O(^TMP("LRRR",$J,DFN,YSCLSB1,YSCLTDT)) Q:YSCLTDT="" I $P(YSCLTDT,".",2)]"" D - . . . S YSCLTA="" F S YSCLTA=$O(^TMP("LRRR",$J,DFN,YSCLSB1,YSCLTDT,YSCLTA)) Q:YSCLTA="" I YSCLTA D - . . . . S RESULTS1=^TMP("LRRR",$J,DFN,YSCLSB1,YSCLTDT,YSCLTA) - . . . . S RESULTS(YSCLTL,YSCLTDT)=$P(RESULTS1,"^",2) - ;Find all entries for WBC and sort by inverse date. - S YSCLA="" F S YSCLA=$O(YSCLTLS("W",YSCLA)) Q:'YSCLA S YSCLXWBC(YSCLA)="" D - . S YSCLA1="" F S YSCLA1=$O(RESULTS(YSCLA,YSCLA1)) Q:'YSCLA1 S YSCLYWBC(YSCLA1)=RESULTS(YSCLA,YSCLA1)_"^"_$P($G(^LAB(60,YSCLA,0)),"^")_"^"_YSCLTLS("W",YSCLA) - S YSCLRWBC=$O(YSCLYWBC(0)) I 'YSCLRWBC D KILL Q "0^^^^^^"_YSCLFRQ - S YSCLMULT=$P(YSCLYWBC(YSCLRWBC),"^",3),YSCLMULT=$S(YSCLMULT:1000,1:1) - S YSCLRWBC(YSCLRWBC)=($P(YSCLYWBC(YSCLRWBC),"^")*YSCLMULT)_"^"_$P(YSCLYWBC(YSCLRWBC),"^",2) - ;Scan for Neutrophil count on same day and time as most recent WBC - S YSCLMTCH=0 F YSCLA="A","N","S","T" S YSCLTPT="" Q:YSCLMTCH F S YSCLTPT=$O(YSCLTLS(YSCLA,YSCLTPT)) Q:'YSCLTPT D Q:YSCLMTCH - . S YSCLMULT=YSCLTLS(YSCLA,YSCLTPT),YSCLMULT=$S(YSCLMULT:1000,1:1) - . I $D(RESULTS(YSCLTPT,YSCLRWBC)),YSCLA="A",RESULTS(YSCLTPT,YSCLRWBC)'?1A.E S YSCLMTCH=1,YSCLRANC(YSCLRWBC)=RESULTS(YSCLTPT,YSCLRWBC)*YSCLMULT_"^"_$P(^LAB(60,YSCLTPT,0),"^") Q - . I $D(RESULTS(YSCLTPT,YSCLRWBC)),YSCLA="N",RESULTS(YSCLTPT,YSCLRWBC)'?1A.E S YSCLMTCH=1,YSCLRANC(YSCLRWBC)=YSCLRWBC(YSCLRWBC)*((RESULTS(YSCLTPT,YSCLRWBC))*.01)_"^"_$P(^LAB(60,YSCLTPT,0),"^") Q - . I $D(RESULTS(YSCLTPT,YSCLRWBC)),YSCLA="S",RESULTS(YSCLTPT,YSCLRWBC)'?1A.E D - . . S YSCLSGS="" F S YSCLSGS=$O(YSCLTLS("B",YSCLSGS)) D Q:YSCLMTCH - . . . S:'YSCLSGS YSCLSGS="Z" I '$D(RESULTS(YSCLSGS,YSCLRWBC)) S RESULTS(YSCLSGS,YSCLRWBC)=0 - . . . S YSCLMTCH=1,YSCLRANC(YSCLRWBC)=YSCLRWBC(YSCLRWBC)*((RESULTS(YSCLTPT,YSCLRWBC)*.01)+(RESULTS(YSCLSGS,YSCLRWBC)*.01))_"^"_$P(^LAB(60,YSCLTPT,0),"^")_"/"_$P($G(^LAB(60,YSCLSGS,0)),"^") Q - . I $D(RESULTS(YSCLTPT,YSCLRWBC)),YSCLA="C",RESULTS(YSCLTPT,YSCLRWBC)'?1A.E D - . . S YSCLSGS="" F S YSCLSGS=$O(YSCLTLS("T",YSCLSGS)) D Q:YSCLMTCH - . . . S:'YSCLSGS YSCLSGS="Z" I '$D(RESULTS(YSCLSGS,YSCLRWBC)) S RESULTS(YSCLSGS,YSCLRWBC)=0 - . . . S YSCLMTCH=1,YSCLRANC(YSCLRWBC)=((RESULTS(YSCLTPT,YSCLRWBC)*YSCLMULT)+(RESULTS(YSCLSGS,YSCLRWBC)*YSCLMULT))_"^"_$P(^LAB(60,YSCLTPT,0),"^")_"/"_$P($G(^LAB(60,YSCLSGS,0)),"^") Q - D KILL - I $G(YSCLRWBC(YSCLRWBC))<3000!($G(YSCLRANC(YSCLRWBC))<1500) Q "0^"_$G(YSCLRWBC(YSCLRWBC))_"^"_$S($G(YSCLRANC(YSCLRWBC))="":"^",1:$G(YSCLRANC(YSCLRWBC)))_"^"_(9999999-YSCLRWBC)_"^"_YSCLFRQ - I $G(YSCLRWBC(YSCLRWBC))<3500!($G(YSCLRANC(YSCLRWBC))<2000) Q "2^"_$G(YSCLRWBC(YSCLRWBC))_"^"_$S($G(YSCLRANC(YSCLRWBC))="":"^",1:$G(YSCLRANC(YSCLRWBC)))_"^"_(9999999-YSCLRWBC)_"^"_YSCLFRQ - Q "1^"_YSCLRWBC(YSCLRWBC)_"^"_YSCLRANC(YSCLRWBC)_"^"_(9999999-YSCLRWBC)_"^"_YSCLFRQ - ; -KILL ; - K FDA,YSCLSGS,Y15,RESULTS,RESULTS1,YSCLA,YSCLA1,YSCLMTCH,YSCLSB1,YSCLSD,YSCLTA,YSCLMULT - K YSCLTL,YSCLTLS,X1,X2 - Q - ; -OVERRIDE(DFN) ;Check for an over-ride. - S YSCLOVR=$O(^YSCL(603.01,"C",DFN,"")) - Q:YSCLOVR="" 0 - S YSCLOVR=$P(^YSCL(603.01,YSCLOVR,0),"^",4) - Q YSCLOVR=DT - ; -ZEOR ;YSCLTST2 +YSCLTST2 ;DALOI/LB/RLM-TRANSMIT RX AND lAB DATA FOR CLOZAPINE ;19 Feb 93 + ;;5.01;MENTAL HEALTH;**18,22,26,47,61,69,74,90**;Dec 30, 1994;Build 18 + ; Reference to ^LAB(60 supported by IA #333 + ; Reference to ^PSDRUG supported by IA #25 + ; Reference to ^XMD supported by IA #10070 + ; +TRANSMIT ; send remote and local, kill and quit + K XMZ S %DT="T",X="NOW" D ^%DT S YSCLNOW=$P(Y,".",2),YSCLSITE=$P($$SITE^VASITE,"^",2) + S $P(YSSTOP,",",7)=7 I $$S^%ZTLOAD D ABORT^YSCLTEST G END + I YSCLLN D + . K XMY + . S XMY("S.RUCLRXLAB@FO-HINES.MED.VA.GOV")="" + . I YSDEBUG K XMY S XMY("G.CLOZAPINE DEBUG@FO-DALLAS.MED.VA.GOV")="",XMY("G.RUCLRXLAB@FO-DALLAS.MED.VA.GOV")="" + . S XMDUZ="Clozapine MONITOR",XMTEXT="^TMP($J,",XMSUB=$S(YSDEBUG:"DEBUG ",1:"")_"Clozapine lab data @ "_YSCLSITE_" on "_DT_" at "_YSCLNOW D ^XMD + K XMY + S XMY("G.CLOZAPINE ROLL-UP@FORUM.VA.GOV")="" + I YSDEBUG K XMY S XMY("G.CLOZAPINE DEBUG@FO-DALLAS.MED.VA.GOV")="" + S XMY("G.PSOCLOZ")="" + S XMSUB=$S(YSDEBUG:"DEBUG ",1:"")_"Clozapine lab data @ "_YSCLSITE_" on "_DT_" at "_YSCLNOW + S ^TMP("YSCL",$J,2,0)=" ",^TMP("YSCL",$J,3,0)="In message # "_$S($D(XMZ):XMZ,1:"no data sent") + K XMZ S XMDUZ="Clozapine MONITOR",^TMP("YSCL",$J,1,0)="Clozapine lab data was transmitted, "_(YSCLLLN-3)_" records were sent",XMTEXT="^TMP(""YSCL"",$J," D ^XMD + S $P(^YSCL(603.03,1,0),"^",5)=$$NOW^XLFDT +END ; + G END1^YSCLTST3 + Q +REXMIT ; retransmit lab and RX data + ; must be a period ending on tuesday + S DIR(0)="Y",DIR("A")="Are you sure you wish to retransmit lab data" + D ^DIR K DIR I Y'=1 K Y Q +DATE S %DT="AEXP",%DT(0)=-DT,%DT("A")="Ending date for data collection (must be a tuesday )" + D ^%DT K %DT G END:X="^",END:X="^" I Y=-1 G DATE +SERV S YSCLED=Y,X=Y D H^%DTC I %H#7'=5 W !,"MUST BE A TUESDAY" G DATE + S ZTDESC="Server triggered retransmission" + S ZTSAVE("YSCLED")="",ZTIO="",ZTRTN="REXMIT^YSCLTEST",ZTDTH=$H D ^%ZTLOAD G END +FLSET ;Set up file 603.02 + W @IOF,"This option specifies the blood tests associated with the Clozapine" + W !,"reporting software. Two tests must be defined. The first is the White" + W !,"Blood Count. The second is the Granulocyte (or Neutrophil) percentage." + K DIR W !! S DIR(0)="PA^64:EMZ",DIR("A",1)="Enter the test that will be used to record the White Blood Count for the",DIR("A")="Clozapine patients: " D ^DIR + Q:Y=-1!($D(DUOUT))!($D(DTOUT))!($D(DIRUT))!($D(DIROUT)) + S YSCLWBC=+Y + K DIR W !! S DIR(0)="PA^64:EMZ",DIR("A",1)="Enter the test that will be used to record the Neutrophil Count (percentage)",DIR("A")=" for the Clozapine patients: " D ^DIR + Q:Y=-1!($D(DUOUT))!($D(DTOUT))!($D(DIRUT))!($D(DIROUT)) + S YSCLGRN=+Y + I YSCLWBC,YSCLGRN S ^YSCL(603.02,1,0)=YSCLWBC_"^"_YSCLGRN,$P(^YSCL(603.02,0),"^",3,4)="1^1" + ;Only one entry is allowed. No cross reference is necessary. Update zeroeth node RLM 9-29-99 + K DIR,X,Y,YSCLWBC,YSCLGRN,ZTDESC + Q +EN(DRG) ; + K LAB I $P($G(^PSDRUG(DRG,"CLOZ1")),"^")'="PSOCLO1" S LAB("NOT")=0 Q + I $P($G(^PSDRUG(DRG,"CLOZ1")),"^")="PSOCLO1" D + . S (CNT,I)=0 F S I=$O(^PSDRUG(DRG,"CLOZ2",I)) Q:'I S CNT=$G(CNT)+1 + . I CNT'=2 S LAB("BAD TEST")=0 K CNT Q + . K CNT F I=0:0 S I=$O(^PSDRUG(DRG,"CLOZ2",I)) Q:'I D + . . S LABT=$S($P(^PSDRUG(DRG,"CLOZ2",I,0),"^",4)=1:"WBC",1:"ANC"),LAB(LABT)=$P(^PSDRUG(DRG,"CLOZ2",I,0),"^")_"^"_$P(^(0),"^",3)_"^"_$P(^(0),"^",4) + K LABT,I + Q +CL1(DFN,DAYS) ; + K ^TMP($J,"PSO"),RESULTS,YSCLYWBC,YSCLRANC,YSCLXWBC + Q:'DFN + S:'$G(DAYS) DAYS=90 + S YSCLFRQ=$O(^YSCL(603.01,"C",DFN,"")) I YSCLFRQ]"" S YSCLFRQ=$P(^YSCL(603.01,YSCLFRQ,0),"^",3) + I $G(^YSCL(603.03,1,1))=1 Q "-1^0^0^0^0^0^"_YSCLFRQ + S X1=DT,X2="-"_DAYS D C^%DTC S YSCLSD=X + S YSCLA=0 F S YSCLA=$O(^YSCL(603.04,1,1,YSCLA)) Q:'YSCLA S YSCLTLS=^YSCL(603.04,1,1,YSCLA,0),YSCLTLS($P(YSCLTLS,"^",2),$P(YSCLTLS,"^",1))=$P(YSCLTLS,"^",3) + S YSCLTL="" F S YSCLTL=$O(^YSCL(603.04,1,1,"B",YSCLTL)) Q:'YSCLTL D + . D RR^LR7OR1(DFN,,YSCLSD,DT,,YSCLTL,"L") + . S YSCLSB1="" F S YSCLSB1=$O(^TMP("LRRR",$J,DFN,YSCLSB1)) Q:YSCLSB1="" D + . . S YSCLTDT="" F S YSCLTDT=$O(^TMP("LRRR",$J,DFN,YSCLSB1,YSCLTDT)) Q:YSCLTDT="" I $P(YSCLTDT,".",2)]"" D + . . . S YSCLTA="" F S YSCLTA=$O(^TMP("LRRR",$J,DFN,YSCLSB1,YSCLTDT,YSCLTA)) Q:YSCLTA="" I YSCLTA D + . . . . S RESULTS1=^TMP("LRRR",$J,DFN,YSCLSB1,YSCLTDT,YSCLTA) + . . . . S RESULTS(YSCLTL,YSCLTDT)=$P(RESULTS1,"^",2) + ;Find all entries for WBC and sort by inverse date. + S YSCLA="" F S YSCLA=$O(YSCLTLS("W",YSCLA)) Q:'YSCLA S YSCLXWBC(YSCLA)="" D + . S YSCLA1="" F S YSCLA1=$O(RESULTS(YSCLA,YSCLA1)) Q:'YSCLA1 S YSCLYWBC(YSCLA1)=RESULTS(YSCLA,YSCLA1)*$S(YSCLTLS("W",YSCLA):1000,1:1) + S YSCLRWBC=0 F S YSCLRWBC=$O(YSCLYWBC(YSCLRWBC)) Q:YSCLRWBC="" S YSCLRWBC(YSCLRWBC)=YSCLYWBC(YSCLRWBC) D + . ;Match all ANC's and WBC's + . S YSCLMTCH=0 F YSCLA="A","N","S","C" S YSCLTPT="" F S YSCLTPT=$O(YSCLTLS(YSCLA,YSCLTPT)) Q:'YSCLTPT D + . . I $D(RESULTS(YSCLTPT,YSCLRWBC)),YSCLA="A",$D(YSCLRWBC(YSCLRWBC)) S ^TMP($J,"PSO",YSCLRWBC)=YSCLRWBC(YSCLRWBC)_"^"_(RESULTS(YSCLTPT,YSCLRWBC)*$S(YSCLTLS(YSCLA,YSCLTPT):1000,1:1)) Q + . . I $D(RESULTS(YSCLTPT,YSCLRWBC)),YSCLA="N",$D(YSCLRWBC(YSCLRWBC)) S ^TMP($J,"PSO",YSCLRWBC)=YSCLRWBC(YSCLRWBC)_"^"_(YSCLRWBC(YSCLRWBC)*((RESULTS(YSCLTPT,YSCLRWBC)*.01))) Q + . . I $D(RESULTS(YSCLTPT,YSCLRWBC)),YSCLA="S",$D(YSCLRWBC(YSCLRWBC)) D + . . . S YSCLSGS="" F S YSCLSGS=$O(YSCLTLS("B",YSCLSGS)) D Q:'YSCLSGS + . . . . S:'YSCLSGS YSCLSGS="Z" I '$D(RESULTS(YSCLSGS,YSCLRWBC)) S RESULTS(YSCLSGS,YSCLRWBC)=0 + . . . . S ^TMP($J,"PSO",YSCLRWBC)=YSCLRWBC(YSCLRWBC)_"^"_(YSCLRWBC(YSCLRWBC)*((RESULTS(YSCLTPT,YSCLRWBC)*.01)+(RESULTS(YSCLSGS,YSCLRWBC)*.01))) Q + . . I $D(RESULTS(YSCLTPT,YSCLRWBC)),YSCLA="C" D + . . . S YSCLSGS="" F S YSCLSGS=$O(YSCLTLS("T",YSCLSGS)) D Q:'YSCLSGS + . . . . S:'YSCLSGS YSCLSGS="Z" I '$D(RESULTS(YSCLSGS,YSCLRWBC)) S RESULTS(YSCLSGS,YSCLRWBC)=0 + . . . . S ^TMP($J,"PSO",YSCLRWBC)=YSCLRWBC(YSCLRWBC)_"^"_((RESULTS(YSCLTPT,YSCLRWBC)*$S(YSCLTLS(YSCLA,YSCLTPT):1000,1:1))+(RESULTS(YSCLSGS,YSCLRWBC))) Q + K FDA,YSCLSGS,Y15,YSCLRWBC,YSCLANC,YSCLYWBC,YSCLFRQ,ZIENS,RESULTS,RESULTS1,YSCLA,YSCLA1,YSCLMTCH,YSCLSB1,YSCLSD + K YSCLTA,YSCLTDT,YSCLTL,YSCLTLS,YSCLTPT,YSCLXWBC,YSCLMULT + Q + ; + ; +CL(DFN) ; + K ^TMP("LRRR",$J) N RESULTS,YSCLYWBC,YSCLRANC,YSCLXWBC,YSCLRWBC,YSCLFRQ + I 'DFN Q "-1^-1^-1^-1^-1^-1^-1" + S YSCLFRQ=$O(^YSCL(603.01,"C",DFN,"")) I YSCLFRQ]"" S YSCLFRQ=$P(^YSCL(603.01,YSCLFRQ,0),"^",3) + I $G(^YSCL(603.03,1,1))=1!(YSCLFRQ="") Q "-1^0^0^0^0^0^"_YSCLFRQ + S X1=DT,X2="-7" D C^%DTC S YSCLSD=X + S YSCLA=0 F S YSCLA=$O(^YSCL(603.04,1,1,YSCLA)) Q:'YSCLA S YSCLTLS=^YSCL(603.04,1,1,YSCLA,0),YSCLTLS($P(YSCLTLS,"^",2),$P(YSCLTLS,"^",1))=$P(YSCLTLS,"^",3) + S YSCLTL="" F S YSCLTL=$O(^YSCL(603.04,1,1,"B",YSCLTL)) Q:'YSCLTL D + . D RR^LR7OR1(DFN,,YSCLSD,DT,,YSCLTL,"L") + . S YSCLSB1="" F S YSCLSB1=$O(^TMP("LRRR",$J,DFN,YSCLSB1)) Q:YSCLSB1="" D + . . S YSCLTDT="" F S YSCLTDT=$O(^TMP("LRRR",$J,DFN,YSCLSB1,YSCLTDT)) Q:YSCLTDT="" I $P(YSCLTDT,".",2)]"" D + . . . S YSCLTA="" F S YSCLTA=$O(^TMP("LRRR",$J,DFN,YSCLSB1,YSCLTDT,YSCLTA)) Q:YSCLTA="" I YSCLTA D + . . . . S RESULTS1=^TMP("LRRR",$J,DFN,YSCLSB1,YSCLTDT,YSCLTA) + . . . . S RESULTS(YSCLTL,YSCLTDT)=$P(RESULTS1,"^",2) + ;Find all entries for WBC and sort by inverse date. + S YSCLA="" F S YSCLA=$O(YSCLTLS("W",YSCLA)) Q:'YSCLA S YSCLXWBC(YSCLA)="" D + . S YSCLA1="" F S YSCLA1=$O(RESULTS(YSCLA,YSCLA1)) Q:'YSCLA1 S YSCLYWBC(YSCLA1)=RESULTS(YSCLA,YSCLA1)_"^"_$P($G(^LAB(60,YSCLA,0)),"^")_"^"_YSCLTLS("W",YSCLA) + S YSCLRWBC=$O(YSCLYWBC(0)) I 'YSCLRWBC D KILL Q "0^^^^^^"_YSCLFRQ + S YSCLMULT=$P(YSCLYWBC(YSCLRWBC),"^",3),YSCLMULT=$S(YSCLMULT:1000,1:1) + S YSCLRWBC(YSCLRWBC)=($P(YSCLYWBC(YSCLRWBC),"^")*YSCLMULT)_"^"_$P(YSCLYWBC(YSCLRWBC),"^",2) + ;Scan for Neutrophil count on same day and time as most recent WBC + S YSCLMTCH=0 F YSCLA="A","N","S","T" S YSCLTPT="" F S YSCLTPT=$O(YSCLTLS(YSCLA,YSCLTPT)) Q:'YSCLTPT D Q:YSCLMTCH + . S YSCLMULT=YSCLTLS(YSCLA,YSCLTPT),YSCLMULT=$S(YSCLMULT:1000,1:1) + . I $D(RESULTS(YSCLTPT,YSCLRWBC)),YSCLA="A" S YSCLMTCH=1,YSCLRANC(YSCLRWBC)=RESULTS(YSCLTPT,YSCLRWBC)*YSCLMULT_"^"_$P(^LAB(60,YSCLTPT,0),"^") Q + . I $D(RESULTS(YSCLTPT,YSCLRWBC)),YSCLA="N" S YSCLMTCH=1,YSCLRANC(YSCLRWBC)=YSCLRWBC(YSCLRWBC)*((RESULTS(YSCLTPT,YSCLRWBC))*.01)_"^"_$P(^LAB(60,YSCLTPT,0),"^") Q + . I $D(RESULTS(YSCLTPT,YSCLRWBC)),YSCLA="S" D + . . S YSCLSGS="" F S YSCLSGS=$O(YSCLTLS("B",YSCLSGS)) D Q:YSCLMTCH + . . . S:'YSCLSGS YSCLSGS="Z" I '$D(RESULTS(YSCLSGS,YSCLRWBC)) S RESULTS(YSCLSGS,YSCLRWBC)=0 + . . . S YSCLMTCH=1,YSCLRANC(YSCLRWBC)=YSCLRWBC(YSCLRWBC)*((RESULTS(YSCLTPT,YSCLRWBC)*.01)+(RESULTS(YSCLSGS,YSCLRWBC)*.01))_"^"_$P(^LAB(60,YSCLTPT,0),"^")_"/"_$P($G(^LAB(60,YSCLSGS,0)),"^") Q + . I $D(RESULTS(YSCLTPT,YSCLRWBC)),YSCLA="C" D + . . S YSCLSGS="" F S YSCLSGS=$O(YSCLTLS("T",YSCLSGS)) D Q:YSCLMTCH + . . . S:'YSCLSGS YSCLSGS="Z" I '$D(RESULTS(YSCLSGS,YSCLRWBC)) S RESULTS(YSCLSGS,YSCLRWBC)=0 + . . . S YSCLMTCH=1,YSCLRANC(YSCLRWBC)=((RESULTS(YSCLTPT,YSCLRWBC)*YSCLMULT)+(RESULTS(YSCLSGS,YSCLRWBC)*YSCLMULT))_"^"_$P(^LAB(60,YSCLTPT,0),"^")_"/"_$P($G(^LAB(60,YSCLSGS,0)),"^") Q + D KILL + I $G(YSCLRWBC(YSCLRWBC))<3000!($G(YSCLRANC(YSCLRWBC))<1500) Q "0^"_$G(YSCLRWBC(YSCLRWBC))_"^"_$S($G(YSCLRANC(YSCLRWBC))="":"^",1:$G(YSCLRANC(YSCLRWBC)))_"^"_(9999999-YSCLRWBC)_"^"_YSCLFRQ + I $G(YSCLRWBC(YSCLRWBC))<3500!($G(YSCLRANC(YSCLRWBC))<2000) Q "2^"_$G(YSCLRWBC(YSCLRWBC))_"^"_$S($G(YSCLRANC(YSCLRWBC))="":"^",1:$G(YSCLRANC(YSCLRWBC)))_"^"_(9999999-YSCLRWBC)_"^"_YSCLFRQ + Q "1^"_YSCLRWBC(YSCLRWBC)_"^"_YSCLRANC(YSCLRWBC)_"^"_(9999999-YSCLRWBC)_"^"_YSCLFRQ + ; +KILL ; + K FDA,YSCLSGS,Y15,RESULTS,RESULTS1,YSCLA,YSCLA1,YSCLMTCH,YSCLSB1,YSCLSD,YSCLTA,YSCLMULT + K YSCLTDT,YSCLTL,YSCLTLS,YSCLTPT,YSCLXWBC + ; +OVERRIDE(DFN) ;Check to see if the NCCC has authorized an over-ride for today on this patient. + S YSCLOVR=$O(^YSCL(603.01,"C",DFN,"")) + Q:YSCLOVR="" 0 + S YSCLOVR=$P(^YSCL(603.01,YSCLOVR,0),"^",4) + Q YSCLOVR=DT + ; +ZEOR ;YSCLTST2 diff --git a/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTALUSE.m b/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTALUSE.m index c8e78a69..e88d83a8 100644 --- a/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTALUSE.m +++ b/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTALUSE.m @@ -1,10 +1,10 @@ -YTALUSE ;ALB/ASF TEST-AUDIT ALCOHOL SCREEN ;4/30/97 09:25 - ;;5.01;MENTAL HEALTH;**31**;Dec 30, 1994 -SCOR ; - S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1) - S R=0 F I=1:1:8 S R=R+$E(X,I) - S X1=$S($E(X,9)=1:2,$E(X,9)=2:4,1:0) S R=R+X1 - S X1=$S($E(X,10)=1:2,$E(X,10)=2:4,1:0) S R=R+X1 - D REPT^YTREPT - W !!,"A score of 8 or more indicates a strong likelihood of hazardous",!,"or harmful alcohol consumption." - QUIT +YTALUSE ;ALB/ASF TEST-AUDIT ALCOHOL SCREEN ;4/30/97 09:25 + ;;5.01;MENTAL HEALTH;**31**;Dec 30, 1994 +SCOR ; + S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1) + S R=0 F I=1:1:8 S R=R+$E(X,I) + S X1=$S($E(X,9)=1:2,$E(X,9)=2:4,1:0) S R=R+X1 + S X1=$S($E(X,10)=1:2,$E(X,10)=2:4,1:0) S R=R+X1 + D REPT^YTREPT + W !!,"A score of 8 or more indicates a strong likelihood of hazardous",!,"or harmful alcohol consumption." + QUIT diff --git a/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTAPI5.m b/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTAPI5.m index 2e66357a..a641bbca 100644 --- a/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTAPI5.m +++ b/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTAPI5.m @@ -1,87 +1,77 @@ -YTAPI5 ;ALB/ASF- MH API NOTES ; 7/24/07 4:11pm - ;;5.01;MENTAL HEALTH;**62,85**;Dec 30, 1994;Build 49 - Q -OUTNOTE(YSDATA) ; - N G,I,N,P,R,X,Y,YS2,YSADATE,YSCODE,YSGG,YSGG1,YSGG2,YSJ,YSJJ,YSNCODE,YSSET,YSSR,YSST,YSX1,YSX2,YSX3,YIN,YSINN,YSINE,YSMC - I $G(YSDATA(1))?1"[ERROR".E Q ;----> - I '$D(YSDATA(5)) S YSDATA(1)="[ERROR]",YSDATA(2)="bad ysdata to outnote" Q ;---> - S YS2=$G(YSDATA(2)) - S YSCODE=$P(YS2,U,2) - S YSADATE=$P(YS2,U,4) - S YSNCODE=$O(^YTT(601,"B",YSCODE,-1)) - S YSX1=$P(YSDATA(3),U,2) - S YSX2=$P(YSDATA(4),U,2) - S YSX3=$P(YSDATA(5),U,2) - S YSSR=$P(YSDATA(6),U,3) - S YSST=$P(YSDATA(6),U,4) - S Y=$G(^YTT(601.6,YSNCODE,2)) - I Y="" S YSDATA(1)="[ERROR]",YSDATA(2)="no mh mult outcome code" Q ;---> - ; - X Y - I X'>0 S YSDATA(1)="[ERROR]",YSDATA(2)="bad M executable" Q ;---> -LD ;LOAD NOTE - S N=0 - F S N=$O(^YTT(601.6,YSNCODE,3,X,1,N)) Q:N'>0 D - . S YSDATA("ON",N,0)=^YTT(601.6,YSNCODE,3,X,1,N,0) -REP ;replace || - S N=0 - F S N=$O(YSDATA("ON",N)) Q:N'>0 D - . S G=YSDATA("ON",N,0) - . S R="" - . F I=1:1:$L(G,"|") D - .. S P=$P(G,"|",I) - .. D:P?1"RSCORE".1N.N RSCORE - .. D:P?1"SSCORE".1N.N SSCORE - .. D:P?1"ITEM".1N.E ITEM - .. D:P?1"EXECUTE".E MC - .. S R=R_P - . S YSDATA("ON",N,0)=R - Q -RSCORE ; raw scores - S YSJ=$E(P,7,99),P=$P(YSDATA(YSJ+5),U,3) - Q -SSCORE ;scaled score - S YSJ=$E(P,7,99),P=$P(YSDATA(YSJ+5),U,4) - Q -ITEM ;items resolution - S YSIN=$E(P,5,999) - S YSSET=$P(YSIN,";",2) - S YSIN=$P(YSIN,";",1) - S YSINN=$S(YSIN>400:5,YSIN>200:4,1:3) - S YSINE=$S(YSIN#200=0:200,1:YSIN) - S P=$P(YSDATA(YSINN),U,2) - S P=$E(P,YSINE) - Q:YSSET="" - F YSJJ=1:1:$L(YSSET,",") D - . S YSGG=$P(YSSET,",",YSJJ),YSGG1=$P(YSGG,":"),YSGG2=$P(YSGG,":",2) - . S:P=YSGG1 P=YSGG2 - Q -MC ;mumps executable setting P - S YSMC=$P(P,";",2) - X YSMC - Q -GAFURL(YSDATA) ;returns MH GAF horizontal sheet - S YSDATA(1)="[DATA]" - S YSDATA(2)="http://vaww.mentalhealth.med.va.gov/gafsheet.htm" - Q -PRIVL(YSDATA,YS) ;check privileges - N YSCODE,YSET - S YSCODE=$G(YS("CODE"),-1) - ;ASF 03/08/06 - I (YSCODE="GAF")!(YSCODE="ASI") S YSDATA(1)="[DATA]",YSDATA(2)="1^exempt test" Q ;-->out test exempt - I $D(^YTT(601.71,"B",YSCODE)) D Q ;--> out - . S YSET=$O(^YTT(601.71,"B",YSCODE,0)) - . S YSDATA(1)="[DATA]" - . S YSKEY=$$GET1^DIQ(601.71,YSET_",",9) - . I YSKEY="" S YSDATA(2)="1^exempt test" Q ;-->out - . I $D(^XUSEC(YSKEY,DUZ)) S YSDATA(2)="1^user privileged" Q ;-->out has key - . S YSDATA(2)="0^no access" Q ;->out - ; - I '$D(^YTT(601,"B",YSCODE)) S YSDATA(1)="[ERROR]",YSDATA(2)="BAD TEST CODE" Q ;--> out - S YSET=$O(^YTT(601,"B",YSCODE,0)) - S YSDATA(1)="[DATA]" - I $D(^XUSEC("YSP",DUZ)) S YSDATA(2)="1^user privileged for all tests" Q ;has key - I $P(^YTT(601,YSET,0),U,10)="Y"!(YSCODE="GAF")!(YSCODE="ASI") S YSDATA(2)="1^exempt test" Q ;test exempt - I $P(^YTT(601,YSET,0),U,9)="I" S YSDATA(2)="1^interview" Q ;interview - S YSDATA(2)="0^no access" - Q +YTAPI5 ;ALB/ASF- MH API NOTES ;3/17/00 14:54 + ;;5.01;MENTAL HEALTH;**62**;Dec 30, 1994 + Q +OUTNOTE(YSDATA) ; + N G,I,N,P,R,X,Y,YS2,YSADATE,YSCODE,YSGG,YSGG1,YSGG2,YSJ,YSJJ,YSNCODE,YSSET,YSSR,YSST,YSX1,YSX2,YSX3,YIN,YSINN,YSINE,YSMC + I $G(YSDATA(1))?1"[ERROR".E Q ;----> + I '$D(YSDATA(5)) S YSDATA(1)="ERROR]",YSDATA(2)="bad ysdata to outnote" Q ;---> + S YS2=$G(YSDATA(2)) + S YSCODE=$P(YS2,U,2) + S YSADATE=$P(YS2,U,4) + S YSNCODE=$O(^YTT(601,"B",YSCODE,-1)) + S YSX1=$P(YSDATA(3),U,2) + S YSX2=$P(YSDATA(4),U,2) + S YSX3=$P(YSDATA(5),U,2) + S YSSR=$P(YSDATA(6),U,3) + S YSST=$P(YSDATA(6),U,4) + S Y=$G(^YTT(601.6,YSNCODE,2)) + I Y="" S YSDATA(1)="[ERROR"],YSDATA(2)="no mh mult outcome code" Q ;---> + ; + X Y + I X'>0 S YSDATA(1)="[ERROR]",YSDATA(2)="bad M executable" Q ;---> +LD ;LOAD NOTE + S N=0 + F S N=$O(^YTT(601.6,YSNCODE,3,X,1,N)) Q:N'>0 D + . S YSDATA("ON",N,0)=^YTT(601.6,YSNCODE,3,X,1,N,0) +REP ;replace || + S N=0 + F S N=$O(YSDATA("ON",N)) Q:N'>0 D + . S G=YSDATA("ON",N,0) + . S R="" + . F I=1:1:$L(G,"|") D + .. S P=$P(G,"|",I) + .. D:P?1"RSCORE".1N.N RSCORE + .. D:P?1"SSCORE".1N.N SSCORE + .. D:P?1"ITEM".1N.E ITEM + .. D:P?1"EXECUTE".E MC + .. S R=R_P + . S YSDATA("ON",N,0)=R + Q +RSCORE ; raw scores + S YSJ=$E(P,7,99),P=$P(YSDATA(YSJ+5),U,3) + Q +SSCORE ;scaled score + S YSJ=$E(P,7,99),P=$P(YSDATA(YSJ+5),U,4) + Q +ITEM ;items resolution + S YSIN=$E(P,5,999) + S YSSET=$P(YSIN,";",2) + S YSIN=$P(YSIN,";",1) + S YSINN=$S(YSIN>400:5,YSIN>200:4,1:3) + S YSINE=$S(YSIN#200=0:200,1:YSIN) + S P=$P(YSDATA(YSINN),U,2) + S P=$E(P,YSINE) + Q:YSSET="" + F YSJJ=1:1:$L(YSSET,",") D + . S YSGG=$P(YSSET,",",YSJJ),YSGG1=$P(YSGG,":"),YSGG2=$P(YSGG,":",2) + . S:P=YSGG1 P=YSGG2 + Q +MC ;mumps executable setting P + S YSMC=$P(P,";",2) + X YSMC + Q +GAFURL(YSDATA) ;returns MH GAF horizontal sheet + S YSDATA(1)="[DATA]" + S YSDATA(2)="http://vaww.mentalhealth.med.va.gov/gafsheet.htm" + Q +PRIVL(YSDATA,YS) ;check privileges + N YSCODE,YSET + S YSCODE=$G(YS("CODE"),-1) + I '$D(^YTT(601,"B",YSCODE)) S YSDATA(1)="[ERROR]",YSDATA(2)="BAD TEST CODE" Q ;--> out + S YSET=$O(^YTT(601,"B",YSCODE,0)) + S YSDATA(1)="[DATA]" + I $D(^XUSEC("YSP",DUZ)) S YSDATA(2)="1^user privileged for all tests" Q ;has key + I $P(^YTT(601,YSET,0),U,10)="Y"!(YSCODE="GAF")!(YSCODE="ASI") S YSDATA(2)="1^exempt test" Q ;test exempt + I $P(^YTT(601,YSET,0),U,9)="I" S YSDATA(2)="1^interview" Q ;interview + S YSDATA(2)="0^no access" + Q diff --git a/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTAUIRR.m b/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTAUIRR.m index 24995802..5ee032b9 100644 --- a/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTAUIRR.m +++ b/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTAUIRR.m @@ -1,77 +1,70 @@ -YTAUIRR ;ALB/ASF- AUI-R REPORT ;11/15/90 16:58 ; 4/6/07 4:12pm - ;;5.01;MENTAL HEALTH;**37,85**;Dec 30, 1994;Build 49 -F0 ; - S R="",J=1 -T0 ; - S L=200,M=0,YSKK=1,YSTL=0 G:'$D(^YTT(601,YSTEST,"S",J,"K",YSKK,0)) STND D RD -T1 ; - I '$D(^YTT(601,YSTEST,"S",J,"K",YSKK,0)) S R=R_YSTL_"^",J=J+1 G T0 - S Y=^YTT(601,YSTEST,"S",J,"K",YSKK,0),P=1 -T2 ; - S YSIT=$P(Y,U,P) I YSIT="" S YSKK=YSKK+1 G T1 - S A=$P(Y,U,P+1),A=$A(A)-64,P=P+2 -T3 ; - I +YSIT>L S L=L+200,M=M+200 D RD G T3 - S:$E(X,+YSIT-M)=A YSTL=YSTL+$P(YSIT,"(",2) G T2 -RD ; - S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,L\200) Q -STND ; - S J=1,S="" -LK ; - S A=$P(R,U,J) G:A="" REPT S L1=$P(^YTT(601,YSTEST,"S",J,"M"),U) I A out ASF 09/15/04 - S X1="",$P(X1,"# ",60)="" - S X=$P(^YTT(601,YSTEST,"P"),U),A=$P(^("P"),U,2),B=$P(^("P"),U,3),L1=58-A\2,L2=L1+A+4 S:A<9 A=9 - D DTA W !!?(72-$L(X)\2),X,!!!?4,"S C A L E",?22,"RAW DECILE RANK" - F J=1:1 S YSRS=$P(R,U,J) Q:YSRS="" D:IOST?1"C-".E&($Y>21) SCR D H1:J=1,H5:J=5,H8:J=8,H13:J=13,H18:J=18,H24:J=24 W !?4,$P(^YTT(601,YSTEST,"S",J,0),U,2),?20,$J(YSRS,4,0),$J($P(S,U,J),5)," |",$E(X1,1,2*$P(S,U,J)) - Q -IR ; - S P0=$S(IOST?1"P".E:1,1:0),K=0,YSLFT=0 F I=1:1 Q:'$D(^YTD(601.2,YSDFN,1,YSET,1,YSED,I)) S K=K+$L(^(I)) - S K=K\10+$Y D DTA S X=$P(^YTT(601,YSTEST,"P"),U) W !!?(72-$L(X)/2),X - W !!!?25,"--- ITEM RESPONSES ---",!! S L=200,M=0,YSIT=1 I $D(^YTD(601.2,YSDFN,1,YSTEST,1,YSHD,99)),^(99)="MMPIR" S L=800 -R2 ; - D RD S A=$L(X),B=A\10 I B S K=10 F I=1:1:B D RLN Q:YSLFT - G:YSLFT DONE - S K=-10*B+A I K D RLN G DONE - G:A<200 DONE S L=L+200,M=M+200 I $D(^YTD(601.2,YSDFN,1,YSET,1,YSED,L\200)) G R2 -DONE ; - K YSTY,X,Y,A,B,K,YSKK,L,L1,L2,M,J,YSIT,YSRS,I,P,YSMX,YSTL,YSTTL Q -RLN ; - W ?1 F YSKK=1:1:K W $J(YSIT,3,0)," ",$E(X,YSIT-M)," " S YSIT=YSIT+1 - D:'P0&($Y>21) SCR:IL S L=L+200,M=M+200 D RD G T3 + S:$E(X,+YSIT-M)=A YSTL=YSTL+$P(YSIT,"(",2) G T2 +RD ; + S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,L\200) Q +STND ; + S J=1,S="" +LK ; + S A=$P(R,U,J) G:A="" REPT S L1=$P(^YTT(601,YSTEST,"S",J,"M"),U) I A21) SCR D H1:J=1,H5:J=5,H8:J=8,H13:J=13,H18:J=18,H24:J=24 W !?4,$P(^YTT(601,YSTEST,"S",J,0),U,2),?20,$J(YSRS,4,0),$J($P(S,U,J),5)," |",$E(X1,1,2*$P(S,U,J)) + Q +IR ; + S P0=$S(IOST?1"P".E:1,1:0),K=0,YSLFT=0 F I=1:1 Q:'$D(^YTD(601.2,YSDFN,1,YSET,1,YSED,I)) S K=K+$L(^(I)) + S K=K\10+$Y D DTA S X=$P(^YTT(601,YSTEST,"P"),U) W !!?(72-$L(X)/2),X + W !!!?25,"--- ITEM RESPONSES ---",!! S L=200,M=0,YSIT=1 I $D(^YTD(601.2,YSDFN,1,YSTEST,1,YSHD,99)),^(99)="MMPIR" S L=800 +R2 ; + D RD S A=$L(X),B=A\10 I B S K=10 F I=1:1:B D RLN Q:YSLFT + G:YSLFT DONE + S K=-10*B+A I K D RLN G DONE + G:A<200 DONE S L=L+200,M=M+200 I $D(^YTD(601.2,YSDFN,1,YSET,1,YSED,L\200)) G R2 +DONE ; + K YSTY,X,Y,A,B,K,YSKK,L,L1,L2,M,J,YSIT,YSRS,I,P,YSMX,YSTL,YSTTL Q +RLN ; + W ?1 F YSKK=1:1:K W $J(YSIT,3,0)," ",$E(X,YSIT-M)," " S YSIT=YSIT+1 + D:'P0&($Y>21) SCR:I2!($E(R,50)>2) S YSPA=1 - ;PART B DEPRESSIVE SYMPTOMS 4 WEEKS - I $E(R,49)>2 S YSCR=YSCR+1 - I $E(R,50)>2 S YSCR=YSCR+1 - I $E(R,51)>2!($E(R,52)>2) S YSCR=YSCR+1 - I $E(R,53)>2 S YSCR=YSCR+1 - I $E(R,54)>2 S YSCR=YSCR+1 - I $E(R,55)>2 S YSCR=YSCR+1 - I $E(R,56)>2 S YSCR=YSCR+1 - I $E(R,57)>2 S YSCR=YSCR+1 - I $E(R,58)>2!($E(R,59)="Y") S YSCR=YSCR+1 - I YSCR>4 S YSPB=1 - ;MISSING - S YSMISS=$L($E(R,49,59),"X")-1 - I ((YSCR<5)&((YSMISS+YSCR)>4))!(YSMISS>4) S YSPB="" - I YSPA,YSPB S YSDEP=1 - I YSPB="" S YSDEP="" - I $E(R,25)="Y" S YSNOT=1 - F I=49:1:59 S X=$E(R,I) S X=$S(X="Y":3,X="N":0,X?1N:X-1,1:0) S YSSEV=YSSEV+X - S YSSEV=YSSEV/(11-YSMISS)*33.33 - I YSMISS>1 S YSSEV="" -OUT81 ; - S I1="",$P(I1,"_",79)="" W !!,I1 - W !,"Scoring: By self report," - W:YSDEP'="" !,"The patient "_$S(YSDEP:"DOES",1:"DOES NOT")_" meet DSM IV Criterion A for Major Depressive Episode." - W:YSDEP="" !,"Diagnosis not available due to "_YTMISS_" missing items" - I YSNOT W !,"However a recent death is reported." - W !?15,"DOM severity score= " - W $S(YSSEV="":" not scoreable due to missing items",1:$J(YSSEV,3,0)) - W !,"There are no normative data for interpreting the severity score, but changes" - W !,"between this score and the score on the DOM Patient Follow-Up Assessment",!,"(Form 8.3) may reflect changes in the severity of the patient's symptoms." - W !,I1 - Q -EN82 ; - D ^YTDOMR1 - S (YSCR,YSDEP,YSPA,YSPB,YSSEV,YSNOT)=0 - S R=^YTD(601.2,YSDFN,1,YSTEST,1,YSED,1) - I $E(R,4)="Y"!($E(R,5)="Y") S YSPA=1 - F I=4:1:12 S:$E(R,I)="Y" YSCR=YSCR+1 - S:YSCR>4 YSPB=1 - I YSPA&YSPB S YSDEP=1 - F I=13,14,15,18,20,21,22 S:$E(R,I)="Y" YSNOT=1 - ; -OUT82 ; - S I1="",$P(I1,"_",79)="" W !!,I1 - W !,"Scoring:" - S X=$E(R,1) - W !,"Clinician reports: " - W $S(X=1:"MAJOR DEPRESSION (SINGLE EPISODE OR RECURRENT)",X=2:"Mood Disorder secondary to a general medical condition",X=3:"Posttraumatic Stress Disorder",X=4:"Substance use disorder(s)",X=5:"NO MAJOR DEPRESSION",1:"??") - W !,"The patient "_$S(YSDEP:"DOES",1:"DOES NOT")_" meet DSM IV criteria for major depression." - I YSNOT W !,"However exclusionary features are reported." - W !,I1 - Q -EN80 ; - D ^YTDOMR1 - S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1) - S X1=0 - S:$E(X,1)="Y" X1=1 - S:($E(X,2)="Y")&($E(X,3)="Y")&($E(X,4)>1) X1=1 - W:(X1=1) !!,"This screen is positive, and the possibility of a mood disorder",!,"should be evaluated further." - W:(X1=0) !!,"This screen for mood disorder is negative." - Q -ENG ;geriatric screen - S YSHDR=$E(YSHDR,1,43)_" "_YSSEX_" AGE "_$J(YSAGE,2,0) - W @IOF,YSHDR,?53,$$FMTE^XLFDT(DT,"5ZD"),?64,$$FMTE^XLFDT(YSHD,"5ZD") - W !,?53,"PRINTED",?64,"ENTERED",! - W !!,?3,"*** Geriatric Depression Screen ***",!! - W !,"The patient was questioned about mood in the past week.",! - W !,"Felt could not shake off blues: " S YSI=1 D ENGQ - W !,"Felt depressed: " S YSI=2 D ENGQ - W !,"Felt fearful: " S YSI=3 D ENGQ - W !,"Sleep was restless: " S YSI=4 D ENGQ - W !,"Felt hopeless about the future: " S YSI=5 D ENGQ - S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1) - S (YSMISS,YSDEP)=0 F I=1:1:4 S YSDEP=YSDEP+$E(X,I) S:$E(X,I)="X" YSMISS=YSMISS+1 ; ASF 10/20/06 - S:$E(X,5)?1N YSDEP=YSDEP+(3-$E(X,5)) S:$E(X,5)="X" YSMISS=YSMISS+1 - I YSMISS=1 S YSDEP=YSDEP+(YSDEP/4) - I YSMISS>1 W !!,"The validity of this test is compromised as "_YSMISS_" of the 5 questions",!,"were not answered." Q - W !!,"Score: "_YSDEP - W:(YSDEP>3.9) !,"This screen is positive, and the possibility of a mood disorder",!,"should be evaluated further." - W:(YSDEP<4) !,"This screen for mood disorder is negative." - Q -ENGQ ; - S Y1=$E(^YTD(601.2,YSDFN,1,YSET,1,YSED,1),YSI) - I YSI<5 W $S(Y1=0:"rarely",Y1=1:"some of the time",Y1=2:"much of the time",Y1=3:"most of the time",1:"question not answered") - I YSI=5 W $S(Y1=3:"rarely",Y1=2:"some of the time",Y1=1:"much of the time",Y1=0:"most of the time",1:"question not answered") +YTDOMR ;ALB/ASF-DEPRESSION OUTCOME MODULE REPORT ;2/23/99 15:09 + ;;5.01;MENTAL HEALTH;**31**;Dec 30, 1994 +EN81 ; + D ^YTDOMR1 + S (YSCR,YSDEP,YSPA,YSPB,YSSEV,YSNOT)=0 + S R=^YTD(601.2,YSDFN,1,YSTEST,1,YSED,1) + ;PART A SAD-NOFUN + I $E(R,49)>2!($E(R,50)>2) S YSPA=1 + ;PART B DEPRESSIVE SYMPTOMS 4 WEEKS + I $E(R,49)>2 S YSCR=YSCR+1 + I $E(R,50)>2 S YSCR=YSCR+1 + I $E(R,51)>2!($E(R,52)>2) S YSCR=YSCR+1 + I $E(R,53)>2 S YSCR=YSCR+1 + I $E(R,54)>2 S YSCR=YSCR+1 + I $E(R,55)>2 S YSCR=YSCR+1 + I $E(R,56)>2 S YSCR=YSCR+1 + I $E(R,57)>2 S YSCR=YSCR+1 + I $E(R,58)>2!($E(R,59)="Y") S YSCR=YSCR+1 + I YSCR>4 S YSPB=1 + ;MISSING + S YSMISS=$L($E(R,49,59),"X")-1 + I ((YSCR<5)&((YSMISS+YSCR)>4))!(YSMISS>4) S YSPB="" + I YSPA,YSPB S YSDEP=1 + I YSPB="" S YSDEP="" + I $E(R,25)="Y" S YSNOT=1 + F I=49:1:59 S X=$E(R,I) S X=$S(X="Y":3,X="N":0,X?1N:X-1,1:0) S YSSEV=YSSEV+X + S YSSEV=YSSEV/(11-YSMISS)*33.33 + I YSMISS>1 S YSSEV="" +OUT81 ; + S I1="",$P(I1,"_",79)="" W !!,I1 + W !,"Scoring: By self report," + W:YSDEP'="" !,"The patient "_$S(YSDEP:"DOES",1:"DOES NOT")_" meet DSM IV Criterion A for Major Depressive Episode." + W:YSDEP="" !,"Diagnosis not available due to "_YTMISS_" missing items" + I YSNOT W !,"However a recent death is reported." + W !?15,"DOM severity score= " + W $S(YSSEV="":" not scoreable due to missing items",1:$J(YSSEV,3,0)) + W !,"There are no normative data for interpreting the severity score, but changes" + W !,"between this score and the score on the DOM Patient Follow-Up Assessment",!,"(Form 8.3) may reflect changes in the severity of the patient's symptoms." + W !,I1 + Q +EN82 ; + D ^YTDOMR1 + S (YSCR,YSDEP,YSPA,YSPB,YSSEV,YSNOT)=0 + S R=^YTD(601.2,YSDFN,1,YSTEST,1,YSED,1) + I $E(R,4)="Y"!($E(R,5)="Y") S YSPA=1 + F I=4:1:12 S:$E(R,I)="Y" YSCR=YSCR+1 + S:YSCR>4 YSPB=1 + I YSPA&YSPB S YSDEP=1 + F I=13,14,15,18,20,21,22 S:$E(R,I)="Y" YSNOT=1 + ; +OUT82 ; + S I1="",$P(I1,"_",79)="" W !!,I1 + W !,"Scoring:" + S X=$E(R,1) + W !,"Clinician reports: " + W $S(X=1:"MAJOR DEPRESSION (SINGLE EPISODE OR RECURRENT)",X=2:"Mood Disorder secondary to a general medical condition",X=3:"Posttraumatic Stress Disorder",X=4:"Substance use disorder(s)",X=5:"NO MAJOR DEPRESSION",1:"??") + W !,"The patient "_$S(YSDEP:"DOES",1:"DOES NOT")_" meet DSM IV criteria for major depression." + I YSNOT W !,"However exclusionary features are reported." + W !,I1 + Q +EN80 ; + D ^YTDOMR1 + S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1) + S X1=0 + S:$E(X,1)="Y" X1=1 + S:($E(X,2)="Y")&($E(X,3)="Y")&($E(X,4)>1) X1=1 + W:(X1=1) !!,"This screen is positive, and the possibility of a mood disorder",!,"should be evaluated further." + W:(X1=0) !!,"This screen for mood disorder is negative." + Q +ENG ;geriatric screen + S YSHDR=$E(YSHDR,1,43)_" "_YSSEX_" AGE "_$J(YSAGE,2,0) + W @IOF,YSHDR,?53,$$FMTE^XLFDT(DT,"5ZD"),?64,$$FMTE^XLFDT(YSHD,"5ZD") + W !,?53,"PRINTED",?64,"ENTERED",! + W !!,?3,"*** Geriatric Depression Screen ***",!! + W !,"The patient was questioned about mood in the past week.",! + W !,"Felt could not shake off blues: " S YSI=1 D ENGQ + W !,"Felt depressed: " S YSI=2 D ENGQ + W !,"Felt fearful: " S YSI=3 D ENGQ + W !,"Sleep was restless: " S YSI=4 D ENGQ + W !,"Felt hopeful about the future: " S YSI=5 D ENGQ + S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1) + S (YSMISS,YSDEP)=0 F I=1:1:5 S YSDEP=YSDEP+$E(X,I) S:$E(X,I)="X" YSMISS=YSMISS+1 + I YSMISS=1 S YSDEP=YSDEP+(YSDEP/4) + I YSMISS>1 W !!,"The validity of this test is compromised as "_YSMISS_" of the 5 questions",!,"were not answered." Q + W !!,"Score: "_YSDEP + W:(YSDEP>3.9) !,"This screen is positive, and the possibility of a mood disorder",!,"should be evaluated further." + W:(YSDEP<4) !,"This screen for mood disorder is negative." + Q +ENGQ ; + S Y1=$E(^YTD(601.2,YSDFN,1,YSET,1,YSED,1),YSI) + I YSI<5 W $S(Y1=0:"rarely",Y1=1:"some of the time",Y1=2:"much of the time",Y1=3:"most of the time",1:"question not answered") + I YSI=5 W $S(Y1=3:"rarely",Y1=2:"some of the time",Y1=1:"much of the time",Y1=0:"most of the time",1:"question not answered") diff --git a/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTDOMR1.m b/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTDOMR1.m index ec6d19cc..76d7c983 100644 --- a/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTDOMR1.m +++ b/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTDOMR1.m @@ -1,94 +1,94 @@ -YTDOMR1 ;ALB/ASF SLC/DKG-EXTENDED INTERVIEW REPORTER ;6/19/97 17:09 - ;;5.01;MENTAL HEALTH;**31**;Dec 30, 1994 - ; -MAIN ; - K ^UTILITY($J,"W") - S YSLFN=1 ; S YSJ=1,U1=0,L=-200,YSLCK=200 - D R1 - D PRT - Q -R1 ; - F YSJ=1:1 Q:'$D(^YTT(601,YSTEST,"G",1,1,YSJ,0)) D R2 - Q -R2 ; - S A=^YTT(601,YSTEST,"G",1,1,YSJ,0),YSITEM=+$P(A,U),YSEXE=$P($P(A,U),";",2) - I YSITEM=0 S R="" X YSEXE D STEM Q - I YSEXE="L"!(YSEXE="'L") D LISTER Q - S L=(YSITEM-1)\200*200,U1=L+200,YSYX=^YTD(601.2,YSDFN,1,YSET,1,YSED,U1\200) - S R=$E(YSYX,YSITEM-L) Q:R=" "!(R="X") - S:"YN"[R R=R="N"+1 S R=$P(A,U,R+2) Q:R="" - D STEM - Q -STEM ; - S YSSTEM=$P(A,U,2) - I YSSTEM'["#" S YSYTX=YSSTEM_R D L Q - S A=$F(YSSTEM,"#") I A<3 S YSYTX=R_$E(YSSTEM,2,999) D L Q - S YSYTX=$E(YSSTEM,1,A-2)_R_$E(YSSTEM,A,999) D L - Q -END ; - K I,YSLCK,R,YSSTEM,YSYX,YSYCK,YSSCK Q -LISTER ;list formated output - K B1 S YSTL=0,YSTLN=1,YSCOMP=$S(YSEXE="'L":"N",1:"Y") - ; check at list begining - S YSQTYP=^YTT(601,YSTEST,"Q",YSITEM,1) I YSQTYP'=1 S R="eRROR LINE "_YSJ D STEM Q - S L=(YSITEM-1)\200*200,U1=L+200,YSYX=^YTD(601.2,YSDFN,1,YSET,1,YSED,U1\200) - S R=$E(YSYX,YSITEM-L) - S:R=YSCOMP YSTL=YSTL+1,B1(YSTL)=$P(A,U,3) - D LIST1 - I 'YSTL S R=$P(A,U,YSTLN+2) D STEM Q - I YSTL=1 S R=B1(1) D STEM Q - I YSTL=2 S R=B1(1)_" and "_B1(2) D STEM Q - S R="" F I=1:1:YSTL-1 S R=R_B1(I)_", " - S R=R_"and "_B1(YSTL) D STEM - Q -LIST1 S YSTLN=YSTLN+1,YSITEM=YSITEM+1 - Q:'$D(^YTT(601,YSTEST,"Q",YSITEM)) - S YSQTYP=^YTT(601,YSTEST,"Q",YSITEM,1) Q:YSQTYP'=2 - S L=(YSITEM-1)\200*200,U1=L+200,YSYX=^YTD(601.2,YSDFN,1,YSET,1,YSED,U1\200) - S R=$E(YSYX,YSITEM-L) - S:R=YSCOMP YSTL=YSTL+1,B1(YSTL)=$P(A,U,YSTLN+2) - G LIST1 -L ; - D:YSYTX["{" PRO ;evaluate pronouns etc - I $L(YSYTX)<80 S DIWL=0,DIWR=79,X=YSYTX D ^DIWP - I $L(YSYTX)>80 D - . S YSX1=YSYTX - . F I=$L(YSX1):-1:1 S Y1=$E(YSX1,I) I Y1=" "&(I<80) S X=$E(YSX1,1,I-1),YSX1=$E(YSX1,I+1,999),DIWL=0,DIWR=79 D ^DIWP Q - . I $L(YSX1),YSX1'=" " S DIWL=0,DIWR=79,X=YSX1 D ^DIWP - Q -PRT ; Print output - S YSZZ=0 - S YSHDR=$E(YSHDR,1,43)_" "_YSSEX_" AGE "_$J(YSAGE,2,0) - W @IOF,YSHDR,?53,$$FMTE^XLFDT(DT,"5ZD"),?64,$$FMTE^XLFDT(YSHD,"5ZD") - W !,?53,"PRINTED",?64,"ENTERED",! - S N=0 F S N=$O(^UTILITY($J,"W",0,N)) Q:N'>0!YSZZ D - . W !,^UTILITY($J,"W",0,N,0) - . D:$Y+4>IOSL WAIT - ; - Q -WAIT ; - F I0=1:1:IOSL-$Y-2 W ! - N DTOUT,DUOUT,DIRUT - I IOST?1"C".E W $C(7) S DIR(0)="E" D ^DIR K DIR S YSZZ=$D(DIRUT) - Q:YSZZ - W @IOF,YSHDR,?53,$$FMTE^XLFDT(DT,"5ZD"),?64,$$FMTE^XLFDT(YSHD,"5ZD") - W !?53,"PRINTED",?64,"ENTERED",! - Q -PRO ;evaluate pronoun, possesive etc - F I=1:1:$L(YSYTX,"{") D - . S P1=$F(YSYTX,"{")-1,P2=$F(YSYTX,"}") - . Q:'P1!'P2 - . S G=$E(YSYTX,P1+1,P2-2),G1=0 - . S:G="Pro" G1=$S(YSSEX="F":"She",1:"He") - . S:G="pro" G1=$S(YSSEX="F":"she",1:"he") - . S:G="Pos" G1=$S(YSSEX="F":"Her",1:"His") - . S:G="pos" G1=$S(YSSEX="F":"her",1:"his") - . S:G="Title" G1=$S(YSSEX="F":"Ms.",1:"Mr.") - . S:G="DATE" G1=$E(YSED,4,5)_"/"_$E(YSED,6,7)_"/"_$E(YSED,2,3) - . S:G="CLIN" G1=$P($G(^VA(200,$P(^YTD(601.2,YSDFN,1,YSET,1,YSED,0),U,3),20)),U,2) - . I G="Last" S X=$P($P(^DPT(YSDFN,0),U),",") D - .. F %=2:1:$L(X) I $E(X,%)?1U,$E(X,%-1)?1A S X=$E(X,0,%-1)_$C($A(X,%)+32)_$E(X,%+1,999) - .. S G1=X - . S YSYTX=$E(YSYTX,1,P1-1)_G1_$E(YSYTX,P2,999) - ; - Q +YTDOMR1 ;ALB/ASF SLC/DKG-EXTENDED INTERVIEW REPORTER ;6/19/97 17:09 + ;;5.01;MENTAL HEALTH;**31**;Dec 30, 1994 + ; +MAIN ; + K ^UTILITY($J,"W") + S YSLFN=1 ; S YSJ=1,U1=0,L=-200,YSLCK=200 + D R1 + D PRT + Q +R1 ; + F YSJ=1:1 Q:'$D(^YTT(601,YSTEST,"G",1,1,YSJ,0)) D R2 + Q +R2 ; + S A=^YTT(601,YSTEST,"G",1,1,YSJ,0),YSITEM=+$P(A,U),YSEXE=$P($P(A,U),";",2) + I YSITEM=0 S R="" X YSEXE D STEM Q + I YSEXE="L"!(YSEXE="'L") D LISTER Q + S L=(YSITEM-1)\200*200,U1=L+200,YSYX=^YTD(601.2,YSDFN,1,YSET,1,YSED,U1\200) + S R=$E(YSYX,YSITEM-L) Q:R=" "!(R="X") + S:"YN"[R R=R="N"+1 S R=$P(A,U,R+2) Q:R="" + D STEM + Q +STEM ; + S YSSTEM=$P(A,U,2) + I YSSTEM'["#" S YSYTX=YSSTEM_R D L Q + S A=$F(YSSTEM,"#") I A<3 S YSYTX=R_$E(YSSTEM,2,999) D L Q + S YSYTX=$E(YSSTEM,1,A-2)_R_$E(YSSTEM,A,999) D L + Q +END ; + K I,YSLCK,R,YSSTEM,YSYX,YSYCK,YSSCK Q +LISTER ;list formated output + K B1 S YSTL=0,YSTLN=1,YSCOMP=$S(YSEXE="'L":"N",1:"Y") + ; check at list begining + S YSQTYP=^YTT(601,YSTEST,"Q",YSITEM,1) I YSQTYP'=1 S R="eRROR LINE "_YSJ D STEM Q + S L=(YSITEM-1)\200*200,U1=L+200,YSYX=^YTD(601.2,YSDFN,1,YSET,1,YSED,U1\200) + S R=$E(YSYX,YSITEM-L) + S:R=YSCOMP YSTL=YSTL+1,B1(YSTL)=$P(A,U,3) + D LIST1 + I 'YSTL S R=$P(A,U,YSTLN+2) D STEM Q + I YSTL=1 S R=B1(1) D STEM Q + I YSTL=2 S R=B1(1)_" and "_B1(2) D STEM Q + S R="" F I=1:1:YSTL-1 S R=R_B1(I)_", " + S R=R_"and "_B1(YSTL) D STEM + Q +LIST1 S YSTLN=YSTLN+1,YSITEM=YSITEM+1 + Q:'$D(^YTT(601,YSTEST,"Q",YSITEM)) + S YSQTYP=^YTT(601,YSTEST,"Q",YSITEM,1) Q:YSQTYP'=2 + S L=(YSITEM-1)\200*200,U1=L+200,YSYX=^YTD(601.2,YSDFN,1,YSET,1,YSED,U1\200) + S R=$E(YSYX,YSITEM-L) + S:R=YSCOMP YSTL=YSTL+1,B1(YSTL)=$P(A,U,YSTLN+2) + G LIST1 +L ; + D:YSYTX["{" PRO ;evaluate pronouns etc + I $L(YSYTX)<80 S DIWL=0,DIWR=79,X=YSYTX D ^DIWP + I $L(YSYTX)>80 D + . S YSX1=YSYTX + . F I=$L(YSX1):-1:1 S Y1=$E(YSX1,I) I Y1=" "&(I<80) S X=$E(YSX1,1,I-1),YSX1=$E(YSX1,I+1,999),DIWL=0,DIWR=79 D ^DIWP Q + . I $L(YSX1),YSX1'=" " S DIWL=0,DIWR=79,X=YSX1 D ^DIWP + Q +PRT ; Print output + S YSZZ=0 + S YSHDR=$E(YSHDR,1,43)_" "_YSSEX_" AGE "_$J(YSAGE,2,0) + W @IOF,YSHDR,?53,$$FMTE^XLFDT(DT,"5ZD"),?64,$$FMTE^XLFDT(YSHD,"5ZD") + W !,?53,"PRINTED",?64,"ENTERED",! + S N=0 F S N=$O(^UTILITY($J,"W",0,N)) Q:N'>0!YSZZ D + . W !,^UTILITY($J,"W",0,N,0) + . D:$Y+4>IOSL WAIT + ; + Q +WAIT ; + F I0=1:1:IOSL-$Y-2 W ! + N DTOUT,DUOUT,DIRUT + I IOST?1"C".E W $C(7) S DIR(0)="E" D ^DIR K DIR S YSZZ=$D(DIRUT) + Q:YSZZ + W @IOF,YSHDR,?53,$$FMTE^XLFDT(DT,"5ZD"),?64,$$FMTE^XLFDT(YSHD,"5ZD") + W !?53,"PRINTED",?64,"ENTERED",! + Q +PRO ;evaluate pronoun, possesive etc + F I=1:1:$L(YSYTX,"{") D + . S P1=$F(YSYTX,"{")-1,P2=$F(YSYTX,"}") + . Q:'P1!'P2 + . S G=$E(YSYTX,P1+1,P2-2),G1=0 + . S:G="Pro" G1=$S(YSSEX="F":"She",1:"He") + . S:G="pro" G1=$S(YSSEX="F":"she",1:"he") + . S:G="Pos" G1=$S(YSSEX="F":"Her",1:"His") + . S:G="pos" G1=$S(YSSEX="F":"her",1:"his") + . S:G="Title" G1=$S(YSSEX="F":"Ms.",1:"Mr.") + . S:G="DATE" G1=$E(YSED,4,5)_"/"_$E(YSED,6,7)_"/"_$E(YSED,2,3) + . S:G="CLIN" G1=$P($G(^VA(200,$P(^YTD(601.2,YSDFN,1,YSET,1,YSED,0),U,3),20)),U,2) + . I G="Last" S X=$P($P(^DPT(YSDFN,0),U),",") D + .. F %=2:1:$L(X) I $E(X,%)?1U,$E(X,%-1)?1A S X=$E(X,0,%-1)_$C($A(X,%)+32)_$E(X,%+1,999) + .. S G1=X + . S YSYTX=$E(YSYTX,1,P1-1)_G1_$E(YSYTX,P2,999) + ; + Q diff --git a/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTKIL.m b/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTKIL.m index da8d62cd..c6cb06c9 100644 --- a/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTKIL.m +++ b/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTKIL.m @@ -1,43 +1,39 @@ -YTKIL ;SLC/TGA-KILL TEST/INTERVIEW DATA ;4/21/92 08:50 ; 10/31/07 12:41pm - ;;5.01;MENTAL HEALTH;**37,85**;Dec 30, 1994;Build 49 - ; - ; Called from the top by MENU option YSMKIL - ; - S YSO=0,YSNOKILL=1 W @IOF,!!,"Delete Patient Data" - W ! D ^YSLRP G:YSDFN<1 END - S DIR(0)="Y",DIR("A")="Delete MHA3 data",DIR("B")="No" D ^DIR - Q:$G(DIRUT) - IF Y D EN^YTQKIL Q ;-->out - I '$D(^YTD(601.2,YSDFN)),'$D(^YTD(601.4,YSDFN)) W !!,"NO DATA ON THIS PATIENT!" G END -R ; - R !!,"Delete All tests and interviews? N// ",A:DTIME S YSTOUT='$T,YSUOUT=A["^" G:YSTOUT!YSUOUT END S A=$TR($E(A_"N"),"yn","YN") I "YN"'[A W:A'["?" " ?",$C(7) G R - I "Y"[A S DIK="^YTD(601.2,",DA=YSDFN D ^DIK S DIK="^YTD(601.4,",DA=YSDFN D ^DIK W !!,"DELETED!" G END - S T(0)=0 G:'$O(^YTD(601.4,YSDFN,1,0)) C W !!,"Incomplete tests and Interviews",! S YTC=$O(^YTT(601,"B","CLERK",0)) - S T=0 - F S T=$O(^YTD(601.4,YSDFN,1,T)) G:'T C S T(0)=T(0)+1 G:YSTOUT!YSUOUT END S X=^(T,0),P=$P(X,U),D=$P(X,U,2),DA=P S:P=YTC P=$P(X,U,6),DA=YTC W !!,$$TN(+YSDFN,+T,+P),?10,$$FMTE^XLFDT(D,"5ZD") D DI -DI ; - R " ...Delete? N// ",K:DTIME S YSTOUT='$T,YSUOUT=K["^",K=$E(K) Q:"Nn"[K I YSTOUT!YSUOUT Q - I "Yy"'[K W:K'["?" " ?",$C(7) G DI - S DIK="^YTD(601.4,YSDFN,1,",DA(1)=YSDFN D ^DIK W ?40,"DELETED!" Q -C ; - G:'$D(^YTD(601.2,YSDFN,1,0)) E W !!,"Completed Tests and Interviews" - S T=0 - F S T=$O(^YTD(601.2,YSDFN,1,T)) G:'T!YSUOUT END F D=0:0 S D=$O(^YTD(601.2,YSDFN,1,T,1,D)) Q:'D S T(0)=T(0)+1 Q:YSTOUT!YSUOUT Q:'$D(^YTT(601,T)) W !!,$P(^YTT(601,T,0),U),?10,$$FMTE^XLFDT(D,"5ZD") D DC -DC ; - R " ...Delete? N// ",K:DTIME S YSTOUT='$T,YSUOUT=K["^",K=$E(K) Q:"Nn"[K I YSTOUT!YSUOUT Q - I "Yy"'[K W:K'["?" " ?",$C(7) G DC - S DIK="^YTD(601.2,YSDFN,1,T,1,",DA=D,DA(1)=T,DA(2)=YSDFN D ^DIK W ?40,"DELETED" Q -E ; - W:'T(0) !!,"NO TESTS/INTERVIEWS FOUND!" -END ; - K %,A,D,DA,DIC,DIK,K,P,T,X,YSAGE,YSDFN,YSDOB,YSE,YSN,YSNM,YSNOKILL,YSO,YSS,YSSEX,YSSSN,YTC - QUIT - ; -TN(DFN,TN6014,TN601) ;Print test name... - ; TN6014 = IEN of ^YTD(601.4,+DFN,1,+TN6014... - ; TN601 = IEN of ^YTT(601,+TN601... - N TESTNAME,X - S X=$P($G(^YTT(601,+TN601,0)),U),TESTNAME=$S(X']"":"Unknown",1:X) - I $G(^YTD(601.4,+DFN,1,+TN6014,99))'="MMPIR" QUIT TESTNAME ;-> - QUIT $S(TN601=60:"MMPIR",TN601=61:"MMPR",1:"Unknown") ;-> - ; +YTKIL ;SLC/TGA-KILL TEST/INTERVIEW DATA ;4/21/92 08:50 ;03/11/94 12:49 + ;;5.01;MENTAL HEALTH;**37**;Dec 30, 1994 + ; + ; Called from the top by MENU option YSMKIL + ; + S YSO=0,YSNOKILL=1 W @IOF,!!,"Delete Patient Data" + W ! D ^YSLRP G:YSDFN<1 END I '$D(^YTD(601.2,YSDFN)),'$D(^YTD(601.4,YSDFN)) W !!,"NO DATA ON THIS PATIENT!" G END +R ; + R !!,"Delete All tests and interviews? N// ",A:DTIME S YSTOUT='$T,YSUOUT=A["^" G:YSTOUT!YSUOUT END S A=$TR($E(A_"N"),"yn","YN") I "YN"'[A W:A'["?" " ?",$C(7) G R + I "Y"[A S DIK="^YTD(601.2,",DA=YSDFN D ^DIK S DIK="^YTD(601.4,",DA=YSDFN D ^DIK W !!,"DELETED!" G END + S T(0)=0 G:'$O(^YTD(601.4,YSDFN,1,0)) C W !!,"Incomplete tests and Interviews",! S YTC=$O(^YTT(601,"B","CLERK",0)) + S T=0 + F S T=$O(^YTD(601.4,YSDFN,1,T)) G:'T C S T(0)=T(0)+1 G:YSTOUT!YSUOUT END S X=^(T,0),P=$P(X,U),D=$P(X,U,2),DA=P S:P=YTC P=$P(X,U,6),DA=YTC W !!,$$TN(+YSDFN,+T,+P),?10,$$FMTE^XLFDT(D,"5ZD") D DI +DI ; + R " ...Delete? N// ",K:DTIME S YSTOUT='$T,YSUOUT=K["^",K=$E(K) Q:"Nn"[K I YSTOUT!YSUOUT Q + I "Yy"'[K W:K'["?" " ?",$C(7) G DI + S DIK="^YTD(601.4,YSDFN,1,",DA(1)=YSDFN D ^DIK W ?40,"DELETED!" Q +C ; + G:'$D(^YTD(601.2,YSDFN,1,0)) E W !!,"Completed Tests and Interviews" + S T=0 + F S T=$O(^YTD(601.2,YSDFN,1,T)) G:'T!YSUOUT END F D=0:0 S D=$O(^YTD(601.2,YSDFN,1,T,1,D)) Q:'D S T(0)=T(0)+1 Q:YSTOUT!YSUOUT Q:'$D(^YTT(601,T)) W !!,$P(^YTT(601,T,0),U),?10,$$FMTE^XLFDT(D,"5ZD") D DC +DC ; + R " ...Delete? N// ",K:DTIME S YSTOUT='$T,YSUOUT=K["^",K=$E(K) Q:"Nn"[K I YSTOUT!YSUOUT Q + I "Yy"'[K W:K'["?" " ?",$C(7) G DC + S DIK="^YTD(601.2,YSDFN,1,T,1,",DA=D,DA(1)=T,DA(2)=YSDFN D ^DIK W ?40,"DELETED" Q +E ; + W:'T(0) !!,"NO TESTS/INTERVIEWS FOUND!" +END ; + K %,A,D,DA,DIC,DIK,K,P,T,X,YSAGE,YSDFN,YSDOB,YSE,YSN,YSNM,YSNOKILL,YSO,YSS,YSSEX,YSSSN,YTC + QUIT + ; +TN(DFN,TN6014,TN601) ;Print test name... + ; TN6014 = IEN of ^YTD(601.4,+DFN,1,+TN6014... + ; TN601 = IEN of ^YTT(601,+TN601... + N TESTNAME,X + S X=$P($G(^YTT(601,+TN601,0)),U),TESTNAME=$S(X']"":"Unknown",1:X) + I $G(^YTD(601.4,+DFN,1,+TN6014,99))'="MMPIR" QUIT TESTNAME ;-> + QUIT $S(TN601=60:"MMPIR",TN601=61:"MMPR",1:"Unknown") ;-> + ; diff --git a/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTMMPI2B.m b/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTMMPI2B.m index 6b8e444a..a151a33d 100644 --- a/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTMMPI2B.m +++ b/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTMMPI2B.m @@ -1,59 +1,75 @@ -YTMMPI2B ;ALB/ASF-MMPI2 HARRIS:LINGOS,CRIT,OS ;11/4/98 16:25 - ;;5.01;MENTAL HEALTH;**10,31**;Dec 30, 1994 -SCOR ; - S (R,S)="" F J=44:1:84 D T0^YTMMPI2A S P=YSSX D LK^YTMMPI2A - K A,YSTVL S YSSCALE=S,YSRAW=R - D HL,WAIT:IOST?1"C-".E Q:YSLFT - D SI Q:YSLFT - D OS,WAIT:IOST?1"C-".E Q:YSLFT - D NEWSC,WAIT:IOST?1"C".E Q:YSLFT - ;I $D(^YTT(601,YSTEST,"S",107)) D ^YTMMPI2D,WAIT:IOST?1"C-".E Q:YSLFT - D CRIT,WAIT:IOST?1"C-".E Q:YSLFT D:(X(0)["X")!(X(1)["X")!(X(2)["X") OMIT,WAIT:IOST?1"C-".E Q:YSLFT D NK^YTMMPI2P Q -HL ;HARRIS LINGOS - D DTA^YTREPT W !!!?25,"Harris-Lingoes Subscales",!?10,"(to be used as an aid in interpreting the parent scale)",!!?50,"Raw Score",?65,"T Score" - F J=44:1:71 S YSN=$P(^YTT(601,YSTEST,"S",J,0),U,2),R=$P(YSRAW,U,J-43),S=$P(YSSCALE,U,J-43) D:YSN?.E1"1".E HLPARNT W !?3,$E($P(YSN," ",2,9),1,36)," (",$P(YSN," "),")",?50,$J(R,4),?65,$J(S,4) D:$Y+4>IOSL&(IOST?1"C-".E) WAIT Q:YSLFT - Q -HLPARNT ; - W:J'=44 !! W !,$S(J=44:"Depression",J=49:"Hysteria",J=54:"Psychopathic Deviate",J=59:"Paranoia",J=62:"Schizophrenia",1:"Hypomania")," Subscales",! Q -WAIT ; - I IOST'?1"C-".E D DTA^YTREPT Q - ; %% ANOTHER READER CALL ???? LOOK YSLFT = YSTOUT %%% - W $C(7) R YSLFT:DTIME S YSTOUT='$T,YSUOUT=YSLFT["^" - S:YSLFT["^"!'$T YSLFT=1 Q:YSLFT S Z1=1 W # Q -SI ; - D DTA^YTREPT W !!!?25,"Social Introversion Subscales",!?18,"(Ben-Porath, Hostetler, Butcher, and Graham)",!!?50,"Raw Score",?65,"T Score" - F J=72:1:74 S YSN=$P(^YTT(601,YSTEST,"S",J,0),U,2),R=$P(YSRAW,U,J-43),S=$P(YSSCALE,U,J-43) W !?3,$E($P(YSN," ",2,9),1,36)," (",$P(YSN," "),")",?50,$J(R,4),?65,$J(S,4) D:$Y+4>IOSL WAIT Q:YSLFT - Q -OS ;OBVIOUS SUBTLE - W !!!!?25,"Wiener-Harmon Subtle-Obvious Subscales",!!?50,"Raw Score",?65,"T Score" - F J=75:1:84 S YSN=$P(^YTT(601,YSTEST,"S",J,0),U,2),R=$P(YSRAW,U,J-43),S=$P(YSSCALE,U,J-43) W !?3,$E($P(YSN," ",2,9),1,36)," (",$P(YSN," "),")",?50,$J(R,4),?65,$J(S,4) D:$Y+4>IOSL WAIT Q:YSLFT - S S=$P(YSSCALE,U,32,41) W !!?3,"Total T Score Difference (Obvious-Subtle): ",$P(S,U)+$P(S,U,3)+$P(S,U,5)+$P(S,U,7)+$P(S,U,9)-$P(S,U,2)-$P(S,U,4)-$P(S,U,6)-$P(S,U,8)-$P(S,U,10) - Q -NEWSC ;scales AAS,AAP,marital,fp S,hostility - Q:'$D(^YTT(601,YSTEST,"S",107)) - W !!?25,"Additional Supplementary Scales",! - S (R,S)="" F J=107:1:112 D T0^YTMMPI2A S P=YSSX D LK^YTMMPI2A - K A,YSTVL S YSSCALE=S,YSRAW=R - F J=107:1:112 S YSN=$P(^YTT(601,YSTEST,"S",J,0),U,2),R=$P(YSRAW,U,J-106),S=$P(YSSCALE,U,J-106) W !?3,$E($P(YSN," ",2,9),1,36)," (",$P(YSN," "),")",?50,$J(R,4),?65,$J(S,4) D:$Y+4>IOSL WAIT Q:YSLFT - W !!!!,"Uniform T scores are used for HS, D, Hy, Pd, Pa, Pt, Sc, Ma, and",!,"the Content Scales; all other MMPI-2 scales use linear T scores.",!! Q -CRIT ;CRITICAL ITEMS - D DTA^YTREPT W !?25,"Critical Items",!! S N=0 F I=1:1 S N=$O(^YTT(601,YSTEST,"G",1,1,N)) Q:'N W !,^(N,0) - S YSCNT=0 F J=85,88,86,89,87,90 D CRIT1 Q:YSLFT - Q:YSLFT W !!!,YSCNT," Koss-Butcher Critical Items were endorsed." - S YSCNT=0 F J=91:1:100,106 D CRIT1 Q:YSLFT - Q:YSLFT W !!!,YSCNT," Lachar-Wrobel Critical Items were endorsed." - Q -CRIT1 ; - S YSN=$P(^YTT(601,YSTEST,"S",J,0),U,2),YSKY=$S($D(^YTT(601,YSTEST,"S",J,YSSX_"K")):^(YSSX_"K"),1:^YTT(601,YSTEST,"S",J,"K",1,0)) - I $D(^YTT(601,YSTEST,"S",J,"K",2,0)) S YSKY=YSKY_^(0) - S X(0)=^YTD(601.2,YSDFN,1,YSTEST,1,YSED,1),X(1)=^(2),X(2)=^(3) D:$Y+4>IOSL WAIT Q:YSLFT W !!!,YSN,! - F I=1:2 S YSIT=$P(YSKY,U,I) Q:YSIT'?1N.N S B=$P(YSKY,U,I+1) I $E(X(YSIT\200),YSIT#200)=B S YSCNT=YSCNT+1 D L,WAIT:$Y+4>IOSL - Q -L W !,$J(YSIT,5),". " F K=1:1 Q:'$D(^YTT(601,YSTEST,"Q",YSIT,"T",K)) W:K'=1 !?7 W ^YTT(601,YSTEST,"Q",YSIT,"T",K,0) - W:B'="X" " (",B,")" Q -OMIT ;OMITTED ITEMS - D DTA^YTREPT W !!!?25,"OMITTED ITEMS",!!!,"The following items were omitted by the client. It may be helpful to",!,"discuss these items with this individual to determine the reason",!,"for non-compliance with test instructions.",!!! - S B="X" F I=0,1,2 I X(I)["X" F J=1:1:$L(X(I)) I $E(X(I),J)="X" S YSIT=J+(200*I) D L - D WAIT Q -VV ; - S N=0 F S N=$O(^YTT(601,202,"S",N)) Q:'N S G=^(N,0) W !,N,?5,$P(G,U),?10,$P(G,U,2) +YTMMPI2B ;ALB/ASF-MMPI2 HARRIS:LINGOS,CRIT,OS ;6/19/03 14:43 + ;;5.01;MENTAL HEALTH;**10,31,76,70**;Dec 30, 1994 +SCOR ; + S (R,S)="" F J=44:1:84 D T0^YTMMPI2A S P=YSSX D LK^YTMMPI2A + K A,YSTVL S YSSCALE=S,YSRAW=R + D HL,WAIT:IOST?1"C-".E Q:YSLFT + D SI Q:YSLFT + ;D OS,WAIT:IOST?1"C-".E Q:YSLFT + D NEWSC,WAIT:(IOST?1"C".E)&($Y+4>IOSL) Q:YSLFT + D PSY5,WAIT:(IOST?1"C".E)&($Y+4>IOSL) Q:YSLFT + D RCCLIN,WAIT:IOST?1"C".E Q:YSLFT + ;I $D(^YTT(601,YSTEST,"S",107)) D ^YTMMPI2D,WAIT:IOST?1"C-".E Q:YSLFT + D CRIT,WAIT:IOST?1"C-".E Q:YSLFT D:(X(0)["X")!(X(1)["X")!(X(2)["X") OMIT,WAIT:IOST?1"C-".E Q:YSLFT D NK^YTMMPI2P Q +HL ;HARRIS LINGOS + D DTA^YTREPT W !!!?25,"Harris-Lingoes Subscales",!?10,"(to be used as an aid in interpreting the parent scale)",!!?50,"Raw Score",?65,"T Score" + F J=44:1:71 S YSN=$P(^YTT(601,YSTEST,"S",J,0),U,2),R=$P(YSRAW,U,J-43),S=$P(YSSCALE,U,J-43) D:YSN?.E1"1".E HLPARNT W !?3,$E($P(YSN," ",2,9),1,36)," (",$P(YSN," "),")",?50,$J(R,4),?65,$J(S,4) D:$Y+4>IOSL&(IOST?1"C-".E) WAIT Q:YSLFT + Q +HLPARNT ; + W:J'=44 !! W !,$S(J=44:"Depression",J=49:"Hysteria",J=54:"Psychopathic Deviate",J=59:"Paranoia",J=62:"Schizophrenia",1:"Hypomania")," Subscales",! Q +WAIT ; + I IOST'?1"C-".E D DTA^YTREPT Q + ; %% ANOTHER READER CALL ???? LOOK YSLFT = YSTOUT %%% + W $C(7) R YSLFT:DTIME S YSTOUT='$T,YSUOUT=YSLFT["^" + S:YSLFT["^"!'$T YSLFT=1 Q:YSLFT S Z1=1 W # Q +SI ; + D DTA^YTREPT W !!!?25,"Social Introversion Subscales",!?18,"(Ben-Porath, Hostetler, Butcher, and Graham)",!!?50,"Raw Score",?65,"T Score" + F J=72:1:74 S YSN=$P(^YTT(601,YSTEST,"S",J,0),U,2),R=$P(YSRAW,U,J-43),S=$P(YSSCALE,U,J-43) W !?3,$E($P(YSN," ",2,9),1,36)," (",$P(YSN," "),")",?50,$J(R,4),?65,$J(S,4) D:$Y+4>IOSL WAIT Q:YSLFT + Q +OS ;OBVIOUS SUBTLE + W !!!!?25,"Wiener-Harmon Subtle-Obvious Subscales",!!?50,"Raw Score",?65,"T Score" + F J=75:1:84 S YSN=$P(^YTT(601,YSTEST,"S",J,0),U,2),R=$P(YSRAW,U,J-43),S=$P(YSSCALE,U,J-43) W !?3,$E($P(YSN," ",2,9),1,36)," (",$P(YSN," "),")",?50,$J(R,4),?65,$J(S,4) D:$Y+4>IOSL WAIT Q:YSLFT + S S=$P(YSSCALE,U,32,41) W !!?3,"Total T Score Difference (Obvious-Subtle): ",$P(S,U)+$P(S,U,3)+$P(S,U,5)+$P(S,U,7)+$P(S,U,9)-$P(S,U,2)-$P(S,U,4)-$P(S,U,6)-$P(S,U,8)-$P(S,U,10) + Q +NEWSC ;scales AAS,AAP,marital,fp S,hostility + Q:'$D(^YTT(601,YSTEST,"S",107)) + W !!?25,"Additional Supplementary Scales",! + S (R,S)="" F J=107:1:112 D T0^YTMMPI2A S P=YSSX D LK^YTMMPI2A + K A,YSTVL S YSSCALE=S,YSRAW=R + F J=107:1:112 S YSN=$P(^YTT(601,YSTEST,"S",J,0),U,2),R=$P(YSRAW,U,J-106),S=$P(YSSCALE,U,J-106) W !?3,$E($P(YSN," ",2,9),1,36)," (",$P(YSN," "),")",?50,$J(R,4),?65,$J(S,4) D:$Y+4>IOSL WAIT Q:YSLFT + W !!,"Uniform T scores are used for HS, D, Hy, Pd, Pa, Pt, Sc, Ma, and",!,"the Content Scales; all other MMPI-2 scales use linear T scores.",! Q +PSY5 ; ADDED 8/30/02 ASF + Q:'$D(^YTT(601,YSTEST,"S",114)) + W !?25,"PSY-5 Personality Psychopathology Five",!?50,"Raw Score",?65,"T Score" + S (R,S)="" F J=114:1:118 D T0^YTMMPI2A S P=YSSX D LK^YTMMPI2A + K A,YSTVL S YSSCALE=S,YSRAW=R + F J=114:1:118 S YSN=$P(^YTT(601,YSTEST,"S",J,0),U,2),R=$P(YSRAW,U,J-113),S=$P(YSSCALE,U,J-113) W !?3,YSN,?50,$J(R,4),?65,$J(S,4) D:$Y+4>IOSL WAIT Q:YSLFT + Q +RCCLIN ;restructured clinical + Q:$G(^YTT(601,YSTEST,"S",119,0))'?.E1"RC".E + W !!?25,"RC Restructured Clinical Scales",!?50,"Raw Score",?65,"T Score" + S (R,S)="" F J=119:1:127 D T0^YTMMPI2A S P=YSSX D LK^YTMMPI2A + K A,YSTVL S YSSCALE=S,YSRAW=R + F J=119:1:127 S YSN=$P(^YTT(601,YSTEST,"S",J,0),U,2),R=$P(YSRAW,U,J-118),S=$P(YSSCALE,U,J-118) W !?3,YSN,?50,$J(R,4),?65,$J(S,4) D:$Y+4>IOSL WAIT Q:YSLFT + Q +CRIT ;CRITICAL ITEMS + D DTA^YTREPT W !?25,"Critical Items",!! S N=0 F I=1:1 S N=$O(^YTT(601,YSTEST,"G",1,1,N)) Q:'N W !,^(N,0) + S YSCNT=0 F J=85,88,86,89,87,90 D CRIT1 Q:YSLFT + Q:YSLFT W !!!,YSCNT," Koss-Butcher Critical Items were endorsed." + S YSCNT=0 F J=91:1:100,106 D CRIT1 Q:YSLFT + Q:YSLFT W !!!,YSCNT," Lachar-Wrobel Critical Items were endorsed." + Q +CRIT1 ; + S YSN=$P(^YTT(601,YSTEST,"S",J,0),U,2),YSKY=$S($D(^YTT(601,YSTEST,"S",J,YSSX_"K")):^(YSSX_"K"),1:^YTT(601,YSTEST,"S",J,"K",1,0)) + I $D(^YTT(601,YSTEST,"S",J,"K",2,0)) S YSKY=YSKY_^(0) + S X(0)=^YTD(601.2,YSDFN,1,YSTEST,1,YSED,1),X(1)=^(2),X(2)=^(3) D:$Y+4>IOSL WAIT Q:YSLFT W !!!,YSN,! + F I=1:2 S YSIT=$P(YSKY,U,I) Q:YSIT'?1N.N S B=$P(YSKY,U,I+1) I $E(X(YSIT\200),YSIT#200)=B S YSCNT=YSCNT+1 D L,WAIT:$Y+4>IOSL + Q +L W !,$J(YSIT,5),". " F K=1:1 Q:'$D(^YTT(601,YSTEST,"Q",YSIT,"T",K)) W:K'=1 !?7 W ^YTT(601,YSTEST,"Q",YSIT,"T",K,0) + W:B'="X" " (",B,")" Q +OMIT ;OMITTED ITEMS + D DTA^YTREPT W !!!?25,"OMITTED ITEMS",!!!,"The following items were omitted by the client. It may be helpful to",!,"discuss these items with this individual to determine the reason",!,"for non-compliance with test instructions.",!!! + S B="X" F I=0,1,2 I X(I)["X" F J=1:1:$L(X(I)) I $E(X(I),J)="X" S YSIT=J+(200*I) D L + D WAIT Q +VV ; + S N=0 F S N=$O(^YTT(601,202,"S",N)) Q:'N S G=^(N,0) W !,N,?5,$P(G,U),?10,$P(G,U,2) diff --git a/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTPCL.m b/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTPCL.m index 4e4161f7..db6f68c5 100644 --- a/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTPCL.m +++ b/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTPCL.m @@ -1,38 +1,32 @@ -YTPCL ;ALB/ASF TEST-PTST CHECKLISTS ; 4/5/07 10:05am - ;;5.01;MENTAL HEALTH;**66,85**;Dec 30, 1994;Build 49 - ; - ;Reference to ^DIR supported by IA #10026 - ; -SCOR ; - S YSTY="W*",YSNOITEM="DONE^YTPCL" - D ^YTREPT - S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1) - S (B,C,D)=0 - F I=1:1:5 S Y=$E(X,I) S:(Y=3)!(Y=4)!(Y=5) B=B+1 - F I=6:1:12 S Y=$E(X,I) S:(Y=3)!(Y=4)!(Y=5) C=C+1 - F I=13:1:17 S Y=$E(X,I) S:(Y=3)!(Y=4)!(Y=5) D=D+1 -ZZ W !!,"DSM-IV PTSD Criteria B ",$S(B>0:"IS met",1:"is NOT met") - W !,"DSM-IV PTSD Criteria C ",$S(C>2:"IS met",1:"is NOT met") - W !,"DSM-IV PTSD Criteria D ",$S(D>1:"IS met",1:"is NOT met") - I (B>0)&(C>2)&(D>1) W !!,"*** PTSD Diagnosis IS SUGGESTED ***" - W !! - I IOST?1"C".E W ! S DIR(0)="E" D ^DIR Q:Y'=1 - W !!!,"Items" - F I=1:1:17 D - . W !,I,". ",^YTT(601,YSET,"Q",I,"T",1,0) - . I $D(^YTT(601,YSET,"Q",I,"T",2,0)) W:^(0)'=" " !?7,^(0) - . I I=5 W !?7,^YTT(601,YSET,"Q",I,"T",3,0) - . W " :",$E(^YTD(601.2,YSDFN,1,YSET,1,YSED,1),I) - W !!,"1= Not at all 2= A little bit 3= Moderately 4= Quite a bit 5= Extremely" - Q -SPTSD ;SCREENING REPORT - D DTA^YTREPT - W !!,?7,"Post Traumatic Stress Disorder Screen",!! - S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1) - W !,"Patient Reports "_$S($E(X,1)="Y":"HAVING",1:"NO")_" traumatic experiences.",! - W:$E(X,2)="Y" !,"In the past month, the patient has been bothered by repeated, disturbing",!,"memories, thoughts, or images of one or more of the stressful events." - W:$E(X,3)="Y" !,"In the past month, has felt distant or cut off from other people." - W:$E(X,4)="Y" !,"Has been 'super alert' or watchful or on guard in the past month." - W:$E(X,2,9)?.E1"Y".E !!,"Please refer to a mental health professional for further evaluation",!,"and treatment of probable PTSD" - I IOST?1"C".E W ! S DIR(0)="E" D ^DIR Q:Y'=1 -DONE QUIT +YTPCL ;ALB/ASF TEST-PTST CHECKLISTS ;7/19/00 11:11 + ;;5.01;MENTAL HEALTH;**66**;Dec 30, 1994 + ; + ;Reference to ^DIR supported by IA #10026 + ; +SCOR ; + S YSTY="W*",YSNOITEM="DONE^YTPCL" + D ^YTREPT + S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1) + S (B,C,D)=0 + F I=1:1:5 S Y=$E(X,I) S:(Y=3)!(Y=4)!(Y=5) B=B+1 + F I=6:1:12 S Y=$E(X,I) S:(Y=3)!(Y=4)!(Y=5) C=C+1 + F I=13:1:17 S Y=$E(X,I) S:(Y=3)!(Y=4)!(Y=5) D=D+1 +ZZ W !!,"DSM-IV PTSD Criteria B ",$S(B>0:"IS met",1:"is NOT met") + W !,"DSM-IV PTSD Criteria C ",$S(C>2:"IS met",1:"is NOT met") + W !,"DSM-IV PTSD Criteria D ",$S(D>1:"IS met",1:"is NOT met") + I (B>0)&(C>2)&(D>1) W !!,"*** PTSD Diagnosis IS SUGGESTED ***" + W !! + I IOST?1"C".E W ! S DIR(0)="E" D ^DIR Q:Y'=1 + D IR^YTREPT + Q +SPTSD ;SCREENING REPORT + D DTA^YTREPT + W !!,?7,"Post Traumatic Stress Disorder Screen",!! + S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1) + W !,"Patient Reports "_$S($E(X,1)="Y":"HAVING",1:"NO")_" traumatic experiences.",! + W:$E(X,2)="Y" !,"In the past month, the patient has been bothered by repeated, disturbing",!,"memories, thoughts, or images of one or more of the stressful events." + W:$E(X,3)="Y" !,"In the past month, has felt distant or cut off from other people." + W:$E(X,4)="Y" !,"Has been 'super alert' or watchful or on guard in the past month." + W:$E(X,2,9)?.E1"Y".E !!,"Please refer to a mental health professional for further evaluation",!,"and treatment of probable PTSD" + I IOST?1"C".E W ! S DIR(0)="E" D ^DIR Q:Y'=1 +DONE QUIT diff --git a/r/MY_HEALTHEVET-MHV/MHV7B0.m b/r/MY_HEALTHEVET-MHV/MHV7B0.m index 87bb564b..361140c0 100644 --- a/r/MY_HEALTHEVET-MHV/MHV7B0.m +++ b/r/MY_HEALTHEVET-MHV/MHV7B0.m @@ -1,57 +1,54 @@ -MHV7B0 ;WAS/GPM - HL7 MESSAGE BUILDER FOR MFN^Z01 ; 1/21/08 5:18pm - ;;1.0;My HealtheVet;**2**;Aug 23, 2005;Build 22 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -MFNZ01(MSGROOT,ADM,ERR,DATAROOT,LEN,HL) ;Build MFN^Z01 - ; - ; Input: - ; MSGROOT - (required) Global root of message - ; ADM - (required) Array of administrative data - ; ERR - (Not used) For compatibility with MHV7T - ; DATAROOT - (Not used) For compatibility with MHV7T - ; HL - (required) Array of HL package variables - ; - ; Output: - ; MFN^Z01 message in MSGROOT - ; MSH,MFI,MFE,ZHV - ; LEN - Length of formatted message - ; - N CNT - D LOG^MHVUL2("MFN-Z01 BUILDER","BEGIN","S","TRACE") - K @MSGROOT - S CNT=1,@MSGROOT@(CNT)=$$MFI(.HL),LEN=$L(@MSGROOT@(CNT)) - S CNT=CNT+1,@MSGROOT@(CNT)=$$MFE(.ADM,.HL),LEN=LEN+$L(@MSGROOT@(CNT)) - S CNT=CNT+1,@MSGROOT@(CNT)=$$ZHV(.ADM,.HL),LEN=LEN+$L(@MSGROOT@(CNT)) - D LOG^MHVUL2("MFN-Z01 BUILDER","END","S","TRACE") - Q - ; -MFI(HL) ;build MFI segment - N MFI - S MFI(0)="MFI" - S MFI(1,1,1)="MHV" - S MFI(3)="UPD" - S MFI(6)="NE" - Q $$BLDSEG^MHV7U(.MFI,.HL) - ; -MFE(ADM,HL) ;build MFE segment - N MFE - S MFE(0)="MFE" - S MFE(1)="MUP" - S MFE(4)=$G(ADM("SITE NUMBER")) - S MFE(5)="CE" - Q $$BLDSEG^MHV7U(.MFE,.HL) - ; -ZHV(ADM,HL) ;build ZHV segment - N ZHV - S ZHV(0)="ZHV" - S ZHV(1,1,1)=$G(ADM("SITE NUMBER")) - S ZHV(1,1,2)=$$ESCAPE^MHV7U($G(ADM("SITE NAME")),.HL) - S ZHV(2)=$G(ADM("DOMAIN")) - S ZHV(3)=$G(ADM("IP ADDRESS")) - S ZHV(4)=$G(ADM("HL7 LISTENER PORT")) - S ZHV(5)=$G(ADM("RPC BROKER PORT")) - S ZHV(6,1,1)=$G(ADM("VERSION")) - S ZHV(7)=$$ESCAPE^MHV7U($G(ADM("PATCH NUMBER")),.HL) - S ZHV(8)=$G(ADM("SYSTEM TYPE")) - Q $$BLDSEG^MHV7U(.ZHV,.HL) - ; +MHV7B0 ;WAS/GPM - HL7 MESSAGE BUILDER FOR MFN^Z01 ; [8/22/05 6:21pm] + ;;1.0;My HealtheVet;;Aug 23, 2005 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; +MFNZ01(MSGROOT,ADM,ERR,DATAROOT,HL) ;Build MFN^Z01 + ; + ; Input: + ; MSGROOT - (required) Global root of message + ; ADM - (required) Array of administrative data + ; ERR - (Not used) For compatibility with MHV7T + ; DATAROOT - (Not used) For compatibility with MHV7T + ; HL - (required) Array of HL package variables + ; Output: + ; MFN^Z01 message in MSGROOT + ; MSH,MFI,MFE,ZHV + ; + N CNT + S CNT=0 + K @MSGROOT + S CNT=CNT+1,@MSGROOT@(CNT)=$$MFI(.HL) + S CNT=CNT+1,@MSGROOT@(CNT)=$$MFE(.ADM,.HL) + S CNT=CNT+1,@MSGROOT@(CNT)=$$ZHV(.ADM,.HL) + Q + ; +MFI(HL) ;build MFI segment + N MFI + S MFI(0)="MFI" + S MFI(1,1,1)="MHV" + S MFI(3)="UPD" + S MFI(6)="NE" + Q $$BLDSEG^MHV7U(.MFI,.HL) + ; +MFE(ADM,HL) ;build MFE segment + N MFE + S MFE(0)="MFE" + S MFE(1)="MUP" + S MFE(4)=$G(ADM("SITE NUMBER")) + S MFE(5)="CE" + Q $$BLDSEG^MHV7U(.MFE,.HL) + ; +ZHV(ADM,HL) ;build ZHV segment + N ZHV + S ZHV(0)="ZHV" + S ZHV(1,1,1)=$G(ADM("SITE NUMBER")) + S ZHV(1,1,2)=$$ESCAPE^MHV7U($G(ADM("SITE NAME")),.HL) + S ZHV(2)=$G(ADM("DOMAIN")) + S ZHV(3)=$G(ADM("IP ADDRESS")) + S ZHV(4)=$G(ADM("HL7 LISTENER PORT")) + S ZHV(5)=$G(ADM("RPC BROKER PORT")) + S ZHV(6,1,1)=$G(ADM("VERSION")) + S ZHV(7)=$$ESCAPE^MHV7U($G(ADM("PATCH NUMBER")),.HL) + S ZHV(8)=$G(ADM("SYSTEM TYPE")) + Q $$BLDSEG^MHV7U(.ZHV,.HL) + ; diff --git a/r/MY_HEALTHEVET-MHV/MHV7B1.m b/r/MY_HEALTHEVET-MHV/MHV7B1.m index 71383bc4..1417c9d9 100644 --- a/r/MY_HEALTHEVET-MHV/MHV7B1.m +++ b/r/MY_HEALTHEVET-MHV/MHV7B1.m @@ -1,58 +1,108 @@ -MHV7B1 ;WAS/GPM - HL7 message builder RTB^K13 ; [1/7/08 10:45pm] - ;;1.0;My HealtheVet;**2**;Aug 23, 2005;Build 22 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - Q - ; -RTBK13(MSGROOT,QRY,ERR,DATAROOT,LEN,HL) ; Build query response - ; - ; Populates the array pointed to by MSGROOT with an RTB^K13 query - ; response message by calling the appropriate segment builders based - ; on the type of response ACK/Data or NAK. Extracted data pointed to - ; by DATAROOT, errors, hit counts, and query information are used to - ; build the segments. - ; An error number in ERR^4 indicates a NAK is needed. - ; DATAROOT being null indicates a dataless ACK (testing purposes). - ; Multiple types of RDF/RDT are supported based on the type of - ; data in the response. The appropriate domain specific builder is - ; called based on QRY("BUILDER"). Note that this is a different - ; routine than the XMT("BUILDER"). - ; - ; Input: - ; MSGROOT - Global root of message - ; QRY - Query parameters - ; QRY("BUILDER") - Domain specific builder routine - ; QRY("MID") - original message control ID - ; ERR - Caret delimited error string - ; segment^sequence^field^code^ACK type^error text - ; DATAROOT - Global root of data array - ; HL - HL7 package array variable - ; - ; Output: RTB^K13 message in MSGROOT - ; LEN - Length of formatted message - ; - N CNT,RDT,HIT,EXTIME - D LOG^MHVUL2("RTB-K13 BUILDER","BEGIN","S","TRACE") - ; - S HIT=0,EXTIME="" - I DATAROOT'="" D - . S HIT=+$P($G(@DATAROOT),"^",1) - . S EXTIME=$P($G(@DATAROOT),"^",2) - . Q - S HIT=HIT_"^"_HIT_"^0" - ; - K @MSGROOT - S CNT=1,@MSGROOT@(CNT)=$$MSA^MHV7BUS($G(QRY("MID")),ERR,.HL),LEN=$L(@MSGROOT@(CNT)) - I $P(ERR,"^",4) S CNT=CNT+1,HIT="0^0^0",@MSGROOT@(CNT)=$$ERR^MHV7BUS(ERR,.HL),LEN=LEN+$L(@MSGROOT@(CNT)) - S CNT=CNT+1,@MSGROOT@(CNT)=$$QAK^MHV7BUS(.QRY,ERR,HIT,.HL),LEN=LEN+$L(@MSGROOT@(CNT)) - S CNT=CNT+1,@MSGROOT@(CNT)=$$QPD^MHV7BUS(.QRY,EXTIME,.HL),LEN=LEN+$L(@MSGROOT@(CNT)) - I '$P(ERR,"^",4) D - . D @("RDF^"_QRY("BUILDER")_"(MSGROOT,.CNT,.LEN,.HL)") - . Q:DATAROOT="" - . Q:HIT<1 - . D @("RDT^"_QRY("BUILDER")_"(MSGROOT,DATAROOT,.CNT,.LEN,.HL)") - . Q - ; - D LOG^MHVUL2("RTB-K13 BUILDER","END","S","TRACE") - Q - ; +MHV7B1 ;WAS/GPM - HL7 message builder RTB^K13 ; [8/22/05 6:18pm] + ;;1.0;My HealtheVet;;Aug 23, 2005 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; + Q + ; +RTBK13(MSGROOT,QRY,ERR,DATAROOT,HL) ; Build query response + ; + ; Populates the array pointed to by MSGROOT with an RTB^K13 query + ; response message by calling the appropriate segment builders based + ; on the type of response ACK/Data or NAK. Extracted data pointed to + ; by DATAROOT, errors, hit counts, and query information are user to + ; buld the segments. + ; An error number in ERR^4 indicates a NAK is needed. + ; DATAROOT being null indicates a dataless ACK (testing purposes). + ; Multiple types of RDF/RDT are supported based on the type of + ; data in the response, indicated by QRY("TYPE"). + ; + ; Input: + ; MSGROOT - Global root of message + ; QRY - Query parameters + ; QRY("TYPE") - Request type number + ; QRY("MID") - original message control ID + ; ERR - Caret delimited error string + ; segment^sequence^field^code^ACK type^error text + ; DATAROOT - Global root of data array + ; HL - HL7 package array variable + ; + ; Output: RTB^K13 message in MSGROOT + ; + N CNT,RDT,HIT + S HIT="" + I DATAROOT'="" S HIT=$G(@DATAROOT) + I HIT="" S HIT=0 + S HIT=HIT_"^"_HIT_"^0" + K @MSGROOT + S CNT=1,@MSGROOT@(CNT)=$$MSA($G(QRY("MID")),ERR,.HL) + I $P(ERR,"^",4) S CNT=CNT+1,HIT="0^0^0",@MSGROOT@(CNT)=$$ERR(ERR,.HL) + S CNT=CNT+1,@MSGROOT@(CNT)=$$QAK(.QRY,ERR,HIT,.HL) + S CNT=CNT+1,@MSGROOT@(CNT)=$$QPD(.QRY,.HL) + Q:$P(ERR,"^",4) + S CNT=CNT+1,@MSGROOT@(CNT)=$$RDF(QRY("TYPE"),.HL) + Q:DATAROOT="" + Q:@DATAROOT<1 + D RDT(MSGROOT,QRY("TYPE"),DATAROOT,.CNT,.HL) + Q + ; +MSA(MID,ERROR,HL) ;build MSA segment + N MSA,ACK + S ACK=$P(ERROR,"^",5) + I ACK="" S ACK="AA" + S MSA(0)="MSA" + S MSA(1)=ACK ;ACK code + S MSA(2)=MID ;message control ID + S MSA(3)=$$ESCAPE^MHV7U($P(ERROR,"^",6),.HL) ;text message + Q $$BLDSEG^MHV7U(.MSA,.HL) + ; +ERR(ERROR,HL) ;build ERR segment + N ERR + S ERR(0)="ERR" + S ERR(1,1,1)=$P(ERROR,"^",1) ;segment + S ERR(1,1,2)=$P(ERROR,"^",2) ;sequence + S ERR(1,1,3)=$P(ERROR,"^",3) ;field + S ERR(1,1,4,1)=$P(ERROR,"^",4) ;code + S ERR(1,1,4,2)=$$ESCAPE^MHV7U($P(ERROR,"^",6),.HL) ;text + Q $$BLDSEG^MHV7U(.ERR,.HL) + ; +QAK(QRY,ERROR,HIT,HL) ;build QAK segment + N QAK,STATUS + S STATUS=$P(ERROR,"^",5) + I STATUS="" S STATUS="OK" + I STATUS="OK",HIT<1 S STATUS="NF" + S QAK(0)="QAK" + S QAK(1)=QRY("QPD",2) ;query tag + S QAK(2)=STATUS ;query response status + M QAK(3)=QRY("QPD",1) ;message query name + S QAK(4)=$P(HIT,"^",1) ;hit count total + S QAK(5)=$P(HIT,"^",2) ;hits this payload + S QAK(6)=$P(HIT,"^",3) ;hits remaining + Q $$BLDSEG^MHV7U(.QAK,.HL) + ; +QPD(QRY,HL) ;build QPD segment + N QPD + M QPD=QRY("QPD") + S QPD(0)="QPD" + S QPD(7)=$G(QRY("ICN")) ;ICN + S QPD(8)=$G(QRY("DFN")) ;DFN + Q $$BLDSEG^MHV7U(.QPD,.HL) + ; +RDF(REQTYPE,HL) ; build RDF segment + N RTN + S RTN=$$RTN(REQTYPE) + Q:RTN="" "RDF" + Q @("$$RDF^"_RTN_"(.HL)") + ; +RDT(MSGROOT,REQTYPE,DATAROOT,CNT,HL) ; Build RDT segments + N RTN + S RTN=$$RTN(REQTYPE) + Q:RTN="" + D @("RDT^"_RTN_"(MSGROOT,DATAROOT,.CNT,.HL)") + Q + ; +RTN(REQTYPE) ; + N RDEF + S RDEF(3)="MHV7B1B" + S RDEF(21)="MHV7B1B" + Q $G(RDEF(REQTYPE)) + ; diff --git a/r/MY_HEALTHEVET-MHV/MHV7B1B.m b/r/MY_HEALTHEVET-MHV/MHV7B1B.m index eb68ee0f..6fae1916 100644 --- a/r/MY_HEALTHEVET-MHV/MHV7B1B.m +++ b/r/MY_HEALTHEVET-MHV/MHV7B1B.m @@ -1,113 +1,97 @@ -MHV7B1B ;WAS/GPM - HL7 message builder RTB^K13 Rx Profile ; 10/13/05 7:52pm [12/24/07 5:39pm] - ;;1.0;My HealtheVet;**2**;Aug 23, 2005;Build 22 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - Q - ; -RDF(MSGROOT,CNT,LEN,HL) ; Build RDF segment for Rx Profile data - ; - ; Input: - ; MSGROOT - Root of array holding the message - ; CNT - Current message line counter - ; LEN - Current message length - ; HL - HL7 package array variable - ; - ; Output: - ; - Populated message array - ; - Updated LEN and CNT - ; - N RDF - S RDF(0)="RDF" - S RDF(1)=20 - S RDF(2,1,1)="Prescription Number",RDF(2,1,2)="ST",RDF(2,1,3)=20 - S RDF(2,2,1)="IEN",RDF(2,2,2)="NM",RDF(2,2,3)=30 - S RDF(2,3,1)="Drug Name",RDF(2,3,2)="ST",RDF(2,3,3)=40 - S RDF(2,4,1)="Issue Date/Time",RDF(2,4,2)="TS",RDF(2,4,3)=26 - S RDF(2,5,1)="Last Fill Date",RDF(2,5,2)="TS",RDF(2,5,3)=26 - S RDF(2,6,1)="Release Date/Time",RDF(2,6,2)="TS",RDF(2,6,3)=26 - S RDF(2,7,1)="Expiration or Cancel Date",RDF(2,7,2)="TS",RDF(2,7,3)=26 - S RDF(2,8,1)="Status",RDF(2,8,2)="ST",RDF(2,8,3)=25 - S RDF(2,9,1)="Quantity",RDF(2,9,2)="NM",RDF(2,9,3)=11 - S RDF(2,10,1)="Days Supply",RDF(2,10,2)="NM",RDF(2,10,3)=3 - S RDF(2,11,1)="Number of Refills",RDF(2,11,2)="NM",RDF(2,11,3)=3 - S RDF(2,12,1)="Provider",RDF(2,12,2)="XCN",RDF(2,12,3)=150 - S RDF(2,13,1)="Placer Order Number",RDF(2,13,2)="ST",RDF(2,13,3)=30 - S RDF(2,14,1)="Mail/Window",RDF(2,14,2)="ST",RDF(2,14,3)=1 - S RDF(2,15,1)="Division",RDF(2,15,2)="NM",RDF(2,15,3)=3 - S RDF(2,16,1)="Division Name",RDF(2,16,2)="ST",RDF(2,16,3)=20 - S RDF(2,17,1)="MHV Request Status",RDF(2,17,2)="NM",RDF(2,17,3)=3 - S RDF(2,18,1)="MHV Request Status Date",RDF(2,18,2)="TS",RDF(2,18,3)=26 - S RDF(2,19,1)="Remarks",RDF(2,19,2)="ST",RDF(2,19,3)=75 - S RDF(2,20,1)="SIG",RDF(2,20,2)="TX",RDF(2,20,3)=1024 - ; - S CNT=CNT+1 - S @MSGROOT@(CNT)=$$BLDSEG^MHV7U(.RDF,.HL) - S LEN=LEN+$L(@MSGROOT@(CNT)) - Q - ; -RDT(MSGROOT,DATAROOT,CNT,LEN,HL) ; Build RDT segments for Rx Profile data - ; - ; Walks data in DATAROOT to populate MSGROOT with RDT segments - ; sequentially numbered starting at CNT - ; - ; Integration Agreements: - ; 10103 : FMTHL7^XLFDT - ; 3065 : HLNAME^XLFNAME - ; - ; Input: - ; MSGROOT - Root of array holding the message - ; DATAROOT - Root of array to hold extract data - ; CNT - Current message line counter - ; LEN - Current message length - ; HL - HL7 package array variable - ; - ; Output: - ; - Populated message array - ; - Updated LEN and CNT - ; - N I,RX,RX0,RXP,RXN,RXD,RDT,SIG,SEG,PIEN,NAME,WPLEN - D LOG^MHVUL2("MHV7B1B","BEGIN RDT","S","TRACE") - F I=1:1 Q:'$D(@DATAROOT@(I)) D - . S RX=@DATAROOT@(I) - . S RX0=@DATAROOT@(I,0) - . S RXP=@DATAROOT@(I,"P") - . S PIEN=+RXP - . S RXN=@DATAROOT@(I,"RXN") - . S RXD=@DATAROOT@(I,"DIV") - . K SIG M SIG=@DATAROOT@(I,"SIG") - . S RDT(0)="RDT" - . S RDT(1)=$P(RX,"^") ;Rx Number - . S RDT(2)=$P(RXN,"^",9) ;Rx IEN - . S RDT(3)=$$ESCAPE^MHV7U($P(RX,"^",2),.HL) ;Drug Name - . S RDT(4)=$$FMTHL7^XLFDT($P(RX0,"^",5)) ;Issue Date/Time - . S RDT(5)=$$FMTHL7^XLFDT($P(RX0,"^",12)) ;Last Fill Date - . S RDT(6)=$$FMTHL7^XLFDT($P(RXN,"^",2)) ;Release Date/Time - . S RDT(7)=$$FMTHL7^XLFDT($P(RX0,"^",3)) ;Expiration/Cancel Date - . S RDT(8)=$$ESCAPE^MHV7U($P(RX0,"^",6),.HL) ;Status - . S RDT(9)=$P(RX0,"^",8) ;Quantity - . S RDT(10)=$P(RX0,"^",7) ;Days Supply - . S RDT(11)=$P(RX0,"^",4) ;Number of Refills - . I PIEN D - .. D FMTNAME2^MHV7BU(PIEN,200,.NAME,.HL,"XCN") - .. M RDT(12,1)=NAME - .. S RDT(12,1,1)=PIEN ;Provider IEN - .. Q - . S RDT(13)=$$ESCAPE^MHV7U($P(RX0,"^",11),.HL) ;Placer Order Number - . S RDT(14)=$P(RXN,"^",3) ;Mail/Window - . S RDT(15)=$P(RXD,"^") ;Division - . S RDT(16)=$$ESCAPE^MHV7U($P(RXD,"^",2),.HL) ;Division Name - . S RDT(17)=$P(RX,"^",3) ;MHV status - . S RDT(18)=$$FMTHL7^XLFDT($P(RX,"^",4)) ;MHV status date - . S RDT(19)=$$ESCAPE^MHV7U($P(RXN,"^",4),.HL) ;Remarks - . S CNT=CNT+1 - . S @MSGROOT@(CNT)=$$BLDSEG^MHV7U(.RDT,.HL) - . S LEN=LEN+$L(@MSGROOT@(CNT)) - . Q:'SIG(0) - . K SEG,WPLEN - . D BLDWP^MHV7U(.SIG,.SEG,1024,0,.WPLEN,.HL) - . M @MSGROOT@(CNT)=SEG - . S LEN=LEN+WPLEN - . Q - D LOG^MHVUL2("MHV7B1B","END RDT","S","TRACE") - Q - ; +MHV7B1B ;WAS/GPM - HL7 message builder RTB^K13 Rx Profile ; [8/22/05 11:45pm] + ;;1.0;My HealtheVet;;Aug 23, 2005 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; + Q + ; +RDF(HL) ; Build RDF segment for Rx Profile data + N RDF + S RDF(0)="RDF" + S RDF(1)=20 + S RDF(2,1,1)="Prescription Number",RDF(2,1,2)="ST",RDF(2,1,3)=20 + S RDF(2,2,1)="IEN",RDF(2,2,2)="NM",RDF(2,2,3)=30 + S RDF(2,3,1)="Drug Name",RDF(2,3,2)="ST",RDF(2,3,3)=40 + S RDF(2,4,1)="Issue Date/Time",RDF(2,4,2)="TS",RDF(2,4,3)=26 + S RDF(2,5,1)="Last Fill Date",RDF(2,5,2)="TS",RDF(2,5,3)=26 + S RDF(2,6,1)="Release Date/Time",RDF(2,6,2)="TS",RDF(2,6,3)=26 + S RDF(2,7,1)="Expiration or Cancel Date",RDF(2,7,2)="TS",RDF(2,7,3)=26 + S RDF(2,8,1)="Status",RDF(2,8,2)="ST",RDF(2,8,3)=25 + S RDF(2,9,1)="Quantity",RDF(2,9,2)="NM",RDF(2,9,3)=11 + S RDF(2,10,1)="Days Supply",RDF(2,10,2)="NM",RDF(2,10,3)=3 + S RDF(2,11,1)="Number of Refills",RDF(2,11,2)="NM",RDF(2,11,3)=3 + S RDF(2,12,1)="Provider",RDF(2,12,2)="XCN",RDF(2,12,3)=150 + S RDF(2,13,1)="Placer Order Number",RDF(2,13,2)="ST",RDF(2,13,3)=30 + S RDF(2,14,1)="Mail/Window",RDF(2,14,2)="ST",RDF(2,14,3)=1 + S RDF(2,15,1)="Division",RDF(2,15,2)="NM",RDF(2,15,3)=3 + S RDF(2,16,1)="Division Name",RDF(2,16,2)="ST",RDF(2,16,3)=20 + S RDF(2,17,1)="MHV Request Status",RDF(2,17,2)="NM",RDF(2,17,3)=3 + S RDF(2,18,1)="MHV Request Status Date",RDF(2,18,2)="TS",RDF(2,18,3)=26 + S RDF(2,19,1)="Remarks",RDF(2,19,2)="ST",RDF(2,19,3)=75 + S RDF(2,20,1)="SIG",RDF(2,20,2)="TX",RDF(2,20,3)=1024 + Q $$BLDSEG^MHV7U(.RDF,.HL) + ; +RDT(MSGROOT,DATAROOT,CNT,HL) ; Build RDT segments for Rx Profile data + ; + ; Walks data in DATAROOT to popoulate MSGROOT with RDT segments + ; sequentially numbered starting at CNT + ; + ; Integration Agreements: + ; 3065 : $$HLNAME^XLFNAME + ; + ; Input: + ; MSGROOT - Root of array holding the message + ; DATAROOT - Root of array to hold extract data + ; CNT - Current message line counter + ; HL - HL7 package array variable + ; + ; Output: + ; - Populated message array + ; + N I,RX,RX0,RXP,RXN,RXD,RDT,SIG,SEG,PIEN,NAME + F I=1:1 Q:'$D(@DATAROOT@(I)) D + . S RX=@DATAROOT@(I) + . S RX0=@DATAROOT@(I,0) + . S RXP=@DATAROOT@(I,"P") + . S PIEN=+RXP + . S RXN=@DATAROOT@(I,"RXN") + . S RXD=@DATAROOT@(I,"DIV") + . K SIG M SIG=@DATAROOT@(I,"SIG") + . S RDT(0)="RDT" + . S RDT(1)=$P(RX,"^") ;Rx Number + . S RDT(2)=$P(RXN,"^",9) ;Rx IEN + . S RDT(3)=$$ESCAPE^MHV7U($P(RX,"^",2),.HL) ;Drug Name + . S RDT(4)=$$FMTHL7^XLFDT($P(RX0,"^",5)) ;Issue Date/Time + . S RDT(5)=$$FMTHL7^XLFDT($P(RX0,"^",12)) ;Last Fill Date + . S RDT(6)=$$FMTHL7^XLFDT($P(RXN,"^",2)) ;Release Date/Time + . S RDT(7)=$$FMTHL7^XLFDT($P(RX0,"^",3)) ;Expiration/Cancel Date + . S RDT(8)=$$ESCAPE^MHV7U($P(RX0,"^",6),.HL) ;Status + . S RDT(9)=$P(RX0,"^",8) ;Quantity + . S RDT(10)=$P(RX0,"^",7) ;Days Supply + . S RDT(11)=$P(RX0,"^",4) ;Number of Refills + . I PIEN D + .. S RDT(12,1,1)=PIEN ;Provider IEN + .. S NAME("FILE")=200,NAME("FIELD")=.01,NAME("IENS")=PIEN_"," + .. S NAME=$$HLNAME^XLFNAME(.NAME,"","^") + .. S RDT(12,1,2)=$$ESCAPE^MHV7U($P(NAME,"^"),.HL) ;family + .. S RDT(12,1,3)=$$ESCAPE^MHV7U($P(NAME,"^",2),.HL) ;given + .. S RDT(12,1,4)=$$ESCAPE^MHV7U($P(NAME,"^",3),.HL) ;middle + .. S RDT(12,1,5)=$$ESCAPE^MHV7U($P(NAME,"^",4),.HL) ;suffix + .. S RDT(12,1,6)=$$ESCAPE^MHV7U($P(NAME,"^",5),.HL) ;prefix + .. S RDT(12,1,7)=$$ESCAPE^MHV7U($P(NAME,"^",6),.HL) ;degree + .. Q + . S RDT(13)=$$ESCAPE^MHV7U($P(RX0,"^",11),.HL) ;Placer Order Number + . S RDT(14)=$P(RXN,"^",3) ;Mail/Window + . S RDT(15)=$P(RXD,"^") ;Division + . S RDT(16)=$$ESCAPE^MHV7U($P(RXD,"^",2),.HL) ;Division Name + . S RDT(17)=$P(RX,"^",3) ;MHV status + . S RDT(18)=$$FMTHL7^XLFDT($P(RX,"^",4)) ;MHV status date + . S RDT(19)=$$ESCAPE^MHV7U($P(RXN,"^",4),.HL) ;Remarks + . S CNT=CNT+1 + . S @MSGROOT@(CNT)=$$BLDSEG^MHV7U(.RDT,.HL) + . Q:'SIG(0) + . K SEG + . D BLDWPSEG^MHV7U(.SIG,.SEG,1024,.HL) + . M @MSGROOT@(CNT)=SEG + . Q + Q + ; diff --git a/r/MY_HEALTHEVET-MHV/MHV7B2.m b/r/MY_HEALTHEVET-MHV/MHV7B2.m index f9f060e5..6f716d5b 100644 --- a/r/MY_HEALTHEVET-MHV/MHV7B2.m +++ b/r/MY_HEALTHEVET-MHV/MHV7B2.m @@ -1,75 +1,115 @@ -MHV7B2 ;WAS/GPM - HL7 message builder ORP^O10 ; [12/24/07 5:43pm] - ;;1.0;My HealtheVet;**2**;Aug 23, 2005;Build 22 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - Q - ; -ORPO10(MSGROOT,REQ,ERR,DATAROOT,LEN,HL) ; Build refill request response - ; - ; Populates the array pointed to by MSGROOT with an ORP^O10 order - ; response message by calling the appropriate segment builders based - ; on the type of response ACK or NAK. Extracted data pointed to - ; by DATAROOT, errors, and request parameters are used to build the - ; segments. An error number in ERR^4 indicates a NAK is needed. - ; - ; Integration Agreements: - ; 3065 : $$HLNAME^XLFNAME - ; 10112 : $$SITE^VASITE - ; - ; Input: - ; MSGROOT - Global root of message - ; REQ - Query parameters - ; REQ("TYPE") - Request type number - ; REQ("MID") - original message control ID - ; ERR - Caret delimited error string - ; segment^sequence^field^code^ACK type^error text - ; DATAROOT - Global root of data array - ; HL - HL7 package array variable - ; - ; Output: ORP^O10 message in MSGROOT - ; LEN - Length of formatted message - ; - N CNT,HIT,I - D LOG^MHVUL2("ORP-O10 BUILDER","BEGIN","S","TRACE") - ; - K @MSGROOT - S CNT=1,@MSGROOT@(CNT)=$$MSA^MHV7BUS($G(REQ("MID")),ERR,.HL),LEN=$L(@MSGROOT@(CNT)) - I $P(ERR,"^",4) S CNT=CNT+1,@MSGROOT@(CNT)=$$ERR^MHV7BUS(ERR,.HL),LEN=LEN+$L(@MSGROOT@(CNT)) - S CNT=CNT+1,@MSGROOT@(CNT)=$$PID^MHV7BUS(.REQ,.HL),LEN=LEN+$L(@MSGROOT@(CNT)) - ; - I '$P(ERR,"^",4),DATAROOT'="" D - . F I=1:1 Q:'$D(@DATAROOT@(I)) D - .. S CNT=CNT+1,@MSGROOT@(CNT)=$$ORC(@DATAROOT@(I),.HL),LEN=LEN+$L(@MSGROOT@(CNT)) - .. S CNT=CNT+1,@MSGROOT@(CNT)=$$RXE(@DATAROOT@(I),.HL),LEN=LEN+$L(@MSGROOT@(CNT)) - .. Q - . Q - ; - D LOG^MHVUL2("ORP-O10 BUILDER","END","S","TRACE") - Q - ; -ORC(DATA,HL) ;build ORC segment - N ORC,STATUS,CONTROL - S STATUS=$P(DATA,"^",2) - S CONTROL=$S(STATUS=1:"OK",1:"UA") - S ORC(0)="ORC" - S ORC(1)=CONTROL ;order control - S ORC(2)=$P(DATA,"^",3) ;placer order number - S ORC(3)=$P(DATA,"^",3) ;filler order number - Q $$BLDSEG^MHV7U(.ORC,.HL) - ; -RXE(DATA,HL) ;build RXE segment - N RXE,STATUS,CONTROL - S STATUS=$P(DATA,"^",2) - S CONTROL=$S(STATUS=1:"OK",1:"UA") - S RXE(0)="RXE" - S RXE(1,1,1,1)=1 ;order quantity - S RXE(1,1,4,1)=$P(DATA,"^",4) ;order start time - S RXE(2,1,1)=CONTROL ;give code identifier - S RXE(2,1,2)=STATUS ;give code text - S RXE(2,1,3)="HL70119" ;give code system - S RXE(3)=1 ;give amount - S RXE(5)="1 refill unit" ;give units - ;S RXE(7)="" ;division number - S RXE(15)=$P(DATA,"^",1) ;prescription number - Q $$BLDSEG^MHV7U(.RXE,.HL) - ; +MHV7B2 ;WAS/GPM - HL7 message builder ORP^O10 ; [8/22/05 11:47pm] + ;;1.0;My HealtheVet;;Aug 23, 2005 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; + Q + ; +ORPO10(MSGROOT,REQ,ERR,DATAROOT,HL) ; Build refill request response + ; + ; Populates the array pointed to by MSGROOT with an ORP^O10 order + ; response message by calling the appropriate segment builders based + ; on the type of response ACK or NAK. Extracted data pointed to + ; by DATAROOT, errors, and request parameters are used to build the + ; segments. An error number in ERR^4 indicates a NAK is needed. + ; + ; Integration Agreements: + ; 3065 : $$HLNAME^XLFNAME + ; 10112 : $$SITE^VASITE + ; + ; Input: + ; MSGROOT - Global root of message + ; REQ - Query parameters + ; REQ("TYPE") - Request type number + ; REQ("MID") - original message control ID + ; ERR - Caret delimited error string + ; segment^sequence^field^code^ACK type^error text + ; DATAROOT - Global root of data array + ; HL - HL7 package array variable + ; + ; Output: ORP^O10 message in MSGROOT + ; + N CNT,RDT,HIT,I + K @MSGROOT + S CNT=1,@MSGROOT@(CNT)=$$MSA^MHV7B1($G(REQ("MID")),ERR,.HL) + I $P(ERR,"^",4) S CNT=CNT+1,@MSGROOT@(CNT)=$$ERR^MHV7B1(ERR,.HL) + Q:$P(ERR,"^",4) + S CNT=CNT+1,@MSGROOT@(CNT)=$$PID(.REQ,.HL) + F I=1:1 Q:'$D(@DATAROOT@(I)) D + . S CNT=CNT+1,@MSGROOT@(CNT)=$$ORC(@DATAROOT@(I),.HL) + . S CNT=CNT+1,@MSGROOT@(CNT)=$$RXE(@DATAROOT@(I),.HL) + . Q + Q + ; +PID(REQ,HL) ; + N PID,NAME,STATION,IDCNT + S STATION=$P($$SITE^VASITE,"^",3) + S PID(0)="PID" + S IDCNT=0 + I REQ("ICN")'="" D + . S IDCNT=IDCNT+1 + . S PID(3,IDCNT,1)=REQ("ICN") ;Patient ID - ICN + . S PID(3,IDCNT,4,1)="USVHA" ;assigning authority ID + . S PID(3,IDCNT,4,3)="HL70363" ;assigning authority type + . S PID(3,IDCNT,5)="NI" ;Patient ID type + . S PID(3,IDCNT,6,1)="VA FACILITY ID" ;assigning facility + . S PID(3,IDCNT,6,2)=STATION ;Station number + . S PID(3,IDCNT,6,3)="L" ;facility ID type + . Q + ; + I REQ("DFN")'="" D + . S IDCNT=IDCNT+1 + . S PID(3,IDCNT,1)=REQ("DFN") ;Patient ID - DFN + . S PID(3,IDCNT,4,1)="USVHA" ;assigning authority ID + . S PID(3,IDCNT,4,3)="HL70363" ;assigning authority type + . S PID(3,IDCNT,5)="PI" ;Patient ID type + . S PID(3,IDCNT,6,1)="VA FACILITY ID" ;assigning facility + . S PID(3,IDCNT,6,2)=STATION ;Station number + . S PID(3,IDCNT,6,3)="L" ;facility ID type + . Q + ; + I REQ("SSN")'="" D + . S IDCNT=IDCNT+1 + . S PID(3,IDCNT,1)=REQ("SSN") ;Patient ID - SSN + . S PID(3,IDCNT,4,1)="USSSA" ;assigning authority ID + . S PID(3,IDCNT,4,3)="HL70363" ;assigning authority type + . S PID(3,IDCNT,5)="SS" ;Patient ID type + . S PID(3,IDCNT,6,1)="VA FACILITY ID" ;assigning facility + . S PID(3,IDCNT,6,2)="200MH" ;Station number + . S PID(3,IDCNT,6,3)="L" ;facility ID type + . Q + ; + S NAME("FILE")=2,NAME("FIELD")=.01,NAME("IENS")=REQ("DFN")_"," + S NAME=$$NAMEFMT^XLFNAME(.NAME) + S PID(5,1,1)=$$ESCAPE^MHV7U($P(NAME,"^"),.HL) ;family + S PID(5,1,2)=$$ESCAPE^MHV7U($P(NAME,"^",2),.HL) ;given + S PID(5,1,3)=$$ESCAPE^MHV7U($P(NAME,"^",3),.HL) ;middle + S PID(5,1,4)=$$ESCAPE^MHV7U($P(NAME,"^",4),.HL) ;suffix + ; + Q $$BLDSEG^MHV7U(.PID,.HL) + ; +ORC(DATA,HL) ;build ORC segment + N ORC,STATUS,CONTROL + S STATUS=$P(DATA,"^",2) + S CONTROL=$S(STATUS=1:"OK",1:"UA") + S ORC(0)="ORC" + S ORC(1)=CONTROL ;order control + S ORC(2)=$P(DATA,"^",3) ;placer order number + S ORC(3)=$P(DATA,"^",3) ;filler order number + Q $$BLDSEG^MHV7U(.ORC,.HL) + ; +RXE(DATA,HL) ;build RXE segment + N RXE,STATUS,CONTROL + S STATUS=$P(DATA,"^",2) + S CONTROL=$S(STATUS=1:"OK",1:"UA") + S RXE(0)="RXE" + S RXE(1,1,1,1)=1 ;order quantity + S RXE(1,1,4,1)=$P(DATA,"^",4) ;order start time + S RXE(2,1,1)=CONTROL ;give code identifier + S RXE(2,1,2)=STATUS ;give code text + S RXE(2,1,3)="HL70119" ;give code system + S RXE(3)=1 ;give amount + S RXE(5)="1 refill unit" ;give units + ;S RXE(7)="" ;division number + S RXE(15)=$P(DATA,"^",1) ;prescription number + Q $$BLDSEG^MHV7U(.RXE,.HL) + ; diff --git a/r/MY_HEALTHEVET-MHV/MHV7R1.m b/r/MY_HEALTHEVET-MHV/MHV7R1.m index ab8700e8..7e6b14b5 100644 --- a/r/MY_HEALTHEVET-MHV/MHV7R1.m +++ b/r/MY_HEALTHEVET-MHV/MHV7R1.m @@ -1,182 +1,195 @@ -MHV7R1 ;WAS/GPM - HL7 RECEIVER FOR QBP QUERIES ; [12/31/07 3:11pm] - ;;1.0;My HealtheVet;**1,2**;Aug 23, 2005;Build 22 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - Q - ; -QBPQ13 ;Process QBP^Q13 messages from the MHV QBP-Q13 Subscriber protocol - ; -QBPQ11 ;Process QBP^Q11 messages from the MHV QBP-Q11 Subscriber protocol - ; - ; This routine and subroutines assume that all VistA HL7 environment - ; variables are properly initialized and will produce a fatal error - ; if they are missing. - ; - ; The message will be checked to see if it is a valid query. - ; If not a negative acknowledgement will be sent. If the query is an - ; immediate mode or synchronous query, the realtime request manager - ; is called to handle the query. This means the query will be - ; processed and a response generated immediately. - ; In the future deferred mode queries may be filed in a database for - ; later processing, or transmission. - ; - ; Input: - ; HL7 environment variables - ; - ; Output: - ; Processed query or negative acknowledgement - ; If handled real-time the query response is generated - ; - N MSGROOT,QRY,XMT,ERR,RNAME - S (QRY,XMT,ERR)="" - ; Inbound query messages are small enough to be held in a local. - ; The following lines commented out support use of global and are - ; left in case use a global becomes necessary. - ;S MSGROOT="^TMP(""MHV7"",$J)" - ;K @MSGROOT - S MSGROOT="MHV7MSG" - N MHV7MSG - D LOADXMT^MHV7U(.XMT) ;Load inbound message information - ; - S RNAME=XMT("MESSAGE TYPE")_"-"_XMT("EVENT TYPE")_" RECEIVER" - D LOG^MHVUL2(RNAME,"BEGIN","S","TRACE") - ; - D LOADMSG^MHV7U(MSGROOT) - D LOG^MHVUL2("LOAD",MSGROOT,"I","DEBUG") - ; - D PARSEMSG^MHV7U(MSGROOT,.HL) - D LOG^MHVUL2("PARSE",MSGROOT,"I","DEBUG") - ; - I '$$VALIDMSG(MSGROOT,.QRY,.XMT,.ERR) D Q - . D LOG^MHVUL2("MSG CHECK","INVALID^"_ERR,"S","ERROR") - . D XMIT^MHV7T(.QRY,.XMT,ERR,"",.HL) - D LOG^MHVUL2("MSG CHECK","VALID","S","TRACE") - ; - ; Immediate Mode - ; Deferred mode queries are not supported at this time - D REALTIME^MHVRQI(.QRY,.XMT,.HL) - ; - D LOG^MHVUL2(RNAME,"END","S","TRACE") - D RESET^MHVUL2 ;Clean up TMP used by logging - ;K @MSGROOT - ; - Q - ; -VALIDMSG(MSGROOT,QRY,XMT,ERR) ;Validate message - ; - ; Messages handled: QBP^Q13 - ; QBP^Q11 - ; - ; QBP query messages must contain PID, QPD and RCP segments - ; RXE segments are processed on Q13 prescription queries - ; Any additional segments are ignored - ; - ; The following sequences are required - ; PID(3) - Patient ID - ; PID(5)* - Patient Name - ; QPD(1)* - Message Query Name - ; QPD(2)* - Query Tag - ; QPD(3) - Request ID - ; QPD(4) - Subject Area - ; RCP(1) - Query Priority - ; * required by HL7 standard but not used by MHV - ; - ; The following sequences are optional - ; QPD(5) - From Date - ; QPD(6) - To Date - ; RCP(2) - Quantity Limited - ; - ; Input: - ; MSGROOT - Root of array holding message - ; XMT - Transmission parameters - ; - ; Output: - ; QRY - Query Array - ; XMT - Transmission parameters - ; ERR - segment^sequence^field^code^ACK type^error text - ; - N MSH,PID,RDF,RXE,QPD,RCP,REQID,REQTYPE,FROMDT,TODT,PRI,QTAG,QNAME,SEGTYPE,CNT,OCNT,RXNUM,QTY,UNIT - K QRY,ERR - S ERR="" - ; - ; Set up basics for responding to message. - ;----------------------------------------- - S QRY("MID")=XMT("MID") ;Message ID - S QRY("QPD")="" - ; - ; Validate message is a well-formed QBP query message. - ;----------------------------------------------------------- - ; Must have MSH first, followed by QPD,PID,RXE,RDF,RCP in any order - ; RXE is processed on Q13 prescriptions queries - ; RDF is not required - ; Any other segments are ignored. - ; - I $G(@MSGROOT@(1,0))="MSH" M MSH=@MSGROOT@(1) - E S ERR="MSH^1^^100^AE^Missing MSH segment" Q 0 - ; - S CNT=2,OCNT=0 - F Q:'$D(@MSGROOT@(CNT)) D S CNT=CNT+1 - . S SEGTYPE=$G(@MSGROOT@(CNT,0)) - . I SEGTYPE="PID" M PID=@MSGROOT@(CNT),QRY("PID")=PID Q - . I SEGTYPE="QPD" M QPD=@MSGROOT@(CNT),QRY("QPD")=QPD Q - . I SEGTYPE="RDF" M RDF=@MSGROOT@(CNT) Q - . I SEGTYPE="RCP" M RCP=@MSGROOT@(CNT) Q - . I SEGTYPE="RXE" S OCNT=OCNT+1 M RXE(OCNT)=@MSGROOT@(CNT) Q - . Q - ; - I '$D(PID) S ERR="PID^1^^100^AE^Missing PID segment" Q 0 - I '$D(QPD) S ERR="QPD^1^^100^AE^Missing QPD segment" Q 0 - I '$D(RCP) S ERR="RCP^1^^100^AE^Missing RCP segment" Q 0 - ; - ; Validate required fields and query parameters - ;------------------------------------------------------ - S QTAG=$G(QPD(2)) ;Query Tag - S REQID=$G(QPD(3)) ;Request ID - S REQTYPE=$G(QPD(4)) ;Request Type - S FROMDT=$G(QPD(5)) ;From Date - S TODT=$G(QPD(6)) ;To Date - S PRI=$G(RCP(1)) ;Query Priority - S QTY=$G(RCP(2,1,1)) ;Quantity Limited - S UNIT=$G(RCP(2,1,2)) ;Quantity units - ; - I '$D(QPD(1)) S ERR="QPD^1^1^101^AE^Missing Message Query Name" Q 0 - M QNAME=QPD(1) ;Message Query Name - ; - I QTAG="" S ERR="QPD^1^2^101^AE^Missing Query Tag" Q 0 - ; - I REQID="" S ERR="QPD^1^3^101^AE^Missing Request ID" Q 0 - S QRY("REQID")=REQID - ; - I REQTYPE="" S ERR="QPD^1^4^101^AE^Missing Request Type" Q 0 - I '$$VALRTYPE^MHV7RU(REQTYPE,.QRY,.ERR) S ERR="QPD^1^4^"_ERR Q 0 - ; - I '$$VALIDDT^MHV7RU(.FROMDT) S ERR="QPD^1^5^102^AE^Invalid From Date" Q 0 - S QRY("FROM")=FROMDT - I '$$VALIDDT^MHV7RU(.TODT) S ERR="QPD^1^6^102^AE^Invalid To Date" Q 0 - I TODT'="",TODT0 D - . S CNT=0 - . S @MSGROOT@(SEG,CNT)=HLNODE - . F S CNT=$O(HLNODE(CNT)) Q:'CNT S @MSGROOT@(SEG,CNT)=HLNODE(CNT) - Q - ; -LOADXMT(XMT) ;Set HL dependent XMT values - ; - ; The HL array and variables are expected to be defined. If not, - ; message processing will fail. These references should not be - ; wrapped in $G, as null values will simply postpone the failure to - ; a point that will be harder to diagnose. Except HL("APAT") which - ; is not defined on synchronous calls. - ; Also assumes MHV RESPONSE MAP file is setup for every protocol - ; pair defined by MHV package. - ; - ; Integration Agreements: - ; 1373 : Reference to PROTOCOL file #101 - ; - N SUBPROT,RESPIEN,RESP0 - S XMT("MID")=HL("MID") ;Message ID - S XMT("MODE")="A" ;Response mode - I $G(HL("APAT"))="" S XMT("MODE")="S" ;Synchronous mode - S XMT("HLMTIENS")=HLMTIENS ;Message IEN - S XMT("MESSAGE TYPE")=HL("MTN") ;Message type - S XMT("EVENT TYPE")=HL("ETN") ;Event type - S XMT("DELIM")=HL("FS")_HL("ECH") ;HL Delimiters - S XMT("MAX SIZE")=0 ;Default size unlimited - ; - ; Map response protocol and builder - S SUBPROT=$P(^ORD(101,HL("EIDS"),0),"^") - S RESPIEN=$O(^MHV(2275.4,"B",SUBPROT,0)) - S RESP0=$G(^MHV(2275.4,RESPIEN,0)) - S XMT("PROTOCOL")=$P(RESP0,"^",2) ;Response Protocol - S XMT("BUILDER")=$TR($P(RESP0,"^",3),"~","^") ;Response Builder - S XMT("BREAK SEGMENT")=$P(RESP0,"^",4) ;Boundary Segment - Q - ; -DELIM(PROTOCOL) ;Return string of message delimiters based on Protocol - ; - ; Integration Agreements: - ; 2161 : INIT^HLFNC2 - ; - N HL - Q:PROTOCOL="" "" - D INIT^HLFNC2(PROTOCOL,.HL) - Q $G(HL("FS"))_$G(HL("ECH")) - ; -PARSEMSG(MSGROOT,HL) ; Message Parser - ; Does not handle segments that span nodes - ; Does not handle extremely long segments (uses a local) - ; Does not handle long fields (segment parser doesn't) - ; - N SEG,CNT,DATA,MSG - F CNT=1:1 Q:'$D(@MSGROOT@(CNT)) M SEG=@MSGROOT@(CNT) D - . D PARSESEG(SEG(0),.DATA,.HL) - . K @MSGROOT@(CNT) - . I DATA(0)'="" M @MSGROOT@(CNT)=DATA - . Q:'$D(SEG(1)) - . ;Add handler for segments that span nodes here. - . Q - Q - ; -PARSESEG(SEG,DATA,HL) ;Generic segment parser - ;This procedure parses a single HL7 segment and builds an array - ;subscripted by the field number containing the data for that field. - ; Does not handle segments that span nodes - ; - ; Input: - ; SEG - HL7 segment to parse - ; HL - HL7 environment array - ; - ; Output: - ; Function value - field data array [SUB1:field, SUB2:repetition, - ; SUB3:component, SUB4:sub-component] - ; - N CMP ;component subscript - N CMPVAL ;component value - N FLD ;field subscript - N FLDVAL ;field value - N REP ;repetition subscript - N REPVAL ;repetition value - N SUB ;sub-component subscript - N SUBVAL ;sub-component value - N FS ;field separator - N CS ;component separator - N RS ;repetition separator - N SS ;sub-component separator - ; - K DATA - S FS=HL("FS") - S CS=$E(HL("ECH")) - S RS=$E(HL("ECH"),2) - S SS=$E(HL("ECH"),4) - ; - S DATA(0)=$P(SEG,FS) - S SEG=$P(SEG,FS,2,9999) - F FLD=1:1:$L(SEG,FS) D - . S FLDVAL=$P(SEG,FS,FLD) - . F REP=1:1:$L(FLDVAL,RS) D - . . S REPVAL=$P(FLDVAL,RS,REP) - . . I REPVAL[CS F CMP=1:1:$L(REPVAL,CS) D - . . . S CMPVAL=$P(REPVAL,CS,CMP) - . . . I CMPVAL[SS F SUB=1:1:$L(CMPVAL,SS) D - . . . . S SUBVAL=$P(CMPVAL,SS,SUB) - . . . . I SUBVAL'="" S DATA(FLD,REP,CMP,SUB)=SUBVAL - . . . I '$D(DATA(FLD,REP,CMP)),CMPVAL'="" S DATA(FLD,REP,CMP)=CMPVAL - . . I '$D(DATA(FLD,REP)),REPVAL'="",FLDVAL[RS S DATA(FLD,REP)=REPVAL - . I '$D(DATA(FLD)),FLDVAL'="" S DATA(FLD)=FLDVAL - Q - ; -BLDSEG(DATA,HL) ;generic segment builder - ; - ; Input: - ; DATA - field data array [SUB1:field, SUB2:repetition, - ; SUB3:component, SUB4:sub-component] - ; HL - HL7 environment array - ; - ; Output: - ; Function Value - Formatted HL7 segment on success, "" on failure - ; - N CMP ;component subscript - N CMPVAL ;component value - N FLD ;field subscript - N FLDVAL ;field value - N REP ;repetition subscript - N REPVAL ;repetition value - N SUB ;sub-component subscript - N SUBVAL ;sub-component value - N FS ;field separator - N CS ;component separator - N RS ;repetition separator - N ES ;escape character - N SS ;sub-component separator - N SEG,SEP - ; - S FS=HL("FS") - S CS=$E(HL("ECH")) - S RS=$E(HL("ECH"),2) - S ES=$E(HL("ECH"),3) - S SS=$E(HL("ECH"),4) - ; - S SEG=$G(DATA(0)) - F FLD=1:1:$O(DATA(""),-1) D - . S FLDVAL=$G(DATA(FLD)),SEP=FS - . S SEG=SEG_SEP_FLDVAL - . F REP=1:1:$O(DATA(FLD,""),-1) D - . . S REPVAL=$G(DATA(FLD,REP)) - . . S SEP=$S(REP=1:"",1:RS) - . . S SEG=SEG_SEP_REPVAL - . . F CMP=1:1:$O(DATA(FLD,REP,""),-1) D - . . . S CMPVAL=$G(DATA(FLD,REP,CMP)) - . . . S SEP=$S(CMP=1:"",1:CS) - . . . S SEG=SEG_SEP_CMPVAL - . . . F SUB=1:1:$O(DATA(FLD,REP,CMP,""),-1) D - . . . . S SUBVAL=$G(DATA(FLD,REP,CMP,SUB)) - . . . . S SEP=$S(SUB=1:"",1:SS) - . . . . S SEG=SEG_SEP_SUBVAL - Q SEG - ; -BLDWP(WP,SEG,MAXLEN,FORMAT,FMTLEN,HL) ; - ;Builds segment nodes to add word processing fields to a segment - N CNT,LINE,LAST,FS,RS,LENGTH,I - I MAXLEN<1 S MAXLEN=99999999999999999 - S FS=HL("FS") ;field separator - S RS=$E(HL("ECH"),2) ;repeat separator - S CNT=$O(SEG(""),-1)+1 - S SEG(CNT)=FS - S FMTLEN=0 - S LENGTH=0 - ; - S I=0 - F S I=$O(WP(I)) Q:'I D Q:LENGTH'0 D + . S CNT=0 + . S @MSGROOT@(SEG,CNT)=HLNODE + . F S CNT=$O(HLNODE(CNT)) Q:'CNT S @MSGROOT@(SEG,CNT)=HLNODE(CNT) + Q + ; +PARSEMSG(MSGROOT,HL) ; Message Parser + ; Does not handle segments that span nodes + ; Does not handle extremely long segments (uses a local) + ; Does not handle long fields (segment parser doesn't) + ; + N SEG,CNT,DATA,MSG + F CNT=1:1 Q:'$D(@MSGROOT@(CNT)) M SEG=@MSGROOT@(CNT) D + . D PARSESEG(SEG(0),.DATA,.HL) + . K @MSGROOT@(CNT) + . I DATA(0)'="" M @MSGROOT@(CNT)=DATA + . Q:'$D(SEG(1)) + . ;Add handler for segments that span nodes here. + . Q + Q + ; +LOG(NAME,DATA,TYPE,NEW) ;Log to MHV application log + ; + ; Input: + ; NAME - Name to identify log line + ; DATA - Value,Tree, or Name of structure to put in log + ; TYPE - Type of log entry + ; S:Set Single Value + ; M:Merge Tree + ; I:Indirect Merge @ + ; NEW - Flag to create new log entry + ; + ; Output: + ; Updates log + ; + ; ^XTMP("MHV7LOG",0) - Head of log file + ; ^XTMP("MHV7LOG",1) - if set indicates that logging is on + ; ^XTMP("MHV7LOG",2) - contains the log + ; ^XTMP("MHV7LOG",2,negated FM timestamp,$J,counter,NAME) - log entry + ; + ; ^TMP("MHV7LOG",$J) - Session current log entry (DTM) + ; + ;Quit if logging is not turned on + Q:'$G(^XTMP("MHV7LOG",1)) + N DTM,CNT + ; + Q:'$D(DATA) + Q:$G(TYPE)="" + Q:$G(NAME)="" + S NAME=$TR(NAME,"^","-") + ; + ; Check ^TMP("MHV7LOG",$J) If no current log node start a new node + I '$G(^TMP("MHV7LOG",$J)) S NEW=1 + ; + I $G(NEW) D + . S DTM=-$$NOW^XLFDT() + . K ^XTMP("MHV7LOG",2,DTM,$J) + . S ^TMP("MHV7LOG",$J)=DTM + . S CNT=1 + . S ^XTMP("MHV7LOG",2,DTM,$J)=CNT + . D AUTOPRG + . Q + E D + . S DTM=^TMP("MHV7LOG",$J) + . S CNT=$G(^XTMP("MHV7LOG",2,DTM,$J))+1 + . S ^XTMP("MHV7LOG",2,DTM,$J)=CNT + . Q + ; + I TYPE="S" S ^XTMP("MHV7LOG",2,DTM,$J,CNT,NAME)=DATA Q + I TYPE="M" M ^XTMP("MHV7LOG",2,DTM,$J,CNT,NAME)=DATA Q + I TYPE="I" M ^XTMP("MHV7LOG",2,DTM,$J,CNT,NAME)=@DATA Q + ; + Q + ; +AUTOPRG ; + Q:'$G(^XTMP("MHV7LOG",1,"AUTOPURGE")) + N DT,DAYS,RESULT + ; Purge only once per day + S DT=$$DT^XLFDT + Q:$G(^XTMP("MHV7LOG",1,"AUTOPURGE","PURGE DATE"))=DT + ; + S DAYS=$G(^XTMP("MHV7LOG",1,"AUTOPURGE","DAYS")) + I DAYS<1 S DAYS=7 + ;*** Consider tasking the purge + D LOGPRG^MHVUL1(.RESULT,$$HTFM^XLFDT($H-DAYS,1)) + S ^XTMP("MHV7LOG",1,"AUTOPURGE","PURGE DATE")=DT + Q + ; +TRIMSPC(STR) ;Trim leading and trailing spaces from a text string + ; + ; Input: + ; STR - Text string + ; + ; Output: + ; Function Value - Input text string with leading and trailing + ; spaces removed + ; + N SPACE,POS,LEN + S SPACE=$C(32) + S LEN=$L(STR) + S POS=1 + F Q:$E(STR,POS)'=SPACE!(POS>LEN) S POS=POS+1 + S STR=$E(STR,POS,LEN) + S POS=$L(STR) + F Q:$E(STR,POS)'=SPACE!(POS<1) S POS=POS-1 + S STR=$E(STR,1,POS) + Q STR + ; +PARSESEG(SEG,DATA,HL) ;Generic segment parser + ;This procedure parses a single HL7 segment and builds an array + ;subscripted by the field number containing the data for that field. + ; Does not handle segments that span nodes + ; + ; Input: + ; SEG - HL7 segment to parse + ; HL - HL7 environment array + ; + ; Output: + ; Function value - field data array [SUB1:field, SUB2:repetition, + ; SUB3:component, SUB4:sub-component] + ; + N CMP ;component subscript + N CMPVAL ;component value + N FLD ;field subscript + N FLDVAL ;field value + N REP ;repetition subscript + N REPVAL ;repetition value + N SUB ;sub-component subscript + N SUBVAL ;sub-component value + N FS ;field separator + N CS ;component separator + N RS ;repetition separator + N SS ;sub-component separator + ; + K DATA + S FS=HL("FS") + S CS=$E(HL("ECH")) + S RS=$E(HL("ECH"),2) + S SS=$E(HL("ECH"),4) + ; + S DATA(0)=$P(SEG,FS) + S SEG=$P(SEG,FS,2,9999) + F FLD=1:1:$L(SEG,FS) D + . S FLDVAL=$P(SEG,FS,FLD) + . F REP=1:1:$L(FLDVAL,RS) D + . . S REPVAL=$P(FLDVAL,RS,REP) + . . I REPVAL[CS F CMP=1:1:$L(REPVAL,CS) D + . . . S CMPVAL=$P(REPVAL,CS,CMP) + . . . I CMPVAL[SS F SUB=1:1:$L(CMPVAL,SS) D + . . . . S SUBVAL=$P(CMPVAL,SS,SUB) + . . . . I SUBVAL'="" S DATA(FLD,REP,CMP,SUB)=SUBVAL + . . . I '$D(DATA(FLD,REP,CMP)),CMPVAL'="" S DATA(FLD,REP,CMP)=CMPVAL + . . I '$D(DATA(FLD,REP)),REPVAL'="",FLDVAL[RS S DATA(FLD,REP)=REPVAL + . I '$D(DATA(FLD)),FLDVAL'="" S DATA(FLD)=FLDVAL + Q + ; +BLDSEG(DATA,HL) ;generic segment builder + ; + ; Input: + ; DATA - field data array [SUB1:field, SUB2:repetition, + ; SUB3:component, SUB4:sub-component] + ; HL - HL7 environment array + ; + ; Output: + ; Function Value - Formatted HL7 segment on success, "" on failure + ; + N CMP ;component subscript + N CMPVAL ;component value + N FLD ;field subscript + N FLDVAL ;field value + N REP ;repetition subscript + N REPVAL ;repetition value + N SUB ;sub-component subscript + N SUBVAL ;sub-component value + N FS ;field separator + N CS ;component separator + N RS ;repetition separator + N ES ;escape character + N SS ;sub-component separator + N SEG,SEP + ; + S FS=HL("FS") + S CS=$E(HL("ECH")) + S RS=$E(HL("ECH"),2) + S ES=$E(HL("ECH"),3) + S SS=$E(HL("ECH"),4) + ; + S SEG=$G(DATA(0)) + F FLD=1:1:$O(DATA(""),-1) D + . S FLDVAL=$G(DATA(FLD)),SEP=FS + . S SEG=SEG_SEP_FLDVAL + . F REP=1:1:$O(DATA(FLD,""),-1) D + . . S REPVAL=$G(DATA(FLD,REP)) + . . S SEP=$S(REP=1:"",1:RS) + . . S SEG=SEG_SEP_REPVAL + . . F CMP=1:1:$O(DATA(FLD,REP,""),-1) D + . . . S CMPVAL=$G(DATA(FLD,REP,CMP)) + . . . S SEP=$S(CMP=1:"",1:CS) + . . . S SEG=SEG_SEP_CMPVAL + . . . F SUB=1:1:$O(DATA(FLD,REP,CMP,""),-1) D + . . . . S SUBVAL=$G(DATA(FLD,REP,CMP,SUB)) + . . . . S SEP=$S(SUB=1:"",1:SS) + . . . . S SEG=SEG_SEP_SUBVAL + Q SEG + ; +BLDWPSEG(WP,SEG,MAXLEN,HL) ; + ;Builds segment nodes to add word processing fields to a segment + N CNT,LINE,LAST,FS,RS,LENGTH + I MAXLEN<1 S MAXLEN=999999999999 + S FS=HL("FS") ;field separator + S RS=$E(HL("ECH"),2) ;repeat separator + S CNT=$O(SEG(""),-1)+1 + S LINE=$O(WP(0)) + S LENGTH=$L(LINE) + S SEG(CNT)="" + S SEG(CNT)=FS_$$ESCAPE($G(WP(LINE,0)),.HL) + F S LINE=$O(WP(LINE)) Q:LINE="" D Q:LENGTH'$G(^XTMP("MHV7LOG",1,"LEVEL",LOGLEVEL)) Q:LOGLEVEL'="NAMED" Q:'$D(^XTMP("MHV7LOG",1,"NAMES",NAME)) - ; - ; Check ^TMP("MHV7LOG",$J) If no current log node start a new node - I '$G(^TMP("MHV7LOG",$J)) D - . S DTM=-$$NOW^XLFDT() - . K ^XTMP("MHV7LOG",2,DTM,$J) - . S ^TMP("MHV7LOG",$J)=DTM - . S CNT=1 - . S ^XTMP("MHV7LOG",2,DTM,$J)=CNT - . D AUTOPRG - . Q - E D - . S DTM=^TMP("MHV7LOG",$J) - . S CNT=$G(^XTMP("MHV7LOG",2,DTM,$J))+1 - . S ^XTMP("MHV7LOG",2,DTM,$J)=CNT - . Q - ; - I TYPE="S" S ^XTMP("MHV7LOG",2,DTM,$J,CNT,NAME)=DATA Q - I TYPE="M" M ^XTMP("MHV7LOG",2,DTM,$J,CNT,NAME)=DATA Q - I TYPE="I" M ^XTMP("MHV7LOG",2,DTM,$J,CNT,NAME)=@DATA Q - ; - Q - ; -RESET ; Initialize or clear session pointer into log - K ^TMP("MHV7LOG",$J) - Q - ; -AUTOPRG ; - Q:'$G(^XTMP("MHV7LOG",1,"AUTOPURGE")) - N DT,DAYS,RESULT - ; Purge only once per day - S DT=$$DT^XLFDT - Q:$G(^XTMP("MHV7LOG",1,"AUTOPURGE","PURGE DATE"))=DT - ; - S DAYS=$G(^XTMP("MHV7LOG",1,"AUTOPURGE","DAYS")) - I DAYS<1 S DAYS=7 - ; - D LOGPRG^MHVUL1(.RESULT,$$HTFM^XLFDT($H-DAYS,1)) - S ^XTMP("MHV7LOG",1,"AUTOPURGE","PURGE DATE")=DT - Q - ; -LOGBROWS ; Browser view of Log - N LOG,CNT,DTM,JOB,NUM,NAME,DIR,DIRUT,X,Y - K ^TMP("MHV LOG SUMMARY",$J) - K ^TMP("MHV LOG DETAIL",$J) - K ^TMP("MHV LOG BROWSE",$J) - K ^TMP("MHV LOG BROWSE DETAIL",$J) - D LOGSUM^MHVUL1(.LOG) - S CNT=$P(@LOG,"^",2) - I CNT<1 D Q - . W !!,?12,"LOG IS EMPTY" - . K DIR,DIRUT,X,Y - . S DIR(0)="E" - . D ^DIR - . Q - F I=1:1:CNT D - . S DTM=$P(@LOG@(I),"^") - . S JOB=$P(@LOG@(I),"^",2) - . S NUM=$P(@LOG@(I),"^",3) - . S NAME=$E($P(@LOG@(I),"^",4)_$J("",20),1,20) - . S ^TMP("MHV LOG BROWSE",$J,I)="$.%$CREF$^TMP(""MHV LOG BROWSE DETAIL"",$J,"_I_")$CREF$^"_NAME_"$.%"_$J($$FMTE^XLFDT(-DTM),22)_$J(JOB,13)_" "_NUM - . S ^TMP("MHV LOG BROWSE DETAIL",$J,I)="$XC$^D LOGBDET^MHVUL2("_I_","_DTM_","_JOB_")$XC$^"_NAME_" "_$$FMTE^XLFDT(-DTM)_" "_JOB - . Q - D LOGBTITL - S TITLE="Log Entry Timestamp Job Number Items" - D BROWSE^DDBR("^TMP(""MHV LOG BROWSE"",$J)","NA",TITLE_$J("",80-$L(TITLE)),"","",3,24) - K ^TMP("MHV LOG SUMMARY",$J) - K ^TMP("MHV LOG DETAIL",$J) - K ^TMP("MHV LOG BROWSE",$J) - K ^TMP("MHV LOG BROWSE DETAIL",$J) - Q - ; -LOGBTITL ; Build Titles for Browser - N TITLE,INFO,TLOG,TPRG,TAUT,TLEN - D LOGINFO^MHVUL1(.INFO) - S TLOG="Logging: "_$S(INFO("STATE"):"",1:"OFF") - I INFO("STATE") S TLOG=TLOG_INFO("LEVEL") - S TAUT="Auto Purge: "_$S(INFO("AUTOPURGE"):"",1:"OFF") - I INFO("AUTOPURGE") S TAUT=TAUT_+INFO("DAYS")_" days" - S TPRG="Delete: "_$$FMTE^XLFDT(INFO("DELETE")) - ; - S TITLE="MHV APPLICATION LOG" - S TLEN=$L(TITLE) - W @IOF,$J(TITLE,TLEN\2+40)_$J(TPRG,40-(TLEN\2)) - S TITLE=$J(TLOG_" ",15)_$J(TAUT,63) - W !,TITLE - Q - ; -LOGBDET(NODE,DTM,JOB) ; Build document from entry for Browser - N I,CNT,LINE,ENTRY - D LOGDET^MHVUL1(.ENTRY,DTM,JOB) - S I=0 - S CNT=0 - F S I=$O(@ENTRY@(I)) Q:I="" D - . S LINE=@ENTRY@(I) - . S CNT=CNT+1 - . S ^TMP("MHV LOG BROWSE DETAIL",$J,NODE,CNT)=$E(LINE,1,80) - . S LINE=$E(LINE,81,999999) - . F Q:LINE="" D - .. S CNT=CNT+1 - .. S ^TMP("MHV LOG BROWSE DETAIL",$J,NODE,CNT)=$J("",9)_$E(LINE,1,71) - .. S LINE=$E(LINE,72,999999) - .. Q - . Q - Q - ; +MHVUL2 ;WAS/GPM - MHV UTILITIES - LOGGING ; 3/2/06 5:38pm [4/19/06 2:30pm] + ;;1.0;My HealtheVet;**1**;Aug 23, 2005 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; + Q + ; +LOG(NAME,DATA,TYPE,LEVEL) ;Log to MHV application log + ; + ; Input: + ; NAME - Name to identify log entry + ; DATA - Value,Tree, or Name of structure to put in log + ; TYPE - Type of log entry + ; S:Set Single Value + ; M:Merge Tree + ; I:Indirect Merge @ + ; LEVEL - Level of log entry - ERROR,TRACE,NAMED,DEBUG + ; + ; Output: + ; Adds entry to log + ; + ; ^XTMP("MHV7LOG",0) - Head of log file + ; ^XTMP("MHV7LOG",1) - if set indicates that logging is on + ; ^XTMP("MHV7LOG",1,"LEVEL") - logging level + ; ^XTMP("MHV7LOG",1,"LEVEL",LEVEL) = rank + ; ^XTMP("MHV7LOG",1,"NAMES",) - names to log caret delimited string + ; ^XTMP("MHV7LOG",1,"NAMES",NAME) - name to log + ; ^XTMP("MHV7LOG",2) - contains the log + ; ^XTMP("MHV7LOG",2,negated FM timestamp,$J,counter,NAME) - log entry + ; + ; ^TMP("MHV7LOG",$J) - Session current log entry (DTM) + ; + ;Quit if logging is not turned on + Q:'$G(^XTMP("MHV7LOG",1)) + N DTM,CNT,LOGLEVEL + ; + Q:'$D(DATA) + Q:$G(TYPE)="" + Q:$G(NAME)="" + S NAME=$TR(NAME,"^","-") + ; + ;If LEVEL is null or unknown default to DEBUG + I $G(LEVEL)="" S LEVEL="DEBUG" + I '$D(^XTMP("MHV7LOG",1,"LEVEL",LEVEL)) S LEVEL="DEBUG" + ; + ;Log entries at or lower than the current logging level set + ;Levels are ranked as follows: + ; ^XTMP("MHV7LOG",1,"LEVEL","ERROR")=1 + ; ^XTMP("MHV7LOG",1,"LEVEL","TRACE")=2 + ; ^XTMP("MHV7LOG",1,"LEVEL","NAMED")=3 + ; ^XTMP("MHV7LOG",1,"LEVEL","DEBUG")=4 + ;Named is like a filtered version of debug. + ;Additional levels may be added, and ranks changed without affecting + ;the LOG api. Inserting a level between Named and Debug will require + ;a change to the conditional below. + S LOGLEVEL=$G(^XTMP("MHV7LOG",1,"LEVEL")) + I LOGLEVEL="" S LOGLEVEL="TRACE" + I $G(^XTMP("MHV7LOG",1,"LEVEL",LEVEL))>$G(^XTMP("MHV7LOG",1,"LEVEL",LOGLEVEL)) Q:LOGLEVEL'="NAMED" Q:'$D(^XTMP("MHV7LOG",1,"NAMES",NAME)) + ; + ; Check ^TMP("MHV7LOG",$J) If no current log node start a new node + I '$G(^TMP("MHV7LOG",$J)) D + . S DTM=-$$NOW^XLFDT() + . K ^XTMP("MHV7LOG",2,DTM,$J) + . S ^TMP("MHV7LOG",$J)=DTM + . S CNT=1 + . S ^XTMP("MHV7LOG",2,DTM,$J)=CNT + . D AUTOPRG + . Q + E D + . S DTM=^TMP("MHV7LOG",$J) + . S CNT=$G(^XTMP("MHV7LOG",2,DTM,$J))+1 + . S ^XTMP("MHV7LOG",2,DTM,$J)=CNT + . Q + ; + I TYPE="S" S ^XTMP("MHV7LOG",2,DTM,$J,CNT,NAME)=DATA Q + I TYPE="M" M ^XTMP("MHV7LOG",2,DTM,$J,CNT,NAME)=DATA Q + I TYPE="I" M ^XTMP("MHV7LOG",2,DTM,$J,CNT,NAME)=@DATA Q + ; + Q + ; +AUTOPRG ; + Q:'$G(^XTMP("MHV7LOG",1,"AUTOPURGE")) + N DT,DAYS,RESULT + ; Purge only once per day + S DT=$$DT^XLFDT + Q:$G(^XTMP("MHV7LOG",1,"AUTOPURGE","PURGE DATE"))=DT + ; + S DAYS=$G(^XTMP("MHV7LOG",1,"AUTOPURGE","DAYS")) + I DAYS<1 S DAYS=7 + ; + D LOGPRG^MHVUL1(.RESULT,$$HTFM^XLFDT($H-DAYS,1)) + S ^XTMP("MHV7LOG",1,"AUTOPURGE","PURGE DATE")=DT + Q + ; +LOGBROWS ; Browser view of Log + N LOG,CNT,DTM,JOB,NUM,NAME,DIR,DIRUT,X,Y + K ^TMP("MHV LOG SUMMARY",$J) + K ^TMP("MHV LOG DETAIL",$J) + K ^TMP("MHV LOG BROWSE",$J) + K ^TMP("MHV LOG BROWSE DETAIL",$J) + D LOGSUM^MHVUL1(.LOG) + S CNT=$P(@LOG,"^",2) + I CNT<1 D Q + . W !!,?12,"LOG IS EMPTY" + . K DIR,DIRUT,X,Y + . S DIR(0)="E" + . D ^DIR + . Q + F I=1:1:CNT D + . S DTM=$P(@LOG@(I),"^") + . S JOB=$P(@LOG@(I),"^",2) + . S NUM=$P(@LOG@(I),"^",3) + . S NAME=$E($P(@LOG@(I),"^",4)_$J("",20),1,20) + . S ^TMP("MHV LOG BROWSE",$J,I)="$.%$CREF$^TMP(""MHV LOG BROWSE DETAIL"",$J,"_I_")$CREF$^"_NAME_"$.%"_$J($$FMTE^XLFDT(-DTM),22)_$J(JOB,13)_" "_NUM + . S ^TMP("MHV LOG BROWSE DETAIL",$J,I)="$XC$^D LOGBDET^MHVUL2("_I_","_DTM_","_JOB_")$XC$^"_NAME_" "_$$FMTE^XLFDT(-DTM)_" "_JOB + . Q + D LOGBTITL + S TITLE="Log Entry Timestamp Job Number Items" + D BROWSE^DDBR("^TMP(""MHV LOG BROWSE"",$J)","NA",TITLE_$J("",80-$L(TITLE)),"","",3,24) + K ^TMP("MHV LOG SUMMARY",$J) + K ^TMP("MHV LOG DETAIL",$J) + K ^TMP("MHV LOG BROWSE",$J) + K ^TMP("MHV LOG BROWSE DETAIL",$J) + Q + ; +LOGBTITL ; Build Titles for Browser + N TITLE,INFO,TLOG,TPRG,TAUT,TLEN + D LOGINFO^MHVUL1(.INFO) + S TLOG="Logging: "_$S(INFO("STATE"):"",1:"OFF") + I INFO("STATE") S TLOG=TLOG_INFO("LEVEL") + S TAUT="Auto Purge: "_$S(INFO("AUTOPURGE"):"",1:"OFF") + I INFO("AUTOPURGE") S TAUT=TAUT_+INFO("DAYS")_" days" + S TPRG="Delete: "_$$FMTE^XLFDT(INFO("DELETE")) + ; + S TITLE="MHV APPLICATION LOG" + S TLEN=$L(TITLE) + W @IOF,$J(TITLE,TLEN\2+40)_$J(TPRG,40-(TLEN\2)) + S TITLE=$J(TLOG_" ",15)_$J(TAUT,63) + W !,TITLE + Q + ; +LOGBDET(NODE,DTM,JOB) ; Build document from entry for Browser + N I,CNT,LINE,ENTRY + D LOGDET^MHVUL1(.ENTRY,DTM,JOB) + S I=0 + S CNT=0 + F S I=$O(@ENTRY@(I)) Q:I="" D + . S LINE=@ENTRY@(I) + . S CNT=CNT+1 + . S ^TMP("MHV LOG BROWSE DETAIL",$J,NODE,CNT)=$E(LINE,1,80) + . S LINE=$E(LINE,81,999999) + . F Q:LINE="" D + .. S CNT=CNT+1 + .. S ^TMP("MHV LOG BROWSE DETAIL",$J,NODE,CNT)=$J("",9)_$E(LINE,1,71) + .. S LINE=$E(LINE,72,999999) + .. Q + . Q + Q + ; diff --git a/r/MY_HEALTHEVET-MHV/MHVXRX.m b/r/MY_HEALTHEVET-MHV/MHVXRX.m index d0da44b9..0ea8b153 100644 --- a/r/MY_HEALTHEVET-MHV/MHVXRX.m +++ b/r/MY_HEALTHEVET-MHV/MHVXRX.m @@ -1,113 +1,115 @@ -MHVXRX ;WAS/GPM - Prescription extract ; [12/14/06 11:38am] - ;;1.0;My HealtheVet;**2**;Aug 23, 2005;Build 22 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - Q - ; -PROFILE(QRY,ERR,DATAROOT) ; Entry point to get prescription profile - ; Retrieves requested prescription data and returns it in DATAROOT - ; Retrieves all prescriptions with an active status - ; - ; Integration Agreements: - ; 3768 : AP2^PSOPRA,AP5^PSOPRA - ; 4687 : EN^PSOMHV1 - ; - ; Input: - ; QRY - Query array - ; QRY(DFN) - (required) Pointer to PATIENT (#2) file - ; DATAROOT - Root of array to hold extract data - ; - ; Output: - ; DATAROOT - Populated data array, includes # of hits - ; ERR - Errors during extraction - ; - N U,DT,HIT,DFN,FROM,TO,STA,DRUG,DIV,MHVSTAT,RXN,MHVDATE,INDEX - ; - D LOG^MHVUL2("MHVXRX PROFILE","BEGIN","S","TRACE") - S U="^",DT=$$DT^XLFDT - S ERR=0,HIT=0 - K @DATAROOT - K ^TMP("PSO",$J) - S DFN=$G(QRY("DFN")) - S FROM=DT - S TO="" - ; - D EN^PSOMHV1(DFN,FROM,TO) - ; - S STA="",INDEX="" - F STA="ACT","SUS" F S INDEX=$O(^TMP("PSO",$J,STA,INDEX)) Q:INDEX="" D SET - ; - K ^TMP("PSO",$J) - S @DATAROOT=HIT - D LOG^MHVUL2("MHVXRX PROFILE",HIT_" HITS","S","TRACE") - D LOG^MHVUL2("MHVXRX PROFILE","END","S","TRACE") - Q - ; -EXTRACT(QRY,ERR,DATAROOT) ; Entry point to extract prescription data - ; Retrieves requested prescription data and returns it in DATAROOT - ; Retrieves all prescriptions of all statuses in given date range - ; Statuses of deleted are filtered by the pharmacy API. - ; - ; Integration Agreements: - ; 3768 : AP2^PSOPRA,AP5^PSOPRA - ; 4687 : EN3^PSOMHV1 - ; - ; Input: - ; QRY - Query array - ; QRY(DFN) - (required) Pointer to PATIENT (#2) file - ; QRY(FROM) - Date to start from - ; QRY(TO) - Date to go to - ; DATAROOT - Root of array to hold extract data - ; - ; Output: - ; DATAROOT - Populated data array, includes # of hits - ; ERR - Errors during extraction - ; - N U,DT,HIT,DFN,FROM,TO,STA,DRUG,DIV,MHVSTAT,RXN,MHVDATE,INDEX - ; - D LOG^MHVUL2("MHVXRX EXTRACT","BEGIN","S","TRACE") - S U="^",DT=$$DT^XLFDT - S ERR=0,HIT=0 - K @DATAROOT - K ^TMP("PS",$J) - S DFN=$G(QRY("DFN")) - S FROM=$G(QRY("FROM")) - S TO=$G(QRY("TO")) - ; - I FROM="" S FROM=2000101 ;01/01/1900 - ; - ; The EN3^PSOMHV1 call uses RX IEN instead of DRUG as a - ; subscript in ^TMP("PSO",$J). This was a late breaking change to - ; PSOMHV1 to support historical extracts. - D EN3^PSOMHV1(DFN,FROM,TO) - ; - S STA="",INDEX="" - F S STA=$O(^TMP("PSO",$J,STA)) Q:STA="" I STA'="PEN" F S INDEX=$O(^TMP("PSO",$J,STA,INDEX)) Q:INDEX="" D SET - ; - K ^TMP("PSO",$J) - S @DATAROOT=HIT - D LOG^MHVUL2("MHVXRX EXTRACT",HIT_" HITS","S","TRACE") - D LOG^MHVUL2("MHVXRX EXTRACT","END","S","TRACE") - Q - ; -SET ; - ;INDEX will be RXIEN if called from EXTRACT - ;INDEX will be drug name if called from PROFILE - S RXN=$P($G(^TMP("PSO",$J,STA,INDEX,"RXN",0)),"^") - I RXN="" Q - I $D(QRY("RXLIST")) Q:'$D(QRY("RXLIST",RXN)) - S MHVSTAT=$$AP2^PSOPRA(DFN,RXN) - S MHVDATE=$P(MHVSTAT,"^",2) - S MHVSTAT=$P(MHVSTAT,"^",1) - I MHVSTAT>0 I $$AP5^PSOPRA(DFN,RXN) ;Clear RXN from queue - S DRUG=$P($G(^TMP("PSO",$J,STA,INDEX,0)),"^",1) ;Drug Name - S HIT=HIT+1 - S @DATAROOT@(HIT)=RXN_U_DRUG_U_MHVSTAT_U_MHVDATE - S @DATAROOT@(HIT,0)=$G(^TMP("PSO",$J,STA,INDEX,0)) - S @DATAROOT@(HIT,"P")=$G(^TMP("PSO",$J,STA,INDEX,"P",0)) - S @DATAROOT@(HIT,"RXN")=$G(^TMP("PSO",$J,STA,INDEX,"RXN",0)) - S @DATAROOT@(HIT,"DIV")=$G(^TMP("PSO",$J,STA,INDEX,"DIV",0)) - I '$D(^TMP("PSO",$J,STA,INDEX,"SIG")) S @DATAROOT@(HIT,"SIG",0)=0 - E M @DATAROOT@(HIT,"SIG")=^TMP("PSO",$J,STA,INDEX,"SIG") - Q - ; +MHVXRX ;WAS/GPM - Prescription extract ; [8/23/05 12:33am] + ;;1.0;My HealtheVet;;Aug 23, 2005 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; + Q + ; +PROFILE(QRY,ERR,DATAROOT) ; Entry point to get prescription profile + ; Retrieves requested prescripton data and returns it in DATAROOT + ; Retrieves all prescriptions with an active status + ; + ; Integration Agreements: + ; 3768 : AP2^PSOPRA,AP5^PSOPRA + ; 4687 : EN^PSOMHV1 + ; + ; Input: + ; QRY - Query array + ; QRY(DFN) - (required) Pointer to PATIENT (#2) file + ; DATAROOT - Root of array to hold extract data + ; + ; Output: + ; DATAROOT - Populated data array, includes # of hits + ; ERR - Errors during extraction + ; + N U,DT,HIT,DFN,PRI,FROM,TO,STA,DRUG,DIV,MHVSTAT,RXN,MHVDATE,INDEX + ; + D LOG^MHV7U("MHVXRX Profile","BEGIN","S",0) + S U="^",DT=$$DT^XLFDT + S ERR=0,HIT=0 + K @DATAROOT + K ^TMP("PSO",$J) + S DFN=$G(QRY("DFN")) + S PRI=$G(QRY("PRI")) + S FROM=DT + S TO="" + ; + D EN^PSOMHV1(DFN,FROM,TO) + ; + S STA="",INDEX="" + F STA="ACT","SUS" F S INDEX=$O(^TMP("PSO",$J,STA,INDEX)) Q:INDEX="" D SET + ; + K ^TMP("PSO",$J) + S @DATAROOT=HIT + D LOG^MHV7U("MHVXRX Profile HITS=",HIT,"S",0) + D LOG^MHV7U("MHVXRX Profile","END","S",0) + Q + ; +EXTRACT(QRY,ERR,DATAROOT) ; Entry point to extract prescription data + ; Retrieves requested prescripton data and returns it in DATAROOT + ; Retrieves all prescriptions of all statuses in given date range + ; Statuses of deleted are filtered by the pharmacy API. + ; + ; Integration Agreements: + ; 3768 : AP2^PSOPRA,AP5^PSOPRA + ; 4687 : EN3^PSOMHV1 + ; + ; Input: + ; QRY - Query array + ; QRY(DFN) - (required) Pointer to PATIENT (#2) file + ; QRY(FROM) - Date to start from + ; QRY(TO) - Date to go to + ; DATAROOT - Root of array to hold extract data + ; + ; Output: + ; DATAROOT - Populated data array, includes # of hits + ; ERR - Errors during extraction + ; + N U,DT,HIT,DFN,PRI,FROM,TO,STA,DRUG,DIV,MHVSTAT,RXN,MHVDATE,INDEX + ; + D LOG^MHV7U("MHVXRX Extract","BEGIN","S",0) + S U="^",DT=$$DT^XLFDT + S ERR=0,HIT=0 + K @DATAROOT + K ^TMP("PS",$J) + S DFN=$G(QRY("DFN")) + S PRI=$G(QRY("PRI")) + S FROM=$G(QRY("FROM")) + S TO=$G(QRY("TO")) + ; + I FROM="" S FROM=2000101 ;01/01/1900 + ; + ; The EN3^PSOMHV1 call uses RX IEN instead of DRUG as a + ; subscript in ^TMP("PSO",$J). This was a late breaking change to + ; PSOMHV1 to support historical extracts. + D EN3^PSOMHV1(DFN,FROM,TO) + ; + S STA="",INDEX="" + F S STA=$O(^TMP("PSO",$J,STA)) Q:STA="" I STA'="PEN" F S INDEX=$O(^TMP("PSO",$J,STA,INDEX)) Q:INDEX="" D SET + ; + K ^TMP("PSO",$J) + S @DATAROOT=HIT + D LOG^MHV7U("MHVXRX Extract HITS=",HIT,"S",0) + D LOG^MHV7U("MHVXRX Extract","END","S",0) + Q + ; +SET ; + ;INDEX will be RXIEN if called from EXTRACT + ;INDEX will be drug name if called from PROFILE + S RXN=$P($G(^TMP("PSO",$J,STA,INDEX,"RXN",0)),"^") + I RXN="" Q + I $D(QRY("RXLIST")) Q:'$D(QRY("RXLIST",RXN)) + S MHVSTAT=$$AP2^PSOPRA(DFN,RXN) + S MHVDATE=$P(MHVSTAT,"^",2) + S MHVSTAT=$P(MHVSTAT,"^",1) + I MHVSTAT>0 I $$AP5^PSOPRA(DFN,RXN) ;Clear RXN from queue + S DRUG=$P($G(^TMP("PSO",$J,STA,INDEX,0)),"^",1) ;Drug Name + S HIT=HIT+1 + S @DATAROOT@(HIT)=RXN_U_DRUG_U_MHVSTAT_U_MHVDATE + S @DATAROOT@(HIT,0)=$G(^TMP("PSO",$J,STA,INDEX,0)) + S @DATAROOT@(HIT,"P")=$G(^TMP("PSO",$J,STA,INDEX,"P",0)) + S @DATAROOT@(HIT,"RXN")=$G(^TMP("PSO",$J,STA,INDEX,"RXN",0)) + S @DATAROOT@(HIT,"DIV")=$G(^TMP("PSO",$J,STA,INDEX,"DIV",0)) + I '$D(^TMP("PSO",$J,STA,INDEX,"SIG")) S @DATAROOT@(HIT,"SIG",0)=0 + E M @DATAROOT@(HIT,"SIG")=^TMP("PSO",$J,STA,INDEX,"SIG") + Q + ; diff --git a/r/MY_HEALTHEVET-MHV/MHVXRXR.m b/r/MY_HEALTHEVET-MHV/MHVXRXR.m index 4afb60e0..138ef2cc 100644 --- a/r/MY_HEALTHEVET-MHV/MHVXRXR.m +++ b/r/MY_HEALTHEVET-MHV/MHVXRXR.m @@ -1,44 +1,41 @@ -MHVXRXR ;WAS/GPM - Prescription refill request ; [12/12/07 11:38pm] - ;;1.0;My HealtheVet;**2**;Aug 23, 2005;Build 22 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - Q - ; -REQUEST(QRY,ERR,DATAROOT) ; Entry point to request refills - ; Walks list of prescriptions calling a pharmacy api AP1^PSOPRA to - ; add the prescription to the internet refill request queue in the - ; PRESCRIPTION REFILL REQUEST file #52.43. The status of the api - ; call is returned in DATAROOT. - ; - ; Integration Agreements: - ; 3768 : AP1^PSOPRA - ; - ; Input: - ; QRY - Query array - ; QRY(DFN) - (required) Pointer to PATIENT (#2) file - ; DATAROOT - Root of array to hold extract data - ; - ; Output: - ; DATAROOT - Populated data array, includes # of hits - ; ERR - Errors during extraction - ; - N CNT,RX,PORDERN,ORDERTM,STATUS,DIV,DFN,U - ; - D LOG^MHVUL2("MHVXRXR","BEGIN","S","TRACE") - S U="^" - S ERR=0 - K @DATAROOT - S DFN=$G(QRY("DFN")) - ; - F CNT=1:1 Q:'$D(QRY("RX",CNT)) D - . S RX=$G(QRY("RX",CNT)) - . S PORDERN=$P(RX,"^",2) - . S ORDERTM=$P(RX,"^",3) - . S RX=$P(RX,"^") - . S STATUS=$$AP1^PSOPRA(DFN,RX) - . S @DATAROOT@(CNT)=RX_U_STATUS_U_PORDERN_U_ORDERTM - . Q - ; - S @DATAROOT=CNT-1 - D LOG^MHVUL2("MHVXRXR","END","S","TRACE") - Q +MHVXRXR ;WAS/GPM - Prescription refill request ; [8/23/05 12:34am] + ;;1.0;My HealtheVet;;Aug 23, 2005 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; + Q + ; +REQUEST(QRY,ERR,DATAROOT) ; Entry point to extract appointment data + ; Retrieves requested appointment data and returns it in DATAROOT + ; + ; Integration Agreements: + ; 3768 : AP1^PSOPRA + ; + ; Input: + ; QRY - Query array + ; QRY(DFN) - (required) Pointer to PATIENT (#2) file + ; DATAROOT - Root of array to hold extract data + ; + ; Output: + ; DATAROOT - Populated data array, includes # of hits + ; ERR - Errors during extraction + ; + N CNT,RX,PORDERN,ORDERTM,STATUS,DIV,DFN,U + ; + D LOG^MHV7U("MHVXRXR","BEGIN","S",0) + S U="^" + S ERR=0 + K @DATAROOT + S DFN=$G(QRY("DFN")) + ; + F CNT=1:1 Q:'$D(QRY("RX",CNT)) D + . S RX=$G(QRY("RX",CNT)) + . S PORDERN=$P(RX,"^",2) + . S ORDERTM=$P(RX,"^",3) + . S RX=$P(RX,"^") + . S STATUS=$$AP1^PSOPRA(DFN,RX) + . S @DATAROOT@(CNT)=RX_U_STATUS_U_PORDERN_U_ORDERTM + . Q + ; + S @DATAROOT=CNT-1 + D LOG^MHV7U("MHVXRXR","END","S",0) + Q diff --git a/r/NATIONAL_DRUG_FILE-PSN/PSNACT.m b/r/NATIONAL_DRUG_FILE-PSN/PSNACT.m index cb996702..df811248 100644 --- a/r/NATIONAL_DRUG_FILE-PSN/PSNACT.m +++ b/r/NATIONAL_DRUG_FILE-PSN/PSNACT.m @@ -1,125 +1,125 @@ -PSNACT ;BIR/DMA&WRT-inquiries by VAPN, CMOP ID, or NDC ; 07/02/03 14:01 - ;;4.0; NATIONAL DRUG FILE;**22,35,47,62,65,70,160**; 30 Oct 98;Build 3 - ; - ;Reference to ^PS(50.606 supported by DBIA #2174 - ; - I '$D(IORVON) S X="IORVON;IORVOFF" D ENDR^%ZISS - K DIC,DIR F ZXX=0:0 W ! D TEXT,ASKIT Q:$D(DIRUT) - K QUIT,DIR,DIC,OLDDA,PROMPT,J,I,IEN,PPP,Y,Y1,Y3,Y5,Y6,Y7,Z0,Z1,Z3,Z5,Z6,Z7,ZA,ZXX,ASK,NDX,SIE,PSN,PSN1,MORE,SIE1,PMIS,QQQ,ENG,MAP - Q -TEXT W !,"This option allows you to lookup NDF file information three ways (VA Product",!,"Name, NDC, or CMOP ID number).",! - Q -ASKIT S DIR(0)="SA^VA:VA PRODUCT;N:NDC;C:CMOP ID",DIR("A")="LOOKUP BY (VA) PRODUCT, (N)DC, OR (C)MOP ID ? " D ^DIR G END:$D(DIRUT) S ASK=Y(0) - I ASK="NDC" D NDC - I ASK="VA PRODUCT" D LISTNDC - I ASK="CMOP ID" D CMOP - Q -ENTER K QQQ S DA=+Y,Y1=^PSNDF(50.68,DA,1),Y3=^(3),Y7=$G(^(7)),Y5=$G(^(5)),Y6=$G(^PSNDF(50.68,DA,6,1,0)),QQQ=$P(Y1,"^",5) D GCN D - .W @IOF,!,"VA Product Name: ",$P(Y(0),"^"),$$DT($P(Y7,"^",3)) - .W !,"VA Generic Name: ",$P(^PSNDF(50.6,+$P(Y(0),"^",2),0),"^"),!,"Dose Form: ",$P(^PS(50.606,+$P(Y(0),"^",3),0),"^")," Strength: ",$P(Y(0),"^",4)," Units: ",$P($G(^PS(50.607,+$P(Y(0),"^",5),0)),"^") - .W !,"National Formulary Name: ",$P(Y(0),"^",6),!,"VA Print Name: ",$P(Y1,"^"),!,"VA Product Identifier: ",$P(Y1,"^",2)," Transmit to CMOP: ",$S($P(Y1,"^",3):"Yes",1:"No") - .W " VA Dispense Unit: ",$P($G(^PSNDF(50.64,+$P(Y1,"^",4),0)),"^") - .W !,"PMIS: ",PMIS,!,"Active Ingredients: " S K=0 F S K=$O(^PSNDF(50.68,DA,2,K)) Q:'K!($G(QUIT)) S X=^(K,0),ING=^PS(50.416,K,0) S:$P(ING,"^",2) ING=^PS(50.416,$P(ING,"^",2),0) D - ..D:($Y+5)>IOSL&('$G(QUIT)) HANG Q:$G(QUIT) W ?23,$P(ING,"^")," Strength: ",$P(X,"^",2)," Units :",$P($G(^PS(50.607,+$P(X,"^",3),0)),"^"),! - .Q:$G(QUIT) W !,"Primary VA Drug Class: ",$P($G(^PS(50.605,+Y3,0),"Unknown"),"^"),!,"Secondary VA Drug Class: " S K=0 F S K=$O(^PSNDF(50.68,DA,4,K)) Q:'K W ?26,$P($G(^PS(50.605,+K,0),"Unknown"),"^"),! - .W !,"CS Federal Schedule: "_$S($P($G(^PSNDF(50.68,DA,7)),"^")]"":$P(^PSNDF(50.68,DA,7),"^"),1:"") - .W !,"National Formulary Indicator: " W:$P(Y5,"^")=1 "Yes" W:$P(Y5,"^")=0 "No" - .W !,"National Formulary Restriction: ",!,$P(Y6,"^") - .I $G(^PSNDF(50.68,DA,8)) W !,"Exclude Drg-Drg Interaction Ck: Yes (No check for Drug-Drug Interactions)" - Q - K DA,DIE,DIE,DIRUT,DR,ING,K,OLDDA,X,Y,Y1,Y3,Y7 Q - ; -NDC ;OR UPN - K PROMPT S DIR(0)="SA^N:NDC;U:UPN",DIR("A")="NDC (N) or UPN (U) ? " D ^DIR G END:$D(DIRUT) S PROMPT=Y(0) - I PROMPT="NDC" S DIR(0)="F",DIR("A")="Enter NDC with or without Dashes (-)" D ^DIR G END:$D(DIRUT) D:X["-" PAD S DIC=50.67,DIC(0)="EQZN",D=PROMPT D IX^DIC Q:Y<0 S DA=+Y,NDF=Y(0) D LKNDC - I PROMPT="UPN" S DIC=50.67,DIC(0)="AEQZN",DIC("A")="Select "_PROMPT_":"_" ",D=PROMPT D IX^DIC Q:Y<0 S DA=+Y,NDF=Y(0) D LKNDC - Q -LKNDC W @IOF,!,"NDC: ",$P(NDF,"^",2),$$DT($P(NDF,"^",7))," UPN: ",$P(NDF,"^",3),!,"VA Product Name: ",$P(^PSNDF(50.68,$P(NDF,"^",6),0),"^"),!,"Manufacturer: ",$P($G(^PS(55.95,+$P(NDF,"^",4),0)),"^")," Trade Name: ",$P(NDF,"^",5),!,"Route: " - S K=0 F S K=$O(^PSNDF(50.67,DA,1,K)) Q:'K W $P(^(K,0),"^")," " - W !,"Package Size: ",$P(^PS(50.609,$P(NDF,"^",8),0),"^")," Package Type: ",$P(^PS(50.608,$P(NDF,"^",9),0),"^") - S ZA=$P(NDF,"^",6) D ENTER1 - Q -END K DA,DA,DIC,DIE,DIR,DR,IN,ING,J,K,L,NEW,NDF,OLD,OLDDA,PROMPT,X,Y,Y1,Y3,Y7,^TMP($J) Q - Q - ; -PRODI ;INQUIRE INTO 50.68 - F S DIC="^PSNDF(50.68,",DIC(0)="AEQM" D ^DIC Q:Y<0 S DA=+Y D EN^DIQ - K DA,DIC,X,Y Q - ; -NDCI ;INQUIRE INTO 50.67 - S DIR(0)="SA^N:NDC;U:UPN;T:TRADE;P:PRODUCT",DIR("A")="NDC (N), UPN (U), Trade name (T), or Product (P) " D ^DIR G END:$D(DIRUT) S PROMPT=Y(0) G LISTNDC:PROMPT["PRO",LISTNDC1:PROMPT="NDC" I PROMPT["T" S PROMPT="T" - F S DIC="^PSNDF(50.67,",DIC(0)="AEQZS",DIC("A")="Select "_PROMPT S:PROMPT="T" DIC("A")=DIC("A")_"rade name" S DIC("A")=DIC("A")_" ",D=PROMPT D IX^DIC Q:Y<0 S DA=+Y D EN^DIQ - K DA,DIC,DIR,PROMPT,X,Y Q - ; -LINK ;LINK NDCS OR UPNS - S DIR(0)="SA^N:NDC;U:UPN",DIR("A")="NDC (N) or UPN (U) ",DIR("B")="NDC" D ^DIR G END:$D(DIRUT) S PROMPT=Y(0) - F Q:$D(DIRUT)!(Y<0) S DIC=50.67,DIC(0)="AEQZ",DIC("A")="Enter Current "_PROMPT_" ",D=PROMPT D IX^DIC Q:Y<0 S DA=+Y,OLD=$P(Y(0),"^",$S(PROMPT="NDC":2,1:3)) D - .K DIR S DIR(0)="F^"_$S(PROMPT="NDC":"12:12",1:"1:40")_"^W:$D(^PSNDF(50.67,PROMPT,X)) !!,""That "_PROMPT_" already exists"",! K:$D(^PSNDF(50.67,PROMPT,X)) X",DIR("A")="Enter a new "_PROMPT_" " D ^DIR K DIR Q:$D(DIRUT) S NEW=Y - .I PROMPT="NDC" D - ..S IN=$O(^PSNDF(50.67,DA,2,"B",NEW,0)) I IN S DIR(0)="Y" W !,"Those NDCs are already linked" S DIR("A")="Do you want to unlink them " D ^DIR Q:$D(DIRUT) Q:'Y - ..I IN S DA(1)=DA,DA=IN,DIE="^PSNDF(50.67,"_DA(1)_",2,",DR=".01///@;" D ^DIE W !,"Unlinked",! Q - ..I 'IN S DIE="^PSNDF(50.67,",DR="1////"_NEW D ^DIE K DD,DO S DA(1)=DA,DIC="^PSNDF(50.67,"_DA(1)_",2,",DIC(0)="L",DLAYGO=50.67,DIC("P")=$P(^DD(50.67,11,0),"^",2),X=OLD D ^DIC W !,"Linked",! Q - .I PROMPT="UPN" D - ..S IN=$O(^PSNDF(50.67,DA,3,"B",NEW,0)) I IN S DIR(0)="Y" W !,"Those UPNs are already linked" S DIR("A")="Do you want to unlink them " D ^DIR Q:$D(DIRUT) Q:'Y - ..S DA(1)=DA,DA=IN,DIE="^PSNDF(50.67,"_DA(1)_",3,",DR=".01///@;" D ^DIE W !,"Unlinked",! Q - ..I 'IN S DIE="^PSNDF(50.67,",DR="1////"_NEW D ^DIE K DD,DO S DA(1)=DA,DIC="^PSNDF(50.67,"_DA(1)_",3,",DIC(0)="L",DLAYGO=50.67,DIC("P")=$P(^DD(50.67,12,0),"^",2),X=OLD D ^DIC W !,"Linked",! Q - G LINK - ; -LISTNDC ;LOOK UP NDCS BY PRODUCT - K L,DA,^TMP($J),DIC - S DIC=50.68,DIC(0)="AQEMZ" D ^DIC G END:Y<0 S IEN=+Y D ENTER F SIE=0:0 S SIE=$O(^PSNDF(50.68,"ANDC",IEN,SIE)) Q:'SIE!($G(QUIT)) D PRNT ; S ^TMP($J,"A"_$P(^PSNDF(50.67,SIE,0),"^",2)_"^"_SIE)="" - Q -PRT D:($Y+5)>IOSL&('$G(QUIT)) HANG Q:$G(QUIT) S DA=SIE,DIC="^PSNDF(50.67," W ! D EN^DIQ - Q - ; -LISTNDC1 ;LOOK UP PARTIAL NDC - ; - F K ^TMP($J) S QUIT=0,DIR(0)="F^1:12",DIR("A")="Select NDC " D ^DIR Q:$D(DIRUT) S PSN1=Y,PSN=Y D - .I $D(^PSNDF(50.67,"NDC",PSN1)) S DA=0 F S DA=$O(^PSNDF(50.67,"NDC",PSN1,DA)) S:'DA QUIT=1 Q:QUIT S DIC="^PSNDF(50.67," W ! D EN^DIQ - .Q:QUIT - .I PSN1?."0".E S PSN1=PSN1_"/" - .I PSN1?.N,PSN1=+PSN1 S PSN1=$$LJ^XLFSTR(PSN1,12,0)-1 - .S ZCT=0 F Q:QUIT S PSN1=$O(^PSNDF(50.67,"NDC",PSN1)),DA=0 Q:$E(PSN1,1,$L(PSN))'=PSN F Q:QUIT S DA=$O(^PSNDF(50.67,"NDC",PSN1,DA)) Q:'DA S ZCT=ZCT+1,^TMP($J,ZCT)=DA W !,$J(ZCT,5)," ",PSN1 D - ..S MORE=$E($O(^PSNDF(50.67,"NDC",PSN1)),1,$L(PSN))=PSN!$O(^(PSN1,DA)) I ZCT#5&MORE Q - ..S DIR(0)="NOA^1:"_ZCT,DIR("A")="Choose 1 - "_ZCT_" or ^ to quit " S:MORE DIR("A")=DIR("A")_"or return to see more " - ..D ^DIR I $D(DUOUT)!$D(DTOUT) S QUIT=1 Q - ..I Y="" Q - ..S DA=^TMP($J,Y),QUIT=1,DIC="^PSNDF(50.67," W !! D EN^DIQ Q - G END -ENTER1 K QQQ S Z0=^PSNDF(50.68,ZA,0),Z1=^PSNDF(50.68,ZA,1),Z3=^PSNDF(50.68,ZA,3),Z7=$G(^PSNDF(50.68,ZA,7)),Z5=$G(^PSNDF(50.68,ZA,5)),Z6=$G(^PSNDF(50.68,ZA,6,1,0)),QQQ=$P(Z1,"^",5) D GCN D - .W !,"VA Product Name: ",$P(Z0,"^"),!,"VA Generic Name: ",$P(^PSNDF(50.6,+$P(Z0,"^",2),0),"^"),!,"Dose Form: ",$P(^PS(50.606,+$P(Z0,"^",3),0),"^")," Strength: ",$P(Z0,"^",4)," Units: ",$P($G(^PS(50.607,+$P(Z0,"^",5),0)),"^") - .W !,"National Formulary Name: ",$P(Z0,"^",6),!,"VA Print Name: ",$P(Z1,"^"),!,"VA Product Identifier: ",$P(Z1,"^",2)," Transmit to CMOP: ",$S($P(Z1,"^",3):"Yes",1:"No") - .W " VA Dispense Unit: ",$P($G(^PSNDF(50.64,+$P(Z1,"^",4),0)),"^") - .W !,"PMIS: ",PMIS,!,"Active Ingredients: " S K=0 F S K=$O(^PSNDF(50.68,ZA,2,K)) Q:'K!($G(QUIT)) S X=^(K,0),ING=^PS(50.416,K,0) S:$P(ING,"^",2) ING=^PS(50.416,$P(ING,"^",2),0) D - ..D:($Y+5)>IOSL&('$G(QUIT)) HANG Q:$G(QUIT) W ?23,$P(ING,"^")," Strength: ",$P(X,"^",2)," Units :",$P($G(^PS(50.607,+$P(X,"^",3),0)),"^"),! - .Q:$G(QUIT) W !,"Primary VA Drug Class: ",$P($G(^PS(50.605,+Z3,0),"Unknown"),"^"),!,"Secondary VA Drug Class: " S K=0 F S K=$O(^PSNDF(50.68,ZA,4,K)) Q:'K W ?26,$P($G(^PS(50.605,+K,0),"Unknown"),"^"),! - .W !,"CS Federal Schedule: "_$S($P(Z7,"^")]"":$P(Z7,"^"),1:"") - .W !,"National Formulary Indicator: " W:$P(Z5,"^")=1 "Yes" W:$P(Z5,"^")=0 "No" - .W !,"National Formulary Restriction: ",!,$P(Z6,"^") - .I $G(^PSNDF(50.68,ZA,8)) W !,"Exclude Drg-Drg Interaction Ck: Yes (No check for Drug-Drug Interactions)" - Q -CMOP K DIC S DIC="^PSNDF(50.68,",DIC(0)="QEAZ",D="C",DIC("A")="CMOP ID: " D MIX^DIC1 Q:Y<0 S IEN=+Y D ENTER F SIE=0:0 S SIE=$O(^PSNDF(50.68,"ANDC",IEN,SIE)) Q:'SIE D PRNT - Q -HANG K DIR S DIR(0)="E",DIR("A")="Press return to continue or '^' to exit" D ^DIR W @IOF S $X=0 S:Y'=1 QUIT=1 - Q -PRNT D:($Y+5)>IOSL&('$G(QUIT)) HANG Q:$G(QUIT) - S NDX=^PSNDF(50.67,SIE,0) - W !!,"NDC: ",$P(NDX,"^",2)," UPN: ",$P(NDX,"^",3),!,"VA Product Name: ",$P(^PSNDF(50.68,$P(NDX,"^",6),0),"^"),!,"Manufacturer: ",$P($G(^PS(55.95,+$P(NDX,"^",4),0)),"^")," Trade Name: ",$P(NDX,"^",5),!,"Route: " - S SIE1=0 F S SIE1=$O(^PSNDF(50.67,SIE,1,SIE1)) Q:'SIE1 W $P(^(SIE1,0),"^") - W !,"Package Size: ",$P(^PS(50.609,$P(NDX,"^",8),0),"^")," Package Type: ",$P(^PS(50.608,$P(NDX,"^",9),0),"^") - Q -PAD S ANS=Y F VV=1:1:3 S VV1=$S(VV=1:6,VV=2:4,VV=3:2) D PAD1 - S ANS=$P(ANS,"-",1)_$P(ANS,"-",2)_$P(ANS,"-",3) K VV,VV1 - S ANS=$TR(ANS,"-"),X=ANS - Q -PAD1 I $L($P(ANS,"-",VV))IOSL&('$G(QUIT)) HANG Q:$G(QUIT) W ?23,$P(ING,"^")," Strength: ",$P(X,"^",2)," Units :",$P($G(^PS(50.607,+$P(X,"^",3),0)),"^"),! + .Q:$G(QUIT) W !,"Primary VA Drug Class: ",$P($G(^PS(50.605,+Y3,0),"Unknown"),"^"),!,"Secondary VA Drug Class: " S K=0 F S K=$O(^PSNDF(50.68,DA,4,K)) Q:'K W ?26,$P($G(^PS(50.605,+K,0),"Unknown"),"^"),! + .W !,"CS Federal Schedule: "_$S($P($G(^PSNDF(50.68,DA,7)),"^")]"":$P(^PSNDF(50.68,DA,7),"^"),1:"") + .W !,"National Formulary Indicator: " W:$P(Y5,"^")=1 "Yes" W:$P(Y5,"^")=0 "No" + .W !,"National Formulary Restriction: ",!,$P(Y6,"^") + .I $G(^PSNDF(50.68,DA,8)) W !,"Exclude Drg-Drg Interaction Ck: Yes (No check for Drug-Drug Interactions)" + Q + K DA,DIE,DIE,DIRUT,DR,ING,K,OLDDA,X,Y,Y1,Y3,Y7 Q + ; +NDC ;OR UPN + K PROMPT S DIR(0)="SA^N:NDC;U:UPN",DIR("A")="NDC (N) or UPN (U) ? " D ^DIR G END:$D(DIRUT) S PROMPT=Y(0) + I PROMPT="NDC" S DIR(0)="F",DIR("A")="Enter NDC with or without Dashes (-)" D ^DIR G END:$D(DIRUT) D:X["-" PAD S DIC=50.67,DIC(0)="EQZN",D=PROMPT D IX^DIC Q:Y<0 S DA=+Y,NDF=Y(0) D LKNDC + I PROMPT="UPN" S DIC=50.67,DIC(0)="AEQZN",DIC("A")="Select "_PROMPT_":"_" ",D=PROMPT D IX^DIC Q:Y<0 S DA=+Y,NDF=Y(0) D LKNDC + Q +LKNDC W @IOF,!,"NDC: ",$P(NDF,"^",2),$$DT($P(NDF,"^",7))," UPN: ",$P(NDF,"^",3),!,"VA Product Name: ",$P(^PSNDF(50.68,$P(NDF,"^",6),0),"^"),!,"Manufacturer: ",$P($G(^PS(55.95,+$P(NDF,"^",4),0)),"^")," Trade Name: ",$P(NDF,"^",5),!,"Route: " + S K=0 F S K=$O(^PSNDF(50.67,DA,1,K)) Q:'K W $P(^(K,0),"^")," " + W !,"Package Size: ",$P(^PS(50.609,$P(NDF,"^",8),0),"^")," Package Type: ",$P(^PS(50.608,$P(NDF,"^",9),0),"^") + S ZA=$P(NDF,"^",6) D ENTER1 + Q +END K DA,DA,DIC,DIE,DIR,DR,IN,ING,J,K,L,NEW,NDF,OLD,OLDDA,PROMPT,X,Y,Y1,Y3,Y7,^TMP($J) Q + Q + ; +PRODI ;INQUIRE INTO 50.68 + F S DIC="^PSNDF(50.68,",DIC(0)="AEQM" D ^DIC Q:Y<0 S DA=+Y D EN^DIQ + K DA,DIC,X,Y Q + ; +NDCI ;INQUIRE INTO 50.67 + S DIR(0)="SA^N:NDC;U:UPN;T:TRADE;P:PRODUCT",DIR("A")="NDC (N), UPN (U), Trade name (T), or Product (P) " D ^DIR G END:$D(DIRUT) S PROMPT=Y(0) G LISTNDC:PROMPT["PRO",LISTNDC1:PROMPT="NDC" I PROMPT["T" S PROMPT="T" + F S DIC="^PSNDF(50.67,",DIC(0)="AEQZS",DIC("A")="Select "_PROMPT S:PROMPT="T" DIC("A")=DIC("A")_"rade name" S DIC("A")=DIC("A")_" ",D=PROMPT D IX^DIC Q:Y<0 S DA=+Y D EN^DIQ + K DA,DIC,DIR,PROMPT,X,Y Q + ; +LINK ;LINK NDCS OR UPNS + S DIR(0)="SA^N:NDC;U:UPN",DIR("A")="NDC (N) or UPN (U) ",DIR("B")="NDC" D ^DIR G END:$D(DIRUT) S PROMPT=Y(0) + F Q:$D(DIRUT)!(Y<0) S DIC=50.67,DIC(0)="AEQZ",DIC("A")="Enter Current "_PROMPT_" ",D=PROMPT D IX^DIC Q:Y<0 S DA=+Y,OLD=$P(Y(0),"^",$S(PROMPT="NDC":2,1:3)) D + .K DIR S DIR(0)="F^"_$S(PROMPT="NDC":"12:12",1:"1:40")_"^W:$D(^PSNDF(50.67,PROMPT,X)) !!,""That "_PROMPT_" already exists"",! K:$D(^PSNDF(50.67,PROMPT,X)) X",DIR("A")="Enter a new "_PROMPT_" " D ^DIR K DIR Q:$D(DIRUT) S NEW=Y + .I PROMPT="NDC" D + ..S IN=$O(^PSNDF(50.67,DA,2,"B",NEW,0)) I IN S DIR(0)="Y" W !,"Those NDCs are already linked" S DIR("A")="Do you want to unlink them " D ^DIR Q:$D(DIRUT) Q:'Y + ..I IN S DA(1)=DA,DA=IN,DIE="^PSNDF(50.67,"_DA(1)_",2,",DR=".01///@;" D ^DIE W !,"Unlinked",! Q + ..I 'IN S DIE="^PSNDF(50.67,",DR="1////"_NEW D ^DIE K DD,DO S DA(1)=DA,DIC="^PSNDF(50.67,"_DA(1)_",2,",DIC(0)="L",DLAYGO=50.67,DIC("P")=$P(^DD(50.67,11,0),"^",2),X=OLD D ^DIC W !,"Linked",! Q + .I PROMPT="UPN" D + ..S IN=$O(^PSNDF(50.67,DA,3,"B",NEW,0)) I IN S DIR(0)="Y" W !,"Those UPNs are already linked" S DIR("A")="Do you want to unlink them " D ^DIR Q:$D(DIRUT) Q:'Y + ..S DA(1)=DA,DA=IN,DIE="^PSNDF(50.67,"_DA(1)_",3,",DR=".01///@;" D ^DIE W !,"Unlinked",! Q + ..I 'IN S DIE="^PSNDF(50.67,",DR="1////"_NEW D ^DIE K DD,DO S DA(1)=DA,DIC="^PSNDF(50.67,"_DA(1)_",3,",DIC(0)="L",DLAYGO=50.67,DIC("P")=$P(^DD(50.67,12,0),"^",2),X=OLD D ^DIC W !,"Linked",! Q + G LINK + ; +LISTNDC ;LOOK UP NDCS BY PRODUCT + K L,DA,^TMP($J),DIC + S DIC=50.68,DIC(0)="AQEMZ" D ^DIC G END:Y<0 S IEN=+Y D ENTER F SIE=0:0 S SIE=$O(^PSNDF(50.68,"ANDC",IEN,SIE)) Q:'SIE!($G(QUIT)) D PRNT ; S ^TMP($J,"A"_$P(^PSNDF(50.67,SIE,0),"^",2)_"^"_SIE)="" + Q +PRT D:($Y+5)>IOSL&('$G(QUIT)) HANG Q:$G(QUIT) S DA=SIE,DIC="^PSNDF(50.67," W ! D EN^DIQ + Q + ; +LISTNDC1 ;LOOK UP PARTIAL NDC + ; + F K ^TMP($J) S QUIT=0,DIR(0)="F^1:12",DIR("A")="Select NDC " D ^DIR Q:$D(DIRUT) S PSN1=Y,PSN=Y D + .I $D(^PSNDF(50.67,"NDC",PSN1)) S DA=0 F S DA=$O(^PSNDF(50.67,"NDC",PSN1,DA)) S:'DA QUIT=1 Q:QUIT S DIC="^PSNDF(50.67," W ! D EN^DIQ + .Q:QUIT + .I PSN1?."0".E S PSN1=PSN1_"/" + .I PSN1?.N,PSN1=+PSN1 S PSN1=$$LJ^XLFSTR(PSN1,12,0)-1 + .S ZCT=0 F Q:QUIT S PSN1=$O(^PSNDF(50.67,"NDC",PSN1)),DA=0 Q:$E(PSN1,1,$L(PSN))'=PSN F Q:QUIT S DA=$O(^PSNDF(50.67,"NDC",PSN1,DA)) Q:'DA S ZCT=ZCT+1,^TMP($J,ZCT)=DA W !,$J(ZCT,5)," ",PSN1 D + ..S MORE=$E($O(^PSNDF(50.67,"NDC",PSN1)),1,$L(PSN))=PSN!$O(^(PSN1,DA)) I ZCT#5&MORE Q + ..S DIR(0)="NOA^1:"_ZCT,DIR("A")="Choose 1 - "_ZCT_" or ^ to quit " S:MORE DIR("A")=DIR("A")_"or return to see more " + ..D ^DIR I $D(DUOUT)!$D(DTOUT) S QUIT=1 Q + ..I Y="" Q + ..S DA=^TMP($J,Y),QUIT=1,DIC="^PSNDF(50.67," W !! D EN^DIQ Q + G END +ENTER1 K QQQ S Z0=^PSNDF(50.68,ZA,0),Z1=^PSNDF(50.68,ZA,1),Z3=^PSNDF(50.68,ZA,3),Z7=$G(^PSNDF(50.68,ZA,7)),Z5=$G(^PSNDF(50.68,ZA,5)),Z6=$G(^PSNDF(50.68,ZA,6,1,0)),QQQ=$P(Z1,"^",5) D GCN D + .W !,"VA Product Name: ",$P(Z0,"^"),!,"VA Generic Name: ",$P(^PSNDF(50.6,+$P(Z0,"^",2),0),"^"),!,"Dose Form: ",$P(^PS(50.606,+$P(Z0,"^",3),0),"^")," Strength: ",$P(Z0,"^",4)," Units: ",$P($G(^PS(50.607,+$P(Z0,"^",5),0)),"^") + .W !,"National Formulary Name: ",$P(Z0,"^",6),!,"VA Print Name: ",$P(Z1,"^"),!,"VA Product Identifier: ",$P(Z1,"^",2)," Transmit to CMOP: ",$S($P(Z1,"^",3):"Yes",1:"No") + .W " VA Dispense Unit: ",$P($G(^PSNDF(50.64,+$P(Z1,"^",4),0)),"^") + .W !,"PMIS: ",PMIS,!,"Active Ingredients: " S K=0 F S K=$O(^PSNDF(50.68,ZA,2,K)) Q:'K!($G(QUIT)) S X=^(K,0),ING=^PS(50.416,K,0) S:$P(ING,"^",2) ING=^PS(50.416,$P(ING,"^",2),0) D + ..D:($Y+5)>IOSL&('$G(QUIT)) HANG Q:$G(QUIT) W ?23,$P(ING,"^")," Strength: ",$P(X,"^",2)," Units :",$P($G(^PS(50.607,+$P(X,"^",3),0)),"^"),! + .Q:$G(QUIT) W !,"Primary VA Drug Class: ",$P($G(^PS(50.605,+Z3,0),"Unknown"),"^"),!,"Secondary VA Drug Class: " S K=0 F S K=$O(^PSNDF(50.68,ZA,4,K)) Q:'K W ?26,$P($G(^PS(50.605,+K,0),"Unknown"),"^"),! + .W !,"CS Federal Schedule: "_$S($P(Z7,"^")]"":$P(Z7,"^"),1:"") + .W !,"National Formulary Indicator: " W:$P(Z5,"^")=1 "Yes" W:$P(Z5,"^")=0 "No" + .W !,"National Formulary Restriction: ",!,$P(Z6,"^") + .I $G(^PSNDF(50.68,DA,8)) W !,"Exclude Drg-Drg Interaction Ck: Yes (No check for Drug-Drug Interactions)" + Q +CMOP K DIC S DIC="^PSNDF(50.68,",DIC(0)="QEAZ",D="C",DIC("A")="CMOP ID: " D MIX^DIC1 Q:Y<0 S IEN=+Y D ENTER F SIE=0:0 S SIE=$O(^PSNDF(50.68,"ANDC",IEN,SIE)) Q:'SIE D PRNT + Q +HANG K DIR S DIR(0)="E",DIR("A")="Press return to continue or '^' to exit" D ^DIR W @IOF S $X=0 S:Y'=1 QUIT=1 + Q +PRNT D:($Y+5)>IOSL&('$G(QUIT)) HANG Q:$G(QUIT) + S NDX=^PSNDF(50.67,SIE,0) + W !!,"NDC: ",$P(NDX,"^",2)," UPN: ",$P(NDX,"^",3),!,"VA Product Name: ",$P(^PSNDF(50.68,$P(NDX,"^",6),0),"^"),!,"Manufacturer: ",$P($G(^PS(55.95,+$P(NDX,"^",4),0)),"^")," Trade Name: ",$P(NDX,"^",5),!,"Route: " + S SIE1=0 F S SIE1=$O(^PSNDF(50.67,SIE,1,SIE1)) Q:'SIE1 W $P(^(SIE1,0),"^") + W !,"Package Size: ",$P(^PS(50.609,$P(NDX,"^",8),0),"^")," Package Type: ",$P(^PS(50.608,$P(NDX,"^",9),0),"^") + Q +PAD S ANS=Y F VV=1:1:3 S VV1=$S(VV=1:6,VV=2:4,VV=3:2) D PAD1 + S ANS=$P(ANS,"-",1)_$P(ANS,"-",2)_$P(ANS,"-",3) K VV,VV1 + S ANS=$TR(ANS,"-"),X=ANS + Q +PAD1 I $L($P(ANS,"-",VV))PSNPGLNG TITLE W:PSNFLG !,PSNLGN,! S PSNFLG=0 W ?3 W:PSNLOC'="ZZXZZXZZX" PSNLOC W:PSNLOC="ZZXZZXZZX" " " W ?46,PSNCL,?59,PSNPR,! - Q -DATE K ^TMP($J,"PSNDT") F PSNB=0:0 S PSNB=$O(^PSDRUG(PSNB)) Q:'PSNB D DATE0 - Q -DATE0 I '$D(^PSDRUG(PSNB,"I")) S ^TMP($J,"PSNDT",PSNB)="" - I $D(^PSDRUG(PSNB,"I")) S PSNDATE=$P(^PSDRUG(PSNB,"I"),"^") D NOW^%DTC I XPSNPGLNG TITLE W:PSNFLG !,PSNLGN,! S PSNFLG=0 W ?3 W:PSNLOC'="ZZXZZXZZX" PSNLOC W:PSNLOC="ZZXZZXZZX" " " W ?46,PSNCL,?59,PSNPR,! + Q +DATE K ^TMP($J,"PSNDT") F PSNB=0:0 S PSNB=$O(^PSDRUG(PSNB)) Q:'PSNB D DATE0 + Q +DATE0 I '$D(^PSDRUG(PSNB,"I")) S ^TMP($J,"PSNDT",PSNB)="" + I $D(^PSDRUG(PSNB,"I")) S PSNDATE=$P(^PSDRUG(PSNB,"I"),"^") D NOW^%DTC I X60) ! W "." - ; - K ^TMP("OCXCMP",$J,"D CODE") - ; - W:'$G(OCXAUTO) !,?5,"Assign Subroutines to Routines..." - S OCXRN=1,OCXD0=0 - D GETHDR(1) - F S OCXD0=$O(^TMP("OCXCMP",$J,"C CODE",OCXD0)) Q:'OCXD0 D Q:OCXWARN - .N OCXLLAB,OCXSKIP,OCXEXF,OCXSUB,OCXSIZE,OCXFILE,OCXCCODE,OCXDCODE,OCXLAST - .I '$G(OCXAUTO) W:($X>60) ! W "." - .S OCXLLAB=^TMP("OCXCMP",$J,"LINE",OCXD0) - .S OCXSKIP=((OCXLLAB="UPDATE")!(OCXLLAB="LOG")) - .S OCXSIZE=$$SIZE^OCXOCMP8(OCXRN,OCXD0) - .S OCXLAST='$O(^TMP("OCXCMP",$J,"C CODE",OCXD0)) - .S OCXFILE=(OCXSIZE>OCXCRS)!(OCXLAST) S:OCXSKIP OCXFILE=0 - .I OCXFILE D - ..K OCXEXF S OCXEXF="" - ..I $D(^TMP("OCXCMP",$J,"D CODE",OCXRN,"CALLS")) M OCXEXF=^("CALLS") - ..S OCXSUB="" F S OCXSUB=$O(OCXEXF(OCXSUB)) Q:'$L(OCXSUB) I 'OCXEXF(OCXSUB) D - ...S OCXEXF(OCXSUB)=1,OCXEXF=OCXSUB - ...S OCXSUB="" F S OCXSUB=$O(^TMP("OCXCMP",$J,"INCLUDE",OCXEXF,"CALLS",OCXSUB)) Q:'$L(OCXSUB) D - ....S OCXEXF(OCXSUB)=$G(OCXEXF(OCXSUB)) - ..S OCXSUB="" F S OCXSUB=$O(OCXEXF(OCXSUB)) Q:'$L(OCXSUB) D - ...D APPEND^OCXOCMP8(OCXRN,OCXSUB,"F") - ..D APPEND^OCXOCMP8(OCXRN,"$") - ..S OCXRN=OCXRN+1 D GETHDR(OCXRN) - ..; - .D APPEND^OCXOCMP8(OCXRN,OCXD0,"C",OCXLLAB) - .I ($E(OCXLLAB,1,2)="EL") D - ..S ^OCXS(860.3,"APGM",(+$E(OCXLLAB,3,$L(OCXLLAB))),(OCXLLAB_U_$$RNAM(OCXRN)))="" - .S $P(^TMP("OCXCMP",$J,"LINE",OCXD0),U,2)=$$RNAM(OCXRN) - .Q:'OCXLAST - .K OCXEXF S OCXEXF="" - .I $D(^TMP("OCXCMP",$J,"D CODE",OCXRN,"CALLS")) M OCXEXF=^("CALLS") - .S OCXSUB="" F S OCXSUB=$O(OCXEXF(OCXSUB)) Q:'$L(OCXSUB) I 'OCXEXF(OCXSUB) D - ..S OCXEXF(OCXSUB)=1,OCXEXF=OCXSUB - ..S OCXSUB="" F S OCXSUB=$O(^TMP("OCXCMP",$J,"INCLUDE",OCXEXF,"CALLS",OCXSUB)) Q:'$L(OCXSUB) D - ...S OCXEXF(OCXSUB)=$G(OCXEXF(OCXSUB)) - .S OCXSUB="" F S OCXSUB=$O(OCXEXF(OCXSUB)) Q:'$L(OCXSUB) D - ..D APPEND^OCXOCMP8(OCXRN,OCXSUB,"F") - .D APPEND^OCXOCMP8(OCXRN,"$") - ; - W:'$G(OCXAUTO) !,?5,"Resolve Routine Line Tags..." - S OCXD0=0 F S OCXD0=$O(^TMP("OCXCMP",$J,"D CODE",OCXD0)) Q:'OCXD0 D Q:OCXWARN - .I '$G(OCXAUTO) W:($X>60) ! W "." - .N TEXT,RTN,TEMP,ALT,LABL,OBJ,PIEC - .S RTN=$$RNAM(OCXD0) - .K TEMP M TEMP=^TMP("OCXCMP",$J,"D CODE",OCXD0) - .S OCXD1=0 F OCXOFF=0:1 S OCXD1=$O(TEMP(OCXD1)) Q:'OCXD1 D Q:OCXWARN - ..N TEXT,PIEC - ..S TEXT=TEMP(OCXD1,0) Q:'(TEXT["||") - ..; - ..F PIEC=2:2:$L(TEXT,"||") D Q:OCXWARN - ...S LABL=$P(TEXT,"||",PIEC) - ...I ($E(LABL,1,5)="LINE:") D I 1 - ....S LABL=$G(^TMP("OCXCMP",$J,"LINE",+$P(LABL,":",2))) - ....I '$L(LABL) D WARN^OCXOCMPV("Line Label not found: "_$P(TEXT,"|",2),$P($T(+1)," ",1)) Q - ....S:($P(LABL,"^",2)=RTN) LABL=$P(LABL,"^",1) - ...; - ...E I ($E(LABL,1,5)="LNTAG") D I 1 - ....N D0,CNT - ....S D0=OCXD1 F CNT=1:1 S D0=$O(TEMP(D0),-1) Q:$L($P(TEMP(D0,0)," ",1)) - ....S LABL=$P(TEMP(D0,0)," ",1) S:(LABL["(") LABL=$P(LABL,"(",1) - ....S LABL="(+$P($H,"","",2))_""<"_LABL_"+"_CNT_U_RTN_">""" - ...; - ...E D WARN^OCXOCMPV("Unknown Compiler directive: "_LABL,$P($T(+1)," ",1)) Q - ...; - ...S $P(TEXT,"||",PIEC)=LABL - ..; - ..F Q:'(TEXT["||") S TEXT=$P(TEXT,"||",1)_$P(TEXT,"||",2,999) - ..S TEMP(OCXD1,0)=TEXT - .; - .K ^TMP("OCXCMP",$J,"D CODE",OCXD0) - .M ^TMP("OCXCMP",$J,"D CODE",OCXD0)=TEMP - ; - Q:OCXWARN 1 - W:'$G(OCXAUTO) !,?5,"Generate Subroutine and Call documentation..." - S OCXD0=0 F S OCXD0=$O(^TMP("OCXCMP",$J,"C CODE",OCXD0)) Q:'OCXD0 D CALL^OCXOCMPT(OCXD0) - ; - W:'$G(OCXAUTO) !!,?5,"Delete Old OCXOZ* Routines..." - S OCXRTEST=^%ZOSF("TEST"),OCXSAVE=^%ZOSF("SAVE"),OCXDEL=^%ZOSF("DEL") - F OCXRN=1:1:1290 D - .I '$G(OCXAUTO) W:($X>60) ! W:'(OCXRN#100) "." - .S X=$$RNAM(OCXRN) X OCXRTEST I X OCXDEL W:'$G(OCXAUTO) "!" - ; - W:'$G(OCXAUTO) !,?5,"File New OCXOZ* routines..." - S OCXD0=$O(^TMP("OCXCMP",$J,"D CODE",0)) Q:'OCXD0 1 - F S OCXD0=$O(^TMP("OCXCMP",$J,"D CODE",OCXD0)) Q:'OCXD0 D Q:OCXWARN - .I '$G(OCXAUTO) W:($X>60) ! W "." - .D FILE^OCXOCMP8(OCXD0) - S OCXD0=$O(^TMP("OCXCMP",$J,"D CODE",0)) Q:'OCXD0 1 D FILE^OCXOCMP8(OCXD0) - ; - Q OCXWARN - ; -GETHDR(RNUM) ; - ; - N OCXREC,D0,EFC,OCXEFF,PIEC,TEXT - S OCXREC(1,0)=$$RNAM(RNUM)_" ;SLC/RJS,CLA - Order Check Scan ;"_$$NOW - S OCXREC(2,0)=$T(+2) - S OCXREC(3,0)=$T(+3) - S OCXREC(4,0)=" ;" - S OCXREC(5,0)=" ; ***************************************************************" - S OCXREC(6,0)=" ; ** Warning: This routine is automatically generated by the **" - S OCXREC(7,0)=" ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine **" - S OCXREC(8,0)=" ; ** will be lost the next time the rule compiler executes. **" - S OCXREC(9,0)=" ; ***************************************************************" - S OCXREC(10,0)=" ;" - I (RNUM=1) D - .S OCXREC(11,0)=" ; compiled code line length: "_OCXCLL - .S OCXREC(12,0)=" ; compiled routine size: "_OCXCRS - .S OCXREC(13,0)=" ; triggered rule ignore period: "_OCXTSPI - .S OCXREC(14,0)=" ;" - .S OCXREC(15,0)=" ; Program Execution Trace Mode: "_$S($G(OCXTRACE):" ON",1:"OFF") - .S OCXREC(16,0)=" ;" ; " ; Elapsed time logging: "_$S($G(OCXTLOG):" ON",1:"OFF") - .S OCXREC(17,0)=" ; Raw Data Logging: "_$S($G(OCXDLOG):(" ON Keep data for "_OCXDLOG_" day"_$S(OCXDLOG=1:"",1:"s")_" then purge."),1:"OFF") - .S OCXREC(18,0)=" ; Compiler mode: "_$S(($G(OCXAUTO)>1):"Queued",$G(OCXAUTO):" ON",1:"OFF") - .S OCXREC(19,0)=" ; Compiled by: "_$P($G(^VA(200,+$G(DUZ),0)),U,1)_" (DUZ="_(+$G(DUZ))_")" - .S OCXREC(20,0)=" Q" - .S OCXREC(21,0)=" ;" - ; - E D - .S OCXREC(11,0)=" Q" - .S OCXREC(12,0)=" ;" - ; - M ^TMP("OCXCMP",$J,"D CODE",RNUM)=OCXREC - Q - ; -RNAM(X) ; - N CHAR - S CHAR="0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" - Q "OCXOZ"_$E(CHAR,(X\36+1))_$E(CHAR,(X#36+1)) - ; -TODAY() N X,Y,%DT S X="T",%DT="" D ^%DT X ^DD("DD") Q Y - ; -NOW() N X,Y,%DT S X="N",%DT="T" D ^%DT X ^DD("DD") S:(Y["@") Y=$P(Y,"@",1)_" at "_$P(Y,"@",2,99) Q Y - ; +OCXOCMP6 ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Assemble Order Check Routines) ;1/05/04 14:33 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; +EN() ; + ; + Q:$G(OCXWARN) 1 + N OCXD0,OCXD1,OCXRN,OCXSCNT,OCXOFF + ; + S OCXLCNT=0 + ; + W:'$G(OCXAUTO) !,?5,"Generate Extrinsic Function and Variables documentation..." + S OCXD0=0 F S OCXD0=$O(^TMP("OCXCMP",$J,"C CODE",OCXD0)) Q:'OCXD0 D DOC^OCXOCMPT(OCXD0) + ; + K ^OCXS(860.3,"APGM") + S OCXD0=0 F S OCXD0=$O(^OCXS(860.3,OCXD0)) Q:'OCXD0 D + .K ^OCXS(860.3,OCXD0,"RTN") I '$G(OCXAUTO) W:($X>60) ! W "." + ; + K ^TMP("OCXCMP",$J,"D CODE") + ; + W:'$G(OCXAUTO) !,?5,"Assign Subroutines to Routines..." + S OCXRN=1,OCXD0=0 + D GETHDR(1) + F S OCXD0=$O(^TMP("OCXCMP",$J,"C CODE",OCXD0)) Q:'OCXD0 D Q:OCXWARN + .N OCXLLAB,OCXSKIP,OCXEXF,OCXSUB,OCXSIZE,OCXFILE,OCXCCODE,OCXDCODE,OCXLAST + .I '$G(OCXAUTO) W:($X>60) ! W "." + .S OCXLLAB=^TMP("OCXCMP",$J,"LINE",OCXD0) + .S OCXSKIP=((OCXLLAB="UPDATE")!(OCXLLAB="LOG")) + .S OCXSIZE=$$SIZE^OCXOCMP8(OCXRN,OCXD0) + .S OCXLAST='$O(^TMP("OCXCMP",$J,"C CODE",OCXD0)) + .S OCXFILE=(OCXSIZE>OCXCRS)!(OCXLAST) S:OCXSKIP OCXFILE=0 + .I OCXFILE D + ..K OCXEXF S OCXEXF="" + ..I $D(^TMP("OCXCMP",$J,"D CODE",OCXRN,"CALLS")) M OCXEXF=^("CALLS") + ..S OCXSUB="" F S OCXSUB=$O(OCXEXF(OCXSUB)) Q:'$L(OCXSUB) I 'OCXEXF(OCXSUB) D + ...S OCXEXF(OCXSUB)=1,OCXEXF=OCXSUB + ...S OCXSUB="" F S OCXSUB=$O(^TMP("OCXCMP",$J,"INCLUDE",OCXEXF,"CALLS",OCXSUB)) Q:'$L(OCXSUB) D + ....S OCXEXF(OCXSUB)=$G(OCXEXF(OCXSUB)) + ..S OCXSUB="" F S OCXSUB=$O(OCXEXF(OCXSUB)) Q:'$L(OCXSUB) D + ...D APPEND^OCXOCMP8(OCXRN,OCXSUB,"F") + ..D APPEND^OCXOCMP8(OCXRN,"$") + ..S OCXRN=OCXRN+1 D GETHDR(OCXRN) + ..; + .D APPEND^OCXOCMP8(OCXRN,OCXD0,"C",OCXLLAB) + .I ($E(OCXLLAB,1,2)="EL") D + ..S ^OCXS(860.3,"APGM",(+$E(OCXLLAB,3,$L(OCXLLAB))),(OCXLLAB_U_$$RNAM(OCXRN)))="" + .S $P(^TMP("OCXCMP",$J,"LINE",OCXD0),U,2)=$$RNAM(OCXRN) + .Q:'OCXLAST + .K OCXEXF S OCXEXF="" + .I $D(^TMP("OCXCMP",$J,"D CODE",OCXRN,"CALLS")) M OCXEXF=^("CALLS") + .S OCXSUB="" F S OCXSUB=$O(OCXEXF(OCXSUB)) Q:'$L(OCXSUB) I 'OCXEXF(OCXSUB) D + ..S OCXEXF(OCXSUB)=1,OCXEXF=OCXSUB + ..S OCXSUB="" F S OCXSUB=$O(^TMP("OCXCMP",$J,"INCLUDE",OCXEXF,"CALLS",OCXSUB)) Q:'$L(OCXSUB) D + ...S OCXEXF(OCXSUB)=$G(OCXEXF(OCXSUB)) + .S OCXSUB="" F S OCXSUB=$O(OCXEXF(OCXSUB)) Q:'$L(OCXSUB) D + ..D APPEND^OCXOCMP8(OCXRN,OCXSUB,"F") + .D APPEND^OCXOCMP8(OCXRN,"$") + ; + W:'$G(OCXAUTO) !,?5,"Resolve Routine Line Tags..." + S OCXD0=0 F S OCXD0=$O(^TMP("OCXCMP",$J,"D CODE",OCXD0)) Q:'OCXD0 D Q:OCXWARN + .I '$G(OCXAUTO) W:($X>60) ! W "." + .N TEXT,RTN,TEMP,ALT,LABL,OBJ,PIEC + .S RTN=$$RNAM(OCXD0) + .K TEMP M TEMP=^TMP("OCXCMP",$J,"D CODE",OCXD0) + .S OCXD1=0 F OCXOFF=0:1 S OCXD1=$O(TEMP(OCXD1)) Q:'OCXD1 D Q:OCXWARN + ..N TEXT,PIEC + ..S TEXT=TEMP(OCXD1,0) Q:'(TEXT["||") + ..; + ..F PIEC=2:2:$L(TEXT,"||") D Q:OCXWARN + ...S LABL=$P(TEXT,"||",PIEC) + ...I ($E(LABL,1,5)="LINE:") D I 1 + ....S LABL=$G(^TMP("OCXCMP",$J,"LINE",+$P(LABL,":",2))) + ....I '$L(LABL) D WARN^OCXOCMPV("Line Label not found: "_$P(TEXT,"|",2),$P($T(+1)," ",1)) Q + ....S:($P(LABL,"^",2)=RTN) LABL=$P(LABL,"^",1) + ...; + ...E I ($E(LABL,1,5)="LNTAG") D I 1 + ....N D0,CNT + ....S D0=OCXD1 F CNT=1:1 S D0=$O(TEMP(D0),-1) Q:$L($P(TEMP(D0,0)," ",1)) + ....S LABL=$P(TEMP(D0,0)," ",1) S:(LABL["(") LABL=$P(LABL,"(",1) + ....S LABL="(+$P($H,"","",2))_""<"_LABL_"+"_CNT_U_RTN_">""" + ...; + ...E D WARN^OCXOCMPV("Unknown Compiler directive: "_LABL,$P($T(+1)," ",1)) Q + ...; + ...S $P(TEXT,"||",PIEC)=LABL + ..; + ..F Q:'(TEXT["||") S TEXT=$P(TEXT,"||",1)_$P(TEXT,"||",2,999) + ..S TEMP(OCXD1,0)=TEXT + .; + .K ^TMP("OCXCMP",$J,"D CODE",OCXD0) + .M ^TMP("OCXCMP",$J,"D CODE",OCXD0)=TEMP + ; + Q:OCXWARN 1 + W:'$G(OCXAUTO) !,?5,"Generate Subroutine and Call documentation..." + S OCXD0=0 F S OCXD0=$O(^TMP("OCXCMP",$J,"C CODE",OCXD0)) Q:'OCXD0 D CALL^OCXOCMPT(OCXD0) + ; + W:'$G(OCXAUTO) !!,?5,"Delete Old OCXOZ* Routines..." + S OCXRTEST=^%ZOSF("TEST"),OCXSAVE=^%ZOSF("SAVE"),OCXDEL=^%ZOSF("DEL") + F OCXRN=1:1:1290 D + .I '$G(OCXAUTO) W:($X>60) ! W:'(OCXRN#100) "." + .S X=$$RNAM(OCXRN) X OCXRTEST I X OCXDEL W:'$G(OCXAUTO) "!" + ; + W:'$G(OCXAUTO) !,?5,"File New OCXOZ* routines..." + S OCXD0=$O(^TMP("OCXCMP",$J,"D CODE",0)) Q:'OCXD0 1 + F S OCXD0=$O(^TMP("OCXCMP",$J,"D CODE",OCXD0)) Q:'OCXD0 D Q:OCXWARN + .I '$G(OCXAUTO) W:($X>60) ! W "." + .D FILE^OCXOCMP8(OCXD0) + S OCXD0=$O(^TMP("OCXCMP",$J,"D CODE",0)) Q:'OCXD0 1 D FILE^OCXOCMP8(OCXD0) + ; + Q OCXWARN + ; +GETHDR(RNUM) ; + ; + N OCXREC,D0,EFC,OCXEFF,PIEC,TEXT + S OCXREC(1,0)=$$RNAM(RNUM)_" ;SLC/RJS,CLA - Order Check Scan ;"_$$NOW + S OCXREC(2,0)=$T(+2) + S OCXREC(3,0)=$T(+3) + S OCXREC(4,0)=" ;" + S OCXREC(5,0)=" ; ***************************************************************" + S OCXREC(6,0)=" ; ** Warning: This routine is automatically generated by the **" + S OCXREC(7,0)=" ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine **" + S OCXREC(8,0)=" ; ** will be lost the next time the rule compiler executes. **" + S OCXREC(9,0)=" ; ***************************************************************" + S OCXREC(10,0)=" ;" + I (RNUM=1) D + .S OCXREC(11,0)=" ; compiled code line length: "_OCXCLL + .S OCXREC(12,0)=" ; compiled routine size: "_OCXCRS + .S OCXREC(13,0)=" ; triggered rule ignore period: "_OCXTSPI + .S OCXREC(14,0)=" ;" + .S OCXREC(15,0)=" ; Program Execution Trace Mode: "_$S($G(OCXTRACE):" ON",1:"OFF") + .S OCXREC(16,0)=" ;" ; " ; Elapsed time logging: "_$S($G(OCXTLOG):" ON",1:"OFF") + .S OCXREC(17,0)=" ; Raw Data Logging: "_$S($G(OCXDLOG):(" ON Keep data for "_OCXDLOG_" day"_$S(OCXDLOG=1:"",1:"s")_" then purge."),1:"OFF") + .S OCXREC(18,0)=" ; Compiler mode: "_$S(($G(OCXAUTO)>1):"Queued",$G(OCXAUTO):" ON",1:"OFF") + .S OCXREC(19,0)=" ; Compiled by: "_$P($G(^VA(200,+$G(DUZ),0)),U,1)_" (DUZ="_(+$G(DUZ))_")" + .S OCXREC(20,0)=" Q" + .S OCXREC(21,0)=" ;" + ; + E D + .S OCXREC(11,0)=" Q" + .S OCXREC(12,0)=" ;" + ; + M ^TMP("OCXCMP",$J,"D CODE",RNUM)=OCXREC + Q + ; +RNAM(X) ; + N CHAR + S CHAR="0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" + Q "OCXOZ"_$E(CHAR,(X\36+1))_$E(CHAR,(X#36+1)) + ; +TODAY() N X,Y,%DT S X="T",%DT="" D ^%DT X ^DD("DD") Q Y + ; +NOW() N X,Y,%DT S X="N",%DT="T" D ^%DT X ^DD("DD") S:(Y["@") Y=$P(Y,"@",1)_" at "_$P(Y,"@",2,99) Q Y + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOCMP8.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOCMP8.m index 9f615a78..f4108284 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOCMP8.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOCMP8.m @@ -1,89 +1,102 @@ -OCXOCMP8 ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Assemble Order Check Routines utilities) ;10/29/98 12:37 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; - Q -FILE(RNUM) ; - ; - W:'$G(OCXAUTO) !,$$RNAM(RNUM) - N DIE,XCN,X - S DIE="^TMP(""OCXCMP"",$J,""D CODE"","_RNUM_",",XCN=0,X=$$RNAM(RNUM) - X ^%ZOSF("SAVE") - Q - ; -APPEND(DSUB,CSUB,SRC,LABEL) ; - ; - N OCXSRC,OCXNDX,OCXNEXT,GLD,GLC - S GLD="^TMP(""OCXCMP"",$J,""D CODE"","_(+DSUB)_")" - I (CSUB="$") D Q - .S OCXNEXT=$O(@GLD@(" "),-1)+1 - .S @GLD@(OCXNEXT,0)="$" - .S OCXNEXT=$O(@GLD@(" "),-1)+1 - .S @GLD@(OCXNEXT,0)="" - ; - I (SRC="C") M GLC=^TMP("OCXCMP",$J,"C CODE",+CSUB) S ^TMP("OCXCMP",$J,"D CODE","LINE",LABEL)=DSUB_","_($O(@GLD@(" "),-1)+1) - I (SRC="F") M GLC=^TMP("OCXCMP",$J,"INCLUDE",CSUB) - S OCXNDX=0 F S OCXNDX=$O(GLC(OCXNDX)) Q:'OCXNDX D - .S OCXNEXT=$O(@GLD@(" "),-1)+1 - .S @GLD@(OCXNEXT,0)=GLC(OCXNDX,0) - M @GLD@("CALLS")=GLC("CALLS") - S @GLD@("SIZE")=$G(@GLD@("SIZE"))+$G(GLC("SIZE")) - Q - ; -SIZE(DSUB,CSUB) ; - ; - N D0,EFC,OCXEFC,OCXEFD,OCXEFF,OCXREC - N OCXTEMP,PIEC,SIZEC,SIZED,SIZEF,TEXT - ; - S (SIZEC,SIZED,SIZEF)=0 - K OCXEFF,OCXEFC,OCXEFD - S (OCXEFF,OCXEFC,OCXEFD)="" - ; - I $G(CSUB),$D(^TMP("OCXCMP",$J,"C CODE",+CSUB)) D - .I $D(^TMP("OCXCMP",$J,"C CODE",+CSUB,"SIZE")) D Q - ..S SIZEC=^TMP("OCXCMP",$J,"C CODE",+CSUB,"SIZE") - ..I $D(^TMP("OCXCMP",$J,"C CODE",+CSUB,"CALLS")) D - ...K OCXEFC M OCXEFC=^TMP("OCXCMP",$J,"C CODE",+CSUB,"CALLS") - .K OCXREC M OCXREC=^TMP("OCXCMP",$J,"C CODE",+CSUB) - .S D0=0 F S D0=$O(OCXREC(D0)) Q:'D0 D - ..S TEXT=OCXREC(D0,0),SIZEC=SIZEC+$L(TEXT) - ..Q:'(TEXT["$$") - ..F PIEC=2:1:$L(TEXT,"$$") D - ...S EFC=$P($P(TEXT,"$$",PIEC),"(",1) - ...S:(EFC[" ") EFC=$P(EFC," ",1) Q:(EFC["^") Q:'$L(EFC) - ...I '$D(^TMP("OCXCMP",$J,"INCLUDE",EFC)) D Q - ....D WARN^OCXOCMPV("Unknown Local Extrinsic Function: "_EFC,$P($T(+1)," ",1)) Q - ...S OCXEFC(EFC)="" - .S SIZEC=SIZEC+100 ; ADJUST FOR SUBROUTINE DOCUMENTATION - .S ^TMP("OCXCMP",$J,"C CODE",+CSUB,"SIZE")=SIZEC - .M ^TMP("OCXCMP",$J,"C CODE",+CSUB,"CALLS")=OCXEFC - ; - I $G(DSUB),$D(^TMP("OCXCMP",$J,"D CODE",+DSUB)) D - .I $G(^TMP("OCXCMP",$J,"D CODE",+DSUB,"SIZE")) D Q - ..S SIZED=^TMP("OCXCMP",$J,"D CODE",+DSUB,"SIZE") - ..I $D(^TMP("OCXCMP",$J,"D CODE",+DSUB,"CALLS")) D - ...K OCXEFD M OCXEFD=^TMP("OCXCMP",$J,"D CODE",+DSUB,"CALLS") - ; - K OCXEFF M OCXEFF=OCXEFC,OCXEFF=OCXEFD - ; - I $D(OCXEFF) S EFC="" F S EFC=$O(OCXEFF(EFC)) Q:'$L(EFC) I 'OCXEFF(EFC) D - .K OCXTEMP - .I $D(^TMP("OCXCMP",$J,"INCLUDE",EFC,"SIZE")) M OCXTEMP("SIZE")=^TMP("OCXCMP",$J,"INCLUDE",EFC,"SIZE") - .I $D(^TMP("OCXCMP",$J,"INCLUDE",EFC,"CALLS")) M OCXTEMP("CALLS")=^TMP("OCXCMP",$J,"INCLUDE",EFC,"CALLS") - .S OCXEFF(EFC)=OCXTEMP("SIZE") - .Q:'$D(OCXTEMP("CALLS")) - .S EFC="" F S EFC=$O(OCXTEMP("CALLS",EFC)) Q:'$L(EFC) S OCXEFF(EFC)=+$G(OCXEFF(EFC)) - ; - I $D(OCXEFF) S EFC="" F S EFC=$O(OCXEFF(EFC)) Q:'$L(EFC) S SIZEF=SIZEF+OCXEFF(EFC) - ; - Q $G(SIZEC)+$G(SIZED)+$G(SIZEF) - ; -RNAM(X) ; - N CHAR - S CHAR="0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" - Q "OCXOZ"_$E(CHAR,(X\36+1))_$E(CHAR,(X#36+1)) - ; -TODAY() N X,Y,%DT S X="T",%DT="" D ^%DT X ^DD("DD") Q Y - ; -NOW() N X,Y,%DT S X="N",%DT="T" D ^%DT X ^DD("DD") S:(Y["@") Y=$P(Y,"@",1)_" at "_$P(Y,"@",2,99) Q Y - ; +OCXOCMP8 ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Assemble Order Check Routines utilities) ;6:55 PM 24 Jan 2008 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32**;Dec 17,1997;Build 2 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; + ; 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. + ; + Q +FILE(RNUM) ; + ; + W:'$G(OCXAUTO) !,$$RNAM(RNUM) + N DIE,XCN,X + S DIE="^TMP(""OCXCMP"",$J,""D CODE"","_RNUM_",",XCN=0,X=$$RNAM(RNUM) + X ^%ZOSF("SAVE") + ; + ; WVEHR/SO 01/24/08 ;Commented out next 2 lines + ; W:'$G(OCXAUTO) " ...",XCM," lines filed." + ; S OCXLCNT=$G(OCXLCNT)+XCM + ; + Q + ; +APPEND(DSUB,CSUB,SRC,LABEL) ; + ; + N OCXSRC,OCXNDX,OCXNEXT,GLD,GLC + S GLD="^TMP(""OCXCMP"",$J,""D CODE"","_(+DSUB)_")" + I (CSUB="$") D Q + .S OCXNEXT=$O(@GLD@(" "),-1)+1 + .S @GLD@(OCXNEXT,0)="$" + .S OCXNEXT=$O(@GLD@(" "),-1)+1 + .S @GLD@(OCXNEXT,0)="" + ; + I (SRC="C") M GLC=^TMP("OCXCMP",$J,"C CODE",+CSUB) S ^TMP("OCXCMP",$J,"D CODE","LINE",LABEL)=DSUB_","_($O(@GLD@(" "),-1)+1) + I (SRC="F") M GLC=^TMP("OCXCMP",$J,"INCLUDE",CSUB) + S OCXNDX=0 F S OCXNDX=$O(GLC(OCXNDX)) Q:'OCXNDX D + .S OCXNEXT=$O(@GLD@(" "),-1)+1 + .S @GLD@(OCXNEXT,0)=GLC(OCXNDX,0) + M @GLD@("CALLS")=GLC("CALLS") + S @GLD@("SIZE")=$G(@GLD@("SIZE"))+$G(GLC("SIZE")) + Q + ; +SIZE(DSUB,CSUB) ; + ; + N D0,EFC,OCXEFC,OCXEFD,OCXEFF,OCXREC + N OCXTEMP,PIEC,SIZEC,SIZED,SIZEF,TEXT + ; + S (SIZEC,SIZED,SIZEF)=0 + K OCXEFF,OCXEFC,OCXEFD + S (OCXEFF,OCXEFC,OCXEFD)="" + ; + I $G(CSUB),$D(^TMP("OCXCMP",$J,"C CODE",+CSUB)) D + .I $D(^TMP("OCXCMP",$J,"C CODE",+CSUB,"SIZE")) D Q + ..S SIZEC=^TMP("OCXCMP",$J,"C CODE",+CSUB,"SIZE") + ..I $D(^TMP("OCXCMP",$J,"C CODE",+CSUB,"CALLS")) D + ...K OCXEFC M OCXEFC=^TMP("OCXCMP",$J,"C CODE",+CSUB,"CALLS") + .K OCXREC M OCXREC=^TMP("OCXCMP",$J,"C CODE",+CSUB) + .S D0=0 F S D0=$O(OCXREC(D0)) Q:'D0 D + ..S TEXT=OCXREC(D0,0),SIZEC=SIZEC+$L(TEXT) + ..Q:'(TEXT["$$") + ..F PIEC=2:1:$L(TEXT,"$$") D + ...S EFC=$P($P(TEXT,"$$",PIEC),"(",1) + ...S:(EFC[" ") EFC=$P(EFC," ",1) Q:(EFC["^") Q:'$L(EFC) + ...I '$D(^TMP("OCXCMP",$J,"INCLUDE",EFC)) D Q + ....D WARN^OCXOCMPV("Unknown Local Extrinsic Function: "_EFC,$P($T(+1)," ",1)) Q + ...S OCXEFC(EFC)="" + .S SIZEC=SIZEC+100 ; ADJUST FOR SUBROUTINE DOCUMENTATION + .S ^TMP("OCXCMP",$J,"C CODE",+CSUB,"SIZE")=SIZEC + .M ^TMP("OCXCMP",$J,"C CODE",+CSUB,"CALLS")=OCXEFC + ; + I $G(DSUB),$D(^TMP("OCXCMP",$J,"D CODE",+DSUB)) D + .I $G(^TMP("OCXCMP",$J,"D CODE",+DSUB,"SIZE")) D Q + ..S SIZED=^TMP("OCXCMP",$J,"D CODE",+DSUB,"SIZE") + ..I $D(^TMP("OCXCMP",$J,"D CODE",+DSUB,"CALLS")) D + ...K OCXEFD M OCXEFD=^TMP("OCXCMP",$J,"D CODE",+DSUB,"CALLS") + ; + K OCXEFF M OCXEFF=OCXEFC,OCXEFF=OCXEFD + ; + I $D(OCXEFF) S EFC="" F S EFC=$O(OCXEFF(EFC)) Q:'$L(EFC) I 'OCXEFF(EFC) D + .K OCXTEMP + .I $D(^TMP("OCXCMP",$J,"INCLUDE",EFC,"SIZE")) M OCXTEMP("SIZE")=^TMP("OCXCMP",$J,"INCLUDE",EFC,"SIZE") + .I $D(^TMP("OCXCMP",$J,"INCLUDE",EFC,"CALLS")) M OCXTEMP("CALLS")=^TMP("OCXCMP",$J,"INCLUDE",EFC,"CALLS") + .S OCXEFF(EFC)=OCXTEMP("SIZE") + .Q:'$D(OCXTEMP("CALLS")) + .S EFC="" F S EFC=$O(OCXTEMP("CALLS",EFC)) Q:'$L(EFC) S OCXEFF(EFC)=+$G(OCXEFF(EFC)) + ; + I $D(OCXEFF) S EFC="" F S EFC=$O(OCXEFF(EFC)) Q:'$L(EFC) S SIZEF=SIZEF+OCXEFF(EFC) + ; + Q $G(SIZEC)+$G(SIZED)+$G(SIZEF) + ; +RNAM(X) ; + N CHAR + S CHAR="0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" + Q "OCXOZ"_$E(CHAR,(X\36+1))_$E(CHAR,(X#36+1)) + ; +TODAY() N X,Y,%DT S X="T",%DT="" D ^%DT X ^DD("DD") Q Y + ; +NOW() N X,Y,%DT S X="N",%DT="T" D ^%DT X ^DD("DD") S:(Y["@") Y=$P(Y,"@",1)_" at "_$P(Y,"@",2,99) Q Y + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOCMPV.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOCMPV.m index c39e6823..1d33d271 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOCMPV.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOCMPV.m @@ -1,231 +1,231 @@ -OCXOCMPV ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Main Entry point - All Rules cont...) ;1/05/04 14:09 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,105,221,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; -MAN ; - I '$D(DUZ) W !!,"DUZ not defined." Q - N OCXD0,OCXD1,OCXWARN,OCXNAM,OCXTRACE,OCXOETIM,OCXAUTO,OCXERRM,OCXTSPI - S OCXWARN=0,OCXOETIM=$H - K ^TMP("OCXCMP",$J) - S ^TMP("OCXCMP",$J)=($P($H,",",2)+($H*86400)+(2*60*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG" - ; - ; Compiler Constants - ; - S OCXCLL=200 ; compiled code line length - S OCXCRS=4000 ; compiled routine size - S OCXTSPI=300 ; Duplicate triggered Rule message "ignore period" in seconds - ; - S OCXTRACE=0,OCXTLOG=0,OCXDLOG=0,OCXAUTO=0,OCXERRM="" - ; - S OCXTRACE=$$READ("Y","Want to enable Compiled Routine Execution Display ","NO") Q:(OCXTRACE[U) - S OCXDLOG=$$READ("Y","Want to enable Logging of incoming raw data ","NO") Q:(OCXDLOG[U) - I OCXDLOG S OCXDLOG=$$READ("N^1:20","Number of days to keep raw data ","3") Q:(OCXDLOG[U) - I OCXDLOG W !!,"*** Note: The raw data log will only hold 200,000 entries. *****",! - I 0 I OCXDLOG S OCXTLOG=$$READ("Y","Want to enable Elapsed Time Logging ","YES") Q:(OCXTLOG[U) - ; - Q:'$$READ("Y","Are you sure you want to recompile the Expert System routines ","NO") - ; - D SETFLAG - L +^OCXD(861,1):5 E D ERMESG("Run aborted. Another compiler run has ^OCXD(861,1) locked.") Q - D RUN^OCXOCMP,BULL(DUZ),KILLFLAG - L -^OCXD(861,1) - ; - ;K ^TMP("OCXCMP",$J) - ; - Q - ; -MESG(OCXX) ; - I '$G(OCXAUTO) W !!,OCXX - I ($G(OCXAUTO)=1) D BMES^XPDUTL(.OCXX) - Q - ; -ERMESG(OCXX) ; - N OCXY S OCXY=OCXX - I '$G(OCXAUTO) W !!,OCXX - I ($G(OCXAUTO)=1) D BMES^XPDUTL(.OCXX) - S OCXERRM=OCXY - Q - ; -WARN(X,FILE,D0,RLINE) ; - ; - Q:$G(OCXWARN) - ; - S OCXWARN=1 - ; - I $G(OCXAUTO) D Q - .D MESG(" Error... "_X) - .D MESG(" Error... File:"_(+$G(FILE))) - .D MESG(" Error... Index:"_(+$G(D0))) - .D MESG(" Error... Order Check Routine Compile Aborted.") - ; - S OCXWARN=$G(OCXWARN)+1 - N OCXSP,OCXST,OCXTXT,OCXLEN,OCXZZZ,OCXCNT - S OCXLEN=60,OCXTXT="Compiler Warning # "_OCXWARN - I ($D(X)>2) S OCXCNT=0 F S OCXCNT=$O(X(OCXCNT)) Q:'OCXCNT D - .I ($L(X(OCXCNT))>OCXLEN),($L(X(OCXCNT))<80) S OCXLEN=$L(X(OCXCNT)) - S (OCXSP,OCXST)="",$P(OCXST,"*",150)="*",$P(OCXSP," ",150)=" " - W !! - W !,$E(OCXST,1,OCXLEN+6) - W !,"**",$E(OCXSP,1,OCXLEN+2),"**" - W !,"** ",OCXTXT,$E(OCXSP,$L(OCXTXT),OCXLEN-1)," **" - W:$L($G(RLINE)) !,"** ",RLINE,$E(OCXSP,$L(RLINE),OCXLEN-1)," **" - W !,"**",$E(OCXSP,1,OCXLEN+2),"**" - S OCXGL="^OCXS" S:(FILE=1) OCXGL="^OCXD" S:(FILE=7) OCXGL="^OCXD" S:(FILE=10) OCXGL="^OCXD" S FILE=FILE/10+860 - I $G(FILE),$G(D0),$D(@OCXGL@(FILE,D0,0)) D - .S OCXTXT=$P(@OCXGL@(FILE,0),U,1) - .W !,"** ",OCXTXT,$E(OCXSP,$L(OCXTXT),OCXLEN-1)," **" - .S OCXTXT=" "_$P(@OCXGL@(FILE,D0,0),U,1) - .W !,"** ",OCXTXT,$E(OCXSP,$L(OCXTXT),OCXLEN-1)," **" - W !,"**",$E(OCXSP,1,OCXLEN+2),"**" - I ($D(X)#2) D - .W !,"** " F OCXCNT=1:1:$L(X," ") D - ..I (($X+$L($P(X," ",OCXCNT)))>OCXLEN) W $E(OCXSP,$X,OCXLEN+2)," **",!,"** " - ..W $P(X," ",OCXCNT)," " - .W $E(OCXSP,$X,OCXLEN+2)," **" - I ($D(X)>2) S OCXCNT=0 F S OCXCNT=$O(X(OCXCNT)) Q:'OCXCNT D - .W !,"** ",X(OCXCNT),$E(OCXSP,$X,OCXLEN+2)," **" - W !,$E(OCXST,1,OCXLEN+6) - W !!!,"Press to continue... " R OCXZZZ:DTIME - Q - K D0 - ; -READ(OCXZ0,OCXZA,OCXZB,OCXZL) ; - N OCXLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT - Q:'$L($G(OCXZ0)) U - S DIR(0)=OCXZ0 - S:$L($G(OCXZA)) DIR("A")=OCXZA - S:$L($G(OCXZB)) DIR("B")=OCXZB - F OCXLINE=1:1:($G(OCXZL)-1) W ! - D ^DIR - I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U - Q Y - ; - Q - ; -DT(X,D) N Y,%DT S %DT=D D ^%DT Q Y - Q - ; -CNT(X) ; - ; - N CNT,D0 - S D0=0 F CNT=1:1 S D0=$O(@X@(D0)) Q:'D0 - W !!,?10,X," ",CNT - Q CNT - ; -AUTO ; - N OCXD0,OCXD1,OCXWARN,OCXNAM,OCXTRACE,OCXAUTO,OCXOETIM,OCXTSPI - S OCXWARN=0,OCXOETIM=$H - K ^TMP("OCXCMP",$J) - S ^TMP("OCXCMP",$J)=($P($H,",",2)+($H*86400)+(2*60*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG" - ; - ; Compiler Constants - ; - S OCXCLL=200 ; compiled code line length - S OCXCRS=8000 ; compiled routine size - S OCXTSPI=300 ; Duplicate triggered Rule message "ignore period" in seconds - ; - S OCXTRACE=0 ; Program Execution Trace Mode (OFF) - S OCXTLOG=0 ; Elapsed time logging (OFF) - S OCXDLOG=0 ; Raw Data Logging (OFF) - S OCXAUTO=1 ; Compile in the Background Mode (ON) - ; - D SETFLAG - L +^OCXD(861,1):5 E D ERMESG("Run aborted. Another compiler run has ^OCXD(861,1) locked."),BULL(DUZ),KILLFLAG Q - D RUN^OCXOCMP,BULL(DUZ),KILLFLAG - L -^OCXD(861,1) - ; - K ^TMP("OCXCMP",$J) - ; - Q - ; -BULL(OCXDUZ) ; - I $L($T(^XMB)) D - .; - .N XMB,XMDUZ,XMY,OCXTIME - .S OCXTIME=$H-OCXOETIM*86400 - .S OCXTIME=OCXTIME+($P($H,",",2)-$P(OCXOETIM,",",2)) - .S XMB="OCX COMPILER RUN" - .S XMB(1)=$P($T(+3),";;",3) - .S XMB(2)=$$CONV($$DATE) - .S XMB(3)="" - .S:$G(OCXDUZ) XMB(3)="["_OCXDUZ_"] "_$P($G(^VA(200,OCXDUZ,0)),U,1) - .S XMB(4)=(OCXTIME\60)_" minutes "_(OCXTIME#60)_" seconds " - .S XMB(5)=$S(($G(OCXAUTO)>1):"Queued",$G(OCXAUTO):"Automatic Mode",1:"Interactive Mode") - .S XMB(6)=$S($G(OCXTRACE):" ON",1:"OFF") - .S XMB(7)=" " ; $S($G(OCXTLOG):" ON",1:"OFF") - .S XMB(8)=$S($G(OCXDLOG):(" ON Keep data for "_OCXDLOG_" day"_$S(OCXDLOG=1:"",1:"s")_" then purge."),1:"OFF") - .S XMB(9)="No longer tracked" ; $S($G(OCXLCNT):OCXLCNT,1:"Zero") - .S XMB(10)=$G(OCXERRM) - .S XMB(11)=$S($L($G(OCXERRM)):"ABORTED",1:"has completed normally") - .S XMY("G.OCX DEVELOPERS@ISC-SLC.VA.GOV")="" - .S XMY("G.OCX DEVELOPERS")="" - .S XMY(OCXDUZ)="" - .S XMDUZ=.5 - .S XMDT="N" - .D ^XMB - ; - Q - ; -DATE() N X,Y,%DT S X="N",%DT="T" D ^%DT X ^DD("DD") Q Y - ; -CONV(Y) Q:'(Y["@") Y Q $P(Y,"@",1)_" at "_$P(Y,"@",2,99) - ; -SETFLAG ; - I '($P($G(^OCXD(861,1,0)),U,1)="SITE PREFERENCES") K ^OCXD(861,1) S ^OCXD(861,1,0)="SITE PREFERENCES" - S $P(^OCXD(861,1,0),U,3)=$H - Q - ; -KILLFLAG ; - ; - I '($P($G(^OCXD(861,1,0)),U,1)="SITE PREFERENCES") K ^OCXD(861,1) S ^OCXD(861,1,0)="SITE PREFERENCES" - S $P(^OCXD(861,1,0),U,3)="" - Q - ; -QUE(OCXADD) ; - ; - N ZTCPU,ZTDESC,ZTDTH,ZTIO,ZTPAR,ZTPRE,ZTPRI,ZTRTN,ZTSAVE,ZTSK,ZTUCI - N OCXDUZ - ; - S ZTDTH=$P($H,",",2)+OCXADD,OCXADD=0 - I (ZTDTH>86400) S ZTDTH=(86400-ZTDTH),OCXADD=1 - S ZTDTH=($H+OCXADD)_","_ZTDTH - S OCXDUZ=$G(DUZ) - S ZTIO="",ZTRTN="TASK^OCXOCMPV",ZTDESC="Queued Compiler: "_$P($T(+3),";;",2) - K ZTSAVE,ZTCPU,ZTUCI,ZTPRI,ZTPAR,ZTPRE - S ZTSAVE("OCXDUZ")="" - ; - D ^%ZTLOAD - ; - Q - ; -TASK ; - ; - N OCXD0,OCXD1,OCXWARN,OCXNAM,OCXTRACE,OCXAUTO,OCXOETIM,OCXTSPI - S OCXWARN=0,OCXOETIM=$H - K ^TMP("OCXCMP",$J) - S ^TMP("OCXCMP",$J)=($P($H,",",2)+($H*86400)+(2*60*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG" - ; - ; Compiler Constants - ; - S OCXCLL=200 ; compiled code line length - S OCXCRS=8000 ; compiled routine size - S OCXTSPI=300 ; Duplicate triggered Rule message "ignore period" in seconds - ; - S OCXDATA="0^0^0" - I $L($T(CDATA^OCXOZ01)) S OCXDATA=$$CDATA^OCXOZ01 - ; - S OCXTRACE=$P(OCXDATA,U,1),OCXTLOG=$P(OCXDATA,U,2),OCXDLOG=$P(OCXDATA,U,3) - ; - S OCXAUTO=2 ; Compile in the Background Mode (ON QUEUED) - ; - D SETFLAG - L +^OCXD(861,1):5 E D QUE^OCXOCMPV(300),ERMESG("Run rescheduled. Another compiler run has ^OCXD(861,1) locked."),BULL(OCXDUZ),KILLFLAG Q - D RUN^OCXOCMP,BULL(OCXDUZ),KILLFLAG - L -^OCXD(861,1) - ; - K ^TMP("OCXCMP",$J) - ; - I $G(ZTSK) D KILL^%ZTLOAD - ; - Q - ; +OCXOCMPV ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Main Entry point - All Rules cont...) ;1/05/04 14:09 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,105,221**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; +MAN ; + I '$D(DUZ) W !!,"DUZ not defined." Q + N OCXD0,OCXD1,OCXWARN,OCXNAM,OCXTRACE,OCXOETIM,OCXLCNT,OCXAUTO,OCXERRM,OCXTSPI + S OCXWARN=0,OCXOETIM=$H + K ^TMP("OCXCMP",$J) + S ^TMP("OCXCMP",$J)=($P($H,",",2)+($H*86400)+(2*60*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG" + ; + ; Compiler Constants + ; + S OCXCLL=200 ; compiled code line length + S OCXCRS=4000 ; compiled routine size + S OCXTSPI=300 ; Duplicate triggered Rule message "ignore period" in seconds + ; + S OCXTRACE=0,OCXTLOG=0,OCXDLOG=0,OCXAUTO=0,OCXERRM="" + ; + S OCXTRACE=$$READ("Y","Want to enable Compiled Routine Execution Display ","NO") Q:(OCXTRACE[U) + S OCXDLOG=$$READ("Y","Want to enable Logging of incoming raw data ","NO") Q:(OCXDLOG[U) + I OCXDLOG S OCXDLOG=$$READ("N^1:20","Number of days to keep raw data ","3") Q:(OCXDLOG[U) + I OCXDLOG W !!,"*** Note: The raw data log will only hold 200,000 entries. *****",! + I 0 I OCXDLOG S OCXTLOG=$$READ("Y","Want to enable Elapsed Time Logging ","YES") Q:(OCXTLOG[U) + ; + Q:'$$READ("Y","Are you sure you want to recompile the Expert System routines ","NO") + ; + D SETFLAG + L +^OCXD(861,1):5 E D ERMESG("Run aborted. Another compiler run has ^OCXD(861,1) locked.") Q + D RUN^OCXOCMP,BULL(DUZ),KILLFLAG + L -^OCXD(861,1) + ; + ;K ^TMP("OCXCMP",$J) + ; + Q + ; +MESG(OCXX) ; + I '$G(OCXAUTO) W !!,OCXX + I ($G(OCXAUTO)=1) D BMES^XPDUTL(.OCXX) + Q + ; +ERMESG(OCXX) ; + N OCXY S OCXY=OCXX + I '$G(OCXAUTO) W !!,OCXX + I ($G(OCXAUTO)=1) D BMES^XPDUTL(.OCXX) + S OCXERRM=OCXY + Q + ; +WARN(X,FILE,D0,RLINE) ; + ; + Q:$G(OCXWARN) + ; + S OCXWARN=1 + ; + I $G(OCXAUTO) D Q + .D MESG(" Error... "_X) + .D MESG(" Error... File:"_(+$G(FILE))) + .D MESG(" Error... Index:"_(+$G(D0))) + .D MESG(" Error... Order Check Routine Compile Aborted.") + ; + S OCXWARN=$G(OCXWARN)+1 + N OCXSP,OCXST,OCXTXT,OCXLEN,OCXZZZ,OCXCNT + S OCXLEN=60,OCXTXT="Compiler Warning # "_OCXWARN + I ($D(X)>2) S OCXCNT=0 F S OCXCNT=$O(X(OCXCNT)) Q:'OCXCNT D + .I ($L(X(OCXCNT))>OCXLEN),($L(X(OCXCNT))<80) S OCXLEN=$L(X(OCXCNT)) + S (OCXSP,OCXST)="",$P(OCXST,"*",150)="*",$P(OCXSP," ",150)=" " + W !! + W !,$E(OCXST,1,OCXLEN+6) + W !,"**",$E(OCXSP,1,OCXLEN+2),"**" + W !,"** ",OCXTXT,$E(OCXSP,$L(OCXTXT),OCXLEN-1)," **" + W:$L($G(RLINE)) !,"** ",RLINE,$E(OCXSP,$L(RLINE),OCXLEN-1)," **" + W !,"**",$E(OCXSP,1,OCXLEN+2),"**" + S OCXGL="^OCXS" S:(FILE=1) OCXGL="^OCXD" S:(FILE=7) OCXGL="^OCXD" S:(FILE=10) OCXGL="^OCXD" S FILE=FILE/10+860 + I $G(FILE),$G(D0),$D(@OCXGL@(FILE,D0,0)) D + .S OCXTXT=$P(@OCXGL@(FILE,0),U,1) + .W !,"** ",OCXTXT,$E(OCXSP,$L(OCXTXT),OCXLEN-1)," **" + .S OCXTXT=" "_$P(@OCXGL@(FILE,D0,0),U,1) + .W !,"** ",OCXTXT,$E(OCXSP,$L(OCXTXT),OCXLEN-1)," **" + W !,"**",$E(OCXSP,1,OCXLEN+2),"**" + I ($D(X)#2) D + .W !,"** " F OCXCNT=1:1:$L(X," ") D + ..I (($X+$L($P(X," ",OCXCNT)))>OCXLEN) W $E(OCXSP,$X,OCXLEN+2)," **",!,"** " + ..W $P(X," ",OCXCNT)," " + .W $E(OCXSP,$X,OCXLEN+2)," **" + I ($D(X)>2) S OCXCNT=0 F S OCXCNT=$O(X(OCXCNT)) Q:'OCXCNT D + .W !,"** ",X(OCXCNT),$E(OCXSP,$X,OCXLEN+2)," **" + W !,$E(OCXST,1,OCXLEN+6) + W !!!,"Press to continue... " R OCXZZZ:DTIME + Q + K D0 + ; +READ(OCXZ0,OCXZA,OCXZB,OCXZL) ; + N OCXLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT + Q:'$L($G(OCXZ0)) U + S DIR(0)=OCXZ0 + S:$L($G(OCXZA)) DIR("A")=OCXZA + S:$L($G(OCXZB)) DIR("B")=OCXZB + F OCXLINE=1:1:($G(OCXZL)-1) W ! + D ^DIR + I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U + Q Y + ; + Q + ; +DT(X,D) N Y,%DT S %DT=D D ^%DT Q Y + Q + ; +CNT(X) ; + ; + N CNT,D0 + S D0=0 F CNT=1:1 S D0=$O(@X@(D0)) Q:'D0 + W !!,?10,X," ",CNT + Q CNT + ; +AUTO ; + N OCXD0,OCXD1,OCXWARN,OCXNAM,OCXTRACE,OCXAUTO,OCXOETIM,OCXLCNT,OCXTSPI + S OCXWARN=0,OCXOETIM=$H + K ^TMP("OCXCMP",$J) + S ^TMP("OCXCMP",$J)=($P($H,",",2)+($H*86400)+(2*60*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG" + ; + ; Compiler Constants + ; + S OCXCLL=200 ; compiled code line length + S OCXCRS=8000 ; compiled routine size + S OCXTSPI=300 ; Duplicate triggered Rule message "ignore period" in seconds + ; + S OCXTRACE=0 ; Program Execution Trace Mode (OFF) + S OCXTLOG=0 ; Elapsed time logging (OFF) + S OCXDLOG=0 ; Raw Data Logging (OFF) + S OCXAUTO=1 ; Compile in the Background Mode (ON) + ; + D SETFLAG + L +^OCXD(861,1):5 E D ERMESG("Run aborted. Another compiler run has ^OCXD(861,1) locked."),BULL(DUZ),KILLFLAG Q + D RUN^OCXOCMP,BULL(DUZ),KILLFLAG + L -^OCXD(861,1) + ; + K ^TMP("OCXCMP",$J) + ; + Q + ; +BULL(OCXDUZ) ; + I $L($T(^XMB)) D + .; + .N XMB,XMDUZ,XMY,OCXTIME + .S OCXTIME=$H-OCXOETIM*86400 + .S OCXTIME=OCXTIME+($P($H,",",2)-$P(OCXOETIM,",",2)) + .S XMB="OCX COMPILER RUN" + .S XMB(1)=$P($T(+3),";;",3) + .S XMB(2)=$$CONV($$DATE) + .S XMB(3)="" + .S:$G(OCXDUZ) XMB(3)="["_OCXDUZ_"] "_$P($G(^VA(200,OCXDUZ,0)),U,1) + .S XMB(4)=(OCXTIME\60)_" minutes "_(OCXTIME#60)_" seconds " + .S XMB(5)=$S(($G(OCXAUTO)>1):"Queued",$G(OCXAUTO):"Automatic Mode",1:"Interactive Mode") + .S XMB(6)=$S($G(OCXTRACE):" ON",1:"OFF") + .S XMB(7)=" " ; $S($G(OCXTLOG):" ON",1:"OFF") + .S XMB(8)=$S($G(OCXDLOG):(" ON Keep data for "_OCXDLOG_" day"_$S(OCXDLOG=1:"",1:"s")_" then purge."),1:"OFF") + .S XMB(9)=$S($G(OCXLCNT):OCXLCNT,1:"Zero") + .S XMB(10)=$G(OCXERRM) + .S XMB(11)=$S($L($G(OCXERRM)):"ABORTED",1:"has completed normally") + .S XMY("G.OCX DEVELOPERS@ISC-SLC.VA.GOV")="" + .S XMY("G.OCX DEVELOPERS")="" + .S XMY(OCXDUZ)="" + .S XMDUZ=.5 + .S XMDT="N" + .D ^XMB + ; + Q + ; +DATE() N X,Y,%DT S X="N",%DT="T" D ^%DT X ^DD("DD") Q Y + ; +CONV(Y) Q:'(Y["@") Y Q $P(Y,"@",1)_" at "_$P(Y,"@",2,99) + ; +SETFLAG ; + I '($P($G(^OCXD(861,1,0)),U,1)="SITE PREFERENCES") K ^OCXD(861,1) S ^OCXD(861,1,0)="SITE PREFERENCES" + S $P(^OCXD(861,1,0),U,3)=$H + Q + ; +KILLFLAG ; + ; + I '($P($G(^OCXD(861,1,0)),U,1)="SITE PREFERENCES") K ^OCXD(861,1) S ^OCXD(861,1,0)="SITE PREFERENCES" + S $P(^OCXD(861,1,0),U,3)="" + Q + ; +QUE(OCXADD) ; + ; + N ZTCPU,ZTDESC,ZTDTH,ZTIO,ZTPAR,ZTPRE,ZTPRI,ZTRTN,ZTSAVE,ZTSK,ZTUCI + N OCXDUZ + ; + S ZTDTH=$P($H,",",2)+OCXADD,OCXADD=0 + I (ZTDTH>86400) S ZTDTH=(86400-ZTDTH),OCXADD=1 + S ZTDTH=($H+OCXADD)_","_ZTDTH + S OCXDUZ=$G(DUZ) + S ZTIO="",ZTRTN="TASK^OCXOCMPV",ZTDESC="Queued Compiler: "_$P($T(+3),";;",2) + K ZTSAVE,ZTCPU,ZTUCI,ZTPRI,ZTPAR,ZTPRE + S ZTSAVE("OCXDUZ")="" + ; + D ^%ZTLOAD + ; + Q + ; +TASK ; + ; + N OCXD0,OCXD1,OCXWARN,OCXNAM,OCXTRACE,OCXAUTO,OCXOETIM,OCXLCNT,OCXTSPI + S OCXWARN=0,OCXOETIM=$H + K ^TMP("OCXCMP",$J) + S ^TMP("OCXCMP",$J)=($P($H,",",2)+($H*86400)+(2*60*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG" + ; + ; Compiler Constants + ; + S OCXCLL=200 ; compiled code line length + S OCXCRS=8000 ; compiled routine size + S OCXTSPI=300 ; Duplicate triggered Rule message "ignore period" in seconds + ; + S OCXDATA="0^0^0" + I $L($T(CDATA^OCXOZ01)) S OCXDATA=$$CDATA^OCXOZ01 + ; + S OCXTRACE=$P(OCXDATA,U,1),OCXTLOG=$P(OCXDATA,U,2),OCXDLOG=$P(OCXDATA,U,3) + ; + S OCXAUTO=2 ; Compile in the Background Mode (ON QUEUED) + ; + D SETFLAG + L +^OCXD(861,1):5 E D QUE^OCXOCMPV(300),ERMESG("Run rescheduled. Another compiler run has ^OCXD(861,1) locked."),BULL(OCXDUZ),KILLFLAG Q + D RUN^OCXOCMP,BULL(OCXDUZ),KILLFLAG + L -^OCXD(861,1) + ; + K ^TMP("OCXCMP",$J) + ; + I $G(ZTSK) D KILL^%ZTLOAD + ; + Q + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ01.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ01.m index 05f2afa1..f9bb29e4 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ01.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ01.m @@ -1,198 +1,198 @@ -OCXOZ01 ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; - ; *************************************************************** - ; ** Warning: This routine is automatically generated by the ** - ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** - ; ** will be lost the next time the rule compiler executes. ** - ; *************************************************************** - ; - ; compiled code line length: 200 - ; compiled routine size: 8000 - ; triggered rule ignore period: 300 - ; - ; Program Execution Trace Mode: OFF - ; - ; Raw Data Logging: OFF - ; Compiler mode: ON - ; Compiled by: DEWAYNE,ROBERT (DUZ=9) - Q - ; -LOG() ; Returns the number of days to keep the Raw Data Log or 0 if logging is disabled. - ; External Call. - ; - Q 0 - ; -CDATA() ; Returns compiler flags, Execution TRACE ON/OFF, Time Logging ON/OFF, and Raw Data Logging ON/OFF - ; External Call. - ; - Q "0^0^0" - ; -UPDATE(DFN,OCXSRC,OUTMSG) ; Main Entry point for evaluating Rules. - ; External Call. - ; - ; - K ^TMP("OCXCHK",$J) - S ^TMP("OCXCHK",$J)=($P($H,",",2)+($H*86400)+(2*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG" - N OCXOERR,OCXOCMSG,OCXNDX,OCXDF,OCXX,OCXTSPI - S OCXTSPI=300 - Q:'$G(DFN) - I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D GETDF,SWAPOUT("OCXODATA",.OCXODATA) - I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D CHK1^OCXOZ02 - I ($G(OCXOSRC)="DGPM PATIENT MOVEMENT PROTOCOL") D CHK23^OCXOZ03 - I ($G(OCXOSRC)="CPRS ORDER PRESCAN") D CHK58^OCXOZ05 - I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D CHK95^OCXOZ06 - ; - D SCAN - ; - I $O(OCXOCMSG("")) D - .N OCXNDX1,OCXNDX2 - .S OCXNDX1=0 F S OCXNDX1=$O(OCXOCMSG(OCXNDX1)) Q:'OCXNDX1 D - ..S OCXNDX2=0 F S OCXNDX2=$O(OUTMSG(OCXNDX2)) Q:'OCXNDX2 Q:(OUTMSG(OCXNDX2)=OCXOCMSG(OCXNDX1)) - ..Q:OCXNDX2 S OUTMSG($O(OUTMSG(999999),-1)+1)=OCXOCMSG(OCXNDX1) - K ^TMP("OCXCHK",$J) - ; - I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") K OCXDF D SWAPIN("OCXODATA",.OCXODATA) - Q - ; -GETDF ;This subroutine loads the OCXDF data field array from variables in the environment. - ; Called from UPDATE+9. - ; - Q:$G(OCXOERR) - ; - ; Local GETDF Variables - ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT) - ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) - ; OCXDF(5) ----> Data Field: ORDER PRIORITY (OBR) (FREE TEXT) - ; OCXDF(6) ----> Data Field: ABNORMAL FLAG (FREE TEXT) - ; OCXDF(9) ----> Data Field: ORDER ST D/T (DATE/TIME) - ; OCXDF(12) ---> Data Field: LAB RESULT (FREE TEXT) - ; OCXDF(13) ---> Data Field: LAB COLLECTION D/T (DATE/TIME) - ; OCXDF(15) ---> Data Field: RESULT STATUS (OBX) (FREE TEXT) - ; OCXDF(21) ---> Data Field: ORDER PRIORITY (ORC) (FREE TEXT) - ; OCXDF(23) ---> Data Field: REQUEST STATUS (OBR) (FREE TEXT) - ; OCXDF(24) ---> Data Field: ORDERABLE ITEM LOCAL TEXT (FREE TEXT) - ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(82) ---> Data Field: PHARMACY LOCAL ORDERABLE ITEM TEXT (FREE TEXT) - ; OCXDF(113) --> Data Field: LAB TEST ID (NUMERIC) - ; OCXDF(152) --> Data Field: LAB SPECIMEN ID (NUMERIC) - ; - ; Local Extrinsic Functions - ; DT2INT( ----------> CONVERT DATE FROM FILEMAN FORMAT TO OCX FORMAT - ; - S OCXDF(1)=$P($G(OCXODATA("ORC",1)),"^",1) - S OCXDF(2)=$P($G(OCXODATA("ORC",3)),"^",2) - S OCXDF(5)=$P($P($G(OCXODATA("OBR",27)),"^",6),";",1) - S OCXDF(6)=$P($G(OCXODATA("OBX",8)),"^",1) - S OCXDF(9)=$$DT2INT($P($G(OCXODATA("ORC",15)),"^",1)) - S OCXDF(12)=$P($G(OCXODATA("OBX",5)),"^",1) - S OCXDF(13)=$$DT2INT($P($G(OCXODATA("OBR",7)),"^",1)) - S OCXDF(15)=$P($G(OCXODATA("OBX",11)),"^",1) - S OCXDF(21)=$P($G(OCXODATA("ORC",7)),"^",6) - S OCXDF(23)=$P($G(OCXODATA("OBR",25)),"^",1) - S OCXDF(24)=$P($G(OCXODATA("OBR",4)),"^",5) - S OCXDF(34)=$P($G(OCXODATA("ORC",2)),"^",1) - S OCXDF(37)=$G(OCXODATA("PID",3)) - S OCXDF(82)=$P($G(OCXODATA("RXO",1)),"^",5) - S OCXDF(113)=$P($G(OCXODATA("OBX",3)),"^",4) - S OCXDF(152)=$P($P($G(OCXODATA("OBR",15)),"^",4),";",1) - Q - ; -SWAPOUT(NAME,ARRAY) ; - ; Called from UPDATE+9. - ; - Q:$G(OCXOERR) - ; - Q:'$L(NAME) - K ^TMP("OCXSWAP",$J,NAME) - S ^TMP("OCXSWAP",$J)=($P($H,",",2)+($H*86400)+(2*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG" - M ^TMP("OCXSWAP",$J,NAME)=ARRAY - K ARRAY - Q - ; -SWAPIN(NAME,ARRAY) ; - ; Called from UPDATE+24. - ; - Q:$G(OCXOERR) - ; - Q:'$L(NAME) - K ARRAY - M ARRAY=^TMP("OCXSWAP",$J,NAME) - K ^TMP("OCXSWAP",$J,NAME) - Q - ; -SCAN ; Tests all Rules for Event/Elements that were found to be valid in the UPDATE subroutine. - ; Called from UPDATE+15. - ; - Q:$G(OCXOERR) - ; - ; - N OCXD0,OCXRULE S OCXD0=0 F S OCXD0=$O(^TMP("OCXCHK",$J,DFN,OCXD0)) Q:'OCXD0 D - .Q:'($G(^TMP("OCXCHK",$J,DFN,OCXD0))=1) - .N OCXPGM S OCXPGM=$O(^OCXS(860.3,"APGM",OCXD0,"")) Q:'$L(OCXPGM) X "I $L($T("_OCXPGM_"))" E Q - .D @OCXPGM - .S ^TMP("OCXCHK",$J,DFN,OCXD0)=$G(^TMP("OCXCHK",$J,DFN,OCXD0))+10 - K ^TMP("OCXCHK",$J) - Q - ; -TERM(OCXTERM,OCXLIST) ; Local Term Lookup - ; Internal Call. - ; - Q:$G(OCXOERR) - ; - Q:'$L(OCXTERM) 0 - ; - N FILE,IEN,LINE,LTERM,NTERM,TEXT S FILE=0 K OCXLIST - F LINE=1:1:999 S TEXT=$T(TERM+LINE) Q:$P(TEXT,";",2) I ($E(TEXT,2,3)=";;") D - .S TEXT=$P(TEXT,";;",2) - .S NTERM=$P(TEXT,U,1) Q:'$L(NTERM) Q:'(OCXTERM=NTERM) - .S FILE=$P(TEXT,U,2),IEN=$P(TEXT,U,3),LTERM=$P(TEXT,U,4) - .S OCXLIST(IEN)=LTERM,OCXLIST("B",LTERM,IEN)="" - ; - Q FILE - ; - ;TERM DATA; - ;1; - ; - Q - ; -DT2INT(OCXDT) ; This Local Extrinsic Function converts a date into an integer - ; By taking the Years, Months, Days, Hours and Minutes converting - ; Them into Seconds and then adding them all together into one big integer - ; - Q:'$L($G(OCXDT)) "" - N OCXDIFF,OCXVAL S (OCXDIFF,OCXVAL)=0 - ; - I $L(OCXDT),'OCXDT,(OCXDT[" at ") D ; EXTERNAL EXPERT SYSTEM FORMAT 1 TO EXTERNAL FORMAT - .N OCXHR,OCXMIN,OCXTIME - .S OCXTIME=$P($P(OCXDT," at ",2),".",1),OCXHR=$P(OCXTIME,":",1),OCXMIN=$P(OCXTIME,":",2) - .S:(OCXDT["Midnight") OCXHR=00 - .S:(OCXDT["PM") OCXHR=OCXHR+12 - .S OCXDT=$P(OCXDT," at ")_"@"_$E(OCXHR+100,2,3)_$E(OCXMIN+100,2,3) - ; - I $L(OCXDT),(OCXDT?1.2N1"/"1.2N.1" ".2N.1":".2N) D ; EXTERNAL EXPERT SYSTEM FORMAT 2 TO EXTERNAL FORMAT - .N OCXMON - .S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,$P(OCXDT,"/",1)) - .I $L($P(OCXDT," ",2)) S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_"@"_$TR($P(OCXDT," ",2),":","") - .E S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2) - ; - I $L(OCXDT),(OCXDT?1.2N1"/"1.2N1"/"1.2N.1" ".2N.1":".2N) D ; EXTERNAL EXPERT SYSTEM FORMAT 3 TO EXTERNAL FORMAT - .N OCXMON - .S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,$P(OCXDT,"/",1)) - .I $L($P(OCXDT," ",2)) S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_","_$P($P(OCXDT," ",1),"/",3)_"@"_$TR($P(OCXDT," ",2),":","") - .E S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_", "_$P($P(OCXDT," ",1),"/",3) - ; - I $L(OCXDT),'OCXDT D ; EXTERNAL FORMAT TO INTERNAL FILEMAN FORMAT - .I (OCXDT["@0000") S OCXDT=$P(OCXDT,"@",1),OCXDIFF=1 - .N %DT,X,Y S X=OCXDT,%DT="" S:(OCXDT["@")!(OCXDT="N") %DT="T" D ^%DT S OCXDT=+Y - ; - I ($L(OCXDT\1)>7) S OCXDT=$$HL7TFM^XLFDT(OCXDT) ; HL7 FORMAT TO INTERNAL FILEMAN FORMAT - ; - I ($L(OCXDT\1)=7) S OCXDT=$$FMTH^XLFDT(+OCXDT) ; INTERNAL FILEMAN FORMAT TO $H FORMAT - ; - I (OCXDT?5N1","1.5N) S OCXVAL=(OCXDT*86400)+$P(OCXDT,",",2) ; $H FORMAT TO EXPERT SYSTEM INTERNAL FORMAT - ; - Q OCXVAL - ; +OCXOZ01 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; + ; *************************************************************** + ; ** Warning: This routine is automatically generated by the ** + ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** + ; ** will be lost the next time the rule compiler executes. ** + ; *************************************************************** + ; + ; compiled code line length: 200 + ; compiled routine size: 8000 + ; triggered rule ignore period: 300 + ; + ; Program Execution Trace Mode: OFF + ; + ; Raw Data Logging: OFF + ; Compiler mode: ON + ; Compiled by: ORMSBY,SKIP (DUZ=1) + Q + ; +LOG() ; Returns the number of days to keep the Raw Data Log or 0 if logging is disabled. + ; External Call. + ; + Q 0 + ; +CDATA() ; Returns compiler flags, Execution TRACE ON/OFF, Time Logging ON/OFF, and Raw Data Logging ON/OFF + ; External Call. + ; + Q "0^0^0" + ; +UPDATE(DFN,OCXSRC,OUTMSG) ; Main Entry point for evaluating Rules. + ; External Call. + ; + ; + K ^TMP("OCXCHK",$J) + S ^TMP("OCXCHK",$J)=($P($H,",",2)+($H*86400)+(2*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG" + N OCXOERR,OCXOCMSG,OCXNDX,OCXDF,OCXX,OCXTSPI + S OCXTSPI=300 + Q:'$G(DFN) + I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D GETDF,SWAPOUT("OCXODATA",.OCXODATA) + I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D CHK1^OCXOZ02 + I ($G(OCXOSRC)="DGPM PATIENT MOVEMENT PROTOCOL") D CHK23^OCXOZ03 + I ($G(OCXOSRC)="CPRS ORDER PRESCAN") D CHK58^OCXOZ05 + I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D CHK95^OCXOZ06 + ; + D SCAN + ; + I $O(OCXOCMSG("")) D + .N OCXNDX1,OCXNDX2 + .S OCXNDX1=0 F S OCXNDX1=$O(OCXOCMSG(OCXNDX1)) Q:'OCXNDX1 D + ..S OCXNDX2=0 F S OCXNDX2=$O(OUTMSG(OCXNDX2)) Q:'OCXNDX2 Q:(OUTMSG(OCXNDX2)=OCXOCMSG(OCXNDX1)) + ..Q:OCXNDX2 S OUTMSG($O(OUTMSG(999999),-1)+1)=OCXOCMSG(OCXNDX1) + K ^TMP("OCXCHK",$J) + ; + I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") K OCXDF D SWAPIN("OCXODATA",.OCXODATA) + Q + ; +GETDF ;This subroutine loads the OCXDF data field array from variables in the environment. + ; Called from UPDATE+9. + ; + Q:$G(OCXOERR) + ; + ; Local GETDF Variables + ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT) + ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) + ; OCXDF(5) ----> Data Field: ORDER PRIORITY (OBR) (FREE TEXT) + ; OCXDF(6) ----> Data Field: ABNORMAL FLAG (FREE TEXT) + ; OCXDF(9) ----> Data Field: ORDER ST D/T (DATE/TIME) + ; OCXDF(12) ---> Data Field: LAB RESULT (FREE TEXT) + ; OCXDF(13) ---> Data Field: LAB COLLECTION D/T (DATE/TIME) + ; OCXDF(15) ---> Data Field: RESULT STATUS (OBX) (FREE TEXT) + ; OCXDF(21) ---> Data Field: ORDER PRIORITY (ORC) (FREE TEXT) + ; OCXDF(23) ---> Data Field: REQUEST STATUS (OBR) (FREE TEXT) + ; OCXDF(24) ---> Data Field: ORDERABLE ITEM LOCAL TEXT (FREE TEXT) + ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(82) ---> Data Field: PHARMACY LOCAL ORDERABLE ITEM TEXT (FREE TEXT) + ; OCXDF(113) --> Data Field: LAB TEST ID (NUMERIC) + ; OCXDF(152) --> Data Field: LAB SPECIMEN ID (NUMERIC) + ; + ; Local Extrinsic Functions + ; DT2INT( ----------> CONVERT DATE FROM FILEMAN FORMAT TO OCX FORMAT + ; + S OCXDF(1)=$P($G(OCXODATA("ORC",1)),"^",1) + S OCXDF(2)=$P($G(OCXODATA("ORC",3)),"^",2) + S OCXDF(5)=$P($P($G(OCXODATA("OBR",27)),"^",6),";",1) + S OCXDF(6)=$P($G(OCXODATA("OBX",8)),"^",1) + S OCXDF(9)=$$DT2INT($P($G(OCXODATA("ORC",15)),"^",1)) + S OCXDF(12)=$P($G(OCXODATA("OBX",5)),"^",1) + S OCXDF(13)=$$DT2INT($P($G(OCXODATA("OBR",7)),"^",1)) + S OCXDF(15)=$P($G(OCXODATA("OBX",11)),"^",1) + S OCXDF(21)=$P($G(OCXODATA("ORC",7)),"^",6) + S OCXDF(23)=$P($G(OCXODATA("OBR",25)),"^",1) + S OCXDF(24)=$P($G(OCXODATA("OBR",4)),"^",5) + S OCXDF(34)=$P($G(OCXODATA("ORC",2)),"^",1) + S OCXDF(37)=$G(OCXODATA("PID",3)) + S OCXDF(82)=$P($G(OCXODATA("RXO",1)),"^",5) + S OCXDF(113)=$P($G(OCXODATA("OBX",3)),"^",4) + S OCXDF(152)=$P($P($G(OCXODATA("OBR",15)),"^",4),";",1) + Q + ; +SWAPOUT(NAME,ARRAY) ; + ; Called from UPDATE+9. + ; + Q:$G(OCXOERR) + ; + Q:'$L(NAME) + K ^TMP("OCXSWAP",$J,NAME) + S ^TMP("OCXSWAP",$J)=($P($H,",",2)+($H*86400)+(2*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG" + M ^TMP("OCXSWAP",$J,NAME)=ARRAY + K ARRAY + Q + ; +SWAPIN(NAME,ARRAY) ; + ; Called from UPDATE+24. + ; + Q:$G(OCXOERR) + ; + Q:'$L(NAME) + K ARRAY + M ARRAY=^TMP("OCXSWAP",$J,NAME) + K ^TMP("OCXSWAP",$J,NAME) + Q + ; +SCAN ; Tests all Rules for Event/Elements that were found to be valid in the UPDATE subroutine. + ; Called from UPDATE+15. + ; + Q:$G(OCXOERR) + ; + ; + N OCXD0,OCXRULE S OCXD0=0 F S OCXD0=$O(^TMP("OCXCHK",$J,DFN,OCXD0)) Q:'OCXD0 D + .Q:'($G(^TMP("OCXCHK",$J,DFN,OCXD0))=1) + .N OCXPGM S OCXPGM=$O(^OCXS(860.3,"APGM",OCXD0,"")) Q:'$L(OCXPGM) X "I $L($T("_OCXPGM_"))" E Q + .D @OCXPGM + .S ^TMP("OCXCHK",$J,DFN,OCXD0)=$G(^TMP("OCXCHK",$J,DFN,OCXD0))+10 + K ^TMP("OCXCHK",$J) + Q + ; +TERM(OCXTERM,OCXLIST) ; Local Term Lookup + ; Internal Call. + ; + Q:$G(OCXOERR) + ; + Q:'$L(OCXTERM) 0 + ; + N FILE,IEN,LINE,LTERM,NTERM,TEXT S FILE=0 K OCXLIST + F LINE=1:1:999 S TEXT=$T(TERM+LINE) Q:$P(TEXT,";",2) I ($E(TEXT,2,3)=";;") D + .S TEXT=$P(TEXT,";;",2) + .S NTERM=$P(TEXT,U,1) Q:'$L(NTERM) Q:'(OCXTERM=NTERM) + .S FILE=$P(TEXT,U,2),IEN=$P(TEXT,U,3),LTERM=$P(TEXT,U,4) + .S OCXLIST(IEN)=LTERM,OCXLIST("B",LTERM,IEN)="" + ; + Q FILE + ; + ;TERM DATA; + ;1; + ; + Q + ; +DT2INT(OCXDT) ; This Local Extrinsic Function converts a date into an integer + ; By taking the Years, Months, Days, Hours and Minutes converting + ; Them into Seconds and then adding them all together into one big integer + ; + Q:'$L($G(OCXDT)) "" + N OCXDIFF,OCXVAL S (OCXDIFF,OCXVAL)=0 + ; + I $L(OCXDT),'OCXDT,(OCXDT[" at ") D ; EXTERNAL EXPERT SYSTEM FORMAT 1 TO EXTERNAL FORMAT + .N OCXHR,OCXMIN,OCXTIME + .S OCXTIME=$P($P(OCXDT," at ",2),".",1),OCXHR=$P(OCXTIME,":",1),OCXMIN=$P(OCXTIME,":",2) + .S:(OCXDT["Midnight") OCXHR=00 + .S:(OCXDT["PM") OCXHR=OCXHR+12 + .S OCXDT=$P(OCXDT," at ")_"@"_$E(OCXHR+100,2,3)_$E(OCXMIN+100,2,3) + ; + I $L(OCXDT),(OCXDT?1.2N1"/"1.2N.1" ".2N.1":".2N) D ; EXTERNAL EXPERT SYSTEM FORMAT 2 TO EXTERNAL FORMAT + .N OCXMON + .S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,$P(OCXDT,"/",1)) + .I $L($P(OCXDT," ",2)) S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_"@"_$TR($P(OCXDT," ",2),":","") + .E S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2) + ; + I $L(OCXDT),(OCXDT?1.2N1"/"1.2N1"/"1.2N.1" ".2N.1":".2N) D ; EXTERNAL EXPERT SYSTEM FORMAT 3 TO EXTERNAL FORMAT + .N OCXMON + .S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,$P(OCXDT,"/",1)) + .I $L($P(OCXDT," ",2)) S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_","_$P($P(OCXDT," ",1),"/",3)_"@"_$TR($P(OCXDT," ",2),":","") + .E S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_", "_$P($P(OCXDT," ",1),"/",3) + ; + I $L(OCXDT),'OCXDT D ; EXTERNAL FORMAT TO INTERNAL FILEMAN FORMAT + .I (OCXDT["@0000") S OCXDT=$P(OCXDT,"@",1),OCXDIFF=1 + .N %DT,X,Y S X=OCXDT,%DT="" S:(OCXDT["@")!(OCXDT="N") %DT="T" D ^%DT S OCXDT=+Y + ; + I ($L(OCXDT\1)>7) S OCXDT=$$HL7TFM^XLFDT(OCXDT) ; HL7 FORMAT TO INTERNAL FILEMAN FORMAT + ; + I ($L(OCXDT\1)=7) S OCXDT=$$FMTH^XLFDT(+OCXDT) ; INTERNAL FILEMAN FORMAT TO $H FORMAT + ; + I (OCXDT?5N1","1.5N) S OCXVAL=(OCXDT*86400)+$P(OCXDT,",",2) ; $H FORMAT TO EXPERT SYSTEM INTERNAL FORMAT + ; + Q OCXVAL + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ02.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ02.m index 267e13f9..843aabda 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ02.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ02.m @@ -1,143 +1,143 @@ -OCXOZ02 ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; - ; *************************************************************** - ; ** Warning: This routine is automatically generated by the ** - ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** - ; ** will be lost the next time the rule compiler executes. ** - ; *************************************************************** - ; - Q - ; -CHK1 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from UPDATE+10^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - ; Local CHK1 Variables - ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT) - ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) - ; OCXDF(5) ----> Data Field: ORDER PRIORITY (OBR) (FREE TEXT) - ; OCXDF(6) ----> Data Field: ABNORMAL FLAG (FREE TEXT) - ; OCXDF(12) ---> Data Field: LAB RESULT (FREE TEXT) - ; OCXDF(15) ---> Data Field: RESULT STATUS (OBX) (FREE TEXT) - ; OCXDF(21) ---> Data Field: ORDER PRIORITY (ORC) (FREE TEXT) - ; OCXDF(23) ---> Data Field: REQUEST STATUS (OBR) (FREE TEXT) - ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(113) --> Data Field: LAB TEST ID (NUMERIC) - ; OCXDF(146) --> Data Field: INPT/OUTPT (FREE TEXT) - ; OCXDF(152) --> Data Field: LAB SPECIMEN ID (NUMERIC) - ; - ; Local Extrinsic Functions - ; FILE(DFN,16, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: HL7 OERR ORDER) - ; LIST( ------------> IN LIST OPERATOR - ; PATLOC( ----------> PATIENT LOCATION - ; - I $L(OCXDF(23)) D CHK2 - I $L(OCXDF(1)) D CHK12^OCXOZ03 - I $L(OCXDF(2)),(OCXDF(2)="OR") S OCXOERR=$$FILE(DFN,16,"") Q:OCXOERR - I $L(OCXDF(6)) D CHK34^OCXOZ04 - I $L(OCXDF(15)),$$LIST(OCXDF(15),"F,C") D CHK47^OCXOZ05 - I $L(OCXDF(34)) D CHK113^OCXOZ06 - I $L(OCXDF(5)),(OCXDF(5)="S") D CHK151^OCXOZ07 - I $L(OCXDF(21)),(OCXDF(21)="S") D CHK157^OCXOZ07 - I $L(OCXDF(37)) S OCXDF(146)=$P($$PATLOC(OCXDF(37)),"^",1) I $L(OCXDF(146)) D CHK436^OCXOZ0E - I $L(OCXDF(12)),$L(OCXDF(152)),$L(OCXDF(113)) D CHK463^OCXOZ0F - Q - ; -CHK2 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK1+25. - ; - Q:$G(OCXOERR) - ; - ; Local CHK2 Variables - ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT) - ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) - ; OCXDF(23) ---> Data Field: REQUEST STATUS (OBR) (FREE TEXT) - ; - ; Local Extrinsic Functions - ; LIST( ------------> IN LIST OPERATOR - ; - I $$LIST(OCXDF(23),"F,C"),$L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)) D CHK6 - I (OCXDF(23)="F"),$L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)) D CHK121^OCXOZ07 - Q - ; -CHK6 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK2+13. - ; - Q:$G(OCXOERR) - ; - ; Local CHK6 Variables - ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) - ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(55) ---> Data Field: SITE FLAGGED RESULT (BOOLEAN) - ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) - ; OCXDF(146) --> Data Field: INPT/OUTPT (FREE TEXT) - ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT) - ; - ; Local Extrinsic Functions - ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER - ; PATLOC( ----------> PATIENT LOCATION - ; - I ($E(OCXDF(2),1,2)="LR"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)) I $L(OCXDF(37)) S OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2) D CHK11 - I (OCXDF(2)="RA"),$L(OCXDF(37)) S OCXDF(146)=$P($$PATLOC(OCXDF(37)),"^",1) I $L(OCXDF(146)),$L(OCXDF(34)) S OCXDF(55)=$$SITERES^ORB3F1(OCXDF(34),OCXDF(146)) D CHK302^OCXOZ0C - I (OCXDF(2)="GMRC"),$L(OCXDF(37)) S OCXDF(146)=$P($$PATLOC(OCXDF(37)),"^",1) I $L(OCXDF(146)),$L(OCXDF(34)) S OCXDF(55)=$$SITERES^ORB3F1(OCXDF(34),OCXDF(146)) D CHK336^OCXOZ0C - Q - ; -CHK11 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK6+18. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; FILE(DFN,5, ------> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: HL7 FINAL LAB RESULT) - ; - S OCXOERR=$$FILE(DFN,5,"12,37,96,113,147,152") Q:OCXOERR - Q - ; -FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. - ; - N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI - S DFN=+$G(DFN),OCXELE=+$G(OCXELE) - ; - Q:'DFN 1 Q:'OCXELE 1 K OCXDATA - ; - S OCXDATA(DFN,OCXELE)=1 - F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D - .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL - ; - M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) - ; - Q 0 - ; -LIST(DATA,LIST) ; IS THE DATA FIELD IN THE LIST - ; - S:'($E(LIST,1)=",") LIST=","_LIST S:'($E(LIST,$L(LIST))=",") LIST=LIST_"," S DATA=","_DATA_"," - Q (LIST[DATA) - ; -ORDITEM(OIEN) ; Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER - Q:'$G(OIEN) "" - ; - N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found." - S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found." - Q $P(X,U,1) - ; -PATLOC(DFN) ; Compiler Function: PATIENT LOCATION - ; - N OCXP1,OCXP2 - S OCXP1=$G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",2)) - S OCXP2=$P($G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",3)),"^",1) - I OCXP2 D - .S OCXP2=$P($G(^SC(+OCXP2,0)),"^",1,2) - .I $L($P(OCXP2,"^",2)) S OCXP2=$P(OCXP2,"^",2) - .E S OCXP2=$P(OCXP2,"^",1) - .S:'$L(OCXP2) OCXP2="NO LOC" - I $L(OCXP1),$L(OCXP2) Q OCXP1_"^"_OCXP2 - ; - S OCXP2=$G(^DPT(+$G(DFN),.1)) - I $L(OCXP2) Q "I^"_OCXP2 - Q "O^OUTPT" - ; +OCXOZ02 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; + ; *************************************************************** + ; ** Warning: This routine is automatically generated by the ** + ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** + ; ** will be lost the next time the rule compiler executes. ** + ; *************************************************************** + ; + Q + ; +CHK1 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from UPDATE+10^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + ; Local CHK1 Variables + ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT) + ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) + ; OCXDF(5) ----> Data Field: ORDER PRIORITY (OBR) (FREE TEXT) + ; OCXDF(6) ----> Data Field: ABNORMAL FLAG (FREE TEXT) + ; OCXDF(12) ---> Data Field: LAB RESULT (FREE TEXT) + ; OCXDF(15) ---> Data Field: RESULT STATUS (OBX) (FREE TEXT) + ; OCXDF(21) ---> Data Field: ORDER PRIORITY (ORC) (FREE TEXT) + ; OCXDF(23) ---> Data Field: REQUEST STATUS (OBR) (FREE TEXT) + ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(113) --> Data Field: LAB TEST ID (NUMERIC) + ; OCXDF(146) --> Data Field: INPT/OUTPT (FREE TEXT) + ; OCXDF(152) --> Data Field: LAB SPECIMEN ID (NUMERIC) + ; + ; Local Extrinsic Functions + ; FILE(DFN,16, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: HL7 OERR ORDER) + ; LIST( ------------> IN LIST OPERATOR + ; PATLOC( ----------> PATIENT LOCATION + ; + I $L(OCXDF(23)) D CHK2 + I $L(OCXDF(1)) D CHK12^OCXOZ03 + I $L(OCXDF(2)),(OCXDF(2)="OR") S OCXOERR=$$FILE(DFN,16,"") Q:OCXOERR + I $L(OCXDF(6)) D CHK34^OCXOZ04 + I $L(OCXDF(15)),$$LIST(OCXDF(15),"F,C") D CHK47^OCXOZ05 + I $L(OCXDF(34)) D CHK113^OCXOZ06 + I $L(OCXDF(5)),(OCXDF(5)="S") D CHK151^OCXOZ07 + I $L(OCXDF(21)),(OCXDF(21)="S") D CHK157^OCXOZ07 + I $L(OCXDF(37)) S OCXDF(146)=$P($$PATLOC(OCXDF(37)),"^",1) I $L(OCXDF(146)) D CHK444^OCXOZ0E + I $L(OCXDF(12)),$L(OCXDF(152)),$L(OCXDF(113)) D CHK471^OCXOZ0F + Q + ; +CHK2 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK1+25. + ; + Q:$G(OCXOERR) + ; + ; Local CHK2 Variables + ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT) + ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) + ; OCXDF(23) ---> Data Field: REQUEST STATUS (OBR) (FREE TEXT) + ; + ; Local Extrinsic Functions + ; LIST( ------------> IN LIST OPERATOR + ; + I $$LIST(OCXDF(23),"F,C"),$L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)) D CHK6 + I (OCXDF(23)="F"),$L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)) D CHK121^OCXOZ07 + Q + ; +CHK6 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK2+13. + ; + Q:$G(OCXOERR) + ; + ; Local CHK6 Variables + ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) + ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(55) ---> Data Field: SITE FLAGGED RESULT (BOOLEAN) + ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) + ; OCXDF(146) --> Data Field: INPT/OUTPT (FREE TEXT) + ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT) + ; + ; Local Extrinsic Functions + ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER + ; PATLOC( ----------> PATIENT LOCATION + ; + I ($E(OCXDF(2),1,2)="LR"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)) I $L(OCXDF(37)) S OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2) D CHK11 + I (OCXDF(2)="RA"),$L(OCXDF(37)) S OCXDF(146)=$P($$PATLOC(OCXDF(37)),"^",1) I $L(OCXDF(146)),$L(OCXDF(34)) S OCXDF(55)=$$SITERES^ORB3F1(OCXDF(34),OCXDF(146)) D CHK302^OCXOZ0C + I (OCXDF(2)="GMRC"),$L(OCXDF(37)) S OCXDF(146)=$P($$PATLOC(OCXDF(37)),"^",1) I $L(OCXDF(146)),$L(OCXDF(34)) S OCXDF(55)=$$SITERES^ORB3F1(OCXDF(34),OCXDF(146)) D CHK336^OCXOZ0C + Q + ; +CHK11 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK6+18. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; FILE(DFN,5, ------> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: HL7 FINAL LAB RESULT) + ; + S OCXOERR=$$FILE(DFN,5,"12,37,96,113,147,152") Q:OCXOERR + Q + ; +FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. + ; + N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI + S DFN=+$G(DFN),OCXELE=+$G(OCXELE) + ; + Q:'DFN 1 Q:'OCXELE 1 K OCXDATA + ; + S OCXDATA(DFN,OCXELE)=1 + F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D + .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL + ; + M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) + ; + Q 0 + ; +LIST(DATA,LIST) ; IS THE DATA FIELD IN THE LIST + ; + S:'($E(LIST,1)=",") LIST=","_LIST S:'($E(LIST,$L(LIST))=",") LIST=LIST_"," S DATA=","_DATA_"," + Q (LIST[DATA) + ; +ORDITEM(OIEN) ; Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER + Q:'$G(OIEN) "" + ; + N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found." + S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found." + Q $P(X,U,1) + ; +PATLOC(DFN) ; Compiler Function: PATIENT LOCATION + ; + N OCXP1,OCXP2 + S OCXP1=$G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",2)) + S OCXP2=$P($G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",3)),"^",1) + I OCXP2 D + .S OCXP2=$P($G(^SC(+OCXP2,0)),"^",1,2) + .I $L($P(OCXP2,"^",2)) S OCXP2=$P(OCXP2,"^",2) + .E S OCXP2=$P(OCXP2,"^",1) + .S:'$L(OCXP2) OCXP2="NO LOC" + I $L(OCXP1),$L(OCXP2) Q OCXP1_"^"_OCXP2 + ; + S OCXP2=$G(^DPT(+$G(DFN),.1)) + I $L(OCXP2) Q "I^"_OCXP2 + Q "O^OUTPT" + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ03.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ03.m index 6d41690e..1ad84aea 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ03.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ03.m @@ -1,142 +1,142 @@ -OCXOZ03 ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; - ; *************************************************************** - ; ** Warning: This routine is automatically generated by the ** - ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** - ; ** will be lost the next time the rule compiler executes. ** - ; *************************************************************** - ; - Q - ; -CHK12 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK1+26^OCXOZ02. - ; - Q:$G(OCXOERR) - ; - ; Local CHK12 Variables - ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT) - ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) - ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(105) --> Data Field: ORDER TEXT (51 CHARS) (FREE TEXT) - ; OCXDF(146) --> Data Field: INPT/OUTPT (FREE TEXT) - ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT) - ; OCXDF(148) --> Data Field: FOOD-DRUG INTERACTION MED (BOOLEAN) - ; - ; Local Extrinsic Functions - ; FILE(DFN,126, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: HL7 DCED OERR ORDER) - ; FILE(DFN,20, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: HL7 LAB ORDER CANCELLED) - ; FILE(DFN,30, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: RADIOLOGY ORDER PUT ON-HOLD) - ; FILE(DFN,31, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: RADIOLOGY ORDER CANCELLED) - ; FILE(DFN,32, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: RADIOLOGY ORDER DISCONTINUED) - ; FILE(DFN,40, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: HL7 LAB REQUEST CANCELLED) - ; FILE(DFN,6, ------> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: HL7 NEW OERR ORDER) - ; FOODDRG( ---------> FOOD-DRUG INTERACTION MED - ; LIST( ------------> IN LIST OPERATOR - ; PATLOC( ----------> PATIENT LOCATION - ; - I $$LIST(OCXDF(1),"NW,SN,XR"),$L(OCXDF(37)) S OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,6,"147") Q:OCXOERR - I (OCXDF(1)="OC"),$L(OCXDF(2)),($E(OCXDF(2),1,2)="LR"),$L(OCXDF(34)) S OCXDF(105)=$P($$TEXT^ORKOR(OCXDF(34),51),"^",2),OCXOERR=$$FILE(DFN,20,"105") Q:OCXOERR - I (OCXDF(1)="OH"),$L(OCXDF(2)),(OCXDF(2)="RA"),$L(OCXDF(34)) S OCXDF(105)=$P($$TEXT^ORKOR(OCXDF(34),51),"^",2),OCXOERR=$$FILE(DFN,30,"105") Q:OCXOERR - I (OCXDF(1)="OD"),$L(OCXDF(2)),(OCXDF(2)="RA"),$L(OCXDF(34)) S OCXDF(105)=$P($$TEXT^ORKOR(OCXDF(34),51),"^",2),OCXOERR=$$FILE(DFN,31,"105") Q:OCXOERR - I (OCXDF(1)="DC"),$L(OCXDF(2)),(OCXDF(2)="RA"),$L(OCXDF(34)) S OCXDF(105)=$P($$TEXT^ORKOR(OCXDF(34),51),"^",2),OCXOERR=$$FILE(DFN,32,"105") Q:OCXOERR - I (OCXDF(1)="CA"),$L(OCXDF(2)),($E(OCXDF(2),1,2)="LR"),$L(OCXDF(34)) S OCXDF(105)=$P($$TEXT^ORKOR(OCXDF(34),51),"^",2),OCXOERR=$$FILE(DFN,40,"105") Q:OCXOERR - I $$LIST(OCXDF(1),"NW,SN,XO"),$L(OCXDF(37)) S OCXDF(146)=$P($$PATLOC(OCXDF(37)),"^",1) I $L(OCXDF(146)),$L(OCXDF(34)) D CHK131^OCXOZ07 - I $$LIST(OCXDF(1),"NW,SN"),$L(OCXDF(34)) S OCXDF(148)=$P($$FOODDRG(OCXDF(34)),"^",1) I $L(OCXDF(148)),(OCXDF(148)),$L(OCXDF(37)) D CHK270^OCXOZ0B - I $$LIST(OCXDF(1),"DC,CA,OD,OC"),$L(OCXDF(37)) S OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,126,"147") Q:OCXOERR - Q - ; -CHK23 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from UPDATE+11^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - ; Local CHK23 Variables - ; OCXDF(25) ---> Data Field: PATIENT MOVEMENT TYPE CURRENT (FREE TEXT) - ; OCXDF(92) ---> Data Field: PATIENT MOVEMENT WARD IEN CURRENT (NUMERIC) - ; OCXDF(93) ---> Data Field: PATIENT MOVEMENT WARD IEN PREVIOUS (NUMERIC) - ; OCXDF(94) ---> Data Field: PATIENT MOVEMENT SERVICE PREVIOUS (FREE TEXT) - ; - ; Local Extrinsic Functions - ; POINTER( ---------> RETURN POINTED TO VALUE - ; WARDSERV( --------> GET WARD SERVICE - ; - S OCXDF(25)=$$POINTER(405.3,$P($G(DGPMA),"^",2)) I $L(OCXDF(25)) D CHK25^OCXOZ04 - S OCXDF(93)=$P($G(DGPM0),"^",6) I $L(OCXDF(93)) S OCXDF(94)=$$WARDSERV(OCXDF(93)) I $L(OCXDF(94)),(OCXDF(94)="PSYCHIATRY") S OCXDF(92)=$P($G(DGPMA),"^",6) D CHK87^OCXOZ05 - Q - ; -FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. - ; - N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI - S DFN=+$G(DFN),OCXELE=+$G(OCXELE) - ; - Q:'DFN 1 Q:'OCXELE 1 K OCXDATA - ; - S OCXDATA(DFN,OCXELE)=1 - F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D - .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL - ; - M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) - ; - Q 0 - ; -FOODDRG(OCXOR) ;func rtns 1^ if OCXOR is food-drug med - N OCXTL,OCXT,OCXFD,OCXOI - S OCXOI=$$OI(OCXOR) - Q:'$L(OCXOI) "0^" - Q:'$$TERMLKUP("FOOD-DRUG INTERACTION MED",.OCXTL) "0^" - S OCXFD="",OCXT=0 F S OCXT=$O(OCXTL(OCXT)) Q:'OCXT D Q:$L(OCXFD) - .I OCXT=OCXOI S OCXFD="1^"_OCXTL(OCXT) - Q:'$L(OCXFD) "0^" - Q OCXFD - ; -LIST(DATA,LIST) ; IS THE DATA FIELD IN THE LIST - ; - S:'($E(LIST,1)=",") LIST=","_LIST S:'($E(LIST,$L(LIST))=",") LIST=LIST_"," S DATA=","_DATA_"," - Q (LIST[DATA) - ; -OI(OCXOR) ;func rtns orderable item for an order number (OCXOR) - Q:+$G(OCXOR)<1 "" - N OCXOI S OCXOI="" - S OCXOI=+$G(^OR(100,+$G(OCXOR),.1,1,0)) - Q OCXOI - ; -PATLOC(DFN) ; Compiler Function: PATIENT LOCATION - ; - N OCXP1,OCXP2 - S OCXP1=$G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",2)) - S OCXP2=$P($G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",3)),"^",1) - I OCXP2 D - .S OCXP2=$P($G(^SC(+OCXP2,0)),"^",1,2) - .I $L($P(OCXP2,"^",2)) S OCXP2=$P(OCXP2,"^",2) - .E S OCXP2=$P(OCXP2,"^",1) - .S:'$L(OCXP2) OCXP2="NO LOC" - I $L(OCXP1),$L(OCXP2) Q OCXP1_"^"_OCXP2 - ; - S OCXP2=$G(^DPT(+$G(DFN),.1)) - I $L(OCXP2) Q "I^"_OCXP2 - Q "O^OUTPT" - ; -POINTER(OCXFILE,D0) ; This Local Extrinsic Function gets the value of the name field - ; of record D0 in file OCXFILE - Q:'$G(D0) "" Q:'$L($G(OCXFILE)) "" - N GLREF - I '(OCXFILE=(+OCXFILE)) S GLREF=U_OCXFILE - E S GLREF=$$FILE^OCXBDTD(+OCXFILE,"GLOBAL NAME") Q:'$L(GLREF) "" - Q $P($G(@(GLREF_(+D0)_",0)")),U,1) - ; -TERMLKUP(OCXTERM,OCXLIST) ; - Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST) - ; -WARDSERV(WARD) ; Compiler Function: GET WARD SERVICE - ; - N CODESET,PC,SERV,DIC,X,Y,DA - S CODESET="M:MEDICINE;S:SURGERY;P:PSYCHIATRY;NH:NHCU;NE:NEUROLOGY;I:INTERMEDIATE MED;R:REHAB MEDICINE;SCI:SPINAL CORD INJURY;D:DOMICILIARY;B:BLIND REHAB;NC:NON-COUNT" - S DIC=42,DIC(0)="NZ",X="`"_(+WARD) D ^DIC Q:(Y<1) "" - S SERV=$P($G(Y(0)),U,3) - Q:'$L(SERV) "" Q:'$L(CODESET) "" - F PC=1:1:$L(CODESET,";"),0 I PC,($P($P(CODESET,";",PC),":",1)=SERV) Q - Q:'PC "" Q $P($P(CODESET,";",PC),":",2) - ; +OCXOZ03 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; + ; *************************************************************** + ; ** Warning: This routine is automatically generated by the ** + ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** + ; ** will be lost the next time the rule compiler executes. ** + ; *************************************************************** + ; + Q + ; +CHK12 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK1+26^OCXOZ02. + ; + Q:$G(OCXOERR) + ; + ; Local CHK12 Variables + ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT) + ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) + ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(105) --> Data Field: ORDER TEXT (51 CHARS) (FREE TEXT) + ; OCXDF(146) --> Data Field: INPT/OUTPT (FREE TEXT) + ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT) + ; OCXDF(148) --> Data Field: FOOD-DRUG INTERACTION MED (BOOLEAN) + ; + ; Local Extrinsic Functions + ; FILE(DFN,126, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: HL7 DCED OERR ORDER) + ; FILE(DFN,20, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: HL7 LAB ORDER CANCELLED) + ; FILE(DFN,30, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: RADIOLOGY ORDER PUT ON-HOLD) + ; FILE(DFN,31, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: RADIOLOGY ORDER CANCELLED) + ; FILE(DFN,32, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: RADIOLOGY ORDER DISCONTINUED) + ; FILE(DFN,40, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: HL7 LAB REQUEST CANCELLED) + ; FILE(DFN,6, ------> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: HL7 NEW OERR ORDER) + ; FOODDRG( ---------> FOOD-DRUG INTERACTION MED + ; LIST( ------------> IN LIST OPERATOR + ; PATLOC( ----------> PATIENT LOCATION + ; + I $$LIST(OCXDF(1),"NW,SN,XR"),$L(OCXDF(37)) S OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,6,"147") Q:OCXOERR + I (OCXDF(1)="OC"),$L(OCXDF(2)),($E(OCXDF(2),1,2)="LR"),$L(OCXDF(34)) S OCXDF(105)=$P($$TEXT^ORKOR(OCXDF(34),51),"^",2),OCXOERR=$$FILE(DFN,20,"105") Q:OCXOERR + I (OCXDF(1)="OH"),$L(OCXDF(2)),(OCXDF(2)="RA"),$L(OCXDF(34)) S OCXDF(105)=$P($$TEXT^ORKOR(OCXDF(34),51),"^",2),OCXOERR=$$FILE(DFN,30,"105") Q:OCXOERR + I (OCXDF(1)="OD"),$L(OCXDF(2)),(OCXDF(2)="RA"),$L(OCXDF(34)) S OCXDF(105)=$P($$TEXT^ORKOR(OCXDF(34),51),"^",2),OCXOERR=$$FILE(DFN,31,"105") Q:OCXOERR + I (OCXDF(1)="DC"),$L(OCXDF(2)),(OCXDF(2)="RA"),$L(OCXDF(34)) S OCXDF(105)=$P($$TEXT^ORKOR(OCXDF(34),51),"^",2),OCXOERR=$$FILE(DFN,32,"105") Q:OCXOERR + I (OCXDF(1)="CA"),$L(OCXDF(2)),($E(OCXDF(2),1,2)="LR"),$L(OCXDF(34)) S OCXDF(105)=$P($$TEXT^ORKOR(OCXDF(34),51),"^",2),OCXOERR=$$FILE(DFN,40,"105") Q:OCXOERR + I $$LIST(OCXDF(1),"NW,SN,XO"),$L(OCXDF(37)) S OCXDF(146)=$P($$PATLOC(OCXDF(37)),"^",1) I $L(OCXDF(146)),$L(OCXDF(34)) D CHK131^OCXOZ07 + I $$LIST(OCXDF(1),"NW,SN"),$L(OCXDF(34)) S OCXDF(148)=$P($$FOODDRG(OCXDF(34)),"^",1) I $L(OCXDF(148)),(OCXDF(148)),$L(OCXDF(37)) D CHK270^OCXOZ0B + I $$LIST(OCXDF(1),"DC,CA,OD,OC"),$L(OCXDF(37)) S OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,126,"147") Q:OCXOERR + Q + ; +CHK23 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from UPDATE+11^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + ; Local CHK23 Variables + ; OCXDF(25) ---> Data Field: PATIENT MOVEMENT TYPE CURRENT (FREE TEXT) + ; OCXDF(92) ---> Data Field: PATIENT MOVEMENT WARD IEN CURRENT (NUMERIC) + ; OCXDF(93) ---> Data Field: PATIENT MOVEMENT WARD IEN PREVIOUS (NUMERIC) + ; OCXDF(94) ---> Data Field: PATIENT MOVEMENT SERVICE PREVIOUS (FREE TEXT) + ; + ; Local Extrinsic Functions + ; POINTER( ---------> RETURN POINTED TO VALUE + ; WARDSERV( --------> GET WARD SERVICE + ; + S OCXDF(25)=$$POINTER(405.3,$P($G(DGPMA),"^",2)) I $L(OCXDF(25)) D CHK25^OCXOZ04 + S OCXDF(93)=$P($G(DGPM0),"^",6) I $L(OCXDF(93)) S OCXDF(94)=$$WARDSERV(OCXDF(93)) I $L(OCXDF(94)),(OCXDF(94)="PSYCHIATRY") S OCXDF(92)=$P($G(DGPMA),"^",6) D CHK87^OCXOZ05 + Q + ; +FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. + ; + N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI + S DFN=+$G(DFN),OCXELE=+$G(OCXELE) + ; + Q:'DFN 1 Q:'OCXELE 1 K OCXDATA + ; + S OCXDATA(DFN,OCXELE)=1 + F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D + .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL + ; + M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) + ; + Q 0 + ; +FOODDRG(OCXOR) ;func rtns 1^ if OCXOR is food-drug med + N OCXTL,OCXT,OCXFD,OCXOI + S OCXOI=$$OI(OCXOR) + Q:'$L(OCXOI) "0^" + Q:'$$TERMLKUP("FOOD-DRUG INTERACTION MED",.OCXTL) "0^" + S OCXFD="",OCXT=0 F S OCXT=$O(OCXTL(OCXT)) Q:'OCXT D Q:$L(OCXFD) + .I OCXT=OCXOI S OCXFD="1^"_OCXTL(OCXT) + Q:'$L(OCXFD) "0^" + Q OCXFD + ; +LIST(DATA,LIST) ; IS THE DATA FIELD IN THE LIST + ; + S:'($E(LIST,1)=",") LIST=","_LIST S:'($E(LIST,$L(LIST))=",") LIST=LIST_"," S DATA=","_DATA_"," + Q (LIST[DATA) + ; +OI(OCXOR) ;func rtns orderable item for an order number (OCXOR) + Q:+$G(OCXOR)<1 "" + N OCXOI S OCXOI="" + S OCXOI=+$G(^OR(100,+$G(OCXOR),.1,1,0)) + Q OCXOI + ; +PATLOC(DFN) ; Compiler Function: PATIENT LOCATION + ; + N OCXP1,OCXP2 + S OCXP1=$G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",2)) + S OCXP2=$P($G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",3)),"^",1) + I OCXP2 D + .S OCXP2=$P($G(^SC(+OCXP2,0)),"^",1,2) + .I $L($P(OCXP2,"^",2)) S OCXP2=$P(OCXP2,"^",2) + .E S OCXP2=$P(OCXP2,"^",1) + .S:'$L(OCXP2) OCXP2="NO LOC" + I $L(OCXP1),$L(OCXP2) Q OCXP1_"^"_OCXP2 + ; + S OCXP2=$G(^DPT(+$G(DFN),.1)) + I $L(OCXP2) Q "I^"_OCXP2 + Q "O^OUTPT" + ; +POINTER(OCXFILE,D0) ; This Local Extrinsic Function gets the value of the name field + ; of record D0 in file OCXFILE + Q:'$G(D0) "" Q:'$L($G(OCXFILE)) "" + N GLREF + I '(OCXFILE=(+OCXFILE)) S GLREF=U_OCXFILE + E S GLREF=$$FILE^OCXBDTD(+OCXFILE,"GLOBAL NAME") Q:'$L(GLREF) "" + Q $P($G(@(GLREF_(+D0)_",0)")),U,1) + ; +TERMLKUP(OCXTERM,OCXLIST) ; + Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST) + ; +WARDSERV(WARD) ; Compiler Function: GET WARD SERVICE + ; + N CODESET,PC,SERV,DIC,X,Y,DA + S CODESET="M:MEDICINE;S:SURGERY;P:PSYCHIATRY;NH:NHCU;NE:NEUROLOGY;I:INTERMEDIATE MED;R:REHAB MEDICINE;SCI:SPINAL CORD INJURY;D:DOMICILIARY;B:BLIND REHAB;NC:NON-COUNT" + S DIC=42,DIC(0)="NZ",X="`"_(+WARD) D ^DIC Q:(Y<1) "" + S SERV=$P($G(Y(0)),U,3) + Q:'$L(SERV) "" Q:'$L(CODESET) "" + F PC=1:1:$L(CODESET,";"),0 I PC,($P($P(CODESET,";",PC),":",1)=SERV) Q + Q:'PC "" Q $P($P(CODESET,";",PC),":",2) + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ04.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ04.m index 35b9c45f..811eafeb 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ04.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ04.m @@ -1,172 +1,172 @@ -OCXOZ04 ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; - ; *************************************************************** - ; ** Warning: This routine is automatically generated by the ** - ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** - ; ** will be lost the next time the rule compiler executes. ** - ; *************************************************************** - ; - Q - ; -CHK25 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK23+15^OCXOZ03. - ; - Q:$G(OCXOERR) - ; - ; Local CHK25 Variables - ; OCXDF(25) ---> Data Field: PATIENT MOVEMENT TYPE CURRENT (FREE TEXT) - ; OCXDF(26) ---> Data Field: PATIENT MOVEMENT DATE CURRENT (DATE/TIME) - ; OCXDF(97) ---> Data Field: NEW PATIENT MOVEMENT (BOOLEAN) - ; - ; Local Extrinsic Functions - ; DT2INT( ----------> CONVERT DATE FROM FILEMAN FORMAT TO OCX FORMAT - ; FILE(DFN,56, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: PATIENT DISCHARGE) - ; - I (OCXDF(25)="ADMISSION") S OCXDF(97)=('(+$G(DGPMA)=+$G(DGPM0))&'$L(DGPMP)) I $L(OCXDF(97)),(OCXDF(97)) S OCXDF(26)=$$DT2INT($P($G(DGPMA),"^",1)) D CHK30 - I (OCXDF(25)="DISCHARGE") S OCXDF(26)=$$DT2INT($P($G(DGPMA),"^",1)),OCXOERR=$$FILE(DFN,56,"26") Q:OCXOERR - Q - ; -CHK30 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK25+14. - ; - Q:$G(OCXOERR) - ; - ; Local CHK30 Variables - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(83) ---> Data Field: PATIENT WARD ROOM-BED (FREE TEXT) - ; - ; Local Extrinsic Functions - ; FILE(DFN,21, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: PATIENT ADMISSION) - ; WARDRMBD( --------> WARD ROOM-BED - ; - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(83)=$P($$WARDRMBD(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,21,"26,83") Q:OCXOERR - Q - ; -CHK34 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK1+28^OCXOZ02. - ; - Q:$G(OCXOERR) - ; - ; Local CHK34 Variables - ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT) - ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) - ; OCXDF(6) ----> Data Field: ABNORMAL FLAG (FREE TEXT) - ; OCXDF(23) ---> Data Field: REQUEST STATUS (OBR) (FREE TEXT) - ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) - ; - ; Local Extrinsic Functions - ; LIST( ------------> IN LIST OPERATOR - ; - I $$LIST(OCXDF(6),"H,L") D CHK35 - I $$LIST(OCXDF(6),"HH,LL"),$L(OCXDF(23)),$$LIST(OCXDF(23),"F,C"),$L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)),($E(OCXDF(2),1,2)="LR"),$L(OCXDF(34)) D CHK324^OCXOZ0C - Q - ; -CHK35 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK34+15. - ; - Q:$G(OCXOERR) - ; - ; Local CHK35 Variables - ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT) - ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) - ; OCXDF(15) ---> Data Field: RESULT STATUS (OBX) (FREE TEXT) - ; OCXDF(23) ---> Data Field: REQUEST STATUS (OBR) (FREE TEXT) - ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) - ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) - ; - ; Local Extrinsic Functions - ; LIST( ------------> IN LIST OPERATOR - ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER - ; - I $L(OCXDF(23)),$$LIST(OCXDF(23),"F,C"),$L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)),($E(OCXDF(2),1,2)="LR"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)) D CHK43 - I $L(OCXDF(15)),$$LIST(OCXDF(15),"F,C"),$L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)),($E(OCXDF(2),1,2)="LR"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)) D CHK314^OCXOZ0C - Q - ; -CHK43 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK35+17. - ; - Q:$G(OCXOERR) - ; - ; Local CHK43 Variables - ; OCXDF(113) --> Data Field: LAB TEST ID (NUMERIC) - ; OCXDF(114) --> Data Field: LAB TEST PRINT NAME (FREE TEXT) - ; - ; Local Extrinsic Functions - ; FILE(DFN,23, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: HL7 LAB ORDER RESULTS ABNORMAL) - ; - I $L(OCXDF(113)) S OCXDF(114)=$$PRINTNAM^ORQQLR1(OCXDF(113)),OCXOERR=$$FILE(DFN,23,"12,13,96,114") Q:OCXOERR - Q - ; -DT2INT(OCXDT) ; This Local Extrinsic Function converts a date into an integer - ; By taking the Years, Months, Days, Hours and Minutes converting - ; Them into Seconds and then adding them all together into one big integer - ; - Q:'$L($G(OCXDT)) "" - N OCXDIFF,OCXVAL S (OCXDIFF,OCXVAL)=0 - ; - I $L(OCXDT),'OCXDT,(OCXDT[" at ") D ; EXTERNAL EXPERT SYSTEM FORMAT 1 TO EXTERNAL FORMAT - .N OCXHR,OCXMIN,OCXTIME - .S OCXTIME=$P($P(OCXDT," at ",2),".",1),OCXHR=$P(OCXTIME,":",1),OCXMIN=$P(OCXTIME,":",2) - .S:(OCXDT["Midnight") OCXHR=00 - .S:(OCXDT["PM") OCXHR=OCXHR+12 - .S OCXDT=$P(OCXDT," at ")_"@"_$E(OCXHR+100,2,3)_$E(OCXMIN+100,2,3) - ; - I $L(OCXDT),(OCXDT?1.2N1"/"1.2N.1" ".2N.1":".2N) D ; EXTERNAL EXPERT SYSTEM FORMAT 2 TO EXTERNAL FORMAT - .N OCXMON - .S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,$P(OCXDT,"/",1)) - .I $L($P(OCXDT," ",2)) S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_"@"_$TR($P(OCXDT," ",2),":","") - .E S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2) - ; - I $L(OCXDT),(OCXDT?1.2N1"/"1.2N1"/"1.2N.1" ".2N.1":".2N) D ; EXTERNAL EXPERT SYSTEM FORMAT 3 TO EXTERNAL FORMAT - .N OCXMON - .S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,$P(OCXDT,"/",1)) - .I $L($P(OCXDT," ",2)) S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_","_$P($P(OCXDT," ",1),"/",3)_"@"_$TR($P(OCXDT," ",2),":","") - .E S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_", "_$P($P(OCXDT," ",1),"/",3) - ; - I $L(OCXDT),'OCXDT D ; EXTERNAL FORMAT TO INTERNAL FILEMAN FORMAT - .I (OCXDT["@0000") S OCXDT=$P(OCXDT,"@",1),OCXDIFF=1 - .N %DT,X,Y S X=OCXDT,%DT="" S:(OCXDT["@")!(OCXDT="N") %DT="T" D ^%DT S OCXDT=+Y - ; - I ($L(OCXDT\1)>7) S OCXDT=$$HL7TFM^XLFDT(OCXDT) ; HL7 FORMAT TO INTERNAL FILEMAN FORMAT - ; - I ($L(OCXDT\1)=7) S OCXDT=$$FMTH^XLFDT(+OCXDT) ; INTERNAL FILEMAN FORMAT TO $H FORMAT - ; - I (OCXDT?5N1","1.5N) S OCXVAL=(OCXDT*86400)+$P(OCXDT,",",2) ; $H FORMAT TO EXPERT SYSTEM INTERNAL FORMAT - ; - Q OCXVAL - ; -FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. - ; - N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI - S DFN=+$G(DFN),OCXELE=+$G(OCXELE) - ; - Q:'DFN 1 Q:'OCXELE 1 K OCXDATA - ; - S OCXDATA(DFN,OCXELE)=1 - F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D - .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL - ; - M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) - ; - Q 0 - ; -LIST(DATA,LIST) ; IS THE DATA FIELD IN THE LIST - ; - S:'($E(LIST,1)=",") LIST=","_LIST S:'($E(LIST,$L(LIST))=",") LIST=LIST_"," S DATA=","_DATA_"," - Q (LIST[DATA) - ; -ORDITEM(OIEN) ; Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER - Q:'$G(OIEN) "" - ; - N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found." - S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found." - Q $P(X,U,1) - ; -WARDRMBD(DFN) ; Compiler Function: WARD ROOM-BED - ; - Q:'$G(DFN) 0 - N OUT S OUT=$G(^DPT(DFN,.1)) Q:'$L(OUT) 0 - S OUT=1_"^"_OUT_" "_$G(^DPT(DFN,.101)) Q OUT - ; +OCXOZ04 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; + ; *************************************************************** + ; ** Warning: This routine is automatically generated by the ** + ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** + ; ** will be lost the next time the rule compiler executes. ** + ; *************************************************************** + ; + Q + ; +CHK25 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK23+15^OCXOZ03. + ; + Q:$G(OCXOERR) + ; + ; Local CHK25 Variables + ; OCXDF(25) ---> Data Field: PATIENT MOVEMENT TYPE CURRENT (FREE TEXT) + ; OCXDF(26) ---> Data Field: PATIENT MOVEMENT DATE CURRENT (DATE/TIME) + ; OCXDF(97) ---> Data Field: NEW PATIENT MOVEMENT (BOOLEAN) + ; + ; Local Extrinsic Functions + ; DT2INT( ----------> CONVERT DATE FROM FILEMAN FORMAT TO OCX FORMAT + ; FILE(DFN,56, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: PATIENT DISCHARGE) + ; + I (OCXDF(25)="ADMISSION") S OCXDF(97)=('(+$G(DGPMA)=+$G(DGPM0))&'$L(DGPMP)) I $L(OCXDF(97)),(OCXDF(97)) S OCXDF(26)=$$DT2INT($P($G(DGPMA),"^",1)) D CHK30 + I (OCXDF(25)="DISCHARGE") S OCXDF(26)=$$DT2INT($P($G(DGPMA),"^",1)),OCXOERR=$$FILE(DFN,56,"26") Q:OCXOERR + Q + ; +CHK30 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK25+14. + ; + Q:$G(OCXOERR) + ; + ; Local CHK30 Variables + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(83) ---> Data Field: PATIENT WARD ROOM-BED (FREE TEXT) + ; + ; Local Extrinsic Functions + ; FILE(DFN,21, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: PATIENT ADMISSION) + ; WARDRMBD( --------> WARD ROOM-BED + ; + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(83)=$P($$WARDRMBD(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,21,"26,83") Q:OCXOERR + Q + ; +CHK34 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK1+28^OCXOZ02. + ; + Q:$G(OCXOERR) + ; + ; Local CHK34 Variables + ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT) + ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) + ; OCXDF(6) ----> Data Field: ABNORMAL FLAG (FREE TEXT) + ; OCXDF(23) ---> Data Field: REQUEST STATUS (OBR) (FREE TEXT) + ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) + ; + ; Local Extrinsic Functions + ; LIST( ------------> IN LIST OPERATOR + ; + I $$LIST(OCXDF(6),"H,L") D CHK35 + I $$LIST(OCXDF(6),"HH,LL"),$L(OCXDF(23)),$$LIST(OCXDF(23),"F,C"),$L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)),($E(OCXDF(2),1,2)="LR"),$L(OCXDF(34)) D CHK324^OCXOZ0C + Q + ; +CHK35 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK34+15. + ; + Q:$G(OCXOERR) + ; + ; Local CHK35 Variables + ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT) + ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) + ; OCXDF(15) ---> Data Field: RESULT STATUS (OBX) (FREE TEXT) + ; OCXDF(23) ---> Data Field: REQUEST STATUS (OBR) (FREE TEXT) + ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) + ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) + ; + ; Local Extrinsic Functions + ; LIST( ------------> IN LIST OPERATOR + ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER + ; + I $L(OCXDF(23)),$$LIST(OCXDF(23),"F,C"),$L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)),($E(OCXDF(2),1,2)="LR"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)) D CHK43 + I $L(OCXDF(15)),$$LIST(OCXDF(15),"F,C"),$L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)),($E(OCXDF(2),1,2)="LR"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)) D CHK314^OCXOZ0C + Q + ; +CHK43 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK35+17. + ; + Q:$G(OCXOERR) + ; + ; Local CHK43 Variables + ; OCXDF(113) --> Data Field: LAB TEST ID (NUMERIC) + ; OCXDF(114) --> Data Field: LAB TEST PRINT NAME (FREE TEXT) + ; + ; Local Extrinsic Functions + ; FILE(DFN,23, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: HL7 LAB ORDER RESULTS ABNORMAL) + ; + I $L(OCXDF(113)) S OCXDF(114)=$$PRINTNAM^ORQQLR1(OCXDF(113)),OCXOERR=$$FILE(DFN,23,"12,13,96,114") Q:OCXOERR + Q + ; +DT2INT(OCXDT) ; This Local Extrinsic Function converts a date into an integer + ; By taking the Years, Months, Days, Hours and Minutes converting + ; Them into Seconds and then adding them all together into one big integer + ; + Q:'$L($G(OCXDT)) "" + N OCXDIFF,OCXVAL S (OCXDIFF,OCXVAL)=0 + ; + I $L(OCXDT),'OCXDT,(OCXDT[" at ") D ; EXTERNAL EXPERT SYSTEM FORMAT 1 TO EXTERNAL FORMAT + .N OCXHR,OCXMIN,OCXTIME + .S OCXTIME=$P($P(OCXDT," at ",2),".",1),OCXHR=$P(OCXTIME,":",1),OCXMIN=$P(OCXTIME,":",2) + .S:(OCXDT["Midnight") OCXHR=00 + .S:(OCXDT["PM") OCXHR=OCXHR+12 + .S OCXDT=$P(OCXDT," at ")_"@"_$E(OCXHR+100,2,3)_$E(OCXMIN+100,2,3) + ; + I $L(OCXDT),(OCXDT?1.2N1"/"1.2N.1" ".2N.1":".2N) D ; EXTERNAL EXPERT SYSTEM FORMAT 2 TO EXTERNAL FORMAT + .N OCXMON + .S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,$P(OCXDT,"/",1)) + .I $L($P(OCXDT," ",2)) S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_"@"_$TR($P(OCXDT," ",2),":","") + .E S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2) + ; + I $L(OCXDT),(OCXDT?1.2N1"/"1.2N1"/"1.2N.1" ".2N.1":".2N) D ; EXTERNAL EXPERT SYSTEM FORMAT 3 TO EXTERNAL FORMAT + .N OCXMON + .S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,$P(OCXDT,"/",1)) + .I $L($P(OCXDT," ",2)) S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_","_$P($P(OCXDT," ",1),"/",3)_"@"_$TR($P(OCXDT," ",2),":","") + .E S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_", "_$P($P(OCXDT," ",1),"/",3) + ; + I $L(OCXDT),'OCXDT D ; EXTERNAL FORMAT TO INTERNAL FILEMAN FORMAT + .I (OCXDT["@0000") S OCXDT=$P(OCXDT,"@",1),OCXDIFF=1 + .N %DT,X,Y S X=OCXDT,%DT="" S:(OCXDT["@")!(OCXDT="N") %DT="T" D ^%DT S OCXDT=+Y + ; + I ($L(OCXDT\1)>7) S OCXDT=$$HL7TFM^XLFDT(OCXDT) ; HL7 FORMAT TO INTERNAL FILEMAN FORMAT + ; + I ($L(OCXDT\1)=7) S OCXDT=$$FMTH^XLFDT(+OCXDT) ; INTERNAL FILEMAN FORMAT TO $H FORMAT + ; + I (OCXDT?5N1","1.5N) S OCXVAL=(OCXDT*86400)+$P(OCXDT,",",2) ; $H FORMAT TO EXPERT SYSTEM INTERNAL FORMAT + ; + Q OCXVAL + ; +FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. + ; + N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI + S DFN=+$G(DFN),OCXELE=+$G(OCXELE) + ; + Q:'DFN 1 Q:'OCXELE 1 K OCXDATA + ; + S OCXDATA(DFN,OCXELE)=1 + F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D + .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL + ; + M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) + ; + Q 0 + ; +LIST(DATA,LIST) ; IS THE DATA FIELD IN THE LIST + ; + S:'($E(LIST,1)=",") LIST=","_LIST S:'($E(LIST,$L(LIST))=",") LIST=LIST_"," S DATA=","_DATA_"," + Q (LIST[DATA) + ; +ORDITEM(OIEN) ; Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER + Q:'$G(OIEN) "" + ; + N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found." + S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found." + Q $P(X,U,1) + ; +WARDRMBD(DFN) ; Compiler Function: WARD ROOM-BED + ; + Q:'$G(DFN) 0 + N OUT S OUT=$G(^DPT(DFN,.1)) Q:'$L(OUT) 0 + S OUT=1_"^"_OUT_" "_$G(^DPT(DFN,.101)) Q OUT + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ05.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ05.m index c9c4d878..8574ad2f 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ05.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ05.m @@ -1,197 +1,197 @@ -OCXOZ05 ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; - ; *************************************************************** - ; ** Warning: This routine is automatically generated by the ** - ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** - ; ** will be lost the next time the rule compiler executes. ** - ; *************************************************************** - ; - Q - ; -CHK47 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK1+29^OCXOZ02. - ; - Q:$G(OCXOERR) - ; - ; Local CHK47 Variables - ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT) - ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) - ; OCXDF(6) ----> Data Field: ABNORMAL FLAG (FREE TEXT) - ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) - ; OCXDF(146) --> Data Field: INPT/OUTPT (FREE TEXT) - ; - ; Local Extrinsic Functions - ; LIST( ------------> IN LIST OPERATOR - ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER - ; PATLOC( ----------> PATIENT LOCATION - ; - I $L(OCXDF(6)),$$LIST(OCXDF(6),"HH,LL"),$L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)),($E(OCXDF(2),1,2)="LR"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)) D CHK55 - I $L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)),($E(OCXDF(2),1,2)="LR"),$L(OCXDF(37)) S OCXDF(146)=$P($$PATLOC(OCXDF(37)),"^",1) I $L(OCXDF(146)),$L(OCXDF(34)) D CHK144^OCXOZ07 - Q - ; -CHK55 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK47+19. - ; - Q:$G(OCXOERR) - ; - ; Local CHK55 Variables - ; OCXDF(113) --> Data Field: LAB TEST ID (NUMERIC) - ; OCXDF(114) --> Data Field: LAB TEST PRINT NAME (FREE TEXT) - ; - ; Local Extrinsic Functions - ; FILE(DFN,24, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: HL7 LAB TEST RESULTS CRITICAL) - ; - I $L(OCXDF(113)) S OCXDF(114)=$$PRINTNAM^ORQQLR1(OCXDF(113)),OCXOERR=$$FILE(DFN,24,"12,13,96,114") Q:OCXOERR - Q - ; -CHK58 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from UPDATE+12^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - ; Local CHK58 Variables - ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(40) ---> Data Field: ORDER MODE (FREE TEXT) - ; OCXDF(47) ---> Data Field: OI LOCAL TEXT (FREE TEXT) - ; OCXDF(73) ---> Data Field: ORDERABLE ITEM IEN (NUMERIC) - ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) - ; OCXDF(143) --> Data Field: DANGEROUS MEDS FOR PT > 64 NAME (FREE TEXT) - ; - ; Local Extrinsic Functions - ; DMED64( ----------> DANGEROUS MEDS FOR PATIENTS > 64 - ; - S OCXDF(2)=$P($G(OCXPSD),"|",2) I $L(OCXDF(2)) D CHK60 - S OCXDF(40)=$G(OCXPSM) I $L(OCXDF(40)) D CHK163^OCXOZ07 - S OCXDF(47)=$P($P($G(OCXPSD),"|",3),"^",5) I $L(OCXDF(47)) D CHK188^OCXOZ09 - S OCXDF(131)=$P($P($G(OCXPSD),"|",3),"^",4) I $L(OCXDF(131)) S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) D CHK347^OCXOZ0C - S OCXDF(73)=$P($G(OCXPSD),"|",1) I $L(OCXDF(73)) S OCXDF(143)=$P($$DMED64(OCXDF(73)),"^",2) I $L(OCXDF(143)) D CHK398^OCXOZ0D - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) D CHK446^OCXOZ0F - Q - ; -CHK60 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK58+17. - ; - Q:$G(OCXOERR) - ; - ; Local CHK60 Variables - ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) - ; - ; Local Extrinsic Functions - ; FILE(DFN,135, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: DIET ORDER) - ; FILE(DFN,137, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: PHARMACY ORDER) - ; FILE(DFN,28, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: RADIOLOGY ORDER) - ; - I (OCXDF(2)="RA") S OCXOERR=$$FILE(DFN,28,"") Q:OCXOERR - I (OCXDF(2)="FH") S OCXOERR=$$FILE(DFN,135,"") Q:OCXOERR - I ($E(OCXDF(2),1,2)="PS") S OCXOERR=$$FILE(DFN,137,"") Q:OCXOERR - Q - ; -CHK87 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK23+16^OCXOZ03. - ; - Q:$G(OCXOERR) - ; - ; Local CHK87 Variables - ; OCXDF(90) ---> Data Field: PATIENT MOVEMENT WARD CURRENT (FREE TEXT) - ; OCXDF(91) ---> Data Field: PATIENT MOVEMENT SERVICE CURRENT (FREE TEXT) - ; OCXDF(92) ---> Data Field: PATIENT MOVEMENT WARD IEN CURRENT (NUMERIC) - ; - ; Local Extrinsic Functions - ; POINTER( ---------> RETURN POINTED TO VALUE - ; WARDSERV( --------> GET WARD SERVICE - ; - I $L(OCXDF(92)) S OCXDF(91)=$$WARDSERV(OCXDF(92)) I $L(OCXDF(91)),($L(OCXDF(91))>0),'(OCXDF(91)="PSYCHIATRY") S OCXDF(90)=$$POINTER(42,$P($G(DGPMA),"^",6)) D CHK93 - Q - ; -CHK93 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK87+14. - ; - Q:$G(OCXOERR) - ; - ; Local CHK93 Variables - ; OCXDF(95) ---> Data Field: PATIENT MOVEMENT WARD PREVIOUS (FREE TEXT) - ; - ; Local Extrinsic Functions - ; FILE(DFN,42, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: PATIENT TRANSFERRED FROM PSYCH WARD) - ; POINTER( ---------> RETURN POINTED TO VALUE - ; - S OCXDF(95)=$$POINTER(42,$P($G(DGPM0),"^",6)),OCXOERR=$$FILE(DFN,42,"90,95") Q:OCXOERR - Q - ; -DMED64(OCXOI) ;ext func rtns med oi^med name if OCXOI is dangerous - N OCXTL,OCXT,OCXDM - Q:'$$TERMLKUP("DANGEROUS MEDS FOR PTS > 64",.OCXTL) "0^" - S OCXDM="",OCXT=0 F S OCXT=$O(OCXTL(OCXT)) Q:'OCXT D Q:$L(OCXDM) - .I OCXT=OCXOI S OCXDM=OCXT_"^"_OCXTL(OCXT) - Q:'$L(OCXDM) "0^" - Q OCXDM - ; -FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. - ; - N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI - S DFN=+$G(DFN),OCXELE=+$G(OCXELE) - ; - Q:'DFN 1 Q:'OCXELE 1 K OCXDATA - ; - S OCXDATA(DFN,OCXELE)=1 - F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D - .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL - ; - M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) - ; - Q 0 - ; -LIST(DATA,LIST) ; IS THE DATA FIELD IN THE LIST - ; - S:'($E(LIST,1)=",") LIST=","_LIST S:'($E(LIST,$L(LIST))=",") LIST=LIST_"," S DATA=","_DATA_"," - Q (LIST[DATA) - ; -ORDITEM(OIEN) ; Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER - Q:'$G(OIEN) "" - ; - N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found." - S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found." - Q $P(X,U,1) - ; -PATLOC(DFN) ; Compiler Function: PATIENT LOCATION - ; - N OCXP1,OCXP2 - S OCXP1=$G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",2)) - S OCXP2=$P($G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",3)),"^",1) - I OCXP2 D - .S OCXP2=$P($G(^SC(+OCXP2,0)),"^",1,2) - .I $L($P(OCXP2,"^",2)) S OCXP2=$P(OCXP2,"^",2) - .E S OCXP2=$P(OCXP2,"^",1) - .S:'$L(OCXP2) OCXP2="NO LOC" - I $L(OCXP1),$L(OCXP2) Q OCXP1_"^"_OCXP2 - ; - S OCXP2=$G(^DPT(+$G(DFN),.1)) - I $L(OCXP2) Q "I^"_OCXP2 - Q "O^OUTPT" - ; -POINTER(OCXFILE,D0) ; This Local Extrinsic Function gets the value of the name field - ; of record D0 in file OCXFILE - Q:'$G(D0) "" Q:'$L($G(OCXFILE)) "" - N GLREF - I '(OCXFILE=(+OCXFILE)) S GLREF=U_OCXFILE - E S GLREF=$$FILE^OCXBDTD(+OCXFILE,"GLOBAL NAME") Q:'$L(GLREF) "" - Q $P($G(@(GLREF_(+D0)_",0)")),U,1) - ; -TERMLKUP(OCXTERM,OCXLIST) ; - Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST) - ; -WARDSERV(WARD) ; Compiler Function: GET WARD SERVICE - ; - N CODESET,PC,SERV,DIC,X,Y,DA - S CODESET="M:MEDICINE;S:SURGERY;P:PSYCHIATRY;NH:NHCU;NE:NEUROLOGY;I:INTERMEDIATE MED;R:REHAB MEDICINE;SCI:SPINAL CORD INJURY;D:DOMICILIARY;B:BLIND REHAB;NC:NON-COUNT" - S DIC=42,DIC(0)="NZ",X="`"_(+WARD) D ^DIC Q:(Y<1) "" - S SERV=$P($G(Y(0)),U,3) - Q:'$L(SERV) "" Q:'$L(CODESET) "" - F PC=1:1:$L(CODESET,";"),0 I PC,($P($P(CODESET,";",PC),":",1)=SERV) Q - Q:'PC "" Q $P($P(CODESET,";",PC),":",2) - ; +OCXOZ05 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; + ; *************************************************************** + ; ** Warning: This routine is automatically generated by the ** + ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** + ; ** will be lost the next time the rule compiler executes. ** + ; *************************************************************** + ; + Q + ; +CHK47 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK1+29^OCXOZ02. + ; + Q:$G(OCXOERR) + ; + ; Local CHK47 Variables + ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT) + ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) + ; OCXDF(6) ----> Data Field: ABNORMAL FLAG (FREE TEXT) + ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) + ; OCXDF(146) --> Data Field: INPT/OUTPT (FREE TEXT) + ; + ; Local Extrinsic Functions + ; LIST( ------------> IN LIST OPERATOR + ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER + ; PATLOC( ----------> PATIENT LOCATION + ; + I $L(OCXDF(6)),$$LIST(OCXDF(6),"HH,LL"),$L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)),($E(OCXDF(2),1,2)="LR"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)) D CHK55 + I $L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)),($E(OCXDF(2),1,2)="LR"),$L(OCXDF(37)) S OCXDF(146)=$P($$PATLOC(OCXDF(37)),"^",1) I $L(OCXDF(146)),$L(OCXDF(34)) D CHK144^OCXOZ07 + Q + ; +CHK55 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK47+19. + ; + Q:$G(OCXOERR) + ; + ; Local CHK55 Variables + ; OCXDF(113) --> Data Field: LAB TEST ID (NUMERIC) + ; OCXDF(114) --> Data Field: LAB TEST PRINT NAME (FREE TEXT) + ; + ; Local Extrinsic Functions + ; FILE(DFN,24, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: HL7 LAB TEST RESULTS CRITICAL) + ; + I $L(OCXDF(113)) S OCXDF(114)=$$PRINTNAM^ORQQLR1(OCXDF(113)),OCXOERR=$$FILE(DFN,24,"12,13,96,114") Q:OCXOERR + Q + ; +CHK58 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from UPDATE+12^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + ; Local CHK58 Variables + ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(40) ---> Data Field: ORDER MODE (FREE TEXT) + ; OCXDF(47) ---> Data Field: OI LOCAL TEXT (FREE TEXT) + ; OCXDF(73) ---> Data Field: ORDERABLE ITEM IEN (NUMERIC) + ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) + ; OCXDF(143) --> Data Field: DANGEROUS MEDS FOR PT > 64 NAME (FREE TEXT) + ; + ; Local Extrinsic Functions + ; DMED64( ----------> DANGEROUS MEDS FOR PATIENTS > 64 + ; + S OCXDF(2)=$P($G(OCXPSD),"|",2) I $L(OCXDF(2)) D CHK60 + S OCXDF(40)=$G(OCXPSM) I $L(OCXDF(40)) D CHK163^OCXOZ07 + S OCXDF(47)=$P($P($G(OCXPSD),"|",3),"^",5) I $L(OCXDF(47)) D CHK188^OCXOZ09 + S OCXDF(131)=$P($P($G(OCXPSD),"|",3),"^",4) I $L(OCXDF(131)) S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) D CHK347^OCXOZ0C + S OCXDF(73)=$P($G(OCXPSD),"|",1) I $L(OCXDF(73)) S OCXDF(143)=$P($$DMED64(OCXDF(73)),"^",2) I $L(OCXDF(143)) D CHK406^OCXOZ0E + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) D CHK454^OCXOZ0F + Q + ; +CHK60 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK58+17. + ; + Q:$G(OCXOERR) + ; + ; Local CHK60 Variables + ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) + ; + ; Local Extrinsic Functions + ; FILE(DFN,135, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: DIET ORDER) + ; FILE(DFN,137, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: PHARMACY ORDER) + ; FILE(DFN,28, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: RADIOLOGY ORDER) + ; + I (OCXDF(2)="RA") S OCXOERR=$$FILE(DFN,28,"") Q:OCXOERR + I (OCXDF(2)="FH") S OCXOERR=$$FILE(DFN,135,"") Q:OCXOERR + I ($E(OCXDF(2),1,2)="PS") S OCXOERR=$$FILE(DFN,137,"") Q:OCXOERR + Q + ; +CHK87 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK23+16^OCXOZ03. + ; + Q:$G(OCXOERR) + ; + ; Local CHK87 Variables + ; OCXDF(90) ---> Data Field: PATIENT MOVEMENT WARD CURRENT (FREE TEXT) + ; OCXDF(91) ---> Data Field: PATIENT MOVEMENT SERVICE CURRENT (FREE TEXT) + ; OCXDF(92) ---> Data Field: PATIENT MOVEMENT WARD IEN CURRENT (NUMERIC) + ; + ; Local Extrinsic Functions + ; POINTER( ---------> RETURN POINTED TO VALUE + ; WARDSERV( --------> GET WARD SERVICE + ; + I $L(OCXDF(92)) S OCXDF(91)=$$WARDSERV(OCXDF(92)) I $L(OCXDF(91)),($L(OCXDF(91))>0),'(OCXDF(91)="PSYCHIATRY") S OCXDF(90)=$$POINTER(42,$P($G(DGPMA),"^",6)) D CHK93 + Q + ; +CHK93 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK87+14. + ; + Q:$G(OCXOERR) + ; + ; Local CHK93 Variables + ; OCXDF(95) ---> Data Field: PATIENT MOVEMENT WARD PREVIOUS (FREE TEXT) + ; + ; Local Extrinsic Functions + ; FILE(DFN,42, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: PATIENT TRANSFERRED FROM PSYCH WARD) + ; POINTER( ---------> RETURN POINTED TO VALUE + ; + S OCXDF(95)=$$POINTER(42,$P($G(DGPM0),"^",6)),OCXOERR=$$FILE(DFN,42,"90,95") Q:OCXOERR + Q + ; +DMED64(OCXOI) ;ext func rtns med oi^med name if OCXOI is dangerous + N OCXTL,OCXT,OCXDM + Q:'$$TERMLKUP("DANGEROUS MEDS FOR PTS > 64",.OCXTL) "0^" + S OCXDM="",OCXT=0 F S OCXT=$O(OCXTL(OCXT)) Q:'OCXT D Q:$L(OCXDM) + .I OCXT=OCXOI S OCXDM=OCXT_"^"_OCXTL(OCXT) + Q:'$L(OCXDM) "0^" + Q OCXDM + ; +FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. + ; + N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI + S DFN=+$G(DFN),OCXELE=+$G(OCXELE) + ; + Q:'DFN 1 Q:'OCXELE 1 K OCXDATA + ; + S OCXDATA(DFN,OCXELE)=1 + F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D + .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL + ; + M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) + ; + Q 0 + ; +LIST(DATA,LIST) ; IS THE DATA FIELD IN THE LIST + ; + S:'($E(LIST,1)=",") LIST=","_LIST S:'($E(LIST,$L(LIST))=",") LIST=LIST_"," S DATA=","_DATA_"," + Q (LIST[DATA) + ; +ORDITEM(OIEN) ; Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER + Q:'$G(OIEN) "" + ; + N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found." + S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found." + Q $P(X,U,1) + ; +PATLOC(DFN) ; Compiler Function: PATIENT LOCATION + ; + N OCXP1,OCXP2 + S OCXP1=$G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",2)) + S OCXP2=$P($G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",3)),"^",1) + I OCXP2 D + .S OCXP2=$P($G(^SC(+OCXP2,0)),"^",1,2) + .I $L($P(OCXP2,"^",2)) S OCXP2=$P(OCXP2,"^",2) + .E S OCXP2=$P(OCXP2,"^",1) + .S:'$L(OCXP2) OCXP2="NO LOC" + I $L(OCXP1),$L(OCXP2) Q OCXP1_"^"_OCXP2 + ; + S OCXP2=$G(^DPT(+$G(DFN),.1)) + I $L(OCXP2) Q "I^"_OCXP2 + Q "O^OUTPT" + ; +POINTER(OCXFILE,D0) ; This Local Extrinsic Function gets the value of the name field + ; of record D0 in file OCXFILE + Q:'$G(D0) "" Q:'$L($G(OCXFILE)) "" + N GLREF + I '(OCXFILE=(+OCXFILE)) S GLREF=U_OCXFILE + E S GLREF=$$FILE^OCXBDTD(+OCXFILE,"GLOBAL NAME") Q:'$L(GLREF) "" + Q $P($G(@(GLREF_(+D0)_",0)")),U,1) + ; +TERMLKUP(OCXTERM,OCXLIST) ; + Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST) + ; +WARDSERV(WARD) ; Compiler Function: GET WARD SERVICE + ; + N CODESET,PC,SERV,DIC,X,Y,DA + S CODESET="M:MEDICINE;S:SURGERY;P:PSYCHIATRY;NH:NHCU;NE:NEUROLOGY;I:INTERMEDIATE MED;R:REHAB MEDICINE;SCI:SPINAL CORD INJURY;D:DOMICILIARY;B:BLIND REHAB;NC:NON-COUNT" + S DIC=42,DIC(0)="NZ",X="`"_(+WARD) D ^DIC Q:(Y<1) "" + S SERV=$P($G(Y(0)),U,3) + Q:'$L(SERV) "" Q:'$L(CODESET) "" + F PC=1:1:$L(CODESET,";"),0 I PC,($P($P(CODESET,";",PC),":",1)=SERV) Q + Q:'PC "" Q $P($P(CODESET,";",PC),":",2) + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ06.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ06.m index a4909b9a..dcc8a65d 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ06.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ06.m @@ -1,184 +1,184 @@ -OCXOZ06 ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; - ; *************************************************************** - ; ** Warning: This routine is automatically generated by the ** - ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** - ; ** will be lost the next time the rule compiler executes. ** - ; *************************************************************** - ; - Q - ; -CHK95 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from UPDATE+13^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - ; Local CHK95 Variables - ; OCXDF(27) ---> Data Field: ORDER FLAGGED FOR CLARIFICATION (BOOLEAN) - ; OCXDF(28) ---> Data Field: ORDER REQ. CHART SIGN. (BOOLEAN) - ; OCXDF(29) ---> Data Field: SERV. ORDER REQ CHART SIG. (BOOLEAN) - ; OCXDF(30) ---> Data Field: ORDER REQ. CO-SIG. (BOOLEAN) - ; OCXDF(31) ---> Data Field: ORDER REQ. ELEC. SIG. (BOOLEAN) - ; - ; Local Extrinsic Functions - ; FILE(DFN,45, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: ORDER REQUIRES CHART SIGNATURE) - ; FILE(DFN,46, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: SERVICE ORDER REQUIRES CHART SIGNATURE) - ; FILE(DFN,47, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: ORDER REQUIRES CO-SIGNATURE) - ; FILE(DFN,48, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: ORDER REQUIRES ELECTRONIC SIGNATURE) - ; - S OCXDF(27)=$P($G(OCXORD),"^",4) I $L(OCXDF(27)) D CHK97 - S OCXDF(28)=$P($G(OCXORD),"^",5) I $L(OCXDF(28)),(OCXDF(28)) S OCXOERR=$$FILE(DFN,45,"") Q:OCXOERR - S OCXDF(29)=$P($G(OCXORD),"^",6) I $L(OCXDF(29)),(OCXDF(29)) S OCXOERR=$$FILE(DFN,46,"") Q:OCXOERR - S OCXDF(30)=$P($G(OCXORD),"^",7) I $L(OCXDF(30)),(OCXDF(30)) S OCXOERR=$$FILE(DFN,47,"") Q:OCXOERR - S OCXDF(31)=$P($G(OCXORD),"^",8) I $L(OCXDF(31)),(OCXDF(31)) S OCXOERR=$$FILE(DFN,48,"") Q:OCXOERR - Q - ; -CHK97 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK95+18. - ; - Q:$G(OCXOERR) - ; - ; Local CHK97 Variables - ; OCXDF(27) ---> Data Field: ORDER FLAGGED FOR CLARIFICATION (BOOLEAN) - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(115) --> Data Field: CURRENT DATE/TIME (FREE TEXT) - ; - ; Local Extrinsic Functions - ; DT2INT( ----------> CONVERT DATE FROM FILEMAN FORMAT TO OCX FORMAT - ; FILE(DFN,134, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: ORDER UNFLAGGED) - ; FILE(DFN,44, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: ORDER FLAGGED) - ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT - ; - I (OCXDF(27)) S OCXDF(37)=$P($G(OCXORD),"^",1),OCXDF(115)=$$INT2DT($$DT2INT("N"),0),OCXOERR=$$FILE(DFN,44,"37,115") Q:OCXOERR - I '(OCXDF(27)) S OCXDF(37)=$P($G(OCXORD),"^",1),OCXDF(115)=$$INT2DT($$DT2INT("N"),0),OCXOERR=$$FILE(DFN,134,"37,115") Q:OCXOERR - Q - ; -CHK113 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK1+30^OCXOZ02. - ; - Q:$G(OCXOERR) - ; - ; Local CHK113 Variables - ; OCXDF(32) ---> Data Field: ORDER FLAGGED FOR RESULTS (BOOLEAN) - ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) - ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) - ; OCXDF(105) --> Data Field: ORDER TEXT (51 CHARS) (FREE TEXT) - ; OCXDF(112) --> Data Field: ORDERED BY (FREE TEXT) - ; OCXDF(149) --> Data Field: ORDER CANCELED BY (FREE TEXT) - ; - ; Local Extrinsic Functions - ; CANCELER( --------> ORDER CANCELING PROVIDER - ; FILE(DFN,49, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: ORDER FLAGGED FOR RESULTS) - ; ORDERER( ---------> ORDERING PROVIDER - ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER - ; - S OCXDF(32)=$$RSLTFLG^ORQOR2(OCXDF(34)) I $L(OCXDF(32)),(OCXDF(32)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXOERR=$$FILE(DFN,49,"96") Q:OCXOERR - S OCXDF(112)=$$ORDERER(OCXDF(34)),OCXDF(149)=$$CANCELER(OCXDF(34)) I '(OCXDF(112)=OCXDF(149)) S OCXDF(105)=$P($$TEXT^ORKOR(OCXDF(34),51),"^",2) D CHK293^OCXOZ0B - Q - ; -CANCELER(ORNUM) ; Compiler Function: ORDER CANCELING PROVIDER - ; - Q:'$G(ORNUM) "" - S ORNUM=+$G(ORNUM) - N ORQDUZ - Q:'$D(^OR(100,ORNUM,6)) "" - S ORQDUZ=$P(^OR(100,ORNUM,6),U,2) - Q ORQDUZ - ; -DT2INT(OCXDT) ; This Local Extrinsic Function converts a date into an integer - ; By taking the Years, Months, Days, Hours and Minutes converting - ; Them into Seconds and then adding them all together into one big integer - ; - Q:'$L($G(OCXDT)) "" - N OCXDIFF,OCXVAL S (OCXDIFF,OCXVAL)=0 - ; - I $L(OCXDT),'OCXDT,(OCXDT[" at ") D ; EXTERNAL EXPERT SYSTEM FORMAT 1 TO EXTERNAL FORMAT - .N OCXHR,OCXMIN,OCXTIME - .S OCXTIME=$P($P(OCXDT," at ",2),".",1),OCXHR=$P(OCXTIME,":",1),OCXMIN=$P(OCXTIME,":",2) - .S:(OCXDT["Midnight") OCXHR=00 - .S:(OCXDT["PM") OCXHR=OCXHR+12 - .S OCXDT=$P(OCXDT," at ")_"@"_$E(OCXHR+100,2,3)_$E(OCXMIN+100,2,3) - ; - I $L(OCXDT),(OCXDT?1.2N1"/"1.2N.1" ".2N.1":".2N) D ; EXTERNAL EXPERT SYSTEM FORMAT 2 TO EXTERNAL FORMAT - .N OCXMON - .S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,$P(OCXDT,"/",1)) - .I $L($P(OCXDT," ",2)) S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_"@"_$TR($P(OCXDT," ",2),":","") - .E S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2) - ; - I $L(OCXDT),(OCXDT?1.2N1"/"1.2N1"/"1.2N.1" ".2N.1":".2N) D ; EXTERNAL EXPERT SYSTEM FORMAT 3 TO EXTERNAL FORMAT - .N OCXMON - .S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,$P(OCXDT,"/",1)) - .I $L($P(OCXDT," ",2)) S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_","_$P($P(OCXDT," ",1),"/",3)_"@"_$TR($P(OCXDT," ",2),":","") - .E S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_", "_$P($P(OCXDT," ",1),"/",3) - ; - I $L(OCXDT),'OCXDT D ; EXTERNAL FORMAT TO INTERNAL FILEMAN FORMAT - .I (OCXDT["@0000") S OCXDT=$P(OCXDT,"@",1),OCXDIFF=1 - .N %DT,X,Y S X=OCXDT,%DT="" S:(OCXDT["@")!(OCXDT="N") %DT="T" D ^%DT S OCXDT=+Y - ; - I ($L(OCXDT\1)>7) S OCXDT=$$HL7TFM^XLFDT(OCXDT) ; HL7 FORMAT TO INTERNAL FILEMAN FORMAT - ; - I ($L(OCXDT\1)=7) S OCXDT=$$FMTH^XLFDT(+OCXDT) ; INTERNAL FILEMAN FORMAT TO $H FORMAT - ; - I (OCXDT?5N1","1.5N) S OCXVAL=(OCXDT*86400)+$P(OCXDT,",",2) ; $H FORMAT TO EXPERT SYSTEM INTERNAL FORMAT - ; - Q OCXVAL - ; -FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. - ; - N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI - S DFN=+$G(DFN),OCXELE=+$G(OCXELE) - ; - Q:'DFN 1 Q:'OCXELE 1 K OCXDATA - ; - S OCXDATA(DFN,OCXELE)=1 - F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D - .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL - ; - M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) - ; - Q 0 - ; -INT2DT(OCXDT,OCXF) ; This Local Extrinsic Function converts an OCX internal format - ; date into an Externl Format (Human Readable) date. 'OCXF=SHORT FORMAT OCXF=LONG FORMAT - ; - Q:'$L($G(OCXDT)) "" S OCXF=+$G(OCXF) - N OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXCYR - S (OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXAP)="" - S OCXSEC=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 - S OCXMIN=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 - S OCXHR=$E(OCXDT#24+100,2,3),OCXDT=OCXDT\24 - S OCXCYR=($H\1461)*4+1841+(($H#1461)\365) - S OCXYR=(OCXDT\1461)*4+1841,OCXDT=OCXDT#1461 - S OCXLPYR=(OCXDT\365),OCXDT=OCXDT-(OCXLPYR*365),OCXYR=OCXYR+OCXLPYR - S OCXCNT="031^059^090^120^151^181^212^243^273^304^334^365" - S:(OCXLPYR=3) OCXCNT="031^060^091^121^152^182^213^244^274^305^335^366" - F OCXMON=1:1:12 Q:(OCXDT<$P(OCXCNT,U,OCXMON)) - S OCXDAY=OCXDT-$P(OCXCNT,U,OCXMON-1)+1 - I OCXF S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,OCXMON) - E S OCXMON=$E(OCXMON+100,2,3) - S OCXAP=$S('OCXHR:"Midnight",(OCXHR=12):"Noon",(OCXHR<12):"AM",1:"PM") - I OCXF S OCXHR=OCXHR#12 S:'OCXHR OCXHR=12 - Q:'OCXF $E(OCXMON+100,2,3)_"/"_$E(OCXDAY+100,2,3)_$S((OCXCYR=OCXYR):" "_OCXHR_":"_OCXMIN,1:"/"_$E(OCXYR,3,4)) - Q:(OCXHR+OCXMIN+OCXSEC) OCXMON_" "_OCXDAY_","_OCXYR_" at "_OCXHR_":"_OCXMIN_"."_OCXSEC_" "_OCXAP - Q OCXMON_" "_OCXDAY_","_OCXYR - ; -ORDERER(ORNUM) ; Compiler Function: ORDERING PROVIDER - ; - Q:'$G(ORNUM) "" - S ORNUM=+$G(ORNUM) - N ORQDUZ,ORQI S ORQDUZ="" - I $L($G(^OR(100,ORNUM,8,0))) D - .S ORQI=0,ORQI=$O(^OR(100,ORNUM,8,"C","NW",ORQI)) - Q:+$G(ORQI)<1 "" - S ORQDUZ=$P(^OR(100,ORNUM,8,ORQI,0),U,3) - Q ORQDUZ - ; -ORDITEM(OIEN) ; Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER - Q:'$G(OIEN) "" - ; - N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found." - S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found." - Q $P(X,U,1) - ; +OCXOZ06 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; + ; *************************************************************** + ; ** Warning: This routine is automatically generated by the ** + ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** + ; ** will be lost the next time the rule compiler executes. ** + ; *************************************************************** + ; + Q + ; +CHK95 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from UPDATE+13^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + ; Local CHK95 Variables + ; OCXDF(27) ---> Data Field: ORDER FLAGGED FOR CLARIFICATION (BOOLEAN) + ; OCXDF(28) ---> Data Field: ORDER REQ. CHART SIGN. (BOOLEAN) + ; OCXDF(29) ---> Data Field: SERV. ORDER REQ CHART SIG. (BOOLEAN) + ; OCXDF(30) ---> Data Field: ORDER REQ. CO-SIG. (BOOLEAN) + ; OCXDF(31) ---> Data Field: ORDER REQ. ELEC. SIG. (BOOLEAN) + ; + ; Local Extrinsic Functions + ; FILE(DFN,45, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: ORDER REQUIRES CHART SIGNATURE) + ; FILE(DFN,46, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: SERVICE ORDER REQUIRES CHART SIGNATURE) + ; FILE(DFN,47, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: ORDER REQUIRES CO-SIGNATURE) + ; FILE(DFN,48, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: ORDER REQUIRES ELECTRONIC SIGNATURE) + ; + S OCXDF(27)=$P($G(OCXORD),"^",4) I $L(OCXDF(27)) D CHK97 + S OCXDF(28)=$P($G(OCXORD),"^",5) I $L(OCXDF(28)),(OCXDF(28)) S OCXOERR=$$FILE(DFN,45,"") Q:OCXOERR + S OCXDF(29)=$P($G(OCXORD),"^",6) I $L(OCXDF(29)),(OCXDF(29)) S OCXOERR=$$FILE(DFN,46,"") Q:OCXOERR + S OCXDF(30)=$P($G(OCXORD),"^",7) I $L(OCXDF(30)),(OCXDF(30)) S OCXOERR=$$FILE(DFN,47,"") Q:OCXOERR + S OCXDF(31)=$P($G(OCXORD),"^",8) I $L(OCXDF(31)),(OCXDF(31)) S OCXOERR=$$FILE(DFN,48,"") Q:OCXOERR + Q + ; +CHK97 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK95+18. + ; + Q:$G(OCXOERR) + ; + ; Local CHK97 Variables + ; OCXDF(27) ---> Data Field: ORDER FLAGGED FOR CLARIFICATION (BOOLEAN) + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(115) --> Data Field: CURRENT DATE/TIME (FREE TEXT) + ; + ; Local Extrinsic Functions + ; DT2INT( ----------> CONVERT DATE FROM FILEMAN FORMAT TO OCX FORMAT + ; FILE(DFN,134, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: ORDER UNFLAGGED) + ; FILE(DFN,44, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: ORDER FLAGGED) + ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT + ; + I (OCXDF(27)) S OCXDF(37)=$P($G(OCXORD),"^",1),OCXDF(115)=$$INT2DT($$DT2INT("N"),0),OCXOERR=$$FILE(DFN,44,"37,115") Q:OCXOERR + I '(OCXDF(27)) S OCXDF(37)=$P($G(OCXORD),"^",1),OCXDF(115)=$$INT2DT($$DT2INT("N"),0),OCXOERR=$$FILE(DFN,134,"37,115") Q:OCXOERR + Q + ; +CHK113 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK1+30^OCXOZ02. + ; + Q:$G(OCXOERR) + ; + ; Local CHK113 Variables + ; OCXDF(32) ---> Data Field: ORDER FLAGGED FOR RESULTS (BOOLEAN) + ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) + ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) + ; OCXDF(105) --> Data Field: ORDER TEXT (51 CHARS) (FREE TEXT) + ; OCXDF(112) --> Data Field: ORDERED BY (FREE TEXT) + ; OCXDF(149) --> Data Field: ORDER CANCELED BY (FREE TEXT) + ; + ; Local Extrinsic Functions + ; CANCELER( --------> ORDER CANCELING PROVIDER + ; FILE(DFN,49, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: ORDER FLAGGED FOR RESULTS) + ; ORDERER( ---------> ORDERING PROVIDER + ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER + ; + S OCXDF(32)=$$RSLTFLG^ORQOR2(OCXDF(34)) I $L(OCXDF(32)),(OCXDF(32)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXOERR=$$FILE(DFN,49,"96") Q:OCXOERR + S OCXDF(112)=$$ORDERER(OCXDF(34)),OCXDF(149)=$$CANCELER(OCXDF(34)) I '(OCXDF(112)=OCXDF(149)) S OCXDF(105)=$P($$TEXT^ORKOR(OCXDF(34),51),"^",2) D CHK293^OCXOZ0B + Q + ; +CANCELER(ORNUM) ; Compiler Function: ORDER CANCELING PROVIDER + ; + Q:'$G(ORNUM) "" + S ORNUM=+$G(ORNUM) + N ORQDUZ + Q:'$D(^OR(100,ORNUM,6)) "" + S ORQDUZ=$P(^OR(100,ORNUM,6),U,2) + Q ORQDUZ + ; +DT2INT(OCXDT) ; This Local Extrinsic Function converts a date into an integer + ; By taking the Years, Months, Days, Hours and Minutes converting + ; Them into Seconds and then adding them all together into one big integer + ; + Q:'$L($G(OCXDT)) "" + N OCXDIFF,OCXVAL S (OCXDIFF,OCXVAL)=0 + ; + I $L(OCXDT),'OCXDT,(OCXDT[" at ") D ; EXTERNAL EXPERT SYSTEM FORMAT 1 TO EXTERNAL FORMAT + .N OCXHR,OCXMIN,OCXTIME + .S OCXTIME=$P($P(OCXDT," at ",2),".",1),OCXHR=$P(OCXTIME,":",1),OCXMIN=$P(OCXTIME,":",2) + .S:(OCXDT["Midnight") OCXHR=00 + .S:(OCXDT["PM") OCXHR=OCXHR+12 + .S OCXDT=$P(OCXDT," at ")_"@"_$E(OCXHR+100,2,3)_$E(OCXMIN+100,2,3) + ; + I $L(OCXDT),(OCXDT?1.2N1"/"1.2N.1" ".2N.1":".2N) D ; EXTERNAL EXPERT SYSTEM FORMAT 2 TO EXTERNAL FORMAT + .N OCXMON + .S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,$P(OCXDT,"/",1)) + .I $L($P(OCXDT," ",2)) S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_"@"_$TR($P(OCXDT," ",2),":","") + .E S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2) + ; + I $L(OCXDT),(OCXDT?1.2N1"/"1.2N1"/"1.2N.1" ".2N.1":".2N) D ; EXTERNAL EXPERT SYSTEM FORMAT 3 TO EXTERNAL FORMAT + .N OCXMON + .S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,$P(OCXDT,"/",1)) + .I $L($P(OCXDT," ",2)) S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_","_$P($P(OCXDT," ",1),"/",3)_"@"_$TR($P(OCXDT," ",2),":","") + .E S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_", "_$P($P(OCXDT," ",1),"/",3) + ; + I $L(OCXDT),'OCXDT D ; EXTERNAL FORMAT TO INTERNAL FILEMAN FORMAT + .I (OCXDT["@0000") S OCXDT=$P(OCXDT,"@",1),OCXDIFF=1 + .N %DT,X,Y S X=OCXDT,%DT="" S:(OCXDT["@")!(OCXDT="N") %DT="T" D ^%DT S OCXDT=+Y + ; + I ($L(OCXDT\1)>7) S OCXDT=$$HL7TFM^XLFDT(OCXDT) ; HL7 FORMAT TO INTERNAL FILEMAN FORMAT + ; + I ($L(OCXDT\1)=7) S OCXDT=$$FMTH^XLFDT(+OCXDT) ; INTERNAL FILEMAN FORMAT TO $H FORMAT + ; + I (OCXDT?5N1","1.5N) S OCXVAL=(OCXDT*86400)+$P(OCXDT,",",2) ; $H FORMAT TO EXPERT SYSTEM INTERNAL FORMAT + ; + Q OCXVAL + ; +FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. + ; + N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI + S DFN=+$G(DFN),OCXELE=+$G(OCXELE) + ; + Q:'DFN 1 Q:'OCXELE 1 K OCXDATA + ; + S OCXDATA(DFN,OCXELE)=1 + F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D + .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL + ; + M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) + ; + Q 0 + ; +INT2DT(OCXDT,OCXF) ; This Local Extrinsic Function converts an OCX internal format + ; date into an Externl Format (Human Readable) date. 'OCXF=SHORT FORMAT OCXF=LONG FORMAT + ; + Q:'$L($G(OCXDT)) "" S OCXF=+$G(OCXF) + N OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXCYR + S (OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXAP)="" + S OCXSEC=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 + S OCXMIN=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 + S OCXHR=$E(OCXDT#24+100,2,3),OCXDT=OCXDT\24 + S OCXCYR=($H\1461)*4+1841+(($H#1461)\365) + S OCXYR=(OCXDT\1461)*4+1841,OCXDT=OCXDT#1461 + S OCXLPYR=(OCXDT\365),OCXDT=OCXDT-(OCXLPYR*365),OCXYR=OCXYR+OCXLPYR + S OCXCNT="031^059^090^120^151^181^212^243^273^304^334^365" + S:(OCXLPYR=3) OCXCNT="031^060^091^121^152^182^213^244^274^305^335^366" + F OCXMON=1:1:12 Q:(OCXDT<$P(OCXCNT,U,OCXMON)) + S OCXDAY=OCXDT-$P(OCXCNT,U,OCXMON-1)+1 + I OCXF S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,OCXMON) + E S OCXMON=$E(OCXMON+100,2,3) + S OCXAP=$S('OCXHR:"Midnight",(OCXHR=12):"Noon",(OCXHR<12):"AM",1:"PM") + I OCXF S OCXHR=OCXHR#12 S:'OCXHR OCXHR=12 + Q:'OCXF $E(OCXMON+100,2,3)_"/"_$E(OCXDAY+100,2,3)_$S((OCXCYR=OCXYR):" "_OCXHR_":"_OCXMIN,1:"/"_$E(OCXYR,3,4)) + Q:(OCXHR+OCXMIN+OCXSEC) OCXMON_" "_OCXDAY_","_OCXYR_" at "_OCXHR_":"_OCXMIN_"."_OCXSEC_" "_OCXAP + Q OCXMON_" "_OCXDAY_","_OCXYR + ; +ORDERER(ORNUM) ; Compiler Function: ORDERING PROVIDER + ; + Q:'$G(ORNUM) "" + S ORNUM=+$G(ORNUM) + N ORQDUZ,ORQI S ORQDUZ="" + I $L($G(^OR(100,ORNUM,8,0))) D + .S ORQI=0,ORQI=$O(^OR(100,ORNUM,8,"C","NW",ORQI)) + Q:+$G(ORQI)<1 "" + S ORQDUZ=$P(^OR(100,ORNUM,8,ORQI,0),U,3) + Q ORQDUZ + ; +ORDITEM(OIEN) ; Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER + Q:'$G(OIEN) "" + ; + N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found." + S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found." + Q $P(X,U,1) + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ07.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ07.m index f64d19df..ac6413ea 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ07.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ07.m @@ -1,195 +1,195 @@ -OCXOZ07 ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; - ; *************************************************************** - ; ** Warning: This routine is automatically generated by the ** - ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** - ; ** will be lost the next time the rule compiler executes. ** - ; *************************************************************** - ; - Q - ; -CHK121 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK2+14^OCXOZ02. - ; - Q:$G(OCXOERR) - ; - ; Local CHK121 Variables - ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) - ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) - ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) - ; - ; Local Extrinsic Functions - ; FILE(DFN,101, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: HL7 FINAL IMAGING RESULT) - ; FILE(DFN,55, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CONSULT FINAL RESULTS) - ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER - ; - I (OCXDF(2)="GMRC"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXOERR=$$FILE(DFN,55,"96") Q:OCXOERR - I (OCXDF(2)="RA"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXOERR=$$FILE(DFN,101,"96") Q:OCXOERR - Q - ; -CHK131 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK12+33^OCXOZ03. - ; - Q:$G(OCXOERR) - ; - ; Local CHK131 Variables - ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(54) ---> Data Field: SITE FLAGGED ORDER (BOOLEAN) - ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) - ; OCXDF(146) --> Data Field: INPT/OUTPT (FREE TEXT) - ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT) - ; - ; Local Extrinsic Functions - ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER - ; PATLOC( ----------> PATIENT LOCATION - ; - S OCXDF(54)=$$SITEORD^ORB3F1(OCXDF(34),OCXDF(146)) I $L(OCXDF(54)),(OCXDF(54)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2) D CHK136 - Q - ; -CHK136 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK131+17. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; FILE(DFN,58, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: NEW SITE FLAGGED ORDER) - ; - S OCXOERR=$$FILE(DFN,58,"9,96,147") Q:OCXOERR - Q - ; -CHK144 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK47+20^OCXOZ05. - ; - Q:$G(OCXOERR) - ; - ; Local CHK144 Variables - ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(55) ---> Data Field: SITE FLAGGED RESULT (BOOLEAN) - ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) - ; OCXDF(146) --> Data Field: INPT/OUTPT (FREE TEXT) - ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT) - ; - ; Local Extrinsic Functions - ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER - ; PATLOC( ----------> PATIENT LOCATION - ; - S OCXDF(55)=$$SITERES^ORB3F1(OCXDF(34),OCXDF(146)) I $L(OCXDF(55)),(OCXDF(55)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2) D CHK149 - Q - ; -CHK149 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK144+17. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; FILE(DFN,59, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: SITE FLAGGED FINAL LAB RESULT) - ; - S OCXOERR=$$FILE(DFN,59,"9,96,147") Q:OCXOERR - Q - ; -CHK151 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK1+31^OCXOZ02. - ; - Q:$G(OCXOERR) - ; - ; Local CHK151 Variables - ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT) - ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) - ; OCXDF(15) ---> Data Field: RESULT STATUS (OBX) (FREE TEXT) - ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) - ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) - ; - ; Local Extrinsic Functions - ; FILE(DFN,60, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: NEW OBR STAT ORDER) - ; LIST( ------------> IN LIST OPERATOR - ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER - ; - I $L(OCXDF(1)),$$LIST(OCXDF(1),"NW,SN"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXOERR=$$FILE(DFN,60,"96") Q:OCXOERR - I $L(OCXDF(15)),(OCXDF(15)="F"),$L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)),($E(OCXDF(2),1,2)="LR"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)) D CHK264^OCXOZ0B - Q - ; -CHK157 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK1+32^OCXOZ02. - ; - Q:$G(OCXOERR) - ; - ; Local CHK157 Variables - ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT) - ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) - ; OCXDF(23) ---> Data Field: REQUEST STATUS (OBR) (FREE TEXT) - ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) - ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) - ; - ; Local Extrinsic Functions - ; FILE(DFN,61, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: NEW ORC STAT ORDER) - ; LIST( ------------> IN LIST OPERATOR - ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER - ; - I $L(OCXDF(1)),$$LIST(OCXDF(1),"NW,SN"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXOERR=$$FILE(DFN,61,"96") Q:OCXOERR - I $L(OCXDF(23)),(OCXDF(23)="F"),$L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)) D CHK253^OCXOZ0B - Q - ; -CHK163 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK58+18^OCXOZ05. - ; - Q:$G(OCXOERR) - ; - ; Local CHK163 Variables - ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(40) ---> Data Field: ORDER MODE (FREE TEXT) - ; OCXDF(43) ---> Data Field: OI NATIONAL ID (FREE TEXT) - ; - I (OCXDF(40)="ACCEPT") D CHK164^OCXOZ08 - I (OCXDF(40)="DISPLAY") S OCXDF(2)=$P($G(OCXPSD),"|",2) I $L(OCXDF(2)),($E(OCXDF(2),1,2)="PS") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) D CHK182^OCXOZ08 - I (OCXDF(40)="SELECT") D CHK196^OCXOZ09 - I (OCXDF(40)="SESSION") S OCXDF(2)=$P($G(OCXPSD),"|",2) I $L(OCXDF(2)),($E(OCXDF(2),1,2)="PS") S OCXDF(43)=$P($P($G(OCXPSD),"|",3),"^",1) I $L(OCXDF(43)) D CHK227^OCXOZ0A - Q - ; -FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. - ; - N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI - S DFN=+$G(DFN),OCXELE=+$G(OCXELE) - ; - Q:'DFN 1 Q:'OCXELE 1 K OCXDATA - ; - S OCXDATA(DFN,OCXELE)=1 - F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D - .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL - ; - M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) - ; - Q 0 - ; -LIST(DATA,LIST) ; IS THE DATA FIELD IN THE LIST - ; - S:'($E(LIST,1)=",") LIST=","_LIST S:'($E(LIST,$L(LIST))=",") LIST=LIST_"," S DATA=","_DATA_"," - Q (LIST[DATA) - ; -ORDITEM(OIEN) ; Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER - Q:'$G(OIEN) "" - ; - N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found." - S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found." - Q $P(X,U,1) - ; -PATLOC(DFN) ; Compiler Function: PATIENT LOCATION - ; - N OCXP1,OCXP2 - S OCXP1=$G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",2)) - S OCXP2=$P($G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",3)),"^",1) - I OCXP2 D - .S OCXP2=$P($G(^SC(+OCXP2,0)),"^",1,2) - .I $L($P(OCXP2,"^",2)) S OCXP2=$P(OCXP2,"^",2) - .E S OCXP2=$P(OCXP2,"^",1) - .S:'$L(OCXP2) OCXP2="NO LOC" - I $L(OCXP1),$L(OCXP2) Q OCXP1_"^"_OCXP2 - ; - S OCXP2=$G(^DPT(+$G(DFN),.1)) - I $L(OCXP2) Q "I^"_OCXP2 - Q "O^OUTPT" - ; +OCXOZ07 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; + ; *************************************************************** + ; ** Warning: This routine is automatically generated by the ** + ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** + ; ** will be lost the next time the rule compiler executes. ** + ; *************************************************************** + ; + Q + ; +CHK121 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK2+14^OCXOZ02. + ; + Q:$G(OCXOERR) + ; + ; Local CHK121 Variables + ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) + ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) + ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) + ; + ; Local Extrinsic Functions + ; FILE(DFN,101, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: HL7 FINAL IMAGING RESULT) + ; FILE(DFN,55, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CONSULT FINAL RESULTS) + ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER + ; + I (OCXDF(2)="GMRC"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXOERR=$$FILE(DFN,55,"96") Q:OCXOERR + I (OCXDF(2)="RA"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXOERR=$$FILE(DFN,101,"96") Q:OCXOERR + Q + ; +CHK131 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK12+33^OCXOZ03. + ; + Q:$G(OCXOERR) + ; + ; Local CHK131 Variables + ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(54) ---> Data Field: SITE FLAGGED ORDER (BOOLEAN) + ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) + ; OCXDF(146) --> Data Field: INPT/OUTPT (FREE TEXT) + ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT) + ; + ; Local Extrinsic Functions + ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER + ; PATLOC( ----------> PATIENT LOCATION + ; + S OCXDF(54)=$$SITEORD^ORB3F1(OCXDF(34),OCXDF(146)) I $L(OCXDF(54)),(OCXDF(54)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2) D CHK136 + Q + ; +CHK136 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK131+17. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; FILE(DFN,58, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: NEW SITE FLAGGED ORDER) + ; + S OCXOERR=$$FILE(DFN,58,"9,96,147") Q:OCXOERR + Q + ; +CHK144 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK47+20^OCXOZ05. + ; + Q:$G(OCXOERR) + ; + ; Local CHK144 Variables + ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(55) ---> Data Field: SITE FLAGGED RESULT (BOOLEAN) + ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) + ; OCXDF(146) --> Data Field: INPT/OUTPT (FREE TEXT) + ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT) + ; + ; Local Extrinsic Functions + ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER + ; PATLOC( ----------> PATIENT LOCATION + ; + S OCXDF(55)=$$SITERES^ORB3F1(OCXDF(34),OCXDF(146)) I $L(OCXDF(55)),(OCXDF(55)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2) D CHK149 + Q + ; +CHK149 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK144+17. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; FILE(DFN,59, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: SITE FLAGGED FINAL LAB RESULT) + ; + S OCXOERR=$$FILE(DFN,59,"9,96,147") Q:OCXOERR + Q + ; +CHK151 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK1+31^OCXOZ02. + ; + Q:$G(OCXOERR) + ; + ; Local CHK151 Variables + ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT) + ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) + ; OCXDF(15) ---> Data Field: RESULT STATUS (OBX) (FREE TEXT) + ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) + ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) + ; + ; Local Extrinsic Functions + ; FILE(DFN,60, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: NEW OBR STAT ORDER) + ; LIST( ------------> IN LIST OPERATOR + ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER + ; + I $L(OCXDF(1)),$$LIST(OCXDF(1),"NW,SN"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXOERR=$$FILE(DFN,60,"96") Q:OCXOERR + I $L(OCXDF(15)),(OCXDF(15)="F"),$L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)),($E(OCXDF(2),1,2)="LR"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)) D CHK264^OCXOZ0B + Q + ; +CHK157 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK1+32^OCXOZ02. + ; + Q:$G(OCXOERR) + ; + ; Local CHK157 Variables + ; OCXDF(1) ----> Data Field: CONTROL CODE (FREE TEXT) + ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) + ; OCXDF(23) ---> Data Field: REQUEST STATUS (OBR) (FREE TEXT) + ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) + ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) + ; + ; Local Extrinsic Functions + ; FILE(DFN,61, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: NEW ORC STAT ORDER) + ; LIST( ------------> IN LIST OPERATOR + ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER + ; + I $L(OCXDF(1)),$$LIST(OCXDF(1),"NW,SN"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXOERR=$$FILE(DFN,61,"96") Q:OCXOERR + I $L(OCXDF(23)),(OCXDF(23)="F"),$L(OCXDF(1)),$$LIST(OCXDF(1),"RE"),$L(OCXDF(2)) D CHK253^OCXOZ0B + Q + ; +CHK163 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK58+18^OCXOZ05. + ; + Q:$G(OCXOERR) + ; + ; Local CHK163 Variables + ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(40) ---> Data Field: ORDER MODE (FREE TEXT) + ; OCXDF(43) ---> Data Field: OI NATIONAL ID (FREE TEXT) + ; + I (OCXDF(40)="ACCEPT") D CHK164^OCXOZ08 + I (OCXDF(40)="DISPLAY") S OCXDF(2)=$P($G(OCXPSD),"|",2) I $L(OCXDF(2)),($E(OCXDF(2),1,2)="PS") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) D CHK182^OCXOZ08 + I (OCXDF(40)="SELECT") D CHK196^OCXOZ09 + I (OCXDF(40)="SESSION") S OCXDF(2)=$P($G(OCXPSD),"|",2) I $L(OCXDF(2)),($E(OCXDF(2),1,2)="PS") S OCXDF(43)=$P($P($G(OCXPSD),"|",3),"^",1) I $L(OCXDF(43)) D CHK227^OCXOZ0A + Q + ; +FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. + ; + N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI + S DFN=+$G(DFN),OCXELE=+$G(OCXELE) + ; + Q:'DFN 1 Q:'OCXELE 1 K OCXDATA + ; + S OCXDATA(DFN,OCXELE)=1 + F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D + .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL + ; + M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) + ; + Q 0 + ; +LIST(DATA,LIST) ; IS THE DATA FIELD IN THE LIST + ; + S:'($E(LIST,1)=",") LIST=","_LIST S:'($E(LIST,$L(LIST))=",") LIST=LIST_"," S DATA=","_DATA_"," + Q (LIST[DATA) + ; +ORDITEM(OIEN) ; Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER + Q:'$G(OIEN) "" + ; + N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found." + S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found." + Q $P(X,U,1) + ; +PATLOC(DFN) ; Compiler Function: PATIENT LOCATION + ; + N OCXP1,OCXP2 + S OCXP1=$G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",2)) + S OCXP2=$P($G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",3)),"^",1) + I OCXP2 D + .S OCXP2=$P($G(^SC(+OCXP2,0)),"^",1,2) + .I $L($P(OCXP2,"^",2)) S OCXP2=$P(OCXP2,"^",2) + .E S OCXP2=$P(OCXP2,"^",1) + .S:'$L(OCXP2) OCXP2="NO LOC" + I $L(OCXP1),$L(OCXP2) Q OCXP1_"^"_OCXP2 + ; + S OCXP2=$G(^DPT(+$G(DFN),.1)) + I $L(OCXP2) Q "I^"_OCXP2 + Q "O^OUTPT" + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ08.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ08.m index ab78f8e0..ef876f54 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ08.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ08.m @@ -1,191 +1,191 @@ -OCXOZ08 ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; - ; *************************************************************** - ; ** Warning: This routine is automatically generated by the ** - ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** - ; ** will be lost the next time the rule compiler executes. ** - ; *************************************************************** - ; - Q - ; -CHK164 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK163+11^OCXOZ07. - ; - Q:$G(OCXOERR) - ; - ; Local CHK164 Variables - ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(59) ---> Data Field: CHOLECYSTOGRAM PROCEDURE FLAG (BOOLEAN) - ; OCXDF(62) ---> Data Field: PATIENT AGE (NUMERIC) - ; OCXDF(73) ---> Data Field: ORDERABLE ITEM IEN (NUMERIC) - ; - ; Local Extrinsic Functions - ; CH( --------------> IS THIS A CHOLECYSTOGRAM RADIOLOGY PROCEDURE - ; - S OCXDF(73)=$P($G(OCXPSD),"|",1) I $L(OCXDF(73)) S OCXDF(59)=$P($$CH(OCXDF(73)),"^",1) I $L(OCXDF(59)),(OCXDF(59)) S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) D CHK171 - S OCXDF(2)=$P($G(OCXPSD),"|",2) I $L(OCXDF(2)),($E(OCXDF(2),1,2)="PS") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(62)=$$AGE^ORQPTQ4(OCXDF(37)) I $L(OCXDF(62)) D CHK426^OCXOZ0E - Q - ; -CHK171 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK164+15. - ; - Q:$G(OCXOERR) - ; - ; Local CHK171 Variables - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(60) ---> Data Field: RECENT CHOLECYSTOGRAM FLAG (BOOLEAN) - ; OCXDF(61) ---> Data Field: RECENT CHOLECYSTOGRAM TEXT (FREE TEXT) - ; OCXDF(122) --> Data Field: RECENT CHOLECYSTOGRAM ORDER STATUS (FREE TEXT) - ; - ; Local Extrinsic Functions - ; RECCH( -----------> RECENT CHOLECYSTOGRAM PREOCEDURE - ; RECCHST( ---------> RECENT CHOLECYSTOGRAM ORDER STATUS - ; - S OCXDF(60)=$P($$RECCH(OCXDF(37),7),"^",1) I $L(OCXDF(60)),(OCXDF(60)) S OCXDF(61)=$P($$RECCH(OCXDF(37),7),"^",3),OCXDF(122)=$P($$RECCHST(OCXDF(37),7),"^",2) D CHK176 - Q - ; -CHK176 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK171+15. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; FILE(DFN,63, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: PATIENT HAS RECENT CHOLECYSTOGRAM) - ; - S OCXOERR=$$FILE(DFN,63,"61,122") Q:OCXOERR - Q - ; -CHK182 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK163+12^OCXOZ07. - ; - Q:$G(OCXOERR) - ; - ; Local CHK182 Variables - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(62) ---> Data Field: PATIENT AGE (NUMERIC) - ; OCXDF(64) ---> Data Field: FORMATTED RENAL LAB RESULTS (FREE TEXT) - ; OCXDF(76) ---> Data Field: CREATININE CLEARANCE (ESTIM) VALUE (NUMERIC) - ; OCXDF(109) --> Data Field: NUMBER OF MEDS (NUMERIC) - ; OCXDF(123) --> Data Field: POLYPHARMACY (BOOLEAN) - ; - ; Local Extrinsic Functions - ; CRCL( ------------> CREATININE CLEARANCE (ESTIMATED/CALCULATED) - ; FILE(DFN,95, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: POLYPHARMACY) - ; FLAB( ------------> FORMATTED LAB RESULTS - ; - S OCXDF(62)=$$AGE^ORQPTQ4(OCXDF(37)) I $L(OCXDF(62)),(OCXDF(62)>65) S OCXDF(64)=$$FLAB(OCXDF(37),"SERUM CREATININE^SERUM UREA NITROGEN","SERUM SPECIMEN") D CHK186 - S OCXDF(76)=$P($$CRCL(OCXDF(37)),"^",2) I $L(OCXDF(76)),(OCXDF(76)<50),(OCXDF(76)>0) D CHK247^OCXOZ0B - S OCXDF(123)=$P($$POLYRX^ORKPS(OCXDF(37)),"^",1) I $L(OCXDF(123)),(OCXDF(123)) S OCXDF(109)=$P($$NUMRX^ORKPS(OCXDF(37)),"^",1),OCXOERR=$$FILE(DFN,95,"109") Q:OCXOERR - Q - ; -CHK186 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK182+18. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; FILE(DFN,64, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: PHARMACY PATIENT OVER 65) - ; - S OCXOERR=$$FILE(DFN,64,"64") Q:OCXOERR - Q - ; -CH(OCXOI) ; Compiler Function: IS THIS A CHOLECYSTOGRAM RADIOLOGY PROCEDURE - ; - N OCXVAL S OCXVAL=$$CM^ORQQRA(OCXOI) Q:(OCXVAL["C") 1_U_OCXVAL Q 0 - ; -CRCL(DFN) ; Compiler Function: CREATININE CLEARANCE (ESTIMATED/CALCULATED) - ; - N HT,AGE,SEX,SCR,SCRD,CRCL,LRWKLD,RSLT,ORW,ORH,PSCR - N HTGT60,ABW,IBW,BWRATIO,BWDIFF,LOWBW,ADJBW - S RSLT="0^" - S PSCR="^^^^^^0" - D VITAL^ORQQVI("WEIGHT","WT",DFN,.ORW,0,"",$$NOW^XLFDT) - Q:'$D(ORW) RSLT - S ABW=$P(ORW(1),U,3) Q:+$G(ABW)<1 RSLT - S ABW=ABW/2.2 ;ABW (actual body weight) in kg - D VITAL^ORQQVI("HEIGHT","HT",DFN,.ORH,0,"",$$NOW^XLFDT) - Q:'$D(ORH) RSLT - S HT=$P(ORH(1),U,3) Q:+$G(HT)<1 RSLT - S AGE=$$AGE^ORQPTQ4(DFN) Q:'AGE RSLT - S SEX=$P($$SEX^ORQPTQ4(DFN),U,1) Q:'$L(SEX) RSLT - S OCXTL="" Q:'$$TERMLKUP^ORB31(.OCXTL,"SERUM CREATININE") RSLT - S OCXTLS="" Q:'$$TERMLKUP^ORB31(.OCXTLS,"SERUM SPECIMEN") RSLT - S SCR="",OCXT=0 F S OCXT=$O(OCXTL(OCXT)) Q:'OCXT D - .S OCXTS=0 F S OCXTS=$O(OCXTLS(OCXTS)) Q:'OCXTS D - ..S SCR=$$LOCL^ORQQLR1(DFN,$P(OCXTL(OCXT),U),$P(OCXTLS(OCXTS),U)) - ..I $P(SCR,U,7)>$P(PSCR,U,7) S PSCR=SCR - S SCR=PSCR,SCRV=$P(SCR,U,3) Q:+$G(SCRV)<.01 RSLT - S SCRD=$P(SCR,U,7) Q:'$L(SCRD) RSLT - ; - S HTGT60=$S(HT>60:(HT-60)*2.3,1:0) ;if ht > 60 inches - I HTGT60>0 D - .S IBW=$S(SEX="M":50+HTGT60,1:45.5+HTGT60) ;Ideal Body Weight - .S BWRATIO=(ABW/IBW) ;body weight ratio - .S BWDIFF=$S(ABW>IBW:ABW-IBW,1:0) - .S LOWBW=$S(IBW1.3,(BWDIFF>0) S ADJBW=((0.3*BWDIFF)+IBW) - .E S ADJBW=LOWBW - I +$G(ADJBW)<1 D - .S ADJBW=ABW - S CRCL=(((140-AGE)*ADJBW)/(SCRV*72)) - ; - S:SEX="M" RSLT=SCRD_U_$J(CRCL,1,1) - S:SEX="F" RSLT=SCRD_U_$J((CRCL*.85),1,1) - Q RSLT - ; -FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. - ; - N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI - S DFN=+$G(DFN),OCXELE=+$G(OCXELE) - ; - Q:'DFN 1 Q:'OCXELE 1 K OCXDATA - ; - S OCXDATA(DFN,OCXELE)=1 - F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D - .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL - ; - M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) - ; - Q 0 - ; -FLAB(DFN,OCXLIST,OCXSPEC) ; Compiler Function: FORMATTED LAB RESULTS - ; - Q:'$G(DFN) "" - Q:'$L($G(OCXLIST)) "" - N OCXLAB,OCXOUT,OCXPC,OCXSL,SPEC S OCXOUT="",SPEC="" - I $L($G(OCXSPEC)) S OCXSL=$$TERMLKUP(OCXSPEC,.OCXSL) - F OCXPC=1:1:$L(OCXLIST,U) S OCXLAB=$P(OCXLIST,U,OCXPC) I $L(OCXLAB) D - .N OCXX,OCXY,X,Y,DIC,TEST,SPEC,OCXTL,OCXA,OCXR - .S OCXTL="" Q:'$$TERMLKUP(OCXLAB,.OCXTL) - .S OCXX="",TEST=0 F S TEST=$O(OCXTL(TEST)) Q:'TEST D - ..I $L($G(OCXSL)) D - ...S SPEC=0 F S SPEC=$O(OCXSL(SPEC)) Q:'SPEC D - ....S OCXX=$$LOCL^ORQQLR1(DFN,TEST,SPEC) I $L(OCXX) D - .....S OCXA($P(OCXX,U,7))=OCXX - ..I '$L($G(OCXSL)) S OCXX=$$LOCL^ORQQLR1(DFN,TEST,"") - ..Q:'$L(OCXX) - .I $D(OCXA) S OCXR="",OCXR=$O(OCXA(OCXR),-1),OCXX=OCXA(OCXR) - .I $L(OCXX) D - ..S OCXY=$P(OCXX,U,2)_": "_$P(OCXX,U,3)_" "_$P(OCXX,U,4) - ..S OCXY=OCXY_" "_$S($L($P(OCXX,U,5)):"["_$P(OCXX,U,5)_"]",1:"") - ..I $L($P(OCXX,U,7)) S OCXY=OCXY_" "_$$FMTE^XLFDT($P(OCXX,U,7),"2P") - .S:$L(OCXOUT) OCXOUT=OCXOUT_" " S OCXOUT=OCXOUT_$G(OCXY) - Q:'$L(OCXOUT) "" Q OCXOUT - ; -RECCH(DFN,DAYS) ; Compiler Function: RECENT CHOLECYSTOGRAM PREOCEDURE - ; - Q:'$G(DFN) 0 Q:'$G(DAYS) 0 N OUT S OUT=$$RECENTCH^ORKRA(DFN,DAYS) Q:'$L(OUT) 0 Q 1_U_OUT - ; -RECCHST(DFN,DAYS) ; Compiler Function: RECENT CHOLECYSTOGRAM ORDER STATUS - ; - Q:'$G(DFN) 0 Q:'$G(DAYS) 0 - N ORDER S ORDER=$P($$RECENTCH^ORKRA(DFN,DAYS),U) Q:'$L(ORDER) 0 - N STATUS S STATUS=$P($$STATUS^ORQOR2(ORDER),U,2) Q:'$L(STATUS) 0 - Q 1_U_STATUS - ; -TERMLKUP(OCXTERM,OCXLIST) ; - Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST) - ; +OCXOZ08 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; + ; *************************************************************** + ; ** Warning: This routine is automatically generated by the ** + ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** + ; ** will be lost the next time the rule compiler executes. ** + ; *************************************************************** + ; + Q + ; +CHK164 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK163+11^OCXOZ07. + ; + Q:$G(OCXOERR) + ; + ; Local CHK164 Variables + ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(59) ---> Data Field: CHOLECYSTOGRAM PROCEDURE FLAG (BOOLEAN) + ; OCXDF(62) ---> Data Field: PATIENT AGE (NUMERIC) + ; OCXDF(73) ---> Data Field: ORDERABLE ITEM IEN (NUMERIC) + ; + ; Local Extrinsic Functions + ; CH( --------------> IS THIS A CHOLECYSTOGRAM RADIOLOGY PROCEDURE + ; + S OCXDF(73)=$P($G(OCXPSD),"|",1) I $L(OCXDF(73)) S OCXDF(59)=$P($$CH(OCXDF(73)),"^",1) I $L(OCXDF(59)),(OCXDF(59)) S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) D CHK171 + S OCXDF(2)=$P($G(OCXPSD),"|",2) I $L(OCXDF(2)),($E(OCXDF(2),1,2)="PS") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(62)=$$AGE^ORQPTQ4(OCXDF(37)) I $L(OCXDF(62)) D CHK434^OCXOZ0E + Q + ; +CHK171 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK164+15. + ; + Q:$G(OCXOERR) + ; + ; Local CHK171 Variables + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(60) ---> Data Field: RECENT CHOLECYSTOGRAM FLAG (BOOLEAN) + ; OCXDF(61) ---> Data Field: RECENT CHOLECYSTOGRAM TEXT (FREE TEXT) + ; OCXDF(122) --> Data Field: RECENT CHOLECYSTOGRAM ORDER STATUS (FREE TEXT) + ; + ; Local Extrinsic Functions + ; RECCH( -----------> RECENT CHOLECYSTOGRAM PREOCEDURE + ; RECCHST( ---------> RECENT CHOLECYSTOGRAM ORDER STATUS + ; + S OCXDF(60)=$P($$RECCH(OCXDF(37),7),"^",1) I $L(OCXDF(60)),(OCXDF(60)) S OCXDF(61)=$P($$RECCH(OCXDF(37),7),"^",3),OCXDF(122)=$P($$RECCHST(OCXDF(37),7),"^",2) D CHK176 + Q + ; +CHK176 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK171+15. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; FILE(DFN,63, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: PATIENT HAS RECENT CHOLECYSTOGRAM) + ; + S OCXOERR=$$FILE(DFN,63,"61,122") Q:OCXOERR + Q + ; +CHK182 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK163+12^OCXOZ07. + ; + Q:$G(OCXOERR) + ; + ; Local CHK182 Variables + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(62) ---> Data Field: PATIENT AGE (NUMERIC) + ; OCXDF(64) ---> Data Field: FORMATTED RENAL LAB RESULTS (FREE TEXT) + ; OCXDF(76) ---> Data Field: CREATININE CLEARANCE (ESTIM) VALUE (NUMERIC) + ; OCXDF(109) --> Data Field: NUMBER OF MEDS (NUMERIC) + ; OCXDF(123) --> Data Field: POLYPHARMACY (BOOLEAN) + ; + ; Local Extrinsic Functions + ; CRCL( ------------> CREATININE CLEARANCE (ESTIMATED/CALCULATED) + ; FILE(DFN,95, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: POLYPHARMACY) + ; FLAB( ------------> FORMATTED LAB RESULTS + ; + S OCXDF(62)=$$AGE^ORQPTQ4(OCXDF(37)) I $L(OCXDF(62)),(OCXDF(62)>65) S OCXDF(64)=$$FLAB(OCXDF(37),"SERUM CREATININE^SERUM UREA NITROGEN","SERUM SPECIMEN") D CHK186 + S OCXDF(76)=$P($$CRCL(OCXDF(37)),"^",2) I $L(OCXDF(76)),(OCXDF(76)<50),(OCXDF(76)>0) D CHK247^OCXOZ0B + S OCXDF(123)=$P($$POLYRX^ORKPS(OCXDF(37)),"^",1) I $L(OCXDF(123)),(OCXDF(123)) S OCXDF(109)=$P($$NUMRX^ORKPS(OCXDF(37)),"^",1),OCXOERR=$$FILE(DFN,95,"109") Q:OCXOERR + Q + ; +CHK186 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK182+18. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; FILE(DFN,64, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: PHARMACY PATIENT OVER 65) + ; + S OCXOERR=$$FILE(DFN,64,"64") Q:OCXOERR + Q + ; +CH(OCXOI) ; Compiler Function: IS THIS A CHOLECYSTOGRAM RADIOLOGY PROCEDURE + ; + N OCXVAL S OCXVAL=$$CM^ORQQRA(OCXOI) Q:(OCXVAL["C") 1_U_OCXVAL Q 0 + ; +CRCL(DFN) ; Compiler Function: CREATININE CLEARANCE (ESTIMATED/CALCULATED) + ; + N HT,AGE,SEX,SCR,SCRD,CRCL,LRWKLD,RSLT,ORW,ORH,PSCR + N HTGT60,ABW,IBW,BWRATIO,BWDIFF,LOWBW,ADJBW + S RSLT="0^" + S PSCR="^^^^^^0" + D VITAL^ORQQVI("WEIGHT","WT",DFN,.ORW,0,"",$$NOW^XLFDT) + Q:'$D(ORW) RSLT + S ABW=$P(ORW(1),U,3) Q:+$G(ABW)<1 RSLT + S ABW=ABW/2.2 ;ABW (actual body weight) in kg + D VITAL^ORQQVI("HEIGHT","HT",DFN,.ORH,0,"",$$NOW^XLFDT) + Q:'$D(ORH) RSLT + S HT=$P(ORH(1),U,3) Q:+$G(HT)<1 RSLT + S AGE=$$AGE^ORQPTQ4(DFN) Q:'AGE RSLT + S SEX=$P($$SEX^ORQPTQ4(DFN),U,1) Q:'$L(SEX) RSLT + S OCXTL="" Q:'$$TERMLKUP^ORB31(.OCXTL,"SERUM CREATININE") RSLT + S OCXTLS="" Q:'$$TERMLKUP^ORB31(.OCXTLS,"SERUM SPECIMEN") RSLT + S SCR="",OCXT=0 F S OCXT=$O(OCXTL(OCXT)) Q:'OCXT D + .S OCXTS=0 F S OCXTS=$O(OCXTLS(OCXTS)) Q:'OCXTS D + ..S SCR=$$LOCL^ORQQLR1(DFN,$P(OCXTL(OCXT),U),$P(OCXTLS(OCXTS),U)) + ..I $P(SCR,U,7)>$P(PSCR,U,7) S PSCR=SCR + S SCR=PSCR,SCRV=$P(SCR,U,3) Q:+$G(SCRV)<.01 RSLT + S SCRD=$P(SCR,U,7) Q:'$L(SCRD) RSLT + ; + S HTGT60=$S(HT>60:(HT-60)*2.3,1:0) ;if ht > 60 inches + I HTGT60>0 D + .S IBW=$S(SEX="M":50+HTGT60,1:45.5+HTGT60) ;Ideal Body Weight + .S BWRATIO=(ABW/IBW) ;body weight ratio + .S BWDIFF=$S(ABW>IBW:ABW-IBW,1:0) + .S LOWBW=$S(IBW1.3,(BWDIFF>0) S ADJBW=((0.3*BWDIFF)+IBW) + .E S ADJBW=LOWBW + I +$G(ADJBW)<1 D + .S ADJBW=ABW + S CRCL=(((140-AGE)*ADJBW)/(SCRV*72)) + ; + S:SEX="M" RSLT=SCRD_U_$J(CRCL,1,1) + S:SEX="F" RSLT=SCRD_U_$J((CRCL*.85),1,1) + Q RSLT + ; +FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. + ; + N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI + S DFN=+$G(DFN),OCXELE=+$G(OCXELE) + ; + Q:'DFN 1 Q:'OCXELE 1 K OCXDATA + ; + S OCXDATA(DFN,OCXELE)=1 + F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D + .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL + ; + M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) + ; + Q 0 + ; +FLAB(DFN,OCXLIST,OCXSPEC) ; Compiler Function: FORMATTED LAB RESULTS + ; + Q:'$G(DFN) "" + Q:'$L($G(OCXLIST)) "" + N OCXLAB,OCXOUT,OCXPC,OCXSL,SPEC S OCXOUT="",SPEC="" + I $L($G(OCXSPEC)) S OCXSL=$$TERMLKUP(OCXSPEC,.OCXSL) + F OCXPC=1:1:$L(OCXLIST,U) S OCXLAB=$P(OCXLIST,U,OCXPC) I $L(OCXLAB) D + .N OCXX,OCXY,X,Y,DIC,TEST,SPEC,OCXTL,OCXA,OCXR + .S OCXTL="" Q:'$$TERMLKUP(OCXLAB,.OCXTL) + .S OCXX="",TEST=0 F S TEST=$O(OCXTL(TEST)) Q:'TEST D + ..I $L($G(OCXSL)) D + ...S SPEC=0 F S SPEC=$O(OCXSL(SPEC)) Q:'SPEC D + ....S OCXX=$$LOCL^ORQQLR1(DFN,TEST,SPEC) I $L(OCXX) D + .....S OCXA($P(OCXX,U,7))=OCXX + ..I '$L($G(OCXSL)) S OCXX=$$LOCL^ORQQLR1(DFN,TEST,"") + ..Q:'$L(OCXX) + .I $D(OCXA) S OCXR="",OCXR=$O(OCXA(OCXR),-1),OCXX=OCXA(OCXR) + .I $L(OCXX) D + ..S OCXY=$P(OCXX,U,2)_": "_$P(OCXX,U,3)_" "_$P(OCXX,U,4) + ..S OCXY=OCXY_" "_$S($L($P(OCXX,U,5)):"["_$P(OCXX,U,5)_"]",1:"") + ..I $L($P(OCXX,U,7)) S OCXY=OCXY_" "_$$FMTE^XLFDT($P(OCXX,U,7),"2P") + .S:$L(OCXOUT) OCXOUT=OCXOUT_" " S OCXOUT=OCXOUT_$G(OCXY) + Q:'$L(OCXOUT) "" Q OCXOUT + ; +RECCH(DFN,DAYS) ; Compiler Function: RECENT CHOLECYSTOGRAM PREOCEDURE + ; + Q:'$G(DFN) 0 Q:'$G(DAYS) 0 N OUT S OUT=$$RECENTCH^ORKRA(DFN,DAYS) Q:'$L(OUT) 0 Q 1_U_OUT + ; +RECCHST(DFN,DAYS) ; Compiler Function: RECENT CHOLECYSTOGRAM ORDER STATUS + ; + Q:'$G(DFN) 0 Q:'$G(DAYS) 0 + N ORDER S ORDER=$P($$RECENTCH^ORKRA(DFN,DAYS),U) Q:'$L(ORDER) 0 + N STATUS S STATUS=$P($$STATUS^ORQOR2(ORDER),U,2) Q:'$L(STATUS) 0 + Q 1_U_STATUS + ; +TERMLKUP(OCXTERM,OCXLIST) ; + Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST) + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ09.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ09.m index 22568996..f31b21e7 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ09.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ09.m @@ -1,207 +1,207 @@ -OCXOZ09 ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; - ; *************************************************************** - ; ** Warning: This routine is automatically generated by the ** - ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** - ; ** will be lost the next time the rule compiler executes. ** - ; *************************************************************** - ; - Q - ; -CHK188 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK58+19^OCXOZ05. - ; - Q:$G(OCXOERR) - ; - ; Local CHK188 Variables - ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) - ; OCXDF(40) ---> Data Field: ORDER MODE (FREE TEXT) - ; OCXDF(47) ---> Data Field: OI LOCAL TEXT (FREE TEXT) - ; - ; Local Extrinsic Functions - ; CLIST( -----------> STRING CONTAINS ONE OF A LIST OF VALUES - ; EQTERM( ----------> EQUALS TERM OPERATOR - ; - I $$EQTERM(OCXDF(47),"ANGIOGRAM (PERIPHERAL)") S OCXDF(40)=$G(OCXPSM) I $L(OCXDF(40)),(OCXDF(40)="SESSION") D CHK192 - I $$CLIST(OCXDF(47),"GLUCOPHAGE,METFORMIN") S OCXDF(40)=$G(OCXPSM) I $L(OCXDF(40)),(OCXDF(40)="SELECT") S OCXDF(2)=$P($G(OCXPSD),"|",2) I $L(OCXDF(2)) D CHK280^OCXOZ0B - Q - ; -CHK192 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK188+14. - ; - Q:$G(OCXOERR) - ; - ; Local CHK192 Variables - ; OCXDF(68) ---> Data Field: MISSING ANGIOGRAM, CATH PERIF LAB TESTS (FREE TEXT) - ; - ; Local Extrinsic Functions - ; FILE(DFN,65, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: SESSION ORDER FOR ANGIOGRAM) - ; MTSTF( -----------> MISSING TESTS DURING SESSION - ; - S OCXDF(68)=$$MTSTF("PROTHROMBIN TIME,PARTIAL THROMBOPLASTIN TIME") I $L(OCXDF(68)),($L(OCXDF(68))>0) S OCXOERR=$$FILE(DFN,65,"68") Q:OCXOERR - Q - ; -CHK196 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK163+13^OCXOZ07. - ; - Q:$G(OCXOERR) - ; - ; Local CHK196 Variables - ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(67) ---> Data Field: CONTRAST MEDIA CODE (FREE TEXT) - ; OCXDF(73) ---> Data Field: ORDERABLE ITEM IEN (NUMERIC) - ; OCXDF(156) --> Data Field: ALLERGY ASSESSMENT (BOOLEAN) - ; - ; Local Extrinsic Functions - ; ALRGY( -----------> ALLERGY ASSESSMENT - ; CLIST( -----------> STRING CONTAINS ONE OF A LIST OF VALUES - ; FILE(DFN,136, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: NO ALLERGY ASSESSMENT) - ; - S OCXDF(2)=$P($G(OCXPSD),"|",2) I $L(OCXDF(2)) D CHK198 - S OCXDF(73)=$P($G(OCXPSD),"|",1) I $L(OCXDF(73)) S OCXDF(67)=$$CM^ORQQRA(OCXDF(73)) I $L(OCXDF(67)),$$CLIST(OCXDF(67),"M,I,N") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) D CHK458^OCXOZ0F - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(156)=$$ALRGY(OCXDF(37)) I $L(OCXDF(156)),'(OCXDF(156)) S OCXOERR=$$FILE(DFN,136,"") Q:OCXOERR - Q - ; -CHK198 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK196+17. - ; - Q:$G(OCXOERR) - ; - ; Local CHK198 Variables - ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) - ; - I (OCXDF(2)="RA") D CHK199 - I ($E(OCXDF(2),1,2)="PS") D CHK360^OCXOZ0D - Q - ; -CHK199 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK198+8. - ; - Q:$G(OCXOERR) - ; - ; Local CHK199 Variables - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(73) ---> Data Field: ORDERABLE ITEM IEN (NUMERIC) - ; - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) D CHK201 - S OCXDF(73)=$P($G(OCXPSD),"|",1) I $L(OCXDF(73)) D CHK236^OCXOZ0A - Q - ; -CHK201 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK199+9. - ; - Q:$G(OCXOERR) - ; - ; Local CHK201 Variables - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(65) ---> Data Field: CONTRAST MEDIA ALLERGY FLAG (BOOLEAN) - ; OCXDF(67) ---> Data Field: CONTRAST MEDIA CODE (FREE TEXT) - ; OCXDF(69) ---> Data Field: RECENT BARIUM STUDY FLAG (BOOLEAN) - ; OCXDF(73) ---> Data Field: ORDERABLE ITEM IEN (NUMERIC) - ; - ; Local Extrinsic Functions - ; RECBAR( ----------> RECENT BARIUM STUDY - ; - S OCXDF(65)=$$ORCHK^GMRAOR(OCXDF(37),"CM","") I $L(OCXDF(65)),(OCXDF(65)) S OCXDF(73)=$P($G(OCXPSD),"|",1) I $L(OCXDF(73)) S OCXDF(67)=$$CM^ORQQRA(OCXDF(73)) D CHK207 - S OCXDF(69)=$P($$RECBAR(OCXDF(37),48),"^",1) I $L(OCXDF(69)),(OCXDF(69)) S OCXDF(73)=$P($G(OCXPSD),"|",1) I $L(OCXDF(73)) S OCXDF(67)=$$CM^ORQQRA(OCXDF(73)) D CHK217^OCXOZ0A - Q - ; -CHK207 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK201+15. - ; - Q:$G(OCXOERR) - ; - ; Local CHK207 Variables - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(66) ---> Data Field: CONTRAST MEDIA CODE TRANSLATION (FREE TEXT) - ; OCXDF(67) ---> Data Field: CONTRAST MEDIA CODE (FREE TEXT) - ; OCXDF(159) --> Data Field: ALLERGY CONTRAST MEDIA LOCATION (FREE TEXT) - ; - ; Local Extrinsic Functions - ; CLIST( -----------> STRING CONTAINS ONE OF A LIST OF VALUES - ; CONTRANS( --------> CONTRAST MEDIA CODE TRANSLATION - ; - I $L(OCXDF(67)),$$CLIST(OCXDF(67),"M,I,N,L,C,G,B") S OCXDF(66)=$$CONTRANS(OCXDF(67)),OCXDF(159)=$P($$ORCHK^GMRAOR(OCXDF(37),"CM","",1),"^",2) D CHK211 - Q - ; -CHK211 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK207+15. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; FILE(DFN,66, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CONTRAST MEDIA ALLERGY) - ; - S OCXOERR=$$FILE(DFN,66,"66,159") Q:OCXOERR - Q - ; -ALRGY(ORPT) ; determine if pt has an allergy assessment - ; rtn 0 if no allergy assessment, 1 if allergy assessment or NKA - N ORALRGY - D EN1^GMRAOR1(ORPT,"ORALRGY") - Q:$G(ORALRGY)="" 0 - Q 1 - ; -CLIST(DATA,LIST) ; DOES THE DATA FIELD CONTAIN AN ELEMENT IN THE LIST - ; - N PC F PC=1:1:$L(LIST,","),0 I PC,$L($P(LIST,",",PC)),(DATA[$P(LIST,",",PC)) Q - Q ''PC - ; -CONTRANS(OCXC) ; Compiler Function: CONTRAST MEDIA CODE TRANSLATION - ; - N OCXX - Q:'$L($G(OCXC)) "" S OCXX=$S((OCXC["B"):"Barium",1:"") - I (OCXC["G") S:$L(OCXX) OCXX=OCXX_" and/or " S OCXX=OCXX_"Gastrografin" - I (OCXC["I") S:$L(OCXX) OCXX=OCXX_" and/or " S OCXX=OCXX_"Ionic Iodinated" - I (OCXC["N") S:$L(OCXX) OCXX=OCXX_" and/or " S OCXX=OCXX_"Non-ionic Iodinated" - I (OCXC["L") S:$L(OCXX) OCXX=OCXX_" and/or " S OCXX=OCXX_"Gadolinium" - I (OCXC["C") S:$L(OCXX) OCXX=OCXX_" and/or " S OCXX=OCXX_"Cholecystographic" - I (OCXC["M") S:$L(OCXX) OCXX=OCXX_" and/or " S OCXX=OCXX_"Unspecified contrast media" - Q OCXX - ; -EQTERM(DATA,TERM) ; Compiler Function: EQUALS TERM OPERATOR - ; - N OCXF,OCXL - ; - S OCXL="",OCXF=$$TERMLKUP(TERM,.OCXL) - Q:'OCXF 0 - I ($D(OCXL(DATA))!$D(OCXL("B",DATA))) Q 1 - Q 0 - ; -FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. - ; - N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI - S DFN=+$G(DFN),OCXELE=+$G(OCXELE) - ; - Q:'DFN 1 Q:'OCXELE 1 K OCXDATA - ; - S OCXDATA(DFN,OCXELE)=1 - F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D - .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL - ; - M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) - ; - Q 0 - ; -MTSTF(OILIST) ; Compiler Function: MISSING TESTS DURING SESSION - ; - N OCXPC,OCXOI,OCXOUT S OCXOUT="" - F OCXPC=1:1:$L(OILIST,",") S OCXOI=$P(OILIST,",",OCXPC) I $L(OCXOI) D - .N OCXL,OCXF,OCXD0 - .S OCXL="",OCXF=$$TERMLKUP(OCXOI,.OCXL) - .S OCXD0=0 F S OCXD0=$O(OCXL(OCXD0)) Q:'OCXD0 Q:$$OISESS^ORKCHK2(+OCXD0) - .Q:OCXD0 - .S:$L(OCXOUT) OCXOUT=OCXOUT_", " S OCXOUT=OCXOUT_OCXOI - Q OCXOUT - ; -RECBAR(DFN,HOURS) ; Compiler Function: RECENT BARIUM STUDY - ; - Q:'$G(DFN) 0 Q:'$G(HOURS) 0 N OUT S OUT=$$RECENTBA^ORKRA(DFN,HOURS) Q:'$L(OUT) 0 Q 1_U_OUT - ; - ; -TERMLKUP(OCXTERM,OCXLIST) ; - Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST) - ; +OCXOZ09 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; + ; *************************************************************** + ; ** Warning: This routine is automatically generated by the ** + ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** + ; ** will be lost the next time the rule compiler executes. ** + ; *************************************************************** + ; + Q + ; +CHK188 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK58+19^OCXOZ05. + ; + Q:$G(OCXOERR) + ; + ; Local CHK188 Variables + ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) + ; OCXDF(40) ---> Data Field: ORDER MODE (FREE TEXT) + ; OCXDF(47) ---> Data Field: OI LOCAL TEXT (FREE TEXT) + ; + ; Local Extrinsic Functions + ; CLIST( -----------> STRING CONTAINS ONE OF A LIST OF VALUES + ; EQTERM( ----------> EQUALS TERM OPERATOR + ; + I $$EQTERM(OCXDF(47),"ANGIOGRAM (PERIPHERAL)") S OCXDF(40)=$G(OCXPSM) I $L(OCXDF(40)),(OCXDF(40)="SESSION") D CHK192 + I $$CLIST(OCXDF(47),"GLUCOPHAGE,METFORMIN") S OCXDF(40)=$G(OCXPSM) I $L(OCXDF(40)),(OCXDF(40)="SELECT") S OCXDF(2)=$P($G(OCXPSD),"|",2) I $L(OCXDF(2)) D CHK280^OCXOZ0B + Q + ; +CHK192 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK188+14. + ; + Q:$G(OCXOERR) + ; + ; Local CHK192 Variables + ; OCXDF(68) ---> Data Field: MISSING ANGIOGRAM, CATH PERIF LAB TESTS (FREE TEXT) + ; + ; Local Extrinsic Functions + ; FILE(DFN,65, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: SESSION ORDER FOR ANGIOGRAM) + ; MTSTF( -----------> MISSING TESTS DURING SESSION + ; + S OCXDF(68)=$$MTSTF("PROTHROMBIN TIME,PARTIAL THROMBOPLASTIN TIME") I $L(OCXDF(68)),($L(OCXDF(68))>0) S OCXOERR=$$FILE(DFN,65,"68") Q:OCXOERR + Q + ; +CHK196 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK163+13^OCXOZ07. + ; + Q:$G(OCXOERR) + ; + ; Local CHK196 Variables + ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(67) ---> Data Field: CONTRAST MEDIA CODE (FREE TEXT) + ; OCXDF(73) ---> Data Field: ORDERABLE ITEM IEN (NUMERIC) + ; OCXDF(156) --> Data Field: ALLERGY ASSESSMENT (BOOLEAN) + ; + ; Local Extrinsic Functions + ; ALRGY( -----------> ALLERGY ASSESSMENT + ; CLIST( -----------> STRING CONTAINS ONE OF A LIST OF VALUES + ; FILE(DFN,136, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: NO ALLERGY ASSESSMENT) + ; + S OCXDF(2)=$P($G(OCXPSD),"|",2) I $L(OCXDF(2)) D CHK198 + S OCXDF(73)=$P($G(OCXPSD),"|",1) I $L(OCXDF(73)) S OCXDF(67)=$$CM^ORQQRA(OCXDF(73)) I $L(OCXDF(67)),$$CLIST(OCXDF(67),"M,I,N") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) D CHK466^OCXOZ0F + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(156)=$$ALRGY(OCXDF(37)) I $L(OCXDF(156)),'(OCXDF(156)) S OCXOERR=$$FILE(DFN,136,"") Q:OCXOERR + Q + ; +CHK198 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK196+17. + ; + Q:$G(OCXOERR) + ; + ; Local CHK198 Variables + ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) + ; + I (OCXDF(2)="RA") D CHK199 + I ($E(OCXDF(2),1,2)="PS") D CHK362^OCXOZ0D + Q + ; +CHK199 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK198+8. + ; + Q:$G(OCXOERR) + ; + ; Local CHK199 Variables + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(73) ---> Data Field: ORDERABLE ITEM IEN (NUMERIC) + ; + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) D CHK201 + S OCXDF(73)=$P($G(OCXPSD),"|",1) I $L(OCXDF(73)) D CHK236^OCXOZ0A + Q + ; +CHK201 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK199+9. + ; + Q:$G(OCXOERR) + ; + ; Local CHK201 Variables + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(65) ---> Data Field: CONTRAST MEDIA ALLERGY FLAG (BOOLEAN) + ; OCXDF(67) ---> Data Field: CONTRAST MEDIA CODE (FREE TEXT) + ; OCXDF(69) ---> Data Field: RECENT BARIUM STUDY FLAG (BOOLEAN) + ; OCXDF(73) ---> Data Field: ORDERABLE ITEM IEN (NUMERIC) + ; + ; Local Extrinsic Functions + ; RECBAR( ----------> RECENT BARIUM STUDY + ; + S OCXDF(65)=$$ORCHK^GMRAOR(OCXDF(37),"CM","") I $L(OCXDF(65)),(OCXDF(65)) S OCXDF(73)=$P($G(OCXPSD),"|",1) I $L(OCXDF(73)) S OCXDF(67)=$$CM^ORQQRA(OCXDF(73)) D CHK207 + S OCXDF(69)=$P($$RECBAR(OCXDF(37),48),"^",1) I $L(OCXDF(69)),(OCXDF(69)) S OCXDF(73)=$P($G(OCXPSD),"|",1) I $L(OCXDF(73)) S OCXDF(67)=$$CM^ORQQRA(OCXDF(73)) D CHK217^OCXOZ0A + Q + ; +CHK207 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK201+15. + ; + Q:$G(OCXOERR) + ; + ; Local CHK207 Variables + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(66) ---> Data Field: CONTRAST MEDIA CODE TRANSLATION (FREE TEXT) + ; OCXDF(67) ---> Data Field: CONTRAST MEDIA CODE (FREE TEXT) + ; OCXDF(159) --> Data Field: ALLERGY CONTRAST MEDIA LOCATION (FREE TEXT) + ; + ; Local Extrinsic Functions + ; CLIST( -----------> STRING CONTAINS ONE OF A LIST OF VALUES + ; CONTRANS( --------> CONTRAST MEDIA CODE TRANSLATION + ; + I $L(OCXDF(67)),$$CLIST(OCXDF(67),"M,I,N,L,C,G,B") S OCXDF(66)=$$CONTRANS(OCXDF(67)),OCXDF(159)=$P($$ORCHK^GMRAOR(OCXDF(37),"CM","",1),"^",2) D CHK211 + Q + ; +CHK211 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK207+15. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; FILE(DFN,66, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CONTRAST MEDIA ALLERGY) + ; + S OCXOERR=$$FILE(DFN,66,"66,159") Q:OCXOERR + Q + ; +ALRGY(ORPT) ; determine if pt has an allergy assessment + ; rtn 0 if no allergy assessment, 1 if allergy assessment or NKA + N ORALRGY + D EN1^GMRAOR1(ORPT,"ORALRGY") + Q:$G(ORALRGY)="" 0 + Q 1 + ; +CLIST(DATA,LIST) ; DOES THE DATA FIELD CONTAIN AN ELEMENT IN THE LIST + ; + N PC F PC=1:1:$L(LIST,","),0 I PC,$L($P(LIST,",",PC)),(DATA[$P(LIST,",",PC)) Q + Q ''PC + ; +CONTRANS(OCXC) ; Compiler Function: CONTRAST MEDIA CODE TRANSLATION + ; + N OCXX + Q:'$L($G(OCXC)) "" S OCXX=$S((OCXC["B"):"Barium",1:"") + I (OCXC["G") S:$L(OCXX) OCXX=OCXX_" and/or " S OCXX=OCXX_"Gastrografin" + I (OCXC["I") S:$L(OCXX) OCXX=OCXX_" and/or " S OCXX=OCXX_"Ionic Iodinated" + I (OCXC["N") S:$L(OCXX) OCXX=OCXX_" and/or " S OCXX=OCXX_"Non-ionic Iodinated" + I (OCXC["L") S:$L(OCXX) OCXX=OCXX_" and/or " S OCXX=OCXX_"Gadolinium" + I (OCXC["C") S:$L(OCXX) OCXX=OCXX_" and/or " S OCXX=OCXX_"Cholecystographic" + I (OCXC["M") S:$L(OCXX) OCXX=OCXX_" and/or " S OCXX=OCXX_"Unspecified contrast media" + Q OCXX + ; +EQTERM(DATA,TERM) ; Compiler Function: EQUALS TERM OPERATOR + ; + N OCXF,OCXL + ; + S OCXL="",OCXF=$$TERMLKUP(TERM,.OCXL) + Q:'OCXF 0 + I ($D(OCXL(DATA))!$D(OCXL("B",DATA))) Q 1 + Q 0 + ; +FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. + ; + N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI + S DFN=+$G(DFN),OCXELE=+$G(OCXELE) + ; + Q:'DFN 1 Q:'OCXELE 1 K OCXDATA + ; + S OCXDATA(DFN,OCXELE)=1 + F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D + .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL + ; + M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) + ; + Q 0 + ; +MTSTF(OILIST) ; Compiler Function: MISSING TESTS DURING SESSION + ; + N OCXPC,OCXOI,OCXOUT S OCXOUT="" + F OCXPC=1:1:$L(OILIST,",") S OCXOI=$P(OILIST,",",OCXPC) I $L(OCXOI) D + .N OCXL,OCXF,OCXD0 + .S OCXL="",OCXF=$$TERMLKUP(OCXOI,.OCXL) + .S OCXD0=0 F S OCXD0=$O(OCXL(OCXD0)) Q:'OCXD0 Q:$$OISESS^ORKCHK2(+OCXD0) + .Q:OCXD0 + .S:$L(OCXOUT) OCXOUT=OCXOUT_", " S OCXOUT=OCXOUT_OCXOI + Q OCXOUT + ; +RECBAR(DFN,HOURS) ; Compiler Function: RECENT BARIUM STUDY + ; + Q:'$G(DFN) 0 Q:'$G(HOURS) 0 N OUT S OUT=$$RECENTBA^ORKRA(DFN,HOURS) Q:'$L(OUT) 0 Q 1_U_OUT + ; + ; +TERMLKUP(OCXTERM,OCXLIST) ; + Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST) + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0A.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0A.m index ceb7b146..e75b5c7f 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0A.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0A.m @@ -1,197 +1,197 @@ -OCXOZ0A ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; - ; *************************************************************** - ; ** Warning: This routine is automatically generated by the ** - ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** - ; ** will be lost the next time the rule compiler executes. ** - ; *************************************************************** - ; - Q - ; -CHK217 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK201+16^OCXOZ09. - ; - Q:$G(OCXOERR) - ; - ; Local CHK217 Variables - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(67) ---> Data Field: CONTRAST MEDIA CODE (FREE TEXT) - ; OCXDF(70) ---> Data Field: RECENT BARIUM STUDY TEXT (FREE TEXT) - ; OCXDF(121) --> Data Field: RECENT BARIUM STUDY ORDER STATUS (FREE TEXT) - ; - ; Local Extrinsic Functions - ; FILE(DFN,67, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: RECENT BARIUM STUDY ORDERED) - ; RECBAR( ----------> RECENT BARIUM STUDY - ; RECBARST( --------> RECENT BARIUM ORDER STATUS - ; - I $L(OCXDF(67)),(OCXDF(67)["B") S OCXDF(70)=$P($$RECBAR(OCXDF(37),48),"^",3),OCXDF(121)=$P($$RECBARST(OCXDF(37),48),"^",2),OCXOERR=$$FILE(DFN,67,"70,121") Q:OCXOERR - Q - ; -CHK227 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK163+14^OCXOZ07. - ; - Q:$G(OCXOERR) - ; - ; Local CHK227 Variables - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(43) ---> Data Field: OI NATIONAL ID (FREE TEXT) - ; OCXDF(74) ---> Data Field: VA DRUG CLASS (FREE TEXT) - ; - ; Local Extrinsic Functions - ; - S OCXDF(74)=$P($$ENVAC^PSJORUT2(OCXDF(43)),"^",2) I $L(OCXDF(74)),(OCXDF(74)="AMINOGLYCOSIDES") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) D CHK232 - Q - ; -CHK232 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK227+12. - ; - Q:$G(OCXOERR) - ; - ; Local CHK232 Variables - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(64) ---> Data Field: FORMATTED RENAL LAB RESULTS (FREE TEXT) - ; OCXDF(76) ---> Data Field: CREATININE CLEARANCE (ESTIM) VALUE (NUMERIC) - ; - ; Local Extrinsic Functions - ; CRCL( ------------> CREATININE CLEARANCE (ESTIMATED/CALCULATED) - ; FILE(DFN,71, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: AMINOGLYCOSIDE ORDER SESSION) - ; FLAB( ------------> FORMATTED LAB RESULTS - ; - S OCXDF(64)=$$FLAB(OCXDF(37),"SERUM CREATININE^SERUM UREA NITROGEN","SERUM SPECIMEN"),OCXDF(76)=$P($$CRCL(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,71,"64,76") Q:OCXOERR - Q - ; -CHK236 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK199+10^OCXOZ09. - ; - Q:$G(OCXOERR) - ; - ; Local CHK236 Variables - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(67) ---> Data Field: CONTRAST MEDIA CODE (FREE TEXT) - ; OCXDF(73) ---> Data Field: ORDERABLE ITEM IEN (NUMERIC) - ; OCXDF(78) ---> Data Field: PATIENT TOO BIG FOR SCANNER FLAG (BOOLEAN) - ; - ; Local Extrinsic Functions - ; CLIST( -----------> STRING CONTAINS ONE OF A LIST OF VALUES - ; CTMRI( -----------> CT MRI PHYSICAL LIMITS - ; FILE(DFN,106, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: RADIOLOGY PROCEDURE CONTAINS NON-BARIUM CONTRAST MEDIA) - ; - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(78)=$P($$CTMRI(OCXDF(37),OCXDF(73)),"^",1) I $L(OCXDF(78)),(OCXDF(78)) D CHK241^OCXOZ0B - S OCXDF(67)=$$CM^ORQQRA(OCXDF(73)) I $L(OCXDF(67)),$$CLIST(OCXDF(67),"M,I,N") S OCXOERR=$$FILE(DFN,106,"") Q:OCXOERR - Q - ; -CLIST(DATA,LIST) ; DOES THE DATA FIELD CONTAIN AN ELEMENT IN THE LIST - ; - N PC F PC=1:1:$L(LIST,","),0 I PC,$L($P(LIST,",",PC)),(DATA[$P(LIST,",",PC)) Q - Q ''PC - ; -CRCL(DFN) ; Compiler Function: CREATININE CLEARANCE (ESTIMATED/CALCULATED) - ; - N HT,AGE,SEX,SCR,SCRD,CRCL,LRWKLD,RSLT,ORW,ORH,PSCR - N HTGT60,ABW,IBW,BWRATIO,BWDIFF,LOWBW,ADJBW - S RSLT="0^" - S PSCR="^^^^^^0" - D VITAL^ORQQVI("WEIGHT","WT",DFN,.ORW,0,"",$$NOW^XLFDT) - Q:'$D(ORW) RSLT - S ABW=$P(ORW(1),U,3) Q:+$G(ABW)<1 RSLT - S ABW=ABW/2.2 ;ABW (actual body weight) in kg - D VITAL^ORQQVI("HEIGHT","HT",DFN,.ORH,0,"",$$NOW^XLFDT) - Q:'$D(ORH) RSLT - S HT=$P(ORH(1),U,3) Q:+$G(HT)<1 RSLT - S AGE=$$AGE^ORQPTQ4(DFN) Q:'AGE RSLT - S SEX=$P($$SEX^ORQPTQ4(DFN),U,1) Q:'$L(SEX) RSLT - S OCXTL="" Q:'$$TERMLKUP^ORB31(.OCXTL,"SERUM CREATININE") RSLT - S OCXTLS="" Q:'$$TERMLKUP^ORB31(.OCXTLS,"SERUM SPECIMEN") RSLT - S SCR="",OCXT=0 F S OCXT=$O(OCXTL(OCXT)) Q:'OCXT D - .S OCXTS=0 F S OCXTS=$O(OCXTLS(OCXTS)) Q:'OCXTS D - ..S SCR=$$LOCL^ORQQLR1(DFN,$P(OCXTL(OCXT),U),$P(OCXTLS(OCXTS),U)) - ..I $P(SCR,U,7)>$P(PSCR,U,7) S PSCR=SCR - S SCR=PSCR,SCRV=$P(SCR,U,3) Q:+$G(SCRV)<.01 RSLT - S SCRD=$P(SCR,U,7) Q:'$L(SCRD) RSLT - ; - S HTGT60=$S(HT>60:(HT-60)*2.3,1:0) ;if ht > 60 inches - I HTGT60>0 D - .S IBW=$S(SEX="M":50+HTGT60,1:45.5+HTGT60) ;Ideal Body Weight - .S BWRATIO=(ABW/IBW) ;body weight ratio - .S BWDIFF=$S(ABW>IBW:ABW-IBW,1:0) - .S LOWBW=$S(IBW1.3,(BWDIFF>0) S ADJBW=((0.3*BWDIFF)+IBW) - .E S ADJBW=LOWBW - I +$G(ADJBW)<1 D - .S ADJBW=ABW - S CRCL=(((140-AGE)*ADJBW)/(SCRV*72)) - ; - S:SEX="M" RSLT=SCRD_U_$J(CRCL,1,1) - S:SEX="F" RSLT=SCRD_U_$J((CRCL*.85),1,1) - Q RSLT - ; -CTMRI(DFN,OCXOI) ; Compiler Function: CT MRI PHYSICAL LIMITS - ; - N OCXDEV,OCXWTP,OCXHTP,OCXWTL,OCXHTL - S OCXDEV=$$TYPE^ORKRA(OCXOI) - Q:'((OCXDEV="MRI")!(OCXDEV="CT")) 0_U - S OCXWTP=$P($$WT^ORQPTQ4(DFN),U,2),OCXHTP=$P($$HT^ORQPTQ4(DFN),U,2) - I (OCXDEV="CT") S OCXWTL=$$GET^XPAR("ALL","ORK CT LIMIT WT",1,"Q"),OCXHTL=$$GET^XPAR("ALL","ORK CT LIMIT HT",1,"Q") - I (OCXDEV="CT"),(OCXWTL),(OCXWTP>OCXWTL) Q 1_U_"too heavy"_U_"CT scanner" - I (OCXDEV="CT"),(OCXHTL),(OCXHTP>OCXHTL) Q 1_U_"too tall"_U_"CT scanner" - I (OCXDEV="MRI") S OCXWTL=$$GET^XPAR("ALL","ORK MRI LIMIT WT",1,"Q"),OCXHTL=$$GET^XPAR("ALL","ORK MRI LIMIT HT",1,"Q") - I (OCXDEV="MRI"),(OCXWTL),(OCXWTP>OCXWTL) Q 1_U_"too heavy"_U_"MRI scanner" - I (OCXDEV="MRI"),(OCXHTL),(OCXHTP>OCXHTL) Q 1_U_"too tall"_U_"MRI scanner" - Q 0_U - ; -FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. - ; - N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI - S DFN=+$G(DFN),OCXELE=+$G(OCXELE) - ; - Q:'DFN 1 Q:'OCXELE 1 K OCXDATA - ; - S OCXDATA(DFN,OCXELE)=1 - F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D - .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL - ; - M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) - ; - Q 0 - ; -FLAB(DFN,OCXLIST,OCXSPEC) ; Compiler Function: FORMATTED LAB RESULTS - ; - Q:'$G(DFN) "" - Q:'$L($G(OCXLIST)) "" - N OCXLAB,OCXOUT,OCXPC,OCXSL,SPEC S OCXOUT="",SPEC="" - I $L($G(OCXSPEC)) S OCXSL=$$TERMLKUP(OCXSPEC,.OCXSL) - F OCXPC=1:1:$L(OCXLIST,U) S OCXLAB=$P(OCXLIST,U,OCXPC) I $L(OCXLAB) D - .N OCXX,OCXY,X,Y,DIC,TEST,SPEC,OCXTL,OCXA,OCXR - .S OCXTL="" Q:'$$TERMLKUP(OCXLAB,.OCXTL) - .S OCXX="",TEST=0 F S TEST=$O(OCXTL(TEST)) Q:'TEST D - ..I $L($G(OCXSL)) D - ...S SPEC=0 F S SPEC=$O(OCXSL(SPEC)) Q:'SPEC D - ....S OCXX=$$LOCL^ORQQLR1(DFN,TEST,SPEC) I $L(OCXX) D - .....S OCXA($P(OCXX,U,7))=OCXX - ..I '$L($G(OCXSL)) S OCXX=$$LOCL^ORQQLR1(DFN,TEST,"") - ..Q:'$L(OCXX) - .I $D(OCXA) S OCXR="",OCXR=$O(OCXA(OCXR),-1),OCXX=OCXA(OCXR) - .I $L(OCXX) D - ..S OCXY=$P(OCXX,U,2)_": "_$P(OCXX,U,3)_" "_$P(OCXX,U,4) - ..S OCXY=OCXY_" "_$S($L($P(OCXX,U,5)):"["_$P(OCXX,U,5)_"]",1:"") - ..I $L($P(OCXX,U,7)) S OCXY=OCXY_" "_$$FMTE^XLFDT($P(OCXX,U,7),"2P") - .S:$L(OCXOUT) OCXOUT=OCXOUT_" " S OCXOUT=OCXOUT_$G(OCXY) - Q:'$L(OCXOUT) "" Q OCXOUT - ; -RECBAR(DFN,HOURS) ; Compiler Function: RECENT BARIUM STUDY - ; - Q:'$G(DFN) 0 Q:'$G(HOURS) 0 N OUT S OUT=$$RECENTBA^ORKRA(DFN,HOURS) Q:'$L(OUT) 0 Q 1_U_OUT - ; - ; -RECBARST(DFN,HOURS) ; Compiler Function: RECENT BARIUM ORDER STATUS - ; - Q:'$G(DFN) 0 Q:'$G(HOURS) 0 - N ORDER S ORDER=$P($$RECENTBA^ORKRA(DFN,HOURS),U) Q:'$L(ORDER) 0 - N STATUS S STATUS=$P($$STATUS^ORQOR2(ORDER),U,2) Q:'$L(STATUS) 0 - Q 1_U_STATUS - ; -TERMLKUP(OCXTERM,OCXLIST) ; - Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST) - ; +OCXOZ0A ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; + ; *************************************************************** + ; ** Warning: This routine is automatically generated by the ** + ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** + ; ** will be lost the next time the rule compiler executes. ** + ; *************************************************************** + ; + Q + ; +CHK217 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK201+16^OCXOZ09. + ; + Q:$G(OCXOERR) + ; + ; Local CHK217 Variables + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(67) ---> Data Field: CONTRAST MEDIA CODE (FREE TEXT) + ; OCXDF(70) ---> Data Field: RECENT BARIUM STUDY TEXT (FREE TEXT) + ; OCXDF(121) --> Data Field: RECENT BARIUM STUDY ORDER STATUS (FREE TEXT) + ; + ; Local Extrinsic Functions + ; FILE(DFN,67, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: RECENT BARIUM STUDY ORDERED) + ; RECBAR( ----------> RECENT BARIUM STUDY + ; RECBARST( --------> RECENT BARIUM ORDER STATUS + ; + I $L(OCXDF(67)),(OCXDF(67)["B") S OCXDF(70)=$P($$RECBAR(OCXDF(37),48),"^",3),OCXDF(121)=$P($$RECBARST(OCXDF(37),48),"^",2),OCXOERR=$$FILE(DFN,67,"70,121") Q:OCXOERR + Q + ; +CHK227 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK163+14^OCXOZ07. + ; + Q:$G(OCXOERR) + ; + ; Local CHK227 Variables + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(43) ---> Data Field: OI NATIONAL ID (FREE TEXT) + ; OCXDF(74) ---> Data Field: VA DRUG CLASS (FREE TEXT) + ; + ; Local Extrinsic Functions + ; + S OCXDF(74)=$P($$ENVAC^PSJORUT2(OCXDF(43)),"^",2) I $L(OCXDF(74)),(OCXDF(74)="AMINOGLYCOSIDES") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) D CHK232 + Q + ; +CHK232 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK227+12. + ; + Q:$G(OCXOERR) + ; + ; Local CHK232 Variables + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(64) ---> Data Field: FORMATTED RENAL LAB RESULTS (FREE TEXT) + ; OCXDF(76) ---> Data Field: CREATININE CLEARANCE (ESTIM) VALUE (NUMERIC) + ; + ; Local Extrinsic Functions + ; CRCL( ------------> CREATININE CLEARANCE (ESTIMATED/CALCULATED) + ; FILE(DFN,71, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: AMINOGLYCOSIDE ORDER SESSION) + ; FLAB( ------------> FORMATTED LAB RESULTS + ; + S OCXDF(64)=$$FLAB(OCXDF(37),"SERUM CREATININE^SERUM UREA NITROGEN","SERUM SPECIMEN"),OCXDF(76)=$P($$CRCL(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,71,"64,76") Q:OCXOERR + Q + ; +CHK236 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK199+10^OCXOZ09. + ; + Q:$G(OCXOERR) + ; + ; Local CHK236 Variables + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(67) ---> Data Field: CONTRAST MEDIA CODE (FREE TEXT) + ; OCXDF(73) ---> Data Field: ORDERABLE ITEM IEN (NUMERIC) + ; OCXDF(78) ---> Data Field: PATIENT TOO BIG FOR SCANNER FLAG (BOOLEAN) + ; + ; Local Extrinsic Functions + ; CLIST( -----------> STRING CONTAINS ONE OF A LIST OF VALUES + ; CTMRI( -----------> CT MRI PHYSICAL LIMITS + ; FILE(DFN,106, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: RADIOLOGY PROCEDURE CONTAINS NON-BARIUM CONTRAST MEDIA) + ; + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(78)=$P($$CTMRI(OCXDF(37),OCXDF(73)),"^",1) I $L(OCXDF(78)),(OCXDF(78)) D CHK241^OCXOZ0B + S OCXDF(67)=$$CM^ORQQRA(OCXDF(73)) I $L(OCXDF(67)),$$CLIST(OCXDF(67),"M,I,N") S OCXOERR=$$FILE(DFN,106,"") Q:OCXOERR + Q + ; +CLIST(DATA,LIST) ; DOES THE DATA FIELD CONTAIN AN ELEMENT IN THE LIST + ; + N PC F PC=1:1:$L(LIST,","),0 I PC,$L($P(LIST,",",PC)),(DATA[$P(LIST,",",PC)) Q + Q ''PC + ; +CRCL(DFN) ; Compiler Function: CREATININE CLEARANCE (ESTIMATED/CALCULATED) + ; + N HT,AGE,SEX,SCR,SCRD,CRCL,LRWKLD,RSLT,ORW,ORH,PSCR + N HTGT60,ABW,IBW,BWRATIO,BWDIFF,LOWBW,ADJBW + S RSLT="0^" + S PSCR="^^^^^^0" + D VITAL^ORQQVI("WEIGHT","WT",DFN,.ORW,0,"",$$NOW^XLFDT) + Q:'$D(ORW) RSLT + S ABW=$P(ORW(1),U,3) Q:+$G(ABW)<1 RSLT + S ABW=ABW/2.2 ;ABW (actual body weight) in kg + D VITAL^ORQQVI("HEIGHT","HT",DFN,.ORH,0,"",$$NOW^XLFDT) + Q:'$D(ORH) RSLT + S HT=$P(ORH(1),U,3) Q:+$G(HT)<1 RSLT + S AGE=$$AGE^ORQPTQ4(DFN) Q:'AGE RSLT + S SEX=$P($$SEX^ORQPTQ4(DFN),U,1) Q:'$L(SEX) RSLT + S OCXTL="" Q:'$$TERMLKUP^ORB31(.OCXTL,"SERUM CREATININE") RSLT + S OCXTLS="" Q:'$$TERMLKUP^ORB31(.OCXTLS,"SERUM SPECIMEN") RSLT + S SCR="",OCXT=0 F S OCXT=$O(OCXTL(OCXT)) Q:'OCXT D + .S OCXTS=0 F S OCXTS=$O(OCXTLS(OCXTS)) Q:'OCXTS D + ..S SCR=$$LOCL^ORQQLR1(DFN,$P(OCXTL(OCXT),U),$P(OCXTLS(OCXTS),U)) + ..I $P(SCR,U,7)>$P(PSCR,U,7) S PSCR=SCR + S SCR=PSCR,SCRV=$P(SCR,U,3) Q:+$G(SCRV)<.01 RSLT + S SCRD=$P(SCR,U,7) Q:'$L(SCRD) RSLT + ; + S HTGT60=$S(HT>60:(HT-60)*2.3,1:0) ;if ht > 60 inches + I HTGT60>0 D + .S IBW=$S(SEX="M":50+HTGT60,1:45.5+HTGT60) ;Ideal Body Weight + .S BWRATIO=(ABW/IBW) ;body weight ratio + .S BWDIFF=$S(ABW>IBW:ABW-IBW,1:0) + .S LOWBW=$S(IBW1.3,(BWDIFF>0) S ADJBW=((0.3*BWDIFF)+IBW) + .E S ADJBW=LOWBW + I +$G(ADJBW)<1 D + .S ADJBW=ABW + S CRCL=(((140-AGE)*ADJBW)/(SCRV*72)) + ; + S:SEX="M" RSLT=SCRD_U_$J(CRCL,1,1) + S:SEX="F" RSLT=SCRD_U_$J((CRCL*.85),1,1) + Q RSLT + ; +CTMRI(DFN,OCXOI) ; Compiler Function: CT MRI PHYSICAL LIMITS + ; + N OCXDEV,OCXWTP,OCXHTP,OCXWTL,OCXHTL + S OCXDEV=$$TYPE^ORKRA(OCXOI) + Q:'((OCXDEV="MRI")!(OCXDEV="CT")) 0_U + S OCXWTP=$P($$WT^ORQPTQ4(DFN),U,2),OCXHTP=$P($$HT^ORQPTQ4(DFN),U,2) + I (OCXDEV="CT") S OCXWTL=$$GET^XPAR("ALL","ORK CT LIMIT WT",1,"Q"),OCXHTL=$$GET^XPAR("ALL","ORK CT LIMIT HT",1,"Q") + I (OCXDEV="CT"),(OCXWTL),(OCXWTP>OCXWTL) Q 1_U_"too heavy"_U_"CT scanner" + I (OCXDEV="CT"),(OCXHTL),(OCXHTP>OCXHTL) Q 1_U_"too tall"_U_"CT scanner" + I (OCXDEV="MRI") S OCXWTL=$$GET^XPAR("ALL","ORK MRI LIMIT WT",1,"Q"),OCXHTL=$$GET^XPAR("ALL","ORK MRI LIMIT HT",1,"Q") + I (OCXDEV="MRI"),(OCXWTL),(OCXWTP>OCXWTL) Q 1_U_"too heavy"_U_"MRI scanner" + I (OCXDEV="MRI"),(OCXHTL),(OCXHTP>OCXHTL) Q 1_U_"too tall"_U_"MRI scanner" + Q 0_U + ; +FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. + ; + N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI + S DFN=+$G(DFN),OCXELE=+$G(OCXELE) + ; + Q:'DFN 1 Q:'OCXELE 1 K OCXDATA + ; + S OCXDATA(DFN,OCXELE)=1 + F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D + .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL + ; + M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) + ; + Q 0 + ; +FLAB(DFN,OCXLIST,OCXSPEC) ; Compiler Function: FORMATTED LAB RESULTS + ; + Q:'$G(DFN) "" + Q:'$L($G(OCXLIST)) "" + N OCXLAB,OCXOUT,OCXPC,OCXSL,SPEC S OCXOUT="",SPEC="" + I $L($G(OCXSPEC)) S OCXSL=$$TERMLKUP(OCXSPEC,.OCXSL) + F OCXPC=1:1:$L(OCXLIST,U) S OCXLAB=$P(OCXLIST,U,OCXPC) I $L(OCXLAB) D + .N OCXX,OCXY,X,Y,DIC,TEST,SPEC,OCXTL,OCXA,OCXR + .S OCXTL="" Q:'$$TERMLKUP(OCXLAB,.OCXTL) + .S OCXX="",TEST=0 F S TEST=$O(OCXTL(TEST)) Q:'TEST D + ..I $L($G(OCXSL)) D + ...S SPEC=0 F S SPEC=$O(OCXSL(SPEC)) Q:'SPEC D + ....S OCXX=$$LOCL^ORQQLR1(DFN,TEST,SPEC) I $L(OCXX) D + .....S OCXA($P(OCXX,U,7))=OCXX + ..I '$L($G(OCXSL)) S OCXX=$$LOCL^ORQQLR1(DFN,TEST,"") + ..Q:'$L(OCXX) + .I $D(OCXA) S OCXR="",OCXR=$O(OCXA(OCXR),-1),OCXX=OCXA(OCXR) + .I $L(OCXX) D + ..S OCXY=$P(OCXX,U,2)_": "_$P(OCXX,U,3)_" "_$P(OCXX,U,4) + ..S OCXY=OCXY_" "_$S($L($P(OCXX,U,5)):"["_$P(OCXX,U,5)_"]",1:"") + ..I $L($P(OCXX,U,7)) S OCXY=OCXY_" "_$$FMTE^XLFDT($P(OCXX,U,7),"2P") + .S:$L(OCXOUT) OCXOUT=OCXOUT_" " S OCXOUT=OCXOUT_$G(OCXY) + Q:'$L(OCXOUT) "" Q OCXOUT + ; +RECBAR(DFN,HOURS) ; Compiler Function: RECENT BARIUM STUDY + ; + Q:'$G(DFN) 0 Q:'$G(HOURS) 0 N OUT S OUT=$$RECENTBA^ORKRA(DFN,HOURS) Q:'$L(OUT) 0 Q 1_U_OUT + ; + ; +RECBARST(DFN,HOURS) ; Compiler Function: RECENT BARIUM ORDER STATUS + ; + Q:'$G(DFN) 0 Q:'$G(HOURS) 0 + N ORDER S ORDER=$P($$RECENTBA^ORKRA(DFN,HOURS),U) Q:'$L(ORDER) 0 + N STATUS S STATUS=$P($$STATUS^ORQOR2(ORDER),U,2) Q:'$L(STATUS) 0 + Q 1_U_STATUS + ; +TERMLKUP(OCXTERM,OCXLIST) ; + Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST) + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0B.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0B.m index 83ed12ea..c1ed7b12 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0B.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0B.m @@ -1,217 +1,217 @@ -OCXOZ0B ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; - ; *************************************************************** - ; ** Warning: This routine is automatically generated by the ** - ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** - ; ** will be lost the next time the rule compiler executes. ** - ; *************************************************************** - ; - Q - ; -CHK241 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK236+16^OCXOZ0A. - ; - Q:$G(OCXOERR) - ; - ; Local CHK241 Variables - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(73) ---> Data Field: ORDERABLE ITEM IEN (NUMERIC) - ; OCXDF(79) ---> Data Field: PATIENT TOO BIG FOR SCANNER TEXT (FREE TEXT) - ; OCXDF(80) ---> Data Field: PATIENT TOO BIG FOR SCANNER DEVICE (FREE TEXT) - ; - ; Local Extrinsic Functions - ; CTMRI( -----------> CT MRI PHYSICAL LIMITS - ; FILE(DFN,72, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: PATIENT OVER CT OR MRI DEVICE LIMITATIONS) - ; - S OCXDF(79)=$P($$CTMRI(OCXDF(37),OCXDF(73)),"^",2),OCXDF(80)=$P($$CTMRI(OCXDF(37),OCXDF(73)),"^",3),OCXOERR=$$FILE(DFN,72,"79,80") Q:OCXOERR - Q - ; -CHK247 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK182+19^OCXOZ08. - ; - Q:$G(OCXOERR) - ; - ; Local CHK247 Variables - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(64) ---> Data Field: FORMATTED RENAL LAB RESULTS (FREE TEXT) - ; - ; Local Extrinsic Functions - ; FILE(DFN,73, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CREATININE CLEARANCE ESTIMATE) - ; FLAB( ------------> FORMATTED LAB RESULTS - ; - S OCXDF(64)=$$FLAB(OCXDF(37),"SERUM CREATININE^SERUM UREA NITROGEN","SERUM SPECIMEN"),OCXOERR=$$FILE(DFN,73,"64,76") Q:OCXOERR - Q - ; -CHK253 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK157+18^OCXOZ07. - ; - Q:$G(OCXOERR) - ; - ; Local CHK253 Variables - ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) - ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) - ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) - ; - ; Local Extrinsic Functions - ; FILE(DFN,110, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: STAT CONSULT RESULT) - ; FILE(DFN,75, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: STAT IMAGING RESULT) - ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER - ; - I (OCXDF(2)="RA"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXOERR=$$FILE(DFN,75,"24,96") Q:OCXOERR - I (OCXDF(2)="GMRC"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXOERR=$$FILE(DFN,110,"24,96") Q:OCXOERR - Q - ; -CHK264 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK151+18^OCXOZ07. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; FILE(DFN,76, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: STAT LAB RESULT) - ; - S OCXOERR=$$FILE(DFN,76,"24,96") Q:OCXOERR - Q - ; -CHK270 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK12+34^OCXOZ03. - ; - Q:$G(OCXOERR) - ; - ; Local CHK270 Variables - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(84) ---> Data Field: INPATIENT (BOOLEAN) - ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT) - ; - ; Local Extrinsic Functions - ; FILE(DFN,84, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: INPATIENT FOOD-DRUG REACTION) - ; PATLOC( ----------> PATIENT LOCATION - ; WARDRMBD( --------> WARD ROOM-BED - ; - S OCXDF(84)=$P($$WARDRMBD(OCXDF(37)),"^",1) I $L(OCXDF(84)),(OCXDF(84)) S OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,84,"82,147") Q:OCXOERR - Q - ; -CHK280 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK188+15^OCXOZ09. - ; - Q:$G(OCXOERR) - ; - ; Local CHK280 Variables - ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(125) --> Data Field: RECENT GLUCOPHAGE CREATININE TEXT (FREE TEXT) - ; OCXDF(127) --> Data Field: RECENT GLUCOPHAGE CREATININE DAYS (NUMERIC) - ; - ; Local Extrinsic Functions - ; - I ($E(OCXDF(2),1,2)="PS") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(125)=$P($$GLCREAT^ORKPS(OCXDF(37)),"^",2),OCXDF(127)=$P($$GCDAYS^ORKPS(OCXDF(37)),"^",1) D CHK285 - Q - ; -CHK285 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK280+13. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; FILE(DFN,86, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: GLUCOPHAGE ORDER) - ; - S OCXOERR=$$FILE(DFN,86,"125,127") Q:OCXOERR - Q - ; -CHK293 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK113+20^OCXOZ06. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; FILE(DFN,100, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CANCELED BY NON-ORIG ORDERING PROVIDER) - ; - S OCXOERR=$$FILE(DFN,100,"105") Q:OCXOERR - Q - ; -CTMRI(DFN,OCXOI) ; Compiler Function: CT MRI PHYSICAL LIMITS - ; - N OCXDEV,OCXWTP,OCXHTP,OCXWTL,OCXHTL - S OCXDEV=$$TYPE^ORKRA(OCXOI) - Q:'((OCXDEV="MRI")!(OCXDEV="CT")) 0_U - S OCXWTP=$P($$WT^ORQPTQ4(DFN),U,2),OCXHTP=$P($$HT^ORQPTQ4(DFN),U,2) - I (OCXDEV="CT") S OCXWTL=$$GET^XPAR("ALL","ORK CT LIMIT WT",1,"Q"),OCXHTL=$$GET^XPAR("ALL","ORK CT LIMIT HT",1,"Q") - I (OCXDEV="CT"),(OCXWTL),(OCXWTP>OCXWTL) Q 1_U_"too heavy"_U_"CT scanner" - I (OCXDEV="CT"),(OCXHTL),(OCXHTP>OCXHTL) Q 1_U_"too tall"_U_"CT scanner" - I (OCXDEV="MRI") S OCXWTL=$$GET^XPAR("ALL","ORK MRI LIMIT WT",1,"Q"),OCXHTL=$$GET^XPAR("ALL","ORK MRI LIMIT HT",1,"Q") - I (OCXDEV="MRI"),(OCXWTL),(OCXWTP>OCXWTL) Q 1_U_"too heavy"_U_"MRI scanner" - I (OCXDEV="MRI"),(OCXHTL),(OCXHTP>OCXHTL) Q 1_U_"too tall"_U_"MRI scanner" - Q 0_U - ; -FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. - ; - N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI - S DFN=+$G(DFN),OCXELE=+$G(OCXELE) - ; - Q:'DFN 1 Q:'OCXELE 1 K OCXDATA - ; - S OCXDATA(DFN,OCXELE)=1 - F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D - .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL - ; - M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) - ; - Q 0 - ; -FLAB(DFN,OCXLIST,OCXSPEC) ; Compiler Function: FORMATTED LAB RESULTS - ; - Q:'$G(DFN) "" - Q:'$L($G(OCXLIST)) "" - N OCXLAB,OCXOUT,OCXPC,OCXSL,SPEC S OCXOUT="",SPEC="" - I $L($G(OCXSPEC)) S OCXSL=$$TERMLKUP(OCXSPEC,.OCXSL) - F OCXPC=1:1:$L(OCXLIST,U) S OCXLAB=$P(OCXLIST,U,OCXPC) I $L(OCXLAB) D - .N OCXX,OCXY,X,Y,DIC,TEST,SPEC,OCXTL,OCXA,OCXR - .S OCXTL="" Q:'$$TERMLKUP(OCXLAB,.OCXTL) - .S OCXX="",TEST=0 F S TEST=$O(OCXTL(TEST)) Q:'TEST D - ..I $L($G(OCXSL)) D - ...S SPEC=0 F S SPEC=$O(OCXSL(SPEC)) Q:'SPEC D - ....S OCXX=$$LOCL^ORQQLR1(DFN,TEST,SPEC) I $L(OCXX) D - .....S OCXA($P(OCXX,U,7))=OCXX - ..I '$L($G(OCXSL)) S OCXX=$$LOCL^ORQQLR1(DFN,TEST,"") - ..Q:'$L(OCXX) - .I $D(OCXA) S OCXR="",OCXR=$O(OCXA(OCXR),-1),OCXX=OCXA(OCXR) - .I $L(OCXX) D - ..S OCXY=$P(OCXX,U,2)_": "_$P(OCXX,U,3)_" "_$P(OCXX,U,4) - ..S OCXY=OCXY_" "_$S($L($P(OCXX,U,5)):"["_$P(OCXX,U,5)_"]",1:"") - ..I $L($P(OCXX,U,7)) S OCXY=OCXY_" "_$$FMTE^XLFDT($P(OCXX,U,7),"2P") - .S:$L(OCXOUT) OCXOUT=OCXOUT_" " S OCXOUT=OCXOUT_$G(OCXY) - Q:'$L(OCXOUT) "" Q OCXOUT - ; -ORDITEM(OIEN) ; Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER - Q:'$G(OIEN) "" - ; - N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found." - S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found." - Q $P(X,U,1) - ; -PATLOC(DFN) ; Compiler Function: PATIENT LOCATION - ; - N OCXP1,OCXP2 - S OCXP1=$G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",2)) - S OCXP2=$P($G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",3)),"^",1) - I OCXP2 D - .S OCXP2=$P($G(^SC(+OCXP2,0)),"^",1,2) - .I $L($P(OCXP2,"^",2)) S OCXP2=$P(OCXP2,"^",2) - .E S OCXP2=$P(OCXP2,"^",1) - .S:'$L(OCXP2) OCXP2="NO LOC" - I $L(OCXP1),$L(OCXP2) Q OCXP1_"^"_OCXP2 - ; - S OCXP2=$G(^DPT(+$G(DFN),.1)) - I $L(OCXP2) Q "I^"_OCXP2 - Q "O^OUTPT" - ; -TERMLKUP(OCXTERM,OCXLIST) ; - Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST) - ; -WARDRMBD(DFN) ; Compiler Function: WARD ROOM-BED - ; - Q:'$G(DFN) 0 - N OUT S OUT=$G(^DPT(DFN,.1)) Q:'$L(OUT) 0 - S OUT=1_"^"_OUT_" "_$G(^DPT(DFN,.101)) Q OUT - ; +OCXOZ0B ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; + ; *************************************************************** + ; ** Warning: This routine is automatically generated by the ** + ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** + ; ** will be lost the next time the rule compiler executes. ** + ; *************************************************************** + ; + Q + ; +CHK241 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK236+16^OCXOZ0A. + ; + Q:$G(OCXOERR) + ; + ; Local CHK241 Variables + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(73) ---> Data Field: ORDERABLE ITEM IEN (NUMERIC) + ; OCXDF(79) ---> Data Field: PATIENT TOO BIG FOR SCANNER TEXT (FREE TEXT) + ; OCXDF(80) ---> Data Field: PATIENT TOO BIG FOR SCANNER DEVICE (FREE TEXT) + ; + ; Local Extrinsic Functions + ; CTMRI( -----------> CT MRI PHYSICAL LIMITS + ; FILE(DFN,72, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: PATIENT OVER CT OR MRI DEVICE LIMITATIONS) + ; + S OCXDF(79)=$P($$CTMRI(OCXDF(37),OCXDF(73)),"^",2),OCXDF(80)=$P($$CTMRI(OCXDF(37),OCXDF(73)),"^",3),OCXOERR=$$FILE(DFN,72,"79,80") Q:OCXOERR + Q + ; +CHK247 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK182+19^OCXOZ08. + ; + Q:$G(OCXOERR) + ; + ; Local CHK247 Variables + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(64) ---> Data Field: FORMATTED RENAL LAB RESULTS (FREE TEXT) + ; + ; Local Extrinsic Functions + ; FILE(DFN,73, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CREATININE CLEARANCE ESTIMATE) + ; FLAB( ------------> FORMATTED LAB RESULTS + ; + S OCXDF(64)=$$FLAB(OCXDF(37),"SERUM CREATININE^SERUM UREA NITROGEN","SERUM SPECIMEN"),OCXOERR=$$FILE(DFN,73,"64,76") Q:OCXOERR + Q + ; +CHK253 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK157+18^OCXOZ07. + ; + Q:$G(OCXOERR) + ; + ; Local CHK253 Variables + ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) + ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) + ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) + ; + ; Local Extrinsic Functions + ; FILE(DFN,110, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: STAT CONSULT RESULT) + ; FILE(DFN,75, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: STAT IMAGING RESULT) + ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER + ; + I (OCXDF(2)="RA"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXOERR=$$FILE(DFN,75,"24,96") Q:OCXOERR + I (OCXDF(2)="GMRC"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXOERR=$$FILE(DFN,110,"24,96") Q:OCXOERR + Q + ; +CHK264 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK151+18^OCXOZ07. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; FILE(DFN,76, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: STAT LAB RESULT) + ; + S OCXOERR=$$FILE(DFN,76,"24,96") Q:OCXOERR + Q + ; +CHK270 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK12+34^OCXOZ03. + ; + Q:$G(OCXOERR) + ; + ; Local CHK270 Variables + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(84) ---> Data Field: INPATIENT (BOOLEAN) + ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT) + ; + ; Local Extrinsic Functions + ; FILE(DFN,84, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: INPATIENT FOOD-DRUG REACTION) + ; PATLOC( ----------> PATIENT LOCATION + ; WARDRMBD( --------> WARD ROOM-BED + ; + S OCXDF(84)=$P($$WARDRMBD(OCXDF(37)),"^",1) I $L(OCXDF(84)),(OCXDF(84)) S OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,84,"82,147") Q:OCXOERR + Q + ; +CHK280 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK188+15^OCXOZ09. + ; + Q:$G(OCXOERR) + ; + ; Local CHK280 Variables + ; OCXDF(2) ----> Data Field: FILLER (FREE TEXT) + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(125) --> Data Field: RECENT GLUCOPHAGE CREATININE TEXT (FREE TEXT) + ; OCXDF(127) --> Data Field: RECENT GLUCOPHAGE CREATININE DAYS (NUMERIC) + ; + ; Local Extrinsic Functions + ; + I ($E(OCXDF(2),1,2)="PS") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(125)=$P($$GLCREAT^ORKPS(OCXDF(37)),"^",2),OCXDF(127)=$P($$GCDAYS^ORKPS(OCXDF(37)),"^",1) D CHK285 + Q + ; +CHK285 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK280+13. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; FILE(DFN,86, -----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: GLUCOPHAGE ORDER) + ; + S OCXOERR=$$FILE(DFN,86,"125,127") Q:OCXOERR + Q + ; +CHK293 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK113+20^OCXOZ06. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; FILE(DFN,100, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CANCELED BY NON-ORIG ORDERING PROVIDER) + ; + S OCXOERR=$$FILE(DFN,100,"105") Q:OCXOERR + Q + ; +CTMRI(DFN,OCXOI) ; Compiler Function: CT MRI PHYSICAL LIMITS + ; + N OCXDEV,OCXWTP,OCXHTP,OCXWTL,OCXHTL + S OCXDEV=$$TYPE^ORKRA(OCXOI) + Q:'((OCXDEV="MRI")!(OCXDEV="CT")) 0_U + S OCXWTP=$P($$WT^ORQPTQ4(DFN),U,2),OCXHTP=$P($$HT^ORQPTQ4(DFN),U,2) + I (OCXDEV="CT") S OCXWTL=$$GET^XPAR("ALL","ORK CT LIMIT WT",1,"Q"),OCXHTL=$$GET^XPAR("ALL","ORK CT LIMIT HT",1,"Q") + I (OCXDEV="CT"),(OCXWTL),(OCXWTP>OCXWTL) Q 1_U_"too heavy"_U_"CT scanner" + I (OCXDEV="CT"),(OCXHTL),(OCXHTP>OCXHTL) Q 1_U_"too tall"_U_"CT scanner" + I (OCXDEV="MRI") S OCXWTL=$$GET^XPAR("ALL","ORK MRI LIMIT WT",1,"Q"),OCXHTL=$$GET^XPAR("ALL","ORK MRI LIMIT HT",1,"Q") + I (OCXDEV="MRI"),(OCXWTL),(OCXWTP>OCXWTL) Q 1_U_"too heavy"_U_"MRI scanner" + I (OCXDEV="MRI"),(OCXHTL),(OCXHTP>OCXHTL) Q 1_U_"too tall"_U_"MRI scanner" + Q 0_U + ; +FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. + ; + N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI + S DFN=+$G(DFN),OCXELE=+$G(OCXELE) + ; + Q:'DFN 1 Q:'OCXELE 1 K OCXDATA + ; + S OCXDATA(DFN,OCXELE)=1 + F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D + .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL + ; + M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) + ; + Q 0 + ; +FLAB(DFN,OCXLIST,OCXSPEC) ; Compiler Function: FORMATTED LAB RESULTS + ; + Q:'$G(DFN) "" + Q:'$L($G(OCXLIST)) "" + N OCXLAB,OCXOUT,OCXPC,OCXSL,SPEC S OCXOUT="",SPEC="" + I $L($G(OCXSPEC)) S OCXSL=$$TERMLKUP(OCXSPEC,.OCXSL) + F OCXPC=1:1:$L(OCXLIST,U) S OCXLAB=$P(OCXLIST,U,OCXPC) I $L(OCXLAB) D + .N OCXX,OCXY,X,Y,DIC,TEST,SPEC,OCXTL,OCXA,OCXR + .S OCXTL="" Q:'$$TERMLKUP(OCXLAB,.OCXTL) + .S OCXX="",TEST=0 F S TEST=$O(OCXTL(TEST)) Q:'TEST D + ..I $L($G(OCXSL)) D + ...S SPEC=0 F S SPEC=$O(OCXSL(SPEC)) Q:'SPEC D + ....S OCXX=$$LOCL^ORQQLR1(DFN,TEST,SPEC) I $L(OCXX) D + .....S OCXA($P(OCXX,U,7))=OCXX + ..I '$L($G(OCXSL)) S OCXX=$$LOCL^ORQQLR1(DFN,TEST,"") + ..Q:'$L(OCXX) + .I $D(OCXA) S OCXR="",OCXR=$O(OCXA(OCXR),-1),OCXX=OCXA(OCXR) + .I $L(OCXX) D + ..S OCXY=$P(OCXX,U,2)_": "_$P(OCXX,U,3)_" "_$P(OCXX,U,4) + ..S OCXY=OCXY_" "_$S($L($P(OCXX,U,5)):"["_$P(OCXX,U,5)_"]",1:"") + ..I $L($P(OCXX,U,7)) S OCXY=OCXY_" "_$$FMTE^XLFDT($P(OCXX,U,7),"2P") + .S:$L(OCXOUT) OCXOUT=OCXOUT_" " S OCXOUT=OCXOUT_$G(OCXY) + Q:'$L(OCXOUT) "" Q OCXOUT + ; +ORDITEM(OIEN) ; Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER + Q:'$G(OIEN) "" + ; + N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found." + S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found." + Q $P(X,U,1) + ; +PATLOC(DFN) ; Compiler Function: PATIENT LOCATION + ; + N OCXP1,OCXP2 + S OCXP1=$G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",2)) + S OCXP2=$P($G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",3)),"^",1) + I OCXP2 D + .S OCXP2=$P($G(^SC(+OCXP2,0)),"^",1,2) + .I $L($P(OCXP2,"^",2)) S OCXP2=$P(OCXP2,"^",2) + .E S OCXP2=$P(OCXP2,"^",1) + .S:'$L(OCXP2) OCXP2="NO LOC" + I $L(OCXP1),$L(OCXP2) Q OCXP1_"^"_OCXP2 + ; + S OCXP2=$G(^DPT(+$G(DFN),.1)) + I $L(OCXP2) Q "I^"_OCXP2 + Q "O^OUTPT" + ; +TERMLKUP(OCXTERM,OCXLIST) ; + Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST) + ; +WARDRMBD(DFN) ; Compiler Function: WARD ROOM-BED + ; + Q:'$G(DFN) 0 + N OUT S OUT=$G(^DPT(DFN,.1)) Q:'$L(OUT) 0 + S OUT=1_"^"_OUT_" "_$G(^DPT(DFN,.101)) Q OUT + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0C.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0C.m index b37d90cf..1a595032 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0C.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0C.m @@ -1,210 +1,208 @@ -OCXOZ0C ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; - ; *************************************************************** - ; ** Warning: This routine is automatically generated by the ** - ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** - ; ** will be lost the next time the rule compiler executes. ** - ; *************************************************************** - ; - Q - ; -CHK302 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK6+19^OCXOZ02. - ; - Q:$G(OCXOERR) - ; - ; Local CHK302 Variables - ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(55) ---> Data Field: SITE FLAGGED RESULT (BOOLEAN) - ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) - ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT) - ; - ; Local Extrinsic Functions - ; FILE(DFN,102, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: SITE FLAGGED FINAL IMAGING RESULT) - ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER - ; PATLOC( ----------> PATIENT LOCATION - ; - I $L(OCXDF(55)),(OCXDF(55)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,102,"9,96,147") Q:OCXOERR - Q - ; -CHK314 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK35+18^OCXOZ04. - ; - Q:$G(OCXOERR) - ; - ; Local CHK314 Variables - ; OCXDF(113) --> Data Field: LAB TEST ID (NUMERIC) - ; OCXDF(114) --> Data Field: LAB TEST PRINT NAME (FREE TEXT) - ; - ; Local Extrinsic Functions - ; FILE(DFN,103, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: HL7 LAB TEST RESULTS ABNORMAL) - ; - I $L(OCXDF(113)) S OCXDF(114)=$$PRINTNAM^ORQQLR1(OCXDF(113)),OCXOERR=$$FILE(DFN,103,"12,13,96,114") Q:OCXOERR - Q - ; -CHK324 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK34+16^OCXOZ04. - ; - Q:$G(OCXOERR) - ; - ; Local CHK324 Variables - ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) - ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) - ; OCXDF(113) --> Data Field: LAB TEST ID (NUMERIC) - ; OCXDF(114) --> Data Field: LAB TEST PRINT NAME (FREE TEXT) - ; - ; Local Extrinsic Functions - ; FILE(DFN,105, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: HL7 LAB ORDER RESULTS CRITICAL) - ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER - ; - S OCXDF(96)=$$ORDITEM(OCXDF(34)) I $L(OCXDF(113)) S OCXDF(114)=$$PRINTNAM^ORQQLR1(OCXDF(113)),OCXOERR=$$FILE(DFN,105,"12,13,96,114") Q:OCXOERR - Q - ; -CHK336 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK6+20^OCXOZ02. - ; - Q:$G(OCXOERR) - ; - ; Local CHK336 Variables - ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(55) ---> Data Field: SITE FLAGGED RESULT (BOOLEAN) - ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) - ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT) - ; - ; Local Extrinsic Functions - ; FILE(DFN,109, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: SITE FLAGGED FINAL CONSULT RESULT) - ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER - ; PATLOC( ----------> PATIENT LOCATION - ; - I $L(OCXDF(55)),(OCXDF(55)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,109,"9,96,147") Q:OCXOERR - Q - ; -CHK347 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK58+20^OCXOZ05. - ; - Q:$G(OCXOERR) - ; - ; Local CHK347 Variables - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) - ; OCXDF(136) --> Data Field: CLOZAPINE ANC W/IN 7 FLAG (BOOLEAN) - ; OCXDF(137) --> Data Field: CLOZAPINE ANC W/IN 7 RESULT (NUMERIC) - ; OCXDF(139) --> Data Field: CLOZAPINE WBC W/IN 7 FLAG (BOOLEAN) - ; OCXDF(140) --> Data Field: CLOZAPINE WBC W/IN 7 RESULT (NUMERIC) - ; - ; Local Extrinsic Functions - ; - S OCXDF(137)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",3),";",2) I $L(OCXDF(137)) D CHK349 - S OCXDF(136)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",3),";",1) I $L(OCXDF(136)),'(OCXDF(136)) D CHK371^OCXOZ0D - S OCXDF(139)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",2),";",1) I $L(OCXDF(139)),'(OCXDF(139)) D CHK375^OCXOZ0D - S OCXDF(140)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",2),";",2) I $L(OCXDF(140)) D CHK378^OCXOZ0D - Q - ; -CHK349 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK347+15. - ; - Q:$G(OCXOERR) - ; - ; Local CHK349 Variables - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) - ; OCXDF(136) --> Data Field: CLOZAPINE ANC W/IN 7 FLAG (BOOLEAN) - ; OCXDF(137) --> Data Field: CLOZAPINE ANC W/IN 7 RESULT (NUMERIC) - ; - ; Local Extrinsic Functions - ; - I (OCXDF(137)<1.5) S OCXDF(136)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",3),";",1) I $L(OCXDF(136)),(OCXDF(136)) D CHK353 - I (OCXDF(137)>1.499) D CHK355 - Q - ; -CHK353 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK349+13. - ; - Q:$G(OCXOERR) - ; - ; Local CHK353 Variables - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT) - ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) - ; - ; Local Extrinsic Functions - ; FILE(DFN,114, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CLOZAPINE ANC < 1.5) - ; - S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXOERR=$$FILE(DFN,114,"130") Q:OCXOERR - Q - ; -CHK355 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK349+14. - ; - Q:$G(OCXOERR) - ; - ; Local CHK355 Variables - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) - ; OCXDF(136) --> Data Field: CLOZAPINE ANC W/IN 7 FLAG (BOOLEAN) - ; OCXDF(137) --> Data Field: CLOZAPINE ANC W/IN 7 RESULT (NUMERIC) - ; - ; Local Extrinsic Functions - ; - S OCXDF(136)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",3),";",1) I $L(OCXDF(136)),(OCXDF(136)) D CHK358 - I (OCXDF(137)<"2.0") S OCXDF(136)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",3),";",1) I $L(OCXDF(136)),(OCXDF(136)) D CHK505^OCXOZ0G - Q - ; -CHK358 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK355+13. - ; - Q:$G(OCXOERR) - ; - ; Local CHK358 Variables - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT) - ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) - ; - ; Local Extrinsic Functions - ; FILE(DFN,115, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CLOZAPINE ANC >= 1.5) - ; - S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXOERR=$$FILE(DFN,115,"130") Q:OCXOERR - Q - ; -FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. - ; - N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI - S DFN=+$G(DFN),OCXELE=+$G(OCXELE) - ; - Q:'DFN 1 Q:'OCXELE 1 K OCXDATA - ; - S OCXDATA(DFN,OCXELE)=1 - F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D - .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL - ; - M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) - ; - Q 0 - ; -ORDITEM(OIEN) ; Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER - Q:'$G(OIEN) "" - ; - N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found." - S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found." - Q $P(X,U,1) - ; -PATLOC(DFN) ; Compiler Function: PATIENT LOCATION - ; - N OCXP1,OCXP2 - S OCXP1=$G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",2)) - S OCXP2=$P($G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",3)),"^",1) - I OCXP2 D - .S OCXP2=$P($G(^SC(+OCXP2,0)),"^",1,2) - .I $L($P(OCXP2,"^",2)) S OCXP2=$P(OCXP2,"^",2) - .E S OCXP2=$P(OCXP2,"^",1) - .S:'$L(OCXP2) OCXP2="NO LOC" - I $L(OCXP1),$L(OCXP2) Q OCXP1_"^"_OCXP2 - ; - S OCXP2=$G(^DPT(+$G(DFN),.1)) - I $L(OCXP2) Q "I^"_OCXP2 - Q "O^OUTPT" - ; +OCXOZ0C ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; + ; *************************************************************** + ; ** Warning: This routine is automatically generated by the ** + ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** + ; ** will be lost the next time the rule compiler executes. ** + ; *************************************************************** + ; + Q + ; +CHK302 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK6+19^OCXOZ02. + ; + Q:$G(OCXOERR) + ; + ; Local CHK302 Variables + ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(55) ---> Data Field: SITE FLAGGED RESULT (BOOLEAN) + ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) + ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT) + ; + ; Local Extrinsic Functions + ; FILE(DFN,102, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: SITE FLAGGED FINAL IMAGING RESULT) + ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER + ; PATLOC( ----------> PATIENT LOCATION + ; + I $L(OCXDF(55)),(OCXDF(55)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,102,"9,96,147") Q:OCXOERR + Q + ; +CHK314 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK35+18^OCXOZ04. + ; + Q:$G(OCXOERR) + ; + ; Local CHK314 Variables + ; OCXDF(113) --> Data Field: LAB TEST ID (NUMERIC) + ; OCXDF(114) --> Data Field: LAB TEST PRINT NAME (FREE TEXT) + ; + ; Local Extrinsic Functions + ; FILE(DFN,103, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: HL7 LAB TEST RESULTS ABNORMAL) + ; + I $L(OCXDF(113)) S OCXDF(114)=$$PRINTNAM^ORQQLR1(OCXDF(113)),OCXOERR=$$FILE(DFN,103,"12,13,96,114") Q:OCXOERR + Q + ; +CHK324 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK34+16^OCXOZ04. + ; + Q:$G(OCXOERR) + ; + ; Local CHK324 Variables + ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) + ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) + ; OCXDF(113) --> Data Field: LAB TEST ID (NUMERIC) + ; OCXDF(114) --> Data Field: LAB TEST PRINT NAME (FREE TEXT) + ; + ; Local Extrinsic Functions + ; FILE(DFN,105, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: HL7 LAB ORDER RESULTS CRITICAL) + ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER + ; + S OCXDF(96)=$$ORDITEM(OCXDF(34)) I $L(OCXDF(113)) S OCXDF(114)=$$PRINTNAM^ORQQLR1(OCXDF(113)),OCXOERR=$$FILE(DFN,105,"12,13,96,114") Q:OCXOERR + Q + ; +CHK336 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK6+20^OCXOZ02. + ; + Q:$G(OCXOERR) + ; + ; Local CHK336 Variables + ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(55) ---> Data Field: SITE FLAGGED RESULT (BOOLEAN) + ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) + ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT) + ; + ; Local Extrinsic Functions + ; FILE(DFN,109, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: SITE FLAGGED FINAL CONSULT RESULT) + ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER + ; PATLOC( ----------> PATIENT LOCATION + ; + I $L(OCXDF(55)),(OCXDF(55)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,109,"9,96,147") Q:OCXOERR + Q + ; +CHK347 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK58+20^OCXOZ05. + ; + Q:$G(OCXOERR) + ; + ; Local CHK347 Variables + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) + ; OCXDF(136) --> Data Field: CLOZAPINE ANC W/IN 7 FLAG (BOOLEAN) + ; OCXDF(137) --> Data Field: CLOZAPINE ANC W/IN 7 RESULT (NUMERIC) + ; OCXDF(139) --> Data Field: CLOZAPINE WBC W/IN 7 FLAG (BOOLEAN) + ; OCXDF(140) --> Data Field: CLOZAPINE WBC W/IN 7 RESULT (NUMERIC) + ; + ; Local Extrinsic Functions + ; + S OCXDF(137)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",3),";",2) I $L(OCXDF(137)) D CHK349 + S OCXDF(136)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",3),";",1) I $L(OCXDF(136)),'(OCXDF(136)) D CHK374^OCXOZ0D + S OCXDF(139)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",2),";",1) I $L(OCXDF(139)),'(OCXDF(139)) D CHK379^OCXOZ0D + S OCXDF(140)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",2),";",2) I $L(OCXDF(140)) D CHK383^OCXOZ0D + Q + ; +CHK349 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK347+15. + ; + Q:$G(OCXOERR) + ; + ; Local CHK349 Variables + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) + ; OCXDF(136) --> Data Field: CLOZAPINE ANC W/IN 7 FLAG (BOOLEAN) + ; OCXDF(137) --> Data Field: CLOZAPINE ANC W/IN 7 RESULT (NUMERIC) + ; + ; Local Extrinsic Functions + ; + I (OCXDF(137)<1.5) S OCXDF(136)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",3),";",1) I $L(OCXDF(136)),(OCXDF(136)) D CHK353 + I (OCXDF(137)>1.499) S OCXDF(136)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",3),";",1) I $L(OCXDF(136)),(OCXDF(136)) D CHK359^OCXOZ0D + Q + ; +CHK353 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK349+13. + ; + Q:$G(OCXOERR) + ; + ; Local CHK353 Variables + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT) + ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) + ; OCXDF(145) --> Data Field: CLOZAPINE WBC 3.0-3.5 TEXT (FREE TEXT) + ; + ; Local Extrinsic Functions + ; FILE(DFN,114, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CLOZAPINE ANC < 1.5) + ; MSGTEXT( ---------> MESSAGE TEXT + ; + S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXDF(145)=$$MSGTEXT("CLOZWBC30_35"),OCXOERR=$$FILE(DFN,114,"130,145") Q:OCXOERR + Q + ; +FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. + ; + N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI + S DFN=+$G(DFN),OCXELE=+$G(OCXELE) + ; + Q:'DFN 1 Q:'OCXELE 1 K OCXDATA + ; + S OCXDATA(DFN,OCXELE)=1 + F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D + .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL + ; + M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) + ; + Q 0 + ; +MSGTEXT(ID) ; Compiler Function: MESSAGE TEXT + ; + N MSG + S MSG="" + ; + I ID="AMITRIPTYLINE" D + .S MSG="Amitriptyline can cause cognitive impairment and loss of" + .S MSG=MSG_" balance in older patients. Consider other antidepressant" + .S MSG=MSG_" medications on formulary." + ; + I ID="CHLORPROPAMIDE" D + .S MSG="Older patients may experience hypoglycemia with" + .S MSG=MSG_" Chlorpropamide due to its long duration and variable" + .S MSG=MSG_" renal secretion. They may also be at increased risk for" + .S MSG=MSG_" Chlorpropamide-induced SIADH." + ; + I ID="DIPYRIDAMOLE" D + .S MSG="Older patients can experience adverse reactions at high doses" + .S MSG=MSG_" of Dipyridamole (e.g., headache, dizziness, syncope, GI" + .S MSG=MSG_" intolerance.) There is also questionable efficacy at" + .S MSG=MSG_" lower doses." + ; + I ID="CLOZWBC30_35" D + .S MSG="WBC between 3.0 and 3.5 with no ANC - pharmacy cannot fill" + .S MSG=MSG_" clozapine order. Please order CBC/Diff with WBC and ANC" + .S MSG=MSG_" immediately." + ; + Q MSG + ; +ORDITEM(OIEN) ; Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER + Q:'$G(OIEN) "" + ; + N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found." + S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found." + Q $P(X,U,1) + ; +PATLOC(DFN) ; Compiler Function: PATIENT LOCATION + ; + N OCXP1,OCXP2 + S OCXP1=$G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",2)) + S OCXP2=$P($G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",3)),"^",1) + I OCXP2 D + .S OCXP2=$P($G(^SC(+OCXP2,0)),"^",1,2) + .I $L($P(OCXP2,"^",2)) S OCXP2=$P(OCXP2,"^",2) + .E S OCXP2=$P(OCXP2,"^",1) + .S:'$L(OCXP2) OCXP2="NO LOC" + I $L(OCXP1),$L(OCXP2) Q OCXP1_"^"_OCXP2 + ; + S OCXP2=$G(^DPT(+$G(DFN),.1)) + I $L(OCXP2) Q "I^"_OCXP2 + Q "O^OUTPT" + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0D.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0D.m index 335743d9..1927151e 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0D.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0D.m @@ -1,208 +1,201 @@ -OCXOZ0D ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; - ; *************************************************************** - ; ** Warning: This routine is automatically generated by the ** - ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** - ; ** will be lost the next time the rule compiler executes. ** - ; *************************************************************** - ; - Q - ; -CHK360 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK198+9^OCXOZ09. - ; - Q:$G(OCXOERR) - ; - ; Local CHK360 Variables - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(43) ---> Data Field: OI NATIONAL ID (FREE TEXT) - ; OCXDF(74) ---> Data Field: VA DRUG CLASS (FREE TEXT) - ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) - ; OCXDF(132) --> Data Field: CLOZAPINE MED (BOOLEAN) - ; - ; Local Extrinsic Functions - ; - S OCXDF(131)=$P($P($G(OCXPSD),"|",3),"^",4) I $L(OCXDF(131)) S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(132)=$P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",1) D CHK365 - S OCXDF(43)=$P($P($G(OCXPSD),"|",3),"^",1) I $L(OCXDF(43)) S OCXDF(74)=$P($$ENVAC^PSJORUT2(OCXDF(43)),"^",2) I $L(OCXDF(74)) D CHK497^OCXOZ0G - Q - ; -CHK365 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK360+14. - ; - Q:$G(OCXOERR) - ; - ; Local CHK365 Variables - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT) - ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) - ; OCXDF(132) --> Data Field: CLOZAPINE MED (BOOLEAN) - ; - ; Local Extrinsic Functions - ; FILE(DFN,116, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CLOZAPINE DRUG SELECTED) - ; - I $L(OCXDF(132)),(OCXDF(132)) S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXOERR=$$FILE(DFN,116,"130") Q:OCXOERR - Q - ; -CHK371 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK347+16^OCXOZ0C. - ; - Q:$G(OCXOERR) - ; - ; Local CHK371 Variables - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT) - ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) - ; - ; Local Extrinsic Functions - ; FILE(DFN,117, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CLOZAPINE NO ANC W/IN 7 DAYS) - ; - S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXOERR=$$FILE(DFN,117,"130") Q:OCXOERR - Q - ; -CHK375 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK347+17^OCXOZ0C. - ; - Q:$G(OCXOERR) - ; - ; Local CHK375 Variables - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT) - ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) - ; - ; Local Extrinsic Functions - ; FILE(DFN,118, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CLOZAPINE NO WBC W/IN 7 DAYS) - ; - S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXOERR=$$FILE(DFN,118,"130") Q:OCXOERR - Q - ; -CHK378 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK347+18^OCXOZ0C. - ; - Q:$G(OCXOERR) - ; - ; Local CHK378 Variables - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) - ; OCXDF(139) --> Data Field: CLOZAPINE WBC W/IN 7 FLAG (BOOLEAN) - ; OCXDF(140) --> Data Field: CLOZAPINE WBC W/IN 7 RESULT (NUMERIC) - ; - ; Local Extrinsic Functions - ; - I (OCXDF(140)<"3.0") S OCXDF(139)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",2),";",1) I $L(OCXDF(139)),(OCXDF(139)) D CHK382 - I (OCXDF(140)>2.999),(OCXDF(140)<3.5) S OCXDF(139)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",2),";",1) I $L(OCXDF(139)),(OCXDF(139)) D CHK388 - I (OCXDF(140)>3.499) S OCXDF(139)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",2),";",1) I $L(OCXDF(139)),(OCXDF(139)) D CHK393 - Q - ; -CHK382 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK378+13. - ; - Q:$G(OCXOERR) - ; - ; Local CHK382 Variables - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT) - ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) - ; - ; Local Extrinsic Functions - ; FILE(DFN,119, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CLOZAPINE WBC < 3.0) - ; - S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXOERR=$$FILE(DFN,119,"130") Q:OCXOERR - Q - ; -CHK388 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK378+14. - ; - Q:$G(OCXOERR) - ; - ; Local CHK388 Variables - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT) - ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) - ; - ; Local Extrinsic Functions - ; FILE(DFN,120, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CLOZAPINE WBC >= 3.0 & < 3.5) - ; - S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXOERR=$$FILE(DFN,120,"130") Q:OCXOERR - Q - ; -CHK393 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK378+15. - ; - Q:$G(OCXOERR) - ; - ; Local CHK393 Variables - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT) - ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) - ; - ; Local Extrinsic Functions - ; FILE(DFN,121, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CLOZAPINE WBC >= 3.5) - ; - S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXOERR=$$FILE(DFN,121,"130") Q:OCXOERR - Q - ; -CHK398 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK58+21^OCXOZ05. - ; - Q:$G(OCXOERR) - ; - ; Local CHK398 Variables - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(62) ---> Data Field: PATIENT AGE (NUMERIC) - ; OCXDF(141) --> Data Field: AMITRIPTYLINE TEXT (FREE TEXT) - ; OCXDF(143) --> Data Field: DANGEROUS MEDS FOR PT > 64 NAME (FREE TEXT) - ; - ; Local Extrinsic Functions - ; MSGTEXT( ---------> MESSAGE TEXT - ; - I (OCXDF(143)["AMITRIPTYLINE") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(62)=$$AGE^ORQPTQ4(OCXDF(37)),OCXDF(141)=$$MSGTEXT("AMITRIPTYLINE") D CHK403^OCXOZ0E - I (OCXDF(143)["CHLORPROPAMIDE") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(62)=$$AGE^ORQPTQ4(OCXDF(37)),OCXDF(141)=$$MSGTEXT("AMITRIPTYLINE") D CHK410^OCXOZ0E - I (OCXDF(143)["DIPYRIDAMOLE") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(62)=$$AGE^ORQPTQ4(OCXDF(37)),OCXDF(141)=$$MSGTEXT("AMITRIPTYLINE") D CHK417^OCXOZ0E - Q - ; -FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. - ; - N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI - S DFN=+$G(DFN),OCXELE=+$G(OCXELE) - ; - Q:'DFN 1 Q:'OCXELE 1 K OCXDATA - ; - S OCXDATA(DFN,OCXELE)=1 - F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D - .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL - ; - M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) - ; - Q 0 - ; -MSGTEXT(ID) ; Compiler Function: MESSAGE TEXT - ; - N MSG - S MSG="" - ; - I ID="AMITRIPTYLINE" D - .S MSG="Amitriptyline can cause cognitive impairment and loss of" - .S MSG=MSG_" balance in older patients. Consider other antidepressant" - .S MSG=MSG_" medications on formulary." - ; - I ID="CHLORPROPAMIDE" D - .S MSG="Older patients may experience hypoglycemia with" - .S MSG=MSG_" Chlorpropamide due to its long duration and variable" - .S MSG=MSG_" renal secretion. They may also be at increased risk for" - .S MSG=MSG_" Chlorpropamide-induced SIADH." - ; - I ID="DIPYRIDAMOLE" D - .S MSG="Older patients can experience adverse reactions at high doses" - .S MSG=MSG_" of Dipyridamole (e.g., headache, dizziness, syncope, GI" - .S MSG=MSG_" intolerance.) There is also questionable efficacy at" - .S MSG=MSG_" lower doses." - ; - I ID="CLOZWBC30_35" D - .S MSG="WBC between 3.0 and 3.5 with no ANC - pharmacy cannot fill" - .S MSG=MSG_" clozapine order. Please order CBC/Diff with WBC and ANC" - .S MSG=MSG_" immediately." - ; - Q MSG - ; +OCXOZ0D ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; + ; *************************************************************** + ; ** Warning: This routine is automatically generated by the ** + ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** + ; ** will be lost the next time the rule compiler executes. ** + ; *************************************************************** + ; + Q + ; +CHK359 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK349+14^OCXOZ0C. + ; + Q:$G(OCXOERR) + ; + ; Local CHK359 Variables + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT) + ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) + ; OCXDF(145) --> Data Field: CLOZAPINE WBC 3.0-3.5 TEXT (FREE TEXT) + ; + ; Local Extrinsic Functions + ; FILE(DFN,115, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CLOZAPINE ANC >= 1.5) + ; MSGTEXT( ---------> MESSAGE TEXT + ; + S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXDF(145)=$$MSGTEXT("CLOZWBC30_35"),OCXOERR=$$FILE(DFN,115,"130,145") Q:OCXOERR + Q + ; +CHK362 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK198+9^OCXOZ09. + ; + Q:$G(OCXOERR) + ; + ; Local CHK362 Variables + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(43) ---> Data Field: OI NATIONAL ID (FREE TEXT) + ; OCXDF(74) ---> Data Field: VA DRUG CLASS (FREE TEXT) + ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) + ; OCXDF(132) --> Data Field: CLOZAPINE MED (BOOLEAN) + ; + ; Local Extrinsic Functions + ; + S OCXDF(131)=$P($P($G(OCXPSD),"|",3),"^",4) I $L(OCXDF(131)) S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(132)=$P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",1) D CHK367 + S OCXDF(43)=$P($P($G(OCXPSD),"|",3),"^",1) I $L(OCXDF(43)) S OCXDF(74)=$P($$ENVAC^PSJORUT2(OCXDF(43)),"^",2) I $L(OCXDF(74)) D CHK505^OCXOZ0G + Q + ; +CHK367 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK362+14. + ; + Q:$G(OCXOERR) + ; + ; Local CHK367 Variables + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT) + ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) + ; OCXDF(132) --> Data Field: CLOZAPINE MED (BOOLEAN) + ; OCXDF(145) --> Data Field: CLOZAPINE WBC 3.0-3.5 TEXT (FREE TEXT) + ; + ; Local Extrinsic Functions + ; FILE(DFN,116, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CLOZAPINE DRUG SELECTED) + ; MSGTEXT( ---------> MESSAGE TEXT + ; + I $L(OCXDF(132)),(OCXDF(132)) S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXDF(145)=$$MSGTEXT("CLOZWBC30_35"),OCXOERR=$$FILE(DFN,116,"130,145") Q:OCXOERR + Q + ; +CHK374 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK347+16^OCXOZ0C. + ; + Q:$G(OCXOERR) + ; + ; Local CHK374 Variables + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT) + ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) + ; OCXDF(145) --> Data Field: CLOZAPINE WBC 3.0-3.5 TEXT (FREE TEXT) + ; + ; Local Extrinsic Functions + ; FILE(DFN,117, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CLOZAPINE NO ANC W/IN 7 DAYS) + ; MSGTEXT( ---------> MESSAGE TEXT + ; + S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXDF(145)=$$MSGTEXT("CLOZWBC30_35"),OCXOERR=$$FILE(DFN,117,"130,145") Q:OCXOERR + Q + ; +CHK379 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK347+17^OCXOZ0C. + ; + Q:$G(OCXOERR) + ; + ; Local CHK379 Variables + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT) + ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) + ; OCXDF(145) --> Data Field: CLOZAPINE WBC 3.0-3.5 TEXT (FREE TEXT) + ; + ; Local Extrinsic Functions + ; FILE(DFN,118, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CLOZAPINE NO WBC W/IN 7 DAYS) + ; MSGTEXT( ---------> MESSAGE TEXT + ; + S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXDF(145)=$$MSGTEXT("CLOZWBC30_35"),OCXOERR=$$FILE(DFN,118,"130,145") Q:OCXOERR + Q + ; +CHK383 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK347+18^OCXOZ0C. + ; + Q:$G(OCXOERR) + ; + ; Local CHK383 Variables + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) + ; OCXDF(139) --> Data Field: CLOZAPINE WBC W/IN 7 FLAG (BOOLEAN) + ; OCXDF(140) --> Data Field: CLOZAPINE WBC W/IN 7 RESULT (NUMERIC) + ; + ; Local Extrinsic Functions + ; + I (OCXDF(140)<"3.0") S OCXDF(139)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",2),";",1) I $L(OCXDF(139)),(OCXDF(139)) D CHK387 + I (OCXDF(140)>2.999),(OCXDF(140)<3.5) S OCXDF(139)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",2),";",1) I $L(OCXDF(139)),(OCXDF(139)) D CHK394 + I (OCXDF(140)>3.499) S OCXDF(139)=$P($P($$CLOZLABS^ORKLR(OCXDF(37),7,OCXDF(131)),"^",2),";",1) I $L(OCXDF(139)),(OCXDF(139)) D CHK400^OCXOZ0E + Q + ; +CHK387 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK383+13. + ; + Q:$G(OCXOERR) + ; + ; Local CHK387 Variables + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT) + ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) + ; OCXDF(145) --> Data Field: CLOZAPINE WBC 3.0-3.5 TEXT (FREE TEXT) + ; + ; Local Extrinsic Functions + ; FILE(DFN,119, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CLOZAPINE WBC < 3.0) + ; MSGTEXT( ---------> MESSAGE TEXT + ; + S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXDF(145)=$$MSGTEXT("CLOZWBC30_35"),OCXOERR=$$FILE(DFN,119,"130,145") Q:OCXOERR + Q + ; +CHK394 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK383+14. + ; + Q:$G(OCXOERR) + ; + ; Local CHK394 Variables + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT) + ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) + ; OCXDF(145) --> Data Field: CLOZAPINE WBC 3.0-3.5 TEXT (FREE TEXT) + ; + ; Local Extrinsic Functions + ; FILE(DFN,120, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CLOZAPINE WBC >= 3.0 & < 3.5) + ; MSGTEXT( ---------> MESSAGE TEXT + ; + S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXDF(145)=$$MSGTEXT("CLOZWBC30_35"),OCXOERR=$$FILE(DFN,120,"130,145") Q:OCXOERR + Q + ; +FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. + ; + N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI + S DFN=+$G(DFN),OCXELE=+$G(OCXELE) + ; + Q:'DFN 1 Q:'OCXELE 1 K OCXDATA + ; + S OCXDATA(DFN,OCXELE)=1 + F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D + .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL + ; + M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) + ; + Q 0 + ; +MSGTEXT(ID) ; Compiler Function: MESSAGE TEXT + ; + N MSG + S MSG="" + ; + I ID="AMITRIPTYLINE" D + .S MSG="Amitriptyline can cause cognitive impairment and loss of" + .S MSG=MSG_" balance in older patients. Consider other antidepressant" + .S MSG=MSG_" medications on formulary." + ; + I ID="CHLORPROPAMIDE" D + .S MSG="Older patients may experience hypoglycemia with" + .S MSG=MSG_" Chlorpropamide due to its long duration and variable" + .S MSG=MSG_" renal secretion. They may also be at increased risk for" + .S MSG=MSG_" Chlorpropamide-induced SIADH." + ; + I ID="DIPYRIDAMOLE" D + .S MSG="Older patients can experience adverse reactions at high doses" + .S MSG=MSG_" of Dipyridamole (e.g., headache, dizziness, syncope, GI" + .S MSG=MSG_" intolerance.) There is also questionable efficacy at" + .S MSG=MSG_" lower doses." + ; + I ID="CLOZWBC30_35" D + .S MSG="WBC between 3.0 and 3.5 with no ANC - pharmacy cannot fill" + .S MSG=MSG_" clozapine order. Please order CBC/Diff with WBC and ANC" + .S MSG=MSG_" immediately." + ; + Q MSG + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0E.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0E.m index b4b74bd4..04b49243 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0E.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0E.m @@ -1,177 +1,214 @@ -OCXOZ0E ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; - ; *************************************************************** - ; ** Warning: This routine is automatically generated by the ** - ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** - ; ** will be lost the next time the rule compiler executes. ** - ; *************************************************************** - ; - Q - ; -CHK403 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK398+14^OCXOZ0D. - ; - Q:$G(OCXOERR) - ; - ; Local CHK403 Variables - ; OCXDF(142) --> Data Field: CHLORPROPAMIDE TEXT (FREE TEXT) - ; OCXDF(144) --> Data Field: DIPYRIDAMOLE TEXT (FREE TEXT) - ; - ; Local Extrinsic Functions - ; FILE(DFN,122, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: AMITRIPTYLINE ORDER) - ; MSGTEXT( ---------> MESSAGE TEXT - ; - S OCXDF(142)=$$MSGTEXT("CHLORPROPAMIDE"),OCXDF(144)=$$MSGTEXT("DIPYRIDAMOLE"),OCXOERR=$$FILE(DFN,122,"62,141,142,144") Q:OCXOERR - Q - ; -CHK410 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK398+15^OCXOZ0D. - ; - Q:$G(OCXOERR) - ; - ; Local CHK410 Variables - ; OCXDF(142) --> Data Field: CHLORPROPAMIDE TEXT (FREE TEXT) - ; OCXDF(144) --> Data Field: DIPYRIDAMOLE TEXT (FREE TEXT) - ; - ; Local Extrinsic Functions - ; FILE(DFN,123, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CHLORPROPAMIDE ORDER) - ; MSGTEXT( ---------> MESSAGE TEXT - ; - S OCXDF(142)=$$MSGTEXT("CHLORPROPAMIDE"),OCXDF(144)=$$MSGTEXT("DIPYRIDAMOLE"),OCXOERR=$$FILE(DFN,123,"62,141,142,144") Q:OCXOERR - Q - ; -CHK417 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK398+16^OCXOZ0D. - ; - Q:$G(OCXOERR) - ; - ; Local CHK417 Variables - ; OCXDF(142) --> Data Field: CHLORPROPAMIDE TEXT (FREE TEXT) - ; OCXDF(144) --> Data Field: DIPYRIDAMOLE TEXT (FREE TEXT) - ; - ; Local Extrinsic Functions - ; FILE(DFN,124, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: DIPYRIDAMOLE ORDER) - ; MSGTEXT( ---------> MESSAGE TEXT - ; - S OCXDF(142)=$$MSGTEXT("CHLORPROPAMIDE"),OCXDF(144)=$$MSGTEXT("DIPYRIDAMOLE"),OCXOERR=$$FILE(DFN,124,"62,141,142,144") Q:OCXOERR - Q - ; -CHK426 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK164+16^OCXOZ08. - ; - Q:$G(OCXOERR) - ; - ; Local CHK426 Variables - ; OCXDF(62) ---> Data Field: PATIENT AGE (NUMERIC) - ; OCXDF(141) --> Data Field: AMITRIPTYLINE TEXT (FREE TEXT) - ; OCXDF(142) --> Data Field: CHLORPROPAMIDE TEXT (FREE TEXT) - ; OCXDF(144) --> Data Field: DIPYRIDAMOLE TEXT (FREE TEXT) - ; - ; Local Extrinsic Functions - ; MSGTEXT( ---------> MESSAGE TEXT - ; - I (OCXDF(62)>64) S OCXDF(141)=$$MSGTEXT("AMITRIPTYLINE"),OCXDF(142)=$$MSGTEXT("CHLORPROPAMIDE"),OCXDF(144)=$$MSGTEXT("DIPYRIDAMOLE") D CHK430 - Q - ; -CHK430 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK426+14. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; FILE(DFN,125, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: MED ORDER FOR PT > 64) - ; - S OCXOERR=$$FILE(DFN,125,"62,141,142,144") Q:OCXOERR - Q - ; -CHK436 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK1+33^OCXOZ02. - ; - Q:$G(OCXOERR) - ; - ; Local CHK436 Variables - ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) - ; OCXDF(146) --> Data Field: INPT/OUTPT (FREE TEXT) - ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT) - ; - ; Local Extrinsic Functions - ; FILE(DFN,127, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: INPATIENT) - ; FILE(DFN,128, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: OUTPATIENT) - ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER - ; PATLOC( ----------> PATIENT LOCATION - ; - I (OCXDF(146)="I"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,127,"9,96,147") Q:OCXOERR - I (OCXDF(146)="O"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,128,"9,96,147") Q:OCXOERR - Q - ; -FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. - ; - N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI - S DFN=+$G(DFN),OCXELE=+$G(OCXELE) - ; - Q:'DFN 1 Q:'OCXELE 1 K OCXDATA - ; - S OCXDATA(DFN,OCXELE)=1 - F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D - .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL - ; - M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) - ; - Q 0 - ; -MSGTEXT(ID) ; Compiler Function: MESSAGE TEXT - ; - N MSG - S MSG="" - ; - I ID="AMITRIPTYLINE" D - .S MSG="Amitriptyline can cause cognitive impairment and loss of" - .S MSG=MSG_" balance in older patients. Consider other antidepressant" - .S MSG=MSG_" medications on formulary." - ; - I ID="CHLORPROPAMIDE" D - .S MSG="Older patients may experience hypoglycemia with" - .S MSG=MSG_" Chlorpropamide due to its long duration and variable" - .S MSG=MSG_" renal secretion. They may also be at increased risk for" - .S MSG=MSG_" Chlorpropamide-induced SIADH." - ; - I ID="DIPYRIDAMOLE" D - .S MSG="Older patients can experience adverse reactions at high doses" - .S MSG=MSG_" of Dipyridamole (e.g., headache, dizziness, syncope, GI" - .S MSG=MSG_" intolerance.) There is also questionable efficacy at" - .S MSG=MSG_" lower doses." - ; - I ID="CLOZWBC30_35" D - .S MSG="WBC between 3.0 and 3.5 with no ANC - pharmacy cannot fill" - .S MSG=MSG_" clozapine order. Please order CBC/Diff with WBC and ANC" - .S MSG=MSG_" immediately." - ; - Q MSG - ; -ORDITEM(OIEN) ; Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER - Q:'$G(OIEN) "" - ; - N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found." - S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found." - Q $P(X,U,1) - ; -PATLOC(DFN) ; Compiler Function: PATIENT LOCATION - ; - N OCXP1,OCXP2 - S OCXP1=$G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",2)) - S OCXP2=$P($G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",3)),"^",1) - I OCXP2 D - .S OCXP2=$P($G(^SC(+OCXP2,0)),"^",1,2) - .I $L($P(OCXP2,"^",2)) S OCXP2=$P(OCXP2,"^",2) - .E S OCXP2=$P(OCXP2,"^",1) - .S:'$L(OCXP2) OCXP2="NO LOC" - I $L(OCXP1),$L(OCXP2) Q OCXP1_"^"_OCXP2 - ; - S OCXP2=$G(^DPT(+$G(DFN),.1)) - I $L(OCXP2) Q "I^"_OCXP2 - Q "O^OUTPT" - ; +OCXOZ0E ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; + ; *************************************************************** + ; ** Warning: This routine is automatically generated by the ** + ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** + ; ** will be lost the next time the rule compiler executes. ** + ; *************************************************************** + ; + Q + ; +CHK400 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK383+15^OCXOZ0D. + ; + Q:$G(OCXOERR) + ; + ; Local CHK400 Variables + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT) + ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) + ; OCXDF(145) --> Data Field: CLOZAPINE WBC 3.0-3.5 TEXT (FREE TEXT) + ; + ; Local Extrinsic Functions + ; FILE(DFN,121, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CLOZAPINE WBC >= 3.5) + ; MSGTEXT( ---------> MESSAGE TEXT + ; + S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXDF(145)=$$MSGTEXT("CLOZWBC30_35"),OCXOERR=$$FILE(DFN,121,"130,145") Q:OCXOERR + Q + ; +CHK406 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK58+21^OCXOZ05. + ; + Q:$G(OCXOERR) + ; + ; Local CHK406 Variables + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(62) ---> Data Field: PATIENT AGE (NUMERIC) + ; OCXDF(141) --> Data Field: AMITRIPTYLINE TEXT (FREE TEXT) + ; OCXDF(143) --> Data Field: DANGEROUS MEDS FOR PT > 64 NAME (FREE TEXT) + ; + ; Local Extrinsic Functions + ; MSGTEXT( ---------> MESSAGE TEXT + ; + I (OCXDF(143)["AMITRIPTYLINE") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(62)=$$AGE^ORQPTQ4(OCXDF(37)),OCXDF(141)=$$MSGTEXT("AMITRIPTYLINE") D CHK411 + I (OCXDF(143)["CHLORPROPAMIDE") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(62)=$$AGE^ORQPTQ4(OCXDF(37)),OCXDF(141)=$$MSGTEXT("AMITRIPTYLINE") D CHK418 + I (OCXDF(143)["DIPYRIDAMOLE") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(62)=$$AGE^ORQPTQ4(OCXDF(37)),OCXDF(141)=$$MSGTEXT("AMITRIPTYLINE") D CHK425 + Q + ; +CHK411 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK406+14. + ; + Q:$G(OCXOERR) + ; + ; Local CHK411 Variables + ; OCXDF(142) --> Data Field: CHLORPROPAMIDE TEXT (FREE TEXT) + ; OCXDF(144) --> Data Field: DIPYRIDAMOLE TEXT (FREE TEXT) + ; + ; Local Extrinsic Functions + ; FILE(DFN,122, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: AMITRIPTYLINE ORDER) + ; MSGTEXT( ---------> MESSAGE TEXT + ; + S OCXDF(142)=$$MSGTEXT("CHLORPROPAMIDE"),OCXDF(144)=$$MSGTEXT("DIPYRIDAMOLE"),OCXOERR=$$FILE(DFN,122,"62,141,142,144") Q:OCXOERR + Q + ; +CHK418 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK406+15. + ; + Q:$G(OCXOERR) + ; + ; Local CHK418 Variables + ; OCXDF(142) --> Data Field: CHLORPROPAMIDE TEXT (FREE TEXT) + ; OCXDF(144) --> Data Field: DIPYRIDAMOLE TEXT (FREE TEXT) + ; + ; Local Extrinsic Functions + ; FILE(DFN,123, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CHLORPROPAMIDE ORDER) + ; MSGTEXT( ---------> MESSAGE TEXT + ; + S OCXDF(142)=$$MSGTEXT("CHLORPROPAMIDE"),OCXDF(144)=$$MSGTEXT("DIPYRIDAMOLE"),OCXOERR=$$FILE(DFN,123,"62,141,142,144") Q:OCXOERR + Q + ; +CHK425 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK406+16. + ; + Q:$G(OCXOERR) + ; + ; Local CHK425 Variables + ; OCXDF(142) --> Data Field: CHLORPROPAMIDE TEXT (FREE TEXT) + ; OCXDF(144) --> Data Field: DIPYRIDAMOLE TEXT (FREE TEXT) + ; + ; Local Extrinsic Functions + ; FILE(DFN,124, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: DIPYRIDAMOLE ORDER) + ; MSGTEXT( ---------> MESSAGE TEXT + ; + S OCXDF(142)=$$MSGTEXT("CHLORPROPAMIDE"),OCXDF(144)=$$MSGTEXT("DIPYRIDAMOLE"),OCXOERR=$$FILE(DFN,124,"62,141,142,144") Q:OCXOERR + Q + ; +CHK434 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK164+16^OCXOZ08. + ; + Q:$G(OCXOERR) + ; + ; Local CHK434 Variables + ; OCXDF(62) ---> Data Field: PATIENT AGE (NUMERIC) + ; OCXDF(141) --> Data Field: AMITRIPTYLINE TEXT (FREE TEXT) + ; OCXDF(142) --> Data Field: CHLORPROPAMIDE TEXT (FREE TEXT) + ; OCXDF(144) --> Data Field: DIPYRIDAMOLE TEXT (FREE TEXT) + ; + ; Local Extrinsic Functions + ; MSGTEXT( ---------> MESSAGE TEXT + ; + I (OCXDF(62)>64) S OCXDF(141)=$$MSGTEXT("AMITRIPTYLINE"),OCXDF(142)=$$MSGTEXT("CHLORPROPAMIDE"),OCXDF(144)=$$MSGTEXT("DIPYRIDAMOLE") D CHK438 + Q + ; +CHK438 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK434+14. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; FILE(DFN,125, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: MED ORDER FOR PT > 64) + ; + S OCXOERR=$$FILE(DFN,125,"62,141,142,144") Q:OCXOERR + Q + ; +CHK444 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK1+33^OCXOZ02. + ; + Q:$G(OCXOERR) + ; + ; Local CHK444 Variables + ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) + ; OCXDF(146) --> Data Field: INPT/OUTPT (FREE TEXT) + ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT) + ; + ; Local Extrinsic Functions + ; FILE(DFN,127, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: INPATIENT) + ; FILE(DFN,128, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: OUTPATIENT) + ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER + ; PATLOC( ----------> PATIENT LOCATION + ; + I (OCXDF(146)="I"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,127,"9,96,147") Q:OCXOERR + I (OCXDF(146)="O"),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)),OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,128,"9,96,147") Q:OCXOERR + Q + ; +FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. + ; + N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI + S DFN=+$G(DFN),OCXELE=+$G(OCXELE) + ; + Q:'DFN 1 Q:'OCXELE 1 K OCXDATA + ; + S OCXDATA(DFN,OCXELE)=1 + F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D + .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL + ; + M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) + ; + Q 0 + ; +MSGTEXT(ID) ; Compiler Function: MESSAGE TEXT + ; + N MSG + S MSG="" + ; + I ID="AMITRIPTYLINE" D + .S MSG="Amitriptyline can cause cognitive impairment and loss of" + .S MSG=MSG_" balance in older patients. Consider other antidepressant" + .S MSG=MSG_" medications on formulary." + ; + I ID="CHLORPROPAMIDE" D + .S MSG="Older patients may experience hypoglycemia with" + .S MSG=MSG_" Chlorpropamide due to its long duration and variable" + .S MSG=MSG_" renal secretion. They may also be at increased risk for" + .S MSG=MSG_" Chlorpropamide-induced SIADH." + ; + I ID="DIPYRIDAMOLE" D + .S MSG="Older patients can experience adverse reactions at high doses" + .S MSG=MSG_" of Dipyridamole (e.g., headache, dizziness, syncope, GI" + .S MSG=MSG_" intolerance.) There is also questionable efficacy at" + .S MSG=MSG_" lower doses." + ; + I ID="CLOZWBC30_35" D + .S MSG="WBC between 3.0 and 3.5 with no ANC - pharmacy cannot fill" + .S MSG=MSG_" clozapine order. Please order CBC/Diff with WBC and ANC" + .S MSG=MSG_" immediately." + ; + Q MSG + ; +ORDITEM(OIEN) ; Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER + Q:'$G(OIEN) "" + ; + N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found." + S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found." + Q $P(X,U,1) + ; +PATLOC(DFN) ; Compiler Function: PATIENT LOCATION + ; + N OCXP1,OCXP2 + S OCXP1=$G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",2)) + S OCXP2=$P($G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",3)),"^",1) + I OCXP2 D + .S OCXP2=$P($G(^SC(+OCXP2,0)),"^",1,2) + .I $L($P(OCXP2,"^",2)) S OCXP2=$P(OCXP2,"^",2) + .E S OCXP2=$P(OCXP2,"^",1) + .S:'$L(OCXP2) OCXP2="NO LOC" + I $L(OCXP1),$L(OCXP2) Q OCXP1_"^"_OCXP2 + ; + S OCXP2=$G(^DPT(+$G(DFN),.1)) + I $L(OCXP2) Q "I^"_OCXP2 + Q "O^OUTPT" + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0F.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0F.m index 05aa26db..0052f256 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0F.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0F.m @@ -1,217 +1,216 @@ -OCXOZ0F ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; - ; *************************************************************** - ; ** Warning: This routine is automatically generated by the ** - ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** - ; ** will be lost the next time the rule compiler executes. ** - ; *************************************************************** - ; - Q - ; -CHK446 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK58+22^OCXOZ05. - ; - Q:$G(OCXOERR) - ; - ; Local CHK446 Variables - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(57) ---> Data Field: MOST RECENT RENAL TEST ABNORMAL FLAG (BOOLEAN) - ; OCXDF(58) ---> Data Field: ABNORMAL RENAL BIOCHEM RESULTS (FREE TEXT) - ; OCXDF(154) --> Data Field: RECENT CONTRAST MEDIA CREATININE DAYS (NUMERIC) - ; OCXDF(155) --> Data Field: RECENT CONTRAST MEDIA CREATININE FLAG (BOOLEAN) - ; - ; Local Extrinsic Functions - ; ABREN( -----------> DETERMINE IF RENAL LAB RESULTS ARE ABNORMAL HIGH OR LOW - ; RECCREAT( --------> RECENT CREATININE LAB PROCEDURE - ; - S OCXDF(57)=$P($$ABREN(OCXDF(37)),"^",1) I $L(OCXDF(57)),(OCXDF(57)) S OCXDF(58)=$P($$ABREN(OCXDF(37)),"^",2),OCXDF(154)=$P($$CMCDAYS^ORKRA(OCXDF(37)),"^",1) D CHK451 - S OCXDF(154)=$P($$CMCDAYS^ORKRA(OCXDF(37)),"^",1) I $L(OCXDF(154)) S OCXDF(155)=$P($$RECCREAT(OCXDF(37),OCXDF(154)),"^",1) I $L(OCXDF(155)),'(OCXDF(155)) D CHK482^OCXOZ0G - Q - ; -CHK451 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK446+16. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; FILE(DFN,129, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: ABNORMAL RENAL RESULTS) - ; - S OCXOERR=$$FILE(DFN,129,"58,154") Q:OCXOERR - Q - ; -CHK458 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK196+18^OCXOZ09. - ; - Q:$G(OCXOERR) - ; - ; Local CHK458 Variables - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(58) ---> Data Field: ABNORMAL RENAL BIOCHEM RESULTS (FREE TEXT) - ; OCXDF(154) --> Data Field: RECENT CONTRAST MEDIA CREATININE DAYS (NUMERIC) - ; - ; Local Extrinsic Functions - ; ABREN( -----------> DETERMINE IF RENAL LAB RESULTS ARE ABNORMAL HIGH OR LOW - ; FILE(DFN,130, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CONTRAST MEDIA ORDER) - ; - S OCXDF(58)=$P($$ABREN(OCXDF(37)),"^",2),OCXDF(154)=$P($$CMCDAYS^ORKRA(OCXDF(37)),"^",1),OCXOERR=$$FILE(DFN,130,"58,154") Q:OCXOERR - Q - ; -CHK463 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK1+34^OCXOZ02. - ; - Q:$G(OCXOERR) - ; - ; Local CHK463 Variables - ; OCXDF(12) ---> Data Field: LAB RESULT (FREE TEXT) - ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) - ; OCXDF(113) --> Data Field: LAB TEST ID (NUMERIC) - ; OCXDF(150) --> Data Field: LAB RESULT < THRESHOLD (BOOLEAN) - ; OCXDF(151) --> Data Field: LAB RESULT > THRESHOLD (BOOLEAN) - ; OCXDF(152) --> Data Field: LAB SPECIMEN ID (NUMERIC) - ; - ; Local Extrinsic Functions - ; LABTHRSB( --------> LAB THRESHOLD EXCEEDED BOOLEAN - ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER - ; - S OCXDF(151)=$P($$LABTHRSB(OCXDF(113),OCXDF(152),OCXDF(12),">"),"^",1) I $L(OCXDF(151)),(OCXDF(151)),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)) I $L(OCXDF(37)) D CHK469 - S OCXDF(150)=$P($$LABTHRSB(OCXDF(113),OCXDF(152),OCXDF(12),"<"),"^",1) I $L(OCXDF(150)),(OCXDF(150)),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)) I $L(OCXDF(37)) D CHK476 - Q - ; -CHK469 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK463+19. - ; - Q:$G(OCXOERR) - ; - ; Local CHK469 Variables - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT) - ; - ; Local Extrinsic Functions - ; FILE(DFN,131, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: GREATER THAN LAB THRESHOLD) - ; PATLOC( ----------> PATIENT LOCATION - ; - S OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,131,"12,37,96,113,147,152") Q:OCXOERR - Q - ; -CHK476 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK463+20. - ; - Q:$G(OCXOERR) - ; - ; Local CHK476 Variables - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT) - ; - ; Local Extrinsic Functions - ; FILE(DFN,132, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: LESS THAN LAB THRESHOLD) - ; PATLOC( ----------> PATIENT LOCATION - ; - S OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,132,"12,37,96,113,147,152") Q:OCXOERR - Q - ; -ABREN(DFN) ; Compiler Function: DETERMINE IF RENAL LAB RESULTS ARE ABNORMAL HIGH OR LOW - ; - N OCXFLAG,OCXVAL,OCXLIST,OCXTEST,UNAV,OCXTLIST,OCXTERM,OCXSLIST,OCXSPEC - S (OCXLIST,OCXTLIST)="",UNAV="0^" - S OCXSLIST="" Q:'$$TERMLKUP("SERUM SPECIMEN",.OCXSLIST) UNAV - F OCXTERM="SERUM CREATININE","SERUM UREA NITROGEN" D Q:($L(OCXLIST)>130) - .Q:'$$TERMLKUP(OCXTERM,.OCXTLIST) - .S OCXTEST=0 F S OCXTEST=$O(OCXTLIST(OCXTEST)) Q:'OCXTEST D Q:($L(OCXLIST)>130) - ..S OCXSPEC=0 F S OCXSPEC=$O(OCXSLIST(OCXSPEC)) Q:'OCXSPEC D Q:($L(OCXLIST)>130) - ...S OCXVAL=$$LOCL^ORQQLR1(DFN,OCXTEST,OCXSPEC),OCXFLAG=$P(OCXVAL,U,5) - ...I $L(OCXVAL),((OCXFLAG["H")!(OCXFLAG["L")) D - ....N OCXY S OCXY="" - ....S OCXY=$P(OCXVAL,U,2)_": "_$P(OCXVAL,U,3)_" "_$P(OCXVAL,U,4) - ....S OCXY=OCXY_" "_$S($L(OCXFLAG):"["_OCXFLAG_"]",1:"") - ....S OCXY=OCXY_" "_$$FMTE^XLFDT($P(OCXVAL,U,7),"2P") - ....S:$L(OCXLIST) OCXLIST=OCXLIST_" " S OCXLIST=OCXLIST_OCXY - Q:'$L(OCXLIST) UNAV Q 1_U_OCXLIST - ; - ; -FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. - ; - N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI - S DFN=+$G(DFN),OCXELE=+$G(OCXELE) - ; - Q:'DFN 1 Q:'OCXELE 1 K OCXDATA - ; - S OCXDATA(DFN,OCXELE)=1 - F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D - .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL - ; - M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) - ; - Q 0 - ; -LABTHRSB(OCXLAB,OCXSPEC,OCXRSLT,OCXOP) ; Compiler Function: LAB THRESHOLD EXCEEDED BOOLEAN - ; - S OCXRSLT=$TR($G(OCXRSLT),"<>=","") - Q:'$G(OCXLAB)!'$G(OCXSPEC)!'$G(OCXRSLT)!'$L($G(OCXOP)) 0 - ; - N OCXX,OCXPENT,OCXERR,OCXLABSP,OCXPVAL,OCXEXCD - S OCXEXCD=0,OCXLABSP=OCXLAB_";"_OCXSPEC - D ENVAL^XPAR(.OCXX,"ORB LAB "_OCXOP_" THRESHOLD",OCXLABSP,.OCXERR) - Q:+$G(ORERR)'=0 OCXEXCD - Q:+$G(OCXX)=0 OCXEXCD - S OCXPENT="" F S OCXPENT=$O(OCXX(OCXPENT)) Q:'OCXPENT!OCXEXCD=1 D - .S OCXPVAL=OCXX(OCXPENT,OCXLABSP) - .I $L(OCXPVAL) D - ..I $P(OCXPENT,";",2)="VA(200,",@((+OCXRSLT)_OCXOP_OCXPVAL) D - ...S OCXEXCD=1 - Q OCXEXCD - ; -ORDITEM(OIEN) ; Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER - Q:'$G(OIEN) "" - ; - N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found." - S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found." - Q $P(X,U,1) - ; -PATLOC(DFN) ; Compiler Function: PATIENT LOCATION - ; - N OCXP1,OCXP2 - S OCXP1=$G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",2)) - S OCXP2=$P($G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",3)),"^",1) - I OCXP2 D - .S OCXP2=$P($G(^SC(+OCXP2,0)),"^",1,2) - .I $L($P(OCXP2,"^",2)) S OCXP2=$P(OCXP2,"^",2) - .E S OCXP2=$P(OCXP2,"^",1) - .S:'$L(OCXP2) OCXP2="NO LOC" - I $L(OCXP1),$L(OCXP2) Q OCXP1_"^"_OCXP2 - ; - S OCXP2=$G(^DPT(+$G(DFN),.1)) - I $L(OCXP2) Q "I^"_OCXP2 - Q "O^OUTPT" - ; -RECCREAT(ORDFN,ORDAYS) ;extrinsic function to return most recent - ;SERUM CREATININE within in format: - ; test id^result units flag ref range collection d/t - N BDT,CDT,ORY,ORX,ORZ,X,ORI,ORJ,CREARSLT,LABFILE,SPECFILE - Q:'$L($G(ORDFN)) "0^" - Q:'$L($G(ORDAYS)) "0^" - D NOW^%DTC - S BDT=$$FMADD^XLFDT(%,"-"_ORDAYS,"","","") - K % - Q:'$L($G(BDT)) "0^" - S LABFILE=$$TERMLKUP("SERUM CREATININE",.ORY) - Q:$G(LABFILE)'=60 "0^" - Q:+$D(ORY)<1 "0^" - S SPECFILE=$$TERMLKUP("SERUM SPECIMEN",.ORX) - Q:$G(SPECFILE)'=61 "0^" - Q:+$D(ORX)<1 "0^" - S ORI=0 F S ORI=$O(ORY(ORI)) Q:'ORI I +$G(CREARSLT)<1 D - .S ORJ=0 F S ORJ=$O(ORX(ORJ)) Q:'ORJ I +$G(CREARSLT)<1 D - ..S ORZ=$$LOCL^ORQQLR1(ORDFN,ORI,ORJ) - ..Q:'$L($G(ORZ)) - ..S CDT=$P(ORZ,U,7) - ..I CDT' Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(57) ---> Data Field: MOST RECENT RENAL TEST ABNORMAL FLAG (BOOLEAN) + ; OCXDF(58) ---> Data Field: ABNORMAL RENAL BIOCHEM RESULTS (FREE TEXT) + ; OCXDF(154) --> Data Field: RECENT CONTRAST MEDIA CREATININE DAYS (NUMERIC) + ; OCXDF(155) --> Data Field: RECENT CONTRAST MEDIA CREATININE FLAG (BOOLEAN) + ; + ; Local Extrinsic Functions + ; ABREN( -----------> DETERMINE IF RENAL LAB RESULTS ARE ABNORMAL HIGH OR LOW + ; RECCREAT( --------> RECENT CREATININE LAB PROCEDURE + ; + S OCXDF(57)=$P($$ABREN(OCXDF(37)),"^",1) I $L(OCXDF(57)),(OCXDF(57)) S OCXDF(58)=$P($$ABREN(OCXDF(37)),"^",2),OCXDF(154)=$P($$CMCDAYS^ORKRA(OCXDF(37)),"^",1) D CHK459 + S OCXDF(154)=$P($$CMCDAYS^ORKRA(OCXDF(37)),"^",1) I $L(OCXDF(154)) S OCXDF(155)=$P($$RECCREAT(OCXDF(37),OCXDF(154)),"^",1) I $L(OCXDF(155)),'(OCXDF(155)) D CHK490^OCXOZ0G + Q + ; +CHK459 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK454+16. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; FILE(DFN,129, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: ABNORMAL RENAL RESULTS) + ; + S OCXOERR=$$FILE(DFN,129,"58,154") Q:OCXOERR + Q + ; +CHK466 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK196+18^OCXOZ09. + ; + Q:$G(OCXOERR) + ; + ; Local CHK466 Variables + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(58) ---> Data Field: ABNORMAL RENAL BIOCHEM RESULTS (FREE TEXT) + ; OCXDF(154) --> Data Field: RECENT CONTRAST MEDIA CREATININE DAYS (NUMERIC) + ; + ; Local Extrinsic Functions + ; ABREN( -----------> DETERMINE IF RENAL LAB RESULTS ARE ABNORMAL HIGH OR LOW + ; FILE(DFN,130, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CONTRAST MEDIA ORDER) + ; + S OCXDF(58)=$P($$ABREN(OCXDF(37)),"^",2),OCXDF(154)=$P($$CMCDAYS^ORKRA(OCXDF(37)),"^",1),OCXOERR=$$FILE(DFN,130,"58,154") Q:OCXOERR + Q + ; +CHK471 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK1+34^OCXOZ02. + ; + Q:$G(OCXOERR) + ; + ; Local CHK471 Variables + ; OCXDF(12) ---> Data Field: LAB RESULT (FREE TEXT) + ; OCXDF(34) ---> Data Field: ORDER NUMBER (NUMERIC) + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(96) ---> Data Field: ORDERABLE ITEM NAME (FREE TEXT) + ; OCXDF(113) --> Data Field: LAB TEST ID (NUMERIC) + ; OCXDF(150) --> Data Field: LAB RESULT < THRESHOLD (BOOLEAN) + ; OCXDF(151) --> Data Field: LAB RESULT > THRESHOLD (BOOLEAN) + ; OCXDF(152) --> Data Field: LAB SPECIMEN ID (NUMERIC) + ; + ; Local Extrinsic Functions + ; LABTHRSB( --------> LAB THRESHOLD EXCEEDED BOOLEAN + ; ORDITEM( ---------> GET ORDERABLE ITEM FROM ORDER NUMBER + ; + S OCXDF(151)=$P($$LABTHRSB(OCXDF(113),OCXDF(152),OCXDF(12),">"),"^",1) I $L(OCXDF(151)),(OCXDF(151)),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)) I $L(OCXDF(37)) D CHK477 + S OCXDF(150)=$P($$LABTHRSB(OCXDF(113),OCXDF(152),OCXDF(12),"<"),"^",1) I $L(OCXDF(150)),(OCXDF(150)),$L(OCXDF(34)) S OCXDF(96)=$$ORDITEM(OCXDF(34)) I $L(OCXDF(37)) D CHK484 + Q + ; +CHK477 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK471+19. + ; + Q:$G(OCXOERR) + ; + ; Local CHK477 Variables + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT) + ; + ; Local Extrinsic Functions + ; FILE(DFN,131, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: GREATER THAN LAB THRESHOLD) + ; PATLOC( ----------> PATIENT LOCATION + ; + S OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,131,"12,37,96,113,147,152") Q:OCXOERR + Q + ; +CHK484 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK471+20. + ; + Q:$G(OCXOERR) + ; + ; Local CHK484 Variables + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(147) --> Data Field: PATIENT LOCATION (FREE TEXT) + ; + ; Local Extrinsic Functions + ; FILE(DFN,132, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: LESS THAN LAB THRESHOLD) + ; PATLOC( ----------> PATIENT LOCATION + ; + S OCXDF(147)=$P($$PATLOC(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,132,"12,37,96,113,147,152") Q:OCXOERR + Q + ; +ABREN(DFN) ; Compiler Function: DETERMINE IF RENAL LAB RESULTS ARE ABNORMAL HIGH OR LOW + ; + N OCXFLAG,OCXVAL,OCXLIST,OCXTEST,UNAV,OCXTLIST,OCXTERM,OCXSLIST,OCXSPEC + S (OCXLIST,OCXTLIST)="",UNAV="0^" + S OCXSLIST="" Q:'$$TERMLKUP("SERUM SPECIMEN",.OCXSLIST) UNAV + F OCXTERM="SERUM CREATININE","SERUM UREA NITROGEN" D Q:($L(OCXLIST)>130) + .Q:'$$TERMLKUP(OCXTERM,.OCXTLIST) + .S OCXTEST=0 F S OCXTEST=$O(OCXTLIST(OCXTEST)) Q:'OCXTEST D Q:($L(OCXLIST)>130) + ..S OCXSPEC=0 F S OCXSPEC=$O(OCXSLIST(OCXSPEC)) Q:'OCXSPEC D Q:($L(OCXLIST)>130) + ...S OCXVAL=$$LOCL^ORQQLR1(DFN,OCXTEST,OCXSPEC),OCXFLAG=$P(OCXVAL,U,5) + ...I $L(OCXVAL),((OCXFLAG["H")!(OCXFLAG["L")) D + ....N OCXY S OCXY="" + ....S OCXY=$P(OCXVAL,U,2)_": "_$P(OCXVAL,U,3)_" "_$P(OCXVAL,U,4) + ....S OCXY=OCXY_" "_$S($L(OCXFLAG):"["_OCXFLAG_"]",1:"") + ....S OCXY=OCXY_" "_$$FMTE^XLFDT($P(OCXVAL,U,7),"2P") + ....S:$L(OCXLIST) OCXLIST=OCXLIST_" " S OCXLIST=OCXLIST_OCXY + Q:'$L(OCXLIST) UNAV Q 1_U_OCXLIST + ; + ; +FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. + ; + N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI + S DFN=+$G(DFN),OCXELE=+$G(OCXELE) + ; + Q:'DFN 1 Q:'OCXELE 1 K OCXDATA + ; + S OCXDATA(DFN,OCXELE)=1 + F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D + .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL + ; + M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) + ; + Q 0 + ; +LABTHRSB(OCXLAB,OCXSPEC,OCXRSLT,OCXOP) ; Compiler Function: LAB THRESHOLD EXCEEDED BOOLEAN + ; + Q:'$G(OCXLAB)!'$G(OCXSPEC)!'$G(OCXRSLT)!'$L($G(OCXOP)) 0 + ; + N OCXX,OCXPENT,OCXERR,OCXLABSP,OCXPVAL,OCXEXCD + S OCXEXCD=0,OCXLABSP=OCXLAB_";"_OCXSPEC + D ENVAL^XPAR(.OCXX,"ORB LAB "_OCXOP_" THRESHOLD",OCXLABSP,.OCXERR) + Q:+$G(ORERR)'=0 OCXEXCD + Q:+$G(OCXX)=0 OCXEXCD + S OCXPENT="" F S OCXPENT=$O(OCXX(OCXPENT)) Q:'OCXPENT!OCXEXCD=1 D + .S OCXPVAL=OCXX(OCXPENT,OCXLABSP) + .I $L(OCXPVAL) D + ..I $P(OCXPENT,";",2)="VA(200,",@((+OCXRSLT)_OCXOP_OCXPVAL) D + ...S OCXEXCD=1 + Q OCXEXCD + ; +ORDITEM(OIEN) ; Compiler Function: GET ORDERABLE ITEM FROM ORDER NUMBER + Q:'$G(OIEN) "" + ; + N OITXT,X S OITXT=$$OI^ORQOR2(OIEN) Q:'OITXT "No orderable item found." + S X=$G(^ORD(101.43,+OITXT,0)) Q:'$L(X) "No orderable item found." + Q $P(X,U,1) + ; +PATLOC(DFN) ; Compiler Function: PATIENT LOCATION + ; + N OCXP1,OCXP2 + S OCXP1=$G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",2)) + S OCXP2=$P($G(^TMP("OCXSWAP",$J,"OCXODATA","PV1",3)),"^",1) + I OCXP2 D + .S OCXP2=$P($G(^SC(+OCXP2,0)),"^",1,2) + .I $L($P(OCXP2,"^",2)) S OCXP2=$P(OCXP2,"^",2) + .E S OCXP2=$P(OCXP2,"^",1) + .S:'$L(OCXP2) OCXP2="NO LOC" + I $L(OCXP1),$L(OCXP2) Q OCXP1_"^"_OCXP2 + ; + S OCXP2=$G(^DPT(+$G(DFN),.1)) + I $L(OCXP2) Q "I^"_OCXP2 + Q "O^OUTPT" + ; +RECCREAT(ORDFN,ORDAYS) ;extrinsic function to return most recent + ;SERUM CREATININE within in format: + ; test id^result units flag ref range collection d/t + N BDT,CDT,ORY,ORX,ORZ,X,ORI,ORJ,CREARSLT,LABFILE,SPECFILE + Q:'$L($G(ORDFN)) "0^" + Q:'$L($G(ORDAYS)) "0^" + D NOW^%DTC + S BDT=$$FMADD^XLFDT(%,"-"_ORDAYS,"","","") + K % + Q:'$L($G(BDT)) "0^" + S LABFILE=$$TERMLKUP("SERUM CREATININE",.ORY) + Q:$G(LABFILE)'=60 "0^" + Q:+$D(ORY)<1 "0^" + S SPECFILE=$$TERMLKUP("SERUM SPECIMEN",.ORX) + Q:$G(SPECFILE)'=61 "0^" + Q:+$D(ORX)<1 "0^" + S ORI=0 F S ORI=$O(ORY(ORI)) Q:'ORI I +$G(CREARSLT)<1 D + .S ORJ=0 F S ORJ=$O(ORX(ORJ)) Q:'ORJ I +$G(CREARSLT)<1 D + ..S ORZ=$$LOCL^ORQQLR1(ORDFN,ORI,ORJ) + ..Q:'$L($G(ORZ)) + ..S CDT=$P(ORZ,U,7) + ..I CDT' Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(58) ---> Data Field: ABNORMAL RENAL BIOCHEM RESULTS (FREE TEXT) - ; - ; Local Extrinsic Functions - ; ABREN( -----------> DETERMINE IF RENAL LAB RESULTS ARE ABNORMAL HIGH OR LOW - ; FILE(DFN,133, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: NO CREAT RESULTS W/IN X DAYS) - ; - S OCXDF(58)=$P($$ABREN(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,133,"58,154") Q:OCXOERR - Q - ; -CHK497 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK360+15^OCXOZ0D. - ; - Q:$G(OCXOERR) - ; - ; Local CHK497 Variables - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(74) ---> Data Field: VA DRUG CLASS (FREE TEXT) - ; OCXDF(158) --> Data Field: DUPLICATE OPIOID MEDICATIONS TEXT (FREE TEXT) - ; - ; Local Extrinsic Functions - ; LIST( ------------> IN LIST OPERATOR - ; OPIOID( ----------> OPIOID MEDICATIONS - ; - I $$LIST(OCXDF(74),"OPIOID ANALGESICS,OPIOID ANTAGONIST ANALGESICS") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(158)=$P($$OPIOID(OCXDF(37)),"^",2) D CHK501 - Q - ; -CHK501 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK497+14. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; FILE(DFN,139, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: OPIOID MED ORDER) - ; - S OCXOERR=$$FILE(DFN,139,"158") Q:OCXOERR - Q - ; -CHK505 ; Look through the current environment for valid Event/Elements for this patient. - ; Called from CHK355+14^OCXOZ0C. - ; - Q:$G(OCXOERR) - ; - ; Local CHK505 Variables - ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) - ; OCXDF(130) --> Data Field: CLOZAPINE LAB RESULTS (FREE TEXT) - ; OCXDF(131) --> Data Field: PHARMACY LOCAL ID (FREE TEXT) - ; - ; Local Extrinsic Functions - ; FILE(DFN,140, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: CLOZAPINE ANC >= 1.5 & < 2.0) - ; - S OCXDF(130)=$P($$CLOZLABS^ORKLR(OCXDF(37),"",OCXDF(131)),"^",4),OCXOERR=$$FILE(DFN,140,"130") Q:OCXOERR - Q - ; -EL24 ; Examine every rule that involves Element #24 [HL7 LAB TEST RESULTS CRITICAL] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R3R1A^OCXOZ0I ; Check Relation #1 in Rule #3 'CRITICAL LAB RESULTS' - Q - ; -EL105 ; Examine every rule that involves Element #105 [HL7 LAB ORDER RESULTS CRITICAL] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R3R2A^OCXOZ0J ; Check Relation #2 in Rule #3 'CRITICAL LAB RESULTS' - Q - ; -EL44 ; Examine every rule that involves Element #44 [ORDER FLAGGED] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R5R1A^OCXOZ0J ; Check Relation #1 in Rule #5 'ORDER FLAGGED FOR CLARIFICATION' - Q - ; -EL134 ; Examine every rule that involves Element #134 [ORDER UNFLAGGED] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R5R2A^OCXOZ0K ; Check Relation #2 in Rule #5 'ORDER FLAGGED FOR CLARIFICATION' - Q - ; -EL45 ; Examine every rule that involves Element #45 [ORDER REQUIRES CHART SIGNATURE] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R6R1A^OCXOZ0K ; Check Relation #1 in Rule #6 'ORDER REQUIRES CHART SIGNATURE' - Q - ; -EL21 ; Examine every rule that involves Element #21 [PATIENT ADMISSION] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R7R1A^OCXOZ0K ; Check Relation #1 in Rule #7 'PATIENT ADMISSION' - Q - ; -EL31 ; Examine every rule that involves Element #31 [RADIOLOGY ORDER CANCELLED] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R11R1A^OCXOZ0L ; Check Relation #1 in Rule #11 'IMAGING REQUEST CANCELLED/HELD' - Q - ; -EL100 ; Examine every rule that involves Element #100 [CANCELED BY NON-ORIG ORDERING PROVIDER] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R11R1A^OCXOZ0L ; Check Relation #1 in Rule #11 'IMAGING REQUEST CANCELLED/HELD' - D R11R2A^OCXOZ0L ; Check Relation #2 in Rule #11 'IMAGING REQUEST CANCELLED/HELD' - D R11R3A^OCXOZ0M ; Check Relation #3 in Rule #11 'IMAGING REQUEST CANCELLED/HELD' - D R35R1A^OCXOZ0Q ; Check Relation #1 in Rule #35 'LAB ORDER CANCELLED' - Q - ; -EL30 ; Examine every rule that involves Element #30 [RADIOLOGY ORDER PUT ON-HOLD] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R11R2A^OCXOZ0L ; Check Relation #2 in Rule #11 'IMAGING REQUEST CANCELLED/HELD' - Q - ; -EL32 ; Examine every rule that involves Element #32 [RADIOLOGY ORDER DISCONTINUED] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R11R3A^OCXOZ0M ; Check Relation #3 in Rule #11 'IMAGING REQUEST CANCELLED/HELD' - Q - ; -EL46 ; Examine every rule that involves Element #46 [SERVICE ORDER REQUIRES CHART SIGNATURE] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R16R1A^OCXOZ0M ; Check Relation #1 in Rule #16 'SERVICE ORDER REQUIRES CHART SIGNATURE' - Q - ; -EL76 ; Examine every rule that involves Element #76 [STAT LAB RESULT] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R18R1A^OCXOZ0M ; Check Relation #1 in Rule #18 'STAT RESULTS AVAILABLE' - Q - ; -EL75 ; Examine every rule that involves Element #75 [STAT IMAGING RESULT] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R18R2A^OCXOZ0N ; Check Relation #2 in Rule #18 'STAT RESULTS AVAILABLE' - Q - ; -EL110 ; Examine every rule that involves Element #110 [STAT CONSULT RESULT] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R18R3A^OCXOZ0N ; Check Relation #3 in Rule #18 'STAT RESULTS AVAILABLE' - Q - ; -ABREN(DFN) ; Compiler Function: DETERMINE IF RENAL LAB RESULTS ARE ABNORMAL HIGH OR LOW - ; - N OCXFLAG,OCXVAL,OCXLIST,OCXTEST,UNAV,OCXTLIST,OCXTERM,OCXSLIST,OCXSPEC - S (OCXLIST,OCXTLIST)="",UNAV="0^" - S OCXSLIST="" Q:'$$TERMLKUP("SERUM SPECIMEN",.OCXSLIST) UNAV - F OCXTERM="SERUM CREATININE","SERUM UREA NITROGEN" D Q:($L(OCXLIST)>130) - .Q:'$$TERMLKUP(OCXTERM,.OCXTLIST) - .S OCXTEST=0 F S OCXTEST=$O(OCXTLIST(OCXTEST)) Q:'OCXTEST D Q:($L(OCXLIST)>130) - ..S OCXSPEC=0 F S OCXSPEC=$O(OCXSLIST(OCXSPEC)) Q:'OCXSPEC D Q:($L(OCXLIST)>130) - ...S OCXVAL=$$LOCL^ORQQLR1(DFN,OCXTEST,OCXSPEC),OCXFLAG=$P(OCXVAL,U,5) - ...I $L(OCXVAL),((OCXFLAG["H")!(OCXFLAG["L")) D - ....N OCXY S OCXY="" - ....S OCXY=$P(OCXVAL,U,2)_": "_$P(OCXVAL,U,3)_" "_$P(OCXVAL,U,4) - ....S OCXY=OCXY_" "_$S($L(OCXFLAG):"["_OCXFLAG_"]",1:"") - ....S OCXY=OCXY_" "_$$FMTE^XLFDT($P(OCXVAL,U,7),"2P") - ....S:$L(OCXLIST) OCXLIST=OCXLIST_" " S OCXLIST=OCXLIST_OCXY - Q:'$L(OCXLIST) UNAV Q 1_U_OCXLIST - ; - ; -FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. - ; - N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI - S DFN=+$G(DFN),OCXELE=+$G(OCXELE) - ; - Q:'DFN 1 Q:'OCXELE 1 K OCXDATA - ; - S OCXDATA(DFN,OCXELE)=1 - F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D - .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL - ; - M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) - ; - Q 0 - ; -LIST(DATA,LIST) ; IS THE DATA FIELD IN THE LIST - ; - S:'($E(LIST,1)=",") LIST=","_LIST S:'($E(LIST,$L(LIST))=",") LIST=LIST_"," S DATA=","_DATA_"," - Q (LIST[DATA) - ; -OPIOID(ORPT) ;determine if pat is receiving opioid med - ; rtn 1^opioid drug 1, opioid drug 2, opioid drug3, ... - N ORDG,ORTN,ORNUM,ORDI,ORDCLAS,ORDERS,ORTEXT,DUP,DUPI,DUPJ,DUPLEN - S ORDG=0,ORTN=0,DUPI=0,DUPLEN=20 - K ^TMP("ORR",$J) - S ORDG=$O(^ORD(100.98,"B","RX",ORDG)) - D EN^ORQ1(ORPT_";DPT(",ORDG,2,"","","",0,0) - N J,HOR,SEQ,X S J=1,HOR=0,SEQ=0 - S HOR=$O(^TMP("ORR",$J,HOR)) Q:+HOR<1 ORTN - F S SEQ=$O(^TMP("ORR",$J,HOR,SEQ)) Q:+SEQ<1 D - .S X=^TMP("ORR",$J,HOR,SEQ) - .S ORNUM=+$P(X,";") - .Q:ORNUM=+$G(ORIFN) ;quit if dup med order # = current order # - .S ORDI=$$VALUE^ORCSAVE2(ORNUM,"DRUG") - .I +$G(ORDI)>0 D - ..S ORDCLAS=$P(^PSDRUG(ORDI,0),U,2) ;va drug class - ..I ($G(ORDCLAS)="CN101")!($G(ORDCLAS)="CN102") D ;opioid classes - ...S ORTEXT=$$FULLTEXT^ORQOR1(ORNUM) - ...S ORTEXT=$P(ORTEXT,U)_" ["_$P(ORTEXT,U,2)_"]" - ...S DUPI=DUPI+1,DUP(DUPI)=" ["_DUPI_"] "_ORTEXT - ...S ORTN=1 - I DUPI>0 D - .S DUPLEN=$P(215/DUPI,".") - .F DUPJ=1:1:DUPI D - ..I DUPJ=1 S ORDERS=$E(DUP(DUPJ),1,DUPLEN) - ..E S ORDERS=ORDERS_", "_$E(DUP(DUPJ),1,DUPLEN) - K ^TMP("ORR",$J) - Q ORTN_U_$G(ORDERS) - ; -TERMLKUP(OCXTERM,OCXLIST) ; - Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST) - ; +OCXOZ0G ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; + ; *************************************************************** + ; ** Warning: This routine is automatically generated by the ** + ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** + ; ** will be lost the next time the rule compiler executes. ** + ; *************************************************************** + ; + Q + ; +CHK490 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK454+17^OCXOZ0F. + ; + Q:$G(OCXOERR) + ; + ; Local CHK490 Variables + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(58) ---> Data Field: ABNORMAL RENAL BIOCHEM RESULTS (FREE TEXT) + ; + ; Local Extrinsic Functions + ; ABREN( -----------> DETERMINE IF RENAL LAB RESULTS ARE ABNORMAL HIGH OR LOW + ; FILE(DFN,133, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: NO CREAT RESULTS W/IN X DAYS) + ; + S OCXDF(58)=$P($$ABREN(OCXDF(37)),"^",2),OCXOERR=$$FILE(DFN,133,"58,154") Q:OCXOERR + Q + ; +CHK505 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK362+15^OCXOZ0D. + ; + Q:$G(OCXOERR) + ; + ; Local CHK505 Variables + ; OCXDF(37) ---> Data Field: PATIENT IEN (NUMERIC) + ; OCXDF(74) ---> Data Field: VA DRUG CLASS (FREE TEXT) + ; OCXDF(158) --> Data Field: DUPLICATE OPIOID MEDICATIONS TEXT (FREE TEXT) + ; + ; Local Extrinsic Functions + ; LIST( ------------> IN LIST OPERATOR + ; OPIOID( ----------> OPIOID MEDICATIONS + ; + I $$LIST(OCXDF(74),"OPIOID ANALGESICS,OPIOID ANTAGONIST ANALGESICS") S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXDF(158)=$P($$OPIOID(OCXDF(37)),"^",2) D CHK509 + Q + ; +CHK509 ; Look through the current environment for valid Event/Elements for this patient. + ; Called from CHK505+14. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; FILE(DFN,139, ----> FILE DATA IN PATIENT ACTIVE DATA FILE (Event/Element: OPIOID MED ORDER) + ; + S OCXOERR=$$FILE(DFN,139,"158") Q:OCXOERR + Q + ; +EL24 ; Examine every rule that involves Element #24 [HL7 LAB TEST RESULTS CRITICAL] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R3R1A^OCXOZ0I ; Check Relation #1 in Rule #3 'CRITICAL LAB RESULTS' + Q + ; +EL105 ; Examine every rule that involves Element #105 [HL7 LAB ORDER RESULTS CRITICAL] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R3R2A^OCXOZ0J ; Check Relation #2 in Rule #3 'CRITICAL LAB RESULTS' + Q + ; +EL44 ; Examine every rule that involves Element #44 [ORDER FLAGGED] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R5R1A^OCXOZ0J ; Check Relation #1 in Rule #5 'ORDER FLAGGED FOR CLARIFICATION' + Q + ; +EL134 ; Examine every rule that involves Element #134 [ORDER UNFLAGGED] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R5R2A^OCXOZ0K ; Check Relation #2 in Rule #5 'ORDER FLAGGED FOR CLARIFICATION' + Q + ; +EL45 ; Examine every rule that involves Element #45 [ORDER REQUIRES CHART SIGNATURE] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R6R1A^OCXOZ0K ; Check Relation #1 in Rule #6 'ORDER REQUIRES CHART SIGNATURE' + Q + ; +EL21 ; Examine every rule that involves Element #21 [PATIENT ADMISSION] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R7R1A^OCXOZ0K ; Check Relation #1 in Rule #7 'PATIENT ADMISSION' + Q + ; +EL31 ; Examine every rule that involves Element #31 [RADIOLOGY ORDER CANCELLED] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R11R1A^OCXOZ0L ; Check Relation #1 in Rule #11 'IMAGING REQUEST CANCELLED/HELD' + Q + ; +EL100 ; Examine every rule that involves Element #100 [CANCELED BY NON-ORIG ORDERING PROVIDER] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R11R1A^OCXOZ0L ; Check Relation #1 in Rule #11 'IMAGING REQUEST CANCELLED/HELD' + D R11R2A^OCXOZ0L ; Check Relation #2 in Rule #11 'IMAGING REQUEST CANCELLED/HELD' + D R11R3A^OCXOZ0M ; Check Relation #3 in Rule #11 'IMAGING REQUEST CANCELLED/HELD' + D R35R1A^OCXOZ0Q ; Check Relation #1 in Rule #35 'LAB ORDER CANCELLED' + Q + ; +EL30 ; Examine every rule that involves Element #30 [RADIOLOGY ORDER PUT ON-HOLD] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R11R2A^OCXOZ0L ; Check Relation #2 in Rule #11 'IMAGING REQUEST CANCELLED/HELD' + Q + ; +EL32 ; Examine every rule that involves Element #32 [RADIOLOGY ORDER DISCONTINUED] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R11R3A^OCXOZ0M ; Check Relation #3 in Rule #11 'IMAGING REQUEST CANCELLED/HELD' + Q + ; +EL46 ; Examine every rule that involves Element #46 [SERVICE ORDER REQUIRES CHART SIGNATURE] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R16R1A^OCXOZ0M ; Check Relation #1 in Rule #16 'SERVICE ORDER REQUIRES CHART SIGNATURE' + Q + ; +EL76 ; Examine every rule that involves Element #76 [STAT LAB RESULT] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R18R1A^OCXOZ0M ; Check Relation #1 in Rule #18 'STAT RESULTS AVAILABLE' + Q + ; +EL75 ; Examine every rule that involves Element #75 [STAT IMAGING RESULT] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R18R2A^OCXOZ0N ; Check Relation #2 in Rule #18 'STAT RESULTS AVAILABLE' + Q + ; +EL110 ; Examine every rule that involves Element #110 [STAT CONSULT RESULT] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R18R3A^OCXOZ0N ; Check Relation #3 in Rule #18 'STAT RESULTS AVAILABLE' + Q + ; +EL56 ; Examine every rule that involves Element #56 [PATIENT DISCHARGE] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R19R1A^OCXOZ0N ; Check Relation #1 in Rule #19 'PATIENT DISCHARGE' + Q + ; +EL47 ; Examine every rule that involves Element #47 [ORDER REQUIRES CO-SIGNATURE] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R22R1A^OCXOZ0O ; Check Relation #1 in Rule #22 'ORDER REQUIRES CO-SIGNATURE' + Q + ; +ABREN(DFN) ; Compiler Function: DETERMINE IF RENAL LAB RESULTS ARE ABNORMAL HIGH OR LOW + ; + N OCXFLAG,OCXVAL,OCXLIST,OCXTEST,UNAV,OCXTLIST,OCXTERM,OCXSLIST,OCXSPEC + S (OCXLIST,OCXTLIST)="",UNAV="0^" + S OCXSLIST="" Q:'$$TERMLKUP("SERUM SPECIMEN",.OCXSLIST) UNAV + F OCXTERM="SERUM CREATININE","SERUM UREA NITROGEN" D Q:($L(OCXLIST)>130) + .Q:'$$TERMLKUP(OCXTERM,.OCXTLIST) + .S OCXTEST=0 F S OCXTEST=$O(OCXTLIST(OCXTEST)) Q:'OCXTEST D Q:($L(OCXLIST)>130) + ..S OCXSPEC=0 F S OCXSPEC=$O(OCXSLIST(OCXSPEC)) Q:'OCXSPEC D Q:($L(OCXLIST)>130) + ...S OCXVAL=$$LOCL^ORQQLR1(DFN,OCXTEST,OCXSPEC),OCXFLAG=$P(OCXVAL,U,5) + ...I $L(OCXVAL),((OCXFLAG["H")!(OCXFLAG["L")) D + ....N OCXY S OCXY="" + ....S OCXY=$P(OCXVAL,U,2)_": "_$P(OCXVAL,U,3)_" "_$P(OCXVAL,U,4) + ....S OCXY=OCXY_" "_$S($L(OCXFLAG):"["_OCXFLAG_"]",1:"") + ....S OCXY=OCXY_" "_$$FMTE^XLFDT($P(OCXVAL,U,7),"2P") + ....S:$L(OCXLIST) OCXLIST=OCXLIST_" " S OCXLIST=OCXLIST_OCXY + Q:'$L(OCXLIST) UNAV Q 1_U_OCXLIST + ; + ; +FILE(DFN,OCXELE,OCXDFL) ; This Local Extrinsic Function logs a validated event/element. + ; + N OCXTIMN,OCXTIML,OCXTIMT1,OCXTIMT2,OCXDATA,OCXPC,OCXPC,OCXVAL,OCXSUB,OCXDFI + S DFN=+$G(DFN),OCXELE=+$G(OCXELE) + ; + Q:'DFN 1 Q:'OCXELE 1 K OCXDATA + ; + S OCXDATA(DFN,OCXELE)=1 + F OCXPC=1:1:$L(OCXDFL,",") S OCXDFI=$P(OCXDFL,",",OCXPC) I OCXDFI D + .S OCXVAL=$G(OCXDF(+OCXDFI)),OCXDATA(DFN,OCXELE,+OCXDFI)=OCXVAL + ; + M ^TMP("OCXCHK",$J,DFN)=OCXDATA(DFN) + ; + Q 0 + ; +LIST(DATA,LIST) ; IS THE DATA FIELD IN THE LIST + ; + S:'($E(LIST,1)=",") LIST=","_LIST S:'($E(LIST,$L(LIST))=",") LIST=LIST_"," S DATA=","_DATA_"," + Q (LIST[DATA) + ; +OPIOID(ORPT) ;determine if pat is receiving opioid med + ; rtn 1^opioid drug 1, opioid drug 2, opioid drug3, ... + N ORDG,ORTN,ORNUM,ORDI,ORDCLAS,ORDERS,ORTEXT,DUP,DUPI,DUPJ,DUPLEN + S ORDG=0,ORTN=0,DUPI=0,DUPLEN=20 + K ^TMP("ORR",$J) + S ORDG=$O(^ORD(100.98,"B","RX",ORDG)) + D EN^ORQ1(ORPT_";DPT(",ORDG,2,"","","",0,0) + N J,HOR,SEQ,X S J=1,HOR=0,SEQ=0 + S HOR=$O(^TMP("ORR",$J,HOR)) Q:+HOR<1 ORTN + F S SEQ=$O(^TMP("ORR",$J,HOR,SEQ)) Q:+SEQ<1 D + .S X=^TMP("ORR",$J,HOR,SEQ) + .S ORNUM=+$P(X,";") + .Q:ORNUM=+$G(ORIFN) ;quit if dup med order # = current order # + .S ORDI=$$VALUE^ORCSAVE2(ORNUM,"DRUG") + .I +$G(ORDI)>0 D + ..S ORDCLAS=$P(^PSDRUG(ORDI,0),U,2) ;va drug class + ..I ($G(ORDCLAS)="CN101")!($G(ORDCLAS)="CN102") D ;opioid classes + ...S ORTEXT=$$FULLTEXT^ORQOR1(ORNUM) + ...S ORTEXT=$P(ORTEXT,U)_" ["_$P(ORTEXT,U,2)_"]" + ...S DUPI=DUPI+1,DUP(DUPI)=" ["_DUPI_"] "_ORTEXT + ...S ORTN=1 + I DUPI>0 D + .S DUPLEN=$P(215/DUPI,".") + .F DUPJ=1:1:DUPI D + ..I DUPJ=1 S ORDERS=$E(DUP(DUPJ),1,DUPLEN) + ..E S ORDERS=ORDERS_", "_$E(DUP(DUPJ),1,DUPLEN) + K ^TMP("ORR",$J) + Q ORTN_U_$G(ORDERS) + ; +TERMLKUP(OCXTERM,OCXLIST) ; + Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST) + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0H.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0H.m index bbfb9442..a546b66e 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0H.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0H.m @@ -1,288 +1,289 @@ -OCXOZ0H ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; - ; *************************************************************** - ; ** Warning: This routine is automatically generated by the ** - ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** - ; ** will be lost the next time the rule compiler executes. ** - ; *************************************************************** - ; - Q - ; -EL56 ; Examine every rule that involves Element #56 [PATIENT DISCHARGE] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R19R1A^OCXOZ0N ; Check Relation #1 in Rule #19 'PATIENT DISCHARGE' - Q - ; -EL47 ; Examine every rule that involves Element #47 [ORDER REQUIRES CO-SIGNATURE] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R22R1A^OCXOZ0O ; Check Relation #1 in Rule #22 'ORDER REQUIRES CO-SIGNATURE' - Q - ; -EL5 ; Examine every rule that involves Element #5 [HL7 FINAL LAB RESULT] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R24R1A^OCXOZ0O ; Check Relation #1 in Rule #24 'ORDERER FLAGGED RESULTS AVAILABLE' - D R66R1A^OCXOZ0Z ; Check Relation #1 in Rule #66 'LAB RESULTS' - D R69R1A^OCXOZ11 ; Check Relation #1 in Rule #69 'LAB THRESHOLD' - Q - ; -EL49 ; Examine every rule that involves Element #49 [ORDER FLAGGED FOR RESULTS] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R24R1A^OCXOZ0O ; Check Relation #1 in Rule #24 'ORDERER FLAGGED RESULTS AVAILABLE' - Q - ; -EL55 ; Examine every rule that involves Element #55 [CONSULT FINAL RESULTS] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R24R1A^OCXOZ0O ; Check Relation #1 in Rule #24 'ORDERER FLAGGED RESULTS AVAILABLE' - Q - ; -EL101 ; Examine every rule that involves Element #101 [HL7 FINAL IMAGING RESULT] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R24R1A^OCXOZ0O ; Check Relation #1 in Rule #24 'ORDERER FLAGGED RESULTS AVAILABLE' - Q - ; -EL60 ; Examine every rule that involves Element #60 [NEW OBR STAT ORDER] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R28R1A^OCXOZ0P ; Check Relation #1 in Rule #28 'STAT ORDER PLACED' - Q - ; -EL61 ; Examine every rule that involves Element #61 [NEW ORC STAT ORDER] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R28R1A^OCXOZ0P ; Check Relation #1 in Rule #28 'STAT ORDER PLACED' - Q - ; -EL42 ; Examine every rule that involves Element #42 [PATIENT TRANSFERRED FROM PSYCH WARD] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R32R1A^OCXOZ0P ; Check Relation #1 in Rule #32 'PATIENT TRANSFERRED FROM PSYCHIATRY TO ANOTHER UNIT' - Q - ; -EL20 ; Examine every rule that involves Element #20 [HL7 LAB ORDER CANCELLED] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R35R1A^OCXOZ0Q ; Check Relation #1 in Rule #35 'LAB ORDER CANCELLED' - Q - ; -EL40 ; Examine every rule that involves Element #40 [HL7 LAB REQUEST CANCELLED] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R35R1A^OCXOZ0Q ; Check Relation #1 in Rule #35 'LAB ORDER CANCELLED' - Q - ; -EL6 ; Examine every rule that involves Element #6 [HL7 NEW OERR ORDER] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R38R1A^OCXOZ0Q ; Check Relation #1 in Rule #38 'NEW ORDER PLACED' - Q - ; -EL126 ; Examine every rule that involves Element #126 [HL7 DCED OERR ORDER] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R38R2A^OCXOZ0Q ; Check Relation #2 in Rule #38 'NEW ORDER PLACED' - Q - ; -EL23 ; Examine every rule that involves Element #23 [HL7 LAB ORDER RESULTS ABNORMAL] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R42R1A^OCXOZ0R ; Check Relation #1 in Rule #42 'ABNORMAL LAB RESULTS' - Q - ; -EL103 ; Examine every rule that involves Element #103 [HL7 LAB TEST RESULTS ABNORMAL] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R42R2A^OCXOZ0R ; Check Relation #2 in Rule #42 'ABNORMAL LAB RESULTS' - Q - ; -EL48 ; Examine every rule that involves Element #48 [ORDER REQUIRES ELECTRONIC SIGNATURE] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R44R1A^OCXOZ0R ; Check Relation #1 in Rule #44 'ORDER REQUIRES ELECTRONIC SIGNATURE' - Q - ; -EL58 ; Examine every rule that involves Element #58 [NEW SITE FLAGGED ORDER] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R48R1A^OCXOZ0S ; Check Relation #1 in Rule #48 'SITE FLAGGED ORDER' - D R48R2A^OCXOZ0S ; Check Relation #2 in Rule #48 'SITE FLAGGED ORDER' - Q - ; -EL127 ; Examine every rule that involves Element #127 [INPATIENT] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R48R1A^OCXOZ0S ; Check Relation #1 in Rule #48 'SITE FLAGGED ORDER' - D R49R1A^OCXOZ0T ; Check Relation #1 in Rule #49 'SITE FLAGGED RESULT' - Q - ; -EL128 ; Examine every rule that involves Element #128 [OUTPATIENT] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R48R2A^OCXOZ0S ; Check Relation #2 in Rule #48 'SITE FLAGGED ORDER' - D R49R2A^OCXOZ0U ; Check Relation #2 in Rule #49 'SITE FLAGGED RESULT' - Q - ; -EL59 ; Examine every rule that involves Element #59 [SITE FLAGGED FINAL LAB RESULT] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R49R1A^OCXOZ0T ; Check Relation #1 in Rule #49 'SITE FLAGGED RESULT' - D R49R2A^OCXOZ0U ; Check Relation #2 in Rule #49 'SITE FLAGGED RESULT' - Q - ; -EL102 ; Examine every rule that involves Element #102 [SITE FLAGGED FINAL IMAGING RESULT] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R49R1A^OCXOZ0T ; Check Relation #1 in Rule #49 'SITE FLAGGED RESULT' - D R49R2A^OCXOZ0U ; Check Relation #2 in Rule #49 'SITE FLAGGED RESULT' - Q - ; -EL109 ; Examine every rule that involves Element #109 [SITE FLAGGED FINAL CONSULT RESULT] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R49R1A^OCXOZ0T ; Check Relation #1 in Rule #49 'SITE FLAGGED RESULT' - D R49R2A^OCXOZ0U ; Check Relation #2 in Rule #49 'SITE FLAGGED RESULT' - Q - ; -EL129 ; Examine every rule that involves Element #129 [ABNORMAL RENAL RESULTS] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R50R1A^OCXOZ0U ; Check Relation #1 in Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHECK' - Q - ; -EL130 ; Examine every rule that involves Element #130 [CONTRAST MEDIA ORDER] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R50R1A^OCXOZ0U ; Check Relation #1 in Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHECK' - D R50R2A^OCXOZ0V ; Check Relation #2 in Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHECK' - Q - ; -EL133 ; Examine every rule that involves Element #133 [NO CREAT RESULTS W/IN X DAYS] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R50R2A^OCXOZ0V ; Check Relation #2 in Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHECK' - Q - ; -EL63 ; Examine every rule that involves Element #63 [PATIENT HAS RECENT CHOLECYSTOGRAM] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R51R1A^OCXOZ0V ; Check Relation #1 in Rule #51 'RECENT CHOLECYSTOGRAM ORDER' - Q - ; -EL64 ; Examine every rule that involves Element #64 [PHARMACY PATIENT OVER 65] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R53R1A^OCXOZ0V ; Check Relation #1 in Rule #53 'RENAL FUNCTIONS OVER AGE 65 CHECK' - Q - ; -EL65 ; Examine every rule that involves Element #65 [SESSION ORDER FOR ANGIOGRAM] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R54R1A^OCXOZ0V ; Check Relation #1 in Rule #54 'CONCURRENT LAB ORDERS FOR ANGIOGRAM, CATH - PERIPHERAL' - Q - ; -EL66 ; Examine every rule that involves Element #66 [CONTRAST MEDIA ALLERGY] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R55R1A^OCXOZ0V ; Check Relation #1 in Rule #55 'ALLERGY - CONTRAST MEDIA REACTION' - Q - ; -EL67 ; Examine every rule that involves Element #67 [RECENT BARIUM STUDY ORDERED] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R56R1A^OCXOZ0W ; Check Relation #1 in Rule #56 'RECENT BARIUM STUDY' - Q - ; -EL116 ; Examine every rule that involves Element #116 [CLOZAPINE DRUG SELECTED] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R57R1A^OCXOZ0W ; Check Relation #1 in Rule #57 'CLOZAPINE' - D R57R2A^OCXOZ0W ; Check Relation #2 in Rule #57 'CLOZAPINE' - D R57R3A^OCXOZ0W ; Check Relation #3 in Rule #57 'CLOZAPINE' - D R57R4A^OCXOZ0W ; Check Relation #4 in Rule #57 'CLOZAPINE' - Q - ; -EL117 ; Examine every rule that involves Element #117 [CLOZAPINE NO ANC W/IN 7 DAYS] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R57R1A^OCXOZ0W ; Check Relation #1 in Rule #57 'CLOZAPINE' - Q - ; -EL118 ; Examine every rule that involves Element #118 [CLOZAPINE NO WBC W/IN 7 DAYS] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R57R1A^OCXOZ0W ; Check Relation #1 in Rule #57 'CLOZAPINE' - Q - ; +OCXOZ0H ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; + ; *************************************************************** + ; ** Warning: This routine is automatically generated by the ** + ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** + ; ** will be lost the next time the rule compiler executes. ** + ; *************************************************************** + ; + Q + ; +EL5 ; Examine every rule that involves Element #5 [HL7 FINAL LAB RESULT] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R24R1A^OCXOZ0O ; Check Relation #1 in Rule #24 'ORDERER FLAGGED RESULTS AVAILABLE' + D R66R1A^OCXOZ0Z ; Check Relation #1 in Rule #66 'LAB RESULTS' + D R69R1A^OCXOZ11 ; Check Relation #1 in Rule #69 'LAB THRESHOLD' + Q + ; +EL49 ; Examine every rule that involves Element #49 [ORDER FLAGGED FOR RESULTS] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R24R1A^OCXOZ0O ; Check Relation #1 in Rule #24 'ORDERER FLAGGED RESULTS AVAILABLE' + Q + ; +EL55 ; Examine every rule that involves Element #55 [CONSULT FINAL RESULTS] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R24R1A^OCXOZ0O ; Check Relation #1 in Rule #24 'ORDERER FLAGGED RESULTS AVAILABLE' + Q + ; +EL101 ; Examine every rule that involves Element #101 [HL7 FINAL IMAGING RESULT] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R24R1A^OCXOZ0O ; Check Relation #1 in Rule #24 'ORDERER FLAGGED RESULTS AVAILABLE' + Q + ; +EL60 ; Examine every rule that involves Element #60 [NEW OBR STAT ORDER] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R28R1A^OCXOZ0P ; Check Relation #1 in Rule #28 'STAT ORDER PLACED' + Q + ; +EL61 ; Examine every rule that involves Element #61 [NEW ORC STAT ORDER] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R28R1A^OCXOZ0P ; Check Relation #1 in Rule #28 'STAT ORDER PLACED' + Q + ; +EL42 ; Examine every rule that involves Element #42 [PATIENT TRANSFERRED FROM PSYCH WARD] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R32R1A^OCXOZ0P ; Check Relation #1 in Rule #32 'PATIENT TRANSFERRED FROM PSYCHIATRY TO ANOTHER UNIT' + Q + ; +EL20 ; Examine every rule that involves Element #20 [HL7 LAB ORDER CANCELLED] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R35R1A^OCXOZ0Q ; Check Relation #1 in Rule #35 'LAB ORDER CANCELLED' + Q + ; +EL40 ; Examine every rule that involves Element #40 [HL7 LAB REQUEST CANCELLED] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R35R1A^OCXOZ0Q ; Check Relation #1 in Rule #35 'LAB ORDER CANCELLED' + Q + ; +EL6 ; Examine every rule that involves Element #6 [HL7 NEW OERR ORDER] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R38R1A^OCXOZ0Q ; Check Relation #1 in Rule #38 'NEW ORDER PLACED' + Q + ; +EL126 ; Examine every rule that involves Element #126 [HL7 DCED OERR ORDER] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R38R2A^OCXOZ0Q ; Check Relation #2 in Rule #38 'NEW ORDER PLACED' + Q + ; +EL23 ; Examine every rule that involves Element #23 [HL7 LAB ORDER RESULTS ABNORMAL] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R42R1A^OCXOZ0R ; Check Relation #1 in Rule #42 'ABNORMAL LAB RESULTS' + Q + ; +EL103 ; Examine every rule that involves Element #103 [HL7 LAB TEST RESULTS ABNORMAL] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R42R2A^OCXOZ0R ; Check Relation #2 in Rule #42 'ABNORMAL LAB RESULTS' + Q + ; +EL48 ; Examine every rule that involves Element #48 [ORDER REQUIRES ELECTRONIC SIGNATURE] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R44R1A^OCXOZ0R ; Check Relation #1 in Rule #44 'ORDER REQUIRES ELECTRONIC SIGNATURE' + Q + ; +EL58 ; Examine every rule that involves Element #58 [NEW SITE FLAGGED ORDER] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R48R1A^OCXOZ0S ; Check Relation #1 in Rule #48 'SITE FLAGGED ORDER' + D R48R2A^OCXOZ0S ; Check Relation #2 in Rule #48 'SITE FLAGGED ORDER' + Q + ; +EL127 ; Examine every rule that involves Element #127 [INPATIENT] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R48R1A^OCXOZ0S ; Check Relation #1 in Rule #48 'SITE FLAGGED ORDER' + D R49R1A^OCXOZ0T ; Check Relation #1 in Rule #49 'SITE FLAGGED RESULT' + Q + ; +EL128 ; Examine every rule that involves Element #128 [OUTPATIENT] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R48R2A^OCXOZ0S ; Check Relation #2 in Rule #48 'SITE FLAGGED ORDER' + D R49R2A^OCXOZ0U ; Check Relation #2 in Rule #49 'SITE FLAGGED RESULT' + Q + ; +EL59 ; Examine every rule that involves Element #59 [SITE FLAGGED FINAL LAB RESULT] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R49R1A^OCXOZ0T ; Check Relation #1 in Rule #49 'SITE FLAGGED RESULT' + D R49R2A^OCXOZ0U ; Check Relation #2 in Rule #49 'SITE FLAGGED RESULT' + Q + ; +EL102 ; Examine every rule that involves Element #102 [SITE FLAGGED FINAL IMAGING RESULT] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R49R1A^OCXOZ0T ; Check Relation #1 in Rule #49 'SITE FLAGGED RESULT' + D R49R2A^OCXOZ0U ; Check Relation #2 in Rule #49 'SITE FLAGGED RESULT' + Q + ; +EL109 ; Examine every rule that involves Element #109 [SITE FLAGGED FINAL CONSULT RESULT] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R49R1A^OCXOZ0T ; Check Relation #1 in Rule #49 'SITE FLAGGED RESULT' + D R49R2A^OCXOZ0U ; Check Relation #2 in Rule #49 'SITE FLAGGED RESULT' + Q + ; +EL129 ; Examine every rule that involves Element #129 [ABNORMAL RENAL RESULTS] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R50R1A^OCXOZ0U ; Check Relation #1 in Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHECK' + Q + ; +EL130 ; Examine every rule that involves Element #130 [CONTRAST MEDIA ORDER] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R50R1A^OCXOZ0U ; Check Relation #1 in Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHECK' + D R50R2A^OCXOZ0V ; Check Relation #2 in Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHECK' + Q + ; +EL133 ; Examine every rule that involves Element #133 [NO CREAT RESULTS W/IN X DAYS] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R50R2A^OCXOZ0V ; Check Relation #2 in Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHECK' + Q + ; +EL63 ; Examine every rule that involves Element #63 [PATIENT HAS RECENT CHOLECYSTOGRAM] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R51R1A^OCXOZ0V ; Check Relation #1 in Rule #51 'RECENT CHOLECYSTOGRAM ORDER' + Q + ; +EL64 ; Examine every rule that involves Element #64 [PHARMACY PATIENT OVER 65] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R53R1A^OCXOZ0V ; Check Relation #1 in Rule #53 'RENAL FUNCTIONS OVER AGE 65 CHECK' + Q + ; +EL65 ; Examine every rule that involves Element #65 [SESSION ORDER FOR ANGIOGRAM] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R54R1A^OCXOZ0V ; Check Relation #1 in Rule #54 'CONCURRENT LAB ORDERS FOR ANGIOGRAM, CATH - PERIPHERAL' + Q + ; +EL66 ; Examine every rule that involves Element #66 [CONTRAST MEDIA ALLERGY] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R55R1A^OCXOZ0V ; Check Relation #1 in Rule #55 'ALLERGY - CONTRAST MEDIA REACTION' + Q + ; +EL67 ; Examine every rule that involves Element #67 [RECENT BARIUM STUDY ORDERED] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R56R1A^OCXOZ0W ; Check Relation #1 in Rule #56 'RECENT BARIUM STUDY' + Q + ; +EL114 ; Examine every rule that involves Element #114 [CLOZAPINE ANC < 1.5] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R57R1A^OCXOZ0W ; Check Relation #1 in Rule #57 'CLOZAPINE' + Q + ; +EL116 ; Examine every rule that involves Element #116 [CLOZAPINE DRUG SELECTED] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R57R1A^OCXOZ0W ; Check Relation #1 in Rule #57 'CLOZAPINE' + D R57R2A^OCXOZ0W ; Check Relation #2 in Rule #57 'CLOZAPINE' + D R57R3A^OCXOZ0W ; Check Relation #3 in Rule #57 'CLOZAPINE' + D R57R4A^OCXOZ0W ; Check Relation #4 in Rule #57 'CLOZAPINE' + D R57R5A^OCXOZ0X ; Check Relation #5 in Rule #57 'CLOZAPINE' + Q + ; +EL119 ; Examine every rule that involves Element #119 [CLOZAPINE WBC < 3.0] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R57R1A^OCXOZ0W ; Check Relation #1 in Rule #57 'CLOZAPINE' + Q + ; +EL118 ; Examine every rule that involves Element #118 [CLOZAPINE NO WBC W/IN 7 DAYS] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R57R2A^OCXOZ0W ; Check Relation #2 in Rule #57 'CLOZAPINE' + Q + ; +EL117 ; Examine every rule that involves Element #117 [CLOZAPINE NO ANC W/IN 7 DAYS] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R57R3A^OCXOZ0W ; Check Relation #3 in Rule #57 'CLOZAPINE' + Q + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0I.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0I.m index 4a1dbe29..fc5594e9 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0I.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0I.m @@ -1,268 +1,253 @@ -OCXOZ0I ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; - ; *************************************************************** - ; ** Warning: This routine is automatically generated by the ** - ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** - ; ** will be lost the next time the rule compiler executes. ** - ; *************************************************************** - ; - Q - ; -EL114 ; Examine every rule that involves Element #114 [CLOZAPINE ANC < 1.5] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R57R2A^OCXOZ0W ; Check Relation #2 in Rule #57 'CLOZAPINE' - Q - ; -EL119 ; Examine every rule that involves Element #119 [CLOZAPINE WBC < 3.0] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R57R2A^OCXOZ0W ; Check Relation #2 in Rule #57 'CLOZAPINE' - Q - ; -EL115 ; Examine every rule that involves Element #115 [CLOZAPINE ANC >= 1.5] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R57R3A^OCXOZ0W ; Check Relation #3 in Rule #57 'CLOZAPINE' - Q - ; -EL120 ; Examine every rule that involves Element #120 [CLOZAPINE WBC >= 3.0 & < 3.5] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R57R3A^OCXOZ0W ; Check Relation #3 in Rule #57 'CLOZAPINE' - Q - ; -EL140 ; Examine every rule that involves Element #140 [CLOZAPINE ANC >= 1.5 & < 2.0] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R57R4A^OCXOZ0W ; Check Relation #4 in Rule #57 'CLOZAPINE' - Q - ; -EL71 ; Examine every rule that involves Element #71 [AMINOGLYCOSIDE ORDER SESSION] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R59R1A^OCXOZ0X ; Check Relation #1 in Rule #59 'AMINOGLYCOSIDE ORDER' - Q - ; -EL72 ; Examine every rule that involves Element #72 [PATIENT OVER CT OR MRI DEVICE LIMITATIONS] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R60R1A^OCXOZ0X ; Check Relation #1 in Rule #60 'CT OR MRI PHYSICAL LIMIT CHECK' - Q - ; -EL73 ; Examine every rule that involves Element #73 [CREATININE CLEARANCE ESTIMATE] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R61R1A^OCXOZ0Y ; Check Relation #1 in Rule #61 'CREATININE CLEARANCE ESTIMATION' - Q - ; -EL96 ; Examine every rule that involves Element #96 [CREATININE CLEARANCE DATE/TIME] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R61R1A^OCXOZ0Y ; Check Relation #1 in Rule #61 'CREATININE CLEARANCE ESTIMATION' - Q - ; -EL97 ; Examine every rule that involves Element #97 [RENAL RESULTS] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R61R1A^OCXOZ0Y ; Check Relation #1 in Rule #61 'CREATININE CLEARANCE ESTIMATION' - Q - ; -EL84 ; Examine every rule that involves Element #84 [INPATIENT FOOD-DRUG REACTION] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R62R1A^OCXOZ0Z ; Check Relation #1 in Rule #62 'FOOD/DRUG INTERACTION' - Q - ; -EL91 ; Examine every rule that involves Element #91 [PATIENT WITH GLUCOPHAGE MED] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R63R1A^OCXOZ0Z ; Check Relation #1 in Rule #63 'GLUCOPHAGE - CONTRAST MEDIA' - Q - ; -EL106 ; Examine every rule that involves Element #106 [RADIOLOGY PROCEDURE CONTAINS NON-BARIUM CONTRAST MEDIA] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R63R1A^OCXOZ0Z ; Check Relation #1 in Rule #63 'GLUCOPHAGE - CONTRAST MEDIA' - Q - ; -EL95 ; Examine every rule that involves Element #95 [POLYPHARMACY] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R65R1A^OCXOZ0Z ; Check Relation #1 in Rule #65 'POLYPHARMACY' - Q - ; -EL86 ; Examine every rule that involves Element #86 [GLUCOPHAGE ORDER] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R67R1A^OCXOZ10 ; Check Relation #1 in Rule #67 'GLUCOPHAGE - LAB RESULTS' - D R67R2A^OCXOZ10 ; Check Relation #2 in Rule #67 'GLUCOPHAGE - LAB RESULTS' - Q - ; -EL111 ; Examine every rule that involves Element #111 [GLUCOPHAGE CREATININE > 1.5] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R67R1A^OCXOZ10 ; Check Relation #1 in Rule #67 'GLUCOPHAGE - LAB RESULTS' - Q - ; -EL112 ; Examine every rule that involves Element #112 [NO GLUCOPHAGE CREATININE] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R67R2A^OCXOZ10 ; Check Relation #2 in Rule #67 'GLUCOPHAGE - LAB RESULTS' - Q - ; -EL122 ; Examine every rule that involves Element #122 [AMITRIPTYLINE ORDER] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R68R1A^OCXOZ11 ; Check Relation #1 in Rule #68 'DANGEROUS MEDS OVER AGE 64' - Q - ; -EL125 ; Examine every rule that involves Element #125 [MED ORDER FOR PT > 64] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R68R1A^OCXOZ11 ; Check Relation #1 in Rule #68 'DANGEROUS MEDS OVER AGE 64' - D R68R2A^OCXOZ11 ; Check Relation #2 in Rule #68 'DANGEROUS MEDS OVER AGE 64' - D R68R3A^OCXOZ11 ; Check Relation #3 in Rule #68 'DANGEROUS MEDS OVER AGE 64' - Q - ; -EL123 ; Examine every rule that involves Element #123 [CHLORPROPAMIDE ORDER] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R68R2A^OCXOZ11 ; Check Relation #2 in Rule #68 'DANGEROUS MEDS OVER AGE 64' - Q - ; -EL124 ; Examine every rule that involves Element #124 [DIPYRIDAMOLE ORDER] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R68R3A^OCXOZ11 ; Check Relation #3 in Rule #68 'DANGEROUS MEDS OVER AGE 64' - Q - ; -EL131 ; Examine every rule that involves Element #131 [GREATER THAN LAB THRESHOLD] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R69R1A^OCXOZ11 ; Check Relation #1 in Rule #69 'LAB THRESHOLD' - Q - ; -EL132 ; Examine every rule that involves Element #132 [LESS THAN LAB THRESHOLD] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R69R1A^OCXOZ11 ; Check Relation #1 in Rule #69 'LAB THRESHOLD' - Q - ; -EL28 ; Examine every rule that involves Element #28 [RADIOLOGY ORDER] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R70R1A^OCXOZ12 ; Check Relation #1 in Rule #70 'NO ALLERGY ASSESSMENT' - Q - ; -EL135 ; Examine every rule that involves Element #135 [DIET ORDER] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R70R1A^OCXOZ12 ; Check Relation #1 in Rule #70 'NO ALLERGY ASSESSMENT' - Q - ; -EL136 ; Examine every rule that involves Element #136 [NO ALLERGY ASSESSMENT] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R70R1A^OCXOZ12 ; Check Relation #1 in Rule #70 'NO ALLERGY ASSESSMENT' - Q - ; -EL137 ; Examine every rule that involves Element #137 [PHARMACY ORDER] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R70R1A^OCXOZ12 ; Check Relation #1 in Rule #70 'NO ALLERGY ASSESSMENT' - Q - ; -EL138 ; Examine every rule that involves Element #138 [DUP OPIOID MEDS] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R71R1A^OCXOZ13 ; Check Relation #1 in Rule #71 'OPIOID MEDICATIONS' - Q - ; -EL139 ; Examine every rule that involves Element #139 [OPIOID MED ORDER] - ; Called from SCAN+9^OCXOZ01. - ; - Q:$G(OCXOERR) - ; - D R71R1A^OCXOZ13 ; Check Relation #1 in Rule #71 'OPIOID MEDICATIONS' - Q - ; -R3R1A ; Verify all Event/Elements of Rule #3 'CRITICAL LAB RESULTS' Relation #1 'CRITICAL LAB TEST' - ; Called from EL24+5^OCXOZ0G. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE24( -----------> Verify Event/Element: 'HL7 LAB TEST RESULTS CRITICAL' - ; - Q:$G(^OCXS(860.2,3,"INACT")) - ; - I $$MCE24 D R3R1B^OCXOZ0J - Q - ; -MCE24() ; Verify Event/Element: HL7 LAB TEST RESULTS CRITICAL - ; - ; - N OCXRES - I $L(OCXDF(37)) S OCXRES(24,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),24)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),24)) - Q 0 - ; +OCXOZ0I ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; + ; *************************************************************** + ; ** Warning: This routine is automatically generated by the ** + ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** + ; ** will be lost the next time the rule compiler executes. ** + ; *************************************************************** + ; + Q + ; +EL120 ; Examine every rule that involves Element #120 [CLOZAPINE WBC >= 3.0 & < 3.5] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R57R3A^OCXOZ0W ; Check Relation #3 in Rule #57 'CLOZAPINE' + D R57R4A^OCXOZ0W ; Check Relation #4 in Rule #57 'CLOZAPINE' + Q + ; +EL115 ; Examine every rule that involves Element #115 [CLOZAPINE ANC >= 1.5] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R57R4A^OCXOZ0W ; Check Relation #4 in Rule #57 'CLOZAPINE' + Q + ; +EL121 ; Examine every rule that involves Element #121 [CLOZAPINE WBC >= 3.5] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R57R5A^OCXOZ0X ; Check Relation #5 in Rule #57 'CLOZAPINE' + Q + ; +EL71 ; Examine every rule that involves Element #71 [AMINOGLYCOSIDE ORDER SESSION] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R59R1A^OCXOZ0X ; Check Relation #1 in Rule #59 'AMINOGLYCOSIDE ORDER' + Q + ; +EL72 ; Examine every rule that involves Element #72 [PATIENT OVER CT OR MRI DEVICE LIMITATIONS] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R60R1A^OCXOZ0X ; Check Relation #1 in Rule #60 'CT OR MRI PHYSICAL LIMIT CHECK' + Q + ; +EL73 ; Examine every rule that involves Element #73 [CREATININE CLEARANCE ESTIMATE] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R61R1A^OCXOZ0Y ; Check Relation #1 in Rule #61 'CREATININE CLEARANCE ESTIMATION' + Q + ; +EL96 ; Examine every rule that involves Element #96 [CREATININE CLEARANCE DATE/TIME] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R61R1A^OCXOZ0Y ; Check Relation #1 in Rule #61 'CREATININE CLEARANCE ESTIMATION' + Q + ; +EL97 ; Examine every rule that involves Element #97 [RENAL RESULTS] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R61R1A^OCXOZ0Y ; Check Relation #1 in Rule #61 'CREATININE CLEARANCE ESTIMATION' + Q + ; +EL84 ; Examine every rule that involves Element #84 [INPATIENT FOOD-DRUG REACTION] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R62R1A^OCXOZ0Z ; Check Relation #1 in Rule #62 'FOOD/DRUG INTERACTION' + Q + ; +EL91 ; Examine every rule that involves Element #91 [PATIENT WITH GLUCOPHAGE MED] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R63R1A^OCXOZ0Z ; Check Relation #1 in Rule #63 'GLUCOPHAGE - CONTRAST MEDIA' + Q + ; +EL106 ; Examine every rule that involves Element #106 [RADIOLOGY PROCEDURE CONTAINS NON-BARIUM CONTRAST MEDIA] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R63R1A^OCXOZ0Z ; Check Relation #1 in Rule #63 'GLUCOPHAGE - CONTRAST MEDIA' + Q + ; +EL95 ; Examine every rule that involves Element #95 [POLYPHARMACY] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R65R1A^OCXOZ0Z ; Check Relation #1 in Rule #65 'POLYPHARMACY' + Q + ; +EL86 ; Examine every rule that involves Element #86 [GLUCOPHAGE ORDER] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R67R1A^OCXOZ10 ; Check Relation #1 in Rule #67 'GLUCOPHAGE - LAB RESULTS' + D R67R2A^OCXOZ10 ; Check Relation #2 in Rule #67 'GLUCOPHAGE - LAB RESULTS' + Q + ; +EL111 ; Examine every rule that involves Element #111 [GLUCOPHAGE CREATININE > 1.5] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R67R1A^OCXOZ10 ; Check Relation #1 in Rule #67 'GLUCOPHAGE - LAB RESULTS' + Q + ; +EL112 ; Examine every rule that involves Element #112 [NO GLUCOPHAGE CREATININE] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R67R2A^OCXOZ10 ; Check Relation #2 in Rule #67 'GLUCOPHAGE - LAB RESULTS' + Q + ; +EL122 ; Examine every rule that involves Element #122 [AMITRIPTYLINE ORDER] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R68R1A^OCXOZ11 ; Check Relation #1 in Rule #68 'DANGEROUS MEDS OVER AGE 64' + Q + ; +EL125 ; Examine every rule that involves Element #125 [MED ORDER FOR PT > 64] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R68R1A^OCXOZ11 ; Check Relation #1 in Rule #68 'DANGEROUS MEDS OVER AGE 64' + D R68R2A^OCXOZ11 ; Check Relation #2 in Rule #68 'DANGEROUS MEDS OVER AGE 64' + D R68R3A^OCXOZ11 ; Check Relation #3 in Rule #68 'DANGEROUS MEDS OVER AGE 64' + Q + ; +EL123 ; Examine every rule that involves Element #123 [CHLORPROPAMIDE ORDER] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R68R2A^OCXOZ11 ; Check Relation #2 in Rule #68 'DANGEROUS MEDS OVER AGE 64' + Q + ; +EL124 ; Examine every rule that involves Element #124 [DIPYRIDAMOLE ORDER] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R68R3A^OCXOZ11 ; Check Relation #3 in Rule #68 'DANGEROUS MEDS OVER AGE 64' + Q + ; +EL131 ; Examine every rule that involves Element #131 [GREATER THAN LAB THRESHOLD] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R69R1A^OCXOZ11 ; Check Relation #1 in Rule #69 'LAB THRESHOLD' + Q + ; +EL132 ; Examine every rule that involves Element #132 [LESS THAN LAB THRESHOLD] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R69R1A^OCXOZ11 ; Check Relation #1 in Rule #69 'LAB THRESHOLD' + Q + ; +EL28 ; Examine every rule that involves Element #28 [RADIOLOGY ORDER] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R70R1A^OCXOZ12 ; Check Relation #1 in Rule #70 'NO ALLERGY ASSESSMENT' + Q + ; +EL135 ; Examine every rule that involves Element #135 [DIET ORDER] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R70R1A^OCXOZ12 ; Check Relation #1 in Rule #70 'NO ALLERGY ASSESSMENT' + Q + ; +EL136 ; Examine every rule that involves Element #136 [NO ALLERGY ASSESSMENT] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R70R1A^OCXOZ12 ; Check Relation #1 in Rule #70 'NO ALLERGY ASSESSMENT' + Q + ; +EL137 ; Examine every rule that involves Element #137 [PHARMACY ORDER] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R70R1A^OCXOZ12 ; Check Relation #1 in Rule #70 'NO ALLERGY ASSESSMENT' + Q + ; +EL138 ; Examine every rule that involves Element #138 [DUP OPIOID MEDS] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R71R1A^OCXOZ13 ; Check Relation #1 in Rule #71 'OPIOID MEDICATIONS' + Q + ; +EL139 ; Examine every rule that involves Element #139 [OPIOID MED ORDER] + ; Called from SCAN+9^OCXOZ01. + ; + Q:$G(OCXOERR) + ; + D R71R1A^OCXOZ13 ; Check Relation #1 in Rule #71 'OPIOID MEDICATIONS' + Q + ; +R3R1A ; Verify all Event/Elements of Rule #3 'CRITICAL LAB RESULTS' Relation #1 'CRITICAL LAB TEST' + ; Called from EL24+5^OCXOZ0G. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE24( -----------> Verify Event/Element: 'HL7 LAB TEST RESULTS CRITICAL' + ; + Q:$G(^OCXS(860.2,3,"INACT")) + ; + I $$MCE24 D R3R1B^OCXOZ0J + Q + ; +MCE24() ; Verify Event/Element: HL7 LAB TEST RESULTS CRITICAL + ; + ; + N OCXRES + I $L(OCXDF(37)) S OCXRES(24,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),24)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),24)) + Q 0 + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0J.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0J.m index 42903d99..a9119141 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0J.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0J.m @@ -1,226 +1,226 @@ -OCXOZ0J ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; - ; *************************************************************** - ; ** Warning: This routine is automatically generated by the ** - ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** - ; ** will be lost the next time the rule compiler executes. ** - ; *************************************************************** - ; - Q - ; -R3R1B ; Send Order Check, Notication messages and/or Execute code for Rule #3 'CRITICAL LAB RESULTS' Relation #1 'CRITICAL LAB TEST' - ; Called from R3R1A+10^OCXOZ0I. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT - ; NEWRULE( ---------> NEW RULE MESSAGE - ; - Q:$D(OCXRULE("R3R1B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - S OCXCMSG="" - S OCXNMSG="Critical lab: "_$$GETDATA(DFN,"24^",114)_" "_$$GETDATA(DFN,"24^",12)_" "_$$INT2DT($$GETDATA(DFN,"24^",13),0) - ; - Q:$G(OCXOERR) - ; - ; Send Notification - ; - S (OCXDUZ,OCXDATA)="",OCXNUM=0 - I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D - .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) - .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA - I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D - .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" - .S OCXNUM=+$P(OCXORD,U,2) - S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) - S OCXRULE("R3R1B")="" - I $$NEWRULE(DFN,OCXNUM,3,1,24,OCXNMSG) D I 1 - .D:($G(OCXTRACE)<5) EN^ORB3(24,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) - Q - ; -R3R2A ; Verify all Event/Elements of Rule #3 'CRITICAL LAB RESULTS' Relation #2 'CRITICAL LAB ORDER' - ; Called from EL105+5^OCXOZ0G. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE105( ----------> Verify Event/Element: 'HL7 LAB ORDER RESULTS CRITICAL' - ; - Q:$G(^OCXS(860.2,3,"INACT")) - ; - I $$MCE105 D R3R2B - Q - ; -R3R2B ; Send Order Check, Notication messages and/or Execute code for Rule #3 'CRITICAL LAB RESULTS' Relation #2 'CRITICAL LAB ORDER' - ; Called from R3R2A+10. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; NEWRULE( ---------> NEW RULE MESSAGE - ; - Q:$D(OCXRULE("R3R2B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - S OCXCMSG="" - S OCXNMSG="Critical labs - ["_$$GETDATA(DFN,"105^",96)_"]" - ; - Q:$G(OCXOERR) - ; - ; Send Notification - ; - S (OCXDUZ,OCXDATA)="",OCXNUM=0 - I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D - .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) - .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA - I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D - .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" - .S OCXNUM=+$P(OCXORD,U,2) - S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) - S OCXRULE("R3R2B")="" - I $$NEWRULE(DFN,OCXNUM,3,2,57,OCXNMSG) D I 1 - .D:($G(OCXTRACE)<5) EN^ORB3(57,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) - Q - ; -R5R1A ; Verify all Event/Elements of Rule #5 'ORDER FLAGGED FOR CLARIFICATION' Relation #1 'ORDER FLAGGED' - ; Called from EL44+5^OCXOZ0G. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE44( -----------> Verify Event/Element: 'ORDER FLAGGED' - ; - Q:$G(^OCXS(860.2,5,"INACT")) - ; - I $$MCE44 D R5R1B^OCXOZ0K - Q - ; -CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM - ; - N CKSUM,PTR,ASC S CKSUM=0 - S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") - F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC - Q +CKSUM - ; -GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data - ; - N OCXE,VAL,PC S VAL="" - F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) - Q VAL - ; -INT2DT(OCXDT,OCXF) ; This Local Extrinsic Function converts an OCX internal format - ; date into an Externl Format (Human Readable) date. 'OCXF=SHORT FORMAT OCXF=LONG FORMAT - ; - Q:'$L($G(OCXDT)) "" S OCXF=+$G(OCXF) - N OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXCYR - S (OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXAP)="" - S OCXSEC=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 - S OCXMIN=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 - S OCXHR=$E(OCXDT#24+100,2,3),OCXDT=OCXDT\24 - S OCXCYR=($H\1461)*4+1841+(($H#1461)\365) - S OCXYR=(OCXDT\1461)*4+1841,OCXDT=OCXDT#1461 - S OCXLPYR=(OCXDT\365),OCXDT=OCXDT-(OCXLPYR*365),OCXYR=OCXYR+OCXLPYR - S OCXCNT="031^059^090^120^151^181^212^243^273^304^334^365" - S:(OCXLPYR=3) OCXCNT="031^060^091^121^152^182^213^244^274^305^335^366" - F OCXMON=1:1:12 Q:(OCXDT<$P(OCXCNT,U,OCXMON)) - S OCXDAY=OCXDT-$P(OCXCNT,U,OCXMON-1)+1 - I OCXF S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,OCXMON) - E S OCXMON=$E(OCXMON+100,2,3) - S OCXAP=$S('OCXHR:"Midnight",(OCXHR=12):"Noon",(OCXHR<12):"AM",1:"PM") - I OCXF S OCXHR=OCXHR#12 S:'OCXHR OCXHR=12 - Q:'OCXF $E(OCXMON+100,2,3)_"/"_$E(OCXDAY+100,2,3)_$S((OCXCYR=OCXYR):" "_OCXHR_":"_OCXMIN,1:"/"_$E(OCXYR,3,4)) - Q:(OCXHR+OCXMIN+OCXSEC) OCXMON_" "_OCXDAY_","_OCXYR_" at "_OCXHR_":"_OCXMIN_"."_OCXSEC_" "_OCXAP - Q OCXMON_" "_OCXDAY_","_OCXYR - ; -MCE105() ; Verify Event/Element: HL7 LAB ORDER RESULTS CRITICAL - ; - ; - N OCXRES - I $L(OCXDF(37)) S OCXRES(105,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),105)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),105)) - Q 0 - ; -MCE44() ; Verify Event/Element: ORDER FLAGGED - ; - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$P($G(OCXORD),"^",1) I $L(OCXDF(37)) S OCXRES(44,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),44)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),44)) - Q 0 - ; -NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number - ; - ; - Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 - Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 - S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN - ; - N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL - ; - S OCXTIME=(+$H) - S OCXCKSUM=$$CKSUM(OCXMESS) - ; - S OCXTSP=($H*86400)+$P($H,",",2) - S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) - ; - Q:(OCXTSPL>OCXTSP) 0 - ; - K OCXDATA - S OCXDATA(OCXDFN,0)=OCXDFN - S OCXDATA("B",OCXDFN,OCXDFN)="" - S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP - ; - S OCXGR="^OCXD(860.7" - D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) - ; - K OCXDATA - S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) - S OCXDATA(OCXRUL,"M")=OCXMESS - S OCXDATA("B",OCXRUL,OCXRUL)="" - S OCXGR=OCXGR_","_OCXDFN_",1" - D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) - ; - K OCXDATA - S OCXDATA(OCXREL,0)=OCXREL - S OCXDATA("B",OCXREL,OCXREL)="" - S OCXGR=OCXGR_","_OCXRUL_",1" - D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) - ; - S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D - .; - .N OCXGR1 - .S OCXGR1=OCXGR_","_OCXREL_",1" - .K OCXDATA - .S OCXDATA(OCXELE,0)=OCXELE - .S OCXDATA(OCXELE,"TIME")=OCXTIME - .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) - .S OCXDATA("B",OCXELE,OCXELE)="" - .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) - .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) - .; - .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D - ..N OCXGR2 - ..S OCXGR2=OCXGR1_","_OCXELE_",1" - ..K OCXDATA - ..S OCXDATA(OCXDFI,0)=OCXDFI - ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) - ..S OCXDATA("B",OCXDFI,OCXDFI)="" - ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) - ; - Q 1 - ; -SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data - M @ROOT=DATA - I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) - I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) - ; - Q - ; - ; +OCXOZ0J ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; + ; *************************************************************** + ; ** Warning: This routine is automatically generated by the ** + ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** + ; ** will be lost the next time the rule compiler executes. ** + ; *************************************************************** + ; + Q + ; +R3R1B ; Send Order Check, Notication messages and/or Execute code for Rule #3 'CRITICAL LAB RESULTS' Relation #1 'CRITICAL LAB TEST' + ; Called from R3R1A+10^OCXOZ0I. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT + ; NEWRULE( ---------> NEW RULE MESSAGE + ; + Q:$D(OCXRULE("R3R1B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + S OCXCMSG="" + S OCXNMSG="Critical lab: "_$$GETDATA(DFN,"24^",114)_" "_$$GETDATA(DFN,"24^",12)_" "_$$INT2DT($$GETDATA(DFN,"24^",13),0) + ; + Q:$G(OCXOERR) + ; + ; Send Notification + ; + S (OCXDUZ,OCXDATA)="",OCXNUM=0 + I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D + .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) + .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA + I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D + .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" + .S OCXNUM=+$P(OCXORD,U,2) + S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) + S OCXRULE("R3R1B")="" + I $$NEWRULE(DFN,OCXNUM,3,1,24,OCXNMSG) D I 1 + .D:($G(OCXTRACE)<5) EN^ORB3(24,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) + Q + ; +R3R2A ; Verify all Event/Elements of Rule #3 'CRITICAL LAB RESULTS' Relation #2 'CRITICAL LAB ORDER' + ; Called from EL105+5^OCXOZ0G. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE105( ----------> Verify Event/Element: 'HL7 LAB ORDER RESULTS CRITICAL' + ; + Q:$G(^OCXS(860.2,3,"INACT")) + ; + I $$MCE105 D R3R2B + Q + ; +R3R2B ; Send Order Check, Notication messages and/or Execute code for Rule #3 'CRITICAL LAB RESULTS' Relation #2 'CRITICAL LAB ORDER' + ; Called from R3R2A+10. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; NEWRULE( ---------> NEW RULE MESSAGE + ; + Q:$D(OCXRULE("R3R2B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + S OCXCMSG="" + S OCXNMSG="Critical labs - ["_$$GETDATA(DFN,"105^",96)_"]" + ; + Q:$G(OCXOERR) + ; + ; Send Notification + ; + S (OCXDUZ,OCXDATA)="",OCXNUM=0 + I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D + .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) + .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA + I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D + .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" + .S OCXNUM=+$P(OCXORD,U,2) + S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) + S OCXRULE("R3R2B")="" + I $$NEWRULE(DFN,OCXNUM,3,2,57,OCXNMSG) D I 1 + .D:($G(OCXTRACE)<5) EN^ORB3(57,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) + Q + ; +R5R1A ; Verify all Event/Elements of Rule #5 'ORDER FLAGGED FOR CLARIFICATION' Relation #1 'ORDER FLAGGED' + ; Called from EL44+5^OCXOZ0G. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE44( -----------> Verify Event/Element: 'ORDER FLAGGED' + ; + Q:$G(^OCXS(860.2,5,"INACT")) + ; + I $$MCE44 D R5R1B^OCXOZ0K + Q + ; +CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM + ; + N CKSUM,PTR,ASC S CKSUM=0 + S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") + F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC + Q +CKSUM + ; +GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data + ; + N OCXE,VAL,PC S VAL="" + F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) + Q VAL + ; +INT2DT(OCXDT,OCXF) ; This Local Extrinsic Function converts an OCX internal format + ; date into an Externl Format (Human Readable) date. 'OCXF=SHORT FORMAT OCXF=LONG FORMAT + ; + Q:'$L($G(OCXDT)) "" S OCXF=+$G(OCXF) + N OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXCYR + S (OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXAP)="" + S OCXSEC=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 + S OCXMIN=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 + S OCXHR=$E(OCXDT#24+100,2,3),OCXDT=OCXDT\24 + S OCXCYR=($H\1461)*4+1841+(($H#1461)\365) + S OCXYR=(OCXDT\1461)*4+1841,OCXDT=OCXDT#1461 + S OCXLPYR=(OCXDT\365),OCXDT=OCXDT-(OCXLPYR*365),OCXYR=OCXYR+OCXLPYR + S OCXCNT="031^059^090^120^151^181^212^243^273^304^334^365" + S:(OCXLPYR=3) OCXCNT="031^060^091^121^152^182^213^244^274^305^335^366" + F OCXMON=1:1:12 Q:(OCXDT<$P(OCXCNT,U,OCXMON)) + S OCXDAY=OCXDT-$P(OCXCNT,U,OCXMON-1)+1 + I OCXF S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,OCXMON) + E S OCXMON=$E(OCXMON+100,2,3) + S OCXAP=$S('OCXHR:"Midnight",(OCXHR=12):"Noon",(OCXHR<12):"AM",1:"PM") + I OCXF S OCXHR=OCXHR#12 S:'OCXHR OCXHR=12 + Q:'OCXF $E(OCXMON+100,2,3)_"/"_$E(OCXDAY+100,2,3)_$S((OCXCYR=OCXYR):" "_OCXHR_":"_OCXMIN,1:"/"_$E(OCXYR,3,4)) + Q:(OCXHR+OCXMIN+OCXSEC) OCXMON_" "_OCXDAY_","_OCXYR_" at "_OCXHR_":"_OCXMIN_"."_OCXSEC_" "_OCXAP + Q OCXMON_" "_OCXDAY_","_OCXYR + ; +MCE105() ; Verify Event/Element: HL7 LAB ORDER RESULTS CRITICAL + ; + ; + N OCXRES + I $L(OCXDF(37)) S OCXRES(105,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),105)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),105)) + Q 0 + ; +MCE44() ; Verify Event/Element: ORDER FLAGGED + ; + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$P($G(OCXORD),"^",1) I $L(OCXDF(37)) S OCXRES(44,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),44)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),44)) + Q 0 + ; +NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number + ; + ; + Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 + Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 + S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN + ; + N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL + ; + S OCXTIME=(+$H) + S OCXCKSUM=$$CKSUM(OCXMESS) + ; + S OCXTSP=($H*86400)+$P($H,",",2) + S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) + ; + Q:(OCXTSPL>OCXTSP) 0 + ; + K OCXDATA + S OCXDATA(OCXDFN,0)=OCXDFN + S OCXDATA("B",OCXDFN,OCXDFN)="" + S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP + ; + S OCXGR="^OCXD(860.7" + D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) + ; + K OCXDATA + S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) + S OCXDATA(OCXRUL,"M")=OCXMESS + S OCXDATA("B",OCXRUL,OCXRUL)="" + S OCXGR=OCXGR_","_OCXDFN_",1" + D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) + ; + K OCXDATA + S OCXDATA(OCXREL,0)=OCXREL + S OCXDATA("B",OCXREL,OCXREL)="" + S OCXGR=OCXGR_","_OCXRUL_",1" + D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) + ; + S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D + .; + .N OCXGR1 + .S OCXGR1=OCXGR_","_OCXREL_",1" + .K OCXDATA + .S OCXDATA(OCXELE,0)=OCXELE + .S OCXDATA(OCXELE,"TIME")=OCXTIME + .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) + .S OCXDATA("B",OCXELE,OCXELE)="" + .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) + .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) + .; + .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D + ..N OCXGR2 + ..S OCXGR2=OCXGR1_","_OCXELE_",1" + ..K OCXDATA + ..S OCXDATA(OCXDFI,0)=OCXDFI + ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) + ..S OCXDATA("B",OCXDFI,OCXDFI)="" + ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) + ; + Q 1 + ; +SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data + M @ROOT=DATA + I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) + I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) + ; + Q + ; + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0K.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0K.m index ee84da31..962c8be4 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0K.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0K.m @@ -1,244 +1,244 @@ -OCXOZ0K ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; - ; *************************************************************** - ; ** Warning: This routine is automatically generated by the ** - ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** - ; ** will be lost the next time the rule compiler executes. ** - ; *************************************************************** - ; - Q - ; -R5R1B ; Send Order Check, Notication messages and/or Execute code for Rule #5 'ORDER FLAGGED FOR CLARIFICATION' Relation #1 'ORDER FLAGGED' - ; Called from R5R1A+10^OCXOZ0J. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; NEWRULE( ---------> NEW RULE MESSAGE - ; - Q:$D(OCXRULE("R5R1B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - S OCXCMSG="" - S OCXNMSG="Order(s) needing clarification: Flagged "_$$GETDATA(DFN,"44^",115)_"." - ; - Q:$G(OCXOERR) - ; - ; Send Notification - ; - S (OCXDUZ,OCXDATA)="",OCXNUM=0 - I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D - .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) - .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA - I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D - .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" - .S OCXNUM=+$P(OCXORD,U,2) - S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) - S OCXRULE("R5R1B")="" - I $$NEWRULE(DFN,OCXNUM,5,1,6,OCXNMSG) D I 1 - .D:($G(OCXTRACE)<5) EN^ORB3(6,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) - Q - ; -R5R2A ; Verify all Event/Elements of Rule #5 'ORDER FLAGGED FOR CLARIFICATION' Relation #2 'ORDER UNFLAGGED' - ; Called from EL134+5^OCXOZ0G. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE134( ----------> Verify Event/Element: 'ORDER UNFLAGGED' - ; - Q:$G(^OCXS(860.2,5,"INACT")) - ; - I $$MCE134 D R5R2B - Q - ; -R5R2B ; Send Order Check, Notication messages and/or Execute code for Rule #5 'ORDER FLAGGED FOR CLARIFICATION' Relation #2 'ORDER UNFLAGGED' - ; Called from R5R2A+10. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; - Q:$D(OCXRULE("R5R2B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - S OCXCMSG="" - S OCXNMSG="" - ; - ; - ; Run Execute Code - ; - D UNFLAG^ORB3FUP1($$GETDATA(DFN,"134^",37)) - Q:$G(OCXOERR) - Q - ; -R6R1A ; Verify all Event/Elements of Rule #6 'ORDER REQUIRES CHART SIGNATURE' Relation #1 'SIGNATURE' - ; Called from EL45+5^OCXOZ0G. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE45( -----------> Verify Event/Element: 'ORDER REQUIRES CHART SIGNATURE' - ; - Q:$G(^OCXS(860.2,6,"INACT")) - ; - I $$MCE45 D R6R1B - Q - ; -R6R1B ; Send Order Check, Notication messages and/or Execute code for Rule #6 'ORDER REQUIRES CHART SIGNATURE' Relation #1 'SIGNATURE' - ; Called from R6R1A+10. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; NEWRULE( ---------> NEW RULE MESSAGE - ; - Q:$D(OCXRULE("R6R1B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - S OCXCMSG="" - S OCXNMSG="Order released - requires chart signature." - ; - Q:$G(OCXOERR) - ; - ; Send Notification - ; - S (OCXDUZ,OCXDATA)="",OCXNUM=0 - I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D - .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) - .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA - I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D - .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" - .S OCXNUM=+$P(OCXORD,U,2) - S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) - S OCXRULE("R6R1B")="" - I $$NEWRULE(DFN,OCXNUM,6,1,5,OCXNMSG) D I 1 - .D:($G(OCXTRACE)<5) EN^ORB3(5,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) - Q - ; -R7R1A ; Verify all Event/Elements of Rule #7 'PATIENT ADMISSION' Relation #1 'ADMISSION' - ; Called from EL21+5^OCXOZ0G. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE21( -----------> Verify Event/Element: 'PATIENT ADMISSION' - ; - Q:$G(^OCXS(860.2,7,"INACT")) - ; - I $$MCE21 D R7R1B^OCXOZ0L - Q - ; -CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM - ; - N CKSUM,PTR,ASC S CKSUM=0 - S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") - F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC - Q +CKSUM - ; -GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data - ; - N OCXE,VAL,PC S VAL="" - F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) - Q VAL - ; -MCE134() ; Verify Event/Element: ORDER UNFLAGGED - ; - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$P($G(OCXORD),"^",1) I $L(OCXDF(37)) S OCXRES(134,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),134)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),134)) - Q 0 - ; -MCE21() ; Verify Event/Element: PATIENT ADMISSION - ; - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(21,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),21)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),21)) - Q 0 - ; -MCE45() ; Verify Event/Element: ORDER REQUIRES CHART SIGNATURE - ; - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$P($G(OCXORD),"^",1) I $L(OCXDF(37)) S OCXRES(45,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),45)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),45)) - Q 0 - ; -NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number - ; - ; - Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 - Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 - S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN - ; - N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL - ; - S OCXTIME=(+$H) - S OCXCKSUM=$$CKSUM(OCXMESS) - ; - S OCXTSP=($H*86400)+$P($H,",",2) - S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) - ; - Q:(OCXTSPL>OCXTSP) 0 - ; - K OCXDATA - S OCXDATA(OCXDFN,0)=OCXDFN - S OCXDATA("B",OCXDFN,OCXDFN)="" - S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP - ; - S OCXGR="^OCXD(860.7" - D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) - ; - K OCXDATA - S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) - S OCXDATA(OCXRUL,"M")=OCXMESS - S OCXDATA("B",OCXRUL,OCXRUL)="" - S OCXGR=OCXGR_","_OCXDFN_",1" - D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) - ; - K OCXDATA - S OCXDATA(OCXREL,0)=OCXREL - S OCXDATA("B",OCXREL,OCXREL)="" - S OCXGR=OCXGR_","_OCXRUL_",1" - D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) - ; - S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D - .; - .N OCXGR1 - .S OCXGR1=OCXGR_","_OCXREL_",1" - .K OCXDATA - .S OCXDATA(OCXELE,0)=OCXELE - .S OCXDATA(OCXELE,"TIME")=OCXTIME - .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) - .S OCXDATA("B",OCXELE,OCXELE)="" - .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) - .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) - .; - .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D - ..N OCXGR2 - ..S OCXGR2=OCXGR1_","_OCXELE_",1" - ..K OCXDATA - ..S OCXDATA(OCXDFI,0)=OCXDFI - ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) - ..S OCXDATA("B",OCXDFI,OCXDFI)="" - ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) - ; - Q 1 - ; -SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data - M @ROOT=DATA - I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) - I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) - ; - Q - ; - ; +OCXOZ0K ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; + ; *************************************************************** + ; ** Warning: This routine is automatically generated by the ** + ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** + ; ** will be lost the next time the rule compiler executes. ** + ; *************************************************************** + ; + Q + ; +R5R1B ; Send Order Check, Notication messages and/or Execute code for Rule #5 'ORDER FLAGGED FOR CLARIFICATION' Relation #1 'ORDER FLAGGED' + ; Called from R5R1A+10^OCXOZ0J. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; NEWRULE( ---------> NEW RULE MESSAGE + ; + Q:$D(OCXRULE("R5R1B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + S OCXCMSG="" + S OCXNMSG="Order(s) needing clarification: Flagged "_$$GETDATA(DFN,"44^",115)_"." + ; + Q:$G(OCXOERR) + ; + ; Send Notification + ; + S (OCXDUZ,OCXDATA)="",OCXNUM=0 + I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D + .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) + .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA + I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D + .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" + .S OCXNUM=+$P(OCXORD,U,2) + S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) + S OCXRULE("R5R1B")="" + I $$NEWRULE(DFN,OCXNUM,5,1,6,OCXNMSG) D I 1 + .D:($G(OCXTRACE)<5) EN^ORB3(6,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) + Q + ; +R5R2A ; Verify all Event/Elements of Rule #5 'ORDER FLAGGED FOR CLARIFICATION' Relation #2 'ORDER UNFLAGGED' + ; Called from EL134+5^OCXOZ0G. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE134( ----------> Verify Event/Element: 'ORDER UNFLAGGED' + ; + Q:$G(^OCXS(860.2,5,"INACT")) + ; + I $$MCE134 D R5R2B + Q + ; +R5R2B ; Send Order Check, Notication messages and/or Execute code for Rule #5 'ORDER FLAGGED FOR CLARIFICATION' Relation #2 'ORDER UNFLAGGED' + ; Called from R5R2A+10. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; + Q:$D(OCXRULE("R5R2B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + S OCXCMSG="" + S OCXNMSG="" + ; + ; + ; Run Execute Code + ; + D UNFLAG^ORB3FUP1($$GETDATA(DFN,"134^",37)) + Q:$G(OCXOERR) + Q + ; +R6R1A ; Verify all Event/Elements of Rule #6 'ORDER REQUIRES CHART SIGNATURE' Relation #1 'SIGNATURE' + ; Called from EL45+5^OCXOZ0G. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE45( -----------> Verify Event/Element: 'ORDER REQUIRES CHART SIGNATURE' + ; + Q:$G(^OCXS(860.2,6,"INACT")) + ; + I $$MCE45 D R6R1B + Q + ; +R6R1B ; Send Order Check, Notication messages and/or Execute code for Rule #6 'ORDER REQUIRES CHART SIGNATURE' Relation #1 'SIGNATURE' + ; Called from R6R1A+10. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; NEWRULE( ---------> NEW RULE MESSAGE + ; + Q:$D(OCXRULE("R6R1B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + S OCXCMSG="" + S OCXNMSG="Order released - requires chart signature." + ; + Q:$G(OCXOERR) + ; + ; Send Notification + ; + S (OCXDUZ,OCXDATA)="",OCXNUM=0 + I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D + .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) + .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA + I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D + .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" + .S OCXNUM=+$P(OCXORD,U,2) + S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) + S OCXRULE("R6R1B")="" + I $$NEWRULE(DFN,OCXNUM,6,1,5,OCXNMSG) D I 1 + .D:($G(OCXTRACE)<5) EN^ORB3(5,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) + Q + ; +R7R1A ; Verify all Event/Elements of Rule #7 'PATIENT ADMISSION' Relation #1 'ADMISSION' + ; Called from EL21+5^OCXOZ0G. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE21( -----------> Verify Event/Element: 'PATIENT ADMISSION' + ; + Q:$G(^OCXS(860.2,7,"INACT")) + ; + I $$MCE21 D R7R1B^OCXOZ0L + Q + ; +CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM + ; + N CKSUM,PTR,ASC S CKSUM=0 + S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") + F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC + Q +CKSUM + ; +GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data + ; + N OCXE,VAL,PC S VAL="" + F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) + Q VAL + ; +MCE134() ; Verify Event/Element: ORDER UNFLAGGED + ; + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$P($G(OCXORD),"^",1) I $L(OCXDF(37)) S OCXRES(134,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),134)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),134)) + Q 0 + ; +MCE21() ; Verify Event/Element: PATIENT ADMISSION + ; + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(21,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),21)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),21)) + Q 0 + ; +MCE45() ; Verify Event/Element: ORDER REQUIRES CHART SIGNATURE + ; + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$P($G(OCXORD),"^",1) I $L(OCXDF(37)) S OCXRES(45,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),45)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),45)) + Q 0 + ; +NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number + ; + ; + Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 + Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 + S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN + ; + N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL + ; + S OCXTIME=(+$H) + S OCXCKSUM=$$CKSUM(OCXMESS) + ; + S OCXTSP=($H*86400)+$P($H,",",2) + S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) + ; + Q:(OCXTSPL>OCXTSP) 0 + ; + K OCXDATA + S OCXDATA(OCXDFN,0)=OCXDFN + S OCXDATA("B",OCXDFN,OCXDFN)="" + S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP + ; + S OCXGR="^OCXD(860.7" + D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) + ; + K OCXDATA + S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) + S OCXDATA(OCXRUL,"M")=OCXMESS + S OCXDATA("B",OCXRUL,OCXRUL)="" + S OCXGR=OCXGR_","_OCXDFN_",1" + D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) + ; + K OCXDATA + S OCXDATA(OCXREL,0)=OCXREL + S OCXDATA("B",OCXREL,OCXREL)="" + S OCXGR=OCXGR_","_OCXRUL_",1" + D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) + ; + S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D + .; + .N OCXGR1 + .S OCXGR1=OCXGR_","_OCXREL_",1" + .K OCXDATA + .S OCXDATA(OCXELE,0)=OCXELE + .S OCXDATA(OCXELE,"TIME")=OCXTIME + .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) + .S OCXDATA("B",OCXELE,OCXELE)="" + .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) + .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) + .; + .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D + ..N OCXGR2 + ..S OCXGR2=OCXGR1_","_OCXELE_",1" + ..K OCXDATA + ..S OCXDATA(OCXDFI,0)=OCXDFI + ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) + ..S OCXDATA("B",OCXDFI,OCXDFI)="" + ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) + ; + Q 1 + ; +SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data + M @ROOT=DATA + I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) + I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) + ; + Q + ; + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0L.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0L.m index dd600b9d..d6819432 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0L.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0L.m @@ -1,237 +1,237 @@ -OCXOZ0L ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; - ; *************************************************************** - ; ** Warning: This routine is automatically generated by the ** - ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** - ; ** will be lost the next time the rule compiler executes. ** - ; *************************************************************** - ; - Q - ; -R7R1B ; Send Order Check, Notication messages and/or Execute code for Rule #7 'PATIENT ADMISSION' Relation #1 'ADMISSION' - ; Called from R7R1A+10^OCXOZ0K. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT - ; NEWRULE( ---------> NEW RULE MESSAGE - ; - Q:$D(OCXRULE("R7R1B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - S OCXCMSG="" - S OCXNMSG="Admitted on "_$$INT2DT($$GETDATA(DFN,"21^",26),0)_" to "_$$GETDATA(DFN,"21^",83) - ; - Q:$G(OCXOERR) - ; - ; Send Notification - ; - S (OCXDUZ,OCXDATA)="",OCXNUM=0 - I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D - .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) - .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA - I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D - .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" - .S OCXNUM=+$P(OCXORD,U,2) - S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) - S OCXRULE("R7R1B")="" - I $$NEWRULE(DFN,OCXNUM,7,1,18,OCXNMSG) D I 1 - .D:($G(OCXTRACE)<5) EN^ORB3(18,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) - Q - ; -R11R1A ; Verify all Event/Elements of Rule #11 'IMAGING REQUEST CANCELLED/HELD' Relation #1 'CANCELLED AND CANCELED BY NON-ORIG ORDERER' - ; Called from EL31+5^OCXOZ0G, and EL100+5^OCXOZ0G. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE100( ----------> Verify Event/Element: 'CANCELED BY NON-ORIG ORDERING PROVIDER' - ; MCE31( -----------> Verify Event/Element: 'RADIOLOGY ORDER CANCELLED' - ; - Q:$G(^OCXS(860.2,11,"INACT")) - ; - I $$MCE31 D - .I $$MCE100 D R11R1B - Q - ; -R11R1B ; Send Order Check, Notication messages and/or Execute code for Rule #11 'IMAGING REQUEST CANCELLED/HELD' Relation #1 'CANCELLED AND CANCELED BY NON-ORIG ORDERER' - ; Called from R11R1A+12. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; NEWRULE( ---------> NEW RULE MESSAGE - ; - Q:$D(OCXRULE("R11R1B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - S OCXCMSG="" - S OCXNMSG="Imaging request canceled: "_$$GETDATA(DFN,"31^100",105) - ; - Q:$G(OCXOERR) - ; - ; Send Notification - ; - S (OCXDUZ,OCXDATA)="",OCXNUM=0 - I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D - .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) - .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA - I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D - .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" - .S OCXNUM=+$P(OCXORD,U,2) - S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) - S OCXRULE("R11R1B")="" - I $$NEWRULE(DFN,OCXNUM,11,1,26,OCXNMSG) D I 1 - .D:($G(OCXTRACE)<5) EN^ORB3(26,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) - Q - ; -R11R2A ; Verify all Event/Elements of Rule #11 'IMAGING REQUEST CANCELLED/HELD' Relation #2 'ON HOLD AND CANCELED BY NON-ORIG ORDERER' - ; Called from EL100+6^OCXOZ0G, and EL30+5^OCXOZ0G. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE100( ----------> Verify Event/Element: 'CANCELED BY NON-ORIG ORDERING PROVIDER' - ; MCE30( -----------> Verify Event/Element: 'RADIOLOGY ORDER PUT ON-HOLD' - ; - Q:$G(^OCXS(860.2,11,"INACT")) - ; - I $$MCE30 D - .I $$MCE100 D R11R2B^OCXOZ0M - Q - ; -CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM - ; - N CKSUM,PTR,ASC S CKSUM=0 - S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") - F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC - Q +CKSUM - ; -GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data - ; - N OCXE,VAL,PC S VAL="" - F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) - Q VAL - ; -INT2DT(OCXDT,OCXF) ; This Local Extrinsic Function converts an OCX internal format - ; date into an Externl Format (Human Readable) date. 'OCXF=SHORT FORMAT OCXF=LONG FORMAT - ; - Q:'$L($G(OCXDT)) "" S OCXF=+$G(OCXF) - N OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXCYR - S (OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXAP)="" - S OCXSEC=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 - S OCXMIN=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 - S OCXHR=$E(OCXDT#24+100,2,3),OCXDT=OCXDT\24 - S OCXCYR=($H\1461)*4+1841+(($H#1461)\365) - S OCXYR=(OCXDT\1461)*4+1841,OCXDT=OCXDT#1461 - S OCXLPYR=(OCXDT\365),OCXDT=OCXDT-(OCXLPYR*365),OCXYR=OCXYR+OCXLPYR - S OCXCNT="031^059^090^120^151^181^212^243^273^304^334^365" - S:(OCXLPYR=3) OCXCNT="031^060^091^121^152^182^213^244^274^305^335^366" - F OCXMON=1:1:12 Q:(OCXDT<$P(OCXCNT,U,OCXMON)) - S OCXDAY=OCXDT-$P(OCXCNT,U,OCXMON-1)+1 - I OCXF S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,OCXMON) - E S OCXMON=$E(OCXMON+100,2,3) - S OCXAP=$S('OCXHR:"Midnight",(OCXHR=12):"Noon",(OCXHR<12):"AM",1:"PM") - I OCXF S OCXHR=OCXHR#12 S:'OCXHR OCXHR=12 - Q:'OCXF $E(OCXMON+100,2,3)_"/"_$E(OCXDAY+100,2,3)_$S((OCXCYR=OCXYR):" "_OCXHR_":"_OCXMIN,1:"/"_$E(OCXYR,3,4)) - Q:(OCXHR+OCXMIN+OCXSEC) OCXMON_" "_OCXDAY_","_OCXYR_" at "_OCXHR_":"_OCXMIN_"."_OCXSEC_" "_OCXAP - Q OCXMON_" "_OCXDAY_","_OCXYR - ; -MCE100() ; Verify Event/Element: CANCELED BY NON-ORIG ORDERING PROVIDER - ; - ; - N OCXRES - I $L(OCXDF(37)) S OCXRES(100,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),100)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),100)) - Q 0 - ; -MCE30() ; Verify Event/Element: RADIOLOGY ORDER PUT ON-HOLD - ; - ; - N OCXRES - I $L(OCXDF(37)) S OCXRES(30,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),30)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),30)) - Q 0 - ; -MCE31() ; Verify Event/Element: RADIOLOGY ORDER CANCELLED - ; - ; - N OCXRES - I $L(OCXDF(37)) S OCXRES(31,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),31)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),31)) - Q 0 - ; -NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number - ; - ; - Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 - Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 - S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN - ; - N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL - ; - S OCXTIME=(+$H) - S OCXCKSUM=$$CKSUM(OCXMESS) - ; - S OCXTSP=($H*86400)+$P($H,",",2) - S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) - ; - Q:(OCXTSPL>OCXTSP) 0 - ; - K OCXDATA - S OCXDATA(OCXDFN,0)=OCXDFN - S OCXDATA("B",OCXDFN,OCXDFN)="" - S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP - ; - S OCXGR="^OCXD(860.7" - D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) - ; - K OCXDATA - S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) - S OCXDATA(OCXRUL,"M")=OCXMESS - S OCXDATA("B",OCXRUL,OCXRUL)="" - S OCXGR=OCXGR_","_OCXDFN_",1" - D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) - ; - K OCXDATA - S OCXDATA(OCXREL,0)=OCXREL - S OCXDATA("B",OCXREL,OCXREL)="" - S OCXGR=OCXGR_","_OCXRUL_",1" - D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) - ; - S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D - .; - .N OCXGR1 - .S OCXGR1=OCXGR_","_OCXREL_",1" - .K OCXDATA - .S OCXDATA(OCXELE,0)=OCXELE - .S OCXDATA(OCXELE,"TIME")=OCXTIME - .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) - .S OCXDATA("B",OCXELE,OCXELE)="" - .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) - .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) - .; - .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D - ..N OCXGR2 - ..S OCXGR2=OCXGR1_","_OCXELE_",1" - ..K OCXDATA - ..S OCXDATA(OCXDFI,0)=OCXDFI - ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) - ..S OCXDATA("B",OCXDFI,OCXDFI)="" - ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) - ; - Q 1 - ; -SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data - M @ROOT=DATA - I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) - I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) - ; - Q - ; - ; +OCXOZ0L ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; + ; *************************************************************** + ; ** Warning: This routine is automatically generated by the ** + ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** + ; ** will be lost the next time the rule compiler executes. ** + ; *************************************************************** + ; + Q + ; +R7R1B ; Send Order Check, Notication messages and/or Execute code for Rule #7 'PATIENT ADMISSION' Relation #1 'ADMISSION' + ; Called from R7R1A+10^OCXOZ0K. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT + ; NEWRULE( ---------> NEW RULE MESSAGE + ; + Q:$D(OCXRULE("R7R1B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + S OCXCMSG="" + S OCXNMSG="Admitted on "_$$INT2DT($$GETDATA(DFN,"21^",26),0)_" to "_$$GETDATA(DFN,"21^",83) + ; + Q:$G(OCXOERR) + ; + ; Send Notification + ; + S (OCXDUZ,OCXDATA)="",OCXNUM=0 + I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D + .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) + .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA + I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D + .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" + .S OCXNUM=+$P(OCXORD,U,2) + S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) + S OCXRULE("R7R1B")="" + I $$NEWRULE(DFN,OCXNUM,7,1,18,OCXNMSG) D I 1 + .D:($G(OCXTRACE)<5) EN^ORB3(18,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) + Q + ; +R11R1A ; Verify all Event/Elements of Rule #11 'IMAGING REQUEST CANCELLED/HELD' Relation #1 'CANCELLED AND CANCELED BY NON-ORIG ORDERER' + ; Called from EL31+5^OCXOZ0G, and EL100+5^OCXOZ0G. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE100( ----------> Verify Event/Element: 'CANCELED BY NON-ORIG ORDERING PROVIDER' + ; MCE31( -----------> Verify Event/Element: 'RADIOLOGY ORDER CANCELLED' + ; + Q:$G(^OCXS(860.2,11,"INACT")) + ; + I $$MCE31 D + .I $$MCE100 D R11R1B + Q + ; +R11R1B ; Send Order Check, Notication messages and/or Execute code for Rule #11 'IMAGING REQUEST CANCELLED/HELD' Relation #1 'CANCELLED AND CANCELED BY NON-ORIG ORDERER' + ; Called from R11R1A+12. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; NEWRULE( ---------> NEW RULE MESSAGE + ; + Q:$D(OCXRULE("R11R1B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + S OCXCMSG="" + S OCXNMSG="Imaging request canceled: "_$$GETDATA(DFN,"31^100",105) + ; + Q:$G(OCXOERR) + ; + ; Send Notification + ; + S (OCXDUZ,OCXDATA)="",OCXNUM=0 + I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D + .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) + .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA + I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D + .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" + .S OCXNUM=+$P(OCXORD,U,2) + S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) + S OCXRULE("R11R1B")="" + I $$NEWRULE(DFN,OCXNUM,11,1,26,OCXNMSG) D I 1 + .D:($G(OCXTRACE)<5) EN^ORB3(26,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) + Q + ; +R11R2A ; Verify all Event/Elements of Rule #11 'IMAGING REQUEST CANCELLED/HELD' Relation #2 'ON HOLD AND CANCELED BY NON-ORIG ORDERER' + ; Called from EL100+6^OCXOZ0G, and EL30+5^OCXOZ0G. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE100( ----------> Verify Event/Element: 'CANCELED BY NON-ORIG ORDERING PROVIDER' + ; MCE30( -----------> Verify Event/Element: 'RADIOLOGY ORDER PUT ON-HOLD' + ; + Q:$G(^OCXS(860.2,11,"INACT")) + ; + I $$MCE30 D + .I $$MCE100 D R11R2B^OCXOZ0M + Q + ; +CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM + ; + N CKSUM,PTR,ASC S CKSUM=0 + S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") + F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC + Q +CKSUM + ; +GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data + ; + N OCXE,VAL,PC S VAL="" + F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) + Q VAL + ; +INT2DT(OCXDT,OCXF) ; This Local Extrinsic Function converts an OCX internal format + ; date into an Externl Format (Human Readable) date. 'OCXF=SHORT FORMAT OCXF=LONG FORMAT + ; + Q:'$L($G(OCXDT)) "" S OCXF=+$G(OCXF) + N OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXCYR + S (OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXAP)="" + S OCXSEC=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 + S OCXMIN=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 + S OCXHR=$E(OCXDT#24+100,2,3),OCXDT=OCXDT\24 + S OCXCYR=($H\1461)*4+1841+(($H#1461)\365) + S OCXYR=(OCXDT\1461)*4+1841,OCXDT=OCXDT#1461 + S OCXLPYR=(OCXDT\365),OCXDT=OCXDT-(OCXLPYR*365),OCXYR=OCXYR+OCXLPYR + S OCXCNT="031^059^090^120^151^181^212^243^273^304^334^365" + S:(OCXLPYR=3) OCXCNT="031^060^091^121^152^182^213^244^274^305^335^366" + F OCXMON=1:1:12 Q:(OCXDT<$P(OCXCNT,U,OCXMON)) + S OCXDAY=OCXDT-$P(OCXCNT,U,OCXMON-1)+1 + I OCXF S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,OCXMON) + E S OCXMON=$E(OCXMON+100,2,3) + S OCXAP=$S('OCXHR:"Midnight",(OCXHR=12):"Noon",(OCXHR<12):"AM",1:"PM") + I OCXF S OCXHR=OCXHR#12 S:'OCXHR OCXHR=12 + Q:'OCXF $E(OCXMON+100,2,3)_"/"_$E(OCXDAY+100,2,3)_$S((OCXCYR=OCXYR):" "_OCXHR_":"_OCXMIN,1:"/"_$E(OCXYR,3,4)) + Q:(OCXHR+OCXMIN+OCXSEC) OCXMON_" "_OCXDAY_","_OCXYR_" at "_OCXHR_":"_OCXMIN_"."_OCXSEC_" "_OCXAP + Q OCXMON_" "_OCXDAY_","_OCXYR + ; +MCE100() ; Verify Event/Element: CANCELED BY NON-ORIG ORDERING PROVIDER + ; + ; + N OCXRES + I $L(OCXDF(37)) S OCXRES(100,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),100)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),100)) + Q 0 + ; +MCE30() ; Verify Event/Element: RADIOLOGY ORDER PUT ON-HOLD + ; + ; + N OCXRES + I $L(OCXDF(37)) S OCXRES(30,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),30)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),30)) + Q 0 + ; +MCE31() ; Verify Event/Element: RADIOLOGY ORDER CANCELLED + ; + ; + N OCXRES + I $L(OCXDF(37)) S OCXRES(31,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),31)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),31)) + Q 0 + ; +NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number + ; + ; + Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 + Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 + S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN + ; + N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL + ; + S OCXTIME=(+$H) + S OCXCKSUM=$$CKSUM(OCXMESS) + ; + S OCXTSP=($H*86400)+$P($H,",",2) + S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) + ; + Q:(OCXTSPL>OCXTSP) 0 + ; + K OCXDATA + S OCXDATA(OCXDFN,0)=OCXDFN + S OCXDATA("B",OCXDFN,OCXDFN)="" + S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP + ; + S OCXGR="^OCXD(860.7" + D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) + ; + K OCXDATA + S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) + S OCXDATA(OCXRUL,"M")=OCXMESS + S OCXDATA("B",OCXRUL,OCXRUL)="" + S OCXGR=OCXGR_","_OCXDFN_",1" + D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) + ; + K OCXDATA + S OCXDATA(OCXREL,0)=OCXREL + S OCXDATA("B",OCXREL,OCXREL)="" + S OCXGR=OCXGR_","_OCXRUL_",1" + D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) + ; + S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D + .; + .N OCXGR1 + .S OCXGR1=OCXGR_","_OCXREL_",1" + .K OCXDATA + .S OCXDATA(OCXELE,0)=OCXELE + .S OCXDATA(OCXELE,"TIME")=OCXTIME + .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) + .S OCXDATA("B",OCXELE,OCXELE)="" + .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) + .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) + .; + .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D + ..N OCXGR2 + ..S OCXGR2=OCXGR1_","_OCXELE_",1" + ..K OCXDATA + ..S OCXDATA(OCXDFI,0)=OCXDFI + ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) + ..S OCXDATA("B",OCXDFI,OCXDFI)="" + ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) + ; + Q 1 + ; +SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data + M @ROOT=DATA + I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) + I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) + ; + Q + ; + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0M.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0M.m index 12da0e23..13294a67 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0M.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0M.m @@ -1,263 +1,263 @@ -OCXOZ0M ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; - ; *************************************************************** - ; ** Warning: This routine is automatically generated by the ** - ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** - ; ** will be lost the next time the rule compiler executes. ** - ; *************************************************************** - ; - Q - ; -R11R2B ; Send Order Check, Notication messages and/or Execute code for Rule #11 'IMAGING REQUEST CANCELLED/HELD' Relation #2 'ON HOLD AND CANCELED BY NON-ORIG ORDERER' - ; Called from R11R2A+12^OCXOZ0L. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; NEWRULE( ---------> NEW RULE MESSAGE - ; - Q:$D(OCXRULE("R11R2B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - S OCXCMSG="" - S OCXNMSG="Imaging request held: "_$$GETDATA(DFN,"30^100",105) - ; - Q:$G(OCXOERR) - ; - ; Send Notification - ; - S (OCXDUZ,OCXDATA)="",OCXNUM=0 - I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D - .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) - .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA - I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D - .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" - .S OCXNUM=+$P(OCXORD,U,2) - S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) - S OCXRULE("R11R2B")="" - I $$NEWRULE(DFN,OCXNUM,11,2,26,OCXNMSG) D I 1 - .D:($G(OCXTRACE)<5) EN^ORB3(26,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) - Q - ; -R11R3A ; Verify all Event/Elements of Rule #11 'IMAGING REQUEST CANCELLED/HELD' Relation #3 'DISCONTINUED AND CANCELED BY NON-ORIG ORDERER' - ; Called from EL100+7^OCXOZ0G, and EL32+5^OCXOZ0G. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE100( ----------> Verify Event/Element: 'CANCELED BY NON-ORIG ORDERING PROVIDER' - ; MCE32( -----------> Verify Event/Element: 'RADIOLOGY ORDER DISCONTINUED' - ; - Q:$G(^OCXS(860.2,11,"INACT")) - ; - I $$MCE32 D - .I $$MCE100 D R11R3B - Q - ; -R11R3B ; Send Order Check, Notication messages and/or Execute code for Rule #11 'IMAGING REQUEST CANCELLED/HELD' Relation #3 'DISCONTINUED AND CANCELED BY NON-ORIG ORDERER' - ; Called from R11R3A+12. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; NEWRULE( ---------> NEW RULE MESSAGE - ; - Q:$D(OCXRULE("R11R3B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - S OCXCMSG="" - S OCXNMSG="Imaging request discontinued: "_$$GETDATA(DFN,"32^100",105) - ; - Q:$G(OCXOERR) - ; - ; Send Notification - ; - S (OCXDUZ,OCXDATA)="",OCXNUM=0 - I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D - .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) - .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA - I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D - .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" - .S OCXNUM=+$P(OCXORD,U,2) - S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) - S OCXRULE("R11R3B")="" - I $$NEWRULE(DFN,OCXNUM,11,3,26,OCXNMSG) D I 1 - .D:($G(OCXTRACE)<5) EN^ORB3(26,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) - Q - ; -R16R1A ; Verify all Event/Elements of Rule #16 'SERVICE ORDER REQUIRES CHART SIGNATURE' Relation #1 'SERVICE' - ; Called from EL46+5^OCXOZ0G. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE46( -----------> Verify Event/Element: 'SERVICE ORDER REQUIRES CHART SIGNATURE' - ; - Q:$G(^OCXS(860.2,16,"INACT")) - ; - I $$MCE46 D R16R1B - Q - ; -R16R1B ; Send Order Check, Notication messages and/or Execute code for Rule #16 'SERVICE ORDER REQUIRES CHART SIGNATURE' Relation #1 'SERVICE' - ; Called from R16R1A+10. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; NEWRULE( ---------> NEW RULE MESSAGE - ; - Q:$D(OCXRULE("R16R1B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - S OCXCMSG="" - S OCXNMSG="Service order - requires chart signature." - ; - Q:$G(OCXOERR) - ; - ; Send Notification - ; - S (OCXDUZ,OCXDATA)="",OCXNUM=0 - I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D - .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) - .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA - I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D - .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" - .S OCXNUM=+$P(OCXORD,U,2) - S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) - S OCXRULE("R16R1B")="" - I $$NEWRULE(DFN,OCXNUM,16,1,28,OCXNMSG) D I 1 - .D:($G(OCXTRACE)<5) EN^ORB3(28,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) - Q - ; -R18R1A ; Verify all Event/Elements of Rule #18 'STAT RESULTS AVAILABLE' Relation #1 'STAT LAB RESULT' - ; Called from EL76+5^OCXOZ0G. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE76( -----------> Verify Event/Element: 'STAT LAB RESULT' - ; - Q:$G(^OCXS(860.2,18,"INACT")) - ; - I $$MCE76 D R18R1B^OCXOZ0N - Q - ; -CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM - ; - N CKSUM,PTR,ASC S CKSUM=0 - S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") - F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC - Q +CKSUM - ; -GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data - ; - N OCXE,VAL,PC S VAL="" - F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) - Q VAL - ; -MCE100() ; Verify Event/Element: CANCELED BY NON-ORIG ORDERING PROVIDER - ; - ; - N OCXRES - I $L(OCXDF(37)) S OCXRES(100,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),100)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),100)) - Q 0 - ; -MCE32() ; Verify Event/Element: RADIOLOGY ORDER DISCONTINUED - ; - ; - N OCXRES - I $L(OCXDF(37)) S OCXRES(32,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),32)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),32)) - Q 0 - ; -MCE46() ; Verify Event/Element: SERVICE ORDER REQUIRES CHART SIGNATURE - ; - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$P($G(OCXORD),"^",1) I $L(OCXDF(37)) S OCXRES(46,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),46)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),46)) - Q 0 - ; -MCE76() ; Verify Event/Element: STAT LAB RESULT - ; - ; - N OCXRES - I $L(OCXDF(37)) S OCXRES(76,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),76)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),76)) - Q 0 - ; -NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number - ; - ; - Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 - Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 - S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN - ; - N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL - ; - S OCXTIME=(+$H) - S OCXCKSUM=$$CKSUM(OCXMESS) - ; - S OCXTSP=($H*86400)+$P($H,",",2) - S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) - ; - Q:(OCXTSPL>OCXTSP) 0 - ; - K OCXDATA - S OCXDATA(OCXDFN,0)=OCXDFN - S OCXDATA("B",OCXDFN,OCXDFN)="" - S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP - ; - S OCXGR="^OCXD(860.7" - D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) - ; - K OCXDATA - S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) - S OCXDATA(OCXRUL,"M")=OCXMESS - S OCXDATA("B",OCXRUL,OCXRUL)="" - S OCXGR=OCXGR_","_OCXDFN_",1" - D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) - ; - K OCXDATA - S OCXDATA(OCXREL,0)=OCXREL - S OCXDATA("B",OCXREL,OCXREL)="" - S OCXGR=OCXGR_","_OCXRUL_",1" - D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) - ; - S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D - .; - .N OCXGR1 - .S OCXGR1=OCXGR_","_OCXREL_",1" - .K OCXDATA - .S OCXDATA(OCXELE,0)=OCXELE - .S OCXDATA(OCXELE,"TIME")=OCXTIME - .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) - .S OCXDATA("B",OCXELE,OCXELE)="" - .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) - .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) - .; - .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D - ..N OCXGR2 - ..S OCXGR2=OCXGR1_","_OCXELE_",1" - ..K OCXDATA - ..S OCXDATA(OCXDFI,0)=OCXDFI - ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) - ..S OCXDATA("B",OCXDFI,OCXDFI)="" - ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) - ; - Q 1 - ; -SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data - M @ROOT=DATA - I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) - I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) - ; - Q - ; - ; +OCXOZ0M ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; + ; *************************************************************** + ; ** Warning: This routine is automatically generated by the ** + ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** + ; ** will be lost the next time the rule compiler executes. ** + ; *************************************************************** + ; + Q + ; +R11R2B ; Send Order Check, Notication messages and/or Execute code for Rule #11 'IMAGING REQUEST CANCELLED/HELD' Relation #2 'ON HOLD AND CANCELED BY NON-ORIG ORDERER' + ; Called from R11R2A+12^OCXOZ0L. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; NEWRULE( ---------> NEW RULE MESSAGE + ; + Q:$D(OCXRULE("R11R2B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + S OCXCMSG="" + S OCXNMSG="Imaging request held: "_$$GETDATA(DFN,"30^100",105) + ; + Q:$G(OCXOERR) + ; + ; Send Notification + ; + S (OCXDUZ,OCXDATA)="",OCXNUM=0 + I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D + .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) + .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA + I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D + .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" + .S OCXNUM=+$P(OCXORD,U,2) + S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) + S OCXRULE("R11R2B")="" + I $$NEWRULE(DFN,OCXNUM,11,2,26,OCXNMSG) D I 1 + .D:($G(OCXTRACE)<5) EN^ORB3(26,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) + Q + ; +R11R3A ; Verify all Event/Elements of Rule #11 'IMAGING REQUEST CANCELLED/HELD' Relation #3 'DISCONTINUED AND CANCELED BY NON-ORIG ORDERER' + ; Called from EL100+7^OCXOZ0G, and EL32+5^OCXOZ0G. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE100( ----------> Verify Event/Element: 'CANCELED BY NON-ORIG ORDERING PROVIDER' + ; MCE32( -----------> Verify Event/Element: 'RADIOLOGY ORDER DISCONTINUED' + ; + Q:$G(^OCXS(860.2,11,"INACT")) + ; + I $$MCE32 D + .I $$MCE100 D R11R3B + Q + ; +R11R3B ; Send Order Check, Notication messages and/or Execute code for Rule #11 'IMAGING REQUEST CANCELLED/HELD' Relation #3 'DISCONTINUED AND CANCELED BY NON-ORIG ORDERER' + ; Called from R11R3A+12. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; NEWRULE( ---------> NEW RULE MESSAGE + ; + Q:$D(OCXRULE("R11R3B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + S OCXCMSG="" + S OCXNMSG="Imaging request discontinued: "_$$GETDATA(DFN,"32^100",105) + ; + Q:$G(OCXOERR) + ; + ; Send Notification + ; + S (OCXDUZ,OCXDATA)="",OCXNUM=0 + I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D + .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) + .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA + I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D + .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" + .S OCXNUM=+$P(OCXORD,U,2) + S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) + S OCXRULE("R11R3B")="" + I $$NEWRULE(DFN,OCXNUM,11,3,26,OCXNMSG) D I 1 + .D:($G(OCXTRACE)<5) EN^ORB3(26,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) + Q + ; +R16R1A ; Verify all Event/Elements of Rule #16 'SERVICE ORDER REQUIRES CHART SIGNATURE' Relation #1 'SERVICE' + ; Called from EL46+5^OCXOZ0G. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE46( -----------> Verify Event/Element: 'SERVICE ORDER REQUIRES CHART SIGNATURE' + ; + Q:$G(^OCXS(860.2,16,"INACT")) + ; + I $$MCE46 D R16R1B + Q + ; +R16R1B ; Send Order Check, Notication messages and/or Execute code for Rule #16 'SERVICE ORDER REQUIRES CHART SIGNATURE' Relation #1 'SERVICE' + ; Called from R16R1A+10. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; NEWRULE( ---------> NEW RULE MESSAGE + ; + Q:$D(OCXRULE("R16R1B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + S OCXCMSG="" + S OCXNMSG="Service order - requires chart signature." + ; + Q:$G(OCXOERR) + ; + ; Send Notification + ; + S (OCXDUZ,OCXDATA)="",OCXNUM=0 + I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D + .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) + .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA + I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D + .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" + .S OCXNUM=+$P(OCXORD,U,2) + S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) + S OCXRULE("R16R1B")="" + I $$NEWRULE(DFN,OCXNUM,16,1,28,OCXNMSG) D I 1 + .D:($G(OCXTRACE)<5) EN^ORB3(28,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) + Q + ; +R18R1A ; Verify all Event/Elements of Rule #18 'STAT RESULTS AVAILABLE' Relation #1 'STAT LAB RESULT' + ; Called from EL76+5^OCXOZ0G. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE76( -----------> Verify Event/Element: 'STAT LAB RESULT' + ; + Q:$G(^OCXS(860.2,18,"INACT")) + ; + I $$MCE76 D R18R1B^OCXOZ0N + Q + ; +CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM + ; + N CKSUM,PTR,ASC S CKSUM=0 + S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") + F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC + Q +CKSUM + ; +GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data + ; + N OCXE,VAL,PC S VAL="" + F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) + Q VAL + ; +MCE100() ; Verify Event/Element: CANCELED BY NON-ORIG ORDERING PROVIDER + ; + ; + N OCXRES + I $L(OCXDF(37)) S OCXRES(100,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),100)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),100)) + Q 0 + ; +MCE32() ; Verify Event/Element: RADIOLOGY ORDER DISCONTINUED + ; + ; + N OCXRES + I $L(OCXDF(37)) S OCXRES(32,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),32)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),32)) + Q 0 + ; +MCE46() ; Verify Event/Element: SERVICE ORDER REQUIRES CHART SIGNATURE + ; + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$P($G(OCXORD),"^",1) I $L(OCXDF(37)) S OCXRES(46,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),46)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),46)) + Q 0 + ; +MCE76() ; Verify Event/Element: STAT LAB RESULT + ; + ; + N OCXRES + I $L(OCXDF(37)) S OCXRES(76,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),76)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),76)) + Q 0 + ; +NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number + ; + ; + Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 + Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 + S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN + ; + N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL + ; + S OCXTIME=(+$H) + S OCXCKSUM=$$CKSUM(OCXMESS) + ; + S OCXTSP=($H*86400)+$P($H,",",2) + S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) + ; + Q:(OCXTSPL>OCXTSP) 0 + ; + K OCXDATA + S OCXDATA(OCXDFN,0)=OCXDFN + S OCXDATA("B",OCXDFN,OCXDFN)="" + S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP + ; + S OCXGR="^OCXD(860.7" + D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) + ; + K OCXDATA + S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) + S OCXDATA(OCXRUL,"M")=OCXMESS + S OCXDATA("B",OCXRUL,OCXRUL)="" + S OCXGR=OCXGR_","_OCXDFN_",1" + D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) + ; + K OCXDATA + S OCXDATA(OCXREL,0)=OCXREL + S OCXDATA("B",OCXREL,OCXREL)="" + S OCXGR=OCXGR_","_OCXRUL_",1" + D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) + ; + S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D + .; + .N OCXGR1 + .S OCXGR1=OCXGR_","_OCXREL_",1" + .K OCXDATA + .S OCXDATA(OCXELE,0)=OCXELE + .S OCXDATA(OCXELE,"TIME")=OCXTIME + .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) + .S OCXDATA("B",OCXELE,OCXELE)="" + .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) + .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) + .; + .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D + ..N OCXGR2 + ..S OCXGR2=OCXGR1_","_OCXELE_",1" + ..K OCXDATA + ..S OCXDATA(OCXDFI,0)=OCXDFI + ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) + ..S OCXDATA("B",OCXDFI,OCXDFI)="" + ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) + ; + Q 1 + ; +SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data + M @ROOT=DATA + I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) + I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) + ; + Q + ; + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0N.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0N.m index 0ff5068f..5bbbdcc9 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0N.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0N.m @@ -1,254 +1,254 @@ -OCXOZ0N ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; - ; *************************************************************** - ; ** Warning: This routine is automatically generated by the ** - ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** - ; ** will be lost the next time the rule compiler executes. ** - ; *************************************************************** - ; - Q - ; -R18R1B ; Send Order Check, Notication messages and/or Execute code for Rule #18 'STAT RESULTS AVAILABLE' Relation #1 'STAT LAB RESULT' - ; Called from R18R1A+10^OCXOZ0M. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; NEWRULE( ---------> NEW RULE MESSAGE - ; - Q:$D(OCXRULE("R18R1B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - S OCXCMSG="" - S OCXNMSG="STAT lab results: ["_$$GETDATA(DFN,"76^",96)_"]" - ; - Q:$G(OCXOERR) - ; - ; Send Notification - ; - S (OCXDUZ,OCXDATA)="",OCXNUM=0 - I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D - .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) - .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA - I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D - .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" - .S OCXNUM=+$P(OCXORD,U,2) - S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) - S OCXRULE("R18R1B")="" - I $$NEWRULE(DFN,OCXNUM,18,1,44,OCXNMSG) D I 1 - .D:($G(OCXTRACE)<5) EN^ORB3(44,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) - Q - ; -R18R2A ; Verify all Event/Elements of Rule #18 'STAT RESULTS AVAILABLE' Relation #2 'STAT IMAGING RESULT' - ; Called from EL75+5^OCXOZ0G. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE75( -----------> Verify Event/Element: 'STAT IMAGING RESULT' - ; - Q:$G(^OCXS(860.2,18,"INACT")) - ; - I $$MCE75 D R18R2B - Q - ; -R18R2B ; Send Order Check, Notication messages and/or Execute code for Rule #18 'STAT RESULTS AVAILABLE' Relation #2 'STAT IMAGING RESULT' - ; Called from R18R2A+10. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; NEWRULE( ---------> NEW RULE MESSAGE - ; - Q:$D(OCXRULE("R18R2B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - S OCXCMSG="" - S OCXNMSG="STAT imaging results: "_$$GETDATA(DFN,"75^",24) - ; - Q:$G(OCXOERR) - ; - ; Send Notification - ; - S (OCXDUZ,OCXDATA)="",OCXNUM=0 - I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D - .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) - .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA - I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D - .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" - .S OCXNUM=+$P(OCXORD,U,2) - S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) - S OCXRULE("R18R2B")="" - I $$NEWRULE(DFN,OCXNUM,18,2,44,OCXNMSG) D I 1 - .D:($G(OCXTRACE)<5) EN^ORB3(44,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) - Q - ; -R18R3A ; Verify all Event/Elements of Rule #18 'STAT RESULTS AVAILABLE' Relation #3 'STAT CONSULT RESULT' - ; Called from EL110+5^OCXOZ0G. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE110( ----------> Verify Event/Element: 'STAT CONSULT RESULT' - ; - Q:$G(^OCXS(860.2,18,"INACT")) - ; - I $$MCE110 D R18R3B - Q - ; -R18R3B ; Send Order Check, Notication messages and/or Execute code for Rule #18 'STAT RESULTS AVAILABLE' Relation #3 'STAT CONSULT RESULT' - ; Called from R18R3A+10. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; NEWRULE( ---------> NEW RULE MESSAGE - ; - Q:$D(OCXRULE("R18R3B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - S OCXCMSG="" - S OCXNMSG="STAT consult results: "_$$GETDATA(DFN,"110^",24) - ; - Q:$G(OCXOERR) - ; - ; Send Notification - ; - S (OCXDUZ,OCXDATA)="",OCXNUM=0 - I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D - .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) - .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA - I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D - .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" - .S OCXNUM=+$P(OCXORD,U,2) - S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) - S OCXRULE("R18R3B")="" - I $$NEWRULE(DFN,OCXNUM,18,3,44,OCXNMSG) D I 1 - .D:($G(OCXTRACE)<5) EN^ORB3(44,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) - Q - ; -R19R1A ; Verify all Event/Elements of Rule #19 'PATIENT DISCHARGE' Relation #1 'DISCHARGE' - ; Called from EL56+5^OCXOZ0H. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE56( -----------> Verify Event/Element: 'PATIENT DISCHARGE' - ; - Q:$G(^OCXS(860.2,19,"INACT")) - ; - I $$MCE56 D R19R1B^OCXOZ0O - Q - ; -CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM - ; - N CKSUM,PTR,ASC S CKSUM=0 - S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") - F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC - Q +CKSUM - ; -GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data - ; - N OCXE,VAL,PC S VAL="" - F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) - Q VAL - ; -MCE110() ; Verify Event/Element: STAT CONSULT RESULT - ; - ; - N OCXRES - I $L(OCXDF(37)) S OCXRES(110,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),110)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),110)) - Q 0 - ; -MCE56() ; Verify Event/Element: PATIENT DISCHARGE - ; - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(56,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),56)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),56)) - Q 0 - ; -MCE75() ; Verify Event/Element: STAT IMAGING RESULT - ; - ; - N OCXRES - I $L(OCXDF(37)) S OCXRES(75,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),75)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),75)) - Q 0 - ; -NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number - ; - ; - Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 - Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 - S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN - ; - N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL - ; - S OCXTIME=(+$H) - S OCXCKSUM=$$CKSUM(OCXMESS) - ; - S OCXTSP=($H*86400)+$P($H,",",2) - S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) - ; - Q:(OCXTSPL>OCXTSP) 0 - ; - K OCXDATA - S OCXDATA(OCXDFN,0)=OCXDFN - S OCXDATA("B",OCXDFN,OCXDFN)="" - S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP - ; - S OCXGR="^OCXD(860.7" - D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) - ; - K OCXDATA - S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) - S OCXDATA(OCXRUL,"M")=OCXMESS - S OCXDATA("B",OCXRUL,OCXRUL)="" - S OCXGR=OCXGR_","_OCXDFN_",1" - D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) - ; - K OCXDATA - S OCXDATA(OCXREL,0)=OCXREL - S OCXDATA("B",OCXREL,OCXREL)="" - S OCXGR=OCXGR_","_OCXRUL_",1" - D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) - ; - S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D - .; - .N OCXGR1 - .S OCXGR1=OCXGR_","_OCXREL_",1" - .K OCXDATA - .S OCXDATA(OCXELE,0)=OCXELE - .S OCXDATA(OCXELE,"TIME")=OCXTIME - .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) - .S OCXDATA("B",OCXELE,OCXELE)="" - .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) - .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) - .; - .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D - ..N OCXGR2 - ..S OCXGR2=OCXGR1_","_OCXELE_",1" - ..K OCXDATA - ..S OCXDATA(OCXDFI,0)=OCXDFI - ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) - ..S OCXDATA("B",OCXDFI,OCXDFI)="" - ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) - ; - Q 1 - ; -SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data - M @ROOT=DATA - I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) - I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) - ; - Q - ; - ; +OCXOZ0N ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; + ; *************************************************************** + ; ** Warning: This routine is automatically generated by the ** + ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** + ; ** will be lost the next time the rule compiler executes. ** + ; *************************************************************** + ; + Q + ; +R18R1B ; Send Order Check, Notication messages and/or Execute code for Rule #18 'STAT RESULTS AVAILABLE' Relation #1 'STAT LAB RESULT' + ; Called from R18R1A+10^OCXOZ0M. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; NEWRULE( ---------> NEW RULE MESSAGE + ; + Q:$D(OCXRULE("R18R1B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + S OCXCMSG="" + S OCXNMSG="STAT lab results: ["_$$GETDATA(DFN,"76^",96)_"]" + ; + Q:$G(OCXOERR) + ; + ; Send Notification + ; + S (OCXDUZ,OCXDATA)="",OCXNUM=0 + I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D + .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) + .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA + I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D + .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" + .S OCXNUM=+$P(OCXORD,U,2) + S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) + S OCXRULE("R18R1B")="" + I $$NEWRULE(DFN,OCXNUM,18,1,44,OCXNMSG) D I 1 + .D:($G(OCXTRACE)<5) EN^ORB3(44,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) + Q + ; +R18R2A ; Verify all Event/Elements of Rule #18 'STAT RESULTS AVAILABLE' Relation #2 'STAT IMAGING RESULT' + ; Called from EL75+5^OCXOZ0G. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE75( -----------> Verify Event/Element: 'STAT IMAGING RESULT' + ; + Q:$G(^OCXS(860.2,18,"INACT")) + ; + I $$MCE75 D R18R2B + Q + ; +R18R2B ; Send Order Check, Notication messages and/or Execute code for Rule #18 'STAT RESULTS AVAILABLE' Relation #2 'STAT IMAGING RESULT' + ; Called from R18R2A+10. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; NEWRULE( ---------> NEW RULE MESSAGE + ; + Q:$D(OCXRULE("R18R2B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + S OCXCMSG="" + S OCXNMSG="STAT imaging results: "_$$GETDATA(DFN,"75^",24) + ; + Q:$G(OCXOERR) + ; + ; Send Notification + ; + S (OCXDUZ,OCXDATA)="",OCXNUM=0 + I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D + .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) + .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA + I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D + .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" + .S OCXNUM=+$P(OCXORD,U,2) + S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) + S OCXRULE("R18R2B")="" + I $$NEWRULE(DFN,OCXNUM,18,2,44,OCXNMSG) D I 1 + .D:($G(OCXTRACE)<5) EN^ORB3(44,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) + Q + ; +R18R3A ; Verify all Event/Elements of Rule #18 'STAT RESULTS AVAILABLE' Relation #3 'STAT CONSULT RESULT' + ; Called from EL110+5^OCXOZ0G. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE110( ----------> Verify Event/Element: 'STAT CONSULT RESULT' + ; + Q:$G(^OCXS(860.2,18,"INACT")) + ; + I $$MCE110 D R18R3B + Q + ; +R18R3B ; Send Order Check, Notication messages and/or Execute code for Rule #18 'STAT RESULTS AVAILABLE' Relation #3 'STAT CONSULT RESULT' + ; Called from R18R3A+10. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; NEWRULE( ---------> NEW RULE MESSAGE + ; + Q:$D(OCXRULE("R18R3B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + S OCXCMSG="" + S OCXNMSG="STAT consult results: "_$$GETDATA(DFN,"110^",24) + ; + Q:$G(OCXOERR) + ; + ; Send Notification + ; + S (OCXDUZ,OCXDATA)="",OCXNUM=0 + I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D + .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) + .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA + I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D + .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" + .S OCXNUM=+$P(OCXORD,U,2) + S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) + S OCXRULE("R18R3B")="" + I $$NEWRULE(DFN,OCXNUM,18,3,44,OCXNMSG) D I 1 + .D:($G(OCXTRACE)<5) EN^ORB3(44,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) + Q + ; +R19R1A ; Verify all Event/Elements of Rule #19 'PATIENT DISCHARGE' Relation #1 'DISCHARGE' + ; Called from EL56+5^OCXOZ0G. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE56( -----------> Verify Event/Element: 'PATIENT DISCHARGE' + ; + Q:$G(^OCXS(860.2,19,"INACT")) + ; + I $$MCE56 D R19R1B^OCXOZ0O + Q + ; +CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM + ; + N CKSUM,PTR,ASC S CKSUM=0 + S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") + F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC + Q +CKSUM + ; +GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data + ; + N OCXE,VAL,PC S VAL="" + F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) + Q VAL + ; +MCE110() ; Verify Event/Element: STAT CONSULT RESULT + ; + ; + N OCXRES + I $L(OCXDF(37)) S OCXRES(110,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),110)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),110)) + Q 0 + ; +MCE56() ; Verify Event/Element: PATIENT DISCHARGE + ; + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(56,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),56)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),56)) + Q 0 + ; +MCE75() ; Verify Event/Element: STAT IMAGING RESULT + ; + ; + N OCXRES + I $L(OCXDF(37)) S OCXRES(75,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),75)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),75)) + Q 0 + ; +NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number + ; + ; + Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 + Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 + S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN + ; + N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL + ; + S OCXTIME=(+$H) + S OCXCKSUM=$$CKSUM(OCXMESS) + ; + S OCXTSP=($H*86400)+$P($H,",",2) + S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) + ; + Q:(OCXTSPL>OCXTSP) 0 + ; + K OCXDATA + S OCXDATA(OCXDFN,0)=OCXDFN + S OCXDATA("B",OCXDFN,OCXDFN)="" + S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP + ; + S OCXGR="^OCXD(860.7" + D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) + ; + K OCXDATA + S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) + S OCXDATA(OCXRUL,"M")=OCXMESS + S OCXDATA("B",OCXRUL,OCXRUL)="" + S OCXGR=OCXGR_","_OCXDFN_",1" + D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) + ; + K OCXDATA + S OCXDATA(OCXREL,0)=OCXREL + S OCXDATA("B",OCXREL,OCXREL)="" + S OCXGR=OCXGR_","_OCXRUL_",1" + D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) + ; + S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D + .; + .N OCXGR1 + .S OCXGR1=OCXGR_","_OCXREL_",1" + .K OCXDATA + .S OCXDATA(OCXELE,0)=OCXELE + .S OCXDATA(OCXELE,"TIME")=OCXTIME + .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) + .S OCXDATA("B",OCXELE,OCXELE)="" + .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) + .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) + .; + .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D + ..N OCXGR2 + ..S OCXGR2=OCXGR1_","_OCXELE_",1" + ..K OCXDATA + ..S OCXDATA(OCXDFI,0)=OCXDFI + ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) + ..S OCXDATA("B",OCXDFI,OCXDFI)="" + ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) + ; + Q 1 + ; +SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data + M @ROOT=DATA + I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) + I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) + ; + Q + ; + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0O.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0O.m index 8ec077da..2ea87968 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0O.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0O.m @@ -1,255 +1,255 @@ -OCXOZ0O ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; - ; *************************************************************** - ; ** Warning: This routine is automatically generated by the ** - ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** - ; ** will be lost the next time the rule compiler executes. ** - ; *************************************************************** - ; - Q - ; -R19R1B ; Send Order Check, Notication messages and/or Execute code for Rule #19 'PATIENT DISCHARGE' Relation #1 'DISCHARGE' - ; Called from R19R1A+10^OCXOZ0N. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT - ; NEWRULE( ---------> NEW RULE MESSAGE - ; - Q:$D(OCXRULE("R19R1B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - S OCXCMSG="" - S OCXNMSG="Discharged on "_$$INT2DT($$GETDATA(DFN,"56^",26),0) - ; - Q:$G(OCXOERR) - ; - ; Send Notification - ; - S (OCXDUZ,OCXDATA)="",OCXNUM=0 - I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D - .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) - .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA - I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D - .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" - .S OCXNUM=+$P(OCXORD,U,2) - S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) - S OCXRULE("R19R1B")="" - I $$NEWRULE(DFN,OCXNUM,19,1,35,OCXNMSG) D I 1 - .D:($G(OCXTRACE)<5) EN^ORB3(35,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) - Q - ; -R22R1A ; Verify all Event/Elements of Rule #22 'ORDER REQUIRES CO-SIGNATURE' Relation #1 'COSIG' - ; Called from EL47+5^OCXOZ0H. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE47( -----------> Verify Event/Element: 'ORDER REQUIRES CO-SIGNATURE' - ; - Q:$G(^OCXS(860.2,22,"INACT")) - ; - I $$MCE47 D R22R1B - Q - ; -R22R1B ; Send Order Check, Notication messages and/or Execute code for Rule #22 'ORDER REQUIRES CO-SIGNATURE' Relation #1 'COSIG' - ; Called from R22R1A+10. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; NEWRULE( ---------> NEW RULE MESSAGE - ; - Q:$D(OCXRULE("R22R1B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - S OCXCMSG="" - S OCXNMSG="Order requires a co-signature" - ; - Q:$G(OCXOERR) - ; - ; Send Notification - ; - S (OCXDUZ,OCXDATA)="",OCXNUM=0 - I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D - .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) - .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA - I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D - .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" - .S OCXNUM=+$P(OCXORD,U,2) - S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) - S OCXRULE("R22R1B")="" - I $$NEWRULE(DFN,OCXNUM,22,1,37,OCXNMSG) D I 1 - .D:($G(OCXTRACE)<5) EN^ORB3(37,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) - Q - ; -R24R1A ; Verify all Event/Elements of Rule #24 'ORDERER FLAGGED RESULTS AVAILABLE' Relation #1 'ORDER FLAGGED FOR RESULTS AND (LAB RESULT OR IMAGI...' - ; Called from EL5+5^OCXOZ0H, and EL49+5^OCXOZ0H, and EL55+5^OCXOZ0H, and EL101+5^OCXOZ0H. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE101( ----------> Verify Event/Element: 'HL7 FINAL IMAGING RESULT' - ; MCE49( -----------> Verify Event/Element: 'ORDER FLAGGED FOR RESULTS' - ; MCE5( ------------> Verify Event/Element: 'HL7 FINAL LAB RESULT' - ; MCE55( -----------> Verify Event/Element: 'CONSULT FINAL RESULTS' - ; - Q:$G(^OCXS(860.2,24,"INACT")) - ; - I $$MCE49 D - .I $$MCE5 D R24R1B^OCXOZ0P - .I $$MCE101 D R24R1B^OCXOZ0P - .I $$MCE55 D R24R1B^OCXOZ0P - Q - ; -CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM - ; - N CKSUM,PTR,ASC S CKSUM=0 - S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") - F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC - Q +CKSUM - ; -GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data - ; - N OCXE,VAL,PC S VAL="" - F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) - Q VAL - ; -INT2DT(OCXDT,OCXF) ; This Local Extrinsic Function converts an OCX internal format - ; date into an Externl Format (Human Readable) date. 'OCXF=SHORT FORMAT OCXF=LONG FORMAT - ; - Q:'$L($G(OCXDT)) "" S OCXF=+$G(OCXF) - N OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXCYR - S (OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXAP)="" - S OCXSEC=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 - S OCXMIN=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 - S OCXHR=$E(OCXDT#24+100,2,3),OCXDT=OCXDT\24 - S OCXCYR=($H\1461)*4+1841+(($H#1461)\365) - S OCXYR=(OCXDT\1461)*4+1841,OCXDT=OCXDT#1461 - S OCXLPYR=(OCXDT\365),OCXDT=OCXDT-(OCXLPYR*365),OCXYR=OCXYR+OCXLPYR - S OCXCNT="031^059^090^120^151^181^212^243^273^304^334^365" - S:(OCXLPYR=3) OCXCNT="031^060^091^121^152^182^213^244^274^305^335^366" - F OCXMON=1:1:12 Q:(OCXDT<$P(OCXCNT,U,OCXMON)) - S OCXDAY=OCXDT-$P(OCXCNT,U,OCXMON-1)+1 - I OCXF S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,OCXMON) - E S OCXMON=$E(OCXMON+100,2,3) - S OCXAP=$S('OCXHR:"Midnight",(OCXHR=12):"Noon",(OCXHR<12):"AM",1:"PM") - I OCXF S OCXHR=OCXHR#12 S:'OCXHR OCXHR=12 - Q:'OCXF $E(OCXMON+100,2,3)_"/"_$E(OCXDAY+100,2,3)_$S((OCXCYR=OCXYR):" "_OCXHR_":"_OCXMIN,1:"/"_$E(OCXYR,3,4)) - Q:(OCXHR+OCXMIN+OCXSEC) OCXMON_" "_OCXDAY_","_OCXYR_" at "_OCXHR_":"_OCXMIN_"."_OCXSEC_" "_OCXAP - Q OCXMON_" "_OCXDAY_","_OCXYR - ; -MCE101() ; Verify Event/Element: HL7 FINAL IMAGING RESULT - ; - ; - N OCXRES - I $L(OCXDF(37)) S OCXRES(101,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),101)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),101)) - Q 0 - ; -MCE47() ; Verify Event/Element: ORDER REQUIRES CO-SIGNATURE - ; - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$P($G(OCXORD),"^",1) I $L(OCXDF(37)) S OCXRES(47,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),47)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),47)) - Q 0 - ; -MCE49() ; Verify Event/Element: ORDER FLAGGED FOR RESULTS - ; - ; - N OCXRES - I $L(OCXDF(37)) S OCXRES(49,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),49)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),49)) - Q 0 - ; -MCE5() ; Verify Event/Element: HL7 FINAL LAB RESULT - ; - ; - N OCXRES - I $L(OCXDF(37)) S OCXRES(5,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),5)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),5)) - Q 0 - ; -MCE55() ; Verify Event/Element: CONSULT FINAL RESULTS - ; - ; - N OCXRES - I $L(OCXDF(37)) S OCXRES(55,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),55)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),55)) - Q 0 - ; -NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number - ; - ; - Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 - Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 - S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN - ; - N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL - ; - S OCXTIME=(+$H) - S OCXCKSUM=$$CKSUM(OCXMESS) - ; - S OCXTSP=($H*86400)+$P($H,",",2) - S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) - ; - Q:(OCXTSPL>OCXTSP) 0 - ; - K OCXDATA - S OCXDATA(OCXDFN,0)=OCXDFN - S OCXDATA("B",OCXDFN,OCXDFN)="" - S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP - ; - S OCXGR="^OCXD(860.7" - D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) - ; - K OCXDATA - S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) - S OCXDATA(OCXRUL,"M")=OCXMESS - S OCXDATA("B",OCXRUL,OCXRUL)="" - S OCXGR=OCXGR_","_OCXDFN_",1" - D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) - ; - K OCXDATA - S OCXDATA(OCXREL,0)=OCXREL - S OCXDATA("B",OCXREL,OCXREL)="" - S OCXGR=OCXGR_","_OCXRUL_",1" - D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) - ; - S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D - .; - .N OCXGR1 - .S OCXGR1=OCXGR_","_OCXREL_",1" - .K OCXDATA - .S OCXDATA(OCXELE,0)=OCXELE - .S OCXDATA(OCXELE,"TIME")=OCXTIME - .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) - .S OCXDATA("B",OCXELE,OCXELE)="" - .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) - .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) - .; - .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D - ..N OCXGR2 - ..S OCXGR2=OCXGR1_","_OCXELE_",1" - ..K OCXDATA - ..S OCXDATA(OCXDFI,0)=OCXDFI - ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) - ..S OCXDATA("B",OCXDFI,OCXDFI)="" - ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) - ; - Q 1 - ; -SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data - M @ROOT=DATA - I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) - I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) - ; - Q - ; - ; +OCXOZ0O ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; + ; *************************************************************** + ; ** Warning: This routine is automatically generated by the ** + ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** + ; ** will be lost the next time the rule compiler executes. ** + ; *************************************************************** + ; + Q + ; +R19R1B ; Send Order Check, Notication messages and/or Execute code for Rule #19 'PATIENT DISCHARGE' Relation #1 'DISCHARGE' + ; Called from R19R1A+10^OCXOZ0N. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT + ; NEWRULE( ---------> NEW RULE MESSAGE + ; + Q:$D(OCXRULE("R19R1B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + S OCXCMSG="" + S OCXNMSG="Discharged on "_$$INT2DT($$GETDATA(DFN,"56^",26),0) + ; + Q:$G(OCXOERR) + ; + ; Send Notification + ; + S (OCXDUZ,OCXDATA)="",OCXNUM=0 + I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D + .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) + .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA + I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D + .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" + .S OCXNUM=+$P(OCXORD,U,2) + S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) + S OCXRULE("R19R1B")="" + I $$NEWRULE(DFN,OCXNUM,19,1,35,OCXNMSG) D I 1 + .D:($G(OCXTRACE)<5) EN^ORB3(35,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) + Q + ; +R22R1A ; Verify all Event/Elements of Rule #22 'ORDER REQUIRES CO-SIGNATURE' Relation #1 'COSIG' + ; Called from EL47+5^OCXOZ0G. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE47( -----------> Verify Event/Element: 'ORDER REQUIRES CO-SIGNATURE' + ; + Q:$G(^OCXS(860.2,22,"INACT")) + ; + I $$MCE47 D R22R1B + Q + ; +R22R1B ; Send Order Check, Notication messages and/or Execute code for Rule #22 'ORDER REQUIRES CO-SIGNATURE' Relation #1 'COSIG' + ; Called from R22R1A+10. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; NEWRULE( ---------> NEW RULE MESSAGE + ; + Q:$D(OCXRULE("R22R1B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + S OCXCMSG="" + S OCXNMSG="Order requires a co-signature" + ; + Q:$G(OCXOERR) + ; + ; Send Notification + ; + S (OCXDUZ,OCXDATA)="",OCXNUM=0 + I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D + .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) + .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA + I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D + .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" + .S OCXNUM=+$P(OCXORD,U,2) + S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) + S OCXRULE("R22R1B")="" + I $$NEWRULE(DFN,OCXNUM,22,1,37,OCXNMSG) D I 1 + .D:($G(OCXTRACE)<5) EN^ORB3(37,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) + Q + ; +R24R1A ; Verify all Event/Elements of Rule #24 'ORDERER FLAGGED RESULTS AVAILABLE' Relation #1 'ORDER FLAGGED FOR RESULTS AND (LAB RESULT OR IMAGI...' + ; Called from EL5+5^OCXOZ0H, and EL49+5^OCXOZ0H, and EL55+5^OCXOZ0H, and EL101+5^OCXOZ0H. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE101( ----------> Verify Event/Element: 'HL7 FINAL IMAGING RESULT' + ; MCE49( -----------> Verify Event/Element: 'ORDER FLAGGED FOR RESULTS' + ; MCE5( ------------> Verify Event/Element: 'HL7 FINAL LAB RESULT' + ; MCE55( -----------> Verify Event/Element: 'CONSULT FINAL RESULTS' + ; + Q:$G(^OCXS(860.2,24,"INACT")) + ; + I $$MCE49 D + .I $$MCE5 D R24R1B^OCXOZ0P + .I $$MCE101 D R24R1B^OCXOZ0P + .I $$MCE55 D R24R1B^OCXOZ0P + Q + ; +CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM + ; + N CKSUM,PTR,ASC S CKSUM=0 + S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") + F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC + Q +CKSUM + ; +GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data + ; + N OCXE,VAL,PC S VAL="" + F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) + Q VAL + ; +INT2DT(OCXDT,OCXF) ; This Local Extrinsic Function converts an OCX internal format + ; date into an Externl Format (Human Readable) date. 'OCXF=SHORT FORMAT OCXF=LONG FORMAT + ; + Q:'$L($G(OCXDT)) "" S OCXF=+$G(OCXF) + N OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXCYR + S (OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXAP)="" + S OCXSEC=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 + S OCXMIN=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 + S OCXHR=$E(OCXDT#24+100,2,3),OCXDT=OCXDT\24 + S OCXCYR=($H\1461)*4+1841+(($H#1461)\365) + S OCXYR=(OCXDT\1461)*4+1841,OCXDT=OCXDT#1461 + S OCXLPYR=(OCXDT\365),OCXDT=OCXDT-(OCXLPYR*365),OCXYR=OCXYR+OCXLPYR + S OCXCNT="031^059^090^120^151^181^212^243^273^304^334^365" + S:(OCXLPYR=3) OCXCNT="031^060^091^121^152^182^213^244^274^305^335^366" + F OCXMON=1:1:12 Q:(OCXDT<$P(OCXCNT,U,OCXMON)) + S OCXDAY=OCXDT-$P(OCXCNT,U,OCXMON-1)+1 + I OCXF S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,OCXMON) + E S OCXMON=$E(OCXMON+100,2,3) + S OCXAP=$S('OCXHR:"Midnight",(OCXHR=12):"Noon",(OCXHR<12):"AM",1:"PM") + I OCXF S OCXHR=OCXHR#12 S:'OCXHR OCXHR=12 + Q:'OCXF $E(OCXMON+100,2,3)_"/"_$E(OCXDAY+100,2,3)_$S((OCXCYR=OCXYR):" "_OCXHR_":"_OCXMIN,1:"/"_$E(OCXYR,3,4)) + Q:(OCXHR+OCXMIN+OCXSEC) OCXMON_" "_OCXDAY_","_OCXYR_" at "_OCXHR_":"_OCXMIN_"."_OCXSEC_" "_OCXAP + Q OCXMON_" "_OCXDAY_","_OCXYR + ; +MCE101() ; Verify Event/Element: HL7 FINAL IMAGING RESULT + ; + ; + N OCXRES + I $L(OCXDF(37)) S OCXRES(101,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),101)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),101)) + Q 0 + ; +MCE47() ; Verify Event/Element: ORDER REQUIRES CO-SIGNATURE + ; + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$P($G(OCXORD),"^",1) I $L(OCXDF(37)) S OCXRES(47,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),47)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),47)) + Q 0 + ; +MCE49() ; Verify Event/Element: ORDER FLAGGED FOR RESULTS + ; + ; + N OCXRES + I $L(OCXDF(37)) S OCXRES(49,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),49)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),49)) + Q 0 + ; +MCE5() ; Verify Event/Element: HL7 FINAL LAB RESULT + ; + ; + N OCXRES + I $L(OCXDF(37)) S OCXRES(5,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),5)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),5)) + Q 0 + ; +MCE55() ; Verify Event/Element: CONSULT FINAL RESULTS + ; + ; + N OCXRES + I $L(OCXDF(37)) S OCXRES(55,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),55)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),55)) + Q 0 + ; +NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number + ; + ; + Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 + Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 + S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN + ; + N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL + ; + S OCXTIME=(+$H) + S OCXCKSUM=$$CKSUM(OCXMESS) + ; + S OCXTSP=($H*86400)+$P($H,",",2) + S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) + ; + Q:(OCXTSPL>OCXTSP) 0 + ; + K OCXDATA + S OCXDATA(OCXDFN,0)=OCXDFN + S OCXDATA("B",OCXDFN,OCXDFN)="" + S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP + ; + S OCXGR="^OCXD(860.7" + D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) + ; + K OCXDATA + S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) + S OCXDATA(OCXRUL,"M")=OCXMESS + S OCXDATA("B",OCXRUL,OCXRUL)="" + S OCXGR=OCXGR_","_OCXDFN_",1" + D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) + ; + K OCXDATA + S OCXDATA(OCXREL,0)=OCXREL + S OCXDATA("B",OCXREL,OCXREL)="" + S OCXGR=OCXGR_","_OCXRUL_",1" + D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) + ; + S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D + .; + .N OCXGR1 + .S OCXGR1=OCXGR_","_OCXREL_",1" + .K OCXDATA + .S OCXDATA(OCXELE,0)=OCXELE + .S OCXDATA(OCXELE,"TIME")=OCXTIME + .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) + .S OCXDATA("B",OCXELE,OCXELE)="" + .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) + .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) + .; + .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D + ..N OCXGR2 + ..S OCXGR2=OCXGR1_","_OCXELE_",1" + ..K OCXDATA + ..S OCXDATA(OCXDFI,0)=OCXDFI + ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) + ..S OCXDATA("B",OCXDFI,OCXDFI)="" + ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) + ; + Q 1 + ; +SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data + M @ROOT=DATA + I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) + I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) + ; + Q + ; + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0P.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0P.m index 7b2f90d3..c0b230af 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0P.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0P.m @@ -1,243 +1,243 @@ -OCXOZ0P ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; - ; *************************************************************** - ; ** Warning: This routine is automatically generated by the ** - ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** - ; ** will be lost the next time the rule compiler executes. ** - ; *************************************************************** - ; - Q - ; -R24R1B ; Send Order Check, Notication messages and/or Execute code for Rule #24 'ORDERER FLAGGED RESULTS AVAILABLE' Relation #1 'ORDER FLAGGED FOR RESULTS AND (LAB RESULT OR IMAGI...' - ; Called from R24R1A+14^OCXOZ0O. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; NEWRULE( ---------> NEW RULE MESSAGE - ; - Q:$D(OCXRULE("R24R1B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - S OCXCMSG="" - S OCXNMSG="Requested results available: "_$$GETDATA(DFN,"5^49^55^101",96) - ; - Q:$G(OCXOERR) - ; - ; Send Notification - ; - S (OCXDUZ,OCXDATA)="",OCXNUM=0 - I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D - .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) - .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA - I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D - .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" - .S OCXNUM=+$P(OCXORD,U,2) - S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) - S OCXRULE("R24R1B")="" - I $$NEWRULE(DFN,OCXNUM,24,1,33,OCXNMSG) D I 1 - .D:($G(OCXTRACE)<5) EN^ORB3(33,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) - Q - ; -R28R1A ; Verify all Event/Elements of Rule #28 'STAT ORDER PLACED' Relation #1 'NEW OBR STAT OR NEW ORC STAT' - ; Called from EL60+5^OCXOZ0H, and EL61+5^OCXOZ0H. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE60( -----------> Verify Event/Element: 'NEW OBR STAT ORDER' - ; MCE61( -----------> Verify Event/Element: 'NEW ORC STAT ORDER' - ; - Q:$G(^OCXS(860.2,28,"INACT")) - ; - I $$MCE60 D R28R1B - I $$MCE61 D R28R1B - Q - ; -R28R1B ; Send Order Check, Notication messages and/or Execute code for Rule #28 'STAT ORDER PLACED' Relation #1 'NEW OBR STAT OR NEW ORC STAT' - ; Called from R28R1A+11. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; NEWRULE( ---------> NEW RULE MESSAGE - ; - Q:$D(OCXRULE("R28R1B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - S OCXCMSG="" - S OCXNMSG="STAT order: "_$$GETDATA(DFN,"60^61",96) - ; - Q:$G(OCXOERR) - ; - ; Send Notification - ; - S (OCXDUZ,OCXDATA)="",OCXNUM=0 - I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D - .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) - .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA - I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D - .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" - .S OCXNUM=+$P(OCXORD,U,2) - S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) - S OCXRULE("R28R1B")="" - I $$NEWRULE(DFN,OCXNUM,28,1,43,OCXNMSG) D I 1 - .D:($G(OCXTRACE)<5) EN^ORB3(43,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) - Q - ; -R32R1A ; Verify all Event/Elements of Rule #32 'PATIENT TRANSFERRED FROM PSYCHIATRY TO A...' Relation #1 'FROM PSYCH WARD' - ; Called from EL42+5^OCXOZ0H. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE42( -----------> Verify Event/Element: 'PATIENT TRANSFERRED FROM PSYCH WARD' - ; - Q:$G(^OCXS(860.2,32,"INACT")) - ; - I $$MCE42 D R32R1B - Q - ; -R32R1B ; Send Order Check, Notication messages and/or Execute code for Rule #32 'PATIENT TRANSFERRED FROM PSYCHIATRY TO A...' Relation #1 'FROM PSYCH WARD' - ; Called from R32R1A+10. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; NEWRULE( ---------> NEW RULE MESSAGE - ; - Q:$D(OCXRULE("R32R1B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - S OCXCMSG="" - S OCXNMSG="Transfer from Psych ward: "_$$GETDATA(DFN,"42^",95)_" to ward: "_$$GETDATA(DFN,"42^",90) - ; - Q:$G(OCXOERR) - ; - ; Send Notification - ; - S (OCXDUZ,OCXDATA)="",OCXNUM=0 - I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D - .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) - .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA - I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D - .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" - .S OCXNUM=+$P(OCXORD,U,2) - S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) - S OCXRULE("R32R1B")="" - I $$NEWRULE(DFN,OCXNUM,32,1,36,OCXNMSG) D I 1 - .D:($G(OCXTRACE)<5) EN^ORB3(36,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) - Q - ; -CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM - ; - N CKSUM,PTR,ASC S CKSUM=0 - S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") - F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC - Q +CKSUM - ; -GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data - ; - N OCXE,VAL,PC S VAL="" - F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) - Q VAL - ; -MCE42() ; Verify Event/Element: PATIENT TRANSFERRED FROM PSYCH WARD - ; - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(42,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),42)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),42)) - Q 0 - ; -MCE60() ; Verify Event/Element: NEW OBR STAT ORDER - ; - ; - N OCXRES - I $L(OCXDF(37)) S OCXRES(60,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),60)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),60)) - Q 0 - ; -MCE61() ; Verify Event/Element: NEW ORC STAT ORDER - ; - ; - N OCXRES - I $L(OCXDF(37)) S OCXRES(61,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),61)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),61)) - Q 0 - ; -NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number - ; - ; - Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 - Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 - S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN - ; - N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL - ; - S OCXTIME=(+$H) - S OCXCKSUM=$$CKSUM(OCXMESS) - ; - S OCXTSP=($H*86400)+$P($H,",",2) - S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) - ; - Q:(OCXTSPL>OCXTSP) 0 - ; - K OCXDATA - S OCXDATA(OCXDFN,0)=OCXDFN - S OCXDATA("B",OCXDFN,OCXDFN)="" - S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP - ; - S OCXGR="^OCXD(860.7" - D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) - ; - K OCXDATA - S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) - S OCXDATA(OCXRUL,"M")=OCXMESS - S OCXDATA("B",OCXRUL,OCXRUL)="" - S OCXGR=OCXGR_","_OCXDFN_",1" - D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) - ; - K OCXDATA - S OCXDATA(OCXREL,0)=OCXREL - S OCXDATA("B",OCXREL,OCXREL)="" - S OCXGR=OCXGR_","_OCXRUL_",1" - D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) - ; - S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D - .; - .N OCXGR1 - .S OCXGR1=OCXGR_","_OCXREL_",1" - .K OCXDATA - .S OCXDATA(OCXELE,0)=OCXELE - .S OCXDATA(OCXELE,"TIME")=OCXTIME - .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) - .S OCXDATA("B",OCXELE,OCXELE)="" - .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) - .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) - .; - .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D - ..N OCXGR2 - ..S OCXGR2=OCXGR1_","_OCXELE_",1" - ..K OCXDATA - ..S OCXDATA(OCXDFI,0)=OCXDFI - ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) - ..S OCXDATA("B",OCXDFI,OCXDFI)="" - ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) - ; - Q 1 - ; -SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data - M @ROOT=DATA - I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) - I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) - ; - Q - ; - ; +OCXOZ0P ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; + ; *************************************************************** + ; ** Warning: This routine is automatically generated by the ** + ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** + ; ** will be lost the next time the rule compiler executes. ** + ; *************************************************************** + ; + Q + ; +R24R1B ; Send Order Check, Notication messages and/or Execute code for Rule #24 'ORDERER FLAGGED RESULTS AVAILABLE' Relation #1 'ORDER FLAGGED FOR RESULTS AND (LAB RESULT OR IMAGI...' + ; Called from R24R1A+14^OCXOZ0O. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; NEWRULE( ---------> NEW RULE MESSAGE + ; + Q:$D(OCXRULE("R24R1B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + S OCXCMSG="" + S OCXNMSG="Requested results available: "_$$GETDATA(DFN,"5^49^55^101",96) + ; + Q:$G(OCXOERR) + ; + ; Send Notification + ; + S (OCXDUZ,OCXDATA)="",OCXNUM=0 + I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D + .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) + .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA + I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D + .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" + .S OCXNUM=+$P(OCXORD,U,2) + S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) + S OCXRULE("R24R1B")="" + I $$NEWRULE(DFN,OCXNUM,24,1,33,OCXNMSG) D I 1 + .D:($G(OCXTRACE)<5) EN^ORB3(33,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) + Q + ; +R28R1A ; Verify all Event/Elements of Rule #28 'STAT ORDER PLACED' Relation #1 'NEW OBR STAT OR NEW ORC STAT' + ; Called from EL60+5^OCXOZ0H, and EL61+5^OCXOZ0H. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE60( -----------> Verify Event/Element: 'NEW OBR STAT ORDER' + ; MCE61( -----------> Verify Event/Element: 'NEW ORC STAT ORDER' + ; + Q:$G(^OCXS(860.2,28,"INACT")) + ; + I $$MCE60 D R28R1B + I $$MCE61 D R28R1B + Q + ; +R28R1B ; Send Order Check, Notication messages and/or Execute code for Rule #28 'STAT ORDER PLACED' Relation #1 'NEW OBR STAT OR NEW ORC STAT' + ; Called from R28R1A+11. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; NEWRULE( ---------> NEW RULE MESSAGE + ; + Q:$D(OCXRULE("R28R1B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + S OCXCMSG="" + S OCXNMSG="STAT order: "_$$GETDATA(DFN,"60^61",96) + ; + Q:$G(OCXOERR) + ; + ; Send Notification + ; + S (OCXDUZ,OCXDATA)="",OCXNUM=0 + I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D + .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) + .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA + I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D + .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" + .S OCXNUM=+$P(OCXORD,U,2) + S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) + S OCXRULE("R28R1B")="" + I $$NEWRULE(DFN,OCXNUM,28,1,43,OCXNMSG) D I 1 + .D:($G(OCXTRACE)<5) EN^ORB3(43,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) + Q + ; +R32R1A ; Verify all Event/Elements of Rule #32 'PATIENT TRANSFERRED FROM PSYCHIATRY TO A...' Relation #1 'FROM PSYCH WARD' + ; Called from EL42+5^OCXOZ0H. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE42( -----------> Verify Event/Element: 'PATIENT TRANSFERRED FROM PSYCH WARD' + ; + Q:$G(^OCXS(860.2,32,"INACT")) + ; + I $$MCE42 D R32R1B + Q + ; +R32R1B ; Send Order Check, Notication messages and/or Execute code for Rule #32 'PATIENT TRANSFERRED FROM PSYCHIATRY TO A...' Relation #1 'FROM PSYCH WARD' + ; Called from R32R1A+10. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; NEWRULE( ---------> NEW RULE MESSAGE + ; + Q:$D(OCXRULE("R32R1B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + S OCXCMSG="" + S OCXNMSG="Transfer from Psych ward: "_$$GETDATA(DFN,"42^",95)_" to ward: "_$$GETDATA(DFN,"42^",90) + ; + Q:$G(OCXOERR) + ; + ; Send Notification + ; + S (OCXDUZ,OCXDATA)="",OCXNUM=0 + I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D + .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) + .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA + I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D + .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" + .S OCXNUM=+$P(OCXORD,U,2) + S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) + S OCXRULE("R32R1B")="" + I $$NEWRULE(DFN,OCXNUM,32,1,36,OCXNMSG) D I 1 + .D:($G(OCXTRACE)<5) EN^ORB3(36,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) + Q + ; +CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM + ; + N CKSUM,PTR,ASC S CKSUM=0 + S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") + F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC + Q +CKSUM + ; +GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data + ; + N OCXE,VAL,PC S VAL="" + F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) + Q VAL + ; +MCE42() ; Verify Event/Element: PATIENT TRANSFERRED FROM PSYCH WARD + ; + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(42,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),42)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),42)) + Q 0 + ; +MCE60() ; Verify Event/Element: NEW OBR STAT ORDER + ; + ; + N OCXRES + I $L(OCXDF(37)) S OCXRES(60,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),60)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),60)) + Q 0 + ; +MCE61() ; Verify Event/Element: NEW ORC STAT ORDER + ; + ; + N OCXRES + I $L(OCXDF(37)) S OCXRES(61,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),61)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),61)) + Q 0 + ; +NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number + ; + ; + Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 + Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 + S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN + ; + N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL + ; + S OCXTIME=(+$H) + S OCXCKSUM=$$CKSUM(OCXMESS) + ; + S OCXTSP=($H*86400)+$P($H,",",2) + S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) + ; + Q:(OCXTSPL>OCXTSP) 0 + ; + K OCXDATA + S OCXDATA(OCXDFN,0)=OCXDFN + S OCXDATA("B",OCXDFN,OCXDFN)="" + S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP + ; + S OCXGR="^OCXD(860.7" + D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) + ; + K OCXDATA + S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) + S OCXDATA(OCXRUL,"M")=OCXMESS + S OCXDATA("B",OCXRUL,OCXRUL)="" + S OCXGR=OCXGR_","_OCXDFN_",1" + D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) + ; + K OCXDATA + S OCXDATA(OCXREL,0)=OCXREL + S OCXDATA("B",OCXREL,OCXREL)="" + S OCXGR=OCXGR_","_OCXRUL_",1" + D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) + ; + S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D + .; + .N OCXGR1 + .S OCXGR1=OCXGR_","_OCXREL_",1" + .K OCXDATA + .S OCXDATA(OCXELE,0)=OCXELE + .S OCXDATA(OCXELE,"TIME")=OCXTIME + .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) + .S OCXDATA("B",OCXELE,OCXELE)="" + .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) + .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) + .; + .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D + ..N OCXGR2 + ..S OCXGR2=OCXGR1_","_OCXELE_",1" + ..K OCXDATA + ..S OCXDATA(OCXDFI,0)=OCXDFI + ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) + ..S OCXDATA("B",OCXDFI,OCXDFI)="" + ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) + ; + Q 1 + ; +SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data + M @ROOT=DATA + I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) + I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) + ; + Q + ; + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0Q.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0Q.m index 4e84d5ff..bd70d5d0 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0Q.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0Q.m @@ -1,274 +1,274 @@ -OCXOZ0Q ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; - ; *************************************************************** - ; ** Warning: This routine is automatically generated by the ** - ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** - ; ** will be lost the next time the rule compiler executes. ** - ; *************************************************************** - ; - Q - ; -R35R1A ; Verify all Event/Elements of Rule #35 'LAB ORDER CANCELLED' Relation #1 '(CANCEL OR REQCANCEL) AND CANCELED BY NON-ORIG ORD...' - ; Called from EL100+8^OCXOZ0G, and EL20+5^OCXOZ0H, and EL40+5^OCXOZ0H. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE100( ----------> Verify Event/Element: 'CANCELED BY NON-ORIG ORDERING PROVIDER' - ; MCE20( -----------> Verify Event/Element: 'HL7 LAB ORDER CANCELLED' - ; MCE40( -----------> Verify Event/Element: 'HL7 LAB REQUEST CANCELLED' - ; - Q:$G(^OCXS(860.2,35,"INACT")) - ; - I $$MCE20 D - .I $$MCE100 D R35R1B - I $$MCE40 D - .I $$MCE100 D R35R1B - Q - ; -R35R1B ; Send Order Check, Notication messages and/or Execute code for Rule #35 'LAB ORDER CANCELLED' Relation #1 '(CANCEL OR REQCANCEL) AND CANCELED BY NON-ORIG ORD...' - ; Called from R35R1A+13. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; NEWRULE( ---------> NEW RULE MESSAGE - ; - Q:$D(OCXRULE("R35R1B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - S OCXCMSG="" - S OCXNMSG="Lab order canceled: "_$$GETDATA(DFN,"20^40^100",105) - ; - Q:$G(OCXOERR) - ; - ; Send Notification - ; - S (OCXDUZ,OCXDATA)="",OCXNUM=0 - I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D - .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) - .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA - I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D - .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" - .S OCXNUM=+$P(OCXORD,U,2) - S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) - S OCXRULE("R35R1B")="" - I $$NEWRULE(DFN,OCXNUM,35,1,42,OCXNMSG) D I 1 - .D:($G(OCXTRACE)<5) EN^ORB3(42,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) - Q - ; -R38R1A ; Verify all Event/Elements of Rule #38 'NEW ORDER PLACED' Relation #1 'NEW' - ; Called from EL6+5^OCXOZ0H. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE6( ------------> Verify Event/Element: 'HL7 NEW OERR ORDER' - ; - Q:$G(^OCXS(860.2,38,"INACT")) - ; - I $$MCE6 D R38R1B - Q - ; -R38R1B ; Send Order Check, Notication messages and/or Execute code for Rule #38 'NEW ORDER PLACED' Relation #1 'NEW' - ; Called from R38R1A+10. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; NEWRULE( ---------> NEW RULE MESSAGE - ; - Q:$D(OCXRULE("R38R1B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - S OCXCMSG="" - S OCXNMSG="["_$$GETDATA(DFN,"6^",147)_"] New order(s) placed." - ; - Q:$G(OCXOERR) - ; - ; Send Notification - ; - S (OCXDUZ,OCXDATA)="",OCXNUM=0 - I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D - .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) - .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA - I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D - .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" - .S OCXNUM=+$P(OCXORD,U,2) - S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) - S OCXRULE("R38R1B")="" - I $$NEWRULE(DFN,OCXNUM,38,1,50,OCXNMSG) D I 1 - .D:($G(OCXTRACE)<5) EN^ORB3(50,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) - Q - ; -R38R2A ; Verify all Event/Elements of Rule #38 'NEW ORDER PLACED' Relation #2 'DCED' - ; Called from EL126+5^OCXOZ0H. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE126( ----------> Verify Event/Element: 'HL7 DCED OERR ORDER' - ; - Q:$G(^OCXS(860.2,38,"INACT")) - ; - I $$MCE126 D R38R2B - Q - ; -R38R2B ; Send Order Check, Notication messages and/or Execute code for Rule #38 'NEW ORDER PLACED' Relation #2 'DCED' - ; Called from R38R2A+10. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; NEWRULE( ---------> NEW RULE MESSAGE - ; - Q:$D(OCXRULE("R38R2B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - S OCXCMSG="" - S OCXNMSG="["_$$GETDATA(DFN,"126^",147)_"] New DC order(s) placed." - ; - Q:$G(OCXOERR) - ; - ; Send Notification - ; - S (OCXDUZ,OCXDATA)="",OCXNUM=0 - I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D - .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) - .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA - I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D - .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" - .S OCXNUM=+$P(OCXORD,U,2) - S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) - S OCXRULE("R38R2B")="" - I $$NEWRULE(DFN,OCXNUM,38,2,62,OCXNMSG) D I 1 - .D:($G(OCXTRACE)<5) EN^ORB3(62,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) - Q - ; -CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM - ; - N CKSUM,PTR,ASC S CKSUM=0 - S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") - F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC - Q +CKSUM - ; -GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data - ; - N OCXE,VAL,PC S VAL="" - F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) - Q VAL - ; -MCE100() ; Verify Event/Element: CANCELED BY NON-ORIG ORDERING PROVIDER - ; - ; - N OCXRES - I $L(OCXDF(37)) S OCXRES(100,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),100)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),100)) - Q 0 - ; -MCE126() ; Verify Event/Element: HL7 DCED OERR ORDER - ; - ; - N OCXRES - I $L(OCXDF(37)) S OCXRES(126,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),126)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),126)) - Q 0 - ; -MCE20() ; Verify Event/Element: HL7 LAB ORDER CANCELLED - ; - ; - N OCXRES - I $L(OCXDF(37)) S OCXRES(20,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),20)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),20)) - Q 0 - ; -MCE40() ; Verify Event/Element: HL7 LAB REQUEST CANCELLED - ; - ; - N OCXRES - I $L(OCXDF(37)) S OCXRES(40,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),40)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),40)) - Q 0 - ; -MCE6() ; Verify Event/Element: HL7 NEW OERR ORDER - ; - ; - N OCXRES - I $L(OCXDF(37)) S OCXRES(6,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),6)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),6)) - Q 0 - ; -NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number - ; - ; - Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 - Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 - S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN - ; - N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL - ; - S OCXTIME=(+$H) - S OCXCKSUM=$$CKSUM(OCXMESS) - ; - S OCXTSP=($H*86400)+$P($H,",",2) - S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) - ; - Q:(OCXTSPL>OCXTSP) 0 - ; - K OCXDATA - S OCXDATA(OCXDFN,0)=OCXDFN - S OCXDATA("B",OCXDFN,OCXDFN)="" - S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP - ; - S OCXGR="^OCXD(860.7" - D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) - ; - K OCXDATA - S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) - S OCXDATA(OCXRUL,"M")=OCXMESS - S OCXDATA("B",OCXRUL,OCXRUL)="" - S OCXGR=OCXGR_","_OCXDFN_",1" - D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) - ; - K OCXDATA - S OCXDATA(OCXREL,0)=OCXREL - S OCXDATA("B",OCXREL,OCXREL)="" - S OCXGR=OCXGR_","_OCXRUL_",1" - D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) - ; - S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D - .; - .N OCXGR1 - .S OCXGR1=OCXGR_","_OCXREL_",1" - .K OCXDATA - .S OCXDATA(OCXELE,0)=OCXELE - .S OCXDATA(OCXELE,"TIME")=OCXTIME - .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) - .S OCXDATA("B",OCXELE,OCXELE)="" - .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) - .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) - .; - .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D - ..N OCXGR2 - ..S OCXGR2=OCXGR1_","_OCXELE_",1" - ..K OCXDATA - ..S OCXDATA(OCXDFI,0)=OCXDFI - ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) - ..S OCXDATA("B",OCXDFI,OCXDFI)="" - ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) - ; - Q 1 - ; -SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data - M @ROOT=DATA - I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) - I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) - ; - Q - ; - ; +OCXOZ0Q ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; + ; *************************************************************** + ; ** Warning: This routine is automatically generated by the ** + ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** + ; ** will be lost the next time the rule compiler executes. ** + ; *************************************************************** + ; + Q + ; +R35R1A ; Verify all Event/Elements of Rule #35 'LAB ORDER CANCELLED' Relation #1 '(CANCEL OR REQCANCEL) AND CANCELED BY NON-ORIG ORD...' + ; Called from EL100+8^OCXOZ0G, and EL20+5^OCXOZ0H, and EL40+5^OCXOZ0H. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE100( ----------> Verify Event/Element: 'CANCELED BY NON-ORIG ORDERING PROVIDER' + ; MCE20( -----------> Verify Event/Element: 'HL7 LAB ORDER CANCELLED' + ; MCE40( -----------> Verify Event/Element: 'HL7 LAB REQUEST CANCELLED' + ; + Q:$G(^OCXS(860.2,35,"INACT")) + ; + I $$MCE20 D + .I $$MCE100 D R35R1B + I $$MCE40 D + .I $$MCE100 D R35R1B + Q + ; +R35R1B ; Send Order Check, Notication messages and/or Execute code for Rule #35 'LAB ORDER CANCELLED' Relation #1 '(CANCEL OR REQCANCEL) AND CANCELED BY NON-ORIG ORD...' + ; Called from R35R1A+13. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; NEWRULE( ---------> NEW RULE MESSAGE + ; + Q:$D(OCXRULE("R35R1B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + S OCXCMSG="" + S OCXNMSG="Lab order canceled: "_$$GETDATA(DFN,"20^40^100",105) + ; + Q:$G(OCXOERR) + ; + ; Send Notification + ; + S (OCXDUZ,OCXDATA)="",OCXNUM=0 + I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D + .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) + .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA + I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D + .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" + .S OCXNUM=+$P(OCXORD,U,2) + S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) + S OCXRULE("R35R1B")="" + I $$NEWRULE(DFN,OCXNUM,35,1,42,OCXNMSG) D I 1 + .D:($G(OCXTRACE)<5) EN^ORB3(42,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) + Q + ; +R38R1A ; Verify all Event/Elements of Rule #38 'NEW ORDER PLACED' Relation #1 'NEW' + ; Called from EL6+5^OCXOZ0H. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE6( ------------> Verify Event/Element: 'HL7 NEW OERR ORDER' + ; + Q:$G(^OCXS(860.2,38,"INACT")) + ; + I $$MCE6 D R38R1B + Q + ; +R38R1B ; Send Order Check, Notication messages and/or Execute code for Rule #38 'NEW ORDER PLACED' Relation #1 'NEW' + ; Called from R38R1A+10. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; NEWRULE( ---------> NEW RULE MESSAGE + ; + Q:$D(OCXRULE("R38R1B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + S OCXCMSG="" + S OCXNMSG="["_$$GETDATA(DFN,"6^",147)_"] New order(s) placed." + ; + Q:$G(OCXOERR) + ; + ; Send Notification + ; + S (OCXDUZ,OCXDATA)="",OCXNUM=0 + I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D + .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) + .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA + I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D + .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" + .S OCXNUM=+$P(OCXORD,U,2) + S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) + S OCXRULE("R38R1B")="" + I $$NEWRULE(DFN,OCXNUM,38,1,50,OCXNMSG) D I 1 + .D:($G(OCXTRACE)<5) EN^ORB3(50,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) + Q + ; +R38R2A ; Verify all Event/Elements of Rule #38 'NEW ORDER PLACED' Relation #2 'DCED' + ; Called from EL126+5^OCXOZ0H. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE126( ----------> Verify Event/Element: 'HL7 DCED OERR ORDER' + ; + Q:$G(^OCXS(860.2,38,"INACT")) + ; + I $$MCE126 D R38R2B + Q + ; +R38R2B ; Send Order Check, Notication messages and/or Execute code for Rule #38 'NEW ORDER PLACED' Relation #2 'DCED' + ; Called from R38R2A+10. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; NEWRULE( ---------> NEW RULE MESSAGE + ; + Q:$D(OCXRULE("R38R2B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + S OCXCMSG="" + S OCXNMSG="["_$$GETDATA(DFN,"126^",147)_"] New DC order(s) placed." + ; + Q:$G(OCXOERR) + ; + ; Send Notification + ; + S (OCXDUZ,OCXDATA)="",OCXNUM=0 + I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D + .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) + .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA + I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D + .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" + .S OCXNUM=+$P(OCXORD,U,2) + S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) + S OCXRULE("R38R2B")="" + I $$NEWRULE(DFN,OCXNUM,38,2,62,OCXNMSG) D I 1 + .D:($G(OCXTRACE)<5) EN^ORB3(62,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) + Q + ; +CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM + ; + N CKSUM,PTR,ASC S CKSUM=0 + S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") + F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC + Q +CKSUM + ; +GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data + ; + N OCXE,VAL,PC S VAL="" + F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) + Q VAL + ; +MCE100() ; Verify Event/Element: CANCELED BY NON-ORIG ORDERING PROVIDER + ; + ; + N OCXRES + I $L(OCXDF(37)) S OCXRES(100,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),100)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),100)) + Q 0 + ; +MCE126() ; Verify Event/Element: HL7 DCED OERR ORDER + ; + ; + N OCXRES + I $L(OCXDF(37)) S OCXRES(126,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),126)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),126)) + Q 0 + ; +MCE20() ; Verify Event/Element: HL7 LAB ORDER CANCELLED + ; + ; + N OCXRES + I $L(OCXDF(37)) S OCXRES(20,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),20)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),20)) + Q 0 + ; +MCE40() ; Verify Event/Element: HL7 LAB REQUEST CANCELLED + ; + ; + N OCXRES + I $L(OCXDF(37)) S OCXRES(40,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),40)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),40)) + Q 0 + ; +MCE6() ; Verify Event/Element: HL7 NEW OERR ORDER + ; + ; + N OCXRES + I $L(OCXDF(37)) S OCXRES(6,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),6)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),6)) + Q 0 + ; +NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number + ; + ; + Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 + Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 + S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN + ; + N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL + ; + S OCXTIME=(+$H) + S OCXCKSUM=$$CKSUM(OCXMESS) + ; + S OCXTSP=($H*86400)+$P($H,",",2) + S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) + ; + Q:(OCXTSPL>OCXTSP) 0 + ; + K OCXDATA + S OCXDATA(OCXDFN,0)=OCXDFN + S OCXDATA("B",OCXDFN,OCXDFN)="" + S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP + ; + S OCXGR="^OCXD(860.7" + D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) + ; + K OCXDATA + S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) + S OCXDATA(OCXRUL,"M")=OCXMESS + S OCXDATA("B",OCXRUL,OCXRUL)="" + S OCXGR=OCXGR_","_OCXDFN_",1" + D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) + ; + K OCXDATA + S OCXDATA(OCXREL,0)=OCXREL + S OCXDATA("B",OCXREL,OCXREL)="" + S OCXGR=OCXGR_","_OCXRUL_",1" + D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) + ; + S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D + .; + .N OCXGR1 + .S OCXGR1=OCXGR_","_OCXREL_",1" + .K OCXDATA + .S OCXDATA(OCXELE,0)=OCXELE + .S OCXDATA(OCXELE,"TIME")=OCXTIME + .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) + .S OCXDATA("B",OCXELE,OCXELE)="" + .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) + .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) + .; + .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D + ..N OCXGR2 + ..S OCXGR2=OCXGR1_","_OCXELE_",1" + ..K OCXDATA + ..S OCXDATA(OCXDFI,0)=OCXDFI + ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) + ..S OCXDATA("B",OCXDFI,OCXDFI)="" + ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) + ; + Q 1 + ; +SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data + M @ROOT=DATA + I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) + I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) + ; + Q + ; + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0R.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0R.m index 59c49891..4f4c043c 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0R.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0R.m @@ -1,247 +1,247 @@ -OCXOZ0R ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; - ; *************************************************************** - ; ** Warning: This routine is automatically generated by the ** - ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** - ; ** will be lost the next time the rule compiler executes. ** - ; *************************************************************** - ; - Q - ; -R42R1A ; Verify all Event/Elements of Rule #42 'ABNORMAL LAB RESULTS' Relation #1 'ABNORMAL LAB ORDER' - ; Called from EL23+5^OCXOZ0H. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE23( -----------> Verify Event/Element: 'HL7 LAB ORDER RESULTS ABNORMAL' - ; - Q:$G(^OCXS(860.2,42,"INACT")) - ; - I $$MCE23 D R42R1B - Q - ; -R42R1B ; Send Order Check, Notication messages and/or Execute code for Rule #42 'ABNORMAL LAB RESULTS' Relation #1 'ABNORMAL LAB ORDER' - ; Called from R42R1A+10. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; NEWRULE( ---------> NEW RULE MESSAGE - ; - Q:$D(OCXRULE("R42R1B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - S OCXCMSG="" - S OCXNMSG="Abnormal labs - ["_$$GETDATA(DFN,"23^",96)_"]" - ; - Q:$G(OCXOERR) - ; - ; Send Notification - ; - S (OCXDUZ,OCXDATA)="",OCXNUM=0 - I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D - .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) - .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA - I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D - .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" - .S OCXNUM=+$P(OCXORD,U,2) - S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) - S OCXRULE("R42R1B")="" - I $$NEWRULE(DFN,OCXNUM,42,1,14,OCXNMSG) D I 1 - .D:($G(OCXTRACE)<5) EN^ORB3(14,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) - Q - ; -R42R2A ; Verify all Event/Elements of Rule #42 'ABNORMAL LAB RESULTS' Relation #2 'ABNORMAL LAB TEST' - ; Called from EL103+5^OCXOZ0H. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE103( ----------> Verify Event/Element: 'HL7 LAB TEST RESULTS ABNORMAL' - ; - Q:$G(^OCXS(860.2,42,"INACT")) - ; - I $$MCE103 D R42R2B - Q - ; -R42R2B ; Send Order Check, Notication messages and/or Execute code for Rule #42 'ABNORMAL LAB RESULTS' Relation #2 'ABNORMAL LAB TEST' - ; Called from R42R2A+10. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT - ; NEWRULE( ---------> NEW RULE MESSAGE - ; - Q:$D(OCXRULE("R42R2B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - S OCXCMSG="" - S OCXNMSG="Abnormal lab: "_$$GETDATA(DFN,"103^",114)_" "_$$GETDATA(DFN,"103^",12)_" "_$$INT2DT($$GETDATA(DFN,"103^",13),0) - ; - Q:$G(OCXOERR) - ; - ; Send Notification - ; - S (OCXDUZ,OCXDATA)="",OCXNUM=0 - I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D - .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) - .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA - I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D - .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" - .S OCXNUM=+$P(OCXORD,U,2) - S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) - S OCXRULE("R42R2B")="" - I $$NEWRULE(DFN,OCXNUM,42,2,58,OCXNMSG) D I 1 - .D:($G(OCXTRACE)<5) EN^ORB3(58,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) - Q - ; -R44R1A ; Verify all Event/Elements of Rule #44 'ORDER REQUIRES ELECTRONIC SIGNATURE' Relation #1 'ELECTRONIC SIGNATURE' - ; Called from EL48+5^OCXOZ0H. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE48( -----------> Verify Event/Element: 'ORDER REQUIRES ELECTRONIC SIGNATURE' - ; - Q:$G(^OCXS(860.2,44,"INACT")) - ; - I $$MCE48 D R44R1B^OCXOZ0S - Q - ; -CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM - ; - N CKSUM,PTR,ASC S CKSUM=0 - S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") - F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC - Q +CKSUM - ; -GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data - ; - N OCXE,VAL,PC S VAL="" - F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) - Q VAL - ; -INT2DT(OCXDT,OCXF) ; This Local Extrinsic Function converts an OCX internal format - ; date into an Externl Format (Human Readable) date. 'OCXF=SHORT FORMAT OCXF=LONG FORMAT - ; - Q:'$L($G(OCXDT)) "" S OCXF=+$G(OCXF) - N OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXCYR - S (OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXAP)="" - S OCXSEC=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 - S OCXMIN=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 - S OCXHR=$E(OCXDT#24+100,2,3),OCXDT=OCXDT\24 - S OCXCYR=($H\1461)*4+1841+(($H#1461)\365) - S OCXYR=(OCXDT\1461)*4+1841,OCXDT=OCXDT#1461 - S OCXLPYR=(OCXDT\365),OCXDT=OCXDT-(OCXLPYR*365),OCXYR=OCXYR+OCXLPYR - S OCXCNT="031^059^090^120^151^181^212^243^273^304^334^365" - S:(OCXLPYR=3) OCXCNT="031^060^091^121^152^182^213^244^274^305^335^366" - F OCXMON=1:1:12 Q:(OCXDT<$P(OCXCNT,U,OCXMON)) - S OCXDAY=OCXDT-$P(OCXCNT,U,OCXMON-1)+1 - I OCXF S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,OCXMON) - E S OCXMON=$E(OCXMON+100,2,3) - S OCXAP=$S('OCXHR:"Midnight",(OCXHR=12):"Noon",(OCXHR<12):"AM",1:"PM") - I OCXF S OCXHR=OCXHR#12 S:'OCXHR OCXHR=12 - Q:'OCXF $E(OCXMON+100,2,3)_"/"_$E(OCXDAY+100,2,3)_$S((OCXCYR=OCXYR):" "_OCXHR_":"_OCXMIN,1:"/"_$E(OCXYR,3,4)) - Q:(OCXHR+OCXMIN+OCXSEC) OCXMON_" "_OCXDAY_","_OCXYR_" at "_OCXHR_":"_OCXMIN_"."_OCXSEC_" "_OCXAP - Q OCXMON_" "_OCXDAY_","_OCXYR - ; -MCE103() ; Verify Event/Element: HL7 LAB TEST RESULTS ABNORMAL - ; - ; - N OCXRES - I $L(OCXDF(37)) S OCXRES(103,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),103)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),103)) - Q 0 - ; -MCE23() ; Verify Event/Element: HL7 LAB ORDER RESULTS ABNORMAL - ; - ; - N OCXRES - I $L(OCXDF(37)) S OCXRES(23,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),23)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),23)) - Q 0 - ; -MCE48() ; Verify Event/Element: ORDER REQUIRES ELECTRONIC SIGNATURE - ; - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$P($G(OCXORD),"^",1) I $L(OCXDF(37)) S OCXRES(48,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),48)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),48)) - Q 0 - ; -NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number - ; - ; - Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 - Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 - S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN - ; - N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL - ; - S OCXTIME=(+$H) - S OCXCKSUM=$$CKSUM(OCXMESS) - ; - S OCXTSP=($H*86400)+$P($H,",",2) - S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) - ; - Q:(OCXTSPL>OCXTSP) 0 - ; - K OCXDATA - S OCXDATA(OCXDFN,0)=OCXDFN - S OCXDATA("B",OCXDFN,OCXDFN)="" - S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP - ; - S OCXGR="^OCXD(860.7" - D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) - ; - K OCXDATA - S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) - S OCXDATA(OCXRUL,"M")=OCXMESS - S OCXDATA("B",OCXRUL,OCXRUL)="" - S OCXGR=OCXGR_","_OCXDFN_",1" - D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) - ; - K OCXDATA - S OCXDATA(OCXREL,0)=OCXREL - S OCXDATA("B",OCXREL,OCXREL)="" - S OCXGR=OCXGR_","_OCXRUL_",1" - D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) - ; - S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D - .; - .N OCXGR1 - .S OCXGR1=OCXGR_","_OCXREL_",1" - .K OCXDATA - .S OCXDATA(OCXELE,0)=OCXELE - .S OCXDATA(OCXELE,"TIME")=OCXTIME - .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) - .S OCXDATA("B",OCXELE,OCXELE)="" - .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) - .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) - .; - .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D - ..N OCXGR2 - ..S OCXGR2=OCXGR1_","_OCXELE_",1" - ..K OCXDATA - ..S OCXDATA(OCXDFI,0)=OCXDFI - ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) - ..S OCXDATA("B",OCXDFI,OCXDFI)="" - ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) - ; - Q 1 - ; -SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data - M @ROOT=DATA - I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) - I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) - ; - Q - ; - ; +OCXOZ0R ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; + ; *************************************************************** + ; ** Warning: This routine is automatically generated by the ** + ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** + ; ** will be lost the next time the rule compiler executes. ** + ; *************************************************************** + ; + Q + ; +R42R1A ; Verify all Event/Elements of Rule #42 'ABNORMAL LAB RESULTS' Relation #1 'ABNORMAL LAB ORDER' + ; Called from EL23+5^OCXOZ0H. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE23( -----------> Verify Event/Element: 'HL7 LAB ORDER RESULTS ABNORMAL' + ; + Q:$G(^OCXS(860.2,42,"INACT")) + ; + I $$MCE23 D R42R1B + Q + ; +R42R1B ; Send Order Check, Notication messages and/or Execute code for Rule #42 'ABNORMAL LAB RESULTS' Relation #1 'ABNORMAL LAB ORDER' + ; Called from R42R1A+10. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; NEWRULE( ---------> NEW RULE MESSAGE + ; + Q:$D(OCXRULE("R42R1B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + S OCXCMSG="" + S OCXNMSG="Abnormal labs - ["_$$GETDATA(DFN,"23^",96)_"]" + ; + Q:$G(OCXOERR) + ; + ; Send Notification + ; + S (OCXDUZ,OCXDATA)="",OCXNUM=0 + I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D + .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) + .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA + I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D + .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" + .S OCXNUM=+$P(OCXORD,U,2) + S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) + S OCXRULE("R42R1B")="" + I $$NEWRULE(DFN,OCXNUM,42,1,14,OCXNMSG) D I 1 + .D:($G(OCXTRACE)<5) EN^ORB3(14,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) + Q + ; +R42R2A ; Verify all Event/Elements of Rule #42 'ABNORMAL LAB RESULTS' Relation #2 'ABNORMAL LAB TEST' + ; Called from EL103+5^OCXOZ0H. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE103( ----------> Verify Event/Element: 'HL7 LAB TEST RESULTS ABNORMAL' + ; + Q:$G(^OCXS(860.2,42,"INACT")) + ; + I $$MCE103 D R42R2B + Q + ; +R42R2B ; Send Order Check, Notication messages and/or Execute code for Rule #42 'ABNORMAL LAB RESULTS' Relation #2 'ABNORMAL LAB TEST' + ; Called from R42R2A+10. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT + ; NEWRULE( ---------> NEW RULE MESSAGE + ; + Q:$D(OCXRULE("R42R2B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + S OCXCMSG="" + S OCXNMSG="Abnormal lab: "_$$GETDATA(DFN,"103^",114)_" "_$$GETDATA(DFN,"103^",12)_" "_$$INT2DT($$GETDATA(DFN,"103^",13),0) + ; + Q:$G(OCXOERR) + ; + ; Send Notification + ; + S (OCXDUZ,OCXDATA)="",OCXNUM=0 + I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D + .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) + .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA + I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D + .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" + .S OCXNUM=+$P(OCXORD,U,2) + S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) + S OCXRULE("R42R2B")="" + I $$NEWRULE(DFN,OCXNUM,42,2,58,OCXNMSG) D I 1 + .D:($G(OCXTRACE)<5) EN^ORB3(58,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) + Q + ; +R44R1A ; Verify all Event/Elements of Rule #44 'ORDER REQUIRES ELECTRONIC SIGNATURE' Relation #1 'ELECTRONIC SIGNATURE' + ; Called from EL48+5^OCXOZ0H. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE48( -----------> Verify Event/Element: 'ORDER REQUIRES ELECTRONIC SIGNATURE' + ; + Q:$G(^OCXS(860.2,44,"INACT")) + ; + I $$MCE48 D R44R1B^OCXOZ0S + Q + ; +CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM + ; + N CKSUM,PTR,ASC S CKSUM=0 + S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") + F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC + Q +CKSUM + ; +GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data + ; + N OCXE,VAL,PC S VAL="" + F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) + Q VAL + ; +INT2DT(OCXDT,OCXF) ; This Local Extrinsic Function converts an OCX internal format + ; date into an Externl Format (Human Readable) date. 'OCXF=SHORT FORMAT OCXF=LONG FORMAT + ; + Q:'$L($G(OCXDT)) "" S OCXF=+$G(OCXF) + N OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXCYR + S (OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXAP)="" + S OCXSEC=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 + S OCXMIN=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 + S OCXHR=$E(OCXDT#24+100,2,3),OCXDT=OCXDT\24 + S OCXCYR=($H\1461)*4+1841+(($H#1461)\365) + S OCXYR=(OCXDT\1461)*4+1841,OCXDT=OCXDT#1461 + S OCXLPYR=(OCXDT\365),OCXDT=OCXDT-(OCXLPYR*365),OCXYR=OCXYR+OCXLPYR + S OCXCNT="031^059^090^120^151^181^212^243^273^304^334^365" + S:(OCXLPYR=3) OCXCNT="031^060^091^121^152^182^213^244^274^305^335^366" + F OCXMON=1:1:12 Q:(OCXDT<$P(OCXCNT,U,OCXMON)) + S OCXDAY=OCXDT-$P(OCXCNT,U,OCXMON-1)+1 + I OCXF S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,OCXMON) + E S OCXMON=$E(OCXMON+100,2,3) + S OCXAP=$S('OCXHR:"Midnight",(OCXHR=12):"Noon",(OCXHR<12):"AM",1:"PM") + I OCXF S OCXHR=OCXHR#12 S:'OCXHR OCXHR=12 + Q:'OCXF $E(OCXMON+100,2,3)_"/"_$E(OCXDAY+100,2,3)_$S((OCXCYR=OCXYR):" "_OCXHR_":"_OCXMIN,1:"/"_$E(OCXYR,3,4)) + Q:(OCXHR+OCXMIN+OCXSEC) OCXMON_" "_OCXDAY_","_OCXYR_" at "_OCXHR_":"_OCXMIN_"."_OCXSEC_" "_OCXAP + Q OCXMON_" "_OCXDAY_","_OCXYR + ; +MCE103() ; Verify Event/Element: HL7 LAB TEST RESULTS ABNORMAL + ; + ; + N OCXRES + I $L(OCXDF(37)) S OCXRES(103,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),103)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),103)) + Q 0 + ; +MCE23() ; Verify Event/Element: HL7 LAB ORDER RESULTS ABNORMAL + ; + ; + N OCXRES + I $L(OCXDF(37)) S OCXRES(23,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),23)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),23)) + Q 0 + ; +MCE48() ; Verify Event/Element: ORDER REQUIRES ELECTRONIC SIGNATURE + ; + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$P($G(OCXORD),"^",1) I $L(OCXDF(37)) S OCXRES(48,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),48)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),48)) + Q 0 + ; +NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number + ; + ; + Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 + Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 + S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN + ; + N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL + ; + S OCXTIME=(+$H) + S OCXCKSUM=$$CKSUM(OCXMESS) + ; + S OCXTSP=($H*86400)+$P($H,",",2) + S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) + ; + Q:(OCXTSPL>OCXTSP) 0 + ; + K OCXDATA + S OCXDATA(OCXDFN,0)=OCXDFN + S OCXDATA("B",OCXDFN,OCXDFN)="" + S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP + ; + S OCXGR="^OCXD(860.7" + D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) + ; + K OCXDATA + S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) + S OCXDATA(OCXRUL,"M")=OCXMESS + S OCXDATA("B",OCXRUL,OCXRUL)="" + S OCXGR=OCXGR_","_OCXDFN_",1" + D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) + ; + K OCXDATA + S OCXDATA(OCXREL,0)=OCXREL + S OCXDATA("B",OCXREL,OCXREL)="" + S OCXGR=OCXGR_","_OCXRUL_",1" + D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) + ; + S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D + .; + .N OCXGR1 + .S OCXGR1=OCXGR_","_OCXREL_",1" + .K OCXDATA + .S OCXDATA(OCXELE,0)=OCXELE + .S OCXDATA(OCXELE,"TIME")=OCXTIME + .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) + .S OCXDATA("B",OCXELE,OCXELE)="" + .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) + .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) + .; + .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D + ..N OCXGR2 + ..S OCXGR2=OCXGR1_","_OCXELE_",1" + ..K OCXDATA + ..S OCXDATA(OCXDFI,0)=OCXDFI + ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) + ..S OCXDATA("B",OCXDFI,OCXDFI)="" + ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) + ; + Q 1 + ; +SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data + M @ROOT=DATA + I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) + I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) + ; + Q + ; + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0S.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0S.m index 709b5077..4f368fe3 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0S.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0S.m @@ -1,236 +1,236 @@ -OCXOZ0S ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; - ; *************************************************************** - ; ** Warning: This routine is automatically generated by the ** - ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** - ; ** will be lost the next time the rule compiler executes. ** - ; *************************************************************** - ; - Q - ; -R44R1B ; Send Order Check, Notication messages and/or Execute code for Rule #44 'ORDER REQUIRES ELECTRONIC SIGNATURE' Relation #1 'ELECTRONIC SIGNATURE' - ; Called from R44R1A+10^OCXOZ0R. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; NEWRULE( ---------> NEW RULE MESSAGE - ; - Q:$D(OCXRULE("R44R1B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - S OCXCMSG="" - S OCXNMSG="Order requires electronic signature." - ; - Q:$G(OCXOERR) - ; - ; Send Notification - ; - S (OCXDUZ,OCXDATA)="",OCXNUM=0 - I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D - .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) - .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA - I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D - .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" - .S OCXNUM=+$P(OCXORD,U,2) - S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) - S OCXRULE("R44R1B")="" - I $$NEWRULE(DFN,OCXNUM,44,1,12,OCXNMSG) D I 1 - .D:($G(OCXTRACE)<5) EN^ORB3(12,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) - Q - ; -R48R1A ; Verify all Event/Elements of Rule #48 'SITE FLAGGED ORDER' Relation #1 'NEW SITE FLAGGED ORDER AND INPATIENT' - ; Called from EL58+5^OCXOZ0H, and EL127+5^OCXOZ0H. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE127( ----------> Verify Event/Element: 'INPATIENT' - ; MCE58( -----------> Verify Event/Element: 'NEW SITE FLAGGED ORDER' - ; - Q:$G(^OCXS(860.2,48,"INACT")) - ; - I $$MCE58 D - .I $$MCE127 D R48R1B - Q - ; -R48R1B ; Send Order Check, Notication messages and/or Execute code for Rule #48 'SITE FLAGGED ORDER' Relation #1 'NEW SITE FLAGGED ORDER AND INPATIENT' - ; Called from R48R1A+12. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT - ; NEWRULE( ---------> NEW RULE MESSAGE - ; - Q:$D(OCXRULE("R48R1B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - S OCXCMSG="" - S OCXNMSG="["_$$GETDATA(DFN,"58^127",147)_"] Order placed: "_$$GETDATA(DFN,"58^127",96)_" "_$$INT2DT($$GETDATA(DFN,"58^127",9),0)_"." - ; - Q:$G(OCXOERR) - ; - ; Send Notification - ; - S (OCXDUZ,OCXDATA)="",OCXNUM=0 - I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D - .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) - .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA - I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D - .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" - .S OCXNUM=+$P(OCXORD,U,2) - S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) - S OCXRULE("R48R1B")="" - I $$NEWRULE(DFN,OCXNUM,48,1,41,OCXNMSG) D I 1 - .D:($G(OCXTRACE)<5) EN^ORB3(41,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) - Q - ; -R48R2A ; Verify all Event/Elements of Rule #48 'SITE FLAGGED ORDER' Relation #2 'NEW SITE FLAGGED ORDER AND OUTPATIENT' - ; Called from EL58+6^OCXOZ0H, and EL128+5^OCXOZ0H. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE128( ----------> Verify Event/Element: 'OUTPATIENT' - ; MCE58( -----------> Verify Event/Element: 'NEW SITE FLAGGED ORDER' - ; - Q:$G(^OCXS(860.2,48,"INACT")) - ; - I $$MCE58 D - .I $$MCE128 D R48R2B^OCXOZ0T - Q - ; -CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM - ; - N CKSUM,PTR,ASC S CKSUM=0 - S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") - F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC - Q +CKSUM - ; -GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data - ; - N OCXE,VAL,PC S VAL="" - F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) - Q VAL - ; -INT2DT(OCXDT,OCXF) ; This Local Extrinsic Function converts an OCX internal format - ; date into an Externl Format (Human Readable) date. 'OCXF=SHORT FORMAT OCXF=LONG FORMAT - ; - Q:'$L($G(OCXDT)) "" S OCXF=+$G(OCXF) - N OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXCYR - S (OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXAP)="" - S OCXSEC=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 - S OCXMIN=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 - S OCXHR=$E(OCXDT#24+100,2,3),OCXDT=OCXDT\24 - S OCXCYR=($H\1461)*4+1841+(($H#1461)\365) - S OCXYR=(OCXDT\1461)*4+1841,OCXDT=OCXDT#1461 - S OCXLPYR=(OCXDT\365),OCXDT=OCXDT-(OCXLPYR*365),OCXYR=OCXYR+OCXLPYR - S OCXCNT="031^059^090^120^151^181^212^243^273^304^334^365" - S:(OCXLPYR=3) OCXCNT="031^060^091^121^152^182^213^244^274^305^335^366" - F OCXMON=1:1:12 Q:(OCXDT<$P(OCXCNT,U,OCXMON)) - S OCXDAY=OCXDT-$P(OCXCNT,U,OCXMON-1)+1 - I OCXF S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,OCXMON) - E S OCXMON=$E(OCXMON+100,2,3) - S OCXAP=$S('OCXHR:"Midnight",(OCXHR=12):"Noon",(OCXHR<12):"AM",1:"PM") - I OCXF S OCXHR=OCXHR#12 S:'OCXHR OCXHR=12 - Q:'OCXF $E(OCXMON+100,2,3)_"/"_$E(OCXDAY+100,2,3)_$S((OCXCYR=OCXYR):" "_OCXHR_":"_OCXMIN,1:"/"_$E(OCXYR,3,4)) - Q:(OCXHR+OCXMIN+OCXSEC) OCXMON_" "_OCXDAY_","_OCXYR_" at "_OCXHR_":"_OCXMIN_"."_OCXSEC_" "_OCXAP - Q OCXMON_" "_OCXDAY_","_OCXYR - ; -MCE127() ; Verify Event/Element: INPATIENT - ; - ; - N OCXRES - I $L(OCXDF(37)) S OCXRES(127,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),127)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),127)) - Q 0 - ; -MCE128() ; Verify Event/Element: OUTPATIENT - ; - ; - N OCXRES - I $L(OCXDF(37)) S OCXRES(128,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),128)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),128)) - Q 0 - ; -MCE58() ; Verify Event/Element: NEW SITE FLAGGED ORDER - ; - ; - N OCXRES - I $L(OCXDF(37)) S OCXRES(58,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),58)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),58)) - Q 0 - ; -NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number - ; - ; - Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 - Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 - S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN - ; - N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL - ; - S OCXTIME=(+$H) - S OCXCKSUM=$$CKSUM(OCXMESS) - ; - S OCXTSP=($H*86400)+$P($H,",",2) - S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) - ; - Q:(OCXTSPL>OCXTSP) 0 - ; - K OCXDATA - S OCXDATA(OCXDFN,0)=OCXDFN - S OCXDATA("B",OCXDFN,OCXDFN)="" - S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP - ; - S OCXGR="^OCXD(860.7" - D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) - ; - K OCXDATA - S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) - S OCXDATA(OCXRUL,"M")=OCXMESS - S OCXDATA("B",OCXRUL,OCXRUL)="" - S OCXGR=OCXGR_","_OCXDFN_",1" - D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) - ; - K OCXDATA - S OCXDATA(OCXREL,0)=OCXREL - S OCXDATA("B",OCXREL,OCXREL)="" - S OCXGR=OCXGR_","_OCXRUL_",1" - D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) - ; - S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D - .; - .N OCXGR1 - .S OCXGR1=OCXGR_","_OCXREL_",1" - .K OCXDATA - .S OCXDATA(OCXELE,0)=OCXELE - .S OCXDATA(OCXELE,"TIME")=OCXTIME - .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) - .S OCXDATA("B",OCXELE,OCXELE)="" - .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) - .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) - .; - .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D - ..N OCXGR2 - ..S OCXGR2=OCXGR1_","_OCXELE_",1" - ..K OCXDATA - ..S OCXDATA(OCXDFI,0)=OCXDFI - ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) - ..S OCXDATA("B",OCXDFI,OCXDFI)="" - ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) - ; - Q 1 - ; -SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data - M @ROOT=DATA - I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) - I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) - ; - Q - ; - ; +OCXOZ0S ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; + ; *************************************************************** + ; ** Warning: This routine is automatically generated by the ** + ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** + ; ** will be lost the next time the rule compiler executes. ** + ; *************************************************************** + ; + Q + ; +R44R1B ; Send Order Check, Notication messages and/or Execute code for Rule #44 'ORDER REQUIRES ELECTRONIC SIGNATURE' Relation #1 'ELECTRONIC SIGNATURE' + ; Called from R44R1A+10^OCXOZ0R. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; NEWRULE( ---------> NEW RULE MESSAGE + ; + Q:$D(OCXRULE("R44R1B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + S OCXCMSG="" + S OCXNMSG="Order requires electronic signature." + ; + Q:$G(OCXOERR) + ; + ; Send Notification + ; + S (OCXDUZ,OCXDATA)="",OCXNUM=0 + I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D + .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) + .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA + I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D + .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" + .S OCXNUM=+$P(OCXORD,U,2) + S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) + S OCXRULE("R44R1B")="" + I $$NEWRULE(DFN,OCXNUM,44,1,12,OCXNMSG) D I 1 + .D:($G(OCXTRACE)<5) EN^ORB3(12,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) + Q + ; +R48R1A ; Verify all Event/Elements of Rule #48 'SITE FLAGGED ORDER' Relation #1 'NEW SITE FLAGGED ORDER AND INPATIENT' + ; Called from EL58+5^OCXOZ0H, and EL127+5^OCXOZ0H. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE127( ----------> Verify Event/Element: 'INPATIENT' + ; MCE58( -----------> Verify Event/Element: 'NEW SITE FLAGGED ORDER' + ; + Q:$G(^OCXS(860.2,48,"INACT")) + ; + I $$MCE58 D + .I $$MCE127 D R48R1B + Q + ; +R48R1B ; Send Order Check, Notication messages and/or Execute code for Rule #48 'SITE FLAGGED ORDER' Relation #1 'NEW SITE FLAGGED ORDER AND INPATIENT' + ; Called from R48R1A+12. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT + ; NEWRULE( ---------> NEW RULE MESSAGE + ; + Q:$D(OCXRULE("R48R1B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + S OCXCMSG="" + S OCXNMSG="["_$$GETDATA(DFN,"58^127",147)_"] Order placed: "_$$GETDATA(DFN,"58^127",96)_" "_$$INT2DT($$GETDATA(DFN,"58^127",9),0)_"." + ; + Q:$G(OCXOERR) + ; + ; Send Notification + ; + S (OCXDUZ,OCXDATA)="",OCXNUM=0 + I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D + .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) + .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA + I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D + .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" + .S OCXNUM=+$P(OCXORD,U,2) + S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) + S OCXRULE("R48R1B")="" + I $$NEWRULE(DFN,OCXNUM,48,1,41,OCXNMSG) D I 1 + .D:($G(OCXTRACE)<5) EN^ORB3(41,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) + Q + ; +R48R2A ; Verify all Event/Elements of Rule #48 'SITE FLAGGED ORDER' Relation #2 'NEW SITE FLAGGED ORDER AND OUTPATIENT' + ; Called from EL58+6^OCXOZ0H, and EL128+5^OCXOZ0H. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE128( ----------> Verify Event/Element: 'OUTPATIENT' + ; MCE58( -----------> Verify Event/Element: 'NEW SITE FLAGGED ORDER' + ; + Q:$G(^OCXS(860.2,48,"INACT")) + ; + I $$MCE58 D + .I $$MCE128 D R48R2B^OCXOZ0T + Q + ; +CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM + ; + N CKSUM,PTR,ASC S CKSUM=0 + S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") + F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC + Q +CKSUM + ; +GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data + ; + N OCXE,VAL,PC S VAL="" + F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) + Q VAL + ; +INT2DT(OCXDT,OCXF) ; This Local Extrinsic Function converts an OCX internal format + ; date into an Externl Format (Human Readable) date. 'OCXF=SHORT FORMAT OCXF=LONG FORMAT + ; + Q:'$L($G(OCXDT)) "" S OCXF=+$G(OCXF) + N OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXCYR + S (OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXAP)="" + S OCXSEC=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 + S OCXMIN=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 + S OCXHR=$E(OCXDT#24+100,2,3),OCXDT=OCXDT\24 + S OCXCYR=($H\1461)*4+1841+(($H#1461)\365) + S OCXYR=(OCXDT\1461)*4+1841,OCXDT=OCXDT#1461 + S OCXLPYR=(OCXDT\365),OCXDT=OCXDT-(OCXLPYR*365),OCXYR=OCXYR+OCXLPYR + S OCXCNT="031^059^090^120^151^181^212^243^273^304^334^365" + S:(OCXLPYR=3) OCXCNT="031^060^091^121^152^182^213^244^274^305^335^366" + F OCXMON=1:1:12 Q:(OCXDT<$P(OCXCNT,U,OCXMON)) + S OCXDAY=OCXDT-$P(OCXCNT,U,OCXMON-1)+1 + I OCXF S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,OCXMON) + E S OCXMON=$E(OCXMON+100,2,3) + S OCXAP=$S('OCXHR:"Midnight",(OCXHR=12):"Noon",(OCXHR<12):"AM",1:"PM") + I OCXF S OCXHR=OCXHR#12 S:'OCXHR OCXHR=12 + Q:'OCXF $E(OCXMON+100,2,3)_"/"_$E(OCXDAY+100,2,3)_$S((OCXCYR=OCXYR):" "_OCXHR_":"_OCXMIN,1:"/"_$E(OCXYR,3,4)) + Q:(OCXHR+OCXMIN+OCXSEC) OCXMON_" "_OCXDAY_","_OCXYR_" at "_OCXHR_":"_OCXMIN_"."_OCXSEC_" "_OCXAP + Q OCXMON_" "_OCXDAY_","_OCXYR + ; +MCE127() ; Verify Event/Element: INPATIENT + ; + ; + N OCXRES + I $L(OCXDF(37)) S OCXRES(127,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),127)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),127)) + Q 0 + ; +MCE128() ; Verify Event/Element: OUTPATIENT + ; + ; + N OCXRES + I $L(OCXDF(37)) S OCXRES(128,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),128)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),128)) + Q 0 + ; +MCE58() ; Verify Event/Element: NEW SITE FLAGGED ORDER + ; + ; + N OCXRES + I $L(OCXDF(37)) S OCXRES(58,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),58)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),58)) + Q 0 + ; +NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number + ; + ; + Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 + Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 + S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN + ; + N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL + ; + S OCXTIME=(+$H) + S OCXCKSUM=$$CKSUM(OCXMESS) + ; + S OCXTSP=($H*86400)+$P($H,",",2) + S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) + ; + Q:(OCXTSPL>OCXTSP) 0 + ; + K OCXDATA + S OCXDATA(OCXDFN,0)=OCXDFN + S OCXDATA("B",OCXDFN,OCXDFN)="" + S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP + ; + S OCXGR="^OCXD(860.7" + D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) + ; + K OCXDATA + S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) + S OCXDATA(OCXRUL,"M")=OCXMESS + S OCXDATA("B",OCXRUL,OCXRUL)="" + S OCXGR=OCXGR_","_OCXDFN_",1" + D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) + ; + K OCXDATA + S OCXDATA(OCXREL,0)=OCXREL + S OCXDATA("B",OCXREL,OCXREL)="" + S OCXGR=OCXGR_","_OCXRUL_",1" + D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) + ; + S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D + .; + .N OCXGR1 + .S OCXGR1=OCXGR_","_OCXREL_",1" + .K OCXDATA + .S OCXDATA(OCXELE,0)=OCXELE + .S OCXDATA(OCXELE,"TIME")=OCXTIME + .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) + .S OCXDATA("B",OCXELE,OCXELE)="" + .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) + .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) + .; + .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D + ..N OCXGR2 + ..S OCXGR2=OCXGR1_","_OCXELE_",1" + ..K OCXDATA + ..S OCXDATA(OCXDFI,0)=OCXDFI + ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) + ..S OCXDATA("B",OCXDFI,OCXDFI)="" + ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) + ; + Q 1 + ; +SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data + M @ROOT=DATA + I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) + I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) + ; + Q + ; + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0T.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0T.m index f8e5d2cb..ae076fcb 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0T.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0T.m @@ -1,235 +1,235 @@ -OCXOZ0T ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; - ; *************************************************************** - ; ** Warning: This routine is automatically generated by the ** - ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** - ; ** will be lost the next time the rule compiler executes. ** - ; *************************************************************** - ; - Q - ; -R48R2B ; Send Order Check, Notication messages and/or Execute code for Rule #48 'SITE FLAGGED ORDER' Relation #2 'NEW SITE FLAGGED ORDER AND OUTPATIENT' - ; Called from R48R2A+12^OCXOZ0S. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT - ; NEWRULE( ---------> NEW RULE MESSAGE - ; - Q:$D(OCXRULE("R48R2B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - S OCXCMSG="" - S OCXNMSG="["_$$GETDATA(DFN,"58^128",147)_"] Order placed: "_$$GETDATA(DFN,"58^128",96)_" "_$$INT2DT($$GETDATA(DFN,"58^128",9),0)_"." - ; - Q:$G(OCXOERR) - ; - ; Send Notification - ; - S (OCXDUZ,OCXDATA)="",OCXNUM=0 - I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D - .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) - .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA - I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D - .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" - .S OCXNUM=+$P(OCXORD,U,2) - S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) - S OCXRULE("R48R2B")="" - I $$NEWRULE(DFN,OCXNUM,48,2,61,OCXNMSG) D I 1 - .D:($G(OCXTRACE)<5) EN^ORB3(61,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) - Q - ; -R49R1A ; Verify all Event/Elements of Rule #49 'SITE FLAGGED RESULT' Relation #1 'INPATIENT AND (SITE FLAGGED LAB RESULT OR SITE FLA...' - ; Called from EL127+6^OCXOZ0H, and EL59+5^OCXOZ0H, and EL102+5^OCXOZ0H, and EL109+5^OCXOZ0H. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE102( ----------> Verify Event/Element: 'SITE FLAGGED FINAL IMAGING RESULT' - ; MCE109( ----------> Verify Event/Element: 'SITE FLAGGED FINAL CONSULT RESULT' - ; MCE127( ----------> Verify Event/Element: 'INPATIENT' - ; MCE59( -----------> Verify Event/Element: 'SITE FLAGGED FINAL LAB RESULT' - ; - Q:$G(^OCXS(860.2,49,"INACT")) - ; - I $$MCE127 D - .I $$MCE59 D R49R1B - .I $$MCE102 D R49R1B - .I $$MCE109 D R49R1B - Q - ; -R49R1B ; Send Order Check, Notication messages and/or Execute code for Rule #49 'SITE FLAGGED RESULT' Relation #1 'INPATIENT AND (SITE FLAGGED LAB RESULT OR SITE FLA...' - ; Called from R49R1A+14. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT - ; NEWRULE( ---------> NEW RULE MESSAGE - ; - Q:$D(OCXRULE("R49R1B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - S OCXCMSG="" - S OCXNMSG="["_$$GETDATA(DFN,"59^102^109^127",147)_"] Result available: "_$$GETDATA(DFN,"59^102^109^127",96)_" "_$$INT2DT($$GETDATA(DFN,"59^102^109^127",9),0)_" " - ; - Q:$G(OCXOERR) - ; - ; Send Notification - ; - S (OCXDUZ,OCXDATA)="",OCXNUM=0 - I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D - .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) - .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA - I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D - .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" - .S OCXNUM=+$P(OCXORD,U,2) - S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) - S OCXRULE("R49R1B")="" - I $$NEWRULE(DFN,OCXNUM,49,1,32,OCXNMSG) D I 1 - .D:($G(OCXTRACE)<5) EN^ORB3(32,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) - Q - ; -CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM - ; - N CKSUM,PTR,ASC S CKSUM=0 - S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") - F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC - Q +CKSUM - ; -GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data - ; - N OCXE,VAL,PC S VAL="" - F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) - Q VAL - ; -INT2DT(OCXDT,OCXF) ; This Local Extrinsic Function converts an OCX internal format - ; date into an Externl Format (Human Readable) date. 'OCXF=SHORT FORMAT OCXF=LONG FORMAT - ; - Q:'$L($G(OCXDT)) "" S OCXF=+$G(OCXF) - N OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXCYR - S (OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXAP)="" - S OCXSEC=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 - S OCXMIN=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 - S OCXHR=$E(OCXDT#24+100,2,3),OCXDT=OCXDT\24 - S OCXCYR=($H\1461)*4+1841+(($H#1461)\365) - S OCXYR=(OCXDT\1461)*4+1841,OCXDT=OCXDT#1461 - S OCXLPYR=(OCXDT\365),OCXDT=OCXDT-(OCXLPYR*365),OCXYR=OCXYR+OCXLPYR - S OCXCNT="031^059^090^120^151^181^212^243^273^304^334^365" - S:(OCXLPYR=3) OCXCNT="031^060^091^121^152^182^213^244^274^305^335^366" - F OCXMON=1:1:12 Q:(OCXDT<$P(OCXCNT,U,OCXMON)) - S OCXDAY=OCXDT-$P(OCXCNT,U,OCXMON-1)+1 - I OCXF S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,OCXMON) - E S OCXMON=$E(OCXMON+100,2,3) - S OCXAP=$S('OCXHR:"Midnight",(OCXHR=12):"Noon",(OCXHR<12):"AM",1:"PM") - I OCXF S OCXHR=OCXHR#12 S:'OCXHR OCXHR=12 - Q:'OCXF $E(OCXMON+100,2,3)_"/"_$E(OCXDAY+100,2,3)_$S((OCXCYR=OCXYR):" "_OCXHR_":"_OCXMIN,1:"/"_$E(OCXYR,3,4)) - Q:(OCXHR+OCXMIN+OCXSEC) OCXMON_" "_OCXDAY_","_OCXYR_" at "_OCXHR_":"_OCXMIN_"."_OCXSEC_" "_OCXAP - Q OCXMON_" "_OCXDAY_","_OCXYR - ; -MCE102() ; Verify Event/Element: SITE FLAGGED FINAL IMAGING RESULT - ; - ; - N OCXRES - I $L(OCXDF(37)) S OCXRES(102,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),102)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),102)) - Q 0 - ; -MCE109() ; Verify Event/Element: SITE FLAGGED FINAL CONSULT RESULT - ; - ; - N OCXRES - I $L(OCXDF(37)) S OCXRES(109,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),109)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),109)) - Q 0 - ; -MCE127() ; Verify Event/Element: INPATIENT - ; - ; - N OCXRES - I $L(OCXDF(37)) S OCXRES(127,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),127)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),127)) - Q 0 - ; -MCE59() ; Verify Event/Element: SITE FLAGGED FINAL LAB RESULT - ; - ; - N OCXRES - I $L(OCXDF(37)) S OCXRES(59,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),59)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),59)) - Q 0 - ; -NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number - ; - ; - Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 - Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 - S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN - ; - N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL - ; - S OCXTIME=(+$H) - S OCXCKSUM=$$CKSUM(OCXMESS) - ; - S OCXTSP=($H*86400)+$P($H,",",2) - S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) - ; - Q:(OCXTSPL>OCXTSP) 0 - ; - K OCXDATA - S OCXDATA(OCXDFN,0)=OCXDFN - S OCXDATA("B",OCXDFN,OCXDFN)="" - S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP - ; - S OCXGR="^OCXD(860.7" - D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) - ; - K OCXDATA - S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) - S OCXDATA(OCXRUL,"M")=OCXMESS - S OCXDATA("B",OCXRUL,OCXRUL)="" - S OCXGR=OCXGR_","_OCXDFN_",1" - D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) - ; - K OCXDATA - S OCXDATA(OCXREL,0)=OCXREL - S OCXDATA("B",OCXREL,OCXREL)="" - S OCXGR=OCXGR_","_OCXRUL_",1" - D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) - ; - S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D - .; - .N OCXGR1 - .S OCXGR1=OCXGR_","_OCXREL_",1" - .K OCXDATA - .S OCXDATA(OCXELE,0)=OCXELE - .S OCXDATA(OCXELE,"TIME")=OCXTIME - .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) - .S OCXDATA("B",OCXELE,OCXELE)="" - .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) - .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) - .; - .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D - ..N OCXGR2 - ..S OCXGR2=OCXGR1_","_OCXELE_",1" - ..K OCXDATA - ..S OCXDATA(OCXDFI,0)=OCXDFI - ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) - ..S OCXDATA("B",OCXDFI,OCXDFI)="" - ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) - ; - Q 1 - ; -SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data - M @ROOT=DATA - I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) - I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) - ; - Q - ; - ; +OCXOZ0T ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; + ; *************************************************************** + ; ** Warning: This routine is automatically generated by the ** + ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** + ; ** will be lost the next time the rule compiler executes. ** + ; *************************************************************** + ; + Q + ; +R48R2B ; Send Order Check, Notication messages and/or Execute code for Rule #48 'SITE FLAGGED ORDER' Relation #2 'NEW SITE FLAGGED ORDER AND OUTPATIENT' + ; Called from R48R2A+12^OCXOZ0S. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT + ; NEWRULE( ---------> NEW RULE MESSAGE + ; + Q:$D(OCXRULE("R48R2B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + S OCXCMSG="" + S OCXNMSG="["_$$GETDATA(DFN,"58^128",147)_"] Order placed: "_$$GETDATA(DFN,"58^128",96)_" "_$$INT2DT($$GETDATA(DFN,"58^128",9),0)_"." + ; + Q:$G(OCXOERR) + ; + ; Send Notification + ; + S (OCXDUZ,OCXDATA)="",OCXNUM=0 + I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D + .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) + .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA + I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D + .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" + .S OCXNUM=+$P(OCXORD,U,2) + S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) + S OCXRULE("R48R2B")="" + I $$NEWRULE(DFN,OCXNUM,48,2,61,OCXNMSG) D I 1 + .D:($G(OCXTRACE)<5) EN^ORB3(61,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) + Q + ; +R49R1A ; Verify all Event/Elements of Rule #49 'SITE FLAGGED RESULT' Relation #1 'INPATIENT AND (SITE FLAGGED LAB RESULT OR SITE FLA...' + ; Called from EL127+6^OCXOZ0H, and EL59+5^OCXOZ0H, and EL102+5^OCXOZ0H, and EL109+5^OCXOZ0H. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE102( ----------> Verify Event/Element: 'SITE FLAGGED FINAL IMAGING RESULT' + ; MCE109( ----------> Verify Event/Element: 'SITE FLAGGED FINAL CONSULT RESULT' + ; MCE127( ----------> Verify Event/Element: 'INPATIENT' + ; MCE59( -----------> Verify Event/Element: 'SITE FLAGGED FINAL LAB RESULT' + ; + Q:$G(^OCXS(860.2,49,"INACT")) + ; + I $$MCE127 D + .I $$MCE59 D R49R1B + .I $$MCE102 D R49R1B + .I $$MCE109 D R49R1B + Q + ; +R49R1B ; Send Order Check, Notication messages and/or Execute code for Rule #49 'SITE FLAGGED RESULT' Relation #1 'INPATIENT AND (SITE FLAGGED LAB RESULT OR SITE FLA...' + ; Called from R49R1A+14. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT + ; NEWRULE( ---------> NEW RULE MESSAGE + ; + Q:$D(OCXRULE("R49R1B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + S OCXCMSG="" + S OCXNMSG="["_$$GETDATA(DFN,"59^102^109^127",147)_"] Result available: "_$$GETDATA(DFN,"59^102^109^127",96)_" "_$$INT2DT($$GETDATA(DFN,"59^102^109^127",9),0)_" " + ; + Q:$G(OCXOERR) + ; + ; Send Notification + ; + S (OCXDUZ,OCXDATA)="",OCXNUM=0 + I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D + .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) + .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA + I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D + .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" + .S OCXNUM=+$P(OCXORD,U,2) + S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) + S OCXRULE("R49R1B")="" + I $$NEWRULE(DFN,OCXNUM,49,1,32,OCXNMSG) D I 1 + .D:($G(OCXTRACE)<5) EN^ORB3(32,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) + Q + ; +CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM + ; + N CKSUM,PTR,ASC S CKSUM=0 + S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") + F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC + Q +CKSUM + ; +GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data + ; + N OCXE,VAL,PC S VAL="" + F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) + Q VAL + ; +INT2DT(OCXDT,OCXF) ; This Local Extrinsic Function converts an OCX internal format + ; date into an Externl Format (Human Readable) date. 'OCXF=SHORT FORMAT OCXF=LONG FORMAT + ; + Q:'$L($G(OCXDT)) "" S OCXF=+$G(OCXF) + N OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXCYR + S (OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXAP)="" + S OCXSEC=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 + S OCXMIN=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 + S OCXHR=$E(OCXDT#24+100,2,3),OCXDT=OCXDT\24 + S OCXCYR=($H\1461)*4+1841+(($H#1461)\365) + S OCXYR=(OCXDT\1461)*4+1841,OCXDT=OCXDT#1461 + S OCXLPYR=(OCXDT\365),OCXDT=OCXDT-(OCXLPYR*365),OCXYR=OCXYR+OCXLPYR + S OCXCNT="031^059^090^120^151^181^212^243^273^304^334^365" + S:(OCXLPYR=3) OCXCNT="031^060^091^121^152^182^213^244^274^305^335^366" + F OCXMON=1:1:12 Q:(OCXDT<$P(OCXCNT,U,OCXMON)) + S OCXDAY=OCXDT-$P(OCXCNT,U,OCXMON-1)+1 + I OCXF S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,OCXMON) + E S OCXMON=$E(OCXMON+100,2,3) + S OCXAP=$S('OCXHR:"Midnight",(OCXHR=12):"Noon",(OCXHR<12):"AM",1:"PM") + I OCXF S OCXHR=OCXHR#12 S:'OCXHR OCXHR=12 + Q:'OCXF $E(OCXMON+100,2,3)_"/"_$E(OCXDAY+100,2,3)_$S((OCXCYR=OCXYR):" "_OCXHR_":"_OCXMIN,1:"/"_$E(OCXYR,3,4)) + Q:(OCXHR+OCXMIN+OCXSEC) OCXMON_" "_OCXDAY_","_OCXYR_" at "_OCXHR_":"_OCXMIN_"."_OCXSEC_" "_OCXAP + Q OCXMON_" "_OCXDAY_","_OCXYR + ; +MCE102() ; Verify Event/Element: SITE FLAGGED FINAL IMAGING RESULT + ; + ; + N OCXRES + I $L(OCXDF(37)) S OCXRES(102,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),102)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),102)) + Q 0 + ; +MCE109() ; Verify Event/Element: SITE FLAGGED FINAL CONSULT RESULT + ; + ; + N OCXRES + I $L(OCXDF(37)) S OCXRES(109,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),109)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),109)) + Q 0 + ; +MCE127() ; Verify Event/Element: INPATIENT + ; + ; + N OCXRES + I $L(OCXDF(37)) S OCXRES(127,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),127)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),127)) + Q 0 + ; +MCE59() ; Verify Event/Element: SITE FLAGGED FINAL LAB RESULT + ; + ; + N OCXRES + I $L(OCXDF(37)) S OCXRES(59,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),59)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),59)) + Q 0 + ; +NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number + ; + ; + Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 + Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 + S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN + ; + N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL + ; + S OCXTIME=(+$H) + S OCXCKSUM=$$CKSUM(OCXMESS) + ; + S OCXTSP=($H*86400)+$P($H,",",2) + S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) + ; + Q:(OCXTSPL>OCXTSP) 0 + ; + K OCXDATA + S OCXDATA(OCXDFN,0)=OCXDFN + S OCXDATA("B",OCXDFN,OCXDFN)="" + S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP + ; + S OCXGR="^OCXD(860.7" + D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) + ; + K OCXDATA + S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) + S OCXDATA(OCXRUL,"M")=OCXMESS + S OCXDATA("B",OCXRUL,OCXRUL)="" + S OCXGR=OCXGR_","_OCXDFN_",1" + D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) + ; + K OCXDATA + S OCXDATA(OCXREL,0)=OCXREL + S OCXDATA("B",OCXREL,OCXREL)="" + S OCXGR=OCXGR_","_OCXRUL_",1" + D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) + ; + S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D + .; + .N OCXGR1 + .S OCXGR1=OCXGR_","_OCXREL_",1" + .K OCXDATA + .S OCXDATA(OCXELE,0)=OCXELE + .S OCXDATA(OCXELE,"TIME")=OCXTIME + .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) + .S OCXDATA("B",OCXELE,OCXELE)="" + .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) + .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) + .; + .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D + ..N OCXGR2 + ..S OCXGR2=OCXGR1_","_OCXELE_",1" + ..K OCXDATA + ..S OCXDATA(OCXDFI,0)=OCXDFI + ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) + ..S OCXDATA("B",OCXDFI,OCXDFI)="" + ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) + ; + Q 1 + ; +SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data + M @ROOT=DATA + I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) + I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) + ; + Q + ; + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0U.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0U.m index 6ddf695d..7641c04b 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0U.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0U.m @@ -1,235 +1,235 @@ -OCXOZ0U ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; - ; *************************************************************** - ; ** Warning: This routine is automatically generated by the ** - ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** - ; ** will be lost the next time the rule compiler executes. ** - ; *************************************************************** - ; - Q - ; -R49R2A ; Verify all Event/Elements of Rule #49 'SITE FLAGGED RESULT' Relation #2 'OUTPATIENT AND (SITE FLAGGED LAB RESULT OR SITE FL...' - ; Called from EL128+6^OCXOZ0H, and EL59+6^OCXOZ0H, and EL102+6^OCXOZ0H, and EL109+6^OCXOZ0H. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE102( ----------> Verify Event/Element: 'SITE FLAGGED FINAL IMAGING RESULT' - ; MCE109( ----------> Verify Event/Element: 'SITE FLAGGED FINAL CONSULT RESULT' - ; MCE128( ----------> Verify Event/Element: 'OUTPATIENT' - ; MCE59( -----------> Verify Event/Element: 'SITE FLAGGED FINAL LAB RESULT' - ; - Q:$G(^OCXS(860.2,49,"INACT")) - ; - I $$MCE128 D - .I $$MCE59 D R49R2B - .I $$MCE102 D R49R2B - .I $$MCE109 D R49R2B - Q - ; -R49R2B ; Send Order Check, Notication messages and/or Execute code for Rule #49 'SITE FLAGGED RESULT' Relation #2 'OUTPATIENT AND (SITE FLAGGED LAB RESULT OR SITE FL...' - ; Called from R49R2A+14. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT - ; NEWRULE( ---------> NEW RULE MESSAGE - ; - Q:$D(OCXRULE("R49R2B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - S OCXCMSG="" - S OCXNMSG="["_$$GETDATA(DFN,"59^102^109^128",147)_"] Result available: "_$$GETDATA(DFN,"59^102^109^128",96)_" "_$$INT2DT($$GETDATA(DFN,"59^102^109^128",9),0)_" " - ; - Q:$G(OCXOERR) - ; - ; Send Notification - ; - S (OCXDUZ,OCXDATA)="",OCXNUM=0 - I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D - .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) - .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA - I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D - .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" - .S OCXNUM=+$P(OCXORD,U,2) - S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) - S OCXRULE("R49R2B")="" - I $$NEWRULE(DFN,OCXNUM,49,2,60,OCXNMSG) D I 1 - .D:($G(OCXTRACE)<5) EN^ORB3(60,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) - Q - ; -R50R1A ; Verify all Event/Elements of Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHE...' Relation #1 'CONTRAST MEDIA ORDER AND ABNORMAL RENAL RESULTS' - ; Called from EL129+5^OCXOZ0H, and EL130+5^OCXOZ0H. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE129( ----------> Verify Event/Element: 'ABNORMAL RENAL RESULTS' - ; MCE130( ----------> Verify Event/Element: 'CONTRAST MEDIA ORDER' - ; - Q:$G(^OCXS(860.2,50,"INACT")) - ; - I $$MCE130 D - .I $$MCE129 D R50R1B^OCXOZ0V - Q - ; -CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM - ; - N CKSUM,PTR,ASC S CKSUM=0 - S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") - F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC - Q +CKSUM - ; -GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data - ; - N OCXE,VAL,PC S VAL="" - F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) - Q VAL - ; -INT2DT(OCXDT,OCXF) ; This Local Extrinsic Function converts an OCX internal format - ; date into an Externl Format (Human Readable) date. 'OCXF=SHORT FORMAT OCXF=LONG FORMAT - ; - Q:'$L($G(OCXDT)) "" S OCXF=+$G(OCXF) - N OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXCYR - S (OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXAP)="" - S OCXSEC=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 - S OCXMIN=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 - S OCXHR=$E(OCXDT#24+100,2,3),OCXDT=OCXDT\24 - S OCXCYR=($H\1461)*4+1841+(($H#1461)\365) - S OCXYR=(OCXDT\1461)*4+1841,OCXDT=OCXDT#1461 - S OCXLPYR=(OCXDT\365),OCXDT=OCXDT-(OCXLPYR*365),OCXYR=OCXYR+OCXLPYR - S OCXCNT="031^059^090^120^151^181^212^243^273^304^334^365" - S:(OCXLPYR=3) OCXCNT="031^060^091^121^152^182^213^244^274^305^335^366" - F OCXMON=1:1:12 Q:(OCXDT<$P(OCXCNT,U,OCXMON)) - S OCXDAY=OCXDT-$P(OCXCNT,U,OCXMON-1)+1 - I OCXF S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,OCXMON) - E S OCXMON=$E(OCXMON+100,2,3) - S OCXAP=$S('OCXHR:"Midnight",(OCXHR=12):"Noon",(OCXHR<12):"AM",1:"PM") - I OCXF S OCXHR=OCXHR#12 S:'OCXHR OCXHR=12 - Q:'OCXF $E(OCXMON+100,2,3)_"/"_$E(OCXDAY+100,2,3)_$S((OCXCYR=OCXYR):" "_OCXHR_":"_OCXMIN,1:"/"_$E(OCXYR,3,4)) - Q:(OCXHR+OCXMIN+OCXSEC) OCXMON_" "_OCXDAY_","_OCXYR_" at "_OCXHR_":"_OCXMIN_"."_OCXSEC_" "_OCXAP - Q OCXMON_" "_OCXDAY_","_OCXYR - ; -MCE102() ; Verify Event/Element: SITE FLAGGED FINAL IMAGING RESULT - ; - ; - N OCXRES - I $L(OCXDF(37)) S OCXRES(102,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),102)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),102)) - Q 0 - ; -MCE109() ; Verify Event/Element: SITE FLAGGED FINAL CONSULT RESULT - ; - ; - N OCXRES - I $L(OCXDF(37)) S OCXRES(109,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),109)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),109)) - Q 0 - ; -MCE128() ; Verify Event/Element: OUTPATIENT - ; - ; - N OCXRES - I $L(OCXDF(37)) S OCXRES(128,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),128)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),128)) - Q 0 - ; -MCE129() ; Verify Event/Element: ABNORMAL RENAL RESULTS - ; - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(129,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),129)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),129)) - Q 0 - ; -MCE130() ; Verify Event/Element: CONTRAST MEDIA ORDER - ; - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(130,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),130)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),130)) - Q 0 - ; -MCE59() ; Verify Event/Element: SITE FLAGGED FINAL LAB RESULT - ; - ; - N OCXRES - I $L(OCXDF(37)) S OCXRES(59,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),59)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),59)) - Q 0 - ; -NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number - ; - ; - Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 - Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 - S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN - ; - N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL - ; - S OCXTIME=(+$H) - S OCXCKSUM=$$CKSUM(OCXMESS) - ; - S OCXTSP=($H*86400)+$P($H,",",2) - S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) - ; - Q:(OCXTSPL>OCXTSP) 0 - ; - K OCXDATA - S OCXDATA(OCXDFN,0)=OCXDFN - S OCXDATA("B",OCXDFN,OCXDFN)="" - S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP - ; - S OCXGR="^OCXD(860.7" - D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) - ; - K OCXDATA - S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) - S OCXDATA(OCXRUL,"M")=OCXMESS - S OCXDATA("B",OCXRUL,OCXRUL)="" - S OCXGR=OCXGR_","_OCXDFN_",1" - D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) - ; - K OCXDATA - S OCXDATA(OCXREL,0)=OCXREL - S OCXDATA("B",OCXREL,OCXREL)="" - S OCXGR=OCXGR_","_OCXRUL_",1" - D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) - ; - S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D - .; - .N OCXGR1 - .S OCXGR1=OCXGR_","_OCXREL_",1" - .K OCXDATA - .S OCXDATA(OCXELE,0)=OCXELE - .S OCXDATA(OCXELE,"TIME")=OCXTIME - .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) - .S OCXDATA("B",OCXELE,OCXELE)="" - .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) - .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) - .; - .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D - ..N OCXGR2 - ..S OCXGR2=OCXGR1_","_OCXELE_",1" - ..K OCXDATA - ..S OCXDATA(OCXDFI,0)=OCXDFI - ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) - ..S OCXDATA("B",OCXDFI,OCXDFI)="" - ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) - ; - Q 1 - ; -SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data - M @ROOT=DATA - I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) - I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) - ; - Q - ; - ; +OCXOZ0U ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; + ; *************************************************************** + ; ** Warning: This routine is automatically generated by the ** + ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** + ; ** will be lost the next time the rule compiler executes. ** + ; *************************************************************** + ; + Q + ; +R49R2A ; Verify all Event/Elements of Rule #49 'SITE FLAGGED RESULT' Relation #2 'OUTPATIENT AND (SITE FLAGGED LAB RESULT OR SITE FL...' + ; Called from EL128+6^OCXOZ0H, and EL59+6^OCXOZ0H, and EL102+6^OCXOZ0H, and EL109+6^OCXOZ0H. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE102( ----------> Verify Event/Element: 'SITE FLAGGED FINAL IMAGING RESULT' + ; MCE109( ----------> Verify Event/Element: 'SITE FLAGGED FINAL CONSULT RESULT' + ; MCE128( ----------> Verify Event/Element: 'OUTPATIENT' + ; MCE59( -----------> Verify Event/Element: 'SITE FLAGGED FINAL LAB RESULT' + ; + Q:$G(^OCXS(860.2,49,"INACT")) + ; + I $$MCE128 D + .I $$MCE59 D R49R2B + .I $$MCE102 D R49R2B + .I $$MCE109 D R49R2B + Q + ; +R49R2B ; Send Order Check, Notication messages and/or Execute code for Rule #49 'SITE FLAGGED RESULT' Relation #2 'OUTPATIENT AND (SITE FLAGGED LAB RESULT OR SITE FL...' + ; Called from R49R2A+14. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; INT2DT( ----------> CONVERT DATE FROM OCX FORMAT TO READABLE FORMAT + ; NEWRULE( ---------> NEW RULE MESSAGE + ; + Q:$D(OCXRULE("R49R2B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + S OCXCMSG="" + S OCXNMSG="["_$$GETDATA(DFN,"59^102^109^128",147)_"] Result available: "_$$GETDATA(DFN,"59^102^109^128",96)_" "_$$INT2DT($$GETDATA(DFN,"59^102^109^128",9),0)_" " + ; + Q:$G(OCXOERR) + ; + ; Send Notification + ; + S (OCXDUZ,OCXDATA)="",OCXNUM=0 + I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D + .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) + .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA + I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D + .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" + .S OCXNUM=+$P(OCXORD,U,2) + S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) + S OCXRULE("R49R2B")="" + I $$NEWRULE(DFN,OCXNUM,49,2,60,OCXNMSG) D I 1 + .D:($G(OCXTRACE)<5) EN^ORB3(60,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) + Q + ; +R50R1A ; Verify all Event/Elements of Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHE...' Relation #1 'CONTRAST MEDIA ORDER AND ABNORMAL RENAL RESULTS' + ; Called from EL129+5^OCXOZ0H, and EL130+5^OCXOZ0H. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE129( ----------> Verify Event/Element: 'ABNORMAL RENAL RESULTS' + ; MCE130( ----------> Verify Event/Element: 'CONTRAST MEDIA ORDER' + ; + Q:$G(^OCXS(860.2,50,"INACT")) + ; + I $$MCE130 D + .I $$MCE129 D R50R1B^OCXOZ0V + Q + ; +CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM + ; + N CKSUM,PTR,ASC S CKSUM=0 + S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") + F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC + Q +CKSUM + ; +GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data + ; + N OCXE,VAL,PC S VAL="" + F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) + Q VAL + ; +INT2DT(OCXDT,OCXF) ; This Local Extrinsic Function converts an OCX internal format + ; date into an Externl Format (Human Readable) date. 'OCXF=SHORT FORMAT OCXF=LONG FORMAT + ; + Q:'$L($G(OCXDT)) "" S OCXF=+$G(OCXF) + N OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXCYR + S (OCXYR,OCXLPYR,OCXMON,OCXDAY,OCXHR,OCXMIN,OCXSEC,OCXAP)="" + S OCXSEC=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 + S OCXMIN=$E(OCXDT#60+100,2,3),OCXDT=OCXDT\60 + S OCXHR=$E(OCXDT#24+100,2,3),OCXDT=OCXDT\24 + S OCXCYR=($H\1461)*4+1841+(($H#1461)\365) + S OCXYR=(OCXDT\1461)*4+1841,OCXDT=OCXDT#1461 + S OCXLPYR=(OCXDT\365),OCXDT=OCXDT-(OCXLPYR*365),OCXYR=OCXYR+OCXLPYR + S OCXCNT="031^059^090^120^151^181^212^243^273^304^334^365" + S:(OCXLPYR=3) OCXCNT="031^060^091^121^152^182^213^244^274^305^335^366" + F OCXMON=1:1:12 Q:(OCXDT<$P(OCXCNT,U,OCXMON)) + S OCXDAY=OCXDT-$P(OCXCNT,U,OCXMON-1)+1 + I OCXF S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,OCXMON) + E S OCXMON=$E(OCXMON+100,2,3) + S OCXAP=$S('OCXHR:"Midnight",(OCXHR=12):"Noon",(OCXHR<12):"AM",1:"PM") + I OCXF S OCXHR=OCXHR#12 S:'OCXHR OCXHR=12 + Q:'OCXF $E(OCXMON+100,2,3)_"/"_$E(OCXDAY+100,2,3)_$S((OCXCYR=OCXYR):" "_OCXHR_":"_OCXMIN,1:"/"_$E(OCXYR,3,4)) + Q:(OCXHR+OCXMIN+OCXSEC) OCXMON_" "_OCXDAY_","_OCXYR_" at "_OCXHR_":"_OCXMIN_"."_OCXSEC_" "_OCXAP + Q OCXMON_" "_OCXDAY_","_OCXYR + ; +MCE102() ; Verify Event/Element: SITE FLAGGED FINAL IMAGING RESULT + ; + ; + N OCXRES + I $L(OCXDF(37)) S OCXRES(102,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),102)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),102)) + Q 0 + ; +MCE109() ; Verify Event/Element: SITE FLAGGED FINAL CONSULT RESULT + ; + ; + N OCXRES + I $L(OCXDF(37)) S OCXRES(109,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),109)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),109)) + Q 0 + ; +MCE128() ; Verify Event/Element: OUTPATIENT + ; + ; + N OCXRES + I $L(OCXDF(37)) S OCXRES(128,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),128)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),128)) + Q 0 + ; +MCE129() ; Verify Event/Element: ABNORMAL RENAL RESULTS + ; + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(129,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),129)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),129)) + Q 0 + ; +MCE130() ; Verify Event/Element: CONTRAST MEDIA ORDER + ; + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(130,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),130)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),130)) + Q 0 + ; +MCE59() ; Verify Event/Element: SITE FLAGGED FINAL LAB RESULT + ; + ; + N OCXRES + I $L(OCXDF(37)) S OCXRES(59,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),59)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),59)) + Q 0 + ; +NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number + ; + ; + Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 + Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 + S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN + ; + N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL + ; + S OCXTIME=(+$H) + S OCXCKSUM=$$CKSUM(OCXMESS) + ; + S OCXTSP=($H*86400)+$P($H,",",2) + S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) + ; + Q:(OCXTSPL>OCXTSP) 0 + ; + K OCXDATA + S OCXDATA(OCXDFN,0)=OCXDFN + S OCXDATA("B",OCXDFN,OCXDFN)="" + S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP + ; + S OCXGR="^OCXD(860.7" + D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) + ; + K OCXDATA + S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) + S OCXDATA(OCXRUL,"M")=OCXMESS + S OCXDATA("B",OCXRUL,OCXRUL)="" + S OCXGR=OCXGR_","_OCXDFN_",1" + D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) + ; + K OCXDATA + S OCXDATA(OCXREL,0)=OCXREL + S OCXDATA("B",OCXREL,OCXREL)="" + S OCXGR=OCXGR_","_OCXRUL_",1" + D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) + ; + S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D + .; + .N OCXGR1 + .S OCXGR1=OCXGR_","_OCXREL_",1" + .K OCXDATA + .S OCXDATA(OCXELE,0)=OCXELE + .S OCXDATA(OCXELE,"TIME")=OCXTIME + .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) + .S OCXDATA("B",OCXELE,OCXELE)="" + .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) + .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) + .; + .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D + ..N OCXGR2 + ..S OCXGR2=OCXGR1_","_OCXELE_",1" + ..K OCXDATA + ..S OCXDATA(OCXDFI,0)=OCXDFI + ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) + ..S OCXDATA("B",OCXDFI,OCXDFI)="" + ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) + ; + Q 1 + ; +SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data + M @ROOT=DATA + I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) + I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) + ; + Q + ; + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0V.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0V.m index eabf6781..ceee0cb4 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0V.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0V.m @@ -1,271 +1,271 @@ -OCXOZ0V ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; - ; *************************************************************** - ; ** Warning: This routine is automatically generated by the ** - ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** - ; ** will be lost the next time the rule compiler executes. ** - ; *************************************************************** - ; - Q - ; -R50R1B ; Send Order Check, Notication messages and/or Execute code for Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHE...' Relation #1 'CONTRAST MEDIA ORDER AND ABNORMAL RENAL RESULTS' - ; Called from R50R1A+12^OCXOZ0U. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; - Q:$D(OCXRULE("R50R1B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^9^^Procedure uses intravenous contrast media - abnormal biochem result: "_$$GETDATA(DFN,"129^130",58) I 1 - E S OCXCMSG="Procedure uses intravenous contrast media - abnormal biochem result: "_$$GETDATA(DFN,"129^130",58) - S OCXNMSG="" - ; - Q:$G(OCXOERR) - ; - ; Send Order Check Message - ; - S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG - Q - ; -R50R2A ; Verify all Event/Elements of Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHE...' Relation #2 'CONTRAST MEDIA ORDER AND NO CREAT RESULTS W/IN X D...' - ; Called from EL130+6^OCXOZ0H, and EL133+5^OCXOZ0H. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE130( ----------> Verify Event/Element: 'CONTRAST MEDIA ORDER' - ; MCE133( ----------> Verify Event/Element: 'NO CREAT RESULTS W/IN X DAYS' - ; - Q:$G(^OCXS(860.2,50,"INACT")) - ; - I $$MCE130 D - .I $$MCE133 D R50R2B - Q - ; -R50R2B ; Send Order Check, Notication messages and/or Execute code for Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHE...' Relation #2 'CONTRAST MEDIA ORDER AND NO CREAT RESULTS W/IN X D...' - ; Called from R50R2A+12. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; - Q:$D(OCXRULE("R50R2B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^9^^Procedure uses intravenous contrast media - no creatinine results within "_$$GETDATA(DFN,"130^133",154)_" days" I 1 - E S OCXCMSG="Procedure uses intravenous contrast media - no creatinine results within "_$$GETDATA(DFN,"130^133",154)_" days" - S OCXNMSG="" - ; - Q:$G(OCXOERR) - ; - ; Send Order Check Message - ; - S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG - Q - ; -R51R1A ; Verify all Event/Elements of Rule #51 'RECENT CHOLECYSTOGRAM ORDER' Relation #1 'RECENT CHOLECGRM' - ; Called from EL63+5^OCXOZ0H. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE63( -----------> Verify Event/Element: 'PATIENT HAS RECENT CHOLECYSTOGRAM' - ; - Q:$G(^OCXS(860.2,51,"INACT")) - ; - I $$MCE63 D R51R1B - Q - ; -R51R1B ; Send Order Check, Notication messages and/or Execute code for Rule #51 'RECENT CHOLECYSTOGRAM ORDER' Relation #1 'RECENT CHOLECGRM' - ; Called from R51R1A+10. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; - Q:$D(OCXRULE("R51R1B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^15^^Recent Cholecystogram: "_$$GETDATA(DFN,"63^",61)_" ["_$$GETDATA(DFN,"63^",122)_"]" I 1 - E S OCXCMSG="Recent Cholecystogram: "_$$GETDATA(DFN,"63^",61)_" ["_$$GETDATA(DFN,"63^",122)_"]" - S OCXNMSG="" - ; - Q:$G(OCXOERR) - ; - ; Send Order Check Message - ; - S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG - Q - ; -R53R1A ; Verify all Event/Elements of Rule #53 'RENAL FUNCTIONS OVER AGE 65 CHECK' Relation #1 'PHARM PAT OVER 65' - ; Called from EL64+5^OCXOZ0H. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE64( -----------> Verify Event/Element: 'PHARMACY PATIENT OVER 65' - ; - Q:$G(^OCXS(860.2,53,"INACT")) - ; - I $$MCE64 D R53R1B - Q - ; -R53R1B ; Send Order Check, Notication messages and/or Execute code for Rule #53 'RENAL FUNCTIONS OVER AGE 65 CHECK' Relation #1 'PHARM PAT OVER 65' - ; Called from R53R1A+10. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; - Q:$D(OCXRULE("R53R1B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^21^^Patient >65. Renal Results: "_$$GETDATA(DFN,"64^",64) I 1 - E S OCXCMSG="Patient >65. Renal Results: "_$$GETDATA(DFN,"64^",64) - S OCXNMSG="" - ; - Q:$G(OCXOERR) - ; - ; Send Order Check Message - ; - S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG - Q - ; -R54R1A ; Verify all Event/Elements of Rule #54 'CONCURRENT LAB ORDERS FOR ANGIOGRAM, CAT...' Relation #1 'ANGIOGRAM' - ; Called from EL65+5^OCXOZ0H. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE65( -----------> Verify Event/Element: 'SESSION ORDER FOR ANGIOGRAM' - ; - Q:$G(^OCXS(860.2,54,"INACT")) - ; - I $$MCE65 D R54R1B - Q - ; -R54R1B ; Send Order Check, Notication messages and/or Execute code for Rule #54 'CONCURRENT LAB ORDERS FOR ANGIOGRAM, CAT...' Relation #1 'ANGIOGRAM' - ; Called from R54R1A+10. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; - Q:$D(OCXRULE("R54R1B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^22^^Missing Labs for Angiogram: "_$$GETDATA(DFN,"65^",68) I 1 - E S OCXCMSG="Missing Labs for Angiogram: "_$$GETDATA(DFN,"65^",68) - S OCXNMSG="" - ; - Q:$G(OCXOERR) - ; - ; Send Order Check Message - ; - S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG - Q - ; -R55R1A ; Verify all Event/Elements of Rule #55 'ALLERGY - CONTRAST MEDIA REACTION' Relation #1 'ALLERGY' - ; Called from EL66+5^OCXOZ0H. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE66( -----------> Verify Event/Element: 'CONTRAST MEDIA ALLERGY' - ; - Q:$G(^OCXS(860.2,55,"INACT")) - ; - I $$MCE66 D R55R1B - Q - ; -R55R1B ; Send Order Check, Notication messages and/or Execute code for Rule #55 'ALLERGY - CONTRAST MEDIA REACTION' Relation #1 'ALLERGY' - ; Called from R55R1A+10. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; - Q:$D(OCXRULE("R55R1B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^4^^Patient allergic to contrast media. ("_$$GETDATA(DFN,"66^",159)_") This procedure uses: "_$$GETDATA(DFN,"66^",66) I 1 - E S OCXCMSG="Patient allergic to contrast media. ("_$$GETDATA(DFN,"66^",159)_") This procedure uses: "_$$GETDATA(DFN,"66^",66) - S OCXNMSG="" - ; - Q:$G(OCXOERR) - ; - ; Send Order Check Message - ; - S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG - Q - ; -GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data - ; - N OCXE,VAL,PC S VAL="" - F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) - Q VAL - ; -MCE130() ; Verify Event/Element: CONTRAST MEDIA ORDER - ; - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(130,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),130)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),130)) - Q 0 - ; -MCE133() ; Verify Event/Element: NO CREAT RESULTS W/IN X DAYS - ; - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(133,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),133)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),133)) - Q 0 - ; -MCE63() ; Verify Event/Element: PATIENT HAS RECENT CHOLECYSTOGRAM - ; - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(63,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),63)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),63)) - Q 0 - ; -MCE64() ; Verify Event/Element: PHARMACY PATIENT OVER 65 - ; - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(64,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),64)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),64)) - Q 0 - ; -MCE65() ; Verify Event/Element: SESSION ORDER FOR ANGIOGRAM - ; - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(65,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),65)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),65)) - Q 0 - ; -MCE66() ; Verify Event/Element: CONTRAST MEDIA ALLERGY - ; - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(66,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),66)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),66)) - Q 0 - ; +OCXOZ0V ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; + ; *************************************************************** + ; ** Warning: This routine is automatically generated by the ** + ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** + ; ** will be lost the next time the rule compiler executes. ** + ; *************************************************************** + ; + Q + ; +R50R1B ; Send Order Check, Notication messages and/or Execute code for Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHE...' Relation #1 'CONTRAST MEDIA ORDER AND ABNORMAL RENAL RESULTS' + ; Called from R50R1A+12^OCXOZ0U. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; + Q:$D(OCXRULE("R50R1B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^9^^Procedure uses intravenous contrast media - abnormal biochem result: "_$$GETDATA(DFN,"129^130",58) I 1 + E S OCXCMSG="Procedure uses intravenous contrast media - abnormal biochem result: "_$$GETDATA(DFN,"129^130",58) + S OCXNMSG="" + ; + Q:$G(OCXOERR) + ; + ; Send Order Check Message + ; + S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG + Q + ; +R50R2A ; Verify all Event/Elements of Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHE...' Relation #2 'CONTRAST MEDIA ORDER AND NO CREAT RESULTS W/IN X D...' + ; Called from EL130+6^OCXOZ0H, and EL133+5^OCXOZ0H. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE130( ----------> Verify Event/Element: 'CONTRAST MEDIA ORDER' + ; MCE133( ----------> Verify Event/Element: 'NO CREAT RESULTS W/IN X DAYS' + ; + Q:$G(^OCXS(860.2,50,"INACT")) + ; + I $$MCE130 D + .I $$MCE133 D R50R2B + Q + ; +R50R2B ; Send Order Check, Notication messages and/or Execute code for Rule #50 'BIOCHEM ABNORMALITIES/CONTRAST MEDIA CHE...' Relation #2 'CONTRAST MEDIA ORDER AND NO CREAT RESULTS W/IN X D...' + ; Called from R50R2A+12. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; + Q:$D(OCXRULE("R50R2B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^9^^Procedure uses intravenous contrast media - no creatinine results within "_$$GETDATA(DFN,"130^133",154)_" days" I 1 + E S OCXCMSG="Procedure uses intravenous contrast media - no creatinine results within "_$$GETDATA(DFN,"130^133",154)_" days" + S OCXNMSG="" + ; + Q:$G(OCXOERR) + ; + ; Send Order Check Message + ; + S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG + Q + ; +R51R1A ; Verify all Event/Elements of Rule #51 'RECENT CHOLECYSTOGRAM ORDER' Relation #1 'RECENT CHOLECGRM' + ; Called from EL63+5^OCXOZ0H. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE63( -----------> Verify Event/Element: 'PATIENT HAS RECENT CHOLECYSTOGRAM' + ; + Q:$G(^OCXS(860.2,51,"INACT")) + ; + I $$MCE63 D R51R1B + Q + ; +R51R1B ; Send Order Check, Notication messages and/or Execute code for Rule #51 'RECENT CHOLECYSTOGRAM ORDER' Relation #1 'RECENT CHOLECGRM' + ; Called from R51R1A+10. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; + Q:$D(OCXRULE("R51R1B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^15^^Recent Cholecystogram: "_$$GETDATA(DFN,"63^",61)_" ["_$$GETDATA(DFN,"63^",122)_"]" I 1 + E S OCXCMSG="Recent Cholecystogram: "_$$GETDATA(DFN,"63^",61)_" ["_$$GETDATA(DFN,"63^",122)_"]" + S OCXNMSG="" + ; + Q:$G(OCXOERR) + ; + ; Send Order Check Message + ; + S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG + Q + ; +R53R1A ; Verify all Event/Elements of Rule #53 'RENAL FUNCTIONS OVER AGE 65 CHECK' Relation #1 'PHARM PAT OVER 65' + ; Called from EL64+5^OCXOZ0H. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE64( -----------> Verify Event/Element: 'PHARMACY PATIENT OVER 65' + ; + Q:$G(^OCXS(860.2,53,"INACT")) + ; + I $$MCE64 D R53R1B + Q + ; +R53R1B ; Send Order Check, Notication messages and/or Execute code for Rule #53 'RENAL FUNCTIONS OVER AGE 65 CHECK' Relation #1 'PHARM PAT OVER 65' + ; Called from R53R1A+10. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; + Q:$D(OCXRULE("R53R1B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^21^^Patient >65. Renal Results: "_$$GETDATA(DFN,"64^",64) I 1 + E S OCXCMSG="Patient >65. Renal Results: "_$$GETDATA(DFN,"64^",64) + S OCXNMSG="" + ; + Q:$G(OCXOERR) + ; + ; Send Order Check Message + ; + S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG + Q + ; +R54R1A ; Verify all Event/Elements of Rule #54 'CONCURRENT LAB ORDERS FOR ANGIOGRAM, CAT...' Relation #1 'ANGIOGRAM' + ; Called from EL65+5^OCXOZ0H. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE65( -----------> Verify Event/Element: 'SESSION ORDER FOR ANGIOGRAM' + ; + Q:$G(^OCXS(860.2,54,"INACT")) + ; + I $$MCE65 D R54R1B + Q + ; +R54R1B ; Send Order Check, Notication messages and/or Execute code for Rule #54 'CONCURRENT LAB ORDERS FOR ANGIOGRAM, CAT...' Relation #1 'ANGIOGRAM' + ; Called from R54R1A+10. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; + Q:$D(OCXRULE("R54R1B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^22^^Missing Labs for Angiogram: "_$$GETDATA(DFN,"65^",68) I 1 + E S OCXCMSG="Missing Labs for Angiogram: "_$$GETDATA(DFN,"65^",68) + S OCXNMSG="" + ; + Q:$G(OCXOERR) + ; + ; Send Order Check Message + ; + S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG + Q + ; +R55R1A ; Verify all Event/Elements of Rule #55 'ALLERGY - CONTRAST MEDIA REACTION' Relation #1 'ALLERGY' + ; Called from EL66+5^OCXOZ0H. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE66( -----------> Verify Event/Element: 'CONTRAST MEDIA ALLERGY' + ; + Q:$G(^OCXS(860.2,55,"INACT")) + ; + I $$MCE66 D R55R1B + Q + ; +R55R1B ; Send Order Check, Notication messages and/or Execute code for Rule #55 'ALLERGY - CONTRAST MEDIA REACTION' Relation #1 'ALLERGY' + ; Called from R55R1A+10. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; + Q:$D(OCXRULE("R55R1B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^4^^Patient allergic to contrast media. ("_$$GETDATA(DFN,"66^",159)_") This procedure uses: "_$$GETDATA(DFN,"66^",66) I 1 + E S OCXCMSG="Patient allergic to contrast media. ("_$$GETDATA(DFN,"66^",159)_") This procedure uses: "_$$GETDATA(DFN,"66^",66) + S OCXNMSG="" + ; + Q:$G(OCXOERR) + ; + ; Send Order Check Message + ; + S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG + Q + ; +GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data + ; + N OCXE,VAL,PC S VAL="" + F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) + Q VAL + ; +MCE130() ; Verify Event/Element: CONTRAST MEDIA ORDER + ; + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(130,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),130)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),130)) + Q 0 + ; +MCE133() ; Verify Event/Element: NO CREAT RESULTS W/IN X DAYS + ; + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(133,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),133)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),133)) + Q 0 + ; +MCE63() ; Verify Event/Element: PATIENT HAS RECENT CHOLECYSTOGRAM + ; + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(63,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),63)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),63)) + Q 0 + ; +MCE64() ; Verify Event/Element: PHARMACY PATIENT OVER 65 + ; + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(64,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),64)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),64)) + Q 0 + ; +MCE65() ; Verify Event/Element: SESSION ORDER FOR ANGIOGRAM + ; + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(65,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),65)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),65)) + Q 0 + ; +MCE66() ; Verify Event/Element: CONTRAST MEDIA ALLERGY + ; + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(66,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),66)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),66)) + Q 0 + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0W.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0W.m index a5433e32..f9d1d096 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0W.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0W.m @@ -1,266 +1,257 @@ -OCXOZ0W ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; - ; *************************************************************** - ; ** Warning: This routine is automatically generated by the ** - ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** - ; ** will be lost the next time the rule compiler executes. ** - ; *************************************************************** - ; - Q - ; -R56R1A ; Verify all Event/Elements of Rule #56 'RECENT BARIUM STUDY' Relation #1 'BARIUM' - ; Called from EL67+5^OCXOZ0H. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE67( -----------> Verify Event/Element: 'RECENT BARIUM STUDY ORDERED' - ; - Q:$G(^OCXS(860.2,56,"INACT")) - ; - I $$MCE67 D R56R1B - Q - ; -R56R1B ; Send Order Check, Notication messages and/or Execute code for Rule #56 'RECENT BARIUM STUDY' Relation #1 'BARIUM' - ; Called from R56R1A+10. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; - Q:$D(OCXRULE("R56R1B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^14^^Recent Barium study: "_$$GETDATA(DFN,"67^",70)_" ["_$$GETDATA(DFN,"67^",121)_"]" I 1 - E S OCXCMSG="Recent Barium study: "_$$GETDATA(DFN,"67^",70)_" ["_$$GETDATA(DFN,"67^",121)_"]" - S OCXNMSG="" - ; - Q:$G(OCXOERR) - ; - ; Send Order Check Message - ; - S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG - Q - ; -R57R1A ; Verify all Event/Elements of Rule #57 'CLOZAPINE' Relation #1 'CLOZAPINE AND (NO WBC W/IN 7 DAYS OR NO ANC W/IN 7...' - ; Called from EL116+5^OCXOZ0H, and EL117+5^OCXOZ0H, and EL118+5^OCXOZ0H. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE116( ----------> Verify Event/Element: 'CLOZAPINE DRUG SELECTED' - ; MCE117( ----------> Verify Event/Element: 'CLOZAPINE NO ANC W/IN 7 DAYS' - ; MCE118( ----------> Verify Event/Element: 'CLOZAPINE NO WBC W/IN 7 DAYS' - ; - Q:$G(^OCXS(860.2,57,"INACT")) - ; - I $$MCE116 D - .I $$MCE118 D R57R1B - .I $$MCE117 D R57R1B - Q - ; -R57R1B ; Send Order Check, Notication messages and/or Execute code for Rule #57 'CLOZAPINE' Relation #1 'CLOZAPINE AND (NO WBC W/IN 7 DAYS OR NO ANC W/IN 7...' - ; Called from R57R1A+13. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; - Q:$D(OCXRULE("R57R1B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^19^^Clozapine orders require a CBC/Diff within past 7 days. Please order CBC/Diff with WBC and ANC immediately. Most recent results - "_$$GETDATA(DFN,"116^117^118",130) I 1 - E S OCXCMSG="Clozapine orders require a CBC/Diff within past 7 days. Please order CBC/Diff with WBC and ANC immediately. Most recent results - "_$$GETDATA(DFN,"116^117^118",130) - S OCXNMSG="" - ; - Q:$G(OCXOERR) - ; - ; Send Order Check Message - ; - S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG - Q - ; -R57R2A ; Verify all Event/Elements of Rule #57 'CLOZAPINE' Relation #2 'CLOZAPINE AND (WBC < 3.0 OR ANC < 1.5)' - ; Called from EL116+6^OCXOZ0H, and EL114+5^OCXOZ0I, and EL119+5^OCXOZ0I. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE114( ----------> Verify Event/Element: 'CLOZAPINE ANC < 1.5' - ; MCE116( ----------> Verify Event/Element: 'CLOZAPINE DRUG SELECTED' - ; MCE119( ----------> Verify Event/Element: 'CLOZAPINE WBC < 3.0' - ; - Q:$G(^OCXS(860.2,57,"INACT")) - ; - I $$MCE116 D - .I $$MCE119 D R57R2B - .I $$MCE114 D R57R2B - Q - ; -R57R2B ; Send Order Check, Notication messages and/or Execute code for Rule #57 'CLOZAPINE' Relation #2 'CLOZAPINE AND (WBC < 3.0 OR ANC < 1.5)' - ; Called from R57R2A+13. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; - Q:$D(OCXRULE("R57R2B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^19^^WBC < 3.0 and/or ANC < 1.5 - pharmacy cannot fill clozapine order. Most recent results - "_$$GETDATA(DFN,"114^116^119",130) I 1 - E S OCXCMSG="WBC < 3.0 and/or ANC < 1.5 - pharmacy cannot fill clozapine order. Most recent results - "_$$GETDATA(DFN,"114^116^119",130) - S OCXNMSG="" - ; - Q:$G(OCXOERR) - ; - ; Send Order Check Message - ; - S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG - Q - ; -R57R3A ; Verify all Event/Elements of Rule #57 'CLOZAPINE' Relation #3 'CLOZAPINE AND 3.0 <= WBC < 3.5 AND ANC >= 1.5' - ; Called from EL116+7^OCXOZ0H, and EL115+5^OCXOZ0I, and EL120+5^OCXOZ0I. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE115( ----------> Verify Event/Element: 'CLOZAPINE ANC >= 1.5' - ; MCE116( ----------> Verify Event/Element: 'CLOZAPINE DRUG SELECTED' - ; MCE120( ----------> Verify Event/Element: 'CLOZAPINE WBC >= 3.0 & < 3.5' - ; - Q:$G(^OCXS(860.2,57,"INACT")) - ; - I $$MCE116 D - .I $$MCE120 D - ..I $$MCE115 D R57R3B - Q - ; -R57R3B ; Send Order Check, Notication messages and/or Execute code for Rule #57 'CLOZAPINE' Relation #3 'CLOZAPINE AND 3.0 <= WBC < 3.5 AND ANC >= 1.5' - ; Called from R57R3A+14. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; - Q:$D(OCXRULE("R57R3B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^19^^WBC between 3.0 and 3.5 with ANC >= 1.5 - please repeat CBC/Diff including WBC and ANC immediately and twice weekly. Most recent results - "_$$GETDATA(DFN,"115^116^120",130) I 1 - E S OCXCMSG="WBC between 3.0 and 3.5 with ANC >= 1.5 - please repeat CBC/Diff including WBC and ANC immediately and twice weekly. Most recent results - "_$$GETDATA(DFN,"115^116^120",130) - S OCXNMSG="" - ; - Q:$G(OCXOERR) - ; - ; Send Order Check Message - ; - S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG - Q - ; -R57R4A ; Verify all Event/Elements of Rule #57 'CLOZAPINE' Relation #4 'CLOZAPINE AND 1.5 <= ANC < 2.0' - ; Called from EL116+8^OCXOZ0H, and EL140+5^OCXOZ0I. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE116( ----------> Verify Event/Element: 'CLOZAPINE DRUG SELECTED' - ; MCE140( ----------> Verify Event/Element: 'CLOZAPINE ANC >= 1.5 & < 2.0' - ; - Q:$G(^OCXS(860.2,57,"INACT")) - ; - I $$MCE116 D - .I $$MCE140 D R57R4B^OCXOZ0X - Q - ; -GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data - ; - N OCXE,VAL,PC S VAL="" - F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) - Q VAL - ; -MCE114() ; Verify Event/Element: CLOZAPINE ANC < 1.5 - ; - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(114,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),114)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),114)) - Q 0 - ; -MCE115() ; Verify Event/Element: CLOZAPINE ANC >= 1.5 - ; - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(115,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),115)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),115)) - Q 0 - ; -MCE116() ; Verify Event/Element: CLOZAPINE DRUG SELECTED - ; - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(116,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),116)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),116)) - Q 0 - ; -MCE117() ; Verify Event/Element: CLOZAPINE NO ANC W/IN 7 DAYS - ; - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(117,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),117)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),117)) - Q 0 - ; -MCE118() ; Verify Event/Element: CLOZAPINE NO WBC W/IN 7 DAYS - ; - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(118,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),118)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),118)) - Q 0 - ; -MCE119() ; Verify Event/Element: CLOZAPINE WBC < 3.0 - ; - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(119,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),119)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),119)) - Q 0 - ; -MCE120() ; Verify Event/Element: CLOZAPINE WBC >= 3.0 & < 3.5 - ; - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(120,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),120)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),120)) - Q 0 - ; -MCE140() ; Verify Event/Element: CLOZAPINE ANC >= 1.5 & < 2.0 - ; - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(140,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),140)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),140)) - Q 0 - ; -MCE67() ; Verify Event/Element: RECENT BARIUM STUDY ORDERED - ; - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(67,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),67)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),67)) - Q 0 - ; +OCXOZ0W ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; + ; *************************************************************** + ; ** Warning: This routine is automatically generated by the ** + ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** + ; ** will be lost the next time the rule compiler executes. ** + ; *************************************************************** + ; + Q + ; +R56R1A ; Verify all Event/Elements of Rule #56 'RECENT BARIUM STUDY' Relation #1 'BARIUM' + ; Called from EL67+5^OCXOZ0H. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE67( -----------> Verify Event/Element: 'RECENT BARIUM STUDY ORDERED' + ; + Q:$G(^OCXS(860.2,56,"INACT")) + ; + I $$MCE67 D R56R1B + Q + ; +R56R1B ; Send Order Check, Notication messages and/or Execute code for Rule #56 'RECENT BARIUM STUDY' Relation #1 'BARIUM' + ; Called from R56R1A+10. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; + Q:$D(OCXRULE("R56R1B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^14^^Recent Barium study: "_$$GETDATA(DFN,"67^",70)_" ["_$$GETDATA(DFN,"67^",121)_"]" I 1 + E S OCXCMSG="Recent Barium study: "_$$GETDATA(DFN,"67^",70)_" ["_$$GETDATA(DFN,"67^",121)_"]" + S OCXNMSG="" + ; + Q:$G(OCXOERR) + ; + ; Send Order Check Message + ; + S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG + Q + ; +R57R1A ; Verify all Event/Elements of Rule #57 'CLOZAPINE' Relation #1 'CLOZAPINE AND (WBC < 3.0 OR ANC < 1.5)' + ; Called from EL114+5^OCXOZ0H, and EL116+5^OCXOZ0H, and EL119+5^OCXOZ0H. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE114( ----------> Verify Event/Element: 'CLOZAPINE ANC < 1.5' + ; MCE116( ----------> Verify Event/Element: 'CLOZAPINE DRUG SELECTED' + ; MCE119( ----------> Verify Event/Element: 'CLOZAPINE WBC < 3.0' + ; + Q:$G(^OCXS(860.2,57,"INACT")) + ; + I $$MCE116 D + .I $$MCE119 D R57R1B + .I $$MCE114 D R57R1B + Q + ; +R57R1B ; Send Order Check, Notication messages and/or Execute code for Rule #57 'CLOZAPINE' Relation #1 'CLOZAPINE AND (WBC < 3.0 OR ANC < 1.5)' + ; Called from R57R1A+13. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; + Q:$D(OCXRULE("R57R1B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^19^^WBC < 3.0 and/or ANC < 1.5 - pharmacy cannot fill clozapine order. Most recent results - "_$$GETDATA(DFN,"114^116^119",130) I 1 + E S OCXCMSG="WBC < 3.0 and/or ANC < 1.5 - pharmacy cannot fill clozapine order. Most recent results - "_$$GETDATA(DFN,"114^116^119",130) + S OCXNMSG="" + ; + Q:$G(OCXOERR) + ; + ; Send Order Check Message + ; + S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG + Q + ; +R57R2A ; Verify all Event/Elements of Rule #57 'CLOZAPINE' Relation #2 'CLOZAPINE AND NO WBC W/IN 7 DAYS' + ; Called from EL116+6^OCXOZ0H, and EL118+5^OCXOZ0H. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE116( ----------> Verify Event/Element: 'CLOZAPINE DRUG SELECTED' + ; MCE118( ----------> Verify Event/Element: 'CLOZAPINE NO WBC W/IN 7 DAYS' + ; + Q:$G(^OCXS(860.2,57,"INACT")) + ; + I $$MCE116 D + .I $$MCE118 D R57R2B + Q + ; +R57R2B ; Send Order Check, Notication messages and/or Execute code for Rule #57 'CLOZAPINE' Relation #2 'CLOZAPINE AND NO WBC W/IN 7 DAYS' + ; Called from R57R2A+12. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; + Q:$D(OCXRULE("R57R2B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^19^^Clozapine orders require a CBC/Diff within past 7 days. Please order CBC/Diff with WBC and ANC immediately. Most recent results - "_$$GETDATA(DFN,"116^118",130) I 1 + E S OCXCMSG="Clozapine orders require a CBC/Diff within past 7 days. Please order CBC/Diff with WBC and ANC immediately. Most recent results - "_$$GETDATA(DFN,"116^118",130) + S OCXNMSG="" + ; + Q:$G(OCXOERR) + ; + ; Send Order Check Message + ; + S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG + Q + ; +R57R3A ; Verify all Event/Elements of Rule #57 'CLOZAPINE' Relation #3 'CLOZAPINE AND 3.0 <= WBC < 3.5 AND NO ANC W/IN 7 D...' + ; Called from EL116+7^OCXOZ0H, and EL117+5^OCXOZ0H, and EL120+5^OCXOZ0I. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE116( ----------> Verify Event/Element: 'CLOZAPINE DRUG SELECTED' + ; MCE117( ----------> Verify Event/Element: 'CLOZAPINE NO ANC W/IN 7 DAYS' + ; MCE120( ----------> Verify Event/Element: 'CLOZAPINE WBC >= 3.0 & < 3.5' + ; + Q:$G(^OCXS(860.2,57,"INACT")) + ; + I $$MCE116 D + .I $$MCE120 D + ..I $$MCE117 D R57R3B + Q + ; +R57R3B ; Send Order Check, Notication messages and/or Execute code for Rule #57 'CLOZAPINE' Relation #3 'CLOZAPINE AND 3.0 <= WBC < 3.5 AND NO ANC W/IN 7 D...' + ; Called from R57R3A+14. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; + Q:$D(OCXRULE("R57R3B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^19^^"_$$GETDATA(DFN,"116^117^120",145)_" Most recent results - "_$$GETDATA(DFN,"116^117^120",130) I 1 + E S OCXCMSG=$$GETDATA(DFN,"116^117^120",145)_" Most recent results - "_$$GETDATA(DFN,"116^117^120",130) + S OCXNMSG="" + ; + Q:$G(OCXOERR) + ; + ; Send Order Check Message + ; + S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG + Q + ; +R57R4A ; Verify all Event/Elements of Rule #57 'CLOZAPINE' Relation #4 'CLOZAPINE AND 3.0 <= WBC < 3.5 AND ANC >= 1.5' + ; Called from EL116+8^OCXOZ0H, and EL120+6^OCXOZ0I, and EL115+5^OCXOZ0I. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE115( ----------> Verify Event/Element: 'CLOZAPINE ANC >= 1.5' + ; MCE116( ----------> Verify Event/Element: 'CLOZAPINE DRUG SELECTED' + ; MCE120( ----------> Verify Event/Element: 'CLOZAPINE WBC >= 3.0 & < 3.5' + ; + Q:$G(^OCXS(860.2,57,"INACT")) + ; + I $$MCE116 D + .I $$MCE120 D + ..I $$MCE115 D R57R4B^OCXOZ0X + Q + ; +GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data + ; + N OCXE,VAL,PC S VAL="" + F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) + Q VAL + ; +MCE114() ; Verify Event/Element: CLOZAPINE ANC < 1.5 + ; + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(114,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),114)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),114)) + Q 0 + ; +MCE115() ; Verify Event/Element: CLOZAPINE ANC >= 1.5 + ; + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(115,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),115)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),115)) + Q 0 + ; +MCE116() ; Verify Event/Element: CLOZAPINE DRUG SELECTED + ; + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(116,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),116)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),116)) + Q 0 + ; +MCE117() ; Verify Event/Element: CLOZAPINE NO ANC W/IN 7 DAYS + ; + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(117,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),117)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),117)) + Q 0 + ; +MCE118() ; Verify Event/Element: CLOZAPINE NO WBC W/IN 7 DAYS + ; + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(118,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),118)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),118)) + Q 0 + ; +MCE119() ; Verify Event/Element: CLOZAPINE WBC < 3.0 + ; + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(119,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),119)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),119)) + Q 0 + ; +MCE120() ; Verify Event/Element: CLOZAPINE WBC >= 3.0 & < 3.5 + ; + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(120,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),120)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),120)) + Q 0 + ; +MCE67() ; Verify Event/Element: RECENT BARIUM STUDY ORDERED + ; + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(67,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),67)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),67)) + Q 0 + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0X.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0X.m index a03f0efa..da6464a8 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0X.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0X.m @@ -1,128 +1,183 @@ -OCXOZ0X ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; - ; *************************************************************** - ; ** Warning: This routine is automatically generated by the ** - ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** - ; ** will be lost the next time the rule compiler executes. ** - ; *************************************************************** - ; - Q - ; -R57R4B ; Send Order Check, Notication messages and/or Execute code for Rule #57 'CLOZAPINE' Relation #4 'CLOZAPINE AND 1.5 <= ANC < 2.0' - ; Called from R57R4A+12^OCXOZ0W. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; - Q:$D(OCXRULE("R57R4B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^19^^ANC between 1.5 and 2.0 - please repeat CBC/Diff including WBC and ANC immediately and twice weekly. Most recent results - "_$$GETDATA(DFN,"116^140",130) I 1 - E S OCXCMSG="ANC between 1.5 and 2.0 - please repeat CBC/Diff including WBC and ANC immediately and twice weekly. Most recent results - "_$$GETDATA(DFN,"116^140",130) - S OCXNMSG="" - ; - Q:$G(OCXOERR) - ; - ; Send Order Check Message - ; - S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG - Q - ; -R59R1A ; Verify all Event/Elements of Rule #59 'AMINOGLYCOSIDE ORDER' Relation #1 'AGS ORDER' - ; Called from EL71+5^OCXOZ0I. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE71( -----------> Verify Event/Element: 'AMINOGLYCOSIDE ORDER SESSION' - ; - Q:$G(^OCXS(860.2,59,"INACT")) - ; - I $$MCE71 D R59R1B - Q - ; -R59R1B ; Send Order Check, Notication messages and/or Execute code for Rule #59 'AMINOGLYCOSIDE ORDER' Relation #1 'AGS ORDER' - ; Called from R59R1A+10. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; - Q:$D(OCXRULE("R59R1B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^20^^Aminoglycoside - est. CrCl: "_$$GETDATA(DFN,"71^",76)_" ("_$$GETDATA(DFN,"71^",64)_") [Est. CrCl based on modified Cockcroft-Gault equation using Adjusted Body Weight (if ht > 60 in)]" I 1 - E S OCXCMSG="Aminoglycoside - est. CrCl: "_$$GETDATA(DFN,"71^",76)_" ("_$$GETDATA(DFN,"71^",64)_") [Est. CrCl based on modified Cockcroft-Gault equation using Adjusted Body Weight (if ht > 60 in)]" - S OCXNMSG="" - ; - Q:$G(OCXOERR) - ; - ; Send Order Check Message - ; - S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG - Q - ; -R60R1A ; Verify all Event/Elements of Rule #60 'CT OR MRI PHYSICAL LIMIT CHECK' Relation #1 'TOO BIG' - ; Called from EL72+5^OCXOZ0I. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE72( -----------> Verify Event/Element: 'PATIENT OVER CT OR MRI DEVICE LIMITATIONS' - ; - Q:$G(^OCXS(860.2,60,"INACT")) - ; - I $$MCE72 D R60R1B - Q - ; -R60R1B ; Send Order Check, Notication messages and/or Execute code for Rule #60 'CT OR MRI PHYSICAL LIMIT CHECK' Relation #1 'TOO BIG' - ; Called from R60R1A+10. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; - Q:$D(OCXRULE("R60R1B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^8^^Patient may be "_$$GETDATA(DFN,"72^",79)_" for the "_$$GETDATA(DFN,"72^",80)_"." I 1 - E S OCXCMSG="Patient may be "_$$GETDATA(DFN,"72^",79)_" for the "_$$GETDATA(DFN,"72^",80)_"." - S OCXNMSG="" - ; - Q:$G(OCXOERR) - ; - ; Send Order Check Message - ; - S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG - Q - ; -GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data - ; - N OCXE,VAL,PC S VAL="" - F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) - Q VAL - ; -MCE71() ; Verify Event/Element: AMINOGLYCOSIDE ORDER SESSION - ; - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(71,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),71)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),71)) - Q 0 - ; -MCE72() ; Verify Event/Element: PATIENT OVER CT OR MRI DEVICE LIMITATIONS - ; - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(72,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),72)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),72)) - Q 0 - ; +OCXOZ0X ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; + ; *************************************************************** + ; ** Warning: This routine is automatically generated by the ** + ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** + ; ** will be lost the next time the rule compiler executes. ** + ; *************************************************************** + ; + Q + ; +R57R4B ; Send Order Check, Notication messages and/or Execute code for Rule #57 'CLOZAPINE' Relation #4 'CLOZAPINE AND 3.0 <= WBC < 3.5 AND ANC >= 1.5' + ; Called from R57R4A+14^OCXOZ0W. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; + Q:$D(OCXRULE("R57R4B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^19^^WBC between 3.0 and 3.5 with ANC >= 1.5 - please repeat CBC/Diff including WBC and ANC immediately and twice weekly. Most recent results - "_$$GETDATA(DFN,"115^116^120",130) I 1 + E S OCXCMSG="WBC between 3.0 and 3.5 with ANC >= 1.5 - please repeat CBC/Diff including WBC and ANC immediately and twice weekly. Most recent results - "_$$GETDATA(DFN,"115^116^120",130) + S OCXNMSG="" + ; + Q:$G(OCXOERR) + ; + ; Send Order Check Message + ; + S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG + Q + ; +R57R5A ; Verify all Event/Elements of Rule #57 'CLOZAPINE' Relation #5 'CLOZAPINE AND WBC >= 3.5' + ; Called from EL116+9^OCXOZ0H, and EL121+5^OCXOZ0I. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE116( ----------> Verify Event/Element: 'CLOZAPINE DRUG SELECTED' + ; MCE121( ----------> Verify Event/Element: 'CLOZAPINE WBC >= 3.5' + ; + Q:$G(^OCXS(860.2,57,"INACT")) + ; + I $$MCE116 D + .I $$MCE121 D R57R5B + Q + ; +R57R5B ; Send Order Check, Notication messages and/or Execute code for Rule #57 'CLOZAPINE' Relation #5 'CLOZAPINE AND WBC >= 3.5' + ; Called from R57R5A+12. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; + Q:$D(OCXRULE("R57R5B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^19^^Clozapine - most recent results - "_$$GETDATA(DFN,"116^121",130) I 1 + E S OCXCMSG="Clozapine - most recent results - "_$$GETDATA(DFN,"116^121",130) + S OCXNMSG="" + ; + Q:$G(OCXOERR) + ; + ; Send Order Check Message + ; + S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG + Q + ; +R59R1A ; Verify all Event/Elements of Rule #59 'AMINOGLYCOSIDE ORDER' Relation #1 'AGS ORDER' + ; Called from EL71+5^OCXOZ0I. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE71( -----------> Verify Event/Element: 'AMINOGLYCOSIDE ORDER SESSION' + ; + Q:$G(^OCXS(860.2,59,"INACT")) + ; + I $$MCE71 D R59R1B + Q + ; +R59R1B ; Send Order Check, Notication messages and/or Execute code for Rule #59 'AMINOGLYCOSIDE ORDER' Relation #1 'AGS ORDER' + ; Called from R59R1A+10. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; + Q:$D(OCXRULE("R59R1B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^20^^Aminoglycoside - est. CrCl: "_$$GETDATA(DFN,"71^",76)_" ("_$$GETDATA(DFN,"71^",64)_") [Est. CrCl based on modified Cockcroft-Gault equation using Adjusted Body Weight (if ht > 60 in)]" I 1 + E S OCXCMSG="Aminoglycoside - est. CrCl: "_$$GETDATA(DFN,"71^",76)_" ("_$$GETDATA(DFN,"71^",64)_") [Est. CrCl based on modified Cockcroft-Gault equation using Adjusted Body Weight (if ht > 60 in)]" + S OCXNMSG="" + ; + Q:$G(OCXOERR) + ; + ; Send Order Check Message + ; + S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG + Q + ; +R60R1A ; Verify all Event/Elements of Rule #60 'CT OR MRI PHYSICAL LIMIT CHECK' Relation #1 'TOO BIG' + ; Called from EL72+5^OCXOZ0I. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE72( -----------> Verify Event/Element: 'PATIENT OVER CT OR MRI DEVICE LIMITATIONS' + ; + Q:$G(^OCXS(860.2,60,"INACT")) + ; + I $$MCE72 D R60R1B + Q + ; +R60R1B ; Send Order Check, Notication messages and/or Execute code for Rule #60 'CT OR MRI PHYSICAL LIMIT CHECK' Relation #1 'TOO BIG' + ; Called from R60R1A+10. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; + Q:$D(OCXRULE("R60R1B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^8^^Patient may be "_$$GETDATA(DFN,"72^",79)_" for the "_$$GETDATA(DFN,"72^",80)_"." I 1 + E S OCXCMSG="Patient may be "_$$GETDATA(DFN,"72^",79)_" for the "_$$GETDATA(DFN,"72^",80)_"." + S OCXNMSG="" + ; + Q:$G(OCXOERR) + ; + ; Send Order Check Message + ; + S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG + Q + ; +GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data + ; + N OCXE,VAL,PC S VAL="" + F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) + Q VAL + ; +MCE116() ; Verify Event/Element: CLOZAPINE DRUG SELECTED + ; + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(116,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),116)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),116)) + Q 0 + ; +MCE121() ; Verify Event/Element: CLOZAPINE WBC >= 3.5 + ; + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(121,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),121)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),121)) + Q 0 + ; +MCE71() ; Verify Event/Element: AMINOGLYCOSIDE ORDER SESSION + ; + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(71,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),71)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),71)) + Q 0 + ; +MCE72() ; Verify Event/Element: PATIENT OVER CT OR MRI DEVICE LIMITATIONS + ; + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(72,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),72)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),72)) + Q 0 + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0Y.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0Y.m index 5f233a2e..10ff05c4 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0Y.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0Y.m @@ -1,200 +1,200 @@ -OCXOZ0Y ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; - ; *************************************************************** - ; ** Warning: This routine is automatically generated by the ** - ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** - ; ** will be lost the next time the rule compiler executes. ** - ; *************************************************************** - ; - Q - ; -R61R1A ; Verify all Event/Elements of Rule #61 'CREATININE CLEARANCE ESTIMATION' Relation #1 'IF CREAT CLEAR AND ( CREATININE CLEARANCE DATE OR ...' - ; Called from EL73+5^OCXOZ0I, and EL96+5^OCXOZ0I, and EL97+5^OCXOZ0I. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE73( -----------> Verify Event/Element: 'CREATININE CLEARANCE ESTIMATE' - ; MCE96( -----------> Verify Event/Element: 'CREATININE CLEARANCE DATE/TIME' - ; MCE97( -----------> Verify Event/Element: 'RENAL RESULTS' - ; - Q:$G(^OCXS(860.2,61,"INACT")) - ; - I $$MCE73 D - .I $$MCE96 D R61R1B - .I $$MCE97 D R61R1B - Q - ; -R61R1B ; Send Order Check, Notication messages and/or Execute code for Rule #61 'CREATININE CLEARANCE ESTIMATION' Relation #1 'IF CREAT CLEAR AND ( CREATININE CLEARANCE DATE OR ...' - ; Called from R61R1A+13. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; - Q:$D(OCXRULE("R61R1B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^1^^Est. CrCl: "_$$GETDATA(DFN,"73^96^97",76)_" ("_$$GETDATA(DFN,"73^96^97",64)_") [Est. CrCl based on modified Cockcroft-Gault equation using Adjusted Body Weight (if ht > 60 in.)]" I 1 - E S OCXCMSG="Est. CrCl: "_$$GETDATA(DFN,"73^96^97",76)_" ("_$$GETDATA(DFN,"73^96^97",64)_") [Est. CrCl based on modified Cockcroft-Gault equation using Adjusted Body Weight (if ht > 60 in.)]" - S OCXNMSG="" - ; - Q:$G(OCXOERR) - ; - ; Send Order Check Message - ; - S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG - Q - ; -CRCL(DFN) ; Compiler Function: CREATININE CLEARANCE (ESTIMATED/CALCULATED) - ; - N HT,AGE,SEX,SCR,SCRD,CRCL,LRWKLD,RSLT,ORW,ORH,PSCR - N HTGT60,ABW,IBW,BWRATIO,BWDIFF,LOWBW,ADJBW - S RSLT="0^" - S PSCR="^^^^^^0" - D VITAL^ORQQVI("WEIGHT","WT",DFN,.ORW,0,"",$$NOW^XLFDT) - Q:'$D(ORW) RSLT - S ABW=$P(ORW(1),U,3) Q:+$G(ABW)<1 RSLT - S ABW=ABW/2.2 ;ABW (actual body weight) in kg - D VITAL^ORQQVI("HEIGHT","HT",DFN,.ORH,0,"",$$NOW^XLFDT) - Q:'$D(ORH) RSLT - S HT=$P(ORH(1),U,3) Q:+$G(HT)<1 RSLT - S AGE=$$AGE^ORQPTQ4(DFN) Q:'AGE RSLT - S SEX=$P($$SEX^ORQPTQ4(DFN),U,1) Q:'$L(SEX) RSLT - S OCXTL="" Q:'$$TERMLKUP^ORB31(.OCXTL,"SERUM CREATININE") RSLT - S OCXTLS="" Q:'$$TERMLKUP^ORB31(.OCXTLS,"SERUM SPECIMEN") RSLT - S SCR="",OCXT=0 F S OCXT=$O(OCXTL(OCXT)) Q:'OCXT D - .S OCXTS=0 F S OCXTS=$O(OCXTLS(OCXTS)) Q:'OCXTS D - ..S SCR=$$LOCL^ORQQLR1(DFN,$P(OCXTL(OCXT),U),$P(OCXTLS(OCXTS),U)) - ..I $P(SCR,U,7)>$P(PSCR,U,7) S PSCR=SCR - S SCR=PSCR,SCRV=$P(SCR,U,3) Q:+$G(SCRV)<.01 RSLT - S SCRD=$P(SCR,U,7) Q:'$L(SCRD) RSLT - ; - S HTGT60=$S(HT>60:(HT-60)*2.3,1:0) ;if ht > 60 inches - I HTGT60>0 D - .S IBW=$S(SEX="M":50+HTGT60,1:45.5+HTGT60) ;Ideal Body Weight - .S BWRATIO=(ABW/IBW) ;body weight ratio - .S BWDIFF=$S(ABW>IBW:ABW-IBW,1:0) - .S LOWBW=$S(IBW1.3,(BWDIFF>0) S ADJBW=((0.3*BWDIFF)+IBW) - .E S ADJBW=LOWBW - I +$G(ADJBW)<1 D - .S ADJBW=ABW - S CRCL=(((140-AGE)*ADJBW)/(SCRV*72)) - ; - S:SEX="M" RSLT=SCRD_U_$J(CRCL,1,1) - S:SEX="F" RSLT=SCRD_U_$J((CRCL*.85),1,1) - Q RSLT - ; -DT2INT(OCXDT) ; This Local Extrinsic Function converts a date into an integer - ; By taking the Years, Months, Days, Hours and Minutes converting - ; Them into Seconds and then adding them all together into one big integer - ; - Q:'$L($G(OCXDT)) "" - N OCXDIFF,OCXVAL S (OCXDIFF,OCXVAL)=0 - ; - I $L(OCXDT),'OCXDT,(OCXDT[" at ") D ; EXTERNAL EXPERT SYSTEM FORMAT 1 TO EXTERNAL FORMAT - .N OCXHR,OCXMIN,OCXTIME - .S OCXTIME=$P($P(OCXDT," at ",2),".",1),OCXHR=$P(OCXTIME,":",1),OCXMIN=$P(OCXTIME,":",2) - .S:(OCXDT["Midnight") OCXHR=00 - .S:(OCXDT["PM") OCXHR=OCXHR+12 - .S OCXDT=$P(OCXDT," at ")_"@"_$E(OCXHR+100,2,3)_$E(OCXMIN+100,2,3) - ; - I $L(OCXDT),(OCXDT?1.2N1"/"1.2N.1" ".2N.1":".2N) D ; EXTERNAL EXPERT SYSTEM FORMAT 2 TO EXTERNAL FORMAT - .N OCXMON - .S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,$P(OCXDT,"/",1)) - .I $L($P(OCXDT," ",2)) S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_"@"_$TR($P(OCXDT," ",2),":","") - .E S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2) - ; - I $L(OCXDT),(OCXDT?1.2N1"/"1.2N1"/"1.2N.1" ".2N.1":".2N) D ; EXTERNAL EXPERT SYSTEM FORMAT 3 TO EXTERNAL FORMAT - .N OCXMON - .S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,$P(OCXDT,"/",1)) - .I $L($P(OCXDT," ",2)) S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_","_$P($P(OCXDT," ",1),"/",3)_"@"_$TR($P(OCXDT," ",2),":","") - .E S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_", "_$P($P(OCXDT," ",1),"/",3) - ; - I $L(OCXDT),'OCXDT D ; EXTERNAL FORMAT TO INTERNAL FILEMAN FORMAT - .I (OCXDT["@0000") S OCXDT=$P(OCXDT,"@",1),OCXDIFF=1 - .N %DT,X,Y S X=OCXDT,%DT="" S:(OCXDT["@")!(OCXDT="N") %DT="T" D ^%DT S OCXDT=+Y - ; - I ($L(OCXDT\1)>7) S OCXDT=$$HL7TFM^XLFDT(OCXDT) ; HL7 FORMAT TO INTERNAL FILEMAN FORMAT - ; - I ($L(OCXDT\1)=7) S OCXDT=$$FMTH^XLFDT(+OCXDT) ; INTERNAL FILEMAN FORMAT TO $H FORMAT - ; - I (OCXDT?5N1","1.5N) S OCXVAL=(OCXDT*86400)+$P(OCXDT,",",2) ; $H FORMAT TO EXPERT SYSTEM INTERNAL FORMAT - ; - Q OCXVAL - ; -FLAB(DFN,OCXLIST,OCXSPEC) ; Compiler Function: FORMATTED LAB RESULTS - ; - Q:'$G(DFN) "" - Q:'$L($G(OCXLIST)) "" - N OCXLAB,OCXOUT,OCXPC,OCXSL,SPEC S OCXOUT="",SPEC="" - I $L($G(OCXSPEC)) S OCXSL=$$TERMLKUP(OCXSPEC,.OCXSL) - F OCXPC=1:1:$L(OCXLIST,U) S OCXLAB=$P(OCXLIST,U,OCXPC) I $L(OCXLAB) D - .N OCXX,OCXY,X,Y,DIC,TEST,SPEC,OCXTL,OCXA,OCXR - .S OCXTL="" Q:'$$TERMLKUP(OCXLAB,.OCXTL) - .S OCXX="",TEST=0 F S TEST=$O(OCXTL(TEST)) Q:'TEST D - ..I $L($G(OCXSL)) D - ...S SPEC=0 F S SPEC=$O(OCXSL(SPEC)) Q:'SPEC D - ....S OCXX=$$LOCL^ORQQLR1(DFN,TEST,SPEC) I $L(OCXX) D - .....S OCXA($P(OCXX,U,7))=OCXX - ..I '$L($G(OCXSL)) S OCXX=$$LOCL^ORQQLR1(DFN,TEST,"") - ..Q:'$L(OCXX) - .I $D(OCXA) S OCXR="",OCXR=$O(OCXA(OCXR),-1),OCXX=OCXA(OCXR) - .I $L(OCXX) D - ..S OCXY=$P(OCXX,U,2)_": "_$P(OCXX,U,3)_" "_$P(OCXX,U,4) - ..S OCXY=OCXY_" "_$S($L($P(OCXX,U,5)):"["_$P(OCXX,U,5)_"]",1:"") - ..I $L($P(OCXX,U,7)) S OCXY=OCXY_" "_$$FMTE^XLFDT($P(OCXX,U,7),"2P") - .S:$L(OCXOUT) OCXOUT=OCXOUT_" " S OCXOUT=OCXOUT_$G(OCXY) - Q:'$L(OCXOUT) "" Q OCXOUT - ; -GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data - ; - N OCXE,VAL,PC S VAL="" - F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) - Q VAL - ; -MCE73() ; Verify Event/Element: CREATININE CLEARANCE ESTIMATE - ; - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(73,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),73)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),73)) - Q 0 - ; -MCE96() ; Verify Event/Element: CREATININE CLEARANCE DATE/TIME - ; - ; OCXDF(76) -> CREATININE CLEARANCE (ESTIM) VALUE data field - ; OCXDF(64) -> FORMATTED RENAL LAB RESULTS data field - ; OCXDF(77) -> CREATININE CLEARANCE (ESTIM) DATE data field - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(96,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),96)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),96)) - S OCXRES(96)=0,OCXDF(77)=$$DT2INT($P($$CRCL(OCXDF(37)),"^",1)) I $L(OCXDF(77)) S OCXRES(96,77)=OCXDF(77) I (OCXDF(77)>$$DT2INT(0)) - E Q 0 - S OCXDF(64)=$$FLAB(OCXDF(37),"SERUM CREATININE^SERUM UREA NITROGEN","SERUM SPECIMEN"),OCXDF(76)=$P($$CRCL(OCXDF(37)),"^",2),OCXRES(96)=11 M ^TMP("OCXCHK",$J,OCXDF(37),96)=OCXRES(96) - Q +OCXRES(96) - ; -MCE97() ; Verify Event/Element: RENAL RESULTS - ; - ; OCXDF(76) -> CREATININE CLEARANCE (ESTIM) VALUE data field - ; OCXDF(64) -> FORMATTED RENAL LAB RESULTS data field - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(97,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),97)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),97)) - S OCXRES(97)=0,OCXDF(64)=$$FLAB(OCXDF(37),"SERUM CREATININE^SERUM UREA NITROGEN","SERUM SPECIMEN") I '(OCXDF(64)="") - E Q 0 - S OCXDF(76)=$P($$CRCL(OCXDF(37)),"^",2),OCXRES(97)=11 M ^TMP("OCXCHK",$J,OCXDF(37),97)=OCXRES(97) - Q +OCXRES(97) - ; -TERMLKUP(OCXTERM,OCXLIST) ; - Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST) - ; +OCXOZ0Y ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; + ; *************************************************************** + ; ** Warning: This routine is automatically generated by the ** + ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** + ; ** will be lost the next time the rule compiler executes. ** + ; *************************************************************** + ; + Q + ; +R61R1A ; Verify all Event/Elements of Rule #61 'CREATININE CLEARANCE ESTIMATION' Relation #1 'IF CREAT CLEAR AND ( CREATININE CLEARANCE DATE OR ...' + ; Called from EL73+5^OCXOZ0I, and EL96+5^OCXOZ0I, and EL97+5^OCXOZ0I. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE73( -----------> Verify Event/Element: 'CREATININE CLEARANCE ESTIMATE' + ; MCE96( -----------> Verify Event/Element: 'CREATININE CLEARANCE DATE/TIME' + ; MCE97( -----------> Verify Event/Element: 'RENAL RESULTS' + ; + Q:$G(^OCXS(860.2,61,"INACT")) + ; + I $$MCE73 D + .I $$MCE96 D R61R1B + .I $$MCE97 D R61R1B + Q + ; +R61R1B ; Send Order Check, Notication messages and/or Execute code for Rule #61 'CREATININE CLEARANCE ESTIMATION' Relation #1 'IF CREAT CLEAR AND ( CREATININE CLEARANCE DATE OR ...' + ; Called from R61R1A+13. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; + Q:$D(OCXRULE("R61R1B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^1^^Est. CrCl: "_$$GETDATA(DFN,"73^96^97",76)_" ("_$$GETDATA(DFN,"73^96^97",64)_") [Est. CrCl based on modified Cockcroft-Gault equation using Adjusted Body Weight (if ht > 60 in.)]" I 1 + E S OCXCMSG="Est. CrCl: "_$$GETDATA(DFN,"73^96^97",76)_" ("_$$GETDATA(DFN,"73^96^97",64)_") [Est. CrCl based on modified Cockcroft-Gault equation using Adjusted Body Weight (if ht > 60 in.)]" + S OCXNMSG="" + ; + Q:$G(OCXOERR) + ; + ; Send Order Check Message + ; + S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG + Q + ; +CRCL(DFN) ; Compiler Function: CREATININE CLEARANCE (ESTIMATED/CALCULATED) + ; + N HT,AGE,SEX,SCR,SCRD,CRCL,LRWKLD,RSLT,ORW,ORH,PSCR + N HTGT60,ABW,IBW,BWRATIO,BWDIFF,LOWBW,ADJBW + S RSLT="0^" + S PSCR="^^^^^^0" + D VITAL^ORQQVI("WEIGHT","WT",DFN,.ORW,0,"",$$NOW^XLFDT) + Q:'$D(ORW) RSLT + S ABW=$P(ORW(1),U,3) Q:+$G(ABW)<1 RSLT + S ABW=ABW/2.2 ;ABW (actual body weight) in kg + D VITAL^ORQQVI("HEIGHT","HT",DFN,.ORH,0,"",$$NOW^XLFDT) + Q:'$D(ORH) RSLT + S HT=$P(ORH(1),U,3) Q:+$G(HT)<1 RSLT + S AGE=$$AGE^ORQPTQ4(DFN) Q:'AGE RSLT + S SEX=$P($$SEX^ORQPTQ4(DFN),U,1) Q:'$L(SEX) RSLT + S OCXTL="" Q:'$$TERMLKUP^ORB31(.OCXTL,"SERUM CREATININE") RSLT + S OCXTLS="" Q:'$$TERMLKUP^ORB31(.OCXTLS,"SERUM SPECIMEN") RSLT + S SCR="",OCXT=0 F S OCXT=$O(OCXTL(OCXT)) Q:'OCXT D + .S OCXTS=0 F S OCXTS=$O(OCXTLS(OCXTS)) Q:'OCXTS D + ..S SCR=$$LOCL^ORQQLR1(DFN,$P(OCXTL(OCXT),U),$P(OCXTLS(OCXTS),U)) + ..I $P(SCR,U,7)>$P(PSCR,U,7) S PSCR=SCR + S SCR=PSCR,SCRV=$P(SCR,U,3) Q:+$G(SCRV)<.01 RSLT + S SCRD=$P(SCR,U,7) Q:'$L(SCRD) RSLT + ; + S HTGT60=$S(HT>60:(HT-60)*2.3,1:0) ;if ht > 60 inches + I HTGT60>0 D + .S IBW=$S(SEX="M":50+HTGT60,1:45.5+HTGT60) ;Ideal Body Weight + .S BWRATIO=(ABW/IBW) ;body weight ratio + .S BWDIFF=$S(ABW>IBW:ABW-IBW,1:0) + .S LOWBW=$S(IBW1.3,(BWDIFF>0) S ADJBW=((0.3*BWDIFF)+IBW) + .E S ADJBW=LOWBW + I +$G(ADJBW)<1 D + .S ADJBW=ABW + S CRCL=(((140-AGE)*ADJBW)/(SCRV*72)) + ; + S:SEX="M" RSLT=SCRD_U_$J(CRCL,1,1) + S:SEX="F" RSLT=SCRD_U_$J((CRCL*.85),1,1) + Q RSLT + ; +DT2INT(OCXDT) ; This Local Extrinsic Function converts a date into an integer + ; By taking the Years, Months, Days, Hours and Minutes converting + ; Them into Seconds and then adding them all together into one big integer + ; + Q:'$L($G(OCXDT)) "" + N OCXDIFF,OCXVAL S (OCXDIFF,OCXVAL)=0 + ; + I $L(OCXDT),'OCXDT,(OCXDT[" at ") D ; EXTERNAL EXPERT SYSTEM FORMAT 1 TO EXTERNAL FORMAT + .N OCXHR,OCXMIN,OCXTIME + .S OCXTIME=$P($P(OCXDT," at ",2),".",1),OCXHR=$P(OCXTIME,":",1),OCXMIN=$P(OCXTIME,":",2) + .S:(OCXDT["Midnight") OCXHR=00 + .S:(OCXDT["PM") OCXHR=OCXHR+12 + .S OCXDT=$P(OCXDT," at ")_"@"_$E(OCXHR+100,2,3)_$E(OCXMIN+100,2,3) + ; + I $L(OCXDT),(OCXDT?1.2N1"/"1.2N.1" ".2N.1":".2N) D ; EXTERNAL EXPERT SYSTEM FORMAT 2 TO EXTERNAL FORMAT + .N OCXMON + .S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,$P(OCXDT,"/",1)) + .I $L($P(OCXDT," ",2)) S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_"@"_$TR($P(OCXDT," ",2),":","") + .E S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2) + ; + I $L(OCXDT),(OCXDT?1.2N1"/"1.2N1"/"1.2N.1" ".2N.1":".2N) D ; EXTERNAL EXPERT SYSTEM FORMAT 3 TO EXTERNAL FORMAT + .N OCXMON + .S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,$P(OCXDT,"/",1)) + .I $L($P(OCXDT," ",2)) S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_","_$P($P(OCXDT," ",1),"/",3)_"@"_$TR($P(OCXDT," ",2),":","") + .E S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_", "_$P($P(OCXDT," ",1),"/",3) + ; + I $L(OCXDT),'OCXDT D ; EXTERNAL FORMAT TO INTERNAL FILEMAN FORMAT + .I (OCXDT["@0000") S OCXDT=$P(OCXDT,"@",1),OCXDIFF=1 + .N %DT,X,Y S X=OCXDT,%DT="" S:(OCXDT["@")!(OCXDT="N") %DT="T" D ^%DT S OCXDT=+Y + ; + I ($L(OCXDT\1)>7) S OCXDT=$$HL7TFM^XLFDT(OCXDT) ; HL7 FORMAT TO INTERNAL FILEMAN FORMAT + ; + I ($L(OCXDT\1)=7) S OCXDT=$$FMTH^XLFDT(+OCXDT) ; INTERNAL FILEMAN FORMAT TO $H FORMAT + ; + I (OCXDT?5N1","1.5N) S OCXVAL=(OCXDT*86400)+$P(OCXDT,",",2) ; $H FORMAT TO EXPERT SYSTEM INTERNAL FORMAT + ; + Q OCXVAL + ; +FLAB(DFN,OCXLIST,OCXSPEC) ; Compiler Function: FORMATTED LAB RESULTS + ; + Q:'$G(DFN) "" + Q:'$L($G(OCXLIST)) "" + N OCXLAB,OCXOUT,OCXPC,OCXSL,SPEC S OCXOUT="",SPEC="" + I $L($G(OCXSPEC)) S OCXSL=$$TERMLKUP(OCXSPEC,.OCXSL) + F OCXPC=1:1:$L(OCXLIST,U) S OCXLAB=$P(OCXLIST,U,OCXPC) I $L(OCXLAB) D + .N OCXX,OCXY,X,Y,DIC,TEST,SPEC,OCXTL,OCXA,OCXR + .S OCXTL="" Q:'$$TERMLKUP(OCXLAB,.OCXTL) + .S OCXX="",TEST=0 F S TEST=$O(OCXTL(TEST)) Q:'TEST D + ..I $L($G(OCXSL)) D + ...S SPEC=0 F S SPEC=$O(OCXSL(SPEC)) Q:'SPEC D + ....S OCXX=$$LOCL^ORQQLR1(DFN,TEST,SPEC) I $L(OCXX) D + .....S OCXA($P(OCXX,U,7))=OCXX + ..I '$L($G(OCXSL)) S OCXX=$$LOCL^ORQQLR1(DFN,TEST,"") + ..Q:'$L(OCXX) + .I $D(OCXA) S OCXR="",OCXR=$O(OCXA(OCXR),-1),OCXX=OCXA(OCXR) + .I $L(OCXX) D + ..S OCXY=$P(OCXX,U,2)_": "_$P(OCXX,U,3)_" "_$P(OCXX,U,4) + ..S OCXY=OCXY_" "_$S($L($P(OCXX,U,5)):"["_$P(OCXX,U,5)_"]",1:"") + ..I $L($P(OCXX,U,7)) S OCXY=OCXY_" "_$$FMTE^XLFDT($P(OCXX,U,7),"2P") + .S:$L(OCXOUT) OCXOUT=OCXOUT_" " S OCXOUT=OCXOUT_$G(OCXY) + Q:'$L(OCXOUT) "" Q OCXOUT + ; +GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data + ; + N OCXE,VAL,PC S VAL="" + F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) + Q VAL + ; +MCE73() ; Verify Event/Element: CREATININE CLEARANCE ESTIMATE + ; + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(73,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),73)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),73)) + Q 0 + ; +MCE96() ; Verify Event/Element: CREATININE CLEARANCE DATE/TIME + ; + ; OCXDF(76) -> CREATININE CLEARANCE (ESTIM) VALUE data field + ; OCXDF(64) -> FORMATTED RENAL LAB RESULTS data field + ; OCXDF(77) -> CREATININE CLEARANCE (ESTIM) DATE data field + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(96,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),96)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),96)) + S OCXRES(96)=0,OCXDF(77)=$$DT2INT($P($$CRCL(OCXDF(37)),"^",1)) I $L(OCXDF(77)) S OCXRES(96,77)=OCXDF(77) I (OCXDF(77)>$$DT2INT(0)) + E Q 0 + S OCXDF(64)=$$FLAB(OCXDF(37),"SERUM CREATININE^SERUM UREA NITROGEN","SERUM SPECIMEN"),OCXDF(76)=$P($$CRCL(OCXDF(37)),"^",2),OCXRES(96)=11 M ^TMP("OCXCHK",$J,OCXDF(37),96)=OCXRES(96) + Q +OCXRES(96) + ; +MCE97() ; Verify Event/Element: RENAL RESULTS + ; + ; OCXDF(76) -> CREATININE CLEARANCE (ESTIM) VALUE data field + ; OCXDF(64) -> FORMATTED RENAL LAB RESULTS data field + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(97,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),97)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),97)) + S OCXRES(97)=0,OCXDF(64)=$$FLAB(OCXDF(37),"SERUM CREATININE^SERUM UREA NITROGEN","SERUM SPECIMEN") I '(OCXDF(64)="") + E Q 0 + S OCXDF(76)=$P($$CRCL(OCXDF(37)),"^",2),OCXRES(97)=11 M ^TMP("OCXCHK",$J,OCXDF(37),97)=OCXRES(97) + Q +OCXRES(97) + ; +TERMLKUP(OCXTERM,OCXLIST) ; + Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST) + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0Z.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0Z.m index c25d38b4..e882b8e0 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0Z.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0Z.m @@ -1,268 +1,268 @@ -OCXOZ0Z ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; - ; *************************************************************** - ; ** Warning: This routine is automatically generated by the ** - ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** - ; ** will be lost the next time the rule compiler executes. ** - ; *************************************************************** - ; - Q - ; -R62R1A ; Verify all Event/Elements of Rule #62 'FOOD/DRUG INTERACTION' Relation #1 'INPATIENT FOOD DRUG REACTION' - ; Called from EL84+5^OCXOZ0I. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE84( -----------> Verify Event/Element: 'INPATIENT FOOD-DRUG REACTION' - ; - Q:$G(^OCXS(860.2,62,"INACT")) - ; - I $$MCE84 D R62R1B - Q - ; -R62R1B ; Send Order Check, Notication messages and/or Execute code for Rule #62 'FOOD/DRUG INTERACTION' Relation #1 'INPATIENT FOOD DRUG REACTION' - ; Called from R62R1A+10. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; NEWRULE( ---------> NEW RULE MESSAGE - ; - Q:$D(OCXRULE("R62R1B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - S OCXCMSG="" - S OCXNMSG="["_$$GETDATA(DFN,"84^",147)_"] "_$$GETDATA(DFN,"84^",82)_" ordered - adjust diet accordingly." - ; - Q:$G(OCXOERR) - ; - ; Send Notification - ; - S (OCXDUZ,OCXDATA)="",OCXNUM=0 - I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D - .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) - .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA - I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D - .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" - .S OCXNUM=+$P(OCXORD,U,2) - S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) - S OCXRULE("R62R1B")="" - I $$NEWRULE(DFN,OCXNUM,62,1,55,OCXNMSG) D I 1 - .D:($G(OCXTRACE)<5) EN^ORB3(55,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) - Q - ; -R63R1A ; Verify all Event/Elements of Rule #63 'GLUCOPHAGE - CONTRAST MEDIA' Relation #1 'IF PROC USES NON-BARIUM MEDIA AND PATIENT TAKING G...' - ; Called from EL91+5^OCXOZ0I, and EL106+5^OCXOZ0I. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE106( ----------> Verify Event/Element: 'RADIOLOGY PROCEDURE CONTAINS NON-BARIUM CONTRAST MEDIA' - ; MCE91( -----------> Verify Event/Element: 'PATIENT WITH GLUCOPHAGE MED' - ; - Q:$G(^OCXS(860.2,63,"INACT")) - ; - I $$MCE106 D - .I $$MCE91 D R63R1B - Q - ; -R63R1B ; Send Order Check, Notication messages and/or Execute code for Rule #63 'GLUCOPHAGE - CONTRAST MEDIA' Relation #1 'IF PROC USES NON-BARIUM MEDIA AND PATIENT TAKING G...' - ; Called from R63R1A+12. - ; - Q:$G(OCXOERR) - ; - Q:$D(OCXRULE("R63R1B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^23^^Procedure uses intravenous contrast media and patient is taking metformin." I 1 - E S OCXCMSG="Procedure uses intravenous contrast media and patient is taking metformin." - S OCXNMSG="" - ; - Q:$G(OCXOERR) - ; - ; Send Order Check Message - ; - S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG - Q - ; -R65R1A ; Verify all Event/Elements of Rule #65 'POLYPHARMACY' Relation #1 'POLYPHARMACY' - ; Called from EL95+5^OCXOZ0I. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE95( -----------> Verify Event/Element: 'POLYPHARMACY' - ; - Q:$G(^OCXS(860.2,65,"INACT")) - ; - I $$MCE95 D R65R1B - Q - ; -R65R1B ; Send Order Check, Notication messages and/or Execute code for Rule #65 'POLYPHARMACY' Relation #1 'POLYPHARMACY' - ; Called from R65R1A+10. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; - Q:$D(OCXRULE("R65R1B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^26^^Potential polypharmacy - patient currently receiving "_$$GETDATA(DFN,"95^",109)_" medications." I 1 - E S OCXCMSG="Potential polypharmacy - patient currently receiving "_$$GETDATA(DFN,"95^",109)_" medications." - S OCXNMSG="" - ; - Q:$G(OCXOERR) - ; - ; Send Order Check Message - ; - S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG - Q - ; -R66R1A ; Verify all Event/Elements of Rule #66 'LAB RESULTS' Relation #1 'HL7 LAB RESULTS' - ; Called from EL5+6^OCXOZ0H. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE5( ------------> Verify Event/Element: 'HL7 FINAL LAB RESULT' - ; - Q:$G(^OCXS(860.2,66,"INACT")) - ; - I $$MCE5 D R66R1B^OCXOZ10 - Q - ; -CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM - ; - N CKSUM,PTR,ASC S CKSUM=0 - S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") - F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC - Q +CKSUM - ; -GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data - ; - N OCXE,VAL,PC S VAL="" - F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) - Q VAL - ; -MCE106() ; Verify Event/Element: RADIOLOGY PROCEDURE CONTAINS NON-BARIUM CONTRAST MEDIA - ; - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(106,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),106)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),106)) - Q 0 - ; -MCE5() ; Verify Event/Element: HL7 FINAL LAB RESULT - ; - ; - N OCXRES - I $L(OCXDF(37)) S OCXRES(5,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),5)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),5)) - Q 0 - ; -MCE84() ; Verify Event/Element: INPATIENT FOOD-DRUG REACTION - ; - ; - N OCXRES - I $L(OCXDF(37)) S OCXRES(84,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),84)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),84)) - Q 0 - ; -MCE91() ; Verify Event/Element: PATIENT WITH GLUCOPHAGE MED - ; - ; OCXDF(103) -> PATIENT CURRENTLY ON GLUCOPHAGE data field - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(91,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),91)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),91)) - S OCXRES(91)=0,OCXDF(103)=$P($$TAKEMED^ORKPS(OCXDF(37),"^GLUCOPHAGE^METFORMIN^AVANDAMET^METAGLIP"),"^",1) I $L(OCXDF(103)) S OCXRES(91,103)=OCXDF(103) I (OCXDF(103)) - E Q 0 - S OCXRES(91)=11 M ^TMP("OCXCHK",$J,OCXDF(37),91)=OCXRES(91) - Q +OCXRES(91) - ; -MCE95() ; Verify Event/Element: POLYPHARMACY - ; - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(95,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),95)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),95)) - Q 0 - ; -NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number - ; - ; - Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 - Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 - S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN - ; - N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL - ; - S OCXTIME=(+$H) - S OCXCKSUM=$$CKSUM(OCXMESS) - ; - S OCXTSP=($H*86400)+$P($H,",",2) - S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) - ; - Q:(OCXTSPL>OCXTSP) 0 - ; - K OCXDATA - S OCXDATA(OCXDFN,0)=OCXDFN - S OCXDATA("B",OCXDFN,OCXDFN)="" - S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP - ; - S OCXGR="^OCXD(860.7" - D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) - ; - K OCXDATA - S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) - S OCXDATA(OCXRUL,"M")=OCXMESS - S OCXDATA("B",OCXRUL,OCXRUL)="" - S OCXGR=OCXGR_","_OCXDFN_",1" - D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) - ; - K OCXDATA - S OCXDATA(OCXREL,0)=OCXREL - S OCXDATA("B",OCXREL,OCXREL)="" - S OCXGR=OCXGR_","_OCXRUL_",1" - D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) - ; - S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D - .; - .N OCXGR1 - .S OCXGR1=OCXGR_","_OCXREL_",1" - .K OCXDATA - .S OCXDATA(OCXELE,0)=OCXELE - .S OCXDATA(OCXELE,"TIME")=OCXTIME - .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) - .S OCXDATA("B",OCXELE,OCXELE)="" - .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) - .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) - .; - .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D - ..N OCXGR2 - ..S OCXGR2=OCXGR1_","_OCXELE_",1" - ..K OCXDATA - ..S OCXDATA(OCXDFI,0)=OCXDFI - ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) - ..S OCXDATA("B",OCXDFI,OCXDFI)="" - ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) - ; - Q 1 - ; -SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data - M @ROOT=DATA - I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) - I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) - ; - Q - ; - ; +OCXOZ0Z ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; + ; *************************************************************** + ; ** Warning: This routine is automatically generated by the ** + ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** + ; ** will be lost the next time the rule compiler executes. ** + ; *************************************************************** + ; + Q + ; +R62R1A ; Verify all Event/Elements of Rule #62 'FOOD/DRUG INTERACTION' Relation #1 'INPATIENT FOOD DRUG REACTION' + ; Called from EL84+5^OCXOZ0I. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE84( -----------> Verify Event/Element: 'INPATIENT FOOD-DRUG REACTION' + ; + Q:$G(^OCXS(860.2,62,"INACT")) + ; + I $$MCE84 D R62R1B + Q + ; +R62R1B ; Send Order Check, Notication messages and/or Execute code for Rule #62 'FOOD/DRUG INTERACTION' Relation #1 'INPATIENT FOOD DRUG REACTION' + ; Called from R62R1A+10. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; NEWRULE( ---------> NEW RULE MESSAGE + ; + Q:$D(OCXRULE("R62R1B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + S OCXCMSG="" + S OCXNMSG="["_$$GETDATA(DFN,"84^",147)_"] "_$$GETDATA(DFN,"84^",82)_" ordered - adjust diet accordingly." + ; + Q:$G(OCXOERR) + ; + ; Send Notification + ; + S (OCXDUZ,OCXDATA)="",OCXNUM=0 + I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D + .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) + .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA + I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D + .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" + .S OCXNUM=+$P(OCXORD,U,2) + S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) + S OCXRULE("R62R1B")="" + I $$NEWRULE(DFN,OCXNUM,62,1,55,OCXNMSG) D I 1 + .D:($G(OCXTRACE)<5) EN^ORB3(55,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) + Q + ; +R63R1A ; Verify all Event/Elements of Rule #63 'GLUCOPHAGE - CONTRAST MEDIA' Relation #1 'IF PROC USES NON-BARIUM MEDIA AND PATIENT TAKING G...' + ; Called from EL91+5^OCXOZ0I, and EL106+5^OCXOZ0I. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE106( ----------> Verify Event/Element: 'RADIOLOGY PROCEDURE CONTAINS NON-BARIUM CONTRAST MEDIA' + ; MCE91( -----------> Verify Event/Element: 'PATIENT WITH GLUCOPHAGE MED' + ; + Q:$G(^OCXS(860.2,63,"INACT")) + ; + I $$MCE106 D + .I $$MCE91 D R63R1B + Q + ; +R63R1B ; Send Order Check, Notication messages and/or Execute code for Rule #63 'GLUCOPHAGE - CONTRAST MEDIA' Relation #1 'IF PROC USES NON-BARIUM MEDIA AND PATIENT TAKING G...' + ; Called from R63R1A+12. + ; + Q:$G(OCXOERR) + ; + Q:$D(OCXRULE("R63R1B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^23^^Procedure uses intravenous contrast media and patient is taking metformin." I 1 + E S OCXCMSG="Procedure uses intravenous contrast media and patient is taking metformin." + S OCXNMSG="" + ; + Q:$G(OCXOERR) + ; + ; Send Order Check Message + ; + S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG + Q + ; +R65R1A ; Verify all Event/Elements of Rule #65 'POLYPHARMACY' Relation #1 'POLYPHARMACY' + ; Called from EL95+5^OCXOZ0I. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE95( -----------> Verify Event/Element: 'POLYPHARMACY' + ; + Q:$G(^OCXS(860.2,65,"INACT")) + ; + I $$MCE95 D R65R1B + Q + ; +R65R1B ; Send Order Check, Notication messages and/or Execute code for Rule #65 'POLYPHARMACY' Relation #1 'POLYPHARMACY' + ; Called from R65R1A+10. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; + Q:$D(OCXRULE("R65R1B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^26^^Potential polypharmacy - patient currently receiving "_$$GETDATA(DFN,"95^",109)_" medications." I 1 + E S OCXCMSG="Potential polypharmacy - patient currently receiving "_$$GETDATA(DFN,"95^",109)_" medications." + S OCXNMSG="" + ; + Q:$G(OCXOERR) + ; + ; Send Order Check Message + ; + S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG + Q + ; +R66R1A ; Verify all Event/Elements of Rule #66 'LAB RESULTS' Relation #1 'HL7 LAB RESULTS' + ; Called from EL5+6^OCXOZ0H. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE5( ------------> Verify Event/Element: 'HL7 FINAL LAB RESULT' + ; + Q:$G(^OCXS(860.2,66,"INACT")) + ; + I $$MCE5 D R66R1B^OCXOZ10 + Q + ; +CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM + ; + N CKSUM,PTR,ASC S CKSUM=0 + S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") + F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC + Q +CKSUM + ; +GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data + ; + N OCXE,VAL,PC S VAL="" + F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) + Q VAL + ; +MCE106() ; Verify Event/Element: RADIOLOGY PROCEDURE CONTAINS NON-BARIUM CONTRAST MEDIA + ; + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(106,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),106)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),106)) + Q 0 + ; +MCE5() ; Verify Event/Element: HL7 FINAL LAB RESULT + ; + ; + N OCXRES + I $L(OCXDF(37)) S OCXRES(5,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),5)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),5)) + Q 0 + ; +MCE84() ; Verify Event/Element: INPATIENT FOOD-DRUG REACTION + ; + ; + N OCXRES + I $L(OCXDF(37)) S OCXRES(84,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),84)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),84)) + Q 0 + ; +MCE91() ; Verify Event/Element: PATIENT WITH GLUCOPHAGE MED + ; + ; OCXDF(103) -> PATIENT CURRENTLY ON GLUCOPHAGE data field + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(91,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),91)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),91)) + S OCXRES(91)=0,OCXDF(103)=$P($$TAKEMED^ORKPS(OCXDF(37),"^GLUCOPHAGE^METFORMIN^AVANDAMET^METAGLIP"),"^",1) I $L(OCXDF(103)) S OCXRES(91,103)=OCXDF(103) I (OCXDF(103)) + E Q 0 + S OCXRES(91)=11 M ^TMP("OCXCHK",$J,OCXDF(37),91)=OCXRES(91) + Q +OCXRES(91) + ; +MCE95() ; Verify Event/Element: POLYPHARMACY + ; + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(95,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),95)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),95)) + Q 0 + ; +NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number + ; + ; + Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 + Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 + S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN + ; + N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL + ; + S OCXTIME=(+$H) + S OCXCKSUM=$$CKSUM(OCXMESS) + ; + S OCXTSP=($H*86400)+$P($H,",",2) + S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) + ; + Q:(OCXTSPL>OCXTSP) 0 + ; + K OCXDATA + S OCXDATA(OCXDFN,0)=OCXDFN + S OCXDATA("B",OCXDFN,OCXDFN)="" + S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP + ; + S OCXGR="^OCXD(860.7" + D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) + ; + K OCXDATA + S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) + S OCXDATA(OCXRUL,"M")=OCXMESS + S OCXDATA("B",OCXRUL,OCXRUL)="" + S OCXGR=OCXGR_","_OCXDFN_",1" + D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) + ; + K OCXDATA + S OCXDATA(OCXREL,0)=OCXREL + S OCXDATA("B",OCXREL,OCXREL)="" + S OCXGR=OCXGR_","_OCXRUL_",1" + D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) + ; + S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D + .; + .N OCXGR1 + .S OCXGR1=OCXGR_","_OCXREL_",1" + .K OCXDATA + .S OCXDATA(OCXELE,0)=OCXELE + .S OCXDATA(OCXELE,"TIME")=OCXTIME + .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) + .S OCXDATA("B",OCXELE,OCXELE)="" + .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) + .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) + .; + .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D + ..N OCXGR2 + ..S OCXGR2=OCXGR1_","_OCXELE_",1" + ..K OCXDATA + ..S OCXDATA(OCXDFI,0)=OCXDFI + ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) + ..S OCXDATA("B",OCXDFI,OCXDFI)="" + ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) + ; + Q 1 + ; +SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data + M @ROOT=DATA + I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) + I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) + ; + Q + ; + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ10.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ10.m index 8d1a94d2..fe71fc81 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ10.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ10.m @@ -1,239 +1,239 @@ -OCXOZ10 ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; - ; *************************************************************** - ; ** Warning: This routine is automatically generated by the ** - ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** - ; ** will be lost the next time the rule compiler executes. ** - ; *************************************************************** - ; - Q - ; -R66R1B ; Send Order Check, Notication messages and/or Execute code for Rule #66 'LAB RESULTS' Relation #1 'HL7 LAB RESULTS' - ; Called from R66R1A+10^OCXOZ0Z. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; NEWRULE( ---------> NEW RULE MESSAGE - ; - Q:$D(OCXRULE("R66R1B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - S OCXCMSG="" - S OCXNMSG="Labs resulted - ["_$$GETDATA(DFN,"5^",96)_"]" - ; - Q:$G(OCXOERR) - ; - ; Send Notification - ; - S (OCXDUZ,OCXDATA)="",OCXNUM=0 - I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D - .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) - .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA - I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D - .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" - .S OCXNUM=+$P(OCXORD,U,2) - S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) - S OCXRULE("R66R1B")="" - I $$NEWRULE(DFN,OCXNUM,66,1,3,OCXNMSG) D I 1 - .D:($G(OCXTRACE)<5) EN^ORB3(3,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) - Q - ; -R67R1A ; Verify all Event/Elements of Rule #67 'GLUCOPHAGE - LAB RESULTS' Relation #1 'GLUCOPHAGE ORDER AND GLUCOPHAGE CREATININE > 1.5' - ; Called from EL86+5^OCXOZ0I, and EL111+5^OCXOZ0I. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE111( ----------> Verify Event/Element: 'GLUCOPHAGE CREATININE > 1.5' - ; MCE86( -----------> Verify Event/Element: 'GLUCOPHAGE ORDER' - ; - Q:$G(^OCXS(860.2,67,"INACT")) - ; - I $$MCE86 D - .I $$MCE111 D R67R1B - Q - ; -R67R1B ; Send Order Check, Notication messages and/or Execute code for Rule #67 'GLUCOPHAGE - LAB RESULTS' Relation #1 'GLUCOPHAGE ORDER AND GLUCOPHAGE CREATININE > 1.5' - ; Called from R67R1A+12. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; - Q:$D(OCXRULE("R67R1B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^28^^Metformin - Creatinine results: "_$$GETDATA(DFN,"86^111",125) I 1 - E S OCXCMSG="Metformin - Creatinine results: "_$$GETDATA(DFN,"86^111",125) - S OCXNMSG="" - ; - Q:$G(OCXOERR) - ; - ; Send Order Check Message - ; - S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG - Q - ; -R67R2A ; Verify all Event/Elements of Rule #67 'GLUCOPHAGE - LAB RESULTS' Relation #2 'GLUCOPHAGE ORDER AND NO GLUCOPHAGE CREATININE' - ; Called from EL86+6^OCXOZ0I, and EL112+5^OCXOZ0I. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE112( ----------> Verify Event/Element: 'NO GLUCOPHAGE CREATININE' - ; MCE86( -----------> Verify Event/Element: 'GLUCOPHAGE ORDER' - ; - Q:$G(^OCXS(860.2,67,"INACT")) - ; - I $$MCE86 D - .I $$MCE112 D R67R2B - Q - ; -R67R2B ; Send Order Check, Notication messages and/or Execute code for Rule #67 'GLUCOPHAGE - LAB RESULTS' Relation #2 'GLUCOPHAGE ORDER AND NO GLUCOPHAGE CREATININE' - ; Called from R67R2A+12. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; - Q:$D(OCXRULE("R67R2B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^28^^Metformin - no serum creatinine within past "_$$GETDATA(DFN,"86^112",127)_" days." I 1 - E S OCXCMSG="Metformin - no serum creatinine within past "_$$GETDATA(DFN,"86^112",127)_" days." - S OCXNMSG="" - ; - Q:$G(OCXOERR) - ; - ; Send Order Check Message - ; - S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG - Q - ; -CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM - ; - N CKSUM,PTR,ASC S CKSUM=0 - S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") - F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC - Q +CKSUM - ; -GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data - ; - N OCXE,VAL,PC S VAL="" - F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) - Q VAL - ; -MCE111() ; Verify Event/Element: GLUCOPHAGE CREATININE > 1.5 - ; - ; OCXDF(127) -> RECENT GLUCOPHAGE CREATININE DAYS data field - ; OCXDF(125) -> RECENT GLUCOPHAGE CREATININE TEXT data field - ; OCXDF(126) -> RECENT GLUCOPHAGE CREATININE RESULT data field - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(111,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),111)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),111)) - S OCXRES(111)=0,OCXDF(126)=$P($$GLCREAT^ORKPS(OCXDF(37)),"^",3) I $L(OCXDF(126)) S OCXRES(111,126)=OCXDF(126) I (OCXDF(126)>1.5) - E Q 0 - S OCXDF(125)=$P($$GLCREAT^ORKPS(OCXDF(37)),"^",2),OCXDF(127)=$P($$GCDAYS^ORKPS(OCXDF(37)),"^",1),OCXRES(111)=11 M ^TMP("OCXCHK",$J,OCXDF(37),111)=OCXRES(111) - Q +OCXRES(111) - ; -MCE112() ; Verify Event/Element: NO GLUCOPHAGE CREATININE - ; - ; OCXDF(127) -> RECENT GLUCOPHAGE CREATININE DAYS data field - ; OCXDF(125) -> RECENT GLUCOPHAGE CREATININE TEXT data field - ; OCXDF(124) -> RECENT GLUCOPHAGE CREATININE FLAG data field - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(112,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),112)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),112)) - S OCXRES(112)=0,OCXDF(124)=$P($$GLCREAT^ORKPS(OCXDF(37)),"^",1) I $L(OCXDF(124)) S OCXRES(112,124)=OCXDF(124) I '(OCXDF(124)) - E Q 0 - S OCXDF(125)=$P($$GLCREAT^ORKPS(OCXDF(37)),"^",2),OCXDF(127)=$P($$GCDAYS^ORKPS(OCXDF(37)),"^",1),OCXRES(112)=11 M ^TMP("OCXCHK",$J,OCXDF(37),112)=OCXRES(112) - Q +OCXRES(112) - ; -MCE86() ; Verify Event/Element: GLUCOPHAGE ORDER - ; - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(86,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),86)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),86)) - Q 0 - ; -NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number - ; - ; - Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 - Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 - S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN - ; - N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL - ; - S OCXTIME=(+$H) - S OCXCKSUM=$$CKSUM(OCXMESS) - ; - S OCXTSP=($H*86400)+$P($H,",",2) - S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) - ; - Q:(OCXTSPL>OCXTSP) 0 - ; - K OCXDATA - S OCXDATA(OCXDFN,0)=OCXDFN - S OCXDATA("B",OCXDFN,OCXDFN)="" - S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP - ; - S OCXGR="^OCXD(860.7" - D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) - ; - K OCXDATA - S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) - S OCXDATA(OCXRUL,"M")=OCXMESS - S OCXDATA("B",OCXRUL,OCXRUL)="" - S OCXGR=OCXGR_","_OCXDFN_",1" - D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) - ; - K OCXDATA - S OCXDATA(OCXREL,0)=OCXREL - S OCXDATA("B",OCXREL,OCXREL)="" - S OCXGR=OCXGR_","_OCXRUL_",1" - D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) - ; - S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D - .; - .N OCXGR1 - .S OCXGR1=OCXGR_","_OCXREL_",1" - .K OCXDATA - .S OCXDATA(OCXELE,0)=OCXELE - .S OCXDATA(OCXELE,"TIME")=OCXTIME - .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) - .S OCXDATA("B",OCXELE,OCXELE)="" - .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) - .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) - .; - .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D - ..N OCXGR2 - ..S OCXGR2=OCXGR1_","_OCXELE_",1" - ..K OCXDATA - ..S OCXDATA(OCXDFI,0)=OCXDFI - ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) - ..S OCXDATA("B",OCXDFI,OCXDFI)="" - ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) - ; - Q 1 - ; -SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data - M @ROOT=DATA - I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) - I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) - ; - Q - ; - ; +OCXOZ10 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; + ; *************************************************************** + ; ** Warning: This routine is automatically generated by the ** + ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** + ; ** will be lost the next time the rule compiler executes. ** + ; *************************************************************** + ; + Q + ; +R66R1B ; Send Order Check, Notication messages and/or Execute code for Rule #66 'LAB RESULTS' Relation #1 'HL7 LAB RESULTS' + ; Called from R66R1A+10^OCXOZ0Z. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; NEWRULE( ---------> NEW RULE MESSAGE + ; + Q:$D(OCXRULE("R66R1B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + S OCXCMSG="" + S OCXNMSG="Labs resulted - ["_$$GETDATA(DFN,"5^",96)_"]" + ; + Q:$G(OCXOERR) + ; + ; Send Notification + ; + S (OCXDUZ,OCXDATA)="",OCXNUM=0 + I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D + .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) + .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA + I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D + .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" + .S OCXNUM=+$P(OCXORD,U,2) + S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) + S OCXRULE("R66R1B")="" + I $$NEWRULE(DFN,OCXNUM,66,1,3,OCXNMSG) D I 1 + .D:($G(OCXTRACE)<5) EN^ORB3(3,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) + Q + ; +R67R1A ; Verify all Event/Elements of Rule #67 'GLUCOPHAGE - LAB RESULTS' Relation #1 'GLUCOPHAGE ORDER AND GLUCOPHAGE CREATININE > 1.5' + ; Called from EL86+5^OCXOZ0I, and EL111+5^OCXOZ0I. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE111( ----------> Verify Event/Element: 'GLUCOPHAGE CREATININE > 1.5' + ; MCE86( -----------> Verify Event/Element: 'GLUCOPHAGE ORDER' + ; + Q:$G(^OCXS(860.2,67,"INACT")) + ; + I $$MCE86 D + .I $$MCE111 D R67R1B + Q + ; +R67R1B ; Send Order Check, Notication messages and/or Execute code for Rule #67 'GLUCOPHAGE - LAB RESULTS' Relation #1 'GLUCOPHAGE ORDER AND GLUCOPHAGE CREATININE > 1.5' + ; Called from R67R1A+12. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; + Q:$D(OCXRULE("R67R1B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^28^^Metformin - Creatinine results: "_$$GETDATA(DFN,"86^111",125) I 1 + E S OCXCMSG="Metformin - Creatinine results: "_$$GETDATA(DFN,"86^111",125) + S OCXNMSG="" + ; + Q:$G(OCXOERR) + ; + ; Send Order Check Message + ; + S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG + Q + ; +R67R2A ; Verify all Event/Elements of Rule #67 'GLUCOPHAGE - LAB RESULTS' Relation #2 'GLUCOPHAGE ORDER AND NO GLUCOPHAGE CREATININE' + ; Called from EL86+6^OCXOZ0I, and EL112+5^OCXOZ0I. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE112( ----------> Verify Event/Element: 'NO GLUCOPHAGE CREATININE' + ; MCE86( -----------> Verify Event/Element: 'GLUCOPHAGE ORDER' + ; + Q:$G(^OCXS(860.2,67,"INACT")) + ; + I $$MCE86 D + .I $$MCE112 D R67R2B + Q + ; +R67R2B ; Send Order Check, Notication messages and/or Execute code for Rule #67 'GLUCOPHAGE - LAB RESULTS' Relation #2 'GLUCOPHAGE ORDER AND NO GLUCOPHAGE CREATININE' + ; Called from R67R2A+12. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; + Q:$D(OCXRULE("R67R2B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^28^^Metformin - no serum creatinine within past "_$$GETDATA(DFN,"86^112",127)_" days." I 1 + E S OCXCMSG="Metformin - no serum creatinine within past "_$$GETDATA(DFN,"86^112",127)_" days." + S OCXNMSG="" + ; + Q:$G(OCXOERR) + ; + ; Send Order Check Message + ; + S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG + Q + ; +CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM + ; + N CKSUM,PTR,ASC S CKSUM=0 + S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") + F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC + Q +CKSUM + ; +GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data + ; + N OCXE,VAL,PC S VAL="" + F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) + Q VAL + ; +MCE111() ; Verify Event/Element: GLUCOPHAGE CREATININE > 1.5 + ; + ; OCXDF(127) -> RECENT GLUCOPHAGE CREATININE DAYS data field + ; OCXDF(125) -> RECENT GLUCOPHAGE CREATININE TEXT data field + ; OCXDF(126) -> RECENT GLUCOPHAGE CREATININE RESULT data field + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(111,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),111)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),111)) + S OCXRES(111)=0,OCXDF(126)=$P($$GLCREAT^ORKPS(OCXDF(37)),"^",3) I $L(OCXDF(126)) S OCXRES(111,126)=OCXDF(126) I (OCXDF(126)>1.5) + E Q 0 + S OCXDF(125)=$P($$GLCREAT^ORKPS(OCXDF(37)),"^",2),OCXDF(127)=$P($$GCDAYS^ORKPS(OCXDF(37)),"^",1),OCXRES(111)=11 M ^TMP("OCXCHK",$J,OCXDF(37),111)=OCXRES(111) + Q +OCXRES(111) + ; +MCE112() ; Verify Event/Element: NO GLUCOPHAGE CREATININE + ; + ; OCXDF(127) -> RECENT GLUCOPHAGE CREATININE DAYS data field + ; OCXDF(125) -> RECENT GLUCOPHAGE CREATININE TEXT data field + ; OCXDF(124) -> RECENT GLUCOPHAGE CREATININE FLAG data field + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(112,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),112)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),112)) + S OCXRES(112)=0,OCXDF(124)=$P($$GLCREAT^ORKPS(OCXDF(37)),"^",1) I $L(OCXDF(124)) S OCXRES(112,124)=OCXDF(124) I '(OCXDF(124)) + E Q 0 + S OCXDF(125)=$P($$GLCREAT^ORKPS(OCXDF(37)),"^",2),OCXDF(127)=$P($$GCDAYS^ORKPS(OCXDF(37)),"^",1),OCXRES(112)=11 M ^TMP("OCXCHK",$J,OCXDF(37),112)=OCXRES(112) + Q +OCXRES(112) + ; +MCE86() ; Verify Event/Element: GLUCOPHAGE ORDER + ; + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(86,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),86)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),86)) + Q 0 + ; +NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number + ; + ; + Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 + Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 + S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN + ; + N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL + ; + S OCXTIME=(+$H) + S OCXCKSUM=$$CKSUM(OCXMESS) + ; + S OCXTSP=($H*86400)+$P($H,",",2) + S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) + ; + Q:(OCXTSPL>OCXTSP) 0 + ; + K OCXDATA + S OCXDATA(OCXDFN,0)=OCXDFN + S OCXDATA("B",OCXDFN,OCXDFN)="" + S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP + ; + S OCXGR="^OCXD(860.7" + D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) + ; + K OCXDATA + S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) + S OCXDATA(OCXRUL,"M")=OCXMESS + S OCXDATA("B",OCXRUL,OCXRUL)="" + S OCXGR=OCXGR_","_OCXDFN_",1" + D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) + ; + K OCXDATA + S OCXDATA(OCXREL,0)=OCXREL + S OCXDATA("B",OCXREL,OCXREL)="" + S OCXGR=OCXGR_","_OCXRUL_",1" + D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) + ; + S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D + .; + .N OCXGR1 + .S OCXGR1=OCXGR_","_OCXREL_",1" + .K OCXDATA + .S OCXDATA(OCXELE,0)=OCXELE + .S OCXDATA(OCXELE,"TIME")=OCXTIME + .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) + .S OCXDATA("B",OCXELE,OCXELE)="" + .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) + .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) + .; + .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D + ..N OCXGR2 + ..S OCXGR2=OCXGR1_","_OCXELE_",1" + ..K OCXDATA + ..S OCXDATA(OCXDFI,0)=OCXDFI + ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) + ..S OCXDATA("B",OCXDFI,OCXDFI)="" + ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) + ; + Q 1 + ; +SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data + M @ROOT=DATA + I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) + I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) + ; + Q + ; + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ11.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ11.m index 3246d391..0d9526cb 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ11.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ11.m @@ -1,206 +1,206 @@ -OCXOZ11 ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; - ; *************************************************************** - ; ** Warning: This routine is automatically generated by the ** - ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** - ; ** will be lost the next time the rule compiler executes. ** - ; *************************************************************** - ; - Q - ; -R68R1A ; Verify all Event/Elements of Rule #68 'DANGEROUS MEDS OVER AGE 64' Relation #1 'MED ORDER FOR PT > 64 AND AMITRIPTYLINE' - ; Called from EL122+5^OCXOZ0I, and EL125+5^OCXOZ0I. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE122( ----------> Verify Event/Element: 'AMITRIPTYLINE ORDER' - ; MCE125( ----------> Verify Event/Element: 'MED ORDER FOR PT > 64' - ; - Q:$G(^OCXS(860.2,68,"INACT")) - ; - I $$MCE125 D - .I $$MCE122 D R68R1B - Q - ; -R68R1B ; Send Order Check, Notication messages and/or Execute code for Rule #68 'DANGEROUS MEDS OVER AGE 64' Relation #1 'MED ORDER FOR PT > 64 AND AMITRIPTYLINE' - ; Called from R68R1A+12. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; - Q:$D(OCXRULE("R68R1B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^30^^Patient is "_$$GETDATA(DFN,"122^125",62)_". "_$$GETDATA(DFN,"122^125",141) I 1 - E S OCXCMSG="Patient is "_$$GETDATA(DFN,"122^125",62)_". "_$$GETDATA(DFN,"122^125",141) - S OCXNMSG="" - ; - Q:$G(OCXOERR) - ; - ; Send Order Check Message - ; - S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG - Q - ; -R68R2A ; Verify all Event/Elements of Rule #68 'DANGEROUS MEDS OVER AGE 64' Relation #2 'MED ORDER FOR PT > 64 AND CHLORPROPAMIDE' - ; Called from EL125+6^OCXOZ0I, and EL123+5^OCXOZ0I. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE123( ----------> Verify Event/Element: 'CHLORPROPAMIDE ORDER' - ; MCE125( ----------> Verify Event/Element: 'MED ORDER FOR PT > 64' - ; - Q:$G(^OCXS(860.2,68,"INACT")) - ; - I $$MCE125 D - .I $$MCE123 D R68R2B - Q - ; -R68R2B ; Send Order Check, Notication messages and/or Execute code for Rule #68 'DANGEROUS MEDS OVER AGE 64' Relation #2 'MED ORDER FOR PT > 64 AND CHLORPROPAMIDE' - ; Called from R68R2A+12. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; - Q:$D(OCXRULE("R68R2B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^30^^Patient is "_$$GETDATA(DFN,"123^125",62)_". "_$$GETDATA(DFN,"123^125",142) I 1 - E S OCXCMSG="Patient is "_$$GETDATA(DFN,"123^125",62)_". "_$$GETDATA(DFN,"123^125",142) - S OCXNMSG="" - ; - Q:$G(OCXOERR) - ; - ; Send Order Check Message - ; - S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG - Q - ; -R68R3A ; Verify all Event/Elements of Rule #68 'DANGEROUS MEDS OVER AGE 64' Relation #3 'MED ORDER FOR PT > 64 AND DIPYRIDAMOLE' - ; Called from EL125+7^OCXOZ0I, and EL124+5^OCXOZ0I. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE124( ----------> Verify Event/Element: 'DIPYRIDAMOLE ORDER' - ; MCE125( ----------> Verify Event/Element: 'MED ORDER FOR PT > 64' - ; - Q:$G(^OCXS(860.2,68,"INACT")) - ; - I $$MCE125 D - .I $$MCE124 D R68R3B - Q - ; -R68R3B ; Send Order Check, Notication messages and/or Execute code for Rule #68 'DANGEROUS MEDS OVER AGE 64' Relation #3 'MED ORDER FOR PT > 64 AND DIPYRIDAMOLE' - ; Called from R68R3A+12. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; - Q:$D(OCXRULE("R68R3B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^30^^Patient is "_$$GETDATA(DFN,"124^125",62)_". "_$$GETDATA(DFN,"124^125",144) I 1 - E S OCXCMSG="Patient is "_$$GETDATA(DFN,"124^125",62)_". "_$$GETDATA(DFN,"124^125",144) - S OCXNMSG="" - ; - Q:$G(OCXOERR) - ; - ; Send Order Check Message - ; - S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG - Q - ; -R69R1A ; Verify all Event/Elements of Rule #69 'LAB THRESHOLD' Relation #1 'IF HL7 LAB RESULTS AND (GREATER THAN THRESHOLD VAL...' - ; Called from EL5+7^OCXOZ0H, and EL131+5^OCXOZ0I, and EL132+5^OCXOZ0I. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE131( ----------> Verify Event/Element: 'GREATER THAN LAB THRESHOLD' - ; MCE132( ----------> Verify Event/Element: 'LESS THAN LAB THRESHOLD' - ; MCE5( ------------> Verify Event/Element: 'HL7 FINAL LAB RESULT' - ; - Q:$G(^OCXS(860.2,69,"INACT")) - ; - I $$MCE5 D - .I $$MCE131 D R69R1B^OCXOZ12 - .I $$MCE132 D R69R1B^OCXOZ12 - Q - ; -GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data - ; - N OCXE,VAL,PC S VAL="" - F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) - Q VAL - ; -MCE122() ; Verify Event/Element: AMITRIPTYLINE ORDER - ; - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(122,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),122)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),122)) - Q 0 - ; -MCE123() ; Verify Event/Element: CHLORPROPAMIDE ORDER - ; - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(123,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),123)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),123)) - Q 0 - ; -MCE124() ; Verify Event/Element: DIPYRIDAMOLE ORDER - ; - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(124,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),124)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),124)) - Q 0 - ; -MCE125() ; Verify Event/Element: MED ORDER FOR PT > 64 - ; - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(125,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),125)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),125)) - Q 0 - ; -MCE131() ; Verify Event/Element: GREATER THAN LAB THRESHOLD - ; - ; - N OCXRES - I $L(OCXDF(37)) S OCXRES(131,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),131)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),131)) - Q 0 - ; -MCE132() ; Verify Event/Element: LESS THAN LAB THRESHOLD - ; - ; - N OCXRES - I $L(OCXDF(37)) S OCXRES(132,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),132)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),132)) - Q 0 - ; -MCE5() ; Verify Event/Element: HL7 FINAL LAB RESULT - ; - ; - N OCXRES - I $L(OCXDF(37)) S OCXRES(5,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),5)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),5)) - Q 0 - ; +OCXOZ11 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; + ; *************************************************************** + ; ** Warning: This routine is automatically generated by the ** + ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** + ; ** will be lost the next time the rule compiler executes. ** + ; *************************************************************** + ; + Q + ; +R68R1A ; Verify all Event/Elements of Rule #68 'DANGEROUS MEDS OVER AGE 64' Relation #1 'MED ORDER FOR PT > 64 AND AMITRIPTYLINE' + ; Called from EL122+5^OCXOZ0I, and EL125+5^OCXOZ0I. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE122( ----------> Verify Event/Element: 'AMITRIPTYLINE ORDER' + ; MCE125( ----------> Verify Event/Element: 'MED ORDER FOR PT > 64' + ; + Q:$G(^OCXS(860.2,68,"INACT")) + ; + I $$MCE125 D + .I $$MCE122 D R68R1B + Q + ; +R68R1B ; Send Order Check, Notication messages and/or Execute code for Rule #68 'DANGEROUS MEDS OVER AGE 64' Relation #1 'MED ORDER FOR PT > 64 AND AMITRIPTYLINE' + ; Called from R68R1A+12. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; + Q:$D(OCXRULE("R68R1B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^30^^Patient is "_$$GETDATA(DFN,"122^125",62)_". "_$$GETDATA(DFN,"122^125",141) I 1 + E S OCXCMSG="Patient is "_$$GETDATA(DFN,"122^125",62)_". "_$$GETDATA(DFN,"122^125",141) + S OCXNMSG="" + ; + Q:$G(OCXOERR) + ; + ; Send Order Check Message + ; + S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG + Q + ; +R68R2A ; Verify all Event/Elements of Rule #68 'DANGEROUS MEDS OVER AGE 64' Relation #2 'MED ORDER FOR PT > 64 AND CHLORPROPAMIDE' + ; Called from EL125+6^OCXOZ0I, and EL123+5^OCXOZ0I. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE123( ----------> Verify Event/Element: 'CHLORPROPAMIDE ORDER' + ; MCE125( ----------> Verify Event/Element: 'MED ORDER FOR PT > 64' + ; + Q:$G(^OCXS(860.2,68,"INACT")) + ; + I $$MCE125 D + .I $$MCE123 D R68R2B + Q + ; +R68R2B ; Send Order Check, Notication messages and/or Execute code for Rule #68 'DANGEROUS MEDS OVER AGE 64' Relation #2 'MED ORDER FOR PT > 64 AND CHLORPROPAMIDE' + ; Called from R68R2A+12. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; + Q:$D(OCXRULE("R68R2B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^30^^Patient is "_$$GETDATA(DFN,"123^125",62)_". "_$$GETDATA(DFN,"123^125",142) I 1 + E S OCXCMSG="Patient is "_$$GETDATA(DFN,"123^125",62)_". "_$$GETDATA(DFN,"123^125",142) + S OCXNMSG="" + ; + Q:$G(OCXOERR) + ; + ; Send Order Check Message + ; + S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG + Q + ; +R68R3A ; Verify all Event/Elements of Rule #68 'DANGEROUS MEDS OVER AGE 64' Relation #3 'MED ORDER FOR PT > 64 AND DIPYRIDAMOLE' + ; Called from EL125+7^OCXOZ0I, and EL124+5^OCXOZ0I. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE124( ----------> Verify Event/Element: 'DIPYRIDAMOLE ORDER' + ; MCE125( ----------> Verify Event/Element: 'MED ORDER FOR PT > 64' + ; + Q:$G(^OCXS(860.2,68,"INACT")) + ; + I $$MCE125 D + .I $$MCE124 D R68R3B + Q + ; +R68R3B ; Send Order Check, Notication messages and/or Execute code for Rule #68 'DANGEROUS MEDS OVER AGE 64' Relation #3 'MED ORDER FOR PT > 64 AND DIPYRIDAMOLE' + ; Called from R68R3A+12. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; + Q:$D(OCXRULE("R68R3B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^30^^Patient is "_$$GETDATA(DFN,"124^125",62)_". "_$$GETDATA(DFN,"124^125",144) I 1 + E S OCXCMSG="Patient is "_$$GETDATA(DFN,"124^125",62)_". "_$$GETDATA(DFN,"124^125",144) + S OCXNMSG="" + ; + Q:$G(OCXOERR) + ; + ; Send Order Check Message + ; + S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG + Q + ; +R69R1A ; Verify all Event/Elements of Rule #69 'LAB THRESHOLD' Relation #1 'IF HL7 LAB RESULTS AND (GREATER THAN THRESHOLD VAL...' + ; Called from EL5+7^OCXOZ0H, and EL131+5^OCXOZ0I, and EL132+5^OCXOZ0I. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE131( ----------> Verify Event/Element: 'GREATER THAN LAB THRESHOLD' + ; MCE132( ----------> Verify Event/Element: 'LESS THAN LAB THRESHOLD' + ; MCE5( ------------> Verify Event/Element: 'HL7 FINAL LAB RESULT' + ; + Q:$G(^OCXS(860.2,69,"INACT")) + ; + I $$MCE5 D + .I $$MCE131 D R69R1B^OCXOZ12 + .I $$MCE132 D R69R1B^OCXOZ12 + Q + ; +GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data + ; + N OCXE,VAL,PC S VAL="" + F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) + Q VAL + ; +MCE122() ; Verify Event/Element: AMITRIPTYLINE ORDER + ; + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(122,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),122)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),122)) + Q 0 + ; +MCE123() ; Verify Event/Element: CHLORPROPAMIDE ORDER + ; + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(123,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),123)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),123)) + Q 0 + ; +MCE124() ; Verify Event/Element: DIPYRIDAMOLE ORDER + ; + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(124,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),124)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),124)) + Q 0 + ; +MCE125() ; Verify Event/Element: MED ORDER FOR PT > 64 + ; + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(125,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),125)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),125)) + Q 0 + ; +MCE131() ; Verify Event/Element: GREATER THAN LAB THRESHOLD + ; + ; + N OCXRES + I $L(OCXDF(37)) S OCXRES(131,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),131)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),131)) + Q 0 + ; +MCE132() ; Verify Event/Element: LESS THAN LAB THRESHOLD + ; + ; + N OCXRES + I $L(OCXDF(37)) S OCXRES(132,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),132)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),132)) + Q 0 + ; +MCE5() ; Verify Event/Element: HL7 FINAL LAB RESULT + ; + ; + N OCXRES + I $L(OCXDF(37)) S OCXRES(5,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),5)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),5)) + Q 0 + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ12.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ12.m index 14a43bf2..2ae7b254 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ12.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ12.m @@ -1,230 +1,230 @@ -OCXOZ12 ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; - ; *************************************************************** - ; ** Warning: This routine is automatically generated by the ** - ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** - ; ** will be lost the next time the rule compiler executes. ** - ; *************************************************************** - ; - Q - ; -R69R1B ; Send Order Check, Notication messages and/or Execute code for Rule #69 'LAB THRESHOLD' Relation #1 'IF HL7 LAB RESULTS AND (GREATER THAN THRESHOLD VAL...' - ; Called from R69R1A+13^OCXOZ11. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; LABTHRSR( --------> LAB THRESHOLD EXCEEDED RESULTS - ; NEWRULE( ---------> NEW RULE MESSAGE - ; - Q:$D(OCXRULE("R69R1B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - S OCXCMSG="" - S OCXNMSG="["_$$GETDATA(DFN,"5^131^132",147)_"] Lab threshold exceeded - ["_$$GETDATA(DFN,"5^131^132",96)_"]" - ; - ; - ; Run Execute Code - ; - S OCXTMP=$$LABTHRSR(.OCXDUZ,$$GETDATA(DFN,"5^131^132",113),$$GETDATA(DFN,"5^131^132",152),$$GETDATA(DFN,"5^131^132",12),$$GETDATA(DFN,"5^131^132",37)) - Q:$G(OCXOERR) - ; - ; Send Notification - ; - S (OCXDUZ,OCXDATA)="",OCXNUM=0 - I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D - .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) - .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA - I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D - .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" - .S OCXNUM=+$P(OCXORD,U,2) - S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) - S OCXRULE("R69R1B")="" - I $$NEWRULE(DFN,OCXNUM,69,1,68,OCXNMSG) D I 1 - .D:($G(OCXTRACE)<5) EN^ORB3(68,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) - Q - ; -R70R1A ; Verify all Event/Elements of Rule #70 'NO ALLERGY ASSESSMENT' Relation #1 'NO ALLERGY ASSESSMENT AND (RADIOLOGY ORDER OR PHAR...' - ; Called from EL28+5^OCXOZ0I, and EL135+5^OCXOZ0I, and EL136+5^OCXOZ0I, and EL137+5^OCXOZ0I. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE135( ----------> Verify Event/Element: 'DIET ORDER' - ; MCE136( ----------> Verify Event/Element: 'NO ALLERGY ASSESSMENT' - ; MCE137( ----------> Verify Event/Element: 'PHARMACY ORDER' - ; MCE28( -----------> Verify Event/Element: 'RADIOLOGY ORDER' - ; - Q:$G(^OCXS(860.2,70,"INACT")) - ; - I $$MCE136 D - .I $$MCE28 D R70R1B - .I $$MCE137 D R70R1B - .I $$MCE135 D R70R1B - Q - ; -R70R1B ; Send Order Check, Notication messages and/or Execute code for Rule #70 'NO ALLERGY ASSESSMENT' Relation #1 'NO ALLERGY ASSESSMENT AND (RADIOLOGY ORDER OR PHAR...' - ; Called from R70R1A+14. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; NEWRULE( ---------> NEW RULE MESSAGE - ; - Q:$D(OCXRULE("R70R1B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^32^^Patient has no allergy assessment." I 1 - E S OCXCMSG="Patient has no allergy assessment." - S OCXNMSG="" - ; - ; - ; Run Execute Code - ; - Q:'$$NEWRULE(DFN,$J,39,1,999,"Patient has no allergy assessment.") - Q:$G(OCXOERR) - ; - ; Send Order Check Message - ; - S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG - Q - ; -CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM - ; - N CKSUM,PTR,ASC S CKSUM=0 - S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") - F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC - Q +CKSUM - ; -GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data - ; - N OCXE,VAL,PC S VAL="" - F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) - Q VAL - ; -LABTHRSR(OCXDUZ,OCXLAB,OCXSPEC,OCXRSLT,OCXPTDFN) ; Compiler Function: LAB THRESHOLD EXCEEDED RESULTS - ; - Q:'$G(OCXLAB)!'$G(OCXSPEC)!'$G(OCXRSLT) 0 - ; - N OCXX,OCXPENT,OCXERR,OCXLABSP,OCXPVAL,OCXOP,OCXEXCD - S OCXEXCD=0,OCXLABSP=OCXLAB_";"_OCXSPEC - F OCXOP="<",">" D - .D ENVAL^XPAR(.OCXX,"ORB LAB "_OCXOP_" THRESHOLD",OCXLABSP,.OCXERR) - .Q:+$G(ORERR)'=0 - .Q:+$G(OCXX)=0 - .S OCXPENT="" F S OCXPENT=$O(OCXX(OCXPENT)) Q:'OCXPENT D - ..S OCXPVAL=OCXX(OCXPENT,OCXLABSP) - ..I $L(OCXPVAL) D - ...I $P(OCXPENT,";",2)="VA(200,",@(OCXRSLT_OCXOP_OCXPVAL) D - ....I +$$PPLINK^ORQPTQ1(+OCXPENT,OCXPTDFN) D - .....S OCXDUZ(+OCXPENT)="",OCXEXCD=1 - Q OCXEXCD - ; -MCE135() ; Verify Event/Element: DIET ORDER - ; - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(135,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),135)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),135)) - Q 0 - ; -MCE136() ; Verify Event/Element: NO ALLERGY ASSESSMENT - ; - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(136,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),136)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),136)) - Q 0 - ; -MCE137() ; Verify Event/Element: PHARMACY ORDER - ; - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(137,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),137)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),137)) - Q 0 - ; -MCE28() ; Verify Event/Element: RADIOLOGY ORDER - ; - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(28,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),28)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),28)) - Q 0 - ; -NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number - ; - ; - Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 - Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 - S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN - ; - N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL - ; - S OCXTIME=(+$H) - S OCXCKSUM=$$CKSUM(OCXMESS) - ; - S OCXTSP=($H*86400)+$P($H,",",2) - S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) - ; - Q:(OCXTSPL>OCXTSP) 0 - ; - K OCXDATA - S OCXDATA(OCXDFN,0)=OCXDFN - S OCXDATA("B",OCXDFN,OCXDFN)="" - S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP - ; - S OCXGR="^OCXD(860.7" - D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) - ; - K OCXDATA - S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) - S OCXDATA(OCXRUL,"M")=OCXMESS - S OCXDATA("B",OCXRUL,OCXRUL)="" - S OCXGR=OCXGR_","_OCXDFN_",1" - D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) - ; - K OCXDATA - S OCXDATA(OCXREL,0)=OCXREL - S OCXDATA("B",OCXREL,OCXREL)="" - S OCXGR=OCXGR_","_OCXRUL_",1" - D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) - ; - S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D - .; - .N OCXGR1 - .S OCXGR1=OCXGR_","_OCXREL_",1" - .K OCXDATA - .S OCXDATA(OCXELE,0)=OCXELE - .S OCXDATA(OCXELE,"TIME")=OCXTIME - .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) - .S OCXDATA("B",OCXELE,OCXELE)="" - .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) - .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) - .; - .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D - ..N OCXGR2 - ..S OCXGR2=OCXGR1_","_OCXELE_",1" - ..K OCXDATA - ..S OCXDATA(OCXDFI,0)=OCXDFI - ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) - ..S OCXDATA("B",OCXDFI,OCXDFI)="" - ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) - ; - Q 1 - ; -SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data - M @ROOT=DATA - I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) - I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) - ; - Q - ; - ; +OCXOZ12 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; + ; *************************************************************** + ; ** Warning: This routine is automatically generated by the ** + ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** + ; ** will be lost the next time the rule compiler executes. ** + ; *************************************************************** + ; + Q + ; +R69R1B ; Send Order Check, Notication messages and/or Execute code for Rule #69 'LAB THRESHOLD' Relation #1 'IF HL7 LAB RESULTS AND (GREATER THAN THRESHOLD VAL...' + ; Called from R69R1A+13^OCXOZ11. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; LABTHRSR( --------> LAB THRESHOLD EXCEEDED RESULTS + ; NEWRULE( ---------> NEW RULE MESSAGE + ; + Q:$D(OCXRULE("R69R1B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + S OCXCMSG="" + S OCXNMSG="["_$$GETDATA(DFN,"5^131^132",147)_"] Lab threshold exceeded - ["_$$GETDATA(DFN,"5^131^132",96)_"]" + ; + ; + ; Run Execute Code + ; + S OCXTMP=$$LABTHRSR(.OCXDUZ,$$GETDATA(DFN,"5^131^132",113),$$GETDATA(DFN,"5^131^132",152),$$GETDATA(DFN,"5^131^132",12),$$GETDATA(DFN,"5^131^132",37)) + Q:$G(OCXOERR) + ; + ; Send Notification + ; + S (OCXDUZ,OCXDATA)="",OCXNUM=0 + I ($G(OCXOSRC)="GENERIC HL7 MESSAGE ARRAY") D + .S OCXDATA=$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",2))_"|"_$G(^TMP("OCXSWAP",$J,"OCXODATA","ORC",3)) + .S OCXDATA=$TR(OCXDATA,"^","@"),OCXNUM=+OCXDATA + I ($G(OCXOSRC)="CPRS ORDER PROTOCOL") D + .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))="" + .S OCXNUM=+$P(OCXORD,U,2) + S:($G(OCXOSRC)="CPRS ORDER PRESCAN") OCXNUM=+$P(OCXPSD,"|",5) + S OCXRULE("R69R1B")="" + I $$NEWRULE(DFN,OCXNUM,69,1,68,OCXNMSG) D I 1 + .D:($G(OCXTRACE)<5) EN^ORB3(68,DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA) + Q + ; +R70R1A ; Verify all Event/Elements of Rule #70 'NO ALLERGY ASSESSMENT' Relation #1 'NO ALLERGY ASSESSMENT AND (RADIOLOGY ORDER OR PHAR...' + ; Called from EL28+5^OCXOZ0I, and EL135+5^OCXOZ0I, and EL136+5^OCXOZ0I, and EL137+5^OCXOZ0I. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE135( ----------> Verify Event/Element: 'DIET ORDER' + ; MCE136( ----------> Verify Event/Element: 'NO ALLERGY ASSESSMENT' + ; MCE137( ----------> Verify Event/Element: 'PHARMACY ORDER' + ; MCE28( -----------> Verify Event/Element: 'RADIOLOGY ORDER' + ; + Q:$G(^OCXS(860.2,70,"INACT")) + ; + I $$MCE136 D + .I $$MCE28 D R70R1B + .I $$MCE137 D R70R1B + .I $$MCE135 D R70R1B + Q + ; +R70R1B ; Send Order Check, Notication messages and/or Execute code for Rule #70 'NO ALLERGY ASSESSMENT' Relation #1 'NO ALLERGY ASSESSMENT AND (RADIOLOGY ORDER OR PHAR...' + ; Called from R70R1A+14. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; NEWRULE( ---------> NEW RULE MESSAGE + ; + Q:$D(OCXRULE("R70R1B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^32^^Patient has no allergy assessment." I 1 + E S OCXCMSG="Patient has no allergy assessment." + S OCXNMSG="" + ; + ; + ; Run Execute Code + ; + Q:'$$NEWRULE(DFN,$J,39,1,999,"Patient has no allergy assessment.") + Q:$G(OCXOERR) + ; + ; Send Order Check Message + ; + S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG + Q + ; +CKSUM(STR) ; Compiler Function: GENERATE STRING CHECKSUM + ; + N CKSUM,PTR,ASC S CKSUM=0 + S STR=$TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") + F PTR=$L(STR):-1:1 S ASC=$A(STR,PTR)-42 I (ASC>0),(ASC<51) S CKSUM=CKSUM*2+ASC + Q +CKSUM + ; +GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data + ; + N OCXE,VAL,PC S VAL="" + F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) + Q VAL + ; +LABTHRSR(OCXDUZ,OCXLAB,OCXSPEC,OCXRSLT,OCXPTDFN) ; Compiler Function: LAB THRESHOLD EXCEEDED RESULTS + ; + Q:'$G(OCXLAB)!'$G(OCXSPEC)!'$G(OCXRSLT) 0 + ; + N OCXX,OCXPENT,OCXERR,OCXLABSP,OCXPVAL,OCXOP,OCXEXCD + S OCXEXCD=0,OCXLABSP=OCXLAB_";"_OCXSPEC + F OCXOP="<",">" D + .D ENVAL^XPAR(.OCXX,"ORB LAB "_OCXOP_" THRESHOLD",OCXLABSP,.OCXERR) + .Q:+$G(ORERR)'=0 + .Q:+$G(OCXX)=0 + .S OCXPENT="" F S OCXPENT=$O(OCXX(OCXPENT)) Q:'OCXPENT D + ..S OCXPVAL=OCXX(OCXPENT,OCXLABSP) + ..I $L(OCXPVAL) D + ...I $P(OCXPENT,";",2)="VA(200,",@(OCXRSLT_OCXOP_OCXPVAL) D + ....I +$$PPLINK^ORQPTQ1(+OCXPENT,OCXPTDFN) D + .....S OCXDUZ(+OCXPENT)="",OCXEXCD=1 + Q OCXEXCD + ; +MCE135() ; Verify Event/Element: DIET ORDER + ; + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(135,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),135)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),135)) + Q 0 + ; +MCE136() ; Verify Event/Element: NO ALLERGY ASSESSMENT + ; + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(136,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),136)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),136)) + Q 0 + ; +MCE137() ; Verify Event/Element: PHARMACY ORDER + ; + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(137,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),137)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),137)) + Q 0 + ; +MCE28() ; Verify Event/Element: RADIOLOGY ORDER + ; + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(28,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),28)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),28)) + Q 0 + ; +NEWRULE(OCXDFN,OCXORD,OCXRUL,OCXREL,OCXNOTF,OCXMESS) ; Has this rule already been triggered for this order number + ; + ; + Q:'$G(OCXDFN) 0 Q:'$G(OCXRUL) 0 + Q:'$G(OCXREL) 0 Q:'$G(OCXNOTF) 0 Q:'$L($G(OCXMESS)) 0 + S OCXORD=+$G(OCXORD),OCXDFN=+OCXDFN + ; + N OCXNDX,OCXDATA,OCXDFI,OCXELE,OCXGR,OCXTIME,OCXCKSUM,OCXTSP,OCXTSPL + ; + S OCXTIME=(+$H) + S OCXCKSUM=$$CKSUM(OCXMESS) + ; + S OCXTSP=($H*86400)+$P($H,",",2) + S OCXTSPL=($G(^OCXD(860.7,"AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM))+$G(OCXTSPI,300)) + ; + Q:(OCXTSPL>OCXTSP) 0 + ; + K OCXDATA + S OCXDATA(OCXDFN,0)=OCXDFN + S OCXDATA("B",OCXDFN,OCXDFN)="" + S OCXDATA("AT",OCXTIME,OCXDFN,OCXRUL,+OCXORD,OCXCKSUM)=OCXTSP + ; + S OCXGR="^OCXD(860.7" + D SETAP(OCXGR_")",0,.OCXDATA,OCXDFN) + ; + K OCXDATA + S OCXDATA(OCXRUL,0)=OCXRUL_U_(OCXTIME)_U_(+OCXORD) + S OCXDATA(OCXRUL,"M")=OCXMESS + S OCXDATA("B",OCXRUL,OCXRUL)="" + S OCXGR=OCXGR_","_OCXDFN_",1" + D SETAP(OCXGR_")","860.71P",.OCXDATA,OCXRUL) + ; + K OCXDATA + S OCXDATA(OCXREL,0)=OCXREL + S OCXDATA("B",OCXREL,OCXREL)="" + S OCXGR=OCXGR_","_OCXRUL_",1" + D SETAP(OCXGR_")","860.712",.OCXDATA,OCXREL) + ; + S OCXELE=0 F S OCXELE=$O(^OCXS(860.2,OCXRUL,"C","C",OCXELE)) Q:'OCXELE D + .; + .N OCXGR1 + .S OCXGR1=OCXGR_","_OCXREL_",1" + .K OCXDATA + .S OCXDATA(OCXELE,0)=OCXELE + .S OCXDATA(OCXELE,"TIME")=OCXTIME + .S OCXDATA(OCXELE,"LOG")=$G(OCXOLOG) + .S OCXDATA("B",OCXELE,OCXELE)="" + .K ^OCXD(860.7,OCXDFN,1,OCXRUL,1,OCXREL,1,OCXELE) + .D SETAP(OCXGR1_")","860.7122P",.OCXDATA,OCXELE) + .; + .S OCXDFI=0 F S OCXDFI=$O(^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI)) Q:'OCXDFI D + ..N OCXGR2 + ..S OCXGR2=OCXGR1_","_OCXELE_",1" + ..K OCXDATA + ..S OCXDATA(OCXDFI,0)=OCXDFI + ..S OCXDATA(OCXDFI,"VAL")=^TMP("OCXCHK",$J,OCXDFN,OCXELE,OCXDFI) + ..S OCXDATA("B",OCXDFI,OCXDFI)="" + ..D SETAP(OCXGR2_")","860.71223P",.OCXDATA,OCXDFI) + ; + Q 1 + ; +SETAP(ROOT,DD,DATA,DA) ; Set Rule Event data + M @ROOT=DATA + I +$G(DD) S @ROOT@(0)="^"_($G(DD))_"^"_($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) + I '$G(DD) S $P(@ROOT@(0),U,3,4)=($P($G(@ROOT@(0)),U,3)+1)_"^"_$G(DA) + ; + Q + ; + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ13.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ13.m index c5c1a098..48afe40b 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ13.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ13.m @@ -1,79 +1,79 @@ -OCXOZ13 ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; - ; *************************************************************** - ; ** Warning: This routine is automatically generated by the ** - ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** - ; ** will be lost the next time the rule compiler executes. ** - ; *************************************************************** - ; - Q - ; -R71R1A ; Verify all Event/Elements of Rule #71 'OPIOID MEDICATIONS' Relation #1 'OPIOID MED ORDER AND DUP OPIOID MEDS' - ; Called from EL138+5^OCXOZ0I, and EL139+5^OCXOZ0I. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; MCE138( ----------> Verify Event/Element: 'DUP OPIOID MEDS' - ; MCE139( ----------> Verify Event/Element: 'OPIOID MED ORDER' - ; - Q:$G(^OCXS(860.2,71,"INACT")) - ; - I $$MCE139 D - .I $$MCE138 D R71R1B^OCXOZ14 - Q - ; -MCE138() ; Verify Event/Element: DUP OPIOID MEDS - ; - ; OCXDF(158) -> DUPLICATE OPIOID MEDICATIONS TEXT data field - ; OCXDF(157) -> DUPLICATE OPIOID MEDICATIONS FLAG data field - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(138,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),138)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),138)) - S OCXRES(138)=0,OCXDF(157)=$P($$OPIOID(OCXDF(37)),"^",1) I $L(OCXDF(157)) S OCXRES(138,157)=OCXDF(157) I (OCXDF(157)) - E Q 0 - S OCXDF(158)=$P($$OPIOID(OCXDF(37)),"^",2),OCXRES(138)=11 M ^TMP("OCXCHK",$J,OCXDF(37),138)=OCXRES(138) - Q +OCXRES(138) - ; -MCE139() ; Verify Event/Element: OPIOID MED ORDER - ; - ; OCXDF(37) -> PATIENT IEN data field - ; - N OCXRES - S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(139,37)=OCXDF(37) - Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),139)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),139)) - Q 0 - ; -OPIOID(ORPT) ;determine if pat is receiving opioid med - ; rtn 1^opioid drug 1, opioid drug 2, opioid drug3, ... - N ORDG,ORTN,ORNUM,ORDI,ORDCLAS,ORDERS,ORTEXT,DUP,DUPI,DUPJ,DUPLEN - S ORDG=0,ORTN=0,DUPI=0,DUPLEN=20 - K ^TMP("ORR",$J) - S ORDG=$O(^ORD(100.98,"B","RX",ORDG)) - D EN^ORQ1(ORPT_";DPT(",ORDG,2,"","","",0,0) - N J,HOR,SEQ,X S J=1,HOR=0,SEQ=0 - S HOR=$O(^TMP("ORR",$J,HOR)) Q:+HOR<1 ORTN - F S SEQ=$O(^TMP("ORR",$J,HOR,SEQ)) Q:+SEQ<1 D - .S X=^TMP("ORR",$J,HOR,SEQ) - .S ORNUM=+$P(X,";") - .Q:ORNUM=+$G(ORIFN) ;quit if dup med order # = current order # - .S ORDI=$$VALUE^ORCSAVE2(ORNUM,"DRUG") - .I +$G(ORDI)>0 D - ..S ORDCLAS=$P(^PSDRUG(ORDI,0),U,2) ;va drug class - ..I ($G(ORDCLAS)="CN101")!($G(ORDCLAS)="CN102") D ;opioid classes - ...S ORTEXT=$$FULLTEXT^ORQOR1(ORNUM) - ...S ORTEXT=$P(ORTEXT,U)_" ["_$P(ORTEXT,U,2)_"]" - ...S DUPI=DUPI+1,DUP(DUPI)=" ["_DUPI_"] "_ORTEXT - ...S ORTN=1 - I DUPI>0 D - .S DUPLEN=$P(215/DUPI,".") - .F DUPJ=1:1:DUPI D - ..I DUPJ=1 S ORDERS=$E(DUP(DUPJ),1,DUPLEN) - ..E S ORDERS=ORDERS_", "_$E(DUP(DUPJ),1,DUPLEN) - K ^TMP("ORR",$J) - Q ORTN_U_$G(ORDERS) - ; +OCXOZ13 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; + ; *************************************************************** + ; ** Warning: This routine is automatically generated by the ** + ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** + ; ** will be lost the next time the rule compiler executes. ** + ; *************************************************************** + ; + Q + ; +R71R1A ; Verify all Event/Elements of Rule #71 'OPIOID MEDICATIONS' Relation #1 'OPIOID MED ORDER AND DUP OPIOID MEDS' + ; Called from EL138+5^OCXOZ0I, and EL139+5^OCXOZ0I. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; MCE138( ----------> Verify Event/Element: 'DUP OPIOID MEDS' + ; MCE139( ----------> Verify Event/Element: 'OPIOID MED ORDER' + ; + Q:$G(^OCXS(860.2,71,"INACT")) + ; + I $$MCE139 D + .I $$MCE138 D R71R1B^OCXOZ14 + Q + ; +MCE138() ; Verify Event/Element: DUP OPIOID MEDS + ; + ; OCXDF(158) -> DUPLICATE OPIOID MEDICATIONS TEXT data field + ; OCXDF(157) -> DUPLICATE OPIOID MEDICATIONS FLAG data field + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(138,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),138)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),138)) + S OCXRES(138)=0,OCXDF(157)=$P($$OPIOID(OCXDF(37)),"^",1) I $L(OCXDF(157)) S OCXRES(138,157)=OCXDF(157) I (OCXDF(157)) + E Q 0 + S OCXDF(158)=$P($$OPIOID(OCXDF(37)),"^",2),OCXRES(138)=11 M ^TMP("OCXCHK",$J,OCXDF(37),138)=OCXRES(138) + Q +OCXRES(138) + ; +MCE139() ; Verify Event/Element: OPIOID MED ORDER + ; + ; OCXDF(37) -> PATIENT IEN data field + ; + N OCXRES + S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(139,37)=OCXDF(37) + Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),139)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),139)) + Q 0 + ; +OPIOID(ORPT) ;determine if pat is receiving opioid med + ; rtn 1^opioid drug 1, opioid drug 2, opioid drug3, ... + N ORDG,ORTN,ORNUM,ORDI,ORDCLAS,ORDERS,ORTEXT,DUP,DUPI,DUPJ,DUPLEN + S ORDG=0,ORTN=0,DUPI=0,DUPLEN=20 + K ^TMP("ORR",$J) + S ORDG=$O(^ORD(100.98,"B","RX",ORDG)) + D EN^ORQ1(ORPT_";DPT(",ORDG,2,"","","",0,0) + N J,HOR,SEQ,X S J=1,HOR=0,SEQ=0 + S HOR=$O(^TMP("ORR",$J,HOR)) Q:+HOR<1 ORTN + F S SEQ=$O(^TMP("ORR",$J,HOR,SEQ)) Q:+SEQ<1 D + .S X=^TMP("ORR",$J,HOR,SEQ) + .S ORNUM=+$P(X,";") + .Q:ORNUM=+$G(ORIFN) ;quit if dup med order # = current order # + .S ORDI=$$VALUE^ORCSAVE2(ORNUM,"DRUG") + .I +$G(ORDI)>0 D + ..S ORDCLAS=$P(^PSDRUG(ORDI,0),U,2) ;va drug class + ..I ($G(ORDCLAS)="CN101")!($G(ORDCLAS)="CN102") D ;opioid classes + ...S ORTEXT=$$FULLTEXT^ORQOR1(ORNUM) + ...S ORTEXT=$P(ORTEXT,U)_" ["_$P(ORTEXT,U,2)_"]" + ...S DUPI=DUPI+1,DUP(DUPI)=" ["_DUPI_"] "_ORTEXT + ...S ORTN=1 + I DUPI>0 D + .S DUPLEN=$P(215/DUPI,".") + .F DUPJ=1:1:DUPI D + ..I DUPJ=1 S ORDERS=$E(DUP(DUPJ),1,DUPLEN) + ..E S ORDERS=ORDERS_", "_$E(DUP(DUPJ),1,DUPLEN) + K ^TMP("ORR",$J) + Q ORTN_U_$G(ORDERS) + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ14.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ14.m index 3c2bbb79..559b4e47 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ14.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ14.m @@ -1,40 +1,40 @@ -OCXOZ14 ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:44 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; - ; *************************************************************** - ; ** Warning: This routine is automatically generated by the ** - ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** - ; ** will be lost the next time the rule compiler executes. ** - ; *************************************************************** - ; - Q - ; -R71R1B ; Send Order Check, Notication messages and/or Execute code for Rule #71 'OPIOID MEDICATIONS' Relation #1 'OPIOID MED ORDER AND DUP OPIOID MEDS' - ; Called from R71R1A+12^OCXOZ13. - ; - Q:$G(OCXOERR) - ; - ; Local Extrinsic Functions - ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE - ; - Q:$D(OCXRULE("R71R1B")) - ; - N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD - I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^33^^Duplicate opioid medications: "_$$GETDATA(DFN,"138^139",158) I 1 - E S OCXCMSG="Duplicate opioid medications: "_$$GETDATA(DFN,"138^139",158) - S OCXNMSG="" - ; - Q:$G(OCXOERR) - ; - ; Send Order Check Message - ; - S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG - Q - ; -GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data - ; - N OCXE,VAL,PC S VAL="" - F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) - Q VAL - ; +OCXOZ14 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; + ; *************************************************************** + ; ** Warning: This routine is automatically generated by the ** + ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine ** + ; ** will be lost the next time the rule compiler executes. ** + ; *************************************************************** + ; + Q + ; +R71R1B ; Send Order Check, Notication messages and/or Execute code for Rule #71 'OPIOID MEDICATIONS' Relation #1 'OPIOID MED ORDER AND DUP OPIOID MEDS' + ; Called from R71R1A+12^OCXOZ13. + ; + Q:$G(OCXOERR) + ; + ; Local Extrinsic Functions + ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE + ; + Q:$D(OCXRULE("R71R1B")) + ; + N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD + I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^33^^Duplicate opioid medications: "_$$GETDATA(DFN,"138^139",158) I 1 + E S OCXCMSG="Duplicate opioid medications: "_$$GETDATA(DFN,"138^139",158) + S OCXNMSG="" + ; + Q:$G(OCXOERR) + ; + ; Send Order Check Message + ; + S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG + Q + ; +GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data + ; + N OCXE,VAL,PC S VAL="" + F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL) + Q VAL + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSEND.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSEND.m index eb8192ef..ec14f612 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSEND.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSEND.m @@ -1,138 +1,135 @@ -OCXSEND ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES ;2/22/08 12:30 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,74,96,105,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; -S ; - N X,IOP,TOTL S TOTL=0 - N CVER,RCNT,RSIZE,LASTFILE,HEADER1,HEADER2,HEADER3,HEADER4,HEADER5 - N OCXASK,OCXID,OCXLIN2,OCXLIN3,OCXPATCH,OCXSCR,PARM,PARMV,DIE,DIERR,DIQ2,FCPARM,TEXT - I '$D(IOM) S IOP=0 D ^%ZIS K IOP - K ^TMP("OCXSEND",$J),^UTILITY($J),OCXPATH - K ^UTILITY($J),OCXPATH - S ^TMP("OCXSEND",$J)=($P($H,",",2)+($H*86400)+(4*60*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG" - S OCXLIN2=$T(+2) - S OCXLIN3=$T(+3) - ; - D ^OCXSEND1 ; Get List of Objects to Transport - ; - I '$O(^TMP("OCXSEND",$J,"LIST",0)) K ^TMP("OCXSEND",$J) Q ; Nothing selected so Quit - ; - S OCXASK="" F D Q:$L(OCXASK) - .W ! - .W !,"When the transport routine encounters locally" - .W !,"altered rule data at a site, do you want to:" - .; - .S OCXASK=$$READ("S^O:Overwrite local data;D:Display locally altered data only;A:Ask the site what to do","(O)verwrite, (D)isplay, or (A)sk the site ? ","Ask") - ; - Q:(OCXASK[U) - I (OCXASK="O") W !!,"Locally altered data will be overwritten without asking.",!! - I (OCXASK="D") W !!,"Locally altered data will be displayed only.",!! - I (OCXASK="A") W !!,"Sites will be asked before locally altered data is overwritten.",!! - ; - S OCXPATCH="" F D Q:$L(OCXPATCH) - .W !!,"Enter Patch ID (ex. OR*3*96): " R OCXPATCH:DTIME E S OCXPATCH="^" Q - .Q:(OCXPATCH="^") - .I '$L(OCXPATCH) S OCXPATCH="^^" Q - .I $L(OCXPATCH),'(OCXPATCH?1"OR*"1N1"*"1.4N) D S OCXPATCH="" Q - ..W !! - ..W:'(OCXPATCH["?") "Invalid" - ..W " Format -> OR*v*ppp" - ..W !," v = Package Version." - ..W !," ppp = Patch Number." - ..W ! - Q:(OCXPATCH="^") - S:(OCXPATCH="^^") OCXPATCH="" - I $P(OCXPATCH,"*",3) S $P(OCXLIN2,";",5)="**"_$P(OCXPATCH,"*",3)_"**" - I $L(OCXPATCH) S OCXPATCH="(Delete after Install of "_OCXPATCH_")" - ; - Q:'$$RSDEL - ; - D ^OCXSEND2 ; Get File Data - ; - S TOTL=$$EN^OCXSEND3 ; File Routines - ; - S TOTL=TOTL+$$EN^OCXSENDA ; File Main Runtime Library Routine - ; - S TOTL=TOTL+$$EN^OCXSEND4 ; File Utility Runtime Library Routine 0 - ; - S TOTL=TOTL+$$EN^OCXSEND5 ; File Utility Runtime Library Routine 1 - ; - S TOTL=TOTL+$$EN^OCXSEND6 ; File Utility Runtime Library Routine 2 - ; - S TOTL=TOTL+$$EN^OCXSEND7 ; File Utility Runtime Library Routine 3 - ; - S TOTL=TOTL+$$EN^OCXSEND8 ; File Utility Runtime Library Routine 4 - ; -EXIT K ^TMP("OCXSEND",$J),^UTILITY($J) - ; - W !!,"Routines filed.",!! - ; - Q - ; -READ(OCX0,OCXA,OCXB,OCXL) ; - N X,DIR,DTOUT,DUOUT,DIRUT,DIROUT - Q:'$L($G(OCX0)) U - S DIR(0)=OCX0 - S:$L($G(OCXA)) DIR("A")=OCXA - S:$L($G(OCXB)) DIR("B")=OCXB - F X=1:1:($G(OCXL)-1) W ! - D ^DIR - I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U - Q Y - ; -CUCI() Q:'$D(^%ZOSF("UCI")) "" N Y X ^%ZOSF("UCI") Q Y - ; -NETNAME() ; - N NETNAME - S NETNAME=$P($$NETNAME^XMXUTIL(DUZ),"@",2) - I $L(NETNAME) Q NETNAME - ; Q:$L($G(^XMB("NETNAME"))) ^XMB("NETNAME") - ; Q:$L($G(^XMB("NAME"))) ^XMB("NAME") - Q $$CUCI - ; -RSDEL() ; - ; - W !!,"Scanning for old rule transport routines..." - N X,CNT,RCNT,RLIST,RNAME - S RCNT=0 - ; - ; Scan for Routines To Delete - ; - ; Main Routine - S RNAME=$$RNAME^OCXSEND3(0,0) I $$RFIND(RNAME,100) S RLIST(RNAME)="" - ; - ; Runtime Library routines - F CNT=0:1:35 S RNAME=$$RNAME^OCXSEND3(CNT,1) I $$RFIND(RNAME,CNT) S RLIST(RNAME)="" - ; - ; Data Routines - F CNT=0:1:46655 S RNAME=$$RNAME^OCXSEND3(CNT,2) I $$RFIND(RNAME,CNT) S RLIST(RNAME)="" - ; - I '$L($O(RLIST(""))) W !,"No old rule transport routines found..." H 2 Q 1 - ; - W !!,"These routines will be deleted and overwritten." - Q:'$$READ("Y"," Do you want to proceed?","NO") 0 - ; - ; Delete The routines - ; - I '$D(^%ZOSF("DEL")) W !!,"Old rule transport routines not deleted (^%ZOSF(""DEL"") undefined)" Q 0 - ; - S RNAME="" F RCNT=1:1 S RNAME=$O(RLIST(RNAME)) Q:'$L(RNAME) D - .W !,RNAME - .I $$RDEL(RNAME) W " Deleted..." Q - .W " Not Deleted..." - ; - W !!,RCNT," routine",$S((RCNT=1):"",1:"s")," deleted." - ; - H 2 Q 1 - ; -RFIND(X,C) ; - W:($X>70) ! W:'(C#100) "." - Q:'$L(X) 0 X "S TEXT=$T(+1^"_X_")" Q:'$L(TEXT) 0 - W !,X Q 1 - Q - ; -RDEL(X) ; - ; - Q:'$L(X) 0 X "S TEXT=$T(+1^"_X_")" Q:'$L(TEXT) 0 - X ^%ZOSF("DEL") Q 1 - ; +OCXSEND ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES ;2/01/01 10:10 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,74,96,105**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; +S ; + N X,IOP,TOTL S TOTL=0 + N CVER,RCNT,RSIZE,LASTFILE,HEADER1,HEADER2,HEADER3,HEADER4,HEADER5 + N OCXASK,OCXID,OCXLIN2,OCXLIN3,OCXPATCH,OCXSCR,PARM,PARMV,DIE,DIERR,DIQ2,FCPARM,TEXT + I '$D(IOM) S IOP=0 D ^%ZIS K IOP + K ^TMP("OCXSEND",$J),^UTILITY($J),OCXPATH + K ^UTILITY($J),OCXPATH + S ^TMP("OCXSEND",$J)=($P($H,",",2)+($H*86400)+(4*60*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG" + S OCXLIN2=$T(+2) + S OCXLIN3=$T(+3) + ; + D ^OCXSEND1 ; Get List of Objects to Transport + ; + I '$O(^TMP("OCXSEND",$J,"LIST",0)) K ^TMP("OCXSEND",$J) Q ; Nothing selected so Quit + ; + S OCXASK="" F D Q:$L(OCXASK) + .W ! + .W !,"When the transport routine encounters locally" + .W !,"altered rule data at a site, do you want to:" + .; + .S OCXASK=$$READ("S^O:Overwrite local data;D:Display locally altered data only;A:Ask the site what to do","(O)verwrite, (D)isplay, or (A)sk the site ? ","Ask") + ; + Q:(OCXASK[U) + I (OCXASK="O") W !!,"Locally altered data will be overwritten without asking.",!! + I (OCXASK="D") W !!,"Locally altered data will be displayed only.",!! + I (OCXASK="A") W !!,"Sites will be asked before locally altered data is overwritten.",!! + ; + S OCXPATCH="" F D Q:$L(OCXPATCH) + .W !!,"Enter Patch ID (ex. OR*3*96): " R OCXPATCH:DTIME E S OCXPATCH="^" Q + .Q:(OCXPATCH="^") + .I '$L(OCXPATCH) S OCXPATCH="^^" Q + .I $L(OCXPATCH),'(OCXPATCH?1"OR*"1N1"*"1.4N) D S OCXPATCH="" Q + ..W !! + ..W:'(OCXPATCH["?") "Invalid" + ..W " Format -> OR*v*ppp" + ..W !," v = Package Version." + ..W !," ppp = Patch Number." + ..W ! + Q:(OCXPATCH="^") + S:(OCXPATCH="^^") OCXPATCH="" + I $P(OCXPATCH,"*",3) S $P(OCXLIN2,";",5)="**"_$P(OCXPATCH,"*",3)_"**" + I $L(OCXPATCH) S OCXPATCH="(Delete after Install of "_OCXPATCH_")" + ; + Q:'$$RSDEL + ; + D ^OCXSEND2 ; Get File Data + ; + S TOTL=$$EN^OCXSEND3 ; File Routines + ; + S TOTL=TOTL+$$EN^OCXSENDA ; File Main Runtime Library Routine + ; + S TOTL=TOTL+$$EN^OCXSEND4 ; File Utility Runtime Library Routine 0 + ; + S TOTL=TOTL+$$EN^OCXSEND5 ; File Utility Runtime Library Routine 1 + ; + S TOTL=TOTL+$$EN^OCXSEND6 ; File Utility Runtime Library Routine 2 + ; + S TOTL=TOTL+$$EN^OCXSEND7 ; File Utility Runtime Library Routine 3 + ; + S TOTL=TOTL+$$EN^OCXSEND8 ; File Utility Runtime Library Routine 4 + ; +EXIT K ^TMP("OCXSEND",$J),^UTILITY($J) + ; + W !!,TOTL," total lines of code filed.",!! + ; + Q + ; +READ(OCX0,OCXA,OCXB,OCXL) ; + N X,DIR,DTOUT,DUOUT,DIRUT,DIROUT + Q:'$L($G(OCX0)) U + S DIR(0)=OCX0 + S:$L($G(OCXA)) DIR("A")=OCXA + S:$L($G(OCXB)) DIR("B")=OCXB + F X=1:1:($G(OCXL)-1) W ! + D ^DIR + I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U + Q Y + ; +CUCI() Q:'$D(^%ZOSF("UCI")) "" N Y X ^%ZOSF("UCI") Q Y + ; +NETNAME() ; + Q:$L($G(^XMB("NETNAME"))) ^XMB("NETNAME") + Q:$L($G(^XMB("NAME"))) ^XMB("NAME") + Q $$CUCI + ; +RSDEL() ; + ; + W !!,"Scanning for old rule transport routines..." + N X,CNT,RCNT,RLIST,RNAME + S RCNT=0 + ; + ; Scan for Routines To Delete + ; + ; Main Routine + S RNAME=$$RNAME^OCXSEND3(0,0) I $$RFIND(RNAME,100) S RLIST(RNAME)="" + ; + ; Runtime Library routines + F CNT=0:1:35 S RNAME=$$RNAME^OCXSEND3(CNT,1) I $$RFIND(RNAME,CNT) S RLIST(RNAME)="" + ; + ; Data Routines + F CNT=0:1:46655 S RNAME=$$RNAME^OCXSEND3(CNT,2) I $$RFIND(RNAME,CNT) S RLIST(RNAME)="" + ; + I '$L($O(RLIST(""))) W !,"No old rule transport routines found..." H 2 Q 1 + ; + W !!,"These routines will be deleted and overwritten." + Q:'$$READ("Y"," Do you want to proceed?","NO") 0 + ; + ; Delete The routines + ; + I '$D(^%ZOSF("DEL")) W !!,"Old rule transport routines not deleted (^%ZOSF(""DEL"") undefined)" Q 0 + ; + S RNAME="" F RCNT=1:1 S RNAME=$O(RLIST(RNAME)) Q:'$L(RNAME) D + .W !,RNAME + .I $$RDEL(RNAME) W " Deleted..." Q + .W " Not Deleted..." + ; + W !!,RCNT," routine",$S((RCNT=1):"",1:"s")," deleted." + ; + H 2 Q 1 + ; +RFIND(X,C) ; + W:($X>70) ! W:'(C#100) "." + Q:'$L(X) 0 X "S TEXT=$T(+1^"_X_")" Q:'$L(TEXT) 0 + W !,X Q 1 + Q + ; +RDEL(X) ; + ; + Q:'$L(X) 0 X "S TEXT=$T(+1^"_X_")" Q:'$L(TEXT) 0 + X ^%ZOSF("DEL") Q 1 + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSEND3.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSEND3.m index d0caf6c4..e175ed78 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSEND3.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSEND3.m @@ -1,109 +1,110 @@ -OCXSEND3 ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES (Build Routines) ;1/31/01 08:51 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,74,96,105,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; -EN() ; - ; - N LAST,RLINE,RNUM,RTEXT,TOTLINE - K ^TMP("OCXSEND",$J,"RTN") S ^TMP("OCXSEND",$J,"RTN",100,0)=" ;" - S (TOTLINE,RSIZE,RLINE,RCNT)=0,RNUM=1 F S RLINE=$O(^TMP("OCXSEND",$J,"DATA",RLINE)) Q:'RLINE D - .S RTEXT=$G(^TMP("OCXSEND",$J,"DATA",RLINE)) Q:'$L(RTEXT) - .S LAST=$O(^TMP("OCXSEND",$J,"RTN",""),-1)+1,RCNT=RCNT+1,RSIZE=RSIZE+$L(RTEXT) - .S ^TMP("OCXSEND",$J,"RTN",LAST,0)=" ;;"_RTEXT - .I (RSIZE>6000) S TOTLINE=TOTLINE+$$RFILE($O(^TMP("OCXSEND",$J,"DATA",RLINE)),.RNUM) S (RSIZE,RCNT)=0 - I $O(^TMP("OCXSEND",$J,"RTN",100)) S TOTLINE=TOTLINE+$$RFILE(0,.RNUM) - ; - Q TOTLINE - ; -RFILE(LINK,RNUM) ; - ; - N DIE,LAST,X,XCN - D HDR(LINK,RNUM) - S LAST=$O(^TMP("OCXSEND",$J,"RTN",""),-1)+1 - S ^TMP("OCXSEND",$J,"RTN",LAST,0)=" ;1;" - S ^TMP("OCXSEND",$J,"RTN",LAST+1,0)=" ;" - S ^TMP("OCXSEND",$J,"RTN",LAST+2,0)="$" - S DIE="^TMP(""OCXSEND"","_$J_",""RTN"",",XCN=0 - S X=$$RNAME(RNUM,2) - W !,X - X ^%ZOSF("SAVE") - S RNUM=RNUM+1 - K ^TMP("OCXSEND",$J,"RTN") S ^TMP("OCXSEND",$J,"RTN",100,0)=" ;" - Q "" - ; -NOW() ; - N X,Y,%DT - S X="N",%DT="T" D ^%DT S Y=$$DATE^OCXSENDD(Y) - I (Y["@") S Y=$P(Y,"@",1)_" at "_$P(Y,"@",2) - Q Y - ; -HDR(LINK,RNUM) ; - ; - N R,LINE,TEXT,RNAME,RLINK,NOW - S NOW=$$NOW - I 'LINK S RLINK=";" - E S RLINK="G ^"_$$RNAME(RNUM+1,2) - S RNAME=$$RNAME(RNUM,2),(HEADER1,HEADER2,HEADER3,HEADER4,HEADER5)=";" - ; - F LINE=1:1:999 S TEXT=$P($T(TEXT+LINE),";",2,999) Q:TEXT S TEXT=$P(TEXT,";",2,999) S R(LINE,0)=$$CONV(TEXT) - ; - M ^TMP("OCXSEND",$J,"RTN")=R - ; - Q - ; -HEX(X) Q:'X "" Q $$HEX(X\36)_$E("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ",((X#36)+1)) - ; -RNAME(X,Y) ; - ; Y=0 -> Main Routine - ; Y=1 -> Runtime Library Routine - ; Y=2 -> Data Routine for ORYppp - ; Y=3 -> Data Routine for OCXRU - ; - N OCXRN1,OCXRN2,OCXSEQ - ; - S OCXRN1="OCXRULE",OCXRN2="OCXRU" - S:$L($G(OCXPATCH)) OCXRN2="ORY"_$E((1000+$P(OCXPATCH,"*",3)),2,4),OCXRN1=OCXRN2_"ES" - ; - Q:'Y OCXRN1 - ; - I (Y=1),(X>35) Q "" - I (Y=2),'$L($G(OCXPATCH)) S Y=3 - I (Y=2),(X>1295) Q "" - I (Y=3),(X>46655) Q "" - ; - S OCXSEQ=0 S:X OCXSEQ=$$HEX(X) - S OCXSEQ="00000"_OCXSEQ - S OCXSEQ=$E(OCXSEQ,($L(OCXSEQ)-Y+1),$L(OCXSEQ)) - ; - Q OCXRN2_OCXSEQ - ; -CONV(X) ; - N VAL - F Q:'(X["|") D - .S VAL=$P(X,"|",2) - .X "S VAL="_VAL - .S X=$P(X,"|",1)_VAL_$P(X,"|",3,999) - I '(X="$"),'$L($P(X," ",2)) S X=X_" ;" - Q X - ; -TEXT ; - ;;|RNAME| ;SLC/RJS,CLA - OCX PACKAGE RULE TRANSPORT ROUTINE |OCXPATCH| ;|NOW| - ;;|OCXLIN2| - ;;|OCXLIN3| - ;; ; - ;;S ; - ;; ; - ;; D DOT^|$$RNAME^OCXSEND3(0,0)| - ;; ; - ;; ; - ;; K REMOTE,LOCAL,OPCODE,REF - ;; F LINE=1:1:500 S TEXT=$P($T(DATA+LINE),";",2,999) Q:TEXT I $L(TEXT) D Q:QUIT - ;; .S ^TMP("OCXRULE",$J,$O(^TMP("OCXRULE",$J,"A"),-1)+1)=TEXT - ;; ; - ;; |RLINK| - ;; ; - ;; Q - ;; ; - ;;DATA ; - ;1; - ; +OCXSEND3 ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES (Build Routines) ;1/31/01 08:51 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,74,96,105**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; +EN() ; + ; + N LAST,RLINE,RNUM,RTEXT,TOTLINE + K ^TMP("OCXSEND",$J,"RTN") S ^TMP("OCXSEND",$J,"RTN",100,0)=" ;" + S (TOTLINE,RSIZE,RLINE,RCNT)=0,RNUM=1 F S RLINE=$O(^TMP("OCXSEND",$J,"DATA",RLINE)) Q:'RLINE D + .S RTEXT=$G(^TMP("OCXSEND",$J,"DATA",RLINE)) Q:'$L(RTEXT) + .S LAST=$O(^TMP("OCXSEND",$J,"RTN",""),-1)+1,RCNT=RCNT+1,RSIZE=RSIZE+$L(RTEXT) + .S ^TMP("OCXSEND",$J,"RTN",LAST,0)=" ;;"_RTEXT + .I (RSIZE>6000) S TOTLINE=TOTLINE+$$RFILE($O(^TMP("OCXSEND",$J,"DATA",RLINE)),.RNUM) S (RSIZE,RCNT)=0 + I $O(^TMP("OCXSEND",$J,"RTN",100)) S TOTLINE=TOTLINE+$$RFILE(0,.RNUM) + ; + Q TOTLINE + ; +RFILE(LINK,RNUM) ; + ; + N DIE,LAST,X,XCN,XCM + D HDR(LINK,RNUM) + S LAST=$O(^TMP("OCXSEND",$J,"RTN",""),-1)+1 + S ^TMP("OCXSEND",$J,"RTN",LAST,0)=" ;1;" + S ^TMP("OCXSEND",$J,"RTN",LAST+1,0)=" ;" + S ^TMP("OCXSEND",$J,"RTN",LAST+2,0)="$" + S DIE="^TMP(""OCXSEND"","_$J_",""RTN"",",XCN=0 + S X=$$RNAME(RNUM,2) + W !,X + X ^%ZOSF("SAVE") + W " ... ",XCM," Lines filed" + S RNUM=RNUM+1 + K ^TMP("OCXSEND",$J,"RTN") S ^TMP("OCXSEND",$J,"RTN",100,0)=" ;" + Q XCM + ; +NOW() ; + N X,Y,%DT + S X="N",%DT="T" D ^%DT S Y=$$DATE^OCXSENDD(Y) + I (Y["@") S Y=$P(Y,"@",1)_" at "_$P(Y,"@",2) + Q Y + ; +HDR(LINK,RNUM) ; + ; + N R,LINE,TEXT,RNAME,RLINK,NOW + S NOW=$$NOW + I 'LINK S RLINK=";" + E S RLINK="G ^"_$$RNAME(RNUM+1,2) + S RNAME=$$RNAME(RNUM,2),(HEADER1,HEADER2,HEADER3,HEADER4,HEADER5)=";" + ; + F LINE=1:1:999 S TEXT=$P($T(TEXT+LINE),";",2,999) Q:TEXT S TEXT=$P(TEXT,";",2,999) S R(LINE,0)=$$CONV(TEXT) + ; + M ^TMP("OCXSEND",$J,"RTN")=R + ; + Q + ; +HEX(X) Q:'X "" Q $$HEX(X\36)_$E("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ",((X#36)+1)) + ; +RNAME(X,Y) ; + ; Y=0 -> Main Routine + ; Y=1 -> Runtime Library Routine + ; Y=2 -> Data Routine for ORYppp + ; Y=3 -> Data Routine for OCXRU + ; + N OCXRN1,OCXRN2,OCXSEQ + ; + S OCXRN1="OCXRULE",OCXRN2="OCXRU" + S:$L($G(OCXPATCH)) OCXRN2="ORY"_$E((1000+$P(OCXPATCH,"*",3)),2,4),OCXRN1=OCXRN2_"ES" + ; + Q:'Y OCXRN1 + ; + I (Y=1),(X>35) Q "" + I (Y=2),'$L($G(OCXPATCH)) S Y=3 + I (Y=2),(X>1295) Q "" + I (Y=3),(X>46655) Q "" + ; + S OCXSEQ=0 S:X OCXSEQ=$$HEX(X) + S OCXSEQ="00000"_OCXSEQ + S OCXSEQ=$E(OCXSEQ,($L(OCXSEQ)-Y+1),$L(OCXSEQ)) + ; + Q OCXRN2_OCXSEQ + ; +CONV(X) ; + N VAL + F Q:'(X["|") D + .S VAL=$P(X,"|",2) + .X "S VAL="_VAL + .S X=$P(X,"|",1)_VAL_$P(X,"|",3,999) + I '(X="$"),'$L($P(X," ",2)) S X=X_" ;" + Q X + ; +TEXT ; + ;;|RNAME| ;SLC/RJS,CLA - OCX PACKAGE RULE TRANSPORT ROUTINE |OCXPATCH| ;|NOW| + ;;|OCXLIN2| + ;;|OCXLIN3| + ;; ; + ;;S ; + ;; ; + ;; D DOT^|$$RNAME^OCXSEND3(0,0)| + ;; ; + ;; ; + ;; K REMOTE,LOCAL,OPCODE,REF + ;; F LINE=1:1:500 S TEXT=$P($T(DATA+LINE),";",2,999) Q:TEXT I $L(TEXT) D Q:QUIT + ;; .S ^TMP("OCXRULE",$J,$O(^TMP("OCXRULE",$J,"A"),-1)+1)=TEXT + ;; ; + ;; |RLINK| + ;; ; + ;; Q + ;; ; + ;;DATA ; + ;1; + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSEND4.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSEND4.m index 478262dc..5edb137b 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSEND4.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSEND4.m @@ -1,120 +1,120 @@ -OCXSEND4 ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES (Build Library Routine 0) ;2/01/01 09:56 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,96,105,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; -EN() ; - ; - N R,LINE,TEXT,NOW,RUCI - S NOW=$$NOW^OCXSEND3,RUCI=$$NETNAME^OCXSEND - F LINE=1:1:999 S TEXT=$P($T(TEXT+LINE),";",2,999) Q:TEXT S TEXT=$P(TEXT,";",2,999) S R(LINE,0)=$$CONV^OCXSEND3(TEXT) - ; - M ^TMP("OCXSEND",$J,"RTN")=R - ; - S DIE="^TMP(""OCXSEND"","_$J_",""RTN"",",XCN=0,X=$$RNAME^OCXSEND3(0,1) - W !,X X ^%ZOSF("SAVE") K ^TMP("OCXSEND",$J,"RTN") - ; - Q " " - ; -TEXT ; - ;;|$$RNAME^OCXSEND3(0,1)| ;SLC/RJS,CLA - OCX PACKAGE RULE TRANSPORT ROUTINE |OCXPATCH| ;|NOW| - ;;|OCXLIN2| - ;;|OCXLIN3| - ;; ; - ;;S ; - ;; ; - ;; Q - ;; ; - ;;WARN(RTN,MSG,LINES) ; - ;; ; - ;; Q:$G(OCXAUTO) - ;; ; - ;; N DASH,LINE,NLINE,PLINE - ;; ; - ;; S DASH="",$P(DASH,"-",(55-$L(MSG)-2))="-" - ;; W !!,"--------------",MSG,DASH - ;; ; - ;; W !,RTN,?10,"[|RUCI|] -> [",$$NETNAME^OCXSEND,"] Line" - ;; ; - ;; I $O(LINES($O(LINES(0)))) W "s: " - ;; E W ": " - ;; ; - ;; S LINE=0 F S LINE=$O(LINES(LINE)) Q:'LINE D - ;; .W:($X>60) !,?40 - ;; .S NLINE=LINE F S PLINE=NLINE,NLINE=$O(LINES(NLINE)) Q:(NLINE-PLINE-1) - ;; .I (PLINE=LINE) W " ",LINE - ;; .E W " ",LINE,"-",PLINE S LINE=PLINE - ;; ; - ;; W ! Q - ;; ; - ;;TEXT(RTN,LINE) ; - ;; ; - ;; N TEXT X "S TEXT=$T(+"_(+LINE)_"^"_RTN_")" Q TEXT - ;; ; - ;;HEADER ; - ;; ; - ;; W !," Created: |NOW| at |RUCI|" - ;; W !," Current Date: ",$$NOW," at ",$$NETNAME^OCXSEND,!! - ;; S LASTFILE=0 K ^TMP("OCXRULE",$J) - ;; S ^TMP("OCXRULE",$J)=($P($H,",",2)+($H*86400)+(1*60*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG" - ;; Q - ;; ; - ;;GETFILE(FILE,RECNAME,ARRAY) ; - ;; ; - ;; N CHECK,GLNEXT,GLREF,LINES,REC,DD,FLD - ;; S REC=$$LOOKUP(FILE,RECNAME) - ;; I 'REC W !!,$$FILENAME^OCXSENDD(FILE),": ",RECNAME Q 0 - ;; I (REC=-1) W !!,$$FILENAME^OCXSENDD(FILE),": ",RECNAME," duplicate local entries.",! Q 0 - ;; I (REC=-2) W !!,$$FILENAME^OCXSENDD(FILE)," (",FILE,") local file not found." W ! Q:$$PAUSE -10 Q REC - ;; I (REC<0) W !!,$$FILENAME^OCXSENDD(FILE),": ",RECNAME," unknown lookup error." W ! Q:$$PAUSE -10 Q REC - ;; I (REC>0) D - ;; .S CHECK=0,LINES=0 - ;; .D GETREC($$FILE^OCXSENDD(FILE,"GLOBAL NAME"),"ARRAY(",REC,.ARRAY) - ;; .S GLREF="ARRAY" F S GLREF=$Q(@GLREF) Q:'$L(GLREF) Q:'($E(GLREF,1,6)="ARRAY(") K:'$L(@GLREF) @GLREF - ;; ; - ;; Q REC - ;; ; - ;;LKUPARRY(DD,KEY,ARRAY) ; - ;; ; - ;; N D0 S D0=0 F S D0=$O(ARRAY(DD,D0)) Q:'D0 Q:($G(ARRAY(DD,D0,.01,"E"))=KEY) - ;; Q D0 - ;; ; - ;;LOOKUP(FILE,KEY) ; - ;; I $O(^TMP("OCXRULE",$J,"B",FILE,KEY,0)) Q 0 - ;; N RECNAM,REC,D0,CNT,SHORT S (REC,CNT)=0 - ;; S GL=$$FILE^OCXSENDD(FILE,"GLOBAL NAME") Q:'$L(GL) -2 S GL=$E(GL,1,$L(GL)-1)_")" - ;; S SHORT=$E(KEY,1,30),RECNAM=SHORT D F S RECNAM=$O(@GL@("B",RECNAM)) Q:'$L(RECNAM) Q:'($E(RECNAM,1,$L(SHORT))=SHORT) D - ;; .S D0=0 F S D0=$O(@GL@("B",RECNAM,D0)) Q:'D0 I ($P($G(@GL@(D0,0)),U,1)=KEY) S CNT=CNT+1,REC=D0_U_RECNAME - ;; Q:(CNT>1) -1 - ;; S:$L($P(REC,U,2)) ^TMP("OCXRULE",$J,"A",FILE,$P(REC,U,2))="" - ;; Q +REC - ;; ; - ;;GETREC(GL,PATH,D0,REM) ; - ;; ; - ;; Q:'($P($G(@(GL_"0)")),U,2)) - ;; N S1,DATA,DD - ;; S DATA="" D DIQ(GL,D0,.DATA) - ;; S DD=$O(DATA(0)) Q:'DD - ;; ; - ;; I $L($$FILE^OCXSENDD(DD,"NAME")) S PATH=PATH_""""_DD_":"_D0_"""" - ;; I '$L($$FILE^OCXSENDD(DD,"NAME")) S PATH=PATH_","""_DD_":"_D0_"""" - ;; M @(PATH_")")=DATA(DD,D0) - ;; ; - ;; S S1="" F S S1=$O(@(GL_D0_","_$$SUB(S1)_")")) Q:'$L(S1) I ($D(@(GL_D0_","_$$SUB(S1)_")"))>3) D - ;; .N D1,GLREF S GLREF=GL_D0_","_$$SUB(S1)_"," - ;; .S D1=0 F S D1=$O(@(GLREF_D1_")")) Q:'D1 D GETREC(GLREF,PATH,D1,.REM) - ;; ; - ;; Q - ;; ; - ;;SUB(X) Q:'(X=+X) """"_X_"""" Q X - ;; ; - ;;DIQ(DIC,DA,OCXARY) ; - ;; N DR,DIQ S DR=".01:99999",DIQ="OCXARY(",DIQ(0)="EN" D EN^DIQ1 - ;; Q - ;; ; - ;;PAUSE() W " Press Enter " R X:DTIME W ! Q (X[U) - ;; ; - ;;NOW() N X,Y,%DT S X="N",%DT="T" D ^%DT S Y=$$DATE^OCXSENDD(Y) S:(Y["@") Y=$P(Y,"@",1)_" at "_$P(Y,"@",2) Q Y - ;; ; - ;;$ - ;1; - ; +OCXSEND4 ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES (Build Library Routine 0) ;2/01/01 09:56 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,96,105**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; +EN() ; + ; + N R,LINE,TEXT,NOW,RUCI,XCM + S NOW=$$NOW^OCXSEND3,RUCI=$$NETNAME^OCXSEND + F LINE=1:1:999 S TEXT=$P($T(TEXT+LINE),";",2,999) Q:TEXT S TEXT=$P(TEXT,";",2,999) S R(LINE,0)=$$CONV^OCXSEND3(TEXT) + ; + M ^TMP("OCXSEND",$J,"RTN")=R + ; + S DIE="^TMP(""OCXSEND"","_$J_",""RTN"",",XCN=0,X=$$RNAME^OCXSEND3(0,1) + W !,X X ^%ZOSF("SAVE") W " ... ",XCM," Lines filed" K ^TMP("OCXSEND",$J,"RTN") + ; + Q XCM + ; +TEXT ; + ;;|$$RNAME^OCXSEND3(0,1)| ;SLC/RJS,CLA - OCX PACKAGE RULE TRANSPORT ROUTINE |OCXPATCH| ;|NOW| + ;;|OCXLIN2| + ;;|OCXLIN3| + ;; ; + ;;S ; + ;; ; + ;; Q + ;; ; + ;;WARN(RTN,MSG,LINES) ; + ;; ; + ;; Q:$G(OCXAUTO) + ;; ; + ;; N DASH,LINE,NLINE,PLINE + ;; ; + ;; S DASH="",$P(DASH,"-",(55-$L(MSG)-2))="-" + ;; W !!,"--------------",MSG,DASH + ;; ; + ;; W !,RTN,?10,"[|RUCI|] -> [",$$NETNAME^OCXSEND,"] Line" + ;; ; + ;; I $O(LINES($O(LINES(0)))) W "s: " + ;; E W ": " + ;; ; + ;; S LINE=0 F S LINE=$O(LINES(LINE)) Q:'LINE D + ;; .W:($X>60) !,?40 + ;; .S NLINE=LINE F S PLINE=NLINE,NLINE=$O(LINES(NLINE)) Q:(NLINE-PLINE-1) + ;; .I (PLINE=LINE) W " ",LINE + ;; .E W " ",LINE,"-",PLINE S LINE=PLINE + ;; ; + ;; W ! Q + ;; ; + ;;TEXT(RTN,LINE) ; + ;; ; + ;; N TEXT X "S TEXT=$T(+"_(+LINE)_"^"_RTN_")" Q TEXT + ;; ; + ;;HEADER ; + ;; ; + ;; W !," Created: |NOW| at |RUCI|" + ;; W !," Current Date: ",$$NOW," at ",$$NETNAME^OCXSEND,!! + ;; S LASTFILE=0 K ^TMP("OCXRULE",$J) + ;; S ^TMP("OCXRULE",$J)=($P($H,",",2)+($H*86400)+(1*60*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG" + ;; Q + ;; ; + ;;GETFILE(FILE,RECNAME,ARRAY) ; + ;; ; + ;; N CHECK,GLNEXT,GLREF,LINES,REC,DD,FLD + ;; S REC=$$LOOKUP(FILE,RECNAME) + ;; I 'REC W !!,$$FILENAME^OCXSENDD(FILE),": ",RECNAME Q 0 + ;; I (REC=-1) W !!,$$FILENAME^OCXSENDD(FILE),": ",RECNAME," duplicate local entries.",! Q 0 + ;; I (REC=-2) W !!,$$FILENAME^OCXSENDD(FILE)," (",FILE,") local file not found." W ! Q:$$PAUSE -10 Q REC + ;; I (REC<0) W !!,$$FILENAME^OCXSENDD(FILE),": ",RECNAME," unknown lookup error." W ! Q:$$PAUSE -10 Q REC + ;; I (REC>0) D + ;; .S CHECK=0,LINES=0 + ;; .D GETREC($$FILE^OCXSENDD(FILE,"GLOBAL NAME"),"ARRAY(",REC,.ARRAY) + ;; .S GLREF="ARRAY" F S GLREF=$Q(@GLREF) Q:'$L(GLREF) Q:'($E(GLREF,1,6)="ARRAY(") K:'$L(@GLREF) @GLREF + ;; ; + ;; Q REC + ;; ; + ;;LKUPARRY(DD,KEY,ARRAY) ; + ;; ; + ;; N D0 S D0=0 F S D0=$O(ARRAY(DD,D0)) Q:'D0 Q:($G(ARRAY(DD,D0,.01,"E"))=KEY) + ;; Q D0 + ;; ; + ;;LOOKUP(FILE,KEY) ; + ;; I $O(^TMP("OCXRULE",$J,"B",FILE,KEY,0)) Q 0 + ;; N RECNAM,REC,D0,CNT,SHORT S (REC,CNT)=0 + ;; S GL=$$FILE^OCXSENDD(FILE,"GLOBAL NAME") Q:'$L(GL) -2 S GL=$E(GL,1,$L(GL)-1)_")" + ;; S SHORT=$E(KEY,1,30),RECNAM=SHORT D F S RECNAM=$O(@GL@("B",RECNAM)) Q:'$L(RECNAM) Q:'($E(RECNAM,1,$L(SHORT))=SHORT) D + ;; .S D0=0 F S D0=$O(@GL@("B",RECNAM,D0)) Q:'D0 I ($P($G(@GL@(D0,0)),U,1)=KEY) S CNT=CNT+1,REC=D0_U_RECNAME + ;; Q:(CNT>1) -1 + ;; S:$L($P(REC,U,2)) ^TMP("OCXRULE",$J,"A",FILE,$P(REC,U,2))="" + ;; Q +REC + ;; ; + ;;GETREC(GL,PATH,D0,REM) ; + ;; ; + ;; Q:'($P($G(@(GL_"0)")),U,2)) + ;; N S1,DATA,DD + ;; S DATA="" D DIQ(GL,D0,.DATA) + ;; S DD=$O(DATA(0)) Q:'DD + ;; ; + ;; I $L($$FILE^OCXSENDD(DD,"NAME")) S PATH=PATH_""""_DD_":"_D0_"""" + ;; I '$L($$FILE^OCXSENDD(DD,"NAME")) S PATH=PATH_","""_DD_":"_D0_"""" + ;; M @(PATH_")")=DATA(DD,D0) + ;; ; + ;; S S1="" F S S1=$O(@(GL_D0_","_$$SUB(S1)_")")) Q:'$L(S1) I ($D(@(GL_D0_","_$$SUB(S1)_")"))>3) D + ;; .N D1,GLREF S GLREF=GL_D0_","_$$SUB(S1)_"," + ;; .S D1=0 F S D1=$O(@(GLREF_D1_")")) Q:'D1 D GETREC(GLREF,PATH,D1,.REM) + ;; ; + ;; Q + ;; ; + ;;SUB(X) Q:'(X=+X) """"_X_"""" Q X + ;; ; + ;;DIQ(DIC,DA,OCXARY) ; + ;; N DR,DIQ S DR=".01:99999",DIQ="OCXARY(",DIQ(0)="EN" D EN^DIQ1 + ;; Q + ;; ; + ;;PAUSE() W " Press Enter " R X:DTIME W ! Q (X[U) + ;; ; + ;;NOW() N X,Y,%DT S X="N",%DT="T" D ^%DT S Y=$$DATE^OCXSENDD(Y) S:(Y["@") Y=$P(Y,"@",1)_" at "_$P(Y,"@",2) Q Y + ;; ; + ;;$ + ;1; + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSEND5.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSEND5.m index 41638325..02b631b2 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSEND5.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSEND5.m @@ -1,193 +1,193 @@ -OCXSEND5 ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES (Build Library Routine 1) ;2/01/01 09:56 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,96,105,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; -EN() ; - ; - N R,LINE,TEXT,NOW,RUCI - S NOW=$$NOW^OCXSEND3,RUCI=$$NETNAME^OCXSEND - F LINE=1:1:999 S TEXT=$P($T(TEXT+LINE),";",2,999) Q:TEXT S TEXT=$P(TEXT,";",2,999) S R(LINE,0)=$$CONV^OCXSEND3(TEXT) - ; - M ^TMP("OCXSEND",$J,"RTN")=R - ; - S DIE="^TMP(""OCXSEND"","_$J_",""RTN"",",XCN=0,X=$$RNAME^OCXSEND3(1,1) - W !,X X ^%ZOSF("SAVE") K ^TMP("OCXSEND",$J,"RTN") - ; - Q " " - ; -TEXT ; - ;;|$$RNAME^OCXSEND3(1,1)| ;SLC/RJS,CLA - OCX PACKAGE RULE TRANSPORT ROUTINE |OCXPATCH| ;|NOW| - ;;|OCXLIN2| - ;;|OCXLIN3| - ;; ; - ;;S ; - ;; ; - ;; Q - ;; ; - ;; ; - ;;COMPARE(L,R) ; - ;; ; - ;; Q:$$RES("R") 1 - ;; ; - ;; Q:'$L($O(L(""))) $$ADDREC^|$$RNAME^OCXSEND3(2,1)|("R") - ;; ; - ;; N C,OCXDD M C=L,C=R S OCXDD=$O(C("")) Q $$MULT("C",OCXDD) - ;; ; - ;; Q 0 - ;; ; - ;;RES(REF) ; - ;; ; - ;; N QUIT,SUB - ;; S QUIT=0 - ;; S SUB="" F S SUB=$O(@REF@(SUB)) Q:'$L(SUB) I (SUB[":") D Q:QUIT - ;; .N DD,DA - ;; .S DD=$P(SUB,":",1),DA=$P(SUB,":",2) - ;; .I $L(DA),'(DA=+DA) D Q:QUIT - ;; ..N DANEW,SUBNEW - ;; ..S DANEW=$O(^OCXS($P(DA,U,2),"B",$P(DA,U,1),0)) - ;; ..I 'DANEW W !!,$P($G(^OCXS(+$P(DA,U,2),0)),U,1),": ",$P(DA,U,1)," could not resolve name.",!!," End Transport." S QUIT=1 Q - ;; ..S SUBNEW=DD_":"_DANEW - ;; ..I $D(@REF@(SUBNEW)) W !!," multiple #",DANEW," already existed." S QUIT=1 Q - ;; ..M @REF@(SUBNEW)=@REF@(SUB) - ;; ..K @REF@(SUB) - ;; ..S SUB="" - ;; .I $L(SUB),($D(@REF@(SUB))>9) S QUIT=$$RES($NA(@REF@(SUB))) - ;; ; - ;; Q QUIT - ;; ; - ;;MULT(CREF,OCXDD) ; - ;; ; - ;; N OCXSUB,LREF,RREF,QUIT,OCXFLD - ;; S LREF="L"_$E(CREF,2,$L(CREF)),RREF="R"_$E(CREF,2,$L(CREF)) - ;; ; - ;; S QUIT=0,OCXFLD="" F S OCXFLD=$O(@CREF@(OCXDD,OCXFLD)) Q:'$L(OCXFLD) D Q:QUIT - ;; .I (OCXFLD[":") D Q:QUIT - ;; ..Q:$$EXFLD(+OCXFLD,0) - ;; ..I '$D(@LREF@(OCXDD,OCXFLD,.01,"E")) D M @LREF@(OCXDD,OCXFLD)=@RREF@(OCXDD,OCXFLD) - ;; ...D WARN("Missing multiple:",CREF,OCXDD,OCXFLD) - ;; ...S QUIT=$$ADDMULT^|$$RNAME^OCXSEND3(3,1)|(CREF,OCXDD,OCXFLD) - ;; ..I '$D(@RREF@(OCXDD,OCXFLD,.01,"E")) D M @RREF@(OCXDD,OCXFLD)=@LREF@(OCXDD,OCXFLD) - ;; ...D WARN("Extra multiple:",CREF,OCXDD,OCXFLD) - ;; ...S QUIT=$$DELMULT^|$$RNAME^OCXSEND3(3,1)|($$APPEND(CREF,OCXDD),OCXFLD) - ;; .; - ;; .I (OCXFLD=+OCXFLD),'$$EXFLD(+OCXDD,OCXFLD) D - ;; ..I ($O(@CREF@(OCXDD,OCXFLD,""))="E") D Q - ;; ...I $L($G(@RREF@(OCXDD,OCXFLD,"E"))),'$L($G(@LREF@(OCXDD,OCXFLD,"E"))) D Q - ;; ....D WARN("Data Value Missing in "_$$NETNAME^OCXSEND,CREF,OCXDD,OCXFLD,"E") - ;; ....S QUIT=$$EDITFLD^|$$RNAME^OCXSEND3(4,1)|(CREF,OCXDD,OCXFLD,"E") - ;; ...I $L($G(@LREF@(OCXDD,OCXFLD,"E"))),'$L($G(@RREF@(OCXDD,OCXFLD,"E"))) D Q - ;; ....D WARN("Extra Data Value in "_$$NETNAME^OCXSEND,CREF,OCXDD,OCXFLD,"E") - ;; ....S QUIT=$$DELFLD^|$$RNAME^OCXSEND3(4,1)|(CREF,OCXDD,OCXFLD,"E") - ;; ...I '(@LREF@(OCXDD,OCXFLD,"E")=@RREF@(OCXDD,OCXFLD,"E")) D - ;; ....D WARN("Inconsistent Data",CREF,OCXDD,OCXFLD,"E") - ;; ....S QUIT=$$EDITFLD^|$$RNAME^OCXSEND3(4,1)|(CREF,OCXDD,OCXFLD,"E") - ;; ..S OCXSUB=0 F Q:QUIT S OCXSUB=$O(@CREF@(OCXDD,OCXFLD,OCXSUB)) Q:'OCXSUB I '($G(@RREF@(OCXDD,OCXFLD,OCXSUB))=$G(@LREF@(OCXDD,OCXFLD,OCXSUB))) D Q - ;; ...D WARN("Inconsistent word Data",CREF,OCXDD,OCXFLD,OCXSUB) - ;; ...S QUIT=$$LOADWORD^|$$RNAME^OCXSEND3(2,1)|(RREF,OCXDD,OCXFLD,OCXSUB) - ;; .; - ;; .I 'QUIT,(OCXFLD[":") S QUIT=$$MULT($$APPEND(CREF,OCXDD),OCXFLD) - ;; Q QUIT - ;; ; - ;;APPEND(ARRAY,OCXSUB) ; - ;; S:'(OCXSUB=+OCXSUB) OCXSUB=""""_OCXSUB_"""" - ;; Q:'(ARRAY["(") ARRAY_"("_OCXSUB_")" - ;; Q $E(ARRAY,1,$L(ARRAY)-1)_","_OCXSUB_")" - ;; ; - ;;EXFLD(FILE,OCXFLD) ; - ;; N OCXFNAM - ;; S OCXFNAM=$$FIELD^OCXSENDD(FILE,OCXFLD,"LABEL") - ;; I (OCXFNAM["UNIQUE OBJECT IDENTIFIER") Q 1 - ;; I (FILE=860.2),(OCXFLD=.02) Q 1 - ;; I (FILE=860.22),(OCXFLD=4) Q 1 - ;; I (FILE=860.3),(OCXFLD=3) Q 1 - ;; I (FILE=860.9),(OCXFLD=1) Q 1 - ;; I (FILE=860.91) Q 1 - ;; I (FILE=860.801) Q 1 - ;; I (FILE=860.81) Q 1 - ;; I (FILE=861.01) Q 1 - ;; I (FILE=863.02) Q 1 - ;; I (FILE=863.54) Q 1 - ;; I (FILE=863.61) Q 1 - ;; I (FILE=863.72) Q 1 - ;; I (FILE=863.81) Q 1 - ;; I ($E(OCXFNAM,1)="*") Q 1 - ;; Q 0 - ;; ; - ;;WARN(MSG,CREF,OCXDD,OCXFLD,OCXSUB) ; - ;; ; - ;; Q:$G(OCXAUTO) - ;; ; - ;; N D0,DASH,OCXDDPTH,OCXDPTR,FILE,FILEID,LREF,OCXPTR,RREF - ;; ; - ;; S DASH="",$P(DASH,"-",(55-$L(MSG)))="-" - ;; W !!,"------------",MSG,DASH - ;; D DSPHDR(CREF,OCXDD,OCXFLD) - ;; I $D(OCXSUB) D DSPFLD(CREF,OCXDD,OCXFLD,OCXSUB) - ;; I '$D(OCXSUB) D DSPREC(CREF,OCXDD,OCXFLD) - ;; ; - ;; W ! Q - ;; ; - ;;DSPREC(CREF,OCXDD,OCXFLD) ; - ;; ; - ;; N OCXDPTR,OCXDDPTH,LEVL,OCXCREF,OCXSUB - ;; S OCXCREF=$$APPEND($$APPEND(CREF,OCXDD),OCXFLD) - ;; S OCXDDPTH=$P($P(OCXCREF,"(",2),")",1),LEVL=$L(OCXDDPTH,",") - ;; S OCXSUB="" F S OCXSUB=$O(@OCXCREF@(OCXSUB)) Q:'$L(OCXSUB) D - ;; .; - ;; .I '(OCXSUB[":"),'((OCXSUB=.01)&$O(@OCXCREF@(OCXSUB))) D - ;; ..N LINE - ;; ..Q:$$EXFLD(+OCXFLD,OCXSUB) - ;; ..I OCXFLD W !,?(5+((LEVL)*4)),$$FIELD^OCXSENDD(+OCXFLD,OCXSUB,"LABEL"),": ",$G(@OCXCREF@(OCXSUB,"E")) - ;; ..S LINE=0 F S LINE=$O(@OCXCREF@(OCXSUB,LINE)) Q:'LINE D - ;; ...W !,?(5+(LEVL*4)),$J(LINE,3),">",@OCXCREF@(OCXSUB,LINE) - ;; .; - ;; .I (OCXSUB[":") D - ;; ..N D0,OCXDD,FILENAME - ;; ..S D0=+$P(OCXSUB,":",2),OCXDD=+OCXSUB - ;; ..S FILENAME=$$FILENAME^OCXSENDD(OCXDD) - ;; ..I $L(FILENAME) W !,?(5+($L(LEVL)*4)),FILENAME - ;; ..E W !!,?(5+(LEVL*4)),FILENAME - ;; ..W " ",D0,": ",$G(@OCXCREF@(OCXSUB,.01,"E")) - ;; ..D DSPREC($$APPEND(CREF,OCXDD),OCXFLD,OCXSUB) - ;; ; - ;; Q - ;; ; - ;;DSPHDR(CREF,OCXDD,OCXFLD) ; - ;; ; - ;; N D0,FILE,FILEID,OCXPTR,OCXDDPTH - ;; S OCXDDPTH=$P($P($$APPEND($$APPEND(CREF,OCXDD),OCXFLD),"(",2),")",1) - ;; S FILE="" F OCXPTR=1:1:$L(OCXDDPTH,",") D - ;; .N OCXDD,D0,FILEID - ;; .S FILEID=$P(OCXDDPTH,",",OCXPTR) - ;; .I (FILEID[":") D - ;; ..S D0=+$P(FILEID,":",2),OCXDD=+$E(FILEID,2,$L(FILEID)) - ;; ..W !,?(5+(OCXPTR*4)),$$FILENAME^OCXSENDD(OCXDD) - ;; ..S:$L(FILE) FILE=FILE_"," S FILE=FILE_FILEID - ;; ..I $D(@("L("_FILE_",.01,""E"")")) W ": ",@("L("_FILE_",.01,""E"")") W:D0 " [",D0,"]" - ;; ..E I $D(@("R("_FILE_",.01,""E"")")) W ": ",@("R("_FILE_",.01,""E"")") W:D0 " [",D0,"]" - ;; ; - ;; Q - ;; ; - ;;DSPFLD(CREF,OCXDD,OCXFLD,OCXSUB) ; - ;; ; - ;; N OCXDPTR,LREF,RREF,OCXDDPTH - ;; ; - ;; S OCXDDPTH=$P($P($$APPEND(CREF,OCXDD),"(",2),")",1) - ;; S LREF="L("_OCXDDPTH_")",RREF="R("_OCXDDPTH_")" - ;; W !,?(5+(($L(OCXDDPTH,",")+1)*4)),$$FIELD^OCXSENDD(OCXDD,OCXFLD,"LABEL")," field [",OCXFLD,"]" - ;; I OCXSUB W " Line #",OCXSUB - ;; ; - ;; W:($D(@RREF@(OCXFLD,OCXSUB))) !,?(5+(($L(OCXDDPTH,",")+2)*4)),"(R) |RUCI|: ",@RREF@(OCXFLD,OCXSUB) - ;; W:($D(@LREF@(OCXFLD,OCXSUB))) !,?(5+(($L(OCXDDPTH,",")+2)*4)),"(L) ",$$NETNAME^OCXSEND,": ",@LREF@(OCXFLD,OCXSUB) - ;; ; - ;; Q - ;; ; - ;; W !,?10 Q 0 Q $$PAUSE - ;; ; - ;;PAUSE() W " Press Enter " R X:DTIME W ! Q (X[U) - ;; ; - ;;NOW() N X,Y,%DT S X="N",%DT="T" D ^%DT S Y=$$DATE^OCXSENDD(Y) S:(Y["@") Y=$P(Y,"@",1)_" at "_$P(Y,"@",2) Q Y - ;; ; - ;;$ - ;1; - ; +OCXSEND5 ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES (Build Library Routine 1) ;2/01/01 09:56 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,96,105**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; +EN() ; + ; + N R,LINE,TEXT,NOW,RUCI,XCM + S NOW=$$NOW^OCXSEND3,RUCI=$$NETNAME^OCXSEND + F LINE=1:1:999 S TEXT=$P($T(TEXT+LINE),";",2,999) Q:TEXT S TEXT=$P(TEXT,";",2,999) S R(LINE,0)=$$CONV^OCXSEND3(TEXT) + ; + M ^TMP("OCXSEND",$J,"RTN")=R + ; + S DIE="^TMP(""OCXSEND"","_$J_",""RTN"",",XCN=0,X=$$RNAME^OCXSEND3(1,1) + W !,X X ^%ZOSF("SAVE") W " ... ",XCM," Lines filed" K ^TMP("OCXSEND",$J,"RTN") + ; + Q XCM + ; +TEXT ; + ;;|$$RNAME^OCXSEND3(1,1)| ;SLC/RJS,CLA - OCX PACKAGE RULE TRANSPORT ROUTINE |OCXPATCH| ;|NOW| + ;;|OCXLIN2| + ;;|OCXLIN3| + ;; ; + ;;S ; + ;; ; + ;; Q + ;; ; + ;; ; + ;;COMPARE(L,R) ; + ;; ; + ;; Q:$$RES("R") 1 + ;; ; + ;; Q:'$L($O(L(""))) $$ADDREC^|$$RNAME^OCXSEND3(2,1)|("R") + ;; ; + ;; N C,OCXDD M C=L,C=R S OCXDD=$O(C("")) Q $$MULT("C",OCXDD) + ;; ; + ;; Q 0 + ;; ; + ;;RES(REF) ; + ;; ; + ;; N QUIT,SUB + ;; S QUIT=0 + ;; S SUB="" F S SUB=$O(@REF@(SUB)) Q:'$L(SUB) I (SUB[":") D Q:QUIT + ;; .N DD,DA + ;; .S DD=$P(SUB,":",1),DA=$P(SUB,":",2) + ;; .I $L(DA),'(DA=+DA) D Q:QUIT + ;; ..N DANEW,SUBNEW + ;; ..S DANEW=$O(^OCXS($P(DA,U,2),"B",$P(DA,U,1),0)) + ;; ..I 'DANEW W !!,$P($G(^OCXS(+$P(DA,U,2),0)),U,1),": ",$P(DA,U,1)," could not resolve name.",!!," End Transport." S QUIT=1 Q + ;; ..S SUBNEW=DD_":"_DANEW + ;; ..I $D(@REF@(SUBNEW)) W !!," multiple #",DANEW," already existed." S QUIT=1 Q + ;; ..M @REF@(SUBNEW)=@REF@(SUB) + ;; ..K @REF@(SUB) + ;; ..S SUB="" + ;; .I $L(SUB),($D(@REF@(SUB))>9) S QUIT=$$RES($NA(@REF@(SUB))) + ;; ; + ;; Q QUIT + ;; ; + ;;MULT(CREF,OCXDD) ; + ;; ; + ;; N OCXSUB,LREF,RREF,QUIT,OCXFLD + ;; S LREF="L"_$E(CREF,2,$L(CREF)),RREF="R"_$E(CREF,2,$L(CREF)) + ;; ; + ;; S QUIT=0,OCXFLD="" F S OCXFLD=$O(@CREF@(OCXDD,OCXFLD)) Q:'$L(OCXFLD) D Q:QUIT + ;; .I (OCXFLD[":") D Q:QUIT + ;; ..Q:$$EXFLD(+OCXFLD,0) + ;; ..I '$D(@LREF@(OCXDD,OCXFLD,.01,"E")) D M @LREF@(OCXDD,OCXFLD)=@RREF@(OCXDD,OCXFLD) + ;; ...D WARN("Missing multiple:",CREF,OCXDD,OCXFLD) + ;; ...S QUIT=$$ADDMULT^|$$RNAME^OCXSEND3(3,1)|(CREF,OCXDD,OCXFLD) + ;; ..I '$D(@RREF@(OCXDD,OCXFLD,.01,"E")) D M @RREF@(OCXDD,OCXFLD)=@LREF@(OCXDD,OCXFLD) + ;; ...D WARN("Extra multiple:",CREF,OCXDD,OCXFLD) + ;; ...S QUIT=$$DELMULT^|$$RNAME^OCXSEND3(3,1)|($$APPEND(CREF,OCXDD),OCXFLD) + ;; .; + ;; .I (OCXFLD=+OCXFLD),'$$EXFLD(+OCXDD,OCXFLD) D + ;; ..I ($O(@CREF@(OCXDD,OCXFLD,""))="E") D Q + ;; ...I $L($G(@RREF@(OCXDD,OCXFLD,"E"))),'$L($G(@LREF@(OCXDD,OCXFLD,"E"))) D Q + ;; ....D WARN("Data Value Missing in "_$$NETNAME^OCXSEND,CREF,OCXDD,OCXFLD,"E") + ;; ....S QUIT=$$EDITFLD^|$$RNAME^OCXSEND3(4,1)|(CREF,OCXDD,OCXFLD,"E") + ;; ...I $L($G(@LREF@(OCXDD,OCXFLD,"E"))),'$L($G(@RREF@(OCXDD,OCXFLD,"E"))) D Q + ;; ....D WARN("Extra Data Value in "_$$NETNAME^OCXSEND,CREF,OCXDD,OCXFLD,"E") + ;; ....S QUIT=$$DELFLD^|$$RNAME^OCXSEND3(4,1)|(CREF,OCXDD,OCXFLD,"E") + ;; ...I '(@LREF@(OCXDD,OCXFLD,"E")=@RREF@(OCXDD,OCXFLD,"E")) D + ;; ....D WARN("Inconsistent Data",CREF,OCXDD,OCXFLD,"E") + ;; ....S QUIT=$$EDITFLD^|$$RNAME^OCXSEND3(4,1)|(CREF,OCXDD,OCXFLD,"E") + ;; ..S OCXSUB=0 F Q:QUIT S OCXSUB=$O(@CREF@(OCXDD,OCXFLD,OCXSUB)) Q:'OCXSUB I '($G(@RREF@(OCXDD,OCXFLD,OCXSUB))=$G(@LREF@(OCXDD,OCXFLD,OCXSUB))) D Q + ;; ...D WARN("Inconsistent word Data",CREF,OCXDD,OCXFLD,OCXSUB) + ;; ...S QUIT=$$LOADWORD^|$$RNAME^OCXSEND3(2,1)|(RREF,OCXDD,OCXFLD,OCXSUB) + ;; .; + ;; .I 'QUIT,(OCXFLD[":") S QUIT=$$MULT($$APPEND(CREF,OCXDD),OCXFLD) + ;; Q QUIT + ;; ; + ;;APPEND(ARRAY,OCXSUB) ; + ;; S:'(OCXSUB=+OCXSUB) OCXSUB=""""_OCXSUB_"""" + ;; Q:'(ARRAY["(") ARRAY_"("_OCXSUB_")" + ;; Q $E(ARRAY,1,$L(ARRAY)-1)_","_OCXSUB_")" + ;; ; + ;;EXFLD(FILE,OCXFLD) ; + ;; N OCXFNAM + ;; S OCXFNAM=$$FIELD^OCXSENDD(FILE,OCXFLD,"LABEL") + ;; I (OCXFNAM["UNIQUE OBJECT IDENTIFIER") Q 1 + ;; I (FILE=860.2),(OCXFLD=.02) Q 1 + ;; I (FILE=860.22),(OCXFLD=4) Q 1 + ;; I (FILE=860.3),(OCXFLD=3) Q 1 + ;; I (FILE=860.9),(OCXFLD=1) Q 1 + ;; I (FILE=860.91) Q 1 + ;; I (FILE=860.801) Q 1 + ;; I (FILE=860.81) Q 1 + ;; I (FILE=861.01) Q 1 + ;; I (FILE=863.02) Q 1 + ;; I (FILE=863.54) Q 1 + ;; I (FILE=863.61) Q 1 + ;; I (FILE=863.72) Q 1 + ;; I (FILE=863.81) Q 1 + ;; I ($E(OCXFNAM,1)="*") Q 1 + ;; Q 0 + ;; ; + ;;WARN(MSG,CREF,OCXDD,OCXFLD,OCXSUB) ; + ;; ; + ;; Q:$G(OCXAUTO) + ;; ; + ;; N D0,DASH,OCXDDPTH,OCXDPTR,FILE,FILEID,LREF,OCXPTR,RREF + ;; ; + ;; S DASH="",$P(DASH,"-",(55-$L(MSG)))="-" + ;; W !!,"------------",MSG,DASH + ;; D DSPHDR(CREF,OCXDD,OCXFLD) + ;; I $D(OCXSUB) D DSPFLD(CREF,OCXDD,OCXFLD,OCXSUB) + ;; I '$D(OCXSUB) D DSPREC(CREF,OCXDD,OCXFLD) + ;; ; + ;; W ! Q + ;; ; + ;;DSPREC(CREF,OCXDD,OCXFLD) ; + ;; ; + ;; N OCXDPTR,OCXDDPTH,LEVL,OCXCREF,OCXSUB + ;; S OCXCREF=$$APPEND($$APPEND(CREF,OCXDD),OCXFLD) + ;; S OCXDDPTH=$P($P(OCXCREF,"(",2),")",1),LEVL=$L(OCXDDPTH,",") + ;; S OCXSUB="" F S OCXSUB=$O(@OCXCREF@(OCXSUB)) Q:'$L(OCXSUB) D + ;; .; + ;; .I '(OCXSUB[":"),'((OCXSUB=.01)&$O(@OCXCREF@(OCXSUB))) D + ;; ..N LINE + ;; ..Q:$$EXFLD(+OCXFLD,OCXSUB) + ;; ..I OCXFLD W !,?(5+((LEVL)*4)),$$FIELD^OCXSENDD(+OCXFLD,OCXSUB,"LABEL"),": ",$G(@OCXCREF@(OCXSUB,"E")) + ;; ..S LINE=0 F S LINE=$O(@OCXCREF@(OCXSUB,LINE)) Q:'LINE D + ;; ...W !,?(5+(LEVL*4)),$J(LINE,3),">",@OCXCREF@(OCXSUB,LINE) + ;; .; + ;; .I (OCXSUB[":") D + ;; ..N D0,OCXDD,FILENAME + ;; ..S D0=+$P(OCXSUB,":",2),OCXDD=+OCXSUB + ;; ..S FILENAME=$$FILENAME^OCXSENDD(OCXDD) + ;; ..I $L(FILENAME) W !,?(5+($L(LEVL)*4)),FILENAME + ;; ..E W !!,?(5+(LEVL*4)),FILENAME + ;; ..W " ",D0,": ",$G(@OCXCREF@(OCXSUB,.01,"E")) + ;; ..D DSPREC($$APPEND(CREF,OCXDD),OCXFLD,OCXSUB) + ;; ; + ;; Q + ;; ; + ;;DSPHDR(CREF,OCXDD,OCXFLD) ; + ;; ; + ;; N D0,FILE,FILEID,OCXPTR,OCXDDPTH + ;; S OCXDDPTH=$P($P($$APPEND($$APPEND(CREF,OCXDD),OCXFLD),"(",2),")",1) + ;; S FILE="" F OCXPTR=1:1:$L(OCXDDPTH,",") D + ;; .N OCXDD,D0,FILEID + ;; .S FILEID=$P(OCXDDPTH,",",OCXPTR) + ;; .I (FILEID[":") D + ;; ..S D0=+$P(FILEID,":",2),OCXDD=+$E(FILEID,2,$L(FILEID)) + ;; ..W !,?(5+(OCXPTR*4)),$$FILENAME^OCXSENDD(OCXDD) + ;; ..S:$L(FILE) FILE=FILE_"," S FILE=FILE_FILEID + ;; ..I $D(@("L("_FILE_",.01,""E"")")) W ": ",@("L("_FILE_",.01,""E"")") W:D0 " [",D0,"]" + ;; ..E I $D(@("R("_FILE_",.01,""E"")")) W ": ",@("R("_FILE_",.01,""E"")") W:D0 " [",D0,"]" + ;; ; + ;; Q + ;; ; + ;;DSPFLD(CREF,OCXDD,OCXFLD,OCXSUB) ; + ;; ; + ;; N OCXDPTR,LREF,RREF,OCXDDPTH + ;; ; + ;; S OCXDDPTH=$P($P($$APPEND(CREF,OCXDD),"(",2),")",1) + ;; S LREF="L("_OCXDDPTH_")",RREF="R("_OCXDDPTH_")" + ;; W !,?(5+(($L(OCXDDPTH,",")+1)*4)),$$FIELD^OCXSENDD(OCXDD,OCXFLD,"LABEL")," field [",OCXFLD,"]" + ;; I OCXSUB W " Line #",OCXSUB + ;; ; + ;; W:($D(@RREF@(OCXFLD,OCXSUB))) !,?(5+(($L(OCXDDPTH,",")+2)*4)),"(R) |RUCI|: ",@RREF@(OCXFLD,OCXSUB) + ;; W:($D(@LREF@(OCXFLD,OCXSUB))) !,?(5+(($L(OCXDDPTH,",")+2)*4)),"(L) ",$$NETNAME^OCXSEND,": ",@LREF@(OCXFLD,OCXSUB) + ;; ; + ;; Q + ;; ; + ;; W !,?10 Q 0 Q $$PAUSE + ;; ; + ;;PAUSE() W " Press Enter " R X:DTIME W ! Q (X[U) + ;; ; + ;;NOW() N X,Y,%DT S X="N",%DT="T" D ^%DT S Y=$$DATE^OCXSENDD(Y) S:(Y["@") Y=$P(Y,"@",1)_" at "_$P(Y,"@",2) Q Y + ;; ; + ;;$ + ;1; + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSEND6.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSEND6.m index 883cd3b3..7e93392a 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSEND6.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSEND6.m @@ -1,162 +1,162 @@ -OCXSEND6 ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES (Build Library Routine 2) ;2/01/01 10:03 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,76,74,96,105,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; -EN() ; - ; - N R,LINE,TEXT,NOW,RUCI - S NOW=$$NOW^OCXSEND3,RUCI=$$NETNAME^OCXSEND - F LINE=1:1:999 S TEXT=$P($T(TEXT+LINE),";",2,999) Q:TEXT S TEXT=$P(TEXT,";",2,999) S R(LINE,0)=$$CONV^OCXSEND3(TEXT) - ; - M ^TMP("OCXSEND",$J,"RTN")=R - ; - S DIE="^TMP(""OCXSEND"","_$J_",""RTN"",",XCN=0,X=$$RNAME^OCXSEND3(2,1) - W !,X X ^%ZOSF("SAVE") K ^TMP("OCXSEND",$J,"RTN") - ; - Q " " - ; -TEXT ; - ;;|$$RNAME^OCXSEND3(2,1)| ;SLC/RJS,CLA - OCX PACKAGE RULE TRANSPORT ROUTINE |OCXPATCH| ;|NOW| - ;;|OCXLIN2| - ;;|OCXLIN3| - ;; ; - ;;S ; - ;; ; Record Utilities - ;; Q - ;; ; - ;;ADDREC(OCXCREF) ; - ;; ; - ;; N QUIT,OCXDD,OCXDA,OCXGREF,OCXNAME - ;; S OCXDD=$O(@OCXCREF@("")) Q:'OCXDD 0 - ;; S OCXNAME=$G(@OCXCREF@(OCXDD,.01,"E")) - ;; ; - ;; W " record missing..." - ;; I (OCXFLAG["D") Q 0 - ;; ; - ;; S OCXDA=0 D CREATE(OCXCREF,OCXDD,.OCXDA,0) - ;; S:$L(OCXNAME) ^TMP("OCXRULE",$J,"A",+OCXDD,OCXNAME)="" - ;; ; - ;; Q 0 - ;; ; - ;;CREATE(OCXCREF,OCXDD,OCXDA,OCXLVL) ; - ;; ; - ;; N OCXFLD,OCXGREF,OCXKEY - ;; ; - ;; I $L(OCXDA),'(OCXDA=+OCXDA) W !!,"Unresolved subscript." Q - ;; ; - ;; S OCXKEY=@OCXCREF@(OCXDD,.01,"E") - ;; S OCXGREF=$$GETREF(+OCXDD,.OCXDA,OCXLVL) Q:'$L(OCXGREF) - ;; I 'OCXDA D - ;; .S OCXDA=$O(^TMP("OCXRULE",$J,"B",+OCXDD,OCXKEY,0)) Q:OCXDA - ;; .S OCXDA=$O(@(OCXGREF_""" "")"),-1)+1 - ;; .F OCXDA=OCXDA:1 Q:'$D(@(OCXGREF_OCXDA_",0)")) - ;; .I $D(@(OCXGREF_OCXDA_",0)")) S OCXDA=0 - ;; ; - ;; I 'OCXDA W !!,"Error adding record..." Q - ;; ; - ;; I '$D(@(OCXGREF_"0)")) S @(OCXGREF_"0)")=U_$$FILEHDR^OCXSENDD(+OCXDD)_U_U - ;; ; - ;; S OCXFLD=0 F S OCXFLD=$O(@OCXCREF@(OCXDD,OCXFLD)) Q:'OCXFLD Q:(OCXFLD[":") I '$$EXFLD^|$$RNAME^OCXSEND3(1,1)|(+OCXDD,OCXFLD) D - ;; .I $L($G(@OCXCREF@(OCXDD,OCXFLD,"E"))) D DIE(OCXDD,OCXGREF,OCXFLD,@OCXCREF@(OCXDD,OCXFLD,"E"),.OCXDA,OCXLVL) - ;; .I $O(@OCXCREF@(OCXDD,OCXFLD,0)) D WORD(OCXDD,OCXGREF,OCXFLD,.OCXDA,OCXCREF) - ;; ; - ;; D PUSH(.OCXDA) - ;; S OCXFLD="" F S OCXFLD=$O(@OCXCREF@(OCXDD,OCXFLD)) Q:'$L(OCXFLD) I (OCXFLD[":") D - ;; .S OCXDA=$P(OCXFLD,":",2) W ! D CREATE($$APPEND(OCXCREF,OCXDD),OCXFLD,.OCXDA,OCXLVL+1) - ;; D POP(.OCXDA) - ;; Q - ;; ; - ;;LOADWORD(RREF,OCXDD,OCXFLD,OCXSUB) ; - ;; ; - ;; N QUIT,DDPATH,INDEX,OCXDA,OCXGREF - ;; S DDPATH=$P($P($$APPEND(RREF,OCXDD),"(",2),")",1) - ;; F INDEX=1:1:$L(DDPATH,",") S OCXDA($L(DDPATH,",")-INDEX)=+$P($P(DDPATH,",",INDEX),":",2) - ;; S OCXDA=$G(OCXDA(0)) K OCXDA(0) - ;; Q:(OCXFLAG["D") 0 - ;; I (OCXFLAG["A") S QUIT=$$READ("Y"," Do you want to reload the local '"_$$FIELD^OCXSENDD(+OCXDD,+OCXFLD,"LABEL")_"' field ?","YES") Q:'QUIT (QUIT[U) - ;; S OCXGREF=$$GETREF(+OCXDD,.OCXDA,$L(DDPATH,",")-1) Q:'$L(OCXGREF) - ;; D WORD(OCXDD,OCXGREF,OCXFLD,.OCXDA,RREF) - ;; Q 0 - ;; ; - ;;GETREF(OCXDD,OCXDA,OCXLVL) ; - ;; ; - ;; Q:'OCXDD "" - ;; ; - ;; N OCXIENS,OCXERR,OCXX - ;; S OCXIENS=$$IENS^DILF(.OCXDA),OCXERR="" - ;; S OCXX=$$ROOT^DILFD(OCXDD,OCXIENS,0,OCXERR) - ;; Q OCXX - ;; ; - ;;WORD(DD,GREF,FLD,DA,RREF) ; - ;; ; - ;; N SUB,GLROOT,LINE - ;; S SUB=$P($$FIELD^OCXSENDD(+DD,FLD,"GLOBAL SUBSCRIPT LOCATION"),";",1) S:'(SUB=+SUB) SUB=""""_SUB_"""" - ;; S GLROOT=GREF_DA_","_SUB_")" K @GLROOT - ;; S LINE=0 F S LINE=$O(@RREF@(DD,FLD,LINE)) Q:'LINE D - ;; .S @GLROOT@($O(@GLROOT@(""),-1)+1,0)=@RREF@(DD,FLD,LINE) - ;; S LINE=$O(@GLROOT@(""),-1),@GLROOT@(0)=U_U_LINE_U_LINE_U_$$DATE("T")_U - ;; ; - ;; Q - ;; ; - ;;DATE(X) N %DT,Y S %DT="" D ^%DT Q +Y - ;; ; - ;;DIE(OCXDD,OCXDIC,OCXFLD,OCXVAL,OCXDA,OCXLVL) ; - ;; ; - ;; N DIC,DIE,X,Y,DR,DA,OCXDVAL,OCXPTR,OCXGREF,D0,OCXSCR - ;; S (D0,DA)=OCXDA,(DIC,DIE)=OCXDIC,DR="" - ;; S:OCXLVL D0=OCXDA(1),DR="S DA(1)="_(+D0)_",D0="_(+D0)_";" - ;; S:OCXVAL="?" OCXVAL="? " S DR=DR_OCXFLD_"///^S X=OCXVAL" - ;; I '(OCXVAL="@") W !,?(OCXLVL*5),$$FIELD^OCXSENDD(+OCXDD,OCXFLD,"LABEL"),": ",OCXVAL - ;; ; - ;; I '(OCXVAL="@") D - ;; .N OCXIEN,SHORT - ;; .S OCXPTR=+$P($$FIELD^OCXSENDD(+OCXDD,OCXFLD,"SPECIFIER"),"P",2) - ;; .Q:'OCXPTR - ;; .S OCXGREF="^"_$$FIELD^OCXSENDD(+OCXDD,OCXFLD,"POINTER") - ;; .I '($E(OCXGREF,1,4)="^OCX"),'(OCXGREF="^ORD(100.9,"),'(OCXGREF="^ORD(100.8,") Q - ;; .Q:$$DIC(OCXGREF,OCXVAL,0) - ;; .S OCXIEN=$$DIC(OCXGREF,OCXVAL,1) - ;; .S ^TMP("OCXRULE",$J,"B",OCXPTR,OCXVAL,OCXIEN)="" - ;; ; - ;; S OCXSCR=1 - ;; D ^DIE - ;; ; - ;; ; I $D(Y) -> DIE FILER ERROR - ;; I $D(Y) W " ^DIE filer data error..." S OCXDIER=$G(OCXDIER)+1 - ;; I '$D(Y) W " ...Correct data Filed" - ;; ; - ;; Q - ;; ; - ;;DIC(DIC,X,OCXADD) N OCXSCR S DIC(0)="",OCXSCR=1 S:OCXADD DIC(0)="L" D ^DIC Q:(+Y>0) +Y Q 0 - ;; ; - ;;PUSH(OCXDA) ; - ;; N OCXSUB S OCXSUB="" F S OCXSUB=$O(OCXDA(OCXSUB),-1) Q:'OCXSUB S OCXDA(OCXSUB+1)=OCXDA(OCXSUB) - ;; S OCXDA(1)=OCXDA,OCXDA=0 - ;; Q - ;; ; - ;;POP(OCXDA) ; - ;; N OCXSUB S OCXSUB="" F S OCXSUB=$O(OCXDA(OCXSUB)) Q:'OCXSUB S OCXDA(OCXSUB)=$G(OCXDA(OCXSUB+1)) - ;; S OCXDA=OCXDA(1) K OCXDA($O(OCXDA(""),-1)) - ;; Q - ;; ; - ;;APPEND(ARRAY,OCXSUB) ; - ;; S:'(OCXSUB=+OCXSUB) OCXSUB=""""_OCXSUB_"""" - ;; Q:'(ARRAY["(") ARRAY_"("_OCXSUB_")" - ;; Q $E(ARRAY,1,$L(ARRAY)-1)_","_OCXSUB_")" - ;; ; - ;;READ(OCXZ0,OCXZA,OCXZB,OCXZL) ; - ;; N OCXLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT - ;; Q:'$L($G(OCXZ0)) U - ;; S DIR(0)=OCXZ0 - ;; S:$L($G(OCXZA)) DIR("A")=OCXZA - ;; S:$L($G(OCXZB)) DIR("B")=OCXZB - ;; F OCXLINE=1:1:($G(OCXZL)-1) W ! - ;; D ^DIR - ;; I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U - ;; Q Y - ;; ; - ;;PAUSE() W " Press Enter " R X:DTIME W ! Q (X[U) - ;; ; - ;;$ - ;1; - ; +OCXSEND6 ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES (Build Library Routine 2) ;2/01/01 10:03 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,76,74,96,105**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; +EN() ; + ; + N R,LINE,TEXT,NOW,RUCI,XCM + S NOW=$$NOW^OCXSEND3,RUCI=$$NETNAME^OCXSEND + F LINE=1:1:999 S TEXT=$P($T(TEXT+LINE),";",2,999) Q:TEXT S TEXT=$P(TEXT,";",2,999) S R(LINE,0)=$$CONV^OCXSEND3(TEXT) + ; + M ^TMP("OCXSEND",$J,"RTN")=R + ; + S DIE="^TMP(""OCXSEND"","_$J_",""RTN"",",XCN=0,X=$$RNAME^OCXSEND3(2,1) + W !,X X ^%ZOSF("SAVE") W " ... ",XCM," Lines filed" K ^TMP("OCXSEND",$J,"RTN") + ; + Q XCM + ; +TEXT ; + ;;|$$RNAME^OCXSEND3(2,1)| ;SLC/RJS,CLA - OCX PACKAGE RULE TRANSPORT ROUTINE |OCXPATCH| ;|NOW| + ;;|OCXLIN2| + ;;|OCXLIN3| + ;; ; + ;;S ; + ;; ; Record Utilities + ;; Q + ;; ; + ;;ADDREC(OCXCREF) ; + ;; ; + ;; N QUIT,OCXDD,OCXDA,OCXGREF,OCXNAME + ;; S OCXDD=$O(@OCXCREF@("")) Q:'OCXDD 0 + ;; S OCXNAME=$G(@OCXCREF@(OCXDD,.01,"E")) + ;; ; + ;; W " record missing..." + ;; I (OCXFLAG["D") Q 0 + ;; ; + ;; S OCXDA=0 D CREATE(OCXCREF,OCXDD,.OCXDA,0) + ;; S:$L(OCXNAME) ^TMP("OCXRULE",$J,"A",+OCXDD,OCXNAME)="" + ;; ; + ;; Q 0 + ;; ; + ;;CREATE(OCXCREF,OCXDD,OCXDA,OCXLVL) ; + ;; ; + ;; N OCXFLD,OCXGREF,OCXKEY + ;; ; + ;; I $L(OCXDA),'(OCXDA=+OCXDA) W !!,"Unresolved subscript." Q + ;; ; + ;; S OCXKEY=@OCXCREF@(OCXDD,.01,"E") + ;; S OCXGREF=$$GETREF(+OCXDD,.OCXDA,OCXLVL) Q:'$L(OCXGREF) + ;; I 'OCXDA D + ;; .S OCXDA=$O(^TMP("OCXRULE",$J,"B",+OCXDD,OCXKEY,0)) Q:OCXDA + ;; .S OCXDA=$O(@(OCXGREF_""" "")"),-1)+1 + ;; .F OCXDA=OCXDA:1 Q:'$D(@(OCXGREF_OCXDA_",0)")) + ;; .I $D(@(OCXGREF_OCXDA_",0)")) S OCXDA=0 + ;; ; + ;; I 'OCXDA W !!,"Error adding record..." Q + ;; ; + ;; I '$D(@(OCXGREF_"0)")) S @(OCXGREF_"0)")=U_$$FILEHDR^OCXSENDD(+OCXDD)_U_U + ;; ; + ;; S OCXFLD=0 F S OCXFLD=$O(@OCXCREF@(OCXDD,OCXFLD)) Q:'OCXFLD Q:(OCXFLD[":") I '$$EXFLD^|$$RNAME^OCXSEND3(1,1)|(+OCXDD,OCXFLD) D + ;; .I $L($G(@OCXCREF@(OCXDD,OCXFLD,"E"))) D DIE(OCXDD,OCXGREF,OCXFLD,@OCXCREF@(OCXDD,OCXFLD,"E"),.OCXDA,OCXLVL) + ;; .I $O(@OCXCREF@(OCXDD,OCXFLD,0)) D WORD(OCXDD,OCXGREF,OCXFLD,.OCXDA,OCXCREF) + ;; ; + ;; D PUSH(.OCXDA) + ;; S OCXFLD="" F S OCXFLD=$O(@OCXCREF@(OCXDD,OCXFLD)) Q:'$L(OCXFLD) I (OCXFLD[":") D + ;; .S OCXDA=$P(OCXFLD,":",2) W ! D CREATE($$APPEND(OCXCREF,OCXDD),OCXFLD,.OCXDA,OCXLVL+1) + ;; D POP(.OCXDA) + ;; Q + ;; ; + ;;LOADWORD(RREF,OCXDD,OCXFLD,OCXSUB) ; + ;; ; + ;; N QUIT,DDPATH,INDEX,OCXDA,OCXGREF + ;; S DDPATH=$P($P($$APPEND(RREF,OCXDD),"(",2),")",1) + ;; F INDEX=1:1:$L(DDPATH,",") S OCXDA($L(DDPATH,",")-INDEX)=+$P($P(DDPATH,",",INDEX),":",2) + ;; S OCXDA=$G(OCXDA(0)) K OCXDA(0) + ;; Q:(OCXFLAG["D") 0 + ;; I (OCXFLAG["A") S QUIT=$$READ("Y"," Do you want to reload the local '"_$$FIELD^OCXSENDD(+OCXDD,+OCXFLD,"LABEL")_"' field ?","YES") Q:'QUIT (QUIT[U) + ;; S OCXGREF=$$GETREF(+OCXDD,.OCXDA,$L(DDPATH,",")-1) Q:'$L(OCXGREF) + ;; D WORD(OCXDD,OCXGREF,OCXFLD,.OCXDA,RREF) + ;; Q 0 + ;; ; + ;;GETREF(OCXDD,OCXDA,OCXLVL) ; + ;; ; + ;; Q:'OCXDD "" + ;; ; + ;; N OCXIENS,OCXERR,OCXX + ;; S OCXIENS=$$IENS^DILF(.OCXDA),OCXERR="" + ;; S OCXX=$$ROOT^DILFD(OCXDD,OCXIENS,0,OCXERR) + ;; Q OCXX + ;; ; + ;;WORD(DD,GREF,FLD,DA,RREF) ; + ;; ; + ;; N SUB,GLROOT,LINE + ;; S SUB=$P($$FIELD^OCXSENDD(+DD,FLD,"GLOBAL SUBSCRIPT LOCATION"),";",1) S:'(SUB=+SUB) SUB=""""_SUB_"""" + ;; S GLROOT=GREF_DA_","_SUB_")" K @GLROOT + ;; S LINE=0 F S LINE=$O(@RREF@(DD,FLD,LINE)) Q:'LINE D + ;; .S @GLROOT@($O(@GLROOT@(""),-1)+1,0)=@RREF@(DD,FLD,LINE) + ;; S LINE=$O(@GLROOT@(""),-1),@GLROOT@(0)=U_U_LINE_U_LINE_U_$$DATE("T")_U + ;; ; + ;; Q + ;; ; + ;;DATE(X) N %DT,Y S %DT="" D ^%DT Q +Y + ;; ; + ;;DIE(OCXDD,OCXDIC,OCXFLD,OCXVAL,OCXDA,OCXLVL) ; + ;; ; + ;; N DIC,DIE,X,Y,DR,DA,OCXDVAL,OCXPTR,OCXGREF,D0,OCXSCR + ;; S (D0,DA)=OCXDA,(DIC,DIE)=OCXDIC,DR="" + ;; S:OCXLVL D0=OCXDA(1),DR="S DA(1)="_(+D0)_",D0="_(+D0)_";" + ;; S:OCXVAL="?" OCXVAL="? " S DR=DR_OCXFLD_"///^S X=OCXVAL" + ;; I '(OCXVAL="@") W !,?(OCXLVL*5),$$FIELD^OCXSENDD(+OCXDD,OCXFLD,"LABEL"),": ",OCXVAL + ;; ; + ;; I '(OCXVAL="@") D + ;; .N OCXIEN,SHORT + ;; .S OCXPTR=+$P($$FIELD^OCXSENDD(+OCXDD,OCXFLD,"SPECIFIER"),"P",2) + ;; .Q:'OCXPTR + ;; .S OCXGREF="^"_$$FIELD^OCXSENDD(+OCXDD,OCXFLD,"POINTER") + ;; .I '($E(OCXGREF,1,4)="^OCX"),'(OCXGREF="^ORD(100.9,"),'(OCXGREF="^ORD(100.8,") Q + ;; .Q:$$DIC(OCXGREF,OCXVAL,0) + ;; .S OCXIEN=$$DIC(OCXGREF,OCXVAL,1) + ;; .S ^TMP("OCXRULE",$J,"B",OCXPTR,OCXVAL,OCXIEN)="" + ;; ; + ;; S OCXSCR=1 + ;; D ^DIE + ;; ; + ;; ; I $D(Y) -> DIE FILER ERROR + ;; I $D(Y) W " ^DIE filer data error..." S OCXDIER=$G(OCXDIER)+1 + ;; I '$D(Y) W " ...Correct data Filed" + ;; ; + ;; Q + ;; ; + ;;DIC(DIC,X,OCXADD) N OCXSCR S DIC(0)="",OCXSCR=1 S:OCXADD DIC(0)="L" D ^DIC Q:(+Y>0) +Y Q 0 + ;; ; + ;;PUSH(OCXDA) ; + ;; N OCXSUB S OCXSUB="" F S OCXSUB=$O(OCXDA(OCXSUB),-1) Q:'OCXSUB S OCXDA(OCXSUB+1)=OCXDA(OCXSUB) + ;; S OCXDA(1)=OCXDA,OCXDA=0 + ;; Q + ;; ; + ;;POP(OCXDA) ; + ;; N OCXSUB S OCXSUB="" F S OCXSUB=$O(OCXDA(OCXSUB)) Q:'OCXSUB S OCXDA(OCXSUB)=$G(OCXDA(OCXSUB+1)) + ;; S OCXDA=OCXDA(1) K OCXDA($O(OCXDA(""),-1)) + ;; Q + ;; ; + ;;APPEND(ARRAY,OCXSUB) ; + ;; S:'(OCXSUB=+OCXSUB) OCXSUB=""""_OCXSUB_"""" + ;; Q:'(ARRAY["(") ARRAY_"("_OCXSUB_")" + ;; Q $E(ARRAY,1,$L(ARRAY)-1)_","_OCXSUB_")" + ;; ; + ;;READ(OCXZ0,OCXZA,OCXZB,OCXZL) ; + ;; N OCXLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT + ;; Q:'$L($G(OCXZ0)) U + ;; S DIR(0)=OCXZ0 + ;; S:$L($G(OCXZA)) DIR("A")=OCXZA + ;; S:$L($G(OCXZB)) DIR("B")=OCXZB + ;; F OCXLINE=1:1:($G(OCXZL)-1) W ! + ;; D ^DIR + ;; I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U + ;; Q Y + ;; ; + ;;PAUSE() W " Press Enter " R X:DTIME W ! Q (X[U) + ;; ; + ;;$ + ;1; + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSEND7.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSEND7.m index 12b67686..f47cccc1 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSEND7.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSEND7.m @@ -1,108 +1,108 @@ -OCXSEND7 ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES (Build Library Routine 3) ;1/31/01 11:07 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,96,105,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; -EN() ; - ; - N R,LINE,TEXT,NOW,RUCI - S NOW=$$NOW^OCXSEND3,RUCI=$$NETNAME^OCXSEND - F LINE=1:1:999 S TEXT=$P($T(TEXT+LINE),";",2,999) Q:TEXT S TEXT=$P(TEXT,";",2,999) S R(LINE,0)=$$CONV^OCXSEND3(TEXT) - ; - M ^TMP("OCXSEND",$J,"RTN")=R - ; - S DIE="^TMP(""OCXSEND"","_$J_",""RTN"",",XCN=0,X=$$RNAME^OCXSEND3(3,1) - W !,X X ^%ZOSF("SAVE") K ^TMP("OCXSEND",$J,"RTN") - ; - Q " " - ; -TEXT ; - ;;|$$RNAME^OCXSEND3(3,1)| ;SLC/RJS,CLA - OCX PACKAGE RULE TRANSPORT ROUTINE |OCXPATCH| ;|NOW| - ;;|OCXLIN2| - ;;|OCXLIN3| - ;; ; - ;;S ; - ;; ; Multiple Utilities - ;; Q - ;; ; - ;;ADDMULT(OCXCREF,OCXDD,OCXFLD) ; - ;; ; - ;; ; - ;; N QUIT,OCXDA,OCXGREF,OCXNAME,DDPATH,INDEX - ;; ; - ;; S DDPATH=$P($P($$APPEND($$APPEND(OCXCREF,OCXDD),OCXFLD),"(",2),")",1) - ;; F INDEX=1:1:$L(DDPATH,",") S OCXDA($L(DDPATH,",")-INDEX)=+$P($P(DDPATH,",",INDEX),":",2) - ;; S OCXDA=$G(OCXDA(0)) K OCXDA(0) - ;; ; - ;; Q:(OCXFLAG["D") 0 - ;; I (OCXFLAG["A") S QUIT=$$READ("Y"," Do you want to add a local '"_$$FILENAME^OCXSENDD(+OCXFLD)_"' multiple ?","YES") Q:'QUIT (QUIT[U) - ;; ; - ;; S OCXGREF=$$GETREF^|$$RNAME^OCXSEND3(2,1)|(+OCXFLD,.OCXDA,1) - ;; D CREATE($$APPEND(OCXCREF,OCXDD),OCXFLD,.OCXDA,1) - ;; ; - ;; Q 0 - ;; ; - ;;DELMULT(OCXCREF,OCXDD) ; - ;; ; - ;; N QUIT,OCXGREF,DA,INDEX,DDPATH - ;; ; - ;; Q:(OCXFLAG["D") 0 - ;; I (OCXFLAG["A") S QUIT=$$READ("Y"," Do you want to delete the local '"_$$FILENAME^OCXSENDD(+OCXDD)_"' multiple ?","YES") Q:'QUIT (QUIT[U) - ;; ; - ;; S DDPATH=$P($P($$APPEND(OCXCREF,OCXDD),"(",2),")",1) - ;; F INDEX=1:1:$L(DDPATH,",") S DA($L(DDPATH,",")-INDEX)=+$P($P(DDPATH,",",INDEX),":",2) - ;; S DA=$G(DA(0)) K DA(0) - ;; S OCXGREF=$$GETREF^|$$RNAME^OCXSEND3(2,1)|(+OCXDD,.DA,1) - ;; ; - ;; D DIE^|$$RNAME^OCXSEND3(2,1)|(+OCXDD,OCXGREF,.01,"@",.DA,$L(DDPATH,",")-1) - ;; K @OCXCREF@(OCXDD) W !!," deleted..." - ;; ; - ;; Q 0 - ;; ; - ;;CREATE(OCXCREF,OCXDD,OCXDA,OCXLVL) ; - ;; ; - ;; N OCXFLD,OCXGREF - ;; ; - ;; S OCXGREF=$$GETREF^|$$RNAME^OCXSEND3(2,1)|(+OCXDD,.OCXDA,OCXLVL) Q:'$L(OCXGREF) S:'OCXDA OCXDA=$O(@(OCXGREF_"""@"")"),-1)+1 - ;; ; - ;; I '$D(@(OCXGREF_"0)")) S @(OCXGREF_"0)")=U_$$FILEHDR^OCXSENDD(+OCXDD)_U_U - ;; ; - ;; S OCXFLD=0 F S OCXFLD=$O(@OCXCREF@(OCXDD,OCXFLD)) Q:'OCXFLD Q:(OCXFLD[":") I '$$EXFLD^|$$RNAME^OCXSEND3(1,1)|(+OCXDD,OCXFLD) D - ;; .I $L($G(@OCXCREF@(OCXDD,OCXFLD,"E"))) D DIE^|$$RNAME^OCXSEND3(2,1)|(OCXDD,OCXGREF,OCXFLD,@OCXCREF@(OCXDD,OCXFLD,"E"),.OCXDA,OCXLVL) - ;; ; - ;; D PUSH(.OCXDA) - ;; S OCXFLD="" F S OCXFLD=$O(@OCXCREF@(OCXDD,OCXFLD)) Q:'$L(OCXFLD) I (OCXFLD[":") D - ;; .S OCXDA=$P(OCXFLD,":",2) W ! D CREATE($$APPEND(OCXCREF,OCXDD),OCXFLD,.OCXDA,OCXLVL+1) - ;; D POP(.OCXDA) - ;; Q - ;; ; - ;;PUSH(OCXDA) ; - ;; N OCXSUB S OCXSUB="" F S OCXSUB=$O(OCXDA(OCXSUB),-1) Q:'OCXSUB S OCXDA(OCXSUB+1)=OCXDA(OCXSUB) - ;; S OCXDA(1)=OCXDA,OCXDA=0 - ;; Q - ;; ; - ;;POP(OCXDA) ; - ;; N OCXSUB S OCXSUB="" F S OCXSUB=$O(OCXDA(OCXSUB)) Q:'OCXSUB S OCXDA(OCXSUB)=$G(OCXDA(OCXSUB+1)) - ;; S OCXDA=OCXDA(1) K OCXDA($O(OCXDA(""),-1)) - ;; Q - ;; ; - ;;APPEND(ARRAY,OCXSUB) ; - ;; S:'(OCXSUB=+OCXSUB) OCXSUB=""""_OCXSUB_"""" - ;; Q:'(ARRAY["(") ARRAY_"("_OCXSUB_")" - ;; Q $E(ARRAY,1,$L(ARRAY)-1)_","_OCXSUB_")" - ;; ; - ;;READ(OCXZ0,OCXZA,OCXZB,OCXZL) ; - ;; N OCXLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT - ;; Q:'$L($G(OCXZ0)) U - ;; S DIR(0)=OCXZ0 - ;; S:$L($G(OCXZA)) DIR("A")=OCXZA - ;; S:$L($G(OCXZB)) DIR("B")=OCXZB - ;; F OCXLINE=1:1:($G(OCXZL)-1) W ! - ;; D ^DIR - ;; I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U - ;; Q Y - ;; ; - ;;PAUSE() W " Press Enter " R X:DTIME W ! Q (X[U) - ;; ; - ;;$ - ;1; - ; +OCXSEND7 ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES (Build Library Routine 3) ;1/31/01 11:07 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,96,105**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; +EN() ; + ; + N R,LINE,TEXT,NOW,RUCI,XCM + S NOW=$$NOW^OCXSEND3,RUCI=$$NETNAME^OCXSEND + F LINE=1:1:999 S TEXT=$P($T(TEXT+LINE),";",2,999) Q:TEXT S TEXT=$P(TEXT,";",2,999) S R(LINE,0)=$$CONV^OCXSEND3(TEXT) + ; + M ^TMP("OCXSEND",$J,"RTN")=R + ; + S DIE="^TMP(""OCXSEND"","_$J_",""RTN"",",XCN=0,X=$$RNAME^OCXSEND3(3,1) + W !,X X ^%ZOSF("SAVE") W " ... ",XCM," Lines filed" K ^TMP("OCXSEND",$J,"RTN") + ; + Q XCM + ; +TEXT ; + ;;|$$RNAME^OCXSEND3(3,1)| ;SLC/RJS,CLA - OCX PACKAGE RULE TRANSPORT ROUTINE |OCXPATCH| ;|NOW| + ;;|OCXLIN2| + ;;|OCXLIN3| + ;; ; + ;;S ; + ;; ; Multiple Utilities + ;; Q + ;; ; + ;;ADDMULT(OCXCREF,OCXDD,OCXFLD) ; + ;; ; + ;; ; + ;; N QUIT,OCXDA,OCXGREF,OCXNAME,DDPATH,INDEX + ;; ; + ;; S DDPATH=$P($P($$APPEND($$APPEND(OCXCREF,OCXDD),OCXFLD),"(",2),")",1) + ;; F INDEX=1:1:$L(DDPATH,",") S OCXDA($L(DDPATH,",")-INDEX)=+$P($P(DDPATH,",",INDEX),":",2) + ;; S OCXDA=$G(OCXDA(0)) K OCXDA(0) + ;; ; + ;; Q:(OCXFLAG["D") 0 + ;; I (OCXFLAG["A") S QUIT=$$READ("Y"," Do you want to add a local '"_$$FILENAME^OCXSENDD(+OCXFLD)_"' multiple ?","YES") Q:'QUIT (QUIT[U) + ;; ; + ;; S OCXGREF=$$GETREF^|$$RNAME^OCXSEND3(2,1)|(+OCXFLD,.OCXDA,1) + ;; D CREATE($$APPEND(OCXCREF,OCXDD),OCXFLD,.OCXDA,1) + ;; ; + ;; Q 0 + ;; ; + ;;DELMULT(OCXCREF,OCXDD) ; + ;; ; + ;; N QUIT,OCXGREF,DA,INDEX,DDPATH + ;; ; + ;; Q:(OCXFLAG["D") 0 + ;; I (OCXFLAG["A") S QUIT=$$READ("Y"," Do you want to delete the local '"_$$FILENAME^OCXSENDD(+OCXDD)_"' multiple ?","YES") Q:'QUIT (QUIT[U) + ;; ; + ;; S DDPATH=$P($P($$APPEND(OCXCREF,OCXDD),"(",2),")",1) + ;; F INDEX=1:1:$L(DDPATH,",") S DA($L(DDPATH,",")-INDEX)=+$P($P(DDPATH,",",INDEX),":",2) + ;; S DA=$G(DA(0)) K DA(0) + ;; S OCXGREF=$$GETREF^|$$RNAME^OCXSEND3(2,1)|(+OCXDD,.DA,1) + ;; ; + ;; D DIE^|$$RNAME^OCXSEND3(2,1)|(+OCXDD,OCXGREF,.01,"@",.DA,$L(DDPATH,",")-1) + ;; K @OCXCREF@(OCXDD) W !!," deleted..." + ;; ; + ;; Q 0 + ;; ; + ;;CREATE(OCXCREF,OCXDD,OCXDA,OCXLVL) ; + ;; ; + ;; N OCXFLD,OCXGREF + ;; ; + ;; S OCXGREF=$$GETREF^|$$RNAME^OCXSEND3(2,1)|(+OCXDD,.OCXDA,OCXLVL) Q:'$L(OCXGREF) S:'OCXDA OCXDA=$O(@(OCXGREF_"""@"")"),-1)+1 + ;; ; + ;; I '$D(@(OCXGREF_"0)")) S @(OCXGREF_"0)")=U_$$FILEHDR^OCXSENDD(+OCXDD)_U_U + ;; ; + ;; S OCXFLD=0 F S OCXFLD=$O(@OCXCREF@(OCXDD,OCXFLD)) Q:'OCXFLD Q:(OCXFLD[":") I '$$EXFLD^|$$RNAME^OCXSEND3(1,1)|(+OCXDD,OCXFLD) D + ;; .I $L($G(@OCXCREF@(OCXDD,OCXFLD,"E"))) D DIE^|$$RNAME^OCXSEND3(2,1)|(OCXDD,OCXGREF,OCXFLD,@OCXCREF@(OCXDD,OCXFLD,"E"),.OCXDA,OCXLVL) + ;; ; + ;; D PUSH(.OCXDA) + ;; S OCXFLD="" F S OCXFLD=$O(@OCXCREF@(OCXDD,OCXFLD)) Q:'$L(OCXFLD) I (OCXFLD[":") D + ;; .S OCXDA=$P(OCXFLD,":",2) W ! D CREATE($$APPEND(OCXCREF,OCXDD),OCXFLD,.OCXDA,OCXLVL+1) + ;; D POP(.OCXDA) + ;; Q + ;; ; + ;;PUSH(OCXDA) ; + ;; N OCXSUB S OCXSUB="" F S OCXSUB=$O(OCXDA(OCXSUB),-1) Q:'OCXSUB S OCXDA(OCXSUB+1)=OCXDA(OCXSUB) + ;; S OCXDA(1)=OCXDA,OCXDA=0 + ;; Q + ;; ; + ;;POP(OCXDA) ; + ;; N OCXSUB S OCXSUB="" F S OCXSUB=$O(OCXDA(OCXSUB)) Q:'OCXSUB S OCXDA(OCXSUB)=$G(OCXDA(OCXSUB+1)) + ;; S OCXDA=OCXDA(1) K OCXDA($O(OCXDA(""),-1)) + ;; Q + ;; ; + ;;APPEND(ARRAY,OCXSUB) ; + ;; S:'(OCXSUB=+OCXSUB) OCXSUB=""""_OCXSUB_"""" + ;; Q:'(ARRAY["(") ARRAY_"("_OCXSUB_")" + ;; Q $E(ARRAY,1,$L(ARRAY)-1)_","_OCXSUB_")" + ;; ; + ;;READ(OCXZ0,OCXZA,OCXZB,OCXZL) ; + ;; N OCXLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT + ;; Q:'$L($G(OCXZ0)) U + ;; S DIR(0)=OCXZ0 + ;; S:$L($G(OCXZA)) DIR("A")=OCXZA + ;; S:$L($G(OCXZB)) DIR("B")=OCXZB + ;; F OCXLINE=1:1:($G(OCXZL)-1) W ! + ;; D ^DIR + ;; I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U + ;; Q Y + ;; ; + ;;PAUSE() W " Press Enter " R X:DTIME W ! Q (X[U) + ;; ; + ;;$ + ;1; + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSEND8.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSEND8.m index 20652158..c1c18a6a 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSEND8.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSEND8.m @@ -1,106 +1,106 @@ -OCXSEND8 ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES (Build Library Routine 4) ;1/31/01 08:44 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,96,105,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; -EN() ; - ; - N R,LINE,TEXT,NOW,RUCI - S NOW=$$NOW^OCXSEND3,RUCI=$$NETNAME^OCXSEND - F LINE=1:1:999 S TEXT=$P($T(TEXT+LINE),";",2,999) Q:TEXT S TEXT=$P(TEXT,";",2,999) S R(LINE,0)=$$CONV^OCXSEND3(TEXT) - ; - M ^TMP("OCXSEND",$J,"RTN")=R - ; - S DIE="^TMP(""OCXSEND"","_$J_",""RTN"",",XCN=0,X=$$RNAME^OCXSEND3(4,1) - W !,X X ^%ZOSF("SAVE") K ^TMP("OCXSEND",$J,"RTN") - ; - Q " " - ; -TEXT ; - ;;|$$RNAME^OCXSEND3(4,1)| ;SLC/RJS,CLA - OCX PACKAGE RULE TRANSPORT ROUTINE |OCXPATCH| ;|NOW| - ;;|OCXLIN2| - ;;|OCXLIN3| - ;; ; - ;;S ; - ;; ; Field Utilities - ;; Q - ;; ; - ;;EDITFLD(OCXCREF,OCXDD,OCXFLD,OCXSUB) ; - ;; ; - ;; N DDPATH,OCXDA,OCXPC,OCXLVL,QUIT - ;; ; - ;; S QUIT=0,DDPATH=$P($P($$APPEND(OCXCREF,OCXDD),"(",2),")",1) - ;; S OCXLVL=$L(DDPATH,",") - ;; F OCXPC=1:1:OCXLVL S OCXDA(OCXLVL-OCXPC)=+$P($P(DDPATH,",",OCXPC),":",2) - ;; S OCXDA=OCXDA(0) K OCXDA(0) - ;; I $L($G(@OCXCREF@(OCXDD,OCXFLD,"E"))) D - ;; .N RESP - ;; .Q:(OCXFLAG["D") - ;; .I (OCXFLAG["A") S RESP=$$READ("Y"," Do you want to change the local '"_$$FILENAME^OCXSENDD(+OCXDD)_"' field ?","YES") I 'RESP S QUIT=(RESP[U) Q - ;; .S OCXGREF=$$GETREF^|$$RNAME^OCXSEND3(2,1)|(+OCXDD,.OCXDA,OCXLVL-1) Q:'$L(OCXGREF) - ;; .D DIE^|$$RNAME^OCXSEND3(2,1)|(OCXDD,OCXGREF,OCXFLD,@OCXCREF@(OCXDD,OCXFLD,"E"),.OCXDA,OCXLVL-1) - ;; ; - ;; Q QUIT - ;; ; - ;;DELFLD(OCXCREF,OCXDD,OCXFLD,OCXSUB) ; - ;; ; - ;; N DDPATH,OCXDA,OCXPC,OCXLVL,QUIT,RESP - ;; ; - ;; S QUIT=0,DDPATH=$P($P($$APPEND(OCXCREF,OCXDD),"(",2),")",1) - ;; S OCXLVL=$L(DDPATH,",") - ;; F OCXPC=1:1:OCXLVL S OCXDA(OCXLVL-OCXPC)=+$P($P(DDPATH,",",OCXPC),":",2) - ;; S OCXDA=OCXDA(0) K OCXDA(0) - ;; Q:(OCXFLAG["D") 0 - ;; I (OCXFLAG["A") S RESP=$$READ("Y"," Do you want to Delete the local '"_$$FILENAME^OCXSENDD(+OCXDD)_"' value ?","YES") I 'RESP S QUIT=(RESP[U) Q QUIT - ;; S OCXGREF=$$GETREF^|$$RNAME^OCXSEND3(2,1)|(+OCXDD,.OCXDA,OCXLVL-1) Q:'$L(OCXGREF) - ;; D DIE^|$$RNAME^OCXSEND3(2,1)|(OCXDD,OCXGREF,OCXFLD,"@",.OCXDA,OCXLVL-1) - ;; ; - ;; Q QUIT - ;; ; - ;;CREATE(OCXCREF,OCXDD,OCXDA,OCXLVL) ; - ;; ; - ;; N OCXFLD,OCXGREF - ;; ; - ;; S OCXGREF=$$GETREF^|$$RNAME^OCXSEND3(2,1)|(+OCXDD,.OCXDA,OCXLVL) Q:'$L(OCXGREF) S:'OCXDA OCXDA=$O(@(OCXGREF_"""@"")"),-1)+1 - ;; ; - ;; I '$D(@(OCXGREF_"0)")) S @(OCXGREF_"0)")=U_$$FILEHDR^OCXSENDD(+OCXDD)_U_U - ;; ; - ;; S OCXFLD=0 F S OCXFLD=$O(@OCXCREF@(OCXDD,OCXFLD)) Q:'OCXFLD Q:(OCXFLD[":") I '$$EXFLD^|$$RNAME^OCXSEND3(1,1)|(+OCXDD,OCXFLD) D - ;; .I $L($G(@OCXCREF@(OCXDD,OCXFLD,"E"))) D DIE^|$$RNAME^OCXSEND3(2,1)|(OCXDD,OCXGREF,OCXFLD,@OCXCREF@(OCXDD,OCXFLD,"E"),.OCXDA,OCXLVL) - ;; ; - ;; D PUSH(.OCXDA) - ;; S OCXFLD="" F S OCXFLD=$O(@OCXCREF@(OCXDD,OCXFLD)) Q:'$L(OCXFLD) I (OCXFLD[":") D - ;; .S OCXDA=$P(OCXFLD,":",2) W ! D CREATE($$APPEND(OCXCREF,OCXDD),OCXFLD,.OCXDA,OCXLVL+1) - ;; D POP(.OCXDA) - ;; Q - ;; ; - ;;PUSH(OCXDA) ; - ;; N OCXSUB S OCXSUB="" F S OCXSUB=$O(OCXDA(OCXSUB),-1) Q:'OCXSUB S OCXDA(OCXSUB+1)=OCXDA(OCXSUB) - ;; S OCXDA(1)=OCXDA,OCXDA=0 - ;; Q - ;; ; - ;;POP(OCXDA) ; - ;; N OCXSUB S OCXSUB="" F S OCXSUB=$O(OCXDA(OCXSUB)) Q:'OCXSUB S OCXDA(OCXSUB)=$G(OCXDA(OCXSUB+1)) - ;; S OCXDA=OCXDA(1) K OCXDA($O(OCXDA(""),-1)) - ;; Q - ;; ; - ;;APPEND(ARRAY,OCXSUB) ; - ;; S:'(OCXSUB=+OCXSUB) OCXSUB=""""_OCXSUB_"""" - ;; Q:'(ARRAY["(") ARRAY_"("_OCXSUB_")" - ;; Q $E(ARRAY,1,$L(ARRAY)-1)_","_OCXSUB_")" - ;; ; - ;;READ(OCXZ0,OCXZA,OCXZB,OCXZL) ; - ;; N OCXLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT - ;; Q:'$L($G(OCXZ0)) U - ;; S DIR(0)=OCXZ0 - ;; S:$L($G(OCXZA)) DIR("A")=OCXZA - ;; S:$L($G(OCXZB)) DIR("B")=OCXZB - ;; F OCXLINE=1:1:($G(OCXZL)-1) W ! - ;; D ^DIR - ;; I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U - ;; Q Y - ;; ; - ;;PAUSE() W " Press Enter " R X:DTIME W ! Q (X[U) - ;; ; - ;;$ - ;1; - ; +OCXSEND8 ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES (Build Library Routine 4) ;1/31/01 08:44 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,96,105**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; +EN() ; + ; + N R,LINE,TEXT,NOW,RUCI,XCM + S NOW=$$NOW^OCXSEND3,RUCI=$$NETNAME^OCXSEND + F LINE=1:1:999 S TEXT=$P($T(TEXT+LINE),";",2,999) Q:TEXT S TEXT=$P(TEXT,";",2,999) S R(LINE,0)=$$CONV^OCXSEND3(TEXT) + ; + M ^TMP("OCXSEND",$J,"RTN")=R + ; + S DIE="^TMP(""OCXSEND"","_$J_",""RTN"",",XCN=0,X=$$RNAME^OCXSEND3(4,1) + W !,X X ^%ZOSF("SAVE") W " ... ",XCM," Lines filed" K ^TMP("OCXSEND",$J,"RTN") + ; + Q XCM + ; +TEXT ; + ;;|$$RNAME^OCXSEND3(4,1)| ;SLC/RJS,CLA - OCX PACKAGE RULE TRANSPORT ROUTINE |OCXPATCH| ;|NOW| + ;;|OCXLIN2| + ;;|OCXLIN3| + ;; ; + ;;S ; + ;; ; Field Utilities + ;; Q + ;; ; + ;;EDITFLD(OCXCREF,OCXDD,OCXFLD,OCXSUB) ; + ;; ; + ;; N DDPATH,OCXDA,OCXPC,OCXLVL,QUIT + ;; ; + ;; S QUIT=0,DDPATH=$P($P($$APPEND(OCXCREF,OCXDD),"(",2),")",1) + ;; S OCXLVL=$L(DDPATH,",") + ;; F OCXPC=1:1:OCXLVL S OCXDA(OCXLVL-OCXPC)=+$P($P(DDPATH,",",OCXPC),":",2) + ;; S OCXDA=OCXDA(0) K OCXDA(0) + ;; I $L($G(@OCXCREF@(OCXDD,OCXFLD,"E"))) D + ;; .N RESP + ;; .Q:(OCXFLAG["D") + ;; .I (OCXFLAG["A") S RESP=$$READ("Y"," Do you want to change the local '"_$$FILENAME^OCXSENDD(+OCXDD)_"' field ?","YES") I 'RESP S QUIT=(RESP[U) Q + ;; .S OCXGREF=$$GETREF^|$$RNAME^OCXSEND3(2,1)|(+OCXDD,.OCXDA,OCXLVL-1) Q:'$L(OCXGREF) + ;; .D DIE^|$$RNAME^OCXSEND3(2,1)|(OCXDD,OCXGREF,OCXFLD,@OCXCREF@(OCXDD,OCXFLD,"E"),.OCXDA,OCXLVL-1) + ;; ; + ;; Q QUIT + ;; ; + ;;DELFLD(OCXCREF,OCXDD,OCXFLD,OCXSUB) ; + ;; ; + ;; N DDPATH,OCXDA,OCXPC,OCXLVL,QUIT,RESP + ;; ; + ;; S QUIT=0,DDPATH=$P($P($$APPEND(OCXCREF,OCXDD),"(",2),")",1) + ;; S OCXLVL=$L(DDPATH,",") + ;; F OCXPC=1:1:OCXLVL S OCXDA(OCXLVL-OCXPC)=+$P($P(DDPATH,",",OCXPC),":",2) + ;; S OCXDA=OCXDA(0) K OCXDA(0) + ;; Q:(OCXFLAG["D") 0 + ;; I (OCXFLAG["A") S RESP=$$READ("Y"," Do you want to Delete the local '"_$$FILENAME^OCXSENDD(+OCXDD)_"' value ?","YES") I 'RESP S QUIT=(RESP[U) Q QUIT + ;; S OCXGREF=$$GETREF^|$$RNAME^OCXSEND3(2,1)|(+OCXDD,.OCXDA,OCXLVL-1) Q:'$L(OCXGREF) + ;; D DIE^|$$RNAME^OCXSEND3(2,1)|(OCXDD,OCXGREF,OCXFLD,"@",.OCXDA,OCXLVL-1) + ;; ; + ;; Q QUIT + ;; ; + ;;CREATE(OCXCREF,OCXDD,OCXDA,OCXLVL) ; + ;; ; + ;; N OCXFLD,OCXGREF + ;; ; + ;; S OCXGREF=$$GETREF^|$$RNAME^OCXSEND3(2,1)|(+OCXDD,.OCXDA,OCXLVL) Q:'$L(OCXGREF) S:'OCXDA OCXDA=$O(@(OCXGREF_"""@"")"),-1)+1 + ;; ; + ;; I '$D(@(OCXGREF_"0)")) S @(OCXGREF_"0)")=U_$$FILEHDR^OCXSENDD(+OCXDD)_U_U + ;; ; + ;; S OCXFLD=0 F S OCXFLD=$O(@OCXCREF@(OCXDD,OCXFLD)) Q:'OCXFLD Q:(OCXFLD[":") I '$$EXFLD^|$$RNAME^OCXSEND3(1,1)|(+OCXDD,OCXFLD) D + ;; .I $L($G(@OCXCREF@(OCXDD,OCXFLD,"E"))) D DIE^|$$RNAME^OCXSEND3(2,1)|(OCXDD,OCXGREF,OCXFLD,@OCXCREF@(OCXDD,OCXFLD,"E"),.OCXDA,OCXLVL) + ;; ; + ;; D PUSH(.OCXDA) + ;; S OCXFLD="" F S OCXFLD=$O(@OCXCREF@(OCXDD,OCXFLD)) Q:'$L(OCXFLD) I (OCXFLD[":") D + ;; .S OCXDA=$P(OCXFLD,":",2) W ! D CREATE($$APPEND(OCXCREF,OCXDD),OCXFLD,.OCXDA,OCXLVL+1) + ;; D POP(.OCXDA) + ;; Q + ;; ; + ;;PUSH(OCXDA) ; + ;; N OCXSUB S OCXSUB="" F S OCXSUB=$O(OCXDA(OCXSUB),-1) Q:'OCXSUB S OCXDA(OCXSUB+1)=OCXDA(OCXSUB) + ;; S OCXDA(1)=OCXDA,OCXDA=0 + ;; Q + ;; ; + ;;POP(OCXDA) ; + ;; N OCXSUB S OCXSUB="" F S OCXSUB=$O(OCXDA(OCXSUB)) Q:'OCXSUB S OCXDA(OCXSUB)=$G(OCXDA(OCXSUB+1)) + ;; S OCXDA=OCXDA(1) K OCXDA($O(OCXDA(""),-1)) + ;; Q + ;; ; + ;;APPEND(ARRAY,OCXSUB) ; + ;; S:'(OCXSUB=+OCXSUB) OCXSUB=""""_OCXSUB_"""" + ;; Q:'(ARRAY["(") ARRAY_"("_OCXSUB_")" + ;; Q $E(ARRAY,1,$L(ARRAY)-1)_","_OCXSUB_")" + ;; ; + ;;READ(OCXZ0,OCXZA,OCXZB,OCXZL) ; + ;; N OCXLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT + ;; Q:'$L($G(OCXZ0)) U + ;; S DIR(0)=OCXZ0 + ;; S:$L($G(OCXZA)) DIR("A")=OCXZA + ;; S:$L($G(OCXZB)) DIR("B")=OCXZB + ;; F OCXLINE=1:1:($G(OCXZL)-1) W ! + ;; D ^DIR + ;; I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U + ;; Q Y + ;; ; + ;;PAUSE() W " Press Enter " R X:DTIME W ! Q (X[U) + ;; ; + ;;$ + ;1; + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSENDA.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSENDA.m index 375e36c6..c4580e8e 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSENDA.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXSENDA.m @@ -1,107 +1,107 @@ -OCXSENDA ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES (Build Main Routine) ;6/12/02 12:03 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,74,96,105,143,243**;Dec 17,1997;Build 242 - ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 - ; -EN() ; - ; - N R,LINE,TEXT,NOW,RUCI - S NOW=$$NOW^OCXSEND3,RUCI=$$NETNAME^OCXSEND,CVER=$$VERSION^OCXOCMP - F LINE=1:1:999 S TEXT=$P($T(TEXT+LINE),";",2,999) Q:TEXT S TEXT=$P(TEXT,";",2,999) S R(LINE,0)=$$CONV^OCXSEND3(TEXT) - ; - M ^TMP("OCXSEND",$J,"RTN")=R - ; - S DIE="^TMP(""OCXSEND"","_$J_",""RTN"",",XCN=0,X=$$RNAME^OCXSEND3(0,0) - W !,X X ^%ZOSF("SAVE") K ^TMP("OCXSEND",$J,"RTN") - ; - Q " " - ; - ; -TEXT ; - ;;|$$RNAME^OCXSEND3(0,0)| ;SLC/RJS,CLA - OCX PACKAGE RULE TRANSPORT ROUTINE |OCXPATCH| ;|NOW| - ;;|OCXLIN2| - ;;|OCXLIN3| - ;; ; - ;;S ; - ;; ; - ;; N OCXDIER,QUIT,LINE,TEXT,REMOTE,LOCAL,D0,OPCODE,REF,OCXFLAG S QUIT=0 - ;; N OCXAUTO,OCZSCR - ;; ; - ;; D DOT - ;; I $L($T(VERSION^OCXOCMP)),($$VERSION^OCXOCMP="|CVER|"),1 - ;; E D Q - ;; .W ! - ;; .W !,"Rule Transport aborted, version mismatch." - ;; .W !,"Current Local version: ",$$VERSION^OCXOCMP - ;; .W !," Rule Transport Version: |CVER|" - ;; I '$D(DTIME) W !!,"DTIME not defined !!",!! Q - ;; W !!,"Order Check Expert System Rule Transporter" - ;; W !," Created: |NOW| at |RUCI|" - ;; W !," Current Date: ",$$NOW^|$$RNAME^OCXSEND3(0,1)|," at ",$$NETNAME^OCXSEND,!! - ;; S LASTFILE=0 K ^TMP("OCXRULE",$J) - ;; S ^TMP("OCXRULE",$J)=($P($H,",",2)+($H*86400)+(1*60*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG" - ;; S OCXFLAG="|OCXASK|" - ;; ; - ;;RUN ; - ;; ; - ;; W !,"Loading Data " D ^|$$RNAME^OCXSEND3(1,2)| - ;; ; - ;; S LINE=0 F S LINE=$O(^TMP("OCXRULE",$J,LINE)) Q:'LINE D Q:QUIT - ;; .D:'(LINE#50) STATUS^OCXOPOST(LINE,$O(^TMP("OCXRULE",$J," "),-1)) - ;; .S TEXT=$G(^TMP("OCXRULE",$J,LINE)) I $L(TEXT) D Q:QUIT - ;; ..S TEXT=$P(TEXT,";",2,999),OPCODE=$P(TEXT,U,1),TEXT=$P(TEXT,U,2,999) - ;; ..; - ;; ..I OPCODE="KEY" D DOT S LOCAL="",D0=$$GETFILE^|$$RNAME^OCXSEND3(0,1)|(+$P(TEXT,U,1),$P(TEXT,U,2),.LOCAL) S QUIT=(D0=(-10)) Q - ;; ..I OPCODE="R" S REF="REMOTE("_$P(TEXT,":",1)_":"_D0_$P(TEXT,":",2,99)_")" Q - ;; ..I OPCODE="D",$D(REF) S @REF=$P(TEXT,U,1,999) K REF Q - ;; ..; - ;; ..I OPCODE="EOR" S QUIT=$$COMPARE^|$$RNAME^OCXSEND3(1,1)|(.LOCAL,.REMOTE) K LOCAL,REMOTE Q - ;; ..I OPCODE="EOF" K LOCAL,REMOTE Q - ;; ..I OPCODE="SOF" W !," Installing '",TEXT,"' records... " Q - ;; ..I OPCODE="ROOT" D Q - ;; ...N FILE,DATA - ;; ...S FILE=U_$P(TEXT,U,1),DATA=$P(TEXT,U,2,3) - ;; ...I ($P($G(@FILE),U,1,2)=DATA) Q - ;; ...S $P(@FILE,U,1,2)=DATA - ;; ...W !," Restoring file #",(+$P(DATA,U,2))," zero node" - ;; ..; - ;; ..W !,"Unknown OpCode: ",OPCODE," in: ",TEXT S QUIT=$$PAUSE^|$$RNAME^OCXSEND3(0,1)| W ! - ;; ; - ;; K ^TMP("OCXRULE",$J) - ;; ; - ;; I $D(^OCXS) D - ;; .N FILE,DO,PD0,CNT - ;; .S FILE=0 F S FILE=$O(^OCXS(FILE)) Q:'FILE D - ;; ..S D0=0 F CNT=0:1 S PD0=D0,D0=$O(^OCXS(FILE,D0)) Q:'D0 - ;; ..S $P(^OCXS(FILE,0),U,3,4)=CNT_U_PD0 - ;; ; - ;; I $G(OCXDIER) D - ;; .W !!!!!!! - ;; .W !,?5,"******************** Warning ******************** " - ;; .W !,?7,+$G(OCXDIER)," data filing error",$S(($G(OCXDIER)=1):"",1:"s"),"." - ;; .W !,?7,"Some expert system rules may be incomplete." - ;; .W !,?5,"******************** Warning ******************** " - ;; I '$G(OCXDIER) W !!,?5," No data filing errors." - ;; W !!,"Transport Finished..." - ;; ; - ;; D - ;; .N OCXOETIM - ;; .D BMES^XPDUTL("---Creating Order Check Routines-----------------------------------") - ;; .D AUTO^OCXOCMP - ;; ; - ;; Q - ;; ; - ;;DOT Q:$G(OCXAUTO) W:($X>70) ! W " ." Q - ;; ; - ;;READ(OCXZ0,OCXZA,OCXZB,OCXZL) ; - ;; N OCXLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT - ;; Q:'$L($G(OCXZ0)) U - ;; S DIR(0)=OCXZ0 - ;; S:$L($G(OCXZA)) DIR("A")=OCXZA - ;; S:$L($G(OCXZB)) DIR("B")=OCXZB - ;; F OCXLINE=1:1:($G(OCXZL)-1) W ! - ;; D ^DIR - ;; I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U - ;; Q Y - ;; ; - ;;$ - ;1; +OCXSENDA ;SLC/RJS,CLA - BUILD RULE TRANSPORTER ROUTINES (Build Main Routine) ;6/12/02 12:03 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,74,96,105,143**;Dec 17,1997 + ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998 + ; +EN() ; + ; + N R,LINE,TEXT,NOW,RUCI,XCM + S NOW=$$NOW^OCXSEND3,RUCI=$$NETNAME^OCXSEND,CVER=$$VERSION^OCXOCMP + F LINE=1:1:999 S TEXT=$P($T(TEXT+LINE),";",2,999) Q:TEXT S TEXT=$P(TEXT,";",2,999) S R(LINE,0)=$$CONV^OCXSEND3(TEXT) + ; + M ^TMP("OCXSEND",$J,"RTN")=R + ; + S DIE="^TMP(""OCXSEND"","_$J_",""RTN"",",XCN=0,X=$$RNAME^OCXSEND3(0,0) + W !,X X ^%ZOSF("SAVE") W " ... ",XCM," Lines filed" K ^TMP("OCXSEND",$J,"RTN") + ; + Q XCM + ; + ; +TEXT ; + ;;|$$RNAME^OCXSEND3(0,0)| ;SLC/RJS,CLA - OCX PACKAGE RULE TRANSPORT ROUTINE |OCXPATCH| ;|NOW| + ;;|OCXLIN2| + ;;|OCXLIN3| + ;; ; + ;;S ; + ;; ; + ;; N OCXDIER,QUIT,LINE,TEXT,REMOTE,LOCAL,D0,OPCODE,REF,OCXFLAG S QUIT=0 + ;; N OCXAUTO,OCZSCR + ;; ; + ;; D DOT + ;; I $L($T(VERSION^OCXOCMP)),($$VERSION^OCXOCMP="|CVER|"),1 + ;; E D Q + ;; .W ! + ;; .W !,"Rule Transport aborted, version mismatch." + ;; .W !,"Current Local version: ",$$VERSION^OCXOCMP + ;; .W !," Rule Transport Version: |CVER|" + ;; I '$D(DTIME) W !!,"DTIME not defined !!",!! Q + ;; W !!,"Order Check Expert System Rule Transporter" + ;; W !," Created: |NOW| at |RUCI|" + ;; W !," Current Date: ",$$NOW^|$$RNAME^OCXSEND3(0,1)|," at ",$$NETNAME^OCXSEND,!! + ;; S LASTFILE=0 K ^TMP("OCXRULE",$J) + ;; S ^TMP("OCXRULE",$J)=($P($H,",",2)+($H*86400)+(1*60*60))_" <- ^TMP ENTRY EXPIRATION DATE FOR ^OCXOPURG" + ;; S OCXFLAG="|OCXASK|" + ;; ; + ;;RUN ; + ;; ; + ;; W !,"Loading Data " D ^|$$RNAME^OCXSEND3(1,2)| + ;; ; + ;; S LINE=0 F S LINE=$O(^TMP("OCXRULE",$J,LINE)) Q:'LINE D Q:QUIT + ;; .D:'(LINE#50) STATUS^OCXOPOST(LINE,$O(^TMP("OCXRULE",$J," "),-1)) + ;; .S TEXT=$G(^TMP("OCXRULE",$J,LINE)) I $L(TEXT) D Q:QUIT + ;; ..S TEXT=$P(TEXT,";",2,999),OPCODE=$P(TEXT,U,1),TEXT=$P(TEXT,U,2,999) + ;; ..; + ;; ..I OPCODE="KEY" D DOT S LOCAL="",D0=$$GETFILE^|$$RNAME^OCXSEND3(0,1)|(+$P(TEXT,U,1),$P(TEXT,U,2),.LOCAL) S QUIT=(D0=(-10)) Q + ;; ..I OPCODE="R" S REF="REMOTE("_$P(TEXT,":",1)_":"_D0_$P(TEXT,":",2,99)_")" Q + ;; ..I OPCODE="D",$D(REF) S @REF=$P(TEXT,U,1,999) K REF Q + ;; ..; + ;; ..I OPCODE="EOR" S QUIT=$$COMPARE^|$$RNAME^OCXSEND3(1,1)|(.LOCAL,.REMOTE) K LOCAL,REMOTE Q + ;; ..I OPCODE="EOF" K LOCAL,REMOTE Q + ;; ..I OPCODE="SOF" W !," Installing '",TEXT,"' records... " Q + ;; ..I OPCODE="ROOT" D Q + ;; ...N FILE,DATA + ;; ...S FILE=U_$P(TEXT,U,1),DATA=$P(TEXT,U,2,3) + ;; ...I ($P($G(@FILE),U,1,2)=DATA) Q + ;; ...S $P(@FILE,U,1,2)=DATA + ;; ...W !," Restoring file #",(+$P(DATA,U,2))," zero node" + ;; ..; + ;; ..W !,"Unknown OpCode: ",OPCODE," in: ",TEXT S QUIT=$$PAUSE^|$$RNAME^OCXSEND3(0,1)| W ! + ;; ; + ;; K ^TMP("OCXRULE",$J) + ;; ; + ;; I $D(^OCXS) D + ;; .N FILE,DO,PD0,CNT + ;; .S FILE=0 F S FILE=$O(^OCXS(FILE)) Q:'FILE D + ;; ..S D0=0 F CNT=0:1 S PD0=D0,D0=$O(^OCXS(FILE,D0)) Q:'D0 + ;; ..S $P(^OCXS(FILE,0),U,3,4)=CNT_U_PD0 + ;; ; + ;; I $G(OCXDIER) D + ;; .W !!!!!!! + ;; .W !,?5,"******************** Warning ******************** " + ;; .W !,?7,+$G(OCXDIER)," data filing error",$S(($G(OCXDIER)=1):"",1:"s"),"." + ;; .W !,?7,"Some expert system rules may be incomplete." + ;; .W !,?5,"******************** Warning ******************** " + ;; I '$G(OCXDIER) W !!,?5," No data filing errors." + ;; W !!,"Transport Finished..." + ;; ; + ;; D + ;; .N OCXOETIM + ;; .D BMES^XPDUTL("---Creating Order Check Routines-----------------------------------") + ;; .D AUTO^OCXOCMP + ;; ; + ;; Q + ;; ; + ;;DOT Q:$G(OCXAUTO) W:($X>70) ! W " ." Q + ;; ; + ;;READ(OCXZ0,OCXZA,OCXZB,OCXZL) ; + ;; N OCXLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT + ;; Q:'$L($G(OCXZ0)) U + ;; S DIR(0)=OCXZ0 + ;; S:$L($G(OCXZA)) DIR("A")=OCXZA + ;; S:$L($G(OCXZB)) DIR("B")=OCXZB + ;; F OCXLINE=1:1:($G(OCXZL)-1) W ! + ;; D ^DIR + ;; I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U + ;; Q Y + ;; ; + ;;$ + ;1; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORB3FUP1.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORB3FUP1.m index fd7602dd..5d2c7c38 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORB3FUP1.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORB3FUP1.m @@ -1,212 +1,185 @@ -ORB3FUP1 ; slc/CLA - Routine to support notification follow-up actions ; 4/8/08 9:32am - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**9,64,74,105,139,243**;Dec 17, 1997;Build 242 - Q -TYPE(ORBY,ORXQAID) ; return notif follow-up action type - N NIEN - S NIEN=$P($P(ORXQAID,";"),",",3) - S ORBY=$G(^ORD(100.9,NIEN,3)) - I ORBY="" S ORBY="INFO^" - E S ORBY=$P(ORBY,U,2) - Q -GUI(ORBY,ORXQAID) ; Notification follow-up for GUI called via API: ORB FOLLOW-UP - ; called by ORB FOLLOW-UP api: - S ORENVIR="GUI" - D PROCESS - Q -PROCESS ; main process for notification follow-up - ;ORXQAID = OR,dfn,nien; - ;XQADATA = placer num^placer id;filler num^filler id - ;XQAKILL = value of parameter ORB DELETE MECHANISM for notif in 100.9 - N ORPDIEN,ORN,ORDFN,ORSITE,ORFID,ORFIEN,ORKILL - D GETACT^XQALERT(ORXQAID) ;return follow-up action info - ;Q:'($D(XQADATA)) Q:'($D(XQAID)) - ;Q:($P(XQAID,",")'="OR") - ;call function rpc stored in xqarou with params from xqadata - D @XQAROU - K ORENVIR - Q -MSG ; display msg re: alert being processed for non-GUI follow-up actions - I $G(ORENVIR)'="GUI" D - .I $L($G(XQX)) W !!,"Processing alert: ",$P(XQX,U,3) H 1.5 - Q -DEL(ORBY,XQAID,ORKILL) ; delete an alert - N ORN - S ORN=$P($P(XQAID,";"),",",3) - I $G(ORKILL)=1!($G(ORKILL)=0) S XQAKILL=ORKILL - I $G(XQAKILL)="" S XQAKILL=$$XQAKILL^ORB3F1(ORN) - I $G(XQAKILL)="" S XQAKILL=1 - S ORBY="FALSE" - I $L($G(XQAID)) D DELETE^XQALERT S ORBY="TRUE" - K XQAKILL - Q -CSORD ;co-sign order(s) follow-up - K XQAKILL - N ORPT,ORDG,ORBXQAID,ORY S ORBXQAID=XQAID - S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid - ;the FLG code for orders requiring CO-SIGNATURE in ORQ1 is 'to be determined when ASU is available' - D DEL(.ORY,XQAID) ;until ASU is implemented, delete the alert and quit - Q ;quit until ASU is implemented - ;I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"ALL",???,"","") - ;I $G(ORENVIR)'="GUI" D - ;.D MSG - ;.S ORDG=$$DG^ORQOR1("ALL") ;get Display Group ien - ;.D EN^ORCB(ORPT,???,ORDG,???) - ;.K ^TMP("ORR",$J) - ;.D EN^ORQ1(ORPT_";DPT(",ORDG,???,"","","",0,0) - ;.S X="",X=$O(^TMP("ORR",$J,X)) Q:X="" I +$G(^TMP("ORR",$J,X,"TOT"))<1 D - ;..D DEL(.ORY,ORBXQAID) ;if no more orders req. co-sign, delete the alert - ;.K ^TMP("ORR",$J) - Q -EXDNR ;expiring dnr follow-up - K XQAKILL - N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID - S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid - N DNRORD,DNRY S DNRORD=$P(XQADATA,"@") - I $G(ORENVIR)="GUI" D - .S ORBY(1)=DNRY - I $G(ORENVIR)'="GUI" D - .D MSG - .D EN1^ORCB(DNRORD,"RENEW") ;display order, allow renewing, then delete - .D DEL(.ORY,ORBXQAID) - Q -UNLINKED ;unlinked provider follow-up - K XQAKILL - N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID - S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid - N ORNUM,ORUNY S ORNUM=$P(XQADATA,"@") - I $G(ORENVIR)="GUI" D - .S ORBY(1)=ORUNY - I $G(ORENVIR)'="GUI" D - .D MSG - .D EN1^ORCB(ORNUM,"REPLACE") ;display order, allow replace, then delete - .D DEL(.ORY,ORBXQAID) - Q -FLORD ;flagged order(s) follow-up - K XQAKILL - N ORPT,ORDG,X,ORBXQAID,ORY,ORBLMDEL - S ORBXQAID=XQAID - S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid - ;the FLG code for "FLAGGED" in ORQ1 is '12' - I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"ALL",12,"","") - I $G(ORENVIR)'="GUI" D - .D MSG - .S ORDG=$$DG^ORQOR1("ALL") ;get Display Group ien - .D EN^ORCB(ORPT,12,ORDG,.ORBLMDEL) - .K ^TMP("ORR",$J) - .Q:$G(ORBLMDEL)=1 ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM - .D EN^ORQ1(ORPT_";DPT(",ORDG,12,"","","",0,0) - .S X="",X=$O(^TMP("ORR",$J,X)) Q:X="" I +$G(^TMP("ORR",$J,X,"TOT"))<1 D - ..D DEL(.ORY,ORBXQAID) ;if no more flagged orders found, delete alert - .K ^TMP("ORR",$J) - Q -NEWORD ;new order(s) follow-up - K XQAKILL - N ORPT,ORDG,ORSDT,OREDT,ENT,X,ORBXQAID,ORY,ORBLMDEL - S ORSDT="",OREDT="",ENT="USR",ORBXQAID=XQAID - S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid - ;the FLG code for NEW orders since last reviewed orders in ORQ1 is '6' - I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"ALL",6,"","") - I $G(ORENVIR)'="GUI" D - .D MSG - .S ORDG=$$DG^ORQOR1("ALL") ;get Display Group ien - .D EN^ORCB(ORPT,6,ORDG,.ORBLMDEL) - .Q:$G(ORBLMDEL)=1 ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM - .D DEL(.ORY,ORBXQAID) ;delete the alert - Q -DCORD ;DC order(s) follow-up - K XQAKILL - N ORPT,ORDG,ORSDT,OREDT,ENT,X,ORBXQAID,ORY,ORBLMDEL - S ORSDT="",OREDT="",ENT="USR",ORBXQAID=XQAID - S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid - ;the FLG code for DC orders is '3' - I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"ALL",6,"","") - I $G(ORENVIR)'="GUI" D - .D MSG - .S ORDG=$$DG^ORQOR1("ALL") ;get Display Group ien - .D EN^ORCB(ORPT,6,ORDG,.ORBLMDEL) - .Q:$G(ORBLMDEL)=1 ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM - .D DEL(.ORY,ORBXQAID) ;delete the alert - Q -NUMORD ;detailed order display follow-up - return order number - K XQAKILL - N ORBXQAID,ORY S ORBXQAID=XQAID - S ORNUM=$P(XQADATA,"@") - I $G(ORENVIR)="GUI" D - .Q - I $G(ORENVIR)'="GUI" D - .D MSG - .D EN1^ORCB(+ORNUM,"NEW") ;display order, allow new order then delete - .D DEL(.ORY,ORBXQAID) - Q -ESORD ;order(s) requiring electronic signature follow-up - K XQAKILL - N ORPT,ORDG,ORBXQAID,ORY,ORX,ORZ,ORDERS,ORDNUM,ORQUIT,ORBLMDEL - S ORBXQAID=XQAID,ORDERS=0,ORQUIT=0 - S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid - ;the FLG code for UNSIGNED orders in ORQ1 is '11' - I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"ALL",11,"","") - I $G(ORENVIR)'="GUI" D - .D MSG - .S ORDG=$$DG^ORQOR1("ALL") ;get Display Group ien - .D EN^ORCB(ORPT,11,ORDG,.ORBLMDEL) - .K ^TMP("ORR",$J) ;clean up array - .Q:$G(ORBLMDEL)=1 ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM - .I $L($G(XQAID)) D ;EN^ORCB may kill XQAID in its follow-up - ..; - ..;get unsigned orders - if none exist, delete alert then quit: - ..D EN^ORQ1(ORPT_";DPT(",ORDG,11,"","","",0,0) - ..S ORX="",ORX=$O(^TMP("ORR",$J,ORX)) Q:ORX="" I +$G(^TMP("ORR",$J,ORX,"TOT"))<1 D DEL(.ORY,ORBXQAID) K ^TMP("ORR",$J) Q - ..; - ..;user does not have ORES key, delete user's alert: - ..I '$D(^XUSEC("ORES",DUZ)) S XQAKILL=1 D DEL(.ORY,ORBXQAID) K ^TMP("ORR",$J) Q - ..; - ..;if prov is NOT linked to pt via attending, primary, teams or PCMM: - ..I $$PPLINK^ORQPTQ1(DUZ,ORPT)=0 D - ...S ORX="" F S ORX=$O(^TMP("ORR",$J,ORX)) Q:ORX=""!(ORDERS=1) D - ....S ORZ="" F S ORZ=$O(^TMP("ORR",$J,ORX,ORZ)) Q:ORZ=""!(ORDERS=1) D - .....S ORDNUM=^TMP("ORR",$J,ORX,ORZ) - .....;quit if this unsigned order's last action was made by the user - .....I DUZ=+$$UNSIGNOR^ORQOR2(ORDNUM) S ORDERS=1 - ...I ORDERS'=1 D ;provider has no outstanding unsiged orders for pt - ....S XQAKILL=1 D DEL(.ORY,ORBXQAID) ;delete alert for this user - ..K ^TMP("ORR",$J) - Q -UNFLAG(ORPT) ;order unflagged - delete alert if no more flagged orders - N ORDG,ORDOIT,ORQUIT,X,XQAID,XQAKILL,XQAUSER - S ORDOIT=1,ORQUIT=0 - S ORDG=$$DG^ORQOR1("ALL") ;get Display Group ien - K ^TMP("ORR",$J) - D EN^ORQ1(ORPT_";DPT(",ORDG,12,"","","",0,0) - ;========DELETE ALERT (FOR ALL USERS) IF NO FLAGGED ORDERS AT ALL===== - S X="",X=$O(^TMP("ORR",$J,X)) Q:X="" I +$G(^TMP("ORR",$J,X,"TOT"))<1 D - .;if no more flagged orders found, delete alert: - .S XQAKILL=$$XQAKILL^ORB3F1(6) - .I $G(XQAKILL)="" S XQAKILL=1 - .S XQAID="OR,"_ORPT_",6" D DELETEA^XQALERT K XQAID,XQAKILL S ORQUIT=1 - Q:ORQUIT - ;========DELETE ALERT IF NO FLAGGED ORDERS LEFT RELATED TO THE USER THAT IS UNFLAGGING===== - S X="",X=$O(^TMP("ORR",$J,X)) Q:X="" D - .N Y S Y="" F S Y=$O(^TMP("ORR",$J,X,Y)) Q:'Y D - ..N ORDER S ORDER=$G(^TMP("ORR",$J,X,Y)) - ..I $$FLAGRULE^ORWORR1(+ORDER)=0 S ORDOIT=0 ; FOUND A FLAGGED ORDER THAT THE USER SHOULD GET - I ORDOIT D - .;if no more flagged orders found for this user, delete alert only for this user: - .S XQAKILL=1 - .S XQAID="OR,"_ORPT_",6" D DELETEA^XQALERT K XQAID,XQAKILL - ;========DELETE ALERT IF NO FLAGGED ORDERS LEFT RELATED TO THE USER THAT WAS THE ALERTED PROVIDER OF THE CURRENT ORDER===== - S ORDOIT=1 - ;get the alerted provider - I $G(ORIFN) D - .N ORD,ORACT S ORD=+$G(ORIFN),ORACT=$P($G(ORIFN),";",2) - .N ORUSR S ORUSR=$P($G(^OR(100,ORD,8,ORACT,3)),U,9) - .I ORUSR D - ..S X="",X=$O(^TMP("ORR",$J,X)) Q:X="" D - ...N Y S Y="" F S Y=$O(^TMP("ORR",$J,X,Y)) Q:'Y D - ....N ORDER S ORDER=$G(^TMP("ORR",$J,X,Y)) - ....I $$FLAGRULE^ORWORR1(+ORDER,ORUSR)=0 S ORDOIT=0 ; FOUND A FLAGGED ORDER THAT THE USER SHOULD GET - ..I ORDOIT D - ...;if no more flagged orders found for this user, delete alert only for this user: - ...S XQAKILL=1,XQAUSER=ORUSR - ...S XQAID="OR,"_ORPT_",6" D DELETEA^XQALERT K XQAID,XQAKILL,XQAUSER - K ^TMP("ORR",$J) - Q +ORB3FUP1 ; slc/CLA - Routine to support notification follow-up actions ;7/15/95 17:23 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**9,64,74,105,139**;Dec 17, 1997 + Q +TYPE(ORBY,ORXQAID) ; return notif follow-up action type + N NIEN + S NIEN=$P($P(ORXQAID,";"),",",3) + S ORBY=$G(^ORD(100.9,NIEN,3)) + I ORBY="" S ORBY="INFO^" + E S ORBY=$P(ORBY,U,2) + Q +GUI(ORBY,ORXQAID) ; Notification follow-up for GUI called via API: ORB FOLLOW-UP + ; called by ORB FOLLOW-UP api: + S ORENVIR="GUI" + D PROCESS + Q +PROCESS ; main process for notification follow-up + ;ORXQAID = OR,dfn,nien; + ;XQADATA = placer num^placer id;filler num^filler id + ;XQAKILL = value of parameter ORB DELETE MECHANISM for notif in 101.9 + N ORPDIEN,ORN,ORDFN,ORSITE,ORFID,ORFIEN,ORKILL + D GETACT^XQALERT(ORXQAID) ;return follow-up action info + ;Q:'($D(XQADATA)) Q:'($D(XQAID)) + ;Q:($P(XQAID,",")'="OR") + ;call function rpc stored in xqarou with params from xqadata + D @XQAROU + K ORENVIR + Q +MSG ; display msg re: alert being processed for non-GUI follow-up actions + I $G(ORENVIR)'="GUI" D + .I $L($G(XQX)) W !!,"Processing alert: ",$P(XQX,U,3) H 1.5 + Q +DEL(ORBY,XQAID,ORKILL) ; delete an alert + N ORN + S ORN=$P($P(XQAID,";"),",",3) + I $G(ORKILL)=1!($G(ORKILL)=0) S XQAKILL=ORKILL + I $G(XQAKILL)="" S XQAKILL=$$XQAKILL^ORB3F1(ORN) + I $G(XQAKILL)="" S XQAKILL=1 + S ORBY="FALSE" + I $L($G(XQAID)) D DELETE^XQALERT S ORBY="TRUE" + K XQAKILL + Q +CSORD ;co-sign order(s) follow-up + K XQAKILL + N ORPT,ORDG,ORBXQAID,ORY S ORBXQAID=XQAID + S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid + ;the FLG code for orders requiring CO-SIGNATURE in ORQ1 is 'to be determined when ASU is available' + D DEL(.ORY,XQAID) ;until ASU is implemented, delete the alert and quit + Q ;quit until ASU is implemented + ;I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"ALL",???,"","") + ;I $G(ORENVIR)'="GUI" D + ;.D MSG + ;.S ORDG=$$DG^ORQOR1("ALL") ;get Display Group ien + ;.D EN^ORCB(ORPT,???,ORDG,???) + ;.K ^TMP("ORR",$J) + ;.D EN^ORQ1(ORPT_";DPT(",ORDG,???,"","","",0,0) + ;.S X="",X=$O(^TMP("ORR",$J,X)) Q:X="" I +$G(^TMP("ORR",$J,X,"TOT"))<1 D + ;..D DEL(.ORY,ORBXQAID) ;if no more orders req. co-sign, delete the alert + ;.K ^TMP("ORR",$J) + Q +EXDNR ;expiring dnr follow-up + K XQAKILL + N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID + S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid + N DNRORD,DNRY S DNRORD=$P(XQADATA,"@") + I $G(ORENVIR)="GUI" D + .S ORBY(1)=DNRY + I $G(ORENVIR)'="GUI" D + .D MSG + .D EN1^ORCB(DNRORD,"RENEW") ;display order, allow renewing, then delete + .D DEL(.ORY,ORBXQAID) + Q +UNLINKED ;unlinked provider follow-up + K XQAKILL + N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID + S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid + N ORNUM,ORUNY S ORNUM=$P(XQADATA,"@") + I $G(ORENVIR)="GUI" D + .S ORBY(1)=ORUNY + I $G(ORENVIR)'="GUI" D + .D MSG + .D EN1^ORCB(ORNUM,"REPLACE") ;display order, allow replace, then delete + .D DEL(.ORY,ORBXQAID) + Q +FLORD ;flagged order(s) follow-up + K XQAKILL + N ORPT,ORDG,X,ORBXQAID,ORY,ORBLMDEL + S ORBXQAID=XQAID + S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid + ;the FLG code for "FLAGGED" in ORQ1 is '12' + I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"ALL",12,"","") + I $G(ORENVIR)'="GUI" D + .D MSG + .S ORDG=$$DG^ORQOR1("ALL") ;get Display Group ien + .D EN^ORCB(ORPT,12,ORDG,.ORBLMDEL) + .K ^TMP("ORR",$J) + .Q:$G(ORBLMDEL)=1 ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM + .D EN^ORQ1(ORPT_";DPT(",ORDG,12,"","","",0,0) + .S X="",X=$O(^TMP("ORR",$J,X)) Q:X="" I +$G(^TMP("ORR",$J,X,"TOT"))<1 D + ..D DEL(.ORY,ORBXQAID) ;if no more flagged orders found, delete alert + .K ^TMP("ORR",$J) + Q +NEWORD ;new order(s) follow-up + K XQAKILL + N ORPT,ORDG,ORSDT,OREDT,ENT,X,ORBXQAID,ORY,ORBLMDEL + S ORSDT="",OREDT="",ENT="USR",ORBXQAID=XQAID + S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid + ;the FLG code for NEW orders since last reviewed orders in ORQ1 is '6' + I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"ALL",6,"","") + I $G(ORENVIR)'="GUI" D + .D MSG + .S ORDG=$$DG^ORQOR1("ALL") ;get Display Group ien + .D EN^ORCB(ORPT,6,ORDG,.ORBLMDEL) + .Q:$G(ORBLMDEL)=1 ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM + .D DEL(.ORY,ORBXQAID) ;delete the alert + Q +DCORD ;DC order(s) follow-up + K XQAKILL + N ORPT,ORDG,ORSDT,OREDT,ENT,X,ORBXQAID,ORY,ORBLMDEL + S ORSDT="",OREDT="",ENT="USR",ORBXQAID=XQAID + S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid + ;the FLG code for DC orders is '3' + I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"ALL",6,"","") + I $G(ORENVIR)'="GUI" D + .D MSG + .S ORDG=$$DG^ORQOR1("ALL") ;get Display Group ien + .D EN^ORCB(ORPT,6,ORDG,.ORBLMDEL) + .Q:$G(ORBLMDEL)=1 ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM + .D DEL(.ORY,ORBXQAID) ;delete the alert + Q +NUMORD ;detailed order display follow-up - return order number + K XQAKILL + N ORBXQAID,ORY S ORBXQAID=XQAID + S ORNUM=$P(XQADATA,"@") + I $G(ORENVIR)="GUI" D + .Q + I $G(ORENVIR)'="GUI" D + .D MSG + .D EN1^ORCB(+ORNUM,"NEW") ;display order, allow new order then delete + .D DEL(.ORY,ORBXQAID) + Q +ESORD ;order(s) requiring electronic signature follow-up + K XQAKILL + N ORPT,ORDG,ORBXQAID,ORY,ORX,ORZ,ORDERS,ORDNUM,ORQUIT,ORBLMDEL + S ORBXQAID=XQAID,ORDERS=0,ORQUIT=0 + S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid + ;the FLG code for UNSIGNED orders in ORQ1 is '11' + I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"ALL",11,"","") + I $G(ORENVIR)'="GUI" D + .D MSG + .S ORDG=$$DG^ORQOR1("ALL") ;get Display Group ien + .D EN^ORCB(ORPT,11,ORDG,.ORBLMDEL) + .K ^TMP("ORR",$J) ;clean up array + .Q:$G(ORBLMDEL)=1 ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM + .I $L($G(XQAID)) D ;EN^ORCB may kill XQAID in its follow-up + ..; + ..;get unsigned orders - if none exist, delete alert then quit: + ..D EN^ORQ1(ORPT_";DPT(",ORDG,11,"","","",0,0) + ..S ORX="",ORX=$O(^TMP("ORR",$J,ORX)) Q:ORX="" I +$G(^TMP("ORR",$J,ORX,"TOT"))<1 D DEL(.ORY,ORBXQAID) K ^TMP("ORR",$J) Q + ..; + ..;user does not have ORES key, delete user's alert: + ..I '$D(^XUSEC("ORES",DUZ)) S XQAKILL=1 D DEL(.ORY,ORBXQAID) K ^TMP("ORR",$J) Q + ..; + ..;if prov is NOT linked to pt via attending, primary, teams or PCMM: + ..I $$PPLINK^ORQPTQ1(DUZ,ORPT)=0 D + ...S ORX="" F S ORX=$O(^TMP("ORR",$J,ORX)) Q:ORX=""!(ORDERS=1) D + ....S ORZ="" F S ORZ=$O(^TMP("ORR",$J,ORX,ORZ)) Q:ORZ=""!(ORDERS=1) D + .....S ORDNUM=^TMP("ORR",$J,ORX,ORZ) + .....;quit if this unsigned order's last action was made by the user + .....I DUZ=+$$UNSIGNOR^ORQOR2(ORDNUM) S ORDERS=1 + ...I ORDERS'=1 D ;provider has no outstanding unsiged orders for pt + ....S XQAKILL=1 D DEL(.ORY,ORBXQAID) ;delete alert for this user + ..K ^TMP("ORR",$J) + Q +UNFLAG(ORPT) ;order unflagged - delete alert if no more flagged orders + N ORDG + S ORDG=$$DG^ORQOR1("ALL") ;get Display Group ien + K ^TMP("ORR",$J) + D EN^ORQ1(ORPT_";DPT(",ORDG,12,"","","",0,0) + S X="",X=$O(^TMP("ORR",$J,X)) Q:X="" I +$G(^TMP("ORR",$J,X,"TOT"))<1 D + .;if no more flagged orders found, delete alert: + .S XQAKILL=$$XQAKILL^ORB3F1(6) + .I $G(XQAKILL)="" S XQAKILL=1 + .S XQAID="OR,"_ORPT_",6" D DELETEA^XQALERT K XQAID,XQAKILL + K ^TMP("ORR",$J) + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORB3FUP2.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORB3FUP2.m index 2ccede38..add436a1 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORB3FUP2.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORB3FUP2.m @@ -1,239 +1,229 @@ -ORB3FUP2 ; slc/CLA - Routine to support notification follow-up actions ;6/28/00 12:00 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**31,64,88,112,243**;Dec 17, 1997;Build 242 -RESULT ;STAT, orderer-flagged and site-flagged result follow-up - ;determine what pkg to get report/results from then do RPTLAB or RPTRAD - N ORBFILL S ORBFILL=$P($P(XQADATA,"|",2),"@",2) - I ORBFILL["LR" D RPTLAB - I ORBFILL["RA" D RPTRAD - I ORBFILL["GMRC" D RPTCON - Q -CSPN ;co-sign progress note(s) follow-up - K XQAKILL - N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID - S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid - I $G(ORENVIR)="GUI" ;entry pt to get notes req co-sign then quit - ;joel rtn to display notes req co-signature and allow co-sign on vt - ;if lm fup action completed D DEL^ORB3FUP1(.ORY,ORBXQAID) - Q -USPN ;unsigned progress note(s) follow-up - K XQAKILL - N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID - S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid - I $G(ORENVIR)="GUI" ;entry pt to get unsigned notes then quit - ;joel rtn to display notes req signature and allow signature on vt - ;if lm fup action completed D DEL^ORB3FUP1(.ORY,ORBXQAID) - Q -EXMED ;expiring med(s) follow-up - K XQAKILL - N ORPT,ORDG,ORBXQAID,ORY,ORBLMDEL - S ORBXQAID=XQAID - S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid - ;the FLG code for EXPIRING orders in ORQ1 is '5' - I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"RX",5,"","") - I $G(ORENVIR)'="GUI" D - .D MSG^ORB3FUP1 - .S ORDG=$$DG^ORQOR1("RX") ;get Display Group ien - .D EN^ORCB(ORPT,5,ORDG,.ORBLMDEL) - .K ^TMP("ORR",$J) - .Q:$G(ORBLMDEL)=1 ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM - .D EN^ORQ1(ORPT_";DPT(",ORDG,5,"","","",0,0) - .S X="",X=$O(^TMP("ORR",$J,X)) Q:X="" I +$G(^TMP("ORR",$J,X,"TOT"))<1 D - ..D DEL^ORB3FUP1(.ORY,ORBXQAID) ;if no more EXPIRING orders found, delete the alert - .K X,^TMP("ORR",$J) - Q -UVMED ;unverified med(s) follow-up - K XQAKILL - N ORPT,ORDG,ORBXQAID,ORY,ORBLMDEL,ORADT - S ORBXQAID=XQAID - S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid - ;the FLG code for UNVERIFIED (NURSE) orders in ORQ1 is '9' - I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"RX",9,"","") - I $G(ORENVIR)'="GUI" D - .D MSG^ORB3FUP1 - .S ORDG=$$DG^ORQOR1("RX") ;get Display Group ien - .D EN^ORCB(ORPT,9,ORDG,.ORBLMDEL) - .K ^TMP("ORR",$J) - .Q:$G(ORBLMDEL)=1 ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM - .; - .;if user doesn't have ORELSE or ORMAS keys (can't verify), - .; delete user's alert after display: - .I '$D(^XUSEC("ORELSE",DUZ)),('$D(^XUSEC("OREMAS",DUZ))) S XQAKILL=1 D DEL^ORB3FUP1(.ORY,ORBXQAID) Q - .; - .;get current admission date/time: - .N DFN S DFN=ORPT,VA200="" D INP^VADPT - .S ORADT=$P($G(VAIN(7)),U) - .S ORADT=$S('$L($G(ORADT)):$$FMADD^XLFDT($$NOW^XLFDT,"-30"),1:ORADT) - .; - .;if no more UNVERIFIED MED orders found (within current admission or - .; past 30 days), delete the alert: - .D EN^ORQ1(ORPT_";DPT(",ORDG,9,"",ORADT,$$NOW^XLFDT,0,0) - .S X="",X=$O(^TMP("ORR",$J,X)) Q:X="" I +$G(^TMP("ORR",$J,X,"TOT"))<1 D - ..D DEL^ORB3FUP1(.ORY,ORBXQAID) - .K X,^TMP("ORR",$J),VA200,VAIN - Q -UNVER ;unverified order(s) follow-up - K XQAKILL - N ORPT,ORDG,ORBXQAID,ORY,ORBLMDEL,ORADT - S ORBXQAID=XQAID - S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid - ;the FLG code for UNVERIFIED (NURSE) orders in ORQ1 is '9' - I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"ALL",9,"","") - I $G(ORENVIR)'="GUI" D - .D MSG^ORB3FUP1 - .S ORDG=$$DG^ORQOR1("ALL") ;get Display Group ien - .D EN^ORCB(ORPT,9,ORDG,.ORBLMDEL) - .K ^TMP("ORR",$J) - .Q:$G(ORBLMDEL)=1 ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM - .; - .;if user doesn't have ORELSE or ORMAS keys (can't verify), - .; delete user's alert after display: - .I '$D(^XUSEC("ORELSE",DUZ)),('$D(^XUSEC("OREMAS",DUZ))) S XQAKILL=1 D DEL^ORB3FUP1(.ORY,ORBXQAID) Q - .; - .;get current admission date/time: - .N DFN S DFN=ORPT,VA200="" D INP^VADPT - .S ORADT=$P($G(VAIN(7)),U) - .S ORADT=$S('$L($G(ORADT)):$$FMADD^XLFDT($$NOW^XLFDT,"-30"),1:ORADT) - .; - .;if no more UNVERIFIED orders found (within current admission or past - .; 30 days), delete the alert: - .D EN^ORQ1(ORPT_";DPT(",ORDG,9,"",ORADT,$$NOW^XLFDT,0,0) - .S X="",X=$O(^TMP("ORR",$J,X)) Q:X="" I +$G(^TMP("ORR",$J,X,"TOT"))<1 D - ..D DEL^ORB3FUP1(.ORY,ORBXQAID) - .K X,^TMP("ORR",$J),VA200,VAIN - Q -NEWCON ;new consult/request follow-up - K XQAKILL - N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID - S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid - ;I $G(ORENVIR)="GUI" D ;comment out until GUI follow-up - ;.entry pt to get new consults then quit - I $G(ORENVIR)'="GUI" D - .D MSG^ORB3FUP1 - .D EN^GMRCALRT(XQADATA,XQAID) ;display new c/r and allow action - .;D DEL^ORB3FUP1(.ORY,ORBXQAID) ;Dwight does the delete in GMRC - Q -UPCON ;updated consult/request follow-up - K XQAKILL - N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID - S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid - I $G(ORENVIR)'="GUI" D - .D MSG^ORB3FUP1 - .D EN^GMRCALRT(XQADATA,XQAID) ;display updated c/r and allow action - Q -DCCON ;cancelled, held or DCed consult/request follow-up - K XQAKILL - N ORPT,NXQADATA - S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid - ;I $G(ORENVIR)="GUI" D ;comment out until GUI follow-up - ;.entry pt to get new consults then quit - I $G(ORENVIR)'="GUI" D - .D MSG^ORB3FUP1 - .I XQADATA["GMRC" S NXQADATA=$P($P(XQADATA,"|",2),"@") D EN^GMRCEDIT(NXQADATA,XQAID) - .I +$G(NXQADATA)<1 D EN^GMRCEDIT(XQADATA,XQAID) - Q -RPTCON ;consult result follow-up - K XQAKILL - N NXQADATA - ;N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID - ;S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid - I $G(ORENVIR)="GUI" D DETAIL^ORQQCN(.ORBY,XQADATA) - I $G(ORENVIR)'="GUI" D - .D MSG^ORB3FUP1 - .D EN^GMRCALRT(XQADATA,XQAID) - .;I XQADATA["GMRC" S NXQADATA=$P($P(XQADATA,"|",2),"@") D EN^GMRCALRT(NXQADATA,XQAID) - .;I +$G(NXQADATA)<1 D EN^GMRCALRT(XQADATA,XQAID) - .;D DEL^ORB3FUP1(.ORY,ORBXQAID) ;Dwight does the delete in GMRC - Q -RPTAP ; AP lab result follow-up - K XQAKILL - N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID - S ORPT=$P($P(ORBXQAID,";"),",",2) ;get pt dfn from xqaid - N ORACCNUM,ORDTSTKN S ORACCNUM=$P(XQADATA,U,2),ORDTSTKN=$P(XQADATA,U,3) - I $G(ORENVIR)'="GUI" D - .D MSG^ORB3FUP1 - .D EN1^ORCXPND(ORPT,ORACCNUM_"-"_ORDTSTKN,"LABS") - .D DEL^ORB3FUP1(.ORY,ORBXQAID) - Q -RPTLAB ;lab result follow-up - K XQAKILL - N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID - S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid - N ORDER,ORLAB S ORDER=$P(XQADATA,"@") - I $G(ORENVIR)="GUI" D DETAIL^ORQQLR(.ORBY,ORPT,ORDER) - I $G(ORENVIR)'="GUI" D - .D MSG^ORB3FUP1 - .;S ORLAB=$$OETOLAB^ORQQLR1(ORDER) - .;Q:'$L($G(ORLAB)) - .;D EN1^ORCXPND(ORPT,ORLAB,"LABS") ;api used lab # pre-6/97 - .D EN1^ORCXPND(ORPT,ORDER,"LABS") - .D DEL^ORB3FUP1(.ORY,ORBXQAID) - Q -RPTRAD ;radiology result follow-up for HL7-triggered notifications - K XQAKILL - N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID - S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid - N INVDT,CASE S INVDT="",CASE="" - ;XQADATA is different for HL7-triggered vs. radiology pkg triggered - S INVDT=$P(XQADATA,"~",2),CASE=$P($P(XQADATA,"~",3),"@") - I $G(ORENVIR)="GUI" D DETAIL^ORQQRA(.ORBY,ORPT,INVDT,CASE) - I $G(ORENVIR)'="GUI" D - .D MSG^ORB3FUP1 - .D EN1^ORCXPND(ORPT,INVDT_"-"_CASE,"XRAYS") - .D DEL^ORB3FUP1(.ORY,ORBXQAID) - Q -RPTRAD2 ;radiology result follow-up for radiology pkg-triggered notifications - K XQAKILL - N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID - S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid - N INVDT,CASE S INVDT="",CASE="" - ;XQADATA is different for HL7-triggered vs. radiology pkg triggered - S INVDT=$P(XQADATA,"~",1),CASE=$P(XQADATA,"~",2) - I $G(ORENVIR)="GUI" D DETAIL^ORQQRA(.ORBY,ORPT,INVDT,CASE) - I $G(ORENVIR)'="GUI" D - .D MSG^ORB3FUP1 - .D EN1^ORCXPND(ORPT,INVDT_"-"_CASE,"XRAYS") - .D DEL^ORB3FUP1(.ORY,ORBXQAID) - Q -EXOI ;expiring flagged orderable items follow-up - K XQAKILL - N ORPT,ORDG,ORBXQAID,ORY,ORBLMDEL - S ORBXQAID=XQAID - S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid - ;the FLG code for EXPIRING orders in ORQ1 is '5' - I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"ALL",5,"","") - I $G(ORENVIR)'="GUI" D - .D MSG^ORB3FUP1 - .S ORDG=$$DG^ORQOR1("ALL") ;get Display Group ien - .D EN^ORCB(ORPT,5,ORDG,.ORBLMDEL) - .K ^TMP("ORR",$J) - .Q:$G(ORBLMDEL)=1 ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM - .D EN^ORQ1(ORPT_";DPT(",ORDG,5,"","","",0,0) - .S X="",X=$O(^TMP("ORR",$J,X)) Q:X="" I +$G(^TMP("ORR",$J,X,"TOT"))<1 D - ..D DEL^ORB3FUP1(.ORY,ORBXQAID) ;if no more EXPIRING orders found, delete the alert - .K X,^TMP("ORR",$J) - Q -INTCON ;consult interpretation follow-up - K XQAKILL - N NXQADATA - I $G(ORENVIR)'="GUI" D - .D MSG^ORB3FUP1 - .R !!?5,"This alert must be processed in the CPRS GUI.",X:10 - .K X - Q -CHGRAD ;radiology follow-up for #67 Imaging Request Changed - K XQAKILL - N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID - S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid - I $G(ORENVIR)'="GUI" D - .D MSG^ORB3FUP1 - .I $L($T(EN1^RAO7PC4))>0 D - ..D EN1^RAO7PC4 ;display before and after change(s) - ..D DEL^ORB3FUP1(.ORY,ORBXQAID) - Q -INFODEL ;follow-up action to delete "informational" alerts - K XQAKILL - N ORY,ORBXQAID - S ORBXQAID=XQAID - D MSG^ORB3FUP1 - D DEL^ORB3FUP1(.ORY,ORBXQAID) - Q +ORB3FUP2 ; slc/CLA - Routine to support notification follow-up actions ;6/28/00 12:00 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**31,64,88,112**;Dec 17, 1997 +RESULT ;STAT, orderer-flagged and site-flagged result follow-up + ;determine what pkg to get report/results from then do RPTLAB or RPTRAD + N ORBFILL S ORBFILL=$P($P(XQADATA,"|",2),"@",2) + I ORBFILL["LR" D RPTLAB + I ORBFILL["RA" D RPTRAD + I ORBFILL["GMRC" D RPTCON + Q +CSPN ;co-sign progress note(s) follow-up + K XQAKILL + N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID + S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid + I $G(ORENVIR)="GUI" ;entry pt to get notes req co-sign then quit + ;joel rtn to display notes req co-signature and allow co-sign on vt + ;if lm fup action completed D DEL^ORB3FUP1(.ORY,ORBXQAID) + Q +USPN ;unsigned progress note(s) follow-up + K XQAKILL + N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID + S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid + I $G(ORENVIR)="GUI" ;entry pt to get unsigned notes then quit + ;joel rtn to display notes req signature and allow signature on vt + ;if lm fup action completed D DEL^ORB3FUP1(.ORY,ORBXQAID) + Q +EXMED ;expiring med(s) follow-up + K XQAKILL + N ORPT,ORDG,ORBXQAID,ORY,ORBLMDEL + S ORBXQAID=XQAID + S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid + ;the FLG code for EXPIRING orders in ORQ1 is '5' + I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"RX",5,"","") + I $G(ORENVIR)'="GUI" D + .D MSG^ORB3FUP1 + .S ORDG=$$DG^ORQOR1("RX") ;get Display Group ien + .D EN^ORCB(ORPT,5,ORDG,.ORBLMDEL) + .K ^TMP("ORR",$J) + .Q:$G(ORBLMDEL)=1 ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM + .D EN^ORQ1(ORPT_";DPT(",ORDG,5,"","","",0,0) + .S X="",X=$O(^TMP("ORR",$J,X)) Q:X="" I +$G(^TMP("ORR",$J,X,"TOT"))<1 D + ..D DEL^ORB3FUP1(.ORY,ORBXQAID) ;if no more EXPIRING orders found, delete the alert + .K X,^TMP("ORR",$J) + Q +UVMED ;unverified med(s) follow-up + K XQAKILL + N ORPT,ORDG,ORBXQAID,ORY,ORBLMDEL,ORADT + S ORBXQAID=XQAID + S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid + ;the FLG code for UNVERIFIED (NURSE) orders in ORQ1 is '9' + I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"RX",9,"","") + I $G(ORENVIR)'="GUI" D + .D MSG^ORB3FUP1 + .S ORDG=$$DG^ORQOR1("RX") ;get Display Group ien + .D EN^ORCB(ORPT,9,ORDG,.ORBLMDEL) + .K ^TMP("ORR",$J) + .Q:$G(ORBLMDEL)=1 ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM + .; + .;if user doesn't have ORELSE or ORMAS keys (can't verify), + .; delete user's alert after display: + .I '$D(^XUSEC("ORELSE",DUZ)),('$D(^XUSEC("OREMAS",DUZ))) S XQAKILL=1 D DEL^ORB3FUP1(.ORY,ORBXQAID) Q + .; + .;get current admission date/time: + .N DFN S DFN=ORPT,VA200="" D INP^VADPT + .S ORADT=$P($G(VAIN(7)),U) + .S ORADT=$S('$L($G(ORADT)):$$FMADD^XLFDT($$NOW^XLFDT,"-30"),1:ORADT) + .; + .;if no more UNVERIFIED MED orders found (within current admission or + .; past 30 days), delete the alert: + .D EN^ORQ1(ORPT_";DPT(",ORDG,9,"",ORADT,$$NOW^XLFDT,0,0) + .S X="",X=$O(^TMP("ORR",$J,X)) Q:X="" I +$G(^TMP("ORR",$J,X,"TOT"))<1 D + ..D DEL^ORB3FUP1(.ORY,ORBXQAID) + .K X,^TMP("ORR",$J),VA200,VAIN + Q +UNVER ;unverified order(s) follow-up + K XQAKILL + N ORPT,ORDG,ORBXQAID,ORY,ORBLMDEL,ORADT + S ORBXQAID=XQAID + S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid + ;the FLG code for UNVERIFIED (NURSE) orders in ORQ1 is '9' + I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"ALL",9,"","") + I $G(ORENVIR)'="GUI" D + .D MSG^ORB3FUP1 + .S ORDG=$$DG^ORQOR1("ALL") ;get Display Group ien + .D EN^ORCB(ORPT,9,ORDG,.ORBLMDEL) + .K ^TMP("ORR",$J) + .Q:$G(ORBLMDEL)=1 ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM + .; + .;if user doesn't have ORELSE or ORMAS keys (can't verify), + .; delete user's alert after display: + .I '$D(^XUSEC("ORELSE",DUZ)),('$D(^XUSEC("OREMAS",DUZ))) S XQAKILL=1 D DEL^ORB3FUP1(.ORY,ORBXQAID) Q + .; + .;get current admission date/time: + .N DFN S DFN=ORPT,VA200="" D INP^VADPT + .S ORADT=$P($G(VAIN(7)),U) + .S ORADT=$S('$L($G(ORADT)):$$FMADD^XLFDT($$NOW^XLFDT,"-30"),1:ORADT) + .; + .;if no more UNVERIFIED orders found (within current admission or past + .; 30 days), delete the alert: + .D EN^ORQ1(ORPT_";DPT(",ORDG,9,"",ORADT,$$NOW^XLFDT,0,0) + .S X="",X=$O(^TMP("ORR",$J,X)) Q:X="" I +$G(^TMP("ORR",$J,X,"TOT"))<1 D + ..D DEL^ORB3FUP1(.ORY,ORBXQAID) + .K X,^TMP("ORR",$J),VA200,VAIN + Q +NEWCON ;new consult/request follow-up + K XQAKILL + N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID + S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid + ;I $G(ORENVIR)="GUI" D ;comment out until GUI follow-up + ;.entry pt to get new consults then quit + I $G(ORENVIR)'="GUI" D + .D MSG^ORB3FUP1 + .D EN^GMRCALRT(XQADATA,XQAID) ;display new c/r and allow action + .;D DEL^ORB3FUP1(.ORY,ORBXQAID) ;Dwight does the delete in GMRC + Q +UPCON ;updated consult/request follow-up + K XQAKILL + N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID + S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid + I $G(ORENVIR)'="GUI" D + .D MSG^ORB3FUP1 + .D EN^GMRCALRT(XQADATA,XQAID) ;display updated c/r and allow action + Q +DCCON ;cancelled, held or DCed consult/request follow-up + K XQAKILL + N ORPT,NXQADATA + S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid + ;I $G(ORENVIR)="GUI" D ;comment out until GUI follow-up + ;.entry pt to get new consults then quit + I $G(ORENVIR)'="GUI" D + .D MSG^ORB3FUP1 + .I XQADATA["GMRC" S NXQADATA=$P($P(XQADATA,"|",2),"@") D EN^GMRCEDIT(NXQADATA,XQAID) + .I +$G(NXQADATA)<1 D EN^GMRCEDIT(XQADATA,XQAID) + Q +RPTCON ;consult result follow-up + K XQAKILL + N NXQADATA + ;N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID + ;S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid + I $G(ORENVIR)="GUI" D DETAIL^ORQQCN(.ORBY,XQADATA) + I $G(ORENVIR)'="GUI" D + .D MSG^ORB3FUP1 + .D EN^GMRCALRT(XQADATA,XQAID) + .;I XQADATA["GMRC" S NXQADATA=$P($P(XQADATA,"|",2),"@") D EN^GMRCALRT(NXQADATA,XQAID) + .;I +$G(NXQADATA)<1 D EN^GMRCALRT(XQADATA,XQAID) + .;D DEL^ORB3FUP1(.ORY,ORBXQAID) ;Dwight does the delete in GMRC + Q +RPTLAB ;lab result follow-up + K XQAKILL + N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID + S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid + N ORDER,ORLAB S ORDER=$P(XQADATA,"@") + I $G(ORENVIR)="GUI" D DETAIL^ORQQLR(.ORBY,ORPT,ORDER) + I $G(ORENVIR)'="GUI" D + .D MSG^ORB3FUP1 + .;S ORLAB=$$OETOLAB^ORQQLR1(ORDER) + .;Q:'$L($G(ORLAB)) + .;D EN1^ORCXPND(ORPT,ORLAB,"LABS") ;api used lab # pre-6/97 + .D EN1^ORCXPND(ORPT,ORDER,"LABS") + .D DEL^ORB3FUP1(.ORY,ORBXQAID) + Q +RPTRAD ;radiology result follow-up for HL7-triggered notifications + K XQAKILL + N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID + S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid + N INVDT,CASE S INVDT="",CASE="" + ;XQADATA is different for HL7-triggered vs. radiology pkg triggered + S INVDT=$P(XQADATA,"~",2),CASE=$P($P(XQADATA,"~",3),"@") + I $G(ORENVIR)="GUI" D DETAIL^ORQQRA(.ORBY,ORPT,INVDT,CASE) + I $G(ORENVIR)'="GUI" D + .D MSG^ORB3FUP1 + .D EN1^ORCXPND(ORPT,INVDT_"-"_CASE,"XRAYS") + .D DEL^ORB3FUP1(.ORY,ORBXQAID) + Q +RPTRAD2 ;radiology result follow-up for radiology pkg-triggered notifications + K XQAKILL + N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID + S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid + N INVDT,CASE S INVDT="",CASE="" + ;XQADATA is different for HL7-triggered vs. radiology pkg triggered + S INVDT=$P(XQADATA,"~",1),CASE=$P(XQADATA,"~",2) + I $G(ORENVIR)="GUI" D DETAIL^ORQQRA(.ORBY,ORPT,INVDT,CASE) + I $G(ORENVIR)'="GUI" D + .D MSG^ORB3FUP1 + .D EN1^ORCXPND(ORPT,INVDT_"-"_CASE,"XRAYS") + .D DEL^ORB3FUP1(.ORY,ORBXQAID) + Q +EXOI ;expiring flagged orderable items follow-up + K XQAKILL + N ORPT,ORDG,ORBXQAID,ORY,ORBLMDEL + S ORBXQAID=XQAID + S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid + ;the FLG code for EXPIRING orders in ORQ1 is '5' + I $G(ORENVIR)="GUI" D LIST^ORQOR1(.ORBY,ORPT,"ALL",5,"","") + I $G(ORENVIR)'="GUI" D + .D MSG^ORB3FUP1 + .S ORDG=$$DG^ORQOR1("ALL") ;get Display Group ien + .D EN^ORCB(ORPT,5,ORDG,.ORBLMDEL) + .K ^TMP("ORR",$J) + .Q:$G(ORBLMDEL)=1 ;if EN^ORCB rtns ORBLMDEL=1, alert was removed in LM + .D EN^ORQ1(ORPT_";DPT(",ORDG,5,"","","",0,0) + .S X="",X=$O(^TMP("ORR",$J,X)) Q:X="" I +$G(^TMP("ORR",$J,X,"TOT"))<1 D + ..D DEL^ORB3FUP1(.ORY,ORBXQAID) ;if no more EXPIRING orders found, delete the alert + .K X,^TMP("ORR",$J) + Q +INTCON ;consult interpretation follow-up + K XQAKILL + N NXQADATA + I $G(ORENVIR)'="GUI" D + .D MSG^ORB3FUP1 + .R !!?5,"This alert must be processed in the CPRS GUI.",X:10 + .K X + Q +CHGRAD ;radiology follow-up for #67 Imaging Request Changed + K XQAKILL + N ORPT,ORBXQAID,ORY S ORBXQAID=XQAID + S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid + I $G(ORENVIR)'="GUI" D + .D MSG^ORB3FUP1 + .I $L($T(EN1^RAO7PC4))>0 D + ..D EN1^RAO7PC4 ;display before and after change(s) + ..D DEL^ORB3FUP1(.ORY,ORBXQAID) + Q +INFODEL ;follow-up action to delete "informational" alerts + K XQAKILL + N ORY,ORBXQAID + S ORBXQAID=XQAID + D MSG^ORB3FUP1 + D DEL^ORB3FUP1(.ORY,ORBXQAID) + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORB3LAB.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORB3LAB.m index 519087cc..878eb389 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORB3LAB.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORB3LAB.m @@ -1,17 +1,15 @@ -ORB3LAB ; slc/CLA/TC - Routine to trigger Lab-related notifications ;10/14/03 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**210,243**;Dec 17, 1997;Build 242 - ; -LAB(ORDFN,ORLRDFN,ORLRI,ORLRA,ORLRSS,ORXQA) ;trigger Lab Anatomic Path notifs - ; called by SEND^LRAPRES1 (DBIA #4287) - ; - N ORBMSG,ORAPMD,ORBADUZ,ORSRPT,ORACCNO - I '$D(ORXQA) D - . S ORAPMD=$S(ORLRSS="AU":$P(ORLRA,U,12),1:$P(ORLRA,U,7)) ;provider/physician "ordering" the ap test - . I $L(ORAPMD) S ORBADUZ(ORAPMD)="" - I $D(ORXQA) M ORBADUZ=ORXQA - S ORSRPT=$S($D(^LR(ORLRDFN,84,0))!($D(^LR(ORLRDFN,ORLRSS,ORLRI,1.2,0))):" supplmntl rpt",1:"") ; AP supplmntl rpt - DBIA #5157 - S ORBMSG=$S(ORLRSS="AU":"Autopsy",ORLRSS="CY":"Cytology",ORLRSS="SP":"Surgical Pathology",ORLRSS="EM":"Electron Microscopy",1:"Anatomic Pathology") - S ORBMSG=ORBMSG_ORSRPT_" results available." - S ORACCNO=$P(ORLRA,U,6) ;accession # of lab section - D EN^ORB3(71,ORDFN,"",.ORBADUZ,ORBMSG,ORLRSS_U_ORACCNO_U_ORLRI) ;XQADATA="Lab section^Accession#^DT specimen taken (inverse format)" - Q +ORB3LAB ; slc/CLA - Routine to trigger Lab-related notifications ;10/14/03 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**210**;Dec 17, 1997 + ; +LAB(DFN,LRDFN,LRI,LRA,LRSS) ;trigger Lab Anatomic Path notifs + ; called by ADD^LRWOMEN (DBIA #4287) + ; + N ORBMSG,APMD,ORBADUZ,SRPT + S APMD=$P(LRA,U,7) ;provider/physician "ordering" the ap test + I $L(APMD) S ORBADUZ(APMD)="" + S SRPT=$P(LRA,U,15) ;original release date + S SRPT=$S($L(SRPT):" supplmntl rpt",1:"") + S ORBMSG=$S(LRSS="CY":"Cytology",LRSS="SP":"Surgical Pathology",1:"Anatomic Pathology") + S ORBMSG=ORBMSG_SRPT_" results available." + D EN^ORB3(71,DFN,"",.ORBADUZ,ORBMSG,"") + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORBCMA1.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORBCMA1.m index 514a5bd2..abdf7434 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORBCMA1.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORBCMA1.m @@ -1,103 +1,99 @@ -ORBCMA1 ; SLC/JLI - Pharmacy Calls for Windows Dialog [ 3/7/2006 ] - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**133,243**;Dec 17, 1997;Build 242 - ;;OR BCMA ORDER COM V1.0 ;**133**; Jan 19, 2002 - ; -ODSLCT(LST,PSTYPE,DFN,LOC) ; return default lists for dialog - ; PSTYPE: pharmacy type (U=unit dose, F=IV fluids, O=outpatient) - N ILST S ILST=0 - S ILST=ILST+1,LST(ILST)="~Priority" D PRIOR - S ILST=ILST+1,LST(ILST)="~DispMsg" - S ILST=ILST+1,LST(ILST)="d"_$$DISPMSG - ; - ; I PSTYPE="F" D Q ; IV Fluids - ; . S ILST=ILST+1,LST(ILST)="~ShortList" D SHORT - ; - I PSTYPE="O" D ; Outpatient - . S ILST=ILST+1,LST(ILST)="~Refills" - . S ILST=ILST+1,LST(ILST)="d0^0" - . S ILST=ILST+1,LST(ILST)="~Pickup" - . S ILST=ILST+1,LST(ILST)="d"_$$DEFPICK($G(LOC)) - . ; S ILST=ILST+1,LST(ILST)="~Supply" - . ; S ILST=ILST+1,LST(ILST)="d^"_$$DEFSPLY(DFN) - Q -PRIOR ; from DLGSLCT, get list of allowed priorities - N X,XREF - S X=0 - S X=$O(^ORD(101.42,"B","DONE",X)) - S ILST=ILST+1,LST(ILST)="d"_X_U_$P(^ORD(101.42,X,0),U,2) - Q -DEFPICK(LOC) ; return default routing - N X,DLG,PRMT - S DLG=$O(^ORD(101.41,"AB","PSO OERR",0)),X="" - S PRMT=$O(^ORD(101.41,"AB","OR GTX ROUTING",0)) - I $D(^TMP("ORECALL",$J,+DLG,+PRMT,1)) S X=^(1) - I X'="" S EDITONLY=1 Q X ; EDITONLY used by default action - ; - S X=$$GET^XPAR("ALL^"_"LOC.`"_LOC,"ORWDPS ROUTING DEFAULT",1,"I") - I X="C" S X="C^in Clinic" G XPICK - I X="M" S X="M^by Mail" G XPICK - I X="W" S X="W^at Window" G XPICK - I X="N" S X="" G XPICK - I X="" S X=$S($D(^PSX(550,"C")):"M^by Mail",1:"W^at Window") -XPICK Q X - ; -DEFSPLY(DFN) ; return default days supply for this patient - N ORWX - S ORWX("PATIENT")=DFN - D DSUP^PSOSIGDS(.ORWX) - Q $G(ORWX("DAYS SUPPLY")) - ; -DFLTSPLY(VAL,UPD,SCH,PAT,DRG) ; return days supply given quantity - ; VAL: default days supply - N ORWX,I - S ORWX("PATIENT")=PAT - I DRG S ORWX("DRUG")=DRG - F I=1:1:$L(UPD,U)-1 D - . S ORWX("DOSE ORDERED",I)=$P(UPD,U,I) - . S ORWX("SCHEDULE",I)=$P(SCH,U,I) - D DSUP^PSOSIGDS(.ORWX) - S VAL=$G(ORWX("DAYS SUPPLY")) - Q -DISPMSG() ; return 1 to suppress dispense message - Q +$$GET^XPAR("ALL","ORWDPS SUPPRESS DISPENSE MSG",1,"I") - ; -SCHALL(LST) ; return all schedules - N ILST,SCH,IEN,EXP,TYP,X0 - K ^TMP($J,"ORBCMA1 SCHALL") - D AP^PSS51P1("PSJ",,,,"ORBCMA1 SCHALL") - S ILST=0,SCH="" - F S SCH=$O(^TMP($J,"ORBCMA1 SCHALL","APPSJ",SCH)) Q:SCH="" D - . I (SCH="STAT")!(SCH="NOW") D - .. S IEN=$O(^TMP($J,"ORBCMA1 SCHALL","APPSJ",SCH,"")) - .. S EXP=$G(^TMP($J,"ORBCMA1 SCHALL",SCH,8)) - .. S TYP=$P($G(^TMP($J,"ORBCMA1 SCHALL",SCH,5)),U) - .. S ILST=ILST+1,LST(ILST)=SCH_U_EXP_U_TYP - K ^TMP($J,"ORBCMA1 SCHALL") - Q -FORMALT(ORLST,IEN,PSTYPE) ; return a list of formulary alternatives - N PSID,I - S IEN=+$P(^ORD(101.43,IEN,0),U,2) - D EN1^PSSUTIL1(.IEN,PSTYPE) - S PSID=0,I=0 - F S PSID=$O(IEN(PSID)) Q:'PSID D - . S OI=+$O(^ORD(101.43,"ID",PSID_";99PSP",0)) - . I OI S I=I+1,ORLST(I)=OI,$P(ORLST(I),U,2)=$P(^ORD(101.43,OI,0),U) - Q -DOSEALT(LST,DDRUG,CUROI,PSTYPE) ; return a list of formulary alternatives for dose - N I,OI,ORWLST,ILST S ILST=0 - D ENRFA^PSJORUTL(DDRUG,PSTYPE,.ORWLST) - S I=0 F S I=$O(ORWLST(I)) Q:'I D - . S OI=+$O(^ORD(101.43,"ID",+$P(ORWLST(I),U,4)_";99PSP",0)) - . I OI,OI'=CUROI S ILST=ILST+1,LST(ILST)=OI_U_$P(^ORD(101.43,OI,0),U) - Q -FAILDEA(FAIL,OI,ORNP,PSTYPE) ; return 1 if DEA check fails for this provider - N DEAFLG,PSOI - S FAIL=0,PSOI=+$P($G(^ORD(101.43,+$G(OI),0)),U,2) Q:PSOI'>0 - I '$L($T(OIDEA^PSSUTLA1)) Q - S DEAFLG=$$OIDEA^PSSUTLA1(PSOI,PSTYPE) Q:DEAFLG'>0 - I '$L($P($G(^VA(200,+$G(ORNP),"PS")),U,2)),'$L($P($G(^("PS")),U,3)) S FAIL=1 - Q -CHK94(VAL) ; return 1 if patch 94 has been installed - S VAL=0 - I $O(^ORD(101.41,"B","PS MEDS",0)) S VAL=1 - Q +ORBCMA1 ; SLC/JLI - Pharmacy Calls for Windows Dialog [ 2/11/02 4:30PM ] + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**133**;Dec 17, 1997 + ;;OR BCMA ORDER COM V1.0 ;**133**; Jan 19, 2002 + ; +ODSLCT(LST,PSTYPE,DFN,LOC) ; return default lists for dialog + ; PSTYPE: pharmacy type (U=unit dose, F=IV fluids, O=outpatient) + N ILST S ILST=0 + S ILST=ILST+1,LST(ILST)="~Priority" D PRIOR + S ILST=ILST+1,LST(ILST)="~DispMsg" + S ILST=ILST+1,LST(ILST)="d"_$$DISPMSG + ; + ; I PSTYPE="F" D Q ; IV Fluids + ; . S ILST=ILST+1,LST(ILST)="~ShortList" D SHORT + ; + I PSTYPE="O" D ; Outpatient + . S ILST=ILST+1,LST(ILST)="~Refills" + . S ILST=ILST+1,LST(ILST)="d0^0" + . S ILST=ILST+1,LST(ILST)="~Pickup" + . S ILST=ILST+1,LST(ILST)="d"_$$DEFPICK($G(LOC)) + . ; S ILST=ILST+1,LST(ILST)="~Supply" + . ; S ILST=ILST+1,LST(ILST)="d^"_$$DEFSPLY(DFN) + Q +PRIOR ; from DLGSLCT, get list of allowed priorities + N X,XREF + S X=0 + S X=$O(^ORD(101.42,"B","DONE",X)) + S ILST=ILST+1,LST(ILST)="d"_X_U_$P(^ORD(101.42,X,0),U,2) + Q +DEFPICK(LOC) ; return default routing + N X,DLG,PRMT + S DLG=$O(^ORD(101.41,"AB","PSO OERR",0)),X="" + S PRMT=$O(^ORD(101.41,"AB","OR GTX ROUTING",0)) + I $D(^TMP("ORECALL",$J,+DLG,+PRMT,1)) S X=^(1) + I X'="" S EDITONLY=1 Q X ; EDITONLY used by default action + ; + S X=$$GET^XPAR("ALL^"_"LOC.`"_LOC,"ORWDPS ROUTING DEFAULT",1,"I") + I X="C" S X="C^in Clinic" G XPICK + I X="M" S X="M^by Mail" G XPICK + I X="W" S X="W^at Window" G XPICK + I X="N" S X="" G XPICK + I X="" S X=$S($D(^PSX(550,"C")):"M^by Mail",1:"W^at Window") +XPICK Q X + ; +DEFSPLY(DFN) ; return default days supply for this patient + N ORWX + S ORWX("PATIENT")=DFN + D DSUP^PSOSIGDS(.ORWX) + Q $G(ORWX("DAYS SUPPLY")) + ; +DFLTSPLY(VAL,UPD,SCH,PAT,DRG) ; return days supply given quantity + ; VAL: default days supply + N ORWX,I + S ORWX("PATIENT")=PAT + I DRG S ORWX("DRUG")=DRG + F I=1:1:$L(UPD,U)-1 D + . S ORWX("DOSE ORDERED",I)=$P(UPD,U,I) + . S ORWX("SCHEDULE",I)=$P(SCH,U,I) + D DSUP^PSOSIGDS(.ORWX) + S VAL=$G(ORWX("DAYS SUPPLY")) + Q +DISPMSG() ; return 1 to suppress dispense message + Q +$$GET^XPAR("ALL","ORWDPS SUPPRESS DISPENSE MSG",1,"I") + ; +SCHALL(LST) ; return all schedules + N ILST,SCH,IEN,EXP,TYP,X0 + S ILST=0,SCH="" + F S SCH=$O(^PS(51.1,"APPSJ",SCH)) Q:SCH="" D + . I (SCH="STAT")!(SCH="NOW") D + .. S IEN=$O(^PS(51.1,"APPSJ",SCH,0)) + .. S X0=$G(^PS(51.1,IEN,0)),EXP=$P(X0,U,8),TYP=$P(X0,U,5) + .. S ILST=ILST+1,LST(ILST)=SCH_U_EXP_U_TYP + Q +FORMALT(ORLST,IEN,PSTYPE) ; return a list of formulary alternatives + N PSID,I + S IEN=+$P(^ORD(101.43,IEN,0),U,2) + D EN1^PSSUTIL1(.IEN,PSTYPE) + S PSID=0,I=0 + F S PSID=$O(IEN(PSID)) Q:'PSID D + . S OI=+$O(^ORD(101.43,"ID",PSID_";99PSP",0)) + . I OI S I=I+1,ORLST(I)=OI,$P(ORLST(I),U,2)=$P(^ORD(101.43,OI,0),U) + Q +DOSEALT(LST,DDRUG,CUROI,PSTYPE) ; return a list of formulary alternatives for dose + N I,OI,ORWLST,ILST S ILST=0 + D ENRFA^PSJORUTL(DDRUG,PSTYPE,.ORWLST) + S I=0 F S I=$O(ORWLST(I)) Q:'I D + . S OI=+$O(^ORD(101.43,"ID",+$P(ORWLST(I),U,4)_";99PSP",0)) + . I OI,OI'=CUROI S ILST=ILST+1,LST(ILST)=OI_U_$P(^ORD(101.43,OI,0),U) + Q +FAILDEA(FAIL,OI,ORNP,PSTYPE) ; return 1 if DEA check fails for this provider + N DEAFLG,PSOI + S FAIL=0,PSOI=+$P($G(^ORD(101.43,+$G(OI),0)),U,2) Q:PSOI'>0 + I '$L($T(OIDEA^PSSUTLA1)) Q + S DEAFLG=$$OIDEA^PSSUTLA1(PSOI,PSTYPE) Q:DEAFLG'>0 + I '$L($P($G(^VA(200,+$G(ORNP),"PS")),U,2)),'$L($P($G(^("PS")),U,3)) S FAIL=1 + Q +CHK94(VAL) ; return 1 if patch 94 has been installed + S VAL=0 + I $O(^ORD(101.41,"B","PS MEDS",0)) S VAL=1 + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORBCMA32.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORBCMA32.m index 4f454bd7..ad112746 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORBCMA32.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORBCMA32.m @@ -1,244 +1,227 @@ -ORBCMA32 ; SLC/JLI - Pharmacy Calls for GUI Dialog 02/11/2008 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**133,243**;Dec 17, 1997;Build 242 - ;;BCMA ORDER V1.0 ;**133,243**;Jan 17, 2002 - ; -NXT() ; -- returns next available index in return data array - S ILST=ILST+1 - Q ILST - ; -DLGSLCT(LST,PSTYPE) ; return default lists for dialog - ; PSTYPE: pharmacy type (U=unit dose, F=IV fluids, O=outpatient) - N ILST S ILST=0 - I PSTYPE="F" D Q ; IV Fluids - . S LST($$NXT)="~ShortList" D SHORT - . S LST($$NXT)="~Priorities" D PRIOR - ; - S LST($$NXT)="~ShortList" D SHORT ; Unit Dose & Outpatient - S LST($$NXT)="~Schedules" D SCHED - S LST($$NXT)="~Priorities" D PRIOR - I PSTYPE="O" D ; Outpatient - . S LST($$NXT)="~Pickup" D PICKUP - . S LST($$NXT)="~SCStatus" D SCLIST - Q -SHORT ; from DLGSLCT, get short list of med quick orders - N I,X,TMP - I PSTYPE="U" S X="UD RX" - I PSTYPE="F" S X="IV RX" - I PSTYPE="O" S X="O RX" - D GETQLST^ORWDXQ(.TMP,X,"iQ") - S I=0 F S I=$O(TMP(I)) Q:'I S LST($$NXT)=TMP(I) - Q -SCHED ; from DLGSLCT, get all pharmacy administration schedules - N X - K ^TMP($J,"ORBCMA32 SCHED") - D AP^PSS51P1("PSJ",,,,"ORBCMA32 SCHED") - S X="" F S X=$O(^TMP($J,"ORBCMA32 SCHED","APPSJ",X)) Q:X="" S LST($$NXT)="i"_X - K ^TMP($J,"ORBCMA32 SCHED") - Q -SCHEDA ; (similar to SCHED, but also returns administration times) - N X,IEN,SCH - K ^TMP($J,"ORBCMA32 SCHEDA") - D AP^PSS51P1("PSJ",,,,"ORBCMA32 SCHEDA") - S SCH="" F S SCH=$O(^TMP($J,"ORBCMA32 SCHEDA","APPSJ",SCH)) Q:SCH="" D - . S IEN=0 F S IEN=$O(^TMP($J,"ORBCMA32 SCHEDA","APPSJ",SCH,IEN)) Q:IEN'>0 D - . . S X=$S($L(^TMP($J,"ORBCMA32 SCHEDA",IEN,2)):" ("_^TMP($J,"ORBCMA32 SCHEDA",IEN,2)_")",1:"") - . . S LST($$NXT)="i"_IEN_U_SCH_X - Q -PRIOR ; from DLGSLCT, get list of allowed priorities - N X,XREF - S X=0 - S X=$O(^ORD(101.42,"B","DONE",X)) - S LST($$NXT)="i"_X_U_$P(^ORD(101.42,X,0),U,2) - Q -PICKUP ; from DLGSLCT, get prescription routing - N X,EDITONLY - F X="W^at Window","M^by Mail","C^in Clinic" S LST($$NXT)="i"_X - S X=$$DEFPICK I $L(X) S LST($$NXT)="d"_X - Q -DEFPICK() ; return default routing - N X,DLG,PRMT - S DLG=$O(^ORD(101.41,"AB","PSO OERR",0)),X="" - S PRMT=$O(^ORD(101.41,"AB","OR GTX ROUTING",0)) - I $D(^TMP("ORECALL",$J,+DLG,+PRMT,1)) S X=^(1) - I X'="" S EDITONLY=1 Q X ; EDITONLY used by default action - ; - S X=$$GET^XPAR("ALL","ORWDPS ROUTING DEFAULT",1,"I") - I X="C" S X="C^in Clinic" G XPICK - I X="M" S X="M^by Mail" G XPICK - I X="W" S X="W^at Window" G XPICK - I X="N" S X="" G XPICK - I X="" S X=$S($D(^PSX(550,"C")):"M^by Mail",1:"W^at Window") -XPICK Q X - ; -SCLIST ; from DLGSLCT, get options for service connected - F X="0^No","1^Yes" S LST($$NXT)="i"_X - Q - ; -OISLCT(LST,OI,PSTYPE,ORVP) ; return for defaults for pharmacy orderable item - N ILST S ILST=0 - K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) - S LST($$NXT)="~Dispense" D DISPDRG - S LST($$NXT)="~Instruct" D INSTRCT - S LST($$NXT)="~Route" D ROUTE - S LST($$NXT)="~Message" D MESSAGE - I $L($G(^TMP("PSJSCH",$J))) S LST($$NXT)="~DefSched",LST($$NXT)="d"_^($J) - K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) - Q - ; -DISPDRUG(LST,OI) ; list dispense drugs for an orderable item - N ILST,PSTYPE S ILST=0,PSTYPE="U" D DISPDRG - Q - ; -DISPDRG ; from OISLCT, get dispense drugs for this pharmacy orderable item - N I,ORTMP,ORX - S ORX=$T(ENDD^PSJORUTL),ORX=$L($P(ORX,";"),",") - I ORX>3 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP,+ORVP) - I ORX'>3 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP) - S I="" F S I=$O(ORTMP(I)) Q:I="" D - . I $P(ORTMP(I),U,4)="1" S $P(ORTMP(I),U,4)="NF" - . S $P(ORTMP(I),U,3)="$"_$P(ORTMP(I),U,3)_" per "_$P(ORTMP(I),U,5) - . S LST($$NXT)="i"_ORTMP(I) - Q -INSTRCT ; from OISLCT, get list of potential instructions (based on drug form) - N INOUN,NOUN,IINS,INS,VERB,INSREC - D START^PSSJORDF(+$P(^ORD(101.43,OI,0),U,2)) - I PSTYPE="U" Q ; don't use the instructions list for inpatients - S IINS=0 F S IINS=$O(^TMP("PSJINS",$J,IINS)) Q:'IINS D - . S INSREC=$G(^TMP("PSJINS",$J,IINS)) - . I '$D(VERB) S VERB=$P(INSREC,U) - . I $L($P(INSREC,U,2)) S LST($$NXT)="i"_$P(INSREC,U,2) - S LST($$NXT)="~Nouns" - S INOUN=0 F S INOUN=$O(^TMP("PSJNOUN",$J,INOUN)) Q:'INOUN D - . S LST($$NXT)="i"_$P(^TMP("PSJNOUN",$J,INOUN),U) - I $D(VERB) S LST($$NXT)="~Verb",LST($$NXT)="d"_VERB - ; - Q -MIXED(X) ; Return mixed case - Q X ;$E(X)_$TR($E(X,2,$L(X)),"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz") - ; -ROUTE ; from OISLCT, get list of routes for the drug form - ; ** NEED BOTH ABBREVIATION & NAME IN LIST BOX - N I,CNT,ABBR,IEN,ROUT,X - S I="" F S I=$O(^TMP("PSJMR",$J,I)) Q:I="" D - . S ROUT=$P(^TMP("PSJMR",$J,I),U),ABBR=$P(^(I),U,2),IEN=$P(^(I),U,3) - . S LST($$NXT)="i"_IEN_U_ROUT_U_ABBR - . I I=1,IEN S LST($$NXT)="d"_IEN_U_ROUT ;_U_ABBR ; assume first always default - S I="" F S I=$O(^TMP("PSJMR",$J,I)) Q:I="" D - . S ROUT=$P(^TMP("PSJMR",$J,I),U),ABBR=$P(^(I),U,2),IEN=$P(^(I),U,3) - . I $L(ABBR),(ABBR'=ROUT) S LST($$NXT)="i"_IEN_U_ABBR_" ("_ROUT_")"_U_ABBR - Q -MESSAGE ; message - S I=0 F S I=$O(^ORD(101.43,OI,8,I)) Q:I'>0 S LST($$NXT)="t"_^(I,0) - Q -ALLROUTE(LST) ; returns a list of all available med routes - N I,X,ILST - S ILST=0 - K ^TMP($J,"ORWDPS32 ALLROUTE") - D ALL^PSS51P2(,"??",,,"ORWDPS32 ALLROUTE") - S I=0 F S I=$O(^TMP($J,"ORWDPS32 ALLROUTE",I)) Q:'I D - . I +$P(^TMP($J,"ORWDPS32 ALLROUTE",I,3),U)>0 S LST($$NXT)=I_U_^TMP($J,"ORWDPS32 ALLROUTE",I,.01)_U_^TMP($J,"ORWDPS32 ALLROUTE",I,1) - Q -VALROUTE(REC,X) ; validates route name & returns IEN + abbreviation - N ABBR,NAME,IEN - K ^TMP($J,"ORBCMA32 VALROUTE") - S X=$$UPPER(X) - D ALL^PSS51P2(,X,,1,"ORBCMA32 VALROUTE") - I $P(^TMP($J,"ORBCMA32 VALROUTE",0),U)=-1 K ^TMP($J,"ORBCMA32 VALROUTE") S REC=0 Q - S IEN=$O(^TMP($J,"ORBCMA32 VALROUTE","B",X,"")) - I IEN'>0 S IEN=$O(^TMP($J,"ORBCMA32 VALROUTE","C",X,"")) - I IEN'>0 S REC=0 Q - S NAME=$G(^TMP($J,"ORBCMA32 VALROUTE",IEN,.01)) - S ABBR=$G(^TMP($J,"ORBCMA32 VALROUTE",IEN,1)) - I '$L(ABBR) S ABBR=NAME - I ($$UPPER(NAME)'=X),($$UPPER(ABBR)'=X) S REC=0 K ^TMP($J,"ORBCMA32 VALROUTE") Q - S REC=IEN_U_ABBR - K ^TMP($J,"ORBCMA32 VALROUTE") - Q -AUTH(VAL,PRV) ; For inpatient meds, check restrictions - N NAME,AUTH,INACT,X S VAL=0 - S NAME=$P($G(^VA(200,PRV,20)),U,2) S:'$L(NAME) NAME=$P(^(0),U) - S X=$G(^VA(200,PRV,"PS")),AUTH=$P(X,U),INACT=$P(X,U,4) - I 'AUTH!(INACT&(DT>INACT)) D Q - . S VAL="1^"_NAME_" is not authorized to write medication orders." - I $D(^XUSEC("OREMAS",DUZ)),'$$GET^XPAR("ALL","OR OREMAS MED ORDERS") D Q - . S VAL="1^OREMAS key holders may not enter medication orders." - Q -DRUGMSG(VAL,IEN) ; return any message associated with a dispense drug - N X S X=$$ENDCM^PSJORUTL(IEN) - S VAL=$P(X,U,2)_U_$P(X,U,4) - Q -MEDISIV(VAL,IEN) ; return true if orderable item is IV medication - S VAL=0 - I $P($G(^ORD(101.43,IEN,"PS")),U)=2 S VAL=1 - Q -ISSPLY(VAL,IEN) ; return true if orderable item is a supply - S VAL=0 - I $P($G(^ORD(101.43,IEN,"PS")),U,5)=1 S VAL=1 - Q -IVAMT(VAL,OI,ORWTYP) ; return UNITS^AMOUNT |^AMOUNT^AMOUNT...| for IV soln - N I,PSOI,ORWY,AMT,IVFLAG - S IVFLAG=$P(OI,U,2) - S PSOI=+$P($G(^ORD(101.43,+OI,0)),U,2)_ORWTYP,VAL="" - I IVFLAG="NF" D ENVOL2^PSJORUT2(PSOI,.ORWY) - I IVFLAG="" D ENVOL^PSJORUT2(PSOI,.ORWY) - I ORWTYP="B" D - . S I=0 F S I=$O(ORWY(I)) Q:I'>0 S AMT(+ORWY(I))="" - . S AMT=0,VAL="ML" F S AMT=$O(AMT(AMT)) Q:AMT'>0 S VAL=VAL_U_AMT - I ORWTYP="A" D - . S I=+$O(ORWY(0)) S VAL=$P($G(ORWY(I)),U,2) - . I '$L(VAL) S VAL="ML^LITER^MCG^MG^GM^UNITS^IU^MEQ^MM^MU^THOUU^MG-PE^NANOGRAM^MMOL" - Q -VALRATE(VAL,X) ; return "1" (true) if IV rate text is valid - I $E($RE($$UPPER(X)),1,5)="RH/LM" S X=$E(X,1,$L(X)-5) - S X=$$TRIM(X) - D ORINF^PSIVSP S VAL=$G(X) ;S OK=$S($D(X):1,1:0) - Q -UPPER(X) ; return uppercase - Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") - ; -TRIM(X) ; trim leading and trailing spaces - S X=$RE(X) F S:$E(X)=" " X=$E(X,2,999) Q:$E(X)'=" " Q:'$L(X) ;trail - S X=$RE(X) F S:$E(X)=" " X=$E(X,2,999) Q:$E(X)'=" " Q:'$L(X) ;lead - Q X -SCSTS(VAL,ORVP,ORDRUG) ; return service connected eligibility for patient - N ORWP94 S ORWP94=$O(^ORD(101.41,"AB","PS MEDS",0))>0 - I $L($T(SC^PSOCP)),$$SC^PSOCP(+ORVP,+$G(ORDRUG)) S VAL=0 G XSCSTS - I 'ORWP94,(+$$RXST^IBARXEU(+ORVP)>0) S VAL=0 G XSCSTS - S VAL=1 -XSCSTS Q -FORMALT(ORLST,IEN,PSTYPE) ; return a list of formulary alternatives - D ENRFA^PSJORUTL(IEN,PSTYPE,.ORLST) - S I=0 F S I=$O(ORLST(I)) Q:'I D - . S OI=+$O(^ORD(101.43,"ID",+$P(ORLST(I),U,4)_";99PSP",0)) - . S $P(ORLST(I),U,4)=OI I OI S $P(ORLST(I),U,5)=$P(^ORD(101.43,OI,0),U) - Q -VALSCH(OK,X,PSTYPE) ; validate a schedule, return 1 if valid, 0 if not - I '$L($T(EN^PSSGSGUI)) S OK=-1 Q - I $E($T(EN^PSSGSGUI),1,4)="EN(X" D - . N ORX S ORX=$G(X) D EN^PSSGSGUI(.ORX,$G(PSTYPE,"I")) - . K X S:$D(ORX) X=ORX - E D - . D EN^PSSGSGUI - S OK=$S($D(X):1,1:0) - Q -VALQTY(OK,X) ; validate a quantity, return 1 if valid, 0 if not - ; to be compatible with LM, make sure X is integer from 1 to 240 - ; this is based on the input transform from 52,7 - K:(+X'>0)!(+X>99999999)!(X'?.8N.1".".2N)!($L(X)>12) X - S OK=$S($D(X):1,1:0) - Q -DOSES(LST,OI) ; return doses for an orderable item - TEST ONLY - N ORTMP,ORI,ORJ,ILST,NDF,VAPN,X,PSTYPE S PSTYPE="O" - D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP) - S ORI=0 F S ORI=$O(ORTMP(ORI)) Q:'ORI S ORWDRG=+ORTMP(ORI) D - . K ^TMP($J,"ORBCMA32 DRUG") - . D NDF^PSS50(+ORWDRG,,,,,"ORBCMA32 DRUG") - . S VAPN=$P($G(^TMP($J,"ORBCMA32 DRUG",+ORWDRG,22)),U),NDF=$P($G(^TMP($J,"ORBCMA32 DRUG",+ORWDRG,20)),U) - . S X=$$DFSU^PSNAPIS(NDF,VAPN) - . S LSTA($P(X,U,4),$P(X,U,6))="" - . I +$P(X,U,4)=$P(X,U,4) S LSTA($P(X,U,4)*2,$P(X,U,6))="" - K ^TMP($J,"ORBCMA32 DRUG") - S ORI="",ILST=0 F S ORI=$O(LSTA(ORI)) Q:ORI="" D - . S ORJ="" F S ORJ=$O(LSTA(ORI,ORJ)) Q:ORJ="" D - . . S ILST=ILST+1,LST(ILST)=ORI_" "_ORJ - Q +ORBCMA32 ; SLC/JLI - Pharmacy Calls for GUI Dialog ;01/17/02 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**133,237**;Dec 17, 1997 + ;;BCMA ORDER V1.0 ;**133,237**;Jan 17, 2002 + ; +NXT() ; -- returns next available index in return data array + S ILST=ILST+1 + Q ILST + ; +DLGSLCT(LST,PSTYPE) ; return default lists for dialog + ; PSTYPE: pharmacy type (U=unit dose, F=IV fluids, O=outpatient) + N ILST S ILST=0 + I PSTYPE="F" D Q ; IV Fluids + . S LST($$NXT)="~ShortList" D SHORT + . S LST($$NXT)="~Priorities" D PRIOR + ; + S LST($$NXT)="~ShortList" D SHORT ; Unit Dose & Outpatient + S LST($$NXT)="~Schedules" D SCHED + S LST($$NXT)="~Priorities" D PRIOR + I PSTYPE="O" D ; Outpatient + . S LST($$NXT)="~Pickup" D PICKUP + . S LST($$NXT)="~SCStatus" D SCLIST + Q +SHORT ; from DLGSLCT, get short list of med quick orders + ; !!! change this so that it uses the ORWDXQ call!!! + N I,X,TMP + I PSTYPE="U" S X="UD RX" + I PSTYPE="F" S X="IV RX" + I PSTYPE="O" S X="O RX" + D GETQLST^ORWDXQ(.TMP,X,"iQ") + S I=0 F S I=$O(TMP(I)) Q:'I S LST($$NXT)=TMP(I) + Q +SCHED ; from DLGSLCT, get all pharmacy administration schedules + N X + S X="" F S X=$O(^PS(51.1,"APPSJ",X)) Q:X="" S LST($$NXT)="i"_X + Q +SCHEDA ; (similar to SCHED, but also returns administration times) + N X,IEN,SCH + S SCH="" F S SCH=$O(^PS(51.1,"APPSJ",SCH)) Q:SCH="" D + . S IEN=0 F S IEN=$O(^PS(51.1,"APPSJ",SCH,IEN)) Q:IEN'>0 D + . . S X=^PS(51.1,IEN,0) S X=$S($L($P(X,U,2)):" ("_$P(X,U,2)_")",1:"") + . . S LST($$NXT)="i"_IEN_U_SCH_X + Q +PRIOR ; from DLGSLCT, get list of allowed priorities + N X,XREF + S X=0 + S X=$O(^ORD(101.42,"B","DONE",X)) + S LST($$NXT)="i"_X_U_$P(^ORD(101.42,X,0),U,2) + Q +PICKUP ; from DLGSLCT, get prescription routing + N X,EDITONLY + F X="W^at Window","M^by Mail","C^in Clinic" S LST($$NXT)="i"_X + S X=$$DEFPICK I $L(X) S LST($$NXT)="d"_X + Q +DEFPICK() ; return default routing + N X,DLG,PRMT + S DLG=$O(^ORD(101.41,"AB","PSO OERR",0)),X="" + S PRMT=$O(^ORD(101.41,"AB","OR GTX ROUTING",0)) + I $D(^TMP("ORECALL",$J,+DLG,+PRMT,1)) S X=^(1) + I X'="" S EDITONLY=1 Q X ; EDITONLY used by default action + ; + S X=$$GET^XPAR("ALL","ORWDPS ROUTING DEFAULT",1,"I") + I X="C" S X="C^in Clinic" G XPICK + I X="M" S X="M^by Mail" G XPICK + I X="W" S X="W^at Window" G XPICK + I X="N" S X="" G XPICK + I X="" S X=$S($D(^PSX(550,"C")):"M^by Mail",1:"W^at Window") +XPICK Q X + ; +SCLIST ; from DLGSLCT, get options for service connected + F X="0^No","1^Yes" S LST($$NXT)="i"_X + Q + ; +OISLCT(LST,OI,PSTYPE,ORVP) ; return for defaults for pharmacy orderable item + N ILST S ILST=0 + K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) + S LST($$NXT)="~Dispense" D DISPDRG + S LST($$NXT)="~Instruct" D INSTRCT + S LST($$NXT)="~Route" D ROUTE + S LST($$NXT)="~Message" D MESSAGE + I $L($G(^TMP("PSJSCH",$J))) S LST($$NXT)="~DefSched",LST($$NXT)="d"_^($J) + K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) + Q + ; +DISPDRUG(LST,OI) ; list dispense drugs for an orderable item + N ILST,PSTYPE S ILST=0,PSTYPE="U" D DISPDRG + Q + ; +DISPDRG ; from OISLCT, get dispense drugs for this pharmacy orderable item + N I,ORTMP,ORX + S ORX=$T(ENDD^PSJORUTL),ORX=$L($P(ORX,";"),",") + I ORX>3 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP,+ORVP) + I ORX'>3 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP) + S I="" F S I=$O(ORTMP(I)) Q:I="" D + . I $P(ORTMP(I),U,4)="1" S $P(ORTMP(I),U,4)="NF" + . S $P(ORTMP(I),U,3)="$"_$P(ORTMP(I),U,3)_" per "_$P(ORTMP(I),U,5) + . S LST($$NXT)="i"_ORTMP(I) + Q +INSTRCT ; from OISLCT, get list of potential instructions (based on drug form) + N INOUN,NOUN,IINS,INS,VERB,INSREC + D START^PSSJORDF(+$P(^ORD(101.43,OI,0),U,2)) + I PSTYPE="U" Q ; don't use the instructions list for inpatients + S IINS=0 F S IINS=$O(^TMP("PSJINS",$J,IINS)) Q:'IINS D + . S INSREC=$G(^TMP("PSJINS",$J,IINS)) + . I '$D(VERB) S VERB=$P(INSREC,U) + . I $L($P(INSREC,U,2)) S LST($$NXT)="i"_$P(INSREC,U,2) + S LST($$NXT)="~Nouns" + S INOUN=0 F S INOUN=$O(^TMP("PSJNOUN",$J,INOUN)) Q:'INOUN D + . S LST($$NXT)="i"_$P(^TMP("PSJNOUN",$J,INOUN),U) + I $D(VERB) S LST($$NXT)="~Verb",LST($$NXT)="d"_VERB + ; + Q +MIXED(X) ; Return mixed case + Q X ;$E(X)_$TR($E(X,2,$L(X)),"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz") + ; +ROUTE ; from OISLCT, get list of routes for the drug form + ; ** NEED BOTH ABBREVIATION & NAME IN LIST BOX + N I,CNT,ABBR,IEN,ROUT,X + S I="" F S I=$O(^TMP("PSJMR",$J,I)) Q:I="" D + . S ROUT=$P(^TMP("PSJMR",$J,I),U),ABBR=$P(^(I),U,2),IEN=$P(^(I),U,3) + . S LST($$NXT)="i"_IEN_U_ROUT_U_ABBR + . I I=1,IEN S LST($$NXT)="d"_IEN_U_ROUT ;_U_ABBR ; assume first always default + S I="" F S I=$O(^TMP("PSJMR",$J,I)) Q:I="" D + . S ROUT=$P(^TMP("PSJMR",$J,I),U),ABBR=$P(^(I),U,2),IEN=$P(^(I),U,3) + . I $L(ABBR),(ABBR'=ROUT) S LST($$NXT)="i"_IEN_U_ABBR_" ("_ROUT_")"_U_ABBR + Q +MESSAGE ; message + S I=0 F S I=$O(^ORD(101.43,OI,8,I)) Q:I'>0 S LST($$NXT)="t"_^(I,0) + Q +ALLROUTE(LST) ; returns a list of all available med routes + N I,X,ILST S ILST=0 + S I=0 F S I=$O(^PS(51.2,I)) Q:'I S X=^(I,0) D + . I $P(X,U,4) S LST($$NXT)=I_U_$P(X,U)_U_$P(X,U,3) + Q +VALROUTE(REC,X) ; validates route name & returns IEN + abbreviation + N ORLST,ABBR + D FIND^DIC(51.2,"",1,"MO",X,1,,"I $P(^(0),U,4)=1",,"ORLST") + I 'ORLST("DILIST",0) S REC=0 Q + S X=$$UPPER(X),ABBR=ORLST("DILIST","ID",1,1) + I '$L(ABBR) S ABBR=ORLST("DILIST",1,1) + I ($$UPPER(ORLST("DILIST",1,1))'=X),($$UPPER(ABBR)'=X) S REC=0 Q + S REC=ORLST("DILIST",2,1)_U_ABBR + Q +AUTH(VAL,PRV) ; For inpatient meds, check restrictions + N NAME,AUTH,INACT,X S VAL=0 + S NAME=$P($G(^VA(200,PRV,20)),U,2) S:'$L(NAME) NAME=$P(^(0),U) + S X=$G(^VA(200,PRV,"PS")),AUTH=$P(X,U),INACT=$P(X,U,4) + I 'AUTH!(INACT&(DT>INACT)) D Q + . S VAL="1^"_NAME_" is not authorized to write medication orders." + I $D(^XUSEC("OREMAS",DUZ)),'$$GET^XPAR("ALL","OR OREMAS MED ORDERS") D Q + . S VAL="1^OREMAS key holders may not enter medication orders." + Q +DRUGMSG(VAL,IEN) ; return any message associated with a dispense drug + N X S X=$$ENDCM^PSJORUTL(IEN) + S VAL=$P(X,U,2)_U_$P(X,U,4) + Q +MEDISIV(VAL,IEN) ; return true if orderable item is IV medication + S VAL=0 + I $P($G(^ORD(101.43,IEN,"PS")),U)=2 S VAL=1 + Q +ISSPLY(VAL,IEN) ; return true if orderable item is a supply + S VAL=0 + I $P($G(^ORD(101.43,IEN,"PS")),U,5)=1 S VAL=1 + Q +IVAMT(VAL,OI,ORWTYP) ; return UNITS^AMOUNT |^AMOUNT^AMOUNT...| for IV soln + N I,PSOI,ORWY,AMT,IVFLAG + S IVFLAG=$P(OI,U,2) + S PSOI=+$P($G(^ORD(101.43,+OI,0)),U,2)_ORWTYP,VAL="" + I IVFLAG="NF" D ENVOL2^PSJORUT2(PSOI,.ORWY) + I IVFLAG="" D ENVOL^PSJORUT2(PSOI,.ORWY) + I ORWTYP="B" D + . S I=0 F S I=$O(ORWY(I)) Q:I'>0 S AMT(+ORWY(I))="" + . S AMT=0,VAL="ML" F S AMT=$O(AMT(AMT)) Q:AMT'>0 S VAL=VAL_U_AMT + I ORWTYP="A" D + . S I=+$O(ORWY(0)) S VAL=$P($G(ORWY(I)),U,2) + . I '$L(VAL) S VAL="ML^LITER^MCG^MG^GM^UNITS^IU^MEQ^MM^MU^THOUU^MG-PE^NANOGRAM" + Q +VALRATE(VAL,X) ; return "1" (true) if IV rate text is valid + I $E($RE($$UPPER(X)),1,5)="RH/LM" S X=$E(X,1,$L(X)-5) + S X=$$TRIM(X) + D ORINF^PSIVSP S VAL=$G(X) ;S OK=$S($D(X):1,1:0) + Q +UPPER(X) ; return uppercase + Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") + ; +TRIM(X) ; trim leading and trailing spaces + S X=$RE(X) F S:$E(X)=" " X=$E(X,2,999) Q:$E(X)'=" " Q:'$L(X) ;trail + S X=$RE(X) F S:$E(X)=" " X=$E(X,2,999) Q:$E(X)'=" " Q:'$L(X) ;lead + Q X +SCSTS(VAL,ORVP,ORDRUG) ; return service connected eligibility for patient + N ORWP94 S ORWP94=$O(^ORD(101.41,"AB","PS MEDS",0))>0 + I $L($T(SC^PSOCP)),$$SC^PSOCP(+ORVP,+$G(ORDRUG)) S VAL=0 G XSCSTS + I 'ORWP94,(+$$RXST^IBARXEU(+ORVP)>0) S VAL=0 G XSCSTS + S VAL=1 +XSCSTS Q +FORMALT(ORLST,IEN,PSTYPE) ; return a list of formulary alternatives + D ENRFA^PSJORUTL(IEN,PSTYPE,.ORLST) + S I=0 F S I=$O(ORLST(I)) Q:'I D + . S OI=+$O(^ORD(101.43,"ID",+$P(ORLST(I),U,4)_";99PSP",0)) + . S $P(ORLST(I),U,4)=OI I OI S $P(ORLST(I),U,5)=$P(^ORD(101.43,OI,0),U) + Q +VALSCH(OK,X,PSTYPE) ; validate a schedule, return 1 if valid, 0 if not + I '$L($T(EN^PSSGSGUI)) S OK=-1 Q + I $E($T(EN^PSSGSGUI),1,4)="EN(X" D + . N ORX S ORX=$G(X) D EN^PSSGSGUI(.ORX,$G(PSTYPE,"I")) + . K X S:$D(ORX) X=ORX + E D + . D EN^PSSGSGUI + S OK=$S($D(X):1,1:0) + Q +VALQTY(OK,X) ; validate a quantity, return 1 if valid, 0 if not + ; to be compatible with LM, make sure X is integer from 1 to 240 + ; this is based on the input transform from 52,7 + K:(+X'>0)!(+X>99999999)!(X'?.8N.1".".2N)!($L(X)>12) X + S OK=$S($D(X):1,1:0) + Q +DOSES(LST,OI) ; return doses for an orderable item - TEST ONLY + N ORTMP,ORI,ORJ,ILST,NDF,VAPN,X,PSTYPE S PSTYPE="O" + D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP) + S ORI=0 F S ORI=$O(ORTMP(ORI)) Q:'ORI S ORWDRG=+ORTMP(ORI) D + . S NDF=$G(^PSDRUG(+ORWDRG,"ND")),VAPN=$P(NDF,U,3),NDF=+NDF + . S X=$$DFSU^PSNAPIS(NDF,VAPN) + . S LSTA($P(X,U,4),$P(X,U,6))="" + . I +$P(X,U,4)=$P(X,U,4) S LSTA($P(X,U,4)*2,$P(X,U,6))="" + S ORI="",ILST=0 F S ORI=$O(LSTA(ORI)) Q:ORI="" D + . S ORJ="" F S ORJ=$O(LSTA(ORI,ORJ)) Q:ORJ="" D + . . S ILST=ILST+1,LST(ILST)=ORI_" "_ORJ + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCACT0.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCACT0.m index 35e612fb..790da513 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCACT0.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCACT0.m @@ -1,126 +1,121 @@ -ORCACT0 ;SLC/MKB-Validate order action ;5/19/08 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,27,48,72,86,92,94,141,165,177,173,190,215,243**;Dec 17, 1997;Build 242 - ; -VALID(IFN,ACTION,ERROR,NATR) ; -- Determines if action is valid for order IFN - N OR0,OR3,ORA0,AIFN,PKG,DG,ORDSTS,ACTSTS,VER,X,Y,MEDPARM K ERROR - S OR0=$G(^OR(100,+IFN,0)),OR3=$G(^(3)),PKG=$$NMSP^ORCD($P(OR0,U,14)) - S DG=$P($G(^ORD(100.98,+$P(OR0,U,11),0)),U,3) - S MEDPARM=$S($G(NATR)="A":2,PKG'="PS":2,'$D(^XUSEC("OREMAS",DUZ)):2,DG="NV RX":$$GET^XPAR("ALL","OR OREMAS NON-VA MED ORDERS"),1:$$GET^XPAR("ALL","OR OREMAS MED ORDERS")) - S AIFN=$P(IFN,";",2) S:'AIFN AIFN=+$P(OR3,U,7) - S ORA0=$G(^OR(100,+IFN,8,AIFN,0)),ACTSTS=$P(ORA0,U,15) - S ORDSTS=$P(OR3,U,3),VER=$S($P(OR0,U,5)["101.41":3,1:2) -CM I ACTION="CM" S ERROR="This action is no longer available!" G VQ ; ward comments - no restrictions -FL I ACTION="FL" D G VQ ; flag - . I +$G(^OR(100,+IFN,8,AIFN,3)) S ERROR="This order is already flagged!" Q -UF I ACTION="UF" D G VQ ; unflag - . I '+$G(^OR(100,+IFN,8,AIFN,3)) S ERROR="This order is not flagged!" Q -DC1 I ACTION="DC",ACTSTS D G VQ ; discontinue/cancel unrel or canc order - . I (ACTSTS=11)!(ACTSTS=10) D Q ; unreleased - .. I 'MEDPARM S ERROR="You are not authorized to cancel med orders!" Q - .. I $G(NATR)="A" S X=$O(^ORE(100.2,"AO",+IFN,0)) I X,'$G(^ORE(100.2,X,1)) S ERROR="Future event orders may not be auto-discontinued!" Q - . I ACTSTS=12 S ERROR="This order has been dc'd due to edit!" Q - . I ACTSTS=13 S ERROR="This order has been cancelled!" Q -ES I (ACTION="ES")!(ACTION="OC")!(ACTION="RS")!(ACTION="DS") D ES^ORCACT01 G VQ ; sign -VR I ACTION="VR" D G VQ ; verify - . I $G(ORVER)="N",$P(ORA0,U,9) S ERROR="This order has been verified!" Q - . I $G(ORVER)="C",$P(ORA0,U,11) S ERROR="This order has been verified!" Q - . I $G(ORVER)="R",$P(ORA0,U,19) S ERROR="This order has been reviewed!" Q - . I (ACTSTS=11)!(ACTSTS=10) S ERROR="This order has not been released to the service." Q - . I AIFN=1,ORDSTS=5,PKG="PS" S X=$$DISABLED I X S ERROR=$P(X,U,2) Q -DIS S X=$$DISABLED I X S ERROR=$P(X,U,2) G VQ -MN I ACTION="MN" D G VQ ; manually release (delayed) - . I ACTSTS'=10,ACTSTS'=11 S ERROR="This order has already been released!" Q - . I $P(OR0,U,12)="I",'$G(^DPT(+ORVP,.105)) S ERROR="This patient is not currently admitted!" -GMRA I PKG="GMRA" S ERROR="This action is not allowed on an allergy/adverse reaction!" G VQ ; no actions allowed on Allergies -MEDS I PKG="PS",'MEDPARM S ERROR="You are not authorized to enter med orders!" G VQ -RW I ACTION="RW" D RW^ORCACT01 G VQ ; rewrite/copy -XFR I ACTION="XFR" D XFR^ORCACT01 G VQ ; transfer to in/outpt -RN I ACTION="RN" D RN^ORCACT01 G VQ ; renew -TRM I $$DONE G VQ ; ORDSTS=1,2,7,12,13 -EV I ACTION="EV" D G VQ ; change delay event - . I ORDSTS'=10,ORDSTS'=11 S ERROR="This order has been released!" Q - . I DG="NV RX" S ERROR="Non-VA Med orders do not support this action!" Q - . I $$EVTORDER^OREVNTX(IFN) S ERROR="The release event for this order may not be changed!" Q - . S X=$P(ORA0,U,4) I X'=2,X'=3 S ERROR="Signed orders may not be delayed to another event!" Q -DC2 I ACTION="DC",ACTSTS="" D G VQ ; DC released order - . I $G(NATR)="A" D Q:$D(ERROR) - .. S X=$O(^ORE(100.2,"AO",+IFN,0)) I X S:'$G(^ORE(100.2,X,1)) ERROR="Future event orders may not be auto-discontinued!" Q - .. I $$GET1^DIQ(9.4,+$P(OR0,U,14)_",",1)="PSO",$G(DGPMT)=1 Q ;177 If admission auto-dc and order is outpt med then no further checking needed - .. I $G(DGPMT)=1,$P($G(^SC(+$P(OR0,U,10),0)),U,3)'="C" S ERROR="Only outpatient orders may be auto-discontinued!" Q - .. I $G(DGPMT)'=1,$P($G(^SC(+$P(OR0,U,10),0)),U,3)="C",PKG'="PS" S ERROR="Only inpatient orders may be auto-discontinued!" Q - . I PKG="RA",ORDSTS=6 S ERROR="Active Radiology orders cannot be discontinued!" Q - . I PKG="VBEC",ORDSTS=6 S ERROR="Active Blood Product orders cannot be discontinued!" Q - . I PKG="LR" D Q - .. I $$COLLECTD S ERROR="Lab orders that have been collected may not be discontinued!" Q - .. I $G(NATR)="A","^12^38^"'[(U_$P($G(DGPMA),U,18)_U),$$VALUE^ORX8(+IFN,"COLLECT")="SP",$P(OR0,U,8)'
1,ACTSTS S ERROR="This action is not allowed on a "_$$ACTION(X)_" order!" G VQ -RF I ACTION="RF" D G VQ - . I DG'="O RX" S ERROR="Only Outpatient Med orders may be refilled!" Q - . I ORDSTS=5 S ERROR="Pending orders may not be refilled!" Q - . I ORDSTS=7 S ERROR="Expired orders may not be refilled!" Q - . N X,PSIFN S PSIFN=$G(^OR(100,+IFN,4)) - . S X=$$REFILL^PSOREF(PSIFN) I X'>0 S ERROR=$P(X,U,2) Q -CP I ACTION="CP" D G VQ ; complete - . I PKG'="OR" S ERROR="Only generic text orders may be completed through this option!" Q - . I ORDSTS=11!(ORDSTS=10) S ERROR="This order has not been released!" Q -AL I ACTION="AL" D G VQ - . I PKG'="LR",PKG'="RA",PKG'="GMRC" S ERROR="This order does not generate results!" Q - . I $P(OR3,U,10) S ERROR="This order is already flagged to alert the provider when resulted!" Q -XX I ACTION="XX" D G VQ ; edit/change - . I ORDSTS=7 S ERROR="Expired orders may not be changed!" Q - . D XX^ORCACT01 -HD I ACTION="HD" D G VQ ; hold - . I PKG="FH" S ERROR="Diet orders cannot be held!" Q - . I PKG="LR" S ERROR="Lab orders cannot be held!" Q - . I PKG="RA" S ERROR="Radiology orders cannot be held!" Q - . I PKG="GMRC" S ERROR="Consult orders cannot be held!" Q - . I DG="NV RX" S ERROR="Non-VA Med orders cannot be held!" Q - . I ORDSTS=3 S ERROR="This order is already on hold!" Q - . I ORDSTS'=6,PKG="PS" S ERROR="Only active Pharmacy orders may be held!" Q - . I (ORDSTS=11)!(ORDSTS=10) S ERROR="This order has not been released to the service." Q -VQ S Y=$S($D(ERROR):0,1:1) - Q Y - ; -ACTION(X) ; -- Return text of action X - N Y S Y=$S(X="NW":"New",X="DC":"Discontinue",X="HD":"Hold",X="RL":"Release Hold",X="RN":"Renew",1:X) - Q Y - ; -NPO(ORIFN) ; -- Returns 1 or 0, if order ORIFN is for NPO - N X,Y S X=$$VALUE^ORX8(+ORIFN,"ORDERABLE",1,"E") - S Y=$S($E(X,1,3)="NPO":1,1:0) - Q Y - ; -COLLECTD() ; -- Lab order collected/active (incl all children)? - I (ORDSTS=11)!(ORDSTS=10) Q 0 ; unreleased - I '$O(^OR(100,+IFN,2,0)) Q (ORDSTS'=5) - ;I ORDSTS'=6 Q 1 ; Parent -> active instead of pending - N Y,Z S Y=1,Z=0 - F S Z=$O(^OR(100,+IFN,2,Z)) Q:Z'>0 I $P($G(^OR(100,Z,3)),U,3)=5 S Y=0 Q - Q Y - ; -DONE() ; -- sets ERROR if terminal status - I ORDSTS=1 S ERROR="This order has been discontinued!" Q 1 - I ORDSTS=2 S ERROR="This order has been completed!" Q 1 - I ORDSTS=7,DG'="O RX" S ERROR="This order has expired!" Q 1 - I ORDSTS=12 S ERROR="This order has been changed!" Q 1 - I ORDSTS=13 S ERROR="This order has been cancelled!" Q 1 - I ORDSTS=14 S ERROR="This order has lapsed!" Q 1 - I ORDSTS=15 S ERROR="This order has been renewed!" Q 1 - Q 0 - ; -DISABLED() ; -- Order dialog [or protocol] disabled? - N X,DLG S DLG=$P(OR0,U,5),X=0 I +DLG'>0 Q X - I VER'<3,DLG?1.N1";ORD(101.41," S X=$$MSG^ORXD(+DLG) Q X - S DLG=$S(PKG="RA":"RA OERR EXAM",PKG="GMRC":"GMRCOR CONSULT",1:"") - I $L(DLG) S DLG=+$O(^ORD(101.41,"AB",DLG,0)),X=$$MSG^ORXD(DLG) - Q X +ORCACT0 ;SLC/MKB-Validate order action ;2/24/03 10:35 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,27,48,72,86,92,94,141,165,177,173,190,215**;Dec 17, 1997 + ; +VALID(IFN,ACTION,ERROR,NATR) ; -- Determines if action is valid for order IFN + N OR0,OR3,ORA0,AIFN,PKG,DG,ORDSTS,ACTSTS,VER,X,Y,MEDPARM K ERROR + S OR0=$G(^OR(100,+IFN,0)),OR3=$G(^(3)),PKG=$$NMSP^ORCD($P(OR0,U,14)) + S DG=$P($G(^ORD(100.98,+$P(OR0,U,11),0)),U,3) + S MEDPARM=$S($G(NATR)="A":2,PKG'="PS":2,'$D(^XUSEC("OREMAS",DUZ)):2,DG="NV RX":$$GET^XPAR("ALL","OR OREMAS NON-VA MED ORDERS"),1:$$GET^XPAR("ALL","OR OREMAS MED ORDERS")) + S AIFN=$P(IFN,";",2) S:'AIFN AIFN=+$P(OR3,U,7) + S ORA0=$G(^OR(100,+IFN,8,AIFN,0)),ACTSTS=$P(ORA0,U,15) + S ORDSTS=$P(OR3,U,3),VER=$S($P(OR0,U,5)["101.41":3,1:2) +CM I ACTION="CM" S ERROR="This action is no longer available!" G VQ ; ward comments - no restrictions +FL I ACTION="FL" D G VQ ; flag + . I +$G(^OR(100,+IFN,8,AIFN,3)) S ERROR="This order is already flagged!" Q +UF I ACTION="UF" D G VQ ; unflag + . I '+$G(^OR(100,+IFN,8,AIFN,3)) S ERROR="This order is not flagged!" Q +DC1 I ACTION="DC",ACTSTS D G VQ ; discontinue/cancel unrel or canc order + . I (ACTSTS=11)!(ACTSTS=10) D Q ; unreleased + .. I 'MEDPARM S ERROR="You are not authorized to cancel med orders!" Q + .. I $G(NATR)="A" S X=$O(^ORE(100.2,"AO",+IFN,0)) I X,'$G(^ORE(100.2,X,1)) S ERROR="Future event orders may not be auto-discontinued!" Q + . I ACTSTS=12 S ERROR="This order has been dc'd due to edit!" Q + . I ACTSTS=13 S ERROR="This order has been cancelled!" Q +ES I (ACTION="ES")!(ACTION="OC")!(ACTION="RS")!(ACTION="DS") D ES^ORCACT01 G VQ ; sign +VR I ACTION="VR" D G VQ ; verify + . I $G(ORVER)="N",$P(ORA0,U,9) S ERROR="This order has been verified!" Q + . I $G(ORVER)="C",$P(ORA0,U,11) S ERROR="This order has been verified!" Q + . I $G(ORVER)="R",$P(ORA0,U,19) S ERROR="This order has been reviewed!" Q + . I (ACTSTS=11)!(ACTSTS=10) S ERROR="This order has not been released to the service." Q + . I AIFN=1,ORDSTS=5,PKG="PS" S X=$$DISABLED I X S ERROR=$P(X,U,2) Q +DIS S X=$$DISABLED I X S ERROR=$P(X,U,2) G VQ +MN I ACTION="MN" D G VQ ; manually release (delayed) + . I ACTSTS'=10,ACTSTS'=11 S ERROR="This order has already been released!" Q + . I $P(OR0,U,12)="I",'$G(^DPT(+ORVP,.105)) S ERROR="This patient is not currently admitted!" +GMRA I PKG="GMRA" S ERROR="This action is not allowed on an allergy/adverse reaction!" G VQ ; no actions allowed on Allergies +MEDS I PKG="PS",'MEDPARM S ERROR="You are not authorized to enter med orders!" G VQ +RW I ACTION="RW" D RW^ORCACT01 G VQ ; rewrite/copy +XFR I ACTION="XFR" D XFR^ORCACT01 G VQ ; transfer to in/outpt +RN I ACTION="RN" D RN^ORCACT01 G VQ ; renew +TRM I $$DONE G VQ ; ORDSTS=1,2,7,12,13 +EV I ACTION="EV" D G VQ ; change delay event + . I ORDSTS'=10,ORDSTS'=11 S ERROR="This order has been released!" Q + . I DG="NV RX" S ERROR="Non-VA Med orders do not support this action!" Q + . I $$EVTORDER^OREVNTX(IFN) S ERROR="The release event for this order may not be changed!" Q + . S X=$P(ORA0,U,4) I X'=2,X'=3 S ERROR="Signed orders may not be delayed to another event!" Q +DC2 I ACTION="DC",ACTSTS="" D G VQ ; DC released order + . I $G(NATR)="A" D Q:$D(ERROR) + .. S X=$O(^ORE(100.2,"AO",+IFN,0)) I X S:'$G(^ORE(100.2,X,1)) ERROR="Future event orders may not be auto-discontinued!" Q + .. I $$GET1^DIQ(9.4,+$P(OR0,U,14)_",",1)="PSO",$G(DGPMT)=1 Q ;177 If admission auto-dc and order is outpt med then no further checking needed + .. I $G(DGPMT)=1,$P($G(^SC(+$P(OR0,U,10),0)),U,3)'="C" S ERROR="Only outpatient orders may be auto-discontinued!" Q + .. I $G(DGPMT)'=1,$P($G(^SC(+$P(OR0,U,10),0)),U,3)="C" S ERROR="Only inpatient orders may be auto-discontinued!" Q + . I PKG="RA",ORDSTS=6 S ERROR="Active Radiology orders cannot be discontinued!" Q + . I PKG="VBEC",ORDSTS=6 S ERROR="Active Blood Product orders cannot be discontinued!" Q + . I PKG="LR" D Q + .. I $$COLLECTD S ERROR="Lab orders that have been collected may not be discontinued!" Q + .. I $G(NATR)="A","^12^38^"'[(U_$P($G(DGPMA),U,18)_U),$$VALUE^ORX8(+IFN,"COLLECT")="SP",$P(OR0,U,8)'
1,ACTSTS S ERROR="This action is not allowed on a "_$$ACTION(X)_" order!" G VQ +RF I ACTION="RF" D G VQ + . I DG'="O RX" S ERROR="Only Outpatient Med orders may be refilled!" Q + . I ORDSTS=5 S ERROR="Pending orders may not be refilled!" Q + . N X,PSIFN S PSIFN=$G(^OR(100,+IFN,4)) + . S X=$$REFILL^PSOREF(PSIFN) I X'>0 S ERROR=$P(X,U,2) Q +CP I ACTION="CP" D G VQ ; complete + . I PKG'="OR" S ERROR="Only generic text orders may be completed through this option!" Q + . I ORDSTS=11!(ORDSTS=10) S ERROR="This order has not been released!" Q +AL I ACTION="AL" D G VQ + . I PKG'="LR",PKG'="RA",PKG'="GMRC" S ERROR="This order does not generate results!" Q + . I $P(OR3,U,10) S ERROR="This order is already flagged to alert the provider when resulted!" Q +XX I ACTION="XX" D XX^ORCACT01 G VQ ; edit/change +HD I ACTION="HD" D G VQ ; hold + . I PKG="FH" S ERROR="Diet orders cannot be held!" Q + . I PKG="LR" S ERROR="Lab orders cannot be held!" Q + . I PKG="RA" S ERROR="Radiology orders cannot be held!" Q + . I PKG="GMRC" S ERROR="Consult orders cannot be held!" Q + . I DG="NV RX" S ERROR="Non-VA Med orders cannot be held!" Q + . I ORDSTS=3 S ERROR="This order is already on hold!" Q + . I ORDSTS'=6,PKG="PS" S ERROR="Only active Pharmacy orders may be held!" Q + . I (ORDSTS=11)!(ORDSTS=10) S ERROR="This order has not been released to the service." Q +VQ S Y=$S($D(ERROR):0,1:1) + Q Y + ; +ACTION(X) ; -- Return text of action X + N Y S Y=$S(X="NW":"New",X="DC":"Discontinue",X="HD":"Hold",X="RL":"Release Hold",X="RN":"Renew",1:X) + Q Y + ; +NPO(ORIFN) ; -- Returns 1 or 0, if order ORIFN is for NPO + N X,Y S X=$$VALUE^ORX8(+ORIFN,"ORDERABLE",1,"E") + S Y=$S($E(X,1,3)="NPO":1,1:0) + Q Y + ; +COLLECTD() ; -- Lab order collected/active (incl all children)? + I (ORDSTS=11)!(ORDSTS=10) Q 0 ; unreleased + I '$O(^OR(100,+IFN,2,0)) Q (ORDSTS'=5) + ;I ORDSTS'=6 Q 1 ; Parent -> active instead of pending + N Y,Z S Y=1,Z=0 + F S Z=$O(^OR(100,+IFN,2,Z)) Q:Z'>0 I $P($G(^OR(100,Z,3)),U,3)=5 S Y=0 Q + Q Y + ; +DONE() ; -- sets ERROR if terminal status + I ORDSTS=1 S ERROR="This order has been discontinued!" Q 1 + I ORDSTS=2 S ERROR="This order has been completed!" Q 1 + I ORDSTS=7 S ERROR="This order has expired!" Q 1 + I ORDSTS=12 S ERROR="This order has been changed!" Q 1 + I ORDSTS=13 S ERROR="This order has been cancelled!" Q 1 + I ORDSTS=14 S ERROR="This order has lapsed!" Q 1 + I ORDSTS=15 S ERROR="This order has been renewed!" Q 1 + Q 0 + ; +DISABLED() ; -- Order dialog [or protocol] disabled? + N X,DLG S DLG=$P(OR0,U,5),X=0 I +DLG'>0 Q X + I VER'<3,DLG?1.N1";ORD(101.41," S X=$$MSG^ORXD(+DLG) Q X + S DLG=$S(PKG="RA":"RA OERR EXAM",PKG="GMRC":"GMRCOR CONSULT",1:"") + I $L(DLG) S DLG=+$O(^ORD(101.41,"AB",DLG,0)),X=$$MSG^ORXD(DLG) + Q X diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCACT01.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCACT01.m index bc7c3efe..7f7f6089 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCACT01.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCACT01.m @@ -1,135 +1,169 @@ -ORCACT01 ;SLC/MKB-Validate order actions cont ;03/28/2008 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**94,116,134,141,163,187,190,213,243**;Dec 17, 1997;Build 242 - ; -ES ; -- sign [on chart] - I ORDSTS=11,VER<3,PKG'="OR" S ERROR="This order cannot be released and must be discontinued!" Q - N X I ACTSTS=11!(ACTSTS=10) D Q:$L($G(ERROR)) - . I $P(ORA0,U,2)="DC",$$DONE^ORCACT0 D CANCEL^ORCSEND(+IFN),UNOTIF^ORCSIGN S OREBUILD=1 Q - . S X=$$DISABLED^ORCACT0 I X S ERROR=$P(X,U,2) Q - I ACTION="OC",$G(DG)="NV RX" S:MEDPARM<2 ERROR="You are not authorized to release non-VA med orders!" Q - S X=$P(ORA0,U,4) I X=3 S:ACTSTS'=11&(ACTSTS'=10) ERROR="This order does not require a signature!" Q - I X'=2 S ERROR="This order has been signed!" Q - I DG="O RX",ACTION'="ES",ACTION'="DS",$G(NATR)'="I" S ERROR="Outpatient meds may not be released without a clinician's signature!" Q - I (ACTION="ES"!(ACTION="DS")),$D(^XUSEC("ORELSE",DUZ)),$P(OR0,U,16)'<2 S ERROR="You are not privileged to sign this order!" Q - I ACTION="OC" S:MEDPARM<2 ERROR="You are not authorized to release med orders!" Q - I ACTION="RS" D Q:$D(ERROR) Q:$G(NATR)'="I" - . Q:ACTSTS=11 Q:ACTSTS=10 ;unreleased - ok - . S ERROR="This order has already been released!" -ES1 I PKG="PS" D ;authorized to write meds? - . N TYPE,OI,PSOI,DEAFLG,PKI,IVERROR - . S X=$G(^VA(200,DUZ,"PS")) - . I '$P(X,U) S ERROR="You are not authorized to sign med orders!" Q - . I $P(X,U,4),$$NOW^XLFDT>$P(X,U,4) S ERROR="You are no longer authorized to sign med orders!" Q - . ;Q:DG="IV RX" Q:$P(ORA0,U,2)="DC" ;don't need to ck DEA# - . Q:$P(ORA0,U,2)="DC" - . I DG="IV RX" D Q - . .I $$IVDEACHK(+IFN)=1 S ERROR="You must have a valid DEA# or VA# to sign this order!" - . S OI=+$$VALUE^ORX8(+IFN,"ORDERABLE") - . S PSOI=+$P($G(^ORD(101.43,OI,0)),U,2) Q:PSOI'>0 - . S TYPE=$S($P(DG," ")="O":"O",1:"I"),DEAFLG=$$OIDEA^PSSUTLA1(PSOI,TYPE) - . I (DEAFLG>0||$$ISCLOZ^ORALWORD(OI)),'$L($$DEA^XUSER()) S ERROR="You must have a valid DEA# or VA# to sign this order!" Q - . D PKISITE^ORWOR(.PKI) - . I $G(PKI),ACTION="RS",DEAFLG=1 S ERROR="This order cannot be released without a Digital Signature" Q - Q - ; -IVDEACHK(IFN) ; -- Returns value of prompt by ID - I '$G(IFN)!('$D(^OR(100,+$G(IFN),0))) Q "" - N I,DIAL,DIALTYP,FAIL,PATCLASS,RESULT,Y - S PATCLASS=$P(^OR(100,+IFN,0),U,12) - S RESULT=0 - ;if ORNP is not set then assume this is called from VistA not CPRS - I $G(ORNP)="" S ORNP=DUZ - S I=0,Y="" S:'$G(INST) INST=1 - F S I=$O(^OR(100,+IFN,4.5,"ID","ORDERABLE",I)) Q:I'>0!(RESULT=1) D - .S Y=$G(^OR(100,+IFN,4.5,I,1)) Q:Y'>0 - .;S PSOI=+$P($G(^ORD(101.43,Y,0)),U,2) Q:PSOI'>0 - .I PATCLASS="I" D Q - ..D FAILDEA^ORWDPS1(.FAIL,Y,ORNP,"I") I FAIL=1 S RESULT=1 - .S DIAL=+$P(^OR(100,+IFN,4.5,I,0),U,2) - .S DIALTYP=$S($P(^ORD(101.41,DIAL,0),U)["ADDITIVE":"A",1:"S") - .D FDEA1^ORWDPS1(.FAIL,Y,DIALTYP,ORNP) - .I FAIL=1 S RESULT=1 - .;I $$OIDEA^PSSUTLA1(PSOI,"I")>0 S RESULT=1 Q - Q RESULT - ; -XFR ; -- transfer to inpt/outpt [IFN=order to be transferred] - N OI,PS I DG="TPN" S ERROR="TPN orders may not be copied!" Q - I $$INACTIVE^ORCACT03 S ERROR="Orders for inactive orderables may not be transferred; please enter a new order!" Q - S OI=+$O(^OR(100,+IFN,.1,"B",0)),ORPS=$G(^ORD(101.43,OI,"PS")) - I DG="UD RX",'$P(ORPS,U,2) S ERROR="This drug may not be ordered for an outpatient!" Q - I DG="O RX" D Q:$L($G(ERROR)) - . I '$P(ORPS,U) S ERROR="This drug may not be ordered for an inpatient!" Q - . D:$O(^OR(100,+IFN,4.5,"ID","MISC",0)) DOSES^ORCACT02(+IFN) - Q - ; -RW ; -- rewrite/copy - I ACTSTS=12 S ERROR="Orders that have been dc'd due to editing may not be copied!" Q - I DG="NV RX" S ERROR="Non-VA Med orders cannot be copied!" Q - I DG="TPN" S ERROR="TPN orders may not be rewritten!" Q - I DG="UD RX",$$NTBG^ORCACT03(+IFN) S ERROR="This order has been marked 'Not to be Given' and may not be rewritten!" Q - I $$INACTIVE^ORCACT03 S ERROR="Orders for inactive orderables may not be copied; please enter a new order!" Q - I PKG="PS",'$$MEDOK^ORCACT03 S ERROR="This drug may not be ordered!" Q - I DG="O RX",$O(^OR(100,+IFN,4.5,"ID","MISC",0)) D DOSES^ORCACT02(+IFN) ;old form - Q - ; -RN ; -- renew - I PKG'="PS",PKG'="OR" S ERROR="This order may not be renewed!" Q - I (ORDSTS=11)!(ORDSTS=10) S ERROR="This order has not been released to the service." Q - I ACTSTS=12 S ERROR="Orders that have been dc'd due to editing may not be renewed!" Q - I $P(OR3,U,6) S ERROR="This order has already been "_$S($P($G(^OR(100,+$P(OR3,U,6),3)),U,11)=1:"changed!",1:"renewed!") Q - I PKG="OR" D Q ;Generic orders - . I $$INACTIVE^ORCACT03 S ERROR="Orders for inactive orderables may not be renewed!" Q - . I DG="ADT" S ERROR="M.A.S. orders may not be renewed!" Q - . I "^1^2^6^7^"[(U_ORDSTS_U) Q ;ok - . S ERROR="This order may not be renewed!" - I (PKG="PS"),$$INACTIVE^ORCACT03 S ERROR="Orders for inactive orderables may not be renewed!" Q - I '$$MEDOK^ORCACT03 S ERROR="This drug may not be ordered!" Q -RN1 N PSIFN S PSIFN=$G(^OR(100,+IFN,4)) - I PSIFN<1,'$O(^OR(100,+IFN,2,0)) S ERROR="Missing or invalid order number!" Q - I DG="O RX" D Q ;Outpt Meds - . N ORZ,ORD S ORZ=$L($T(RENEW^PSORENW),",") - . I ORZ>1 S ORD=+$$VALUE^ORX8(+IFN,"DRUG"),X=$$RENEW^PSORENW(PSIFN,ORD) - . S:ORZ'>1 X=$$RENEW^PSORENW(PSIFN) I X<1 S ERROR=$P(X,U,2) Q - . S X=+$P(X,U,2) D:X RESET^ORCACT03(+IFN,X) - . I $O(^OR(100,+IFN,4.5,"ID","MISC",0)) D DOSES^ORCACT02(+IFN) ;old format - I DG="UD RX",$$NTBG^ORCACT03(+IFN) S ERROR="This order has been marked 'Not to be Given' and may not be renewed!" Q - I ORDSTS=7,'$$IV^ORCACT03,$P(OR0,U,9)<$$FMADD^XLFDT(DT,-4) S ERROR="Inpatient med orders may not be renewed more than 4 days after expiration!" Q - I ORDSTS'=6,ORDSTS'=7 S ERROR="This order may not be renewed!" Q -RN2 I $O(^OR(100,+IFN,2,0))!$P(OR3,U,9) D Q:$D(ERROR)!'PSIFN - . I $P(OR3,U,9),$$VALUE^ORX8(+IFN,"SCHEDULE",1,"E")="NOW" S ERROR="One-time NOW orders may not be renewed!" Q - . N DAD,ORD3,I,Y S DAD=$S($P(OR3,U,9):+$P(OR3,U,9),1:+IFN),Y=0 - . S ORD3=$G(^OR(100,DAD,3)) I $P(ORD3,U,6) S ERROR="This complex order has already been renewed!" Q - . I $P(ORD3,U,3)'=6 S ERROR="This complex order is not active and may not be renewed!" Q - . I '$$AND^ORX8(DAD) S ERROR="Complex orders with sequential doses may not be renewed!" Q - . S I=0 F S I=+$O(^OR(100,DAD,2,I)) Q:I<1 D Q:Y - .. I I=+$O(^OR(100,DAD,2,0)),$$VALUE^ORX8(I,"SCHEDULE",1,"E")="NOW",$$VALUE^ORX8(DAD,"NOW") Q ;ignore NOW orders - .. I $P($G(^OR(100,I,3)),U,3)'=6 S Y=1,ERROR="Complex orders with terminated doses may not be renewed!" Q - .. I PSIFN<1 S X=$$ACTIVE^PSJORREN(+ORVP,$G(^OR(100,I,4))) I +X'=1 S ERROR="This order may not be renewed: "_$S(+X>1:"Inactive orderable item",1:$P(X,U,2)) Q - ;I DG="TPN" S ERROR="TPN orders may not be renewed!" Q - S X=$$ACTIVE^PSJORREN(+ORVP,PSIFN) Q:+X=1 ;Ok - I +X>1,$P(X,U,2) D RESET^ORCACT03(+IFN,+$P(X,U,2)) Q ;replace OI - S ERROR="This order may not be renewed: "_$P(X,U,2) - Q - ; -XX ; -- edit/change-- - I PKG="RA",ORDSTS'=11,ORDSTS'=10 S ERROR="Orders released to Radiology cannot be changed!" Q - I PKG="LR",ORDSTS'=11,ORDSTS'=10 S ERROR="Orders released to Lab cannot be changed!" Q - I PKG="FH",ORDSTS'=11,ORDSTS'=10 S ERROR="Orders released to Dietetics cannot be changed!" Q - I PKG="GMRC",ORDSTS'=11,ORDSTS'=10 S ERROR="Orders released to Consults cannot be changed!" Q - I DG="TPN" S ERROR="TPN orders may not be changed!" Q - I ORDSTS=3 S ERROR="Orders on hold may not be changed!" Q - I DG="UD RX",$$NTBG^ORCACT03(+IFN) S ERROR="This order has been marked 'Not to be Given' and may not be changed!" Q - I $O(^OR(100,+IFN,2,0)) S ERROR="Complex orders may not be changed!" Q - I $P(OR3,U,9) D Q:$D(ERROR) - . Q:$$VALUE^ORX8(+IFN,"SCHEDULE",1,"E")="NOW" ;NOW ok - . Q:'$O(^OR(100,+$P(OR3,U,9),4.5,"ID","CONJ",0)) ;no conj=1dose/ok - . S ERROR="Complex orders may not be changed!" Q - I $P(OR3,U,6) S ERROR="This order may not be changed - a "_$S($P($G(^OR(100,+$P(OR3,U,6),3)),U,11)=1:"change",1:"renewal")_" order already exists!" Q - I $P(OR3,U,11)=2 D Q:$D(ERROR) - . I (ORDSTS=10!(ORDSTS=11)),DG'="O RX" S ERROR="Unreleased renewals may not be changed!" Q - . I PKG="PS",ORDSTS=5 S ERROR="Pending renewals may not be changed!" Q - I $$INACTIVE^ORCACT03 S ERROR="Orders for inactive orderables may not be changed; please enter a new order!" Q - I PKG="PS",'$$MEDOK^ORCACT03 S ERROR="This drug may not be ordered!" Q - I DG="O RX",$O(^OR(100,+IFN,4.5,"ID","MISC",0)) D DOSES^ORCACT02(+IFN) ;old form - Q - ; +ORCACT01 ;SLC/MKB-Validate order actions cont ;5/6/04 20:39 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**94,116,134,141,163,187,190,213**;Dec 17, 1997 + ; +ES ; -- sign [on chart] + I ORDSTS=11,VER<3,PKG'="OR" S ERROR="This order cannot be released and must be discontinued!" Q + N X I ACTSTS=11!(ACTSTS=10) D Q:$L($G(ERROR)) + . I $P(ORA0,U,2)="DC",$$DONE^ORCACT0 D CANCEL^ORCSEND(+IFN),UNOTIF^ORCSIGN S OREBUILD=1 Q + . S X=$$DISABLED^ORCACT0 I X S ERROR=$P(X,U,2) Q + I ACTION="OC",$G(DG)="NV RX" S:MEDPARM<2 ERROR="You are not authorized to release non-VA med orders!" Q + S X=$P(ORA0,U,4) I X=3 S:ACTSTS'=11&(ACTSTS'=10) ERROR="This order does not require a signature!" Q + I X'=2 S ERROR="This order has been signed!" Q + I DG="O RX",ACTION'="ES",ACTION'="DS",$G(NATR)'="I" S ERROR="Outpatient meds may not be released without a clinician's signature!" Q + I (ACTION="ES"!(ACTION="DS")),$D(^XUSEC("ORELSE",DUZ)),$P(OR0,U,16)'<2 S ERROR="You are not privileged to sign this order!" Q + I ACTION="OC" S:MEDPARM<2 ERROR="You are not authorized to release med orders!" Q + I ACTION="RS" D Q:$D(ERROR) Q:$G(NATR)'="I" + . Q:ACTSTS=11 Q:ACTSTS=10 ;unreleased - ok + . S ERROR="This order has already been released!" +ES1 I PKG="PS" D ;authorized to write meds? + . N TYPE,OI,PSOI,DEAFLG,PKI + . S X=$G(^VA(200,DUZ,"PS")) + . I '$P(X,U) S ERROR="You are not authorized to sign med orders!" Q + . I $P(X,U,4),$$NOW^XLFDT>$P(X,U,4) S ERROR="You are no longer authorized to sign med orders!" Q + . Q:DG="IV RX" Q:$P(ORA0,U,2)="DC" ;don't need to ck DEA# + . S OI=+$$VALUE^ORX8(+IFN,"ORDERABLE") + . S PSOI=+$P($G(^ORD(101.43,OI,0)),U,2) Q:PSOI'>0 + . S TYPE=$S($P(DG," ")="O":"O",1:"I"),DEAFLG=$$OIDEA^PSSUTLA1(PSOI,TYPE) + . I DEAFLG>0,'$L($$DEA^XUSER()) S ERROR="You must have a valid DEA# or VA# to sign this order!" Q + . D PKISITE^ORWOR(.PKI) + . I $G(PKI),ACTION="RS",DEAFLG=1 S ERROR="This order cannot be released without a Digital Signature" Q + Q + ; +XFR ; -- transfer to inpt/outpt [IFN=order to be transferred] + N OI,PS I DG="TPN" S ERROR="TPN orders may not be copied!" Q + I $$INACTIVE S ERROR="Orders for inactive orderables may not be transferred; please enter a new order!" Q + S OI=+$O(^OR(100,+IFN,.1,"B",0)),ORPS=$G(^ORD(101.43,OI,"PS")) + I DG="UD RX",'$P(ORPS,U,2) S ERROR="This drug may not be ordered for an outpatient!" Q + I DG="O RX" D Q:$L($G(ERROR)) + . I '$P(ORPS,U) S ERROR="This drug may not be ordered for an inpatient!" Q + . D:$O(^OR(100,+IFN,4.5,"ID","MISC",0)) DOSES^ORCACT02(+IFN) + Q + ; +RW ; -- rewrite/copy + I ACTSTS=12 S ERROR="Orders that have been dc'd due to editing may not be copied!" Q + I DG="NV RX" S ERROR="Non-VA Med orders cannot be copied!" Q + I DG="TPN" S ERROR="TPN orders may not be rewritten!" Q + I DG="UD RX",$$NTBG(+IFN) S ERROR="This order has been marked 'Not to be Given' and may not be rewritten!" Q + I $$INACTIVE S ERROR="Orders for inactive orderables may not be copied; please enter a new order!" Q + I PKG="PS",'$$MEDOK S ERROR="This drug may not be ordered!" Q + I DG="O RX",$O(^OR(100,+IFN,4.5,"ID","MISC",0)) D DOSES^ORCACT02(+IFN) ;old form + Q + ; +RN ; -- renew + I PKG'="PS",PKG'="OR" S ERROR="This order may not be renewed!" Q + I (ORDSTS=11)!(ORDSTS=10) S ERROR="This order has not been released to the service." Q + I ACTSTS=12 S ERROR="Orders that have been dc'd due to editing may not be renewed!" Q + I $P(OR3,U,6) S ERROR="This order has already been "_$S($P($G(^OR(100,+$P(OR3,U,6),3)),U,11)=1:"changed!",1:"renewed!") Q + I PKG="OR" D Q ;Generic orders + . I $$INACTIVE S ERROR="Orders for inactive orderables may not be renewed!" Q + . I DG="ADT" S ERROR="M.A.S. orders may not be renewed!" Q + . I "^1^2^6^7^"[(U_ORDSTS_U) Q ;ok + . S ERROR="This order may not be renewed!" + I (PKG="PS"),$$INACTIVE S ERROR="Orders for inactive orderables may not be renewed!" Q + I '$$MEDOK S ERROR="This drug may not be ordered!" Q +RN1 N PSIFN S PSIFN=$G(^OR(100,+IFN,4)) + I PSIFN<1,'$O(^OR(100,+IFN,2,0)) S ERROR="Missing or invalid order number!" Q + I DG="O RX" D Q ;Outpt Meds + . N ORZ,ORD S ORZ=$L($T(RENEW^PSORENW),",") + . I ORZ>1 S ORD=+$$VALUE^ORX8(+IFN,"DRUG"),X=$$RENEW^PSORENW(PSIFN,ORD) + . S:ORZ'>1 X=$$RENEW^PSORENW(PSIFN) I X<1 S ERROR=$P(X,U,2) Q + . S X=+$P(X,U,2) D:X RESET(+IFN,X) + . I $O(^OR(100,+IFN,4.5,"ID","MISC",0)) D DOSES^ORCACT02(+IFN) ;old format + I DG="UD RX",$$NTBG(+IFN) S ERROR="This order has been marked 'Not to be Given' and may not be renewed!" Q + I ORDSTS=7,'$$IV,$P(OR0,U,9)<$$FMADD^XLFDT(DT,-4) S ERROR="Inpatient med orders may not be renewed more than 4 days after expiration!" Q + I ORDSTS'=6,ORDSTS'=7 S ERROR="This order may not be renewed!" Q +RN2 I $O(^OR(100,+IFN,2,0))!$P(OR3,U,9) D Q:$D(ERROR)!'PSIFN + . I $P(OR3,U,9),$$VALUE^ORX8(+IFN,"SCHEDULE",1,"E")="NOW" S ERROR="One-time NOW orders may not be renewed!" Q + . N DAD,ORD3,I,Y S DAD=$S($P(OR3,U,9):+$P(OR3,U,9),1:+IFN),Y=0 + . S ORD3=$G(^OR(100,DAD,3)) I $P(ORD3,U,6) S ERROR="This complex order has already been renewed!" Q + . I $P(ORD3,U,3)'=6 S ERROR="This complex order is not active and may not be renewed!" Q + . I '$$AND^ORX8(DAD) S ERROR="Complex orders with sequential doses may not be renewed!" Q + . S I=0 F S I=+$O(^OR(100,DAD,2,I)) Q:I<1 D Q:Y + .. I I=+$O(^OR(100,DAD,2,0)),$$VALUE^ORX8(I,"SCHEDULE",1,"E")="NOW",$$VALUE^ORX8(DAD,"NOW") Q ;ignore NOW orders + .. I $P($G(^OR(100,I,3)),U,3)'=6 S Y=1,ERROR="Complex orders with terminated doses may not be renewed!" Q + .. I PSIFN<1 S X=$$ACTIVE^PSJORREN(+ORVP,$G(^OR(100,I,4))) I +X'=1 S ERROR="This order may not be renewed: "_$S(+X>1:"Inactive orderable item",1:$P(X,U,2)) Q + ;I DG="TPN" S ERROR="TPN orders may not be renewed!" Q + S X=$$ACTIVE^PSJORREN(+ORVP,PSIFN) Q:+X=1 ;Ok + I +X>1,$P(X,U,2) D RESET(+IFN,+$P(X,U,2)) Q ;replace OI + S ERROR="This order may not be renewed: "_$P(X,U,2) + Q + ; +XX ; -- edit/change-- + I PKG="RA",ORDSTS'=11,ORDSTS'=10 S ERROR="Orders released to Radiology cannot be changed!" Q + I PKG="LR",ORDSTS'=11,ORDSTS'=10 S ERROR="Orders released to Lab cannot be changed!" Q + I PKG="FH",ORDSTS'=11,ORDSTS'=10 S ERROR="Orders released to Dietetics cannot be changed!" Q + I PKG="GMRC",ORDSTS'=11,ORDSTS'=10 S ERROR="Orders released to Consults cannot be changed!" Q + I DG="TPN" S ERROR="TPN orders may not be changed!" Q + I ORDSTS=3 S ERROR="Orders on hold may not be changed!" Q + I DG="UD RX",$$NTBG(+IFN) S ERROR="This order has been marked 'Not to be Given' and may not be changed!" Q + I $O(^OR(100,+IFN,2,0)) S ERROR="Complex orders may not be changed!" Q + I $P(OR3,U,9) D Q:$D(ERROR) + . Q:$$VALUE^ORX8(+IFN,"SCHEDULE",1,"E")="NOW" ;NOW ok + . Q:'$O(^OR(100,+$P(OR3,U,9),4.5,"ID","CONJ",0)) ;no conj=1dose/ok + . S ERROR="Complex orders may not be changed!" Q + I $P(OR3,U,6) S ERROR="This order may not be changed - a "_$S($P($G(^OR(100,+$P(OR3,U,6),3)),U,11)=1:"change",1:"renewal")_" order already exists!" Q + I $P(OR3,U,11)=2 D Q:$D(ERROR) + . I (ORDSTS=10!(ORDSTS=11)),DG'="O RX" S ERROR="Unreleased renewals may not be changed!" Q + . I PKG="PS",ORDSTS=5 S ERROR="Pending renewals may not be changed!" Q + I $$INACTIVE S ERROR="Orders for inactive orderables may not be changed; please enter a new order!" Q + I PKG="PS",'$$MEDOK S ERROR="This drug may not be ordered!" Q + I DG="O RX",$O(^OR(100,+IFN,4.5,"ID","MISC",0)) D DOSES^ORCACT02(+IFN) ;old form + Q + ; +INACTIVE() ; -- Returns 1 or 0, if OI is now inactive + N I,OI,PREOI,PREOIX,X,Y,ORNOW,DD,PSOI S Y=0,ORNOW=$$NOW^XLFDT + S I=0 F S I=+$O(^OR(100,+IFN,4.5,"ID","ORDERABLE",I)) Q:I'>0 D Q:Y + . S OI=+$G(^OR(100,+IFN,4.5,I,1)) + . I OI S X=$G(^ORD(101.43,OI,.1)) I X,X0 ;first + . S DD=+$G(^OR(100,+IFN,4.5,I,1)) Q:DD'>0 Q:$G(OI)'>0 + . S PSOI=+$P($G(^ORD(101.43,OI,0)),U,2),X=$$ITEM^PSSUTIL1(PSOI,DD) + . Q:X'>0 S X=+$O(^ORD(101.43,"ID",+$P(X,U,2)_";99PSP",0)) Q:X'>0 + . I $G(^ORD(101.43,X,.1)),$G(^(.1))1) + ; +NTBG(ORIFN) ; -- Inpt order marked as 'Not to be Given'? + N PSIFN,Y,ORI,ORCH S Y="" + S PSIFN=$G(^OR(100,+ORIFN,4)) I PSIFN>0 Q $$ENNG^PSJORUT2(+ORVP,PSIFN) + S ORI=0 F S ORI=$O(^OR(100,+ORIFN,2,ORI)) Q:ORI'>0 S ORCH=+$G(^(ORI,0)),PSIFN=$G(^OR(100,ORCH,4)) I PSIFN>0 S Y=$$ENNG^PSJORUT2(+ORVP,PSIFN) Q:Y + Q Y + ; +RESET(IFN,NEWOI) ; -- Update OI if changed before renewing + Q:'$G(IFN) Q:'$D(^OR(100,+IFN,0)) Q:'$G(NEWOI) + N I,ORIT S ORIT=+$O(^ORD(101.43,"ID",NEWOI_";99PSP",0)) Q:ORIT'>0 + S I=$O(^OR(100,+IFN,4.5,"ID","ORDERABLE",0)) + S:I ^OR(100,+IFN,4.5,I,1)=ORIT + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCACT2.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCACT2.m index 282c6ec3..fbef1eb9 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCACT2.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCACT2.m @@ -1,178 +1,175 @@ -ORCACT2 ;SLC/MKB-DC orders ; 03/27/2007 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,48,79,92,108,94,141,149,265,243**;Dec 17, 1997;Build 242 - ;;Per VHA Directive 2004-038, this routine should not be modified. -DC ; -- start here with: - ; ORNMBR = #,#,...,# of selected orders - ; - ; OREBUILD defined on return if Orders tab needs to be rebuilt - ; - N ORACT,ORI,NMBR,ORQUIT,ORIFN,ORDC,OREVT,ORNATR,ORPTLK,ORLK,IDX,ORDITM,ORPRINT,ORERR,ORSTS,ORPRNT,ORCLNUP,ORDA,ORCREATE,OR0,OR3,OREASON,ORXNP,ORX S VALMBCK="" - S ORPTLK=$$LOCK^ORX2(+ORVP) I 'ORPTLK W !!,$C(7),$P(ORPTLK,U,2) H 2 Q - I '$G(ORNMBR) S ORNMBR=$$ORDERS^ORCHART("") G:'ORNMBR DCQ - D FREEZE^ORCMENU S ORACT="DC",VALMBCK="R" K OREBUILD -DC1 F ORI=1:1:$L(ORNMBR,",") S NMBR=$P(ORNMBR,",",ORI) D:NMBR Q:$D(ORQUIT) - . S IDX=$G(^TMP("OR",$J,ORTAB,"IDX",NMBR)) - . S ORIFN=$S(ORTAB="MEDS":$P(IDX,U,4),1:$P(IDX,U)) Q:'ORIFN - . I '$D(^OR(100,+ORIFN,0)) W !,"This order has been deleted!" H 1 Q - . S:'$P(ORIFN,";",2) ORIFN=+ORIFN_";"_+$P($G(^OR(100,+ORIFN,3)),U,7) - . S ORDITM=$$ORDITEM(ORIFN) D SUBHDR(ORDITM) - . I '$$VALID^ORCACT0(ORIFN,ORACT,.ORERR) W !,ORERR H 1 Q - . S ORLK=$$LOCK1^ORX2(+ORIFN) I 'ORLK W !,$P(ORLK,U,2) H 1 Q - . S OR0=$G(^OR(100,+ORIFN,0)),OR3=$G(^(3)),ORSTS=$P($G(^(8,+$P(ORIFN,";",2),0)),U,15) - . S:$P(OR0,U,17) OREVT(+$P(OR0,U,17))="" ;ck event when done - . I (ORSTS=10)!(ORSTS=11) D UNREL Q ;delete unreleased orders - . I $P(OR0,U,11)=$O(^ORD(100.98,"B","TF",0)),$P(OR3,U,3)=6 D RESUME(ORIFN) Q:$G(ORQUIT) -DC2 . S ORDC(ORI)=ORIFN I $$NMSP^ORCD(+$P(OR0,U,14))="PS" S ORX=1 D ;meds - .. I $P(OR3,U,9),$$VALUE^ORX8(+ORIFN,"SCHEDULE")'="NOW",$$DOSES^ORCACT4($P(OR3,U,9))>1 D - ... N I,X S ORDC("DAD",+$P(OR3,U,9),+ORIFN)="" - ... W !,$C(7),"This is part of a complex order, which will be discontinued in its entirety:" - ... S I=0 F S I=$O(^OR(100,+$P(OR3,U,9),8,1,.1,I)) Q:I<1 S X=$G(^(I,0)) W:$$UP^XLFSTR(X)'=" FIRST DOSE NOW" !,X - .. N ORY,ORJ,ORV,ORTX,DA,DIK D DELAYED^ORX8(.ORY,+ORIFN) Q:ORY'>0 - .. W !,+ORY_" delayed order(s) for the same medication were found:" - .. S ORJ=0 F S ORJ=$O(ORY(ORJ)) Q:ORJ'>0 S ORV=ORY(ORJ) D TEXT^ORQ12(.ORTX,ORJ) W !,$E(ORTX(1),1,75)_$S($L(ORTX(1))>75:"...",1:""),!," >> delayed until "_$P(ORV,U,2) - .. I '$$OK(+ORY) W ! Q - .. W !,"Orders not signed or released to the service will be deleted.",! - .. S DIK="^OR(100,",DA=0 F S DA=$O(ORY(DA)) Q:DA'>0 D - ... N ORJ,ORSIG,STS,ORLKD - ... S ORLKD=$$LOCK1^ORX2(+DA) I 'ORLKD W !,$P(ORLKD,U,2) H 1 Q - ... S STS=$P($G(^OR(100,DA,3)),U,3),ORSIG=$S($P($G(^(8,1,0)),U,4)=2:0,1:1) - ... I STS'=10 S ORDC($$NXT)=DA Q ;released - add to list - ... D CLRDLY(DA):ORSIG,^DIK:'ORSIG S OREVT(+ORY(DA))="" - ... I $D(^TMP("ORNEW",$J,DA,1)) K ^(1) D UNLK1^ORX2(DA) ;unlock again - G:'$O(ORDC(0)) DCQ D:$D(ORDC("DAD")) COMPLX -DC3 S OREASON=$$DCREASON I OREASON'>0 D UNLOCK G DCQ - S ORNATR=$P(OREASON,U,3),ORCREATE=1 ; CHGD $$CREATE^ORX1(ORNATR) - I 'ORCREATE,$G(ORX),$D(^XUSEC("OREMAS",DUZ)),$$GET^XPAR("ALL","OR OREMAS MED ORDERS")<2 W $C(7),!,"You are not authorized to release med orders.",! G DC3 - I ORCREATE D I (ORNP="^")!($G(ORL)="^") D UNLOCK G DCQ - . S ORNP=$$PROVIDER^ORCMENU1 Q:ORNP="^" ;S:ORNP=DUZ ORNATR="E" - . I $G(ORX) D PROVIDER^ORCDPSIV I $G(ORQUIT) S ORNP="^" Q - . S:'$G(ORL) ORL=$$LOCATION^ORCMENU1 - W ! W:'ORCREATE "Discontinuing orders ..." - S ORPRNT=$$PRINT(ORNATR),ORCLNUP=$S(ORNATR="D":1,ORNATR="M":1,1:0) - S (ORI,ORPRINT)=0 F S ORI=$O(ORDC(ORI)) Q:ORI'>0 S ORIFN=ORDC(ORI) D - . I ORCREATE S ORDA=$$ACTION^ORCSAVE("DC",+ORIFN,ORNP) Q:'ORDA D SET(+ORIFN,ORNATR,+OREASON,$P(OREASON,U,2)) S ^TMP("ORNEW",$J,+ORIFN,ORDA)="" W "." Q - . ; release -> no order or ES req'd - . D EN^ORCSEND(+ORIFN,ORACT,3,1,ORNATR,+OREASON,.ORERR),UNLK1^ORX2(+ORIFN) - . I '$G(ORERR) S:$P(ORPRNT,U)!$P(ORPRNT,U,5) ORPRINT=ORPRINT+1,ORPRINT(ORPRINT)=+ORIFN_";" W "." Q - . W !,$$ORDITEM(+ORIFN)_" not discontinued." - . W:$L($P($G(ORERR),U,2)) !," >> "_$P(ORERR,U,2) W ! H 1 - W:ORCREATE "... discontinue order(s) placed." H 1 - I $O(ORPRINT(0)) D PRINT^ORPR02(ORVP,.ORPRINT,,ORL,ORPRNT) - S OREBUILD=1 ; rebuild orders list -DCQ D:$G(OREBUILD) UNOTIF^ORCSIGN ; undo notif? - D:'$D(^TMP("ORNEW",$J)) UNLOCK^ORX2(+ORVP) ;unlock if no new orders - S:$G(ORXNP) ORNP=ORXNP ;reset provider if needed - D:$D(OREVT) EVENT ;cancel any events? - Q - ; -UNLOCK ; -- Unlock orders in ORDC(ORI)=ORIFN - N ORI,ORIFN S ORI=0 - F S ORI=$O(ORDC(ORI)) Q:ORI'>0 S ORIFN=+ORDC(ORI) D UNLK1^ORX2(ORIFN) - Q - ; -OK(NUM) ; -- Ok to DC delayed order(s) too? - N X,Y,DIR S DIR(0)="YA",DIR("B")="NO" - S DIR("A")="Do you want to discontinue "_$S(NUM>1:"these orders",1:"this order")_" too? " - S DIR("?")="Enter YES to also cancel the delayed order(s), or NO to allow the order(s) to be activated when the designated event occurs." - W ! D ^DIR - Q +Y - ; -NXT() ; -- Return next available subscript in ORDC() - N Y S Y=$L(ORNMBR,",")+1 S:Y'>$O(ORDC(""),-1) Y=$O(ORDC(""),-1)+1 - Q Y - ; -PRINT(NATR) ; -- Ok to print order? - N I,OR1,Y S I=$O(^ORD(100.02,"C",NATR,0)),OR1=$G(^ORD(100.02,I,1)) - S Y=$P(OR1,U,2)_"^^^^"_$P(OR1,U,5) - Q Y - ; -ORDITEM(ID) ; -- Returns order text - ;N X,I,MORE S X="" - ;I $P(ID,";",2)>1 S I=$P($G(^OR(100,+ID,8,+$P(ID,";",2),0)),U,2),X=$S(I="DC":"Discontinue ",I="HD":"Hold ",1:"") - ;S I=$O(^OR(100,+ID,1,0)) Q:'I "" S MORE=$O(^(I)),X=X_$G(^(I,0)) - ;I $L(X)>68 S X=$E(X,1,68),MORE=1 - ;S:MORE X=X_" ..." - N X,ORX D TEXT^ORQ12(.ORX,ID,68) S X=ORX(1)_$S(ORX>1:" ...",1:"") - Q X - ; -SUBHDR(X) ; -- Display subheader of order being acted on - W !!,?(36-($L(X)\2)),"-- "_X_" --",! - Q - ; -COMPLX ; -- Ck for other child orders to be dc'd at same time - N DAD,CHLD - S DAD=0 F S DAD=$O(ORDC("DAD",DAD)) Q:DAD<1 D - . S CHLD=0 F S CHLD=$O(^OR(100,DAD,2,CHLD)) Q:CHLD<1 D - .. Q:"^1^2^7^12^13^14^15^"[(U_$P($G(^OR(100,CHLD,3)),U,3)_U) - .. Q:$D(ORDC("DAD",DAD,CHLD)) S ORDC($$NXT)=CHLD - Q - ; -DCREASON() ; -- Returns Reason for DC - N X,Y,DIC - ;I $D(^XUSEC("ORES",DUZ)) S Y=+$O(^ORD(100.03,"C","ORREQ",0)) I Y S Y(0)=$G(^ORD(100.03,Y,0)),Y=Y_U_$P(Y(0),U) G DCRQ ; silent - S DIC="^ORD(100.03,",DIC(0)="AEMQZ",DIC("B")=+$O(^ORD(100.03,"C","ORREQ",0)),DIC("W")="W:$L($P(^(0),U))>30 $E($P(^(0),U),31,999)" K:DIC("B")'>0 DIC("B") - S DIC("S")="I '$P(^(0),U,4),$P(^(0),U,5)="_+$O(^DIC(9.4,"C","OR",0))_",$P(^(0),U,7)'="_+$O(^ORD(100.02,"C","A",0)),DIC("A")="REASON FOR DC: " - D ^DIC -DCRQ S:Y>0 Y=Y_U_$S($P(Y(0),U,7):$P($G(^ORD(100.02,+$P(Y(0),U,7),0)),U,2),1:"W") ; ^nature - Q Y - ; -SET(ORDER,NATURE,REASON,TEXT,DCORIG) ; -- Set DC Reason into 6-node - Q:'$G(ORDER) Q:'$D(^OR(100,+ORDER,0)) S ORDER=+ORDER - I $L($G(NATURE)),NATURE'>0 S NATURE=$O(^ORD(100.02,"C",NATURE,0)) - S $P(^OR(100,ORDER,6),U,1,5)=$G(NATURE)_U_DUZ_U_$E($$NOW^XLFDT,1,12)_U_$G(REASON)_U_$G(TEXT),$P(^(6),U,9)=$G(DCORIG) - Q - ; -RESUME(ORDER) ; -- Resume tray service when dc'ing tubefeeding ORDER? - N X,Y,DIR,DIC,DA S X=$$RESUME^FHWORR(+ORVP) - I '$L(X) W !,"NOTE: NO current diet order exists for this patient!" Q - Q:'X I X=2 W !,"Note: Patient is on a WITHHOLD SERVICE order!" - S DIR(0)="YA",DIR("A")="Do you wish to resume tray service? " - S DIR("?")="Enter YES to resume the previous diet order",DIR("B")="NO" - D ^DIR I Y'=1 S:$D(DTOUT)!(X["^") ORQUIT=1 - D:Y=1 RESUME^ORCSAVE(+ORDER) - Q - ; -UNREL ; -- Process unreleased/delayed order - N ORA,ORA0,DA,DR,DIE - S ORA=+$P(ORIFN,";",2),ORA0=$G(^OR(100,+ORIFN,8,ORA,0)) - ;S ORDEL=$S(ORSTS=11:1,$P(ORA0,U,4)=2:1,1:0) - ;W !,"This order was not released "_$S(ORDEL:"to the service and will be deleted.",1:"but signed and will be cancelled.") - K:$P(ORA0,U,2)="DC" ^OR(100,+ORIFN,6) I $P(ORA0,U,2)="NW" D - . S:$P(OR3,U,5) $P(^OR(100,+$P(OR3,U,5),3),U,6)="" - . I $P(OR0,U,17) S DA=+$O(^ORE(100.2,"AO",+ORIFN,0)) I DA S DR="4///@",DIE=100.2 D ^DIE - D UNLK1^ORX2(+ORIFN) S OREBUILD=1 - I $D(^TMP("ORNEW",$J,+ORIFN,ORA)) K ^(ORA) D Q ;new this session - . W !,"This order will be deleted." H 1 - . D DELETE^ORCSAVE2(ORIFN),UNLK1^ORX2(+ORIFN) ;decrement lock again - W !,"This order was not released and will be cancelled." H 1 - D CANCEL^ORCSAVE2(ORIFN):ORSTS=11,CLRDLY(+ORIFN):ORSTS=10 - Q - ; -CLRDLY(IFN) ; -- [old Clear delayed fields] Cancel delayed [event]order - N STS,ORX S IFN=+$G(IFN) Q:IFN'>0 - Q:'$D(^OR(100,IFN,0)) S STS=$P($G(^(3)),U,3) - S ORX="Delayed "_$S(STS=10:"Order",1:"Release Event")_" Cancelled" - S ^OR(100,IFN,6)=$O(^ORD(100.02,"C","M",0))_U_DUZ_U_+$E($$NOW^XLFDT,1,12)_U_U_ORX - D STATUS^ORCSAVE2(IFN,13) S $P(^OR(100,IFN,8,1,0),U,15)=13 - Q - ; -EVENT ; -- Cancel event too? - N EVT,X - S EVT=0 F S EVT=$O(OREVT(EVT)) Q:EVT<1 D Q:$G(ORQUIT) - . Q:$G(^ORE(100.2,EVT,1)) Q:'$$EMPTY^OREVNTX(EVT) ;done or has orders - . ;W !!,$P($$NAME^OREVNTX(EVT)," ",2,99)_" has no more delayed orders." - . ;S DIR(0)="YA",DIR("A")="Do you want to cancel this event? " - . ;S DIR("?")="Enter NO if you wish to enter new delayed orders for this event, otherwise enter YES to terminate it." - . ;S DIR("B")="YES" D ^DIR I $D(DTOUT)!$D(DUOUT) S ORQUIT=1 Q - . D CANCEL^OREVNTX(EVT) S X=$P($$NAME^OREVNTX(EVT)," ",2,99) - . W !," ... "_X_" event cancelled." H 1 - . I $G(OREVENT),OREVENT=EVT D EX^OREVNT ;Return to Active Orders - Q - ; -DCD(IFN) ; -- order discontinued already? - N STS,Y,I S Y=0 I '$G(IFN) Q 1 - S STS=+$P($G(^OR(100,+IFN,3)),U,3) - I "^1^2^7^12^13^14^"[(U_STS_U) S Y=1 G DQ ;terminal sts - ;look for existing DC action awaiting ES: - S I=0 F S I=+$O(^OR(100,+IFN,8,"C","DC",I)) Q:I<1 I $P($G(^OR(100,+IFN,8,I,0)),U,15)=11 S Y=1 Q -DQ Q Y +ORCACT2 ;SLC/MKB-DC orders ; 08 May 2002 2:12 PM + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,48,79,92,108,94,141,149,265**;Dec 17, 1997;Build 17 + ;;Per VHA Directive 2004-038, this routine should not be modified. +DC ; -- start here with: + ; ORNMBR = #,#,...,# of selected orders + ; + ; OREBUILD defined on return if Orders tab needs to be rebuilt + ; + N ORACT,ORI,NMBR,ORQUIT,ORIFN,ORDC,OREVT,ORNATR,ORPTLK,ORLK,IDX,ORDITM,ORPRINT,ORERR,ORSTS,ORPRNT,ORCLNUP,ORDA,ORCREATE,OR0,OR3,OREASON,ORXNP,ORX S VALMBCK="" + S ORPTLK=$$LOCK^ORX2(+ORVP) I 'ORPTLK W !!,$C(7),$P(ORPTLK,U,2) H 2 Q + I '$G(ORNMBR) S ORNMBR=$$ORDERS^ORCHART("") G:'ORNMBR DCQ + D FREEZE^ORCMENU S ORACT="DC",VALMBCK="R" K OREBUILD +DC1 F ORI=1:1:$L(ORNMBR,",") S NMBR=$P(ORNMBR,",",ORI) D:NMBR Q:$D(ORQUIT) + . S IDX=$G(^TMP("OR",$J,ORTAB,"IDX",NMBR)) + . S ORIFN=$S(ORTAB="MEDS":$P(IDX,U,4),1:$P(IDX,U)) Q:'ORIFN + . I '$D(^OR(100,+ORIFN,0)) W !,"This order has been deleted!" H 1 Q + . S:'$P(ORIFN,";",2) ORIFN=+ORIFN_";"_+$P($G(^OR(100,+ORIFN,3)),U,7) + . S ORDITM=$$ORDITEM(ORIFN) D SUBHDR(ORDITM) + . I '$$VALID^ORCACT0(ORIFN,ORACT,.ORERR) W !,ORERR H 1 Q + . S ORLK=$$LOCK1^ORX2(+ORIFN) I 'ORLK W !,$P(ORLK,U,2) H 1 Q + . S OR0=$G(^OR(100,+ORIFN,0)),OR3=$G(^(3)),ORSTS=$P($G(^(8,+$P(ORIFN,";",2),0)),U,15) + . S:$P(OR0,U,17) OREVT(+$P(OR0,U,17))="" ;ck event when done + . I (ORSTS=10)!(ORSTS=11) D UNREL Q ;delete unreleased orders + . I $P(OR0,U,11)=$O(^ORD(100.98,"B","TF",0)),$P(OR3,U,3)=6 D RESUME(ORIFN) Q:$G(ORQUIT) +DC2 . S ORDC(ORI)=ORIFN I $$NMSP^ORCD(+$P(OR0,U,14))="PS" S ORX=1 D ;meds + .. I $P(OR3,U,9),$$VALUE^ORX8(+ORIFN,"SCHEDULE")'="NOW",$$DOSES^ORCACT4($P(OR3,U,9))>1 D + ... N I,X S ORDC("DAD",+$P(OR3,U,9),+ORIFN)="" + ... W !,$C(7),"This is part of a complex order, which will be discontinued in its entirety:" + ... S I=0 F S I=$O(^OR(100,+$P(OR3,U,9),8,1,.1,I)) Q:I<1 S X=$G(^(I,0)) W:$$UP^XLFSTR(X)'=" FIRST DOSE NOW" !,X + .. N ORY,ORJ,ORV,ORTX,DA,DIK D DELAYED^ORX8(.ORY,+ORIFN) Q:ORY'>0 + .. W !,+ORY_" delayed order(s) for the same medication were found:" + .. S ORJ=0 F S ORJ=$O(ORY(ORJ)) Q:ORJ'>0 S ORV=ORY(ORJ) D TEXT^ORQ12(.ORTX,ORJ) W !,$E(ORTX(1),1,75)_$S($L(ORTX(1))>75:"...",1:""),!," >> delayed until "_$P(ORV,U,2) + .. I '$$OK(+ORY) W ! Q + .. W !,"Orders not signed or released to the service will be deleted.",! + .. S DIK="^OR(100,",DA=0 F S DA=$O(ORY(DA)) Q:DA'>0 D + ... N ORJ,ORSIG,STS,ORLKD + ... S ORLKD=$$LOCK1^ORX2(+DA) I 'ORLKD W !,$P(ORLKD,U,2) H 1 Q + ... S STS=$P($G(^OR(100,DA,3)),U,3),ORSIG=$S($P($G(^(8,1,0)),U,4)=2:0,1:1) + ... I STS'=10 S ORDC($$NXT)=DA Q ;released - add to list + ... D CLRDLY(DA):ORSIG,^DIK:'ORSIG S OREVT(+ORY(DA))="" + ... I $D(^TMP("ORNEW",$J,DA,1)) K ^(1) D UNLK1^ORX2(DA) ;unlock again + G:'$O(ORDC(0)) DCQ D:$D(ORDC("DAD")) COMPLX +DC3 S OREASON=$$DCREASON I OREASON'>0 D UNLOCK G DCQ + S ORNATR=$P(OREASON,U,3),ORCREATE=1 ; CHGD $$CREATE^ORX1(ORNATR) + I 'ORCREATE,$G(ORX),$D(^XUSEC("OREMAS",DUZ)),$$GET^XPAR("ALL","OR OREMAS MED ORDERS")<2 W $C(7),!,"You are not authorized to release med orders.",! G DC3 + I ORCREATE D I (ORNP="^")!($G(ORL)="^") D UNLOCK G DCQ + . S ORNP=$$PROVIDER^ORCMENU1 Q:ORNP="^" ;S:ORNP=DUZ ORNATR="E" + . I $G(ORX) D PROVIDER^ORCDPSIV I $G(ORQUIT) S ORNP="^" Q + . S:'$G(ORL) ORL=$$LOCATION^ORCMENU1 + W ! W:'ORCREATE "Discontinuing orders ..." + S ORPRNT=$$PRINT(ORNATR),ORCLNUP=$S(ORNATR="D":1,ORNATR="M":1,1:0) + S (ORI,ORPRINT)=0 F S ORI=$O(ORDC(ORI)) Q:ORI'>0 S ORIFN=ORDC(ORI) D + . I ORCREATE S ORDA=$$ACTION^ORCSAVE("DC",+ORIFN,ORNP) Q:'ORDA D SET(+ORIFN,ORNATR,+OREASON,$P(OREASON,U,2)) S ^TMP("ORNEW",$J,+ORIFN,ORDA)="" W "." Q + . ; release -> no order or ES req'd + . D EN^ORCSEND(+ORIFN,ORACT,3,1,ORNATR,+OREASON,.ORERR),UNLK1^ORX2(+ORIFN) + . I '$G(ORERR) S:$P(ORPRNT,U)!$P(ORPRNT,U,5) ORPRINT=ORPRINT+1,ORPRINT(ORPRINT)=+ORIFN_";" W "." Q + . W !,$$ORDITEM(+ORIFN)_" not discontinued." + . W:$L($P($G(ORERR),U,2)) !," >> "_$P(ORERR,U,2) W ! H 1 + W:ORCREATE "... discontinue order(s) placed." H 1 + I $O(ORPRINT(0)) D PRINT^ORPR02(ORVP,.ORPRINT,,ORL,ORPRNT) + S OREBUILD=1 ; rebuild orders list +DCQ D:$G(OREBUILD) UNOTIF^ORCSIGN ; undo notif? + D:'$D(^TMP("ORNEW",$J)) UNLOCK^ORX2(+ORVP) ;unlock if no new orders + S:$G(ORXNP) ORNP=ORXNP ;reset provider if needed + D:$D(OREVT) EVENT ;cancel any events? + Q + ; +UNLOCK ; -- Unlock orders in ORDC(ORI)=ORIFN + N ORI,ORIFN S ORI=0 + F S ORI=$O(ORDC(ORI)) Q:ORI'>0 S ORIFN=+ORDC(ORI) D UNLK1^ORX2(ORIFN) + Q + ; +OK(NUM) ; -- Ok to DC delayed order(s) too? + N X,Y,DIR S DIR(0)="YA",DIR("B")="NO" + S DIR("A")="Do you want to discontinue "_$S(NUM>1:"these orders",1:"this order")_" too? " + S DIR("?")="Enter YES to also cancel the delayed order(s), or NO to allow the order(s) to be activated when the designated event occurs." + W ! D ^DIR + Q +Y + ; +NXT() ; -- Return next available subscript in ORDC() + N Y S Y=$L(ORNMBR,",")+1 S:Y'>$O(ORDC(""),-1) Y=$O(ORDC(""),-1)+1 + Q Y + ; +PRINT(NATR) ; -- Ok to print order? + N I,OR1,Y S I=$O(^ORD(100.02,"C",NATR,0)),OR1=$G(^ORD(100.02,I,1)) + S Y=$P(OR1,U,2)_"^^^^"_$P(OR1,U,5) + Q Y + ; +ORDITEM(ID) ; -- Returns order text + ;N X,I,MORE S X="" + ;I $P(ID,";",2)>1 S I=$P($G(^OR(100,+ID,8,+$P(ID,";",2),0)),U,2),X=$S(I="DC":"Discontinue ",I="HD":"Hold ",1:"") + ;S I=$O(^OR(100,+ID,1,0)) Q:'I "" S MORE=$O(^(I)),X=X_$G(^(I,0)) + ;I $L(X)>68 S X=$E(X,1,68),MORE=1 + ;S:MORE X=X_" ..." + N X,ORX D TEXT^ORQ12(.ORX,ID,68) S X=ORX(1)_$S(ORX>1:" ...",1:"") + Q X + ; +SUBHDR(X) ; -- Display subheader of order being acted on + W !!,?(36-($L(X)\2)),"-- "_X_" --",! + Q + ; +COMPLX ; -- Ck for other child orders to be dc'd at same time + N DAD,CHLD + S DAD=0 F S DAD=$O(ORDC("DAD",DAD)) Q:DAD<1 D + . S CHLD=0 F S CHLD=$O(^OR(100,DAD,2,CHLD)) Q:CHLD<1 D + .. Q:"^1^2^7^12^13^14^15^"[(U_$P($G(^OR(100,CHLD,3)),U,3)_U) + .. Q:$D(ORDC("DAD",DAD,CHLD)) S ORDC($$NXT)=CHLD + Q + ; +DCREASON() ; -- Returns Reason for DC + N X,Y,DIC + ;I $D(^XUSEC("ORES",DUZ)) S Y=+$O(^ORD(100.03,"C","ORREQ",0)) I Y S Y(0)=$G(^ORD(100.03,Y,0)),Y=Y_U_$P(Y(0),U) G DCRQ ; silent + S DIC="^ORD(100.03,",DIC(0)="AEMQZ",DIC("B")=+$O(^ORD(100.03,"C","ORREQ",0)),DIC("W")="W:$L($P(^(0),U))>30 $E($P(^(0),U),31,999)" K:DIC("B")'>0 DIC("B") + S DIC("S")="I '$P(^(0),U,4),$P(^(0),U,5)="_+$O(^DIC(9.4,"C","OR",0))_",$P(^(0),U,7)'="_+$O(^ORD(100.02,"C","A",0)),DIC("A")="REASON FOR DC: " ;is referenced by DBIA #2058 + D ^DIC +DCRQ S:Y>0 Y=Y_U_$S($P(Y(0),U,7):$P($G(^ORD(100.02,+$P(Y(0),U,7),0)),U,2),1:"W") ; ^nature + Q Y + ; +SET(ORDER,NATURE,REASON,TEXT) ; -- Set DC Reason into 6-node + Q:'$G(ORDER) Q:'$D(^OR(100,+ORDER,0)) S ORDER=+ORDER + I $L($G(NATURE)),NATURE'>0 S NATURE=$O(^ORD(100.02,"C",NATURE,0)) + S ^OR(100,ORDER,6)=$G(NATURE)_U_DUZ_U_$E($$NOW^XLFDT,1,12)_U_$G(REASON)_U_$G(TEXT) + Q + ; +RESUME(ORDER) ; -- Resume tray service when dc'ing tubefeeding ORDER? + N X,Y,DIR,DIC,DA S X=$$RESUME^FHWORR(+ORVP) + I '$L(X) W !,"NOTE: NO current diet order exists for this patient!" Q + Q:'X I X=2 W !,"Note: Patient is on a WITHHOLD SERVICE order!" + S DIR(0)="YA",DIR("A")="Do you wish to resume tray service? " + S DIR("?")="Enter YES to resume the previous diet order",DIR("B")="NO" + D ^DIR I Y'=1 S:$D(DTOUT)!(X["^") ORQUIT=1 + D:Y=1 RESUME^ORCSAVE(+ORDER) + Q + ; +UNREL ; -- Process unreleased/delayed order + N ORA,ORA0,ORDEL,DA,DR,DIE + S ORA=+$P(ORIFN,";",2),ORA0=$G(^OR(100,+ORIFN,8,ORA,0)) + S ORDEL=$S(ORSTS=11:1,$P(ORA0,U,4)=2:1,1:0) + W !,"This order was not released "_$S(ORDEL:"to the service and will be deleted.",1:"but signed and will be cancelled.") H 1 I ORDEL D + . K:$P(ORA0,U,2)="DC" ^OR(100,+ORIFN,6) I $P(ORA0,U,2)="NW" D + .. S:$P(OR3,U,5) $P(^OR(100,+$P(OR3,U,5),3),U,6)="" + .. I $P(OR0,U,17) S DA=+$O(^ORE(100.2,"AO",+ORIFN,0)) I DA S DR="4///@",DIE=100.2 D ^DIE + . D DELETE^ORCSAVE2(ORIFN) + D CLRDLY(+ORIFN):'ORDEL,UNLK1^ORX2(+ORIFN) S OREBUILD=1 + I $D(^TMP("ORNEW",$J,+ORIFN,ORA)) K ^(ORA) D UNLK1^ORX2(+ORIFN) ;decrement lock again + Q + ; +EVENT ; -- Cancel event too? + N EVT,X + S EVT=0 F S EVT=$O(OREVT(EVT)) Q:EVT<1 D Q:$G(ORQUIT) + . Q:$G(^ORE(100.2,EVT,1)) Q:'$$EMPTY^OREVNTX(EVT) ;done or has orders + . ;W !!,$P($$NAME^OREVNTX(EVT)," ",2,99)_" has no more delayed orders." + . ;S DIR(0)="YA",DIR("A")="Do you want to cancel this event? " + . ;S DIR("?")="Enter NO if you wish to enter new delayed orders for this event, otherwise enter YES to terminate it." + . ;S DIR("B")="YES" D ^DIR I $D(DTOUT)!$D(DUOUT) S ORQUIT=1 Q + . D CANCEL^OREVNTX(EVT) S X=$P($$NAME^OREVNTX(EVT)," ",2,99) + . W !," ... "_X_" event cancelled." H 1 + . I $G(OREVENT),OREVENT=EVT D EX^OREVNT ;Return to Active Orders + Q + ; +DCD(IFN) ; -- order discontinued already? + N STS,Y,I S Y=0 I '$G(IFN) Q 1 + S STS=+$P($G(^OR(100,+IFN,3)),U,3) + I "^1^2^7^12^13^14^"[(U_STS_U) S Y=1 G DQ ;terminal sts + ;look for existing DC action awaiting ES: + S I=0 F S I=+$O(^OR(100,+IFN,8,"C","DC",I)) Q:I<1 I $P($G(^OR(100,+IFN,8,I,0)),U,15)=11 S Y=1 Q +DQ Q Y + ; +CLRDLY(IFN) ; -- [old Clear delayed fields] Cancel delayed [event]order + N STS,ORX S IFN=+$G(IFN) Q:IFN'>0 + Q:'$D(^OR(100,IFN,0)) S STS=$P($G(^(3)),U,3) + S ORX="Delayed "_$S(STS=10:"Order",1:"Release Event")_" Cancelled" + S ^OR(100,IFN,6)=$O(^ORD(100.02,"C","M",0))_U_DUZ_U_+$E($$NOW^XLFDT,1,12)_U_U_ORX + D STATUS^ORCSAVE2(IFN,13) S $P(^OR(100,IFN,8,1,0),U,15)=13 + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCB.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCB.m index c205b23a..e65d70dc 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCB.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCB.m @@ -1,165 +1,164 @@ -ORCB ;SLC/MKB-Notifications followup for LMgr chart ;4/5/01 21:32 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,36,48,70,108,116,243**;Dec 17, 1997;Build 242 -EN(DFN,ORFLG,DGRP,DEL) ; -- main entry point - Q:'$G(DFN) Q:'$G(ORFLG) - N BEG,END D SLCT1^ORQPT - S DGRP=$P($G(^ORD(100.98,+$G(DGRP),0)),U,3) S:'$L(DGRP) DGRP="ALL" - S (BEG,END)="" I ORFLG=6 D ;get BEG from XQAID for New Orders - . S BEG=$P(XQAID,";",3) I BEG'?7N1".".6N!(BEG' to continue ..." R X:DTIME - Q - ; -PHDR ; -- protocol menu header code - N NUM,ORI,ORDEF,I,X K ORNMBR,OREBUILD - S VALMSG=$$MSG^ORCHART D SHOW^VALM - S NUM=+$P($G(^TMP("OR",$J,"CURRENT",0)),U,2) - S XQORM("#")=$O(^ORD(101,"B","ORCB ACTIONS",0))_"^1:"_NUM - S ORI=$S(ORFLG=5:1,ORFLG=11:"2,3,4",ORFLG=12:"3,4,5,6,7",1:8) - S ORDEF=$S(ORFLG=5:1,ORFLG=11:9,ORFLG=12:5,1:10) - F I=1:1:$L(ORI,",") S X=$T(ACTIONS+$P(ORI,",",I)),XQORM("KEY",$P(X,";",3))=$O(^ORD(101,"B","ORC "_$P(X,";",4)_" ORDERS",0))_"^1" - S XQORM("KEY","DT")=$O(^ORD(101,"B","ORC DETAILED DISPLAY",0))_"^1" - I +$P($G(^TMP("OR",$J,"CURRENT",0)),U,2)>0,XQORM("B")="Quit" S X=$T(ACTIONS+ORDEF),X=$P(X,";",4),XQORM("KEY",$P(X," "))=$O(^ORD(101,"B","ORC "_X_" ORDERS",0))_"^1",XQORM("B")=$$LOWER^VALM1(X)_" Orders" ; default action - S:'$G(ORL) ORL=$$FINDLOC ; attempt to determine location from orders - Q - ; -SELECT ; -- process selected order(s) - N MENU,XQORM,Y,ORNMBR,OREBUILD,ORY S VALMBCK="" - S ORNMBR=$P(XQORNOD(0),"=",2) D SELECT^ORCHART(ORNMBR) - S:'$G(ORFLG) ORFLG=$P($P(^TMP("OR",$J,"CURRENT",0),U,3),";",3) - S MENU=$S(ORFLG=5:"EXPIRING",ORFLG=11:"UNSIGNED",ORFLG=12:"FLAGGED",1:"NEW") - S XQORM=$O(^ORD(101,"B","ORCB "_MENU_" MENU",0))_";ORD(101," - I 'XQORM W !!,"ERROR" H 2 G SQ - S XQORM(0)="1AD",XQORM("A")="Select action: " - W ! D EN^XQORM G:Y'>0 SQ M ORY=Y - I $D(^ORD(101,+$P(ORY(1),U,2),20)) X ^(20) S VALMBCK="R" - I $G(OREBUILD) D:ORFLG=12 UNFLAG D TAB^ORCHART(ORTAB,1) Q -SQ D DESELECT^ORCHART(ORNMBR) - Q - ; -UNFLAG ; -- Unflag orders - N ORX,ORI,NUM,ORIFN,ORA,X - S ORX=$P(ORY(1),U,3) Q:(ORX="Unflag")!(ORX="Detailed Display") - F ORI=1:1:$L(ORNMBR,",") S NUM=$P(ORNMBR,",",ORI) I NUM D - . S ORIFN=$P(^TMP("OR",$J,"CURRENT","IDX",NUM),U) Q:'ORIFN - . S ORA=+$P(ORIFN,";",2),ORIFN=+ORIFN Q:'ORA - . Q:'$D(^OR(100,ORIFN)) Q:(ORX="Edit")&($P(^(ORIFN,3),U,3)'=12) - . S X=+$G(^OR(100,ORIFN,8,ORA,0)),$P(^(3),U)=0,$P(^(3),U,6,8)=X_U_DUZ_"^Unflagged by action" ; Unflag - . S X=ORIFN_";"_ORA D MSG^ORCFLAG(X) - Q - ; -EN1(ORIFN,ACTION) ; -- entry point to display single order - Q:'ORIFN Q:'$D(^OR(100,ORIFN)) - Q:"^^NEW^RENEW^REPLACE^"'[(U_$G(ACTION)_U) - S DFN=+$P(^OR(100,ORIFN,0),U,2) Q:'DFN - S ^TMP("ORXPND",$J,0)=ORIFN_U_$G(ACTION) - D EN1^ORCXPND(DFN,ORIFN) - K ^TMP("ORXPND",$J),^TMP("OR",$J) - Q - ; -NEW ; -- Add new order as follow-up action - N IFN,TYPE,ORIG,ORNP,ORPTLK S VALMBCK="" K ^TMP("ORNEW",$J) - S ORPTLK=$$LOCK^ORX2(+ORVP) I 'ORPTLK W !!,$C(7),$P(ORPTLK,U,2) H 2 Q - S ORNP=$$PROVIDER^ORCMENU1,VALMBCK="R" G:ORNP="^" NWQ - I '$G(ORL) S ORL=$$LOCATION^ORCMENU1 G:ORL["^" NWQ - S ORIG=+$P($G(^TMP("ORXPND",$J,0)),U),IFN=+$P($G(^OR(100,+ORIG,0)),U,5) - G:'IFN NWQ S TYPE=$P($G(^ORD(101.41,IFN,0)),U,4) - ; If 2.5 order, use DG or PKG to get dlg - D FULL^VALM1,ORDER^ORCMENU - I $O(^TMP("ORNEW",$J,0)) D SIGN,NOTIF^ORCMENU2 - K ^TMP("ORNEW",$J) S VALMBCK="R" -NWQ D UNLOCK^ORX2(+ORVP) - Q - ; -EDIT ; -- Edit order as follow-up action - N OREBUILD K ^TMP("ORNEW",$J) - D EDIT^ORCACT I $G(OREBUILD) D - . D SIGN,NOTIF^ORCMENU2 - . S $P(^TMP("ORXPND",$J,0),U,2)="" - K ^TMP("ORNEW",$J) S VALMBCK="R" - D UNLOCK^ORX2(+ORVP) - Q - ; -RENEW ; --Renew order as follow-up action - N OREBUILD K ^TMP("ORNEW",$J) - D RENEW^ORCACT I $G(OREBUILD) D - . D SIGN,NOTIF^ORCMENU2 - . S $P(^TMP("ORXPND",$J,0),U,2)="" - . K ^TMP("ORXPND",$J) D INIT^ORCXPND - K ^TMP("ORNEW",$J) S VALMBCK="R" - D UNLOCK^ORX2(+ORVP) - Q - ; -SIGN ; -- Sign new order - N ORIFN,ORTAB,ORNMBR,CNT - S ORTAB="NEW",(ORIFN,CNT)=0,ORNMBR="" - F S ORIFN=+$O(^TMP("ORNEW",$J,ORIFN)) Q:ORIFN'>0 S CNT=CNT+1,^TMP("OR",$J,"NEW","IDX",CNT)=ORIFN,ORNMBR=ORNMBR_CNT_"," - I CNT D EN^ORCSIGN K ^TMP("OR",$J,"NEW","IDX") - Q - ; -EXIT ; -- exit action - I $P($P(^TMP("OR",$J,"CURRENT",0),U,3),";",3)=12 D ; flagged orders - . Q:'$$GET^XPAR("ALL","ORPF AUTO UNFLAG") - . N ORI,ORIFN,ORA,XQAKILL,ORN,ORUNF - . S ORUNF=+$E($$NOW^XLFDT,1,12)_U_DUZ_"^Auto-Unflagged" - . S ORI=0 F S ORI=$O(^TMP("OR",$J,"CURRENT","IDX",ORI)) Q:ORI'>0 S ORIFN=$P(^(ORI),U),ORA=+$P(ORIFN,";",2) I ORIFN,$D(^OR(100,+ORIFN,0)) S $P(^(8,ORA,3),U)=0,$P(^(3),U,6,8)=ORUNF D MSG^ORCFLAG(ORIFN) ; unflag - . S ORN=+$O(^ORD(100.9,"B","FLAGGED ORDERS",0)) - . S XQAKILL=$$XQAKILL^ORB3F1(ORN) D:$D(XQAID) DELETE^XQALERT - D EXIT^ORCHART - Q - ; -ACTIONS ;;KEY;NAME - ;;RN;RENEW - ;;$;SIGN - ;;DC;DISCONTINUE - ;;ED;CHANGE - ;;UF;UNFLAG - ;;HD;HOLD - ;;RL;UNHOLD - ;;VF;VERIFY - ;;;SIGN ALL - ;;;VERIFY ALL - ; -ALL ; -- Select ALL orders - N X,Y,DIR,MAX - S MAX=+$P($G(^TMP("OR",$J,"CURRENT",0)),U,2),X="1-"_MAX,Y="" - S DIR(0)="L^1:"_MAX,DIR("V")="" D:MAX ^DIR - S ORNMBR=Y - Q - ; -FINDLOC() ; -- Loop through orders in alert to find assigned location - N ORI,ORIFN,ORY S ORI=0,ORY="" - F S ORI=$O(^TMP("OR",$J,"CURRENT","IDX",ORI)) Q:ORI'>0 S ORIFN=+^(ORI),ORX=$P($G(^OR(100,ORIFN,0)),U,10) S:ORY="" ORY=ORX I ORY'="",ORX'=ORY S ORY="" Q ; ORY=location for all orders, or "" if different - Q ORY - ; -DELETE ; -- Delete current alert - N %,%Y,X,Y,PRMT,XQAKILL S VALMBCK="",XQAKILL=1 - S PRMT="Your "_$S(ORFLG=5:"Expiring",ORFLG=11:"Unsigned",ORFLG=12:"Flagged",ORFLG=9:"Unverified",1:"New")_" Orders alert for "_$G(ORPNM)_" will be deleted!" -D1 W !!,PRMT,!,"Are you sure" S %=2 D YN^DICN - I (%<0)!(%=2) W !,"Nothing deleted." H 2 Q - I %=0 D G D1 - . W !!,"This action will delete the alert you are currently processing; the alert will",!,"disappear automatically when all orders have been acted on, but this action may",!,"be used to remove the alert if some orders are to be left unchanged." - . W !,"Press to continue ..." R X:DTIME - W !,"Removing alert ..." D:$D(XQAID) DEL^ORB3FUP1(.Y,XQAID) - I $G(Y)="TRUE" W " done." S VALMBCK="Q",DEL=1 H 2 - E W " unable to delete alert." H 2 - Q +ORCB ;SLC/MKB-Notifications followup for LMgr chart ;4/5/01 21:32 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,36,48,70,108,116**;Dec 17, 1997 +EN(DFN,ORFLG,DGRP,DEL) ; -- main entry point + Q:'$G(DFN) Q:'$G(ORFLG) + N BEG,END D SLCT1^ORQPT + S DGRP=$P($G(^ORD(100.98,+$G(DGRP),0)),U,3) S:'$L(DGRP) DGRP="ALL" + S (BEG,END)="" I ORFLG=6 D ;get BEG from XQAID for New Orders + . S BEG=$P(XQAID,";",3) I BEG'?7N1".".6N!(BEG' to continue ..." R X:DTIME + Q + ; +PHDR ; -- protocol menu header code + N NUM,ORI,ORDEF,I,X K ORNMBR,OREBUILD + S VALMSG=$$MSG^ORCHART D SHOW^VALM + S NUM=+$P($G(^TMP("OR",$J,"CURRENT",0)),U,2) + S XQORM("#")=$O(^ORD(101,"B","ORCB ACTIONS",0))_"^1:"_NUM + S ORI=$S(ORFLG=5:1,ORFLG=11:"2,3,4",ORFLG=12:"3,4,5,6,7",1:8) + S ORDEF=$S(ORFLG=5:1,ORFLG=11:9,ORFLG=12:5,1:10) + F I=1:1:$L(ORI,",") S X=$T(ACTIONS+$P(ORI,",",I)),XQORM("KEY",$P(X,";",3))=$O(^ORD(101,"B","ORC "_$P(X,";",4)_" ORDERS",0))_"^1" + S XQORM("KEY","DT")=$O(^ORD(101,"B","ORC DETAILED DISPLAY",0))_"^1" + I +$P($G(^TMP("OR",$J,"CURRENT",0)),U,2)>0,XQORM("B")="Quit" S X=$T(ACTIONS+ORDEF),X=$P(X,";",4),XQORM("KEY",$P(X," "))=$O(^ORD(101,"B","ORC "_X_" ORDERS",0))_"^1",XQORM("B")=$$LOWER^VALM1(X)_" Orders" ; default action + S:'$G(ORL) ORL=$$FINDLOC ; attempt to determine location from orders + Q + ; +SELECT ; -- process selected order(s) + N MENU,XQORM,Y,ORNMBR,OREBUILD,ORY S VALMBCK="" + S ORNMBR=$P(XQORNOD(0),"=",2) D SELECT^ORCHART(ORNMBR) + S:'$G(ORFLG) ORFLG=$P($P(^TMP("OR",$J,"CURRENT",0),U,3),";",3) + S MENU=$S(ORFLG=5:"EXPIRING",ORFLG=11:"UNSIGNED",ORFLG=12:"FLAGGED",1:"NEW") + S XQORM=$O(^ORD(101,"B","ORCB "_MENU_" MENU",0))_";ORD(101," + I 'XQORM W !!,"ERROR" H 2 G SQ + S XQORM(0)="1AD",XQORM("A")="Select action: " + W ! D EN^XQORM G:Y'>0 SQ M ORY=Y + I $D(^ORD(101,+$P(ORY(1),U,2),20)) X ^(20) S VALMBCK="R" + I $G(OREBUILD) D:ORFLG=12 UNFLAG D TAB^ORCHART(ORTAB,1) Q +SQ D DESELECT^ORCHART(ORNMBR) + Q + ; +UNFLAG ; -- Unflag orders + N X,ORI,NUM,ORIFN,ORA + S X=$P(ORY(1),U,3) Q:(X="Unflag")!(X="Detailed Display") + F ORI=1:1:$L(ORNMBR,",") S NUM=$P(ORNMBR,",",ORI) I NUM D + . S ORIFN=$P(^TMP("OR",$J,"CURRENT","IDX",NUM),U) Q:'ORIFN + . S ORA=+$P(ORIFN,";",2),ORIFN=+ORIFN Q:'ORA + . Q:'$D(^OR(100,ORIFN)) Q:(X="Edit")&($P(^(ORIFN,3),U,3)'=12) + . S $P(^OR(100,ORIFN,8,ORA,3),U)=0 ; Unflag + Q + ; +EN1(ORIFN,ACTION) ; -- entry point to display single order + Q:'ORIFN Q:'$D(^OR(100,ORIFN)) + Q:"^^NEW^RENEW^REPLACE^"'[(U_$G(ACTION)_U) + S DFN=+$P(^OR(100,ORIFN,0),U,2) Q:'DFN + S ^TMP("ORXPND",$J,0)=ORIFN_U_$G(ACTION) + D EN1^ORCXPND(DFN,ORIFN) + K ^TMP("ORXPND",$J),^TMP("OR",$J) + Q + ; +NEW ; -- Add new order as follow-up action + N IFN,TYPE,ORIG,ORNP,ORPTLK S VALMBCK="" K ^TMP("ORNEW",$J) + S ORPTLK=$$LOCK^ORX2(+ORVP) I 'ORPTLK W !!,$C(7),$P(ORPTLK,U,2) H 2 Q + S ORNP=$$PROVIDER^ORCMENU1,VALMBCK="R" G:ORNP="^" NWQ + I '$G(ORL) S ORL=$$LOCATION^ORCMENU1 G:ORL["^" NWQ + S ORIG=+$P($G(^TMP("ORXPND",$J,0)),U),IFN=+$P($G(^OR(100,+ORIG,0)),U,5) + G:'IFN NWQ S TYPE=$P($G(^ORD(101.41,IFN,0)),U,4) + ; If 2.5 order, use DG or PKG to get dlg + D FULL^VALM1,ORDER^ORCMENU + I $O(^TMP("ORNEW",$J,0)) D SIGN,NOTIF^ORCMENU2 + K ^TMP("ORNEW",$J) S VALMBCK="R" +NWQ D UNLOCK^ORX2(+ORVP) + Q + ; +EDIT ; -- Edit order as follow-up action + N OREBUILD K ^TMP("ORNEW",$J) + D EDIT^ORCACT I $G(OREBUILD) D + . D SIGN,NOTIF^ORCMENU2 + . S $P(^TMP("ORXPND",$J,0),U,2)="" + K ^TMP("ORNEW",$J) S VALMBCK="R" + D UNLOCK^ORX2(+ORVP) + Q + ; +RENEW ; --Renew order as follow-up action + N OREBUILD K ^TMP("ORNEW",$J) + D RENEW^ORCACT I $G(OREBUILD) D + . D SIGN,NOTIF^ORCMENU2 + . S $P(^TMP("ORXPND",$J,0),U,2)="" + . K ^TMP("ORXPND",$J) D INIT^ORCXPND + K ^TMP("ORNEW",$J) S VALMBCK="R" + D UNLOCK^ORX2(+ORVP) + Q + ; +SIGN ; -- Sign new order + N ORIFN,ORTAB,ORNMBR,CNT + S ORTAB="NEW",(ORIFN,CNT)=0,ORNMBR="" + F S ORIFN=+$O(^TMP("ORNEW",$J,ORIFN)) Q:ORIFN'>0 S CNT=CNT+1,^TMP("OR",$J,"NEW","IDX",CNT)=ORIFN,ORNMBR=ORNMBR_CNT_"," + I CNT D EN^ORCSIGN K ^TMP("OR",$J,"NEW","IDX") + Q + ; +EXIT ; -- exit action + I $P($P(^TMP("OR",$J,"CURRENT",0),U,3),";",3)=12 D ; flagged orders + . Q:'$$GET^XPAR("ALL","ORPF AUTO UNFLAG") + . N ORI,ORIFN,ORA,XQAKILL,ORN,ORUNF + . S ORUNF=+$E($$NOW^XLFDT,1,12)_U_DUZ_"^Auto-Unflagged" + . S ORI=0 F S ORI=$O(^TMP("OR",$J,"CURRENT","IDX",ORI)) Q:ORI'>0 S ORIFN=$P(^(ORI),U),ORA=+$P(ORIFN,";",2) I ORIFN,$D(^OR(100,+ORIFN,0)) S $P(^(8,ORA,3),U)=0,$P(^(3),U,6,8)=ORUNF ; unflag + . S ORN=+$O(^ORD(100.9,"B","FLAGGED ORDERS",0)) + . S XQAKILL=$$XQAKILL^ORB3F1(ORN) D:$D(XQAID) DELETE^XQALERT + D EXIT^ORCHART + Q + ; +ACTIONS ;;KEY;NAME + ;;RN;RENEW + ;;$;SIGN + ;;DC;DISCONTINUE + ;;ED;CHANGE + ;;UF;UNFLAG + ;;HD;HOLD + ;;RL;UNHOLD + ;;VF;VERIFY + ;;;SIGN ALL + ;;;VERIFY ALL + ; +ALL ; -- Select ALL orders + N X,Y,DIR,MAX + S MAX=+$P($G(^TMP("OR",$J,"CURRENT",0)),U,2),X="1-"_MAX,Y="" + S DIR(0)="L^1:"_MAX,DIR("V")="" D:MAX ^DIR + S ORNMBR=Y + Q + ; +FINDLOC() ; -- Loop through orders in alert to find assigned location + N ORI,ORIFN,ORY S ORI=0,ORY="" + F S ORI=$O(^TMP("OR",$J,"CURRENT","IDX",ORI)) Q:ORI'>0 S ORIFN=+^(ORI),ORX=$P($G(^OR(100,ORIFN,0)),U,10) S:ORY="" ORY=ORX I ORY'="",ORX'=ORY S ORY="" Q ; ORY=location for all orders, or "" if different + Q ORY + ; +DELETE ; -- Delete current alert + N %,%Y,X,Y,PRMT,XQAKILL S VALMBCK="",XQAKILL=1 + S PRMT="Your "_$S(ORFLG=5:"Expiring",ORFLG=11:"Unsigned",ORFLG=12:"Flagged",ORFLG=9:"Unverified",1:"New")_" Orders alert for "_$G(ORPNM)_" will be deleted!" +D1 W !!,PRMT,!,"Are you sure" S %=2 D YN^DICN + I (%<0)!(%=2) W !,"Nothing deleted." H 2 Q + I %=0 D G D1 + . W !!,"This action will delete the alert you are currently processing; the alert will",!,"disappear automatically when all orders have been acted on, but this action may",!,"be used to remove the alert if some orders are to be left unchanged." + . W !,"Press to continue ..." R X:DTIME + W !,"Removing alert ..." D:$D(XQAID) DEL^ORB3FUP1(.Y,XQAID) + I $G(Y)="TRUE" W " done." S VALMBCK="Q",DEL=1 H 2 + E W " unable to delete alert." H 2 + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCD.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCD.m index 7d1ea3ef..4c2a006d 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCD.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCD.m @@ -1,191 +1,189 @@ -ORCD ; SLC/MKB - Order Dialog utilities ;12/15/2006 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**8,38,68,94,161,141,195,215,243**;Dec 17,1997;Build 242 - ;Per VHA Directive 2004-038, this routine should not be modified. -INPT() ; -- Return 1 or 0, if patient/order sheet = inpatient - N Y S Y=$S($G(ORWARD):1,$G(^DPT(+ORVP,.105)):1,1:0) - I $G(OREVENT) D ;override if delayed order - . N X,X0 S X=$$EVT^OREVNTX(+OREVENT),X0=$G(^ORD(100.5,+X,0)) - . I $P(X0,U,12) S X0=$G(^ORD(100.5,$P(X0,U,12),0)) ;use parent - . S X=$P(X0,U,2) Q:X="M" Q:X="O" ;M/O keep current inpt status - . S Y=$S(X="A":1,X="T":1,1:0) - . I X="D",$P(X0,U,7)=41 S Y=1 ;From ASIH = Inpt - . I X="T",$P(X0,U,7),$P(X0,U,7)<4 S Y=0 ;pass = Outpt - Q Y - ; -EXT(P,I,F) ; -- Returns external value of ORDIALOG(Prompt,Instance) - N TYPE,PARAM,FNUM,IENS,X,Y,J,Z - S TYPE=$E($G(ORDIALOG(P,0))),PARAM=$P($G(ORDIALOG(P,0)),U,2) - S X=$G(ORDIALOG(P,I)) I X="" Q "" - I TYPE="N",X<1 S X=0_+X I X="00" S X=0 - I "FNW"[TYPE Q X - I TYPE="Y" Q $S(X:"YES",X=0:"NO",1:"") - I TYPE="D" S:'$L($G(F)) F=1 Q $$FMTE^XLFDT(X,F) - I TYPE="R" Q $$FTDATE(X,$G(F)) ; DAY@TIME - I TYPE="P" D Q Y - . S PARAM=$P(PARAM,":"),FNUM=$S(PARAM:+PARAM,1:+$P(@(U_PARAM_"0)"),U,2)) - . S IENS=+X_",",J=$L(PARAM,",") I J>2 F S J=J-2 Q:J'>0 S Z=$P(PARAM,",",J),IENS=IENS_$S(Z:Z,1:+$P(Z,"(",2))_"," - . S:'+$G(F) F=.01 S Y=$$GET1^DIQ(FNUM,IENS,+F) - . I Y="",F'=.01 S Y=$$GET1^DIQ(FNUM,IENS,.01) - I TYPE="S" F J=1:1:$L(PARAM,";") S Z=$P(PARAM,";",J) I $P(Z,":")=X S Y=$S(+$G(F):X,1:$P(Z,":",2)) Q - Q $G(Y) - ; -FTDATE(X,F) ; -- Returns free text form of date (i.e. TODAY) - N D,T,P,Y I X="" Q "" - S X=$$UP^XLFSTR(X),D=$P(X,"@"),T=$P(X,"@",2) ; D=date,T=time parts - I "NOW"[X Q "NOW" - I "NOON"[X Q "NOON" - I $E("MIDNIGHT",1,$L(X))=X Q "MIDNIGHT" - I (X="AM")!(X="NEXT") Q X_" Lab collection" - I (X="NEXTA")!(X="CLOSEST") Q $S(X="NEXTA":"NEXT",1:X)_" administration time" - I $E(D)'="T",$E(D)'="V",($E(D)'="N"!($E(D,1,3)="NOV")) D Q $$FMTE^XLFDT(X,F) - . N %DT S %DT="TX" D ^%DT S:Y>0 X=Y S:'$G(F) F=1 - S P=$S(D["+":"+",D["-":"-",1:"") - I P="" S Y=$S($E(D)="T":"TODAY",$E(D)="V":"NEXT VISIT",1:"NOW") -FTD1 E D - . N OFFSET,NUM,UNIT - . S OFFSET=$P(D,P,2),NUM=+OFFSET,UNIT=$E($P(OFFSET,NUM,2)) ; +/-#D - . I $E(D)="T",NUM=1,UNIT=""!(UNIT="D") S Y=$S(P="+":"TOMORROW",1:"YESTERDAY") Q - . S Y=NUM_" "_$S(UNIT="'":"MINUTE",UNIT="H":"HOUR",UNIT="W":"WEEK",UNIT="M":"MONTH",1:"DAY") - . S:NUM>1 Y=Y_"S" ; plural - . S:$E(D)="N" Y=Y_" "_$S(P="+":"FROM NOW",1:"AGO") - . S:$E(D)="T" Y=Y_" "_$S(P="+":"FROM TODAY",1:"AGO") - . S:$E(D)="V" Y=Y_" "_$S(P="+":"AFTER",1:"BEFORE")_" NEXT VISIT" - I $L(T) S Y=Y_"@"_$$TIME(T) - Q Y - ; -FTDHELP ; -- Displays ??-help for R-type prompts - G R^ORCDLGH - Q - ; -FTDCOMP(X1,X2,OPER) ; -- Compares free text dates from prompts X1 & X2 - ; Returns 1 or 0, IF $$VAL(X1)$$VAL(X2) is true - N X,Y,Y1,Y2,Z,%DT - S X=$$VAL(X1),%DT="TX" D ^%DT S Y1=Y ; Y'>0 ?? - S X=$$VAL(X2),%DT="TX" D ^%DT S Y2=Y ; Y'>0 ?? - S Z="I "_Y1_OPER_Y2 X Z - Q $T - ; -TIME(X) ; -- Returns 00:00 PM formatted time - N Y,Z,%DT - I X?1U,"BNE"[X Q $S(X="B":"BREAKFAST",X="N":"NOON",X="E":"EVENING",1:"") - I "NOON"[X Q X - I "MIDNIGHT"[X Q "MIDNIGHT" - S X="T@"_X,%DT="TX" D ^%DT I Y'>0 Q "" - S Z=$$FMTE^XLFDT(Y,"2P"),Z=$P(Z," ",2)_$$UP^XLFSTR($P(Z," ",3)) - Q Z - ; -VAL(TEXT,INST) ; -- Returns internal form of TEXT's current value - N I,X S X="" S:'$G(INST) INST=1 - I '$D(ORDIALOG("B",TEXT)) S I=$O(ORDIALOG("B",TEXT)) Q:$E(I,1,$L(TEXT))'=TEXT X S TEXT=I ; partial match - S X=$P($G(ORDIALOG("B",TEXT)),U,2) ; ptr - Q $G(ORDIALOG(X,INST)) - ; -ORDMSG(OI) ; -- Display order message for orderable OI - Q:'$O(^ORD(101.43,OI,8,0)) ; no order message - N I S I=0 W ! - F S I=$O(^ORD(101.43,OI,8,I)) Q:I'>0 W !,$G(^(I,0)) - W ! Q - ; -PTR(NAME) ; -- Returns pointer to Dialog file for prompt NAME - Q +$O(^ORD(101.41,"AB",$E(NAME,1,63),0)) - ; -NMSP(PKG) ; -- Returns package namespace from pointer - N Y S Y=$$GET1^DIQ(9.4,+PKG_",",1) - S:$E(Y,1,2)="PS" Y="PS" S:Y="GMRV" Y="OR" - Q Y - ; -GETQDLG(QIFN) ; -- define ORDIALOG(PROMPT) for quick order QIFN - S ORDIALOG=$$DEFDLG(QIFN) Q:'ORDIALOG - D GETDLG(ORDIALOG),GETORDER("^ORD(101.41,"_QIFN_",6)") - X:$D(^ORD(101.41,QIFN,3)) ^(3) ; entry action for quick order - Q - ; -DEFDLG(QDLG) ; -- Returns default dialog for QDLG - N DG,DLG,TOP S DG=+$P($G(^ORD(101.41,+QDLG,0)),U,5) - S DLG=+$P($G(^ORD(100.98,DG,0)),U,4) ; default dialog - I 'DLG S TOP=+$O(^ORD(100.98,"AD",DG,0)),DLG=+$P($G(^ORD(100.98,TOP,0)),U,4) - Q DLG - ; -GETDLG(IFN) ; -- define ORDIALOG(PROMPT) for dialog IFN - N SEQ,DA,ITEM,PTR,PROMPT,TEXT,INDEX,HELP,XHELP,SCREEN,ORD,INPUTXFM,LKP - S SEQ=0 K ^TMP("ORWORD",$J) - F S SEQ=$O(^ORD(101.41,IFN,10,"B",SEQ)) Q:SEQ'>0 S DA=0 F S DA=$O(^ORD(101.41,IFN,10,"B",SEQ,DA)) Q:'DA D - . S ITEM=$G(^ORD(101.41,IFN,10,DA,0)),INPUTXFM=$G(^(.1)),HELP=$G(^(1)),SCREEN=$G(^(4)),XHELP=$G(^(6)) - . S PTR=$P(ITEM,U,2),TEXT=$P(ITEM,U,4),INDEX=$P(ITEM,U,10) Q:'PTR - . S:'$L(TEXT) TEXT=$P(^ORD(101.41,PTR,0),U,2) K ORD - . S PROMPT=$G(^ORD(101.41,PTR,1)),ORD=DA_U_$P(PROMPT,U,3) - . S ORD(0)=$P(PROMPT,U)_$S($P(PROMPT,U)="S":"M",1:"")_U_$P(PROMPT,U,2)_$S($L(INPUTXFM):U_INPUTXFM,1:"") - . S ORD("A")=TEXT S:$L($P(ITEM,U,13)) ORD("TTL")=$P(ITEM,U,13) - . I $P(ITEM,U,7) S ORD("MAX")=$P(ITEM,U,12),ORD("MORE")=$P(ITEM,U,14) ; fields for multiples - . I $L(HELP) S LKP=$P(HELP,U,2),HELP=$P(HELP,U) S:$L(HELP) ORD("?")=HELP S:$L(LKP) ORD("LKP")=$S($L(LKP,";")>1:$TR(LKP,";","^"),1:U_LKP) - . S:$L(XHELP) ORD("??")=U_XHELP - . S:$L(INDEX) ORD("D")=INDEX - . S:$L(SCREEN) ORD("S")=SCREEN - . S ORDIALOG("B",$$UP^XLFSTR($P(TEXT,":")))=SEQ_U_PTR - . M ORDIALOG(PTR)=ORD - Q - ; -GETDLG1(IFN) ; -- basic ORDIALOG(PROMPT) for dialog IFN - N SEQ,DA,PROMPT,PTR,WINCTRL - K ^TMP("ORWORD",$J) S SEQ=0 - F S SEQ=$O(^ORD(101.41,IFN,10,"B",SEQ)) Q:SEQ'>0 S DA=0 F S DA=$O(^ORD(101.41,IFN,10,"B",SEQ,DA)) Q:'DA D - . S PTR=$P($G(^ORD(101.41,IFN,10,DA,0)),U,2) Q:'PTR - . S WINCTRL=$P($G(^ORD(101.41,IFN,10,DA,"W")),U) - . S PROMPT=$G(^ORD(101.41,PTR,1)) Q:'$L(PROMPT) - . S ORDIALOG(PTR)=DA_U_$P(PROMPT,U,3)_U_WINCTRL - . S ORDIALOG(PTR,0)=$P(PROMPT,U,1,2) - Q - ; -GETORDER(ROOT,ARRAY) ; -- retrieve order values from RESPONSES in ARRAY() - N ORI,ID,PTR,INST,TYPE,DA,X,ORTXT S:'$L($G(ARRAY)) ARRAY="ORDIALOG" - I +ROOT=ROOT S ROOT="^OR(100,"_ROOT_",4.5)" ; assume Orders file IFN - S ORI=0 F S ORI=$O(@ROOT@(ORI)) Q:ORI'>0 S ID=$G(@ROOT@(ORI,0)) D - . S DA=$P(ID,U),PTR=$P(ID,U,2),INST=$P(ID,U,3) S:'INST INST=1 - . S:'PTR PTR=$P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,2) Q:'PTR - . Q:'$D(ORDIALOG(PTR)) S TYPE=$E($G(ORDIALOG(PTR,0))) Q:'$L(TYPE) - . I TYPE'="W" S X=$G(@ROOT@(ORI,1)) S:$L(X) @ARRAY@(PTR,INST)=X Q - . D RESTXT ;resolve objects - . I ARRAY="ORDIALOG" M ^TMP("ORWORD",$J,PTR,INST)=@ORTXT S @ARRAY@(PTR,INST)="^TMP(""ORWORD"","_$J_","_PTR_","_INST_")" - . I ARRAY'="ORDIALOG" M @ARRAY@(PTR,INST)=@ORTXT S @ARRAY@(PTR,INST)=$NA(@ARRAY@(PTR,INST)) - . K @ORTXT - Q - ; -RESTXT ; -- resolve objects in text [from GETORDER+8] - I $$BROKER^XWBLIB!($G(ORTYPE)="Z") M ^TMP("ORX",$J)=@ROOT@(ORI,2) S ORTXT=$NA(^TMP("ORX",$J)) Q ;return text unresolved - N ARRAY,PTR,INST - D BLRPLT^TIUSRVD(.ORTXT,,+$G(ORVP),,$NA(@ROOT@(ORI,2))) - Q - ; -DUP(PROMPT,CURRENT) ; -- Compare CURRENT instance of PROMPT for duplicates - N X,Y,I - S X=ORDIALOG(PROMPT,CURRENT),Y=0 - S I=0 F S I=$O(ORDIALOG(PROMPT,I)) Q:I'>0 I I'=CURRENT,$P(ORDIALOG(PROMPT,I),U)=$P(ORDIALOG(PROMPT,CURRENT),U) S Y=1 Q - Q Y - ; -LIST ; -- Show contents of ORDIALOG(PROMPT,"LIST") - N NUM S NUM=$G(ORDIALOG(PROMPT,"LIST")) Q:'NUM - W !,"Choose from"_$S('$P(NUM,U,2):" (or enter another):",1:":") -LIST1 N I,DONE,CNT S (I,CNT,DONE)=0 - F S I=$O(ORDIALOG(PROMPT,"LIST",I)) Q:I'>0 D Q:DONE - . S CNT=CNT+1 I CNT>(IOSL-2) S CNT=0 I '$$MORE S DONE=1 Q - . W !,$J(I,6)_" "_$P(ORDIALOG(PROMPT,"LIST",I),U,2) - Q - ; -SETLIST ; -- Show allowable set of codes - W !,"Choose from:" -SETLST1 N I,X F I=1:1:$L(DOMAIN,";") S X=$P(DOMAIN,";",I) I $L(X) D - . W !,?5,$P(X,":"),?15,$P(X,":",2) - Q - ; -MORE() ; -- show more? - N X,Y,DIR - S DIR(0)="EA",DIR("A")=" press to continue or ^ to exit ..." - D ^DIR - Q +Y - ; -FIRST(P,I) ; -- Returns 1 or 0, if current instance I is first of multiple - Q '$O(ORDIALOG(P,I),-1) - ; -RECALL(P,I) ; -- Returns first value for prompt P, instance I - N Y S:'$G(I) I=1 S Y=$G(^TMP("ORECALL",$J,+ORDIALOG,P,I)) - Q Y +ORCD ; SLC/MKB - Order Dialog utilities ;9/21/2005 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**8,38,68,94,161,141,195,215**;Dec 17,1997 +INPT() ; -- Return 1 or 0, if patient/order sheet = inpatient + N Y S Y=$S($G(ORWARD):1,$G(^DPT(+ORVP,.105)):1,1:0) + I $G(OREVENT) D ;override if delayed order + . N X,X0 S X=$$EVT^OREVNTX(+OREVENT),X0=$G(^ORD(100.5,+X,0)) + . I $P(X0,U,12) S X0=$G(^ORD(100.5,$P(X0,U,12),0)) ;use parent + . S X=$P(X0,U,2) Q:X="M" Q:X="O" ;M/O keep current inpt status + . S Y=$S(X="A":1,X="T":1,1:0) + . I X="D",$P(X0,U,7)=41 S Y=1 ;From ASIH = Inpt + . I X="T",$P(X0,U,7),$P(X0,U,7)<4 S Y=0 ;pass = Outpt + Q Y + ; +EXT(P,I,F) ; -- Returns external value of ORDIALOG(Prompt,Instance) + N TYPE,PARAM,FNUM,IENS,X,Y,J,Z + S TYPE=$E($G(ORDIALOG(P,0))),PARAM=$P($G(ORDIALOG(P,0)),U,2) + S X=$G(ORDIALOG(P,I)) I X="" Q "" + I "FNW"[TYPE Q X + I TYPE="Y" Q $S(X:"YES",X=0:"NO",1:"") + I TYPE="D" S:'$L($G(F)) F=1 Q $$FMTE^XLFDT(X,F) + I TYPE="R" Q $$FTDATE(X,$G(F)) ; DAY@TIME + I TYPE="P" D Q Y + . S PARAM=$P(PARAM,":"),FNUM=$S(PARAM:+PARAM,1:+$P(@(U_PARAM_"0)"),U,2)) + . S IENS=+X_",",J=$L(PARAM,",") I J>2 F S J=J-2 Q:J'>0 S Z=$P(PARAM,",",J),IENS=IENS_$S(Z:Z,1:+$P(Z,"(",2))_"," + . S:'+$G(F) F=.01 S Y=$$GET1^DIQ(FNUM,IENS,+F) + . I Y="",F'=.01 S Y=$$GET1^DIQ(FNUM,IENS,.01) + I TYPE="S" F J=1:1:$L(PARAM,";") S Z=$P(PARAM,";",J) I $P(Z,":")=X S Y=$S(+$G(F):X,1:$P(Z,":",2)) Q + Q $G(Y) + ; +FTDATE(X,F) ; -- Returns free text form of date (i.e. TODAY) + N D,T,P,Y I X="" Q "" + S X=$$UP^XLFSTR(X),D=$P(X,"@"),T=$P(X,"@",2) ; D=date,T=time parts + I "NOW"[X Q "NOW" + I "NOON"[X Q "NOON" + I $E("MIDNIGHT",1,$L(X))=X Q "MIDNIGHT" + I (X="AM")!(X="NEXT") Q X_" Lab collection" + I (X="NEXTA")!(X="CLOSEST") Q $S(X="NEXTA":"NEXT",1:X)_" administration time" + I $E(D)'="T",$E(D)'="V",($E(D)'="N"!($E(D,1,3)="NOV")) D Q $$FMTE^XLFDT(X,F) + . N %DT S %DT="TX" D ^%DT S:Y>0 X=Y S:'$G(F) F=1 + S P=$S(D["+":"+",D["-":"-",1:"") + I P="" S Y=$S($E(D)="T":"TODAY",$E(D)="V":"NEXT VISIT",1:"NOW") +FTD1 E D + . N OFFSET,NUM,UNIT + . S OFFSET=$P(D,P,2),NUM=+OFFSET,UNIT=$E($P(OFFSET,NUM,2)) ; +/-#D + . I $E(D)="T",NUM=1,UNIT=""!(UNIT="D") S Y=$S(P="+":"TOMORROW",1:"YESTERDAY") Q + . S Y=NUM_" "_$S(UNIT="'":"MINUTE",UNIT="H":"HOUR",UNIT="W":"WEEK",UNIT="M":"MONTH",1:"DAY") + . S:NUM>1 Y=Y_"S" ; plural + . S:$E(D)="N" Y=Y_" "_$S(P="+":"FROM NOW",1:"AGO") + . S:$E(D)="T" Y=Y_" "_$S(P="+":"FROM TODAY",1:"AGO") + . S:$E(D)="V" Y=Y_" "_$S(P="+":"AFTER",1:"BEFORE")_" NEXT VISIT" + I $L(T) S Y=Y_"@"_$$TIME(T) + Q Y + ; +FTDHELP ; -- Displays ??-help for R-type prompts + G R^ORCDLGH + Q + ; +FTDCOMP(X1,X2,OPER) ; -- Compares free text dates from prompts X1 & X2 + ; Returns 1 or 0, IF $$VAL(X1)$$VAL(X2) is true + N X,Y,Y1,Y2,Z,%DT + S X=$$VAL(X1),%DT="TX" D ^%DT S Y1=Y ; Y'>0 ?? + S X=$$VAL(X2),%DT="TX" D ^%DT S Y2=Y ; Y'>0 ?? + S Z="I "_Y1_OPER_Y2 X Z + Q $T + ; +TIME(X) ; -- Returns 00:00 PM formatted time + N Y,Z,%DT + I "NOON"[X Q X + I "MIDNIGHT"[X Q "MIDNIGHT" + I X?1U,"BNE"[X Q $S(X="B":"BREAKFAST",X="N":"NOON",X="E":"EVENING",1:"") + S X="T@"_X,%DT="TX" D ^%DT I Y'>0 Q "" + S Z=$$FMTE^XLFDT(Y,"2P"),Z=$P(Z," ",2)_$$UP^XLFSTR($P(Z," ",3)) + Q Z + ; +VAL(TEXT,INST) ; -- Returns internal form of TEXT's current value + N I,X S X="" S:'$G(INST) INST=1 + I '$D(ORDIALOG("B",TEXT)) S I=$O(ORDIALOG("B",TEXT)) Q:$E(I,1,$L(TEXT))'=TEXT X S TEXT=I ; partial match + S X=$P($G(ORDIALOG("B",TEXT)),U,2) ; ptr + Q $G(ORDIALOG(X,INST)) + ; +ORDMSG(OI) ; -- Display order message for orderable OI + Q:'$O(^ORD(101.43,OI,8,0)) ; no order message + N I S I=0 W ! + F S I=$O(^ORD(101.43,OI,8,I)) Q:I'>0 W !,$G(^(I,0)) + W ! Q + ; +PTR(NAME) ; -- Returns pointer to Dialog file for prompt NAME + Q +$O(^ORD(101.41,"AB",$E(NAME,1,63),0)) + ; +NMSP(PKG) ; -- Returns package namespace from pointer + N Y S Y=$$GET1^DIQ(9.4,+PKG_",",1) + S:$E(Y,1,2)="PS" Y="PS" S:Y="GMRV" Y="OR" + Q Y + ; +GETQDLG(QIFN) ; -- define ORDIALOG(PROMPT) for quick order QIFN + S ORDIALOG=$$DEFDLG(QIFN) Q:'ORDIALOG + D GETDLG(ORDIALOG),GETORDER("^ORD(101.41,"_QIFN_",6)") + X:$D(^ORD(101.41,QIFN,3)) ^(3) ; entry action for quick order + Q + ; +DEFDLG(QDLG) ; -- Returns default dialog for QDLG + N DG,DLG,TOP S DG=+$P($G(^ORD(101.41,+QDLG,0)),U,5) + S DLG=+$P($G(^ORD(100.98,DG,0)),U,4) ; default dialog + I 'DLG S TOP=+$O(^ORD(100.98,"AD",DG,0)),DLG=+$P($G(^ORD(100.98,TOP,0)),U,4) + Q DLG + ; +GETDLG(IFN) ; -- define ORDIALOG(PROMPT) for dialog IFN + N SEQ,DA,ITEM,PTR,PROMPT,TEXT,INDEX,HELP,XHELP,SCREEN,ORD,INPUTXFM,LKP + S SEQ=0 K ^TMP("ORWORD",$J) + F S SEQ=$O(^ORD(101.41,IFN,10,"B",SEQ)) Q:SEQ'>0 S DA=0 F S DA=$O(^ORD(101.41,IFN,10,"B",SEQ,DA)) Q:'DA D + . S ITEM=$G(^ORD(101.41,IFN,10,DA,0)),INPUTXFM=$G(^(.1)),HELP=$G(^(1)),SCREEN=$G(^(4)),XHELP=$G(^(6)) + . S PTR=$P(ITEM,U,2),TEXT=$P(ITEM,U,4),INDEX=$P(ITEM,U,10) Q:'PTR + . S:'$L(TEXT) TEXT=$P(^ORD(101.41,PTR,0),U,2) K ORD + . S PROMPT=$G(^ORD(101.41,PTR,1)),ORD=DA_U_$P(PROMPT,U,3) + . S ORD(0)=$P(PROMPT,U)_$S($P(PROMPT,U)="S":"M",1:"")_U_$P(PROMPT,U,2)_$S($L(INPUTXFM):U_INPUTXFM,1:"") + . S ORD("A")=TEXT S:$L($P(ITEM,U,13)) ORD("TTL")=$P(ITEM,U,13) + . I $P(ITEM,U,7) S ORD("MAX")=$P(ITEM,U,12),ORD("MORE")=$P(ITEM,U,14) ; fields for multiples + . I $L(HELP) S LKP=$P(HELP,U,2),HELP=$P(HELP,U) S:$L(HELP) ORD("?")=HELP S:$L(LKP) ORD("LKP")=$S($L(LKP,";")>1:$TR(LKP,";","^"),1:U_LKP) + . S:$L(XHELP) ORD("??")=U_XHELP + . S:$L(INDEX) ORD("D")=INDEX + . S:$L(SCREEN) ORD("S")=SCREEN + . S ORDIALOG("B",$$UP^XLFSTR($P(TEXT,":")))=SEQ_U_PTR + . M ORDIALOG(PTR)=ORD + Q + ; +GETDLG1(IFN) ; -- basic ORDIALOG(PROMPT) for dialog IFN + N SEQ,DA,PROMPT,PTR,WINCTRL + K ^TMP("ORWORD",$J) S SEQ=0 + F S SEQ=$O(^ORD(101.41,IFN,10,"B",SEQ)) Q:SEQ'>0 S DA=0 F S DA=$O(^ORD(101.41,IFN,10,"B",SEQ,DA)) Q:'DA D + . S PTR=$P($G(^ORD(101.41,IFN,10,DA,0)),U,2) Q:'PTR + . S WINCTRL=$P($G(^ORD(101.41,IFN,10,DA,"W")),U) + . S PROMPT=$G(^ORD(101.41,PTR,1)) Q:'$L(PROMPT) + . S ORDIALOG(PTR)=DA_U_$P(PROMPT,U,3)_U_WINCTRL + . S ORDIALOG(PTR,0)=$P(PROMPT,U,1,2) + Q + ; +GETORDER(ROOT,ARRAY) ; -- retrieve order values from RESPONSES in ARRAY() + N ORI,ID,PTR,INST,TYPE,DA,X,ORTXT S:'$L($G(ARRAY)) ARRAY="ORDIALOG" + I +ROOT=ROOT S ROOT="^OR(100,"_ROOT_",4.5)" ; assume Orders file IFN + S ORI=0 F S ORI=$O(@ROOT@(ORI)) Q:ORI'>0 S ID=$G(@ROOT@(ORI,0)) D + . S DA=$P(ID,U),PTR=$P(ID,U,2),INST=$P(ID,U,3) S:'INST INST=1 + . S:'PTR PTR=$P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,2) Q:'PTR + . Q:'$D(ORDIALOG(PTR)) S TYPE=$E($G(ORDIALOG(PTR,0))) Q:'$L(TYPE) + . I TYPE'="W" S X=$G(@ROOT@(ORI,1)) S:$L(X) @ARRAY@(PTR,INST)=X Q + . D RESTXT ;resolve objects + . I ARRAY="ORDIALOG" M ^TMP("ORWORD",$J,PTR,INST)=@ORTXT S @ARRAY@(PTR,INST)="^TMP(""ORWORD"","_$J_","_PTR_","_INST_")" + . I ARRAY'="ORDIALOG" M @ARRAY@(PTR,INST)=@ORTXT S @ARRAY@(PTR,INST)=$NA(@ARRAY@(PTR,INST)) + . K @ORTXT + Q + ; +RESTXT ; -- resolve objects in text [from GETORDER+8] + I $$BROKER^XWBLIB!($G(ORTYPE)="Z") M ^TMP("ORX",$J)=@ROOT@(ORI,2) S ORTXT=$NA(^TMP("ORX",$J)) Q ;return text unresolved + N ARRAY,PTR,INST + D BLRPLT^TIUSRVD(.ORTXT,,+$G(ORVP),,$NA(@ROOT@(ORI,2))) + Q + ; +DUP(PROMPT,CURRENT) ; -- Compare CURRENT instance of PROMPT for duplicates + N X,Y,I + S X=ORDIALOG(PROMPT,CURRENT),Y=0 + S I=0 F S I=$O(ORDIALOG(PROMPT,I)) Q:I'>0 I I'=CURRENT,$P(ORDIALOG(PROMPT,I),U)=$P(ORDIALOG(PROMPT,CURRENT),U) S Y=1 Q + Q Y + ; +LIST ; -- Show contents of ORDIALOG(PROMPT,"LIST") + N NUM S NUM=$G(ORDIALOG(PROMPT,"LIST")) Q:'NUM + W !,"Choose from"_$S('$P(NUM,U,2):" (or enter another):",1:":") +LIST1 N I,DONE,CNT S (I,CNT,DONE)=0 + F S I=$O(ORDIALOG(PROMPT,"LIST",I)) Q:I'>0 D Q:DONE + . S CNT=CNT+1 I CNT>(IOSL-2) S CNT=0 I '$$MORE S DONE=1 Q + . W !,$J(I,6)_" "_$P(ORDIALOG(PROMPT,"LIST",I),U,2) + Q + ; +SETLIST ; -- Show allowable set of codes + W !,"Choose from:" +SETLST1 N I,X F I=1:1:$L(DOMAIN,";") S X=$P(DOMAIN,";",I) I $L(X) D + . W !,?5,$P(X,":"),?15,$P(X,":",2) + Q + ; +MORE() ; -- show more? + N X,Y,DIR + S DIR(0)="EA",DIR("A")=" press to continue or ^ to exit ..." + D ^DIR + Q +Y + ; +FIRST(P,I) ; -- Returns 1 or 0, if current instance I is first of multiple + Q '$O(ORDIALOG(P,I),-1) + ; +RECALL(P,I) ; -- Returns first value for prompt P, instance I + N Y S:'$G(I) I=1 S Y=$G(^TMP("ORECALL",$J,+ORDIALOG,P,I)) + Q Y diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDFH1.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDFH1.m index faad8022..995ee698 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDFH1.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDFH1.m @@ -1,95 +1,91 @@ -ORCDFH1 ;SLC/MKB,DKM - Utility functions for FH dialogs cont ;8/24/01 10:22 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**73,95,243**;Dec 17, 1997;Build 242 - ; -RECENT ; -- get 5 most recent diet orders - N ORDT,ORIFN,ORIT,ORTXT,ORCURR,I,X,CNT,INDT S ORDT=$$NOW^XLFDT,CNT=0 - F S ORDT=$O(^OR(100,"AW",ORVP,ORDG,ORDT),-1) Q:ORDT'>0 S ORIFN=0 D Q:CNT'<5 - . F S ORIFN=$O(^OR(100,"AW",ORVP,ORDG,ORDT,ORIFN)) Q:ORIFN'>0 D Q:CNT'<5 - .. S (ORIT,ORTXT)="" K ORCURR - .. S:$P($G(^OR(100,+ORIFN,3)),U,3)=6 ORCURR=1 Q:'$O(^(.1,0)) - .. S I=0 F S I=$O(^OR(100,ORIFN,.1,I)) Q:I'>0 S X=+$G(^(I,0)) I X D ;**95 - ... S INDT=$G(^ORD(101.43,X,.1)) S ORIT=ORIT_$S($L(ORIT):";",1:"")_X,ORTXT=ORTXT_$S($L(ORTXT):", ",1:"")_$P($G(^ORD(101.43,X,0)),U)_$S(INDT&(INDT<$$NOW^XLFDT):" (*INACTIVE*)",1:"") ;**95 - .. Q:'ORIT Q:'$L(ORTXT) Q:ORTXT="NPO" - .. S ORDIALOG(PROMPT,"LIST","D",ORIT)=ORIFN ;link oi string to order# - .. Q:$G(ORCURR) Q:+$G(ORDIALOG(PROMPT,"LIST","B",ORTXT)) - .. S CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=ORIT_U_ORTXT - .. S ORDIALOG(PROMPT,"LIST","B",ORTXT)=ORIT - S ORDIALOG(PROMPT,"LIST")=CNT,ORDIALOG(PROMPT,"TOT")=0 - Q - ; -PTR(X) ; -- Return ptr to Order Dialog file #101.41 for prompt X - Q +$O(^ORD(101.41,"B","OR GTX "_X,0)) - ; -EXP ; -- Expand old order into instances - N X,I,P,D S X=$G(ORDIALOG(PROMPT,ORI)) Q:'$L(X) Q:X'[";" - S ORDIALOG(PROMPT,ORI)=+X,I=ORI ;1st mod only - F P=2:1:$L(X,";") S D=$P(X,";",P),I=I+1,ORDIALOG(PROMPT,I)=D,ORDIALOG(PROMPT,"TOT")=+$G(ORDIALOG(PROMPT,"TOT"))+1 - ;S:FIRST MAX=$L(X,";") - Q - ; -VALID() ; -- Returns 1 or 0, if selected diet modification is valid - N Y,NUM,I,TOTAL,OI - S OI=$G(ORDIALOG(PROMPT,ORI)) I OI[";" D Q Y - .S Y=1 D EXP - .I $$INACTIVE S Y=0 S ORDIALOG(PROMPT,"TOT")=ORDIALOG(PROMPT,"TOT")-($L(OI,";")-1) F I=0:1:($L(OI,";")-1) K ORDIALOG(PROMPT,(I+ORI)) ;**95 - S Y=1,TOTAL=+$G(ORDIALOG(PROMPT,"TOT")),ORDIALOG(PROMPT,"MAX")=5,MAX=5 - I $$INACTIVE Q 0 ;**95 - ;S:FIRST MAX=$S($G(ORDIALOG(PROMPT,"LIST","D",OI)):1,1:5) - S OI=$P($G(^ORD(101.43,+OI,0)),U) - I (OI="REGULAR")!(OI="NPO") D Q Y - . I '$D(ORESET),TOTAL=0 S ORDIALOG(PROMPT,"MAX")=1,MAX=1 Q ; add first - . I $G(ORESET),TOTAL'>1 S ORDIALOG(PROMPT,"MAX")=1,MAX=1 Q ; edit first - . S Y=0 W $C(7),!,OI_" may not be ordered with other diets!" - ;I $$DUP^ORCD(PROMPT,ORI) W $C(7),"This diet has already been selected!" Q 0 ;may delete after testing patch 95 - S NUM=$P($G(^ORD(101.43,+ORDIALOG(PROMPT,ORI),"FH")),U,2) ; precedence # - S I=0 F S I=$O(ORDIALOG(PROMPT,I)) Q:I'>0 D Q:Y'>0 - . Q:I=ORI Q:$P($G(^ORD(101.43,+ORDIALOG(PROMPT,I),"FH")),U,2)'=NUM ;ok - . S Y=0 W $C(7),!,"This diet is not orderable with those already selected!",! - Q Y - ; -PREV ; -- Ck if previous diet being reordered - N I,OI,IFN S OI="",I=0 - F S I=$O(ORDIALOG(PROMPT,I)) Q:I'>0 S OI=OI_$S(OI:";",1:"")_ORDIALOG(PROMPT,I) - S IFN=$S(OI:$G(ORDIALOG(PROMPT,"LIST","D",OI)),1:"") - S:IFN ORDIALOG("PREV")=IFN K:'IFN ORDIALOG("PREV") - Q - ; -CNV ; -- Convert meal abbreviation to time in X [Input Xform] - ; Expects X,PROMPT [also called from Entry Action, DO^ORWDXM2] - N A1 S X=$$UP^XLFSTR(X),A1=$P(X,"@",2) - I A1?1U,"BNE"[A1 D - . I $G(ORTYPE)="Z" S DATATYPE="",Y=X Q ;editor - ok - . N TIMES S TIMES=$S($D(ORPARAM(2)):$P(ORPARAM(2),U,7,9),1:"6:00A^12:00P^6:00P") - . S A1=$S(A1="B":$P(TIMES,U),A1="N":$P(TIMES,U,2),A1="E":$P(TIMES,U,3),1:A1) - . S $P(X,"@",2)=A1 - Q - ; -LKUP ; -- special lookup routine for diet modifications - G:'$G(ORDIALOG(PROMPT,"LIST")) LKQ N OROOT,Z - S:X=" " X=$$SPACE^ORCDLG2(DOMAIN) S OROOT=$NA(ORDIALOG(PROMPT,"LIST")) - S Y=$$FIND^ORCDLG2(OROOT,X) - I Y Q:X?1N Q:'$$MORE(X,Y) S Z=$$OK Q:Z I Z="^" S Y="^" Q -LKQ D DIC^ORCDLG2 - Q - ; -MORE(XX,YY) ; -- Returns 1 or 0, if more matches exist - Q:$P(YY,U)[";" 1 ;multiple mods - N CNT,XP,NOW S CNT=0,XP=XX,NOW=+$$NOW^XLFDT - F S XP=$O(^ORD(101.43,"S.DO",XP)) Q:$E(XP,1,$L(XX))'=XX D Q:CNT - . N IFN S IFN=$O(^ORD(101.43,"S.DO",XP,0)) Q:IFN=+YY ;same mod - . I $G(^ORD(101.43,IFN,.1)),$G(^(.1))'>NOW Q ;inactive - . S CNT=CNT+1 - Q CNT - ; -OK() ; -- Verify multiple diet mod selection - N X,Y,DIR S DIR(0)="YA",DIR("A")=" ... OK? ",DIR("B")="Yes" - S DIR("?")="Enter YES if you wish to re-order this entire diet, or NO to search for another single diet modification" - D ^DIR S:$D(DUOUT)!$D(DTOUT) Y="^" - Q Y -INACTIVE() ;Check for inactive/duplicate diets in single or multiple modifications ;**95 - N I,Y - S Y=0 - S I=0 F S I=$O(ORDIALOG(PROMPT,I)) Q:'+I D - .I $G(^ORD(101.43,ORDIALOG(PROMPT,I),.1)),^(.1)<$$NOW^XLFDT S Y=1 W !,"The ",$P(^ORD(101.43,ORDIALOG(PROMPT,I),0),U)," diet is INACTIVE." Q ;Quit if inactive diet found in order - F I=0:1:($L(OI,";")-1) I $$DUP^ORCD(PROMPT,(I+ORI)) S Y=1 W !,"The ",$P(^ORD(101.43,ORDIALOG(PROMPT,(I+ORI)),0),U)," diet has already been selected." ;check for duplicate orders - Q Y +ORCDFH1 ;SLC/MKB,DKM - Utility functions for FH dialogs cont ;8/24/01 10:22 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**73,95**;Dec 17, 1997 + ; +RECENT ; -- get 5 most recent diet orders + N ORDT,ORIFN,ORIT,ORTXT,ORCURR,I,X,CNT,INDT S ORDT=$$NOW^XLFDT,CNT=0 + F S ORDT=$O(^OR(100,"AW",ORVP,ORDG,ORDT),-1) Q:ORDT'>0 S ORIFN=0 D Q:CNT'<5 + . F S ORIFN=$O(^OR(100,"AW",ORVP,ORDG,ORDT,ORIFN)) Q:ORIFN'>0 D Q:CNT'<5 + .. S (ORIT,ORTXT)="" K ORCURR + .. S:$P($G(^OR(100,+ORIFN,3)),U,3)=6 ORCURR=1 Q:'$O(^(.1,0)) + .. S I=0 F S I=$O(^OR(100,ORIFN,.1,I)) Q:I'>0 S X=+$G(^(I,0)) I X D ;**95 + ... S INDT=$G(^ORD(101.43,X,.1)) S ORIT=ORIT_$S($L(ORIT):";",1:"")_X,ORTXT=ORTXT_$S($L(ORTXT):", ",1:"")_$P($G(^ORD(101.43,X,0)),U)_$S(INDT&(INDT<$$NOW^XLFDT):" (*INACTIVE*)",1:"") ;**95 + .. Q:'ORIT Q:'$L(ORTXT) Q:ORTXT="NPO" + .. S ORDIALOG(PROMPT,"LIST","D",ORIT)=ORIFN ;link oi string to order# + .. Q:$G(ORCURR) Q:+$G(ORDIALOG(PROMPT,"LIST","B",ORTXT)) + .. S CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=ORIT_U_ORTXT + .. S ORDIALOG(PROMPT,"LIST","B",ORTXT)=ORIT + S ORDIALOG(PROMPT,"LIST")=CNT,ORDIALOG(PROMPT,"TOT")=0 + Q + ; +PTR(X) ; -- Return ptr to Order Dialog file #101.41 for prompt X + Q +$O(^ORD(101.41,"AB","OR GTX "_X,0)) + ; +EXP ; -- Expand old order into instances + N X,I,P,D S X=$G(ORDIALOG(PROMPT,ORI)) Q:'$L(X) Q:X'[";" + S ORDIALOG(PROMPT,ORI)=+X,I=ORI ;1st mod only + F P=2:1:$L(X,";") S D=$P(X,";",P),I=I+1,ORDIALOG(PROMPT,I)=D,ORDIALOG(PROMPT,"TOT")=+$G(ORDIALOG(PROMPT,"TOT"))+1 + ;S:FIRST MAX=$L(X,";") + Q + ; +VALID() ; -- Returns 1 or 0, if selected diet modification is valid + N Y,NUM,I,TOTAL,OI + S OI=$G(ORDIALOG(PROMPT,ORI)) I OI[";" D Q Y + .S Y=1 D EXP + .I $$INACTIVE S Y=0 S ORDIALOG(PROMPT,"TOT")=ORDIALOG(PROMPT,"TOT")-($L(OI,";")-1) F I=0:1:($L(OI,";")-1) K ORDIALOG(PROMPT,(I+ORI)) ;**95 + S Y=1,TOTAL=+$G(ORDIALOG(PROMPT,"TOT")),ORDIALOG(PROMPT,"MAX")=5,MAX=5 + I $$INACTIVE Q 0 ;**95 + ;S:FIRST MAX=$S($G(ORDIALOG(PROMPT,"LIST","D",OI)):1,1:5) + S OI=$P($G(^ORD(101.43,+OI,0)),U) + I (OI="REGULAR")!(OI="NPO") D Q Y + . I '$D(ORESET),TOTAL=0 S ORDIALOG(PROMPT,"MAX")=1,MAX=1 Q ; add first + . I $G(ORESET),TOTAL'>1 S ORDIALOG(PROMPT,"MAX")=1,MAX=1 Q ; edit first + . S Y=0 W $C(7),!,OI_" may not be ordered with other diets!" + ;I $$DUP^ORCD(PROMPT,ORI) W $C(7),"This diet has already been selected!" Q 0 ;may delete after testing patch 95 + S NUM=$P($G(^ORD(101.43,+ORDIALOG(PROMPT,ORI),"FH")),U,2) ; precedence # + S I=0 F S I=$O(ORDIALOG(PROMPT,I)) Q:I'>0 D Q:Y'>0 + . Q:I=ORI Q:$P($G(^ORD(101.43,+ORDIALOG(PROMPT,I),"FH")),U,2)'=NUM ;ok + . S Y=0 W $C(7),!,"This diet is not orderable with those already selected!",! + Q Y + ; +PREV ; -- Ck if previous diet being reordered + N I,OI,IFN S OI="",I=0 + F S I=$O(ORDIALOG(PROMPT,I)) Q:I'>0 S OI=OI_$S(OI:";",1:"")_ORDIALOG(PROMPT,I) + S IFN=$S(OI:$G(ORDIALOG(PROMPT,"LIST","D",OI)),1:"") + S:IFN ORDIALOG("PREV")=IFN K:'IFN ORDIALOG("PREV") + Q + ; +CNV ; -- Convert meal abbreviation to time [Input Xform] + N A1 S A1=$E($P(X,"@",2)) Q:'$L(A1) ;not in form T@meal + S A1=$S(A1="M":"11:59P",'$D(ORPARAM(2)):A1,A1="B":$P(ORPARAM(2),U,7),A1="N":$P(ORPARAM(2),U,8),A1="E":$P(ORPARAM(2),U,9),1:A1),$P(X,"@",2)=A1 + I $G(ORTYPE)="Z",A1?1U,"BNE"[A1 S DATATYPE="",Y=X ;editor + Q + ; +LKUP ; -- special lookup routine for diet modifications + G:'$G(ORDIALOG(PROMPT,"LIST")) LKQ N OROOT,Z + S:X=" " X=$$SPACE^ORCDLG2(DOMAIN) S OROOT=$NA(ORDIALOG(PROMPT,"LIST")) + S Y=$$FIND^ORCDLG2(OROOT,X) + I Y Q:X?1N Q:'$$MORE(X,Y) S Z=$$OK Q:Z I Z="^" S Y="^" Q +LKQ D DIC^ORCDLG2 + Q + ; +MORE(XX,YY) ; -- Returns 1 or 0, if more matches exist + Q:$P(YY,U)[";" 1 ;multiple mods + N CNT,XP,NOW S CNT=0,XP=XX,NOW=+$$NOW^XLFDT + F S XP=$O(^ORD(101.43,"S.DO",XP)) Q:$E(XP,1,$L(XX))'=XX D Q:CNT + . N IFN S IFN=$O(^ORD(101.43,"S.DO",XP,0)) Q:IFN=+YY ;same mod + . I $G(^ORD(101.43,IFN,.1)),$G(^(.1))'>NOW Q ;inactive + . S CNT=CNT+1 + Q CNT + ; +OK() ; -- Verify multiple diet mod selection + N X,Y,DIR S DIR(0)="YA",DIR("A")=" ... OK? ",DIR("B")="Yes" + S DIR("?")="Enter YES if you wish to re-order this entire diet, or NO to search for another single diet modification" + D ^DIR S:$D(DUOUT)!$D(DTOUT) Y="^" + Q Y +INACTIVE() ;Check for inactive/duplicate diets in single or multiple modifications ;**95 + N I,Y + S Y=0 + S I=0 F S I=$O(ORDIALOG(PROMPT,I)) Q:'+I D + .I $G(^ORD(101.43,ORDIALOG(PROMPT,I),.1)),^(.1)<$$NOW^XLFDT S Y=1 W !,"The ",$P(^ORD(101.43,ORDIALOG(PROMPT,I),0),U)," diet is INACTIVE." Q ;Quit if inactive diet found in order + F I=0:1:($L(OI,";")-1) I $$DUP^ORCD(PROMPT,(I+ORI)) S Y=1 W !,"The ",$P(^ORD(101.43,ORDIALOG(PROMPT,(I+ORI)),0),U)," diet has already been selected." ;check for duplicate orders + Q Y diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDLG1.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDLG1.m index ac73a0b0..cc42f9ef 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDLG1.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDLG1.m @@ -1,166 +1,164 @@ -ORCDLG1 ; SLC/MKB - Order dialogs cont ;12/15/2006 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**60,71,95,110,243**;Dec 17, 1997;Build 242 - ;Per VHA Directive 2004-038, this routine should not be modified. -EN(ITM,INST) ; -- ask each ITM prompt where - ; ORDIALOG(PROMPT,#) = internal form of each response - ; - N ITEM,COND,MULT,REQD,EDITONLY,DATATYPE,DOMAIN,DIR,Y,ACTION,PROMPT,ORX,VALIDEF - S ITEM=$G(^ORD(101.41,+ORDIALOG,10,ITM,0)),COND=$G(^(3)) - S PROMPT=$P(ITEM,U,2) Q:'PROMPT S:'$G(INST) INST=1 - S MULT=$P(ITEM,U,7),ACTION=$P(ITEM,U,9) - S REQD=$P(ITEM,U,6),EDITONLY=$P(ITEM,U,8) S:$G(ORTYPE)="Z" (REQD,EDITONLY)=0 - I $D(^ORD(101.41,+ORDIALOG,10,ITM,9)) X ^(9) G:$G(ORQUIT) ENQ ;Entry - I $G(ORTYPE)="Q",$D(ORDIALOG(PROMPT,INST)),$E(ORDIALOG(PROMPT,0))'="W" S EDITONLY=1 - I '$D(ORDIALOG(PROMPT,INST)) D ; get default value - . I $E(ORDIALOG(PROMPT,0))="W",$D(^ORD(101.41,+ORDIALOG,10,ITM,8))>9 M ^TMP("ORWORD",$J,PROMPT,INST)=^(8) S ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"","_$J_","_PROMPT_","_INST_")" Q - . K Y X:$D(^ORD(101.41,+ORDIALOG,10,ITM,7)) ^(7) - . I $D(Y) S VALIDEF=$$VALID S:VALIDEF ORDIALOG(PROMPT,INST)=Y ;**95 - . I $G(VALIDEF)=0 W !,"The DEFAULT value for the ",$G(ORDIALOG(PROMPT,"A"))," prompt is invalid." S EDITONLY=0 ;**95 - . K VALIDEF ;**95 - I $G(AUTO),'REQD!($E(ORDIALOG(PROMPT,0))="W"&$D(ORDIALOG(PROMPT,INST))) S EDITONLY=1 ;Auto-accept -EN0 I FIRST&EDITONLY D:$D(ORDIALOG(PROMPT,INST)) G ENQ ;ck child prompts - . Q:'$D(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT)) N SEQ,DA,ITEM,PRMT,X,Y,VALIDEF ;**95 - . S SEQ=0 F S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT,SEQ)) Q:SEQ'>0 S DA=$O(^(SEQ,0)) D Q:$G(ORQUIT) - . . K VALIDEF ;110 - . . S ITEM=$G(^ORD(101.41,+ORDIALOG,10,DA,0)),PRMT=$P(ITEM,U,2) - . . Q:$D(ORDIALOG(PRMT,INST)) ; already has a value - . . K Y X:$D(^ORD(101.41,+ORDIALOG,10,DA,7)) ^(7) - . . I $D(Y) S VALIDEF=$$VALID ;**95 - . . I $G(VALIDEF)!('$P(ITEM,U,6)) S:$G(VALIDEF) ORDIALOG(PRMT,INST)=Y Q ;**95 - . . D EN(DA,INST) ; ask - I ($G(OREDIT)&(ACTION'["C"))!($G(ORENEW)&(ACTION'["R")) G ENQ ;ask? - I $G(OREWRITE),ACTION'["W",FIRST,'REQD!$D(ORDIALOG(PROMPT,INST)) G ENQ - I $L(COND) X COND G:'$T ENQ ; failed condition - M DIR=ORDIALOG(PROMPT) S DATATYPE=$E(DIR(0)),DOMAIN=$P(DIR(0),U,2) - I 'MULT D WP^ORCDLG2:DATATYPE="W",ONE(INST,REQD):DATATYPE'="W" G ENQ -EN1 ; -- loop for multiples - I '$O(ORDIALOG(PROMPT,0)) D G:$G(ORQUIT)!('$O(ORDIALOG(PROMPT,0)))!FIRST ENQ -M1 . D ADDMULT Q:$G(ORQUIT) - . Q:'REQD!$O(ORDIALOG(PROMPT,0)) I FIRST,$G(SEQ)=1 S ORQUIT=1 Q - . W $C(7),!!,$$REQUIRED,! G M1 - F S ORX=$$SELECT Q:ORX="" S:ORX="^" ORQUIT=1 Q:$G(ORQUIT) D Q:$G(DIROUT) - . S DIR("A")=ORDIALOG(PROMPT,"A"),X=$S('REQD:0,$$ONLY(ORX):1,1:0) - . D ADDMULT:ORX="A",ONE(ORX,X):ORX Q:$G(DIROUT) K ORQUIT,DIR("B") - . I REQD,'$O(ORDIALOG(PROMPT,0)) W $C(7),!!,$$REQUIRED,! -ENQ X:$D(^ORD(101.41,+ORDIALOG,10,ITM,10)) ^(10) ; exit action - Q - ; -REQUIRED() ; -- Required response message - Q "A response is required! Enter '^' to quit." - ; -SELECT() ; -- select instance of multiple to edit - N DIR,X,Y,CNT,I,MAX,TOTAL,DONE - S MAX=+$G(ORDIALOG(PROMPT,"MAX")),TOTAL=+$G(ORDIALOG(PROMPT,"TOT")) - S DIR("A",1)=$S($L($G(ORDIALOG(PROMPT,"TTL"))):ORDIALOG(PROMPT,"TTL"),1:ORDIALOG(PROMPT,"A")) - S (I,CNT)=0 F S I=$O(ORDIALOG(PROMPT,I)) Q:I'>0 S CNT=CNT+1,CNT(CNT)=I,DIR("A",CNT+1)=$J(CNT,3)_": "_$$ITEM^ORCDLG(PROMPT,I) ; parent+children - I 'MAX!(MAX&(MAX>TOTAL)) S CNT=CNT+1,CNT(CNT)="A",DIR("A",CNT+1)=$J(CNT,3)_": " - S DIR("A")="Select "_$S(CNT>1:"(1-"_CNT_")",1:1)_" or to continue: " - S DIR(0)="NAO^1:"_CNT,DIR("?")="Select the instance you wish to change" -S1 D ^DIR I $D(DTOUT)!(Y="^") Q "^" - I Y?1"^".E D UJUMP Q:$G(ORQUIT)!($G(DONE)) "" G S1 - I Y="" Q Y - Q CNT(Y) - ; -ONLY(I) ; -- I the only instance? - N J,Z S J=0,Z=1 - F S J=$O(ORDIALOG(PROMPT,J)) Q:J'>0 I J'=I S Z=0 Q - Q Z - ; -ADDMULT ; -- add new instances of multiple - N DONE,LAST,INST,MAX,ANOTHER - S MAX=+$G(ORDIALOG(PROMPT,"MAX")) I MAX,MAX'>$G(ORDIALOG(PROMPT,"TOT")) W $C(7),!,"Only "_MAX_" items may be selected!",! Q - S ANOTHER=$G(ORDIALOG(PROMPT,"MORE")) S:'$L(ANOTHER) ANOTHER="Another " - S DIR("A")=$S($O(ORDIALOG(PROMPT,0)):ANOTHER,1:"")_ORDIALOG(PROMPT,"A") - F D Q:$G(ORQUIT)!($G(DONE)) I MAX Q:MAX'>$G(ORDIALOG(PROMPT,"TOT")) - . S INST=$O(ORDIALOG(PROMPT,"?"),-1)+1 - . D ONE(INST,0) I '$D(ORDIALOG(PROMPT,INST)) S DONE=1 Q - . S ORDIALOG(PROMPT,"TOT")=+$G(ORDIALOG(PROMPT,"TOT"))+1,DIR("A")=ANOTHER_ORDIALOG(PROMPT,"A") - Q - ; -ONE(ORI,REQD) ; -- ask single-valued prompt - N DONE,ORESET - S:$D(ORDIALOG(PROMPT,ORI)) DIR("B")=$$EXT^ORCD(PROMPT,ORI),ORESET=ORDIALOG(PROMPT,ORI) - F D Q:$G(DONE) I $G(ORQUIT) Q:FIRST Q:'REQD!$D(ORDIALOG(PROMPT,ORI)) S FIRST=$$DONE^ORCDLG2 Q:FIRST K ORQUIT - . D DIR^ORCDLG2 I $D(DTOUT)!$D(DIROUT)!(X=U) S ORQUIT=1 Q - . I X="" S DONE=1 Q - . I X?1"^".E D UJUMP Q - . I X="@" D DELETE Q - . I $E(DIR(0))="N",Y<1,$E(Y,1,2)'="0." S Y=0_Y - . S ORDIALOG(PROMPT,ORI)=$P(Y,U),DONE=1 - . X:$L($G(^ORD(101.41,+ORDIALOG,10,ITM,5))) ^(5) I '$G(DONE) D RESET Q ; validate - if failed, K DONE to reask - . D:$D(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT)) CHILDREN(PROMPT,ORI) I '$G(DONE),'FIRST D DELCHILD(PROMPT,ORI),RESET Q - Q - ; -CHILDREN(PARENT,INST) ; -- ask child prompts - N SEQ,DA,ORQUIT S SEQ=0 - F S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PARENT,SEQ)) Q:SEQ'>0 S DA=$O(^(SEQ,0)) D EN(DA,INST) Q:$G(ORQUIT) - K:$G(ORQUIT) DONE ; reask parent - Q - ; -RESET ; -- Reset original prompt value - K ORDIALOG(PROMPT,ORI) - S:$D(ORESET) ORDIALOG(PROMPT,ORI)=ORESET - Q - ; -UJUMP ; -- ^-jump - N XP,P,CNT,MATCH,I,DIR,NEWSEQ ; XP=$$UP(X),P=PROMPT - I $G(NOJUMP) W $C(7)," ^-jumping not allowed!" Q - S XP=$$UP^XLFSTR($P(X,U,2)) I "^"[XP S ORQUIT=1 Q - I $G(ORDIALOG("B",XP)) S NEWSEQ=+ORDIALOG("B",XP) G UJQ - S CNT=0,P=XP F S P=$O(ORDIALOG("B",P)) Q:P="" Q:$E(P,1,$L(XP))'=XP Q:FIRST&(+ORDIALOG("B",P)'0 S DA=$O(^(SEQ,0)),PTR=+$P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,2) K:PTR ORDIALOG(PTR,INST) - Q - ; -SURE() ; -- sure you want to delete? - N X,Y,DIR - S DIR(0)="YA",DIR("A")=" Are you sure you want to delete this value? " - S DIR("B")="NO" W $C(7) D ^DIR - S:$D(DTOUT) Y="^" - Q Y - ; -VALID() ;Check to see if default value is valid. Returns 0 or 1 - ;Entire section added in patch 95 - N TYPE,RANGE,MIN,MAX,DIR,X,ORDIC,DDS,RTYPE,ORIG - I Y="" Q 1 ;If default is null allow to pass ;110 - S DIR(0)=$G(ORDIALOG(PROMPT,0)),(ORIG,X)=Y,DIR("V")="" ;Set reader type, default input, silent call - S TYPE=$E($P(DIR(0),"^")) ;Get type of look-up being done - I TYPE="W" Q 1 ;If word processing assume value is valid, may be referencing a global location - I TYPE="R" S $P(DIR(0),"^")="D"_$E($P(DIR(0),"^"),2,999),TYPE="D",RTYPE=1 ;If type is R then change to date look up - I TYPE="D" I X="AM"!(X="NEXT")!(X="NEXTA")!(X="CLOSEST") Q 1 ;If date/time prompt default is AM, NEXT, NEXTA, or CLOSEST then accept without checking - S:TYPE="P"&(X=+X) X="`"_X ;If pointer type add ` to IEN for DIR call - I TYPE="P" S ORDIC=$P(DIR(0),"^",2) S $P(ORDIC,":",2)=$TR($P(ORDIC,":",2),"QE","") S $P(DIR(0),"^",2)=ORDIC ;If pointer type remove Q&E from DIC(0) so no echo and no ?? on erroneous input - I TYPE="D" S ORDIC=$P(DIR(0),"^",2) S $P(ORDIC,":",3)=$TR($P(ORDIC,":",3),"E",""),$P(ORDIC,":")=$TR($P(ORDIC,":"),"DTNOW",""),$P(DIR(0),"^",2)=ORDIC ;Remove "E" so no echo, remove DT and NOW so DIR call works correctly - I TYPE="Y" S:"^Y^YE^YES^"[("^"_$TR(X,"yes","YES")_"^")!(X=1) X="YES" S:"^N^NO^"[("^"_$TR(X,"no","NO")_"^")!(X=0) X="NO" ;If yes/no type convert input to uppercase full entry to avoid echo - I TYPE="S" S DDS=1 ;Stops DIR call from echoing rest of entry for set of codes - D ^DIR - I TYPE="D"&('$D(Y(0))) Q 0 ;Date not valid - I TYPE="L"&($G(Y)="") Q 0 ;List/Range not valid - I TYPE="N"&('$D(Y)) Q 0 ;Numeric not valid - I TYPE="P"&($G(Y)=-1) Q 0 ;Pointer not valid - I TYPE="S"&($G(Y(0))="") Q 0 ;Set of codes not valid - I TYPE="Y"&($G(Y(0))="") Q 0 ;Yes/No not valid - I TYPE="F" S RANGE=$P(DIR(0),"^",2),MIN=$S($P(RANGE,":"):$P(RANGE,":"),1:1),MAX=$S($P(RANGE,":",2):$P(RANGE,":",2),1:240) I $L(Y)MAX) Q 0 ;Free text and not within valid limit - I $G(RTYPE) S Y=ORIG ;Set y back to relative date - I TYPE="P" S Y=$P(Y,"^") ;only store IEN ;110 - Q 1 ;Must be valid +ORCDLG1 ; SLC/MKB - Order dialogs cont ;11/21/01 08:03 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**60,71,95,110**;Dec 17, 1997 +EN(ITM,INST) ; -- ask each ITM prompt where + ; ORDIALOG(PROMPT,#) = internal form of each response + ; + N ITEM,COND,MULT,REQD,EDITONLY,DATATYPE,DOMAIN,DIR,Y,ACTION,PROMPT,ORX,VALIDEF + S ITEM=$G(^ORD(101.41,+ORDIALOG,10,ITM,0)),COND=$G(^(3)) + S PROMPT=$P(ITEM,U,2) Q:'PROMPT S:'$G(INST) INST=1 + S MULT=$P(ITEM,U,7),ACTION=$P(ITEM,U,9) + S REQD=$P(ITEM,U,6),EDITONLY=$P(ITEM,U,8) S:$G(ORTYPE)="Z" (REQD,EDITONLY)=0 + I $D(^ORD(101.41,+ORDIALOG,10,ITM,9)) X ^(9) G:$G(ORQUIT) ENQ ;Entry + I $G(ORTYPE)="Q",$D(ORDIALOG(PROMPT,INST)),$E(ORDIALOG(PROMPT,0))'="W" S EDITONLY=1 + I '$D(ORDIALOG(PROMPT,INST)) D ; get default value + . I $E(ORDIALOG(PROMPT,0))="W",$D(^ORD(101.41,+ORDIALOG,10,ITM,8))>9 M ^TMP("ORWORD",$J,PROMPT,INST)=^(8) S ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"","_$J_","_PROMPT_","_INST_")" Q + . K Y X:$D(^ORD(101.41,+ORDIALOG,10,ITM,7)) ^(7) + . I $D(Y) S VALIDEF=$$VALID S:VALIDEF ORDIALOG(PROMPT,INST)=Y ;**95 + . I $G(VALIDEF)=0 W !,"The DEFAULT value for the ",$G(ORDIALOG(PROMPT,"A"))," prompt is invalid." S EDITONLY=0 ;**95 + . K VALIDEF ;**95 + I $G(AUTO),'REQD!($E(ORDIALOG(PROMPT,0))="W"&$D(ORDIALOG(PROMPT,INST))) S EDITONLY=1 ;Auto-accept +EN0 I FIRST&EDITONLY D:$D(ORDIALOG(PROMPT,INST)) G ENQ ;ck child prompts + . Q:'$D(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT)) N SEQ,DA,ITEM,PRMT,X,Y,VALIDEF ;**95 + . S SEQ=0 F S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT,SEQ)) Q:SEQ'>0 S DA=$O(^(SEQ,0)) D Q:$G(ORQUIT) + . . K VALIDEF ;110 + . . S ITEM=$G(^ORD(101.41,+ORDIALOG,10,DA,0)),PRMT=$P(ITEM,U,2) + . . Q:$D(ORDIALOG(PRMT,INST)) ; already has a value + . . K Y X:$D(^ORD(101.41,+ORDIALOG,10,DA,7)) ^(7) + . . I $D(Y) S VALIDEF=$$VALID ;**95 + . . I $G(VALIDEF)!('$P(ITEM,U,6)) S:$G(VALIDEF) ORDIALOG(PRMT,INST)=Y Q ;**95 + . . D EN(DA,INST) ; ask + I ($G(OREDIT)&(ACTION'["C"))!($G(ORENEW)&(ACTION'["R")) G ENQ ;ask? + I $G(OREWRITE),ACTION'["W",FIRST,'REQD!$D(ORDIALOG(PROMPT,INST)) G ENQ + I $L(COND) X COND G:'$T ENQ ; failed condition + M DIR=ORDIALOG(PROMPT) S DATATYPE=$E(DIR(0)),DOMAIN=$P(DIR(0),U,2) + I 'MULT D WP^ORCDLG2:DATATYPE="W",ONE(INST,REQD):DATATYPE'="W" G ENQ +EN1 ; -- loop for multiples + I '$O(ORDIALOG(PROMPT,0)) D G:$G(ORQUIT)!('$O(ORDIALOG(PROMPT,0)))!FIRST ENQ +M1 . D ADDMULT Q:$G(ORQUIT) + . Q:'REQD!$O(ORDIALOG(PROMPT,0)) I FIRST,$G(SEQ)=1 S ORQUIT=1 Q + . W $C(7),!!,$$REQUIRED,! G M1 + F S ORX=$$SELECT Q:ORX="" S:ORX="^" ORQUIT=1 Q:$G(ORQUIT) D Q:$G(DIROUT) + . S DIR("A")=ORDIALOG(PROMPT,"A"),X=$S('REQD:0,$$ONLY(ORX):1,1:0) + . D ADDMULT:ORX="A",ONE(ORX,X):ORX Q:$G(DIROUT) K ORQUIT,DIR("B") + . I REQD,'$O(ORDIALOG(PROMPT,0)) W $C(7),!!,$$REQUIRED,! +ENQ X:$D(^ORD(101.41,+ORDIALOG,10,ITM,10)) ^(10) ; exit action + Q + ; +REQUIRED() ; -- Required response message + Q "A response is required! Enter '^' to quit." + ; +SELECT() ; -- select instance of multiple to edit + N DIR,X,Y,CNT,I,MAX,TOTAL,DONE + S MAX=+$G(ORDIALOG(PROMPT,"MAX")),TOTAL=+$G(ORDIALOG(PROMPT,"TOT")) + S DIR("A",1)=$S($L($G(ORDIALOG(PROMPT,"TTL"))):ORDIALOG(PROMPT,"TTL"),1:ORDIALOG(PROMPT,"A")) + S (I,CNT)=0 F S I=$O(ORDIALOG(PROMPT,I)) Q:I'>0 S CNT=CNT+1,CNT(CNT)=I,DIR("A",CNT+1)=$J(CNT,3)_": "_$$ITEM^ORCDLG(PROMPT,I) ; parent+children + I 'MAX!(MAX&(MAX>TOTAL)) S CNT=CNT+1,CNT(CNT)="A",DIR("A",CNT+1)=$J(CNT,3)_": " + S DIR("A")="Select "_$S(CNT>1:"(1-"_CNT_")",1:1)_" or to continue: " + S DIR(0)="NAO^1:"_CNT,DIR("?")="Select the instance you wish to change" +S1 D ^DIR I $D(DTOUT)!(Y="^") Q "^" + I Y?1"^".E D UJUMP Q:$G(ORQUIT)!($G(DONE)) "" G S1 + I Y="" Q Y + Q CNT(Y) + ; +ONLY(I) ; -- I the only instance? + N J,Z S J=0,Z=1 + F S J=$O(ORDIALOG(PROMPT,J)) Q:J'>0 I J'=I S Z=0 Q + Q Z + ; +ADDMULT ; -- add new instances of multiple + N DONE,LAST,INST,MAX,ANOTHER + S MAX=+$G(ORDIALOG(PROMPT,"MAX")) I MAX,MAX'>$G(ORDIALOG(PROMPT,"TOT")) W $C(7),!,"Only "_MAX_" items may be selected!",! Q + S ANOTHER=$G(ORDIALOG(PROMPT,"MORE")) S:'$L(ANOTHER) ANOTHER="Another " + S DIR("A")=$S($O(ORDIALOG(PROMPT,0)):ANOTHER,1:"")_ORDIALOG(PROMPT,"A") + F D Q:$G(ORQUIT)!($G(DONE)) I MAX Q:MAX'>$G(ORDIALOG(PROMPT,"TOT")) + . S INST=$O(ORDIALOG(PROMPT,"?"),-1)+1 + . D ONE(INST,0) I '$D(ORDIALOG(PROMPT,INST)) S DONE=1 Q + . S ORDIALOG(PROMPT,"TOT")=+$G(ORDIALOG(PROMPT,"TOT"))+1,DIR("A")=ANOTHER_ORDIALOG(PROMPT,"A") + Q + ; +ONE(ORI,REQD) ; -- ask single-valued prompt + N DONE,ORESET + S:$D(ORDIALOG(PROMPT,ORI)) DIR("B")=$$EXT^ORCD(PROMPT,ORI),ORESET=ORDIALOG(PROMPT,ORI) + F D Q:$G(DONE) I $G(ORQUIT) Q:FIRST Q:'REQD!$D(ORDIALOG(PROMPT,ORI)) S FIRST=$$DONE^ORCDLG2 Q:FIRST K ORQUIT + . D DIR^ORCDLG2 I $D(DTOUT)!$D(DIROUT)!(X=U) S ORQUIT=1 Q + . I X="" S DONE=1 Q + . I X?1"^".E D UJUMP Q + . I X="@" D DELETE Q + . S ORDIALOG(PROMPT,ORI)=$P(Y,U),DONE=1 + . X:$L($G(^ORD(101.41,+ORDIALOG,10,ITM,5))) ^(5) I '$G(DONE) D RESET Q ; validate - if failed, K DONE to reask + . D:$D(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT)) CHILDREN(PROMPT,ORI) I '$G(DONE),'FIRST D DELCHILD(PROMPT,ORI),RESET Q + Q + ; +CHILDREN(PARENT,INST) ; -- ask child prompts + N SEQ,DA,ORQUIT S SEQ=0 + F S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PARENT,SEQ)) Q:SEQ'>0 S DA=$O(^(SEQ,0)) D EN(DA,INST) Q:$G(ORQUIT) + K:$G(ORQUIT) DONE ; reask parent + Q + ; +RESET ; -- Reset original prompt value + K ORDIALOG(PROMPT,ORI) + S:$D(ORESET) ORDIALOG(PROMPT,ORI)=ORESET + Q + ; +UJUMP ; -- ^-jump + N XP,P,CNT,MATCH,I,DIR,NEWSEQ ; XP=$$UP(X),P=PROMPT + I $G(NOJUMP) W $C(7)," ^-jumping not allowed!" Q + S XP=$$UP^XLFSTR($P(X,U,2)) I "^"[XP S ORQUIT=1 Q + I $G(ORDIALOG("B",XP)) S NEWSEQ=+ORDIALOG("B",XP) G UJQ + S CNT=0,P=XP F S P=$O(ORDIALOG("B",P)) Q:P="" Q:$E(P,1,$L(XP))'=XP Q:FIRST&(+ORDIALOG("B",P)'0 S DA=$O(^(SEQ,0)),PTR=+$P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,2) K:PTR ORDIALOG(PTR,INST) + Q + ; +SURE() ; -- sure you want to delete? + N X,Y,DIR + S DIR(0)="YA",DIR("A")=" Are you sure you want to delete this value? " + S DIR("B")="NO" W $C(7) D ^DIR + S:$D(DTOUT) Y="^" + Q Y + ; +VALID() ;Check to see if default value is valid. Returns 0 or 1 + ;Entire section added in patch 95 + N TYPE,RANGE,MIN,MAX,DIR,X,ORDIC,DDS,RTYPE,ORIG + I Y="" Q 1 ;If default is null allow to pass ;110 + S DIR(0)=$G(ORDIALOG(PROMPT,0)),(ORIG,X)=Y,DIR("V")="" ;Set reader type, default input, silent call + S TYPE=$E($P(DIR(0),"^")) ;Get type of look-up being done + I TYPE="W" Q 1 ;If word processing assume value is valid, may be referencing a global location + I TYPE="R" S $P(DIR(0),"^")="D"_$E($P(DIR(0),"^"),2,999),TYPE="D",RTYPE=1 ;If type is R then change to date look up + I TYPE="D" I X="AM"!(X="NEXT")!(X="NEXTA")!(X="CLOSEST") Q 1 ;If date/time prompt default is AM, NEXT, NEXTA, or CLOSEST then accept without checking + S:TYPE="P"&(X=+X) X="`"_X ;If pointer type add ` to IEN for DIR call + I TYPE="P" S ORDIC=$P(DIR(0),"^",2) S $P(ORDIC,":",2)=$TR($P(ORDIC,":",2),"QE","") S $P(DIR(0),"^",2)=ORDIC ;If pointer type remove Q&E from DIC(0) so no echo and no ?? on erroneous input + I TYPE="D" S ORDIC=$P(DIR(0),"^",2) S $P(ORDIC,":",3)=$TR($P(ORDIC,":",3),"E",""),$P(ORDIC,":")=$TR($P(ORDIC,":"),"DTNOW",""),$P(DIR(0),"^",2)=ORDIC ;Remove "E" so no echo, remove DT and NOW so DIR call works correctly + I TYPE="Y" S:"^Y^YE^YES^"[("^"_$TR(X,"yes","YES")_"^")!(X=1) X="YES" S:"^N^NO^"[("^"_$TR(X,"no","NO")_"^")!(X=0) X="NO" ;If yes/no type convert input to uppercase full entry to avoid echo + I TYPE="S" S DDS=1 ;Stops DIR call from echoing rest of entry for set of codes + D ^DIR + I TYPE="D"&('$D(Y(0))) Q 0 ;Date not valid + I TYPE="L"&($G(Y)="") Q 0 ;List/Range not valid + I TYPE="N"&('$D(Y)) Q 0 ;Numeric not valid + I TYPE="P"&($G(Y)=-1) Q 0 ;Pointer not valid + I TYPE="S"&($G(Y(0))="") Q 0 ;Set of codes not valid + I TYPE="Y"&($G(Y(0))="") Q 0 ;Yes/No not valid + I TYPE="F" S RANGE=$P(DIR(0),"^",2),MIN=$S($P(RANGE,":"):$P(RANGE,":"),1:1),MAX=$S($P(RANGE,":",2):$P(RANGE,":",2),1:240) I $L(Y)MAX) Q 0 ;Free text and not within valid limit + I $G(RTYPE) S Y=ORIG ;Set y back to relative date + I TYPE="P" S Y=$P(Y,"^") ;only store IEN ;110 + Q 1 ;Must be valid diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDLG2.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDLG2.m index 68417b92..91dd430c 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDLG2.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDLG2.m @@ -1,198 +1,193 @@ -ORCDLG2 ;SLC/MKB-Order dialogs cont ;10/12/2007 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,60,79,94,243**;Dec 17, 1997;Build 242 - ;;Per VHA Directive 2004-038, this routine should not be modified. -DIR ; -- ^DIR read of X, returns Y - N INPUTXFM,LKUP,REPL K DTOUT,DUOUT,DIRUT,DIROUT,DDER,Y - S (X,Y)="",INPUTXFM=$P(DIR(0),U,3,99) - S LKUP=$G(ORDIALOG(PROMPT,"LKP")) ; special lookup rtn - S REPL=$S(DATATYPE'="F":0,$L($G(DIR("B")))>20:1,1:0) S:REPL DIR(0)=$E(DIR(0))_"AO^"_$P(DIR(0),U,2,99) -DIR1 I 'REPL W !,DIR("A")_$S($D(DIR("B")):DIR("B")_"// ",1:"") R X:DTIME I '$T S DTOUT=1 Q - I REPL D ^DIR Q:$D(DTOUT)!$D(DUOUT) - I X="" S:$D(DIR("B")) X=DIR("B"),Y=ORDIALOG(PROMPT,ORI) S:'$L(X)&(SEQ=1)&('MULT) X="^" Q:'REQD!$L(X) W $C(7),!!,$$REQUIRED^ORCDLG1,! G DIR1 - I X="@" Q:'REQD W $C(7),!!,$$REQUIRED^ORCDLG1,! G DIR1 - I X?1"^".E S (DUOUT,DIRUT)=1,Y=X S:X="^^" DIROUT=1 Q - I X?1"?".E D G DIR1 - . N XHELP - . S XHELP=$S($D(DIR("??")):$P(DIR("??"),U,2,99),1:("D "_DATATYPE_"^ORCDLGH")) - . I (DATATYPE="P")!(DATATYPE="S")!(X?1"??".E) X XHELP - . S:'$D(DIR("?")) DIR("?")=$$HELP(DATATYPE) - . I $L(DIR("?"))<80 W !,DIR("?"),! - . E D W ! - . . N X,DIWL,DIWR,I S X=DIR("?"),DIWL=1,DIWR=80 K ^UTILITY($J,"W") - . . D ^DIWP F I=1:1:^UTILITY($J,"W",DIWL) W !,$G(^UTILITY($J,"W",DIWL,I,0)) - I $L(INPUTXFM) X INPUTXFM I '$D(X) D ERR G DIR1 - I $L(LKUP),$L($T(@LKUP)) D @LKUP Q:Y>0 D ERR G DIR1 - I $G(ORDIALOG(PROMPT,"LIST")) D Q:$L(Y) I $P(ORDIALOG(PROMPT,"LIST"),U,2) W $C(7) D LIST^ORCD G DIR1 - . N OROOT S OROOT="ORDIALOG("_PROMPT_",""LIST"")" - . S:(X=" ")&(DATATYPE="P") X=$$SPACE(DOMAIN) - . S Y=$$FIND(OROOT,X) ; I X'[",",X'["-" S Y=$$FIND Q - . ; S ORX=$$EXPLIST(X) F S Y(Y+1)=$$FIND - I DATATYPE="P" D DIC I Y'>0 D ERR G DIR1 - I (DATATYPE="R")!(DATATYPE="D") D DT I Y<0 D ERR G DIR1 - I "^F^N^S^Y^"[(U_DATATYPE_U) D I $G(DDER) D ERR G DIR1 ;JEH 'REPL was checked - . N I F I=1:1:31 S X=$TR(X,$C(I)) ; strip out control char's - . S DIR("V")="" D ^DIR ; silent - Q - ; -ERR ; -- show help msg on error - W:$D(DIR("?")) $C(7),!,DIR("?"),! - Q - ; -FIND(LIST,X) ; -- find value X in LIST(#) or LIST("B",name) - N Y,XP,CNT,MATCH,I,DIR - S:$L(X)>63 X=$E(X,1,63) S X=$$UP^XLFSTR(X) - S CNT=0,XP="" F S XP=$O(@LIST@("B",XP)) Q:XP="" I $S(X=+X:+XP=+X,1:$E(XP,1,$L(X))=X) S CNT=CNT+1,MATCH(CNT)=@LIST@("B",XP)_U_XP,DIR("A",CNT)=$J(CNT,3)_" "_XP - I X=+X!(X?1"0."1.N) S Y=$G(@LIST@(X)) I $L(Y) W " "_$P(Y,U,2) G:$$OK FQ S X="" W " " ;force entire text to echo if CNT=1 - I 'CNT S Y="" G FQ - I CNT=1 S Y=MATCH(1),XP=$P(Y,U,2) W $E(XP,$L(X)+1,$L(XP)) G FQ - S DIR("A")="Select 1-"_CNT_": ",DIR(0)="NAO^1:"_CNT - S DIR("?")="Select the desired value, by number" - D ^DIR I $D(DTOUT)!($D(DUOUT))!(Y="") S Y="" G FQ - S Y=MATCH(Y) W " "_$P(Y,U,2) -FQ D:Y&((+DOMAIN=101.43)!(DOMAIN?1"ORD(101.43,:".E)) SETDISV - Q Y - ; -OK() ; -- Return 1 or 0, if selected item is correct - N X,Y,DIR I CNT'>0 Q 1 ;no other matches - S DIR(0)="YA",DIR("A")=" ...OK? ",DIR("B")="YES" - S DIR("?")="Enter YES if this is the item you wish to select, or NO to continue searching the list" - D ^DIR S:$D(DUOUT)!$D(DTOUT) Y="" - Q +Y - ; -DIC ; -- ^DIC lookup on X, return Y - N ORDMN,ORDITM,DIC,D,ORDIC,TYPE S Y=-1,ORDMN=$P(ORDIALOG(PROMPT,0),U,2) - S ORDITM=$S(+ORDMN=101.43:1,ORDMN?1"ORD(101.43,:".E:1,1:0) ; OI file? - I X=" ",ORDITM D SPBAR W $S(Y>0:" "_X,1:$C(7)_" ??") Q - I ORDITM,X?1"`"1.N W $C(7),!,"Lookup by internal entry number not allowed!",! Q - I X=$G(DIR("B")) S Y=ORDIALOG(PROMPT,ORI) Q ; default - S DIC=$P(ORDMN,":"),DIC(0)=$P(ORDMN,":",2),ORDIC="^DIC" S:'DIC DIC=U_DIC - S:$D(ORDIALOG(PROMPT,"S")) DIC("S")=ORDIALOG(PROMPT,"S") - S TYPE=$P($G(^ORD(100.98,+$G(ORDG),0)),U,3) - S:ORDITM DIC("W")="W:$S('$D(%):0,'$D(DIY):0,%=DIY:0,1:1) $G(DIY)"_$S(TYPE["RX":" W:$P($G(^(""PS"")),U,6) "" (non-formulary)"" ",1:"") ;W NAME if OI/synm, or NF - S D=$G(ORDIALOG(PROMPT,"D")),D=$TR(D,";","^") - I $L(D) S ORDIC="IX^DIC" S:$L(D,U)>1 ORDIC="MIX^DIC1",DIC(0)=DIC(0)_"M" - D @ORDIC,SETDISV:Y&ORDITM - I DIC(0)["S",X'=$P(Y,"^",2) W " ",$P(Y,"^",2) - Q - ; -SPACE(FILE) ; -- Resolve spbar-return for ptrs - N X,Y,DIC,ROOT S X=" ",FILE=$P(FILE,":") - I (+FILE=101.43)!(FILE="ORD(101.43,") D SPBAR Q X - S ROOT=$S(+FILE:$$ROOT^DILFD(+FILE),1:U_FILE),Y=$G(^DISV(DUZ,ROOT)) - S:Y X=$P(@(ROOT_Y_",0)"),U) - Q X - ; -SPBAR ; -- Resolve spbar-return for #101.43 - N SDX,I,X1,D S SDX="",D=$G(ORDIALOG(PROMPT,"D")),D=$TR(D,";","^") - F I=1:1:$L(D,"^") I $P(D,U,I)?1"S."1.E S SDX=$P(D,U,I) Q - Q:'$L(SDX) S X1=$G(^DISV(DUZ,"ORDITM",SDX,1)) Q:'$L(X1) - S Y=$O(^ORD(101.43,SDX,X1,0)) S:Y X=X1,Y=Y_U_X1 - Q - ; -SETDISV ; -- Save entry Y=ifn^name in ^DISV for #101.43 - N SDX,I Q:'$L($P(Y,U,2)) - S SDX="",D=$G(ORDIALOG(PROMPT,"D")) Q:D'["S." - F I=1:1:$L(D,";") I $P(D,";",I)?1"S."1.E S SDX=$P(D,";",I) Q - Q:'$L(SDX) S ^DISV(DUZ,"ORDITM",SDX,1)=$P(Y,U,2) - Q - ; -DT ; -- %DT validation on X, return Y - N %DT,BEG,END S %DT=$P(DOMAIN,":",3),X=$$UP^XLFSTR(X) - I $L($P(DOMAIN,":")) S BEG=$$FMDT($P(DOMAIN,":")) ;earliest date allowed - I $L($P(DOMAIN,":",2)) S END=$$FMDT($P(DOMAIN,":",2)) ;latest allowed - D ^%DT Q:Y'>0 - I $G(BEG) D Q:Y<0 - . I $L(Y,".")'=$L(BEG,".") S BEG=$P(BEG,".") ; date only - . I YEND W $C(7),!,"Date may not be after "_$$FMTE^XLFDT(END) S Y=-1 Q - I DATATYPE="R",$$RELDT(X) S:(%DT'["T")&("NOW"[X) X="TODAY" S Y=X ;text - Q -DT1 S:X="NOON" X="T@NOON" S:$E("MIDNIGHT",1,$L(X))=X X="T@MIDNIGHT" - I X'?1"V".E,X'?1"T".E D ^%DT S:Y>0&("NOW"[X) Y="NOW" Q - S D=$$UP^XLFSTR($P(X,"@")),T=$P(X,"@",2) - S Y=$E(D) I "VT"'[Y S Y=-1 Q - I (D["+")!(D["-") D Q:Y<0 - . N SIGN,OFFSET,X1,X2 - . S SIGN=$S(D["+":"+",1:"-"),OFFSET=$P(D,SIGN,2) I 'OFFSET S Y=-1 Q - . S X1=+OFFSET,X2=$P(OFFSET,X1,2) I "DWM"'[$E(X2) S Y=-1 Q - . S Y=Y_SIGN_X1_$E(X2) ; T+3W, e.g. - I '$L(T)&(DOMAIN["R") S Y=-1 Q ; time missing, required - I $L(T) D I '$D(T) S Y=-1 Q - . I '(DOMAIN["T"!(DOMAIN["R")) K T Q ; time prohibited - . N X,Y S X="T@"_T,%DT=$TR(DOMAIN,"E") D ^%DT I Y<0 K T Q - . S T=$E($P(Y,".",2),1,4) S:$L(T)<4 T=T_$E("0000",1,4-$L(T)) - S:$L(T) Y=Y_"@"_T ; Y=date text, or -1 if error - Q - ; -RELDT(X) ; -- Returns 1 or 0, if X is relative date - N Y S X=$G(X) - I ("NOON"[X)!("MIDNIGHT"[X)!($E(X)="T")!($E(X)="N") S Y=1 - E S Y=0 - Q Y - ; -FMDT(X) ; -- Return FM form of date X - N Y,%DT S %DT="T" D ^%DT - Q Y - ; -WP ; -- edit WP field - N DIC,DWLW,DWPK,DIWESUB,DONE,ORLINEDT,LCNT,UPCARR - S DIC="^TMP(""ORWORD"",$J,"_PROMPT_","_INST_",",DWLW=80,DWPK=1 - S DIWESUB=$P(DIR("A"),":"),ORLINEDT=$$LINEDTR(DUZ) - I '$D(^TMP("ORWORD",$J,PROMPT,INST)) M:$D(^ORD(101.41,+ORDIALOG,10,ITM,8))>9 ^TMP("ORWORD",$J,PROMPT,INST)=^(8) - I 'ORLINEDT,'REQD,'$$EDITWP Q ;94 -WP1 W:ORLINEDT !,DIR("A") S DIWESUB=$P(DIR("A"),":") - D EN^DIWE I $D(DTOUT)!($D(DUOUT)) S ORQUIT=1 Q - I REQD,'$O(^TMP("ORWORD",$J,PROMPT,INST,0)) W $C(7),!!,"A response is required!" G:'$$DONE WP1 S ORQUIT=1 Q - I '$O(^TMP("ORWORD",$J,PROMPT,INST,0)) K ^TMP("ORWORD",$J,PROMPT,INST),ORDIALOG(PROMPT,INST) Q ;empty - S LCNT="",UPCARR=0 - F S LCNT=$O(^TMP("ORWORD",$J,PROMPT,INST,LCNT)) Q:LCNT=""!(UPCARR=1) D - .I LCNT>0,$G(^TMP("ORWORD",$J,PROMPT,INST,LCNT,0))[U S UPCARR=1 - I UPCARR=1 W !!,"An ""^"" is not allowed in a word processing field." G:'$$DONE WP1 S ORQUIT=1 Q - S ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"","_$J_","_PROMPT_","_INST_")",DONE=1 - I $D(^ORD(101.41,+ORDIALOG,10,ITM,5)) X ^(5) Q:$G(ORQUIT)!($G(DONE)) G WP1 - Q - ; -EDITWP() ; -- Want to edit WP field? - N X,Y,%,%Y - W !,ORDIALOG(PROMPT,"A") S Y=$D(ORDIALOG(PROMPT,INST)) - I 'Y,REQD Q 1 ; no data, req'd - W:'Y !," No existing text",! I Y D ; show comments - . N X,DIWL,DIWR,DIWF,ORI - . S DIWL=3,DIWR=79,DIWF="W" K ^UTILITY($J,"W") - . S ORI=0 F S ORI=$O(^TMP("ORWORD",$J,PROMPT,INST,ORI)) Q:ORI'>0 S X=$G(^(ORI,0)) D:$L(X) ^DIWP - . D ^DIWW -ED1 S %=$S($D(OREDIT):1,1:2) W " Edit" D YN^DICN - I %=0 W !," Enter 'YES' if you wish to go into the editor.",!," Enter 'NO' if you do not wish to edit at this time.",! G ED1 - S Y=$S(%<0:"^",%=2:0,1:1) - Q Y - ; -LINEDTR(USER) ; -- Returns 1 or 0, if user's editor will be LineEd - N X,Y - S X=+$P($G(^VA(200,USER,1)),U,5),Y=0 I 'X S Y=1 - E S:$$GET1^DIQ(1.2,+X_",",.01)="LINE EDITOR - VA FILEMAN" Y=1 - Q Y - ; -RETURN() ; -- press return to cont - N X W !,"Press to continue ..." R X:DTIME - Q "" - ; -DONE() ; -- Done editing? - N DIR,X,Y - S DIR(0)="YA",DIR("A")="Do you want to quit? ",DIR("B")="NO" - S DIR("?")="Enter YES to exit this order, or NO to continue editing" - D ^DIR - Q +Y - ; -HELP(TYPE) ; -- Returns default help msg for TYPE prompt - N Y S Y="" - I TYPE="D" S Y="Enter a date[/time]." - I TYPE="R" S Y="Enter a date[/time] as T for TODAY or T+1 for TOMORROW." - I TYPE="F" S Y="Enter a string of text." - I TYPE="N" S Y="Enter a number." - I TYPE="S" S Y="Enter an item from the list." - I TYPE="Y" S Y="Enter YES or NO." - I TYPE="P" S Y="Enter an item from the file." - I TYPE="W" S Y="" - Q Y +ORCDLG2 ;SLC/MKB-Order dialogs cont ;3/13/01 11:16 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,60,79,94**;Dec 17, 1997 +DIR ; -- ^DIR read of X, returns Y + N INPUTXFM,LKUP,REPL K DTOUT,DUOUT,DIRUT,DIROUT,DDER,Y + S (X,Y)="",INPUTXFM=$P(DIR(0),U,3,99) + S LKUP=$G(ORDIALOG(PROMPT,"LKP")) ; special lookup rtn + S REPL=$S(DATATYPE'="F":0,$L($G(DIR("B")))>20:1,1:0) S:REPL DIR(0)=$E(DIR(0))_"AO^"_$P(DIR(0),U,2,99) +DIR1 I 'REPL W !,DIR("A")_$S($D(DIR("B")):DIR("B")_"// ",1:"") R X:DTIME I '$T S DTOUT=1 Q + I REPL D ^DIR Q:$D(DTOUT)!$D(DUOUT) + I X="" S:$D(DIR("B")) X=DIR("B"),Y=ORDIALOG(PROMPT,ORI) S:'$L(X)&(SEQ=1)&('MULT) X="^" Q:'REQD!$L(X) W $C(7),!!,$$REQUIRED^ORCDLG1,! G DIR1 + I X="@" Q:'REQD W $C(7),!!,$$REQUIRED^ORCDLG1,! G DIR1 + I X?1"^".E S (DUOUT,DIRUT)=1,Y=X S:X="^^" DIROUT=1 Q + I X?1"?".E D G DIR1 + . N XHELP + . S XHELP=$S($D(DIR("??")):$P(DIR("??"),U,2,99),1:("D "_DATATYPE_"^ORCDLGH")) + . I (DATATYPE="P")!(DATATYPE="S")!(X?1"??".E) X XHELP + . S:'$D(DIR("?")) DIR("?")=$$HELP(DATATYPE) + . I $L(DIR("?"))<80 W !,DIR("?"),! + . E D W ! + . . N X,DIWL,DIWR,I S X=DIR("?"),DIWL=1,DIWR=80 K ^UTILITY($J,"W") + . . D ^DIWP F I=1:1:^UTILITY($J,"W",DIWL) W !,$G(^UTILITY($J,"W",DIWL,I,0)) + I $L(INPUTXFM) X INPUTXFM I '$D(X) D ERR G DIR1 + I $L(LKUP),$L($T(@LKUP)) D @LKUP Q:Y>0 D ERR G DIR1 + I $G(ORDIALOG(PROMPT,"LIST")) D Q:$L(Y) I $P(ORDIALOG(PROMPT,"LIST"),U,2) W $C(7) D LIST^ORCD G DIR1 + . N OROOT S OROOT="ORDIALOG("_PROMPT_",""LIST"")" + . S:(X=" ")&(DATATYPE="P") X=$$SPACE(DOMAIN) + . S Y=$$FIND(OROOT,X) ; I X'[",",X'["-" S Y=$$FIND Q + . ; S ORX=$$EXPLIST(X) F S Y(Y+1)=$$FIND + I DATATYPE="P" D DIC I Y'>0 D ERR G DIR1 + I (DATATYPE="R")!(DATATYPE="D") D DT I Y<0 D ERR G DIR1 + I "^F^N^S^Y^"[(U_DATATYPE_U),'REPL D I $G(DDER) D ERR G DIR1 + . N I F I=1:1:31 S X=$TR(X,$C(I)) ; strip out control char's + . S DIR("V")="" D ^DIR ; silent + Q + ; +ERR ; -- show help msg on error + W:$D(DIR("?")) $C(7),!,DIR("?"),! + Q + ; +FIND(LIST,X) ; -- find value X in LIST(#) or LIST("B",name) + N Y,XP,CNT,MATCH,I,DIR + S:$L(X)>63 X=$E(X,1,63) S X=$$UP^XLFSTR(X) + S CNT=0,XP="" F S XP=$O(@LIST@("B",XP)) Q:XP="" I $S(X=+X:+XP=+X,1:$E(XP,1,$L(X))=X) S CNT=CNT+1,MATCH(CNT)=@LIST@("B",XP)_U_XP,DIR("A",CNT)=$J(CNT,3)_" "_XP + I X=+X S Y=$G(@LIST@(X)) I $L(Y) W " "_$P(Y,U,2) G:$$OK FQ S X="" W " " ;force entire text to echo if CNT=1 + I 'CNT S Y="" G FQ + I CNT=1 S Y=MATCH(1),XP=$P(Y,U,2) W $E(XP,$L(X)+1,$L(XP)) G FQ + S DIR("A")="Select 1-"_CNT_": ",DIR(0)="NAO^1:"_CNT + S DIR("?")="Select the desired value, by number" + D ^DIR I $D(DTOUT)!($D(DUOUT))!(Y="") S Y="" G FQ + S Y=MATCH(Y) W " "_$P(Y,U,2) +FQ D:Y&((+DOMAIN=101.43)!(DOMAIN?1"ORD(101.43,:".E)) SETDISV + Q Y + ; +OK() ; -- Return 1 or 0, if selected item is correct + N X,Y,DIR I CNT'>0 Q 1 ;no other matches + S DIR(0)="YA",DIR("A")=" ...OK? ",DIR("B")="YES" + S DIR("?")="Enter YES if this is the item you wish to select, or NO to continue searching the list" + D ^DIR S:$D(DUOUT)!$D(DTOUT) Y="" + Q +Y + ; +DIC ; -- ^DIC lookup on X, return Y + N ORDMN,ORDITM,DIC,D,ORDIC,TYPE S Y=-1,ORDMN=$P(ORDIALOG(PROMPT,0),U,2) + S ORDITM=$S(+ORDMN=101.43:1,ORDMN?1"ORD(101.43,:".E:1,1:0) ; OI file? + I X=" ",ORDITM D SPBAR W $S(Y>0:" "_X,1:$C(7)_" ??") Q + I ORDITM,X?1"`"1.N W $C(7),!,"Lookup by internal entry number not allowed!",! Q + I X=$G(DIR("B")) S Y=ORDIALOG(PROMPT,ORI) Q ; default + S DIC=$P(ORDMN,":"),DIC(0)=$P(ORDMN,":",2),ORDIC="^DIC" S:'DIC DIC=U_DIC + S:$D(ORDIALOG(PROMPT,"S")) DIC("S")=ORDIALOG(PROMPT,"S") + S TYPE=$P($G(^ORD(100.98,+$G(ORDG),0)),U,3) + S:ORDITM DIC("W")="W:$S('$D(%):0,'$D(DIY):0,%=DIY:0,1:1) $G(DIY)"_$S(TYPE["RX":" W:$P($G(^(""PS"")),U,6) "" (non-formulary)"" ",1:"") ;W NAME if OI/synm, or NF + S D=$G(ORDIALOG(PROMPT,"D")),D=$TR(D,";","^") + I $L(D) S ORDIC="IX^DIC" S:$L(D,U)>1 ORDIC="MIX^DIC1",DIC(0)=DIC(0)_"M" + D @ORDIC,SETDISV:Y&ORDITM + I DIC(0)["S",X'=$P(Y,"^",2) W " ",$P(Y,"^",2) + Q + ; +SPACE(FILE) ; -- Resolve spbar-return for ptrs + N X,Y,DIC,ROOT S X=" ",FILE=$P(FILE,":") + I (+FILE=101.43)!(FILE="ORD(101.43,") D SPBAR Q X + S ROOT=$S(+FILE:$$ROOT^DILFD(+FILE),1:U_FILE),Y=$G(^DISV(DUZ,ROOT)) + S:Y X=$P(@(ROOT_Y_",0)"),U) + Q X + ; +SPBAR ; -- Resolve spbar-return for #101.43 + N SDX,I,X1,D S SDX="",D=$G(ORDIALOG(PROMPT,"D")),D=$TR(D,";","^") + F I=1:1:$L(D,"^") I $P(D,U,I)?1"S."1.E S SDX=$P(D,U,I) Q + Q:'$L(SDX) S X1=$G(^DISV(DUZ,"ORDITM",SDX,1)) Q:'$L(X1) + S Y=$O(^ORD(101.43,SDX,X1,0)) S:Y X=X1,Y=Y_U_X1 + Q + ; +SETDISV ; -- Save entry Y=ifn^name in ^DISV for #101.43 + N SDX,I Q:'$L($P(Y,U,2)) + S SDX="",D=$G(ORDIALOG(PROMPT,"D")) Q:D'["S." + F I=1:1:$L(D,";") I $P(D,";",I)?1"S."1.E S SDX=$P(D,";",I) Q + Q:'$L(SDX) S ^DISV(DUZ,"ORDITM",SDX,1)=$P(Y,U,2) + Q + ; +DT ; -- %DT validation on X, return Y + N %DT,BEG,END S %DT=$P(DOMAIN,":",3),X=$$UP^XLFSTR(X) + I $L($P(DOMAIN,":")) S BEG=$$FMDT($P(DOMAIN,":")) ;earliest date allowed + I $L($P(DOMAIN,":",2)) S END=$$FMDT($P(DOMAIN,":",2)) ;latest allowed + D ^%DT Q:Y'>0 + I $G(BEG) D Q:Y<0 + . I $L(Y,".")'=$L(BEG,".") S BEG=$P(BEG,".") ; date only + . I YEND W $C(7),!,"Date may not be after "_$$FMTE^XLFDT(END) S Y=-1 Q + I DATATYPE="R",$$RELDT(X) S:(%DT'["T")&("NOW"[X) X="TODAY" S Y=X ;text + Q +DT1 S:X="NOON" X="T@NOON" S:$E("MIDNIGHT",1,$L(X))=X X="T@MIDNIGHT" + I X'?1"V".E,X'?1"T".E D ^%DT S:Y>0&("NOW"[X) Y="NOW" Q + S D=$$UP^XLFSTR($P(X,"@")),T=$P(X,"@",2) + S Y=$E(D) I "VT"'[Y S Y=-1 Q + I (D["+")!(D["-") D Q:Y<0 + . N SIGN,OFFSET,X1,X2 + . S SIGN=$S(D["+":"+",1:"-"),OFFSET=$P(D,SIGN,2) I 'OFFSET S Y=-1 Q + . S X1=+OFFSET,X2=$P(OFFSET,X1,2) I "DWM"'[$E(X2) S Y=-1 Q + . S Y=Y_SIGN_X1_$E(X2) ; T+3W, e.g. + I '$L(T)&(DOMAIN["R") S Y=-1 Q ; time missing, required + I $L(T) D I '$D(T) S Y=-1 Q + . I '(DOMAIN["T"!(DOMAIN["R")) K T Q ; time prohibited + . N X,Y S X="T@"_T,%DT=$TR(DOMAIN,"E") D ^%DT I Y<0 K T Q + . S T=$E($P(Y,".",2),1,4) S:$L(T)<4 T=T_$E("0000",1,4-$L(T)) + S:$L(T) Y=Y_"@"_T ; Y=date text, or -1 if error + Q + ; +RELDT(X) ; -- Returns 1 or 0, if X is relative date + N Y S X=$G(X) + I ("NOON"[X)!("MIDNIGHT"[X)!($E(X)="T")!($E(X)="N") S Y=1 + E S Y=0 + Q Y + ; +FMDT(X) ; -- Return FM form of date X + N Y,%DT S %DT="T" D ^%DT + Q Y + ; +WP ; -- edit WP field + N DIC,DWLW,DWPK,DIWESUB,DONE,ORLINEDT + S DIC="^TMP(""ORWORD"",$J,"_PROMPT_","_INST_",",DWLW=80,DWPK=1 + S DIWESUB=$P(DIR("A"),":"),ORLINEDT=$$LINEDTR(DUZ) + I '$D(^TMP("ORWORD",$J,PROMPT,INST)) M:$D(^ORD(101.41,+ORDIALOG,10,ITM,8))>9 ^TMP("ORWORD",$J,PROMPT,INST)=^(8) + I 'ORLINEDT,'REQD,'$$EDITWP Q ;94 +WP1 W:ORLINEDT !,DIR("A") S DIWESUB=$P(DIR("A"),":") + D EN^DIWE I $D(DTOUT)!($D(DUOUT)) S ORQUIT=1 Q + I REQD,'$O(^TMP("ORWORD",$J,PROMPT,INST,0)) W $C(7),!!,"A response is required!" G:'$$DONE WP1 S ORQUIT=1 Q + I '$O(^TMP("ORWORD",$J,PROMPT,INST,0)) K ^TMP("ORWORD",$J,PROMPT,INST),ORDIALOG(PROMPT,INST) Q ;empty + S ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"","_$J_","_PROMPT_","_INST_")",DONE=1 + I $D(^ORD(101.41,+ORDIALOG,10,ITM,5)) X ^(5) Q:$G(ORQUIT)!($G(DONE)) G WP1 + Q + ; +EDITWP() ; -- Want to edit WP field? + N X,Y,%,%Y + W !,ORDIALOG(PROMPT,"A") S Y=$D(ORDIALOG(PROMPT,INST)) + I 'Y,REQD Q 1 ; no data, req'd + W:'Y !," No existing text",! I Y D ; show comments + . N X,DIWL,DIWR,DIWF,ORI + . S DIWL=3,DIWR=79,DIWF="W" K ^UTILITY($J,"W") + . S ORI=0 F S ORI=$O(^TMP("ORWORD",$J,PROMPT,INST,ORI)) Q:ORI'>0 S X=$G(^(ORI,0)) D:$L(X) ^DIWP + . D ^DIWW +ED1 S %=$S($D(OREDIT):1,1:2) W " Edit" D YN^DICN + I %=0 W !," Enter 'YES' if you wish to go into the editor.",!," Enter 'NO' if you do not wish to edit at this time.",! G ED1 + S Y=$S(%<0:"^",%=2:0,1:1) + Q Y + ; +LINEDTR(USER) ; -- Returns 1 or 0, if user's editor will be LineEd + N X,Y + S X=+$P($G(^VA(200,USER,1)),U,5),Y=0 I 'X S Y=1 + E S:$$GET1^DIQ(1.2,+X_",",.01)="LINE EDITOR - VA FILEMAN" Y=1 + Q Y + ; +RETURN() ; -- press return to cont + N X W !,"Press to continue ..." R X:DTIME + Q "" + ; +DONE() ; -- Done editing? + N DIR,X,Y + S DIR(0)="YA",DIR("A")="Do you want to quit? ",DIR("B")="NO" + S DIR("?")="Enter YES to exit this order, or NO to continue editing" + D ^DIR + Q +Y + ; +HELP(TYPE) ; -- Returns default help msg for TYPE prompt + N Y S Y="" + I TYPE="D" S Y="Enter a date[/time]." + I TYPE="R" S Y="Enter a date[/time] as T for TODAY or T+1 for TOMORROW." + I TYPE="F" S Y="Enter a string of text." + I TYPE="N" S Y="Enter a number." + I TYPE="S" S Y="Enter an item from the list." + I TYPE="Y" S Y="Enter YES or NO." + I TYPE="P" S Y="Enter an item from the file." + I TYPE="W" S Y="" + Q Y diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDLR.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDLR.m index 010d4fce..0f97bed9 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDLR.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDLR.m @@ -1,180 +1,170 @@ -ORCDLR ;SLC/MKB-Utility functions for LR dialogs ;11/22/06 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,29,49,61,71,79,175,243**;Dec 17, 1997;Build 242 -TEST ; -- Setup ORTEST() array of ordering parameters - N OI,TST,WRD,I,DG - S OI=+$G(ORDIALOG(PROMPT,INST)) Q:'OI - I '$D(ORTEST) S TST=+$P($G(^ORD(101.43,OI,0)),U,2) D TEST^LR7OR3(TST,.ORTEST) S ORTEST=TST - S WRD="GenWardInstructions" I $O(ORTEST(WRD,0)) D W ! - . W ! S I=0 F S I=$O(ORTEST(WRD,I)) Q:I'>0 W !,ORTEST(WRD,I,0) - S DG=$P($G(^ORD(101.43,+OI,"LR")),U,6) S:'$L(DG) DG="LAB" - S DG=$O(^ORD(100.98,"B",DG,0)) S:DG ORDG=DG - Q - ; -CKTYP ; -- ck type of test [Exit Action] - N X,Y S X=$G(ORDIALOG(PROMPT,INST)) Q:'X - S Y=$P($G(^ORD(101.43,+X,"LR")),U,7) - I (Y="O")!(Y="N") W $C(7),!,"This test may not be ordered anymore. Please select another test." S ORQUIT=1 D WAIT Q - Q - ; -WAIT ; -- Wait for user - N X W !,"Press to continue ..." R X:DTIME - Q - ; -SHOWMAX ; -- Setup max days allowed for cont orders - K ^TMP($J,"ORCDLR SHOWMAX") - D ZERO^PSS51P1(+ORSCH,,,,"ORCDLR SHOWMAX") - I $S('$G(ORSCH):1,"CD"'[$P($G(^TMP($J,"ORCDLR SHOWMAX",+ORSCH,5)),U):1,1:0) K ORDIALOG(PROMPT,INST) Q ;just in case - ;I $S('$G(ORSCH):1,"CD"'[$P($G(^PS(51.1,+ORSCH,0)),U,5):1,1:0) K ORDIALOG(PROMPT,INST) Q ;just in case - N Y,OK S ORSMAX=$G(^TMP($J,"ORCDLR SHOWMAX",+ORSCH,2.5)),ORSTMS=$P($G(^(0)),U,3) - ;N Y,OK S ORSMAX=$P($G(^PS(51.1,ORSCH,0)),U,7),ORSTMS=$P($G(^(0)),U,3) - S ORSMAX=$S('$G(ORSMAX):ORMAX,$G(ORTYPE)="Z":ORSMAX,ORMAXORSMAX:1,1:"0^Cannot order more than "_ORSMAX_" days in advance.") G CKQ - I (X'?1"X"1.N),(X'?1"x"1.N) S Y="0^Enter either a number of days or X_number of times." G CKQ - I ORSTMS,+$E(X,2,9)>ORSTMS S Y="0^Cannot order more than "_ORSTMS_" time* s." G CKQ - I 'ORSTMS,+$E(X,2,9)>ORSMAX S Y="0^Cannot order for more than "_ORSMAX_" days." G CKQ ; day of week schedule - S Y=1 -CKQ Q Y - ; -SAMPLE() ; -- Get default sample from Test for INST - N X,Y I $L($G(LRFSAMP)) Q LRFSAMP - I (ORCOLLCT="LC")!(ORCOLLCT="I") S X=$G(ORTEST("Lab CollSamp")) G SAMPQ - S X=$G(ORTEST("Unique CollSamp")) G:X SAMPQ - S X=$G(ORTEST("Default CollSamp")) -SAMPQ S Y=+$G(ORTEST("CollSamp",+X)) - Q Y - ; -ENSAMP ; -- Get list of samples to pick from - Q:$G(ORDIALOG(PROMPT,"LIST")) N I,CNT,X,Y S (I,CNT)=0 - F S I=$O(ORTEST("CollSamp",I)) Q:I'>0 S X=$G(ORTEST("CollSamp",I)) D - . S Y=$P(X,U,1,2)_" "_$$GET1^DIQ(61,+$P(X,U,3)_",",.01)_" "_$P(X,U,4) - . S CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=Y - . S ORDIALOG(PROMPT,"LIST","B",$P(X,U,2))=+X - S:CNT ORDIALOG(PROMPT,"LIST")=CNT_$S($$SECTION'="MI":"^1",1:"") - Q - ; -ASKSAMP() ; -- Ask for Collection Sample? - N X,Y,DIR,DEFSAMP,SAMP0 - S DEFSAMP=$G(ORDIALOG(PROMPT,INST)),SAMP0=$G(^LAB(62,+DEFSAMP,0)) - I $G(ORTYPE)="Z",DEFSAMP Q 1 - I (ORCOLLCT="LC")!(ORCOLLCT="I"),$G(ORTEST("Lab CollSamp")) W !!,"Lab will collect "_$P(SAMP0,U)_" "_$P(SAMP0,U,3)_".",! Q 0 - I $G(ORTEST("Unique CollSamp")),DEFSAMP Q 0 ; unique -> don't ask - I 'DEFSAMP!('FIRST) Q 1 ; no default or edit -> ask - I $G(ORDIALOG(PROMPT,"LIST"))="1^1" Q 0 ; only one choice - S DIR(0)="YA",DIR("A")="Is "_$P(SAMP0,U)_" "_$P(SAMP0,U,3)_" the correct sample to collect? ",DIR("B")="Yes" - D ^DIR I $D(DTOUT)!$D(DUOUT) S ORQUIT=1 Q 0 - D:'Y LIST^ORCD - Q 'Y - ; -SECTION() ; -- Returns Lab section of Orderable Item - N PTR,X - S PTR=$O(^ORD(101.41,"AB","OR GTX ORDERABLE ITEM",0)) - S X=$P($G(^ORD(101.43,+$G(ORDIALOG(PTR,1)),"LR")),U,6) - Q X - ; -SHOWCOMM(SAMP) ; -- Show comments for sample - Q:'$G(SAMP) Q:'$G(ORTEST) N ORCOMM,I - D SCOM^LR7OR3(+ORTEST,SAMP,.ORCOMM) - S I=0 F S I=$O(ORCOMM(I)) Q:I'>0 W !,ORCOMM(I,0) - Q - ; -SPECIMEN() ; -- Get default specimen from Sample for INST - N X,Y I $L($G(LRFSPEC)) S Y=LRFSPEC - E S X=$$VAL^ORCD("COLLECTION SAMPLE"),Y=+$P($G(^LAB(62,+X,0)),U,2) - Q Y - ; -SPECHELP ; -- Xecutable help for Specimen prompt - I '$D(^LAB(61,"E")) D P^ORCDLGH Q - W !,"Choose from: " - N SP,I,DONE,CNT S (CNT,DONE)=0,SP="" - F S SP=$O(^LAB(61,"E",SP)) Q:SP="" S I=+$O(^(SP,0)) I I D - . S CNT=CNT+1 I CNT>(IOSL-2) S CNT=0 I '$$MORE^ORCD S DONE=1 Q - . W !," "_$P($G(^LAB(61,I,0)),U) - Q - ; -URGENCY ; -- Get list of urgencies to pick from - Q:$D(ORDIALOG(PROMPT,"LIST")) N I,J,X - I $G(ORTEST("Default Urgency")) S ORDIALOG(PROMPT,"LIST")="1^1",ORDIALOG(PROMPT,"LIST",1)=ORTEST("Default Urgency") Q ; Forced Urgency - I '$D(ORTEST("Urgencies")) S ORDIALOG(PROMPT,"LIST")="0^1" Q - S (I,J)=0 F S I=$O(ORTEST("Urgencies",I)) Q:I'>0 D - . S X=ORTEST("Urgencies",I) I $G(ORCOLLCT)="LC",'$P($G(^LAB(62.05,+X,0)),U,2) Q ; Lab cannot collect - . S J=J+1,ORDIALOG(PROMPT,"LIST",J)=X,ORDIALOG(PROMPT,"LIST","B",$P(X,U,2))=+X - S ORDIALOG(PROMPT,"LIST")=J_"^1" - Q - ; -ASKURG() ; -- Ask urgency prompt? - I $G(ORTEST("Default Urgency")) Q 0 ; Forced Urgency - I FIRST,$G(ORL) Q $$GET^XPAR("ALL^"_ORL,"LR ASK URGENCY") - Q (+$G(ORDIALOG(PROMPT,"LIST"))>1) - ; -REQDCOMM() ; -- Process required comments - I $O(^TMP("ORWORD",$J,PROMPT,INST,0)) Q 0 ;edit as WP - N LRTEST,LRSAMP,LRSPEC,LRTSTN,LRTCOM,LRCCOM,DA,CNT,I,REQDCOMM - S LRSAMP=$$VAL^ORCD("COLLECTION SAMPLE"),LRSPEC=$$VAL^ORCD("SPECIMEN") - S LRTSTN=1,LRTEST(1)=+ORTEST,DA=$O(^LAB(60,LRTEST(1),3,"B",+LRSAMP,0)) - S REQDCOMM=$P($G(^LAB(60,LRTEST(1),3,+DA,0)),U,6) - S:'REQDCOMM REQDCOMM=+$P($G(^LAB(60,LRTEST(1),0)),U,19) Q:'REQDCOMM 1 - I $G(ORTYPE)="Z",$P($G(^LAB(62.07,+REQDCOMM,0)),U)'="ORDER COMMENT" Q 1 - X:$D(^LAB(62.07,REQDCOMM,.1)) ^(.1) - S (CNT,I)=0 K REQDCOMM - F S I=$O(LRTCOM(LRTEST(1),I)) Q:I'>0 S CNT=CNT+1,REQDCOMM(CNT,0)=LRTCOM(LRTEST(1),I) - S:$L($G(LRCCOM)) CNT=CNT+1,REQDCOMM(CNT,0)=LRCCOM - I CNT S REQDCOMM(0)="^^"_CNT_U_CNT_U_DT_U_U,ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"",$J,"_PROMPT_","_INST_")" M ^TMP("ORWORD",$J,PROMPT,INST)=REQDCOMM -RQ Q 1 - ; -XHELP(PTR) ; -- Xecutable help - I $D(ORDIALOG(PTR,"LIST")),X="?"!$P(ORDIALOG(PTR,"LIST"),U,2) D LIST^ORCD Q - D P^ORCDLGH ; ??-help - Q - ; -CHANGED(FLD) ; -- Kill dependent values when FLD changes - N PROMPTS,P,NAME,PTR K ORCOLLCT - S PROMPTS="COLLECTION SAMPLE^SPECIMEN^WORD PROCESSING 1^START DATE/TIME" - S:FLD="OI" PROMPTS="COLLECTION TYPE^"_PROMPTS_"^LAB URGENCY" - F P=1:1:$L(PROMPTS,U) S NAME=$P(PROMPTS,U,P),PTR=$O(^ORD(101.41,"AB","OR GTX "_NAME,0)) I PTR K ORDIALOG(PTR,ORI),ORDIALOG(PTR,"LIST") - Q - ; -LB(ORDER) ; -- Returns 1 or 0, if "LB #" is already in text - N I,Y S I=0,Y=0 - F S I=$O(^OR(100,+ORDER,1,I)) Q:I'>0 I $G(^(I,0))["LB #" S Y=1 Q - Q Y - ; -DATE(X) ; Free text input to FM time - N %DT,Y - D ^%DT - Q Y - ; -XSCH ; -- xecutable help for schedule prompt - N X,IFN,CNT,Z,DONE - K ^TMP($J,"ORSCLR XSCH") - D AP^PSS51P1("LR",,,,"ORSCLR XSCH") - W !!,"Choose from:" S CNT=1 - S X="" F S X=$O(^TMP($J,"ORSCLR XSCH","APLR",X)) Q:X="" S IFN=0 D Q:$G(DONE) - .;S X="" F S X=$O(^PS(51.1,"APLR",X)) Q:X="" S IFN=0 D Q:$G(DONE) - . F S IFN=$O(^TMP($J,"ORSCLR XSCH","APLR",X,IFN)) Q:IFN'>0 D Q:$G(DONE) - . .;F S IFN=$O(^PS(51.1,"APLR",X,IFN)) Q:IFN'>0 D Q:$G(DONE) - .. W !," "_X S CNT=CNT+1 Q:CNT'>(IOSL-5) S CNT=0 - .. W !," '^' TO STOP: " R Z:DTIME S:'$T!(Z["^") DONE=1 - W ! - K ^TMP($J,"ORSCLR XSCH") - Q - ; -MULT(ORIFN,CTYPE,CDATE) ;check multiple orders from VALID^ORCDLR1 - N KID,OREVENT,ORSTRT,OK,X,Y,%DT - I '$D(CTYPE) S CTYPE=$$VALUE^ORCSAVE2(ORIFN,"COLLECT") - Q:"SPWC"[CTYPE 0 ; only check LC and I - I '$D(CDATE) S CDATE=$$VALUE^ORCSAVE2(ORIFN,"START") - D AM^ORCSAVE2:CDATE="AM",NEXT^ORCSAVE2:CDATE="NEXT" ; returns X - S %DT="T" S:'$D(X) X=CDATE D ^%DT I Y<1 Q 0 - D SCHEDULE^ORCSEND1(ORIFN,"LR",.ORSTRT,Y) Q:ORSTRT'>1 0 ; get all starts - S KID=0,OK=1 F S KID=$O(ORSTRT(KID)) Q:'KID!('OK) D - . I CTYPE="LC" S OK=$$LABCOLL^ORCDLR1(KID) Q - . S OK=$$IMMCOLL^ORCDLR1(KID) - I OK Q 0 - Q "1^One or more of the multiple orders will be changed to Ward Collect" +ORCDLR ;SLC/MKB-Utility functions for LR dialogs ;6/11/97 11:47 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,29,49,61,71,79,175**;Dec 17, 1997 +TEST ; -- Setup ORTEST() array of ordering parameters + N OI,TST,WRD,I,DG + S OI=+$G(ORDIALOG(PROMPT,INST)) Q:'OI + I '$D(ORTEST) S TST=+$P($G(^ORD(101.43,OI,0)),U,2) D TEST^LR7OR3(TST,.ORTEST) S ORTEST=TST + S WRD="GenWardInstructions" I $O(ORTEST(WRD,0)) D W ! + . W ! S I=0 F S I=$O(ORTEST(WRD,I)) Q:I'>0 W !,ORTEST(WRD,I,0) + S DG=$P($G(^ORD(101.43,+OI,"LR")),U,6) S:'$L(DG) DG="LAB" + S DG=$O(^ORD(100.98,"B",DG,0)) S:DG ORDG=DG + Q + ; +CKTYP ; -- ck type of test [Exit Action] + N X,Y S X=$G(ORDIALOG(PROMPT,INST)) Q:'X + S Y=$P($G(^ORD(101.43,+X,"LR")),U,7) + I (Y="O")!(Y="N") W $C(7),!,"This test may not be ordered anymore. Please select another test." S ORQUIT=1 D WAIT Q + Q + ; +WAIT ; -- Wait for user + N X W !,"Press to continue ..." R X:DTIME + Q + ; +SHOWMAX ; -- Setup max days allowed for cont orders + I $S('$G(ORSCH):1,"CD"'[$P($G(^PS(51.1,+ORSCH,0)),U,5):1,1:0) K ORDIALOG(PROMPT,INST) Q ;just in case + N Y,OK S ORSMAX=$P($G(^PS(51.1,ORSCH,0)),U,7),ORSTMS=$P($G(^(0)),U,3) + S ORSMAX=$S('$G(ORSMAX):ORMAX,$G(ORTYPE)="Z":ORSMAX,ORMAXORSMAX:1,1:"0^Cannot order more than "_ORSMAX_" days in advance.") G CKQ + I (X'?1"X"1.N),(X'?1"x"1.N) S Y="0^Enter either a number of days or X_number of times." G CKQ + I ORSTMS,+$E(X,2,9)>ORSTMS S Y="0^Cannot order more than "_ORSTMS_" time* s." G CKQ + I 'ORSTMS,+$E(X,2,9)>ORSMAX S Y="0^Cannot order for more than "_ORSMAX_" days." G CKQ ; day of week schedule + S Y=1 +CKQ Q Y + ; +SAMPLE() ; -- Get default sample from Test for INST + N X,Y I $L($G(LRFSAMP)) Q LRFSAMP + I (ORCOLLCT="LC")!(ORCOLLCT="I") S X=$G(ORTEST("Lab CollSamp")) G SAMPQ + S X=$G(ORTEST("Unique CollSamp")) G:X SAMPQ + S X=$G(ORTEST("Default CollSamp")) +SAMPQ S Y=+$G(ORTEST("CollSamp",+X)) + Q Y + ; +ENSAMP ; -- Get list of samples to pick from + Q:$G(ORDIALOG(PROMPT,"LIST")) N I,CNT,X,Y S (I,CNT)=0 + F S I=$O(ORTEST("CollSamp",I)) Q:I'>0 S X=$G(ORTEST("CollSamp",I)) D + . S Y=$P(X,U,1,2)_" "_$$GET1^DIQ(61,+$P(X,U,3)_",",.01)_" "_$P(X,U,4) + . S CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=Y + . S ORDIALOG(PROMPT,"LIST","B",$P(X,U,2))=+X + S:CNT ORDIALOG(PROMPT,"LIST")=CNT_$S($$SECTION'="MI":"^1",1:"") + Q + ; +ASKSAMP() ; -- Ask for Collection Sample? + N X,Y,DIR,DEFSAMP,SAMP0 + S DEFSAMP=$G(ORDIALOG(PROMPT,INST)),SAMP0=$G(^LAB(62,+DEFSAMP,0)) + I $G(ORTYPE)="Z",DEFSAMP Q 1 + I (ORCOLLCT="LC")!(ORCOLLCT="I"),$G(ORTEST("Lab CollSamp")) W !!,"Lab will collect "_$P(SAMP0,U)_" "_$P(SAMP0,U,3)_".",! Q 0 + I $G(ORTEST("Unique CollSamp")),DEFSAMP Q 0 ; unique -> don't ask + I 'DEFSAMP!('FIRST) Q 1 ; no default or edit -> ask + I $G(ORDIALOG(PROMPT,"LIST"))="1^1" Q 0 ; only one choice + S DIR(0)="YA",DIR("A")="Is "_$P(SAMP0,U)_" "_$P(SAMP0,U,3)_" the correct sample to collect? ",DIR("B")="Yes" + D ^DIR I $D(DTOUT)!$D(DUOUT) S ORQUIT=1 Q 0 + D:'Y LIST^ORCD + Q 'Y + ; +SECTION() ; -- Returns Lab section of Orderable Item + N PTR,X + S PTR=$O(^ORD(101.41,"AB","OR GTX ORDERABLE ITEM",0)) + S X=$P($G(^ORD(101.43,+$G(ORDIALOG(PTR,1)),"LR")),U,6) + Q X + ; +SHOWCOMM(SAMP) ; -- Show comments for sample + Q:'$G(SAMP) Q:'$G(ORTEST) N ORCOMM,I + D SCOM^LR7OR3(+ORTEST,SAMP,.ORCOMM) + S I=0 F S I=$O(ORCOMM(I)) Q:I'>0 W !,ORCOMM(I,0) + Q + ; +SPECIMEN() ; -- Get default specimen from Sample for INST + N X,Y I $L($G(LRFSPEC)) S Y=LRFSPEC + E S X=$$VAL^ORCD("COLLECTION SAMPLE"),Y=+$P($G(^LAB(62,+X,0)),U,2) + Q Y + ; +SPECHELP ; -- Xecutable help for Specimen prompt + I '$D(^LAB(61,"E")) D P^ORCDLGH Q + W !,"Choose from: " + N SP,I,DONE,CNT S (CNT,DONE)=0,SP="" + F S SP=$O(^LAB(61,"E",SP)) Q:SP="" S I=+$O(^(SP,0)) I I D + . S CNT=CNT+1 I CNT>(IOSL-2) S CNT=0 I '$$MORE^ORCD S DONE=1 Q + . W !," "_$P($G(^LAB(61,I,0)),U) + Q + ; +URGENCY ; -- Get list of urgencies to pick from + Q:$D(ORDIALOG(PROMPT,"LIST")) N I,J,X + I $G(ORTEST("Default Urgency")) S ORDIALOG(PROMPT,"LIST")="1^1",ORDIALOG(PROMPT,"LIST",1)=ORTEST("Default Urgency") Q ; Forced Urgency + I '$D(ORTEST("Urgencies")) S ORDIALOG(PROMPT,"LIST")="0^1" Q + S (I,J)=0 F S I=$O(ORTEST("Urgencies",I)) Q:I'>0 D + . S X=ORTEST("Urgencies",I) I $G(ORCOLLCT)="LC",'$P($G(^LAB(62.05,+X,0)),U,2) Q ; Lab cannot collect + . S J=J+1,ORDIALOG(PROMPT,"LIST",J)=X,ORDIALOG(PROMPT,"LIST","B",$P(X,U,2))=+X + S ORDIALOG(PROMPT,"LIST")=J_"^1" + Q + ; +ASKURG() ; -- Ask urgency prompt? + I $G(ORTEST("Default Urgency")) Q 0 ; Forced Urgency + I FIRST,$G(ORL) Q $$GET^XPAR("ALL^"_ORL,"LR ASK URGENCY") + Q (+$G(ORDIALOG(PROMPT,"LIST"))>1) + ; +REQDCOMM() ; -- Process required comments + I $O(^TMP("ORWORD",$J,PROMPT,INST,0)) Q 0 ;edit as WP + N LRTEST,LRSAMP,LRSPEC,LRTSTN,LRTCOM,LRCCOM,DA,CNT,I,REQDCOMM + S LRSAMP=$$VAL^ORCD("COLLECTION SAMPLE"),LRSPEC=$$VAL^ORCD("SPECIMEN") + S LRTSTN=1,LRTEST(1)=+ORTEST,DA=$O(^LAB(60,LRTEST(1),3,"B",+LRSAMP,0)) + S REQDCOMM=$P($G(^LAB(60,LRTEST(1),3,+DA,0)),U,6) + S:'REQDCOMM REQDCOMM=+$P($G(^LAB(60,LRTEST(1),0)),U,19) Q:'REQDCOMM 1 + I $G(ORTYPE)="Z",$P($G(^LAB(62.07,+REQDCOMM,0)),U)'="ORDER COMMENT" Q 1 + X:$D(^LAB(62.07,REQDCOMM,.1)) ^(.1) + S (CNT,I)=0 K REQDCOMM + F S I=$O(LRTCOM(LRTEST(1),I)) Q:I'>0 S CNT=CNT+1,REQDCOMM(CNT,0)=LRTCOM(LRTEST(1),I) + S:$L($G(LRCCOM)) CNT=CNT+1,REQDCOMM(CNT,0)=LRCCOM + I CNT S REQDCOMM(0)="^^"_CNT_U_CNT_U_DT_U_U,ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"",$J,"_PROMPT_","_INST_")" M ^TMP("ORWORD",$J,PROMPT,INST)=REQDCOMM +RQ Q 1 + ; +XHELP(PTR) ; -- Xecutable help + I $D(ORDIALOG(PTR,"LIST")),X="?"!$P(ORDIALOG(PTR,"LIST"),U,2) D LIST^ORCD Q + D P^ORCDLGH ; ??-help + Q + ; +CHANGED(FLD) ; -- Kill dependent values when FLD changes + N PROMPTS,P,NAME,PTR K ORCOLLCT + S PROMPTS="COLLECTION SAMPLE^SPECIMEN^WORD PROCESSING 1^START DATE/TIME" + S:FLD="OI" PROMPTS="COLLECTION TYPE^"_PROMPTS_"^LAB URGENCY" + F P=1:1:$L(PROMPTS,U) S NAME=$P(PROMPTS,U,P),PTR=$O(^ORD(101.41,"AB","OR GTX "_NAME,0)) I PTR K ORDIALOG(PTR,ORI),ORDIALOG(PTR,"LIST") + Q + ; +LB(ORDER) ; -- Returns 1 or 0, if "LB #" is already in text + N I,Y S I=0,Y=0 + F S I=$O(^OR(100,+ORDER,1,I)) Q:I'>0 I $G(^(I,0))["LB #" S Y=1 Q + Q Y + ; +DATE(X) ; Free text input to FM time + N %DT,Y + D ^%DT + Q Y + ; +XSCH ; -- xecutable help for schedule prompt + N X,IFN,CNT,Z,DONE + W !!,"Choose from:" S CNT=1 + S X="" F S X=$O(^PS(51.1,"APLR",X)) Q:X="" S IFN=0 D Q:$G(DONE) + . F S IFN=$O(^PS(51.1,"APLR",X,IFN)) Q:IFN'>0 D Q:$G(DONE) + .. W !," "_X S CNT=CNT+1 Q:CNT'>(IOSL-5) S CNT=0 + .. W !," '^' TO STOP: " R Z:DTIME S:'$T!(Z["^") DONE=1 + W ! + Q + ; +MULT(ORIFN,CTYPE,CDATE) ;check multiple orders from VALID^ORCDLR1 + N KID,OREVENT,ORSTRT,OK,X,Y,%DT + I '$D(CTYPE) S CTYPE=$$VALUE^ORCSAVE2(ORIFN,"COLLECT") + Q:"SPWC"[CTYPE 0 ; only check LC and I + I '$D(CDATE) S CDATE=$$VALUE^ORCSAVE2(ORIFN,"START") + D AM^ORCSAVE2:CDATE="AM",NEXT^ORCSAVE2:CDATE="NEXT" ; returns X + S %DT="T" S:'$D(X) X=CDATE D ^%DT I Y<1 Q 0 + D SCHEDULE^ORCSEND1(ORIFN,"LR",.ORSTRT,Y) Q:ORSTRT'>1 0 ; get all starts + S KID=0,OK=1 F S KID=$O(ORSTRT(KID)) Q:'KID!('OK) D + . I CTYPE="LC" S OK=$$LABCOLL^ORCDLR1(KID) Q + . S OK=$$IMMCOLL^ORCDLR1(KID) + I OK Q 0 + Q "1^One or more of the multiple orders will be changed to Ward Collect" diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDLR1.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDLR1.m index d0b4da3e..15c543f9 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDLR1.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDLR1.m @@ -1,187 +1,186 @@ -ORCDLR1 ;SLC/MKB,JFR - Utility fcns for LR dialogs cont ;8/29/02 14:45 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,29,49,61,79,141,143,243**;Dec 17, 1997;Build 242 - ; -EN ; -- Entry Action for LR OTHER LAB TESTS order dialog - D GETIMES S ORMAX=0 - S:$G(ORL) ORMAX=$$GET^XPAR("LOC.`"_+ORL,"LR MAX DAYS CONTINUOUS",1,"Q") - Q - ; -EX ; -- Exit Action for order dialog - K ORTIME,ORCOLLCT,ORMAX,ORTEST,ORDIV,ORIMTIME,ORSMAX,ORSTMS,ORSCH,ORCAT - I $G(ORXL) S ORL=ORXL K ORXL - Q - ; -GETIMES ; -- Set list of routine collections into ORTIME($H)=FMtime - N I,X,CNT,ON K ORTIME - I '$D(VALIDT) D - . S I=$$PTR^ORCD("OR GTX START DATE/TIME"),X=$P(ORDIALOG(I,0),U,2) - . S X="T::ETX",$P(ORDIALOG(I,0),U,2)=X ; reset lower bound - S ORDIV=+$P($G(^SC(+$G(ORL),0)),U,4) S:'ORDIV ORDIV=+$G(DUZ(2)) - I $G(OREVENT) S ORDIV=+$$DIV^OREVNTX(OREVENT),ORXL=$G(ORL),ORL=$$LOC^OREVNTX(OREVENT) - D GETLST^XPAR(.ORTIME,ORDIV_";DIC(4,","LR PHLEBOTOMY COLLECTION","N") - S (I,CNT)=0 F S I=$O(ORTIME(I)) Q:I'>0 S CNT=CNT+1,X=$P(ORTIME(I),U),ORTIME(I)=X,ORTIME("B",+("."_X))=I ; ORTIME($H time)=0000 FM time, ORTIME("B",.0000)=$H time of cut-off - S ORTIME=CNT,I=$O(ORTIME(0)) S:I ORTIME("AM")=ORTIME(I) ; 1st collection - S I=$O(ORTIME($P($H,",",2))) S:I ORTIME("NEXT")=ORTIME(I) ;NEXT coll - S ON=$$ON^LR7OV4(ORDIV) D:ON SHOW^LR7OV4(ORDIV,.ORIMTIME) - I 'ON,'$D(VALIDT) S I=$$PTR^ORCD("OR GTX COLLECTION TYPE"),X=$P(ORDIALOG(I,0),U,2),$P(ORDIALOG(I,0),U,2)=$P(X,";",1,3) ;Remove Immed if '$$ON - Q - ; -DEFTIME() ; -- Returns default collection time - I $L($G(LRFDATE)) S EDITONLY=1 Q LRFDATE - I '$D(ORCOLLCT) Q "" - N Y S Y="" I $D(^TMP("ORECALL",$J,ORDIALOG,PROMPT)) D Q:$L(Y) Y - . S Y=$$RECALL^ORCD(PROMPT) - . I '$S(ORCOLLCT="LC":$$LABCOLL(Y),ORCOLLCT="I":$$IMMCOLL(Y),1:$$CKDATE(Y)) S Y="" Q - . S EDITONLY=1 - ;I $G(ORTYPE)="Q" Q $S(ORCOLLCT="LC":"AM",1:"") - D LIST^ORCD:ORCOLLCT="LC"&$G(ORDIALOG(PROMPT,"LIST")) - D IMMTIMES:ORCOLLCT="I"&$O(ORIMTIME(0)) - Q $S(ORCOLLCT="LC":"NEXT",ORCOLLCT="I":$$IMMDEF,ORCOLLCT="WC":"NOW",1:"TODAY") - ; -IMMDEF() ; -- Returns immediate collect default - N X,Y S X=$$DEFTIME^LR7OV4(ORDIV) - S Y=$S($P(X,U,3):"NOW+"_$P(X,U,3)_"'",1:$P(X,U)) - Q Y - ; -COLLTIME ; -- Get list of common collection times - I ORCOLLCT="I" D:'$D(ORIMTIME) SHOW^LR7OV4(ORDIV,.ORIMTIME) - I ORCOLLCT'="LC" K ORDIALOG(PROMPT,"LIST") Q - Q:$G(ORDIALOG(PROMPT,"LIST")) Q:'$O(ORTIME(0)) - N I,X,CNT,NEXT,DAY,NOW S NOW=$P($H,",",2) - S NEXT=$O(ORTIME(NOW)),DAY=$$NEXTCOLL($S(NEXT:"T",1:"T+1")) Q:DAY="" - S:'NEXT!(DAY["+") NEXT=$O(ORTIME(0)) - S CNT=1,ORDIALOG(PROMPT,"LIST",1)="NEXT^NEXT Lab collection ("_DAY_"@"_$$TIME(ORTIME(NEXT))_")",ORDIALOG(PROMPT,"LIST","B","NEXT LAB COLLECTION")="NEXT" - S ORDIALOG(PROMPT,"LIST","B","AM LAB COLLECTION")="AM" - G:ORTIME'>1 CTMQ ; only NEXT - S I=NEXT F S I=$O(ORTIME(I)) Q:I'>0 S X=DAY_"@"_$$TIME(ORTIME(I)),CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=X_"^Routine Lab collection ("_X_")",ORDIALOG(PROMPT,"LIST","B","ROUTINE LAB COLLECTION")=X - I NEXT>$O(ORTIME(0)) D ;add morning times before NEXT to T+1 - . S DAY="T+"_(+$P(DAY,"+",2)+1),DAY=$$NEXTCOLL(DAY),I=$O(ORTIME(0)) - . S X=DAY_"@"_$$TIME(ORTIME("AM")),CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)="AM^AM Lab collection ("_X_")" - . F S I=$O(ORTIME(I)) Q:(I'>0)!(I'0 K X Q - . I $G(ORL),$$GET^XPAR("ALL^LOC.`"_+ORL,"LR EXCEPTED LOCATIONS") Q - . S PARAM="LR COLLECT "_$$UP^XLFSTR($$DOW^XLFDT(Y)) - . I '$$GET^XPAR("ALL",PARAM) K X Q - . I '$$GET^XPAR("ALL","LR IGNORE HOLIDAYS"),$D(^HOLIDAY($P(Y,"."))) K X Q - S Y=$S($D(X):X,1:"") - Q Y - ; -TIME(X) ; -- Returns 00:00AM from 0000 FileMan time - N HOUR,MIN,XM,Y - S HOUR=$E(X,1,2),MIN=$E(X,3,4),XM="AM" - I HOUR'<12 S XM="PM" S:HOUR>12 HOUR=HOUR-12 - S:$E(HOUR)="0" HOUR=$E(HOUR,2) ; strip leading 0 - S Y=HOUR_":"_MIN_XM - Q Y - ; -LISTCOLL ; -- Lists the routine collection times for ??-help - I '$O(ORTIME(0)) W !,"No routine lab collection times defined." Q - N I,X S I=0,X="" - F S I=$O(ORTIME(I)) Q:I'>0 S X=X_$S($L(X):", ",1:"")_$$TIME(ORTIME(I)) - W !,"Routine collection times are "_X_"." - W !,"You may also enter AM for the morning collection, or NEXT for the next",!,"routine collection time." - Q - ; -IMMTIMES ; -- Show the valid date/times for immediate collect - N I S I=0 - F S I=$O(ORIMTIME(I)) Q:I'>0 W !,ORIMTIME(I) - Q - ; -CKDATE(X) ; -- Valid coll time for SP or WC? - S X=$$UP^XLFSTR(X) I ("NOW"[X)!("TODAY"[X) Q 1 - I X?1"T+"1.3N,+$P(X,"+",2)'>370 Q 1 - N Y,%DT,D - I X'?7N.1".".6N S %DT="TX" D ^%DT S:Y>0 X=Y I Y'>0 Q "0^Invalid date/time" - S D=$P(X,".") I D
$$FMADD^XLFDT(DT,370) Q "0^Cannot order more than 370 days in advance" - Q 1 - ; -IMMCOLL(X) ; -- Valid immediate collection date/time? - I X?1"NOW+"1.N1"'" Q 1 - I X'?7N.1".".6N N Y,%DT S %DT="T" D ^%DT S:Y>0 X=Y I Y'>0 Q "0^Invalid date/time" - Q $$VALID^LR7OV4(ORDIV,X) - ; -LABCOLL(ORXTIM) ; -- Valid lab collection date/time? - ; Returns valid flag of 1 or 0^message - N I,X,Y,%DT,ORD,ORT,PARAM,ORDY - I '$O(ORTIME(0)) Q "0^There are no lab collection times defined!" - I (ORXTIM="AM")!(ORXTIM="NEXT") Q 1 - I ORXTIM'?7N.1".".6N S %DT="T",X=ORXTIM D ^%DT S:Y>0 ORXTIM=Y I Y'>0 Q "0^Invalid date/time" - ;I ORXTIM?1"V".E S T="."_$P(ORXTIM,"@",2) G D1 ; Visit - ignore day (D ^%DT ??) - S ORD=$P(ORXTIM,"."),ORT="."_$P(ORXTIM,".",2) - S:ORT="." ORT=+("."_$G(ORTIME("AM"))) - I '$D(ORTIME("B",ORT)) Q "0^Invalid lab collection time" -LC1 ; -- check date - I ORD
ORTIME("B",ORT) Q "0^The cut-off time for this collection has passed" - S ORDY=7 I $D(^XTV(8989.51,"B","LR LAB COLLECT FUTURE")),$G(ORL) S ORDY=+$$GET^XPAR("ALL^DIV.`"_ORDIV_"^LOC.`"_+ORL,"LR LAB COLLECT FUTURE",1,"I") - I ORXTIM>$$FMADD^XLFDT($$NOW^XLFDT,ORDY) Q "0^Cannot order a lab collection more than "_ORDY_" days in advance" - I $G(ORL),$$GET^XPAR("ALL^LOC.`"_+ORL,"LR EXCEPTED LOCATIONS") Q 1 - S PARAM="LR COLLECT "_$$UP^XLFSTR($$DOW^XLFDT(ORD)) - I $G(ORTYPE)'="Z",'$$GET^XPAR("ALL",PARAM) Q "0^There are no lab collections that day" - I $G(ORTYPE)'="Z",'$$GET^XPAR("ALL","LR IGNORE HOLIDAYS"),$D(^HOLIDAY(ORD)) Q "0^There are no lab collections on holidays" - Q 1 - ; -LABSAMP() ; -- Lab Collect sample? - N X,Y S X=+$$VAL^ORCD("COLLECTION SAMPLE"),Y=$P($G(^LAB(62,X,0)),U,7) - Q Y - ; -COLLTYPE() ; -- Returns default collection type - N Y I $G(ORTYPE)="Z" S Y="" G CTQ - I $L($G(LRFZX)) S Y=LRFZX,EDITONLY=1 G CTQ - I $D(^TMP("ORECALL",$J,+ORDIALOG,PROMPT)) D G CTQ - . S Y=$$RECALL^ORCD(PROMPT),EDITONLY=1 - S:$G(ORL) Y=$$GET^XPAR("ALL^"_ORL,"LR DEFAULT TYPE QUICK") - I '$L($G(Y)) S Y=$S('$$INPT^ORCD:"SP",$G(ORTYPE)="Q":"LC",1:"WC") -CTQ I Y="I",'$O(ORIMTIME(0))!('$G(ORTEST("Lab CollSamp"))) S Y="WC" - I Y="LC",'$O(ORTIME(0))!('$G(ORTEST("Lab CollSamp"))) S Y="WC" - ;S:$G(ORTYPE)="Q" EDITONLY=1 - I '(FIRST&EDITONLY) D HELPTYPE - Q Y - ; -CKTYPE ; -- Valid type for time, sample? - I Y="LC",'$O(ORTIME(0)) W $C(7),!,"There are no lab collection times defined!" K DONE Q - I Y="I",'$O(ORIMTIME(0)) W $C(7),!,"There are no immediate collection times defined!" K DONE Q - I (Y="LC"!(Y="I")),'$G(ORTEST("Lab CollSamp")) W $C(7),!,"There is no lab collection sample defined for this test!",! K DONE Q - I $D(ORESET),ORESET'=Y,("ILC"[ORESET)!("ILC"[Y) D CHANGED^ORCDLR("TYPE") K ORDIALOG($$PTR^ORCD("OR GTX LAB URGENCY"),"LIST") - Q - ; -HELPTYPE ; -- Xecutable help for Coll Type - W !!,"SEND TO LAB - Means the patient is ambulatory and will be sent to the",!,"Laboratory draw room to have blood drawn." - W !,"WARD COLLECT - Means that either the physician or a nurse will be collecting",!,"the sample on the ward." - W !,"LAB BLOOD TEAM - Means the phlebotomist from Lab will draw the blood on the",!,"ward. This method is limited to laboratory defined collection times." - W:$$ON^LR7OV4(ORDIV) !,"IMMEDIATE COLLECT BY BLOOD TEAM - Means the phlebotomist from Lab is on",!,"call to draw blood on the ward. This method is available during times",!,"defined by Laboratory." W ! - N DOMAIN S DOMAIN=$P(ORDIALOG(PROMPT,0),U,2) D SETLST1^ORCD - Q -VALID(ORDER) ;check collection time on release - N VALIDT,OREVENT,COLLTYPE,COLLDT,OK,ORDIV,ORTXT,ORPTLK,ORTIME,ORIMTIME,ORACT - S VALIDT="" D GETIMES - S COLLDT=$$VALUE^ORCSAVE2(ORDER,"START") - S COLLTYPE=$$VALUE^ORCSAVE2(ORDER,"COLLECT") - I $L($P(^OR(100,+ORIFN,0),U,17)) S OREVENT=$P(^(0),U,17) - I "NOWAMNEXT"[COLLDT D:'$G(OREVENT) MULT Q 1 ;OK - S OK=$S(COLLTYPE="LC":$$LABCOLL(COLLDT),COLLTYPE="I":$$IMMCOLL(COLLDT),1:$$CKDATE(COLLDT)) - I OK D:'$G(OREVENT) MULT Q 1 ;COLLDT passed checks - W !!,$C(7),$P(OK,U,2) - D TEXT^ORQ12(.ORTXT,ORDER) W !,$G(ORTXT(1)) K ORTXT - W !,"must be edited before signing/release." K VALIDT D - . N ORDIV,ORIMTIME,ORTIME,ORNP - . S ORNP=$P(^OR(100,ORDER,0),U,4) - . S ORACT="XX" D XX^ORCACT4 ;edit order - I $$VALUE^ORCSAVE2(ORDER,"START")'=COLLDT D:'$G(OREVENT) MULT Q 1 ;OK - Q 0 - ; -MULT ; -- ck child orders - N CHGD S CHGD=$$MULT^ORCDLR(ORDER,COLLTYPE,COLLDT) Q:'CHGD - W !!,$P(CHGD,U,2) H 2 - Q +ORCDLR1 ;SLC/MKB,JFR - Utility fcns for LR dialogs cont ;8/29/02 14:45 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,29,49,61,79,141**;Dec 17, 1997 + ; +EN ; -- Entry Action for LR OTHER LAB TESTS order dialog + D GETIMES S ORMAX=0 + S:$G(ORL) ORMAX=$$GET^XPAR("LOC.`"_+ORL,"LR MAX DAYS CONTINUOUS",1,"Q") + Q + ; +EX ; -- Exit Action for order dialog + K ORTIME,ORCOLLCT,ORMAX,ORTEST,ORDIV,ORIMTIME,ORSMAX,ORSTMS,ORSCH,ORCAT + I $G(ORXL) S ORL=ORXL K ORXL + Q + ; +GETIMES ; -- Set list of routine collections into ORTIME($H)=FMtime + N I,X,CNT,ON K ORTIME + I '$D(VALIDT) D + . S I=$$PTR^ORCD("OR GTX START DATE/TIME"),X=$P(ORDIALOG(I,0),U,2) + . S X="T::ETX",$P(ORDIALOG(I,0),U,2)=X ; reset lower bound + S ORDIV=+$P($G(^SC(+$G(ORL),0)),U,4) S:'ORDIV ORDIV=+$G(DUZ(2)) + I $G(OREVENT) S ORDIV=+$$DIV^OREVNTX(OREVENT),ORXL=$G(ORL),ORL=$$LOC^OREVNTX(OREVENT) + D GETLST^XPAR(.ORTIME,ORDIV_";DIC(4,","LR PHLEBOTOMY COLLECTION","N") + S (I,CNT)=0 F S I=$O(ORTIME(I)) Q:I'>0 S CNT=CNT+1,X=$P(ORTIME(I),U),ORTIME(I)=X,ORTIME("B",+("."_X))=I ; ORTIME($H time)=0000 FM time, ORTIME("B",.0000)=$H time of cut-off + S ORTIME=CNT,I=$O(ORTIME(0)) S:I ORTIME("AM")=ORTIME(I) ; 1st collection + S I=$O(ORTIME($P($H,",",2))) S:I ORTIME("NEXT")=ORTIME(I) ;NEXT coll + S ON=$$ON^LR7OV4(ORDIV) D:ON SHOW^LR7OV4(ORDIV,.ORIMTIME) + I 'ON,'$D(VALIDT) S I=$$PTR^ORCD("OR GTX COLLECTION TYPE"),X=$P(ORDIALOG(I,0),U,2),$P(ORDIALOG(I,0),U,2)=$P(X,";",1,3) ;Remove Immed if '$$ON + Q + ; +DEFTIME() ; -- Returns default collection time + I $L($G(LRFDATE)) S EDITONLY=1 Q LRFDATE + N Y S Y="" I $D(^TMP("ORECALL",$J,ORDIALOG,PROMPT)) D Q:$L(Y) Y + . S Y=$$RECALL^ORCD(PROMPT) + . I '$S(ORCOLLCT="LC":$$LABCOLL(Y),ORCOLLCT="I":$$IMMCOLL(Y),1:$$CKDATE(Y)) S Y="" Q + . S EDITONLY=1 + ;I $G(ORTYPE)="Q" Q $S(ORCOLLCT="LC":"AM",1:"") + D LIST^ORCD:ORCOLLCT="LC"&$G(ORDIALOG(PROMPT,"LIST")) + D IMMTIMES:ORCOLLCT="I"&$O(ORIMTIME(0)) + Q $S(ORCOLLCT="LC":"NEXT",ORCOLLCT="I":$$IMMDEF,ORCOLLCT="WC":"NOW",1:"TODAY") + ; +IMMDEF() ; -- Returns immediate collect default + N X,Y S X=$$DEFTIME^LR7OV4(ORDIV) + S Y=$S($P(X,U,3):"NOW+"_$P(X,U,3)_"'",1:$P(X,U)) + Q Y + ; +COLLTIME ; -- Get list of common collection times + I ORCOLLCT="I" D:'$D(ORIMTIME) SHOW^LR7OV4(ORDIV,.ORIMTIME) + I ORCOLLCT'="LC" K ORDIALOG(PROMPT,"LIST") Q + Q:$G(ORDIALOG(PROMPT,"LIST")) Q:'$O(ORTIME(0)) + N I,X,CNT,NEXT,DAY,NOW S NOW=$P($H,",",2) + S NEXT=$O(ORTIME(NOW)),DAY=$$NEXTCOLL($S(NEXT:"T",1:"T+1")) Q:DAY="" + S:'NEXT!(DAY["+") NEXT=$O(ORTIME(0)) + S CNT=1,ORDIALOG(PROMPT,"LIST",1)="NEXT^NEXT Lab collection ("_DAY_"@"_$$TIME(ORTIME(NEXT))_")",ORDIALOG(PROMPT,"LIST","B","NEXT LAB COLLECTION")="NEXT" + S ORDIALOG(PROMPT,"LIST","B","AM LAB COLLECTION")="AM" + G:ORTIME'>1 CTMQ ; only NEXT + S I=NEXT F S I=$O(ORTIME(I)) Q:I'>0 S X=DAY_"@"_$$TIME(ORTIME(I)),CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=X_"^Routine Lab collection ("_X_")",ORDIALOG(PROMPT,"LIST","B","ROUTINE LAB COLLECTION")=X + I NEXT>$O(ORTIME(0)) D ;add morning times before NEXT to T+1 + . S DAY="T+"_(+$P(DAY,"+",2)+1),DAY=$$NEXTCOLL(DAY),I=$O(ORTIME(0)) + . S X=DAY_"@"_$$TIME(ORTIME("AM")),CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)="AM^AM Lab collection ("_X_")" + . F S I=$O(ORTIME(I)) Q:(I'>0)!(I'0 K X Q + . I $G(ORL),$$GET^XPAR("ALL^LOC.`"_+ORL,"LR EXCEPTED LOCATIONS") Q + . S PARAM="LR COLLECT "_$$UP^XLFSTR($$DOW^XLFDT(Y)) + . I '$$GET^XPAR("ALL",PARAM) K X Q + . I '$$GET^XPAR("ALL","LR IGNORE HOLIDAYS"),$D(^HOLIDAY($P(Y,"."))) K X Q + S Y=$S($D(X):X,1:"") + Q Y + ; +TIME(X) ; -- Returns 00:00AM from 0000 FileMan time + N HOUR,MIN,XM,Y + S HOUR=$E(X,1,2),MIN=$E(X,3,4),XM="AM" + I HOUR'<12 S XM="PM" S:HOUR>12 HOUR=HOUR-12 + S:$E(HOUR)="0" HOUR=$E(HOUR,2) ; strip leading 0 + S Y=HOUR_":"_MIN_XM + Q Y + ; +LISTCOLL ; -- Lists the routine collection times for ??-help + I '$O(ORTIME(0)) W !,"No routine lab collection times defined." Q + N I,X S I=0,X="" + F S I=$O(ORTIME(I)) Q:I'>0 S X=X_$S($L(X):", ",1:"")_$$TIME(ORTIME(I)) + W !,"Routine collection times are "_X_"." + W !,"You may also enter AM for the morning collection, or NEXT for the next",!,"routine collection time." + Q + ; +IMMTIMES ; -- Show the valid date/times for immediate collect + N I S I=0 + F S I=$O(ORIMTIME(I)) Q:I'>0 W !,ORIMTIME(I) + Q + ; +CKDATE(X) ; -- Valid coll time for SP or WC? + S X=$$UP^XLFSTR(X) I ("NOW"[X)!("TODAY"[X) Q 1 + I X?1"T+"1.3N,+$P(X,"+",2)'>370 Q 1 + N Y,%DT,D + I X'?7N.1".".6N S %DT="TX" D ^%DT S:Y>0 X=Y I Y'>0 Q "0^Invalid date/time" + S D=$P(X,".") I D
$$FMADD^XLFDT(DT,370) Q "0^Cannot order more than 370 days in advance" + Q 1 + ; +IMMCOLL(X) ; -- Valid immediate collection date/time? + I X?1"NOW+"1.N1"'" Q 1 + I X'?7N.1".".6N N Y,%DT S %DT="T" D ^%DT S:Y>0 X=Y I Y'>0 Q "0^Invalid date/time" + Q $$VALID^LR7OV4(ORDIV,X) + ; +LABCOLL(ORXTIM) ; -- Valid lab collection date/time? + ; Returns valid flag of 1 or 0^message + N I,X,Y,%DT,ORD,ORT,PARAM,ORDY + I '$O(ORTIME(0)) Q "0^There are no lab collection times defined!" + I (ORXTIM="AM")!(ORXTIM="NEXT") Q 1 + I ORXTIM'?7N.1".".6N S %DT="T",X=ORXTIM D ^%DT S:Y>0 ORXTIM=Y I Y'>0 Q "0^Invalid date/time" + ;I ORXTIM?1"V".E S T="."_$P(ORXTIM,"@",2) G D1 ; Visit - ignore day (D ^%DT ??) + S ORD=$P(ORXTIM,"."),ORT="."_$P(ORXTIM,".",2) + S:ORT="." ORT=+("."_$G(ORTIME("AM"))) + I '$D(ORTIME("B",ORT)) Q "0^Invalid lab collection time" +LC1 ; -- check date + I ORD
ORTIME("B",ORT) Q "0^The cut-off time for this collection has passed" + S ORDY=7 I $D(^XTV(8989.51,"B","LR LAB COLLECT FUTURE")),$G(ORL) S ORDY=+$$GET^XPAR("ALL^DIV.`"_ORDIV_"^LOC.`"_+ORL,"LR LAB COLLECT FUTURE",1,"I") + I ORXTIM>$$FMADD^XLFDT($$NOW^XLFDT,ORDY) Q "0^Cannot order a lab collection more than "_ORDY_" days in advance" + I $G(ORL),$$GET^XPAR("ALL^LOC.`"_+ORL,"LR EXCEPTED LOCATIONS") Q 1 + S PARAM="LR COLLECT "_$$UP^XLFSTR($$DOW^XLFDT(ORD)) + I $G(ORTYPE)'="Z",'$$GET^XPAR("ALL",PARAM) Q "0^There are no lab collections that day" + I $G(ORTYPE)'="Z",'$$GET^XPAR("ALL","LR IGNORE HOLIDAYS"),$D(^HOLIDAY(ORD)) Q "0^There are no lab collections on holidays" + Q 1 + ; +LABSAMP() ; -- Lab Collect sample? + N X,Y S X=+$$VAL^ORCD("COLLECTION SAMPLE"),Y=$P($G(^LAB(62,X,0)),U,7) + Q Y + ; +COLLTYPE() ; -- Returns default collection type + N Y I $G(ORTYPE)="Z" S Y="" G CTQ + I $L($G(LRFZX)) S Y=LRFZX,EDITONLY=1 G CTQ + I $D(^TMP("ORECALL",$J,+ORDIALOG,PROMPT)) D G CTQ + . S Y=$$RECALL^ORCD(PROMPT),EDITONLY=1 + S:$G(ORL) Y=$$GET^XPAR("ALL^"_ORL,"LR DEFAULT TYPE QUICK") + I '$L($G(Y)) S Y=$S('$$INPT^ORCD:"SP",$G(ORTYPE)="Q":"LC",1:"WC") +CTQ I Y="I",'$O(ORIMTIME(0))!('$G(ORTEST("Lab CollSamp"))) S Y="WC" + I Y="LC",'$O(ORTIME(0))!('$G(ORTEST("Lab CollSamp"))) S Y="WC" + ;S:$G(ORTYPE)="Q" EDITONLY=1 + I '(FIRST&EDITONLY) D HELPTYPE + Q Y + ; +CKTYPE ; -- Valid type for time, sample? + I Y="LC",'$O(ORTIME(0)) W $C(7),!,"There are no lab collection times defined!" K DONE Q + I Y="I",'$O(ORIMTIME(0)) W $C(7),!,"There are no immediate collection times defined!" K DONE Q + I (Y="LC"!(Y="I")),'$G(ORTEST("Lab CollSamp")) W $C(7),!,"There is no lab collection sample defined for this test!",! K DONE Q + I $D(ORESET),ORESET'=Y,("ILC"[ORESET)!("ILC"[Y) D CHANGED^ORCDLR("TYPE") K ORDIALOG($$PTR^ORCD("OR GTX LAB URGENCY"),"LIST") + Q + ; +HELPTYPE ; -- Xecutable help for Coll Type + W !!,"SEND TO LAB - Means the patient is ambulatory and will be sent to the",!,"Laboratory draw room to have blood drawn." + W !,"WARD COLLECT - Means that either the physician or a nurse will be collecting",!,"the sample on the ward." + W !,"LAB BLOOD TEAM - Means the phlebotomist from Lab will draw the blood on the",!,"ward. This method is limited to laboratory defined collection times." + W:$$ON^LR7OV4(ORDIV) !,"IMMEDIATE COLLECT BY BLOOD TEAM - Means the phlebotomist from Lab is on",!,"call to draw blood on the ward. This method is available during times",!,"defined by Laboratory." W ! + N DOMAIN S DOMAIN=$P(ORDIALOG(PROMPT,0),U,2) D SETLST1^ORCD + Q +VALID(ORDER) ;check collection time on release + N VALIDT,OREVENT,COLLTYPE,COLLDT,OK,ORDIV,ORTXT,ORPTLK,ORTIME,ORIMTIME,ORACT + S VALIDT="" D GETIMES + S COLLDT=$$VALUE^ORCSAVE2(ORDER,"START") + S COLLTYPE=$$VALUE^ORCSAVE2(ORDER,"COLLECT") + I $L($P(^OR(100,+ORIFN,0),U,17)) S OREVENT=$P(^(0),U,17) + I "NOWAMNEXT"[COLLDT D:'$G(OREVENT) MULT Q 1 ;OK + S OK=$S(COLLTYPE="LC":$$LABCOLL(COLLDT),COLLTYPE="I":$$IMMCOLL(COLLDT),1:$$CKDATE(COLLDT)) + I OK D:'$G(OREVENT) MULT Q 1 ;COLLDT passed checks + W !!,$C(7),$P(OK,U,2) + D TEXT^ORQ12(.ORTXT,ORDER) W !,$G(ORTXT(1)) K ORTXT + W !,"must be edited before signing/release." K VALIDT D + . N ORDIV,ORIMTIME,ORTIME,ORNP + . S ORNP=$P(^OR(100,ORDER,0),U,4) + . S ORACT="XX" D XX^ORCACT4 ;edit order + I $$VALUE^ORCSAVE2(ORDER,"START")'=COLLDT D:'$G(OREVENT) MULT Q 1 ;OK + Q 0 + ; +MULT ; -- ck child orders + N CHGD S CHGD=$$MULT^ORCDLR(ORDER,COLLTYPE,COLLDT) Q:'CHGD + W !!,$P(CHGD,U,2) H 2 + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDPS1.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDPS1.m index a4ebb681..b5d7a021 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDPS1.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDPS1.m @@ -1,209 +1,208 @@ -ORCDPS1 ;SLC/MKB-Pharmacy dialog utilities ; 08 May 2002 2:12 PM - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**94,117,141,149,195,215,243**;Dec 17, 1997;Build 242 - ; - ; DBIA 2418 START^PSSJORDF ^TMP("PSJMR",$J) - ; DBIA 3166 EN^PSSDIN ^TMP("PSSDIN",$J) - ; -EN(TYPE) ; -- entry action for Meds dialogs - S ORINPT=$$INPT^ORCD,ORCAT=$G(TYPE) - I 'ORINPT,ORCAT="I" D IMOLOC^ORIMO(.ORINPT,+ORL,+ORVP) S:ORINPT<0 ORINPT=0 ;allow inpt meds at this location? - I ORCAT="" D - . I $G(ORENEW)!$G(OREWRITE)!$D(OREDIT),$L($P($G(OR0),U,12)) S ORCAT=$P(OR0,U,12) Q ;use value from order, via ORCACT4 - . S ORCAT=$S(ORINPT:"I",1:"O") - S ORDG=+$O(^ORD(100.98,"B",$S(ORCAT="I":"UD RX",1:"O RX"),0)) - K ^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) - I $G(ORENEW)!$G(OREWRITE)!$G(OREDIT)!$G(ORXFER) D Q:$G(ORQUIT) - . I 'ORINPT,ORCAT="I" D Q:$G(ORQUIT) - .. N OI S OI=+$O(^OR(100,+$G(ORIFN),.1,"B",0)) Q:OI<1 - .. I '$O(^ORD(101.43,OI,9,"B","IVM RX",0)) S ORQUIT=1 W $C(7),!!,"This order may not be placed at this location!" Q - . K ORDIALOG($$PTR("START DATE/TIME"),1) - . K ORDIALOG($$PTR("NOW"),1) Q:ORCAT'="O" - . N WP S WP=$$PTR("WORD PROCESSING 1") - . I '$G(ORXFER),'$$DRAFT^ORWDX2($G(ORIFN)) K ORDIALOG(WP,1),^TMP("ORWORD",$J,WP) - . I $G(OREDIT),'$O(ORDIALOG($$PTR^ORCD("OR GTX INSTRUCTIONS"),0)) K ^TMP("ORWORD",$J) - I ORINPT,ORCAT="O" W $C(7),!!,"NOTE: This will create an outpatient prescription for an inpatient!",! - Q - ; -EN1 ; -- setup Meds dialog for quick order editor using ORDG - N DG S DG=$P($G(^ORD(100.98,+$G(ORDG),0)),U,3) - I $P(DG," ")="O"!(DG="SPLY") S ORINPT=0,ORCAT="O" - E S ORINPT=1,ORCAT="I" - K ^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) - Q - ; -ENOI ; -- setup OI prompt - N D S D=$G(ORDIALOG(PROMPT,"D")) - S:D="S.RX" ORDIALOG(PROMPT,"D")=$S(ORCAT="I":"S.UD RX",1:"S.O RX") - I ORCAT="I",'ORINPT,D="S.UD RX" D ;limit to IV meds for outpt's - . S ORDIALOG(PROMPT,"D")="S.IVM RX" ;ORDG=+$O(^ORD(100.98,"B","O RX",0)) - . S ORDIALOG(PROMPT,"?")="Enter the IV medication you wish to order for this patient." - Q - ; -DEA ; -- ck DEA# of ordering provider if SchedII drug - Q:$G(ORTYPE)="Z" N DEAFLG,PSOI - S PSOI=+$P($G(^ORD(101.43,+$G(Y),0)),U,2) Q:PSOI'>0 - S DEAFLG=$$OIDEA^PSSUTLA1(PSOI,ORCAT) Q:DEAFLG'>0 ;ok - I $G(ORNP),'$L($P($G(^VA(200,+ORNP,"PS")),U,2)),'$L($P($G(^("PS")),U,3)) W $C(7),!,$P($G(^(0)),U)_" must have a DEA# or VA# to order this drug!" K DONE Q - I DEAFLG=1 W $C(7),!,"This order will require a wet signature!" - Q - ; -CHANGED(X) ; -- Kill dependent values when prompt X changes - N PROMPTS,NAME,PTR,P,I - S PROMPTS=X I X="OI" D - . S PROMPTS="INSTRUCTIONS^ROUTE^SCHEDULE^START DATE/TIME^DURATION^AND/THEN^DOSE^DISPENSE DRUG^SIG^PATIENT INSTRUCTIONS^DAYS SUPPLY^QUANTITY^REFILLS^SERVICE CONNECTED" - . K ORDRUG,ORDOSE,OROUTE,ORSCH,ORSD,ORDSUP,ORQTY,ORQTYUNT,OREFILLS,ORCOPAY - . K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) - I X="DS" S PROMPTS="QUANTITY^REFILLS" K OREFILLS - F P=1:1:$L(PROMPTS,U) S NAME=$P(PROMPTS,U,P) D - . S PTR=$$PTR(NAME) Q:'PTR - . S I=0 F S I=$O(ORDIALOG(PTR,I)) Q:I'>0 K ORDIALOG(PTR,I) - . K ORDIALOG(PTR,"LIST"),^TMP("ORWORD",$J,PTR) - Q - ; -ORDITM(OI) ; -- Check OI, get dependent info - Q:OI'>0 ;quit - no value - N ORPS,ORPSOI S ORPS=$G(^ORD(101.43,+OI,"PS")),ORPSOI=+$P($G(^(0)),U,2) - S ORIV=$S($P(ORPS,U)=2:1,1:0) - I $G(ORCAT)="O",'$P(ORPS,U,2) W $C(7),!,"This drug may not be used in an outpatient order." S ORQUIT=1 D WAIT Q - I $G(ORCAT)="I" D Q:$G(ORQUIT) - . I $G(ORINPT),'$P(ORPS,U) W $C(7),!,"This drug may not be used in an inpatient order." S ORQUIT=1 D WAIT Q - . I '$G(ORINPT),'ORIV W $C(7),!,"This drug may not be ordered for an outpatient." S ORQUIT=1 D WAIT Q - I $G(ORTYPE)="Q" D I $G(ORQUIT) D WAIT Q - . N DEAFLG S DEAFLG=$$OIDEA^PSSUTLA1(ORPSOI,ORCAT) Q:DEAFLG'>0 ;ok - . I $G(ORNP),'$L($P($G(^VA(200,+ORNP,"PS")),U,2)),'$L($P($G(^("PS")),U,3)) W $C(7),!,$P($G(^(0)),U)_" must have a DEA# or VA# to order this drug!" S ORQUIT=1 Q - . I DEAFLG=1 W $C(7),!,"This order will require a wet signature!" -OI1 ; -ck NF status - I $P(ORPS,U,6),'$G(ORENEW) D ;alternative - . W !!,"*** This medication is not in the formulary! ***" - . N PSX,CNT,ORX,DIR,X,Y,DTOUT,DUOUT - . D EN1^PSSUTIL1(.ORPSOI,ORCAT) I '$O(ORPSOI(0)) D Q - .. W !," There are no formulary alternatives entered for this item." - .. W !," Please consult with your pharmacy before ordering it." - . S PSX=0,CNT=0 F S PSX=$O(ORPSOI(PSX)) Q:PSX'>0 D - .. S ORX=+$O(^ORD(101.43,"ID",PSX_";99PSP",0)) Q:ORX'>0 - .. S CNT=CNT+1,ORPSOI("OI",CNT)=ORX_U_PSX - .. S DIR("A",CNT)=$J(CNT,3)_" "_$P($G(^ORD(101.43,ORX,0)),U) - . S DIR(0)="NAO^1:"_CNT,DIR("A")="Select alternative (or to continue): " - . S DIR("?")="The medication selected is not in the formulary; you may select one of the above listed alternatives instead, or press to continue processing this order." - . Q:CNT'>0 W !," Formulary alternatives:" D ^DIR - . I Y'>0 S:$D(DTOUT)!$D(DUOUT) ORQUIT=1 Q - . D:OI'=+ORPSOI("OI",+Y) CHANGED("OI") ;reset parameters if different - . S OI=+ORPSOI("OI",+Y),ORDIALOG(PROMPT,INST)=OI,OROI=OI - . S ORPSOI=+$P(ORPSOI("OI",+Y),U,2) -OI2 ; -get routes, doses [also called from NF^ORCDPS] - D:'$D(^TMP("PSJMR",$J)) START^PSSJORDF(ORPSOI,$G(ORCAT)) ;DBIA 2418 - I '$D(ORDOSE) D - . D DOSE^PSSORUTL(.ORDOSE,ORPSOI,$S($G(ORCAT)="I":"U",1:"O"),+ORVP) - . K:$G(ORDOSE(1))=-1 ORDOSE - Q - ; -NFI(OI) ; -- Show NFI restrictions, if exist - N PSOI,I,J,LCNT,MAX,X,STOP - S PSOI=+$P($G(^ORD(101.43,+$G(OI),0)),U,2) - D EN^PSSDIN(PSOI,"") Q:'$D(^TMP("PSSDIN",$J,"OI",PSOI)) ;DBIA 3166 - S I=0,LCNT=0,MAX=$S($G(IOBM)&$G(IOTM):IOBM-IOTM+1,1:24) W ! - F S I=$O(^TMP("PSSDIN",$J,"OI",PSOI,I)) Q:I'>0 D - . S J=0 F S J=$O(^TMP("PSSDIN",$J,"OI",PSOI,I,J)) Q:J'>0 S X=$G(^(J)) D Q:$G(STOP) - .. S LCNT=LCNT+1 I LCNT' to continue ..." R X:DTIME - Q - ; -ROUTES ; -- Get med routes - Q:$G(ORDIALOG(PROMPT,"LIST")) N I,X,CNT S (I,CNT)=0 - F S I=$O(^TMP("PSJMR",$J,I)) Q:I'>0 S X=^(I),CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=$P(X,U,3)_U_$P(X,U,1,2),ORDIALOG(PROMPT,"LIST","B",$P(X,U))=$P(X,U,3) - S:$G(CNT) ORDIALOG(PROMPT,"LIST")=CNT - S:$G(ORTYPE)'="Z" REQD=$S(ORCAT="I":1,$P($G(^ORD(101.43,+$G(OROI),"PS")),U,5):0,1:1) - Q - ; -DEFRTE ; -- Get default route - N INST1 S INST1=$O(ORDIALOG(PROMPT,0)) S:INST1'>0 INST1=INST - I INST1=INST S Y=+$P($G(^TMP("PSJMR",$J,1)),U,3) K:Y'>0 Y Q - S Y=+$G(ORDIALOG(PROMPT,INST1)) K:Y'>0 Y S:$G(Y) EDITONLY=1 - Q - ; -CKSCH ; -- validate schedule [Called from P-S Action] - N ORX S ORX=ORDIALOG(PROMPT,ORI) Q:ORX=$G(ORESET) K ORSD - D EN^PSSGS0(.ORX,$G(ORCAT)) - I $D(ORX) S ORDIALOG(PROMPT,ORI)=ORX D CHANGED("QUANTITY") Q ;ok - W $C(7),!,"Enter a standard schedule for administering this medication" - K DONE I $G(ORCAT)="I" W ".",! Q - W " or one of your own,",!,"up to 20 characters.",! - Q - ; -DEFCONJ ; -- Set default conjuction for previous instance [P-S Action] - N LAST,DUR,CONJ - S LAST=$O(ORDIALOG(PROMPT,ORI),-1) Q:LAST'>0 ;first instance - S CONJ=$$PTR("AND/THEN") Q:$L($G(ORDIALOG(CONJ,LAST))) - S DUR=$G(ORDIALOG($$PTR("DURATION"),LAST)) - S ORDIALOG(CONJ,LAST)=$S(+DUR'>0:"A",1:"T") - Q - ; -ENCONJ ; -- Get allowable values, if req'd for INST - N P S P=$$PTR("INSTRUCTIONS") - S REQD=$S($O(ORDIALOG(P,INST)):1,1:0) - S ORDIALOG(PROMPT,"A")="And/then"_$S(ORCAT="O":"/except: ",1:": ") - S $P(ORDIALOG(PROMPT,0),U,2)="A:AND;T:THEN;"_$S(ORCAT="O":"X:EXCEPT;",1:"") - Q - ; -DSUP ; -- Get max/default days supply - N ORX,Y - S ORX("PATIENT")=+$G(ORVP),ORX("DRUG")=+$G(ORDRUG) - D DSUP^PSOSIGDS(.ORX) S Y=+$G(ORX("DAYS SUPPLY")) S:Y'>0 Y=90 - ;S $P(ORDIALOG(PROMPT,0),U,2)="1:"_Y ;max allowed - I '$G(ORDIALOG(PROMPT,1)),$G(ORTYPE)'="Z" S ORDIALOG(PROMPT,1)=Y - Q - ; -QTY() ; -- Return default quantity [Expects ORDSUP] - N INSTR,DOSE,DUR,SCH,I,ORX,X,Y - S Y="" I $G(ORDSUP)'>0!'$G(ORDRUG) G QTYQ ;need days supply, disp drug - S INSTR=$$PTR("INSTRUCTIONS") - S DOSE=$$PTR("DOSE"),CONJ=$$PTR("AND/THEN") - S DUR=$$PTR("DURATION"),SCH=$$PTR("SCHEDULE") - S I=0 F S I=$O(ORDIALOG(INSTR,I)) Q:I'>0 D Q:'$D(ORX) - . S X=$P($G(ORDIALOG(DOSE,I)),"&",3) I X'>0 K ORX Q - . S ORX("DOSE ORDERED",I)=X,ORX("SCHEDULE",I)=$G(ORDIALOG(SCH,I)) - . S X=$G(ORDIALOG(DUR,I)),ORX("DURATION",I)=$$HL7DUR^ORMBLDPS - . S ORX("CONJUNCTION",I)=$G(ORDIALOG(CONJ,I)) - G:'$D(ORX) QTYQ ;no doses - S ORX("PATIENT")=+$G(ORVP),ORX("DRUG")=+$G(ORDRUG) - S ORX("DAYS SUPPLY")=+$G(ORDSUP) - D QTYX^PSOSIG(.ORX) S Y=$G(ORX("QTY")) -QTYQ Q Y - ; -MAXREFS ; -- Get max refills allowed [Entry Action] - Q:$G(ORCAT)'="O" N ORX,X - S ORX("ITEM")=+$P($G(^ORD(101.43,+$G(OROI),0)),U,2) - S ORX("DRUG")=+$G(ORDRUG),ORX("PATIENT")=+$G(ORVP) - I $G(OREVENT),$$TYPE^OREVNTX(OREVENT)="D" S ORX("DISCHARGE")=1 - S ORX("DAYS SUPPLY")=$G(ORDSUP) D MAX^PSOSIGDS(.ORX) - S OREFILLS=$G(ORX("MAX")),X=$G(ORDIALOG(PROMPT,INST)) - I OREFILLS'>0 S ORDIALOG(PROMPT,INST)=0 W !,"No refills allowed." Q - S $P(ORDIALOG(PROMPT,0),U,2)="0:"_OREFILLS - S ORDIALOG(PROMPT,"A")="Refills (0-"_OREFILLS_"): " - I X,X>OREFILLS S ORDIALOG(PROMPT,INST)=OREFILLS - Q - ; -ASKSC() ; -- Return 1 or 0, if SC prompt should be asked - I $$SC^PSOCP(+ORVP,+$G(ORDRUG)) Q 0 - ;I $$RXST^IBARXEU(+ORVP)>0 Q 0 ;exempt from copay - Q 1 - ; -PTR(X) ; -- Return ptr to prompt OR GTX X - Q +$O(^ORD(101.41,"AB","OR GTX "_X,0)) - ; -EXIT ; -- exit action for Meds - S:$G(ORXNP) ORNP=ORXNP - K ORXNP,ORINPT,ORCAT,ORPKG,OROI,ORIV,ORDRUG,ORDOSE,OROUTE,ORSCH,ORSD,ORDSUP,OREFILLS,ORQTY,ORQTYUNT,ORCOPAY,PSJNOPC,ORCOMPLX - K ^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) - Q +ORCDPS1 ;SLC/MKB-Pharmacy dialog utilities ; 08 May 2002 2:12 PM + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**94,117,141,149,195,215**;Dec 17, 1997 + ; + ; DBIA 2418 START^PSSJORDF ^TMP("PSJMR",$J) + ; DBIA 3166 EN^PSSDIN ^TMP("PSSDIN",$J) + ; +EN(TYPE) ; -- entry action for Meds dialogs + S ORINPT=$$INPT^ORCD,ORCAT=$G(TYPE) + I 'ORINPT,ORCAT="I" D IMOLOC^ORIMO(.ORINPT,+ORL,+ORVP) S:ORINPT<0 ORINPT=0 ;allow inpt meds at this location? + I ORCAT="" D + . I $G(ORENEW)!$G(OREWRITE)!$D(OREDIT),$L($P($G(OR0),U,12)) S ORCAT=$P(OR0,U,12) Q ;use value from order, via ORCACT4 + . S ORCAT=$S(ORINPT:"I",1:"O") + S ORDG=+$O(^ORD(100.98,"B",$S(ORCAT="I":"UD RX",1:"O RX"),0)) + K ^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) + I $G(ORENEW)!$G(OREWRITE)!$D(OREDIT)!$G(ORXFER) D Q:$G(ORQUIT) + . I 'ORINPT,ORCAT="I" D Q:$G(ORQUIT) + .. N OI S OI=+$O(^OR(100,+$G(ORIFN),.1,"B",0)) Q:OI<1 + .. I '$O(^ORD(101.43,OI,9,"B","IVM RX",0)) S ORQUIT=1 W $C(7),!!,"This order may not be placed at this location!" Q + . K ORDIALOG($$PTR("START DATE/TIME"),1) + . K ORDIALOG($$PTR("NOW"),1) Q:ORCAT'="O" + . I $G(OREDIT)!$G(OREWRITE) N PI S PI=$$PTR("PATIENT INSTRUCTIONS") K ORDIALOG(PI,1),^TMP("ORWORD",$J,PI) + . I $D(OREDIT),'$O(ORDIALOG($$PTR^ORCD("OR GTX INSTRUCTIONS"),0)) K ^TMP("ORWORD",$J) + I ORINPT,ORCAT="O" W $C(7),!!,"NOTE: This will create an outpatient prescription for an inpatient!",! + Q + ; +EN1 ; -- setup Meds dialog for quick order editor using ORDG + N DG S DG=$P($G(^ORD(100.98,+$G(ORDG),0)),U,3) + I $P(DG," ")="O"!(DG="SPLY") S ORINPT=0,ORCAT="O" + E S ORINPT=1,ORCAT="I" + K ^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) + Q + ; +ENOI ; -- setup OI prompt + N D S D=$G(ORDIALOG(PROMPT,"D")) + S:D="S.RX" ORDIALOG(PROMPT,"D")=$S(ORCAT="I":"S.UD RX",1:"S.O RX") + I ORCAT="I",'ORINPT,D="S.UD RX" D ;limit to IV meds for outpt's + . S ORDIALOG(PROMPT,"D")="S.IVM RX" ;ORDG=+$O(^ORD(100.98,"B","O RX",0)) + . S ORDIALOG(PROMPT,"?")="Enter the IV medication you wish to order for this patient." + Q + ; +DEA ; -- ck DEA# of ordering provider if SchedII drug + Q:$G(ORTYPE)="Z" N DEAFLG,PSOI + S PSOI=+$P($G(^ORD(101.43,+$G(Y),0)),U,2) Q:PSOI'>0 + S DEAFLG=$$OIDEA^PSSUTLA1(PSOI,ORCAT) Q:DEAFLG'>0 ;ok + I $G(ORNP),'$L($P($G(^VA(200,+ORNP,"PS")),U,2)),'$L($P($G(^("PS")),U,3)) W $C(7),!,$P($G(^(0)),U)_" must have a DEA# or VA# to order this drug!" K DONE Q + I DEAFLG=1 W $C(7),!,"This order will require a wet signature!" + Q + ; +CHANGED(X) ; -- Kill dependent values when prompt X changes + N PROMPTS,NAME,PTR,P,I + S PROMPTS=X I X="OI" D + . S PROMPTS="INSTRUCTIONS^ROUTE^SCHEDULE^START DATE/TIME^DURATION^AND/THEN^DOSE^DISPENSE DRUG^SIG^PATIENT INSTRUCTIONS^DAYS SUPPLY^QUANTITY^REFILLS^SERVICE CONNECTED" + . K ORDRUG,ORDOSE,OROUTE,ORSCH,ORSD,ORDSUP,ORQTY,ORQTYUNT,OREFILLS,ORCOPAY + . K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) + I X="DS" S PROMPTS="QUANTITY^REFILLS" K OREFILLS + F P=1:1:$L(PROMPTS,U) S NAME=$P(PROMPTS,U,P) D + . S PTR=$$PTR(NAME) Q:'PTR + . S I=0 F S I=$O(ORDIALOG(PTR,I)) Q:I'>0 K ORDIALOG(PTR,I) + . K ORDIALOG(PTR,"LIST"),^TMP("ORWORD",$J,PTR) + Q + ; +ORDITM(OI) ; -- Check OI, get dependent info + Q:OI'>0 ;quit - no value + N ORPS,ORPSOI S ORPS=$G(^ORD(101.43,+OI,"PS")),ORPSOI=+$P($G(^(0)),U,2) + S ORIV=$S($P(ORPS,U)=2:1,1:0) + I $G(ORCAT)="O",'$P(ORPS,U,2) W $C(7),!,"This drug may not be used in an outpatient order." S ORQUIT=1 D WAIT Q + I $G(ORCAT)="I" D Q:$G(ORQUIT) + . I $G(ORINPT),'$P(ORPS,U) W $C(7),!,"This drug may not be used in an inpatient order." S ORQUIT=1 D WAIT Q + . I '$G(ORINPT),'ORIV W $C(7),!,"This drug may not be ordered for an outpatient." S ORQUIT=1 D WAIT Q + I $G(ORTYPE)="Q" D I $G(ORQUIT) D WAIT Q + . N DEAFLG S DEAFLG=$$OIDEA^PSSUTLA1(ORPSOI,ORCAT) Q:DEAFLG'>0 ;ok + . I $G(ORNP),'$L($P($G(^VA(200,+ORNP,"PS")),U,2)),'$L($P($G(^("PS")),U,3)) W $C(7),!,$P($G(^(0)),U)_" must have a DEA# or VA# to order this drug!" S ORQUIT=1 Q + . I DEAFLG=1 W $C(7),!,"This order will require a wet signature!" +OI1 ; -ck NF status + I $P(ORPS,U,6),'$G(ORENEW) D ;alternative + . W !!,"*** This medication is not in the formulary! ***" + . N PSX,CNT,ORX,DIR,X,Y,DTOUT,DUOUT + . D EN1^PSSUTIL1(.ORPSOI,ORCAT) I '$O(ORPSOI(0)) D Q + .. W !," There are no formulary alternatives entered for this item." + .. W !," Please consult with your pharmacy before ordering it." + . S PSX=0,CNT=0 F S PSX=$O(ORPSOI(PSX)) Q:PSX'>0 D + .. S ORX=+$O(^ORD(101.43,"ID",PSX_";99PSP",0)) Q:ORX'>0 + .. S CNT=CNT+1,ORPSOI("OI",CNT)=ORX_U_PSX + .. S DIR("A",CNT)=$J(CNT,3)_" "_$P($G(^ORD(101.43,ORX,0)),U) + . S DIR(0)="NAO^1:"_CNT,DIR("A")="Select alternative (or to continue): " + . S DIR("?")="The medication selected is not in the formulary; you may select one of the above listed alternatives instead, or press to continue processing this order." + . Q:CNT'>0 W !," Formulary alternatives:" D ^DIR + . I Y'>0 S:$D(DTOUT)!$D(DUOUT) ORQUIT=1 Q + . D:OI'=+ORPSOI("OI",+Y) CHANGED("OI") ;reset parameters if different + . S OI=+ORPSOI("OI",+Y),ORDIALOG(PROMPT,INST)=OI,OROI=OI + . S ORPSOI=+$P(ORPSOI("OI",+Y),U,2) +OI2 ; -get routes, doses [also called from NF^ORCDPS] + D:'$D(^TMP("PSJMR",$J)) START^PSSJORDF(ORPSOI,$G(ORCAT)) ;DBIA 2418 + I '$D(ORDOSE) D + . D DOSE^PSSORUTL(.ORDOSE,ORPSOI,$S($G(ORCAT)="I":"U",1:"O"),+ORVP) + . K:$G(ORDOSE(1))=-1 ORDOSE + Q + ; +NFI(OI) ; -- Show NFI restrictions, if exist + N PSOI,I,J,LCNT,MAX,X,STOP + S PSOI=+$P($G(^ORD(101.43,+$G(OI),0)),U,2) + D EN^PSSDIN(PSOI,"") Q:'$D(^TMP("PSSDIN",$J,"OI",PSOI)) ;DBIA 3166 + S I=0,LCNT=0,MAX=$S($G(IOBM)&$G(IOTM):IOBM-IOTM+1,1:24) W ! + F S I=$O(^TMP("PSSDIN",$J,"OI",PSOI,I)) Q:I'>0 D + . S J=0 F S J=$O(^TMP("PSSDIN",$J,"OI",PSOI,I,J)) Q:J'>0 S X=$G(^(J)) D Q:$G(STOP) + .. S LCNT=LCNT+1 I LCNT' to continue ..." R X:DTIME + Q + ; +ROUTES ; -- Get med routes + Q:$G(ORDIALOG(PROMPT,"LIST")) N I,X,CNT S (I,CNT)=0 + F S I=$O(^TMP("PSJMR",$J,I)) Q:I'>0 S X=^(I),CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=$P(X,U,3)_U_$P(X,U,1,2),ORDIALOG(PROMPT,"LIST","B",$P(X,U))=$P(X,U,3) + S:$G(CNT) ORDIALOG(PROMPT,"LIST")=CNT + S:$G(ORTYPE)'="Z" REQD=$S(ORCAT="I":1,$P($G(^ORD(101.43,+$G(OROI),"PS")),U,5):0,1:1) + Q + ; +DEFRTE ; -- Get default route + N INST1 S INST1=$O(ORDIALOG(PROMPT,0)) S:INST1'>0 INST1=INST + I INST1=INST S Y=+$P($G(^TMP("PSJMR",$J,1)),U,3) K:Y'>0 Y Q + S Y=+$G(ORDIALOG(PROMPT,INST1)) K:Y'>0 Y S:$G(Y) EDITONLY=1 + Q + ; +CKSCH ; -- validate schedule [Called from P-S Action] + N ORX S ORX=ORDIALOG(PROMPT,ORI) Q:ORX=$G(ORESET) K ORSD + D EN^PSSGS0(.ORX,$G(ORCAT)) + I $D(ORX) S ORDIALOG(PROMPT,ORI)=ORX D CHANGED("QUANTITY") Q ;ok + W $C(7),!,"Enter a standard administration schedule" + K DONE I $G(ORCAT)="I" W ".",! Q + W " or one of your own,",!,"up to 70 characters and no more than 2 spaces.",! + Q + ; +DEFCONJ ; -- Set default conjuction for previous instance [P-S Action] + N LAST,DUR,CONJ + S LAST=$O(ORDIALOG(PROMPT,ORI),-1) Q:LAST'>0 ;first instance + S CONJ=$$PTR("AND/THEN") Q:$L($G(ORDIALOG(CONJ,LAST))) + S DUR=$G(ORDIALOG($$PTR("DURATION"),LAST)) + S ORDIALOG(CONJ,LAST)=$S(+DUR'>0:"A",1:"T") + Q + ; +ENCONJ ; -- Get allowable values, if req'd for INST + N P S P=$$PTR("INSTRUCTIONS") + S REQD=$S($O(ORDIALOG(P,INST)):1,1:0) + S ORDIALOG(PROMPT,"A")="And/then"_$S(ORCAT="O":"/except: ",1:": ") + S $P(ORDIALOG(PROMPT,0),U,2)="A:AND;T:THEN;"_$S(ORCAT="O":"X:EXCEPT;",1:"") + Q + ; +DSUP ; -- Get max/default days supply + N ORX,Y + S ORX("PATIENT")=+$G(ORVP),ORX("DRUG")=+$G(ORDRUG) + D DSUP^PSOSIGDS(.ORX) S Y=+$G(ORX("DAYS SUPPLY")) S:Y'>0 Y=90 + ;S $P(ORDIALOG(PROMPT,0),U,2)="1:"_Y ;max allowed + I '$G(ORDIALOG(PROMPT,1)),$G(ORTYPE)'="Z" S ORDIALOG(PROMPT,1)=Y + Q + ; +QTY() ; -- Return default quantity [Expects ORDSUP] + N INSTR,DOSE,DUR,SCH,I,ORX,X,Y + S Y="" I $G(ORDSUP)'>0!'$G(ORDRUG) G QTYQ ;need days supply, disp drug + S INSTR=$$PTR("INSTRUCTIONS") + S DOSE=$$PTR("DOSE"),CONJ=$$PTR("AND/THEN") + S DUR=$$PTR("DURATION"),SCH=$$PTR("SCHEDULE") + S I=0 F S I=$O(ORDIALOG(INSTR,I)) Q:I'>0 D Q:'$D(ORX) + . S X=$P($G(ORDIALOG(DOSE,I)),"&",3) I X'>0 K ORX Q + . S ORX("DOSE ORDERED",I)=X,ORX("SCHEDULE",I)=$G(ORDIALOG(SCH,I)) + . S X=$G(ORDIALOG(DUR,I)),ORX("DURATION",I)=$$HL7DUR^ORMBLDPS + . S ORX("CONJUNCTION",I)=$G(ORDIALOG(CONJ,I)) + G:'$D(ORX) QTYQ ;no doses + S ORX("PATIENT")=+$G(ORVP),ORX("DRUG")=+$G(ORDRUG) + S ORX("DAYS SUPPLY")=+$G(ORDSUP) + D QTYX^PSOSIG(.ORX) S Y=$G(ORX("QTY")) +QTYQ Q Y + ; +MAXREFS ; -- Get max refills allowed [Entry Action] + Q:$G(ORCAT)'="O" N ORX,X + S ORX("ITEM")=+$P($G(^ORD(101.43,+$G(OROI),0)),U,2) + S ORX("DRUG")=+$G(ORDRUG),ORX("PATIENT")=+$G(ORVP) + I $G(OREVENT),$$TYPE^OREVNTX(OREVENT)="D" S ORX("DISCHARGE")=1 + S ORX("DAYS SUPPLY")=$G(ORDSUP) D MAX^PSOSIGDS(.ORX) + S OREFILLS=$G(ORX("MAX")),X=$G(ORDIALOG(PROMPT,INST)) + I OREFILLS'>0 S ORDIALOG(PROMPT,INST)=0 W !,"No refills allowed." Q + S $P(ORDIALOG(PROMPT,0),U,2)="0:"_OREFILLS + S ORDIALOG(PROMPT,"A")="Refills (0-"_OREFILLS_"): " + I X,X>OREFILLS S ORDIALOG(PROMPT,INST)=OREFILLS + Q + ; +ASKSC() ; -- Return 1 or 0, if SC prompt should be asked + I $$SC^PSOCP(+ORVP,+$G(ORDRUG)) Q 0 + ;I $$RXST^IBARXEU(+ORVP)>0 Q 0 ;exempt from copay + Q 1 + ; +PTR(X) ; -- Return ptr to prompt OR GTX X + Q +$O(^ORD(101.41,"AB","OR GTX "_X,0)) + ; +EXIT ; -- exit action for Meds + S:$G(ORXNP) ORNP=ORXNP + K ORXNP,ORINPT,ORCAT,ORPKG,OROI,ORIV,ORDRUG,ORDOSE,OROUTE,ORSCH,ORSD,ORDSUP,OREFILLS,ORQTY,ORQTYUNT,ORCOPAY,PSJNOPC,ORCOMPLX + K ^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDPS2.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDPS2.m index 39375928..2898a3e4 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDPS2.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDPS2.m @@ -1,181 +1,178 @@ -ORCDPS2 ;SLC/MKB-Pharmacy dialog utilities ;12/14/2006 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**94,116,125,131,243**;Dec 17, 1997;Build 242 - ; -COMPLEX() ; -- Single or complex? - N X,Y,DIR,DUOUT,DTOUT,COMPLX - S COMPLX=$S($O(ORDIALOG(PROMPT,"?"),-1)>1:1,$L($G(ORDIALOG($$PTR("DURATION"),1))):1,1:0) - I $G(ORTYPE)="Q",$O(ORDIALOG(PROMPT,0)),FIRST Q COMPLX - I $D(ORENEW)!$D(OREWRITE)!$D(ORXFER)!COMPLX Q COMPLX - I $D(OREDIT) Q:$D(ORCOMPLX)!COMPLX COMPLX G CP1 ;Q if complex or 'first, else ask - I 'FIRST S Y=$S($D(ORCOMPLX):ORCOMPLX,1:COMPLX) Q Y -CP1 S DIR(0)="YA",DIR("A")="Complex dose? ",DIR("B")="NO" - S DIR("?")="Enter YES if you wish to enter multiple sets of dosage instructions, a tapering dose, or to limit the duration of a single dose." - D ^DIR S:$D(DTOUT) Y="^" - Q Y - ; -DOSES ; -- Available common doses - ;S $P(ORDIALOG(PROMPT,0),U,2)=$S(ORCAT="I":"1:20",1:"1:80") - S ORDIALOG(PROMPT,"A")="Dose"_$S(ORCAT="I"&$G(ORIV):" or Rate: ",1:": ") - S $P(ORDIALOG(PROMPT,"?"),",",2)=$S($G(ORIV):" as either a dose amount or infusion rate.",1:" as a dose or amount.") - I FIRST,'$O(ORDIALOG(PROMPT,0)),$G(ORXFER) D SHOWSIG^ORCMED - S ORCOMPLX=$$COMPLEX,MULT=+ORCOMPLX I ORCOMPLX="^" S ORQUIT=1 Q - Q:$G(ORDIALOG(PROMPT,"LIST")) Q:'$D(ORDOSE) -D1 ; -- Entry from ORCMED,NF^ORCDPS to build list - N I,J,X,DD,DRUG,DOSE,CONJ,CNT,UD,COST,TEXT - S (I,CNT)=0,CONJ=$P($G(ORDOSE("MISC")),U,3) S:$L(CONJ) CONJ=" "_CONJ - F S I=$O(ORDOSE(I)) Q:I'>0 D - . S X=ORDOSE(I),DD=+$P(X,U,6),DRUG=ORDOSE("DD",DD) - . ; =TotalDose^Units^U/D^Noun^LocalDose^DispDrugIEN^Cost - . ;DD=Name^Cost^NF^DispUnit^Strength^Units^DoseForm^MaxRefills? - . S DOSE=$P(X,U,5),UD=$P(X,U,3),COST=$P(X,U,7) Q:'$L(DOSE) - . I '$P(X,U) S DOSE=DOSE_CONJ_" "_$S($L($P(DRUG,U,5)):$P(DRUG,U,5)_$P(DRUG,U,6),1:$P(DRUG,U)) - . ;I UD S COST="$"_$J(UD*$P(DRUG,U,2),1,3) ;_" per "_UD_" "_$P(X,U,4) - . S TEXT=DOSE_$S($L(COST):" $"_COST,1:"")_$S($P(DRUG,U,3):" (non-formulary)",1:"") - . S CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=DOSE_U_TEXT - . S ORDIALOG(PROMPT,"LIST","B",TEXT)=DOSE - . S ORDIALOG(PROMPT,"LIST","D",DOSE)=DD ;default DispDrug - . S ORDOSE("DD",DD,DOSE)=$P(ORDOSE(I),U,1,6)_U_$P(DRUG,U,5,6) - . S J=0 F S J=$O(ORDOSE(I,J)) Q:J'>0 D ;xref alt forms of dose - .. S DD=+$P(ORDOSE(I,J),U,6),DRUG=$G(ORDOSE("DD",DD)) - .. S ORDOSE("DD",DD,DOSE)=$P(ORDOSE(I,J),U,1,6)_U_$P(DRUG,U,5,6) - S:CNT ORDIALOG(PROMPT,"LIST")=CNT - Q - ; -CHDOSE ; -- Kill dependent values if inst ORI of dose changes - N X,PROMPTS,P,NAME,DOSE,DD S X=$G(ORDIALOG(PROMPT,ORI)) - S X=$$UP^XLFSTR(X),ORDIALOG(PROMPT,ORI)=X ;force uppercase - I X,X'?1.N.E1.A.E K DONE W $C(7),!,"Enter the amount of this drug that the patient is to receive as a dose,",!,"NOT as the number of units per dose." Q - I $L(X)>60,'$D(ORDIALOG(PROMPT,"LIST","B",X)) K DONE W $C(7),!,"Instructions may not be longer than 60 characters." Q - I $G(ORESET)'=X D ;kill dependent values if new/changed dose - . S PROMPTS="STRENGTH^DRUG NAME^DOSE^DISPENSE DRUG^DAYS SUPPLY^QUANTITY^REFILLS" - . F P=1:1:$L(PROMPTS,U) S NAME=$P(PROMPTS,U,P) K ORDIALOG($$PTR(NAME),ORI) - . K ORQTY,ORQTYUNT,ORDRUG,ORDIALOG($$PTR("DISPENSE DRUG"),1) - . K ^TMP("ORWORD",$J,$$PTR("SIG")) - S DOSE=$$PTR("DOSE") I $L(X),'$L($G(ORDIALOG(DOSE,ORI))) D ;set ID - . S DD=+$G(ORDIALOG(PROMPT,"LIST","D",X)) - . S:DD ORDIALOG(DOSE,ORI)=$TR($G(ORDOSE("DD",DD,X)),"^","&") - S DD=+$P($G(ORDIALOG(DOSE,ORI)),"&",6) - I DD,$P($G(ORDOSE("DD",DD)),U,3) D NF^ORCDPS(DD) ;look for FormAlt - Q - ; -EXDOSE ; -- Exit Action - Q:'$O(ORDIALOG(PROMPT,0)) N DRUG,MISC,QUIT,LAST - S ORDRUG=$$DISPDRUG^ORCDPS,DRUG=$G(ORDOSE("DD",+ORDRUG)) - I ORDRUG D I $G(QUIT) S ORQUIT=1 Q - . ;I $P(DRUG,U,10),'$L($P($G(^VA(200,+$G(ORNP),"PS")),U,2)),'$L($P($G(^("PS")),U,3)) W $C(7),!,$P($G(^(0)),U)_" must have a DEA# or VA# to order this drug!" S QUIT=1 Q - . ;I $P(DRUG,U,10)=1 W $C(7),!,"This order will require a wet signature!" - . S ORDIALOG($$PTR("DISPENSE DRUG"),1)=ORDRUG - . D:$G(ORCAT)="O" RESETID^ORCDPS - . N STR,MED S STR=$P(DRUG,U,5)_$P(DRUG,U,6) - . I STR'>0 S:'$G(ORDOSE(1)) ORDIALOG($$PTR("DRUG NAME"),1)=$P(DRUG,U) Q - . S MED=$P($G(^ORD(101.43,+$G(OROI),0)),U) - . I MED'[STR,ORCAT="O"!'$G(ORDOSE(1)) S ORDIALOG($$PTR("STRENGTH"),1)=STR - I +ORDRUG'>0,ORCAT="O" W $C(7),!,"Cannot determine dispense drug - some defaults and order checks may not occur!" -EXD1 ; -- Kill dangling conjunction, [re]build Sig, get Qty info - S LAST=$O(ORDIALOG(PROMPT,"?"),-1) K ORDIALOG($$PTR("AND/THEN"),LAST) - D ADMIN^ORCDPS3 D:$G(ORTYPE)'="Z" SIG ;[re]build Sig/Text - I ORDRUG,ORCAT="O" D ;set Qty info - . S:$L($P(DRUG,U,4)) ORQTYUNT=$P(DRUG,U,4) - . S MISC=$$ENDCM^PSJORUTL(+ORDRUG),ORQTY=$P(MISC,U,4) - . W:$L($P(MISC,U,2)) !!,$P(MISC,U,2),! - Q - ; -SIG ; -- Create ORDIALOG(SIG) from Instructions PROMPT,ORDOSE,ORDRUG,ORCAT - ; Return text in ^TMP("ORWORD",$J,SIG,INST) - ; [also called from PSJ^ORCSEND1 to build child orders] - ; - N ORT,ORSCH,ORDUR,ORID,ORDD,ORCNJ,ORMISC,ORPREP,ORX,ORI,CNT,ORSIG,ORS,DOSE - S ORT=$$PTR("ROUTE"),ORSCH=$$PTR("SCHEDULE"),ORDUR=$$PTR("DURATION") - S ORID=$$PTR("DOSE"),ORCNJ=$$PTR("AND/THEN"),ORS=$$PTR("SIG") - S ORMISC=$G(ORDOSE("MISC")),ORPREP=$P(ORMISC,U,2) - S ORX=$S(ORCAT="I":"",ORCAT="O"&(+$G(ISIMO)=1):"",$L($P(ORMISC,U)):$P(ORMISC,U)_" ",1:"") ;"TAKE " - S (CNT,ORI)=0 F S ORI=$O(ORDIALOG(PROMPT,ORI)) Q:ORI'>0 D - . S DOSE=$G(ORDIALOG(PROMPT,ORI)) Q:'$L(DOSE) - . S ORX=ORX_$$DOSE_$$RTE_$$SCH_$$DUR_$$CONJ - . S CNT=CNT+1,ORSIG(CNT,0)=ORX,ORX="" - Q:CNT'>0 S ORSIG(0)="^^"_CNT_U_CNT_U_DT_U - K ^TMP("ORWORD",$J,ORS,1) M ^(1)=ORSIG S ORDIALOG(PROMPT,"FORMAT")="@" - S ORDIALOG(ORS,1)=$NA(^TMP("ORWORD",$J,ORS,1)) - Q - ; -PTR(X) ; -- Ptr to prompt OR GTX X - Q +$O(^ORD(101.41,"AB","OR GTX "_X,0)) - ; -DOSE() ; -- Dosage - N X0,Y S X0=$G(ORDIALOG(ORID,ORI)) ;ID string - S Y=DOSE I ORDRUG,$L(X0) D ;use local dose if common DispDrug - . S:$L($P(X0,"&",5)) Y=$P(X0,"&",5) ;unless Outpt w/total dose - . I ORCAT="O",X0 S Y=$$WORD($P(X0,"&",3))_" "_$P(X0,"&",4) ;u/d - Q Y - ; -WORD(X) ; -- Words for number X - N X1,X2,Y S X1=$P(+X,"."),X2=$P(+X,".",2) - S Y="" I X1 S Y=$S(X1=1:"ONE",X1=2:"TWO",X1=3:"THREE",X1=4:"FOUR",X1=5:"FIVE",X1=6:"SIX",X1=7:"SEVEN",X1=8:"EIGHT",X1=9:"NINE",X1=10:"TEN",1:X1) - I X2 S Y=Y_$S($L(Y):" AND ",1:"")_$S(X2=5:"ONE-HALF",X2=33!(X2=34):"ONE-THIRD",X2=25:"ONE-FOURTH",X2=66!(X2=67):"TWO-THIRDS",X2=75:"THREE-FOURTHS",1:"."_X2) - Q Y - ; -RTE() ; -- Expansion of route - N X,X0,Y S X=+$G(ORDIALOG(ORT,ORI)) Q:X'>0 "" - K ^TMP($J,"ORCDPS2 RTE") - D ALL^PSS51P2(+X,,,,"ORCDPS2 RTE") - ;S X0=$G(^PS(51.2,+X,0)),Y="" - I ORCAT="I"!(+$G(ISIMO)=1) S Y=" "_$S($L(^TMP($J,"ORCDPS2 RTE",+X,1)):^TMP($J,"ORCDPS2 RTE",+X,1),1:^TMP($J,"ORCDPS2 RTE",+X,.01)) - ;I ORCAT="I" S Y=" "_$S($L($P(X0,U,3)):$P(X0,U,3),1:$P(X0,U)) - I ORCAT="O",'+$G(ISIMO) S Y=" "_$S($L(ORPREP):ORPREP_" ",1:"")_$S($L(^TMP($J,"ORCDPS2 RTE",+X,4)):^TMP($J,"ORCDPS2 RTE",+X,4),1:^TMP($J,"ORCDPS2 RTE",+X,.01)) - Q Y - ; -SCH() ; -- [outpatient] expansion of schedule - N X,Y S X=$G(ORDIALOG(ORSCH,ORI)) - I $L(X),ORCAT="O",'+$G(ISIMO) D SCH^PSSUTIL1(.X) - S Y=$S($L(X):" "_X,1:"") - Q Y - ; -DUR() ; -- Duration - N X,Y S X=$G(ORDIALOG(ORDUR,ORI)),Y="" - I X S Y=" FOR "_$$UP^XLFSTR(X)_$S(+X=X:" DAYS",1:"") - Q Y - ; -CONJ() ; -- Conjunction - N X,Y S X=$G(ORDIALOG(ORCNJ,ORI)) - S:$L(X)>1 X=$E(X) S:X="E" S="X" - S Y=$S(X="T":", THEN",X="X":" EXCEPT",X="A":" AND",1:"") - Q Y - ; -DOSETEXT ; -- Reset dose text in ORDIALOG(INSTR) for backdoor orders - ; [Called from ORMPS1 - uses ORCAT,PSOI,ORVP,DRUG,INSTR,DOSE] - ; - N ORTYPE,ORDOSE,CONJ,ORDRUG,DRUG0,STRG,ORI,LDOSE,X,PROMPT - S ORTYPE=$S($G(ORCAT)="I":"U",1:"O") - D DOSE^PSSORUTL(.ORDOSE,+PSOI,ORTYPE,+ORVP) - S CONJ=$P($G(ORDOSE("MISC")),U,3) S:$L(CONJ) CONJ=" "_CONJ - S ORDRUG=+$G(ORDIALOG(DRUG,1)),DRUG0=$G(ORDOSE("DD",ORDRUG)) - S STRG=$P(DRUG0,U,5)_$P(DRUG0,U,6) - I '$G(ORDOSE(1)) S ORI=0 F S ORI=$O(ORDIALOG(INSTR,ORI)) Q:ORI'>0 D - . S LDOSE=$G(ORDIALOG(INSTR,ORI)),X=$G(ORDIALOG(DOSE,ORI)) Q:'$L(X) - . S:'X ORDIALOG(INSTR,ORI)=LDOSE_CONJ_" "_$S(STRG:STRG,1:$P(DRUG0,U)) - ; -build Sig/Text if not defined - I '$D(ORDIALOG(+$$PTR("SIG"),1)) S PROMPT=INSTR D SIG - Q - ; -PI ; -- Include Pt Instructions w/Sig in Outpt order? - N X,Y,DIR,DUOUT,DTOUT,DIRUT,ORTX,ORMAX,I,CNT - I $G(ORCAT)'="O" D CLEARWP Q ;!'$O(ORDOSE("PI",0)) - Q:$G(ORENEW) S I=0,ORMAX=57 - I $G(OREDIT)!$G(OREWRITE),$O(^TMP("ORWORD",$J,PROMPT,INST,0)) K ORDOSE("PI") S I=0 F S I=$O(^TMP("ORWORD",$J,PROMPT,INST,I)) Q:I<1 S ORDOSE("PI",I)=$G(^(I,0)) - I '$O(ORDOSE("PI",0)) D CLEARWP Q - F S I=$O(ORDOSE("PI",I)) Q:I'>0 S X=ORDOSE("PI",I) D TXT^ORCHTAB - S DIR(0)="YA",DIR("A")="Include Patient Instructions in Sig? " - S DIR("?")="Enter NO if you do not want these instructions included in the sig for this order",DIR("B")=$S($D(^TMP("ORWORD",$J,PROMPT)):"YES",1:"NO") - W ! S I=0 F S I=$O(ORTX(I)) Q:I'>0 W !,$S(I=1:"Patient Instructions: ",1:" ")_ORTX(I) - D ^DIR I $D(DUOUT)!$D(DTOUT) S ORQUIT=1 Q - I Y D Q ;save text - . K ^TMP("ORWORD",$J,PROMPT,INST) S CNT=0 - . S I=0 F S I=$O(ORDOSE("PI",I)) Q:I'>0 S ^TMP("ORWORD",$J,PROMPT,INST,I,0)=ORDOSE("PI",I),CNT=CNT+1 - . S ^TMP("ORWORD",$J,PROMPT,INST,0)="^^"_CNT_U_CNT_U_DT_U - . S ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"","_$J_","_PROMPT_","_INST_")" - I Y'>0 K ORDIALOG(PROMPT,INST),^TMP("ORWORD",$J,PROMPT,INST) - Q - ; -CLEARWP ; -- Clear INST of wp field PROMPT - K ORDIALOG(PROMPT,INST),^TMP("ORWORD",$J,PROMPT,INST) - Q +ORCDPS2 ;SLC/MKB-Pharmacy dialog utilities ;07:24 AM 5 Apr 2001 [12/31/01 6:35pm] + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**94,116,125,131**;Dec 17, 1997 + ; +COMPLEX() ; -- Single or complex dose? + N X,Y,DIR,DUOUT,DTOUT,COMPLX + S COMPLX=$S($O(ORDIALOG(PROMPT,"?"),-1)>1:1,$L($G(ORDIALOG($$PTR("DURATION"),1))):1,1:0) + I $G(ORTYPE)="Q",$O(ORDIALOG(PROMPT,0)),FIRST Q COMPLX + I $D(ORENEW)!$D(OREWRITE)!$D(ORXFER)!COMPLX Q COMPLX + I $D(OREDIT) Q:$D(ORCOMPLX)!COMPLX COMPLX G CP1 ;Q if complex or 'first, else ask + I 'FIRST S Y=$S($D(ORCOMPLX):ORCOMPLX,1:COMPLX) Q Y +CP1 S DIR(0)="YA",DIR("A")="Complex dose? ",DIR("B")="NO" + S DIR("?")="Enter YES if you wish to enter multiple sets of dosage instructions, a tapering dose, or to limit the duration of a single dose." + D ^DIR S:$D(DTOUT) Y="^" + Q Y + ; +DOSES ; -- Get available common doses + ;S $P(ORDIALOG(PROMPT,0),U,2)=$S(ORCAT="I":"1:20",1:"1:80") + S ORDIALOG(PROMPT,"A")="Dose"_$S(ORCAT="I"&$G(ORIV):" or Rate: ",1:": ") + S $P(ORDIALOG(PROMPT,"?"),",",2)=$S($G(ORIV):" as either a dose amount or infusion rate.",1:" as a dose or amount.") + I FIRST,'$O(ORDIALOG(PROMPT,0)),$G(ORXFER) D SHOWSIG^ORCMED + S ORCOMPLX=$$COMPLEX,MULT=+ORCOMPLX I ORCOMPLX="^" S ORQUIT=1 Q + Q:$G(ORDIALOG(PROMPT,"LIST")) Q:'$D(ORDOSE) +D1 ; -- enter here from ORCMED,NF^ORCDPS to build list + N I,J,X,DD,DRUG,DOSE,CONJ,CNT,UD,COST,TEXT + S (I,CNT)=0,CONJ=$P($G(ORDOSE("MISC")),U,3) S:$L(CONJ) CONJ=" "_CONJ + F S I=$O(ORDOSE(I)) Q:I'>0 D + . S X=ORDOSE(I),DD=+$P(X,U,6),DRUG=ORDOSE("DD",DD) + . ; =TotalDose^Units^U/D^Noun^LocalDose^DispDrugIEN^Cost + . ;DD=Name^Cost^NF^DispUnit^Strength^Units^DoseForm^MaxRefills? + . S DOSE=$P(X,U,5),UD=$P(X,U,3),COST=$P(X,U,7) Q:'$L(DOSE) + . I '$P(X,U) S DOSE=DOSE_CONJ_" "_$S($L($P(DRUG,U,5)):$P(DRUG,U,5)_$P(DRUG,U,6),1:$P(DRUG,U)) + . ;I UD S COST="$"_$J(UD*$P(DRUG,U,2),1,3) ;_" per "_UD_" "_$P(X,U,4) + . S TEXT=DOSE_$S($L(COST):" $"_COST,1:"")_$S($P(DRUG,U,3):" (non-formulary)",1:"") + . S CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=DOSE_U_TEXT + . S ORDIALOG(PROMPT,"LIST","B",TEXT)=DOSE + . S ORDIALOG(PROMPT,"LIST","D",DOSE)=DD ;default DispDrug + . S ORDOSE("DD",DD,DOSE)=$P(ORDOSE(I),U,1,6)_U_$P(DRUG,U,5,6) + . S J=0 F S J=$O(ORDOSE(I,J)) Q:J'>0 D ;xref alt forms of dose + .. S DD=+$P(ORDOSE(I,J),U,6),DRUG=$G(ORDOSE("DD",DD)) + .. S ORDOSE("DD",DD,DOSE)=$P(ORDOSE(I,J),U,1,6)_U_$P(DRUG,U,5,6) + S:CNT ORDIALOG(PROMPT,"LIST")=CNT + Q + ; +CHDOSE ; -- kill dependent values if inst ORI of dose changes + N X,PROMPTS,P,NAME,DOSE,DD S X=$G(ORDIALOG(PROMPT,ORI)) + S X=$$UP^XLFSTR(X),ORDIALOG(PROMPT,ORI)=X ;force uppercase + I X,X'?1.N.E1.A.E K DONE W $C(7),!,"Enter the amount of this drug that the patient is to receive as a dose,",!,"NOT as the number of units per dose." Q + I $L(X)>60,'$D(ORDIALOG(PROMPT,"LIST","B",X)) K DONE W $C(7),!,"Instructions may not be longer than 60 characters." Q + I $G(ORESET)'=X D ;kill dependent values if new/changed dose + . S PROMPTS="STRENGTH^DRUG NAME^DOSE^DISPENSE DRUG^DAYS SUPPLY^QUANTITY^REFILLS" + . F P=1:1:$L(PROMPTS,U) S NAME=$P(PROMPTS,U,P) K ORDIALOG($$PTR(NAME),ORI) + . K ORQTY,ORQTYUNT,ORDRUG,ORDIALOG($$PTR("DISPENSE DRUG"),1) + . K ^TMP("ORWORD",$J,$$PTR("SIG")) + S DOSE=$$PTR("DOSE") I $L(X),'$L($G(ORDIALOG(DOSE,ORI))) D ;set ID + . S DD=+$G(ORDIALOG(PROMPT,"LIST","D",X)) + . S:DD ORDIALOG(DOSE,ORI)=$TR($G(ORDOSE("DD",DD,X)),"^","&") + S DD=+$P($G(ORDIALOG(DOSE,ORI)),"&",6) + I DD,$P($G(ORDOSE("DD",DD)),U,3) D NF^ORCDPS(DD) ;look for FormAlt + Q + ; +EXDOSE ; -- Dose Exit Action + Q:'$O(ORDIALOG(PROMPT,0)) N DRUG,MISC,QUIT,LAST + S ORDRUG=$$DISPDRUG^ORCDPS,DRUG=$G(ORDOSE("DD",+ORDRUG)) + I ORDRUG D I $G(QUIT) S ORQUIT=1 Q + . ;I $P(DRUG,U,10),'$L($P($G(^VA(200,+$G(ORNP),"PS")),U,2)),'$L($P($G(^("PS")),U,3)) W $C(7),!,$P($G(^(0)),U)_" must have a DEA# or VA# to order this drug!" S QUIT=1 Q + . ;I $P(DRUG,U,10)=1 W $C(7),!,"This order will require a wet signature!" + . S ORDIALOG($$PTR("DISPENSE DRUG"),1)=ORDRUG + . D:$G(ORCAT)="O" RESETID^ORCDPS + . N STR,MED S STR=$P(DRUG,U,5)_$P(DRUG,U,6) + . I STR'>0 S:'$G(ORDOSE(1)) ORDIALOG($$PTR("DRUG NAME"),1)=$P(DRUG,U) Q + . S MED=$P($G(^ORD(101.43,+$G(OROI),0)),U) + . I MED'[STR,ORCAT="O"!'$G(ORDOSE(1)) S ORDIALOG($$PTR("STRENGTH"),1)=STR + I +ORDRUG'>0,ORCAT="O" W $C(7),!,"Cannot determine dispense drug - some defaults and order checks may not occur!" +EXD1 ; -kill dangling conjunction, [re]build Sig, get Qty info + S LAST=$O(ORDIALOG(PROMPT,"?"),-1) K ORDIALOG($$PTR("AND/THEN"),LAST) + D ADMIN^ORCDPS3 D:$G(ORTYPE)'="Z" SIG ;[re]build Sig/Text + I ORDRUG,ORCAT="O" D ;set Qty info + . S:$L($P(DRUG,U,4)) ORQTYUNT=$P(DRUG,U,4) + . S MISC=$$ENDCM^PSJORUTL(+ORDRUG),ORQTY=$P(MISC,U,4) + . W:$L($P(MISC,U,2)) !!,$P(MISC,U,2),! + Q + ; +SIG ; -- Create ORDIALOG(SIG) from Instructions PROMPT,ORDOSE,ORDRUG,ORCAT + ; Return text in ^TMP("ORWORD",$J,SIG,INST) + ; [also called from PSJ^ORCSEND1 to build child orders] + ; + N ORT,ORSCH,ORDUR,ORID,ORDD,ORCNJ,ORMISC,ORPREP,ORX,ORI,CNT,ORSIG,ORS,DOSE + S ORT=$$PTR("ROUTE"),ORSCH=$$PTR("SCHEDULE"),ORDUR=$$PTR("DURATION") + S ORID=$$PTR("DOSE"),ORCNJ=$$PTR("AND/THEN"),ORS=$$PTR("SIG") + S ORMISC=$G(ORDOSE("MISC")),ORPREP=$P(ORMISC,U,2) + S ORX=$S(ORCAT="I":"",$L($P(ORMISC,U)):$P(ORMISC,U)_" ",1:"") ;"TAKE " + S (CNT,ORI)=0 F S ORI=$O(ORDIALOG(PROMPT,ORI)) Q:ORI'>0 D + . S DOSE=$G(ORDIALOG(PROMPT,ORI)) Q:'$L(DOSE) + . S ORX=ORX_$$DOSE_$$RTE_$$SCH_$$DUR_$$CONJ + . S CNT=CNT+1,ORSIG(CNT,0)=ORX,ORX="" + Q:CNT'>0 S ORSIG(0)="^^"_CNT_U_CNT_U_DT_U + K ^TMP("ORWORD",$J,ORS,1) M ^(1)=ORSIG S ORDIALOG(PROMPT,"FORMAT")="@" + S ORDIALOG(ORS,1)=$NA(^TMP("ORWORD",$J,ORS,1)) + Q + ; +PTR(X) ; -- Return ptr to prompt OR GTX X + Q +$O(^ORD(101.41,"AB","OR GTX "_X,0)) + ; +DOSE() ; -- Return dosage + N X0,Y S X0=$G(ORDIALOG(ORID,ORI)) ;ID string + S Y=DOSE I ORDRUG,$L(X0) D ;use local dose if common DispDrug + . S:$L($P(X0,"&",5)) Y=$P(X0,"&",5) ;unless Outpt w/total dose + . I ORCAT="O",X0 S Y=$$WORD($P(X0,"&",3))_" "_$P(X0,"&",4) ;u/d + Q Y + ; +WORD(X) ; -- Return words for number X + N X1,X2,Y S X1=$P(+X,"."),X2=$P(+X,".",2) + S Y="" I X1 S Y=$S(X1=1:"ONE",X1=2:"TWO",X1=3:"THREE",X1=4:"FOUR",X1=5:"FIVE",X1=6:"SIX",X1=7:"SEVEN",X1=8:"EIGHT",X1=9:"NINE",X1=10:"TEN",1:X1) + I X2 S Y=Y_$S($L(Y):" AND ",1:"")_$S(X2=5:"ONE-HALF",X2=33!(X2=34):"ONE-THIRD",X2=25:"ONE-FOURTH",X2=66!(X2=67):"TWO-THIRDS",X2=75:"THREE-FOURTHS",1:"."_X2) + Q Y + ; +RTE() ; -- Return expansion of route + N X,X0,Y S X=+$G(ORDIALOG(ORT,ORI)) Q:X'>0 "" + S X0=$G(^PS(51.2,+X,0)),Y="" + I ORCAT="I" S Y=" "_$S($L($P(X0,U,3)):$P(X0,U,3),1:$P(X0,U)) + I ORCAT="O" S Y=" "_$S($L(ORPREP):ORPREP_" ",1:"")_$S($L($P(X0,U,2)):$P(X0,U,2),1:$P(X0,U)) + Q Y + ; +SCH() ; -- Return [outpatient] expansion of schedule + N X,Y S X=$G(ORDIALOG(ORSCH,ORI)) + I $L(X),ORCAT="O" D SCH^PSSUTIL1(.X) + S Y=$S($L(X):" "_X,1:"") + Q Y + ; +DUR() ; -- Return duration + N X,Y S X=$G(ORDIALOG(ORDUR,ORI)),Y="" + I X S Y=" FOR "_$$UP^XLFSTR(X)_$S(+X=X:" DAYS",1:"") + Q Y + ; +CONJ() ; -- Return conjuction + N X,Y S X=$G(ORDIALOG(ORCNJ,ORI)) + S:$L(X)>1 X=$E(X) S:X="E" S="X" + S Y=$S(X="T":", THEN",X="X":" EXCEPT",X="A":" AND",1:"") + Q Y + ; +DOSETEXT ; -- Reset dose text in ORDIALOG(INSTR) for backdoor orders + ; [Called from ORMPS1 - uses ORCAT,PSOI,ORVP,DRUG,INSTR,DOSE] + ; + N ORTYPE,ORDOSE,CONJ,ORDRUG,DRUG0,STRG,ORI,LDOSE,X,PROMPT + S ORTYPE=$S($G(ORCAT)="I":"U",1:"O") + D DOSE^PSSORUTL(.ORDOSE,+PSOI,ORTYPE,+ORVP) + S CONJ=$P($G(ORDOSE("MISC")),U,3) S:$L(CONJ) CONJ=" "_CONJ + S ORDRUG=+$G(ORDIALOG(DRUG,1)),DRUG0=$G(ORDOSE("DD",ORDRUG)) + S STRG=$P(DRUG0,U,5)_$P(DRUG0,U,6) + I '$G(ORDOSE(1)) S ORI=0 F S ORI=$O(ORDIALOG(INSTR,ORI)) Q:ORI'>0 D + . S LDOSE=$G(ORDIALOG(INSTR,ORI)),X=$G(ORDIALOG(DOSE,ORI)) Q:'$L(X) + . S:'X ORDIALOG(INSTR,ORI)=LDOSE_CONJ_" "_$S(STRG:STRG,1:$P(DRUG0,U)) + ; -build Sig/Text if not defined + I '$D(ORDIALOG(+$$PTR("SIG"),1)) S PROMPT=INSTR D SIG + Q + ; +PI ; -- Include Patient Instructions w/Sig in Outpt order? + N X,Y,DIR,DUOUT,DTOUT,DIRUT,ORTX,ORMAX,I,CNT + I $G(ORCAT)'="O" D CLEARWP Q ;!'$O(ORDOSE("PI",0)) + Q:$G(ORENEW) S I=0,ORMAX=57 + I $G(OREDIT)!$G(OREWRITE),$O(^TMP("ORWORD",$J,PROMPT,INST,0)) K ORDOSE("PI") S I=0 F S I=$O(^TMP("ORWORD",$J,PROMPT,INST,I)) Q:I<1 S ORDOSE("PI",I)=$G(^(I,0)) + I '$O(ORDOSE("PI",0)) D CLEARWP Q + F S I=$O(ORDOSE("PI",I)) Q:I'>0 S X=ORDOSE("PI",I) D TXT^ORCHTAB + S DIR(0)="YA",DIR("A")="Include Patient Instructions in Sig? " + S DIR("?")="Enter NO if you do not want these instructions included in the sig for this order",DIR("B")="YES" + W ! S I=0 F S I=$O(ORTX(I)) Q:I'>0 W !,$S(I=1:"Patient Instructions: ",1:" ")_ORTX(I) + D ^DIR I $D(DUOUT)!$D(DTOUT) S ORQUIT=1 Q + I Y D Q ;save text + . K ^TMP("ORWORD",$J,PROMPT,INST) S CNT=0 + . S I=0 F S I=$O(ORDOSE("PI",I)) Q:I'>0 S ^TMP("ORWORD",$J,PROMPT,INST,I,0)=ORDOSE("PI",I),CNT=CNT+1 + . S ^TMP("ORWORD",$J,PROMPT,INST,0)="^^"_CNT_U_CNT_U_DT_U + . S ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"","_$J_","_PROMPT_","_INST_")" + I Y'>0 K ORDIALOG(PROMPT,INST),^TMP("ORWORD",$J,PROMPT,INST) + Q + ; +CLEARWP ; -- Clear INST of wp field PROMPT + K ORDIALOG(PROMPT,INST),^TMP("ORWORD",$J,PROMPT,INST) + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDPS3.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDPS3.m index d27c1611..149b6f96 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDPS3.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDPS3.m @@ -1,164 +1,143 @@ -ORCDPS3 ;SLC/MKB-Pharmacy dialog utilities ;09/11/07 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**94,116,134,158,149,190,277,243**;Dec 17, 1997;Build 242 - ; -START ; -- Start Date entry action - S $P(ORDIALOG(PROMPT,0),":",3)=$S($G(ORCAT)="I":"ETRX",1:"EX") - I $G(ORCAT)'="I" K ORSD K:$G(ORENEW)!$G(OREWRITE)!$D(OREDIT) ORDIALOG(PROMPT,INST) ;Inpt only - Q - ; -ADMIN ; -- Return default admin time for order in ORSD - ; Called from EXDOSE^ORCDPS2 - Q:$D(ORSD) Q:$G(ORCAT)'="I" ;inpt only - N PSOI,PSIFN,SCH,CNJ,ORI,ORX - S PSOI=+$P($G(^ORD(101.43,+$G(OROI),0)),U,2) - S PSIFN=$S($G(ORENEW):$G(^OR(100,+$G(ORIFN),4)),1:"") - S SCH=$$PTR^ORCD("OR GTX SCHEDULE"),CNJ=$$PTR^ORCD("OR GTX AND/THEN"),ORX="" - S ORI=0 F S ORI=$O(ORDIALOG(PROMPT,ORI)) Q:ORI<1 S ORX=ORX_$S($L(ORX):U,1:"")_$G(ORDIALOG(CNJ,ORI))_";"_$G(ORDIALOG(SCH,ORI)) - S ORSD=$$FIRST(+ORVP,+$G(ORWARD),PSOI,ORX,PSIFN,"") - S:$P(ORSD,U)="NEXT" ORSD="NEXTA^"_$P(ORSD,U,2,99) - Q - ; -FIRST(DFN,WARD,OI,DATA,ORDER,ADMIN) ; -- Return expected first admin time of order - N CNT,ORCNT,ORI,J,ORZ,Y,SCH,ORX,TNUM - I '$G(DFN)!'$G(OI) Q "" - S ORCNT=0 F ORI=1:1:$L(DATA,"^") S ORZ=$P(DATA,U,ORI) D Q:$E(ORZ)="T" - .S TNUM=$$NUMCHAR(ORZ,";") Q:TNUM=0 - .F CNT=1:1:TNUM D - .. S SCH=$P(ORZ,";",CNT+1) Q:'$L(SCH) S ORCNT=ORCNT+1 - .. I ORCNT>1 S ADMIN="" - .. S ORX(ORCNT)=$$STARTSTP^PSJORPOE(DFN,SCH,OI,WARD,$G(ORDER),$G(ADMIN)) - S Y=9999999,J=0 - F ORI=1:1:ORCNT S ORZ=$P(ORX(ORI),U,4) I ORZ0) K ORDIALOG(PROMPT,INST),^TMP($J,"ORCDPS3 NOW") Q - S ORDIALOG(PROMPT,INST)=1 I $G(ORCOMPLX) D - . W $C(7),!," >> First Dose NOW is in addition to those already entered. <<" - . W !," >> Please adjust the duration of the first one, if necessary. <<" - K ^TMP($J,"ORCDPS3 NOW") - Q - ; -DEFSTRT ; -- Returns default start date/time in Y - ; Expects PROMPT,INST,ORDIALOG,ORSD to be defined - ; - Q:$G(ORCAT)="O" Q:$G(ORTYPE)="Z" ;skip if outpt or editor - N LAST,STRT,DUR,D1,D2,OFF,F1,F2,UNT,Y1,Y2,I,J K Y - S LAST=+$O(ORDIALOG(+$$PTR^ORCD("OR GTX INSTRUCTIONS"),INST),-1) - S STRT=$G(ORDIALOG(PROMPT,LAST)) - I LAST'>0!'$L(STRT) S:$L($P($G(ORSD),U)) Y=$P(ORSD,U) Q ;first inst - S DUR=$G(ORDIALOG(+$$PTR^ORCD("OR GTX DURATION"),LAST)) - I +DUR'>0 S Y=STRT Q ;no duration = same start - S DUR=$$FMDUR(DUR) I STRT D Q ;FM date/time, so just add - . N X,%DT S %DT="TX",X=STRT_"+"_DUR D ^%DT - . I Y'>0 S Y=STRT ;error - S D1=+DUR,D2=$P(DUR,D1,2) S:(STRT="NEXTA")!(STRT="CLOSEST") STRT="NOW" - S OFF=$P(STRT,"+",2) I '$L(OFF) S Y=STRT_"+"_DUR Q ;no prev offset - S F1=+OFF,F2=$P(OFF,F1,2),UNT=F2,Y=STRT - I D2=F2 S Y=$P(STRT,"+")_"+"_(D1+F1)_UNT Q ;same units - F I="S","'","H","D","W","M" I (F2=I)!(D2=I) S UNT=I D Q - . S:D2=UNT Y1=D1,X1=F1,X2=F2 ; Y1=# in UNT - . S:F2=UNT Y1=F1,X1=D1,X2=D2 ; X1=# in other units X2 - . F J=1:1 S Z=$T(CONV+J) Q:Z["ZZZZ" I $P(Z,";",3,4)=(X2_";"_UNT) S Y2=+$P(Z,";",5) Q - . S Y=$P(STRT,"+")_"+"_(Y1+$S(Y2:Y2*X1,1:0))_UNT - Q - ; -FMDUR(X) ; -- convert '# DAYS' to #D - N X1,X2,Y I +X'>0 Q "" - S X1=+X,X2=$P(X," ",2) S:'$L(X2) X2="DAYS" - S Y=X1_$S("MINUTES"[X2:"'",1:$E(X2)) - Q Y - ; -CONV ;;unit;unit;factor - ;;';S;60 - ;;H;';60 - ;;H;S;3600 - ;;D;H;24 - ;;D;';1440 - ;;D;S;86400 - ;;W;D;7 - ;;W;H;168 - ;;W;';10080 - ;;W;S;604800 - ;;M;W;4 - ;;M;D;30 - ;;M;H;720 - ;;M;';43200 - ;;M;S;2592000 - ;;ZZZZ - ; -ASKDUR() ; -- Returns 1 or 0, if Duration prompt should be asked - K ^TMP($J,"ORCDPS3 ASKDUR") - N X,Y I '$G(ORCOMPLX) K ORDIALOG(PROMPT,INST) Q 0 - S Y=1 G:'$L($G(ORSCH)) ADQ ;no schedule - D AP^PSS51P1("PSJ",,,,"ORCDPS3 ASKDUR") - S X=+$O(^TMP($J,"ORCDPS3 ASKDUR","APPSJ",ORSCH,"")) G:X'>0 ADQ - ;S X=+$O(^PS(51.1,"APPSJ",ORSCH,0)) G:X'>0 ADQ - S:^TMP($J,"ORCDPS3 ASKDUR",X,5)="O" Y=0 - ;S:$P($G(^PS(51.1,X,0)),U,5)="O" Y=0 -ADQ ; - K ^TMP($J,"ORCDPS3 ASKDUR") - Q Y - ; -CKDUR(X) ; -- Returns validated form of duration X, or null if invalid - N X1,X2,Y,Z S Y="" - S X1=+$G(X),X2=$P($G(X),X1,2) I X1'>0 Q "" - S X2=$$UP^XLFSTR(X2),X2=$$STRIP^XLFSTR(X2," ") S:'$L(X2) X2="DAYS" - F Z="MONTHS^&MONTHS&MONS","WEEKS^&WEEKS&WKS","DAYS^&DAYS&DYS","HOURS^&HOURS&HRS","MINUTES^&MINUTES&MINS'","SECONDS^&SECONDS&SECS" I $P(Z,U,2)[("&"_X2) S Y=$P(Z,U) Q - S:$L(Y) Y=X1_" "_$S(X1=1:$E(Y,1,$L(Y)-1),1:Y) ;strip trailing 's' - Q Y - ; -DUR ; -- Process duration [from P-S Action] - N X S X=$G(ORDIALOG(PROMPT,ORI)),X=$$CKDUR(X) - I '$L(X) K DONE W $C(7),!,ORDIALOG(PROMPT,"?"),! Q - S ORDIALOG(PROMPT,ORI)=X D:$G(ORESET)'=X CHANGED^ORCDPS1("QUANTITY") - Q - ; -TEST(START,DURTN) ; -- test DEFSTRT - N INST,ORSD,ORDIALOG,PROMPT - S ORDIALOG(136,1)="",INST=2,ORSD="NOW",PROMPT=6 - S:$L($G(START)) ORDIALOG(6,1)=START S:$G(DURTN) ORDIALOG(153,1)=DURTN - D DEFSTRT W !,Y - Q - ; -SC ; -- Dialog validation, to ask SC questions - ; Expects ORIFN, ORDA, and ORDER - ; - Q:'$L($T(SCNEW^PSOCP)) Q:'$G(ORIFN) Q:'$G(ORDA) - Q:$P($G(^OR(100,ORIFN,0)),U,12)'="O" Q:$P($G(^(8,ORDA,0)),U,2)'="NW" Q:$P($G(^(0)),U,15)="" - ; - N OR3,ORDRUG,PSIFN,ORX,I,J,DIE,DR,DA,X,Y,DTOUT,ORIGVIEW,DFN - S OR3=$G(^OR(100,ORIFN,3)),X=$P(OR3,U,11) I X>2 Q ;new, edit, or renew - I X S Y=$P(OR3,U,5),PSIFN=$G(^OR(100,Y,4)) ;get PS# if edit/renewal - S ORDRUG=$$VALUE^ORCSAVE2(ORIFN,"DRUG") - D SCNEW^PSOCP(.ORX,+ORVP,ORDRUG,$G(PSIFN)) Q:'$D(ORX) - S DIE="^OR(100,",DA=ORIFN,DR="",J=0 - F I="SC","MST","AO","IR","EC","HNC","CV" S J=J+1 I $D(ORX(I)) S X=ORX(I) S:I="CV"&(X="") X=1 S DR=DR_";5"_J_"R"_$S($L(X):"//"_$S(X:"YES",1:"NO"),1:"") - S:$E(DR)=";" DR=$E(DR,2,999) Q:'$L(DR) S ORIGVIEW=1 - I $D(ORX("SC")) S DFN=+ORVP D DIS^DGRPDB ;show current SC data - W !!,"Is "_$$ORDITEM^ORCACT(ORDER)_" for treatment related to:" - D ^DIE S:$D(DTOUT)!$D(Y) ORQUIT=1 - Q +ORCDPS3 ;SLC/MKB-Pharmacy dialog utilities ;11/25/02 09:47 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**94,116,134,158,149,190,277**;Dec 17, 199;Build 13 + ; +START ; -- Start Date entry action + S $P(ORDIALOG(PROMPT,0),":",3)=$S($G(ORCAT)="I":"ETRX",1:"EX") + I $G(ORCAT)'="I" K ORSD K:$G(ORENEW)!$G(OREWRITE)!$D(OREDIT) ORDIALOG(PROMPT,INST) ;Inpt only + Q + ; +ADMIN ; -- Return default admin time for order in ORSD + ; Called from EXDOSE^ORCDPS2 + Q:$D(ORSD) Q:$G(ORCAT)'="I" ;inpt only + N PSOI,PSIFN,SCH,CNJ,ORI,ORX + S PSOI=+$P($G(^ORD(101.43,+$G(OROI),0)),U,2) + S PSIFN=$S($G(ORENEW):$G(^OR(100,+$G(ORIFN),4)),1:"") + S SCH=$$PTR^ORCD("OR GTX SCHEDULE"),CNJ=$$PTR^ORCD("OR GTX AND/THEN"),ORX="" + S ORI=0 F S ORI=$O(ORDIALOG(PROMPT,ORI)) Q:ORI<1 S ORX=ORX_$S($L(ORX):U,1:"")_$G(ORDIALOG(CNJ,ORI))_";"_$G(ORDIALOG(SCH,ORI)) + S ORSD=$$FIRST(+ORVP,+$G(ORWARD),PSOI,ORX,PSIFN) + S:$P(ORSD,U)="NEXT" ORSD="NEXTA^"_$P(ORSD,U,2,99) + Q + ; +FIRST(DFN,WARD,OI,DATA,ORDER) ; -- Return expected first admin time of order + N ORCNT,ORI,J,ORZ,Y,SCH,ORX I '$G(DFN)!'$G(OI) Q "" + S ORCNT=0 F ORI=1:1:$L(DATA,"^") S ORZ=$P(DATA,U,ORI) D Q:$E(ORZ)="T" + . S SCH=$P(ORZ,";",2) Q:'$L(SCH) S ORCNT=ORCNT+1 + . S ORX(ORCNT)=$$STARTSTP^PSJORPOE(DFN,SCH,OI,WARD,$G(ORDER)) + S Y=9999999,J=0 + F ORI=1:1:ORCNT S ORZ=$P(ORX(ORI),U,4) I ORZ0) K ORDIALOG(PROMPT,INST) Q + S ORDIALOG(PROMPT,INST)=1 I $G(ORCOMPLX) D + . W $C(7),!," >> First Dose NOW is in addition to those already entered. <<" + . W !," >> Please adjust the duration of the first one, if necessary. <<" + Q + ; +DEFSTRT ; -- Returns default start date/time in Y + ; Expects PROMPT,INST,ORDIALOG,ORSD to be defined + ; + Q:$G(ORCAT)="O" Q:$G(ORTYPE)="Z" ;skip if outpt or editor + N LAST,STRT,DUR,D1,D2,OFF,F1,F2,UNT,Y1,Y2,I,J K Y + S LAST=+$O(ORDIALOG(+$$PTR^ORCD("OR GTX INSTRUCTIONS"),INST),-1) + S STRT=$G(ORDIALOG(PROMPT,LAST)) + I LAST'>0!'$L(STRT) S:$L($P($G(ORSD),U)) Y=$P(ORSD,U) Q ;first inst + S DUR=$G(ORDIALOG(+$$PTR^ORCD("OR GTX DURATION"),LAST)) + I +DUR'>0 S Y=STRT Q ;no duration = same start + S DUR=$$FMDUR(DUR) I STRT D Q ;FM date/time, so just add + . N X,%DT S %DT="TX",X=STRT_"+"_DUR D ^%DT + . I Y'>0 S Y=STRT ;error + S D1=+DUR,D2=$P(DUR,D1,2) S:(STRT="NEXTA")!(STRT="CLOSEST") STRT="NOW" + S OFF=$P(STRT,"+",2) I '$L(OFF) S Y=STRT_"+"_DUR Q ;no prev offset + S F1=+OFF,F2=$P(OFF,F1,2),UNT=F2,Y=STRT + I D2=F2 S Y=$P(STRT,"+")_"+"_(D1+F1)_UNT Q ;same units + F I="S","'","H","D","W","M" I (F2=I)!(D2=I) S UNT=I D Q + . S:D2=UNT Y1=D1,X1=F1,X2=F2 ; Y1=# in UNT + . S:F2=UNT Y1=F1,X1=D1,X2=D2 ; X1=# in other units X2 + . F J=1:1 S Z=$T(CONV+J) Q:Z["ZZZZ" I $P(Z,";",3,4)=(X2_";"_UNT) S Y2=+$P(Z,";",5) Q + . S Y=$P(STRT,"+")_"+"_(Y1+$S(Y2:Y2*X1,1:0))_UNT + Q + ; +FMDUR(X) ; -- convert '# DAYS' to #D + N X1,X2,Y I +X'>0 Q "" + S X1=+X,X2=$P(X," ",2) S:'$L(X2) X2="DAYS" + S Y=X1_$S("MINUTES"[X2:"'",1:$E(X2)) + Q Y + ; +CONV ;;unit;unit;factor + ;;';S;60 + ;;H;';60 + ;;H;S;3600 + ;;D;H;24 + ;;D;';1440 + ;;D;S;86400 + ;;W;D;7 + ;;W;H;168 + ;;W;';10080 + ;;W;S;604800 + ;;M;W;4 + ;;M;D;30 + ;;M;H;720 + ;;M;';43200 + ;;M;S;2592000 + ;;ZZZZ + ; +ASKDUR() ; -- Returns 1 or 0, if Duration prompt should be asked + N X,Y I '$G(ORCOMPLX) K ORDIALOG(PROMPT,INST) Q 0 + S Y=1 G:'$L($G(ORSCH)) ADQ ;no schedule + S X=+$O(^PS(51.1,"APPSJ",ORSCH,0)) G:X'>0 ADQ + S:$P($G(^PS(51.1,X,0)),U,5)="O" Y=0 +ADQ Q Y + ; +CKDUR(X) ; -- Returns validated form of duration X, or null if invalid + N X1,X2,Y,Z S Y="" + S X1=+$G(X),X2=$P($G(X),X1,2) I X1'>0 Q "" + S X2=$$UP^XLFSTR(X2),X2=$$STRIP^XLFSTR(X2," ") S:'$L(X2) X2="DAYS" + F Z="MONTHS^&MONTHS&MONS","WEEKS^&WEEKS&WKS","DAYS^&DAYS&DYS","HOURS^&HOURS&HRS","MINUTES^&MINUTES&MINS'","SECONDS^&SECONDS&SECS" I $P(Z,U,2)[("&"_X2) S Y=$P(Z,U) Q + S:$L(Y) Y=X1_" "_$S(X1=1:$E(Y,1,$L(Y)-1),1:Y) ;strip trailing 's' + Q Y + ; +DUR ; -- Process duration [from P-S Action] + N X S X=$G(ORDIALOG(PROMPT,ORI)),X=$$CKDUR(X) + I '$L(X) K DONE W $C(7),!,ORDIALOG(PROMPT,"?"),! Q + S ORDIALOG(PROMPT,ORI)=X D:$G(ORESET)'=X CHANGED^ORCDPS1("QUANTITY") + Q + ; +TEST(START,DURTN) ; -- test DEFSTRT + N INST,ORSD,ORDIALOG,PROMPT + S ORDIALOG(136,1)="",INST=2,ORSD="NOW",PROMPT=6 + S:$L($G(START)) ORDIALOG(6,1)=START S:$G(DURTN) ORDIALOG(153,1)=DURTN + D DEFSTRT W !,Y + Q + ; +SC ; -- Dialog validation, to ask SC questions + ; Expects ORIFN, ORDA, and ORDER + ; + Q:'$L($T(SCNEW^PSOCP)) Q:'$G(ORIFN) Q:'$G(ORDA) + Q:$P($G(^OR(100,ORIFN,0)),U,12)'="O" Q:$P($G(^(8,ORDA,0)),U,2)'="NW" Q:$P($G(^(0)),U,15)="" + ; + N OR3,ORDRUG,PSIFN,ORX,I,J,DIE,DR,DA,X,Y,DTOUT,ORIGVIEW,DFN + S OR3=$G(^OR(100,ORIFN,3)),X=$P(OR3,U,11) I X>2 Q ;new, edit, or renew + I X S Y=$P(OR3,U,5),PSIFN=$G(^OR(100,Y,4)) ;get PS# if edit/renewal + S ORDRUG=$$VALUE^ORCSAVE2(ORIFN,"DRUG") + D SCNEW^PSOCP(.ORX,+ORVP,ORDRUG,$G(PSIFN)) Q:'$D(ORX) + S DIE="^OR(100,",DA=ORIFN,DR="",J=0 + F I="SC","MST","AO","IR","EC","HNC","CV" S J=J+1 I $D(ORX(I)) S X=ORX(I) S:I="CV"&(X="") X=1 S DR=DR_";5"_J_"R"_$S($L(X):"//"_$S(X:"YES",1:"NO"),1:"") + S:$E(DR)=";" DR=$E(DR,2,999) Q:'$L(DR) S ORIGVIEW=1 + I $D(ORX("SC")) S DFN=+ORVP D DIS^DGRPDB ;show current SC data + W !!,"Is "_$$ORDITEM^ORCACT(ORDER)_" for treatment related to:" + D ^DIE S:$D(DTOUT)!$D(Y) ORQUIT=1 + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDPSH.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDPSH.m index a49a1a44..add1e7ca 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDPSH.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDPSH.m @@ -1,101 +1,101 @@ -ORCDPSH ;SLC/CLA-Pharmacy dialog utilities-Non-VA Meds ; 09 April 2003 11:00 AM - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**190,215,243**;Dec 17, 1997;Build 242 - ; - ; DBIA 2418 START^PSSJORDF ^TMP("PSJMR",$J) - ; DBIA 3166 EN^PSSDIN ^TMP("PSSDIN",$J) - ; -EN(TYPE) ; -- entry action for Meds dialogs - S ORDG=+$O(^ORD(100.98,"B","NV RX",0)),ORCAT="O" - K ^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) - I $G(ORENEW)!$G(OREWRITE)!$D(OREDIT)!$G(ORXFER) D - . K ORDIALOG($$PTR("START DATE/TIME"),1) - . K ORDIALOG($$PTR("NOW"),1) - . I $D(OREDIT),'$O(ORDIALOG($$PTR^ORCD("OR GTX INSTRUCTIONS"),0)) K ^TMP("ORWORD",$J) - Q - ; -EN1 ; -- setup Non-VA Meds dialog for quick order editor using ORDG - N DG S DG=$P($G(^ORD(100.98,+$G(ORDG),0)),U,3) - S ORINPT=0,ORCAT="O" - K ^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) - Q - ; -ENOI ; -- setup OI prompt - S ORDIALOG(PROMPT,"D")="S.NV RX" - Q - ; -CHANGED(X) ; -- Kill dependent values when prompt X changes - N PROMPTS,NAME,PTR,P,I - S PROMPTS=X I X="OI" D - . S PROMPTS="INSTRUCTIONS^ROUTE^SCHEDULE^START DATE/TIME^DOSE^DISPENSE DRUG^SIG^PATIENT INSTRUCTIONS" - . K ORDRUG,ORDOSE,OROUTE,ORSCH,ORSD,ORDSUP,ORQTY,ORQTYUNT,OREFILLS,ORCOPAY - . K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) - F P=1:1:$L(PROMPTS,U) S NAME=$P(PROMPTS,U,P) D - . S PTR=$$PTR(NAME) Q:'PTR - . S I=0 F S I=$O(ORDIALOG(PTR,I)) Q:I'>0 K ORDIALOG(PTR,I) - . K ORDIALOG(PTR,"LIST"),^TMP("ORWORD",$J,PTR) - Q - ; -ORDITM(OI) ; -- Check OI inactive date & type, get dependent info - Q:OI'>0 ;quit - no value - N ORPS,PSOI S ORPS=$G(^ORD(101.43,+OI,"PS")),PSOI=+$P($G(^(0)),U,2) - S ORIV=$S($P(ORPS,U)=2:1,1:0) - I '$P(ORPS,U,7) W $C(7),!,"This drug may not be used in a non-VA med order." S ORQUIT=1 D WAIT Q -OI1 ; ck NF status (don't care if Non-VA Meds are formulary or not) -OI2 ; -get selectable routes, doses [also called from NF^ORCDPS] - D:'$D(^TMP("PSJMR",$J)) START^PSSJORDF(PSOI,$G(ORCAT)) ;DBIA 2418 - I '$D(ORDOSE) D - . D DOSE^PSSORUTL(.ORDOSE,PSOI,"X",+ORVP) - . K:$G(ORDOSE(1))=-1 ORDOSE - Q - ; -NFI(OI) ; -- Show NFI restrictions, if exist - N PSOI,I,J,LCNT,MAX,X,STOP - S PSOI=+$P($G(^ORD(101.43,+$G(OI),0)),U,2) - D EN^PSSDIN(PSOI,"") Q:'$D(^TMP("PSSDIN",$J,"OI",PSOI)) ;DBIA 3166 - S I=0,LCNT=0,MAX=$S($G(IOBM)&$G(IOTM):IOBM-IOTM+1,1:24) W ! - F S I=$O(^TMP("PSSDIN",$J,"OI",PSOI,I)) Q:I'>0 D - . S J=0 F S J=$O(^TMP("PSSDIN",$J,"OI",PSOI,I,J)) Q:J'>0 S X=$G(^(J)) D Q:$G(STOP) - .. S LCNT=LCNT+1 I LCNT' to continue ..." R X:DTIME - Q - ; -ROUTES ; -- Get allowable med routes - Q:$G(ORDIALOG(PROMPT,"LIST")) N I,X,CNT S (I,CNT)=0 - F S I=$O(^TMP("PSJMR",$J,I)) Q:I'>0 S X=^(I),CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=$P(X,U,3)_U_$P(X,U,1,2),ORDIALOG(PROMPT,"LIST","B",$P(X,U))=$P(X,U,3) - S:$G(CNT) ORDIALOG(PROMPT,"LIST")=CNT - S REQD=0 - Q - ; -DEFRTE ; -- Get default route - N INST1 S INST1=$O(ORDIALOG(PROMPT,0)) S:INST1'>0 INST1=INST ;1st inst - I INST1=INST S Y=+$P($G(^TMP("PSJMR",$J,1)),U,3) K:Y'>0 Y Q - S Y=+$G(ORDIALOG(PROMPT,INST1)) K:Y'>0 Y S:$G(Y) EDITONLY=1 - Q - ; -CKSCH ; -- validate schedule [Called from P-S Action] - N ORX S ORX=ORDIALOG(PROMPT,ORI) Q:ORX=$G(ORESET) K ORSD ;reset - D EN^PSSGS0(.ORX,"X") - I $D(ORX) S ORDIALOG(PROMPT,ORI)=ORX D CHANGED("QUANTITY") Q ;ok - W $C(7),!,"Enter a standard schedule for administering this medication or one of your own,",!,"up to 20 characters.",! - K DONE - Q - ; -PTR(X) ; -- Return ptr to prompt OR GTX X - Q +$O(^ORD(101.41,"AB","OR GTX "_X,0)) - ; -EXIT ; -- exit action for Meds dialogs - S:$G(ORXNP) ORNP=ORXNP - K ORXNP,ORINPT,ORCAT,ORPKG,OROI,ORIV,ORDRUG,ORDOSE,OROUTE,ORSCH,ORSD,ORDSUP,OREFILLS,ORQTY,ORQTYUNT,ORCOPAY,PSJNOPC,ORCOMPLX - K ^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) - Q +ORCDPSH ;SLC/CLA-Pharmacy dialog utilities-Non-VA Meds ; 09 April 2003 11:00 AM + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**190,215**;Dec 17, 1997 + ; + ; DBIA 2418 START^PSSJORDF ^TMP("PSJMR",$J) + ; DBIA 3166 EN^PSSDIN ^TMP("PSSDIN",$J) + ; +EN(TYPE) ; -- entry action for Meds dialogs + S ORDG=+$O(^ORD(100.98,"B","NV RX",0)),ORCAT="O" + K ^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) + I $G(ORENEW)!$G(OREWRITE)!$D(OREDIT)!$G(ORXFER) D + . K ORDIALOG($$PTR("START DATE/TIME"),1) + . K ORDIALOG($$PTR("NOW"),1) + . I $D(OREDIT),'$O(ORDIALOG($$PTR^ORCD("OR GTX INSTRUCTIONS"),0)) K ^TMP("ORWORD",$J) + Q + ; +EN1 ; -- setup Non-VA Meds dialog for quick order editor using ORDG + N DG S DG=$P($G(^ORD(100.98,+$G(ORDG),0)),U,3) + S ORINPT=0,ORCAT="O" + K ^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) + Q + ; +ENOI ; -- setup OI prompt + S ORDIALOG(PROMPT,"D")="S.NV RX" + Q + ; +CHANGED(X) ; -- Kill dependent values when prompt X changes + N PROMPTS,NAME,PTR,P,I + S PROMPTS=X I X="OI" D + . S PROMPTS="INSTRUCTIONS^ROUTE^SCHEDULE^START DATE/TIME^DOSE^DISPENSE DRUG^SIG^PATIENT INSTRUCTIONS" + . K ORDRUG,ORDOSE,OROUTE,ORSCH,ORSD,ORDSUP,ORQTY,ORQTYUNT,OREFILLS,ORCOPAY + . K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) + F P=1:1:$L(PROMPTS,U) S NAME=$P(PROMPTS,U,P) D + . S PTR=$$PTR(NAME) Q:'PTR + . S I=0 F S I=$O(ORDIALOG(PTR,I)) Q:I'>0 K ORDIALOG(PTR,I) + . K ORDIALOG(PTR,"LIST"),^TMP("ORWORD",$J,PTR) + Q + ; +ORDITM(OI) ; -- Check OI inactive date & type, get dependent info + Q:OI'>0 ;quit - no value + N ORPS,PSOI S ORPS=$G(^ORD(101.43,+OI,"PS")),PSOI=+$P($G(^(0)),U,2) + S ORIV=$S($P(ORPS,U)=2:1,1:0) + I '$P(ORPS,U,7) W $C(7),!,"This drug may not be used in a non-VA med order." S ORQUIT=1 D WAIT Q +OI1 ; ck NF status (don't care if Non-VA Meds are formulary or not) +OI2 ; -get selectable routes, doses [also called from NF^ORCDPS] + D:'$D(^TMP("PSJMR",$J)) START^PSSJORDF(PSOI,$G(ORCAT)) ;DBIA 2418 + I '$D(ORDOSE) D + . D DOSE^PSSORUTL(.ORDOSE,PSOI,"X",+ORVP) + . K:$G(ORDOSE(1))=-1 ORDOSE + Q + ; +NFI(OI) ; -- Show NFI restrictions, if exist + N PSOI,I,J,LCNT,MAX,X,STOP + S PSOI=+$P($G(^ORD(101.43,+$G(OI),0)),U,2) + D EN^PSSDIN(PSOI,"") Q:'$D(^TMP("PSSDIN",$J,"OI",PSOI)) ;DBIA 3166 + S I=0,LCNT=0,MAX=$S($G(IOBM)&$G(IOTM):IOBM-IOTM+1,1:24) W ! + F S I=$O(^TMP("PSSDIN",$J,"OI",PSOI,I)) Q:I'>0 D + . S J=0 F S J=$O(^TMP("PSSDIN",$J,"OI",PSOI,I,J)) Q:J'>0 S X=$G(^(J)) D Q:$G(STOP) + .. S LCNT=LCNT+1 I LCNT' to continue ..." R X:DTIME + Q + ; +ROUTES ; -- Get allowable med routes + Q:$G(ORDIALOG(PROMPT,"LIST")) N I,X,CNT S (I,CNT)=0 + F S I=$O(^TMP("PSJMR",$J,I)) Q:I'>0 S X=^(I),CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=$P(X,U,3)_U_$P(X,U,1,2),ORDIALOG(PROMPT,"LIST","B",$P(X,U))=$P(X,U,3) + S:$G(CNT) ORDIALOG(PROMPT,"LIST")=CNT + S REQD=0 + Q + ; +DEFRTE ; -- Get default route + N INST1 S INST1=$O(ORDIALOG(PROMPT,0)) S:INST1'>0 INST1=INST ;1st inst + I INST1=INST S Y=+$P($G(^TMP("PSJMR",$J,1)),U,3) K:Y'>0 Y Q + S Y=+$G(ORDIALOG(PROMPT,INST1)) K:Y'>0 Y S:$G(Y) EDITONLY=1 + Q + ; +CKSCH ; -- validate schedule [Called from P-S Action] + N ORX S ORX=ORDIALOG(PROMPT,ORI) Q:ORX=$G(ORESET) K ORSD ;reset + D EN^PSSGS0(.ORX,"X") + I $D(ORX) S ORDIALOG(PROMPT,ORI)=ORX D CHANGED("QUANTITY") Q ;ok + W $C(7),!,"Enter either a standard administration schedule or one of your own,",!,"up to 70 characters and no more than 2 spaces.",! + K DONE + Q + ; +PTR(X) ; -- Return ptr to prompt OR GTX X + Q +$O(^ORD(101.41,"AB","OR GTX "_X,0)) + ; +EXIT ; -- exit action for Meds dialogs + S:$G(ORXNP) ORNP=ORXNP + K ORXNP,ORINPT,ORCAT,ORPKG,OROI,ORIV,ORDRUG,ORDOSE,OROUTE,ORSCH,ORSD,ORDSUP,OREFILLS,ORQTY,ORQTYUNT,ORCOPAY,PSJNOPC,ORCOMPLX + K ^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDPSIV.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDPSIV.m index 372765c9..94ebc233 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDPSIV.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDPSIV.m @@ -1,251 +1,102 @@ -ORCDPSIV ;SLC/MKB-Pharmacy IV dialog utilities ;5/07/08 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,38,48,158,195,243**;Dec 17, 1997;Build 242 - ;Per VHA Directive 2004-038, this routine should not be modified. -CKSCH ; -- validate schedule [Called from P-S Action] - N ORX S ORX=ORDIALOG(PROMPT,ORI) Q:ORX=$G(ORESET) K ORSD - D EN^PSSGS0(.ORX,"I") - I $D(ORX) S ORDIALOG(PROMPT,ORI)=ORX Q - W $C(7),!,"Enter a standard schedule for administering this medication." - Q -ISONETIM(SCH) ; - N DUR - I SCH="" Q 0 - K ^TMP($J,"ORCDPSIV GETSCHTYP") - D ZERO^PSS51P1(,SCH,"PSJ","O","ORCDPSIV GETSCHTYP") - I +^TMP($J,"ORCDPSIV GETSCHTYP",0)>0 D Q 1 - .S DUR=$$PTR^ORCD("OR GTX DURATION") - .I $G(ORDIALOG(DUR,1))="" Q - .S ORDIALOG(DUR,1)="" - .W !,"IV Orders with a schedule type of one-time cannot have a duration." - .W !,"The duration has been deleted from this quick order." H 1 - K ^TMP($J,"ORCDPSIV GETSCHTYP") - Q 0 - ; -PROVIDER ; -- Check provider, if authorized to write med orders - I $D(^XUSEC("OREMAS",DUZ)),'$$GET^XPAR("ALL","OR OREMAS MED ORDERS") W $C(7),!!,"OREMAS key holders may not enter medication orders." S ORQUIT=1 Q - N PS,NAME S PS=$G(^VA(200,+$G(ORNP),"PS")),NAME=$P($G(^(20)),U,2) - I '$L(NAME) S NAME=$P(^VA(200,+$G(ORNP),0),U) - I '$P(PS,U) W $C(7),!!,NAME_" is not authorized to write medication orders!" S ORQUIT=1 - I $P(PS,U,4),$$NOW^XLFDT>$P(PS,U,4) W $C(7),!!,NAME_" is no longer authorized to write medication orders!" S ORQUIT=1 - I $G(ORQUIT) W !,"You must select another provider to continue.",! S PS=$$MEDPROV I PS S ORXNP=ORNP,ORNP=PS K ORQUIT - Q - ; -MEDPROV() ; -- Return ordering med provider - N X,Y,D,DIC - S DIC=200,DIC(0)="AEQ",DIC("A")="Select PROVIDER: ",D="AK.PROVIDER" - S DIC("S")="I $P($G(^(""PS"")),U),'$P(^(""PS""),U,4)!($P(^(""PS""),U,4)>$$NOW^XLFDT)" - D IX^DIC S:Y>0 Y=+Y I Y'>0 S Y="^" - Q Y - ; -CHANGED(TYPE) ; -- Kill dependent values when OI changes - N PROMPTS,NAME,PTR,P,I - Q:'$L($G(TYPE)) S PROMPTS="" - S:TYPE="B" PROMPTS="VOLUME" - S:TYPE="A" PROMPTS="STRENGTH PSIV^UNITS" - S:TYPE="T" PROMPTS="INFUSION RATE^SCHEDULE" - F P=1:1:$L(PROMPTS,U) S NAME=$P(PROMPTS,U,P) D - . S PTR=$O(^ORD(101.41,"AB","OR GTX "_NAME,0)) Q:'PTR - . S I=0 F S I=$O(ORDIALOG(PTR,I)) Q:I'>0 K ORDIALOG(PTR,I) - . K ORDIALOG(PTR,"LIST") - Q - ; -INACTIVE(TYPE) ; -- Check OI inactive date - N OI,X,I,PSOI,DEA,EXIT S:$G(TYPE)'="A" TYPE="S" - S OI=+$G(ORDIALOG(PROMPT,INST)) Q:OI'>0 - I $G(^ORD(101.43,OI,.1)),^(.1)'>$$NOW^XLFDT D Q ;inactive - . S X=$S(TYPE="A":"additive",1:"solution"),ORQUIT=1 - . W $C(7),!,"This "_X_" may not be ordered anymore. Please select another." - S I=$S(TYPE="A":4,1:3) I '$P($G(^ORD(101.43,OI,"PS")),U,I) D Q - . S X=$S(TYPE="A":"an additive",1:"a solution"),ORQUIT=1 - . W $C(7),!,"This item may not be ordered as "_X_"." - S EXIT=$$INPT^ORCD I EXIT=0 D ROUTECHK Q - Q:'$L($T(IVDEA^PSSUTIL1)) ;DBIA #3784 - S PSOI=+$P($G(^ORD(101.43,OI,0)),U,2) - S DEA=$$IVDEA^PSSUTIL1(PSOI,TYPE) I DEA>0 D Q:$G(ORQUIT) - . I $G(ORNP),'$L($P($G(^VA(200,+ORNP,"PS")),U,2)),'$L($P($G(^("PS")),U,3)) W $C(7),!,$P($G(^(0)),U)_" must have a DEA# or VA# to order this drug!" S ORQUIT=1 Q - . I DEA=1 W $C(7),!,"This order will require a wet signature!" - D ROUTECHK - Q - ; -VOLUME ; -- get allowable volumes for solution - N PSOI,ORY,CNT,I,XORY K ORDIALOG(PROMPT,"LIST") - S PSOI=+$P($G(^ORD(101.43,+$$VAL^ORCD("SOLUTION",INST),0)),U,2)_"B" - D ENVOL^PSJORUT2(PSOI,.ORY) Q:'ORY - ;S (I,CNT)=0 F S I=$O(ORY(I)) Q:I'>0 S CNT=CNT+1,ORDIALOG(PROMPT,"LIST",+ORY(I))=+ORY(I) - S (I,CNT)=0 F S I=$O(ORY(I)) Q:I'>0 D - . S CNT=CNT+1 - . S XORY(I)=+ORY(I) I XORY(I)<1,$E(XORY(I),1,2)'="0." S XORY(I)=0_XORY(I) - . S ORDIALOG(PROMPT,"LIST",XORY(I))=XORY(I) - S ORDIALOG(PROMPT,"LIST")=CNT_"^1" - Q - ; -UNITS ; -- get allowable units for current additive - N PSOI,ORY,I,UNITS - S PSOI=+$P(^ORD(101.43,+ORDIALOG($$PTR^ORCD("OR GTX ADDITIVE"),INST),0),U,2)_"A" - D ENVOL^PSJORUT2(PSOI,.ORY) - S I=$O(ORY(0)) Q:'I S UNITS=$P($G(ORY(I)),U,2) - S ORDIALOG($$PTR^ORCD("OR GTX UNITS"),INST)=UNITS - W !," (Units for this additive are "_UNITS_")" - Q - ; -PREMIX() ; -- Returns 1 or 0, if IV base is a premix solution - N BASE,PS,I,Y - S BASE=$$PTR^ORCD("OR GTX ORDERABLE ITEM"),Y=0 - S I=0 F S I=$O(ORDIALOG(BASE,I)) Q:I'>0 D Q:Y - . S PS=$G(^ORD(101.43,+$G(ORDIALOG(BASE,I)),"PS")) - . I $P(PS,U,3)&($P(PS,U,4)) S Y=1 - Q Y - ; -IVRTEENT ; - N ARRAY,DIR,RIEN,TROUTE - I ORTYPE'="Z" Q - S RIEN=$P($G(ORDIALOG("B","ROUTE")),U,2) Q:RIEN'>0 - S EXIT=0,TROUTE=$G(ORDIALOG(RIEN,1)) Q:TROUTE'>0 - I $$IVRTESCR(TROUTE)=1 Q - S ORDIALOG(RIEN,1)="" - W !!,"The selected route is not a valid route for this order." - W !,"Select a new route for this order from the list of routes below." - D RTEDISP(.ARRAY) - Q - ; -BIVOI(ARRAY) ; - N CNT,NUM,OIIEN,OTYPE - S CNT=0 - F OTYPE="SOLUTION","ADDITIVE" D - .S OIIEN=+$P($G(ORDIALOG("B",OTYPE)),U,2) I OIIEN>0 D - ..S NUM=0 F S NUM=$O(ORDIALOG(OIIEN,NUM)) Q:NUM'>0 I +$G(ORDIALOG(OIIEN,NUM))>0 D - ...S CNT=CNT+1,ARRAY(CNT)=ORDIALOG(OIIEN,NUM) - Q - ; -LVROUTES ; - N ARRAY,ROUTES - D BIVOI(.ARRAY) - D IVDOSFRM^ORWDPS33(.ROUTES,.ARRAY,0,1) - D RTEDISP(.ROUTES) - Q - ; -RTEDISP(ROUTES) ; - N CNT - S CNT="" F S CNT=$O(ROUTES(CNT)) Q:CNT'>0 D - .W !,$P($G(ROUTES(CNT)),U,2) - Q - ; -IVRTESCR(Y) ; - N ARRAY,ROUTES,VALUE - D BIVOI(.ARRAY) - S VALUE=$$IVQOVAL^ORWDPS33(.ARRAY,Y) I VALUE'="" Q 1 - Q 0 - ; -ROUTECHK ; - N CNT,IEN,ROUTE,VALUE - S RIEN=$P($G(ORDIALOG("B","ROUTE")),U,2) Q:RIEN'>0 - S TROUTE=$G(ORDIALOG(RIEN,1)) Q:TROUTE'>0 - I $$IVRTESCR(TROUTE)=1 Q - S ORDIALOG(RIEN,1)="" - W !!,"The route defined for this order is an invalid route." - W !,"You will need to define a new route for this order." - Q - ; -ENRATE ; -- set display text, help based on IV TYPE - N X,MSG S X=$G(ORIVTYPE),MSG="" - S ORDIALOG(PROMPT,"A")=$S(X="I":"Infuse over time (min): ",1:"Infusion Rate (ml/hr): ") - S MSG="Enter the "_$S(X="I":"number of minutes over which to infuse this medication.",1:"infusion rate, as the number of ml/hr or Text@Number of Labels per day. ") - S ORDIALOG(PROMPT,"?")=MSG - I X="I" D - .N RATEI,RATEV,TIME,UNIT - .S RATEI=$P($G(ORDIALOG("B","INFUSION RATE")),U,2) Q:RATEI'>0 - .S RATEV=$G(ORDIALOG(RATEI,1)) Q:'$L(RATEV) - .I RATEV'["INFUSE OVER" Q - .S TIME=$P(RATEV," ",3) - .S UNIT=$P(RATEV," ",4) - .I TIME["." Q - .I UNIT="Hours" S TIME=TIME*60 - .S ORDIALOG(RATEI,1)=TIME - Q - ; -INF ; -- input transform for INFUSION RATE - N ALPHA,CNT,EXIT,FAIL,LDEC,RDEC,TEMP - I $G(ORIVTYPE)="I" D Q - .I X["." W !,"Infuse Over Time must be a whole number." K X Q - .I $L(X)>4 W !,"Infuse Over Time cannot exceed 4 spaces for minutes." K X - .S FAIL=0 - .F CNT=1:1:$L(X) D I FAIL=1 Q - ..I ($A($E(X,CNT))<48)!($A($E(X,CNT))>58) S FAIL=1 - .I FAIL=1 W !,"Infuse Over Time must be a whole number." K X Q - K:$L(X)<1!($L(X)>30)!(X["""")!($A(X)=45) X I '$D(X) Q - I $G(ORIVTYPE)="C" D Q - .S TEMP=$E(X,($L(X)-5),$L(X)) - .I X["@",$$UP^XLFSTR(TEMP)=" ML/HR" Q - .S ALPHA=0 - .I X'["@" D I ALPHA=1 K X Q - ..F CNT=1:1:$L(X) D I ALPHA=1 Q - ...I ($A($E(X,CNT))<48)!($A($E(X,CNT))>58) S ALPHA=1 - .S EXIT=0 - .I X[".",X'["@" D I EXIT=1 K X Q - ..S LDEC=$P(X,"."),RDEC=$P(X,".",2) - ..I LDEC="" W !,"Infusion Rate required a leading numeric value." S EXIT=1 - ..I $L(RDEC)>1 W !,"Infusion Rate cannot exceed one decimal place." S EXIT=1 - ..S ALPHA=0 - ..F CNT=1:1:$L(LDEC) D I ALPHA=1 S EXIT=1 Q - ...I ($A($E(LDEC,CNT))<48)!($A($E(LDEC,CNT))>58) S ALPHA=1 - ..I $L(RDEC)=0 Q - ..F CNT=1:1:$L(RDEC) D I ALPHA=1 S EXIT=1 Q - ...I ($A($E(RDEC,CNT))<48)!($A($E(RDEC,CNT))>58) S ALPHA=1 - .D ORINF^PSIVSP Q - ; -- assume #minutes for now - K:(X'=+X)!(X<1)!(X>999) X ;range? - Q - ; -VALIDAYS(X) ; -- Validate IV duration - N UNITS,X1,X2,Y,I - I X'?1.N." "1.A Q 0 - S UNITS="^MIN^HOURS^DAYS^M^H^D^",(X1,X2)="" - F I=1:1:$L(X) S Y=$E(X,I) S:Y?1N X1=X1_Y S:Y?1A X2=X2_$$UP^XLFSTR(Y) - I 'X1 Q 0 - I UNITS'[(U_X2_U) Q 0 - Q 1 - ; -VALDURA(X) ;-- Validate IV duration/limitation - K:$L(X)<1!($L(X)>30)!(X["""")!($A(X)=45) X I '$D(X) Q - ; -IVPSI ;INPUT-TRANSFORM - I $L(X)<1!($L(X)>30)!(X["""")!($A(X)=45) S X="" Q - I $L(X)>1,X[" " W !,"Spaces are not allow in the duration." K X Q - I $E(X)=0 W !,!,"Duration cannot start with a zero." K X Q - I X["." W !,!,"Invalid duration or total volume.",!,"Duration has to be integer value!" S X="" Q - S X=$$UP^XLFSTR(X) - I X["DOSES" D Q - .I $G(ORIVTYPE)'="I" K X W !,"Continuous IV Orders cannot have DOSES as a duration." Q - .I +$P(X,"DOSES")<1,+$P(X,"DOSES")>200000 W !,"Invalid number of Doses.",! K X Q - I (X'?.N1.2A),(X'?.N1".".N1.2A) W !,!,"Invalid duration or total volume.",! S X="" Q - I (X?.N1A) D - . I (X["L")!(X["H")!(X["D") Q - . E W !,!,"Invalid duration or total volume.",! S X="" Q - I (X?.N1".".N1A) D - . I X["L" Q - . E W !,!,"Invalid duration or total volume.",!,"Duration has to be integer value!",! S X="" Q - I (X?.N2A)!(X?.N1".".N2A) D - . I (X["ML")!(X["CC") Q - . E W !,!,"Invalid duration or total volume",! S X="" Q - I X="" K X - Q - ; -IVPSI1 ; ASK ON CONDITION - N DURI,DURV - I $G(OROTSCH)=1 Q - S DURI=$P($G(ORDIALOG("B","LIMITATION")),U,2) - I DURI>0 S DURV=$G(ORDIALOG(DURI,1)) - I $L(DURV)>1,$E(DURV)="f",DURV["doses" D - .S TEMPX=$P(DURV," ",5)_"DOSES" - .I TEMPX'="",TEMPX'=DURV S ORDIALOG(DURI,1)=TEMPX - N INT,IVTYPE,ONETIME,TYPE,SCH,SCHNAME - I $G(ORIVTYPE)'="I" D G IVPS1X - .W !,!,"Enter the length of administrative time or total volume for IV fluid order followed by ML or CC for milliliters, L for liters, D for days, H for hours to set limitation." - .W !,"(Examples: 1500ML, 1000CC, 1L, 3D, or 72H)",! - W !,"This field is optional a value does not need to be entered." - W !,!,"Enter the length of administrative time or total volume for IV fluid order followed by ML or CC for milliliters, L for liters, D for days, H for hours or DOSES to set limitation." - W !,"(Examples: 1500ML, 1000CC, 1L, 3D, 72H, or 10DOSES)",! -IVPS1X ; - W !,"This field is optional a value does not need to be entered." - I 1 - Q +ORCDPSIV ;SLC/MKB-Pharmacy IV dialog utilities ;11/25/02 09:47 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,38,48,158,195**;Dec 17, 1997 +PROVIDER ; -- Check provider, if authorized to write med orders + I $D(^XUSEC("OREMAS",DUZ)),'$$GET^XPAR("ALL","OR OREMAS MED ORDERS") W $C(7),!!,"OREMAS key holders may not enter medication orders." S ORQUIT=1 Q + N PS,NAME S PS=$G(^VA(200,+$G(ORNP),"PS")),NAME=$P($G(^(20)),U,2) + I '$L(NAME) S NAME=$P(^VA(200,+$G(ORNP),0),U) + I '$P(PS,U) W $C(7),!!,NAME_" is not authorized to write medication orders!" S ORQUIT=1 + I $P(PS,U,4),$$NOW^XLFDT>$P(PS,U,4) W $C(7),!!,NAME_" is no longer authorized to write medication orders!" S ORQUIT=1 + I $G(ORQUIT) W !,"You must select another provider to continue.",! S PS=$$MEDPROV I PS S ORXNP=ORNP,ORNP=PS K ORQUIT + Q + ; +MEDPROV() ; -- Return ordering med provider + N X,Y,D,DIC + S DIC=200,DIC(0)="AEQ",DIC("A")="Select PROVIDER: ",D="AK.PROVIDER" + S DIC("S")="I $P($G(^(""PS"")),U),'$P(^(""PS""),U,4)!($P(^(""PS""),U,4)>$$NOW^XLFDT)" + D IX^DIC S:Y>0 Y=+Y I Y'>0 S Y="^" + Q Y + ; +CHANGED(TYPE) ; -- Kill dependent values when OI changes + N PROMPTS,NAME,PTR,P,I + Q:'$L($G(TYPE)) S PROMPTS="" + S:TYPE="B" PROMPTS="VOLUME" + S:TYPE="A" PROMPTS="STRENGTH PSIV^UNITS" + F P=1:1:$L(PROMPTS,U) S NAME=$P(PROMPTS,U,P) D + . S PTR=$O(^ORD(101.41,"AB","OR GTX "_NAME,0)) Q:'PTR + . S I=0 F S I=$O(ORDIALOG(PTR,I)) Q:I'>0 K ORDIALOG(PTR,I) + . K ORDIALOG(PTR,"LIST") + Q + ; +INACTIVE(TYPE) ; -- Check OI inactive date + N OI,X,I,PSOI,DEA S:$G(TYPE)'="A" TYPE="S" + S OI=+$G(ORDIALOG(PROMPT,INST)) Q:OI'>0 + I $G(^ORD(101.43,OI,.1)),^(.1)'>$$NOW^XLFDT D Q ;inactive + . S X=$S(TYPE="A":"additive",1:"solution"),ORQUIT=1 + . W $C(7),!,"This "_X_" may not be ordered anymore. Please select another." + S I=$S(TYPE="A":4,1:3) I '$P($G(^ORD(101.43,OI,"PS")),U,I) D Q + . S X=$S(TYPE="A":"an additive",1:"a solution"),ORQUIT=1 + . W $C(7),!,"This item may not be ordered as "_X_"." + Q:'$$INPT^ORCD Q:'$L($T(IVDEA^PSSUTIL1)) ;DBIA #3784 + S PSOI=+$P($G(^ORD(101.43,OI,0)),U,2) + S DEA=$$IVDEA^PSSUTIL1(PSOI,TYPE) I DEA>0 D Q:$G(ORQUIT) + . I $G(ORNP),'$L($P($G(^VA(200,+ORNP,"PS")),U,2)),'$L($P($G(^("PS")),U,3)) W $C(7),!,$P($G(^(0)),U)_" must have a DEA# or VA# to order this drug!" S ORQUIT=1 Q + . I DEA=1 W $C(7),!,"This order will require a wet signature!" + Q + ; +VOLUME ; -- get allowable volumes for solution + N PSOI,ORY,CNT,I K ORDIALOG(PROMPT,"LIST") + S PSOI=+$P($G(^ORD(101.43,+$$VAL^ORCD("SOLUTION",INST),0)),U,2)_"B" + D ENVOL^PSJORUT2(PSOI,.ORY) Q:'ORY + S (I,CNT)=0 F S I=$O(ORY(I)) Q:I'>0 S CNT=CNT+1,ORDIALOG(PROMPT,"LIST",+ORY(I))=+ORY(I) + S ORDIALOG(PROMPT,"LIST")=CNT_"^1" + Q + ; +UNITS ; -- get allowable units for current additive + N PSOI,ORY,I,UNITS + S PSOI=+$P(^ORD(101.43,+ORDIALOG($$PTR^ORCD("OR GTX ADDITIVE"),INST),0),U,2)_"A" + D ENVOL^PSJORUT2(PSOI,.ORY) + S I=$O(ORY(0)) Q:'I S UNITS=$P($G(ORY(I)),U,2) + S ORDIALOG($$PTR^ORCD("OR GTX UNITS"),INST)=UNITS + W !," (Units for this additive are "_UNITS_")" + Q + ; +PREMIX() ; -- Returns 1 or 0, if IV base is a premix solution + N BASE,PS,I,Y + S BASE=$$PTR^ORCD("OR GTX ORDERABLE ITEM"),Y=0 + S I=0 F S I=$O(ORDIALOG(BASE,I)) Q:I'>0 D Q:Y + . S PS=$G(^ORD(101.43,+$G(ORDIALOG(BASE,I)),"PS")) + . I $P(PS,U,3)&($P(PS,U,4)) S Y=1 + Q Y + ; +VALIDAYS(X) ; -- Validate IV duration + N UNITS,X1,X2,Y,I + I X'?1.N." "1.A Q 0 ; invalid format + S UNITS="^MIN^HOURS^DAYS^M^H^D^",(X1,X2)="" + F I=1:1:$L(X) S Y=$E(X,I) S:Y?1N X1=X1_Y S:Y?1A X2=X2_$$UP^XLFSTR(Y) + I 'X1 Q 0 + I UNITS'[(U_X2_U) Q 0 + Q 1 + ; +VALDURA(X) ;-- Validate IV duration/limitation + K:$L(X)<1!($L(X)>30)!(X["""")!($A(X)=45) X I '$D(X) Q + ; +IVPSI ;INPUT-TRANSFORM + I $L(X)<1!($L(X)>30)!(X["""")!($A(X)=45) S X="" Q + S X=$$UP^XLFSTR(X) + I (X'?.N1.2A),(X'?.N1".".N1.2A) W !,!,"Invalid duration or total volume.",! S X="" Q + I (X?.N1A) D + . I (X["L")!(X["H")!(X["D") Q + . E W !,!,"Invalid duration or total volume.",! S X="" Q + I (X?.N1".".N1A) D + . I X["L" Q + . E W !,!,"Invalid duration or total volume.",!,"Duration has to be integer value!",! S X="" Q + I (X?.N2A)!(X?.N1".".N2A) D + . I (X["ML")!(X["CC") Q + . E W !,!,"Invalid duration or total volume",! S X="" Q + I X="" K X + Q + ; +IVPSI1 ; ASK ON CONDITION + W !,!,"Enter the length of administrative time or total volume for IV fluid order followed by ML or CC for milliliters, L for liters, D for days, H for hours to set limitation." + W !,"(Examples: 1500ML, 1000CC, 1.5L, 3D, or 72H)",! + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCFLAG.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCFLAG.m index 56f670ab..15d7800a 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCFLAG.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCFLAG.m @@ -1,106 +1,106 @@ -ORCFLAG ; SLC/MKB - Flag orders ;12/26/2006 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141,243**;Dec 17, 1997;Build 242 - ; -EN1(ORIFN) ; -- standalone entry point to un/flag order ORIFN - N ORLK,ORERR,VA,VADM,VAERR,DFN,ORVP,ORPNM,ORSSN,ORAGE,ORACTN,ORPS - Q:'$G(ORIFN) S:'$P(ORIFN,";",2) ORIFN=+ORIFN_";1" - S ORVP=$P($G(^OR(100,+ORIFN,0)),U,2),DFN=+ORVP I 'ORVP!'$D(^(8,+$P(ORIFN,";",2),0)) W !,"Missing or invalid order!" H 1 Q - D DEM^VADPT S ORPNM=VADM(1),ORSSN=$P(VADM(2),U,2),ORAGE=VADM(4) - S ORACTN=$S($G(^OR(100,+ORIFN,8,+$P(ORIFN,";",2),3)):"UF",1:"FL") - I '$$VALID^ORCACT0(ORIFN,ORACTN,.ORERR) W !,ORERR H 1 Q - S ORLK=$$LOCK1^ORX2(+ORIFN) I 'ORLK W !,$P(ORLK,U,2) H 1 Q - S ORACTN=$S(ORACTN="UF":"UN",1:"EN"),ORPS=1 - D @ORACTN,UNLK1^ORX2(+ORIFN) - Q - ; -EN ; -- Flag order ORIFN - N OREASON,DA,ORB,ORNP,ORNOW S ORNOW=+$E($$NOW^XLFDT,1,12) - S DA=$P(ORIFN,";",2) I 'DA W !,"Unable to flag!" H 1 Q - S OREASON=$$REASON Q:OREASON="^" - S ORNP=+$P($G(^OR(100,+ORIFN,8,DA,0)),U,3),ORNP=$$PROV(ORNP) Q:ORNP="^" - D BULLETIN ;use ORNP? - K ^OR(100,+ORIFN,8,DA,3) S ^(3)="1^"_$G(XMZ)_U_ORNOW_U_DUZ_U_OREASON_"^^^^"_ORNP - S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT,OREBUILD=1 ; Last Activity - S ORB=+ORVP_U_+ORIFN_U_ORNP_"^1" D EN^OCXOERR(ORB) ; notification - W !?10,"... order flagged." H 1 D KILL^XM,MSG(ORIFN) - Q - ; -UN ; -- Unflag order ORIFN - N OREASON,DA,ORB,ORNP,ORNOW S ORNOW=+$E($$NOW^XLFDT,1,12) - S DA=$P(ORIFN,";",2) I 'DA W !,"Unable to unflag order!" H 1 Q - D SHOWFLAG S OREASON=$$COMMENT Q:OREASON="^" - S $P(^OR(100,+ORIFN,8,DA,3),U)=0,$P(^(3),U,6,8)=ORNOW_U_DUZ_U_OREASON - S ORNP=+$P(^OR(100,+ORIFN,8,DA,3),U,9) S:'ORNP ORNP=+$P($G(^(0)),U,3) - S ORB=+ORVP_U_+ORIFN_U_ORNP_"^0" D EN^OCXOERR(ORB) ; notification - S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT,OREBUILD=1 ; Last Activity - W !?10,"... order unflagged." H 1 D MSG(ORIFN) - Q - ; -SHOWFLAG ; -- Display [last] flag for order ORIFN - N FLAG - S FLAG=$G(^OR(100,+ORIFN,8,DA,3)) - W !," FLAGGED: "_$$LTIM($P(FLAG,U,3))_" by "_$P($G(^VA(200,+$P(FLAG,U,4),0)),U) - W !?10,$P(FLAG,U,5) ; reason - Q - ; -REASON() ; -- Reason for flag - N X,Y,DIR - S DIR(0)="FA^1:80",DIR("A")="REASON FOR FLAG: " ; ck E3R - S DIR("?")="A reason must be entered to flag this order." - D ^DIR - Q Y - ; -COMMENT() ; -- Comments on unflag - N X,Y,DIR - S DIR(0)="FAO^1:80",DIR("A")="COMMENTS: " - S DIR("?")="A comment may be entered to clarify this order." - D ^DIR S:$D(DTOUT) Y="^" - Q Y - ; -PROV(ORDR) ; -- Get provider to alert - N X,Y,DIC - S DIC=200,DIC(0)="AEQM",DIC("A")="Send alert to: " - I $G(ORDR) S ORDR=$P($G(^VA(200,+ORDR,0)),U) S:$L(ORDR) DIC("B")=ORDR - S DIC("S")="N ORT S ORT=$P(^(0),U,11) I 'ORT!(ORT>DT)" - D ^DIC S:Y>0 Y=+Y I Y'>0 S Y="^" - Q Y - ; -BULLETIN ; -- Send bulletin re: flag - N OR0,OR3,ORDTXT,XMB,XMY,XMDUZ,ORENT,BULL,ORSRV,ORUSR - S OR0=$G(^OR(100,+ORIFN,0)),OR3=$G(^(3)) ;ORUSR=+$P(OR0,U,4) - S ORUSR=+$G(ORNP),ORSRV=+$P($G(^VA(200,ORUSR,5)),U) - S ORENT="USR.`"_ORUSR_"^SRV.`"_ORSRV_"^DIV^SYS^PKG" - S BULL=$$GET^XPAR(ORENT,"ORB FLAGGED ORDERS BULLETIN",1,"Q") - Q:$G(BULL)'="Y" ;quit if parameter value is not 'Y'es - ; - W !,"Sending bulletin to "_$P($G(^VA(200,ORUSR,0)),U)_"..." - S XMB="OR FLAGGED ORDER",XMDUZ=DUZ,XMY(ORUSR)="" - S XMB(1)=ORPNM,XMB(2)=ORSSN,XMB(3)=ORAGE,XMB(4)=$$LTIM($P(OR0,U,7)) - D TEXT^ORQ12(.ORDTXT,+ORIFN,80) - S XMB(5)=$G(ORDTXT(1)),XMB(6)=$G(ORDTXT(2)),XMB(7)=$G(ORDTXT(3)) - S XMB(8)=$$LTIM($P(OR0,U,8)),XMB(9)=$$LTIM($P(OR0,U,9)),XMB(10)=OREASON - S XMB(11)=$P($G(^ORD(100.01,+$P(OR3,U,3),0)),U) - D EN^XMB - Q - ; -LTIM(X) ; -- format FM date/time into MM/DD HH:MM - N Y S Y="" - S:X Y=$E(X,4,5)_"/"_$E(X,6,7) - S:X["." Y=Y_" "_$E(X_"0",9,10)_":"_$E(X_"000",11,12) - Q Y - ; -MSG(ORDER) ; -- Sends HL7 message to Pharmacy when order is un/flagged - Q:'$L($T(OBR^PSJHL4)) ;needs PSJ*5*85 - Q:'$G(ORDER) Q:'$D(^OR(100,+ORDER,0)) Q:'$P(ORDER,";",2) - N OR0,OR3,ORMSG,ORVP,ORX,ORFLAG - S OR0=$G(^OR(100,+ORDER,0)),OR3=$G(^(8,+$P(ORDER,";",2),3)) - Q:"^PSJ^PSIV^PSO^"'[(U_$$GET1^DIQ(9.4,+$P(OR0,U,14)_",",1)_U) ;Inpt or IV - S ORMSG(1)=$$MSH^ORMBLD("ORU","PS") - S ORVP=$P(OR0,U,2),ORMSG(2)=$$PID^ORMBLD(ORVP) - S ORMSG(3)=$$PV1^ORMBLD(ORVP,$P(OR0,U,12),+$P(OR0,U,10)) - S ORX=$S(OR3:$P(OR3,U,3,5),1:$P(OR3,U,6,8)) - S ORFLAG=$S(OR3:"FL",1:"UF")_"|||"_$$HL7DATE^ORMBLD($P(ORX,U))_"||||||"_$P(ORX,U,3)_"|||"_+$P(ORX,U,2) - S:$G(ORPS) ORFLAG=ORFLAG_"||||||||PHR" ;action taken by pharmacist - S ORMSG(4)="OBR|1|"_ORDER_"^OR|"_$G(^OR(100,+ORDER,4))_"^PS|"_ORFLAG - D MSG^XQOR("OR EVSEND PS",.ORMSG) - Q +ORCFLAG ; SLC/MKB - Flag orders ;6/2/97 10:44 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141**;Dec 17, 1997 + ; +EN1(ORIFN) ; -- standalone entry point to un/flag order ORIFN + N ORLK,ORERR,VA,VADM,VAERR,DFN,ORVP,ORPNM,ORSSN,ORAGE,ORACTN,ORPS + Q:'$G(ORIFN) S:'$P(ORIFN,";",2) ORIFN=+ORIFN_";1" + S ORVP=$P($G(^OR(100,+ORIFN,0)),U,2),DFN=+ORVP I 'ORVP!'$D(^(8,+$P(ORIFN,";",2),0)) W !,"Missing or invalid order!" H 1 Q + D DEM^VADPT S ORPNM=VADM(1),ORSSN=$P(VADM(2),U,2),ORAGE=VADM(4) + S ORACTN=$S($G(^OR(100,+ORIFN,8,+$P(ORIFN,";",2),3)):"UF",1:"FL") + I '$$VALID^ORCACT0(ORIFN,ORACTN,.ORERR) W !,ORERR H 1 Q + S ORLK=$$LOCK1^ORX2(+ORIFN) I 'ORLK W !,$P(ORLK,U,2) H 1 Q + S ORACTN=$S(ORACTN="UF":"UN",1:"EN"),ORPS=1 + D @ORACTN,UNLK1^ORX2(+ORIFN) + Q + ; +EN ; -- Flag order ORIFN + N OREASON,DA,ORB,ORNP,ORNOW S ORNOW=+$E($$NOW^XLFDT,1,12) + S DA=$P(ORIFN,";",2) I 'DA W !,"Unable to flag!" H 1 Q + S OREASON=$$REASON Q:OREASON="^" + S ORNP=+$P($G(^OR(100,+ORIFN,8,DA,0)),U,3),ORNP=$$PROV(ORNP) Q:ORNP="^" + D BULLETIN ;use ORNP? + K ^OR(100,+ORIFN,8,DA,3) S ^(3)="1^"_$G(XMZ)_U_ORNOW_U_DUZ_U_OREASON_"^^^^"_ORNP + S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT,OREBUILD=1 ; Last Activity + S ORB=+ORVP_U_+ORIFN_U_ORNP_"^1" D EN^OCXOERR(ORB) ; notification + W !?10,"... order flagged." H 1 D KILL^XM,MSG(ORIFN) + Q + ; +UN ; -- Unflag order ORIFN + N OREASON,DA,ORB,ORNP,ORNOW S ORNOW=+$E($$NOW^XLFDT,1,12) + S DA=$P(ORIFN,";",2) I 'DA W !,"Unable to unflag order!" H 1 Q + D SHOWFLAG S OREASON=$$COMMENT Q:OREASON="^" + S $P(^OR(100,+ORIFN,8,DA,3),U)=0,$P(^(3),U,6,8)=ORNOW_U_DUZ_U_OREASON + S ORNP=+$P(^OR(100,+ORIFN,8,DA,3),U,9) S:'ORNP ORNP=+$P($G(^(0)),U,3) + S ORB=+ORVP_U_+ORIFN_U_ORNP_"^0" D EN^OCXOERR(ORB) ; notification + S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT,OREBUILD=1 ; Last Activity + W !?10,"... order unflagged." H 1 D MSG(ORIFN) + Q + ; +SHOWFLAG ; -- Display [last] flag for order ORIFN + N FLAG + S FLAG=$G(^OR(100,+ORIFN,8,DA,3)) + W !," FLAGGED: "_$$LTIM($P(FLAG,U,3))_" by "_$P($G(^VA(200,+$P(FLAG,U,4),0)),U) + W !?10,$P(FLAG,U,5) ; reason + Q + ; +REASON() ; -- Reason for flag + N X,Y,DIR + S DIR(0)="FA^1:80",DIR("A")="REASON FOR FLAG: " ; ck E3R + S DIR("?")="A reason must be entered to flag this order." + D ^DIR + Q Y + ; +COMMENT() ; -- Comments on unflag + N X,Y,DIR + S DIR(0)="FAO^1:80",DIR("A")="COMMENTS: " + S DIR("?")="A comment may be entered to clarify this order." + D ^DIR S:$D(DTOUT) Y="^" + Q Y + ; +PROV(ORDR) ; -- Get provider to alert + N X,Y,DIC + S DIC=200,DIC(0)="AEQM",DIC("A")="Send alert to: " + I $G(ORDR) S ORDR=$P($G(^VA(200,+ORDR,0)),U) S:$L(ORDR) DIC("B")=ORDR + S DIC("S")="N ORT S ORT=$P(^(0),U,11) I 'ORT!(ORT>DT)" + D ^DIC S:Y>0 Y=+Y I Y'>0 S Y="^" + Q Y + ; +BULLETIN ; -- Send bulletin re: flag + N OR0,OR3,ORDTXT,XMB,XMY,XMDUZ,ORENT,BULL,ORSRV,ORUSR + S OR0=$G(^OR(100,+ORIFN,0)),OR3=$G(^(3)) ;ORUSR=+$P(OR0,U,4) + S ORUSR=+$G(ORNP),ORSRV=+$P($G(^VA(200,ORUSR,5)),U) + S ORENT="USR.`"_ORUSR_"^SRV.`"_ORSRV_"^DIV^SYS^PKG" + S BULL=$$GET^XPAR(ORENT,"ORB FLAGGED ORDERS BULLETIN",1,"Q") + Q:$G(BULL)'="Y" ;quit if parameter value is not 'Y'es + ; + W !,"Sending bulletin to "_$P($G(^VA(200,ORUSR,0)),U)_"..." + S XMB="OR FLAGGED ORDER",XMDUZ=DUZ,XMY(ORUSR)="" + S XMB(1)=ORPNM,XMB(2)=ORSSN,XMB(3)=ORAGE,XMB(4)=$$LTIM($P(OR0,U,7)) + D TEXT^ORQ12(.ORDTXT,+ORIFN,80) + S XMB(5)=$G(ORDTXT(1)),XMB(6)=$G(ORDTXT(2)),XMB(7)=$G(ORDTXT(3)) + S XMB(8)=$$LTIM($P(OR0,U,8)),XMB(9)=$$LTIM($P(OR0,U,9)),XMB(10)=OREASON + S XMB(11)=$P($G(^ORD(100.01,+$P(OR3,U,3),0)),U) + D EN^XMB + Q + ; +LTIM(X) ; -- format FM date/time into MM/DD HH:MM + N Y S Y="" + S:X Y=$E(X,4,5)_"/"_$E(X,6,7) + S:X["." Y=Y_" "_$E(X_"0",9,10)_":"_$E(X_"000",11,12) + Q Y + ; +MSG(ORDER) ; -- Sends HL7 message to Pharmacy when order is un/flagged + Q:'$L($T(OBR^PSJHL4)) ;needs PSJ*5*85 + Q:'$G(ORDER) Q:'$D(^OR(100,+ORDER,0)) Q:'$P(ORDER,";",2) + N OR0,OR3,ORMSG,ORVP,ORX,ORFLAG + S OR0=$G(^OR(100,+ORDER,0)),OR3=$G(^(8,+$P(ORDER,";",2),3)) + Q:"^PSJ^PSIV^"'[(U_$$GET1^DIQ(9.4,+$P(OR0,U,14)_",",1)_U) ;Inpt or IV + S ORMSG(1)=$$MSH^ORMBLD("ORU","PS") + S ORVP=$P(OR0,U,2),ORMSG(2)=$$PID^ORMBLD(ORVP) + S ORMSG(3)=$$PV1^ORMBLD(ORVP,$P(OR0,U,12),+$P(OR0,U,10)) + S ORX=$S(OR3:$P(OR3,U,3,5),1:$P(OR3,U,6,8)) + S ORFLAG=$S(OR3:"FL",1:"UF")_"|||"_$$HL7DATE^ORMBLD($P(ORX,U))_"||||||"_$P(ORX,U,3)_"|||"_+$P(ORX,U,2) + S:$G(ORPS) ORFLAG=ORFLAG_"||||||||PHR" ;action taken by pharmacist + S ORMSG(4)="OBR|1|"_ORDER_"^OR|"_$G(^OR(100,+ORDER,4))_"^PS|"_ORFLAG + D MSG^XQOR("OR EVSEND PS",.ORMSG) + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCHANG2.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCHANG2.m index 4731192e..b00d1250 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCHANG2.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCHANG2.m @@ -1,142 +1,133 @@ -ORCHANG2 ;SLC/MKB-Change View status ; 08 May 2002 2:12 PM - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**27,72,68,141,215,243**;Dec 17, 1997;Build 242 -ORDERS ; -- Select new order status - N X,Y,HDR,I,DOMAIN,DEFAULT,PROMPT,HELP,STS - S HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3),DEFAULT="" - F I=1:1 S X=$T(ORDSTS+I) Q:$P(X,";",4)="ZZZZ" D SET - S DOMAIN(0)=I-1,PROMPT="Select Order Status: " - S HELP="Enter the status of orders you wish to see listed here." - D EN Q:Y="^" S STS=+$G(DOMAIN(Y)) - I "^8^9^10^20^"[(U_STS_U) D Q:Y="^" - . N STRT,STOP,Z - . S STRT=$$START^ORCHANGE("NOW-24H") I STRT="^" S Y="^" Q - . S STOP=$$STOP^ORCHANGE("NOW") I STOP="^" S Y="^" Q - . I STOP0 Q:I=99 S X=$G(^(I,0)) D - . Q:"^1^2^5^6^8^9^13^"'[(U_I_U) S Y=Y+1 - . S DOMAIN(Y)=I_U_$$LOWER^VALM1($P(X,U)),DOMAIN("B",$P(X,U))=Y - . S:I=$P(HDR,";",3) DEFAULT=$P(DOMAIN(Y),U,2) - S Y=Y+1,DOMAIN(Y)="^All Statuses",DOMAIN("B","ALL STATUSES")=Y - S DOMAIN(0)=Y,PROMPT="Select Consult Status: " - S HELP="Enter the status of consults you wish to see listed here." - D EN Q:Y="^" - S $P(HDR,";",3)=$P(DOMAIN(Y),U),$P(^TMP("OR",$J,ORTAB,0),U,3,4)=HDR_U - Q - ; -TIU ; -- Select new document status - N X,Y,ORY,I,CNT,HDR,DOMAIN,DEFAULT,PROMPT,HELP - S HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3),DEFAULT=$P(HDR,";",3) - D STATUS^TIUSRVL(.ORY) - S (I,CNT)=0 F S I=$O(ORY(I)) Q:I'>0 S CNT=CNT+1,DOMAIN(CNT)=ORY(I),DOMAIN("B",$$UP^XLFSTR($P(ORY(I),U,2)))=CNT - S DOMAIN(0)=CNT,PROMPT="Select Signature Status: " - S HELP="Enter the signature status you would like to screen on" - D EN Q:Y="^" - S $P(HDR,";",3)=$P(DOMAIN(Y),U,2),$P(^TMP("OR",$J,ORTAB,0),U,3,4)=HDR_U - Q - ; -PLIST ; -- Select problem status - N X,Y,HDR,I,ID,NAME,DOMAIN,DEFAULT,PROMPT,HELP - S HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3) - F I=1:1 S X=$T(PLSTS+I) Q:$P(X,";",4)="ZZZZ" D SET - S DOMAIN(0)=I-1,PROMPT="Select Problem Status: " - S HELP="Enter the status of the problems you wish to see listed here." - D EN Q:Y="^" - S $P(HDR,";",3)=$P(DOMAIN(Y),U),$P(^TMP("OR",$J,ORTAB,0),U,3,4)=HDR_U - Q - ; -PLSTS ;;I;name - ;;A;active - ;;I;inactive - ;;B;both active & inactive - ;;;ZZZZ - ; -SET ; -- set DOMAIN(I)=ID^NAME, DEFAULT from X=";;ID;NAME" - N ID,NAME - S ID=$P(X,";",3),NAME=$P(X,";",4) - S DOMAIN(I)=ID_U_NAME,DOMAIN("B",$$UP^XLFSTR(NAME))=I - S:ID=$P(HDR,";",3) DEFAULT=NAME - Q - ; -EN ; -- Select new status via DOMAIN(), PROMPT, DEFAULT, HELP - N DONE S DONE=0,Y="" F D Q:DONE - . W !,PROMPT_$S($L(DEFAULT):DEFAULT_"//",1:"") - . R X:DTIME S:'$T X="^" I X["^" S Y="^",DONE=1 Q - . S:X="" X=DEFAULT I X="" S Y="^",DONE=1 Q - . I X["?" W !!,HELP D LIST Q - . D I 'Y W $C(7),!,HELP Q - . . N XP,XY,CNT,MATCH,DIR,I - . . S X=$$UP^XLFSTR(X),Y=+$G(DOMAIN("B",X)) Q:Y ; done - . . S CNT=0,XP=X F S XP=$O(DOMAIN("B",XP)) Q:XP="" Q:$E(XP,1,$L(X))'=X S CNT=CNT+1,XY=+DOMAIN("B",XP),MATCH(CNT)=XY_U_$P(DOMAIN(XY),U,2) - . . Q:'CNT - . . I CNT=1 S Y=+MATCH(1),XP=$P(MATCH(1),U,2) W $E(XP,$L(X)+1,$L(XP)) Q - . . S DIR(0)="NAO^1:"_CNT,DIR("A")="Select 1-"_CNT_": " - . . F I=1:1:CNT S DIR("A",I)=$J(I,3)_" "_$P(MATCH(I),U,2) - . . S DIR("?")="Select the desired value, by number" - . . I CNT>3 D FULL^VALM1 S VALMBCK="R" ;need to scroll - . . D ^DIR I $D(DIRUT) S Y="" Q - . . S Y=+MATCH(Y) W " "_$P(DOMAIN(Y),U,2) - . S DONE=1 - Q - ; -LIST ; -- List order statuses in DOMAIN - N I,Z,CNT,DONE D FULL^VALM1 S VALMBCK="R" - S CNT=0 W !,"Choose from:" - F I=1:1:DOMAIN(0) D Q:$G(DONE) - . S CNT=CNT+1 W ! I CNT>(IOSL-3) D Q:$G(DONE) - .. W ?3,"'^' TO STOP: " R Z:DTIME S:'$T!(Z["^") DONE=1 S CNT=1 - . W $C(13)," "_$P(DOMAIN(I),U,2) - Q +ORCHANG2 ;SLC/MKB-Change View status ; 08 May 2002 2:12 PM + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**27,72,68,141,215**;Dec 17, 1997 +ORDERS ; -- Select new order status + N X,Y,HDR,I,DOMAIN,DEFAULT,PROMPT,HELP,STS + S HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3),DEFAULT="" + F I=1:1 S X=$T(ORDSTS+I) Q:$P(X,";",4)="ZZZZ" D SET + S DOMAIN(0)=I-1,PROMPT="Select Order Status: " + S HELP="Enter the status of orders you wish to see listed here." + D EN Q:Y="^" S STS=+$G(DOMAIN(Y)) + I "^8^9^10^20^"[(U_STS_U) D Q:Y="^" + . N STRT,STOP,Z + . S STRT=$$START^ORCHANGE("NOW-24H") I STRT="^" S Y="^" Q + . S STOP=$$STOP^ORCHANGE("NOW") I STOP="^" S Y="^" Q + . I STOP0 Q:I=99 S X=$G(^(I,0)) D + . Q:"^1^2^5^6^8^9^13^"'[(U_I_U) S Y=Y+1 + . S DOMAIN(Y)=I_U_$$LOWER^VALM1($P(X,U)),DOMAIN("B",$P(X,U))=Y + . S:I=$P(HDR,";",3) DEFAULT=$P(DOMAIN(Y),U,2) + S Y=Y+1,DOMAIN(Y)="^All Statuses",DOMAIN("B","ALL STATUSES")=Y + S DOMAIN(0)=Y,PROMPT="Select Consult Status: " + S HELP="Enter the status of consults you wish to see listed here." + D EN Q:Y="^" + S $P(HDR,";",3)=$P(DOMAIN(Y),U),$P(^TMP("OR",$J,ORTAB,0),U,3,4)=HDR_U + Q + ; +TIU ; -- Select new document status + N X,Y,ORY,I,CNT,HDR,DOMAIN,DEFAULT,PROMPT,HELP + S HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3),DEFAULT=$P(HDR,";",3) + D STATUS^TIUSRVL(.ORY) + S (I,CNT)=0 F S I=$O(ORY(I)) Q:I'>0 S CNT=CNT+1,DOMAIN(CNT)=ORY(I),DOMAIN("B",$$UP^XLFSTR($P(ORY(I),U,2)))=CNT + S DOMAIN(0)=CNT,PROMPT="Select Signature Status: " + S HELP="Enter the signature status you would like to screen on" + D EN Q:Y="^" + S $P(HDR,";",3)=$P(DOMAIN(Y),U,2),$P(^TMP("OR",$J,ORTAB,0),U,3,4)=HDR_U + Q + ; +PLIST ; -- Select problem status + N X,Y,HDR,I,ID,NAME,DOMAIN,DEFAULT,PROMPT,HELP + S HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3) + F I=1:1 S X=$T(PLSTS+I) Q:$P(X,";",4)="ZZZZ" D SET + S DOMAIN(0)=I-1,PROMPT="Select Problem Status: " + S HELP="Enter the status of the problems you wish to see listed here." + D EN Q:Y="^" + S $P(HDR,";",3)=$P(DOMAIN(Y),U),$P(^TMP("OR",$J,ORTAB,0),U,3,4)=HDR_U + Q + ; +PLSTS ;;I;name + ;;A;active + ;;I;inactive + ;;B;both active & inactive + ;;;ZZZZ + ; +SET ; -- set DOMAIN(I)=ID^NAME, DEFAULT from X=";;ID;NAME" + N ID,NAME + S ID=$P(X,";",3),NAME=$P(X,";",4) + S DOMAIN(I)=ID_U_NAME,DOMAIN("B",$$UP^XLFSTR(NAME))=I + S:ID=$P(HDR,";",3) DEFAULT=NAME + Q + ; +EN ; -- Select new status via DOMAIN(), PROMPT, DEFAULT, HELP + N DONE S DONE=0,Y="" F D Q:DONE + . W !,PROMPT_$S($L(DEFAULT):DEFAULT_"//",1:"") + . R X:DTIME S:'$T X="^" I X["^" S Y="^",DONE=1 Q + . S:X="" X=DEFAULT I X="" S Y="^",DONE=1 Q + . I X["?" W !!,HELP D LIST Q + . D I 'Y W $C(7),!,HELP Q + . . N XP,XY,CNT,MATCH,DIR,I + . . S X=$$UP^XLFSTR(X),Y=+$G(DOMAIN("B",X)) Q:Y ; done + . . S CNT=0,XP=X F S XP=$O(DOMAIN("B",XP)) Q:XP="" Q:$E(XP,1,$L(X))'=X S CNT=CNT+1,XY=+DOMAIN("B",XP),MATCH(CNT)=XY_U_$P(DOMAIN(XY),U,2) + . . Q:'CNT + . . I CNT=1 S Y=+MATCH(1),XP=$P(MATCH(1),U,2) W $E(XP,$L(X)+1,$L(XP)) Q + . . S DIR(0)="NAO^1:"_CNT,DIR("A")="Select 1-"_CNT_": " + . . F I=1:1:CNT S DIR("A",I)=$J(I,3)_" "_$P(MATCH(I),U,2) + . . S DIR("?")="Select the desired value, by number" + . . I CNT>3 D FULL^VALM1 S VALMBCK="R" ;need to scroll + . . D ^DIR I $D(DIRUT) S Y="" Q + . . S Y=+MATCH(Y) W " "_$P(DOMAIN(Y),U,2) + . S DONE=1 + Q + ; +LIST ; -- List order statuses in DOMAIN + N I,Z,CNT,DONE D FULL^VALM1 S VALMBCK="R" + S CNT=0 W !,"Choose from:" + F I=1:1:DOMAIN(0) D Q:$G(DONE) + . S CNT=CNT+1 W ! I CNT>(IOSL-3) D Q:$G(DONE) + .. W ?3,"'^' TO STOP: " R Z:DTIME S:'$T!(Z["^") DONE=1 S CNT=1 + . W $C(13)," "_$P(DOMAIN(I),U,2) + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCHANGE.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCHANGE.m index 58e2282e..2f61d108 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCHANGE.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCHANGE.m @@ -1,137 +1,135 @@ -ORCHANGE ;SLC/MKB-Change View utilities ; 08 May 2002 2:12 PM - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**27,72,141,243**;Dec 17, 1997;Build 242 -EN ; -- Change view of current list - N XQORM,Y,ORI - S XQORM=$G(^TMP("OR",$J,"CURRENT","CHANGE")),VALMBCK="" - I 'XQORM W !!,"No other views of this list currently available" H 2 Q - S Y=$S(ORTAB="NOTES"!(ORTAB="SUMMRIES"):"1\",ORTAB="ORDERS":"\",1:"") - S XQORM(0)=Y_"AD" K Y - S XQORM("A")=$S($L($G(^ORD(101,+XQORM,28))):^(28),1:"Select attribute(s) to change: ") - D EN^XQORM S ORI=0 - F S ORI=$O(Y(ORI)) Q:ORI'>0 X:$D(^ORD(101,+$P(Y(ORI),U,2),20)) ^(20) - I $G(^TMP("OR",$J,"CURRENT",0))'=$G(^TMP("OR",$J,ORTAB,0)) K VALMBG D TAB^ORCHART(ORTAB,1) - Q - ; -RANGE ; -- Get new date range for list - N HDR,OLD,NEW,REQ,BEG,END - S HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3) - S REQ=$S(ORTAB="XRAYS":1,ORTAB="REPORTS":1,1:0) - I ($P(HDR,";",3)=2)!($P(HDR,";",3)=5) D Q - . N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y,THISTS - . S THISTS=" only active " - . I $P(HDR,";",3)=5 S THISTS=" expiring " - . W !,"Date range can not be selected when viewing"_THISTS_"orders." - . S DIR(0)="E" D ^DIR - S OLD=$P(HDR,";"),NEW=$$START(OLD,REQ) Q:NEW="^" S BEG=NEW - I BEG="" S END="" G RQ - S OLD=$P(HDR,";",2),NEW=$$STOP(OLD,REQ) Q:NEW="^" S END=NEW - I END0 Y="" - Q +Y - ; -LISTHDR ; -- List available subhdrs - N HDR,DONE,CNT D FULL^VALM1 - W !!,"Choose from:" S HDR="",(CNT,DONE)=0,VALMBCK="R" - F S HDR=$O(^TMP("OR",$J,"CURRENT","HDR",HDR)) Q:HDR="" D Q:DONE - . S CNT=CNT+1 I CNT>(IOSL-2) S CNT=0 I '$$MORE^ORCD S DONE=1 Q - . W !," "_HDR - Q - ; -LRSUB ; -- Return lab subscript to jump to in list - ; Available subscripts in ^TMP("OR",$J,"IDX",name)=line # - I '$D(^TMP("OR",$J,"CURRENT","HDR")) W !!,"There are no section headers defined for this report." H 3 Q - N X,Y,DIR,XP,P,CNT,MATCH D FULL^VALM1 S VALMBCK="R" -LRS S DIR(0)="FAO^1:30",DIR("A")="Select Lab Section: " - S DIR("A",1)="Available sections in this report:",X="" - F I=2:1 S X=$O(^TMP("OR",$J,"CURRENT","HDR",X)) Q:X="" S DIR("A",I)=" "_X - S DIR("?")="Enter the lab section from which to wish to see results; the display will scroll to the top of the selected section" ;,DIR("??")="^D LISTHDR^ORCHANGE" - D ^DIR Q:"^"[Y - S XP=$$UP^XLFSTR(X) - I $G(^TMP("OR",$J,"CURRENT","HDR",XP)) S VALMBG=^(XP),VALMBCK="R" Q - S CNT=0,P=XP F S P=$O(^TMP("OR",$J,"CURRENT","HDR",P)) Q:$E(P,1,$L(XP))'=XP S CNT=CNT+1,MATCH(CNT)=+$G(^(P))_U_P ; line# ^ hdr name - I 'CNT W $C(7)," ??" G LRS - I CNT=1 S VALMBG=+MATCH(CNT),VALMBCK="R",P=$P(MATCH(1),U,2) W $E(P,$L(X)+1,$L(P)) Q -LRS1 K DIR S DIR(0)="NAO^1:"_CNT,DIR("A")="Select 1-"_CNT_": " - F I=1:1:CNT S DIR("A",I)=I_" "_$P(MATCH(I),U,2) - S DIR("?")="Select the lab section you want to go to, by number" - D ^DIR Q:$D(DTOUT)!($D(DUOUT)) I 'Y K DIR G LRS - S VALMBG=+MATCH(Y),VALMBCK="R" - Q - ; -DGROUP ; -- Select new service (display group) - N X,Y,Z,ZZ,DIC,HDR,DONE,HELP - D FULL^VALM1 S VALMBCK="R" - S HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3),Z=$P(HDR,";",4),ZZ=+$O(^ORD(100.98,"B",$S($L(Z):Z,1:"ALL"),0)) - S HELP="Enter the service or section from which you wish to see orders for this patient." - S DONE=0 F D Q:DONE - . W !!,"Select Service/Section: "_$P(^ORD(100.98,+ZZ,0),U)_"//" - . R X:DTIME S:'$T X="^" I X["^" S DONE=1 Q - . I X="" S DONE=1 Q ; no change - . I X["?" W !!,HELP,!,"Choose from:" D DG^ORCHANG1(1,"DISP") Q - . S DIC=100.98,DIC(0)="NEQZ" D ^DIC S:Y>0 Z=$P(Y(0),U,3),ZZ=+Y,DONE=1 - S $P(HDR,";",4)=Z,$P(^TMP("OR",$J,ORTAB,0),U,3,4)=HDR_U - Q - ; -CS ; -- Select new consult service - N GMRCDG,GMRCBUF,GMRCACT,GMRCQUT,GMRCGRP,HDR - D FULL^VALM1,ASRV^GMRCASV S VALMBCK="R" Q:$D(GMRCQUT) - S:$G(GMRCDG) HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3),$P(HDR,";",4)=GMRCDG,$P(^(0),U,3,4)=HDR_U - K ^TMP("GMRCS",$J),^TMP("GMRCSLIST",$J) - Q - ; -REMOVE ; -- Remove preferred view - N ORDEL S ORDEL=1 -SAVE ; -- Save current view as preferred - Q:'$$OK($G(ORDEL)) N X,Y,PARAM - S X=$S($G(ORDEL):"@",1:$P($G(^TMP("OR",$J,ORTAB,0)),U,3)),Y="" - ;S:$G(ORTAB)="MEDS" Y=$S($P(X,";",3):"IN",1:"OUT")_"PT " - S:$G(ORTAB)="LABS" Y=$S($G(ORWARD):"IN",1:"OUT")_"PT " - S PARAM="ORCH CONTEXT "_Y_$G(ORTAB) - D EN^XPAR("USR",PARAM,1,X) W " ...done." H 1 - Q - ; -OK(DEL) ; -- Are you sure you want to save/remove view of ORTAB? - N X,Y,DIR S DIR(0)="YA" - S DIR("A")="Are you sure you want to "_$S($G(DEL):"remove",1:"save the current view as")_" your preference? " - S:$G(DEL) DIR("?",1)="Enter YES if you wish to remove your preferred view of this chart tab and use",DIR("?")="the default view next time, or NO to quit without changing anything." - S:'$G(DEL) DIR("?",1)="Enter YES if you wish to use these same parameters again the next time the ",DIR("?")=$$LOWER^VALM1(ORTAB)_" tab is created for you, or NO to quit without saving anything." - D ^DIR - Q +Y - ; -RETURN ; -- Return to preferred view of ORTAB - S $P(^TMP("OR",$J,ORTAB,0),U,4)=1 - Q +ORCHANGE ;SLC/MKB-Change View utilities ; 08 May 2002 2:12 PM + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**27,72,141**;Dec 17, 1997 +EN ; -- Change view of current list + N XQORM,Y,ORI + S XQORM=$G(^TMP("OR",$J,"CURRENT","CHANGE")),VALMBCK="" + I 'XQORM W !!,"No other views of this list currently available" H 2 Q + S Y=$S(ORTAB="NOTES"!(ORTAB="SUMMRIES"):"1\",ORTAB="ORDERS":"\",1:"") + S XQORM(0)=Y_"AD" K Y + S XQORM("A")=$S($L($G(^ORD(101,+XQORM,28))):^(28),1:"Select attribute(s) to change: ") + D EN^XQORM S ORI=0 + F S ORI=$O(Y(ORI)) Q:ORI'>0 X:$D(^ORD(101,+$P(Y(ORI),U,2),20)) ^(20) + I $G(^TMP("OR",$J,"CURRENT",0))'=$G(^TMP("OR",$J,ORTAB,0)) K VALMBG D TAB^ORCHART(ORTAB,1) + Q + ; +RANGE ; -- Get new date range for list + N HDR,OLD,NEW,REQ + S HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3) + S REQ=$S(ORTAB="XRAYS":1,ORTAB="REPORTS":1,1:0) + I $P(HDR,";",3)=2 D Q + . N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y + . W !,"Date range can not be selected when viewing only active orders" + . S DIR(0)="E" D ^DIR + S OLD=$P(HDR,";"),NEW=$$START(OLD,REQ) Q:NEW="^" S BEG=NEW + I BEG="" S END="" G RQ + S OLD=$P(HDR,";",2),NEW=$$STOP(OLD,REQ) Q:NEW="^" S END=NEW + I END0 Y="" + Q +Y + ; +LISTHDR ; -- List available subhdrs + N HDR,DONE,CNT D FULL^VALM1 + W !!,"Choose from:" S HDR="",(CNT,DONE)=0,VALMBCK="R" + F S HDR=$O(^TMP("OR",$J,"CURRENT","HDR",HDR)) Q:HDR="" D Q:DONE + . S CNT=CNT+1 I CNT>(IOSL-2) S CNT=0 I '$$MORE^ORCD S DONE=1 Q + . W !," "_HDR + Q + ; +LRSUB ; -- Return lab subscript to jump to in list + ; Available subscripts in ^TMP("OR",$J,"IDX",name)=line # + I '$D(^TMP("OR",$J,"CURRENT","HDR")) W !!,"There are no section headers defined for this report." H 3 Q + N X,Y,DIR,XP,P,CNT,MATCH D FULL^VALM1 S VALMBCK="R" +LRS S DIR(0)="FAO^1:30",DIR("A")="Select Lab Section: " + S DIR("A",1)="Available sections in this report:",X="" + F I=2:1 S X=$O(^TMP("OR",$J,"CURRENT","HDR",X)) Q:X="" S DIR("A",I)=" "_X + S DIR("?")="Enter the lab section from which to wish to see results; the display will scroll to the top of the selected section" ;,DIR("??")="^D LISTHDR^ORCHANGE" + D ^DIR Q:"^"[Y + S XP=$$UP^XLFSTR(X) + I $G(^TMP("OR",$J,"CURRENT","HDR",XP)) S VALMBG=^(XP),VALMBCK="R" Q + S CNT=0,P=XP F S P=$O(^TMP("OR",$J,"CURRENT","HDR",P)) Q:$E(P,1,$L(XP))'=XP S CNT=CNT+1,MATCH(CNT)=+$G(^(P))_U_P ; line# ^ hdr name + I 'CNT W $C(7)," ??" G LRS + I CNT=1 S VALMBG=+MATCH(CNT),VALMBCK="R",P=$P(MATCH(1),U,2) W $E(P,$L(X)+1,$L(P)) Q +LRS1 K DIR S DIR(0)="NAO^1:"_CNT,DIR("A")="Select 1-"_CNT_": " + F I=1:1:CNT S DIR("A",I)=I_" "_$P(MATCH(I),U,2) + S DIR("?")="Select the lab section you want to go to, by number" + D ^DIR Q:$D(DTOUT)!($D(DUOUT)) I 'Y K DIR G LRS + S VALMBG=+MATCH(Y),VALMBCK="R" + Q + ; +DGROUP ; -- Select new service (display group) + N X,Y,Z,ZZ,DIC,HDR,DONE,HELP + D FULL^VALM1 S VALMBCK="R" + S HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3),Z=$P(HDR,";",4),ZZ=+$O(^ORD(100.98,"B",$S($L(Z):Z,1:"ALL"),0)) + S HELP="Enter the service or section from which you wish to see orders for this patient." + S DONE=0 F D Q:DONE + . W !!,"Select Service/Section: "_$P(^ORD(100.98,+ZZ,0),U)_"//" + . R X:DTIME S:'$T X="^" I X["^" S DONE=1 Q + . I X="" S DONE=1 Q ; no change + . I X["?" W !!,HELP,!,"Choose from:" D DG^ORCHANG1(1,"DISP") Q + . S DIC=100.98,DIC(0)="NEQZ" D ^DIC S:Y>0 Z=$P(Y(0),U,3),ZZ=+Y,DONE=1 + S $P(HDR,";",4)=Z,$P(^TMP("OR",$J,ORTAB,0),U,3,4)=HDR_U + Q + ; +CS ; -- Select new consult service + N GMRCDG,GMRCBUF,GMRCACT,GMRCQUT,GMRCGRP,HDR + D FULL^VALM1,ASRV^GMRCASV S VALMBCK="R" Q:$D(GMRCQUT) + S:$G(GMRCDG) HDR=$P($G(^TMP("OR",$J,ORTAB,0)),U,3),$P(HDR,";",4)=GMRCDG,$P(^(0),U,3,4)=HDR_U + K ^TMP("GMRCS",$J),^TMP("GMRCSLIST",$J) + Q + ; +REMOVE ; -- Remove preferred view + N ORDEL S ORDEL=1 +SAVE ; -- Save current view as preferred + Q:'$$OK($G(ORDEL)) N X,Y,PARAM + S X=$S($G(ORDEL):"@",1:$P($G(^TMP("OR",$J,ORTAB,0)),U,3)),Y="" + ;S:$G(ORTAB)="MEDS" Y=$S($P(X,";",3):"IN",1:"OUT")_"PT " + S:$G(ORTAB)="LABS" Y=$S($G(ORWARD):"IN",1:"OUT")_"PT " + S PARAM="ORCH CONTEXT "_Y_$G(ORTAB) + D EN^XPAR("USR",PARAM,1,X) W " ...done." H 1 + Q + ; +OK(DEL) ; -- Are you sure you want to save/remove view of ORTAB? + N X,Y,DIR S DIR(0)="YA" + S DIR("A")="Are you sure you want to "_$S($G(DEL):"remove",1:"save the current view as")_" your preference? " + S:$G(DEL) DIR("?",1)="Enter YES if you wish to remove your preferred view of this chart tab and use",DIR("?")="the default view next time, or NO to quit without changing anything." + S:'$G(DEL) DIR("?",1)="Enter YES if you wish to use these same parameters again the next time the ",DIR("?")=$$LOWER^VALM1(ORTAB)_" tab is created for you, or NO to quit without saving anything." + D ^DIR + Q +Y + ; +RETURN ; -- Return to preferred view of ORTAB + S $P(^TMP("OR",$J,ORTAB,0),U,4)=1 + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCHECK.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCHECK.m index 17b416dc..c8716826 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCHECK.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCHECK.m @@ -1,163 +1,144 @@ -ORCHECK ;SLC/MKB-Order checking calls ; 08 May 2002 2:12 PM [8/16/05 5:28am] - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,56,70,94,141,215,243**;Dec 17, 1997;Build 242 - ;;Per VHA Directive 2004-038, this routine should not be modified. -DISPLAY ; -- DISPLAY event [called from ORCDLG,ORCACT4,ORCMED] - ; Expects ORVP, ORNMSP, ORTAB, [ORWARD] - Q:$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE")'="E" - N ORX,ORY,I - I ORNMSP="PS" D ;reset to PSJ, PSJI, or PSO - . I $G(ORDG) S I=$P($G(^ORD(100.98,+ORDG,0)),U,3),I=$P(I," ") Q:'$L(I) S ORNMSP="PS"_$S(I="UD":"I",1:I) Q - . I $G(ORXFER) S I=$P($P(^TMP("OR",$J,ORTAB,0),U,3),";",3) S:I="" I=$G(ORWARD) S ORNMSP="PS"_$S(I:"O",1:"I") ;opposite of list - S ORX(1)="|"_ORNMSP,ORX=1 - D EN^ORKCHK(.ORY,+ORVP,.ORX,"DISPLAY") Q:'$D(ORY) - S I=0 F S I=$O(ORY(I)) Q:I'>0 W !,$P(ORY(I),U,4) ; display only - Q - ; -SELECT ; -- SELECT event - ; Expects ORVP, ORDAILOG(PROMPT,ORI), ORNMSP - Q:$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE")'="E" - N ORX,ORY,OI - S OI=+$G(ORDIALOG(PROMPT,ORI)) - S ORX=1,ORX(1)=OI_"|"_ORNMSP_"|"_$$USID^ORMBLD(OI) - D EN^ORKCHK(.ORY,+ORVP,.ORX,"SELECT"),RETURN:$D(ORY) - Q - ; -ACCEPT(MODE) ; -- ACCEPT event [called from ORCDLG,ORCACT4,ORCMED] - ; Expects ORVP, ORDIALOG(), ORNMSP - Q:$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE")'="E" - N ORX,ORY,ORZ,OI,ORSTRT,ORI,ORIT,ORID,ORSP - S:'$L($G(MODE)) MODE="ACCEPT" - S OI=$$PTR^ORCD("OR GTX ORDERABLE ITEM"),ORSTRT=$$START,ORX=0 - S ORI=0 F S ORI=$O(ORDIALOG(OI,ORI)) Q:ORI'>0 D STUF - I $G(ORDG)=+$O(^ORD(100.98,"B","IV RX",0)) S OI=$$PTR^ORCD("OR GTX ADDITIVE"),ORI=0 F S ORI=$O(ORDIALOG(OI,ORI)) Q:ORI'>0 D STUF - D EN^ORKCHK(.ORY,+ORVP,.ORX,MODE),RETURN:$D(ORY) - Q -STUF S ORIT=ORDIALOG(OI,ORI),ORSP="" - S:ORNMSP="LR" ORSP=+$G(ORDIALOG($$PTR^ORCD("OR GTX SPECIMEN"),ORI)) - S ORID=$S($E(ORNMSP,1,2)="PS":$$DRUG(ORIT,OI),1:$$USID^ORMBLD(ORIT)) - S ORZ=1,ORZ(1)=ORIT_"|"_ORNMSP_"|"_ORID - I MODE'="ALL" D EN^ORKCHK(.ORY,+ORVP,.ORZ,"SELECT"),RETURN:$D(ORY) - S ORX=ORX+1,ORX(ORX)=ORZ(1)_"|"_ORSTRT_"||"_ORSP K ORY,ORZ - Q - ; -DELAY(MODE) ; -- Delayed ACCEPT event [called from ORMEVNT] - ; Expects ORVP, ORIFN - Q:$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE")'="E" - N ORX,ORY,ORCHECK S:'$L($G(MODE)) MODE="NOTIF" - D BLD(+ORIFN),EN^ORKCHK(.ORY,+ORVP,.ORX,MODE) Q:'$D(ORY) - D RETURN I MODE="NOTIF" S ORCHECK("OK")="Notification sent to provider" D OC^ORCSAVE2 Q ; silent - Q - ; -SESSION ; -- SESSION event [called from ORCSIGN] - ; Expects ORVP, ORES() - Q:$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE")'="E" - N ORX,ORY,ORIFN,I,X,Y - S ORIFN=0 F S ORIFN=$O(ORES(ORIFN)) Q:ORIFN'>0 I +$P(ORIFN,";",2)'>1 D - . I "^5^6^10^11^"'[(U_$P($G(^OR(100,+ORIFN,3)),U,3)_U) Q ;unreleased - . D BLD(+ORIFN) Q:'$D(^OR(100,+ORIFN,9)) - . S ORCHECK("IFN")=+$G(ORCHECK("IFN"))+1 - . S I=0 F S I=$O(^OR(100,+ORIFN,9,I)) Q:I'>0 S X=$G(^(I,0)),Y=$G(^(1)),ORCHECK=+$G(ORCHECK)+1,ORCHECK(+ORIFN,$S($P(X,U,2):$P(X,U,2),1:99),ORCHECK)=$P(X,U,1,2)_U_Y - I $D(ORX) D EN^ORKCHK(.ORY,+ORVP,.ORX,"SESSION"),RETURN:$D(ORY),REMDUPS - Q - ; -BLD(ORDER) ; -- Build new ORX(#) for ORDER - Q:'$G(ORDER) Q:'$D(^OR(100,ORDER,0)) ;Q:$P($G(^(3)),U,11) ;edit/renew - N PKG,START,ORI,ITEM,USID,SPEC,ORDG,PTR,INST - S ORDG=$P(^OR(100,ORDER,0),U,11),PKG=$$GET1^DIQ(9.4,$P(^(0),U,14)_",",1) - I PKG="PS",$G(ORDG) S ORI=$P($G(^ORD(100.98,+ORDG,0)),U,3),ORI=$P(ORI," "),PKG=PKG_$S(ORI="UD":"I",1:ORI) - S START=$$START(ORDER),ORI=0 - F S ORI=$O(^OR(100,ORDER,4.5,"ID","ORDERABLE",ORI)) Q:ORI'>0 D - . S INST=$P($G(^OR(100,ORDER,4.5,ORI,0)),U,3),PTR=$P($G(^(0)),U,2),ITEM=+$G(^(1)) - . S USID=$S(PKG?1"PS".E:$$DRUG(ITEM,PTR,ORDER),1:$$USID^ORMBLD(ITEM)) - . S SPEC=$S(PKG="LR":$$VALUE^ORCSAVE2(ORDER,"SPECIMEN",INST),1:"") - . S ORX=+$G(ORX)+1,ORX(ORX)=ITEM_"|"_PKG_"|"_USID_"|"_START_"|"_ORDER_"|"_SPEC - Q - ; -RETURN ; -- Return checks in ORCHECK(ORIFN,CDL,#) - N I,IFN,CDL S I=0 F S I=$O(ORY(I)) Q:I'>0 D - . S IFN=+$P(ORY(I),U) S:'IFN IFN="NEW" - . S CDL=+$P(ORY(I),U,3) S:'CDL CDL=99 - . S:'$D(ORCHECK(IFN)) ORCHECK("IFN")=+$G(ORCHECK("IFN"))+1 ; count - . S ORCHECK=+$G(ORCHECK)+1,ORCHECK(IFN,CDL,ORCHECK)=$P(ORY(I),U,2,4) - Q - ; -REMDUPS ; - N IFN,CDL,I - S IFN=0 F S IFN=$O(ORCHECK(IFN)) Q:'IFN D - . S CDL=0 F S CDL=$O(ORCHECK(IFN,CDL)) Q:'CDL D - . . S I=0 F S I=$O(ORCHECK(IFN,CDL,I)) Q:'I D - . . . S J=I F S J=$O(ORCHECK(IFN,CDL,J)) Q:'J I $G(ORCHECK(IFN,CDL,I))=$G(ORCHECK(IFN,CDL,J)) K ORCHECK(IFN,CDL,J) S ORCHECK=$G(ORCHECK)-1 - Q -START(DA) ; -- Returns start date/time - N I,X,Y,%DT S Y="" - I $G(DA) S X=$O(^OR(100,DA,4.5,"ID","START",0)),X=$G(^OR(100,DA,4.5,+X,1)) - E D ; look in ORDIALOG instead - . S I=0 F S I=$O(ORDIALOG(I)) Q:I'>0 Q:$P(ORDIALOG(I),U,2)="START" - . S X=$S(I:$G(ORDIALOG(I,1)),1:"") - D AM^ORCSAVE2:X="AM",NEXT^ORCSAVE2:X="NEXT" - D ADMIN^ORCSAVE2("NEXT"):X="NEXTA",ADMIN^ORCSAVE2("CLOSEST"):X="CLOSEST" - I $L(X) S %DT="TX" D ^%DT S:Y'>0 Y="" - Q Y - ; -DRUG(OI,PTR,IFN) ; -- Returns 6 ^-piece identifier for Dispense Drug - N ORDD,ORNDF,Y - I ORDG=+$O(^ORD(100.98,"B","IV RX",0)) S ORDD=$$IV G D1 - I $G(IFN) S ORDD=$O(^OR(100,IFN,4.5,"ID","DRUG",0)),ORDD=+$G(^OR(100,IFN,4.5,+ORDD,1)) - E S ORDD=+$G(ORDIALOG($$PTR^ORCD("OR GTX DISPENSE DRUG"),1)) -D1 Q:'ORDD "" S ORNDF=$$ENDCM^PSJORUTL(ORDD) - S Y=$P(ORNDF,U,3)_"^^99NDF^"_ORDD_U_$$NAME50^ORPEAPI(ORDD)_"^99PSD" - Q Y - ; -IV() ; -- Get Dispense Drug for IV orderable - N PSOI,TYPE,VOL,ORY - S PSOI=+$P($G(^ORD(101.43,+OI,0)),U,2),VOL="" - S TYPE=$S(PTR=$$PTR^ORCD("OR GTX ADDITIVE"):"A",1:"B") - S:TYPE="B" VOL=$S($G(IFN):$$VALUE^ORCSAVE2(IFN,"VOLUME"),1:+$G(ORDIALOG($$PTR^ORCD("OR GTX VOLUME"),1))) - D ENDDIV^PSJORUTL(PSOI,TYPE,VOL,.ORY) - Q +$G(ORY) - ; -LIST(IFN) ; -- Displays list of ORCHECK(IFN) checks - N ORI,ORJ,ORZ,ORMAX,ORTX,ON,OFF - S ORZ=0 F S ORZ=$O(ORCHECK(IFN,ORZ)) Q:ORZ'>0 D - . S:ORZ=1 ON=IOINHI,OFF=IOINORM S:ORZ'=1 (ON,OFF)="" ; use bold if High - . S ORI=0 F S ORI=$O(ORCHECK(IFN,ORZ,ORI)) Q:ORI'>0 D - . . S X=$P(ORCHECK(IFN,ORZ,ORI),U,3) I $L(X)<75 W !,ON_">>> "_X_OFF Q - . . S ORMAX=74 K ORTX D TXT^ORCHTAB Q:'$G(ORTX) ; wrap - . . F ORJ=1:1:ORTX W !,ON_$S(ORJ=1:">>> ",1:" ")_ORTX(ORJ)_OFF - W ! - Q - ; -CANCEL() ; -- Returns 1 or 0: Cancel order(s)? - N X,Y,DIR,NUM - S NUM=+$G(ORCHECK("IFN")),DIR(0)="YA" - S DIR("A")="Do you want to cancel "_$S(NUM>1:"any of the new orders? ",1:"the new order? ") - S DIR("?",1)="Enter YES to cancel "_$S(NUM>1:"an",1:"the")_" order. If you wish to override these order checks" - S DIR("?",2)="and release "_$S(NUM>1:"these orders",1:"this order")_", enter NO; you will be prompted for a justification",DIR("?")="if there are any highlighted critical order checks." - D ^DIR - Q +Y - ; -REASON() ; -- Reason for overriding order checks - ; I '$D(^XUSEC("ORES",DUZ)),'$D(^XUSEC("ORELSE",DUZ)) Q ?? - N X,Y,DIR - S DIR(0)="FA^2:80^K:X?1."" "" X",DIR("A")="REASON FOR OVERRIDE: " - S DIR("?")="Enter a justification for overriding these order checks, up to 80 characters" - D ^DIR I $D(DTOUT)!$D(DUOUT) S Y="^" - Q Y -OCAPI(IFN,ORPLACE) ;IA #4859 - ;API to get the order checking info for a specific order (IFN) - ;info is stored in ^TMP($J,ORPLACE) - ; ^TMP($J,ORPLACE,D0,"OC LEVEL")="order check level" - ; ,"OC TEXT")="order check text" - ; ,"OR REASON")="over ride reason text" - ; ,"OR PROVIDER")="provider DUZ who entered over ride reason" - ; ,"OR DT")="date/time over ride reason was entered" - ; NOTE on OC LEVEL: 1 is HIGH, 2 is MODERATE, 3 is LOW - I '$D(^OR(100,IFN,9)) Q - N I - S I=0 F S I=$O(^OR(100,IFN,9,I)) Q:'I D - .S ^TMP($J,ORPLACE,I,"OC LEVEL")=$P($G(^OR(100,IFN,9,I,0)),U,2) - .S ^TMP($J,ORPLACE,I,"OC TEXT")=$G(^OR(100,IFN,9,I,1)) - .S ^TMP($J,ORPLACE,I,"OR REASON")=$P($G(^OR(100,IFN,9,I,0)),U,4) - .S ^TMP($J,ORPLACE,I,"OR PROVIDER")=$P($G(^OR(100,IFN,9,I,0)),U,5) - .S ^TMP($J,ORPLACE,I,"OR DT")=$P($G(^OR(100,IFN,9,I,0)),U,6) - Q +ORCHECK ;SLC/MKB-Order checking calls ; 08 May 2002 2:12 PM [8/16/05 5:28am] + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,56,70,94,141,215**;Dec 17, 1997 +DISPLAY ; -- DISPLAY event [called from ORCDLG,ORCACT4,ORCMED] + ; Expects ORVP, ORNMSP, ORTAB, [ORWARD] + Q:$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE")'="E" + N ORX,ORY,I + I ORNMSP="PS" D ;reset to PSJ, PSJI, or PSO + . I $G(ORDG) S I=$P($G(^ORD(100.98,+ORDG,0)),U,3),I=$P(I," ") Q:'$L(I) S ORNMSP="PS"_$S(I="UD":"I",1:I) Q + . I $G(ORXFER) S I=$P($P(^TMP("OR",$J,ORTAB,0),U,3),";",3) S:I="" I=$G(ORWARD) S ORNMSP="PS"_$S(I:"O",1:"I") ;opposite of list + S ORX(1)="|"_ORNMSP,ORX=1 + D EN^ORKCHK(.ORY,+ORVP,.ORX,"DISPLAY") Q:'$D(ORY) + S I=0 F S I=$O(ORY(I)) Q:I'>0 W !,$P(ORY(I),U,4) ; display only + Q + ; +SELECT ; -- SELECT event + ; Expects ORVP, ORDAILOG(PROMPT,ORI), ORNMSP + Q:$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE")'="E" + N ORX,ORY,OI + S OI=+$G(ORDIALOG(PROMPT,ORI)) + S ORX=1,ORX(1)=OI_"|"_ORNMSP_"|"_$$USID^ORMBLD(OI) + D EN^ORKCHK(.ORY,+ORVP,.ORX,"SELECT"),RETURN:$D(ORY) + Q + ; +ACCEPT(MODE) ; -- ACCEPT event [called from ORCDLG,ORCACT4,ORCMED] + ; Expects ORVP, ORDIALOG(), ORNMSP + Q:$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE")'="E" + N ORX,ORY,ORZ,OI,ORSTRT,ORI,ORIT,ORID,ORSP + S:'$L($G(MODE)) MODE="ACCEPT" + S OI=$$PTR^ORCD("OR GTX ORDERABLE ITEM"),ORSTRT=$$START,ORX=0 + S ORI=0 F S ORI=$O(ORDIALOG(OI,ORI)) Q:ORI'>0 D STUF + I $G(ORDG)=+$O(^ORD(100.98,"B","IV RX",0)) S OI=$$PTR^ORCD("OR GTX ADDITIVE"),ORI=0 F S ORI=$O(ORDIALOG(OI,ORI)) Q:ORI'>0 D STUF + D EN^ORKCHK(.ORY,+ORVP,.ORX,MODE),RETURN:$D(ORY) + Q +STUF S ORIT=ORDIALOG(OI,ORI),ORSP="" + S:ORNMSP="LR" ORSP=+$G(ORDIALOG($$PTR^ORCD("OR GTX SPECIMEN"),ORI)) + S ORID=$S($E(ORNMSP,1,2)="PS":$$DRUG(ORIT,OI),1:$$USID^ORMBLD(ORIT)) + S ORZ=1,ORZ(1)=ORIT_"|"_ORNMSP_"|"_ORID + I MODE'="ALL" D EN^ORKCHK(.ORY,+ORVP,.ORZ,"SELECT"),RETURN:$D(ORY) + S ORX=ORX+1,ORX(ORX)=ORZ(1)_"|"_ORSTRT_"||"_ORSP K ORY,ORZ + Q + ; +DELAY(MODE) ; -- Delayed ACCEPT event [called from ORMEVNT] + ; Expects ORVP, ORIFN + Q:$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE")'="E" + N ORX,ORY,ORCHECK S:'$L($G(MODE)) MODE="NOTIF" + D BLD(+ORIFN),EN^ORKCHK(.ORY,+ORVP,.ORX,MODE) Q:'$D(ORY) + D RETURN I MODE="NOTIF" S ORCHECK("OK")="Notification sent to provider" D OC^ORCSAVE2 Q ; silent + Q + ; +SESSION ; -- SESSION event [called from ORCSIGN] + ; Expects ORVP, ORES() + Q:$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE")'="E" + N ORX,ORY,ORIFN,I,X,Y + S ORIFN=0 F S ORIFN=$O(ORES(ORIFN)) Q:ORIFN'>0 I +$P(ORIFN,";",2)'>1 D + . I "^5^6^10^11^"'[(U_$P($G(^OR(100,+ORIFN,3)),U,3)_U) Q ;unreleased + . D BLD(+ORIFN) Q:'$D(^OR(100,+ORIFN,9)) + . S ORCHECK("IFN")=+$G(ORCHECK("IFN"))+1 + . S I=0 F S I=$O(^OR(100,+ORIFN,9,I)) Q:I'>0 S X=$G(^(I,0)),Y=$G(^(1)),ORCHECK=+$G(ORCHECK)+1,ORCHECK(+ORIFN,$S($P(X,U,2):$P(X,U,2),1:99),ORCHECK)=$P(X,U,1,2)_U_Y + I $D(ORX) D EN^ORKCHK(.ORY,+ORVP,.ORX,"SESSION"),RETURN:$D(ORY),REMDUPS + Q + ; +BLD(ORDER) ; -- Build new ORX(#) for ORDER + Q:'$G(ORDER) Q:'$D(^OR(100,ORDER,0)) ;Q:$P($G(^(3)),U,11) ;edit/renew + N PKG,START,ORI,ITEM,USID,SPEC,ORDG,PTR,INST + S ORDG=$P(^OR(100,ORDER,0),U,11),PKG=$$GET1^DIQ(9.4,$P(^(0),U,14)_",",1) + I PKG="PS",$G(ORDG) S ORI=$P($G(^ORD(100.98,+ORDG,0)),U,3),ORI=$P(ORI," "),PKG=PKG_$S(ORI="UD":"I",1:ORI) + S START=$$START(ORDER),ORI=0 + F S ORI=$O(^OR(100,ORDER,4.5,"ID","ORDERABLE",ORI)) Q:ORI'>0 D + . S INST=$P($G(^OR(100,ORDER,4.5,ORI,0)),U,3),PTR=$P($G(^(0)),U,2),ITEM=+$G(^(1)) + . S USID=$S(PKG?1"PS".E:$$DRUG(ITEM,PTR,ORDER),1:$$USID^ORMBLD(ITEM)) + . S SPEC=$S(PKG="LR":$$VALUE^ORCSAVE2(ORDER,"SPECIMEN",INST),1:"") + . S ORX=+$G(ORX)+1,ORX(ORX)=ITEM_"|"_PKG_"|"_USID_"|"_START_"|"_ORDER_"|"_SPEC + Q + ; +RETURN ; -- Return checks in ORCHECK(ORIFN,CDL,#) + N I,IFN,CDL S I=0 F S I=$O(ORY(I)) Q:I'>0 D + . S IFN=+$P(ORY(I),U) S:'IFN IFN="NEW" + . S CDL=+$P(ORY(I),U,3) S:'CDL CDL=99 + . S:'$D(ORCHECK(IFN)) ORCHECK("IFN")=+$G(ORCHECK("IFN"))+1 ; count + . S ORCHECK=+$G(ORCHECK)+1,ORCHECK(IFN,CDL,ORCHECK)=$P(ORY(I),U,2,4) + Q + ; +REMDUPS ; + N IFN,CDL,I + S IFN=0 F S IFN=$O(ORCHECK(IFN)) Q:'IFN D + . S CDL=0 F S CDL=$O(ORCHECK(IFN,CDL)) Q:'CDL D + . . S I=0 F S I=$O(ORCHECK(IFN,CDL,I)) Q:'I D + . . . S J=I F S J=$O(ORCHECK(IFN,CDL,J)) Q:'J I $G(ORCHECK(IFN,CDL,I))=$G(ORCHECK(IFN,CDL,J)) K ORCHECK(IFN,CDL,J) S ORCHECK=$G(ORCHECK)-1 + Q +START(DA) ; -- Returns start date/time + N I,X,Y,%DT S Y="" + I $G(DA) S X=$O(^OR(100,DA,4.5,"ID","START",0)),X=$G(^OR(100,DA,4.5,+X,1)) + E D ; look in ORDIALOG instead + . S I=0 F S I=$O(ORDIALOG(I)) Q:I'>0 Q:$P(ORDIALOG(I),U,2)="START" + . S X=$S(I:$G(ORDIALOG(I,1)),1:"") + D AM^ORCSAVE2:X="AM",NEXT^ORCSAVE2:X="NEXT" + D ADMIN^ORCSAVE2("NEXT"):X="NEXTA",ADMIN^ORCSAVE2("CLOSEST"):X="CLOSEST" + I $L(X) S %DT="TX" D ^%DT S:Y'>0 Y="" + Q Y + ; +DRUG(OI,PTR,IFN) ; -- Returns 6 ^-piece identifier for Dispense Drug + N ORDD,ORNDF,Y + I ORDG=+$O(^ORD(100.98,"B","IV RX",0)) S ORDD=$$IV G D1 + I $G(IFN) S ORDD=$O(^OR(100,IFN,4.5,"ID","DRUG",0)),ORDD=+$G(^OR(100,IFN,4.5,+ORDD,1)) + E S ORDD=+$G(ORDIALOG($$PTR^ORCD("OR GTX DISPENSE DRUG"),1)) +D1 Q:'ORDD "" S ORNDF=$$ENDCM^PSJORUTL(ORDD) + S Y=$P(ORNDF,U,3)_"^^99NDF^"_ORDD_U_$P($G(^PSDRUG(ORDD,0)),U)_"^99PSD" + Q Y + ; +IV() ; -- Get Dispense Drug for IV orderable + N PSOI,TYPE,VOL,ORY + S PSOI=+$P($G(^ORD(101.43,+OI,0)),U,2),VOL="" + S TYPE=$S(PTR=$$PTR^ORCD("OR GTX ADDITIVE"):"A",1:"B") + S:TYPE="B" VOL=$S($G(IFN):$$VALUE^ORCSAVE2(IFN,"VOLUME"),1:+$G(ORDIALOG($$PTR^ORCD("OR GTX VOLUME"),1))) + D ENDDIV^PSJORUTL(PSOI,TYPE,VOL,.ORY) + Q +$G(ORY) + ; +LIST(IFN) ; -- Displays list of ORCHECK(IFN) checks + N ORI,ORJ,ORZ,ORMAX,ORTX,ON,OFF + S ORZ=0 F S ORZ=$O(ORCHECK(IFN,ORZ)) Q:ORZ'>0 D + . S:ORZ=1 ON=IOINHI,OFF=IOINORM S:ORZ'=1 (ON,OFF)="" ; use bold if High + . S ORI=0 F S ORI=$O(ORCHECK(IFN,ORZ,ORI)) Q:ORI'>0 D + . . S X=$P(ORCHECK(IFN,ORZ,ORI),U,3) I $L(X)<75 W !,ON_">>> "_X_OFF Q + . . S ORMAX=74 K ORTX D TXT^ORCHTAB Q:'$G(ORTX) ; wrap + . . F ORJ=1:1:ORTX W !,ON_$S(ORJ=1:">>> ",1:" ")_ORTX(ORJ)_OFF + W ! + Q + ; +CANCEL() ; -- Returns 1 or 0: Cancel order(s)? + N X,Y,DIR,NUM + S NUM=+$G(ORCHECK("IFN")),DIR(0)="YA" + S DIR("A")="Do you want to cancel "_$S(NUM>1:"any of the new orders? ",1:"the new order? ") + S DIR("?",1)="Enter YES to cancel "_$S(NUM>1:"an",1:"the")_" order. If you wish to override these order checks" + S DIR("?",2)="and release "_$S(NUM>1:"these orders",1:"this order")_", enter NO; you will be prompted for a justification",DIR("?")="if there are any highlighted critical order checks." + D ^DIR + Q +Y + ; +REASON() ; -- Reason for overriding order checks + ; I '$D(^XUSEC("ORES",DUZ)),'$D(^XUSEC("ORELSE",DUZ)) Q ?? + N X,Y,DIR + S DIR(0)="FA^2:80^K:X?1."" "" X",DIR("A")="REASON FOR OVERRIDE: " + S DIR("?")="Enter a justification for overriding these order checks, up to 80 characters" + D ^DIR I $D(DTOUT)!$D(DUOUT) S Y="^" + Q Y diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCMED.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCMED.m index cb259aa6..88041632 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCMED.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCMED.m @@ -1,143 +1,143 @@ -ORCMED ;SLC/MKB-Medication actions ;03/19/07 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,7,38,48,94,141,178,190,195,243**;Dec 17, 1997;Build 242 -XFER ; -- transfer to in/outpt meds - N ORPTLK,ORTYPE,ORXFER,ORSRC,ORCAT,OREVENT,X,ORINPT,ORIDLG,ORODLG,ORIVDLG,ORNMSP,ORCNT,ORI,NMBR,ORIFN,OLDIFN,ORDIALOG,ORDG,ORCHECK,ORQUIT,ORDUZ,ORLOG,FIRST,ORDITM,ORD,ORERR - S ORPTLK=$$LOCK^ORX2(+ORVP) I 'ORPTLK D G XFQ ; lock pt chart - . W !!,$C(7),$P(ORPTLK,U,2) H 2 - . S:'$D(VALMBCK) VALMBCK="" - I '$G(ORNMBR) S ORNMBR=$$ORDERS^ORCHART("transfer") G:'ORNMBR XFQ - D FULL^VALM1 S VALMBCK="R",ORTYPE="Q",ORXFER=1,ORDUZ=DUZ,ORSRC="X" - S X=$P($P($G(^TMP("OR",$J,"CURRENT",0)),U,3),";",3) S:X="" X=$G(ORWARD) - S ORCAT=$S(X:"O",1:"I") I ORCAT="I"!$G(ORWARD) D Q:$G(OREVENT)="^" - . W !!,$$CURRENT^OREVNT - . S X=$$DELAY^ORCACT I X="^" S OREVENT="^" Q - . S:X OREVENT=+$$PTEVENT^OREVNT(+ORVP,1) - I '$G(ORL) S ORL=$S($G(OREVENT):$$LOC^OREVNTX(OREVENT),1:$$LOCATION^ORCMENU1) G:ORL="^" XFQ - S ORINPT=$$INPT^ORCD,ORNP=$$PROVIDER^ORCMENU1 G:ORNP="^" XFQ - I 'ORINPT,ORCAT="I" D IMOLOC^ORIMO(.ORINPT,+ORL,+ORVP) S:ORINPT<0 ORINPT=0 ;allow inpt meds at this location? - S ORIDLG=+$O(^ORD(101.41,"AB","PSJ OR PAT OE",0)) - S ORODLG=+$O(^ORD(101.41,"AB","PSO OERR",0)) - S ORIVDLG=+$O(^ORD(101.41,"AB","PSJI OR PAT FLUID OE",0)) - D PROVIDER^ORCDPSIV G:$G(ORQUIT) XFQ ;X:$D(^ORD(101.41,ORDIALOG,3)) ^(3) - S ORNMSP="PS" D DISPLAY^ORCHECK - S ORCNT=$L(ORNMBR,",") S:$P(ORNMBR,",",ORCNT)'>0 ORCNT=ORCNT-1 -XF1 F ORI=1:1:ORCNT S NMBR=$P(ORNMBR,",",ORI) D:NMBR I $D(ORQUIT),ORI0 D - . K ORDIALOG(DOSE,I) S X=$G(ORDIALOG(PROMPT,I)) Q:'$L(X) - . S X=$$UP^XLFSTR(X),DD=+$G(ORDIALOG(PROMPT,"LIST","D",X)) Q:'DD - . S ORDIALOG(DOSE,I)=$TR($G(ORDOSE("DD",DD,X)),"^","&") - . S ORDIALOG(DRUG,I)=DD,DRUG0=$G(ORDOSE("DD",DD)) - . S STR=$P(DRUG0,U,5)_$P(DRUG0,U,6) - . I STR'>0 S:'$G(ORDOSE(1)) ORDIALOG($$PTR("DRUG NAME"),1)=$P(DRUG0,U) Q - . I ORMED'[STR,TYPE="O"!'$G(ORDOSE(1)) S ORDIALOG($$PTR("STRENGTH"),1)=STR - Q - ; -CONT() ; -- Want to continue processing orders? - N X,Y,DIR - S DIR(0)="YA",DIR("A")="Do you want to continue transferring orders? ",DIR("B")="YES" - S DIR("?")="Enter YES to continue transferring the remaining orders selected, or NO to quit this option." - D ^DIR - Q +Y - ; -SHOWSIG ; -- Show old sig for transfer in ^TMP("ORSIG",$J) - N ORTX,I,X,ORMAX S ORMAX=72 - S I=0 F S I=$O(^TMP("ORSIG",$J,I)) Q:I'>0 S X=$G(^(I,0)) D:$L(X) TXT^ORCHTAB - S I=0 F S I=$O(ORTX(I)) Q:I'>0 W !,$S(I=1:"(Sig: ",1:" ")_ORTX(I) - W ")" - Q - ; -PTR(NAME) ; -- Returns pointer to OR GTX NAME - Q +$O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0)) - ; -REFILLS ; -- Request a refill for med orders - ; ORNMBR = #,#,...,# of selected orders - ; - N ORLK,ORI,NMBR,IDX,ORIFN,ORDITM,ORERR,ORQUIT,OROUT - I '$G(ORNMBR) S ORNMBR=$$ORDERS^ORCHART("") G:'ORNMBR RFQ - D FREEZE^ORCMENU S VALMBCK="R" - S ORNP=$$PROVIDER^ORCMENU1 G:ORNP="^" RFQ - S:'$G(ORL) ORL=$$LOCATION^ORCMENU1 G:ORL="^" RFQ - S OROUT=$$ROUTING G:OROUT="^" RFQ - F ORI=1:1:$L(ORNMBR,",") S NMBR=$P(ORNMBR,",",ORI) D:NMBR Q:$D(ORQUIT) - . S IDX=$G(^TMP("OR",$J,"CURRENT","IDX",NMBR)),ORIFN=+$P(IDX,U,4) - . Q:'ORIFN I '$D(^OR(100,ORIFN,0)) W !,"Invalid order number!" H 2 Q - . S ORDITM=$$ORDITEM^ORCACT(ORIFN) D SUBHDR^ORCACT(ORDITM) - . I '$$VALID^ORCACT0(ORIFN,"RF",.ORERR) W !,ORERR H 2 Q - . S ORLK=$$LOCK1^ORX2(+ORIFN) I 'ORLK W !,$P(ORLK,U,2) H 2 Q - . D REF^ORMBLDPS(ORIFN,OROUT),UNLK1^ORX2(+ORIFN) - . W !?10,"... refill requested.",$$RETURN -RFQ Q - ; -RETURN() ; -- press return to cont - N X W !,"Press to continue ..." R X:DTIME - Q "" - ; -ROUTING() ; -- Routing for refill - N X,Y,DIR S DIR(0)="SAM^W:WINDOW;M:MAIL;C:ADMINISTERED IN CLINIC;" - S DIR("A")="Routing: ",DIR("B")=$S($D(^PSX(550,"C")):"MAIL",1:"WINDOW") - S DIR("?")="Select how the patient is to receive this refill, by mail or at the window or in the clinic" - D ^DIR S:$D(DTOUT)!(X["^") Y="^" - Q Y - ; -NW ; -- Order New Medication from Meds tab - ; Requires ORDIALOG = name of pkg dialog - ; OREVENT = event, if delaying orders - ; OREVENT("TS") = treating spec, if admission or transfer - N ORPTLK G:'$L($G(ORDIALOG)) NWQ - S ORPTLK=$$LOCK^ORX2(+ORVP) I 'ORPTLK W !!,$C(7),$P(ORPTLK,U,2) H 2 Q - D FREEZE^ORCMENU S VALMBCK="R" - S ORNP=$$PROVIDER^ORCMENU1 G:ORNP="^" NWQ - I '$G(ORL) S ORL=$S($G(OREVENT):$$LOC^OREVNTX(OREVENT),1:$$LOCATION^ORCMENU1) G:ORL["^" NWQ - S ORDIALOG=$O(^ORD(101.41,"AB",$E(ORDIALOG,1,63),0)) G:'ORDIALOG NWQ - D ADD^ORCDLG,REBLD^ORCMENU:$D(^TMP("ORNEW",$J)) - K ORDIALOG,^TMP("ORWORD",$J),^TMP("ORECALL",$J) S VALMBCK="R" -NWQ D:'$D(^TMP("ORNEW",$J)) UNLOCK^ORX2(+ORVP) ;unlock if no new orders - Q +ORCMED ;SLC/MKB-Medication actions ;4/2/02 16:45 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,7,38,48,94,141,178,190,195**;Dec 17, 1997 +XFER ; -- transfer to in/outpt meds + N ORPTLK,ORTYPE,ORXFER,ORSRC,ORCAT,OREVENT,X,ORINPT,ORIDLG,ORODLG,ORIVDLG,ORNMSP,ORCNT,ORI,NMBR,ORIFN,OLDIFN,ORDIALOG,ORDG,ORCHECK,ORQUIT,ORDUZ,ORLOG,FIRST,ORDITM,ORD,ORERR + S ORPTLK=$$LOCK^ORX2(+ORVP) I 'ORPTLK D G XFQ ; lock pt chart + . W !!,$C(7),$P(ORPTLK,U,2) H 2 + . S:'$D(VALMBCK) VALMBCK="" + I '$G(ORNMBR) S ORNMBR=$$ORDERS^ORCHART("transfer") G:'ORNMBR XFQ + D FULL^VALM1 S VALMBCK="R",ORTYPE="Q",ORXFER=1,ORDUZ=DUZ,ORSRC="X" + S X=$P($P($G(^TMP("OR",$J,"CURRENT",0)),U,3),";",3) S:X="" X=$G(ORWARD) + S ORCAT=$S(X:"O",1:"I") I ORCAT="I"!$G(ORWARD) D Q:$G(OREVENT)="^" + . W !!,$$CURRENT^OREVNT + . S X=$$DELAY^ORCACT I X="^" S OREVENT="^" Q + . S:X OREVENT=+$$PTEVENT^OREVNT(+ORVP,1) + I '$G(ORL) S ORL=$S($G(OREVENT):$$LOC^OREVNTX(OREVENT),1:$$LOCATION^ORCMENU1) G:ORL="^" XFQ + S ORINPT=$$INPT^ORCD,ORNP=$$PROVIDER^ORCMENU1 G:ORNP="^" XFQ + I 'ORINPT,ORCAT="I" D IMOLOC^ORIMO(.ORINPT,+ORL,+ORVP) S:ORINPT<0 ORINPT=0 ;allow inpt meds at this location? + S ORIDLG=+$O(^ORD(101.41,"AB","PSJ OR PAT OE",0)) + S ORODLG=+$O(^ORD(101.41,"AB","PSO OERR",0)) + S ORIVDLG=+$O(^ORD(101.41,"AB","PSJI OR PAT FLUID OE",0)) + D PROVIDER^ORCDPSIV G:$G(ORQUIT) XFQ ;X:$D(^ORD(101.41,ORDIALOG,3)) ^(3) + S ORNMSP="PS" D DISPLAY^ORCHECK + S ORCNT=$L(ORNMBR,",") S:$P(ORNMBR,",",ORCNT)'>0 ORCNT=ORCNT-1 +XF1 F ORI=1:1:ORCNT S NMBR=$P(ORNMBR,",",ORI) D:NMBR I $D(ORQUIT),ORI0 D + . K ORDIALOG(DOSE,I) S X=$G(ORDIALOG(PROMPT,I)) Q:'$L(X) + . S X=$$UP^XLFSTR(X),DD=+$G(ORDIALOG(PROMPT,"LIST","D",X)) Q:'DD + . S ORDIALOG(DOSE,I)=$TR($G(ORDOSE("DD",DD,X)),"^","&") + . S ORDIALOG(DRUG,I)=DD,DRUG0=$G(ORDOSE("DD",DD)) + . S STR=$P(DRUG0,U,5)_$P(DRUG0,U,6) + . I STR'>0 S:'$G(ORDOSE(1)) ORDIALOG($$PTR("DRUG NAME"),1)=$P(DRUG0,U) Q + . I ORMED'[STR,TYPE="O"!'$G(ORDOSE(1)) S ORDIALOG($$PTR("STRENGTH"),1)=STR + Q + ; +CONT() ; -- Want to continue processing orders? + N X,Y,DIR + S DIR(0)="YA",DIR("A")="Do you want to continue transferring orders? ",DIR("B")="YES" + S DIR("?")="Enter YES to continue transferring the remaining orders selected, or NO to quit this option." + D ^DIR + Q +Y + ; +SHOWSIG ; -- Show old sig for transfer in ^TMP("ORSIG",$J) + N ORTX,I,X,ORMAX S ORMAX=72 + S I=0 F S I=$O(^TMP("ORSIG",$J,I)) Q:I'>0 S X=$G(^(I,0)) D:$L(X) TXT^ORCHTAB + S I=0 F S I=$O(ORTX(I)) Q:I'>0 W !,$S(I=1:"(Sig: ",1:" ")_ORTX(I) + W ")" + Q + ; +PTR(NAME) ; -- Returns pointer to OR GTX NAME + Q +$O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0)) + ; +REFILLS ; -- Request a refill for med orders + ; ORNMBR = #,#,...,# of selected orders + ; + N ORLK,ORI,NMBR,IDX,ORIFN,ORDITM,ORERR,ORQUIT,OROUT + I '$G(ORNMBR) S ORNMBR=$$ORDERS^ORCHART("") G:'ORNMBR RFQ + D FREEZE^ORCMENU S VALMBCK="R" + S ORNP=$$PROVIDER^ORCMENU1 G:ORNP="^" RFQ + S:'$G(ORL) ORL=$$LOCATION^ORCMENU1 G:ORL="^" RFQ + S OROUT=$$ROUTING G:OROUT="^" RFQ + F ORI=1:1:$L(ORNMBR,",") S NMBR=$P(ORNMBR,",",ORI) D:NMBR Q:$D(ORQUIT) + . S IDX=$G(^TMP("OR",$J,"CURRENT","IDX",NMBR)),ORIFN=+$P(IDX,U,4) + . Q:'ORIFN I '$D(^OR(100,ORIFN,0)) W !,"Invalid order number!" H 2 Q + . S ORDITM=$$ORDITEM^ORCACT(ORIFN) D SUBHDR^ORCACT(ORDITM) + . I '$$VALID^ORCACT0(ORIFN,"RF",.ORERR) W !,ORERR H 2 Q + . S ORLK=$$LOCK1^ORX2(+ORIFN) I 'ORLK W !,$P(ORLK,U,2) H 2 Q + . D REF^ORMBLDPS(ORIFN,OROUT),UNLK1^ORX2(+ORIFN) + . W !?10,"... refill requested.",$$RETURN +RFQ Q + ; +RETURN() ; -- press return to cont + N X W !,"Press to continue ..." R X:DTIME + Q "" + ; +ROUTING() ; -- Routing for refill + N X,Y,DIR S DIR(0)="SAM^W:WINDOW;M:MAIL;C:ADMINISTERED IN CLINIC;" + S DIR("A")="Routing: ",DIR("B")=$S($D(^PSX(550,"C")):"MAIL",1:"WINDOW") + S DIR("?")="Select how the patient is to receive this refill, by mail or at the window or in the clinic" + D ^DIR S:$D(DTOUT)!(X["^") Y="^" + Q Y + ; +NW ; -- Order New Medication from Meds tab + ; Requires ORDIALOG = name of pkg dialog + ; OREVENT = event, if delaying orders + ; OREVENT("TS") = treating spec, if admission or transfer + N ORPTLK G:'$L($G(ORDIALOG)) NWQ + S ORPTLK=$$LOCK^ORX2(+ORVP) I 'ORPTLK W !!,$C(7),$P(ORPTLK,U,2) H 2 Q + D FREEZE^ORCMENU S VALMBCK="R" + S ORNP=$$PROVIDER^ORCMENU1 G:ORNP="^" NWQ + I '$G(ORL) S ORL=$S($G(OREVENT):$$LOC^OREVNTX(OREVENT),1:$$LOCATION^ORCMENU1) G:ORL["^" NWQ + S ORDIALOG=$O(^ORD(101.41,"AB",$E(ORDIALOG,1,63),0)) G:'ORDIALOG NWQ + D ADD^ORCDLG,REBLD^ORCMENU:$D(^TMP("ORNEW",$J)) + K ORDIALOG,^TMP("ORWORD",$J),^TMP("ORECALL",$J) S VALMBCK="R" +NWQ D:'$D(^TMP("ORNEW",$J)) UNLOCK^ORX2(+ORVP) ;unlock if no new orders + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCMEDT0.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCMEDT0.m index 05b42232..2b89030c 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCMEDT0.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCMEDT0.m @@ -1,75 +1,72 @@ -ORCMEDT0 ;SLC/MKB-Dialog Utilities ;08/06/2007 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**46,60,190,215,243**;Dec 17, 1997;Build 242 -DIALOG(TYPE) ; -- Get Dialog file entry - N X,Y,Z,D,DIC,DIE,DIK,DA,DR,DLAYGO,ORPKG,ORDLG,ORIT,OROI,I,IDX - S ORPKG="ORDER ENTRY/RESULTS REPORTING",DIC="^ORD(101.41,",DIC(0)="AEQLZ" - S DIC("S")="I $P(^(0),U,4)="""_TYPE_"""",DLAYGO=101.41 - S DIC("A")="Select "_$S(TYPE="Q":"QUICK ORDER",TYPE="O":"ORDER SET",TYPE="A":"ACTION",1:"ORDER DIALOG")_" NAME: " - S DIC("DR")="4///"_TYPE_$S(TYPE="D":";7///^S X=ORPKG",1:"") -D0 S D="AB" D IX^DIC I Y'>0 S ORDLG="^" G DQ - S ORDLG=+Y,ORDG=$P(Y(0),U,5) G:'$P(Y,U,3) DQ ; not a new entry - I $O(^ORD(101.41,"AB",$P(Y,U,2),0))'=+Y W $C(7),!,"Another entry already exists by this name!",! D DEL(+Y) G D0 - I TYPE="D" D G:ORDLG="^" DQ ;new dialog - . S DA=ORDLG,DR="5R",DIE=DIC,ORIT=$P(Y,U,2) D ^DIE - . S ORDG=+$P($G(^ORD(101.41,ORDLG,0)),U,5) - . I 'ORDG W $C(7),!,"Deleting <"_ORIT_"> ..." S DA=ORDLG,DIK=DIC D ^DIK S ORDLG="^" Q - . S ORIT=$$OI^ORCMEDT3(+ORDG) S:ORIT="^" ORDLG="^" - I TYPE="Q" D G DQ ;new quick order - . S DIC="^ORD(100.98,",DIC(0)="AEQM",DIC("S")="I $P(^(0),U,4)" - . S DIC("A")="TYPE OF QUICK ORDER: " D ^DIC - . I Y>0 S ORDG=+Y,$P(^ORD(101.41,ORDLG,0),U,5)=+Y Q - . W !,$P(^ORD(101.41,ORDLG,0),U)_" quick order dialog DELETED!",! - . S DA=ORDLG,DIK="^ORD(101.41,",ORDLG="^" D ^DIK -D1 I $$COPY^ORCMEDIT(TYPE) D ;copy an existing dialog? - . K DLAYGO,DIC("B") S DIC(0)="AEQZ",DIC("A")="Select "_$S(TYPE="Q":"QUICK ORDER",TYPE="O":"ORDER SET",1:"ORDER DIALOG")_" TO COPY: " - . D ^DIC Q:Y'>0 W !,"Copying ..." - . F I=2,6,8,9 S $P(^ORD(101.41,ORDLG,0),U,I)=$P(Y(0),U,I) - . S:TYPE'="D" $P(^ORD(101.41,ORDLG,0),U,5)=$P(Y(0),U,5) ;skip DG if Dlg - . S:$L($P(Y(0),U,2)) ^ORD(101.41,"C",$$UP^XLFSTR($P(Y(0),U,2)),ORDLG)="" ;disp text - . F I=2,3,3.1,4,5,6,7,9,10 I $D(^ORD(101.41,+Y,I)) M ^ORD(101.41,ORDLG,I)=^ORD(101.41,+Y,I) - . I $P(Y(0),U,7) S DA=ORDLG,DIE=DIC,DR="7///"_$P(Y(0),U,7) D ^DIE - . K DA S DA(1)=ORDLG,DIK="^ORD(101.41,"_ORDLG_",10,",DIK(1)="2^AD" D ENALL^DIK -D2 I TYPE="D",$G(ORIT) D ;stuff in default OI - . S DA=ORDLG,DR="2///"_$P(ORIT,U,2),DIE="^ORD(101.41," D ^DIE - . S OROI=$$PTR^ORCD("OR GTX ORDERABLE ITEM"),DA=$O(^ORD(101.41,ORDLG,10,"D",OROI,0)) I 'DA D Q:'DA ;create OI prompt - .. S X=+$O(^ORD(101.41,ORDLG,10,"B",0)),X=$S(X=0:1,1:X-.1) ;get Seq# - .. K DA,DIC S DIC="^ORD(101.41,"_ORDLG_",10,",DIC(0)="L",DA(1)=ORDLG - .. D ^DIC Q:Y'>0 S DA=+Y ;S DIC("P")=$P(^DD(101.41,10,0),U,2) - .. S Z=+$O(^ORD(101.41,ORDLG,10,"ATXT",0)),Z=$S(Z=0:1,1:Z-.1) ;TxtSeq# - .. S ^ORD(101.41,ORDLG,10,DA,0)=X_U_OROI_"^^Order: ^^1",^(2)=Z - .. S ^ORD(101.41,"AD",OROI,ORDLG,DA)="",^ORD(101.41,ORDLG,10,"B",X,DA)="",^ORD(101.41,ORDLG,10,"D",OROI,DA)="",^ORD(101.41,ORDLG,10,"ATXT",X,DA)="" - . S IDX="S."_$P($G(^ORD(100.98,+ORDG,0)),U,3) - . S $P(^ORD(101.41,ORDLG,10,DA,0),U,8)=1,$P(^(0),U,10)=IDX,^(3)="I 0 ;uneditable",^(7)="S Y="_+ORIT -DQ Q ORDLG - ; -DEL(DA) ; -- delete bad entry in Order Dialog file - N DIK S DIK="^ORD(101.41," D:$G(DA) ^DIK - Q - ; -SAVE ; -- Save ORDG, responses in ORDIALOG to dialog ORQDLG - N PROMPT,CNT,ITM,TYPE,INST,VALUE,INP,UD K ^ORD(101.41,ORQDLG,6) - S (PROMPT,CNT)=0 F S PROMPT=$O(ORDIALOG(PROMPT)) Q:PROMPT'>0 D - . S ITM=ORDIALOG(PROMPT),TYPE=$E(ORDIALOG(PROMPT,0)) - . S INST=0 F S INST=$O(ORDIALOG(PROMPT,INST)) Q:INST'>0 D - . . S VALUE=$G(ORDIALOG(PROMPT,INST)),CNT=CNT+1 - . . S ^ORD(101.41,ORQDLG,6,CNT,0)=+ITM_U_PROMPT_U_INST - . . S:TYPE'="W" ^ORD(101.41,ORQDLG,6,CNT,1)=VALUE - . . M:TYPE="W" ^ORD(101.41,ORQDLG,6,CNT,2)=@VALUE - . . S ^ORD(101.41,ORQDLG,6,"D",PROMPT,CNT)="" - S ^ORD(101.41,ORQDLG,6,0)="^101.416^"_CNT_U_CNT - S INP=+$O(^ORD(100.98,"B","INPATIENT MEDICATIONS","")) - S UD=+$O(^ORD(100.98,"B","UNIT DOSE MEDICATIONS","")) - I +$G(ORDG)>0,ORDG=INP,UD>0 S ORDG=UD - S:$G(ORDG) $P(^ORD(101.41,ORQDLG,0),U,5)=+ORDG - Q - ; -ITEM(Z) ; -- Select new item to add - N X,Y,DIC,ORDDF,ORERR,I - S DIC=101.41,DIC(0)="AEQM",DIC("A")="ITEM: " - I $G(Z) S Z=$P($G(^ORD(101.41,+Z,0)),U) S:$L(Z) DIC("B")=Z - S DIC("S")="I $P(^(0),U,4)'=""P""" -IT1 D ^DIC I Y'>0 S Y=$S($D(DUOUT)!$D(DTOUT):"^",1:"") Q Y - D RECURSV^ORCMEDT5(+Y,+ORMENU,.ORERR) I $D(ORERR) D G IT1 - . W $C(7),!!,"An ancestor of this menu may not be added as an item!" - . W !,ORERR S I=0 F S I=$O(ORERR(I)) Q:I'>0 W !?18," =>"_ORERR(I) - Q +Y +ORCMEDT0 ;SLC/MKB-Dialog Utilities ;04:11 PM 12 Feb 1999 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**46,60,190,215**;Dec 17, 1997 +DIALOG(TYPE) ; -- Get Dialog file entry + N X,Y,Z,D,DIC,DIE,DIK,DA,DR,DLAYGO,ORPKG,ORDLG,ORIT,OROI,I,IDX + S ORPKG="ORDER ENTRY/RESULTS REPORTING",DIC="^ORD(101.41,",DIC(0)="AEQLZ" + S DIC("S")="I $P(^(0),U,4)="""_TYPE_"""",DLAYGO=101.41 + S DIC("A")="Select "_$S(TYPE="Q":"QUICK ORDER",TYPE="O":"ORDER SET",TYPE="A":"ACTION",1:"ORDER DIALOG")_" NAME: " + S DIC("DR")="4///"_TYPE_$S(TYPE="D":";7///^S X=ORPKG",1:"") +D0 S D="AB" D IX^DIC I Y'>0 S ORDLG="^" G DQ + S ORDLG=+Y,ORDG=$P(Y(0),U,5) G:'$P(Y,U,3) DQ ; not a new entry + I $O(^ORD(101.41,"AB",$P(Y,U,2),0))'=+Y W $C(7),!,"Another entry already exists by this name!",! D DEL(+Y) G D0 + I TYPE="D" D G:ORDLG="^" DQ ;new dialog + . S DA=ORDLG,DR="5R",DIE=DIC,ORIT=$P(Y,U,2) D ^DIE + . S ORDG=+$P($G(^ORD(101.41,ORDLG,0)),U,5) + . I 'ORDG W $C(7),!,"Deleting <"_ORIT_"> ..." S DA=ORDLG,DIK=DIC D ^DIK S ORDLG="^" Q + . S ORIT=$$OI^ORCMEDT3(+ORDG) S:ORIT="^" ORDLG="^" + I TYPE="Q" D G DQ ;new quick order + . S DIC="^ORD(100.98,",DIC(0)="AEQM",DIC("S")="I $P(^(0),U,4)" + . S DIC("A")="TYPE OF QUICK ORDER: " D ^DIC + . I Y>0 S ORDG=+Y,$P(^ORD(101.41,ORDLG,0),U,5)=+Y Q + . W !,$P(^ORD(101.41,ORDLG,0),U)_" quick order dialog DELETED!",! + . S DA=ORDLG,DIK="^ORD(101.41,",ORDLG="^" D ^DIK +D1 I $$COPY^ORCMEDIT(TYPE) D ;copy an existing dialog? + . K DLAYGO,DIC("B") S DIC(0)="AEQZ",DIC("A")="Select "_$S(TYPE="Q":"QUICK ORDER",TYPE="O":"ORDER SET",1:"ORDER DIALOG")_" TO COPY: " + . D ^DIC Q:Y'>0 W !,"Copying ..." + . F I=2,6,8,9 S $P(^ORD(101.41,ORDLG,0),U,I)=$P(Y(0),U,I) + . S:TYPE'="D" $P(^ORD(101.41,ORDLG,0),U,5)=$P(Y(0),U,5) ;skip DG if Dlg + . S:$L($P(Y(0),U,2)) ^ORD(101.41,"C",$$UP^XLFSTR($P(Y(0),U,2)),ORDLG)="" ;disp text + . F I=2,3,3.1,4,5,6,7,9,10 I $D(^ORD(101.41,+Y,I)) M ^ORD(101.41,ORDLG,I)=^ORD(101.41,+Y,I) + . I $P(Y(0),U,7) S DA=ORDLG,DIE=DIC,DR="7///"_$P(Y(0),U,7) D ^DIE + . K DA S DA(1)=ORDLG,DIK="^ORD(101.41,"_ORDLG_",10,",DIK(1)="2^AD" D ENALL^DIK +D2 I TYPE="D",$G(ORIT) D ;stuff in default OI + . S DA=ORDLG,DR="2///"_$P(ORIT,U,2),DIE="^ORD(101.41," D ^DIE + . S OROI=$$PTR^ORCD("OR GTX ORDERABLE ITEM"),DA=$O(^ORD(101.41,ORDLG,10,"D",OROI,0)) I 'DA D Q:'DA ;create OI prompt + .. S X=+$O(^ORD(101.41,ORDLG,10,"B",0)),X=$S(X=0:1,1:X-.1) ;get Seq# + .. K DA,DIC S DIC="^ORD(101.41,"_ORDLG_",10,",DIC(0)="L",DA(1)=ORDLG + .. D ^DIC Q:Y'>0 S DA=+Y ;S DIC("P")=$P(^DD(101.41,10,0),U,2) + .. S Z=+$O(^ORD(101.41,ORDLG,10,"ATXT",0)),Z=$S(Z=0:1,1:Z-.1) ;TxtSeq# + .. S ^ORD(101.41,ORDLG,10,DA,0)=X_U_OROI_"^^Order: ^^1",^(2)=Z + .. S ^ORD(101.41,"AD",OROI,ORDLG,DA)="",^ORD(101.41,ORDLG,10,"B",X,DA)="",^ORD(101.41,ORDLG,10,"D",OROI,DA)="",^ORD(101.41,ORDLG,10,"ATXT",X,DA)="" + . S IDX="S."_$P($G(^ORD(100.98,+ORDG,0)),U,3) + . S $P(^ORD(101.41,ORDLG,10,DA,0),U,8)=1,$P(^(0),U,10)=IDX,^(3)="I 0 ;uneditable",^(7)="S Y="_+ORIT +DQ Q ORDLG + ; +DEL(DA) ; -- delete bad entry in Order Dialog file + N DIK S DIK="^ORD(101.41," D:$G(DA) ^DIK + Q + ; +SAVE ; -- Save ORDG, responses in ORDIALOG to dialog ORQDLG + N PROMPT,CNT,ITM,TYPE,INST,VALUE K ^ORD(101.41,ORQDLG,6) + S (PROMPT,CNT)=0 F S PROMPT=$O(ORDIALOG(PROMPT)) Q:PROMPT'>0 D + . S ITM=ORDIALOG(PROMPT),TYPE=$E(ORDIALOG(PROMPT,0)) + . S INST=0 F S INST=$O(ORDIALOG(PROMPT,INST)) Q:INST'>0 D + . . S VALUE=$G(ORDIALOG(PROMPT,INST)),CNT=CNT+1 + . . S ^ORD(101.41,ORQDLG,6,CNT,0)=+ITM_U_PROMPT_U_INST + . . S:TYPE'="W" ^ORD(101.41,ORQDLG,6,CNT,1)=VALUE + . . M:TYPE="W" ^ORD(101.41,ORQDLG,6,CNT,2)=@VALUE + . . S ^ORD(101.41,ORQDLG,6,"D",PROMPT,CNT)="" + S ^ORD(101.41,ORQDLG,6,0)="^101.416^"_CNT_U_CNT + S:$G(ORDG) $P(^ORD(101.41,ORQDLG,0),U,5)=+ORDG + Q + ; +ITEM(Z) ; -- Select new item to add + N X,Y,DIC,ORDDF,ORERR,I + S DIC=101.41,DIC(0)="AEQM",DIC("A")="ITEM: " + I $G(Z) S Z=$P($G(^ORD(101.41,+Z,0)),U) S:$L(Z) DIC("B")=Z + S DIC("S")="I $P(^(0),U,4)'=""P""" +IT1 D ^DIC I Y'>0 S Y=$S($D(DUOUT)!$D(DTOUT):"^",1:"") Q Y + D RECURSV^ORCMEDT5(+Y,+ORMENU,.ORERR) I $D(ORERR) D G IT1 + . W $C(7),!!,"An ancestor of this menu may not be added as an item!" + . W !,ORERR S I=0 F S I=$O(ORERR(I)) Q:I'>0 W !?18," =>"_ORERR(I) + Q +Y diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCMEDT1.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCMEDT1.m index 8289e339..ae66e08b 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCMEDT1.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCMEDT1.m @@ -1,123 +1,122 @@ -ORCMEDT1 ;SLC/MKB-QO,Set editor ;02/25/08 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**8,46,57,95,110,245,243**;Dec 17, 1997;Build 242 -OI ; -- Enter/edit generic orderable items - N X,Y,DA,DR,DIE,DIC,ID,DLAYGO,ORDG - F S ORDG=$$DGRP Q:ORDG'>0 D W !! - . F S D="S."_$P(ORDG,U,4) D Q:Y'>0 S DA=+Y,ID=DA_";99ORD",DR=".01"_$S($P(Y,U,3):";2///^S X=ID;5////"_+ORDG,1:"") D ^DIE W ! ;110 - .. S DIC="^ORD(101.43,",DIC(0)="AEQL",DLAYGO=101.43,DIE=DIC D IX^DIC ;110 - Q - ; -DGRP() ; -- Returns sub-display group of Nursing or Other for generic OI - N X,Y,DIC,ORGRP,ORDG,ORI - F ORI="NURS","OTHER" S ORDG=+$O(^ORD(100.98,"B",ORI,0)) D DG^ORCHANG1(ORDG,"BILD",.ORGRP) - S DIC="^ORD(100.98,",DIC(0)="AEQ",DIC("S")="I $D(ORGRP(+Y))" - S DIC("A")="Type of Orderable: " D ^DIC - S:Y>0 Y=+Y_U_$G(^ORD(100.98,+Y,0)) - Q Y - ; -QUICK ; -- Enter/edit quick order dialogs - N ORQDLG,ORDG - F S ORQDLG=$$DIALOG^ORCMEDT0("Q") Q:ORQDLG="^" D QCK0(ORQDLG) W ! - Q -QCK0(ORQDLG) ; -- edit quick order ORQDLG - N ORDIALOG,DA,DR,DIE,DIDEL,ORQUIT,ORVP,ORL,ACTION,FIRST,ORTYPE,ORNAME,X,Y,BEFORCRC,AFTERCRC - Q:'$G(ORQDLG) S DA=ORQDLG,(ORVP,ORL)=0,FIRST=1,ORTYPE="Z" - S ORNAME=$$NAME^ORCMEDT4(ORQDLG) Q:(ORNAME="@")!(ORNAME="^") ;deleted,^ - S BEFORCRC=$$RAWCRC^ORCMEDT8(ORQDLG) - S DR=".01///^S X=ORNAME;2;8;20"_$S(DUZ(0)="@":";30",1:""),DIE="^ORD(101.41," - D ^DIE G:$D(Y)!$D(DTOUT) QR D GETQDLG^ORCD(ORQDLG) G:'$G(ORDIALOG) QR - I '$P($G(^ORD(101.41,ORQDLG,0)),U,7) S X=+$P($G(^ORD(101.41,+ORDIALOG,0)),U,7) S:X $P(^ORD(101.41,ORQDLG,0),U,7)=X,^ORD(101.41,"APKG",X,ORQDLG)="" - W ! I $D(^ORD(101.41,+ORDIALOG,3.1)) X ^(3.1) G:$G(ORQUIT) QQ -Q1 D DIALOG^ORCDLG G:$G(ORQUIT) QQ - D DISPLAY^ORCDLG S ACTION=$$OK G:ACTION="^" QQ - D:ACTION="P" SAVE^ORCMEDT0,AUTO(ORQDLG) I ACTION="E" S FIRST=0 G Q1 ;fall thru if "C" -QQ X:$D(^ORD(101.41,+ORDIALOG,4)) ^(4) -QR S AFTERCRC=$$RAWCRC^ORCMEDT8(ORQDLG) - I BEFORCRC'=AFTERCRC D UPDQNAME^ORCMEDT8(ORQDLG) ; Rename personal quick order if modified - Q - ; -OK() ; -- Ready to save? - N X,Y,DIR S DIR(0)="SAM^P:PLACE;E:EDIT;C:CANCEL;",DIR("B")="PLACE" - S DIR("A")="(P)lace, (E)dit, or (C)ancel this quick order? " - S DIR("?")="Enter P to save this quick order, or E to change any of the displayed values; enter C to quit without saving these responses" - D ^DIR S:$D(DTOUT) Y="^" - Q Y - ; -SAVE G SAVE^ORCMEDT0 - ; -AUTO(DLG) ; -- set AutoAccept flag for GUI - N X,Y,DIR - I $$VALQO^ORWDXM3(+DLG)=0 S $P(^ORD(101.41,+DLG,5),U,8)="" Q - S DIR(0)="YA",DIR("A")="Auto-accept this order? " - S DIR("B")=$S($P($G(^ORD(101.41,+DLG,5)),U,8):"YES",1:"NO") - S DIR("?")="Enter YES if this order can be placed simply by selecting it, or NO if the dialog should be presented to complete the order." - D ^DIR S:Y=1!(Y=0) $P(^ORD(101.41,+DLG,5),U,8)=$S(Y:1,1:"") - I $P($G(^ORD(101.41,+DLG,0)),"^",8)'=1&($P($G(^(0)),"^",9)=2)&(Y) D EXPLAIN S $P(^ORD(101.41,+DLG,5),"^",8)="" ;Reset auto-accept to no if explanation required. - Q - ; -SET ; -- Order Sets - N ORSET,ORDG - F S ORSET=$$DIALOG^ORCMEDT0("O") Q:ORSET="^" D SET0(ORSET) W ! - Q -SET0(ORSET) ; -- edit order set ORSET - N DA,DR,DIE,DIC,DIK,X,Y,SEQ,ITM,LCNT,QUIT,ORNAME Q:'$G(ORSET) - S ORNAME=$$NAME^ORCMEDT4(ORSET) Q:(ORNAME="@")!(ORNAME="^") ;deleted,^ - S DR=".01///^S X=ORNAME;2;20"_$S(DUZ(0)="@":";30;40",1:""),DA=ORSET - S DIE="^ORD(101.41," D ^DIE Q:$D(Y) Q:'$G(DA) -S1 I $O(^ORD(101.41,+ORSET,10,0)) D Q:QUIT ;Show existing components - . W !,"ORDER SET COMPONENTS:" S (SEQ,LCNT,QUIT)=0 - . S DIK="^ORD(101.41,"_+ORSET_",10,",DA(1)=+ORSET ;just in case - . F S SEQ=$O(^ORD(101.41,+ORSET,10,"B",SEQ)) Q:SEQ'>0 D - . . S DA=0 F S DA=$O(^ORD(101.41,+ORSET,10,"B",SEQ,DA)) Q:DA'>0 D - . . . S ITM=$P($G(^ORD(101.41,+ORSET,10,DA,0)),U,2) I ITM'>0 D ^DIK Q - . . . S LCNT=LCNT+1 I LCNT>(IOSL-3) R !,"Press to continue ...",X:DTIME S LCNT=0 I X["^" S QUIT=1 Q - . . . W !?3,SEQ,?10,$P(^ORD(101.41,ITM,0),U) -S2 S QUIT=0 F D Q:QUIT W ! ;Enter/edit components - . S DIC="^ORD(101.41,"_+ORSET_",10,",DIC(0)="AEQLM",D="B^D" - . S DIC("A")="Select COMPONENT SEQUENCE#: ",DIC("P")=$P(^DD(101.41,10,0),U,2) - . K DA S DA(1)=+ORSET D MIX^DIC1 I Y'>0 S QUIT=1 Q - . S DA=+Y,DIE=DIC,DR=".01;2R" D ^DIE Q:'$G(DA) - . I $D(^ORD(101.41,+ORSET,10,DA,0)),'$P(^(0),U,2) S DIK=DIE D ^DIK - Q - ; -PROTOCOL ; -- Convert additional protocols to dialogs - N X,Y,DIC,ORERR - F S DIC="^ORD(101,",DIC(0)="AEQM" D ^DIC Q:Y'>0 D W ! - . S ORP=+Y,ORM=$$MENU Q:ORM="^" ; What about "^^"-jumping? (ORWARD) - . W !,"Converting ..." D ONE(ORP,ORM,.ORERR) I '$G(ORERR) W " done." Q - . W " unable to convert.",!,">> "_$P(ORERR,U,2) K ORERR - Q -ONE(PITEM,ORADD,ERROR) ; -- Convert single item protocol, add to menu(s) - N PMENU,DMENU,NAME,ORPOS,POS,XUTL,DA,DIK - I $D(^ORD(100.99,1,101.41,PITEM,0)) S DA=PITEM,DA(1)=1,DIK="^ORD(100.99,1,101.41," D ^DIK ; delete error entry - S NAME=$P($G(^ORD(101,PITEM,0)),U),DITEM=$$ITEM^ORCONVRT(PITEM) - I 'DITEM!$D(^ORD(100.99,1,101.41,PITEM,0)) S ERROR=$G(^(0)) Q - Q:'$G(ORADD) ;to add, may enter here with PITEM & DITEM defined -ADD S PMENU=0 F S PMENU=$O(^ORD(101,"AD",PITEM,PMENU)) Q:PMENU'>0 D W "." - . S DMENU=$O(^ORD(101.41,"AB",$P(^ORD(101,PMENU,0),U),0)) Q:'DMENU - . S ORPOS=$$FINDXUTL(PMENU,PITEM) Q:'ORPOS - . S XUTL=$G(^XUTL("XQORM",PMENU_";ORD(101,",ORPOS,0)) - . S DA=$O(^ORD(101.41,DMENU,10,"B",ORPOS,0)) I DA Q:$P(^ORD(101.41,DMENU,10,DA,0),U,2)=DITEM S POS=$O(^ORD(101.41,DMENU,10,"B",""),-1),ORPOS=($P(POS,".")+1)_".1",DA="" ; move to end, if collision - . S DA=$$NEXT^ORCONVRT(DMENU) - . S ^ORD(101.41,DMENU,10,DA,0)=ORPOS_U_DITEM_U_$P(XUTL,U,4)_U_$S($P(XUTL,U,3)'=$P(^ORD(101.41,DITEM,0),U,2):$P(XUTL,U,3),1:"") - . S ^ORD(101.41,DMENU,10,"B",ORPOS,DA)="",^ORD(101.41,DMENU,10,"D",DITEM,DA)="" - . S ^ORD(101.41,"AD",DITEM,DMENU,DA)="",^ORD(101.41,DMENU,99)=$H - Q - ; -FINDXUTL(MENU,ITEM) ; -- Returns position of ITEM in MENU - N XQORM,POS - S XQORM=MENU_";ORD(101," D XREF^XQORM - S POS=0 F S POS=$O(^XUTL("XQORM",XQORM,POS)) Q:POS'>0 I $P(^(POS,0),U,2)=ITEM Q - Q POS - ; -MENU() ; -- Add converted item to menus? - N X,Y,DIR S DIR(0)="YA" - S DIR("A")="Add this item to the same menus again? ",DIR("B")="YES" - S DIR("?")="Enter YES to have this item placed on the same menus in the Order Dialog file as it was in the Protocol file" - D ^DIR S:$D(DTOUT) Y="^" - Q Y -EXPLAIN ;Give reason why user can't set auto-accept to yes - W !!,"The combination of VERIFY set to NO and ASK FOR ANOTHER ORDER set to",!,"YES, DON'T ASK and AUTO-ACCEPT set to YES is not allowed." - W !!,"This combination of settings could cause CPRS to enter into an infinite loop",!,"creating the same order over and over. If you wish to have" - W !,"AUTO-ACCEPT set to YES you must change one of the other two fields",!,"to a different value.",!!,"AUTO-ACCEPT is being set to NO for you." - Q +ORCMEDT1 ;SLC/MKB-QO,Set editor ;11/6/01 13:33 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**8,46,57,95,110,245**;Dec 17, 1997;Build 2 +OI ; -- Enter/edit generic orderable items + N X,Y,DA,DR,DIE,DIC,ID,DLAYGO,ORDG + F S ORDG=$$DGRP Q:ORDG'>0 D W !! + . F S D="S."_$P(ORDG,U,4) D Q:Y'>0 S DA=+Y,ID=DA_";99ORD",DR=".01"_$S($P(Y,U,3):";2///^S X=ID;5////"_+ORDG,1:"") D ^DIE W ! ;110 + .. S DIC="^ORD(101.43,",DIC(0)="AEQL",DLAYGO=101.43,DIE=DIC D IX^DIC ;110 + Q + ; +DGRP() ; -- Returns sub-display group of Nursing or Other for generic OI + N X,Y,DIC,ORGRP,ORDG,ORI + F ORI="NURS","OTHER" S ORDG=+$O(^ORD(100.98,"B",ORI,0)) D DG^ORCHANG1(ORDG,"BILD",.ORGRP) + S DIC="^ORD(100.98,",DIC(0)="AEQ",DIC("S")="I $D(ORGRP(+Y))" + S DIC("A")="Type of Orderable: " D ^DIC + S:Y>0 Y=+Y_U_$G(^ORD(100.98,+Y,0)) + Q Y + ; +QUICK ; -- Enter/edit quick order dialogs + N ORQDLG,ORDG + F S ORQDLG=$$DIALOG^ORCMEDT0("Q") Q:ORQDLG="^" D QCK0(ORQDLG) W ! + Q +QCK0(ORQDLG) ; -- edit quick order ORQDLG + N ORDIALOG,DA,DR,DIE,DIDEL,ORQUIT,ORVP,ORL,ACTION,FIRST,ORTYPE,ORNAME,X,Y,BEFORCRC,AFTERCRC + Q:'$G(ORQDLG) S DA=ORQDLG,(ORVP,ORL)=0,FIRST=1,ORTYPE="Z" + S ORNAME=$$NAME^ORCMEDT4(ORQDLG) Q:(ORNAME="@")!(ORNAME="^") ;deleted,^ + S BEFORCRC=$$RAWCRC^ORCMEDT8(ORQDLG) + S DR=".01///^S X=ORNAME;2;8;20"_$S(DUZ(0)="@":";30",1:""),DIE="^ORD(101.41," + D ^DIE G:$D(Y)!$D(DTOUT) QR D GETQDLG^ORCD(ORQDLG) G:'$G(ORDIALOG) QR + I '$P($G(^ORD(101.41,ORQDLG,0)),U,7) S X=+$P($G(^ORD(101.41,+ORDIALOG,0)),U,7) S:X $P(^ORD(101.41,ORQDLG,0),U,7)=X,^ORD(101.41,"APKG",X,ORQDLG)="" + W ! I $D(^ORD(101.41,+ORDIALOG,3.1)) X ^(3.1) G:$G(ORQUIT) QQ +Q1 D DIALOG^ORCDLG G:$G(ORQUIT) QQ + D DISPLAY^ORCDLG S ACTION=$$OK G:ACTION="^" QQ + D:ACTION="P" SAVE^ORCMEDT0,AUTO(ORQDLG) I ACTION="E" S FIRST=0 G Q1 ;fall thru if "C" +QQ X:$D(^ORD(101.41,+ORDIALOG,4)) ^(4) +QR S AFTERCRC=$$RAWCRC^ORCMEDT8(ORQDLG) + I BEFORCRC'=AFTERCRC D UPDQNAME^ORCMEDT8(ORQDLG) ; Rename personal quick order if modified + Q + ; +OK() ; -- Ready to save? + N X,Y,DIR S DIR(0)="SAM^P:PLACE;E:EDIT;C:CANCEL;",DIR("B")="PLACE" + S DIR("A")="(P)lace, (E)dit, or (C)ancel this quick order? " + S DIR("?")="Enter P to save this quick order, or E to change any of the displayed values; enter C to quit without saving these responses" + D ^DIR S:$D(DTOUT) Y="^" + Q Y + ; +SAVE G SAVE^ORCMEDT0 + ; +AUTO(DLG) ; -- set AutoAccept flag for GUI + N X,Y,DIR + S DIR(0)="YA",DIR("A")="Auto-accept this order? " + S DIR("B")=$S($P($G(^ORD(101.41,+DLG,5)),U,8):"YES",1:"NO") + S DIR("?")="Enter YES if this order can be placed simply by selecting it, or NO if the dialog should be presented to complete the order." + D ^DIR S:Y=1!(Y=0) $P(^ORD(101.41,+DLG,5),U,8)=$S(Y:1,1:"") + I $P($G(^ORD(101.41,+DLG,0)),"^",8)'=1&($P($G(^(0)),"^",9)=2)&(Y) D EXPLAIN S $P(^ORD(101.41,+DLG,5),"^",8)="" ;Reset auto-accept to no if explanation required. + Q + ; +SET ; -- Order Sets + N ORSET,ORDG + F S ORSET=$$DIALOG^ORCMEDT0("O") Q:ORSET="^" D SET0(ORSET) W ! + Q +SET0(ORSET) ; -- edit order set ORSET + N DA,DR,DIE,DIC,DIK,X,Y,SEQ,ITM,LCNT,QUIT,ORNAME Q:'$G(ORSET) + S ORNAME=$$NAME^ORCMEDT4(ORSET) Q:(ORNAME="@")!(ORNAME="^") ;deleted,^ + S DR=".01///^S X=ORNAME;2;20"_$S(DUZ(0)="@":";30;40",1:""),DA=ORSET + S DIE="^ORD(101.41," D ^DIE Q:$D(Y) Q:'$G(DA) +S1 I $O(^ORD(101.41,+ORSET,10,0)) D Q:QUIT ;Show existing components + . W !,"ORDER SET COMPONENTS:" S (SEQ,LCNT,QUIT)=0 + . S DIK="^ORD(101.41,"_+ORSET_",10,",DA(1)=+ORSET ;just in case + . F S SEQ=$O(^ORD(101.41,+ORSET,10,"B",SEQ)) Q:SEQ'>0 D + . . S DA=0 F S DA=$O(^ORD(101.41,+ORSET,10,"B",SEQ,DA)) Q:DA'>0 D + . . . S ITM=$P($G(^ORD(101.41,+ORSET,10,DA,0)),U,2) I ITM'>0 D ^DIK Q + . . . S LCNT=LCNT+1 I LCNT>(IOSL-3) R !,"Press to continue ...",X:DTIME S LCNT=0 I X["^" S QUIT=1 Q + . . . W !?3,SEQ,?10,$P(^ORD(101.41,ITM,0),U) +S2 S QUIT=0 F D Q:QUIT W ! ;Enter/edit components + . S DIC="^ORD(101.41,"_+ORSET_",10,",DIC(0)="AEQLM",D="B^D" + . S DIC("A")="Select COMPONENT SEQUENCE#: ",DIC("P")=$P(^DD(101.41,10,0),U,2) + . K DA S DA(1)=+ORSET D MIX^DIC1 I Y'>0 S QUIT=1 Q + . S DA=+Y,DIE=DIC,DR=".01;2R" D ^DIE Q:'$G(DA) + . I $D(^ORD(101.41,+ORSET,10,DA,0)),'$P(^(0),U,2) S DIK=DIE D ^DIK + Q + ; +PROTOCOL ; -- Convert additional protocols to dialogs + N X,Y,DIC,ORERR + F S DIC="^ORD(101,",DIC(0)="AEQM" D ^DIC Q:Y'>0 D W ! + . S ORP=+Y,ORM=$$MENU Q:ORM="^" ; What about "^^"-jumping? (ORWARD) + . W !,"Converting ..." D ONE(ORP,ORM,.ORERR) I '$G(ORERR) W " done." Q + . W " unable to convert.",!,">> "_$P(ORERR,U,2) K ORERR + Q +ONE(PITEM,ORADD,ERROR) ; -- Convert single item protocol, add to menu(s) + N PMENU,DMENU,NAME,ORPOS,POS,XUTL,DA,DIK + I $D(^ORD(100.99,1,101.41,PITEM,0)) S DA=PITEM,DA(1)=1,DIK="^ORD(100.99,1,101.41," D ^DIK ; delete error entry + S NAME=$P($G(^ORD(101,PITEM,0)),U),DITEM=$$ITEM^ORCONVRT(PITEM) + I 'DITEM!$D(^ORD(100.99,1,101.41,PITEM,0)) S ERROR=$G(^(0)) Q + Q:'$G(ORADD) ;to add, may enter here with PITEM & DITEM defined +ADD S PMENU=0 F S PMENU=$O(^ORD(101,"AD",PITEM,PMENU)) Q:PMENU'>0 D W "." + . S DMENU=$O(^ORD(101.41,"AB",$P(^ORD(101,PMENU,0),U),0)) Q:'DMENU + . S ORPOS=$$FINDXUTL(PMENU,PITEM) Q:'ORPOS + . S XUTL=$G(^XUTL("XQORM",PMENU_";ORD(101,",ORPOS,0)) + . S DA=$O(^ORD(101.41,DMENU,10,"B",ORPOS,0)) I DA Q:$P(^ORD(101.41,DMENU,10,DA,0),U,2)=DITEM S POS=$O(^ORD(101.41,DMENU,10,"B",""),-1),ORPOS=($P(POS,".")+1)_".1",DA="" ; move to end, if collision + . S DA=$$NEXT^ORCONVRT(DMENU) + . S ^ORD(101.41,DMENU,10,DA,0)=ORPOS_U_DITEM_U_$P(XUTL,U,4)_U_$S($P(XUTL,U,3)'=$P(^ORD(101.41,DITEM,0),U,2):$P(XUTL,U,3),1:"") + . S ^ORD(101.41,DMENU,10,"B",ORPOS,DA)="",^ORD(101.41,DMENU,10,"D",DITEM,DA)="" + . S ^ORD(101.41,"AD",DITEM,DMENU,DA)="",^ORD(101.41,DMENU,99)=$H + Q + ; +FINDXUTL(MENU,ITEM) ; -- Returns position of ITEM in MENU + N XQORM,POS + S XQORM=MENU_";ORD(101," D XREF^XQORM + S POS=0 F S POS=$O(^XUTL("XQORM",XQORM,POS)) Q:POS'>0 I $P(^(POS,0),U,2)=ITEM Q + Q POS + ; +MENU() ; -- Add converted item to menus? + N X,Y,DIR S DIR(0)="YA" + S DIR("A")="Add this item to the same menus again? ",DIR("B")="YES" + S DIR("?")="Enter YES to have this item placed on the same menus in the Order Dialog file as it was in the Protocol file" + D ^DIR S:$D(DTOUT) Y="^" + Q Y +EXPLAIN ;Give reason why user can't set auto-accept to yes + W !!,"The combination of VERIFY set to NO and ASK FOR ANOTHER ORDER set to",!,"YES, DON'T ASK and AUTO-ACCEPT set to YES is not allowed." + W !!,"This combination of settings could cause CPRS to enter into an infinite loop",!,"creating the same order over and over. If you wish to have" + W !,"AUTO-ACCEPT set to YES you must change one of the other two fields",!,"to a different value.",!!,"AUTO-ACCEPT is being set to NO for you." + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCMEDT8.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCMEDT8.m index 7e8fa8e2..c42aa6d6 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCMEDT8.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCMEDT8.m @@ -1,281 +1,277 @@ -ORCMEDT8 ;SLC/JM-QO, Generate quick order CRC ;10/18/07 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**245,243**;Dec 17, 1997;Build 242 - Q - ; -UPDQNAME(ORIEN) ; Rename personal quick order name if needed - N OLDNAME,NEWNAME,DA,DR,DIE,DIDEL - I $P($G(^ORD(101.41,ORIEN,0)),U,4)'="Q" Q - S OLDNAME=$P($G(^ORD(101.41,ORIEN,0)),U,1) - I $E($P(OLDNAME,U),1,6)'="ORWDQ " Q - S NEWNAME="ORWDQ "_$$CRC4QCK(ORIEN) - I OLDNAME'=NEWNAME D - . S NEWNAME=$$ENSURNEW(NEWNAME) - . S DA=ORIEN,DR=".01///"_NEWNAME,DIE="^ORD(101.41," D ^DIE - Q - ; -ENSURNEW(NAME) ; Ensures the name is a new entry - N IDX,BASENAME,ABC,NEWNAME - S NEWNAME=NAME - S IDX=0,BASENAME=NEWNAME,ABC=97 ; Find an unused name - F S IDX=$O(^ORD(101.41,"B",NEWNAME,0)) Q:'IDX D - . S NEWNAME=BASENAME_$C(ABC) ; append letter 'a' - 'z' - . S ABC=ABC+1 I ABC>122 S BASENAME=BASENAME_"a",ABC=97 - Q NEWNAME -RAWCRC(ORIEN) ; Get a raw CRC value to determine if a record has changed - N ORDATA,RESULT,ADDCRLF,LASTLINE,LASTIDX,OLDCRC - S (RESULT,OLDCRC)="" - I $P($G(^ORD(101.41,ORIEN,0)),U,4)'="Q" G RWQ - I $E($P($G(^ORD(101.41,ORIEN,0)),U),1,6)'="ORWDQ " G RWQ - D LOADRSP^ORWDX(.ORDATA,ORIEN) - D PARSE -RWQ Q RESULT - ; - ; The following code attemps to duplicate the CRC calculated by the Delphi code - ; in CPRS for quick orders. It will not match all the time, since not all the - ; data neded to make the determination is stored on the M side, but it does it's best. - ; -CRC4QCK(ORIEN) ; Get CRC for a personal quick order - N ORDATA,DISPGRP,DEFDLG,FORMID,RESULT,FORMDATA,ADDCRLF - N LASTLINE,LASTIDX,OLDCRC,FORMINFO,IDINFO,NEXTFORM - S RESULT="",FORMID=0 - ; Must be personal quick order - I $P($G(^ORD(101.41,ORIEN,0)),U,4)'="Q" G EXT - I $E($P($G(^ORD(101.41,ORIEN,0)),U),1,6)'="ORWDQ " G EXT - S OLDCRC=$E($P($G(^ORD(101.41,ORIEN,0)),U,1),7,14) - F Q:(RESULT=OLDCRC)!(FORMID="") D - . K ORDATA D LOADRSP^ORWDX(.ORDATA,ORIEN) - . ; First pass don't use any form id - get baseline CRC - . I FORMID=1 D Q:FORMID="" - . . S FORMID="" - . . S DISPGRP=$P($G(^ORD(101.41,ORIEN,0)),U,5) I '+DISPGRP Q ; Must have a valid display group - . . S DEFDLG=$P($G(^ORD(100.98,DISPGRP,0)),U,4) I '+DEFDLG Q ; Display group must have a valid default dialog - . . D FORMID^ORWDXM(.FORMID,DEFDLG) I '+FORMID S FORMID="" Q ; Default dialog must have a valid windows form ID - . . I (FORMID=130)!(FORMID=140) D - . . . N NEWFORM D CHK94^ORWDPS1(.NEWFORM) I NEWFORM=1 S FORMID=135 - . . D FORMINFO(.FORMINFO,.IDINFO,.NEXTFORM) - . I FORMID=0 S FORMID=1 - . E D SORTDATA I FORMDATA="" S FORMID="" Q ; Updates FORMID - . D PARSE -EXT Q RESULT - ; -PARSE ; Parse Data - N DATAIDX,IDX,LINE,CODE,CRCDATA,OUTPUT,DONE,ISMASTER,LASTMSTR,FIRST,P3,LK4SPACE - S DATAIDX="",(IDX,DONE,ISMASTER,LASTMSTR,LASTIDX)=0,LASTLINE="" - F D GETLINE Q:DONE D Q:DONE - . I ISMASTER D - . . S OUTPUT=+$P(LINE,U,1)_U_+$P(LINE,U,2)_U - . . S IDX=IDX+1,CRCDATA(IDX)=OUTPUT - . . S FIRST=1,P3=$P(LINE,U,3) - . . I P3="COMMENT" S ADDCRLF=1,LK4SPACE=1 - . . E D - . . . I P3="STATEMENTS" S ADDCRLF=1,LK4SPACE=0 - . . . E S ADDCRLF=0,LK4SPACE=0 - . . F D GETLINE Q:DONE!ISMASTER D - . . . I CODE="i" S IDX=IDX+1,CRCDATA(IDX)=LINE - . . . I CODE="t" D - . . . . I FIRST S FIRST=0,OUTPUT=LINE - . . . . E D - . . . . . I $L(LASTLINE)=0 S OUTPUT=$C(13)_$C(10)_LINE Q - . . . . . I LK4SPACE,$L(LASTLINE)>1,$E(LASTLINE,$L(LASTLINE))=" " S OUTPUT="" - . . . . . E D - . . . . . . I ADDCRLF S OUTPUT=$C(13)_$C(10) ; ,$L(LASTLINE)<65 - . . . . . . E S OUTPUT=" " - . . . . . S OUTPUT=OUTPUT_LINE - . . . . S LASTLINE=LINE - . . . . S IDX=IDX+1,CRCDATA(IDX)=OUTPUT - . . . . I ADDCRLF S LASTIDX=IDX - . . I ISMASTER,'DONE S LASTMSTR=1 - S RESULT=$$CRC4ARRY^ORCRC(.CRCDATA) - ; Same data can generate 2 different CRCs - CRLF on end of comments are stripped - I OLDCRC'="",RESULT'=OLDCRC,LASTIDX>0 D - . S CRCDATA(LASTIDX)=CRCDATA(LASTIDX)_$C(13)_$C(10) - . S RESULT=$$CRC4ARRY^ORCRC(.CRCDATA) - Q - ; -SORTDATA ; Sorts data by fields according to FormID - N IN,OUT,LINE,DATA,ID,CODE,INDEX,END,IDX,RTN,SUBFORM,SUBFORM2,SUBIDX,NODE - S SUBFORM="",SUBFORM2="" - S FORMDATA=$G(FORMINFO(FORMID)) I FORMDATA="" Q - I $E(FORMDATA,1,2)'="00" S RTN="SUBID"_$E(FORMDATA,1,2) D @RTN S FORMDATA=$G(FORMINFO(FORMID)) I FORMDATA="" Q - S IN=0,OUT=0,END=1000000,IDX=0 - F S IN=$O(ORDATA(IN)) Q:'+IN D - . S LINE=ORDATA(IN) - . I $E(LINE)="~" D - . . S IDX=1,ID=$P(LINE,U,3),CODE="."_IDINFO(ID)_".",NODE=$P(LINE,U,2) - . . S INDEX=$F(FORMDATA,CODE),SUBIDX=0 - . . I INDEX=0,SUBFORM'="" D - . . . S INDEX=($F(FORMDATA,".ZZZ.")) - . . . I INDEX>0 S SUBIDX=$F(SUBFORM,CODE) I SUBIDX<1 S INDEX=0 - . . I INDEX=0,SUBFORM2'="" D - . . . S INDEX=($F(FORMDATA,".XXX.")) - . . . I INDEX>0 S SUBIDX=$F(SUBFORM2,CODE) I SUBIDX<1 S INDEX=0 - . . I INDEX=0 S OUT=END,END=END+1 - . . E D - . . . I SUBIDX>0 D I 1 - . . . . S OUT=(INDEX-4)*250 - . . . . S SUBIDX=(SUBIDX-4)\4 - . . . . S OUT=OUT+SUBIDX+(NODE*20) - . . . E S OUT=(INDEX-4)*250 - . I IDX>0 D - . . S DATA(OUT,IDX)=LINE - . . S IDX=IDX+1 - K ORDATA - S (IN,OUT,INDEX)=0 - F S IN=$O(DATA(IN)) Q:'+IN D - . F S INDEX=$O(DATA(IN,INDEX)) Q:'+INDEX D - . . S OUT=OUT+1 - . . S ORDATA(OUT)=DATA(IN,INDEX) - S FORMID=$G(NEXTFORM(FORMID)) - Q - ; -GETLINE ; - I LASTMSTR S LASTMSTR=0 Q - S DATAIDX=$O(ORDATA(DATAIDX)) - S DONE=(DATAIDX="") - I 'DONE S CODE=$E(ORDATA(DATAIDX),1),LINE=$E(ORDATA(DATAIDX),2,9999),ISMASTER=(CODE="~") - Q - ; -FORMINFO(FORMINFO,IDINFO,NEXTFORM) ; populates FORMINFO,IDINFO and NEXTFORM arrays - N IDX,LINE,CODE,RTN,NEXT - S IDX=1 - F S LINE=$E($T(FORMTBL+IDX),21,999) Q:$L(LINE)<1 D - . S CODE=$E(LINE,1,3),NEXT=$E(LINE,5,7),LINE=$E(LINE,9,999) - . S FORMINFO(CODE)=LINE - . I NEXT'=" " S NEXTFORM(CODE)=NEXT - . S IDX=IDX+1 - S IDX=1 - F S LINE=$E($T(IDTABLE+IDX),4,999) Q:$L(LINE)<1 D - . S CODE=$E(LINE,1,3),LINE=$E(LINE,5,99) - . S IDINFO(LINE)=CODE,IDX=IDX+1 - Q - ; -HASCODE(CODE) ; scans data for code - N RESULT,IDX,LINE S IDX="",RESULT=0 - F S IDX=$O(ORDATA(IDX)) Q:IDX="" D Q:IDX="" - . S LINE=ORDATA(IDX) - . I $E(LINE)="~" D - . . S LINE=$P(LINE,U,3) - . . I LINE=CODE S RESULT=1,IDX="" - Q RESULT - ; -SUBID ; SubID codes are used to change the form ID depending on depending on data - ; Data below is FormID;SubID.list of ID codes in order of use - ; SubID's are used to change the FormID depending on data values. - Q -SUBID01 ; Generic Meds dialog - N INPT,COMPLEX - S INPT=$$HASCODE("NOW"),COMPLEX=$$HASCODE("DAYS") - I INPT D I 1 - . I COMPLEX S FORMID="INX",SUBFORM=$G(FORMINFO("MDX")) - . E S FORMID="INP" - E I COMPLEX S FORMID="OPX",SUBFORM=$G(FORMINFO("MDX")) - Q -SUBID02 ; IV Meds - S SUBFORM=$G(FORMINFO("IVL")) - Q -SUBID03 ; Delphi code adds URGENCY prompt that does not exist in dialog on M side - I '$$HASCODE("URGENCY") D - . N X - . S X=$O(ORDATA(999999),-1)+1 - . S ORDATA(X)="~0^1^URGENCY" - Q -SUBID04 ; Blood Bank will probably be wrong - quick orders not working in v26 - S SUBFORM=$G(FORMINFO("BBK")) - S SUBFORM2=$G(FORMINFO("BBX")) - Q -SUBID05 ; Diet - I FORMID="117" S SUBFORM=$G(FORMINFO("DLN")) - I FORMID="TBF" S SUBFORM=$G(FORMINFO("TBL")) - Q -FORMTBL ; Form Table - Forms allowing personal quick orders, as of CPRS GUI v26 (OR*3*215) - ;;Consult ;110;CS2;00.ORD.CLS.URG.PLA.MSC.COD.PRV.COM. - ;; ;CS2; ;00.ORD.CLS.URG.PLA.MSC.COD.COM.PRV. - ;;Procedure ;112;PR2;00.SER.ORD.CLS.URG.PLA.MSC.COD.PRV.COM. - ;; ;PR2;PR3;00.SER.ORD.COM.CLS.URG.PLA.MSC.COD.PRV. - ;; ;PR3; ;00.SER.ORD.CLS.URG.PLA.MSC.COD.COM.PRV. - ;;Diet ;117;TBF;05.STT.STP.ZZZ.COM.DEL.CAN. - ;; ;TBF;OPM;05.ZZZ.COM.CAN. - ;; ;OPM; ;00.ORD.MEL.STT.STP.SCH.COM.DEL. - ;; ;DLN; ;00.ORD. - ;; ;TBL; ;00.ORD.STR.INS. - ;;Lab ;120; ;00.ORD.SAM.SPE.URG.COM.COL.STT.SCH.DAY. - ;;Blood Bank ;125;BB2;04.ZZZ.DTE.COL.URG.COM.STT.MSC.REA.YN0.XXX.LAB. - ;; ;BB2; ;04.ZZZ.URG.COM.COL.DTE.MSC.REA.YN0.STT.XXX. - ;; ;BBK; ;00.ORD.QTY.MDF.SPC. - ;; ;BBX; ;00.RES. - ;;Inpatient Meds ;130; ;00.ORD.DRG.INS.ROU.SCH.URG.COM.SCT.ADM - ;;Generic Meds ;135; ;01.ORD.INS.DRG.DOS.STR.NAM.ROU.SCH.URG.COM.SUP.QTY.REF.SC0.PCK.PI0.SIG. - ;; ;INP; ;00.ORD.INS.DRG.DOS.STR.NAM.ROU.SCH.URG.COM.NOW.SIG. - ;; ;OPX; ;00.ORD.STR.NAM.DRG.ZZZ.URG.COM.SUP.QTY.REF.SC0.PCK.PI0.SIG. - ;; ;INX; ;00.ORD.STR.NAM.DRG.ZZZ.URG.COM.NOW.SIG. - ;; ;MDX; ;00.INS.DOS.ROU.SCH.DAY.CNJ. - ;;Outpatient Meds ;140; ;00.ORD.DRG.INS.MSC.ROU.SCH.QTY.REF.PCK.URG.COM.SC0. - ;;Non-VA Meds ;145; ;03.ORD.INS.DRG.DOS.STR.NAM.ROU.SCH.URG.COM.STT.STA.NOW.SIG. - ;;Radiology ;160; ;00.ORD.STT.URG.MOD.CLS.IML.PRG.YN0.PRE.COM.MDF.PRV.CON.RSH.LOC. - ;;IV Meds ;180; ;02.ZZZ.RAT.URG.DAY.COM.SCH.TYP.ADM - ;; ;IVL; ;00.ORD.VOL.ADD.STR.UNT. - ;; -IDTABLE ; ID table - returns codes used in the form table IDINFO("LONGNAME")=SHORNAME - ;;ADD;ADDITIVE - ;;ADM:ADMIN - ;;CAN;CANCEL - ;;CLS;CLASS - ;;COD;CODE - ;;COL;COLLECT - ;;COM;COMMENT - ;;CNJ;CONJ - ;;CON;CONTRACT - ;;DTE;DATETIME - ;;DAY;DAYS - ;;DEL;DELIVERY - ;;DOS;DOSE - ;;DRG;DRUG - ;;IML;IMLOC - ;;INS;INSTR - ;;ISO;ISOLATION - ;;LAB;LAB - ;;LOC;LOCATION - ;;MEL;MEAL - ;;MSC;MISC - ;;MOD;MODE - ;;MDF;MODIFIER - ;;NAM;NAME - ;;NOW;NOW - ;;ORD;ORDERABLE - ;;PI0;PI - ;;PCK;PICKUP - ;;PLA;PLACE - ;;PRG;PREGNANT - ;;PRE;PREOP - ;;PRV;PROVIDER - ;;QTY;QTY - ;;RAT;RATE - ;;REA;REASON - ;;REF;REFILLS - ;;RSH:RESEARCH - ;;RES;RESULTS - ;;ROU;ROUTE - ;;SAM;SAMPLE - ;;SC0;SC - ;;SCH;SCHEDULE - ;;SCT:SCHTYPE - ;;SER;SERVICE - ;;SIG;SIG - ;;SPE;SPECIMEN - ;;SPC;SPECSTS - ;;STT;START - ;;STA;STATEMENTS - ;;STP;STOP - ;;STR;STRENGTH - ;;SUP;SUPPLY - ;;TIM;TIME - ;;TYP:TYPE - ;;UNT;UNITS - ;;URG;URGENCY - ;;VIS;VISITSTR - ;;VOL;VOLUME - ;;XFU;XFUSION - ;;YN0;YN - ;;XXX;XXX - ;;ZZZ;ZZZ - ;; +ORCMEDT8 ;SLC/JM-QO, Generate quick order CRC ;3/3/06 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**245**;Dec 17, 1997;Build 2 + Q + ; +UPDQNAME(ORIEN) ; Rename personal quick order name if needed + N OLDNAME,NEWNAME,DA,DR,DIE,DIDEL + I $P($G(^ORD(101.41,ORIEN,0)),U,4)'="Q" Q + S OLDNAME=$P($G(^ORD(101.41,ORIEN,0)),U,1) + I $E($P(OLDNAME,U),1,6)'="ORWDQ " Q + S NEWNAME="ORWDQ "_$$CRC4QCK(ORIEN) + I OLDNAME'=NEWNAME D + . S NEWNAME=$$ENSURNEW(NEWNAME) + . S DA=ORIEN,DR=".01///"_NEWNAME,DIE="^ORD(101.41," D ^DIE + Q + ; +ENSURNEW(NAME) ; Ensures the name is a new entry + N IDX,BASENAME,ABC,NEWNAME + S NEWNAME=NAME + S IDX=0,BASENAME=NEWNAME,ABC=97 ; Find an unused name + F S IDX=$O(^ORD(101.41,"B",NEWNAME,0)) Q:'IDX D + . S NEWNAME=BASENAME_$C(ABC) ; append letter 'a' - 'z' + . S ABC=ABC+1 I ABC>122 S BASENAME=BASENAME_"a",ABC=97 + Q NEWNAME +RAWCRC(ORIEN) ; Get a raw CRC value to determine if a record has changed + N ORDATA,RESULT,ADDCRLF,LASTLINE,LASTIDX,OLDCRC + S (RESULT,OLDCRC)="" + I $P($G(^ORD(101.41,ORIEN,0)),U,4)'="Q" G RWQ + I $E($P($G(^ORD(101.41,ORIEN,0)),U),1,6)'="ORWDQ " G RWQ + D LOADRSP^ORWDX(.ORDATA,ORIEN) + D PARSE +RWQ Q RESULT + ; + ; The following code attemps to duplicate the CRC calculated by the Delphi code + ; in CPRS for quick orders. It will not match all the time, since not all the + ; data neded to make the determination is stored on the M side, but it does it's best. + ; +CRC4QCK(ORIEN) ; Get CRC for a personal quick order + N ORDATA,DISPGRP,DEFDLG,FORMID,RESULT,FORMDATA,ADDCRLF + N LASTLINE,LASTIDX,OLDCRC,FORMINFO,IDINFO,NEXTFORM + S RESULT="",FORMID=0 + ; Must be personal quick order + I $P($G(^ORD(101.41,ORIEN,0)),U,4)'="Q" G EXT + I $E($P($G(^ORD(101.41,ORIEN,0)),U),1,6)'="ORWDQ " G EXT + S OLDCRC=$E($P($G(^ORD(101.41,ORIEN,0)),U,1),7,14) + F Q:(RESULT=OLDCRC)!(FORMID="") D + . K ORDATA D LOADRSP^ORWDX(.ORDATA,ORIEN) + . ; First pass don't use any form id - get baseline CRC + . I FORMID=1 D Q:FORMID="" + . . S FORMID="" + . . S DISPGRP=$P($G(^ORD(101.41,ORIEN,0)),U,5) I '+DISPGRP Q ; Must have a valid display group + . . S DEFDLG=$P($G(^ORD(100.98,DISPGRP,0)),U,4) I '+DEFDLG Q ; Display group must have a valid default dialog + . . D FORMID^ORWDXM(.FORMID,DEFDLG) I '+FORMID S FORMID="" Q ; Default dialog must have a valid windows form ID + . . I (FORMID=130)!(FORMID=140) D + . . . N NEWFORM D CHK94^ORWDPS1(.NEWFORM) I NEWFORM=1 S FORMID=135 + . . D FORMINFO(.FORMINFO,.IDINFO,.NEXTFORM) + . I FORMID=0 S FORMID=1 + . E D SORTDATA I FORMDATA="" S FORMID="" Q ; Updates FORMID + . D PARSE +EXT Q RESULT + ; +PARSE ; Parse Data + N DATAIDX,IDX,LINE,CODE,CRCDATA,OUTPUT,DONE,ISMASTER,LASTMSTR,FIRST,P3,LK4SPACE + S DATAIDX="",(IDX,DONE,ISMASTER,LASTMSTR,LASTIDX)=0,LASTLINE="" + F D GETLINE Q:DONE D Q:DONE + . I ISMASTER D + . . S OUTPUT=+$P(LINE,U,1)_U_+$P(LINE,U,2)_U + . . S IDX=IDX+1,CRCDATA(IDX)=OUTPUT + . . S FIRST=1,P3=$P(LINE,U,3) + . . I P3="COMMENT" S ADDCRLF=1,LK4SPACE=1 + . . E D + . . . I P3="STATEMENTS" S ADDCRLF=1,LK4SPACE=0 + . . . E S ADDCRLF=0,LK4SPACE=0 + . . F D GETLINE Q:DONE!ISMASTER D + . . . I CODE="i" S IDX=IDX+1,CRCDATA(IDX)=LINE + . . . I CODE="t" D + . . . . I FIRST S FIRST=0,OUTPUT=LINE + . . . . E D + . . . . . I $L(LASTLINE)=0 S OUTPUT=$C(13)_$C(10)_LINE Q + . . . . . I LK4SPACE,$L(LASTLINE)>1,$E(LASTLINE,$L(LASTLINE))=" " S OUTPUT="" + . . . . . E D + . . . . . . I ADDCRLF S OUTPUT=$C(13)_$C(10) ; ,$L(LASTLINE)<65 + . . . . . . E S OUTPUT=" " + . . . . . S OUTPUT=OUTPUT_LINE + . . . . S LASTLINE=LINE + . . . . S IDX=IDX+1,CRCDATA(IDX)=OUTPUT + . . . . I ADDCRLF S LASTIDX=IDX + . . I ISMASTER,'DONE S LASTMSTR=1 + S RESULT=$$CRC4ARRY^ORCRC(.CRCDATA) + ; Same data can generate 2 different CRCs - CRLF on end of comments are stripped + I OLDCRC'="",RESULT'=OLDCRC,LASTIDX>0 D + . S CRCDATA(LASTIDX)=CRCDATA(LASTIDX)_$C(13)_$C(10) + . S RESULT=$$CRC4ARRY^ORCRC(.CRCDATA) + Q + ; +SORTDATA ; Sorts data by fields according to FormID + N IN,OUT,LINE,DATA,ID,CODE,INDEX,END,IDX,RTN,SUBFORM,SUBFORM2,SUBIDX,NODE + S SUBFORM="",SUBFORM2="" + S FORMDATA=$G(FORMINFO(FORMID)) I FORMDATA="" Q + I $E(FORMDATA,1,2)'="00" S RTN="SUBID"_$E(FORMDATA,1,2) D @RTN S FORMDATA=$G(FORMINFO(FORMID)) I FORMDATA="" Q + S IN=0,OUT=0,END=1000000,IDX=0 + F S IN=$O(ORDATA(IN)) Q:'+IN D + . S LINE=ORDATA(IN) + . I $E(LINE)="~" D + . . S IDX=1,ID=$P(LINE,U,3),CODE="."_IDINFO(ID)_".",NODE=$P(LINE,U,2) + . . S INDEX=$F(FORMDATA,CODE),SUBIDX=0 + . . I INDEX=0,SUBFORM'="" D + . . . S INDEX=($F(FORMDATA,".ZZZ.")) + . . . I INDEX>0 S SUBIDX=$F(SUBFORM,CODE) I SUBIDX<1 S INDEX=0 + . . I INDEX=0,SUBFORM2'="" D + . . . S INDEX=($F(FORMDATA,".XXX.")) + . . . I INDEX>0 S SUBIDX=$F(SUBFORM2,CODE) I SUBIDX<1 S INDEX=0 + . . I INDEX=0 S OUT=END,END=END+1 + . . E D + . . . I SUBIDX>0 D I 1 + . . . . S OUT=(INDEX-4)*250 + . . . . S SUBIDX=(SUBIDX-4)\4 + . . . . S OUT=OUT+SUBIDX+(NODE*20) + . . . E S OUT=(INDEX-4)*250 + . I IDX>0 D + . . S DATA(OUT,IDX)=LINE + . . S IDX=IDX+1 + K ORDATA + S (IN,OUT,INDEX)=0 + F S IN=$O(DATA(IN)) Q:'+IN D + . F S INDEX=$O(DATA(IN,INDEX)) Q:'+INDEX D + . . S OUT=OUT+1 + . . S ORDATA(OUT)=DATA(IN,INDEX) + S FORMID=$G(NEXTFORM(FORMID)) + Q + ; +GETLINE ; + I LASTMSTR S LASTMSTR=0 Q + S DATAIDX=$O(ORDATA(DATAIDX)) + S DONE=(DATAIDX="") + I 'DONE S CODE=$E(ORDATA(DATAIDX),1),LINE=$E(ORDATA(DATAIDX),2,9999),ISMASTER=(CODE="~") + Q + ; +FORMINFO(FORMINFO,IDINFO,NEXTFORM) ; populates FORMINFO,IDINFO and NEXTFORM arrays + N IDX,LINE,CODE,RTN,NEXT + S IDX=1 + F S LINE=$E($T(FORMTBL+IDX),21,999) Q:$L(LINE)<1 D + . S CODE=$E(LINE,1,3),NEXT=$E(LINE,5,7),LINE=$E(LINE,9,999) + . S FORMINFO(CODE)=LINE + . I NEXT'=" " S NEXTFORM(CODE)=NEXT + . S IDX=IDX+1 + S IDX=1 + F S LINE=$E($T(IDTABLE+IDX),4,999) Q:$L(LINE)<1 D + . S CODE=$E(LINE,1,3),LINE=$E(LINE,5,99) + . S IDINFO(LINE)=CODE,IDX=IDX+1 + Q + ; +HASCODE(CODE) ; scans data for code + N RESULT,IDX,LINE S IDX="",RESULT=0 + F S IDX=$O(ORDATA(IDX)) Q:IDX="" D Q:IDX="" + . S LINE=ORDATA(IDX) + . I $E(LINE)="~" D + . . S LINE=$P(LINE,U,3) + . . I LINE=CODE S RESULT=1,IDX="" + Q RESULT + ; +SUBID ; SubID codes are used to change the form ID depending on depending on data + ; Data below is FormID;SubID.list of ID codes in order of use + ; SubID's are used to change the FormID depending on data values. + Q +SUBID01 ; Generic Meds dialog + N INPT,COMPLEX + S INPT=$$HASCODE("NOW"),COMPLEX=$$HASCODE("DAYS") + I INPT D I 1 + . I COMPLEX S FORMID="INX",SUBFORM=$G(FORMINFO("MDX")) + . E S FORMID="INP" + E I COMPLEX S FORMID="OPX",SUBFORM=$G(FORMINFO("MDX")) + Q +SUBID02 ; IV Meds + S SUBFORM=$G(FORMINFO("IVL")) + Q +SUBID03 ; Delphi code adds URGENCY prompt that does not exist in dialog on M side + I '$$HASCODE("URGENCY") D + . N X + . S X=$O(ORDATA(999999),-1)+1 + . S ORDATA(X)="~0^1^URGENCY" + Q +SUBID04 ; Blood Bank will probably be wrong - quick orders not working in v26 + S SUBFORM=$G(FORMINFO("BBK")) + S SUBFORM2=$G(FORMINFO("BBX")) + Q +SUBID05 ; Diet + I FORMID="117" S SUBFORM=$G(FORMINFO("DLN")) + I FORMID="TBF" S SUBFORM=$G(FORMINFO("TBL")) + Q +FORMTBL ; Form Table - Forms allowing personal quick orders, as of CPRS GUI v26 (OR*3*215) + ;;Consult ;110;CS2;00.ORD.CLS.URG.PLA.MSC.COD.PRV.COM. + ;; ;CS2; ;00.ORD.CLS.URG.PLA.MSC.COD.COM.PRV. + ;;Procedure ;112;PR2;00.SER.ORD.CLS.URG.PLA.MSC.COD.PRV.COM. + ;; ;PR2;PR3;00.SER.ORD.COM.CLS.URG.PLA.MSC.COD.PRV. + ;; ;PR3; ;00.SER.ORD.CLS.URG.PLA.MSC.COD.COM.PRV. + ;;Diet ;117;TBF;05.STT.STP.ZZZ.COM.DEL.CAN. + ;; ;TBF;OPM;05.ZZZ.COM.CAN. + ;; ;OPM; ;00.ORD.MEL.STT.STP.SCH.COM.DEL. + ;; ;DLN; ;00.ORD. + ;; ;TBL; ;00.ORD.STR.INS. + ;;Lab ;120; ;00.ORD.SAM.SPE.URG.COM.COL.STT.SCH.DAY. + ;;Blood Bank ;125;BB2;04.ZZZ.DTE.COL.URG.COM.STT.MSC.REA.YN0.XXX. + ;; ;BB2; ;04.ZZZ.URG.COM.COL.DTE.MSC.REA.YN0.STT.XXX. + ;; ;BBK; ;00.ORD.QTY.MDF.SPC. + ;; ;BBX; ;00.RES. + ;;Inpatient Meds ;130; ;00.ORD.DRG.INS.ROU.SCH.URG.COM. + ;;Generic Meds ;135; ;01.ORD.INS.DRG.DOS.STR.NAM.ROU.SCH.URG.COM.SUP.QTY.REF.SC0.PCK.PI0.SIG. + ;; ;INP; ;00.ORD.INS.DRG.DOS.STR.NAM.ROU.SCH.URG.COM.NOW.SIG. + ;; ;OPX; ;00.ORD.STR.NAM.DRG.ZZZ.URG.COM.SUP.QTY.REF.SC0.PCK.PI0.SIG. + ;; ;INX; ;00.ORD.STR.NAM.DRG.ZZZ.URG.COM.NOW.SIG. + ;; ;MDX; ;00.INS.DOS.ROU.SCH.DAY.CNJ. + ;;Outpatient Meds ;140; ;00.ORD.DRG.INS.MSC.ROU.SCH.QTY.REF.PCK.URG.COM.SC0. + ;;Non-VA Meds ;145; ;03.ORD.INS.DRG.DOS.STR.NAM.ROU.SCH.URG.COM.STT.STA.NOW.SIG. + ;;Radiology ;160; ;00.ORD.STT.URG.MOD.CLS.IML.PRG.YN0.PRE.COM.MDF.PRV.CON.RSH.LOC. + ;;IV Meds ;180; ;02.ZZZ.RAT.URG.DAY.COM.SCH. + ;; ;IVL; ;00.ORD.VOL.ADD.STR.UNT. + ;; +IDTABLE ; ID table - returns codes used in the form table IDINFO("LONGNAME")=SHORNAME + ;;ADD;ADDITIVE + ;;CAN;CANCEL + ;;CLS;CLASS + ;;COD;CODE + ;;COL;COLLECT + ;;COM;COMMENT + ;;CNJ;CONJ + ;;CON;CONTRACT + ;;DTE;DATETIME + ;;DAY;DAYS + ;;DEL;DELIVERY + ;;DOS;DOSE + ;;DRG;DRUG + ;;IML;IMLOC + ;;INS;INSTR + ;;ISO;ISOLATION + ;;LOC;LOCATION + ;;MEL;MEAL + ;;MSC;MISC + ;;MOD;MODE + ;;MDF;MODIFIER + ;;NAM;NAME + ;;NOW;NOW + ;;ORD;ORDERABLE + ;;PI0;PI + ;;PCK;PICKUP + ;;PLA;PLACE + ;;PRG;PREGNANT + ;;PRE;PREOP + ;;PRV;PROVIDER + ;;QTY;QTY + ;;RAT;RATE + ;;REA;REASON + ;;REF;REFILLS + ;;RSH:RESEARCH + ;;RES;RESULTS + ;;ROU;ROUTE + ;;SAM;SAMPLE + ;;SC0;SC + ;;SCH;SCHEDULE + ;;SER;SERVICE + ;;SIG;SIG + ;;SPE;SPECIMEN + ;;SPC;SPECSTS + ;;STT;START + ;;STA;STATEMENTS + ;;STP;STOP + ;;STR;STRENGTH + ;;SUP;SUPPLY + ;;TIM;TIME + ;;UNT;UNITS + ;;URG;URGENCY + ;;VIS;VISITSTR + ;;VOL;VOLUME + ;;XFU;XFUSION + ;;YN0;YN + ;;XXX;XXX + ;;ZZZ;ZZZ + ;; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCSAVE.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCSAVE.m index c57716bf..6bc8dace 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCSAVE.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCSAVE.m @@ -1,184 +1,182 @@ -ORCSAVE ;SLC/MKB/JDL-Save ; 7/24/07 9:54am - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,56,70,73,92,94,116,141,163,187,190,195,243**;Dec 17, 1997;Build 242 - ;Per VHA Directive 2004-038, this routine should not be modified. -NEW(ORDIALOG,ORDG,ORPKG,ORCAT,OREVENT,ORDUZ,ORLOG) ; -- New order - ; Returns ORIFN = [new] order number, if created/saved - D EN - Q - ; -XX ; -- save new/unreleased edited order into Orders file - ; Requires: ORDIALOG() = array of dialog values - ; ORIFN = IFN of original order that was edited - ; - N OLDIFN S ORIFN=+ORIFN,OLDIFN=0 - I $S($P(^OR(100,ORIFN,3),U,3)=11:0,$P(^(3),U,3)'=10:1,$P(^(8,1,0),U,4)=2:0,1:1) S OLDIFN=ORIFN K ORIFN ; create new order if released or delayed&signed - D EN Q:'ORIFN S:'$G(ORDA) ORDA=1 - I $G(OLDIFN) D ;save links between orders - . S $P(^OR(100,ORIFN,3),U,5)=OLDIFN,$P(^(3),U,11)=1 - . S $P(^OR(100,OLDIFN,3),U,6)=ORIFN S:$D(^(5)) ^OR(100,ORIFN,5)=^OR(100,OLDIFN,5) - I $D(^OR(100,+OLDIFN,0)) D - . Q:'$G(OREVTDF) - . N OLDEVT,OLDSTS,LSTACT,PATID,NOW,WHEN - . S (OLDEVT,OLDSTS,LSTACT)=0 - . S NOW=$$NOW^XLFDT - . S OLDEVT=$P(^(0),U,17),OLDSTS=$P(^(3),U,3) - . ; Active status = 6 from #100.01 - . I (OLDEVT>0),OLDSTS=6 D - . . S $P(^OR(100,+ORIFN,0),U,17)=OLDEVT - . . S $P(^OR(100,+ORIFN,3),U,3)=11 - . . S LSTACT=$P($G(^OR(100,+ORIFN,3)),U,7) - . . I $D(^OR(100,+ORIFN,8,LSTACT,0)) D - . . . S $P(^OR(100,+ORIFN,8,LSTACT,0),U,15)=11 - . . . S PATID=$P(^OR(100,+ORIFN,0),U,2) - . . . S WHEN=$P(^OR(100,+ORIFN,8,LSTACT,0),U) - . . . S ^OR(100,"AC",PATID,9999999-WHEN,+ORIFN,LSTACT)="" - Q - ; -RN ; -- save new/unreleased renewal order into Orders file - ; Requires: ORDIALOG() = array of new dialog values - ; ORIFN = IFN of original order that was renewed - ; - N OLDIFN S OLDIFN=+ORIFN K ORIFN - D EN Q:'ORIFN S:'$G(ORDA) ORDA=1 - S $P(^OR(100,ORIFN,3),U,5)=OLDIFN,$P(^(3),U,11)=2 - S $P(^OR(100,OLDIFN,3),U,6)=ORIFN S:$D(^(5)) ^OR(100,ORIFN,5)=^OR(100,OLDIFN,5) - Q - ; -EN ; -- save new/unreleased order in ORDIALOG() into Orders file - ; Requires: ORVP, ORNP [and ORL, ORTS, ORAPPT if available] - ; If defined: ORCAT,ORPKG,ORDG,ORLOG,ORDUZ,OREVENT,ORDCNTRL,ORSRC - ; (else use values from ORDIALOG and current state) - ; - N PKG,NOW,NODE,CNT,CDL,I,X,STS,SIGNREQD,LOC,TRSPEC,NATR,CATG,DG,LOG,USR,TYPE - Q:'$G(ORVP) Q:'$G(ORDIALOG) Q:'$D(^ORD(101.41,+ORDIALOG,0)) - S NOW=$$NOW^XLFDT,SIGNREQD=+$P(^ORD(101.41,+ORDIALOG,0),U,6) - S CATG=$S($L($G(ORCAT)):ORCAT,1:$S($$INPT^ORCD:"I",1:"O")) - S PKG=$S($G(ORPKG):ORPKG,1:$P(^ORD(101.41,+ORDIALOG,0),U,7)) - I $G(ORIFN),$D(^OR(100,ORIFN,0)) S STS=$P(^(3),U,3) G EN2 ; unrel order - S DG=$S($G(ORDG):+ORDG,1:$P(^ORD(101.41,+ORDIALOG,0),U,5)) - I $G(OREVENT),$$GET1^DIQ(9.4,+PKG_",",1)'="PSO",'$G(DGPMT) S LOC="",TRSPEC="" ;195 - E S LOC=$G(ORL),TRSPEC=$G(ORTS) - S TYPE=$S("^B^C^X^P^0^"[(U_$G(ORSRC)_U):ORSRC,$G(ORDCNTRL)="SN":"P",1:0) - S LOG=$S($G(ORLOG):ORLOG,1:+$E(NOW,1,12)),USR=$S($G(ORDUZ):ORDUZ,1:DUZ) - S NATR=+$O(^ORD(100.02,"C","E",0)) ;assume Elec Entered until changed - S STS=$S($G(OREVENT):10,1:11),ORIFN=$$NEXTIFN Q:'ORIFN -EN1 S ^OR(100,ORIFN,0)=ORIFN_U_ORVP_U_U_$G(ORNP)_U_+ORDIALOG_";ORD(101.41,^"_USR_U_LOG_U_U_U_LOC_U_DG_U_CATG_U_TRSPEC_U_PKG_U_U_SIGNREQD_U_$G(OREVENT)_U_$G(ORAPPT) - S ^OR(100,ORIFN,3)=LOG_"^90^"_STS_U_$S($G(ORIT):ORIT_";ORD(101.41,",1:"")_U_$G(ORDIALOG("PREV"))_"^^1^^^^"_TYPE - S ^OR(100,ORIFN,8,0)="^100.008DA^1^1",^OR(100,ORIFN,8,1,0)=LOG_"^NW^"_$G(ORNP)_U_$S(SIGNREQD:2,1:3)_"^^^^^^^^"_NATR_U_USR_"^1^"_STS,^OR(100,ORIFN,8,"C","NW",1)="" - S ^OR(100,"AF",LOG,ORIFN,1)="" - S ^OR(100,"ACT",ORVP,9999999-LOG,+DG,ORIFN,1)="" - S:STS'=10 ^OR(100,"AC",ORVP,9999999-LOG,ORIFN,1)="" - S:SIGNREQD ^OR(100,"AS",ORVP,9999999-LOG,ORIFN,1)="" - S:$G(OREVENT) ^OR(100,"AEVNT",ORVP,OREVENT,ORIFN)="" -EN2 S ORIFN=+ORIFN D RESPONSE ; save responses - I $P(^OR(100,ORIFN,0),"^",5) D ;Copy orders PKI fix - . N OI - . S OI=+$O(^OR(100,ORIFN,4.5,"ID","ORDERABLE",0)),OI=+$G(^OR(100,ORIFN,4.5,OI,1)) Q:'OI - . I PKG'=$O(^DIC(9.4,"B","OUTPATIENT PHARMACY",0)) Q - . D PKI^ORWDPS1(.ORY,OI,CATG,+ORVP,$$GET^XPAR("ALL^USR.`"_DUZ,"ORWOR PKI USE",1,"Q")) - . I $E($G(ORY))=2 S ORDEA=ORY - K ^OR(100,ORIFN,8,1,.1) D ORDTEXT^ORCSAVE1(ORIFN_";1") ; order text - S NODE=$G(^OR(100,ORIFN,0)) D S ^OR(100,ORIFN,0)=NODE - . S $P(NODE,U,4)=$G(ORNP) ; COST? - . S I=$O(^OR(100,ORIFN,4.5,"ID","LOCATION",0)) - . I I,$P(NODE,U,10) S X=+$G(^OR(100,ORIFN,4.5,+I,1)) S:X $P(NODE,U,10)=X_";SC(" ;reset Loc if prev value - . S I=$O(^OR(100,ORIFN,4.5,"ID","CLASS",0)) - . I I S X=$G(^OR(100,ORIFN,4.5,+I,1)) S:"^I^O^"[(U_X_U) $P(NODE,U,12)=X - S $P(^OR(100,ORIFN,3),U)=NOW - K ^OR(100,ORIFN,9) I $G(ORCHECK) D ; save order checks - . S (CNT,CDL)=0 F S CDL=$O(ORCHECK("NEW",CDL)) Q:CDL'>0 S I=0 D - . . F S I=$O(ORCHECK("NEW",CDL,I)) Q:I'>0 S X=ORCHECK("NEW",CDL,I) D - . . . S CNT=CNT+1,^OR(100,ORIFN,9,"B",+X,CNT)="" - . . . S ^OR(100,ORIFN,9,CNT,0)=$P(X,U,1,2),^(1)=$E($P(X,U,3),1,245) - . S:CNT ^OR(100,ORIFN,9,0)="^100.09PA^"_CNT_U_CNT - K ORDEA -ENQ Q - ; -NEXTIFN() ; -- Returns next available ORIFN - N I,HDR,LAST,TOTAL,DA - F I=1:1:10 L +^OR(100,0):1 Q:$T H 2 - I '$T Q "^" - S HDR=$G(^OR(100,0)),TOTAL=+$P(HDR,U,4),LAST=$O(^OR(100,"?"),-1) - S I=LAST\1 F I=(I+1):1 Q:'$D(^OR(100,I,0)) - S DA=I,^OR(100,DA,0)=DA,$P(HDR,U,3,4)=DA_U_(TOTAL+1) - S ^OR(100,0)=HDR L -^OR(100,0) - Q DA - ; -RESPONSE ; -- Save responses in ORDIALOG() into ^OR(100,ORIFN,4.5) - N PROMPT,CNT,ITM,TYPE,INST,VALUE,I,START,PAT,X - S PAT=$P(^OR(100,ORIFN,0),U,2),START=$P(^(0),U,8) K ^(4.5) - S (PROMPT,CNT)=0 F S PROMPT=$O(ORDIALOG(PROMPT)) Q:PROMPT'>0 D - . S ITM=$G(ORDIALOG(PROMPT)) Q:'ITM - . S TYPE=$E($G(ORDIALOG(PROMPT,0))) Q:'$L(TYPE) - . S INST=0 F S INST=$O(ORDIALOG(PROMPT,INST)) Q:INST'>0 D - . . S VALUE=$G(ORDIALOG(PROMPT,INST)) Q:VALUE="" S CNT=CNT+1 - . . S ^OR(100,ORIFN,4.5,CNT,0)=+ITM_U_PROMPT_U_INST_U_$P(ITM,U,2) - . . S:$L($P(ITM,U,2)) ^OR(100,ORIFN,4.5,"ID",$P(ITM,U,2),CNT)="" - . . I VALUE<1,TYPE="N" S VALUE=0_+VALUE I VALUE="00" S VALUE=0 - . . S:TYPE'="W" ^OR(100,ORIFN,4.5,CNT,1)=VALUE - . . M:TYPE="W" ^OR(100,ORIFN,4.5,CNT,2)=@VALUE ; array root - S ^OR(100,ORIFN,4.5,0)="^100.045A^"_CNT_U_CNT -R1 ; [Reset] Orderables - I $D(^OR(100,ORIFN,.1)) S I=0 F S I=$O(^OR(100,ORIFN,.1,I)) Q:I'>0 S X=$G(^(I,0)) I X,PAT,START K ^OR(100,"AOI",X,PAT,9999999-START,ORIFN) ; kill xref - K ^OR(100,ORIFN,.1) I $D(^OR(100,ORIFN,4.5,"ID","ORDERABLE")) D - . S (I,CNT)=0 - . F S I=$O(^OR(100,ORIFN,4.5,"ID","ORDERABLE",I)) Q:I'>0 D - . . S X=$G(^OR(100,ORIFN,4.5,I,1)) Q:'X - . . S CNT=CNT+1,^OR(100,ORIFN,.1,CNT,0)=X,^OR(100,ORIFN,.1,"B",X,CNT)="" - . . I PAT,START S ^OR(100,"AOI",X,PAT,9999999-START,ORIFN)="" - . S ^OR(100,ORIFN,.1,0)="^100.001PA^"_CNT_U_CNT - Q - ; -RESUME(IFN) ; -- add Response nodes for RESUME tray service - ; S ^OR(100,+IFN,4.5,,0)=DT_"^^^RESUME",^(1)=1 - ; - N X,Y,DA,DIC - S DIC="^OR(100,"_+IFN_",4.5,",DIC(0)="LX",DA(1)=+IFN,X=DT - S DIC("DR")=".04///RESUME",DIC("P")=$P(^DD(100,4.5,0),U,2) - D ^DIC S:Y ^OR(100,+IFN,4.5,+Y,1)=1 - Q - ; -PROVIDER(ORDER,PROV) ; -- Change PROVider assigned to ORDER - Q:'$G(ORDER) Q:'$G(PROV) - N ORACT S ORACT=+$P(ORDER,";",2) S:'ORACT ORACT=1 - S $P(^OR(100,+ORDER,8,ORACT,0),U,3)=PROV - S:ORACT=1 $P(^OR(100,+ORDER,0),U,4)=PROV - Q - ; -ACTION(CODE,DA,PROV,REASON,WHEN,WHO) ; -- save new action - N NEXT,TOTAL,HDR,LAST,X,PAT,DGRP,SIG,NATR,TXT S DA=+DA - Q:'$D(^OR(100,DA,0)) 0 Q:$G(CODE)'?2U 0 - S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12) S:'$G(WHO) WHO=DUZ - S NATR=+$O(^ORD(100.02,"C","E",0)) ;assume Elec Entered until changed - S PAT=$P(^OR(100,DA,0),U,2),DGRP=$P(^(0),U,11),SIG=$P(^(0),U,16),X=+$P($G(^(3)),U,7),HDR=$G(^(8,0)) - S:X'>0 X=1 S TXT=$P($G(^OR(100,DA,8,X,0)),U,14) ;current actn's txt ptr - S:HDR="" HDR="^100.008DA^^" S TOTAL=+$P(HDR,U,4) - S LAST=$O(^OR(100,DA,8,"C",CODE,"?"),-1) I LAST D - . S X=$G(^OR(100,DA,8,LAST,0)) Q:$P(X,U,15)'=11 Q:$P(X,U,4)'=2 - . S NEXT=LAST I PAT,$P(X,U) D ; kill old xref entries - . . K:DGRP ^OR(100,"ACT",PAT,(9999999-$P(X,U)),DGRP,DA,NEXT) - . . K ^OR(100,"AC",PAT,(9999999-$P(X,U)),DA,NEXT),^OR(100,"AS",PAT,(9999999-$P(X,U)),DA,NEXT),^OR(100,"AF",$P(X,U),DA,NEXT) - S:'$G(NEXT) NEXT=$O(^OR(100,DA,8,"?"),-1)+1,TOTAL=TOTAL+1 - S ^OR(100,DA,8,NEXT,0)=WHEN_U_CODE_U_$G(PROV)_U_$S(SIG:2,1:3)_"^^^^^^^^"_NATR_U_WHO_U_TXT_"^11",^OR(100,DA,8,"C",CODE,NEXT)="" - S ^OR(100,"AF",WHEN,DA,NEXT)="" - I PAT,DGRP S ^OR(100,"ACT",PAT,9999999-WHEN,DGRP,DA,NEXT)="" - I PAT S ^OR(100,"AC",PAT,9999999-WHEN,DA,NEXT)="" - I SIG S ^OR(100,"AS",PAT,9999999-WHEN,DA,NEXT)="" - S:$L($G(REASON)) ^OR(100,DA,8,NEXT,1)=REASON - S $P(HDR,U,3,4)=NEXT_U_TOTAL,^OR(100,DA,8,0)=HDR - Q NEXT - ; -SET(DLG) ; -- Create new parent for order set ORDIALOG - ; Returns ORPIFN = ifn of new parent order for set - ; - Q:'$G(ORVP) Q:'$G(DLG) N OR0,PKG,NOW,CATG,STS,ORLOC,TRSPEC,X - S OR0=$G(^ORD(101.41,DLG,0)) Q:OR0="" S ORPIFN=$$NEXTIFN Q:'ORPIFN - S PKG=$O(^DIC(9.4,"C","OR",0)),CATG=$S($$INPT^ORCD:"I",1:"O"),STS=$S($G(OREVENT):10,1:11),NOW=$S($G(ORSLOG):ORSLOG,1:+$E($$NOW^XLFDT,1,12)) - I $G(OREVENT) S ORLOC="",TRSPEC="" - S ^OR(100,ORPIFN,0)=ORPIFN_U_ORVP_U_U_$G(ORNP)_U_DLG_";ORD(101.41,^"_DUZ_U_NOW_U_U_U_ORLOC_U_U_CATG_U_TRSPEC_U_PKG_"^^^"_$G(OREVENT),^(3)=NOW_"^90^"_STS_U_$S($G(ORIT):ORIT_"ORD(101.41,",1:"")_"^^^1^^^^0^^"_+$P(OR0,U,6) - S ^OR(100,ORPIFN,8,0)="^100.008DA^1^1",^(1,0)=NOW_"^NW^"_$G(ORNP)_"^^^^^^^^^^"_DUZ_"^^"_STS,^OR(100,ORPIFN,8,"C","NW",1)="",^OR(100,"AF",NOW,ORPIFN,1)="" - S ^OR(100,"ACT",ORVP,9999999-NOW,ORPIFN,1)="" - S:STS=11 ^OR(100,"AC",ORVP,9999999-NOW,ORPIFN,1)="" - ; AEVNT ?? - S ^OR(100,ORPIFN,1,0)="^100.011^1^1",^(1,0)=$P(OR0,U,2) ; Order text - Q +ORCSAVE ;SLC/MKB/JDL-Save ;9/13/04 14:05 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,56,70,73,92,94,116,141,163,187,190,195**;Dec 17, 1997 +NEW(ORDIALOG,ORDG,ORPKG,ORCAT,OREVENT,ORDUZ,ORLOG) ; -- New order + ; Returns ORIFN = [new] order number, if created/saved + D EN + Q + ; +XX ; -- save new/unreleased edited order into Orders file + ; Requires: ORDIALOG() = array of dialog values + ; ORIFN = IFN of original order that was edited + ; + N OLDIFN S ORIFN=+ORIFN,OLDIFN=0 + I $S($P(^OR(100,ORIFN,3),U,3)=11:0,$P(^(3),U,3)'=10:1,$P(^(8,1,0),U,4)=2:0,1:1) S OLDIFN=ORIFN K ORIFN ; create new order if released or delayed&signed + D EN Q:'ORIFN S:'$G(ORDA) ORDA=1 + I $G(OLDIFN) D ;save links between orders + . S $P(^OR(100,ORIFN,3),U,5)=OLDIFN,$P(^(3),U,11)=1 + . S $P(^OR(100,OLDIFN,3),U,6)=ORIFN S:$D(^(5)) ^OR(100,ORIFN,5)=^OR(100,OLDIFN,5) + I $D(^OR(100,+OLDIFN,0)) D + . Q:'$G(OREVTDF) + . N OLDEVT,OLDSTS,LSTACT,PATID,NOW,WHEN + . S (OLDEVT,OLDSTS,LSTACT)=0 + . S NOW=$$NOW^XLFDT + . S OLDEVT=$P(^(0),U,17),OLDSTS=$P(^(3),U,3) + . ; Active status = 6 from #100.01 + . I (OLDEVT>0),OLDSTS=6 D + . . S $P(^OR(100,+ORIFN,0),U,17)=OLDEVT + . . S $P(^OR(100,+ORIFN,3),U,3)=11 + . . S LSTACT=$P($G(^OR(100,+ORIFN,3)),U,7) + . . I $D(^OR(100,+ORIFN,8,LSTACT,0)) D + . . . S $P(^OR(100,+ORIFN,8,LSTACT,0),U,15)=11 + . . . S PATID=$P(^OR(100,+ORIFN,0),U,2) + . . . S WHEN=$P(^OR(100,+ORIFN,8,LSTACT,0),U) + . . . S ^OR(100,"AC",PATID,9999999-WHEN,+ORIFN,LSTACT)="" + Q + ; +RN ; -- save new/unreleased renewal order into Orders file + ; Requires: ORDIALOG() = array of new dialog values + ; ORIFN = IFN of original order that was renewed + ; + N OLDIFN S OLDIFN=+ORIFN K ORIFN + D EN Q:'ORIFN S:'$G(ORDA) ORDA=1 + S $P(^OR(100,ORIFN,3),U,5)=OLDIFN,$P(^(3),U,11)=2 + S $P(^OR(100,OLDIFN,3),U,6)=ORIFN S:$D(^(5)) ^OR(100,ORIFN,5)=^OR(100,OLDIFN,5) + Q + ; +EN ; -- save new/unreleased order in ORDIALOG() into Orders file + ; Requires: ORVP, ORNP [and ORL, ORTS, ORAPPT if available] + ; If defined: ORCAT,ORPKG,ORDG,ORLOG,ORDUZ,OREVENT,ORDCNTRL,ORSRC + ; (else use values from ORDIALOG and current state) + ; + N PKG,NOW,NODE,CNT,CDL,I,X,STS,SIGNREQD,LOC,TRSPEC,NATR,CATG,DG,LOG,USR,TYPE + Q:'$G(ORVP) Q:'$G(ORDIALOG) Q:'$D(^ORD(101.41,+ORDIALOG,0)) + S NOW=$$NOW^XLFDT,SIGNREQD=+$P(^ORD(101.41,+ORDIALOG,0),U,6) + S CATG=$S($L($G(ORCAT)):ORCAT,1:$S($$INPT^ORCD:"I",1:"O")) + S PKG=$S($G(ORPKG):ORPKG,1:$P(^ORD(101.41,+ORDIALOG,0),U,7)) + I $G(ORIFN),$D(^OR(100,ORIFN,0)) S STS=$P(^(3),U,3) G EN2 ; unrel order + S DG=$S($G(ORDG):+ORDG,1:$P(^ORD(101.41,+ORDIALOG,0),U,5)) + I $G(OREVENT),$$GET1^DIQ(9.4,+PKG_",",1)'="PSO",'$G(DGPMT) S LOC="",TRSPEC="" ;195 + E S LOC=$G(ORL),TRSPEC=$G(ORTS) + S TYPE=$S("^B^C^X^P^0^"[(U_$G(ORSRC)_U):ORSRC,$G(ORDCNTRL)="SN":"P",1:0) + S LOG=$S($G(ORLOG):ORLOG,1:+$E(NOW,1,12)),USR=$S($G(ORDUZ):ORDUZ,1:DUZ) + S NATR=+$O(^ORD(100.02,"C","E",0)) ;assume Elec Entered until changed + S STS=$S($G(OREVENT):10,1:11),ORIFN=$$NEXTIFN Q:'ORIFN +EN1 S ^OR(100,ORIFN,0)=ORIFN_U_ORVP_U_U_$G(ORNP)_U_+ORDIALOG_";ORD(101.41,^"_USR_U_LOG_U_U_U_LOC_U_DG_U_CATG_U_TRSPEC_U_PKG_U_U_SIGNREQD_U_$G(OREVENT)_U_$G(ORAPPT) + S ^OR(100,ORIFN,3)=LOG_"^90^"_STS_U_$S($G(ORIT):ORIT_";ORD(101.41,",1:"")_U_$G(ORDIALOG("PREV"))_"^^1^^^^"_TYPE + S ^OR(100,ORIFN,8,0)="^100.008DA^1^1",^OR(100,ORIFN,8,1,0)=LOG_"^NW^"_$G(ORNP)_U_$S(SIGNREQD:2,1:3)_"^^^^^^^^"_NATR_U_USR_"^1^"_STS,^OR(100,ORIFN,8,"C","NW",1)="" + S ^OR(100,"AF",LOG,ORIFN,1)="" + S ^OR(100,"ACT",ORVP,9999999-LOG,+DG,ORIFN,1)="" + S:STS'=10 ^OR(100,"AC",ORVP,9999999-LOG,ORIFN,1)="" + S:SIGNREQD ^OR(100,"AS",ORVP,9999999-LOG,ORIFN,1)="" + S:$G(OREVENT) ^OR(100,"AEVNT",ORVP,OREVENT,ORIFN)="" +EN2 S ORIFN=+ORIFN D RESPONSE ; save responses + I $P(^OR(100,ORIFN,0),"^",5) D ;Copy orders PKI fix + . N OI + . S OI=+$O(^OR(100,ORIFN,4.5,"ID","ORDERABLE",0)),OI=+$G(^OR(100,ORIFN,4.5,OI,1)) Q:'OI + . I PKG'=$O(^DIC(9.4,"B","OUTPATIENT PHARMACY",0)) Q + . D PKI^ORWDPS1(.ORY,OI,CATG,+ORVP,$$GET^XPAR("ALL^USR.`"_DUZ,"ORWOR PKI USE",1,"Q")) + . I $E($G(ORY))=2 S ORDEA=ORY + K ^OR(100,ORIFN,8,1,.1) D ORDTEXT^ORCSAVE1(ORIFN_";1") ; order text + S NODE=$G(^OR(100,ORIFN,0)) D S ^OR(100,ORIFN,0)=NODE + . S $P(NODE,U,4)=$G(ORNP) ; COST? + . S I=$O(^OR(100,ORIFN,4.5,"ID","LOCATION",0)) + . I I,$P(NODE,U,10) S X=+$G(^OR(100,ORIFN,4.5,+I,1)) S:X $P(NODE,U,10)=X_";SC(" ;reset Loc if prev value + . S I=$O(^OR(100,ORIFN,4.5,"ID","CLASS",0)) + . I I S X=$G(^OR(100,ORIFN,4.5,+I,1)) S:"^I^O^"[(U_X_U) $P(NODE,U,12)=X + S $P(^OR(100,ORIFN,3),U)=NOW + K ^OR(100,ORIFN,9) I $G(ORCHECK) D ; save order checks + . S (CNT,CDL)=0 F S CDL=$O(ORCHECK("NEW",CDL)) Q:CDL'>0 S I=0 D + . . F S I=$O(ORCHECK("NEW",CDL,I)) Q:I'>0 S X=ORCHECK("NEW",CDL,I) D + . . . S CNT=CNT+1,^OR(100,ORIFN,9,"B",+X,CNT)="" + . . . S ^OR(100,ORIFN,9,CNT,0)=$P(X,U,1,2),^(1)=$E($P(X,U,3),1,245) + . S:CNT ^OR(100,ORIFN,9,0)="^100.09PA^"_CNT_U_CNT + K ORDEA +ENQ Q + ; +NEXTIFN() ; -- Returns next available ORIFN + N I,HDR,LAST,TOTAL,DA + F I=1:1:10 L +^OR(100,0):1 Q:$T H 2 + I '$T Q "^" + S HDR=$G(^OR(100,0)),TOTAL=+$P(HDR,U,4),LAST=$O(^OR(100,"?"),-1) + S I=LAST\1 F I=(I+1):1 Q:'$D(^OR(100,I,0)) + S DA=I,^OR(100,DA,0)=DA,$P(HDR,U,3,4)=DA_U_(TOTAL+1) + S ^OR(100,0)=HDR L -^OR(100,0) + Q DA + ; +RESPONSE ; -- Save responses in ORDIALOG() into ^OR(100,ORIFN,4.5) + N PROMPT,CNT,ITM,TYPE,INST,VALUE,I,START,PAT,X + S PAT=$P(^OR(100,ORIFN,0),U,2),START=$P(^(0),U,8) K ^(4.5) + S (PROMPT,CNT)=0 F S PROMPT=$O(ORDIALOG(PROMPT)) Q:PROMPT'>0 D + . S ITM=$G(ORDIALOG(PROMPT)) Q:'ITM + . S TYPE=$E($G(ORDIALOG(PROMPT,0))) Q:'$L(TYPE) + . S INST=0 F S INST=$O(ORDIALOG(PROMPT,INST)) Q:INST'>0 D + . . S VALUE=$G(ORDIALOG(PROMPT,INST)) Q:VALUE="" S CNT=CNT+1 + . . S ^OR(100,ORIFN,4.5,CNT,0)=+ITM_U_PROMPT_U_INST_U_$P(ITM,U,2) + . . S:$L($P(ITM,U,2)) ^OR(100,ORIFN,4.5,"ID",$P(ITM,U,2),CNT)="" + . . S:TYPE'="W" ^OR(100,ORIFN,4.5,CNT,1)=VALUE + . . M:TYPE="W" ^OR(100,ORIFN,4.5,CNT,2)=@VALUE ; array root + S ^OR(100,ORIFN,4.5,0)="^100.045A^"_CNT_U_CNT +R1 ; [Reset] Orderables + I $D(^OR(100,ORIFN,.1)) S I=0 F S I=$O(^OR(100,ORIFN,.1,I)) Q:I'>0 S X=$G(^(I,0)) I X,PAT,START K ^OR(100,"AOI",X,PAT,9999999-START,ORIFN) ; kill xref + K ^OR(100,ORIFN,.1) I $D(^OR(100,ORIFN,4.5,"ID","ORDERABLE")) D + . S (I,CNT)=0 + . F S I=$O(^OR(100,ORIFN,4.5,"ID","ORDERABLE",I)) Q:I'>0 D + . . S X=$G(^OR(100,ORIFN,4.5,I,1)) Q:'X + . . S CNT=CNT+1,^OR(100,ORIFN,.1,CNT,0)=X,^OR(100,ORIFN,.1,"B",X,CNT)="" + . . I PAT,START S ^OR(100,"AOI",X,PAT,9999999-START,ORIFN)="" + . S ^OR(100,ORIFN,.1,0)="^100.001PA^"_CNT_U_CNT + Q + ; +RESUME(IFN) ; -- add Response nodes for RESUME tray service + ; S ^OR(100,+IFN,4.5,,0)=DT_"^^^RESUME",^(1)=1 + ; + N X,Y,DA,DIC + S DIC="^OR(100,"_+IFN_",4.5,",DIC(0)="LX",DA(1)=+IFN,X=DT + S DIC("DR")=".04///RESUME",DIC("P")=$P(^DD(100,4.5,0),U,2) + D ^DIC S:Y ^OR(100,+IFN,4.5,+Y,1)=1 + Q + ; +PROVIDER(ORDER,PROV) ; -- Change PROVider assigned to ORDER + Q:'$G(ORDER) Q:'$G(PROV) + N ORACT S ORACT=+$P(ORDER,";",2) S:'ORACT ORACT=1 + S $P(^OR(100,+ORDER,8,ORACT,0),U,3)=PROV + S:ORACT=1 $P(^OR(100,+ORDER,0),U,4)=PROV + Q + ; +ACTION(CODE,DA,PROV,REASON,WHEN,WHO) ; -- save new action + N NEXT,TOTAL,HDR,LAST,X,PAT,DGRP,SIG,NATR,TXT S DA=+DA + Q:'$D(^OR(100,DA,0)) 0 Q:$G(CODE)'?2U 0 + S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12) S:'$G(WHO) WHO=DUZ + S NATR=+$O(^ORD(100.02,"C","E",0)) ;assume Elec Entered until changed + S PAT=$P(^OR(100,DA,0),U,2),DGRP=$P(^(0),U,11),SIG=$P(^(0),U,16),X=+$P($G(^(3)),U,7),HDR=$G(^(8,0)) + S:X'>0 X=1 S TXT=$P($G(^OR(100,DA,8,X,0)),U,14) ;current actn's txt ptr + S:HDR="" HDR="^100.008DA^^" S TOTAL=+$P(HDR,U,4) + S LAST=$O(^OR(100,DA,8,"C",CODE,"?"),-1) I LAST D + . S X=$G(^OR(100,DA,8,LAST,0)) Q:$P(X,U,15)'=11 Q:$P(X,U,4)'=2 + . S NEXT=LAST I PAT,$P(X,U) D ; kill old xref entries + . . K:DGRP ^OR(100,"ACT",PAT,(9999999-$P(X,U)),DGRP,DA,NEXT) + . . K ^OR(100,"AC",PAT,(9999999-$P(X,U)),DA,NEXT),^OR(100,"AS",PAT,(9999999-$P(X,U)),DA,NEXT),^OR(100,"AF",$P(X,U),DA,NEXT) + S:'$G(NEXT) NEXT=$O(^OR(100,DA,8,"?"),-1)+1,TOTAL=TOTAL+1 + S ^OR(100,DA,8,NEXT,0)=WHEN_U_CODE_U_$G(PROV)_U_$S(SIG:2,1:3)_"^^^^^^^^"_NATR_U_WHO_U_TXT_"^11",^OR(100,DA,8,"C",CODE,NEXT)="" + S ^OR(100,"AF",WHEN,DA,NEXT)="" + I PAT,DGRP S ^OR(100,"ACT",PAT,9999999-WHEN,DGRP,DA,NEXT)="" + I PAT S ^OR(100,"AC",PAT,9999999-WHEN,DA,NEXT)="" + I SIG S ^OR(100,"AS",PAT,9999999-WHEN,DA,NEXT)="" + S:$L($G(REASON)) ^OR(100,DA,8,NEXT,1)=REASON + S $P(HDR,U,3,4)=NEXT_U_TOTAL,^OR(100,DA,8,0)=HDR + Q NEXT + ; +SET(DLG) ; -- Create new parent for order set ORDIALOG + ; Returns ORPIFN = ifn of new parent order for set + ; + Q:'$G(ORVP) Q:'$G(DLG) N OR0,PKG,NOW,CATG,STS,ORLOC,TRSPEC,X + S OR0=$G(^ORD(101.41,DLG,0)) Q:OR0="" S ORPIFN=$$NEXTIFN Q:'ORPIFN + S PKG=$O(^DIC(9.4,"C","OR",0)),CATG=$S($$INPT^ORCD:"I",1:"O"),STS=$S($G(OREVENT):10,1:11),NOW=$S($G(ORSLOG):ORSLOG,1:+$E($$NOW^XLFDT,1,12)) + I $G(OREVENT) S ORLOC="",TRSPEC="" + S ^OR(100,ORPIFN,0)=ORPIFN_U_ORVP_U_U_$G(ORNP)_U_DLG_";ORD(101.41,^"_DUZ_U_NOW_U_U_U_ORLOC_U_U_CATG_U_TRSPEC_U_PKG_"^^^"_$G(OREVENT),^(3)=NOW_"^90^"_STS_U_$S($G(ORIT):ORIT_"ORD(101.41,",1:"")_"^^^1^^^^0^^"_+$P(OR0,U,6) + S ^OR(100,ORPIFN,8,0)="^100.008DA^1^1",^(1,0)=NOW_"^NW^"_$G(ORNP)_"^^^^^^^^^^"_DUZ_"^^"_STS,^OR(100,ORPIFN,8,"C","NW",1)="",^OR(100,"AF",NOW,ORPIFN,1)="" + S ^OR(100,"ACT",ORVP,9999999-NOW,ORPIFN,1)="" + S:STS=11 ^OR(100,"AC",ORVP,9999999-NOW,ORPIFN,1)="" + ; AEVNT ?? + S ^OR(100,ORPIFN,1,0)="^100.011^1^1",^(1,0)=$P(OR0,U,2) ; Order text + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCSAVE1.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCSAVE1.m index 364a203e..103d6583 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCSAVE1.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCSAVE1.m @@ -1,118 +1,117 @@ -ORCSAVE1 ; SLC/MKB - Save Order Text ;02/22/07 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**92,132,141,163,187,223,243**;Dec 17, 1997;Build 242 - ; - ; ^ORD(101.41,+ORDIALOG,10,ITM,2)=Seq#^Format^Omit^Lead Text^Trail Text - ; ^ORD(101.41,+ORDIALOG,10,"ATXT",Seq#,ITM)="" - ; -ORDTEXT(ORDER) ; -- Build and save order text from ORDIALOG() into ORDER - N ORTX,I,IFN,ACT,ORSET - D ORTX(240) Q:'$G(ORTX) - S IFN=+ORDER,ACT=+$P(ORDER,";",2) S:ACT'>0 ACT=1 - F I=1:1:ORTX S ^OR(100,IFN,8,ACT,.1,I,0)=ORTX(I) - S ^OR(100,IFN,8,ACT,.1,0)=U_U_ORTX_U_ORTX_U_DT_U - I $E($G(ORDEA))=2 D ;PKI Drug Schedule - in future may allow 2-5 - . S ORSET=0 - . D DIGTEXT(IFN,ORDEA) - . F I=1:1:ORSET S ^OR(100,IFN,8,ACT,.2,I,0)=ORSET(I) - . I ORSET>0 S ^OR(100,IFN,8,ACT,.2,0)=U_U_ORSET_U_ORSET_U_DT_U - Q - ; -ORTX(WIDTH) ; -- May enter here to return order text in ORTX() - N ORP,SEQ,ITEM,ORMAX,IVIEN,IVITEM,IVTYPE,RATE - K ORTX S ORMAX=$S(+$G(WIDTH):WIDTH,1:240) - D EXT ; get external form of values - S SEQ=0 F S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"ATXT",SEQ)) Q:SEQ'>0 D - . S ITEM=0 F S ITEM=$O(^ORD(101.41,+ORDIALOG,10,"ATXT",SEQ,ITEM)) Q:ITEM'>0 D TEXT(ITEM) - Q - ; -TEXT(DA) ; -- Includes text of item DA - Q:$P(^ORD(101.41,ORDIALOG,10,DA,0),U,11) Q:'$O(ORP(DA,0)) - N NEWLN,INST,TYPE,PTR,CHSEQ,CHILD,ORI,X,Y - S:'$G(ORTX) ORTX=1,ORTX(1)="" - S NEWLN=+$P(ORP(DA),U,4),INST=$O(ORP(DA,0)),Y="" - I NEWLN,$L(ORTX(ORTX)) S ORTX=ORTX+1,ORTX(ORTX)="",Y=" " - S X=$$GETXT($P(ORP(DA),U,2)) I $L(X) S X=Y_X,Y="" D TXT^ORCHTAB ;lead tx - S PTR=+ORP(DA),TYPE=$E(ORDIALOG(PTR,0)) -TXT1 I TYPE'="W" S X=Y_ORP(DA,INST),Y="" D TXT^ORCHTAB - I TYPE="W" S ORI=0 F S ORI=$O(ORP(DA,INST,ORI)) Q:ORI'>0 D S Y="" - . S Y=$S(Y=" ":" ",$P(ORP(DA),U,5):" ",1:"") ;new line, or as stored - . S X=Y_ORP(DA,INST,ORI,0),Y="" - . I $E(X)'=" " D TXT^ORCHTAB Q ; wrap - . S:$L(ORTX(ORTX)) ORTX=ORTX+1,ORTX(ORTX)="" ; force new line - . I X?1." " S ORTX(ORTX)=" ",ORTX=ORTX+1,ORTX(ORTX)="" ; blank line - . E D TXT^ORCHTAB - D:$D(^ORD(101.41,+ORDIALOG,10,"DAD",PTR)) CHILD(PTR) - S INST=$O(ORP(DA,INST)) ; multiple? - I INST S ORTX(ORTX)=ORTX(ORTX)_",",Y="" S:NEWLN ORTX=ORTX+1,ORTX(ORTX)="",Y=" " G TXT1 - S X=$$GETXT($P(ORP(DA),U,3)) D:$L(X) TXT^ORCHTAB ; trailing text - Q - ; -CHILD(PARENT) ; -- add child values - N CHSEQ,CHILD S CHSEQ=0 - F S CHSEQ=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PARENT,CHSEQ)) Q:CHSEQ'>0 S CHILD=$O(^(CHSEQ,0)) D - . Q:'$L($G(ORP(CHILD,INST))) - . S X=$$GETXT($P(ORP(CHILD),U,2)) D:$L(X) TXT^ORCHTAB ; lead text - . S X=ORP(CHILD,INST) D TXT^ORCHTAB - . S X=$$GETXT($P(ORP(CHILD),U,3)) D:$L(X) TXT^ORCHTAB ; trail text - Q - ; -GETXT(X) ; -- Returns text of X - I $E(X)="@" N VAR S VAR=$E(X,2,99),X=$G(@VAR) K @VAR ; variable w/text - Q X - ; -EXT ; -- Build ORP(DA) array of external forms - N PROMPT,INST,DA,NODE,FORMAT,OMIT,X,Y,TYPE,PTR - S PROMPT=0 F S PROMPT=$O(ORDIALOG(PROMPT)) Q:PROMPT'>0 D - . S DA=+$G(ORDIALOG(PROMPT)),TYPE=$E($G(ORDIALOG(PROMPT,0))) Q:'$L(TYPE) - . Q:'DA S NODE=$G(^ORD(101.41,ORDIALOG,10,DA,2)),FORMAT=$P(NODE,U,2),OMIT=$P(NODE,U,3) - . S:$D(ORDIALOG(PROMPT,"FORMAT")) FORMAT=ORDIALOG(PROMPT,"FORMAT") - . I $E(FORMAT)="@" S PTR=+$E(FORMAT,2,99) Q:'PTR ; Don't include - . S INST=0 F S INST=$O(ORDIALOG(PROMPT,INST)) Q:INST'>0 D - . . Q:ORDIALOG(PROMPT,INST)="" - . . I $E(FORMAT)="@",$L($G(ORDIALOG(PTR,INST))) Q ; use PTR instead - . . I $E(FORMAT)="*" S PTR=+$E(FORMAT,2,99) I '$L($G(ORDIALOG(PTR,INST))) Q ; must have PTR too - . . I $E(FORMAT)="=" S PTR=+$E(FORMAT,2,99) I PTR,$L($G(ORDIALOG(PTR,INST))) S Y=$$EXT^ORCD(PTR,INST),X=$$EXT^ORCD(PROMPT,INST) I (X=Y)!(X[Y)!(Y[X) Q - . . I TYPE="W" M ORP(DA,INST)=@ORDIALOG(PROMPT,INST) - . . E S X=$$EXT^ORCD(PROMPT,INST,FORMAT) Q:X="" Q:OMIT[X S ORP(DA,INST)=X - . . S ORP(DA)=PROMPT_U_$P(NODE,U,4,7) ; ptr^lead^trail^new line^wrap - Q -DIGTEXT(ORDER,ORDEA,ORSIGNER) ;Build text used to create Digital Signature - ;ORDER = ifn of order # (file 100) - ;ORDEA = Controlled substance schedule of drug (2-5) - ;ORSIGNER = DUZ of sigining physician - ;ORSET(1)=1)Date of Prescription (RX) -Date Ordered HL7 format 2)Full Patient Name 3)Patient SSN 4)DFN - ;ORSET(2)=5)Patient Street1 6)Patient Street2 7)Patient Street3 8)Patient City 9)Patient State 10)Patient Zip 11)??? - ;ORSET(3)=12)Drug name (From Dispense Drug or Orderable Item) 13)Variable ptr for Drug (file 50 or 101.43) 14)Drug quantity prescribed 15)Schedule of medication 16)DEA Schedule - ;ORSET(4)=17)Direction for use - ;ORSET(5)=18)Practitioner's name 19)DUZ 20)Practitioner's (DEA) registration number - ;ORSET(6)=22)SiteName 23)SiteStreet1 24)SiteStreet2 25)SiteCity 26)SiteState 27)SiteZip - ;ORSET(7)=28)$H - N I,DFN,OR80,ORPNM,ORSSN,ORXDT,VAERR,VAPA,X0,X1,X4,X5,X6,X8,X9,X10,X11,X12,X13,X14,SIG - S OR80=$G(^OR(100,ORDER,8,1,0)) - Q:'$L(OR80) - S:'$G(ORSIGNER) ORSIGNER=$P(OR80,"^",3) - Q:'ORSIGNER - S $P(^OR(100,ORDER,8,1,2),"^",4,5)=ORDEA_"^"_1 ;Flag to signing process to get digital signature - S ORXDT=$P(OR80,"^"),X1=$$FMTHL7^XLFDT(ORXDT),X4="",X14="",X10="" - I '$D(ORVP) S ORVP=$P(^OR(100,ORDER,0),"^",2) - S DFN=+ORVP - D ADD^VADPT - S ORPNM=^DPT(+ORVP,0),ORSSN=$P(ORPNM,"^",9),ORPNM=$P(ORPNM,"^") - F I=1:1:6 S X4=X4_$S($L($G(VAPA(I))):$S((I=5):$P(VAPA(I),"^",2),1:VAPA(I)),1:"")_"^" - S X11=$$GET1^DIQ(200,ORSIGNER,.01,"E") Q:'$L(X11) - S X12=$$DEA^XUSER(,ORSIGNER) - S X0=$$GET1^DIQ(4,+$G(DUZ(2)),.01,"E") - I $L(X0) S X14=X0_"^"_$$GET1^DIQ(4,DUZ(2),1.01,"E")_"^"_$$GET1^DIQ(4,DUZ(2),1.02,"E")_"^"_$$GET1^DIQ(4,DUZ(2),1.03,"E")_"^"_$$GET1^DIQ(4,DUZ(2),.02,"E")_"^"_$$GET1^DIQ(4,DUZ(2),1.04,"E") - S X5=$$VALUE^ORX8(ORDER,"DRUG",,"E"),X6=$$VALUE^ORX8(ORDER,"DRUG")_";50" - I '$L(X5) S X5=$$VALUE^ORX8(ORDER,"ORDERABLE",,"E"),X6=$$VALUE^ORX8(ORDER,"ORDERABLE")_";101.43" - S X8=$$VALUE^ORX8(ORDER,"QTY",,"E"),X9=$$VALUE^ORX8(ORDER,"SCHEDULE",,"E") - S SIG=+$O(^OR(100,ORDER,4.5,"ID","SIG",0)) I SIG,$L($G(^OR(100,ORDER,4.5,SIG,2,1,0))) S X10=^(0) - S ORSET(1)=X1_"^"_ORPNM_"^"_ORSSN_"^"_+ORVP_"^" - S ORSET(2)=X4_"^" - S ORSET(3)=X5_"^"_X6_"^"_X8_"^"_X9_"^"_ORDEA_"^" - S ORSET(4)=X10_"^" - S ORSET(5)=X11_"^"_ORSIGNER_"^"_X12_"^" - S ORSET(6)=X14 - S ORSET(7)=$H - S ORSET=7 - Q +ORCSAVE1 ; SLC/MKB - Save Order Text ;7/13/04 15:41 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**92,132,141,163,187,223**;Dec 17, 1997 + ; + ; ^ORD(101.41,+ORDIALOG,10,ITM,2)=Seq#^Format^Omit^Lead Text^Trail Text + ; ^ORD(101.41,+ORDIALOG,10,"ATXT",Seq#,ITM)="" + ; +ORDTEXT(ORDER) ; -- Build and save order text from ORDIALOG() into ORDER + N ORTX,I,IFN,ACT,ORSET + D ORTX(240) Q:'$G(ORTX) + S IFN=+ORDER,ACT=+$P(ORDER,";",2) S:ACT'>0 ACT=1 + F I=1:1:ORTX S ^OR(100,IFN,8,ACT,.1,I,0)=ORTX(I) + S ^OR(100,IFN,8,ACT,.1,0)=U_U_ORTX_U_ORTX_U_DT_U + I $E($G(ORDEA))=2 D ;PKI Drug Schedule - in future may allow 2-5 + . S ORSET=0 + . D DIGTEXT(IFN,ORDEA) + . F I=1:1:ORSET S ^OR(100,IFN,8,ACT,.2,I,0)=ORSET(I) + . I ORSET>0 S ^OR(100,IFN,8,ACT,.2,0)=U_U_ORSET_U_ORSET_U_DT_U + Q + ; +ORTX(WIDTH) ; -- May enter here to return order text in ORTX() + N ORP,SEQ,ITEM,ORMAX + K ORTX S ORMAX=$S(+$G(WIDTH):WIDTH,1:240) + D EXT ; get external form of values + S SEQ=0 F S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"ATXT",SEQ)) Q:SEQ'>0 S ITEM=$O(^(SEQ,0)) D TEXT(ITEM) + Q + ; +TEXT(DA) ; -- Includes text of item DA + Q:$P(^ORD(101.41,ORDIALOG,10,DA,0),U,11) Q:'$O(ORP(DA,0)) + N NEWLN,INST,TYPE,PTR,CHSEQ,CHILD,ORI,X,Y + S:'$G(ORTX) ORTX=1,ORTX(1)="" + S NEWLN=+$P(ORP(DA),U,4),INST=$O(ORP(DA,0)),Y="" + I NEWLN,$L(ORTX(ORTX)) S ORTX=ORTX+1,ORTX(ORTX)="",Y=" " + S X=$$GETXT($P(ORP(DA),U,2)) I $L(X) S X=Y_X,Y="" D TXT^ORCHTAB ;lead tx + S PTR=+ORP(DA),TYPE=$E(ORDIALOG(PTR,0)) +TXT1 I TYPE'="W" S X=Y_ORP(DA,INST),Y="" D TXT^ORCHTAB + I TYPE="W" S ORI=0 F S ORI=$O(ORP(DA,INST,ORI)) Q:ORI'>0 D S Y="" + . S Y=$S(Y=" ":" ",$P(ORP(DA),U,5):" ",1:"") ;new line, or as stored + . S X=Y_ORP(DA,INST,ORI,0),Y="" + . I $E(X)'=" " D TXT^ORCHTAB Q ; wrap + . S:$L(ORTX(ORTX)) ORTX=ORTX+1,ORTX(ORTX)="" ; force new line + . I X?1." " S ORTX(ORTX)=" ",ORTX=ORTX+1,ORTX(ORTX)="" ; blank line + . E D TXT^ORCHTAB + D:$D(^ORD(101.41,+ORDIALOG,10,"DAD",PTR)) CHILD(PTR) + S INST=$O(ORP(DA,INST)) ; multiple? + I INST S ORTX(ORTX)=ORTX(ORTX)_",",Y="" S:NEWLN ORTX=ORTX+1,ORTX(ORTX)="",Y=" " G TXT1 + S X=$$GETXT($P(ORP(DA),U,3)) D:$L(X) TXT^ORCHTAB ; trailing text + Q + ; +CHILD(PARENT) ; -- add child values + N CHSEQ,CHILD S CHSEQ=0 + F S CHSEQ=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PARENT,CHSEQ)) Q:CHSEQ'>0 S CHILD=$O(^(CHSEQ,0)) D + . Q:'$L($G(ORP(CHILD,INST))) + . S X=$$GETXT($P(ORP(CHILD),U,2)) D:$L(X) TXT^ORCHTAB ; lead text + . S X=ORP(CHILD,INST) D TXT^ORCHTAB + . S X=$$GETXT($P(ORP(CHILD),U,3)) D:$L(X) TXT^ORCHTAB ; trail text + Q + ; +GETXT(X) ; -- Returns text of X + I $E(X)="@" N VAR S VAR=$E(X,2,99),X=$G(@VAR) K @VAR ; variable w/text + Q X + ; +EXT ; -- Build ORP(DA) array of external forms + N PROMPT,INST,DA,NODE,FORMAT,OMIT,X,Y,TYPE,PTR + S PROMPT=0 F S PROMPT=$O(ORDIALOG(PROMPT)) Q:PROMPT'>0 D + . S DA=+$G(ORDIALOG(PROMPT)),TYPE=$E($G(ORDIALOG(PROMPT,0))) Q:'$L(TYPE) + . Q:'DA S NODE=$G(^ORD(101.41,ORDIALOG,10,DA,2)),FORMAT=$P(NODE,U,2),OMIT=$P(NODE,U,3) + . S:$D(ORDIALOG(PROMPT,"FORMAT")) FORMAT=ORDIALOG(PROMPT,"FORMAT") + . I $E(FORMAT)="@" S PTR=+$E(FORMAT,2,99) Q:'PTR ; Don't include + . S INST=0 F S INST=$O(ORDIALOG(PROMPT,INST)) Q:INST'>0 D + . . Q:ORDIALOG(PROMPT,INST)="" + . . I $E(FORMAT)="@",$L($G(ORDIALOG(PTR,INST))) Q ; use PTR instead + . . I $E(FORMAT)="*" S PTR=+$E(FORMAT,2,99) I '$L($G(ORDIALOG(PTR,INST))) Q ; must have PTR too + . . I $E(FORMAT)="=" S PTR=+$E(FORMAT,2,99) I PTR,$L($G(ORDIALOG(PTR,INST))) S Y=$$EXT^ORCD(PTR,INST),X=$$EXT^ORCD(PROMPT,INST) I (X=Y)!(X[Y)!(Y[X) Q + . . I TYPE="W" M ORP(DA,INST)=@ORDIALOG(PROMPT,INST) + . . E S X=$$EXT^ORCD(PROMPT,INST,FORMAT) Q:X="" Q:OMIT[X S ORP(DA,INST)=X + . . S ORP(DA)=PROMPT_U_$P(NODE,U,4,7) ; ptr^lead^trail^new line^wrap + Q +DIGTEXT(ORDER,ORDEA,ORSIGNER) ;Build text used to create Digital Signature + ;ORDER = ifn of order # (file 100) + ;ORDEA = Controlled substance schedule of drug (2-5) + ;ORSIGNER = DUZ of sigining physician + ;ORSET(1)=1)Date of Prescription (RX) -Date Ordered HL7 format 2)Full Patient Name 3)Patient SSN 4)DFN + ;ORSET(2)=5)Patient Street1 6)Patient Street2 7)Patient Street3 8)Patient City 9)Patient State 10)Patient Zip 11)??? + ;ORSET(3)=12)Drug name (From Dispense Drug or Orderable Item) 13)Variable ptr for Drug (file 50 or 101.43) 14)Drug quantity prescribed 15)Schedule of medication 16)DEA Schedule + ;ORSET(4)=17)Direction for use + ;ORSET(5)=18)Practitioner's name 19)DUZ 20)Practitioner's (DEA) registration number + ;ORSET(6)=22)SiteName 23)SiteStreet1 24)SiteStreet2 25)SiteCity 26)SiteState 27)SiteZip + ;ORSET(7)=28)$H + N I,DFN,OR80,ORPNM,ORSSN,ORXDT,VAERR,VAPA,X0,X1,X4,X5,X6,X8,X9,X10,X11,X12,X13,X14,SIG + S OR80=$G(^OR(100,ORDER,8,1,0)) + Q:'$L(OR80) + S:'$G(ORSIGNER) ORSIGNER=$P(OR80,"^",3) + Q:'ORSIGNER + S $P(^OR(100,ORDER,8,1,2),"^",4,5)=ORDEA_"^"_1 ;Flag to signing process to get digital signature + S ORXDT=$P(OR80,"^"),X1=$$FMTHL7^XLFDT(ORXDT),X4="",X14="",X10="" + I '$D(ORVP) S ORVP=$P(^OR(100,ORDER,0),"^",2) + S DFN=+ORVP + D ADD^VADPT + S ORPNM=^DPT(+ORVP,0),ORSSN=$P(ORPNM,"^",9),ORPNM=$P(ORPNM,"^") + F I=1:1:6 S X4=X4_$S($L($G(VAPA(I))):$S((I=5):$P(VAPA(I),"^",2),1:VAPA(I)),1:"")_"^" + S X11=$$GET1^DIQ(200,ORSIGNER,.01,"E") Q:'$L(X11) + S X12=$$DEA^XUSER(,ORSIGNER) + S X0=$$GET1^DIQ(4,+$G(DUZ(2)),.01,"E") + I $L(X0) S X14=X0_"^"_$$GET1^DIQ(4,DUZ(2),1.01,"E")_"^"_$$GET1^DIQ(4,DUZ(2),1.02,"E")_"^"_$$GET1^DIQ(4,DUZ(2),1.03,"E")_"^"_$$GET1^DIQ(4,DUZ(2),.02,"E")_"^"_$$GET1^DIQ(4,DUZ(2),1.04,"E") + S X5=$$VALUE^ORX8(ORDER,"DRUG",,"E"),X6=$$VALUE^ORX8(ORDER,"DRUG")_";50" + I '$L(X5) S X5=$$VALUE^ORX8(ORDER,"ORDERABLE",,"E"),X6=$$VALUE^ORX8(ORDER,"ORDERABLE")_";101.43" + S X8=$$VALUE^ORX8(ORDER,"QTY",,"E"),X9=$$VALUE^ORX8(ORDER,"SCHEDULE",,"E") + S SIG=+$O(^OR(100,ORDER,4.5,"ID","SIG",0)) I SIG,$L($G(^OR(100,ORDER,4.5,SIG,2,1,0))) S X10=^(0) + S ORSET(1)=X1_"^"_ORPNM_"^"_ORSSN_"^"_+ORVP_"^" + S ORSET(2)=X4_"^" + S ORSET(3)=X5_"^"_X6_"^"_X8_"^"_X9_"^"_ORDEA_"^" + S ORSET(4)=X10_"^" + S ORSET(5)=X11_"^"_ORSIGNER_"^"_X12_"^" + S ORSET(6)=X14 + S ORSET(7)=$H + S ORSET=7 + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCSAVE2.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCSAVE2.m index e71e447e..1dbcd29b 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCSAVE2.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCSAVE2.m @@ -1,224 +1,172 @@ -ORCSAVE2 ;SLC/MKB-Utilities to update an order ; 4/8/08 12:04pm - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,27,56,70,94,116,190,157,215,265,243**;Dec 17, 1997;Build 242 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -STATUS(IFN,ST) ; -- Update status of order - Q:'$G(IFN) Q:'$D(^OR(100,+IFN,0)) Q:$P($G(^(3)),U,3)=$G(ST) ;no change - Q:'$G(ST) Q:'$D(^ORD(100.01,+ST,0)) - N NODE0,NODE3,ORNOW,DA,XACT,PROV,ORVP - S NODE3=$G(^OR(100,+IFN,3)),ORVP=$P($G(^(0)),U,2),ORNOW=$$NOW^XLFDT - S $P(NODE3,U)=ORNOW,$P(NODE3,U,3)=ST,^OR(100,+IFN,3)=NODE3 - I (ST<3)!(ST=12)!(ST=13),$G(ORDCNTRL)'="ZC" D DATES(+IFN,,+$E(ORNOW,1,12)) - I "^1^2^7^12^13^15^"[(U_ST_U) D CANCEL^ORCSEND(+IFN),UNOTIF^ORCSIGN - I $P(NODE3,U,9) D CKPARENT($P(NODE3,U,9)) ; ck siblings to update parent - D SETALL^ORDD100(+IFN) - Q - ; -CKPARENT(ORIFN) ; -- Update status of parent order, if appropriate - N ORSTS,ALLRELSD,ALLDONE,DC,COMP,CH,CHSTS,ACTIVE,LAPS - Q:'$D(^OR(100,ORIFN,0)) S ORSTS=$P($G(^(3)),U,3) - I (ORSTS=11)!(ORSTS=10) S ALLRELSD=1 D Q ;Parent unrel'd - ck children - . F CH=0:0 S CH=$O(^OR(100,ORIFN,2,CH)) Q:CH'>0 D Q:'ALLRELSD - . . I '$D(^OR(100,CH)) K ^OR(100,ORIFN,2,CH) Q - . . S CHSTS=$P($G(^OR(100,CH,3)),U,3) S:CHSTS=11 ALLRELSD=0 - . I ALLRELSD D STATUS(ORIFN,5) ; update Parent order to pending - S ALLDONE=1,(DC,COMP,LAPS,ACTIVE)=0 - F CH=0:0 S CH=$O(^OR(100,ORIFN,2,CH)) Q:CH'>0 D Q:'ALLDONE - . I '$D(^OR(100,CH)) K ^OR(100,ORIFN,2,CH) Q - . S CHSTS=$P($G(^OR(100,CH,3)),U,3) I CHSTS=14 S LAPS=1 Q - . I "^1^12^13^"[(U_CHSTS_U) S DC=1 Q - . I "^2^7^"[(U_CHSTS_U) S COMP=1 Q - . S ALLDONE=0 S:CHSTS=6 ACTIVE=1 - I ALLDONE S ORSTS=$S(COMP:2,DC:1,LAPS:14,1:"") D:ORSTS STATUS(ORIFN,ORSTS) Q - I ACTIVE,ORSTS'=6 D STATUS(ORIFN,6) ;at least child active - Q - ; -RELEASE(ORDER,ACTION,WHEN,WHO,NATURE) ; -- Mark order as released to service - S:'$G(ACTION) ACTION=1 S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12) S:'$G(WHO) WHO=DUZ - Q:'$G(ORDER) N OR0 S OR0=$G(^OR(100,ORDER,8,ACTION,0)) - S:$L($G(NATURE)) $P(OR0,U,12)=$S(NATURE:NATURE,1:+$O(^ORD(100.02,"C",NATURE,0))) - S:($P(OR0,U,15)=10)!($P(OR0,U,15)=11) $P(OR0,U,15)="" - ;S $P(OR0,U,16,17)=WHEN_U_WHO,^OR(100,"AR",ORVP,9999999-WHEN,ORDER,ACTION)="" - S $P(OR0,U,16,17)=WHEN_U_WHO - S ^OR(100,ORDER,8,ACTION,0)=OR0 - I $P(OR0,U,2)="NW",'$P(^OR(100,ORDER,0),U,8) D STARTDT(ORDER) - ;Set the "AR" index. - D RS^ORDD100(ORDER,ACTION,ORVP,WHEN) - Q - ; -STARTDT(DA) ; -- resolve Start and Stop dates from Responses - N X,Y,%DT,ORDG,ORT,ORLAB - S ORDG=$P($G(^ORD(100.98,+$P(^OR(100,DA,0),U,11),0)),U,3) - S ORLAB="^LAB^CH^HEMA^MI^AP^AU^EM^SP^CY^BB^"[(U_ORDG_U),ORT="" - S:ORDG="E/L T" ORT=$$VALUE(DA,"TIME") S:ORDG="MEAL" ORT=$$MEALTIME^ORCDFHO(DA) -STRT S X=$$VALUE(DA,"START") I '$L(X) D WS^ORDD100 Q S:$L(ORT) X=X_"@"_ORT - D AM:X="AM",NEXT:X="NEXT",ADMIN("NEXT"):X="NEXTA",ADMIN("CLOSEST"):X="CLOSEST" - S %DT="T" D ^%DT Q:Y'>0 S:$E($P(Y,".",2),1,2)=24 Y=$P(Y,".")_".2359" - S $P(^OR(100,DA,0),U,8)=Y D SS^ORDD100,WS^ORDD100,OI1^ORDD100A(DA) -STOP I ORLAB S X=$$VALUE(DA,"DAYS") Q:X'>1 S X=$$FMADD^XLFDT(Y,(X-1)) - I 'ORLAB S X=$$VALUE(DA,"STOP") Q:'$L(X) S:$L(ORT) X=X_"@"_ORT - S %DT="T" D ^%DT Q:Y'>0 S:$E($P(Y,".",2),1,2)=24 Y=$P(Y,".")_".2359" - S $P(^OR(100,DA,0),U,9)=Y D ES^ORDD100A - Q - ; -NEXT ; -- Resolve next lab collection to FM date/time - N ORTIME,ORDAY,NOW,NEXT,ENT - ;is referenced by DBIA #964 - S ENT=$S($P($G(^SC(+$G(ORL),0)),U,4):+$P(^(0),U,4),1:+$G(DUZ(2)))_";DIC(4," S:ENT'>0 ENT="ALL" - D GETLST^XPAR(.ORTIME,ENT,"LR PHLEBOTOMY COLLECTION","N") - S NOW=$P($H,",",2),ORDAY=$S($O(ORTIME(NOW)):"T",1:"T+1") - S ORDAY=$$NEXTCOLL^ORCDLR1(ORDAY) S:ORDAY["+" NOW=0 - S NEXT=$O(ORTIME(NOW)),X=ORDAY_"@"_$P($G(ORTIME(+NEXT)),U) - Q - ; -AM ; -- Resolve AM lab collection to FM date/time - N ORTIME,ORDAY,AM,NOW,ENT - ;is referenced by DBIA #964 - S ENT=$S($P($G(^SC(+$G(ORL),0)),U,4):+$P(^(0),U,4),1:+$G(DUZ(2)))_";DIC(4," S:ENT'>0 ENT="ALL" - D GETLST^XPAR(.ORTIME,ENT,"LR PHLEBOTOMY COLLECTION","N") - S AM=$O(ORTIME(0)),NOW=$P($H,",",2) - S ORDAY=$S(AM=$O(ORTIME(NOW)):"T",1:"T+1") - S X=$$NEXTCOLL^ORCDLR1(ORDAY)_"@"_$P($G(ORTIME(+AM)),U) - Q - ; -ADMIN(START) ; -- Resolve next/closest administration times to FM date/time - N PAT,SCH,OI,LOC,Y,I - I $G(DA) D ;get data from order DA - . S PAT=+$P($G(^OR(100,DA,0)),U,2),LOC="" - . S I=+$O(^OR(100,DA,4.5,"ID","INSTR",0)),I=+$P($G(^OR(100,DA,4.5,I,0)),U,3) ;first - . S SCH=$$VALUE(DA,"SCHEDULE",I),OI=$$VALUE(DA,"ORDERABLE") - I '$G(DA) D ;or look in ORDIALOG() instead - . S I=+$O(ORDIALOG($$PTR^ORCD("OR GTX INSTRUCTIONS"),0)) - . S PAT=$G(ORVP),SCH=$G(ORDIALOG($$PTR^ORCD("OR GTX SCHEDULE"),I)) - . S OI=$G(ORDIALOG($$PTR^ORCD("OR GTX ORDERABLE ITEM"),1)),LOC="" - S OI=+$P($G(^ORD(101.43,+OI,0)),U,2) ;PSOI - ;is referenced by DBIA #3167 - S Y=$$RESOLVE^PSJORPOE(PAT,SCH,OI,START,LOC),X=$P(Y,U,2) - Q - ; -SIGN(DA,WHO,WHEN,HOW,WHAT) ; -- affix ES to order - Q:'$G(DA) S:'$G(WHAT) WHAT=1 - N X S X=$G(^OR(100,DA,8,WHAT,0)) D S2^ORDD100(DA,WHAT) ; kill AS xref - S $P(X,U,4,7)=$G(HOW)_U_$G(WHO)_U_$E($G(WHEN),1,12)_U_$S(HOW=0:DUZ,1:"") - ; S:$G(WHO) $P(X,U,3)=WHO ; reset provider to signer - S ^OR(100,DA,8,WHAT,0)=X - D:$G(HOW)=2 S1^ORDD100(DA,WHAT) ; reset AS xref - Q - ; -SIGSTS(IFN,ACT) ; -- Set SigSts for backdoor orders [Called from ^ORM* rtns] - ; Expects ORNATR, ORVP, ORNP to be defined - Q:'$G(IFN) Q:'$G(ACT) N X,OR0 S OR0=+$P($G(^OR(100,+IFN,8,ACT,0)),U) - S X=$S($$SIGNREQD^ORCACT1(+IFN):$$SIGSTS^ORX1(ORNATR),1:3) - K ^OR(100,"AS",ORVP,9999999-OR0,+IFN,ACT) - S $P(^OR(100,+IFN,8,ACT,0),U,4)=X - I X=2 S ^OR(100,"AS",ORVP,9999999-OR0,+IFN,ACT)="" D NOTIF^ORCSIGN - Q - ; -UNVEIL(IFN) ; -- unveil new order - S $P(^OR(100,IFN,3),U,8)="" - Q - ; -DELETE(ORDER) ; -- delete order [action] - N DIK,DA,DAD - I $P(ORDER,";",2)>1 S DA=+$P(ORDER,";",2),DA(1)=+ORDER,DIK="^OR(100,"_DA(1)_",8," D:DA ^DIK Q - S DAD=+$P($G(^OR(100,+ORDER,3)),U,9) I DAD S DIK="^OR(100,"_DAD_",2,",DA(1)=DAD,DA=+ORDER D ^DIK ; remove link to child from parent - K DA S DA=+ORDER,DIK="^OR(100," D ^DIK ;remove order, text - Q - ; -VERIFY(IFN,DA,TYPE,WHO,WHEN) ; -- order verified - Q:'$G(IFN) Q:'$G(DA) Q:"^N^C^R^"'[(U_$G(TYPE)_U) - N FLD S FLD=$S(TYPE="N":8,TYPE="C":10,1:18) - S:'$G(WHO) WHO=DUZ S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12) - S $P(^OR(100,IFN,8,DA,0),U,FLD,FLD+1)=WHO_U_WHEN - D:$L($T(VER^EDPFMON)) VER^EDPFMON(IFN) - Q - ; -COMP(IFN,WHO,WHEN) ; -- order completed - Q:'$G(IFN) S:'$G(WHO) WHO=DUZ S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12) - D DATES(+IFN,,WHEN),STATUS(+IFN,2) - S $P(^OR(100,+IFN,6),U,6,7)=WHEN_U_WHO - D:$L($T(COMP^EDPFMON)) COMP^EDPFMON(IFN) - Q - ; -DATES(DA,START,STOP) ; -- Update start/stop dates for order DA - Q:'$G(DA) I $G(START) D - . Q:START=$P(^OR(100,DA,0),U,8) - . D SK^ORDD100,WK^ORDD100,OI2^ORDD100A(DA) - . S $P(^OR(100,DA,0),U,8)=START - . D SS^ORDD100,WS^ORDD100,OI1^ORDD100A(DA) - I $G(STOP) D - . ;Q:STOP=$P(^OR(100,DA,0),U,9) ;ck xref anyway - . D EK^ORDD100A S $P(^OR(100,DA,0),U,9)=STOP D ES^ORDD100A - Q - ; -OC ; -- Save order checks in ORCHECK() in ^OR(100,+ORIFN,9) - Q:'$G(ORIFN) Q:'$D(^OR(100,+ORIFN,0)) K ^OR(100,+ORIFN,9) - N NOW,CNT,CDL,I,OC,OVERIDE S NOW=+$E($$NOW^XLFDT,1,12),CNT=0 - S CDL=0 F S CDL=$O(ORCHECK(+ORIFN,CDL)) Q:CDL'>0 D - . S I=0 F S I=$O(ORCHECK(+ORIFN,CDL,I)) Q:I'>0 D - . . S OC=ORCHECK(+ORIFN,CDL,I) Q:'OC - . . S OVERIDE=$S($G(MODE)="NOTIF":$G(ORCHECK("OK"))_U,CDL=1:$G(ORCHECK("OK"))_U_DUZ,1:U_DUZ)_U_NOW - . . S CNT=CNT+1,^OR(100,+ORIFN,9,"B",+OC,CNT)="" - . . S ^OR(100,+ORIFN,9,CNT,0)=$P(OC,U,1,2)_U_U_OVERIDE,^(1)=$E($P(OC,U,3),1,245) - S:CNT ^OR(100,+ORIFN,9,0)="^100.09PA^"_CNT_U_CNT - Q - ; -VALUE(IFN,ID,INST) ; -- Returns value of prompt by identifier ID - I '$G(IFN)!('$D(^OR(100,+$G(IFN),0)))!($G(ID)="") Q "" - N I,Y S I=0,Y="" S:'$G(INST) INST=1 - F S I=$O(^OR(100,IFN,4.5,"ID",ID,I)) Q:I'>0 I $P($G(^OR(100,IFN,4.5,+I,0)),U,3)=INST S Y=$G(^(1)) Q - Q Y - ; -SC(ORX,ORIFN) ; -- save responses to SC questions - Q:'$G(ORIFN) Q:'$D(^OR(100,+ORIFN,0)) ;invalid order number - N OR5,I,P S OR5=$G(^OR(100,+ORIFN,5)),P=0 - F I="SC","MST","AO","IR","EC","HNC","CV","SHD" S P=P+1 S:$D(ORX(I)) $P(OR5,U,P)=ORX(I) - S ^OR(100,+ORIFN,5)=OR5 - Q - ; -CANCEL(ORDER) ; -- cancel order [action] - N ORA,DIE,DA,DR,ORX - S ORDER=$G(ORDER),ORA=+$P(ORDER,";",2) Q:'ORA!('ORDER) - I $D(^OR(100,+ORDER,8,ORA)) D - .S ORX="Unsigned/unreleased order cancelled by provider" - .S DIE="^OR(100,"_+ORDER_",8,",DA=ORA,DA(1)=+ORDER - .S DR="4////5;15////13;1////^S X=ORX" D ^DIE - I ORA=1 D - .K DA S DIE="^OR(100,",DA=+ORDER,DR="5////13" D ^DIE - Q - ; -LAPSE(ORDER) ; -- lapse order [action] - N ORA S ORA=+$P(ORDER,";",2) - Q:'$D(^OR(100,+ORDER,0)) Q:'ORA!('ORDER) - I $D(^OR(100,+ORDER,8,ORA)) D - .N DIE,DA,DR - .S DIE="^OR(100,"_+ORDER_",8,",DA=ORA,DA(1)=+ORDER - .S DR="4////5;15////14" D ^DIE - I ORA=1 D - .N DIE,DA,DR - .S DIE="^OR(100,",DA=+ORDER,DR="5////14" - .D ^DIE,ALPS(DA,ORA) - Q -ALPS(DA,ORACT,TYPE) ;set the lapse index ^OR(100,"ALPS") - N ORVP,X,OR0,ORLOG - S OR0=$G(^OR(100,DA,8,ORACT,0)) - S ORLOG=$P(OR0,U),ORVP=$P($G(^OR(100,DA,0)),U,2) - I ORVP,ORLOG S ^OR(100,"ALPS",ORVP,9999999-ORLOG,DA,ORACT)=$G(TYPE) - S ^OR(100,DA,10)=$$NOW^XLFDT - Q - ; -RESP(IFN,PRMT,VAL,INST) ; -- update a single Response VALue - S IFN=+$G(IFN),VAL=$G(VAL),PRMT=+$O(^ORD(101.41,"AB",PRMT,0)) - N ID,DA,DIK S:'$G(INST) INST=1 - S ID=$P($G(^ORD(101.41,PRMT,1)),U,3) Q:'$L(ID) - S DA=0 F S DA=$O(^OR(100,IFN,4.5,"ID",ID,DA)) Q:DA<1 Q:$P($G(^OR(100,IFN,4.5,DA,0)),U,3)=INST - I 'DA D:$L(VAL) Q ;add - . N DO,DIC,DLG,X - . S DIC="^OR(100,"_IFN_",4.5,",DA(1)=IFN,DIC(0)="FL" - . S DIC("DR")=".02///"_PRMT_";.03///"_INST_";.04///"_ID - . S DLG=+$P($G(^OR(100,IFN,0)),U,5) - . S X=+$O(^ORD(101.41,DLG,10,"D",PRMT,0)) - . D FILE^DICN S:Y ^OR(100,IFN,4.5,+Y,1)=VAL - I $L(VAL) S ^OR(100,IFN,4.5,DA,1)=VAL Q ;change - S DIK="^OR(100,"_IFN_",4.5,",DA(1)=IFN D ^DIK ;delete - Q +ORCSAVE2 ;SLC/MKB-Utilities to update an order ;04:19 PM 06/16/2004 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,27,56,70,94,116,190,157,215,265**;Dec 17, 1997;Build 17 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; +STATUS(IFN,ST) ; -- Update status of order + Q:'$G(IFN) Q:'$D(^OR(100,+IFN,0)) Q:$P($G(^(3)),U,3)=$G(ST) ;no change + Q:'$G(ST) Q:'$D(^ORD(100.01,+ST,0)) + N NODE0,NODE3,ORNOW,DA,XACT,PROV,ORVP + S NODE3=$G(^OR(100,+IFN,3)),ORVP=$P($G(^(0)),U,2),ORNOW=$$NOW^XLFDT + S $P(NODE3,U)=ORNOW,$P(NODE3,U,3)=ST,^OR(100,+IFN,3)=NODE3 + I (ST<3)!(ST=12)!(ST=13),$G(ORDCNTRL)'="ZC" D DATES(+IFN,,+$E(ORNOW,1,12)) + I "^1^2^7^12^13^15^"[(U_ST_U) D CANCEL^ORCSEND(+IFN),UNOTIF^ORCSIGN + I $P(NODE3,U,9) D CKPARENT($P(NODE3,U,9)) ; ck siblings to update parent + D SETALL^ORDD100(+IFN) + Q + ; +CKPARENT(ORIFN) ; -- Update status of parent order, if appropriate + N ORSTS,ALLRELSD,ALLDONE,DC,COMP,CH,CHSTS,ACTIVE,LAPS + Q:'$D(^OR(100,ORIFN,0)) S ORSTS=$P($G(^(3)),U,3) + I (ORSTS=11)!(ORSTS=10) S ALLRELSD=1 D Q ;Parent unrel'd - ck children + . F CH=0:0 S CH=$O(^OR(100,ORIFN,2,CH)) Q:CH'>0 D Q:'ALLRELSD + . . I '$D(^OR(100,CH)) K ^OR(100,ORIFN,2,CH) Q + . . S CHSTS=$P($G(^OR(100,CH,3)),U,3) S:CHSTS=11 ALLRELSD=0 + . I ALLRELSD D STATUS(ORIFN,5) ; update Parent order to pending + S ALLDONE=1,(DC,COMP,LAPS,ACTIVE)=0 + F CH=0:0 S CH=$O(^OR(100,ORIFN,2,CH)) Q:CH'>0 D Q:'ALLDONE + . I '$D(^OR(100,CH)) K ^OR(100,ORIFN,2,CH) Q + . S CHSTS=$P($G(^OR(100,CH,3)),U,3) I CHSTS=14 S LAPS=1 Q + . I "^1^12^13^"[(U_CHSTS_U) S DC=1 Q + . I "^2^7^"[(U_CHSTS_U) S COMP=1 Q + . S ALLDONE=0 S:CHSTS=6 ACTIVE=1 + I ALLDONE S ORSTS=$S(COMP:2,DC:1,LAPS:14,1:"") D:ORSTS STATUS(ORIFN,ORSTS) Q + I ACTIVE,ORSTS'=6 D STATUS(ORIFN,6) ;at least child active + Q + ; +RELEASE(ORDER,ACTION,WHEN,WHO,NATURE) ; -- Mark order as released to service + S:'$G(ACTION) ACTION=1 S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12) S:'$G(WHO) WHO=DUZ + Q:'$G(ORDER) N OR0 S OR0=$G(^OR(100,ORDER,8,ACTION,0)) + S:$L($G(NATURE)) $P(OR0,U,12)=$S(NATURE:NATURE,1:+$O(^ORD(100.02,"C",NATURE,0))) + S:($P(OR0,U,15)=10)!($P(OR0,U,15)=11) $P(OR0,U,15)="" + ;S $P(OR0,U,16,17)=WHEN_U_WHO,^OR(100,"AR",ORVP,9999999-WHEN,ORDER,ACTION)="" + S $P(OR0,U,16,17)=WHEN_U_WHO + S ^OR(100,ORDER,8,ACTION,0)=OR0 + I $P(OR0,U,2)="NW",'$P(^OR(100,ORDER,0),U,8) D STARTDT(ORDER) + ;Set the "AR" index. + D RS^ORDD100(ORDER,ACTION,ORVP,WHEN) + Q + ; +STARTDT(DA) ; -- resolve Start and Stop dates from Responses + N X,Y,%DT,ORDG,ORT,ORLAB + S ORDG=$P($G(^ORD(100.98,+$P(^OR(100,DA,0),U,11),0)),U,3) + S ORLAB="^LAB^CH^HEMA^MI^AP^AU^EM^SP^CY^BB^"[(U_ORDG_U),ORT="" + S:ORDG="E/L T" ORT=$$VALUE(DA,"TIME") S:ORDG="MEAL" ORT=$$MEALTIME^ORCDFHO(DA) +STRT S X=$$VALUE(DA,"START") I '$L(X) D WS^ORDD100 Q S:$L(ORT) X=X_"@"_ORT + D AM:X="AM",NEXT:X="NEXT",ADMIN("NEXT"):X="NEXTA",ADMIN("CLOSEST"):X="CLOSEST" + S %DT="T" D ^%DT Q:Y'>0 S:$E($P(Y,".",2),1,2)=24 Y=$P(Y,".")_".2359" + S $P(^OR(100,DA,0),U,8)=Y D SS^ORDD100,WS^ORDD100,OI1^ORDD100A(DA) +STOP I ORLAB S X=$$VALUE(DA,"DAYS") Q:X'>1 S X=$$FMADD^XLFDT(Y,(X-1)) + I 'ORLAB S X=$$VALUE(DA,"STOP") Q:'$L(X) S:$L(ORT) X=X_"@"_ORT + S %DT="T" D ^%DT Q:Y'>0 S:$E($P(Y,".",2),1,2)=24 Y=$P(Y,".")_".2359" + S $P(^OR(100,DA,0),U,9)=Y D ES^ORDD100A + Q + ; +NEXT ; -- Resolve next lab collection to FM date/time + N ORTIME,ORDAY,NOW,NEXT,ENT + S ENT=$S($P($G(^SC(+$G(ORL),0)),U,4):+$P(^(0),U,4),1:+$G(DUZ(2)))_";DIC(4," S:ENT'>0 ENT="ALL" ;is referenced by DBIA #964 + D GETLST^XPAR(.ORTIME,ENT,"LR PHLEBOTOMY COLLECTION","N") + S NOW=$P($H,",",2),ORDAY=$S($O(ORTIME(NOW)):"T",1:"T+1") + S ORDAY=$$NEXTCOLL^ORCDLR1(ORDAY) S:ORDAY["+" NOW=0 + S NEXT=$O(ORTIME(NOW)),X=ORDAY_"@"_$P($G(ORTIME(+NEXT)),U) + Q + ; +AM ; -- Resolve AM lab collection to FM date/time + N ORTIME,ORDAY,AM,NOW,ENT + S ENT=$S($P($G(^SC(+$G(ORL),0)),U,4):+$P(^(0),U,4),1:+$G(DUZ(2)))_";DIC(4," S:ENT'>0 ENT="ALL" ;is referenced by DBIA #964 + D GETLST^XPAR(.ORTIME,ENT,"LR PHLEBOTOMY COLLECTION","N") + S AM=$O(ORTIME(0)),NOW=$P($H,",",2) + S ORDAY=$S(AM=$O(ORTIME(NOW)):"T",1:"T+1") + S X=$$NEXTCOLL^ORCDLR1(ORDAY)_"@"_$P($G(ORTIME(+AM)),U) + Q + ; +ADMIN(START) ; -- Resolve next/closest administration times to FM date/time + N PAT,SCH,OI,LOC,Y,I + I $G(DA) D ;get data from order DA + . S PAT=+$P($G(^OR(100,DA,0)),U,2),LOC="" + . S I=+$O(^OR(100,DA,4.5,"ID","INSTR",0)),I=+$P($G(^OR(100,DA,4.5,I,0)),U,3) ;first + . S SCH=$$VALUE(DA,"SCHEDULE",I),OI=$$VALUE(DA,"ORDERABLE") + I '$G(DA) D ;or look in ORDIALOG() instead + . S I=+$O(ORDIALOG($$PTR^ORCD("OR GTX INSTRUCTIONS"),0)) + . S PAT=$G(ORVP),SCH=$G(ORDIALOG($$PTR^ORCD("OR GTX SCHEDULE"),I)) + . S OI=$G(ORDIALOG($$PTR^ORCD("OR GTX ORDERABLE ITEM"),1)),LOC="" + S OI=+$P($G(^ORD(101.43,+OI,0)),U,2) ;PSOI + S Y=$$RESOLVE^PSJORPOE(PAT,SCH,OI,START,LOC),X=$P(Y,U,2) ;is referenced by DBIA #3167 + Q + ; +SIGN(DA,WHO,WHEN,HOW,WHAT) ; -- affix ES to order + Q:'$G(DA) S:'$G(WHAT) WHAT=1 + N X S X=$G(^OR(100,DA,8,WHAT,0)) D S2^ORDD100(DA,WHAT) ; kill AS xref + S $P(X,U,4,7)=$G(HOW)_U_$G(WHO)_U_$E($G(WHEN),1,12)_U_$S(HOW=0:DUZ,1:"") + ; S:$G(WHO) $P(X,U,3)=WHO ; reset provider to signer + S ^OR(100,DA,8,WHAT,0)=X + D:$G(HOW)=2 S1^ORDD100(DA,WHAT) ; reset AS xref + Q + ; +SIGSTS(IFN,ACT) ; -- Set SigSts for backdoor orders [Called from ^ORM* rtns] + ; Expects ORNATR, ORVP, ORNP to be defined + Q:'$G(IFN) Q:'$G(ACT) N X,OR0 S OR0=+$P($G(^OR(100,+IFN,8,ACT,0)),U) + S X=$S($$SIGNREQD^ORCACT1(+IFN):$$SIGSTS^ORX1(ORNATR),1:3) + K ^OR(100,"AS",ORVP,9999999-OR0,+IFN,ACT) + S $P(^OR(100,+IFN,8,ACT,0),U,4)=X + I X=2 S ^OR(100,"AS",ORVP,9999999-OR0,+IFN,ACT)="" D NOTIF^ORCSIGN + Q + ; +UNVEIL(IFN) ; -- unveil new order + S $P(^OR(100,IFN,3),U,8)="" + Q + ; +DELETE(ORDER) ; -- delete order [action] + N DIK,DA,DAD + I $P(ORDER,";",2)>1 S DA=+$P(ORDER,";",2),DA(1)=+ORDER,DIK="^OR(100,"_DA(1)_",8," D:DA ^DIK Q + S DAD=+$P($G(^OR(100,+ORDER,3)),U,9) I DAD S DIK="^OR(100,"_DAD_",2,",DA(1)=DAD,DA=+ORDER D ^DIK ; remove link to child from parent + K DA S DA=+ORDER,DIK="^OR(100," D ^DIK ;remove order, text + Q + ; +VERIFY(IFN,DA,TYPE,WHO,WHEN) ; -- order verified + Q:'$G(IFN) Q:'$G(DA) Q:"^N^C^R^"'[(U_$G(TYPE)_U) + N FLD S FLD=$S(TYPE="N":8,TYPE="C":10,1:18) + S:'$G(WHO) WHO=DUZ S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12) + S $P(^OR(100,IFN,8,DA,0),U,FLD,FLD+1)=WHO_U_WHEN + Q + ; +COMP(IFN,WHO,WHEN) ; -- order completed + Q:'$G(IFN) S:'$G(WHO) WHO=DUZ S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12) + D DATES(+IFN,,WHEN),STATUS(+IFN,2) + S $P(^OR(100,+IFN,6),U,6,7)=WHEN_U_WHO + Q + ; +DATES(DA,START,STOP) ; -- Update start/stop dates for order DA + Q:'$G(DA) I $G(START) D + . Q:START=$P(^OR(100,DA,0),U,8) + . D SK^ORDD100,WK^ORDD100,OI2^ORDD100A(DA) + . S $P(^OR(100,DA,0),U,8)=START + . D SS^ORDD100,WS^ORDD100,OI1^ORDD100A(DA) + I $G(STOP) D + . ;Q:STOP=$P(^OR(100,DA,0),U,9) ;ck xref anyway + . D EK^ORDD100A S $P(^OR(100,DA,0),U,9)=STOP D ES^ORDD100A + Q + ; +OC ; -- Save order checks in ORCHECK() in ^OR(100,+ORIFN,9) + Q:'$G(ORIFN) Q:'$D(^OR(100,+ORIFN,0)) K ^OR(100,+ORIFN,9) + N NOW,CNT,CDL,I,OC,OVERIDE S NOW=+$E($$NOW^XLFDT,1,12),CNT=0 + S CDL=0 F S CDL=$O(ORCHECK(+ORIFN,CDL)) Q:CDL'>0 D + . S I=0 F S I=$O(ORCHECK(+ORIFN,CDL,I)) Q:I'>0 D + . . S OC=ORCHECK(+ORIFN,CDL,I) Q:'OC + . . S OVERIDE=$S($G(MODE)="NOTIF":$G(ORCHECK("OK"))_U,CDL=1:$G(ORCHECK("OK"))_U_DUZ,1:U_DUZ)_U_NOW + . . S CNT=CNT+1,^OR(100,+ORIFN,9,"B",+OC,CNT)="" + . . S ^OR(100,+ORIFN,9,CNT,0)=$P(OC,U,1,2)_U_U_OVERIDE,^(1)=$E($P(OC,U,3),1,245) + S:CNT ^OR(100,+ORIFN,9,0)="^100.09PA^"_CNT_U_CNT + Q + ; +VALUE(IFN,ID,INST) ; -- Returns value of prompt by identifier ID + I '$G(IFN)!('$D(^OR(100,+$G(IFN),0)))!($G(ID)="") Q "" + N I,Y S I=0,Y="" S:'$G(INST) INST=1 + F S I=$O(^OR(100,IFN,4.5,"ID",ID,I)) Q:I'>0 I $P($G(^OR(100,IFN,4.5,+I,0)),U,3)=INST S Y=$G(^(1)) Q + Q Y + ; +SC(ORX,ORIFN) ; -- save responses to SC questions + Q:'$G(ORIFN) Q:'$D(^OR(100,+ORIFN,0)) ;invalid order number + N OR5,I,P S OR5=$G(^OR(100,+ORIFN,5)),P=0 + F I="SC","MST","AO","IR","EC","HNC","CV" S P=P+1 S:$D(ORX(I)) $P(OR5,U,P)=ORX(I) + S ^OR(100,+ORIFN,5)=OR5 + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCSEND.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCSEND.m index 17c0c082..bbda13db 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCSEND.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCSEND.m @@ -1,180 +1,176 @@ -ORCSEND ;SLC/MKB-Release orders ; 11/8/2006 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,27,45,79,92,141,165,195,243**;Dec 17, 1997;Build 242 - ; -EN(ORIFN,ACTION,SIGSTS,RELSTS,NATURE,REASON,ORERR) ; -- Release [actions on] orders - N ORDA,ORNOW,SIGNREQD,SIGNED,SIGNER - S SIGNREQD=+$P($G(^OR(100,+ORIFN,0)),U,16),ORERR="" - S SIGNED=$S(SIGSTS=2:0,1:1),SIGNER=$S(SIGSTS=1:DUZ,SIGSTS=7:DUZ,1:"") - S ORDA=+$P(ORIFN,";",2),ORIFN=+ORIFN,ORNOW=+$E($$NOW^XLFDT,1,12) - S:"ES"[$G(ACTION) ACTION=$P($G(^OR(100,ORIFN,8,ORDA,0)),U,2) - I SIGNREQD,ORDA,"^NW^RW^XX^RN^DC^HD^RL^"[(U_ACTION_U) D ; sign/alert - . I 'SIGNED D NOTIF^ORCSIGN Q - . D:SIGSTS'="" SIGN^ORCSAVE2(ORIFN,SIGNER,ORNOW,SIGSTS,ORDA) - . D:SIGSTS=4 CHART^ORCSIGN ; not used anymore - I '$L(ACTION) S ORERR="1^Invalid order action" Q - I $$READY(ORIFN,ORDA) D:$L($T(@ACTION)) @ACTION I 'ORERR,ACTION="NW" D - . N OREVT S OREVT=+$P($G(^OR(100,ORIFN,0)),U,17) Q:OREVT<1 - . I '$$EVTORDER^OREVNTX(ORIFN) D SAVE^ORMEVNT1(ORIFN,OREVT,2,"ES") - ; If order originated from the back door, send Dx and TxF back to ancil. - I SIGNED,$P($G(^OR(100,+ORIFN,3)),U,11)="P" D BDOEDIT^ORWDBA7 - Q - ; -EN1(ORDER,ORERR) ; -- Delayed Release [from RELEASE^ORMEVNT] - ; - Q:$P($G(^OR(100,+ORDER,3)),U,3)'=10 - N ORPKG,ORA0,ORNOW,ORIFN,ORDA,ORNP,ORNATR,ORQUIT,ORDUZ,SIGSTS,RELSTS - S ORPKG=$P($G(^OR(100,+ORDER,0)),U,14),ORA0=$G(^(8,1,0)) - S ORNOW=+$E($$NOW^XLFDT,1,12),ORIFN=+ORDER,ORDA=1,ORNP=$P(ORA0,U,3) - S SIGSTS=$P(ORA0,U,4),ORNATR=$P($G(^ORD(100.02,+$P(ORA0,U,12),0)),U,2) - S RELSTS=$S(SIGSTS'=2:1,"^V^P^"[(U_ORNATR_U):1,1:0) I RELSTS D - . D STARTDT^ORCSAVE2(ORIFN),PKGSTUFF^ORCSEND1(ORPKG) Q:$G(ORQUIT) - . S ORDUZ=$S(SIGSTS=0:$P(ORA0,U,7),SIGSTS=1:$P(ORA0,U,5),SIGSTS=2:$P(ORA0,U,17),SIGSTS=3:$P(ORA0,U,13),1:DUZ) - . D RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,ORDUZ),NEW^ORMBLD(ORIFN) - . I "^10^13^"[(U_$P($G(^OR(100,ORIFN,3)),U,3)_U) S ORERR=1 ;error - I 'RELSTS!$G(ORERR),$P($G(^OR(100,ORIFN,3)),U,3)=10 D STATUS^ORCSAVE2(ORIFN,11) S $P(^OR(100,ORIFN,8,1,0),U,15)=11 - Q - ; -EN2(ORIFN,SIGSTS,NATURE,ORERR) ; -- Manual Release [from OREVNT1,SENDED^ORWDX] - N ORDA,ORNOW,OREVT,ORA0,ORNP,SIGNREQD,SIGNED,RELSTS - S ORDA=+$P(ORIFN,";",2),ORIFN=+ORIFN S:ORDA<1 ORDA=1 - S OREVT=+$P($G(^OR(100,ORIFN,0)),U,17),ORA0=$G(^(8,ORDA,0)) - S ORNP=$P(ORA0,U,3),SIGNREQD=($P(ORA0,U,4)'=3),(SIGNED,RELSTS)=1 - S ORNOW=+$E($$NOW^XLFDT,1,12),ORERR="" I $P(ORA0,U,4)=2 D ;needs ES - . N SIGNER S SIGNER=$S(SIGSTS=1:DUZ,1:"") - . I SIGSTS=2 D NOTIF^ORCSIGN S SIGNED=0 Q ;still unsigned - . D:SIGSTS'="" SIGN^ORCSAVE2(ORIFN,SIGNER,ORNOW,SIGSTS,ORDA) - D NW I 'ORERR D SAVE^ORMEVNT1(+ORIFN,OREVT,2,"MN") - Q - ; -NW ; -- New order ORIFN -RW ; -- Rewritten order ORIFN -XX ; -- Changed order ORIFN -RN ; -- Renewed order ORIFN - N ORQUIT,STS,TYPE,OR0,OR3,CODE,ORIG,ORSAVE - N IVDIEN,IVPKGM - S IVPKGM=0 - S IVDIEN=$O(^ORD(101.41,"B","PSJI OR PAT FLUID OE","")) - I SIGNREQD,'SIGNED,'RELSTS S ORERR=$$NEEDSIG,OREBUILD=1 Q - S:'ORDA ORDA=1 S ORSAVE=ORIFN - S OR0=$G(^OR(100,ORIFN,0)),OR3=$G(^(3)) D STARTDT^ORCSAVE2(ORIFN) - S TYPE=$P(OR3,U,11),ORIG=+$P(OR3,U,5),CODE="NW" - I TYPE=1,ORIG,$D(^OR(100,ORIG,4)) S CODE="XO",^OR(100,ORIG,6)=$O(^ORD(100.02,"C","C",0))_U_DUZ_U_ORNOW - I $$GET1^DIQ(9.4,+$P(OR0,U,14)_",",1)="PSJ" S IVPKGM=1 - I IVPKGM=1,$P($P(OR0,U,5),";")=IVDIEN D PSJI^ORCSEND3 Q:$G(ORQUIT) - I IVPKGM=0!($P($P(OR0,U,5),";")'=IVDIEN) D PKGSTUFF^ORCSEND1(+$P(OR0,U,14)) Q:$G(ORQUIT) - D RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,DUZ,$G(NATURE)) - D NEW^ORMBLD(ORIFN,CODE) S ORIFN=ORSAVE,STS=$P($G(^OR(100,ORIFN,3)),U,3) - I (STS=1)!(STS=13) S ORERR="1^"_$$WHY(ORIFN,1) D:'SIGNED&SIGNREQD NOSIG K:ORIG ^OR(100,ORIG,6) - I STS=11 S ORERR="1^ERROR" - Q - ; -DC ; -- DC order ORIFN - N PKG,CODE,ORCHLD,ORCHDA,STS,ORIDA,ORSAVE,OR3,OR6,DCNATURE - I '$G(REASON),$G(NATURE)="D" S REASON=+$O(^ORD(100.03,"C","ORDUP",0)) - S:$G(REASON) $P(^OR(100,ORIFN,6),U,1,5)=$S($G(NATURE):NATURE,$L($G(NATURE)):$O(^ORD(100.02,"C",NATURE,0)),1:"")_"^^^"_+REASON_U_$P(^ORD(100.03,+REASON,0),U) - I SIGNREQD,'SIGNED,'RELSTS S ORERR=$$NEEDSIG Q - S $P(^OR(100,ORIFN,6),U,2,3)=$S($G(DGPMT):"",1:DUZ)_U_ORNOW,ORSAVE=ORIFN S:'$G(REASON) REASON=$P(^(6),U,4) - S STS=$P($G(^OR(100,ORIFN,3)),U,3),PKG=$P($G(^(0)),U,14),PKG=$$NMSP^ORCD(PKG),CODE=$S(PKG="LR":"CA",(PKG="PS")&(STS=5):"CA",(PKG="FH")&(STS=8):"CA",1:"DC") - D:ORDA RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,DUZ,$G(NATURE)) -DC1 I $O(^OR(100,ORIFN,2,0)) D G DC2 ; DC children - . S ORCHLD=0 F S ORCHLD=$O(^OR(100,ORIFN,2,ORCHLD)) Q:ORCHLD'>0 I $$VALID^ORCACT0(ORCHLD,"DC") D Q:$G(ORERR) - . . S ORCHDA=$S(ORDA:$$ACTION^ORCSAVE("DC",ORCHLD,ORNP),1:0) - . . D:ORCHDA SIGN^ORCSAVE2(ORCHLD,,,8,ORCHDA) ;Sig on Parent only - . . D MSG^ORMBLD((ORCHLD_";"_ORCHDA),CODE,$G(REASON)) - . . I "^1^13^"'[(U_$P(^OR(100,ORCHLD,3),U,3)_U) S ORERR="1^"_$$WHY(ORCHLD,ORCHDA) - . ;D:'$G(ORERR) STATUS^ORCSAVE2(ORIFN,1) - . S:$G(ORERR) ^OR(100,ORIFN,8,ORDA,1)=$P(ORERR,U,2) - D MSG^ORMBLD((ORIFN_";"_ORDA),CODE,$G(REASON)) -DC2 S ORIFN=ORSAVE,OR3=$G(^OR(100,ORIFN,3)),STS=$P(OR3,U,3) - S OR6=$G(^OR(100,ORIFN,6)) - I STS'=1,STS'=13,STS'=2 D Q - . S ORERR="1^"_$S(ORDA:$$WHY(ORIFN,ORDA),1:"Unable to discontinue") - . I ORDA,'SIGNED&SIGNREQD D NOSIG ; sig no longer reqd - . K ^OR(100,ORIFN,6) - S DCNATURE=$S(+OR6:+OR6,1:$G(NATURE)) - S $P(^OR(100,ORIFN,3),U,7)=$S('$$ACTV^ORX1($G(DCNATURE)):0,1:$P(OR3,U,7)) - D CANCEL(ORIFN),SETALL^ORDD100(ORIFN) - I $P(OR3,U,11)=2 D ; dc a renewal - . N ORIG,ORIG3,NATR S ORIG=$P(OR3,U,5),ORIG3=$G(^OR(100,ORIG,3)) Q:'ORIG - . ;I CODE="CA",+$P(OR6,U,9)'>0 S $P(^OR(100,ORIG,3),U,6)="" Q ;pend - remove fwd ptr - . I +$P(OR6,U,9)'>0 S $P(^OR(100,ORIG,3),U,6)="" Q ;pend - remove fwd ptr - . Q:"^1^7^12^13^"[(U_$P(ORIG3,U,3)_U) S NATR=$O(^ORD(100.02,"C","A",0)) - . S ^OR(100,ORIG,6)=NATR_U_DUZ_U_ORNOW_"^^Renewal cancelled" - . D MSG^ORMBLD(ORIG,"DC") I "^1^13^"'[$P(^OR(100,ORIG,3),U,3) K ^(6) Q - . S:'$$ACTV^ORX1(NATR) $P(^OR(100,ORIG,3),U,7)=0 - Q - ; -CANCEL(IFN) ; -- Cancel any outstanding actions for order IFN - N I S I=0 - F S I=$O(^OR(100,IFN,8,I)) Q:I'>0 I $P(^(I,0),U,15)=11 S $P(^(0),U,15)=13 D:$P(^(0),U,4)=2 SIGN^ORCSAVE2(IFN,"","",5,I) ; cancelled, sig not reqd now - Q - ; -HD ; -- Hold order ORIFN - N STS,ORSAVE I 'ORDA S ORERR="1^Unable to hold" Q - I SIGNREQD,'SIGNED,'RELSTS S ORERR=$$NEEDSIG Q - D RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,DUZ,$G(NATURE)) - S ORSAVE=ORIFN D MSG^ORMBLD((ORIFN_";"_ORDA),"HD") S ORIFN=ORSAVE - S STS=$P($G(^OR(100,ORIFN,3)),U,3) I STS=3 S $P(^(3),U,7)=ORDA D SET^ORDD100(ORIFN,ORDA) - I STS'=3 S ORERR="1^"_$$WHY(ORIFN,ORDA) D:'SIGNED&SIGNREQD NOSIG - Q - ; -RL ; -- Release hold on order ORIFN - N STS,ORSAVE,ORHD I 'ORDA S ORERR="1^Unable to release hold" Q - I SIGNREQD,'SIGNED,'RELSTS S ORERR=$$NEEDSIG Q - D RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,DUZ,$G(NATURE)) - S ORSAVE=ORIFN D MSG^ORMBLD((ORIFN_";"_ORDA),"RL") S ORIFN=ORSAVE - S STS=$P($G(^OR(100,ORIFN,3)),U,3),ORHD=+$P($G(^(3)),U,7) - I STS'=3 S $P(^OR(100,ORIFN,3),U,7)=ORDA,$P(^(8,ORHD,2),U,1,2)=ORNOW_U_DUZ D SET^ORDD100(ORIFN,ORDA) - I STS=3 S ORERR="1^"_$$WHY(ORIFN,ORDA) D:'SIGNED&SIGNREQD NOSIG - Q - ; -FL ; -- Flag order ORIFN - Q - ; -UF ; -- Unflag order ORIFN - Q - ; -CM ; -- Add Ward comments to order ORIFN - Q - ; -VR ; -- Verify order ORIFN - I 'ORDA!(SIGSTS=2) S ORERR="1^Unable to verify" Q - I "^N^C^R^"'[(U_$G(ORVER)_U) S ORERR="1^Unable to verify" Q - D VERIFY^ORCSAVE2(ORIFN,ORDA,ORVER,DUZ,ORNOW) - ; -- send HL7 msg to Pharmacy if Nurse-Verified, [Sts=pending] - Q:ORVER'="N" N ORSTS,ORPKG,ORX - S ORX=$P($G(^OR(100,ORIFN,8,ORDA,0)),U,2) Q:ORX'="NW"&(ORX'="XX") - S ORPKG=+$P($G(^OR(100,ORIFN,0)),U,14),ORSTS=$P($G(^(3)),U,3) - ;I ORSTS=5!$L($T(ZV^ORMPS)),$$NMSP^ORCD(ORPKG)="PS" D VER^ORMBLDPS(ORIFN) - I $$NMSP^ORCD(ORPKG)="PS" D VER^ORMBLDPS(ORIFN) - Q - ; -NEEDSIG() ; -- Msg - Q "1^This order requires a signature." - ; -WHY(IFN,DA) ; -- Return reason request was rejected - N X S X=$G(^OR(100,IFN,8,DA,1)) - S:'$L(X) X="Unable to "_$S(ACTION="HD":"hold",ACTION="RL":"release hold",ACTION="DC":"discontinue",ACTION="XX":"change",ACTION="RN":"renew",1:"release") - Q X - ; -NOSIG ; -- Mark order as Sig not Req'd due to cancel/reject - D SIGN^ORCSAVE2(ORIFN,"","",5,ORDA) S SIGNREQD=0 - Q - ; -READY(IFN,ACT) ; -- Ready to release? - N X,Y,OR0,OR3,ORA - I ACTION="VR" S Y=1 G RQ ; no action to release - I 'ACT,ACTION="DC" S Y=1 G RQ ; cancel a duplicate - S Y=0,OR0=$G(^OR(100,IFN,0)),OR3=$G(^(3)),ORA=$G(^(8,ACT,0)) - I $P(ORA,U,15)=11 S Y=1 G RQ ; unreleased - I $P(ORA,U,15)=10 D G RQ ; delayed - . I $G(^DPT(+ORVP,.105)),$$GET1^DIQ(9.4,+$P(OR0,U,14)_",",1)="PSO" S Y=1 Q - . Q:'RELSTS N ORIG S ORIG=+$P(OR3,U,5) - . I 'SIGNED,$L($G(NATURE)) S $P(ORA,U,17)=DUZ,$P(ORA,U,12)=$S(NATURE:NATURE,1:+$O(^ORD(100.02,"C",NATURE,0))),^OR(100,IFN,8,ACT,0)=ORA - . Q:$P(OR3,U,11)'=1!('ORIG) ;dc original if signed edit - . D STATUS^ORCSAVE2(ORIG,12) - . S ^OR(100,ORIG,6)=+$O(^ORD(100.02,"C","C",0))_U_DUZ_U_ORNOW - . S $P(^OR(100,ORIG,3),U,7)=0,$P(^(8,1,0),U,15)=12 D:$P($G(^(0)),U,4)=2 SIGN^ORCSAVE2(ORIG,,,5,1) - I $P(OR3,U,3)=11,$P(ORA,U,2)="NW" S Y=1 ; Action Sts = "" (old) -RQ I +$$SWSTAT^IBBAPI() D:Y=1 EN^ORWPFSS4(+IFN) ; Associate PFSS Account Reference with order, Patch OR*3.0*228 IA #4663 - Q Y +ORCSEND ;SLC/MKB-Release orders ; 08 May 2002 2:12 PM + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,27,45,79,92,141,165,195,228**;Dec 17, 1997 + ; +EN(ORIFN,ACTION,SIGSTS,RELSTS,NATURE,REASON,ORERR) ; -- Release [actions on] orders + N ORDA,ORNOW,SIGNREQD,SIGNED,SIGNER + S SIGNREQD=+$P($G(^OR(100,+ORIFN,0)),U,16),ORERR="" + S SIGNED=$S(SIGSTS=2:0,1:1),SIGNER=$S(SIGSTS=1:DUZ,SIGSTS=7:DUZ,1:"") + S ORDA=+$P(ORIFN,";",2),ORIFN=+ORIFN,ORNOW=+$E($$NOW^XLFDT,1,12) + S:"ES"[$G(ACTION) ACTION=$P($G(^OR(100,ORIFN,8,ORDA,0)),U,2) + I SIGNREQD,ORDA,"^NW^RW^XX^RN^DC^HD^RL^"[(U_ACTION_U) D ; sign/alert + . I 'SIGNED D NOTIF^ORCSIGN Q + . D:SIGSTS'="" SIGN^ORCSAVE2(ORIFN,SIGNER,ORNOW,SIGSTS,ORDA) + . D:SIGSTS=4 CHART^ORCSIGN ; not used anymore + I '$L(ACTION) S ORERR="1^Invalid order action" Q + I $$READY(ORIFN,ORDA) D:$L($T(@ACTION)) @ACTION I 'ORERR,ACTION="NW" D + . N OREVT S OREVT=+$P($G(^OR(100,ORIFN,0)),U,17) Q:OREVT<1 + . I '$$EVTORDER^OREVNTX(ORIFN) D SAVE^ORMEVNT1(ORIFN,OREVT,2,"ES") + ; If order originated from the back door, send Dx and TxF back to ancil. + I SIGNED,$P($G(^OR(100,+ORIFN,3)),U,11)="P" D BDOEDIT^ORWDBA7 + Q + ; +EN1(ORDER,ORERR) ; -- Delayed Release [from RELEASE^ORMEVNT] + ; + Q:$P($G(^OR(100,+ORDER,3)),U,3)'=10 + N ORPKG,ORA0,ORNOW,ORIFN,ORDA,ORNP,ORNATR,ORQUIT,ORDUZ,SIGSTS,RELSTS + S ORPKG=$P($G(^OR(100,+ORDER,0)),U,14),ORA0=$G(^(8,1,0)) + S ORNOW=+$E($$NOW^XLFDT,1,12),ORIFN=+ORDER,ORDA=1,ORNP=$P(ORA0,U,3) + S SIGSTS=$P(ORA0,U,4),ORNATR=$P($G(^ORD(100.02,+$P(ORA0,U,12),0)),U,2) + S RELSTS=$S(SIGSTS'=2:1,"^V^P^"[(U_ORNATR_U):1,1:0) + I RELSTS D + . D STARTDT^ORCSAVE2(ORIFN),PKGSTUFF^ORCSEND1(ORPKG) Q:$G(ORQUIT) + . S ORDUZ=$S(SIGSTS=0:$P(ORA0,U,7),SIGSTS=1:$P(ORA0,U,5),SIGSTS=2:$P(ORA0,U,17),SIGSTS=3:$P(ORA0,U,13),1:DUZ) + . D EDO1^ORWPFSS1 ;PFSS Event Delayed Orders + . D RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,ORDUZ),NEW^ORMBLD(ORIFN) + . I "^10^13^"[(U_$P($G(^OR(100,ORIFN,3)),U,3)_U) S ORERR=1 ;error + I 'RELSTS!$G(ORERR),$P($G(^OR(100,ORIFN,3)),U,3)=10 D STATUS^ORCSAVE2(ORIFN,11) S $P(^OR(100,ORIFN,8,1,0),U,15)=11 + Q + ; +EN2(ORIFN,SIGSTS,NATURE,ORERR) ; -- Manual Release [from OREVNT1,SENDED^ORWDX] + N ORDA,ORNOW,OREVT,ORA0,ORNP,SIGNREQD,SIGNED,RELSTS + S ORDA=+$P(ORIFN,";",2),ORIFN=+ORIFN S:ORDA<1 ORDA=1 + S OREVT=+$P($G(^OR(100,ORIFN,0)),U,17),ORA0=$G(^(8,ORDA,0)) + S ORNP=$P(ORA0,U,3),SIGNREQD=($P(ORA0,U,4)'=3),(SIGNED,RELSTS)=1 + S ORNOW=+$E($$NOW^XLFDT,1,12),ORERR="" + I $P(ORA0,U,4)=2 D ;needs ES + . N SIGNER S SIGNER=$S(SIGSTS=1:DUZ,1:"") + . I SIGSTS=2 D NOTIF^ORCSIGN S SIGNED=0 Q ;still unsigned + . D:SIGSTS'="" SIGN^ORCSAVE2(ORIFN,SIGNER,ORNOW,SIGSTS,ORDA) + D EDO2^ORWPFSS1 ;PFSS Event Delayed Orders + D NW I 'ORERR D SAVE^ORMEVNT1(+ORIFN,OREVT,2,"MN") + Q + ; +NW ; -- New order ORIFN +RW ; -- Rewritten order ORIFN +XX ; -- Changed order ORIFN +RN ; -- Renewed order ORIFN + N ORQUIT,STS,TYPE,OR0,OR3,CODE,ORIG,ORSAVE + I SIGNREQD,'SIGNED,'RELSTS S ORERR=$$NEEDSIG,OREBUILD=1 Q + S:'ORDA ORDA=1 S ORSAVE=ORIFN + S OR0=$G(^OR(100,ORIFN,0)),OR3=$G(^(3)) D STARTDT^ORCSAVE2(ORIFN) + S TYPE=$P(OR3,U,11),ORIG=+$P(OR3,U,5),CODE="NW" + I TYPE=1,ORIG,$D(^OR(100,ORIG,4)) S CODE="XO",^OR(100,ORIG,6)=$O(^ORD(100.02,"C","C",0))_U_DUZ_U_ORNOW + D PKGSTUFF^ORCSEND1(+$P(OR0,U,14)) Q:$G(ORQUIT) + D RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,DUZ,$G(NATURE)) + D NEW^ORMBLD(ORIFN,CODE) S ORIFN=ORSAVE,STS=$P($G(^OR(100,ORIFN,3)),U,3) + I (STS=1)!(STS=13) S ORERR="1^"_$$WHY(ORIFN,1) D:'SIGNED&SIGNREQD NOSIG K:ORIG ^OR(100,ORIG,6) + I STS=11 S ORERR="1^ERROR" + Q + ; +DC ; -- DC order ORIFN + N PKG,CODE,ORCHLD,ORCHDA,STS,ORIDA,ORSAVE,OR3 + I '$G(REASON),$G(NATURE)="D" S REASON=+$O(^ORD(100.03,"C","ORDUP",0)) + S:$G(REASON) ^OR(100,ORIFN,6)=$S($G(NATURE):NATURE,$L($G(NATURE)):$O(^ORD(100.02,"C",NATURE,0)),1:"")_"^^^"_+REASON_U_$P(^ORD(100.03,+REASON,0),U) + I SIGNREQD,'SIGNED,'RELSTS S ORERR=$$NEEDSIG Q + S $P(^OR(100,ORIFN,6),U,2,3)=$S($G(DGPMT):"",1:DUZ)_U_ORNOW,ORSAVE=ORIFN S:'$G(REASON) REASON=$P(^(6),U,4) + S STS=$P($G(^OR(100,ORIFN,3)),U,3),PKG=$P($G(^(0)),U,14),PKG=$$NMSP^ORCD(PKG),CODE=$S(PKG="LR":"CA",(PKG="PS")&(STS=5):"CA",(PKG="FH")&(STS=8):"CA",1:"DC") + D:ORDA RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,DUZ,$G(NATURE)) +DC1 I $O(^OR(100,ORIFN,2,0)) D G DC2 ; DC children + . S ORCHLD=0 F S ORCHLD=$O(^OR(100,ORIFN,2,ORCHLD)) Q:ORCHLD'>0 I $$VALID^ORCACT0(ORCHLD,"DC") D Q:$G(ORERR) + . . S ORCHDA=$S(ORDA:$$ACTION^ORCSAVE("DC",ORCHLD,ORNP),1:0) + . . D:ORCHDA SIGN^ORCSAVE2(ORCHLD,,,"",ORCHDA) ;Sig on Parent only + . . D MSG^ORMBLD((ORCHLD_";"_ORCHDA),CODE,$G(REASON)) + . . I "^1^13^"'[(U_$P(^OR(100,ORCHLD,3),U,3)_U) S ORERR="1^"_$$WHY(ORCHLD,ORCHDA) + . ;D:'$G(ORERR) STATUS^ORCSAVE2(ORIFN,1) + . S:$G(ORERR) ^OR(100,ORIFN,8,ORDA,1)=$P(ORERR,U,2) + D MSG^ORMBLD((ORIFN_";"_ORDA),CODE,$G(REASON)) +DC2 S ORIFN=ORSAVE,OR3=$G(^OR(100,ORIFN,3)),STS=$P(OR3,U,3) + I STS'=1,STS'=13,STS'=2 D Q + . S ORERR="1^"_$S(ORDA:$$WHY(ORIFN,ORDA),1:"Unable to discontinue") + . I ORDA,'SIGNED&SIGNREQD D NOSIG ; sig no longer reqd + . K ^OR(100,ORIFN,6) + S $P(^OR(100,ORIFN,3),U,7)=$S(ORDA:ORDA,'$$ACTV^ORX1($G(NATURE)):0,1:$P(OR3,U,7)) + D CANCEL(ORIFN),SETALL^ORDD100(ORIFN) + I $P(OR3,U,11)=2 D ; dc a renewal + . N ORIG,ORIG3,NATR S ORIG=$P(OR3,U,5),ORIG3=$G(^OR(100,ORIG,3)) Q:'ORIG + . I CODE="CA" S $P(^OR(100,ORIG,3),U,6)="" Q ;pend - remove fwd ptr + . Q:"^1^7^12^13^"[(U_$P(ORIG3,U,3)_U) S NATR=$O(^ORD(100.02,"C","A",0)) + . S ^OR(100,ORIG,6)=NATR_U_DUZ_U_ORNOW_"^^Renewal cancelled" + . D MSG^ORMBLD(ORIG,"DC") I "^1^13^"'[$P(^OR(100,ORIG,3),U,3) K ^(6) Q + . S:'$$ACTV^ORX1(NATR) $P(^OR(100,ORIG,3),U,7)=0 + Q + ; +CANCEL(IFN) ; -- Cancel any outstanding actions for order IFN + N I S I=0 + F S I=$O(^OR(100,IFN,8,I)) Q:I'>0 I $P(^(I,0),U,15)=11 S $P(^(0),U,15)=13 D:$P(^(0),U,4)=2 SIGN^ORCSAVE2(IFN,"","",5,I) ; cancelled, sig not reqd now + Q + ; +HD ; -- Hold order ORIFN + N STS,ORSAVE I 'ORDA S ORERR="1^Unable to hold" Q + I SIGNREQD,'SIGNED,'RELSTS S ORERR=$$NEEDSIG Q + D RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,DUZ,$G(NATURE)) + S ORSAVE=ORIFN D MSG^ORMBLD((ORIFN_";"_ORDA),"HD") S ORIFN=ORSAVE + S STS=$P($G(^OR(100,ORIFN,3)),U,3) I STS=3 S $P(^(3),U,7)=ORDA D SET^ORDD100(ORIFN,ORDA) + I STS'=3 S ORERR="1^"_$$WHY(ORIFN,ORDA) D:'SIGNED&SIGNREQD NOSIG + Q + ; +RL ; -- Release hold on order ORIFN + N STS,ORSAVE,ORHD I 'ORDA S ORERR="1^Unable to release hold" Q + I SIGNREQD,'SIGNED,'RELSTS S ORERR=$$NEEDSIG Q + D RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,DUZ,$G(NATURE)) + S ORSAVE=ORIFN D MSG^ORMBLD((ORIFN_";"_ORDA),"RL") S ORIFN=ORSAVE + S STS=$P($G(^OR(100,ORIFN,3)),U,3),ORHD=+$P($G(^(3)),U,7) + I STS'=3 S $P(^OR(100,ORIFN,3),U,7)=ORDA,$P(^(8,ORHD,2),U,1,2)=ORNOW_U_DUZ D SET^ORDD100(ORIFN,ORDA) + I STS=3 S ORERR="1^"_$$WHY(ORIFN,ORDA) D:'SIGNED&SIGNREQD NOSIG + Q + ; +FL ; -- Flag order ORIFN + Q + ; +UF ; -- Unflag order ORIFN + Q + ; +CM ; -- Add Ward comments to order ORIFN + Q + ; +VR ; -- Verify order ORIFN + I 'ORDA!(SIGSTS=2) S ORERR="1^Unable to verify" Q + I "^N^C^R^"'[(U_$G(ORVER)_U) S ORERR="1^Unable to verify" Q + D VERIFY^ORCSAVE2(ORIFN,ORDA,ORVER,DUZ,ORNOW) + ; -- send HL7 msg to Pharmacy if Nurse-Verified, [Sts=pending] + Q:ORVER'="N" N ORSTS,ORPKG,ORX + S ORX=$P($G(^OR(100,ORIFN,8,ORDA,0)),U,2) Q:ORX'="NW"&(ORX'="XX") + S ORPKG=+$P($G(^OR(100,ORIFN,0)),U,14),ORSTS=$P($G(^(3)),U,3) + ;I ORSTS=5!$L($T(ZV^ORMPS)),$$NMSP^ORCD(ORPKG)="PS" D VER^ORMBLDPS(ORIFN) + I $$NMSP^ORCD(ORPKG)="PS" D VER^ORMBLDPS(ORIFN) + Q + ; +NEEDSIG() ; -- Msg + Q "1^This order requires a signature." + ; +WHY(IFN,DA) ; -- Return reason request was rejected + N X S X=$G(^OR(100,IFN,8,DA,1)) + S:'$L(X) X="Unable to "_$S(ACTION="HD":"hold",ACTION="RL":"release hold",ACTION="DC":"discontinue",ACTION="XX":"change",ACTION="RN":"renew",1:"release") + Q X + ; +NOSIG ; -- Mark order as Sig not Req'd due to cancel/reject + D SIGN^ORCSAVE2(ORIFN,"","",5,ORDA) S SIGNREQD=0 + Q + ; +READY(IFN,ACT) ; -- Ready to release? + N X,Y,OR0,OR3,ORA + I ACTION="VR" S Y=1 G RQ ; no action to release + I 'ACT,ACTION="DC" S Y=1 G RQ ; cancel a duplicate + S Y=0,OR0=$G(^OR(100,IFN,0)),OR3=$G(^(3)),ORA=$G(^(8,ACT,0)) + I $P(ORA,U,15)=11 S Y=1 G RQ ; unreleased + I $P(ORA,U,15)=10 D G RQ ; delayed + . I $G(^DPT(+ORVP,.105)),$$GET1^DIQ(9.4,+$P(OR0,U,14)_",",1)="PSO" S Y=1 Q + . Q:'RELSTS N ORIG S ORIG=+$P(OR3,U,5) + . I 'SIGNED,$L($G(NATURE)) S $P(ORA,U,17)=DUZ,$P(ORA,U,12)=$S(NATURE:NATURE,1:+$O(^ORD(100.02,"C",NATURE,0))),^OR(100,IFN,8,ACT,0)=ORA + . Q:$P(OR3,U,11)'=1!('ORIG) ;dc original if signed edit + . D STATUS^ORCSAVE2(ORIG,12) + . S ^OR(100,ORIG,6)=+$O(^ORD(100.02,"C","C",0))_U_DUZ_U_ORNOW + . S $P(^OR(100,ORIG,3),U,7)=0,$P(^(8,1,0),U,15)=12 D:$P($G(^(0)),U,4)=2 SIGN^ORCSAVE2(ORIG,,,5,1) + I $P(OR3,U,3)=11,$P(ORA,U,2)="NW" S Y=1 ; Action Sts = "" (old) +RQ I Y=1 D EN^ORWPFSS4(+IFN) ; Associate PFSS Account Reference with order, Patch OR*3.0*228 + Q Y diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCSEND1.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCSEND1.m index 29d625e4..763ff7a2 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCSEND1.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCSEND1.m @@ -1,179 +1,189 @@ -ORCSEND1 ;SLC/MKB-Release cont ;11/22/06 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,29,45,61,79,94,116,138,158,149,187,215,243**;Dec 17, 1997;Build 242 - ; -PKGSTUFF(PKG) ; Package code - S PKG=$$GET1^DIQ(9.4,+PKG_",",1) Q:'$L(PKG) - D:$L($T(@PKG)) @PKG - Q -LR ; Spawn child orders if continuous schedule - N ORSTRT,ORPARENT,OR0,ORNP,ORDIALOG,ORL,ORX,ORTIME,ORPITEM,ORPSAMP,ORPSPEC,ORPURG,ORPCOMM,ORPTYPE,ORPCOLL,ORS1,ORS2,P,ORCHLD,ORDG,ORLAST,ORDUZ,ORLOG,ORCOLLCT,STS - S ORPARENT=+ORIFN,OR0=$G(^OR(100,ORIFN,0)),ORL=$P(OR0,U,10) - D SCHEDULE(ORIFN,"LR",.ORSTRT) I ORSTRT'>1 D Q - . N START S START=$O(ORSTRT(0)) Q:START=$P($G(^OR(100,+ORIFN,0)),U,8) - . D DATES^ORCSAVE2(+ORIFN,START) ;update start date from schedule - S ORNP=+$P(OR0,U,4),ORDIALOG=+$P(OR0,U,5),ORDUZ=+$P(OR0,U,6),ORLOG=$P(OR0,U,7),ORDG=+$P(OR0,U,11) - D GETDLG1^ORCD(ORDIALOG),GETORDER(ORIFN),GETIMES^ORCDLR1 - K ORDIALOG($$PTR^ORCD("OR GTX ADMIN SCHEDULE"),1),ORDIALOG($$PTR^ORCD("OR GTX DURATION"),1) - S ORPITEM=$$PTR^ORCD("OR GTX ORDERABLE ITEM") - S ORPSAMP=$$PTR^ORCD("OR GTX COLLECTION SAMPLE") - S ORPSPEC=$$PTR^ORCD("OR GTX SPECIMEN") - S ORPURG=$$PTR^ORCD("OR GTX LAB URGENCY") - S ORPCOMM=$$PTR^ORCD("OR GTX WORD PROCESSING 1") - S ORPTYPE=$$PTR^ORCD("OR GTX COLLECTION TYPE") - S ORPCOLL=$$PTR^ORCD("OR GTX START DATE/TIME") -LR1 S ORS1=0 F S ORS1=$O(ORX(ORS1)) Q:ORS1'>0 D - . F P=ORPITEM,ORPSAMP,ORPSPEC,ORPURG,ORPCOMM,ORPTYPE S ORDIALOG(P,1)=$G(ORX(ORS1,P)) ;set values to next instance - . S ORCOLLCT=$G(ORDIALOG(ORPTYPE,1)) - . S ORS2=0 F S ORS2=$O(ORSTRT(ORS2)) Q:ORS2'>0 D - .. S ORDIALOG(ORPCOLL,1)=ORS2 ;,ORDUZ=DUZ,ORLOG=+$E($$NOW^XLFDT,1,12) - .. I ORCOLLCT="LC" S ORDIALOG(ORPTYPE,1)=$S($$LABCOLL^ORCDLR1(ORS2):"LC",1:"WC") - .. I ORCOLLCT="I" S ORDIALOG(ORPTYPE,1)=$S($$IMMCOLL^ORCDLR1(ORS2):"I",1:"WC") - .. D CHILD^ORCSEND3() - S:$G(ORCHLD) ^OR(100,ORPARENT,2,0)="^100.002PA^"_ORLAST_U_ORCHLD - S ORIFN=ORPARENT,ORQUIT=1,STS=$P(^OR(100,ORIFN,3),U,3) - I (STS=1)!(STS=13)!(STS=11) S ORERR="1^Unable to release orders" - D RELEASE^ORCSAVE2(ORPARENT,1,ORNOW,DUZ,$G(NATURE)) - Q -SCHEDULE(IFN,PKG,ORY,STRT) ; Returns list of start time(s) from schedule - N I,X,PSJSD,PSJFD,PSJW,PSJNE,PSJPP,PSJX,PSJAT,PSJM,PSJTS,PSJY,PSJAX,PSJSCH,PSJOSD,PSJOFD,PSJC,ORDUR - S PSJSD=$S(+$G(STRT):STRT,1:$P($G(^OR(100,+IFN,0)),U,8)) I 'PSJSD S ORY=-1 Q - S ORY=1,ORY(PSJSD)="" ;1st occurrance - S I=$O(^OR(100,+IFN,4.5,"ID","SCHEDULE",0)) Q:'I Q:'$L($G(PKG)) - S X=$G(^OR(100,+IFN,4.5,I,1)),PSJX=$S(X:$$GET1^DIQ(51.1,+X_",",.01),1:X) - S PSJW=+$G(ORL),PSJNE="",PSJPP=PKG D ENSV^PSJEEU Q:'$L($G(PSJX)) - I $G(PSJTS)'="C",$G(PSJTS)'="D" Q ;not continuous or day-of-week - S PSJSCH=PSJX,I=$O(^OR(100,+IFN,4.5,"ID","DAYS",0)) Q:'I - S ORDUR=$G(^OR(100,+IFN,4.5,+I,1)) - S:ORDUR PSJFD=$$FMADD^XLFDT(PSJSD,+ORDUR,,-1) - I 'ORDUR S X=+$E(ORDUR,2,9) D - . I PSJM S PSJFD=$$FMADD^XLFDT(PSJSD,,,(PSJM*X)-1) ;X_#times - . E D ;no freq in minutes --> day of week - .. N DAYS,LOCMX,SCHMX - .. S LOCMX=$$GET^XPAR("ALL^LOC.`"_+ORL,"LR MAX DAYS CONTINUOUS",1,"Q") - .. K ^TMP($J,"ORCSEND1 SCHEDULE") - .. D ZERO^PSS51P1(PSJY,,,,"ORCSEND1 SCHEDULE") - .. S SCHMX=+$G(^TMP($J,"ORCSEND1 SCHEDULE",PSJY,2.5)) - .. K ^TMP($J,"ORCSEND1 SCHEDULE") - .. ;S SCHMX=$P(^PS(51.1,PSJY,0),U,7) - .. S DAYS=$S('SCHMX:LOCMX,LOCMX0 S X=$G(^(I,0)),Y=$G(^(1)) D - . S PTR=+$P(X,U,2),INST=+$P(X,U,3),TYPE=$P($G(^ORD(101.41,PTR,1)),U) - . I TYPE'="W" S ORX(INST,PTR)=Y Q - . S ORX(INST,PTR)="^OR(100,"_IFN_",4.5,"_I_",2)" - Q -PTR(X) ; Returns ptr of prompt X in Order Dialog file - Q +$O(^ORD(101.41,"AB",$E("OR GTX "_X,1,63),0)) -PS ; spawn child orders if multiple doses -PSJ ; (Inpt only) -PSS ; - N ORPARENT,OR0,ORNP,ORDIALOG,ORDUZ,ORLOG,ORL,ORDG,ORCAT,ORX,ORP,ORI,STS - N ORDOSE,ORT,ORSCH,ORDUR,ORSTRT,ORFRST,ORCONJ,ORID,ORDD,ORSTR,ORDGNM - N ORSTART,ORCHLD,ORLAST,ORSIG,OROI,ID,OR3,ORIG,CODE,ORPKG,ORENEW,I,ORADMIN - S ORPARENT=+ORIFN,OR0=$G(^OR(100,ORPARENT,0)),OR3=$G(^(3)) - Q:$P(OR0,U,12)'="I" S ORCAT="I",ORNP=+$P(OR0,U,4) - S ORDIALOG=+$P(OR0,U,5),ORDUZ=+$P(OR0,U,6),ORLOG=$P(OR0,U,7) - S ORL=$P(OR0,U,10),ORDG=+$P(OR0,U,11),ORPKG=+$P(OR0,U,14) - D GETDLG1^ORCD(ORDIALOG),GETORDER(ORPARENT) - S ORDOSE=$$PTR("INSTRUCTIONS"),ORT=$$PTR("ROUTE") - S ORSCH=$$PTR("SCHEDULE"),ORDUR=$$PTR("DURATION") - S ORCONJ=$$PTR("AND/THEN") D STRT S ORSTART=$G(ORSTRT("BEG")) - S ORADMIN=$$PTR("ADMIN TIMES") - D DATES^ORCSAVE2(ORPARENT,ORSTART) Q:$$DOSES(ORPARENT)'>1 - S ORFRST=$$PTR("NOW"),ORSIG=$$PTR("SIG") - S ORID=$$PTR("DOSE"),ORDD=$$PTR("DISPENSE DRUG") - S ORSTR=$$PTR("STRENGTH"),ORDGNM=$$PTR("DRUG NAME") - I $P(OR3,U,11)=2,$O(^OR(100,+$P(OR3,U,5),2,0)) D - . S ORENEW=+$P(OR3,U,5),I=0 - . I $$VALUE^ORX8(ORENEW,"NOW") S I=$O(^OR(100,ORENEW,2,0)) - . F S I=$O(^OR(100,ORENEW,2,I)) Q:I<1 S ORENEW(I)="" -PS1 F ORP="ORDERABLE ITEM","URGENCY","WORD PROCESSING 1" D - . N PTR S PTR=$$PTR(ORP) Q:PTR'>0 Q:'$D(ORX(1,PTR)) - . S ORDIALOG(PTR,1)=ORX(1,PTR) S:$E(ORP)="O" OROI=ORX(1,PTR) - S ORI=$$FRSTDOSE I $G(ORX(1,ORFRST)) D - . F ORP=ORDOSE,ORT,ORID S:$D(ORX(ORI,ORP)) ORDIALOG(ORP,1)=ORX(ORI,ORP) - . S ID=$G(ORX(ORI,ORID)) S:$P(ID,"&",6) ORDIALOG(ORDD,1)=$P(ID,"&",6) - . S ORDIALOG(ORSCH,1)="NOW",ORSTART=$$NOW^XLFDT - . D SIG,CHILD^ORCSEND3(ORSTART) - F D S ORI=$O(ORX(ORI)) Q:ORI'>0 - . F ORP=ORDOSE,ORT,ORSCH,ORDUR,ORID,ORADMIN S:$D(ORX(ORI,ORP)) ORDIALOG(ORP,1)=ORX(ORI,ORP) K:'$D(ORX(ORI,ORP)) ORDIALOG(ORP,1) - . K ORDIALOG(ORDD,1) S ID=$G(ORX(ORI,ORID)) - . S:$P(ID,"&",6) ORDIALOG(ORDD,1)=$P(ID,"&",6) - . S ORSTART=$G(ORSTRT(ORI)) - . D SIG,CHILD^ORCSEND3(ORSTART) - S:$G(ORCHLD) ^OR(100,ORPARENT,2,0)="^100.002PA^"_ORLAST_U_ORCHLD - S ORIFN=ORPARENT,ORQUIT=1,OR3=$G(^OR(100,ORIFN,3)),STS=$P(OR3,U,3) - I (STS=1)!(STS=13)!(STS=11) S ORERR="1^Unable to release orders" - D RELEASE^ORCSAVE2(ORIFN,1,ORNOW,DUZ,$G(NATURE)) K ^TMP("ORWORD",$J) - S $P(^OR(100,ORIFN,3),U,8)=1 ;veil parent order - set stop date/time? - Q:(STS=1)!(STS=13)!(STS=11) ;unsuccessful -PS2 ; ck if parent is unsigned or edit - I $P($G(^OR(100,ORIFN,8,1,0)),U,4)=2 S $P(^(0),U,4)="" K ^OR(100,"AS",ORVP,9999999-ORLOG,ORIFN,1) ;clear ES - Q:$P(OR3,U,11)'=1 S ORIG=$P(OR3,U,5) Q:ORIG'>0 - S CODE=$S($P($G(^OR(100,ORIG,3)),U,3)=5:"CA",1:"DC") - D MSG^ORMBLD(ORIG,CODE) I "^1^13^"[(U_$P($G(^OR(100,ORIG,3)),U,3)_U) D - . N NATR S NATR=+$O(^ORD(100.02,"C","C",0)) - . S $P(^OR(100,ORIG,3),U,3)=12,$P(^(3),U,7)=0,^(6)=NATR_U_DUZ_U_ORNOW - . D CANCEL^ORCSEND(ORIG) ;ck for unrel actions - Q -DOSES(IFN) ; count number of doses in order - N I,CNT S CNT=0 - S I=0 F S I=$O(^OR(100,+$G(IFN),4.5,"ID","INSTR",I)) Q:I'>0 I $L($G(^OR(100,+$G(IFN),4.5,I,1))) S CNT=CNT+1 - S I=+$O(^OR(100,+$G(IFN),4.5,"ID","NOW",0)) I I,$G(^OR(100,+$G(IFN),4.5,I,1)) S CNT=CNT+1 - Q CNT -FRSTDOSE() ; Return instance of first dose - N I,Y S I=0,Y=1 - F S I=$O(ORX(I)) Q:I'>0 I $D(ORX(I,ORDOSE)) S Y=I Q - Q Y -SIG ; Build text of instructions - N ORDRUG,ID,DOSE,ORI,ORX K ^TMP("ORWORD",$J,ORSIG,1) - S ORDRUG=$G(ORDIALOG(ORDD,1)),ID=$G(ORDIALOG(ORID,1)) - S DOSE=$G(ORDIALOG(ORDOSE,1)),ORI=1 - S ORX=$$DOSE^ORCDPS2_$$RTE^ORCDPS2_$$SCH^ORCDPS2_$$DUR^ORCDPS2 - S ^TMP("ORWORD",$J,ORSIG,1,0)="^^1^1^"_DT_U,^(1,0)=ORX - S ORDIALOG(ORSIG,1)=$NA(^TMP("ORWORD",$J,ORSIG,1)) - S ORDIALOG(ORDOSE,"FORMAT")="@" - K ORDIALOG(ORSTR,1),ORDIALOG(ORDGNM,1) - I ORDRUG,'ID D ;set strength or drug name - . N STR,ITM S STR=$P(ID,"&",7)_$P(ID,"&",8) - . I STR'>0 S ORDIALOG(ORDGNM,1)=$$GET1^DIQ(50,+ORDRUG_",",.01) Q - . S ITM=$P($G(^ORD(101.43,+$G(OROI),0)),U) - . S:ITM'[STR ORDIALOG(ORSTR,1)=STR - Q -STRT ; Build ORSTRT(inst)=date.time array of start times by dose - N OI,PSOI,XD,XH,XM,XS,ORWD,ORI,SCH,ORSD,X,ORD K ORSTRT - S OI=$G(ORX(1,$$PTR^ORCD("OR GTX ORDERABLE ITEM"))) - S PSOI=+$P($G(^ORD(101.43,+OI,0)),U,2),(XD,XH,XM,XS)=0 - S ORWD=+$G(^SC(+$G(ORL),42)) ;ward - S ORI=0 F S ORI=$O(ORX(ORI)) Q:ORI<1 D - . S SCH=$G(ORX(ORI,ORSCH)),ORSD="" S:'$L(SCH) X=$$NOW^XLFDT - . S:$L(SCH) ORSD=$$STARTSTP^PSJORPOE(+ORVP,SCH,PSOI,ORWD),X=$P(ORSD,U,4) - . S ORSTRT(ORI)=$$FMADD^XLFDT(X,XD,XH,XM,XS) ;START+OFFSET - . ; update OFFSET for next THEN dose - . D DUR(ORI) I $G(ORX(ORI,ORCONJ))="T" D - .. I $G(ORD("XD"))<1,$G(ORD("XH"))<1,$G(ORD("XM"))<1,$G(ORD("XS"))<1 S ORD("XD")=+$P(ORSD,U,3) ;default duration - .. N I,Y F I="XD","XH","XM","XS" S Y=@I,@I=Y+$G(ORD(I)) - .. K ORD - ; find beginning date.time for parent - S ORI=0,X=9999999 F S ORI=$O(ORSTRT(ORI)) Q:ORI<1 I ORSTRT(ORI)$G(ORD("XS")) S ORD("XS")=+X - I X["'",+X>$G(ORD("XM")) S ORD("XM")=+X - I X["H",+X>$G(ORD("XH")) S ORD("XH")=+X - S Y=$S(X["D":+X,X["W":+X*7,X["M":+X*30,1:0) - I Y,Y>$G(ORD("XD")) S ORD("XD")=Y - Q -VBEC ; Spawn VBECS children - D:$L($T(EN^ORCSEND2)) EN^ORCSEND2 - Q +ORCSEND1 ;SLC/MKB-Release cont ;11/25/02 09:48 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,29,45,61,79,94,116,138,158,149,187,215**;Dec 17, 1997 + ; +PKGSTUFF(PKG) ; Package code + S PKG=$$GET1^DIQ(9.4,+PKG_",",1) Q:'$L(PKG) + D:$L($T(@PKG)) @PKG + Q +LR ; Spawn child orders if continuous schedule + N ORSTRT,ORPARENT,OR0,ORNP,ORDIALOG,ORL,ORX,ORTIME,ORPITEM,ORPSAMP,ORPSPEC,ORPURG,ORPCOMM,ORPTYPE,ORPCOLL,ORS1,ORS2,P,ORCHLD,ORDG,ORLAST,ORDUZ,ORLOG,ORCOLLCT,STS + S ORPARENT=+ORIFN,OR0=$G(^OR(100,ORIFN,0)),ORL=$P(OR0,U,10) + D SCHEDULE(ORIFN,"LR",.ORSTRT) I ORSTRT'>1 D Q + . N START S START=$O(ORSTRT(0)) Q:START=$P($G(^OR(100,+ORIFN,0)),U,8) + . D DATES^ORCSAVE2(+ORIFN,START) ;update start date from schedule + S ORNP=+$P(OR0,U,4),ORDIALOG=+$P(OR0,U,5),ORDUZ=+$P(OR0,U,6),ORLOG=$P(OR0,U,7),ORDG=+$P(OR0,U,11) + D GETDLG1^ORCD(ORDIALOG),GETORDER(ORIFN),GETIMES^ORCDLR1 + K ORDIALOG($$PTR^ORCD("OR GTX ADMIN SCHEDULE"),1),ORDIALOG($$PTR^ORCD("OR GTX DURATION"),1) + S ORPITEM=$$PTR^ORCD("OR GTX ORDERABLE ITEM") + S ORPSAMP=$$PTR^ORCD("OR GTX COLLECTION SAMPLE") + S ORPSPEC=$$PTR^ORCD("OR GTX SPECIMEN") + S ORPURG=$$PTR^ORCD("OR GTX LAB URGENCY") + S ORPCOMM=$$PTR^ORCD("OR GTX WORD PROCESSING 1") + S ORPTYPE=$$PTR^ORCD("OR GTX COLLECTION TYPE") + S ORPCOLL=$$PTR^ORCD("OR GTX START DATE/TIME") +LR1 S ORS1=0 F S ORS1=$O(ORX(ORS1)) Q:ORS1'>0 D + . F P=ORPITEM,ORPSAMP,ORPSPEC,ORPURG,ORPCOMM,ORPTYPE S ORDIALOG(P,1)=$G(ORX(ORS1,P)) ;set values to next instance + . S ORCOLLCT=$G(ORDIALOG(ORPTYPE,1)) + . S ORS2=0 F S ORS2=$O(ORSTRT(ORS2)) Q:ORS2'>0 D + .. S ORDIALOG(ORPCOLL,1)=ORS2 ;,ORDUZ=DUZ,ORLOG=+$E($$NOW^XLFDT,1,12) + .. I ORCOLLCT="LC" S ORDIALOG(ORPTYPE,1)=$S($$LABCOLL^ORCDLR1(ORS2):"LC",1:"WC") + .. I ORCOLLCT="I" S ORDIALOG(ORPTYPE,1)=$S($$IMMCOLL^ORCDLR1(ORS2):"I",1:"WC") + .. D CHILD() + S:$G(ORCHLD) ^OR(100,ORPARENT,2,0)="^100.002PA^"_ORLAST_U_ORCHLD + S ORIFN=ORPARENT,ORQUIT=1,STS=$P(^OR(100,ORIFN,3),U,3) + I (STS=1)!(STS=13)!(STS=11) S ORERR="1^Unable to release orders" + D RELEASE^ORCSAVE2(ORPARENT,1,ORNOW,DUZ,$G(NATURE)) + Q +SCHEDULE(IFN,PKG,ORY,STRT) ; Returns list of start time(s) from schedule + N I,X,PSJSD,PSJFD,PSJW,PSJNE,PSJPP,PSJX,PSJAT,PSJM,PSJTS,PSJY,PSJAX,PSJSCH,PSJOSD,PSJOFD,PSJC,ORDUR + S PSJSD=$S(+$G(STRT):STRT,1:$P($G(^OR(100,+IFN,0)),U,8)) I 'PSJSD S ORY=-1 Q + S ORY=1,ORY(PSJSD)="" ;1st occurrance + S I=$O(^OR(100,+IFN,4.5,"ID","SCHEDULE",0)) Q:'I Q:'$L($G(PKG)) + S X=$G(^OR(100,+IFN,4.5,I,1)),PSJX=$S(X:$$GET1^DIQ(51.1,+X_",",.01),1:X) + S PSJW=+$G(ORL),PSJNE="",PSJPP=PKG D ENSV^PSJEEU Q:'$L($G(PSJX)) + I $G(PSJTS)'="C",$G(PSJTS)'="D" Q ;not continuous or day-of-week + S PSJSCH=PSJX,I=$O(^OR(100,+IFN,4.5,"ID","DAYS",0)) Q:'I + S ORDUR=$G(^OR(100,+IFN,4.5,+I,1)) + S:ORDUR PSJFD=$$FMADD^XLFDT(PSJSD,+ORDUR,,-1) + I 'ORDUR S X=+$E(ORDUR,2,9) D + . I PSJM S PSJFD=$$FMADD^XLFDT(PSJSD,,,(PSJM*X)-1) ;X_#times + . E D ;no freq in minutes --> day of week + .. N DAYS,LOCMX,SCHMX + .. S LOCMX=$$GET^XPAR("ALL^LOC.`"_+ORL,"LR MAX DAYS CONTINUOUS",1,"Q") + .. S SCHMX=$P(^PS(51.1,PSJY,0),U,7) + .. S DAYS=$S('SCHMX:LOCMX,LOCMX0 S X=$G(^(I,0)),Y=$G(^(1)) D + . S PTR=+$P(X,U,2),INST=+$P(X,U,3),TYPE=$P($G(^ORD(101.41,PTR,1)),U) + . I TYPE'="W" S ORX(INST,PTR)=Y Q + . S ORX(INST,PTR)="^OR(100,"_IFN_",4.5,"_I_",2)" + Q +PTR(X) ; Returns ptr of prompt X in Order Dialog file + Q +$O(^ORD(101.41,"AB",$E("OR GTX "_X,1,63),0)) +CHILD(STRT) ; Create child order, send to package + N ORAPPT + K ORIFN D EN^ORCSAVE Q:'$G(ORIFN) D STARTDT^ORCSAVE2(ORIFN) + I $G(STRT) D DATES^ORCSAVE2(ORIFN,STRT) + S ORCHLD=+$G(ORCHLD)+1,^OR(100,ORPARENT,2,ORIFN,0)=ORIFN,ORLAST=ORIFN + S ORAPPT=$P($G(^OR(100,ORPARENT,0)),U,18) + S $P(^OR(100,ORIFN,0),U,18)=ORAPPT,$P(^(3),U,9)=ORPARENT + I $G(PKG)="LR" S $P(^OR(100,ORIFN,8,1,0),U,4)=8 K ^OR(100,"AS",ORVP,9999999-ORLOG,ORIFN,1) ;signature tracked on parent order only, for Labs + I $G(PKG)?1"PS".E D + . N X0,OLD S X0=$G(^OR(100,ORPARENT,8,1,0)) + . I $P(X0,U,4)'=2 D SIGN^ORCSAVE2(ORIFN,+$P(X0,U,5),ORNOW,$P(X0,U,4),1) + . I $D(^OR(100,ORPARENT,9)) M ^OR(100,ORIFN,9)=^OR(100,ORPARENT,9) + . I $G(ORENEW) S OLD=$O(ORENEW(0)) I OLD S $P(^OR(100,OLD,3),U,6)=ORIFN,$P(^OR(100,ORIFN,3),U,5)=OLD,$P(^(3),U,11)=2 K ORENEW(OLD) + D RELEASE^ORCSAVE2(ORIFN,1,ORNOW,DUZ,$G(NATURE)),NEW^ORMBLD(ORIFN) + Q +PS ; spawn child orders if multiple doses +PSJ ; (Inpt only) +PSS ; + N ORPARENT,OR0,ORNP,ORDIALOG,ORDUZ,ORLOG,ORL,ORDG,ORCAT,ORX,ORP,ORI,STS + N ORDOSE,ORT,ORSCH,ORDUR,ORSTRT,ORFRST,ORCONJ,ORID,ORDD,ORSTR,ORDGNM + N ORSTART,ORCHLD,ORLAST,ORSIG,OROI,ID,OR3,ORIG,CODE,ORPKG,ORENEW,I + S ORPARENT=+ORIFN,OR0=$G(^OR(100,ORPARENT,0)),OR3=$G(^(3)) + Q:$P(OR0,U,12)'="I" S ORCAT="I",ORNP=+$P(OR0,U,4) + S ORDIALOG=+$P(OR0,U,5),ORDUZ=+$P(OR0,U,6),ORLOG=$P(OR0,U,7) + S ORL=$P(OR0,U,10),ORDG=+$P(OR0,U,11),ORPKG=+$P(OR0,U,14) + D GETDLG1^ORCD(ORDIALOG),GETORDER(ORPARENT) + S ORDOSE=$$PTR("INSTRUCTIONS"),ORT=$$PTR("ROUTE") + S ORSCH=$$PTR("SCHEDULE"),ORDUR=$$PTR("DURATION") + S ORCONJ=$$PTR("AND/THEN") D STRT S ORSTART=$G(ORSTRT("BEG")) + D DATES^ORCSAVE2(ORPARENT,ORSTART) Q:$$DOSES(ORPARENT)'>1 + S ORFRST=$$PTR("NOW"),ORSIG=$$PTR("SIG") + S ORID=$$PTR("DOSE"),ORDD=$$PTR("DISPENSE DRUG") + S ORSTR=$$PTR("STRENGTH"),ORDGNM=$$PTR("DRUG NAME") + I $P(OR3,U,11)=2,$O(^OR(100,+$P(OR3,U,5),2,0)) D + . S ORENEW=+$P(OR3,U,5),I=0 + . I $$VALUE^ORX8(ORENEW,"NOW") S I=$O(^OR(100,ORENEW,2,0)) + . F S I=$O(^OR(100,ORENEW,2,I)) Q:I<1 S ORENEW(I)="" +PS1 F ORP="ORDERABLE ITEM","URGENCY","WORD PROCESSING 1" D + . N PTR S PTR=$$PTR(ORP) Q:PTR'>0 Q:'$D(ORX(1,PTR)) + . S ORDIALOG(PTR,1)=ORX(1,PTR) S:$E(ORP)="O" OROI=ORX(1,PTR) + S ORI=$$FRSTDOSE I $G(ORX(1,ORFRST)) D + . F ORP=ORDOSE,ORT,ORID S:$D(ORX(ORI,ORP)) ORDIALOG(ORP,1)=ORX(ORI,ORP) + . S ID=$G(ORX(ORI,ORID)) S:$P(ID,"&",6) ORDIALOG(ORDD,1)=$P(ID,"&",6) + . S ORDIALOG(ORSCH,1)="NOW",ORSTART=$$NOW^XLFDT + . D SIG,CHILD(ORSTART) + F D S ORI=$O(ORX(ORI)) Q:ORI'>0 + . F ORP=ORDOSE,ORT,ORSCH,ORDUR,ORID S:$D(ORX(ORI,ORP)) ORDIALOG(ORP,1)=ORX(ORI,ORP) K:'$D(ORX(ORI,ORP)) ORDIALOG(ORP,1) + . K ORDIALOG(ORDD,1) S ID=$G(ORX(ORI,ORID)) + . S:$P(ID,"&",6) ORDIALOG(ORDD,1)=$P(ID,"&",6) + . S ORSTART=$G(ORSTRT(ORI)) + . D SIG,CHILD(ORSTART) + S:$G(ORCHLD) ^OR(100,ORPARENT,2,0)="^100.002PA^"_ORLAST_U_ORCHLD + S ORIFN=ORPARENT,ORQUIT=1,OR3=$G(^OR(100,ORIFN,3)),STS=$P(OR3,U,3) + I (STS=1)!(STS=13)!(STS=11) S ORERR="1^Unable to release orders" + D RELEASE^ORCSAVE2(ORIFN,1,ORNOW,DUZ,$G(NATURE)) K ^TMP("ORWORD",$J) + S $P(^OR(100,ORIFN,3),U,8)=1 ;veil parent order - set stop date/time? + Q:(STS=1)!(STS=13)!(STS=11) ;unsuccessful +PS2 ; ck if parent is unsigned or edit + I $P($G(^OR(100,ORIFN,8,1,0)),U,4)=2 S $P(^(0),U,4)="" K ^OR(100,"AS",ORVP,9999999-ORLOG,ORIFN,1) ;clear ES + Q:$P(OR3,U,11)'=1 S ORIG=$P(OR3,U,5) Q:ORIG'>0 + S CODE=$S($P($G(^OR(100,ORIG,3)),U,3)=5:"CA",1:"DC") + D MSG^ORMBLD(ORIG,CODE) I "^1^13^"[(U_$P($G(^OR(100,ORIG,3)),U,3)_U) D + . N NATR S NATR=+$O(^ORD(100.02,"C","C",0)) + . S $P(^OR(100,ORIG,3),U,3)=12,$P(^(3),U,7)=0,^(6)=NATR_U_DUZ_U_ORNOW + . D CANCEL^ORCSEND(ORIG) ;ck for unrel actions + Q +DOSES(IFN) ; count number of doses in order + N I,CNT S CNT=0 + S I=0 F S I=$O(^OR(100,+$G(IFN),4.5,"ID","INSTR",I)) Q:I'>0 I $L($G(^OR(100,+$G(IFN),4.5,I,1))) S CNT=CNT+1 + S I=+$O(^OR(100,+$G(IFN),4.5,"ID","NOW",0)) I I,$G(^OR(100,+$G(IFN),4.5,I,1)) S CNT=CNT+1 + Q CNT +FRSTDOSE() ; Return instance of first dose + N I,Y S I=0,Y=1 + F S I=$O(ORX(I)) Q:I'>0 I $D(ORX(I,ORDOSE)) S Y=I Q + Q Y +SIG ; Build text of instructions + N ORDRUG,ID,DOSE,ORI,ORX K ^TMP("ORWORD",$J,ORSIG,1) + S ORDRUG=$G(ORDIALOG(ORDD,1)),ID=$G(ORDIALOG(ORID,1)) + S DOSE=$G(ORDIALOG(ORDOSE,1)),ORI=1 + S ORX=$$DOSE^ORCDPS2_$$RTE^ORCDPS2_$$SCH^ORCDPS2_$$DUR^ORCDPS2 + S ^TMP("ORWORD",$J,ORSIG,1,0)="^^1^1^"_DT_U,^(1,0)=ORX + S ORDIALOG(ORSIG,1)=$NA(^TMP("ORWORD",$J,ORSIG,1)) + S ORDIALOG(ORDOSE,"FORMAT")="@" + K ORDIALOG(ORSTR,1),ORDIALOG(ORDGNM,1) + I ORDRUG,'ID D ;set strength or drug name + . N STR,ITM S STR=$P(ID,"&",7)_$P(ID,"&",8) + . I STR'>0 S ORDIALOG(ORDGNM,1)=$$GET1^DIQ(50,+ORDRUG_",",.01) Q + . S ITM=$P($G(^ORD(101.43,+$G(OROI),0)),U) + . S:ITM'[STR ORDIALOG(ORSTR,1)=STR + Q +STRT ; Build ORSTRT(inst)=date.time array of start times by dose + N OI,PSOI,XD,XH,XM,XS,ORWD,ORI,SCH,ORSD,X,ORD K ORSTRT + S OI=$G(ORX(1,$$PTR^ORCD("OR GTX ORDERABLE ITEM"))) + S PSOI=+$P($G(^ORD(101.43,+OI,0)),U,2),(XD,XH,XM,XS)=0 + S ORWD=+$G(^SC(+$G(ORL),42)) ;ward + S ORI=0 F S ORI=$O(ORX(ORI)) Q:ORI<1 D + . S SCH=$G(ORX(ORI,ORSCH)),ORSD="" S:'$L(SCH) X=$$NOW^XLFDT + . S:$L(SCH) ORSD=$$STARTSTP^PSJORPOE(+ORVP,SCH,PSOI,ORWD),X=$P(ORSD,U,4) + . S ORSTRT(ORI)=$$FMADD^XLFDT(X,XD,XH,XM,XS) ;START+OFFSET + . ; update OFFSET for next THEN dose + . D DUR(ORI) I $G(ORX(ORI,ORCONJ))="T" D + .. I $G(ORD("XD"))<1,$G(ORD("XH"))<1,$G(ORD("XM"))<1,$G(ORD("XS"))<1 S ORD("XD")=+$P(ORSD,U,3) ;default duration + .. N I,Y F I="XD","XH","XM","XS" S Y=@I,@I=Y+$G(ORD(I)) + .. K ORD + ; find beginning date.time for parent + S ORI=0,X=9999999 F S ORI=$O(ORSTRT(ORI)) Q:ORI<1 I ORSTRT(ORI)$G(ORD("XS")) S ORD("XS")=+X + I X["'",+X>$G(ORD("XM")) S ORD("XM")=+X + I X["H",+X>$G(ORD("XH")) S ORD("XH")=+X + S Y=$S(X["D":+X,X["W":+X*7,X["M":+X*30,1:0) + I Y,Y>$G(ORD("XD")) S ORD("XD")=Y + Q +VBEC ; Spawn VBECS children + D:$L($T(EN^ORCSEND2)) EN^ORCSEND2 + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCXPND1.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCXPND1.m index 958c4ee2..f51c5846 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCXPND1.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCXPND1.m @@ -1,209 +1,206 @@ -ORCXPND1 ; SLC/MKB - Expanded Display cont ; 04/25/2007 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**26,67,75,89,92,94,148,159,188,172,215,243**;Dec 17, 1997;Build 242 - ; - ; External References - ; DBIA 2387 ^LAB(60 - ; DBIA 3420 ^DPT( file #2 - ; DBIA 10035 ^DPT( file #2 - ; DBIA 10037 EN^DGRPD - ; DBIA 700 DIS^DGRPDB - ; DBIA 2926 RT^GMRCGUIA - ; DBIA 2925 DT^GMRCSLM2 ^TMP("GMRCR" - ; DBIA 2503 RR^LR7OR1 ^TMP("LRRR" - ; DBIA 2951 EN1^LR7OSBR ^TMP("LRC" - ; DBIA 2952 EN^LR7OSMZ0 - ; DBIA 2400 OEL^PSOORRL ^TMP("PS" - ; DBIA 2877 EN3^RAO7PC3 - ; DBIA 2877 EN30^RAO7PC3 - ; DBIA 1252 $$OUTPTPR^SDUTL3 - ; DBIA 1252 $$OUTPTTM^SDUTL3 - ; DBIA 2832 RPC^TIUSRV - ; DBIA 10061 DEM^VADPT - ; DBIA 10061 KVAR^VADPT - ; DBIA 10061 OAD^VADPT - ; DBIA 10103 $$FMTE^XLFDT - ; DBIA 4408 DISP^DGIBDSP - ; -COVER ; -- Cover Sheet - N PKG S PKG=$P($G(^TMP("OR",$J,ORTAB,"IDX",NUM)),U,4) - D ALLERGY^ORCXPND2:PKG="GMRA",NOTES:PKG="TIU" - Q -NOTES ; -- Progress Notes - N I,ORY,DATE,AUTHOR,PTLOC,SUBJ K ^TMP("TIUAUDIT",$J) - D RPC^TIUSRV(.ORY,ID) - S I=0 F S I=$O(@ORY@(I)) Q:I'>0 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=$G(@ORY@(I,0)) - K @ORY - Q -PROBLEMS ; -- Problem List - D PL^ORCXPND4 - Q -MEDS ; -- Pharmacy - ;N NODE,ORIFN - K ^TMP("PS",$J) - D OEL^PSOORRL(+ORVP,ID) ;S NODE=$G(^TMP("PS",$J,0)),ORIFN=+$P(NODE,U,11) - S ID=+$P($G(^TMP("PS",$J,0)),U,11) D ORDERS ;DBIA 2400 - ;D @($S($P($G(^OR(100,ORIFN,0)),U,11)=$O(^ORD(100.98,"B","IV RX",0)):"IV",1:"DRUG")_"^ORCXPND2") - K ^TMP("PS",$J) - Q -LABS ; -- Laboratory [RESULTS ONLY for ID=OE order #] - N ORIFN,X,SUB,TEST,NAME,SS,IDE,IVDT,TST,CCNT,ORCY,IG,TCNT - K ^TMP("LRRR",$J) ;DBIA 2503 - I (ID?2.5U1" "2N1" "1.N1"-"7N1"."1.4N)!(ID?2.5U1" "2N1" "1.N1"-"7N) D AP^ORCXPND3 Q ;ID=Accession #-Date/time specimen taken - S ORIFN=+ID,IDE=$G(^OR(100,+ID,4)) Q:'$L(IDE) ; OE# -> Lab# - I +IDE D RR^LR7OR1(+ORVP,IDE) I '$D(^TMP("LRRR",$J,+ORVP)) S $P(IDE,";",1,3)=";;" ;Order possibly purged, reset to lookup on file 63 - I '+IDE,$P(IDE,";",5) D RR^LR7OR1(+ORVP,,9999999-$P(IDE,";",5),9999999-$P(IDE,";",5),$P(IDE,";",4)) - K ORCY D TEXT^ORQ12(.ORCY,ORIFN,80) - S IG=0 F S IG=$O(ORCY(IG)) Q:IG<1 S X=ORCY(IG) D ITEM^ORCXPND(X) - D BLANK^ORCXPND I '$D(^TMP("LRRR",$J,+ORVP)) S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="No data available." Q - M TEST=^TMP("LRRR",$J,+ORVP) S CCNT=0,SS="" - F S SS=$O(TEST(SS)) Q:SS="" S IVDT=0 F S IVDT=$O(TEST(SS,IVDT)) Q:'IVDT D - . I SS="BB" D - .. I $$GET^XPAR("DIV^SYS^PKG","OR VBECS ON",1,"Q"),$L($T(EN^ORWLR1)),$L($T(CPRS^VBECA3B)) D Q ;Transition to VBEC's interface - ... K ^TMP("ORLRC",$J) - ... D EN^ORWLR1(DFN) - ... I '$O(^TMP("ORLRC",$J,0)) S ^TMP("ORLRC",$J,1,0)="",^TMP("ORLRC",$J,2,0)="No Blood Bank report available..." - ... N I S I=0 F S I=$O(^TMP("ORLRC",$J,I)) Q:I<1 S X=^(I,0),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X - ... K ^TMP("ORLRC",$J) - .. K ^TMP("LRC",$J) D EN1^LR7OSBR(+ORVP) Q:'$D(^TMP("LRC",$J)) D Q ;DBIA 2951 - ... N I S I=0 F S I=$O(^TMP("LRC",$J,I)) Q:I<1 S X=^(I,0),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X - ... K ^TMP("LRC",$J) - . I SS="MI" K ^TMP("LRC",$J) D EN^LR7OSMZ0(+ORVP) Q:'$D(^TMP("LRC",$J)) D Q - .. N I S I=0 F S I=$O(^TMP("LRC",$J,I)) Q:I<1 S X=^(I,0),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X - .. K ^TMP("LRC",$J) - . I SS="CH" D Q - .. S (TCNT,TST)=0 F S TST=$O(TEST(SS,IVDT,TST)) Q:TST="" S CCNT=0,TCNT=TCNT+1 D - ... I TCNT=1 D - .... S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=" Collection time: "_$$FMTE^XLFDT(9999999-IVDT,1) - .... S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=$$S(1,CCNT," ")_$$S(3,CCNT,"Test Name")_$$S(29,CCNT,"Result")_$$S(39,CCNT,"Units")_$$S(55,CCNT,"Range") D:$D(IOUON) SETVIDEO^ORCXPND(LCNT,1,70,IOUON,IOUOFF) - ... I TST S X=TEST(SS,IVDT,TST),CCNT=0 I +X D - .... S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=$$S(1,CCNT,$P(^LAB(60,+X,0),U))_$$S(26,CCNT,$J($P(X,U,2),7))_$$S(34,CCNT,$S($L($P(X,U,3)):$P(X,U,3),1:""))_$$S(39,CCNT,$P(X,U,4))_$$S(45,CCNT,$J($P(X,U,5),15)) - .... I $L($P(X,U,3)),$D(IOINHI) D SETVIDEO^ORCXPND(LCNT,26,8,IOINHI,IOINORM) - .... I $P(X,U,3)["*",$D(IOBON),$D(IOINHI) D SETVIDEO^ORCXPND(LCNT,26,8,IOBON_IOINHI,IOBOFF_IOINORM) - ... I TST="N" S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=" Comments: " D - .... N CMT S CMT=0 F S CMT=$O(TEST(SS,IVDT,"N",CMT)) Q:'CMT S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=" "_TEST(SS,IVDT,"N",CMT) - K ^TMP("LRRR",$J) - Q - ; -DELAY ; -- Delayed Orders -NEW ; -- New Orders -ORDERS ; -- Orders - I '$G(ORESULTS) D ORDERS^ORCXPND2 Q - ; -- Results Display (Add more packages as available) - N PKG,TAB,ORIFN - S PKG=+$P($G(^OR(100,+ID,0)),"^",14),PKG=$$NMSP^ORCD(PKG) - S TAB=$S(PKG="LR":"LABS",PKG="GMRC":"CONSULTS",PKG="RA":"XRAYS",1:"") - I '$L(TAB)!(ID'>0) D Q ; no display available - . N ORY,I D TEXT^ORQ12(.ORY,+ID,80) - . S I=0 F S I=$O(ORY(I)) Q:I'>0 D ITEM^ORCXPND(ORY(I)) - . D BLANK^ORCXPND - . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="There are no results to report." - I $O(^OR(100,+ID,2,0)) S ORIFN=+ID,ID=0 F S ID=$O(^OR(100,ORIFN,2,ID)) Q:ID<1 I $D(^OR(100,ID,0)) D @TAB - I '$O(^OR(100,+ID,2,0)) D @TAB - Q -REPORTS ; -- Patient Profiles - D EN^ORCXPNDR ; Reports - Q -CONSULTS ; -- Consults - N I,X,SUB,ORTX ;,VALMAR - I $G(ORTAB)="CONSULTS" S X=$P($G(^TMP("OR",$J,ORTAB,"IDX",NUM)),U,4) - E D TEXT^ORQ12(.ORTX,+ID) S X=ORTX(1),ID=+$G(^OR(100,+ID,4)) ; OE->GMRC order# - D ITEM^ORCXPND(X),BLANK^ORCXPND - I ID'>0 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="No data available." Q - I '$G(ORESULTS) D ;DT action - . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="Consult No.: "_ID - . N GMRCOER S GMRCOER=2 D DT^GMRCSLM2(ID) S SUB="DT" ;DBIA 2925 - I $G(ORESULTS) D RT^GMRCGUIA(ID,"^TMP(""GMRCR"",$J,""RT"")") S SUB="RT" - S I=0 F S I=$O(^TMP("GMRCR",$J,SUB,I)) Q:I'>0 S X=$G(^(I,0)),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X ;DBIA 2925 - K ^TMP("GMRCR",$J) - Q -XRAYS ; -- Radiology - I '$G(ORESULTS) S ID=+ORVP_U_$TR(ID,"-","^") D EN3^RAO7PC3(ID) - I $G(ORESULTS) S ID=+$G(^OR(100,+ID,4)) D EN30^RAO7PC3(ID) - N CASE,PROC,PSET S PSET=$D(^TMP($J,"RAE3",+ORVP,"PRINT_SET")) - S CASE=0 F S CASE=$O(^TMP($J,"RAE3",+ORVP,CASE)) Q:CASE'>0 D - . I PSET S PROC=$O(^TMP($J,"RAE3",+ORVP,CASE,"")) D ITEM^ORCXPND(PROC) Q - . S PROC="" F S PROC=$O(^TMP($J,"RAE3",+ORVP,CASE,PROC)) Q:PROC="" D ITEM^ORCXPND(PROC),BLANK^ORCXPND,XRPT,BLANK^ORCXPND - I PSET S CASE=$O(^TMP($J,"RAE3",+ORVP,0)),PROC=$O(^(CASE,"")) D BLANK^ORCXPND,XRPT,BLANK^ORCXPND ;printset=list all procs, then one report - K ^TMP($J,"RAE3",+ORVP),^UTILITY($J,"W") - S VALM("RM")=81 - Q - ; -XRPT ; -- Body of Report for CASE, PROC - N ORD,X,I - S ORD=$S($L($G(^TMP($J,"RAE3",+ORVP,"ORD"))):^("ORD"),$L($G(^("ORD",CASE))):^(CASE),1:"") I $L(ORD),ORD'=PROC S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="Proc Ord: "_ORD - S I=1 F S I=$O(^TMP($J,"RAE3",+ORVP,CASE,PROC,I)) Q:I'>0 S X=^(I),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X ;Skip pt ID on line 1 - Q - ; -SUMMRIES ; -- Discharge Summaries - N I,ORY,DATE,AUTHOR,PTLOC,SUBJ K ^TMP("TIUAUDIT",$J) - D RPC^TIUSRV(.ORY,ID) - S I=0 F S I=$O(@ORY@(I)) Q:I'>0 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=$G(@ORY@(I,0)) - K @ORY - Q -PTINQ ; Print Patient Inquiry in List Manager - N DFN,ORI,X - S DFN=+ORVP - D DGINQ(DFN) - S ORI=4,LCNT=0 - F S ORI=$O(^TMP("ORDATA",$J,1,ORI)) Q:'ORI S X=^(ORI) D - . S LCNT=LCNT+1 - . S ^TMP("ORXPND",$J,LCNT,0)=X - K ^TMP("ORDATA",$J,1) - Q - ; -DGINQ(DFN) ; Patient Inquiry - D START^ORWRP(80,"DGINQB^ORCXPND1(DFN)") - Q -DGINQB(DFN) ; Build Patient Inquiry - N CONTACT,ORDOC,ORTEAM,ORVP,XQORNOD,ORSSTRT,ORSSTOPT,VAOA - S ORVP=DFN_";DPT(",XQORNOD=1 - D EN^DGRPD ; MAS Patient Inquiry - ; - S ORDOC=$$OUTPTPR^SDUTL3(DFN) - S ORTEAM=$$OUTPTTM^SDUTL3(DFN) - I ORDOC!ORTEAM D - . W !!,"Primary Care Information:" - . I ORDOC W !,"Primary Practitioner: ",$P(ORDOC,"^",2) - . I ORTEAM W !,"Primary Care Team: ",$P(ORTEAM,"^",2) - W !!,"Health Insurance Information:" - D DISP^DGIBDSP ;DBIA #4408 - W !!,"Service Connection/Rated Disabilities:" - D DIS^DGRPDB - F CONTACT="N","S" D - .S VAOA("A")=$S(CONTACT="N":"",1:3) - .D OAD^VADPT ; Get NOK Information - .I VAOA(9)]"" D - .. W !!,$S(CONTACT="N":"Next of Kin Information:",1:"Secondary Next of Kin Information:") - .. W !,"Name: ",VAOA(9) ; NOK Name - .. I VAOA(10)]"" W " (",VAOA(10),")" ; Relationship - .. I VAOA(1)]"" W !?7,VAOA(1) ; Address Line 1 - .. I VAOA(2)]"" W !?7,VAOA(2) ; Line 2 - .. I VAOA(3)]"" W !?7,VAOA(3) ; Line 3 - .. I VAOA(4)]"" D - .. . W !?7,VAOA(4) ; City - .. . I VAOA(5)]"" W ", "_$P(VAOA(5),"^",2) ; State - .. . W " ",$P(VAOA(11),"^",2) ; Zip+4 - .. I VAOA(8)]"" W !!?7,"Phone number: ",VAOA(8) ; Phone - .. I CONTACT="N",$P($G(^DPT(DFN,.21)),U,11)]"" W !?7,"Work phone number: ",$P(^DPT(DFN,.21),U,11) - .. I CONTACT="S",$P($G(^DPT(DFN,.211)),U,11)]"" W !?7,"Work phone number: ",$P(^DPT(DFN,.211),U,11) - D KVAR^VADPT - Q -TRIM(X) ; Trim Spaces - S X=$G(X) F Q:$E(X,1)'=" " S X=$E(X,2,$L(X)) - F Q:$E(X,$L(X))'=" " S X=$E(X,1,($L(X)-1)) - Q X -S(X,Y,Z) ; Pad Over - ; X=Column # - ; Y=Current Length - ; Z=Text - ; SP=Text Sent - ; CCNT=Line Position After Input Text - I '$D(Z) Q "" - N SP S SP=Z I X,Y,X>Y S SP=$E(" ",1,X-Y)_Z - S CCNT=$$INC(CCNT,SP) - Q SP -INC(X,Y) ; Character Position Count - ; X=Current Count - ; Y=Text - N INC S INC=X+$L(Y) - Q INC +ORCXPND1 ; SLC/MKB - Expanded Display cont ; 02/20/2003 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**26,67,75,89,92,94,148,159,188,172,215**;Dec 17, 1997 + ; + ; External References + ; DBIA 2387 ^LAB(60 + ; DBIA 3420 ^DPT( file #2 + ; DBIA 10035 ^DPT( file #2 + ; DBIA 10037 EN^DGRPD + ; DBIA 700 DIS^DGRPDB + ; DBIA 2926 RT^GMRCGUIA + ; DBIA 2925 DT^GMRCSLM2 ^TMP("GMRCR" + ; DBIA 10146 DISP^IBCNS + ; DBIA 2503 RR^LR7OR1 ^TMP("LRRR" + ; DBIA 2951 EN1^LR7OSBR ^TMP("LRC" + ; DBIA 2952 EN^LR7OSMZ0 + ; DBIA 2400 OEL^PSOORRL ^TMP("PS" + ; DBIA 2877 EN3^RAO7PC3 + ; DBIA 2877 EN30^RAO7PC3 + ; DBIA 1252 $$OUTPTPR^SDUTL3 + ; DBIA 1252 $$OUTPTTM^SDUTL3 + ; DBIA 2832 RPC^TIUSRV + ; DBIA 10061 DEM^VADPT + ; DBIA 10061 KVAR^VADPT + ; DBIA 10061 OAD^VADPT + ; DBIA 10103 $$FMTE^XLFDT + ; DBIA 4408 DISP^DGIBDSP + ; +COVER ; -- Cover Sheet + N PKG S PKG=$P($G(^TMP("OR",$J,ORTAB,"IDX",NUM)),U,4) + D ALLERGY^ORCXPND2:PKG="GMRA",NOTES:PKG="TIU" + Q +NOTES ; -- Progress Notes + N I,ORY,DATE,AUTHOR,PTLOC,SUBJ K ^TMP("TIUAUDIT",$J) + D RPC^TIUSRV(.ORY,ID) + S I=0 F S I=$O(@ORY@(I)) Q:I'>0 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=$G(@ORY@(I,0)) + K @ORY + Q +PROBLEMS ; -- Problem List + D PL^ORCXPND4 + Q +MEDS ; -- Pharmacy + ;N NODE,ORIFN + D OEL^PSOORRL(+ORVP,ID) ;S NODE=$G(^TMP("PS",$J,0)),ORIFN=+$P(NODE,U,11) + S ID=+$P($G(^TMP("PS",$J,0)),U,11) D ORDERS ;DBIA 2400 + ;D @($S($P($G(^OR(100,ORIFN,0)),U,11)=$O(^ORD(100.98,"B","IV RX",0)):"IV",1:"DRUG")_"^ORCXPND2") + K ^TMP("PS",$J) + Q +LABS ; -- Laboratory [RESULTS ONLY for ID=OE order #] + N ORIFN,X,SUB,TEST,NAME,SS,IDE,IVDT,TST,CCNT,ORCY,IG,TCNT + K ^TMP("LRRR",$J) ;DBIA 2503 + S ORIFN=+ID,IDE=$G(^OR(100,+ID,4)) Q:'$L(IDE) ; OE# -> Lab# + I +IDE D RR^LR7OR1(+ORVP,IDE) I '$D(^TMP("LRRR",$J,+ORVP)) S $P(IDE,";",1,3)=";;" ;Order possibly purged, reset to lookup on file 63 + I '+IDE,$P(IDE,";",5) D RR^LR7OR1(+ORVP,,9999999-$P(IDE,";",5),9999999-$P(IDE,";",5),$P(IDE,";",4)) + K ORCY D TEXT^ORQ12(.ORCY,ORIFN,80) + S IG=0 F S IG=$O(ORCY(IG)) Q:IG<1 S X=ORCY(IG) D ITEM^ORCXPND(X) + D BLANK^ORCXPND I '$D(^TMP("LRRR",$J,+ORVP)) S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="No data available." Q + M TEST=^TMP("LRRR",$J,+ORVP) S CCNT=0,SS="" + F S SS=$O(TEST(SS)) Q:SS="" S IVDT=0 F S IVDT=$O(TEST(SS,IVDT)) Q:'IVDT D + . I SS="BB" D + .. I $L($T(EN^ORWLR1)),$L($T(CPRS^VBECA3B)) D Q ;Transition to VBEC's interface + ... K ^TMP("ORLRC",$J) + ... D EN^ORWLR1(DFN) + ... I '$O(^TMP("ORLRC",$J,0)) S ^TMP("ORLRC",$J,1,0)="",^TMP("ORLRC",$J,2,0)="No Blood Bank report available..." + ... N I S I=0 F S I=$O(^TMP("ORLRC",$J,I)) Q:I<1 S X=^(I,0),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X + ... K ^TMP("ORLRC",$J) + .. K ^TMP("LRC",$J) D EN1^LR7OSBR(+ORVP) Q:'$D(^TMP("LRC",$J)) D Q ;DBIA 2951 + ... N I S I=0 F S I=$O(^TMP("LRC",$J,I)) Q:I<1 S X=^(I,0),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X + ... K ^TMP("LRC",$J) + . I SS="MI" K ^TMP("LRC",$J) D EN^LR7OSMZ0(+ORVP) Q:'$D(^TMP("LRC",$J)) D Q + .. N I S I=0 F S I=$O(^TMP("LRC",$J,I)) Q:I<1 S X=^(I,0),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X + .. K ^TMP("LRC",$J) + . I SS="CH" D Q + .. S (TCNT,TST)=0 F S TST=$O(TEST(SS,IVDT,TST)) Q:TST="" S CCNT=0,TCNT=TCNT+1 D + ... I TCNT=1 D + .... S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=" Collection time: "_$$FMTE^XLFDT(9999999-IVDT,1) + .... S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=$$S(1,CCNT," ")_$$S(3,CCNT,"Test Name")_$$S(29,CCNT,"Result")_$$S(39,CCNT,"Units")_$$S(55,CCNT,"Range") D:$D(IOUON) SETVIDEO^ORCXPND(LCNT,1,70,IOUON,IOUOFF) + ... I TST S X=TEST(SS,IVDT,TST),CCNT=0 I +X D + .... S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=$$S(1,CCNT,$P(^LAB(60,+X,0),U))_$$S(26,CCNT,$J($P(X,U,2),7))_$$S(34,CCNT,$S($L($P(X,U,3)):$P(X,U,3),1:""))_$$S(39,CCNT,$P(X,U,4))_$$S(45,CCNT,$J($P(X,U,5),15)) + .... I $L($P(X,U,3)),$D(IOINHI) D SETVIDEO^ORCXPND(LCNT,26,8,IOINHI,IOINORM) + .... I $P(X,U,3)["*",$D(IOBON),$D(IOINHI) D SETVIDEO^ORCXPND(LCNT,26,8,IOBON_IOINHI,IOBOFF_IOINORM) + ... I TST="N" S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=" Comments: " D + .... N CMT S CMT=0 F S CMT=$O(TEST(SS,IVDT,"N",CMT)) Q:'CMT S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=" "_TEST(SS,IVDT,"N",CMT) + K ^TMP("LRRR",$J) + Q + ; +DELAY ; -- Delayed Orders +NEW ; -- New Orders +ORDERS ; -- Orders + I '$G(ORESULTS) D ORDERS^ORCXPND2 Q + ; -- Results Display (Add more packages as available) + N PKG,TAB,ORIFN + S PKG=+$P($G(^OR(100,+ID,0)),"^",14),PKG=$$NMSP^ORCD(PKG) + S TAB=$S(PKG="LR":"LABS",PKG="GMRC":"CONSULTS",PKG="RA":"XRAYS",1:"") + I '$L(TAB)!(ID'>0) D Q ; no display available + . N ORY,I D TEXT^ORQ12(.ORY,+ID,80) + . S I=0 F S I=$O(ORY(I)) Q:I'>0 D ITEM^ORCXPND(ORY(I)) + . D BLANK^ORCXPND + . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="There are no results to report." + I $O(^OR(100,+ID,2,0)) S ORIFN=+ID,ID=0 F S ID=$O(^OR(100,ORIFN,2,ID)) Q:ID<1 I $D(^OR(100,ID,0)) D @TAB + I '$O(^OR(100,+ID,2,0)) D @TAB + Q +REPORTS ; -- Patient Profiles + D EN^ORCXPNDR ; Reports + Q +CONSULTS ; -- Consults + N I,X,SUB,ORTX ;,VALMAR + I $G(ORTAB)="CONSULTS" S X=$P($G(^TMP("OR",$J,ORTAB,"IDX",NUM)),U,4) + E D TEXT^ORQ12(.ORTX,+ID) S X=ORTX(1),ID=+$G(^OR(100,+ID,4)) ; OE->GMRC order# + D ITEM^ORCXPND(X),BLANK^ORCXPND + I ID'>0 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="No data available." Q + I '$G(ORESULTS) D ;DT action + . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="Consult No.: "_ID + . N GMRCOER S GMRCOER=2 D DT^GMRCSLM2(ID) S SUB="DT" ;DBIA 2925 + I $G(ORESULTS) D RT^GMRCGUIA(ID,"^TMP(""GMRCR"",$J,""RT"")") S SUB="RT" + S I=0 F S I=$O(^TMP("GMRCR",$J,SUB,I)) Q:I'>0 S X=$G(^(I,0)),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X ;DBIA 2925 + K ^TMP("GMRCR",$J) + Q +XRAYS ; -- Radiology + I '$G(ORESULTS) S ID=+ORVP_U_$TR(ID,"-","^") D EN3^RAO7PC3(ID) + I $G(ORESULTS) S ID=+$G(^OR(100,+ID,4)) D EN30^RAO7PC3(ID) + N CASE,PROC,PSET S PSET=$D(^TMP($J,"RAE3",+ORVP,"PRINT_SET")) + S CASE=0 F S CASE=$O(^TMP($J,"RAE3",+ORVP,CASE)) Q:CASE'>0 D + . I PSET S PROC=$O(^TMP($J,"RAE3",+ORVP,CASE,"")) D ITEM^ORCXPND(PROC) Q + . S PROC="" F S PROC=$O(^TMP($J,"RAE3",+ORVP,CASE,PROC)) Q:PROC="" D ITEM^ORCXPND(PROC),BLANK^ORCXPND,XRPT,BLANK^ORCXPND + I PSET S CASE=$O(^TMP($J,"RAE3",+ORVP,0)),PROC=$O(^(CASE,"")) D BLANK^ORCXPND,XRPT,BLANK^ORCXPND ;printset=list all procs, then one report + K ^TMP($J,"RAE3",+ORVP),^UTILITY($J,"W") + S VALM("RM")=81 + Q + ; +XRPT ; -- Body of Report for CASE, PROC + N ORD,X,I + S ORD=$S($L($G(^TMP($J,"RAE3",+ORVP,"ORD"))):^("ORD"),$L($G(^("ORD",CASE))):^(CASE),1:"") I $L(ORD),ORD'=PROC S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="Proc Ord: "_ORD + S I=1 F S I=$O(^TMP($J,"RAE3",+ORVP,CASE,PROC,I)) Q:I'>0 S X=^(I),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X ;Skip pt ID on line 1 + Q + ; +SUMMRIES ; -- Discharge Summaries + N I,ORY,DATE,AUTHOR,PTLOC,SUBJ K ^TMP("TIUAUDIT",$J) + D RPC^TIUSRV(.ORY,ID) + S I=0 F S I=$O(@ORY@(I)) Q:I'>0 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=$G(@ORY@(I,0)) + K @ORY + Q +PTINQ ; Print Patient Inquiry in List Manager + N DFN,ORI,X + S DFN=+ORVP + D DGINQ(DFN) + S ORI=4,LCNT=0 + F S ORI=$O(^TMP("ORDATA",$J,1,ORI)) Q:'ORI S X=^(ORI) D + . S LCNT=LCNT+1 + . S ^TMP("ORXPND",$J,LCNT,0)=X + K ^TMP("ORDATA",$J,1) + Q + ; +DGINQ(DFN) ; Patient Inquiry + D START^ORWRP(80,"DGINQB^ORCXPND1(DFN)") + Q +DGINQB(DFN) ; Build Patient Inquiry + N ORDOC,ORTEAM,ORVP,XQORNOD,ORSSTRT,ORSSTOP,X,VAOA + S ORVP=DFN_";DPT(",XQORNOD=1 + D EN^DGRPD ; MAS Patient Inquiry + ; + S ORDOC=$$OUTPTPR^SDUTL3(DFN) + S ORTEAM=$$OUTPTTM^SDUTL3(DFN) + I ORDOC!ORTEAM D + . W !!,"Primary Care Information:" + . I ORDOC W !,"Primary Practitioner: ",$P(ORDOC,"^",2) + . I ORTEAM W !,"Primary Care Team: ",$P(ORTEAM,"^",2) + W !!,"Health Insurance Information:" + I $L($T(DISP^DGIBDSP)) D DISP^DGIBDSP ;DBIA #4408 + E D DISP^IBCNS + W !!,"Service Connection/Rated Disabilities:" + D DIS^DGRPDB + D OAD^VADPT ; Get NOK Information + I VAOA(9)]"" D + . W !!,"Next of Kin Information:" + . W !,"Name: ",VAOA(9) ; NOK Name + . I VAOA(10)]"" W " (",VAOA(10),")" ; Relationship + . I VAOA(1)]"" W !?7,VAOA(1) ; Address Line 1 + . I VAOA(2)]"" W !?7,VAOA(2) ; Line 2 + . I VAOA(3)]"" W !?7,VAOA(3) ; Line 3 + . I VAOA(4)]"" D + . . W !?7,VAOA(4) ; City + . . I VAOA(5)]"" W ", "_$P(VAOA(5),"^",2) ; State + . . W " ",$P(VAOA(11),"^",2) ; Zip+4 + . I VAOA(8)]"" W !!?7,"Phone number: ",VAOA(8) ; Phone + . I $P($G(^DPT(DFN,.21)),U,11)]"" W !?7,"Work phone number: ",$P(^DPT(DFN,.21),U,11) + D KVAR^VADPT + Q +TRIM(X) ; Trim Spaces + S X=$G(X) F Q:$E(X,1)'=" " S X=$E(X,2,$L(X)) + F Q:$E(X,$L(X))'=" " S X=$E(X,1,($L(X)-1)) + Q X +S(X,Y,Z) ; Pad Over + ; X=Column # + ; Y=Current Length + ; Z=Text + ; SP=Text Sent + ; CCNT=Line Position After Input Text + I '$D(Z) Q "" + N SP S SP=Z I X,Y,X>Y S SP=$E(" ",1,X-Y)_Z + S CCNT=$$INC(CCNT,SP) + Q SP +INC(X,Y) ; Character Position Count + ; X=Current Count + ; Y=Text + N INC S INC=X+$L(Y) + Q INC diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCXPND3.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCXPND3.m index f338a30e..dc8d716c 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCXPND3.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCXPND3.m @@ -1,165 +1,148 @@ -ORCXPND3 ; SLC/MKB,dcm - Expanded display of Reports ;2/21/01 14:07 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**25,30,43,85,172,243**;Dec 17, 1997;Build 242 - ; -AP ; -- Retrieve AP results for a specific date/time specimen taken - ; [alert follow-up, from LABS^ORCXPND1] - N ORACCNO,ORDTSTKN S ORACCNO=$P(ID,"-"),ORDTSTKN=$P(ID,"-",2) - I (ORACCNO["CY"!(ORACCNO["SP")!(ORACCNO["EM")!(ORACCNO["AU"))&($L(ORACCNO)>0) D ;check for valid accession # - . N ORLRDFN,ORLRSS S ORLRDFN=$$LRDFN^LR7OR1(DFN),ORLRSS=$P($G(XQADATA),U) ;DBIA/ICR #2503 - . K ^TMP("ORAP",$J) D EN^LR7OSAP4("^TMP(""ORAP"",$J)",ORLRDFN,ORLRSS,ORDTSTKN) - . I '$O(^TMP("ORAP",$J,0)) S ^TMP("ORAP",$J,1,0)="",^TMP("ORAP",$J,2,0)="No Anatomic Pathology report available..." - . N I S I=0 F S I=$O(^TMP("ORAP",$J,I)) Q:I<1 S X=^(I,0),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X - . K ^TMP("ORAP",$J) - Q - ; -LRA ; -- Anatomic Pathology Report - N DFN,Y,I,LRLLOC,LRQ - D TIT^ORCXPNDR("Anatomic Path Report") Q:$$OS^ORCXPNDR() - D PREP^ORCXPNDR - D RPT^ORWRP(.Y,ID,3) - D ITEM^ORCXPND("Anatomic Path Report") - S I=3 F S I=$O(^TMP("ORDATA",$J,1,I)) Q:I<1 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=^TMP("ORDATA",$J,1,I) - K ^TMP("ORDATA",$J) - Q - ; -LRAA ; -- Alternate Anatomic Path Report - N DFN,Y,I,LRLLOC,LRQ - D TIT^ORCXPNDR("Alternate Anatomic Path Report") Q:$$OS^ORCXPNDR() - D PREP^ORCXPNDR I $$OS^ORCXPNDR() Q - D AP^LR7OSUM(ID) - D ITEM^ORCXPND("Anatomic Pathology Report") - I '$O(^TMP("LRC",$J,0)) S ^TMP("LRC",$J,1,0)="No Anatomic Pathology reports available..." - S I=0 F S I=$O(^TMP("LRC",$J,I)) Q:I<1 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=^TMP("LRC",$J,I,0) - K ^TMP("LRC",$J) - Q - ; -LRB1 ; -- Blood Bank Report - N DFN,Y,I,LRBLOOD,LRCAPA,LRDT0,LRLABKY,LRLLOC,LRO,LRPCEVSO,LRPLASMA,LRSERUM,LRT,LRUNKNOW,LRURINE,LRVIDO,LRVIDOF - D TIT^ORCXPNDR("Blood Bank Report") Q:$$OS^ORCXPNDR() - D PREP^ORCXPNDR - D RPT^ORWRP(.Y,ID,2) - D ITEM^ORCXPND("Blood Bank Report") - S I=5 F S I=$O(^TMP("ORDATA",$J,1,I)) Q:I<1 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=^TMP("ORDATA",$J,1,I) - K ^TMP("ORDATA",$J) - Q - ; -LRB ; -- A better Blood Bank Report - N DFN,ORY,I,SUBHEAD - D TIT^ORCXPNDR("Blood Bank Report") - S DFN=ID - D PREP^ORCXPNDR - I $$GET^XPAR("DIV^SYS^PKG","OR VBECS ON",1,"Q"),$L($T(EN^ORWLR1)),$L($T(CPRS^VBECA3B)) D Q ;Transition to VBEC's interface - . K ^TMP("ORLRC",$J) - . D EN^ORWLR1(DFN) - . I '$O(^TMP("ORLRC",$J,0)) S ^TMP("ORLRC",$J,1,0)="",^TMP("ORLRC",$J,2,0)="No Blood Bank report available..." - . D ITEM^ORCXPND("Blood Bank Report"),BLANK^ORCXPND - . S I=0 F S I=$O(^TMP("ORLRC",$J,I)) Q:I'>0 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=^TMP("ORLRC",$J,I,0) - . K ^TMP("ORLRC",$J) - S SUBHEAD("BLOOD BANK")="" - D EN^LR7OSUM(.ORY,DFN,,,,,.SUBHEAD) - I '$O(^TMP("LRC",$J,0)) S ^TMP("LRC",$J,1,0)="No Blood Bank report available..." - D ITEM^ORCXPND("Blood Bank Report"),BLANK^ORCXPND - S I=0 F S I=$O(^TMP("LRC",$J,I)) Q:I'>0 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=^TMP("LRC",$J,I,0) - K ^TMP("LRC",$J),^TMP("LRH",$J) - Q - ; -LRC ; -- Lab Cumulative - N DFN,ORY,I,BEG,END,OREND,ORSSTRT,ORSSTOP - D TIT^ORCXPNDR("Lab Cumulative") - S DFN=ID - D RANGE($S($G(ORWARD):7,1:180)) Q:OREND S BEG=+ORSSTRT,END=+ORSSTOP - D PREP^ORCXPNDR - D EN^LR7OSUM(.ORY,DFN,BEG,END) - D ITEM^ORCXPND("Lab Cumulative"),BLANK^ORCXPND - S I=0 F S I=$O(^TMP("LRC",$J,I)) Q:I'>0 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=^TMP("LRC",$J,I,0) - K ^TMP("LRC",$J),^TMP("LRH",$J) - Q - ; -LRG ; -- Graph Lab Tests - N DFN,Y,I,X,BCNT,LRSS,LRCW,LRFLAG,LRCTRL,LRNSET,N,LOW,LRPCEVSO,LRPRAC,LRRB,LRTREA,LRVIDO,LRVIDOF,OREND,ORSSTRT,ORSSTOP - D TIT^ORCXPNDR("Graph Lab Tests") Q:$$OS^ORCXPNDR() - D RANGE($S($G(ORWARD):7,1:180)) Q:OREND - S LRSS="CH",LRCW=8,LRFLAG="",LRCTRL=0,(LRNSET,N)=80 - D L2^LRDIST4 Q:'$D(LRTEST) - D PREP^ORCXPNDR - D RPT^ORWRP(.Y,ID,8,,,,+ORSSTRT,+ORSSTOP) - D ITEM^ORCXPND("Lab Graph") - S I=4,BCNT=0 - F S I=$O(^TMP("ORDATA",$J,1,I)) Q:I<1 S X=^(I) D - . I '$L(X) S BCNT=BCNT+1 I BCNT>1 Q - . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X S:$L(X) BCNT=0 - K ^TMP("ORDATA",$J) - Q - ; -LRI ; -- Interim Lab Results - N ORX,DFN,Y,I,X,BCNT,LREDT,LRIDT,LRLLT,LRPCEVSO,LRPRAC,LRRB,LRTREA,LRVIDO,LRVIDOF,OREND,ORSSTRT,ORSSTOP - D TIT^ORCXPNDR("Lab Interim Results") Q:$$OS^ORCXPNDR() - D RANGE($S($G(ORWARD):7,1:180)) Q:OREND - D SET^LRRP4 - D PREP^ORCXPNDR - D RPT^ORWRP(.Y,ID,3,,,,+ORSSTRT,+ORSSTOP) - D ITEM^ORCXPND("Lab Interim Report") - S I=0,BCNT=0 - F S I=$O(^TMP("ORDATA",$J,1,I)) Q:I<1 S X=^(I) D - . I '$L(X) S BCNT=BCNT+1 I BCNT>1 Q - . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X S:$L(X) BCNT=0 - K ^TMP("ORDATA",$J) - Q - ; -LRGEN ;Lab Results by Test - N DFN,Y,I,II,X,BCNT,LRPRETTY,LREDT,LRLLT,LRPCEVSO,LRPRAC,LRRB,LRTREA,LRVIDO,LRVIDOF,LRCW,LREND,LRTP,LRIX,LRWPL,LRIDT,LRSC,DIC,LRTSTS,LRORD,LRTEST,LRSUB,LRHDR,LRSSP,LRHI,LRLO - N LBL,LRBLOOD,LRDAT,LRDFN,LRDPF,LRDT0,LREX,LRFFLG,LRFOOT,LRLAB,LRLABKY,LRND,LRNG,LRNOP,LRNOTE,LRODT0,LRONESPC,LRONETST,LRPAGE,LRPARAM,LRPLASMA,LRPP,LRSERUM,LRPS,LRTN,LRUNKNOW,LRURINE,LRWRD,LRX,LRY - N AGE,I,INC,LRIDT1,LRSV,OREND,ORSSTRT,ORSSTOP - K ^TMP("LR",$J) - D TIT^ORCXPNDR("Lab Results by Test") Q:$$OS^ORCXPNDR() - D RANGE($S($G(ORWARD):7,1:180)) Q:OREND - D SET^LRGEN - Q:LREND!'LRTSTS - D PREP^ORCXPNDR - D RPT^ORWRP(.Y,ID,16,,,,+ORSSTRT,+ORSSTOP) - D ITEM^ORCXPND("Lab Results by Test") - S I=1,BCNT=0 - F S I=$O(^TMP("ORDATA",$J,1,I)) Q:I<1 S X=^(I) D - . I '$L(X) S BCNT=BCNT+1 I BCNT>1 Q - . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X S:$L(X) BCNT=0 - K ^TMP("ORDATA",$J) - Q - ; -STAT ; -- Lab test status - N DFN,Y,I,X,BCNT,OREND,ORSSTRT,ORSSTOP - D TIT^ORCXPNDR("Lab Test Status") Q:$$OS^ORCXPNDR() - D RANGE($S($G(ORWARD):7,1:180)) Q:$G(OREND) - D PREP^ORCXPNDR - D RPT^ORWRP(.Y,ID,9,,,,+ORSSTRT,+ORSSTOP) - D ITEM^ORCXPND("Lab Test Status") - S I=0,BCNT=0 - F S I=$O(^TMP("ORDATA",$J,1,I)) Q:I<1 S X=$S($D(^(I))#2:^(I),$D(^(I,0))#2:^(0),1:"") D - . I '$L(X) S BCNT=BCNT+1 I BCNT>1 Q - . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X S:$L(X) BCNT=0 - K ^TMP("ORDATA",$J) - Q - ; -RANGE(BEG) ;Get date range for report - ;BEG=# of days (T-BEG) for start default - ;Output: ORSSTRT=Start date/time - ; ORSSTOP=Stop date/time - ; OREND=1 if user '^'s out, so look for it! - S BEG=$$FMADD^XLFDT(DT,-$G(BEG)),END=$$NOW^XLFDT - D RANGE^ORPRS01(BEG,END) - Q - ; -MED(MED) ; -- Medicine Summary of Patient Procedures - N DFN,Y,I,X,BCNT,OREND,PROCID - D TIT^ORCXPNDR("Summary of Patient Procedures") Q:$$OS^ORCXPNDR() - D PREP^ORCXPNDR - S DFN=+ID,PROCID=$P(MED,"~",2) - D RPT^ORWRP(.Y,DFN,19,,,PROCID) - D ITEM^ORCXPND("Summary of Patient Procedures") - S I=4,BCNT=0 - F S I=$O(^TMP("ORDATA",$J,1,I)) Q:I<1 S X=^(I) D - . I '$L(X) S BCNT=BCNT+1 I BCNT>1 Q - . I $E(X,1,4)="Pg. " Q - . I X["PHYSICIANS' SIGNATURE" Q - . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X S:$L(X) BCNT=0 - K ^TMP("ORDATA",$J) - Q +ORCXPND3 ; SLC/MKB,dcm - Expanded display of Reports ;2/21/01 14:07 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**25,30,43,85,172**;Dec 17, 1997 +LRA ; -- Anatomic Pathology Report + N DFN,Y,I,LRLLOC,LRQ + D TIT^ORCXPNDR("Anatomic Path Report") Q:$$OS^ORCXPNDR() + D PREP^ORCXPNDR + D RPT^ORWRP(.Y,ID,3) + D ITEM^ORCXPND("Anatomic Path Report") + S I=3 F S I=$O(^TMP("ORDATA",$J,1,I)) Q:I<1 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=^TMP("ORDATA",$J,1,I) + K ^TMP("ORDATA",$J) + Q + ; +LRAA ; -- Alternate Anatomic Path Report + N DFN,Y,I,LRLLOC,LRQ + D TIT^ORCXPNDR("Alternate Anatomic Path Report") Q:$$OS^ORCXPNDR() + D PREP^ORCXPNDR I $$OS^ORCXPNDR() Q + D AP^LR7OSUM(ID) + D ITEM^ORCXPND("Anatomic Pathology Report") + I '$O(^TMP("LRC",$J,0)) S ^TMP("LRC",$J,1,0)="No Anatomic Pathology reports available..." + S I=0 F S I=$O(^TMP("LRC",$J,I)) Q:I<1 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=^TMP("LRC",$J,I,0) + K ^TMP("LRC",$J) + Q +LRB1 ; -- Blood Bank Report + N DFN,Y,I,LRBLOOD,LRCAPA,LRDT0,LRLABKY,LRLLOC,LRO,LRPCEVSO,LRPLASMA,LRSERUM,LRT,LRUNKNOW,LRURINE,LRVIDO,LRVIDOF + D TIT^ORCXPNDR("Blood Bank Report") Q:$$OS^ORCXPNDR() + D PREP^ORCXPNDR + D RPT^ORWRP(.Y,ID,2) + D ITEM^ORCXPND("Blood Bank Report") + S I=5 F S I=$O(^TMP("ORDATA",$J,1,I)) Q:I<1 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=^TMP("ORDATA",$J,1,I) + K ^TMP("ORDATA",$J) + Q + ; +LRB ; -- A better Blood Bank Report + N DFN,ORY,I,SUBHEAD + D TIT^ORCXPNDR("Blood Bank Report") + S DFN=ID + D PREP^ORCXPNDR + I $L($T(EN^ORWLR1)),$L($T(CPRS^VBECA3B)) D Q ;Transition to VBEC's interface + . K ^TMP("ORLRC",$J) + . D EN^ORWLR1(DFN) + . I '$O(^TMP("ORLRC",$J,0)) S ^TMP("ORLRC",$J,1,0)="",^TMP("ORLRC",$J,2,0)="No Blood Bank report available..." + . D ITEM^ORCXPND("Blood Bank Report"),BLANK^ORCXPND + . S I=0 F S I=$O(^TMP("ORLRC",$J,I)) Q:I'>0 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=^TMP("ORLRC",$J,I,0) + . K ^TMP("ORLRC",$J) + S SUBHEAD("BLOOD BANK")="" + D EN^LR7OSUM(.ORY,DFN,,,,,.SUBHEAD) + I '$O(^TMP("LRC",$J,0)) S ^TMP("LRC",$J,1,0)="No Blood Bank report available..." + D ITEM^ORCXPND("Blood Bank Report"),BLANK^ORCXPND + S I=0 F S I=$O(^TMP("LRC",$J,I)) Q:I'>0 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=^TMP("LRC",$J,I,0) + K ^TMP("LRC",$J),^TMP("LRH",$J) + Q +LRC ; -- Lab Cumulative + N DFN,ORY,I,BEG,END,OREND,ORSSTRT,ORSSTOP + D TIT^ORCXPNDR("Lab Cumulative") + S DFN=ID + D RANGE($S($G(ORWARD):7,1:180)) Q:OREND S BEG=+ORSSTRT,END=+ORSSTOP + D PREP^ORCXPNDR + D EN^LR7OSUM(.ORY,DFN,BEG,END) + D ITEM^ORCXPND("Lab Cumulative"),BLANK^ORCXPND + S I=0 F S I=$O(^TMP("LRC",$J,I)) Q:I'>0 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=^TMP("LRC",$J,I,0) + K ^TMP("LRC",$J),^TMP("LRH",$J) + Q + ; +LRG ; -- Graph Lab Tests + N DFN,Y,I,X,BCNT,LRSS,LRCW,LRFLAG,LRCTRL,LRNSET,N,LOW,LRPCEVSO,LRPRAC,LRRB,LRTREA,LRVIDO,LRVIDOF,OREND,ORSSTRT,ORSSTOP + D TIT^ORCXPNDR("Graph Lab Tests") Q:$$OS^ORCXPNDR() + D RANGE($S($G(ORWARD):7,1:180)) Q:OREND + S LRSS="CH",LRCW=8,LRFLAG="",LRCTRL=0,(LRNSET,N)=80 + D L2^LRDIST4 Q:'$D(LRTEST) + D PREP^ORCXPNDR + D RPT^ORWRP(.Y,ID,8,,,,+ORSSTRT,+ORSSTOP) + D ITEM^ORCXPND("Lab Graph") + S I=4,BCNT=0 + F S I=$O(^TMP("ORDATA",$J,1,I)) Q:I<1 S X=^(I) D + . I '$L(X) S BCNT=BCNT+1 I BCNT>1 Q + . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X S:$L(X) BCNT=0 + K ^TMP("ORDATA",$J) + Q + ; +LRI ; -- Interim Lab Results + N ORX,DFN,Y,I,X,BCNT,LREDT,LRIDT,LRLLT,LRPCEVSO,LRPRAC,LRRB,LRTREA,LRVIDO,LRVIDOF,OREND,ORSSTRT,ORSSTOP + D TIT^ORCXPNDR("Lab Interim Results") Q:$$OS^ORCXPNDR() + D RANGE($S($G(ORWARD):7,1:180)) Q:OREND + D SET^LRRP4 + D PREP^ORCXPNDR + D RPT^ORWRP(.Y,ID,3,,,,+ORSSTRT,+ORSSTOP) + D ITEM^ORCXPND("Lab Interim Report") + S I=0,BCNT=0 + F S I=$O(^TMP("ORDATA",$J,1,I)) Q:I<1 S X=^(I) D + . I '$L(X) S BCNT=BCNT+1 I BCNT>1 Q + . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X S:$L(X) BCNT=0 + K ^TMP("ORDATA",$J) + Q +LRGEN ;Lab Results by Test + N DFN,Y,I,II,X,BCNT,LRPRETTY,LREDT,LRLLT,LRPCEVSO,LRPRAC,LRRB,LRTREA,LRVIDO,LRVIDOF,LRCW,LREND,LRTP,LRIX,LRWPL,LRIDT,LRSC,DIC,LRTSTS,LRORD,LRTEST,LRSUB,LRHDR,LRSSP,LRHI,LRLO + N LBL,LRBLOOD,LRDAT,LRDFN,LRDPF,LRDT0,LREX,LRFFLG,LRFOOT,LRLAB,LRLABKY,LRND,LRNG,LRNOP,LRNOTE,LRODT0,LRONESPC,LRONETST,LRPAGE,LRPARAM,LRPLASMA,LRPP,LRSERUM,LRPS,LRTN,LRUNKNOW,LRURINE,LRWRD,LRX,LRY + N AGE,I,INC,LRIDT1,LRSV,OREND,ORSSTRT,ORSSTOP + K ^TMP("LR",$J) + D TIT^ORCXPNDR("Lab Results by Test") Q:$$OS^ORCXPNDR() + D RANGE($S($G(ORWARD):7,1:180)) Q:OREND + D SET^LRGEN + Q:LREND!'LRTSTS + D PREP^ORCXPNDR + D RPT^ORWRP(.Y,ID,16,,,,+ORSSTRT,+ORSSTOP) + D ITEM^ORCXPND("Lab Results by Test") + S I=1,BCNT=0 + F S I=$O(^TMP("ORDATA",$J,1,I)) Q:I<1 S X=^(I) D + . I '$L(X) S BCNT=BCNT+1 I BCNT>1 Q + . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X S:$L(X) BCNT=0 + K ^TMP("ORDATA",$J) + Q + ; +STAT ; -- Lab test status + N DFN,Y,I,X,BCNT,OREND,ORSSTRT,ORSSTOP + D TIT^ORCXPNDR("Lab Test Status") Q:$$OS^ORCXPNDR() + D RANGE($S($G(ORWARD):7,1:180)) Q:$G(OREND) + D PREP^ORCXPNDR + D RPT^ORWRP(.Y,ID,9,,,,+ORSSTRT,+ORSSTOP) + D ITEM^ORCXPND("Lab Test Status") + S I=0,BCNT=0 + F S I=$O(^TMP("ORDATA",$J,1,I)) Q:I<1 S X=$S($D(^(I))#2:^(I),$D(^(I,0))#2:^(0),1:"") D + . I '$L(X) S BCNT=BCNT+1 I BCNT>1 Q + . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X S:$L(X) BCNT=0 + K ^TMP("ORDATA",$J) + Q +RANGE(BEG) ;Get date range for report + ;BEG=# of days (T-BEG) for start default + ;Output: ORSSTRT=Start date/time + ; ORSSTOP=Stop date/time + ; OREND=1 if user '^'s out, so look for it! + S BEG=$$FMADD^XLFDT(DT,-$G(BEG)),END=$$NOW^XLFDT + D RANGE^ORPRS01(BEG,END) + Q +MED(MED) ; -- Medicine Summary of Patient Procedures + N DFN,Y,I,X,BCNT,OREND,PROCID + D TIT^ORCXPNDR("Summary of Patient Procedures") Q:$$OS^ORCXPNDR() + D PREP^ORCXPNDR + S DFN=+ID,PROCID=$P(MED,"~",2) + D RPT^ORWRP(.Y,DFN,19,,,PROCID) + D ITEM^ORCXPND("Summary of Patient Procedures") + S I=4,BCNT=0 + F S I=$O(^TMP("ORDATA",$J,1,I)) Q:I<1 S X=^(I) D + . I '$L(X) S BCNT=BCNT+1 I BCNT>1 Q + . I $E(X,1,4)="Pg. " Q + . I X["PHYSICIANS' SIGNATURE" Q + . S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X S:$L(X) BCNT=0 + K ^TMP("ORDATA",$J) + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD2.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD2.m index d659148b..1e186305 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD2.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD2.m @@ -1,4 +1,4 @@ -ORD2 ; DRIVER FOR COMPILED XREFS FOR FILE #100 ; 11/08/09 +ORD2 ; DRIVER FOR COMPILED XREFS FOR FILE #100 ; 12/25/06 ; N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2 I '$D(DIKSAT) S DIKLK=DIK_DA_")" L +@DIKLK:10 K:'$T DIKLK diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD21.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD21.m index 67f906da..ebbb7b78 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD21.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD21.m @@ -1,4 +1,4 @@ -ORD21 ; COMPILED XREF FOR FILE #100 ; 11/08/09 +ORD21 ; COMPILED XREF FOR FILE #100 ; 12/25/06 ; S DIKZK=2 S DIKZ(0)=$G(^OR(100,DA,0)) diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD210.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD210.m index a4d7bb6f..c5681dea 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD210.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD210.m @@ -1,4 +1,4 @@ -ORD210 ; COMPILED XREF FOR FILE #100.001 ; 11/08/09 +ORD210 ; COMPILED XREF FOR FILE #100.001 ; 12/25/06 ; S DA(1)=DA S DA=0 A1 ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD211.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD211.m index b8c560e7..684d0786 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD211.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD211.m @@ -1,4 +1,4 @@ -ORD211 ; COMPILED XREF FOR FILE #100.002 ; 11/08/09 +ORD211 ; COMPILED XREF FOR FILE #100.002 ; 12/25/06 ; S DA=0 A1 ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD212.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD212.m index e14135d1..21792e29 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD212.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD212.m @@ -1,4 +1,4 @@ -ORD212 ; COMPILED XREF FOR FILE #100.008 ; 11/08/09 +ORD212 ; COMPILED XREF FOR FILE #100.008 ; 12/25/06 ; S DA=0 A1 ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD213.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD213.m index 50c0ec93..348f012b 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD213.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD213.m @@ -1,4 +1,4 @@ -ORD213 ; COMPILED XREF FOR FILE #100.04 ; 11/08/09 +ORD213 ; COMPILED XREF FOR FILE #100.04 ; 12/25/06 ; S DA=0 A1 ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD214.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD214.m index 16ac0a22..82aa0bee 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD214.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD214.m @@ -1,4 +1,4 @@ -ORD214 ; COMPILED XREF FOR FILE #100.045 ; 11/08/09 +ORD214 ; COMPILED XREF FOR FILE #100.045 ; 12/25/06 ; S DA=0 A1 ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD215.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD215.m index 47777379..76a35b27 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD215.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD215.m @@ -1,4 +1,4 @@ -ORD215 ; COMPILED XREF FOR FILE #100.051 ; 11/08/09 +ORD215 ; COMPILED XREF FOR FILE #100.051 ; 12/25/06 ; S DA=0 A1 ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD216.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD216.m index 333fba8e..7c21d5b7 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD216.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD216.m @@ -1,4 +1,4 @@ -ORD216 ; COMPILED XREF FOR FILE #100.09 ; 11/08/09 +ORD216 ; COMPILED XREF FOR FILE #100.09 ; 12/25/06 ; S DA=0 A1 ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD22.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD22.m index 673babcd..69bdf34d 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD22.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD22.m @@ -1,4 +1,4 @@ -ORD22 ; COMPILED XREF FOR FILE #100.001 ; 11/08/09 +ORD22 ; COMPILED XREF FOR FILE #100.001 ; 12/25/06 ; S DA(1)=DA S DA=0 A1 ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD23.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD23.m index 986b7a70..ac7e4851 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD23.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD23.m @@ -1,4 +1,4 @@ -ORD23 ; COMPILED XREF FOR FILE #100.002 ; 11/08/09 +ORD23 ; COMPILED XREF FOR FILE #100.002 ; 12/25/06 ; S DA=0 A1 ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD24.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD24.m index b84aac7e..bed28a26 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD24.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD24.m @@ -1,4 +1,4 @@ -ORD24 ; COMPILED XREF FOR FILE #100.008 ; 11/08/09 +ORD24 ; COMPILED XREF FOR FILE #100.008 ; 12/25/06 ; S DA=0 A1 ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD25.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD25.m index 85ef9836..3b391bb7 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD25.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD25.m @@ -1,4 +1,4 @@ -ORD25 ; COMPILED XREF FOR FILE #100.04 ; 11/08/09 +ORD25 ; COMPILED XREF FOR FILE #100.04 ; 12/25/06 ; S DA=0 A1 ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD26.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD26.m index c81a5c48..d974ca79 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD26.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD26.m @@ -1,4 +1,4 @@ -ORD26 ; COMPILED XREF FOR FILE #100.045 ; 11/08/09 +ORD26 ; COMPILED XREF FOR FILE #100.045 ; 12/25/06 ; S DA=0 A1 ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD27.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD27.m index c020a9bf..8ca5db0d 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD27.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD27.m @@ -1,4 +1,4 @@ -ORD27 ; COMPILED XREF FOR FILE #100.051 ; 11/08/09 +ORD27 ; COMPILED XREF FOR FILE #100.051 ; 12/25/06 ; S DA=0 A1 ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD28.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD28.m index b338c237..5810d306 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD28.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD28.m @@ -1,4 +1,4 @@ -ORD28 ; COMPILED XREF FOR FILE #100.09 ; 11/08/09 +ORD28 ; COMPILED XREF FOR FILE #100.09 ; 12/25/06 ; S DA=0 A1 ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD29.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD29.m index 58d005eb..2e084ee8 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD29.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD29.m @@ -1,4 +1,4 @@ -ORD29 ; COMPILED XREF FOR FILE #100 ; 11/08/09 +ORD29 ; COMPILED XREF FOR FILE #100 ; 12/25/06 ; S DIKZK=1 S DIKZ(0)=$G(^OR(100,DA,0)) diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORDV03.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORDV03.m index 2b5f5d9e..aa74b688 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORDV03.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORDV03.m @@ -1,137 +1,119 @@ -ORDV03 ; slc/dcm - OE/RR Report Extracts ;10/8/03 11:17 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**109,208,215,243**;Dec 17, 1997;Build 242 -RI(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Radiology impression - ;External Calls: MAIN^GMTSRAE(1) - ; - ; ^TMP("GMTSRAD",$J) used via DBIA 4333 - ; ^TMP("RAE",$J) used via DBIA 3968 - N ORDT,ORX0,ORJ,ORCNT,GMDATA,GMTSI,GMW,MAX,TEST,GMTSNDM,GMTS1,GMTS2,ORSITE,SITE,GO - Q:'$L(OREXT) - S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) - Q:'$L($T(@GO)) - S IOST=$G(IOST),GMTSNDM=$S(+$G(ORMAX)>0:ORMAX,1:999),GMTS2=ORALPHA,GMTS1=OROMEGA - S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) - K ^TMP("ORDATA",$J),^TMP("RAE",$J) ;DBIA 3968 - D @GO - S ORDT=GMTS1,ORCNT=0 - F S ORDT=$O(^TMP("RAE",$J,ORDT)) Q:(ORDT'>0)!(ORDT>GMTS2) D - . S ORJ=0 F S ORJ=$O(^TMP("RAE",$J,ORDT,ORJ)) Q:'ORJ I $G(^(ORJ,0)) S ORX0=^(0) D - .. S ORCNT=ORCNT+1 - .. S SITE=$S($L($G(^TMP("RAE",$J,ORDT,ORJ,"facility"))):^("facility"),1:ORSITE) - .. S ^TMP("ORDATA",$J,ORCNT,"WP",1)="1^"_SITE ;Station ID - .. S ^TMP("ORDATA",$J,ORCNT,"WP",2)="2^"_$$DATE^ORDVU($P(ORX0,U)) ;date - .. S ^TMP("ORDATA",$J,ORCNT,"WP",3)="3^"_$P(ORX0,U,2) ;procedure - .. S ^TMP("ORDATA",$J,ORCNT,"WP",4)="4^"_$P(ORX0,U,4) ;report status - .. S ^TMP("ORDATA",$J,ORCNT,"WP",5)="5^"_$P(ORX0,U,7) ;cpt code - .. D SPMRG^ORDVU($NA(^TMP("RAE",$J,ORDT,ORJ,"I")),$NA(^TMP("ORDATA",$J,ORCNT,"WP",6)),6) ;impression - .. I $O(^TMP("RAE",$J,ORDT,ORJ,"I",0)) S ^TMP("ORDATA",$J,ORCNT,"WP",8)="8^[+]" ;flag for detail - K ^TMP("RAE",$J) - S ROOT=$NA(^TMP("ORDATA",$J)) - Q -RR(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Radiology report - ;External Calls: MAIN^GMTSRAE(2) - I $L($T(GCPR^OMGCOAS1)) D ; Call if FHIE station 200 - . N BEG,END,MAX - . Q:'$G(ORALPHA) Q:'$G(OROMEGA) - . S MAX=$S(+$G(ORMAX)>0:ORMAX,1:999) - . S BEG=9999999-OROMEGA,END=9999999-ORALPHA - . D GCPR^OMGCOAS1(DFN,"RR",BEG,END,MAX) - N ORDT,ORX0,ORJ,ORCNT,GMDATA,GMTSI,GMW,MAX,TEST,GMTSNDM,GMTS1,GMTS2,ORSITE,SITE,GO,ORMORE - Q:'$L(OREXT) - S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) - Q:'$L($T(@GO)) - K ^TMP("ORDATA",$J) - S GMTSNDM=$S(+$G(ORMAX)>0:ORMAX,1:999),GMTS1=OROMEGA,GMTS2=ORALPHA - S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) - I '$L($T(GCPR^OMGCOAS1)) D - . K ^TMP("RAE",$J) - . D @GO - S ORDT=GMTS1,ORCNT=0 - F S ORDT=$O(^TMP("RAE",$J,ORDT)) Q:(ORDT'>0) D - . S ORJ=0 F S ORJ=$O(^TMP("RAE",$J,ORDT,ORJ)) Q:'ORJ D - .. S ORCNT=ORCNT+1,ORMORE=0 - .. S ORX0=$G(^TMP("RAE",$J,ORDT,ORJ,0)) - .. S SITE=$S($L($G(^TMP("RAE",$J,ORDT,ORJ,"facility"))):^("facility"),1:ORSITE) - .. S ^TMP("ORDATA",$J,ORCNT,"WP",1)="1^"_SITE ;Site ID - .. S ^TMP("ORDATA",$J,ORCNT,"WP",2)="2^"_$$DATE^ORDVU($P(ORX0,U)) ;date - .. S ^TMP("ORDATA",$J,ORCNT,"WP",3)="3^"_$P(ORX0,U,2) ;procedure - .. S ^TMP("ORDATA",$J,ORCNT,"WP",4)="4^"_$S($L($P(ORX0,U,4)):$P(ORX0,U,4),1:"No Report") ;report status - .. S ^TMP("ORDATA",$J,ORCNT,"WP",5)="5^"_$P(ORX0,U,7) ;cpt code - .. I $O(^TMP("RAE",$J,ORDT,ORJ,"S",0)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("RAE",$J,ORDT,ORJ,"S")),$NA(^TMP("ORDATA",$J,ORCNT,"WP",6,1)),6) ;reason for study - .. I $O(^TMP("RAE",$J,ORDT,ORJ,"H",0)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("RAE",$J,ORDT,ORJ,"H")),$NA(^TMP("ORDATA",$J,ORCNT,"WP",7,1)),7) ;clinical history - .. I $O(^TMP("RAE",$J,ORDT,ORJ,"I",0)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("RAE",$J,ORDT,ORJ,"I")),$NA(^TMP("ORDATA",$J,ORCNT,"WP",8,1)),8) ;impression - .. I $O(^TMP("RAE",$J,ORDT,ORJ,"R",0)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("RAE",$J,ORDT,ORJ,"R")),$NA(^TMP("ORDATA",$J,ORCNT,"WP",9,1)),9) ;report - .. I ORMORE S ^TMP("ORDATA",$J,ORCNT,"WP",10)="10^[+]" ;flag for detail - K ^TMP("RAE",$J) - S ROOT=$NA(^TMP("ORDATA",$J)) - Q -RRDOD(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Radiology report - ;External Calls: MAIN^GMTSRAE(2) - ; - I $L($T(GCPR^OMGCOAS1)) D ; Call if FHIE station 200 - . N BEG,END,MAX - . Q:'$G(ORALPHA) Q:'$G(OROMEGA) - . S MAX=$S(+$G(ORMAX)>0:ORMAX,1:999) - . S BEG=9999999-OROMEGA,END=9999999-ORALPHA - . D GCPR^OMGCOAS1(DFN,"RR",BEG,END,MAX) - ; - N ORDT,ORX0,ORJ,ORCNT,GMDATA,GMTSI,GMW,MAX,TEST,GMTSNDM,GMTS1,GMTS2,ORSITE,SITE,GO,ORMORE - Q:'$L(OREXT) - S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) - Q:'$L($T(@GO)) - K ^TMP("ORDATA",$J) - S GMTSNDM=$S(+$G(ORMAX)>0:ORMAX,1:999),GMTS1=OROMEGA,GMTS2=ORALPHA - S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) - I '$L($T(GCPR^OMGCOAS1)) D - . K ^TMP("RAE",$J) - . D @GO - S ORDT=GMTS1,ORCNT=0 - F S ORDT=$O(^TMP("RAE",$J,ORDT)) Q:(ORDT'>0) D - . S ORJ=0 F S ORJ=$O(^TMP("RAE",$J,ORDT,ORJ)) Q:'ORJ D - .. S ORCNT=ORCNT+1,ORMORE=0 - .. S ORX0=$G(^TMP("RAE",$J,ORDT,ORJ,0)) - .. S SITE=$S($L($G(^TMP("RAE",$J,ORDT,ORJ,"facility"))):^("facility"),1:ORSITE) - .. S ^TMP("ORDATA",$J,ORCNT,"WP",1)="1^"_SITE ;Site ID - .. S ^TMP("ORDATA",$J,ORCNT,"WP",2)="2^"_$$DATE^ORDVU($P(ORX0,U)) ;date - .. S ^TMP("ORDATA",$J,ORCNT,"WP",3)="3^"_$P(ORX0,U,2) ;procedure - .. S ^TMP("ORDATA",$J,ORCNT,"WP",4)="4^"_$S($L($P(ORX0,U,4)):$P(ORX0,U,4),1:"No Report") ;report status - .. S ^TMP("ORDATA",$J,ORCNT,"WP",5)="5^"_$P(ORX0,U,7) ;cpt code - .. I $O(^TMP("RAE",$J,ORDT,ORJ,"H",0)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("RAE",$J,ORDT,ORJ,"H")),$NA(^TMP("ORDATA",$J,ORCNT,"WP",6,1)),6) ;clinical history - .. I $O(^TMP("RAE",$J,ORDT,ORJ,"I",0)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("RAE",$J,ORDT,ORJ,"I")),$NA(^TMP("ORDATA",$J,ORCNT,"WP",7,1)),7) ;impression - .. I $O(^TMP("RAE",$J,ORDT,ORJ,"R",0)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("RAE",$J,ORDT,ORJ,"R")),$NA(^TMP("ORDATA",$J,ORCNT,"WP",8,1)),8) ;report - .. I ORMORE S ^TMP("ORDATA",$J,ORCNT,"WP",9)="9^[+]" ;flag for detail - K ^TMP("RAE",$J) - S ROOT=$NA(^TMP("ORDATA",$J)) - Q -RS(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Radiology status - ;External calls: GET^GMTSRAD - N ORSITE,SITE,CNT,ORDT,ORDA,ORDA2,REC,GMTSEND,GMTSBEG,GO,STAT - Q:'$L(OREXT) - S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) - Q:'$L($T(@GO)) - S GMTSBEG=ORDBEG,GMTSEND=ORDEND - S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) - K ^TMP("GMTSRAD",$J) ;DBIA 4333 - D @GO - S CNT=0,ORDT=OROMEGA - F S ORDT=$O(^TMP("GMTSRAD",$J,ORDT)) Q:(ORDT'>0)!(ORDT>ORALPHA)!(CNT'0:ORMAX,1:999) + . S BEG=9999999-OROMEGA,END=9999999-ORALPHA + . D GCPR^OMGCOAS1(DFN,"RI",BEG,END,MAX) + ; + N ORDT,ORX0,ORJ,ORCNT,GMDATA,GMTSI,GMW,MAX,TEST,GMTSNDM,GMTS1,GMTS2,ORSITE,SITE,GO + Q:'$L(OREXT) + S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) + Q:'$L($T(@GO)) + S IOST=$G(IOST),GMTSNDM=$S(+$G(ORMAX)>0:ORMAX,1:999),GMTS2=ORALPHA,GMTS1=OROMEGA + S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) + K ^TMP("ORDATA",$J) + I '$L($T(GCPR^OMGCOAS1)) D + . K ^TMP("RAE",$J) ;DBIA 3968 + . D @GO + S ORDT=GMTS1,ORCNT=0 + F S ORDT=$O(^TMP("RAE",$J,ORDT)) Q:(ORDT'>0)!(ORDT>GMTS2) D + . S ORJ=0 F S ORJ=$O(^TMP("RAE",$J,ORDT,ORJ)) Q:'ORJ I $G(^(ORJ,0)) S ORX0=^(0) D + .. S ORCNT=ORCNT+1 + .. S SITE=$S($L($G(^TMP("RAE",$J,ORDT,ORJ,"facility"))):^("facility"),1:ORSITE) + .. S ^TMP("ORDATA",$J,ORCNT,"WP",1)="1^"_SITE ;Station ID + .. S ^TMP("ORDATA",$J,ORCNT,"WP",2)="2^"_$$DATE^ORDVU($P(ORX0,U)) ;date + .. S ^TMP("ORDATA",$J,ORCNT,"WP",3)="3^"_$P(ORX0,U,2) ;procedure + .. S ^TMP("ORDATA",$J,ORCNT,"WP",4)="4^"_$P(ORX0,U,4) ;report status + .. S ^TMP("ORDATA",$J,ORCNT,"WP",5)="5^"_$P(ORX0,U,7) ;cpt code + .. D SPMRG^ORDVU($NA(^TMP("RAE",$J,ORDT,ORJ,"I")),$NA(^TMP("ORDATA",$J,ORCNT,"WP",6)),6) ;impression + .. I $O(^TMP("RAE",$J,ORDT,ORJ,"I",0)) S ^TMP("ORDATA",$J,ORCNT,"WP",8)="8^[+]" ;flag for detail + K ^TMP("RAE",$J) + S ROOT=$NA(^TMP("ORDATA",$J)) + Q +RR(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Radiology report + ;External Calls: MAIN^GMTSRAE(2) + ; + I $L($T(GCPR^OMGCOAS1)) D ; Call if FHIE station 200 + . N BEG,END,MAX + . Q:'$G(ORALPHA) Q:'$G(OROMEGA) + . S MAX=$S(+$G(ORMAX)>0:ORMAX,1:999) + . S BEG=9999999-OROMEGA,END=9999999-ORALPHA + . D GCPR^OMGCOAS1(DFN,"RR",BEG,END,MAX) + ; + N ORDT,ORX0,ORJ,ORCNT,GMDATA,GMTSI,GMW,MAX,TEST,GMTSNDM,GMTS1,GMTS2,ORSITE,SITE,GO,ORMORE + Q:'$L(OREXT) + S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) + Q:'$L($T(@GO)) + K ^TMP("ORDATA",$J) + S GMTSNDM=$S(+$G(ORMAX)>0:ORMAX,1:999),GMTS1=OROMEGA,GMTS2=ORALPHA + S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) + I '$L($T(GCPR^OMGCOAS1)) D + . K ^TMP("RAE",$J) + . D @GO + S ORDT=GMTS1,ORCNT=0 + F S ORDT=$O(^TMP("RAE",$J,ORDT)) Q:(ORDT'>0) D + . S ORJ=0 F S ORJ=$O(^TMP("RAE",$J,ORDT,ORJ)) Q:'ORJ D + .. S ORCNT=ORCNT+1,ORMORE=0 + .. S ORX0=$G(^TMP("RAE",$J,ORDT,ORJ,0)) + .. S SITE=$S($L($G(^TMP("RAE",$J,ORDT,ORJ,"facility"))):^("facility"),1:ORSITE) + .. S ^TMP("ORDATA",$J,ORCNT,"WP",1)="1^"_SITE ;Site ID + .. S ^TMP("ORDATA",$J,ORCNT,"WP",2)="2^"_$$DATE^ORDVU($P(ORX0,U)) ;date + .. S ^TMP("ORDATA",$J,ORCNT,"WP",3)="3^"_$P(ORX0,U,2) ;procedure + .. S ^TMP("ORDATA",$J,ORCNT,"WP",4)="4^"_$S($L($P(ORX0,U,4)):$P(ORX0,U,4),1:"No Report") ;report status + .. S ^TMP("ORDATA",$J,ORCNT,"WP",5)="5^"_$P(ORX0,U,7) ;cpt code + .. I $O(^TMP("RAE",$J,ORDT,ORJ,"H",0)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("RAE",$J,ORDT,ORJ,"H")),$NA(^TMP("ORDATA",$J,ORCNT,"WP",6,1)),6) ;clinical history + .. I $O(^TMP("RAE",$J,ORDT,ORJ,"I",0)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("RAE",$J,ORDT,ORJ,"I")),$NA(^TMP("ORDATA",$J,ORCNT,"WP",7,1)),7) ;impression + .. I $O(^TMP("RAE",$J,ORDT,ORJ,"R",0)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("RAE",$J,ORDT,ORJ,"R")),$NA(^TMP("ORDATA",$J,ORCNT,"WP",8,1)),8) ;report + .. I ORMORE S ^TMP("ORDATA",$J,ORCNT,"WP",9)="9^[+]" ;flag for detail + K ^TMP("RAE",$J) + S ROOT=$NA(^TMP("ORDATA",$J)) + Q +RS(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Radiology status + ;External calls: GET^GMTSRAD + ; + I $L($T(GCPR^OMGCOAS1)) D ; Call if FHIE station 200 + . N BEG,END,MAX + . Q:'$G(ORALPHA) Q:'$G(OROMEGA) + . S MAX=$S(+$G(ORMAX)>0:ORMAX,1:999) + . S BEG=9999999-OROMEGA,END=9999999-ORALPHA + . D GCPR^OMGCOAS1(DFN,"RS",BEG,END,MAX) + ; + N ORSITE,SITE,CNT,ORDT,ORDA,ORDA2,REC,GMTSEND,GMTSBEG,GO,STAT + Q:'$L(OREXT) + S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) + Q:'$L($T(@GO)) + S GMTSBEG=ORDBEG,GMTSEND=ORDEND + S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) + I '$L($T(GCPR^OMGCOAS1)) D + . K ^TMP("GMTSRAD",$J) ;DBIA 4333 + . D @GO + S CNT=0,ORDT=OROMEGA + F S ORDT=$O(^TMP("GMTSRAD",$J,ORDT)) Q:(ORDT'>0)!(ORDT>ORALPHA)!(CNT'ORMAX) D ;DBIA 10061 + . S SITE=$S($L($G(^TMP("GMRVD",$J,ORDT,"facility"))):^("facility"),1:ORSITE) ;DBIA 10061 + . S ^TMP("ORDATA",$J,"WP",ORDT,1)="1^"_SITE + . S ^TMP("ORDATA",$J,"WP",ORDT,2)="2^"_$$DATE^ORDVU(9999999-ORDT) ;date vitals taken + . S TYPE="" + . F S TYPE=$O(^UTILITY($J,"GMRVD",ORDT,TYPE)) Q:TYPE="" D + .. S IEN=$O(^UTILITY($J,"GMRVD",ORDT,TYPE,0)) Q:'IEN + .. S PLACE=$S(TYPE="T":3,TYPE="P":4,TYPE="R":5,TYPE="BP":6,TYPE="HT":7,TYPE="WT":8,TYPE="PN":9,TYPE="PO2":10,TYPE="CVP":11,TYPE="CG":12,1:13) + .. S ^TMP("ORDATA",$J,"WP",ORDT,PLACE)=PLACE_"^"_$P($G(^UTILITY($J,"GMRVD",ORDT,TYPE,IEN)),"^",8) ;Get value of vitals from global + K ^UTILITY($J,"GMRVD") + S ROOT=$NA(^TMP("ORDATA",$J)) + Q +TIUPRG(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ; TIU version of progress reports + ;External calls to TIUSRVLO,TIUSRVR1,VASITE + I $L($T(GCPR^OMGCOAS1)) D Q ; Call if FHIE station 200 + . D GCPR^OMGCOAS1(DFN,"PN",ORDBEG,ORDEND,ORMAX) + . S ROOT=$NA(^TMP("ORDATA",$J)) + N ORDT,DATE,ORCI,ORGLOB,ORGLOBA,ORTEMP,ORSITE,SITE,I,ORNODE,GO,ORIMAG + Q:'$L(OREXT) + S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) + Q:'$L($T(@GO)) + S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) + D @GO + I '$D(@ORGLOB) Q + S ORNODE=0,ORCI=0 + K ^TMP("ORDATA",$J) + F S ORNODE=$O(@ORGLOB@(ORNODE)) Q:'ORNODE!(ORCI'0 D SORT - I '$D(SURG) Q - S GMIDT=0 F S GMIDT=$O(SURG(GMIDT)) Q:GMIDT'>0!(ORCNT'ORDBEG&(GMDT0 S Y=X,C=$P(^DD(130,.04,0),U,2) D Y^DIQ S SPEC=Y K Y - I $D(^SRF(GMN,.1)) S X=$P(^SRF(GMN,.1),U,4) I X>0 S Y=X,C=$P(^DD(130,.14,0),U,2) D Y^DIQ S SURGEON=Y K Y - S VER=$S($G(^SRF(GMN,"VER"))'="Y":"(Unverified)",1:"") - S PREDX(0)=$S($G(^SRF(GMN,33))]"":$P(^(33),U),1:"") S GMI=0 F S GMI=$O(^SRF(GMN,14,GMI)) Q:GMI'>0 S PREDX(GMI)=$P(^SRF(GMN,14,GMI,0),U) - S POSDX(0)=$S($G(^SRF(GMN,34))]"":$P(^(34),U),1:"") S GMI=0 F S GMI=$O(^SRF(GMN,15,GMI)) Q:GMI'>0 S POSDX(GMI)=$P(^SRF(GMN,15,GMI,0),U) - S OPPRC(0)=$P($G(^SRF(GMN,"OP")),U,1,2) S:$P(OPPRC(0),U,2)]"" $P(OPPRC(0),U,2)=$P($$CPT^ICPTCOD($P($G(^SRF(GMN,"OP")),U,2)),U,3) D - . S GMI=0 F S GMI=$O(^SRF(GMN,13,GMI)) Q:GMI'>0 S OPPRC(GMI)=$P($G(^SRF(GMN,13,GMI,0)),U)_U_$G(^SRF(GMN,13,GMI,2)) S:$P(OPPRC(GMI),U,2)]"" $P(OPPRC(GMI),U,2)=$P($$CPT^ICPTCOD($P($G(^SRF(GMN,13,GMI,2)),U)),U,3) - S X=$P($G(^SRF(GMN,31)),U,6) S:X>0 DCTDTM=$$DATE^ORDVU(X) - S X=$P($G(^SRF(GMN,31)),U,7) S:X>0 TRSDTM=$$DATE^ORDVU(X) - S DIWL=0,DIWF="N",ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) - K ^UTILITY($J,"W") - I $D(^SRF(GMN,12)) F GMI=1:1:$P(^SRF(GMN,12,0),U,4) S X=^SRF(GMN,12,GMI,0) D ^DIWP - S SITE=ORSITE - S ^TMP("ORDATA",$J,GMIDT,"WP",1)="1^"_SITE ;Station ID - S ^TMP("ORDATA",$J,GMIDT,"WP",2)="2^"_GMDT ; date - ; - ; Operative Procedure(s) - S GMI="" F S GMI=$O(OPPRC(GMI)) Q:GMI="" D S:GMI ORMORE=1 - . S ^TMP("ORDATA",$J,GMIDT,"WP",3,GMI)="3^"_$P(OPPRC(GMI),U)_$S($P(OPPRC(GMI),U,2)]"":" - "_$P(OPPRC(GMI),U,2),1:"") - ; - S ^TMP("ORDATA",$J,GMIDT,"WP",4)="4^"_$G(SPEC) ;surgical specialty - ; - S ^TMP("ORDATA",$J,GMIDT,"WP",5)="5^"_$G(SURGEON) ; surgeon - S ^TMP("ORDATA",$J,GMIDT,"WP",6)="6^"_$G(STATUS) ; op status - ; - ; Pre-operative diagnosis - S GMI="" F S GMI=$O(PREDX(GMI)) Q:GMI="" D S:GMI ORMORE=1 - . S ^TMP("ORDATA",$J,GMIDT,"WP",7,GMI)="7^"_PREDX(GMI) - ; - ; Post-operative diagnosis - S GMI="" F S GMI=$O(POSDX(GMI)) Q:GMI="" D S:GMI ORMORE=1 - . S ^TMP("ORDATA",$J,GMIDT,"WP",8,GMI)="8^"_POSDX(GMI) - ; - ; Lab work? Y/N - S ^TMP("ORDATA",$J,GMIDT,"WP",9)="9^"_$S($O(^SRF(GMN,9,0)):"Yes",1:"No") - S ^TMP("ORDATA",$J,GMIDT,"WP",10)="10^"_$G(DCTDTM) ; dictation time - S ^TMP("ORDATA",$J,GMIDT,"WP",11)="11^"_$G(TRSDTM) ; transcription time - ; - ; surgeon's dictation - I $D(^UTILITY($J,"W")) D S ORMORE=1 - . K ^TMP("ORHSSRT",$J) - . F GMI=1:1:^UTILITY($J,"W",DIWL) D - .. S ^TMP("ORHSSRT",$J,GMIDT,"WP",GMI)=^UTILITY($J,"W",DIWL,GMI,0) - . D SPMRG^ORDVU($NA(^TMP("ORHSSRT",$J,GMIDT,"WP")),$NA(^TMP("ORDATA",$J,GMIDT,"WP",12)),12) - . K ^UTILITY($J,"W") - . K ^TMP("ORHSSRT",$J) - I ORMORE S ^TMP("ORDATA",$J,GMIDT,"WP",13)="13^[+]" ;flag for detail - Q -VS ;Continuation of Vitals Extract (from ORDV04) - ;Calls GMRVUT0 - I $L($T(GCPR^OMGCOAS1)) D Q ; OMGCOAS1 routine only on Station 200 - . D GCPR^OMGCOAS1(DFN,"VIT",ORDBEG,ORDEND,ORMAX) - . S ROOT=$NA(^TMP("ORDATA",$J)) - N ORDT,I,TYPE,IEN,GMRVSTR,ORSITE,SITE,PLACE,GO,X,QUALIF,NODE,UNITS,UCNT,QCNT,ORI - Q:'$L(OREXT) - S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) - Q:'$L($T(@GO)) - K ^UTILITY($J,"GMRVD"),^TMP("ORDATA",$J) - S GMRVSTR="T;P;R;BP;HT;WT;PN;PO2;CVP;CG",GMRVSTR(0)=ORDBEG_"^"_ORDEND_"^"_ORMAX_"^"_1 - S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) - D @GO - S ORDT=0 - F I=1:1 S ORDT=$O(^UTILITY($J,"GMRVD",ORDT)) Q:'+ORDT!(I>ORMAX) D ;DBIA 4791 - . S SITE=$S($L($G(^TMP("GMRVD",$J,ORDT,"facility"))):^("facility"),1:ORSITE) - . S ^TMP("ORDATA",$J,"WP",ORDT,1)="1^"_SITE - . S ^TMP("ORDATA",$J,"WP",ORDT,2)="2^"_$$DATE^ORDVU(9999999-ORDT) ;date vitals taken - . K UNITS,QUALIF - . S TYPE="",(UCNT,QCNT)=1,UNITS(UCNT)="",QUALIF(QCNT)="",QUALIF="" - . F S TYPE=$O(^UTILITY($J,"GMRVD",ORDT,TYPE)) Q:TYPE="" D - .. S IEN=$O(^UTILITY($J,"GMRVD",ORDT,TYPE,0)) Q:'IEN S NODE=$G(^(IEN)) - .. S PLACE=$S(TYPE="T":3,TYPE="P":4,TYPE="R":5,TYPE="BP":6,TYPE="HT":7,TYPE="WT":8,TYPE="PN":9,TYPE="PO2":10,TYPE="CVP":11,TYPE="CG":12,1:0) - .. I PLACE S ^TMP("ORDATA",$J,"WP",ORDT,PLACE)=PLACE_"^"_$P(NODE,"^",8) ;Get value of vitals from global - .. S X=$$UNITMAP(TYPE) S:$L(UNITS(UCNT))>60 UCNT=UCNT+1,UNITS(UCNT)="" S UNITS(UCNT)=$S($L(UNITS(UCNT)):UNITS(UCNT)_","_$$MAP(TYPE)_":",1:$$MAP(TYPE)_":")_X ;Units - .. I TYPE="PO2" D - ... I $L($P(NODE,"^",15)) S ^TMP("ORDATA",$J,"WP",ORDT,13)=13_"^"_$P($G(^UTILITY($J,"GMRVD",ORDT,TYPE,IEN)),"^",15) ; Flow Rate - ... I $L($P(NODE,"^",16)) S ^TMP("ORDATA",$J,"WP",ORDT,14)=14_"^"_$P($G(^UTILITY($J,"GMRVD",ORDT,TYPE,IEN)),"^",16) ; O2 Concentration - .. I $L($P(NODE,"^",17)) S X=$P(NODE,"^",17) D - ... I QUALIF'[($$MAP(TYPE)_":"_X) D - .... S QUALIF=$S($L(QUALIF):QUALIF_" , "_$$MAP(TYPE)_":",1:$$MAP(TYPE)_":")_X ; Qualifier - .... S:$L(QUALIF(QCNT))>60 QCNT=QCNT+1,QUALIF(QCNT)="" - .... S QUALIF(QCNT)=$S($L(QUALIF(QCNT)):QUALIF(QCNT)_" , "_$$MAP(TYPE)_":",1:$$MAP(TYPE)_":")_X ; Qualifier - .. I TYPE="WT",$L($P(NODE,"^",14)) D - ... S ^TMP("ORDATA",$J,"WP",ORDT,16)=16_"^"_$P(NODE,"^",14) ; BMI - . I $O(QUALIF(0)) D - .. S ORI=0 F S ORI=$O(QUALIF(ORI)) Q:'ORI D - ... S ^TMP("ORDATA",$J,"WP",ORDT,15,ORI)="15^"_QUALIF(ORI) - . I $O(UNITS(0)) D - .. S ORI=0 F S ORI=$O(UNITS(ORI)) Q:'ORI D - ... S ^TMP("ORDATA",$J,"WP",ORDT,17,ORI)="17^"_UNITS(ORI) - K ^UTILITY($J,"GMRVD") - S ROOT=$NA(^TMP("ORDATA",$J)) - Q -MAP(TEXT) ;Map test code to abbreviation - Q:'$L($G(TEXT)) "" - I TEXT="T" Q "TEMP" - I TEXT="P" Q "PULSE" - I TEXT="R" Q "RESP" - I TEXT="BP" Q "BP" - I TEXT="HT" Q "HT" - I TEXT="WT" Q "WT" - I TEXT="PN" Q "PAIN" - I TEXT="PO2" Q "POx" - I TEXT="CVP" Q "CVP" - I TEXT="CG" Q "C/G" - Q TEXT -UNITMAP(TEXT) ;Map units to abbreviation - Q:'$L($G(TEXT)) "" - I TEXT="T" Q "F" - I TEXT="P" Q "/min" - I TEXT="R" Q " /min" - I TEXT="BP" Q "mmHg" - I TEXT="HT" Q "in" - I TEXT="WT" Q "lb" - I TEXT="PN" Q "" - I TEXT="PO2" Q "%SpO2" - I TEXT="CVP" Q "cmH2O" - I TEXT="CG" Q " in" - Q "" +ORDV04A ;SLC/DAN - OE/RR ;7/30/01 14:33 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**109**;Dec 17,1997 + ; + Q +ENSR ; Entry point for component + ;External calls to ^GMTSROB, ^DIQ, ^GMTSORC, ^DIWP + ;External references to ^SRF, ^DD, ^ICPT + N GMIDT,GMN,SURG + I '$D(^SRF("B",DFN)) Q + S GMN=0 F S GMN=$O(^SRF("B",DFN,GMN)) Q:GMN'>0 D SORT + I '$D(SURG) Q + S GMIDT=0 F S GMIDT=$O(SURG(GMIDT)) Q:GMIDT'>0!(ORCNT'ORDBEG&(GMDT0 S Y=X,C=$P(^DD(130,.04,0),U,2) D Y^DIQ S SPEC=Y K Y + I $D(^SRF(GMN,.1)) S X=$P(^SRF(GMN,.1),U,4) I X>0 S Y=X,C=$P(^DD(130,.14,0),U,2) D Y^DIQ S SURGEON=Y K Y + S VER=$S($G(^SRF(GMN,"VER"))'="Y":"(Unverified)",1:"") + S PREDX(0)=$S($G(^SRF(GMN,33))]"":$P(^(33),U),1:"") S GMI=0 F S GMI=$O(^SRF(GMN,14,GMI)) Q:GMI'>0 S PREDX(GMI)=$P(^SRF(GMN,14,GMI,0),U) + S POSDX(0)=$S($G(^SRF(GMN,34))]"":$P(^(34),U),1:"") S GMI=0 F S GMI=$O(^SRF(GMN,15,GMI)) Q:GMI'>0 S POSDX(GMI)=$P(^SRF(GMN,15,GMI,0),U) + S OPPRC(0)=$P($G(^SRF(GMN,"OP")),U,1,2) S:$P(OPPRC(0),U,2)]"" $P(OPPRC(0),U,2)=$P($$CPT^ICPTCOD($P($G(^SRF(GMN,"OP")),U,2)),U,3) D + . S GMI=0 F S GMI=$O(^SRF(GMN,13,GMI)) Q:GMI'>0 S OPPRC(GMI)=$P($G(^SRF(GMN,13,GMI,0)),U)_U_$G(^SRF(GMN,13,GMI,2)) S:$P(OPPRC(GMI),U,2)]"" $P(OPPRC(GMI),U,2)=$P($$CPT^ICPTCOD($P($G(^SRF(GMN,13,GMI,2)),U)),U,3) + S X=$P($G(^SRF(GMN,31)),U,6) S:X>0 DCTDTM=$$DATE^ORDVU(X) + S X=$P($G(^SRF(GMN,31)),U,7) S:X>0 TRSDTM=$$DATE^ORDVU(X) + S DIWL=0,DIWF="N",ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) + K ^UTILITY($J,"W") + I $D(^SRF(GMN,12)) F GMI=1:1:$P(^SRF(GMN,12,0),U,4) S X=^SRF(GMN,12,GMI,0) D ^DIWP + S SITE=ORSITE + S ^TMP("ORDATA",$J,GMIDT,"WP",1)="1^"_SITE ;Station ID + S ^TMP("ORDATA",$J,GMIDT,"WP",2)="2^"_GMDT ; date + ; + ; Operative Procedure(s) + S GMI="" F S GMI=$O(OPPRC(GMI)) Q:GMI="" D S:GMI ORMORE=1 + . S ^TMP("ORDATA",$J,GMIDT,"WP",3,GMI)="3^"_$P(OPPRC(GMI),U)_$S($P(OPPRC(GMI),U,2)]"":" - "_$P(OPPRC(GMI),U,2),1:"") + ; + S ^TMP("ORDATA",$J,GMIDT,"WP",4)="4^"_$G(SPEC) ;surgical specialty + ; + S ^TMP("ORDATA",$J,GMIDT,"WP",5)="5^"_$G(SURGEON) ; surgeon + S ^TMP("ORDATA",$J,GMIDT,"WP",6)="6^"_$G(STATUS) ; op status + ; + ; Pre-operative diagnosis + S GMI="" F S GMI=$O(PREDX(GMI)) Q:GMI="" D S:GMI ORMORE=1 + . S ^TMP("ORDATA",$J,GMIDT,"WP",7,GMI)="7^"_PREDX(GMI) + ; + ; Post-operative diagnosis + S GMI="" F S GMI=$O(POSDX(GMI)) Q:GMI="" D S:GMI ORMORE=1 + . S ^TMP("ORDATA",$J,GMIDT,"WP",8,GMI)="8^"_POSDX(GMI) + ; + ; Lab work? Y/N + S ^TMP("ORDATA",$J,GMIDT,"WP",9)="9^"_$S($O(^SRF(GMN,9,0)):"Yes",1:"No") + S ^TMP("ORDATA",$J,GMIDT,"WP",10)="10^"_$G(DCTDTM) ; dictation time + S ^TMP("ORDATA",$J,GMIDT,"WP",11)="11^"_$G(TRSDTM) ; transcription time + ; + ; surgeon's dictation + I $D(^UTILITY($J,"W")) D S ORMORE=1 + . K ^TMP("ORHSSRT",$J) + . F GMI=1:1:^UTILITY($J,"W",DIWL) D + .. S ^TMP("ORHSSRT",$J,GMIDT,"WP",GMI)=^UTILITY($J,"W",DIWL,GMI,0) + . D SPMRG^ORDVU($NA(^TMP("ORHSSRT",$J,GMIDT,"WP")),$NA(^TMP("ORDATA",$J,GMIDT,"WP",12)),12) + . K ^UTILITY($J,"W") + . K ^TMP("ORHSSRT",$J) + I ORMORE S ^TMP("ORDATA",$J,GMIDT,"WP",13)="13^[+]" ;flag for detail + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORDV06.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORDV06.m index 82b17ca5..78a7b7a9 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORDV06.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORDV06.m @@ -1,135 +1,136 @@ -ORDV06 ; slc/dkm - OE/RR Report Extracts ;10/8/03 11:17 - ;;3.0;ORDER ENTRY RESULTS REPORTING;**109,118,167,208,215,274,243**;Dec 17, 1997;Build 242 - ;Pharmacy Extracts -RXA(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Active Outpatient Pharmacy - ;Call to PSOHCSUM - ; - I $L($T(GCPR^OMGCOAS1)) D ; Call if FHIE station 200 - . N BEG,END,MAX - . S BEG=0,END=9999999,MAX=9999 - . D GCPR^OMGCOAS1(DFN,"RXA",BEG,END,MAX) - ; - N ORRXSTAT,GO,PSOACT - Q:'$L(OREXT) - S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) - Q:'$L($T(@GO)) - S PSOACT=1,ORRXSTAT="^ACTIVE^ACTIVE/SUSP^" - D GET - Q -RXOP(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;All Outpatient Pharmacy - ;Call to PSOHCSUM - ; - I $L($T(GCPR^OMGCOAS1)) D ; Call if FHIE station 200 - . N BEG,END,MAX - . S BEG=0,END=9999999,MAX=9999 - . D GCPR^OMGCOAS1(DFN,"RXOP",BEG,END,MAX) - ; - N ORRXSTAT,GO - Q:'$L(OREXT) - S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) - Q:'$L($T(@GO)) - S ORRXSTAT="" - D GET - Q -GET N J,ORDT,ORI,ORDRGIEN,ORDRG,ORRXNO,ORSTAT,ORQTY,OREXP,ORISSUE,ORLAST,ORREF,ORPRVD,ORCOST,ORSIG - N ECD,GMR,GMW,IX,PSOBEGIN,GMTSNDM,GMTS1,GMTS2,ORSITE,SITE - S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) - S PSOBEGIN=0 - K ^TMP("ORDATA",$J) - I '$L($T(GCPR^OMGCOAS1)) D - . K ^TMP("PSOO",$J) - . D @GO - S (ORDT,ORI)=0 - F S ORDT=$O(^TMP("PSOO",$J,ORDT)) Q:(ORDT'>0) S ORX0=$G(^(ORDT,0)) I ORX0'="" D - . I $L(ORRXSTAT),ORRXSTAT'[(U_$P($P(ORX0,U,5),";",2)) Q ;Check status - . S ORI=ORI+1 - . S SITE=$S($L($G(^TMP("PSOO",$J,ORDT,"facility"))):^("facility"),1:ORSITE) - . S ^TMP("ORDATA",$J,ORDT,"WP",1)="1^"_SITE ;Station ID - . S ^TMP("ORDATA",$J,ORDT,"WP",2)="2^"_$P($P(ORX0,U,3),";",2) ;Drug Name - . S ^TMP("ORDATA",$J,ORDT,"WP",3)="3^"_$P($P(ORX0,U,3),";") ;Drug IEN - . S ^TMP("ORDATA",$J,ORDT,"WP",4)="4^"_$P(ORX0,U,6) ;RX # - . S ^TMP("ORDATA",$J,ORDT,"WP",5)="5^"_$P($P(ORX0,U,5),";",2) ;Status - . S ^TMP("ORDATA",$J,ORDT,"WP",6)="6^"_$P(ORX0,U,7) ;Quantity - . S ^TMP("ORDATA",$J,ORDT,"WP",7)="7^"_$$DATE^ORDVU($P(ORX0,U,11)) ;Exp/Cancel Date - . S ^TMP("ORDATA",$J,ORDT,"WP",8)="8^"_$$DATE^ORDVU($P(ORX0,U)) ;Issue Date - . S ^TMP("ORDATA",$J,ORDT,"WP",9)="9^"_$$DATE^ORDVU($P(ORX0,U,2)) ;Last Fill Date - . S ^TMP("ORDATA",$J,ORDT,"WP",10)="10^"_$P(ORX0,U,8) ;#Refills - . S ^TMP("ORDATA",$J,ORDT,"WP",11)="11^"_$P($P(ORX0,U,4),";",2) ;Provider - . S ^TMP("ORDATA",$J,ORDT,"WP",12)="12^"_$P(ORX0,U,10) ;Cost-fill - . S ^TMP("ORDATA",$J,ORDT,"WP",15)="15^"_$P(ORX0,U,9) ;PharmID - . S ^TMP("ORDATA",$J,ORDT,"WP",16)="16^"_$P(ORX0,U,11) ;Order Number - . S J=0 - . F S J=$O(^TMP("PSOO",$J,ORDT,J)) Q:'J D - ..S X=^(J,0),^TMP("ORDATA",$J,ORDT,"WP",14,J)="14^"_X - K ^TMP("PSOO",$J) - S ROOT=$NA(^TMP("ORDATA",$J)) - Q -RXAV(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Active IV Pharmacy - ;Call to ENHS^PSJEEU0 - N ORIVSTAT,GO - Q:'$L(OREXT) - S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) - Q:'$L($T(@GO)) - S ORIVSTAT="^ACTIVE^" - D GET1 - Q -RXIV(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ; All IV Pharmcy - ;Call to ENHS^PSJEEU0 - N ORIVSTAT,GO - Q:'$L(OREXT) - S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) - Q:'$L($T(@GO)) - S ORIVSTAT="" - D GET1 - Q -GET1 N ORDT,ORI,ORX0,ORIDRG,ORDRGIEN,ORDRG,ORDOSE,ORREC,ORSTAT,ORSTRTDT,ORSTOPDT,ORROUT,ORSIG,ORWII,ORMORE - N GMI,GMTSIDT,MAX,ON,PS,PSIVREA,PSJEDT,PSJNKF,PSJPFWD,TN,GMTSNDM,GMTS1,GMTS2,ORSITE,SITE - S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) - S PSJEDT=1,PSJNKF=1 - K ^TMP("ORDATA",$J),^UTILITY("PSG",$J),^UTILITY("PSIV",$J) - D @GO - S ORDT=-9999999,ORI=0 - F S ORDT=$O(^UTILITY("PSIV",$J,ORDT)) Q:(ORDT="") S ORX0=$G(^(ORDT,0)) I ORX0'="" D - . I $L(ORIVSTAT),ORIVSTAT'[(U_$P($P(ORX0,U,4),";",2)_U) Q ;Check status - . S ORMORE=0,SITE=$S($L($G(^UTILITY("PSIV",$J,ORDT,"facility"))):^("facility"),1:ORSITE) - . S ^TMP("ORDATA",$J,ORDT,"WP",1)="1^"_SITE ;Station ID - . S ^TMP("ORDATA",$J,ORDT,"WP",6)="6^"_$$DATE^ORDVU($P(ORX0,U)) ;Start Date - . S ^TMP("ORDATA",$J,ORDT,"WP",7)="7^"_$$DATE^ORDVU($P(ORX0,U,2)) ;Stop Date - . S ^TMP("ORDATA",$J,ORDT,"WP",4)="4^"_$P(ORX0,U,5) ;Rate - . S ^TMP("ORDATA",$J,ORDT,"WP",5)="5^"_$P(ORX0,U,6) ;Schedule JEH - . S ORIDRG=0 - . F S ORIDRG=$O(^UTILITY("PSIV",$J,ORDT,"A",ORIDRG)) Q:'ORIDRG S ORREC=$G(^(ORIDRG)) S:ORIDRG>1 ORMORE=1 D ;Additives - .. S ^TMP("ORDATA",$J,ORDT,"WP",2,ORIDRG)="2^"_$P($P(ORREC,U),";",2)_" "_$P(ORREC,U,2) ;Additive Dose - . S ORIDRG=0 - . F S ORIDRG=$O(^UTILITY("PSIV",$J,ORDT,"S",ORIDRG)) Q:'ORIDRG S ORREC=$G(^(ORIDRG)) S:ORIDRG>1 ORMORE=1 D ;Solutions - .. S ^TMP("ORDATA",$J,ORDT,"WP",3,ORIDRG)="3^"_$P($P(ORREC,U),";",2)_" "_$P(ORREC,U,2) ;Solution Dose - . I ORMORE S ^TMP("ORDATA",$J,ORDT,"WP",8)="8^[+]" ;flag for detail - K ^UTILITY("PSG",$J),^UTILITY("PSIV",$J) - S ROOT=$NA(^TMP("ORDATA",$J)) - Q -RXUD(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ; Get Unit Dose Pharmacy Component - ;Call to ENHS^PSJEEU0 - N J,ORDT,ORI,ORX0,ORDRGIEN,ORDRG,ORDOSE,ORSTAT,ORSTRTDT,ORSTOPDT,ORROUT,ORSIG,GO - N GMI,IX,MAX,ON,PS,PSIVREA,PSJEDT,PSJNKF,PSJPFWD,GMR,TN,UDS,GMTSNDM,GMTS1,GMTS2,ORSITE,SITE - Q:'$L(OREXT) - S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) - Q:'$L($T(@GO)) - S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) - S PSJEDT=1,PSJNKF=1 - K ^TMP("ORDATA",$J),^UTILITY("PSG",$J),^UTILITY("PSIV",$J) - D @GO - S ORDT=-9999999,ORI=0 - F S ORDT=$O(^UTILITY("PSG",$J,ORDT)) Q:(ORDT="") S ORX0=$G(^(ORDT)) I ORX0'="" D - . S SITE=$S($L($G(^UTILITY("PSG",$J,ORDT,"facility"))):^("facility"),1:ORSITE) - . S ^TMP("ORDATA",$J,ORDT,"WP",1)="1^"_SITE ;Station ID - . S ^TMP("ORDATA",$J,ORDT,"WP",2)="2^"_$P($P(ORX0,U,3),":") ;DRUG IEN - . S ^TMP("ORDATA",$J,ORDT,"WP",3)="3^"_$P($P(ORX0,U,3),";",2) ;Drug Name - . S ^TMP("ORDATA",$J,ORDT,"WP",4)="4^"_$P(ORX0,U,6) ;Dose - . S ^TMP("ORDATA",$J,ORDT,"WP",5)="5^"_$P($P(ORX0,U,5),";",2) ;Status - . S ^TMP("ORDATA",$J,ORDT,"WP",6)="6^"_$$DATE^ORDVU($P(ORX0,U)) ;START Date - . S ^TMP("ORDATA",$J,ORDT,"WP",7)="7^"_$$DATE^ORDVU($P(ORX0,U,2)) ;Stop Date - . S ^TMP("ORDATA",$J,ORDT,"WP",8)="8^"_$P($P(ORX0,U,7),";",3) ;Route - . S ^TMP("ORDATA",$J,ORDT,"WP",9)="9^"_$P(ORX0,U,8) ;SIG - K ^UTILITY("PSG",$J),^UTILITY("PSIV",$J) - S ROOT=$NA(^TMP("ORDATA",$J)) - Q +ORDV06 ; slc/dkm - OE/RR Report Extracts ;10/8/03 11:17 + ;;3.0;ORDER ENTRY RESULTS REPORTING;**109,118,167,208,215,274**;Dec 17, 1997;Build 20 + ;Pharmacy Extracts +RXA(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Active Outpatient Pharmacy + ;Call to PSOHCSUM + ; + I $L($T(GCPR^OMGCOAS1)) D ; Call if FHIE station 200 + . N BEG,END,MAX + . S BEG=0,END=9999999,MAX=9999 + . D GCPR^OMGCOAS1(DFN,"RXA",BEG,END,MAX) + ; + N ORRXSTAT,GO,PSOACT + Q:'$L(OREXT) + S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) + Q:'$L($T(@GO)) + S PSOACT=1,ORRXSTAT="^ACTIVE^ACTIVE/SUSP^" + D GET + Q +RXOP(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;All Outpatient Pharmacy + ;Call to PSOHCSUM + ; + I $L($T(GCPR^OMGCOAS1)) D ; Call if FHIE station 200 + . N BEG,END,MAX + . S BEG=0,END=9999999,MAX=9999 + . D GCPR^OMGCOAS1(DFN,"RXOP",BEG,END,MAX) + ; + N ORRXSTAT,GO + Q:'$L(OREXT) + S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) + Q:'$L($T(@GO)) + S ORRXSTAT="" + D GET + Q +GET N J,ORDT,ORI,ORDRGIEN,ORDRG,ORRXNO,ORSTAT,ORQTY,OREXP,ORISSUE,ORLAST,ORREF,ORPRVD,ORCOST,ORSIG + N ECD,GMR,GMW,IX,PSOBEGIN,GMTSNDM,GMTS1,GMTS2,ORSITE,SITE + S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) + S PSOBEGIN=0 + K ^TMP("ORDATA") + I '$L($T(GCPR^OMGCOAS1)) D + . K ^TMP("PSOO",$J) + . D @GO + S (ORDT,ORI)=0 + F S ORDT=$O(^TMP("PSOO",$J,ORDT)) Q:(ORDT'>0) S ORX0=$G(^(ORDT,0)) I ORX0'="" D + . I $L(ORRXSTAT),ORRXSTAT'[(U_$P($P(ORX0,U,5),";",2)) Q ;Check status + . S ORI=ORI+1 + . S SITE=$S($L($G(^TMP("PSOO",$J,ORDT,"facility"))):^("facility"),1:ORSITE) + . S ^TMP("ORDATA",$J,ORDT,"WP",1)="1^"_SITE ;Station ID + . S ^TMP("ORDATA",$J,ORDT,"WP",2)="2^"_$P($P(ORX0,U,3),";",2) ;Drug Name + . S ^TMP("ORDATA",$J,ORDT,"WP",3)="3^"_$P($P(ORX0,U,3),";") ;Drug IEN + . S ^TMP("ORDATA",$J,ORDT,"WP",4)="4^"_$P(ORX0,U,6) ;RX # + . S ^TMP("ORDATA",$J,ORDT,"WP",5)="5^"_$P($P(ORX0,U,5),";",2) ;Status + . S ^TMP("ORDATA",$J,ORDT,"WP",6)="6^"_$P(ORX0,U,7) ;Quantity + . S ^TMP("ORDATA",$J,ORDT,"WP",7)="7^"_$$DATE^ORDVU($P(ORX0,U,11)) ;Exp/Cancel Date + . S ^TMP("ORDATA",$J,ORDT,"WP",8)="8^"_$$DATE^ORDVU($P(ORX0,U)) ;Issue Date + . S ^TMP("ORDATA",$J,ORDT,"WP",9)="9^"_$$DATE^ORDVU($P(ORX0,U,2)) ;Last Fill Date + . S ^TMP("ORDATA",$J,ORDT,"WP",10)="10^"_$P(ORX0,U,8) ;#Refills + . S ^TMP("ORDATA",$J,ORDT,"WP",11)="11^"_$P($P(ORX0,U,4),";",2) ;Provider + . S ^TMP("ORDATA",$J,ORDT,"WP",12)="12^"_$P(ORX0,U,10) ;Cost-fill + . S ^TMP("ORDATA",$J,ORDT,"WP",15)="15^"_$P(ORX0,U,9) ;PharmID + . S ^TMP("ORDATA",$J,ORDT,"WP",16)="16^"_$P(ORX0,U,11) ;Order Number + . S J=0 + . F S J=$O(^TMP("PSOO",$J,ORDT,J)) Q:'J S X=^(J,0),^TMP("ORDATA",$J,ORDT,"WP",14,J)="14^"_X + . I $O(^TMP("PSOO",$J,ORDT,1)) S ^TMP("ORDATA",$J,ORDT,"WP",13)="13^[+]" ;flag for detail + K ^TMP("PSOO",$J) + S ROOT=$NA(^TMP("ORDATA",$J)) + Q +RXAV(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Active IV Pharmacy + ;Call to ENHS^PSJEEU0 + N ORIVSTAT,GO + Q:'$L(OREXT) + S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) + Q:'$L($T(@GO)) + S ORIVSTAT="^ACTIVE^" + D GET1 + Q +RXIV(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ; All IV Pharmcy + ;Call to ENHS^PSJEEU0 + N ORIVSTAT,GO + Q:'$L(OREXT) + S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) + Q:'$L($T(@GO)) + S ORIVSTAT="" + D GET1 + Q +GET1 N ORDT,ORI,ORX0,ORIDRG,ORDRGIEN,ORDRG,ORDOSE,ORREC,ORSTAT,ORSTRTDT,ORSTOPDT,ORROUT,ORSIG,ORWII,ORMORE + N GMI,GMTSIDT,MAX,ON,PS,PSIVREA,PSJEDT,PSJNKF,PSJPFWD,TN,GMTSNDM,GMTS1,GMTS2,ORSITE,SITE + S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) + S PSJEDT=1,PSJNKF=1 + K ^TMP("ORDATA"),^UTILITY("PSG",$J),^UTILITY("PSIV",$J) + D @GO + S ORDT=-9999999,ORI=0 + F S ORDT=$O(^UTILITY("PSIV",$J,ORDT)) Q:(ORDT="") S ORX0=$G(^(ORDT,0)) I ORX0'="" D + . I $L(ORIVSTAT),ORIVSTAT'[(U_$P($P(ORX0,U,4),";",2)_U) Q ;Check status + . S ORMORE=0,SITE=$S($L($G(^UTILITY("PSIV",$J,ORDT,"facility"))):^("facility"),1:ORSITE) + . S ^TMP("ORDATA",$J,ORDT,"WP",1)="1^"_SITE ;Station ID + . S ^TMP("ORDATA",$J,ORDT,"WP",2)="2^"_$$DATE^ORDVU($P(ORX0,U)) ;Start Date + . S ^TMP("ORDATA",$J,ORDT,"WP",3)="3^"_$$DATE^ORDVU($P(ORX0,U,2)) ;Stop Date + . S ^TMP("ORDATA",$J,ORDT,"WP",4)="4^"_$P(ORX0,U,5) ;Rate + . S ORIDRG=0 + . F S ORIDRG=$O(^UTILITY("PSIV",$J,ORDT,"A",ORIDRG)) Q:'ORIDRG S ORREC=$G(^(ORIDRG)) S:ORIDRG>1 ORMORE=1 D ;Additives + .. S ^TMP("ORDATA",$J,ORDT,"WP",5,ORIDRG)="5^"_$P($P(ORREC,U),";",2)_" "_$P(ORREC,U,2) ;Additive Dose + . S ORIDRG=0 + . F S ORIDRG=$O(^UTILITY("PSIV",$J,ORDT,"S",ORIDRG)) Q:'ORIDRG S ORREC=$G(^(ORIDRG)) S:ORIDRG>1 ORMORE=1 D ;Solutions + .. S ^TMP("ORDATA",$J,ORDT,"WP",6,ORIDRG)="6^"_$P($P(ORREC,U),";",2)_" "_$P(ORREC,U,2) ;Solution Dose + . I ORMORE S ^TMP("ORDATA",$J,ORDT,"WP",7)="7^[+]" ;flag for detail + K ^UTILITY("PSG",$J),^UTILITY("PSIV",$J) + S ROOT=$NA(^TMP("ORDATA",$J)) + Q +RXUD(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ; Get Unit Dose Pharmacy Component + ;Call to ENHS^PSJEEU0 + N J,ORDT,ORI,ORX0,ORDRGIEN,ORDRG,ORDOSE,ORSTAT,ORSTRTDT,ORSTOPDT,ORROUT,ORSIG,GO + N GMI,IX,MAX,ON,PS,PSIVREA,PSJEDT,PSJNKF,PSJPFWD,GMR,TN,UDS,GMTSNDM,GMTS1,GMTS2,ORSITE,SITE + Q:'$L(OREXT) + S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) + Q:'$L($T(@GO)) + S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) + S PSJEDT=1,PSJNKF=1 + K ^TMP("ORDATA",$J),^UTILITY("PSG",$J),^UTILITY("PSIV",$J) + D @GO + S ORDT=-9999999,ORI=0 + F S ORDT=$O(^UTILITY("PSG",$J,ORDT)) Q:(ORDT="") S ORX0=$G(^(ORDT)) I ORX0'="" D + . S SITE=$S($L($G(^UTILITY("PSG",$J,ORDT,"facility"))):^("facility"),1:ORSITE) + . S ^TMP("ORDATA",$J,ORDT,"WP",1)="1^"_SITE ;Station ID + . S ^TMP("ORDATA",$J,ORDT,"WP",2)="2^"_$P($P(ORX0,U,3),":") ;DRUG IEN + . S ^TMP("ORDATA",$J,ORDT,"WP",3)="3^"_$P($P(ORX0,U,3),";",2) ;Drug Name + . S ^TMP("ORDATA",$J,ORDT,"WP",4)="4^"_$P(ORX0,U,6) ;Dose + . S ^TMP("ORDATA",$J,ORDT,"WP",5)="5^"_$P($P(ORX0,U,5),";",2) ;Status + . S ^TMP("ORDATA",$J,ORDT,"WP",6)="6^"_$$DATE^ORDVU($P(ORX0,U)) ;START Date + . S ^TMP("ORDATA",$J,ORDT,"WP",7)="7^"_$$DATE^ORDVU($P(ORX0,U,2)) ;Stop Date + . S ^TMP("ORDATA",$J,ORDT,"WP",8)="8^"_$P($P(ORX0,U,7),";",3) ;Route + . S J=0,ORI=ORI+1 + . F S J=$O(^UTILITY("PSG",$J,ORDT,J)) Q:'J S X=^(J,0),^TMP("ORDATA",$J,ORDT,"WP",10,J)="10^"_X ;SIG + . I $O(^UTILITY("PSG",$J,ORDT,1)) S ^TMP("ORDATA",$J,ORDT,"WP",9)="9^[+]" ;flag for detail + K ^UTILITY("PSG",$J),^UTILITY("PSIV",$J) + S ROOT=$NA(^TMP("ORDATA",$J)) + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORDV06A.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORDV06A.m index dfddf672..81fd6070 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORDV06A.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORDV06A.m @@ -1,45 +1,45 @@ -ORDV06A ; slc/dcm - OE/RR Report Extracts ;3/8/04 11:17 - ;;3.0;ORDER ENTRY RESULTS REPORTING;**215,243**;Dec 17, 1997;Build 242 - ;Pharmacy Extracts -NVA(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;All Outpatient Pharmacy - ;Call to PSOHCSUM - ;^TMP("PSOO",$J,"NVA",n,0)=Herbal/OTC/Non VA Medication^status (active or discontinued)^start date(fm format)^cprs order # (ptr to 100) - ; ^date/time documented (fm format)^documented by (ptr to 200_";"_.01)^dc date/time(fm format) - ;^TMP("PSOO",$J,"NVA",n,1,0)=dosage^med route^schedule (previous 3 fields are Instructions)^drug (file #50_";"_.01)^clinic (file #44_";"_.01) - ;^TMP("PSOO",$J,"NVA",n,"DSC",nn,0)=statement/explanation/comments - I $L($T(GCPR^OMGCOAS1)) D ; Call if FHIE station 200 - . N BEG,END,MAX - . S BEG=0,END=9999999,MAX=9999 - . D GCPR^OMGCOAS1(DFN,"RXOP",BEG,END,MAX) - ; - N GO - Q:'$L(OREXT) - S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) - Q:'$L($T(@GO)) - D GET - Q -GET N J,ORDT,ORDRGIEN,ORDRG,ORRXNO,ORSTAT,ORQTY,OREXP,ORISSUE,ORLAST,ORREF,ORPRVD,ORCOST,ORSIG,ORX0,ORX1 - N ECD,GMR,GMW,IX,PSOBEGIN,GMTSNDM,GMTS1,GMTS2,ORSITE,SITE - S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) - S PSOBEGIN=0 - K ^TMP("ORDATA",$J) - I '$L($T(GCPR^OMGCOAS1)) D - . K ^TMP("PSOO",$J) - . D @GO - S ORDT=0 - F S ORDT=$O(^TMP("PSOO",$J,"NVA",ORDT)) Q:(ORDT'>0) S ORX0=$G(^(ORDT,0)) I ORX0'="" S ORX1=$G(^(1,0)) D - . S SITE=$S($L($G(^TMP("PSOO",$J,"NVA",ORDT,"facility"))):^("facility"),1:ORSITE) - . S ^TMP("ORDATA",$J,ORDT,"WP",1)="1^"_SITE ;Station ID - . S ^TMP("ORDATA",$J,ORDT,"WP",2)="2^"_$P(ORX0,U) ;Herbal/OTC/Non VA Medication - . S ^TMP("ORDATA",$J,ORDT,"WP",3)="3^"_$P(ORX0,U,2) ;Status - . S ^TMP("ORDATA",$J,ORDT,"WP",4)="4^"_$$DATE^ORDVU($P(ORX0,U,3)) ;Start Date - . S ^TMP("ORDATA",$J,ORDT,"WP",5)="5^"_$$DATE^ORDVU($P(ORX0,U,5)) ;Date Documented - . S ^TMP("ORDATA",$J,ORDT,"WP",6)="6^"_$P($P(ORX0,U,6),";",2) ;Documented By - . S ^TMP("ORDATA",$J,ORDT,"WP",7)="7^"_$$DATE^ORDVU($P(ORX0,U,7)) ;Date DC'd - . S ^TMP("ORDATA",$J,ORDT,"WP",8)="8^"_$P(ORX1,U)_" "_$P(ORX1,U,2)_" "_$P(ORX1,U,3) ;SIG dose + route + schedule - . S J=0 - . F S J=$O(^TMP("PSOO",$J,"NVA",ORDT,"DSC",J)) Q:'J S X=^(J,0),^TMP("ORDATA",$J,ORDT,"WP",10,J)="10^"_X - . I $O(^TMP("PSOO",$J,"NVA",ORDT,"DSC",1)) S ^TMP("ORDATA",$J,ORDT,"WP",9)="9^[+]" ;flag for detail - K ^TMP("PSOO",$J) - S ROOT=$NA(^TMP("ORDATA",$J)) - Q +ORDV06A ; slc/dcm - OE/RR Report Extracts ;3/8/04 11:17 + ;;3.0;ORDER ENTRY RESULTS REPORTING;**215**;Dec 17, 1997 + ;Pharmacy Extracts +NVA(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;All Outpatient Pharmacy + ;Call to PSOHCSUM + ;^TMP("PSOO",$J,"NVA",n,0)=Herbal/OTC/Non VA Medication^status (active or discontinued)^start date(fm format)^cprs order # (ptr to 100) + ; ^date/time documented (fm format)^documented by (ptr to 200_";"_.01)^dc date/time(fm format) + ;^TMP("PSOO",$J,"NVA",n,1,0)=dosage^med route^schedule (previous 3 fields are Instructions)^drug (file #50_";"_.01)^clinic (file #44_";"_.01) + ;^TMP("PSOO",$J,"NVA",n,"DSC",nn,0)=statement/explanation/comments + I $L($T(GCPR^OMGCOAS1)) D ; Call if FHIE station 200 + . N BEG,END,MAX + . S BEG=0,END=9999999,MAX=9999 + . D GCPR^OMGCOAS1(DFN,"RXOP",BEG,END,MAX) + ; + N GO + Q:'$L(OREXT) + S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) + Q:'$L($T(@GO)) + D GET + Q +GET N J,ORDT,ORDRGIEN,ORDRG,ORRXNO,ORSTAT,ORQTY,OREXP,ORISSUE,ORLAST,ORREF,ORPRVD,ORCOST,ORSIG,ORX0,ORX1 + N ECD,GMR,GMW,IX,PSOBEGIN,GMTSNDM,GMTS1,GMTS2,ORSITE,SITE + S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) + S PSOBEGIN=0 + K ^TMP("ORDATA") + I '$L($T(GCPR^OMGCOAS1)) D + . K ^TMP("PSOO",$J) + . D @GO + S ORDT=0 + F S ORDT=$O(^TMP("PSOO",$J,"NVA",ORDT)) Q:(ORDT'>0) S ORX0=$G(^(ORDT,0)) I ORX0'="" S ORX1=$G(^(1,0)) D + . S SITE=$S($L($G(^TMP("PSOO",$J,"NVA",ORDT,"facility"))):^("facility"),1:ORSITE) + . S ^TMP("ORDATA",$J,ORDT,"WP",1)="1^"_SITE ;Station ID + . S ^TMP("ORDATA",$J,ORDT,"WP",2)="2^"_$P(ORX0,U) ;Herbal/OTC/Non VA Medication + . S ^TMP("ORDATA",$J,ORDT,"WP",3)="3^"_$P(ORX0,U,2) ;Status + . S ^TMP("ORDATA",$J,ORDT,"WP",4)="4^"_$$DATE^ORDVU($P(ORX0,U,3)) ;Start Date + . S ^TMP("ORDATA",$J,ORDT,"WP",5)="5^"_$$DATE^ORDVU($P(ORX0,U,5)) ;Date Documented + . S ^TMP("ORDATA",$J,ORDT,"WP",6)="6^"_$P($P(ORX0,U,6),";",2) ;Documented By + . S ^TMP("ORDATA",$J,ORDT,"WP",7)="7^"_$$DATE^ORDVU($P(ORX0,U,7)) ;Date DC'd + . S ^TMP("ORDATA",$J,ORDT,"WP",8)="8^"_$P(ORX1,U)_" "_$P(ORX1,U,2)_" "_$P(ORX1,U,3) ;SIG dose + route + schedule + . S J=0 + . F S J=$O(^TMP("PSOO",$J,"NVA",ORDT,"DSC",J)) Q:'J S X=^(J,0),^TMP("ORDATA",$J,ORDT,"WP",10,J)="10^"_X + . I $O(^TMP("PSOO",$J,"NVA",ORDT,"DSC",1)) S ^TMP("ORDATA",$J,ORDT,"WP",9)="9^[+]" ;flag for detail + K ^TMP("PSOO",$J) + S ROOT=$NA(^TMP("ORDATA",$J)) + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORDV08.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORDV08.m index 275069f0..a7ae862b 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORDV08.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORDV08.m @@ -1,95 +1,94 @@ -ORDV08 ;DAN/SLC Testing new component ;8/22/01 11:30 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**109,120,243**;Dec 17,1997;Build 242 - ; -RIM(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Radiology report - ;External Calls: MAIN^GMTSRAE(2),RPT^ORWRA - N ORX0,ORCNT,ORSITE,SITE,GO,ORMORE,ORROOT - Q:'$L(OREXT) - S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) - Q:'$L($T(@GO)) - K ^TMP("ORDATA",$J),^TMP("ORXPND",$J) - S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) - D @GO - S ORCNT=0 - F S ORCNT=$O(^TMP($J,"ORAEXAMS",ORCNT)) Q:'ORCNT D - . S ORMORE=0 - . S ORX0=$G(^TMP($J,"ORAEXAMS",ORCNT)) - . D RPT^ORWRA(.ORROOT,DFN,$P(ORX0,U)) - . S SITE=$S($L($G(^TMP($J,"ORAEXAMS",ORCNT,"facility"))):^("facility"),1:ORSITE) - . S ^TMP("ORDATA",$J,ORCNT,"WP",1)="1^"_SITE ;Site ID - . S ^TMP("ORDATA",$J,ORCNT,"WP",2)="2^"_$$DATE^ORDVU($P(ORX0,U,2)) ;date - . S ^TMP("ORDATA",$J,ORCNT,"WP",3)="3^"_$P(ORX0,U,3) ;procedure - . S ^TMP("ORDATA",$J,ORCNT,"WP",4)="4^"_$P(ORX0,U,5) ;report status - . S ^TMP("ORDATA",$J,ORCNT,"WP",5)="5^"_$P(ORX0,U,4) ;Case # - . I $O(^TMP("ORXPND",$J,0)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("ORXPND",$J)),$NA(^TMP("ORDATA",$J,ORCNT,"WP",6,1)),6) ;clinical history - . I ORMORE S ^TMP("ORDATA",$J,ORCNT,"WP",7)="7^[+]" ;flag for detail - . S ^TMP("ORDATA",$J,ORCNT,"WP",8)="8^"_$P(ORX0,U,14) ;Image available - . S ^TMP("ORDATA",$J,ORCNT,"WP",9)="9^"_"i"_$P(ORX0,U,1) ;EXAM ID - K ^TMP("RAE",$J),^TMP("ORXPND",$J) - S ROOT=$NA(^TMP("ORDATA",$J)) - Q - ; -IGET ;Get imaging exams - N ORROOT,ORRADATA,I,ID - S ORRADATA=$NA(^TMP($J,"RAE1",DFN)) - S ORROOT=$NA(^TMP($J,"ORAEXAMS")) - K @ORRADATA,@ORROOT - D EN1^RAO7PC1(DFN,ORDBEG,ORDEND,ORMAX) ;call to Radiology to get exams - S I=0,ID="" - F S ID=$O(@ORRADATA@(ID)) Q:ID="" D - . S I=I+1 - . S @ORROOT@(I)=ID_U_(9999999.9999-ID)_U_@ORRADATA@(ID) - K @ORRADATA - Q - ; -MPRO(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Medicine Procedures - N ORSITE,ORI,ORREC,ORMORE,ORDATE,SITE,ORARRAY,ORPROC,ORSUM - Q:'$L(OREXT) - S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) - Q:'$L($T(@GO)) - K ^TMP("ORDATA",$J),^TMP("ORTEMP",$J),^TMP("MCAR",$J) - S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) - D @GO - S ORI=0 - F S ORI=$O(^TMP("MCAR",$J,ORI)) Q:'ORI!(ORI>ORMAX) D - .K ^TMP("ORTEMP",$J) D GETREC^ORDV08A(ORI,80,20,56,3) - .S SITE=$S($L($G(^TMP("MCAR",$J,ORI,"facility"))):^("facility"),1:ORSITE) - .S ^TMP("ORDATA",$J,ORI,"WP",1)="1^"_SITE ;Site ID - .S ^TMP("ORDATA",$J,ORI,"WP",2)="2^"_$$DATEMMM^ORDVU(ORDATE) ;Procedure date/time - .S ^TMP("ORDATA",$J,ORI,"WP",3)="3^"_ORPROC ;Procedure Name - .S ^TMP("ORDATA",$J,ORI,"WP",4)="4^"_$S(ORSUM'="":ORSUM,1:"No Summary") ;Summary - .I $D(^TMP("ORTEMP",$J)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("ORTEMP",$J)),$NA(^TMP("ORDATA",$J,ORI,"WP",5,1)),5) ;Detailed Report - .I ORMORE S ^TMP("ORDATA",$J,ORI,"WP",6)="6^[+]" ;Detailed report flag - .Q - K ^TMP("ORTEMP",$J),^TMP("MCAR",$J) - S ROOT=$NA(^TMP("ORDATA",$J)) - Q -MGET ;Get medicine results - D HSUM^GMTSMCMA(DFN,ORDBEG,ORDEND,ORMAX,"","F") - Q -DIETNS(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Nutrition assessment - ;External Calls:SITE^VASITE, NUTR^ORWRP1, LISTNUTR^ORWPR1,FMTE^XLFDT - N ORSITE,ORARRAY,ORID,ORCNT,ORMORE,GO,ORDT - Q:'$L(OREXT) - S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) - Q:'$L($T(@GO)) - K ^TMP("ORDATA",$J),^TMP("ORXPND",$J) - S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) - D @GO - S ORCNT=0,ORDT=OROMEGA - F S ORDT=$O(^TMP($J,"FHADT",DFN,ORDT)) Q:(ORDT'>0)!(ORDT>ORALPHA)!(ORCNT>ORMAX) D - . S ORID=$$FMTE^XLFDT(9999999-ORDT,2) ;convert inverse date to external date - . S ORCNT=ORCNT+1,ORMORE=0 - . D NUTR^ORWRP1(.ORARRAY,DFN,ORID) - . S ORSITE=$S($L($G(^TMP($J,"FHADT",ORDT,"facility"))):^("facility"),1:ORSITE) - . S ^TMP("ORDATA",$J,ORCNT,"WP",1)="1^"_ORSITE ;Site ID - . S ^TMP("ORDATA",$J,ORCNT,"WP",2)="2^"_ORID ;assessment date/time - . I $O(^TMP("ORXPND",$J,0)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("ORXPND",$J)),$NA(^TMP("ORDATA",$J,ORCNT,"WP",3,1)),3) ;assessment report - . I ORMORE S ^TMP("ORDATA",$J,ORCNT,"WP",4)="4^[+]" ;flag for detail - K ^TMP($J,"FHADT"),^TMP("ORXPND",$J) - S ROOT=$NA(^TMP("ORDATA",$J)) - Q - ; -GETNS ;Get nutritional assessments - D LISTNUTR^ORWRP1(.ORARRAY,DFN) - Q +ORDV08 ;DAN/SLC Testing new component ;8/22/01 11:30 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**109,120**;Dec 17,1997 + ; +RIM(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Radiology report + ;External Calls: MAIN^GMTSRAE(2),RPT^ORWRA + N ORX0,ORCNT,ORSITE,SITE,GO,ORMORE,ORROOT + Q:'$L(OREXT) + S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) + Q:'$L($T(@GO)) + K ^TMP("ORDATA",$J),^TMP("ORXPND",$J) + S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) + D @GO + S ORCNT=0 + F S ORCNT=$O(^TMP($J,"ORAEXAMS",ORCNT)) Q:'ORCNT D + . S ORMORE=0 + . S ORX0=$G(^TMP($J,"ORAEXAMS",ORCNT)) + . D RPT^ORWRA(.ORROOT,DFN,$P(ORX0,U)) + . S SITE=$S($L($G(^TMP($J,"ORAEXAMS",ORCNT,"facility"))):^("facility"),1:ORSITE) + . S ^TMP("ORDATA",$J,ORCNT,"WP",1)="1^"_SITE ;Site ID + . S ^TMP("ORDATA",$J,ORCNT,"WP",2)="2^"_$$DATE^ORDVU($P(ORX0,U,2)) ;date + . S ^TMP("ORDATA",$J,ORCNT,"WP",3)="3^"_$P(ORX0,U,3) ;procedure + . S ^TMP("ORDATA",$J,ORCNT,"WP",4)="4^"_$P(ORX0,U,5) ;report status + . S ^TMP("ORDATA",$J,ORCNT,"WP",5)="5^"_$P(ORX0,U,4) ;Case # + . I $O(^TMP("ORXPND",$J,0)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("ORXPND",$J)),$NA(^TMP("ORDATA",$J,ORCNT,"WP",6,1)),6) ;clinical history + . I ORMORE S ^TMP("ORDATA",$J,ORCNT,"WP",7)="7^[+]" ;flag for detail + . S ^TMP("ORDATA",$J,ORCNT,"WP",8)="8^"_$P(ORX0,U,14) ;Image available + K ^TMP("RAE",$J),^TMP("ORXPND",$J) + S ROOT=$NA(^TMP("ORDATA",$J)) + Q + ; +IGET ;Get imaging exams + N ORROOT,ORRADATA,I,ID + S ORRADATA=$NA(^TMP($J,"RAE1",DFN)) + S ORROOT=$NA(^TMP($J,"ORAEXAMS")) + K @ORRADATA,@ORROOT + D EN1^RAO7PC1(DFN,ORDBEG,ORDEND,ORMAX) ;call to Radiology to get exams + S I=0,ID="" + F S ID=$O(@ORRADATA@(ID)) Q:ID="" D + . S I=I+1 + . S @ORROOT@(I)=ID_U_(9999999.9999-ID)_U_@ORRADATA@(ID) + K @ORRADATA + Q + ; +MPRO(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Medicine Procedures + N ORSITE,ORI,ORREC,ORMORE,ORDATE,SITE,ORARRAY,ORPROC,ORSUM + Q:'$L(OREXT) + S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) + Q:'$L($T(@GO)) + K ^TMP("ORDATA",$J),^TMP("ORTEMP",$J),^TMP("MCAR",$J) + S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) + D @GO + S ORI=0 + F S ORI=$O(^TMP("MCAR",$J,ORI)) Q:'ORI!(ORI>ORMAX) D + .K ^TMP("ORTEMP",$J) D GETREC^ORDV08A(ORI,80,20,56,3) + .S SITE=$S($L($G(^TMP("MCAR",$J,ORI,"facility"))):^("facility"),1:ORSITE) + .S ^TMP("ORDATA",$J,ORI,"WP",1)="1^"_SITE ;Site ID + .S ^TMP("ORDATA",$J,ORI,"WP",2)="2^"_$$DATEMMM^ORDVU(ORDATE) ;Procedure date/time + .S ^TMP("ORDATA",$J,ORI,"WP",3)="3^"_ORPROC ;Procedure Name + .S ^TMP("ORDATA",$J,ORI,"WP",4)="4^"_$S(ORSUM'="":ORSUM,1:"No Summary") ;Summary + .I $D(^TMP("ORTEMP",$J)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("ORTEMP",$J)),$NA(^TMP("ORDATA",$J,ORI,"WP",5,1)),5) ;Detailed Report + .I ORMORE S ^TMP("ORDATA",$J,ORI,"WP",6)="6^[+]" ;Detailed report flag + .Q + K ^TMP("ORTEMP",$J),^TMP("MCAR",$J) + S ROOT=$NA(^TMP("ORDATA",$J)) + Q +MGET ;Get medicine results + D HSUM^GMTSMCMA(DFN,ORDBEG,ORDEND,ORMAX,"","F") + Q +DIETNS(ROOT,ORALPHA,OROMEGA,ORMAX,ORDBEG,ORDEND,OREXT) ;Nutrition assessment + ;External Calls:SITE^VASITE, NUTR^ORWRP1, LISTNUTR^ORWPR1,FMTE^XLFDT + N ORSITE,ORARRAY,ORID,ORCNT,ORMORE,GO,ORDT + Q:'$L(OREXT) + S GO=$P(OREXT,";")_"^"_$P(OREXT,";",2) + Q:'$L($T(@GO)) + K ^TMP("ORDATA",$J),^TMP("ORXPND",$J) + S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3) + D @GO + S ORCNT=0,ORDT=OROMEGA + F S ORDT=$O(^TMP($J,"FHADT",DFN,ORDT)) Q:(ORDT'>0)!(ORDT>ORALPHA)!(ORCNT>ORMAX) D + . S ORID=$$FMTE^XLFDT(9999999-ORDT,2) ;convert inverse date to external date + . S ORCNT=ORCNT+1,ORMORE=0 + . D NUTR^ORWRP1(.ORARRAY,DFN,ORID) + . S ORSITE=$S($L($G(^TMP($J,"FHADT",ORDT,"facility"))):^("facility"),1:ORSITE) + . S ^TMP("ORDATA",$J,ORCNT,"WP",1)="1^"_ORSITE ;Site ID + . S ^TMP("ORDATA",$J,ORCNT,"WP",2)="2^"_ORID ;assessment date/time + . I $O(^TMP("ORXPND",$J,0)) S ORMORE=1 D SPMRG^ORDVU($NA(^TMP("ORXPND",$J)),$NA(^TMP("ORDATA",$J,ORCNT,"WP",3,1)),3) ;assessment report + . I ORMORE S ^TMP("ORDATA",$J,ORCNT,"WP",4)="4^[+]" ;flag for detail + K ^TMP($J,"FHADT"),^TMP("ORXPND",$J) + S ROOT=$NA(^TMP("ORDATA",$J)) + Q + ; +GETNS ;Get nutritional assessments + D LISTNUTR^ORWRP1(.ORARRAY,DFN) + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OREVNTX.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OREVNTX.m index c570b04e..e2aa8ecb 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OREVNTX.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OREVNTX.m @@ -1,211 +1,209 @@ -OREVNTX ; SLC/MKB - Event delayed orders RPC's ; 5/4/07 11:34am - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141,243**;Dec 17, 1997;Build 242 - ; -PAT(ORY,DFN) ; -- Returns currently delayed events for patient DFN - N EVT,CNT,X,Y S DFN=+$G(DFN),(EVT,CNT)=0 - F S EVT=+$O(^ORE(100.2,"AE",DFN,EVT)) Q:EVT<1 S Y=+$O(^(EVT,0)) D - . I $G(^ORE(100.2,Y,1)) K ^ORE(100.2,"AE",DFN,EVT,Y) Q - . Q:$$LAPSED(Y) ;I $$EMPTY(Y) D CANCEL(Y) Q - . Q:$O(^ORE(100.2,"DAD",Y,0)) ;has children - . S X=$P($G(^ORD(100.5,EVT,0)),U,8),X="Delayed "_$$LOWER^VALM1(X) - . S CNT=CNT+1,ORY(CNT)=Y_U_X - S:CNT ORY(0)=CNT - Q - ; -EXISTS(DFN,EVT) ; -- Returns 1 if patient DFN has delayed orders for EVT, - ; or 2 if parent/sibling event has delayed orders, else 0 - ; - N X,Y,I S Y=0 I '$G(DFN)!'$G(EVT) G EXQ - I $O(^ORE(100.2,"AE",+DFN,+EVT,0)) S Y=1 G EXQ - S X=+$P($G(^ORD(100.5,+EVT,0)),U,12) I X D G EXQ ;ck parent,siblings - . I $O(^ORE(100.2,"AE",+DFN,X,0)) S Y=2 Q - . S I=0 F S I=+$O(^ORD(100.5,"DAD",X,I)) Q:I<1 I $O(^ORE(100.2,"AE",+DFN,I,0)) S Y=2 Q -EXQ Q Y - ; -LIST(ORY,DFN) ; -- Returns all processed events for patient DFN as - ; ORY(#) = PatEvtIEN ^ Display Text ^ EvtDateTime - ; in reverse chronological order - N IDT,DA,CNT,X0,X1,EVT,DC,X - S DFN=+$G(DFN),(IDT,CNT)=0 - F S IDT=$O(^ORE(100.2,"AC",DFN,IDT)) Q:IDT<1 D - . S DA=0 F S DA=+$O(^ORE(100.2,"AC",DFN,IDT,DA)) Q:DA<1 D - .. S X0=$G(^ORE(100.2,DA,0)),X1=$G(^(1)) Q:$P(X1,U,5) ;has parent - .. S EVT=+$P(X0,U,2),DC=+$P(X1,U,3) - .. I '$P(X0,U,4),'$O(^ORE(100.2,DA,2,0)),'$O(^ORE(100.2,DA,3,0)),'$D(^OR(100,"AEVNT",DFN_";DPT(",DA)) Q ;no orders - .. S I=+$O(^ORE(100.2,DA,10,"B"),-1),X=$P($G(^(I,0)),U,2) I X="LP"!(X="CA") Q ;lapsed or cancelled - .. ;Q if not current admission? - .. S X=$S(EVT:$P($G(^ORD(100.5,EVT,0)),U,8),DC:$P($G(^ORD(100.6,DC,0)),U,5),1:"UNSPECIFIED EVENT") - .. S X=$$LOWER^VALM1(X),CNT=CNT+1,ORY(CNT)=DA_U_X_U_$P(X1,U) - S:CNT ORY(0)=CNT - Q - ; -COMP(PTEVT) ; -- Returns 1 or 0, if PTEVT has been completed - N Y,I S Y=$S($G(^ORE(100.2,+$G(PTEVT),1)):1,1:0) - I Y S I=+$O(^ORE(100.2,+$G(PTEVT),10,0)) S:$P($G(^(I,0)),U,2)="CA" Y=0 - Q Y - ; -ACTIVE(ORY,TYPE) ; -- Returns all active events [of TYPE] from #100.5 - ; where TYPE=string containing any of the codes from the TYPE field - N NM,IEN,CNT,X0,X S CNT=0,TYPE=$G(TYPE) - S NM="" F S NM=$O(^ORD(100.5,"C",NM)) Q:NM="" D - . S IEN=0 F S IEN=+$O(^ORD(100.5,"C",NM,IEN)) Q:IEN<1 D - .. S X0=$G(^ORD(100.5,IEN,0)) I '$L($P(X0,U,2)) D ;Child event - ... S X=$P(X0,U,12) S:X $P(X0,U,2)=$P($G(^ORD(100.5,+X,0)),U,2) - .. I $L(TYPE),TYPE'[$P(X0,U,2) Q - .. Q:$O(^ORD(100.5,"DAD",IEN,0)) ;Parent event - .. S CNT=CNT+1,ORY(CNT)=IEN_U_X0 - S:CNT ORY(0)=CNT - Q - ; -NAME(PTEVT) ; -- Return name of Patient Event - N X,Y,Z S X=+$P($G(^ORE(100.2,+$G(PTEVT),0)),U,2),Z=$G(^(1)) - S:X Y=$P($G(^ORD(100.5,X,0)),U,8) - I 'X S X=+$P(Z,U,3),Y=$P($G(^ORD(100.6,X,0)),U,5) - S Y=$S('Z:"Delayed ",1:"")_$$LOWER^VALM1(Y) - Q Y - ; -SHORTNM(PTEVT) ; -- Return Short Name of Patient Event - ; or first 15 characters of Event Name if unspecified - N X,Y,Y0 S X=+$P($G(^ORE(100.2,+$G(PTEVT),0)),U,2) I X D - . S Y0=$G(^ORD(100.5,X,0)),Y=$P(Y0,U,10) - . S:'$L(Y) Y=$E($P(Y0,U,8),1,15) - I 'X S X=+$P($G(^ORE(100.2,+$G(PTEVT),1)),U,3),Y=$E($P($G(^ORD(100.6,X,0)),U,5),1,15) - Q Y - ; -EVT(PTEVT) ; -- Return Event ptr #100.5, given PTEVT ptr #100.2 - Q +$P($G(^ORE(100.2,+$G(PTEVT),0)),U,2) - ; -DC(PTEVT) ; -- Return DC Rule ptr #100.6, given PTEVT ptr #100.2 - I $P($G(^ORE(100.2,+$G(PTEVT),1)),U,5) S PTEVT=$P(^(1),U,5) ;use parent - Q +$P($G(^ORE(100.2,+$G(PTEVT),1)),U,3) - ; -TYPE(PTEVT) ; -- Return Type of Patient Event (i.e. A/D/T) - N X,Y S X=+$P($G(^ORE(100.2,+$G(PTEVT),0)),U,2) - I $P($G(^ORD(100.5,X,0)),U,12) S X=$P(^(0),U,12) ;use parent - S Y=$S(X:$P($G(^ORD(100.5,X,0)),U,2),1:"DC") - Q Y - ; -DIV(PTEVT) ; -- Return Division for PTEVT - N X,Y S X=+$P($G(^ORE(100.2,+$G(PTEVT),0)),U,2) - I $P($G(^ORD(100.5,X,0)),U,12) S X=$P(^(0),U,12) ;use parent - S Y=+$P($G(^ORD(100.5,X,0)),U,3) S:Y<1 Y=+$G(DUZ(2)) - Q Y - ; -LOC(PTEVT) ; -- Return Default Ordering Location for PTEVT - N X,X0,Y S X=+$P($G(^ORE(100.2,+$G(PTEVT),0)),U,2) - S X0=$G(^ORD(100.5,X,0)),Y=+$P(X0,U,9)_";SC(" - I Y<1,$P(X0,U,12) S Y=+$P($G(^ORD(100.5,+$P(X0,U,12),0)),U,9)_";SC(" - S:Y<1 Y=$G(ORL) - Q Y - ; -EMPTY(PTEVT) ; -- Returns 1 or 0, if PTEVT has delayed orders - N Y,OR0,PAT,TYPE,PSO,IFN,STS S Y=1 I '$G(PTEVT) Q Y - S OR0=$G(^ORE(100.2,+PTEVT,0)),PAT=+$P(OR0,U)_";DPT(" - S TYPE=$$TYPE(PTEVT) I TYPE="D" S PSO=+$O(^DIC(9.4,"C","PSO",0)) - S IFN=0 F S IFN=$O(^OR(100,"AEVNT",PAT,PTEVT,IFN)) Q:IFN<1 D Q:'Y - . S STS=$P($G(^OR(100,IFN,3)),U,3) I STS=10 S Y=0 Q - . ;I IFN=+$P(OR0,U,4),STS=11!(STS=6) S Y=0 Q - . I TYPE="D",$P($G(^OR(100,IFN,0)),U,14)=PSO,STS=5!(STS=6) S Y=0 Q - I Y,$D(^ORE(100.2,"DAD",PTEVT)) D ;ck child events - . N CHLD S CHLD=0 - . F S CHLD=+$O(^ORE(100.2,"DAD",PTEVT,CHLD)) Q:CHLD<1 D Q:'Y - .. S IFN=0 F S IFN=$O(^OR(100,"AEVNT",PAT,CHLD,IFN)) Q:IFN<1 I $P($G(^OR(100,IFN,3)),U,3)=10 S Y=0 Q - Q Y - ; -EVTORDER(ORDER) ; -- Returns 1 or 0, if ORDER is for event - ; Will return 0 if action DA is included but not NW - N X0,X,Y S X0=$G(^OR(100,+ORDER,0)),X=+$P(ORDER,";",2),Y=0 - I $P(X0,U,17),X'>1 D - . I $P($G(^ORE(100.2,+$P(X0,U,17),0)),U,4)=+ORDER S Y=1 Q - . S DAD=+$P($G(^ORE(100.2,+$P(X0,U,17),1)),U,5) ;has parent? - . I DAD,$P($G(^ORE(100.2,DAD,0)),U,4)=+ORDER S Y=1 - Q Y - ; -MANREL(ORDER) ; -- Returns 1 or 0, if ORDER was manually released - N EVT,Y,RELDT,TYPE,EVTDT S Y=0 - S EVT=+$P($G(^OR(100,+ORDER,0)),U,17),RELDT=+$P($G(^(8,1,0)),U,16) - G:EVT<1 MNQ G:RELDT<1 MNQ ;not delayed or released - I '$D(^ORE(100.2,EVT,2,+ORDER)) S Y=1 G MNQ ;not rel'd by event - S TYPE=$$TYPE(EVT),EVTDT=+$G(^ORE(100.2,EVT,1)) - I TYPE="M",$$FMDIFF^XLFDT(EVTDT,RELDT,2)<300 S Y=1 -MNQ Q Y - ; -CANCEL(PTEVT) ; -- Cancel empty PTEVT, event order - S PTEVT=+$G(PTEVT) D DONE(PTEVT),ACTLOG(PTEVT,"CA") - N IFN,DAD S IFN=+$P($G(^ORE(100.2,PTEVT,0)),U,4) - I IFN<1 D ;ck for parent w/event order - . S DAD=+$P($G(^ORE(100.2,PTEVT,1)),U,5) Q:DAD<1 - . Q:'$G(^ORE(100.2,DAD,1)) ;parent still active - . S IFN=+$P($G(^ORE(100.2,DAD,0)),U,4) - I IFN D:'$$DCD^ORCACT2(IFN) CLRDLY^ORCACT2(IFN) ;cancel event order - Q - ; -DONE(PTEVT,WHEN,MVT,OR) ; -- Terminate PTEVT - Q:'$G(PTEVT) Q:'$D(^ORE(100.2,PTEVT,0)) - N X0,X1,PAT,EVT,DAD - S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12) D D1 - S DAD=$P(X1,U,5) I DAD,$$ALLDONE(DAD) S PTEVT=DAD D D1 Q - S DAD=PTEVT,PTEVT=0 ;if PTEVT=parent, terminate children too - F S PTEVT=+$O(^ORE(100.2,"DAD",DAD,PTEVT)) Q:PTEVT<1 D D1 - Q -D1 S X0=$G(^ORE(100.2,+PTEVT,0)),X1=$G(^(1)) Q:'$L(X0) - S PAT=+$P(X0,U),EVT=+$P(X0,U,2) ;,ORD=+$P(X0,U,4) - S $P(X1,U,1,2)=WHEN_U_$G(MVT),$P(X1,U,4)=$G(OR),^ORE(100.2,PTEVT,1)=X1 - S ^ORE(100.2,"AC",PAT,9999999-WHEN,PTEVT)="" - S:$G(OR) ^ORE(100.2,"ASR",OR,PTEVT)="" - K:EVT ^ORE(100.2,"AE",PAT,EVT,PTEVT) - Q - ; -ALLDONE(DAD) ; -- Returns 1 or 0, if all child events are done - N I,Y S Y=1,I=0 - F S I=+$O(^ORE(100.2,"DAD",+$G(DAD),I)) Q:I<1 I '$G(^ORE(100.2,I,1)) S Y=0 Q - Q Y - ; -CHGEVT(IFN,NEWEVT) ; -- Change the Patient Event for order IFN to NEWEVT - ; Includes adding or removing event pointer to order - Q:'$G(IFN) N PAT,OLDEVT,OR3 S:$G(NEWEVT) NEWEVT=+NEWEVT - S PAT=$P($G(^OR(100,+IFN,0)),U,2),OLDEVT=$P($G(^(0)),U,17),OR3=$G(^(3)) - Q:OLDEVT=NEWEVT K:OLDEVT ^OR(100,"AEVNT",PAT,OLDEVT,+IFN) - S $P(^OR(100,+IFN,0),U,17)=NEWEVT S:NEWEVT ^OR(100,"AEVNT",PAT,NEWEVT,+IFN)="" - I NEWEVT,$P(OR3,U,3)'=10 S $P(^OR(100,+IFN,3),U,3)=10,$P(^(8,1,0),U,15)=10 - I 'NEWEVT,$P(OR3,U,3)=10 S $P(^OR(100,+IFN,3),U,3)=11,$P(^(8,1,0),U,15)=11 D SET^ORDD100(+IFN,1) - Q - ; -ACTLOG(PTEVT,ACTION,EVTYPE,SAVE) ; -- Log a note for ACTION on PTEVT - ; SAVE => new data in VAIP() will be saved - Q:'$G(PTEVT) Q:'$D(^ORE(100.2,PTEVT,0)) Q:'$L($G(ACTION)) - N I,HDR,LAST,TOTAL,DA,ORNOW,MVT - F I=1:1:10 L +^ORE(100.2,PTEVT,10,0):1 Q:$T H 2 - Q:'$T "^" S HDR=$G(^ORE(100.2,PTEVT,10,0)) S:'$L(HDR) HDR="^100.25DA^^" - S TOTAL=+$P(HDR,U,4),LAST=+$O(^ORE(100.2,PTEVT,10,"B"),-1) - S I=LAST F I=(I+1):1 Q:'$D(^ORE(100.2,PTEVT,10,I,0)) - S DA=I,$P(HDR,U,3,4)=DA_U_(TOTAL+1) - S ^ORE(100.2,PTEVT,10,0)=HDR L -^ORE(100.2,PTEVT,10,0) - S ORNOW=+$$NOW^XLFDT,^ORE(100.2,PTEVT,10,"B",ORNOW,DA)="" - S ^ORE(100.2,PTEVT,10,DA,0)=ORNOW_U_ACTION_U_$S(ACTION="LP":"",1:$G(DUZ))_U_$G(EVTYPE) - S MVT=+$P($G(^ORE(100.2,PTEVT,1)),U,2) - S:MVT ^ORE(100.2,"ADT",MVT,ORNOW,PTEVT,DA)="" - I $G(SAVE),$G(VAIP(4)) S $P(^ORE(100.2,PTEVT,10,DA,0),U,5,7)=+VAIP(4)_U_+VAIP(8)_U_+VAIP(5) - Q - ; -LAPSED(PTEVT) ; -- Ck if PTEVT has lapsed, if so lapse all orders - N Y,X0,EVT,ENTERED,DAYS S Y=0 - I $G(^ORE(100.2,PTEVT,1)) G LPQ ;already terminated - S X0=$G(^ORE(100.2,PTEVT,0)),EVT=+$P(X0,U,2),ENTERED=+$P(X0,U,5) - S:$P($G(^ORD(100.5,EVT,0)),U,12) EVT=+$P(^(0),U,12) ;parent - S DAYS=+$P($G(^ORD(100.5,EVT,0)),U,6) I DAYS<1 G LPQ ;doesn't lapse - I ENTERED>$$FMADD^XLFDT(DT,(0-DAYS)) G LPQ ;not lapsed yet - D LP1(PTEVT) S Y=1 ;lapse orders, event - N J S J=0 F S J=$O(^ORE(100.2,"DAD",PTEVT,J)) Q:'J D LP1(J) -LPQ Q Y - ; -LP1(PTEVT) ; -- Lapse orders, event PTEVT - N X0,PAT,IFN,STS - S X0=$G(^ORE(100.2,PTEVT,0)),PAT=+$P(X0,U)_";DPT(" - S IFN=0 F S IFN=$O(^OR(100,"AEVNT",PAT,PTEVT,IFN)) Q:IFN<1 D - . S STS=$P($G(^OR(100,IFN,3)),U,3) I (STS=10)!(STS=11)!(IFN=+$P(X0,U,4)) D - .. D STATUS^ORCSAVE2(IFN,14) - .. D ALPS^ORCSAVE2(IFN,1,"DELAYED ORDER") - .. S $P(^OR(100,IFN,8,1,0),U,15)="" D:$P(^(0),U,4)=2 SIGN^ORCSAVE2(IFN,"","",5,1) - D DONE(PTEVT),ACTLOG(PTEVT,"LP") - Q +OREVNTX ; SLC/MKB - Event delayed orders RPC's ; 08 May 2002 2:12 PM + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141**;Dec 17, 1997 + ; +PAT(ORY,DFN) ; -- Returns currently delayed events for patient DFN + N EVT,CNT,X,Y S DFN=+$G(DFN),(EVT,CNT)=0 + F S EVT=+$O(^ORE(100.2,"AE",DFN,EVT)) Q:EVT<1 S Y=+$O(^(EVT,0)) D + . I $G(^ORE(100.2,Y,1)) K ^ORE(100.2,"AE",DFN,EVT,Y) Q + . Q:$$LAPSED(Y) ;I $$EMPTY(Y) D CANCEL(Y) Q + . Q:$O(^ORE(100.2,"DAD",Y,0)) ;has children + . S X=$P($G(^ORD(100.5,EVT,0)),U,8),X="Delayed "_$$LOWER^VALM1(X) + . S CNT=CNT+1,ORY(CNT)=Y_U_X + S:CNT ORY(0)=CNT + Q + ; +EXISTS(DFN,EVT) ; -- Returns 1 if patient DFN has delayed orders for EVT, + ; or 2 if parent/sibling event has delayed orders, else 0 + ; + N X,Y,I S Y=0 I '$G(DFN)!'$G(EVT) G EXQ + I $O(^ORE(100.2,"AE",+DFN,+EVT,0)) S Y=1 G EXQ + S X=+$P($G(^ORD(100.5,+EVT,0)),U,12) I X D G EXQ ;ck parent,siblings + . I $O(^ORE(100.2,"AE",+DFN,X,0)) S Y=2 Q + . S I=0 F S I=+$O(^ORD(100.5,"DAD",X,I)) Q:I<1 I $O(^ORE(100.2,"AE",+DFN,I,0)) S Y=2 Q +EXQ Q Y + ; +LIST(ORY,DFN) ; -- Returns all processed events for patient DFN as + ; ORY(#) = PatEvtIEN ^ Display Text ^ EvtDateTime + ; in reverse chronological order + N IDT,DA,CNT,X0,X1,EVT,DC,X + S DFN=+$G(DFN),(IDT,CNT)=0 + F S IDT=$O(^ORE(100.2,"AC",DFN,IDT)) Q:IDT<1 D + . S DA=0 F S DA=+$O(^ORE(100.2,"AC",DFN,IDT,DA)) Q:DA<1 D + .. S X0=$G(^ORE(100.2,DA,0)),X1=$G(^(1)) Q:$P(X1,U,5) ;has parent + .. S EVT=+$P(X0,U,2),DC=+$P(X1,U,3) + .. I '$P(X0,U,4),'$O(^ORE(100.2,DA,2,0)),'$O(^ORE(100.2,DA,3,0)),'$D(^OR(100,"AEVNT",DFN_";DPT(",DA)) Q ;no orders + .. S I=+$O(^ORE(100.2,DA,10,"B"),-1),X=$P($G(^(I,0)),U,2) I X="LP"!(X="CA") Q ;lapsed or cancelled + .. ;Q if not current admission? + .. S X=$S(EVT:$P($G(^ORD(100.5,EVT,0)),U,8),DC:$P($G(^ORD(100.6,DC,0)),U,5),1:"UNSPECIFIED EVENT") + .. S X=$$LOWER^VALM1(X),CNT=CNT+1,ORY(CNT)=DA_U_X_U_$P(X1,U) + S:CNT ORY(0)=CNT + Q + ; +COMP(PTEVT) ; -- Returns 1 or 0, if PTEVT has been completed + N Y,I S Y=$S($G(^ORE(100.2,+$G(PTEVT),1)):1,1:0) + I Y S I=+$O(^ORE(100.2,+$G(PTEVT),10,0)) S:$P($G(^(I,0)),U,2)="CA" Y=0 + Q Y + ; +ACTIVE(ORY,TYPE) ; -- Returns all active events [of TYPE] from #100.5 + ; where TYPE=string containing any of the codes from the TYPE field + N NM,IEN,CNT,X0,X S CNT=0,TYPE=$G(TYPE) + S NM="" F S NM=$O(^ORD(100.5,"C",NM)) Q:NM="" D + . S IEN=0 F S IEN=+$O(^ORD(100.5,"C",NM,IEN)) Q:IEN<1 D + .. S X0=$G(^ORD(100.5,IEN,0)) I '$L($P(X0,U,2)) D ;Child event + ... S X=$P(X0,U,12) S:X $P(X0,U,2)=$P($G(^ORD(100.5,+X,0)),U,2) + .. I $L(TYPE),TYPE'[$P(X0,U,2) Q + .. Q:$O(^ORD(100.5,"DAD",IEN,0)) ;Parent event + .. S CNT=CNT+1,ORY(CNT)=IEN_U_X0 + S:CNT ORY(0)=CNT + Q + ; +NAME(PTEVT) ; -- Return name of Patient Event + N X,Y,Z S X=+$P($G(^ORE(100.2,+$G(PTEVT),0)),U,2),Z=$G(^(1)) + S:X Y=$P($G(^ORD(100.5,X,0)),U,8) + I 'X S X=+$P(Z,U,3),Y=$P($G(^ORD(100.6,X,0)),U,5) + S Y=$S('Z:"Delayed ",1:"")_$$LOWER^VALM1(Y) + Q Y + ; +SHORTNM(PTEVT) ; -- Return Short Name of Patient Event + ; or first 15 characters of Event Name if unspecified + N X,Y,Y0 S X=+$P($G(^ORE(100.2,+$G(PTEVT),0)),U,2) I X D + . S Y0=$G(^ORD(100.5,X,0)),Y=$P(Y0,U,10) + . S:'$L(Y) Y=$E($P(Y0,U,8),1,15) + I 'X S X=+$P($G(^ORE(100.2,+$G(PTEVT),1)),U,3),Y=$E($P($G(^ORD(100.6,X,0)),U,5),1,15) + Q Y + ; +EVT(PTEVT) ; -- Return Event ptr #100.5, given PTEVT ptr #100.2 + Q +$P($G(^ORE(100.2,+$G(PTEVT),0)),U,2) + ; +DC(PTEVT) ; -- Return DC Rule ptr #100.6, given PTEVT ptr #100.2 + I $P($G(^ORE(100.2,+$G(PTEVT),1)),U,5) S PTEVT=$P(^(1),U,5) ;use parent + Q +$P($G(^ORE(100.2,+$G(PTEVT),1)),U,3) + ; +TYPE(PTEVT) ; -- Return Type of Patient Event (i.e. A/D/T) + N X,Y S X=+$P($G(^ORE(100.2,+$G(PTEVT),0)),U,2) + I $P($G(^ORD(100.5,X,0)),U,12) S X=$P(^(0),U,12) ;use parent + S Y=$S(X:$P($G(^ORD(100.5,X,0)),U,2),1:"DC") + Q Y + ; +DIV(PTEVT) ; -- Return Division for PTEVT + N X,Y S X=+$P($G(^ORE(100.2,+$G(PTEVT),0)),U,2) + I $P($G(^ORD(100.5,X,0)),U,12) S X=$P(^(0),U,12) ;use parent + S Y=+$P($G(^ORD(100.5,X,0)),U,3) S:Y<1 Y=+$G(DUZ(2)) + Q Y + ; +LOC(PTEVT) ; -- Return Default Ordering Location for PTEVT + N X,X0,Y S X=+$P($G(^ORE(100.2,+$G(PTEVT),0)),U,2) + S X0=$G(^ORD(100.5,X,0)),Y=+$P(X0,U,9)_";SC(" + I Y<1,$P(X0,U,12) S Y=+$P($G(^ORD(100.5,+$P(X0,U,12),0)),U,9)_";SC(" + S:Y<1 Y=$G(ORL) + Q Y + ; +EMPTY(PTEVT) ; -- Returns 1 or 0, if PTEVT has delayed orders + N Y,OR0,PAT,TYPE,PSO,IFN,STS S Y=1 I '$G(PTEVT) Q Y + S OR0=$G(^ORE(100.2,+PTEVT,0)),PAT=+$P(OR0,U)_";DPT(" + S TYPE=$$TYPE(PTEVT) I TYPE="D" S PSO=+$O(^DIC(9.4,"C","PSO",0)) + S IFN=0 F S IFN=$O(^OR(100,"AEVNT",PAT,PTEVT,IFN)) Q:IFN<1 D Q:'Y + . S STS=$P($G(^OR(100,IFN,3)),U,3) I STS=10 S Y=0 Q + . ;I IFN=+$P(OR0,U,4),STS=11!(STS=6) S Y=0 Q + . I TYPE="D",$P($G(^OR(100,IFN,0)),U,14)=PSO,STS=5!(STS=6) S Y=0 Q + I Y,$D(^ORE(100.2,"DAD",PTEVT)) D ;ck child events + . N CHLD S CHLD=0 + . F S CHLD=+$O(^ORE(100.2,"DAD",PTEVT,CHLD)) Q:CHLD<1 D Q:'Y + .. S IFN=0 F S IFN=$O(^OR(100,"AEVNT",PAT,CHLD,IFN)) Q:IFN<1 I $P($G(^OR(100,IFN,3)),U,3)=10 S Y=0 Q + Q Y + ; +EVTORDER(ORDER) ; -- Returns 1 or 0, if ORDER is for event + ; Will return 0 if action DA is included but not NW + N X0,X,Y S X0=$G(^OR(100,+ORDER,0)),X=+$P(ORDER,";",2),Y=0 + I $P(X0,U,17),X'>1 D + . I $P($G(^ORE(100.2,+$P(X0,U,17),0)),U,4)=+ORDER S Y=1 Q + . S DAD=+$P($G(^ORE(100.2,+$P(X0,U,17),1)),U,5) ;has parent? + . I DAD,$P($G(^ORE(100.2,DAD,0)),U,4)=+ORDER S Y=1 + Q Y + ; +MANREL(ORDER) ; -- Returns 1 or 0, if ORDER was manually released + N EVT,Y,RELDT,TYPE,EVTDT S Y=0 + S EVT=+$P($G(^OR(100,+ORDER,0)),U,17),RELDT=+$P($G(^(8,1,0)),U,16) + G:EVT<1 MNQ G:RELDT<1 MNQ ;not delayed or released + I '$D(^ORE(100.2,EVT,2,+ORDER)) S Y=1 G MNQ ;not rel'd by event + S TYPE=$$TYPE(EVT),EVTDT=+$G(^ORE(100.2,EVT,1)) + I TYPE="M",$$FMDIFF^XLFDT(EVTDT,RELDT,2)<300 S Y=1 +MNQ Q Y + ; +CANCEL(PTEVT) ; -- Cancel empty PTEVT, event order + S PTEVT=+$G(PTEVT) D DONE(PTEVT),ACTLOG(PTEVT,"CA") + N IFN,DAD S IFN=+$P($G(^ORE(100.2,PTEVT,0)),U,4) + I IFN<1 D ;ck for parent w/event order + . S DAD=+$P($G(^ORE(100.2,PTEVT,1)),U,5) Q:DAD<1 + . Q:'$G(^ORE(100.2,DAD,1)) ;parent still active + . S IFN=+$P($G(^ORE(100.2,DAD,0)),U,4) + I IFN D:'$$DCD^ORCACT2(IFN) CLRDLY^ORCACT2(IFN) ;cancel event order + Q + ; +DONE(PTEVT,WHEN,MVT,OR) ; -- Terminate PTEVT + Q:'$G(PTEVT) Q:'$D(^ORE(100.2,PTEVT,0)) + N X0,X1,PAT,EVT,DAD + S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12) D D1 + S DAD=$P(X1,U,5) I DAD,$$ALLDONE(DAD) S PTEVT=DAD D D1 Q + S DAD=PTEVT,PTEVT=0 ;if PTEVT=parent, terminate children too + F S PTEVT=+$O(^ORE(100.2,"DAD",DAD,PTEVT)) Q:PTEVT<1 D D1 + Q +D1 S X0=$G(^ORE(100.2,+PTEVT,0)),X1=$G(^(1)) Q:'$L(X0) + S PAT=+$P(X0,U),EVT=+$P(X0,U,2) ;,ORD=+$P(X0,U,4) + S $P(X1,U,1,2)=WHEN_U_$G(MVT),$P(X1,U,4)=$G(OR),^ORE(100.2,PTEVT,1)=X1 + S ^ORE(100.2,"AC",PAT,9999999-WHEN,PTEVT)="" + S:$G(OR) ^ORE(100.2,"ASR",OR,PTEVT)="" + K:EVT ^ORE(100.2,"AE",PAT,EVT,PTEVT) + Q + ; +ALLDONE(DAD) ; -- Returns 1 or 0, if all child events are done + N I,Y S Y=1,I=0 + F S I=+$O(^ORE(100.2,"DAD",+$G(DAD),I)) Q:I<1 I '$G(^ORE(100.2,I,1)) S Y=0 Q + Q Y + ; +CHGEVT(IFN,NEWEVT) ; -- Change the Patient Event for order IFN to NEWEVT + ; Includes adding or removing event pointer to order + Q:'$G(IFN) N PAT,OLDEVT,OR3 S:$G(NEWEVT) NEWEVT=+NEWEVT + S PAT=$P($G(^OR(100,+IFN,0)),U,2),OLDEVT=$P($G(^(0)),U,17),OR3=$G(^(3)) + Q:OLDEVT=NEWEVT K:OLDEVT ^OR(100,"AEVNT",PAT,OLDEVT,+IFN) + S $P(^OR(100,+IFN,0),U,17)=NEWEVT S:NEWEVT ^OR(100,"AEVNT",PAT,NEWEVT,+IFN)="" + I NEWEVT,$P(OR3,U,3)'=10 S $P(^OR(100,+IFN,3),U,3)=10,$P(^(8,1,0),U,15)=10 + I 'NEWEVT,$P(OR3,U,3)=10 S $P(^OR(100,+IFN,3),U,3)=11,$P(^(8,1,0),U,15)=11 D SET^ORDD100(+IFN,1) + Q + ; +ACTLOG(PTEVT,ACTION,EVTYPE,SAVE) ; -- Log a note for ACTION on PTEVT + ; SAVE => new data in VAIP() will be saved + Q:'$G(PTEVT) Q:'$D(^ORE(100.2,PTEVT,0)) Q:'$L($G(ACTION)) + N I,HDR,LAST,TOTAL,DA,ORNOW,MVT + F I=1:1:10 L +^ORE(100.2,PTEVT,10,0):1 Q:$T H 2 + Q:'$T "^" S HDR=$G(^ORE(100.2,PTEVT,10,0)) S:'$L(HDR) HDR="^100.25DA^^" + S TOTAL=+$P(HDR,U,4),LAST=+$O(^ORE(100.2,PTEVT,10,"B"),-1) + S I=LAST F I=(I+1):1 Q:'$D(^ORE(100.2,PTEVT,10,I,0)) + S DA=I,$P(HDR,U,3,4)=DA_U_(TOTAL+1) + S ^ORE(100.2,PTEVT,10,0)=HDR L -^ORE(100.2,PTEVT,10,0) + S ORNOW=+$$NOW^XLFDT,^ORE(100.2,PTEVT,10,"B",ORNOW,DA)="" + S ^ORE(100.2,PTEVT,10,DA,0)=ORNOW_U_ACTION_U_$S(ACTION="LP":"",1:$G(DUZ))_U_$G(EVTYPE) + S MVT=+$P($G(^ORE(100.2,PTEVT,1)),U,2) + S:MVT ^ORE(100.2,"ADT",MVT,ORNOW,PTEVT,DA)="" + I $G(SAVE),$G(VAIP(4)) S $P(^ORE(100.2,PTEVT,10,DA,0),U,5,7)=+VAIP(4)_U_+VAIP(8)_U_+VAIP(5) + Q + ; +LAPSED(PTEVT) ; -- Ck if PTEVT has lapsed, if so lapse all orders + N Y,X0,EVT,ENTERED,DAYS S Y=0 + I $G(^ORE(100.2,PTEVT,1)) G LPQ ;already terminated + S X0=$G(^ORE(100.2,PTEVT,0)),EVT=+$P(X0,U,2),ENTERED=+$P(X0,U,5) + S:$P($G(^ORD(100.5,EVT,0)),U,12) EVT=+$P(^(0),U,12) ;parent + S DAYS=+$P($G(^ORD(100.5,EVT,0)),U,6) I DAYS<1 G LPQ ;doesn't lapse + I ENTERED>$$FMADD^XLFDT(DT,(0-DAYS)) G LPQ ;not lapsed yet + D LP1(PTEVT) S Y=1 ;lapse orders, event +LPQ Q Y + ; +LP1(PTEVT) ; -- Lapse orders, event PTEVT + N X0,PAT,IFN,STS + S X0=$G(^ORE(100.2,PTEVT,0)),PAT=+$P(X0,U)_";DPT(" + S IFN=0 F S IFN=$O(^OR(100,"AEVNT",PAT,PTEVT,IFN)) Q:IFN<1 D + . S STS=$P($G(^OR(100,IFN,3)),U,3) I (STS=10)!(STS=11)!(IFN=+$P(X0,U,4)) D + .. D STATUS^ORCSAVE2(IFN,14) + .. S $P(^OR(100,IFN,8,1,0),U,15)="" D:$P(^(0),U,4)=2 SIGN^ORCSAVE2(IFN,"","",5,1) + D DONE(PTEVT),ACTLOG(PTEVT,"LP") + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OREVNTX1.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OREVNTX1.m index b2670cff..1f6f3494 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OREVNTX1.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OREVNTX1.m @@ -1,303 +1,305 @@ -OREVNTX1 ; SLC/JLI - Event delayed orders RPC's ;9/19/02 13:35 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141,165,149,243**;Dec 17, 1997;Build 242 - ; -PUTEVNT(ORY,DFN,EVT,ORIFN) ; Save new patient delayed events to file 100.2 - S ORY=$$NEW^OREVNT(DFN,EVT,ORIFN) - Q - ; -GTEVT(ORY,PTEVT) ; Return Event infomation based on PTEVT ptr #100.2 - ;EVTID ptr #100.5 - Q:'+PTEVT - N EVTID,EVTTYPE,EVTNAME,EVTDISP,EVTDLG,PRTEVT - S (EVTTYPE,EVTNAME,EVTDISP,PRTEVT)="" - S EVTDLG=0 - I '$P(^ORE(100.2,+$G(PTEVT),0),U,2) Q - S EVTID=$$EVT^OREVNTX(PTEVT) - S PRTEVT=$P(^ORD(100.5,EVTID,0),U,12) - I PRTEVT S EVTTYPE=$P(^ORD(100.5,PRTEVT,0),U,2) - E S EVTTYPE=$P(^ORD(100.5,EVTID,0),U,2) - I $D(^ORD(100.5,EVTID,0)) D - . S EVTNAME=$P(^ORD(100.5,EVTID,0),U,1) - . S EVTDISP=$P(^ORD(100.5,EVTID,0),U,8) - . S EVTDLG=$P(^ORD(100.5,EVTID,0),U,4) - S ORY=EVTTYPE_U_EVTID_U_EVTNAME_U_EVTDISP_U_EVTDLG - Q -GTEVT1(ORY,EVT) ; Return Event information based on EVT ptr #100.5 - ;EVT ptr #100.5 - Q:'+EVT - N EVTTYPE,EVTNAME,EVTDISP,EVTDLG,PRTEVT - S (EVTDLG,PRTEVT)=0 - S PRTEVT=$P(^ORD(100.5,+EVT,0),U,12) - I PRTEVT>0 S EVTTYPE=$P(^ORD(100.5,PRTEVT,0),U,2) - E S EVTTYPE=$P(^ORD(100.5,+EVT,0),U,2) - S EVTNAME=$P($G(^ORD(100.5,+EVT,0)),U,1) - S EVTDISP=$P($G(^ORD(100.5,+EVT,0)),U,8) - S EVTDLG=$P($G(^ORD(100.5,+EVT,0)),U,4) - S ORY=EVTTYPE_U_EVT_U_EVTNAME_U_EVTDISP_U_EVTDLG - Q - ; -EVT(ORY,PTEVT) ; Return Event ptr #100.5, given PTEVT ptr #100.2 - Q:'+PTEVT - S ORY=$$EVT^OREVNTX(PTEVT) - Q - ; -EXISTS(ORY,DFN,EVT) ;Returns PtEvtID ptr #100.2 if patient already has delayed orders - I '+EVT S ORY=0 Q - N PTEVT S (PTEVT,ORY)=0 - S PTEVT=$O(^ORE(100.2,"AE",+DFN,+EVT,PTEVT)) - I PTEVT>0 S ORY=PTEVT - Q - ; -TYPEXT(ORY,DFN,EVT) ; does EVT has delayed orders? - ; 1 if Patient DFN has delayed orders for EVT - ; 2 if Parent/Sibling event has delayed orders - ; 0 if No delayed orders for EVT - Q:'+EVT - S ORY=$$EXISTS^OREVNTX(DFN,EVT) - Q - ; -MATCH(ORY,DFN,EVT) ;If Pt's current data match selected event - ;DFN: patient DFN - ;EVT: ptr to #100.5 - S ORY=0 - Q:('+DFN)!('+EVT) - S ORY=$$MATCH^OREVNT(DFN,EVT) - N TS,TSNM - S TS=$S($G(ORTS):+ORTS,1:+$G(^DPT(DFN,.103))) - S TSNM=$P($G(^DIC(45.7,TS,0)),U) - S:ORY ORY=ORY_U_TSNM - Q - ; -NAME(ORY,PTEVT) ; Return Event name from #100.5, given PTEVT ptr #100.2 - I PTEVT'>0 S ORY="" Q - S ORY=$$NAME^OREVNTX(PTEVT) - Q - ; -DIV(ORY,PTEVT) ; Return division for PTEVT ptr #100.2 - Q:'+PTEVT - S ORY=$$DIV^OREVNTX(PTEVT) - Q - ; -DIV1(ORY,EVT) ; Return division for EVT ptr #100.5 - Q:'+EVT - S ORY=+$P($G(^ORD(100.5,+EVT,0)),U,3) S:ORY<1 ORY=+$G(DUZ(2)) - Q - ; -LOC(ORY,PTEVT) ; Return default hospital location ^SC( for PTEVT ptr #100.2 - Q:'+PTEVT - S ORY=$$LOC^OREVNTX(PTEVT) - S ORY=+ORY - Q - ; -LOC1(ORY,EVT) ; Return default hospital location ^SC( for EVT ptr #100.5 - Q:'+EVT - S ORY=+$P($G(^ORD(100.5,+EVT,0)),U,9) S:ORY<1 ORY=+$G(ORL) - Q - ; -CHGEVT(ORY,NEWEVT,ORIDS) ; Change order's event - N ORI - S ORI=0 - F S ORI=$O(ORIDS(ORI)) Q:'+ORI D - . D CHGEVT^OREVNTX(+$G(ORIDS(ORI)),NEWEVT) - Q - ; -EMPTY(ORY,PTEVT) ; Return 1 if PTEVT doesn't have any orders - Q:'+PTEVT - S ORY=$$EMPTY^OREVNTX(PTEVT) - Q - ; -DELPTEVT(ORY,PTEVT) ; Delete Patient Event in #100.2 - Q:'+PTEVT - D CANCEL^OREVNTX(PTEVT) - Q - ; -UPDTOR(ORY,PTIFN,ORIFN,PTEVT) ; If delayed order was DCed, then update the EVENT and "AEVNT" - Q ;Don't ever need to do this! -CURSPE(ORY,PTIFN) ; Return current treating specialty - Q:'PTIFN - N SPEC S SPEC=$$PT^DGPMOBS(PTIFN),ORY="" - I SPEC'<0 S ORY=$P(SPEC,U,3)_U_$P(SPEC,U,2)_U_$P(SPEC,U) ;name^ien^obs flag - Q -DFLTEVT(ORY,PVIFN) ; Return default release event based on provider IFN - N CMEVTLST,IDX - S CMEVTLST="",IDX=0 - D GETLST^OREV3(.CMEVTLST) - F S IDX=$O(CMEVTLST(IDX)) Q:'IDX D - . I $P($G(CMEVTLST(IDX)),U,2) S ORY=$P($G(CMEVTLST(IDX)),U) Q - Q -CMEVTS(ORY,CLOC) ;Return common event list - N IDX,X0,X,LOC - S:CLOC>0 LOC=CLOC - S IDX=0,ORY="" - D GETLST^OREV3(.ORY) - F S IDX=$O(ORY(IDX)) Q:'IDX D - . S X0="" - . S:$L($G(^ORD(100.5,+ORY(IDX),0))) X0=$G(^(0)) - . I '$L($P(X0,U,2)) D - .. S X=$P(X0,U,12) S:X $P(X0,U,2)=$P($G(^ORD(100.5,+X,0)),U,2) - . S:$L(X0) ORY(IDX)=+ORY(IDX)_U_X0 - Q - ; -DELDFLT(ORY,PVIFN) ; Delete default release event - Q:'PVIFN - N ORERR - S ORERR="" - D DEL^XPAR(PVIFN_";VA(200,","OREVNT DEFAULT",1,.ORERR) - Q -WRLSTED(LST,LOC,EVTID) ; Return list of dialogs for writing event delayed orders - ; .Y(n): DlgName^ListBox Text -WRLST1 N ANENT - S LOC=+$G(LOC)_";SC(" I 'LOC S LOC="" - S ANENT="ALL^USR.`"_DUZ_"^"_LOC_$S($G(^VA(200,DUZ,5)):"^SRV.`"_+$G(^(5)),1:"") - N MNU,SEQ,IEN,ITM,TXT,FID,DGRP,X,TYP - S MNU=$$GET^XPAR(ANENT,"ORWDX WRITE ORDERS EVENT LIST",EVTID,"I") Q:'MNU - S SEQ=0 F S SEQ=$O(^ORD(101.41,MNU,10,"B",SEQ)) Q:'SEQ D - . S IEN=0 F S IEN=$O(^ORD(101.41,MNU,10,"B",SEQ,IEN)) Q:'IEN D - . . S X=$G(^ORD(101.41,MNU,10,IEN,0)),ITM=+$P(X,U,2),TXT=$P(X,U,4) - . . S X=$G(^ORD(101.41,ITM,5)),FID=+$P(X,U,5) - . . S X=$G(^ORD(101.41,ITM,0)),TYP=$P(X,U,4),DGRP=+$P(X,U,5) - . . S:'$L(TXT) TXT=$P(X,U,2) - . . I TYP="M" S:'FID FID=1001 - . . S LST(SEQ)=ITM_";"_FID_";"_DGRP_";"_TYP_U_TXT - Q - ; -GETDLG(LST,DLGID) ; Return dialog infomation based on the DLGID - N DIEN,DFID,DTXT,DTYP,DGRP,X0,X5 - S DLGID=+DLGID - Q:'DLGID - S X0=^ORD(101.41,DLGID,0),X5=$G(^(5)) - S DGRP=+$P(X0,U,5),DFID=+$P(X5,U,5),DTXT=$P(X5,U,4),DTYP=$P(X0,U,4) - S:'$L(DTXT) DTXT=$P(X0,U,2) - I $P(X0,U,4)="M" S:'DFID DFID=1001 - S LST=DLGID_";"_DFID_";"_DGRP_";"_DTYP_U_DTXT - Q -DONE(LST,PTEVT) ; Terminate PTEvt - Q:'PTEVT - D DONE^OREVNTX(PTEVT) - D ACTLOG^OREVNTX(PTEVT,"MN") - Q -SETDFLT(ORY,EVT) ;Set personal default event - N ERR,VAL S ERR="" - Q:'$D(^ORD(100.5,EVT,0)) - S VAL=$P(^ORD(100.5,EVT,0),U) - D EN^XPAR(DUZ_";VA(200,","OREVNT DEFAULT",1,VAL,ERR) - S ORY=ERR - Q -CPACT(ORY,EVT) ; Return True/False to display active orders for copy - ; EVT ptr to #100.5 - Q:'EVT - S ORY=0 - Q:'$D(^ORD(100.5,EVT,0)) - S ORY=$P(^ORD(100.5,EVT,0),U,11) - Q -PRMPTID(ORY,PRTNM) ;Return event prompt IEN for OR GTX EVENT - S:$D(^ORD(101.41,"B","OR GTX EVENT")) ORY=$O(^("OR GTX EVENT",0)) - Q -ISDCOD(ORY,ORIFN) ;True: the order need to be filtered out - N PAS,X3,X0,ORGRPLST,THEGRP,IDX,ODGRP - S (ORY,IDX)=0 - Q:'$D(^OR(100,+ORIFN,0)) - S X0=$G(^OR(100,+ORIFN,0)) - S ODGRP=$P(X0,U,11) - D GETLST^XPAR(.ORGRPLST,"ALL","OREVNT EXCLUDE DGRP") - F S IDX=$O(ORGRPLST(IDX)) Q:'IDX!ORY D - . S THEGRP=$P($G(ORGRPLST(IDX)),U,2) - . I $$GRPCHK(THEGRP,ODGRP) S ORY=1 - I ORY Q - S PAS=";1;" - S:$D(^OR(100,+ORIFN,3)) X3=^OR(100,+ORIFN,3) - S:(PAS'[(";"_$P(X3,U,3)_";")) ORY=0 - Q -DEFLTS(ORY,EVTID) ;Return default specialty for EVTID(#100.5) - Q:'+EVTID - N PRTEVT - S PRTEVT=0 - S PRTEVT=$P(^ORD(100.5,+EVTID,0),U,12) - I PRTEVT>0 S EVTID=PRTEVT - S ORY=$$DEFTS^ORCDADT(EVTID) - Q - ; -MULTS(ORY,EVTID) ;Return specialty list for the EVTID(#100.5) - Q:'+EVTID - N I,CNT,X,Y S (I,CNT)=0 - N PRTEVT - S PRTEVT=0 - S PRTEVT=$P(^ORD(100.5,+EVTID,0),U,12) - I PRTEVT>0 S EVTID=PRTEVT - F S I=$O(^ORD(100.5,+$G(EVTID),"TS",I)) Q:I<1 S X=+$G(^(I,0)) D - . S Y=$$GET1^DIQ(45.7,X_",",.01) - . S CNT=CNT+1,ORY(CNT)=X_U_Y - Q - ; -PRTIDS(ORY,IDS) ;Return some prompt ids from #101.41 - ; treating specialty Id^attending provider id - N IDX,ORTS,ORATT - S (ORY,ORTS,ORATT)="" - S IDX=$O(^ORD(101.41,"B","OR GTX TREATING SPECIALTY",0)) - S:$D(^ORD(101.41,IDX,1)) ORTS=$P($G(^ORD(101.41,IDX,1)),U,2,3) - S IDX=$O(^ORD(101.41,"B","OR GTX PROVIDER",0)) - S:$D(^ORD(101.41,IDX,1)) ORATT=$P($G(^ORD(101.41,IDX,1)),U,2,3) - S ORY=ORTS_"~"_ORATT - Q - ; -DFLTDLG(ORY,EVTID) ;Return event default dialog IEN - S ORY=0 - Q:'$D(^ORD(100.5,+EVTID,0)) - S ORY=$P(^ORD(100.5,+EVTID,0),U,4) - Q -AUTHMREL(ORY,USER) ;1: user can manual release delayed orders 0: can't - S ORY=$$CANREL^OREV3 - Q -HAVEPRT(ORY,PTEVT) ;return parent patient event from #100.2 - Q:'+PTEVT - S ORY="" - S:$L($G(^ORE(100.2,PTEVT,1))) ORY=$P(^(1),U,5) - Q -GRPCHK(DG,AGRP) ;If an order's group belong to DG group - N RST - S RST=0 - N ORGRP - D GRP^ORQ1(DG) - S RST=$S($D(ORGRP(AGRP)):1,1:0) - Q RST -ODPTEVID(ORY,ORID) ;Return PtEvtID based on the ORID - Q:'$D(^OR(100,+ORID,0)) - S ORY=$P($G(^OR(100,+ORID,0)),U,17) - Q -COMP(ORY,PTEVT) ;Return 1 or 0 if PTEVT completed or not - Q:'+PTEVT - S ORY=$$COMP^OREVNTX(+PTEVT) - Q -ISHDORD(ORY,ORID) ;Return 1 if it's on-hold med order - Q:'+ORID - Q:'$D(^OR(100,+ORID,0)) - N STS,HDSTS,ODGP,INPT,OUPT,MEDS,IVMD - S HDSTS=$O(^ORD(100.01,"B","HOLD",0)) - S STS=$P($G(^OR(100,+ORID,3)),U,3) - S INPT=$O(^ORD(100.98,"B","UD RX",0)) - S OUPT=$O(^ORD(100.98,"B","O RX",0)) - S MEDS=$O(^ORD(100.98,"B","RX",0)) - S IVMD=$O(^ORD(100.98,"B","IV RX",0)) - S ODGP=$P(^OR(100,+ORID,0),U,11) - I (U_INPT_U_OUPT_U_MEDS_U_IVMD_U[U_ODGP_U),(HDSTS=STS) S ORY=1 - Q -ISPASS(ORY,PTEVTID,EVTTYPE) ;Return 1 if it's a pass event - S ORY=$$EVT^OREVNTX(PTEVTID) - S ORY=$P($G(^ORD(100.5,+ORY,0)),U,7) - I EVTTYPE="T",ORY,ORY<4 S ORY=1 - E S ORY=0 - Q -ISPASS1(ORY,EVTID,EVTTYPE) ;Return 1 if it's a pass event - S ORY=$P($G(^ORD(100.5,+EVTID,0)),U,7) - I EVTTYPE="T",ORY,ORY<4 S ORY=1 - E S ORY=0 - Q -DLGIEN(ORY,DLGNAME) ;Return Order Dialog IEN based on name - Q:'$D(^ORD(101.41,"B",DLGNAME)) - S ORY=$O(^ORD(101.41,"B",DLGNAME,0)) - Q -GETSTS(ORY,ORDID) ;Return Order status - Q:'+ORDID - Q:'$D(^OR(100,+ORDID,0)) - S ORY=$P($G(^OR(100,+ORDID,3)),U,3) - Q +OREVNTX1 ; SLC/JLI - Event delayed orders RPC's ;9/19/02 13:35 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141,165,149**;Dec 17, 1997 + ; +PUTEVNT(ORY,DFN,EVT,ORIFN) ; Save new patient delayed events to file 100.2 + S ORY=$$NEW^OREVNT(DFN,EVT,ORIFN) + Q + ; +GTEVT(ORY,PTEVT) ; Return Event infomation based on PTEVT ptr #100.2 + ;EVTID ptr #100.5 + Q:'+PTEVT + N EVTID,EVTTYPE,EVTNAME,EVTDISP,EVTDLG,PRTEVT + S (EVTTYPE,EVTNAME,EVTDISP,PRTEVT)="" + S EVTDLG=0 + I '$P(^ORE(100.2,+$G(PTEVT),0),U,2) Q + S EVTID=$$EVT^OREVNTX(PTEVT) + S PRTEVT=$P(^ORD(100.5,EVTID,0),U,12) + I PRTEVT S EVTTYPE=$P(^ORD(100.5,PRTEVT,0),U,2) + E S EVTTYPE=$P(^ORD(100.5,EVTID,0),U,2) + I $D(^ORD(100.5,EVTID,0)) D + . S EVTNAME=$P(^ORD(100.5,EVTID,0),U,1) + . S EVTDISP=$P(^ORD(100.5,EVTID,0),U,8) + . S EVTDLG=$P(^ORD(100.5,EVTID,0),U,4) + S ORY=EVTTYPE_U_EVTID_U_EVTNAME_U_EVTDISP_U_EVTDLG + Q +GTEVT1(ORY,EVT) ; Return Event information based on EVT ptr #100.5 + ;EVT ptr #100.5 + Q:'+EVT + N EVTTYPE,EVTNAME,EVTDISP,EVTDLG,PRTEVT + S (EVTDLG,PRTEVT)=0 + S PRTEVT=$P(^ORD(100.5,+EVT,0),U,12) + I PRTEVT>0 S EVTTYPE=$P(^ORD(100.5,PRTEVT,0),U,2) + E S EVTTYPE=$P(^ORD(100.5,+EVT,0),U,2) + S EVTNAME=$P($G(^ORD(100.5,+EVT,0)),U,1) + S EVTDISP=$P($G(^ORD(100.5,+EVT,0)),U,8) + S EVTDLG=$P($G(^ORD(100.5,+EVT,0)),U,4) + S ORY=EVTTYPE_U_EVT_U_EVTNAME_U_EVTDISP_U_EVTDLG + Q + ; +EVT(ORY,PTEVT) ; Return Event ptr #100.5, given PTEVT ptr #100.2 + Q:'+PTEVT + S ORY=$$EVT^OREVNTX(PTEVT) + Q + ; +EXISTS(ORY,DFN,EVT) ;Returns PtEvtID ptr #100.2 if patient already has delayed orders + I '+EVT S ORY=0 Q + N PTEVT S (PTEVT,ORY)=0 + S PTEVT=$O(^ORE(100.2,"AE",+DFN,+EVT,PTEVT)) + I PTEVT>0 S ORY=PTEVT + Q + ; +TYPEXT(ORY,DFN,EVT) ; does EVT has delayed orders? + ; 1 if Patient DFN has delayed orders for EVT + ; 2 if Parent/Sibling event has delayed orders + ; 0 if No delayed orders for EVT + Q:'+EVT + S ORY=$$EXISTS^OREVNTX(DFN,EVT) + Q + ; +MATCH(ORY,DFN,EVT) ;If Pt's current data match selected event + ;DFN: patient DFN + ;EVT: ptr to #100.5 + S ORY=0 + Q:('+DFN)!('+EVT) + S ORY=$$MATCH^OREVNT(DFN,EVT) + N TS,TSNM + S TS=$S($G(ORTS):+ORTS,1:+$G(^DPT(DFN,.103))) + S TSNM=$P($G(^DIC(45.7,TS,0)),U) + S:ORY ORY=ORY_U_TSNM + Q + ; +NAME(ORY,PTEVT) ; Return Event name from #100.5, given PTEVT ptr #100.2 + I PTEVT'>0 S ORY="" Q + S ORY=$$NAME^OREVNTX(PTEVT) + Q + ; +DIV(ORY,PTEVT) ; Return division for PTEVT ptr #100.2 + Q:'+PTEVT + S ORY=$$DIV^OREVNTX(PTEVT) + Q + ; +DIV1(ORY,EVT) ; Return division for EVT ptr #100.5 + Q:'+EVT + S ORY=+$P($G(^ORD(100.5,+EVT,0)),U,3) S:ORY<1 ORY=+$G(DUZ(2)) + Q + ; +LOC(ORY,PTEVT) ; Return default hospital location ^SC( for PTEVT ptr #100.2 + Q:'+PTEVT + S ORY=$$LOC^OREVNTX(PTEVT) + S ORY=+ORY + Q + ; +LOC1(ORY,EVT) ; Return default hospital location ^SC( for EVT ptr #100.5 + Q:'+EVT + S ORY=+$P($G(^ORD(100.5,+EVT,0)),U,9) S:ORY<1 ORY=+$G(ORL) + Q + ; +CHGEVT(ORY,NEWEVT,ORIDS) ; Change order's event + N ORI + S ORI=0 + F S ORI=$O(ORIDS(ORI)) Q:'+ORI D + . D CHGEVT^OREVNTX(+$G(ORIDS(ORI)),NEWEVT) + Q + ; +EMPTY(ORY,PTEVT) ; Return 1 if PTEVT doesn't have any orders + Q:'+PTEVT + S ORY=$$EMPTY^OREVNTX(PTEVT) + Q + ; +DELPTEVT(ORY,PTEVT) ; Delete Patient Event in #100.2 + Q:'+PTEVT + D CANCEL^OREVNTX(PTEVT) + Q + ; +UPDTOR(ORY,PTIFN,ORIFN,PTEVT) ; If delayed order was DCed, then update the EVENT and "AEVNT" + Q ;Don't ever need to do this! +CURSPE(ORY,PTIFN) ; Return current treating specialty + Q:'PTIFN + N SPCID + I $D(^DPT(PTIFN,.103)) D + . S SPCID=$G(^DPT(PTIFN,.103)) + . S:SPCID ORY=$P($G(^DIC(45.7,SPCID,0)),U)_U_SPCID + Q +DFLTEVT(ORY,PVIFN) ; Return default release event based on provider IFN + N CMEVTLST,IDX + S CMEVTLST="",IDX=0 + D GETLST^OREV3(.CMEVTLST) + F S IDX=$O(CMEVTLST(IDX)) Q:'IDX D + . I $P($G(CMEVTLST(IDX)),U,2) S ORY=$P($G(CMEVTLST(IDX)),U) Q + Q +CMEVTS(ORY,CLOC) ;Return common event list + N IDX,X0,X,LOC + S:CLOC>0 LOC=CLOC + S IDX=0,ORY="" + D GETLST^OREV3(.ORY) + F S IDX=$O(ORY(IDX)) Q:'IDX D + . S X0="" + . S:$L($G(^ORD(100.5,+ORY(IDX),0))) X0=$G(^(0)) + . I '$L($P(X0,U,2)) D + .. S X=$P(X0,U,12) S:X $P(X0,U,2)=$P($G(^ORD(100.5,+X,0)),U,2) + . S:$L(X0) ORY(IDX)=+ORY(IDX)_U_X0 + Q + ; +DELDFLT(ORY,PVIFN) ; Delete default release event + Q:'PVIFN + N ORERR + S ORERR="" + D DEL^XPAR(PVIFN_";VA(200,","OREVNT DEFAULT",1,.ORERR) + Q +WRLSTED(LST,LOC,EVTID) ; Return list of dialogs for writing event delayed orders + ; .Y(n): DlgName^ListBox Text +WRLST1 N ANENT + S LOC=+$G(LOC)_";SC(" I 'LOC S LOC="" + S ANENT="ALL^USR.`"_DUZ_"^"_LOC_$S($G(^VA(200,DUZ,5)):"^SRV.`"_+$G(^(5)),1:"") + N MNU,SEQ,IEN,ITM,TXT,FID,DGRP,X,TYP + S MNU=$$GET^XPAR(ANENT,"ORWDX WRITE ORDERS EVENT LIST",EVTID,"I") Q:'MNU + S SEQ=0 F S SEQ=$O(^ORD(101.41,MNU,10,"B",SEQ)) Q:'SEQ D + . S IEN=0 F S IEN=$O(^ORD(101.41,MNU,10,"B",SEQ,IEN)) Q:'IEN D + . . S X=$G(^ORD(101.41,MNU,10,IEN,0)),ITM=+$P(X,U,2),TXT=$P(X,U,4) + . . S X=$G(^ORD(101.41,ITM,5)),FID=+$P(X,U,5) + . . S X=$G(^ORD(101.41,ITM,0)),TYP=$P(X,U,4),DGRP=+$P(X,U,5) + . . S:'$L(TXT) TXT=$P(X,U,2) + . . I TYP="M" S:'FID FID=1001 + . . S LST(SEQ)=ITM_";"_FID_";"_DGRP_";"_TYP_U_TXT + Q + ; +GETDLG(LST,DLGID) ; Return dialog infomation based on the DLGID + N DIEN,DFID,DTXT,DTYP,DGRP,X0,X5 + S DLGID=+DLGID + Q:'DLGID + S X0=^ORD(101.41,DLGID,0),X5=$G(^(5)) + S DGRP=+$P(X0,U,5),DFID=+$P(X5,U,5),DTXT=$P(X5,U,4),DTYP=$P(X0,U,4) + S:'$L(DTXT) DTXT=$P(X0,U,2) + I $P(X0,U,4)="M" S:'DFID DFID=1001 + S LST=DLGID_";"_DFID_";"_DGRP_";"_DTYP_U_DTXT + Q +DONE(LST,PTEVT) ; Terminate PTEvt + Q:'PTEVT + D DONE^OREVNTX(PTEVT) + D ACTLOG^OREVNTX(PTEVT,"MN") + Q +SETDFLT(ORY,EVT) ;Set personal default event + N ERR,VAL S ERR="" + Q:'$D(^ORD(100.5,EVT,0)) + S VAL=$P(^ORD(100.5,EVT,0),U) + D EN^XPAR(DUZ_";VA(200,","OREVNT DEFAULT",1,VAL,ERR) + S ORY=ERR + Q +CPACT(ORY,EVT) ; Return True/False to display active orders for copy + ; EVT ptr to #100.5 + Q:'EVT + S ORY=0 + Q:'$D(^ORD(100.5,EVT,0)) + S ORY=$P(^ORD(100.5,EVT,0),U,11) + Q +PRMPTID(ORY,PRTNM) ;Return event prompt IEN for OR GTX EVENT + S:$D(^ORD(101.41,"B","OR GTX EVENT")) ORY=$O(^("OR GTX EVENT",0)) + Q +ISDCOD(ORY,ORIFN) ;True: the order need to be filtered out + N PAS,X3,X0,ORGRPLST,THEGRP,IDX,ODGRP + S (ORY,IDX)=0 + Q:'$D(^OR(100,+ORIFN,0)) + S X0=$G(^OR(100,+ORIFN,0)) + S ODGRP=$P(X0,U,11) + D GETLST^XPAR(.ORGRPLST,"ALL","OREVNT EXCLUDE DGRP") + F S IDX=$O(ORGRPLST(IDX)) Q:'IDX!ORY D + . S THEGRP=$P($G(ORGRPLST(IDX)),U,2) + . I $$GRPCHK(THEGRP,ODGRP) S ORY=1 + I ORY Q + S PAS=";1;" + S:$D(^OR(100,+ORIFN,3)) X3=^OR(100,+ORIFN,3) + S:(PAS'[(";"_$P(X3,U,3)_";")) ORY=0 + Q +DEFLTS(ORY,EVTID) ;Return default specialty for EVTID(#100.5) + Q:'+EVTID + N PRTEVT + S PRTEVT=0 + S PRTEVT=$P(^ORD(100.5,+EVTID,0),U,12) + I PRTEVT>0 S EVTID=PRTEVT + S ORY=$$DEFTS^ORCDADT(EVTID) + Q + ; +MULTS(ORY,EVTID) ;Return specialty list for the EVTID(#100.5) + Q:'+EVTID + N I,CNT,X,Y S (I,CNT)=0 + N PRTEVT + S PRTEVT=0 + S PRTEVT=$P(^ORD(100.5,+EVTID,0),U,12) + I PRTEVT>0 S EVTID=PRTEVT + F S I=$O(^ORD(100.5,+$G(EVTID),"TS",I)) Q:I<1 S X=+$G(^(I,0)) D + . S Y=$$GET1^DIQ(45.7,X_",",.01) + . S CNT=CNT+1,ORY(CNT)=X_U_Y + Q + ; +PRTIDS(ORY,IDS) ;Return some prompt ids from #101.41 + ; treating specialty Id^attending provider id + N IDX,ORTS,ORATT + S (ORY,ORTS,ORATT)="" + S IDX=$O(^ORD(101.41,"B","OR GTX TREATING SPECIALTY",0)) + S:$D(^ORD(101.41,IDX,1)) ORTS=$P($G(^ORD(101.41,IDX,1)),U,2,3) + S IDX=$O(^ORD(101.41,"B","OR GTX PROVIDER",0)) + S:$D(^ORD(101.41,IDX,1)) ORATT=$P($G(^ORD(101.41,IDX,1)),U,2,3) + S ORY=ORTS_"~"_ORATT + Q + ; +DFLTDLG(ORY,EVTID) ;Return event default dialog IEN + S ORY=0 + Q:'$D(^ORD(100.5,+EVTID,0)) + S ORY=$P(^ORD(100.5,+EVTID,0),U,4) + Q +AUTHMREL(ORY,USER) ;1: user can manual release delayed orders 0: can't + S ORY=$$CANREL^OREV3 + Q +HAVEPRT(ORY,PTEVT) ;return parent patient event from #100.2 + Q:'+PTEVT + S ORY="" + S:$L($G(^ORE(100.2,PTEVT,1))) ORY=$P(^(1),U,5) + Q +GRPCHK(DG,AGRP) ;If an order's group belong to DG group + N RST + S RST=0 + N ORGRP + D GRP^ORQ1(DG) + S RST=$S($D(ORGRP(AGRP)):1,1:0) + Q RST +ODPTEVID(ORY,ORID) ;Return PtEvtID based on the ORID + Q:'$D(^OR(100,+ORID,0)) + S ORY=$P($G(^OR(100,+ORID,0)),U,17) + Q +COMP(ORY,PTEVT) ;Return 1 or 0 if PTEVT completed or not + Q:'+PTEVT + S ORY=$$COMP^OREVNTX(+PTEVT) + Q +ISHDORD(ORY,ORID) ;Return 1 if it's on-hold med order + Q:'+ORID + Q:'$D(^OR(100,+ORID,0)) + N STS,HDSTS,ODGP,INPT,OUPT,MEDS,IVMD + S HDSTS=$O(^ORD(100.01,"B","HOLD",0)) + S STS=$P($G(^OR(100,+ORID,3)),U,3) + S INPT=$O(^ORD(100.98,"B","UD RX",0)) + S OUPT=$O(^ORD(100.98,"B","O RX",0)) + S MEDS=$O(^ORD(100.98,"B","RX",0)) + S IVMD=$O(^ORD(100.98,"B","IV RX",0)) + S ODGP=$P(^OR(100,+ORID,0),U,11) + I (U_INPT_U_OUPT_U_MEDS_U_IVMD_U[U_ODGP_U),(HDSTS=STS) S ORY=1 + Q +ISPASS(ORY,PTEVTID,EVTTYPE) ;Return 1 if it's a pass event + S ORY=$$EVT^OREVNTX(PTEVTID) + S ORY=$P($G(^ORD(100.5,+ORY,0)),U,7) + I EVTTYPE="T",ORY,ORY<4 S ORY=1 + E S ORY=0 + Q +ISPASS1(ORY,EVTID,EVTTYPE) ;Return 1 if it's a pass event + S ORY=$P($G(^ORD(100.5,+EVTID,0)),U,7) + I EVTTYPE="T",ORY,ORY<4 S ORY=1 + E S ORY=0 + Q +DLGIEN(ORY,DLGNAME) ;Return Order Dialog IEN based on name + Q:'$D(^ORD(101.41,"B",DLGNAME)) + S ORY=$O(^ORD(101.41,"B",DLGNAME,0)) + Q +GETSTS(ORY,ORDID) ;Return Order status + Q:'+ORDID + Q:'$D(^OR(100,+ORDID,0)) + S ORY=$P($G(^OR(100,+ORDID,3)),U,3) + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORIMO.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORIMO.m index 9b4732d4..fcb69d01 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORIMO.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORIMO.m @@ -1,42 +1,40 @@ -ORIMO ;SLC/JDL - Inpatient medication on outpatient. ; 02/12/2007 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**187,190,195,215,243**;Dec 17, 1997;Build 242 -IMOLOC(ORY,ORLOC,ORDFN) ;ORY>=0: LOC is an IMO authorized location - S ORY=-1 - N PACH - S PACH=$$PATCH^XPDUTL("PSJ*5.0*111") - Q:'PACH - I $L($TEXT(SDIMO^SDAMA203)) D - . ;#DBIA 4133 - . S ORY=$$SDIMO^SDAMA203(ORLOC,ORDFN) - . ;if RSA returns an error then check against Clinic Loc. - . I ORY=-3 D - . .I $P($G(^SC(ORLOC,0)),U,3)'="C" Q - . .I $D(^SC("AE",1,ORLOC))=1 S ORY=1 - . K SDIMO(1) - Q - ; -IMOOD(ORY,ORDERID) ;Is it an IMO order? - Q:'$D(^OR(100,+ORDERID,0)) - N PIMO,DGRP,IMOGRP,ISIMO - S (PIMO,DGRP,ISIMO)=0 - I $P($G(^OR(100,+ORDERID,0)),U,18)>0 S PIMO=1 - S DGRP=$P($G(^OR(100,+ORDERID,0)),U,11) - S IMOGRP=$O(^ORD(100.98,"B","CLINIC ORDERS","")) - I DGRP=IMOGRP S ISIMO=1 - I PIMO,ISIMO S ORY=1 - Q - ; -ISCLOC(ORY,ALOC) ;Is it a clinical location - S ORY=0 - Q:'$D(^SC(+ALOC,0)) - I $P(^SC(+ALOC,0),U,3)="C" S ORY=1 - Q -ISIVQO(ORY,DLGID) ;Is it an IV quick order - S ORY=0 - Q:'$D(^ORD(101.41,DLGID,0)) - N IVGRP,DLGTYP,DLGGRP - S IVGRP=$O(^ORD(100.98,"B","IV RX",0)) - S DLGTYP=$P($G(^ORD(101.41,DLGID,0)),U,4) - S DLGGRP=$P($G(^ORD(101.41,DLGID,0)),U,5) - I (DLGTYP="Q"),(DLGGRP=IVGRP) S ORY=1 - Q +ORIMO ;SLC/JDL - Inpatient medication on outpatient. ; 07/07/2005 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**187,190,195,215**;Dec 17, 1997 +IMOLOC(ORY,ORLOC,ORDFN) ;ORY>=0: LOC is an IMO authorized location + S ORY=-1 + N PACH + S PACH=$$PATCH^XPDUTL("PSJ*5.0*111") + Q:'PACH + I $L($TEXT(SDIMO^SDAMA203)) D + . ;I $P($G(^SC(ORLOC,0)),U,3)'="C" Q + . ;I $D(^SC("AE",1,ORLOC))=1 S ORY=1 + . ;#DBIA 4133 + . S ORY=$$SDIMO^SDAMA203(ORLOC,ORDFN) + . K SDIMO(1) + Q + ; +IMOOD(ORY,ORDERID) ;Is it an IMO order? + Q:'$D(^OR(100,+ORDERID,0)) + N PIMO,DGRP,IMOGRP,ISIMO + S (PIMO,DGRP,ISIMO)=0 + I $P($G(^OR(100,+ORDERID,0)),U,18)>0 S PIMO=1 + S DGRP=$P($G(^OR(100,+ORDERID,0)),U,11) + S IMOGRP=$O(^ORD(100.98,"B","CLINIC ORDERS","")) + I DGRP=IMOGRP S ISIMO=1 + I PIMO,ISIMO S ORY=1 + Q + ; +ISCLOC(ORY,ALOC) ;Is it a clinical location + S ORY=0 + Q:'$D(^SC(+ALOC,0)) + I $P(^SC(+ALOC,0),U,3)="C" S ORY=1 + Q +ISIVQO(ORY,DLGID) ;Is it an IV quick order + S ORY=0 + Q:'$D(^ORD(101.41,DLGID,0)) + N IVGRP,DLGTYP,DLGGRP + S IVGRP=$O(^ORD(100.98,"B","IV RX",0)) + S DLGTYP=$P($G(^ORD(101.41,DLGID,0)),U,4) + S DLGGRP=$P($G(^ORD(101.41,DLGID,0)),U,5) + I (DLGTYP="Q"),(DLGGRP=IVGRP) S ORY=1 + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORKCHK.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORKCHK.m index 905331e0..a3ea482d 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORKCHK.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORKCHK.m @@ -1,155 +1,155 @@ -ORKCHK ; slc/CLA - Main routine called by OE/RR to initiate order checks ; 9/21/07 11:54am - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**6,32,94,105,123,232,267,243**;Dec 17, 1997;Build 242 -EN(ORKY,ORKDFN,ORKA,ORKMODE) ;initiate order checking - ;ORKY: array of returned msgs in format: ornum^orderchk ien^clin danger^msg - ;ORKDFN: patient dfn - ;ORKA: array of order information in the format: - ; orderable item ien| - ; display group-filler app| - ; nat'l id^nat'l text^nat'l code sys^local id^local text^local code sys| - ; effective d/t| - ; order number| - ; filler data (LR: specimen ien, PS: meds prev ordered during this session in format med1^med2^...) - ;ORKMODE: mode/event trigger (DISPLAY,SELECT,ACCEPT,SESSION,ALL,NOTIF) - ; PS: meds previously ordered during this session med1^med2^... - ; - N ORKQ,ORKN S ORKQ=0,ORKN=1 - S:+$G(ORKDFN)<1 ORKY(ORKN)="^^^Order Checking Unavailable - invalid patient id",ORKQ=1,ORKN=ORKN+1 - S:'$L($G(ORKMODE)) ORKY(ORKN)="^^^Order Checking Unavailable - invalid mode/event",ORKQ=1,ORKN=ORKN+1 - Q:$G(ORKQ)=1 - Q:+$G(ORKA)<1 - N ORKX,ORKS,DNGR,ORENT,ORKENT,ORKNENT,ORNUM,ORKOFF,ORKTMODE - N ORKADUZ,ORKNDUZ,ORKI,ORKPRIM,ORKNMSG,ORKMSG,ORKLOG,ORKLD,ORKLI,ORKOI - N ORKDG,ORKLPS,ORKPSA,ORKCNT,ORKDGI - ; - ;save array of orders for use in session processing: - M ^TMP("ORKA",$J)=ORKA - ; - ;get patient's location flag (INPATIENT ONLY - outpt locations cannot be - ;reliably determined, and many simultaneous outpt locations can occur): - N DFN,ORKLOC - S DFN=ORKDFN,VA200="" D OERR^VADPT - S ORKLOC=+$G(^DIC(42,+VAIN(4),44)) - K VA200,VAIN - ; - ;get user's service/section flag: - N ORKSRV - S ORKSRV=$$GET1^DIQ(200,DUZ,29,"I") I +ORKSRV>0 S ORKSRV=$P(ORKSRV,U) - ; - ;log order check debug messages (or not) - S ORKLOG=$$GET^XPAR("DIV^SYS^PKG","ORK DEBUG ENABLE/DISABLE",1,"I") - I $G(ORKLOG)="D" K ^XTMP("ORKLOG") S ^XTMP("ORKLOG",0)="" - I +$P($G(^XTMP("ORKLOG",0)),U,3)>5000 K ^XTMP("ORKLOG") - ; - ;if SESSION mode & pharmacy order occurred in session get unsigned med orders - I ORKMODE="SESSION" D - .S ORKDG=$P(ORKA(1),"|",2) - .I $E($G(ORKDG),1,2)="PS" D - ..S ORKDGI=0,ORKDGI=$O(^ORD(100.98,"B","PHARMACY",ORKDGI)) - ..K ^TMP("ORR",$J) - ..D EN^ORQ1(DFN_";DPT(",ORKDGI,11,"","","",0,0) - ..;store unsigned med orders in ^TMP("ORR",$J for processing in ORKPS - ; - ;main processing loop: - S ORKX="" F S ORKX=$O(ORKA(ORKX)) Q:ORKX="" D - .S ORKOI=$P(ORKA(ORKX),"|") - .; - .;log debug msgs if parameter is enabled: - .I $G(ORKLOG)="E" D - ..S ORKLD=$$NOW^XLFDT - ..S ORKLI=0 - ..I +$P($G(^XTMP("ORKLOG",0)),U,3)<1 S $P(^XTMP("ORKLOG",0),U,3)=0 - ..S ORKCNT=$P(^XTMP("ORKLOG",0),U,3)+1 - ..S ^XTMP("ORKLOG",0)=$$FMADD^XLFDT(ORKLD,3,"","","")_U_ORKLD_U_ORKCNT - ..S ^XTMP("ORKLOG",ORKLD,ORKDFN,+$G(ORKOI),ORKMODE,DUZ,ORKLI)=ORKA(ORKX) - .; - .S ORKDG=$P(ORKA(ORKX),"|",2),ORKTMODE="" - .S ORKENT="USR^LOC.`"_+$G(ORKLOC)_"^SRV.`"_+$G(ORKSRV)_"^DIV^SYS^PKG" - .Q:'$L($G(ORKDG)) - .; - .;if pharmacy order and multiple pharmacy orders in session add data node: - .I $E(ORKDG,1,2)="PS",($L($G(ORKPSA))) D - ..S $P(ORKA(ORKX),"|",6)=ORKPSA - .; - .S ORNUM=$P(ORKA(ORKX),"|",5) - .; get correct DUZ for notification processing if in NOTIF mode: - .I ORKMODE="NOTIF" D - ..S:+$G(ORNUM)>0 ORKNDUZ=$$ORDERER^ORQOR2(ORNUM) ;ordering provider - ..S:+$G(ORNUM)<1 ORKNDUZ=$P($$PRIM^ORQPTQ4(ORKDFN),U) ;prim provider - ..I +$G(ORKNDUZ)>0 D - ...S ORKSRV=$$GET1^DIQ(200,ORKNDUZ,29,"I") I +ORKSRV>0 S ORKSRV=$P(ORKSRV,U) - ...S ORKNENT="USR.`"_+ORKNDUZ_"^LOC.`"_+$G(ORKLOC)_"^SRV.`"_+$G(ORKSRV)_"^DIV^SYS^PKG" - ..S:+$G(ORKNDUZ)<1 ORKNENT="LOC.`"_+$G(ORKLOC)_"^DIV^SYS^PKG" - .S ORENT=$S(ORKMODE="NOTIF":ORKNENT,1:ORKENT) - .; - .;If the order is a delayed release order (NOTIF) process all nodes. - .;If it is a renewal, edit or delayed signature order (ALL) process all - .;modes except SESSION which gets processed just before signature: - .I ORKMODE="NOTIF"!(ORKMODE="ALL") S ORKTMODE=ORKMODE D - ..D EN^ORKCHK3(.ORKS,ORKDFN,ORKA(ORKX),ORENT,ORKTMODE) ;DISPLAY - ..D EN^ORKCHK4(.ORKS,ORKDFN,ORKA(ORKX),ORENT,ORKTMODE) ;SELECT - ..D EN^ORKCHK5(.ORKS,ORKDFN,ORKA(ORKX),ORENT,ORKTMODE) ;ACCEPT - ..I ORKMODE="NOTIF" D EN^ORKCHK6(.ORKS,ORKDFN,ORKA(ORKX),ORENT,ORKTMODE) ;SESSION - ..S ORKMODE=ORKTMODE - .; - .;Process regular orders/modes: - .I '$L($G(ORKTMODE)) D - ..I ORKMODE="DISPLAY" D EN^ORKCHK3(.ORKS,ORKDFN,ORKA(ORKX),ORENT,ORKTMODE) - ..I ORKMODE="SELECT" D EN^ORKCHK4(.ORKS,ORKDFN,ORKA(ORKX),ORENT,ORKTMODE) - ..I ORKMODE="ACCEPT" D EN^ORKCHK5(.ORKS,ORKDFN,ORKA(ORKX),ORENT,ORKTMODE) - ..I ORKMODE="SESSION" D EN^ORKCHK6(.ORKS,ORKDFN,ORKA(ORKX),ORENT,ORKTMODE) - ; - ;set messages into sorting array then into ORKY ORKS("ORK",clinical danger level,oi,msg)=ornum^order check ien^clin danger level^message - S ORKX="",ORKI=1 - F S ORKX=$O(ORKS("ORK",ORKX)) Q:ORKX="" D - .S ORKY(ORKI)=$E(ORKS("ORK",ORKX),1,250) - .; - .;log debug msgs if parameter is enabled: - .I $G(ORKLOG)="E" D - ..S ORKLI=$G(ORKLI)+1 - ..S ^XTMP("ORKLOG",$$NOW^XLFDT,ORKDFN,+$G(ORKOI),ORKMODE,DUZ,ORKLI)=ORKY(ORKI) - ..S $P(^XTMP("ORKLOG",0),U,3)=$P($G(^XTMP("ORKLOG",0)),U,3)+1 - .; - .;send moderate and high danger order checks for delayed orders as notifications: - .I ORKMODE="NOTIF" S DNGR=$P(ORKY(ORKI),U,3) I $G(DNGR)<3 D - ..S ORKADUZ="",ORNUM=$P(ORKY(ORKI),U) - ..S:+$G(ORKNDUZ)>0 ORKADUZ(ORKNDUZ)="" - ..S ORKNMSG="Order check: "_$P(ORKY(ORKI),U,4) - ..D EN^ORB3(54,ORKDFN,$G(ORNUM),.ORKADUZ,ORKNMSG,"") - .S ORKI=ORKI+1 - ; - K ^TMP("ORKA",$J),^TMP("ORR",$J) - I $G(ORKLOG)="E" D - .S ORKLI=$G(ORKLI)+1 - .S ^XTMP("ORKLOG",$$NOW^XLFDT,ORKDFN,+$G(ORKOI),ORKMODE,DUZ,ORKLI)="LEAVING ORDER CHECKING" - .S $P(^XTMP("ORKLOG",0),U,3)=$P($G(^XTMP("ORKLOG",0)),U,3)+1 - D CHKRMT - Q - ; -OI2DD(ORPSA,OROI,ORPSPKG) ;rtn dispense drugs for a PS OI - N PSOI - Q:'$D(^ORD(101.43,OROI,0)) - S PSOI=$P($P(^ORD(101.43,OROI,0),U,2),";") - Q:+$G(PSOI)<1 - D DRG^PSSUTIL1(.ORPSA,PSOI,ORPSPKG) - Q -CHKRMT ; - N I,ORQFLAG - S ORQFLAG=1 - S I=0 F S I=$O(ORKA(I)) Q:'I I $E($P(ORKA(I),"|",2),1,2)="PS"!($E($P(ORKA(I),"|",2),1,2)="RA") S ORQFLAG=0 - Q:$G(ORQFLAG) - Q:'$$HAVEHDR^ORRDI1 - Q:$$LDPTTVAL^ORRDI2($G(DFN)) - Q:$P($G(^XTMP("ORRDI","PSOO",ORKDFN,0)),U,3)'<0&($P($G(^XTMP("ORRDI","ART",ORKDFN,0)),U,3)'<0) - I $G(ORKMODE)="ACCEPT" D - . N IFN - . S IFN=$O(ORKY(""),-1)+1 - . S ORKY(IFN)="^99^2^Remote Order Checking not available - checks done on local data only" - . K ^TMP($J,"ORRDI") S ^TMP($J,"ORRDI",ORKDFN)=1 - I $G(ORKMODE)="SESSION" D - . N I,IFN,ORARR - . S IFN=$O(ORKY(""),-1) - . S I=0 F S I=$O(ORKY(I)) Q:'I S ORARR(+ORKY(I))="" - . S I=0 F S I=$O(ORARR(I)) Q:'I S IFN=IFN+1,ORKY(IFN)=I_"^99^2^Remote Order Checking not available - checks done on local data only" - . K ^TMP($J,"ORRDI") S ^TMP($J,"ORRDI",ORKDFN)=1 - Q +ORKCHK ; slc/CLA - Main routine called by OE/RR to initiate order checks ; 1/16/07 6:28am + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**6,32,94,105,123,232,267**;Dec 17, 1997;Build 6 +EN(ORKY,ORKDFN,ORKA,ORKMODE) ;initiate order checking + ;ORKY: array of returned msgs in format: ornum^orderchk ien^clin danger^msg + ;ORKDFN: patient dfn + ;ORKA: array of order information in the format: + ; orderable item ien| + ; display group-filler app| + ; nat'l id^nat'l text^nat'l code sys^local id^local text^local code sys| + ; effective d/t| + ; order number| + ; filler data (LR: specimen ien, PS: meds prev ordered during this session in format med1^med2^...) + ;ORKMODE: mode/event trigger (DISPLAY,SELECT,ACCEPT,SESSION,ALL,NOTIF) + ; PS: meds previously ordered during this session med1^med2^... + ; + N ORKQ,ORKN S ORKQ=0,ORKN=1 + S:+$G(ORKDFN)<1 ORKY(ORKN)="^^^Order Checking Unavailable - invalid patient id",ORKQ=1,ORKN=ORKN+1 + S:'$L($G(ORKMODE)) ORKY(ORKN)="^^^Order Checking Unavailable - invalid mode/event",ORKQ=1,ORKN=ORKN+1 + Q:$G(ORKQ)=1 + Q:+$G(ORKA)<1 + N ORKX,ORKS,DNGR,ORENT,ORKENT,ORKNENT,ORNUM,ORKOFF,ORKTMODE + N ORKADUZ,ORKNDUZ,ORKI,ORKPRIM,ORKNMSG,ORKMSG,ORKLOG,ORKLD,ORKLI,ORKOI + N ORKDG,ORKLPS,ORKPSA,ORKCNT,ORKDGI + ; + ;save array of orders for use in session processing: + M ^TMP("ORKA",$J)=ORKA + ; + ;get patient's location flag (INPATIENT ONLY - outpt locations cannot be + ;reliably determined, and many simultaneous outpt locations can occur): + N DFN,ORKLOC + S DFN=ORKDFN,VA200="" D OERR^VADPT + S ORKLOC=+$G(^DIC(42,+VAIN(4),44)) + K VA200,VAIN + ; + ;get user's service/section flag: + N ORKSRV + S ORKSRV=$$GET1^DIQ(200,DUZ,29,"I") I +ORKSRV>0 S ORKSRV=$P(ORKSRV,U) + ; + ;log order check debug messages (or not) + S ORKLOG=$$GET^XPAR("DIV^SYS^PKG","ORK DEBUG ENABLE/DISABLE",1,"I") + I $G(ORKLOG)="D" K ^XTMP("ORKLOG") S ^XTMP("ORKLOG",0)="" + I +$P($G(^XTMP("ORKLOG",0)),U,3)>5000 K ^XTMP("ORKLOG") + ; + ;if SESSION mode & pharmacy order occurred in session get unsigned med orders + I ORKMODE="SESSION" D + .S ORKDG=$P(ORKA(1),"|",2) + .I $E($G(ORKDG),1,2)="PS" D + ..S ORKDGI=0,ORKDGI=$O(^ORD(100.98,"B","PHARMACY",ORKDGI)) + ..K ^TMP("ORR",$J) + ..D EN^ORQ1(DFN_";DPT(",ORKDGI,11,"","","",0,0) + ..;store unsigned med orders in ^TMP("ORR",$J for processing in ORKPS + ; + ;main processing loop: + S ORKX="" F S ORKX=$O(ORKA(ORKX)) Q:ORKX="" D + .S ORKOI=$P(ORKA(ORKX),"|") + .; + .;log debug msgs if parameter is enabled: + .I $G(ORKLOG)="E" D + ..S ORKLD=$$NOW^XLFDT + ..S ORKLI=0 + ..I +$P($G(^XTMP("ORKLOG",0)),U,3)<1 S $P(^XTMP("ORKLOG",0),U,3)=0 + ..S ORKCNT=$P(^XTMP("ORKLOG",0),U,3)+1 + ..S ^XTMP("ORKLOG",0)=$$FMADD^XLFDT(ORKLD,3,"","","")_U_ORKLD_U_ORKCNT + ..S ^XTMP("ORKLOG",ORKLD,ORKDFN,+$G(ORKOI),ORKMODE,DUZ,ORKLI)=ORKA(ORKX) + .; + .S ORKDG=$P(ORKA(ORKX),"|",2),ORKTMODE="" + .S ORKENT="USR^LOC.`"_+$G(ORKLOC)_"^SRV.`"_+$G(ORKSRV)_"^DIV^SYS^PKG" + .Q:'$L($G(ORKDG)) + .; + .;if pharmacy order and multiple pharmacy orders in session add data node: + .I $E(ORKDG,1,2)="PS",($L($G(ORKPSA))) D + ..S $P(ORKA(ORKX),"|",6)=ORKPSA + .; + .S ORNUM=$P(ORKA(ORKX),"|",5) + .; get correct DUZ for notification processing if in NOTIF mode: + .I ORKMODE="NOTIF" D + ..S:+$G(ORNUM)>0 ORKNDUZ=$$ORDERER^ORQOR2(ORNUM) ;ordering provider + ..S:+$G(ORNUM)<1 ORKNDUZ=$P($$PRIM^ORQPTQ4(ORKDFN),U) ;prim provider + ..I +$G(ORKNDUZ)>0 D + ...S ORKSRV=$$GET1^DIQ(200,ORKNDUZ,29,"I") I +ORKSRV>0 S ORKSRV=$P(ORKSRV,U) + ...S ORKNENT="USR.`"_+ORKNDUZ_"^LOC.`"_+$G(ORKLOC)_"^SRV.`"_+$G(ORKSRV)_"^DIV^SYS^PKG" + ..S:+$G(ORKNDUZ)<1 ORKNENT="LOC.`"_+$G(ORKLOC)_"^DIV^SYS^PKG" + .S ORENT=$S(ORKMODE="NOTIF":ORKNENT,1:ORKENT) + .; + .;If the order is a delayed release order (NOTIF) process all nodes. + .;If it is a renewal, edit or delayed signature order (ALL) process all + .;modes except SESSION which gets processed just before signature: + .I ORKMODE="NOTIF"!(ORKMODE="ALL") S ORKTMODE=ORKMODE D + ..D EN^ORKCHK3(.ORKS,ORKDFN,ORKA(ORKX),ORENT,ORKTMODE) ;DISPLAY + ..D EN^ORKCHK4(.ORKS,ORKDFN,ORKA(ORKX),ORENT,ORKTMODE) ;SELECT + ..D EN^ORKCHK5(.ORKS,ORKDFN,ORKA(ORKX),ORENT,ORKTMODE) ;ACCEPT + ..I ORKMODE="NOTIF" D EN^ORKCHK6(.ORKS,ORKDFN,ORKA(ORKX),ORENT,ORKTMODE) ;SESSION + ..S ORKMODE=ORKTMODE + .; + .;Process regular orders/modes: + .I '$L($G(ORKTMODE)) D + ..I ORKMODE="DISPLAY" D EN^ORKCHK3(.ORKS,ORKDFN,ORKA(ORKX),ORENT,ORKTMODE) + ..I ORKMODE="SELECT" D EN^ORKCHK4(.ORKS,ORKDFN,ORKA(ORKX),ORENT,ORKTMODE) + ..I ORKMODE="ACCEPT" D EN^ORKCHK5(.ORKS,ORKDFN,ORKA(ORKX),ORENT,ORKTMODE) + ..I ORKMODE="SESSION" D EN^ORKCHK6(.ORKS,ORKDFN,ORKA(ORKX),ORENT,ORKTMODE) + ; + ;set messages into sorting array then into ORKY ORKS("ORK",clinical danger level,oi,msg)=ornum^order check ien^clin danger level^message + S ORKX="",ORKI=1 + F S ORKX=$O(ORKS("ORK",ORKX)) Q:ORKX="" D + .S ORKY(ORKI)=$E(ORKS("ORK",ORKX),1,250) + .; + .;log debug msgs if parameter is enabled: + .I $G(ORKLOG)="E" D + ..S ORKLI=$G(ORKLI)+1 + ..S ^XTMP("ORKLOG",$$NOW^XLFDT,ORKDFN,+$G(ORKOI),ORKMODE,DUZ,ORKLI)=ORKY(ORKI) + ..S $P(^XTMP("ORKLOG",0),U,3)=$P($G(^XTMP("ORKLOG",0)),U,3)+1 + .; + .;send moderate and high danger order checks for delayed orders as notifications: + .I ORKMODE="NOTIF" S DNGR=$P(ORKY(ORKI),U,3) I $G(DNGR)<3 D + ..S ORKADUZ="",ORNUM=$P(ORKY(ORKI),U) + ..S:+$G(ORKNDUZ)>0 ORKADUZ(ORKNDUZ)="" + ..S ORKNMSG="Order check: "_$P(ORKY(ORKI),U,4) + ..D EN^ORB3(54,ORKDFN,$G(ORNUM),.ORKADUZ,ORKNMSG,"") + .S ORKI=ORKI+1 + ; + K ^TMP("ORKA",$J),^TMP("ORR",$J) + I $G(ORKLOG)="E" D + .S ORKLI=$G(ORKLI)+1 + .S ^XTMP("ORKLOG",$$NOW^XLFDT,ORKDFN,+$G(ORKOI),ORKMODE,DUZ,ORKLI)="LEAVING ORDER CHECKING" + .S $P(^XTMP("ORKLOG",0),U,3)=$P($G(^XTMP("ORKLOG",0)),U,3)+1 + D CHKRMT + Q + ; +OI2DD(ORPSA,OROI,ORPSPKG) ;rtn dispense drugs for a PS OI + N PSOI + Q:'$D(^ORD(101.43,OROI,0)) + S PSOI=$P($P(^ORD(101.43,OROI,0),U,2),";") + Q:+$G(PSOI)<1 + D DRG^PSSUTIL1(.ORPSA,PSOI,ORPSPKG) + Q +CHKRMT ; + N I,ORQFLAG + S ORQFLAG=1 + S I=0 F S I=$O(ORKA(I)) Q:'I I $E($P(ORKA(I),"|",2),1,2)="PS"!($E($P(ORKA(I),"|",2),1,2)="RA") S ORQFLAG=0 + Q:$G(ORQFLAG) + Q:'$$HAVEHDR^ORRDI1 + Q:$$LDPTTVAL^ORRDI2($G(DFN)) + Q:$P($G(^XTMP("ORRDI","PSOO",ORKDFN,0)),U,3)'<0&($P($G(^XTMP("ORRDI","ART",ORKDFN,0)),U,3)'<0) + I $G(ORKMODE)="ACCEPT" D + . N IFN + . S IFN=$O(ORKY(""),-1)+1 + . S ORKY(IFN)="^99^2^Order check performed on local data only" + . K ^TMP($J,"ORRDI") S ^TMP($J,"ORRDI",ORKDFN)=1 + I $G(ORKMODE)="SESSION" D + . N I,IFN,ORARR + . S IFN=$O(ORKY(""),-1) + . S I=0 F S I=$O(ORKY(I)) Q:'I S ORARR(+ORKY(I))="" + . S I=0 F S I=$O(ORARR(I)) Q:'I S IFN=IFN+1,ORKY(IFN)=I_"^99^2^Order check performed on local data only." + . K ^TMP($J,"ORRDI") S ^TMP($J,"ORRDI",ORKDFN)=1 + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORKLR.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORKLR.m index 706c1958..f352022b 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORKLR.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORKLR.m @@ -1,136 +1,140 @@ -ORKLR ; slc/CLA - Order checking support procedure for lab orders ;7/23/96 14:31 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**6,32,51,92,105,243**;Dec 17, 1997;Build 242 - Q -DUP(ORKLR,OI,ORDFN,NEWORDT,SPECIMEN) ; return duplicate lab order info - N ORL,DDT,ODT,ORN,ORNC,LRID,DGIEN,ORPANEL - ;get lab id from orderable item (OI): - S LRID=$P(^ORD(101.43,OI,0),U,2) S:$L($G(LRID)) ORL(LRID_";"_SPECIMEN)="" - ;expand into child-level lab identifiers if children exist for this OI: - ;if children found, set panel flag to '1': - S LRID="" F S LRID=$O(^ORD(101.43,OI,10,"AID",LRID)) Q:LRID="" S ORL(LRID_";"_SPECIMEN)="",ORPANEL=1 - ;get duplicate date range-beginning date/time for this OI: - S DDT=$P($$DUPRANGE^ORQOR2(OI,"LR",NEWORDT,ORDFN),U) - Q:DDT=0 ;if dup range for this OI = zero, don't process dup order oc - ; - ;get all lab orders since dup beg d/t: - S DGIEN=0,DGIEN=$O(^ORD(100.98,"B","LAB",DGIEN)) - K ^TMP("ORR",$J) - D EN^ORQ1(ORDFN_";DPT(",DGIEN,1,"",DDT,NEWORDT,1,0) - N J,HOR,SEQ,X S J=1,HOR=0,SEQ=0 - S HOR=$O(^TMP("ORR",$J,HOR)) Q:+HOR<1 - F S SEQ=$O(^TMP("ORR",$J,HOR,SEQ)) Q:+SEQ<1 D - .S X=^TMP("ORR",$J,HOR,SEQ),ORN=+$P(X,U),ODT=$P(X,U,4) - .Q:+$G(ORN)=+$G(ORIFN) ;quit current order # = dup order # - .;break into child orders if they exist: - .I $D(^OR(100,ORN,2,0)) D ;child orders exist - ..S ORNC=0 F S ORNC=$O(^OR(100,ORN,2,ORNC)) Q:ORNC="" D - ...Q:+$G(ORNC)=+$G(ORIFN) ;quit current order # = dup order # - ...D DUP2(.ORKLR,ORNC,ODT,.ORL,$G(ORPANEL)) - .I '$D(^OR(100,ORN,2,0)) D DUP2(.ORKLR,ORN,ODT,.ORL,$G(ORPANEL)) - K ^TMP("ORR",$J) - Q -DUP2(ORKLR,ORN,ODT,ORL,ORPANEL) ;second part of dup lab order check - N ORS,ORST,ORSI,ORSP,OROI,LRID,LRIDX,LRIDXC,EXDT,INVDT,RCNT,ORY,ORX,ORQ - S ORS=$$STATUS^ORQOR2(ORN),ORSI=$P(ORS,U),ORST=$P(ORS,U,2) - ;quit if order status is canceled/discontinued/expired/lapsed/changed/delayed: - I (ORSI=13)!(ORSI=1)!(ORSI=7)!(ORSI=14)!(ORSI=12)!(ORSI=10) Q - ; - ;get specimen for this order: - S ORSP=$$VALUE^ORCSAVE2(ORN,"SPECIMEN") - Q:'$L($G(ORSP)) ;quit if no specimen found - ;get orderable item for this order: - S OROI=$$OI^ORQOR2(ORN) - Q:'$L($G(OROI)) ;quit if no orderable item found - ;get lab id and check against ordered array ORL - S:$L($G(^ORD(101.43,OROI,0))) LRIDX=$P(^ORD(101.43,OROI,0),U,2)_";"_ORSP I $L($G(LRIDX)) D - .S LRID="" F S LRID=$O(ORL(LRID)) Q:LRID="" I LRID=LRIDX D ;dup! - ..; - ..;quit if order results entered in lab as "cancelled": - ..D ORDER^ORQQLR(.ORY,ORDFN,ORN) - ..S ORX=0 F S ORX=$O(ORY(ORX)) Q:+$G(ORX)<1 D - ...I ($P(LRID,";")=$P(ORY(ORX),U)),($P(ORY(ORX),U,3)["canc") S ORQ=1 - ..Q:+$G(ORQ)=1 ;quit if lab test cancelled in lab - ..; - ..S EXDT=$$FMTE^XLFDT(ODT,"2P"),INVDT=9999999-ODT - ..;get most recent lab results: - ..S RCNT=$$LOCLFORM^ORQQLR1(ORDFN,+LRID,ORSP) - ..; - ..S ORKLR(INVDT)=ORN_U_$P($$TEXT^ORKOR(ORN,60),U,2)_" "_$G(EXDT)_" ["_$S(ORST="COMPLETE":"COLLECTED",ORST="PENDING":"UNCOLLECTED",1:ORST)_"]" - ..I +RCNT>0 S ORKLR(INVDT)=ORKLR(INVDT)_" *Most recent result: "_$P(RCNT,U,2)_"*" - ;get children lab ids and check against ordered array ORL - S LRIDX="" F S LRIDX=$O(^ORD(101.43,OROI,10,"AID",LRIDX)) Q:LRIDX="" D - .S LRIDXC=LRIDX_";"_ORSP - .S LRID="" F S LRID=$O(ORL(LRID)) Q:LRID="" I LRID=LRIDXC D ;dup! - ..; - ..D ORDER^ORQQLR(.ORY,ORDFN,ORN) - ..S ORX=0 F S ORX=$O(ORY(ORX)) Q:+$G(ORX)<1 D - ...I ($P(LRID,";")=$P(ORY(ORX),U)),($P(ORY(ORX),U,3)["canc") S ORQ=1 - ..Q:+$G(ORQ)=1 ;quit if lab test cancelled in lab - ..; - ..S EXDT=$$FMTE^XLFDT(ODT,"2P"),INVDT=9999999-ODT - ..;get most recent lab results: - ..S RCNT=$S($G(ORPANEL)=1:"",1:$$LOCLFORM^ORQQLR1(ORDFN,+LRID,ORSP)) - ..; - ..S ORKLR(INVDT)=ORN_U_$P($$TEXT^ORKOR(ORN,60),U,2)_" "_$G(EXDT)_" ["_$S(ORST="COMPLETE":"COLLECTED",ORST="PENDING":"UNCOLLECTED",1:ORST)_"]" - ..I +RCNT>0 S ORKLR(INVDT)=ORKLR(INVDT)_" *Most recent result: "_$P(RCNT,U,2)_"*" - Q -RECNTWBC(ORDFN,ORDAYS) ;extrinsic function to return most recent WBC within in format: - ;test id^result units flag ref range collection d/t - N BDT,CDT,ORY,ORX,ORZ,X,TEST,ORI,ORJ,WBCRSLT,LABFILE,SPECFILE - Q:'$L($G(ORDFN)) "0^" - D NOW^%DTC - I $L($G(ORDAYS)) S BDT=$$FMADD^XLFDT(%,"-"_ORDAYS,"","","") - K % - S:'$L($G(BDT)) BDT=1 ;if no ORDAYS, set BDT to '1' to search all days - S LABFILE=$$TERMLKUP^ORB31(.ORY,"WBC") - Q:'$D(ORY) "0^" ;quit if no link between WBC and local lab test - Q:$G(LABFILE)'=60 "0^" - S SPECFILE=$$TERMLKUP^ORB31(.ORX,"BLOOD SPECIMEN") - Q:'$D(ORX) "0^" ;quit if no link between BLOOD SPECIMEN and local spec - Q:$G(SPECFILE)'=61 "0^" - F ORI=1:1:ORY I +$G(WBCRSLT)<1 D - .S TEST=$P(ORY(ORI),U) - .Q:+$G(TEST)<1 - .F ORJ=1:1:ORX I +$G(WBCRSLT)<1 D - ..S SPECIMEN=$P(ORX(ORJ),U) - ..Q:+$G(SPECIMEN)<1 - ..S ORZ=$$LOCL^ORQQLR1(ORDFN,TEST,SPECIMEN) - ..Q:'$L($G(ORZ)) - ..S CDT=$P(ORZ,U,7) - ..I CDT'0 S ORKLR(INVDT)=ORKLR(INVDT)_" *Most recent result: "_$P(RCNT,U,2)_"*" + ;get children lab ids and check against ordered array ORL + S LRIDX="" F S LRIDX=$O(^ORD(101.43,OROI,10,"AID",LRIDX)) Q:LRIDX="" D + .S LRIDXC=LRIDX_";"_ORSP + .S LRID="" F S LRID=$O(ORL(LRID)) Q:LRID="" I LRID=LRIDXC D ;dup! + ..; + ..D ORDER^ORQQLR(.ORY,ORDFN,ORN) + ..S ORX=0 F S ORX=$O(ORY(ORX)) Q:+$G(ORX)<1 D + ...I ($P(LRID,";")=$P(ORY(ORX),U)),($P(ORY(ORX),U,3)["canc") S ORQ=1 + ..Q:+$G(ORQ)=1 ;quit if lab test cancelled in lab + ..; + ..S EXDT=$$FMTE^XLFDT(ODT,"2P"),INVDT=9999999-ODT + ..;get most recent lab results: + ..S RCNT=$S($G(ORPANEL)=1:"",1:$$LOCLFORM^ORQQLR1(ORDFN,+LRID,ORSP)) + ..; + ..S ORKLR(INVDT)=ORN_U_$P($$TEXT^ORKOR(ORN,60),U,2)_" "_$G(EXDT)_" ["_$S(ORST="COMPLETE":"COLLECTED",ORST="PENDING":"UNCOLLECTED",1:ORST)_"]" + ..I +RCNT>0 S ORKLR(INVDT)=ORKLR(INVDT)_" *Most recent result: "_$P(RCNT,U,2)_"*" + Q +RECNTWBC(ORDFN,ORDAYS) ;extrinsic function to return most recent WBC within in format: + ;test id^result units flag ref range collection d/t + N BDT,CDT,ORY,ORX,ORZ,X,TEST,ORI,ORJ,WBCRSLT,LABFILE,SPECFILE + Q:'$L($G(ORDFN)) "0^" + D NOW^%DTC + I $L($G(ORDAYS)) S BDT=$$FMADD^XLFDT(%,"-"_ORDAYS,"","","") + K % + S:'$L($G(BDT)) BDT=1 ;if no ORDAYS, set BDT to '1' to search all days + S LABFILE=$$TERMLKUP^ORB31(.ORY,"WBC") + Q:'$D(ORY) "0^" ;quit if no link between WBC and local lab test + Q:$G(LABFILE)'=60 "0^" + S SPECFILE=$$TERMLKUP^ORB31(.ORX,"BLOOD SPECIMEN") + Q:'$D(ORX) "0^" ;quit if no link between BLOOD SPECIMEN and local spec + Q:$G(SPECFILE)'=61 "0^" + F ORI=1:1:ORY I +$G(WBCRSLT)<1 D + .S TEST=$P(ORY(ORI),U) + .Q:+$G(TEST)<1 + .F ORJ=1:1:ORX I +$G(WBCRSLT)<1 D + ..S SPECIMEN=$P(ORX(ORJ),U) + ..Q:+$G(SPECIMEN)<1 + ..S ORZ=$$LOCL^ORQQLR1(ORDFN,TEST,SPECIMEN) + ..Q:'$L($G(ORZ)) + ..S CDT=$P(ORZ,U,7) + ..I CDT'BDT) S WBCF=1 + S:$G(WBCF)'=1 WBCF=0 + ; + S ANCRSLT=$$LOCL^ORQQLR1(ORDFN,ANC,ANCSPEC) + S ANCCDT=$P(ANCRSLT,U,7) + S ANC=$P(ANCRSLT,U,3) + I $L(ANC),(ANCCDT=WBCCDT) D ;ANC from same collection d/t as WBC + .S ANC=(WBC*ANC)/100 + .S ANCRSLT="ANC: "_ANC_" ["_$$FMTE^XLFDT(ANCCDT,"""2P""")_"]" + E S ANCRSLT="ANC: no results found" + I $L(ANC),(ANCCDT>BDT) S ANCF=1 + S:$G(ANCF)'=1 ANCF=0 + ; + K LAB + Q "1^"_WBCF_";"_WBC_"^"_ANCF_";"_ANC_"^"_WBCRSLT_" "_ANCRSLT diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORLP.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORLP.m index 435ec996..2a405a31 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORLP.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORLP.m @@ -1,257 +1,256 @@ -ORLP ; SLC/CLA - Manager for Team List options ; 5/30/08 6:28am - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**47,90,98,243**;Dec 17, 1997;Build 242 - ; -CLEAR ; From TM, MERG^ORLP1, END^ORLP0. - K ^XUTL("OR",$J,"ORLP"),^("ORV"),^("ORU"),^("ORW") S ORCNT=0 - Q - ; -TM ; From option ORLP TEAM ADD - create/add a team list. - N ORLTYP - D CLEAR - W @IOF,!,"A team list is a list containing patients related to several providers.",!,"These providers are the list's users. You may now create a new team list" - W !,"or add autolinks, users and/or patients to an existing team list. Autolinks",!,"automatically add or remove patients with ADT movements. Users on the list" - W !,"may receive notifications regarding patients on the same list. Please prefix",!,"your list name with 'TEAM' or 'SERVICE' (e.g. TEAM7B, SERVICECARDIOLOGY.)",! - D ASKLIST,END - Q - ; -ASKLIST ; Ask for team list. - ; NOTE: For new entries, TYPE field is required and trigger - ; stuffs CREATOR field with DUZ of current user. - ; -AL N DLAYGO,DIC,DIE,DIK,DR,ORFLAG,ORLTNAM,OROWNER,ORROOT,ORDA,ORYY - N DIR S DIR(0)="FAO^3:30",DIR("A")="Enter team list name: " - D ^DIR - I '$D(X)!$D(DIRUT) K DIR,DIRUT Q - S ORLTNAM=$$CHKNAM(Y) ; Check for duplication. - K DIR - N DIC S X=$G(X),(ORROOT,DIC)="^OR(100.21,",DLAYGO=100.21,DIC(0)="LEFQZ" D ^DIC - I '$D(X)!(+Y<0)!$D(DIRUT) K DIRUT Q ; User aborted or problem. - I +Y,'+$G(^OR(100.21,+Y,11)) S ^OR(100.21,+Y,11)="0^" - ; Check for "Personal" lists (and not a new entry): - I ORLTNAM>0,(+Y>0),$P($G(^OR(100.21,+Y,0)),U,2)="P" W !!," Personal lists cannot be edited here.",! G AL - S (ORYY,TEAM)=Y,ORDA=+Y,TEAM(0)=Y(0),^TMP("ORLP",$J,"TLIST")=+Y K DIC - ; Check for entry of team type (new team entry): - I $P(TEAM,U,3) D Q - .I $P(TEAM(0),U,2)="" D - ..SET Y=TEAM,Y(0)=TEAM(0) ; Reassign in case DIE previously called. - ..N DIE S DIE=ORROOT,DA=+Y,DR="1 Enter type: ~R" D ^DIE I $O(Y(0)) S DIK=DIE D ^DIK Q - .S (ORLTYP,OROWNER)="" - .S ORLTYP=$P(^OR(100.21,+TEAM,0),U,2) Q:'$L(ORLTYP) - .; Check for "P" type, ask for user/owner input: - .I ORLTYP="P" D OWNER^ORLP1 ; Sets OROWNER variable. - .I (ORLTYP="P")&(OROWNER="") S DIK=ORROOT,DA=ORDA D ^DIK Q - .; - .; Allow further editing of autolink type teams: - .I ORLTYP["A" S:'$D(^OR(100.21,+TEAM,2,0)) ^(0)="^100.213AVI^^" D Q - .. D ASKLINK,ASKUSER,ASKDEV,ASKSUB - .; - .; Proceed with editing for "TM" type teams: - .D ASKPT^ORLP00(+TEAM),ASKUSER,ASKDEV - ; - ; For existing teams, display team type: - W !," Type: "_$S($P(Y(0),U,2)="TM":"Manual Team List",$P(Y(0),U,2)="TA":"Autolinked Team List",$P(Y(0),U,2)="MRAL":"Manual Removal Autolinked Team List",1:"(Unknown)") - ; - ; Lock before allowing editing: - I $O(^OR(100.21,+TEAM,10,0)) L +^OR(100.21,+TEAM):3 I '$T W !?5," Another user is editing this entry." Q - ; - ; Allow applicable editing for all types but "TM" teams: - I $P(TEAM(0),U,2)'="TM" D - . D ASKLINK,ASKUSER,ASKDEV - . ; - . ; Editing of "subscription" attribute for "TA" and "MRAL" teams: - . I $P(TEAM(0),U,2)["A" D - . . D ASKSUB - ; - ; Proceed with editing for "TM" type teams: - I $P(TEAM(0),U,2)="TM" D ASKPT^ORLP00(+TEAM),ASKUSER,ASKDEV - Q - ; -ASKLINK ; Ask for autolinks. - N DIC,DA,DLAYGO,Y,DUOUT,LVP,LVPT,LNAME - W ! - F K DIC,DA,DUOUT D I LVP<1 Q - .S DLAYGO=100.21,DA(1)=+TEAM,DIC="^OR(100.21,"_DA(1)_",2,",DIC(0)="AELMQZ",DIC("A")=" Enter team autolink: " - .D ^DIC S LVP=Y I Y<1 Q - .I $P($G(Y),U,3)=1 D - ..S LNAME=Y(0,0) - ..I LVP["VA(200" F D Q:'$D(Y) - ...S DA(1)=+TEAM,DIE="^OR(100.21,"_DA(1)_",2,",DA(1)=+TEAM,DA=+LVP,DR="1R" D ^DIE I $D(Y) W !," This field is required in order for Provider autolinks to work correctly.",!," Please answer the question." - ..S LVPT=$P($G(^OR(100.21,+TEAM,2,+LVP,0)),U,2) - ..; For clinics, take a fork in the road: - ..I $P($P(LVP,U,2),";",2)="SC(" D BYCL(LVP) Q - ..; For autolinks besides clinics, truck on: - ..D ADDLPTS - Q - ; -ADDLPTS ; Add patients linked to autolink. - W ! - W !," [ADT movements linked to " - W !," ",LNAME - W !," will now automatically add patients to this list.]" - S LINK=$P(LVP,U,2),FILE="^"_$P(LINK,";",2),X="",CNT=0 - W !!," Adding patients linked to ",LNAME,"..." - W ! - I FILE="^DIC(42," D LOOPTS("CN",LNAME) Q - I FILE="^DG(405.4," D LOOPTS("RM",LNAME) Q - I FILE="^VA(200," D Q - . ; Variable LVPT determines if provider pointer is for: - . ; B - Both Primary and Attending - . ; A - Attending - . ; P - Primary - . I LVPT["B" D LOOPTS("APR",+LINK) N CNTAPR S CNTAPR=CNT,CNT=0 D LOOPTS("AAP",+LINK) Q - . I LVPT["P" D LOOPTS("APR",+LINK) Q - . I LVPT["A" D LOOPTS("AAP",+LINK) - I FILE="^DIC(45.7," D LOOPTS("ATR",+LINK) Q - Q - ; -BYCL(CLINIC) ; SLC/PKS - 6/99 - Return list of clinic patients by enrollment. - ; - ; Called by ASKLINK. - ; - ; Variables used: - ; - ; CLINIC = Clinic to search. - ; ORLIST = Array, returned by call to PTCL^SCAPMC. - ; ORERR = Array for errors, returned by call to PTCL^SCAPMC. - ; ORRET = Flag for problem with PTCL^SCAPMC call. - ; RESULT = Holds result of PTCL^SCAPMC call (1=OK, 0=error). - ; RCD = Holder for each record in ^TMP of PTCL^SCAPMC. - ; DFN = Patient IEN. - ; ALCNT = Count of autolink patients added. - ; DUPCNT = Count of duplicate patients already on list. - ; X = Temp value holder variable. - ; - N DIC,DA,DO,DD,ORLIST,ORERR,RESULT,RCD,DFN,ALCNT,DUPCNT,X,ORRET - ; - ; Assign clinic variable: - S CLINIC=$P(CLINIC,"^",2) - S CLINIC=$P(CLINIC,";") - ; - ; Keep user informed: - W ! - W !," [Patient enrollments linked to " - W !," ",LNAME - W !," will now automatically add patients to this list.]" - W ! - W !," Adding patients enrolled in ",LNAME,"..." - W ! - ; - ; Process the Autolink entries: - K ^TMP("SC TMP LIST") ; Clean up potential leftover data. - S ORRET=1 - S RESULT=$$PTCL^SCAPMC(CLINIC,,.ORLIST,.ORERR) - I $L($G(RESULT)) D ; Make sure something was returned. - .I RESULT>0 S ORRET=0 ; Was return value 1 or more? - I ORRET W !," Error in processing - patients will not be added." Q ; Abort if there's a problem. - ; Clinic patients should now be in ^TMP("SC TMP LIST",$J file. - ; - ; Write the patients to the OE/RR LIST file: - S ALCNT=0 ; Initialize autolink counter. - S DUPCNT=0 ; Initialize duplicate counter. - S RCD=0 ; Initialize to start with first data record. - F S RCD=$O(^TMP("SC TMP LIST",$J,RCD)) Q:'RCD D ; Each record. - .S DFN=$P(^TMP("SC TMP LIST",$J,RCD),"^") ; Patient IEN. - .S X=DFN_";DPT(" ; Add ";DPT(" to patient string. - .I $D(^OR(100.21,+TEAM,10,"B",X)) S DUPCNT=DUPCNT+1 Q ; This patient already on list - increment dupe counter. - .S:'$D(^OR(100.21,+TEAM,10,0)) ^(0)="^100.2101AV^^" - .K DIC,DA,DO,DD - .S DA(1)=+TEAM,DIC="^OR(100.21,"_DA(1)_",10,",DIC(0)="L" - .D FILE^DICN - .I +X S ALCNT=ALCNT+1 ; Increment counter. - .Q ; Loop for each record in ^TMP file. - ; - ; Give user the results: - I ALCNT>0 W !," "_ALCNT_" patient(s) added to list." - I ALCNT=0 W !," No linked patients found." - I DUPCNT>0 W !," "_DUPCNT_" patient(s) already on list." - W ! - K ^TMP("SC TMP LIST",$J) ; Clean up ^TMP file entries. - ; - Q - ; -LOOPTS(REF,DEX) ; - S ORLPT=0 F S ORLPT=$O(^DPT(REF,DEX,ORLPT)) Q:ORLPT'>0 S X=ORLPT_";DPT(" D ADDLOOP - I $D(LVPT),LVPT["B"!(LVPT']"") Q:REF="APR" - I +X W !,$S(+CNT:" "_(+$G(CNTAPR)+(+CNT))_" patient(s) added.",1:" Linked patients already on list.") - E W " No linked patients found." - W ! - K DEX,FILE,MSG,REF,X,Y - Q - ; -ASKUSER ; From ASKLIST - ask for providers/users. - Q:$D(DTOUT)!($D(DUOUT)) - W ! - S:'$D(^OR(100.21,+TEAM,1,0)) ^(0)="^100.212PA^^" - K DIC,DA - S DLAYGO=100.212,DA(1)=+TEAM - S DIC("P")="100.212PA",DIC="^OR(100.21,"_DA(1)_",1,",DIC(0)="AELMQ" - S DIC("A")=" Enter team provider/user: " - ; SLC/PKS - Next line added on 4/11/2000: - S DIC("S")="I $D(X),$D(^VA(200,""AK.PROVIDER"",$P(^(0),U))),$$ACTIVE^XUSER(+Y)" - F D Q:Y<1 - .D ^DIC - .I '(Y<1) W ! - K DIC,DA,DLAYGO - Q - ; -ASKDEV ; From ASKLIST - ask for device. - ; - ; New, by PKS - 7/29/99: - Q:$D(DTOUT)!($D(DUOUT)) ; Previous interaction fail? - W ! - N DIE,DR - S DIE="^OR(100.21," - S DA=+TEAM - S DR="1.5 Enter device: " - D ^DIE ; Writes to DEVICE field. - K DIE - Q - ; -ASKSUB ; From ASKLIST - Ask re: subscription status. - ; (PKS - 8/1999) - ; - Q:$D(DTOUT)!($D(DUOUT)) ; Previous interaction fail? - W ! - N DIE,DR - S DIE="^OR(100.21," - S DA=+TEAM - S DR="1.7 Enter subscription status: " - D ^DIE ; Writes to SUBSCRIBE field. - K DIE - ; - Q - ; -STOR ; From SEQ^ORLP0 - store list in 100.21. - Q:'$D(DUZ)!('ORCNT) - I '$D(TEAM),($D(Y)#2) S TEAM=Y - S DLAYGO=100.21 - L +^OR(100.21,+TEAM) - S (CNT,ORLI)=0 F ORLJ=1:1 S ORLI=$O(^XUTL("OR",$J,"ORLP",ORLI)) Q:ORLI<1 I $D(^(ORLI,0)) S X=^(0),X=$P(X,U,3) D ADDLOOP - I $G(X)>0 S MSG=$S(CNT=0:" Patient(s) already on list.",1:" "_CNT_" patient(s) added.") W !?5,MSG - E W !?5," No patients found." - I CNT>0 W !?5," Storing list " W:$D(TEAM) $P(TEAM,U,2)," " W "for future reference..." - L -^OR(100.12,+TEAM) - Q - ; -ADDLOOP ; From STOR, LOOPTS - add patients. - Q:$D(^OR(100.21,+TEAM,10,"B",X)) ; Quit if on list. - S:'$D(^OR(100.21,+TEAM,10,0)) ^(0)="^100.2101AV^^" - K DIC,DA,DO,DD - S DA(1)=+TEAM,DIC="^OR(100.21,"_DA(1)_",10,",DIC(0)="L" - D FILE^DICN I Y>0 S:$D(CNT) CNT=CNT+1 - Q - ; -CHKNAM(X) ; Check for duplicate entry. - N DIC - S X=$G(X) - S DIC="^OR(100.21," - D ^DIC - S X=+Y - Q X - ; -END ; - I $G(TEAM) L -^OR(100.21,+TEAM) - ; -END1 K %,CNT,DA,DD,DIC,DO,DIE,DIK,DIR,DR,LINK,ORCNT,ORLI,ORLJ,ORLPT,SEL,TEAM,X,Y,ORBSTG,ORBROOT,DTOUT - Q - ; +ORLP ; SLC/CLA - Manager for Team List options ; [1/12/01 1:54pm] + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**47,90,98**;Dec 17, 1997 + ; +CLEAR ; From TM, MERG^ORLP1, END^ORLP0. + K ^XUTL("OR",$J,"ORLP"),^("ORV"),^("ORU"),^("ORW") S ORCNT=0 + Q + ; +TM ; From option ORLP TEAM ADD - create/add a team list. + N ORLTYP + D CLEAR + W @IOF,!,"A team list is a list containing patients related to several providers.",!,"These providers are the list's users. You may now create a new team list" + W !,"or add autolinks, users and/or patients to an existing team list. Autolinks",!,"automatically add or remove patients with ADT movements. Users on the list" + W !,"may receive notifications regarding patients on the same list. Please prefix",!,"your list name with 'TEAM' or 'SERVICE' (e.g. TEAM7B, SERVICECARDIOLOGY.)",! + D ASKLIST,END + Q + ; +ASKLIST ; Ask for team list. + ; NOTE: For new entries, TYPE field is required and trigger + ; stuffs CREATOR field with DUZ of current user. + ; +AL N DLAYGO,DIC,DIE,DIK,DR,ORFLAG,ORLTNAM,OROWNER,ORROOT,ORDA,ORYY + N DIR S DIR(0)="FAO^3:30",DIR("A")="Enter team list name: " + D ^DIR + I '$D(X)!$D(DIRUT) K DIR,DIRUT Q + S ORLTNAM=$$CHKNAM(Y) ; Check for duplication. + K DIR + N DIC S X=$G(X),(ORROOT,DIC)="^OR(100.21,",DLAYGO=100.21,DIC(0)="LEFQZ" D ^DIC + I '$D(X)!(+Y<0)!$D(DIRUT) K DIRUT Q ; User aborted or problem. + ; Check for "Personal" lists (and not a new entry): + I ORLTNAM>0,(+Y>0),$P($G(^OR(100.21,+Y,0)),U,2)="P" W !!," Personal lists cannot be edited here.",! G AL + S (ORYY,TEAM)=Y,ORDA=+Y,TEAM(0)=Y(0),^TMP("ORLP",$J,"TLIST")=+Y K DIC + ; Check for entry of team type (new team entry): + I $P(TEAM,U,3) D Q + .I $P(TEAM(0),U,2)="" D + ..SET Y=TEAM,Y(0)=TEAM(0) ; Reassign in case DIE previously called. + ..N DIE S DIE=ORROOT,DA=+Y,DR="1 Enter type: ~R" D ^DIE I $O(Y(0)) S DIK=DIE D ^DIK Q + .S (ORLTYP,OROWNER)="" + .S ORLTYP=$P(^OR(100.21,+TEAM,0),U,2) Q:'$L(ORLTYP) + .; Check for "P" type, ask for user/owner input: + .I ORLTYP="P" D OWNER^ORLP1 ; Sets OROWNER variable. + .I (ORLTYP="P")&(OROWNER="") S DIK=ORROOT,DA=ORDA D ^DIK Q + .; + .; Allow further editing of autolink type teams: + .I ORLTYP["A" S:'$D(^OR(100.21,+TEAM,2,0)) ^(0)="^100.213AVI^^" D Q + .. D ASKLINK,ASKUSER,ASKDEV,ASKSUB + .; + .; Proceed with editing for "TM" type teams: + .D ASKPT^ORLP00(+TEAM),ASKUSER,ASKDEV + ; + ; For existing teams, display team type: + W !," Type: "_$S($P(Y(0),U,2)="TM":"Manual Team List",$P(Y(0),U,2)="TA":"Autolinked Team List",$P(Y(0),U,2)="MRAL":"Manual Removal Autolinked Team List",1:"(Unknown)") + ; + ; Lock before allowing editing: + I $O(^OR(100.21,+TEAM,10,0)) L +^OR(100.21,+TEAM):3 I '$T W !?5," Another user is editing this entry." Q + ; + ; Allow applicable editing for all types but "TM" teams: + I $P(TEAM(0),U,2)'="TM" D + . D ASKLINK,ASKUSER,ASKDEV + . ; + . ; Editing of "subscription" attribute for "TA" and "MRAL" teams: + . I $P(TEAM(0),U,2)["A" D + . . D ASKSUB + ; + ; Proceed with editing for "TM" type teams: + I $P(TEAM(0),U,2)="TM" D ASKPT^ORLP00(+TEAM),ASKUSER,ASKDEV + Q + ; +ASKLINK ; Ask for autolinks. + N DIC,DA,DLAYGO,Y,DUOUT,LVP,LVPT,LNAME + W ! + F K DIC,DA,DUOUT D I LVP<1 Q + .S DLAYGO=100.21,DA(1)=+TEAM,DIC="^OR(100.21,"_DA(1)_",2,",DIC(0)="AELMQZ",DIC("A")=" Enter team autolink: " + .D ^DIC S LVP=Y I Y<1 Q + .I $P($G(Y),U,3)=1 D + ..S LNAME=Y(0,0) + ..I LVP["VA(200" F D Q:'$D(Y) + ...S DA(1)=+TEAM,DIE="^OR(100.21,"_DA(1)_",2,",DA(1)=+TEAM,DA=+LVP,DR="1R" D ^DIE I $D(Y) W !," This field is required in order for Provider autolinks to work correctly.",!," Please answer the question." + ..S LVPT=$P($G(^OR(100.21,+TEAM,2,+LVP,0)),U,2) + ..; For clinics, take a fork in the road: + ..I $P($P(LVP,U,2),";",2)="SC(" D BYCL(LVP) Q + ..; For autolinks besides clinics, truck on: + ..D ADDLPTS + Q + ; +ADDLPTS ; Add patients linked to autolink. + W ! + W !," [ADT movements linked to " + W !," ",LNAME + W !," will now automatically add patients to this list.]" + S LINK=$P(LVP,U,2),FILE="^"_$P(LINK,";",2),X="",CNT=0 + W !!," Adding patients linked to ",LNAME,"..." + W ! + I FILE="^DIC(42," D LOOPTS("CN",LNAME) Q + I FILE="^DG(405.4," D LOOPTS("RM",LNAME) Q + I FILE="^VA(200," D Q + . ; Variable LVPT determines if provider pointer is for: + . ; B - Both Primary and Attending + . ; A - Attending + . ; P - Primary + . I LVPT["B" D LOOPTS("APR",+LINK) N CNTAPR S CNTAPR=CNT,CNT=0 D LOOPTS("AAP",+LINK) Q + . I LVPT["P" D LOOPTS("APR",+LINK) Q + . I LVPT["A" D LOOPTS("AAP",+LINK) + I FILE="^DIC(45.7," D LOOPTS("ATR",+LINK) Q + Q + ; +BYCL(CLINIC) ; SLC/PKS - 6/99 - Return list of clinic patients by enrollment. + ; + ; Called by ASKLINK. + ; + ; Variables used: + ; + ; CLINIC = Clinic to search. + ; ORLIST = Array, returned by call to PTCL^SCAPMC. + ; ORERR = Array for errors, returned by call to PTCL^SCAPMC. + ; ORRET = Flag for problem with PTCL^SCAPMC call. + ; RESULT = Holds result of PTCL^SCAPMC call (1=OK, 0=error). + ; RCD = Holder for each record in ^TMP of PTCL^SCAPMC. + ; DFN = Patient IEN. + ; ALCNT = Count of autolink patients added. + ; DUPCNT = Count of duplicate patients already on list. + ; X = Temp value holder variable. + ; + N DIC,DA,DO,DD,ORLIST,ORERR,RESULT,RCD,DFN,ALCNT,DUPCNT,X,ORRET + ; + ; Assign clinic variable: + S CLINIC=$P(CLINIC,"^",2) + S CLINIC=$P(CLINIC,";") + ; + ; Keep user informed: + W ! + W !," [Patient enrollments linked to " + W !," ",LNAME + W !," will now automatically add patients to this list.]" + W ! + W !," Adding patients enrolled in ",LNAME,"..." + W ! + ; + ; Process the Autolink entries: + K ^TMP("SC TMP LIST") ; Clean up potential leftover data. + S ORRET=1 + S RESULT=$$PTCL^SCAPMC(CLINIC,,.ORLIST,.ORERR) + I $L($G(RESULT)) D ; Make sure something was returned. + .I RESULT>0 S ORRET=0 ; Was return value 1 or more? + I ORRET W !," Error in processing - patients will not be added." Q ; Abort if there's a problem. + ; Clinic patients should now be in ^TMP("SC TMP LIST",$J file. + ; + ; Write the patients to the OE/RR LIST file: + S ALCNT=0 ; Initialize autolink counter. + S DUPCNT=0 ; Initialize duplicate counter. + S RCD=0 ; Initialize to start with first data record. + F S RCD=$O(^TMP("SC TMP LIST",$J,RCD)) Q:'RCD D ; Each record. + .S DFN=$P(^TMP("SC TMP LIST",$J,RCD),"^") ; Patient IEN. + .S X=DFN_";DPT(" ; Add ";DPT(" to patient string. + .I $D(^OR(100.21,+TEAM,10,"B",X)) S DUPCNT=DUPCNT+1 Q ; This patient already on list - increment dupe counter. + .S:'$D(^OR(100.21,+TEAM,10,0)) ^(0)="^100.2101AV^^" + .K DIC,DA,DO,DD + .S DA(1)=+TEAM,DIC="^OR(100.21,"_DA(1)_",10,",DIC(0)="L" + .D FILE^DICN + .I +X S ALCNT=ALCNT+1 ; Increment counter. + .Q ; Loop for each record in ^TMP file. + ; + ; Give user the results: + I ALCNT>0 W !," "_ALCNT_" patient(s) added to list." + I ALCNT=0 W !," No linked patients found." + I DUPCNT>0 W !," "_DUPCNT_" patient(s) already on list." + W ! + K ^TMP("SC TMP LIST",$J) ; Clean up ^TMP file entries. + ; + Q + ; +LOOPTS(REF,DEX) ; + S ORLPT=0 F S ORLPT=$O(^DPT(REF,DEX,ORLPT)) Q:ORLPT'>0 S X=ORLPT_";DPT(" D ADDLOOP + I $D(LVPT),LVPT["B"!(LVPT']"") Q:REF="APR" + I +X W !,$S(+CNT:" "_(+$G(CNTAPR)+(+CNT))_" patient(s) added.",1:" Linked patients already on list.") + E W " No linked patients found." + W ! + K DEX,FILE,MSG,REF,X,Y + Q + ; +ASKUSER ; From ASKLIST - ask for providers/users. + Q:$D(DTOUT)!($D(DUOUT)) + W ! + S:'$D(^OR(100.21,+TEAM,1,0)) ^(0)="^100.212PA^^" + K DIC,DA + S DLAYGO=100.212,DA(1)=+TEAM + S DIC("P")="100.212PA",DIC="^OR(100.21,"_DA(1)_",1,",DIC(0)="AELMQ" + S DIC("A")=" Enter team provider/user: " + ; SLC/PKS - Next line added on 4/11/2000: + S DIC("S")="I $D(X),$D(^VA(200,""AK.PROVIDER"",$P(^(0),U))),$$ACTIVE^XUSER(+Y)" + F D Q:Y<1 + .D ^DIC + .I '(Y<1) W ! + K DIC,DA,DLAYGO + Q + ; +ASKDEV ; From ASKLIST - ask for device. + ; + ; New, by PKS - 7/29/99: + Q:$D(DTOUT)!($D(DUOUT)) ; Previous interaction fail? + W ! + N DIE,DR + S DIE="^OR(100.21," + S DA=+TEAM + S DR="1.5 Enter device: " + D ^DIE ; Writes to DEVICE field. + K DIE + Q + ; +ASKSUB ; From ASKLIST - Ask re: subscription status. + ; (PKS - 8/1999) + ; + Q:$D(DTOUT)!($D(DUOUT)) ; Previous interaction fail? + W ! + N DIE,DR + S DIE="^OR(100.21," + S DA=+TEAM + S DR="1.7 Enter subscription status: " + D ^DIE ; Writes to SUBSCRIBE field. + K DIE + ; + Q + ; +STOR ; From SEQ^ORLP0 - store list in 100.21. + Q:'$D(DUZ)!('ORCNT) + I '$D(TEAM),($D(Y)#2) S TEAM=Y + S DLAYGO=100.21 + L +^OR(100.21,+TEAM) + S (CNT,ORLI)=0 F ORLJ=1:1 S ORLI=$O(^XUTL("OR",$J,"ORLP",ORLI)) Q:ORLI<1 I $D(^(ORLI,0)) S X=^(0),X=$P(X,U,3) D ADDLOOP + I $G(X)>0 S MSG=$S(CNT=0:" Patient(s) already on list.",1:" "_CNT_" patient(s) added.") W !?5,MSG + E W !?5," No patients found." + I CNT>0 W !?5," Storing list " W:$D(TEAM) $P(TEAM,U,2)," " W "for future reference..." + L -^OR(100.12,+TEAM) + Q + ; +ADDLOOP ; From STOR, LOOPTS - add patients. + Q:$D(^OR(100.21,+TEAM,10,"B",X)) ; Quit if on list. + S:'$D(^OR(100.21,+TEAM,10,0)) ^(0)="^100.2101AV^^" + K DIC,DA,DO,DD + S DA(1)=+TEAM,DIC="^OR(100.21,"_DA(1)_",10,",DIC(0)="L" + D FILE^DICN I Y>0 S:$D(CNT) CNT=CNT+1 + Q + ; +CHKNAM(X) ; Check for duplicate entry. + N DIC + S X=$G(X) + S DIC="^OR(100.21," + D ^DIC + S X=+Y + Q X + ; +END ; + I $G(TEAM) L -^OR(100.21,+TEAM) + ; +END1 K %,CNT,DA,DD,DIC,DO,DIE,DIK,DIR,DR,LINK,ORCNT,ORLI,ORLJ,ORLPT,SEL,TEAM,X,Y,ORBSTG,ORBROOT,DTOUT + Q + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMBLDPS.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMBLDPS.m index d8a61d5c..3b00c3e8 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMBLDPS.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMBLDPS.m @@ -1,208 +1,195 @@ -ORMBLDPS ;SLC/MKB-Build outgoing Pharmacy ORM msgs ;6/16/08 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,38,54,86,97,94,116,129,141,190,195,237,254,243**;Dec 17, 1997;Build 242 -PTR(NAME) ; -- Returns ptr value of prompt in Dialog file - Q +$O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0)) - ; -NVA ; -- new Non-VA Meds order - N NVA S NVA=1 -OUT ; -- new Outpt Meds order [same as UD, +3 fields] -UD ; -- new Inpt (Unit Dose) Meds order - N ADMIN,OI,DRUG,INSTR,DOSE,ROUTE,SCHED,DUR,URG,PROVCOMM,PI,DISPENSE,X,Y,I,J,K,L,QT1,QT2,QT3,QT4,QT6,QT9,CONJ,ORC,SC,OUTPT,OITXT,OITXT2 - N QT7,SCHTYPE - S OUTPT=$S($P(OR0,U,12)="O":1,1:0) ;outpt flag - S X=$G(^OR(100,IFN,8,1,0)) I $P(X,U,5),$P(X,U,5)'=$P(X,U,3) S $P(ORMSG(4),"|",13)=$P(X,U,5) ; Send signer instead of orderer if different - S OI=$$PTR("ORDERABLE ITEM"),DRUG=$$PTR("DISPENSE DRUG") - S INSTR=$$PTR("INSTRUCTIONS"),SCHED=$$PTR("SCHEDULE"),ADMIN=$$PTR("ADMIN TIMES") - S SCHTYPE=$$PTR("SCHEDULE TYPE") - S DUR=$$PTR("DURATION"),URG=$$PTR("URGENCY"),DOSE=$$PTR("DOSE") - S ROUTE=$$PTR("ROUTE"),PROVCOMM=$$PTR("WORD PROCESSING 1") - S PI=$$PTR("PATIENT INSTRUCTIONS"),CONJ=$$PTR("AND/THEN") - S J=1,ORC(J)=$P(ORMSG(4),"|",1,7)_"|" - I +$G(NVA)=1 G NVA1 -UD1 S I=0 F S I=$O(ORDIALOG(INSTR,I)) Q:I'>0 D - . S X=$G(ORDIALOG(DOSE,I)) - . ;S QT1=$S($L(X):$P(X,"&",1,4)_"&"_$P(X,"&",6),1:"") - . S QT2=$$ESC($G(ORDIALOG(SCHED,I)))_$S(OUTPT:"",1:"&"_$G(ORDIALOG(ADMIN,I))) - . S QT3=$$HL7DUR - . S QT1=$S($L(X):$P(X,"&",1,6),1:"") - . S QT6=$P($G(^ORD(101.42,+$G(ORDIALOG(URG,I)),0)),U,2) - . S QT7=$G(ORDIALOG(SCHTYPE,I)) - . S QT9=$G(ORDIALOG(CONJ,I))_"~" S:$E(QT9)="T" QT9="S~" - . S J=J+1,ORC(J)=QT1_U_QT2_U_QT3_"^^^"_QT6_U_QT7_U_$$INSTR_U_QT9 - ; -NVA1 I +$G(NVA)=1 D - . S I=1 ;only one dosage possible for non-va meds - . S QT2=$G(ORDIALOG(SCHED,I)),QT3=$$HL7DUR,X=$G(ORDIALOG(DOSE,I)) - . S QT1=$S($L(X):$P(X,"&",1,6),1:"") - . S QT6=$P($G(^ORD(101.42,+$G(ORDIALOG(URG,I)),0)),U,2) - . S QT9=$G(ORDIALOG(CONJ,I))_"~" S:$E(QT9)="T" QT9="S~" - . S J=J+1,ORC(J)=QT1_U_$$ESC(QT2)_U_QT3_"^^^"_QT6_"^^"_$$INSTR_U_QT9 - ; - I $L($P(OR0,U,8)) S $P(ORC(2),U,4)=$$FMTHL7^XLFDT($P(OR0,U,8)) S:J<2 J=2 - S J=J+1,ORC(J)="|"_$P(ORMSG(4),"|",9,999),ORC=J,X="ORMSG(4)",ORMSG(4)="",I=0 - F J=1:1:ORC S Y=ORC(J) D ;add to ORMSG(4) - . I $L(@X)+$L(Y)'>245 S @X=@X_Y - . E S L=245-$L(@X),@X=@X_$E(Y,1,L),I=I+1,X="ORMSG(4,"_I_")",@X=$E(Y,L+1,$L(Y)) - I $G(ORDIALOG(DRUG,1)) S X=$$ENDCM^PSJORUTL(ORDIALOG(DRUG,1)),DISPENSE=$P(X,U,3)_"^^99NDF^"_ORDIALOG(DRUG,1)_"^^99PSD" - S OITXT=$$USID^ORMBLD($G(ORDIALOG(OI,1))) - S OITXT2=$P(OITXT,U,1,4)_U_$$ESC($P(OITXT,U,5))_U_$P(OITXT,U,6,99) - S ORMSG(5)="RXO|"_OITXT2_"|||||||||"_$G(DISPENSE) -UD2 I $G(OUTPT) D - . N QTY,REFS,DSPY - . S QTY=$$PTR("QUANTITY"),REFS=$$PTR("REFILLS"),DSPY=$$PTR("DAYS SUPPLY") - . S ORMSG(5)=ORMSG(5)_"|"_$G(ORDIALOG(QTY,1))_"||"_$G(ORDIALOG(REFS,1))_"||||D"_$G(ORDIALOG(DSPY,1)) - S I=5 I $L($G(ORDIALOG(PROVCOMM,1))) D - . S J=$O(^TMP("ORWORD",$J,PROVCOMM,1,0)) Q:'J - . S I=6,ORMSG(6)="NTE|6|P|"_$$ESC($G(^TMP("ORWORD",$J,PROVCOMM,1,J,0))) - . S K=0 F S J=$O(^TMP("ORWORD",$J,PROVCOMM,1,J)) Q:J'>0 S K=K+1,ORMSG(6,K)=$G(^(J,0)) - I $G(OUTPT),$L($G(ORDIALOG(PI,1))) D - . S J=$O(^TMP("ORWORD",$J,PI,1,0)) Q:'J - . S I=I+1,ORMSG(I)="NTE|7|P|"_$G(^TMP("ORWORD",$J,PI,1,J,0)) - . S K=0 F S J=$O(^TMP("ORWORD",$J,PI,1,J)) Q:J'>0 S K=K+1,ORMSG(I,K)=$G(^(J,0)) -UD3 S J=0 F S J=$O(ORDIALOG(ROUTE,J)) Q:J'>0 S I=I+1,ORMSG(I)=$$RXR($G(ORDIALOG(ROUTE,J))) - I $D(^OR(100,IFN,9)) D ORDCHKS - S I=I+1,ORMSG(I)=$$ZRX(IFN,OUTPT) - I $G(OUTPT) D ;add SC data - . N OR5 S OR5=$G(^OR(100,IFN,5)) - . I $L(OR5),OR5'?5"^" S I=I+1,ORMSG(I)="ZSC|"_$TR(OR5,"^","|") Q - . S SC=$$PTR("SERVICE CONNECTED") S:$D(ORDIALOG(SC,1)) I=I+1,ORMSG(I)="ZSC|"_$S(ORDIALOG(SC,1):"SC",1:"NSC") - ; Create DG1 & ZCL segment(s) for Billing Awareness (BA) Project - D DG1^ORWDBA3($G(IFN),"I",I) - I $P(^ORD(100.98,$P(OR0,U,11),0),U)="NON-VA MEDICATIONS" D - . S I=I+1 D ZRN(IFN,.ORMSG,I) - Q - ; -INSTR() ; -- Return text instructions for QT-8, instance I - N Y S Y=$P($G(ORDIALOG(DOSE,I)),"&",5) - I $G(ORDIALOG(DRUG,1)),$L(Y) Q $$ESC(Y) - S Y=$G(ORDIALOG(INSTR,I)) I $G(OUTPT) D - . N UNITS,UNT S UNITS=$$PTR("FREE TEXT"),UNT=$G(ORDIALOG(UNITS,I)) - . S:$L(UNT) Y=Y_" "_UNT ;old format - Q $$ESC(Y) - ; -HL7DUR() ; -- Returns HL7 form of duration X - N X,X1,X2,Y S X=$G(ORDIALOG(DUR,I)) - S X1=+$G(X),Y="" G:X1'>0 HDQ - S X2=$$UP^XLFSTR($P(X,X1,2)) S:$E(X2)=" " X2=$E(X2,2,99) - S Y=$S($E(X2,1,2)="MO":"L",'$L(X2):"D",1:$E(X2))_X1 -HDQ Q Y - ; -IV ; -- new IV Meds order - N SOLN,VOL,ADDS,STR,UNITS,RATE,URG,WP,QT,I,X1,X2,INST - N IVLIMIT ; duratioin or total volume for IV order - N IVTYPE,IVZRX,X,CNT,ROUTE,ORBCMA,DFN - S IVLIMIT=$$PTR("DURATION") - S IVTYPE=$G(ORDIALOG(+$$PTR("IV TYPE"),1)) - I IVTYPE="",$P($G(^OR(100,IFN,3)),U,11)="B" D - .S IVTYPE=$$MOB^ORMBLDP1(IFN,+$P($G(^OR(100,IFN,0)),U,2)) - .D RESP^ORCSAVE2(IFN,"OR GTX IV TYPE",IVTYPE) - S RATE=$$PTR("INFUSION RATE"),ADDS=$$PTR("ADDITIVE") - S STR=$$PTR("STRENGTH PSIV"),UNITS=$$PTR("UNITS") - S WP=$$PTR("WORD PROCESSING 1"),VOL=$$PTR("VOLUME") - S SCHTYPE=$$PTR("SCHEDULE TYPE") - S SOLN=$$PTR("ORDERABLE ITEM"),URG=+$G(ORDIALOG($$PTR("URGENCY"),1)) - ;I IVTYPE="",$G(ORDIALOG(+$$PTR("SCHEDULE"),1))="" S IVTYPE="C" - I IVTYPE="I" S QT=U_$$ESC($G(ORDIALOG(+$$PTR("SCHEDULE"),1)))_"&"_$G(ORDIALOG(+$$PTR("ADMIN TIMES"),1))_"^^^^" - I IVTYPE="C" S QT="^^^^^" - ;S QT=U_$G(ORDIALOG(+$$PTR("SCHEDULE"),1))_"^^^^" - S:URG QT=QT_$P($G(^ORD(101.42,URG,0)),U,2) - S $P(ORMSG(4),"|",8)=QT - S X=$G(^OR(100,IFN,8,1,0)) I $P(X,U,5),$P(X,U,5)'=$P(X,U,3) S $P(ORMSG(4),"|",13)=$P(X,U,5) ; Send signer instead of orderer if different - S RATE=$G(ORDIALOG(RATE,1)) S:$E(RATE,$L(RATE))=" " RATE=$E(RATE,1,($L(RATE)-1)) S ORMSG(5)="RXO|^^^PS-1^IV^99OTH|"_$$ESC(RATE) ;strip any trailing spaces - S IVLIMIT=$G(ORDIALOG(IVLIMIT,1)) - I $L(IVLIMIT) S IVLIMIT=$$HL7IVLMT^ORMBLDP1(IVLIMIT),ORMSG(5)="RXO|^^"_IVLIMIT_"^PS-1^IV^99OTH|"_RATE - S I=5 I $L($G(ORDIALOG(WP,1))) D - . N J,K S J=$O(^TMP("ORWORD",$J,WP,1,0)) Q:'J - . S I=6,ORMSG(6)="NTE|6|P|"_$$ESC($G(^TMP("ORWORD",$J,WP,1,J,0))) - . S K=0 F S J=$O(^TMP("ORWORD",$J,WP,1,J)) Q:J'>0 S K=K+1,ORMSG(6,K)=^(J,0) - ;S I=I+1,ORMSG(I)=$$RXR(+$$PTR("ROUTE")) - S ROUTE=+$$PTR("ROUTE") - S I=I+1,ORMSG(I)=$$RXR($G(ORDIALOG(ROUTE,1))) -IV1 S INST=0 F S INST=$O(ORDIALOG(SOLN,INST)) Q:INST'>0 D - . S X1="B",X2=+$G(ORDIALOG(SOLN,INST)) - . I $P($G(^ORD(101.43,X2,"PS")),U,4) S X1=X1_"A" ;pre-mix - . S I=I+1,ORMSG(I)="RXC|"_X1_"|"_$$USID^ORMBLD(X2)_"|"_$G(ORDIALOG(VOL,INST))_"|"_$$HL7UNIT("ML") - I $O(ORDIALOG(ADDS,0)) D - . S INST=0 F S INST=$O(ORDIALOG(ADDS,INST)) Q:INST'>0 D - . . S X1=$G(ORDIALOG(ADDS,INST)),X2=$G(ORDIALOG(UNITS,INST)) - . . S I=I+1,ORMSG(I)="RXC|A|"_$$USID^ORMBLD(X1)_"|"_$G(ORDIALOG(STR,INST))_"|"_$$HL7UNIT(X2) - I $D(^OR(100,IFN,9)) D ORDCHKS - S IVZRX=$$ZRX(IFN,0) - S CNT=0 - F X=1:1:$L(IVZRX) I $E(IVZRX,X)="|" S CNT=CNT+1 - I CNT<6 F X=CNT:1:5 S IVZRX=IVZRX_"|" - S I=I+1,ORMSG(I)=IVZRX_IVTYPE - ; Create DG1 & ZCL segment(s) for Billing Awareness (BA) Project - D DG1^ORWDBA3($G(IFN),"I",I) - Q - ; -RXR(ROUTE) ; -- Returns RXR segment - N IEN,NAME - I +ROUTE=0 Q "RXR|^^^^^99PSR" - K ^TMP($J,"ORMBLDPS RXR") - D ALL^PSS51P2(+ROUTE,,,,"ORMBLDPS RXR") - S NAME=^TMP($J,"ORMBLDPS RXR",+ROUTE,.01) - ;N NAME S NAME=$$GET1^DIQ(51.2,+ROUTE_",",.01) - K ^TMP($J,"ORMBLDPS RXR") - Q "RXR|^^^"_+ROUTE_U_NAME_"^99PSR" - ; -ZRX(IFN,OUTPT) ; -- Returns ZRX segment - N NATURE,TYPE,ORIG,PSORIG,ROUTING,ZRX - S TYPE=$P($G(^OR(100,IFN,3)),U,11),NATURE=$P($G(^(8,1,0)),U,12) - S:NATURE NATURE=$P($G(^ORD(100.02,+NATURE,0)),U,2) ;code - S PSORIG="" I (TYPE=1)!(TYPE=2) D - . S ORIG=$P($G(^OR(100,IFN,3)),U,5),PSORIG=$G(^OR(100,+ORIG,4)) - . I PSORIG'>0 S PSORIG="",TYPE=0 ;edit of unreleased order - S ZRX="ZRX|"_PSORIG_"|"_NATURE_"|"_$S(TYPE=1:"E",TYPE=2:"R",1:"N") - S ROUTING=$G(ORDIALOG($$PTR("ROUTING"),1)) - ;AGP FIX FOR PROBLEM WITH ROUTING BE SET TO DAY SUPPLY ONCE ROOT CAUSE - ;IS FOUND THIS CODE WILL BE REMOVE - I OUTPT=1,ROUTING'="",ROUTING>0 S ROUTING="M" - I $G(OUTPT) S ZRX=ZRX_"|"_ROUTING_$S($L($P($G(^OR(100,ORIFN,8,1,2)),"^",3)):"|||1",1:"") - Q ZRX - ; -ZRN(IFN,ORMSG,I) ; -- Set ZRN segment - N ST,ZRN,J,K,TXT - S ORMSG(I)="ZRN|N|" - S ST=$$PTR("STATEMENTS") - I $L($G(ORDIALOG(ST,1))) D - . S J=$O(^TMP("ORWORD",$J,ST,1,0)) Q:'J - . S K=0,TXT=$G(^TMP("ORWORD",$J,ST,1,J,0)) - . I $L(TXT) S K=K+1,ORMSG(I,K)=TXT - . F S J=$O(^TMP("ORWORD",$J,ST,1,J)) Q:J'>0 S TXT=$G(^(J,0)) D - . . I $L(TXT) S K=K+1,ORMSG(I,K)=TXT - Q - ; -ORDCHKS ; -- Include order checks in OBX segments - N OC,X,X1 S OC=0 - F S OC=$O(^OR(100,IFN,9,OC)) Q:OC'>0 S X=$G(^(OC,0)),X1=$G(^(1)) D - . S I=I+1,ORMSG(I)="OBX|"_OC_"|TX|^^^"_+X_"^^99OCX||"_$$ESC($S($L(X1):X1,1:$P(X,U,3)))_"|||||||||"_$$FMTHL7^XLFDT($P(X,U,6))_"||"_$P(X,U,5) - . I $L($P(X,U,4)) S I=I+1,ORMSG(I)="NTE|"_OC_"|P|"_$$ESC($P(X,U,4)) - Q - ; -HL7UNIT(X) ; -- Return coded element for volume/strength units - N I,UNIT,Y - F I=1:1:$L(X) I $E(X,I)?1A Q ; first letter - S UNIT=$$UP^XLFSTR($E(X,I,$L(X))),Y="" - F I=1:1:14 S X=$P("ML^LITER^MCG^MG^GM^UNITS^IU^MEQ^MM^MU^THOUU^MG-PE^NANOGRAM^MMOL","^",I) I UNIT=X S Y="^^^PSIV-"_I_U_UNIT_"^99OTH" Q - Q Y - ; -VER(IFN) ; -- Send msg for nurse-verified orders - N OR0,ORMSG S OR0=$G(^OR(100,+IFN,0)) Q:$P(OR0,U,12)'="I" ;Inpt only - S ORMSG(1)=$$MSH^ORMBLD("ORM","PS"),ORMSG(2)=$$PID^ORMBLD($P(OR0,U,2)) - S ORMSG(3)=$$PV1^ORMBLD($P(OR0,U,2),$P(OR0,U,12),+$P(OR0,U,10)) - S ORMSG(4)="ORC|ZV|"_IFN_"^OR|"_$G(^OR(100,+IFN,4))_"^PS||||||||"_DUZ_"||||"_$$FMTHL7^XLFDT($$NOW^XLFDT) - D MSG^XQOR("OR EVSEND PS",.ORMSG) - Q - ; -REF(IFN,ROUTING,CLINIC) ; -- Send msg for refill request - N OR0,ORMSG S OR0=$G(^OR(100,+IFN,0)) Q:$P(OR0,U,12)'="O" - S:'$G(CLINIC) CLINIC=$S($G(ORL):+ORL,1:+$P(OR0,U,10)) - S ORMSG(1)=$$MSH^ORMBLD("ORM","PS"),ORMSG(2)=$$PID^ORMBLD($P(OR0,U,2)) - S ORMSG(3)=$$PV1^ORMBLD($P(OR0,U,2),"O",CLINIC) - S ORMSG(4)="ORC|ZF|"_IFN_"^OR|"_$G(^OR(100,+IFN,4))_"^PS|||||||"_DUZ_"||"_$G(ORNP)_"|||"_$$FMTHL7^XLFDT($$NOW^XLFDT) - S ORMSG(5)="ZRX||||"_ROUTING - D MSG^XQOR("OR EVSEND PS",.ORMSG) - Q -ESC(STR) ; - Q $$ESC^ORHLESC(STR,"~|\&^") +ORMBLDPS ;SLC/MKB-Build outgoing Pharmacy ORM msgs ;11:26 AM 2 Apr 2001 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,38,54,86,97,94,116,129,141,190,195,237,254**;Dec 17, 1997 +PTR(NAME) ; -- Returns ptr value of prompt in Dialog file + Q +$O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0)) + ; +NVA ; -- new Non-VA Meds order + N NVA S NVA=1 +OUT ; -- new Outpt Meds order + ; fall through to UD: same msg, +3 fields +UD ; -- new Inpt (Unit Dose) Meds order + N OI,DRUG,INSTR,DOSE,ROUTE,SCHED,DUR,URG,PROVCOMM,PI,DISPENSE,X,Y,I,J,K,L,QT1,QT2,QT3,QT4,QT6,QT9,CONJ,ORC,SC,OUTPT + S OUTPT=$S($P(OR0,U,12)="O":1,1:0) ;outpt flag + S X=$G(^OR(100,IFN,8,1,0)) I $P(X,U,5),$P(X,U,5)'=$P(X,U,3) S $P(ORMSG(4),"|",13)=$P(X,U,5) ; Send signer instead of orderer if different + S OI=$$PTR("ORDERABLE ITEM"),DRUG=$$PTR("DISPENSE DRUG") + S INSTR=$$PTR("INSTRUCTIONS"),SCHED=$$PTR("SCHEDULE") + S DUR=$$PTR("DURATION"),URG=$$PTR("URGENCY"),DOSE=$$PTR("DOSE") + S ROUTE=$$PTR("ROUTE"),PROVCOMM=$$PTR("WORD PROCESSING 1") + S PI=$$PTR("PATIENT INSTRUCTIONS"),CONJ=$$PTR("AND/THEN") + S J=1,ORC(J)=$P(ORMSG(4),"|",1,7)_"|" + I +$G(NVA)=1 G NVA1 +UD1 S I=0 F S I=$O(ORDIALOG(INSTR,I)) Q:I'>0 D + . S QT2=$G(ORDIALOG(SCHED,I)),QT3=$$HL7DUR,X=$G(ORDIALOG(DOSE,I)) + . ;S QT1=$S($L(X):$P(X,"&",1,4)_"&"_$P(X,"&",6),1:"") + . S QT1=$S($L(X):$P(X,"&",1,6),1:"") + . S QT6=$P($G(^ORD(101.42,+$G(ORDIALOG(URG,I)),0)),U,2) + . S QT9=$G(ORDIALOG(CONJ,I))_"~" S:$E(QT9)="T" QT9="S~" + . S J=J+1,ORC(J)=QT1_U_QT2_U_QT3_"^^^"_QT6_"^^"_$$INSTR_U_QT9 + ; +NVA1 I +$G(NVA)=1 D + . S I=1 ;only one dosage possible for non-va meds + . S QT2=$G(ORDIALOG(SCHED,I)),QT3=$$HL7DUR,X=$G(ORDIALOG(DOSE,I)) + . S QT1=$S($L(X):$P(X,"&",1,6),1:"") + . S QT6=$P($G(^ORD(101.42,+$G(ORDIALOG(URG,I)),0)),U,2) + . S QT9=$G(ORDIALOG(CONJ,I))_"~" S:$E(QT9)="T" QT9="S~" + . S J=J+1,ORC(J)=QT1_U_QT2_U_QT3_"^^^"_QT6_"^^"_$$INSTR_U_QT9 + ; + I $L($P(OR0,U,8)) S $P(ORC(2),U,4)=$$FMTHL7^XLFDT($P(OR0,U,8)) S:J<2 J=2 + S J=J+1,ORC(J)="|"_$P(ORMSG(4),"|",9,999),ORC=J,X="ORMSG(4)",ORMSG(4)="",I=0 + F J=1:1:ORC S Y=ORC(J) D ;add to ORMSG(4) + . I $L(@X)+$L(Y)'>245 S @X=@X_Y + . E S L=245-$L(@X),@X=@X_$E(Y,1,L),I=I+1,X="ORMSG(4,"_I_")",@X=$E(Y,L+1,$L(Y)) + I $G(ORDIALOG(DRUG,1)) S X=$$ENDCM^PSJORUTL(ORDIALOG(DRUG,1)),DISPENSE=$P(X,U,3)_"^^99NDF^"_ORDIALOG(DRUG,1)_"^^99PSD" + S ORMSG(5)="RXO|"_$$USID^ORMBLD($G(ORDIALOG(OI,1)))_"|||||||||"_$G(DISPENSE) +UD2 I $G(OUTPT) D + . N QTY,REFS,DSPY + . S QTY=$$PTR("QUANTITY"),REFS=$$PTR("REFILLS"),DSPY=$$PTR("DAYS SUPPLY") + . S ORMSG(5)=ORMSG(5)_"|"_$G(ORDIALOG(QTY,1))_"||"_$G(ORDIALOG(REFS,1))_"||||D"_$G(ORDIALOG(DSPY,1)) + S I=5 I $L($G(ORDIALOG(PROVCOMM,1))) D + . S J=$O(^TMP("ORWORD",$J,PROVCOMM,1,0)) Q:'J + . S I=6,ORMSG(6)="NTE|6|P|"_$G(^TMP("ORWORD",$J,PROVCOMM,1,J,0)) + . S K=0 F S J=$O(^TMP("ORWORD",$J,PROVCOMM,1,J)) Q:J'>0 S K=K+1,ORMSG(6,K)=$G(^(J,0)) + I $G(OUTPT),$L($G(ORDIALOG(PI,1))) D + . S J=$O(^TMP("ORWORD",$J,PI,1,0)) Q:'J + . S I=I+1,ORMSG(I)="NTE|7|P|"_$G(^TMP("ORWORD",$J,PI,1,J,0)) + . S K=0 F S J=$O(^TMP("ORWORD",$J,PI,1,J)) Q:J'>0 S K=K+1,ORMSG(I,K)=$G(^(J,0)) +UD3 S J=0 F S J=$O(ORDIALOG(ROUTE,J)) Q:J'>0 S I=I+1,ORMSG(I)=$$RXR($G(ORDIALOG(ROUTE,J))) + I $D(^OR(100,IFN,9)) D ORDCHKS + S I=I+1,ORMSG(I)=$$ZRX(IFN) + I $G(OUTPT) D ;add SC data + . N OR5 S OR5=$G(^OR(100,IFN,5)) + . I $L(OR5),OR5'?5"^" S I=I+1,ORMSG(I)="ZSC|"_$TR(OR5,"^","|") Q + . S SC=$$PTR("SERVICE CONNECTED") S:$D(ORDIALOG(SC,1)) I=I+1,ORMSG(I)="ZSC|"_$S(ORDIALOG(SC,1):"SC",1:"NSC") + ; Create DG1 & ZCL segment(s) for Billing Awareness (BA) Project + D DG1^ORWDBA3($G(IFN),"I",I) + I $P(^ORD(100.98,$P(OR0,U,11),0),U)="NON-VA MEDICATIONS" D + . S I=I+1 D ZRN(IFN,.ORMSG,I) + Q + ; +INSTR() ; -- Return text instructions for QT-8, instance I + N Y S Y=$P($G(ORDIALOG(DOSE,I)),"&",5) + I $G(ORDIALOG(DRUG,1)),$L(Y) Q Y + S Y=$G(ORDIALOG(INSTR,I)) I $G(OUTPT) D + . N UNITS,UNT S UNITS=$$PTR("FREE TEXT"),UNT=$G(ORDIALOG(UNITS,I)) + . S:$L(UNT) Y=Y_" "_UNT ;old format + Q Y + ; +HL7DUR() ; -- Returns HL7 form of duration X + N X,X1,X2,Y S X=$G(ORDIALOG(DUR,I)) + S X1=+$G(X),Y="" G:X1'>0 HDQ + S X2=$$UP^XLFSTR($P(X,X1,2)) S:$E(X2)=" " X2=$E(X2,2,99) + S Y=$S($E(X2,1,2)="MO":"L",'$L(X2):"D",1:$E(X2))_X1 +HDQ Q Y + ; +IV ; -- new IV Meds order + N SOLN,VOL,ADDS,STR,UNITS,RATE,URG,WP,QT,I,X1,X2,INST + N IVLIMIT ; duratioin or total volume for IV order + S IVLIMIT=$$PTR("DURATION") + S RATE=$$PTR("INFUSION RATE"),ADDS=$$PTR("ADDITIVE") + S STR=$$PTR("STRENGTH PSIV"),UNITS=$$PTR("UNITS") + S WP=$$PTR("WORD PROCESSING 1"),VOL=$$PTR("VOLUME") + S SOLN=$$PTR("ORDERABLE ITEM"),URG=+$G(ORDIALOG($$PTR("URGENCY"),1)) + S QT=U_$G(ORDIALOG(+$$PTR("SCHEDULE"),1))_"^^^^" + S:URG QT=QT_$P($G(^ORD(101.42,URG,0)),U,2) S $P(ORMSG(4),"|",8)=QT + S X=$G(^OR(100,IFN,8,1,0)) I $P(X,U,5),$P(X,U,5)'=$P(X,U,3) S $P(ORMSG(4),"|",13)=$P(X,U,5) ; Send signer instead of orderer if different + S RATE=$G(ORDIALOG(RATE,1)) S:$E(RATE,$L(RATE))=" " RATE=$E(RATE,1,($L(RATE)-1)) S ORMSG(5)="RXO|^^^PS-1^IV^99OTH|"_RATE ;strip any trailing spaces + S IVLIMIT=$G(ORDIALOG(IVLIMIT,1)) + I $L(IVLIMIT) S IVLIMIT=$$HL7IVLMT(IVLIMIT),ORMSG(5)="RXO|^^"_IVLIMIT_"^PS-1^IV^99OTH|"_RATE + S I=5 I $L($G(ORDIALOG(WP,1))) D + . N J,K S J=$O(^TMP("ORWORD",$J,WP,1,0)) Q:'J + . S I=6,ORMSG(6)="NTE|6|P|"_$G(^TMP("ORWORD",$J,WP,1,J,0)) + . S K=0 F S J=$O(^TMP("ORWORD",$J,WP,1,J)) Q:J'>0 S K=K+1,ORMSG(6,K)=^(J,0) +IV1 S INST=0 F S INST=$O(ORDIALOG(SOLN,INST)) Q:INST'>0 D + . S X1="B",X2=+$G(ORDIALOG(SOLN,INST)) + . I $P($G(^ORD(101.43,X2,"PS")),U,4) S X1=X1_"A" ;pre-mix + . S I=I+1,ORMSG(I)="RXC|"_X1_"|"_$$USID^ORMBLD(X2)_"|"_$G(ORDIALOG(VOL,INST))_"|"_$$HL7UNIT("ML") + I $O(ORDIALOG(ADDS,0)) D + . S INST=0 F S INST=$O(ORDIALOG(ADDS,INST)) Q:INST'>0 D + . . S X1=$G(ORDIALOG(ADDS,INST)),X2=$G(ORDIALOG(UNITS,INST)) + . . S I=I+1,ORMSG(I)="RXC|A|"_$$USID^ORMBLD(X1)_"|"_$G(ORDIALOG(STR,INST))_"|"_$$HL7UNIT(X2) + I $D(^OR(100,IFN,9)) D ORDCHKS + S I=I+1,ORMSG(I)=$$ZRX(IFN) + ; Create DG1 & ZCL segment(s) for Billing Awareness (BA) Project + D DG1^ORWDBA3($G(IFN),"I",I) + Q + ; +RXR(ROUTE) ; -- Returns RXR segment + N NAME S NAME=$$GET1^DIQ(51.2,+ROUTE_",",.01) + Q "RXR|^^^"_+ROUTE_U_NAME_"^99PSR" + ; +ZRX(IFN) ; -- Returns ZRX segment + N NATURE,TYPE,ORIG,PSORIG,ZRX + S TYPE=$P($G(^OR(100,IFN,3)),U,11),NATURE=$P($G(^(8,1,0)),U,12) + S:NATURE NATURE=$P($G(^ORD(100.02,+NATURE,0)),U,2) ;code + S PSORIG="" I (TYPE=1)!(TYPE=2) D + . S ORIG=$P($G(^OR(100,IFN,3)),U,5),PSORIG=$G(^OR(100,+ORIG,4)) + . I PSORIG'>0 S PSORIG="",TYPE=0 ;edit of unreleased order + S ZRX="ZRX|"_PSORIG_"|"_NATURE_"|"_$S(TYPE=1:"E",TYPE=2:"R",1:"N") + I $G(OUTPT) S ZRX=ZRX_"|"_$G(ORDIALOG($$PTR("ROUTING"),1))_$S($L($P($G(^OR(100,ORIFN,8,1,2)),"^",3)):"|||1",1:"") + Q ZRX + ; +ZRN(IFN,ORMSG,I) ; -- Set ZRN segment + N ST,ZRN,J,K,TXT + S ORMSG(I)="ZRN|N|" + S ST=$$PTR("STATEMENTS") + I $L($G(ORDIALOG(ST,1))) D + . S J=$O(^TMP("ORWORD",$J,ST,1,0)) Q:'J + . S K=0,TXT=$G(^TMP("ORWORD",$J,ST,1,J,0)) + . I $L(TXT) S K=K+1,ORMSG(I,K)=TXT + . F S J=$O(^TMP("ORWORD",$J,ST,1,J)) Q:J'>0 S TXT=$G(^(J,0)) D + . . I $L(TXT) S K=K+1,ORMSG(I,K)=TXT + Q + ; +ORDCHKS ; -- Include order checks in OBX segments + N OC,X,X1 S OC=0 + F S OC=$O(^OR(100,IFN,9,OC)) Q:OC'>0 S X=$G(^(OC,0)),X1=$G(^(1)) D + . S I=I+1,ORMSG(I)="OBX|"_OC_"|TX|^^^"_+X_"^^99OCX||"_$S($L(X1):X1,1:$P(X,U,3))_"|||||||||"_$$FMTHL7^XLFDT($P(X,U,6))_"||"_$P(X,U,5) + . I $L($P(X,U,4)) S I=I+1,ORMSG(I)="NTE|"_OC_"|P|"_$P(X,U,4) + Q + ; +HL7UNIT(X) ; -- Return coded element for volume/strength units + N I,UNIT,Y + F I=1:1:$L(X) I $E(X,I)?1A Q ; first letter + S UNIT=$$UP^XLFSTR($E(X,I,$L(X))),Y="" + F I=1:1:13 S X=$P("ML^LITER^MCG^MG^GM^UNITS^IU^MEQ^MM^MU^THOUU^MG-PE^NANOGRAM","^",I) I UNIT=X S Y="^^^PSIV-"_I_U_UNIT_"^99OTH" Q + Q Y + ; +HL7TIME(X) ; -- Return HL7 formatted duration + N I,Y S Y="" + F I=1:1:$L(X) I $E(X,I)?1A S Y=$$UP^XLFSTR($E(X,I)) Q ; first letter + S Y=Y_+X + Q Y + ; +VER(IFN) ; -- Send msg for nurse-verified orders + N OR0,ORMSG S OR0=$G(^OR(100,+IFN,0)) Q:$P(OR0,U,12)'="I" ;Inpt only + S ORMSG(1)=$$MSH^ORMBLD("ORM","PS"),ORMSG(2)=$$PID^ORMBLD($P(OR0,U,2)) + S ORMSG(3)=$$PV1^ORMBLD($P(OR0,U,2),$P(OR0,U,12),+$P(OR0,U,10)) + S ORMSG(4)="ORC|ZV|"_IFN_"^OR|"_$G(^OR(100,+IFN,4))_"^PS||||||||"_DUZ_"||||"_$$FMTHL7^XLFDT($$NOW^XLFDT) + D MSG^XQOR("OR EVSEND PS",.ORMSG) + Q + ; +REF(IFN,ROUTING,CLINIC) ; -- Send msg for refill request + N OR0,ORMSG S OR0=$G(^OR(100,+IFN,0)) Q:$P(OR0,U,12)'="O" + S:'$G(CLINIC) CLINIC=$S($G(ORL):+ORL,1:+$P(OR0,U,10)) + S ORMSG(1)=$$MSH^ORMBLD("ORM","PS"),ORMSG(2)=$$PID^ORMBLD($P(OR0,U,2)) + S ORMSG(3)=$$PV1^ORMBLD($P(OR0,U,2),"O",CLINIC) + S ORMSG(4)="ORC|ZF|"_IFN_"^OR|"_$G(^OR(100,+IFN,4))_"^PS|||||||"_DUZ_"||"_$G(ORNP)_"|||"_$$FMTHL7^XLFDT($$NOW^XLFDT) + S ORMSG(5)="ZRX||||"_ROUTING + D MSG^XQOR("OR EVSEND PS",.ORMSG) + Q +HL7IVLMT(STR) ; + N VAL,UNIT,IVLMT,TVAL,LEN + S (UNIT,IVLMT)="",VAL=0 + I $E($$LOW^XLFSTR(STR))="f" D + . S VAL=$P(STR," ",2) + . S UNIT=$E($P(STR," ",3)) + I $E($$LOW^XLFSTR(STR))="w" D + . S TVAL=$P(STR," ",4) ;pull data in total example 0.5ml + . S VAL=+TVAL ;this will strip out leading zero and alpha 00.5L becomes .5 or 05.5 becomes 5.5 + . S LEN=$F(TVAL,VAL) ;get length up to alphas or trailing zeros + . I $P(VAL,".")="" S VAL=0_VAL ;make sure decimal values have only one leading zero .5 becomes 0.5. + . F S UNIT=$E(TVAL,LEN) Q:((UNIT'=0)&(UNIT'=".")) D ;get first alpha m or l + . . S LEN=LEN+1 + I $L(UNIT),$L(VAL) S IVLMT=$$LOW^XLFSTR(UNIT)_VAL + Q IVLMT + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMBLDRA.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMBLDRA.m index 7279b6e1..f0f35dad 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMBLDRA.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMBLDRA.m @@ -1,48 +1,40 @@ -ORMBLDRA ; SLC/MKB - Build outgoing Radiology ORM msgs ;05/30/06 11:30AM - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**75,97,190,195,243**;Dec 17, 1997;Build 242 -HL7DATE(DATE) ; -- FM -> HL7 format - Q $$FMTHL7^XLFDT(DATE) ;**97 - ; -PTR(NAME) ; -- Returns ptr value of prompt in Dialog file - Q $O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0)) - ; -EN ; -- Segments for new Radiology order - N ORSEX,OI,START,IP,URG,ILOC,MODE,CATG,PREOP,PREG,MODS,CLHIST,PROV,REASON,QT,I,J,Z,J0,LIN,RA75 - S OI=$G(ORDIALOG($$PTR("ORDERABLE ITEM"),1)) - S START=$P($G(^OR(100,IFN,0)),U,8),IP=$G(ORDIALOG($$PTR("YES/NO"),1)) - S URG=$P($G(^ORD(101.42,+$G(ORDIALOG($$PTR("URGENCY"),1)),0)),U,2) - S ILOC=$G(ORDIALOG($$PTR("IMAGING LOCATION"),1)) - S MODE=$G(ORDIALOG($$PTR("MODE OF TRANSPORT"),1)) - S CATG=$G(ORDIALOG($$PTR("CATEGORY"),1)) - S PREOP=$G(ORDIALOG($$PTR("PRE-OP SCHEDULED DATE/TIME"),1)) - S PREG=$G(ORDIALOG($$PTR("PREGNANT"),1)) - S REASON=$G(ORDIALOG($$PTR("STUDY REASON"),1)) - S MODS=$$PTR("MODIFIERS"),CLHIST=$$PTR("WORD PROCESSING 1") - S MODS=$$MULT(MODS) S:ILOC ILOC=ILOC_U_$P($G(^RA(79.1,+ILOC,0)),U) - S MODE=$S(MODE="A":"WALK",MODE="P":"PORT",MODE="S":"CART",1:"WHLC") - S PREG=$S(PREG="Y":"YES",PREG="N":"NO",1:"UNKNOWN") - S QT="^^^"_$$HL7DATE(START)_"^^"_URG,$P(ORMSG(4),"|",8)=QT - S PROV=+$G(ORDIALOG($$PTR("PROVIDER"),1)) S:PROV $P(ORMSG(4),"|",12)=PROV - S RA75=$$PATCH^XPDUTL("RA*5.0*75") - S ORMSG(5)="OBR||||"_$$USID^ORMBLD(OI)_"||||||||"_$S(IP:"isolation",1:"")_"||||||"_MODS_"|"_ILOC_"|||||||||||"_MODE,I=5 - I +RA75 S $P(ORMSG(5),"|",32)=U_REASON - ; Create DG1 & ZCL segment(s) for Billing Awareness (BA) Project - D DG1^ORWDBA3($G(IFN),"I",I) -OBX S J0=0 - I 'RA75 D - . S I=I+1,ORMSG(I)="OBX|1|TX|2000.02^CLINICAL HISTORY^AS4|1|"_"REASON FOR STUDY: "_REASON - . S $P(LIN,"-",55)="" - . S I=I+1,ORMSG(I)="OBX|2|TX|2000.02^CLINICAL HISTORY^AS4|1|"_LIN - . S J0=2 - S J=0 F S J=$O(^TMP("ORWORD",$J,CLHIST,1,J)) Q:J'>0 S I=I+1,J0=J0+1,ORMSG(I)="OBX|"_J0_"|TX|2000.02^CLINICAL HISTORY^AS4|1|"_^(J,0) - S ORSEX=$P($G(^DPT(+ORVP,0)),U,2) - S:ORSEX="F" I=I+1,ORMSG(I)="OBX|1|TX|2000.33^PREGNANT^AS4||"_PREG - S:PREOP I=I+1,ORMSG(I)="OBX|1|TS|^PRE-OP SCHEDULED DATE/TIME||"_$$HL7DATE(PREOP) - I "CS"[CATG S Z=$$PTR("CONTRACT/SHARING SOURCE"),I=I+1,ORMSG(I)="OBX|1|CE|34^CONTRACT/SHARING SOURCE^99DD||"_+$G(ORDIALOG(Z,1))_U_$P($G(^DIC(34,+$G(ORDIALOG(Z,1)),0)),U) - I CATG="R" S Z=$$PTR("RESEARCH SOURCE"),I=I+1,ORMSG(I)="OBX|1|TX|^RESEARCH SOURCE||"_$G(ORDIALOG(Z,1)) - Q -MULT(M) ; -- Returns string of MODIFIER~MODIFIER~... - N I,X S X="" Q:'$O(ORDIALOG(M,0)) X - S I=$O(ORDIALOG(M,0)),X=$P($G(^RAMIS(71.2,+ORDIALOG(M,I),0)),U) - F S I=$O(ORDIALOG(M,I)) Q:I'>0 S X=X_"~"_$P($G(^RAMIS(71.2,+ORDIALOG(M,I),0)),U) - Q X +ORMBLDRA ; SLC/MKB - Build outgoing Radiology ORM msgs ;11/17/00 11:14 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**75,97,190,195**;Dec 17, 1997 +HL7DATE(DATE) ; -- FM -> HL7 format + Q $$FMTHL7^XLFDT(DATE) ;**97 + ; +PTR(NAME) ; -- Returns ptr value of prompt in Dialog file + Q $O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0)) + ; +EN ; -- Segments for new Radiology order + N ORSEX,OI,START,IP,URG,ILOC,MODE,CATG,PREOP,PREG,MODS,CLHIST,PROV,QT,I,J,Z + S OI=$G(ORDIALOG($$PTR("ORDERABLE ITEM"),1)) + S START=$P($G(^OR(100,IFN,0)),U,8),IP=$G(ORDIALOG($$PTR("YES/NO"),1)) + S URG=$P($G(^ORD(101.42,+$G(ORDIALOG($$PTR("URGENCY"),1)),0)),U,2) + S ILOC=$G(ORDIALOG($$PTR("IMAGING LOCATION"),1)) + S MODE=$G(ORDIALOG($$PTR("MODE OF TRANSPORT"),1)) + S CATG=$G(ORDIALOG($$PTR("CATEGORY"),1)) + S PREOP=$G(ORDIALOG($$PTR("PRE-OP SCHEDULED DATE/TIME"),1)) + S PREG=$G(ORDIALOG($$PTR("PREGNANT"),1)) + S MODS=$$PTR("MODIFIERS"),CLHIST=$$PTR("WORD PROCESSING 1") + S MODS=$$MULT(MODS) S:ILOC ILOC=ILOC_U_$P($G(^RA(79.1,+ILOC,0)),U) + S MODE=$S(MODE="A":"WALK",MODE="P":"PORT",MODE="S":"CART",1:"WHLC") + S PREG=$S(PREG="Y":"YES",PREG="N":"NO",1:"UNKNOWN") + S QT="^^^"_$$HL7DATE(START)_"^^"_URG,$P(ORMSG(4),"|",8)=QT + S PROV=+$G(ORDIALOG($$PTR("PROVIDER"),1)) S:PROV $P(ORMSG(4),"|",12)=PROV + S ORMSG(5)="OBR||||"_$$USID^ORMBLD(OI)_"||||||||"_$S(IP:"isolation",1:"")_"||||||"_MODS_"|"_ILOC_"|||||||||||"_MODE,I=5 + ; Create DG1 & ZCL segment(s) for Billing Awareness (BA) Project + D DG1^ORWDBA3($G(IFN),"I",I) +OBX S J=0 F S J=$O(^TMP("ORWORD",$J,CLHIST,1,J)) Q:J'>0 S I=I+1,ORMSG(I)="OBX|"_J_"|TX|2000.02^CLINICAL HISTORY^AS4|1|"_^(J,0) + S ORSEX=$P($G(^DPT(+ORVP,0)),U,2) + S:ORSEX="F" I=I+1,ORMSG(I)="OBX|1|TX|2000.33^PREGNANT^AS4||"_PREG + S:PREOP I=I+1,ORMSG(I)="OBX|1|TS|^PRE-OP SCHEDULED DATE/TIME||"_$$HL7DATE(PREOP) + I "CS"[CATG S Z=$$PTR("CONTRACT/SHARING SOURCE"),I=I+1,ORMSG(I)="OBX|1|CE|34^CONTRACT/SHARING SOURCE^99DD||"_+$G(ORDIALOG(Z,1))_U_$P($G(^DIC(34,+$G(ORDIALOG(Z,1)),0)),U) + I CATG="R" S Z=$$PTR("RESEARCH SOURCE"),I=I+1,ORMSG(I)="OBX|1|TX|^RESEARCH SOURCE||"_$G(ORDIALOG(Z,1)) + Q + ; +MULT(M) ; -- Returns string of MODIFIER~MODIFIER~... + N I,X S X="" Q:'$O(ORDIALOG(M,0)) X + S I=$O(ORDIALOG(M,0)),X=$P($G(^RAMIS(71.2,+ORDIALOG(M,I),0)),U) + F S I=$O(ORDIALOG(M,I)) Q:I'>0 S X=X_"~"_$P($G(^RAMIS(71.2,+ORDIALOG(M,I),0)),U) + Q X diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMEVNT.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMEVNT.m index 45e30572..3eb91ad5 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMEVNT.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMEVNT.m @@ -1,191 +1,186 @@ -ORMEVNT ;SLC/MKB-Trigger HL7 msg off MAS events ;3/31/04 09:21 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**24,45,70,79,141,165,177,186,195,278,243**;Dec 17, 1997;Build 242 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -EN1 ; -- tasked entry point - Q:'$G(DFN) Q:$D(DGPMPC) Q:DGPMT=4!(DGPMT=5) ;skip lodger mvts - N ZTDESC,ZTIO,ZTRTN,ZTDTH,ZTSAVE,ZTSK,I - S ZTDESC="Auto-DC and/or Release orders on MAS movement",ZTIO="" - S ZTRTN="EN^ORMEVNT",ZTDTH=$H,ZTSAVE("^UTILITY(""DGPM"",$J,")="" - F I="DFN","DGPMDA","DGPMA","DGPMP","DGPMT" S ZTSAVE(I)="" - D ^%ZTLOAD ;D EN^ORYDGPM - Q - ; -EN ; -- main entry point - S:$D(ZTQUEUED) ZTREQ="@" - Q:'$G(DFN) Q:$D(DGPMPC) Q:DGPMT=4!(DGPMT=5) - I '$G(DGPMP) S ^XTMP("OREVENT",DFN,DGPMDA,0)=DT_U_$$FMADD^XLFDT(DT,2)_U_"Event process flag" ;195 - I $G(DGPMP),$D(^XTMP("OREVENT",DFN,DGPMDA)) D EN1 Q ;195 edits processed after new JEH - N XQORQUIT,XQORPOP,DTOUT,DUOUT,DIRUT,DIROUT ;protect protocol context - N VAIP,DONE,ORVP,ORWARD,ORTS,ORL,ORDIV,ORLAST,X,Y,I,ORCURRNT,OREVENT,ORDCRULE,ORACT,ORPRINT - S VAIP("E")=DGPMDA D IN5^VADPT M ORVP=VAIP I '$G(DGPMA) D Q ;deleted - . N LAST,OREVT S LAST=+$O(^ORE(100.2,"ADT",DGPMDA,""),-1) Q:LAST<1 - . S OREVT=+$O(^ORE(100.2,"ADT",DGPMDA,LAST,0)) - . D ACTLOG^OREVNTX(OREVT,"DL") -A ; - S ORVP=+DFN_";DPT(",ORTS=+$G(^DPT(DFN,.103)),ORWARD=$G(^(.1)) - S ORWARD=$S($L(ORWARD):+$O(^DIC(42,"B",ORWARD,0)),1:0) - S ORL=$S(ORWARD:+$G(^DIC(42,ORWARD,44))_";SC(",1:""),ORDIV=$$DIV(+ORL) - S ORLAST("TS")=$$PREVTS,X=+VAIP(15,4) F I="WD","LOC","DIV" S ORLAST(I)="" - S:X ORLAST("WD")=X,Y=+$G(^DIC(42,X,44)),ORLAST("LOC")=Y_";SC(",ORLAST("DIV")=$$DIV(Y) - N OREVNTLK S OREVNTLK="" ;JEH - S ORCURRNT=$$CURRENT,OREVENT=$$PATEVT,ORACT=$S($G(DGPMP):"ED",1:"NW") ; Lock - I OREVENT=-1 D EN1 Q ;195 Can't lock, retry - S OREVNTLK=OREVENT ; save routine copy of ifn JEH - I $G(DGPMP),$D(^ORE(100.2,"ADT",DGPMDA)) D ;edited - . N LAST,OREVT,DA,X,I S LAST=+$O(^ORE(100.2,"ADT",DGPMDA,""),-1) Q:LAST<1 - . S OREVT=+$O(^ORE(100.2,"ADT",DGPMDA,LAST,0)),DA=+$O(^(OREVT,0)) - . S X=$G(^ORE(100.2,OREVT,10,DA,0)) ;last activity on movement - . I $P(X,U,5)=+$G(VAIP(4)),$P(X,U,6)=+$G(VAIP(8)),$P(X,U,7)=+$G(VAIP(5)) S DONE=1 Q ;no change - . I 'OREVENT D ACTLOG^OREVNTX(OREVT,"ED",$$TYPE(DGPMT),1) S DONE=1 - I $G(DONE) D FINISHED Q ; unlock and clean up before quit IFNjeh -B ; - I '$G(DGPMP),ORCURRNT D ;new mvt - autoDC - . I $D(^ORE(100.2,"ADT",DGPMDA)) D Q:$G(DONE) ;ReEntered - .. N LAST,OREVT S DONE=0 - .. S LAST=+$O(^ORE(100.2,"ADT",DGPMDA,""),-1),OREVT=+$O(^(LAST,0)) - .. Q:+ORVP'=+$G(^ORE(100.2,OREVT,0)) ;diff pat -> diff mvt - .. S ORACT="RE",DONE=1 Q:OREVENT ;log on new event instead - .. D ACTLOG^OREVNTX(OREVT,ORACT,$$TYPE(DGPMT),1) - . I DGPMT=3 D COMP("ALG") ;keep until GMRA*4*15 gets out - . S ORDCRULE=$$DCEVT D:ORDCRULE AUTODC^ORMEVNT1(ORDCRULE,$P(DGPMA,U)) - . I DGPMT=1!(DGPMT=2&("^13^40^"[("^"_$P(DGPMA,U,18)_"^"))) I $G(^XTMP("ORDCOBS-"_+ORVP,0)) D REINST ;186 TO ASIH tran mvmt -C ; - I OREVENT D ;release delayed orders, complete event - . D RELEASE^ORMEVNT1(OREVENT),DONE^OREVNTX(OREVENT,$P(DGPMA,U),DGPMDA) - . I '$G(VAIP(1)) M VAIP=ORVP ;reset for ACTLOG use - . D ACTLOG^OREVNTX(OREVENT,ORACT,$$TYPE(DGPMT),1) - . I DGPMT=1,'$P($G(^ORE(100.2,+OREVENT,0)),U,3) S $P(^(0),U,3)=DGPMDA - . ;D UNLEVT^ORX2(OREVENT) - I $O(ORPRINT(0)),$G(ORL) D PRINTS^ORWD1(.ORPRINT,+ORL) - I DGPMT=3,ORCURRNT,'$G(DGPMP) D DISCH ;lapse remaining events - I '$G(DFN),$G(ORVP) S DFN=+ORVP ;just in case -FINISHED ; unlock and clean up JEH - D:$G(OREVNTLK) UNLEVT^ORX2(OREVNTLK) K ^XTMP("OREVENT",DFN,DGPMDA) ;195 - Q - ; -CURRENT() ; -- Returns 1 or 0, if DGPMDA is the latest movement - N Y,LAST,LASTYPE,LASTDT S Y=0 - S LAST=+VAIP(14),LASTDT=+VAIP(14,1),LASTYPE=+VAIP(14,2) - ; VAIP(14) = last physical movement for the admission - I DGPMT=6 D G CQ - . N CA,IDT I LAST,LASTDT>+VAIP(3) Q ;last physical mvt - . S CA=+VAIP(13),IDT=9999999.9999999-VAIP(3) - . I '$O(^DGPM("ATS",DFN,CA,IDT),-1) S Y=1 Q ;last TS mvt - I DGPMT=3 D ;get last mvt overall - . N VAIP,Y S VAIP("D")="LAST" D IN5^VADPT - . S LAST=+VAIP(14),LASTYPE=+VAIP(14,2) ;reset - I LAST=DGPMDA S Y=1 G CQ ;primary mvt - I $D(^UTILITY("DGPM",$J,LASTYPE,LAST)) S Y=1 ;secondary mvt -CQ Q Y - ; -PREVTS() ; -- Returns previous treating specialty - N TS,TSP,CA,ID,LAST,Y - S TS=+$O(^UTILITY("DGPM",$J,6,0)),TSP=$G(^(TS,"P")) - I $G(TSP) S Y=+$P(TSP,U,9) G PRVQ ;edited TS mvt - ; look for TS mvt since last phys mvt - S CA=$P(DGPMA,U,14),ID=9999999.9999999-DGPMA - S LAST=+$O(^DGPM("ATS",DFN,CA,ID)),Y=$S(LAST:+$O(^(LAST,0)),1:+VAIP(15,6)) -PRVQ Q Y - ; -TYPE(X) ; -- Return type of event from MAS code - N Y S Y=$S(X=1:"A",X=2:"T",X=3:"D",X=6:"S",1:"") - Q Y - ; -DIV(LOC) ; -- Return Institution file #4 ptr for LOC - N X0,Y S X0=$G(^SC(+LOC,0)) - S Y=$S($P(X0,U,4):$P(X0,U,4),$P(X0,U,15):$$SITE^VASITE(DT,$P(X0,U,15)),1:+$G(DUZ(2))) - Q Y - ; -PATEVT() ; -- Find match to new data in Patient Event file - N TYPE,MVTYPE,EVT,IFN,X0,Y S Y="" G:'$G(ORCURRNT) PTQ - S TYPE=$S(DGPMT=1:"A",DGPMT=3:"D",DGPMT=2!(DGPMT=6):"T",1:""),EVT=0 - S MVTYPE=$P(DGPMA,U,18),TYPE(1)="",MVTYPE(1)="" - I DGPMT=2,MVTYPE=13 S TYPE(1)="A",MVTYPE(1)=40 ;To ASIH - I DGPMT=3,MVTYPE=41 S TYPE(1)="T",MVTYPE(1)=14 ;From ASIH - I DGPMT'=3,$$GET1^DIQ(45.7,+$G(ORTS)_",","SPECIALTY:SERVICE")="NHCU" S TYPE(1)=$S(TYPE="A":"T",1:"A") ;DBIA #1154 - F S EVT=+$O(^ORE(100.2,"AE",DFN,EVT)) Q:EVT<1 S IFN=+$O(^(EVT,0)) D Q:Y - . Q:$$LAPSED^OREVNTX(+IFN) Q:$P($G(^ORE(100.2,IFN,1)),U,5) - . S X0=$G(^ORD(100.5,EVT,0)) Q:$P(X0,U,3)'=ORDIV - . I $P(X0,U,2)'=TYPE,$P(X0,U,2)'=TYPE(1) Q ;Xaction type - . I $P(X0,U,7),$P(X0,U,7)'=MVTYPE,$P(X0,U,7)'=MVTYPE(1) Q ;Mvt type - . I $O(^ORD(100.5,EVT,"TS",0)) Q:'$D(^("B",ORTS)) Q:ORTS=ORLAST("TS")&(ORDIV=ORLAST("DIV")) - . I $O(^ORD(100.5,EVT,"LOC",0)) Q:'$D(^("B",ORWARD)) Q:ORWARD=ORLAST("WD") - . S Y=+IFN ;ok - I Y S:'$$LCKEVT^ORX2(Y) Y=-1 ;195 Lock event if possible -PTQ Q Y - ; -DCEVT() ; -- Find match to event in AutoDC Rules file for [new] ORDIV,ORTS,ORL - N MVTYPE,DIV,XFER,ORY,EXC,OBS - S OBS=$S(DGPMT=3:$$MVT^DGPMOBS(DGPMDA),1:0) ;observation mvt - S MVTYPE=+$P(DGPMA,U,18) S:MVTYPE=41 MVTYPE=14 S:MVTYPE=40 MVTYPE=13 ;ASIH- 186 - S XFER=$S(DGPMT=2:1,DGPMT=6:1,MVTYPE'=14:0,OBS:0,1:1) - I DGPMT=2,MVTYPE=13,$G(^XTMP("ORDCOBS-"_+ORVP,"READMIT")) S ORY=0 K ^XTMP("ORDCOBS-"_+ORVP,"READMIT") G DCQ ;186 Obs readmit from ASIH don't auto-dc - I XFER,ORLAST("TS")'=ORTS,$D(^ORD(100.6,"AC",ORDIV,20)) S MVTYPE=20 ;TS - S DIV=ORDIV I DGPMT=3,MVTYPE'=14 S DIV=ORLAST("DIV") ;discharge - S ORY=+$O(^ORD(100.6,"AC",ORDIV,MVTYPE,0)) K:ORY<1&(DGPMT=3)&(OBS) ^XTMP("ORDCOBS-"_+ORVP) G:ORY<1 DCQ ;186, If obs, no active rule, no reinstate - I MVTYPE=20,$D(^ORD(100.6,ORY,4,ORLAST("TS"),1,ORTS))!(ORTS=ORLAST("TS")) S ORY=0 G DCQ - I MVTYPE=4 D G DCQ ;ck Div and Loc multiples - . I ORLAST("DIV")'=ORDIV S:'$D(^ORD(100.6,ORY,6,ORLAST("DIV"))) ORY=0 Q - . N OLD,INCL S INCL=0 ;ck incl loc's - . F OLD=+ORLAST("LOC"),"ALL" I $D(^ORD(100.6,ORY,5,"ADC",OLD,+ORL))!$D(^("ALL")) S INCL=1 Q - . S:'INCL ORY=0 - I DGPMT=3,OBS D ;readmitting from observation? - . N TORY - . S TORY=ORY - . S EXC=+$P($G(^ORD(100.6,ORY,0)),U,6) S:EXC=2 ORY=0 ;ignore rule - . I EXC=1,'$D(ZTQUEUED),$$READMIT S ORY=0 - . I ORY=0 D DCGEN^ORMEVNT2,TIMER^ORMEVNT2 S:"^14^41^"[("^"_$P(DGPMA,U,18)_"^") ^XTMP("ORDCOBS-"_+ORVP,"READMIT")=1 ;177,186 - . K:ORY ^XTMP("ORDCOBS-"_+ORVP) ;have rule -> dc, don't reinstate meds -DCQ Q ORY - ; -READMIT() ; -- Return 1 or 0, if patient is being readmitted - N X,Y,DIR - S DIR(0)="YA",DIR("A")="Will the patient be re-admitted immediately? " - S DIR("?")="Enter YES if the patient is to be admitted to the hospital immediately following this discharge from observation." - D ^DIR S:$D(DTOUT)!$D(DUOUT) Y="^" - Q Y - ; -COMP(ORDG) ; -- Complete orders on event [Keep until GMRA*4*15] - N ORI,ORLIST,ORIFN,OREDT - I 'ORDG S:ORDG?1.U ORDG=+$O(^ORD(100.98,"B",ORDG,0)) Q:ORDG'>0 - D EN^ORQ1(ORVP,ORDG,2) S ORI=0,OREDT=$P(DGPMA,U) - F S ORI=$O(^TMP("ORR",$J,ORLIST,ORI)) Q:ORI'>0 S ORIFN=^(ORI) D STATUS^ORCSAVE2(+ORIFN,2) S:$G(OREDT) $P(^OR(100,+ORIFN,3),U)=OREDT,$P(^(6),U,6)=OREDT - Q - ; -LOC(NODE) ; -- Returns [new] patient location from NODE - N X,Y S X=$P($G(NODE),U,6) - I X'>0 S X=$P($G(^DPT(+ORVP,.1)),U) S:$L(X) X=$O(^DIC(42,"B",X,0)) - S Y=+$G(^DIC(42,+X,44))_";SC(" - Q Y - ; -DISCH ; -- Lapse/cancel outstanding events on discharge - D DISCH^ORMEVNT2 ;195 Code moved to ORMEVNT2 for space considerations - Q - ; -XTMP ; -- Save ORIFN to possibly reinstate on admission - ; Also uses ORVP, DGPMDA - Q:'$G(DGPMDA) Q:'$G(ORIFN) Q:'$G(ORVP) - N ORNOW S ORNOW=+$$NOW^XLFDT - I $G(^XTMP("ORDCOBS-"_+ORVP,0)),+^(0) diff mvt + .. S ORACT="RE",DONE=1 Q:OREVENT ;log on new event instead + .. D ACTLOG^OREVNTX(OREVT,ORACT,$$TYPE(DGPMT),1) + . I DGPMT=3 D COMP("ALG") ;keep until GMRA*4*15 gets out + . S ORDCRULE=$$DCEVT D:ORDCRULE AUTODC^ORMEVNT1(ORDCRULE,$P(DGPMA,U)) + . I DGPMT=1!(DGPMT=2&("^13^40^"[("^"_$P(DGPMA,U,18)_"^"))) I $G(^XTMP("ORDCOBS-"_+ORVP,0)) D REINST ;186 TO ASIH tran mvmt +C ; + I OREVENT D ;release delayed orders, complete event + . D RELEASE^ORMEVNT1(OREVENT),DONE^OREVNTX(OREVENT,$P(DGPMA,U),DGPMDA) + . I '$G(VAIP(1)) M VAIP=ORVP ;reset for ACTLOG use + . D ACTLOG^OREVNTX(OREVENT,ORACT,$$TYPE(DGPMT),1) + . I DGPMT=1,'$P($G(^ORE(100.2,+OREVENT,0)),U,3) S $P(^(0),U,3)=DGPMDA + . ;D UNLEVT^ORX2(OREVENT) + I $O(ORPRINT(0)),$G(ORL) D PRINTS^ORWD1(.ORPRINT,+ORL) + I DGPMT=3,ORCURRNT,'$G(DGPMP) D DISCH ;lapse remaining events + I '$G(DFN),$G(ORVP) S DFN=+ORVP ;just in case + D:$G(OREVENT) UNLEVT^ORX2(OREVENT) K ^XTMP("OREVENT",DFN,DGPMDA) ;195 + Q + ; +CURRENT() ; -- Returns 1 or 0, if DGPMDA is the latest movement + N Y,LAST,LASTYPE,LASTDT S Y=0 + S LAST=+VAIP(14),LASTDT=+VAIP(14,1),LASTYPE=+VAIP(14,2) + ; VAIP(14) = last physical movement for the admission + I DGPMT=6 D G CQ + . N CA,IDT I LAST,LASTDT>+VAIP(3) Q ;last physical mvt + . S CA=+VAIP(13),IDT=9999999.9999999-VAIP(3) + . I '$O(^DGPM("ATS",DFN,CA,IDT),-1) S Y=1 Q ;last TS mvt + I DGPMT=3 D ;get last mvt overall + . N VAIP,Y S VAIP("D")="LAST" D IN5^VADPT + . S LAST=+VAIP(14),LASTYPE=+VAIP(14,2) ;reset + I LAST=DGPMDA S Y=1 G CQ ;primary mvt + I $D(^UTILITY("DGPM",$J,LASTYPE,LAST)) S Y=1 ;secondary mvt +CQ Q Y + ; +PREVTS() ; -- Returns previous treating specialty + N TS,TSP,CA,ID,LAST,Y + S TS=+$O(^UTILITY("DGPM",$J,6,0)),TSP=$G(^(TS,"P")) + I $G(TSP) S Y=+$P(TSP,U,9) G PRVQ ;edited TS mvt + ; look for TS mvt since last phys mvt + S CA=$P(DGPMA,U,14),ID=9999999.9999999-DGPMA + S LAST=+$O(^DGPM("ATS",DFN,CA,ID)),Y=$S(LAST:+$O(^(LAST,0)),1:+VAIP(15,6)) +PRVQ Q Y + ; +TYPE(X) ; -- Return type of event from MAS code + N Y S Y=$S(X=1:"A",X=2:"T",X=3:"D",X=6:"S",1:"") + Q Y + ; +DIV(LOC) ; -- Return Institution file #4 ptr for LOC + N X0,Y S X0=$G(^SC(+LOC,0)) + S Y=$S($P(X0,U,4):$P(X0,U,4),$P(X0,U,15):$$SITE^VASITE(DT,$P(X0,U,15)),1:+$G(DUZ(2))) + Q Y + ; +PATEVT() ; -- Find match to new data in Patient Event file + N TYPE,MVTYPE,EVT,IFN,X0,Y S Y="" G:'$G(ORCURRNT) PTQ + S TYPE=$S(DGPMT=1:"A",DGPMT=3:"D",DGPMT=2!(DGPMT=6):"T",1:""),EVT=0 + S MVTYPE=$P(DGPMA,U,18),TYPE(1)="",MVTYPE(1)="" + I DGPMT=2,MVTYPE=13 S TYPE(1)="A",MVTYPE(1)=40 ;To ASIH + I DGPMT=3,MVTYPE=41 S TYPE(1)="T",MVTYPE(1)=14 ;From ASIH + I DGPMT'=3,$$GET1^DIQ(45.7,+$G(ORTS)_",","SPECIALTY:SERVICE")="NHCU" S TYPE(1)=$S(TYPE="A":"T",1:"A") ;DBIA #1154 + F S EVT=+$O(^ORE(100.2,"AE",DFN,EVT)) Q:EVT<1 S IFN=+$O(^(EVT,0)) D Q:Y + . Q:$$LAPSED^OREVNTX(+IFN) Q:$P($G(^ORE(100.2,IFN,1)),U,5) + . S X0=$G(^ORD(100.5,EVT,0)) Q:$P(X0,U,3)'=ORDIV + . I $P(X0,U,2)'=TYPE,$P(X0,U,2)'=TYPE(1) Q ;Xaction type + . I $P(X0,U,7),$P(X0,U,7)'=MVTYPE,$P(X0,U,7)'=MVTYPE(1) Q ;Mvt type + . I $O(^ORD(100.5,EVT,"TS",0)) Q:'$D(^("B",ORTS)) Q:ORTS=ORLAST("TS")&(ORDIV=ORLAST("DIV")) + . I $O(^ORD(100.5,EVT,"LOC",0)) Q:'$D(^("B",ORWARD)) Q:ORWARD=ORLAST("WD") + . S Y=+IFN ;ok + I Y S:'$$LCKEVT^ORX2(Y) Y=-1 ;195 Lock event if possible +PTQ Q Y + ; +DCEVT() ; -- Find match to event in AutoDC Rules file for [new] ORDIV,ORTS,ORL + N MVTYPE,DIV,XFER,ORY,EXC,OBS + S OBS=$S(DGPMT=3:$$MVT^DGPMOBS(DGPMDA),1:0) ;observation mvt + S MVTYPE=+$P(DGPMA,U,18) S:MVTYPE=41 MVTYPE=14 S:MVTYPE=40 MVTYPE=13 ;ASIH- 186 + S XFER=$S(DGPMT=2:1,DGPMT=6:1,MVTYPE'=14:0,OBS:0,1:1) + I DGPMT=2,MVTYPE=13,$G(^XTMP("ORDCOBS-"_+ORVP,"READMIT")) S ORY=0 K ^XTMP("ORDCOBS-"_+ORVP,"READMIT") G DCQ ;186 Obs readmit from ASIH don't auto-dc + I XFER,ORLAST("TS")'=ORTS,$D(^ORD(100.6,"AC",ORDIV,20)) S MVTYPE=20 ;TS + S DIV=ORDIV I DGPMT=3,MVTYPE'=14 S DIV=ORLAST("DIV") ;discharge + S ORY=+$O(^ORD(100.6,"AC",ORDIV,MVTYPE,0)) K:ORY<1&(DGPMT=3)&(OBS) ^XTMP("ORDCOBS-"_+ORVP) G:ORY<1 DCQ ;186, If obs, no active rule, no reinstate + I MVTYPE=20,$D(^ORD(100.6,ORY,4,ORLAST("TS"),1,ORTS))!(ORTS=ORLAST("TS")) S ORY=0 G DCQ + I MVTYPE=4 D G DCQ ;ck Div and Loc multiples + . I ORLAST("DIV")'=ORDIV S:'$D(^ORD(100.6,ORY,6,ORLAST("DIV"))) ORY=0 Q + . N OLD,INCL S INCL=0 ;ck incl loc's + . F OLD=+ORLAST("LOC"),"ALL" I $D(^ORD(100.6,ORY,5,"ADC",OLD,+ORL))!$D(^("ALL")) S INCL=1 Q + . S:'INCL ORY=0 + I DGPMT=3,OBS D ;readmitting from observation? + . N TORY + . S TORY=ORY + . S EXC=+$P($G(^ORD(100.6,ORY,0)),U,6) S:EXC=2 ORY=0 ;ignore rule + . I EXC=1,'$D(ZTQUEUED),$$READMIT S ORY=0 + . I ORY=0 D DCGEN^ORMEVNT2,TIMER^ORMEVNT2 S:"^14^41^"[("^"_$P(DGPMA,U,18)_"^") ^XTMP("ORDCOBS-"_+ORVP,"READMIT")=1 ;177,186 + . K:ORY ^XTMP("ORDCOBS-"_+ORVP) ;have rule -> dc, don't reinstate meds +DCQ Q ORY + ; +READMIT() ; -- Return 1 or 0, if patient is being readmitted + N X,Y,DIR + S DIR(0)="YA",DIR("A")="Will the patient be re-admitted immediately? " + S DIR("?")="Enter YES if the patient is to be admitted to the hospital immediately following this discharge from observation." + D ^DIR S:$D(DTOUT)!$D(DUOUT) Y="^" + Q Y + ; +COMP(ORDG) ; -- Complete orders on event [Keep until GMRA*4*15] + N ORI,ORLIST,ORIFN,OREDT + I 'ORDG S:ORDG?1.U ORDG=+$O(^ORD(100.98,"B",ORDG,0)) Q:ORDG'>0 + D EN^ORQ1(ORVP,ORDG,2) S ORI=0,OREDT=$P(DGPMA,U) + F S ORI=$O(^TMP("ORR",$J,ORLIST,ORI)) Q:ORI'>0 S ORIFN=^(ORI) D STATUS^ORCSAVE2(+ORIFN,2) S:$G(OREDT) $P(^OR(100,+ORIFN,3),U)=OREDT,$P(^(6),U,6)=OREDT + Q + ; +LOC(NODE) ; -- Returns [new] patient location from NODE + N X,Y S X=$P($G(NODE),U,6) + I X'>0 S X=$P($G(^DPT(+ORVP,.1)),U) S:$L(X) X=$O(^DIC(42,"B",X,0)) + S Y=+$G(^DIC(42,+X,44))_";SC(" + Q Y + ; +DISCH ; -- Lapse/cancel outstanding events on discharge + D DISCH^ORMEVNT2 ;195 Code moved to ORMEVNT2 for space considerations + Q + ; +XTMP ; -- Save ORIFN to possibly reinstate on admission + ; Also uses ORVP, DGPMDA + Q:'$G(DGPMDA) Q:'$G(ORIFN) Q:'$G(ORVP) + N ORNOW S ORNOW=+$$NOW^XLFDT + I $G(^XTMP("ORDCOBS-"_+ORVP,0)),+^(0)ORLOG:8,1:6) - D STATUS^ORCSAVE2(+ORIFN,ORSTS) - Q - ; -XX ; -- Edited backdoor order (OP recurring meals only) - D XX^ORMFH1 Q - ; -SN ; -- New backdoor order: return NA msg w/ORIFN - N ODS,ODT,OBR,ORDIALOG,X,I,OI,SEG,ORNEW,ORPARAM,ORTIME,ORSTS,ORDG,ORP,ORTRAIL - ;I '$D(^VA(200,+ORNP,0)) S ORERR="Missing or invalid ordering provider"Q - ; Don't require provider until Nature of Order is added - I '$G(DGPMT),'$D(^VA(200,+ORDUZ,0)) S ORERR="Missing or invalid entering person" Q - I 'ORSTRT S ORERR="Missing effective date/time" Q - ;I '$G(ORL) S ORERR="Missing or invalid patient location" Q - D EN1^FHWOR8(ORL,.ORPARAM) - S ODS=$O(@ORMSG@(+ORC)) I 'ODS S ORERR="Incomplete message" Q - S ODS=ODS_U_@ORMSG@(ODS),ORSTS=6 I '$L(ORNATR),ORCAT="I" S ORNATR="S" - I $E($P(ODS,U,2),1,3)="OBR" S OBR=ODS D IP G SN1 - I $E($P(ODS,U,2),1,3)="ODT" S ODT=ODS D TRAY G SN1 - I $E($P(ODS,U,2),1,3)'="ODS" S ORERR="Missing or invalid ODS segment" Q - I $P(ODS,"|",2)="ZE" D TF G SN1 - I $P(ODS,"|",4)?1"^^^FH-6".E D ADDL G SN1 - I ORCAT'="I" D OPM^ORMFH1 G SN1 - I $P(ODS,"|",4)?1"^^^FH-5".E D NPO G SN1 -DIET ; Diet order - S ORDIALOG=$O(^ORD(101.41,"AB","FHW1",0)),ORTRAIL="Diet" - D GETDLG1^ORCD(ORDIALOG) S:ORSTRT>ORLOG ORSTS=8 - S ORDIALOG($$PTR("START DATE/TIME"),1)=ORSTRT - S:ORSTOP ORDIALOG($$PTR("STOP DATE/TIME"),1)=ORSTOP - S X=$P(ODS,"|",2),ORDIALOG($$PTR("DELIVERY"),1)=$S($L(X)=1:X,1:$E(X,2)) - ; Comments ?? - S X=$$ORDITEM^ORM($P(ODS,"|",4)) - I 'X S ORERR="Missing or invalid diet modification" Q - S I=1,OI=$$PTR("ORDERABLE ITEM"),ORDIALOG(OI,I)=X - I $O(@ORMSG@(+ODS)) F S ODS=$O(@ORMSG@(+ODS)) Q:ODS'>0 S SEG=$E(@ORMSG@(+ODS),1,3) Q:SEG="ORC" Q:SEG="MSH" I SEG="ODS" D Q:$D(ORERR) - . S X=$$ORDITEM^ORM($P(@ORMSG@(+ODS),"|",4)) - . I 'X S ORERR="Missing or invalid diet modification" Q - . S I=I+1,ORDIALOG(OI,I)=X -SN1 ; continue ... save order, post message - Q:$D(ORERR) - D EN^ORCSAVE I '$G(ORIFN) S ORERR="Cannot create new order" Q - D RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR),SIGSTS^ORCSAVE2(ORIFN,1) - D:'$P($G(^OR(100,ORIFN,0)),U,8) DATES^ORCSAVE2(ORIFN,ORSTRT,ORSTOP) - D STATUS^ORCSAVE2(ORIFN,ORSTS) - I $G(ORL) S ORP(1)=ORIFN_";1^1" D PRINTS^ORWD1(.ORP,+ORL) ; chart copy - S ^OR(100,ORIFN,4)=PKGIFN - Q - ; -TRAY ; Early/Late tray - I 'ORSTOP S ORERR="Missing stop date" Q - S ORDIALOG=$O(^ORD(101.41,"AB","FHW2",0)) D GETDLG1^ORCD(ORDIALOG),EN2^ORCDFH - S ORDIALOG($$PTR("START DATE"),1)=ORSTRT - S ORDIALOG($$PTR("STOP DATE"),1)=ORSTOP - N DAYS,SCH S DAYS="",SCH=$P(ORQT,U,2) - I $L(SCH),SCH'="ONCE" F I=1:1:$L(SCH,"~") S X=+$P($P(SCH,"~",I),"J",2),DAYS=DAYS_$E("MTWRFSX",X) - S:$L(DAYS) ORDIALOG($$PTR("SCHEDULE"),1)=DAYS - S OI=+$O(^ORD(101.43,"S.E/L T",$P(ODT,"|",2)_" TRAY",0)),ORDIALOG($$PTR("ORDERABLE ITEM"),1)=OI - S X=$P($P(ODT,"|",3),U,4),ORDIALOG($$PTR("MEAL"),1)=$E(X) - S ORDIALOG($$PTR("MEAL TIME"),1)=$P($G(ORTIME(OI,$E(X),+$E(X,3))),U,2) - S:$L($P(ODT,"|",4)) ORDIALOG($$PTR("YES/NO"),1)=1 - Q - ; -IP ; Isolation/Precautions - N IP S IP=+$P($P(OBR,"|",13),U,4) - I IP'>0 S ORERR="Missing or invalid isolation type" Q - S ORDIALOG=$O(^ORD(101.41,"AB","FHW3",0)) D GETDLG1^ORCD(ORDIALOG) - S ORDIALOG($$PTR("ISOLATION TYPE"),1)=IP - S ORDIALOG($$PTR("ORDERABLE ITEM"),1)=$O(^ORD(101.43,"S.PREC","ISOLATION PROCEDURES",0)) - Q - ; -TF ; Tubefeeding - N OI,STR,INSTR,CMMT,I,X,X4,XI,ZQT,QT,QTY,DUR - S ORDIALOG=$O(^ORD(101.41,"AB","FHW8",0)) D GETDLG1^ORCD(ORDIALOG) - S OI=$$PTR("ORDERABLE ITEM"),STR=$$PTR("STRENGTH FH") - S INSTR=$$PTR("INSTRUCTIONS"),CMMT=$$PTR("FREE TEXT 1") - ; Comments ?? - S I=0 F D S ODS=$O(@ORMSG@(+ODS)) Q:ODS'>0 Q:$E(@ORMSG@(ODS),1,3)="ORC" S ODS=ODS_U_@ORMSG@(ODS) - . Q:$E($P(ODS,U,2),1,3)'="ODS" ; not ODS segment - . S X=$P(ODS,"|",4),X4=$P(X,U,4) ; OI - . S:X4["-" $P(X,U,4)=+X4,X4=+$P(X4,"-",2) ; strength - . S XI=$$ORDITEM^ORM(X) I 'XI S ORERR="Missing or invalid tubefeeding product" Q - . S ZQT=$O(@ORMSG@(+ODS)) I 'ZQT S ORERR="Missing QT information" Q - . S QT=$P(@ORMSG@(ZQT),"|",3),DUR=$P(QT,U,3) - . S QTY=+QT_" "_$$UNITS($P($P(QT,U),"&",2))_"/"_$P(QT,U,2) - . S:$L(DUR) QTY=QTY_" X "_+$E(DUR,2,99)_$S($E(DUR)="H":"HR",1:"") - . S I=I+1,ORDIALOG(OI,I)=XI,ORDIALOG(STR,I)=X4,ORDIALOG(INSTR,I)=QTY - . S:$L($P(ODS,"|",5)) ORDIALOG(CMMT,I)=$P(ODS,"|",5) - I ORCAT="O",ORQT["~" D DATES - Q - ; -UNITS(X) ; -- Returns name of unit X - N Y S X=$E(X) - S Y=$S(X="K":"KCAL",X="C":"CC",X="M":"ML",X="O":"OZ",X="U":"UNITS",X="T":"TBSP",X="G":"GM",1:"") - Q Y - ; -NPO ; NPO - S ORDIALOG=$O(^ORD(101.41,"AB","FHW1",0)) D GETDLG1^ORCD(ORDIALOG) - S ORDIALOG($$PTR("ORDERABLE ITEM"),1)=$O(^ORD(101.43,"S.DIET","NPO",0)) - S ORDIALOG($$PTR("START DATE/TIME"),1)=ORSTRT S:ORSTRT>ORLOG ORSTS=8 - S:ORSTOP ORDIALOG($$PTR("STOP DATE/TIME"),1)=ORSTOP - S:$L($P(ODS,"|",5)) ORDIALOG($$PTR("FREE TEXT 1"),1)=$P(ODS,"|",5) - Q - ; -ADDL ; Additional order - S ORDIALOG=$O(^ORD(101.41,"AB","FHW7",0)) D GETDLG1^ORCD(ORDIALOG) - S ORDIALOG($$PTR("FREE TEXT 1"),1)=$P(ODS,"|",5) - I ORCAT="O",ORQT["~" D DATES - Q - ; -DATES ; -- pull dates out of ORQT - N P,I,X S P=$$PTR("DATE/TIME") - F I=1:1:$L(ORQT,"~") S X=$P(ORQT,"~",I),ORDIALOG(P,I)=$$HL7TFM^XLFDT($P(X,U,4)) - S ORSTRT=$G(ORDIALOG(P,1)),ORSTOP=$G(ORDIALOG(P,I)) - Q - ; -SC ; -- Status Change -SR ; -- Status Update [ack] - N ORSTS,OROLD S OROLD=$P($G(^OR(100,+ORIFN,3)),U,3) - D DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP) - S ORSTS=$S(ORDSTS="DC":1,ORDSTS="IP":6,ORDSTS="ZE":7,ORDSTS="SC":8,1:"") - D:ORSTS STATUS^ORCSAVE2(+ORIFN,ORSTS) - I ORDSTS="DC",'$D(^OR(100,+ORIFN,6)) D ;set 6-node - . I ORNATR'="A","DN"[$E(PKGIFN) S ORNATR="C" S:'$L(OREASON) OREASON="Replaced with new diet order" S:ORDUZ<1 ORDUZ="" - . S ^OR(100,+ORIFN,6)=$S($L(ORNATR):+$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORDUZ_U_ORLOG_U_U_OREASON - I OROLD=1,ORSTS=6 D ; reactivate - . N X S $P(^OR(100,+ORIFN,3),U,7)=1,X=$P(^(0),U,9) K ^(6) - . I 'ORSTOP,X S $P(^OR(100,+ORIFN,0),U,9)="" K ^OR(100,"AE",X,+ORIFN) - . D SETALL^ORDD100(+ORIFN) - Q - ; -OC ; -- Cancelled / [ack] - G:ORTYPE="ORR" UA ;rejected new order - I $P($G(^OR(100,+ORIFN,3)),U,3)=6,$P(^(0),U,8) - S ^OR(100,+ORIFN,6)=$S($L(ORNATR):+$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORDUZ_U_ORLOG_U_U_OREASON - D UPDATE(1,"DC") - Q - ; -DR ; -- Discontinued as requested [ack] - D STATUS^ORCSAVE2(+ORIFN,1) - Q - ; -UA ; -- Unable to Accept [ack] - S:'$L(ORNATR) ORNATR="X" ;Rejected - S ^OR(100,+ORIFN,6)=+$O(^ORD(100.02,"C",ORNATR,0))_U_U_ORLOG_U_U_OREASON - D STATUS^ORCSAVE2(+ORIFN,13) -UC ; -- Unable to Cancel [ack] -UD ; -- Unable to Discontinue [ack] - N DA S DA=$P(ORIFN,";",2) I DA D - . S:$G(OREJECT) $P(^OR(100,+ORIFN,8,DA,0),U,15)=13 ; request rejected - . S:$L(OREASON) ^OR(100,+ORIFN,8,DA,1)=OREASON - Q - ; -UPDATE(ORSTS,ORACT) ; -- continue processing - N ORX,DA,ORP D DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP) - D:$G(ORSTS) STATUS^ORCSAVE2(+ORIFN,ORSTS) - S ORX=$$CREATE^ORX1(ORNATR) D:ORX - . S DA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,OREASON,ORLOG,ORDUZ) - . I DA'>0 S ORERR="Cannot create new order action" Q - . D RELEASE^ORCSAVE2(+ORIFN,DA,ORLOG,ORDUZ,ORNATR) - . D SIGSTS^ORCSAVE2(+ORIFN,DA) - . I $G(ORL) S ORP(1)=+ORIFN_";"_DA_"^1" D PRINTS^ORWD1(.ORP,+ORL) - . S $P(^OR(100,+ORIFN,3),U,7)=DA - I ORACT="DC",'$$ACTV^ORX1(ORNATR) S $P(^OR(100,+ORIFN,3),U,7)=0 - D:ORACT="DC" CANCEL^ORCSEND(+ORIFN) - Q - ; -PTR(NAME) ; -- Returns ien of prompt NAME in Order Dialog file #101.41 - Q $O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0)) +ORMFH ;SLC/MKB - Process Dietetics ORM msgs ;5/5/05 13:18 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,73,92,215**;Dec 17, 1997 + ; +EN ; -- entry point for FH messages + I '$L($T(@ORDCNTRL)) Q ;S ORERR="Invalid order control code" Q + I ORDCNTRL'="SN",ORDCNTRL'="ZP",'ORIFN!('$D(^OR(100,+ORIFN,0))) S ORERR="Invalid OE/RR order number" Q + S ORLOG=+$E($$NOW^XLFDT,1,12) S:'$G(ORDUZ) ORDUZ=DUZ S:'$G(ORNP) ORNP=ORDUZ + S:$G(DGPMT) ORNATR="A",OREASON=$S(DGPMT=1:"Admission",DGPMT=3:"Discharge",1:"Transfer"),ORDUZ="" + D @ORDCNTRL + Q + ; +ZP ; -- Purged + Q:'ORIFN Q:'$D(^OR(100,+ORIFN,0)) + K ^OR(100,+ORIFN,4) I "^6^8^"[(U_$P($G(^(3)),U,3)_U) D STATUS^ORCSAVE2(+ORIFN,14) ; Remove pkg reference, sts=lapsed if still active + Q + ; +ZR ; -- Purged as requested [ack] + D DELETE^ORCSAVE2(+ORIFN) + Q + ; +ZU ; -- Unable to purge [ack] + S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ; update Last Activity + Q + ; +OK ; -- Order accepted, FH order # assigned [ack] + N ORSTS S ^OR(100,+ORIFN,4)=PKGIFN ; FH identifier + I "DN"'[$E(PKGIFN) S ORSTS=6 ;not Diet or NPO + E S ORSTS=$S($P($G(^OR(100,+ORIFN,0)),U,8)>ORLOG:8,1:6) + D STATUS^ORCSAVE2(+ORIFN,ORSTS) + Q + ; +XX ; -- Edited backdoor order (OP recurring meals only) + D XX^ORMFH1 Q + ; +SN ; -- New backdoor order: return NA msg w/ORIFN + N ODS,ODT,OBR,ORDIALOG,X,I,OI,SEG,ORNEW,ORPARAM,ORTIME,ORSTS,ORDG,ORP,ORTRAIL + ;I '$D(^VA(200,+ORNP,0)) S ORERR="Missing or invalid ordering provider"Q + ; Don't require provider until Nature of Order is added + I '$G(DGPMT),'$D(^VA(200,+ORDUZ,0)) S ORERR="Missing or invalid entering person" Q + I 'ORSTRT S ORERR="Missing effective date/time" Q + ;I '$G(ORL) S ORERR="Missing or invalid patient location" Q + D EN1^FHWOR8(ORL,.ORPARAM) + S ODS=$O(@ORMSG@(+ORC)) I 'ODS S ORERR="Incomplete message" Q + S ODS=ODS_U_@ORMSG@(ODS),ORSTS=6 I '$L(ORNATR),ORCAT="I" S ORNATR="S" + I $E($P(ODS,U,2),1,3)="OBR" S OBR=ODS D IP G SN1 + I $E($P(ODS,U,2),1,3)="ODT" S ODT=ODS D TRAY G SN1 + I $E($P(ODS,U,2),1,3)'="ODS" S ORERR="Missing or invalid ODS segment" Q + I $P(ODS,"|",2)="ZE" D TF G SN1 + I $P(ODS,"|",4)?1"^^^FH-6".E D ADDL G SN1 + I ORCAT'="I" D OPM^ORMFH1 G SN1 + I $P(ODS,"|",4)?1"^^^FH-5".E D NPO G SN1 +DIET ; Diet order + S ORDIALOG=$O(^ORD(101.41,"AB","FHW1",0)),ORTRAIL="Diet" + D GETDLG1^ORCD(ORDIALOG) S:ORSTRT>ORLOG ORSTS=8 + S ORDIALOG($$PTR("START DATE/TIME"),1)=ORSTRT + S:ORSTOP ORDIALOG($$PTR("STOP DATE/TIME"),1)=ORSTOP + S X=$P(ODS,"|",2),ORDIALOG($$PTR("DELIVERY"),1)=$S($L(X)=1:X,1:$E(X,2)) + ; Comments ?? + S X=$$ORDITEM^ORM($P(ODS,"|",4)) + I 'X S ORERR="Missing or invalid diet modification" Q + S I=1,OI=$$PTR("ORDERABLE ITEM"),ORDIALOG(OI,I)=X + I $O(@ORMSG@(+ODS)) F S ODS=$O(@ORMSG@(+ODS)) Q:ODS'>0 S SEG=$E(@ORMSG@(+ODS),1,3) Q:SEG="ORC" Q:SEG="MSH" I SEG="ODS" D Q:$D(ORERR) + . S X=$$ORDITEM^ORM($P(@ORMSG@(+ODS),"|",4)) + . I 'X S ORERR="Missing or invalid diet modification" Q + . S I=I+1,ORDIALOG(OI,I)=X +SN1 ; continue ... save order, post message + Q:$D(ORERR) + D EN^ORCSAVE I '$G(ORIFN) S ORERR="Cannot create new order" Q + D RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR),SIGSTS^ORCSAVE2(ORIFN,1) + D:'$P($G(^OR(100,ORIFN,0)),U,8) DATES^ORCSAVE2(ORIFN,ORSTRT,ORSTOP) + D STATUS^ORCSAVE2(ORIFN,ORSTS) + I $G(ORL) S ORP(1)=ORIFN_";1^1" D PRINTS^ORWD1(.ORP,+ORL) ; chart copy + S ^OR(100,ORIFN,4)=PKGIFN + Q + ; +TRAY ; Early/Late tray + I 'ORSTOP S ORERR="Missing stop date" Q + S ORDIALOG=$O(^ORD(101.41,"AB","FHW2",0)) D GETDLG1^ORCD(ORDIALOG),EN2^ORCDFH + S ORDIALOG($$PTR("START DATE"),1)=ORSTRT + S ORDIALOG($$PTR("STOP DATE"),1)=ORSTOP + N DAYS,SCH S DAYS="",SCH=$P(ORQT,U,2) + I $L(SCH),SCH'="ONCE" F I=1:1:$L(SCH,"~") S X=+$P($P(SCH,"~",I),"J",2),DAYS=DAYS_$E("MTWRFSX",X) + S:$L(DAYS) ORDIALOG($$PTR("SCHEDULE"),1)=DAYS + S OI=+$O(^ORD(101.43,"S.E/L T",$P(ODT,"|",2)_" TRAY",0)),ORDIALOG($$PTR("ORDERABLE ITEM"),1)=OI + S X=$P($P(ODT,"|",3),U,4),ORDIALOG($$PTR("MEAL"),1)=$E(X) + S ORDIALOG($$PTR("MEAL TIME"),1)=$P($G(ORTIME(OI,$E(X),+$E(X,3))),U,2) + S:$L($P(ODT,"|",4)) ORDIALOG($$PTR("YES/NO"),1)=1 + Q + ; +IP ; Isolation/Precautions + N IP S IP=+$P($P(OBR,"|",13),U,4) + I IP'>0 S ORERR="Missing or invalid isolation type" Q + S ORDIALOG=$O(^ORD(101.41,"AB","FHW3",0)) D GETDLG1^ORCD(ORDIALOG) + S ORDIALOG($$PTR("ISOLATION TYPE"),1)=IP + S ORDIALOG($$PTR("ORDERABLE ITEM"),1)=$O(^ORD(101.43,"S.PREC","ISOLATION PROCEDURES",0)) + Q + ; +TF ; Tubefeeding + N OI,STR,INSTR,CMMT,I,X,X4,XI,ZQT,QT,QTY,DUR + S ORDIALOG=$O(^ORD(101.41,"AB","FHW8",0)) D GETDLG1^ORCD(ORDIALOG) + S OI=$$PTR("ORDERABLE ITEM"),STR=$$PTR("STRENGTH FH") + S INSTR=$$PTR("INSTRUCTIONS"),CMMT=$$PTR("FREE TEXT 1") + ; Comments ?? + S I=0 F D S ODS=$O(@ORMSG@(+ODS)) Q:ODS'>0 Q:$E(@ORMSG@(ODS),1,3)="ORC" S ODS=ODS_U_@ORMSG@(ODS) + . Q:$E($P(ODS,U,2),1,3)'="ODS" ; not ODS segment + . S X=$P(ODS,"|",4),X4=$P(X,U,4) ; OI + . S:X4["-" $P(X,U,4)=+X4,X4=+$P(X4,"-",2) ; strength + . S XI=$$ORDITEM^ORM(X) I 'XI S ORERR="Missing or invalid tubefeeding product" Q + . S ZQT=$O(@ORMSG@(+ODS)) I 'ZQT S ORERR="Missing QT information" Q + . S QT=$P(@ORMSG@(ZQT),"|",3),DUR=$P(QT,U,3) + . S QTY=+QT_" "_$$UNITS($P($P(QT,U),"&",2))_"/"_$P(QT,U,2) + . S:$L(DUR) QTY=QTY_" X "_+$E(DUR,2,99)_$S($E(DUR)="H":"HR",1:"") + . S I=I+1,ORDIALOG(OI,I)=XI,ORDIALOG(STR,I)=X4,ORDIALOG(INSTR,I)=QTY + . S:$L($P(ODS,"|",5)) ORDIALOG(CMMT,I)=$P(ODS,"|",5) + I ORCAT="O",ORQT["~" D DATES + Q + ; +UNITS(X) ; -- Returns name of unit X + N Y S X=$E(X) + S Y=$S(X="K":"KCAL",X="C":"CC",X="M":"ML",X="O":"OZ",X="U":"UNITS",X="T":"TBSP",X="G":"GM",1:"") + Q Y + ; +NPO ; NPO + S ORDIALOG=$O(^ORD(101.41,"AB","FHW1",0)) D GETDLG1^ORCD(ORDIALOG) + S ORDIALOG($$PTR("ORDERABLE ITEM"),1)=$O(^ORD(101.43,"S.DIET","NPO",0)) + S ORDIALOG($$PTR("START DATE/TIME"),1)=ORSTRT S:ORSTRT>ORLOG ORSTS=8 + S:ORSTOP ORDIALOG($$PTR("STOP DATE/TIME"),1)=ORSTOP + S:$L($P(ODS,"|",5)) ORDIALOG($$PTR("FREE TEXT 1"),1)=$P(ODS,"|",5) + Q + ; +ADDL ; Additional order + S ORDIALOG=$O(^ORD(101.41,"AB","FHW7",0)) D GETDLG1^ORCD(ORDIALOG) + S ORDIALOG($$PTR("FREE TEXT 1"),1)=$P(ODS,"|",5) + I ORCAT="O",ORQT["~" D DATES + Q + ; +DATES ; -- pull dates out of ORQT + N P,I,X S P=$$PTR("DATE/TIME") + F I=1:1:$L(ORQT,"~") S X=$P(ORQT,"~",I),ORDIALOG(P,I)=$$HL7TFM^XLFDT($P(X,U,4)) + S ORSTRT=$G(ORDIALOG(P,1)),ORSTOP=$G(ORDIALOG(P,I)) + Q + ; +SC ; -- Status Change +SR ; -- Status Update [ack] + N ORSTS,OROLD S OROLD=$P($G(^OR(100,+ORIFN,3)),U,3) + D DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP) + S ORSTS=$S(ORDSTS="DC":1,ORDSTS="IP":6,ORDSTS="ZE":7,ORDSTS="SC":8,1:"") + D:ORSTS STATUS^ORCSAVE2(+ORIFN,ORSTS) + I ORDSTS="DC",'$D(^OR(100,+ORIFN,6)) D ;set 6-node + . I ORNATR'="A","DN"[$E(PKGIFN) S ORNATR="C" S:'$L(OREASON) OREASON="Replaced with new diet order" S:ORDUZ<1 ORDUZ="" + . S ^OR(100,+ORIFN,6)=$S($L(ORNATR):+$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORDUZ_U_ORLOG_U_U_OREASON + I OROLD=1,ORSTS=6 D ; reactivate + . N X S $P(^OR(100,+ORIFN,3),U,7)=1,X=$P(^(0),U,9) K ^(6) + . I 'ORSTOP,X S $P(^OR(100,+ORIFN,0),U,9)="" K ^OR(100,"AE",X,+ORIFN) + . D SETALL^ORDD100(+ORIFN) + Q + ; +OC ; -- Cancelled / [ack] + G:ORTYPE="ORR" UA ;rejected new order + I $P($G(^OR(100,+ORIFN,3)),U,3)=6,$P(^(0),U,8) + S ^OR(100,+ORIFN,6)=$S($L(ORNATR):+$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORDUZ_U_ORLOG_U_U_OREASON + D UPDATE(1,"DC") + Q + ; +DR ; -- Discontinued as requested [ack] + D STATUS^ORCSAVE2(+ORIFN,1) + Q + ; +UA ; -- Unable to Accept [ack] + S:'$L(ORNATR) ORNATR="X" ;Rejected + S ^OR(100,+ORIFN,6)=+$O(^ORD(100.02,"C",ORNATR,0))_U_U_ORLOG_U_U_OREASON + D STATUS^ORCSAVE2(+ORIFN,13) +UC ; -- Unable to Cancel [ack] +UD ; -- Unable to Discontinue [ack] + N DA S DA=$P(ORIFN,";",2) I DA D + . S:$G(OREJECT) $P(^OR(100,+ORIFN,8,DA,0),U,15)=13 ; request rejected + . S:$L(OREASON) ^OR(100,+ORIFN,8,DA,1)=OREASON + Q + ; +UPDATE(ORSTS,ORACT) ; -- continue processing + N ORX,DA,ORP D DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP) + D:$G(ORSTS) STATUS^ORCSAVE2(+ORIFN,ORSTS) + S ORX=$$CREATE^ORX1(ORNATR) D:ORX + . S DA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,OREASON,ORLOG,ORDUZ) + . I DA'>0 S ORERR="Cannot create new order action" Q + . D RELEASE^ORCSAVE2(+ORIFN,DA,ORLOG,ORDUZ,ORNATR) + . D SIGSTS^ORCSAVE2(+ORIFN,DA) + . I $G(ORL) S ORP(1)=+ORIFN_";"_DA_"^1" D PRINTS^ORWD1(.ORP,+ORL) + . S $P(^OR(100,+ORIFN,3),U,7)=DA + I 'ORX,ORACT="DC",'$$ACTV^ORX1(ORNATR) S $P(^OR(100,+ORIFN,3),U,7)=0 + D:ORACT="DC" CANCEL^ORCSEND(+ORIFN) + Q + ; +PTR(NAME) ; -- Returns ien of prompt NAME in Order Dialog file #101.41 + Q $O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0)) diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMFN.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMFN.m index 3935c75c..0d62fd53 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMFN.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMFN.m @@ -1,139 +1,127 @@ -ORMFN ; SLC/MKB - MFN msg router ;11/21/2006 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**26,97,94,176,215,243**;Dec 17, 1997;Build 242 -EN(MSG) ; -- main entry point for OR ITEM RECEIVE - N ORMSG,ORNMSP,ORDG,MSH,MFI,MFE,ZPKG,ZSY,NTE,ORMFE,ORDITEM,ORACTION,ORDIFN,ORFIEN,ORFLD,ORFDA,NUM,VALUE,X,Y,DA,DIC,DIK,SYS,ZLC,LAST,NAME,ID,INACTIVE,I,ORY,NEXT,DD,DO - S ORMSG=$G(MSG,"MSG") Q:'$O(@ORMSG@(0)) ; msg array root - N ORNOW S ORNOW=$$NOW^XLFDT ;M ^XTMP("OR ITEM RECEIVE",ORNOW)=@ORMSG -MSH S MSH=0 F S MSH=$O(@ORMSG@(MSH)) Q:MSH'>0 Q:$E(@ORMSG@(MSH),1,3)="MSH" - Q:'MSH S MSH=MSH_U_@ORMSG@(MSH) - S X=$P(MSH,"|",3) S:X="RADIOLOGY" X="IMAGING" - S ORDG=$O(^ORD(100.98,"B",X,0)),ORNMSP=$$NMSP(X) Q:'$L(ORNMSP) - S MFI=$O(@ORMSG@(+MSH)) Q:$E(@ORMSG@(MFI),1,3)'="MFI" ; error -MFE S MFE=+MFI ; ** loop through each MFE segment - F S MFE=$O(@ORMSG@(+MFE)) Q:MFE'>0 I $E(@ORMSG@(MFE),1,3)="MFE" D - . K ORFLD,ORFDA - . S MFE=MFE_U_@ORMSG@(MFE),ORMFE=$P(MFE,"|",2),INACTIVE=$P(MFE,"|",4) - . S ORDITEM=$P(MFE,"|",5),NAME=$TR($P(ORDITEM,U,5),"~"," ") - . S ID=$P(ORDITEM,U,4)_";"_$P(ORDITEM,U,6) - . S ORDIFN=+$O(^ORD(101.43,"ID",ID,0)),ORFIEN=ORDIFN_"," - . S ORACTION=$S(ORMFE="MAD":1,(ORMFE="MAC")&('ORDIFN):1,(ORMFE="MUP")&('ORDIFN):1,'ORDIFN:0,ORMFE="MAC":2,ORMFE="MUP":2,ORMFE="MDC":3,ORMFE="MDL":3,1:0) ; 1=add, 2=change, 3=delete (inactivate) - . Q:'ORACTION ; 0=error - . I ORACTION=3 S ORFDA(101.43,ORFIEN,.1)=$S(INACTIVE:$$HL7TFM^XLFDT(INACTIVE),1:$$NOW^XLFDT) D FILE^DIE("K","ORFDA") Q -ADD . I ORACTION=1,'ORDIFN D Q:'ORDIFN ;create item if it doesn't exist - . . S ORDIFN=$$CREATE(NAME),ORFIEN=ORDIFN_"," - . . S ORFDA(101.43,ORFIEN,5)=+ORDG - . S ORFLD(.01)=NAME,ORFLD(1.1)=NAME,ORFLD(2)=ID,ORFLD(3)=$P(ORDITEM,U) - . S SYS=$P(ORDITEM,U,3),ORFLD(4)=$S(+SYS=99:$E(SYS,3,99),1:SYS) - . S ORFLD(.1)=$S(ORMFE="MAC":"@",(ORMFE="MUP")&('INACTIVE):"@",INACTIVE:$$HL7TFM^XLFDT(INACTIVE),1:"") - . F NUM=.01,.1,1.1,2,3,4 S VALUE=$S(ORFLD(NUM)="":"@",1:ORFLD(NUM)) D VAL^DIE(101.43,ORFIEN,NUM,"F",VALUE,.ORY,"ORFDA") -ZPKG . S LAST=+MFE,ZPKG=$O(@ORMSG@(+MFE)) - . I ZPKG,$E(@ORMSG@(ZPKG),1,3)=("Z"_ORNMSP) S ZPKG=ZPKG_U_@ORMSG@(ZPKG),LAST=+ZPKG D @ORNMSP ; ZXX segment - . D FILE^DIE("K","ORFDA") ; file data -ZLC . S NEXT=$O(@ORMSG@(LAST)) I NEXT,$E(@ORMSG@(NEXT),1,3)="ZLC" D - . . N COMP,CID,CODE,CSYS - . . K DA,^ORD(101.43,ORDIFN,10) ;S DIC("P")=$P(^DD(101.43,10,0),U,2) - . . S DA(1)=ORDIFN,DIC="^ORD(101.43,"_DA(1)_",10,",DIC(0)="L",ZLC=LAST - . . F S ZLC=$O(@ORMSG@(ZLC)) Q:ZLC'>0 Q:$E(@ORMSG@(ZLC),1,3)'="ZLC" D - . . . S COMP=$P(@ORMSG@(ZLC),"|",5),X=$P(COMP,U,5) I X="" S LAST=ZLC Q - . . . S CID=$P(COMP,U,4)_";"_$P(COMP,U,6) K DIC("DR"),DO,DD - . . . S CODE=$P(COMP,U),CSYS=$P(COMP,U,3) S:+CSYS=99 CSYS=$E(CSYS,3,99) - . . . S DIC("DR")="2///^S X=CID;3///^S X=CODE;4///^S X=CSYS" - . . . D FILE^DICN S LAST=ZLC -ZSY . I $D(^ORD(101.43,ORDIFN,2)) D ; kill old ones first - . . S DA(1)=ORDIFN,DIK="^ORD(101.43,"_DA(1)_",2," - . . S DA=0 F S DA=$O(^ORD(101.43,DA(1),2,DA)) Q:DA'>0 D ^DIK - . . K ^ORD(101.43,ORDIFN,2),DIK,DA - . S NEXT=$O(@ORMSG@(LAST)) I NEXT,$E(@ORMSG@(NEXT),1,3)="ZSY" D - . . K DA,DIC S DA(1)=ORDIFN,DIC="^ORD(101.43,"_DA(1)_",2," - . . S DIC(0)="L",ZSY=LAST ;,DIC("P")=$P(^DD(101.43,1,0),U,2) - . . F S ZSY=$O(@ORMSG@(+ZSY)) Q:ZSY'>0 Q:$E(@ORMSG@(ZSY),1,3)'="ZSY" D - . . . S X=$P(@ORMSG@(ZSY),"|",3),LAST=ZSY - . . . K DD,DO D:$L(X) FILE^DICN -NTE . K ^ORD(101.43,ORDIFN,8) ; replace text - . S NEXT=$O(@ORMSG@(LAST)) I NEXT,$E(@ORMSG@(NEXT),1,3)="NTE" D - . . S NTE=LAST,DA=0 - . . F S NTE=$O(@ORMSG@(NTE)) Q:NTE'>0 Q:$E(@ORMSG@(NTE),1,3)'="NTE" S DA=DA+1,^ORD(101.43,ORDIFN,8,DA,0)=$P(@ORMSG@(NTE),"|",4) I $O(@ORMSG@(NTE,0)) D - . . . S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S DA=DA+1,^ORD(101.43,ORDIFN,8,DA,0)=@ORMSG@(NTE,I) - . . S ^ORD(101.43,ORDIFN,8,0)="^^"_DA_U_DA_U_DT_U - Q - ; -NMSP(NAME) ; -- returns namespace for package - I NAME="RADIOLOGY" Q "RA" - I NAME="IMAGING" Q "RA" - I NAME="LABORATORY" Q "LR" - I NAME="DIETETICS" Q "FH" - I NAME="PHARMACY" Q "PS" - I NAME="CONSULTS" Q "CS" - I NAME="PROCEDURES" Q "CS" - Q "" - ; -CREATE(X) ; -- Create new item in #101.43 - Q:'$L($G(X)) 0 N HDR,LAST,TOTAL,I - L +^ORD(101.43,0):1 Q:'$T 0 - S HDR=$G(^ORD(101.43,0)) Q:HDR="" 0 - S LAST=$P(HDR,U,3),TOTAL=$P(HDR,U,4) - F I=(LAST+1):1 Q:'$D(^ORD(101.43,I,0)) - S ^ORD(101.43,I,0)=X,X=$E(X,1,30),^ORD(101.43,"B",$$UP^XLFSTR(X),I)="" - S $P(^ORD(101.43,0),U,3,4)=I_U_(TOTAL+1) - L -^ORD(101.43,0) - Q I - ; -FH ; -- Dietetics - S X=$P(ZPKG,"|",2),ORFLD(111.1)=$S(X="":"@",1:X) - S X=$P(ZPKG,"|",3),ORFLD(111.2)=$S(X="":"@",1:X) - S X=$P(ZPKG,"|",5),ORFLD(111.3)=$S(X="":"@",1:X) - F NUM=111.1,111.2,111.3 D VAL^DIE(101.43,ORFIEN,NUM,"F",ORFLD(NUM),.ORY,"ORFDA") - K ^ORD(101.43,ORDIFN,8) S X=$P(ZPKG,"|",4) - I $L(X) S ^ORD(101.43,ORDIFN,8,0)="^^1^1^"_DT_U,^(1,0)=X - Q - ; -LR ; -- Laboratory - S X=$P(ZPKG,"|",2),ORFLD(60.1)=$S(X="":"@",1:X) - S X=$P(ZPKG,"|",3),ORFLD(60.2)=$S(X="":"@",1:X) - ;S X=$P(ZPKG,"|",4),ORFLD(60.3)=$S(X="":"@",1:X) - S X=$P(ZPKG,"|",5),ORFLD(60.6)=$S(X="":"@",1:X) - S X=$P(ZPKG,"|",6),ORFLD(60.4)=$S(X="":"@",1:X) - S X=$P(ZPKG,"|",7),ORFLD(60.5)=$S(X="":"@",1:X) - S X=$P(ZPKG,"|",8),ORFLD(6)=$S(X="":"@",1:X) - S X=$P(ZPKG,"|",9),ORFLD(60.7)=$S(X="":"@",1:X) - F NUM=6,60.1,60.2,60.4,60.5,60.6,60.7 D VAL^DIE(101.43,ORFIEN,NUM,"F",ORFLD(NUM),.ORY,"ORFDA") - Q - ; -PS ; -- Pharmacy - N ROUTE - S X=$P(ZPKG,"|",2) - ;S ORFDA(101.43,ORFIEN,50.1)=$S(X'["I":0,$L($P($P(ORDITEM,U,5),"~",3)):2,1:1) - S ORFDA(101.43,ORFIEN,50.1)=$S(X["V":2,X["I":1,1:0) ;inpt or iv med - S ORFDA(101.43,ORFIEN,50.2)=(X["O") ;outpt med - S ORFDA(101.43,ORFIEN,50.3)=(X["B") ;fluid base/soln - S ORFDA(101.43,ORFIEN,50.4)=(X["A") ;fluid additive - S ORFDA(101.43,ORFIEN,50.5)=(X["S") ;supply item - S ORFDA(101.43,ORFIEN,50.7)=(X["N") ;non-VA med - S X=$P(ZPKG,"|",3),ORFDA(101.43,ORFIEN,50.6)=$S(X:1,1:0) - ;Check for default med route - ;S ROUTE=$$MEDROUTE - ;I ROUTE>0 S ORFDA(101.43,ORFIEN,50.8)=ROUTE - Q - ; -MEDROUTE() ; - N CNT,ROUTE - S CNT=0,ROUTE=0 - F S CNT=$O(@ORMSG@(CNT)) Q:CNT'>0 D - .I $P($G(@ORMSG@(CNT)),"|")'="ZPB" Q - .S ROUTE=+$P($G(@ORMSG@(CNT)),"|",4) - Q ROUTE - ; -RA ; -- Radiology/Nuc Medicine - S X=$P(ZPKG,"|",4),ORFLD(6)=$S(X="":"@",1:X) - S X=$P(ZPKG,"|",5),ORFLD(71.1)=$S(X="":"@",1:X) - S X=$P(ZPKG,"|",7),ORFLD(71.2)=$S(X="":"@",1:X) - S X=$P(ZPKG,"|",2),ORFLD(71.3)=$S(X="":"@",1:X) - S ORFLD(71.4)=$S($P(ZPKG,"|",6)="Y":1,1:0) - S ORFLD(7)=$S($P(ZPKG,"|",3)="Y":2,1:1) - F NUM=6,7,71.1,71.2,71.3,71.4 D VAL^DIE(101.43,ORFIEN,NUM,"F",ORFLD(NUM),.ORY,"ORFDA") - Q - ; -CS ; -- Consults/Requests - S X=$P(ZPKG,"|",2),ORFLD(123.1)=$S(X="":"@",1:X) - D VAL^DIE(101.43,ORFIEN,123.1,"F",ORFLD(123.1),.ORY,"ORFDA") - Q +ORMFN ; SLC/MKB - MFN msg router ;04:29 PM 19 Dec 2000 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**26,97,94,176,215**;Dec 17, 1997 +EN(MSG) ; -- main entry point for OR ITEM RECEIVE + N ORMSG,ORNMSP,ORDG,MSH,MFI,MFE,ZPKG,ZSY,NTE,ORMFE,ORDITEM,ORACTION,ORDIFN,ORFIEN,ORFLD,ORFDA,NUM,VALUE,X,Y,DA,DIC,DIK,SYS,ZLC,LAST,NAME,ID,INACTIVE,I,ORY,NEXT,DD,DO + S ORMSG=$G(MSG,"MSG") Q:'$O(@ORMSG@(0)) ; msg array root + N ORNOW S ORNOW=$$NOW^XLFDT ;M ^XTMP("OR ITEM RECEIVE",ORNOW)=@ORMSG +MSH S MSH=0 F S MSH=$O(@ORMSG@(MSH)) Q:MSH'>0 Q:$E(@ORMSG@(MSH),1,3)="MSH" + Q:'MSH S MSH=MSH_U_@ORMSG@(MSH) + S X=$P(MSH,"|",3) S:X="RADIOLOGY" X="IMAGING" + S ORDG=$O(^ORD(100.98,"B",X,0)),ORNMSP=$$NMSP(X) Q:'$L(ORNMSP) + S MFI=$O(@ORMSG@(+MSH)) Q:$E(@ORMSG@(MFI),1,3)'="MFI" ; error +MFE S MFE=+MFI ; ** loop through each MFE segment + F S MFE=$O(@ORMSG@(+MFE)) Q:MFE'>0 I $E(@ORMSG@(MFE),1,3)="MFE" D + . K ORFLD,ORFDA + . S MFE=MFE_U_@ORMSG@(MFE),ORMFE=$P(MFE,"|",2),INACTIVE=$P(MFE,"|",4) + . S ORDITEM=$P(MFE,"|",5),NAME=$TR($P(ORDITEM,U,5),"~"," ") + . S ID=$P(ORDITEM,U,4)_";"_$P(ORDITEM,U,6) + . S ORDIFN=+$O(^ORD(101.43,"ID",ID,0)),ORFIEN=ORDIFN_"," + . S ORACTION=$S(ORMFE="MAD":1,(ORMFE="MAC")&('ORDIFN):1,(ORMFE="MUP")&('ORDIFN):1,'ORDIFN:0,ORMFE="MAC":2,ORMFE="MUP":2,ORMFE="MDC":3,ORMFE="MDL":3,1:0) ; 1=add, 2=change, 3=delete (inactivate) + . Q:'ORACTION ; 0=error + . I ORACTION=3 S ORFDA(101.43,ORFIEN,.1)=$S(INACTIVE:$$HL7TFM^XLFDT(INACTIVE),1:$$NOW^XLFDT) D FILE^DIE("K","ORFDA") Q +ADD . I ORACTION=1,'ORDIFN D Q:'ORDIFN ;create item if it doesn't exist + . . S ORDIFN=$$CREATE(NAME),ORFIEN=ORDIFN_"," + . . S ORFDA(101.43,ORFIEN,5)=+ORDG + . S ORFLD(.01)=NAME,ORFLD(1.1)=NAME,ORFLD(2)=ID,ORFLD(3)=$P(ORDITEM,U) + . S SYS=$P(ORDITEM,U,3),ORFLD(4)=$S(+SYS=99:$E(SYS,3,99),1:SYS) + . S ORFLD(.1)=$S(ORMFE="MAC":"@",(ORMFE="MUP")&('INACTIVE):"@",INACTIVE:$$HL7TFM^XLFDT(INACTIVE),1:"") + . F NUM=.01,.1,1.1,2,3,4 S VALUE=$S(ORFLD(NUM)="":"@",1:ORFLD(NUM)) D VAL^DIE(101.43,ORFIEN,NUM,"F",VALUE,.ORY,"ORFDA") +ZPKG . S LAST=+MFE,ZPKG=$O(@ORMSG@(+MFE)) + . I ZPKG,$E(@ORMSG@(ZPKG),1,3)=("Z"_ORNMSP) S ZPKG=ZPKG_U_@ORMSG@(ZPKG),LAST=+ZPKG D @ORNMSP ; ZXX segment + . D FILE^DIE("K","ORFDA") ; file data +ZLC . S NEXT=$O(@ORMSG@(LAST)) I NEXT,$E(@ORMSG@(NEXT),1,3)="ZLC" D + . . N COMP,CID,CODE,CSYS + . . K DA,^ORD(101.43,ORDIFN,10) ;S DIC("P")=$P(^DD(101.43,10,0),U,2) + . . S DA(1)=ORDIFN,DIC="^ORD(101.43,"_DA(1)_",10,",DIC(0)="L",ZLC=LAST + . . F S ZLC=$O(@ORMSG@(ZLC)) Q:ZLC'>0 Q:$E(@ORMSG@(ZLC),1,3)'="ZLC" D + . . . S COMP=$P(@ORMSG@(ZLC),"|",5),X=$P(COMP,U,5) I X="" S LAST=ZLC Q + . . . S CID=$P(COMP,U,4)_";"_$P(COMP,U,6) K DIC("DR"),DO,DD + . . . S CODE=$P(COMP,U),CSYS=$P(COMP,U,3) S:+CSYS=99 CSYS=$E(CSYS,3,99) + . . . S DIC("DR")="2///^S X=CID;3///^S X=CODE;4///^S X=CSYS" + . . . D FILE^DICN S LAST=ZLC +ZSY . I $D(^ORD(101.43,ORDIFN,2)) D ; kill old ones first + . . S DA(1)=ORDIFN,DIK="^ORD(101.43,"_DA(1)_",2," + . . S DA=0 F S DA=$O(^ORD(101.43,DA(1),2,DA)) Q:DA'>0 D ^DIK + . . K ^ORD(101.43,ORDIFN,2),DIK,DA + . S NEXT=$O(@ORMSG@(LAST)) I NEXT,$E(@ORMSG@(NEXT),1,3)="ZSY" D + . . K DA,DIC S DA(1)=ORDIFN,DIC="^ORD(101.43,"_DA(1)_",2," + . . S DIC(0)="L",ZSY=LAST ;,DIC("P")=$P(^DD(101.43,1,0),U,2) + . . F S ZSY=$O(@ORMSG@(+ZSY)) Q:ZSY'>0 Q:$E(@ORMSG@(ZSY),1,3)'="ZSY" D + . . . S X=$P(@ORMSG@(ZSY),"|",3),LAST=ZSY + . . . K DD,DO D:$L(X) FILE^DICN +NTE . K ^ORD(101.43,ORDIFN,8) ; replace text + . S NEXT=$O(@ORMSG@(LAST)) I NEXT,$E(@ORMSG@(NEXT),1,3)="NTE" D + . . S NTE=LAST,DA=0 + . . F S NTE=$O(@ORMSG@(NTE)) Q:NTE'>0 Q:$E(@ORMSG@(NTE),1,3)'="NTE" S DA=DA+1,^ORD(101.43,ORDIFN,8,DA,0)=$P(@ORMSG@(NTE),"|",4) I $O(@ORMSG@(NTE,0)) D + . . . S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S DA=DA+1,^ORD(101.43,ORDIFN,8,DA,0)=@ORMSG@(NTE,I) + . . S ^ORD(101.43,ORDIFN,8,0)="^^"_DA_U_DA_U_DT_U + Q + ; +NMSP(NAME) ; -- returns namespace for package + I NAME="RADIOLOGY" Q "RA" + I NAME="IMAGING" Q "RA" + I NAME="LABORATORY" Q "LR" + I NAME="DIETETICS" Q "FH" + I NAME="PHARMACY" Q "PS" + I NAME="CONSULTS" Q "CS" + I NAME="PROCEDURES" Q "CS" + Q "" + ; +CREATE(X) ; -- Create new item in #101.43 + Q:'$L($G(X)) 0 N HDR,LAST,TOTAL,I + L +^ORD(101.43,0):1 Q:'$T 0 + S HDR=$G(^ORD(101.43,0)) Q:HDR="" 0 + S LAST=$P(HDR,U,3),TOTAL=$P(HDR,U,4) + F I=(LAST+1):1 Q:'$D(^ORD(101.43,I,0)) + S ^ORD(101.43,I,0)=X,X=$E(X,1,30),^ORD(101.43,"B",$$UP^XLFSTR(X),I)="" + S $P(^ORD(101.43,0),U,3,4)=I_U_(TOTAL+1) + L -^ORD(101.43,0) + Q I + ; +FH ; -- Dietetics + S X=$P(ZPKG,"|",2),ORFLD(111.1)=$S(X="":"@",1:X) + S X=$P(ZPKG,"|",3),ORFLD(111.2)=$S(X="":"@",1:X) + S X=$P(ZPKG,"|",5),ORFLD(111.3)=$S(X="":"@",1:X) + F NUM=111.1,111.2,111.3 D VAL^DIE(101.43,ORFIEN,NUM,"F",ORFLD(NUM),.ORY,"ORFDA") + K ^ORD(101.43,ORDIFN,8) S X=$P(ZPKG,"|",4) + I $L(X) S ^ORD(101.43,ORDIFN,8,0)="^^1^1^"_DT_U,^(1,0)=X + Q + ; +LR ; -- Laboratory + S X=$P(ZPKG,"|",2),ORFLD(60.1)=$S(X="":"@",1:X) + S X=$P(ZPKG,"|",3),ORFLD(60.2)=$S(X="":"@",1:X) + ;S X=$P(ZPKG,"|",4),ORFLD(60.3)=$S(X="":"@",1:X) + S X=$P(ZPKG,"|",5),ORFLD(60.6)=$S(X="":"@",1:X) + S X=$P(ZPKG,"|",6),ORFLD(60.4)=$S(X="":"@",1:X) + S X=$P(ZPKG,"|",7),ORFLD(60.5)=$S(X="":"@",1:X) + S X=$P(ZPKG,"|",8),ORFLD(6)=$S(X="":"@",1:X) + S X=$P(ZPKG,"|",9),ORFLD(60.7)=$S(X="":"@",1:X) + F NUM=6,60.1,60.2,60.4,60.5,60.6,60.7 D VAL^DIE(101.43,ORFIEN,NUM,"F",ORFLD(NUM),.ORY,"ORFDA") + Q + ; +PS ; -- Pharmacy + S X=$P(ZPKG,"|",2) + ;S ORFDA(101.43,ORFIEN,50.1)=$S(X'["I":0,$L($P($P(ORDITEM,U,5),"~",3)):2,1:1) + S ORFDA(101.43,ORFIEN,50.1)=$S(X["V":2,X["I":1,1:0) ;inpt or iv med + S ORFDA(101.43,ORFIEN,50.2)=(X["O") ;outpt med + S ORFDA(101.43,ORFIEN,50.3)=(X["B") ;fluid base/soln + S ORFDA(101.43,ORFIEN,50.4)=(X["A") ;fluid additive + S ORFDA(101.43,ORFIEN,50.5)=(X["S") ;supply item + S ORFDA(101.43,ORFIEN,50.7)=(X["N") ;non-VA med + S X=$P(ZPKG,"|",3),ORFDA(101.43,ORFIEN,50.6)=$S(X:1,1:0) + Q + ; +RA ; -- Radiology/Nuc Medicine + S X=$P(ZPKG,"|",4),ORFLD(6)=$S(X="":"@",1:X) + S X=$P(ZPKG,"|",5),ORFLD(71.1)=$S(X="":"@",1:X) + S X=$P(ZPKG,"|",7),ORFLD(71.2)=$S(X="":"@",1:X) + S X=$P(ZPKG,"|",2),ORFLD(71.3)=$S(X="":"@",1:X) + S ORFLD(71.4)=$S($P(ZPKG,"|",6)="Y":1,1:0) + S ORFLD(7)=$S($P(ZPKG,"|",3)="Y":2,1:1) + F NUM=6,7,71.1,71.2,71.3,71.4 D VAL^DIE(101.43,ORFIEN,NUM,"F",ORFLD(NUM),.ORY,"ORFDA") + Q + ; +CS ; -- Consults/Requests + S X=$P(ZPKG,"|",2),ORFLD(123.1)=$S(X="":"@",1:X) + D VAL^DIE(101.43,ORFIEN,123.1,"F",ORFLD(123.1),.ORY,"ORFDA") + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMGMRC.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMGMRC.m index cc14bb7e..41c9b2c4 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMGMRC.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMGMRC.m @@ -1,158 +1,158 @@ -ORMGMRC ; SLC/MKB - Process Consult ORM msgs ;12/13/2006 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,26,68,92,153,174,195,255,243**;Dec 17, 1997;Build 242 -EN ; -- entry point for GMRC messges - I '$L($T(@ORDCNTRL)) Q ;S ORERR="Invalid order control code" Q - I ORDCNTRL'="SN",ORDCNTRL'="ZP",'ORIFN!('$D(^OR(100,+ORIFN,0))) S ORERR="Invalid OE/RR order number" Q - S:ORDCNTRL="OC"&(ORTYPE="ORR") ORDCNTRL="UA" ;new code - N ORSTS,OREASON1,NTE S ORSTS=$$STATUS(ORDSTS) - S:'ORLOG ORLOG=$$NOW^XLFDT S:'ORDUZ ORDUZ=DUZ S:$G(DGPMT) ORDUZ="" - S OREASON=$P(OREASON,U,5),NTE=$O(@ORMSG@(+ORC)),OREASON1="" - I NTE,$E(@ORMSG@(NTE),1,3)="NTE" S OREASON1=$P(@ORMSG@(NTE),"|",4) - D @ORDCNTRL - Q - ; -ZP ; -- Purged - Q:'ORIFN Q:'$D(^OR(100,+ORIFN,0)) - K ^OR(100,+ORIFN,4) I "^3^5^6^8^"[(U_$P($G(^(3)),U,3)_U) D STATUS^ORCSAVE2(+ORIFN,14) ; Remove pkg reference, sts=lapsed if still active - Q - ; -ZR ; -- Purged as requested [ack] - D DELETE^ORCSAVE2(+ORIFN) - Q - ; -ZU ; -- Unable to purge [ack] - S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ; update Last Activity - Q - ; -OK ; -- Order accepted, GMRC order # assigned [ack] - S ^OR(100,+ORIFN,4)=PKGIFN S:'$G(ORSTS) ORSTS=5 - D STATUS^ORCSAVE2(+ORIFN,ORSTS) ; 5=pending - D DATES^ORCSAVE2(+ORIFN,+$E($$NOW^XLFDT,1,12)) - Q - ; -XX ; -- Change order - N ORDIALOG,ORDG,ORDA,ORX,ORP,ORSIG S:'$L(ORNATR) ORNATR="S" - D DLG Q:$D(ORERR) Q:'$D(ORDIALOG) S ORIFN=+ORIFN - S ORDA=$$ACTION^ORCSAVE("XX",ORIFN,ORNP,OREASON1,ORLOG,ORDUZ) - I ORDA'>0 S ORERR="Cannot create new order action" Q - ; -Update sts of order to active, last action to dc/edit: - S ORX=+$P($G(^OR(100,ORIFN,3)),U,7) S:ORX'>0 ORX=+$O(^(8,ORDA),-1) - I $D(^OR(100,ORIFN,8,ORX,0)),$P(^(0),U,15)="" S $P(^(0),U,15)=12 - S $P(^OR(100,ORIFN,3),U,7)=ORDA D:$G(ORSTS) STATUS^ORCSAVE2(ORIFN,ORSTS) - D PXRMKILL^ORDD100(ORIFN,ORVP,ORLOG) ; JEH 255 - D RELEASE^ORCSAVE2(ORIFN,ORDA,ORLOG,ORDUZ,ORNATR) - ; -If unsigned edit, leave XX unsigned & mark ORX as Sig Not Req'd - S ORSIG=$S($P($G(^OR(100,ORIFN,8,ORX,0)),U,4)'=2:1,1:0) - D SIGSTS^ORCSAVE2(ORIFN,ORDA):ORSIG,SIGN^ORCSAVE2(ORIFN,,,5,ORX):'ORSIG - ; -Update responses, get/save new order text: - K ^OR(100,ORIFN,4.5) D RESPONSE^ORCSAVE,ORDTEXT^ORCSAVE1(ORIFN_";"_ORDA) - S $P(^OR(100,ORIFN,8,ORDA,0),U,14)=ORDA - K:OREASON="RESUBMIT" ^OR(100,ORIFN,6) ;clear previous DC data - D PXRMADD^ORDD100(ORIFN,ORVP,ORLOG) ; JEH 255 - I $G(ORL) S ORP(1)=+ORIFN_";"_ORDA_"^1" D PRINTS^ORWD1(.ORP,+ORL) - Q - ; -SN ; -- New backdoor order: return NA msg w/ORIFN, or DE msg - N ORDIALOG,ORDG,ORP K ^TMP("ORWORD",$J) S:'$L(ORNATR) ORNATR="W" - I '$D(^VA(200,ORNP,0)) S ORERR="Missing or invalid ordering provider" Q - I ORDUZ,'$D(^VA(200,ORDUZ,0)) S ORERR="Invalid entering person" Q - I '$G(ORL) S ORERR="Missing or invalid patient location" Q - D DLG Q:$D(ORERR) Q:'$D(ORDIALOG) -SN1 D EN^ORCSAVE K ^TMP("ORWORD",$J) ; setting status, xrefs - I '$G(ORIFN) S ORERR="Cannot create new order" Q - ;Save DG1 and ZCL segments of HL7 message from backdoor orders - D BDOSTR^ORWDBA3 - D RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR),SIGSTS^ORCSAVE2(ORIFN,1) - S:'ORSTRT ORSTRT=$$NOW^XLFDT D DATES^ORCSAVE2(+ORIFN,ORSTRT) - D:$G(ORSTS) STATUS^ORCSAVE2(ORIFN,ORSTS) - I $G(ORL) S ORP(1)=ORIFN_";1^1" D PRINTS^ORWD1(.ORP,+ORL) ; chart copy - S ^OR(100,ORIFN,4)=PKGIFN - Q - ; -DLG ; -- Build ORDIALOG(),ORDG from msg - N OBR,USID,TYPE,OI,ZSV,J,OBX,WP,I - S OBR=$$OBR I 'OBR!($E($G(@ORMSG@(OBR)),1,3)'="OBR") S ORERR="Missing OBR segment" Q - S USID=$P(@ORMSG@(OBR),"|",5),TYPE=$S(USID["99CON":"CONSULT",1:"REQUEST") - S ORDIALOG=$O(^ORD(101.41,"AB","GMRCOR "_TYPE,0)) - D GETDLG1^ORCD(ORDIALOG) - S ORDIALOG($$PTR("URGENCY"),1)=ORURG - S OI=$$ORDITEM^ORM(USID) I 'OI S ORERR="Invalid consult or procedure" Q - S ORDIALOG($$PTR("ORDERABLE ITEM"),1)=OI - S ZSV=$O(@ORMSG@(OBR)) I ZSV,$E(@ORMSG@(ZSV),1,3)="ZSV" D - . N X1,X2 S X1=$P(@ORMSG@(ZSV),"|",2),X2=$P(@ORMSG@(ZSV),"|",3) - . I TYPE="REQUEST" S ORDIALOG($$PTR("REQUEST SERVICE"),1)=+$P(X1,U,4) - . I TYPE="CONSULT",$L(X2) S ORDIALOG($$PTR("FREE TEXT OI"),1)=X2 -D1 S ORDIALOG($$PTR("CATEGORY"),1)=$G(ORCAT) - S J=$P(@ORMSG@(OBR),"|",19),ORDIALOG($$PTR("PLACE OF CONSULTATION"),1)=$S(J="OC":"C",1:J) - S ORDIALOG($$PTR("PROVIDER"),1)=$P(@ORMSG@(OBR),"|",20) - S OBX=OBR F S OBX=$O(@ORMSG@(OBX)) Q:OBX'>0 S J=$E(@ORMSG@(OBX),1,3) Q:J="ORC" Q:J="MSH" I J="OBX" D - . N SEG,NAME,VALUE S SEG=@ORMSG@(OBX) - . S NAME=$$UP^XLFSTR($P($P(SEG,"|",4),U,2)),VALUE=$P(SEG,"|",6) - . I NAME="PROVISIONAL DIAGNOSIS" D Q - .. S:$P(SEG,"|",3)="CE" ORDIALOG($$PTR("CODE"),1)=$P(VALUE,U),VALUE=$P(VALUE,U,2) - .. S ORDIALOG($$PTR("FREE TEXT"),1)=VALUE - . S WP=$$PTR("WORD PROCESSING 1"),I=1,^TMP("ORWORD",$J,WP,1,I,0)=VALUE - . S J=0 F S J=$O(@ORMSG@(OBX,J)) Q:J'>0 S I=I+1,^TMP("ORWORD",$J,WP,1,I,0)=@ORMSG@(OBX,J) - S:$G(I) ^TMP("ORWORD",$J,WP,1,0)="^^"_I_U_I_U_DT_U,ORDIALOG(WP,1)="^TMP(""ORWORD"",$J,"_WP_",1)" - Q - ; -OBR() ; -- Return subscript of RXE segment - N X,I,SEG S X="",I=+ORC - F S I=$O(@ORMSG@(I)) Q:I'>0 S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC" I SEG="OBR" S X=I Q - Q X - ; -SC ; -- Status changed (i.e. scheduled) - S:'$G(ORSTS) ORSTS=6 D STATUS^ORCSAVE2(+ORIFN,ORSTS) ; 6=active - Q - ; -STATUS(X) ; -- Returns ptr to Order Status file #100.01 - Q $S(X="DC":1,X="CM":2,X="HD":3,X="IP":5,X="SC":6,X="A":9,X="RP":12,X="CA":13,X="ZC":8,1:5) - ; -RE ; -- Completed, w/results - N I,SEG,DA,DR,DIE,X,Y - S:'$G(ORSTS) ORSTS=2 D STATUS^ORCSAVE2(+ORIFN,ORSTS) - S X="",DA=+ORIFN,DIE="^OR(100," - S DR="71////"_+$E($$NOW^XLFDT,1,12) D ^DIE - S I=+ORC,X="" F S I=$O(@ORMSG@(I)) Q:I<1 S SEG=$G(@ORMSG@(I)) Q:$E(SEG,1,3)="ORC" I $E(SEG,1,3)="OBX",$P(SEG,"|",4)["SIG FINDINGS" S X=$P(SEG,"|",6) Q - S $P(^OR(100,DA,7),U,2)=$S(X="Y":1,1:"") - S:'$G(ORNP) ORNP=+$P($G(^OR(100,+ORIFN,0)),U,4) - I $P(ORC,"|",17)["MAINTENANCE" Q ;group update - no CM ack needed - I $L($T(ADD^ORRCACK)) D ADD^ORRCACK(+ORIFN,ORNP) ;Ack stub for prov - Q - ; -UA ; -- Unable to Accept [ack] - S ORDUZ="" I '$L(OREASON1),$L(OREASON) S OREASON1=OREASON -OC ; -- Cancelled/Denied - S:'$L(ORNATR) ORNATR="X" ;Rejected - S ^OR(100,+ORIFN,6)=$O(^ORD(100.02,"C",ORNATR,0))_U_ORDUZ_U_ORLOG_U_U_OREASON1 - D STATUS^ORCSAVE2(+ORIFN,13) I ORDCNTRL="OC" D UPDATE("DC") Q -UD ; -- Unable to discontinue [ack] - N DA S DA=$P(ORIFN,";",2) I DA D - . S $P(^OR(100,+ORIFN,8,DA,0),U,15)=13 ;request rejected - . S:$L(OREASON1) ^OR(100,+ORIFN,8,DA,1)=OREASON1 - Q - ; -OD ; -- Discontinued - S ^OR(100,+ORIFN,6)=$S($L(ORNATR):$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORDUZ_U_ORLOG_U_U_OREASON1 - D STATUS^ORCSAVE2(+ORIFN,1),UPDATE("DC"):$L(ORNATR) - Q - ; -DR ; -- Discontinued [ack] - D STATUS^ORCSAVE2(+ORIFN,1) - Q - ; -UPDATE(ORACT) ; -- continue processing - N ORX,ORDA,ORP - S ORX=$$CREATE^ORX1(ORNATR) D:ORX - . S ORDA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,OREASON1,ORLOG,ORDUZ) - . I ORDA'>0 S ORERR="Cannot create new order action" Q - . D RELEASE^ORCSAVE2(+ORIFN,ORDA,ORLOG,ORDUZ,ORNATR) - . D SIGSTS^ORCSAVE2(+ORIFN,ORDA) - . I $G(ORL) S ORP(1)=+ORIFN_";"_ORDA_"^1" D PRINTS^ORWD1(.ORP,+ORL) - . S $P(^OR(100,+ORIFN,3),U,7)=ORDA - I 'ORX,ORACT="DC",'$$ACTV^ORX1(ORNATR) S $P(^OR(100,+ORIFN,3),U,7)=0 - D:$G(ORACT)="DC" CANCEL^ORCSEND(+ORIFN) - Q - ; -PTR(X) ; -- Returns ptr to prompt in Order Dialog file #101.41 - Q $O(^ORD(101.41,"AB",$E("OR GTX "_X,1,63),0)) +ORMGMRC ; SLC/MKB - Process Consult ORM msgs ;7/14/04 13:29 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,26,68,92,153,174,195,255**;Dec 17, 1997 +EN ; -- entry point for GMRC messges + I '$L($T(@ORDCNTRL)) Q ;S ORERR="Invalid order control code" Q + I ORDCNTRL'="SN",ORDCNTRL'="ZP",'ORIFN!('$D(^OR(100,+ORIFN,0))) S ORERR="Invalid OE/RR order number" Q + S:ORDCNTRL="OC"&(ORTYPE="ORR") ORDCNTRL="UA" ;new code + N ORSTS,OREASON1,NTE S ORSTS=$$STATUS(ORDSTS) + S:'ORLOG ORLOG=$$NOW^XLFDT S:'ORDUZ ORDUZ=DUZ S:$G(DGPMT) ORDUZ="" + S OREASON=$P(OREASON,U,5),NTE=$O(@ORMSG@(+ORC)),OREASON1="" + I NTE,$E(@ORMSG@(NTE),1,3)="NTE" S OREASON1=$P(@ORMSG@(NTE),"|",4) + D @ORDCNTRL + Q + ; +ZP ; -- Purged + Q:'ORIFN Q:'$D(^OR(100,+ORIFN,0)) + K ^OR(100,+ORIFN,4) I "^3^5^6^8^"[(U_$P($G(^(3)),U,3)_U) D STATUS^ORCSAVE2(+ORIFN,14) ; Remove pkg reference, sts=lapsed if still active + Q + ; +ZR ; -- Purged as requested [ack] + D DELETE^ORCSAVE2(+ORIFN) + Q + ; +ZU ; -- Unable to purge [ack] + S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ; update Last Activity + Q + ; +OK ; -- Order accepted, GMRC order # assigned [ack] + S ^OR(100,+ORIFN,4)=PKGIFN S:'$G(ORSTS) ORSTS=5 + D STATUS^ORCSAVE2(+ORIFN,ORSTS) ; 5=pending + D DATES^ORCSAVE2(+ORIFN,+$E($$NOW^XLFDT,1,12)) + Q + ; +XX ; -- Change order + N ORDIALOG,ORDG,ORDA,ORX,ORP,ORSIG S:'$L(ORNATR) ORNATR="S" + D DLG Q:$D(ORERR) Q:'$D(ORDIALOG) S ORIFN=+ORIFN + S ORDA=$$ACTION^ORCSAVE("XX",ORIFN,ORNP,OREASON1,ORLOG,ORDUZ) + I ORDA'>0 S ORERR="Cannot create new order action" Q + ; -Update sts of order to active, last action to dc/edit: + S ORX=+$P($G(^OR(100,ORIFN,3)),U,7) S:ORX'>0 ORX=+$O(^(8,ORDA),-1) + I $D(^OR(100,ORIFN,8,ORX,0)),$P(^(0),U,15)="" S $P(^(0),U,15)=12 + S $P(^OR(100,ORIFN,3),U,7)=ORDA D:$G(ORSTS) STATUS^ORCSAVE2(ORIFN,ORSTS) + D PXRMKILL^ORDD100(ORIFN,ORVP,ORLOG) ; JEH 255 + D RELEASE^ORCSAVE2(ORIFN,ORDA,ORLOG,ORDUZ,ORNATR) + ; -If unsigned edit, leave XX unsigned & mark ORX as Sig Not Req'd + S ORSIG=$S($P($G(^OR(100,ORIFN,8,ORX,0)),U,4)'=2:1,1:0) + D SIGSTS^ORCSAVE2(ORIFN,ORDA):ORSIG,SIGN^ORCSAVE2(ORIFN,,,5,ORX):'ORSIG + ; -Update responses, get/save new order text: + K ^OR(100,ORIFN,4.5) D RESPONSE^ORCSAVE,ORDTEXT^ORCSAVE1(ORIFN_";"_ORDA) + S $P(^OR(100,ORIFN,8,ORDA,0),U,14)=ORDA + K:OREASON="RESUBMIT" ^OR(100,ORIFN,6) ;clear previous DC data + D PXRMADD^ORDD100(ORIFN,ORVP,ORLOG) ; JEH 255 + I $G(ORL) S ORP(1)=+ORIFN_";"_ORDA_"^1" D PRINTS^ORWD1(.ORP,+ORL) + Q + ; +SN ; -- New backdoor order: return NA msg w/ORIFN, or DE msg + N ORDIALOG,ORDG,ORP K ^TMP("ORWORD",$J) S:'$L(ORNATR) ORNATR="W" + I '$D(^VA(200,ORNP,0)) S ORERR="Missing or invalid ordering provider" Q + I ORDUZ,'$D(^VA(200,ORDUZ,0)) S ORERR="Invalid entering person" Q + I '$G(ORL) S ORERR="Missing or invalid patient location" Q + D DLG Q:$D(ORERR) Q:'$D(ORDIALOG) +SN1 D EN^ORCSAVE K ^TMP("ORWORD",$J) ; setting status, xrefs + I '$G(ORIFN) S ORERR="Cannot create new order" Q + ;Save DG1 and ZCL segments of HL7 message from backdoor orders + D BDOSTR^ORWDBA3 + D RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR),SIGSTS^ORCSAVE2(ORIFN,1) + S:'ORSTRT ORSTRT=$$NOW^XLFDT D DATES^ORCSAVE2(+ORIFN,ORSTRT) + D:$G(ORSTS) STATUS^ORCSAVE2(ORIFN,ORSTS) + I $G(ORL) S ORP(1)=ORIFN_";1^1" D PRINTS^ORWD1(.ORP,+ORL) ; chart copy + S ^OR(100,ORIFN,4)=PKGIFN + Q + ; +DLG ; -- Build ORDIALOG(),ORDG from msg + N OBR,USID,TYPE,OI,ZSV,J,OBX,WP,I + S OBR=$$OBR I 'OBR!($E($G(@ORMSG@(OBR)),1,3)'="OBR") S ORERR="Missing OBR segment" Q + S USID=$P(@ORMSG@(OBR),"|",5),TYPE=$S(USID["99CON":"CONSULT",1:"REQUEST") + S ORDIALOG=$O(^ORD(101.41,"AB","GMRCOR "_TYPE,0)) + D GETDLG1^ORCD(ORDIALOG) + S ORDIALOG($$PTR("URGENCY"),1)=ORURG + S OI=$$ORDITEM^ORM(USID) I 'OI S ORERR="Invalid consult or procedure" Q + S ORDIALOG($$PTR("ORDERABLE ITEM"),1)=OI + S ZSV=$O(@ORMSG@(OBR)) I ZSV,$E(@ORMSG@(ZSV),1,3)="ZSV" D + . N X1,X2 S X1=$P(@ORMSG@(ZSV),"|",2),X2=$P(@ORMSG@(ZSV),"|",3) + . I TYPE="REQUEST" S ORDIALOG($$PTR("REQUEST SERVICE"),1)=+$P(X1,U,4) + . I TYPE="CONSULT",$L(X2) S ORDIALOG($$PTR("FREE TEXT OI"),1)=X2 +D1 S ORDIALOG($$PTR("CATEGORY"),1)=$G(ORCAT) + S J=$P(@ORMSG@(OBR),"|",19),ORDIALOG($$PTR("PLACE OF CONSULTATION"),1)=$S(J="OC":"C",1:J) + S ORDIALOG($$PTR("PROVIDER"),1)=$P(@ORMSG@(OBR),"|",20) + S OBX=OBR F S OBX=$O(@ORMSG@(OBX)) Q:OBX'>0 S J=$E(@ORMSG@(OBX),1,3) Q:J="ORC" Q:J="MSH" I J="OBX" D + . N SEG,NAME,VALUE S SEG=@ORMSG@(OBX) + . S NAME=$$UP^XLFSTR($P($P(SEG,"|",4),U,2)),VALUE=$P(SEG,"|",6) + . I NAME="PROVISIONAL DIAGNOSIS" D Q + .. S:$P(SEG,"|",3)="CE" ORDIALOG($$PTR("CODE"),1)=$P(VALUE,U),VALUE=$P(VALUE,U,2) + .. S ORDIALOG($$PTR("FREE TEXT"),1)=VALUE + . S WP=$$PTR("WORD PROCESSING 1"),I=1,^TMP("ORWORD",$J,WP,1,I,0)=VALUE + . S J=0 F S J=$O(@ORMSG@(OBX,J)) Q:J'>0 S I=I+1,^TMP("ORWORD",$J,WP,1,I,0)=@ORMSG@(OBX,J) + S:$G(I) ^TMP("ORWORD",$J,WP,1,0)="^^"_I_U_I_U_DT_U,ORDIALOG(WP,1)="^TMP(""ORWORD"",$J,"_WP_",1)" + Q + ; +OBR() ; -- Return subscript of RXE segment + N X,I,SEG S X="",I=+ORC + F S I=$O(@ORMSG@(I)) Q:I'>0 S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC" I SEG="OBR" S X=I Q + Q X + ; +SC ; -- Status changed (i.e. scheduled) + S:'$G(ORSTS) ORSTS=6 D STATUS^ORCSAVE2(+ORIFN,ORSTS) ; 6=active + Q + ; +STATUS(X) ; -- Returns ptr to Order Status file #100.01 + Q $S(X="DC":1,X="CM":2,X="HD":3,X="IP":5,X="SC":6,X="A":9,X="RP":12,X="CA":13,X="ZC":8,1:5) + ; +RE ; -- Completed, w/results + N I,SEG,DA,DR,DIE,X,Y + S:'$G(ORSTS) ORSTS=2 D STATUS^ORCSAVE2(+ORIFN,ORSTS) + S X="",DA=+ORIFN,DIE="^OR(100," + S DR="71////"_+$E($$NOW^XLFDT,1,12) D ^DIE + S I=+ORC,X="" F S I=$O(@ORMSG@(I)) Q:I<1 S SEG=$G(@ORMSG@(I)) Q:$E(SEG,1,3)="ORC" I $E(SEG,1,3)="OBX",$P(SEG,"|",4)["SIG FINDINGS" S X=$P(SEG,"|",6) Q + S $P(^OR(100,DA,7),U,2)=$S(X="Y":1,1:"") + S:'$G(ORNP) ORNP=+$P($G(^OR(100,+ORIFN,0)),U,4) + I $P(ORC,"|",17)["MAINTENANCE" Q ;group update - no CM ack needed + I $L($T(ADD^ORRCACK)) D ADD^ORRCACK(+ORIFN,ORNP) ;Ack stub for prov + Q + ; +UA ; -- Unable to Accept [ack] + S ORDUZ="" I '$L(OREASON1),$L(OREASON) S OREASON1=OREASON +OC ; -- Cancelled/Denied + S:'$L(ORNATR) ORNATR="X" ;Rejected + S ^OR(100,+ORIFN,6)=$O(^ORD(100.02,"C",ORNATR,0))_U_ORDUZ_U_ORLOG_U_U_OREASON1 + D STATUS^ORCSAVE2(+ORIFN,13) I ORDCNTRL="OC" D UPDATE("DC") Q +UD ; -- Unable to discontinue [ack] + N DA S DA=$P(ORIFN,";",2) I DA D + . S $P(^OR(100,+ORIFN,8,DA,0),U,15)=13 ;request rejected + . S:$L(OREASON1) ^OR(100,+ORIFN,8,DA,1)=OREASON1 + Q + ; +OD ; -- Discontinued + S ^OR(100,+ORIFN,6)=$S($L(ORNATR):$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORDUZ_U_ORLOG_U_U_OREASON1 + D STATUS^ORCSAVE2(+ORIFN,1),UPDATE("DC"):$L(ORNATR) + Q + ; +DR ; -- Discontinued [ack] + D STATUS^ORCSAVE2(+ORIFN,1) + Q + ; +UPDATE(ORACT) ; -- continue processing + N ORX,ORDA,ORP + S ORX=$$CREATE^ORX1(ORNATR) D:ORX + . S ORDA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,OREASON1,ORLOG,ORDUZ) + . I ORDA'>0 S ORERR="Cannot create new order action" Q + . D RELEASE^ORCSAVE2(+ORIFN,ORDA,ORLOG,ORDUZ,ORNATR) + . D SIGSTS^ORCSAVE2(+ORIFN,ORDA) + . I $G(ORL) S ORP(1)=+ORIFN_";"_ORDA_"^1" D PRINTS^ORWD1(.ORP,+ORL) + . S $P(^OR(100,+ORIFN,3),U,7)=ORDA + I 'ORX,ORACT="DC",'$$ACTV^ORX1(ORNATR) S $P(^OR(100,+ORIFN,3),U,7)=0 + D:$G(ORACT)="DC" CANCEL^ORCSEND(+ORIFN) + Q + ; +PTR(X) ; -- Returns ptr to prompt in Order Dialog file #101.41 + Q $O(^ORD(101.41,"AB",$E("OR GTX "_X,1,63),0)) diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMLR.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMLR.m index 5ddcffd1..1a9387ac 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMLR.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMLR.m @@ -1,188 +1,187 @@ -ORMLR ; SLC/MKB - Process Lab ORM msgs ;11:59 AM 26 Jul 2000 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,92,153,174,195,243**;Dec 17, 1997;Build 242 -EN ; -- entry point for LR messages - I '$L($T(@ORDCNTRL)) Q ;S ORERR="Invalid order control code" Q - I ORDCNTRL'="SN",ORDCNTRL'="ZC",ORDCNTRL'="ZP" D Q:$L($G(ORERR)) - . I 'ORIFN!('$D(^OR(100,+ORIFN,0))) S ORERR="Invalid OE/RR order number" Q - . S ORDUZ=DUZ,ORLOG=+$E($$NOW^XLFDT,1,12) - S OREASON=$$REASON I 'ORNATR,OREASON S ORNATR=+$P($G(^ORD(100.03,+OREASON,0)),U,7) - D @ORDCNTRL - Q - ; -STATUS(X) ; -- Returns Order Status for HL7 code X - N Y S Y=$S(X="DC":1,X="CM":2,X="IP":5,X="SC":6,X="ZS":9,X="CA":13,1:"") - Q Y - ; -OK ; -- Order accepted, LR order # assigned [ack] - S ^OR(100,+ORIFN,4)=PKGIFN ; LR identifier - D STATUS^ORCSAVE2(+ORIFN,5) ; pending - Q - ; -ZC ; -- Convert existing 2.5 orders to 3.0 format - S ORNATR="" I 'ORIFN!('$D(^OR(100,+ORIFN,0))) D Q ;create - . K ORIFN D SN Q:'$G(ORIFN) S ORDCNTRL="SN" - . I ORSTOP,ORSTOP<$$NOW^XLFDT S $P(^OR(100,+ORIFN,3),U)=ORSTOP - N ORDIALOG,I,X,OBR,NTE S ORIFN=+ORIFN - S I=+ORC F S I=$O(@ORMSG@(I)) Q:'I S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC" Q:SEG="MSH" I SEG="OBR" S OBR=I Q - I '$G(OBR) S ORERR="Missing OBR segment" Q - S ORDIALOG=+$O(^ORD(101.41,"AB","LR OTHER LAB TESTS",0)) - D GETDLG1^ORCD(ORDIALOG) - S X=$$FIND^ORM(OBR,5),X=$$ORDITEM^ORM(X) I 'X S ORERR="Invalid test" Q - S ORDIALOG($$PTR("ORDERABLE ITEM"),1)=X,X=$$FIND^ORM(OBR,16) - S ORDIALOG($$PTR("COLLECTION SAMPLE"),1)=$P(X,";",4) - S ORDIALOG($$PTR("SPECIMEN"),1)=$S($L($P(X,";")):+$O(^LAB(61,"C",$P(X,";"),0)),1:+$P(X,U,4)) - S X=$$FIND^ORM(OBR,28),ORDIALOG($$PTR("LAB URGENCY"),1)=+$P($P(X,U,6),";",2) - S X=$$FIND^ORM(OBR,12),ORDIALOG($$PTR("COLLECTION TYPE"),1)=$S(X="L":"LC",X="O":"WC",X=2:"I",1:"SP") -ZC1 S NTE=$O(@ORMSG@(OBR)) I NTE,$E(@ORMSG@(NTE),1,3)="NTE" D - . N LCNT,WP S WP=$$PTR("WORD PROCESSING 1") K ^TMP("ORWORD",$J) - . S LCNT=1,^TMP("ORWORD",$J,WP,1,LCNT,0)=$P(@ORMSG@(NTE),"|",4) - . S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S LCNT=LCNT+1,^TMP("ORWORD",$J,WP,1,LCNT,0)=@ORMSG@(NTE,I) - . S ^TMP("ORWORD",$J,WP,1,0)="^^"_LCNT_U_LCNT_U_DT_U - . S ORDIALOG(WP,1)="^TMP(""ORWORD"","_$J_","_WP_",1)" - S ORDIALOG($$PTR("START DATE/TIME"),1)=ORSTRT - S ^OR(100,ORIFN,4)=PKGIFN,$P(^(0),U,5)=+ORDIALOG_";ORD(101.41," - D RESPONSE^ORCSAVE ; save ORDIALOG() into ^(4.5) - K ^TMP("ORWORD",$J) - Q - ; -SN ; -- New backdoor order: return NA msg w/ORIFN, or DE msg - N X,ORDIALOG,ORDG,OBR,NTE,CMMT,OI,LCNT,I,ORSTS,LRSUB,ORNEW,ORP - I ORDUZ,'$D(^VA(200,+ORDUZ,0)) S ORERR="Invalid entering person" Q - ; I '$G(ORL) S ORERR="Missing or invalid patient location" Q - ;S LRSUB=$E($P($P(@ORMSG@(+ORC),"|",4),U,2),3,4),ORDG=$$DGRP(LRSUB) - S ORDIALOG="LR OTHER LAB TESTS" ; $S(LRSUB="AP",LRSUB="BB") - S ORDIALOG=$O(^ORD(101.41,"AB",ORDIALOG,0)) D GETDLG1^ORCD(ORDIALOG) - S ORDIALOG($$PTR("START DATE/TIME"),1)=ORSTRT - S CMMT=$$PTR("WORD PROCESSING 1") K ^TMP("ORWORD",$J) -SN1 S OBR=$O(@ORMSG@(+ORC)) I 'OBR!($E($G(@ORMSG@(OBR)),1,3)'="OBR") S ORERR="Missing OBR segment" Q - S X=$$FIND^ORM(OBR,5),OI=$$ORDITEM^ORM(X) I 'OI S ORERR="Invalid test" Q - S LRSUB=$P(^ORD(101.43,OI,"LR"),U,6),ORDG=$$DGRP(LRSUB) - S ORDIALOG($$PTR("ORDERABLE ITEM"),1)=OI - I LRSUB="BB" S ORDIALOG($$PTR("QUANTITY"),1)=+ORQT G SN2 - S X=$$FIND^ORM(OBR,16),ORDIALOG($$PTR("COLLECTION SAMPLE"),1)=$P(X,";",4) - S ORDIALOG($$PTR("SPECIMEN"),1)=$S($L($P(X,";")):$O(^LAB(61,"C",$P(X,";"),0)),1:+$P(X,U,4)) - S X=+$P($P($$FIND^ORM(OBR,28),U,6),";",2),ORDIALOG($$PTR("LAB URGENCY"),1)=$S(X:X,1:9) - S X=$$FIND^ORM(OBR,12),ORDIALOG($$PTR("COLLECTION TYPE"),1)=$S(X="L":"LC",X="O":"WC",X=2:"I",1:"SP") -SN2 S NTE=$O(@ORMSG@(+OBR)) I NTE,$E(@ORMSG@(NTE),1,3)="NTE" D - . S LCNT=1,^TMP("ORWORD",$J,CMMT,1,LCNT,0)=$P(@ORMSG@(NTE),"|",4) - . I $O(@ORMSG@(NTE,0)) S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S LCNT=LCNT+1,^TMP("ORWORD",$J,CMMT,1,LCNT,0)=@ORMSG@(NTE,I) - . S ^TMP("ORWORD",$J,CMMT,1,0)="^^"_LCNT_U_LCNT_U_DT_U,ORDIALOG(CMMT,1)="^TMP(""ORWORD"",$J,"_CMMT_",1)" -SNQ D EN^ORCSAVE K ^TMP("ORWORD",$J) - I '$G(ORIFN) S ORERR="Cannot create new order" Q - ;Save DG1 and ZCL segments of HL7 message from backdoor orders - D BDOSTR^ORWDBA3 - D RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR),SIGSTS^ORCSAVE2(ORIFN,1) - D:ORSTOP DATES^ORCSAVE2(ORIFN,,ORSTOP) ;Start date in order itself - S ORSTS=$$STATUS(ORDSTS) D:ORSTS STATUS^ORCSAVE2(ORIFN,ORSTS) - I ORDCNTRL="SN",$G(ORL) S ORP(1)=ORIFN_";1^1" D PRINTS^ORWD1(.ORP,+ORL) - S ^OR(100,ORIFN,4)=PKGIFN - Q - ; -PTR(NAME) ; -- Returns ien of prompt NAME in Order Dialog file #101.41 - Q $O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0)) - ; -DGRP(DG) ; -- Returns Display Group ptr based on Lab section - N Y S:'$L($G(DG)) DG="CH" S Y=$O(^ORD(100.98,"B",DG,0)) - S:'Y Y=$O(^ORD(100.98,"B","LAB",0)) - Q Y - ; -XX ; -- Changed: NOT IN USE - D XX^ORMLR1 - Q - ; -XR ; -- Changed [ack]: NOT IN USE - N ORIG - S ^OR(100,+ORIFN,4)=PKGIFN,ORIG=$P(^(3),U,5) - D:ORIG STATUS^ORCSAVE2(ORIG,12) - D STATUS^ORCSAVE2(+ORIFN,5) ; pending - Q - ; -ZP ; -- Purged - Q:'ORIFN Q:'$D(^OR(100,+ORIFN,0)) - S $P(^OR(100,+ORIFN,4),";",1,3)=";;" I "^5^6^"[(U_$P($G(^(3)),U,3)_U) D STATUS^ORCSAVE2(+ORIFN,$S($P(^(4),";",5):2,1:14)) ; Remove pkg reference, sts=lapsed if still active - Q - ; -ZR ; -- Purged as requested [ack] - D DELETE^ORCSAVE2(+ORIFN) - Q - ; -ZU ; -- Unable to purge [ack] - S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ; update Last Activity - Q - ; -SC ; -- Status changed (collected) - N ORSTS D DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP) - S ORSTS=$$STATUS(ORDSTS) D:ORSTS STATUS^ORCSAVE2(+ORIFN,ORSTS) - S:$L($P(OREASON,U,2)) ^OR(100,+ORIFN,8,1,1)=$P(OREASON,U,2) - Q - ; -RE ; -- Completed, w/results - N ORSTS,ORX,I,SEG,DONE,X,Y,ORABN,ORFIND,LRSA,LRSB - S ORSTS=$$STATUS(ORDSTS) D:ORSTS STATUS^ORCSAVE2(+ORIFN,ORSTS) - S ^OR(100,+ORIFN,4)=PKGIFN,ORX="" D ;get Results D/T [from OBR] - . N OBR S OBR=+$O(@ORMSG@(+ORC)),X="" - . I OBR,$E($G(@ORMSG@(OBR)),1,3)="OBR" S X=$P(@ORMSG@(OBR),"|",23) - . S X=$S(X:$$FMDATE^ORM(X),1:+$E($$NOW^XLFDT,1,12)) - . S $P(^OR(100,+ORIFN,7),U)=X,^OR(100,"ARS",ORVP,9999999-X,+ORIFN)="" - D RR^LR7OR1(DFN,PKGIFN) - S ORABN="",ORFIND="" - I $D(^TMP("LRRR",$J)) D - . N IDT,DNAM,ORSLT - . S IDT=0 F S IDT=$O(^TMP("LRRR",$J,DFN,"CH",IDT)) Q:'IDT D - .. S DNAM=0 F S DNAM=$O(^TMP("LRRR",$J,DFN,"CH",IDT,DNAM)) Q:'DNAM D - ... S ORSLT=$G(^TMP("LRRR",$J,DFN,"CH",IDT,DNAM)) - ... I '$L($P(ORSLT,U,3)) Q - ... S ORABN=1,ORFIND=$S($L(ORFIND):(ORFIND_", "),1:"") - ... S ORFIND=ORFIND_$P(ORSLT,U,15)_"="_$P(ORSLT,U,2) - . Q - K ^TMP("LRRR",$J),^TMP("LRX",$J) - S $P(^OR(100,+ORIFN,7),U,2,3)=ORABN_U_ORFIND - S:'$G(ORNP) ORNP=+$P($G(^OR(100,+ORIFN,0)),U,4) - I $L($T(ADD^ORRCACK)) D ADD^ORRCACK(+ORIFN,ORNP) ;Ack stub for prov - Q - ; -OC ; -- Cancelled - G:ORTYPE="ORR" UA S:ORNATR=+$O(^ORD(100.02,"C","A",0)) ORDUZ="" - S ^OR(100,+ORIFN,6)=ORNATR_U_ORDUZ_U_ORLOG_U_$P(OREASON,U)_U_$E($P(OREASON,U,2),1,80) - D UPDATE(1,"DC") - Q - ; -CR ; -- Cancelled [ack] - D STATUS^ORCSAVE2(+ORIFN,1) - Q - ; -UA ; -- Unable to accept [ack] -UX ; -- Unable to change [ack]: NOT IN USE - S:'ORNATR ORNATR=$O(^ORD(100.02,"C","X",0)) ;rejected - S ^OR(100,+ORIFN,6)=ORNATR_U_U_ORLOG_U_$P(OREASON,U)_U_$E($P(OREASON,U,2),1,80) - D STATUS^ORCSAVE2(+ORIFN,13) -UC ; -- Unable to cancel [ack] -DE ; -- Data Error [ack] - N DA S DA=$P(ORIFN,";",2) Q:'DA - S $P(^OR(100,+ORIFN,8,DA,0),U,15)=13 ;request rejected - S:$L($P(OREASON,U,2)) ^OR(100,+ORIFN,8,DA,1)=$E($P(OREASON,U,2),1,240) - Q - ; -UPDATE(ORSTS,ORACT) ; -- continue processing - N DA,ORX,ORCMMT,ORP - D DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP) - D:$G(ORSTS) STATUS^ORCSAVE2(+ORIFN,ORSTS) - S ORCMMT=$E($P(OREASON,U,2),1,240),ORX=$$CREATE^ORX1(ORNATR) D:ORX - . S DA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,ORCMMT,ORLOG,ORDUZ) - . I DA'>0 S ORERR="Cannot create new order action" Q - . D RELEASE^ORCSAVE2(+ORIFN,DA,ORLOG,ORDUZ,ORNATR) - . D SIGSTS^ORCSAVE2(+ORIFN,DA) - . I $G(ORL) S ORP(1)=+ORIFN_";"_DA_"^1" D PRINTS^ORWD1(.ORP,+ORL) - . S $P(^OR(100,+ORIFN,3),U,7)=DA - I '$$ACTV^ORX1(ORNATR) S $P(^OR(100,+ORIFN,3),U,7)=0 - D:ORACT="DC" CANCEL^ORCSEND(+ORIFN) - Q - ; -REASON() ; -- Get reason from OREASON or NTE segments - N NTE,CMMT,X,Y,I,L - S NTE=+$O(@ORMSG@(+ORC)),CMMT=$P(OREASON,U,4,5) - G:'NTE RQ G:$E(@ORMSG@(NTE),1,3)'="NTE" RQ ; no add'l comments - S Y=$P(@ORMSG@(NTE),"|",4),I=0 - F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S X=$G(@ORMSG@(NTE,I)),L=$L(Y)+1+$L(X) S:L'>240 Y=Y_" "_X I L>240 S Y=Y_" "_$E(X,1,239-$L(Y)) Q - S $P(CMMT,U,2)=Y -RQ Q CMMT +ORMLR ; SLC/MKB - Process Lab ORM msgs ;11:59 AM 26 Jul 2000 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,92,153,174,195**;Dec 17, 1997 +EN ; -- entry point for LR messages + I '$L($T(@ORDCNTRL)) Q ;S ORERR="Invalid order control code" Q + I ORDCNTRL'="SN",ORDCNTRL'="ZC",ORDCNTRL'="ZP" D Q:$L($G(ORERR)) + . I 'ORIFN!('$D(^OR(100,+ORIFN,0))) S ORERR="Invalid OE/RR order number" Q + . S ORDUZ=DUZ,ORLOG=+$E($$NOW^XLFDT,1,12) + S OREASON=$$REASON I 'ORNATR,OREASON S ORNATR=+$P($G(^ORD(100.03,+OREASON,0)),U,7) + D @ORDCNTRL + Q + ; +STATUS(X) ; -- Returns Order Status for HL7 code X + N Y S Y=$S(X="DC":1,X="CM":2,X="IP":5,X="SC":6,X="ZS":9,X="CA":13,1:"") + Q Y + ; +OK ; -- Order accepted, LR order # assigned [ack] + S ^OR(100,+ORIFN,4)=PKGIFN ; LR identifier + D STATUS^ORCSAVE2(+ORIFN,5) ; pending + Q + ; +ZC ; -- Convert existing 2.5 orders to 3.0 format + S ORNATR="" I 'ORIFN!('$D(^OR(100,+ORIFN,0))) D Q ;create + . K ORIFN D SN Q:'$G(ORIFN) S ORDCNTRL="SN" + . I ORSTOP,ORSTOP<$$NOW^XLFDT S $P(^OR(100,+ORIFN,3),U)=ORSTOP + N ORDIALOG,I,X,OBR,NTE S ORIFN=+ORIFN + S I=+ORC F S I=$O(@ORMSG@(I)) Q:'I S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC" Q:SEG="MSH" I SEG="OBR" S OBR=I Q + I '$G(OBR) S ORERR="Missing OBR segment" Q + S ORDIALOG=+$O(^ORD(101.41,"AB","LR OTHER LAB TESTS",0)) + D GETDLG1^ORCD(ORDIALOG) + S X=$$FIND^ORM(OBR,5),X=$$ORDITEM^ORM(X) I 'X S ORERR="Invalid test" Q + S ORDIALOG($$PTR("ORDERABLE ITEM"),1)=X,X=$$FIND^ORM(OBR,16) + S ORDIALOG($$PTR("COLLECTION SAMPLE"),1)=$P(X,";",4) + S ORDIALOG($$PTR("SPECIMEN"),1)=$S($L($P(X,";")):+$O(^LAB(61,"C",$P(X,";"),0)),1:+$P(X,U,4)) + S X=$$FIND^ORM(OBR,28),ORDIALOG($$PTR("LAB URGENCY"),1)=+$P($P(X,U,6),";",2) + S X=$$FIND^ORM(OBR,12),ORDIALOG($$PTR("COLLECTION TYPE"),1)=$S(X="L":"LC",X="O":"WC",X=2:"I",1:"SP") +ZC1 S NTE=$O(@ORMSG@(OBR)) I NTE,$E(@ORMSG@(NTE),1,3)="NTE" D + . N LCNT,WP S WP=$$PTR("WORD PROCESSING 1") K ^TMP("ORWORD",$J) + . S LCNT=1,^TMP("ORWORD",$J,WP,1,LCNT,0)=$P(@ORMSG@(NTE),"|",4) + . S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S LCNT=LCNT+1,^TMP("ORWORD",$J,WP,1,LCNT,0)=@ORMSG@(NTE,I) + . S ^TMP("ORWORD",$J,WP,1,0)="^^"_LCNT_U_LCNT_U_DT_U + . S ORDIALOG(WP,1)="^TMP(""ORWORD"","_$J_","_WP_",1)" + S ORDIALOG($$PTR("START DATE/TIME"),1)=ORSTRT + S ^OR(100,ORIFN,4)=PKGIFN,$P(^(0),U,5)=+ORDIALOG_";ORD(101.41," + D RESPONSE^ORCSAVE ; save ORDIALOG() into ^(4.5) + K ^TMP("ORWORD",$J) + Q + ; +SN ; -- New backdoor order: return NA msg w/ORIFN, or DE msg + N X,ORDIALOG,ORDG,OBR,NTE,CMMT,OI,LCNT,I,ORSTS,LRSUB,ORNEW,ORP + I ORDUZ,'$D(^VA(200,+ORDUZ,0)) S ORERR="Invalid entering person" Q + ; I '$G(ORL) S ORERR="Missing or invalid patient location" Q + S LRSUB=$E($P($P(@ORMSG@(+ORC),"|",4),U,2),3,4),ORDG=$$DGRP(LRSUB) + S ORDIALOG="LR OTHER LAB TESTS" ; $S(LRSUB="AP",LRSUB="BB") + S ORDIALOG=$O(^ORD(101.41,"AB",ORDIALOG,0)) D GETDLG1^ORCD(ORDIALOG) + S ORDIALOG($$PTR("START DATE/TIME"),1)=ORSTRT + S CMMT=$$PTR("WORD PROCESSING 1") K ^TMP("ORWORD",$J) +SN1 S OBR=$O(@ORMSG@(+ORC)) I 'OBR!($E($G(@ORMSG@(OBR)),1,3)'="OBR") S ORERR="Missing OBR segment" Q + S X=$$FIND^ORM(OBR,5),OI=$$ORDITEM^ORM(X) I 'OI S ORERR="Invalid test" Q + S ORDIALOG($$PTR("ORDERABLE ITEM"),1)=OI + I LRSUB="BB" S ORDIALOG($$PTR("QUANTITY"),1)=+ORQT G SN2 + S X=$$FIND^ORM(OBR,16),ORDIALOG($$PTR("COLLECTION SAMPLE"),1)=$P(X,";",4) + S ORDIALOG($$PTR("SPECIMEN"),1)=$S($L($P(X,";")):$O(^LAB(61,"C",$P(X,";"),0)),1:+$P(X,U,4)) + S X=+$P($P($$FIND^ORM(OBR,28),U,6),";",2),ORDIALOG($$PTR("LAB URGENCY"),1)=$S(X:X,1:9) + S X=$$FIND^ORM(OBR,12),ORDIALOG($$PTR("COLLECTION TYPE"),1)=$S(X="L":"LC",X="O":"WC",X=2:"I",1:"SP") +SN2 S NTE=$O(@ORMSG@(+OBR)) I NTE,$E(@ORMSG@(NTE),1,3)="NTE" D + . S LCNT=1,^TMP("ORWORD",$J,CMMT,1,LCNT,0)=$P(@ORMSG@(NTE),"|",4) + . I $O(@ORMSG@(NTE,0)) S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S LCNT=LCNT+1,^TMP("ORWORD",$J,CMMT,1,LCNT,0)=@ORMSG@(NTE,I) + . S ^TMP("ORWORD",$J,CMMT,1,0)="^^"_LCNT_U_LCNT_U_DT_U,ORDIALOG(CMMT,1)="^TMP(""ORWORD"",$J,"_CMMT_",1)" +SNQ D EN^ORCSAVE K ^TMP("ORWORD",$J) + I '$G(ORIFN) S ORERR="Cannot create new order" Q + ;Save DG1 and ZCL segments of HL7 message from backdoor orders + D BDOSTR^ORWDBA3 + D RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR),SIGSTS^ORCSAVE2(ORIFN,1) + D:ORSTOP DATES^ORCSAVE2(ORIFN,,ORSTOP) ;Start date in order itself + S ORSTS=$$STATUS(ORDSTS) D:ORSTS STATUS^ORCSAVE2(ORIFN,ORSTS) + I ORDCNTRL="SN",$G(ORL) S ORP(1)=ORIFN_";1^1" D PRINTS^ORWD1(.ORP,+ORL) + S ^OR(100,ORIFN,4)=PKGIFN + Q + ; +PTR(NAME) ; -- Returns ien of prompt NAME in Order Dialog file #101.41 + Q $O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0)) + ; +DGRP(DG) ; -- Returns Display Group ptr based on Lab section + N Y S:'$L($G(DG)) DG="CH" S Y=$O(^ORD(100.98,"B",DG,0)) + S:'Y Y=$O(^ORD(100.98,"B","LAB",0)) + Q Y + ; +XX ; -- Changed: NOT IN USE + D XX^ORMLR1 + Q + ; +XR ; -- Changed [ack]: NOT IN USE + N ORIG + S ^OR(100,+ORIFN,4)=PKGIFN,ORIG=$P(^(3),U,5) + D:ORIG STATUS^ORCSAVE2(ORIG,12) + D STATUS^ORCSAVE2(+ORIFN,5) ; pending + Q + ; +ZP ; -- Purged + Q:'ORIFN Q:'$D(^OR(100,+ORIFN,0)) + S $P(^OR(100,+ORIFN,4),";",1,3)=";;" I "^5^6^"[(U_$P($G(^(3)),U,3)_U) D STATUS^ORCSAVE2(+ORIFN,$S($P(^(4),";",5):2,1:14)) ; Remove pkg reference, sts=lapsed if still active + Q + ; +ZR ; -- Purged as requested [ack] + D DELETE^ORCSAVE2(+ORIFN) + Q + ; +ZU ; -- Unable to purge [ack] + S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ; update Last Activity + Q + ; +SC ; -- Status changed (collected) + N ORSTS D DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP) + S ORSTS=$$STATUS(ORDSTS) D:ORSTS STATUS^ORCSAVE2(+ORIFN,ORSTS) + S:$L($P(OREASON,U,2)) ^OR(100,+ORIFN,8,1,1)=$P(OREASON,U,2) + Q + ; +RE ; -- Completed, w/results + N ORSTS,ORX,I,SEG,DONE,X,Y,ORABN,ORFIND,LRSA,LRSB + S ORSTS=$$STATUS(ORDSTS) D:ORSTS STATUS^ORCSAVE2(+ORIFN,ORSTS) + S ^OR(100,+ORIFN,4)=PKGIFN,ORX="" D ;get Results D/T [from OBR] + . N OBR S OBR=+$O(@ORMSG@(+ORC)),X="" + . I OBR,$E($G(@ORMSG@(OBR)),1,3)="OBR" S X=$P(@ORMSG@(OBR),"|",23) + . S X=$S(X:$$FMDATE^ORM(X),1:+$E($$NOW^XLFDT,1,12)) + . S $P(^OR(100,+ORIFN,7),U)=X,^OR(100,"ARS",ORVP,9999999-X,+ORIFN)="" + D RR^LR7OR1(DFN,PKGIFN) + S ORABN="",ORFIND="" + I $D(^TMP("LRRR",$J)) D + . N IDT,DNAM,ORSLT + . S IDT=0 F S IDT=$O(^TMP("LRRR",$J,DFN,"CH",IDT)) Q:'IDT D + .. S DNAM=0 F S DNAM=$O(^TMP("LRRR",$J,DFN,"CH",IDT,DNAM)) Q:'DNAM D + ... S ORSLT=$G(^TMP("LRRR",$J,DFN,"CH",IDT,DNAM)) + ... I '$L($P(ORSLT,U,3)) Q + ... S ORABN=1,ORFIND=$S($L(ORFIND):(ORFIND_", "),1:"") + ... S ORFIND=ORFIND_$P(ORSLT,U,15)_"="_$P(ORSLT,U,2) + . Q + K ^TMP("LRRR",$J),^TMP("LRX",$J) + S $P(^OR(100,+ORIFN,7),U,2,3)=ORABN_U_ORFIND + S:'$G(ORNP) ORNP=+$P($G(^OR(100,+ORIFN,0)),U,4) + I $L($T(ADD^ORRCACK)) D ADD^ORRCACK(+ORIFN,ORNP) ;Ack stub for prov + Q + ; +OC ; -- Cancelled + G:ORTYPE="ORR" UA S:ORNATR=+$O(^ORD(100.02,"C","A",0)) ORDUZ="" + S ^OR(100,+ORIFN,6)=ORNATR_U_ORDUZ_U_ORLOG_U_$P(OREASON,U)_U_$E($P(OREASON,U,2),1,80) + D UPDATE(1,"DC") + Q + ; +CR ; -- Cancelled [ack] + D STATUS^ORCSAVE2(+ORIFN,1) + Q + ; +UA ; -- Unable to accept [ack] +UX ; -- Unable to change [ack]: NOT IN USE + S:'ORNATR ORNATR=$O(^ORD(100.02,"C","X",0)) ;rejected + S ^OR(100,+ORIFN,6)=ORNATR_U_U_ORLOG_U_$P(OREASON,U)_U_$E($P(OREASON,U,2),1,80) + D STATUS^ORCSAVE2(+ORIFN,13) +UC ; -- Unable to cancel [ack] +DE ; -- Data Error [ack] + N DA S DA=$P(ORIFN,";",2) Q:'DA + S $P(^OR(100,+ORIFN,8,DA,0),U,15)=13 ;request rejected + S:$L($P(OREASON,U,2)) ^OR(100,+ORIFN,8,DA,1)=$E($P(OREASON,U,2),1,240) + Q + ; +UPDATE(ORSTS,ORACT) ; -- continue processing + N DA,ORX,ORCMMT,ORP + D DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP) + D:$G(ORSTS) STATUS^ORCSAVE2(+ORIFN,ORSTS) + S ORCMMT=$E($P(OREASON,U,2),1,240),ORX=$$CREATE^ORX1(ORNATR) D:ORX + . S DA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,ORCMMT,ORLOG,ORDUZ) + . I DA'>0 S ORERR="Cannot create new order action" Q + . D RELEASE^ORCSAVE2(+ORIFN,DA,ORLOG,ORDUZ,ORNATR) + . D SIGSTS^ORCSAVE2(+ORIFN,DA) + . I $G(ORL) S ORP(1)=+ORIFN_";"_DA_"^1" D PRINTS^ORWD1(.ORP,+ORL) + . S $P(^OR(100,+ORIFN,3),U,7)=DA + I 'ORX,'$$ACTV^ORX1(ORNATR) S $P(^OR(100,+ORIFN,3),U,7)=0 + D:ORACT="DC" CANCEL^ORCSEND(+ORIFN) + Q + ; +REASON() ; -- Get reason from OREASON or NTE segments + N NTE,CMMT,X,Y,I,L + S NTE=+$O(@ORMSG@(+ORC)),CMMT=$P(OREASON,U,4,5) + G:'NTE RQ G:$E(@ORMSG@(NTE),1,3)'="NTE" RQ ; no add'l comments + S Y=$P(@ORMSG@(NTE),"|",4),I=0 + F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S X=$G(@ORMSG@(NTE,I)),L=$L(Y)+1+$L(X) S:L'>240 Y=Y_" "_X I L>240 S Y=Y_" "_$E(X,1,239-$L(Y)) Q + S $P(CMMT,U,2)=Y +RQ Q CMMT diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMPS.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMPS.m index 763875fa..ac52c196 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMPS.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMPS.m @@ -1,237 +1,227 @@ -ORMPS ; SLC/MKB - Process Pharmacy ORM msgs ;02/06/2007 10:32 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,54,62,86,92,94,116,138,152,141,165,149,213,195,243**;Dec 17, 1997;Build 242 - ; -EN ; -- entry point - I '$L($T(@ORDCNTRL)) Q ;S ORERR="Invalid order control code" Q - I ORDCNTRL'="SN",ORDCNTRL'="ZC",ORDCNTRL'="ZP",'ORIFN!('$D(^OR(100,+ORIFN,0))) S ORERR="Invalid OE/RR order number" Q - N ORSTS,RXE,ZRX,ORWHO,ORNOW - S ORSTS=$$STATUS(ORDSTS),RXE=$$RXE,ZRX=$$ZRX D QT^ORMPS1 ;QT in RXE - S ORNOW=+$E($$NOW^XLFDT,1,12),ORWHO=+$P(ZRX,"|",6) S:'ORWHO ORWHO=DUZ - S:ORLOG ORLOG=+$E(ORLOG,1,12) ;no seconds - S:'$L(ORNATR) ORNATR=$P(ZRX,"|",3) S:OREASON["^" OREASON=$P(OREASON,U,5) - I ORNATR="D",'$L(OREASON) S OREASON="DUPLICATE" - D @ORDCNTRL - Q - ; -ZV ; -- Verified - N ORUSR,ORVER,ORDA,ORES,ORI - S ORUSR=+$P(ORC,"|",12),ORVER="N" Q:'ORUSR - S ORDA=+$P($G(^OR(100,+ORIFN,3)),U,7),ORES(+ORIFN_";"_ORDA)="" - Q:$P($G(^OR(100,+ORIFN,8,ORDA,0)),U,8) ;already verified - D REPLCD^ORCACT1 ;get unverified replaced orders - S ORI="" F S ORI=$O(ORES(ORI)) Q:ORI="" D - . S ORDA=+$P(ORI,";",2) - . D VERIFY^ORCSAVE2(+ORI,ORDA,"N",ORUSR,ORLOG) - Q - ; -ZP ; -- Purged - Q:'ORIFN Q:'$D(^OR(100,+ORIFN,0)) - K ^OR(100,+ORIFN,4) I "^3^5^6^15^"[(U_$P($G(^(3)),U,3)_U) D STATUS^ORCSAVE2(+ORIFN,14) ;Remove pkg reference, sts=lapsed if still active - Q - ; -ZR ; -- Purged as requested [ack] - D DELETE^ORCSAVE2(+ORIFN) - Q - ; -ZU ; -- Unable to purge [ack] - S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ;update Last Activity - Q - ; -XR ; -- Changed as requested [ack] - N ORIG S ORIG=$P(^OR(100,+ORIFN,3),U,5) I ORIG,$P(^OR(100,ORIG,3),U,3)'=12 D STATUS^ORCSAVE2(ORIG,12) -OK ; -- Order accepted, PS order # assigned [ack] - S ^OR(100,+ORIFN,4)=PKGIFN ;PS identifier - D:ORSTS STATUS^ORCSAVE2(+ORIFN,ORSTS) - Q - ; -ZC ; -- convert orders - N RXO,RXC,ORDIALOG,ORDG,ORPKG,ORP,ORSIG,ORIG,TYPE,EVNT - I '$D(^VA(200,ORDUZ,0)) S ORERR="Missing or invalid entering person" Q - I '$D(^VA(200,ORNP,0)) S ORERR="Missing or invalid ordering provider" Q - I 'RXE S ORERR="Missing or invalid RXE segment" Q - S RXO=$$RXO,RXC=$$RXC K ^TMP("ORWORD",$J) - D @($S(RXC:"IV",$G(ORCAT)="I":"UDOSE",1:"OUT")_"^ORMPS1") -ZC1 ; continue - Q:$D(ORERR) I 'ORIFN!('$D(^OR(100,+ORIFN,0))) D Q ;create - . K ORIFN D SN1 Q:'$G(ORIFN) S ORDCNTRL="SN" - . I ORSTOP,ORSTOPORNOW ORSTOP=ORNOW - D EXPDT,UPDATE(ORSTS,"DC") - Q - ; -CR ; -- Cancelled [ack] - D EXPDT ;save exp date, if past - D STATUS^ORCSAVE2(+ORIFN,13) S ^OR(100,+ORIFN,4)=PKGIFN - Q - ; -OD ; -- Discontinued (cancelled after pharmacist's verification) - S:'ORSTS ORSTS=1 S:ORSTS=12 ORNATR="C" - I ORNATR="A" S ORWHO="" I $G(DGPMT)=3,$$MVT^DGPMOBS(DGPMDA) D XTMP^ORMEVNT ;save order# - S $P(^OR(100,+ORIFN,6),U,1,5)=$S($L(ORNATR):$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORWHO_U_ORNOW_U_U_OREASON - S ^OR(100,+ORIFN,4)=PKGIFN S:ORSTOP>ORNOW ORSTOP=ORNOW - D EXPDT,UPDATE(ORSTS,"DC") - Q - ; -DR ; -- Discontinued [ack] - D EXPDT ;save exp date, if past - D STATUS^ORCSAVE2(+ORIFN,1) S ^OR(100,+ORIFN,4)=PKGIFN - Q - ; -EXPDT ; -- save exp date when dc'd - N STOP S STOP=$P($G(^OR(100,+ORIFN,0)),U,9) - I STOP,STOP0 S ORERR="Cannot create new order action" Q - . D RELEASE^ORCSAVE2(+ORIFN,ORDA,ORNOW,ORWHO,ORNATR) - . D SIGSTS^ORCSAVE2(+ORIFN,ORDA) - . I $G(ORL) S ORP(1)=+ORIFN_";"_ORDA_"^1" D PRINTS^ORWD1(.ORP,+ORL) - . S $P(^OR(100,+ORIFN,3),U,7)=ORDA - I ORACT="DC",'$$ACTV^ORX1(ORNATR) S $P(^OR(100,+ORIFN,3),U,7)=0 - D:$G(ORACT)="DC" CANCEL^ORCSEND(+ORIFN) - Q - ; -RXO() ; -- RXO segment - N I,X S X="",I=$O(@ORMSG@(+ORC)) - I I,$E(@ORMSG@(I),1,3)="RXO" S X=I_U_@ORMSG@(I) - Q X - ; -RXE() ; -- RXE segment - N X,I,SEG S X="",I=+ORC - F S I=$O(@ORMSG@(I)) Q:I'>0 S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC" I SEG="RXE" S X=I_U_@ORMSG@(I) Q - Q X - ; -RXR() ; -- RXR segment - N X,I,SEG S X="",I=+RXE - F S I=$O(@ORMSG@(I)) Q:I'>0 S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC" I SEG="RXR" S X=I_U_@ORMSG@(I) Q - Q X - ; -RXC() ; -- [First] RXC segment - N X,I,SEG S X="",I=+RXE - F S I=$O(@ORMSG@(I)) Q:I'>0 S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC" I SEG="RXC" S X=I Q - Q X - ; -ZRX() ; -- ZRX segment - N X,I,SEG S X="",I=+ORC - F S I=$O(@ORMSG@(I)) Q:I'>0 S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC" I SEG="ZRX" S X=I_U_@ORMSG@(I) Q - Q X +ORMPS ; SLC/MKB - Process Pharmacy ORM msgs ;12/3/03 10:32 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,54,62,86,92,94,116,138,152,141,165,149,213,195**;Dec 17, 1997 + ; +EN ; -- entry point + I '$L($T(@ORDCNTRL)) Q ;S ORERR="Invalid order control code" Q + I ORDCNTRL'="SN",ORDCNTRL'="ZC",ORDCNTRL'="ZP",'ORIFN!('$D(^OR(100,+ORIFN,0))) S ORERR="Invalid OE/RR order number" Q + N ORSTS,RXE,ZRX,ORWHO,ORNOW + S ORSTS=$$STATUS(ORDSTS),RXE=$$RXE,ZRX=$$ZRX D QT^ORMPS1 ;QT in RXE + S ORNOW=+$E($$NOW^XLFDT,1,12),ORWHO=+$P(ZRX,"|",6) S:'ORWHO ORWHO=DUZ + S:ORLOG ORLOG=+$E(ORLOG,1,12) ;no seconds + S:'$L(ORNATR) ORNATR=$P(ZRX,"|",3) S:OREASON["^" OREASON=$P(OREASON,U,5) + I ORNATR="D",'$L(OREASON) S OREASON="DUPLICATE" + D @ORDCNTRL + Q + ; +ZV ; -- Verified + N ORUSR,ORVER,ORDA,ORES,ORI + S ORUSR=+$P(ORC,"|",12),ORVER="N" Q:'ORUSR + S ORDA=+$P($G(^OR(100,+ORIFN,3)),U,7),ORES(+ORIFN_";"_ORDA)="" + Q:$P($G(^OR(100,+ORIFN,8,ORDA,0)),U,8) ;already verified + D REPLCD^ORCACT1 ;get unverified replaced orders + S ORI="" F S ORI=$O(ORES(ORI)) Q:ORI="" D + . S ORDA=+$P(ORI,";",2) + . D VERIFY^ORCSAVE2(+ORI,ORDA,"N",ORUSR,ORLOG) + Q + ; +ZP ; -- Purged + Q:'ORIFN Q:'$D(^OR(100,+ORIFN,0)) + K ^OR(100,+ORIFN,4) I "^3^5^6^15^"[(U_$P($G(^(3)),U,3)_U) D STATUS^ORCSAVE2(+ORIFN,14) ;Remove pkg reference, sts=lapsed if still active + Q + ; +ZR ; -- Purged as requested [ack] + D DELETE^ORCSAVE2(+ORIFN) + Q + ; +ZU ; -- Unable to purge [ack] + S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ;update Last Activity + Q + ; +XR ; -- Changed as requested [ack] + N ORIG S ORIG=$P(^OR(100,+ORIFN,3),U,5) I ORIG,$P(^OR(100,ORIG,3),U,3)'=12 D STATUS^ORCSAVE2(ORIG,12) +OK ; -- Order accepted, PS order # assigned [ack] + S ^OR(100,+ORIFN,4)=PKGIFN ;PS identifier + D:ORSTS STATUS^ORCSAVE2(+ORIFN,ORSTS) + Q + ; +ZC ; -- convert orders + N RXO,RXC,ORDIALOG,ORDG,ORPKG,ORP,ORSIG,ORIG,TYPE,EVNT + I '$D(^VA(200,ORDUZ,0)) S ORERR="Missing or invalid entering person" Q + I '$D(^VA(200,ORNP,0)) S ORERR="Missing or invalid ordering provider" Q + I 'RXE S ORERR="Missing or invalid RXE segment" Q + S RXO=$$RXO,RXC=$$RXC K ^TMP("ORWORD",$J) + D @($S(RXC:"IV",$G(ORCAT)="I":"UDOSE",1:"OUT")_"^ORMPS1") +ZC1 ; continue + Q:$D(ORERR) I 'ORIFN!('$D(^OR(100,+ORIFN,0))) D Q ;create + . K ORIFN D SN1 Q:'$G(ORIFN) S ORDCNTRL="SN" + . I ORSTOP,ORSTOPORNOW ORSTOP=ORNOW + D UPDATE(ORSTS,"DC") + Q + ; +CR ; -- Cancelled [ack] + D STATUS^ORCSAVE2(+ORIFN,13) S ^OR(100,+ORIFN,4)=PKGIFN + Q + ; +OD ; -- Discontinued (cancelled after pharmacist's verification) + S:'ORSTS ORSTS=1 S:ORSTS=12 ORNATR="C" + I ORNATR="A" S ORWHO="" I $G(DGPMT)=3,$$MVT^DGPMOBS(DGPMDA) D XTMP^ORMEVNT ;save order# + S ^OR(100,+ORIFN,6)=$S($L(ORNATR):$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORWHO_U_ORNOW_U_U_OREASON + S ^OR(100,+ORIFN,4)=PKGIFN S:ORSTOP>ORNOW ORSTOP=ORNOW + D UPDATE(ORSTS,"DC") + Q + ; +DR ; -- Discontinued [ack] + D STATUS^ORCSAVE2(+ORIFN,1) S ^OR(100,+ORIFN,4)=PKGIFN + Q + ; +OH ; -- Held + S:'ORSTS ORSTS=3 D UPDATE(ORSTS,"HD") + Q + ; +HR ; -- Held [ack] + D STATUS^ORCSAVE2(+ORIFN,3) + Q + ; +RL ; -- Released hold +OE ; -- Released hold + N ORDA S ORDA=+$P(^OR(100,+ORIFN,3),U,7) + I $P($G(^OR(100,+ORIFN,8,ORDA,0)),U,2)="HD" S $P(^(2),U,1,2)=ORNOW_U_ORWHO + S:'$G(ORSTS) ORSTS=6 D UPDATE(ORSTS,"RL") + Q + ; +OR ; -- Released / [ack] + S:'ORSTS ORSTS=6 D STATUS^ORCSAVE2(+ORIFN,ORSTS) + D:ORSTRT!ORSTOP DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP) + Q + ; +UPDATE(ORSTS,ORACT) ; -- continue + N ORX,ORDA,ORP D:$G(ORSTS) STATUS^ORCSAVE2(+ORIFN,ORSTS) + D:ORSTRT!ORSTOP DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP) + S ORX=$$CREATE^ORX1(ORNATR) D:ORX + . S ORDA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,OREASON,ORNOW,ORWHO) + . I ORDA'>0 S ORERR="Cannot create new order action" Q + . D RELEASE^ORCSAVE2(+ORIFN,ORDA,ORNOW,ORWHO,ORNATR) + . D SIGSTS^ORCSAVE2(+ORIFN,ORDA) + . I $G(ORL) S ORP(1)=+ORIFN_";"_ORDA_"^1" D PRINTS^ORWD1(.ORP,+ORL) + . S $P(^OR(100,+ORIFN,3),U,7)=ORDA + I 'ORX,ORACT="DC",'$$ACTV^ORX1(ORNATR) S $P(^OR(100,+ORIFN,3),U,7)=0 + D:$G(ORACT)="DC" CANCEL^ORCSEND(+ORIFN) + Q + ; +RXO() ; -- RXO segment + N I,X S X="",I=$O(@ORMSG@(+ORC)) + I I,$E(@ORMSG@(I),1,3)="RXO" S X=I_U_@ORMSG@(I) + Q X + ; +RXE() ; -- RXE segment + N X,I,SEG S X="",I=+ORC + F S I=$O(@ORMSG@(I)) Q:I'>0 S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC" I SEG="RXE" S X=I_U_@ORMSG@(I) Q + Q X + ; +RXR() ; -- RXR segment + N X,I,SEG S X="",I=+RXE + F S I=$O(@ORMSG@(I)) Q:I'>0 S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC" I SEG="RXR" S X=I_U_@ORMSG@(I) Q + Q X + ; +RXC() ; -- [First] RXC segment + N X,I,SEG S X="",I=+RXE + F S I=$O(@ORMSG@(I)) Q:I'>0 S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC" I SEG="RXC" S X=I Q + Q X + ; +ZRX() ; -- ZRX segment + N X,I,SEG S X="",I=+ORC + F S I=$O(@ORMSG@(I)) Q:I'>0 S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC" I SEG="ZRX" S X=I_U_@ORMSG@(I) Q + Q X diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMPS1.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMPS1.m index fdacf49c..a09c8cf7 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMPS1.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMPS1.m @@ -1,168 +1,175 @@ -ORMPS1 ;SLC/MKB - Process Pharmacy ORM msgs cont ; 3/27/08 7:38am - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**86,92,94,116,134,152,158,149,190,195,215,265,275,243**;Dec 17, 1997;Build 242 - ;;Per VHA Directive 2004-038, this routine should not be modified. -UDOSE ; -- new Unit Dose order - N ADMIN,QT,DRUG,INSTR,DOSE,RTE,SCH,OI,URG,WP,DUR,STR,DRGNM,X,PSOI,PSDD,S0,ID,LDOSE,XC,NTE,S0,RXR - S ORDIALOG=+$O(^ORD(101.41,"AB","PSJ OR PAT OE",0)) - I $G(ORAPPT)>0 S ORDG=+$O(^ORD(100.98,"B","CLINIC ORDERS",0)) - E S ORDG=+$O(^ORD(100.98,"B","UNIT DOSE MEDICATIONS",0)) - S ORPKG=+$$PKG("PSJ") - D GETDLG1^ORCD(ORDIALOG) S QT=$G(ORQT(1)) - S DRUG=$$PTR("DISPENSE DRUG"),INSTR=$$PTR("INSTRUCTIONS") - S DOSE=$$PTR("DOSE"),RTE=$$PTR("ROUTE") - S SCH=$$PTR("SCHEDULE"),ADMIN=$$PTR("ADMIN TIMES") - S OI=$$PTR("ORDERABLE ITEM"),URG=$$PTR("URGENCY") - S WP=$$PTR("WORD PROCESSING 1"),DUR=$$PTR("DURATION") - S STR=$$PTR("STRENGTH"),DRGNM=$$PTR("DRUG NAME") -UD1 S:RXO X=$P(RXO,"|",2),ORDIALOG(OI,1)=$$ORDITEM^ORM(X),PSOI=$P(X,U,4,5) - I '$G(ORDIALOG(OI,1)) S ORERR="Missing or invalid orderable item" Q - S PSDD=$P($$FIND^ORM(+RXE,3),U,4,5),ORDIALOG(DRUG,1)=+PSDD - S S0=$$FIND^ORM(+RXE,26)_"&"_$P($$FIND^ORM(+RXE,27),U,5) - S ID=$P(QT,U),LDOSE=$P(QT,U,8) I 'ID,S0 D - . N UNT,PTRN S UNT=$P(S0,"&",2),PTRN="1.N1"""_UNT_"""" - . I LDOSE?@PTRN S $P(ID,"&",1,2)=+LDOSE_"&"_UNT Q ;pre-POE orders - . S:$P(PSOI,U,2)'[S0 ORDIALOG(STR,1)=$TR(S0,"&") - I 'ID,'S0 S ORDIALOG(DRGNM,1)=$$UNESC^ORMPS2($P(PSDD,U,2)) - S:$L(ID) ORDIALOG(DOSE,1)=$$UNESC^ORMPS2($P(ID,"&",1,4)_"&"_LDOSE_"&"_+PSDD_"&"_S0) - I LDOSE="" D I LDOSE="" S ORERR="Unable to determine instructions" Q - . I $G(RXC)'>0 D Q ;look for units/dose - .. S LDOSE=$P(ID,"&",3),X=$P(ID,"&",4) I 'LDOSE S LDOSE="" Q - .. S:'$L(X) X=$$UNESC^ORMPS2($P($$FIND^ORM(+RXE,7),U,5)) S:$L(X) LDOSE=LDOSE_" "_X - .. S ORDIALOG(DRGNM,1)=$$UNESC^ORMPS2($P(PSDD,U,2)) ;force use of DD - . F D Q:LDOSE'="" S RXC=$O(@ORMSG@(RXC)) Q:'RXC Q:$E(@ORMSG@(RXC),1,3)'="RXC" - .. S XC=@ORMSG@(RXC) Q:+$P($P(XC,"|",3),U,4)'=+PSOI - .. S LDOSE=$P(XC,"|",4)_$P($P(XC,"|",5),U,5) ;strength_units - S ORDIALOG(INSTR,1)=$$UNESC^ORMPS2(LDOSE) -UD2 S NTE=$$NTE^ORMPS3(21) I NTE D - . N CNT,I S CNT=1,^TMP("ORWORD",$J,WP,1,CNT,0)=$$UNESC^ORMPS2($P(@ORMSG@(NTE),"|",4)) - . I $O(@ORMSG@(NTE,0)) S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S CNT=CNT+1,^TMP("ORWORD",$J,WP,1,CNT,0)=$$UNESC^ORMPS2(@ORMSG@(NTE,I)) - . S ^TMP("ORWORD",$J,WP,1,0)="^^"_CNT_U_CNT_U_DT_U - . S ORDIALOG(WP,1)="^TMP(""ORWORD"",$J,"_WP_",1)" - S RXR=$$RXR^ORMPS I 'RXR S ORERR="Missing or invalid RXR segment" Q - S ORDIALOG(RTE,1)=$P($P(RXR,"|",2),U,4),ORDIALOG(URG,1)=ORURG - S X=$P(QT,U,2) - S ORDIALOG(SCH,1)=$$UNESC^ORMPS2($P(X,"&")) - S:$L($P(X,"&",2)) ORDIALOG(ADMIN,1)=$P(X,"&",2) - S X=$P(QT,U,3) I $L(X) D ;set only if previous order had duration - . N IFN S IFN=$S($G(ORIFN):+ORIFN,$P(ZRX,"|",2):+$P(ZRX,"|",2),1:0) - . S:$O(^OR(100,+IFN,4.5,"ID","DAYS",0)) ORDIALOG(DUR,1)=$$DURATION^ORMPS3(X) - D DOSETEXT^ORCDPS2 ;reset Instructions text, SIG - D UNESCARR^ORMPS2("ORDIALOG") - Q -OUT ; -- new Outpt order - N OI,SIG,INSTR,DOSE,RTE,SCH,DUR,SC,STR,DRUG,PI,CONJ,PSOI,PSDD,S0,X,I,RXR,J,NTE,ZSC,CNT,PC - S ORDIALOG=+$O(^ORD(101.41,"AB","PSO OERR",0)) - S ORDG=+$O(^ORD(100.98,"B","OUTPATIENT MEDICATIONS",0)) - S ORPKG=+$$PKG("PSO") D GETDLG1^ORCD(ORDIALOG) - S OI=$$PTR("ORDERABLE ITEM"),SIG=$$PTR("SIG") - S INSTR=$$PTR("INSTRUCTIONS"),DOSE=$$PTR("DOSE") - S SCH=$$PTR("SCHEDULE"),DUR=$$PTR("DURATION") - S RTE=$$PTR("ROUTE"),SC=$$PTR("SERVICE CONNECTED") - S STR=$$PTR("STRENGTH"),DRUG=$$PTR("DISPENSE DRUG") - S PI=$$PTR("PATIENT INSTRUCTIONS"),CONJ=$$PTR("AND/THEN") - S PC=$$PTR("WORD PROCESSING 1") - S:RXO X=$P(RXO,"|",2),ORDIALOG(OI,1)=$$ORDITEM^ORM(X),PSOI=$P(X,U,4,5) - I '$G(ORDIALOG(OI,1)) S ORERR="Missing or invalid orderable item" Q - S PSDD=$P($$FIND^ORM(+RXE,3),U,4,5),ORDIALOG(DRUG,1)=+PSDD - S S0=$$FIND^ORM(+RXE,26)_"&"_$P($$FIND^ORM(+RXE,27),U,5) - I S0,$P(PSOI,U,2)'[S0 S ORDIALOG(STR,1)=$TR(S0,"&") - I 'S0,'$G(ORQT(1)) S ORDIALOG($$PTR("DRUG NAME"),1)=$$UNESC^ORMPS2($P(PSDD,U,2)) -OUT1 S ORDIALOG($$PTR("QUANTITY"),1)=$$FIND^ORM(+RXE,11) - S ORDIALOG($$PTR("REFILLS"),1)=$$FIND^ORM(+RXE,13) - S X=$$FIND^ORM(+RXE,23) S:$E(X)="D" X=+$E(X,2,99) - S:X ORDIALOG($$PTR("DAYS SUPPLY"),1)=X - I ZRX S X=$P(ZRX,"|",5) S:$L(X) ORDIALOG($$PTR("ROUTING"),1)=X - S:ORURG ORDIALOG($$PTR("URGENCY"),1)=ORURG F I=1:1:ORQT D - . S ORDIALOG(INSTR,I)=$$UNESC^ORMPS2($P(ORQT(I),U,8)),X=$P(ORQT(I),U) - . S:$L(X) ORDIALOG(DOSE,I)=$$UNESC^ORMPS2($P(X,"&",1,4)_"&"_$P(ORQT(I),U,8)_"&"_+PSDD_"&"_S0) - . S X=$P(ORQT(I),U,2) S:$L(X) ORDIALOG(SCH,I)=$$UNESC^ORMPS2(X) - . S X=$P(ORQT(I),U,3) S:$L(X) ORDIALOG(DUR,I)=$$DURATION^ORMPS3(X) - . S X=$P(ORQT(I),U,9) S:$L(X) ORDIALOG(CONJ,I)=$S(X="S":"T",1:X) - S RXR=$$RXR^ORMPS I RXR S ORDIALOG(RTE,1)=$P($P(RXR,"|",2),U,4) D - . S I=1,J=+RXR ;look for multiple RXR's - . F S J=$O(@ORMSG@(J)) Q:J'>0 S RXR=@ORMSG@(J) Q:$E(RXR,1,3)'="RXR" S I=I+1,ORDIALOG(RTE,I)=$P($P(RXR,"|",2),U,4) -OUT2 S NTE=$$NTE^ORMPS3(6) I NTE D ;Prov Comm ;D:'NTE PCOMM^ORMPS2 - . S CNT=1,^TMP("ORWORD",$J,PC,1,CNT,0)=$$UNESC^ORMPS2($P(@ORMSG@(NTE),"|",4)) - . I $O(@ORMSG@(NTE,0)) S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S CNT=CNT+1,^TMP("ORWORD",$J,PC,1,CNT,0)=$$UNESC^ORMPS2(@ORMSG@(NTE,I)) - . S ^TMP("ORWORD",$J,PC,1,0)="^^"_CNT_U_CNT_U_DT_U - . S ORDIALOG(PC,1)="^TMP(""ORWORD"",$J,"_PC_",1)",ORDIALOG(PC,"FORMAT")="@" ;keep, don't show - . N XCNT,XCOMM,XCOMMENT,XORCOMM,XXCNT,XORIFN - . S XORIFN=$G(ORIFN) S:XORIFN="" XORIFN=$P(RXR,"|",2) Q:XORIFN="" - . S XCOMM=$O(^OR(100,+XORIFN,4.5,"ID","COMMENT",0)) Q:XCOMM="" - . S XCNT=0 F S XCNT=$O(^TMP("ORWORD",$J,PC,1,XCNT)) Q:XCNT="" S XCOMMENT=^TMP("ORWORD",$J,PC,1,XCNT,0) D - .. S XORCOMM=$G(^OR(100,+XORIFN,4.5,XCOMM,2,XCNT,0)),XXCNT=0 - .. I XORCOMM="" F S XXCNT=$O(^OR(100,+XORIFN,4.5,XCOMM,2,XXCNT)) Q:XXCNT="" S XORCOMM=$G(^(XXCNT,0)) Q:XORCOMM'="" - .. I $G(XCOMMENT)=$G(XORCOMM) S ORDIALOG(PC,"FORMAT")="@" - S NTE=$$NTE^ORMPS3(7) I NTE D ;Pat Instr - . S CNT=1,^TMP("ORWORD",$J,PI,1,CNT,0)=$$UNESC^ORMPS2($P(@ORMSG@(NTE),"|",4)) - . I $O(@ORMSG@(NTE,0)) S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S CNT=CNT+1,^TMP("ORWORD",$J,PI,1,CNT,0)=$$UNESC^ORMPS2(@ORMSG@(NTE,I)) - . S ^TMP("ORWORD",$J,PI,1,0)="^^"_CNT_U_CNT_U_DT_U - . S ORDIALOG(PI,1)="^TMP(""ORWORD"",$J,"_PI_",1)" - S NTE=$$NTE^ORMPS3(21) I NTE D ;Sig - . S CNT=1,^TMP("ORWORD",$J,SIG,1,CNT,0)=$$UNESC^ORMPS2($P(@ORMSG@(NTE),"|",4)) - . I $O(@ORMSG@(NTE,0)) S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S CNT=CNT+1,^TMP("ORWORD",$J,SIG,1,CNT,0)=$$UNESC^ORMPS2(@ORMSG@(NTE,I)) - . S ^TMP("ORWORD",$J,SIG,1,0)="^^"_CNT_U_CNT_U_DT_U - . S ORDIALOG(SIG,1)="^TMP(""ORWORD"",$J,"_SIG_",1)" - . S ORDIALOG(PI,"FORMAT")="@" ;PI already included in Sig -OUT3 I '$G(ORQT(1))!('NTE) D DOSETEXT^ORCDPS2 ;reset Instructions text, Sig - S ZSC=$$ZSC^ORMPS3,X=$P(ZSC,"|",2) I X?2.3U S ORDIALOG(SC,1)=$S(X="SC":1,1:0) - Q -IV ; -- new IV order - N IVTYP,IVTYPE S IVTYP=$P(ZRX,"|",7) I IVTYP="",$$NUMADDS^ORMPS3'>1 G UDOSE - N SOLN,VOL,ADDS,STR,UNITS,RATE,URG,X,X1,X2,I,J,TYPE,OI,WP,NTE,SCH,DAYS,ROUTE,ADMIN - N RXR - S ORDIALOG=+$O(^ORD(101.41,"AB","PSJI OR PAT FLUID OE",0)) - I +$G(ORAPPT)>0 S ORDG=+$O(^ORD(100.98,"B","CLINIC ORDERS",0)) - E S ORDG=+$O(^ORD(100.98,"B",$S($P(ZRX,"|",7)="TPN":"TPN",1:"IV RX"),0)) - S ORPKG=+$$PKG("PSJ") D GETDLG1^ORCD(ORDIALOG) - S SOLN=$$PTR("ORDERABLE ITEM"),VOL=$$PTR("VOLUME"),SCH=$$PTR("SCHEDULE") - S RATE=$$PTR("INFUSION RATE") S:ORURG ORDIALOG($$PTR("URGENCY"),1)=ORURG - S WP=$$PTR("WORD PROCESSING 1"),ADDS=$$PTR("ADDITIVE") - S STR=$$PTR("STRENGTH PSIV"),UNITS=$$PTR("UNITS") - S DAYS=$$PTR("DURATION"),IVTYPE=$$PTR("IV TYPE"),ADMIN=$$PTR("ADMIN TIMES") -IV1 S NTE=$$NTE^ORMPS3(21) I NTE D - . N CNT,I S CNT=1,^TMP("ORWORD",$J,WP,1,CNT,0)=$$UNESC^ORMPS2($P(@ORMSG@(NTE),"|",4)) - . I $O(@ORMSG@(NTE,0)) S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S CNT=CNT+1,^TMP("ORWORD",$J,WP,1,CNT,0)=$$UNESC^ORMPS2(@ORMSG@(NTE,I)) - . S ^TMP("ORWORD",$J,WP,1,0)="^^"_CNT_U_CNT_U_DT_U - . S ORDIALOG(WP,1)="^TMP(""ORWORD"",$J,"_WP_",1)" - N ORDAYS S ORDAYS="" - S:$D(RXO) ORDAYS=$P($P(RXO,"|",2),"^",3) - S:$L(ORDAYS) ORDAYS=$$IVLIM^ORMPS2(ORDAYS) - S:$L(ORDAYS) ORDIALOG(DAYS,1)=ORDAYS - S ORDIALOG(IVTYPE,1)=IVTYP - S X=$P($$FIND^ORM(+RXE,25),U,5) - S ORDIALOG(RATE,1)=$$FIND^ORM(+RXE,24)_$S($L(X):" "_X,1:""),(I,J)=0 - F D S RXC=$O(@ORMSG@(RXC)) Q:'RXC Q:$E(@ORMSG@(RXC),1,3)'="RXC" - . S X=@ORMSG@(RXC),TYPE=$P(X,"|",2),OI=$$ORDITEM^ORM($P(X,"|",3)) Q:'OI - . S X1=$P(X,"|",4),X2=$P($P(X,"|",5),U,5) - . I $E(TYPE)="B" S J=J+1,ORDIALOG(SOLN,J)=OI,ORDIALOG(VOL,J)=X1 Q - . S I=I+1,ORDIALOG(ADDS,I)=OI,ORDIALOG(STR,I)=X1,ORDIALOG(UNITS,I)=X2 -IV2 ; - S RXR=$$RXR^ORMPS - S ROUTE=$P(RXR,"|",2) - S ORDIALOG($$PTR("ROUTE"),1)=$P(ROUTE,U,4) - I IVTYP="I" S X=$P($G(ORQT(1)),U,2) D - .S:$L($P(X,"&")) ORDIALOG(SCH,1)=$P(X,"&") - .S:$L($P(X,"&",2)) ORDIALOG(ADMIN,1)=$P(X,"&",2) - D UNESCARR^ORMPS2("ORDIALOG") - Q -PKG(NMSP) ; -- Return Package file ptr for NMSP - N I S I=0 - F S I=+$O(^DIC(9.4,"C",NMSP,I)) Q:I<1 Q:'$O(^(I,0)) ;no Addl Prefs - Q I -PTR(NAME) ; -- Returns ien of prompt NAME in Order Dialog file #101.41 - Q +$O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0)) -QT ; -- Unpiece the Q/T field from RXE - I 'RXE S ORQT(1)=ORQT,ORQT=1 Q ; nothing to reset - N X,Y,I,J,P,SEG,DONE K ORQT - S SEG=$G(@ORMSG@(+RXE)),X=$P(SEG,"|",2),(I,J,P,DONE)=0 - F D Q:DONE - . S P=P+1,Y=$P(X,"~",P) I Y="" S DONE=1 Q - . I P<$L(X,"~") S I=I+1,ORQT(I)=Y Q - . I $L(SEG,"|")>2 S I=I+1,ORQT(I)=Y,DONE=1 Q - . S J=+$O(@ORMSG@(+RXE,J)) I J'>0 S I=I+1,ORQT(I)=Y,DONE=1 Q - . S SEG=$G(@ORMSG@(+RXE,J)),X=$P(SEG,"|"),P=1,I=I+1,ORQT(I)=Y_$P(X,"~") - S ORQT=I Q:'ORQT ; else reset ORSTRT, ORSTOP, ORURG - S ORSTRT=$P(ORQT(1),U,4),ORSTOP=$P(ORQT(ORQT),U,5),ORURG=$P(ORQT(1),U,6) - S:ORSTRT ORSTRT=$$FMDATE^ORM(ORSTRT) S:ORSTOP ORSTOP=$$FMDATE^ORM(ORSTOP) S:$L(ORURG) ORURG=$$URGENCY^ORM(ORURG) - Q +ORMPS1 ;SLC/MKB - Process Pharmacy ORM msgs cont ;12/9/04 12:01 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**86,92,94,116,134,152,158,149,190,195,215,265,275**;Dec 17, 1997;Build 7 + ;;Per VHA Directive 2004-038, this routine should not be modified. +UDOSE ; -- new Unit Dose order + N QT,DRUG,INSTR,DOSE,RTE,SCH,OI,URG,WP,DUR,STR,DRGNM,X,PSOI,PSDD,S0,ID,LDOSE,XC,NTE,S0,RXR + S ORDIALOG=+$O(^ORD(101.41,"AB","PSJ OR PAT OE",0)) + I $G(ORAPPT)>0 S ORDG=+$O(^ORD(100.98,"B","CLINIC ORDERS",0)) + E S ORDG=+$O(^ORD(100.98,"B","UNIT DOSE MEDICATIONS",0)) + S ORPKG=+$$PKG("PSJ") + D GETDLG1^ORCD(ORDIALOG) S QT=$G(ORQT(1)) + S DRUG=$$PTR("DISPENSE DRUG"),INSTR=$$PTR("INSTRUCTIONS") + S DOSE=$$PTR("DOSE"),RTE=$$PTR("ROUTE"),SCH=$$PTR("SCHEDULE") + S OI=$$PTR("ORDERABLE ITEM"),URG=$$PTR("URGENCY") + S WP=$$PTR("WORD PROCESSING 1"),DUR=$$PTR("DURATION") + S STR=$$PTR("STRENGTH"),DRGNM=$$PTR("DRUG NAME") +UD1 S:RXO X=$P(RXO,"|",2),ORDIALOG(OI,1)=$$ORDITEM^ORM(X),PSOI=$P(X,U,4,5) + I '$G(ORDIALOG(OI,1)) S ORERR="Missing or invalid orderable item" Q + S PSDD=$P($$FIND^ORM(+RXE,3),U,4,5),ORDIALOG(DRUG,1)=+PSDD + S S0=$$FIND^ORM(+RXE,26)_"&"_$P($$FIND^ORM(+RXE,27),U,5) + S ID=$P(QT,U),LDOSE=$P(QT,U,8) I 'ID,S0 D + . N UNT,PTRN S UNT=$P(S0,"&",2),PTRN="1.N1"""_UNT_"""" + . I LDOSE?@PTRN S $P(ID,"&",1,2)=+LDOSE_"&"_UNT Q ;pre-POE orders + . S:$P(PSOI,U,2)'[S0 ORDIALOG(STR,1)=$TR(S0,"&") + I 'ID,'S0 S ORDIALOG(DRGNM,1)=$P(PSDD,U,2) + S:$L(ID) ORDIALOG(DOSE,1)=$P(ID,"&",1,4)_"&"_LDOSE_"&"_+PSDD_"&"_S0 + I LDOSE="" D I LDOSE="" S ORERR="Unable to determine instructions" Q + . I $G(RXC)'>0 D Q ;look for units/dose + .. S LDOSE=$P(ID,"&",3),X=$P(ID,"&",4) I 'LDOSE S LDOSE="" Q + .. S:'$L(X) X=$P($$FIND^ORM(+RXE,7),U,5) S:$L(X) LDOSE=LDOSE_" "_X + .. S ORDIALOG(DRGNM,1)=$P(PSDD,U,2) ;force use of DD + . F D Q:LDOSE'="" S RXC=$O(@ORMSG@(RXC)) Q:'RXC Q:$E(@ORMSG@(RXC),1,3)'="RXC" + .. S XC=@ORMSG@(RXC) Q:+$P($P(XC,"|",3),U,4)'=+PSOI + .. S LDOSE=$P(XC,"|",4)_$P($P(XC,"|",5),U,5) ;strength_units + S ORDIALOG(INSTR,1)=LDOSE +UD2 S NTE=$$NTE(21) I NTE D + . N CNT,I S CNT=1,^TMP("ORWORD",$J,WP,1,CNT,0)=$P(@ORMSG@(NTE),"|",4) + . I $O(@ORMSG@(NTE,0)) S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S CNT=CNT+1,^TMP("ORWORD",$J,WP,1,CNT,0)=@ORMSG@(NTE,I) + . S ^TMP("ORWORD",$J,WP,1,0)="^^"_CNT_U_CNT_U_DT_U + . S ORDIALOG(WP,1)="^TMP(""ORWORD"",$J,"_WP_",1)" + S RXR=$$RXR^ORMPS I 'RXR S ORERR="Missing or invalid RXR segment" Q + S ORDIALOG(RTE,1)=$P($P(RXR,"|",2),U,4),ORDIALOG(URG,1)=ORURG + S ORDIALOG(SCH,1)=$P(QT,U,2),X=$P(QT,U,3) + I $L(X) D ;set only if previous order had duration + . N IFN S IFN=$S($G(ORIFN):+ORIFN,$P(ZRX,"|",2):+$P(ZRX,"|",2),1:0) + . S:$O(^OR(100,+IFN,4.5,"ID","DAYS",0)) ORDIALOG(DUR,1)=$$DURATION(X) + D DOSETEXT^ORCDPS2 ;reset Instructions text, SIG + Q +OUT ; -- new Outpt order + N OI,SIG,INSTR,DOSE,RTE,SCH,DUR,SC,STR,DRUG,PI,CONJ,PSOI,PSDD,S0,X,I,RXR,J,NTE,ZSC,CNT,PC + S ORDIALOG=+$O(^ORD(101.41,"AB","PSO OERR",0)) + S ORDG=+$O(^ORD(100.98,"B","OUTPATIENT MEDICATIONS",0)) + S ORPKG=+$$PKG("PSO") D GETDLG1^ORCD(ORDIALOG) + S OI=$$PTR("ORDERABLE ITEM"),SIG=$$PTR("SIG") + S INSTR=$$PTR("INSTRUCTIONS"),DOSE=$$PTR("DOSE") + S SCH=$$PTR("SCHEDULE"),DUR=$$PTR("DURATION") + S RTE=$$PTR("ROUTE"),SC=$$PTR("SERVICE CONNECTED") + S STR=$$PTR("STRENGTH"),DRUG=$$PTR("DISPENSE DRUG") + S PI=$$PTR("PATIENT INSTRUCTIONS"),CONJ=$$PTR("AND/THEN") + S PC=$$PTR("WORD PROCESSING 1") + S:RXO X=$P(RXO,"|",2),ORDIALOG(OI,1)=$$ORDITEM^ORM(X),PSOI=$P(X,U,4,5) + I '$G(ORDIALOG(OI,1)) S ORERR="Missing or invalid orderable item" Q + S PSDD=$P($$FIND^ORM(+RXE,3),U,4,5),ORDIALOG(DRUG,1)=+PSDD + S S0=$$FIND^ORM(+RXE,26)_"&"_$P($$FIND^ORM(+RXE,27),U,5) + I S0,$P(PSOI,U,2)'[S0 S ORDIALOG(STR,1)=$TR(S0,"&") + I 'S0,'$G(ORQT(1)) S ORDIALOG($$PTR("DRUG NAME"),1)=$P(PSDD,U,2) +OUT1 S ORDIALOG($$PTR("QUANTITY"),1)=$$FIND^ORM(+RXE,11) + S ORDIALOG($$PTR("REFILLS"),1)=$$FIND^ORM(+RXE,13) + S X=$$FIND^ORM(+RXE,23) S:$E(X)="D" X=+$E(X,2,99) + S:X ORDIALOG($$PTR("DAYS SUPPLY"),1)=X + I ZRX S X=$P(ZRX,"|",5) S:$L(X) ORDIALOG($$PTR("ROUTING"),1)=X + S:ORURG ORDIALOG($$PTR("URGENCY"),1)=ORURG F I=1:1:ORQT D + . S ORDIALOG(INSTR,I)=$P(ORQT(I),U,8),X=$P(ORQT(I),U) + . S:$L(X) ORDIALOG(DOSE,I)=$P(X,"&",1,4)_"&"_$P(ORQT(I),U,8)_"&"_+PSDD_"&"_S0 + . S X=$P(ORQT(I),U,2) S:$L(X) ORDIALOG(SCH,I)=X + . S X=$P(ORQT(I),U,3) S:$L(X) ORDIALOG(DUR,I)=$$DURATION(X) + . S X=$P(ORQT(I),U,9) S:$L(X) ORDIALOG(CONJ,I)=$S(X="S":"T",1:X) + S RXR=$$RXR^ORMPS I RXR S ORDIALOG(RTE,1)=$P($P(RXR,"|",2),U,4) D + . S I=1,J=+RXR ;look for multiple RXR's + . F S J=$O(@ORMSG@(J)) Q:J'>0 S RXR=@ORMSG@(J) Q:$E(RXR,1,3)'="RXR" S I=I+1,ORDIALOG(RTE,I)=$P($P(RXR,"|",2),U,4) +OUT2 S NTE=$$NTE(6) D:'NTE PCOMM^ORMPS2 I NTE D ;Prov Comm + . S CNT=1,^TMP("ORWORD",$J,PC,1,CNT,0)=$P(@ORMSG@(NTE),"|",4) + . I $O(@ORMSG@(NTE,0)) S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S CNT=CNT+1,^TMP("ORWORD",$J,PC,1,CNT,0)=@ORMSG@(NTE,I) + . S ^TMP("ORWORD",$J,PC,1,0)="^^"_CNT_U_CNT_U_DT_U + . S ORDIALOG(PC,1)="^TMP(""ORWORD"",$J,"_PC_",1)" + . N XCNT,XCOMM,XCOMMENT,XORCOMM,XXCNT,XORIFN + . S (XCOMM,XORCOMM)="" + . S XORIFN=$G(ORIFN) I XORIFN="" S XORIFN=$P(RXR,"|",2) + . Q:XORIFN="" + . S XCOMM=$O(^OR(100,+XORIFN,4.5,"ID","COMMENT",XCOMM)) Q:XCOMM="" + . S XCNT=0 F S XCNT=$O(^TMP("ORWORD",$J,PC,1,XCNT)) Q:XCNT="" S XCOMMENT=$G(^TMP("ORWORD",$J,PC,1,XCNT,0)) D + . . S XORCOMM=$G(^OR(100,+XORIFN,4.5,XCOMM,2,XCNT,0)) + . . S XXCNT=0 + . . I XORCOMM="" F S XXCNT=$O(^OR(100,+XORIFN,4.5,XCOMM,2,XXCNT)) Q:XXCNT="" S XORCOMM=$G(^OR(100,+XORIFN,4.5,XCOMM,2,XXCNT,0)) Q:XORCOMM'="" + . . I $G(XCOMMENT)=$G(XORCOMM) S ORDIALOG(PC,"FORMAT")="@" + S NTE=$$NTE(7) I NTE D ;Pat Instr + . S CNT=1,^TMP("ORWORD",$J,PI,1,CNT,0)=$P(@ORMSG@(NTE),"|",4) + . I $O(@ORMSG@(NTE,0)) S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S CNT=CNT+1,^TMP("ORWORD",$J,PI,1,CNT,0)=@ORMSG@(NTE,I) + . S ^TMP("ORWORD",$J,PI,1,0)="^^"_CNT_U_CNT_U_DT_U + . S ORDIALOG(PI,1)="^TMP(""ORWORD"",$J,"_PI_",1)" + S NTE=$$NTE(21) I NTE D ;Sig + . S CNT=1,^TMP("ORWORD",$J,SIG,1,CNT,0)=$P(@ORMSG@(NTE),"|",4) + . I $O(@ORMSG@(NTE,0)) S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S CNT=CNT+1,^TMP("ORWORD",$J,SIG,1,CNT,0)=@ORMSG@(NTE,I) + . S ^TMP("ORWORD",$J,SIG,1,0)="^^"_CNT_U_CNT_U_DT_U + . S ORDIALOG(SIG,1)="^TMP(""ORWORD"",$J,"_SIG_",1)" + . S ORDIALOG(PI,"FORMAT")="@" ;PI already included in Sig +OUT3 I '$G(ORQT(1))!('NTE) D DOSETEXT^ORCDPS2 ;reset Instructions text, Sig + S ZSC=$$ZSC,X=$P(ZSC,"|",2) I X?2.3U S ORDIALOG(SC,1)=$S(X="SC":1,1:0) + Q +IV ; -- new IV order + N IVTYP S IVTYP=$P(ZRX,"|",7) I IVTYP="",$$NUMADDS'>1 G UDOSE + N SOLN,VOL,ADDS,STR,UNITS,RATE,URG,X,X1,X2,I,J,TYPE,OI,WP,NTE,SCH,DAYS + S ORDIALOG=+$O(^ORD(101.41,"AB","PSJI OR PAT FLUID OE",0)) + I +$G(ORAPPT)>0 S ORDG=+$O(^ORD(100.98,"B","CLINIC ORDERS",0)) + E S ORDG=+$O(^ORD(100.98,"B",$S($P(ZRX,"|",7)="TPN":"TPN",1:"IV RX"),0)) + S ORPKG=+$$PKG("PSJ") D GETDLG1^ORCD(ORDIALOG) + S SOLN=$$PTR("ORDERABLE ITEM"),VOL=$$PTR("VOLUME"),SCH=$$PTR("SCHEDULE") + S RATE=$$PTR("INFUSION RATE") S:ORURG ORDIALOG($$PTR("URGENCY"),1)=ORURG + S WP=$$PTR("WORD PROCESSING 1"),ADDS=$$PTR("ADDITIVE") + S STR=$$PTR("STRENGTH PSIV"),UNITS=$$PTR("UNITS") + S DAYS=$$PTR("DURATION") +IV1 S NTE=$$NTE(21) I NTE D + . N CNT,I S CNT=1,^TMP("ORWORD",$J,WP,1,CNT,0)=$P(@ORMSG@(NTE),"|",4) + . I $O(@ORMSG@(NTE,0)) S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S CNT=CNT+1,^TMP("ORWORD",$J,WP,1,CNT,0)=@ORMSG@(NTE,I) + . S ^TMP("ORWORD",$J,WP,1,0)="^^"_CNT_U_CNT_U_DT_U + . S ORDIALOG(WP,1)="^TMP(""ORWORD"",$J,"_WP_",1)" + N ORDAYS S ORDAYS="" + S:$D(RXO) ORDAYS=$P($P(RXO,"|",2),"^",3) + S:$L(ORDAYS) ORDAYS=$$IVLIM^ORMPS2(ORDAYS) + S:$L(ORDAYS) ORDIALOG(DAYS,1)=ORDAYS + S X=$P($$FIND^ORM(+RXE,25),U,5) + S ORDIALOG(RATE,1)=$$FIND^ORM(+RXE,24)_$S($L(X):" "_X,1:""),(I,J)=0 + F D S RXC=$O(@ORMSG@(RXC)) Q:'RXC Q:$E(@ORMSG@(RXC),1,3)'="RXC" + . S X=@ORMSG@(RXC),TYPE=$P(X,"|",2),OI=$$ORDITEM^ORM($P(X,"|",3)) Q:'OI + . S X1=$P(X,"|",4),X2=$P($P(X,"|",5),U,5) + . I $E(TYPE)="B" S J=J+1,ORDIALOG(SOLN,J)=OI,ORDIALOG(VOL,J)=X1 Q + . S I=I+1,ORDIALOG(ADDS,I)=OI,ORDIALOG(STR,I)=X1,ORDIALOG(UNITS,I)=X2 + I IVTYP="" S X=$P($G(ORQT(1)),U,2) S:$L(X) ORDIALOG(SCH,1)=X + Q +NTE(ID) ; -- Return subscript of NTE segment for RXE- + N I,SEG,Y S Y="",I=+RXE S:'$G(ID) ID=21 + F S I=$O(@ORMSG@(I)) Q:I'>0 S SEG=@ORMSG@(I) Q:$E(SEG,1,3)="ORC" I $P(SEG,"|",1,2)=("NTE|"_ID) S Y=I Q + Q Y +ZSC() ; -- Return subscript of ZSC segment + N I,SEG,Y S Y="",I=+RXE + F S I=$O(@ORMSG@(I)) Q:I'>0 S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC" I SEG="ZSC" S Y=I_U_@ORMSG@(I) Q + Q Y +NUMADDS() ; -- count number of additives to determine type + N CNT,I,X S CNT=0,I=+RXE + F S I=$O(@ORMSG@(I)) Q:I'>0 S X=@ORMSG@(I) Q:$P(X,"|")="ORC" I $E(X,1,6)="RXC|A|" S CNT=CNT+1 + Q CNT +PKG(NMSP) ; -- Return Package file ptr for NMSP + N I S I=0 + F S I=+$O(^DIC(9.4,"C",NMSP,I)) Q:I<1 Q:'$O(^(I,0)) ;no Addl Prefs DBIA #2058 + Q I +PTR(NAME) ; -- Returns ien of prompt NAME in Order Dialog file #101.41 + Q +$O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0)) +DURATION(X) ; -- Returns "# units" from U# format + N Y,Y1,Y2 I X'?.1U1.N Q "" + S Y1=$E(X),Y2=+$E(X,2,$L(X)) I X=+X S Y1="D",Y2=+X + S Y=Y2_" "_$S(Y1="L":"MONTH",Y1="W":"WEEK",Y1="H":"HOUR",Y1="M":"MINUTE",Y1="S":"SECOND",1:"DAY")_$S(Y2>1:"S",1:"") + Q Y +QT ; -- Unpiece the Q/T field from RXE + I 'RXE S ORQT(1)=ORQT,ORQT=1 Q ; nothing to reset + N X,Y,I,J,P,SEG,DONE K ORQT + S SEG=$G(@ORMSG@(+RXE)),X=$P(SEG,"|",2),(I,J,P,DONE)=0 + F D Q:DONE + . S P=P+1,Y=$P(X,"~",P) I Y="" S DONE=1 Q + . I P<$L(X,"~") S I=I+1,ORQT(I)=Y Q + . I $L(SEG,"|")>2 S I=I+1,ORQT(I)=Y,DONE=1 Q + . S J=+$O(@ORMSG@(+RXE,J)) I J'>0 S I=I+1,ORQT(I)=Y,DONE=1 Q + . S SEG=$G(@ORMSG@(+RXE,J)),X=$P(SEG,"|"),P=1,I=I+1,ORQT(I)=Y_$P(X,"~") + S ORQT=I Q:'ORQT ; else reset ORSTRT, ORSTOP, ORURG + S ORSTRT=$P(ORQT(1),U,4),ORSTOP=$P(ORQT(ORQT),U,5),ORURG=$P(ORQT(1),U,6) + S:ORSTRT ORSTRT=$$FMDATE^ORM(ORSTRT) S:ORSTOP ORSTOP=$$FMDATE^ORM(ORSTOP) S:$L(ORURG) ORURG=$$URGENCY^ORM(ORURG) + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMPS2.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMPS2.m index 6df79cb7..e39e5452 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMPS2.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMPS2.m @@ -1,159 +1,146 @@ -ORMPS2 ;SLC/MKB - Process Pharmacy ORM msgs cont ;04/01/2008 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**94,116,129,134,186,190,195,215,265,243**;Dec 17, 1997;Build 242 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -FINISHED() ; -- new order [SN^ORMPS] due to finishing? - N Y,ORIG,TYPE,ORIG4 S Y=0 - S ORIG=+$P(ZRX,"|",2),TYPE=$P(ZRX,"|",4),ORIG4=$G(^OR(100,ORIG,4)) - I ORIG,TYPE="E",ORIG4?1.N1"P"!(ORIG4?1.N1"S") S ORIFN=+ORIG,Y=1 - Q Y - ; -WPX() ; -- Compare comments in @ORMSG@(NTE) with order ORIFN - ; Returns 1 if different, or 0 if same - N NTE,SPINST,Y,X S Y=0 - S NTE=+$$NTE^ORMPS3(21),SPINST=$S(NTE:$$NTXT^ORMPS3(NTE),1:"") - S X=$$VALTXT^ORMPS3(+ORIFN,"COMMENT") - I $TR(X," ")'=$TR(SPINST," ") S Y=1 ;comp text w/o spaces -WQ Q Y - ; -IVX() ; -- Compare ORMSG to Inpt order ORIFN if IV, return 0 if 'diff or 'IV - N Y,RXC,DG,OI,PSOI,XC,X,RATE,RXR,ORA,ORB,ORX,I,J,OI0,INST,VOL,STR,UNT - S RXC=$$RXC^ORMPS,Y=0 I RXC'>0 Q Y ;not IV of any kind - S DG=+$P($G(^OR(100,+ORIFN,0)),U,11),DG=$P($G(^ORD(100.98,DG,0)),U,3) - I DG'="IV RX",DG'="TPN" D Q Y ;not fluid - . I $P(ZRX,"|",7)'="" S Y=1 Q - . I $$NUMADDS^ORMPS3>1 S Y=1 Q - . S OI=$$VALUE("ORDERABLE"),PSOI=+$P($G(^ORD(101.43,+OI,0)),U,2) - . S XC=@ORMSG@(RXC) I PSOI'=$P(XC,U,4) S Y=1 Q - . N X1,X2,X3 S X1=$P(XC,"|",4),X2=$P($P(XC,"|",5),U,5) - . S X3=$$VALUE("INSTR") I (X1_X2)'=X3,(X1_" "_X2)'=X3 S Y=1 Q -IV1 S RATE=$$FIND^ORM(+RXE,24),UNT=$P($$FIND^ORM(+RXE,25),U,5) - S:$L(UNT) RATE=RATE_" "_UNT S X=$$VALUE("RATE") I RATE'=X D Q:Y Y - . S:RATE["@" RATE=$P(RATE,"@") S:X["@" X=$P(X,"@") ;rate@labels - . I RATE'=X S Y=1 Q - I $P(ZRX,"|",7)'=$$VALUE("TYPE") S Y=1 Q Y - S RXR=$$RXR^ORMPS - I $P($P(RXR,"|",2),U,4)'=$$VALUE("ROUTE") S Y=1 Q Y - S ORB=+$$PTR("ORDERABLE ITEM"),ORA=+$$PTR("ADDITIVE"),I=+RXC - F S XC=@ORMSG@(I) Q:$E(XC,1,3)'="RXC" D S I=$O(@ORMSG@(I)) Q:I'>0 - . S ORX($P(XC,"|",2),+$P(XC,U,4))=$P(XC,"|",4)_U_$P($P(XC,"|",5),U,5) - . ;ORX("A",PSOI)=str^units or ORX("B",PSOI)=volume^units - F I="STRENGTH","UNITS","VOLUME" D ;ORX(I,inst)=value - . S J=0 F S J=$O(^OR(100,+ORIFN,4.5,"ID",I,J)) Q:J'>0 D - .. S INST=+$P($G(^OR(100,+ORIFN,4.5,J,0)),U,3) - .. S:INST ORX(I,INST)=$G(^OR(100,+ORIFN,4.5,J,1)) - S I=0 F S I=$O(^OR(100,+ORIFN,4.5,"ID","ORDERABLE",I)) Q:I'>0 D Q:Y - . S OI0=$G(^OR(100,+ORIFN,4.5,I,0)),OI=+$G(^(1)) - . S PSOI=+$P($G(^ORD(101.43,OI,0)),U,2) - . I $P(OI0,U,2)=ORA,$G(ORX("A",PSOI)) D Q - .. S INST=$P(OI0,U,3),STR=+ORX("A",PSOI),UNT=$P(ORX("A",PSOI),U,2) - .. I STR'=$G(ORX("STRENGTH",INST)) S Y=1 Q - .. I UNT'=$G(ORX("UNITS",INST)) S Y=1 Q - .. K ORX("A",PSOI) ;same - . I $P(OI0,U,2)=ORB,$G(ORX("B",PSOI)) D Q - .. S INST=$P(OI0,U,3),VOL=+$G(ORX("B",PSOI)) - .. I VOL'=$G(ORX("VOLUME",INST)) S Y=1 Q - .. K ORX("B",PSOI) ;same - . S Y=1 - I $O(ORX("A",0))!$O(ORX("B",0)) S Y=1 ;leftover items - changed - Q Y - ; -CHANGED() ; -- Compare ORMSG to order ORIFN, return 1 if different - N I,X,Y,X1,NTE,SIG,PI,TRXO S Y=0 - I $G(ORCAT)="I" D G CHQ - . I $$WPX S Y=1 Q ;Special Instructions - . S X=$$VALUE("DAYS") ;duration - . I $G(X)'="" D I $G(X)'=X1 S Y=1 Q - . .S X=$$HL7IVLMT^ORMBLDP1(X) - . .S TRXO=$$RXO^ORMPS,X1=$P($P($G(TRXO),"|",2),U,3) - . .;S X1=$$DURATION^ORMPS3($P($P(TRXO,"|",2),U,3)) - . I $$IVX S Y=1 Q ;IV fields - ;S X=+$P($P(RXE,"|",3),U,4) I X'=+$$VALUE("DRUG") S Y=1 G CHQ - I +$P(RXE,"|",11)'=+$$VALUE("QTY") S Y=1 G CHQ - I +$P(RXE,"|",13)'=+$$VALUE("REFILLS") S Y=1 G CHQ - ;S X=$P(RXE,"|",23) S:$E(X)="D" X=+$E(X,2,99) I X'=+$$VALUE("SUPPLY") S Y=1 G CHQ - ;I $P(ZRX,"|",5)'=$$VALUE("PICKUP") S Y=1 G CHQ - S NTE=$$NTE^ORMPS3(21),SIG=+$O(^OR(100,+ORIFN,4.5,"ID","SIG",0)) ;verb - I NTE,SIG,$P($P(@ORMSG@(NTE),"|",4)," ")'=$P($G(^OR(100,+ORIFN,4.5,SIG,2,1,0))," ") S Y=1 G CHQ - S NTE=$$NTE^ORMPS3(7),PI=+$O(^OR(100,+ORIFN,4.5,"ID","PI",0)) - I (NTE&'PI)!('NTE&PI) Q 1 ;added or deleted - I NTE,PI D G CHQ ;compare text - . S PI=$$VALTXT^ORMPS3(+ORIFN,PI)_$$VALTXT^ORMPS3(+ORIFN,"COMMENT") - . S NTE=$$NTXT^ORMPS3(NTE) - . I $TR(NTE," ")'=$TR(PI," ") S Y=1 Q ;comp text w/o spaces -CHQ Q Y - ; -VALUE(ID) ; -- Return value of ID in ^OR(100,+ORIFN,4.5,"ID") - N I,Y I '$L($G(ID)) Q "" - S I=+$O(^OR(100,+ORIFN,4.5,"ID",ID,0)) - S Y=$G(^OR(100,+ORIFN,4.5,I,1)) - Q Y - ; -PTR(X) ; -- Return ptr to prompt OR GTX X - Q +$O(^ORD(101.41,"AB","OR GTX "_X,0)) - ; -RO ; -- Replacement order (finished) - N RXO,RXC,ORDIALOG,ORDG,ORPKG,ORDA,ORX,ORSIG,ORP,ZSC,NEWSTS - N ADMIN,IVTYPE - K ^TMP("ORWORD",$J) - I '$D(^VA(200,ORNP,0)) S ORERR="Missing or invalid ordering provider" Q - I 'RXE S ORERR="Missing or invalid RXE segment" Q - S RXO=$$RXO^ORMPS,RXC=$$RXC^ORMPS,ORIFN=+$G(ORIFN) - I ORIFN'>0 S ORERR="Missing or invalid order number" Q - D @($S(RXC:"IV",$G(ORCAT)="I":"UDOSE",1:"OUT")_"^ORMPS1") Q:$D(ORERR) - ;Check keep Admin Time with order if not define in the RXE segment on - ;verify - I RXC,$$VALUE("TYPE")="I" S ORDIALOG($$PTR("ADMIN TIMES"),1)=$$VALUE("ADMIN") - S ORDA=$$ACTION^ORCSAVE("XX",ORIFN,ORNP,"",ORNOW,ORWHO) - I ORDA'>0 S ORERR="Cannot create new order action" Q -RO1 ; -Update sts of order to active, last action to dc/edit: - S ORX=ORDA F S ORX=+$O(^OR(100,ORIFN,8,ORX),-1) Q:ORX'>0 I $D(^(ORX,0)),$P(^(0),U,15)="" Q ;ORX=last released action - S:ORX $P(^OR(100,ORIFN,8,ORX,0),U,15)=12 ;dc/edit - S $P(^OR(100,ORIFN,3),U,7)=ORDA,NEWSTS=$S('$G(ORSTS):0,ORSTS=$P(^(3),U,3):0,1:1) K ^(6) - D STATUS^ORCSAVE2(ORIFN,ORSTS):NEWSTS,SETALL^ORDD100(ORIFN):'NEWSTS - D DATES^ORCSAVE2(ORIFN,ORSTRT,ORSTOP) - D RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,ORWHO,ORNATR) - ; -If unsigned edit, leave XX unsigned & mark ORX as Sig Not Req'd - S ORSIG=$S($P($G(^OR(100,ORIFN,8,ORX,0)),U,4)'=2:1,1:0) - D SIGSTS^ORCSAVE2(ORIFN,ORDA):ORSIG,SIGN^ORCSAVE2(ORIFN,,,5,ORX):'ORSIG -RO2 ; -Update responses, get/save new order text: - K ^OR(100,ORIFN,4.5) D RESPONSE^ORCSAVE,ORDTEXT^ORCSAVE1(ORIFN_";"_ORDA) - S $P(^OR(100,ORIFN,0),U,5)=ORDIALOG_";ORD(101.41,",$P(^(0),U,14)=ORPKG - ;I $P(^OR(100,ORIFN,0),U,11)'=ORDG D ;update DG,xrefs - ;AGP Changes to handle IMO IV orders CPRS 26v43 - I $P(^OR(100,ORIFN,0),U,11)'=ORDG,$P(^OR(100,ORIFN,0),U,11)'=$O(^ORD(100.98,"B","CLINIC ORDERS","")) D - . N DA,DR,DIE - . S DA=ORIFN,DR="23////"_ORDG,DIE="^OR(100," D ^DIE - S ^OR(100,ORIFN,4)=PKGIFN,$P(^(8,ORDA,0),U,14)=ORDA - S ORIFN=ORIFN_";"_ORDA,ORDCNTRL="SN" ;to send NA msg back - I $G(ORL) S ORP(1)=ORIFN_"^1" D PRINTS^ORWD1(.ORP,+ORL) - I $G(ORCAT)="O" S ZSC=$$ZSC^ORMPS3 I ZSC,$P(ZSC,"|",2)'?2.3U S ^OR(100,+ORIFN,5)=$TR($P(ZSC,"|",2,9),"|","^") ;1 or 0 instead of [N]SC in #100 - Q -IVLIM(IVDUR) ; - I $L(IVDUR) D - . N DURU,DURV S DURU="",DURV=0 - . S DURU=$E(IVDUR,1),DURV=$E(IVDUR,2,$L(IVDUR)) - . I IVDUR["dose" S DURV=$E(IVDUR,6,$L(IVDUR)),IVDUR="for a total of "_+DURV_$S(+DURV=1:" doses",+DURV>1:" doses",1:" dose") Q - . I (DURU="D")!(DURU="d") S IVDUR="for "_+DURV_$S(+DURV=1:" day",+DURV>1:" days",1:" day") - . I (DURU="H")!(DURU="h") S IVDUR="for "_+DURV_$S(+DURV=1:" hours",+DURV>1:" hours",1:" hour") - . I (DURU="M")!(DURU="m") S IVDUR="with total volume "_+DURV_" ml" - . I (DURU="L")!(DURU="l") S IVDUR="with total volume "_+DURV_" L" - Q IVDUR -UNESC(STRING) ; - Q $$UNESC^ORHLESC(STRING) -UNESCARR(ARR) ; - N I S I="" F S I=$O(@ARR@(I)) Q:'$L(I) D - .N IND S IND=$S(ARR["(":$E(ARR,0,$L(ARR)-1)_","""_I_""")",1:ARR_"("""_I_""")") - .N TYPE S TYPE=$D(@ARR@(I)) - .I TYPE=11!(TYPE=10) D UNESCARR(IND) - .I TYPE=1!(TYPE=11) S @ARR@(I)=$$UNESC(@ARR@(I)) - Q -PCOMM ; -- Get Provider Comments from previous order, when changed - N OLD,I - S OLD=+$G(ORIFN) I OLD<1 S OLD=+$P(ZRX,"|",2) Q:OLD<1 - S I=+$O(^OR(100,OLD,4.5,"ID","COMMENT",0)) Q:I<1 - Q:'$O(^OR(100,OLD,4.5,I,2,0)) ;none - M ^TMP("ORWORD",$J,PC,1)=^OR(100,OLD,4.5,I,2) - S ORDIALOG(PC,1)="^TMP(""ORWORD"",$J,"_PC_",1)" - S ORDIALOG(PC,"FORMAT")="@" ;text in Sig already - Q +ORMPS2 ;SLC/MKB - Process Pharmacy ORM msgs cont ; 1/26/07 11:58am + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**94,116,129,134,186,190,195,215,265**;Dec 17, 1997;Build 17 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; +FINISHED() ; -- new order [SN^ORMPS] due to finishing? + N Y,ORIG,TYPE,ORIG4 S Y=0 + S ORIG=+$P(ZRX,"|",2),TYPE=$P(ZRX,"|",4),ORIG4=$G(^OR(100,ORIG,4)) + I ORIG,TYPE="E",ORIG4?1.N1"P"!(ORIG4?1.N1"S") S ORIFN=+ORIG,Y=1 + Q Y + ; +WPX() ; -- Compare comments in @ORMSG@(NTE) with order ORIFN + ; Returns 1 if different, or 0 if same + N NTE,SPINST,Y,I,J,X,X1 S Y=0 + S NTE=+$$NTE^ORMPS1(21),SPINST=$S(NTE:$P(@ORMSG@(NTE),"|",4),1:"") + S I=+$O(^OR(100,+ORIFN,4.5,"ID","COMMENT",0)) I I'>0 S:$L(SPINST) Y=1 G WQ + S X=$G(^OR(100,+ORIFN,4.5,I,2,1,0)) ;1st line + I '$O(^OR(100,+ORIFN,4.5,I,2,1)) S:X'=SPINST Y=1 G WQ + S J=1 F S J=$O(^OR(100,+ORIFN,4.5,I,2,J)) Q:J'>0 S X1=$G(^(J,0)) D Q:$L(X)'<240 + . I ($L(X)+$L(X1)+1)'>240 S X=X_" "_X1 Q + . S X=X_" "_$E(X1,1,239-$L(X)) + S:X'=SPINST Y=1 ;changed +WQ Q Y + ; +IVX() ; -- Compare ORMSG to Inpt order ORIFN if IV, return 0 if 'diff or 'IV + N Y,RXC,DG,OI,PSOI,XC,RATE,ORA,ORB,ORX,I,J,OI0,INST,VOL,STR,UNT + S RXC=$$RXC^ORMPS,Y=0 I RXC'>0 Q Y ;not IV of any kind + S DG=+$P($G(^OR(100,+ORIFN,0)),U,11),DG=$P($G(^ORD(100.98,DG,0)),U,3) + I DG'="IV RX",DG'="TPN" D Q Y ;not fluid + . I $P(ZRX,"|",7)'="" S Y=1 Q + . I $$NUMADDS^ORMPS1>1 S Y=1 Q + . S OI=$$VALUE("ORDERABLE"),PSOI=+$P($G(^ORD(101.43,+OI,0)),U,2) + . S XC=@ORMSG@(RXC) I PSOI'=$P(XC,U,4) S Y=1 Q + . N X1,X2,X3 S X1=$P(XC,"|",4),X2=$P($P(XC,"|",5),U,5) + . S X3=$$VALUE("INSTR") I (X1_X2)'=X3,(X1_" "_X2)'=X3 S Y=1 Q +IV1 S RATE=$$FIND^ORM(+RXE,24),UNT=$P($$FIND^ORM(+RXE,25),U,5) + S:$L(UNT) RATE=RATE_" "_UNT I RATE'=$$VALUE("RATE") S Y=1 Q Y + S ORB=+$$PTR("ORDERABLE ITEM"),ORA=+$$PTR("ADDITIVE"),I=+RXC + F S XC=@ORMSG@(I) Q:$E(XC,1,3)'="RXC" D S I=$O(@ORMSG@(I)) Q:I'>0 + . S ORX($P(XC,"|",2),+$P(XC,U,4))=$P(XC,"|",4)_U_$P($P(XC,"|",5),U,5) + . ;ORX("A",PSOI)=str^units or ORX("B",PSOI)=volume^units + F I="STRENGTH","UNITS","VOLUME" D ;ORX(I,inst)=value + . S J=0 F S J=$O(^OR(100,+ORIFN,4.5,"ID",I,J)) Q:J'>0 D + .. S INST=+$P($G(^OR(100,+ORIFN,4.5,J,0)),U,3) + .. S:INST ORX(I,INST)=$G(^OR(100,+ORIFN,4.5,J,1)) + S I=0 F S I=$O(^OR(100,+ORIFN,4.5,"ID","ORDERABLE",I)) Q:I'>0 D Q:Y + . S OI0=$G(^OR(100,+ORIFN,4.5,I,0)),OI=+$G(^(1)) + . S PSOI=+$P($G(^ORD(101.43,OI,0)),U,2) + . I $P(OI0,U,2)=ORA,$G(ORX("A",PSOI)) D Q + .. S INST=$P(OI0,U,3),STR=+ORX("A",PSOI),UNT=$P(ORX("A",PSOI),U,2) + .. I STR'=$G(ORX("STRENGTH",INST)) S Y=1 Q + .. I UNT'=$G(ORX("UNITS",INST)) S Y=1 Q + .. K ORX("A",PSOI) ;same + . I $P(OI0,U,2)=ORB,$G(ORX("B",PSOI)) D Q + .. S INST=$P(OI0,U,3),VOL=+$G(ORX("B",PSOI)) + .. I VOL'=$G(ORX("VOLUME",INST)) S Y=1 Q + .. K ORX("B",PSOI) ;same + . S Y=1 + I $O(ORX("A",0))!$O(ORX("B",0)) S Y=1 ;leftover items - changed + Q Y + ; +CHANGED() ; -- Compare ORMSG to order ORIFN, return 1 if different + N X,Y,X1,ZSC,NTE,SIG,PI S Y=0 + I $G(ORCAT)="I" D G CHQ + . I $$WPX S Y=1 Q ;Special Instructions + . ;S X=$$VALUE("DAYS") ;duration + . ;I X S X1=$$DURATION^ORMPS1($P($G(ORQT(1)),U,3)) I X'=X1 S Y=1 Q + . I $$IVX S Y=1 Q ;IV fields + S X=$P($P(RXE,"|",3),U,4) I X'=$$VALUE("DRUG") S Y=1 G CHQ + I $P(RXE,"|",11)'=$$VALUE("QTY") S Y=1 G CHQ + I $P(RXE,"|",13)'=$$VALUE("REFILLS") S Y=1 G CHQ + S X=$P(RXE,"|",23) S:$E(X)="D" X=+$E(X,2,99) I X'=$$VALUE("SUPPLY") S Y=1 G CHQ + I $P(ZRX,"|",5)'=$$VALUE("PICKUP") S Y=1 G CHQ + S NTE=$$NTE^ORMPS1(21),SIG=+$O(^OR(100,+ORIFN,4.5,"ID","SIG",0)) ;verb + I NTE,SIG,$P($P(@ORMSG@(NTE),"|",4)," ")'=$P($G(^OR(100,+ORIFN,4.5,SIG,2,1,0))," ") S Y=1 G CHQ + S NTE=$$NTE^ORMPS1(7),PI=+$O(^OR(100,+ORIFN,4.5,"ID","PI",0)) + I (NTE&'PI)!('NTE&PI) Q 1 ;added or deleted + I NTE,PI,$P(@ORMSG@(NTE),"|",4)'=$G(^OR(100,+ORIFN,4.5,PI,2,1,0)) S Y=1 G CHQ + Q:'$P($G(^OR(100,+ORIFN,8,0)),U,3) + N LSTACT,PREPRV,CURPRV S LSTACT="?",(PREPRV,CURPRV)=0 + F S LSTACT=$O(^OR(100,+ORIFN,8,LSTACT),-1) Q:LSTACT + S PREPRV=$P($G(^OR(100,+ORIFN,8,LSTACT,0)),U,3) + S CURPRV=$P($G(ORC),"|",13) + I (PREPRV'=CURPRV) S Y=1 G CHQ +CHQ Q Y + ; +VALUE(ID) ; -- Return value of ID in ^OR(100,+ORIFN,4.5,"ID") + N I,Y I '$L($G(ID)) Q "" + S I=+$O(^OR(100,+ORIFN,4.5,"ID",ID,0)) + S Y=$G(^OR(100,+ORIFN,4.5,I,1)) + Q Y + ; +PTR(X) ; -- Return ptr to prompt OR GTX X + Q +$O(^ORD(101.41,"AB","OR GTX "_X,0)) + ; +RO ; -- Replacement order (finished) + ; + N RXO,RXC,ORDIALOG,ORDG,ORPKG,ORDA,ORX,ORSIG,ORP,ZSC,NEWSTS + K ^TMP("ORWORD",$J) + I '$D(^VA(200,ORNP,0)) S ORERR="Missing or invalid ordering provider" Q + I 'RXE S ORERR="Missing or invalid RXE segment" Q + S RXO=$$RXO^ORMPS,RXC=$$RXC^ORMPS,ORIFN=+$G(ORIFN) + I ORIFN'>0 S ORERR="Missing or invalid order number" Q + D @($S(RXC:"IV",$G(ORCAT)="I":"UDOSE",1:"OUT")_"^ORMPS1") Q:$D(ORERR) + S ORDA=$$ACTION^ORCSAVE("XX",ORIFN,ORNP,"",ORNOW,ORWHO) + I ORDA'>0 S ORERR="Cannot create new order action" Q +RO1 ; -Update sts of order to active, last action to dc/edit: + S ORX=ORDA F S ORX=+$O(^OR(100,ORIFN,8,ORX),-1) Q:ORX'>0 I $D(^(ORX,0)),$P(^(0),U,15)="" Q ;ORX=last released action + S:ORX $P(^OR(100,ORIFN,8,ORX,0),U,15)=12 ;dc/edit + S $P(^OR(100,ORIFN,3),U,7)=ORDA,NEWSTS=$S('$G(ORSTS):0,ORSTS=$P(^(3),U,3):0,1:1) K ^(6) + D STATUS^ORCSAVE2(ORIFN,ORSTS):NEWSTS,SETALL^ORDD100(ORIFN):'NEWSTS + D DATES^ORCSAVE2(ORIFN,ORSTRT,ORSTOP) + D RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,ORWHO,ORNATR) + ; -If unsigned edit, leave XX unsigned & mark ORX as Sig Not Req'd + S ORSIG=$S($P($G(^OR(100,ORIFN,8,ORX,0)),U,4)'=2:1,1:0) + D SIGSTS^ORCSAVE2(ORIFN,ORDA):ORSIG,SIGN^ORCSAVE2(ORIFN,,,5,ORX):'ORSIG +RO2 ; -Update responses, get/save new order text: + K ^OR(100,ORIFN,4.5) D RESPONSE^ORCSAVE,ORDTEXT^ORCSAVE1(ORIFN_";"_ORDA) + S $P(^OR(100,ORIFN,0),U,5)=ORDIALOG_";ORD(101.41,",$P(^(0),U,14)=ORPKG + ;I $P(^OR(100,ORIFN,0),U,11)'=ORDG D ;update DG,xrefs + ;AGP Changes to handle IMO IV orders CPRS 26v43 + I $P(^OR(100,ORIFN,0),U,11)'=ORDG,$P(^OR(100,ORIFN,0),U,11)'=$O(^ORD(100.98,"B","CLINIC ORDERS","")) D + . N DA,DR,DIE + . S DA=ORIFN,DR="23////"_ORDG,DIE="^OR(100," D ^DIE + S ^OR(100,ORIFN,4)=PKGIFN,$P(^(8,ORDA,0),U,14)=ORDA + S ORIFN=ORIFN_";"_ORDA,ORDCNTRL="SN" ;to send NA msg back + I $G(ORL) S ORP(1)=ORIFN_"^1" D PRINTS^ORWD1(.ORP,+ORL) + I $G(ORCAT)="O" S ZSC=$$ZSC^ORMPS1 I ZSC,$P(ZSC,"|",2)'?2.3U S ^OR(100,+ORIFN,5)=$TR($P(ZSC,"|",2,7),"|","^") ;1 or 0 instead of [N]SC in #100 + Q +IVLIM(IVDUR) ; + I $L(IVDUR) D + . N DURU,DURV S DURU="",DURV=0 + . S DURU=$E(IVDUR,1),DURV=$E(IVDUR,2,$L(IVDUR)) + . I (DURU="D")!(DURU="d") S IVDUR="for "_+DURV_$S(+DURV=1:" day",+DURV>1:" days",1:" day") + . I (DURU="H")!(DURU="h") S IVDUR="for "_+DURV_$S(+DURV=1:" hours",+DURV>1:" hours",1:" hour") + . I (DURU="M")!(DURU="m") S IVDUR="with total volume "_+DURV_" ml" + . I (DURU="L")!(DURU="l") S IVDUR="with total volume "_+DURV_" L" + Q IVDUR +PCOMM ; -- Get Provider Comments from previous order, when changed + N OLD,I + S OLD=+$G(ORIFN) I OLD<1 S OLD=+$P(ZRX,"|",2) Q:OLD<1 + S I=+$O(^OR(100,OLD,4.5,"ID","COMMENT",0)) Q:I<1 + Q:'$O(^OR(100,OLD,4.5,I,2,0)) ;none + M ^TMP("ORWORD",$J,PC,1)=^OR(100,OLD,4.5,I,2) + S ORDIALOG(PC,1)="^TMP(""ORWORD"",$J,"_PC_",1)" + S ORDIALOG(PC,"FORMAT")="@" ;text in Sig already + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMPS3.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMPS3.m index fb6b1aa5..bd592e58 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMPS3.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMPS3.m @@ -1,113 +1,42 @@ -ORMPS3 ;SLC/MKB - Process Pharmacy ORM msgs cont ;05/08/2008 10:32 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**213,243**;Dec 17, 1997;Build 242 - ; -PTR(X) ; -- Return ptr to prompt OR GTX X - Q +$O(^ORD(101.41,"AB","OR GTX "_X,0)) - ; -PARENT ; -- create parent order for backdoor complex renewals - ; Expects ORIFN, ORIG, ORDIALOG() - ;Q:'$$PATCH^XPDUTL("PSJ*5.0*110") - N ORIGDAD,ORIFNDAD,HDR S ORIGDAD=$P($G(^OR(100,ORIG,3)),U,9) - Q:ORIGDAD<1 Q:$$DOSES^ORCACT4(ORIGDAD)'>1 ;cont if complex - S ORIFNDAD=$P($G(^OR(100,ORIGDAD,3)),U,6) I ORIFNDAD<1 D G P1 - . N ORIFN D EN^ORCSAVE Q:ORIFN<1 - . S $P(^OR(100,ORIFN,3),U,5)=ORIGDAD,$P(^(3),U,8)=1,$P(^(3),U,11)=2 - . S $P(^OR(100,ORIGDAD,3),U,6)=ORIFN,ORIFNDAD=ORIFN - . D RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR) - . D SIGSTS^ORCSAVE2(ORIFN,1),DATES^ORCSAVE2(ORIFN,ORSTRT) - . I $P(^OR(100,ORIFN,8,1,0),U,4)=2 S $P(^(0),U,4)="" K ^OR(100,"AS",ORVP,9999999-ORLOG,ORIFN,1) ;sign children instead - . ;STATUS updated in SN2^ORMPS from child orders -P0 ; -- just add conjunction, new dose if DAD already exists - N INST,DA,PTR,ID,P,I,J,X - S INST=$$DOSES^ORCACT4(ORIFNDAD),DA=$O(^OR(100,ORIFNDAD,4.5,"A"),-1) - S PTR=$$PTR("AND/THEN"),ID="CONJ",DA=DA+1 - S ^OR(100,ORIFNDAD,4.5,DA,0)=U_PTR_U_INST_U_ID,^(1)="A" - S ^OR(100,ORIFNDAD,4.5,"ID","CONJ",DA)="",INST=INST+1 - F P="INSTRUCTIONS","ROUTE","SCHEDULE","DURATION","DOSE","DISPENSE DRUG" D - . S PTR=$$PTR(P) Q:'$L($G(ORDIALOG(PTR,1))) - . S DA=DA+1,ID=$P($G(^ORD(101.41,PTR,1)),U,3) - . S ^OR(100,ORIFNDAD,4.5,DA,0)=U_PTR_U_INST_U_ID,^(1)=ORDIALOG(PTR,1) - . S ^OR(100,ORIFNDAD,4.5,"ID",ID,DA)="" - S $P(^OR(100,ORIFNDAD,4.5,0),U,3,4)=DA_U_DA - S P=$$PTR("SIG"),DA=+$O(^OR(100,ORIFNDAD,4.5,"ID","SIG",0)) - S I=+$O(^OR(100,ORIFNDAD,4.5,DA,2,""),-1),X=$G(^(I,0)) S:$L(X) X=X_" AND",^(0)=X - S J=0 F S J=$O(^TMP("ORWORD",$J,PTR,1,J)) Q:J<1 S I=I+1,^OR(100,ORIFNDAD,4.5,DA,2,I,0)=^TMP("ORWORD",$J,PTR,1,J,0) - S $P(^OR(100,ORIFNDAD,4.5,DA,2,0),U,3,4)=I_U_I - ; -- rebuild order text w/new SIG - K ^TMP("ORWORD",$J,PTR) M ^TMP("ORWORD",$J,PTR,1)=^OR(100,ORIFNDAD,4.5,DA,2) - K ^OR(100,ORIFNDAD,8,1,.1) D ORDTEXT^ORCSAVE1(ORIFNDAD_";1") -P1 ; -- set up links - S $P(^OR(100,ORIFN,3),U,9)=ORIFNDAD - S HDR=$G(^OR(100,ORIFNDAD,2,0)),^(0)="^100.002PA^"_ORIFN_U_($P(HDR,U,4)+1),^(ORIFN,0)=ORIFN - Q - ; -NTE(ID) ; -- Return subscript of NTE|ID segment - N I,SEG,Y S Y="",I=+RXE S:'$G(ID) ID=21 - F S I=$O(@ORMSG@(I)) Q:I'>0 S SEG=@ORMSG@(I) Q:$E(SEG,1,3)="ORC" I $P(SEG,"|",1,2)=("NTE|"_ID) S Y=I Q - Q Y - ; -NTXT(NTE) ; -- Return string of text in ORMSG(NTE) - N Y,I S NTE=+$G(NTE) - S Y=$P($G(@ORMSG@(NTE)),"|",4),Y=$$UNESC^ORHLESC(Y) - S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I<1 S Y=Y_" "_$$UNESC^ORHLESC(@ORMSG@(NTE,I)) - Q Y - ; -ZSC() ; -- Return subscript of ZSC segment - N I,SEG,Y S Y="",I=+RXE - F S I=$O(@ORMSG@(I)) Q:I'>0 S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC" I SEG="ZSC" S Y=I_U_@ORMSG@(I) Q - Q Y - ; -NUMADDS() ; -- count number of additives to determine type - N CNT,I,X S CNT=0,I=+RXE - F S I=$O(@ORMSG@(I)) Q:I'>0 S X=@ORMSG@(I) Q:$P(X,"|")="ORC" I $E(X,1,6)="RXC|A|" S CNT=CNT+1 - Q CNT - ; -DURATION(X) ; -- Returns "# units" from U# format - N Y,Y1,Y2 I X'?.1U1.N Q "" - S Y1=$E(X),Y2=+$E(X,2,$L(X)) I X=+X S Y1="D",Y2=+X - S Y=Y2_" "_$S(Y1="L":"MONTH",Y1="W":"WEEK",Y1="H":"HOUR",Y1="M":"MINUTE",Y1="S":"SECOND",1:"DAY")_$S(Y2>1:"S",1:"") - Q Y - ; -UPD ; -- Compare ORMSG to order, update responses [from SC^ORMPS] - ; Also expects ORIFN,ORNP,ORCAT,OR3,RXE,ZRX,PKGIFN - N X,I,ORDER,ZSC,NTE,PI - S ORDER=+$G(ORIFN),I=+$P(ORIFN,";",2) I I<1 D - . S I=+$P(OR3,U,7) Q:I - . S I=$O(^OR(100,+ORIFN,8,"A"),-1) - S X=+$P($G(^OR(100,+ORIFN,8,I,0)),U,3) S:X'=ORNP $P(^(0),U,3)=ORNP - S X=+$P($P(RXE,"|",3),U,4) - I X,X'=+$$VALUE(ORDER,"DRUG") D RESP^ORCSAVE2(ORDER,"OR GTX DISPENSE DRUG",X) - I $G(ORCAT)="I" D Q - . S X=$P($P($P(RXE,"|",2),U,2),"&",2) - . I X'=$$VALUE(ORDER,"ADMIN") D RESP^ORCSAVE2(ORDER,"OR GTX ADMIN TIMES",X) - . ;SCHEDULE TYPE - . S X=$P($P(RXE,"|",2),U,7) - . I X'=$$VALUE(ORDER,"SCHTYPE") D RESP^ORCSAVE2(ORDER,"OR GTX SCHEDULE TYPE",X) - . I $S(X="P":1,X="O":1,X="OC":1,1:0) D - . .D RESP^ORCSAVE2(ORDER,"OR GTX ADMIN TIMES","") - I $G(PKGIFN)'["N" D ;Rx only, not non-VA - . S X=$P(RXE,"|",23) S:$E(X)="D" X=+$E(X,2,99) - . I +X'=+$$VALUE(ORDER,"SUPPLY") D RESP^ORCSAVE2(ORDER,"OR GTX DAYS SUPPLY",X) - . I $P(ZRX,"|",5)'=$$VALUE(ORDER,"PICKUP") D RESP^ORCSAVE2(ORDER,"OR GTX ROUTING",$P(ZRX,"|",5)) - . S NTE=$$NTE(7),PI=+$O(^OR(100,ORDER,4.5,"ID","PI",0)) - . I NTE,PI,$$NTXT(NTE)'=$$VALTXT(ORDER,PI) D - .. N CNT K ^OR(100,ORDER,4.5,PI,2) - .. S CNT=1,^OR(100,ORDER,4.5,PI,2,1,0)=$$UNESC^ORMPS2($P(@ORMSG@(NTE),"|",4)) - .. S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I<1 S CNT=CNT+1,^OR(100,ORDER,4.5,PI,2,CNT,0)=$$UNESC^ORMPS2(@ORMSG@(NTE,I)) - .. S ^OR(100,ORDER,4.5,PI,2,0)="^^"_CNT_U_CNT_U_DT_U - S ZSC=$$ZSC I ZSC,$P(ZSC,"|",2)'?2.3U S ^OR(100,ORDER,5)=$TR($P(ZSC,"|",2,7),"|","^") ;1 or 0 instead of [N]SC - Q - ; -VALUE(IFN,ID,INST) ; -- Returns value of prompt by identifier ID - I '$G(IFN)!('$D(^OR(100,+$G(IFN),0)))!($G(ID)="") Q "" - N I,Y S I=0,Y="" S:'$G(INST) INST=1 - F S I=$O(^OR(100,IFN,4.5,"ID",ID,I)) Q:I'>0 I $P($G(^OR(100,IFN,4.5,+I,0)),U,3)=INST S Y=$G(^(1)) Q - Q Y - ; -VALTXT(IFN,ID) ; -- Return string of text for prompt ID [assumes single instance] - ; ID may be identifier name or Response IEN - N Y,DA,I S IFN=+$G(IFN),ID=$G(ID) - S DA=$S($G(ID):+ID,$L(ID):+$O(^OR(100,IFN,4.5,"ID",ID,0)),1:0) - S I=+$O(^OR(100,IFN,4.5,DA,2,0)),Y=$G(^(I,0)) - F S I=$O(^OR(100,IFN,4.5,DA,2,I)) Q:I<1 S Y=Y_" "_$G(^(I,0)) - Q Y +ORMPS3 ;SLC/MKB - Process Pharmacy ORM msgs cont ;12/3/03 10:32 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**213**;Dec 17, 1997 + ; +PTR(X) ; -- Return ptr to prompt OR GTX X + Q +$O(^ORD(101.41,"AB","OR GTX "_X,0)) + ; +PARENT ; -- create parent order for backdoor complex renewals + ; Expects ORIFN, ORIG, ORDIALOG() + ;Q:'$$PATCH^XPDUTL("PSJ*5.0*110") + N ORIGDAD,ORIFNDAD,HDR S ORIGDAD=$P($G(^OR(100,ORIG,3)),U,9) + Q:ORIGDAD<1 Q:$$DOSES^ORCACT4(ORIGDAD)'>1 ;cont if complex + S ORIFNDAD=$P($G(^OR(100,ORIGDAD,3)),U,6) I ORIFNDAD<1 D G P1 + . N ORIFN D EN^ORCSAVE Q:ORIFN<1 + . S $P(^OR(100,ORIFN,3),U,5)=ORIGDAD,$P(^(3),U,8)=1,$P(^(3),U,11)=2 + . S $P(^OR(100,ORIGDAD,3),U,6)=ORIFN,ORIFNDAD=ORIFN + . D RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR) + . D SIGSTS^ORCSAVE2(ORIFN,1),DATES^ORCSAVE2(ORIFN,ORSTRT) + . I $P(^OR(100,ORIFN,8,1,0),U,4)=2 S $P(^(0),U,4)="" K ^OR(100,"AS",ORVP,9999999-ORLOG,ORIFN,1) ;sign children instead + . ;STATUS updated in SN2^ORMPS from child orders +P0 ; -- just add conjunction, new dose if DAD already exists + N INST,DA,PTR,ID,P,I,J,X + S INST=$$DOSES^ORCACT4(ORIFNDAD),DA=$O(^OR(100,ORIFNDAD,4.5,"A"),-1) + S PTR=$$PTR("AND/THEN"),ID="CONJ",DA=DA+1 + S ^OR(100,ORIFNDAD,4.5,DA,0)=U_PTR_U_INST_U_ID,^(1)="A" + S ^OR(100,ORIFNDAD,4.5,"ID","CONJ",DA)="",INST=INST+1 + F P="INSTRUCTIONS","ROUTE","SCHEDULE","DURATION","DOSE","DISPENSE DRUG" D + . S PTR=$$PTR(P) Q:'$L($G(ORDIALOG(PTR,1))) + . S DA=DA+1,ID=$P($G(^ORD(101.41,PTR,1)),U,3) + . S ^OR(100,ORIFNDAD,4.5,DA,0)=U_PTR_U_INST_U_ID,^(1)=ORDIALOG(PTR,1) + . S ^OR(100,ORIFNDAD,4.5,"ID",ID,DA)="" + S $P(^OR(100,ORIFNDAD,4.5,0),U,3,4)=DA_U_DA + S P=$$PTR("SIG"),DA=+$O(^OR(100,ORIFNDAD,4.5,"ID","SIG",0)) + S I=+$O(^OR(100,ORIFNDAD,4.5,DA,2,""),-1),X=$G(^(I,0)) S:$L(X) X=X_" AND",^(0)=X + S J=0 F S J=$O(^TMP("ORWORD",$J,PTR,1,J)) Q:J<1 S I=I+1,^OR(100,ORIFNDAD,4.5,DA,2,I,0)=^TMP("ORWORD",$J,PTR,1,J,0) + S $P(^OR(100,ORIFNDAD,4.5,DA,2,0),U,3,4)=I_U_I + ; -- rebuild order text w/new SIG + K ^TMP("ORWORD",$J,PTR) M ^TMP("ORWORD",$J,PTR,1)=^OR(100,ORIFNDAD,4.5,DA,2) + K ^OR(100,ORIFNDAD,8,1,.1) D ORDTEXT^ORCSAVE1(ORIFNDAD_";1") +P1 ; -- set up links + S $P(^OR(100,ORIFN,3),U,9)=ORIFNDAD + S HDR=$G(^OR(100,ORIFNDAD,2,0)),^(0)="^100.002PA^"_ORIFN_U_($P(HDR,U,4)+1),^(ORIFN,0)=ORIFN + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMRA.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMRA.m index ee4b619e..94e903ea 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMRA.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMRA.m @@ -1,183 +1,182 @@ -ORMRA ; SLC/MKB/RV - Process Radiology ORM msgs ;2/21/02 15:44 [05/30/06 12:30pm] - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,53,92,110,136,153,174,195,243**;Dec 17, 1997;Build 242 - ;DBIA 2968 allows for reading ^DIC(34 -EN ; -- entry point for RA messages - I '$L($T(@ORDCNTRL)) Q ;S ORERR="Invalid order control code" Q - I ORDCNTRL'="SN",ORDCNTRL'="ZP",'ORIFN!('$D(^OR(100,+ORIFN,0))) S ORERR="Invalid OE/RR order number" Q - S OREASON=$S($P(OREASON,U,6)="99RAR":$P(OREASON,U,5),1:$P(OREASON,U,2)) - S:'ORDUZ ORDUZ=DUZ S:'ORLOG ORLOG=+$E($$NOW^XLFDT,1,12) - D @ORDCNTRL - Q - ; -ZP ; -- Purged - Q:'ORIFN Q:'$D(^OR(100,+ORIFN,0)) K ^OR(100,+ORIFN,4) - ; - Set status=lapsed, if still active - I "^3^5^6^8^"[(U_$P($G(^(3)),U,3)_U) D STATUS^ORCSAVE2(ORIFN,14) - Q - ; -ZR ; -- Purged as requested [ack] - D DELETE^ORCSAVE2(+ORIFN) - Q - ; -ZU ; -- Unable to purge [ack] - S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ; update Last Activity - Q - ; -OK ; -- Order accepted, RA order # assigned [ack] - N ORSTS,OBR S ^OR(100,+ORIFN,4)=PKGIFN,ORSTS=5 ; 5=pending - ; Ck if also scheduled, else quit - S OBR=$O(@ORMSG@(+ORC)) G:'OBR OKQ G:$E(@ORMSG@(OBR),1,3)'="OBR" OKQ - S ORSTRT=$$FMDATE^ORM($P(@ORMSG@(OBR),"|",37)) - D:ORSTRT DATES^ORCSAVE2(+ORIFN,ORSTRT) -OKQ D STATUS^ORCSAVE2(ORIFN,ORSTS) - ;Save the Radiology pre-certification Account Reference in the PV1 - ;segment of the HL7 message from the Radiology package to the Order - ;File (#100). Support for Patch OR*3.0*228 - I +$$SWSTAT^IBBAPI() D PRECERT^ORWPFSS2 ;IA #4663 - Q - ; -XX ; -- Change order - N ORDIALOG,ORDG,ORDA,ORX,ORP S:'$L(ORNATR) ORNATR="S" - D DLG Q:$D(ORERR) Q:'$D(ORDIALOG) S ORIFN=+ORIFN - S ORDA=$$ACTION^ORCSAVE("XX",ORIFN,ORNP,OREASON,ORLOG,ORDUZ) - I ORDA'>0 S ORERR="Cannot create new order action" Q - ; -Update sts of order to active, last action to dc/edit: - S ORX=+$P($G(^OR(100,ORIFN,3)),U,7) - S:$P($G(^OR(100,ORIFN,8,ORX,0)),U,15)="" $P(^(0),U,15)=12 - S $P(^OR(100,ORIFN,3),U,7)=ORDA D STATUS^ORCSAVE2(ORIFN,6) - D RELEASE^ORCSAVE2(ORIFN,ORDA,ORLOG,ORDUZ,ORNATR) - ; -If unsigned edit, leave XX unsigned & mark ORX as Sig Not Req'd - S ORSIG=$S($P($G(^OR(100,ORIFN,8,ORX,0)),U,4)'=2:1,1:0) - D SIGSTS^ORCSAVE2(ORIFN,ORDA):ORSIG,SIGN^ORCSAVE2(ORIFN,,,5,ORX):'ORSIG - ; -Update responses, get/save new order text: - K ^OR(100,ORIFN,4.5) D RESPONSE^ORCSAVE,ORDTEXT^ORCSAVE1(ORIFN_";"_ORDA) - S $P(^OR(100,ORIFN,8,ORDA,0),U,14)=ORDA - I $G(ORL) S ORP(1)=+ORIFN_";"_ORDA_"^1" D PRINTS^ORWD1(.ORP,+ORL) - Q - ; -SN ; -- New backdoor order: return NA msg w/ORIFN, or DE msg - N ORDIALOG,ORDG,ORP K ^TMP("ORWORD",$J) S:'$L(ORNATR) ORNATR="W" - I ORDUZ,'$D(^VA(200,ORDUZ,0)) S ORERR="Invalid entering person" Q - I '$D(^VA(200,ORNP,0)) S ORERR="Missing or invalid ordering provider" Q - I '$G(ORL) S ORERR="Missing or invalid patient location" Q - D DLG Q:$D(ORERR) Q:'$D(ORDIALOG) -SNQ D EN^ORCSAVE K ^TMP("ORWORD",$J) - I '$G(ORIFN) S ORERR="Cannot create new order" Q - ;Save DG1 and ZCL segments of HL7 message from backdoor orders - D BDOSTR^ORWDBA3 - ;Save the Radiology pre-certification Account Reference in the PV1 - ;segment of the HL7 message from the Radiology package to the Order - ;File (#100). Support for Patch OR*3.0*228 - I +$$SWSTAT^IBBAPI() D PRECERT^ORWPFSS2 ;IA #4663 - D RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR),SIGSTS^ORCSAVE2(ORIFN,1) - D STATUS^ORCSAVE2(ORIFN,5) S ^OR(100,ORIFN,4)=PKGIFN - I $G(ORL) S ORP(1)=ORIFN_";1^1" D PRINTS^ORWD1(.ORP,+ORL) ; chart copy - Q - ; -DLG ; -- Build ORDIALOG() from msg - N OBR,OI,MODS,J,X,Y,ILOC,MODE,CH,CHI,OBX,NTE,REASON - S ORDIALOG=$O(^ORD(101.41,"AB","RA OERR EXAM",0)) - D GETDLG1^ORCD(ORDIALOG) - S ORDIALOG($$PTR("CATEGORY"),1)=$G(ORCAT) - S ORDIALOG($$PTR("START DATE/TIME"),1)=ORSTRT - S ORDIALOG($$PTR("URGENCY"),1)=ORURG - S:$P(ORC,"|",12) ORDIALOG($$PTR("PROVIDER"),1)=+$P(ORC,"|",12) -D1 S OBR=$O(@ORMSG@(+ORC)) I 'OBR!($E($G(@ORMSG@(OBR)),1,3)'="OBR") S ORERR="Missing OBR segment" Q - S OI=$$ORDITEM^ORM($P(@ORMSG@(OBR),"|",5)) - I 'OI S ORERR="Invalid procedure" Q - S ORDIALOG($$PTR("ORDERABLE ITEM"),1)=OI - S ORDG=$P($G(^ORD(101.43,+OI,"RA")),U,3) S:$L(ORDG) ORDG=+$O(^ORD(100.98,"B",ORDG,0)) I 'ORDG S ORDG=$P(^ORD(101.41,+ORDIALOG,0),U,5) ; Im Type - S MODS=$P(@ORMSG@(OBR),"|",19) I $L(MODS) D - . F J=1:1:$L(MODS,"~") S X=$P(MODS,"~",J) I $L(X) S Y=$O(^RAMIS(71.2,"B",X,0)) S:Y ORDIALOG($$PTR("MODIFIERS"),J)=Y - S ILOC=+$P(@ORMSG@(OBR),"|",20),MODE=$P(@ORMSG@(OBR),"|",31),REASON=$P($P(@ORMSG@(OBR),"|",32),U,2) - S:ILOC ORDIALOG($$PTR("IMAGING LOCATION"),1)=ILOC - S ORDIALOG($$PTR("MODE OF TRANSPORT"),1)=$S(MODE="WALK":"A",MODE="CART":"S",1:$E(MODE)) - S:$L(REASON) ORDIALOG($$PTR("STUDY REASON"),1)=REASON - I ORDCNTRL="XX" S NTE=+$O(@ORMSG@(OBR)) I NTE,$E($G(@ORMSG@(NTE)),1,3)="NTE" S OREASON=$P(@ORMSG@(NTE),"|",4) ;Tech's Comments -D2 ; might the procedure be scheduled at this point ?? Not in spec - S CH=$$PTR("WORD PROCESSING 1"),CHI=0 - S OBX=OBR F S OBX=$O(@ORMSG@(OBX)) Q:OBX'>0 S J=$E(@ORMSG@(OBX),1,3) Q:J="ORC" Q:J="MSH" I J="OBX" D - . N NAME,VALUE,X0 S VALUE=$P(@ORMSG@(OBX),"|",6) - . S NAME=$$UP^XLFSTR($P($P(@ORMSG@(OBX),"|",4),U,2)) - . I NAME="CONTRACT/SHARING SOURCE" S X0=$G(^DIC(34,+VALUE,0)) S:$L(X0) ORDIALOG($$PTR(NAME),1)=+VALUE,ORDIALOG($$PTR("CATEGORY"),1)=$P(X0,U,2) Q - . I NAME="RESEARCH SOURCE" S ORDIALOG($$PTR(NAME),1)=VALUE,ORDIALOG($$PTR("CATEGORY"),1)="R" Q - . I NAME="PREGNANT" S ORDIALOG($$PTR(NAME),1)=VALUE Q - . I NAME="PRE-OP SCHEDULED DATE/TIME" S ORDIALOG($$PTR(NAME),1)=$$FMDATE^ORM(VALUE) Q - . S CHI=CHI+1,^TMP("ORWORD",$J,CH,1,CHI,0)=VALUE - S:CHI ^TMP("ORWORD",$J,CH,1,0)="^^"_CHI_U_CHI_U_DT_U,ORDIALOG(CH,1)="^TMP(""ORWORD"",$J,"_CH_",1)" - Q - ; -PTR(X) ; -- Returns ptr to prompt in Order Dialog file #101.41 - Q +$O(^ORD(101.41,"AB",$E("OR GTX "_X,1,63),0)) - ; -SC ; -- Status changed (scheduled, registered, or unverified) - N ORSTS,OBR,OR3 ;110 - S ORSTS=$S(ORDSTS="ZR":6,ORDSTS="ZU":6,1:8),OR3=$G(^OR(100,+ORIFN,3)) ;110 - G:ORSTS=6 SCQ ;136 Done if active, else get scheduled data - S OBR=$O(@ORMSG@(+ORC)) I 'OBR!($E($G(@ORMSG@(OBR)),1,3)'="OBR") S ORERR="Missing OBR segment" Q - S ORSTRT=$$FMDATE^ORM($P(@ORMSG@(OBR),"|",37)) - D:ORSTRT DATES^ORCSAVE2(+ORIFN,ORSTRT) - I $P(OR3,U,3)=3,$P($G(^OR(100,+ORIFN,8,+$P(OR3,U,7),0)),U,2)="HD" D RL ;If status is hold and current action is hold then release. Added with 110 -SCQ D STATUS^ORCSAVE2(ORIFN,ORSTS) - Q - ; -RE ; -- Completed, w/results - N I,SEG,OBX - D STATUS^ORCSAVE2(ORIFN,2) - S OBX="" D ;get Results D/T [from OBR] - . N DA,DR,DIE,X,Y,OBR - . S DA=+ORIFN,DIE="^OR(100,",OBR=+$O(@ORMSG@(+ORC)),X="" - . I OBR,$E($G(@ORMSG@(OBR)),1,3)="OBR" S X=$P(@ORMSG@(OBR),"|",23) - . S DR="71////"_$S(X:$$FMDATE^ORM(X),1:+$E($$NOW^XLFDT,1,12)) D ^DIE - S I=+ORC F S I=$O(@ORMSG@(I)) Q:I<1 S SEG=$G(@ORMSG@(I)) Q:$E(SEG,1,3)="ORC" I $E(SEG,1,3)="OBX" S OBX=I_U_SEG Q ;first one - S $P(^OR(100,+ORIFN,7),U,2)=$S($P(OBX,"|",9)="A":1,1:"") - S:'$G(ORNP) ORNP=+$P($G(^OR(100,+ORIFN,0)),U,4) - I $L($T(ADD^ORRCACK)) D ADD^ORRCACK(+ORIFN,ORNP) ;Ack stub for prov - Q - ; -OH ; -- Held - D UPDATE(3,"HD") - Q - ; -OC ; -- Cancelled/Unable to accept [ack] -UA ; -- Unable to accept [ack] - S:'$L(ORNATR) ORNATR="X" ;Rejected - S ^OR(100,+ORIFN,6)=$O(^ORD(100.02,"C",ORNATR,0))_U_U_ORLOG_U_U_OREASON - D STATUS^ORCSAVE2(ORIFN,13) -UD ; -- Unable to discontinue [ack] - N DA S DA=+$P(ORIFN,";",2) I DA D - . S $P(^OR(100,+ORIFN,8,DA,0),U,15)=13 ;Request rejected - . S:$L(OREASON) ^OR(100,+ORIFN,8,DA,1)=OREASON - Q - ; -OD ; -- Discontinued - S:$G(DGPMT) ORDUZ="" ;auto-dc on movement - S ^OR(100,+ORIFN,6)=$S($L(ORNATR):$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORDUZ_U_ORLOG_U_U_OREASON - D UPDATE(1,"DC") - Q - ; -DR ; -- Discontinued [ack] - D STATUS^ORCSAVE2(ORIFN,1) - Q - ; -UPDATE(ORSTS,ORACT) ; -- continue processing - N ORX,ORDA,ORP D:$G(ORSTS) STATUS^ORCSAVE2(ORIFN,ORSTS) - S ORX=$$CREATE^ORX1(ORNATR) D:ORX - . S ORDA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,OREASON,ORLOG,ORDUZ) - . I ORDA'>0 S ORERR="Cannot create new order action" Q - . D RELEASE^ORCSAVE2(+ORIFN,ORDA,ORLOG,ORDUZ,ORNATR) - . D SIGSTS^ORCSAVE2(+ORIFN,ORDA) - . I $G(ORL) S ORP(1)=+ORIFN_";"_ORDA_"^1" D PRINTS^ORWD1(.ORP,+ORL) - . S $P(^OR(100,+ORIFN,3),U,7)=ORDA - I 'ORX D ;no new action created - . ;I ORACT="DC" S:'$$ACTV^ORX1(ORNATR) $P(^OR(100,+ORIFN,3),U,7)=0 Q - . S:ORACT="HD"&$L(OREASON) ^OR(100,+ORIFN,8,1,1)=OREASON ;pend/sch only - I ORACT="DC" D CANCEL^ORCSEND(+ORIFN) S:'$$ACTV^ORX1(ORNATR) $P(^OR(100,+ORIFN,3),U,7)=0 - Q - ; -RL ;Release hold --entire section added with patch 110 - S ^OR(100,+ORIFN,8,$P(OR3,U,7),2)=ORLOG_"^"_ORDUZ ;Set release hold date/time and release hold user - S ORNATR=$S($L(ORNATR):ORNATR,1:$P(^OR(100,+ORIFN,8,$P(OR3,U,7),0),U,12)) ;set nature of order for release equal to nature of order for hold if it doesn't exist - I $G(ORSTS)="" S ORSTS=6 - D UPDATE(ORSTS,"RL") - Q +ORMRA ; SLC/MKB - Process Radiology ORM msgs ;2/21/02 15:44 [3/4/04 10:43am] + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,53,92,110,136,153,174,195,228**;Dec 17, 1997 + ;DBIA 2968 allows for reading ^DIC(34 +EN ; -- entry point for RA messages + I '$L($T(@ORDCNTRL)) Q ;S ORERR="Invalid order control code" Q + I ORDCNTRL'="SN",ORDCNTRL'="ZP",'ORIFN!('$D(^OR(100,+ORIFN,0))) S ORERR="Invalid OE/RR order number" Q + S OREASON=$S($P(OREASON,U,6)="99RAR":$P(OREASON,U,5),1:$P(OREASON,U,2)) + S:'ORDUZ ORDUZ=DUZ S:'ORLOG ORLOG=+$E($$NOW^XLFDT,1,12) + D @ORDCNTRL + Q + ; +ZP ; -- Purged + Q:'ORIFN Q:'$D(^OR(100,+ORIFN,0)) K ^OR(100,+ORIFN,4) + ; - Set status=lapsed, if still active + I "^3^5^6^8^"[(U_$P($G(^OR(100,+ORIFN,3)),U,3)_U) D STATUS^ORCSAVE2(ORIFN,14) + Q + ; +ZR ; -- Purged as requested [ack] + D DELETE^ORCSAVE2(+ORIFN) + Q + ; +ZU ; -- Unable to purge [ack] + S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ; update Last Activity + Q + ; +OK ; -- Order accepted, RA order # assigned [ack] + N ORSTS,OBR S ^OR(100,+ORIFN,4)=PKGIFN,ORSTS=5 ; 5=pending + ; Ck if also scheduled, else quit + S OBR=$O(@ORMSG@(+ORC)) G:'OBR OKQ G:$E(@ORMSG@(OBR),1,3)'="OBR" OKQ + S ORSTRT=$$FMDATE^ORM($P(@ORMSG@(OBR),"|",37)) + D:ORSTRT DATES^ORCSAVE2(+ORIFN,ORSTRT) +OKQ D STATUS^ORCSAVE2(ORIFN,ORSTS) + ;Save the Radiology pre-certification Account Reference in the PV1 + ;segment of the HL7 message from the Radiology package to the Order + ;File (#100). Support for Patch OR*3.0*228 + D PRECERT^ORWPFSS2 + Q + ; +XX ; -- Change order + N ORDIALOG,ORDG,ORDA,ORX,ORP S:'$L(ORNATR) ORNATR="S" + D DLG Q:$D(ORERR) Q:'$D(ORDIALOG) S ORIFN=+ORIFN + S ORDA=$$ACTION^ORCSAVE("XX",ORIFN,ORNP,OREASON,ORLOG,ORDUZ) + I ORDA'>0 S ORERR="Cannot create new order action" Q + ; -Update sts of order to active, last action to dc/edit: + S ORX=+$P($G(^OR(100,ORIFN,3)),U,7) + S:$P($G(^OR(100,ORIFN,8,ORX,0)),U,15)="" $P(^(0),U,15)=12 + S $P(^OR(100,ORIFN,3),U,7)=ORDA D STATUS^ORCSAVE2(ORIFN,6) + D RELEASE^ORCSAVE2(ORIFN,ORDA,ORLOG,ORDUZ,ORNATR) + ; -If unsigned edit, leave XX unsigned & mark ORX as Sig Not Req'd + S ORSIG=$S($P($G(^OR(100,ORIFN,8,ORX,0)),U,4)'=2:1,1:0) + D SIGSTS^ORCSAVE2(ORIFN,ORDA):ORSIG,SIGN^ORCSAVE2(ORIFN,,,5,ORX):'ORSIG + ; -Update responses, get/save new order text: + K ^OR(100,ORIFN,4.5) D RESPONSE^ORCSAVE,ORDTEXT^ORCSAVE1(ORIFN_";"_ORDA) + S $P(^OR(100,ORIFN,8,ORDA,0),U,14)=ORDA + I $G(ORL) S ORP(1)=+ORIFN_";"_ORDA_"^1" D PRINTS^ORWD1(.ORP,+ORL) + Q + ; +SN ; -- New backdoor order: return NA msg w/ORIFN, or DE msg + N ORDIALOG,ORDG,ORP K ^TMP("ORWORD",$J) S:'$L(ORNATR) ORNATR="W" + I ORDUZ,'$D(^VA(200,ORDUZ,0)) S ORERR="Invalid entering person" Q + I '$D(^VA(200,ORNP,0)) S ORERR="Missing or invalid ordering provider" Q + I '$G(ORL) S ORERR="Missing or invalid patient location" Q + D DLG Q:$D(ORERR) Q:'$D(ORDIALOG) +SNQ D EN^ORCSAVE K ^TMP("ORWORD",$J) + I '$G(ORIFN) S ORERR="Cannot create new order" Q + ;Save DG1 and ZCL segments of HL7 message from backdoor orders + D BDOSTR^ORWDBA3 + ;Save the Rediology pre-certification Account Reference in the PV1 + ;segment of the HL7 message from the Radiology package to the Order + ;File (#100). Support for Patch OR*3.0*228 + D PRECERT^ORWPFSS2 + D RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR),SIGSTS^ORCSAVE2(ORIFN,1) + D STATUS^ORCSAVE2(ORIFN,5) S ^OR(100,ORIFN,4)=PKGIFN + I $G(ORL) S ORP(1)=ORIFN_";1^1" D PRINTS^ORWD1(.ORP,+ORL) ; chart copy + Q + ; +DLG ; -- Build ORDIALOG() from msg + N OBR,OI,MODS,J,X,Y,ILOC,MODE,CH,CHI,OBX,NTE + S ORDIALOG=$O(^ORD(101.41,"AB","RA OERR EXAM",0)) + D GETDLG1^ORCD(ORDIALOG) + S ORDIALOG($$PTR("CATEGORY"),1)=$G(ORCAT) + S ORDIALOG($$PTR("START DATE/TIME"),1)=ORSTRT + S ORDIALOG($$PTR("URGENCY"),1)=ORURG + S:$P(ORC,"|",12) ORDIALOG($$PTR("PROVIDER"),1)=+$P(ORC,"|",12) +D1 S OBR=$O(@ORMSG@(+ORC)) I 'OBR!($E($G(@ORMSG@(OBR)),1,3)'="OBR") S ORERR="Missing OBR segment" Q + S OI=$$ORDITEM^ORM($P(@ORMSG@(OBR),"|",5)) + I 'OI S ORERR="Invalid procedure" Q + S ORDIALOG($$PTR("ORDERABLE ITEM"),1)=OI + S ORDG=$P($G(^ORD(101.43,+OI,"RA")),U,3) S:$L(ORDG) ORDG=+$O(^ORD(100.98,"B",ORDG,0)) I 'ORDG S ORDG=$P(^ORD(101.41,+ORDIALOG,0),U,5) ; Im Type + S MODS=$P(@ORMSG@(OBR),"|",19) I $L(MODS) D + . F J=1:1:$L(MODS,"~") S X=$P(MODS,"~",J) I $L(X) S Y=$O(^RAMIS(71.2,"B",X,0)) S:Y ORDIALOG($$PTR("MODIFIERS"),J)=Y + S ILOC=+$P(@ORMSG@(OBR),"|",20),MODE=$P(@ORMSG@(OBR),"|",31) + S:ILOC ORDIALOG($$PTR("IMAGING LOCATION"),1)=ILOC + S ORDIALOG($$PTR("MODE OF TRANSPORT"),1)=$S(MODE="WALK":"A",MODE="CART":"S",1:$E(MODE)) + I ORDCNTRL="XX" S NTE=+$O(@ORMSG@(OBR)) I NTE,$E($G(@ORMSG@(NTE)),1,3)="NTE" S OREASON=$P(@ORMSG@(NTE),"|",4) ;Tech's Comments +D2 ; might the procedure be scheduled at this point ?? Not in spec + S CH=$$PTR("WORD PROCESSING 1"),CHI=0 + S OBX=OBR F S OBX=$O(@ORMSG@(OBX)) Q:OBX'>0 S J=$E(@ORMSG@(OBX),1,3) Q:J="ORC" Q:J="MSH" I J="OBX" D + . N NAME,VALUE,X0 S VALUE=$P(@ORMSG@(OBX),"|",6) + . S NAME=$$UP^XLFSTR($P($P(@ORMSG@(OBX),"|",4),U,2)) + . I NAME="CONTRACT/SHARING SOURCE" S X0=$G(^DIC(34,+VALUE,0)) S:$L(X0) ORDIALOG($$PTR(NAME),1)=+VALUE,ORDIALOG($$PTR("CATEGORY"),1)=$P(X0,U,2) Q + . I NAME="RESEARCH SOURCE" S ORDIALOG($$PTR(NAME),1)=VALUE,ORDIALOG($$PTR("CATEGORY"),1)="R" Q + . I NAME="PREGNANT" S ORDIALOG($$PTR(NAME),1)=VALUE Q + . I NAME="PRE-OP SCHEDULED DATE/TIME" S ORDIALOG($$PTR(NAME),1)=$$FMDATE^ORM(VALUE) Q + . S CHI=CHI+1,^TMP("ORWORD",$J,CH,1,CHI,0)=VALUE + S:CHI ^TMP("ORWORD",$J,CH,1,0)="^^"_CHI_U_CHI_U_DT_U,ORDIALOG(CH,1)="^TMP(""ORWORD"",$J,"_CH_",1)" + Q + ; +PTR(X) ; -- Returns ptr to prompt in Order Dialog file #101.41 + Q +$O(^ORD(101.41,"AB",$E("OR GTX "_X,1,63),0)) + ; +SC ; -- Status changed (scheduled, registered, or unverified) + N ORSTS,OBR,OR3 ;110 + S ORSTS=$S(ORDSTS="ZR":6,ORDSTS="ZU":6,1:8),OR3=$G(^OR(100,+ORIFN,3)) ;110 + G:ORSTS=6 SCQ ;136 Done if active, else get scheduled data + S OBR=$O(@ORMSG@(+ORC)) I 'OBR!($E($G(@ORMSG@(OBR)),1,3)'="OBR") S ORERR="Missing OBR segment" Q + S ORSTRT=$$FMDATE^ORM($P(@ORMSG@(OBR),"|",37)) + D:ORSTRT DATES^ORCSAVE2(+ORIFN,ORSTRT) + I $P(OR3,U,3)=3,$P($G(^OR(100,+ORIFN,8,+$P(OR3,U,7),0)),U,2)="HD" D RL ;If status is hold and current action is hold then release. Added with 110 +SCQ D STATUS^ORCSAVE2(ORIFN,ORSTS) + Q + ; +RE ; -- Completed, w/results + N I,SEG,OBX + D STATUS^ORCSAVE2(ORIFN,2) + S OBX="" D ;get Results D/T [from OBR] + . N DA,DR,DIE,X,Y,OBR + . S DA=+ORIFN,DIE="^OR(100,",OBR=+$O(@ORMSG@(+ORC)),X="" + . I OBR,$E($G(@ORMSG@(OBR)),1,3)="OBR" S X=$P(@ORMSG@(OBR),"|",23) + . S DR="71////"_$S(X:$$FMDATE^ORM(X),1:+$E($$NOW^XLFDT,1,12)) D ^DIE + S I=+ORC F S I=$O(@ORMSG@(I)) Q:I<1 S SEG=$G(@ORMSG@(I)) Q:$E(SEG,1,3)="ORC" I $E(SEG,1,3)="OBX" S OBX=I_U_SEG Q ;first one + S $P(^OR(100,+ORIFN,7),U,2)=$S($P(OBX,"|",9)="A":1,1:"") + S:'$G(ORNP) ORNP=+$P($G(^OR(100,+ORIFN,0)),U,4) + I $L($T(ADD^ORRCACK)) D ADD^ORRCACK(+ORIFN,ORNP) ;Ack stub for prov + Q + ; +OH ; -- Held + D UPDATE(3,"HD") + Q + ; +OC ; -- Cancelled/Unable to accept [ack] +UA ; -- Unable to accept [ack] + S:'$L(ORNATR) ORNATR="X" ;Rejected + S ^OR(100,+ORIFN,6)=$O(^ORD(100.02,"C",ORNATR,0))_U_U_ORLOG_U_U_OREASON + D STATUS^ORCSAVE2(ORIFN,13) +UD ; -- Unable to discontinue [ack] + N DA S DA=+$P(ORIFN,";",2) I DA D + . S $P(^OR(100,+ORIFN,8,DA,0),U,15)=13 ;Request rejected + . S:$L(OREASON) ^OR(100,+ORIFN,8,DA,1)=OREASON + Q + ; +OD ; -- Discontinued + S:$G(DGPMT) ORDUZ="" ;auto-dc on movement + S ^OR(100,+ORIFN,6)=$S($L(ORNATR):$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORDUZ_U_ORLOG_U_U_OREASON + D UPDATE(1,"DC") + Q + ; +DR ; -- Discontinued [ack] + D STATUS^ORCSAVE2(ORIFN,1) + Q + ; +UPDATE(ORSTS,ORACT) ; -- continue processing + N ORX,ORDA,ORP D:$G(ORSTS) STATUS^ORCSAVE2(ORIFN,ORSTS) + S ORX=$$CREATE^ORX1(ORNATR) D:ORX + . S ORDA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,OREASON,ORLOG,ORDUZ) + . I ORDA'>0 S ORERR="Cannot create new order action" Q + . D RELEASE^ORCSAVE2(+ORIFN,ORDA,ORLOG,ORDUZ,ORNATR) + . D SIGSTS^ORCSAVE2(+ORIFN,ORDA) + . I $G(ORL) S ORP(1)=+ORIFN_";"_ORDA_"^1" D PRINTS^ORWD1(.ORP,+ORL) + . S $P(^OR(100,+ORIFN,3),U,7)=ORDA + I 'ORX D ;no new action created + . I ORACT="DC" S:'$$ACTV^ORX1(ORNATR) $P(^OR(100,+ORIFN,3),U,7)=0 Q + . S:ORACT="HD"&$L(OREASON) ^OR(100,+ORIFN,8,1,1)=OREASON ;pend/sch only + D:ORACT="DC" CANCEL^ORCSEND(+ORIFN) + Q + ; +RL ;Release hold --entire section added with patch 110 + S ^OR(100,+ORIFN,8,$P(OR3,U,7),2)=ORLOG_"^"_ORDUZ ;Set release hold date/time and release hold user + S ORNATR=$S($L(ORNATR):ORNATR,1:$P(^OR(100,+ORIFN,8,$P(OR3,U,7),0),U,12)) ;set nature of order for release equal to nature of order for hold if it doesn't exist + I $G(ORSTS)="" S ORSTS=6 + D UPDATE(ORSTS,"RL") + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMTIM02.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMTIM02.m index 22c86a54..56682dcc 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMTIM02.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMTIM02.m @@ -1,91 +1,90 @@ -ORMTIM02 ; JM/SLC-ISC - PERFORM MISC TIME BASED ACTIVITIES ;05/02/06 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**253,243**;Dec 17, 1997;Build 242 - ; - Q -MISC ; Perform misc time based activities - ; - D UNSIGNED ; Generate alerts for unsigned orders that have slipped through the cracks - D INIT^ORWGTASK(0) ; check to run rebuild of cache for graphing - ; - Q - ; -UNSIGNED ; Generate alerts for unsigned orders that were not alerted by CPRS - ; This happens when CPRS crashes - through network connection drops or other causes - N ORZPAT,ORZDATE,ORZIEN,ORZSUB,ORZSDATE,%DT,X,Y,ORZTIME,ORZNOW,ORZPURGE - N ORN,ORBDFN,ORNUM,ORBADUZ,ORBPMSG,ORBPDATA,ORZREC8,ORZSIGDT,ORZSTS,ORZWHEN,ORMARKID - N MINTIME,XTMPDAYS,XTMPHOUR,MINDAYS - S ORN=12,ORMARKID="ORMTIME_UNSGNORD" - ; - S MINTIME=60 ; Order must be unsigned for 60 Minutes before generating an alert - S MINDAYS=90 ; Order must have been generated within the last 90 days - ; - S XTMPDAYS=10 ; Keep ^XTMP record for 10 days - reset timeframe with each run - S XTMPHOUR=48 ; Each order that's verified as having generated an alert has a flag set in - ; ^XTMP that's kept for 48 hours. When flag is gone, must recheck alert status - ; - S X="T-"_MINDAYS - D ^%DT S ORZSDATE=9999999-Y - S %DT="ST",X="NOW" D ^%DT - S ORZNOW=Y - S ORZTIME=$$FMADD^XLFDT(ORZNOW,0,0,-MINTIME,0) ; Order must have existed for ORZTIME minutes - S ORZPURGE=$$FMADD^XLFDT(ORZNOW,XTMPDAYS,0,0,0) ; Purge all marked flags if not run in XTMPDAYS days - S ^XTMP(ORMARKID,0)=ORZPURGE_U_ORZNOW_U_"Unsigned Orders Reviewed by ORMTIME" - S ORZPURGE=$$FMADD^XLFDT(ORZNOW,0,XTMPHOUR,0,0) ; Purge each marked flag XTMPHOUR hours after creation - K MINTIME,MINDAYS,XTMPDAYS,XTMPHOUR,X,Y,%DT ; Kill non-namespaced vars - S ORZPAT="" F S ORZPAT=$O(^OR(100,"AS",ORZPAT)) Q:'ORZPAT D - . Q:$P(^DPT(+ORZPAT,0),U,21) ; Quit if test patient - . S ORZDATE=0 F S ORZDATE=$O(^OR(100,"AS",ORZPAT,ORZDATE)) Q:'ORZDATE I ORZDATE0 Q ; Can't have a sign date/time - . . . . . S ORZSTS=$P(ORZREC8,U,4) I ORZSTS'=2 Q ; must be in an unsigned state - . . . . . S ORZWHEN=$P(ORZREC8,U) I ORZWHEN>ORZTIME Q ; must have been unsigned for MINTIME - . . . . . S ORBDFN=+ORZPAT - . . . . . S ORNUM=ORZIEN_";"_ORZSUB - . . . . . I $$NEEDALRT($P(ORZREC8,U,3),ORBDFN,ORNUM) D ; must not have already generated an alert - . . . . . . S (ORBADUZ,ORBPMSG,ORBPDATA)="" - . . . . . . D DOALERT^ORB3 - . . . . . . D MARK(ORNUM) ; Alert sent, don't send another one - D CLEAN - Q - ; -NEEDALRT(PROVIDER,DFN,ORNUM) ; Returns true if order needs an alert - ; - I $$MARKED(ORNUM) Q 0 ; If already checked, return - ; - N RESULT,SUROGATE - S RESULT=1 - I $$HASALERT(PROVIDER,DFN) S RESULT=0 I 1 - E D - . S SUROGATE=$P($$GETSURO^XQALSURO(PROVIDER),U,1) - . I +SUROGATE,$$HASALERT(SUROGATE,DFN) S RESULT=0 - I 'RESULT D MARK(ORNUM) - Q RESULT - ; -HASALERT(USER,PATIENT) ; Returns true if alert exists for user and patient - N RESULT,ALERTID,DATE - S RESULT=0,ALERTID="OR,"_PATIENT_",12" - I $D(^XTV(8992,"AXQAN",ALERTID,USER)) D ;DBIA# 2689 - . S DATE=$O(^XTV(8992,"AXQAN",ALERTID,USER,0)) - . I $G(DATE)>0 S RESULT=1 - Q RESULT - ; -MARKED(ORNUM) ; Returns true if the order has been marked as not needing an alert - I $D(^XTMP(ORMARKID,"A",ORNUM))>0 Q 1 - Q 0 - ; -MARK(ORNUM) ; Marks an order as already having been alerted - S ^XTMP(ORMARKID,"A",ORNUM)="" - S ^XTMP(ORMARKID,"B",ORZPURGE,ORNUM)="" - Q -CLEAN ; Clean up old entries in ^XTMP - N IDX,ORNUM - S IDX=0 - F S IDX=$O(^XTMP(ORMARKID,"B",IDX)) Q:((+IDX=0)!(IDX>ORZNOW)) D - . S ORNUM=0 - . F S ORNUM=$O(^XTMP(ORMARKID,"B",IDX,ORNUM)) Q:+ORNUM=0 D - . . K ^XTMP(ORMARKID,"A",ORNUM) - . . K ^XTMP(ORMARKID,"B",IDX,ORNUM) - Q +ORMTIM02 ; JM/SLC-ISC - PERFORM MISC TIME BASED ACTIVITIES ;05/02/06 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**253**;Dec 17, 1997 + ; + Q +MISC ; Perform misc time based activities + ; + D UNSIGNED ; Generate alerts for unsigned orders that have slipped through the cracks + ; + Q + ; +UNSIGNED ; Generate alerts for unsigned orders that were not alerted by CPRS + ; This happens when CPRS crashes - through network connection drops or other causes + N ORZPAT,ORZDATE,ORZIEN,ORZSUB,ORZSDATE,%DT,X,Y,ORZTIME,ORZNOW,ORZPURGE + N ORN,ORBDFN,ORNUM,ORBADUZ,ORBPMSG,ORBPDATA,ORZREC8,ORZSIGDT,ORZSTS,ORZWHEN,ORMARKID + N MINTIME,XTMPDAYS,XTMPHOUR,MINDAYS + S ORN=12,ORMARKID="ORMTIME_UNSGNORD" + ; + S MINTIME=60 ; Order must be unsigned for 60 Minutes before generating an alert + S MINDAYS=90 ; Order must have been generated within the last 90 days + ; + S XTMPDAYS=10 ; Keep ^XTMP record for 10 days - reset timeframe with each run + S XTMPHOUR=48 ; Each order that's verified as having generated an alert has a flag set in + ; ^XTMP that's kept for 48 hours. When flag is gone, must recheck alert status + ; + S X="T-"_MINDAYS + D ^%DT S ORZSDATE=9999999-Y + S %DT="ST",X="NOW" D ^%DT + S ORZNOW=Y + S ORZTIME=$$FMADD^XLFDT(ORZNOW,0,0,-MINTIME,0) ; Order must have existed for ORZTIME minutes + S ORZPURGE=$$FMADD^XLFDT(ORZNOW,XTMPDAYS,0,0,0) ; Purge all marked flags if not run in XTMPDAYS days + S ^XTMP(ORMARKID,0)=ORZPURGE_U_ORZNOW_U_"Unsigned Orders Reviewed by ORMTIME" + S ORZPURGE=$$FMADD^XLFDT(ORZNOW,0,XTMPHOUR,0,0) ; Purge each marked flag XTMPHOUR hours after creation + K MINTIME,MINDAYS,XTMPDAYS,XTMPHOUR,X,Y,%DT ; Kill non-namespaced vars + S ORZPAT="" F S ORZPAT=$O(^OR(100,"AS",ORZPAT)) Q:'ORZPAT D + . Q:$P(^DPT(+ORZPAT,0),U,21) ; Quit if test patient + . S ORZDATE=0 F S ORZDATE=$O(^OR(100,"AS",ORZPAT,ORZDATE)) Q:'ORZDATE I ORZDATE0 Q ; Can't have a sign date/time + . . . . . S ORZSTS=$P(ORZREC8,U,4) I ORZSTS'=2 Q ; must be in an unsigned state + . . . . . S ORZWHEN=$P(ORZREC8,U) I ORZWHEN>ORZTIME Q ; must have been unsigned for MINTIME + . . . . . S ORBDFN=+ORZPAT + . . . . . S ORNUM=ORZIEN_";"_ORZSUB + . . . . . I $$NEEDALRT($P(ORZREC8,U,3),ORBDFN,ORNUM) D ; must not have already generated an alert + . . . . . . S (ORBADUZ,ORBPMSG,ORBPDATA)="" + . . . . . . D DOALERT^ORB3 + . . . . . . D MARK(ORNUM) ; Alert sent, don't send another one + D CLEAN + Q + ; +NEEDALRT(PROVIDER,DFN,ORNUM) ; Returns true if order needs an alert + ; + I $$MARKED(ORNUM) Q 0 ; If already checked, return + ; + N RESULT,SUROGATE + S RESULT=1 + I $$HASALERT(PROVIDER,DFN) S RESULT=0 I 1 + E D + . S SUROGATE=$P($$GETSURO^XQALSURO(PROVIDER),U,1) + . I +SUROGATE,$$HASALERT(SUROGATE,DFN) S RESULT=0 + I 'RESULT D MARK(ORNUM) + Q RESULT + ; +HASALERT(USER,PATIENT) ; Returns true if alert exists for user and patient + N RESULT,ALERTID,DATE + S RESULT=0,ALERTID="OR,"_PATIENT_",12" + I $D(^XTV(8992,"AXQAN",ALERTID,USER)) D ;DBIA# 2689 + . S DATE=$O(^XTV(8992,"AXQAN",ALERTID,USER,0)) + . I $G(DATE)>0 S RESULT=1 + Q RESULT + ; +MARKED(ORNUM) ; Returns true if the order has been marked as not needing an alert + I $D(^XTMP(ORMARKID,"A",ORNUM))>0 Q 1 + Q 0 + ; +MARK(ORNUM) ; Marks an order as already having been alerted + S ^XTMP(ORMARKID,"A",ORNUM)="" + S ^XTMP(ORMARKID,"B",ORZPURGE,ORNUM)="" + Q +CLEAN ; Clean up old entries in ^XTMP + N IDX,ORNUM + S IDX=0 + F S IDX=$O(^XTMP(ORMARKID,"B",IDX)) Q:((+IDX=0)!(IDX>ORZNOW)) D + . S ORNUM=0 + . F S ORNUM=$O(^XTMP(ORMARKID,"B",IDX,ORNUM)) Q:+ORNUM=0 D + . . K ^XTMP(ORMARKID,"A",ORNUM) + . . K ^XTMP(ORMARKID,"B",IDX,ORNUM) + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMTIME.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMTIME.m index f9636cf3..50621727 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMTIME.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMTIME.m @@ -1,81 +1,80 @@ -ORMTIME ; SLC/RJS - PROCESS TIME BASED EVENT ;9/29/99 09:35 [2/1/00 9:30am] - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**40,253,243**;Dec 17, 1997;Build 242 - ; -EN ; Main entry tag. - ; - N OCXPSDT,OCXZTSK,OCXERR,OCXORMTR,OCXSTDT,OCXLOCK,OCXPAR - K ^TMP("OCXORMTIME",$J) - S OCXLOCK=0 - S OCXORMTR="ORMTIME: Startup" - S OCXSTDT=$$EDATE($$IDATE("NOW")) - S ^TMP("OCXORMTIME",$J,"STATUS")="ORMTIME: Attempting to lock ^OR(100,""AE"") at "_OCXSTDT_"." - L +^OR(100,"AE"):10 - I D - .S OCXLOCK=1 - .D SCAN - .L -^OR(100,"AE") - .K ^TMP("OCXORMTIME") - .S OCXPAR=$$IDATE2("NOW") - .D PUT^XPAR("SYS","ORM ORMTIME LAST RUN",1,OCXPAR,.OCXERR) - S:'OCXLOCK ^TMP("OCXORMTIME",$J,"STATUS")="ORMTIME: Unable to lock ^OR(100,""AE"") at "_OCXSTDT_" attempt." - Q - ; -SCAN ; Call ORMTIM01 for order checking, etc. ORMTIM02 for misc time based tasks - ; - D SCAN^ORMTIM01 - D MISC^ORMTIM02 - D TASK^ORTSKLPS - Q - ; -EDATE(Y) X ^DD("DD") S:(Y["@") Y=$P(Y,"@",1)_" at "_$P(Y,"@",2) Q Y - ; -IDATE(X) N %DT,Y S %DT="F" D ^%DT Q Y - ; -IDATE2(X) N %DT,Y S %DT="TF" D ^%DT Q Y - ; -REQUEUE(ORMQT) ; Code formerly queued ORMTIME tasks in Taskman. - ; - ; (This tag kept for compatibility with outside calls.) - ; - Q - ; -STATUS ; Check status of last ORMTIME run. - ; - N ORMLAST - ; - ; Get date/time of last ORMTIME run: - S ORMLAST=$$GET^XPAR("SYS","ORM ORMTIME LAST RUN",1,"I") - S ORMLAST=$$EDATE(ORMLAST) ; Convert to external format for display. - ; - ; Present information to user: - W ! - W !," ORMTIME last ran "_ORMLAST_"." - W ! - ; - Q - ; -BULL ; Send a bulletin if ORMTIME's last run is greater than 24 hours. - ; - N DIC,ORMMSG,X,XMSUB,XMTEXT,XMY,XMZ,Y,ORMLAST - ; - ; Don't send bulletin if ORMTIME STATUS mail group does not exist: - S DIC=3.8,DIC(0)="",X="ORMTIME STATUS" - D ^DIC Q:(+Y<0) - ; - S ORMLAST=$$GET^XPAR("SYS","ORM ORMTIME LAST RUN",1,"I") - I $$FMDIFF^XLFDT($$IDATE2("NOW"),ORMLAST,2)>86400 D - .S XMY("G.ORMTIME STATUS")="" - .S XMSUB=" ORMTIME Warning" - .S ORMMSG(1,0)=" " - .S ORMMSG(2,0)=" The ORMTIME process last ran more than 24 hours ago. " - .S ORMMSG(3,0)=" " - .S ORMMSG(4,0)=" The ORMTIME background job handles activating and expiring orders," - .S ORMMSG(5,0)=" some time based notifications, as well as purging of temporary CPRS" - .S ORMMSG(6,0)=" data. It is important that it runs regularly." - .S ORMMSG(7,0)=" " - .S ORMMSG(8,0)=" Assure that the scheduled option, ORMTIME RUN, is correctly implemented." - .S ORMMSG(9,0)=" " - .S XMTEXT="ORMMSG(" - .D ^XMD - Q - ; +ORMTIME ; SLC/RJS - PROCESS TIME BASED EVENT ;9/29/99 09:35 [2/1/00 9:30am] + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**40,253**;Dec 17, 1997 + ; +EN ; Main entry tag. + ; + N OCXPSDT,OCXZTSK,OCXERR,OCXORMTR,OCXSTDT,OCXLOCK,OCXPAR + K ^TMP("OCXORMTIME",$J) + S OCXLOCK=0 + S OCXORMTR="ORMTIME: Startup" + S OCXSTDT=$$EDATE($$IDATE("NOW")) + S ^TMP("OCXORMTIME",$J,"STATUS")="ORMTIME: Attempting to lock ^OR(100,""AE"") at "_OCXSTDT_"." + L +^OR(100,"AE"):10 + I D + .S OCXLOCK=1 + .D SCAN + .L -^OR(100,"AE") + .K ^TMP("OCXORMTIME") + .S OCXPAR=$$IDATE2("NOW") + .D PUT^XPAR("SYS","ORM ORMTIME LAST RUN",1,OCXPAR,.OCXERR) + S:'OCXLOCK ^TMP("OCXORMTIME",$J,"STATUS")="ORMTIME: Unable to lock ^OR(100,""AE"") at "_OCXSTDT_" attempt." + Q + ; +SCAN ; Call ORMTIM01 for order checking, etc. ORMTIM02 for misc time based tasks + ; + D SCAN^ORMTIM01 + D MISC^ORMTIM02 + Q + ; +EDATE(Y) X ^DD("DD") S:(Y["@") Y=$P(Y,"@",1)_" at "_$P(Y,"@",2) Q Y + ; +IDATE(X) N %DT,Y S %DT="F" D ^%DT Q Y + ; +IDATE2(X) N %DT,Y S %DT="TF" D ^%DT Q Y + ; +REQUEUE(ORMQT) ; Code formerly queued ORMTIME tasks in Taskman. + ; + ; (This tag kept for compatibility with outside calls.) + ; + Q + ; +STATUS ; Check status of last ORMTIME run. + ; + N ORMLAST + ; + ; Get date/time of last ORMTIME run: + S ORMLAST=$$GET^XPAR("SYS","ORM ORMTIME LAST RUN",1,"I") + S ORMLAST=$$EDATE(ORMLAST) ; Convert to external format for display. + ; + ; Present information to user: + W ! + W !," ORMTIME last ran "_ORMLAST_"." + W ! + ; + Q + ; +BULL ; Send a bulletin if ORMTIME's last run is greater than 24 hours. + ; + N DIC,ORMMSG,X,XMSUB,XMTEXT,XMY,XMZ,Y,ORMLAST + ; + ; Don't send bulletin if ORMTIME STATUS mail group does not exist: + S DIC=3.8,DIC(0)="",X="ORMTIME STATUS" + D ^DIC Q:(+Y<0) + ; + S ORMLAST=$$GET^XPAR("SYS","ORM ORMTIME LAST RUN",1,"I") + I $$FMDIFF^XLFDT($$IDATE2("NOW"),ORMLAST,2)>86400 D + .S XMY("G.ORMTIME STATUS")="" + .S XMSUB=" ORMTIME Warning" + .S ORMMSG(1,0)=" " + .S ORMMSG(2,0)=" The ORMTIME process last ran more than 24 hours ago. " + .S ORMMSG(3,0)=" " + .S ORMMSG(4,0)=" The ORMTIME background job handles activating and expiring orders," + .S ORMMSG(5,0)=" some time based notifications, as well as purging of temporary CPRS" + .S ORMMSG(6,0)=" data. It is important that it runs regularly." + .S ORMMSG(7,0)=" " + .S ORMMSG(8,0)=" Assure that the scheduled option, ORMTIME RUN, is correctly implemented." + .S ORMMSG(9,0)=" " + .S XMTEXT="ORMMSG(" + .D ^XMD + Q + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORPRF.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORPRF.m index 53252366..7e6572bb 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORPRF.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORPRF.m @@ -1,105 +1,101 @@ -ORPRF ;SLC/JLI-Patient record flag ;6/14/06 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**173,187,190,215,243**;Dec 17, 1997;Build 242 - ; -FMT(ROOT) ; Format - Convert record flag data to displayable data - ; Sets ^TMP("ORPRF",$J,NN) with flag data for multiple flags - N IDX,IX,CNT - S (IDX,CNT)=0 - F S IDX=$O(ROOT(IDX)) Q:'IDX D - . S ^TMP("ORPRF",$J,IDX,"FLAG")=$P($G(ROOT(IDX,"FLAG")),U,2) - . S ^TMP("ORPRF",$J,IDX,"CATEGORY")=$P($G(ROOT(IDX,"CATEGORY")),U,2) - . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Flag Name: "_$P($G(ROOT(IDX,"FLAG")),U,2) - . I $D(ROOT(IDX,"NARR")) D - . . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)=" " - . . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Assignment Narrative: " - . . S IX=0 F S IX=$O(ROOT(IDX,"NARR",IX)) Q:'IX D - . . . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)=$G(ROOT(IDX,"NARR",IX,0)) - . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)=" " - . ; -- Assignment Details: - . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Flag Type: "_$P($G(ROOT(IDX,"FLAGTYPE")),U,2) - . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Flag Category: "_$P($G(ROOT(IDX,"CATEGORY")),U,2) - . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Assignment Status: "_"Active" - . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Initial Assigned Date: "_$P($G(ROOT(IDX,"ASSIGNDT")),U,2) - . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Approved by: "_$P($G(ROOT(IDX,"APPRVBY")),U,2) - . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Next Review Date: "_$P($G(ROOT(IDX,"REVIEWDT")),U,2) - . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Owner Site: "_$P($G(ROOT(IDX,"OWNER")),U,2) - . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Originating Site: "_$P($G(ROOT(IDX,"ORIGSITE")),U,2) - K ROOT - Q - ; -HASFLG(ORY,PTDFN) ;Does patient PTDFN has flags - ; DBIA 3860: $$GETACT^DGPFAPI(PTDFN,.FLGDATA) - ; Returns array ORY listing active assigned flags - ; Array ORY has form: - ; ORY(flagID) = flagID^flagname,CAT1 - ; where CAT1 is 1 if flag is cat 1, 0 if cat 2 - ; ORY = Num of items returned in array ORY = num of flags - I '$L($TEXT(GETACT^DGPFAPI)) S ORY=0 Q - N IDY,PRFARR,CAT1 - K ^TMP("ORPRF",$J) - S ORY=$$GETACT^DGPFAPI(PTDFN,"PRFARR") - Q:'ORY - D FMT(.@("PRFARR")) ; Sets ^TMP("ORPRF" - S IDY=0 F S IDY=$O(^TMP("ORPRF",$J,IDY)) Q:'IDY D - . S ORY(IDY)=IDY_U_$G(^TMP("ORPRF",$J,IDY,"FLAG")) - . S CAT1=0 - . I $G(^TMP("ORPRF",$J,IDY,"CATEGORY"))="I (NATIONAL)" S CAT1=1 - . S ORY(IDY)=ORY(IDY)_U_CAT1 - Q - ; -HASFLG1(ORY,PTDFN) ; Does patient PTDFN have **Cat I** flags - ; Returns array ORY listing active assigned Cat I flags - ; Array ORY has form: - ; ORY(flagID) = flagID^flagname - ; ORY = Num of Cat I flags - ; If pt has no Cat I flags ORY = 0 and no flags are returned. - ; Also calls FMT^ORPRF, which sets ^TMP("ORPRF" for Cat I flags - ; - I '$L($TEXT(GETACT^DGPFAPI)) S ORY=0 Q - N FLAGID,PRFARR,CAT1CNT,ACTFLGS - K ^TMP("ORPRF",$J) - S ACTFLGS=$$GETACT^DGPFAPI(PTDFN,"PRFARR") - I 'ACTFLGS S ORY=0 Q - S (FLAGID,CAT1CNT)=0 - F S FLAGID=$O(PRFARR(FLAGID)) Q:'FLAGID D - . I $P($G(PRFARR(FLAGID,"CATEGORY"))," ")="I" S CAT1CNT=CAT1CNT+1 Q - . K PRFARR(FLAGID) - I 'CAT1CNT S ORY=0 Q - D FMT(.@("PRFARR")) - S IDY=0 F S IDY=$O(^TMP("ORPRF",$J,IDY)) Q:'IDY D - . S ORY(IDY)=IDY_U_$G(^TMP("ORPRF",$J,IDY,"FLAG")) - S ORY=CAT1CNT - Q - ; -HASCAT1(HASCAT1,PTDFN) ;Does patient have Category I flags (no arrays) - ; Returns boolean HASCAT1 = 0 or 1 - ; Does NOT set arrays or TMP globals - N FLAGID,PRFARR,ACTFLGS - S (HASCAT1,FLAGID)=0 - S ACTFLGS=$$GETACT^DGPFAPI(PTDFN,"PRFARR") I 'ACTFLGS G HASCAT1X - F S FLAGID=$O(PRFARR(FLAGID)) Q:'FLAGID D Q:HASCAT1 - . I $P($G(PRFARR(FLAGID,"CATEGORY"))," ")="I" S HASCAT1=1 -HASCAT1X ; - Q - ; -TRIGRPOP(POPUP,PTDFN) ;Should the flag display pop up upon patient selection - ; for patient PTDFN? - ;As of 1/10/06, returns POPUP as: - ; 1 if pt has any active flags, either Cat I or Cat II - ; 0 otherwise - N PRFARR - S POPUP=$S($$GETACT^DGPFAPI(PTDFN,"PRFARR"):1,1:0) - Q - ; -GETFLG(ORY,PTDFN,FLAGID) ;Return detailed flag info for flag FLAGID - I '$D(^TMP("ORPRF",$J,FLAGID)) Q - N IX,CNT - S (IX,CNT)=0 - F S IX=$O(^TMP("ORPRF",$J,FLAGID,IX)) Q:'IX D - . S CNT=CNT+1,ORY(CNT)=$G(^TMP("ORPRF",$J,FLAGID,IX)) - Q - ; -CLEAR(ORY) ;Clear up the temp global - K ^TMP("ORPRF",$J) - Q - ; +ORPRF ;SLC/JLI-Patient record flag ;1/10/06 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**173,187,190,215**;Dec 17, 1997 + ; +FMT(ROOT) ; Format - Convert record flag data to displayable data + ; Sets ^TMP("ORPRF",$J,NN) with flag data for multiple flags + N IDX,IX,CNT + S (IDX,CNT)=0 + F S IDX=$O(ROOT(IDX)) Q:'IDX D + . S ^TMP("ORPRF",$J,IDX,"FLAG")=$P($G(ROOT(IDX,"FLAG")),U,2) + . S ^TMP("ORPRF",$J,IDX,"CATEGORY")=$P($G(ROOT(IDX,"CATEGORY")),U,2) + . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Flag Name: "_$P($G(ROOT(IDX,"FLAG")),U,2) + . I $D(ROOT(IDX,"NARR")) D + . . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)=" " + . . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Assignment Narrative: " + . . S IX=0 F S IX=$O(ROOT(IDX,"NARR",IX)) Q:'IX D + . . . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)=$G(ROOT(IDX,"NARR",IX,0)) + . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)=" " + . ; -- Assignment Details: + . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Flag Type: "_$P($G(ROOT(IDX,"FLAGTYPE")),U,2) + . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Flag Category: "_$P($G(ROOT(IDX,"CATEGORY")),U,2) + . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Assignment Status: "_"Active" + . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Initial Assigned Date: "_$P($G(ROOT(IDX,"ASSIGNDT")),U,2) + . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Approved by: "_$P($G(ROOT(IDX,"APPRVBY")),U,2) + . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Next Review Date: "_$P($G(ROOT(IDX,"REVIEWDT")),U,2) + . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Owner Site: "_$P($G(ROOT(IDX,"OWNER")),U,2) + . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Originating Site: "_$P($G(ROOT(IDX,"ORIGSITE")),U,2) + K ROOT + Q + ; +HASFLG(ORY,PTDFN) ;Does patient PTDFN has flags + ; DBIA 3860: $$GETACT^DGPFAPI(PTDFN,.FLGDATA) + ; Returns array ORY listing active assigned flags + ; Array ORY has form: + ; ORY(flagID) = flagID^flagname + ; ORY = Num of items returned in array ORY = num of flags + I '$L($TEXT(GETACT^DGPFAPI)) S ORY=0 Q + N IDY,PRFARR + K ^TMP("ORPRF",$J) + S ORY=$$GETACT^DGPFAPI(PTDFN,"PRFARR") + Q:'ORY + D FMT(.@("PRFARR")) ; Sets ^TMP("ORPRF" + S IDY=0 F S IDY=$O(^TMP("ORPRF",$J,IDY)) Q:'IDY D + . S ORY(IDY)=IDY_U_$G(^TMP("ORPRF",$J,IDY,"FLAG")) + Q + ; +HASFLG1(ORY,PTDFN) ; Does patient PTDFN have **Cat I** flags + ; Returns array ORY listing active assigned Cat I flags + ; Array ORY has form: + ; ORY(flagID) = flagID^flagname + ; ORY = Num of Cat I flags + ; If pt has no Cat I flags ORY = 0 and no flags are returned. + ; Also calls FMT^ORPRF, which sets ^TMP("ORPRF" for Cat I flags + ; + I '$L($TEXT(GETACT^DGPFAPI)) S ORY=0 Q + N FLAGID,PRFARR,CAT1CNT,ACTFLGS + K ^TMP("ORPRF",$J) + S ACTFLGS=$$GETACT^DGPFAPI(PTDFN,"PRFARR") + I 'ACTFLGS S ORY=0 Q + S (FLAGID,CAT1CNT)=0 + F S FLAGID=$O(PRFARR(FLAGID)) Q:'FLAGID D + . I $P($G(PRFARR(FLAGID,"CATEGORY"))," ")="I" S CAT1CNT=CAT1CNT+1 Q + . K PRFARR(FLAGID) + I 'CAT1CNT S ORY=0 Q + D FMT(.@("PRFARR")) + S IDY=0 F S IDY=$O(^TMP("ORPRF",$J,IDY)) Q:'IDY D + . S ORY(IDY)=IDY_U_$G(^TMP("ORPRF",$J,IDY,"FLAG")) + S ORY=CAT1CNT + Q + ; +HASCAT1(HASCAT1,PTDFN) ;Does patient have Category I flags (no arrays) + ; Returns boolean HASCAT1 = 0 or 1 + ; Does NOT set arrays or TMP globals + N FLAGID,PRFARR,ACTFLGS + S (HASCAT1,FLAGID)=0 + S ACTFLGS=$$GETACT^DGPFAPI(PTDFN,"PRFARR") I 'ACTFLGS G HASCAT1X + F S FLAGID=$O(PRFARR(FLAGID)) Q:'FLAGID D Q:HASCAT1 + . I $P($G(PRFARR(FLAGID,"CATEGORY"))," ")="I" S HASCAT1=1 +HASCAT1X ; + Q + ; +TRIGRPOP(POPUP,PTDFN) ;Should the flag display pop up upon patient selection + ; for patient PTDFN? + ;As of 1/10/06, returns POPUP as: + ; 1 if pt has any active flags, either Cat I or Cat II + ; 0 otherwise + N PRFARR + S POPUP=$S($$GETACT^DGPFAPI(PTDFN,"PRFARR"):1,1:0) + Q + ; +GETFLG(ORY,PTDFN,FLAGID) ;Return detailed flag info for flag FLAGID + I '$D(^TMP("ORPRF",$J,FLAGID)) Q + N IX,CNT + S (IX,CNT)=0 + F S IX=$O(^TMP("ORPRF",$J,FLAGID,IX)) Q:'IX D + . S CNT=CNT+1,ORY(CNT)=$G(^TMP("ORPRF",$J,FLAGID,IX)) + Q + ; +CLEAR(ORY) ;Clear up the temp global + K ^TMP("ORPRF",$J) + Q + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORPRPM.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORPRPM.m index 82b429db..4811c52b 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORPRPM.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORPRPM.m @@ -1,124 +1,122 @@ -ORPRPM ;DAN/SLC Performance Measure; ;4/8/04 10:20 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**107,114,119,196,190,243**;Dec 17, 1997;Build 242 - ; - ;DBIA SECTION - ;4195 - EN^PSOTPCUL - ; - ;This routine will print a report indicating the percent of - ;orders entered for a provider by a provider holding the ORES key. - ;The data for the report will be stored in ^TMP as follows: - ;^TMP($J,"SUM",Provider Name,Patient Status)=Total # of order (universe)^Denominator^Numerator^Verbal^Written^Telephone^Policy^Electronically entered^Student entered^Outpatient narcotic orders - ;Where Patient Status is I for inpatient or O for outpatient. - ; - N DIR,ORSD,ORED,ORPROV,ORTYPE,ORPT,ORREP,ORPIECE,Y,DIRUT,DUOUT,DTOUT,ZTRTN,ORDT,ORIEN,ORACT0,ORPVID,PG,REPDT,ORSTOP,ORI,ORJ,ORPAT,ORTOT,ORSTOT,X,ORPVNM,ORORD,ORPTST,ORP,ORWROTE,ORNS,ORFS,ORPFILE - D GETDATE K DIR Q:$D(DIRUT) ;quit if no dates selected ;get start and end dates - D GETPROV K DIR Q:'$D(ORPROV)!($G(ORPROV)'="ALL"&($D(ORPROV)'=11))!($D(DUOUT))!($D(DTOUT)) ;quit if user didn't select all providers or if didn't choose individual providers or if user timed out or up-arrowed out - D GETOTHER Q:$D(DIRUT) ;quit if any questions were unanswered in this section - I DUZ=1395 D DQ Q - S ZTRTN="DQ^ORPRPM" D QUE^ORUTL1(ZTRTN,"CPRS Performance Monitor") - Q - ; -GETDATE ;Prompt for start and end dates - S DIR(0)="DO^:DT:AE",DIR("A")="Enter starting date",DIR("?")="Enter date to begin searching from" D ^DIR Q:$D(DIRUT) S ORSD=Y - S DIR(0)="DOA^"_ORSD_":DT:AE",DIR("A")="Enter ending date: ",DIR("?")="Enter date to stop searching. Must be between "_$$FMTE^XLFDT(ORSD,2)_" and "_$$FMTE^XLFDT(DT,2) D ^DIR Q:$D(DIRUT) - S ORED=Y_.24,ORSD=ORSD-.1 ;Set end date to end of day, start date back to include current day - Q ;End GETDATE - ; -GETPROV ;Allow selection of all/single/multiple providers - ;return ORPROV="ALL" for all providers or ORPROV array for individual providers - S DIR(0)="Y",DIR("A")="Do you want ALL providers to appear on this report",DIR("B")="Y",DIR("?")="Enter Yes to search for all providers. Enter No to select individual providers" D ^DIR Q:$D(DIRUT) S ORPROV=$S(Y=1:"ALL",1:"") Q:ORPROV="ALL" - K DIR ;clear DIR variables before getting individual providers - F D Q:$D(DIRUT) ;quit when finished selecting - .S DIR(0)="PO^200:AEQM",DIR("S")="I $D(^VA(200,""AK.PROVIDER"",$P(^(0),U)))",DIR("A")="Select "_$S($D(ORPROV)=11:"another ",1:"")_"provider" - .S DIR("?")="Select providers to appear on report. Return when finished, ^ to stop processing" D ^DIR Q:$D(DIRUT) S ORPROV(+Y)="" - Q ;End GETPROV - ; -GETOTHER ;Get order type, patient type, and summary only report response - ;Get order type first - S DIR(0)="S^A:All orders;P:Pharmacy orders only",DIR("A")="Select order category",DIR("B")="P",DIR("?")="Enter P to see pharmacy orders only. Enter A to see all orders. Enter ^ to quit" D ^DIR Q:$D(DIRUT) S ORTYPE=Y - K DIR - ;Get patient status - S DIR(0)="S^I:Inpatient;O:Outpatient;B:Both",DIR("A")="Select patient status",DIR("B")="B",DIR("?")="Enter patient status at time of order. Enter ^ to quit" D ^DIR Q:$D(DIRUT) S ORPT=Y - K DIR - ;Ask if user desires facility subtotal, summary, detail, or both (detail and summary) reports - S DIR(0)="S^S:Summary (includes provider details);D:Detail (includes order details);B:Both (Summary & Detail);T:Summary Report Totals Only (no provider details)",DIR("A")="Select report",DIR("B")="S" - D ^DIR Q:$D(DIRUT) S ORREP=Y,ORFS=0 I Y="T" S ORREP="S",ORFS=1 - K DIR - Q ;End GETOTHER - ; -DQ ;Come here to do build and print from QUE^ORUTL either direct or tasked - U IO K ^TMP($J) ;clean out temp space - S ORDT=ORSD F S ORDT=$O(^OR(100,"AF",ORDT)) Q:'ORDT!(ORDT>ORED) S ORIEN="" F S ORIEN=$O(^OR(100,"AF",ORDT,ORIEN)) Q:'ORIEN I $O(^OR(100,"AF",ORDT,ORIEN,0))=1 I $D(^OR(100,ORIEN,8,1,0)) D CHECK - D PRINT^ORPRPM1 - K ^TMP($J) - Q - ; -CHECK ;If order matches requirements then save - S ORPFILE=$P($G(^OR(100,ORIEN,0)),"^",2) Q:ORPFILE="" ;Quit if no object of order - I $P(ORPFILE,";",2)["DPT" Q:$P($G(^DPT(+$P($G(^OR(100,ORIEN,0)),"^",2),0)),"^",21) ;Quit if test patient - Q:+$P($G(^OR(100,ORIEN,3)),"^",11)'=0 ;190 quit if order type not standard - S ORPTST=$P($G(^OR(100,ORIEN,0)),"^",12) ;patient status (in/out) - I ORPT'="B" Q:ORPTST'=ORPT ;Quit if patient status is not 'both' and status doesn't match selected status - S ORNS=$$NMSP^ORCD($P($G(^OR(100,ORIEN,0)),"^",14)) - I ORTYPE'="A"&(ORNS'="PS") Q ;if not getting all types of orders then quit if order is not from pharmacy - I ORPTST="O",ORNS="PS",$G(^OR(100,ORIEN,4))=+$G(^OR(100,ORIEN,4)),$L($T(EN^PSOTPCUL)) Q:$$EN^PSOTPCUL($G(^OR(100,ORIEN,4))) ;196 Don't count if outpatient pharm order is a transitional pharmacy benefit order - S ORACT0=$G(^OR(100,ORIEN,8,1,0)),ORORD=$P(ORACT0,"^",12) ;ORORD holds nature of order ien - S ORPVID=$P(ORACT0,"^",3) I ORPROV'="ALL" Q:'$D(ORPROV(ORPVID)) ;quit if ordering provider doesn't match user selected provider - S ORPVNM=$P($G(^VA(200,ORPVID,0)),"^") ;get provider name - Q:'$D(^XUSEC("ORES",ORPVID)) ;quit if ordering provider doesn't have ORES key DBIA # 10076 allows direct read of XUSEC - Q:"^1^2^3^5^8^"'[("^"_ORORD_"^") ;quit if NATURE OF ORDER is not verbal, written, telephoned, policy, or electronically entered - D COUNT ;Count order - Q - ; -COUNT ;This section determines how the order should be counted - N OREB,ORPIECE - D ADD(1) ;Add one to universe (total # of orders) - S OREB=$P(ORACT0,"^",13) ;Entered by - S ^TMP($J,"DET",ORPVNM,ORIEN)=$D(^XUSEC("ORES",OREB))&(OREB=ORPVID) ;Mark "HAS ORES" column for detailed listing if entered by = provider and has ORES key - I OREB=ORPVID D ADD(2),ADD(3) Q ;if order entered by provider then add one to denominator and numerator - I ORNS="PS" I $$OIDEA=1 D ADD(10) Q ;If order requires wet signature add one to narcotic group - I $$STUDENT D ADD(9) Q ;If order entered by student add one to student group - S ORPIECE=$S(ORORD=1:4,ORORD=2:5,ORORD=3:6,ORORD=8:7,1:8) D ADD(ORPIECE) ;add to exceptions group for orders not entered by provider - I ORORD'=5 D ADD(2) ;Add to denominator if not policy order - Q - ; -ADD(PIECE) ;Add one to storage - S $P(^TMP($J,"SUM",ORPVNM,ORPTST),"^",PIECE)=$P($G(^TMP($J,"SUM",ORPVNM,ORPTST)),"^",PIECE)+1 Q - ; -OIDEA() ;Check to see if pharmacy order requires wet signature - ;dbia 3373 allows call to pharmacy API or dbia 221 allows direct read of ^PSDRUG if routine doesn't exist yet - N OI,PSOI,SIGREQ,PSSXOLP,PSSXOLPD,PSSXOLPX,PSSXNODD,PSSPKLX - Q:ORPTST'="O" 0 ;quit if inpatient - S OI=$$VALUE^ORX8(ORIEN,"ORDERABLE") ;get orderable item - S PSOI=+$P($G(^ORD(101.43,+OI,0)),U,2) I PSOI'>0 Q 0 ;quit if no pharmacy orderable item - I $L($T(OIDEA^PSSUTLA1)) S SIGREQ=$$OIDEA^PSSUTLA1(PSOI,"O") Q:SIGREQ=1 1 Q 0 ;If SIGREQ = 1 then wet signature required - S (PSSXOLPD,PSSXNODD)=0 - S PSSPKLX=0 - K ^TMP($J,"ORPRPM ASP") - D ASP^PSS50(PSOI,,,"ORPRPM ASP") - F PSSXOLP=0:0 S PSSXOLP=$O(^TMP($J,"ORPRPM ASP","")) Q:'PSSXOLP!(PSSXOLPD=1) D - .K ^TMP($J,"ORPRPM DATA") D DATA^PSS50(PSSXOLP,,(DT-1),,,"ORPRPM DATA") I +^TMP($J,"ORPRPM DATA",0)<0 Q - .I 'PSSPKLX,$G(^TMP($J,"ORPRPM DATA",63))'["O" K ^TMP($J,"ORPRPM DATA") Q - .I PSSPKLX I $G(^TMP($J,"ORPRPM DATA",63))'["U",$G(^TMP($J,"ORPRPM DATA",63))'["I" Q - .S PSSXNODD=1 - .S PSSXOLPX=$G(^TMP($J,"ORPRPM DATA",3)) - .I PSSXOLPX[1!(PSSXOLPX[2)!((PSSXOLPX[3)&(PSSXOLPX["A")) S PSSXOLPD=1 Q - .I PSSXOLPX[3!(PSSXOLPX[4)!(PSSXOLPX[5) S PSSXOLPD=2 - I PSSXOLPD=0,'PSSXNODD S PSSXOLPD="" - K ^TMP($J,"ORPRPM ASP") - K ^TMP($J,"ORPRPM DATA") - Q PSSXOLPD - ; -STUDENT() ;Check to see if entered by is a student - ;Check USER CLASS for membership in "STUDENT" CLASS - DBIA 2324 - ;Then check PROVIDER CLASS in NEW PERSON file for "STUDENT" - DBIA 10060 - N ORCLASS,ORSUB,EXPIRE,ORUSR - D WHATIS^USRLM(OREB,"ORCLASS") ;API to get user class membership - S ORSUB=0,ORUSR=0 F S ORSUB=$O(ORCLASS(ORSUB)) Q:ORSUB=""!ORUSR D - .I $$UP^XLFSTR(ORSUB)'["STUDENT" Q ;User not a member of student class - .I ORDT'<+$P(ORCLASS(ORSUB),"^",4) S EXPIRE=$S(+$P(ORCLASS(ORSUB),"^",5):$P(ORCLASS(ORSUB),"^",5),1:9999999) I ORDT'>EXPIRE S ORUSR=1 ;member of student class and within date range for class - I ORUSR Q 1 ;User identified as a student - K ORCLASS - S DIC=200,DR=53.5,DA=OREB,DIQ="ORCLASS",DIQ(0)="E" D EN^DIQ1 - I $G(ORCLASS(200,OREB,53.5,"E"))["STUDENT" Q 1 ;Provider class set to student - Q 0 ;User not a student +ORPRPM ;DAN/SLC Performance Measure; ;10/7/04 09:08 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**107,114,119,196,190,225**;Dec 17, 1997 + ; + ;DBIA SECTION + ;4195 - EN^PSOTPCUL + ;3744 - $$TESTPAT^VADPT + ;10060- Reference to file 200 + ; + ;This routine will print a report indicating the percent of + ;orders entered for a provider by a provider holding the ORES key. + ;The data for the report will be stored in ^TMP as follows: + ;^TMP($J,"SUM",Provider Name,Patient Status)=Total # of order (universe)^Denominator^Numerator^Verbal^Written^Telephone^Policy^Electronically entered^Student entered^Outpatient narcotic orders + ;Where Patient Status is I for inpatient or O for outpatient. + ; + N DIR,ORSD,ORED,ORPROV,ORTYPE,ORPT,ORREP,ORPIECE,Y,DIRUT,DUOUT,DTOUT,ZTRTN,ORDT,ORIEN,ORACT0,ORPVID,PG,REPDT,ORSTOP,ORI,ORJ,ORPAT,ORTOT,ORSTOT,X,ORPVNM,ORORD,ORPTST,ORP,ORWROTE,ORNS,ORFS,ORPFILE + D GETDATE K DIR Q:$D(DIRUT) ;quit if no dates selected ;get start and end dates + D GETPROV K DIR Q:'$D(ORPROV)!($G(ORPROV)'="ALL"&($D(ORPROV)'=11))!($D(DUOUT))!($D(DTOUT)) ;quit if user didn't select all providers or if didn't choose individual providers or if user timed out or up-arrowed out + D GETOTHER Q:$D(DIRUT) ;quit if any questions were unanswered in this section + S ZTRTN="DQ^ORPRPM" D QUE^ORUTL1(ZTRTN,"CPRS Performance Monitor") + Q + ; +GETDATE ;Prompt for start and end dates + S DIR(0)="DO^:DT:AE",DIR("A")="Enter starting date",DIR("?")="Enter date to begin searching from" D ^DIR Q:$D(DIRUT) S ORSD=Y + S DIR(0)="DOA^"_ORSD_":DT:AE",DIR("A")="Enter ending date: ",DIR("?")="Enter date to stop searching. Must be between "_$$FMTE^XLFDT(ORSD,2)_" and "_$$FMTE^XLFDT(DT,2) D ^DIR Q:$D(DIRUT) + S ORED=Y_.24,ORSD=ORSD-.1 ;Set end date to end of day, start date back to include current day + Q ;End GETDATE + ; +GETPROV ;Allow selection of all/single/multiple providers + ;return ORPROV="ALL" for all providers or ORPROV array for individual providers + S DIR(0)="Y",DIR("A")="Do you want ALL providers to appear on this report",DIR("B")="Y",DIR("?")="Enter Yes to search for all providers. Enter No to select individual providers" D ^DIR Q:$D(DIRUT) S ORPROV=$S(Y=1:"ALL",1:"") Q:ORPROV="ALL" + K DIR ;clear DIR variables before getting individual providers + F D Q:$D(DIRUT) ;quit when finished selecting + .S DIR(0)="PO^200:AEQM",DIR("S")="I $D(^VA(200,""AK.PROVIDER"",$P(^(0),U)))",DIR("A")="Select "_$S($D(ORPROV)=11:"another ",1:"")_"provider" + .S DIR("?")="Select providers to appear on report. Return when finished, ^ to stop processing" D ^DIR Q:$D(DIRUT) S ORPROV(+Y)="" + Q ;End GETPROV + ; +GETOTHER ;Get order type, patient type, and summary only report response + ;Get order type first + S DIR(0)="S^A:All orders;P:Pharmacy orders only",DIR("A")="Select order category",DIR("B")="P",DIR("?")="Enter P to see pharmacy orders only. Enter A to see all orders. Enter ^ to quit" D ^DIR Q:$D(DIRUT) S ORTYPE=Y + K DIR + ;Get patient status + S DIR(0)="S^I:Inpatient;O:Outpatient;B:Both",DIR("A")="Select patient status",DIR("B")="B",DIR("?")="Enter patient status at time of order. Enter ^ to quit" D ^DIR Q:$D(DIRUT) S ORPT=Y + K DIR + ;Ask if user desires facility subtotal, summary, detail, or both (detail and summary) reports + S DIR(0)="S^S:Summary (includes provider details);D:Detail (includes order details);B:Both (Summary & Detail);T:Summary Report Totals Only (no provider details)",DIR("A")="Select report",DIR("B")="S" + D ^DIR Q:$D(DIRUT) S ORREP=Y,ORFS=0 I Y="T" S ORREP="S",ORFS=1 + K DIR + Q ;End GETOTHER + ; +DQ ;Come here to do build and print from QUE^ORUTL either direct or tasked + U IO K ^TMP($J) ;clean out temp space + S ORDT=ORSD F S ORDT=$O(^OR(100,"AF",ORDT)) Q:'ORDT!(ORDT>ORED) S ORIEN="" F S ORIEN=$O(^OR(100,"AF",ORDT,ORIEN)) Q:'ORIEN I $O(^OR(100,"AF",ORDT,ORIEN,0))=1 I $D(^OR(100,ORIEN,8,1,0)) D CHECK + D PRINT^ORPRPM1 + K ^TMP($J) + Q + ; +CHECK ;If order matches requirements then save + S ORPFILE=$P($G(^OR(100,ORIEN,0)),"^",2) Q:ORPFILE="" ;Quit if no object of order + I $P(ORPFILE,";",2)["DPT" Q:$$TESTPAT^VADPT(+$P($G(^OR(100,ORIEN,0)),"^",2)) ;225 Quit if test patient + Q:+$P($G(^OR(100,ORIEN,3)),"^",11)'=0 ;190 quit if order type not standard + Q:$P(^ORD(100.98,$P(^OR(100,ORIEN,0),U,11),0),U)="NON-VA MEDICATIONS" ;225 Quit if Non-VA med entry + S ORPTST=$P($G(^OR(100,ORIEN,0)),"^",12) ;patient status (in/out) + I ORPT'="B" Q:ORPTST'=ORPT ;Quit if patient status is not 'both' and status doesn't match selected status + S ORNS=$$NMSP^ORCD($P($G(^OR(100,ORIEN,0)),"^",14)) + I ORTYPE'="A"&(ORNS'="PS") Q ;if not getting all types of orders then quit if order is not from pharmacy + I ORPTST="O",ORNS="PS",$G(^OR(100,ORIEN,4))=+$G(^OR(100,ORIEN,4)),$L($T(EN^PSOTPCUL)) Q:$$EN^PSOTPCUL($G(^OR(100,ORIEN,4))) ;196 Don't count if outpatient pharm order is a transitional pharmacy benefit order + S ORACT0=$G(^OR(100,ORIEN,8,1,0)),ORORD=$P(ORACT0,"^",12) ;ORORD holds nature of order ien + S ORPVID=$P(ORACT0,"^",3) I ORPROV'="ALL" Q:'$D(ORPROV(ORPVID)) ;quit if ordering provider doesn't match user selected provider + S ORPVNM=$$GET1^DIQ(200,ORPVID_",",.01) ;225 get provider name + Q:'$D(^XUSEC("ORES",ORPVID)) ;quit if ordering provider doesn't have ORES key DBIA # 10076 allows direct read of XUSEC + Q:"^1^2^3^5^8^"'[("^"_ORORD_"^") ;quit if NATURE OF ORDER is not verbal, written, telephoned, policy, or electronically entered + D COUNT ;Count order + Q + ; +COUNT ;This section determines how the order should be counted + N OREB,ORPIECE + D ADD(1) ;Add one to universe (total # of orders) + S OREB=$P(ORACT0,"^",13) ;Entered by + S ^TMP($J,"DET",ORPVNM,ORIEN)=$D(^XUSEC("ORES",OREB))&(OREB=ORPVID) ;Mark "HAS ORES" column for detailed listing if entered by = provider and has ORES key + I OREB=ORPVID D ADD(2),ADD(3) Q ;if order entered by provider then add one to denominator and numerator + I ORNS="PS" I $$OIDEA=1 D ADD(10) Q ;If order requires wet signature add one to narcotic group + I $$STUDENT D ADD(9) Q ;If order entered by student add one to student group + S ORPIECE=$S(ORORD=1:4,ORORD=2:5,ORORD=3:6,ORORD=8:7,1:8) D ADD(ORPIECE) ;add to exceptions group for orders not entered by provider + I ORORD'=5 D ADD(2) ;Add to denominator if not policy order + Q + ; +ADD(PIECE) ;Add one to storage + S $P(^TMP($J,"SUM",ORPVNM,ORPTST),"^",PIECE)=$P($G(^TMP($J,"SUM",ORPVNM,ORPTST)),"^",PIECE)+1 Q + ; +OIDEA() ;Check to see if pharmacy order requires wet signature + ;dbia 3373 allows call to pharmacy API or dbia 221 allows direct read of ^PSDRUG if routine doesn't exist yet + N OI,PSOI,SIGREQ,PSSXOLP,PSSXOLPD,PSSXOLPX,PSSXNODD,PSSPKLX + Q:ORPTST'="O" 0 ;quit if inpatient + S OI=$$VALUE^ORX8(ORIEN,"ORDERABLE") ;get orderable item + S PSOI=+$P($G(^ORD(101.43,+OI,0)),U,2) I PSOI'>0 Q 0 ;quit if no pharmacy orderable item + I $L($T(OIDEA^PSSUTLA1)) S SIGREQ=$$OIDEA^PSSUTLA1(PSOI,"O") Q:SIGREQ=1 1 Q 0 ;If SIGREQ = 1 then wet signature required + S (PSSXOLPD,PSSXNODD)=0 + S PSSPKLX=0 + F PSSXOLP=0:0 S PSSXOLP=$O(^PSDRUG("ASP",PSOI,PSSXOLP)) Q:'PSSXOLP!(PSSXOLPD=1) D + .I $P($G(^PSDRUG(PSSXOLP,"I")),"^"),$P($G(^("I")),"^")
EXPIRE S ORUSR=1 ;member of student class and within date range for class + I ORUSR Q 1 ;User identified as a student + K ORCLASS + S DIC=200,DR=53.5,DA=OREB,DIQ="ORCLASS",DIQ(0)="E" D EN^DIQ1 + I $G(ORCLASS(200,OREB,53.5,"E"))["STUDENT" Q 1 ;Provider class set to student + Q 0 ;User not a student diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORPRS07.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORPRS07.m index a7680ed4..9963622a 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORPRS07.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORPRS07.m @@ -1,62 +1,62 @@ -ORPRS07 ; slc/dcm - Managing multiple reportz ;6/10/97 15:43 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**281**;Dec 17, 1997;Build 14 -EN ;Entry point - N ORVP - D MAIN("") - Q -MAIN(ORVP) ; Controls branching - N DFN,DIC,GMTYP,I,ORANSI,ORDG,OREND,ORH,ORH2,ORPRES,ORSCPAT,ORSDG - N ORSHORT,ORSRI,ORSRPT,ORSSTOP,ORSSTRT,ORTIT,ORWHL,VAROOT,XQORSPEW,X,Y - N ORAGE,ORATTEND,ORDOB,ORL,ORNP,ORPD,ORPNM,ORPV,ORSEX,ORSSN,ORTS,ORWARD - N ORSDG,ORURMBD,ORX,ORCONT,OROPREF - I '+$G(ORVP) D P^ORPRS01 Q:$D(ORSCPAT)'>9 - S ORANSI=0,XQORFLG("SH")=1 - S (ORANSI,OREND,X)=0 - I +$G(ORSCPAT)=1,+$G(ORSCPAT(1)) S ORVP=+$G(ORSCPAT(1))_";DPT(",Y=+ORVP D HOMO^ORUDPA - S DIC=101 S X="ORS REPORT MENU" D EN^XQOR - K VA200,VAERR,VAIN,VADM - Q -EXIT ; Queue output - N DUOUT,ORSRI,ORSRPT,ZTDESC,ZTRTN,ZTSAVE S OREND=+$G(OREND) - S ORSRI=0 F S ORSRI=$O(Y(ORSRI)) Q:ORSRI'>0 S ORSRPT=ORSRI,ORSRPT(ORSRI)=Y(ORSRI) - I $S($D(XQORPOP):1,$G(OREND)=1:1,$D(DUOUT):1,$D(DIROUT):1,'$D(ORSRPT):1,'$D(ORSCPAT)&'+$G(ORVP):1,1:0) Q - S (ZTSAVE("OR*"),ZTSAVE("GM*"),ZTSAVE("LR*"))="",IO("Q")=1 - S ZTRTN="OUTPUT^ORPRS07",ZTDESC="Results Reporting" W ! D DEVICE - Q -OUTPUT ; Loops through ORSRPT( and queues each report - N DIROUT,DIRUT,ORH,ORH2,ORMETHOD,ORSEND,ORSHORT,ORSI,ORSJ,ORSRI,ORTIT,ORWHL,X - N XQORNOD,XQORSPEW,XY,ORSLTR,ORSPNM,ORDG,ORION S ORION=$G(ION) - I +$G(ORVP) D REPORT(ORVP) K OROLOC,ORSSTOP,ORSSTRT,VAROOT,VA,X1 Q - S ORSI=0 F S ORSI=$O(ORSCPAT(ORSI)) Q:ORSI'>0!($G(DIROUT))!($$S^%ZTLOAD) S:'$O(ORSCPAT(ORSI)) ORSEND=1 D - . S ORVP=+ORSCPAT(ORSI)_";DPT(",ORSPNM=$P(ORSCPAT(ORSI),U,2) - . D REPORT(ORVP) - K ORNO,ORSPG - Q -REPORT(ORVP) ; Loops through ORSRPT( and prints all reports for ea patient - N ORSJ,ORSSTFLG,XQORNOD - U IO - S ORSJ=0 F S ORSJ=$O(ORSRPT(ORSJ)) Q:ORSJ'>0!+$G(DIROUT)!$G(OREND) D - . S XQORNOD=$P(ORSRPT(ORSJ),U,2)_";ORD(101,",ORMETHOD=$G(^ORD(101,+XQORNOD,101.05,20,1)) - . I $D(ORSSTRT)>9,+XQORNOD S ORSSTRT=+$G(ORSSTRT(+XQORNOD)),ORH=$P($G(ORSSTRT(+XQORNOD)),U,2) - . I $D(ORSSTOP)>9,+XQORNOD S ORSSTOP=+$G(ORSSTOP(+XQORNOD)),ORH2=$P($G(ORSSTOP(+XQORNOD)),U,2) - . I $D(ORSDG(+XQORNOD)) S ORDG=$G(ORSDG(+XQORNOD)) - . I $L(ORMETHOD) X ORMETHOD I $G(ION)'=ORION S IOP=ORION D ^%ZIS - . I +$G(ORSSTFLG) D STOP^ORPRS01 S ORSSTFLG=0 - Q -DEVICE ; Device Handling/Output control - N IO,IOP,%ZIS - S %ZIS="Q",%ZIS("B")="HOME" D ^%ZIS Q:POP - I +$G(ORSRPT)>1,(IO'=IO(0)),'$D(IO("Q")) W !,"Printing of multiple reports requires queueing.",! - D @$S(+$G(ORSRPT)>1&(IO'=IO(0)):"QUE",$D(IO("Q")):"QUE",1:"NOQUE") - Q -QUE ; Set ZT parameters and tasks ZTRTN - N ZTIO K IO("Q") - S ZTIO=ION - D ^%ZTLOAD W !,$S($D(ZTSK):"Request Queued!",1:"Request Cancelled!") - K ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE D ^%ZISC - Q -NOQUE ; Calls ZTRTN in interactive mode - I IO'=IO(0) U IO - D @ZTRTN - D ^%ZISC - Q +ORPRS07 ; slc/dcm - Managing multiple reportz ;6/10/97 15:43 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997 +EN ;Entry point + N ORVP + D MAIN("") + Q +MAIN(ORVP) ; Controls branching + N DFN,DIC,GMTYP,I,ORANSI,ORDG,OREND,ORH,ORH2,ORPRES,ORSCPAT,ORSDG + N ORSHORT,ORSRI,ORSRPT,ORSSTOP,ORSSTRT,ORTIT,ORWHL,VAROOT,XQORSPEW,X,Y + N ORAGE,ORATTEND,ORDOB,ORL,ORNP,ORPD,ORPNM,ORPV,ORSEX,ORSSN,ORTS,ORWARD + N ORSDG,ORURMBD,ORX,ORCONT,OROPREF + I '+$G(ORVP) D P^ORPRS01 Q:$D(ORSCPAT)'>9 + S ORANSI=0,XQORFLG("SH")=1 + S (ORANSI,OREND,X)=0 + I +$G(ORSCPAT)=1,+$G(ORSCPAT(1)) S ORVP=+$G(ORSCPAT(1))_";DPT(",Y=+ORVP D HOMO^ORUDPA + S DIC=101 S X="ORS REPORT MENU" D EN^XQOR + K VA200,VAERR,VAIN,VADM + Q +EXIT ; Queue output + N DUOUT,ORSRI,ORSRPT,ZTDESC,ZTRTN,ZTSAVE S OREND=+$G(OREND) + S ORSRI=0 F S ORSRI=$O(Y(ORSRI)) Q:ORSRI'>0 S ORSRPT=ORSRI,ORSRPT(ORSRI)=Y(ORSRI) + I $S($D(XQORPOP):1,$G(OREND)=1:1,$D(DUOUT):1,$D(DIROUT):1,'$D(ORSRPT):1,'$D(ORSCPAT)&'+$G(ORVP):1,1:0) Q + S (ZTSAVE("OR*"),ZTSAVE("GM*"),ZTSAVE("LR*"))="",IO("Q")=1 + S ZTRTN="OUTPUT^ORPRS07",ZTDESC="Results Reporting" W ! D DEVICE + Q +OUTPUT ; Loops through ORSRPT( and queues each report + N DIROUT,DIRUT,ORH,ORH2,ORMETHOD,ORSEND,ORSHORT,ORSI,ORSJ,ORSRI,ORTIT,ORWHL,X + N XQORNOD,XQORSPEW,XY,ORSLTR,ORSPNM,ORDG,ORION S ORION=$G(ION) + I +$G(ORVP) D REPORT(ORVP) K OROLOC,ORSSTOP,ORSSTRT,VAROOT,VA,X1 Q + S ORSI=0 F S ORSI=$O(ORSCPAT(ORSI)) Q:ORSI'>0!($G(DIROUT))!($$S^%ZTLOAD) S:'$O(ORSCPAT(ORSI)) ORSEND=1 D + . S ORVP=+ORSCPAT(ORSI)_";DPT(",ORSPNM=$P(ORSCPAT(ORSI),U,2) + . D REPORT(ORVP) + K ORNO,ORSPG + Q +REPORT(ORVP) ; Loops through ORSRPT( and prints all reports for ea patient + N ORSJ,ORSSTFLG,XQORNOD + U IO + S ORSJ=0 F S ORSJ=$O(ORSRPT(ORSJ)) Q:ORSJ'>0!+$G(DIROUT)!$G(OREND) D + . S XQORNOD=$P(ORSRPT(ORSJ),U,2),ORMETHOD=$G(^ORD(101,+XQORNOD,101.05,20,1)) + . I $D(ORSSTRT)>9,+XQORNOD S ORSSTRT=+$G(ORSSTRT(XQORNOD)),ORH=$P($G(ORSSTRT(XQORNOD)),U,2) + . I $D(ORSSTOP)>9,+XQORNOD S ORSSTOP=+$G(ORSSTOP(XQORNOD)),ORH2=$P($G(ORSSTOP(XQORNOD)),U,2) + . I $D(ORSDG(+XQORNOD)) S ORDG=$G(ORSDG(+XQORNOD)) + . I $L(ORMETHOD) X ORMETHOD I $G(ION)'=ORION S IOP=ORION D ^%ZIS + . I +$G(ORSSTFLG) D STOP^ORPRS01 S ORSSTFLG=0 + Q +DEVICE ; Device Handling/Output control + N IO,IOP,%ZIS + S %ZIS="Q",%ZIS("B")="HOME" D ^%ZIS Q:POP + I +$G(ORSRPT)>1,(IO'=IO(0)),'$D(IO("Q")) W !,"Printing of multiple reports requires queueing.",! + D @$S(+$G(ORSRPT)>1&(IO'=IO(0)):"QUE",$D(IO("Q")):"QUE",1:"NOQUE") + Q +QUE ; Set ZT parameters and tasks ZTRTN + N ZTIO K IO("Q") + S ZTIO=ION + D ^%ZTLOAD W !,$S($D(ZTSK):"Request Queued!",1:"Request Cancelled!") + K ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE D ^%ZISC + Q +NOQUE ; Calls ZTRTN in interactive mode + I IO'=IO(0) U IO + D @ZTRTN + D ^%ZISC + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQ11.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQ11.m index fe6cb7bc..5af7fa9e 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQ11.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQ11.m @@ -1,204 +1,202 @@ -ORQ11 ;slc/dcm-Get patient orders in context ;3/31/04 09:57 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,27,48,72,78,99,94,148,141,177,186,190,195,215,243**;Dec 17, 1997;Build 242 -LOOP ; -- main loop through "ACT" x-ref - I $G(XREF)="AW" D AW Q - I $G(FLG)=27 D EXPD^ORQ12 Q - K ^TMP("ORGOTIT",$J) -AWIN ;Jump in here to add active orders to AW context - N TM,TO,IFN,X0,X3,X7,X8,USTS,NOW,ACTOR,X ;195 - S NOW=+$E($$NOW^XLFDT,1,12),TM=SDATE - F S TM=$O(^OR(100,"ACT",PAT,TM)) Q:'TM!(TM>EDATE) S TO=0 F S TO=$O(^OR(100,"ACT",PAT,TM,TO)) Q:'TO I $D(ORGRP(TO)) D - . S IFN=0 F S IFN=$O(^OR(100,"ACT",PAT,TM,TO,IFN)) Q:'IFN I ('$D(^TMP("ORGOTIT",$J,IFN))!MULT),$D(^OR(100,IFN,0)),$D(^(3)) S X0=^(0),X3=^(3) D - .. S ACTOR=0 F S ACTOR=$O(^OR(100,"ACT",PAT,TM,TO,IFN,ACTOR)) Q:ACTOR<1 I '$D(^TMP("ORGOTIT",$J,IFN,ACTOR)),$D(^OR(100,IFN,8,ACTOR,0)),$P(^(0),U,15)'=13!(FLG=1) S X8=^(0),X7=$G(^(7)) D LP1 - S ^TMP("ORR",$J,ORLIST,"TOT")=ORLST - Q -AW ; -- loop through "AW" x-ref - K ^TMP("ORGOTIT",$J),^TMP("ORSORT",$J) - N TM,TO,IFN,X0,X3,X7,X8,USTS,NOW,ACTOR,X ;195 - S NOW=+$E($$NOW^XLFDT,1,12),TO=0,SDATE=9999999-SDATE,EDATE=9999999-EDATE - F S TO=$O(^OR(100,"AW",PAT,TO)) Q:'TO I $D(ORGRP(TO)) S TM=EDATE F S TM=$O(^OR(100,"AW",PAT,TO,TM)) Q:'TM!(TM>SDATE)!(+TMEDATE) S IFN=0 F S IFN=$O(^OR(100,"AC",PAT,TM,IFN)) Q:IFN<1 I $D(^OR(100,IFN,0)),$D(^(3)) S X0=^(0),X3=^(3) D - . Q:'$D(ORGRP($P(X0,U,11))) S ACTOR=0 - . F S ACTOR=$O(^OR(100,"AC",PAT,TM,IFN,ACTOR)) Q:ACTOR<1 I $D(^OR(100,IFN,8,ACTOR,0)) S X8=^(0) D - .. I "^10^12^"[(U_$P(X8,U,15)_U) K ^OR(100,"AC",PAT,TM,IFN,ACTOR) Q - .. I $P(X8,U,15)=13,$P(X8,U)0,$P($G(^OR(100,IFN,8,ACTOR,0)),U,2)="DC" S OIEN=IFN,OACT=ACTOR - .. ;I OIEN=IFN,OACT>ACTOR K ^OR(100,"AC",PAT,TM,IFN,ACTOR) Q - .. D LP1 - S ^TMP("ORR",$J,ORLIST,"TOT")=ORLST - Q -CUR1 ; 2 -- secondary pass for Active/Current - N STOP S STOP=$P(X0,U,9) - I STS=10 K ^OR(100,"AC",PAT,TM,IFN) Q ;no delayed orders - I $P(X8,U,4)=2,$P(X8,U,15)=11 G CURX ;incl all unsig/unrel actions - I '$D(YD),"^1^2^7^12^13^14^"[(U_STS_U) K ^OR(100,"AC",PAT,TM,IFN) Q - I $D(YD),"^1^2^7^12^13^14^"[(U_STS_U),STOP4:1,1:0) - . S DIC="^HOLIDAY(",X=$P(ORDT,".") - . D ^DIC S ORHOL=$S(+$G(Y)>0:1,1:0) - S %DT="",X="T+"_ORNG D ^%DT - S TMW=Y_".9999",NOW=+$E($$NOW^XLFDT,1,12) - D CUR ;D LOOP - Q -EXG1 ; 5 -- secondary pass for Expiring - N STOP S STOP=$P(X0,U,9) - I STS'=1,STS'=2,STS'=7,STS'>9,STOP>NOW,STOP'>TMW D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) - Q - ; -ACT ; 6 -- Recent Activity (Order Summary) - ;N ORLSIGN S ORLSIGN=$$GET^XPAR("ALL","OR ORDER REVIEW DT","`"_+PAT,"Q") - N TM,IFN,X0,X3,ACTOR,X8 - S TM=SDATE F S TM=$O(^OR(100,"AR",PAT,TM)) Q:TM<1!(TM>EDATE) D - . S IFN=0 F S IFN=$O(^OR(100,"AR",PAT,TM,IFN)) Q:IFN<1 S X0=$G(^OR(100,IFN,0)),X3=$G(^(3)) I $D(ORGRP(+$P(X0,U,11))) D - .. S ACTOR=0 F S ACTOR=$O(^OR(100,"AR",PAT,TM,IFN,ACTOR)) Q:ACTOR<1 I $D(^OR(100,IFN,8,ACTOR,0)),$P(^(0),U,15)'=13 S X8=^(0) D LP1 - S ^TMP("ORR",$J,ORLIST,"TOT")=ORLST - Q - ; -PEN1 ; 7 -- secondary pass for Pending - I STS=5 D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) - Q - ; -UVR1 ; 8 -- secondary pass for Unverified - ; Include if: unverified, released, inpt, not repl/canc/lapsed - I '$P(X8,U,9),'$P(X8,U,11),$P(X8,U,15)="",$$INPT,"^12^13^14^"'[(U_STS_U) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) - Q - ; -UVN1 ; 9 -- secondary pass for Unverified/Nurse - ; Include if: unverified, released, inpt, not repl/canc/lapsed - I '$P(X8,U,9),$P(X8,U,15)="",$$INPT,"^12^13^14^"'[(U_STS_U) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) - Q - ; -UVC1 ; 10 -- secondary pass for Unverified/Clerk - ; Include if: unverified, released, inpt, not repl/canc/lapsed - I '$P(X8,U,11),$P(X8,U,15)="",$$INPT,"^12^13^14^"'[(U_STS_U) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) - Q - ; -INPT() ; -- Returns 1 or 0, if inpt order using X0=^OR(100,IFN,0) - I ($P(X0,U,12)="I")!($$TYPE^OREVNTX($P(X0,U,17))="D") Q 1 - ;I $P($G(^SC(+$P(X0,U,10),0)),U,3)="W" Q 1 - Q 0 - ; -SIG ; 11 -- Unsigned - N TM,IFN,X0,X3,ACTOR S TM=SDATE - F S TM=$O(^OR(100,"AS",PAT,TM)) Q:TM<1!(TM>EDATE) S IFN=0 F S IFN=$O(^OR(100,"AS",PAT,TM,IFN)) Q:IFN<1 D - . S X0=$G(^OR(100,IFN,0)),X3=$G(^(3)) - . I X0="" K ^OR(100,"AS",PAT,TM,IFN) Q ;deleted - . Q:'$D(ORGRP(+$P(X0,U,11))) ;not a selected DispGrp - . S ACTOR=0 F S ACTOR=$O(^OR(100,"AS",PAT,TM,IFN,ACTOR)) Q:ACTOR<1 D - .. I $P($G(^OR(100,IFN,8,ACTOR,0)),U,4)'=2 K ^OR(100,"AS",PAT,TM,IFN,ACTOR) Q ;signed or deleted - .. D LP1 - S ^TMP("ORR",$J,ORLIST,"TOT")=ORLST - Q - ; -FLG1 ; 12 -- secondary pass for Flagged - I +$G(^OR(100,IFN,8,ACTOR,3)) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) - Q - ; -VP1 ; 13 -- secondary pass for Verbal/Phone - N ORNATR S ORNATR=$P(X8,U,12) - I ORNATR,"PV"[$P($G(^ORD(100.02,+ORNATR,0)),U,2) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) ;STS'=12 - Q - ; -VPU1 ; 14 -- secondary pass for Verbal/Phone Unsigned - N ORNATR S ORNATR=$P(X8,U,12) - I ORNATR,"PV"[$P($G(^ORD(100.02,+ORNATR,0)),U,2),'$P(X8,U,5),$P(X8,U,4)=2 D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) ;STS'=12 - Q - ; -HLD1 ; 18 -- secondary pass for On Hold - I STS=3 D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) - Q - ; -NEW ; 19 -- New Orders, plus other unsigned orders by current provider - N IFN,ACTOR,TM,X0,X3,X8,ORENT,ORPAR - S IFN=0 F S IFN=$O(^TMP("ORNEW",$J,IFN)) Q:IFN'>0 D ;New orders - . S ACTOR=0 F S ACTOR=$O(^TMP("ORNEW",$J,IFN,ACTOR)) Q:ACTOR'>0 D - .. Q:'$D(^OR(100,IFN,0)) Q:'$D(^(8,ACTOR,0)) ;deleted - .. D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) - G:'$D(^XUSEC("ORES",DUZ)) NW1 ;ck parameter for add'l orders - S ORENT="ALL"_$S($G(^VA(200,DUZ,5)):"^SRV.`"_+^(5),1:"") - S ORPAR=$$GET^XPAR(ORENT,"OR UNSIGNED ORDERS ON EXIT") - I ORPAR S TM=SDATE F S TM=$O(^OR(100,"AS",PAT,TM)) Q:TM<1!(TM>EDATE) D - . S IFN=0 F S IFN=$O(^OR(100,"AS",PAT,TM,IFN)) Q:IFN<1 D - .. S ACTOR=0 F S ACTOR=$O(^OR(100,"AS",PAT,TM,IFN,ACTOR)) Q:ACTOR<1 D - ... Q:$D(^TMP("ORNEW",$J,IFN,ACTOR)) ;already included - ... S X0=$G(^OR(100,IFN,0)),X3=$G(^(3)),X8=$G(^(8,ACTOR,0)) - ... I $S(ORPAR=1&($P(X8,U,3)=DUZ):1,ORPAR=2:1,1:0) D LP1 -NW1 S ^TMP("ORR",$J,ORLIST,"TOT")=ORLST - Q - ; -CHT1 ; 20 -- secondary pass for Chart Review - ; Include if: unverified, released, inpt, not repl/canc/lapsed - I '$P(X8,U,19),$P(X8,U,15)="",$$INPT,"^12^13^14^"'[(U_STS_U) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) - Q - ; -CHTSUM ; 21 -- secondary pass for Chart copy summary - ; Included based on Nature of Order - N XP,NAT - S XP=+$$GET^XPAR("SYS","OR PRINT ALL ORDERS CHART SUM",1,"I") - I XP=2 D Q ;depends on Nature of Order - . S NAT=$P($G(^OR(100,IFN,6)),U) - . I 'NAT S NAT=$P(X8,U,12) - . I NAT,$$CHART^ORX1(NAT) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) - I XP=0 D Q ;If original printed, print on sum - . I X7 D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) - D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) ;XP=1 gets All orders - Q - ; -LPS1 ; 22 -- secondary pass for Lapsed - I STS=14 D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) - Q - ; -AVT1 ; 23 -- secondary pass for Active/Pending sts only - I (STS=6)!(STS=5) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) - Q - ; -QUIT ; -- stop - Q +ORQ11 ;slc/dcm-Get patient orders in context ;3/31/04 09:57 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,27,48,72,78,99,94,148,141,177,186,190,195,215**;Dec 17, 1997 +LOOP ; -- main loop through "ACT" x-ref + I $G(XREF)="AW" D AW Q + I $G(FLG)=27 D EXPD^ORQ12 Q + K ^TMP("ORGOTIT",$J) +AWIN ;Jump in here to add active orders to AW context + N TM,TO,IFN,X0,X3,X7,X8,USTS,NOW,ACTOR,X ;195 + S NOW=+$E($$NOW^XLFDT,1,12),TM=SDATE + F S TM=$O(^OR(100,"ACT",PAT,TM)) Q:'TM!(TM>EDATE) S TO=0 F S TO=$O(^OR(100,"ACT",PAT,TM,TO)) Q:'TO I $D(ORGRP(TO)) D + . S IFN=0 F S IFN=$O(^OR(100,"ACT",PAT,TM,TO,IFN)) Q:'IFN I ('$D(^TMP("ORGOTIT",$J,IFN))!MULT),$D(^OR(100,IFN,0)),$D(^(3)) S X0=^(0),X3=^(3) D + .. S ACTOR=0 F S ACTOR=$O(^OR(100,"ACT",PAT,TM,TO,IFN,ACTOR)) Q:ACTOR<1 I '$D(^TMP("ORGOTIT",$J,IFN,ACTOR)),$D(^OR(100,IFN,8,ACTOR,0)),$P(^(0),U,15)'=13!(FLG=1) S X8=^(0),X7=$G(^(7)) D LP1 + S ^TMP("ORR",$J,ORLIST,"TOT")=ORLST + Q +AW ; -- loop through "AW" x-ref + K ^TMP("ORGOTIT",$J),^TMP("ORSORT",$J) + N TM,TO,IFN,X0,X3,X7,X8,USTS,NOW,ACTOR,X ;195 + S NOW=+$E($$NOW^XLFDT,1,12),TO=0,SDATE=9999999-SDATE,EDATE=9999999-EDATE + F S TO=$O(^OR(100,"AW",PAT,TO)) Q:'TO I $D(ORGRP(TO)) S TM=EDATE F S TM=$O(^OR(100,"AW",PAT,TO,TM)) Q:'TM!(TM>SDATE)!(+TMEDATE) S IFN=0 F S IFN=$O(^OR(100,"AC",PAT,TM,IFN)) Q:IFN<1 I $D(^OR(100,IFN,0)),$D(^(3)) S X0=^(0),X3=^(3) D + . Q:'$D(ORGRP($P(X0,U,11))) S ACTOR=0 + . F S ACTOR=$O(^OR(100,"AC",PAT,TM,IFN,ACTOR)) Q:ACTOR<1 I $D(^OR(100,IFN,8,ACTOR,0)) S X=^(0) D + .. I "^10^12^"[(U_$P(X,U,15)_U) K ^OR(100,"AC",PAT,TM,IFN,ACTOR) Q + .. I $P(X,U,15)=13,$P(X,U)0,$P($G(^OR(100,IFN,8,ACTOR,0)),U,2)="DC" S OIEN=IFN,OACT=ACTOR + .. ;I OIEN=IFN,OACT>ACTOR K ^OR(100,"AC",PAT,TM,IFN,ACTOR) Q + .. D LP1 + S ^TMP("ORR",$J,ORLIST,"TOT")=ORLST + Q +CUR1 ; 2 -- secondary pass for Active/Current + N STOP S STOP=$P(X0,U,9) + I STS=10 K ^OR(100,"AC",PAT,TM,IFN) Q ;no delayed orders + I '$D(YD),"^1^2^7^12^13^14^"[(U_STS_U) K ^OR(100,"AC",PAT,TM,IFN) Q + I $D(YD),"^1^2^7^12^13^14^"[(U_STS_U),STOP4:1,1:0) + . S DIC="^HOLIDAY(",X=$P(ORDT,".") + . D ^DIC S ORHOL=$S(+$G(Y)>0:1,1:0) + S %DT="",X="T+"_ORNG D ^%DT + S TMW=Y_".9999",NOW=+$E($$NOW^XLFDT,1,12) + D CUR ;D LOOP + Q +EXG1 ; 5 -- secondary pass for Expiring + N STOP S STOP=$P(X0,U,9) + I STS'=1,STS'=2,STS'=7,STS'>9,STOP>NOW,STOP'>TMW D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) + Q + ; +ACT ; 6 -- Recent Activity (Order Summary) + ;N ORLSIGN S ORLSIGN=$$GET^XPAR("ALL","OR ORDER REVIEW DT","`"_+PAT,"Q") + N TM,IFN,X0,X3,ACTOR,X8 + S TM=SDATE F S TM=$O(^OR(100,"AR",PAT,TM)) Q:TM<1!(TM>EDATE) D + . S IFN=0 F S IFN=$O(^OR(100,"AR",PAT,TM,IFN)) Q:IFN<1 S X0=$G(^OR(100,IFN,0)),X3=$G(^(3)) I $D(ORGRP(+$P(X0,U,11))) D + .. S ACTOR=0 F S ACTOR=$O(^OR(100,"AR",PAT,TM,IFN,ACTOR)) Q:ACTOR<1 I $D(^OR(100,IFN,8,ACTOR,0)),$P(^(0),U,15)'=13 S X8=^(0) D LP1 + S ^TMP("ORR",$J,ORLIST,"TOT")=ORLST + Q + ; +PEN1 ; 7 -- secondary pass for Pending + I STS=5 D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) + Q + ; +UVR1 ; 8 -- secondary pass for Unverified + ; Include if: unverified, released, inpt, not repl/canc/lapsed + I '$P(X8,U,9),'$P(X8,U,11),$P(X8,U,15)="",$$INPT,"^12^13^14^"'[(U_STS_U) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) + Q + ; +UVN1 ; 9 -- secondary pass for Unverified/Nurse + ; Include if: unverified, released, inpt, not repl/canc/lapsed + I '$P(X8,U,9),$P(X8,U,15)="",$$INPT,"^12^13^14^"'[(U_STS_U) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) + Q + ; +UVC1 ; 10 -- secondary pass for Unverified/Clerk + ; Include if: unverified, released, inpt, not repl/canc/lapsed + I '$P(X8,U,11),$P(X8,U,15)="",$$INPT,"^12^13^14^"'[(U_STS_U) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) + Q + ; +INPT() ; -- Returns 1 or 0, if inpt order using X0=^OR(100,IFN,0) + I ($P(X0,U,12)="I")!($P(X0,U,17)="D") Q 1 + I $P($G(^SC(+$P(X0,U,10),0)),U,3)="W" Q 1 + Q 0 + ; +SIG ; 11 -- Unsigned + N TM,IFN,X0,X3,ACTOR S TM=SDATE + F S TM=$O(^OR(100,"AS",PAT,TM)) Q:TM<1!(TM>EDATE) S IFN=0 F S IFN=$O(^OR(100,"AS",PAT,TM,IFN)) Q:IFN<1 D + . S X0=$G(^OR(100,IFN,0)),X3=$G(^(3)) + . I X0="" K ^OR(100,"AS",PAT,TM,IFN) Q ;deleted + . Q:'$D(ORGRP(+$P(X0,U,11))) ;not a selected DispGrp + . S ACTOR=0 F S ACTOR=$O(^OR(100,"AS",PAT,TM,IFN,ACTOR)) Q:ACTOR<1 D + .. I $P($G(^OR(100,IFN,8,ACTOR,0)),U,4)'=2 K ^OR(100,"AS",PAT,TM,IFN,ACTOR) Q ;signed or deleted + .. D LP1 + S ^TMP("ORR",$J,ORLIST,"TOT")=ORLST + Q + ; +FLG1 ; 12 -- secondary pass for Flagged + I +$G(^OR(100,IFN,8,ACTOR,3)) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) + Q + ; +VP1 ; 13 -- secondary pass for Verbal/Phone + N ORNATR S ORNATR=$P(X8,U,12) + I ORNATR,"PV"[$P($G(^ORD(100.02,+ORNATR,0)),U,2) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) ;STS'=12 + Q + ; +VPU1 ; 14 -- secondary pass for Verbal/Phone Unsigned + N ORNATR S ORNATR=$P(X8,U,12) + I ORNATR,"PV"[$P($G(^ORD(100.02,+ORNATR,0)),U,2),'$P(X8,U,5),$P(X8,U,4)=2 D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) ;STS'=12 + Q + ; +HLD1 ; 18 -- secondary pass for On Hold + I STS=3 D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) + Q + ; +NEW ; 19 -- New Orders, plus other unsigned orders by current provider + N IFN,ACTOR,TM,X0,X3,X8,ORENT,ORPAR + S IFN=0 F S IFN=$O(^TMP("ORNEW",$J,IFN)) Q:IFN'>0 D ;New orders + . S ACTOR=0 F S ACTOR=$O(^TMP("ORNEW",$J,IFN,ACTOR)) Q:ACTOR'>0 D + .. Q:'$D(^OR(100,IFN,0)) Q:'$D(^(8,ACTOR,0)) ;deleted + .. D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) + G:'$D(^XUSEC("ORES",DUZ)) NW1 ;ck parameter for add'l orders + S ORENT="ALL"_$S($G(^VA(200,DUZ,5)):"^SRV.`"_+^(5),1:"") + S ORPAR=$$GET^XPAR(ORENT,"OR UNSIGNED ORDERS ON EXIT") + I ORPAR S TM=SDATE F S TM=$O(^OR(100,"AS",PAT,TM)) Q:TM<1!(TM>EDATE) D + . S IFN=0 F S IFN=$O(^OR(100,"AS",PAT,TM,IFN)) Q:IFN<1 D + .. S ACTOR=0 F S ACTOR=$O(^OR(100,"AS",PAT,TM,IFN,ACTOR)) Q:ACTOR<1 D + ... Q:$D(^TMP("ORNEW",$J,IFN,ACTOR)) ;already included + ... S X0=$G(^OR(100,IFN,0)),X3=$G(^(3)),X8=$G(^(8,ACTOR,0)) + ... I $S(ORPAR=1&($P(X8,U,3)=DUZ):1,ORPAR=2:1,1:0) D LP1 +NW1 S ^TMP("ORR",$J,ORLIST,"TOT")=ORLST + Q + ; +CHT1 ; 20 -- secondary pass for Chart Review + ; Include if: unverified, released, inpt, not repl/canc/lapsed + I '$P(X8,U,19),$P(X8,U,15)="",$$INPT,"^12^13^14^"'[(U_STS_U) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) + Q + ; +CHTSUM ; 21 -- secondary pass for Chart copy summary + ; Included based on Nature of Order + N XP,NAT + S XP=+$$GET^XPAR("SYS","OR PRINT ALL ORDERS CHART SUM",1,"I") + I XP=2 D Q ;depends on Nature of Order + . S NAT=$P($G(^OR(100,IFN,6)),U) + . I 'NAT S NAT=$P(X8,U,12) + . I NAT,$$CHART^ORX1(NAT) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) + I XP=0 D Q ;If original printed, print on sum + . I X7 D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) + D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) ;XP=1 gets All orders + Q + ; +LPS1 ; 22 -- secondary pass for Lapsed + I STS=14 D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) + Q + ; +AVT1 ; 23 -- secondary pass for Active/Pending sts only + I (STS=6)!(STS=5) D GET^ORQ12(IFN,ORLIST,DETAIL,ACTOR) + Q + ; +QUIT ; -- stop + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQ12.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQ12.m index 40e8100a..9403b2eb 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQ12.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQ12.m @@ -1,122 +1,121 @@ -ORQ12 ; slc/dcm - Get patient orders in context ;06/29/06 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**12,27,78,92,116,190,220,215,243**;Dec 17, 1997;Build 242 -GET(IFN,NEWD,DETAIL,ACTOR) ; -- Setup TMP array - ; IFN=ifn of order - ; NEWD=3rd subscript in ^TMP("ORR",$J, node (ORLIST) - ; DETAIL=see description in ^ORQ1 - ; - N X0,X3,X4,X6,TXT,STAT,START,DG,STOP,ENTERD - S ORLST=ORLST+1,^TMP("ORGOTIT",$J,IFN,+$G(ACTOR))="" - I '$G(DETAIL) S ^TMP("ORR",$J,NEWD,ORLST)=IFN_$S($G(ACTOR):";"_ACTOR,1:"") Q - S X0=^OR(100,IFN,0),X3=$G(^(3)),X4=$G(^(4)),X6=$G(^(6)) - S DG=$P(X0,U,11),DG=$P($G(^ORD(100.98,+DG,0)),U,3) - S STAT=$S($P(X3,U,3):$P(^ORD(100.01,$P(X3,U,3),0),U,1,2),1:"") ;.01^abbr - S ENTERD=$P(X0,U,7),START=$P(X0,U,8),STOP=$P(X0,U,9) - ; S FLAGREA=$P(X6,U,7) - S ^TMP("ORR",$J,NEWD,ORLST)=IFN_$S($G(ACTOR):";"_ACTOR,1:"")_U_DG_U_ENTERD_U_START_U_STOP_U_STAT - D TEXT(.TXT,IFN) M ^TMP("ORR",$J,NEWD,ORLST,"TX")=TXT - Q - ; -TEXT(ORTX,ORIFN,WIDTH) ; -- Returns text of order ORIFN in ORTX(#) - N OR0,OR3,OR6,X,Y,FIRST,ORI,ORJ,DLG,ORX,ORACT,ORTA - K ORTX S:'$G(WIDTH) WIDTH=244 - S ORACT=+$P(ORIFN,";",2),ORIFN=+ORIFN - I ORACT<1 S ORACT=+$P($G(^OR(100,ORIFN,3)),U,7) S:'ORACT ORACT=1 - ;D:$O(^OR(100,ORIFN,1,0)) CNV^ORY92(ORIFN) ;convert text otf - S OR0=$G(^OR(100,ORIFN,0)),OR3=$G(^(3)),OR6=$G(^(6)),ORX=$G(^(8,ORACT,0)) - S ORTX=1,ORTX(1)="" - I $P($G(OR0),U,11)'="",($P(^ORD(100.98,$P(OR0,U,11),0),U)="NON-VA MEDICATIONS") S X="Non-VA" D ADD - G:$G(ORIGVIEW)>1 T1 - S:$P(OR0,U,14)=$O(^DIC(9.4,"C","OR",0)) ORTX(1)=">>" ;generic - S X=$$ACTION($P(ORX,U,2)) D:$L(X) ADD - I $P(ORX,U,2)="NW",$P(OR3,U,11),'$G(ORIGVIEW) D ; Changed or Renewed - . I $P(OR3,U,11)=2 S X="Renew" D ADD Q - . N ORIG,ORIGTA S ORIG=+$P(OR3,U,5) Q:'ORIG Q:$P(OR3,U,11)'=1 - . S X="Change" D ADD S ORI=0 - . I $G(IOST)'="P-OTHER" D - . .S ORIGTA=$$LASTXT(ORIG) ;D:$O(^OR(100,ORIG,1,0)) CNV^ORY92(ORIG) - . .F S ORI=$O(^OR(100,ORIG,8,ORIGTA,.1,ORI)) Q:ORI'>0 S X=$G(^(ORI,0)) S:$E(X,1,3)=">> " X=$E(X,4,999) D ADD - . .S X=" to" D ADD -T1 S ORTA=+$P(ORX,U,14),FIRST=+$O(^OR(100,ORIFN,8,ORTA,.1,0)) - S ORI=0 F S ORI=$O(^OR(100,ORIFN,8,ORTA,.1,ORI)) Q:ORI'>0 S X=$G(^(ORI,0)) S:(FIRST=ORI)&($E(X,1,3)=">> ") X=$E(X,4,999) D:$L(X) ADD - Q:$G(ORIGVIEW)>1 ;contents of global only - S DLG=$P(OR0,U,5) K Y I DLG,$P(DLG,";",2)["101.41",$D(^ORD(101.41,+DLG,9)) X ^(9) I $L($G(Y)) S X=Y D ADD ; additional text - ; I $P(OR3,U,11)=2 S X="(Renewal)" D ADD - I $P(ORX,U,4)=2 S X="*UNSIGNED*" D ADD - I $P(ORX,U,2)="DC"!("^1^13^"[(U_$P(OR3,U,3)_U)),$L(OR6) S X=" <"_$S($L($P(OR6,U,5)):$P(OR6,U,5),$P(OR6,U,4):$P($G(^ORD(100.03,+$P(OR6,U,4),0)),U),1:"")_">" D:$L(X)>3 ADD ; DC Reason - I $D(XQAID),$G(ORFLG)=12 S ORX=$G(^OR(100,ORIFN,8,ORACT,3)) I $P(ORX,U) S X=" Flagged "_$$DATETIME($P(ORX,U,3))_$S($P(ORX,U,4):" by "_$$NAME($P(ORX,U,4)),1:"")_": "_$P(ORX,U,5) D ADD ; Flagged - show in FUP - Q - ; -LASTXT(IFN) ; -- Returns action with latest text for order IFN - N I,Y S Y=1 - S I=0 F S I=$O(^OR(100,IFN,8,I)) Q:I'>0 S:$O(^(I,.1,0)) Y=I - Q Y - ; -LAST(CODE) ; -- Return DA of last occurence of CODE action - N DA - I '$L($G(CODE)) S DA=$O(^OR(100,ORIFN,8,"A"),-1) ; last entry - E S DA=$O(^OR(100,ORIFN,8,"C",CODE,"?"),-1) ; last CODE entry - Q DA - ; -ACTION(X) ; -- Returns text of action X - N Y - S Y=$S(X="DC":"Discontinue",X="HD":"Hold",X="RL"&'$G(ORIGVIEW):"Release Hold of",X="FL":"Flag",X="UF":"Unflag",X="RN"&'$G(ORIGVIEW):"Renew",1:"") - Q Y - ; -DATETIME(X) ; -- Returns date/time in format 00/00/00@00:00am - N Y,D,T,T1,Z - S D=$P(X,"."),T=$E($P(X,".",2)_"0000",1,4),T1=$E(T,1,2),Z="AM" - S:T1>12 T1=T1-12,Z="PM" - S Y=$E(D,4,5)_"/"_$E(D,6,7)_"/"_(1700+$E(D,1,3))_"@"_T1_":"_$E(T,3,4)_Z - Q Y - ; -NAME(X) ; -- Returns name as Lname,F - N Y,Z S Z=$P($G(^VA(200,+X,0)),U) Q:Z="" "" - S Y=$P(Z,",")_"," F I=$F(Z,","):1:$L(Z) I $E(Z,I)'=" " S Y=Y_$E(Z,I) Q - S Y=$$LOWER^VALM1(Y) ; mixed case - Q Y - ; -ADD ; -- Add text X to ORTX() - N I,Y S Y=$L(ORTX(ORTX)) S:Y Y=Y+1 ;allow for space - I $E(X)=" ",Y S ORTX=ORTX+1,ORTX(ORTX)="",Y=0,X=$E(X,2,999) ;new line - I Y+$L(X)'>WIDTH S ORTX(ORTX)=ORTX(ORTX)_$S(Y:" ",1:"")_X Q - F I=1:1:$L(X," ") S Z=$P(X," ",I) D:(Y+$L(Z))>WIDTH S ORTX(ORTX)=$G(ORTX(ORTX))_$S(Y:" ",1:"")_Z,Y=$L(ORTX(ORTX)) S:Y Y=Y+1 - . I $L(Z)>WIDTH F S ORTX(ORTX)=$G(ORTX(ORTX))_$S(Y:" ",1:"")_$E(Z,1,WIDTH-Y),Z=$E(Z,WIDTH-Y+1,999) Q:$L(Z)'>WIDTH S ORTX=ORTX+1,Y=0 - . S ORTX=ORTX+1,Y=0 - Q - ; -EXPD ; -- loop through ^XTMP("ORAE" to get expired orders - K ^TMP("ORGOTIT",$J),^TMP("ORSORT",$J) - N TM,TO,IFN,X0,X3,X7,X8,USTS,NOW,ACTOR,X,ORREP - S NOW=+$E($$NOW^XLFDT,1,12),TO=0,SDATE=9999999-SDATE,EDATE=9999999-EDATE - F S TO=$O(^XTMP("ORAE",PAT,TO)) Q:'TO I $D(ORGRP(TO)) S TM=EDATE F S TM=$O(^XTMP("ORAE",PAT,TO,TM)) Q:'TM!(TM>SDATE)!(+TM0 ;quit if order has been replaced - .. S ^TMP("ORSORT",$J,9999999-TM,TO,IFN)="" - S TM=0 F S TM=$O(^TMP("ORSORT",$J,TM)) Q:'TM S TO=0 F S TO=$O(^TMP("ORSORT",$J,TM,TO)) Q:'TO D - .S IFN=0 F S IFN=$O(^TMP("ORSORT",$J,TM,TO,IFN)) Q:'IFN I $D(^OR(100,IFN,0)),$D(^(3)) S X0=^(0),X3=^(3) D - ..S ACTOR=+$P(X3,U,7) D LP1^ORQ11 - ..;S ACTOR=0 F S ACTOR=$O(^OR(100,"ACT",PAT,9999999-$P(X0,U,7),TO,IFN,ACTOR)) Q:ACTOR<1 I '$D(^TMP("ORGOTIT",$J,IFN,ACTOR)),$D(^OR(100,IFN,8,ACTOR,0)),$P(^(0),U,15)'=13 S X8=^(0),X7=$G(^(7)) D LP1^ORQ11 - S ^TMP("ORR",$J,ORLIST,"TOT")=$G(ORLST) - K ^TMP("ORSORT",$J),^TMP("ORGOTIT",$J) - Q -GETEIE(IFN,NEWD,DETAIL,ACTOR) ; -- Setup TMP array - ; IFN=ifn of order - ; NEWD=3rd subscript in ^TMP("ORR",$J, node (ORLIST) - ; DETAIL=see description in ^ORQ1 - ; - N X0,X3,X4,X6,TXT,STAT,START,DG,STOP,ENTERD,DCREAS - S X0=^OR(100,IFN,0),X3=$G(^(3)),X4=$G(^(4)),X6=$G(^(6)) - S DG=$P(X0,U,11),DG=$P($G(^ORD(100.98,+DG,0)),U,3) - S STAT=$S($P(X3,U,3):$P(^ORD(100.01,$P(X3,U,3),0),U,1,2),1:"") - S ENTERD=$P(X0,U,7),START=$P(X0,U,8),STOP=$P(X0,U,9) - S DCREAS=$P($G(X6),U,4) Q:DCREAS'>0 - I DCREAS'=$O(^ORD(100.03,"B","Entered in error","")) Q - S ORLST=ORLST+1,^TMP("ORGOTIT",$J,IFN,+$G(ACTOR))="" - I '$G(DETAIL) S ^TMP("ORR",$J,NEWD,ORLST)=IFN_$S($G(ACTOR):";"_ACTOR,1:"") Q - S ^TMP("ORR",$J,NEWD,ORLST)=IFN_$S($G(ACTOR):";"_ACTOR,1:"")_U_DG_U_ENTERD_U_START_U_STOP_U_STAT - D TEXT(.TXT,IFN) M ^TMP("ORR",$J,NEWD,ORLST,"TX")=TXT - Q +ORQ12 ; slc/dcm - Get patient orders in context ;12/19/05 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**12,27,78,92,116,190,220,215**;Dec 17, 1997 +GET(IFN,NEWD,DETAIL,ACTOR) ; -- Setup TMP array + ; IFN=ifn of order + ; NEWD=3rd subscript in ^TMP("ORR",$J, node (ORLIST) + ; DETAIL=see description in ^ORQ1 + ; + N X0,X3,X4,X6,TXT,STAT,START,DG,STOP,ENTERD + S ORLST=ORLST+1,^TMP("ORGOTIT",$J,IFN,+$G(ACTOR))="" + I '$G(DETAIL) S ^TMP("ORR",$J,NEWD,ORLST)=IFN_$S($G(ACTOR):";"_ACTOR,1:"") Q + S X0=^OR(100,IFN,0),X3=$G(^(3)),X4=$G(^(4)),X6=$G(^(6)) + S DG=$P(X0,U,11),DG=$P($G(^ORD(100.98,+DG,0)),U,3) + S STAT=$S($P(X3,U,3):$P(^ORD(100.01,$P(X3,U,3),0),U,1,2),1:"") ;.01^abbr + S ENTERD=$P(X0,U,7),START=$P(X0,U,8),STOP=$P(X0,U,9) + ; S FLAGREA=$P(X6,U,7) + S ^TMP("ORR",$J,NEWD,ORLST)=IFN_$S($G(ACTOR):";"_ACTOR,1:"")_U_DG_U_ENTERD_U_START_U_STOP_U_STAT + D TEXT(.TXT,IFN) M ^TMP("ORR",$J,NEWD,ORLST,"TX")=TXT + Q + ; +TEXT(ORTX,ORIFN,WIDTH) ; -- Returns text of order ORIFN in ORTX(#) + N OR0,OR3,OR6,X,Y,FIRST,ORI,ORJ,DLG,ORX,ORACT,ORTA + K ORTX S:'$G(WIDTH) WIDTH=244 + S ORACT=+$P(ORIFN,";",2),ORIFN=+ORIFN + I ORACT<1 S ORACT=+$P($G(^OR(100,ORIFN,3)),U,7) S:'ORACT ORACT=1 + ;D:$O(^OR(100,ORIFN,1,0)) CNV^ORY92(ORIFN) ;convert text otf + S OR0=$G(^OR(100,ORIFN,0)),OR3=$G(^(3)),OR6=$G(^(6)),ORX=$G(^(8,ORACT,0)) + S ORTX=1,ORTX(1)="" + I $P($G(OR0),U,11)'="",($P(^ORD(100.98,$P(OR0,U,11),0),U)="NON-VA MEDICATIONS") S X="Non-VA" D ADD + G:$G(ORIGVIEW)>1 T1 + S:$P(OR0,U,14)=$O(^DIC(9.4,"C","OR",0)) ORTX(1)=">>" ;generic + S X=$$ACTION($P(ORX,U,2)) D:$L(X) ADD + I $P(ORX,U,2)="NW",$P(OR3,U,11),'$G(ORIGVIEW) D ; Changed or Renewed + . I $P(OR3,U,11)=2 S X="Renew" D ADD Q + . N ORIG,ORIGTA S ORIG=+$P(OR3,U,5) Q:'ORIG Q:$P(OR3,U,11)'=1 + . S X="Change" D ADD S ORI=0 + . I $G(IOST)'="P-OTHER" D + . .S ORIGTA=$$LASTXT(ORIG) ;D:$O(^OR(100,ORIG,1,0)) CNV^ORY92(ORIG) + . .F S ORI=$O(^OR(100,ORIG,8,ORIGTA,.1,ORI)) Q:ORI'>0 S X=$G(^(ORI,0)) S:$E(X,1,3)=">> " X=$E(X,4,999) D ADD + . .S X=" to" D ADD +T1 S ORTA=+$P(ORX,U,14),FIRST=+$O(^OR(100,ORIFN,8,ORTA,.1,0)) + S ORI=0 F S ORI=$O(^OR(100,ORIFN,8,ORTA,.1,ORI)) Q:ORI'>0 S X=$G(^(ORI,0)) S:(FIRST=ORI)&($E(X,1,3)=">> ") X=$E(X,4,999) D:$L(X) ADD + Q:$G(ORIGVIEW)>1 ;contents of global only + S DLG=$P(OR0,U,5) K Y I DLG,$P(DLG,";",2)["101.41",$D(^ORD(101.41,+DLG,9)) X ^(9) I $L($G(Y)) S X=Y D ADD ; additional text + ; I $P(OR3,U,11)=2 S X="(Renewal)" D ADD + I $P(ORX,U,4)=2 S X="*UNSIGNED*" D ADD + I $P(ORX,U,2)="DC"!("^1^13^"[(U_$P(OR3,U,3)_U)),$L(OR6) S X=" <"_$S($L($P(OR6,U,5)):$P(OR6,U,5),$P(OR6,U,4):$P($G(^ORD(100.03,+$P(OR6,U,4),0)),U),1:"")_">" D:$L(X)>3 ADD ; DC Reason + I $D(XQAID),$G(ORFLG)=12 S ORX=$G(^OR(100,ORIFN,8,ORACT,3)) I $P(ORX,U) S X=" Flagged "_$$DATETIME($P(ORX,U,3))_$S($P(ORX,U,4):" by "_$$NAME($P(ORX,U,4)),1:"")_": "_$P(ORX,U,5) D ADD ; Flagged - show in FUP + Q + ; +LASTXT(IFN) ; -- Returns action with latest text for order IFN + N I,Y S Y=1 + S I=0 F S I=$O(^OR(100,IFN,8,I)) Q:I'>0 S:$O(^(I,.1,0)) Y=I + Q Y + ; +LAST(CODE) ; -- Return DA of last occurence of CODE action + N DA + I '$L($G(CODE)) S DA=$O(^OR(100,ORIFN,8,"A"),-1) ; last entry + E S DA=$O(^OR(100,ORIFN,8,"C",CODE,"?"),-1) ; last CODE entry + Q DA + ; +ACTION(X) ; -- Returns text of action X + N Y + S Y=$S(X="DC":"Discontinue",X="HD":"Hold",X="RL"&'$G(ORIGVIEW):"Release Hold of",X="FL":"Flag",X="UF":"Unflag",X="RN"&'$G(ORIGVIEW):"Renew",1:"") + Q Y + ; +DATETIME(X) ; -- Returns date/time in format 00/00/00@00:00am + N Y,D,T,T1,Z + S D=$P(X,"."),T=$E($P(X,".",2)_"0000",1,4),T1=$E(T,1,2),Z="AM" + S:T1>12 T1=T1-12,Z="PM" + S Y=$E(D,4,5)_"/"_$E(D,6,7)_"/"_(1700+$E(D,1,3))_"@"_T1_":"_$E(T,3,4)_Z + Q Y + ; +NAME(X) ; -- Returns name as Lname,F + N Y,Z S Z=$P($G(^VA(200,+X,0)),U) Q:Z="" "" + S Y=$P(Z,",")_"," F I=$F(Z,","):1:$L(Z) I $E(Z,I)'=" " S Y=Y_$E(Z,I) Q + S Y=$$LOWER^VALM1(Y) ; mixed case + Q Y + ; +ADD ; -- Add text X to ORTX() + N I,Y S Y=$L(ORTX(ORTX)) S:Y Y=Y+1 ;allow for space + I $E(X)=" ",Y S ORTX=ORTX+1,ORTX(ORTX)="",Y=0,X=$E(X,2,999) ;new line + I Y+$L(X)'>WIDTH S ORTX(ORTX)=ORTX(ORTX)_$S(Y:" ",1:"")_X Q + F I=1:1:$L(X," ") S Z=$P(X," ",I) D:(Y+$L(Z))>WIDTH S ORTX(ORTX)=$G(ORTX(ORTX))_$S(Y:" ",1:"")_Z,Y=$L(ORTX(ORTX)) S:Y Y=Y+1 + . I $L(Z)>WIDTH F S ORTX(ORTX)=$G(ORTX(ORTX))_$S(Y:" ",1:"")_$E(Z,1,WIDTH-Y),Z=$E(Z,WIDTH-Y+1,999) Q:$L(Z)'>WIDTH S ORTX=ORTX+1,Y=0 + . S ORTX=ORTX+1,Y=0 + Q + ; +EXPD ; -- loop through ^XTMP("ORAE" to get expired orders + K ^TMP("ORGOTIT",$J),^TMP("ORSORT",$J) + N TM,TO,IFN,X0,X3,X7,X8,USTS,NOW,ACTOR,X,ORREP + S NOW=+$E($$NOW^XLFDT,1,12),TO=0,SDATE=9999999-SDATE,EDATE=9999999-EDATE + F S TO=$O(^XTMP("ORAE",PAT,TO)) Q:'TO I $D(ORGRP(TO)) S TM=EDATE F S TM=$O(^XTMP("ORAE",PAT,TO,TM)) Q:'TM!(TM>SDATE)!(+TM0 ;quit if order has been replaced + .. S ^TMP("ORSORT",$J,9999999-TM,TO,IFN)="" + S TM=0 F S TM=$O(^TMP("ORSORT",$J,TM)) Q:'TM S TO=0 F S TO=$O(^TMP("ORSORT",$J,TM,TO)) Q:'TO D + . S IFN=0 F S IFN=$O(^TMP("ORSORT",$J,TM,TO,IFN)) Q:'IFN I $D(^OR(100,IFN,0)),$D(^(3)) S X0=^(0),X3=^(3) D + .. S ACTOR=0 F S ACTOR=$O(^OR(100,"ACT",PAT,9999999-$P(X0,U,7),TO,IFN,ACTOR)) Q:ACTOR<1 I '$D(^TMP("ORGOTIT",$J,IFN,ACTOR)),$D(^OR(100,IFN,8,ACTOR,0)),$P(^(0),U,15)'=13 S X8=^(0),X7=$G(^(7)) D LP1^ORQ11 + S ^TMP("ORR",$J,ORLIST,"TOT")=ORLST + K ^TMP("ORSORT",$J),^TMP("ORGOTIT",$J) + Q +GETEIE(IFN,NEWD,DETAIL,ACTOR) ; -- Setup TMP array + ; IFN=ifn of order + ; NEWD=3rd subscript in ^TMP("ORR",$J, node (ORLIST) + ; DETAIL=see description in ^ORQ1 + ; + N X0,X3,X4,X6,TXT,STAT,START,DG,STOP,ENTERD,DCREAS + S X0=^OR(100,IFN,0),X3=$G(^(3)),X4=$G(^(4)),X6=$G(^(6)) + S DG=$P(X0,U,11),DG=$P($G(^ORD(100.98,+DG,0)),U,3) + S STAT=$S($P(X3,U,3):$P(^ORD(100.01,$P(X3,U,3),0),U,1,2),1:"") + S ENTERD=$P(X0,U,7),START=$P(X0,U,8),STOP=$P(X0,U,9) + S DCREAS=$P($G(X6),U,4) Q:DCREAS'>0 + I DCREAS'=$O(^ORD(100.03,"B","Entered in error","")) Q + S ORLST=ORLST+1,^TMP("ORGOTIT",$J,IFN,+$G(ACTOR))="" + I '$G(DETAIL) S ^TMP("ORR",$J,NEWD,ORLST)=IFN_$S($G(ACTOR):";"_ACTOR,1:"") Q + S ^TMP("ORR",$J,NEWD,ORLST)=IFN_$S($G(ACTOR):";"_ACTOR,1:"")_U_DG_U_ENTERD_U_START_U_STOP_U_STAT + D TEXT(.TXT,IFN) M ^TMP("ORR",$J,NEWD,ORLST,"TX")=TXT + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQ2.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQ2.m index 19c164da..15c6d628 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQ2.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQ2.m @@ -1,130 +1,125 @@ -ORQ2 ; SLC/MKB/GSS - Detailed Order Report ;10/10/2006 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**12,56,75,94,141,213,195,243**;Dec 17, 1997;Build 242 -DETAIL(ORY,ORIFN) ; -- Returns details of order ORIFN in ORY(#) - N X,X2,I,CNT,ORDIALOG,OR0,OR3,OR6,SEQ,ITEM,PRMT,MULT,FIRST,TITLE,INST,DIWL,DIWR,DIWF,ACTION,VAIN,ORIGVIEW,ORNMSP,ORYT - S CNT=0,ORIFN=+ORIFN,OR0=$G(^OR(100,ORIFN,0)),OR3=$G(^(3)),OR6=$G(^(6)) - K @ORY,ORYT S ORIGVIEW=1 D TEXT^ORQ12(.ORYT,+ORIFN_";"_+$P(OR3,U,7),80) ;CurrTx - M @ORY=ORYT ;Move text to global - S I=0 F CNT=1:1 S I=$O(ORYT(I)) Q:I'>0 D:$D(IORVON) SETVIDEO(I,1,$L(ORYT(I)),IORVON,IORVOFF) - S CNT=CNT+1,@ORY@(CNT)=" " ;blank -D1 I $O(^OR(100,+ORIFN,2,0)) D - . S CNT=CNT+1,@ORY@(CNT)="Sub Orders:" - . D:$D(IOUON) SETVIDEO(CNT,1,11,IOUON,IOUOFF) - . N IFN S IFN=0 - . F S IFN=+$O(^OR(100,+ORIFN,2,IFN)) Q:IFN<1 I $D(^OR(100,IFN,0)) D SUB(IFN) - . S CNT=CNT+1,@ORY@(CNT)=" " ;blank - I $P(OR3,U,9),$D(^OR(100,+$P(OR3,U,9),0)) D - . S CNT=CNT+1,@ORY@(CNT)="Parent Order:" - . D:$D(IOUON) SETVIDEO(CNT,1,12,IOUON,IOUOFF) - . D SUB(+$P(OR3,U,9)) - . S CNT=CNT+1,@ORY@(CNT)=" " ;blank - I $P(OR3,U,11)=1,$P(OR3,U,5) D ;Changed - show previous order - . S CNT=CNT+1,@ORY@(CNT)="Previous Order:" - . D:$D(IOUON) SETVIDEO(CNT,1,15,IOUON,IOUOFF) ;prev order original text - . N ORZ,I,ORIGVIEW S ORIGVIEW=2 D TEXT^ORQ12(.ORZ,+$P(OR3,U,5),55) - . S CNT=CNT+1,@ORY@(CNT)=" Order Text: "_$G(ORZ(1)) - . S I=1 F S I=$O(ORZ(I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=$$REPEAT^XLFSTR(" ",24)_$G(ORZ(I)) -D2 S CNT=CNT+1,@ORY@(CNT)="Activity:" - D:$D(IOUON) SETVIDEO(CNT,1,9,IOUON,IOUOFF) - S DIWL=1,DIWR=64,DIWF="C64",ORI=0 K ^UTILITY($J,"W") - F S ORI=$O(^OR(100,ORIFN,8,ORI)) Q:ORI'>0 S ACTION=$G(^(ORI,0)) D ACT^ORQ20 - I "^1^12^13^"[(U_$P(OR3,U,3)_U),$L(OR6),$P(ACTION,U,2)'="DC" D DC^ORQ20 - I $P(OR3,U,3)=2,$P(OR6,U,6) S CNT=CNT+1,@ORY@(CNT)=$$DATE^ORQ20($P(OR6,U,6))_" Completed"_$S($P(OR6,U,7):" by "_$$USER^ORQ20($P(OR6,U,7)),1:"") - S CNT=CNT+1,@ORY@(CNT)=" " ;blank -D3 S CNT=CNT+1,@ORY@(CNT)="Current Data:" - D:$D(IOUON) SETVIDEO(CNT,1,13,IOUON,IOUOFF) - D VA I $G(VAIN(2)) S CNT=CNT+1,@ORY@(CNT)="Current Primary Provider: "_$P(VAIN(2),"^",2) - I $G(VAIN(11)) S CNT=CNT+1,@ORY@(CNT)="Current Attending Physician: "_$P(VAIN(11),"^",2) - S CNT=CNT+1,@ORY@(CNT)="Treating Specialty: "_$P($G(^DIC(45.7,+$P(OR0,U,13),0)),U) - S CNT=CNT+1,@ORY@(CNT)="Ordering Location: "_$P($G(^SC(+$P(OR0,U,10),0)),U) - S CNT=CNT+1,@ORY@(CNT)="Start Date/Time: "_$S($P(OR0,U,8):$$DATE^ORQ20($P(OR0,U,8)),1:"") - I $P(OR3,U,5),$P(OR3,U,11)=2 S X=$$ORIG(ORIFN),@ORY@(CNT)=@ORY@(CNT)_" (originally "_$$DATE^ORQ20(X)_")" - S CNT=CNT+1,@ORY@(CNT)="Stop Date/Time: "_$S($P(OR0,U,9):$$DATE^ORQ20($P(OR0,U,9)),1:"") - I $P(OR3,U,3)=1,$P(OR6,U,6) S @ORY@(CNT)=@ORY@(CNT)_" (expired "_$$DATE^ORQ20($P(OR6,U,6))_")" - S CNT=CNT+1,@ORY@(CNT)="Current Status: "_$S($D(^ORD(100.01,+$P(OR3,U,3),0)):$P(^(0),"^"),1:"-") - I $$GET^XPAR("ALL","ORPF SHOW STATUS DESCRIPTION",1,"I"),$P(OR3,U,3),$D(^ORD(100.01,$P(OR3,U,3),0)) N J S J=0 F S J=$O(^ORD(100.01,$P(OR3,U,3),1,J)) Q:J<1 S CNT=CNT+1,@ORY@(CNT)=" "_^(J,0) - S CNT=CNT+1,@ORY@(CNT)="Order #"_ORIFN - S CNT=CNT+1,@ORY@(CNT)=" " ;blank -D4 S CNT=CNT+1,@ORY@(CNT)="Order:" D:$D(IOUON) SETVIDEO(CNT,1,6,IOUON,IOUOFF) - S ORNMSP=$$NMSP^ORCD($P(OR0,U,14)) - I '$O(^OR(100,ORIFN,4.5,0)),ORNMSP="RA" D RAD^ORQ21("") Q - S ORDIALOG=$P(OR0,U,5) Q:$P(ORDIALOG,";",2)="ORD(101," ; 2.5 order - D GETDLG^ORCD(+ORDIALOG),GETORDER^ORCD(ORIFN) - S DIWL=1,DIWR=50,DIWF="C50" - S SEQ=0 F S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ)) Q:SEQ'>0 S DA=0 F S DA=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ,DA)) Q:'DA D - . S ITEM=$G(^ORD(101.41,+ORDIALOG,10,DA,0)) Q:$P(ITEM,U,11) ; child - . S PRMT=$P(ITEM,U,2),MULT=$P(ITEM,U,7) Q:$P(ITEM,U,9)["*" ;hide - . S FIRST=$O(ORDIALOG(PRMT,0)) Q:'FIRST ; no values - . S TITLE=$S(MULT&$L($G(ORDIALOG(PRMT,"TTL"))):ORDIALOG(PRMT,"TTL"),1:ORDIALOG(PRMT,"A")) - . S TITLE=TITLE_$$REPEAT^XLFSTR(" ",30-$L(TITLE)) - . S INST=0 F S INST=$O(ORDIALOG(PRMT,INST)) Q:INST'>0 D - . . I $E(ORDIALOG(PRMT,0))="W" D WP Q - . . K ^UTILITY($J,"W") S X=$$EXT^ORCD(PRMT,INST) I TITLE["Infusion Rate"&(X'="")&(X'["ml/hr") S TITLE="Infuse Over Time:",TITLE=TITLE_$$REPEAT^XLFSTR(" ",30-$L(TITLE)) - . . D ^DIWP - . . D:$D(^ORD(101.41,+ORDIALOG,10,"DAD",PRMT)) CHILDREN(PRMT) - . . S I=0 F S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=$S((INST=FIRST)&(I=1):TITLE,1:$$REPEAT^XLFSTR(" ",30))_^(I,0) - I ORNMSP="GMRC",$G(^OR(100,ORIFN,4)) S CNT=CNT+1,@ORY@(CNT)="Consult No.: "_+^(4) - S CNT=CNT+1,@ORY@(CNT)=" " ;blank - D RAD^ORQ21(1):ORNMSP="RA",MED^ORQ21:ORNMSP="PS" ;add'l data - D BA^ORQ21 ;call for CIDC data -D5 I $O(^OR(100,+ORIFN,9,0)) D - . N CK,OK,X0,X,CDL,I S CNT=CNT+1,@ORY@(CNT)="Order Checks:" - . D:$D(IOUON) SETVIDEO(CNT,1,13,IOUON,IOUOFF) - . S CK=0 F S CK=$O(^OR(100,+ORIFN,9,CK)) Q:CK'>0 S X0=$G(^(CK,0)),X=$G(^(1)) D - .. S CDL=$$CDL($P(X0,U,2)) I $P(X0,U,6),'$D(OK) S OK=$P(X0,U,4,6) - .. I $L(X)'>68 S CNT=CNT+1,@ORY@(CNT)=CDL_X Q - .. S DIWL=1,DIWR=68,DIWF="C68" K ^UTILITY($J,"W") D ^DIWP - .. S I=0 F S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=CDL_^(I,0),CDL=" " - . Q:'$L($G(OK)) S CNT=CNT+1,@ORY@(CNT)="Override: "_$S($P(OK,U,2):$$USER^ORQ20($P(OK,U,2))_" on ",1:"")_$$DATE^ORQ20($P(OK,U,3)) - . I $L($P(OK,U))'>68 S CNT=CNT+1,@ORY@(CNT)=" "_$P(OK,U) Q - . S DIWL=1,DIWR=68,DIWF="C68",X=$P(OK,U) K ^UTILITY($J,"W") D ^DIWP - . S I=0 F S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=" "_^(I,0) - K ^TMP("ORWORD",$J),^UTILITY($J,"W") - Q - ; -SUB(IFN) ; -- add suborder or parent - N ORCY,STS,STRT,IG D TEXT^ORQ12(.ORCY,IFN,58) - S STS=$G(^ORD(100.01,+$P($G(^OR(100,IFN,3)),U,3),.1)) - S STRT=$P(^OR(100,IFN,0),U,8) S:STRT'="" STRT=$$DATE^ORQ20(STRT) - S IG=0 F S IG=$O(ORCY(IG)) Q:IG<1 S CNT=CNT+1,@ORY@(CNT)=$J(STS,4)_" "_ORCY(IG)_" "_STRT,(STS,STRT)=" " - Q - ; -WP ; -- add word-processing - N WP,ORI,X M WP=@ORDIALOG(PRMT,INST) - S CNT=CNT+1,@ORY@(CNT)=TITLE - S ORI=0 F S ORI=$O(WP(ORI)) Q:ORI'>0 S X=WP(ORI,0) S:X'="" CNT=CNT+1,@ORY@(CNT)=" "_X - Q - ; -CHILDREN(PARENT) ; -- add children - N SEQ,DA,ITM,PRMT,TYPE,X - S SEQ=0 F S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PARENT,SEQ)) Q:SEQ'>0 S DA=$O(^(SEQ,0)) D - . S ITM=$G(^ORD(101.41,+ORDIALOG,10,DA,0)),PRMT=$P(ITM,U,2) - . Q:$G(ORDIALOG(PRMT,INST))="" Q:$P(ITM,U,9)["*" ;no value or hide - . S TYPE=$E(ORDIALOG(PRMT,0)) D:TYPE="W" WP - . I TYPE'="W" D - . . S X=$$EXT^ORCD(PRMT,INST) - . . I $L(X,"|")=2 S X=$$REPLACE^ORHLESC(X,"|","||") - . . D ^DIWP - Q - ; -SETVIDEO(LINE,COL,WIDTH,ON,OFF) ; -- set video attributes - S ORY("VIDEO",LINE,COL,WIDTH)=ON - S ORY("VIDEO",LINE,COL+WIDTH,0)=OFF - Q - ; -VA ; -- Call VADPT - N ORY,DFN,Y S DFN=+$P(OR0,"^",2) D OERR^VADPT - Q - ; -CDL(X) ; -- Returns Clinical Danger Level X - N Y S Y=$S(X=1:"HIGH:",X=2:"MODERATE:",X=3:"LOW:",1:"NONE:") - S Y=$E(Y_" ",1,12) - Q Y - ; -ORIG(IFN) ; -- Return original start date of [renewal] order - N I,Y,X3,DONE - S I=IFN,Y=$P($G(^OR(100,IFN,0)),U,8),DONE=0 - F S X3=$G(^OR(100,I,3)) D Q:DONE - . I $P(X3,U,11)=2,$P(X3,U,5) S I=$P(X3,U,5) Q ;loop - . S Y=$P($G(^OR(100,I,0)),U,8),DONE=1 - Q Y +ORQ2 ; SLC/MKB/GSS - Detailed Order Report ;7/1/04 10:58 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**12,56,75,94,141,213,195**;Dec 17, 1997 +DETAIL(ORY,ORIFN) ; -- Returns details of order ORIFN in ORY(#) + N X,X2,I,CNT,ORDIALOG,OR0,OR3,OR6,SEQ,ITEM,PRMT,MULT,FIRST,TITLE,INST,DIWL,DIWR,DIWF,ACTION,VAIN,ORIGVIEW,ORNMSP,ORYT + S CNT=0,ORIFN=+ORIFN,OR0=$G(^OR(100,ORIFN,0)),OR3=$G(^(3)),OR6=$G(^(6)) + K @ORY,ORYT S ORIGVIEW=1 D TEXT^ORQ12(.ORYT,+ORIFN_";"_+$P(OR3,U,7),80) ;CurrTx + M @ORY=ORYT ;Move text to global + S I=0 F CNT=1:1 S I=$O(ORYT(I)) Q:I'>0 D:$D(IORVON) SETVIDEO(I,1,$L(ORYT(I)),IORVON,IORVOFF) + S CNT=CNT+1,@ORY@(CNT)=" " ;blank +D1 I $O(^OR(100,+ORIFN,2,0)) D + . S CNT=CNT+1,@ORY@(CNT)="Sub Orders:" + . D:$D(IOUON) SETVIDEO(CNT,1,11,IOUON,IOUOFF) + . N IFN S IFN=0 + . F S IFN=+$O(^OR(100,+ORIFN,2,IFN)) Q:IFN<1 I $D(^OR(100,IFN,0)) D SUB(IFN) + . S CNT=CNT+1,@ORY@(CNT)=" " ;blank + I $P(OR3,U,9),$D(^OR(100,+$P(OR3,U,9),0)) D + . S CNT=CNT+1,@ORY@(CNT)="Parent Order:" + . D:$D(IOUON) SETVIDEO(CNT,1,12,IOUON,IOUOFF) + . D SUB(+$P(OR3,U,9)) + . S CNT=CNT+1,@ORY@(CNT)=" " ;blank + I $P(OR3,U,11)=1,$P(OR3,U,5) D ;Changed - show previous order + . S CNT=CNT+1,@ORY@(CNT)="Previous Order:" + . D:$D(IOUON) SETVIDEO(CNT,1,15,IOUON,IOUOFF) ;prev order original text + . N ORZ,I,ORIGVIEW S ORIGVIEW=2 D TEXT^ORQ12(.ORZ,+$P(OR3,U,5),55) + . S CNT=CNT+1,@ORY@(CNT)=" Order Text: "_$G(ORZ(1)) + . S I=1 F S I=$O(ORZ(I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=$$REPEAT^XLFSTR(" ",24)_$G(ORZ(I)) +D2 S CNT=CNT+1,@ORY@(CNT)="Activity:" + D:$D(IOUON) SETVIDEO(CNT,1,9,IOUON,IOUOFF) + S DIWL=1,DIWR=64,DIWF="C64",ORI=0 K ^UTILITY($J,"W") + F S ORI=$O(^OR(100,ORIFN,8,ORI)) Q:ORI'>0 S ACTION=$G(^(ORI,0)) D ACT^ORQ20 + I "^1^12^13^"[(U_$P(OR3,U,3)_U),$L(OR6),$P(ACTION,U,2)'="DC" D DC^ORQ20 + I $P(OR3,U,3)=2,$P(OR6,U,6) S CNT=CNT+1,@ORY@(CNT)=$$DATE^ORQ20($P(OR6,U,6))_" Completed"_$S($P(OR6,U,7):" by "_$$USER^ORQ20($P(OR6,U,7)),1:"") + S CNT=CNT+1,@ORY@(CNT)=" " ;blank +D3 S CNT=CNT+1,@ORY@(CNT)="Current Data:" + D:$D(IOUON) SETVIDEO(CNT,1,13,IOUON,IOUOFF) + D VA I $G(VAIN(2)) S CNT=CNT+1,@ORY@(CNT)="Current Primary Provider: "_$P(VAIN(2),"^",2) + I $G(VAIN(11)) S CNT=CNT+1,@ORY@(CNT)="Current Attending Physician: "_$P(VAIN(11),"^",2) + S CNT=CNT+1,@ORY@(CNT)="Treating Specialty: "_$P($G(^DIC(45.7,+$P(OR0,U,13),0)),U) + S CNT=CNT+1,@ORY@(CNT)="Ordering Location: "_$P($G(^SC(+$P(OR0,U,10),0)),U) + S CNT=CNT+1,@ORY@(CNT)="Start Date/Time: "_$S($P(OR0,U,8):$$DATE^ORQ20($P(OR0,U,8)),1:"") + I $P(OR3,U,5),$P(OR3,U,11)=2 S X=$$ORIG(ORIFN),@ORY@(CNT)=@ORY@(CNT)_" (originally "_$$DATE^ORQ20(X)_")" + S CNT=CNT+1,@ORY@(CNT)="Stop Date/Time: "_$S($P(OR0,U,9):$$DATE^ORQ20($P(OR0,U,9)),1:"") + S CNT=CNT+1,@ORY@(CNT)="Current Status: "_$S($D(^ORD(100.01,+$P(OR3,U,3),0)):$P(^(0),"^"),1:"-") + I $$GET^XPAR("ALL","ORPF SHOW STATUS DESCRIPTION",1,"I"),$P(OR3,U,3),$D(^ORD(100.01,$P(OR3,U,3),0)) N J S J=0 F S J=$O(^ORD(100.01,$P(OR3,U,3),1,J)) Q:J<1 S CNT=CNT+1,@ORY@(CNT)=" "_^(J,0) + S CNT=CNT+1,@ORY@(CNT)="Order #"_ORIFN + S CNT=CNT+1,@ORY@(CNT)=" " ;blank +D4 S CNT=CNT+1,@ORY@(CNT)="Order:" D:$D(IOUON) SETVIDEO(CNT,1,6,IOUON,IOUOFF) + S ORNMSP=$$NMSP^ORCD($P(OR0,U,14)) + I '$O(^OR(100,ORIFN,4.5,0)),ORNMSP="RA" D RAD^ORQ21("") Q + S ORDIALOG=$P(OR0,U,5) Q:$P(ORDIALOG,";",2)="ORD(101," ; 2.5 order + D GETDLG^ORCD(+ORDIALOG),GETORDER^ORCD(ORIFN) + S DIWL=1,DIWR=50,DIWF="C50" + S SEQ=0 F S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ)) Q:SEQ'>0 S DA=0 F S DA=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ,DA)) Q:'DA D + . S ITEM=$G(^ORD(101.41,+ORDIALOG,10,DA,0)) Q:$P(ITEM,U,11) ; child + . S PRMT=$P(ITEM,U,2),MULT=$P(ITEM,U,7) Q:$P(ITEM,U,9)["*" ;hide + . S FIRST=$O(ORDIALOG(PRMT,0)) Q:'FIRST ; no values + . S TITLE=$S(MULT&$L($G(ORDIALOG(PRMT,"TTL"))):ORDIALOG(PRMT,"TTL"),1:ORDIALOG(PRMT,"A")) + . S TITLE=TITLE_$$REPEAT^XLFSTR(" ",30-$L(TITLE)) + . S INST=0 F S INST=$O(ORDIALOG(PRMT,INST)) Q:INST'>0 D + . . I $E(ORDIALOG(PRMT,0))="W" D WP Q + . . K ^UTILITY($J,"W") S X=$$EXT^ORCD(PRMT,INST) D ^DIWP + . . D:$D(^ORD(101.41,+ORDIALOG,10,"DAD",PRMT)) CHILDREN(PRMT) + . . S I=0 F S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=$S((INST=FIRST)&(I=1):TITLE,1:$$REPEAT^XLFSTR(" ",30))_^(I,0) + I ORNMSP="GMRC",$G(^OR(100,ORIFN,4)) S CNT=CNT+1,@ORY@(CNT)="Consult No.: "_+^(4) + S CNT=CNT+1,@ORY@(CNT)=" " ;blank + D RAD^ORQ21(1):ORNMSP="RA",MED^ORQ21:ORNMSP="PS" ;add'l data + D BA^ORQ21 ;call for CIDC data +D5 I $O(^OR(100,+ORIFN,9,0)) D + . N CK,OK,X0,X,CDL,I S CNT=CNT+1,@ORY@(CNT)="Order Checks:" + . D:$D(IOUON) SETVIDEO(CNT,1,13,IOUON,IOUOFF) + . S CK=0 F S CK=$O(^OR(100,+ORIFN,9,CK)) Q:CK'>0 S X0=$G(^(CK,0)),X=$G(^(1)) D + .. S CDL=$$CDL($P(X0,U,2)) I $P(X0,U,6),'$D(OK) S OK=$P(X0,U,4,6) + .. I $L(X)'>68 S CNT=CNT+1,@ORY@(CNT)=CDL_X Q + .. S DIWL=1,DIWR=68,DIWF="C68" K ^UTILITY($J,"W") D ^DIWP + .. S I=0 F S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=CDL_^(I,0),CDL=" " + . Q:'$L($G(OK)) S CNT=CNT+1,@ORY@(CNT)="Override: "_$S($P(OK,U,2):$$USER^ORQ20($P(OK,U,2))_" on ",1:"")_$$DATE^ORQ20($P(OK,U,3)) + . I $L($P(OK,U))'>68 S CNT=CNT+1,@ORY@(CNT)=" "_$P(OK,U) Q + . S DIWL=1,DIWR=68,DIWF="C68",X=$P(OK,U) K ^UTILITY($J,"W") D ^DIWP + . S I=0 F S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=" "_^(I,0) + K ^TMP("ORWORD",$J),^UTILITY($J,"W") + Q + ; +SUB(IFN) ; -- add suborder or parent + N ORCY,STS,STRT,IG D TEXT^ORQ12(.ORCY,IFN,58) + S STS=$G(^ORD(100.01,+$P($G(^OR(100,IFN,3)),U,3),.1)) + S STRT=$P(^OR(100,IFN,0),U,8) S:STRT'="" STRT=$$DATE^ORQ20(STRT) + S IG=0 F S IG=$O(ORCY(IG)) Q:IG<1 S CNT=CNT+1,@ORY@(CNT)=$J(STS,4)_" "_ORCY(IG)_" "_STRT,(STS,STRT)=" " + Q + ; +WP ; -- add word-processing + N WP,ORI,X M WP=@ORDIALOG(PRMT,INST) + S CNT=CNT+1,@ORY@(CNT)=TITLE + S ORI=0 F S ORI=$O(WP(ORI)) Q:ORI'>0 S X=WP(ORI,0) S:X'="" CNT=CNT+1,@ORY@(CNT)=" "_X + Q + ; +CHILDREN(PARENT) ; -- add children + N SEQ,DA,ITM,PRMT,TYPE,X + S SEQ=0 F S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PARENT,SEQ)) Q:SEQ'>0 S DA=$O(^(SEQ,0)) D + . S ITM=$G(^ORD(101.41,+ORDIALOG,10,DA,0)),PRMT=$P(ITM,U,2) + . Q:$G(ORDIALOG(PRMT,INST))="" Q:$P(ITM,U,9)["*" ;no value or hide + . S TYPE=$E(ORDIALOG(PRMT,0)) D:TYPE="W" WP + . I TYPE'="W" S X=$$EXT^ORCD(PRMT,INST) D ^DIWP + Q + ; +SETVIDEO(LINE,COL,WIDTH,ON,OFF) ; -- set video attributes + S ORY("VIDEO",LINE,COL,WIDTH)=ON + S ORY("VIDEO",LINE,COL+WIDTH,0)=OFF + Q + ; +VA ; -- Call VADPT + N ORY,DFN,Y S DFN=+$P(OR0,"^",2) D OERR^VADPT + Q + ; +CDL(X) ; -- Returns Clinical Danger Level X + N Y S Y=$S(X=1:"HIGH:",X=2:"MODERATE:",X=3:"LOW:",1:"NONE:") + S Y=$E(Y_" ",1,12) + Q Y + ; +ORIG(IFN) ; -- Return original start date of [renewal] order + N I,Y,X3,DONE + S I=IFN,Y=$P($G(^OR(100,IFN,0)),U,8),DONE=0 + F S X3=$G(^OR(100,I,3)) D Q:DONE + . I $P(X3,U,11)=2,$P(X3,U,5) S I=$P(X3,U,5) Q ;loop + . S Y=$P($G(^OR(100,I,0)),U,8),DONE=1 + Q Y diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQ20.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQ20.m index d7e76b61..3ef414fd 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQ20.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQ20.m @@ -1,133 +1,125 @@ -ORQ20 ; SLC/MKB - Detailed Order Report cont ;3/6/08 10:25 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**12,27,92,94,116,141,177,186,190,215,243**;Dec 17, 1997;Build 242 -ACT ; -- add Activity [from ^ORQ2] - N ORACT S ORACT=$P(ACTION,U,2) - I ORACT'="NW",$P(ACTION,U,4)=5,$P(ACTION,U,15)=13 Q ;skip canc actions - N NVA,USER S:$P(^ORD(100.98,$P(^OR(100,+ORIFN,0),U,11),0),U)="NON-VA MEDICATIONS" NVA=1 - S CNT=CNT+1,@ORY@(CNT)=$$DATE($P(ACTION,U))_" "_$$ACTION(ORACT) - I $P(ACTION,U,13) S @ORY@(CNT)=@ORY@(CNT)_" entered by "_$$USER(+$P(ACTION,U,13)) - I ORACT="NW" D ;Show original order text - . N ORZ,I,ORIGVIEW S ORIGVIEW=2 D TEXT^ORQ12(.ORZ,ORIFN_";1",80) - . S CNT=CNT+1,@ORY@(CNT)=" Order Text: "_$G(ORZ(1)) - . S I=1 F S I=$O(ORZ(I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=$$REPEAT^XLFSTR(" ",24)_$G(ORZ(I)) - I ORACT="XX" D ;Changed - show new text - . N ORZ,I,ORIGVIEW S ORIGVIEW=2 D TEXT^ORQ12(.ORZ,ORIFN_";"_ORI,80) - . S CNT=CNT+1,@ORY@(CNT)=" Changed to: "_$G(ORZ(1)) - . S I=1 F S I=$O(ORZ(I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=$$REPEAT^XLFSTR(" ",24)_$G(ORZ(I)) -A1 I $P(ACTION,U,12) D ;Nature of Order/Release - . N ORZ S ORZ=$G(^ORD(100.02,+$P(ACTION,U,12),0)) - . S CNT=CNT+1,@ORY@(CNT)=" Nature of Order: "_$P(ORZ,U) - . I $P(OR0,U,17),(ORACT="NW") Q ;see event - . I "^V^P^"[(U_$P(ORZ,U,2)_U),$P(ACTION,U,16) S CNT=CNT+1,@ORY@(CNT)=" Released by: "_$$USER(+$P(ACTION,U,17))_" on "_$$DATE($P(ACTION,U,16)) - I $P(OR0,U,17)&(ORACT="NW") D ;Delayed Release Event - . N EVT,X,ORV,I S EVT=+$P(OR0,U,17),X=$$NAME^OREVNTX(EVT) - . S:$E(X,1,8)="Delayed " X=$E(X,9,99) - . I $G(^ORE(100.2,EVT,1)),'$P(ACTION,U,16) S X=X_" on "_$$DATE(+^(1)) - . S CNT=CNT+1,@ORY@(CNT)=" Delayed Until: "_X Q:'$P(ACTION,U,16) - . D EVENT(.ORV) S CNT=CNT+1,@ORY@(CNT)=" Released by: "_ORV(1) - . S I=1 F S I=$O(ORV(I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=$$REPEAT^XLFSTR(" ",24)_$G(ORV(I)) -A2 I $P(ACTION,U,5) S CNT=CNT+1,@ORY@(CNT)=$S($P(ACTION,U,4)=7:" Dig",1:" Elec")_" Signature: "_$$USER(+$P(ACTION,U,5))_" on "_$$DATE($P(ACTION,U,6)) - I '$P(ACTION,U,5)!($P(ACTION,U,3)'=$P(ACTION,U,5)),'$$SERVCORR S CNT=CNT+1,@ORY@(CNT)=" "_$S($D(NVA):"Documented by:",1:"Ordered by: ")_" "_$$USER(+$P(ACTION,U,3)) - I '$P(ACTION,U,5),$L($P(ACTION,U,4)) D - .I $P(ACTION,U,4)=0 D - ..S USER=$$USER(+$P(ACTION,U,7)) - ..S CNT=CNT+1 - ..I USER'="" S @ORY@(CNT)=" Released by: "_USER_" on "_$$DATE($P(ACTION,U,16)) - ..I USER="" S @ORY@(CNT)=" Released: "_$$DATE($P(ACTION,U,16)) - .S CNT=CNT+1,@ORY@(CNT)=" Signature: "_$$SIG($P(ACTION,U,4)) ;186 - ;I '$P(ACTION,U,5),$L($P(ACTION,U,4)) S:$P(ACTION,U,4)=0 CNT=CNT+1,@ORY@(CNT)=" Released by: "_$$USER(+$P(ACTION,U,7))_" on "_$$DATE($P(ACTION,U,16)) S CNT=CNT+1,@ORY@(CNT)=" Signature: "_$$SIG($P(ACTION,U,4)) ;186 - I $P(ACTION,U,9) S CNT=CNT+1,@ORY@(CNT)=" Nurse Verified: "_$S($P(ACTION,U,8):$$USER(+$P(ACTION,U,8))_" on ",1:"")_$$DATE($P(ACTION,U,9)) - I $P(ACTION,U,11) S CNT=CNT+1,@ORY@(CNT)=" Clerk Verified: "_$S($P(ACTION,U,10):$$USER(+$P(ACTION,U,10))_" on ",1:"")_$$DATE($P(ACTION,U,11)) - I $P(ACTION,U,19) S CNT=CNT+1,@ORY@(CNT)=" Chart Reviewed: "_$S($P(ACTION,U,18):$$USER(+$P(ACTION,U,18))_" on ",1:"")_$$DATE($P(ACTION,U,19)) -A3 I $P(ACTION,U,2)="DC",$L(OR6) S X=$S($L($P(OR6,U,5)):$P(OR6,U,5),$P(OR6,U,4):$P($G(^ORD(100.03,+$P(OR6,U,4),0)),U),$P(OR6,U):$P($G(^ORD(100.02,+$P(OR6,U),0)),U),1:"") S:$L(X) CNT=CNT+1,@ORY@(CNT)=" Reason for DC: "_X - I $L($G(^OR(100,ORIFN,8,ORI,1))) S X=^(1) D ;add backdoor comments - . N LBL,I S LBL="" - . I $P(ACTION,U,15)="",$P(ACTION,U,2)'="DC" S LBL=" Comments: " ;DC shown above - . I $P(ACTION,U,15)=13,$P(ACTION,U,2)'="NW" S LBL=" Cancelled: " ;NW shown in ORQ2 - . Q:'$L(LBL) I $L(X)'>56 S CNT=CNT+1,@ORY@(CNT)=LBL_X Q - . S DIWL=1,DIWR=56,DIWF="C56" K ^UTILITY($J,"W") D ^DIWP - . S I=0 F S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=LBL_^(I,0),LBL=" " - I $D(^OR(100,ORIFN,8,ORI,5)) D ;Ward comments - . N X,ORJ K ^UTILITY($J,"W") - . S ORJ=0 F S ORJ=$O(^OR(100,ORIFN,8,ORI,5,ORJ)) Q:ORJ'>0 S X=^(ORJ,0) D ^DIWP - . S ORJ=0 F S ORJ=$O(^UTILITY($J,"W",DIWL,ORJ)) Q:ORJ'>0 S CNT=CNT+1,@ORY@(CNT)=$S(ORJ=1:" Ward/Clinic Cmmts: ",1:" ")_^(ORJ,0) - . K ^UTILITY($J,"W") -A4 I $P(ACTION,U,2)="HD",$G(^OR(100,ORIFN,8,ORI,2)) S X2=^(2),CNT=CNT+1,@ORY@(CNT)=" Hold Released: "_$$FMTE^XLFDT($P(X2,U),"2P")_" by "_$$USER($P(X2,U,2)) - I $D(^OR(100,ORIFN,8,ORI,3)) D ;Un-/Flagged - . N X S X=$G(^OR(100,ORIFN,8,ORI,3)) - . S CNT=CNT+1,@ORY@(CNT)=" Flagged by: "_$$USER(+$P(X,U,4))_" on "_$$DATE($P(X,U,3)) - . S CNT=CNT+1,@ORY@(CNT)=" "_$P(X,U,5) - . Q:X S CNT=CNT+1,@ORY@(CNT)=" Unflagged by: "_$$USER(+$P(X,U,7))_" on "_$$DATE($P(X,U,6)) - . S CNT=CNT+1,@ORY@(CNT)=" "_$P(X,U,8) - Q - ; -DC ; -- Add Reason for DC - S CNT=CNT+1,@ORY@(CNT)=$$DATE($P(OR6,U,3))_$S($P(OR6,U,8):" Auto-",1:" ")_"Discontinued" - I $P(OR6,U,8) D Q - . N EVT,PKG,ORV,I - . S EVT=$P(OR6,U,8),PKG=$P($G(^ORE(100.2,+EVT,3,ORIFN,0)),U,2) - . S @ORY@(CNT)=@ORY@(CNT)_" by "_$S(PKG="FH":"DIETETICS",PKG="LR":"LABORATORY",PKG="PS":"PHARMACY",1:"CPRS") - . D EVENT(.ORV,1) S CNT=CNT+1,@ORY@(CNT)=" Patient Movement: "_ORV(1) - . S I=1 F S I=$O(ORV(I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=$$REPEAT^XLFSTR(" ",24)_$G(ORV(I)) - I $P(OR6,U,2),$P($G(^ORD(100.02,+$P(OR6,U),0)),U,2)'="A" S @ORY@(CNT)=@ORY@(CNT)_" by "_$$USER($P(OR6,U,2)) ;don't show user name if auto-dc - N X S X=$S($L($P(OR6,U,5)):$P(OR6,U,5),$P(OR6,U,4):$P($G(^ORD(100.03,+$P(OR6,U,4),0)),U),$P(OR6,U):$P($G(^ORD(100.02,+$P(OR6,U),0)),U),1:"") S:$L(X) CNT=CNT+1,@ORY@(CNT)=" Reason for DC: "_X - Q - ; -ACTION(CODE) ; -- Return name of action CODE - N NAME S NAME=$S(CODE="NW":"New Order",CODE="DC":"Discontinue",CODE="HD":"Hold",CODE="RL":"Release Hold",CODE="RN":"Renewal",CODE="XX":"Change",1:"") - I CODE="NW",$P(OR3,U,11) S NAME=NAME_$S($P(OR3,U,11)=1:" (Change)",$P(OR3,U,11)=2:" (Renewal)",1:"") - Q NAME - ; -XACT(X) ; -- Return name of transaction code X - N Y S X=$G(X) - S Y=$S(X="XX":"Edited",X="DC":"Discontinued",X="HD":"Held",X="RL":"Hold Released",X="FW":"Forwarded",X="CA":"Cancelled",1:"") - Q Y - ; -DATE(X) ; -- Return date formatted as 00/00/0000 00:00 - N T,Y S T=$P(X,".",2)_"0000" - S Y=$E(X,4,5)_"/"_$E(X,6,7)_"/"_(1700+$E(X,1,3)) - I T S Y=Y_" "_$E(T,1,2)_":"_$E(T,3,4) - Q Y - ; -USER(X) ; -- Returns NAME (TITLE) of New Person X - N X0,Y S X0=$G(^VA(200,+X,0)),Y=$P(X0,U) - S:$P(X0,U,9) Y=Y_" ("_$E($P($G(^DIC(3.1,+$P(X0,U,9),0)),U),1,15)_")" - Q Y - ; -SIG(X) ; -- Returns text of signature status X - N Y S Y="" - I X=0 S Y="ON CHART WITH WRITTEN ORDERS" - I X=1 S Y="ELECTRONICALLY SIGNED" - I X=2 S Y="NOT SIGNED" - I X=3 S Y="NOT REQUIRED" - I X=4 S Y="ON CHART WITH PRINTED ORDERS" - I X=5 S Y="NOT REQUIRED DUE TO SERVICE CANCEL/LAPSE" - I X=6 S Y="SERVICE CORRECTION TO SIGNED ORDER" - Q Y - ; -SERVCORR() ; -- Returns 1 or 0, if current ACTION is a serv corr change - N Y,NATURE,I,X S Y=0 - G:ORACT'="XX" SCQ - S NATURE=+$P(ACTION,U,12),NATURE=$P($G(^ORD(100.02,NATURE,0)),U,2) - I "^S^I^"'[(U_NATURE_U) G SCQ - S I=$O(^OR(100,ORIFN,8,ORI),-1),X=$G(^(I,0)) - I $P(X,U,3)'=$P(ACTION,U,3),$P(X,U,5)'=$P(ACTION,U,3) G SCQ ;show prov - S Y=1 -SCQ Q Y - ; -EVENT(ORTX,DC) ; -- Returns patient event info for EVT - N EVT1,REL,X,Y,I,ORMAX - S ORTX(1)="" ;177 - S EVT1=$G(^ORE(100.2,EVT,1)),REL=$G(^ORE(100.2,EVT,2,ORIFN,0)) - ; Return event data if AutoDC or auto-released by an event: - I $G(DC)!(REL&'$L($P(REL,U,2))&($P(EVT1,U,2)!$P(EVT1,U,4))) D Q - . S Y=$S($P(EVT1,U,5):$P(EVT1,U,5),1:EVT) ;parent owns Activity - . S Y=+$O(^ORE(100.2,+Y,10,0)),Y=$G(^(Y,0)),X=$P(Y,U,4) Q:'$L(X) - . S X=$S(X="A":"ADMISSION",X="T":"TRANSFER",X="D":"DISCHARGE",X="S":"SPECIALTY CHANGE",1:$S($P(EVT1,U)>$$DPI^ORUTL1("SR*3.0*157"):"IN TO O.R.",1:"OUT OF O.R."))_" on "_$$DATE($P(EVT1,U)) ;243 - . S ORTX(1)=X,ORTX=1,ORMAX=56 - . I $P(Y,U,6) S X=$S($P(Y,U,4)="D":"from ",1:"to ")_$$GET1^DIQ(45.7,+$P(Y,U,6)_",",.01) D TXT^ORCHTAB - . I $P(Y,U,7) S X="on "_$$GET1^DIQ(42,+$P(Y,U,7)_",",.01) D TXT^ORCHTAB - S X=$$USER(+$P(ACTION,U,17))_" on "_$$DATE($P(ACTION,U,16)) - I ORIFN'=+$P($G(^ORE(100.2,EVT,0)),U,4),$P(REL,U,2)="MN" S X=X_" (manually released)" - S ORTX(1)=X - Q +ORQ20 ; SLC/MKB - Detailed Order Report cont ;7/23/03 12:29 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**12,27,92,94,116,141,177,186,190,215**;Dec 17, 1997 +ACT ; -- add Activity [from ^ORQ2] + N ORACT S ORACT=$P(ACTION,U,2) + N NVA S:$P(^ORD(100.98,$P(^OR(100,+ORIFN,0),U,11),0),U)="NON-VA MEDICATIONS" NVA=1 + S CNT=CNT+1,@ORY@(CNT)=$$DATE($P(ACTION,U))_" "_$$ACTION(ORACT) + I $P(ACTION,U,13) S @ORY@(CNT)=@ORY@(CNT)_" entered by "_$$USER(+$P(ACTION,U,13)) + I ORACT="NW" D ;Show original order text + . N ORZ,I,ORIGVIEW S ORIGVIEW=2 D TEXT^ORQ12(.ORZ,ORIFN_";1",80) + . S CNT=CNT+1,@ORY@(CNT)=" Order Text: "_$G(ORZ(1)) + . S I=1 F S I=$O(ORZ(I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=$$REPEAT^XLFSTR(" ",24)_$G(ORZ(I)) + I ORACT="XX" D ;Changed - show new text + . N ORZ,I,ORIGVIEW S ORIGVIEW=2 D TEXT^ORQ12(.ORZ,ORIFN_";"_ORI,80) + . S CNT=CNT+1,@ORY@(CNT)=" Changed to: "_$G(ORZ(1)) + . S I=1 F S I=$O(ORZ(I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=$$REPEAT^XLFSTR(" ",24)_$G(ORZ(I)) +A1 I $P(ACTION,U,12) D ;Nature of Order/Release + . N ORZ S ORZ=$G(^ORD(100.02,+$P(ACTION,U,12),0)) + . S CNT=CNT+1,@ORY@(CNT)=" Nature of Order: "_$P(ORZ,U) + . I $P(OR0,U,17),(ORACT="NW") Q ;see event + . I "^V^P^"[(U_$P(ORZ,U,2)_U),$P(ACTION,U,16) S CNT=CNT+1,@ORY@(CNT)=" Released by: "_$$USER(+$P(ACTION,U,17))_" on "_$$DATE($P(ACTION,U,16)) + I $P(OR0,U,17)&(ORACT="NW") D ;Delayed Release Event + . N EVT,X,ORV,I S EVT=+$P(OR0,U,17),X=$$NAME^OREVNTX(EVT) + . S:$E(X,1,8)="Delayed " X=$E(X,9,99) + . I $G(^ORE(100.2,EVT,1)),'$P(ACTION,U,16) S X=X_" on "_$$DATE(+^(1)) + . S CNT=CNT+1,@ORY@(CNT)=" Delayed Until: "_X Q:'$P(ACTION,U,16) + . D EVENT(.ORV) S CNT=CNT+1,@ORY@(CNT)=" Released by: "_ORV(1) + . S I=1 F S I=$O(ORV(I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=$$REPEAT^XLFSTR(" ",24)_$G(ORV(I)) +A2 I $P(ACTION,U,5) S CNT=CNT+1,@ORY@(CNT)=$S($P(ACTION,U,4)=7:" Dig",1:" Elec")_" Signature: "_$$USER(+$P(ACTION,U,5))_" on "_$$DATE($P(ACTION,U,6)) + I '$P(ACTION,U,5)!($P(ACTION,U,3)'=$P(ACTION,U,5)),'$$SERVCORR S CNT=CNT+1,@ORY@(CNT)=" "_$S($D(NVA):"Documented by:",1:"Ordered by: ")_" "_$$USER(+$P(ACTION,U,3)) + I '$P(ACTION,U,5),$L($P(ACTION,U,4)) S:$P(ACTION,U,4)=0 CNT=CNT+1,@ORY@(CNT)=" Released by: "_$$USER(+$P(ACTION,U,7))_" on "_$$DATE($P(ACTION,U,16)) S CNT=CNT+1,@ORY@(CNT)=" Signature: "_$$SIG($P(ACTION,U,4)) ;186 + I $P(ACTION,U,9) S CNT=CNT+1,@ORY@(CNT)=" Nurse Verified: "_$S($P(ACTION,U,8):$$USER(+$P(ACTION,U,8))_" on ",1:"")_$$DATE($P(ACTION,U,9)) + I $P(ACTION,U,11) S CNT=CNT+1,@ORY@(CNT)=" Clerk Verified: "_$S($P(ACTION,U,10):$$USER(+$P(ACTION,U,10))_" on ",1:"")_$$DATE($P(ACTION,U,11)) + I $P(ACTION,U,19) S CNT=CNT+1,@ORY@(CNT)=" Chart Reviewed: "_$S($P(ACTION,U,18):$$USER(+$P(ACTION,U,18))_" on ",1:"")_$$DATE($P(ACTION,U,19)) +A3 I $P(ACTION,U,2)="DC",$L(OR6) S X=$S($L($P(OR6,U,5)):$P(OR6,U,5),$P(OR6,U,4):$P($G(^ORD(100.03,+$P(OR6,U,4),0)),U),$P(OR6,U):$P($G(^ORD(100.02,+$P(OR6,U),0)),U),1:"") S:$L(X) CNT=CNT+1,@ORY@(CNT)=" Reason for DC: "_X + I $L($G(^OR(100,ORIFN,8,ORI,1))) S X=^(1) D ;add backdoor comments + . N LBL,I S LBL="" + . I $P(ACTION,U,15)="",$P(ACTION,U,2)'="DC" S LBL=" Comments: " ;DC shown above + . I $P(ACTION,U,15)=13,$P(ACTION,U,2)'="NW" S LBL=" Cancelled: " ;NW shown in ORQ2 + . Q:'$L(LBL) I $L(X)'>56 S CNT=CNT+1,@ORY@(CNT)=LBL_X Q + . S DIWL=1,DIWR=56,DIWF="C56" K ^UTILITY($J,"W") D ^DIWP + . S I=0 F S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=LBL_^(I,0),LBL=" " + I $D(^OR(100,ORIFN,8,ORI,5)) D ;Ward comments + . N X,ORJ K ^UTILITY($J,"W") + . S ORJ=0 F S ORJ=$O(^OR(100,ORIFN,8,ORI,5,ORJ)) Q:ORJ'>0 S X=^(ORJ,0) D ^DIWP + . S ORJ=0 F S ORJ=$O(^UTILITY($J,"W",DIWL,ORJ)) Q:ORJ'>0 S CNT=CNT+1,@ORY@(CNT)=$S(ORJ=1:" Ward/Clinic Cmmts: ",1:" ")_^(ORJ,0) + . K ^UTILITY($J,"W") +A4 I $P(ACTION,U,2)="HD",$G(^OR(100,ORIFN,8,ORI,2)) S X2=^(2),CNT=CNT+1,@ORY@(CNT)=" Hold Released: "_$$FMTE^XLFDT($P(X2,U),"2P")_" by "_$$USER($P(X2,U,2)) + I $D(^OR(100,ORIFN,8,ORI,3)) D ;Un-/Flagged + . N X S X=$G(^OR(100,ORIFN,8,ORI,3)) + . S CNT=CNT+1,@ORY@(CNT)=" Flagged by: "_$$USER(+$P(X,U,4))_" on "_$$DATE($P(X,U,3)) + . S CNT=CNT+1,@ORY@(CNT)=" "_$P(X,U,5) + . Q:X S CNT=CNT+1,@ORY@(CNT)=" Unflagged by: "_$$USER(+$P(X,U,7))_" on "_$$DATE($P(X,U,6)) + . S CNT=CNT+1,@ORY@(CNT)=" "_$P(X,U,8) + Q + ; +DC ; -- Add Reason for DC + S CNT=CNT+1,@ORY@(CNT)=$$DATE($P(OR6,U,3))_$S($P(OR6,U,8):" Auto-",1:" ")_"Discontinued" + I $P(OR6,U,8) D Q + . N EVT,PKG,ORV,I + . S EVT=$P(OR6,U,8),PKG=$P($G(^ORE(100.2,+EVT,3,ORIFN,0)),U,2) + . S @ORY@(CNT)=@ORY@(CNT)_" by "_$S(PKG="FH":"DIETETICS",PKG="LR":"LABORATORY",PKG="PS":"PHARMACY",1:"CPRS") + . D EVENT(.ORV,1) S CNT=CNT+1,@ORY@(CNT)=" Patient Movement: "_ORV(1) + . S I=1 F S I=$O(ORV(I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=$$REPEAT^XLFSTR(" ",24)_$G(ORV(I)) + I $P(OR6,U,2),$P($G(^ORD(100.02,+$P(OR6,U),0)),U,2)'="A" S @ORY@(CNT)=@ORY@(CNT)_" by "_$$USER($P(OR6,U,2)) ;don't show user name if auto-dc + N X S X=$S($L($P(OR6,U,5)):$P(OR6,U,5),$P(OR6,U,4):$P($G(^ORD(100.03,+$P(OR6,U,4),0)),U),$P(OR6,U):$P($G(^ORD(100.02,+$P(OR6,U),0)),U),1:"") S:$L(X) CNT=CNT+1,@ORY@(CNT)=" Reason for DC: "_X + Q + ; +ACTION(CODE) ; -- Return name of action CODE + N NAME S NAME=$S(CODE="NW":"New Order",CODE="DC":"Discontinue",CODE="HD":"Hold",CODE="RL":"Release Hold",CODE="RN":"Renewal",CODE="XX":"Change",1:"") + I CODE="NW",$P(OR3,U,11) S NAME=NAME_$S($P(OR3,U,11)=1:" (Change)",$P(OR3,U,11)=2:" (Renewal)",1:"") + Q NAME + ; +XACT(X) ; -- Return name of transaction code X + N Y S X=$G(X) + S Y=$S(X="XX":"Edited",X="DC":"Discontinued",X="HD":"Held",X="RL":"Hold Released",X="FW":"Forwarded",X="CA":"Cancelled",1:"") + Q Y + ; +DATE(X) ; -- Return date formatted as 00/00/0000 00:00 + N T,Y S T=$P(X,".",2)_"0000" + S Y=$E(X,4,5)_"/"_$E(X,6,7)_"/"_(1700+$E(X,1,3)) + I T S Y=Y_" "_$E(T,1,2)_":"_$E(T,3,4) + Q Y + ; +USER(X) ; -- Returns NAME (TITLE) of New Person X + N X0,Y S X0=$G(^VA(200,+X,0)),Y=$P(X0,U) + S:$P(X0,U,9) Y=Y_" ("_$E($P($G(^DIC(3.1,+$P(X0,U,9),0)),U),1,15)_")" + Q Y + ; +SIG(X) ; -- Returns text of signature status X + N Y S Y="" + I X=0 S Y="ON CHART WITH WRITTEN ORDERS" + I X=1 S Y="ELECTRONICALLY SIGNED" + I X=2 S Y="NOT SIGNED" + I X=3 S Y="NOT REQUIRED" + I X=4 S Y="ON CHART WITH PRINTED ORDERS" + I X=5 S Y="NOT REQUIRED DUE TO SERVICE CANCEL" + I X=6 S Y="SERVICE CORRECTION TO SIGNED ORDER" + Q Y + ; +SERVCORR() ; -- Returns 1 or 0, if current ACTION is a serv corr change + N Y,NATURE,I,X S Y=0 + G:ORACT'="XX" SCQ + S NATURE=+$P(ACTION,U,12),NATURE=$P($G(^ORD(100.02,NATURE,0)),U,2) + I "^S^I^"'[(U_NATURE_U) G SCQ + S I=$O(^OR(100,ORIFN,8,ORI),-1),X=$G(^(I,0)) + I $P(X,U,3)'=$P(ACTION,U,3),$P(X,U,5)'=$P(ACTION,U,3) G SCQ ;show prov + S Y=1 +SCQ Q Y + ; +EVENT(ORTX,DC) ; -- Returns patient event info for EVT + N EVT1,REL,X,Y,I,ORMAX + S ORTX(1)="" ;177 + S EVT1=$G(^ORE(100.2,EVT,1)),REL=$G(^ORE(100.2,EVT,2,ORIFN,0)) + ; Return event data if AutoDC or auto-released by an event: + I $G(DC)!(REL&'$L($P(REL,U,2))&($P(EVT1,U,2)!$P(EVT1,U,4))) D Q + . S Y=$S($P(EVT1,U,5):$P(EVT1,U,5),1:EVT) ;parent owns Activity + . S Y=+$O(^ORE(100.2,+Y,10,0)),Y=$G(^(Y,0)),X=$P(Y,U,4) Q:'$L(X) + . S X=$S(X="A":"ADMISSION",X="T":"TRANSFER",X="D":"DISCHARGE",X="S":"SPECIALTY CHANGE",1:"OUT OF O.R.")_" on "_$$DATE($P(EVT1,U)) + . S ORTX(1)=X,ORTX=1,ORMAX=56 + . I $P(Y,U,6) S X=$S($P(Y,U,4)="D":"from ",1:"to ")_$$GET1^DIQ(45.7,+$P(Y,U,6)_",",.01) D TXT^ORCHTAB + . I $P(Y,U,7) S X="on "_$$GET1^DIQ(42,+$P(Y,U,7)_",",.01) D TXT^ORCHTAB + S X=$$USER(+$P(ACTION,U,17))_" on "_$$DATE($P(ACTION,U,16)) + I ORIFN'=+$P($G(^ORE(100.2,EVT,0)),U,4),$P(REL,U,2)="MN" S X=X_" (manually released)" + S ORTX(1)=X + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQ21.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQ21.m index 846da653..3aeff253 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQ21.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQ21.m @@ -1,133 +1,118 @@ -ORQ21 ; SLC/MKB/GSS - Detailed Order Report cont ; 12/28/2006 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141,190,195,215,243**;Dec 17, 1997;Build 242 - ; - ; DBIA 2400 OEL^PSOORRL ^TMP("PS",$J) - ; DBIA 2266 EN30^RAO7PC1 ^TMP($J,"RAE2") - ; -RAD(TCOM) ; -- add RA data for 2.5 orders - N RAIFN,CASE,PROC,ORD,ORI,X,ORTTL,ORB - S RAIFN=$G(^OR(100,ORIFN,4)) Q:RAIFN'>0 - D EN30^RAO7PC1(RAIFN) Q:'$D(^TMP($J,"RAE2",+ORVP)) ;DBIA 2266 - S ORD=$G(^TMP($J,"RAE2",+ORVP,"ORD")),CASE=$O(^(0)) Q:'CASE S PROC=$O(^(CASE,"")) - I '$G(TCOM) D ;else add only Tech Comments - . S CNT=CNT+1,@ORY@(CNT)=$$LJ^XLFSTR("Procedure:",30)_$S($L(ORD):ORD,1:PROC) - . S ORI=0,ORTTL="Procedure Modifiers: ",ORB=1 - . F S ORI=$O(^TMP($J,"RAE2",+ORVP,CASE,PROC,"M",ORI)) Q:ORI'>0 S CNT=CNT+1,@ORY@(CNT)=ORTTL_^(ORI),ORTTL=$$REPEAT^XLFSTR(" ",30) - . S CNT=CNT+1,@ORY@(CNT)="History and Reason for Exam:" - . F S ORI=$O(^TMP($J,"RAE2",+ORVP,CASE,PROC,"H",ORI)) Q:ORI'>0 S CNT=CNT+1,@ORY@(CNT)=" "_^(ORI) -RAD1 I $L($G(^TMP($J,"RAE2",+ORVP,CASE,PROC,"TCOM",1))) S X=^(1) D - . N DIWL,DIWR,DIWF,I K ^UTILITY($J,"W") - . S DIWL=1,DIWR=72,DIWF="C72" D ^DIWP - . S CNT=CNT+1,@ORY@(CNT)="Technologist's Comment:",ORB=1 - . S I=0 F S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=" "_^(I,0) - I $D(^TMP($J,"RAE2",+ORVP,CASE,PROC,"CM")) D - . S ORTTL="Contrast Media used: ",ORI=0,ORB=1 - . F S ORI=$O(^TMP($J,"RAE2",+ORVP,CASE,PROC,"CM",ORI)) Q:ORI<1 S CNT=CNT+1,@ORY@(CNT)=ORTTL_$P(^(ORI),U,2),ORTTL=$$REPEAT^XLFSTR(" ",30) - K ^TMP($J,"RAE2",+ORVP),^UTILITY($J,"W") - S:$G(ORB) CNT=CNT+1,@ORY@(CNT)=" " ;blank - Q - ; -MED ; -- Add Pharmacy order data - Q:$G(^OR(100,ORIFN,4))["N" ;non-VA med -- no refill history - N TYPE,NODE,RXN,OR5,STAT S TYPE=$P(OR0,U,12) - I '$D(^TMP("PS",$J,0)) D ;get PS data / DBIA 2400 - . N PSIFN S PSIFN=$G(^OR(100,ORIFN,4)) - . S:TYPE="O" PSIFN=$TR(PSIFN,"S","P")_$S(PSIFN?1.N:"R",1:"") - . D OEL^PSOORRL(+ORVP,PSIFN_";"_TYPE) ;DBIA 2400 - S NODE=$G(^TMP("PS",$J,0)),RXN=$G(^("RXN",0)),STAT=$P(NODE,U,6) - I '$L(NODE) K ^TMP("PS",$J) Q ;error - I $O(^TMP("PS",$J,"DD",0)) D ;Disp Drugs - . N I,X,Y S X="Dispense Drugs (units/dose): ",I=0 - . F S I=$O(^TMP("PS",$J,"DD",I)) Q:I'>0 S Y=$G(^(I,0)) S:Y CNT=CNT+1,@ORY@(CNT)=X_$$GET1^DIQ(50,+Y_",",.01)_" ("_$P(Y,U,2)_")" - S:$P(NODE,U,9) CNT=CNT+1,@ORY@(CNT)="Total Dose: "_$P(NODE,U,9) -M1 I TYPE="I" D ;admin data - . N I,X,Y I $O(^TMP("PS",$J,"B",0)) D - .. S X="IV Print Name: ",I=0 - .. F S I=$O(^TMP("PS",$J,"B",I)) Q:I<1 S Y=$G(^(I,0)) S:$L(Y) CNT=CNT+1,@ORY@(CNT)=X_$P(Y,U),X=$$REPEAT^XLFSTR(" ",30) I $L($P(Y,U,3)) S CNT=CNT+1,@ORY@(CNT)=X_" "_$P(Y,U,3) - . S I=+$O(^TMP("PS",$J,"SCH",0)),X=$P($G(^(I,0)),U,2) - . S:$L(X) CNT=CNT+1,@ORY@(CNT)="Schedule Type: "_X - . S X="Administration Times: ",I=0 - . F S I=$O(^TMP("PS",$J,"ADM",I)) Q:I'>0 S Y=$G(^(I,0)) S:$L(Y) CNT=CNT+1,@ORY@(CNT)=X_Y,X=$$REPEAT^XLFSTR(" ",30) -M2 I TYPE="O" D ;fill history - . N FILLD,RET,X,Y,I - . S:$P(NODE,U,12) CNT=CNT+1,@ORY@(CNT)="Last Filled: "_$$FMTE^XLFDT($P(NODE,U,12),2) - . S CNT=CNT+1,@ORY@(CNT)="Refills Remaining: "_$P(NODE,U,4) - . I $P(RXN,U,6)!$G(^TMP("PS",$J,"REF",0)) S X="Filled: " D - .. I $P(RXN,U,6) S FILLD=$P(RXN,U,6)_"^^^"_$P(RXN,U,7)_U_$P(RXN,U,3,4) D FILLED("R") - .. S RET=$G(^TMP("PS",$J,"RXN","RSTC")) I RET'="" D RETURNS(RET) - .. S I=0 F S I=$O(^TMP("PS",$J,"REF",I)) Q:I'>0 D - ... S FILLD=$G(^(I,0)) D FILLED("R") - ... S RET=$G(^TMP("PS",$J,"REF",I,"RSTC")) I RET'="" D RETURNS(RET) - . I $G(^TMP("PS",$J,"PAR",0)) S I=0,X="Partial Fills: " F S I=$O(^TMP("PS",$J,"PAR",I)) Q:I'>0 S FILLD=$G(^(I,0)) D FILLED("P") - . S:RXN CNT=CNT+1,@ORY@(CNT)="Prescription#: "_$P(RXN,U) -M3 S:$P(RXN,U,5) CNT=CNT+1,@ORY@(CNT)="Pharmacist: "_$P($G(^VA(200,+$P(RXN,U,5),0)),U) - I $G(STAT)="ACTIVE/SUSP" S CNT=CNT+1,@ORY@(CNT)="Prescription Status: "_STAT_" - Order is active. Fill or Refill has been requested." - S:$P(NODE,U,13) CNT=CNT+1,@ORY@(CNT)="NOT TO BE GIVEN" K ^TMP("PS",$J) - S CNT=CNT+1,@ORY@(CNT)=" " ;blank - S OR5=$G(^OR(100,ORIFN,5)) I $L(OR5) D ;SC data - . N X,Y,I - . S CNT=CNT+1,@ORY@(CNT)=" " ;blank line - . S CNT=CNT+1,@ORY@(CNT)="First Party Pay Exemptions" - . S X="For conditions related to: " - . F I=1:1:8 S Y=$P(OR5,U,I) I Y S CNT=CNT+1,@ORY@(CNT)=X_$$SC(I),X=$$REPEAT^XLFSTR(" ",30) - Q - ; -BA ;Billing Aware data display - N DXIEN,DXV,ICD9,ICDR,OCT,ORFMDAT - S OCT=0,X="" - ; Get the date of the order for CSV/CTD usage - S ORFMDAT=$$ORFMDAT^ORWDBA3(ORIFN) - ; $O through diagnoses for an order - F S OCT=$O(^OR(100,ORIFN,5.1,OCT)) Q:OCT'?1N.N D - . ; DXIEN=Dx IEN - . S DXIEN=+^OR(100,ORIFN,5.1,OCT,0) - . ; Get Dx record for date ORFMDAT - . S ICDR=$$ICDDX^ICDCODE(DXIEN,ORFMDAT) - . ; Get Dx verbiage and ICD code - . S DXV=$P(ICDR,U,4),ICD9=$P(ICDR,U,2) - . S X=" " - . I OCT=1 D - .. S CNT=CNT+1,@ORY@(CNT)=" " ;blank line - .. S CNT=CNT+1,@ORY@(CNT)="Clinical Indicators" - .. S X="Diagnosis of: " - . S X=X_ICD9_" - "_DXV,CNT=CNT+1,@ORY@(CNT)=X - I OCT'="" D ;if there are diagnoses show Treatment Factors - . S X="For conditions related to: " - . F I=1:1:8 S Y=$P(^OR(100,ORIFN,5.2),U,I) I Y D - .. S CNT=CNT+1,@ORY@(CNT)=X_$$SC(I),X=$$REPEAT^XLFSTR(" ",30) - Q - ; -FILLED(TYPE) ; -- add FILLD data - N Y S Y=$$FMTE^XLFDT($P(FILLD,U),2)_" ("_$$ROUTING($P(FILLD,U,5))_")" - S:TYPE="R"&$P(FILLD,U,4) Y=Y_" released "_$$FMTE^XLFDT($P(FILLD,U,4),2) - S:TYPE="P"&$P(FILLD,U,3) Y=Y_" Qty: "_$P(FILLD,U,3) - S CNT=CNT+1,@ORY@(CNT)=X_Y,X=$$REPEAT^XLFSTR(" ",30) - S:$L($P(FILLD,U,6)) CNT=CNT+1,@ORY@(CNT)=X_$P(FILLD,U,6) - Q -RETURNS(NODE) ; add Return to Stock Data - N DATE,NAME,TEXT,X - S DATE=$$FMTE^XLFDT($P(NODE,U)) - S NAME=$P(^VA(200,$P(NODE,U,2),0),U) - S X=$$REPEAT^XLFSTR(" ",13) - S TEXT="Return to Stock: "_X_DATE_" by "_NAME - S CNT=CNT+1,@ORY@(CNT)=TEXT - S X=$$REPEAT^XLFSTR(" ",30) - S TEXT=X_"Comments: "_$P(NODE,U,3) - S CNT=CNT+1,@ORY@(CNT)=TEXT - Q - ; -ROUTING(X) ; -- Returns external form - N Y S Y=$S($G(X)="M":"Mail",$G(X)="W":"Window",1:$G(X)) - Q Y - ; -SC(J) ; -- Returns name of SC field by piece number - I '$G(J) Q "" - I J=1 Q "SERVICE CONNECTED CONDITION" - I J=2 Q "MILITARY SEXUAL TRAUMA" - I J=3 Q "AGENT ORANGE EXPOSURE" - I J=4 Q "IONIZING RADIATION EXPOSURE" - I J=5 Q "ENVIRONMENTAL CONTAMINANTS" - I J=6 Q "HEAD OR NECK CANCER" - I J=7 Q "COMBAT VETERAN" - I J=8 Q "SHIPBOARD HAZARD AND DEFENSE" - Q "" +ORQ21 ; SLC/MKB/GSS - Detailed Order Report cont ; 10/6/2005 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141,190,195,215**;Dec 17, 1997 + ; + ; DBIA 2400 OEL^PSOORRL ^TMP("PS",$J) + ; DBIA 2266 EN30^RAO7PC1 ^TMP($J,"RAE2") + ; +RAD(TCOM) ; -- add RA data for 2.5 orders + N RAIFN,CASE,PROC,ORD,ORI,X,ORTTL,ORB + S RAIFN=$G(^OR(100,ORIFN,4)) Q:RAIFN'>0 + D EN30^RAO7PC1(RAIFN) Q:'$D(^TMP($J,"RAE2",+ORVP)) ;DBIA 2266 + S ORD=$G(^TMP($J,"RAE2",+ORVP,"ORD")),CASE=$O(^(0)) Q:'CASE S PROC=$O(^(CASE,"")) + I '$G(TCOM) D ;else add only Tech Comments + . S CNT=CNT+1,@ORY@(CNT)=$$LJ^XLFSTR("Procedure:",30)_$S($L(ORD):ORD,1:PROC) + . S ORI=0,ORTTL="Procedure Modifiers: ",ORB=1 + . F S ORI=$O(^TMP($J,"RAE2",+ORVP,CASE,PROC,"M",ORI)) Q:ORI'>0 S CNT=CNT+1,@ORY@(CNT)=ORTTL_^(ORI),ORTTL=$$REPEAT^XLFSTR(" ",30) + . S CNT=CNT+1,@ORY@(CNT)="History and Reason for Exam:" + . F S ORI=$O(^TMP($J,"RAE2",+ORVP,CASE,PROC,"H",ORI)) Q:ORI'>0 S CNT=CNT+1,@ORY@(CNT)=" "_^(ORI) +RAD1 I $L($G(^TMP($J,"RAE2",+ORVP,CASE,PROC,"TCOM",1))) S X=^(1) D + . N DIWL,DIWR,DIWF,I K ^UTILITY($J,"W") + . S DIWL=1,DIWR=72,DIWF="C72" D ^DIWP + . S CNT=CNT+1,@ORY@(CNT)="Technologist's Comment:",ORB=1 + . S I=0 F S I=$O(^UTILITY($J,"W",DIWL,I)) Q:I'>0 S CNT=CNT+1,@ORY@(CNT)=" "_^(I,0) + I $D(^TMP($J,"RAE2",+ORVP,CASE,PROC,"CM")) D + . S ORTTL="Contrast Media used: ",ORI=0,ORB=1 + . F S ORI=$O(^TMP($J,"RAE2",+ORVP,CASE,PROC,"CM",ORI)) Q:ORI<1 S CNT=CNT+1,@ORY@(CNT)=ORTTL_$P(^(ORI),U,2),ORTTL=$$REPEAT^XLFSTR(" ",30) + K ^TMP($J,"RAE2",+ORVP),^UTILITY($J,"W") + S:$G(ORB) CNT=CNT+1,@ORY@(CNT)=" " ;blank + Q + ; +MED ; -- Add Pharmacy order data + Q:$G(^OR(100,ORIFN,4))["N" ;non-VA med -- no refill history + N TYPE,NODE,RXN,OR5,STAT S TYPE=$P(OR0,U,12) + I '$D(^TMP("PS",$J,0)) D ;get PS data / DBIA 2400 + . N PSIFN S PSIFN=$G(^OR(100,ORIFN,4)) + . S:TYPE="O" PSIFN=$TR(PSIFN,"S","P")_$S(PSIFN?1.N:"R",1:"") + . D OEL^PSOORRL(+ORVP,PSIFN_";"_TYPE) ;DBIA 2400 + S NODE=$G(^TMP("PS",$J,0)),RXN=$G(^("RXN",0)),STAT=$P(NODE,U,6) + I '$L(NODE) K ^TMP("PS",$J) Q ;error + I $O(^TMP("PS",$J,"DD",0)) D ;Disp Drugs + . N I,X,Y S X="Dispense Drugs (units/dose): ",I=0 + . F S I=$O(^TMP("PS",$J,"DD",I)) Q:I'>0 S Y=$G(^(I,0)) S:Y CNT=CNT+1,@ORY@(CNT)=X_$$GET1^DIQ(50,+Y_",",.01)_" ("_$P(Y,U,2)_")" + S:$P(NODE,U,9) CNT=CNT+1,@ORY@(CNT)="Total Dose: "_$P(NODE,U,9) +M1 I TYPE="I" D ;admin data + . N I,X,Y I $O(^TMP("PS",$J,"B",0)) D + .. S X="IV Print Name: ",I=0 + .. F S I=$O(^TMP("PS",$J,"B",I)) Q:I<1 S Y=$G(^(I,0)) S:$L(Y) CNT=CNT+1,@ORY@(CNT)=X_$P(Y,U),X=$$REPEAT^XLFSTR(" ",30) I $L($P(Y,U,3)) S CNT=CNT+1,@ORY@(CNT)=X_" "_$P(Y,U,3) + . S I=+$O(^TMP("PS",$J,"SCH",0)),X=$P($G(^(I,0)),U,2) + . S:$L(X) CNT=CNT+1,@ORY@(CNT)="Schedule Type: "_X + . S X="Administration Times: ",I=0 + . F S I=$O(^TMP("PS",$J,"ADM",I)) Q:I'>0 S Y=$G(^(I,0)) S:$L(Y) CNT=CNT+1,@ORY@(CNT)=X_Y,X=$$REPEAT^XLFSTR(" ",30) +M2 I TYPE="O" D ;fill history + . N FILLD,X,Y,I + . S:$P(NODE,U,12) CNT=CNT+1,@ORY@(CNT)="Last Filled: "_$$FMTE^XLFDT($P(NODE,U,12),2) + . S CNT=CNT+1,@ORY@(CNT)="Refills Remaining: "_$P(NODE,U,4) + . I $P(RXN,U,6)!$G(^TMP("PS",$J,"REF",0)) S X="Filled: " D + .. I $P(RXN,U,6) S FILLD=$P(RXN,U,6)_"^^^"_$P(RXN,U,7)_U_$P(RXN,U,3,4) D FILLED("R") + .. S I=0 F S I=$O(^TMP("PS",$J,"REF",I)) Q:I'>0 S FILLD=$G(^(I,0)) D FILLED("R") + . I $G(^TMP("PS",$J,"PAR",0)) S I=0,X="Partial Fills: " F S I=$O(^TMP("PS",$J,"PAR",I)) Q:I'>0 S FILLD=$G(^(I,0)) D FILLED("P") + . S:RXN CNT=CNT+1,@ORY@(CNT)="Prescription#: "_$P(RXN,U) +M3 S:$P(RXN,U,5) CNT=CNT+1,@ORY@(CNT)="Pharmacist: "_$P($G(^VA(200,+$P(RXN,U,5),0)),U) + I $G(STAT)="ACTIVE/SUSP" S CNT=CNT+1,@ORY@(CNT)="Prescription Status: "_STAT_" - Order is active. Fill or Refill has been requested." + S:$P(NODE,U,13) CNT=CNT+1,@ORY@(CNT)="NOT TO BE GIVEN" K ^TMP("PS",$J) + S CNT=CNT+1,@ORY@(CNT)=" " ;blank + S OR5=$G(^OR(100,ORIFN,5)) I $L(OR5) D ;SC data + . N X,Y,I + . S CNT=CNT+1,@ORY@(CNT)=" " ;blank line + . S CNT=CNT+1,@ORY@(CNT)="First Party Pay Exemptions" + . S X="For conditions related to: " + . F I=1:1:7 S Y=$P(OR5,U,I) I Y S CNT=CNT+1,@ORY@(CNT)=X_$$SC(I),X=$$REPEAT^XLFSTR(" ",30) + Q + ; +BA ;Billing Aware data display + N DXIEN,DXV,ICD9,ICDR,OCT,ORFMDAT + S OCT=0,X="" + ; Get the date of the order for CSV/CTD usage + S ORFMDAT=$$ORFMDAT^ORWDBA3(ORIFN) + ; $O through diagnoses for an order + F S OCT=$O(^OR(100,ORIFN,5.1,OCT)) Q:OCT'?1N.N D + . ; DXIEN=Dx IEN + . S DXIEN=+^OR(100,ORIFN,5.1,OCT,0) + . ; Get Dx record for date ORFMDAT + . S ICDR=$$ICDDX^ICDCODE(DXIEN,ORFMDAT) + . ; Get Dx verbiage and ICD code + . S DXV=$P(ICDR,U,4),ICD9=$P(ICDR,U,2) + . S X=" " + . I OCT=1 D + .. S CNT=CNT+1,@ORY@(CNT)=" " ;blank line + .. S CNT=CNT+1,@ORY@(CNT)="Clinical Indicators" + .. S X="Diagnosis of: " + . S X=X_ICD9_" - "_DXV,CNT=CNT+1,@ORY@(CNT)=X + I OCT'="" D ;if there are diagnoses show Treatment Factors + . S X="For conditions related to: " + . F I=1:1:7 S Y=$P(^OR(100,ORIFN,5.2),U,I) I Y D + .. S CNT=CNT+1,@ORY@(CNT)=X_$$SC(I),X=$$REPEAT^XLFSTR(" ",30) + Q + ; +FILLED(TYPE) ; -- add FILLD data + N Y S Y=$$FMTE^XLFDT($P(FILLD,U),2)_" ("_$$ROUTING($P(FILLD,U,5))_")" + S:TYPE="R"&$P(FILLD,U,4) Y=Y_" released "_$$FMTE^XLFDT($P(FILLD,U,4),2) + S:TYPE="P"&$P(FILLD,U,3) Y=Y_" Qty: "_$P(FILLD,U,3) + S CNT=CNT+1,@ORY@(CNT)=X_Y,X=$$REPEAT^XLFSTR(" ",30) + S:$L($P(FILLD,U,6)) CNT=CNT+1,@ORY@(CNT)=X_$P(FILLD,U,6) + Q + ; +ROUTING(X) ; -- Returns external form + N Y S Y=$S($G(X)="M":"Mail",$G(X)="W":"Window",1:$G(X)) + Q Y + ; +SC(J) ; -- Returns name of SC field by piece number + I '$G(J) Q "" + I J=1 Q "SERVICE CONNECTED CONDITION" + I J=2 Q "MILITARY SEXUAL TRAUMA" + I J=3 Q "AGENT ORANGE EXPOSURE" + I J=4 Q "IONIZING RADIATION EXPOSURE" + I J=5 Q "ENVIRONMENTAL CONTAMINANTS" + I J=6 Q "HEAD OR NECK CANCER" + I J=7 Q "COMBAT VETERAN" + Q "" diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQPT.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQPT.m index 76c090e5..9301f0d0 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQPT.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQPT.m @@ -1,202 +1,204 @@ -ORQPT ; SLC/MKB - Patient Selection ; 4/18/07 7:20am - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**52,82,85,215,243**;Dec 17, 1997;Build 242 - ; - ; Ref. to ^UTILITY via IA 10061 - ; SLC/PKS - 3/2000: Modified to deal with "Combinations." - ; -EN ; -- main entry point for OR PATIENT SELECTION - I $G(ORVP),'($D(ORPNM)&$D(ORSSN)) K ORVP ; reset - D EN^VALM("OR PATIENT SELECTION") - Q - ; -HDR ; -- header code - N X I '$G(ORVP) S X="** No patient selected **" - E S X=$G(ORPNM)_" "_$G(ORSSN) - S VALMHDR(1)="Current patient: "_X - Q - ; -INIT ; -- init variables and list array - ; Modifications for multiple "Combination" lists by PKS. - ; - ; PARAM herein might end up as: ORLP DEFAULT CLINIC WEDNESDAY - ; (Param Name and current DOW) - ; ORY might end up passed as: 5^5^C;1;T-360;T+60;A - ; (#lines^#pts^source;serviceSection;startDate;stopDate;sort) - ; - N ORY,ORX,PARAM,ORYZB,ORYZE - ; - ;added by CLA 12/12/96 - gets SERVICE/SECTION of user: - N ORSRV S ORSRV=$G(^VA(200,DUZ,5)) I +ORSRV>0 S ORSRV=$P(ORSRV,U) - ; - S ORY=$$GET^XPAR("USR^SRV.`"_$G(ORSRV),"ORLP DEFAULT LIST SOURCE",1,"I") ; Gets default list source for this user. - I $L(ORY) D S ORY=ORY_";"_ORX - . ; PKS: Set "PARAM" var to parameter name in param def file: - . S PARAM="ORLP DEFAULT "_$S(ORY="T":"TEAM",ORY="S":"SPECIALTY",ORY="P":"PROVIDER",ORY="W":"WARD",ORY="C":"CLINIC",ORY="M":"COMBINATION",1:"") - . S:ORY="C" PARAM=PARAM_" "_$$UP^XLFSTR($$DOW^XLFDT(DT)) ; For clinics, add current DOW. - . S ORX=$$GET^XPAR("USR^SRV.`"_$G(ORSRV),PARAM,1,"I") ; Source param. - . ; Next lines modified by PKS for "Combinations" and dates: - . I (ORY="C")!(ORY="M") D - . . S ORYZB=$$UP^XLFSTR($$GET^XPAR("USR^SRV.`"_$G(ORSRV)_"^DIV^SYS^PKG","ORLP DEFAULT CLINIC START DATE",1,"I")) ; Gets clinic start date. - . . I ORYZB="T+0" S ORYZB=$$FMTE^XLFDT(DT,ORYZB) - . . S ORX=ORX_";"_ORYZB - . . S ORYZE=$$UP^XLFSTR($$GET^XPAR("USR^SRV.`"_$G(ORSRV)_"^DIV^SYS^PKG","ORLP DEFAULT CLINIC STOP DATE",1,"I")) ; Add ";" & stop date. - . . I ORYZE="T+0" S ORYZE=$$FMTE^XLFDT(DT,ORYZE) - . . S ORX=ORX_";"_ORYZE - S $P(ORY,";",5)=$$GET^XPAR("USR^SRV.`"_$G(ORSRV)_"^DIV^SYS^PKG","ORLP DEFAULT LIST ORDER",1,"I") ; Add default sort order. - ; - ; Call tag that builds the actual Patient Selection List: - D BUILD(ORY) - Q - ; -DEFAULT() ; -- Returns default action - I '$P($G(^TMP("OR",$J,"PATIENTS",0)),U,2) Q "Change View" - I XQORM("B")="Quit" Q "Close" - Q "Next Screen" - ; -MSG() ; -- Lmgr msg bar - Q "Enter the number of the patient chart to be opened" - ; -HELP ; -- help code - N X D FULL^VALM1 S VALMBCK="R" - W !!,"Enter the display number of the patient whose chart you wish to open" - W !,"or enter a patient name, SSN, or initial/last 4 combination. To" - W !,"change the list of patients displayed on this screen, enter CV. To" - W !,"have the new list automatically displayed when selecting a new patient," - W !,"enter SV. Enter FD to search by patient name or identifier." - W !!,"Press to continue ..." R X:DTIME - Q - ; -EXIT ; -- exit code - K ^TMP("OR",$J,"PATIENTS"),XQORM("ALT") - Q - ; -BUILD(LIST) ; -- build list in ^TMP("OR",$J,"PATIENTS") - N ORI,ORX,ORY,LCNT,NUM,DFN,NAME,TYPE,PTR,BEG,END,SORT,DOB,RBED,%DT,X,Y,TITLE,PTID,SENS - S TYPE=$E(LIST),PTR=+$P(LIST,";",2),SORT=$P(LIST,";",5) - ; Next 5 lines added by PKS: - I ((SORT="S")&(TYPE'="M")) S SORT="A" ; Reset invalid sorts. - I TYPE="M" D ; Deal with combinations. - .I ((SORT="P")!(SORT="A")!(SORT="S")) Q ; P,A,S are acceptable. - .S SORT="A" ; Default. - S $P(LIST,";",5)=SORT ; Reset in case of change. - S BEG=$P(LIST,";",3) I $L(BEG) S X=BEG,%DT="X" D ^%DT S BEG=Y - S END=$P(LIST,";",4) I $L(END) S X=END,%DT="X" D ^%DT S END=Y - I TYPE="T" D TEAMPTS^ORQPTQ1(.ORY,PTR) S TITLE="Team "_$P($G(^OR(100.21,+PTR,0)),U) - I TYPE="P" D PROVPTS^ORQPTQ2(.ORY,PTR) S TITLE="Provider "_$P($G(^VA(200,+PTR,0)),U) - I TYPE="S" D SPECPTS^ORQPTQ2(.ORY,PTR) S TITLE="Specialty "_$P($G(^DIC(45.7,+PTR,0)),U) - I TYPE="W" D WARDPTS^ORQPTQ2(.ORY,PTR) S TITLE="Ward "_$P($G(^DIC(42,+PTR,0)),U) - I TYPE="C" D CLINPTS^ORQPTQ2(.ORY,PTR,BEG,END) S TITLE="Clinic "_$P($G(^SC(+PTR,0)),U) - ; Next line added by PKS for "Combinations:" - I TYPE="M" N MSG D COMBPTS^ORQPTQ6(1,PTR,BEG,END) S TITLE="Combination List" ; Sets MSG,LCNT,NUM, and writes ^TMP("OR",$J,"PATIENTS"). - ; Next section added by PKS for "Combinations:" - I TYPE="M" D G BQ ; Check MSG var, then go to BQ tag. - .I MSG'="" D ; Did call to COMBPTS assign an error message? - ..S LCNT=1,NUM=0 ; Set defaults. - ..S ^TMP("OR",$J,"PATIENTS",1,0)=" "_MSG ; Write error msg. - D CLEAN^VALM10 S (LCNT,NUM)=0 ; All but "M" types reset, go on to B1. - ; -B1 S ORI=0 F S ORI=$O(ORY(ORI)) Q:ORI'>0 I ORY(ORI) D ; sort - . S DFN=+ORY(ORI) - . ;sort logic added by CLA 7/23/97: - . S ORX="" - . I SORT="P",(TYPE="C") S ORX=$P($G(ORY(ORI)),U,4) D - .. S $P(ORX,".",2)=$E($P(ORX,".",2)_"000",1,4) - ..S ORX=ORX_U_$P(ORY(ORI),U,2) - . I SORT="R",(TYPE'="C") S ORX=$P($G(^DPT(+ORY(ORI),.101)),U)_U_$P(ORY(ORI),U,2) - . I SORT="T" S ORX="" ; Need to add terminal digit sorting. - . ; If no sort specified, default to alphabetic (plus app't if clinic type): - . I ORX="" S ORX=$P(ORY(ORI),U,2)_U_$P($G(ORY(ORI)),U,4) - . S ^TMP("OR",$J,"PATIENTS","B",ORX_DFN)=ORY(ORI) ; DFN ^ Name - I '$D(^TMP("OR",$J,"PATIENTS")) D G BQ - . N MSG - . S MSG="No patients found" - . S LCNT=1,NUM=0 - . I $D(ORY(1)) S MSG=$P(ORY(1),"^",2) ; error message from search - . S ^TMP("OR",$J,"PATIENTS",1,0)=" "_MSG -B2 S ORX="" F S ORX=$O(^TMP("OR",$J,"PATIENTS","B",ORX)) Q:ORX="" S ORY=^(ORX) D - . S DFN=+ORY,NAME=$P(ORY,U,2) - . S DOB=$$FMTE^XLFDT($P($G(^DPT(DFN,0)),U,3)) - . S:(TYPE'="C") RBED=$P($G(^DPT(DFN,.101)),U) - . I (TYPE="C") S RBED=$S(SORT="P":$$FMTE^XLFDT($P(ORX,U)),1:$$FMTE^XLFDT($P(^TMP("OR",$J,"PATIENTS","B",ORX),U,4))) - . ;Q:RBED="" removed by CLA 7/23/97 to prevent blank lines - . S LCNT=LCNT+1,NUM=NUM+1 - . S ^TMP("OR",$J,"PATIENTS","IDX",NUM)=ORY ; DFN ^ NAME - . ; Next lines modified/added by PKS on 1/24/2001: - . ; Check for "sensitive" patients: - . S PTID="" - . S PTID=$$ID(DFN) - . S SENS=$$SSN^DPTLK1(DFN) - . I SENS["*" S PTID="" - . S DOB=$$DOB^DPTLK1(DFN) - . S ^TMP("OR",$J,"PATIENTS",LCNT,0)=$$LJ^XLFSTR(NUM,5)_$$LJ^XLFSTR(NAME,31)_$$LJ^XLFSTR(PTID,10)_$$LJ^XLFSTR(DOB,15)_$G(RBED) - . D CNTRL^VALM10(LCNT,1,5,IOINHI,IOINORM) -BQ S ^TMP("OR",$J,"PATIENTS",0)=LCNT_U_NUM_U_$G(LIST) ; #lines^#pts^context - S ^TMP("OR",$J,"PATIENTS","#")=$O(^ORD(101,"B","ORQPT SELECT PATIENT",0))_"^1:"_NUM - S RBED=$S(TYPE="C":"Appointment Date",TYPE="M":"Source Other",1:"Room-Bed") - D CHGCAP^VALM("ROOM-BED",RBED) K VALMHDR - S VALMCNT=LCNT,VALMBG=1,VALMBCK="R" S:$L($G(TITLE)) VALM("TITLE")=TITLE - Q - ; -ID(DFN) ; -- Returns short ID for patient ID - N ID S ID=$P($G(^DPT(DFN,.36)),U,4) ; short ID - I '$L(ID) S ID=$E($P($G(^DPT(DFN,0)),U,9),6,9) ; last 4 of SSN - Q "("_$E(NAME)_ID_")" - ; -APPT(DFN,CLINIC,FROM,TO) ; -- Return [next?] clinic appointment - ; returns date/time next appt or "", returns "^error message" on error - N ERR,ERRMSG,VASD,VAERR K ^UTILITY("VASD",$J) ;IA 10061 - S VASD("F")=FROM,VASD("T")=TO,VASD("C",CLINIC)="" - D SDA^ORQRY01(.ERR,.ERRMSG) - I ERR K ^UTILITY("VASD",$J) Q ERRMSG - S NEXT=+$O(^UTILITY("VASD",$J,0)),NEXT=$P($G(^(NEXT,"I")),U) - K ^UTILITY("VASD",$J) - Q NEXT - ; -ALT ; -- XQORM("ALT") code to search File 2 for patient X - N DIC,DFN,Y,ORX S ORX=X D FULL^VALM1 - S DIC=2,DIC(0)="EQM",X=$S($D(XQORMRCL):" ",1:ORX) - D ^DIC I Y'>0 S VALMBCK="R" Q ;S XQORMERR=1 Q - S ORX=+$G(^DPT(+Y,.35)) I ORX,'$$OK(ORX) S VALMBCK="R" Q - S DFN=+Y G:DFN'=+$G(ORVP) SLCT1 ; set patient variables - Q - ; -FIND ; -- find patient in ^DPT - N X,Y,DIC,ORX,DFN - S DIC=2,DIC(0)="AEQM" D FULL^VALM1 - D ^DIC I Y'>0 S VALMBCK="R" Q - S ORX=+$G(^DPT(+Y,.35)) I ORX,'$$OK(ORX) S VALMBCK="R" Q - S DFN=+Y G:DFN'=+$G(ORVP) SLCT1 ; set patient variables - Q - ; -SELECT ; -- select patient from list - N NMBR,X,Y,Z,DIC,DFN,ORX S NMBR=+$P(XQORNOD(0),"=",2) - S Y=$G(^TMP("OR",$J,"PATIENTS","IDX",NMBR)),DFN=+Y - I 'DFN W $C(7),!!,NMBR_" is not a valid selection.",! S VALMBCK="" H 1 Q - ;W " "_$P(Y,U,2) S ^DISV(DUZ,"^DPT(")=DFN - D FULL^VALM1 S DIC=2,DIC(0)="EQM",X="`"_DFN D ^DIC I Y<0 S VALMBCK="R" Q - S ORX=+$G(^DPT(+Y,.35)) I ORX,'$$OK(ORX) S VALMBCK="R" Q -SLCT1 ; -- may enter here with DFN from FIND - N VADM,VAEL,VAIN,VA,VAERR,LOC,ORCNV - D OERR^VADPT,ELIG^VADPT - S LOC=+$G(^DIC(42,+VAIN(4),44))_";SC(" I 'LOC,'$D(XQAID) D - . I $G(NMBR) N X S X=$$CONTEXT^ORQPT1 I $E(X)="C" S LOC=$P(X,";",2)_";SC(" Q:LOC ; use clinic if selected from list, else ask - . S LOC="" ;,X=$$LOCATION^ORCMENU1(1) S:X LOC=X - S ORL=LOC,ORL(0)=$P($G(^SC(+ORL,0)),U),ORL(1)=VAIN(5) - S ORVP=DFN_";DPT(",ORPNM=VADM(1),ORSSN=$P(VADM(2),U,2) - S ORDOB=$P(VADM(3),U,2),ORAGE=VADM(4),ORSEX=$P(VADM(5),U) - S ORTS=+VAIN(3),ORWARD=VAIN(4),ORATTEND=+VAIN(11),ORSC=$G(VAEL(3)) - I $P($G(^DGSL(38.1,+ORVP,0)),"^",2),($G(^DPT(+ORVP,.1))]""!$D(^XUSEC("DG SENSITIVITY",DUZ))) D - . ; if senstive patient and (patient inpatient or user holds key) - . ; prevents sensitive patient warning from scrolling off screen - . N X - . W !!,"Press to continue ..." - . R X:DTIME -SLCT2 ; -- convert patient's orders, if not already done - Q - ; -OK(DATE) ; -- Patient is deceased; ok to continue? - N X,Y,DIR S DIR(0)="YA",DIR("B")="NO" - S DIR("A")="Do you wish to continue? " - W $C(7),!!,"This patient died "_$$FMTE^XLFDT(DATE)_"!" - D ^DIR - Q +Y +ORQPT ; SLC/MKB - Patient Selection ;3/16/05 08:28 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**52,82,85,215**;Dec 17, 1997 + ; + ; Ref. to ^UTILITY via IA 10061 + ; SLC/PKS - 3/2000: Modified to deal with "Combinations." + ; +EN ; -- main entry point for OR PATIENT SELECTION + I $G(ORVP),'($D(ORPNM)&$D(ORSSN)) K ORVP ; reset + D EN^VALM("OR PATIENT SELECTION") + Q + ; +HDR ; -- header code + N X I '$G(ORVP) S X="** No patient selected **" + E S X=$G(ORPNM)_" "_$G(ORSSN) + S VALMHDR(1)="Current patient: "_X + Q + ; +INIT ; -- init variables and list array + ; Modifications for multiple "Combination" lists by PKS. + ; + ; PARAM herein might end up as: ORLP DEFAULT CLINIC WEDNESDAY + ; (Param Name and current DOW) + ; ORY might end up passed as: 5^5^C;1;T-360;T+60;A + ; (#lines^#pts^source;serviceSection;startDate;stopDate;sort) + ; + N ORY,ORX,PARAM,ORYZB,ORYZE + ; + ;added by CLA 12/12/96 - gets SERVICE/SECTION of user: + N ORSRV S ORSRV=$G(^VA(200,DUZ,5)) I +ORSRV>0 S ORSRV=$P(ORSRV,U) + ; + S ORY=$$GET^XPAR("USR^SRV.`"_$G(ORSRV),"ORLP DEFAULT LIST SOURCE",1,"I") ; Gets default list source for this user. + I $L(ORY) D S ORY=ORY_";"_ORX + . ; PKS: Set "PARAM" var to parameter name in param def file: + . S PARAM="ORLP DEFAULT "_$S(ORY="T":"TEAM",ORY="S":"SPECIALTY",ORY="P":"PROVIDER",ORY="W":"WARD",ORY="C":"CLINIC",ORY="M":"COMBINATION",1:"") + . S:ORY="C" PARAM=PARAM_" "_$$UP^XLFSTR($$DOW^XLFDT(DT)) ; For clinics, add current DOW. + . S ORX=$$GET^XPAR("USR^SRV.`"_$G(ORSRV),PARAM,1,"I") ; Source param. + . ; Next lines modified by PKS for "Combinations" and dates: + . I (ORY="C")!(ORY="M") D + . . S ORYZB=$$UP^XLFSTR($$GET^XPAR("USR^SRV.`"_$G(ORSRV)_"^DIV^SYS^PKG","ORLP DEFAULT CLINIC START DATE",1,"I")) ; Gets clinic start date. + . . I ORYZB="T+0" S ORYZB=$$FMTE^XLFDT(DT,ORYZB) + . . S ORX=ORX_";"_ORYZB + . . S ORYZE=$$UP^XLFSTR($$GET^XPAR("USR^SRV.`"_$G(ORSRV)_"^DIV^SYS^PKG","ORLP DEFAULT CLINIC STOP DATE",1,"I")) ; Add ";" & stop date. + . . I ORYZE="T+0" S ORYZE=$$FMTE^XLFDT(DT,ORYZE) + . . S ORX=ORX_";"_ORYZE + S $P(ORY,";",5)=$$GET^XPAR("USR^SRV.`"_$G(ORSRV)_"^DIV^SYS^PKG","ORLP DEFAULT LIST ORDER",1,"I") ; Add default sort order. + ; + ; Call tag that builds the actual Patient Selection List: + D BUILD(ORY) + Q + ; +DEFAULT() ; -- Returns default action + I '$P($G(^TMP("OR",$J,"PATIENTS",0)),U,2) Q "Change View" + I XQORM("B")="Quit" Q "Close" + Q "Next Screen" + ; +MSG() ; -- Lmgr msg bar + Q "Enter the number of the patient chart to be opened" + ; +HELP ; -- help code + N X D FULL^VALM1 S VALMBCK="R" + W !!,"Enter the display number of the patient whose chart you wish to open" + W !,"or enter a patient name, SSN, or initial/last 4 combination. To" + W !,"change the list of patients displayed on this screen, enter CV. To" + W !,"have the new list automatically displayed when selecting a new patient," + W !,"enter SV. Enter FD to search by patient name or identifier." + W !!,"Press to continue ..." R X:DTIME + Q + ; +EXIT ; -- exit code + K ^TMP("OR",$J,"PATIENTS"),XQORM("ALT") + Q + ; +BUILD(LIST) ; -- build list in ^TMP("OR",$J,"PATIENTS") + N ORI,ORX,ORY,LCNT,NUM,DFN,NAME,TYPE,PTR,BEG,END,SORT,DOB,RBED,%DT,X,Y,TITLE,PTID,SENS + S TYPE=$E(LIST),PTR=+$P(LIST,";",2),SORT=$P(LIST,";",5) + ; Next 5 lines added by PKS: + I ((SORT="S")&(TYPE'="M")) S SORT="A" ; Reset invalid sorts. + I TYPE="M" D ; Deal with combinations. + .I ((SORT="P")!(SORT="A")!(SORT="S")) Q ; P,A,S are acceptable. + .S SORT="A" ; Default. + S $P(LIST,";",5)=SORT ; Reset in case of change. + S BEG=$P(LIST,";",3) I $L(BEG) S X=BEG,%DT="X" D ^%DT S BEG=Y + S END=$P(LIST,";",4) I $L(END) S X=END,%DT="X" D ^%DT S END=Y + I TYPE="T" D TEAMPTS^ORQPTQ1(.ORY,PTR) S TITLE="Team "_$P($G(^OR(100.21,+PTR,0)),U) + I TYPE="P" D PROVPTS^ORQPTQ2(.ORY,PTR) S TITLE="Provider "_$P($G(^VA(200,+PTR,0)),U) + I TYPE="S" D SPECPTS^ORQPTQ2(.ORY,PTR) S TITLE="Specialty "_$P($G(^DIC(45.7,+PTR,0)),U) + I TYPE="W" D WARDPTS^ORQPTQ2(.ORY,PTR) S TITLE="Ward "_$P($G(^DIC(42,+PTR,0)),U) + I TYPE="C" D CLINPTS^ORQPTQ2(.ORY,PTR,BEG,END) S TITLE="Clinic "_$P($G(^SC(+PTR,0)),U) + ; Next line added by PKS for "Combinations:" + I TYPE="M" N MSG D COMBPTS^ORQPTQ6(1,PTR,BEG,END) S TITLE="Combination List" ; Sets MSG,LCNT,NUM, and writes ^TMP("OR",$J,"PATIENTS"). + ; Next section added by PKS for "Combinations:" + I TYPE="M" D G BQ ; Check MSG var, then go to BQ tag. + .I MSG'="" D ; Did call to COMBPTS assign an error message? + ..S LCNT=1,NUM=0 ; Set defaults. + ..S ^TMP("OR",$J,"PATIENTS",1,0)=" "_MSG ; Write error msg. + D CLEAN^VALM10 S (LCNT,NUM)=0 ; All but "M" types reset, go on to B1. + ; +B1 S ORI=0 F S ORI=$O(ORY(ORI)) Q:ORI'>0 I ORY(ORI) D ; sort + . S DFN=+ORY(ORI) + . ;sort logic added by CLA 7/23/97: + . S ORX="" + . I SORT="P",(TYPE="C") S ORX=$P($G(ORY(ORI)),U,4) D + .. S $P(ORX,".",2)=$E($P(ORX,".",2)_"000",1,4) + ..S ORX=ORX_U_$P(ORY(ORI),U,2) + . I SORT="R",(TYPE'="C") S ORX=$P($G(^DPT(+ORY(ORI),.101)),U)_U_$P(ORY(ORI),U,2) + . I SORT="T" S ORX="" ; Need to add terminal digit sorting. + . ; If no sort specified, default to alphabetic (plus app't if clinic type): + . I ORX="" S ORX=$P(ORY(ORI),U,2)_U_$P($G(ORY(ORI)),U,4) + . S ^TMP("OR",$J,"PATIENTS","B",ORX_DFN)=ORY(ORI) ; DFN ^ Name + I '$D(^TMP("OR",$J,"PATIENTS")) D G BQ + . N MSG + . S MSG="No patients found" + . S LCNT=1,NUM=0 + . I $D(ORY(1)) S MSG=$P(ORY(1),"^",2) ; error message from search + . S ^TMP("OR",$J,"PATIENTS",1,0)=" "_MSG +B2 S ORX="" F S ORX=$O(^TMP("OR",$J,"PATIENTS","B",ORX)) Q:ORX="" S ORY=^(ORX) D + . S DFN=+ORY,NAME=$P(ORY,U,2) + . S DOB=$$FMTE^XLFDT($P($G(^DPT(DFN,0)),U,3)) + . S:(TYPE'="C") RBED=$P($G(^DPT(DFN,.101)),U) + . I (TYPE="C") S RBED=$S(SORT="P":$$FMTE^XLFDT($P(ORX,U)),1:$$FMTE^XLFDT($P(^TMP("OR",$J,"PATIENTS","B",ORX),U,4))) + . ;Q:RBED="" removed by CLA 7/23/97 to prevent blank lines + . S LCNT=LCNT+1,NUM=NUM+1 + . S ^TMP("OR",$J,"PATIENTS","IDX",NUM)=ORY ; DFN ^ NAME + . ; Next lines modified/added by PKS on 1/24/2001: + . ; Check for "sensitive" patients: + . S PTID="" + . S PTID=$$ID(DFN) + . S SENS=$$SSN^DPTLK1(DFN) + . I SENS["*" S PTID="" + . S DOB=$$DOB^DPTLK1(DFN) + . S ^TMP("OR",$J,"PATIENTS",LCNT,0)=$$LJ^XLFSTR(NUM,5)_$$LJ^XLFSTR(NAME,31)_$$LJ^XLFSTR(PTID,10)_$$LJ^XLFSTR(DOB,15)_$G(RBED) + . D CNTRL^VALM10(LCNT,1,5,IOINHI,IOINORM) +BQ S ^TMP("OR",$J,"PATIENTS",0)=LCNT_U_NUM_U_$G(LIST) ; #lines^#pts^context + S ^TMP("OR",$J,"PATIENTS","#")=$O(^ORD(101,"B","ORQPT SELECT PATIENT",0))_"^1:"_NUM + S RBED=$S(TYPE="C":"Appointment Date",TYPE="M":"Source Other",1:"Room-Bed") + D CHGCAP^VALM("ROOM-BED",RBED) K VALMHDR + S VALMCNT=LCNT,VALMBG=1,VALMBCK="R" S:$L($G(TITLE)) VALM("TITLE")=TITLE + Q + ; +ID(DFN) ; -- Returns short ID for patient ID + N ID S ID=$P($G(^DPT(DFN,.36)),U,4) ; short ID + I '$L(ID) S ID=$E($P($G(^DPT(DFN,0)),U,9),6,9) ; last 4 of SSN + Q "("_$E(NAME)_ID_")" + ; +APPT(DFN,CLINIC,FROM,TO) ; -- Return [next?] clinic appointment + ; returns date/time next appt or "", returns "^error message" on error + N ERR,ERRMSG,VASD,VAERR K ^UTILITY("VASD",$J) ;IA 10061 + S VASD("F")=FROM,VASD("T")=TO,VASD("C",CLINIC)="" + D SDA^ORQRY01(.ERR,.ERRMSG) + I ERR K ^UTILITY("VASD",$J) Q ERRMSG + S NEXT=+$O(^UTILITY("VASD",$J,0)),NEXT=$P($G(^(NEXT,"I")),U) + K ^UTILITY("VASD",$J) + Q NEXT + ; +ALT ; -- XQORM("ALT") code to search File 2 for patient X + N DIC,DFN,Y,ORX S ORX=X D FULL^VALM1 + S DIC=2,DIC(0)="EQM",X=$S($D(XQORMRCL):" ",1:ORX) + D ^DIC I Y'>0 S VALMBCK="R" Q ;S XQORMERR=1 Q + S ORX=+$G(^DPT(+Y,.35)) I ORX,'$$OK(ORX) S VALMBCK="R" Q + S DFN=+Y G:DFN'=+$G(ORVP) SLCT1 ; set patient variables + Q + ; +FIND ; -- find patient in ^DPT + N X,Y,DIC,ORX,DFN + S DIC=2,DIC(0)="AEQM" D FULL^VALM1 + D ^DIC I Y'>0 S VALMBCK="R" Q + S ORX=+$G(^DPT(+Y,.35)) I ORX,'$$OK(ORX) S VALMBCK="R" Q + S DFN=+Y G:DFN'=+$G(ORVP) SLCT1 ; set patient variables + Q + ; +SELECT ; -- select patient from list + N NMBR,X,Y,Z,DIC,DFN,ORX S NMBR=+$P(XQORNOD(0),"=",2) + S Y=$G(^TMP("OR",$J,"PATIENTS","IDX",NMBR)),DFN=+Y + I 'DFN W $C(7),!!,NMBR_" is not a valid selection.",! S VALMBCK="" H 1 Q + ;W " "_$P(Y,U,2) S ^DISV(DUZ,"^DPT(")=DFN + D FULL^VALM1 S DIC=2,DIC(0)="EQM",X="`"_DFN D ^DIC I Y<0 S VALMBCK="R" Q + S ORX=+$G(^DPT(+Y,.35)) I ORX,'$$OK(ORX) S VALMBCK="R" Q +SLCT1 ; -- may enter here with DFN from FIND + N VADM,VAEL,VAIN,VA,VAERR,LOC,ORCNV + D OERR^VADPT,ELIG^VADPT + S LOC=+$G(^DIC(42,+VAIN(4),44))_";SC(" I 'LOC,'$D(XQAID) D + . I $G(NMBR) N X S X=$$CONTEXT^ORQPT1 I $E(X)="C" S LOC=$P(X,";",2)_";SC(" Q:LOC ; use clinic if selected from list, else ask + . S LOC="" ;,X=$$LOCATION^ORCMENU1(1) S:X LOC=X + S ORL=LOC,ORL(0)=$P($G(^SC(+ORL,0)),U),ORL(1)=VAIN(5) + S ORVP=DFN_";DPT(",ORPNM=VADM(1),ORSSN=$P(VADM(2),U,2) + S ORDOB=$P(VADM(3),U,2),ORAGE=VADM(4),ORSEX=$P(VADM(5),U) + S ORTS=+VAIN(3),ORWARD=VAIN(4),ORATTEND=+VAIN(11),ORSC=$G(VAEL(3)) + I $P($G(^DGSL(38.1,+ORVP,0)),"^",2),($G(^DPT(+ORVP,.1))]""!$D(^XUSEC("DG SENSITIVITY",DUZ))) D + . ; if senstive patient and (patient inpatient or user holds key) + . ; prevents sensitive patient warning from scrolling off screen + . N X + . W !!,"Press to continue ..." + . R X:DTIME +SLCT2 ; -- convert patient's orders, if not already done + S ORCNV=$$OTF^OR3CONV(+ORVP) Q:'ORCNV I ORCNV>0 W !,"DONE" H 1 Q + I ORCNV<0 W $C(7),!!,$P(ORCNV,U,2) H 2 S VALMBCK="R" Q + Q + ; +OK(DATE) ; -- Patient is deceased; ok to continue? + N X,Y,DIR S DIR(0)="YA",DIR("B")="NO" + S DIR("A")="Do you wish to continue? " + W $C(7),!!,"This patient died "_$$FMTE^XLFDT(DATE)_"!" + D ^DIR + Q +Y diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQPTQ1.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQPTQ1.m index a8c5af28..7a66e6af 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQPTQ1.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQPTQ1.m @@ -1,209 +1,209 @@ -ORQPTQ1 ; SLC/CLA - Functs which return OR patient lists and sources pt 1 ; 8/20/07 5:43am - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**9,74,63,91,85,139,243**;Dec 17, 1997;Build 242 -VAMCPTS(Y) ; RETURN LIST OF PATIENTS IN VAMC: DFN^NAME - N I,J,V - S I=1 - S J=0 F S J=$O(^DPT("B",J)) Q:J="" S V=0,V=$O(^DPT("B",J,V)) S Y(I)=V_"^"_J,I=I+1 - Q -VAMCLONG(Y,DIR,FROM) ; return a bolus of patients in VAMC: DFN^NAME - N I,IEN,CNT S CNT=44 - I DIR=0 D ; Forward direction - . F I=1:1:CNT S FROM=$O(^DPT("B",FROM)) Q:FROM="" D - . . S Y(I)=$O(^DPT("B",FROM,0))_"^"_FROM - . I +$G(Y(CNT))="" S Y(I)="" - I DIR=1 D ; Reverse direction - . F I=1:1:CNT S FROM=$O(^DPT("B",FROM),-1) Q:FROM="" D - . . S Y(I)=$O(^DPT("B",FROM,0))_"^"_FROM - Q -DEFTM(ORY) ; return current user's default team list - Q:'$D(DUZ) - N ORSRV S ORSRV=$G(^VA(200,DUZ,5)) I +ORSRV>0 S ORSRV=$P(ORSRV,U) - S ORY=$$GET^XPAR("USR^SRV.`"_+$G(ORSRV),"ORLP DEFAULT TEAM",1,"B") - Q -TEAMS(ORY) ; return list of teams for a system - ; Also called under DBIA # 2692. - N ORTM,I,ORTMN - S ORTMN="",I=1 - F S ORTMN=$O(^OR(100.21,"B",ORTMN)) Q:ORTMN="" D - .S ORTM="",ORTM=$O(^OR(100.21,"B",ORTMN,ORTM)) Q:ORTM="" - .I $P($G(^OR(100.21,ORTM,11)),U)'=0!($D(^OR(100.21,ORTM,1,$G(DUZ,0)))) S ORY(I)=ORTM_U_ORTMN,I=I+1 - S:+$G(ORY(1))<1 ORY(1)="^No teams found." - Q -TEAMPTS(ORY,TEAM,TMPFLAG) ; RETURN LIST OF PATIENTS IN A TEAM - ; Also called under DBIA # 2692. - ; If TMPFLAG passed and = TRUE, code expects a "^TMP(xxx" - ; global root string passed in ORY, and builds the returned - ; list in that global instead of to a memory array. - N DOTMP,NEWTMP - S DOTMP=0 - I $G(TMPFLAG) D ; Was value passed? - .I TMPFLAG S DOTMP=1 ; Is value TRUE? - I +$G(TEAM)<1 D - .I DOTMP S NEWTMP=ORY_1_")",@NEWTMP="^No team identified" Q - .I 'DOTMP S ORY(1)="^No team identified" Q - N ORI,ORPT,I - S I=0 - S ORI=0 F S ORI=$O(^OR(100.21,+TEAM,10,ORI)) Q:ORI<1 D - .S ORPT=^OR(100.21,+TEAM,10,ORI,0) - .I DOTMP D - ..S I=I+1,NEWTMP=ORY_+I_")" - ..S @NEWTMP=+ORPT_U_$P(^DPT(+ORPT,0),U) - .I 'DOTMP S I=I+1,ORY(I)=+ORPT_U_$P(^DPT(+ORPT,0),U) - I DOTMP S:I<1 NEWTMP=ORY_1_")",@NEWTMP="^No patients found." - I 'DOTMP S:I<1 ORY(1)="^No patients found." - Q -TEAMPR(ORY,PROV) ; return list of teams linked to a provider - I +$G(PROV)<1 S ORY(1)="^No provider identified" Q - N ORTM,I,ORTMN - S ORTM="",I=1 - F S ORTM=$O(^OR(100.21,"C",+PROV,ORTM)) Q:+$G(ORTM)<1 D - .S ORTMN=$P(^OR(100.21,ORTM,0),U) - .S ORY(I)=ORTM_U_ORTMN,I=I+1 - S:+$G(ORY(1))<1 ORY(1)="^No teams found." - Q -TEAMPR2(ORY,PROV) ; return list of teams linked to a provider - ; This tag added by PKS/slc - 8/1999. - I +$G(PROV)<1 S ORY(1)="^No provider identified" Q - N ORTM,ORDATA,ORTMN,ORTYPE,I - S ORTM="",I=1 - F S ORTM=$O(^OR(100.21,"C",+PROV,ORTM)) Q:+$G(ORTM)<1 D - .S ORDATA=^OR(100.21,ORTM,0) ; Get value. - .S ORTMN=$P(ORDATA,U) ; Team List name. - .S ORTYPE=$P(ORDATA,U,2) ; Team List type. - .S ORY(I)=ORTM_U_ORTMN_U_ORTYPE,I=I+1 - S:+$G(ORY(1))<1 ORY(1)="^No teams found." - Q -TEAMPROV(ORY,TEAM) ; return list of providers linked to a team - I +$G(TEAM)<1 S ORY(1)="^No team identified" - N PROV,I,SEQ - S I=1 - S SEQ=0 F S SEQ=$O(^OR(100.21,+TEAM,1,SEQ)) Q:SEQ<1 D - .S PROV=^OR(100.21,+TEAM,1,SEQ,0) I $L(PROV) D - ..S ORY(I)=+PROV_U_$P(^VA(200,+PROV,0),U),I=I+1 - S:+$G(ORY(1))<1 ORY(1)="^No providers found." - Q -TPROVPT(PROV) ;return list of patients linked to a provider via teams - ; Modified by PKS: 8/1999. - I +$G(PROV)<1 S ^TMP("ORLPUPT",$J,"^No provider identified")="" - N ORTM,ORTMN,ORI,ORPT - S ORTM="" - F S ORTM=$O(^OR(100.21,"C",+PROV,ORTM)) Q:+$G(ORTM)<1 D ; Teams. - .S ORTMN=$P(^OR(100.21,+ORTM,0),U,1) ; Get name of Team List. - .S ORI=0 F S ORI=$O(^OR(100.21,+ORTM,10,ORI)) Q:ORI<1 D - ..S ORPT=^OR(100.21,+ORTM,10,ORI,0) - ..S ^TMP("ORLPUPT",$J,+ORPT_U_$P(^DPT(+ORPT,0),U))="" - ..; Next line added by PKS: - ..S ^TMP("ORLPUPT",$J,"B",ORTMN,$P(^DPT(+ORPT,0),U)_U_+ORPT)="" - I '$D(^TMP("ORLPUPT",$J)) S ^TMP("ORLPUPT",$J,"^No patients found.")="" - Q -TMSPT(ORY,PT) ;return list of teams linked to a patient (patient is active) - I +$G(PT)<1 S ORY(1)="^No patient identified" Q - N ORTM,I,ORTMN,ORTMTYP - S ORTM="",I=1 - F S ORTM=$O(^OR(100.21,"AB",+PT_";DPT(",ORTM)) Q:+$G(ORTM)<1 D - .S ORTMN=$P(^OR(100.21,ORTM,0),U) - .S ORTMTYP=$P(^OR(100.21,ORTM,0),U,2) I $L(ORTMTYP) D - ..S ORTMTYP=$$EXTERNAL^DILFD(100.21,1,"",ORTMTYP,"") - .S ORY(I)=ORTM_U_ORTMN_U_$S($L(ORTMTYP):ORTMTYP,1:"no type"),I=I+1 - S:+$G(ORY(1))<1 ORY(1)="^No teams found." - Q -TPTPR(ORY,PT) ;return list of providers linked to a patient via teams - I +$G(PT)<1 S ORY(1)="^No patient identified" Q - N ORTM,PROV,SEQ - S ORTM="" - F S ORTM=$O(^OR(100.21,"AB",+PT_";DPT(",ORTM)) Q:+$G(ORTM)<1 D - .S SEQ=0 F S SEQ=$O(^OR(100.21,+ORTM,1,SEQ)) Q:SEQ<1 D - ..S PROV=^OR(100.21,+ORTM,1,SEQ,0) I $L(PROV) D - ...S ORY(+PROV)=+PROV_U_$P(^VA(200,+PROV,0),U) - S:'$D(ORY) ORY(1)="^No providers found." - Q -PERSPR(ORY) ; return list of personal lists linked to current user - N ORTM,I,ORTMN - S ORTM="",I=1 - F S ORTM=$O(^OR(100.21,"C",DUZ,ORTM)) Q:+$G(ORTM)<1 D - .Q:$P(^OR(100.21,ORTM,0),U,2)'="P" ;quit if not a personal list - .S ORTMN=$P(^OR(100.21,ORTM,0),U) - .S ORY(I)=ORTM_U_ORTMN,I=I+1 - S:+$G(ORY(1))<1 ORY(1)="^No personal lists found." - Q -PRIMPT(ORY,ORPT) ; return patient's PCMM primary care team - I +$G(ORPT)<1 S ORY(1)="^No patient identified" - N ORQPUR,ORQERROR,ORQLST,ORQERR,ORQDT,ORIDT,ORADT,ORX - S ORQPUR(2)="" ;"2" is the ien for purpose "primary care" [^SD(403.47] - D NOW^%DTC S ORQDT("BEGIN")=%-.0001,ORQDT("END")=%+.0001,ORQDT("INCL")=0 - S ORQERROR=$$TMPT^SCAPMC(.ORPT,"ORQDT","ORQPUR","ORQLST","ORQERR") - I ORQERROR=0 S ORY="^Error in search for primary care team." - I +$G(ORQLST(1))>0 D - .S ORX=ORQLST(1),ORADT=$P(ORX,U,4),ORIDT=$P(ORX,U,5) - .I ($G(ORADT)>$G(ORIDT)) S ORY=$P(ORX,U)_U_$P(ORX,U,2) - S:+$G(ORY)<1 ORY="^No primary care team found." - K % - Q -PROVPT(ORY,ORPT) ; return PCMM primary provider for a patient - I +$G(ORPT)<1 S ORY(1)="^No patient identified" - S ORY(1)=$$OUTPTPR^SDUTL3(ORPT,$$NOW^XLFDT,1) - Q -PPLINK(ORPROV,ORPT) ; returns '1' if patient is linked to provider - N ORX,ORPP - S ORX="",ORPP=0 - I (+$G(ORPT)<1)!(+$G(ORPROV)<1) Q 0 - I $D(^DPT("APR",ORPROV,ORPT)) Q "1^PRIM" ;provider is patient's primary - I $D(^DPT("AAP",ORPROV,ORPT)) Q "1^ATTD" ;provider is patient's attending - ;is provider and patient on the same team: - D TPROVPT(ORPROV) - F S ORX=$O(^TMP("ORLPUPT",$J,ORX)) Q:ORX="" D - .I +ORX=ORPT S ORPP="1^OERRTM" Q - K ^TMP("ORLPUPT",$J) - ; - ;If not linked already, see if linked via PCMM: - I ORPP=0 S ORPP=$$PCMMLINK(ORPROV,ORPT) - ; - Q ORPP -PDLINK(ORDEV,ORPT) ; returns '1' if patient is linked to device via team - ;ORDEV can be either ien or device name - N ORY,ORX,ORTM,ORDP,ORTMDEV,ORDEVIEN - S ORDP=0 - I (+$G(ORPT)<1)!($L($G(ORDEV))<1) Q 0 - ; Are device and patient on the same team?: - I '$D(^%ZIS(1,ORDEV,0)) D ;ORDEV is not an ien - .S ORDEVIEN=0,ORDEVIEN=$O(^%ZIS(1,"B",$P(ORDEV,U),ORDEVIEN)) - .S ORDEV=ORDEVIEN - Q:+$G(ORDEV)<1 0 - D TMSPT(.ORY,ORPT) - S ORX="" F S ORX=$O(ORY(ORX)) Q:ORX="" D - .S ORTM=ORY(ORX) - .I $D(^OR(100.21,+ORTM,0)),$P(^(0),U,4)=ORDEV S ORDP=1 Q - Q ORDP -PCMMLINK(ORPROV,ORPT) ;returns '1' if patient is linked to provider via PCMM - N ORPP,ORPCMM,ORPCP - S ORPP=0 - I (+$G(ORPT)<1)!(+$G(ORPROV)<1) Q 0 - ; - ;provider is patient's PCMM primary care practitioner: - I ORPROV=+$$OUTPTPR^SDUTL3(ORPT,$$NOW^XLFDT,1) Q "1^PCP" ;DBIA #1252 - ; - ;provider is patient's PCMM associate provider: - I ORPROV=+$$OUTPTAP^SDUTL3(ORPT,$$NOW^XLFDT) Q "1^AP" ;DBIA #1252 - ; - ;provider is linked to patient via PCMM team position assignment: - S ORPCMM=$$PRPT^SCAPMC(ORPT,,,,,,"^TMP(""ORPCMMLK"",$J)",) ;DBIA #1916 - S ORPCP=0 - F S ORPCP=$O(^TMP("ORPCMMLK",$J,"SCPR",ORPCP)) Q:'ORPCP!ORPP=1 D - .I ORPROV=ORPCP S ORPP="1^PCMMTM" - K ^TMP("ORPCMMLK",$J) - ; - Q ORPP -PUNSIGN(ORY,ORBDFN) ;rtns array of providers with unsigned orders for pt - N ORDG,ORX,ORZ,ORDNUM - S ORDG=$$DG^ORQOR1("ALL") ;get Display Group ien - K ^TMP("ORR",$J) - ;get unsigned orders: - D EN^ORQ1(ORBDFN_";DPT(",ORDG,11,"","","",0,0) - S ORX="",ORX=$O(^TMP("ORR",$J,ORX)) Q:ORX="" - I +$G(^TMP("ORR",$J,ORX,"TOT"))>0 D - .S ORX="" F S ORX=$O(^TMP("ORR",$J,ORX)) Q:ORX="" D - ..S ORZ="" F S ORZ=$O(^TMP("ORR",$J,ORX,ORZ)) Q:+$G(ORZ)<1 D - ...S ORDNUM=^TMP("ORR",$J,ORX,ORZ) - ...S ORY(+$$UNSIGNOR^ORQOR2(+ORDNUM))="" - K ^TMP("ORR",$J) - Q +ORQPTQ1 ; SLC/CLA - Functs which return OR patient lists and sources pt 1 ;12/15/97 [ 04/02/97 3:32 PM ] [6/6/01 11:34am] + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**9,74,63,91,85,139**;Dec 17, 1997 +VAMCPTS(Y) ; RETURN LIST OF PATIENTS IN VAMC: DFN^NAME + N I,J,V + S I=1 + S J=0 F S J=$O(^DPT("B",J)) Q:J="" S V=0,V=$O(^DPT("B",J,V)) S Y(I)=V_"^"_J,I=I+1 + Q +VAMCLONG(Y,DIR,FROM) ; return a bolus of patients in VAMC: DFN^NAME + N I,IEN,CNT S CNT=44 + I DIR=0 D ; Forward direction + . F I=1:1:CNT S FROM=$O(^DPT("B",FROM)) Q:FROM="" D + . . S Y(I)=$O(^DPT("B",FROM,0))_"^"_FROM + . I +$G(Y(CNT))="" S Y(I)="" + I DIR=1 D ; Reverse direction + . F I=1:1:CNT S FROM=$O(^DPT("B",FROM),-1) Q:FROM="" D + . . S Y(I)=$O(^DPT("B",FROM,0))_"^"_FROM + Q +DEFTM(ORY) ; return current user's default team list + Q:'$D(DUZ) + N ORSRV S ORSRV=$G(^VA(200,DUZ,5)) I +ORSRV>0 S ORSRV=$P(ORSRV,U) + S ORY=$$GET^XPAR("USR^SRV.`"_+$G(ORSRV),"ORLP DEFAULT TEAM",1,"B") + Q +TEAMS(ORY) ; return list of teams for a system + ; Also called under DBIA # 2692. + N ORTM,I,ORTMN + S ORTMN="",I=1 + F S ORTMN=$O(^OR(100.21,"B",ORTMN)) Q:ORTMN="" D + .S ORTM="",ORTM=$O(^OR(100.21,"B",ORTMN,ORTM)) Q:ORTM="" + .S ORY(I)=ORTM_U_ORTMN,I=I+1 + S:+$G(ORY(1))<1 ORY(1)="^No teams found." + Q +TEAMPTS(ORY,TEAM,TMPFLAG) ; RETURN LIST OF PATIENTS IN A TEAM + ; Also called under DBIA # 2692. + ; If TMPFLAG passed and = TRUE, code expects a "^TMP(xxx" + ; global root string passed in ORY, and builds the returned + ; list in that global instead of to a memory array. + N DOTMP,NEWTMP + S DOTMP=0 + I $G(TMPFLAG) D ; Was value passed? + .I TMPFLAG S DOTMP=1 ; Is value TRUE? + I +$G(TEAM)<1 D + .I DOTMP S NEWTMP=ORY_1_")",@NEWTMP="^No team identified" Q + .I 'DOTMP S ORY(1)="^No team identified" Q + N ORI,ORPT,I + S I=0 + S ORI=0 F S ORI=$O(^OR(100.21,+TEAM,10,ORI)) Q:ORI<1 D + .S ORPT=^OR(100.21,+TEAM,10,ORI,0) + .I DOTMP D + ..S I=I+1,NEWTMP=ORY_+I_")" + ..S @NEWTMP=+ORPT_U_$P(^DPT(+ORPT,0),U) + .I 'DOTMP S I=I+1,ORY(I)=+ORPT_U_$P(^DPT(+ORPT,0),U) + I DOTMP S:I<1 NEWTMP=ORY_1_")",@NEWTMP="^No patients found." + I 'DOTMP S:I<1 ORY(1)="^No patients found." + Q +TEAMPR(ORY,PROV) ; return list of teams linked to a provider + I +$G(PROV)<1 S ORY(1)="^No provider identified" Q + N ORTM,I,ORTMN + S ORTM="",I=1 + F S ORTM=$O(^OR(100.21,"C",+PROV,ORTM)) Q:+$G(ORTM)<1 D + .S ORTMN=$P(^OR(100.21,ORTM,0),U) + .S ORY(I)=ORTM_U_ORTMN,I=I+1 + S:+$G(ORY(1))<1 ORY(1)="^No teams found." + Q +TEAMPR2(ORY,PROV) ; return list of teams linked to a provider + ; This tag added by PKS/slc - 8/1999. + I +$G(PROV)<1 S ORY(1)="^No provider identified" Q + N ORTM,ORDATA,ORTMN,ORTYPE,I + S ORTM="",I=1 + F S ORTM=$O(^OR(100.21,"C",+PROV,ORTM)) Q:+$G(ORTM)<1 D + .S ORDATA=^OR(100.21,ORTM,0) ; Get value. + .S ORTMN=$P(ORDATA,U) ; Team List name. + .S ORTYPE=$P(ORDATA,U,2) ; Team List type. + .S ORY(I)=ORTM_U_ORTMN_U_ORTYPE,I=I+1 + S:+$G(ORY(1))<1 ORY(1)="^No teams found." + Q +TEAMPROV(ORY,TEAM) ; return list of providers linked to a team + I +$G(TEAM)<1 S ORY(1)="^No team identified" + N PROV,I,SEQ + S I=1 + S SEQ=0 F S SEQ=$O(^OR(100.21,+TEAM,1,SEQ)) Q:SEQ<1 D + .S PROV=^OR(100.21,+TEAM,1,SEQ,0) I $L(PROV) D + ..S ORY(I)=+PROV_U_$P(^VA(200,+PROV,0),U),I=I+1 + S:+$G(ORY(1))<1 ORY(1)="^No providers found." + Q +TPROVPT(PROV) ;return list of patients linked to a provider via teams + ; Modified by PKS: 8/1999. + I +$G(PROV)<1 S ^TMP("ORLPUPT",$J,"^No provider identified")="" + N ORTM,ORTMN,ORI,ORPT + S ORTM="" + F S ORTM=$O(^OR(100.21,"C",+PROV,ORTM)) Q:+$G(ORTM)<1 D ; Teams. + .S ORTMN=$P(^OR(100.21,+ORTM,0),U,1) ; Get name of Team List. + .S ORI=0 F S ORI=$O(^OR(100.21,+ORTM,10,ORI)) Q:ORI<1 D + ..S ORPT=^OR(100.21,+ORTM,10,ORI,0) + ..S ^TMP("ORLPUPT",$J,+ORPT_U_$P(^DPT(+ORPT,0),U))="" + ..; Next line added by PKS: + ..S ^TMP("ORLPUPT",$J,"B",ORTMN,$P(^DPT(+ORPT,0),U)_U_+ORPT)="" + I '$D(^TMP("ORLPUPT",$J)) S ^TMP("ORLPUPT",$J,"^No patients found.")="" + Q +TMSPT(ORY,PT) ;return list of teams linked to a patient (patient is active) + I +$G(PT)<1 S ORY(1)="^No patient identified" Q + N ORTM,I,ORTMN,ORTMTYP + S ORTM="",I=1 + F S ORTM=$O(^OR(100.21,"AB",+PT_";DPT(",ORTM)) Q:+$G(ORTM)<1 D + .S ORTMN=$P(^OR(100.21,ORTM,0),U) + .S ORTMTYP=$P(^OR(100.21,ORTM,0),U,2) I $L(ORTMTYP) D + ..S ORTMTYP=$$EXTERNAL^DILFD(100.21,1,"",ORTMTYP,"") + .S ORY(I)=ORTM_U_ORTMN_U_$S($L(ORTMTYP):ORTMTYP,1:"no type"),I=I+1 + S:+$G(ORY(1))<1 ORY(1)="^No teams found." + Q +TPTPR(ORY,PT) ;return list of providers linked to a patient via teams + I +$G(PT)<1 S ORY(1)="^No patient identified" Q + N ORTM,PROV,SEQ + S ORTM="" + F S ORTM=$O(^OR(100.21,"AB",+PT_";DPT(",ORTM)) Q:+$G(ORTM)<1 D + .S SEQ=0 F S SEQ=$O(^OR(100.21,+ORTM,1,SEQ)) Q:SEQ<1 D + ..S PROV=^OR(100.21,+ORTM,1,SEQ,0) I $L(PROV) D + ...S ORY(+PROV)=+PROV_U_$P(^VA(200,+PROV,0),U) + S:'$D(ORY) ORY(1)="^No providers found." + Q +PERSPR(ORY) ; return list of personal lists linked to current user + N ORTM,I,ORTMN + S ORTM="",I=1 + F S ORTM=$O(^OR(100.21,"C",DUZ,ORTM)) Q:+$G(ORTM)<1 D + .Q:$P(^OR(100.21,ORTM,0),U,2)'="P" ;quit if not a personal list + .S ORTMN=$P(^OR(100.21,ORTM,0),U) + .S ORY(I)=ORTM_U_ORTMN,I=I+1 + S:+$G(ORY(1))<1 ORY(1)="^No personal lists found." + Q +PRIMPT(ORY,ORPT) ; return patient's PCMM primary care team + I +$G(ORPT)<1 S ORY(1)="^No patient identified" + N ORQPUR,ORQERROR,ORQLST,ORQERR,ORQDT,ORIDT,ORADT,ORX + S ORQPUR(2)="" ;"2" is the ien for purpose "primary care" [^SD(403.47] + D NOW^%DTC S ORQDT("BEGIN")=%-.0001,ORQDT("END")=%+.0001,ORQDT("INCL")=0 + S ORQERROR=$$TMPT^SCAPMC(.ORPT,"ORQDT","ORQPUR","ORQLST","ORQERR") + I ORQERROR=0 S ORY="^Error in search for primary care team." + I +$G(ORQLST(1))>0 D + .S ORX=ORQLST(1),ORADT=$P(ORX,U,4),ORIDT=$P(ORX,U,5) + .I ($G(ORADT)>$G(ORIDT)) S ORY=$P(ORX,U)_U_$P(ORX,U,2) + S:+$G(ORY)<1 ORY="^No primary care team found." + K % + Q +PROVPT(ORY,ORPT) ; return PCMM primary provider for a patient + I +$G(ORPT)<1 S ORY(1)="^No patient identified" + S ORY(1)=$$OUTPTPR^SDUTL3(ORPT,$$NOW^XLFDT,1) + Q +PPLINK(ORPROV,ORPT) ; returns '1' if patient is linked to provider + N ORX,ORPP + S ORX="",ORPP=0 + I (+$G(ORPT)<1)!(+$G(ORPROV)<1) Q 0 + I $D(^DPT("APR",ORPROV,ORPT)) Q "1^PRIM" ;provider is patient's primary + I $D(^DPT("AAP",ORPROV,ORPT)) Q "1^ATTD" ;provider is patient's attending + ;is provider and patient on the same team: + D TPROVPT(ORPROV) + F S ORX=$O(^TMP("ORLPUPT",$J,ORX)) Q:ORX="" D + .I +ORX=ORPT S ORPP="1^OERRTM" Q + K ^TMP("ORLPUPT",$J) + ; + ;If not linked already, see if linked via PCMM: + I ORPP=0 S ORPP=$$PCMMLINK(ORPROV,ORPT) + ; + Q ORPP +PDLINK(ORDEV,ORPT) ; returns '1' if patient is linked to device via team + ;ORDEV can be either ien or device name + N ORY,ORX,ORTM,ORDP,ORTMDEV,ORDEVIEN + S ORDP=0 + I (+$G(ORPT)<1)!($L($G(ORDEV))<1) Q 0 + ; Are device and patient on the same team?: + I '$D(^%ZIS(1,ORDEV,0)) D ;ORDEV is not an ien + .S ORDEVIEN=0,ORDEVIEN=$O(^%ZIS(1,"B",$P(ORDEV,U),ORDEVIEN)) + .S ORDEV=ORDEVIEN + Q:+$G(ORDEV)<1 0 + D TMSPT(.ORY,ORPT) + S ORX="" F S ORX=$O(ORY(ORX)) Q:ORX="" D + .S ORTM=ORY(ORX) + .I $D(^OR(100.21,+ORTM,0)),$P(^(0),U,4)=ORDEV S ORDP=1 Q + Q ORDP +PCMMLINK(ORPROV,ORPT) ;returns '1' if patient is linked to provider via PCMM + N ORPP,ORPCMM,ORPCP + S ORPP=0 + I (+$G(ORPT)<1)!(+$G(ORPROV)<1) Q 0 + ; + ;provider is patient's PCMM primary care practitioner: + I ORPROV=+$$OUTPTPR^SDUTL3(ORPT,$$NOW^XLFDT,1) Q "1^PCP" ;DBIA #1252 + ; + ;provider is patient's PCMM associate provider: + I ORPROV=+$$OUTPTAP^SDUTL3(ORPT,$$NOW^XLFDT) Q "1^AP" ;DBIA #1252 + ; + ;provider is linked to patient via PCMM team position assignment: + S ORPCMM=$$PRPT^SCAPMC(ORPT,,,,,,"^TMP(""ORPCMMLK"",$J)",) ;DBIA #1916 + S ORPCP=0 + F S ORPCP=$O(^TMP("ORPCMMLK",$J,"SCPR",ORPCP)) Q:'ORPCP!ORPP=1 D + .I ORPROV=ORPCP S ORPP="1^PCMMTM" + K ^TMP("ORPCMMLK",$J) + ; + Q ORPP +PUNSIGN(ORY,ORBDFN) ;rtns array of providers with unsigned orders for pt + N ORDG,ORX,ORZ,ORDNUM + S ORDG=$$DG^ORQOR1("ALL") ;get Display Group ien + K ^TMP("ORR",$J) + ;get unsigned orders: + D EN^ORQ1(ORBDFN_";DPT(",ORDG,11,"","","",0,0) + S ORX="",ORX=$O(^TMP("ORR",$J,ORX)) Q:ORX="" + I +$G(^TMP("ORR",$J,ORX,"TOT"))>0 D + .S ORX="" F S ORX=$O(^TMP("ORR",$J,ORX)) Q:ORX="" D + ..S ORZ="" F S ORZ=$O(^TMP("ORR",$J,ORX,ORZ)) Q:+$G(ORZ)<1 D + ...S ORDNUM=^TMP("ORR",$J,ORX,ORZ) + ...S ORY(+$$UNSIGNOR^ORQOR2(+ORDNUM))="" + K ^TMP("ORR",$J) + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQQAL.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQQAL.m index 61a69254..d78b18a1 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQQAL.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQQAL.m @@ -1,135 +1,134 @@ -ORQQAL ; slc/CLA,JFR - Functions which return patient allergy data ;6/8/06 14:11 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**9,85,162,190,216,232,243**;Dec 17, 1997;Build 242 -LIST(ORAY,ORPT) ; RETURN PATIENT'S ALLERGY/ADVERSE REACTION INFO: - ; null:no allergy assessment, 0:no known allergies, 1:pt has allergies - ; if 1 also get: allergen/reactant^reaction/symptom^severity^allergy ien - N I,J,K - S I=1,J=0,K=0 - D EN1^GMRAOR1(ORPT,"GMRARXN") - I $G(GMRARXN)="" S ORAY(I)="^No Allergy Assessment" - I $G(GMRARXN)=0 S ORAY(I)="^No Known Allergies" - I $G(GMRARXN)=1 F S J=$O(GMRARXN(J)) Q:J="" S ORAY(I)=$P(GMRARXN(J),"^",3)_"^"_$P(GMRARXN(J),"^")_"^"_$P(GMRARXN(J),"^",2) D SIGNS S I=I+1 - S:'$D(ORAY(1)) ORAY(1)="^No allergies found." - K GMRARXN - Q -SIGNS S K=0,N=0 F S K=$O(GMRARXN(J,"S",K)) Q:K'>0 D - .I N=0 S ORAY(I)=ORAY(I)_"^"_$P(GMRARXN(J,"S",K),";") - .E S ORAY(I)=ORAY(I)_";"_$P(GMRARXN(J,"S",K),";") - .S N=N+1 - Q -LRPT(ORAY,ORPT) ; RETURN PT'S ALLERGY/ADVERSE REACTION INFO IN REPORT FORMAT: - ; null:no allergy assessment, 0:no known allergies, 1:pt has allergies - ; if 1 also get: allergen/reactant^reaction/symptom^severity^allergy ien - N I,J,K,SEVER,CR,GMRAIDT ;216 - S CR=$CHAR(13) - S I=1,J=0,K=0,SEVER="",GMRAIDT=1 ;216 - D EN1^GMRAOR1(ORPT,"GMRARXN") - I $G(GMRARXN)="" S ORAY(I)="No Allergy Assessment" - I $G(GMRARXN)=0 S ORAY(I)="No Known Allergies" - I $G(GMRARXN)=1 F S J=$O(GMRARXN(J)) Q:J="" D - .S SEVER=$P(GMRARXN(J),U,2) - .S ORAY(I)=$P(GMRARXN(J),U)_" "_$S($L($G(SEVER)):"[Severity: "_SEVER_"]",1:""),I=I+1 - .S K=0,N=0 F S K=$O(GMRARXN(J,"S",K)) Q:K'>0 D - ..I N=0 S ORAY(I)=" Signs/symptoms: "_$P(GMRARXN(J,"S",K),";") - ..E S ORAY(I)=" "_$P(GMRARXN(J,"S",K),";") - ..I $P(GMRARXN(J,"S",K),";",2) S ORAY(I)=ORAY(I)_" ("_$$FMTE^XLFDT($P(GMRARXN(J,"S",K),";",2),2)_")" ;216 - ..S N=N+1,I=I+1 - .S ORAY(I)=" ",I=I+1 - S:'$D(ORAY(1)) ORAY(1)="No allergies found." - K GMRARXN - Q -RXN(ORAY,ORPT,SRC,NDF,PSDRUG) ; RETURN TRUE OR FALSE IF PATIENT IS ALLERGIC TO AGENT - ; SRC: ALLERGEN SOURCE (CM=CONTRAST MEDIA, DR=DRUG) - ; NDF: IF SRC=DR, NDF=Nat'l Drug File ien ELSE NDF="" - ; PSDRUG:IF SRC=DR, PSDRUG=(local) Drug file ien ELSE PSDRUG="" - S ORAY=$$ORCHK^GMRAOR(ORPT,SRC,NDF) - I SRC="DR",ORAY=1 D ;drug ingredient allergy found - .S I=1,J=0 F S J=$O(GMRAING(J)) Q:J="" D - ..I I=1 S ORAY=ORAY_U_GMRAING(J) - ..E S ORAY=ORAY_";"_GMRAING(J) - ..S I=I+1 - I SRC="DR",ORAY=2 D ;drug class allergy found - .S CL="",I=1,J=0 F S J=$O(GMRADRCL(J)) Q:J="" D - ..; per test sites 3/17/04 - no oc for pt allergy to entire HERBS class: - ..Q:$P(GMRADRCL(J),U)="HA000" - ..I I=1 S ORAY=ORAY_U_$P(GMRADRCL(J),U,2) - ..E S CL=$P(GMRADRCL(J),U,2) I ORAY'[CL S ORAY=ORAY_";"_CL - ..S I=I+1 - I SRC="DR",(+$G(ORAY)<1) D MEDCLASS(.ORAY,ORPT,PSDRUG) - K I,J,GMRADRCL,GMRAING,CL - Q -MEDCLASS(ORAY,DFN,PSDRUG) ;check for allergens with medications in same VA drug class - N ORVACLS,CL,X,I,RET,TYP - S TYP="DR" - Q:+$G(PSDRUG)<1 - ;S ORVACLS=$P(^PSDRUG(PSDRUG,0),U,2) - S ORVACLS=$$CLASS50^ORPEAPI(PSDRUG) - Q:$L(ORVACLS)<4 - Q:$G(ORVACLS)="HA000" ;don't process herbal drug class for order checks - S CL=$S($E(ORVACLS,1,4)="CN10":5,1:4) ;look at 5 chars if ANALGESICS - D GETDATA^GMRAOR(DFN) - Q:'$D(^TMP("GMRAOC",$J,"APC")) - S I="" F S I=$O(^TMP("GMRAOC",$J,"APC",I)) Q:'$L(I) D - .I $E(I,1,CL)=$E(ORVACLS,1,CL) S X=I - I $L($G(X)) D - .N IEN,NAME - .D IEN^PSN50P65(,X,"ORQQAL") - .S IEN=$O(^TMP($J,"ORQQAL","B",X,0)) - .I 'IEN S ORAY="2"_U_X Q - .S NAME=$G(^TMP($J,"ORQQAL",IEN,1)) - .I '$L(NAME) S ORAY="2"_U_X Q - .S ORAY="2"_U_NAME_": ("_$G(^TMP("GMRAOC",$J,"APC",X))_")" - K ^TMP("GMRAOC",$J) - Q -DETAIL(ORAY,DFN,ALLR,ID) ; RETURN DETAILED ALLERGY INFO FOR SPECIFIED ALLERGIC REACTION: - D EN1^GMRAOR2(ALLR,"GMRACT") - N CR,OX,OH S CR=$CHAR(13),I=1 - S ORAY(I)=" Causative agent: "_$P(GMRACT,U),I=I+1 - S ORAY(I)=" Nature of Reaction: "_$S($P(GMRACT,U,6)="ALLERGY":"Allergy",$P(GMRACT,U,6)="PHARMACOLOGIC":"Adverse Reaction",$P(GMRACT,U,6)="UNKNOWN":"Unknown",1:""),I=I+1 ;216 - S ORAY(I)=" ",I=I+1 - I $D(GMRACT("S",1)) D SYMP - I $D(GMRACT("V",1)) D CLAS - S ORAY(I)=" Originator: "_$P(GMRACT,U,2)_$S($L($P(GMRACT,U,3)):" ("_$P(GMRACT,U,3)_")",1:""),I=I+1 ;216 - S ORAY(I)=" Originated: "_$P(GMRACT,U,10),I=I+1 ;216 - I $D(GMRACT("O",1)) D OBS - S ORAY(I)=" Verified: "_$S($P(GMRACT,U,4)="VERIFIED":$P(GMRACT,U,8),1:"No"),I=I+1 ;216 - S ORAY(I)="Observed/Historical: "_$S($P(GMRACT,U,5)="OBSERVED":"Observed",$P(GMRACT,U,5)="HISTORICAL":"Historical",1:""),I=I+1 - I $D(GMRACT("C",1)) D COM - K GMRACT - Q -SYMP S K=0,N=0 F S K=$O(GMRACT("S",K)) Q:K'>0 D - .I N=0 S ORAY(I)=" Signs/symptoms: "_GMRACT("S",K),I=I+1 - .E S ORAY(I)=" "_GMRACT("S",K),I=I+1 - .S N=N+1 - S ORAY(I)=" ",I=I+1 - K N,K - Q -CLAS S K=0,N=0 F S K=$O(GMRACT("V",K)) Q:K'>0 D - .I N=0 S ORAY(I)=" Drug Classes: "_$P(GMRACT("V",K),U,2),I=I+1 - .E S ORAY(I)=" "_$P(GMRACT("V",K),U,2),I=I+1 - .S N=N+1 - S ORAY(I)=" ",I=I+1 - K N,K - Q -OBS S K=0,N=0 F S K=$O(GMRACT("O",K)) Q:K'>0 D - .I N=0 D - ..S Y=$P(GMRACT("O",K),U) D DD^%DT - ..S ORAY(I)=" Obs dates/severity: "_Y_" "_$P(GMRACT("O",K),U,2),I=I+1 - .E D - ..S Y=$P(GMRACT("O",K),U) D DD^%DT - ..S ORAY(I)=" "_Y_" "_$P(GMRACT("O",K),U,2),I=I+1 - .S N=N+1 - S ORAY(I)=" ",I=I+1 - K N,K,Y - Q -COM S K=0,N=0,ORAY(I)=" ",I=I+1 - F S K=$O(GMRACT("C",K)) Q:K'>0 D - .I N=0 S ORAY(I)="Comments:",I=I+1 - .S Y=$P(GMRACT("C",K),U) D DD^%DT - .S ORAY(I)=" "_Y_" by "_$P(GMRACT("C",K),U,2),I=I+1 - .I $D(GMRACT("C",K,1,0)) S L=0 F S L=$O(GMRACT("C",K,L)) Q:L'>0 D - ..S ORAY(I)=GMRACT("C",K,L,0),I=I+1 - .S N=N+1 - S ORAY(I)=" ",I=I+1 - K N,K,L,Y - Q +ORQQAL ; slc/CLA,JFR - Functions which return patient allergy data ;6/8/06 14:11 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**9,85,162,190,216,232**;Dec 17, 1997;Build 19 +LIST(ORAY,ORPT) ; RETURN PATIENT'S ALLERGY/ADVERSE REACTION INFO: + ; null:no allergy assessment, 0:no known allergies, 1:pt has allergies + ; if 1 also get: allergen/reactant^reaction/symptom^severity^allergy ien + N I,J,K + S I=1,J=0,K=0 + D EN1^GMRAOR1(ORPT,"GMRARXN") + I $G(GMRARXN)="" S ORAY(I)="^No Allergy Assessment" + I $G(GMRARXN)=0 S ORAY(I)="^No Known Allergies" + I $G(GMRARXN)=1 F S J=$O(GMRARXN(J)) Q:J="" S ORAY(I)=$P(GMRARXN(J),"^",3)_"^"_$P(GMRARXN(J),"^")_"^"_$P(GMRARXN(J),"^",2) D SIGNS S I=I+1 + S:'$D(ORAY(1)) ORAY(1)="^No allergies found." + K GMRARXN + Q +SIGNS S K=0,N=0 F S K=$O(GMRARXN(J,"S",K)) Q:K'>0 D + .I N=0 S ORAY(I)=ORAY(I)_"^"_$P(GMRARXN(J,"S",K),";") + .E S ORAY(I)=ORAY(I)_";"_$P(GMRARXN(J,"S",K),";") + .S N=N+1 + Q +LRPT(ORAY,ORPT) ; RETURN PT'S ALLERGY/ADVERSE REACTION INFO IN REPORT FORMAT: + ; null:no allergy assessment, 0:no known allergies, 1:pt has allergies + ; if 1 also get: allergen/reactant^reaction/symptom^severity^allergy ien + N I,J,K,SEVER,CR,GMRAIDT ;216 + S CR=$CHAR(13) + S I=1,J=0,K=0,SEVER="",GMRAIDT=1 ;216 + D EN1^GMRAOR1(ORPT,"GMRARXN") + I $G(GMRARXN)="" S ORAY(I)="No Allergy Assessment" + I $G(GMRARXN)=0 S ORAY(I)="No Known Allergies" + I $G(GMRARXN)=1 F S J=$O(GMRARXN(J)) Q:J="" D + .S SEVER=$P(GMRARXN(J),U,2) + .S ORAY(I)=$P(GMRARXN(J),U)_" "_$S($L($G(SEVER)):"[Severity: "_SEVER_"]",1:""),I=I+1 + .S K=0,N=0 F S K=$O(GMRARXN(J,"S",K)) Q:K'>0 D + ..I N=0 S ORAY(I)=" Signs/symptoms: "_$P(GMRARXN(J,"S",K),";") + ..E S ORAY(I)=" "_$P(GMRARXN(J,"S",K),";") + ..I $P(GMRARXN(J,"S",K),";",2) S ORAY(I)=ORAY(I)_" ("_$$FMTE^XLFDT($P(GMRARXN(J,"S",K),";",2),2)_")" ;216 + ..S N=N+1,I=I+1 + .S ORAY(I)=" ",I=I+1 + S:'$D(ORAY(1)) ORAY(1)="No allergies found." + K GMRARXN + Q +RXN(ORAY,ORPT,SRC,NDF,PSDRUG) ; RETURN TRUE OR FALSE IF PATIENT IS ALLERGIC TO AGENT + ; SRC: ALLERGEN SOURCE (CM=CONTRAST MEDIA, DR=DRUG) + ; NDF: IF SRC=DR, NDF=Nat'l Drug File ien ELSE NDF="" + ; PSDRUG:IF SRC=DR, PSDRUG=(local) Drug file ien ELSE PSDRUG="" + S ORAY=$$ORCHK^GMRAOR(ORPT,SRC,NDF) + I SRC="DR",ORAY=1 D ;drug ingredient allergy found + .S I=1,J=0 F S J=$O(GMRAING(J)) Q:J="" D + ..I I=1 S ORAY=ORAY_U_GMRAING(J) + ..E S ORAY=ORAY_";"_GMRAING(J) + ..S I=I+1 + I SRC="DR",ORAY=2 D ;drug class allergy found + .S CL="",I=1,J=0 F S J=$O(GMRADRCL(J)) Q:J="" D + ..; per test sites 3/17/04 - no oc for pt allergy to entire HERBS class: + ..Q:$P(GMRADRCL(J),U)="HA000" + ..I I=1 S ORAY=ORAY_U_$P(GMRADRCL(J),U,2) + ..E S CL=$P(GMRADRCL(J),U,2) I ORAY'[CL S ORAY=ORAY_";"_CL + ..S I=I+1 + I SRC="DR",(+$G(ORAY)<1) D MEDCLASS(.ORAY,ORPT,PSDRUG) + K I,J,GMRADRCL,GMRAING,CL + Q +MEDCLASS(ORAY,DFN,PSDRUG) ;check for allergens with medications in same VA drug class + N ORVACLS,CL,X,I,RET,TYP + S TYP="DR" + Q:+$G(PSDRUG)<1 + S ORVACLS=$P(^PSDRUG(PSDRUG,0),U,2) + Q:$L(ORVACLS)<4 + Q:$G(ORVACLS)="HA000" ;don't process herbal drug class for order checks + S CL=$S($E(ORVACLS,1,4)="CN10":5,1:4) ;look at 5 chars if ANALGESICS + D GETDATA^GMRAOR(DFN) + Q:'$D(^TMP("GMRAOC",$J,"APC")) + S I="" F S I=$O(^TMP("GMRAOC",$J,"APC",I)) Q:'$L(I) D + .I $E(I,1,CL)=$E(ORVACLS,1,CL) S X=I + I $L($G(X)) D + .N IEN,NAME + .D IEN^PSN50P65(,X,"ORQQAL") + .S IEN=$O(^TMP($J,"ORQQAL","B",X,0)) + .I 'IEN S ORAY="2"_U_X Q + .S NAME=$G(^TMP($J,"ORQQAL",IEN,1)) + .I '$L(NAME) S ORAY="2"_U_X Q + .S ORAY="2"_U_NAME_": ("_$G(^TMP("GMRAOC",$J,"APC",X))_")" + K ^TMP("GMRAOC",$J) + Q +DETAIL(ORAY,DFN,ALLR,ID) ; RETURN DETAILED ALLERGY INFO FOR SPECIFIED ALLERGIC REACTION: + D EN1^GMRAOR2(ALLR,"GMRACT") + N CR,OX,OH S CR=$CHAR(13),I=1 + S ORAY(I)=" Causative agent: "_$P(GMRACT,U),I=I+1 + S ORAY(I)=" Nature of Reaction: "_$S($P(GMRACT,U,6)="ALLERGY":"Allergy",$P(GMRACT,U,6)="PHARMACOLOGIC":"Adverse Reaction",$P(GMRACT,U,6)="UNKNOWN":"Unknown",1:""),I=I+1 ;216 + S ORAY(I)=" ",I=I+1 + I $D(GMRACT("S",1)) D SYMP + I $D(GMRACT("V",1)) D CLAS + S ORAY(I)=" Originator: "_$P(GMRACT,U,2)_$S($L($P(GMRACT,U,3)):" ("_$P(GMRACT,U,3)_")",1:""),I=I+1 ;216 + S ORAY(I)=" Originated: "_$P(GMRACT,U,10),I=I+1 ;216 + I $D(GMRACT("O",1)) D OBS + S ORAY(I)=" Verified: "_$S($P(GMRACT,U,4)="VERIFIED":$P(GMRACT,U,8),1:"No"),I=I+1 ;216 + S ORAY(I)="Observed/Historical: "_$S($P(GMRACT,U,5)="OBSERVED":"Observed",$P(GMRACT,U,5)="HISTORICAL":"Historical",1:""),I=I+1 + I $D(GMRACT("C",1)) D COM + K GMRACT + Q +SYMP S K=0,N=0 F S K=$O(GMRACT("S",K)) Q:K'>0 D + .I N=0 S ORAY(I)=" Signs/symptoms: "_GMRACT("S",K),I=I+1 + .E S ORAY(I)=" "_GMRACT("S",K),I=I+1 + .S N=N+1 + S ORAY(I)=" ",I=I+1 + K N,K + Q +CLAS S K=0,N=0 F S K=$O(GMRACT("V",K)) Q:K'>0 D + .I N=0 S ORAY(I)=" Drug Classes: "_$P(GMRACT("V",K),U,2),I=I+1 + .E S ORAY(I)=" "_$P(GMRACT("V",K),U,2),I=I+1 + .S N=N+1 + S ORAY(I)=" ",I=I+1 + K N,K + Q +OBS S K=0,N=0 F S K=$O(GMRACT("O",K)) Q:K'>0 D + .I N=0 D + ..S Y=$P(GMRACT("O",K),U) D DD^%DT + ..S ORAY(I)=" Obs dates/severity: "_Y_" "_$P(GMRACT("O",K),U,2),I=I+1 + .E D + ..S Y=$P(GMRACT("O",K),U) D DD^%DT + ..S ORAY(I)=" "_Y_" "_$P(GMRACT("O",K),U,2),I=I+1 + .S N=N+1 + S ORAY(I)=" ",I=I+1 + K N,K,Y + Q +COM S K=0,N=0,ORAY(I)=" ",I=I+1 + F S K=$O(GMRACT("C",K)) Q:K'>0 D + .I N=0 S ORAY(I)="Comments:",I=I+1 + .S Y=$P(GMRACT("C",K),U) D DD^%DT + .S ORAY(I)=" "_Y_" by "_$P(GMRACT("C",K),U,2),I=I+1 + .I $D(GMRACT("C",K,1,0)) S L=0 F S L=$O(GMRACT("C",K,L)) Q:L'>0 D + ..S ORAY(I)=GMRACT("C",K,L,0),I=I+1 + .S N=N+1 + S ORAY(I)=" ",I=I+1 + K N,K,L,Y + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQQPL1.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQQPL1.m index cce36547..7a045fe4 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQQPL1.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQQPL1.m @@ -1,256 +1,257 @@ -ORQQPL1 ; ALB/PDR/REV - PROBLEM LIST FOR CPRS GUI ; 02/12/08 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,148,173,203,206,249,243**;Dec 17, 1997;Build 242 - ; - ;------------------------- GET PROBLEM FROM LEXICON ------------------- - ; -LEXSRCH(LIST,FROM,N,VIEW,ORDATE) ; Get candidate Problems from LEX file - N LEX,VAL,VAL1,COD,CIEN,SYS,MAX,NAME - S:'+$G(ORDATE) ORDATE=DT - S:'$G(N) N=100 - S:'$L($G(VIEW)) VIEW="PL1" - D CONFIG^LEXSET("GMPL",VIEW,ORDATE) - D LOOK^LEXA(FROM,"GMPL",N,"",ORDATE) - S S=0 - F S S=$O(LEX("LIST",S)) Q:S<1 D - . S VAL1=LEX("LIST",S) - . S COD="",CIEN="",SYS="",NAME="" - . I $L(VAL1,"CPT-4 ")>1 D - .. S SYS="ICD-9-CM " - .. S COD="799.9" - .. S CIEN="" - .. S NAME=$P(VAL1," (CPT-4") - . I $L(VAL1,"DSM-IV ")>1 D - .. S SYS="DSM-IV " - .. S COD=$P($P(VAL1,SYS,2),")") - .. S:COD["/" COD=$P(COD,"/",1) - .. S CIEN=$$CODEN^ICDCODE($$ICDONE^LEXU($P(VAL1,U,1),ORDATE),80) - .. S NAME=$P(VAL1," (DSM-IV") - .. ; - . I $L(VAL1,"(TITLE 38 ")>1 D - .. S SYS="TITLE 38 " - .. S COD=$P($P(VAL1,SYS,2),")") - .. S:COD["/" COD=$P(COD,"/",1) - .. S CIEN=$$CODEN^ICDCODE($$ICDONE^LEXU($P(VAL1,U,1),ORDATE),80) - .. S NAME=$P(VAL1,"(TITLE 38 ") - .. ; - . I $L(VAL1,"ICD-9-CM ")>1 D - .. S SYS="ICD-9-CM " - .. S COD=$P($P(VAL1,SYS,2),")") - .. S:COD["/" COD=$P(COD,"/",1) - .. S CIEN=+$$CODEN^ICDCODE(COD,80) - .. S NAME=$P(VAL1," (ICD-9-CM") - . I $L(NAME)=0 S NAME=$P($P(VAL1," (")," *") - . ; - . ; jeh Clean left over codes - . S NAME=$P(NAME," (CPT-4") - . S NAME=$P(NAME," (DSM-IV") - . S NAME=$P(NAME,"(TITLE 38 ") - . S NAME=$P(NAME," (ICD-9-CM") - . ; - . S VAL=NAME_U_COD_U_CIEN_U_SYS ; ien^.01^icd^icdifn^system - . S LIST(S)=VAL - . S MAX=S - I $G(MAX)'="" S LIST(MAX+1)=$G(LEX("MAT")) - K ^TMP("LEXSCH",$J) - Q - ; -ICDREC(COD) ; - N CODIEN - I COD="" Q "" - S COD=$P($P(COD,U),"/") - S CODIEN=+$O(^ICD9("AB",COD_" ",0)) - S:CODIEN'>0 CODIEN=+$O(^ICD9("AB",COD_"0 ",0)) - Q CODIEN - ;Q $O(^ICD9("BA",COD,"")) - ; -CPTREC(COD) ; - I COD="" Q "" - Q $O(^ICPT("BA",COD,"")) - ; -EDLOAD(RETURN,DA,GMPROV,GMPVAMC) ; LOAD EDIT ARRAYS - ; DA=problem IFN - N I,GMPFLD,GMPORIG,GMPL - D GETFLDS^GMPLEDT3(DA) - S I=0 - D LOADFLDS(.RETURN,"GMPFLD","NEW",.I) - D LOADFLDS(.RETURN,"GMPORIG","ORG",.I) - K GMPFLD,GMPORIG,GMPL ; should not have to do this - Q - ; -LOADFLDS(RETURN,NAM,TYP,I) ; LOAD FIELDS FOR TYPE OF ARRAY - N S,V,CVP,PN,PID - S S="",V=$C(254) - F S S=$O(@NAM@(S)) Q:S=10 D - . S RETURN(I)=TYP_V_S_V_@NAM@(S) - . S I=I+1 - S S="" - F S S=$O(@NAM@(10,S)) Q:S="" D - . S CVP=@NAM@(10,S) - . S PN="" ; provider name - . S PID=$P(CVP,U,6) ; provider id - . I PID'="" S PN=$$GET1^DIQ(200,PID,.01) ; get provider name - . S RETURN(I)=TYP_V_"10,"_S_V_CVP_U_PN - . S I=I+1 - Q - ; -EDSAVE(RETURN,GMPIFN,GMPROV,GMPVAMC,UT,EDARRAY) ; SAVE EDITED RES - ; RETURN - boolean, 1 success, 0 failure - ; EDARRAY - array used for indirect sets of GMPORIG() and GMPFLDS() - ; - N GMPFLD,GMPORIG,S,GMPLUSER - S RETURN=1 ; initialize for success - I UT S GMPLUSER=1 - ; - ;S GMPLUSER=1 - S S="" - F S S=$O(EDARRAY(S)) Q:S="" D - . S @EDARRAY(S) - I $D(GMPFLD(10,"NEW"))>9 D I 'RETURN Q ; Bail Out if no lock - . L +^AUPNPROB(GMPIFN,11):10 ; given bogus nature of this lock, should be able to get - . I '$T S RETURN=0 - ; - D EN^GMPLSAVE ; save the data - K GMPFLD,GMPORIG - ; - L -^AUPNPROB(GMPIFN,11) ; free this instance of lock (in case it was set) - S RETURN=1 - Q - ; -UPDATE(ORRETURN,UPDARRAY) ; UPDATE A PROBLEM RECORD - ; Does essentially same job as EDSAVE above, however does not handle edits to comments - ; or addition of multiple comments. - ; Use initially just for status updates. - ; - N S,GMPL,GMPORIG ; last 2 vars created in nested call - S S="" - F S S=$O(UPDARRAY(S)) Q:S="" D - . S @UPDARRAY(S) - D UPDATE^GMPLUTL(.ORARRAY,.ORRETURN) - K ORARRAY - ; broker wont pick up root node RETURN - S ORRETURN(1)=ORRETURN(0) ; error text - S ORRETURN(0)=ORRETURN ; gmpdfn - I ORRETURN(0)="" S ORRETURN=1 ; insurance ? need - Q - ; -ADDSAVE(RETURN,GMPDFN,GMPROV,GMPVAMC,ADDARRAY) ; SAVE NEW RECORD - ; RETURN - Problem IFN if success, 0 otherwise - ; ADDARRAY - array used for indirect sets of GMPFLDS() - ; - N DA,GMPFLD,GMPORIG,S - S RETURN=0 ; - L +^AUPNPROB(0):10 - Q:'$T ; bail out if no lock - ; - S S="" - F S S=$O(ADDARRAY(S)) Q:S="" D - . S @ADDARRAY(S) - ; - D NEW^GMPLSAVE - ; - S RETURN=DA - ; - L -^AUPNPROB(0) - S RETURN=1 - Q - ; -INITUSER(RETURN,ORDUZ) ; INITIALIZE FOR NEW USER - ; taken from INIT^GMPLMGR - ; leave GMPLUSER on symbol table - is evaluated in EDITSAVE - ; - N X,PV,CTXT,GMPLPROV - S GMPLUSER=$$CLINUSER(DUZ) - S CTXT=$$GET^XPAR("ALL","ORCH CONTEXT PROBLEMS",1) - S X=$G(^GMPL(125.99,1,0)) ; IN1+6^GMPLMGR - S RETURN(0)=GMPLUSER ; problem list user, or other user - S RETURN(1)=$$VIEW^GMPLX1(DUZ) ; GMPLVIEW("VIEW") - users default view - S RETURN(2)=+$P(X,U,2) ; verify transcribed problems - S RETURN(3)=+$P(X,U,3) ; prompt for chart copy - S RETURN(4)=+$P(X,U,4) ; use lexicon - S RETURN(5)=$S($P(X,U,5)="R":1,1:0) ; chron or reverse chron listing - S RETURN(6)=$S($P($G(CTXT),";",3)'="":$P($G(CTXT),";",3),1:"A") - S GMPLPROV=$P($G(CTXT),";",5) - I +GMPLPROV>0,$D(^VA(200,GMPLPROV)) D - . S RETURN(7)=GMPLPROV_U_$P(^VA(200,GMPLPROV,0),U) - E S RETURN(7)="0^All" - S RETURN(8)=$$SERVICE^GMPLX1(DUZ) ; user's service/section - ; Guessing from what I see in the data that $$VIEW^GMPLX1 actually returns a composite - ; of default view (in/out patient)/(c1/c2... if out patient i.e. GMPLVIEW("CLIN")) or - ; /(s1/s2... if in patient i.e. GMPLVIEW("SERV")) - ; Going with this assumption for now: - I $L(RETURN(1),"/")>1 D - . S PV=RETURN(1) - . S RETURN(1)=$P(PV,"/") - . I RETURN(1)="C" S GMPLVIEW("CLIN")=$P(PV,"/",2,99) - . I RETURN(1)="S" S GMPLVIEW("SERV")=$P(PV,"/",2,99) - S RETURN(9)=$G(GMPLVIEW("SERV")) ; ??? Where from - see tech doc - S RETURN(10)=$G(GMPLVIEW("CLIN")) ; ??? Where from - see tech doc - S RETURN(11)="" - S RETURN(12)=+$P($G(CTXT),";",4) ; should comments display? - K GMPLVIEW - Q - ; -CLINUSER(ORDUZ) ;is this a clinical user? - N ORUSER - S ORUSER=0 - I $D(^XUSEC("ORES",ORDUZ)) S ORUSER=1 - I $D(^XUSEC("ORELSE",ORDUZ)) S ORUSER=1 - I $D(^XUSEC("PROVIDER",ORDUZ)) S ORUSER=1 - Q ORUSER - ; -INITPT(RETURN,DFN) ; GET PATIENT PARAMETERS - Q:+$G(DFN)=0 - N GMPSC,GMPAGTOR,GMPION,GMPGULF,GMPHNC,GMPMST,GMPCV,GMPSHD - ; - S RETURN(0)=DUZ(2) ; facility # - D DEM^VADPT ; get death indicator - S RETURN(1)=$G(VADM(6)) ; death indicator - D VADPT^GMPLX1(DFN) ; get eligibilities - S RETURN(2)=$P(GMPSC,U) ; service connected - S RETURN(3)=$G(GMPAGTOR) ; agent orange exposure - S RETURN(4)=$G(GMPION) ; ionizing radiation exposure - S RETURN(5)=$G(GMPGULF) ; gulf war exposure - S RETURN(6)=VA("BID") ; need this to reconstitute GMPDFN on return - S RETURN(7)=$G(GMPHNC) ; head/neck cancer - S RETURN(8)=$G(GMPMST) ; MST - S RETURN(9)=$G(GMPCV) ; CV - S RETURN(10)=$G(GMPSHD) ; SHAD - Q - ; -PROVSRCH(LST,FLAG,N,FROM,PART) ; Get candidate Rroviders from person file - N LV,NS,RV,IEN - S RV=$NAME(LV("DILIST","ID")) - IF +$G(N)=0 S N=50 - S FLAG=$G(FLAG),N=$G(N),FROM=$G(FROM),PART=$G(PART) - D LIST^DIC(200,"",".01;1",FLAG,N,FROM,PART,"","","","LV") - S NS="" - F S NS=$O(LV("DILIST",1,NS)) Q:NS="" D - . S IEN="" - . S IEN=$O(^VA(200,"B",@RV@(NS,.01),IEN)) ; compliments of PROV^ORQPTQ - . S LST(NS)=IEN_U_@RV@(NS,.01) ; initials_U_@RV@(NS,1) - Q - ; -CLINSRCH(Y,X) ; Get LIST OF CLINICS - ; Note: This comes from CLIN^ORQPTQ2, where it was commented out in place of - ; a call to ^XPAR. I would have just used CLIN^ORQPTQ2, but it didn't work - at - ; least on SLC OEX directory. - ; X has no purpose other than to satisfy apparent rpc and tcallv requirement for args - N I,NAME,IEN - S I=1,IEN=0,NAME="" - ;access to SC global granted under DBIA #518: - F S NAME=$O(^SC("B",NAME)) Q:NAME="" S IEN=$O(^(NAME,0)) D - . I $P(^SC(IEN,0),"^",3)="C" S Y(I)=IEN_"^"_NAME,I=I+1 - Q - ; -SRVCSRCH(Y,FROM,DIR,ALL) ; GET LIST OF SERVICES - N I,IEN,CNT S I=0,CNT=44 - F Q:I=CNT S FROM=$O(^DIC(49,"B",FROM),DIR) Q:FROM="" D - . S IEN=$O(^DIC(49,"B",FROM,0)) I '$G(ALL),$P(^DIC(49,IEN,0),U,9)'="C" Q - . S I=I+1,Y(I)=IEN_"^"_FROM - Q - ; -DUP(Y,DFN,TERM,TEXT) ;Check for duplicate problem - S Y=$$DUPL^GMPLX(DFN,TERM,TEXT) Q:+Y=0 - I $P(^AUPNPROB(Y,1),U,2)="H" S Y=0 Q - S Y=Y_U_$P(^AUPNPROB(Y,0),U,12) - Q +ORQQPL1 ; ALB/PDR/REV - PROBLEM LIST FOR CPRS GUI ;03/12/02 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,148,173,203,206,249**;Dec 17, 1997 + ; + ;------------------------- GET PROBLEM FROM LEXICON ------------------- + ; +LEXSRCH(LIST,FROM,N,VIEW,ORDATE) ; Get candidate Problems from LEX file + N LEX,VAL,VAL1,COD,CIEN,SYS,MAX,NAME + S:'+$G(ORDATE) ORDATE=DT + S:'$G(N) N=100 + S:'$L($G(VIEW)) VIEW="PL1" + D CONFIG^LEXSET("GMPL",VIEW,ORDATE) + D LOOK^LEXA(FROM,"GMPL",N,"",ORDATE) + S S=0 + F S S=$O(LEX("LIST",S)) Q:S<1 D + . S VAL1=LEX("LIST",S) + . S COD="",CIEN="",SYS="",NAME="" + . I $L(VAL1,"CPT-4 ")>1 D + .. ;S SYS="CPT-4 " + .. ;S COD=$P($P(VAL1,SYS,2),")") + .. ;S:COD["/" COD=$P(COD,"/",1) + .. ;. S CIEN=$$CODEN^ICPTCOD(COD) + .. S SYS="ICD-9-CM " + .. S COD="799.9" + .. S CIEN="" + .. S NAME=$P(VAL1," (CPT-4") + . I $L(VAL1,"DSM-IV ")>1 D + .. S SYS="DSM-IV " + .. S COD=$P($P(VAL1,SYS,2),")") + .. S:COD["/" COD=$P(COD,"/",1) + .. S CIEN=$$CODEN^ICDCODE($$ICDONE^LEXU($P(VAL1,U,1),ORDATE),80) + .. S NAME=$P(VAL1," (DSM-IV") + .. ; + . I $L(VAL1,"(TITLE 38 ")>1 D + .. S SYS="TITLE 38 " + .. S COD=$P($P(VAL1,SYS,2),")") + .. S:COD["/" COD=$P(COD,"/",1) + .. S CIEN=$$CODEN^ICDCODE($$ICDONE^LEXU($P(VAL1,U,1),ORDATE),80) + .. S NAME=$P(VAL1,"(TITLE 38 ") + .. ; + . I $L(VAL1,"ICD-9-CM ")>1 D + .. S SYS="ICD-9-CM " + .. S COD=$P($P(VAL1,SYS,2),")") + .. S:COD["/" COD=$P(COD,"/",1) + .. S CIEN=+$$CODEN^ICDCODE(COD,80) + .. S NAME=$P(VAL1," (ICD-9-CM") + . I $L(NAME)=0 S NAME=$P($P(VAL1," (")," *") + . ; + . ; jeh Clean left over codes + . S NAME=$P(NAME," (CPT-4") + . S NAME=$P(NAME," (DSM-IV") + . S NAME=$P(NAME,"(TITLE 38 ") + . S NAME=$P(NAME," (ICD-9-CM") + . ; + . S VAL=NAME_U_COD_U_CIEN_U_SYS ; ien^.01^icd^icdifn^system + . S LIST(S)=VAL + . S MAX=S + I $G(MAX)'="" S LIST(MAX+1)=$G(LEX("MAT")) + Q + ; +ICDREC(COD) ; + N CODIEN + I COD="" Q "" + S COD=$P($P(COD,U),"/") + S CODIEN=+$O(^ICD9("AB",COD_" ",0)) + S:CODIEN'>0 CODIEN=+$O(^ICD9("AB",COD_"0 ",0)) + Q CODIEN + ;Q $O(^ICD9("BA",COD,"")) + ; +CPTREC(COD) ; + I COD="" Q "" + Q $O(^ICPT("BA",COD,"")) + ; +EDLOAD(RETURN,DA,GMPROV,GMPVAMC) ; LOAD EDIT ARRAYS + ; DA=problem IFN + N I,GMPFLD,GMPORIG,GMPL + D GETFLDS^GMPLEDT3(DA) + S I=0 + D LOADFLDS(.RETURN,"GMPFLD","NEW",.I) + D LOADFLDS(.RETURN,"GMPORIG","ORG",.I) + K GMPFLD,GMPORIG,GMPL ; should not have to do this + Q + ; +LOADFLDS(RETURN,NAM,TYP,I) ; LOAD FIELDS FOR TYPE OF ARRAY + N S,V,CVP,PN,PID + S S="",V=$C(254) + F S S=$O(@NAM@(S)) Q:S=10 D + . S RETURN(I)=TYP_V_S_V_@NAM@(S) + . S I=I+1 + S S="" + F S S=$O(@NAM@(10,S)) Q:S="" D + . S CVP=@NAM@(10,S) + . S PN="" ; provider name + . S PID=$P(CVP,U,6) ; provider id + . I PID'="" S PN=$$GET1^DIQ(200,PID,.01) ; get provider name + . S RETURN(I)=TYP_V_"10,"_S_V_CVP_U_PN + . S I=I+1 + Q + ; +EDSAVE(RETURN,GMPIFN,GMPROV,GMPVAMC,UT,EDARRAY) ; SAVE EDITED RES + ; RETURN - boolean, 1 success, 0 failure + ; EDARRAY - array used for indirect sets of GMPORIG() and GMPFLDS() + ; + N GMPFLD,GMPORIG,S,GMPLUSER + S RETURN=1 ; initialize for success + I UT S GMPLUSER=1 + ; + ;S GMPLUSER=1 + S S="" + F S S=$O(EDARRAY(S)) Q:S="" D + . S @EDARRAY(S) + I $D(GMPFLD(10,"NEW"))>9 D I 'RETURN Q ; Bail Out if no lock + . L +^AUPNPROB(GMPIFN,11):10 ; given bogus nature of this lock, should be able to get + . I '$T S RETURN=0 + ; + D EN^GMPLSAVE ; save the data + K GMPFLD,GMPORIG + ; + L -^AUPNPROB(GMPIFN,11) ; free this instance of lock (in case it was set) + S RETURN=1 + Q + ; +UPDATE(ORRETURN,UPDARRAY) ; UPDATE A PROBLEM RECORD + ; Does essentially same job as EDSAVE above, however does not handle edits to comments + ; or addition of multiple comments. + ; Use initially just for status updates. + ; + N S,GMPL,GMPORIG ; last 2 vars created in nested call + S S="" + F S S=$O(UPDARRAY(S)) Q:S="" D + . S @UPDARRAY(S) + D UPDATE^GMPLUTL(.ORARRAY,.ORRETURN) + K ORARRAY + ; broker wont pick up root node RETURN + S ORRETURN(1)=ORRETURN(0) ; error text + S ORRETURN(0)=ORRETURN ; gmpdfn + I ORRETURN(0)="" S ORRETURN=1 ; insurance ? need + Q + ; +ADDSAVE(RETURN,GMPDFN,GMPROV,GMPVAMC,ADDARRAY) ; SAVE NEW RECORD + ; RETURN - Problem IFN if success, 0 otherwise + ; ADDARRAY - array used for indirect sets of GMPFLDS() + ; + N DA,GMPFLD,GMPORIG,S + S RETURN=0 ; + L +^AUPNPROB(0):10 + Q:'$T ; bail out if no lock + ; + S S="" + F S S=$O(ADDARRAY(S)) Q:S="" D + . S @ADDARRAY(S) + ; + D NEW^GMPLSAVE + ; + S RETURN=DA + ; + L -^AUPNPROB(0) + S RETURN=1 + Q + ; +INITUSER(RETURN,ORDUZ) ; INITIALIZE FOR NEW USER + ; taken from INIT^GMPLMGR + ; leave GMPLUSER on symbol table - is evaluated in EDITSAVE + ; + N X,PV,CTXT,GMPLPROV + S GMPLUSER=$$CLINUSER(DUZ) + S CTXT=$$GET^XPAR("ALL","ORCH CONTEXT PROBLEMS",1) + S X=$G(^GMPL(125.99,1,0)) ; IN1+6^GMPLMGR + S RETURN(0)=GMPLUSER ; problem list user, or other user + S RETURN(1)=$$VIEW^GMPLX1(DUZ) ; GMPLVIEW("VIEW") - users default view + S RETURN(2)=+$P(X,U,2) ; verify transcribed problems + S RETURN(3)=+$P(X,U,3) ; prompt for chart copy + S RETURN(4)=+$P(X,U,4) ; use lexicon + S RETURN(5)=$S($P(X,U,5)="R":1,1:0) ; chron or reverse chron listing + S RETURN(6)=$S($P($G(CTXT),";",3)'="":$P($G(CTXT),";",3),1:"A") + S GMPLPROV=$P($G(CTXT),";",5) + I +GMPLPROV>0,$D(^VA(200,GMPLPROV)) D + . S RETURN(7)=GMPLPROV_U_$P(^VA(200,GMPLPROV,0),U) + E S RETURN(7)="0^All" + S RETURN(8)=$$SERVICE^GMPLX1(DUZ) ; user's service/section + ; Guessing from what I see in the data that $$VIEW^GMPLX1 actually returns a composite + ; of default view (in/out patient)/(c1/c2... if out patient i.e. GMPLVIEW("CLIN")) or + ; /(s1/s2... if in patient i.e. GMPLVIEW("SERV")) + ; Going with this assumption for now: + I $L(RETURN(1),"/")>1 D + . S PV=RETURN(1) + . S RETURN(1)=$P(PV,"/") + . I RETURN(1)="C" S GMPLVIEW("CLIN")=$P(PV,"/",2,99) + . I RETURN(1)="S" S GMPLVIEW("SERV")=$P(PV,"/",2,99) + S RETURN(9)=$G(GMPLVIEW("SERV")) ; ??? Where from - see tech doc + S RETURN(10)=$G(GMPLVIEW("CLIN")) ; ??? Where from - see tech doc + S RETURN(11)="" + S RETURN(12)=+$P($G(CTXT),";",4) ; should comments display? + K GMPLVIEW + Q + ; +CLINUSER(ORDUZ) ;is this a clinical user? + N ORUSER + S ORUSER=0 + I $D(^XUSEC("ORES",ORDUZ)) S ORUSER=1 + I $D(^XUSEC("ORELSE",ORDUZ)) S ORUSER=1 + I $D(^XUSEC("PROVIDER",ORDUZ)) S ORUSER=1 + Q ORUSER + ; +INITPT(RETURN,DFN) ; GET PATIENT PARAMETERS + Q:+$G(DFN)=0 + N GMPSC,GMPAGTOR,GMPION,GMPGULF,GMPHNC,GMPMST + ; + S RETURN(0)=DUZ(2) ; facility # + D DEM^VADPT ; get death indicator + S RETURN(1)=$G(VADM(6)) ; death indicator + D VADPT^GMPLX1(DFN) ; get eligibilities + S RETURN(2)=$P(GMPSC,U) ; service connected + S RETURN(3)=$G(GMPAGTOR) ; agent orange exposure + S RETURN(4)=$G(GMPION) ; ionizing radiation exposure + S RETURN(5)=$G(GMPGULF) ; gulf war exposure + S RETURN(6)=VA("BID") ; need this to reconstitute GMPDFN on return + S RETURN(7)=$G(GMPHNC) ; head/neck cancer + S RETURN(8)=$G(GMPMST) ; MST + Q + ; +PROVSRCH(LST,FLAG,N,FROM,PART) ; Get candidate Rroviders from person file + N LV,NS,RV,IEN + S RV=$NAME(LV("DILIST","ID")) + IF +$G(N)=0 S N=50 + S FLAG=$G(FLAG),N=$G(N),FROM=$G(FROM),PART=$G(PART) + D LIST^DIC(200,"",".01;1",FLAG,N,FROM,PART,"","","","LV") + S NS="" + F S NS=$O(LV("DILIST",1,NS)) Q:NS="" D + . S IEN="" + . S IEN=$O(^VA(200,"B",@RV@(NS,.01),IEN)) ; compliments of PROV^ORQPTQ + . S LST(NS)=IEN_U_@RV@(NS,.01) ; initials_U_@RV@(NS,1) + Q + ; +CLINSRCH(Y,X) ; Get LIST OF CLINICS + ; Note: This comes from CLIN^ORQPTQ2, where it was commented out in place of + ; a call to ^XPAR. I would have just used CLIN^ORQPTQ2, but it didn't work - at + ; least on SLC OEX directory. + ; X has no purpose other than to satisfy apparent rpc and tcallv requirement for args + N I,NAME,IEN + S I=1,IEN=0,NAME="" + ;access to SC global granted under DBIA #518: + F S NAME=$O(^SC("B",NAME)) Q:NAME="" S IEN=$O(^(NAME,0)) D + . I $P(^SC(IEN,0),"^",3)="C" S Y(I)=IEN_"^"_NAME,I=I+1 + Q + ; +SRVCSRCH(Y,FROM,DIR,ALL) ; GET LIST OF SERVICES + N I,IEN,CNT S I=0,CNT=44 + F Q:I=CNT S FROM=$O(^DIC(49,"B",FROM),DIR) Q:FROM="" D + . S IEN=$O(^DIC(49,"B",FROM,0)) I '$G(ALL),$P(^DIC(49,IEN,0),U,9)'="C" Q + . S I=I+1,Y(I)=IEN_"^"_FROM + Q + ; +DUP(Y,DFN,TERM,TEXT) ;Check for duplicate problem + S Y=$$DUPL^GMPLX(DFN,TERM,TEXT) Q:+Y=0 + I $P(^AUPNPROB(Y,1),U,2)="H" S Y=0 Q + S Y=Y_U_$P(^AUPNPROB(Y,0),U,12) + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQQPL3.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQQPL3.m index bdbe0c45..8798ff33 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQQPL3.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQQPL3.m @@ -1,247 +1,243 @@ -ORQQPL3 ; ALB/PDR/REV ; Problem List RPC's ; 8-OCT-1998 09:08:49.29 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,148,173,243**;Dec 17, 1997;Build 242 - ; - ;---------------- LIST PATIENT PROBLEMS ------------------------ - ; -PROBL(ROOT,DFN,CONTEXT) ; GET LIST OF PATIENT PROBLEMS - N DIWL,DIWR,DIWF - N ST,ORI,ORX - S (LCNT,NUM)=0 - S DIWL=1,DIWR=48,DIWF="C48" - S CONTEXT=";;"_$G(CONTEXT) - I CONTEXT=";;" S CONTEXT=";;A" - S ST=$P(CONTEXT,";",3) - ; - I ST="R" D DELLIST(.ROOT,+DFN) ; show deleted only - I ST'="R" D LIST(.ROOT,+DFN,ST) ; show others - don't trust ELSE here - ; - I ROOT(0)<1 D - . S LCNT=1 - . S ROOT(1)=" "_$$PAD^ORCHTAB("No data available.",49)_"|" - Q - ; - ; -LIST(GMPL,GMPDFN,GMPSTAT) ; -- Returns list of problems for patient GMPDFN - ; in GMPL(#)=ifn^status^description^ICD^onset^last modified^SC^SpExp^Condition^Loc^ - ; loc.type^prov^service - ; & GMPL(0)=number of problems returned - ; This is virtually same as LIST^GMPLUTL2 except that it appends the - ; condition - T)ranscribed or P)ermanent,location,loc type,provider, service. - ; - N I,IFN,CNT,GMPL0,GMPL1,SP,ST,NUM,ONSET,ICD,LASTMOD,PRIO,DTREC - N SC,ORLIST,ORVIEW,GMPARAM,ORTOTAL,LIN,LOC,LT,PROV,SERV,HASCMT - N SCCOND,AO,IR,ENV,HNC,MST,CV,SHD,ORICD186,INACT - Q:$G(GMPDFN)'>0 - S CNT=0,SP="" - S GMPARAM("QUIET")=1 - S GMPARAM("REV")=$P($G(^GMPL(125.99,1,0)),U,5)="R" - S ORVIEW("ACT")=GMPSTAT - S ORVIEW("PROV")=0 - S ORVIEW("VIEW")="" - S ORICD186=$$PATCH^XPDUTL("ICD*18.0*6") - ; - D GETPLIST^GMPLMGR1(.ORLIST,.ORTOTAL,.ORVIEW) - ; - F NUM=0:0 S NUM=$O(ORLIST(NUM)) Q:NUM'>0 D - . S IFN=+ORLIST(NUM) Q:IFN'>0 - . S INACT="" - . S GMPL0=$G(^AUPNPROB(IFN,0)) - . S GMPL1=$G(^AUPNPROB(IFN,1)) - . S HASCMT=($D(^AUPNPROB(IFN,11,0))>0) - . S CNT=CNT+1 - . I +ORICD186 D - . . S ICD=$$CODEC^ICDCODE(+GMPL0) - . . I '+$$STATCHK^ICDAPIU(ICD,DT) S INACT="#" - . E D - . . S ICD=$P($G(^ICD9(+GMPL0,0)),U) - . S LASTMOD=$P(GMPL0,U,3) - . S ST=$P(GMPL0,U,12) - . S ONSET=$P(GMPL0,U,13) - . S SC=$S(+$P(GMPL1,U,10):"SC",$P(GMPL1,U,10)=0:"NSC",1:"") - . S AO=$S(+$P(GMPL1,U,11):"/AO",1:"") - . S IR=$S(+$P(GMPL1,U,12):"/IR",1:"") - . S ENV=$S(+$P(GMPL1,U,13):"/EC",1:"") - . S HNC=$S(+$P(GMPL1,U,15):"/HNC",1:"") - . S MST=$S(+$P(GMPL1,U,16):"/MST",1:"") - . S CV=$S(+$P(GMPL1,U,17):"/CV",1:"") - . S SHD=$S(+$P(GMPL1,U,18):"/SHD",1:"") - . S SCCOND=SC_AO_IR_ENV_HNC_MST_CV_SHD - . S LOC=$P(GMPL1,U,8) - . S DTREC=$P(GMPL1,U,9) - . S LT="" - . I LOC'="" S LT=$P($G(^SC(LOC,0)),"^",3),LOC=LOC_";"_$P($G(^SC(LOC,0)),U,1) - . S PROV=$P(GMPL1,U,5) ; responsible provider - . I PROV'="" S PROV=PROV_";"_$P($G(^VA(200,PROV,0)),U,1) - . S SERV=$P(GMPL1,U,6) - . I SERV=0 S SERV="" ; not sure how it gets set to 0, but need consistency in GUI - . I SERV'="" S SERV=SERV_";"_$P($G(^DIC(49,SERV,0)),U,1) - . S SP="" - . F I=11,12,13 S:$P(GMPL1,U,I) SP=SP_$S(I=11:"A",I=12:"I",1:"P") - . S PRIO=$P(GMPL1,U,14) - . S LIN=IFN_U_ST_U_$$PROBTEXT^GMPLX(IFN)_U_ICD_U_ONSET - . S LIN=LIN_U_LASTMOD_U_SC_U_SP_U_$P(GMPL1,U,2) - . S LIN=LIN_U_LOC_U_LT_U_PROV_U_SERV_U_PRIO_U_HASCMT_U_DTREC_U_SCCOND_U_INACT - . S GMPL(CNT)=LIN - S GMPL(0)=CNT - Q - ; - ; - ;------------------------------------- GET LIST OF DELETED PROBLEMS ----------------------------- - ; -DELLIST(RETURN,GMPDFN) ; GET LIST OF DELETED PROBLEMS - ; see GETPLIST^GMPLMGR1 and LIST^GMPUTL2 - N S,IFN,I,L0,L1,ST,TXT,ICD,ONSET,MOD,SC,SP,LOC,LT,PROV,SERV,PRIO,HASCMT,DTREC - N SCCOND,AO,IR,ENV,HNC,MST,CV,SHD,ORICD186,INACT - S I=0,S="" - S ORICD186=$$PATCH^XPDUTL("ICD*18.0*6") - F S S=$O(^AUPNPROB("ACTIVE",GMPDFN,S)) Q:S="" D - . S IFN="" - . F S IFN=$O(^AUPNPROB("ACTIVE",+GMPDFN,S,IFN)) Q:IFN="" D - .. I $P($G(^AUPNPROB(IFN,1)),U,2)="H" D - ... S L0=$G(^AUPNPROB(IFN,0)) - ... Q:L0="" - ... S INACT="" - ... S L1=$G(^AUPNPROB(IFN,1)) - ... S ST=$P(L0,U,12) - ... S TXT=$$PROBTEXT^GMPLX(IFN) - ... I +ORICD186 D - ... . S ICD=$$CODEC^ICDCODE(+L0) - ... . I '+$$STATCHK^ICDAPIU(ICD,DT) S INACT="#" - ... E D - ... . S ICD=$P($G(^ICD9(+L0,0)),U) - ... S ONSET=$P(L0,U,13) - ... S MOD=$P(L0,U,3) - ... S SC=$S(+$P(L1,U,10):"SC",$P(L1,U,10)=0:"NSC",1:"") - ... S AO=$S(+$P(L1,U,11):"/AO",1:"") - ... S IR=$S(+$P(L1,U,12):"/IR",1:"") - ... S ENV=$S(+$P(L1,U,13):"/EC",1:"") - ... S HNC=$S(+$P(L1,U,15):"/HNC",1:"") - ... S MST=$S(+$P(L1,U,16):"/MST",1:"") - ... S CV=$S(+$P(L1,U,17):"/CV",1:"") - ... S SHD=$S(+$P(L1,U,18):"/SHD",1:"") - ... S SCCOND=SC_AO_IR_ENV_HNC_MST_CV_SHD - ... S SP=$$GETSP - ... S LOC=$P(L1,U,8) - ... S LT="" - ... I LOC'="" S LT=$P($G(^SC(LOC,0)),"^",3) - ... S PROV=$P(L1,U,5) ; responsible provider - ... S SERV=$P(L1,U,6) - ... S PRIO=$P(L1,U,14) - ... S HASCMT=($D(^AUPNPROB(IFN,11,0))>0) - ... S DTREC=$P(L1,U,9) - ... S I=I+1 - ... S RETURN(I)=IFN_U_ST_U_TXT_U_ICD_U_ONSET - ... S RETURN(I)=RETURN(I)_U_MOD_U_SC_U_SP_U_$P(L1,U,2) - ... S RETURN(I)=RETURN(I)_U_LOC_U_LT_U_PROV_U_SERV - ... S RETURN(I)=RETURN(I)_U_PRIO_U_HASCMT_U_DTREC_U_SCCOND_U_INACT - S RETURN(0)=I - Q - ; -GETSP() ; GET EXPOSURES - N I - S SP="" - F I=11,12,13 S:$P(L1,U,I) SP=SP_$S(I=11:"A",I=12:"I",1:"P") - Q SP - ; - ; adapted from ^GMPLBLD3 ;9/96 - ; - ; ----------------------- GET USER PROBLEM CATEGORIES -------------- - ; -CAT(TMP,ORDUZ,CLIN) ; Get user category list - N GSEQ,GCNT,GROUP,HDR,IFN,LCNT,ITEM,TG,GMPLSLST - ; S TG=$NAME(^TMP("GMPLMENU",$J)) ; put list in global for testing - S TG=$NAME(TMP) ; put list in local - K @TG - S (GSEQ,GCNT,LCNT)=0 - ; - S GMPLSLST=$$GETUSLST(DUZ,CLIN) ; get approp list for user - ; Build multiple of category\problems - ; Iterate categories - F S GSEQ=$O(^GMPL(125.1,"C",+GMPLSLST,GSEQ)) Q:GSEQ'>0 D - . S IFN=$O(^GMPL(125.1,"C",+GMPLSLST,GSEQ,0)) Q:IFN'>0 - . S ITEM=$G(^GMPL(125.1,IFN,0)) - . S GROUP=+$P(ITEM,U,3) - . S HDR=GROUP_U_$P(ITEM,U,4,5) - . S GCNT=GCNT+1 - . S @TG@(GCNT)=HDR ; put category into temp global - Q - ; -GETUSLST(ORDUZ,CLIN) ; GET AN APPROPRIATE CATEGORY LIST FOR THE USER - N GMPLSLST - S GMPLSLST=$P($G(^VA(200,DUZ,125)),U,2) - ;I 'GMPLSLST D - I 'GMPLSLST,CLIN,$D(^GMPL(125,"C",+CLIN)) S GMPLSLST=$O(^(+CLIN,0)) - ;. S GMPLSLST=$O(^VA(200,DUZ,+CLIN,0)) ;$O(^(+CLIN,0)) - Q GMPLSLST - ; - ;----------------------- USER PROBLEM LIST -------------------------- - ; -PROB(TMP,GROUP) ; Get user problem list for given group - N PSEQ,PCNT,IFN,ITEM,TG,CODE,TEXT,ORICD186 - ; S TG=$NAME(^TMP("GMPLMENU",$J)) ; put list in global for testing - S TG=$NAME(TMP) ; put list in local - K @TG - S LCNT=0 - S ORICD186=$$PATCH^XPDUTL("ICD*18.0*6") - ; - ; iterate through problems in category - S (PSEQ,PCNT)=0 - F S PSEQ=$O(^GMPL(125.12,"C",GROUP,PSEQ)) Q:PSEQ'>0 D - . S IFN=$O(^GMPL(125.12,"C",GROUP,PSEQ,0)) Q:IFN'>0 - . S ITEM=$G(^GMPL(125.12,IFN,0)) - . S TEXT=$P(ITEM,U,4) - . ; SEE DD for GMPL(125.12,4 : - . ; "...code which is to be displayed... generally assumed to be ICD" - . S CODE=$P(ITEM,U,5) - . I +ORICD186,'+$$STATCHK^ICDAPIU(CODE,DT) Q - . S PCNT=PCNT+1 - . ; RETURN: - . ; PROBLEM^DISPLAY TEXT^CODE^CODE IFN - . I +ORICD186 D - . . S @TG@(PCNT)=$P(ITEM,U,3,5)_U_$$CODEN^ICDCODE(CODE,80) - . E D - . . S @TG@(PCNT)=$P(ITEM,U,3,5)_U_$$ICDCODE(CODE) - Q - ; -ICDCODE(COD) ; RETURN INTERNAL ICD FOR EXTERNAL CODE (obsolete after CSV patches released - RV) - N CODIEN - I COD="" Q "" - S CODIEN=+$O(^ICD9("AB",$P(COD,U)_" ",0)) - S:CODIEN'>0 CODIEN=+$O(^ICD9("AB",$P(COD,U)_"0 ",0)) - Q CODIEN - ; - ;------------------ Filter Providers --------------------- - ; -GETRPRV(RETURN,INP) ; GET LIST OF RESPONSIBLE PROVIDERS FROM PRBLM LIST - ; RETURN - aa list of responsible providers from which to select for filtering - ; INP - array of problem list providers to select from - ; - N S - S S="" - F I=1:1 S S=$O(INP(S)) Q:S="" D - . I INP(S)'="",$G(^VA(200,INP(S),0))'="" D Q ; get next - .. S RETURN(I)=INP(S)_U_$P(^VA(200,INP(S),0),U) - S RETURN(0)="-1"_U_"" ; return empty provider - Q - ; - ;---------------------------------------------------- GET FILTERED CLINIC LIST ------------------------ - ; -GETCLIN(RETURN,INP) ; Get FILTERED LIST OF CLINICS - ; RETURN NAMES FOR LIST OF CLINICS PASSED IN - N I,S - S S="" - F I=1:1 S S=$O(INP(S)) Q:S="" D - . I INP(S)'="",$G(^SC(INP(S),0))'="" D Q ; get next - .. S RETURN(I)=INP(S)_U_$P(^SC(INP(S),0),U,1) - ;. S RETURN(I)="-1"_U_"None" ; return empty location - Q - ; -GETSRVC(RETURN,INP) ; GET FILTERED LIST OF INPATIENT SERVICES - ; RETURN NAMES FOR LIST OF IEN PASSED IN - N I,S - S S="" - F I=1:1 S S=$O(INP(S)) Q:S="" D - . I INP(S)'="",$G(^DIC(49,INP(S),0))'="" D Q ; get next - .. S RETURN(I)=INP(S)_U_$P(^DIC(49,INP(S),0),U,1) - ;. S RETURN(I)="-1"_U_"None" ; return empty service - Q +ORQQPL3 ; ALB/PDR/REV ; Problem List RPC's ; 8-OCT-1998 09:08:49.29 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,148,173**;Dec 17, 1997 + ; + ;---------------- LIST PATIENT PROBLEMS ------------------------ + ; +PROBL(ROOT,DFN,CONTEXT) ; GET LIST OF PATIENT PROBLEMS + N DIWL,DIWR,DIWF + N ST,ORI,ORX + S (LCNT,NUM)=0 + S DIWL=1,DIWR=48,DIWF="C48" + S CONTEXT=";;"_$G(CONTEXT) + I CONTEXT=";;" S CONTEXT=";;A" + S ST=$P(CONTEXT,";",3) + ; + I ST="R" D DELLIST(.ROOT,+DFN) ; show deleted only + I ST'="R" D LIST(.ROOT,+DFN,ST) ; show others - don't trust ELSE here + ; + I ROOT(0)<1 D + . S LCNT=1 + . S ROOT(1)=" "_$$PAD^ORCHTAB("No data available.",49)_"|" + Q + ; + ; +LIST(GMPL,GMPDFN,GMPSTAT) ; -- Returns list of problems for patient GMPDFN + ; in GMPL(#)=ifn^status^description^ICD^onset^last modified^SC^SpExp^Condition^Loc^ + ; loc.type^prov^service + ; & GMPL(0)=number of problems returned + ; This is virtually same as LIST^GMPLUTL2 except that it appends the + ; condition - T)ranscribed or P)ermanent,location,loc type,provider, service. + ; + N I,IFN,CNT,GMPL0,GMPL1,SP,ST,NUM,ONSET,ICD,LASTMOD,PRIO,DTREC + N SC,ORLIST,ORVIEW,GMPARAM,ORTOTAL,LIN,LOC,LT,PROV,SERV,HASCMT + N SCCOND,AO,IR,ENV,HNC,MST,ORICD186,INACT + Q:$G(GMPDFN)'>0 + S CNT=0,SP="" + S GMPARAM("QUIET")=1 + S GMPARAM("REV")=$P($G(^GMPL(125.99,1,0)),U,5)="R" + S ORVIEW("ACT")=GMPSTAT + S ORVIEW("PROV")=0 + S ORVIEW("VIEW")="" + S ORICD186=$$PATCH^XPDUTL("ICD*18.0*6") + ; + D GETPLIST^GMPLMGR1(.ORLIST,.ORTOTAL,.ORVIEW) + ; + F NUM=0:0 S NUM=$O(ORLIST(NUM)) Q:NUM'>0 D + . S IFN=+ORLIST(NUM) Q:IFN'>0 + . S INACT="" + . S GMPL0=$G(^AUPNPROB(IFN,0)) + . S GMPL1=$G(^AUPNPROB(IFN,1)) + . S HASCMT=($D(^AUPNPROB(IFN,11,0))>0) + . S CNT=CNT+1 + . I +ORICD186 D + . . S ICD=$$CODEC^ICDCODE(+GMPL0) + . . I '+$$STATCHK^ICDAPIU(ICD,DT) S INACT="#" + . E D + . . S ICD=$P($G(^ICD9(+GMPL0,0)),U) + . S LASTMOD=$P(GMPL0,U,3) + . S ST=$P(GMPL0,U,12) + . S ONSET=$P(GMPL0,U,13) + . S SC=$S(+$P(GMPL1,U,10):"SC",$P(GMPL1,U,10)=0:"NSC",1:"") + . S AO=$S(+$P(GMPL1,U,11):"/AO",1:"") + . S IR=$S(+$P(GMPL1,U,12):"/IR",1:"") + . S ENV=$S(+$P(GMPL1,U,13):"/EC",1:"") + . S HNC=$S(+$P(GMPL1,U,15):"/HNC",1:"") + . S MST=$S(+$P(GMPL1,U,16):"/MST",1:"") + . S SCCOND=SC_AO_IR_ENV_HNC_MST + . S LOC=$P(GMPL1,U,8) + . S DTREC=$P(GMPL1,U,9) + . S LT="" + . I LOC'="" S LT=$P($G(^SC(LOC,0)),"^",3),LOC=LOC_";"_$P($G(^SC(LOC,0)),U,1) + . S PROV=$P(GMPL1,U,5) ; responsible provider + . I PROV'="" S PROV=PROV_";"_$P($G(^VA(200,PROV,0)),U,1) + . S SERV=$P(GMPL1,U,6) + . I SERV=0 S SERV="" ; not sure how it gets set to 0, but need consistency in GUI + . I SERV'="" S SERV=SERV_";"_$P($G(^DIC(49,SERV,0)),U,1) + . S SP="" + . F I=11,12,13 S:$P(GMPL1,U,I) SP=SP_$S(I=11:"A",I=12:"I",1:"P") + . S PRIO=$P(GMPL1,U,14) + . S LIN=IFN_U_ST_U_$$PROBTEXT^GMPLX(IFN)_U_ICD_U_ONSET + . S LIN=LIN_U_LASTMOD_U_SC_U_SP_U_$P(GMPL1,U,2) + . S LIN=LIN_U_LOC_U_LT_U_PROV_U_SERV_U_PRIO_U_HASCMT_U_DTREC_U_SCCOND_U_INACT + . S GMPL(CNT)=LIN + S GMPL(0)=CNT + Q + ; + ; + ;------------------------------------- GET LIST OF DELETED PROBLEMS ----------------------------- + ; +DELLIST(RETURN,GMPDFN) ; GET LIST OF DELETED PROBLEMS + ; see GETPLIST^GMPLMGR1 and LIST^GMPUTL2 + N S,IFN,I,L0,L1,ST,TXT,ICD,ONSET,MOD,SC,SP,LOC,LT,PROV,SERV,PRIO,HASCMT,DTREC + N SCCOND,AO,IR,ENV,HNC,MST,ORICD186,INACT + S I=0,S="" + S ORICD186=$$PATCH^XPDUTL("ICD*18.0*6") + F S S=$O(^AUPNPROB("ACTIVE",GMPDFN,S)) Q:S="" D + . S IFN="" + . F S IFN=$O(^AUPNPROB("ACTIVE",+GMPDFN,S,IFN)) Q:IFN="" D + .. I $P($G(^AUPNPROB(IFN,1)),U,2)="H" D + ... S L0=$G(^AUPNPROB(IFN,0)) + ... Q:L0="" + ... S INACT="" + ... S L1=$G(^AUPNPROB(IFN,1)) + ... S ST=$P(L0,U,12) + ... S TXT=$$PROBTEXT^GMPLX(IFN) + ... I +ORICD186 D + ... . S ICD=$$CODEC^ICDCODE(+L0) + ... . I '+$$STATCHK^ICDAPIU(ICD,DT) S INACT="#" + ... E D + ... . S ICD=$P($G(^ICD9(+L0,0)),U) + ... S ONSET=$P(L0,U,13) + ... S MOD=$P(L0,U,3) + ... S SC=$S(+$P(L1,U,10):"SC",$P(L1,U,10)=0:"NSC",1:"") + ... S AO=$S(+$P(L1,U,11):"/AO",1:"") + ... S IR=$S(+$P(L1,U,12):"/IR",1:"") + ... S ENV=$S(+$P(L1,U,13):"/EC",1:"") + ... S HNC=$S(+$P(L1,U,15):"/HNC",1:"") + ... S MST=$S(+$P(L1,U,16):"/MST",1:"") + ... S SCCOND=SC_AO_IR_ENV_HNC_MST + ... S SP=$$GETSP + ... S LOC=$P(L1,U,8) + ... S LT="" + ... I LOC'="" S LT=$P($G(^SC(LOC,0)),"^",3) + ... S PROV=$P(L1,U,5) ; responsible provider + ... S SERV=$P(L1,U,6) + ... S PRIO=$P(L1,U,14) + ... S HASCMT=($D(^AUPNPROB(IFN,11,0))>0) + ... S DTREC=$P(L1,U,9) + ... S I=I+1 + ... S RETURN(I)=IFN_U_ST_U_TXT_U_ICD_U_ONSET + ... S RETURN(I)=RETURN(I)_U_MOD_U_SC_U_SP_U_$P(L1,U,2) + ... S RETURN(I)=RETURN(I)_U_LOC_U_LT_U_PROV_U_SERV + ... S RETURN(I)=RETURN(I)_U_PRIO_U_HASCMT_U_DTREC_U_SCCOND_U_INACT + S RETURN(0)=I + Q + ; +GETSP() ; GET EXPOSURES + N I + S SP="" + F I=11,12,13 S:$P(L1,U,I) SP=SP_$S(I=11:"A",I=12:"I",1:"P") + Q SP + ; + ; adapted from ^GMPLBLD3 ;9/96 + ; + ; ----------------------- GET USER PROBLEM CATEGORIES -------------- + ; +CAT(TMP,ORDUZ,CLIN) ; Get user category list + N GSEQ,GCNT,GROUP,HDR,IFN,LCNT,ITEM,TG,GMPLSLST + ; S TG=$NAME(^TMP("GMPLMENU",$J)) ; put list in global for testing + S TG=$NAME(TMP) ; put list in local + K @TG + S (GSEQ,GCNT,LCNT)=0 + ; + S GMPLSLST=$$GETUSLST(DUZ,CLIN) ; get approp list for user + ; Build multiple of category\problems + ; Iterate categories + F S GSEQ=$O(^GMPL(125.1,"C",+GMPLSLST,GSEQ)) Q:GSEQ'>0 D + . S IFN=$O(^GMPL(125.1,"C",+GMPLSLST,GSEQ,0)) Q:IFN'>0 + . S ITEM=$G(^GMPL(125.1,IFN,0)) + . S GROUP=+$P(ITEM,U,3) + . S HDR=GROUP_U_$P(ITEM,U,4,5) + . S GCNT=GCNT+1 + . S @TG@(GCNT)=HDR ; put category into temp global + Q + ; +GETUSLST(ORDUZ,CLIN) ; GET AN APPROPRIATE CATEGORY LIST FOR THE USER + N GMPLSLST + S GMPLSLST=$P($G(^VA(200,DUZ,125)),U,2) + ;I 'GMPLSLST D + I 'GMPLSLST,CLIN,$D(^GMPL(125,"C",+CLIN)) S GMPLSLST=$O(^(+CLIN,0)) + ;. S GMPLSLST=$O(^VA(200,DUZ,+CLIN,0)) ;$O(^(+CLIN,0)) + Q GMPLSLST + ; + ;----------------------- USER PROBLEM LIST -------------------------- + ; +PROB(TMP,GROUP) ; Get user problem list for given group + N PSEQ,PCNT,IFN,ITEM,TG,CODE,TEXT,ORICD186 + ; S TG=$NAME(^TMP("GMPLMENU",$J)) ; put list in global for testing + S TG=$NAME(TMP) ; put list in local + K @TG + S LCNT=0 + S ORICD186=$$PATCH^XPDUTL("ICD*18.0*6") + ; + ; iterate through problems in category + S (PSEQ,PCNT)=0 + F S PSEQ=$O(^GMPL(125.12,"C",GROUP,PSEQ)) Q:PSEQ'>0 D + . S IFN=$O(^GMPL(125.12,"C",GROUP,PSEQ,0)) Q:IFN'>0 + . S ITEM=$G(^GMPL(125.12,IFN,0)) + . S TEXT=$P(ITEM,U,4) + . ; SEE DD for GMPL(125.12,4 : + . ; "...code which is to be displayed... generally assumed to be ICD" + . S CODE=$P(ITEM,U,5) + . I +ORICD186,'+$$STATCHK^ICDAPIU(CODE,DT) Q + . S PCNT=PCNT+1 + . ; RETURN: + . ; PROBLEM^DISPLAY TEXT^CODE^CODE IFN + . I +ORICD186 D + . . S @TG@(PCNT)=$P(ITEM,U,3,5)_U_$$CODEN^ICDCODE(CODE,80) + . E D + . . S @TG@(PCNT)=$P(ITEM,U,3,5)_U_$$ICDCODE(CODE) + Q + ; +ICDCODE(COD) ; RETURN INTERNAL ICD FOR EXTERNAL CODE (obsolete after CSV patches released - RV) + N CODIEN + I COD="" Q "" + S CODIEN=+$O(^ICD9("AB",$P(COD,U)_" ",0)) + S:CODIEN'>0 CODIEN=+$O(^ICD9("AB",$P(COD,U)_"0 ",0)) + Q CODIEN + ; + ;------------------ Filter Providers --------------------- + ; +GETRPRV(RETURN,INP) ; GET LIST OF RESPONSIBLE PROVIDERS FROM PRBLM LIST + ; RETURN - aa list of responsible providers from which to select for filtering + ; INP - array of problem list providers to select from + ; + N S + S S="" + F I=1:1 S S=$O(INP(S)) Q:S="" D + . I INP(S)'="",$G(^VA(200,INP(S),0))'="" D Q ; get next + .. S RETURN(I)=INP(S)_U_$P(^VA(200,INP(S),0),U) + S RETURN(0)="-1"_U_"" ; return empty provider + Q + ; + ;---------------------------------------------------- GET FILTERED CLINIC LIST ------------------------ + ; +GETCLIN(RETURN,INP) ; Get FILTERED LIST OF CLINICS + ; RETURN NAMES FOR LIST OF CLINICS PASSED IN + N I,S + S S="" + F I=1:1 S S=$O(INP(S)) Q:S="" D + . I INP(S)'="",$G(^SC(INP(S),0))'="" D Q ; get next + .. S RETURN(I)=INP(S)_U_$P(^SC(INP(S),0),U,1) + ;. S RETURN(I)="-1"_U_"None" ; return empty location + Q + ; +GETSRVC(RETURN,INP) ; GET FILTERED LIST OF INPATIENT SERVICES + ; RETURN NAMES FOR LIST OF IEN PASSED IN + N I,S + S S="" + F I=1:1 S S=$O(INP(S)) Q:S="" D + . I INP(S)'="",$G(^DIC(49,INP(S),0))'="" D Q ; get next + .. S RETURN(I)=INP(S)_U_$P(^DIC(49,INP(S),0),U,1) + ;. S RETURN(I)="-1"_U_"None" ; return empty service + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQQPXRM.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQQPXRM.m index fbaa3817..3633e30b 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQQPXRM.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORQQPXRM.m @@ -1,156 +1,135 @@ -ORQQPXRM ; SLC/PJH - Functions for reminder data ;12/04/2007 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,173,187,190,215,243**;Dec 17, 1997;Build 242 - ; - ;ORQQPXRM DIALOG ACTIVE -ACTIVE(ORY,ORLIST) D ACTIVE^PXRMRPCC(.ORY,.ORLIST) Q ; DBIA 3080 - ; - ;ORQQPXRM REMINDER EVALUATION -ALIST(ORY,ORPT,ORLIST) D ALIST^PXRMRPCA(.ORY,.ORPT,.ORLIST) Q ; DBIA 3078 - ; - ;ORQQPXRM REMINDERS APPLICABLE -APPL(ORY,ORPT,ORLOC) D EVALCOVR^ORQQPX(.ORY,ORPT,ORLOC) Q - ;D APPL^PXRMRPCA(.ORY,ORPT,ORLOC) Q ; DBIA 3078 - ; - ;ORQQPXRM REMINDER CATEGORIES -CATEGORY(ORY,ORPT,ORLOC) ; - D CATEGORY^PXRMRPCA(.ORY,ORPT,ORLOC) Q ; DBIA 3078 - ; - ;ORQQPXRM REMINDER DIALOG -DIALOG(ORY,ORREM,DFN) ; - ; DBIA 3080 - N DIEN - D DIALOG^PXRMRPCC(.ORY,ORREM,DFN) - ;I $G(DFN)'="" D DIALOG^PXRMRPCC(.ORY,ORREM,DFN) - ;I $G(DFN)="" D DIALOG^PXRMRPCC(.ORY,ORREM) - I $P($G(ORY(1)),U)=-1 Q - S DIEN=$G(^PXD(811.9,ORREM,51)) - S ORY(0)=0_U_+$P($G(^PXRMD(801.41,DIEN,0)),U,17) - Q - ; - ;ORQQPXRM EDUCATION SUBTOPICS -EDS(ORY,OREDU) D EDS^PXRMRPCB(.ORY,OREDU) Q ; DBIA 3079 - ; - ;ORQQPXRM EDUCATION SUMMARY -EDL(ORY,OREM) D EDL^PXRMRPCB(.ORY,OREM) Q ; DBIA 3079 - ; - ;ORQQPXRM EDUCATION TOPIC -EDU(ORY,OREDU) D EDU^PXRMRPCB(.ORY,OREDU) Q ; DBIA 3079 - ; - ;ORQQPXRM PROGRESS NOTE HEADER -HDR(ORY,ORLOC) D HDR^PXRMRPCC(.ORY,ORLOC) Q ; DBIA 3080 - ; - ;ORQQPXRM REMINDERS UNEVALUATED -LIST(ORY,ORPT,ORLOC) D GETLIST^ORQQPX(.ORY,ORLOC) Q - ;D LIST^PXRMRPCA(.ORY,ORPT,ORLOC) Q ; DBIA 3078 - ; - ;ORQQPXRM MENTAL HEALTH -MH(ORY,OTEST) ; - D MH^PXRMRPCC(.ORY,OTEST) ; DBIA 3080 - S ORY(0)=0 - I $$PATCH^XPDUTL("YS*5.01*85") S ORY(0)=1 - Q - ; -MHDLL(ORY,DFN,INPUTS) ; - N CNT,CNT1,ORRESULT,ORSCORES,TEXT - F TEXT="RESULTS","SCORES" D - .S CNT=0,CNT1=0 - .F S CNT=$O(INPUTS(TEXT,CNT)) Q:CNT="" D - ..S CNT1=CNT1+1 - ..I TEXT="RESULTS" S ORRESULT(CNT1)=$G(INPUTS(TEXT,CNT)) - ..I TEXT="SCORES" S ORSCORES(CNT1)=$G(INPUTS(TEXT,CNT)) - D MHDLL^PXRMDRSG(.ORY,.ORRESULT,.ORSCORES,DFN) - Q - ; -MHDLLDMS(ORY) ; - ;Returns a one if CPRS should used the MH dll. Returns a 0 if CPRS - ;should not used the MH dll. - S ORY=1 - I '$$PATCH^XPDUTL("YS*5.01*85") S ORY=0 Q - I '$$PATCH^XPDUTL("PXRM*2.0*6") S ORY=0 Q - I $$GET^XPAR("SYS","OR USE MH DLL")<1 S ORY=0 Q - Q - ; - ;ORQQPXRM MENTAL HEALTH RESULTS -MHR(ORY,RESULT,ORES) ; - ; DBIA 3080 - D MHR^PXRMRPCC(.ORY,RESULT,.ORES) - Q - ; - ;ORQQPXRM MENTAL HEALTH SAVE -MHS(ORY,ORES) D MHS^PXRMRPCC(.ORY,.ORES) Q ; DBIA 3080 - ; -MHV(ORY,DFN,NAME,ANS) ; - N ORDATA,ORES,X - S ORY(0)=0 - I '$$PATCH^XPDUTL("YS*5.01*85") S ORY(0)=2 Q - I '$L(ANS) Q - S ORES("DFN")=DFN,ORES("CODE")=NAME - F X=1:1:$L(ANS) I $E(ANS,X)'="X" D - .;I $E(ANS,X)="T" S $E(ANS,X)=1 - .;I $E(ANS,X)="F" S $E(ANS,X)=2 - .S ORES(X)=X_U_$E(ANS,X) - D CHECKCR^YTQPXRM4(.ORDATA,.ORES) - I $G(ORDATA(2))="OK" S ORY(0)=1 Q - S ORY(1)=$P($G(ORDATA(2)),U,2) - Q - ; - ;ORQQPXRM MST UPDATE -MST(ORY,ORPT,ORDATE,ORSTAT,ORPROV,ORFTYP,ORFIEN,ORRES) ; - D MST^PXRMRPCC(.ORY,ORPT,ORDATE,ORSTAT,ORPROV,ORFTYP,ORFIEN,ORRES) Q - ; - ;ORQQPXRM WOMEN HEALTH RESULT -WH(ORY,ORRESULT) ; - D WH^PXRMRPCC(.ORY,.ORRESULT) Q - ; -WHLETTER(ORY,ORIEN) ; - D LETTER^WVRPCNO1(.ORY,ORIEN) Q - ; -WHREPORT(ORY,ORIEN) ; - D RESULTS^WVALERTF(.ORY,ORIEN) Q - ; - ;ORQQPXRM DIALOG PROMPTS -PROMPT(ORY,ORDLG,ORDCUR,ORFTYP) ; - D PROMPT^PXRMRPCC(.ORY,ORDLG,ORDCUR,ORFTYP) Q ; DBIA 3080 - ; - ;ORQQPXRM REMINDER DETAIL -REMDET(ORY,ORPT,ORIEN) D REMDET^PXRMRPCA(.ORY,ORPT,ORIEN) Q ; DBIA 3078 - ; - ;ORQQPXRM REMINDER INQUIRY -RES(ORY,ORREM) D RES^PXRMRPCC(.ORY,ORREM) Q ; DBIA 3080 - ; - ;ORQQPXRM REMINDER WEB -WEB(ORY,ORREM) D WEB^PXRMRPCA(.ORY,ORREM) Q ; DBIA 3078 - ; - ;PXRM REMINDER DIALOG (TIU) -TDIALOG(ORY,ORDLG,DFN) ; - D DIALOG^PXRMRPCD(.ORY,ORDLG,DFN) - I $P($G(ORY(1)),U)=-1 Q - S ORY(0)=0_U_+$P($G(^PXRMD(801.41,ORDLG,0)),U,17) - Q - ; -ACT(REM) ;ORQQPX SEARCH ITEMS - XPAR value screen for active reminders - ;Treat a null value as inactive - I 'REM Q 0 - ;Treat a non-existen entry as inactive - I $G(^PXD(811.9,REM,0))="" Q 0 - ;Check IF inactive flag is set - I ($T(INACTIVE^PXRM)'=""),$$INACTIVE^PXRM(REM) Q 0 ; DBIA 2182 - ;Otherwise active - Q 1 - ; -REMVER(ORLIST) ; - S ORLIST=$$VERSION^XPDUTL("PXRM") - Q - ; -GEC(ORRESULT,IEN,DFN,VISIT,NOTEIEN) ; - D API^PXRMGECU(.ORRESULT,IEN,DFN,VISIT,1,NOTEIEN) - Q - ; -GECF(RESULT,DFN,FIN) ; - D FINISHED^PXRMGECU(DFN,FIN) - Q - ; -GECP(RESULT,DFN) ; - S RESULT=$$STATUS^PXRMGECU(DFN) - Q - ; +ORQQPXRM ; SLC/PJH - Functions for reminder data ;7/21/2005 [2/4/04 10:24am] + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,173,187,190,215**;Dec 17, 1997 + ; + ;ORQQPXRM DIALOG ACTIVE +ACTIVE(ORY,ORLIST) D ACTIVE^PXRMRPCC(.ORY,.ORLIST) Q ; DBIA 3080 + ; + ;ORQQPXRM REMINDER EVALUATION +ALIST(ORY,ORPT,ORLIST) D ALIST^PXRMRPCA(.ORY,.ORPT,.ORLIST) Q ; DBIA 3078 + ; + ;ORQQPXRM REMINDERS APPLICABLE +APPL(ORY,ORPT,ORLOC) D EVALCOVR^ORQQPX(.ORY,ORPT,ORLOC) Q + ;D APPL^PXRMRPCA(.ORY,ORPT,ORLOC) Q ; DBIA 3078 + ; + ;ORQQPXRM REMINDER CATEGORIES +CATEGORY(ORY,ORPT,ORLOC) ; + D CATEGORY^PXRMRPCA(.ORY,ORPT,ORLOC) Q ; DBIA 3078 + ; + ;ORQQPXRM REMINDER DIALOG +DIALOG(ORY,ORREM,DFN) ; + ; DBIA 3080 + N DIEN + I $G(DFN)'="" D DIALOG^PXRMRPCC(.ORY,ORREM,DFN) + I $G(DFN)="" D DIALOG^PXRMRPCC(.ORY,ORREM) + I $P($G(ORY(1)),U)=-1 Q + S DIEN=$G(^PXD(811.9,ORREM,51)) + S ORY(0)=0_U_+$P($G(^PXRMD(801.41,DIEN,0)),U,17) + Q + ; + ;ORQQPXRM EDUCATION SUBTOPICS +EDS(ORY,OREDU) D EDS^PXRMRPCB(.ORY,OREDU) Q ; DBIA 3079 + ; + ;ORQQPXRM EDUCATION SUMMARY +EDL(ORY,OREM) D EDL^PXRMRPCB(.ORY,OREM) Q ; DBIA 3079 + ; + ;ORQQPXRM EDUCATION TOPIC +EDU(ORY,OREDU) D EDU^PXRMRPCB(.ORY,OREDU) Q ; DBIA 3079 + ; + ;ORQQPXRM PROGRESS NOTE HEADER +HDR(ORY,ORLOC) D HDR^PXRMRPCC(.ORY,ORLOC) Q ; DBIA 3080 + ; + ;ORQQPXRM REMINDERS UNEVALUATED +LIST(ORY,ORPT,ORLOC) D GETLIST^ORQQPX(.ORY,ORLOC) Q + ;D LIST^PXRMRPCA(.ORY,ORPT,ORLOC) Q ; DBIA 3078 + ; + ;ORQQPXRM MENTAL HEALTH +MH(ORY,OTEST) ; + D MH^PXRMRPCC(.ORY,OTEST) ; DBIA 3080 + S ORY(0)=0 + I $$PATCH^XPDUTL("YS*5.01*85") S ORY(0)=1 + Q + ; + ;ORQQPXRM MENTAL HEALTH RESULTS +MHR(ORY,RESULT,ORES) ; + ; DBIA 3080 + D MHR^PXRMRPCC(.ORY,RESULT,.ORES) + Q + ; + ;ORQQPXRM MENTAL HEALTH SAVE +MHS(ORY,ORES) D MHS^PXRMRPCC(.ORY,.ORES) Q ; DBIA 3080 + ; +MHV(ORY,DFN,NAME,ANS) ; + N ORDATA,ORES,X + S ORY(0)=0 + I '$$PATCH^XPDUTL("YS*5.01*85") S ORY(0)=2 Q + I '$L(ANS) Q + S ORES("DFN")=DFN,ORES("CODE")=NAME + F X=1:1:$L(ANS) I $E(ANS,X)'="X" D + .;I $E(ANS,X)="T" S $E(ANS,X)=1 + .;I $E(ANS,X)="F" S $E(ANS,X)=2 + .S ORES(X)=X_U_$E(ANS,X) + D CHECKCR^YTQPXRM4(.ORDATA,.ORES) + I $G(ORDATA(2))="OK" S ORY(0)=1 Q + S ORY(1)=$P($G(ORDATA(2)),U,2) + Q + ; + ;ORQQPXRM MST UPDATE +MST(ORY,ORPT,ORDATE,ORSTAT,ORPROV,ORFTYP,ORFIEN,ORRES) ; + D MST^PXRMRPCC(.ORY,ORPT,ORDATE,ORSTAT,ORPROV,ORFTYP,ORFIEN,ORRES) Q + ; + ;ORQQPXRM WOMEN HEALTH RESULT +WH(ORY,ORRESULT) ; + D WH^PXRMRPCC(.ORY,.ORRESULT) Q + ; +WHLETTER(ORY,ORIEN) ; + D LETTER^WVRPCNO1(.ORY,ORIEN) Q + ; +WHREPORT(ORY,ORIEN) ; + D RESULTS^WVALERTF(.ORY,ORIEN) Q + ; + ;ORQQPXRM DIALOG PROMPTS +PROMPT(ORY,ORDLG,ORDCUR,ORFTYP) ; + D PROMPT^PXRMRPCC(.ORY,ORDLG,ORDCUR,ORFTYP) Q ; DBIA 3080 + ; + ;ORQQPXRM REMINDER DETAIL +REMDET(ORY,ORPT,ORIEN) D REMDET^PXRMRPCA(.ORY,ORPT,ORIEN) Q ; DBIA 3078 + ; + ;ORQQPXRM REMINDER INQUIRY +RES(ORY,ORREM) D RES^PXRMRPCC(.ORY,ORREM) Q ; DBIA 3080 + ; + ;ORQQPXRM REMINDER WEB +WEB(ORY,ORREM) D WEB^PXRMRPCA(.ORY,ORREM) Q ; DBIA 3078 + ; + ;PXRM REMINDER DIALOG (TIU) +TDIALOG(ORY,ORDLG,DFN) ; + D DIALOG^PXRMRPCD(.ORY,ORDLG,DFN) + I $P($G(ORY(1)),U)=-1 Q + S ORY(0)=0_U_+$P($G(^PXRMD(801.41,ORDLG,0)),U,17) + Q + ; +ACT(REM) ;ORQQPX SEARCH ITEMS - XPAR value screen for active reminders + ;Treat a null value as inactive + I 'REM Q 0 + ;Treat a non-existen entry as inactive + I $G(^PXD(811.9,REM,0))="" Q 0 + ;Check IF inactive flag is set + I ($T(INACTIVE^PXRM)'=""),$$INACTIVE^PXRM(REM) Q 0 ; DBIA 2182 + ;Otherwise active + Q 1 + ; +REMVER(ORLIST) ; + S ORLIST=$$VERSION^XPDUTL("PXRM") + Q + ; +GEC(ORRESULT,IEN,DFN,VISIT,NOTEIEN) ; + I $$VERSION^XPDUTL("PXRM")["2.0" D API^PXRMGECU(.ORRESULT,IEN,DFN,VISIT,1,NOTEIEN) + Q + ; +GECF(RESULT,DFN,FIN) ; + I $$VERSION^XPDUTL("PXRM")["2.0" D FINISHED^PXRMGECU(DFN,FIN) + Q + ; +GECP(RESULT,DFN) ; + I $$VERSION^XPDUTL("PXRM")["2.0",$G(DFN)'="" S RESULT=$$STATUS^PXRMGECU(DFN) + Q + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORUDPA.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORUDPA.m index 7cc2196d..11d4d987 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORUDPA.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORUDPA.m @@ -1,36 +1,38 @@ -ORUDPA ; slc/dcm,RWF - Object (patient) lookup ;10/7/91 15:21 ; 3/7/08 5:22am - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**16,243**;Dec 17, 1997;Build 242 -ENT ; - ;Entry: none Exit: DFN,ORACTION,ORAGE,ORDOB,ORL,ORNP,ORPD,ORPNM,ORPV,ORSEX,ORSSN,ORTS,ORVP,ORWARD,VADPT("V"),VAERR - D PATIENT^ORU1(.Y) - Q -EN2 ; - S (ORVP,X)="",DIC(0)="EMQZI",DIC=2 - R !,"Select PATIENT NAME: ",X:DTIME - I X=""!(X["^") S Y=-1 G END1 - S:'$D(DIC(0)) DIC(0)="EMQZI" - S DIC="^DPT(" D ^DIC I $E(X)="^" S:X="^^" DIROUT=1 G END1 - I Y>0 S ORVP=+Y_";DPT(" Q:$D(ORUS) G END1 - Q -END1 ; - I Y>0 S ^TMP("OR",$J,"PAT",1)=ORVP,^TMP("OR",$J,"PAT","B",ORVP,1)="" -END ;from ORUHDR - Q:Y<0 - I ORVP[";DPT(" D HOMO - K VA,VAROOT,VA200,VAIN,VAINDT,VAERR,VADM,DIC Q - ; -GPD ; - N GMRVSTR - K ORPD - S (ORSEQ,ORPD)=0,DFN=+ORVP - I $D(^GMRD(120.51)) S X="GMRVUTL",GMRVSTR="WT" X ^%ZOSF("TEST") I $T D EN6^GMRVUTL S ORPD=+$P(X,U,8)\1 - S:ORPD'>0 ORPD="NF" - K ORSEQ - Q -HOMO ; - N XQORFLG,ORCNV - S DFN=+Y,VA200=1 K VAINDT - D OERR^VADPT,GPD - S ORPNM=VADM(1),ORSSN=VA("PID"),ORDOB=$P(VADM(3),"^",2),ORAGE=VADM(4),ORSEX=$P(VADM(5),"^"),ORTS=+VAIN(3),ORTS=$S(ORTS:ORTS,1:""),(ORATTEND,ORNP)=+VAIN(2),ORWARD=VAIN(4),ORL(1)=VAIN(5),(ORPV,ORL,ORL(0),ORL(2))="" - I +$P(ORWARD,"^") S X=+ORWARD I $D(^DIC(42,+X,44)) S X=$P(^(44),"^") I X,$D(^SC(X,0)) S ORL=X_";SC(",ORL(0)=$S($L($P(^(0),"^",2)):$P(^(0),"^",2),1:$E($P(^(0),"^"),1,4)),ORL(2)=ORL - Q +ORUDPA ; slc/dcm,RWF - Object (patient) lookup ;10/7/91 15:21 ; + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**16**;Dec 17, 1997 +ENT ; + ;Entry: none Exit: DFN,ORACTION,ORAGE,ORDOB,ORL,ORNP,ORPD,ORPNM,ORPV,ORSEX,ORSSN,ORTS,ORVP,ORWARD,VADPT("V"),VAERR + D PATIENT^ORU1(.Y) + Q +EN2 ; + S (ORVP,X)="",DIC(0)="EMQZI",DIC=2 + R !,"Select PATIENT NAME: ",X:DTIME + I X=""!(X["^") S Y=-1 G END1 + S:'$D(DIC(0)) DIC(0)="EMQZI" + S DIC="^DPT(" D ^DIC I $E(X)="^" S:X="^^" DIROUT=1 G END1 + I Y>0 S ORVP=+Y_";DPT(" Q:$D(ORUS) G END1 + Q +END1 ; + I Y>0 S ^TMP("OR",$J,"PAT",1)=ORVP,^TMP("OR",$J,"PAT","B",ORVP,1)="" +END ;from ORUHDR + Q:Y<0 + I ORVP[";DPT(" D HOMO + K VA,VAROOT,VA200,VAIN,VAINDT,VAERR,VADM,DIC Q + ; +GPD ; + K ORPD + S (ORSEQ,ORPD)=0,DFN=+ORVP + I $D(^GMRD(120.51)) S X="GMRVUTL" X ^%ZOSF("TEST") I $T D EN4^GMRVUTL S ORPD=+X\1 + S:ORPD'>0 ORPD="NF" + K ORSEQ + Q +HOMO ; + N XQORFLG,ORCNV + S DFN=+Y,VA200=1 K VAINDT + D OERR^VADPT,GPD + S ORPNM=VADM(1),ORSSN=VA("PID"),ORDOB=$P(VADM(3),"^",2),ORAGE=VADM(4),ORSEX=$P(VADM(5),"^"),ORTS=+VAIN(3),ORTS=$S(ORTS:ORTS,1:""),(ORATTEND,ORNP)=+VAIN(2),ORWARD=VAIN(4),ORL(1)=VAIN(5),(ORPV,ORL,ORL(0),ORL(2))="" + I +$P(ORWARD,"^") S X=+ORWARD I $D(^DIC(42,+X,44)) S X=$P(^(44),"^") I X,$D(^SC(X,0)) S ORL=X_";SC(",ORL(0)=$S($L($P(^(0),"^",2)):$P(^(0),"^",2),1:$E($P(^(0),"^"),1,4)),ORL(2)=ORL + S ORCNV=$$OTF^OR3CONV(+ORVP) Q:'ORCNV + I ORCNV>0 W !,"DONE" H 1 Q + I ORCNV<0 W $C(7),!!,$P(ORCNV,U,2) H 2 S VALMBCK="R" Q + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORUTL1.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORUTL1.m index 967a7a94..31146240 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORUTL1.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORUTL1.m @@ -1,50 +1,31 @@ -ORUTL1 ; slc/dcm - OE/RR Utilities ;5/30/07 13:46 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**11,66,243**;Dec 17, 1997;Build 242 -LOC ;Hospital Location Look-up - N DIC,ORIA,ORRA - S DIC=44,DIC(0)="AEQM",DIC("S")="I '$P($G(^(""OOS"")),""^"")" - D ^DIC - I Y<1 Q - I $D(^SC(+Y,"I")) S ORIA=+^("I"),ORRA=$P(^("I"),U,2) - I $S('$D(ORIA):0,'ORIA:0,ORIA>DT:0,ORRA'>DT&(ORRA):0,1:1) W $C(7),!," This location has been inactivated.",! K ORL G LOC - Q -QUE(ZTRTN,ZTDESC,ZTSAVE,ORIOPTR,ZTDTH,%ZIS,QUE,ECHO,ORION) ;Device Handling -IO ;This entry point replaced by QUE, but left for backwards compatibility - Q:'$D(ZTRTN) - N IO,ION,IOP,IOPAR,IOT,ZTSK,ZTIO,POP - I $G(QUE),'$L($G(ORIOPTR)) Q - I $L($G(ORIOPTR)),$G(QUE),$D(ORION) S ZTIO=ORION G IOQ - S:'($D(%ZIS)#2) %ZIS="Q" - I $G(QUE) S:%ZIS'["Q" %ZIS=%ZIS_"Q" S %ZIS("S")="I $S($G(^%ZIS(2,+$G(^(""SUBTYPE"")),0))'[""C-"":1,1:0)",%ZIS("B")="" - I $L($G(ORIOPTR)) S IOP=ORIOPTR - D ^%ZIS - I POP S OREND=1 Q - S ZTIO=ION -IOQ I $G(QUE)!$D(IO("Q")) D Q - . S:'$D(ZTSAVE) ZTSAVE("O*")="" - . D ^%ZTLOAD - . I $D(ZTSK),'$D(ECHO) W !,"REQUEST QUEUED" - . I '$D(ZTSK) S OREND=1 - . D ^%ZISC - D @ZTRTN - D ^%ZISC - Q - ; -DPI(PATCH) ;Function returns date patch installed - added in patch 243 - ;PATCH is set to patch designation, for example, "SR*3.0*157" - ;Output is the fileman date/time that patch was installed on this system - ;A return value of -1 is given if patch hasn't been installed - N ORVALUE,ORDAT,ORERR,VER,PKG,DATE,NUM - S DATE=-1 - I '$$PATCH^XPDUTL(PATCH) Q DATE ;If patch hasn't been installed yet quit - S ORVALUE=$P(PATCH,"*") ;Package - D FIND^DIC(9.4,,,"MO",.ORVALUE,,,,,"ORDAT","ORERR") - S PKG=$G(ORDAT("DILIST",2,1)) I 'PKG Q DATE - S ORVALUE=$P(PATCH,"*",2) ;Version - D FIND^DIC(9.49,(","_PKG_","),,"X",.ORVALUE,,,,,"ORDAT","ORERR") - S VER=$G(ORDAT("DILIST",2,1)) I 'VER Q DATE - S ORVALUE=$P(PATCH,"*",3) ;Patch number - D FIND^DIC(9.4901,(","_VER_","_PKG_","),,,.ORVALUE,,,,,"ORDAT","ORERR") - S NUM=$G(ORDAT("DILIST",2,1)) I 'NUM Q DATE - S DATE=$$GET1^DIQ(9.4901,(NUM_","_VER_","_PKG_","),.02,"I") - Q DATE +ORUTL1 ; slc/dcm - OE/RR Utilities ;6/7/91 08:47 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**11,66**;Dec 17, 1997 +LOC ;Hospital Location Look-up + N DIC,ORIA,ORRA + S DIC=44,DIC(0)="AEQM",DIC("S")="I '$P($G(^(""OOS"")),""^"")" + D ^DIC + I Y<1 Q + I $D(^SC(+Y,"I")) S ORIA=+^("I"),ORRA=$P(^("I"),U,2) + I $S('$D(ORIA):0,'ORIA:0,ORIA>DT:0,ORRA'>DT&(ORRA):0,1:1) W $C(7),!," This location has been inactivated.",! K ORL G LOC + Q +QUE(ZTRTN,ZTDESC,ZTSAVE,ORIOPTR,ZTDTH,%ZIS,QUE,ECHO,ORION) ;Device Handling +IO ;This entry point replaced by QUE, but left for backwards compatibility + Q:'$D(ZTRTN) + N IO,ION,IOP,IOPAR,IOT,ZTSK,ZTIO,POP + I $G(QUE),'$L($G(ORIOPTR)) Q + I $L($G(ORIOPTR)),$G(QUE),$D(ORION) S ZTIO=ORION G IOQ + S:'($D(%ZIS)#2) %ZIS="Q" + I $G(QUE) S:%ZIS'["Q" %ZIS=%ZIS_"Q" S %ZIS("S")="I $S($G(^%ZIS(2,+$G(^(""SUBTYPE"")),0))'[""C-"":1,1:0)",%ZIS("B")="" + I $L($G(ORIOPTR)) S IOP=ORIOPTR + D ^%ZIS + I POP S OREND=1 Q + S ZTIO=ION +IOQ I $G(QUE)!$D(IO("Q")) D Q + . S:'$D(ZTSAVE) ZTSAVE("O*")="" + . D ^%ZTLOAD + . I $D(ZTSK),'$D(ECHO) W !,"REQUEST QUEUED" + . I '$D(ZTSK) S OREND=1 + . D ^%ZISC + D @ZTRTN + D ^%ZISC + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWCIRN.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWCIRN.m index 5a2d8274..50e585ed 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWCIRN.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWCIRN.m @@ -1,59 +1,65 @@ -ORWCIRN ; slc/dcm,REV - Functions for GUI CIRN ACTIONS ;22-NOV-1999 07:27:24 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,101,109,132,141,160,208,239,215,243**;October 28, 1997;Build 242 - ; -FACLIST(ORY,ORDFN) ; Return list of remote facilities for patient - ;Check to see if CIRN PD/MPI installed - N X,ORSITES,I,IFN,LOCAL,CTR,HDRFLG - S X="MPIF001" X ^%ZOSF("TEST") - I '$T S ORY(0)="-1^CIRN MPI not installed." Q - S X="VAFCTFU1" X ^%ZOSF("TEST") - I '$T S ORY(0)="-1^Remote data view not installed." Q - S X=$$GET^XPAR("ALL","ORWRP CIRN REMOTE DATA ALLOW",1,"I") - I 'X S ORY(0)="-1^Remote access not allowed" Q - D TFL^VAFCTFU1(.ORY,ORDFN) - S I=0 F S I=$O(ORY(I)) Q:'I I $P(ORY(I),"^",5)="OTHER",'($P(ORY(I),"^")="200HD") K ORY(I) ;Screen out Type 'OTHER' locations - S HDRFLG=0 - I $$GET^XPAR("ALL","ORWRP CIRN SITES ALL",1,"I") D - . S (CTR,I)=0 - . F S I=$O(ORY(I)) Q:'I S $P(ORY(I),"^",5)=1,CTR=CTR+1 D - .. I $P(ORY(I),"^")=200 S $P(ORY(I),"^",2)="DEPT. OF DEFENSE" - .. I $P(ORY(I),"^")="200HD" D - ... I +$$GET^XPAR("ALL","ORWRP HDR ON",1,"I")=0 K ORY(I) S CTR=CTR-1 Q - ... S HDRFLG=I ; Remove commented out code to enable HDR + 1 other site. - D GETLST^XPAR(.ORSITES,"ALL","ORWRP CIRN SITES","I") - S (CTR,I)=0,LOCAL=$P($$SITE^VASITE,"^",3) - F S I=$O(ORY(I)) Q:'I D - . I +ORY(I)=+LOCAL K ORY(I) Q - . S IFN=$$IEN^XUAF4(ORY(I)),CTR=CTR+1 - . I IFN,$G(ORSITES(IFN)) S $P(ORY(I),"^",5)=1 I $P(ORY(I),"^")=200 S $P(ORY(I),"^",2)="DEPT. OF DEFENSE" - . I IFN,$G(ORSITES(IFN)),$P(ORY(I),"^")="200HD" D - .. I +$$GET^XPAR("ALL","ORWRP HDR ON",1,"I")=0 K ORY(I) S CTR=CTR-1 Q - .. S HDRFLG=I ; Remove commented out code to enable HDR + 1 other site. - I '$L($O(ORY(""))) S ORY(0)="-1^Only local data exists for this patient" - I $G(HDRFLG),CTR'>1 K ORY(HDRFLG) S ORY(0)="-1^Only HDR has data for this patient" - Q -RESTRICT(ORY,PATID) ;Check for sensitive patient - N DFN,ICN,SITE - I '$G(PATID) S ORY(1)="-1",ORY(2)="Invalid Patient ID" Q - S ICN=$P(PATID,";",2) - I 'ICN S ORY(1)="-1",ORY(2)="Invalid ICN" Q - S SITE=$$SITE^VASITE,SITE=$P(SITE,"^",2)_";"_$P(SITE,"^",3) - S DFN=+$$GETDFN^MPIF001(ICN) - I DFN<0 S ORY(1)="-1",ORY(2)="Patient not found on remote system ("_SITE_")" Q - D PTSEC^DGSEC4(.ORY,DFN) - Q -CHKLNK(ORY) ;Check for active HL7 TCP link on local system - S ORY=$$STAT^HLCSLM - Q -WEBADDR(ORY,PATID) ;Get VistaWeb Address - S ORY=$$GET^XPAR("ALL","ORWRP VISTAWEB ADDRESS",1,"I") - I ORY="" S ORY="https://vistaweb.med.va.gov" Q - I ORY="https://vistaweb.med.va.gov" Q - S ORY=ORY_"?q9gtw0="_$P($$SITE^VASITE,"^",3)_"&xqi4z="_PATID_"&yiicf="_DUZ - Q -AUTORDV(ORY) ;Get parameter value for ORWRP CIRN AUTOMATIC - S ORY=+$$GET^XPAR("ALL","ORWRP CIRN AUTOMATIC",1,"I") - Q -HDRON(ORY) ;Get parameter value for ORWRP HDR ON - S ORY=+$$GET^XPAR("ALL","ORWRP HDR ON",1,"I") - Q +ORWCIRN ; slc/dcm,REV - Functions for GUI CIRN ACTIONS ;22-NOV-1999 07:27:24 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,101,109,132,141,160,208,239,215**;October 28, 1997 + ; +FACLIST(ORY,ORDFN) ; Return list of remote facilities for patient + ;Check to see if CIRN PD/MPI installed + N X,ORSITES,I,IFN,LOCAL,CTR,HDRFLG + S X="MPIF001" X ^%ZOSF("TEST") + I '$T S ORY(0)="-1^CIRN MPI not installed." Q + S X="VAFCTFU1" X ^%ZOSF("TEST") + I '$T S ORY(0)="-1^Remote data view not installed." Q + S X=$$GET^XPAR("ALL","ORWRP CIRN REMOTE DATA ALLOW",1,"I") + I 'X S ORY(0)="-1^Remote access not allowed" Q + D TFL^VAFCTFU1(.ORY,ORDFN) + S I=0 F S I=$O(ORY(I)) Q:'I I $P(ORY(I),"^",5)="OTHER",'($P(ORY(I),"^")="200HD") K ORY(I) ;Screen out Type 'OTHER' locations + S HDRFLG=0 + I $$GET^XPAR("ALL","ORWRP CIRN SITES ALL",1,"I") D + . S (CTR,I)=0 + . F S I=$O(ORY(I)) Q:'I S $P(ORY(I),"^",5)=1,CTR=CTR+1 D + .. I $P(ORY(I),"^")=200 S $P(ORY(I),"^",2)="DEPT. OF DEFENSE" + .. I $P(ORY(I),"^")="200HD" D + ... I +$$GET^XPAR("ALL","ORWRP HDR ON",1,"I")=0 K ORY(I) S CTR=CTR-1 Q + ... S HDRFLG=I ; Remove commented out code to enable HDR + 1 other site. + D GETLST^XPAR(.ORSITES,"ALL","ORWRP CIRN SITES","I") + S (CTR,I)=0,LOCAL=$P($$SITE^VASITE,"^",3) + F S I=$O(ORY(I)) Q:'I D + . I +ORY(I)=+LOCAL K ORY(I) Q + . S IFN=$$IEN^XUAF4(ORY(I)),CTR=CTR+1 + . I IFN,$G(ORSITES(IFN)) S $P(ORY(I),"^",5)=1 I $P(ORY(I),"^")=200 S $P(ORY(I),"^",2)="DEPT. OF DEFENSE" + . I IFN,$G(ORSITES(IFN)),$P(ORY(I),"^")="200HD" D + .. I +$$GET^XPAR("ALL","ORWRP HDR ON",1,"I")=0 K ORY(I) S CTR=CTR-1 Q + .. S HDRFLG=I ; Remove commented out code to enable HDR + 1 other site. + I '$L($O(ORY(""))) S ORY(0)="-1^Only local data exists for this patient" + I $G(HDRFLG),CTR'>1 K ORY(HDRFLG) S ORY(0)="-1^Only HDR has data for this patient" + Q +RESTRICT(ORY,PATID) ;Check for sensitive patient + N DFN,ICN,SITE + I '$G(PATID) S ORY(1)="-1",ORY(2)="Invalid Patient ID" Q + S ICN=$P(PATID,";",2) + I 'ICN S ORY(1)="-1",ORY(2)="Invalid ICN" Q + S SITE=$$SITE^VASITE,SITE=$P(SITE,"^",2)_";"_$P(SITE,"^",3) + S DFN=+$$GETDFN^MPIF001(ICN) + I DFN<0 S ORY(1)="-1",ORY(2)="Patient not found on remote system ("_SITE_")" Q + D PTSEC^DGSEC4(.ORY,DFN) + Q +CHKLNK(ORY) ;Check for active HL7 TCP link on local system + S ORY=$$STAT^HLCSLM + Q +VISTAWEB(ORY) ;Check VistaWeb Parameter + S ORY=+$$GET^XPAR("ALL","ORWRP VISTAWEB",1,"I") + Q +WEBCH(ORY,ORVALUE) ;Change value of ORWRP VISTAWEB parameter + D PUT^XPAR(DUZ_";VA(200,","ORWRP VISTAWEB",1,ORVALUE) + Q +WEBADDR(ORY,PATID) ;Get VistaWeb Address + S ORY=$$GET^XPAR("ALL","ORWRP VISTAWEB ADDRESS",1,"I") + I ORY="" S ORY="https://vistaweb.med.va.gov" Q + I ORY="https://vistaweb.med.va.gov" Q + S ORY=ORY_"?q9gtw0="_$P($$SITE^VASITE,"^",3)_"&xqi4z="_PATID_"&yiicf="_DUZ + Q +AUTORDV(ORY) ;Get parameter value for ORWRP CIRN AUTOMATIC + S ORY=+$$GET^XPAR("ALL","ORWRP CIRN AUTOMATIC",1,"I") + Q +HDRON(ORY) ;Get parameter value for ORWRP HDR ON + S ORY=+$$GET^XPAR("ALL","ORWRP HDR ON",1,"I") + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWCV.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWCV.m index 69caa508..5150cc8d 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWCV.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWCV.m @@ -1,226 +1,225 @@ -ORWCV ; SLC/KCM - Background Cover Sheet Load; ; 3/6/08 6:34am - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,132,209,214,195,215,260,243**;Dec 17, 1997;Build 242 - ; - ; DBIA 4011 Access ^XWB(8994) - ; DBIA 4313 Direct R/W permission to capacity mgmt global ^KMPTMP("KMPDT") - ; DBIA 10061 Reference to ^UTILITY - ; -START(VAL,DFN,IP,HWND,LOC,NODO,NEWREM) ; start cover sheet build in background - N ZTIO,ZTRTN,ZTDTH,ZTSAVE,ZTDESC,SECT,BACK,X,I,ORLIST,STR,FILE,NODE,ORHTIME,ORX - ; Capacity planning timing code uses ORHTIME - S ORHTIME=$H - S LOC=$G(LOC),NODO=";"_$G(NODO),NEWREM=+$G(NEWREM) - D GETLST^XPAR(.ORX,"SYS^PKG","ORWOR COVER RETRIEVAL NEW","Q") - S I=0 F S I=$O(ORX(I)) Q:'I I $D(^ORD(101.24,+ORX(I),0)) S SECT(+$P(^(0),"^",2))=$P(ORX(I),"^",2) - D GETLST^XPAR(.ORLIST,"ALL","ORWCV1 COVERSHEET LIST") - S (VAL,BACK,STR,FILE)="" - F S I=$O(ORLIST(I)) Q:'I I $D(^ORD(101.24,$P(ORLIST(I),"^",2),0)) S X0=^(0) D - . Q:$P(X0,"^",8)'="C" - . S X=$P(X0,"^",2) - . I NODO[(";"_X_";") Q ; if in NODO, dont do section - . S STR=STR_X_";" - . I '$G(SECT(X)) S VAL=VAL_X_";" ; load section in foreground - . E S BACK=BACK_X_";",FILE=FILE_$P(ORLIST(I),"^",2)_";" ; load section in background - Q:BACK="" - S ZTIO="ORW THREAD RESOURCE",ZTRTN="BUILD^ORWCV",ZTDTH=$H - S (ZTSAVE("DFN"),ZTSAVE("IP"),ZTSAVE("HWND"),ZTSAVE("NEWREM"),ZTSAVE("LOC"),ZTSAVE("BACK"),ZTSAVE("FILE"))="" - S ZTDESC="CPRS GUI Background Data Retrieval" - D ^%ZTLOAD I '$D(ZTSK) S VAL=STR Q - S NODE="ORWCV "_IP_"-"_HWND_"-"_DFN - K ^XTMP(NODE) - S ^XTMP(NODE,0)=$$FMADD^XLFDT(DT,1)_U_DT_U_"Background CPRS "_ZTSK - ; Start capacity planning timing clock - will be stopped in POLL code - I +$G(^KMPTMP("KMPD-CPRS")) S ^KMPTMP("KMPDT","ORWCV",NODE)=$G(ORHTIME)_"^^"_$G(DUZ)_"^"_$G(IO("CLNM")) - Q -BUILD ; called in background by task manager, expects DFN, JobID - N NODE,IFLE,ORFNUM,ID,ENT,RTN,INODE,PARAM1,PARAM2,DETAIL,X0,X2 - S NODE="ORWCV "_IP_"-"_HWND_"-"_DFN - I $D(ZTQUEUED) S ZTREQ="@" - I $G(^XTMP(NODE,"STOP")) K ^XTMP(NODE) Q ; client no longer polling - I '$D(^XTMP(NODE,0)) Q ; XTMP node has been purged - L +^XTMP(NODE) - S ^XTMP(NODE,"DFN")=DFN - ;N $ETRAP,$ESTACK - ;S $ETRAP="D ERR^ORWCV Q" - I $L($G(FILE),";")>0 F IFLE=1:1:$L(FILE,";") S ORFNUM=$P(FILE,";",IFLE) Q:'$D(^ORD(101.24,+ORFNUM,0)) S X0=^(0),X2=$G(^(2)) D - . S ID=$P(X0,"^",2),ENT=$P(X0,"^",6),RTN=$P(X0,"^",5),PARAM1=$P(X2,"^"),PARAM2=$P(X2,"^",2),INODE=$P(X2,"^",5),DETAIL="" - . I $P(X0,"^",18) S DETAIL=$P($G(^ORD(101.24,+$P(X0,"^",18),0)),"^",13),DETAIL=$P($G(^XWB(8994,+DETAIL,0)),"^") ;DBIA 4011 - . I '$L(INODE) Q - . I '$L(ENT) S LST(IFLE)="0^ERROR: Missing ENTRY POINT field in file 101.24 for "_$P(X0,"^")_", IFN="_+ORFNUM D LST2XTMP(INODE) Q - . I '$L(RTN) S LST(IFLE)="0^ERROR: Missing ROUTINE field in file 101.24 for "_$P(X0,"^")_", IFN="_+ORFNUM D LST2XTMP(INODE) Q - . I '$L($T(@(ENT_"^"_RTN))) S LST(IFLE)="0^ERROR: "_ENT_"~"_RTN_" does not exist. See file 101.24 entry: "_$P(X0,"^")_", IFN="_+ORFNUM D LST2XTMP(INODE) Q - . I ID=50 D:$L($T(STRT3^AWCMCPR1)) STRT3^AWCMCPR1 D D:$L($T(END^AWCMCPR1)) END^AWCMCPR1 Q ;Special case for reminders - .. I $G(NEWREM) D APPL^ORQQPXRM(.LST,DFN,LOC) I 1 - .. E D @(ENT_"^"_RTN_"(.LST,DFN)") - .. D LST2XTMP(INODE) - . I $L(PARAM1),$L(PARAM2) D @(ENT_"^"_RTN_"(.LST,DFN,PARAM1,PARAM2)"),LST2XTMP(INODE) Q - . I $L(PARAM1) D @(ENT_"^"_RTN_"(.LST,DFN,PARAM1)"),LST2XTMP(INODE) Q - . D @(ENT_"^"_RTN_"(.LST,DFN)"),LST2XTMP(INODE) - S ^XTMP(NODE,"DONE")=1 - I $G(^XTMP(NODE,"STOP")) K ^XTMP(NODE) - L -^XTMP(NODE) - Q -ERR ;Error trap - S $ETRAP="D UNWIND^ORWCV Q" - I $D(NODE) D - . I $D(INODE) S LST(0)="",LST(1)="0^ERROR DURING COVER SHEET BUILD:"_$ZERROR D LST2XTMP(INODE) - . S ^XTMP(NODE,"DONE")=1 - . L -^XTMP(NODE) - D @^%ZOSF("ERRTN") ;file error - S $ECODE=",UOR70 error during Cover Sheet build," - Q -UNWIND ;Unwind Error stack - Q:$ESTACK>1 ;pop the stack - ;add additional code here, if needed - Q -LST2XTMP(ID) ; put the list in ^XTMP(NODE,ID) - I $G(^XTMP(NODE,"STOP")) Q - N I - I $L($G(DETAIL)) S I=0 F S I=$O(LST(I)) Q:'I S $P(LST(I),"^",12)=DETAIL - K ^XTMP(NODE,ID) M ^XTMP(NODE,ID)=LST S ^XTMP(NODE,ID)=1 K LST - Q -POLL(LST,DFN,IP,HWND) ; poll for completed cover sheet parts - N I,ILST,ID,NODE,DONE - S NODE="ORWCV "_IP_"-"_HWND_"-"_DFN,ILST=0,DONE=0 - I '$D(^XTMP(NODE,"DFN")) Q - I ^XTMP(NODE,"DFN")'=DFN S LST(1)="~DONE=1" Q - I $G(^XTMP(NODE,"DONE")) S ILST=ILST+1,LST(ILST)="~DONE=1",DONE=1 - F ID="PROB","CWAD","MEDS","RMND","LABS","VITL","VSIT" D - . I '$G(^XTMP(NODE,ID)) Q - . S ILST=ILST+1,LST(ILST)="~"_ID - . S I=0 F S I=$O(^XTMP(NODE,ID,I)) Q:'I S ILST=ILST+1,LST(ILST)="i"_^(I) - . K ^XTMP(NODE,ID) - ; Stop capacity planning timing clock - was started in START code - I DONE K ^XTMP(NODE) I +$G(^KMPTMP("KMPD-CPRS")) S $P(^KMPTMP("KMPDT","ORWCV",NODE),"^",2)=$H - Q -STOP(OK,DFN,IP,HWND) ; stop cover sheet data retrieval - S NODE="ORWCV "_IP_"-"_HWND_"-"_DFN,ILST=0,DONE=0 - S ^XTMP(NODE,"STOP")=1,OK=1 - L +^XTMP(NODE) - I $G(^XTMP(NODE,"DONE")) K ^XTMP(NODE) - L -^XTMP(NODE) - Q -CLEAN ; clean up ^XTMP nodes - S X="ORWCV" - F S X=$O(^XTMP(X)) Q:$E(X,1,5)'="ORWCV" W !,X K ^XTMP(X) - Q -LAB(LST,DFN) ; return labs for patient - D:$L($T(STRT2^AWCMCPR1)) STRT2^AWCMCPR1 - D LIST^ORQOR1(.LST,DFN,"LAB",4,"T-"_$$RNGLAB(DFN),"T","AW",1) - D:$L($T(END^AWCMCPR1)) END^AWCMCPR1 - Q - ; -VST1(ORVISIT,DFN,BEG,END,SKIP) ; - N ERR,ERRMSG - S ERR=0 ; kludge to return errors - Q:'$G(DFN) - D VST(.ORVISIT,DFN,.BEG,.END,$G(SKIP),.ERR,.ERRMSG) - I ERR K ORVISIT S ORVISIT(1)=ERRMSG - Q - ; -TEST ;D VST(.ZZZ,76,2950101,3050401,777,1,1) - Q -VST(ORVISIT,DFN,BEG,END,SKIP,ERR,ERRMSG) ; return appts/admissions for patient - N CHECKERR,VAERR,VASD,BDT,COUNT,DTM,EDT,LOC,NOW,ORQUERY,ORLST,STI,STS,TODAY,I,J,K,XI,XE,X - S CHECKERR=($G(ERR)=0) ; kludge to check for errors - S NOW=$$NOW^XLFDT(),TODAY=$P(NOW,".",1) - I '$G(BEG) S BEG=$$X2FM($$RNGVBEG) - I '$G(END) S END=$$X2FM($$RNGVEND)+0.2359 - S COUNT=0 - K ^TMP("ORVSTLIST",$J) - S VAERR=0 - I END>NOW D Q:VAERR ; get future encounters, past cancels/no-shows from VADPT - . S VASD("F")=BEG - . S VASD("T")=END - . S VASD("W")="123456789" - . D SDA^ORQRY01(.ERR,.ERRMSG) - . I CHECKERR,ERR K ^UTILITY("VASD",$J) S ORVISIT(1)=ERRMSG Q ;IA 10061 - . S I=0 F S I=$O(^UTILITY("VASD",$J,I)) Q:'I D - . . S XI=^UTILITY("VASD",$J,I,"I"),XE=^("E") - . . S DTM=$P(XI,U),IEN=$P(XI,U,2),STI=$P(XI,U,3) - . . S LOC=$P(XE,U,2),STS=$P(XE,U,3) - . . I DTMNOW D ;past encounters from ACRP Toolkit - set in CALLBACK - . S BDT=BEG - . S EDT=$S(END0 D Q:DONE - . . S MOV=0 F S MOV=$O(^DGPM("ATID1",DFN,TIM,MOV)) Q:MOV'>0 D Q:DONE - . . . S X0=^DGPM(MOV,0),MTIM=$P(X0,U) - . . . I MTIM0 F IFLE=1:1:$L(FILE,";") S ORFNUM=$P(FILE,";",IFLE) Q:'$D(^ORD(101.24,+ORFNUM,0)) S X0=^(0),X2=$G(^(2)) D + . S ID=$P(X0,"^",2),ENT=$P(X0,"^",6),RTN=$P(X0,"^",5),PARAM1=$P(X2,"^"),PARAM2=$P(X2,"^",2),INODE=$P(X2,"^",5),DETAIL="" + . I $P(X0,"^",18) S DETAIL=$P($G(^ORD(101.24,+$P(X0,"^",18),0)),"^",13),DETAIL=$P($G(^XWB(8994,+DETAIL,0)),"^") ;DBIA 4011 + . I '$L(INODE) Q + . I '$L(ENT) S LST(IFLE)="0^ERROR: Missing ENTRY POINT field in file 101.24 for "_$P(X0,"^")_", IFN="_+ORFNUM D LST2XTMP(INODE) Q + . I '$L(RTN) S LST(IFLE)="0^ERROR: Missing ROUTINE field in file 101.24 for "_$P(X0,"^")_", IFN="_+ORFNUM D LST2XTMP(INODE) Q + . I '$L($T(@(ENT_"^"_RTN))) S LST(IFLE)="0^ERROR: "_ENT_"~"_RTN_" does not exist. See file 101.24 entry: "_$P(X0,"^")_", IFN="_+ORFNUM D LST2XTMP(INODE) Q + . I ID=50 D:$L($T(STRT3^AWCMCPR1)) STRT3^AWCMCPR1 D D:$L($T(END^AWCMCPR1)) END^AWCMCPR1 Q ;Special case for reminders + .. I $G(NEWREM) D APPL^ORQQPXRM(.LST,DFN,LOC) I 1 + .. E D @(ENT_"^"_RTN_"(.LST,DFN)") + .. D LST2XTMP(INODE) + . I $L(PARAM1),$L(PARAM2) D @(ENT_"^"_RTN_"(.LST,DFN,PARAM1,PARAM2)"),LST2XTMP(INODE) Q + . I $L(PARAM1) D @(ENT_"^"_RTN_"(.LST,DFN,PARAM1)"),LST2XTMP(INODE) Q + . D @(ENT_"^"_RTN_"(.LST,DFN)"),LST2XTMP(INODE) + S ^XTMP(NODE,"DONE")=1 + I $G(^XTMP(NODE,"STOP")) K ^XTMP(NODE) + L -^XTMP(NODE) + Q +ERR ;Error trap + S $ETRAP="D UNWIND^ORWCV Q" + I $D(NODE) D + . I $D(INODE) S LST(0)="",LST(1)="0^ERROR DURING COVER SHEET BUILD:"_$ZERROR D LST2XTMP(INODE) + . S ^XTMP(NODE,"DONE")=1 + . L -^XTMP(NODE) + D @^%ZOSF("ERRTN") ;file error + S $ECODE=",UOR70 error during Cover Sheet build," + Q +UNWIND ;Unwind Error stack + Q:$ESTACK>1 ;pop the stack + ;add additional code here, if needed + Q +LST2XTMP(ID) ; put the list in ^XTMP(NODE,ID) + I $G(^XTMP(NODE,"STOP")) Q + N I + I $L($G(DETAIL)) S I=0 F S I=$O(LST(I)) Q:'I S $P(LST(I),"^",12)=DETAIL + K ^XTMP(NODE,ID) M ^XTMP(NODE,ID)=LST S ^XTMP(NODE,ID)=1 K LST + Q +POLL(LST,DFN,IP,HWND) ; poll for completed cover sheet parts + N I,ILST,ID,NODE,DONE + S NODE="ORWCV "_IP_"-"_HWND_"-"_DFN,ILST=0,DONE=0 + I '$D(^XTMP(NODE,"DFN")) Q + I ^XTMP(NODE,"DFN")'=DFN S LST(1)="~DONE=1" Q + I $G(^XTMP(NODE,"DONE")) S ILST=ILST+1,LST(ILST)="~DONE=1",DONE=1 + F ID="PROB","CWAD","MEDS","RMND","LABS","VITL","VSIT" D + . I '$G(^XTMP(NODE,ID)) Q + . S ILST=ILST+1,LST(ILST)="~"_ID + . S I=0 F S I=$O(^XTMP(NODE,ID,I)) Q:'I S ILST=ILST+1,LST(ILST)="i"_^(I) + . K ^XTMP(NODE,ID) + ; Stop capacity planning timing clock - was started in START code + I DONE K ^XTMP(NODE) I +$G(^KMPTMP("KMPD-CPRS")) S $P(^KMPTMP("KMPDT","ORWCV",NODE),"^",2)=$H + Q +STOP(OK,DFN,IP,HWND) ; stop cover sheet data retrieval + S NODE="ORWCV "_IP_"-"_HWND_"-"_DFN,ILST=0,DONE=0 + S ^XTMP(NODE,"STOP")=1,OK=1 + L +^XTMP(NODE) + I $G(^XTMP(NODE,"DONE")) K ^XTMP(NODE) + L -^XTMP(NODE) + Q +CLEAN ; clean up ^XTMP nodes + S X="ORWCV" + F S X=$O(^XTMP(X)) Q:$E(X,1,5)'="ORWCV" W !,X K ^XTMP(X) + Q +LAB(LST,DFN) ; return labs for patient + D:$L($T(STRT2^AWCMCPR1)) STRT2^AWCMCPR1 + D LIST^ORQOR1(.LST,DFN,"LAB",4,"T-"_$$RNGLAB(DFN),"T","AW",1) + D:$L($T(END^AWCMCPR1)) END^AWCMCPR1 + Q + ; +VST1(ORVISIT,DFN,BEG,END,SKIP) ; + N ERR,ERRMSG + S ERR=0 ; kludge to return errors + D VST(.ORVISIT,DFN,.BEG,.END,$G(SKIP),.ERR,.ERRMSG) + I ERR K ORVISIT S ORVISIT(1)=ERRMSG + Q + ; +TEST ;D VST(.ZZZ,76,2950101,3050401,777,1,1) + Q +VST(ORVISIT,DFN,BEG,END,SKIP,ERR,ERRMSG) ; return appts/admissions for patient + N CHECKERR,VAERR,VASD,BDT,COUNT,DTM,EDT,LOC,NOW,ORQUERY,ORLST,STI,STS,TODAY,I,J,K,XI,XE,X + S CHECKERR=($G(ERR)=0) ; kludge to check for errors + S NOW=$$NOW^XLFDT(),TODAY=$P(NOW,".",1) + I '$G(BEG) S BEG=$$X2FM($$RNGVBEG) + I '$G(END) S END=$$X2FM($$RNGVEND)+0.2359 + S COUNT=0 + K ^TMP("ORVSTLIST",$J) + S VAERR=0 + I END>NOW D Q:VAERR ; get future encounters, past cancels/no-shows from VADPT + . S VASD("F")=BEG + . S VASD("T")=END + . S VASD("W")="123456789" + . D SDA^ORQRY01(.ERR,.ERRMSG) + . I CHECKERR,ERR K ^UTILITY("VASD",$J) S ORVISIT(1)=ERRMSG Q ;IA 10061 + . S I=0 F S I=$O(^UTILITY("VASD",$J,I)) Q:'I D + . . S XI=^UTILITY("VASD",$J,I,"I"),XE=^("E") + . . S DTM=$P(XI,U),IEN=$P(XI,U,2),STI=$P(XI,U,3) + . . S LOC=$P(XE,U,2),STS=$P(XE,U,3) + . . I DTMNOW D ;past encounters from ACRP Toolkit - set in CALLBACK + . S BDT=BEG + . S EDT=$S(END0 D Q:DONE + . . S MOV=0 F S MOV=$O(^DGPM("ATID1",DFN,TIM,MOV)) Q:MOV'>0 D Q:DONE + . . . S X0=^DGPM(MOV,0),MTIM=$P(X0,U) + . . . I MTIM0 D - . S X0=$G(^ORD(101.41,DLG,10,I,0)),DPTR=$P(X0,U,2) - . S X2=$G(^ORD(101.41,DLG,10,I,2)) - . S XW=$G(^ORD(101.41,DLG,10,I,"W")) - . S N=N+1,Y(N)=$P(XW,U,1)_U_DPTR_U_X2,CHLD="" - . S J=0 F S J=$O(^ORD(101.41,DLG,10,"DAD",DPTR,J)) Q:'J D - . . S K=0 F S K=$O(^ORD(101.41,DLG,10,"DAD",DPTR,J,K)) Q:'K D - . . . S CHLD=CHLD_$P(^ORD(101.41,DLG,10,K,0),U,2)_"~" - . S $P(Y(N),U,8)=CHLD - Q -FORMID(VAL,ORIFN) ; procedure - ; Returns the Dialog Form ID - N X - S VAL=0,X=$P(^OR(100,+ORIFN,0),U,5) - Q:$P(X,";",2)'="ORD(101.41," - S VAL=+$P($G(^ORD(101.41,+X,5)),U,5) - ; I X S VAL=$P($G(^XTV(8989.52,+X,0)),U,2) - Q -GET4EDIT(LST,ORIFN) ; procedure - ; return responses in format that can be used by dialog - N ILST,PRMT,INST,DLG,ORDIALOG S ILST=0 - I '$D(ORIFN) S LST=0 Q - S ORIFN=+ORIFN,DLG=+$P(^OR(100,ORIFN,0),U,5) - D GETDLG1^ORCD(DLG),GETORDER^ORCD("^OR(100,"_ORIFN_",4.5)") - S PRMT=0 F S PRMT=$O(ORDIALOG(PRMT)) Q:'PRMT D - . S INST=0 F S INST=$O(ORDIALOG(PRMT,INST)) Q:'INST D - . . S ILST=ILST+1,LST(ILST)="~"_PRMT_U_INST_U_$P(ORDIALOG(PRMT),U,3) - . . S ILST=ILST+1,LST(ILST)="d"_ORDIALOG(PRMT,INST) - . . I $E(ORDIALOG(PRMT,INST))=U D ; load word processing - . . . N I,REF S I=0,REF=ORDIALOG(PRMT,INST) - . . . F S I=$O(@REF@(I)) Q:'I S ILST=ILST+1,LST(ILST)="t"_^(I,0) - . . E S $P(LST(ILST),U,2)=$$EXT^ORCD(PRMT,INST) ; load external value - . . I "R"[$E(ORDIALOG(PRMT,0)) D - . . . S $P(LST(ILST),U,2)=$$UP^XLFSTR($$FMTE^XLFDT(ORDIALOG(PRMT,INST))) - Q -EXTDT(X) ; Return an external date time that can be interpreted by %DT - I $E(X)="T" Q "TODAY"_$E(X,2,255) - I $E(X)="V" Q "NEXT VISIT"_$E(X,2,255) - Q "" -WRLST(Y,TYP) ; Return list of dialogs for writing orders - ; .Y(n): DlgName^ListBox Text - ; TYP: 'I' = inpatient, 'O' = outpatient - N PAR,ERR,SEQ,IEN,I,X - S PAR=$S(TYP="I":"ORW ADDORD INPT",1:"ORW ADDORD OUTPT") - D GETLST^XPAR(.X,"ALL",PAR,"Q",.ERR) Q:ERR - S I=0 F S I=$O(X(I)) Q:'I D - . S SEQ=$P(X(I),U,1),IEN=$P(X(I),U,2) - . S Y(SEQ)=$P(^ORD(101.41,IEN,0),U,1)_U_$P($G(^(5)),U,4) - Q -SAVE(Y,DFN,ORNP,LOC,DLG,ORWDACT,RSP) ; procedure - ; Save order - N ORDIALOG,ORL,ORVP,ORIFN,ORDUZ,ORSTS,ORDG,OREVENT,ORCAT,ORDA - I $P(^ORD(101.41,+DLG,0),U)="PSO OERR" S ORCAT="O" - I $P(^ORD(101.41,+DLG,0),U)="PSJ OR PAT OE" S ORCAT="I" - S ORVP=DFN_";DPT(",ORL(2)=LOC_";SC(",ORL=ORL(2) - D GETDLG^ORCD(DLG) - M ORDIALOG=RSP S ORDIALOG=DLG - I ORWDACT="N" D - . D EN^ORCSAVE - . S Y="" I ORIFN D GETBYIFN^ORWORR(.Y,ORIFN) - I $P(ORWDACT,U,1)="E" D - . S ORIFN=+$P(ORWDACT,U,2) D XX^ORCSAVE - . S Y="" S ORIFN=+$P(ORWDACT,U,2)_";"_ORDA D GETBYIFN^ORWORR(.Y,ORIFN) - Q -SIGN(ERRLST,DFN,ORNP,LOC,ORWSIGN) ; procedure - ; Sign orders (ORIFN;ACT^RELSTS^SIGSTS^NATR) - N ORVP,ORL,IDX,ANERROR,ERRCNT - S ORVP=DFN_";DPT(",ORL(2)=LOC_";SC(",ORL=ORL(2),ERRCNT=0 - I '$D(^XUSEC("ORES",DUZ)) S ERRLST(1)=0_U_"Must have ORES key." Q - S IDX=0 F S IDX=$O(ORWSIGN(IDX)) Q:'IDX S X=ORWSIGN(IDX) D - . ; ** change NATR when GUI changed to pass Nature in 4th piece - . S ORIFN=$P(X,U),RELSTS=$P(X,U,2),SIGSTS=$P(X,U,3),NATR="E" ;$P(X,U,4) - . I SIGSTS=2 D NOTIF^ORCSIGN S ANERROR="" - . I SIGSTS'=2 D EN^ORCSEND(ORIFN,"",SIGSTS,RELSTS,NATR,"",.ANERROR) - . I $L(ANERROR) D Q ; don't print if an error occurred - . . S ERRCNT=ERRCNT+1,ERRLST(ERRCNT)=$P(ORWSIGN(IDX),U)_U_ANERROR - . . K ORWSIGN(IDX) - . I RELSTS=0 K ORWSIGN(IDX) Q ; don't print if unreleased - . S ORWSIGN(IDX)=$P(ORWSIGN(IDX),U) - D PRINTS^ORWD1(.ORWSIGN,LOC) - Q -VALIDACT(VAL,ORIFN,ACTION) ;procedure - ; Return 1 if action is valid for this order, otherwise 0^error - S VAL=$$VALID^ORCACT0(ORIFN,ACTION,.ERR) - I VAL=0 S VAL=VAL_U_ERR - Q -SAVEACT(LST,ORIFN,ACTION,REASON,DFN,ORNP,LOC) ;procedure - ; Save this action for the order (it is still unsigned/unreleased) - N ORDIALOG,ORL,ORVP,ORDUZ,ORSTS,ORDG,OREVENT,ACTDA,SIGSTS,RELSTS,ASTS - S ORVP=DFN_";DPT(",ORL(2)=LOC_";SC(" - S SIGSTS=2,RELSTS=11 - I '$P(ORIFN,";",2) S $P(ORIFN,";",2)=1 - I (ACTION="FL")!(ACTION="UF")!(ACTION="WC") S SIGSTS=3,RELSTS="" - S ASTS=$P(^OR(100,+ORIFN,8,+$P(ORIFN,";",2),0),U,15) - I ACTION="DC",((ASTS=10)!(ASTS=11)) D Q ; exit here if DELETE - . D GETBYIFN^ORWORR(.LST,ORIFN) - . S $P(LST(1),U,1)="~0",LST(2)="tDELETED - "_$E(LST(2),2,245) - . D CANCEL^ORCSAVE2(ORIFN) - ; - ; the only valid action for ActDA>1 is deletion, so only orders - ; identified by ORIFN;1 should reach this point - ; - I $P(ORIFN,";",2)>1 S $ECODE=",Uorder action invalid," Q - I ACTION="FL" S $P(^OR(100,+ORIFN,6),U,1)=1 - I ACTION="UF" S $P(^OR(100,+ORIFN,6),U,1)=0 - I ACTION'="RN" D - . S ACTDA=$$ACTION^ORCSAVE(ACTION,+ORIFN,ORNP,REASON) - I ACTION="RN" D - . N ORDA,ORDIALOG,PRMT,SAVIFN,X0 - . S SAVIFN=+ORIFN,X0=^OR(100,+ORIFN,0) - . I $P(X0,U,5)["101.41," D ; version 3 - . . S ORDIALOG=+$P(X0,U,5),ORCAT=$P(^OR(100,+ORIFN,0),U,12) - . . D GETDLG^ORCD(ORDIALOG),GETORDER^ORCD(+ORIFN) - . E D ; version 2.5 generic - . . S ORDIALOG=$O(^ORD(101.41,"B","OR GXTEXT WORD PROCESSING ORDE",0)) - . . D GETDLG^ORCD(ORDIALOG) - . . S PRMT=$O(^ORD(101.41,"B","OR GTX WORD PROCESSING 1",0)) - . . S ORDIALOG(PRMT,1)=$NA(^TMP("ORWORD",$J,PRMT,1)) - . . M ^TMP("ORWORD",$J,PRMT,1)=^OR(100,+ORIFN,1) - . . S PRMT=$O(^ORD(101.41,"B","OR GTX START DATE/TIME",0)) - . . I $P(X0,U,9) S ORDIALOG(PRMT,1)=$P(X0,U,9) - . D RN^ORCSAVE I 'ORIFN S $ECODE=",UCPRS renew order," - . S ACTDA=ORDA,ORIFN=SAVIFN - I (ACTION="FL")!(ACTION="UF") S ACTDA=1 - D GETBYIFN^ORWORR(.LST,+ORIFN_";"_ACTDA) - S $P(LST(1),U,12)=ACTDA - Q +ORWD ; SLC/KCM - Utilities for Windows Dialogs ;7/26/96 17:53 [ 11/19/96 4:27 PM ] + ;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997 + ; +DT(Y,X) ; Returns internal Fileman Date/Time + N %DT S %DT="TS" D ^%DT + Q +PROVKEY(VAL,USERID) ; Returns 1 if user possesses the provider key + N NAM S NAM=$P(^VA(200,USERID,0),U,1) + S VAL=$D(^VA(200,"AK.PROVIDER",NAM,USERID)) + Q +KEY(VAL,KEYNAME,USERID) ; Returns 1 if user possesses the key + S VAL=0 I $D(^XUSEC(KEYNAME,USERID)) S VAL=1 + Q +OI(Y,XREF,DIR,FROM) ; Return a bolus of orderable items + ; .Return Array, Cross Reference (S.xxx), Direction, Starting Text + N I,IEN,CNT S CNT=44 + ; + I DIR=0 D ; Forward direction + . F I=1:1:CNT S FROM=$O(^ORD(101.43,XREF,FROM)) Q:FROM="" D + . . S Y(I)=$O(^ORD(101.43,XREF,FROM,0))_"^"_FROM + . I $G(Y(CNT))="" S Y(I)="" + ; + I DIR=1 D ; Reverse direction + . F I=1:1:CNT S FROM=$O(^ORD(101.43,XREF,FROM),-1) Q:FROM="" D + . . S Y(I)=$O(^ORD(101.43,XREF,FROM,0))_"^"_FROM + Q +ODEF(Y,DLG) ; Return the definition for a dialog + Q:'$L(DLG) + S DLG=+$O(^ORD(101.41,"B",DLG,0)) + Q:$D(^ORD(101.41,DLG,50))<10 + N I,IEN,IDX + S I=0,IDX=0 + S Y(0)=$P($G(^ORD(101.41,DLG,5)),"^",4) + F S I=$O(^ORD(101.41,DLG,50,"AC",I)) Q:I="" S IEN=$O(^(I,0)) D + . S IDX=IDX+1,Y(IDX)=$G(^ORD(101.41,DLG,50,IEN,0)) + Q +DEF(Y,DLG) ; Return format mapping for a dialog + ; Y(n): CtrlName^DlgPtr^FmtSeq^Fmt^Omit^Lead^Trail^Mult?^chd1~chd2~... + I DLG="NOT IMPLEMENTED" S Y(0)="0^0" Q ; for testing + S DLG=$O(^ORD(101.41,"B",DLG,0)) + N I,J,K,N,X0,X2,XW,DPTR + S Y(0)=$P(^ORD(101.41,DLG,0),U,5)_U_DLG + S I=0,N=0 + F S I=$O(^ORD(101.41,DLG,10,I)) Q:I'>0 D + . S X0=$G(^ORD(101.41,DLG,10,I,0)),DPTR=$P(X0,U,2) + . S X2=$G(^ORD(101.41,DLG,10,I,2)) + . S XW=$G(^ORD(101.41,DLG,10,I,"W")) + . S N=N+1,Y(N)=$P(XW,U,1)_U_DPTR_U_X2,CHLD="" + . S J=0 F S J=$O(^ORD(101.41,DLG,10,"DAD",DPTR,J)) Q:'J D + . . S K=0 F S K=$O(^ORD(101.41,DLG,10,"DAD",DPTR,J,K)) Q:'K D + . . . S CHLD=CHLD_$P(^ORD(101.41,DLG,10,K,0),U,2)_"~" + . S $P(Y(N),U,8)=CHLD + Q +FORMID(VAL,ORIFN) ; procedure + ; Returns the Dialog Form ID + N X + S VAL=0,X=$P(^OR(100,+ORIFN,0),U,5) + Q:$P(X,";",2)'="ORD(101.41," + S VAL=+$P($G(^ORD(101.41,+X,5)),U,5) + ; I X S VAL=$P($G(^XTV(8989.52,+X,0)),U,2) + Q +GET4EDIT(LST,ORIFN) ; procedure + ; return responses in format that can be used by dialog + N ILST,PRMT,INST,DLG,ORDIALOG S ILST=0 + I '$D(ORIFN) S LST=0 Q + S ORIFN=+ORIFN,DLG=+$P(^OR(100,ORIFN,0),U,5) + D GETDLG1^ORCD(DLG),GETORDER^ORCD("^OR(100,"_ORIFN_",4.5)") + S PRMT=0 F S PRMT=$O(ORDIALOG(PRMT)) Q:'PRMT D + . S INST=0 F S INST=$O(ORDIALOG(PRMT,INST)) Q:'INST D + . . S ILST=ILST+1,LST(ILST)="~"_PRMT_U_INST_U_$P(ORDIALOG(PRMT),U,3) + . . S ILST=ILST+1,LST(ILST)="d"_ORDIALOG(PRMT,INST) + . . I $E(ORDIALOG(PRMT,INST))=U D ; load word processing + . . . N I,REF S I=0,REF=ORDIALOG(PRMT,INST) + . . . F S I=$O(@REF@(I)) Q:'I S ILST=ILST+1,LST(ILST)="t"_^(I,0) + . . E S $P(LST(ILST),U,2)=$$EXT^ORCD(PRMT,INST) ; load external value + . . I "R"[$E(ORDIALOG(PRMT,0)) D + . . . S $P(LST(ILST),U,2)=$$UP^XLFSTR($$FMTE^XLFDT(ORDIALOG(PRMT,INST))) + Q +EXTDT(X) ; Return an external date time that can be interpreted by %DT + I $E(X)="T" Q "TODAY"_$E(X,2,255) + I $E(X)="V" Q "NEXT VISIT"_$E(X,2,255) + Q "" +WRLST(Y,TYP) ; Return list of dialogs for writing orders + ; .Y(n): DlgName^ListBox Text + ; TYP: 'I' = inpatient, 'O' = outpatient + N PAR,ERR,SEQ,IEN,I,X + S PAR=$S(TYP="I":"ORW ADDORD INPT",1:"ORW ADDORD OUTPT") + D GETLST^XPAR(.X,"ALL",PAR,"Q",.ERR) Q:ERR + S I=0 F S I=$O(X(I)) Q:'I D + . S SEQ=$P(X(I),U,1),IEN=$P(X(I),U,2) + . S Y(SEQ)=$P(^ORD(101.41,IEN,0),U,1)_U_$P($G(^(5)),U,4) + Q +SAVE(Y,DFN,ORNP,LOC,DLG,ORWDACT,RSP) ; procedure + ; Save order + N ORDIALOG,ORL,ORVP,ORIFN,ORDUZ,ORSTS,ORDG,OREVENT,ORCAT,ORDA + I $P(^ORD(101.41,+DLG,0),U)="PSO OERR" S ORCAT="O" + I $P(^ORD(101.41,+DLG,0),U)="PSJ OR PAT OE" S ORCAT="I" + S ORVP=DFN_";DPT(",ORL(2)=LOC_";SC(",ORL=ORL(2) + D GETDLG^ORCD(DLG) + M ORDIALOG=RSP S ORDIALOG=DLG + I ORWDACT="N" D + . D EN^ORCSAVE + . S Y="" I ORIFN D GETBYIFN^ORWORR(.Y,ORIFN) + I $P(ORWDACT,U,1)="E" D + . S ORIFN=+$P(ORWDACT,U,2) D XX^ORCSAVE + . S Y="" S ORIFN=+$P(ORWDACT,U,2)_";"_ORDA D GETBYIFN^ORWORR(.Y,ORIFN) + Q +SIGN(ERRLST,DFN,ORNP,LOC,ORWSIGN) ; procedure + ; Sign orders (ORIFN;ACT^RELSTS^SIGSTS^NATR) + N ORVP,ORL,IDX,ANERROR,ERRCNT + S ORVP=DFN_";DPT(",ORL(2)=LOC_";SC(",ORL=ORL(2),ERRCNT=0 + I '$D(^XUSEC("ORES",DUZ)) S ERRLST(1)=0_U_"Must have ORES key." Q + S IDX=0 F S IDX=$O(ORWSIGN(IDX)) Q:'IDX S X=ORWSIGN(IDX) D + . ; ** change NATR when GUI changed to pass Nature in 4th piece + . S ORIFN=$P(X,U),RELSTS=$P(X,U,2),SIGSTS=$P(X,U,3),NATR="E" ;$P(X,U,4) + . I SIGSTS=2 D NOTIF^ORCSIGN S ANERROR="" + . I SIGSTS'=2 D EN^ORCSEND(ORIFN,"",SIGSTS,RELSTS,NATR,"",.ANERROR) + . I $L(ANERROR) D Q ; don't print if an error occurred + . . S ERRCNT=ERRCNT+1,ERRLST(ERRCNT)=$P(ORWSIGN(IDX),U)_U_ANERROR + . . K ORWSIGN(IDX) + . I RELSTS=0 K ORWSIGN(IDX) Q ; don't print if unreleased + . S ORWSIGN(IDX)=$P(ORWSIGN(IDX),U) + D PRINTS^ORWD1(.ORWSIGN,LOC) + Q +VALIDACT(VAL,ORIFN,ACTION) ;procedure + ; Return 1 if action is valid for this order, otherwise 0^error + S VAL=$$VALID^ORCACT0(ORIFN,ACTION,.ERR) + I VAL=0 S VAL=VAL_U_ERR + Q +SAVEACT(LST,ORIFN,ACTION,REASON,DFN,ORNP,LOC) ;procedure + ; Save this action for the order (it is still unsigned/unreleased) + N ORDIALOG,ORL,ORVP,ORDUZ,ORSTS,ORDG,OREVENT,ACTDA,SIGSTS,RELSTS,ASTS + S ORVP=DFN_";DPT(",ORL(2)=LOC_";SC(" + S SIGSTS=2,RELSTS=11 + I '$P(ORIFN,";",2) S $P(ORIFN,";",2)=1 + I (ACTION="FL")!(ACTION="UF")!(ACTION="WC") S SIGSTS=3,RELSTS="" + S ASTS=$P(^OR(100,+ORIFN,8,+$P(ORIFN,";",2),0),U,15) + I ACTION="DC",((ASTS=10)!(ASTS=11)) D Q ; exit here if DELETE + . D GETBYIFN^ORWORR(.LST,ORIFN) + . S $P(LST(1),U,1)="~0",LST(2)="tDELETED - "_$E(LST(2),2,245) + . D DELETE^ORCSAVE2(ORIFN) + ; + ; the only valid action for ActDA>1 is deletion, so only orders + ; identified by ORIFN;1 should reach this point + ; + I $P(ORIFN,";",2)>1 S $ECODE=",Uorder action invalid," Q + I ACTION="FL" S $P(^OR(100,+ORIFN,6),U,1)=1 + I ACTION="UF" S $P(^OR(100,+ORIFN,6),U,1)=0 + I ACTION'="RN" D + . S ACTDA=$$ACTION^ORCSAVE(ACTION,+ORIFN,ORNP,REASON) + I ACTION="RN" D + . N ORDA,ORDIALOG,PRMT,SAVIFN,X0 + . S SAVIFN=+ORIFN,X0=^OR(100,+ORIFN,0) + . I $P(X0,U,5)["101.41," D ; version 3 + . . S ORDIALOG=+$P(X0,U,5),ORCAT=$P(^OR(100,+ORIFN,0),U,12) + . . D GETDLG^ORCD(ORDIALOG),GETORDER^ORCD(+ORIFN) + . E D ; version 2.5 generic + . . S ORDIALOG=$O(^ORD(101.41,"B","OR GXTEXT WORD PROCESSING ORDE",0)) + . . D GETDLG^ORCD(ORDIALOG) + . . S PRMT=$O(^ORD(101.41,"B","OR GTX WORD PROCESSING 1",0)) + . . S ORDIALOG(PRMT,1)=$NA(^TMP("ORWORD",$J,PRMT,1)) + . . M ^TMP("ORWORD",$J,PRMT,1)=^OR(100,+ORIFN,1) + . . S PRMT=$O(^ORD(101.41,"B","OR GTX START DATE/TIME",0)) + . . I $P(X0,U,9) S ORDIALOG(PRMT,1)=$P(X0,U,9) + . D RN^ORCSAVE I 'ORIFN S $ECODE=",UCPRS renew order," + . S ACTDA=ORDA,ORIFN=SAVIFN + I (ACTION="FL")!(ACTION="UF") S ACTDA=1 + D GETBYIFN^ORWORR(.LST,+ORIFN_";"_ACTDA) + S $P(LST(1),U,12)=ACTDA + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDAL32.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDAL32.m index 3f77123c..7397edca 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDAL32.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDAL32.m @@ -1,159 +1,123 @@ -ORWDAL32 ; SLC/REV - Allergy calls to support windows ;5/31/05 14:14 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,190,195,233,243**;Dec 17, 1997;Build 242 - ; -DEF(LST) ; Get dialog data for allergies - N ILST,I,X S ILST=0 - S LST($$NXT)="~Allergy Types" D ALLGYTYP - S LST($$NXT)="~Reactions" D ALLGYTYP - S LST($$NXT)="~Nature of Reaction" D NATREACT - S LST($$NXT)="~Top Ten" D TOPTEN - S LST($$NXT)="~Observ/Hist" D OBSHIST - S LST($$NXT)="~Severity" D SEVERITY - Q -GMRASITE(ORY) ;Return GMRA Site Params - N GMRASITE - D SITE^GMRAUTL - S ORY=$G(^GMRD(120.84,GMRASITE,0)) - Q -TOPTEN ; Get top ten symptoms from Allergy Site Parameters file - N X0,I,CNT,GMRASITE S I=0,X0="",CNT=0 ;233 - D SITE^GMRAUTL ;233 - F S I=$O(^GMRD(120.84,GMRASITE,1,I)),CNT=CNT+1 Q:+I=0!(CNT>10) D ;233 - . S X0=^GMRD(120.84,GMRASITE,1,I,0) Q:'$D(^GMRD(120.83,X0)) Q:$P(^GMRD(120.83,X0,0),"^")="OTHER REACTION" ;233 Don't send this entry - . ;233 Don't send if inactive term - . I $L($T(SCREEN^XTID)) Q:$$SCREEN^XTID(120.83,.01,X0_",") - . S LST($$NXT)="i"_X0_U_$P($G(^GMRD(120.83,X0,0)),U,1) - Q -ALLSRCH(Y,X) ; Return list of partial matches ; CHANGED TO PRODUCE TREEVIEW IN GUI - N ORX,ROOT,XP,CNT,ORFILE,ORSRC,ORIEN,ORREAX S ORIEN=0,CNT=0,ORSRC=0,ORFILE="" - S ORX=X,X=$$UP^XLFSTR(X) - F ROOT="^GMRD(120.82,""B"")","^GMRD(120.82,""D"")",$$B^PSNAPIS,$$T^PSNAPIS,"^PSDRUG(""B"")","^PSDRUG(""C"")","^PS(50.416,""P"")","^PS(50.605,""C"")" D - . S ORSRC=$G(ORSRC)+1,ORFILE=$P(ROOT,",",1)_")",ORSRC(ORSRC)=$P($T(FILENAME+ORSRC),";;",2) - . I (ORSRC'=2),(ORSRC'=6) S CNT=CNT+1,Y(CNT)=ORSRC_U_ORSRC(ORSRC)_U_U_U_"TOP"_U_"+" - . I ORSRC=1!(ORSRC=2) D - .. I $D(@ROOT@(X)) D - ... I ORSRC=1,X="OTHER ALLERGY/ADVERSE REACTION" Q ;don't send this entry - ... S ORIEN=$O(@ROOT@(X,0)) - ... I $L($T(SCREEN^XTID)) I $$SCREEN^XTID(120.82,.01,ORIEN_",") Q ;233 Is term active? - ... I ORSRC=2 S CNT=CNT+1,Y(CNT)=ORIEN_U_$P($G(^GMRD(120.82,+ORIEN,0)),U,1)_" <"_X_">"_ROOT - ... I ORSRC'=2 S CNT=CNT+1,Y(CNT)=ORIEN_U_X_ROOT - ... S Y(CNT)=Y(CNT)_U_$P($G(^GMRD(120.82,+Y(CNT),0)),U,2)_U_$S(ORSRC=2:1,1:ORSRC) - .. S XP=X F S XP=$O(@ROOT@(XP)) Q:XP="" Q:$E(XP,1,$L(X))'=X D - ... I ORSRC=1,XP="OTHER ALLERGY/ADVERSE REACTION" Q ;don't send this entry - ... S ORIEN=$O(@ROOT@(XP,0)) - ... I $L($T(SCREEN^XTID)) I $$SCREEN^XTID(120.82,.01,ORIEN_",") Q ;233 Is term active? - ... I ORSRC=2 S CNT=CNT+1,Y(CNT)=ORIEN_U_$P($G(^GMRD(120.82,+ORIEN,0)),U,1)_" <"_XP_">"_ROOT ; partial matches - ... I ORSRC'=2 S CNT=CNT+1,Y(CNT)=ORIEN_U_XP_ROOT - ... S Y(CNT)=Y(CNT)_U_$P($G(^GMRD(120.82,+Y(CNT),0)),U,2)_U_$S(ORSRC=2:1,1:ORSRC) - . I (ORSRC>2),(ORSRC'=4),(ORSRC'=5),(ORSRC'=6) D - .. N CODE,LIST,VAL,NAME - .. S CODE=$S(ORSRC=3:"S VAL=$$TGTOG2^PSNAPIS(X,.LIST)",ORSRC=4:"D TRDNAME(X,.LIST)",ORSRC=7:"D INGSRCH(X,.LIST)",ORSRC=8:"D CLASRCH(X,.LIST)",1:"") Q:'$L(CODE) - .. X CODE I $D(LIST) S ORIEN=0 F S ORIEN=$O(LIST(ORIEN)) Q:'ORIEN D - ... S NAME=$P(LIST(ORIEN),U,2) - ... Q:$E($P(LIST(ORIEN),U,2),1,$L(X))'=X - ... I $L($T(SCREEN^XTID)) I $$SCREEN^XTID($S(ORSRC=3:50.6,(ORSRC=4):50.6,ORSRC=7:50.416,ORSRC=8:50.605,1:0),.01,ORIEN_",") Q - ... S CNT=CNT+1,Y(CNT)=ORIEN_U_NAME_ROOT_U_"D"_U_ORSRC - . I ORSRC=4 D - .. N CODE,LIST,VAL,NAME - .. S CODE="D TRDNAME(X,.LIST)" - .. X CODE I $D(LIST) S ORIEN=0 F S ORIEN=$O(LIST(ORIEN)) Q:'ORIEN D - ... S NAME=$P(LIST(ORIEN),U,2) - ... Q:$E($P(LIST(ORIEN),U,2),1,$L(X))'=X - ... I $L($T(SCREEN^XTID)) I $$SCREEN^XTID(50.6,.01,+LIST(ORIEN)_",") Q - ... S CNT=CNT+1,Y(CNT)=+LIST(ORIEN)_U_NAME_ROOT_U_"D"_U_ORSRC - Q -FILENAME ; Display text of filenames for search treeview - ;;VA Allergies File - ;;VA Allergies File (Synonyms) SPACER ONLY - NOT DISPLAYED - ;;National Drug File - Generic Drug Name - ;;National Drug file - Trade Name - ;;Local Drug File - ;;Local Drug File (Synonyms) SPACER ONLY - NOT DISPLAYED - ;;Drug Ingredients File - ;;VA Drug Class File - ;; -NATREACT ; Get the NATURE OF REACTION types - ;Removing "R^Adverse Reaction" from choices below until we can add it as a choice in the nature of reaction/mechanism file - F X="A^Allergy","P^Pharmacological","U^Unknown" D - . S LST($$NXT)="i"_X - Q -ALLGYTYP ; Get the allergy types - F X="D^Drug","F^Food","O^Other","DF^Drug,Food","DO^Drug,Other","FO^Food,Other","DFO^Drug,Food,Other" D - . S LST($$NXT)="i"_X - Q -OBSHIST ; Observed or historical - F X="o^Observed","h^Historical" D - . S LST($$NXT)="i"_X - Q -SEVERITY ; Severity - F X="3^Severe","2^Moderate","1^Mild" D - . S LST($$NXT)="i"_X - Q -SYMPTOMS(Y,FROM,DIR) ; Return a subset of symptoms - ; .Return Array, Starting Text, Direction - N I,IEN,CNT,X,NAME,SUB S I=0,CNT=44 ;233 - K ^TMP($J,"SIGNS") ;233 - ;The following lines were added in 233. Now accounts for synonyms - M ^TMP($J,"SIGNS","B")=^GMRD(120.83,"B") ;233 - S SYN="" F S SYN=$O(^GMRD(120.83,"D",SYN)) Q:SYN="" S SUB=0 F S SUB=$O(^GMRD(120.83,"D",SYN,SUB)) Q:'+SUB D ;233 - .S NAME=$P(^GMRD(120.83,SUB,0),U) S ^TMP($J,"SIGNS","B",(SYN_$C(9)_"<"_NAME_">"_U_NAME),SUB)="" ;233 - F Q:I'10) D ;233 + . S X0=^GMRD(120.84,GMRASITE,1,I,0) Q:'$D(^GMRD(120.83,X0)) Q:$P(^GMRD(120.83,X0,0),"^")="OTHER REACTION" ;233 Don't send this entry + . I $L($T(SCREEN^XTID)) Q:$$SCREEN^XTID(120.83,.01,X0_",") ;233 Don't send if inactive term + . S LST($$NXT)="i"_X0_U_$P($G(^GMRD(120.83,X0,0)),U,1) + Q +ALLSRCH(Y,X) ; Return list of partial matches ; CHANGED TO PRODUCE TREEVIEW IN GUI + N ORX,ROOT,XP,CNT,ORFILE,ORSRC,ORIEN,ORREAX S ORIEN=0,CNT=0,ORSRC=0,ORFILE="",ORREAX="" + S ORX=X,X=$$UP^XLFSTR(X) + F ROOT="^GMRD(120.82,""B"")","^GMRD(120.82,""D"")",$$B^PSNAPIS,$$T^PSNAPIS,"^PSDRUG(""B"")","^PSDRUG(""C"")","^PS(50.416,""P"")","^PS(50.605,""C"")" D + . S ORSRC=ORSRC+1,ORFILE=$P(ROOT,",",1)_")",ORSRC(ORSRC)=$P($T(FILENAME+ORSRC),";;",2) + . I (ORSRC'=2),(ORSRC'=6) S CNT=CNT+1,Y(CNT)=ORSRC_U_ORSRC(ORSRC)_U_U_U_"TOP"_U_"+" + . I $D(@ROOT@(X)) D + . . I ORSRC=1,X="OTHER ALLERGY/ADVERSE REACTION" Q ;don't send this entry + . . I ORSRC=5!(ORSRC=6) Q ;233 don't send file 50 entries + . . S ORIEN=$O(@ROOT@(X,0)) + . . I $L($T(SCREEN^XTID)) I $$SCREEN^XTID($S(ORSRC=1!(ORSRC=2):120.82,ORSRC=3!(ORSRC=4):50.6,ORSRC=7:50.416,ORSRC=8:50.605,1:0),.01,$S(ORSRC=4:$$TGTOG^PSNAPIS(X)_",",1:ORIEN_",")) Q ;233 Is term active? + . . I ORSRC=2 S CNT=CNT+1,Y(CNT)=ORIEN_U_$P($G(^GMRD(120.82,+ORIEN,0)),U,1)_" <"_X_">"_ROOT + . . E I ORSRC=6 S CNT=CNT+1,Y(CNT)=ORIEN_U_$P($G(^PSDRUG(+ORIEN,0)),U,1)_" <"_X_">"_ROOT + . . E S CNT=CNT+1,Y(CNT)=ORIEN_U_X_ROOT + . . S ORREAX=$S($P(Y(CNT),U,3)?1"GMR".E:$P($G(^GMRD(120.82,+Y(CNT),0)),U,2),1:"D") + . . S Y(CNT)=Y(CNT)_U_ORREAX_U_$S(ORSRC=2:1,ORSRC=6:5,1:ORSRC) + . S XP=X F S XP=$O(@ROOT@(XP)) Q:XP="" Q:$E(XP,1,$L(X))'=X D + . . I ORSRC=1,XP="OTHER ALLERGY/ADVERSE REACTION" Q ;don't send this entry + . . I ORSRC=5!(ORSRC=6) Q ;233 Don't send file 50 entries + . . S ORIEN=$O(@ROOT@(XP,0)) + . . I $L($T(SCREEN^XTID)) I $$SCREEN^XTID($S(ORSRC=1!(ORSRC=2):120.82,ORSRC=3!(ORSRC=4):50.6,ORSRC=7:50.416,ORSRC=8:50.605,1:0),.01,$S(ORSRC=4:$$TGTOG^PSNAPIS(XP)_",",1:ORIEN_",")) Q ;233 Is term active? + . . I ORSRC=2 S CNT=CNT+1,Y(CNT)=ORIEN_U_$P($G(^GMRD(120.82,+ORIEN,0)),U,1)_" <"_XP_">"_ROOT ; partial matches + . . E I ORSRC=6 S CNT=CNT+1,Y(CNT)=ORIEN_U_$P($G(^PSDRUG(+ORIEN,0)),U,1)_" <"_XP_">"_ROOT ; partial matches + . . E S CNT=CNT+1,Y(CNT)=ORIEN_U_XP_ROOT + . . S ORREAX=$S($P(Y(CNT),U,3)?1"GMR".E:$P($G(^GMRD(120.82,+Y(CNT),0)),U,2),1:"D") + . . S Y(CNT)=Y(CNT)_U_ORREAX_U_$S(ORSRC=2:1,ORSRC=6:5,1:ORSRC) + Q +FILENAME ; Display text of filenames for search treeview + ;;VA Allergies File + ;;VA Allergies File (Synonyms) SPACER ONLY - NOT DISPLAYED + ;;National Drug File - Generic Drug Name + ;;National Drug file - Trade Name + ;;Local Drug File + ;;Local Drug File (Synonyms) SPACER ONLY - NOT DISPLAYED + ;;Drug Ingredients File + ;;VA Drug Class File + ;; +NATREACT ; Get the NATURE OF REACTION types + ;Removing "R^Adverse Reaction" from choices below until we can add it as a choice in the nature of reaction/mechanism file + F X="A^Allergy","P^Pharmacological","U^Unknown" D + . S LST($$NXT)="i"_X + Q +ALLGYTYP ; Get the allergy types + F X="D^Drug","F^Food","O^Other","DF^Drug,Food","DO^Drug,Other","FO^Food,Other","DFO^Drug,Food,Other" D + . S LST($$NXT)="i"_X + Q +OBSHIST ; Observed or historical + F X="o^Observed","h^Historical" D + . S LST($$NXT)="i"_X + Q +SEVERITY ; Severity + F X="3^Severe","2^Moderate","1^Mild" D + . S LST($$NXT)="i"_X + Q +SYMPTOMS(Y,FROM,DIR) ; Return a subset of symptoms + ; .Return Array, Starting Text, Direction + N I,IEN,CNT,X,NAME,SUB S I=0,CNT=44 ;233 + K ^TMP($J,"SIGNS") ;233 + ;The following lines were added in 233. Now accounts for synonyms + M ^TMP($J,"SIGNS","B")=^GMRD(120.83,"B") ;233 + S SYN="" F S SYN=$O(^GMRD(120.83,"D",SYN)) Q:SYN="" S SUB=0 F S SUB=$O(^GMRD(120.83,"D",SYN,SUB)) Q:'+SUB D ;233 + .S NAME=$P(^GMRD(120.83,SUB,0),U) S ^TMP($J,"SIGNS","B",(SYN_$C(9)_"<"_NAME_">"_U_NAME),SUB)="" ;233 + F Q:I'1 Q ;canceled order (2) & ? (3) - . S TEST(ORD)=ORLST(ORI)_DR - Q - ; -SCPRE(DR,DFN) ; Dialog validation, to ask BA questions - ; - ; DR = return value - ; DFN = input patient IEN - ; - Q:$G(DFN)="" - N CPNODE,CT,I,ORX,ORSDCARY,TF,X - K ORSDCARY - S (CPNODE,DR,ORX,TF)="",CT=0,X="T" - ; Call API to acquire Treatment Factors in force - D NOW^%DTC,CL^SDCO21(DFN,%,"",.ORSDCARY) ;DBIA 406 - ; Retrved array order: AO,IR,SC,EC,MST,HNC,CV,SHD e.g., ORSDCARY(3) for SC - ; Convert to ^OR/CPRS GUI order: SC,MST,AO,IR,EC,HNC,CV,SHD - F I=3,5,1,2,4,6,7,8 S TF=0,CT=CT+1 S:$D(ORSDCARY(I)) TF=1 S $P(CPNODE,U,CT)=TF - ; - S X=$S($P(CPNODE,U)=1:"SC",1:""),DR=$S($L(X):DR_U_X,1:DR) - S X=$S($P(CPNODE,U,2)=1:"MST",1:""),DR=$S($L(X):DR_U_X,1:DR) - S X=$S($P(CPNODE,U,3)=1:"AO",1:""),DR=$S($L(X):DR_U_X,1:DR) - S X=$S($P(CPNODE,U,4)=1:"IR",1:""),DR=$S($L(X):DR_U_X,1:DR) - S X=$S($P(CPNODE,U,5)=1:"EC",1:""),DR=$S($L(X):DR_U_X,1:DR) - S X=$S($P(CPNODE,U,6)=1:"HNC",1:""),DR=$S($L(X):DR_U_X,1:DR) - S X=$S($P(CPNODE,U,7)=1:"CV",1:""),DR=$S($L(X):DR_U_X,1:DR) - S X=$S($P(CPNODE,U,8)=1:"SHD",1:""),DR=$S($L(X):DR_U_X,1:DR) - ; - ; TxF's for patient (TxF's include SC,AO,IR,EC,MST,HNC,CV,SHD) where - ; SC = Service Connected - ; AO = Agent Orange - ; IR = Ionizing Radiation - ; EC = Environmental Contaminants - ; MST = Military Sexual Trauma - ; HNC = Head and Neck Cancer - ; CV = Combat Veteran - ; SHD = Shipboard Disability - F I="SC","AO","IR","EC","MST","HNC","CV","SHD" D - . I $D(ORX(I)) S DR=DR_U_I_$S($L(ORX(I)):";"_ORX(I),1:"") - Q - ; -ORPKGTYP(Y,ORLST) ; Build BA supported packages array - ; GMRC=Prosthetics, LR=Lab, PSO=Pharmacy, RA=Radiology - N OIREC,OIV,OIVN - ; - F I=1:1 S ORPKG=$P("GMRC;LR;PSO;RA",";",I) Q:ORPKG="" D - . S ORPKG(+$O(^DIC(9.4,"C",ORPKG,0)))=ORPKG ; ^DIC(9.4) is package file - ; - S GMRCPROS=+$O(^DIC(9.4,"C","GMRC",0)) - ; see if order is for a package which BA supports - D ORPKG1(.Y,.ORLST) - Q - ; -ORPKG1(TEST,ORIFNS) ; Order for package BA supports? TEST(ORI)=1 is YES - S U="^",ORI="" - F I=1:1:5 S OIV(I)=$P("PROSTHETICS REQUEST^EYEGLASS REQUEST^CONTACT LENS REQUEST^HOME OXYGEN REQUEST^AMPUTEE/PROSTHETICS CLINIC",U,I) - F S ORI=$O(ORIFNS(ORI)) Q:'ORI S ORD=+ORIFNS(ORI),TEST(ORI)=0 D - . I ORD=0 Q ;document/note not an order - . ;I ORD="CONSULT_DX" S TEST(ORI)=1 Q ;consult dx prev entered - . I '$D(^OR(100,ORD,0)) Q ;invalid order # - . I $P(^OR(100,ORD,0),U,14)'?1N.N Q ;invalid order # or entry - . I $E($P(ORIFNS(ORI),";",2))>1 Q ;canceled order (2) & ? (3) - . I $D(^OR(100,ORD,5.1,1,0)) S TEST(ORI)=1 Q ; - . I '$D(ORPKG($P(^OR(100,ORD,0),U,14))) Q ;pkg not supported - . ; IPt OPt (ask BA questions?) - . ; Pros Y Y GMRC - . ; Rad Y Y RA - . ; Lab N Y LR - . ; Phrm Y Y PSO - . ; Pt Class = 'I' or 'O' in ^OR - . I $P(^OR(100,ORD,0),U,12)="I"&(ORPKG($P(^OR(100,ORD,0),U,14))="LR") Q - . I $P(^OR(100,ORD,0),U,14)=GMRCPROS D Q ;check for Pros consult order - .. S OIREC=$G(^ORD(101.43,$G(^OR(100,ORD,4.5,1,1)),0)),OIVN="" - .. F S OIVN=$O(OIV(OIVN)) Q:OIVN="" I OIV(OIVN)=$E($P(OIREC,U),1,$L(OIV(OIVN))) S TEST(ORI)=1 Q - . S TEST(ORI)=1 ;order is for a supported pkg (also note Pros ck above) - Q - ; -BASTATUS(Y) ;RPC to retrieve the status of the Billing Awareness software - ; Y = Returned Value (1=BA usable, 0=BA not-usable) - ; Check for installation of CIDC ancillary build - S Y=$D(^XPD(9.7,"B","PX CLINICAL INDICATOR DATA CAPTURE 1.0")) - Q:'Y - ; Check if system parameter switch set - S Y=$$CHKPS1^ORWDBA5 - Q - ; -BASTAT() ; Internal version of BASTATUS - ; Returns 0 if disabled or 1 if enabled - Q $$CHKPS1^ORWDBA5 - ; -RCVORCI(Y,DIAG) ;Receive order related Clinical Indicators & Diagnoses from GUI - ; Store data in ^OR(100,ODN,5.1) & ^OR(100,0DN,5.2) - ; - N DXIEN,ODN,ORIEN,SCI,OCDXCT,OCT - S ODN="",OCDXCT=0,Y="" - F S ODN=$O(DIAG(ODN)) Q:ODN="" D - . S ORIEN=$P(DIAG(ODN),";",1) ;Order IEN - . I ORIEN'?1N.N S Y=0 Q - . K ^OR(100,ORIEN,5.1) ;Clear currently stored diagnosis for rewrite - . ; Data from Delphi format: ORIEN;11CNNNCNN^exDx1^exDx2^exDx3^exDx4 - . ; Convert 8 Tx Factors - . S SCI=$$TFGUIGBL($RE($E($RE($P(DIAG(ODN),U)),1,8))) - . S ^OR(100,ORIEN,5.2)=SCI ;Store TFs (SC,MST,AO,IR,EC,HNC,CV,SHD) - . ; Get order date for CSV/CTD/HIPAA - . S ORFMDAT=$$ORFMDAT^ORWDBA3(ORIEN) - . ; Go through the diagnoses entered - . F OCT=2:1 Q:$P(DIAG(ODN),U,OCT)="" D - .. S DXIEN=$P($$ICDDX^ICDCODE($P(DIAG(ODN),U,OCT),ORFMDAT),U,1) ;Dx IEN - .. I DXIEN=-1!(DXIEN="") Q ;No or invalid code passed in - .. S OCDXCT=OCDXCT+1 - .. S ^OR(100,ORIEN,5.1,0)="^100.051PA^"_OCDXCT_U_OCDXCT ;Set 5.1 zero node - .. S ^OR(100,ORIEN,5.1,OCDXCT,0)=DXIEN ;Store a diagnosis for order - .. S ^OR(100,ORIEN,5.1,"B",DXIEN,OCDXCT)="" ;Index diagnosis for order - S:Y="" Y=1 - Q - ; -TFSTGS ; Set Treatment Factor strings sequence order - ; TFGBL is order of TxFs in ^OR(100,ORIEN,5) & ^OR(100,ORIEN,5.2) - ; TFGUI is order of TxFs to/from GUI - ; TFTBL is order of TxFs for table SD008 (used in ZCL segment) - ; NOTE: change examples in TFGUIGBL and TFGBLGUI if order changed - S TFGBL="SC^MST^AO^IR^EC^HNC^CV^SHD" - S TFGUI="SC^AO^IR^EC^MST^HNC^CV^SHD" - S TFTBL="AO^IR^SC^EC^MST^HNC^CV^SHD" - Q - ; -TFGUIGBL(GUI) ;Convert Treatment Factors from GUI to Global order & format - ; - ; Input: GUI in CNU?NCU: C=checked, N=not checked, U=unchecked - ; Output: GBL in 1^^^0^?^1^0^ (global) format (reordered for storage) - ; - N GBL,J,NTF,TF,TFGBL,TFGUI,TFTBL - S GBL="",NTF=8 ;NTF=# of Treatment Factors (TxF) - ;I $L(GUI)'=NTF Q -1 ;invalid # of TxF - ; Get Treatment Factor sequence order strings - D TFSTGS - ; Convert from GBL to GUI format and sequence - F J=1:1:NTF S TF=$E(GUI,J) D - . S TF($P(TFGUI,U,J))=$S(TF="C":1,TF="U":0,TF="?":"?",1:"") - F J=1:1:NTF S GBL=GBL_U_TF($P(TFGBL,U,J)) - Q $P(GBL,U,2,NTF+1) - ; -TFGBLGUI(GBL) ;Convert Treatment Factors from Global to GUI order & format - ; - ; Input: GBL in 1^0^1^1^^0^?^ (global) format - ; Output: GUI in CCCNUU? (GUI) format (also reordered) - ; - N GUI,J,NTF,TF,TFGBL,TFGUI,TFTBL - S GUI="",NTF=8 ;NCI=# of TxF - ; Get Treatment Factor sequence order strings - D TFSTGS - ; Convert from GUI to GBL format and sequence - F J=1:1:NTF S TF=$P(GBL,U,J) D - . S TF($P(TFGBL,U,J))=$S(TF=1:"C",TF=0:"U",TF="?":"?",1:"N") - F J=1:1:NTF S GUI=GUI_TF($P(TFGUI,U,J)) - Q GUI - ; -PRVKEY(X) ;Check for active & provider key - to be deleted in CPRS v26 - N PTD - Q:'+$G(X) 0 - Q:$G(^VA(200,X,0))="" 0 - S PTD=+$P(^VA(200,X,0),"^",11) - I $$DT^XLFDT'0 Q 0 - Q:$D(^XUSEC("PROVIDER",X)) 1 - Q 0 - ; -ORESKEY(X) ;Does 'X' hold ORES key, returns: 1=true, 0=false - Q:'+$G(X) 0 - Q:$D(^XUSEC("ORES",X)) 1 - Q 0 +ORWDBA1 ;; SLC OIFO/DKK/GSS - Order Dialogs Billing Awareness;[10/21/03 3:16pm] + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**190,195,229,215**;Dec 17, 1997 + ; + ; External References + ; DBIA 406 CL^SDCO21 - call to determine Treatment Factors + ; + ;Ref to ^DIC(9.4 - DBIA ___ + ;BA refers to Billing Awareness Project + ;CIDC refers to Clinical Indicator Data Capture (same project 3/10/2004) + ;Treatment Factors (TxF) refer to SC,AO,IR,EC,MST,HNC,CV + ; +GETORDX(Y,ORIEN) ; Retrieve Diagnoses for an order - RPC + ; Input: + ; ORIEN Order Internal ID# + ; Output: + ; Y Array of Diagnoses (Dx) - Y(#)=#^DxInt#^ICD9^DxDesc^TxF + ; Variables used: + ; CT Counter for # of Dx related to order + ; DXIEN Dx internal ID + ; DXN Internal (to ^OR(100)) sequence # for Dx storage + ; DXREC Dx record from Order file + ; DXV Dx description + ; ICD9 External ICD9 # + ; TXFACTRS Treatment Factors (TxF) + ; + N CT,DXIEN,DXN,DXREC,DXV,ICD9,ICDR,ORFMDAT,TXFACTRS + S (CT,DXN)=0 + I '$G(^OR(100,ORIEN,0)) S Y=-1 + I '$D(^OR(100,ORIEN,5.1,1,0)) S Y=0 + E D S Y=CT + . ; Get order date for CSV/CTD/HIPAA usage + . S ORFMDAT=$$ORFMDAT^ORWDBA3(ORIEN) + . ; Go through all Dx's for an order + . F S DXN=$O(^OR(100,ORIEN,5.1,DXN)) Q:DXN'?1N.N D + .. ; Get diagnosis record and IEN + .. S DXREC=$G(^OR(100,ORIEN,5.1,DXN,0)),DXIEN=$P(DXREC,U) + .. S ICDR=$$ICDDX^ICDCODE($G(DXIEN),ORFMDAT) + .. S DXV=$P(ICDR,U,4),ICD9=$P(ICDR,U,2) + .. ; Convert internal to external Treatment Factors + .. S TXFACTRS=$$TFGBLGUI(^OR(100,ORIEN,5.2)) + .. S CT=CT+1,Y(CT)=DXN_U_$G(DXIEN)_U_ICD9_U_DXV_U_TXFACTRS + Q + ; +SCLST(Y,DFN,ORLST) ; RPC for compiling appropriate TxF's + ; RPC titled ORWDBA1 SCLST + ; + ; Y = Returned value + ; DFN = Patient IEN + ; ORLST = List of orders + ; + ; call for BA/TF + N GMRCPROS,ORD,ORI,ORPKG + D CPLSTBA(.Y,DFN,.ORLST) + Q + ; +CPLSTBA(TEST,PTIFN,ORIFNS) ; set-up SC/TFs for BA + ; + ; TEST = Returned value + ; PTIFN = Patient IEN + ; ORIFNS = List of orders + ; + S ORI="" + ; + ; define array of packages for which BA data collected (SC/CIs) + ; GMRC = Consult/Request Tracking (#128) - Prosthetics + ; LR = Lab Services (#26) - Lab + ; PSO = Outpt Pharmacy (#112) - Outpt Pharmacy (orig. Co-Pay) + ; RA = Radiology/Nuclear Medicine (#31) - Radiology + ; + F I=1:1 S ORPKG=$P("GMRC;LR;PSO;RA",";",I) Q:ORPKG="" D + . S ORPKG(+$O(^DIC(9.4,"C",ORPKG,0)))=1 ; ^DIC(9.4) is package file + ; + ; get Treatment Factors (TxF) for patient + D SCPRE(.DR,DFN) + ; + ; set TxF's if order is for a package for which BA data is collected + F S ORI=$O(ORLST(ORI)) Q:'ORI S ORD=+ORLST(ORI) D + . I $G(^OR(100,ORD,0))="" Q + . I $D(TEST(ORD))!'$D(ORPKG($P($G(^OR(100,ORD,0)),U,14))) Q + . S TEST(ORD)=ORLST(ORI)_DR + Q + ; +SCPRE(DR,DFN) ; Dialog validation, to ask BA questions + ; + ; DR = return value + ; DFN = input patient IEN + ; + Q:$G(DFN)="" + N CPNODE,CT,I,ORX,ORSDCARY,TF,X + K ORSDCARY + S (CPNODE,DR,ORX,TF)="",CT=0,X="T" + ; Call API to acquire Treatment Factors in force + D NOW^%DTC,CL^SDCO21(DFN,%,"",.ORSDCARY) ;DBIA 406 + ; Retrved array order: AO,IR,SC,EC,MST,HNC,CV, e.g., ORSDCARY(3) for SC + ; Convert to ^OR/CPRS GUI order: SC,MST,AO,IR,EC,HNC,CV + F I=3,5,1,2,4,6,7 S TF=0,CT=CT+1 S:$D(ORSDCARY(I)) TF=1 S $P(CPNODE,U,CT)=TF + ; + S X=$S($P(CPNODE,U)=1:"SC",1:""),DR=$S($L(X):DR_U_X,1:DR) + S X=$S($P(CPNODE,U,2)=1:"MST",1:""),DR=$S($L(X):DR_U_X,1:DR) + S X=$S($P(CPNODE,U,3)=1:"AO",1:""),DR=$S($L(X):DR_U_X,1:DR) + S X=$S($P(CPNODE,U,4)=1:"IR",1:""),DR=$S($L(X):DR_U_X,1:DR) + S X=$S($P(CPNODE,U,5)=1:"EC",1:""),DR=$S($L(X):DR_U_X,1:DR) + S X=$S($P(CPNODE,U,6)=1:"HNC",1:""),DR=$S($L(X):DR_U_X,1:DR) + S X=$S($P(CPNODE,U,7)=1:"CV",1:""),DR=$S($L(X):DR_U_X,1:DR) + ; + ; TxF's for patient (TxF's include SC,AO,IR,EC,MST,HNC,CV) where + ; SC = Service Connected + ; AO = Agent Orange + ; IR = Ionizing Radiation + ; EC = Environmental Contaminants + ; MST = Military Sexual Trauma + ; HNC = Head and Neck Cancer + ; CV = Combat Veteran + F I="SC","AO","IR","EC","MST","HNC","CV" D + . I $D(ORX(I)) S DR=DR_U_I_$S($L(ORX(I)):";"_ORX(I),1:"") + Q + ; +ORPKGTYP(Y,ORLST) ; Build BA supported packages array + ; GMRC=Prosthetics, LR=Lab, PSO=Pharmacy, RA=Radiology + N OIREC,OIV,OIVN + F I=1:1 S ORPKG=$P("GMRC;LR;PSO;RA",";",I) Q:ORPKG="" D + . S ORPKG(+$O(^DIC(9.4,"C",ORPKG,0)))=ORPKG ; ^DIC(9.4) is package file + S GMRCPROS=+$O(^DIC(9.4,"C","GMRC",0)) + ; see if order is for a package which BA supports + D ORPKG1(.Y,.ORLST) + Q + ; +ORPKG1(TEST,ORIFNS) ; Order for package BA supports? TEST(ORI)=1 is YES + S U="^",ORI="" + F I=1:1:5 S OIV(I)=$P("PROSTHETICS REQUEST^EYEGLASS REQUEST^CONTACT LENS REQUEST^HOME OXYGEN REQUEST^AMPUTEE/PROSTHETICS CLINIC",U,I) + F S ORI=$O(ORIFNS(ORI)) Q:'ORI S ORD=+ORIFNS(ORI),TEST(ORI)=0 D + . I ORD=0 Q ;document/note not an order + . ;I ORD="CONSULT_DX" S TEST(ORI)=1 Q ;consult dx prev entered + . I '$D(^OR(100,ORD,0)) Q ;invalid order # + . I $P(^OR(100,ORD,0),U,14)'?1N.N Q ;invalid order # or entry + . I $E($P(ORIFNS(ORI),";",2))>1 Q ;canceled order (2) & ? (3) + . I $D(^OR(100,ORD,5.1,1,0)) S TEST(ORI)=1 Q ; + . I '$D(ORPKG($P(^OR(100,ORD,0),U,14))) Q ;pkg not supported + . ; IPt OPt (ask BA questions?) + . ; Pros Y Y GMRC + . ; Rad Y Y RA + . ; Lab N Y LR + . ; Phrm Y Y PSO + . ; Pt Class = 'I' or 'O' in ^OR + . I $P(^OR(100,ORD,0),U,12)="I"&(ORPKG($P(^OR(100,ORD,0),U,14))="LR") Q + . I $P(^OR(100,ORD,0),U,14)=GMRCPROS D Q ;check for Pros consult order + .. S OIREC=$G(^ORD(101.43,$G(^OR(100,ORD,4.5,1,1)),0)),OIVN="" + .. F S OIVN=$O(OIV(OIVN)) Q:OIVN="" I OIV(OIVN)=$E($P(OIREC,U),1,$L(OIV(OIVN))) S TEST(ORI)=1 Q + . S TEST(ORI)=1 ;order is for a supported pkg (also note Pros ck above) + Q + ; +BASTATUS(Y) ;RPC to retrieve the status of the Billing Awareness software + ; Y = Returned Value (1=BA usable, 0=BA not-usable) + ; Check for installation of CIDC ancillary build + S Y=$D(^XPD(9.7,"B","PX CLINICAL INDICATOR DATA CAPTURE 1.0")) + Q:'Y + ; Check if system parameter switch set + S Y=$$CHKPS1^ORWDBA5 + Q + ; +BASTAT() ; Internal version of BASTATUS + ; Returns 0 if disabled or 1 if enabled + Q $$CHKPS1^ORWDBA5 + ; +RCVORCI(Y,DIAG) ;Receive order related Clinical Indicators & Diagnoses from GUI + ; Store data in ^OR(100,ODN,5.1) & ^OR(100,0DN,5.2) + ; + N DXIEN,ODN,ORIEN,SCI,OCDXCT,OCT + S ODN="",OCDXCT=0,Y="" + F S ODN=$O(DIAG(ODN)) Q:ODN="" D + . S ORIEN=$P(DIAG(ODN),";",1) ;Order IEN + . I ORIEN'?1N.N S Y=0 Q + . K ^OR(100,ORIEN,5.1) ;Clear currently stored diagnosis for rewrite + . ; Data from Delphi format: ORIEN;11CNNNCNN^exDx1^exDx2^exDx3^exDx4 + . ; Convert 7 Tx Factors + . S SCI=$$TFGUIGBL($RE($E($RE($P(DIAG(ODN),U)),1,7))) + . S ^OR(100,ORIEN,5.2)=SCI ;Store TFs (SC,MST,AO,IR,EC..) + . ; Get order date for CSV/CTD/HIPAA + . S ORFMDAT=$$ORFMDAT^ORWDBA3(ORIEN) + . ; Go through the diagnoses entered + . F OCT=2:1 Q:$P(DIAG(ODN),U,OCT)="" D + .. S DXIEN=$P($$ICDDX^ICDCODE($P(DIAG(ODN),U,OCT),ORFMDAT),U,1) ;Dx IEN + .. I DXIEN=-1!(DXIEN="") Q ;No or invalid code passed in + .. S OCDXCT=OCDXCT+1 + .. S ^OR(100,ORIEN,5.1,0)="^100.051PA^"_OCDXCT_U_OCDXCT ;Set 5.1 zero node + .. S ^OR(100,ORIEN,5.1,OCDXCT,0)=DXIEN ;Store a diagnosis for order + .. S ^OR(100,ORIEN,5.1,"B",DXIEN,OCDXCT)="" ;Index diagnosis for order + S:Y="" Y=1 + Q + ; +TFSTGS ; Set Treatment Factor strings sequence order + ; TFGBL is order of TxFs in ^OR(100,ORIEN,5) & ^OR(100,ORIEN,5.2) + ; TFGUI is order of TxFs to/from GUI + ; TFTBL is order of TxFs for table SD008 (used in ZCL segment) + ; NOTE: change examples in TFGUIGBL and TFGBLGUI if order changed + S TFGBL="SC^MST^AO^IR^EC^HNC^CV" + S TFGUI="SC^AO^IR^EC^MST^HNC^CV" + S TFTBL="AO^IR^SC^EC^MST^HNC^CV" + Q + ; +TFGUIGBL(GUI) ;Convert Treatment Factors from GUI to Global order & format + ; + ; Input: GUI in CNU?NCU: C=checked, N=not checked, U=unchecked + ; Output: GBL in 1^^^0^?^1^0 (global) format (reordered for storage) + ; + N GBL,J,NTF,TF,TFGBL,TFGUI,TFTBL + S GBL="",NTF=7 ;NTF=# of Treatment Factors (TxF) + ;I $L(GUI)'=NTF Q -1 ;invalid # of TxF + ; Get Treatment Factor sequence order strings + D TFSTGS + ; Convert from GBL to GUI format and sequence + F J=1:1:NTF S TF=$E(GUI,J) D + . S TF($P(TFGUI,U,J))=$S(TF="C":1,TF="U":0,TF="?":"?",1:"") + F J=1:1:NTF S GBL=GBL_U_TF($P(TFGBL,U,J)) + Q $P(GBL,U,2,NTF+1) + ; +TFGBLGUI(GBL) ;Convert Treatment Factors from Global to GUI order & format + ; + ; Input: GBL in 1^0^1^1^^0^? (global) format + ; Output: GUI in CCCNUU? (GUI) format (also reordered) + ; + N GUI,J,NTF,TF,TFGBL,TFGUI,TFTBL + S GUI="",NTF=7 ;NCI=# of TxF + ; Get Treatment Factor sequence order strings + D TFSTGS + ; Convert from GUI to GBL format and sequence + F J=1:1:NTF S TF=$P(GBL,U,J) D + . S TF($P(TFGBL,U,J))=$S(TF=1:"C",TF=0:"U",TF="?":"?",1:"N") + F J=1:1:NTF S GUI=GUI_TF($P(TFGUI,U,J)) + Q GUI + ; +PRVKEY(X) ;Check for active & provider key - to be deleted in CPRS v26 + N PTD + Q:'+$G(X) 0 + Q:$G(^VA(200,X,0))="" 0 + S PTD=+$P(^VA(200,X,0),"^",11) + I $$DT^XLFDT'0 Q 0 + Q:$D(^XUSEC("PROVIDER",X)) 1 + Q 0 + ; +ORESKEY(X) ;Does 'X' hold ORES key, returns: 1=true, 0=false + Q:'+$G(X) 0 + Q:$D(^XUSEC("ORES",X)) 1 + Q 0 diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDBA3.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDBA3.m index 5a3d3198..04f42527 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDBA3.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDBA3.m @@ -1,211 +1,210 @@ -ORWDBA3 ; SLC/GSS Billing Awareness (CIDC) [8/20/03 9:19am] - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**190,195,243**;Dec 17, 1997;Build 242 - ; -ORFMDAT(ORDFN) ; Return date in FM format regarding order for CSV/CTD/HIPAA - ; Pass in Order IEN - Q ($P($G(^OR(100,ORDFN,8,1,0)),"^",16)\1) - ; -DISPLAY ; Display of BA data from original copied order (ORIT = ORIEN) - ; Displayed in window with all order info and user can accept/edit - ; Note: TxF = Treatment Factor - ; BA data (Dx,TxF's) not editable but in signature window, not in above - ; ORIT defined in ORWDXM1, DISPLAY called from ORWDXM2 - ; - ; Input: - ; ORIT, ILST, and LST() from ORWDXM* routines - ; Output: - ; ILST and LST() appropriately incremented/populated for order display - ; Variables: - ; CUN = TxF's in C, U, or N format - ; I = counter - ; ILST = line counter, initially from ORWDXM* routines - ; LST() = array of lines to output, initially from ORWDXM* routines - ; NTF = # of Treatment Factors - ; ORITARY = ORIT array of 1 needed to access GETTFCI^ORWDBA4 - ; SPCS = # of characters to space to left of ':' - ; TF1 = first TxF output? (0/1) - ; TFGBL = TxF's in Global stored order - ; TFGUI = TxF's in GUI returned order - ; TFV = TxF verbiage - ; - N CUN,I,NTF,ORITARY,SPCS,TF1,TFGBL,TFGUI,TFV,Y - S NTF=8,SPCS=28,ORITARY(1)=+ORIT - ; Get Y(+ORIT) string in ORIEN^CUUUCCN^Dx1^Desc1^Dx2^Desc2^... format - D GETTFCI^ORWDBA4(.Y,.ORITARY) - S CUN=$P($G(Y(1)),U,2) ;CUN = Treatment Factors in CUN syntax - ; First output Diagnosis information - if any - F I=3:2:9 I $P($G(Y(1)),U,I)'="" D - . S ILST=ILST+1,LST(ILST)=$S(I=3:"Diagnoses",1:"") - . S LST(ILST)=LST(ILST)_":"_$P(Y(1),U,I)_" - "_$P(Y(1),U,I+1) - . D FRMTLST - ; Get GUI and GBL Treatment Factor sequence strings - D TFSTGS^ORWDBA1 - ; Assumes SC will always be first in sequence! - not likely to change - S ILST=ILST+1 - S LST(ILST)="Service Connected:"_$S($E(CUN)="C":"YES",1:"NO") - D FRMTLST - S ILST=ILST+1,LST(ILST)="Treatment Factors:" - ; If no TxF's (no 'C'hecked) {SC output above} then output '' - I '$F($E(CUN,2,NTF),"C") S LST(ILST)=LST(ILST)_"" D FRMTLST Q - S TF1=0 ;No TxF yet output - ; Verbiage for TxF's - S TFV("MST")="MILITARY SEXUAL TRAUMA",TFV("AO")="AGENT ORANGE" - S TFV("IR")="IONIZING RADIATION",TFV("EC")="ENVIRONMENTAL CONTAMINANTS" - S TFV("HNC")="HEAD AND NECK CANCER",TFV("CV")="COMBAT VETERAN" - S TFV("SHD")="SHIPBOARD HAZARD" - ; Output Checked TxF's - F I=2:1:NTF I $E(CUN,I)="C" D - . I 'TF1 S LST(ILST)=LST(ILST)_TFV($P(TFGUI,U,I)),TF1=1 D FRMTLST Q - . S ILST=ILST+1,LST(ILST)=":"_TFV($P(TFGUI,U,I)) D FRMTLST - Q - ; -FRMTLST ; Format the variable LST(ILST) for DISPLAY tag - S LST(ILST)=$J($P(LST(ILST),":"),SPCS)_": "_$P(LST(ILST),":",2) - Q - ; -HINTS(Y) ; Return HINTS for ORBA Treatment Factors - used by Delphi - ; The hints returned in the Y array will be used in the CPRS GUI and - ; displayed on fly-over of the cursor over the TxF text in the window - ; - ; Input - ; - ; Output - ; Y array of the hints for TxF's> Y(#)=TxFA ^ TxF line # ^ hint text - ; where TxFA is Treatment Factor acronym, e.g., CV=Combat Veteran - ; Variables - ; CT = line number count, used in Y(#) where #=CT - ; I = incrementor index # - ; ORTFIEN = the IEN for the TxF in the Help Frame (^DIC(9.2)) file - ; TF = TxF acronym - ; TFLN = TxF text line number, e.g., ^DIC(9.2,ORTFIEN,1,TFLN,0) - ; TFS = string of TxF acronyms - ; TFV = TxF description/text - ; - N CT,I,ORTFIEN,TF,TFLN,TFS,TFV - ; - S TFS="SC^MST^AO^IR^EC^HNC^CV^SHD",CT=0 - ; Get next TxF from TFS - F I=1:1 S TF=$P(TFS,U,I) Q:TF="" D - . S ORTFIEN=$O(^DIC(9.2,"B","ORBA-"_TF,"")),TFV="",TFLN=0 - . ; Get next line of hint text - . F S TFLN=$O(^DIC(9.2,ORTFIEN,1,TFLN)) Q:'TFLN D - .. S CT=CT+1,Y(CT)=TF_U_TFLN_U_^DIC(9.2,ORTFIEN,1,TFLN,0) - Q - ; -DG1(ORDFN,COUNTER,CTVALUE) ; Create DG1 segment(s) & make call for ZCL seg. - ; - ; Input - ; ORDFN Internal Order ID# - ; COUNTER Variable used as counter from calling routine - ; CTVALUE Value of COUNTER when DG1 called - ; Output - ; DG1 & ZCL HL7 segments - ; - I $$BASTAT^ORWDBA1=0 Q ;BA not used - N DG13,DXIEN,DXR,DXV,FROMFILE,ICD9,OCT,OREC,ORFMDAT - ; zero order count variable - S OCT=0 - ; Get the date of order (for CSV/CTD usage) - S ORFMDAT=$$ORFMDAT(ORDFN) - ; Get the diagnoses for an order - F S OCT=$O(^OR(100,ORDFN,5.1,OCT)) Q:OCT'?1N.N D - . S OREC=^OR(100,ORDFN,5.1,OCT,0) - . S DXIEN=$P(OREC,U) ; DXIEN=pointer to diagnosis (ICD9) file #80 - . ; the DXIEN pointer should point to a valid diagnosis (after all is - . ; was previously entered .. but just in case ...) - . S (DXV,ICD9)="" - . I DXIEN'="" D - .. S DXR=$$ICDDX^ICDCODE(DXIEN,ORFMDAT) Q:+DXR=-1 - .. ; Get diagnosis verbiage and ICD code - .. S DXV=$P(DXR,U,4),ICD9=$P(DXR,U,2) - . S FROMFILE=80 - . S DG13=DXIEN_U_DXV_U_FROMFILE_U_ICD9_U_DXV_U_"ICD9" - . S CTVALUE=CTVALUE+1 - . S ORMSG(CTVALUE)="DG1"_"|"_OCT_"||"_DG13_"|||||||||||||" - . D ZCL - S @COUNTER=CTVALUE - Q - ; -ZCL ;create all the ZCL segments (currently 8 TxF's) for order number OCT - ; - N I,J,TABLE,TF,TFGBL,TFGUI,TFTBL,TFIN,TFS,VALUE - D TFSTGS^ORWDBA1 ;set string sequence of treatment factors - ; TFS is TxF data in ^OR(100,ORIEN,5.2) order - S TFS=$G(^OR(100,ORDFN,5.2)),TABLE="" - ; conversion order from ^OR stored data and Table SD008 for HL7 msg - ; convert so that the ZCL segments will be in Table SD008 order (1-8) - F I=1:1:8 S TF=$P(TFTBL,U,I) F J=1:1:8 I $P(TFGBL,U,J)=TF S TABLE=TABLE_J Q - F TFIN=1:1:8 D - . ; ORMSG counter incremented - . S CTVALUE=CTVALUE+1 - . ; TF VALUE=0 for no or 1 for yes (only if not req. is it null) - . S VALUE=$P(TFS,U,$E(TABLE,TFIN)) - . I VALUE="?" S VALUE=0 ;temp fix if sending '?' to ancillary??? - . ; for Table SD008: OCT=Set ID, SCIN=O/P Classif. Type, VALUE=Value - . S ORMSG(CTVALUE)="ZCL|"_OCT_"|"_TFIN_"|"_VALUE - Q - ; -BDOSTR ;Store backdoor order DG1 and ZCL messages from HL7 - ;Processes one order per entry into BDOSTR, e.g., ROUT(1) - ;Depends upon ORM* routines to set-up a number of variables including - ; ORMSG array and ORIFN. - ;ORM* routines calling BDOSTR: ORMGMRC, ORMLR, ORMPS, & ORMRA - ; - ; Input: HL7 messages and related data - ; Output: ROUT array in Delphi GUI format, i.e. - ; OrderIEN;11CNNNCNN^exDx1^exDx2^exDx3^exDx4 - ; - ; Variables Used - ; DG1 = sequential numbered array with a value of DXIEN - ; I,J = counters - ; GUITF = GUI order treatment factors (TxF) - ; NDX = number of diagnoses being passed - ; NTF = number of TxF - ; OBX = @ORMSG Dx array element # (max of 4 diagnoses stored) - ; REC = set to sequential HL7 messages, contains HL7 message data - ; ROUT = record sent for storage processing to RCVORCI - ; TF = individual TxF values - ; TFGBL = TxF acronyms in ^ delimited string in ^OR sequence - ; TFGUI = TxF acronyms in ^ delimited string in from GUI sequence - ; TFTBL = TxF acronyms in ^ delimited string in Table SD008 sequence - ; VAL = individual TxF values - ; ZCL = TxF in Table SD008 format and sequence - ; - ; See if CIDC master switch set, if not then no DG1/ZCL seg, to store - I $$BASTAT^ORWDBA1=0 Q ;CIDC (nee BA) not used - ; - N CPNODE,CT,DG1,I,J,GUITF,NDX,NTF,OBX,REC,ROUT,ORSDCARY,SDCARYA - N TF,TFGBL,TFGUI,TFTBL,VAL,X,ZCL - ; - K ORSDCARY,SDCARYA - D TFSTGS^ORWDBA1 ;set string sequence of treatment factors - S (CT,NDX,OBX)=0,NTF=8,(CPNODE,GUITF,TF,Y,ZCL)="",X="T" - ; Call API to acquire Treatment Factors in force - D NOW^%DTC,CL^SDCO21(DFN,%,"",.ORSDCARY) ;DBIA 406 - ; Retrved array order: AO,IR,SC,EC,MST,HNC,CV,SHD, e.g., ORSDCARY(3) for SC - ; Convert to character array, e.g., SDCARYA("SC")="" - F I=1:1:NTF S:$D(ORSDCARY(I)) SDCARYA($P("AO^IR^SC^EC^MST^HNC^CV^SHD",U,I))="" - ; Process only four DG1 segments and first set of ZCL segments - F S OBX=$O(@ORMSG@(OBX)) Q:OBX'>0 S J=$E(@ORMSG@(OBX),1,3) I J="DG1"!(J="ZCL"&($P(@ORMSG@(OBX),"|",2)=1)) D - . S REC=@ORMSG@(OBX) - . ; Setting DG1(#)=DXIEN where # is Dx sequence # (1=primary) - . I J="DG1"&(NDX<4) S DG1($P(REC,"|",2))=$P(REC,U,4),NDX=NDX+1 Q - . ; Create ZCL string of TxFs, e.g., 1101011 - . I J="ZCL" D - .. S:$P(REC,"|",4)="" $P(REC,"|",4)=" " - .. S $E(ZCL,$P(REC,"|",3))=$P(REC,"|",4) - ; convert order and format from Table SD008 to GUI - F I=1:1:NTF S TF=$P(TFGUI,U,I) F J=1:1:NTF I $P(TFTBL,U,J)=TF D - . ; If patient does not have that Tx Factor (TF) then ghost in GUI ("N") - . I '$D(SDCARYA(TF)) S GUITF=GUITF_"N" Q - . ; If patient has TF then format for GUI (C=ck'd, U=unck'd, ?=not ans) - . S VAL=$E(ZCL,J),GUITF=GUITF_$S(VAL=1:"C",VAL=0:"U",1:"?") - ; Create output string in a format that can be stored by RCVORCI^ORWDBA1 - S ROUT(1)=ORIFN_";11"_GUITF_U_$G(DG1(1))_U_$G(DG1(2))_U_$G(DG1(3))_U_$G(DG1(4)) - ; Store diagnoses and treatment factors - D RCVORCI^ORWDBA1(Y,.ROUT) - Q - ; -ERRMSG(VISIT) ; Error handling and message - ; to be determined - Q +ORWDBA3 ; SLC/GSS Billing Awareness (CIDC) [8/20/03 9:19am] + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**190,195**;Dec 17, 1997 + ; +ORFMDAT(ORDFN) ; Return date in FM format regarding order for CSV/CTD/HIPAA + ; Pass in Order IEN + Q ($P($G(^OR(100,ORDFN,8,1,0)),"^",16)\1) + ; +DISPLAY ; Display of BA data from original copied order (ORIT = ORIEN) + ; Displayed in window with all order info and user can accept/edit + ; Note: TxF = Treatment Factor + ; BA data (Dx,TxF's) not editable but in signature window, not in above + ; ORIT defined in ORWDXM1, DISPLAY called from ORWDXM2 + ; + ; Input: + ; ORIT, ILST, and LST() from ORWDXM* routines + ; Output: + ; ILST and LST() appropriately incremented/populated for order display + ; Variables: + ; CUN = TxF's in C, U, or N format + ; I = counter + ; ILST = line counter, initially from ORWDXM* routines + ; LST() = array of lines to output, initially from ORWDXM* routines + ; NTF = # of Treatment Factors + ; ORITARY = ORIT array of 1 needed to access GETTFCI^ORWDBA4 + ; SPCS = # of characters to space to left of ':' + ; TF1 = first TxF output? (0/1) + ; TFGBL = TxF's in Global stored order + ; TFGUI = TxF's in GUI returned order + ; TFV = TxF verbiage + ; + N CUN,I,NTF,ORITARY,SPCS,TF1,TFGBL,TFGUI,TFV,Y + S NTF=7,SPCS=28,ORITARY(1)=+ORIT + ; Get Y(+ORIT) string in ORIEN^CUUUCCN^Dx1^Desc1^Dx2^Desc2^... format + D GETTFCI^ORWDBA4(.Y,.ORITARY) + S CUN=$P($G(Y(1)),U,2) ;CUN = Treatment Factors in CUN syntax + ; First output Diagnosis information - if any + F I=3:2:9 I $P($G(Y(1)),U,I)'="" D + . S ILST=ILST+1,LST(ILST)=$S(I=3:"Diagnoses",1:"") + . S LST(ILST)=LST(ILST)_":"_$P(Y(1),U,I)_" - "_$P(Y(1),U,I+1) + . D FRMTLST + ; Get GUI and GBL Treatment Factor sequence strings + D TFSTGS^ORWDBA1 + ; Assumes SC will always be first in sequence! - not likely to change + S ILST=ILST+1 + S LST(ILST)="Service Connected:"_$S($E(CUN)="C":"YES",1:"NO") + D FRMTLST + S ILST=ILST+1,LST(ILST)="Treatment Factors:" + ; If no TxF's (no 'C'hecked) {SC output above} then output '' + I '$F($E(CUN,2,NTF),"C") S LST(ILST)=LST(ILST)_"" D FRMTLST Q + S TF1=0 ;No TxF yet output + ; Verbiage for TxF's + S TFV("MST")="MILITARY SEXUAL TRAUMA",TFV("AO")="AGENT ORANGE" + S TFV("IR")="IONIZING RADIATION",TFV("EC")="ENVIRONMENTAL CONTAMINANTS" + S TFV("HNC")="HEAD AND NECK CANCER",TFV("CV")="COMBAT VETERAN" + ; Output Checked TxF's + F I=2:1:NTF I $E(CUN,I)="C" D + . I 'TF1 S LST(ILST)=LST(ILST)_TFV($P(TFGUI,U,I)),TF1=1 D FRMTLST Q + . S ILST=ILST+1,LST(ILST)=":"_TFV($P(TFGUI,U,I)) D FRMTLST + Q + ; +FRMTLST ; Format the variable LST(ILST) for DISPLAY tag + S LST(ILST)=$J($P(LST(ILST),":"),SPCS)_": "_$P(LST(ILST),":",2) + Q + ; +HINTS(Y) ; Return HINTS for ORBA Treatment Factors - used by Delphi + ; The hints returned in the Y array will be used in the CPRS GUI and + ; displayed on fly-over of the cursor over the TxF text in the window + ; + ; Input + ; + ; Output + ; Y array of the hints for TxF's> Y(#)=TxFA ^ TxF line # ^ hint text + ; where TxFA is Treatment Factor acronym, e.g., CV=Combat Veteran + ; Variables + ; CT = line number count, used in Y(#) where #=CT + ; I = incrementor index # + ; ORTFIEN = the IEN for the TxF in the Help Frame (^DIC(9.2)) file + ; TF = TxF acronym + ; TFLN = TxF text line number, e.g., ^DIC(9.2,ORTFIEN,1,TFLN,0) + ; TFS = string of TxF acronyms + ; TFV = TxF description/text + ; + N CT,I,ORTFIEN,TF,TFLN,TFS,TFV + ; + S TFS="SC^MST^AO^IR^EC^HNC^CV",CT=0 + ; Get next TxF from TFS + F I=1:1 S TF=$P(TFS,U,I) Q:TF="" D + . S ORTFIEN=$O(^DIC(9.2,"B","ORBA-"_TF,"")),TFV="",TFLN=0 + . ; Get next line of hint text + . F S TFLN=$O(^DIC(9.2,ORTFIEN,1,TFLN)) Q:'TFLN D + .. S CT=CT+1,Y(CT)=TF_U_TFLN_U_^DIC(9.2,ORTFIEN,1,TFLN,0) + Q + ; +DG1(ORDFN,COUNTER,CTVALUE) ; Create DG1 segment(s) & make call for ZCL seg. + ; + ; Input + ; ORDFN Internal Order ID# + ; COUNTER Variable used as counter from calling routine + ; CTVALUE Value of COUNTER when DG1 called + ; Output + ; DG1 & ZCL HL7 segments + ; + I $$BASTAT^ORWDBA1=0 Q ;BA not used + N DG13,DXIEN,DXR,DXV,FROMFILE,ICD9,OCT,OREC,ORFMDAT + ; zero order count variable + S OCT=0 + ; Get the date of order (for CSV/CTD usage) + S ORFMDAT=$$ORFMDAT(ORDFN) + ; Get the diagnoses for an order + F S OCT=$O(^OR(100,ORDFN,5.1,OCT)) Q:OCT'?1N.N D + . S OREC=^OR(100,ORDFN,5.1,OCT,0) + . S DXIEN=$P(OREC,U) ; DXIEN=pointer to diagnosis (ICD9) file #80 + . ; the DXIEN pointer should point to a valid diagnosis (after all is + . ; was previously entered .. but just in case ...) + . S (DXV,ICD9)="" + . I DXIEN'="" D + .. S DXR=$$ICDDX^ICDCODE(DXIEN,ORFMDAT) Q:+DXR=-1 + .. ; Get diagnosis verbiage and ICD code + .. S DXV=$P(DXR,U,4),ICD9=$P(DXR,U,2) + . S FROMFILE=80 + . S DG13=DXIEN_U_DXV_U_FROMFILE_U_ICD9_U_DXV_U_"ICD9" + . S CTVALUE=CTVALUE+1 + . S ORMSG(CTVALUE)="DG1"_"|"_OCT_"||"_DG13_"|||||||||||||" + . D ZCL + S @COUNTER=CTVALUE + Q + ; +ZCL ;create all the ZCL segments (currently 7 TxF's) for order number OCT + ; + N I,J,TABLE,TF,TFGBL,TFGUI,TFTBL,TFIN,TFS,VALUE + D TFSTGS^ORWDBA1 ;set string sequence of treatment factors + ; TFS is TxF data in ^OR(100,ORIEN,5.2) order + S TFS=$G(^OR(100,ORDFN,5.2)),TABLE="" + ; conversion order from ^OR stored data and Table SD008 for HL7 msg + ; convert so that the ZCL segments will be in Table SD008 order (1-7) + F I=1:1:7 S TF=$P(TFTBL,U,I) F J=1:1:7 I $P(TFGBL,U,J)=TF S TABLE=TABLE_J Q + F TFIN=1:1:7 D + . ; ORMSG counter incremented + . S CTVALUE=CTVALUE+1 + . ; TF VALUE=0 for no or 1 for yes (only if not req. is it null) + . S VALUE=$P(TFS,U,$E(TABLE,TFIN)) + . I VALUE="?" S VALUE=0 ;temp fix if sending '?' to ancillary??? + . ; for Table SD008: OCT=Set ID, SCIN=O/P Classif. Type, VALUE=Value + . S ORMSG(CTVALUE)="ZCL|"_OCT_"|"_TFIN_"|"_VALUE + Q + ; +BDOSTR ;Store backdoor order DG1 and ZCL messages from HL7 + ;Processes one order per entry into BDOSTR, e.g., ROUT(1) + ;Depends upon ORM* routines to set-up a number of variables including + ; ORMSG array and ORIFN. + ;ORM* routines calling BDOSTR: ORMGMRC, ORMLR, ORMPS, & ORMRA + ; + ; Input: HL7 messages and related data + ; Output: ROUT array in Delphi GUI format, i.e. + ; OrderIEN;11CNNNCNN^exDx1^exDx2^exDx3^exDx4 + ; + ; Variables Used + ; DG1 = sequential numbered array with a value of DXIEN + ; I,J = counters + ; GUITF = GUI order treatment factors (TxF) + ; NDX = number of diagnoses being passed + ; NTF = number of TxF + ; OBX = @ORMSG Dx array element # (max of 4 diagnoses stored) + ; REC = set to sequential HL7 messages, contains HL7 message data + ; ROUT = record sent for storage processing to RCVORCI + ; TF = individual TxF values + ; TFGBL = TxF acronyms in ^ delimited string in ^OR sequence + ; TFGUI = TxF acronyms in ^ delimited string in from GUI sequence + ; TFTBL = TxF acronyms in ^ delimited string in Table SD008 sequence + ; VAL = individual TxF values + ; ZCL = TxF in Table SD008 format and sequence + ; + ; See if CIDC master switch set, if not then no DG1/ZCL seg, to store + I $$BASTAT^ORWDBA1=0 Q ;CIDC (nee BA) not used + ; + N CPNODE,CT,DG1,I,J,GUITF,NDX,NTF,OBX,REC,ROUT,ORSDCARY,SDCARYA + N TF,TFGBL,TFGUI,TFTBL,VAL,X,ZCL + ; + K ORSDCARY,SDCARYA + D TFSTGS^ORWDBA1 ;set string sequence of treatment factors + S (CT,NDX,OBX)=0,NTF=7,(CPNODE,GUITF,TF,Y,ZCL)="",X="T" + ; Call API to acquire Treatment Factors in force + D NOW^%DTC,CL^SDCO21(DFN,%,"",.ORSDCARY) ;DBIA 406 + ; Retrved array order: AO,IR,SC,EC,MST,HNC,CV, e.g., ORSDCARY(3) for SC + ; Convert to character array, e.g., SDCARYA("SC")="" + F I=1:1:NTF S:$D(ORSDCARY(I)) SDCARYA($P("AO^IR^SC^EC^MST^HNC^CV",U,I))="" + ; Process only four DG1 segments and first set of ZCL segments + F S OBX=$O(@ORMSG@(OBX)) Q:OBX'>0 S J=$E(@ORMSG@(OBX),1,3) I J="DG1"!(J="ZCL"&($P(@ORMSG@(OBX),"|",2)=1)) D + . S REC=@ORMSG@(OBX) + . ; Setting DG1(#)=DXIEN where # is Dx sequence # (1=primary) + . I J="DG1"&(NDX<4) S DG1($P(REC,"|",2))=$P(REC,U,4),NDX=NDX+1 Q + . ; Create ZCL string of TxFs, e.g., 1101011 + . I J="ZCL" D + .. S:$P(REC,"|",4)="" $P(REC,"|",4)=" " + .. S $E(ZCL,$P(REC,"|",3))=$P(REC,"|",4) + ; convert order and format from Table SD008 to GUI + F I=1:1:NTF S TF=$P(TFGUI,U,I) F J=1:1:NTF I $P(TFTBL,U,J)=TF D + . ; If patient does not have that Tx Factor (TF) then ghost in GUI ("N") + . I '$D(SDCARYA(TF)) S GUITF=GUITF_"N" Q + . ; If patient has TF then format for GUI (C=ck'd, U=unck'd, ?=not ans) + . S VAL=$E(ZCL,J),GUITF=GUITF_$S(VAL=1:"C",VAL=0:"U",1:"?") + ; Create output string in a format that can be stored by RCVORCI^ORWDBA1 + S ROUT(1)=ORIFN_";11"_GUITF_U_$G(DG1(1))_U_$G(DG1(2))_U_$G(DG1(3))_U_$G(DG1(4)) + ; Store diagnoses and treatment factors + D RCVORCI^ORWDBA1(Y,.ROUT) + Q + ; +ERRMSG(VISIT) ; Error handling and message + ; to be determined + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDBA4.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDBA4.m index 0e794ad7..b065aa82 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDBA4.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDBA4.m @@ -1,120 +1,118 @@ -ORWDBA4 ; SLC/GU Billing Awareness - Phase II [11/26/04 15:44] - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**195,243**;Dec 17, 1997;Build 242 - ; - ;Miscellaneous CIDC functions utility. - ; - ;External References used by this routine - ; $$GETS^DIQ DBIA 2056 - ; GETS^DIQ DBIA 2056 - ; $$ICDDX^ICDCODE DBIA 3990 - ; $$TFGBLGUI^ORWDBA1 DBIA none listed - ; $$SETDXD^ORWDBA2 DBIA none listed - ; $$NOW^XLFDT DBIA 10103 - ; $$GET^XPAR DBIA 2263 - ; -GETTFCI(Y,ORIEN) ;Get Treatment Factors Clinical Indicators - ;Input Variable: - ; ORIEN Order Internal Entry Number (array variable) - ;Ouput Variable: - ; Y Y(AI)=Order_IEN^Treatment_Factors^ICD9^ICD9_Description - ; There can be up to 4 ICD9 codes and thier descriptions - ; ICD901^DESC01^ICD902^DESC02^ICD903^DESC03^ICD904^DESC04 - ;Local Variables: - ; AI Array Index - ; CI Clinical Index - ; TF Treatment Factors - ; TFCI Treatment Factors Clinical Indicators - N AI,CI,CNT,DXS,TF,TFCI - S U="^",(CNT,TF)="" - F S CNT=$O(ORIEN(CNT)) Q:CNT="" D - . S TF=$$GTF(ORIEN(CNT)) - . S DXS=$$GDCD(ORIEN(CNT)) - . I TF="NNNNNNNN"&(DXS="") Q - . S TFCI(CNT)=ORIEN(CNT)_U_TF_$S(DXS="":"",1:U_DXS) - M Y=TFCI - Q - ; -GTF(IEN) ;Get Treatment Factors - ;Gets the Treatment Factors for the current order converted to the - ;format used by the CPRS GUI display. - ; - ;Input Variable: - ; IEN Internal Entry Number - ;Local Variables: - ; ORTF Order Record Treatment Factors - ; OREM Order Record Error Message - ; OTF Order Treatment Factors - ; (Converted to GUI values and returned) - N ORTF,OREM,OTF - S OTF="" - D GETS^DIQ(100,IEN,"90;91;92;93;94;95;96;98","I","ORTF","OREM") - S OTF=$G(ORTF(100,IEN_",",90,"I")) - S OTF=OTF_U_$G(ORTF(100,IEN_",",91,"I")) - S OTF=OTF_U_$G(ORTF(100,IEN_",",92,"I")) - S OTF=OTF_U_$G(ORTF(100,IEN_",",93,"I")) - S OTF=OTF_U_$G(ORTF(100,IEN_",",94,"I")) - S OTF=OTF_U_$G(ORTF(100,IEN_",",95,"I")) - S OTF=OTF_U_$G(ORTF(100,IEN_",",96,"I")) - S OTF=OTF_U_$G(ORTF(100,IEN_",",98,"I")) - S OTF=$$TFGBLGUI^ORWDBA1(OTF) - I OTF'="NNNNNNNN" Q OTF - S OTF="" - K ORTF,OREM - D GETS^DIQ(100,IEN,"51;52;53;54;55;56;57;58","I","ORTF","OREM") - S OTF=$G(ORTF(100,IEN_",",51,"I")) - S OTF=OTF_U_$G(ORTF(100,IEN_",",52,"I")) - S OTF=OTF_U_$G(ORTF(100,IEN_",",53,"I")) - S OTF=OTF_U_$G(ORTF(100,IEN_",",54,"I")) - S OTF=OTF_U_$G(ORTF(100,IEN_",",55,"I")) - S OTF=OTF_U_$G(ORTF(100,IEN_",",56,"I")) - S OTF=OTF_U_$G(ORTF(100,IEN_",",57,"I")) - S OTF=OTF_U_$G(ORTF(100,IEN_",",58,"I")) - S OTF=$$TFGBLGUI^ORWDBA1(OTF) - Q OTF - ; -GDCD(IEN) ;Get Diagnoses Codes / Description - ;Builds and returns a text string delimited by the "^". The text string - ;made from the ICD9 codes associated with the current order and thier - ;descriptions pulled from the ICD DIAGNOSIS file #80. The string can - ;contain up to four diagnoses codes and thier descriptions. The string - ;with all four possiable diagnoses codes is formatted: - ;ICD901^DESC01^ICD902^DESC02^ICD903^DESC03^ICD904^DESC04 - ; - ;Input Variable: - ; IEN - ;Local Variables: - ; DCD Diagnosis Code Description (retrun variable) - ; DXDT Diagnosis Date (either Order date or system date) - ; DXD Diagnosis Description - ; DXIEN Diagnosis Internal Entry Number - ; ICD9 ICD9 code (for GUI display) - ; IENS Internale Entry Number Sequence - ; (Array index variable for data returned from lookup) - ; ORRF Order Record Found (returned data from lookup) - ; OREM Order Record Error Message - N DCD,DXDT,DXD,DXIEN,ICD9,IENS,ORRF,OREM - S DCD="" - D GETS^DIQ(100,IEN,".8*;5.1*","I","ORRF","OREM") - I $D(ORRF) D - . S DXDT="" - . I $D(ORRF(100.008)) S DXDT=$G(ORRF(100.008,"1,"_IEN_",",.01,"I")) - . I DXDT="" S DXDT=$$NOW^XLFDT - . I $D(ORRF(100.051)) D - .. S IENS="" F S IENS=$O(ORRF(100.051,IENS)) Q:IENS="" D - ... I ORRF(100.051,IENS,.01,"I")="" S DCD=DCD_U Q - ... S DXIEN=ORRF(100.051,IENS,.01,"I") - ... S ICD9=$$GET1^DIQ(80,DXIEN,.01,"") - ... S DXD=$$SETDXD^ORWDBA2($P($$ICDDX^ICDCODE(ICD9,DT),U,4)) - ... S DCD=$S(DCD="":ICD9_U_DXD,1:DCD_U_ICD9_U_DXD) - Q DCD - ; -GETBAUSR(Y,ORCIEN) ;GUI RPC CALL - ;Get Billing Awareness By User parameter value - ;Gets and returns the value of the Enabled Billing Awareness By User - ;parameter assigned to a provider. - ;Input Variable: - ; ORCIEN Ordering Clinician's Internal Entry Number - ;Output Variable: - ; Y Parameter value, 1 if enabled, 0 if disabled - S Y=$$GET^XPAR(ORCIEN_";VA(200,","OR BILLING AWARENESS BY USER",1,"Q") - Q +ORWDBA4 ; SLC/GU Billing Awareness - Phase II [11/26/04 15:44] + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**195**;Dec 17, 1997 + ; + ;Miscellaneous CIDC functions utility. + ; + ;External References used by this routine + ; $$GETS^DIQ DBIA 2056 + ; GETS^DIQ DBIA 2056 + ; $$ICDDX^ICDCODE DBIA 3990 + ; $$TFGBLGUI^ORWDBA1 DBIA none listed + ; $$SETDXD^ORWDBA2 DBIA none listed + ; $$NOW^XLFDT DBIA 10103 + ; $$GET^XPAR DBIA 2263 + ; +GETTFCI(Y,ORIEN) ;Get Treatment Factors Clinical Indicators + ;Input Variable: + ; ORIEN Order Internal Entry Number (array variable) + ;Ouput Variable: + ; Y Y(AI)=Order_IEN^Treatment_Factors^ICD9^ICD9_Description + ; There can be up to 4 ICD9 codes and thier descriptions + ; ICD901^DESC01^ICD902^DESC02^ICD903^DESC03^ICD904^DESC04 + ;Local Variables: + ; AI Array Index + ; CI Clinical Index + ; TF Treatment Factors + ; TFCI Treatment Factors Clinical Indicators + N AI,CI,CNT,DXS,TF,TFCI + S U="^",(CNT,TF)="" + F S CNT=$O(ORIEN(CNT)) Q:CNT="" D + . S TF=$$GTF(ORIEN(CNT)) + . S DXS=$$GDCD(ORIEN(CNT)) + . I TF="NNNNNNN"&(DXS="") Q + . S TFCI(CNT)=ORIEN(CNT)_U_TF_$S(DXS="":"",1:U_DXS) + M Y=TFCI + Q + ; +GTF(IEN) ;Get Treatment Factors + ;Gets the Treatment Factors for the current order converted to the + ;format used by the CPRS GUI display. + ; + ;Input Variable: + ; IEN Internal Entry Number + ;Local Variables: + ; ORTF Order Record Treatment Factors + ; OREM Order Record Error Message + ; OTF Order Treatment Factors + ; (Converted to GUI values and returned) + N ORTF,OREM,OTF + S OTF="" + D GETS^DIQ(100,IEN,"90;91;92;93;94;95;96","I","ORTF","OREM") + S OTF=$G(ORTF(100,IEN_",",90,"I")) + S OTF=OTF_U_$G(ORTF(100,IEN_",",91,"I")) + S OTF=OTF_U_$G(ORTF(100,IEN_",",92,"I")) + S OTF=OTF_U_$G(ORTF(100,IEN_",",93,"I")) + S OTF=OTF_U_$G(ORTF(100,IEN_",",94,"I")) + S OTF=OTF_U_$G(ORTF(100,IEN_",",95,"I")) + S OTF=OTF_U_$G(ORTF(100,IEN_",",96,"I")) + S OTF=$$TFGBLGUI^ORWDBA1(OTF) + I OTF'="NNNNNNN" Q OTF + S OTF="" + K ORTF,OREM + D GETS^DIQ(100,IEN,"51;52;53;54;55;56;57","I","ORTF","OREM") + S OTF=$G(ORTF(100,IEN_",",51,"I")) + S OTF=OTF_U_$G(ORTF(100,IEN_",",52,"I")) + S OTF=OTF_U_$G(ORTF(100,IEN_",",53,"I")) + S OTF=OTF_U_$G(ORTF(100,IEN_",",54,"I")) + S OTF=OTF_U_$G(ORTF(100,IEN_",",55,"I")) + S OTF=OTF_U_$G(ORTF(100,IEN_",",56,"I")) + S OTF=OTF_U_$G(ORTF(100,IEN_",",57,"I")) + S OTF=$$TFGBLGUI^ORWDBA1(OTF) + Q OTF + ; +GDCD(IEN) ;Get Diagnoses Codes / Description + ;Builds and returns a text string delimited by the "^". The text string + ;made from the ICD9 codes associated with the current order and thier + ;descriptions pulled from the ICD DIAGNOSIS file #80. The string can + ;contain up to four diagnoses codes and thier descriptions. The string + ;with all four possiable diagnoses codes is formatted: + ;ICD901^DESC01^ICD902^DESC02^ICD903^DESC03^ICD904^DESC04 + ; + ;Input Variable: + ; IEN + ;Local Variables: + ; DCD Diagnosis Code Description (retrun variable) + ; DXDT Diagnosis Date (either Order date or system date) + ; DXD Diagnosis Description + ; DXIEN Diagnosis Internal Entry Number + ; ICD9 ICD9 code (for GUI display) + ; IENS Internale Entry Number Sequence + ; (Array index variable for data returned from lookup) + ; ORRF Order Record Found (returned data from lookup) + ; OREM Order Record Error Message + N DCD,DXDT,DXD,DXIEN,ICD9,IENS,ORRF,OREM + S DCD="" + D GETS^DIQ(100,IEN,".8*;5.1*","I","ORRF","OREM") + I $D(ORRF) D + . S DXDT="" + . I $D(ORRF(100.008)) S DXDT=$G(ORRF(100.008,"1,"_IEN_",",.01,"I")) + . I DXDT="" S DXDT=$$NOW^XLFDT + . I $D(ORRF(100.051)) D + .. S IENS="" F S IENS=$O(ORRF(100.051,IENS)) Q:IENS="" D + ... I ORRF(100.051,IENS,.01,"I")="" S DCD=DCD_U Q + ... S DXIEN=ORRF(100.051,IENS,.01,"I") + ... S ICD9=$$GET1^DIQ(80,DXIEN,.01,"") + ... S DXD=$$SETDXD^ORWDBA2($P($$ICDDX^ICDCODE(ICD9,DT),U,4)) + ... S DCD=$S(DCD="":ICD9_U_DXD,1:DCD_U_ICD9_U_DXD) + Q DCD + ; +GETBAUSR(Y,ORCIEN) ;GUI RPC CALL + ;Get Billing Awareness By User parameter value + ;Gets and returns the value of the Enabled Billing Awareness By User + ;parameter assigned to a provider. + ;Input Variable: + ; ORCIEN Ordering Clinician's Internal Entry Number + ;Output Variable: + ; Y Parameter value, 1 if enabled, 0 if disabled + S Y=$$GET^XPAR(ORCIEN_";VA(200,","OR BILLING AWARENESS BY USER",1,"Q") + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDBA7.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDBA7.m index 2da950e3..cfc6770c 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDBA7.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDBA7.m @@ -1,135 +1,135 @@ -ORWDBA7 ;;SLC/GSS Billing Awareness (CIDC-Clinical Indicators Data Capture) - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**195,215,243**;Dec 17, 1997;Build 242 - ; -BDOEDIT ; Backdoor entered orders edit in CPRS - entry point - ; Data Flow> Ancillary creates a back door order which is incomplete - ; and thus edited in CPRS GUI. The ancillary needs to know - ; what Dx and TF's are edited thus this tag calls three - ; ancillary APIs, passing the Dx and TF data to them. - ; - ; Variable Description - ; ANCILARY Acronym of ancillary/package relative to order - ; DXN Diagnosis sequence number in ^OR file - ; MSG Error message - ; ORDX Array of diagnoses (1-n) with value from ICD file (#80) - ; ORIFN Order internal reference number (defined in ORCSEND) - ; ORITEM Package reference or ^OR(100,ORIFN,4) - ; ORSCEI String of Treatment Factors in table SD008 order/format - ; PTIEN Patient IEN - ; TAGROU Tag^Routine of ancillary routine to store edited data - ; TFO Treatment Factors in ^OR (GBL) order - ; - ; If CIDC master switch set, then no back door orders to store - I $$BASTAT^ORWDBA1=0 Q ;CIDC (nee BA) not used - ; If ORIFN not defined (God only knows why) then log error and quit - I '$D(ORIFN) S MSG="ORIFN not defined" D VAR,EN^ORERR(MSG,"",.VAR) Q - ; - N ANCILARY,DXN,MSG,ORDX,ORITEM,ORSCEI,PTIEN,RT,SUCCESS,TAGROU,TFO,VAR - ; - S DXN=0,(RT,SUCCESS)="",PTIEN=+$P($G(^OR(100,ORIFN,0)),U,2) - ; Package (ancillary) reference data - S ORITEM=$G(^OR(100,ORIFN,4)) - ; Create an array (ORDX) of diagnoses - F S DXN=$O(^OR(100,ORIFN,5.1,DXN)) Q:'DXN D - . S ORDX(DXN)=$G(^OR(100,ORIFN,5.1,DXN,0)) - ; Treatment Factors - converted and reformatted - S ORSCEI=$$TFGBLTBL($G(^OR(100,ORIFN,5.2))) - ; Get the acronym of the package generating this order - S ANCILARY=$P($G(^DIC(9.4,$P($G(^OR(100,ORIFN,0)),U,14),0)),U,2) - ; Send data to the appropriate ancillary API based on package - D OUTPUT - ; If ancillary routine or tag w/in the routine doesn't exist check - I 'RT D - . S MSG="NON-EXISTANT ROUTINE/TAG FOR "_ANCILARY - . D VAR,EN^ORERR(MSG,"",.VAR) - ; If we don't get back a thumbs-up from the ancillary re: the order data - I 'SUCCESS,RT D - . S MSG="ANCILLARY API RETURNED ERROR FOR CPRS EDITED BACK DOOR DATA" - . D VAR,EN^ORERR(MSG,"",.VAR) - Q - ; -OUTPUT ; Call ancillary's API to store data after checking for it's existence - ; - ; Laboratory - I ANCILARY?1"LR".U D Q - . S RT=$$CKROUTAG("UPDOR^LRBEBA4") Q:'RT - . S SUCCESS=$$UPDOR^LRBEBA4(PTIEN,ORITEM,ORIFN,.ORDX,ORSCEI) ;IA 4775 - ; - ; Pharmacy - I ANCILARY?1"PS".U D Q - . S RT=$$CKROUTAG("EN^PSOHLNE3") Q:'RT - . S SUCCESS=$$EN^PSOHLNE3(PTIEN,ORITEM,ORIFN,.ORDX,ORSCEI) ;IA 4666 - ; - ; Radiolgy - I ANCILARY?1"RA".U D Q - . S RT=$$CKROUTAG("CPRSUPD^RABWORD1") Q:'RT - . S SUCCESS=$$CPRSUPD^RABWORD1(PTIEN,ORITEM,ORIFN,.ORDX,ORSCEI) ;IA 4771 - Q - ; -CKROUTAG(TAGROU) ;Check if valid tag and routine - ; Temporary check until all the ancillaries have their API's built - Q $L($T(@TAGROU)) - ; -TFGBLTBL(GBL) ;Convert Tx Factors from Global to TBL (HL7) order & format - ; Note: this does not set Tx Factors in ZCL segment format but rather - ; AO^IR^SC^EC^MST^HNC^CV^SHD ('^' delimited string) format - ; - ; Input: GBL in 1^1^0^0^^^0^ (global) format - ; Output: TBL in 0^0^1^^1^^0^ (TBL) format (also reordered) - ; - N J,NTF,TBL,TF,TFGBL,TFGUI,TFTBL - S TBL="",NTF=8 ;NCI=# of TxF - ; Get Treatment Factor sequence order strings - D TFSTGS^ORWDBA1 - ; Convert from GBL to TBL format and sequence - F J=1:1:NTF S TF=$P(GBL,U,J) D - . ;OK..just in case there is a '?' we'll return a null for a '?' - . S TF($P(TFGBL,U,J))=$S(TF=1:1,TF=0:0,TF="?":"",1:"") - F J=1:1:NTF S TBL=TBL_U_TF($P(TFTBL,U,J)) - ; Remove the first '^' and pass TBL formatted TF's - Q $E(TBL,2,99) - ; -VAR ;Create VAR array for tracking error in ^ORYX("ORERR",err#) - S VAR("DFN")=PTIEN - S VAR("ORITEM")=ORITEM - S VAR("ORIFN")=ORIFN - M VAR("ORDX")=ORDX - S VAR("ORSCEI")=ORSCEI - Q - ; -ISWITCH(Y,DFN) ;Return 0 if don't ask (no ins) or 1 to ask CIDC quest (yes ins) - S Y=$$CIDC^IBBAPI(DFN) - Q - ; -GETIEN9(Y,ICD9) ;Return IEN for an ICD9 code (RPC: ORWDBA7 GETIEN9) - S Y=$P($$CODEN^ICDCODE(ICD9,80),"~") - Q - ; -CONDTLD ;Consult Detailed Display Compile for CIDC/BA (called by GMRCSLM2) - ; Input: ORIFN and GMRCCT defined in GMRCSLM2 - ; Output: CIDCARY = array of CIDC display lines for GMRCSLM2 display - N BGNRCCT,DXIEN,DXOF,DXV,EYE,ICD9,ICDR,LINE,OCT,ORFMDAT,TF - S BGNRCCT=GMRCCT,OCT=0 - ; Get the date of the order for CSV/CTD usage - S ORFMDAT=$$ORFMDAT^ORWDBA3(ORIFN) - ; $O through diagnoses for an order - F S OCT=$O(^OR(100,ORIFN,5.1,OCT)) Q:OCT'?1N.N D - . S DXOF=" " - . ; DXIEN=Dx IEN - . S DXIEN=+^OR(100,ORIFN,5.1,OCT,0) - . ; Get Dx record for date ORFMDAT - . S ICDR=$$ICDDX^ICDCODE(DXIEN,ORFMDAT) - . ; Get Dx verbiage and ICD code - . S DXV=$P(ICDR,U,4),ICD9=$P(ICDR,U,2) - . I OCT=1 D - .. S CIDCARY(GMRCCT,0)=" ",GMRCCT=GMRCCT+1 ;blank line - .. S CIDCARY(GMRCCT,0)="Clinical Indicators",GMRCCT=GMRCCT+1 - .. S DXOF="Diagnosis of: " - . S LINE=DXOF_ICD9_" - "_DXV - . S CIDCARY(GMRCCT,0)=LINE,GMRCCT=GMRCCT+1 - I OCT'="" D ;if there are diagnoses then show Treatment Factors - . S LINE="For conditions related to: " - . F EYE=1:1:8 S TF=$P(^OR(100,ORIFN,5.2),U,EYE) I TF D - .. S CIDCARY(GMRCCT,0)=LINE_$$SC^ORQ21(EYE) - .. S X=$$REPEAT^XLFSTR(" ",30),GMRCCT=GMRCCT+1 - Q +ORWDBA7 ;;SLC/GSS Billing Awareness (CIDC-Clinical Indicators Data Capture) + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**195,215**;Dec 17, 1997 + ; +BDOEDIT ; Backdoor entered orders edit in CPRS - entry point + ; Data Flow> Ancillary creates a back door order which is incomplete + ; and thus edited in CPRS GUI. The ancillary needs to know + ; what Dx and TF's are edited thus this tag calls three + ; ancillary APIs, passing the Dx and TF data to them. + ; + ; Variable Description + ; ANCILARY Acronym of ancillary/package relative to order + ; DXN Diagnosis sequence number in ^OR file + ; MSG Error message + ; ORDX Array of diagnoses (1-n) with value from ICD file (#80) + ; ORIFN Order internal reference number (defined in ORCSEND) + ; ORITEM Package reference or ^OR(100,ORIFN,4) + ; ORSCEI String of Treatment Factors in table SD008 order/format + ; PTIEN Patient IEN + ; TAGROU Tag^Routine of ancillary routine to store edited data + ; TFO Treatment Factors in ^OR (GBL) order + ; + ; If CIDC master switch set, then no back door orders to store + I $$BASTAT^ORWDBA1=0 Q ;CIDC (nee BA) not used + ; If ORIFN not defined (God only knows why) then log error and quit + I '$D(ORIFN) S MSG="ORIFN not defined" D VAR,EN^ORERR(MSG,"",.VAR) Q + ; + N ANCILARY,DXN,MSG,ORDX,ORITEM,ORSCEI,PTIEN,RT,SUCCESS,TAGROU,TFO,VAR + ; + S DXN=0,(RT,SUCCESS)="",PTIEN=+$P($G(^OR(100,ORIFN,0)),U,2) + ; Package (ancillary) reference data + S ORITEM=$G(^OR(100,ORIFN,4)) + ; Create an array (ORDX) of diagnoses + F S DXN=$O(^OR(100,ORIFN,5.1,DXN)) Q:'DXN D + . S ORDX(DXN)=$G(^OR(100,ORIFN,5.1,DXN,0)) + ; Treatment Factors - converted and reformatted + S ORSCEI=$$TFGBLTBL($G(^OR(100,ORIFN,5.2))) + ; Get the acronym of the package generating this order + S ANCILARY=$P($G(^DIC(9.4,$P($G(^OR(100,ORIFN,0)),U,14),0)),U,2) ;D??? + ; Send data to the appropriate ancillary API based on package + D OUTPUT + ; If ancillary routine or tag w/in the routine doesn't exist check + I 'RT D + . S MSG="NON-EXISTANT ROUTINE/TAG FOR "_ANCILARY + . D VAR,EN^ORERR(MSG,"",.VAR) + ; If we don't get back a thumbs-up from the ancillary re: the order data + I 'SUCCESS,RT D + . S MSG="ANCILLARY API RETURNED ERROR FOR CPRS EDITED BACK DOOR DATA" + . D VAR,EN^ORERR(MSG,"",.VAR) + Q + ; +OUTPUT ; Call ancillary's API to store data after checking for it's existence + ; + ; Laboratory + I ANCILARY?1"LR".U D Q + . S RT=$$CKROUTAG("UPDOR^LRBEBA4") Q:'RT + . S SUCCESS=$$UPDOR^LRBEBA4(PTIEN,ORITEM,ORIFN,.ORDX,ORSCEI) ;IA 4775 + ; + ; Pharmacy + I ANCILARY?1"PS".U D Q + . S RT=$$CKROUTAG("EN^PSOHLNE3") Q:'RT + . S SUCCESS=$$EN^PSOHLNE3(PTIEN,ORITEM,ORIFN,.ORDX,ORSCEI) ;IA 4666 + ; + ; Radiolgy + I ANCILARY?1"RA".U D Q + . S RT=$$CKROUTAG("CPRSUPD^RABWORD1") Q:'RT + . S SUCCESS=$$CPRSUPD^RABWORD1(PTIEN,ORITEM,ORIFN,.ORDX,ORSCEI) ;IA 4771 + Q + ; +CKROUTAG(TAGROU) ;Check if valid tag and routine + ; Temporary check until all the ancillaries have their API's built + Q $L($T(@TAGROU)) + ; +TFGBLTBL(GBL) ;Convert Tx Factors from Global to TBL (HL7) order & format + ; Note: this does not set Tx Factors in ZCL segment format but rather + ; AO^IR^SC^EC^MST^HNC^CV ('^' delimited string) format + ; + ; Input: GBL in 1^1^0^0^^^0 (global) format + ; Output: TBL in 0^0^1^^1^^0 (TBL) format (also reordered) + ; + N J,NTF,TBL,TF,TFGBL,TFGUI,TFTBL + S TBL="",NTF=7 ;NCI=# of TxF + ; Get Treatment Factor sequence order strings + D TFSTGS^ORWDBA1 + ; Convert from GBL to TBL format and sequence + F J=1:1:NTF S TF=$P(GBL,U,J) D + . ;OK..just in case there is a '?' we'll return a null for a '?' + . S TF($P(TFGBL,U,J))=$S(TF=1:1,TF=0:0,TF="?":"",1:"") + F J=1:1:NTF S TBL=TBL_U_TF($P(TFTBL,U,J)) + ; Remove the first '^' and pass TBL formatted TF's + Q $E(TBL,2,99) + ; +VAR ;Create VAR array for tracking error in ^ORYX("ORERR",err#) + S VAR("DFN")=PTIEN + S VAR("ORITEM")=ORITEM + S VAR("ORIFN")=ORIFN + M VAR("ORDX")=ORDX + S VAR("ORSCEI")=ORSCEI + Q + ; +ISWITCH(Y,DFN) ;Return 0 if don't ask (no ins) or 1 to ask CIDC quest (yes ins) + S Y=$$CIDC^IBBAPI(DFN) + Q + ; +GETIEN9(Y,ICD9) ;Return IEN for an ICD9 code (RPC: ORWDBA7 GETIEN9) + S Y=$P($$CODEN^ICDCODE(ICD9,80),"~") + Q + ; +CONDTLD ;Consult Detailed Display Compile for CIDC/BA (called by GMRCSLM2) + ; Input: ORIFN and GMRCCT defined in GMRCSLM2 + ; Output: CIDCARY = array of CIDC display lines for GMRCSLM2 display + N BGNRCCT,DXIEN,DXOF,DXV,EYE,ICD9,ICDR,LINE,OCT,ORFMDAT,TF + S BGNRCCT=GMRCCT,OCT=0 + ; Get the date of the order for CSV/CTD usage + S ORFMDAT=$$ORFMDAT^ORWDBA3(ORIFN) + ; $O through diagnoses for an order + F S OCT=$O(^OR(100,ORIFN,5.1,OCT)) Q:OCT'?1N.N D + . S DXOF=" " + . ; DXIEN=Dx IEN + . S DXIEN=+^OR(100,ORIFN,5.1,OCT,0) + . ; Get Dx record for date ORFMDAT + . S ICDR=$$ICDDX^ICDCODE(DXIEN,ORFMDAT) + . ; Get Dx verbiage and ICD code + . S DXV=$P(ICDR,U,4),ICD9=$P(ICDR,U,2) + . I OCT=1 D + .. S CIDCARY(GMRCCT,0)=" ",GMRCCT=GMRCCT+1 ;blank line + .. S CIDCARY(GMRCCT,0)="Clinical Indicators",GMRCCT=GMRCCT+1 + .. S DXOF="Diagnosis of: " + . S LINE=DXOF_ICD9_" - "_DXV + . S CIDCARY(GMRCCT,0)=LINE,GMRCCT=GMRCCT+1 + I OCT'="" D ;if there are diagnoses then show Treatment Factors + . S LINE="For conditions related to: " + . F EYE=1:1:7 S TF=$P(^OR(100,ORIFN,5.2),U,EYE) I TF D + .. S CIDCARY(GMRCCT,0)=LINE_$$SC^ORQ21(EYE) + .. S X=$$REPEAT^XLFSTR(" ",30),GMRCCT=GMRCCT+1 + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDFH.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDFH.m index 4d0e351e..4c1b3c61 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDFH.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDFH.m @@ -1,174 +1,174 @@ -ORWDFH ; SLC/KCM/JLI - Diet Order calls for Windows Dialogs ;12/12/00 14:44 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,92,141,187,215,243**;Dec 17, 1997;Build 242 -TXT(LST,DFN) ; Return text of current & future diets for a patient - S LST(1)="Current Diet: "_$$DIET^ORCDFH(DFN) - N FUTLST D FUT(.FUTLST,DFN) I $D(FUTLST)>1 D - . S LST(2)="Future Diet Orders:",ILST=2 - . S I=0 F S I=$O(FUTLST(I)) Q:'I D - . . S X=$$FMTE^XLFDT(I,2)_" "_$P(FUTLST(I),U,2) - . . S LST(ILST)=$S(ILST=2:"Future Diet Orders: "_X,1:" "_X) - . . S ILST=ILST+1 - Q -FUT(LST,DFN) ; Return a list of future diet orders - N DGRP,NXTDT,ORIFN,ORVP,ORTX - S ORVP=DFN_";DPT(",DGRP=$O(^ORD(100.98,"B","DO",0)),NXTDT=$$NOW^XLFDT - F S NXTDT=$O(^OR(100,"AW",ORVP,DGRP,NXTDT)) Q:NXTDT'>0 D - . S ORIFN=+$O(^OR(100,"AW",ORVP,DGRP,NXTDT,0)) - . I $P($G(^OR(100,ORIFN,3)),U,3)'=8 Q ; only scheduled diets - . D TEXT^ORQ12(.ORTX,ORIFN) S LST(NXTDT)=NXTDT_U_$G(ORTX(1)) - Q -PARAM(ORLST,ORVP,ORLOC) ; Return dietetics parameters for a patient at a location - ; ORLOC: hospital location ptr to ^SC #44 - ; ORLST(1)=EB1^EB2^EB3^LB1^LB2^LB3^EN1^EN2^...LE2^LE3 - ; ORLST(2)=BAB^BAE^NAB^NAE^EAB^EAE^BegB^BegN^BegE^Bagged - ; ORLST(3)=type of service^RegIEN^NPOIEN^EarlyIEN^LateIEN^TFIFN - ; ORLST(4)=max days in future for outpatient recurring meals - ; ORLST(5)=default outpatient diet - Q:'+ORVP - N X,IEN,CURTM - S ORVP=+ORVP_";DPT(",ORLOC=+ORLOC - S CURTM=$$NOW^XLFDT - I +$G(^SC(ORLOC,42)) S ORLOC=$G(^SC(ORLOC,42))_";DIC(42" - E S ORLOC=ORLOC_";SC(" - D EN1^FHWOR8(ORLOC,.ORLST) - ; - I '$L($G(ORLST(3))) S ORLST(3)="T" - S $P(ORLST(3),U,2)=$O(^ORD(101.43,"S.DIET","REGULAR",0)) - S $P(ORLST(3),U,3)=$O(^ORD(101.43,"S.DIET","NPO",0)) - S $P(ORLST(3),U,4)=$O(^ORD(101.43,"S.E/L T","EARLY TRAY",0)) - S $P(ORLST(3),U,5)=$O(^ORD(101.43,"S.E/L T","LATE TRAY",0)) - N TF S TF=$$CURRENT^ORCDFH("TF") I $L(TF,";")=1 S TF=TF_";1" - I TF,'$$FUTURE^ORCDFH("EFFECTIVE DATE/TIME") S $P(ORLST(3),U,6)=TF - I $$VERSION^XPDUTL("FH")>5 D - . S ORLST(4)=$$MAXDAYS^FHOMAPI(ORLOC) - . D DIETLST^FHOMAPI Q:'$G(FHDIET(1)) - . S IEN=$O(^ORD(101.43,"ID",$P(FHDIET(1),U,1)_";99FHD",0)) Q:+IEN=0 - . S X=^ORD(101.43,"S.DIET",$P(FHDIET(1),U,2),IEN) - . I +$P(X,U,3),$P(X,U,3)$$NOW^XLFDT S REC="0^"_$P($G(^ORD(101.43,OI,0)),U)_" has been inactivated and may not be ordered anymore." Q - S REC=OI_U_$P($G(^ORD(101.43,OI,0)),U)_U_$G(^("FH")) - Q -DIETS(Y,FROM,DIR) ; Return a subset of active diets, including NPO - ; Y(n)=IEN^.01 Name^.01 Name -or- IEN^Synonym <.01 Name>^.01 Name - N I,IEN,CNT,X,CURTM - S I=0,CNT=44,CURTM=$$NOW^XLFDT - F Q:I'"_U_$P(X,U,4) - Q -OPDIETS(ORY,FROM,DIR) ;Return a list of up to 5 outpatient diets from file 119.9 - N X,I,J,IEN,CURTM,SYNCNT,SYNTOT,FHDIET - D DIETLST^FHOMAPI - S CURTM=$$NOW^XLFDT,I=0,SYNTOT=1 - F S I=$O(FHDIET(I)) Q:'I D - . S IEN=$O(^ORD(101.43,"ID",$P(FHDIET(I),U,1)_";99FHD",0)) Q:+IEN=0 - . S X=^ORD(101.43,"S.DIET",$P(FHDIET(I),U,2),IEN) - . I +$P(X,U,3),$P(X,U,3)"_U_X - Q -TFPROD(Y) ; Return a list of active tubefeeding products - N I,IEN,NAM,X,CURTM - S I=0,NAM="",CURTM=$$NOW^XLFDT - F S NAM=$O(^ORD(101.43,"S.TF",NAM)) Q:NAM="" D - . S IEN=0 F S IEN=$O(^ORD(101.43,"S.TF",NAM,IEN)) Q:'IEN D - . . S X=^ORD(101.43,"S.TF",NAM,IEN) - . . I +$P(X,U,3),$P(X,U,3)"_U_$P(X,U,4) - Q -QTY2CC(VAL,PRD,STR,QTY) ; Return cc's given a product, strength, & quantity - N X,VQTY,DUR - S VQTY=$$VALIDQTY^ORCDFHTF(QTY) I '$L(VQTY)!('PRD)!('STR) S VAL="" Q - S PRD=+$P($G(^ORD(101.43,PRD,0)),U,2) - S DUR=$P(VQTY," X ",2) I $L(DUR) S DUR=$S(DUR["H":"H",1:"X")_+DUR - S X=+VQTY_"&"_$E($P(VQTY," ",2))_U_$P($P(VQTY,"/",2)," ")_U_DUR - S VAL=$$QUAN^FHWOR5R(PRD_"-"_STR,X)_U_VQTY - Q -FINDTYP(VAL,DGRP) ; Return type of dietetics order based on display group - S VAL=$P($G(^ORD(100.98,DGRP,0)),U,3) - S:VAL="D AO" VAL="A" S VAL=$E(VAL) - Q -ISOIEN(VAL) ; Return IEN for the Isolation/Precaution orderable item - S VAL=$O(^ORD(101.43,"S.PREC","ISOLATION PROCEDURES",0)) - Q -CURISO(VAL,ORVP) ; Return a patient's current isolation - S ORVP=ORVP_";DPT(" S VAL=$P($$IP^ORMBLD,U,2) - I '$L(VAL) S VAL="" - Q -ISOLIST(LST) ; Return list of active isolations/precautions - N I,X,IEN - S I=0,X="" F S X=$O(^FH(119.4,"B",X)) Q:X="" S IEN=$O(^(X,0)) D - . I '$D(^FH(119.4,IEN,"I")) S I=I+1,LST(I)=IEN_U_X - Q -MILTM(X) ; return military time for am/pm time - N TM - S TM=$P(X,":",1)_+$P(X,":",2) - I X["P",TM<1200 S TM=TM+1200 - I X["A",TM>1200 S TM=TM-1200 - Q TM - ; -ASKLATE(REC,DFN,ORIFN) ; Return info for ordering late tray for diet order - ; REC=0 or 1^meal^bagged^time^time^time - S REC=0 Q:'$G(ORIFN) Q:$E($$VALUE^ORX8(ORIFN,"ORDERABLE",1,"E"),1,3)="NPO" - N X,Y,%DT,STRT,DATE,ORPARAM,I,MEAL,MEALTIME - S X=$O(^OR(100,ORIFN,4.5,"ID","START",0)),X=$G(^OR(100,ORIFN,4.5,+X,1)) - Q:X="" S %DT="TX" D ^%DT Q:Y'>0 Q:$P(Y,".")>DT ;invalid or future - S DATE=$P(Y,"."),STRT=+$E($P(Y,".",2)_"0000",1,4),MEAL=0 - D EN^FHWOR8(DFN,.ORPARAM) Q:'$D(ORPARAM(2)) - F I=1,3,5 I $P(ORPARAM(2),U,I)0:1,1:0) - Q +ORWDFH ; SLC/KCM/JLI - Diet Order calls for Windows Dialogs ;12/12/00 14:44 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,92,141,187,215**;Dec 17, 1997 +TXT(LST,DFN) ; Return text of current & future diets for a patient + S LST(1)="Current Diet: "_$$DIET^ORCDFH(DFN) + N FUTLST D FUT(.FUTLST,DFN) I $D(FUTLST)>1 D + . S LST(2)="Future Diet Orders:",ILST=2 + . S I=0 F S I=$O(FUTLST(I)) Q:'I D + . . S X=$$FMTE^XLFDT(I,2)_" "_$P(FUTLST(I),U,2) + . . S LST(ILST)=$S(ILST=2:"Future Diet Orders: "_X,1:" "_X) + . . S ILST=ILST+1 + Q +FUT(LST,DFN) ; Return a list of future diet orders + N DGRP,NXTDT,ORIFN,ORVP,ORTX + S ORVP=DFN_";DPT(",DGRP=$O(^ORD(100.98,"B","DO",0)),NXTDT=$$NOW^XLFDT + F S NXTDT=$O(^OR(100,"AW",ORVP,DGRP,NXTDT)) Q:NXTDT'>0 D + . S ORIFN=+$O(^OR(100,"AW",ORVP,DGRP,NXTDT,0)) + . I $P($G(^OR(100,ORIFN,3)),U,3)'=8 Q ; only scheduled diets + . D TEXT^ORQ12(.ORTX,ORIFN) S LST(NXTDT)=NXTDT_U_$G(ORTX(1)) + Q +PARAM(ORLST,ORVP,ORLOC) ; Return dietetics parameters for a patient at a location + ; ORLOC: hospital location ptr to ^SC #44 + ; ORLST(1)=EB1^EB2^EB3^LB1^LB2^LB3^EN1^EN2^...LE2^LE3 + ; ORLST(2)=BAB^BAE^NAB^NAE^EAB^EAE^BegB^BegN^BegE^Bagged + ; ORLST(3)=type of service^RegIEN^NPOIEN^EarlyIEN^LateIEN^TFIFN + ; ORLST(4)=max days in future for outpatient recurring meals + ; ORLST(5)=default outpatient diet + Q:'+ORVP + N X,IEN,CURTM + S ORVP=+ORVP_";DPT(",ORLOC=+ORLOC + S CURTM=$$NOW^XLFDT + I $D(^SC(ORLOC,42)) S ORLOC=$G(^SC(ORLOC,42))_";DIC(42" + E S ORLOC=ORLOC_";SC(" + D EN1^FHWOR8(ORLOC,.ORLST) + ; + I '$L($G(ORLST(3))) S ORLST(3)="T" + S $P(ORLST(3),U,2)=$O(^ORD(101.43,"S.DIET","REGULAR",0)) + S $P(ORLST(3),U,3)=$O(^ORD(101.43,"S.DIET","NPO",0)) + S $P(ORLST(3),U,4)=$O(^ORD(101.43,"S.E/L T","EARLY TRAY",0)) + S $P(ORLST(3),U,5)=$O(^ORD(101.43,"S.E/L T","LATE TRAY",0)) + N TF S TF=$$CURRENT^ORCDFH("TF") I $L(TF,";")=1 S TF=TF_";1" + I TF,'$$FUTURE^ORCDFH("EFFECTIVE DATE/TIME") S $P(ORLST(3),U,6)=TF + I $$VERSION^XPDUTL("FH")>5 D + . S ORLST(4)=$$MAXDAYS^FHOMAPI(ORLOC) + . D DIETLST^FHOMAPI Q:'$G(FHDIET(1)) + . S IEN=$O(^ORD(101.43,"ID",$P(FHDIET(1),U,1)_";99FHD",0)) Q:+IEN=0 + . S X=^ORD(101.43,"S.DIET",$P(FHDIET(1),U,2),IEN) + . I +$P(X,U,3),$P(X,U,3)$$NOW^XLFDT S REC="0^"_$P($G(^ORD(101.43,OI,0)),U)_" has been inactivated and may not be ordered anymore." Q + S REC=OI_U_$P($G(^ORD(101.43,OI,0)),U)_U_$G(^("FH")) + Q +DIETS(Y,FROM,DIR) ; Return a subset of active diets, including NPO + ; Y(n)=IEN^.01 Name^.01 Name -or- IEN^Synonym <.01 Name>^.01 Name + N I,IEN,CNT,X,CURTM + S I=0,CNT=44,CURTM=$$NOW^XLFDT + F Q:I'"_U_$P(X,U,4) + Q +OPDIETS(ORY,FROM,DIR) ;Return a list of up to 5 outpatient diets from file 119.9 + N X,I,J,IEN,CURTM,SYNCNT,SYNTOT,FHDIET + D DIETLST^FHOMAPI + S CURTM=$$NOW^XLFDT,I=0,SYNTOT=1 + F S I=$O(FHDIET(I)) Q:'I D + . S IEN=$O(^ORD(101.43,"ID",$P(FHDIET(I),U,1)_";99FHD",0)) Q:+IEN=0 + . S X=^ORD(101.43,"S.DIET",$P(FHDIET(I),U,2),IEN) + . I +$P(X,U,3),$P(X,U,3)"_U_X + Q +TFPROD(Y) ; Return a list of active tubefeeding products + N I,IEN,NAM,X,CURTM + S I=0,NAM="",CURTM=$$NOW^XLFDT + F S NAM=$O(^ORD(101.43,"S.TF",NAM)) Q:NAM="" D + . S IEN=0 F S IEN=$O(^ORD(101.43,"S.TF",NAM,IEN)) Q:'IEN D + . . S X=^ORD(101.43,"S.TF",NAM,IEN) + . . I +$P(X,U,3),$P(X,U,3)"_U_$P(X,U,4) + Q +QTY2CC(VAL,PRD,STR,QTY) ; Return cc's given a product, strength, & quantity + N X,VQTY,DUR + S VQTY=$$VALIDQTY^ORCDFHTF(QTY) I '$L(VQTY)!('PRD)!('STR) S VAL="" Q + S PRD=+$P($G(^ORD(101.43,PRD,0)),U,2) + S DUR=$P(VQTY," X ",2) I $L(DUR) S DUR=$S(DUR["H":"H",1:"X")_+DUR + S X=+VQTY_"&"_$E($P(VQTY," ",2))_U_$P($P(VQTY,"/",2)," ")_U_DUR + S VAL=$$QUAN^FHWOR5R(PRD_"-"_STR,X)_U_VQTY + Q +FINDTYP(VAL,DGRP) ; Return type of dietetics order based on display group + S VAL=$P($G(^ORD(100.98,DGRP,0)),U,3) + S:VAL="D AO" VAL="A" S VAL=$E(VAL) + Q +ISOIEN(VAL) ; Return IEN for the Isolation/Precaution orderable item + S VAL=$O(^ORD(101.43,"S.PREC","ISOLATION PROCEDURES",0)) + Q +CURISO(VAL,ORVP) ; Return a patient's current isolation + S ORVP=ORVP_";DPT(" S VAL=$P($$IP^ORMBLD,U,2) + I '$L(VAL) S VAL="" + Q +ISOLIST(LST) ; Return list of active isolations/precautions + N I,X,IEN + S I=0,X="" F S X=$O(^FH(119.4,"B",X)) Q:X="" S IEN=$O(^(X,0)) D + . I '$D(^FH(119.4,IEN,"I")) S I=I+1,LST(I)=IEN_U_X + Q +MILTM(X) ; return military time for am/pm time + N TM + S TM=$P(X,":",1)_+$P(X,":",2) + I X["P",TM<1200 S TM=TM+1200 + I X["A",TM>1200 S TM=TM-1200 + Q TM + ; +ASKLATE(REC,DFN,ORIFN) ; Return info for ordering late tray for diet order + ; REC=0 or 1^meal^bagged^time^time^time + S REC=0 Q:'$G(ORIFN) Q:$E($$VALUE^ORX8(ORIFN,"ORDERABLE",1,"E"),1,3)="NPO" + N X,Y,%DT,STRT,DATE,ORPARAM,I,MEAL,MEALTIME + S X=$O(^OR(100,ORIFN,4.5,"ID","START",0)),X=$G(^OR(100,ORIFN,4.5,+X,1)) + Q:X="" S %DT="TX" D ^%DT Q:Y'>0 Q:$P(Y,".")>DT ;invalid or future + S DATE=$P(Y,"."),STRT=+$E($P(Y,".",2)_"0000",1,4),MEAL=0 + D EN^FHWOR8(DFN,.ORPARAM) Q:'$D(ORPARAM(2)) + F I=1,3,5 I $P(ORPARAM(2),U,I)0:1,1:0) + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDGX.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDGX.m index ee9e2848..9d5e2180 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDGX.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDGX.m @@ -1,56 +1,53 @@ -ORWDGX ; SLC/KCM - Generic Orders calls for Windows Dialogs [ 08/05/96 8:21 AM ] - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**243**;Dec 17, 1997;Build 242 - ; -ACT() N X,RSLT S X=^(0),RSLT=1 - I "DQ"'[$P(X,U,4) S RSLT=0 - S X1=$O(^ORD(100.98,"B","ACTIVITY",0)) - S X2=$O(^ORD(100.98,"B","NURSING",0)) - I "DQ"'[$P(X,U,4) S RSLT=0 - I RSLT,((U_X1_U_X2_U)'[(U_$P(X,U,5)_U)) S RSLT=0 - Q RSLT -NURS() N X,RSLT S X=^(0),RSLT=1 - I "DQ"'[$P(X,U,4) S RSLT=0 - I RSLT,($P(X,U,5)'=$O(^ORD(100.98,"B","NURSING",0))) S RSLT=0 - Q RSLT -OITEXT(Y,DLG) ; Return Orderable Item Text given dialog or quick order - S Y=$P(^ORD(101.41,DLG,0),U,2) - Q -LOAD(LST,PAR) ; Load a list of activity orders - N I,ILST,DLG,NAM,TLST - D GETLST^XPAR(.TLST,"ALL",PAR) - S I=0,ILST=0 F S I=$O(TLST(I)) Q:'I D - . S DLG=$P(TLST(I),U,2),NAM=$P(^ORD(101.41,+DLG,0),U,2) - . S ILST=ILST+1,LST(ILST)=DLG_U_NAM - Q - ; - N DLGTYP,OIDLG,FTDLG,OITYP,I,IFN - S DLGTYP=$P(^ORD(101.41,DLG,0),U,4) - S OIDLG=$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0)) - S FTDLG=$O(^ORD(101.41,"B","OR GTX FREE TEXT OI",0)) - I DLGTYP="D" D - . S I=0,IFN=0 F S I=$O(^ORD(101.41,DLG,10,I)) S X=^(I,0) D Q:IFN - . . I $P(X,U,2)=OIDLG S IFN=I,OITYP="O" - . . I $P(X,U,2)=FTDLG S IFN=I,OITYP="F" - . S Y="" I $L($G(^ORD(101.41,DLG,10,IFN,7))) X ^(7) - . I OITYP="O" S Y=$P(^ORD(101.43,+Y,0),U,1) - Q -VMDEF(LST) ; Return dialog definition for vitals/measurements - N ILST S ILST=0 - S LST($$NXT)="~Measurements" D MEASURE - S LST($$NXT)="~Schedules" D VMSCHED - Q -MEASURE ; Get measurements available - S X="" F S X=$O(^ORD(101.43,"S.V/M",X)) Q:X="" D - . S I=$O(^ORD(101.43,"S.V/M",X,0)),LST($$NXT)="i"_I_U_X - S LST($$NXT)="dTPR B/P" ; ** do this with a parameter - Q -VMSCHED ; Get vitals/measurements schedules - K ^TMP($J,"ORWDGX APGMRV") - D AP^PSS51P1("GMRV",,,,"ORWDGX APGMRV") - S X="" F S X=$O(^TMP($J,"ORWDGX APGMRV","APGMRV",X)) Q:X="" D - . S I=$O(^TMP($J,"ORWDGX APGMRV","APGMRV",X,0)),LST($$NXT)="i"_I_U_X - K ^TMP($J,"ORWDGX APGMRV") - Q -NXT() ; Increment index into LST - S ILST=ILST+1 - Q ILST +ORWDGX ; SLC/KCM - Generic Orders calls for Windows Dialogs [ 08/05/96 8:21 AM ] + ;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997 + ; +ACT() N X,RSLT S X=^(0),RSLT=1 + I "DQ"'[$P(X,U,4) S RSLT=0 + S X1=$O(^ORD(100.98,"B","ACTIVITY",0)) + S X2=$O(^ORD(100.98,"B","NURSING",0)) + I "DQ"'[$P(X,U,4) S RSLT=0 + I RSLT,((U_X1_U_X2_U)'[(U_$P(X,U,5)_U)) S RSLT=0 + Q RSLT +NURS() N X,RSLT S X=^(0),RSLT=1 + I "DQ"'[$P(X,U,4) S RSLT=0 + I RSLT,($P(X,U,5)'=$O(^ORD(100.98,"B","NURSING",0))) S RSLT=0 + Q RSLT +OITEXT(Y,DLG) ; Return Orderable Item Text given dialog or quick order + S Y=$P(^ORD(101.41,DLG,0),U,2) + Q +LOAD(LST,PAR) ; Load a list of activity orders + N I,ILST,DLG,NAM,TLST + D GETLST^XPAR(.TLST,"ALL",PAR) + S I=0,ILST=0 F S I=$O(TLST(I)) Q:'I D + . S DLG=$P(TLST(I),U,2),NAM=$P(^ORD(101.41,+DLG,0),U,2) + . S ILST=ILST+1,LST(ILST)=DLG_U_NAM + Q + ; + N DLGTYP,OIDLG,FTDLG,OITYP,I,IFN + S DLGTYP=$P(^ORD(101.41,DLG,0),U,4) + S OIDLG=$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0)) + S FTDLG=$O(^ORD(101.41,"B","OR GTX FREE TEXT OI",0)) + I DLGTYP="D" D + . S I=0,IFN=0 F S I=$O(^ORD(101.41,DLG,10,I)) S X=^(I,0) D Q:IFN + . . I $P(X,U,2)=OIDLG S IFN=I,OITYP="O" + . . I $P(X,U,2)=FTDLG S IFN=I,OITYP="F" + . S Y="" I $L($G(^ORD(101.41,DLG,10,IFN,7))) X ^(7) + . I OITYP="O" S Y=$P(^ORD(101.43,+Y,0),U,1) + Q +VMDEF(LST) ; Return dialog definition for vitals/measurements + N ILST S ILST=0 + S LST($$NXT)="~Measurements" D MEASURE + S LST($$NXT)="~Schedules" D VMSCHED + Q +MEASURE ; Get measurements available + S X="" F S X=$O(^ORD(101.43,"S.V/M",X)) Q:X="" D + . S I=$O(^ORD(101.43,"S.V/M",X,0)),LST($$NXT)="i"_I_U_X + S LST($$NXT)="dTPR B/P" ; ** do this with a parameter + Q +VMSCHED ; Get vitals/measurements schedules + S X="" F S X=$O(^PS(51.1,"APGMRV",X)) Q:X="" D + . S I=$O(^PS(51.1,"APGMRV",X,0)),LST($$NXT)="i"_I_U_X + Q +NXT() ; Increment index into LST + S ILST=ILST+1 + Q ILST diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDLR.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDLR.m index ebe0863e..58bf4bd0 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDLR.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDLR.m @@ -1,144 +1,140 @@ -ORWDLR ; SLC/KCM - Lab Calls [ 08/04/96 8:47 PM ] - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**243**;Dec 17, 1997;Build 242 - ; -DEF(LST,ALOC) ; procedure - ; get dialog definition specific to lab - S ILST=0 - S LST($$NXT)="~Collection Times" D COLLTM - S LST($$NXT)="~Send Patient Times" D SENDTM - S LST($$NXT)="~Default Urgency="_$$DEFURG^LR7OR3 - ; S LST($$NXT)="~Urgencies Map" D URGMAP - S LST($$NXT)="~Schedules" D SCHED - S LST($$NXT)="~Common" D COMMON - Q -COLLTM ; get collection times - N TDAY,TMRW,IGNOR,CNT,ICTM,CTM,DOW,AMPM,DAY,TIME,FMDT - S TDAY=DT,TDAY("DOW")=$H#7,TDAY("H")=$H - M TMRW=TDAY D INCDATE(.TMRW) - I $G(ALOC),'$$GET^XPAR(ALOC_";SC(","LR EXCEPTED LOCATIONS",1,"Q") D - . S IGNOR=$$GET^XPAR("ALL","LR IGNORE HOLIDAYS",1,"Q") - . S DOW(0)=$$GET^XPAR("ALL","LR COLLECT THURSDAY",1,"Q") - . S DOW(1)=$$GET^XPAR("ALL","LR COLLECT FRIDAY",1,"Q") - . S DOW(2)=$$GET^XPAR("ALL","LR COLLECT SATURDAY",1,"Q") - . S DOW(3)=$$GET^XPAR("ALL","LR COLLECT SUNDAY",1,"Q") - . S DOW(4)=$$GET^XPAR("ALL","LR COLLECT MONDAY",1,"Q") - . S DOW(5)=$$GET^XPAR("ALL","LR COLLECT TUESDAY",1,"Q") - . S DOW(6)=$$GET^XPAR("ALL","LR COLLECT WEDNESDAY",1,"Q") - . S CNT=0 F Q:(DOW(TDAY("DOW"))=1)&((IGNOR=1)!('$D(^HOLIDAY(TDAY,0)))) D Q:CNT>6 - . . D INCDATE(.TDAY) S CNT=CNT+1 - . S CNT=0 F Q:(DOW(TMRW("DOW"))=1)&((IGNOR=1)!('$D(^HOLIDAY(TMRW,0)))) D Q:CNT>6 - . . D INCDATE(.TMRW) S CNT=CNT+1 - D GETLST^XPAR(.CTM,"ALL","LR PHLEBOTOMY COLLECTION","Q") - S ICTM=0 F S ICTM=$O(CTM(ICTM)) Q:'ICTM D - . I $P(CTM(ICTM),U)>$P($H,",",2) D - . . S FMDT=TDAY - . . I +TDAY("H")=+$H S DAY="Today" - . . I TDAY("H")-$H=1 S DAY="Tomorrow" - . . I TDAY("H")-$H>1 S DAY=$$DOWNAME(TDAY("DOW")) - . E D - . . S FMDT=TMRW - . . S DAY=$S(TMRW("H")-$H>1:$$DOWNAME(TMRW("DOW")),1:"Tomorrow") - . S AMPM=$S($P(CTM(ICTM),U,2)>1159:"PM",1:"AM") - . S FMDT=FMDT_"."_$P(CTM(ICTM),"^",2) - . S TIME=$P(CTM(ICTM),U,2),TIME=$E(TIME,1,2)_":"_$E(TIME,3,4) - . S LST($$NXT)="iL"_FMDT_U_AMPM_" Collection: "_TIME_" ("_DAY_")" - D NOW^%DTC - S LST($$NXT)="iW"_%_"^Now (Collect on ward)" - Q -SENDTM ; get send patient times - N X,X1,X2 - S LST($$NXT)="iL"_DT_"^Today" - S X1=DT,X2=1 D C^%DTC - S LST($$NXT)="iL"_X_"^Tomorrow" - Q -INCDATE(ADATE) ; called from COLLTM, increments date nodes in .ADATE - N X,X1,X2,%H - S X1=ADATE,X2=1 D C^%DTC S ADATE=X - S ADATE("H")=ADATE("H")+1 - S ADATE("DOW")=ADATE("H")#7 - Q -DOWNAME(DOW) ; function - ; Returns Day of Week name (DOW should be $H#7) - I DOW=0 Q "Thursday" - I DOW=1 Q "Friday" - I DOW=2 Q "Saturday" - I DOW=3 Q "Sunday" - I DOW=4 Q "Monday" - I DOW=5 Q "Tuesday" - I DOW=6 Q "Wednesday" - Q "" -URGMAP ; return list of lab urgencies mapped to OE/RR urgencies - Q - N I,X - S I=0 F S I=$O(^LAB(62.05,I)) Q:'I S X=^(I,0) I '$P(X,U,3) D - . S LST($$NXT)="i"_I_"="_I_U_$P(X,U) - ; D GETLST^XPAR(.Y,"ALL","ORCDLR URGENCIES","N") - ; S URG=0 F S URG=$O(Y(URG)) Q:'URG S LST($$NXT)="i"_URG_"="_Y(URG) - Q -SCHED ; return list of schedules available for lab tests - N X,IEN - K ^TMP($J,"ORWDLR APLR") - D AP^PSS51P1("LR",,,,"ORWDLR APLR") - S X="" F S X=$O(^TMP($J,"ORWDLR APLR","APLR",X)) Q:X="" D - . S IEN=$O(^TMP($J,"ORWDLR APLR","APLR",X,"")) I IEN'>0 Q - . S LST($$NXT)="i"_IEN_U_X_U_$P($G(^TMP($J,"ORWDLR APLR",IEN,5)),U) - . I X="ONE TIME" S LST($$NXT)="d"_X - K ^TMP($J,"ORWDLR APLR") - Q -COMMON ; return list of commonly ordered lab tests - N TMPLST,IEN,I - D GETLST^XPAR(.TMPLST,"ALL","ORWD COMMON LAB INPT") - S I=0 F S I=$O(TMPLST(I)) Q:'I D - . S IEN=$P(TMPLST(I),U,2) - . S LST($$NXT)="i"_IEN_U_$P(^ORD(101.43,IEN,0),U,1) - Q -LOAD(LST,TESTID) ; procedure - ; Return sample, specimen, & urgency info about a lab test - N X,Y,ILST,PARAM S ILST=0 - S LST($$NXT)="~Test Name="_$P(^ORD(101.43,TESTID,0),U,1) - I $D(^ORD(101.43,TESTID,8))>1 S LST($$NXT)="~OIMessage" - S I=0 F S I=$O(^ORD(101.43,TESTID,8,I)) Q:'I S LST($$NXT)="t"_^(I,0) - S TESTID=+$P(^ORD(101.43,TESTID,0),U,2) - D TEST^LR7OR3(TESTID,.Y) - S PARAM="" F S PARAM=$O(Y(PARAM)) Q:PARAM="" D - . S LST($$NXT)="~"_PARAM_$S($D(Y(PARAM))>1:"",1:"="_$G(Y(PARAM))) - . I $D(Y(PARAM))>1 S I=0 F S I=$O(Y(PARAM,I)) Q:'I D - . . I PARAM="Specimens" S LST($$NXT)="i"_Y(PARAM,I) Q - . . I PARAM="Urgencies" S LST($$NXT)="i"_Y(PARAM,I) Q - . . S LST($$NXT)="i"_I_U_Y(PARAM,I) - . . I PARAM="CollSamp" D - . . . I $G(Y("Lab CollSamp")) S $P(LST(ILST),U,8)=1 - . . . S X=+$P(Y(PARAM,I),U,3) - . . . I X S $P(LST(ILST),U,10)=$P($G(^LAB(61,X,0)),U,1) - . . I $D(Y(PARAM,I,"WP")) S J=0 F S J=$O(Y(PARAM,I,"WP",J)) Q:'J D - . . . S LST($$NXT)="t"_Y(PARAM,I,"WP",J,0) - Q -ALLSAMP(LST) ; procedure - ; returns all collection samples - ; n^SampIEN^SampName^SpecPtr^TubeTop^^^LabCollect^^SpecName - N SMP,SPC,ILST,IEN,X,X0 - S ILST=0,LST($$NXT)="~CollSamp" - S SMP="" F S SMP=$O(^LAB(62,"B",SMP)) Q:SMP="" D - . S IEN=0 F S IEN=$O(^LAB(62,"B",SMP,IEN)) Q:'IEN D - . . S X0=^LAB(62,IEN,0) - . . S X="i"_U_IEN_U_SMP_U_$P(X0,U,2)_U_$P(X0,U,3)_U_U_U_$P(X0,U,7) - . . I $P(X0,U,2) D - . . . S $P(X,U,10)=$P(^LAB(61,+$P(X0,U,2),0),U,1) - . . . S SPC($P(X,U,4))=$P(X,U,10) - . . S LST($$NXT)=X - S LST($$NXT)="~Specimens" - S SPC=0 F S SPC=$O(SPC(SPC)) Q:'SPC S LST($$NXT)=SPC_U_SPC(SPC) - Q -ABBSPEC(LST) ; procedure - ; returns specimens with abbreviation (uses 'E' xref) - N X,IEN,ILST S ILST=0 - S X="" F S X=$O(^LAB(61,"E",X)) Q:X="" S IEN=$O(^(X,0)) D - . S LST($$NXT)=IEN_U_$P(^LAB(61,IEN,0),U,1) - Q -NXT() ; called by TESTINFO, increments ILST - S ILST=ILST+1 - Q ILST -STOP(VAL,X2) ; return a calculated stop date - N X1,X - S X1=DT D C^%DTC S VAL=X - Q +ORWDLR ; SLC/KCM - Lab Calls [ 08/04/96 8:47 PM ] + ;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997 + ; +DEF(LST,ALOC) ; procedure + ; get dialog definition specific to lab + S ILST=0 + S LST($$NXT)="~Collection Times" D COLLTM + S LST($$NXT)="~Send Patient Times" D SENDTM + S LST($$NXT)="~Default Urgency="_$$DEFURG^LR7OR3 + ; S LST($$NXT)="~Urgencies Map" D URGMAP + S LST($$NXT)="~Schedules" D SCHED + S LST($$NXT)="~Common" D COMMON + Q +COLLTM ; get collection times + N TDAY,TMRW,IGNOR,CNT,ICTM,CTM,DOW,AMPM,DAY,TIME,FMDT + S TDAY=DT,TDAY("DOW")=$H#7,TDAY("H")=$H + M TMRW=TDAY D INCDATE(.TMRW) + I $G(ALOC),'$$GET^XPAR(ALOC_";SC(","LR EXCEPTED LOCATIONS",1,"Q") D + . S IGNOR=$$GET^XPAR("ALL","LR IGNORE HOLIDAYS",1,"Q") + . S DOW(0)=$$GET^XPAR("ALL","LR COLLECT THURSDAY",1,"Q") + . S DOW(1)=$$GET^XPAR("ALL","LR COLLECT FRIDAY",1,"Q") + . S DOW(2)=$$GET^XPAR("ALL","LR COLLECT SATURDAY",1,"Q") + . S DOW(3)=$$GET^XPAR("ALL","LR COLLECT SUNDAY",1,"Q") + . S DOW(4)=$$GET^XPAR("ALL","LR COLLECT MONDAY",1,"Q") + . S DOW(5)=$$GET^XPAR("ALL","LR COLLECT TUESDAY",1,"Q") + . S DOW(6)=$$GET^XPAR("ALL","LR COLLECT WEDNESDAY",1,"Q") + . S CNT=0 F Q:(DOW(TDAY("DOW"))=1)&((IGNOR=1)!('$D(^HOLIDAY(TDAY,0)))) D Q:CNT>6 + . . D INCDATE(.TDAY) S CNT=CNT+1 + . S CNT=0 F Q:(DOW(TMRW("DOW"))=1)&((IGNOR=1)!('$D(^HOLIDAY(TMRW,0)))) D Q:CNT>6 + . . D INCDATE(.TMRW) S CNT=CNT+1 + D GETLST^XPAR(.CTM,"ALL","LR PHLEBOTOMY COLLECTION","Q") + S ICTM=0 F S ICTM=$O(CTM(ICTM)) Q:'ICTM D + . I $P(CTM(ICTM),U)>$P($H,",",2) D + . . S FMDT=TDAY + . . I +TDAY("H")=+$H S DAY="Today" + . . I TDAY("H")-$H=1 S DAY="Tomorrow" + . . I TDAY("H")-$H>1 S DAY=$$DOWNAME(TDAY("DOW")) + . E D + . . S FMDT=TMRW + . . S DAY=$S(TMRW("H")-$H>1:$$DOWNAME(TMRW("DOW")),1:"Tomorrow") + . S AMPM=$S($P(CTM(ICTM),U,2)>1159:"PM",1:"AM") + . S FMDT=FMDT_"."_$P(CTM(ICTM),"^",2) + . S TIME=$P(CTM(ICTM),U,2),TIME=$E(TIME,1,2)_":"_$E(TIME,3,4) + . S LST($$NXT)="iL"_FMDT_U_AMPM_" Collection: "_TIME_" ("_DAY_")" + D NOW^%DTC + S LST($$NXT)="iW"_%_"^Now (Collect on ward)" + Q +SENDTM ; get send patient times + N X,X1,X2 + S LST($$NXT)="iL"_DT_"^Today" + S X1=DT,X2=1 D C^%DTC + S LST($$NXT)="iL"_X_"^Tomorrow" + Q +INCDATE(ADATE) ; called from COLLTM, increments date nodes in .ADATE + N X,X1,X2,%H + S X1=ADATE,X2=1 D C^%DTC S ADATE=X + S ADATE("H")=ADATE("H")+1 + S ADATE("DOW")=ADATE("H")#7 + Q +DOWNAME(DOW) ; function + ; Returns Day of Week name (DOW should be $H#7) + I DOW=0 Q "Thursday" + I DOW=1 Q "Friday" + I DOW=2 Q "Saturday" + I DOW=3 Q "Sunday" + I DOW=4 Q "Monday" + I DOW=5 Q "Tuesday" + I DOW=6 Q "Wednesday" + Q "" +URGMAP ; return list of lab urgencies mapped to OE/RR urgencies + Q + N I,X + S I=0 F S I=$O(^LAB(62.05,I)) Q:'I S X=^(I,0) I '$P(X,U,3) D + . S LST($$NXT)="i"_I_"="_I_U_$P(X,U) + ; D GETLST^XPAR(.Y,"ALL","ORCDLR URGENCIES","N") + ; S URG=0 F S URG=$O(Y(URG)) Q:'URG S LST($$NXT)="i"_URG_"="_Y(URG) + Q +SCHED ; return list of schedules available for lab tests + N X,IEN + S X="" F S X=$O(^PS(51.1,"APLR",X)) Q:X="" S IEN=$O(^(X,0)) I IEN D + . S LST($$NXT)="i"_IEN_U_X_U_$P($G(^PS(51.1,IEN,0)),U,5) + . I X="ONE TIME" S LST($$NXT)="d"_X + Q +COMMON ; return list of commonly ordered lab tests + N TMPLST,IEN,I + D GETLST^XPAR(.TMPLST,"ALL","ORWD COMMON LAB INPT") + S I=0 F S I=$O(TMPLST(I)) Q:'I D + . S IEN=$P(TMPLST(I),U,2) + . S LST($$NXT)="i"_IEN_U_$P(^ORD(101.43,IEN,0),U,1) + Q +LOAD(LST,TESTID) ; procedure + ; Return sample, specimen, & urgency info about a lab test + N X,Y,ILST,PARAM S ILST=0 + S LST($$NXT)="~Test Name="_$P(^ORD(101.43,TESTID,0),U,1) + I $D(^ORD(101.43,TESTID,8))>1 S LST($$NXT)="~OIMessage" + S I=0 F S I=$O(^ORD(101.43,TESTID,8,I)) Q:'I S LST($$NXT)="t"_^(I,0) + S TESTID=+$P(^ORD(101.43,TESTID,0),U,2) + D TEST^LR7OR3(TESTID,.Y) + S PARAM="" F S PARAM=$O(Y(PARAM)) Q:PARAM="" D + . S LST($$NXT)="~"_PARAM_$S($D(Y(PARAM))>1:"",1:"="_$G(Y(PARAM))) + . I $D(Y(PARAM))>1 S I=0 F S I=$O(Y(PARAM,I)) Q:'I D + . . I PARAM="Specimens" S LST($$NXT)="i"_Y(PARAM,I) Q + . . I PARAM="Urgencies" S LST($$NXT)="i"_Y(PARAM,I) Q + . . S LST($$NXT)="i"_I_U_Y(PARAM,I) + . . I PARAM="CollSamp" D + . . . I $G(Y("Lab CollSamp")) S $P(LST(ILST),U,8)=1 + . . . S X=+$P(Y(PARAM,I),U,3) + . . . I X S $P(LST(ILST),U,10)=$P($G(^LAB(61,X,0)),U,1) + . . I $D(Y(PARAM,I,"WP")) S J=0 F S J=$O(Y(PARAM,I,"WP",J)) Q:'J D + . . . S LST($$NXT)="t"_Y(PARAM,I,"WP",J,0) + Q +ALLSAMP(LST) ; procedure + ; returns all collection samples + ; n^SampIEN^SampName^SpecPtr^TubeTop^^^LabCollect^^SpecName + N SMP,SPC,ILST,IEN,X,X0 + S ILST=0,LST($$NXT)="~CollSamp" + S SMP="" F S SMP=$O(^LAB(62,"B",SMP)) Q:SMP="" D + . S IEN=0 F S IEN=$O(^LAB(62,"B",SMP,IEN)) Q:'IEN D + . . S X0=^LAB(62,IEN,0) + . . S X="i"_U_IEN_U_SMP_U_$P(X0,U,2)_U_$P(X0,U,3)_U_U_U_$P(X0,U,7) + . . I $P(X0,U,2) D + . . . S $P(X,U,10)=$P(^LAB(61,+$P(X0,U,2),0),U,1) + . . . S SPC($P(X,U,4))=$P(X,U,10) + . . S LST($$NXT)=X + S LST($$NXT)="~Specimens" + S SPC=0 F S SPC=$O(SPC(SPC)) Q:'SPC S LST($$NXT)=SPC_U_SPC(SPC) + Q +ABBSPEC(LST) ; procedure + ; returns specimens with abbreviation (uses 'E' xref) + N X,IEN,ILST S ILST=0 + S X="" F S X=$O(^LAB(61,"E",X)) Q:X="" S IEN=$O(^(X,0)) D + . S LST($$NXT)=IEN_U_$P(^LAB(61,IEN,0),U,1) + Q +NXT() ; called by TESTINFO, increments ILST + S ILST=ILST+1 + Q ILST +STOP(VAL,X2) ; return a calculated stop date + N X1,X + S X1=DT D C^%DTC S VAL=X + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDLR32.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDLR32.m index d219b081..3f3a479d 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDLR32.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDLR32.m @@ -1,221 +1,216 @@ -ORWDLR32 ; SLC/KCM/REV/JDL - Lab Calls 6/28/2002 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,141,215,250,243**;Dec 17, 1997;Build 242 - ; - ; DBIA 2263 GETLST^XPAR ^TMP($J,"WC") - ; -DEF(LST,ALOC,ADIV) ; procedure - ; For Event Delay Order - ; ALOC: Delay Event's default location - ; ADIV: Delay Event's default division - ; get dialog definition specific to lab - S ILST=0 - S LST($$NXT)="~ShortList" D SHORT - S LST($$NXT)="~Lab Collection Times" D LCOLLTM - S LST($$NXT)="~Ward Collection Times" D WCOLLTM - S LST($$NXT)="~Send Patient Times" D SENDTM - S LST($$NXT)="~Collection Types" D COLLTYP - S LST($$NXT)="~Default Urgency" D URGENCY - S LST($$NXT)="~Schedules" D SCHED - S LST($$NXT)="~Common" D COMMON - Q -SHORT ; from DEF, get short list of lab quick orders - N I,ORTMP,ORDG,A - S I=$O(^ORD(100.98,"B","LAB",0)) ; get IEN of parent lab - D DG^ORCHANG1(I,"BILD",.ORDG) ; find members groups for parent lab - S I=0 - F S I=$O(ORDG(I)) Q:'I D ; loop through list of members groups - . I $E($P($G(^ORD(100.98,I,0)),"^",3),1,2)="VB" Q - . D GETQLST^ORWDXQ(.ORTMP,I,"Q") ;get quick order of each members groups - . S A=0 F S A=$O(ORTMP(A)) Q:'A D ; loop through returned quick orders and - . . S LST($$NXT)="i"_ORTMP(A) ; move quick orders to display list - . K ORTMP ; clean up for next members groups of quick orders - Q -LCOLLTM ; get collection times - N TDAY,TMRW,IGNOR,CNT,ICTM,ORCTM,DOW,AMPM,DAY,TIME,TXDT - S TDAY=DT,TDAY("DOW")=$H#7,TDAY("H")=$H,TDAY("TX")="T" - M TMRW=TDAY D INCDATE(.TMRW) - I $G(ALOC),'$$GET^XPAR(ALOC_";SC(","LR EXCEPTED LOCATIONS",1,"Q") D - . S IGNOR=$$GET^XPAR("ALL","LR IGNORE HOLIDAYS",1,"Q") - . S DOW(0)=$$GET^XPAR("ALL","LR COLLECT THURSDAY",1,"Q") - . S DOW(1)=$$GET^XPAR("ALL","LR COLLECT FRIDAY",1,"Q") - . S DOW(2)=$$GET^XPAR("ALL","LR COLLECT SATURDAY",1,"Q") - . S DOW(3)=$$GET^XPAR("ALL","LR COLLECT SUNDAY",1,"Q") - . S DOW(4)=$$GET^XPAR("ALL","LR COLLECT MONDAY",1,"Q") - . S DOW(5)=$$GET^XPAR("ALL","LR COLLECT TUESDAY",1,"Q") - . S DOW(6)=$$GET^XPAR("ALL","LR COLLECT WEDNESDAY",1,"Q") - . S CNT=0 F Q:(DOW(TDAY("DOW"))=1)&((IGNOR=1)!('$D(^HOLIDAY(TDAY,0)))) D Q:CNT>6 - . . D INCDATE(.TDAY) S CNT=CNT+1 - . S CNT=0 F Q:(DOW(TMRW("DOW"))=1)&((IGNOR=1)!('$D(^HOLIDAY(TMRW,0)))) D Q:CNT>6 - . . D INCDATE(.TMRW) S CNT=CNT+1 - I $G(ADIV) D GETLST^XPAR(.ORCTM,ADIV_";DIC(4,^SYS","LR PHLEBOTOMY COLLECTION","Q") - E D GETLST^XPAR(.ORCTM,"ALL","LR PHLEBOTOMY COLLECTION","Q") - ;S DUZ(2)=TMPDIV - S LST($$NXT)="iLNEXT^Next scheduled lab collection" - S ICTM=0 F S ICTM=$O(ORCTM(ICTM)) Q:'ICTM D - . I $P(ORCTM(ICTM),U)>$P($H,",",2) D - . . S TXDT=TDAY("TX") - . . I +TDAY("H")=+$H S DAY="Today" - . . I TDAY("H")-$H=1 S DAY="Tomorrow" - . . I TDAY("H")-$H>1 S DAY=$$DOWNAME(TDAY("DOW")) - . E D - . . S TXDT=TMRW("TX") - . . S DAY=$S(TMRW("H")-$H>1:$$DOWNAME(TMRW("DOW")),1:"Tomorrow") - . S AMPM=$S($P(ORCTM(ICTM),U,2)>1159:"PM",1:"AM") - . S TXDT=TXDT_"@"_$P(ORCTM(ICTM),"^",2) - . S TIME=$P(ORCTM(ICTM),U,2),TIME=$E(TIME,1,2)_":"_$E(TIME,3,4) - . S LST($$NXT)="iL"_TXDT_U_AMPM_" Collection: "_TIME_" ("_DAY_")" - . S ^TMP($J,"WC",ILST)="iW"_TXDT_U_TIME_" "_AMPM_" ("_DAY_") Ward collect" ;DBIA 2263 - ; D NOW^%DTC - ;S LST($$NXT)="iWNOW^Now (Collect on ward)" - S LST($$NXT)="iLO^Future" - Q -WCOLLTM ; get Ward Collect times - S I="" - F S I=$O(^TMP($J,"WC",I)) Q:I="" D - . S LST($$NXT)=^TMP($J,"WC",I) - S LST($$NXT)="iWNOW^Now (Collect on ward)" - ;S LST($$NXT)="iWO^Other" - K ^TMP($J,"WC") - Q -SENDTM ; get send patient times - ;N X,X1,X2 - S LST($$NXT)="iLT^Today" - ;S X1=DT,X2=1 D C^%DTC - S LST($$NXT)="iLT+1^Tomorrow" - ;S LST($$NXT)="iLO^Other" - Q -COLLTYP ; Collection Types in effect for this division - N Y S Y="" - S LST($$NXT)="iLC^Lab Collect" - S LST($$NXT)="iWC^Ward Collect" - S LST($$NXT)="iSP^Send Patient to Lab" - I +$$ON^LR7OV4(DUZ(2)) S LST($$NXT)="iI^Immediate Collect" - S:$G(ALOC) Y=$$GET^XPAR("ALL^"_ALOC_";SC(","LR DEFAULT TYPE QUICK") - I $L(Y) S LST($$NXT)="d"_Y - Q -INCDATE(ADATE) ; called from COLLTM, increments date nodes in .ADATE - N X,X1,X2,%H - S X1=ADATE,X2=1 D C^%DTC S ADATE=X - S ADATE("H")=ADATE("H")+1 - S ADATE("DOW")=ADATE("H")#7 - S ADATE("TX")="T+"_($P(ADATE("TX"),"+",2)+1) - Q -DOWNAME(DOW) ; function - ; Returns Day of Week name (DOW should be $H#7) - I DOW=0 Q "Thursday" - I DOW=1 Q "Friday" - I DOW=2 Q "Saturday" - I DOW=3 Q "Sunday" - I DOW=4 Q "Monday" - I DOW=5 Q "Tuesday" - I DOW=6 Q "Wednesday" - Q "" -URGENCY ; return default urgency for lab - N URG - S URG=$$DEFURG^LR7OR3 - S LST($$NXT)="i"_URG_U_$P(^LAB(62.05,URG,0),U,1) - S LST($$NXT)="d"_URG_U_$P(^LAB(62.05,URG,0),U,1) - Q -SCHED ; return list of schedules available for lab tests - N X,X0,IEN,TYPE,FREQ - K ^TMP($J,"ORWDLR32 APLR") - D AP^PSS51P1("LR",,,,"ORWDLR32 APLR") - S X="" F S X=$O(^TMP($J,"ORWDLR32 APLR","APLR",X)) Q:X="" D - .S IEN=$O(^TMP($J,"ORWDLR32 APLR","APLR",X,"")) I IEN'>0 Q - .S TYPE=$P($G(^TMP($J,"ORWDLR32 APLR",IEN,5)),U) - .S FREQ=+$G(^TMP($J,"ORWDLR32 APLR",IEN,2)) - .I ((TYPE="C")!(TYPE="D")),FREQ=0 Q - .S LST($$NXT)="i"_IEN_U_X_U_TYPE_U_FREQ - .I X="ONE TIME" S LST($$NXT)="d"_IEN_U_X - K ^TMP($J,"ORWDLR32 APLR") - Q -COMMON ; return list of commonly ordered lab tests - N ORLST,IEN,I - D GETLST^XPAR(.ORLST,"ALL","ORWD COMMON LAB INPT") ;DBIA 2263 - S I=0 F S I=$O(ORLST(I)) Q:'I D - . S IEN=$P(ORLST(I),U,2) - . S LST($$NXT)="i"_IEN_U_$P(^ORD(101.43,IEN,0),U,1) - Q -LOAD(LST,TESTID) ; procedure - ; Return sample, specimen, & urgency info about a lab test - N I,J,X,X1,X4,ORY,ORLABID,ILST,PARAM - S ILST=0,X=$P(^ORD(101.43,TESTID,0),"^"),ORLABID=$P(^(0),U,2) - S LST($$NXT)="~Test Name" - S LST($$NXT)="d"_X - S LST($$NXT)="~Item ID" - S LST($$NXT)="d"_+ORLABID - S X1=$S($P($P(^ORD(101.43,TESTID,0),U,2),";",2)="99VBC":$O(^LAB(60,"B",$P(^ORD(101.43,TESTID,0),"^")_" - LAB",0)),1:$P($P(^ORD(101.43,TESTID,0),U,2),";",1)) Q:'X1 - S X4=$P($G(^LAB(60,X1,0)),U,4) - S LST(ILST)=LST(ILST)_U_X4 - I $D(^ORD(101.43,TESTID,8))>1 S LST($$NXT)="~OIMessage" - S I=0 F S I=$O(^ORD(101.43,TESTID,8,I)) Q:'I S LST($$NXT)="t"_^(I,0) - S TESTID=+$P(^ORD(101.43,TESTID,0),U,2) - D TEST^LR7OR3(X1,.ORY) - S PARAM="" F S PARAM=$O(ORY(PARAM)) Q:PARAM="" D - . S LST($$NXT)="~"_PARAM - . I PARAM="ReqCom" D - . . S LST($$NXT)="d"_$G(ORY("ReqCom")) Q - . I PARAM="Default CollSamp" D - . . S LST($$NXT)="d"_$G(ORY("Default CollSamp")) Q - . I PARAM="Unique CollSamp" D - . . S LST($$NXT)="d"_$G(ORY("Unique CollSamp")) Q - . I PARAM="Default Urgency" D - . . S LST($$NXT)="d"_$G(ORY("Default Urgency")) Q - . I PARAM="Lab CollSamp" D - . . S LST($$NXT)="d"_$G(ORY("Lab CollSamp")) Q - . I $D(ORY(PARAM))>1 S I=0 F S I=$O(ORY(PARAM,I)) Q:'I D - . . I PARAM="Specimens" S LST($$NXT)="i"_ORY(PARAM,I) Q - . . I PARAM="Urgencies" S LST($$NXT)="i"_ORY(PARAM,I) Q - . . I PARAM="GenWardInstructions" S LST($$NXT)="t"_ORY(PARAM,I,0) Q - . . S LST($$NXT)="i"_I_U_ORY(PARAM,I) - . . I PARAM="CollSamp" D - . . . I $G(ORY("Lab CollSamp")) S $P(LST(ILST),U,8)=1 - . . . S X=+$P(ORY(PARAM,I),U,3) - . . . I X S $P(LST(ILST),U,10)=$P($G(^LAB(61,X,0)),U,1) - . . I $D(ORY(PARAM,I,"WP")) S J=0 F S J=$O(ORY(PARAM,I,"WP",J)) Q:'J D - . . . S LST($$NXT)="t"_ORY(PARAM,I,"WP",J,0) - Q -ALLSAMP(LST) ; procedure - ; returns all collection samples - ; n^SampIEN^SampName^SpecPtr^TubeTop^^^LabCollect^^SpecName - N SMP,SPC,ILST,IEN,X,X0 - S ILST=0,LST($$NXT)="~CollSamp" - S SMP="" F S SMP=$O(^LAB(62,"B",SMP)) Q:SMP="" D - . S IEN=0 F S IEN=$O(^LAB(62,"B",SMP,IEN)) Q:'IEN D - . . S X0=^LAB(62,IEN,0) - . . S X="i"_U_IEN_U_SMP_U_$P(X0,U,2)_U_$P(X0,U,3)_U_U_U_$P(X0,U,7) - . . I $P(X0,U,2) D - . . . S $P(X,U,10)=$P(^LAB(61,+$P(X0,U,2),0),U,1) - . . . S SPC($P(X,U,4))=$P(X,U,10) - . . S LST($$NXT)=X - S LST($$NXT)="~Specimens" - S SPC=0 F S SPC=$O(SPC(SPC)) Q:'SPC S LST($$NXT)=SPC_U_SPC(SPC) - Q -ONESAMP(LST,IEN) ;Return data for one colelction sample - ; n^SampIEN^SampName^SpecPtr^TubeTop^^^LabCollect^^SpecName - N SPC,ILST,X,X0 - Q:+$G(IEN)=0 - S ILST=0,LST($$NXT)="~CollSamp" - S X0=^LAB(62,IEN,0) - S X="i1"_U_IEN_U_$P(X0,U,1)_U_$P(X0,U,2)_U_$P(X0,U,3)_U_U_U_$P(X0,U,7) - I $P(X0,U,2) D - . S $P(X,U,10)=$P(^LAB(61,+$P(X0,U,2),0),U,1) - . S SPC($P(X,U,4))=$P(X,U,10) - S LST($$NXT)=X - S LST($$NXT)="~Specimens" - S SPC=0 F S SPC=$O(SPC(SPC)) Q:'SPC S LST($$NXT)=SPC_U_SPC(SPC) - Q -ONESPEC(LST,IEN) ;return one specimen - Q:(+$G(IEN)=0)!('$D(^LAB(61,IEN,0))) - S LST=IEN_U_$P(^LAB(61,IEN,0),U,1) - Q -ABBSPEC(LST) ; procedure - ; returns specimens with abbreviation (uses 'E' xref) - N X,IEN,ILST S ILST=0 - S X="" F S X=$O(^LAB(61,"E",X)) Q:X="" S IEN=$O(^(X,0)) D - . S LST($$NXT)=IEN_U_$P(^LAB(61,IEN,0),U,1) - Q -NXT() ; called by TESTINFO, increments ILST - S ILST=ILST+1 - Q ILST - ; +ORWDLR32 ; SLC/KCM/REV/JDL - Lab Calls 6/28/2002 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,141,215,250**;Dec 17, 1997;Build 1 + ; + ; DBIA 2263 GETLST^XPAR ^TMP($J,"WC") + ; +DEF(LST,ALOC,ADIV) ; procedure + ; For Event Delay Order + ; ALOC: Delay Event's default location + ; ADIV: Delay Event's default division + ; get dialog definition specific to lab + S ILST=0 + S LST($$NXT)="~ShortList" D SHORT + S LST($$NXT)="~Lab Collection Times" D LCOLLTM + S LST($$NXT)="~Ward Collection Times" D WCOLLTM + S LST($$NXT)="~Send Patient Times" D SENDTM + S LST($$NXT)="~Collection Types" D COLLTYP + S LST($$NXT)="~Default Urgency" D URGENCY + S LST($$NXT)="~Schedules" D SCHED + S LST($$NXT)="~Common" D COMMON + Q +SHORT ; from DEF, get short list of lab quick orders + N I,ORTMP,ORDG,A + S I=$O(^ORD(100.98,"B","LAB",0)) ; get IEN of parent lab + D DG^ORCHANG1(I,"BILD",.ORDG) ; find members groups for parent lab + S I=0 + F S I=$O(ORDG(I)) Q:'I D ; loop through list of members groups + . D GETQLST^ORWDXQ(.ORTMP,I,"Q") ;get quick order of each members groups + . S A=0 F S A=$O(ORTMP(A)) Q:'A D ; loop through returned quick orders and + . . S LST($$NXT)="i"_ORTMP(A) ; move quick orders to display list + . K ORTMP ; clean up for next members groups of quick orders + Q +LCOLLTM ; get collection times + N TDAY,TMRW,IGNOR,CNT,ICTM,ORCTM,DOW,AMPM,DAY,TIME,TXDT + S TDAY=DT,TDAY("DOW")=$H#7,TDAY("H")=$H,TDAY("TX")="T" + M TMRW=TDAY D INCDATE(.TMRW) + I $G(ALOC),'$$GET^XPAR(ALOC_";SC(","LR EXCEPTED LOCATIONS",1,"Q") D + . S IGNOR=$$GET^XPAR("ALL","LR IGNORE HOLIDAYS",1,"Q") + . S DOW(0)=$$GET^XPAR("ALL","LR COLLECT THURSDAY",1,"Q") + . S DOW(1)=$$GET^XPAR("ALL","LR COLLECT FRIDAY",1,"Q") + . S DOW(2)=$$GET^XPAR("ALL","LR COLLECT SATURDAY",1,"Q") + . S DOW(3)=$$GET^XPAR("ALL","LR COLLECT SUNDAY",1,"Q") + . S DOW(4)=$$GET^XPAR("ALL","LR COLLECT MONDAY",1,"Q") + . S DOW(5)=$$GET^XPAR("ALL","LR COLLECT TUESDAY",1,"Q") + . S DOW(6)=$$GET^XPAR("ALL","LR COLLECT WEDNESDAY",1,"Q") + . S CNT=0 F Q:(DOW(TDAY("DOW"))=1)&((IGNOR=1)!('$D(^HOLIDAY(TDAY,0)))) D Q:CNT>6 + . . D INCDATE(.TDAY) S CNT=CNT+1 + . S CNT=0 F Q:(DOW(TMRW("DOW"))=1)&((IGNOR=1)!('$D(^HOLIDAY(TMRW,0)))) D Q:CNT>6 + . . D INCDATE(.TMRW) S CNT=CNT+1 + I $G(ADIV) D GETLST^XPAR(.ORCTM,ADIV_";DIC(4,^SYS","LR PHLEBOTOMY COLLECTION","Q") + E D GETLST^XPAR(.ORCTM,"ALL","LR PHLEBOTOMY COLLECTION","Q") + ;S DUZ(2)=TMPDIV + S LST($$NXT)="iLNEXT^Next scheduled lab collection" + S ICTM=0 F S ICTM=$O(ORCTM(ICTM)) Q:'ICTM D + . I $P(ORCTM(ICTM),U)>$P($H,",",2) D + . . S TXDT=TDAY("TX") + . . I +TDAY("H")=+$H S DAY="Today" + . . I TDAY("H")-$H=1 S DAY="Tomorrow" + . . I TDAY("H")-$H>1 S DAY=$$DOWNAME(TDAY("DOW")) + . E D + . . S TXDT=TMRW("TX") + . . S DAY=$S(TMRW("H")-$H>1:$$DOWNAME(TMRW("DOW")),1:"Tomorrow") + . S AMPM=$S($P(ORCTM(ICTM),U,2)>1159:"PM",1:"AM") + . S TXDT=TXDT_"@"_$P(ORCTM(ICTM),"^",2) + . S TIME=$P(ORCTM(ICTM),U,2),TIME=$E(TIME,1,2)_":"_$E(TIME,3,4) + . S LST($$NXT)="iL"_TXDT_U_AMPM_" Collection: "_TIME_" ("_DAY_")" + . S ^TMP($J,"WC",ILST)="iW"_TXDT_U_TIME_" "_AMPM_" ("_DAY_") Ward collect" ;DBIA 2263 + ; D NOW^%DTC + ;S LST($$NXT)="iWNOW^Now (Collect on ward)" + S LST($$NXT)="iLO^Future" + Q +WCOLLTM ; get Ward Collect times + S I="" + F S I=$O(^TMP($J,"WC",I)) Q:I="" D + . S LST($$NXT)=^TMP($J,"WC",I) + S LST($$NXT)="iWNOW^Now (Collect on ward)" + ;S LST($$NXT)="iWO^Other" + K ^TMP($J,"WC") + Q +SENDTM ; get send patient times + ;N X,X1,X2 + S LST($$NXT)="iLT^Today" + ;S X1=DT,X2=1 D C^%DTC + S LST($$NXT)="iLT+1^Tomorrow" + ;S LST($$NXT)="iLO^Other" + Q +COLLTYP ; Collection Types in effect for this division + N Y S Y="" + S LST($$NXT)="iLC^Lab Collect" + S LST($$NXT)="iWC^Ward Collect" + S LST($$NXT)="iSP^Send Patient to Lab" + I +$$ON^LR7OV4(DUZ(2)) S LST($$NXT)="iI^Immediate Collect" + S:$G(ALOC) Y=$$GET^XPAR("ALL^"_ALOC_";SC(","LR DEFAULT TYPE QUICK") + I $L(Y) S LST($$NXT)="d"_Y + Q +INCDATE(ADATE) ; called from COLLTM, increments date nodes in .ADATE + N X,X1,X2,%H + S X1=ADATE,X2=1 D C^%DTC S ADATE=X + S ADATE("H")=ADATE("H")+1 + S ADATE("DOW")=ADATE("H")#7 + S ADATE("TX")="T+"_($P(ADATE("TX"),"+",2)+1) + Q +DOWNAME(DOW) ; function + ; Returns Day of Week name (DOW should be $H#7) + I DOW=0 Q "Thursday" + I DOW=1 Q "Friday" + I DOW=2 Q "Saturday" + I DOW=3 Q "Sunday" + I DOW=4 Q "Monday" + I DOW=5 Q "Tuesday" + I DOW=6 Q "Wednesday" + Q "" +URGENCY ; return default urgency for lab + N URG + S URG=$$DEFURG^LR7OR3 + S LST($$NXT)="i"_URG_U_$P(^LAB(62.05,URG,0),U,1) + S LST($$NXT)="d"_URG_U_$P(^LAB(62.05,URG,0),U,1) + Q +SCHED ; return list of schedules available for lab tests + N X,X0,IEN + S X="" F S X=$O(^PS(51.1,"APLR",X)) Q:X="" S IEN=$O(^(X,0)) I IEN D + . S X0=$G(^PS(51.1,IEN,0)) Q:X0="" + . I (($P(X0,U,5)="C")!($P(X0,U,5)="D")),(+$P(X0,U,3)=0) Q + . S LST($$NXT)="i"_IEN_U_X_U_$P(X0,U,5)_U_$P(X0,U,3) + . I X="ONE TIME" S LST($$NXT)="d"_IEN_U_X + Q +COMMON ; return list of commonly ordered lab tests + N ORLST,IEN,I + D GETLST^XPAR(.ORLST,"ALL","ORWD COMMON LAB INPT") ;DBIA 2263 + S I=0 F S I=$O(ORLST(I)) Q:'I D + . S IEN=$P(ORLST(I),U,2) + . S LST($$NXT)="i"_IEN_U_$P(^ORD(101.43,IEN,0),U,1) + Q +LOAD(LST,TESTID) ; procedure + ; Return sample, specimen, & urgency info about a lab test + N I,J,X,X1,X4,ORY,ORLABID,ILST,PARAM + S ILST=0 + S LST($$NXT)="~Test Name" + S LST($$NXT)="d"_$P(^ORD(101.43,TESTID,0),U,1),ORLABID=$P(^(0),U,2) + S LST($$NXT)="~Item ID" + S LST($$NXT)="d"_+ORLABID + S X=$P(ORLABID,";",1),X1=$P(ORLABID,";",2) + I $E(X1,1,4)="99VB" S X1=$O(^LAB(60,"B","VBECS "_$P(^ORD(101.43,TESTID,0),"^"),0)) Q:'X1 S X=X1 + S X4=$P($G(^LAB(60,X,0)),U,4) + S LST(ILST)=LST(ILST)_U_X4 + I $D(^ORD(101.43,TESTID,8))>1 S LST($$NXT)="~OIMessage" + S I=0 F S I=$O(^ORD(101.43,TESTID,8,I)) Q:'I S LST($$NXT)="t"_^(I,0) + S TESTID=+$P(^ORD(101.43,TESTID,0),U,2) + D TEST^LR7OR3(TESTID,.ORY) + S PARAM="" F S PARAM=$O(ORY(PARAM)) Q:PARAM="" D + . S LST($$NXT)="~"_PARAM + . I PARAM="ReqCom" D + . . S LST($$NXT)="d"_$G(ORY("ReqCom")) Q + . I PARAM="Default CollSamp" D + . . S LST($$NXT)="d"_$G(ORY("Default CollSamp")) Q + . I PARAM="Unique CollSamp" D + . . S LST($$NXT)="d"_$G(ORY("Unique CollSamp")) Q + . I PARAM="Default Urgency" D + . . S LST($$NXT)="d"_$G(ORY("Default Urgency")) Q + . I PARAM="Lab CollSamp" D + . . S LST($$NXT)="d"_$G(ORY("Lab CollSamp")) Q + . I $D(ORY(PARAM))>1 S I=0 F S I=$O(ORY(PARAM,I)) Q:'I D + . . I PARAM="Specimens" S LST($$NXT)="i"_ORY(PARAM,I) Q + . . I PARAM="Urgencies" S LST($$NXT)="i"_ORY(PARAM,I) Q + . . I PARAM="GenWardInstructions" S LST($$NXT)="t"_ORY(PARAM,I,0) Q + . . S LST($$NXT)="i"_I_U_ORY(PARAM,I) + . . I PARAM="CollSamp" D + . . . I $G(ORY("Lab CollSamp")) S $P(LST(ILST),U,8)=1 + . . . S X=+$P(ORY(PARAM,I),U,3) + . . . I X S $P(LST(ILST),U,10)=$P($G(^LAB(61,X,0)),U,1) + . . I $D(ORY(PARAM,I,"WP")) S J=0 F S J=$O(ORY(PARAM,I,"WP",J)) Q:'J D + . . . S LST($$NXT)="t"_ORY(PARAM,I,"WP",J,0) + Q +ALLSAMP(LST) ; procedure + ; returns all collection samples + ; n^SampIEN^SampName^SpecPtr^TubeTop^^^LabCollect^^SpecName + N SMP,SPC,ILST,IEN,X,X0 + S ILST=0,LST($$NXT)="~CollSamp" + S SMP="" F S SMP=$O(^LAB(62,"B",SMP)) Q:SMP="" D + . S IEN=0 F S IEN=$O(^LAB(62,"B",SMP,IEN)) Q:'IEN D + . . S X0=^LAB(62,IEN,0) + . . S X="i"_U_IEN_U_SMP_U_$P(X0,U,2)_U_$P(X0,U,3)_U_U_U_$P(X0,U,7) + . . I $P(X0,U,2) D + . . . S $P(X,U,10)=$P(^LAB(61,+$P(X0,U,2),0),U,1) + . . . S SPC($P(X,U,4))=$P(X,U,10) + . . S LST($$NXT)=X + S LST($$NXT)="~Specimens" + S SPC=0 F S SPC=$O(SPC(SPC)) Q:'SPC S LST($$NXT)=SPC_U_SPC(SPC) + Q +ONESAMP(LST,IEN) ;Return data for one colelction sample + ; n^SampIEN^SampName^SpecPtr^TubeTop^^^LabCollect^^SpecName + N SPC,ILST,X,X0 + Q:+$G(IEN)=0 + S ILST=0,LST($$NXT)="~CollSamp" + S X0=^LAB(62,IEN,0) + S X="i1"_U_IEN_U_$P(X0,U,1)_U_$P(X0,U,2)_U_$P(X0,U,3)_U_U_U_$P(X0,U,7) + I $P(X0,U,2) D + . S $P(X,U,10)=$P(^LAB(61,+$P(X0,U,2),0),U,1) + . S SPC($P(X,U,4))=$P(X,U,10) + S LST($$NXT)=X + S LST($$NXT)="~Specimens" + S SPC=0 F S SPC=$O(SPC(SPC)) Q:'SPC S LST($$NXT)=SPC_U_SPC(SPC) + Q +ONESPEC(LST,IEN) ;return one specimen + Q:(+$G(IEN)=0)!('$D(^LAB(61,IEN,0))) + S LST=IEN_U_$P(^LAB(61,IEN,0),U,1) + Q +ABBSPEC(LST) ; procedure + ; returns specimens with abbreviation (uses 'E' xref) + N X,IEN,ILST S ILST=0 + S X="" F S X=$O(^LAB(61,"E",X)) Q:X="" S IEN=$O(^(X,0)) D + . S LST($$NXT)=IEN_U_$P(^LAB(61,IEN,0),U,1) + Q +NXT() ; called by TESTINFO, increments ILST + S ILST=ILST+1 + Q ILST + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDLR33.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDLR33.m index e98c36e3..7e441dbe 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDLR33.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDLR33.m @@ -1,93 +1,84 @@ -ORWDLR33 ; SLC/KCM/REV/JDL - Lab Calls ; 7/1/2002 11AM - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,141,243**;Dec 17, 1997;Build 242 - ; -STOP(VAL,X2) ; return a calculated stop date - N X1,X - S X1=DT D C^%DTC S VAL=X - Q -MAXDAYS(Y,LOC,SCHED) ; Return max number of days for a continuing order - N TMP1,TMP2 - K ^TMP($J,"ORWDLR33 MAXDAYS") - S TMP1=$$GET^XPAR("ALL^LOC.`"_+LOC,"LR MAX DAYS CONTINUOUS",1,"Q") - I +TMP1=0 S Y="-1" Q - I +$G(SCHED)>0 D ZERO^PSS51P1(SCHED,,,,"ORWDLR33 MAXDAYS") S TMP2=$G(^TMP($J,"ORWDLR33 MAXDAYS",SCHED,2.5)) K ^TMP($J,"ORWDLR33 MAXDAYS") - E S TMP2=0 - I +TMP1=0,+TMP2>0 S Y=TMP2 Q - I +TMP2=0,+TMP1>0 S Y=TMP1 Q - S Y=$S(+TMP1>+TMP2:+TMP2,+TMP2>+TMP1:+TMP1,+TMP1=+TMP2:+TMP1,1:0) - K ^TMP($J,"ORWDLR33 MAXDAYS") - Q -ALLSPEC(Y,FROM,DIR) ; Return a set of specimens from topography file - N I,IEN,CNT S I=0,CNT=44 - F Q:I'3 S ORTI=ORTI_"0" - S X=ORDA D DW^%DTC S ORDOW=X - D GETLST^XPAR(.ORCTM,"ALL","LR PHLEBOTOMY COLLECTION","Q") - S I=0 F S I=$O(ORCTM(I)) Q:'I D - . S:$P(ORCTM(I),U,2)=ORTI ORYN=1 - Q:ORYN=0 - I $G(ORLOC),$$GET^XPAR(ORLOC_";SC(","LR EXCEPTED LOCATIONS",1,"Q") S ORYN=1 Q - I '$$GET^XPAR("ALL","LR IGNORE HOLIDAYS",1,"Q"),$D(^HOLIDAY(ORDA,0)) S ORYN=0 Q - I $$GET^XPAR("ALL","LR COLLECT "_ORDOW,1,"Q") S ORYN=1 Q - S ORYN=0 - Q -IMMCOLL(ORY) ; Return help screen showing immediate collect times - D SHOW^LR7OV4(DUZ(2),.ORY) - Q -ICDEFLT(ORY) ;Return default immediate collect time - S ORY=$$DEFTIME^LR7OV4(DUZ(2)) - Q -ICVALID(ORY,ORTIME) ;Is the time a valid immediate collect time? - S ORTIME=$P(ORTIME,".",1)_"."_$E($P(ORTIME,".",2),1,4) - S ORY=$$VALID^LR7OV4(DUZ(2),ORTIME) - Q -GETLABTM(ORY,ORDATE,ORLOC) ;Return list of lab collect times for a date and location - N ORDA,ORTI,ORNOW,ORDOW,ORCTM,ORTI,X,%,%H - S ORY(0)=0 Q:'$G(ORDATE)!($G(ORDATE)<0)!('$G(ORLOC)) - S ORDA=$P(ORDATE,".",1) - S ORNOW=$$NOW^XLFDT,ORTI=$P(ORNOW,".",2) - I ORDA<$P(ORNOW,".",1) S ORY(0)="-1^Dates in the past are not allowed." Q - I '+$$GET^XPAR(ORLOC_";SC(","LR EXCEPTED LOCATIONS",1,"Q") D - . S X=ORDA D DW^%DTC S ORDOW=X - . I '+$$GET^XPAR("ALL","LR COLLECT "_ORDOW,1,"Q") S ORY(0)="-1^No collections on "_ORDOW Q - . I '+$$GET^XPAR("ALL","LR IGNORE HOLIDAYS",1,"Q"),$D(^HOLIDAY(ORDA,0)) S ORY(0)="-1^No holiday collections" Q - I +ORY(0)>-1 D - . D GETLST^XPAR(.ORY,"ALL","LR PHLEBOTOMY COLLECTION","Q") - . I +$G(ORY)=0 S ORY(0)="-1^No lab collect times defined for this division" Q - S I=0 F S I=$O(ORY(I)) Q:'I D - . D NOW^%DTC S ORTI=%,%H=+%H_","_+ORY(I) D YMD^%DTC - . I (ORDA=$P(ORTI,".",1)),(+(ORDA+%)<+ORTI) K ORY(I) S ORY=ORY-1 Q ; cutoff time has passed for this collect time - . S ORY(I)=$P(ORY(I),U,2) - I +$G(ORY)=0,('$D(ORY(0))) S ORY(0)="-1^All of today's collection times have passed." - Q -LCFUTR(ORDY,ORLOC,ORDIV) ;Get # of days for future Lab Collects - ; For Event Delay Order - ; --ORLOC Event default location - ; --ORDIV Event default division - S ORDY=0 - Q:'$D(^XTV(8989.51,"B","LR LAB COLLECT FUTURE")) - I $G(ORDIV) S ORDY=+$$GET^XPAR(+$G(ORLOC)_";SC("_"^"_+$G(ORDIV)_";DIC(4,^SYS^PKG","LR LAB COLLECT FUTURE",1,"I") - E S ORDY=+$$GET^XPAR(+$G(ORLOC)_";SC("_"^DIV^SYS^PKG","LR LAB COLLECT FUTURE",1,"I") - ;S DUZ(2)=TMPDIV - Q -LASTTIME(ORY) ; Get last collection time used from ^TMP("ORECALL",$J) array - N ORDIALOG,ORTYPE,ORTIME - S ORDIALOG=$O(^ORD(101.41,"B","LR OTHER LAB TESTS",0)) - S ORTYPE=$O(^ORD(101.41,"B","OR GTX COLLECTION TYPE",0)) - S ORTIME=$O(^ORD(101.41,"B","OR GTX START DATE/TIME",0)) - S ORY=$$RECALL^ORCD(ORTYPE,1)_U_$$RECALL^ORCD(ORTIME,1) - Q -LCTOWC(ORTXT,ORLOC) ; return text instructing user when LC changed to WC on accept/release - N ORDIV,ORSVC - S ORDIV=DUZ(2) - S ORSVC=+$G(^VA(200,DUZ,5)) - I ORSVC S ORTXT=$$GET^XPAR(+$G(ORLOC)_";SC("_"^"_+$G(ORSVC)_";DIC(49,^"_+$G(ORDIV)_";DIC(4,^SYS^PKG","ORWLR LC CHANGED TO WC",1,"I") - E S ORTXT=$$GET^XPAR(+$G(ORLOC)_";SC("_"^SVC^"_+$G(ORDIV)_";DIC(4,^SYS^PKG","ORWLR LC CHANGED TO WC",1,"I") - Q +ORWDLR33 ; SLC/KCM/REV/JDL - Lab Calls ; 7/1/2002 11AM + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,141**;Dec 17, 1997 + ; +STOP(VAL,X2) ; return a calculated stop date + N X1,X + S X1=DT D C^%DTC S VAL=X + Q +MAXDAYS(Y,LOC,SCHED) ; Return max number of days for a continuing order + N TMP1,TMP2 + S TMP1=$$GET^XPAR("ALL^LOC.`"_+LOC,"LR MAX DAYS CONTINUOUS",1,"Q") + I +TMP1=0 S Y="-1" Q + I +$G(SCHED)>0 S TMP2=$P($G(^PS(51.1,SCHED,0)),U,7) + E S TMP2=0 + I +TMP1=0,+TMP2>0 S Y=TMP2 Q + I +TMP2=0,+TMP1>0 S Y=TMP1 Q + S Y=$S(+TMP1>+TMP2:+TMP2,+TMP2>+TMP1:+TMP1,+TMP1=+TMP2:+TMP1,1:0) + Q +ALLSPEC(Y,FROM,DIR) ; Return a set of specimens from topography file + N I,IEN,CNT S I=0,CNT=44 + F Q:I'3 S ORTI=ORTI_"0" + S X=ORDA D DW^%DTC S ORDOW=X + D GETLST^XPAR(.ORCTM,"ALL","LR PHLEBOTOMY COLLECTION","Q") + S I=0 F S I=$O(ORCTM(I)) Q:'I D + . S:$P(ORCTM(I),U,2)=ORTI ORYN=1 + Q:ORYN=0 + I $G(ORLOC),$$GET^XPAR(ORLOC_";SC(","LR EXCEPTED LOCATIONS",1,"Q") S ORYN=1 Q + I '$$GET^XPAR("ALL","LR IGNORE HOLIDAYS",1,"Q"),$D(^HOLIDAY(ORDA,0)) S ORYN=0 Q + I $$GET^XPAR("ALL","LR COLLECT "_ORDOW,1,"Q") S ORYN=1 Q + S ORYN=0 + Q +IMMCOLL(ORY) ; Return help screen showing immediate collect times + D SHOW^LR7OV4(DUZ(2),.ORY) + Q +ICDEFLT(ORY) ;Return default immediate collect time + S ORY=$$DEFTIME^LR7OV4(DUZ(2)) + Q +ICVALID(ORY,ORTIME) ;Is the time a valid immediate collect time? + S ORTIME=$P(ORTIME,".",1)_"."_$E($P(ORTIME,".",2),1,4) + S ORY=$$VALID^LR7OV4(DUZ(2),ORTIME) + Q +GETLABTM(ORY,ORDATE,ORLOC) ;Return list of lab collect times for a date and location + N ORDA,ORTI,ORNOW,ORDOW,ORCTM,ORTI,X,%,%H + S ORY(0)=0 Q:'$G(ORDATE)!($G(ORDATE)<0)!('$G(ORLOC)) + S ORDA=$P(ORDATE,".",1) + S ORNOW=$$NOW^XLFDT,ORTI=$P(ORNOW,".",2) + I ORDA<$P(ORNOW,".",1) S ORY(0)="-1^Dates in the past are not allowed." Q + I '+$$GET^XPAR(ORLOC_";SC(","LR EXCEPTED LOCATIONS",1,"Q") D + . S X=ORDA D DW^%DTC S ORDOW=X + . I '+$$GET^XPAR("ALL","LR COLLECT "_ORDOW,1,"Q") S ORY(0)="-1^No collections on "_ORDOW Q + . I '+$$GET^XPAR("ALL","LR IGNORE HOLIDAYS",1,"Q"),$D(^HOLIDAY(ORDA,0)) S ORY(0)="-1^No holiday collections" Q + I +ORY(0)>-1 D + . D GETLST^XPAR(.ORY,"ALL","LR PHLEBOTOMY COLLECTION","Q") + . I +$G(ORY)=0 S ORY(0)="-1^No lab collect times defined for this division" Q + S I=0 F S I=$O(ORY(I)) Q:'I D + . D NOW^%DTC S ORTI=%,%H=+%H_","_+ORY(I) D YMD^%DTC + . I (ORDA=$P(ORTI,".",1)),(+(ORDA+%)<+ORTI) K ORY(I) S ORY=ORY-1 Q ; cutoff time has passed for this collect time + . S ORY(I)=$P(ORY(I),U,2) + I +$G(ORY)=0,('$D(ORY(0))) S ORY(0)="-1^All of today's collection times have passed." + Q +LCFUTR(ORDY,ORLOC,ORDIV) ;Get # of days for future Lab Collects + ; For Event Delay Order + ; --ORLOC Event default location + ; --ORDIV Event default division + S ORDY=0 + Q:'$D(^XTV(8989.51,"B","LR LAB COLLECT FUTURE")) + I $G(ORDIV) S ORDY=+$$GET^XPAR(+$G(ORLOC)_";SC("_"^"_+$G(ORDIV)_";DIC(4,^SYS^PKG","LR LAB COLLECT FUTURE",1,"I") + E S ORDY=+$$GET^XPAR(+$G(ORLOC)_";SC("_"^DIV^SYS^PKG","LR LAB COLLECT FUTURE",1,"I") + ;S DUZ(2)=TMPDIV + Q +LASTTIME(ORY) ; Get last collection time used from ^TMP("ORECALL",$J) array + N ORDIALOG,ORTYPE,ORTIME + S ORDIALOG=$O(^ORD(101.41,"B","LR OTHER LAB TESTS",0)) + S ORTYPE=$O(^ORD(101.41,"B","OR GTX COLLECTION TYPE",0)) + S ORTIME=$O(^ORD(101.41,"B","OR GTX START DATE/TIME",0)) + S ORY=$$RECALL^ORCD(ORTYPE,1)_U_$$RECALL^ORCD(ORTIME,1) + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDOR.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDOR.m index d9efdd4c..cd8e5477 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDOR.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDOR.m @@ -1,66 +1,63 @@ -ORWDOR ; SLC/KCM - Generic Orders calls for Windows Dialogs [ 08/05/96 8:21 AM ];03:50 PM 17 Jun 1998 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,164,253,243**;Dec 17, 1997;Build 242 -NXT() ; -- returns next available index in return data array - S ILST=ILST+1 - Q ILST - ; -VMSLCT(LST) ; return default lists for vitals dialog - N ILST S ILST=0 - S LST($$NXT)="~Measurements" D MEAS - S LST($$NXT)="~Schedules" D SCHED - Q -MEAS ; called from VMSLCT - N I,X - S X="" F S X=$O(^ORD(101.43,"S.V/M",X)) Q:X="" D - . S I=$O(^ORD(101.43,"S.V/M",X,0)) - . S LST($$NXT)="i"_I_U_$P(^ORD(101.43,"S.V/M",X,I),U,2) - Q -SCHED ; called from VMSLCT - N X,I - K ^TMP($J,"ORWDGX APGMRV") - D AP^PSS51P1("GMRV",,,,"ORWDGX APGMRV") - S X="" F S X=$O(^TMP($J,"ORWDGX APGMRV","APGMRV",X)) Q:X="" D - . S I=$O(^TMP($J,"ORWDGX APGMRV","APGMRV",X,0)),LST($$NXT)="i"_I_U_X - K ^TMP($J,"ORWDGX APGMRV") - Q -VALNUM(ERR,X,DOM) ; return error if invalid number - N LOW,HIGH,DEC - S LOW=$P(DOM,":"),HIGH=$P(DOM,":",2),DEC=$P(DOM,":",3),ERR=0 - I $L($P(X,"."))>24 S ERR="1^Exceeded maximum number of 24 characters" Q - I X'?.1"-".N.1".".N S ERR="1^Entry must be numeric" Q - I X>HIGH!(XDEC D - . I DEC=0 S ERR="1^No decimal places allowed" - . E I DEC=1 S ERR="1^Only one decimal place allowed" - . E S ERR="1^No more than "_DEC_" decimal places allowed" - Q -LKSCRN(ORLST,FROM,DIR,REF,GBL,SCR) ; Return a set of entries from xref in REF - ; .Y=returned list, FROM=text to $O from, DIR=$O direction, - ; REF=subscript indirection global ref including xref, - ; GBL=standard FM global ref, SCR=reference to screen in 101.41 - N I,IEN,CNT,X,Y,D,ORTYPE - S I=0,CNT=44,SCR=$G(SCR) - I $L(SCR) S SCR=$G(^ORD(101.41,+SCR,10,+$P(SCR,":",2),4)) - S D=$P(REF,"""",2),ORTYPE="D" ;for OI screen - F Q:I'1 D - . . . S LST(ILST)=LST(ILST)_"^+" - . . . D LSTCHLD(CHILD) - Q +ORWDOR ; SLC/KCM - Generic Orders calls for Windows Dialogs [ 08/05/96 8:21 AM ];03:50 PM 17 Jun 1998 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,164,253**;Dec 17, 1997 +NXT() ; -- returns next available index in return data array + S ILST=ILST+1 + Q ILST + ; +VMSLCT(LST) ; return default lists for vitals dialog + N ILST S ILST=0 + S LST($$NXT)="~Measurements" D MEAS + S LST($$NXT)="~Schedules" D SCHED + Q +MEAS ; called from VMSLCT + N I,X + S X="" F S X=$O(^ORD(101.43,"S.V/M",X)) Q:X="" D + . S I=$O(^ORD(101.43,"S.V/M",X,0)) + . S LST($$NXT)="i"_I_U_$P(^ORD(101.43,"S.V/M",X,I),U,2) + Q +SCHED ; called from VMSLCT + N I,X + S X="" F S X=$O(^PS(51.1,"APGMRV",X)) Q:X="" D + . S I=$O(^PS(51.1,"APGMRV",X,0)),LST($$NXT)="i"_I_U_X + Q +VALNUM(ERR,X,DOM) ; return error if invalid number + N LOW,HIGH,DEC + S LOW=$P(DOM,":"),HIGH=$P(DOM,":",2),DEC=$P(DOM,":",3),ERR=0 + I $L($P(X,"."))>24 S ERR="1^Exceeded maximum number of 24 characters" Q + I X'?.1"-".N.1".".N S ERR="1^Entry must be numeric" Q + I X>HIGH!(XDEC D + . I DEC=0 S ERR="1^No decimal places allowed" + . E I DEC=1 S ERR="1^Only one decimal place allowed" + . E S ERR="1^No more than "_DEC_" decimal places allowed" + Q +LKSCRN(ORLST,FROM,DIR,REF,GBL,SCR) ; Return a set of entries from xref in REF + ; .Y=returned list, FROM=text to $O from, DIR=$O direction, + ; REF=subscript indirection global ref including xref, + ; GBL=standard FM global ref, SCR=reference to screen in 101.41 + N I,IEN,CNT,X,Y,D,ORTYPE + S I=0,CNT=44,SCR=$G(SCR) + I $L(SCR) S SCR=$G(^ORD(101.41,+SCR,10,+$P(SCR,":",2),4)) + S D=$P(REF,"""",2),ORTYPE="D" ;for OI screen + F Q:I'1 D + . . . S LST(ILST)=LST(ILST)_"^+" + . . . D LSTCHLD(CHILD) + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDPS1.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDPS1.m index 2286990e..81aad3ec 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDPS1.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDPS1.m @@ -1,202 +1,159 @@ -ORWDPS1 ; SLC/KCM/JLI - Pharmacy Calls for Windows Dialog; 03/10/2008 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,132,141,163,215,255,243**;Dec 17, 1997;Build 242 - ; -ODSLCT(LST,PSTYPE,DFN,LOC) ; return default lists for dialog - ; PSTYPE: pharmacy type (U=unit dose, F=IV fluids, O=outpatient) - N ILST S ILST=0 - S ILST=ILST+1,LST(ILST)="~Priority" D PRIOR - S ILST=ILST+1,LST(ILST)="~DispMsg" - S ILST=ILST+1,LST(ILST)="d"_$$DISPMSG - ; - ; I PSTYPE="F" D Q ; IV Fluids - ; . S ILST=ILST+1,LST(ILST)="~ShortList" D SHORT - ; - I PSTYPE="O" D ; Outpatient - . S ILST=ILST+1,LST(ILST)="~Refills" - . S ILST=ILST+1,LST(ILST)="d0^0" - . S ILST=ILST+1,LST(ILST)="~Pickup" - . S ILST=ILST+1,LST(ILST)="d"_$$DEFPICK($G(LOC)) - . ; S ILST=ILST+1,LST(ILST)="~Supply" - . ; S ILST=ILST+1,LST(ILST)="d^"_$$DEFSPLY(DFN) - Q -PKI(ORY,OI,PSTYPE,ORVP,PKIACTIV) ; return DEA Schedule for drug - N ILST,ORDOSE,ORWPSOI,ORWDOSES,X1,X2,X - K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J),^TMP("PSSDIN",$J) - S ILST=0 - S ORWPSOI=0 - S:+OI ORWPSOI=+$P($G(^ORD(101.43,+OI,0)),U,2) - D START^PSSJORDF(ORWPSOI,$S(PSTYPE="U":"I",1:"O")) ; dflt route, schedule, etc. - I '$L($T(DOSE^PSSOPKI1)) D DOSE^PSSORUTL(.ORDOSE,ORWPSOI,PSTYPE,ORVP) ; dflt doses - I $L($T(DOSE^PSSOPKI1)) D DOSE^PSSOPKI1(.ORDOSE,ORWPSOI,PSTYPE,ORVP) ; dflt doses NEW PKI CODE from pharmacy - D EN^PSSDIN(ORWPSOI) ; nfi text - S ORY="" ;PKI - I $D(ORDOSE("DEA")) S X="",X1=$P(ORDOSE("DEA"),";"),X2=$P(ORDOSE("DEA"),";",2) D - . I '$L(X2) Q - . I $G(PKIACTIV) S X=X2 - S ORY=X - K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J),^TMP("PSSDIN",$J) - Q -PRIOR ; from DLGSLCT, get list of allowed priorities - N X,XREF - S XREF=$S(PSTYPE="O":"S.PSO",1:"S.PSJ") - S X="" F S X=$O(^ORD(101.42,XREF,X)) Q:'$L(X) D - . I XREF["PSJ",X'="ASAP",X'="ROUTINE",X'="STAT" Q - . S ILST=ILST+1,LST(ILST)="i"_$O(^ORD(101.42,XREF,X,0))_U_X - S ILST=ILST+1,LST(ILST)="d"_$O(^ORD(101.42,"B","ROUTINE",0))_U_"ROUTINE" - Q -DEFPICK(LOC) ; return default routing - N X,DLG,PRMT - S DLG=$O(^ORD(101.41,"AB","PSO OERR",0)),X="" - S PRMT=$O(^ORD(101.41,"AB","OR GTX ROUTING",0)) - I $D(^TMP("ORECALL",$J,+DLG,+PRMT,1)) S X=^(1) - I X'="" S EDITONLY=1 Q X ; EDITONLY used by default action - ; - ;S X=$$GET^XPAR("ALL^"_"LOC.`"_LOC,"ORWDPS ROUTING DEFAULT",1,"I") - S X=$$GET^XPAR("LOC.`"_LOC_"^SYS","ORWDPS ROUTING DEFAULT",1,"I") - I X="C" S X="C^in Clinic" G XPICK - I X="M" S X="M^by Mail" G XPICK - I X="W" S X="W^at Window" G XPICK - I X="N" S X="" G XPICK - I X="" S X=$S($D(^PSX(550,"C")):"M^by Mail",1:"W^at Window") -XPICK Q X - ; -DEFSPLY(DFN) ; return default days supply for this patient - N ORWX - S ORWX("PATIENT")=DFN - D DSUP^PSOSIGDS(.ORWX) - Q $G(ORWX("DAYS SUPPLY")) - ; -DFLTSPLY(VAL,UPD,SCH,PAT,DRG) ; return days supply given quantity - ; VAL: default days supply - N ORWX,I - S ORWX("PATIENT")=PAT - I DRG S ORWX("DRUG")=DRG - F I=1:1:$L(UPD,U)-1 D - . S ORWX("DOSE ORDERED",I)=$P(UPD,U,I) - . S ORWX("SCHEDULE",I)=$P(SCH,U,I) - D DSUP^PSOSIGDS(.ORWX) - S VAL=$G(ORWX("DAYS SUPPLY")) - Q -DISPMSG() ; return 1 to suppress dispense message - Q +$$GET^XPAR("ALL","ORWDPS SUPPRESS DISPENSE MSG",1,"I") - ; -DOWSCH(LST,DFN,LOCIEN) ; return all schedules - N CNT,FREQ,ILST,ORARRAY,WIEN - S WIEN=$$WARDIEN^ORWDPS32(+$G(LOCIEN)) - D SCHED^PSS51P1(WIEN,.ORARRAY) - S ILST=0 - S CNT=0 F S CNT=$O(ORARRAY(CNT)) Q:CNT'>0 D - .S NODE=$G(ORARRAY(CNT)) - .I $P(NODE,U,4)="C" D - ..K ^TMP($J,"ORWDPS1 DOWSCH") - ..D ZERO^PSS51P1($P(NODE,U),,,,"ORWDPS1 DOWSCH") - ..S FREQ=$G(^TMP($J,"ORWDPS1 DOWSCH",$P(NODE,U),2)) - ..K ^TMP($J,"ORWDPS1 DOWSCH") - ..I +FREQ=0 Q - ..I +FREQ>1440 Q - ..S ILST=ILST+1,LST(ILST)=$P(ORARRAY(CNT),U,2,5) - Q - ; -SCHALL(LST,DFN,LOCIEN) ; return all schedules - N CNT,ILST,ORARRAY,WIEN - S WIEN=$$WARDIEN^ORWDPS32(+$G(LOCIEN)) - D SCHED^PSS51P1(WIEN,.ORARRAY) - S ILST=0 - S CNT=0 F S CNT=$O(ORARRAY(CNT)) Q:CNT'>0 D - .S ILST=ILST+1,LST(ILST)=$P(ORARRAY(CNT),U,2,5) - Q - ; -FORMALT(ORLST,ORIEN,PSTYPE) ; return a list of formulary alternatives - N PSID,I - S ORIEN=+$P(^ORD(101.43,ORIEN,0),U,2) - D EN1^PSSUTIL1(.ORIEN,PSTYPE) - S PSID=0,I=0 - F S PSID=$O(ORIEN(PSID)) Q:'PSID D - . S OI=+$O(^ORD(101.43,"ID",PSID_";99PSP",0)) - . I OI S I=I+1,ORLST(I)=OI,$P(ORLST(I),U,2)=$P(^ORD(101.43,OI,0),U) - Q -DOSEALT(LST,DDRUG,CUROI,PSTYPE) ; return a list of formulary alternatives for dose - N I,OI,ORWLST,ILST S ILST=0 - D ENRFA^PSJORUTL(DDRUG,PSTYPE,.ORWLST) - S I=0 F S I=$O(ORWLST(I)) Q:'I D - . S OI=+$O(^ORD(101.43,"ID",+$P(ORWLST(I),U,4)_";99PSP",0)) - . I OI,OI'=CUROI S ILST=ILST+1,LST(ILST)=OI_U_$P(^ORD(101.43,OI,0),U) - Q -QOMEDALT(ORY,ODIEN) ; - N ARRAY,IDIEN,ORDERID,PKG,PSTYPE,VALUE - S ORY=0,PKG=+$P(^ORD(101.41,ODIEN,0),U,7) - S PSTYPE=$S($$GET1^DIQ(9.4,PKG_",",1)="PSO":"O",1:"I") - S ORDERID=$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM","")) Q:ORDERID'>0 - S IDIEN=$O(^ORD(101.41,ODIEN,6,"D",ORDERID,"")) Q:IDIEN'>0 - S VALUE=$G(^ORD(101.41,ODIEN,6,IDIEN,1)) Q:VALUE'>0 - I $P($G(^ORD(101.43,VALUE,"PS")),U,6)=1 S ORY=VALUE - ;D FORMALT(.ARRAY,VALUE,PSTYPE) I $D(ARRAY)>0 S ORY=VALUE - ;I ORY=0,$P($G(^ORD(101.43,VALUE,"PS")),U,6)=1 S ORY=VALUE - Q -FAILDEA(FAIL,OI,ORNP,PSTYPE) ; return 1 if DEA check fails for this provider - N DEAFLG,PSOI,TPKG - S FAIL=0,TPKG=$P($G(^ORD(101.43,+$G(OI),0)),U,2) - Q:TPKG'["PS" - S PSOI=+TPKG Q:PSOI'>0 - I '$L($T(OIDEA^PSSUTLA1)) Q - S DEAFLG=$$OIDEA^PSSUTLA1(PSOI,PSTYPE) Q:DEAFLG'>0 - I '$L($$DEA^XUSER(,+$G(ORNP))) S FAIL=1 - Q -FDEA1(FAIL,OI,OITYPE,ORNP) ; only be called for an outpaitent and IV dialog - ;OI: IV Orderable Item - ;OITYPE: A:ADDITIVE S:SOLUTION - N DEAFLG,PSOI,TKPG - S FAIL=0,TPKG=$P($G(^ORD(101.43,+$G(OI),0)),U,2) - Q:TPKG'["PS" - S PSOI=+TPKG Q:PSOI'>0 - I '$L($T(IVDEA^PSSUTIL1)) Q - S DEAFLG=$$IVDEA^PSSUTIL1(PSOI,OITYPE) Q:DEAFLG'>0 - I '$L($P($G(^VA(200,+$G(ORNP),"PS")),U,2)),'$L($P($G(^("PS")),U,3)) S FAIL=1 - Q - ; -CHK94(VAL) ; return 1 if patch 94 has been installed - S VAL=0 - I $O(^ORD(101.41,"B","PS MEDS",0)) S VAL=1 - Q -LOCPICK(Y,LOC) ; return default Location level routing - S Y="" - S Y=$$GET^XPAR("LOC.`"_LOC_"^SYS","ORWDPS ROUTING DEFAULT",1,"I") - I Y="C" S Y="C^in Clinic" - I Y="M" S Y="M^by Mail" - I Y="W" S Y="W^at Window" - I Y="N" S Y="" - Q -HASOIPI(Y,QOID) ; Check if QO put orderable item's PI into Sig - N PIIEN,OIX - S Y=0 - Q:'$D(^ORD(101.41,QOID,0)) - S PIIEN=$O(^ORD(101.41,"B","OR GTX PATIENT INSTRUCTIONS",0)) - Q:'PIIEN - S OIX=0 - Q:'$D(^ORD(101.41,QOID,6,"D")) - F S OIX=$O(^ORD(101.41,+QOID,6,"D",OIX)) Q:'OIX D - . I OIX=PIIEN S Y=1 Q - Q -HASROUTE(Y,QOID) ;Check if QO has a ROUTE defined - N ROUTID - S Y=0,ROUTID=0 - S ROUTID=$O(^ORD(101.41,"B","OR GTX ROUTING",0)) - Q:'ROUTID - Q:'$D(^ORD(101.41,+QOID)) - I $D(^ORD(101.41,+QOID,6,"D",ROUTID)) S Y=1 - Q -QOCHECK(ORY,DIEN) ; - N ARY,DG,FORMIEN,NAME,OI,OIIEN,ORDIALOG,ORPKG,TYPE - S ORPKG=$$NMSP^ORCD($P($G(^ORD(101.41,DIEN,0)),U,7)) Q:ORPKG'["PS" - S DG=$P(^ORD(101.41,DIEN,0),U,5) - S NAME=$P(^ORD(100.98,DIEN,0),U) - S TYPE=$S(NAME="INPATIENT MEDICATIONS":"I",NAME="OUTPATIENT MEDICATIONS":"O",1:"") - I TYPE="" Q - S ORDIALOG=$$DEFDLG^ORCD(DIEN) Q:ORDIALOG - D GETDLG^ORCD(ORDIALOG),GETORDER^ORCD("^ORD(101.41,"_DIEN_",6)") - I $D(ORDIALOG)'>0 Q - S OI=$P($G(ORDIALOG("B","ORDERABLE")),U,2) Q:OI'>0 - S OIIEN=$G(ORDIALOG(OI,1)) Q:OIIEN'>0 - D FORMALT(.ARY,OIIEN,TYPE) I $D(ARY)'>0 Q - S ORY=OIIEN - Q +ORWDPS1 ; SLC/KCM/JLI - Pharmacy Calls for Windows Dialog ; 10/04/2005 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,132,141,163,215,255**;Dec 17, 1997 + ; +ODSLCT(LST,PSTYPE,DFN,LOC) ; return default lists for dialog + ; PSTYPE: pharmacy type (U=unit dose, F=IV fluids, O=outpatient) + N ILST S ILST=0 + S ILST=ILST+1,LST(ILST)="~Priority" D PRIOR + S ILST=ILST+1,LST(ILST)="~DispMsg" + S ILST=ILST+1,LST(ILST)="d"_$$DISPMSG + ; + ; I PSTYPE="F" D Q ; IV Fluids + ; . S ILST=ILST+1,LST(ILST)="~ShortList" D SHORT + ; + I PSTYPE="O" D ; Outpatient + . S ILST=ILST+1,LST(ILST)="~Refills" + . S ILST=ILST+1,LST(ILST)="d0^0" + . S ILST=ILST+1,LST(ILST)="~Pickup" + . S ILST=ILST+1,LST(ILST)="d"_$$DEFPICK($G(LOC)) + . ; S ILST=ILST+1,LST(ILST)="~Supply" + . ; S ILST=ILST+1,LST(ILST)="d^"_$$DEFSPLY(DFN) + Q +PKI(ORY,OI,PSTYPE,ORVP,PKIACTIV) ; return DEA Schedule for drug + N ILST,ORDOSE,ORWPSOI,ORWDOSES,X1,X2,X + K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J),^TMP("PSSDIN",$J) + S ILST=0 + S ORWPSOI=0 + S:+OI ORWPSOI=+$P($G(^ORD(101.43,+OI,0)),U,2) + D START^PSSJORDF(ORWPSOI,$S(PSTYPE="U":"I",1:"O")) ; dflt route, schedule, etc. + I '$L($T(DOSE^PSSOPKI1)) D DOSE^PSSORUTL(.ORDOSE,ORWPSOI,PSTYPE,ORVP) ; dflt doses + I $L($T(DOSE^PSSOPKI1)) D DOSE^PSSOPKI1(.ORDOSE,ORWPSOI,PSTYPE,ORVP) ; dflt doses NEW PKI CODE from pharmacy + D EN^PSSDIN(ORWPSOI) ; nfi text + S ORY="" ;PKI + I $D(ORDOSE("DEA")) S X="",X1=$P(ORDOSE("DEA"),";"),X2=$P(ORDOSE("DEA"),";",2) D + . I '$L(X2) Q + . I $G(PKIACTIV) S X=X2 + S ORY=X + K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J),^TMP("PSSDIN",$J) + Q +PRIOR ; from DLGSLCT, get list of allowed priorities + N X,XREF + S XREF=$S(PSTYPE="O":"S.PSO",1:"S.PSJ") + S X="" F S X=$O(^ORD(101.42,XREF,X)) Q:'$L(X) D + . I XREF["PSJ",X'="ASAP",X'="ROUTINE",X'="STAT" Q + . S ILST=ILST+1,LST(ILST)="i"_$O(^ORD(101.42,XREF,X,0))_U_X + S ILST=ILST+1,LST(ILST)="d"_$O(^ORD(101.42,"B","ROUTINE",0))_U_"ROUTINE" + Q +DEFPICK(LOC) ; return default routing + N X,DLG,PRMT + S DLG=$O(^ORD(101.41,"AB","PSO OERR",0)),X="" + S PRMT=$O(^ORD(101.41,"AB","OR GTX ROUTING",0)) + I $D(^TMP("ORECALL",$J,+DLG,+PRMT,1)) S X=^(1) + I X'="" S EDITONLY=1 Q X ; EDITONLY used by default action + ; + ;S X=$$GET^XPAR("ALL^"_"LOC.`"_LOC,"ORWDPS ROUTING DEFAULT",1,"I") + S X=$$GET^XPAR("LOC.`"_LOC_"^SYS","ORWDPS ROUTING DEFAULT",1,"I") + I X="C" S X="C^in Clinic" G XPICK + I X="M" S X="M^by Mail" G XPICK + I X="W" S X="W^at Window" G XPICK + I X="N" S X="" G XPICK + I X="" S X=$S($D(^PSX(550,"C")):"M^by Mail",1:"W^at Window") +XPICK Q X + ; +DEFSPLY(DFN) ; return default days supply for this patient + N ORWX + S ORWX("PATIENT")=DFN + D DSUP^PSOSIGDS(.ORWX) + Q $G(ORWX("DAYS SUPPLY")) + ; +DFLTSPLY(VAL,UPD,SCH,PAT,DRG) ; return days supply given quantity + ; VAL: default days supply + N ORWX,I + S ORWX("PATIENT")=PAT + I DRG S ORWX("DRUG")=DRG + F I=1:1:$L(UPD,U)-1 D + . S ORWX("DOSE ORDERED",I)=$P(UPD,U,I) + . S ORWX("SCHEDULE",I)=$P(SCH,U,I) + D DSUP^PSOSIGDS(.ORWX) + S VAL=$G(ORWX("DAYS SUPPLY")) + Q +DISPMSG() ; return 1 to suppress dispense message + Q +$$GET^XPAR("ALL","ORWDPS SUPPRESS DISPENSE MSG",1,"I") + ; +SCHALL(LST) ; return all schedules + N ILST,SCH,IEN,EXP,TYP,X0 + S ILST=0,SCH="" + F S SCH=$O(^PS(51.1,"APPSJ",SCH)) Q:SCH="" D + . S IEN=0,EXP="" + . F S IEN=$O(^PS(51.1,"APPSJ",SCH,IEN)) Q:'IEN D Q:$L(EXP) + . . S X0=$G(^PS(51.1,IEN,0)),EXP=$P(X0,U,8),TYP=$P(X0,U,5) + . S ILST=ILST+1,LST(ILST)=SCH_U_EXP_U_TYP + Q +FORMALT(ORLST,ORIEN,PSTYPE) ; return a list of formulary alternatives + N PSID,I + S ORIEN=+$P(^ORD(101.43,ORIEN,0),U,2) + D EN1^PSSUTIL1(.ORIEN,PSTYPE) + S PSID=0,I=0 + F S PSID=$O(ORIEN(PSID)) Q:'PSID D + . S OI=+$O(^ORD(101.43,"ID",PSID_";99PSP",0)) + . I OI S I=I+1,ORLST(I)=OI,$P(ORLST(I),U,2)=$P(^ORD(101.43,OI,0),U) + Q +DOSEALT(LST,DDRUG,CUROI,PSTYPE) ; return a list of formulary alternatives for dose + N I,OI,ORWLST,ILST S ILST=0 + D ENRFA^PSJORUTL(DDRUG,PSTYPE,.ORWLST) + S I=0 F S I=$O(ORWLST(I)) Q:'I D + . S OI=+$O(^ORD(101.43,"ID",+$P(ORWLST(I),U,4)_";99PSP",0)) + . I OI,OI'=CUROI S ILST=ILST+1,LST(ILST)=OI_U_$P(^ORD(101.43,OI,0),U) + Q +FAILDEA(FAIL,OI,ORNP,PSTYPE) ; return 1 if DEA check fails for this provider + N DEAFLG,PSOI,TPKG + S FAIL=0,TPKG=$P($G(^ORD(101.43,+$G(OI),0)),U,2) + Q:TPKG'["PS" + S PSOI=+TPKG Q:PSOI'>0 + I '$L($T(OIDEA^PSSUTLA1)) Q + S DEAFLG=$$OIDEA^PSSUTLA1(PSOI,PSTYPE) Q:DEAFLG'>0 + I '$L($$DEA^XUSER(,+$G(ORNP))) S FAIL=1 + Q +FDEA1(FAIL,OI,OITYPE,ORNP) ; only be called for an outpaitent and IV dialog + ;OI: IV Orderable Item + ;OITYPE: A:ADDITIVE S:SOLUTION + N DEAFLG,PSOI,TKPG + S FAIL=0,TPKG=$P($G(^ORD(101.43,+$G(OI),0)),U,2) + Q:TPKG'["PS" + S PSOI=+TPKG Q:PSOI'>0 + I '$L($T(IVDEA^PSSUTIL1)) Q + S DEAFLG=$$IVDEA^PSSUTIL1(PSOI,OITYPE) Q:DEAFLG'>0 + I '$L($P($G(^VA(200,+$G(ORNP),"PS")),U,2)),'$L($P($G(^("PS")),U,3)) S FAIL=1 + Q + ; +CHK94(VAL) ; return 1 if patch 94 has been installed + S VAL=0 + I $O(^ORD(101.41,"B","PS MEDS",0)) S VAL=1 + Q +LOCPICK(Y,LOC) ; return default Location level routing + S Y="" + S Y=$$GET^XPAR("LOC.`"_LOC_"^SYS","ORWDPS ROUTING DEFAULT",1,"I") + I Y="C" S Y="C^in Clinic" + I Y="M" S Y="M^by Mail" + I Y="W" S Y="W^at Window" + I Y="N" S Y="" + Q +HASOIPI(Y,QOID) ; Check if QO put orderable item's PI into Sig + N PIIEN,OIX + S Y=0 + Q:'$D(^ORD(101.41,QOID,0)) + S PIIEN=$O(^ORD(101.41,"B","OR GTX PATIENT INSTRUCTIONS",0)) + Q:'PIIEN + S OIX=0 + Q:'$D(^ORD(101.41,QOID,6,"D")) + F S OIX=$O(^ORD(101.41,+QOID,6,"D",OIX)) Q:'OIX D + . I OIX=PIIEN S Y=1 Q + Q +HASROUTE(Y,QOID) ;Check if QO has a ROUTE defined + N ROUTID + S Y=0,ROUTID=0 + S ROUTID=$O(^ORD(101.41,"B","OR GTX ROUTING",0)) + Q:'ROUTID + Q:'$D(^ORD(101.41,+QOID)) + I $D(^ORD(101.41,+QOID,6,"D",ROUTID)) S Y=1 + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDPS2.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDPS2.m index 967ffc1d..11244b9c 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDPS2.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDPS2.m @@ -1,234 +1,234 @@ -ORWDPS2 ; SLC/KCM/JLI - Pharmacy Calls for Windows Dialog;05/09/2007 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,116,125,131,132,148,141,195,215,258,243**;Dec 17, 1997;Build 242 - ; -OISLCT(LST,OI,PSTYPE,ORVP,NEEDPI,PKIACTIV) ; return for defaults for pharmacy orderable item - N ILST,ORDOSE,ORWPSOI,ORWDOSES,X1,X2 - K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J),^TMP("PSSDIN",$J) - S ILST=0 - S ORWPSOI=0 - S:+OI ORWPSOI=+$P($G(^ORD(101.43,+OI,0)),U,2) - D START^PSSJORDF(ORWPSOI,$S(PSTYPE="U":"I",1:"O")) ; dflt route, schedule, etc. - I '$L($T(DOSE^PSSOPKI1)) D DOSE^PSSORUTL(.ORDOSE,ORWPSOI,PSTYPE,ORVP) ; dflt doses - I $L($T(DOSE^PSSOPKI1)) D DOSE^PSSOPKI1(.ORDOSE,ORWPSOI,PSTYPE,ORVP) ; dflt doses NEW PKI CODE from pharmacy - D EN^PSSDIN(ORWPSOI) ; nfi text - S ILST=ILST+1,LST(ILST)="~Medication" - S ILST=ILST+1,LST(ILST)="d"_OI_U_$S(+OI:$P(^ORD(101.43,OI,0),U),1:"") - S ILST=ILST+1,LST(ILST)="~Verb" - S ILST=ILST+1,LST(ILST)="d"_$P($G(ORDOSE("MISC")),U) - S ILST=ILST+1,LST(ILST)="~Preposition" - S ILST=ILST+1,LST(ILST)="d"_$P($G(ORDOSE("MISC")),U,2) - I $D(NEEDPI),(NEEDPI="Y") S ILST=ILST+1,LST(ILST)="~PtInstr" D PTINSTR - ;S:NEEDPI="Y" ILST=ILST+1,LST(ILST)="~PtInstr" D PTINSTR - S ILST=ILST+1,LST(ILST)="~AllDoses" D ALLDOSE ; must do before DOSAGE - S ILST=ILST+1,LST(ILST)="~Dosage" D DOSAGE - S ILST=ILST+1,LST(ILST)="~Dispense" D DISPLST - S ILST=ILST+1,LST(ILST)="~Route" D ROUTE - S ILST=ILST+1,LST(ILST)="~Schedule" D SCHED - S ILST=ILST+1,LST(ILST)="~Guideline" D GUIDE - S ILST=ILST+1,LST(ILST)="~Message" D OIMSG - S ILST=ILST+1,LST(ILST)="~DEASchedule" ;PKI - ;S ILST=ILST+1,LST(ILST)="d"_$P($G(ORDOSE("DEA")),U) ;PKI - S ILST=ILST+1,LST(ILST)="d" ;PKI - I $D(ORDOSE("DEA")) S X="",X1=$P(ORDOSE("DEA"),";"),X2=$P(ORDOSE("DEA"),";",2) D - . I '$L(X2) Q - . I $G(PKIACTIV)="Y" S X=X2 - S LST(ILST)=LST(ILST)_X - I PSTYPE="U" D - . ; start, expires, next admin - I PSTYPE="O" D - . ; days supply, quantity, refills - K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J),^TMP("PSSDIN",$J) - Q - ; -PTINSTR ; from OISLCT, set up patient instructions - N I - S I=0 F S I=$O(ORDOSE("PI",I)) Q:I'>0 S ILST=ILST+1,LST(ILST)="t"_ORDOSE("PI",I) - Q -DOSAGE ; from OISLCT, set up the list of dosages - ; LST(n)=iDrugName^Strength^NF^... (see BLDDOSE) - ; must be called after ALLDOSE so ORWDOSES is set up - N I - S I=0 F S I=$O(ORWDOSES(I)) Q:I'>0 S ILST=ILST+1,LST(ILST)=ORWDOSES(I) - Q -DISPLST ; from OISLCT, set up list of dispense drugs - ; DrugIEN^Strength^Units^Name^Split - N DD - S DD=0 F S DD=$O(ORDOSE("DD",DD)) Q:'DD D - . S ILST=ILST+1 - . S LST(ILST)="i"_DD_U_$P(ORDOSE("DD",DD),U,5,6)_U_$P(ORDOSE("DD",DD),U)_U_$P(ORDOSE("DD",DD),U,11) - Q -ALLDOSE ; from OISLCT, set up a list of all possible doses - ; LST(n)=iDrugName^Strength^NF^... (see BLDDOSE) - N I,J,CONJ,DD,DRUG,DDNM,LDOSE,TEXT,STREN,UD,COST,NF,ID,X - S CONJ=$P($G(ORDOSE("MISC")),U,3),ORWDOSES=0 - S:$L(CONJ) CONJ=" "_CONJ_" " S:'$L(CONJ) CONJ=" " - S I=0 F S I=$O(ORDOSE(I)) Q:I'>0 D - . S X=$$BLDDOSE(ORDOSE(I)) - . S ORWDOSES=ORWDOSES+1,ORWDOSES(ORWDOSES)=X - . S ILST=ILST+1 - . S LST(ILST)="i"_$P(X,U,5)_U_$P($P(X,U,4),"&",6)_U_$P(X,U,4) - . S J=0 F S J=$O(ORDOSE(I,J)) Q:J'>0 D - . . S X=$$BLDDOSE(ORDOSE(I,J)) - . . S ILST=ILST+1 - . . S LST(ILST)="i"_$P(X,U,5)_U_$P($P(X,U,4),"&",6)_U_$P(X,U,4) - Q -BLDDOSE(X) ; build dose info where X is ORDOSE node - ; from ALLDOSE - ; X=TotalDose^Units^U/D^Noun^LocalDose^DispDrugIEN - ; Y=iDrugName^Strength^NF^TDose&Units&U/D&Noun&LDose&Drug&Stren&Units^ - ; DoseText^CostText^MaxRefills^DispUnits^CanSplit - ; DRUG=Name^Cost^NF^DispUnit^Strength^Units^DoseForm^MaxRefills^ - ; No TotalDose, use LocalDose - ; TotalDose & Strength, use LocalDose+Conjunction+Strength+Units - ; TotalDose, No Strength, use LocalDose+Conjunction+DispenseName - S DD=+$P(X,U,6),DRUG=ORDOSE("DD",DD),DDNM=$P(DRUG,U),ID=$P(X,U,1,6) - S LDOSE=$P(X,U,5),TEXT=LDOSE,STREN=$P(DRUG,U,5)_$P(DRUG,U,6) - S $P(ID,U,7)=$P(DRUG,U,5) S $P(ID,U,8)=$P(DRUG,U,6) ; add strength - I '$L($P(X,U)),$L($P(DRUG,U,5)) S TEXT=TEXT_CONJ_STREN - I '$L($P(X,U)),'$L($P(DRUG,U,5)) S TEXT=TEXT_CONJ_$P(DRUG,U) - S UD=$P(X,U,3),COST=$P(X,U,7),NF=$S($P(DRUG,U,3):"NF",1:"") - ;I UD S COST="$"_$J(UD*$P(DRUG,U,2),1,3) ;_" per "_UD_" "_$P(X,U,4) - S Y="i"_DDNM_U_STREN_U_NF_U_$TR(ID,U,"&")_U_TEXT_U_COST_U_$P(DRUG,U,8)_U_$P(DRUG,U,4) - Q Y -ROUTE ; from OISLCT, get list of routes for the drug form - ; ** NEED BOTH ABBREVIATION & NAME IN LIST BOX - N I,CNT,ABBR,IEN,ROUT,EXP,X - S I="" F S I=$O(^TMP("PSJMR",$J,I)) Q:I="" D - . S X=^TMP("PSJMR",$J,I) - . S ROUT=$P(X,U),ABBR=$P(X,U,2),IEN=$P(X,U,3),EXP=$P(X,U,4) - . S ILST=ILST+1,LST(ILST)="i"_IEN_U_ROUT_U_ABBR_U_EXP_U_$P(X,U,5) - . I $P(X,U,6)="D",IEN S ILST=ILST+1,LST(ILST)="d"_IEN_U_ROUT ;_U_ABBR ; assume first always default - ; add abbreviations to list of routes, commented out for 15.5 on - ; S I="" F S I=$O(^TMP("PSJMR",$J,I)) Q:I="" D - ; . S X=^TMP("PSJMR",$J,I) - ; . S ROUT=$P(X,U),ABBR=$P(X,U,2),IEN=$P(X,U,3),EXP=$P(X,U,4) - ; . I $L(ABBR),(ABBR'=ROUT) S ILST=ILST+1,LST(ILST)="i"_IEN_U_ABBR_" ("_ROUT_")"_U_ABBR_U_EXP - Q -SCHED ; from OISLCT, get default schedule for this medication - I $L($G(^TMP("PSJSCH",$J))) S ILST=ILST+1,LST(ILST)="d"_^($J) - Q -GUIDE ; from OISLCT, get guidelines associated with this medication - N IEN,I - S IEN=0 F S IEN=$O(^TMP("PSSDIN",$J,"OI",ORWPSOI,IEN)) Q:'IEN D - . S I=0 F S I=$O(^TMP("PSSDIN",$J,"OI",ORWPSOI,IEN,I)) Q:'I D - . . S ILST=ILST+1,LST(ILST)="t"_^TMP("PSSDIN",$J,"OI",ORWPSOI,IEN,I) - Q -OIMSG ; from OISLCT, get the orderable item message for this medication - S I=0 F S I=$O(^ORD(101.43,OI,8,I)) Q:I'>0 S ILST=ILST+1,LST(ILST)="t"_^(I,0) - Q -ADMIN(REC,DFN,SCH,OI,LOC,ADMIN) ; return administration time info - ; REC: StartText^StartTime^Duration^FirstAdmin - S OI=+$P($G(^ORD(101.43,+OI,0)),U,2) - S LOC=+$G(^SC(LOC,42)),REC="" - I $L($G(^DPT(DFN,.1))) S REC=$$FIRST^ORCDPS3(DFN,LOC,OI,SCH,"",$G(ADMIN)) - Q -REQST(VAL,DFN,SCH,OI,LOC,TXT) ; return requested start time - ; VAL: FirstAdmin time - S VAL="" - Q:'$L($G(SCH)) Q:'$G(OI) - S OI=+$P($G(^ORD(101.43,+OI,0)),U,2) - S LOC=+$G(^SC(LOC,42)) - S VAL=$P($$RESOLVE^PSJORPOE(DFN,SCH,OI,TXT,LOC),U,2) - Q -DAY2QTY(VAL,DAY,UPD,SCH,DUR,PAT,DRG) ; return qty for days supply - ; VAL: quantity - N ORWX,I,X,ADUR,ADURNM - S ORWX("DAYS SUPPLY")=DAY - S ORWX("PATIENT")=PAT - I DRG S ORWX("DRUG")=DRG - F I=1:1:$L(UPD,U)-1 D - . S ORWX("DOSE ORDERED",I)=$P(UPD,U,I) - . S ORWX("SCHEDULE",I)=$P(SCH,U,I) - . S ADUR=$P(DUR,U,I),ADURNM=$P($P(ADUR," ",2),"~") - . S:ADURNM="MONTHS" X=+ADUR_"L" - . S:ADURNM'="MONTHS" X=+ADUR_$E($P(ADUR," ",2)) - . I $L(X) S ORWX("DURATION",I)=X - . S X=$E($P(ADUR,"~",2)) - . I $L(X) S ORWX("CONJUNCTION",I)=X - D QTYX^PSOSIG(.ORWX) - S VAL=$G(ORWX("QTY")) - Q -QTY2DAY(VAL,QTY,UPD,SCH,DUR,PAT,DRG) ; return days supply given quantity - ; VAL: days supply - N ORWX,I,X,ADUR - S ORWX("QTY")=QTY - S ORWX("PATIENT")=PAT - I DRG S ORWX("DRUG")=DRG - F I=1:1:$L(UPD,U)-1 D - . S ORWX("DOSE ORDERED",I)=$P(UPD,U,I) - . S ORWX("SCHEDULE",I)=$P(SCH,U,I) - . S ADUR=$P(DUR,U,I),X=+ADUR_$E($P(ADUR," ",2)) - . I $L(X) S ORWX("DURATION",I)=X - . S X=$E($P(ADUR,"~",2)) - . I $L(X) S ORWX("CONJUNCTION",I)=X - D QTYX^PSOSIG(.ORWX) - S VAL=$G(ORWX("DAYS SUPPLY")) - Q -MAXREF(VAL,PAT,DRG,SUP,OI,OUT) ; return the maximum number of refills - ; PAT=Patient DFN, DRG=ptr50, SUP=days supply, OI=orderable item - ; VAL: maximum refills allowed - N ORWX - S ORWX("PATIENT")=PAT - I $G(DRG) S ORWX("DRUG")=+DRG - I $G(SUP) S ORWX("DAYS SUPPLY")=SUP - I $G(OI) S ORWX("ITEM")=+$P(^ORD(101.43,+OI,0),U,2) - I $G(OUT) S ORWX("DISCHARGE")=1 - D MAX^PSOSIGDS(.ORWX) - S VAL=$G(ORWX("MAX")) - Q -SCHREQ(VAL,OI,RTE,DRG) ; return 1 if schedule is required - ; OI=orderable item, RTE=ptr route, DRG=ptr dispense drug - S VAL=1 - Q:'$G(OI) Q:'$G(RTE) - S VAL=$$SCHREQ^PSJORPOE(RTE,OI,+$G(DRG)) - Q -CHKPI(VAL,ODIFN) ; return pre-existing patient instruct - N IDNUM,IDPI - S (IDNUM,IDPI)=0,VAL="" - I '$D(^OR(100,ODIFN,4.5,"ID","PI")) S VAL="" Q - F S IDNUM=$O(^OR(100,ODIFN,4.5,"ID","PI",IDNUM)) Q:'IDNUM D - . F S IDPI=$O(^OR(100,ODIFN,4.5,IDNUM,2,IDPI)) Q:'IDPI D - .. S VAL=VAL_^OR(100,ODIFN,4.5,IDNUM,2,IDPI,0) - K IDNUM,IDPI - Q -CHKGRP(VAL,ORIFN) ; - ;Inpatient Med Order Group or Clin Meds Group: return 1 - ;If order belong to Outpatient Med Order Grpoup: return 2 - ;Otherwise, return 0 - S VAL=0 - I '$L(ORIFN) Q - N UDGRP,IPGRP,OPGRP,ODGRP,ODID,CLMED - S ODID=+ORIFN - Q:ODID<1 - S (UDGRP,IPGRP,OPGRP,ODGRP,CLMED)=0 - S UDGRP=$O(^ORD(100.98,"B","UD RX",UDGRP)) - S OPGRP=$O(^ORD(100.98,"B","OUTPATIENT MEDICATIONS",OPGRP)) - S IPGRP=$O(^ORD(100.98,"B","INPATIENT MEDICATIONS",IPGRP)) - S CLMED=$O(^ORD(100.98,"B","CLINIC ORDERS",CLMED)) - S:IPGRP=0 IPGRP=$O(^ORD(100.98,"B","I RX",IPGRP)) - I $L($G(^OR(100,ODID,0)))<1 Q - S ODGRP=$P(^OR(100,ODID,0),U,11) - I (UDGRP=ODGRP)!(CLMED=ODGRP) S VAL=1 - I IPGRP=ODGRP S VAL=1 - I OPGRP=ODGRP S VAL=2 - K UDGRP,ODGRP,OPGRP,IPGRP,ODID,CLMED - Q -QOGRP(VAL,QOIFN) ; - ;If quick order belong to Inpatient Med Order Group: return 1 - ;Otherwise, return 0 - S VAL=0 - I '$L(QOIFN) Q - N UDGRP,IPGRP,QOGRP,QOID,CLMED - S QOID=+QOIFN - Q:QOID<1 - S (UDGRP,IPGRP,QOGRP,CLMED)=0 - S UDGRP=$O(^ORD(100.98,"B","UD RX",UDGRP)) - S IPGRP=$O(^ORD(100.98,"B","INPATIENT MEDICATIONS",IPGRP)) - S CLMED=$O(^ORD(100.98,"B","CLINIC ORDERS",CLMED)) - S:IPGRP=0 IPGRP=$O(^ORD(100.98,"B","I RX",IPGRP)) - I $L($G(^ORD(101.41,QOID,0)))<1 Q - S QOGRP=$P(^ORD(101.41,QOID,0),U,5) - I UDGRP=QOGRP S VAL=1 - I (IPGRP=QOGRP)!(CLMED=QOGRP) S VAL=1 - K UDGRP,QOGRP,QOID,IPGRP,CLMED - Q +ORWDPS2 ; SLC/KCM/JLI - Pharmacy Calls for Windows Dialog + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,116,125,131,132,148,141,195,215,258**;Dec 17, 1997;Build 7 + ; +OISLCT(LST,OI,PSTYPE,ORVP,NEEDPI,PKIACTIV) ; return for defaults for pharmacy orderable item + N ILST,ORDOSE,ORWPSOI,ORWDOSES,X1,X2 + K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J),^TMP("PSSDIN",$J) + S ILST=0 + S ORWPSOI=0 + S:+OI ORWPSOI=+$P($G(^ORD(101.43,+OI,0)),U,2) + D START^PSSJORDF(ORWPSOI,$S(PSTYPE="U":"I",1:"O")) ; dflt route, schedule, etc. + I '$L($T(DOSE^PSSOPKI1)) D DOSE^PSSORUTL(.ORDOSE,ORWPSOI,PSTYPE,ORVP) ; dflt doses + I $L($T(DOSE^PSSOPKI1)) D DOSE^PSSOPKI1(.ORDOSE,ORWPSOI,PSTYPE,ORVP) ; dflt doses NEW PKI CODE from pharmacy + D EN^PSSDIN(ORWPSOI) ; nfi text + S ILST=ILST+1,LST(ILST)="~Medication" + S ILST=ILST+1,LST(ILST)="d"_OI_U_$S(+OI:$P(^ORD(101.43,OI,0),U),1:"") + S ILST=ILST+1,LST(ILST)="~Verb" + S ILST=ILST+1,LST(ILST)="d"_$P($G(ORDOSE("MISC")),U) + S ILST=ILST+1,LST(ILST)="~Preposition" + S ILST=ILST+1,LST(ILST)="d"_$P($G(ORDOSE("MISC")),U,2) + I $D(NEEDPI),(NEEDPI="Y") S ILST=ILST+1,LST(ILST)="~PtInstr" D PTINSTR + ;S:NEEDPI="Y" ILST=ILST+1,LST(ILST)="~PtInstr" D PTINSTR + S ILST=ILST+1,LST(ILST)="~AllDoses" D ALLDOSE ; must do before DOSAGE + S ILST=ILST+1,LST(ILST)="~Dosage" D DOSAGE + S ILST=ILST+1,LST(ILST)="~Dispense" D DISPLST + S ILST=ILST+1,LST(ILST)="~Route" D ROUTE + S ILST=ILST+1,LST(ILST)="~Schedule" D SCHED + S ILST=ILST+1,LST(ILST)="~Guideline" D GUIDE + S ILST=ILST+1,LST(ILST)="~Message" D OIMSG + S ILST=ILST+1,LST(ILST)="~DEASchedule" ;PKI + ;S ILST=ILST+1,LST(ILST)="d"_$P($G(ORDOSE("DEA")),U) ;PKI + S ILST=ILST+1,LST(ILST)="d" ;PKI + I $D(ORDOSE("DEA")) S X="",X1=$P(ORDOSE("DEA"),";"),X2=$P(ORDOSE("DEA"),";",2) D + . I '$L(X2) Q + . I $G(PKIACTIV)="Y" S X=X2 + S LST(ILST)=LST(ILST)_X + I PSTYPE="U" D + . ; start, expires, next admin + I PSTYPE="O" D + . ; days supply, quantity, refills + K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J),^TMP("PSSDIN",$J) + Q + ; +PTINSTR ; from OISLCT, set up patient instructions + N I + S I=0 F S I=$O(ORDOSE("PI",I)) Q:I'>0 S ILST=ILST+1,LST(ILST)="t"_ORDOSE("PI",I) + Q +DOSAGE ; from OISLCT, set up the list of dosages + ; LST(n)=iDrugName^Strength^NF^... (see BLDDOSE) + ; must be called after ALLDOSE so ORWDOSES is set up + N I + S I=0 F S I=$O(ORWDOSES(I)) Q:I'>0 S ILST=ILST+1,LST(ILST)=ORWDOSES(I) + Q +DISPLST ; from OISLCT, set up list of dispense drugs + ; DrugIEN^Strength^Units^Name^Split + N DD + S DD=0 F S DD=$O(ORDOSE("DD",DD)) Q:'DD D + . S ILST=ILST+1 + . S LST(ILST)="i"_DD_U_$P(ORDOSE("DD",DD),U,5,6)_U_$P(ORDOSE("DD",DD),U)_U_$P(ORDOSE("DD",DD),U,11) + Q +ALLDOSE ; from OISLCT, set up a list of all possible doses + ; LST(n)=iDrugName^Strength^NF^... (see BLDDOSE) + N I,J,CONJ,DD,DRUG,DDNM,LDOSE,TEXT,STREN,UD,COST,NF,ID,X + S CONJ=$P($G(ORDOSE("MISC")),U,3),ORWDOSES=0 + S:$L(CONJ) CONJ=" "_CONJ_" " S:'$L(CONJ) CONJ=" " + S I=0 F S I=$O(ORDOSE(I)) Q:I'>0 D + . S X=$$BLDDOSE(ORDOSE(I)) + . S ORWDOSES=ORWDOSES+1,ORWDOSES(ORWDOSES)=X + . S ILST=ILST+1 + . S LST(ILST)="i"_$P(X,U,5)_U_$P($P(X,U,4),"&",6)_U_$P(X,U,4) + . S J=0 F S J=$O(ORDOSE(I,J)) Q:J'>0 D + . . S X=$$BLDDOSE(ORDOSE(I,J)) + . . S ILST=ILST+1 + . . S LST(ILST)="i"_$P(X,U,5)_U_$P($P(X,U,4),"&",6)_U_$P(X,U,4) + Q +BLDDOSE(X) ; build dose info where X is ORDOSE node + ; from ALLDOSE + ; X=TotalDose^Units^U/D^Noun^LocalDose^DispDrugIEN + ; Y=iDrugName^Strength^NF^TDose&Units&U/D&Noun&LDose&Drug&Stren&Units^ + ; DoseText^CostText^MaxRefills^DispUnits^CanSplit + ; DRUG=Name^Cost^NF^DispUnit^Strength^Units^DoseForm^MaxRefills^ + ; No TotalDose, use LocalDose + ; TotalDose & Strength, use LocalDose+Conjunction+Strength+Units + ; TotalDose, No Strength, use LocalDose+Conjunction+DispenseName + S DD=+$P(X,U,6),DRUG=ORDOSE("DD",DD),DDNM=$P(DRUG,U),ID=$P(X,U,1,6) + S LDOSE=$P(X,U,5),TEXT=LDOSE,STREN=$P(DRUG,U,5)_$P(DRUG,U,6) + S $P(ID,U,7)=$P(DRUG,U,5) S $P(ID,U,8)=$P(DRUG,U,6) ; add strength + I '$L($P(X,U)),$L($P(DRUG,U,5)) S TEXT=TEXT_CONJ_STREN + I '$L($P(X,U)),'$L($P(DRUG,U,5)) S TEXT=TEXT_CONJ_$P(DRUG,U) + S UD=$P(X,U,3),COST=$P(X,U,7),NF=$S($P(DRUG,U,3):"NF",1:"") + ;I UD S COST="$"_$J(UD*$P(DRUG,U,2),1,3) ;_" per "_UD_" "_$P(X,U,4) + S Y="i"_DDNM_U_STREN_U_NF_U_$TR(ID,U,"&")_U_TEXT_U_COST_U_$P(DRUG,U,8)_U_$P(DRUG,U,4) + Q Y +ROUTE ; from OISLCT, get list of routes for the drug form + ; ** NEED BOTH ABBREVIATION & NAME IN LIST BOX + N I,CNT,ABBR,IEN,ROUT,EXP,X + S I="" F S I=$O(^TMP("PSJMR",$J,I)) Q:I="" D + . S X=^TMP("PSJMR",$J,I) + . S ROUT=$P(X,U),ABBR=$P(X,U,2),IEN=$P(X,U,3),EXP=$P(X,U,4) + . S ILST=ILST+1,LST(ILST)="i"_IEN_U_ROUT_U_ABBR_U_EXP_U_$P(X,U,5) + . I $P(X,U,6)="D",IEN S ILST=ILST+1,LST(ILST)="d"_IEN_U_ROUT ;_U_ABBR ; assume first always default + ; add abbreviations to list of routes, commented out for 15.5 on + ; S I="" F S I=$O(^TMP("PSJMR",$J,I)) Q:I="" D + ; . S X=^TMP("PSJMR",$J,I) + ; . S ROUT=$P(X,U),ABBR=$P(X,U,2),IEN=$P(X,U,3),EXP=$P(X,U,4) + ; . I $L(ABBR),(ABBR'=ROUT) S ILST=ILST+1,LST(ILST)="i"_IEN_U_ABBR_" ("_ROUT_")"_U_ABBR_U_EXP + Q +SCHED ; from OISLCT, get default schedule for this medication + I $L($G(^TMP("PSJSCH",$J))) S ILST=ILST+1,LST(ILST)="d"_^($J) + Q +GUIDE ; from OISLCT, get guidelines associated with this medication + N IEN,I + S IEN=0 F S IEN=$O(^TMP("PSSDIN",$J,"OI",ORWPSOI,IEN)) Q:'IEN D + . S I=0 F S I=$O(^TMP("PSSDIN",$J,"OI",ORWPSOI,IEN,I)) Q:'I D + . . S ILST=ILST+1,LST(ILST)="t"_^TMP("PSSDIN",$J,"OI",ORWPSOI,IEN,I) + Q +OIMSG ; from OISLCT, get the orderable item message for this medication + S I=0 F S I=$O(^ORD(101.43,OI,8,I)) Q:I'>0 S ILST=ILST+1,LST(ILST)="t"_^(I,0) + Q +ADMIN(REC,DFN,SCH,OI,LOC) ; return administration time info + ; REC: StartText^StartTime^Duration^FirstAdmin + S OI=+$P($G(^ORD(101.43,+OI,0)),U,2) + S LOC=+$G(^SC(LOC,42)),REC="" + I $L($G(^DPT(DFN,.1))) S REC=$$FIRST^ORCDPS3(DFN,LOC,OI,SCH) + Q +REQST(VAL,DFN,SCH,OI,LOC,TXT) ; return requested start time + ; VAL: FirstAdmin time + S VAL="" + Q:'$L($G(SCH)) Q:'$G(OI) + S OI=+$P($G(^ORD(101.43,+OI,0)),U,2) + S LOC=+$G(^SC(LOC,42)) + S VAL=$P($$RESOLVE^PSJORPOE(DFN,SCH,OI,TXT,LOC),U,2) + Q +DAY2QTY(VAL,DAY,UPD,SCH,DUR,PAT,DRG) ; return qty for days supply + ; VAL: quantity + N ORWX,I,X,ADUR,ADURNM + S ORWX("DAYS SUPPLY")=DAY + S ORWX("PATIENT")=PAT + I DRG S ORWX("DRUG")=DRG + F I=1:1:$L(UPD,U)-1 D + . S ORWX("DOSE ORDERED",I)=$P(UPD,U,I) + . S ORWX("SCHEDULE",I)=$P(SCH,U,I) + . S ADUR=$P(DUR,U,I),ADURNM=$P($P(ADUR," ",2),"~") + . S:ADURNM="MONTHS" X=+ADUR_"L" + . S:ADURNM'="MONTHS" X=+ADUR_$E($P(ADUR," ",2)) + . I $L(X) S ORWX("DURATION",I)=X + . S X=$E($P(ADUR,"~",2)) + . I $L(X) S ORWX("CONJUNCTION",I)=X + D QTYX^PSOSIG(.ORWX) + S VAL=$G(ORWX("QTY")) + Q +QTY2DAY(VAL,QTY,UPD,SCH,DUR,PAT,DRG) ; return days supply given quantity + ; VAL: days supply + N ORWX,I,X,ADUR + S ORWX("QTY")=QTY + S ORWX("PATIENT")=PAT + I DRG S ORWX("DRUG")=DRG + F I=1:1:$L(UPD,U)-1 D + . S ORWX("DOSE ORDERED",I)=$P(UPD,U,I) + . S ORWX("SCHEDULE",I)=$P(SCH,U,I) + . S ADUR=$P(DUR,U,I),X=+ADUR_$E($P(ADUR," ",2)) + . I $L(X) S ORWX("DURATION",I)=X + . S X=$E($P(ADUR,"~",2)) + . I $L(X) S ORWX("CONJUNCTION",I)=X + D QTYX^PSOSIG(.ORWX) + S VAL=$G(ORWX("DAYS SUPPLY")) + Q +MAXREF(VAL,PAT,DRG,SUP,OI,OUT) ; return the maximum number of refills + ; PAT=Patient DFN, DRG=ptr50, SUP=days supply, OI=orderable item + ; VAL: maximum refills allowed + N ORWX + S ORWX("PATIENT")=PAT + I $G(DRG) S ORWX("DRUG")=+DRG + I $G(SUP) S ORWX("DAYS SUPPLY")=SUP + I $G(OI) S ORWX("ITEM")=+$P(^ORD(101.43,+OI,0),U,2) + I $G(OUT) S ORWX("DISCHARGE")=1 + D MAX^PSOSIGDS(.ORWX) + S VAL=$G(ORWX("MAX")) + Q +SCHREQ(VAL,OI,RTE,DRG) ; return 1 if schedule is required + ; OI=orderable item, RTE=ptr route, DRG=ptr dispense drug + S VAL=1 + Q:'$G(OI) Q:'$G(RTE) + S VAL=$$SCHREQ^PSJORPOE(RTE,OI,+$G(DRG)) + Q +CHKPI(VAL,ODIFN) ; return pre-existing patient instruct + N IDNUM,IDPI + S (IDNUM,IDPI)=0,VAL="" + I '$D(^OR(100,ODIFN,4.5,"ID","PI")) S VAL="" Q + F S IDNUM=$O(^OR(100,ODIFN,4.5,"ID","PI",IDNUM)) Q:'IDNUM D + . F S IDPI=$O(^OR(100,ODIFN,4.5,IDNUM,2,IDPI)) Q:'IDPI D + .. S VAL=VAL_^OR(100,ODIFN,4.5,IDNUM,2,IDPI,0) + K IDNUM,IDPI + Q +CHKGRP(VAL,ORIFN) ; + ;Inpatient Med Order Group or Clin Meds Group: return 1 + ;If order belong to Outpatient Med Order Grpoup: return 2 + ;Otherwise, return 0 + S VAL=0 + I '$L(ORIFN) Q + N UDGRP,IPGRP,OPGRP,ODGRP,ODID,CLMED + S ODID=+ORIFN + Q:ODID<1 + S (UDGRP,IPGRP,OPGRP,ODGRP,CLMED)=0 + S UDGRP=$O(^ORD(100.98,"B","UD RX",UDGRP)) + S OPGRP=$O(^ORD(100.98,"B","OUTPATIENT MEDICATIONS",OPGRP)) + S IPGRP=$O(^ORD(100.98,"B","INPATIENT MEDICATIONS",IPGRP)) + S CLMED=$O(^ORD(100.98,"B","CLINIC ORDERS",CLMED)) + S:IPGRP=0 IPGRP=$O(^ORD(100.98,"B","I RX",IPGRP)) + I $L($G(^OR(100,ODID,0)))<1 Q + S ODGRP=$P(^OR(100,ODID,0),U,11) + I (UDGRP=ODGRP)!(CLMED=ODGRP) S VAL=1 + I IPGRP=ODGRP S VAL=1 + I OPGRP=ODGRP S VAL=2 + K UDGRP,ODGRP,OPGRP,IPGRP,ODID,CLMED + Q +QOGRP(VAL,QOIFN) ; + ;If quick order belong to Inpatient Med Order Group: return 1 + ;Otherwise, return 0 + S VAL=0 + I '$L(QOIFN) Q + N UDGRP,IPGRP,QOGRP,QOID,CLMED + S QOID=+QOIFN + Q:QOID<1 + S (UDGRP,IPGRP,QOGRP,CLMED)=0 + S UDGRP=$O(^ORD(100.98,"B","UD RX",UDGRP)) + S IPGRP=$O(^ORD(100.98,"B","INPATIENT MEDICATIONS",IPGRP)) + S CLMED=$O(^ORD(100.98,"B","CLINIC ORDERS",CLMED)) + S:IPGRP=0 IPGRP=$O(^ORD(100.98,"B","I RX",IPGRP)) + I $L($G(^ORD(101.41,QOID,0)))<1 Q + S QOGRP=$P(^ORD(101.41,QOID,0),U,5) + I UDGRP=QOGRP S VAL=1 + I (IPGRP=QOGRP)!(CLMED=QOGRP) S VAL=1 + K UDGRP,QOGRP,QOID,IPGRP,CLMED + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDPS32.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDPS32.m index f8c1b126..0b6cb84c 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDPS32.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDPS32.m @@ -1,227 +1,235 @@ -ORWDPS32 ; SLC/KCM - Pharmacy Calls for GUI Dialog ; 02/11/2008 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,94,190,195,243**;Dec 17, 1997;Build 242 - ;Per VHA Directive 2004-038, this routine should not be modified. -NXT() ; -- ret next available index in data array - S ILST=ILST+1 - Q ILST - ; -DLGSLCT(LST,PSTYPE,DFN,LOCIEN) ; return def lists for dialog - ; PSTYPE: pharmacy type (U=unit dose, F=IV fluids, O=outpt) - N ILST S ILST=0 - I PSTYPE="F" D Q ; IV Fluids - . S LST($$NXT)="~ShortList" D SHORT - . S LST($$NXT)="~Priorities" D PRIOR - . ;S LST($$NXT)="~Schedules" D SCHED(LOCIEN) - . S LST($$NXT)="~Route" D IVROUTE - ; - S LST($$NXT)="~ShortList" D SHORT ; Unit Dose & Outpt - ;S LST($$NXT)="~Schedules" D SCHED(LOCIEN) - S LST($$NXT)="~Priorities" D PRIOR - I PSTYPE="O" D ; Outpt - . S LST($$NXT)="~Pickup" D PICKUP - . S LST($$NXT)="~SCStatus" D SCLIST - Q -SHORT ; from DLGSLCT, get short list of med quick orders - ; !!! change this so that it uses the ORWDXQ call!!! - N I,X,TMP - I PSTYPE="U" S X="UD RX" - I PSTYPE="F" S X="IV RX" - I PSTYPE="O" S X="O RX" - D GETQLST^ORWDXQ(.TMP,X,"iQ") - S I=0 F S I=$O(TMP(I)) Q:'I S LST($$NXT)=TMP(I) - Q -SCHEDA ; (similar to SCHED, but also rtns admin times) - N X,IEN,SCH,TIME - K ^TMP($J,"ORWDPS32 SCHEDA") - D AP^PSS51P1("PSJ",,,,"ORWDPS32 SCHEDA") - S SCH="" F S SCH=$O(^TMP($J,"ORWDPS32 SCHEDA","APPSJ",SCH)) Q:SCH="" D - .S IEN="" F S IEN=$O(^TMP($J,"ORWDPS32 SCHEDA","APPSJ",SCH,IEN)) Q:IEN'>0 D - ..S TIME=$G(^TMP($J,"ORWDPS32 SCHEDA",IEN,1)) - ..S X=$S($L(TIME):" ("_TIME_")",1:"") - ..S LST($$NXT)="i"_IEN_U_SCH_U_X - K ^TMP($J,"ORWDPS32 SCHEDA") - Q - ; -IVROUTE ; - N ABB,EXP,IEN,RTE - K ^TMP($J,"ORWDPS32 IVROUTE") - D ALL^PSS51P2(,"??",,1,"ORWDPS32 IVROUTE") - S RTE="" F S RTE=$O(^TMP($J,"ORWDPS32 IVROUTE","B",RTE)) Q:RTE="" D - .S IEN=$O(^TMP($J,"ORWDPS32 IVROUTE","IV",RTE,"")) Q:IEN'>0 - .S ABB=$G(^TMP($J,"ORWDPS32 IVROUTE",IEN,1)) - .S EXP=$G(^TMP($J,"ORWDPS32 IVROUTE",IEN,4)) - .S LST($$NXT)="i"_IEN_U_RTE_U_ABB_U_EXP - K ^TMP($J,"ORWDPS32 IVROUTE") - Q - ; -ALLIVRTE(LST) ; - N ABB,CNT,EXP,IEN,RTE - K ^TMP($J,"ORWDPS32 ALLIVRTE") - S CNT=0 - D ALL^PSS51P2(,"??",,1,"ORWDPS32 ALLIVRTE") - S RTE="" F S RTE=$O(^TMP($J,"ORWDPS32 ALLIVRTE","B",RTE)) Q:RTE="" D - .S IEN=$O(^TMP($J,"ORWDPS32 ALLIVRTE","IV",RTE,"")) Q:IEN'>0 - .S ABB=$G(^TMP($J,"ORWDPS32 ALLIVRTE",IEN,1)) - .S EXP=$G(^TMP($J,"ORWDPS32 ALLIVRTE",IEN,4)) - .S CNT=CNT+1,LST(CNT)=IEN_U_RTE_U_ABB_U_U_U_U - K ^TMP($J,"ORWDPS32 IVROUTE") - Q - ; -ROUTE ; from OISLCT^ORWDPS32, get list of routes for the drug form - ; ** NEED BOTH ABBREVIATION & NAME IN LIST BOX - N I,CNT,ABBR,IEN,ROUT,X - S I="" F S I=$O(^TMP("PSJMR",$J,I)) Q:I="" D - . S ROUT=$P(^TMP("PSJMR",$J,I),U),ABBR=$P(^(I),U,2),IEN=$P(^(I),U,3) - . S LST($$NXT)="i"_IEN_U_ROUT_U_ABBR - . I I=1,IEN S LST($$NXT)="d"_IEN_U_ROUT ;_U_ABBR ; assume first always default - S I="" F S I=$O(^TMP("PSJMR",$J,I)) Q:I="" D - . S ROUT=$P(^TMP("PSJMR",$J,I),U),ABBR=$P(^(I),U,2),IEN=$P(^(I),U,3) - . I $L(ABBR),(ABBR'=ROUT) S LST($$NXT)="i"_IEN_U_ABBR_" ("_ROUT_")"_U_ABBR - Q - ;similar to SCHED^ORWDPS32, also returns Admin Time for Patient ward location - ;AGP CPRS 27.72 THIS CODE IS NOT NEEDED ANYMORE -SCHED(LOCIEN) ; - N CNT,ORARRAY,SCH,IEN,EXP,TIME,TYP,X0,WIEN - ;K ^TMP($J,"ORWDPS32 SCHED1") - S WIEN=$$WARDIEN(+LOCIEN) - D SCHED^PSS51P1(WIEN,.ORARRAY) - S CNT=0 F S CNT=$O(ORARRAY(CNT)) Q:CNT'>0 D - .S LST($$NXT)="i"_$P(ORARRAY(CNT),U,2,5) - Q - ; -WARDIEN(LOCIEN) ; - N RESULT - S RESULT=0 - I LOCIEN=0 Q RESULT - I $P($G(^SC(LOCIEN,42)),U)="" Q RESULT - S RESULT=+$P($G(^SC(LOCIEN,42)),U) - Q RESULT -PRIOR ; from DLGSLCT, get list of allowed priorities - N X,XREF - S XREF=$S(PSTYPE="O":"S.PSO",1:"S.PSJ") - S X="" F S X=$O(^ORD(101.42,XREF,X)) Q:'$L(X) D - . S LST($$NXT)="i"_$O(^ORD(101.42,XREF,X,0))_U_X - S LST($$NXT)="d"_$O(^ORD(101.42,"B","ROUTINE",0))_U_"ROUTINE" - Q -PICKUP ; from DLGSLCT, get prescription routing - N X,EDITONLY - F X="W^at Window","M^by Mail","C^in Clinic" S LST($$NXT)="i"_X - S X=$$DEFPICK I $L(X) S LST($$NXT)="d"_X - Q -DEFPICK() ; ret def routing - N X,DLG,PRMT - S DLG=$O(^ORD(101.41,"AB","PSO OERR",0)),X="" - S PRMT=$O(^ORD(101.41,"AB","OR GTX ROUTING",0)) - I $D(^TMP("ORECALL",$J,+DLG,+PRMT,1)) S X=^(1) - I X'="" S EDITONLY=1 Q X ; EDITONLY used by def action - ; - S X=$$GET^XPAR("ALL","ORWDPS ROUTING DEFAULT",1,"I") - I X="C" S X="C^in Clinic" G XPICK - I X="M" S X="M^by Mail" G XPICK - I X="W" S X="W^at Window" G XPICK - I X="N" S X="" G XPICK - I X="" S X=$S($D(^PSX(550,"C")):"M^by Mail",1:"W^at Window") -XPICK Q X - ; -SCLIST ; from DLGSLCT, get options for service connected - F X="0^No","1^Yes" S LST($$NXT)="i"_X - Q - ; -OISLCT(LST,OI,PSTYPE,ORVP) ; rtn for defaults for pharm OI - N ILST S ILST=0 - K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) - S LST($$NXT)="~Dispense" D DISPDRG - S LST($$NXT)="~Instruct" D INSTRCT - S LST($$NXT)="~Route" D ROUTE - S LST($$NXT)="~Message" D MESSAGE - I $L($G(^TMP("PSJSCH",$J))) S LST($$NXT)="~DefSched",LST($$NXT)="d"_^($J) - K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) - Q - ; -DISPDRUG(LST,OI) ; list dispense drugs for an OI - N ILST,PSTYPE S ILST=0,PSTYPE="U" D DISPDRG - Q - ; -DISPDRG ; from OISLCT, get disp drugs for this pharm OI - N I,ORTMP,ORX - S ORX=$T(ENDD^PSJORUTL),ORX=$L($P(ORX,";"),",") - I ORX>3 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP,+ORVP) - I ORX'>3 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP) - S I="" F S I=$O(ORTMP(I)) Q:I="" D - . I $P(ORTMP(I),U,4)="1" S $P(ORTMP(I),U,4)="NF" - . S $P(ORTMP(I),U,3)="$"_$P(ORTMP(I),U,3)_" per "_$P(ORTMP(I),U,5) - . S LST($$NXT)="i"_ORTMP(I) - Q -INSTRCT ; from OISLCT, get list of potential instructs (based on drug form) - N INOUN,NOUN,IINS,INS,VERB,INSREC - D START^PSSJORDF(+$P(^ORD(101.43,OI,0),U,2)) - I PSTYPE="U" Q ; don't use the instructions list for inpatients - S IINS=0 F S IINS=$O(^TMP("PSJINS",$J,IINS)) Q:'IINS D - . S INSREC=$G(^TMP("PSJINS",$J,IINS)) - . I '$D(VERB) S VERB=$P(INSREC,U) - . I $L($P(INSREC,U,2)) S LST($$NXT)="i"_$P(INSREC,U,2) - S LST($$NXT)="~Nouns" - S INOUN=0 F S INOUN=$O(^TMP("PSJNOUN",$J,INOUN)) Q:'INOUN D - . S LST($$NXT)="i"_$P(^TMP("PSJNOUN",$J,INOUN),U) - I $D(VERB) S LST($$NXT)="~Verb",LST($$NXT)="d"_VERB - ; - Q -MIXED(X) ; Return mixed case - Q X - ; -MESSAGE ; message - S I=0 F S I=$O(^ORD(101.43,OI,8,I)) Q:I'>0 S LST($$NXT)="t"_^(I,0) - Q -ALLROUTE(LST) ; returns a list of all available med routes - N I,X,ILST - S ILST=0 - K ^TMP($J,"ORWDPS32 ALLROUTE") - D ALL^PSS51P2(,"??",,,"ORWDPS32 ALLROUTE") - S I=0 F S I=$O(^TMP($J,"ORWDPS32 ALLROUTE",I)) Q:'I D - . I +$P(^TMP($J,"ORWDPS32 ALLROUTE",I,3),U)>0 S LST($$NXT)=I_U_^TMP($J,"ORWDPS32 ALLROUTE",I,.01)_U_^TMP($J,"ORWDPS32 ALLROUTE",I,1) - K ^TMP($J,"ORWDPS32 ALLROUTE") - Q -VALROUTE(REC,X) ; validates route name & returns IEN + abbreviation - N ABBR,NAME,IEN - K ^TMP($J,"ORWDPS32 VALROUTE") - S X=$$UPPER(X) - D ALL^PSS51P2(,X,,1,"ORWDPS32 VALROUTE") - I $P(^TMP($J,"ORWDPS32 VALROUTE",0),U)=-1 K ^TMP($J,"ORWDPS32 VALROUTE") S REC=0 Q - S IEN=$O(^TMP($J,"ORWDPS32 VALROUTE","B",X,"")) - I IEN'>0 S IEN=$O(^TMP($J,"ORWDPS32 VALROUTE","C",X,"")) - I IEN'>0 S REC=0 Q - S NAME=$G(^TMP($J,"ORWDPS32 VALROUTE",IEN,.01)) - S ABBR=$G(^TMP($J,"ORWDPS32 VALROUTE",IEN,1)) - I '$L(ABBR) S ABBR=NAME - I ($$UPPER(NAME)'=X),($$UPPER(ABBR)'=X) S REC=0 K ^TMP($J,"ORWDPS32 VALROUTE") Q - S REC=IEN_U_ABBR - K ^TMP($J,"ORWDPS32 VALROUTE") - Q -AUTH(VAL,PRV) ; For inpatient meds, check restrictions - N NAME,AUTH,INACT,X S VAL=0 - S NAME=$P($G(^VA(200,PRV,20)),U,2) S:'$L(NAME) NAME=$P(^(0),U) - S X=$G(^VA(200,PRV,"PS")),AUTH=$P(X,U),INACT=$P(X,U,4) - I 'AUTH!(INACT&(DT>INACT)) D Q - . S VAL="1^"_NAME_" is not authorized to write medication orders." - I $D(^XUSEC("OREMAS",DUZ)),'$$GET^XPAR("ALL","OR OREMAS MED ORDERS") D Q - . S VAL="1^OREMAS key holders may not enter medication orders." - Q -AUTHNVA(VAL,PRV) ; For Non-VA meds, check restrictions - N NAME,AUTH,INACT,X S VAL=0 - I $D(^XUSEC("OREMAS",DUZ)),$$GET^XPAR("ALL","OR OREMAS NON-VA MED ORDERS")=2 Q - I $D(^XUSEC("OREMAS",DUZ)),'$$GET^XPAR("ALL","OR OREMAS NON-VA MED ORDERS") D Q - . S VAL="1^OREMAS key holders may not enter non-VA medication orders." - S NAME=$P($G(^VA(200,PRV,20)),U,2) S:'$L(NAME) NAME=$P(^(0),U) - S X=$G(^VA(200,PRV,"PS")),AUTH=$P(X,U),INACT=$P(X,U,4) - I 'AUTH!(INACT&(DT>INACT)) D Q - . S VAL="1^"_NAME_" is not authorized to write medication orders." - Q - ; -UPPER(X) ; return uppercase - Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") - ; -TRIM(X) ; trim leading and trailing spaces - S X=$RE(X) F S:$E(X)=" " X=$E(X,2,999) Q:$E(X)'=" " Q:'$L(X) ;trail - S X=$RE(X) F S:$E(X)=" " X=$E(X,2,999) Q:$E(X)'=" " Q:'$L(X) ;lead - Q X - ; +ORWDPS32 ; SLC/KCM - Pharmacy Calls for GUI Dialog ;08/04/96 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,94,190,195,237**;Dec 17, 1997 + ; +NXT() ; -- ret next available index in data array + S ILST=ILST+1 + Q ILST + ; +DLGSLCT(LST,PSTYPE) ; return def lists for dialog + ; PSTYPE: pharmacy type (U=unit dose, F=IV fluids, O=outpt) + N ILST S ILST=0 + I PSTYPE="F" D Q ; IV Fluids + . S LST($$NXT)="~ShortList" D SHORT + . S LST($$NXT)="~Priorities" D PRIOR + ; + S LST($$NXT)="~ShortList" D SHORT ; Unit Dose & Outpt + S LST($$NXT)="~Schedules" D SCHED + S LST($$NXT)="~Priorities" D PRIOR + I PSTYPE="O" D ; Outpt + . S LST($$NXT)="~Pickup" D PICKUP + . S LST($$NXT)="~SCStatus" D SCLIST + Q +SHORT ; from DLGSLCT, get short list of med quick orders + ; !!! change this so that it uses the ORWDXQ call!!! + N I,X,TMP + I PSTYPE="U" S X="UD RX" + I PSTYPE="F" S X="IV RX" + I PSTYPE="O" S X="O RX" + D GETQLST^ORWDXQ(.TMP,X,"iQ") + S I=0 F S I=$O(TMP(I)) Q:'I S LST($$NXT)=TMP(I) + Q +SCHED ; from DLGSLCT, get all pharm admin scheds + N X + S X="" F S X=$O(^PS(51.1,"APPSJ",X)) Q:X="" S LST($$NXT)="i"_X + Q +SCHEDA ; (similar to SCHED, but also rtns admin times) + N X,IEN,SCH + S SCH="" F S SCH=$O(^PS(51.1,"APPSJ",SCH)) Q:SCH="" D + . S IEN=0 F S IEN=$O(^PS(51.1,"APPSJ",SCH,IEN)) Q:IEN'>0 D + . . S X=^PS(51.1,IEN,0) S X=$S($L($P(X,U,2)):" ("_$P(X,U,2)_")",1:"") + . . S LST($$NXT)="i"_IEN_U_SCH_X + Q +PRIOR ; from DLGSLCT, get list of allowed priorities + N X,XREF + S XREF=$S(PSTYPE="O":"S.PSO",1:"S.PSJ") + S X="" F S X=$O(^ORD(101.42,XREF,X)) Q:'$L(X) D + . S LST($$NXT)="i"_$O(^ORD(101.42,XREF,X,0))_U_X + S LST($$NXT)="d"_$O(^ORD(101.42,"B","ROUTINE",0))_U_"ROUTINE" + Q +PICKUP ; from DLGSLCT, get prescription routing + N X,EDITONLY + F X="W^at Window","M^by Mail","C^in Clinic" S LST($$NXT)="i"_X + S X=$$DEFPICK I $L(X) S LST($$NXT)="d"_X + Q +DEFPICK() ; ret def routing + N X,DLG,PRMT + S DLG=$O(^ORD(101.41,"AB","PSO OERR",0)),X="" + S PRMT=$O(^ORD(101.41,"AB","OR GTX ROUTING",0)) + I $D(^TMP("ORECALL",$J,+DLG,+PRMT,1)) S X=^(1) + I X'="" S EDITONLY=1 Q X ; EDITONLY used by def action + ; + S X=$$GET^XPAR("ALL","ORWDPS ROUTING DEFAULT",1,"I") + I X="C" S X="C^in Clinic" G XPICK + I X="M" S X="M^by Mail" G XPICK + I X="W" S X="W^at Window" G XPICK + I X="N" S X="" G XPICK + I X="" S X=$S($D(^PSX(550,"C")):"M^by Mail",1:"W^at Window") +XPICK Q X + ; +SCLIST ; from DLGSLCT, get options for service connected + F X="0^No","1^Yes" S LST($$NXT)="i"_X + Q + ; +OISLCT(LST,OI,PSTYPE,ORVP) ; rtn for defaults for pharm OI + N ILST S ILST=0 + K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) + S LST($$NXT)="~Dispense" D DISPDRG + S LST($$NXT)="~Instruct" D INSTRCT + S LST($$NXT)="~Route" D ROUTE + S LST($$NXT)="~Message" D MESSAGE + I $L($G(^TMP("PSJSCH",$J))) S LST($$NXT)="~DefSched",LST($$NXT)="d"_^($J) + K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) + Q + ; +DISPDRUG(LST,OI) ; list dispense drugs for an OI + N ILST,PSTYPE S ILST=0,PSTYPE="U" D DISPDRG + Q + ; +DISPDRG ; from OISLCT, get disp drugs for this pharm OI + N I,ORTMP,ORX + S ORX=$T(ENDD^PSJORUTL),ORX=$L($P(ORX,";"),",") + I ORX>3 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP,+ORVP) + I ORX'>3 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP) + S I="" F S I=$O(ORTMP(I)) Q:I="" D + . I $P(ORTMP(I),U,4)="1" S $P(ORTMP(I),U,4)="NF" + . S $P(ORTMP(I),U,3)="$"_$P(ORTMP(I),U,3)_" per "_$P(ORTMP(I),U,5) + . S LST($$NXT)="i"_ORTMP(I) + Q +INSTRCT ; from OISLCT, get list of potential instructs (based on drug form) + N INOUN,NOUN,IINS,INS,VERB,INSREC + D START^PSSJORDF(+$P(^ORD(101.43,OI,0),U,2)) + I PSTYPE="U" Q ; don't use the instructions list for inpatients + S IINS=0 F S IINS=$O(^TMP("PSJINS",$J,IINS)) Q:'IINS D + . S INSREC=$G(^TMP("PSJINS",$J,IINS)) + . I '$D(VERB) S VERB=$P(INSREC,U) + . I $L($P(INSREC,U,2)) S LST($$NXT)="i"_$P(INSREC,U,2) + S LST($$NXT)="~Nouns" + S INOUN=0 F S INOUN=$O(^TMP("PSJNOUN",$J,INOUN)) Q:'INOUN D + . S LST($$NXT)="i"_$P(^TMP("PSJNOUN",$J,INOUN),U) + I $D(VERB) S LST($$NXT)="~Verb",LST($$NXT)="d"_VERB + ; + Q +MIXED(X) ; Return mixed case + Q X ;$E(X)_$TR($E(X,2,$L(X)),"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz") + ; +ROUTE ; from OISLCT, get list of routes for the drug form + ; ** NEED BOTH ABBREVIATION & NAME IN LIST BOX + N I,CNT,ABBR,IEN,ROUT,X + S I="" F S I=$O(^TMP("PSJMR",$J,I)) Q:I="" D + . S ROUT=$P(^TMP("PSJMR",$J,I),U),ABBR=$P(^(I),U,2),IEN=$P(^(I),U,3) + . S LST($$NXT)="i"_IEN_U_ROUT_U_ABBR + . I I=1,IEN S LST($$NXT)="d"_IEN_U_ROUT ;_U_ABBR ; assume first always default + S I="" F S I=$O(^TMP("PSJMR",$J,I)) Q:I="" D + . S ROUT=$P(^TMP("PSJMR",$J,I),U),ABBR=$P(^(I),U,2),IEN=$P(^(I),U,3) + . I $L(ABBR),(ABBR'=ROUT) S LST($$NXT)="i"_IEN_U_ABBR_" ("_ROUT_")"_U_ABBR + Q +MESSAGE ; message + S I=0 F S I=$O(^ORD(101.43,OI,8,I)) Q:I'>0 S LST($$NXT)="t"_^(I,0) + Q +ALLROUTE(LST) ; returns a list of all available med routes + N I,X,ILST S ILST=0 + S I=0 F S I=$O(^PS(51.2,I)) Q:'I S X=^(I,0) D + . I $P(X,U,4) S LST($$NXT)=I_U_$P(X,U)_U_$P(X,U,3) + Q +VALROUTE(REC,X) ; validates route name & returns IEN + abbreviation + N ORLST,ABBR + D FIND^DIC(51.2,"",1,"MO",X,1,,"I $P(^(0),U,4)=1",,"ORLST") + I 'ORLST("DILIST",0) S REC=0 Q + S X=$$UPPER(X),ABBR=ORLST("DILIST","ID",1,1) + I '$L(ABBR) S ABBR=ORLST("DILIST",1,1) + I ($$UPPER(ORLST("DILIST",1,1))'=X),($$UPPER(ABBR)'=X) S REC=0 Q + S REC=ORLST("DILIST",2,1)_U_ABBR + Q +AUTH(VAL,PRV) ; For inpatient meds, check restrictions + N NAME,AUTH,INACT,X S VAL=0 + S NAME=$P($G(^VA(200,PRV,20)),U,2) S:'$L(NAME) NAME=$P(^(0),U) + S X=$G(^VA(200,PRV,"PS")),AUTH=$P(X,U),INACT=$P(X,U,4) + I 'AUTH!(INACT&(DT>INACT)) D Q + . S VAL="1^"_NAME_" is not authorized to write medication orders." + I $D(^XUSEC("OREMAS",DUZ)),'$$GET^XPAR("ALL","OR OREMAS MED ORDERS") D Q + . S VAL="1^OREMAS key holders may not enter medication orders." + Q +AUTHNVA(VAL,PRV) ; For Non-VA meds, check restrictions + N NAME,AUTH,INACT,X S VAL=0 + I $D(^XUSEC("OREMAS",DUZ)),$$GET^XPAR("ALL","OR OREMAS NON-VA MED ORDERS")=2 Q + I $D(^XUSEC("OREMAS",DUZ)),'$$GET^XPAR("ALL","OR OREMAS NON-VA MED ORDERS") D Q + . S VAL="1^OREMAS key holders may not enter non-VA medication orders." + S NAME=$P($G(^VA(200,PRV,20)),U,2) S:'$L(NAME) NAME=$P(^(0),U) + S X=$G(^VA(200,PRV,"PS")),AUTH=$P(X,U),INACT=$P(X,U,4) + I 'AUTH!(INACT&(DT>INACT)) D Q + . S VAL="1^"_NAME_" is not authorized to write medication orders." + Q +DRUGMSG(VAL,IEN) ; return any message associated with a dispense drug + N X S X=$$ENDCM^PSJORUTL(IEN) + S VAL=$P(X,U,2)_U_$P(X,U,4) + Q +MEDISIV(VAL,IEN) ; return true if orderable item is IV medication + S VAL=0 + I $P($G(^ORD(101.43,IEN,"PS")),U)=2 S VAL=1 + Q +ISSPLY(VAL,IEN) ; return true if orderable item is a supply + S VAL=0 + I $P($G(^ORD(101.43,IEN,"PS")),U,5)=1 S VAL=1 + Q +IVAMT(VAL,OI,ORWTYP) ; return UNITS^AMOUNT |^AMOUNT^AMOUNT...| for IV soln + N I,PSOI,ORWY,AMT + S PSOI=+$P($G(^ORD(101.43,OI,0)),U,2)_ORWTYP,VAL="" + D ENVOL^PSJORUT2(PSOI,.ORWY) + I ORWTYP="B" D + . S I=0 F S I=$O(ORWY(I)) Q:I'>0 S AMT(+ORWY(I))="" + . S AMT=0,VAL="ML" F S AMT=$O(AMT(AMT)) Q:AMT'>0 S VAL=VAL_U_AMT + I ORWTYP="A" D + . S I=+$O(ORWY(0)) S VAL=$P($G(ORWY(I)),U,2) + . I '$L(VAL) S VAL="ML^LITER^MCG^MG^GM^UNITS^IU^MEQ^MM^MU^THOUU^MG-PE^NANOGRAM" + Q +VALRATE(VAL,X) ; return "1" (true) if IV rate text is valid + I $E($RE($$UPPER(X)),1,5)="RH/LM" S X=$E(X,1,$L(X)-5) + S X=$$TRIM(X) + D ORINF^PSIVSP S VAL=$G(X) ;S OK=$S($D(X):1,1:0) + Q +UPPER(X) ; return uppercase + Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") + ; +TRIM(X) ; trim leading and trailing spaces + S X=$RE(X) F S:$E(X)=" " X=$E(X,2,999) Q:$E(X)'=" " Q:'$L(X) ;trail + S X=$RE(X) F S:$E(X)=" " X=$E(X,2,999) Q:$E(X)'=" " Q:'$L(X) ;lead + Q X +SCSTS(VAL,ORVP,ORDRUG) ; return service connected eligibility for patient + N ORWP94 S ORWP94=$O(^ORD(101.41,"AB","PS MEDS",0))>0 + I $L($T(SC^PSOCP)),$$SC^PSOCP(+ORVP,+$G(ORDRUG)) S VAL=0 G XSCSTS + I 'ORWP94,(+$$RXST^IBARXEU(+ORVP)>0) S VAL=0 G XSCSTS + S VAL=1 +XSCSTS Q +FORMALT(ORLST,IEN,PSTYPE) ; return a list of formulary alternatives + D ENRFA^PSJORUTL(IEN,PSTYPE,.ORLST) + S I=0 F S I=$O(ORLST(I)) Q:'I D + . S OI=+$O(^ORD(101.43,"ID",+$P(ORLST(I),U,4)_";99PSP",0)) + . S $P(ORLST(I),U,4)=OI I OI S $P(ORLST(I),U,5)=$P(^ORD(101.43,OI,0),U) + Q +VALSCH(OK,X,PSTYPE) ; validate a schedule, return 1 if valid, 0 if not + I '$L($T(EN^PSSGSGUI)) S OK=-1 Q + I $E($T(EN^PSSGSGUI),1,4)="EN(X" D + . N ORX S ORX=$G(X) D EN^PSSGSGUI(.ORX,$G(PSTYPE,"I")) + . K X S:$D(ORX) X=ORX + E D + . D EN^PSSGSGUI + S OK=$S($D(X):1,1:0) + Q +VALQTY(OK,X) ; validate a quantity, return 1 if valid, 0 if not + ; to be compatible with LM, make sure X is integer from 1 to 240 + ; this is based on the input transform from 52,7 + K:(+X'>0)!(+X>99999999)!(X'?.8N.1".".2N)!($L(X)>12) X + S OK=$S($D(X):1,1:0) + Q +DOSES(LST,OI) ; return doses for an orderable item - TEST ONLY + N ORTMP,ORI,ORJ,ILST,NDF,VAPN,X,PSTYPE S PSTYPE="O" + D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP) + S ORI=0 F S ORI=$O(ORTMP(ORI)) Q:'ORI S ORWDRG=+ORTMP(ORI) D + . S NDF=$G(^PSDRUG(+ORWDRG,"ND")),VAPN=$P(NDF,U,3),NDF=+NDF + . S X=$$DFSU^PSNAPIS(NDF,VAPN) + . S LSTA($P(X,U,4),$P(X,U,6))="" + . I +$P(X,U,4)=$P(X,U,4) S LSTA($P(X,U,4)*2,$P(X,U,6))="" + S ORI="",ILST=0 F S ORI=$O(LSTA(ORI)) Q:ORI="" D + . S ORJ="" F S ORJ=$O(LSTA(ORI,ORJ)) Q:ORJ="" D + . . S ILST=ILST+1,LST(ILST)=ORI_" "_ORJ + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDPS4.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDPS4.m index 9725799b..2af6dea2 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDPS4.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDPS4.m @@ -1,131 +1,128 @@ -ORWDPS4 ;; SLC/JDL - Order Dialogs CO-PAY and Other;[12/31/01 6:38pm] - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**116,125,131,141,173,187,190,195,215,243**;Dec 17, 1997;Build 242 - ; -CPLST(TEST,PTIFN,ORIFNS) ; --Get CP questions - N ORIFN,ORDA,ORI,ORPSO,CPX - S ORI=0,ORPSO=+$O(^DIC(9.4,"C","PSO",0)) - F S ORI=$O(ORIFNS(ORI)) Q:'ORI D - .S ORIFN=+ORIFNS(ORI),ORDA=$P(ORIFNS(ORI),";",2) - .I $D(^OR(100,ORIFN,0)),($P(^OR(100,ORIFN,0),U,14)=ORPSO) D - ..N PRIO S PRIO=0 - ..I $D(^OR(100,ORIFN,4.5,"ID","URGENCY")) S PRIO=$O(^("URGENCY",0)) - ..S PRIO=$G(^OR(100,ORIFN,4.5,+PRIO,1)) - ..Q:PRIO=99 - ..S CPX=$$SC(ORIFN) - ..I $L(CPX)>1 S TEST(ORIFN)=ORIFN_";"_ORDA_CPX - K PTIFN,ORIFN,ORDA,ORI,CPX - Q - ; -CPINFO(Y,ORINFO) ; -- Save reponses to CP questions - Q:'$D(ORINFO) - N ORIFN,ORI,ORX,ANS S ORI=0 - F S ORI=$O(ORINFO(ORI)) Q:'ORI D - .S ORIFN=$P($P(ORINFO(ORI),U,1),";",1) - .S ANS=$P(ORINFO(ORI),U,2) - .D REFMT(.ORX,ANS) - .D SC^ORCSAVE2(.ORX,ORIFN) - S Y=1 - K ORIFN,ORX,ORI,ANS - Q - ; -SC(ORIFN) ; -- Dialog validation, to ask CP questions - ;Expects ORIFN and ORDA - ; - N DR S DR="" - I '$L($T(SCNEW^PSOCP))!('$G(ORIFN))!('$G(ORDA)) Q DR - I $P($G(^OR(100,ORIFN,8,ORDA,0)),U,2)'="NW" Q DR - ; - N OR3,ORDRUG,ORENEW,ORX,I,XACT,YACT,CPNODE,ASC,AAO,AIR,AEC,AMST,AHNC,ACV,ASHD - S ORX="",XACT="" - ;--Only new, renew, edited, copied outpatient order can continue... - ;AGP CHANGE 26.65, will returned service connection data for change orders - S OR3=$G(^OR(100,ORIFN,3)),XACT=$P(OR3,U,11) I (XACT'=0)&(XACT'=1)&((XACT'=2)&(XACT'="C")) Q DR - I (XACT=1)&($D(^OR(100,ORIFN,5))=0) Q DR - I $D(^OR(100,ORIFN,5))>0 D - .S CPNODE=$G(^OR(100,ORIFN,5)) - .S ASC=$S($L($P(CPNODE,"^",1)):"SC;"_$P(CPNODE,"^",1),1:"") - .S DR=$S($L(ASC):DR_U_ASC,1:DR) - .S AAO=$S($L($P(CPNODE,"^",3)):"AO;"_$P(CPNODE,"^",3),1:"") - .S DR=$S($L(AAO):DR_U_AAO,1:DR) - .S AIR=$S($L($P(CPNODE,"^",4)):"IR;"_$P(CPNODE,"^",4),1:"") - .S DR=$S($L(AIR):DR_U_AIR,1:DR) - .S AEC=$S($L($P(CPNODE,"^",5)):"EC;"_$P(CPNODE,"^",5),1:"") - .S DR=$S($L(AEC):DR_U_AEC,1:DR) - .S AMST=$S($L($P(CPNODE,"^",2)):"MST;"_$P(CPNODE,"^",2),1:"") - .S DR=$S($L(AMST):DR_U_AMST,1:DR) - .S AHNC=$S($L($P(CPNODE,"^",6)):"HNC;"_$P(CPNODE,"^",6),1:"") - .S DR=$S($L(AHNC):DR_U_AHNC,1:DR) - .S ACV=$S($L($P(CPNODE,"^",7)):"CV;"_$P(CPNODE,"^",7),1:"") - .S DR=$S($L(ACV):DR_U_ACV,1:DR) - .S ASHD=$S($L($P(CPNODE,"^",8)):"SHD;"_$P(CPNODE,"^",8),1:"") - .S DR=$S($L(ASHD):DR_U_ASHD,1:DR) - .D CPCOMP(.DR) - .K ASC,AAO,AIR,AEC,AMST,AHNC,CPNODE - I $L(DR)>0 Q DR - I XACT=2 S YACT=$P(OR3,U,5),ORENEW=$G(^OR(100,YACT,4)) ;get PS# if renewal - S ORDRUG=$$VALUE^ORCSAVE2(ORIFN,"DRUG") - D SCNEW^PSOCP(.ORX,+PTIFN,ORDRUG,$G(ORENEW)) I '$D(ORX) Q DR - F I="SC","AO","IR","EC","MST","HNC","CV","SHD" D - . I $D(ORX(I)) S DR=DR_U_I_$S($L(ORX(I)):";"_ORX(I),1:"") - Q DR -REFMT(ORX,INFO) ; - ;"U": Unchecked ("NO") - ;"C": Checked ("YES") - ;"N" : Question not asked - N RST,RST1 - S RST="" - F I=1:1:$L(INFO) S RST=RST_U_$S($E(INFO,I)="U":0,$E(INFO,I)="C":1,1:"") - S RST1=$E(RST,2,$L(RST)) - S ORX("SC")=$P(RST1,U,1) - S ORX("MST")=$P(RST1,U,5) - S ORX("AO")=$P(RST1,U,2) - S ORX("IR")=$P(RST1,U,3) - S ORX("EC")=$P(RST1,U,4) - S ORX("HNC")=$P(RST1,U,6) - S ORX("CV")=$P(RST1,U,7) - S ORX("SHD")=$P(RST1,U,8) - K RST,RST1 - Q -CPCOMP(PREX) ; -- Compare the existed exemptions with new exemption questions - N ORX1,ORDRUG1,CPI,LSTCP,TMPVAL - S LSTCP="" - S ORDRUG1=$$VALUE^ORCSAVE2(ORIFN,"DRUG") - D SCNEW^PSOCP(.ORX1,+PTIFN,ORDRUG1,$G(ORENEW)) I '$D(ORX1) Q - F CPI="SC","AO","IR","EC","MST","HNC","CV","SHD" D - . I $D(ORX1(CPI)) D - . . S TMPVAL="" - . . I $F(PREX,CPI) D - . . . S TMPVAL=+$E(PREX,$F(PREX,CPI)+1) - . . . I $L(TMPVAL),((TMPVAL=0)!(TMPVAL=1)) S TMPVAL=CPI_";"_TMPVAL - . . . E S TMPVAL=CPI - . . E S TMPVAL=CPI - . . S LSTCP=LSTCP_U_TMPVAL - S PREX=LSTCP - Q -IPOD4OP(ORY,ORID) ;True: is an Inpt (IV OI) order on an OutPatient - Q:'$D(^OR(100,+ORID,0)) - S ORY=0 - N APKG,ADLG,ADG,APTCLS,RXDG,UDDLG,IPPKG - S (RXDG,UDDLG,IPPKG)=0 - S RXDG=+$O(^ORD(100.98,"B","O RX",0)) - S UDDLG=+$O(^ORD(101.41,"B","PSJ OR PAT OE",0)) - S IPPKG=+$O(^DIC(9.4,"B","INPATIENT MEDICATIONS",0)) - S ADLG=+$P($G(^OR(100,+ORID,0)),U,5) - S ADG=$P($G(^OR(100,+ORID,0)),U,11) - S APKG=$P($G(^OR(100,+ORID,0)),U,14) - S APTCLS=$P($G(^OR(100,+ORID,0)),U,12) - I ADG=RXDG,(ADLG=UDDLG),(APKG=IPPKG),(APTCLS="I") S ORY=1 - Q - ; -UPDTDG(ORY,ORID) ;Update Inpt order for outpatient DG to Inpt DG - Q:'$D(^OR(100,+ORID,0)) - N UDDG - S UDDG=$O(^ORD(100.98,"B","UD RX",0)) - S $P(^OR(100,+ORID,0),U,11)=UDDG - Q -ISUDIV(ORY,ORIFN) ;True: OI of the order is for both UD and IV - N OI - S (OI,ORY)=0 - S OI=+$O(^OR(100,+$G(ORIFN),.1,"B",0)) Q:OI<1 - I $O(^ORD(101.43,OI,9,"B","IVM RX",0)) S ORY=1 - Q +ORWDPS4 ;; SLC/JDL - Order Dialogs CO-PAY and Other;[12/31/01 6:38pm] + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**116,125,131,141,173,187,190,195,215**;Dec 17, 1997 + ; +CPLST(TEST,PTIFN,ORIFNS) ; --Get CP questions + N ORIFN,ORDA,ORI,ORPSO,CPX + S ORI=0,ORPSO=+$O(^DIC(9.4,"C","PSO",0)) + F S ORI=$O(ORIFNS(ORI)) Q:'ORI D + .S ORIFN=+ORIFNS(ORI),ORDA=$P(ORIFNS(ORI),";",2) + .I $D(^OR(100,ORIFN,0)),($P(^OR(100,ORIFN,0),U,14)=ORPSO) D + ..N PRIO S PRIO=0 + ..I $D(^OR(100,ORIFN,4.5,"ID","URGENCY")) S PRIO=$O(^("URGENCY",0)) + ..S PRIO=$G(^OR(100,ORIFN,4.5,+PRIO,1)) + ..Q:PRIO=99 + ..S CPX=$$SC(ORIFN) + ..I $L(CPX)>1 S TEST(ORIFN)=ORIFN_";"_ORDA_CPX + K PTIFN,ORIFN,ORDA,ORI,CPX + Q + ; +CPINFO(Y,ORINFO) ; -- Save reponses to CP questions + Q:'$D(ORINFO) + N ORIFN,ORI,ORX,ANS S ORI=0 + F S ORI=$O(ORINFO(ORI)) Q:'ORI D + .S ORIFN=$P($P(ORINFO(ORI),U,1),";",1) + .S ANS=$P(ORINFO(ORI),U,2) + .D REFMT(.ORX,ANS) + .D SC^ORCSAVE2(.ORX,ORIFN) + S Y=1 + K ORIFN,ORX,ORI,ANS + Q + ; +SC(ORIFN) ; -- Dialog validation, to ask CP questions + ;Expects ORIFN and ORDA + ; + N DR S DR="" + I '$L($T(SCNEW^PSOCP))!('$G(ORIFN))!('$G(ORDA)) Q DR + I $P($G(^OR(100,ORIFN,8,ORDA,0)),U,2)'="NW" Q DR + ; + N OR3,ORDRUG,ORENEW,ORX,I,XACT,YACT,CPNODE,ASC,AAO,AIR,AEC,AMST,AHNC,ACV + S ORX="",XACT="" + ;--Only new, renew, edited, copied outpatient order can continue... + ;AGP CHANGE 26.65, will returned service connection data for change orders + S OR3=$G(^OR(100,ORIFN,3)),XACT=$P(OR3,U,11) I (XACT'=0)&(XACT'=1)&((XACT'=2)&(XACT'="C")) Q DR + I (XACT=1)&($D(^OR(100,ORIFN,5))=0) Q DR + I $D(^OR(100,ORIFN,5))>0 D + .S CPNODE=$G(^OR(100,ORIFN,5)) + .S ASC=$S($L($P(CPNODE,"^",1)):"SC;"_$P(CPNODE,"^",1),1:"") + .S DR=$S($L(ASC):DR_U_ASC,1:DR) + .S AAO=$S($L($P(CPNODE,"^",3)):"AO;"_$P(CPNODE,"^",3),1:"") + .S DR=$S($L(AAO):DR_U_AAO,1:DR) + .S AIR=$S($L($P(CPNODE,"^",4)):"IR;"_$P(CPNODE,"^",4),1:"") + .S DR=$S($L(AIR):DR_U_AIR,1:DR) + .S AEC=$S($L($P(CPNODE,"^",5)):"EC;"_$P(CPNODE,"^",5),1:"") + .S DR=$S($L(AEC):DR_U_AEC,1:DR) + .S AMST=$S($L($P(CPNODE,"^",2)):"MST;"_$P(CPNODE,"^",2),1:"") + .S DR=$S($L(AMST):DR_U_AMST,1:DR) + .S AHNC=$S($L($P(CPNODE,"^",6)):"HNC;"_$P(CPNODE,"^",6),1:"") + .S DR=$S($L(AHNC):DR_U_AHNC,1:DR) + .S ACV=$S($L($P(CPNODE,"^",7)):"CV;"_$P(CPNODE,"^",7),1:"") + .S DR=$S($L(ACV):DR_U_ACV,1:DR) + .D CPCOMP(.DR) + .K ASC,AAO,AIR,AEC,AMST,AHNC,CPNODE + I $L(DR)>0 Q DR + I XACT=2 S YACT=$P(OR3,U,5),ORENEW=$G(^OR(100,YACT,4)) ;get PS# if renewal + S ORDRUG=$$VALUE^ORCSAVE2(ORIFN,"DRUG") + D SCNEW^PSOCP(.ORX,+PTIFN,ORDRUG,$G(ORENEW)) I '$D(ORX) Q DR + F I="SC","AO","IR","EC","MST","HNC","CV" D + . I $D(ORX(I)) S DR=DR_U_I_$S($L(ORX(I)):";"_ORX(I),1:"") + Q DR +REFMT(ORX,INFO) ; + ;"U": Unchecked ("NO") + ;"C": Checked ("YES") + ;"N" : Question not asked + N RST,RST1 + S RST="" + F I=1:1:$L(INFO) S RST=RST_U_$S($E(INFO,I)="U":0,$E(INFO,I)="C":1,1:"") + S RST1=$E(RST,2,$L(RST)) + S ORX("SC")=$P(RST1,U,1) + S ORX("MST")=$P(RST1,U,5) + S ORX("AO")=$P(RST1,U,2) + S ORX("IR")=$P(RST1,U,3) + S ORX("EC")=$P(RST1,U,4) + S ORX("HNC")=$P(RST1,U,6) + S ORX("CV")=$P(RST1,U,7) + K RST,RST1 + Q +CPCOMP(PREX) ; -- Compare the existed exemptions with new exemption questions + N ORX1,ORDRUG1,CPI,LSTCP,TMPVAL + S LSTCP="" + S ORDRUG1=$$VALUE^ORCSAVE2(ORIFN,"DRUG") + D SCNEW^PSOCP(.ORX1,+PTIFN,ORDRUG1,$G(ORENEW)) I '$D(ORX1) Q + F CPI="SC","AO","IR","EC","MST","HNC","CV" D + . I $D(ORX1(CPI)) D + . . S TMPVAL="" + . . I $F(PREX,CPI) D + . . . S TMPVAL=+$E(PREX,$F(PREX,CPI)+1) + . . . I $L(TMPVAL),((TMPVAL=0)!(TMPVAL=1)) S TMPVAL=CPI_";"_TMPVAL + . . . E S TMPVAL=CPI + . . E S TMPVAL=CPI + . . S LSTCP=LSTCP_U_TMPVAL + S PREX=LSTCP + Q +IPOD4OP(ORY,ORID) ;True: is an Inpt (IV OI) order on an OutPatient + Q:'$D(^OR(100,+ORID,0)) + S ORY=0 + N APKG,ADLG,ADG,APTCLS,RXDG,UDDLG,IPPKG + S (RXDG,UDDLG,IPPKG)=0 + S RXDG=+$O(^ORD(100.98,"B","O RX",0)) + S UDDLG=+$O(^ORD(101.41,"B","PSJ OR PAT OE",0)) + S IPPKG=+$O(^DIC(9.4,"B","INPATIENT MEDICATIONS",0)) + S ADLG=+$P($G(^OR(100,+ORID,0)),U,5) + S ADG=$P($G(^OR(100,+ORID,0)),U,11) + S APKG=$P($G(^OR(100,+ORID,0)),U,14) + S APTCLS=$P($G(^OR(100,+ORID,0)),U,12) + I ADG=RXDG,(ADLG=UDDLG),(APKG=IPPKG),(APTCLS="I") S ORY=1 + Q + ; +UPDTDG(ORY,ORID) ;Update Inpt order for outpatient DG to Inpt DG + Q:'$D(^OR(100,+ORID,0)) + N UDDG + S UDDG=$O(^ORD(100.98,"B","UD RX",0)) + S $P(^OR(100,+ORID,0),U,11)=UDDG + Q +ISUDIV(ORY,ORIFN) ;True: OI of the order is for both UD and IV + N OI + S (OI,ORY)=0 + S OI=+$O(^OR(100,+$G(ORIFN),.1,"B",0)) Q:OI<1 + I $O(^ORD(101.43,OI,9,"B","IVM RX",0)) S ORY=1 + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDVAL.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDVAL.m index 3f0b31e1..99cb5912 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDVAL.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDVAL.m @@ -1,39 +1,32 @@ -ORWDVAL ; SLC/KCM - Validate procedures - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**243**;Dec 17, 1997;Build 242 - ; -VALSCHED(ERR,SCHED) ; Validate a schedule - ; Set up 'interval^repeat count', if no interval assume QD - S ERR=0 - S INTERVAL=$P(SCHED," ",1),REPEAT=$P(SCHED," ",2) - ;I '$O(^PS(51.1,"APLR",INTERVAL,0)) S ERR=1 Q - K ^TMP($J,"ORLIST") - D ZERO^PSS51P1(,INTERVAL,"LR",,"ORLIST") - I '$D(^TMP($J,"ORLIST","B",INTERVAL)) K ^TMP($J,"ORLIST") S ERR=1 Q - K ^TMP($J,"ORLIST") - I '(X?1"X"1.N) S ERR=1 Q - Q -STOPDT(ADATE,SCHED) ; Return stop date given a schedule - ; Look at max days continuous orders - ; set numdays to lesser of Xnn and LR MAX... - ; calculate stop date from collection time - Q -EXPSCHED(LST,SCHED,START,STOP,MAX) ; procedure - ; Expand schedule into start/stop times - N IEN,TYP,INTERVAL,REPEAT - D VALSCHED I ERR S LST="" - S INTERVAL=$P(SCHED," ",1),REPEAT=$E($P(SCHED," ",2),2,999) - K ^TMP($J,"ORWDVAL") D AP^PSS51P1("LR",INTERVAL,,,"ORWDVAL") - S IEN=$O(^TMP($J,"ORWDVAL","APLR",INTERVAL,0)) - S TYP=$P($G(^TMP($J,"ORWDVAL",IEN,5)),U) - S FREQ=$G(^TMP($J,"ORWDVAL",IEN,2)) - I TYP="C" D ; add interval until repeat count or stop time reached - . ; - I TYP="D" D ; from start time look for matching day of week & add - . ; - I TYP="O" D ; quit with just the start time - . ; - ; range, shift, dow-range ??? - K ^TMP($J,"ORWDVAL") - Q -DATE ; Validate a date/time (allow visits) - Q +ORWDVAL ; SLC/KCM - Validate procedures + ;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997 + ; +VALSCHED(ERR,SCHED) ; Validate a schedule + ; Set up 'interval^repeat count', if no interval assume QD + S ERR=0 + S INTERVAL=$P(SCHED," ",1),REPEAT=$P(SCHED," ",2) + I '$O(^PS(51.1,"APLR",INTERVAL,0)) S ERR=1 Q + I '(X?1"X"1.N) S ERR=1 Q + Q +STOPDT(ADATE,SCHED) ; Return stop date given a schedule + ; Look at max days continuous orders + ; set numdays to lesser of Xnn and LR MAX... + ; calculate stop date from collection time + Q +EXPSCHED(LST,SCHED,START,STOP,MAX) ; procedure + ; Expand schedule into start/stop times + N IEN,TYP,INTERVAL,REPEAT + D VALSCHED I ERR S LST="" + S INTERVAL=$P(SCHED," ",1),REPEAT=$E($P(SCHED," ",2),2,999) + S IEN=$O(^PS(51.1,"APLR",INTERVAL,0)) + S TYP=$P(^PS(51.1,IEN,0),U,5),FREQ=$P(^(0),U,3) + I TYP="C" D ; add interval until repeat count or stop time reached + . ; + I TYP="D" D ; from start time look for matching day of week & add + . ; + I TYP="O" D ; quit with just the start time + . ; + ; range, shift, dow-range ??? + Q +DATE ; Validate a date/time (allow visits) + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDX.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDX.m index 11808f26..54e0e6ec 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDX.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDX.m @@ -1,200 +1,225 @@ -ORWDX ; SLC/KCM/REV/JLI - Order dialog utilities ;11/28/2006 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,125,131,132,141,164,178,187,190,195,215,246,243**;Dec 17, 1997;Build 242 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; -ORDITM(Y,FROM,DIR,XREF) ; Subset of orderable items - ; Y(n)=IEN^.01 Name^.01 Name -or- IEN^Synonym <.01 Name>^.01 Name - N I,IEN,CNT,X,DTXT,CURTM,DEFROUTE - S DEFROUTE="" - S I=0,CNT=44,CURTM=$$NOW^XLFDT - F Q:I'"_U_$P(X,U,4)_U_DEFROUTE - Q -ODITMBC(Y,XREF,ODLST) ; - N CNT,NM,XRF - S CNT=0,NM=0,XRF=XREF - F S CNT=$O(ODLST(CNT)) Q:'CNT D FNDINFO(.Y,ODLST(CNT)) - Q -FNDINFO(Y,ODIEN) ; - D FNDINFO^ORWDX1(.Y,.ODIEN) - Q -DLGDEF(LST,DLG) ; Format mapping for a dlg - D DLGDEF^ORWDX1(.LST,.DLG) - Q -DLGQUIK(LST,QO) ;(NOT USED) - D LOADRSP(.LST,QO) - Q -LOADRSP(LST,RSPID,TRANS) ; Load responses from 101.41 or 100 - ; RSPID: C123456;1-3243 = cached copy, 134-3234 = cached quick - ; X123456;1 = change order, 134 = quick dialog - N I,J,DLG,INST,ID,VAL,ILST,ROOT,ORLOC S ROOT="" - I RSPID["-" S ROOT="^TMP(""ORWDXMQ"",$J,"""_RSPID_""")" G XROOT^ORWDX2 - I $E(RSPID)="X" S ROOT="^OR(100,"_+$P(RSPID,"X",2)_",4.5)" G XROOT^ORWDX2 - I +RSPID=RSPID S ROOT="^ORD(101.41,"_+RSPID_",6)" G XROOT^ORWDX2 - Q:ROOT="" - G XROOT^ORWDX2 -SAVE(REC,ORVP,ORNP,ORL,DLG,ORDG,ORIT,ORIFN,ORDIALOG,ORDEA,ORAPPT,ORSRC,OREVTDF) ; - ; ORVP=DFN, ORNP=Provider, ORL=Location, DLG=Order Dialog, - ; ORDG=Display Group, ORIT=Quick Order Dialog, ORAPPT=Appointment - N ORDUZ,ORSTS,OREVENT,ORCAT,ORDA,ORTS,ORNEW,ORCHECK,ORLOG,ORLEAD,ORTRAIL,ORPKG,ORWP94,ORCATFN,OREVTYPE,ONPASS - N XCNT,XCOMM,XDONE,XX ;SBR - S (XCOMM,XCNT)="" ;SBR - I $G(ORIFN)'="" D ;SBR problem only occurs on change or renew orders - . S XCNT=$O(^OR(100,+ORIFN,4.5,"ID","COMMENT",XCNT)) ;SBR - . I XCNT'="" S XCOMM=$P($G(^OR(100,+ORIFN,4.5,XCNT,0)),"^",2) ;SBR - . I XCOMM'="" S XDONE=0,XX="" F S XX=$O(ORDIALOG("WP",XCOMM,1,XX)) Q:XX="" D ;SBR - . . I ORDIALOG("WP",XCOMM,1,XX,0)'="" S XDONE=1 Q ;SBR - . I XCOMM'="",'$G(XDONE),$D(ORDIALOG("WP",XCOMM)) K ORDIALOG("WP",XCOMM) ;SBR - S ORCATFN="" I $L($P(DLG,U,2)) S ORCATFN=$P(DLG,U,2),DLG=$P(DLG,U,1) - ;Remove treating facility if inpatient and IMO order 26.42 - I $G(^DPT(ORVP,.1))'="",$P($G(^ORD(100.98,ORDG,0)),U)="CLINIC ORDERS" K ORDIALOG("ORTS") - I $G(ORDIALOG("ORTS")) S ORTS=ORDIALOG("ORTS") K ORDIALOG("ORTS") - I $G(ORDIALOG("ORSLOG")) S ORLOG=ORDIALOG("ORSLOG") K ORDIALOG("ORSLOG") - I $D(ORDIALOG("OREVENT")) S OREVENT=ORDIALOG("OREVENT") K ORDIALOG("OREVENT") - ;===================================================== - ; Changed for v26.27 (RV) - S ORCAT=$$INPT^ORCD,ORCAT=$S(ORCAT=1:"I",1:"O") - ;I $L($G(OREVENT)) D - ;. S ONPASS=0 - ;. S OREVTYPE=$$TYPE^OREVNTX(OREVENT) - ;. I OREVTYPE="T" D ISPASS^OREVNTX1(.ONPASS,+OREVENT,"T") - ;. S ORCAT=$S(OREVTYPE="A":"I",OREVTYPE="T":"I",ONPASS=1:"O",1:"O") - ;E S ORCAT=$S($L($P($G(^DPT(+ORVP,.1)),U)):"I",1:"O") - ;===================================================== - I DLG="PS MEDS" S ORWP94=1 D - . I ORIT=$O(^ORD(101.41,"AB","PSO SUPPLY",0)) S DLG="PSO SUPPLY" - . I ORIT=$O(^ORD(101.41,"AB","PSO OERR",0)) S DLG="PSO OERR" - . I ORIT=$O(^ORD(101.41,"AB","PSJ OR PAT OE",0)) S DLG="PSJ OR PAT OE" - I DLG="PSO OERR" S ORCAT="O" I $G(OREVENT("EFFECTIVE")) D - . S ORDIALOG($O(^ORD(101.41,"B","OR GTX START DATE"_$S($G(ORWP94):"/TIME",1:""),0)),1)=OREVENT("EFFECTIVE") - I DLG="PSJ OR PAT OE" S ORCAT="I" - S:DLG="FHW1" ORCAT="I" S:DLG?1"FHW "2.7U1" MEAL" ORCAT="O" - S ORVP=ORVP_";DPT(",ORL(2)=ORL_";SC(",ORL=ORL(2) - I ORDG=$O(^ORD(100.98,"B","LAB",0)) D ;use section - . N OI,SUB S OI=+$G(ORDIALOG($$PTR^ORCD("OR GTX ORDERABLE ITEM"),1)) - . S SUB=$P($G(^ORD(101.43,OI,"LR")),U,6),ORDG=$$DGRP^ORMLR(SUB) - K:'ORDG ORDG K:'ORIT ORIT ; Dgrp & Quick must be non-zero - M ORCHECK=ORDIALOG("ORCHECK") K ORDIALOG("ORCHECK") - S ORDIALOG=$O(^ORD(101.41,"AB",DLG,0)) - I 'ORDIALOG S ORDIALOG=$O(^ORD(101.41,"B",DLG,0)) - I $D(ORDIALOG("ORLEAD")) S ORLEAD=ORDIALOG("ORLEAD") - I $D(ORDIALOG("ORTRAIL")) S ORTRAIL=ORDIALOG("ORTRAIL") - D GETDLG1^ORCD(ORDIALOG) - I $L(ORCATFN) S ORCAT=ORCATFN - I $G(ORWP94) D - . N SIGPRMT S SIGPRMT=$O(^ORD(101.41,"B","OR GTX SIG",0)) - . N INSPRMT S INSPRMT=$O(^ORD(101.41,"B","OR GTX INSTRUCTIONS",0)) - . I $L($G(ORDIALOG(SIGPRMT,1))) S ORDIALOG(INSPRMT,"FORMAT")="@" - . I ORCAT="O" S ORPKG=$O(^DIC(9.4,"C","PSO",0)) - . I ORCAT="I" S ORPKG=$O(^DIC(9.4,"C","PSJ",0)) - S ORSRC=$G(ORSRC) - D DELPI^ORWDX1 ;delete empty PI - I $G(ORIFN)="" D ; new order - . D EN^ORCSAVE - . S REC="" I ORIFN D GETBYIFN^ORWORR(.REC,ORIFN) - . I '$D(^TMP("ORECALL",$J,ORDIALOG)) M ^TMP("ORECALL",$J,ORDIALOG)=ORDIALOG - E D - . N OR0 - . S OR0=$G(^OR(100,+ORIFN,0)),ORSTS=$P($G(^(3)),U,3),ORDG=$P(OR0,U,11) - . I $L($P(OR0,U,17)),ORSTS=10 S OREVENT=$P(OR0,U,17),OREVENT("TS")=$P(OR0,U,13) - . D XX^ORCSAVE ; edit order - . S REC="" S ORIFN=+ORIFN_";"_ORDA D GETBYIFN^ORWORR(.REC,ORIFN) - Q -SENDED(ORWLST,ORIENS,TS,LOC) ; Release EDOs to svc - N OK,ORVP,ORWERR,ORSIGST,ORDA,ORNATURE,ORIX,X,PTEVT,ORIFN,J,EVENT,LOCK - S ORWERR="",ORIX=0,LOC=LOC_";SC(" - F S ORIX=$O(ORIENS(ORIX)) Q:'ORIX D - . S ORIFN=ORIENS(ORIX) - . S PTEVT=$P(^OR(100,+ORIFN,0),U,17) I PTEVT S LOCK=$$LCKEVT^ORX2(PTEVT) S:LOCK EVENT(PTEVT)="" I 'LOCK S ORWERR="1^delayed event is locked - another user is processing orders for this event" ;195 - . S ORDA=$P(ORIFN,";",2) S:'ORDA ORDA=1 - . S ORVP=$P($G(^OR(100,+ORIFN,0)),U,2) - . I $D(^OR(100,+ORIFN,8,ORDA,0)) D - .. S ORSIGST=$P($G(^(0)),U,4) - .. S ORNATURE=$P($G(^(0)),U,12) - . S:$G(LOC) $P(^OR(100,+ORIFN,0),U,10)=LOC ;set location - . S:$G(TS) $P(^OR(100,+ORIFN,0),U,13)=TS ;set specialty - . S OK=$$LOCK1^ORX2(ORIFN) I 'OK S ORWERR="1^"_$P(OK,U,2) - . I OK,$G(LOCK) D EN2^ORCSEND(ORIENS(ORIX),ORSIGST,ORNATURE,.ORWERR),UNLK1^ORX2(ORIENS(ORIX)) ;add ,LOCK to if statement for 195 - . S ORWLST(ORIX)=ORIENS(ORIX) - . I $L(ORWERR) S ORWLST(ORIX)=ORWLST(ORIX)_"^E^"_ORWERR Q - . E D - .. S PTEVT=$P($G(^OR(100,+ORIENS(ORIX),0)),U,17) - .. D:$$TYPE^OREVNTX(PTEVT)="M" SAVE^ORMEVNT1(ORIENS(ORIX),PTEVT,2) - . S X="RS" - . S $P(ORWLST(ORIX),U,2)=X - S J=0 F S J=$O(EVENT(J)) Q:'+J D UNLEVT^ORX2(J) ;195 - Q -SEND(ORWLST,DFN,ORNP,ORL,ES,ORWREC) ; Sign - ; DFN=Patient, ORNP=Provider, ORL=Location, ES=Encrypted ES code - ; ORWREC(n)=ORIFN;Action^Signature Sts^Release Sts^Nature of Order -SEND1 N ORVP,ORWI,ORWERR,ORWREL,ORWSIG,ORWNATR,ORDERID,ORBEF,ORLR,ORLAB,X,I - S ORVP=DFN_";DPT(",ORL=ORL_";SC(",ORL(2)=ORL,ORWLST=0 - F I="LR","VBEC" S X=+$O(^DIC(9.4,"C",I,0)) S:X ORLR(X)=1 - S ORWI=0 F S ORWI=$O(ORWREC(ORWI)) Q:'ORWI D - . S X=ORWREC(ORWI),ORWERR="" - . S ORDERID=$P(X,U),ORWSIG=$P(X,U,2),ORWREL=$P(X,U,3),ORWNATR=$P(X,U,4) - . S ORBEF=0 - . I '$D(^OR(100,+ORDERID,0)) Q - . I $D(^OR(100,+ORDERID,8,+$P(ORDERID,";",2),0)) S ORBEF=$P(^OR(100,+ORDERID,8,+$P(ORDERID,";",2),0),U,15) - . S:$D(^OR(100,+ORDERID,8,+$P(ORDERID,";",2),0)) ORWNATR=$S($P(^OR(100,+ORDERID,8,+$P(ORDERID,";",2),0),"^",4)=3:"",1:ORWNATR) - . S ORWERR=$$CHKACT^ORWDXR(ORDERID,ORWSIG,ORWREL,ORWNATR) - . I $L(ORWERR) S ORWERR="1^"_ORWERR - . I '$L(ORWERR) D - .. I $G(ORLR(+$P(^OR(100,+ORDERID,0),U,14))),'$G(ORLAB) D ; lab batch start - ... I $L($T(BHS^ORMBLD)) D BHS^ORMBLD(ORVP) S ORLAB=1 - .. N OK S OK=$$LOCK1^ORX2(ORDERID) I 'OK S ORWERR="1^"_$P(OK,U,2) - .. I OK D EN^ORCSEND(ORDERID,"",ORWSIG,ORWREL,ORWNATR,"",.ORWERR),UNLK1^ORX2(ORDERID) - . S ORWLST(ORWI)=ORDERID,X="" - . I $L(ORWERR) S ORWLST(ORWI)=ORWLST(ORWI)_"^E^"_ORWERR Q - . I ORWREL,((ORBEF=10)!(ORBEF=11)),($P(^OR(100,+ORDERID,3),U,3)'=10) S X="R" - . I ORWSIG'=2 S X=X_"S" - . S $P(ORWLST(ORWI),U,2)=X - I $G(ORLAB) D BTS^ORMBLD(ORVP) - Q -DLGID(VAL,ORIFN) ; return dlg IEN for order - S VAL=$P(^OR(100,+ORIFN,0),U,5) - S VAL=$S($P(VAL,";",2)="ORD(101.41,":+VAL,1:0) - Q -FORMID(VAL,ORIFN) ; Base dlg FormID for an order - N DLG - S VAL=0,DLG=$P(^OR(100,+ORIFN,0),U,5) - Q:$P(DLG,";",2)'="ORD(101.41," - D FORMID^ORWDXM(.VAL,+DLG) - Q -AGAIN(VAL,DLG) ; return true to keep dlg for another order - S VAL=''$P($G(^ORD(101.41,DLG,0)),U,9) - Q -DGRP(VAL,DLG) ; Display grp pointer for a dlg - S DLG=$S($E(DLG)="`":+$P(DLG,"`",2),1:$O(^ORD(101.41,"AB",DLG,0))) ;kcm - S VAL=$P($G(^ORD(101.41,DLG,0)),U,5) - Q -DGNM(VAL,NM) ; Display grp pointer for name - S VAL=$O(^ORD(100.98,"B",NM,0)) - Q -WRLST(LST,LOC) ; List of dlgs for writing orders - G WRLST1^ORWDX1 -MSG(LST,IEN) ; Msg text for orderable item - N I - S I=0 F S I=$O(^ORD(101.43,IEN,8,I)) Q:I'>0 S LST(I)=^(I,0) - Q -DISMSG(VAL,IEN) ; Disabled mge for ordering dlg - S VAL=$P($G(^ORD(101.41,+IEN,0)),U,3) - Q -LOCK(OK,DFN) ; Attempt to lock pt for ordering - S OK=$$LOCK^ORX2(DFN) - Q -UNLOCK(OK,DFN) ; Unlock pt for ordering - D UNLOCK^ORX2(DFN) S OK=1 - Q -LOCKORD(OK,ORIFN) ; Attempt to lock order - S OK=$$LOCK1^ORX2(ORIFN) - Q -UNLKORD(OK,ORIFN) ; Unlock order - D UNLK1^ORX2(ORIFN) S OK=1 - Q +ORWDX ; SLC/KCM/REV/JLI - Order dailog utilities ;4/21/07 19:18 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,125,131,132,141,164,178,187,190,195,215,269**;Dec 17, 1997;Build 28 + ; 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. + ; +NXT() ; -- Gets index in array + S ILST=ILST+1 + Q ILST + ; +ORDITM(Y,FROM,DIR,XREF) ; Subset of orderable items + ; Y(n)=IEN^.01 Name^.01 Name -or- IEN^Synonym <.01 Name>^.01 Name + N I,IEN,CNT,X,DTXT,CURTM + S I=0,CNT=44,CURTM=$$NOW^XLFDT + F Q:I'"_U_$P(X,U,4) + Q +ODITMBC(Y,XREF,ODLST) ; + N CNT,NM,XRF + S CNT=0,NM=0,XRF=XREF + F S CNT=$O(ODLST(CNT)) Q:'CNT D FNDINFO(.Y,ODLST(CNT)) + Q +FNDINFO(Y,ODIEN) ; + D FNDINFO^ORWDX1(.Y,.ODIEN) + Q +DLGDEF(LST,DLG) ; Format mapping for a dlg + D DLGDEF^ORWDX1(.LST,.DLG) + Q +DLGQUIK(LST,QO) ;(NOT USED) + D LOADRSP(.LST,QO) + Q +LOADRSP(LST,RSPID) ; Load responses from 101.41 or 100 + ; RSPID: C123456;1-3243 = cached copy, 134-3234 = cached quick + ; X123456;1 = change order, 134 = quick dialog + N I,J,DLG,INST,ID,VAL,ILST,ROOT S ROOT="" + I RSPID["-" S ROOT="^TMP(""ORWDXMQ"",$J,"""_RSPID_""")" G XROOT + I $E(RSPID)="X" S ROOT="^OR(100,"_+$P(RSPID,"X",2)_",4.5)" G XROOT + I +RSPID=RSPID S ROOT="^ORD(101.41,"_+RSPID_",6)" G XROOT + Q:ROOT="" +XROOT S (ILST,I)=0 F S I=$O(@ROOT@(I)) Q:I'>0 D + . S DLG=$P(@ROOT@(I,0),U,2),INST=$P(^(0),U,3) + . S ID=$P($G(^ORD(101.41,DLG,1)),U,3) + . I '$L(ID) S ID="ID"_DLG + . S VAL=$G(@ROOT@(I,1)) + . I $P($G(^ORD(101.41,DLG,0)),U)="OR GTX ADDITIVE" S ID="ADDITIVE" + . I $E(RSPID)="C",(ID="START"),VAL Q ; skip literal start time on copy + . S LST($$NXT)="~"_DLG_U_INST_U_ID + . I $L(VAL) D + .. S LST($$NXT)="i"_VAL,LST($$NXT)="e"_$$EXTVAL(VAL,DLG) + . I $D(@ROOT@(I,2))>1 D + .. S J=0 F S J=$O(@ROOT@(I,2,J)) Q:J'>0 D + ... S LST($$NXT)="t"_$G(@ROOT@(I,2,J,0)) + I $E(ROOT,1,4)="^TMP" K ^TMP("ORWDXMQ",$J) + Q +SAVE(REC,ORVP,ORNP,ORL,DLG,ORDG,ORIT,ORIFN,ORDIALOG,ORDEA,ORAPPT,ORSRC,OREVTDF) ; + ; ORVP=DFN, ORNP=Provider, ORL=Location, DLG=Order Dialog, + ; ORDG=Display Group, ORIT=Quick Order Dialog, ORAPPT=Appointment + N ORDUZ,ORSTS,OREVENT,ORCAT,ORDA,ORTS,ORNEW,ORCHECK,ORLOG,ORLEAD,ORTRAIL,ORPKG,ORWP94,ORCATFN,OREVTYPE,ONPASS + ; JD FIX FOR WASHINGTON DC + ;I '$L(ORSRC)!($G(ORSRC)=" ")!($G(ORSRC)=0) S ORSRC=$P(ORVP,U,2) + ;S ORVP=$P(ORVP,U) + ; END FIX JD + S ORCATFN="" + I $L($P(DLG,U,2)) S ORCATFN=$P(DLG,U,2),DLG=$P(DLG,U,1) + ;Remove treating facility if inpatient and IMO order 26.42 + I $G(^DPT(ORVP,.1))'="",$P($G(^ORD(100.98,ORDG,0)),U)="CLINIC ORDERS" K ORDIALOG("ORTS") + I $G(ORDIALOG("ORTS")) S ORTS=ORDIALOG("ORTS") K ORDIALOG("ORTS") + I $G(ORDIALOG("ORSLOG")) S ORLOG=ORDIALOG("ORSLOG") K ORDIALOG("ORSLOG") + I $D(ORDIALOG("OREVENT")) S OREVENT=ORDIALOG("OREVENT") K ORDIALOG("OREVENT") + ;======= + ; Changed for v26.27 (RV) + S ORCAT=$$INPT^ORCD,ORCAT=$S(ORCAT=1:"I",1:"O") + ;I $L($G(OREVENT)) D + ;. S ONPASS=0 + ;. S OREVTYPE=$$TYPE^OREVNTX(OREVENT) + ;. I OREVTYPE="T" D ISPASS^OREVNTX1(.ONPASS,+OREVENT,"T") + ;. S ORCAT=$S(OREVTYPE="A":"I",OREVTYPE="T":"I",ONPASS=1:"O",1:"O") + ;E S ORCAT=$S($L($P($G(^DPT(+ORVP,.1)),U)):"I",1:"O") + ;======= + I DLG="PS MEDS" S ORWP94=1 D + . I ORIT=$O(^ORD(101.41,"AB","PSO SUPPLY",0)) S DLG="PSO SUPPLY" + . I ORIT=$O(^ORD(101.41,"AB","PSO OERR",0)) S DLG="PSO OERR" + . I ORIT=$O(^ORD(101.41,"AB","PSJ OR PAT OE",0)) S DLG="PSJ OR PAT OE" + I DLG="PSO OERR" S ORCAT="O" I $G(OREVENT("EFFECTIVE")) D + . S ORDIALOG($O(^ORD(101.41,"B","OR GTX START DATE"_$S($G(ORWP94):"/TIME",1:""),0)),1)=OREVENT("EFFECTIVE") + I DLG="PSJ OR PAT OE" S ORCAT="I" + S:DLG="FHW1" ORCAT="I" S:DLG?1"FHW "2.7U1" MEAL" ORCAT="O" + S ORVP=ORVP_";DPT(",ORL(2)=ORL_";SC(",ORL=ORL(2) + K:'ORDG ORDG K:'ORIT ORIT ; Dgrp & Quick must be non-zero + M ORCHECK=ORDIALOG("ORCHECK") K ORDIALOG("ORCHECK") + S ORDIALOG=$O(^ORD(101.41,"AB",DLG,0)) + I 'ORDIALOG S ORDIALOG=$O(^ORD(101.41,"B",DLG,0)) + I $D(ORDIALOG("ORLEAD")) S ORLEAD=ORDIALOG("ORLEAD") + I $D(ORDIALOG("ORTRAIL")) S ORTRAIL=ORDIALOG("ORTRAIL") + D GETDLG1^ORCD(ORDIALOG) + I $L(ORCATFN) S ORCAT=ORCATFN + I $G(ORWP94) D + . N SIGPRMT S SIGPRMT=$O(^ORD(101.41,"B","OR GTX SIG",0)) + . N INSPRMT S INSPRMT=$O(^ORD(101.41,"B","OR GTX INSTRUCTIONS",0)) + . I $L($G(ORDIALOG(SIGPRMT,1))) S ORDIALOG(INSPRMT,"FORMAT")="@" + . I ORCAT="O" S ORPKG=$O(^DIC(9.4,"C","PSO",0)) + . I ORCAT="I" S ORPKG=$O(^DIC(9.4,"C","PSJ",0)) + S ORSRC=$G(ORSRC) + D DELPI^ORWDX1 ;delete empty PI + I $G(ORIFN)="" D ; new order + . D EN^ORCSAVE + . S REC="" I ORIFN D GETBYIFN^ORWORR(.REC,ORIFN) + . I '$D(^TMP("ORECALL",$J,ORDIALOG)) M ^TMP("ORECALL",$J,ORDIALOG)=ORDIALOG + E D + . N OR0 + . S OR0=$G(^OR(100,+ORIFN,0)),ORSTS=$P($G(^(3)),U,3),ORDG=$P(OR0,U,11) + . I $L($P(OR0,U,17)),ORSTS=10 S OREVENT=$P(OR0,U,17),OREVENT("TS")=$P(OR0,U,13) + . D XX^ORCSAVE ; edit order + . S REC="" S ORIFN=+ORIFN_";"_ORDA D GETBYIFN^ORWORR(.REC,ORIFN) + Q +SENDED(ORWLST,ORIENS,TS,LOC) ; Release EDOs to svc + N OK,ORVP,ORWERR,ORSIGST,ORDA,ORNATURE,ORIX,X,PTEVT,ORIFN,J,EVENT,LOCK + S ORWERR="",ORIX=0,LOC=LOC_";SC(" + F S ORIX=$O(ORIENS(ORIX)) Q:'ORIX D + . S ORIFN=ORIENS(ORIX) + . S PTEVT=$P(^OR(100,+ORIFN,0),U,17) I PTEVT S LOCK=$$LCKEVT^ORX2(PTEVT) S:LOCK EVENT(PTEVT)="" I 'LOCK S ORWERR="1^delayed event is locked - another user is processing orders for this event" ;195 + . S ORDA=$P(ORIFN,";",2) S:'ORDA ORDA=1 + . S ORVP=$P($G(^OR(100,+ORIFN,0)),U,2) + . I $D(^OR(100,+ORIFN,8,ORDA,0)) D + .. S ORSIGST=$P($G(^(0)),U,4) + .. S ORNATURE=$P($G(^(0)),U,12) + . S:$G(LOC) $P(^OR(100,+ORIFN,0),U,10)=LOC ;set location + . S:$G(TS) $P(^OR(100,+ORIFN,0),U,13)=TS ;set specialty + . S OK=$$LOCK1^ORX2(ORIFN) I 'OK S ORWERR="1^"_$P(OK,U,2) + . I OK,$G(LOCK) D EN2^ORCSEND(ORIENS(ORIX),ORSIGST,ORNATURE,.ORWERR),UNLK1^ORX2(ORIENS(ORIX)) ;add ,LOCK to if statement for 195 + . S ORWLST(ORIX)=ORIENS(ORIX) + . I $L(ORWERR) S ORWLST(ORIX)=ORWLST(ORIX)_"^E^"_ORWERR Q + . E D + .. S PTEVT=$P($G(^OR(100,+ORIENS(ORIX),0)),U,17) + .. D:$$TYPE^OREVNTX(PTEVT)="M" SAVE^ORMEVNT1(ORIENS(ORIX),PTEVT,2) + . S X="RS" + . S $P(ORWLST(ORIX),U,2)=X + S J=0 F S J=$O(EVENT(J)) Q:'+J D UNLEVT^ORX2(J) ;195 + Q +SEND(ORWLST,DFN,ORNP,ORL,ES,ORWREC) ; Sign + ; DFN=Patient, ORNP=Provider, ORL=Location, ES=Encrypted ES code + ; ORWREC(n)=ORIFN;Action^Signature Sts^Release Sts^Nature of Order +SEND1 N ORVP,ORWI,ORWERR,ORWREL,ORWSIG,ORWNATR,ORDERID,ORBEF,ORLR,ORLAB,X,I + S ORVP=DFN_";DPT(",ORL=ORL_";SC(",ORL(2)=ORL,ORWLST=0 + F I="LR","VBEC" S X=+$O(^DIC(9.4,"C",I,0)) S:X ORLR(X)=1 + S ORWI=0 F S ORWI=$O(ORWREC(ORWI)) Q:'ORWI D + . S X=ORWREC(ORWI),ORWERR="" + . S ORDERID=$P(X,U),ORWSIG=$P(X,U,2),ORWREL=$P(X,U,3),ORWNATR=$P(X,U,4) + . S ORBEF=0 + . I '$D(^OR(100,+ORDERID,0)) Q + . I $D(^OR(100,+ORDERID,8,+$P(ORDERID,";",2),0)) S ORBEF=$P(^OR(100,+ORDERID,8,+$P(ORDERID,";",2),0),U,15) + . S:$D(^OR(100,+ORDERID,8,+$P(ORDERID,";",2),0)) ORWNATR=$S($P(^OR(100,+ORDERID,8,+$P(ORDERID,";",2),0),"^",4)=3:"",1:ORWNATR) + . S ORWERR=$$CHKACT^ORWDXR(ORDERID,ORWSIG,ORWREL,ORWNATR) + . I $L(ORWERR) S ORWERR="1^"_ORWERR + . I '$L(ORWERR) D + .. I $G(ORLR(+$P(^OR(100,+ORDERID,0),U,14))),'$G(ORLAB) D ; lab batch start + ... I $L($T(BHS^ORMBLD)) D BHS^ORMBLD(ORVP) S ORLAB=1 + .. N OK S OK=$$LOCK1^ORX2(ORDERID) I 'OK S ORWERR="1^"_$P(OK,U,2) + .. I OK D EN^ORCSEND(ORDERID,"",ORWSIG,ORWREL,ORWNATR,"",.ORWERR),UNLK1^ORX2(ORDERID) + .. S PSOSITE=$G(^SC(+ORL,"AFRXSITE")) ;+ORL is hospital location from ORWDX + .. Q:PSOSITE="" ;Quits with no autofinish if File#44 does not point to File#59 + .. I $P($G(^PS(59,PSOSITE,"RXFIN")),"^",1)="Y",$$GET1^DIQ(100,+ORDERID_",",12)="OUTPATIENT PHARMACY" D EN^PSOAFIN ;vfam + . S ORWLST(ORWI)=ORDERID,X="" + . I $L(ORWERR) S ORWLST(ORWI)=ORWLST(ORWI)_"^E^"_ORWERR Q + . I ORWREL,((ORBEF=10)!(ORBEF=11)),($P(^OR(100,+ORDERID,3),U,3)'=10) S X="R" + . I ORWSIG'=2 S X=X_"S" + . S $P(ORWLST(ORWI),U,2)=X + I $G(ORLAB) D BTS^ORMBLD(ORVP) + Q +EXTVAL(IVAL,DLG) ; External value given a dlg ptr + N ORDIALOG + S ORDIALOG(DLG,0)=$P($G(^ORD(101.41,DLG,1)),U,1,2) + S ORDIALOG(DLG,1)=IVAL + I $E(ORDIALOG(DLG,0))="R",(+IVAL'=IVAL) Q IVAL ; free text date/time + Q $$EXT^ORCD(DLG,1) ; all others +DLGID(VAL,ORIFN) ; return dlg IEN for order + S VAL=$P(^OR(100,+ORIFN,0),U,5) + S VAL=$S($P(VAL,";",2)="ORD(101.41,":+VAL,1:0) + Q +FORMID(VAL,ORIFN) ; Base dlg FormID for an order + N DLG + S VAL=0,DLG=$P(^OR(100,+ORIFN,0),U,5) + Q:$P(DLG,";",2)'="ORD(101.41," + D FORMID^ORWDXM(.VAL,+DLG) + Q +AGAIN(VAL,DLG) ; return true to keep dlg for another order + S VAL=''$P($G(^ORD(101.41,DLG,0)),U,9) + Q +DGRP(VAL,DLG) ; Display grp pointer for a dlg + S DLG=$S($E(DLG)="`":+$P(DLG,"`",2),1:$O(^ORD(101.41,"AB",DLG,0))) ;kcm + S VAL=$P($G(^ORD(101.41,DLG,0)),U,5) + Q +DGNM(VAL,NM) ; Display grp pointer for name + S VAL=$O(^ORD(100.98,"B",NM,0)) + Q +WRLST(LST,LOC) ; List of dlgs for writing orders + G WRLST1^ORWDX1 +MSG(LST,IEN) ; Msg text for orderable item + N I + S I=0 F S I=$O(^ORD(101.43,IEN,8,I)) Q:I'>0 S LST(I)=^(I,0) + Q +DISMSG(VAL,IEN) ; Disabled mge for ordering dlg + S VAL=$P($G(^ORD(101.41,+IEN,0)),U,3) + Q +LOCK(OK,DFN) ; Attempt to lock pt for ordering + S OK=$$LOCK^ORX2(DFN) + Q +UNLOCK(OK,DFN) ; Unlock pt for ordering + D UNLOCK^ORX2(DFN) S OK=1 + Q +LOCKORD(OK,ORIFN) ; Attempt to lock order + S OK=$$LOCK1^ORX2(ORIFN) + Q +UNLKORD(OK,ORIFN) ; Unlock order + D UNLK1^ORX2(ORIFN) S OK=1 + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDX1.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDX1.m index 27dba52c..bc620409 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDX1.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDX1.m @@ -1,185 +1,161 @@ -ORWDX1 ; SLC/KCM/REV - Utilities for Order Dialogs ;06/06/2007 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,187,195,215,243**;Dec 17, 1997;Build 242 - ; -WRLST(LST,LOC) ; Return list of dialogs for writing orders - ; .Y(n): DlgName^ListBox Text -WRLST1 N ANENT - S LOC=+$G(LOC)_";SC(" I 'LOC S LOC="" - S ANENT="ALL^"_LOC_$S($G(^VA(200,DUZ,5)):"^SRV.`"_+$G(^(5)),1:"") - D WRLSTB(.LST) Q:$D(LST)>1 ; check ORWDX WRITE ORDERS first - N ORX,X0,X5,ORERR,I,SEQ,IEN,DGRP,FID,TXT,TYP - D GETLST^XPAR(.ORX,ANENT,"ORWOR WRITE ORDERS LIST","Q",.ORERR) Q:ORERR - S I=0 F S I=$O(ORX(I)) Q:'I D - . S SEQ=+ORX(I),IEN=$P(ORX(I),U,2),X0=$G(^ORD(101.41,+IEN,0)),X5=$G(^(5)) - . S DGRP=+$P(X0,U,5),FID=+$P(X5,U,5),TXT=$P(X5,U,4),TYP=$P(X0,U,4) - . S:'$L(TXT) TXT=$P(X0,U,2) - . I $P(X0,U,4)="M" S:'FID FID=1001 - . S LST(SEQ)=IEN_";"_FID_";"_DGRP_";"_TYP_U_TXT - Q -WRLSTB(LST) ; return menu from which Write Orders list is built - N MNU,SEQ,IEN,ITM,TXT,FID,DGRP,X,TYP - S MNU=$$GET^XPAR(ANENT,"ORWDX WRITE ORDERS LIST",1,"I") Q:'MNU - S SEQ=0 F S SEQ=$O(^ORD(101.41,MNU,10,"B",SEQ)) Q:'SEQ D - . S IEN=0 F S IEN=$O(^ORD(101.41,MNU,10,"B",SEQ,IEN)) Q:'IEN D - . . S X=$G(^ORD(101.41,MNU,10,IEN,0)),ITM=+$P(X,U,2),TXT=$P(X,U,4) - . . S X=$G(^ORD(101.41,ITM,5)),FID=+$P(X,U,5) - . . S X=$G(^ORD(101.41,ITM,0)),TYP=$P(X,U,4),DGRP=+$P(X,U,5) - . . S:'$L(TXT) TXT=$P(X,U,2) - . . I TYP="M" S:'FID FID=1001 - . . S LST(SEQ)=ITM_";"_FID_";"_DGRP_";"_TYP_U_TXT - Q -DELPI ; delete PI from ORDIALOG if PI = "" - ;Called from SAVE^ORWDX - N ORPI S ORPI=0 - S ORPI=$O(^ORD(101.41,"B","OR GTX PATIENT INSTRUCTIONS",ORPI)) - Q:'$D(ORDIALOG(ORPI)) - I '$D(ORDIALOG(ORPI,1)) K ORDIALOG(ORPI),ORDIALOG("WP",ORPI) Q - N PINODE,PITX - S PITX="",PINODE=$G(ORDIALOG(ORPI,1)) - S PITX=$G(@PINODE@(1,0)) - S PITX=$TR(PITX," ","") - I '$L(PITX) K ORDIALOG(ORPI),ORDIALOG("WP",ORPI) Q - N ORSIG S ORSIG=+$O(^ORD(101.41,"B","OR GTX SIG",0)) - I $$STR^ORWDXR(ORSIG)[$$STR^ORWDXR(ORPI) S ORDIALOG(ORPI,"FORMAT")="@" - Q -FNDINFO(Y,ODIEN) ; - N ODI,CRTM,FRM,XX - S FRM="",CRTM=$$NOW^XLFDT - F S FRM=$O(^ORD(101.43,XRF,FRM)) Q:FRM="" D - . S ODI=0 F S ODI=$O(^ORD(101.43,XRF,FRM,ODI)) Q:'ODI D - .. S XX=^ORD(101.43,XRF,FRM,ODI) - .. I +$P(XX,U,3),$P(XX,U,3)"_U_$P(XX,U,4) - Q -DLGDEF(LST,DLG) ; Format mapping for a dlg - N I,IEN,ILST,X0,X2,XW S ILST=0 - I $O(^ORD(101.41,"AB",DLG,0))>0 S DLG=$O(^ORD(101.41,"AB",DLG,0)) - E S DLG=$O(^ORD(101.41,"B",DLG,0)) - Q:'DLG - S I=0 F S I=$O(^ORD(101.41,DLG,10,I)) Q:I'>0 D - . S X0=$G(^ORD(101.41,DLG,10,I,0)),X2=$G(^(2)),IEN=+$P(X0,U,2) - . S ILST=ILST+1,LST(ILST)=U_IEN_U_$P(X2,U,1,7) - . I $P(X0,U,11) S $P(LST(ILST),U,11)=1 - . S $P(LST(ILST),U)=$P($G(^ORD(101.41,IEN,1)),U,3) - . I $P($G(^ORD(101.41,IEN,0)),U)="OR GTX ADDITIVE" S $P(LST(ILST),U)="ADDITIVE" - . I $P($G(^ORD(101.41,IEN,0)),U)="OR GTX ADDL DIETS" S $P(LST(ILST),U)="ADDLDIETS" - . I $L($P(LST(ILST),U))=0 S $P(LST(ILST),U)="ID"_IEN - . I $D(^ORD(101.41,DLG,10,"DAD",IEN)) D - .. N SEQ,DA,CHILD S CHILD="" - .. S SEQ=0 F S SEQ=$O(^ORD(101.41,DLG,10,"DAD",IEN,SEQ)) Q:'SEQ D - ... S DA=0 F S DA=$O(^ORD(101.41,DLG,10,"DAD",IEN,SEQ,DA)) Q:'DA D - .... S CHILD=CHILD_+$P($G(^ORD(101.41,DLG,10,DA,0)),U,2)_"~" - .. S $P(LST(ILST),U,10)=CHILD - Q - ; -CHANGE(ORLST,ORCLST,DFN,ISIMO) ; - N CATCH,CHANGE,CNT,INP,INPDIEN,IVM,IVMDIEN,ORIEN,ORLOC,OR3,ORDG - N CIEN,DIAL,TDIAL,TDIEN,UDIEN,QORDDG,PACKIEN - S (INP,IVM,INPDIEN,IVMDIEN,UDIEN)=0 - S (TDIAL,TDIEN)=0 - S INP=$O(^ORD(101.41,"B","PSJ OR PAT OE","")) Q:INP'>0 - S IVM=$O(^ORD(101.41,"B","PSJI OR PAT FLUID OE","")) Q:IVM'>0 - S TDIAL=$O(^ORD(101.41,"B","OR GXTEXT WORD PROCESSING ORDER","")) Q:TDIAL'>0 - S INPDIEN=$O(^ORD(100.98,"B","INPATIENT MEDICATIONS","")) Q:INPDIEN'>0 - S IVMDIEN=$O(^ORD(100.98,"B","IV MEDICATIONS","")) Q:IVMDIEN'>0 - S UDIEN=$O(^ORD(100.98,"B","UNIT DOSE MEDICATIONS","")) Q:UDIEN'>0 - S TIEN=$O(^ORD(100.98,"B","NURSING","")) Q:TIEN'>0 - S CIEN=$O(^ORD(100.98,"B","CLINIC ORDERS","")) Q:CIEN'>0 - S CNT=0 F S CNT=$O(ORCLST(CNT)) Q:CNT'>0 D - .S CHANGE=0 - .S ORIEN=$P($G(ORCLST(CNT)),U),ORIEN=$P(ORIEN,";") - .S ORDG=$P($G(^OR(100,ORIEN,0)),U,11) - .S ORLOC=$P($G(ORCLST(CNT)),U,2) - .S OR3=$G(^OR(100,ORIEN,3)) - .S DIAL=$P(OR3,U,4) - .;Remove Treating Speciality if the order location is the clinic - .I $P($G(^OR(100,ORIEN,0)),U,10)=(ORLOC_";SC("),$P($G(^SC(ORLOC,0)),U,3)="C" D Q - ..S $P(^OR(100,ORIEN,0),U,13)="" - .; - .;CHANGE PATIENT LOCATION AND PATIENT STATUS. - .S $P(^OR(100,ORIEN,0),U,10)=ORLOC_";SC(" - .S PACKIEN=$P(^OR(100,ORIEN,0),U,14) - .I $$GET1^DIQ(9.4,PACKIEN_",",1)'="PSO" S $P(^OR(100,ORIEN,0),U,12)="I" - .; - .;Check for IMO orders Nursing Dialog problem - .S CATCH=$P($G(^OR(100,ORIEN,0)),U,11) - .; - .S $P(^OR(100,ORIEN,0),U,11)=$S(DIAL=(IVM_";ORD(101.41,"):IVMDIEN,DIAL=(INP_";ORD(101.41,"):INPDIEN,DIAL=(TDIAL_";ORD(101.41,"):TIEN,1:CATCH) - .; - .;Check for Quick Order Dialog - .I CATCH=$P($G(^OR(100,ORIEN,0)),U,11),ISIMO=1 D - ..S QORDDG=$P($G(^ORD(101.41,+DIAL,0)),U,5) - ..I QORDDG=UDIEN!(QORDDG=INPDIEN) S $P(^OR(100,ORIEN,0),U,11)=INPDIEN,DIAL=(INP_";ORD(101.41,") Q - ..I QORDDG=IVMDIEN S $P(^OR(100,ORIEN,0),U,11)=IVMDIEN,DIAL=(IVM_";ORD(101.41,") Q - ..I QORDDG=TIEN S $P(^OR(100,ORIEN,0),U,11)=TIEN,DIAL=(TDIAL_";ORD(101.41,") Q - .; - .;Add treating spec if Inpatient order - .;I (ISIMO=1)&(DIAL=(IVM_";ORD(101.41,"))!(DIAL=(INP_";ORD(101.41,")) D - .;.S $P(^OR(100,ORIEN,0),U,13)=+$G(^DPT(DFN,.103)) - .I ISIMO=0 S $P(^OR(100,ORIEN,0),U,13)=+$G(^DPT(DFN,.103)) - Q - ; -STCHANGE(ORY,DFN,ORYARR) ; - N CNT,DONE,NODE,PHARMID,STR,STATUS - S ORY=0,DONE=0 - I '$$PATCH^XPDUTL("PSS*1.0*93") Q - S CNT=0 F S CNT=$O(ORYARR(CNT)) Q:CNT'>0!(DONE>0) D - . S NODE=$G(ORYARR(CNT)) - . S PHARMID=$P(NODE,U),STATUS=$P(NODE,U,2) - . I $$UP^XLFSTR(STATUS)'=$$STATUS^PSSORUTE(DFN,PHARMID) S ORY=1,DONE=1 - Q -ORDMATCH(ORY,DFN,ORYARR) ; - N ACTION,CNT,IEN,MATCH,ORDERID,STATUS - S CNT=0,MATCH=1 - F S CNT=$O(ORYARR(CNT)) Q:CNT'>0!(MATCH=0) D - . S ORDERID=$P(ORYARR(CNT),U),STATUS=$P(ORYARR(CNT),U,2) - . I ORDERID=0,$G(ACTION)="" Q - . S IEN=$P(ORDERID,";"),ACTION=$P(ORDERID,";",2) - . I STATUS=$P($G(^OR(100,IEN,3)),U,3) Q - . I $P($G(^ORD(100.01,STATUS,0)),U)="DISCONTINUED/EDIT" Q - . ;S MATCH=0 - . I $P($G(^OR(100,IEN,8,ACTION,0)),U,15)'=STATUS S MATCH=0 - S ORY=MATCH - Q - ; -DCREN(ORY,ORYARR) ; - N ACT,CNT,CNT1,I,OR3,ORG,ORGID,ORID,TEXT,STATUS - S CNT1=0 - S CNT=0 F S CNT=$O(ORYARR(CNT)) Q:CNT'>0 D - .S ORGID=ORYARR(CNT) - .S ORID=+ORGID,ACT=$P(ORGID,";",2),TEXT="" - .S OR3=$G(^OR(100,ORID,3)) - .;Make sure current order status is pending - .I $P($G(^ORD(100.01,$P(OR3,U,3),0)),U)'="PENDING" Q - .S ORG=$P($G(OR3),U,5) Q:ORG'>0 - .;do not add original order if it is expired - .S STATUS=$P(^OR(100,ORG,3),U,3) - .I $P($G(^ORD(100.01,STATUS,0)),U)="EXPIRED" Q - .;Do not add original order if Stop date has pass - .I $P(^OR(100,ORG,0),U,9)'>$$NOW^XLFDT Q - .;make sure current order is a renewed order - .I $P(OR3,U,11)'=2 Q - .S ACT=+$P($G(^OR(100,ORG,3)),U,7) - .S CNT1=CNT1+1,ORY(CNT1)=ORGID_U_$P(OR3,U,5)_";"_ACT_U_TEXT - Q -DCORIG(ORY,ORIEN) ; - S $P(^OR(100,+ORIEN,6),U,9)=1 - Q -UNDCORIG(ORY,ORYARR) ; - N CNT - S CNT=0 F S CNT=$O(ORYARR(CNT)) Q:CNT'>0 S $P(^OR(100,+ORYARR(CNT),6),U,9)=0 - Q -PATWARD(ORY,DFN) ; - S ORY=0 - I $G(^DPT(DFN,.1))'="" S ORY=1 - Q -ISPEND(ORIFN) ;Is the order's status pending? - N ISPEND,PENDST,N3 S ISPEND=0 - Q:'$D(^OR(100,+ORIFN,3)) - S PENDST=$O(^ORD(100.01,"B","PENDING",0)) - S N3=$G(^OR(100,+ORIFN,3)) - I $P(N3,U,3)=PENDST S ISPEND=1 - Q ISPEND +ORWDX1 ; SLC/KCM/REV - Utilities for Order Dialogs ;10/14/05 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,187,195,215**;Dec 17, 1997 + ; +WRLST(LST,LOC) ; Return list of dialogs for writing orders + ; .Y(n): DlgName^ListBox Text +WRLST1 N ANENT + S LOC=+$G(LOC)_";SC(" I 'LOC S LOC="" + S ANENT="ALL^"_LOC_$S($G(^VA(200,DUZ,5)):"^SRV.`"_+$G(^(5)),1:"") + D WRLSTB(.LST) Q:$D(LST)>1 ; check ORWDX WRITE ORDERS first + N ORX,X0,X5,ORERR,I,SEQ,IEN,DGRP,FID,TXT,TYP + D GETLST^XPAR(.ORX,ANENT,"ORWOR WRITE ORDERS LIST","Q",.ORERR) Q:ORERR + S I=0 F S I=$O(ORX(I)) Q:'I D + . S SEQ=+ORX(I),IEN=$P(ORX(I),U,2),X0=$G(^ORD(101.41,+IEN,0)),X5=$G(^(5)) + . S DGRP=+$P(X0,U,5),FID=+$P(X5,U,5),TXT=$P(X5,U,4),TYP=$P(X0,U,4) + . S:'$L(TXT) TXT=$P(X0,U,2) + . I $P(X0,U,4)="M" S:'FID FID=1001 + . S LST(SEQ)=IEN_";"_FID_";"_DGRP_";"_TYP_U_TXT + Q +WRLSTB(LST) ; return menu from which Write Orders list is built + N MNU,SEQ,IEN,ITM,TXT,FID,DGRP,X,TYP + S MNU=$$GET^XPAR(ANENT,"ORWDX WRITE ORDERS LIST",1,"I") Q:'MNU + S SEQ=0 F S SEQ=$O(^ORD(101.41,MNU,10,"B",SEQ)) Q:'SEQ D + . S IEN=0 F S IEN=$O(^ORD(101.41,MNU,10,"B",SEQ,IEN)) Q:'IEN D + . . S X=$G(^ORD(101.41,MNU,10,IEN,0)),ITM=+$P(X,U,2),TXT=$P(X,U,4) + . . S X=$G(^ORD(101.41,ITM,5)),FID=+$P(X,U,5) + . . S X=$G(^ORD(101.41,ITM,0)),TYP=$P(X,U,4),DGRP=+$P(X,U,5) + . . S:'$L(TXT) TXT=$P(X,U,2) + . . I TYP="M" S:'FID FID=1001 + . . S LST(SEQ)=ITM_";"_FID_";"_DGRP_";"_TYP_U_TXT + Q +DELPI ; delete PI from ORDIALOG if PI = "" + ;Called from SAVE^ORWDX + N ORPI S ORPI=0 + S ORPI=$O(^ORD(101.41,"B","OR GTX PATIENT INSTRUCTIONS",ORPI)) + Q:'$D(ORDIALOG(ORPI)) + I '$D(ORDIALOG(ORPI,1)) K ORDIALOG(ORPI),ORDIALOG("WP",ORPI) Q + N PINODE,PITX + S PITX="",PINODE=$G(ORDIALOG(ORPI,1)) + S PITX=$G(@PINODE@(1,0)) + S PITX=$TR(PITX," ","") + I '$L(PITX) K ORDIALOG(ORPI),ORDIALOG("WP",ORPI) + Q +FNDINFO(Y,ODIEN) ; + N ODI,CRTM,FRM,XX + S FRM="",CRTM=$$NOW^XLFDT + F S FRM=$O(^ORD(101.43,XRF,FRM)) Q:FRM="" D + . S ODI=0 F S ODI=$O(^ORD(101.43,XRF,FRM,ODI)) Q:'ODI D + .. S XX=^ORD(101.43,XRF,FRM,ODI) + .. I +$P(XX,U,3),$P(XX,U,3)"_U_$P(XX,U,4) + Q +DLGDEF(LST,DLG) ; Format mapping for a dlg + N I,IEN,ILST,X0,X2,XW S ILST=0 + I $O(^ORD(101.41,"AB",DLG,0))>0 S DLG=$O(^ORD(101.41,"AB",DLG,0)) + E S DLG=$O(^ORD(101.41,"B",DLG,0)) + Q:'DLG + S I=0 F S I=$O(^ORD(101.41,DLG,10,I)) Q:I'>0 D + . S X0=$G(^ORD(101.41,DLG,10,I,0)),X2=$G(^(2)),IEN=+$P(X0,U,2) + . S ILST=ILST+1,LST(ILST)=U_IEN_U_$P(X2,U,1,7) + . I $P(X0,U,11) S $P(LST(ILST),U,11)=1 + . S $P(LST(ILST),U)=$P($G(^ORD(101.41,IEN,1)),U,3) + . I $P($G(^ORD(101.41,IEN,0)),U)="OR GTX ADDITIVE" S $P(LST(ILST),U)="ADDITIVE" + . I $P($G(^ORD(101.41,IEN,0)),U)="OR GTX ADDL DIETS" S $P(LST(ILST),U)="ADDLDIETS" + . I $L($P(LST(ILST),U))=0 S $P(LST(ILST),U)="ID"_IEN + . I $D(^ORD(101.41,DLG,10,"DAD",IEN)) D + .. N SEQ,DA,CHILD S CHILD="" + .. S SEQ=0 F S SEQ=$O(^ORD(101.41,DLG,10,"DAD",IEN,SEQ)) Q:'SEQ D + ... S DA=0 F S DA=$O(^ORD(101.41,DLG,10,"DAD",IEN,SEQ,DA)) Q:'DA D + .... S CHILD=CHILD_+$P($G(^ORD(101.41,DLG,10,DA,0)),U,2)_"~" + .. S $P(LST(ILST),U,10)=CHILD + Q + ; +CHANGE(ORLST,ORCLST,DFN) ; + N CATCH,CNT,INP,INPDIEN,IVM,IVMDIEN,ORIEN,ORLOC,OR3,ORDG + N CIEN,DIAL,TDIAL,TDIEN,UDIEN,QORDDG + S (INP,IVM,INPDIEN,IVMDIEN,UDIEN)=0 + S (TDIAL,TDIEN)=0 + S INP=$O(^ORD(101.41,"B","PSJ OR PAT OE","")) Q:INP'>0 + S IVM=$O(^ORD(101.41,"B","PSJI OR PAT FLUID OE","")) Q:IVM'>0 + S TDIAL=$O(^ORD(101.41,"B","OR GXTEXT WORD PROCESSING ORDE","")) Q:TDIAL'>0 + S INPDIEN=$O(^ORD(100.98,"B","INPATIENT MEDICATIONS","")) Q:INPDIEN'>0 + S IVMDIEN=$O(^ORD(100.98,"B","IV MEDICATIONS","")) Q:IVMDIEN'>0 + S UDIEN=$O(^ORD(100.98,"B","UNIT DOSE MEDICATIONS","")) Q:UDIEN'>0 + S TIEN=$O(^ORD(100.98,"B","NURSING","")) Q:TIEN'>0 + S CIEN=$O(^ORD(100.98,"B","CLINIC ORDERS","")) Q:CIEN'>0 + S CNT=0 F S CNT=$O(ORCLST(CNT)) Q:CNT'>0 D + .S CHANGE=0 + .S ORIEN=$P($G(ORCLST(CNT)),U),ORIEN=$P(ORIEN,";") + .S ORDG=$P($G(^OR(100,ORIEN,0)),U,11) + .I ORDG'=INPDIEN,ORDG'=IVMDIEN,ORDG'=UDIEN,ORDG'=TIEN,ORDG'=CIEN Q + .S ORLOC=$P($G(ORCLST(CNT)),U,2) + .S OR3=$G(^OR(100,ORIEN,3)) + .S DIAL=$P(OR3,U,4) + . + .; + .I $P($G(^OR(100,ORIEN,0)),U,10)=(ORLOC_";SC(") D Q + ..;Remove treating spec. if IMO order 26.42 + ..I $P($G(^OR(100,ORIEN,0)),U,11)=CIEN S $P(^OR(100,ORIEN,0),U,13)="" + .; + .;CHANGE PATIENT LOCATION AND PATIENT STATUS. + .S $P(^OR(100,ORIEN,0),U,10)=ORLOC_";SC(" + .S $P(^OR(100,ORIEN,0),U,12)="I" + .; + .;Check for IMO orders Nursing Dialog problem + .S CATCH=$P($G(^OR(100,ORIEN,0)),U,11) + .; + .S $P(^OR(100,ORIEN,0),U,11)=$S(DIAL=(IVM_";ORD(101.41,"):IVMDIEN,DIAL=(INP_";ORD(101.41,"):INPDIEN,DIAL=(TDIAL_";ORD(101.41,"):TIEN,1:CATCH) + .; + .;Check for Quick Order Dialog + .I CATCH=$P($G(^OR(100,ORIEN,0)),U,11) D + ..S QORDDG=$P($G(^ORD(101.41,+DIAL,0)),U,5) + ..I QORDDG=UDIEN!(QORDDG=INPDIEN) S $P(^OR(100,ORIEN,0),U,11)=INPDIEN,DIAL=(INP_";ORD(101.41,") Q + ..I QORDDG=IVMDIEN S $P(^OR(100,ORIEN,0),U,11)=IVMDIEN,DIAL=(IVM_";ORD(101.41,") Q + ..I QORDDG=TIEN S $P(^OR(100,ORIEN,0),U,11)=TIEN,DIAL=(TDIAL_";ORD(101.41,") Q + .; + .;Add treating spec if Inpatient order + .I (DIAL=(IVM_";ORD(101.41,"))!(DIAL=(INP_";ORD(101.41,")) D + ..S $P(^OR(100,ORIEN,0),U,13)=+$G(^DPT(DFN,.103)) + Q + ; +STCHANGE(ORY,DFN,ORYARR) ; + N CNT,DONE,NODE,PHARMID,STR,STATUS + S ORY=0,DONE=0 + I '$$PATCH^XPDUTL("PSS*1.0*93") Q + S CNT=0 F S CNT=$O(ORYARR(CNT)) Q:CNT'>0!(DONE>0) D + . S NODE=$G(ORYARR(CNT)) + . S PHARMID=$P(NODE,U),STATUS=$P(NODE,U,2) + . I $$UP^XLFSTR(STATUS)'=$$STATUS^PSSORUTE(DFN,PHARMID) S ORY=1,DONE=1 + Q +DCREN(ORY,ORYARR) ; + N ACT,CNT,CNT1,I,OR3,ORG,ORGID,ORID,TEXT,STATUS + S CNT1=0 + S CNT=0 F S CNT=$O(ORYARR(CNT)) Q:CNT'>0 D + .S ORGID=ORYARR(CNT) + .S ORID=+ORGID,ACT=$P(ORGID,";",2),TEXT="" + .S OR3=$G(^OR(100,ORID,3)) + .;Make sure current order status is pending + .I $P($G(^ORD(100.01,$P(OR3,U,3),0)),U)'="PENDING" Q + .S ORG=$P($G(OR3),U,5) Q:ORG'>0 + .;do not add original order if it is expired + .S STATUS=$P(^OR(100,ORG,3),U,3) + .I $P($G(^ORD(100.01,STATUS,0)),U)="EXPIRED" Q + .;make sure current order is a renewed order + .I $P(OR3,U,11)'=2 Q + .S ACT=+$P($G(^OR(100,ORG,3)),U,7) + .S CNT1=CNT1+1,ORY(CNT1)=ORGID_U_$P(OR3,U,5)_";"_ACT_U_TEXT + Q +PATWARD(ORY,DFN) ; + S ORY=0 + I $G(^DPT(DFN,.1))'="" S ORY=1 + Q +ISPEND(ORIFN) ;Is the order's status pending? + N ISPEND,PENDST,N3 S ISPEND=0 + Q:'$D(^OR(100,+ORIFN,3)) + S PENDST=$O(^ORD(100.01,"B","PENDING",0)) + S N3=$G(^OR(100,+ORIFN,3)) + I $P(N3,U,3)=PENDST S ISPEND=1 + Q ISPEND diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXA.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXA.m index b789a93d..699ced37 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXA.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXA.m @@ -1,224 +1,230 @@ -ORWDXA ; SLC/KCM/JLI - Utilites for Order Actions; 10/07/2007 ; 2/7/08 11:48am - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,132,148,141,149,187,213,195,215,243**;Dec 17, 1997;Build 242 - ; -VALID(VAL,ORID,ACTION,ORNP,ORWNAT) ; Return error message if not valid action for order - N ORACT,ORVP,ORVER,ORIFN,PRTID S VAL="",PRTID=0 - I +ORID=0 S VAL="This order has been deleted." Q - I '$D(^OR(100,+ORID,0)) S VAL="This order has been deleted!" Q - I ACTION="XFR",'$L($T(XFR^ORCACT01)) S ACTION="RW" ; for pre-POE - N ORNSS S ORNSS=1 - I (ACTION="RN") D VALSCH^ORWNSS(.ORNSS,ORID) - I ORNSS=0 S VAL="This order contains an invalid administration schedule." Q - I (ACTION="RN") D ISVALIV^ORWDPS33(.VAL,ORID,ACTION) I $L(VAL)>0 Q - S ORIFN=ORID,ORVP=$P(^OR(100,+ORID,0),U,2) ; ORCACT0 expects defined - I (ACTION="RN") D Q:$L(VAL) ; ** There's got to be a better way! - . N DLG S DLG=$P(^OR(100,+ORID,0),U,5) Q:DLG'[";ORD(101.41," - . I $G(^ORD(101.41,+DLG,3))'["PROVIDER^ORCDPSIV" Q - . D AUTH^ORWDPS32(.VAL,ORNP) - . I VAL S VAL=$P(VAL,U,2) - . E S VAL="" - S ORVER=$S(ACTION="CR":"R",$D(^XUSEC("ORELSE",DUZ)):"N",$D(^XUSEC("OREMAS",DUZ)):"C",1:"^") - I ACTION="CR" S ACTION="VR" - I (ACTION="ES")!(ACTION="OC")!(ACTION="RS") S ORACT=ACTION ; why not defined??? - I (ACTION="VR"),'($D(^XUSEC("ORELSE",DUZ))!$D(^XUSEC("OREMAS",DUZ))) D Q - . S VAL="You are not authorized to verify these orders." - I $L(VAL) Q - N OIIEN,ISIV,IVOD - S (ISIV,OIIEN,IVOD)=0 - I (ACTION="RW")!(ACTION="XX")!(ACTION="XFR") D Q:$L(VAL) - . S ISIV=$P(^OR(100,+ORID,0),U,11) - . I ISIV,($P(^ORD(100.98,ISIV,0),U,3)="IV RX") S IVOD=1 - . D:'IVOD GTORITM^ORWDXR(.OIIEN,+ORID) - . D:OIIEN ISACTOI(.VAL,OIIEN) I $L(VAL)>0 Q - . N DLG,FRM - . S DLG=$P(^OR(100,+ORID,0),U,5),FRM=0 - . I $P(DLG,";",2)'="ORD(101.41," S DLG=0 - . I DLG D FORMID^ORWDXM(.FRM,+DLG) - . I '(DLG&FRM) D - . . S VAL="Copy & Change are not implemented for this order that predates CPRS." - N OREBUILD ; sometimes left defined by $$VALID - ;I (ACTION="RW")!(ACTION="XFR")!(ACTION="RN") D ISVALIV^ORWDPS33(.VAL,ORID,ACTION) I $L(VAL)>0 Q - I $$VALID^ORCACT0(ORID,ACTION,.VAL,$G(ORWNAT)) S VAL="" ; VAL=error - Q - ; -HOLD(REC,ORID,ORNP) ; Place an order on hold - N ACTDA - S ACTDA=$$ACTION^ORCSAVE("HD",+ORID,ORNP) - D GETBYIFN^ORWORR(.REC,+ORID_";"_ACTDA) - Q -UNHOLD(REC,ORID,ORNP) ; Release an order from hold - N ACTDA - S ACTDA=$$ACTION^ORCSAVE("RL",+ORID,ORNP) - D GETBYIFN^ORWORR(.REC,+ORID_";"_ACTDA) - Q -DC(REC,ORID,ORNP,ORL,REASON,DCORIG,ISNEWORD) ; Discontinue/Cancel/Delete an order - N NATURE,CREATE,PRINT,STATUS,ACTDA,SIGSTS - N X3,X8,CURRACT - Q:'+ORID - I $G(DCORIG)="" S DCORIG=0 - S CURRACT=0 - S ORL(2)=ORL_";SC(",ORL=ORL(2),NATURE="" - I REASON S NATURE=$P(^ORD(100.02,$P(^ORD(100.03,REASON,0),U,7),0),U,2) - S:NATURE="" NATURE="W" ; S:ORNP=DUZ NATURE="E" - ;change the way create work to support forcing signature for all DC - ;reasons - S CREATE=1,PRINT=$$PRINT^ORCACT2(NATURE) - ;S CREATE=$$CREATE^ORX1(NATURE) - S X3=$G(^OR(100,+ORID,3)) - S CURRACT=$P(X3,U,7) S:CURRACT<1 CURRACT=+$O(^OR(100,+ORID,8,"?"),-1) - I '$D(^OR(100,+ORID,8,+$P(ORID,";",2),0)) D - . S X8=$G(^OR(100,+ORID,8,CURRACT,0)) - . S SIGSTS=$P(X8,U,4) - . S $P(ORID,";",2)=CURRACT - E D - . S X8=^OR(100,+ORID,8,+$P(ORID,";",2),0) - . S SIGSTS=$P(X8,U,4) - I '$D(SIGSTS) S SIGSTS=1 - S STATUS=$P($G(^OR(100,+ORID,8,+$P(ORID,";",2),0)),U,15) - I (STATUS=10)!(STATUS=11) D Q ; delete/cancel unreleased order - . N RPLORD - . S RPLORD=$P($G(^OR(100,+ORID,3)),U,5) ; replaced order - . D GETBYIFN^ORWORR(.REC,ORID) - . I STATUS=10,($P(X8,U,4)'=2) D ; CANCEL signed, delayed, unreleased - . . ; taken from CLRDLY^ORCACT2 - . . I REASON D SET^ORCACT2(+ORID,NATURE,REASON,,DCORIG) - . . I 'REASON D SET^ORCACT2(+ORID,"M","","Delayed Order Cancelled",DCORIG) - . . D STATUS^ORCSAVE2(+ORID,13) S $P(^OR(100,+ORID,8,1,0),U,15)=13 - . E D ; CANCEL OR DELETE unsigned, unreleased - . . I $P(X8,U,2)="DC" K ^OR(100,+ORID,6) - . . ; delete fwd ptr to order about to be deleted - . . I RPLORD,$P(X8,U,2)="NW" S $P(^OR(100,RPLORD,3),U,6)="" - . . ; delete ptr to order in Patient Event file #100.2 - . . N EVT S EVT=$P($G(^OR(100,+ORID,0)),U,17) I EVT,EVT=+$O(^ORE(100.2,"AO",+ORID,0)) S $P(^ORE(100.2,EVT,0),U,4)="" K ^ORE(100.2,"AO",+ORID,EVT) - . . I $G(ISNEWORD) D DELETE^ORCSAVE2(ORID) - . . I '$G(ISNEWORD) D CANCEL^ORCSAVE2(ORID) - . I RPLORD,'(SIGSTS=1) S ORID=RPLORD ; for Renews & Changes, show replaced order - . I '$D(^OR(100,+ORID)) D - . . S $P(REC(1),U)="~0",REC(2)="tDELETED: "_$E(REC(2),2,245) - . E D - . . K REC - . . D GETBYIFN^ORWORR(.REC,+ORID_";"_$P($G(^OR(100,+ORID,3)),U,7)) - . S $P(REC(1),U,14)=2 ; DCType = deletion - S ACTDA=$$ACTION^ORCSAVE("DC",+ORID,ORNP) - D SET^ORCACT2(+ORID,NATURE,REASON,,DCORIG) - D GETBYIFN^ORWORR(.REC,+ORID_";"_ACTDA) - S $P(REC(1),U,14)=$S(CREATE:1,1:3) ;DCType - 1=NewOrder, 3=NewStatus - N PKG - S PKG=$P($G(^OR(100,+ORID,0)),U,14) - S PKG=$$NMSP^ORCD(PKG) - I REASON=16&(PKG="PS") D - . N XMB - . S XMB="OR DRUG ORDER CANCELLED" - . S XMB(1)=$P($G(REC(2)),"tDiscontinue",2),XMB(4)=$P($G(^VA(200,DUZ,0)),U) - . S XMB(2)=+ORID - . S XMB(3)=+$P($G(^OR(100,+ORID,0)),U,2) - . S XMB(3)=$P($G(^DPT(XMB(3),0)),U) - . D ^XMB - Q -DCREQIEN(VAL) ; Return the IEN for Requesting Physician Cancelled reason - S VAL=$O(^ORD(100.03,"S","REQ",0)) - Q -COMPLETE(REC,ORID,ESCODE) ; Complete an order (generic orders) - ;N X S X=+$E($$NOW^XLFDT,1,12) - ;D DATES^ORCSAVE2(+ORID,,X) - ;D STATUS^ORCSAVE2(+ORID,2) - ; validate ESCode - D COMP^ORCSAVE2(ORID) - D GETBYIFN^ORWORR(.REC,ORID) - Q -VERIFY(REC,ORID,ESCODE,ORVER) ; Verify an order - ; validate ESCode - S ORVER=$G(ORVER,$S($D(^XUSEC("ORELSE",DUZ)):"N",$D(^XUSEC("OREMAS",DUZ)):"C",1:U)) - I ORVER'=U D - . N ORIFN,ORES,ORI - . ; to match 56, need to VERIFY any replaced orders: - . S ORIFN=ORID,ORES(ORIFN)="" D REPLCD^ORCACT1 - . S ORI="" F S ORI=$O(ORES(ORI)) Q:ORI="" D EN^ORCSEND(ORI,"VR","",""),UNLK1^ORX2(+ORI):ORI'=ORID ;ORID locked prior - D GETBYIFN^ORWORR(.REC,ORID) - Q -ALERT(DUMMY,ORID,ORDUZ) ;send alert to user (ORDUZ) when order (ORID) resulted - ;if no user passed from GUI, use ordering provider: - I $G(ORDUZ)<1 S ORDUZ=+$$ORDERER^ORQOR2(+ORID) - I $L($G(ORDUZ))<1 S ORDUZ=DUZ - S DUMMY=1,$P(^OR(100,+ORID,3),U,10)=ORDUZ - Q -FLAG(REC,ORIFN,OREASON,ORNP) ; Flag an order - N ORB,ORVP,DA,ORPS - D BULLETIN - S DA=$P(ORIFN,";",2),ORVP=+$P(^OR(100,+ORIFN,0),U,2) - K ^OR(100,+ORIFN,8,DA,3) S ^(3)="1^"_$G(XMZ)_U_+$E($$NOW^XLFDT,1,12)_U_DUZ_U_OREASON_$S($G(ORNP):"^^^^"_+ORNP,1:"") - D KILL^XM,MSG^ORCFLAG(ORIFN) - S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ; Last Activity - I +$G(ORNP)<1 S ORNP=+$P($G(^OR(100,+ORIFN,8,DA,0)),U,3) - S ORB=+ORVP_U_+ORIFN_U_ORNP_"^1" D EN^OCXOERR(ORB) ; notification - D GETBYIFN^ORWORR(.REC,ORIFN) - Q -BULLETIN ; Send flagged order bulletin (USED BY FLAG) - N OR0,OR3,ORDTXT,XMB,XMY,XMDUZ,ORENT,BULL,ORSRV,ORUSR - S OR0=$G(^OR(100,+ORIFN,0)),OR3=$G(^(3)) - ;CLA - 3/21/96: - S ORUSR=+$P(OR0,U,4) - S ORSRV=$G(^VA(200,ORUSR,5)) I +ORSRV>0 S ORSRV=$P(ORSRV,U) - S ORENT="USR.`"_ORUSR_"^SRV.`"_$G(ORSRV)_"^DIV^SYS^PKG" - S BULL=$$GET^XPAR(ORENT,"ORB FLAGGED ORDERS BULLETIN",1,"Q") - Q:$G(BULL)'="Y" ;quit if parameter value is not 'Y'es - ; - S XMB="OR FLAGGED ORDER",XMDUZ=DUZ,XMY(+$P(OR0,U,4))="" - S XMB(1)=$P(^DPT(+$P(OR0,U,2),0),U),XMB(2)=$P(^(0),U,9),XMB(3)="" ;sb AGE - S XMB(4)=$$FMTE^XLFDT($P(OR0,U,7)) - D TEXT^ORQ12(.ORDTXT,+ORIFN,80) - S XMB(5)=$G(ORDTXT(1)),XMB(6)=$G(ORDTXT(2)),XMB(7)=$G(ORDTXT(3)) - S XMB(8)=$$FMTE^XLFDT($P(OR0,U,8)),XMB(9)=$$FMTE^XLFDT($P(OR0,U,9)),XMB(10)=OREASON - S XMB(11)=$P($G(^ORD(100.01,+$P(OR3,U,3),0)),U) - D EN^XMB - Q -UNFLAG(REC,ORIFN,OREASON) ; Unflag an order - N DA,ORB,ORNP,ORVP,ORPS - S DA=$P(ORIFN,";",2),ORVP=+$P(^OR(100,+ORIFN,0),U,2) - S $P(^OR(100,+ORIFN,8,DA,3),U)=0,$P(^(3),U,6,8)=+$E($$NOW^XLFDT,1,12)_U_DUZ_U_OREASON D MSG^ORCFLAG(ORIFN) - S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ; Last Activity - S ORNP=+$P($G(^OR(100,+ORIFN,8,DA,0)),U,3) - S ORB=+ORVP_U_+ORIFN_U_ORNP_"^0" D EN^OCXOERR(ORB) ; notification - D GETBYIFN^ORWORR(.REC,ORIFN) - Q -FLAGTXT(LST,ORID) ; Return flag reason - N FLAG - S FLAG=$G(^OR(100,+ORID,8,$P(ORID,";",2),3)) - S LST(1)="FLAGGED: "_$$FMTE^XLFDT($P(FLAG,U,3))_" by "_$P($G(^VA(200,+$P(FLAG,U,4),0)),U) - S LST(2)=$P(FLAG,U,5) ; reason - Q -WCGET(LST,ORID) ; Return ward comments - N I,ORIFN,ACT S ORIFN=+ORID,ACT=+$P(ORID,";",2) - S I=0 F S I=$O(^OR(100,ORIFN,8,ACT,5,I)) Q:'I S LST(I)=$G(^(I,0)) - Q -WCPUT(ERR,ORID,WCLST) ; Set ward comments for order - N DIERR,ERRLST,ORIFN,ACT S ORIFN=+ORID,ACT=+$P(ORID,";",2) - D WP^DIE(100.008,ACT_","_ORIFN_",",50,"","WCLST","ERRLST") - S ERR="" I $D(DIERR) S ERR="An error occurred while saving comments." - Q -OFCPLX(ORY,ORID,PRTORDER) ;Check if ORID is an child of the PRTORDER - N NUMCHDS,NOWID,NOWVAL,X3,ORDA,ISNOW - Q:'$D(^OR(100,+ORID,0)) - S ISNOW=0 - D ISNOW^ORWDXR(.ISNOW,+ORID) - Q:ISNOW - N PKG - S PKG=$P($G(^OR(100,+ORID,0)),U,14) - S PKG=$$NMSP^ORCD(PKG) - I PKG'="PS" Q - I $L($G(^OR(100,+ORID,3))),('$L($P(^(3),U,9))) Q - S (NUMCHDS,NOWID,NOWVAL,X3,ORDA)=0 - S PRTORDER=+$P(^(3),U,9) - S X3=$G(^OR(100,PRTORDER,3)),ORDA=$P(X3,U,7) - S PRTORDER=PRTORDER_";"_ORDA - S NUMCHDS=$P($G(^OR(100,+PRTORDER,2,0)),U,4) - I NUMCHDS>2 S ORY="COMPLEX-PSI"_U_PRTORDER - S:$D(^OR(100,+PRTORDER,4.5,"ID","NOW")) NOWID=$O(^("NOW",0)) - S:NOWID NOWVAL=$G(^OR(100,+PRTORDER,4.5,NOWID,1)) - I NOWVAL=1 Q - E S ORY="COMPLEX-PSI"_U_PRTORDER - Q -ISACTOI(ORY,OI) ;If it's an active orderable item - I $G(^ORD(101.43,+OI,.1)),^(.1)'>$$NOW^XLFDT D - . S ORY=$P($G(^ORD(101.43,OI,0)),U)_" has been inactivated and may not be ordered anymore." - Q +ORWDXA ; SLC/KCM/JLI - Utilites for Order Actions; 2/10/03 9:13Am [6/7/05 2:09pm] + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,132,148,141,149,187,213,195,215**;Dec 17, 1997 + ; +VALID(VAL,ORID,ACTION,ORNP,ORWNAT) ; Return error message if not valid action for order + N ORACT,ORVP,ORVER,ORIFN,PRTID S VAL="",PRTID=0 + I +ORID=0 S VAL="This order has been deleted." Q + I '$D(^OR(100,+ORID,0)) S VAL="This order has been deleted!" Q + I ACTION="XFR",'$L($T(XFR^ORCACT01)) S ACTION="RW" ; for pre-POE + N ORNSS S ORNSS=1 + I (ACTION="RN") D VALSCH^ORWNSS(.ORNSS,ORID) + I ORNSS=0 S VAL="This order contains an invalid administration schedule." Q + S ORIFN=ORID,ORVP=$P(^OR(100,+ORID,0),U,2) ; ORCACT0 expects defined + I (ACTION="RN") D Q:$L(VAL) ; ** There's got to be a better way! + . N DLG S DLG=$P(^OR(100,+ORID,0),U,5) Q:DLG'[";ORD(101.41," + . I $G(^ORD(101.41,+DLG,3))'["PROVIDER^ORCDPSIV" Q + . D AUTH^ORWDPS32(.VAL,ORNP) + . I VAL S VAL=$P(VAL,U,2) + . E S VAL="" + S ORVER=$S(ACTION="CR":"R",$D(^XUSEC("ORELSE",DUZ)):"N",$D(^XUSEC("OREMAS",DUZ)):"C",1:"^") + I ACTION="CR" S ACTION="VR" + I (ACTION="ES")!(ACTION="OC")!(ACTION="RS") S ORACT=ACTION ; why not defined??? + I (ACTION="VR"),'($D(^XUSEC("ORELSE",DUZ))!$D(^XUSEC("OREMAS",DUZ))) D Q + . S VAL="You are not authorized to verify these orders." + I $L(VAL) Q + N OIIEN,ISIV,IVOD + S (ISIV,OIIEN,IVOD)=0 + I (ACTION="RW")!(ACTION="XX")!(ACTION="XFR") D Q:$L(VAL) + . S ISIV=$P(^OR(100,+ORID,0),U,11) + . I ISIV,($P(^ORD(100.98,ISIV,0),U,3)="IV RX") S IVOD=1 + . D:'IVOD GTORITM^ORWDXR(.OIIEN,+ORID) + . D:OIIEN ISACTOI(.VAL,OIIEN) I $L(VAL)>0 Q + . N DLG,FRM + . S DLG=$P(^OR(100,+ORID,0),U,5),FRM=0 + . I $P(DLG,";",2)'="ORD(101.41," S DLG=0 + . I DLG D FORMID^ORWDXM(.FRM,+DLG) + . I '(DLG&FRM) D + . . S VAL="Copy & Change are not implemented for this order that predates CPRS." + N OREBUILD ; sometimes left defined by $$VALID + I $$VALID^ORCACT0(ORID,ACTION,.VAL,$G(ORWNAT)) S VAL="" ; VAL=error + Q +HOLD(REC,ORID,ORNP) ; Place an order on hold + N ACTDA + S ACTDA=$$ACTION^ORCSAVE("HD",+ORID,ORNP) + D GETBYIFN^ORWORR(.REC,+ORID_";"_ACTDA) + Q +UNHOLD(REC,ORID,ORNP) ; Release an order from hold + N ACTDA + S ACTDA=$$ACTION^ORCSAVE("RL",+ORID,ORNP) + D GETBYIFN^ORWORR(.REC,+ORID_";"_ACTDA) + Q +DC(REC,ORID,ORNP,ORL,REASON) ; Discontinue/Cancel/Delete an order + N NATURE,CREATE,PRINT,STATUS,ACTDA,SIGSTS + N X3,X8,CURRACT + Q:'+ORID + S CURRACT=0 + S ORL(2)=ORL_";SC(",ORL=ORL(2),NATURE="" + I REASON S NATURE=$P(^ORD(100.02,$P(^ORD(100.03,REASON,0),U,7),0),U,2) + S:NATURE="" NATURE="W" ; S:ORNP=DUZ NATURE="E" + ;change the way create work to support forcing signature for all DC + ;reasons + S CREATE=1,PRINT=$$PRINT^ORCACT2(NATURE) + ;S CREATE=$$CREATE^ORX1(NATURE) + S X3=$G(^OR(100,+ORID,3)) + S CURRACT=$P(X3,U,7) S:CURRACT<1 CURRACT=+$O(^OR(100,+ORID,8,"?"),-1) + I '$D(^OR(100,+ORID,8,+$P(ORID,";",2),0)) D + . S X8=$G(^OR(100,+ORID,8,CURRACT,0)) + . S SIGSTS=$P(X8,U,4) + . S $P(ORID,";",2)=CURRACT + E D + . S X8=^OR(100,+ORID,8,+$P(ORID,";",2),0) + . S SIGSTS=$P(X8,U,4) + I '$D(SIGSTS) S SIGSTS=1 + S STATUS=$P($G(^OR(100,+ORID,8,+$P(ORID,";",2),0)),U,15) + I (STATUS=10)!(STATUS=11) D Q ; delete/cancel unreleased order + . N RPLORD + . S RPLORD=$P($G(^OR(100,+ORID,3)),U,5) ; replaced order + . D GETBYIFN^ORWORR(.REC,ORID) + . I STATUS=10,($P(X8,U,4)'=2) D ; CANCEL signed, delayed, unreleased + . . ; taken from CLRDLY^ORCACT2 + . . I REASON D SET^ORCACT2(+ORID,NATURE,REASON) + . . I 'REASON D SET^ORCACT2(+ORID,"M","","Delayed Order Cancelled") + . . D STATUS^ORCSAVE2(+ORID,13) S $P(^OR(100,+ORID,8,1,0),U,15)=13 + . E D ; DELETE unsigned, unreleased + . . I $P(X8,U,2)="DC" K ^OR(100,+ORID,6) + . . ; delete fwd ptr to order about to be deleted + . . I RPLORD,$P(X8,U,2)="NW" S $P(^OR(100,RPLORD,3),U,6)="" + . . ; delete ptr to order in Patient Event file #100.2 + . . N EVT S EVT=$P($G(^OR(100,+ORID,0)),U,17) I EVT,EVT=+$O(^ORE(100.2,"AO",+ORID,0)) S $P(^ORE(100.2,EVT,0),U,4)="" K ^ORE(100.2,"AO",+ORID,EVT) + . . D DELETE^ORCSAVE2(ORID) + . I RPLORD,'(SIGSTS=1) S ORID=RPLORD ; for Renews & Changes, show replaced order + . I '$D(^OR(100,+ORID)) D + . . S $P(REC(1),U)="~0",REC(2)="tDELETED: "_$E(REC(2),2,245) + . E D + . . K REC + . . D GETBYIFN^ORWORR(.REC,+ORID_";"_$P($G(^OR(100,+ORID,3)),U,7)) + . S $P(REC(1),U,14)=2 ; DCType = deletion + S ACTDA=$$ACTION^ORCSAVE("DC",+ORID,ORNP) + D SET^ORCACT2(+ORID,NATURE,REASON) + D GETBYIFN^ORWORR(.REC,+ORID_";"_ACTDA) + S $P(REC(1),U,14)=$S(CREATE:1,1:3) ;DCType - 1=NewOrder, 3=NewStatus + N PKG + S PKG=$P($G(^OR(100,+ORID,0)),U,14) + S PKG=$$NMSP^ORCD(PKG) + I REASON=16&(PKG="PS") D + . N XMB + . S XMB="OR DRUG ORDER CANCELLED" + . S XMB(1)=$P($G(REC(2)),"tDiscontinue",2),XMB(4)=$P($G(^VA(200,DUZ,0)),U) + . S XMB(2)=+ORID + . S XMB(3)=+$P($G(^OR(100,+ORID,0)),U,2) + . S XMB(3)=$P($G(^DPT(XMB(3),0)),U) + . D ^XMB + Q +DCREASON(LST) ; Return a list of DC reasons + N IEN,ILST,X + S ILST=1,LST(ILST)="~DCReason" + S IEN=0 F S IEN=$O(^ORD(100.03,IEN)) Q:'IEN S X=^(IEN,0) D + . I $P(X,U,4) Q ; inactive + . I $P(X,U,5)'=+$O(^DIC(9.4,"C","OR",0)) Q ; not OR pkg + . I $P(X,U,7)=+$O(^ORD(100.02,"C","A",0)) Q ; nature=auto + . S ILST=ILST+1,LST(ILST)="i"_IEN_U_$P(X,U) + S IEN=$O(^ORD(100.03,"C","ORREQ",0)) + I IEN S ILST=ILST+1,LST(ILST)="d"_IEN_U_$P(^ORD(100.03,IEN,0),U) + Q +DCREQIEN(VAL) ; Return the IEN for Requesting Physician Cancelled reason + S VAL=$O(^ORD(100.03,"S","REQ",0)) + Q +COMPLETE(REC,ORID,ESCODE) ; Complete an order (generic orders) + ;N X S X=+$E($$NOW^XLFDT,1,12) + ;D DATES^ORCSAVE2(+ORID,,X) + ;D STATUS^ORCSAVE2(+ORID,2) + ; validate ESCode + D COMP^ORCSAVE2(ORID) + D GETBYIFN^ORWORR(.REC,ORID) + Q +VERIFY(REC,ORID,ESCODE,ORVER) ; Verify an order + ; validate ESCode + S ORVER=$G(ORVER,$S($D(^XUSEC("ORELSE",DUZ)):"N",$D(^XUSEC("OREMAS",DUZ)):"C",1:U)) + I ORVER'=U D + . N ORIFN,ORES,ORI + . ; to match 56, need to VERIFY any replaced orders: + . S ORIFN=ORID,ORES(ORIFN)="" D REPLCD^ORCACT1 + . S ORI="" F S ORI=$O(ORES(ORI)) Q:ORI="" D EN^ORCSEND(ORI,"VR","",""),UNLK1^ORX2(+ORI):ORI'=ORID ;ORID locked prior + D GETBYIFN^ORWORR(.REC,ORID) + Q +ALERT(DUMMY,ORID,ORDUZ) ;send alert to user (ORDUZ) when order (ORID) resulted + ;if no user passed from GUI, use ordering provider: + I $G(ORDUZ)<1 S ORDUZ=+$$ORDERER^ORQOR2(+ORID) + I $L($G(ORDUZ))<1 S ORDUZ=DUZ + S DUMMY=1,$P(^OR(100,+ORID,3),U,10)=ORDUZ + Q +FLAG(REC,ORIFN,OREASON,ORNP) ; Flag an order + N ORB,ORVP,DA,ORPS + D BULLETIN + S DA=$P(ORIFN,";",2),ORVP=+$P(^OR(100,+ORIFN,0),U,2) + K ^OR(100,+ORIFN,8,DA,3) S ^(3)="1^"_$G(XMZ)_U_+$E($$NOW^XLFDT,1,12)_U_DUZ_U_OREASON + D KILL^XM,MSG^ORCFLAG(ORIFN) + S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ; Last Activity + I +$G(ORNP)<1 S ORNP=+$P($G(^OR(100,+ORIFN,8,DA,0)),U,3) + S ORB=+ORVP_U_+ORIFN_U_ORNP_"^1" D EN^OCXOERR(ORB) ; notification + D GETBYIFN^ORWORR(.REC,ORIFN) + Q +BULLETIN ; Send flagged order bulletin (USED BY FLAG) + N OR0,OR3,ORDTXT,XMB,XMY,XMDUZ,ORENT,BULL,ORSRV,ORUSR + S OR0=$G(^OR(100,+ORIFN,0)),OR3=$G(^(3)) + ;CLA - 3/21/96: + S ORUSR=+$P(OR0,U,4) + S ORSRV=$G(^VA(200,ORUSR,5)) I +ORSRV>0 S ORSRV=$P(ORSRV,U) + S ORENT="USR.`"_ORUSR_"^SRV.`"_$G(ORSRV)_"^DIV^SYS^PKG" + S BULL=$$GET^XPAR(ORENT,"ORB FLAGGED ORDERS BULLETIN",1,"Q") + Q:$G(BULL)'="Y" ;quit if parameter value is not 'Y'es + ; + S XMB="OR FLAGGED ORDER",XMDUZ=DUZ,XMY(+$P(OR0,U,4))="" + S XMB(1)=$P(^DPT(+$P(OR0,U,2),0),U),XMB(2)=$P(^(0),U,9),XMB(3)="" ;sb AGE + S XMB(4)=$$FMTE^XLFDT($P(OR0,U,7)) + D TEXT^ORQ12(.ORDTXT,+ORIFN,80) + S XMB(5)=$G(ORDTXT(1)),XMB(6)=$G(ORDTXT(2)),XMB(7)=$G(ORDTXT(3)) + S XMB(8)=$$FMTE^XLFDT($P(OR0,U,8)),XMB(9)=$$FMTE^XLFDT($P(OR0,U,9)),XMB(10)=OREASON + S XMB(11)=$P($G(^ORD(100.01,+$P(OR3,U,3),0)),U) + D EN^XMB + Q +UNFLAG(REC,ORIFN,OREASON) ; Unflag an order + N DA,ORB,ORNP,ORVP,ORPS + S DA=$P(ORIFN,";",2),ORVP=+$P(^OR(100,+ORIFN,0),U,2) + S $P(^OR(100,+ORIFN,8,DA,3),U)=0,$P(^(3),U,6,8)=+$E($$NOW^XLFDT,1,12)_U_DUZ_U_OREASON D MSG^ORCFLAG(ORIFN) + S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ; Last Activity + S ORNP=+$P($G(^OR(100,+ORIFN,8,DA,0)),U,3) + S ORB=+ORVP_U_+ORIFN_U_ORNP_"^0" D EN^OCXOERR(ORB) ; notification + D GETBYIFN^ORWORR(.REC,ORIFN) + Q +FLAGTXT(LST,ORID) ; Return flag reason + N FLAG + S FLAG=$G(^OR(100,+ORID,8,$P(ORID,";",2),3)) + S LST(1)="FLAGGED: "_$$FMTE^XLFDT($P(FLAG,U,3))_" by "_$P($G(^VA(200,+$P(FLAG,U,4),0)),U) + S LST(2)=$P(FLAG,U,5) ; reason + Q +WCGET(LST,ORID) ; Return ward comments + N I,ORIFN,ACT S ORIFN=+ORID,ACT=+$P(ORID,";",2) + S I=0 F S I=$O(^OR(100,ORIFN,8,ACT,5,I)) Q:'I S LST(I)=$G(^(I,0)) + Q +WCPUT(ERR,ORID,WCLST) ; Set ward comments for order + N DIERR,ERRLST,ORIFN,ACT S ORIFN=+ORID,ACT=+$P(ORID,";",2) + D WP^DIE(100.008,ACT_","_ORIFN_",",50,"","WCLST","ERRLST") + S ERR="" I $D(DIERR) S ERR="An error occurred while saving comments." + Q +OFCPLX(ORY,ORID,PRTORDER) ;Check if ORID is an child of the PRTORDER + N NUMCHDS,NOWID,NOWVAL,X3,ORDA,ISNOW + Q:'$D(^OR(100,+ORID,0)) + S ISNOW=0 + D ISNOW^ORWDXR(.ISNOW,+ORID) + Q:ISNOW + N PKG + S PKG=$P($G(^OR(100,+ORID,0)),U,14) + S PKG=$$NMSP^ORCD(PKG) + I PKG'="PS" Q + I $L($G(^OR(100,+ORID,3))),('$L($P(^(3),U,9))) Q + S (NUMCHDS,NOWID,NOWVAL,X3,ORDA)=0 + S PRTORDER=+$P(^(3),U,9) + S X3=$G(^OR(100,PRTORDER,3)),ORDA=$P(X3,U,7) + S PRTORDER=PRTORDER_";"_ORDA + S NUMCHDS=$P($G(^OR(100,+PRTORDER,2,0)),U,4) + I NUMCHDS>2 S ORY="COMPLEX-PSI"_U_PRTORDER + S:$D(^OR(100,+PRTORDER,4.5,"ID","NOW")) NOWID=$O(^("NOW",0)) + S:NOWID NOWVAL=$G(^OR(100,+PRTORDER,4.5,NOWID,1)) + I NOWVAL=1 Q + E S ORY="COMPLEX-PSI"_U_PRTORDER + Q +ISACTOI(ORY,OI) ;If it's an active orderable item + I $G(^ORD(101.43,+OI,.1)),^(.1)'>$$NOW^XLFDT D + . S ORY=$P($G(^ORD(101.43,OI,0)),U)_" has been inactivated and may not be ordered anymore." + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXC.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXC.m index 8aea7ad3..3f41fc86 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXC.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXC.m @@ -1,125 +1,124 @@ -ORWDXC ; SLC/KCM - Utilities for Order Checking - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,141,221,243**;Dec 17, 1997;Build 242 - ; -ON(VAL) ; returns E if order checking enabled, otherwise D - S VAL=$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE") - Q -FILLID(VAL,DLG) ; Return the FillerID (namespace) for a dialog - N DGRP - S VAL="",DGRP=$P($G(^ORD(101.41,DLG,0)),U,5) Q:'DGRP - S DLG=$$DEFDLG^ORWDXQ(DGRP) - S VAL=$P($G(^ORD(101.41,DLG,0)),U,7),VAL=$$NMSP^ORCD(VAL) - I VAL="PS" D - . N X - . S X=$P($P($G(^ORD(100.98,DGRP,0)),U,3)," ") - . I $L(X) S VAL="PS"_$S(X="UD":"I",1:X) - Q -DISPLAY(LST,DFN,FID) ; Return list of Order Checks for a FillerID (namespace) - N I,ORX,ORY - S ORX=1,ORX(1)="|"_FID - D EN^ORKCHK(.ORY,DFN,.ORX,"DISPLAY") - S I=0 F S I=$O(ORY(I)) Q:I'>0 S LST(I)=$P(ORY(I),U,4) - Q -ACCEPT(LST,DFN,FID,STRT,ORL,OIL,ORIFN) ; Return list of Order Checks on Accept Order - ; OIL(n)=OIptr^PS|PSIV|LR^PkgInfo - N X,Y,USID,ORCHECK,ORI,ORX,ORY - ; convert relative start date to real start date - S ORL=ORL_";SC(",X=STRT,STRT="" - D:X="AM" AM^ORCSAVE2 D:X="NEXT" NEXT^ORCSAVE2 - I $L(X) S %DT="FTX" D ^%DT S:Y'>0 Y="" S STRT=Y - ; do the SELECT order checks - S ORI=0 F S ORI=$O(OIL(ORI)) Q:'ORI D - . S USID=$$USID(OIL(ORI)) - . S OIL(ORI,"USID")=USID - . S ORX=1,ORX(1)=+OIL(ORI)_"|"_FID_"|"_USID - . D EN^ORKCHK(.ORY,DFN,.ORX,"SELECT") - . I $D(ORY) D RETURN^ORCHECK ; expects ORY, ORCHECK - . K ORX,ORY - ; do the ACCEPT order checks - S (ORI,ORX)=0 F S ORI=$O(OIL(ORI)) Q:'ORI D - . S ORX=ORX+1 - . S ORX(ORX)=+OIL(ORI)_"|"_FID_"|"_OIL(ORI,"USID")_"|"_STRT - . I $P(OIL(ORI),U,2)="LR" S $P(ORX(ORX),"|",6)=$P(OIL(ORI),U,3) - D EN^ORKCHK(.ORY,DFN,.ORX,"ACCEPT") - I $D(ORY) D RETURN^ORCHECK ; expects ORY, ORCHECK - ; return ORCHECK as 1 dimensional list - D CHK2LST - Q -DELAY(LST,DFN,FID,STRT,ORL,OIL) ; Return list of Order Checks on Accept Delayed - ; OIL(n)=OIptr^PS|PSIV|LR^PkgInfo - N X,Y,ORCHECK,ORI,ORX,ORY - ; convert relative start date to real start date - S ORL=ORL_";SC(",X=STRT,STRT="" - D:X="AM" AM^ORCSAVE2 D:X="NEXT" NEXT^ORCSAVE2 - I $L(X) S %DT="FTX" D ^%DT S:Y'>0 Y="" S STRT=Y - ; do the ACCEPT order checks - S (ORI,ORX)=0 F S ORI=$O(OIL(ORI)) Q:'ORI D - . S ORX=ORX+1 - . S ORX(ORX)=+OIL(ORI)_"|"_FID_"|"_$$USID(OIL(ORI))_"|"_STRT - . I $P(OIL(ORI),U,2)="LR" S $P(ORX(ORX),"|",6)=$P(OIL(ORI),U,3) - D EN^ORKCHK(.ORY,DFN,.ORX,"ALL") - I $D(ORY) D RETURN^ORCHECK ; expects ORY, ORCHECK - ; return ORCHECK as 1 dimensional list - D CHK2LST - Q -SESSION(LST,ORVP,ORLST) ; Return list of Order Checks on Release Order - N ORES,ORCHECK - S ORVP=+ORVP_";DPT(" - S I=0 F S I=$O(ORLST(I)) Q:'I D - . I +$P(ORLST(I),";",2)'=1 Q ; order not new - . I $P(ORLST(I),U,3)="0" Q ; order not being released - . S ORES($P(ORLST(I),U))="" - D SESSION^ORCHECK - D CHK2LST - Q -SAVECHK(OK,ORVP,RSN,LST) ; Save order checks for session - N ORCHECK,ORIFN S OK=1 - D LST2CHK - I $L(RSN)>0 S ORCHECK("OK")=RSN - S ORIFN=0 F S ORIFN=$O(ORCHECK(ORIFN)) Q:'ORIFN D OC^ORCSAVE2 - Q -DELORD(OK,ORIFN) ; Delete order - N STS,DIK,DA - S STS=$P(^OR(100,+ORIFN,8,1,0),U,15),OK=0 - I (STS=10)!(STS=11) D Q ; makes sure it's an unreleased order - . S DA=+ORIFN,DIK="^OR(100," Q:'DA - . D ^DIK - . S OK=1 - Q -USID(ORITMX) ; Return universal svc ID for an orderable item - ; ORITMX = OI^NMSP^PKGINFO - N RSLT,ORDRUG S RSLT="" - I $E($P(ORITMX,U,2),1,2)="PS" D - . I $P(ORITMX,U,2)="PSIV" D - . . N PSOI,TYPE,VOL S VOL="" - . . S PSOI=+$P($G(^ORD(101.43,+ORITMX,0)),U,2) - . . S TYPE=$P($P(ORITMX,U,3),";") - . . I TYPE="B" S VOL=$P($P(ORITMX,U,3),";",2) - . . D ENDDIV^PSJORUTL(PSOI,TYPE,VOL,.ORDRUG) - . . S ORDRUG=+ORDRUG - . E S ORDRUG=+$P(ORITMX,U,3) - . S RSLT=$$ENDCM^PSJORUTL(ORDRUG) - . S RSLT=$P(RSLT,U,3)_"^^99NDF^"_ORDRUG_U_$$NAME50^ORPEAPI(ORDRUG)_"^99PSD" - E S RSLT=$$USID^ORMBLD(+ORITMX) - I +$P(RSLT,U)=0,+($P(RSLT,U,4)=0) S RSLT="" ; has to be null (why?) - Q RSLT - ; -CHK2LST ; creates list that can be passed to broker from ORCHECK array - ; expects ORCHECK to be present and populates LST - N ORIFN,ORID,CDL,I,ILST S ILST=1 ;Start array at 1 always leaving room for RDI msg at top - S ORIFN="" F S ORIFN=$O(ORCHECK(ORIFN)) Q:ORIFN="" D - . S CDL=0 F S CDL=$O(ORCHECK(ORIFN,CDL)) Q:'CDL D - . . S I=0 F S I=$O(ORCHECK(ORIFN,CDL,I)) Q:'I D - . . . S ORID=ORIFN I +ORID,(+ORID=ORID) S ORID=ORID_";1" - . . . I '$P(ORCHECK(ORIFN,CDL,I),U,2) Q ; CDL="" means don't show - . . . I $P(ORCHECK(ORIFN,CDL,I),U,1)=99 S LST(1)=ORID_U_ORCHECK(ORIFN,CDL,I) Q ;Put RDI warning at the top - . . . S ILST=ILST+1,LST(ILST)=ORID_U_ORCHECK(ORIFN,CDL,I) - Q -LST2CHK ; create ORCHECK array from list passed by broker - N ORIFN,CDL,I,ILST S I=0 - S ILST=0 F S ILST=$O(LST(ILST)) Q:'ILST D - . S X=LST(ILST) - . S ORIFN=$P(X,U),CDL=$P(X,U,3) - . I +$G(ORIFN)>0,+$G(CDL)>0 D ;cla 12/16/03 - . . S I=I+1,ORCHECK(+ORIFN,CDL,I)=$P(X,U,2,4) - Q +ORWDXC ; SLC/KCM - Utilities for Order Checking + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,141,221**;Dec 17, 1997 + ; +ON(VAL) ; returns E if order checking enabled, otherwise D + S VAL=$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE") + Q +FILLID(VAL,DLG) ; Return the FillerID (namespace) for a dialog + N DGRP + S VAL="",DGRP=$P($G(^ORD(101.41,DLG,0)),U,5) Q:'DGRP + S DLG=$$DEFDLG^ORWDXQ(DGRP) + S VAL=$P($G(^ORD(101.41,DLG,0)),U,7),VAL=$$NMSP^ORCD(VAL) + I VAL="PS" D + . N X + . S X=$P($P($G(^ORD(100.98,DGRP,0)),U,3)," ") + . I $L(X) S VAL="PS"_$S(X="UD":"I",1:X) + Q +DISPLAY(LST,DFN,FID) ; Return list of Order Checks for a FillerID (namespace) + N I,ORX,ORY + S ORX=1,ORX(1)="|"_FID + D EN^ORKCHK(.ORY,DFN,.ORX,"DISPLAY") + S I=0 F S I=$O(ORY(I)) Q:I'>0 S LST(I)=$P(ORY(I),U,4) + Q +ACCEPT(LST,DFN,FID,STRT,ORL,OIL,ORIFN) ; Return list of Order Checks on Accept Order + ; OIL(n)=OIptr^PS|PSIV|LR^PkgInfo + N X,Y,USID,ORCHECK,ORI,ORX,ORY + ; convert relative start date to real start date + S ORL=ORL_";SC(",X=STRT,STRT="" + D:X="AM" AM^ORCSAVE2 D:X="NEXT" NEXT^ORCSAVE2 + I $L(X) S %DT="FTX" D ^%DT S:Y'>0 Y="" S STRT=Y + ; do the SELECT order checks + S ORI=0 F S ORI=$O(OIL(ORI)) Q:'ORI D + . S USID=$$USID(OIL(ORI)) + . S OIL(ORI,"USID")=USID + . S ORX=1,ORX(1)=+OIL(ORI)_"|"_FID_"|"_USID + . D EN^ORKCHK(.ORY,DFN,.ORX,"SELECT") + . I $D(ORY) D RETURN^ORCHECK ; expects ORY, ORCHECK + . K ORX,ORY + ; do the ACCEPT order checks + S (ORI,ORX)=0 F S ORI=$O(OIL(ORI)) Q:'ORI D + . S ORX=ORX+1 + . S ORX(ORX)=+OIL(ORI)_"|"_FID_"|"_OIL(ORI,"USID")_"|"_STRT + . I $P(OIL(ORI),U,2)="LR" S $P(ORX(ORX),"|",6)=$P(OIL(ORI),U,3) + D EN^ORKCHK(.ORY,DFN,.ORX,"ACCEPT") + I $D(ORY) D RETURN^ORCHECK ; expects ORY, ORCHECK + ; return ORCHECK as 1 dimensional list + D CHK2LST + Q +DELAY(LST,DFN,FID,STRT,ORL,OIL) ; Return list of Order Checks on Accept Delayed + ; OIL(n)=OIptr^PS|PSIV|LR^PkgInfo + N X,Y,ORCHECK,ORI,ORX,ORY + ; convert relative start date to real start date + S ORL=ORL_";SC(",X=STRT,STRT="" + D:X="AM" AM^ORCSAVE2 D:X="NEXT" NEXT^ORCSAVE2 + I $L(X) S %DT="FTX" D ^%DT S:Y'>0 Y="" S STRT=Y + ; do the ACCEPT order checks + S (ORI,ORX)=0 F S ORI=$O(OIL(ORI)) Q:'ORI D + . S ORX=ORX+1 + . S ORX(ORX)=+OIL(ORI)_"|"_FID_"|"_$$USID(OIL(ORI))_"|"_STRT + . I $P(OIL(ORI),U,2)="LR" S $P(ORX(ORX),"|",6)=$P(OIL(ORI),U,3) + D EN^ORKCHK(.ORY,DFN,.ORX,"ALL") + I $D(ORY) D RETURN^ORCHECK ; expects ORY, ORCHECK + ; return ORCHECK as 1 dimensional list + D CHK2LST + Q +SESSION(LST,ORVP,ORLST) ; Return list of Order Checks on Release Order + N ORES,ORCHECK + S ORVP=+ORVP_";DPT(" + S I=0 F S I=$O(ORLST(I)) Q:'I D + . I +$P(ORLST(I),";",2)'=1 Q ; order not new + . I $P(ORLST(I),U,3)="0" Q ; order not being released + . S ORES($P(ORLST(I),U))="" + D SESSION^ORCHECK + D CHK2LST + Q +SAVECHK(OK,ORVP,RSN,LST) ; Save order checks for session + N ORCHECK,ORIFN S OK=1 + D LST2CHK + I $L(RSN)>0 S ORCHECK("OK")=RSN + S ORIFN=0 F S ORIFN=$O(ORCHECK(ORIFN)) Q:'ORIFN D OC^ORCSAVE2 + Q +DELORD(OK,ORIFN) ; Delete order + N STS,DIK,DA + S STS=$P(^OR(100,+ORIFN,8,1,0),U,15),OK=0 + I (STS=10)!(STS=11) D Q ; makes sure it's an unreleased order + . S DA=+ORIFN,DIK="^OR(100," Q:'DA + . D ^DIK + . S OK=1 + Q +USID(ORITMX) ; Return universal svc ID for an orderable item + ; ORITMX = OI^NMSP^PKGINFO + N RSLT,ORDRUG S RSLT="" + I $E($P(ORITMX,U,2),1,2)="PS" D + . I $P(ORITMX,U,2)="PSIV" D + . . N PSOI,TYPE,VOL S VOL="" + . . S PSOI=+$P($G(^ORD(101.43,+ORITMX,0)),U,2) + . . S TYPE=$P($P(ORITMX,U,3),";") + . . I TYPE="B" S VOL=$P($P(ORITMX,U,3),";",2) + . . D ENDDIV^PSJORUTL(PSOI,TYPE,VOL,.ORDRUG) + . . S ORDRUG=+ORDRUG + . E S ORDRUG=+$P(ORITMX,U,3) + . S RSLT=$$ENDCM^PSJORUTL(ORDRUG) + . S RSLT=$P(RSLT,U,3)_"^^99NDF^"_ORDRUG_U_$P($G(^PSDRUG(ORDRUG,0)),U)_"^99PSD" + E S RSLT=$$USID^ORMBLD(+ORITMX) + I +$P(RSLT,U)=0,+($P(RSLT,U,4)=0) S RSLT="" ; has to be null (why?) + Q RSLT + ; +CHK2LST ; creates list that can be passed to broker from ORCHECK array + ; expects ORCHECK to be present and populates LST + N ORIFN,ORID,CDL,I,ILST S ILST=0 + S ORIFN="" F S ORIFN=$O(ORCHECK(ORIFN)) Q:ORIFN="" D + . S CDL=0 F S CDL=$O(ORCHECK(ORIFN,CDL)) Q:'CDL D + . . S I=0 F S I=$O(ORCHECK(ORIFN,CDL,I)) Q:'I D + . . . S ORID=ORIFN I +ORID,(+ORID=ORID) S ORID=ORID_";1" + . . . I '$P(ORCHECK(ORIFN,CDL,I),U,2) Q ; CDL="" means don't show + . . . S ILST=ILST+1,LST(ILST)=ORID_U_ORCHECK(ORIFN,CDL,I) + Q +LST2CHK ; create ORCHECK array from list passed by broker + N ORIFN,CDL,I,ILST S I=0 + S ILST=0 F S ILST=$O(LST(ILST)) Q:'ILST D + . S X=LST(ILST) + . S ORIFN=$P(X,U),CDL=$P(X,U,3) + . I +$G(ORIFN)>0,+$G(CDL)>0 D ;cla 12/16/03 + . . S I=I+1,ORCHECK(+ORIFN,CDL,I)=$P(X,U,2,4) + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXM1.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXM1.m index af10467a..40ef33bb 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXM1.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXM1.m @@ -1,210 +1,180 @@ -ORWDXM1 ; SLC/KCM - Order Dialogs, Menus;2/19/03 ;5/27/2008 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,131,132,141,178,185,187,215,243**;Dec 17, 1997;Build 242 -BLDQRSP(LST,ORIT,FLDS,ISIMO,ENCLOC) ; Build responses for an order - ; LST=QuickLevel^ResponseID(ORIT;$H)^Dialog^Type^FormID^DGrp - ; LST(n)=verify text or reject text - ; ORIT= ptr to 101.41 for quick order, 100 for copy - ; 1 2 3 4 5 6 7 8 11-20 - ; FLDS=DFN^LOC^ORNP^INPT^SEX^AGE^EVENT^SC%^^^Key Variables... - ; ORIT=+ORIT: ptr to 101.41, $E(ORIT)=C: copy $E(ORIT)=X: change - ; !! SHOULD CHECK for PRE-CPRS ORDERS (treat as text?) - K ^TMP("ORWDXMQ",$J) - N ORWMODE ; 0:Dialog,Quick 1:copy order 2:change order - N TEMPCAT ; patient category from DPT file - N ISXFER ; Transfer order? - N ORIMO ;If IMO(inpatient medication on outpatient) - N TEMPORIT - N ADMLOC,PATLOC,ORDLOC,LEVEL,DELAY,SCHLOC,SCHTYP - S PATLOC=$P(FLDS,U,2) - S ORDLOC=$S(ORIT["C":+$P($G(^OR(100,+$P(ORIT,"C",2),0)),U,10),1:0) - S ORIMO=$G(ISIMO) - S ORWMODE=0,ISXFER="" - S:$E(ORIT)="C" ORWMODE=1 S:$E(ORIT)="T" ORWMODE=1,ISXFER=";T" ;treat xfer as copy for now - S:$E(ORIT)="X" ORWMODE=2 - S TEMPORIT=ORIT - I ORWMODE S ORIT=$E(ORIT,2,999) - S LST(0)="" - D CHKDSBL^ORWDXM3(.LST,ORIT,ORWMODE) Q:+LST(0)=8 ;disable - D CHKVACT^ORWDXM3(.LST,ORIT,ORWMODE,$P(FLDS,U,3)) Q:+LST(0)=8 ;action - I ORWMODE=1 D CHKCOPY^ORWDXM3(.LST,ORIT,FLDS) Q:+LST(0)=8 ;no copy - I ORWMODE=2 D BLD4CHG^ORWDXM3(.LST,ORIT,FLDS) Q ;change - I 'ORWMODE,($P(^ORD(101.41,+ORIT,0),U,4)="D"),'($O(^DIC(9.4,"C","OR",0))[$P(^ORD(101.41,+ORIT,0),U,7)) S LST(0)="0^0^"_$$DLGINFO^ORWDXM3(ORIT,ORWMODE_ISXFER) Q - ;radilogy vars - N ORIMTYPE - ;blood bank vars - N ORCOMP,ORTAS - ;lab vars - N LRFZX,LRFSAMP,LRFSPEC,LRFDATE,LRFURG,LRFSCH - N ORTIME,ORCOLLCT,ORMAX,ORTEST,ORIMTIME,ORSMAX,ORSTMS,ORSCH - ;pharmacy vars - N PSJNOPC,ORMORE,ORINPT,ORXNP,ORSCHED,ORQTY,ORNOUNS,ORXNP,OREFILLS - N ORCOMPLX,ORQTY,ORCOPAY,ORDRUG,ORWPSPIK,ORWPSWRG,ORSD,ORDSUP,ORWP94 - ;dietetics vars - N ORPARAM,ORNPO,ORTIME,ORMEAL,ORTRAY,ORDATE - ;consults vars - N GMRCNOPD,GMRCNOAT,GMRCREAF - ; setup general env - N ORTYPE,ORVP,ORL,ORNP,ORSEX,ORAGE,ORWARD,OREVENT,ORDIV,ORSC,KEYVAR - N ORDG,ORDIALOG,ORCAT,FIRST,ORQUIT,X,ORTRAIL,ORLEAD,RSPREF,AUTOACK - N OREVNTYP - S ORWP94=$O(^ORD(101.41,"AB","PS MEDS",0))>0 - S ORVP=$P(FLDS,U,1)_";DPT(",ORNP=+$P(FLDS,U,3),ORSC=$P(FLDS,U,8) - S ORL=$P(FLDS,U,2)_";SC(",ORL(2)=ORL - S ORSEX=$P(FLDS,U,5),ORAGE=$P(FLDS,U,6),ORTYPE="Q",FIRST=1 - I $P(FLDS,U,4),$G(^SC(+ORL,42)) S ORWARD=+^SC(+ORL,42) - I $L($P(FLDS,U,7)) D - . S OREVENT=$P(FLDS,U,7) - . S OREVNTYP=$P(OREVENT,";",2) - . S OREVENT("TS")=$P(OREVENT,";",3) - . S OREVENT("EFFECTIVE")=$P(OREVENT,";",4) - . S OREVENT=+$P(OREVENT,";",1) - I 'ORWMODE D - . D SETKEYV^ORWDXM3($P(FLDS,U,11,20)) ; from menu path - . S KEYVAR=$$KEYVAR^ORWDXM3(ORIT) ; from entry action - . D SETKEYV^ORWDXM3(KEYVAR) - K ^TMP("ORWORD",$J) - ; init return record based on auto-accept - I ORWMODE S LST(0)="2^"_ORIT ;verify on copy - E S LST(0)=+$P($G(^ORD(101.41,ORIT,5)),U,8)_U_ORIT - S TEMPCAT=$S($L($P($G(^DPT(+ORVP,.1)),U)):"I",1:"O") - I TEMPCAT="I",+$P(FLDS,U,4)=1,$E(TEMPORIT)="C",$P($G(^ORD(100.98,$P($G(^OR(100,+ORIT,0)),U,11),0)),U)="OUTPATIENT MEDICATIONS" S TEMPCAT="O" - I $L($G(OREVNTYP)) D - . S ORCAT=$S(OREVNTYP="A":"I",OREVNTYP="T":"I",OREVNTYP="O":TEMPCAT,OREVNTYP="M":TEMPCAT,OREVNTYP="C":TEMPCAT,1:"O") I $G(OREVENT) D - .. N X S X=$$EVT^OREVNTX(OREVENT),X=$P($G(^ORD(100.5,+X,0)),U,7) - .. I OREVNTYP="T",X,X<4 S ORCAT="O" ;To pass=outpt - .. I OREVNTYP="D",X=41 S ORCAT="I" ;From ASIH=inpt - E S ORCAT=TEMPCAT - D SETUP^ORWDXM4 Q:+LST(0)=8 - S X="OR GTX START DATE"_$S($G(ORWP94):"/TIME",1:"") - I ORWMODE,(ORDG=+$O(^ORD(100.98,"B","O RX",0))) D ;remove old values - . K ORDIALOG($$PTR^ORCD(X),1) - . I ORWMODE=2,$$DRAFT^ORWDX2(ORIT) Q ;keep comments - . K:ISXFER'["T" ORDIALOG($$PTR^ORCD("OR GTX WORD PROCESSING 1"),1) - D SETUPS^ORWDXM4 ;moved to save space, expects X - Q:+LST(0)=8 - I $G(ORQUIT) S LST(0)="0^0^"_$$DLGINFO^ORWDXM3(ORIT,ORWMODE_ISXFER)_"^"_$G(KEYVAR) Q - N SEQ,DA,XCODE,MUSTASK,PROMPT,INST,KEY,IVFID - S IVFID=$O(^ORD(101.41,"B","PSJI OR PAT FLUID OE",0)) - S AUTOACK=$S($D(ORWPSWRG):0,1:1) - S SEQ=0 F S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ)) Q:'SEQ D - . S DA=0 F S DA=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ,DA)) Q:'DA D - . . ; skip if this is a child prompt - . . I $P(^ORD(101.41,+ORDIALOG,10,DA,0),U,11) Q - . . ; set default for prompt, see if needs to be interactive - . . S PROMPT=$P(^ORD(101.41,+ORDIALOG,10,DA,0),U,2) - . . D SETITEM(DA,PROMPT,1,.MUSTASK) - . . I MUSTASK S AUTOACK=0 Q - . . ; iterate through the child items if parent and edit only - . . Q:'$D(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT)) - . . N CSEQ,CDA,CPROMPT,INST,ORQUIT - . . S CSEQ=0 F S CSEQ=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT,CSEQ)) Q:'CSEQ D Q:$G(ORQUIT) - . . . S CDA=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT,CSEQ,0)) - . . . S CPROMPT=$P(^ORD(101.41,+ORDIALOG,10,CDA,0),U,2) - . . . ; if req & no instances then need interaction - . . . I $P(^ORD(101.41,+ORDIALOG,10,CDA,0),U,6),ORDIALOG'=IVFID,'$O(ORDIALOG(CPROMPT,0)) S AUTOACK=0 - . . . S INST=0 F S INST=$O(ORDIALOG(CPROMPT,INST)) Q:'INST D - . . . . N ORASK D VBASK^ORWDXM4(INST) ; set ORASK for VBECS - . . . . ; set default for each child prompt, if necessary - . . . . D SETITEM(CDA,CPROMPT,INST,.MUSTASK) - . . . . ; if no val & child prmpt required then need interaction - . . . . I MUSTASK,$P(^ORD(101.41,+ORDIALOG,10,CDA,0),U,6) S AUTOACK=0 - N IVDLG - S IVDLG=$O(^ORD(101.41,"AB","PSJI OR PAT FLUID OE",0)) - I $$ISMED(ORIT),(ORDIALOG'=IVDLG),(ORCAT="I") D - . F P="PATIENT INSTRUCTIONS","START DATE/TIME","DAYS SUPPLY","QUANTITY","REFILLS","ROUTING","SERVICE CONNECTED" K ORDIALOG($$PTR(P),1) - S KEY=$S(ORWMODE:"C",1:"")_ORIT_"-"_$P($H,",",2),SEQ=0 - I $$ISINPMED(ORIT) D - .S LEVEL=$P(LST(0),U),DELAY=$S($P($G(OREVENT),";")>0:1,1:0) - .I LEVEL=2!(ISIMO) D ADMTIME^ORWDXM2(ORDLOC,PATLOC,ENCLOC,DELAY,ISIMO) - I ($$ISMED(ORIT)),'($$VALQO^ORWDXM3(ORIT)) S AUTOACK=0 - S PROMPT=0 F S PROMPT=$O(ORDIALOG(PROMPT)) Q:'PROMPT D - . I '$D(^ORD(101.41,ORDIALOG,10,"D",PROMPT)) K ORDIALOG(PROMPT) Q - . S INST=0 F S INST=$O(ORDIALOG(PROMPT,INST)) Q:'INST D - . . S SEQ=SEQ+1,^TMP("ORWDXMQ",$J,KEY,SEQ,0)=U_PROMPT_U_INST - . . ; save word processing value - . . I $E(ORDIALOG(PROMPT,0))="W",$L(ORDIALOG(PROMPT,INST)) D - . . . M ^TMP("ORWDXMQ",$J,KEY,SEQ,2)=@ORDIALOG(PROMPT,INST) - . . ; save other value types - . . E S ^TMP("ORWDXMQ",$J,KEY,SEQ,1)=ORDIALOG(PROMPT,INST) - I AUTOACK D - . I ORWMODE S AUTOACK=2 - . I 'ORWMODE,($P(^ORD(101.41,ORIT,0),U,8)!'LST(0)) S AUTOACK=2 - ;I ($$ISMED(ORIT)),'($$VALQO^ORWDXM3(ORIT)) S AUTOACK=0 - I ORIMO,ORWMODE S AUTOACK=2 - ; added to accept Herbal/OTC/NonVA Med quick orders - I $L($G(^ORD(101.41,+ORIT,0))),($P(^ORD(100.98,$P(^ORD(101.41,+ORIT,0),U,5),0),U,3)="NV RX"),($P($G(^ORD(101.41,+ORIT,5)),U,8)) S AUTOACK=1 - ;I $G(^OR(100,+ORIT,0)),$P($G(^ORD(101.41,+$P(^OR(100,+ORIT,0),U,5),0)),U,8),$D(ORDIALOG("B","HERBAL/OTC/NON VA MEDICATION")) S AUTOACK=1 - I AUTOACK=2,$$ISMED(ORIT),(ORDIALOG=IVDLG),$$VERORD^ORWDXM3=0 S AUTOACK=0 - I AUTOACK=2 D VERTXT^ORWDXM2 - S LST(0)=AUTOACK_U_KEY_U_$$DLGINFO^ORWDXM3(ORIT,ORWMODE_ISXFER)_"^"_$G(KEYVAR) - I $P(LST(0),U,4)="D" S $P(LST(0),U,4)="Q" - I ORWMODE=1 S $P(LST(0),U,4)="C" - K ^TMP("ORWORD",$J) - K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J) - Q -SETITEM(DA,PROMPT,INST,MUSTASK) ; set default value & return if must prompt - N EDITONLY,Y,VALIV,XCODE - S MUSTASK=0,EDITONLY=0,VALIV=0 - I $D(^TMP("ORWDHTM",$J,ORDIALOG,PROMPT)) D - . I $E(ORDIALOG(PROMPT,0))="W" D - . . S ^TMP("ORWORD",$J,PROMPT,INST,1,0)=^TMP("ORWDHTM",$J,ORDIALOG,PROMPT) - . . S ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"","_$J_","_PROMPT_","_INST_")" - . E S ORDIALOG(PROMPT,INST)=^TMP("ORWDHTM",$J,ORDIALOG,PROMPT) - I $D(^TMP("ORWDHTM",$J,ORIT,PROMPT)) D - . S ORDIALOG(PROMPT,INST)=^TMP("ORWDHTM",$J,ORIT,PROMPT) - . ; NEED TO CLEAN UP ^TMP("ORWDHTM") after process order set!!! - ; - ; skip if a value already exists for this prompt and not WP - Q:$D(ORDIALOG(PROMPT,INST))&($E(ORDIALOG(PROMPT,0))'="W") - ; execute default action if no value in QO, checking EDITONLY afterwards - I '$D(ORDIALOG(PROMPT,INST)) D - . ; - . ;Intermittent IV orders do not require a solution or an infusion rate - . I PROMPT=$$PTR("INFUSION RATE"),$$GETIVTYP^ORWDXM3="I" S VALIV=1 Q - . I PROMPT=$$PTR("ORDERABLE ITEM"),$$GETIVTYP^ORWDXM3="I" S VALIV=1 Q - . I $E(ORDIALOG(PROMPT,0))="W",$D(^ORD(101.41,+ORDIALOG,10,DA,8))>9 D - . . M ^TMP("ORWORD",$J,PROMPT,INST)=^ORD(101.41,+ORDIALOG,10,DA,8) - . . S ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"","_$J_","_PROMPT_","_INST_")" - . E D - . . S XCODE=$$SUBCODE($G(^ORD(101.41,+ORDIALOG,10,DA,7))) - . . I $L(XCODE) X XCODE S:$D(Y) ORDIALOG(PROMPT,INST)=Y - Q:VALIV=1 - Q:$G(EDITONLY) - I 'ORWMODE,$P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,8) Q - I ORWMODE,($P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,9)'["W"),'$P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,6)!$D(ORDIALOG(PROMPT,INST)) Q - I 'ORWMODE,LST(0),$D(ORDIALOG(PROMPT,INST)),($E(ORDIALOG(PROMPT,0))="W") Q - I 'ORWMODE,LST(0),'$P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,6) Q - S XCODE=$$SUBCODE($G(^ORD(101.41,+ORDIALOG,10,DA,3))) - I $L(XCODE) X XCODE Q:'$T - S MUSTASK=1 - Q -SUBCODE(X) ; substitute code - I X["$$REQDCOMM^ORCDLR" Q "I $$LRRQCM^ORWDXM2" - I X["$$ASKSAMP^ORCDLR" Q "I $$LRASMP^ORWDXM2" - I X["$$SCHEDULD^ORCDRA1" Q "I $$SCHEDULD^ORWDXM2" - I X["(^PSX(550,""C"")" Q "S Y=$E($$DEFPICK^ORWDPS32) K:'$L(Y) Y" - I X["I $$ASKURG^ORCDVBEC" Q "I 1" - I X["K:$G(ORASK)" Q "I $G(ORASK)" - Q X -PTR(NAME) ; -- Returns pointer to OR GTX NAME - Q +$O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0)) - ; -ISINPMED(IFN) ; - N PKG,RESULT,Y - I 'ORWMODE S PKG=$P($G(^ORD(101.41,IFN,0)),U,7) - E S PKG=$P($G(^OR(100,+IFN,0)),U,14) - S Y=$$GET1^DIQ(9.4,+PKG_",",1) - S RESULT=$S($E(Y,1,3)="PSJ":1,1:0) - Q RESULT - ; -ISMED(IFN) ; return 1 if pharmacy order dlg used - N PKG - I 'ORWMODE S PKG=$P($G(^ORD(101.41,IFN,0)),U,7) - E S PKG=$P($G(^OR(100,+IFN,0)),U,14) - Q $$NMSP^ORCD(PKG)="PS" -SITEVAL() ;return 1 if site does want the reason for study to carry through from past orders of this ordering session - I $$GET^XPAR("ALL","OR RA RFS CARRY ON")=0 Q 0 - Q 1 -SVRPC(RET,X) ;RPC FOR SITEVAL - S RET=$$SITEVAL - Q +ORWDXM1 ; SLC/KCM - Order Dialogs, Menus;2/19/03 ;11/15/2005 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,131,132,141,178,185,187,215**;Dec 17, 1997 +BLDQRSP(LST,ORIT,FLDS,ISIMO) ; Build responses for an order + ; LST=QuickLevel^ResponseID(ORIT;$H)^Dialog^Type^FormID^DGrp + ; LST(n)=verify text or reject text + ; ORIT= ptr to 101.41 for quick order, 100 for copy + ; 1 2 3 4 5 6 7 8 11-20 + ; FLDS=DFN^LOC^ORNP^INPT^SEX^AGE^EVENT^SC%^^^Key Variables... + ; ORIT=+ORIT: ptr to 101.41, $E(ORIT)=C: copy $E(ORIT)=X: change + ; !! SHOULD CHECK for PRE-CPRS ORDERS (treat as text?) + K ^TMP("ORWDXMQ",$J) + N ORWMODE ; 0:Dialog,Quick 1:copy order 2:change order + N TEMPCAT ; patient category from DPT file + N ISXFER ; Transfer order? + N ORIMO ;If IMO(inpatient medication on outpatient) + N TEMPORIT + S ORIMO=$G(ISIMO) + S ORWMODE=0,ISXFER="" + S:$E(ORIT)="C" ORWMODE=1 S:$E(ORIT)="T" ORWMODE=1,ISXFER=";T" ;treat xfer as copy for now + S:$E(ORIT)="X" ORWMODE=2 + S TEMPORIT=ORIT + I ORWMODE S ORIT=$E(ORIT,2,999) + S LST(0)="" + D CHKDSBL^ORWDXM3(.LST,ORIT,ORWMODE) Q:+LST(0)=8 ;disable + D CHKVACT^ORWDXM3(.LST,ORIT,ORWMODE,$P(FLDS,U,3)) Q:+LST(0)=8 ;action + I ORWMODE=1 D CHKCOPY^ORWDXM3(.LST,ORIT,FLDS) Q:+LST(0)=8 ;no copy + I ORWMODE=2 D BLD4CHG^ORWDXM3(.LST,ORIT,FLDS) Q ;change + I 'ORWMODE,($P(^ORD(101.41,+ORIT,0),U,4)="D"),'($O(^DIC(9.4,"C","OR",0))[$P(^ORD(101.41,+ORIT,0),U,7)) S LST(0)="0^0^"_$$DLGINFO^ORWDXM3(ORIT,ORWMODE_ISXFER) Q + ;radilogy vars + N ORIMTYPE + ;blood bank vars + N ORCOMP,ORTAS + ;lab vars + N LRFZX,LRFSAMP,LRFSPEC,LRFDATE,LRFURG,LRFSCH + N ORTIME,ORCOLLCT,ORMAX,ORTEST,ORIMTIME,ORSMAX,ORSTMS,ORSCH + ;pharmacy vars + N PSJNOPC,ORMORE,ORINPT,ORXNP,ORSCHED,ORQTY,ORNOUNS,ORXNP,OREFILLS + N ORCOMPLX,ORQTY,ORCOPAY,ORDRUG,ORWPSPIK,ORWPSWRG,ORSD,ORDSUP,ORWP94 + ;dietetics vars + N ORPARAM,ORNPO,ORTIME,ORMEAL,ORTRAY,ORDATE + ;consults vars + N GMRCNOPD,GMRCNOAT,GMRCREAF + ; setup general env + N ORTYPE,ORVP,ORL,ORNP,ORSEX,ORAGE,ORWARD,OREVENT,ORDIV,ORSC,KEYVAR + N ORDG,ORDIALOG,ORCAT,FIRST,ORQUIT,X,ORTRAIL,ORLEAD,RSPREF,AUTOACK + N OREVNTYP + S ORWP94=$O(^ORD(101.41,"AB","PS MEDS",0))>0 + S ORVP=$P(FLDS,U,1)_";DPT(",ORNP=+$P(FLDS,U,3),ORSC=$P(FLDS,U,8) + S ORL=$P(FLDS,U,2)_";SC(",ORL(2)=ORL + S ORSEX=$P(FLDS,U,5),ORAGE=$P(FLDS,U,6),ORTYPE="Q",FIRST=1 + I $P(FLDS,U,4),$G(^SC(+ORL,42)) S ORWARD=+^SC(+ORL,42) + I $L($P(FLDS,U,7)) D + . S OREVENT=$P(FLDS,U,7) + . S OREVNTYP=$P(OREVENT,";",2) + . S OREVENT("TS")=$P(OREVENT,";",3) + . S OREVENT("EFFECTIVE")=$P(OREVENT,";",4) + . S OREVENT=+$P(OREVENT,";",1) + I 'ORWMODE D + . D SETKEYV^ORWDXM3($P(FLDS,U,11,20)) ; from menu path + . S KEYVAR=$$KEYVAR^ORWDXM3(ORIT) ; from entry action + . D SETKEYV^ORWDXM3(KEYVAR) + K ^TMP("ORWORD",$J) + ; init return record based on auto-accept + I ORWMODE S LST(0)="2^"_ORIT ;verify on copy + E S LST(0)=+$P($G(^ORD(101.41,ORIT,5)),U,8)_U_ORIT + S TEMPCAT=$S($L($P($G(^DPT(+ORVP,.1)),U)):"I",1:"O") + I TEMPCAT="I",+$P(FLDS,U,4)=1,$E(TEMPORIT)="C",$P($G(^ORD(100.98,$P($G(^OR(100,+ORIT,0)),U,11),0)),U)="OUTPATIENT MEDICATIONS" S TEMPCAT="O" + I $L($G(OREVNTYP)) D + . S ORCAT=$S(OREVNTYP="A":"I",OREVNTYP="T":"I",OREVNTYP="O":TEMPCAT,OREVNTYP="M":TEMPCAT,OREVNTYP="C":TEMPCAT,1:"O") I $G(OREVENT) D + .. N X S X=$$EVT^OREVNTX(OREVENT),X=$P($G(^ORD(100.5,+X,0)),U,7) + .. I OREVNTYP="T",X,X<4 S ORCAT="O" ;To pass=outpt + .. I OREVNTYP="D",X=41 S ORCAT="I" ;From ASIH=inpt + E S ORCAT=TEMPCAT + D SETUP^ORWDXM4 Q:+LST(0)=8 + S X=$S($G(ORWP94):"OR GTX START DATE/TIME",1:"OR GTX START DATE") + I ORWMODE,(ORDG=+$O(^ORD(100.98,"B","O RX",0))) K ORDIALOG($$PTR^ORCD(X),1) + D SETUPS^ORWDXM4 ; moved to save space + Q:+LST(0)=8 + I $G(ORQUIT) S LST(0)="0^0^"_$$DLGINFO^ORWDXM3(ORIT,ORWMODE_ISXFER)_"^"_$G(KEYVAR) Q + N SEQ,DA,XCODE,MUSTASK,PROMPT,INST,KEY,IVFID + S IVFID=$O(^ORD(101.41,"B","PSJI OR PAT FLUID OE",0)) + S AUTOACK=$S($D(ORWPSWRG):0,1:1) + S SEQ=0 F S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ)) Q:'SEQ D + . S DA=0 F S DA=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ,DA)) Q:'DA D + . . ; skip if this is a child prompt + . . I $P(^ORD(101.41,+ORDIALOG,10,DA,0),U,11) Q + . . ; set default for prompt, see if needs to be interactive + . . S PROMPT=$P(^ORD(101.41,+ORDIALOG,10,DA,0),U,2) + . . D SETITEM(DA,PROMPT,1,.MUSTASK) + . . I MUSTASK S AUTOACK=0 Q + . . ; iterate through the child items if parent and edit only + . . Q:'$D(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT)) + . . N CSEQ,CDA,CPROMPT,INST,ORQUIT + . . S CSEQ=0 F S CSEQ=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT,CSEQ)) Q:'CSEQ D Q:$G(ORQUIT) + . . . S CDA=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT,CSEQ,0)) + . . . S CPROMPT=$P(^ORD(101.41,+ORDIALOG,10,CDA,0),U,2) + . . . ; if req & no instances then need interaction + . . . I $P(^ORD(101.41,+ORDIALOG,10,CDA,0),U,6),ORDIALOG'=IVFID,'$O(ORDIALOG(CPROMPT,0)) S AUTOACK=0 + . . . S INST=0 F S INST=$O(ORDIALOG(CPROMPT,INST)) Q:'INST D + . . . . N ORASK D VBASK^ORWDXM4(INST) ; set ORASK for VBECS + . . . . ; set default for each child prompt, if necessary + . . . . D SETITEM(CDA,CPROMPT,INST,.MUSTASK) + . . . . ; if no val & child prmpt required then need interaction + . . . . I MUSTASK,$P(^ORD(101.41,+ORDIALOG,10,CDA,0),U,6) S AUTOACK=0 + N IVDLG + S IVDLG=$O(^ORD(101.41,"AB","PSJI OR PAT FLUID OE",0)) + I $$ISMED(ORIT),(ORDIALOG'=IVDLG),(ORCAT="I") D + . F P="PATIENT INSTRUCTIONS","START DATE/TIME","DAYS SUPPLY","QUANTITY","REFILLS","ROUTING","SERVICE CONNECTED" K ORDIALOG($$PTR(P),1) + S KEY=$S(ORWMODE:"C",1:"")_ORIT_"-"_$P($H,",",2),SEQ=0 + S PROMPT=0 F S PROMPT=$O(ORDIALOG(PROMPT)) Q:'PROMPT D + . I '$D(^ORD(101.41,ORDIALOG,10,"D",PROMPT)) K ORDIALOG(PROMPT) Q + . S INST=0 F S INST=$O(ORDIALOG(PROMPT,INST)) Q:'INST D + . . S SEQ=SEQ+1,^TMP("ORWDXMQ",$J,KEY,SEQ,0)=U_PROMPT_U_INST + . . ; save word processing value + . . I $E(ORDIALOG(PROMPT,0))="W",$L(ORDIALOG(PROMPT,INST)) D + . . . M ^TMP("ORWDXMQ",$J,KEY,SEQ,2)=@ORDIALOG(PROMPT,INST) + . . ; save other value types + . . E S ^TMP("ORWDXMQ",$J,KEY,SEQ,1)=ORDIALOG(PROMPT,INST) + I AUTOACK D + . I ORWMODE S AUTOACK=2 + . I 'ORWMODE,($P(^ORD(101.41,ORIT,0),U,8)!'LST(0)) S AUTOACK=2 + I ($$ISMED(ORIT)),'($$VALQO^ORWDXM3(ORIT)) S AUTOACK=0 + I ORIMO,ORWMODE S AUTOACK=2 + ; added to accept Herbal/OTC/NonVA Med quick orders + I $L($G(^ORD(101.41,+ORIT,0))),($P(^ORD(100.98,$P(^ORD(101.41,+ORIT,0),U,5),0),U,3)="NV RX"),($P($G(^ORD(101.41,+ORIT,5)),U,8)) S AUTOACK=1 + ;I $G(^OR(100,+ORIT,0)),$P($G(^ORD(101.41,+$P(^OR(100,+ORIT,0),U,5),0)),U,8),$D(ORDIALOG("B","HERBAL/OTC/NON VA MEDICATION")) S AUTOACK=1 + I AUTOACK=2 D VERTXT^ORWDXM2 + S LST(0)=AUTOACK_U_KEY_U_$$DLGINFO^ORWDXM3(ORIT,ORWMODE_ISXFER)_"^"_$G(KEYVAR) + I $P(LST(0),U,4)="D" S $P(LST(0),U,4)="Q" + I ORWMODE=1 S $P(LST(0),U,4)="C" + K ^TMP("ORWORD",$J) + K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J) + Q +SETITEM(DA,PROMPT,INST,MUSTASK) ; set default value & return if must prompt + N EDITONLY,Y,XCODE + S MUSTASK=0,EDITONLY=0 + I $D(^TMP("ORWDHTM",$J,ORDIALOG,PROMPT)) D + . I $E(ORDIALOG(PROMPT,0))="W" D + . . S ^TMP("ORWORD",$J,PROMPT,INST,1,0)=^TMP("ORWDHTM",$J,ORDIALOG,PROMPT) + . . S ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"","_$J_","_PROMPT_","_INST_")" + . E S ORDIALOG(PROMPT,INST)=^TMP("ORWDHTM",$J,ORDIALOG,PROMPT) + I $D(^TMP("ORWDHTM",$J,ORIT,PROMPT)) D + . S ORDIALOG(PROMPT,INST)=^TMP("ORWDHTM",$J,ORIT,PROMPT) + . ; NEED TO CLEAN UP ^TMP("ORWDHTM") after process order set!!! + ; + ; skip if a value already exists for this prompt and not WP + Q:$D(ORDIALOG(PROMPT,INST))&($E(ORDIALOG(PROMPT,0))'="W") + ; execute default action if no value in QO, checking EDITONLY afterwards + I '$D(ORDIALOG(PROMPT,INST)) D + . I $E(ORDIALOG(PROMPT,0))="W",$D(^ORD(101.41,+ORDIALOG,10,DA,8))>9 D + . . M ^TMP("ORWORD",$J,PROMPT,INST)=^ORD(101.41,+ORDIALOG,10,DA,8) + . . S ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"","_$J_","_PROMPT_","_INST_")" + . E D + . . S XCODE=$$SUBCODE($G(^ORD(101.41,+ORDIALOG,10,DA,7))) + . . I $L(XCODE) X XCODE S:$D(Y) ORDIALOG(PROMPT,INST)=Y + Q:$G(EDITONLY) + I 'ORWMODE,$P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,8) Q + I ORWMODE,($P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,9)'["W"),'$P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,6)!$D(ORDIALOG(PROMPT,INST)) Q + I 'ORWMODE,LST(0),$D(ORDIALOG(PROMPT,INST)),($E(ORDIALOG(PROMPT,0))="W") Q + I 'ORWMODE,LST(0),'$P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,6) Q + S XCODE=$$SUBCODE($G(^ORD(101.41,+ORDIALOG,10,DA,3))) + I $L(XCODE) X XCODE Q:'$T + S MUSTASK=1 + Q +SUBCODE(X) ; substitute code + I X["$$REQDCOMM^ORCDLR" Q "I $$LRRQCM^ORWDXM2" + I X["$$ASKSAMP^ORCDLR" Q "I $$LRASMP^ORWDXM2" + I X["$$SCHEDULD^ORCDRA1" Q "I $$SCHEDULD^ORWDXM2" + I X["(^PSX(550,""C"")" Q "S Y=$E($$DEFPICK^ORWDPS32) K:'$L(Y) Y" + I X["I $$ASKURG^ORCDVBEC" Q "I 1" + I X["K:$G(ORASK)" Q "I $G(ORASK)" + Q X +PTR(NAME) ; -- Returns pointer to OR GTX NAME + Q +$O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0)) + ; +ISMED(IFN) ; return 1 if pharmacy order dlg used + N PKG + I 'ORWMODE S PKG=$P($G(^ORD(101.41,IFN,0)),U,7) + E S PKG=$P($G(^OR(100,+IFN,0)),U,14) + Q $$NMSP^ORCD(PKG)="PS" diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXM2.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXM2.m index fe2a12d7..512e1f4b 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXM2.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXM2.m @@ -1,210 +1,188 @@ -ORWDXM2 ; SLC/KCM - Quick Orders ;04/25/2007 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,116,132,158,187,195,215,243**;Dec 17, 1997;Build 242 - ; -ADMTIME(ORDLOC,PATLOC,ENCLOC,DELAY,ISIMO) ; - N ADMLOC,INST,SCHLOC,SCHTYPE - S ADMLOC=+$P($G(ORDIALOG("B","ADMINISTRATION TIMES")),U,2) - I ADMLOC>0,ORDLOC>0,PATLOC'=ORDLOC D Q - .S INST=0 F S INST=$O(ORDIALOG(ADMLOC,INST)) Q:+INST'>0 D - ..S ORDIALOG(ADMLOC,INST)="" - I ADMLOC>0,$S(ENCLOC'=PATLOC:1,ISIMO:1,DELAY:1,1:0) D Q - .S INST=0 F S INST=$O(ORDIALOG(ADMLOC,INST)) Q:+INST'>0 D - ..S ORDIALOG(ADMLOC,INST)="" - S SCHLOC=+$P($G(ORDIALOG("B","SCHEDULE TYPE")),U,2) Q:SCHLOC'>0 - S INST=0 F S INST=$O(ORDIALOG(SCHLOC,INST)) Q:+INST'>0 D - .S SCHTYP=$G(ORDIALOG(SCHLOC,INST)) Q:SCHTYP="" - .I $S(SCHTYP="P":1,SCHTYP="O":1,SCHTYP="OC":1,1:0),ADMLOC>0 S ORDIALOG(ADMLOC,INST)="" - Q - ; -CLRRCL(OK) ; clear ORECALL - S OK=1 - K ^TMP("ORECALL",$J),^TMP("ORWDXMQ",$J) - Q -VERTXT ; set verify text for order - N SEQ,DA,X,PROMPT,MULT,CHILD,INST,TITLE,TEMP,ILST,SPACES - N ISADMIN - S ILST=0,$P(SPACES," ",31)="" - S SEQ=0 F S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ)) Q:SEQ'>0 D - . S DA=0 F S DA=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ,DA)) Q:'DA D - . . S X0=$G(^ORD(101.41,+ORDIALOG,10,DA,0)) - . . S ISADMIN=$S(+OREVENT>0:0,ISIMO=1:0,$P($G(^ORD(101.41,$P(X0,U,2),0)),U)="OR GTX ADMIN TIMES":1,1:0) - . . I ISADMIN=1,ORDLOC>0,ORDLOC'=PATLOC Q - . . I $P(X0,U,9)["*",ISADMIN=0 Q - . . S PROMPT=$P(X0,U,2),MULT=$P(X0,U,7),CHILD=$P(X0,U,11) I CHILD,ISADMIN=0 Q - . . Q:'PROMPT S INST=$O(ORDIALOG(PROMPT,0)) Q:'INST ; no values - . . S TITLE=$S($L($G(ORDIALOG(PROMPT,"TTL"))):ORDIALOG(PROMPT,"TTL"),1:ORDIALOG(PROMPT,"A")) - . . I $E(ORDIALOG(PROMPT,0))="W" D - . . . N IWP,WP,CNT - . . . S IWP=0,CNT=0 - . . . F S IWP=$O(^TMP("ORWORD",$J,PROMPT,INST,IWP)) Q:'IWP D - . . . . S CNT=CNT+1,WP(CNT)=^TMP("ORWORD",$J,PROMPT,INST,IWP,0) - . . . I CNT=1 S ILST=ILST+1,LST(ILST)=$J(TITLE,30)_WP(1) - . . . I CNT>1 D - . . . . S ILST=ILST+1,LST(ILST)=TITLE,IWP=0 - . . . . F S IWP=$O(WP(IWP)) Q:'IWP S ILST=ILST+1,LST(ILST)=WP(IWP) - . . E D - . . . S TEMP=$$ITEM^ORCDLG(PROMPT,INST) I TEMP="" Q - . . . S ILST=ILST+1,LST(ILST)=$J(TITLE,30) - . . . ;S LST(ILST)=LST(ILST)_$$ITEM^ORCDLG(PROMPT,INST) - . . . S LST(ILST)=LST(ILST)_TEMP - . . Q:'MULT Q:'$O(ORDIALOG(PROMPT,INST)) ; done - . . F S INST=$O(ORDIALOG(PROMPT,INST)) Q:INST'>0 S ILST=ILST+1,LST(ILST)=SPACES_$$ITEM^ORCDLG(PROMPT,INST) - D DISPLAY^ORWDBA3 ;for display of Billing Aware data from orig order - Q -RA ; setup environment for radiology - ; -- get imaging types based on display group of quick order and - ; setup list of imaging locations based on imaging type - N ORY,ITYPE,IFN,CNT,ORIMLOC,PROMPT - S ORDIV=$$DIV^ORCDRA1,ITYPE=$P($G(^ORD(100.98,+ORDG,0)),U,3) - S ORIMTYPE=$O(^RA(79.2,"C",ITYPE,0)) - D EN4^RAO7PC1(ITYPE,"ORY") - S (IFN,CNT)=0 F S IFN=$O(ORY(IFN)) Q:IFN'>0 D - . S CNT=CNT+1,ORIMLOC(CNT)=ORY(IFN),ORIMLOC("B",$P(ORY(IFN),U,2))=IFN - I '$$GET^XPAR("ALL","RA SUBMIT PROMPT",1,"Q"),CNT>1 K ORIMLOC - E S ORIMLOC=CNT_"^1" - S PROMPT=$O(^ORD(101.41,"B","OR GTX IMAGING LOCATION",0)) - I $G(ORIMLOC) M ORDIALOG(PROMPT,"LIST")=ORIMLOC - Q -LR ; setup environment for lab - ; -- setup ORTIME, ORIMTIME & ORTEST arrays - ; setup ORMAX, ORDG, & ORCOLLCT variables - N PROMPT,INST,EDITONLY - D GETIMES^ORCDLR1 ; sets up ORTIME and ORIMTIME arrays - S ORMAX=$$GET^XPAR("ALL^LOC.`"_+ORL,"LR MAX DAYS CONTINUOUS",1,"Q") - S PROMPT=$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0)),INST=1 - D LRTEST ; sets up ORTEST array and ORDG - S PROMPT=$O(^ORD(101.41,"B","OR GTX COLLECTION TYPE",0)) - I $D(ORDIALOG(PROMPT,1)) S ORCOLLCT=ORDIALOG(PROMPT,1) I 1 - E S EDITONLY=0,ORCOLLCT=$$COLLTYPE^ORCDLR1 - I ORCOLLCT="I" D - . S PROMPT=$O(^ORD(101.41,"B","OR GTX START DATE/TIME",0)) - . D LRICTMOK - S PROMPT=$O(^ORD(101.41,"B","OR GTX ADMIN SCHEDULE",0)) - I $D(ORDIALOG(PROMPT,1)) S ORSCH=ORDIALOG(PROMPT,1) - Q -LRTEST ; -- Setup ORTEST() array of ordering parameters (copied from ORCDLR) - N OI,TST,DG - S OI=+$G(ORDIALOG(PROMPT,INST)) Q:'OI - I '$D(ORTEST) S TST=+$P($G(^ORD(101.43,OI,0)),U,2) D TEST^LR7OR3(TST,.ORTEST) S ORTEST=TST - S DG=$P($G(^ORD(101.43,+OI,"LR")),U,6) S:'$L(DG) DG="LAB" - S DG=$O(^ORD(100.98,"B",DG,0)) S:DG ORDG=DG - Q -LRRQCM() ; return true if lab test has required comments - I $O(^TMP("ORWORD",$J,PROMPT,INST,0)) Q 1 ; edit via WP - N LRTEST,LRSAMP,LRSPEC,LRTSTN,LRTCOM,LRCCOM,DA,CNT,I,REQDCOMM,OI,TST - S LRSAMP=$$VAL^ORCD("COLLECTION SAMPLE"),LRSPEC=$$VAL^ORCD("SPECIMEN") - S OI=+$G(ORDIALOG(PROMPT,INST)) Q:'OI 0 - I '$D(ORTEST) S TST=+$P($G(^ORD(101.43,OI,0)),U,2) D TEST^LR7OR3(TST,.ORTEST) S ORTEST=TST - S LRTSTN=1,LRTEST(1)=+ORTEST,DA=$O(^LAB(60,LRTEST(1),3,"B",+LRSAMP,0)) - S REQDCOMM=$P($G(^LAB(60,LRTEST(1),3,+DA,0)),U,6) - S:'REQDCOMM REQDCOMM=+$P($G(^LAB(60,LRTEST(1),0)),U,19) - Q REQDCOMM -LRASMP() ; return true to ask collection sample (from ASKSAMP^ORCDLR) - N DEFSAMP,SAMP0 - S DEFSAMP=$G(ORDIALOG(PROMPT,INST)),SAMP0=$G(^LAB(62,+DEFSAMP,0)) - I (ORCOLLCT="LC")!(ORCOLLCT="I"),$G(ORTEST("Lab CollSamp")) Q 0 - I $G(ORTEST("Unique CollSamp")),DEFSAMP Q 0 ; unique -> don't ask - I 'DEFSAMP!('FIRST) Q 1 ; no default or edit -> ask - I $G(ORDIALOG(PROMPT,"LIST"))="1^1" Q 0 ; only one choice - Q 1 -LRICTMOK ; - Q:'$D(ORDIALOG(PROMPT,1)) - N ORY - D VALDT^ORWU(.ORY,ORDIALOG(PROMPT,1)) - I +$$VALID^LR7OV4(DUZ(2),ORY)=0 S ORDIALOG(PROMPT,1)="" - Q -DO ; setup environment for diet order - ; partially copied from EN^ORCDFH - I ORCAT'="I" D Q - . S ORQUIT=1 - . S LST(0)="8^0" - . S LST(.5)="This type of diet may be entered for inpatients only." - D EN^FHWOR8(+ORVP,.ORPARAM) ; set FH ordering parameters - S:'$L($G(ORPARAM(3))) ORPARAM(3)="T" ; for now - N PROMPT,OI ; set NPO flag if NPO diet - S PROMPT=$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0)) - S OI=+$G(ORDIALOG(PROMPT,1)) - S ORNPO=($P($G(^ORD(101.43,OI,0)),U)="NPO") - S PROMPT=$O(^ORD(101.41,"B","OR GTX START DATE/TIME",0)) - S X=$G(ORDIALOG(PROMPT,1)) I $L(X) D CNV^ORCDFH1 S ORDIALOG(PROMPT,1)=$G(X) - Q -EL ; setup environment for early/late tray - D EN^FHWOR8(+ORVP,.ORPARAM) ; set FH ordering parameters - S:'$L($G(ORPARAM(3))) ORPARAM(3)="T" ; for now - D EN2^ORCDFH ; setup ORTIME array - N PROMPT ; set ORMEAL,ORTRAY - S PROMPT=$O(^ORD(101.41,"B","OR GTX MEAL",0)) - I $D(ORDIALOG(PROMPT,1)) S ORMEAL=ORDIALOG(PROMPT,1) - S PROMPT=$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0)) - I $D(ORDIALOG(PROMPT,1)) S ORTRAY=ORDIALOG(PROMPT,1) - Q -UD ; setup environment for unit dose med - I $G(ORWP94) G PS^ORWDPS3 ; if patch 94 installed - ; - D AUTHMED Q:$G(ORQUIT) ; checks authorized to write meds - N PROMPT,OI - S PROMPT=$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0)) - I $D(ORDIALOG(PROMPT,1)) S OI=ORDIALOG(PROMPT,1) D MEDACTV(1) Q:$G(ORQUIT) - D INSTR^ORCDPS(OI) ; sets up instructions, routes, etc. - D CHOICES^ORCDPS("U") ; gets list of dispense drugs - Q -IV ; setup environment for IV fluid - D AUTHMED Q:$G(ORQUIT) ; checks authorized to write meds - ; sets up list of volumes if only one solution - ; otherwise, let the dialog go interactive - N PROMPT,INST,CNT,OI - S PROMPT=$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0)) - S (CNT,INST)=0 - F S INST=$O(ORDIALOG(PROMPT,INST)) Q:'INST D Q:$G(ORQUIT) - . S CNT=CNT+1 - . S OI=ORDIALOG(PROMPT,INST) D MEDACTV(3) ; check active solutions - I CNT=1 S INST=1 D VOLUME^ORCDPSIV - S PROMPT=$O(^ORD(101.41,"B","OR GTX ADDITIVE",0)) - S INST=0 - F S INST=$O(ORDIALOG(PROMPT,INST)) Q:'INST D Q:$G(ORQUIT) - . S OI=ORDIALOG(PROMPT,INST) D MEDACTV(4) ; check active additives - Q -OP ; setup environment for outpatient pharmacy - I $G(ORWP94) G PS^ORWDPS3 ; if patch 94 installed - ; - D AUTHMED Q:$G(ORQUIT) ; checks authorized to write meds - N PROMPT,INST,CNT,OI - S PROMPT=$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0)),OI=0 - I $D(ORDIALOG(PROMPT,1)) S OI=$G(ORDIALOG(PROMPT,1)) D MEDACTV(2) Q:$G(ORQUIT) - D:+OI INSTR^ORCDPS(OI) ; sets up instructions, routes, etc. - D CHOICES^ORCDPS("O") ; gets list of dispense drugs - ; get defaults for drug, refills if only one dispense drug - S PROMPT=$O(^ORD(101.41,"B","OR GTX DISPENSE DRUG",0)) - S (CNT,INST)=0 - F S INST=$O(ORDIALOG(PROMPT,INST)) Q:'INST S CNT=CNT+1 - I CNT=1 D - . S ORDRUG=+$G(ORDIALOG(PROMPT,1)),ORCOMPLX=0 - . S OREFILLS=$P($G(ORDIALOG(PROMPT,"LIST","D",ORDRUG)),U,3) - . S:'$L(OREFILLS) OREFILLS=11 - E S ORCOMPLX=1,OREFILLS=11 ; force interactive on complex order - S ORCOPAY=1 ; ask SC if can't determine copay - I $G(ORDRUG),$L($T(ASKSC^ORCDPS)) S ORCOPAY=$$ASKSC^ORCDPS - Q -AUTHMED ; sets ORQUIT if not authorized to write meds - N NOAUTH,NAME - D AUTH^ORWDPS32(.NOAUTH,ORNP) - I +NOAUTH D - . S ORQUIT=1 - . S LST(0)="8^0" - . S NAME=$P($G(^VA(200,+ORNP,20)),U,2) - . I '$L(NAME) S NAME=$P($G(^VA(200,+ORNP,0)),U,1) - . S LST(.5)=NAME_" is not authorized to write med orders." - Q -MEDACTV(USAGE) ; sets ORQUIT if the orderable item is not active for a med - Q:'$G(OI) S USAGE=+$G(USAGE) - I $G(^ORD(101.43,OI,.1)),^(.1)'>$$NOW^XLFDT D Q - . S ORQUIT=1,LST(0)="8^0" - . S LST(.5)=$P($G(^ORD(101.43,OI,0)),U)_" has been inactivated and may not be ordered anymore." - I USAGE,'$P($G(^ORD(101.43,OI,"PS")),U,USAGE) D Q - . S ORQUIT=1,LST(0)="8^0" - . S LST(.5)=$P($G(^ORD(101.43,OI,0)),U)_" may not be ordered as an "_$S(USAGE=1:"inpatient medication",USAGE=2:"outpatient medication",USAGE=3:"IV solution",1:"IV additive")_" anymore." - Q -SCHEDULD() ; Is patient scheduled for PREOP (Imaging) - I $G(ORDIALOG(PROMPT,1)) Q 1 ; don't ask - already have date - E Q 0 - Q +ORWDXM2 ; SLC/KCM - Quick Orders ;11/25/02 09:49 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,116,132,158,187,195,215**;Dec 17, 1997 + ; +CLRRCL(OK) ; clear ORECALL + S OK=1 + K ^TMP("ORECALL",$J),^TMP("ORWDXMQ",$J) + Q +VERTXT ; set verify text for order + N SEQ,DA,X,PROMPT,MULT,CHILD,INST,TITLE,ILST,SPACES + S ILST=0,$P(SPACES," ",31)="" + S SEQ=0 F S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ)) Q:SEQ'>0 D + . S DA=0 F S DA=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ,DA)) Q:'DA D + . . S X0=$G(^ORD(101.41,+ORDIALOG,10,DA,0)) + . . Q:$P(X0,U,9)["*" ; hidden prompt + . . S PROMPT=$P(X0,U,2),MULT=$P(X0,U,7),CHILD=$P(X0,U,11) Q:CHILD + . . Q:'PROMPT S INST=$O(ORDIALOG(PROMPT,0)) Q:'INST ; no values + . . S TITLE=$S($L($G(ORDIALOG(PROMPT,"TTL"))):ORDIALOG(PROMPT,"TTL"),1:ORDIALOG(PROMPT,"A")) + . . I $E(ORDIALOG(PROMPT,0))="W" D + . . . N IWP,WP,CNT + . . . S IWP=0,CNT=0 + . . . F S IWP=$O(^TMP("ORWORD",$J,PROMPT,INST,IWP)) Q:'IWP D + . . . . S CNT=CNT+1,WP(CNT)=^TMP("ORWORD",$J,PROMPT,INST,IWP,0) + . . . I CNT=1 S ILST=ILST+1,LST(ILST)=$J(TITLE,30)_WP(1) + . . . I CNT>1 D + . . . . S ILST=ILST+1,LST(ILST)=TITLE,IWP=0 + . . . . F S IWP=$O(WP(IWP)) Q:'IWP S ILST=ILST+1,LST(ILST)=WP(IWP) + . . E D + . . . S ILST=ILST+1,LST(ILST)=$J(TITLE,30) + . . . S LST(ILST)=LST(ILST)_$$ITEM^ORCDLG(PROMPT,INST) + . . Q:'MULT Q:'$O(ORDIALOG(PROMPT,INST)) ; done + . . F S INST=$O(ORDIALOG(PROMPT,INST)) Q:INST'>0 S ILST=ILST+1,LST(ILST)=SPACES_$$ITEM^ORCDLG(PROMPT,INST) + D DISPLAY^ORWDBA3 ;for display of Billing Aware data from orig order + Q +RA ; setup environment for radiology + ; -- get imaging types based on display group of quick order and + ; setup list of imaging locations based on imaging type + N ORY,ITYPE,IFN,CNT,ORIMLOC,PROMPT + S ORDIV=$$DIV^ORCDRA1,ITYPE=$P($G(^ORD(100.98,+ORDG,0)),U,3) + S ORIMTYPE=$O(^RA(79.2,"C",ITYPE,0)) + D EN4^RAO7PC1(ITYPE,"ORY") + S (IFN,CNT)=0 F S IFN=$O(ORY(IFN)) Q:IFN'>0 D + . S CNT=CNT+1,ORIMLOC(CNT)=ORY(IFN),ORIMLOC("B",$P(ORY(IFN),U,2))=IFN + I '$$GET^XPAR("ALL","RA SUBMIT PROMPT",1,"Q"),CNT>1 K ORIMLOC + E S ORIMLOC=CNT_"^1" + S PROMPT=$O(^ORD(101.41,"AB","OR GTX IMAGING LOCATION",0)) + I $G(ORIMLOC) M ORDIALOG(PROMPT,"LIST")=ORIMLOC + Q +LR ; setup environment for lab + ; -- setup ORTIME, ORIMTIME & ORTEST arrays + ; setup ORMAX, ORDG, & ORCOLLCT variables + N PROMPT,INST,EDITONLY + D GETIMES^ORCDLR1 ; sets up ORTIME and ORIMTIME arrays + S ORMAX=$$GET^XPAR("ALL^LOC.`"_+ORL,"LR MAX DAYS CONTINUOUS",1,"Q") + S PROMPT=$O(^ORD(101.41,"AB","OR GTX ORDERABLE ITEM",0)),INST=1 + D LRTEST ; sets up ORTEST array and ORDG + S PROMPT=$O(^ORD(101.41,"AB","OR GTX COLLECTION TYPE",0)) + I $D(ORDIALOG(PROMPT,1)) S ORCOLLCT=ORDIALOG(PROMPT,1) I 1 + E S EDITONLY=0,ORCOLLCT=$$COLLTYPE^ORCDLR1 + I ORCOLLCT="I" D + . S PROMPT=$O(^ORD(101.41,"AB","OR GTX START DATE/TIME",0)) + . D LRICTMOK + S PROMPT=$O(^ORD(101.41,"AB","OR GTX ADMIN SCHEDULE",0)) + I $D(ORDIALOG(PROMPT,1)) S ORSCH=ORDIALOG(PROMPT,1) + Q +LRTEST ; -- Setup ORTEST() array of ordering parameters (copied from ORCDLR) + N OI,TST,DG + S OI=+$G(ORDIALOG(PROMPT,INST)) Q:'OI + I '$D(ORTEST) S TST=+$P($G(^ORD(101.43,OI,0)),U,2) D TEST^LR7OR3(TST,.ORTEST) S ORTEST=TST + S DG=$P($G(^ORD(101.43,+OI,"LR")),U,6) S:'$L(DG) DG="LAB" + S DG=$O(^ORD(100.98,"B",DG,0)) S:DG ORDG=DG + Q +LRRQCM() ; return true if lab test has required comments + I $O(^TMP("ORWORD",$J,PROMPT,INST,0)) Q 1 ; edit via WP + N LRTEST,LRSAMP,LRSPEC,LRTSTN,LRTCOM,LRCCOM,DA,CNT,I,REQDCOMM,OI,TST + S LRSAMP=$$VAL^ORCD("COLLECTION SAMPLE"),LRSPEC=$$VAL^ORCD("SPECIMEN") + S OI=+$G(ORDIALOG(PROMPT,INST)) Q:'OI 0 + I '$D(ORTEST) S TST=+$P($G(^ORD(101.43,OI,0)),U,2) D TEST^LR7OR3(TST,.ORTEST) S ORTEST=TST + S LRTSTN=1,LRTEST(1)=+ORTEST,DA=$O(^LAB(60,LRTEST(1),3,"B",+LRSAMP,0)) + S REQDCOMM=$P($G(^LAB(60,LRTEST(1),3,+DA,0)),U,6) + S:'REQDCOMM REQDCOMM=+$P($G(^LAB(60,LRTEST(1),0)),U,19) + Q REQDCOMM +LRASMP() ; return true to ask collection sample (from ASKSAMP^ORCDLR) + N DEFSAMP,SAMP0 + S DEFSAMP=$G(ORDIALOG(PROMPT,INST)),SAMP0=$G(^LAB(62,+DEFSAMP,0)) + I (ORCOLLCT="LC")!(ORCOLLCT="I"),$G(ORTEST("Lab CollSamp")) Q 0 + I $G(ORTEST("Unique CollSamp")),DEFSAMP Q 0 ; unique -> don't ask + I 'DEFSAMP!('FIRST) Q 1 ; no default or edit -> ask + I $G(ORDIALOG(PROMPT,"LIST"))="1^1" Q 0 ; only one choice + Q 1 +LRICTMOK ; + Q:'$D(ORDIALOG(PROMPT,1)) + N ORY + D VALDT^ORWU(.ORY,ORDIALOG(PROMPT,1)) + I +$$VALID^LR7OV4(DUZ(2),ORY)=0 S ORDIALOG(PROMPT,1)="" + Q +DO ; setup environment for diet order + ; partially copied from EN^ORCDFH + I ORCAT'="I" D Q + . S ORQUIT=1 + . S LST(0)="8^0" + . S LST(.5)="This type of diet may be entered for inpatients only." + D EN^FHWOR8(+ORVP,.ORPARAM) ; set FH ordering parameters + S:'$L($G(ORPARAM(3))) ORPARAM(3)="T" ; for now + N PROMPT,OI ; set NPO flag if NPO diet + S PROMPT=$O(^ORD(101.41,"AB","OR GTX ORDERABLE ITEM",0)) + S OI=+$G(ORDIALOG(PROMPT,1)) + S ORNPO=($P($G(^ORD(101.43,OI,0)),U)="NPO") + Q +EL ; setup environment for early/late tray + D EN^FHWOR8(+ORVP,.ORPARAM) ; set FH ordering parameters + S:'$L($G(ORPARAM(3))) ORPARAM(3)="T" ; for now + D EN2^ORCDFH ; setup ORTIME array + N PROMPT ; set ORMEAL,ORTRAY + S PROMPT=$O(^ORD(101.41,"AB","OR GTX MEAL",0)) + I $D(ORDIALOG(PROMPT,1)) S ORMEAL=ORDIALOG(PROMPT,1) + S PROMPT=$O(^ORD(101.41,"AB","OR GTX ORDERABLE ITEM",0)) + I $D(ORDIALOG(PROMPT,1)) S ORTRAY=ORDIALOG(PROMPT,1) + Q +UD ; setup environment for unit dose med + I $G(ORWP94) G PS^ORWDPS3 ; if patch 94 installed + ; + D AUTHMED Q:$G(ORQUIT) ; checks authorized to write meds + N PROMPT,OI + S PROMPT=$O(^ORD(101.41,"AB","OR GTX ORDERABLE ITEM",0)) + I $D(ORDIALOG(PROMPT,1)) S OI=ORDIALOG(PROMPT,1) D MEDACTV(1) Q:$G(ORQUIT) + D INSTR^ORCDPS(OI) ; sets up instructions, routes, etc. + D CHOICES^ORCDPS("U") ; gets list of dispense drugs + Q +IV ; setup environment for IV fluid + D AUTHMED Q:$G(ORQUIT) ; checks authorized to write meds + ; sets up list of volumes if only one solution + ; otherwise, let the dialog go interactive + N PROMPT,INST,CNT,OI + S PROMPT=$O(^ORD(101.41,"AB","OR GTX ORDERABLE ITEM",0)) + S (CNT,INST)=0 + F S INST=$O(ORDIALOG(PROMPT,INST)) Q:'INST D Q:$G(ORQUIT) + . S CNT=CNT+1 + . S OI=ORDIALOG(PROMPT,INST) D MEDACTV(3) ; check active solutions + I CNT=1 S INST=1 D VOLUME^ORCDPSIV + S PROMPT=$O(^ORD(101.41,"AB","OR GTX ADDITIVE",0)) + S INST=0 + F S INST=$O(ORDIALOG(PROMPT,INST)) Q:'INST D Q:$G(ORQUIT) + . S OI=ORDIALOG(PROMPT,INST) D MEDACTV(4) ; check active additives + Q +OP ; setup environment for outpatient pharmacy + I $G(ORWP94) G PS^ORWDPS3 ; if patch 94 installed + ; + D AUTHMED Q:$G(ORQUIT) ; checks authorized to write meds + N PROMPT,INST,CNT,OI + S PROMPT=$O(^ORD(101.41,"AB","OR GTX ORDERABLE ITEM",0)),OI=0 + I $D(ORDIALOG(PROMPT,1)) S OI=$G(ORDIALOG(PROMPT,1)) D MEDACTV(2) Q:$G(ORQUIT) + D:+OI INSTR^ORCDPS(OI) ; sets up instructions, routes, etc. + D CHOICES^ORCDPS("O") ; gets list of dispense drugs + ; get defaults for drug, refills if only one dispense drug + S PROMPT=$O(^ORD(101.41,"AB","OR GTX DISPENSE DRUG",0)) + S (CNT,INST)=0 + F S INST=$O(ORDIALOG(PROMPT,INST)) Q:'INST S CNT=CNT+1 + I CNT=1 D + . S ORDRUG=+$G(ORDIALOG(PROMPT,1)),ORCOMPLX=0 + . S OREFILLS=$P($G(ORDIALOG(PROMPT,"LIST","D",ORDRUG)),U,3) + . S:'$L(OREFILLS) OREFILLS=11 + E S ORCOMPLX=1,OREFILLS=11 ; force interactive on complex order + S ORCOPAY=1 ; ask SC if can't determine copay + I $G(ORDRUG),$L($T(ASKSC^ORCDPS)) S ORCOPAY=$$ASKSC^ORCDPS + Q +AUTHMED ; sets ORQUIT if not authorized to write meds + N NOAUTH,NAME + D AUTH^ORWDPS32(.NOAUTH,ORNP) + I +NOAUTH D + . S ORQUIT=1 + . S LST(0)="8^0" + . S NAME=$P($G(^VA(200,+ORNP,20)),U,2) + . I '$L(NAME) S NAME=$P($G(^VA(200,+ORNP,0)),U,1) + . S LST(.5)=NAME_" is not authorized to write med orders." + Q +MEDACTV(USAGE) ; sets ORQUIT if the orderable item is not active for a med + Q:'$G(OI) S USAGE=+$G(USAGE) + I $G(^ORD(101.43,OI,.1)),^(.1)'>$$NOW^XLFDT D Q + . S ORQUIT=1,LST(0)="8^0" + . S LST(.5)=$P($G(^ORD(101.43,OI,0)),U)_" has been inactivated and may not be ordered anymore." + I USAGE,'$P($G(^ORD(101.43,OI,"PS")),U,USAGE) D Q + . S ORQUIT=1,LST(0)="8^0" + . S LST(.5)=$P($G(^ORD(101.43,OI,0)),U)_" may not be ordered as an "_$S(USAGE=1:"inpatient medication",USAGE=2:"outpatient medication",USAGE=3:"IV solution",1:"IV additive")_" anymore." + Q +SCHEDULD() ; Is patient scheduled for PREOP (Imaging) + I $G(ORDIALOG(PROMPT,1)) Q 1 ; don't ask - already have date + E Q 0 + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXM3.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXM3.m index a33f58cf..f88566bf 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXM3.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXM3.m @@ -1,240 +1,160 @@ -ORWDXM3 ; SLC/KCM/JLI - Quick Orders ;05/27/2008 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,131,132,141,185,187,190,195,215,243**;Dec 17, 1997;Build 242 - ; -VALCOUNT(NAME,ORDIALOG) ; - N COUNT,IEN,NUM - S NUM=0,COUNT=0 - S IEN=$P($G(ORDIALOG("B",NAME)),U,2) Q:IEN'>0 - F S NUM=$O(ORDIALOG(IEN,NUM)) Q:+NUM'>0 S COUNT=COUNT+1 - Q COUNT - ; -ISMISSFL(ORDIALOG,IVTYPE) ; - N ADDCNT,RESULT,STRCNT - S RESULT=0 - S ADDCNT=$$VALCOUNT("ADDITIVE",.ORDIALOG) - S STRCNT=$$VALCOUNT("STRENGTH",.ORDIALOG) - I IVTYPE'="I",ADDCNT'=STRCNT S RESULT=1 - I IVTYPE="I",ADDCNT=0 S RESULT=1 - Q RESULT - ; -KEYVAR(DLG) ; Parse entry action for key variables & return in string - ; RV=CollTp^Samp^Spec^CollDt^Urg^Sched^NoComm^NoDiag^NoProv^NoRsn - N XCODE,RV,POS,Z - S XCODE=$G(^ORD(101.41,DLG,3)),RV="" - I '$L(XCODE) Q "" - S POS=$F(XCODE,"LRFZX=") I POS S $P(RV,U,1)=$$VALUE(XCODE,POS) - S POS=$F(XCODE,"LRFSAMP=") I POS S $P(RV,U,2)=$$VALUE(XCODE,POS) - S POS=$F(XCODE,"LRFSPEC=") I POS S $P(RV,U,3)=$$VALUE(XCODE,POS) - S POS=$F(XCODE,"LRFDATE=") I POS S $P(RV,U,4)=$$VALUE(XCODE,POS) - S POS=$F(XCODE,"LRFURG=") I POS S $P(RV,U,5)=$$VALUE(XCODE,POS) - S POS=$F(XCODE,"LRFSCH=") I POS S $P(RV,U,6)=$$VALUE(XCODE,POS) - S POS=$F(XCODE,"PSJNOPC=") I POS S $P(RV,U,7)=$$VALUE(XCODE,POS) - S POS=$F(XCODE,"GMRCNOPD=") I POS S $P(RV,U,8)=$$VALUE(XCODE,POS) - S POS=$F(XCODE,"GMRCNOAT=") I POS S $P(RV,U,9)=$$VALUE(XCODE,POS) - S POS=$F(XCODE,"GMRCREAF=") I POS S $P(RV,U,10)=$$VALUE(XCODE,POS) - S POS=$F(XCODE,"ORFORGET=") I POS D - . ; need to change this so that it is executed in SETKEYV so - . ; that it is executed each time menu is revisited - . N ORFORGET S ORFORGET=$$VALUE(XCODE,POS) - . I ORFORGET K ^TMP("ORECALL",$J,+ORFORGET) - . E K ^TMP("ORECALL",$J) - Q RV -VALUE(STR,BEG) ; Return value of "var=" (copied from ORCONVRT) - N X,Y,I S X=$E(STR,BEG,999),Y="" - S:$E(X)="""" X=$E(X,2,999) ; strip leading " - F I=1:1:$L(X) S Z=$E(X,I) Q:(Z=",")!(Z=" ")!(Z="""") S Y=Y_Z - Q $TR(Y,U,"") - ; -SETKEYV(X) ; Set the key variables based on contents of X - I $L($P(X,U,1)) S LRFZX=$P(X,U,1) - I $L($P(X,U,2)) S LRFSAMP=$P(X,U,2) - I $L($P(X,U,3)) S LRFSPEC=$P(X,U,3) - I $L($P(X,U,4)) S LRFDATE=$P(X,U,4) - I $L($P(X,U,5)) S LRFURG=$P(X,U,5) - I $L($P(X,U,6)) S LRFSCH=$P(X,U,6) - I $L($P(X,U,7)) S PSJNOPC=$P(X,U,7) - I $L($P(X,U,8)) S GMRCNOPD=$P(X,U,8) - I $L($P(X,U,9)) S GMRCNOAT=$P(X,U,9) - I $L($P(X,U,10)) S GMRCREAF=$P(X,U,10) - Q -DLGINFO(IEN,MODE) ; return information about a dialog - ; IEN=DlgIEN or ORIFN, MODE=0:Dlg,1:Copy,2:Change - ; RESULT=DlgIEN^DlgType^FormID^DGrp - ; If MODE="1;T",don't check "PS MEDS" for transfer order - ; PSMDGP=1: Unit/Dose Group - ; PSMDGP=2: OutPatient Group - N X0,DLGIEN,TYP,FID,DGRP,PSMDGP,ISXF - S PSMDGP=0,ISXF="" - S ISXF=$P(MODE,";",2) - S MODE=+MODE - S DLGIEN=IEN I MODE,(ISXF'="T") D - . S DLGIEN=+$P($G(^OR(100,+IEN,0)),U,5) - . I $P(^ORD(101.41,DLGIEN,0),U)="PS MEDS" D - . . N PTCAT S PTCAT=$P($G(^OR(100,+IEN,0)),U,12) - . . I PTCAT="I" S DLGIEN=$O(^ORD(101.41,"B","PSJ OR PAT OE",0)),PSMDGP=1 - . . I PTCAT="O" S DLGIEN=$O(^ORD(101.41,"B","PSO OERR",0)),PSMDGP=2 - I MODE,(ISXF="T") S DLGIEN=+$P($G(^OR(100,+IEN,0)),U,5) - S X0=$G(^ORD(101.41,DLGIEN,0)),TYP=$P(X0,U,4),DGRP=$P(X0,U,5) - I MODE S DGRP=+$P($G(^OR(100,+IEN,0)),U,11) - ;JD NEW START 11/13/02 - I DLGIEN=$O(^ORD(101.41,"B","PSJ OR PAT OE",0)) S PSMDGP=1 - I DLGIEN=$O(^ORD(101.41,"B","PSO OERR",0)) S PSMDGP=2 - ;JD NEW END 11/13/02 - ; for copy or change, if the base dialog has changed, use it's info - I MODE,$G(ORDIALOG),(+DLGIEN'=+ORDIALOG),(PSMDGP=0) D - . S DLGIEN=+ORDIALOG,DGRP=$P(^ORD(101.41,+ORDIALOG,0),U,5) - D FORMID^ORWDXM(.FID,DLGIEN) - Q DLGIEN_U_TYP_U_FID_U_DGRP - ; -CHKDSBL(LST,ID,MODE) ; return message if dialog disabled - ; ID=DlgIEN or ORIFN, MODE=0:Dialog,1:Copy,2:Change - ; LST=QL_REJECT + disabled message or unchanged - S DLGIEN=+ID I MODE S DLGIEN=+$P($G(^OR(100,+ID,0)),U,5) - S X0=$G(^ORD(101.41,DLGIEN,0)),X=$P(X0,U,3) - I '$L(X),($P(X0,U,4)="Q") D ; check default dialog - . S DLGIEN=+$$DEFDLG^ORWDXQ($P(X0,U,5)) - . S X=$P($G(^ORD(101.41,DLGIEN,0)),U,3) - I $L(X) D - . I MODE D GETTXT^ORWORR(.LST,ID) S LST(.6)="",LST(.7)="Cannot "_$S(MODE=1:"Copy",1:"Change")_" -" - . S LST(0)="8^0",LST(.5)="Dialog Disabled: "_X - Q -CHKVACT(LST,ID,MODE,ORNP) ; return message if action not valid - ; ID=DlgIEN or ORIFN, MODE=0:Dialog,1:Copy,2:Change - ; LST=QL_REJECT + invalid action message or unchanged - Q:'MODE ; not an action on an order - N X,ACT S ACT=$S(MODE=1:"RW",MODE=2:"XX",1:"") - D VALID^ORWDXA(.X,ID,ACT,ORNP) - I $L(X) D GETTXT^ORWORR(.LST,ID) D - . S LST(0)="8^0",LST(.5)=X,LST(.6)="",LST(.7)="Cannot "_$S(MODE=1:"Copy",1:"Change")_" -" - Q -CHKCOPY(LST,ID,FLDS) ; return message if can't copy this order - ; ID=ORIFN;ACT FLDS=EventType in 7th piece - ; LST=QL_REJECT + cannot copy message or unchanged - I "^A^D^T^"'[(U_$E($P(FLDS,U,7))_U) Q ; not event delayed - N PKG S PKG=$P($G(^OR(100,+ID,0)),U,14) - S PKG=$$NMSP^ORCD(PKG) I PKG="OR"!(PKG="PS") Q ; xfer meds, generics - N ORWCAT S ORWCAT=$P($G(^OR(100,+ID,0)),U,12) - I ORWCAT="I",("^A^T^"[(U_$E($P(FLDS,U,7))_U)) Q ; admit, xfer inpt - I ORWCAT="O",$E($P(FLDS,U,7))="D" Q ; discharge outpt - D GETTXT^ORWORR(.LST,ID) - I ORWCAT="I" S LST(.5)="inpatient order to outpatient -" - I ORWCAT="O" S LST(.5)="outpatient order to inpatient -" - S:$D(LST(.5)) LST(.5)="Cannot copy the following "_LST(.5) - S LST(0)="8^0",LST(.7)="" - Q -BLD4CHG(LST,ID,FLDS) ; build responses for an edit - ; ID=ORIFN;ACT FLDS=unused right now - ; LST(0)=Qlvl^RespID(XOrderID)^DlgIEN^DlgType^FormID^DGrp - N OIDX,OI,CNT - S (OI,OIDX,CNT)=0 - S:$D(^OR(100,+ID,4.5,"ID","ORDERABLE")) OIDX=$O(^OR(100,+ID,4.5,"ID","ORDERABLE",0)) - I $D(^OR(100,+ID,4.5,OIDX)) D - . F S CNT=$O(^OR(100,+ID,4.5,OIDX,CNT)) Q:'CNT D - . . S OI=^(CNT) D VALDOI - I +LST(0)=8 S LST(.5)="You can not change this order." Q - S LST(0)="0^X"_ID_U_$$DLGINFO(+ID,2) - S $P(LST(0),U,4)="X" - Q -GETIVTYP() ; - N RESULT,TYPEIEN - S RESULT="" - S TYPEIEN=$O(^ORD(101.41,"B","OR GTX IV TYPE","")) I TYPEIEN'>0 Q RESULT - S RESULT=$G(ORDIALOG(TYPEIEN,1)) - Q RESULT - ; -VALDOI ; Validate the Orderable Items - N ORQUIT,ORPS - I $G(^ORD(101.43,OI,.1)),^(.1)'>$$NOW^XLFDT D - . S ORQUIT=1 - . S LST(0)="8^0" - I $D(ORQUIT) Q:ORQUIT - S ORPS=$G(^ORD(101.43,+OI,"PS")) - I $P(ORPS,U,1,4)="0^0^0^0",($P(ORPS,U,7)=0) S LST(0)="8^0" - Q -VERORD() ; - N INFUSE,INFUID,PASSIV,SUCC,TYPE - S SUCC=0 - S TYPE=$$GETIVTYP - I TYPE="" Q SUCC - S PASSIV=$$IVRTECHK - I PASSIV=0 Q SUCC - S INFUID=$O(^ORD(101.41,"B","OR GTX INFUSION RATE",0)) - S INFUSE=$G(ORDIALOG(INFUID,1)) - S SUCC=$$VALINF(TYPE,INFUSE) - Q SUCC - ; -VALINF(TYPE,INFUSE) ; - N SUCC - S SUCC=0 - I TYPE="I" D Q SUCC - .I INFUSE["INFUSE OVER" S SUCC=1 Q - .I $L(INFUSE)>4 Q - Q 1 - ; -VALQO(IFN) ;Check to see if it's a good QO med - ;If it's an IV QO: check if infusion rate entered - ;If it's an UD QO: check if dosage entered - ;regular order treated as good QO - ; - I $P($G(^ORD(101.41,IFN,0)),U,4)'="Q" Q 1 - N ODP,ODG,INFUID,INFUSE,DSAGEID,SUCC,PASSIV,TYPE - S SUCC=0 - S ODP=+$P($G(^ORD(101.41,IFN,0)),U,7),ODG=+$P($G(^(0)),U,5) - S ODP=$$GET1^DIQ(9.4,+ODP_",",1),ODG=$P($G(^ORD(100.98,ODG,0)),U,3) - I ODP'["PS" Q 1 - ;check infusion rate for IV QO - I ODG="IV RX"!(ODG="TPN") D - . S INFUID=$O(^ORD(101.41,"B","OR GTX INFUSION RATE",0)) - . S TYPE=$$GETIVTYP - . I TYPE="" Q - . I $D(ORDIALOG(INFUID,1)) D - . . I TYPE="I" D Q - . . . S INFUSE=$G(ORDIALOG(INFUID,1)) - . . . I INFUSE="" Q - . . . I INFUSE["INFUSE OVER" S SUCC=1 Q - . . . I $L(INFUSE)>4 Q - . . . I +INFUSE>0 S INFUSE="INFUSE OVER "_INFUSE_" Minutes" - . . . S ORDIALOG(INFUID,1)=INFUSE,SUCC=1 - . . S SUCC=1 - . I '$D(ORDIALOG(INFUID,1)),TYPE="I" S SUCC=1 - . S PASSIV=$$IVRTECHK - . I SUCC=0 Q - . I PASSIV=0 S SUCC=0 - . I SUCC=1,$$ISMISSFL(.ORDIALOG,TYPE)=1 S SUCC=0 - ;check dosage for UD QO - I (ODP="PSJ")!(ODP="PSO"),ODG'="IV RX",ODG'="TPN" D - . S DSAGEID=$O(^ORD(101.41,"B","OR GTX INSTRUCTIONS",0)) - . I $D(ORDIALOG(DSAGEID,1)) S SUCC=1 - Q SUCC - ; -IVRTECHK() ; - N RTIEN,RTVALUE,RESULT - N CNT,NUM,ORDERIDS,OIIEN,OTYPE,ROUTE - S CNT=0,RESULT=0 - S RTIEN=+$P($G(ORDIALOG("B","ROUTE")),U,2) I RTIEN'>0 Q RESULT - S RTVALUE=+$G(ORDIALOG(RTIEN,1)) I RTVALUE'>0 Q RESULT - F OTYPE="SOLUTION","ADDITIVE" D - .S OIIEN=+$P($G(ORDIALOG("B",OTYPE)),U,2) I OIIEN>0 D - ..S NUM=0 F S NUM=$O(ORDIALOG(OIIEN,NUM)) Q:NUM'>0 I +$G(ORDIALOG(OIIEN,NUM))>0 D - ...S CNT=CNT+1,ORDERIDS(CNT)=ORDIALOG(OIIEN,NUM) - I $D(ORDERIDS)=0 Q - S ROUTE=$$IVQOVAL^ORWDPS33(.ORDERIDS,RTVALUE) - I ROUTE="" S ORDIALOG(RTIEN,1)=ROUTE - I ROUTE'="" S RESULT=1 - ;K ^TMP($J,"ORWDXM3 IVRTECHK") - ;D ALL^PSS51P2(RTVALUE,,,,"ORWDXM3 IVRTECHK") - ;I +^TMP($J,"ORWDXM3 IVRTECHK",RTVALUE,6)'=1 S ORDIALOG(RTIEN,1)="",RESULT=0 - ;K ^TMP($J,"ORWDXM3 IVRTECHK") - Q RESULT - ; -ISUDQO(ORY,DLGID) ;True: is unit dose quick order - S ORY=0 - Q:'$D(^ORD(101.41,DLGID,0)) - N CLODGRP,UDGRP1,UDGRP2,DLGTYP,DLGGRP - S UDGRP1=$O(^ORD(100.98,"B","UD RX",0)) - S UDGRP2=$O(^ORD(100.98,"B","I RX",0)) - S CLODGRP=$O(^ORD(100.98,"B","CLINIC ORDERS","")) - S DLGTYP=$P($G(^ORD(101.41,DLGID,0)),U,4) - S DLGGRP=$P($G(^ORD(101.41,DLGID,0)),U,5) - I (DLGTYP="Q"),((DLGGRP=UDGRP1)!(DLGGRP=UDGRP2)!(DLGGRP=CLODGRP)) S ORY=1 - Q +ORWDXM3 ; SLC/KCM/JLI - Quick Orders ;10:42 AM 6/20/2002 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,131,132,141,185,187,190,195,215**;Dec 17, 1997 + ; +KEYVAR(DLG) ; Parse entry action for key variables & return in string + ; RV=CollTp^Samp^Spec^CollDt^Urg^Sched^NoComm^NoDiag^NoProv^NoRsn + N XCODE,RV,POS,Z + S XCODE=$G(^ORD(101.41,DLG,3)),RV="" + I '$L(XCODE) Q "" + S POS=$F(XCODE,"LRFZX=") I POS S $P(RV,U,1)=$$VALUE(XCODE,POS) + S POS=$F(XCODE,"LRFSAMP=") I POS S $P(RV,U,2)=$$VALUE(XCODE,POS) + S POS=$F(XCODE,"LRFSPEC=") I POS S $P(RV,U,3)=$$VALUE(XCODE,POS) + S POS=$F(XCODE,"LRFDATE=") I POS S $P(RV,U,4)=$$VALUE(XCODE,POS) + S POS=$F(XCODE,"LRFURG=") I POS S $P(RV,U,5)=$$VALUE(XCODE,POS) + S POS=$F(XCODE,"LRFSCH=") I POS S $P(RV,U,6)=$$VALUE(XCODE,POS) + S POS=$F(XCODE,"PSJNOPC=") I POS S $P(RV,U,7)=$$VALUE(XCODE,POS) + S POS=$F(XCODE,"GMRCNOPD=") I POS S $P(RV,U,8)=$$VALUE(XCODE,POS) + S POS=$F(XCODE,"GMRCNOAT=") I POS S $P(RV,U,9)=$$VALUE(XCODE,POS) + S POS=$F(XCODE,"GMRCREAF=") I POS S $P(RV,U,10)=$$VALUE(XCODE,POS) + S POS=$F(XCODE,"ORFORGET=") I POS D + . ; need to change this so that it is executed in SETKEYV so + . ; that it is executed each time menu is revisited + . N ORFORGET S ORFORGET=$$VALUE(XCODE,POS) + . I ORFORGET K ^TMP("ORECALL",$J,+ORFORGET) + . E K ^TMP("ORECALL",$J) + Q RV +VALUE(STR,BEG) ; Return value of "var=" (copied from ORCONVRT) + N X,Y,I S X=$E(STR,BEG,999),Y="" + S:$E(X)="""" X=$E(X,2,999) ; strip leading " + F I=1:1:$L(X) S Z=$E(X,I) Q:(Z=",")!(Z=" ")!(Z="""") S Y=Y_Z + Q $TR(Y,U,"") + ; +SETKEYV(X) ; Set the key variables based on contents of X + I $L($P(X,U,1)) S LRFZX=$P(X,U,1) + I $L($P(X,U,2)) S LRFSAMP=$P(X,U,2) + I $L($P(X,U,3)) S LRFSPEC=$P(X,U,3) + I $L($P(X,U,4)) S LRFDATE=$P(X,U,4) + I $L($P(X,U,5)) S LRFURG=$P(X,U,5) + I $L($P(X,U,6)) S LRFSCH=$P(X,U,6) + I $L($P(X,U,7)) S PSJNOPC=$P(X,U,7) + I $L($P(X,U,8)) S GMRCNOPD=$P(X,U,8) + I $L($P(X,U,9)) S GMRCNOAT=$P(X,U,9) + I $L($P(X,U,10)) S GMRCREAF=$P(X,U,10) + Q +DLGINFO(IEN,MODE) ; return information about a dialog + ; IEN=DlgIEN or ORIFN, MODE=0:Dlg,1:Copy,2:Change + ; RESULT=DlgIEN^DlgType^FormID^DGrp + ; If MODE="1;T",don't check "PS MEDS" for transfer order + ; PSMDGP=1: Unit/Dose Group + ; PSMDGP=2: OutPatient Group + N X0,DLGIEN,TYP,FID,DGRP,PSMDGP,ISXF + S PSMDGP=0,ISXF="" + S ISXF=$P(MODE,";",2) + S MODE=+MODE + S DLGIEN=IEN I MODE,(ISXF'="T") D + . S DLGIEN=+$P($G(^OR(100,+IEN,0)),U,5) + . I $P(^ORD(101.41,DLGIEN,0),U)="PS MEDS" D + . . N PTCAT S PTCAT=$P($G(^OR(100,+IEN,0)),U,12) + . . I PTCAT="I" S DLGIEN=$O(^ORD(101.41,"B","PSJ OR PAT OE",0)),PSMDGP=1 + . . I PTCAT="O" S DLGIEN=$O(^ORD(101.41,"B","PSO OERR",0)),PSMDGP=2 + I MODE,(ISXF="T") S DLGIEN=+$P($G(^OR(100,+IEN,0)),U,5) + S X0=$G(^ORD(101.41,DLGIEN,0)),TYP=$P(X0,U,4),DGRP=$P(X0,U,5) + I MODE S DGRP=+$P($G(^OR(100,+IEN,0)),U,11) + ;JD NEW START 11/13/02 + I DLGIEN=$O(^ORD(101.41,"B","PSJ OR PAT OE",0)) S PSMDGP=1 + I DLGIEN=$O(^ORD(101.41,"B","PSO OERR",0)) S PSMDGP=2 + ;JD NEW END 11/13/02 + ; for copy or change, if the base dialog has changed, use it's info + I MODE,$G(ORDIALOG),(+DLGIEN'=+ORDIALOG),(PSMDGP=0) D + . S DLGIEN=+ORDIALOG,DGRP=$P(^ORD(101.41,+ORDIALOG,0),U,5) + D FORMID^ORWDXM(.FID,DLGIEN) + Q DLGIEN_U_TYP_U_FID_U_DGRP + ; +CHKDSBL(LST,ID,MODE) ; return message if dialog disabled + ; ID=DlgIEN or ORIFN, MODE=0:Dialog,1:Copy,2:Change + ; LST=QL_REJECT + disabled message or unchanged + S DLGIEN=+ID I MODE S DLGIEN=+$P($G(^OR(100,+ID,0)),U,5) + S X0=$G(^ORD(101.41,DLGIEN,0)),X=$P(X0,U,3) + I '$L(X),($P(X0,U,4)="Q") D ; check default dialog + . S DLGIEN=+$$DEFDLG^ORWDXQ($P(X0,U,5)) + . S X=$P($G(^ORD(101.41,DLGIEN,0)),U,3) + I $L(X) D + . I MODE D GETTXT^ORWORR(.LST,ID) S LST(.6)="",LST(.7)="Cannot "_$S(MODE=1:"Copy",1:"Change")_" -" + . S LST(0)="8^0",LST(.5)="Dialog Disabled: "_X + Q +CHKVACT(LST,ID,MODE,ORNP) ; return message if action not valid + ; ID=DlgIEN or ORIFN, MODE=0:Dialog,1:Copy,2:Change + ; LST=QL_REJECT + invalid action message or unchanged + Q:'MODE ; not an action on an order + N X,ACT S ACT=$S(MODE=1:"RW",MODE=2:"XX",1:"") + D VALID^ORWDXA(.X,ID,ACT,ORNP) + I $L(X) D GETTXT^ORWORR(.LST,ID) D + . S LST(0)="8^0",LST(.5)=X,LST(.6)="",LST(.7)="Cannot "_$S(MODE=1:"Copy",1:"Change")_" -" + Q +CHKCOPY(LST,ID,FLDS) ; return message if can't copy this order + ; ID=ORIFN;ACT FLDS=EventType in 7th piece + ; LST=QL_REJECT + cannot copy message or unchanged + I "^A^D^T^"'[(U_$E($P(FLDS,U,7))_U) Q ; not event delayed + N PKG S PKG=$P($G(^OR(100,+ID,0)),U,14) + S PKG=$$NMSP^ORCD(PKG) I PKG="OR"!(PKG="PS") Q ; xfer meds, generics + N ORWCAT S ORWCAT=$P($G(^OR(100,+ID,0)),U,12) + I ORWCAT="I",("^A^T^"[(U_$E($P(FLDS,U,7))_U)) Q ; admit, xfer inpt + I ORWCAT="O",$E($P(FLDS,U,7))="D" Q ; discharge outpt + D GETTXT^ORWORR(.LST,ID) + I ORWCAT="I" S LST(.5)="inpatient order to outpatient -" + I ORWCAT="O" S LST(.5)="outpatient order to inpatient -" + S:$D(LST(.5)) LST(.5)="Cannot copy the following "_LST(.5) + S LST(0)="8^0",LST(.7)="" + Q +BLD4CHG(LST,ID,FLDS) ; build responses for an edit + ; ID=ORIFN;ACT FLDS=unused right now + ; LST(0)=Qlvl^RespID(XOrderID)^DlgIEN^DlgType^FormID^DGrp + N OIDX,OI,CNT + S (OI,OIDX,CNT)=0 + S:$D(^OR(100,+ID,4.5,"ID","ORDERABLE")) OIDX=$O(^OR(100,+ID,4.5,"ID","ORDERABLE",0)) + I $D(^OR(100,+ID,4.5,OIDX)) D + . F S CNT=$O(^OR(100,+ID,4.5,OIDX,CNT)) Q:'CNT D + . . S OI=^(CNT) D VALDOI + I +LST(0)=8 S LST(.5)="You can not change this order." Q + S LST(0)="0^X"_ID_U_$$DLGINFO(+ID,2) + S $P(LST(0),U,4)="X" + Q +VALDOI ; Validate the Orderable Items + N ORQUIT,ORPS + I $G(^ORD(101.43,OI,.1)),^(.1)'>$$NOW^XLFDT D + . S ORQUIT=1 + . S LST(0)="8^0" + I $D(ORQUIT) Q:ORQUIT + S ORPS=$G(^ORD(101.43,+OI,"PS")) + I $P(ORPS,U,1,4)="0^0^0^0",($P(ORPS,U,7)=0) S LST(0)="8^0" + Q +VALQO(IFN) ;Check to see if it's a good QO med + ;If it's an IV QO: check if infusion rate entered + ;If it's an UD QO: check if dosage entered + ;regular order treated as good QO + ; + I $P($G(^ORD(101.41,IFN,0)),U,4)'="Q" Q 1 + N ODP,ODG,INFUID,DSAGEID,SUCC + S SUCC=0 + S ODP=+$P($G(^ORD(101.41,IFN,0)),U,7),ODG=+$P($G(^(0)),U,5) + S ODP=$$GET1^DIQ(9.4,+ODP_",",1),ODG=$P($G(^ORD(100.98,ODG,0)),U,3) + ;check infusion rate for IV QO + I ODG="IV RX"!(ODG="TPN") D + . S INFUID=$O(^ORD(101.41,"B","OR GTX INFUSION RATE",0)) + . I $D(ORDIALOG(INFUID,1)) S SUCC=1 + ;check dosage for UD QO + I (ODP="PSJ")!(ODP="PSO"),ODG'="IV RX",ODG'="TPN" D + . S DSAGEID=$O(^ORD(101.41,"B","OR GTX INSTRUCTIONS",0)) + . I $D(ORDIALOG(DSAGEID,1)) S SUCC=1 + Q SUCC +ISUDQO(ORY,DLGID) ;True: is unit dose quick order + S ORY=0 + Q:'$D(^ORD(101.41,DLGID,0)) + N CLODGRP,UDGRP1,UDGRP2,DLGTYP,DLGGRP + S UDGRP1=$O(^ORD(100.98,"B","UD RX",0)) + S UDGRP2=$O(^ORD(100.98,"B","I RX",0)) + S CLODGRP=$O(^ORD(100.98,"B","CLINIC ORDERS","")) + S DLGTYP=$P($G(^ORD(101.41,DLGID,0)),U,4) + S DLGGRP=$P($G(^ORD(101.41,DLGID,0)),U,5) + I (DLGTYP="Q"),((DLGGRP=UDGRP1)!(DLGGRP=UDGRP2)!(DLGGRP=CLODGRP)) S ORY=1 + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXR.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXR.m index 07a4dbc0..0a24cf18 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXR.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXR.m @@ -1,208 +1,172 @@ -ORWDXR ; SLC/KCM/JDL - Utilites for Order Actions ;5/30/06 14:50 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,125,131,134,141,149,187,190,213,243**;Dec 17, 1997;Build 242 - ; -ACTDCREA(DCIEN) ; Valid DC Reason - N X - S X=$G(^ORD(100.03,DCIEN,0)) - I $P(X,U,4) Q 0 - I $P(X,U,5)'=+$O(^DIC(9.4,"C","OR",0)) Q 0 - I $P(X,U,7)=+$O(^ORD(100.02,"C","A",0)) Q 0 - Q 1 - ; -ISREL(VAL,ORIFN) ; Return true if an order has been released - N STS S STS=$P(^OR(100,+ORIFN,3),U,3) - S VAL=$S(STS=10:0,STS=11:0,1:1) ; false if delayed or unreleased order - Q -RENEW(REC,ORIFN,ORVP,ORNP,ORL,FLDS,CPLX,ORAPPT) ; Renew an order - N ORDG - N ORDUZ,ORSTS,OREVENT,ORCAT,ORDA,ORTS,ORNEW,ORCHECK,ORLOG,ORPKG - N ORDIALOG,PRMT,X0 - N FSTDOSE,FST - S (FSTDOSE,FST)=0 - I '$D(CPLX) S CPLX=0 - I '$G(ORAPPT) S ORAPPT="" - S ORVP=ORVP_";DPT(",ORL(2)=ORL_";SC(",ORL=ORL(2) - S X0=^OR(100,+ORIFN,0) - S ORDG=$P(X0,U,11) - S ORPKG=$P(X0,U,14) - I $D(FLDS("ORCHECK")) M ORCHECK=FLDS("ORCHECK") - I $P(X0,U,5)["101.41," D ; version 3 - . S ORDIALOG=+$P(X0,U,5),ORCAT=$P(^OR(100,+ORIFN,0),U,12) - . D GETDLG^ORCD(ORDIALOG),GETORDER^ORCD(+ORIFN) - . I CPLX S FSTDOSE=$P($G(ORDIALOG("B","FIRST DOSE")),U,2) S:'FSTDOSE FSTDOSE=$$PTR^ORCD("OR GTX NOW") - . I FSTDOSE,$G(ORDIALOG(FSTDOSE,1)) K ORDIALOG(FSTDOSE,1) - E D ; version 2.5 generic - . S ORDIALOG=$O(^ORD(101.41,"B","OR GXTEXT WORD PROCESSING ORDE",0)) - . D GETDLG^ORCD(ORDIALOG) - . S PRMT=$O(^ORD(101.41,"B","OR GTX WORD PROCESSING 1",0)) - . S ORDIALOG(PRMT,1)=$NA(^TMP("ORWORD",$J,PRMT,1)) - . M ^TMP("ORWORD",$J,PRMT,1)=^OR(100,+ORIFN,1) - . S PRMT=$O(^ORD(101.41,"B","OR GTX START DATE/TIME",0)) - . I $P(X0,U,9) S ORDIALOG(PRMT,1)=$P(X0,U,9) - I +FLDS(1)=999 D ; generic order - . S ORDIALOG($$PTR^ORCD("OR GTX START DATE/TIME"),1)=$P(FLDS(1),U,2) - . S ORDIALOG($$PTR^ORCD("OR GTX STOP DATE/TIME"),1)=$P(FLDS(1),U,3) - I ($O(^ORD(101.41,"AB","PS MEDS",0))>0),(+FLDS(1)=130)!(+FLDS(1)=135)!(+FLDS(1)=140),'$L($G(ORDIALOG($$PTR^ORCD("OR GTX SIG"),1))) D - . N ORDOSE,ORDRUG,ORCAT,ORWPSOI,PROMPT,DRUG - . S ORCAT=$P($G(^OR(100,+ORIFN,0)),U,12) - . S PROMPT=$$PTR^ORCD("OR GTX INSTRUCTIONS") - . S ORDRUG=$G(ORDIALOG($$PTR^ORCD("OR GTX DISPENSE DRUG"),1)) - . S ORWPSOI=+$G(ORDIALOG($$PTR^ORCD("OR GTX ORDERABLE ITEM"),1)) - . I ORWPSOI S ORWPSOI=+$P($G(^ORD(101.43,+ORWPSOI,0)),U,2) - . D DOSE^PSSORUTL(.ORDOSE,ORWPSOI,$S(ORCAT="I":"U",1:"O"),ORVP) ; dflt doses - . D D1^ORCDPS2 ; set up ORDOSE - . S DRUG=$G(ORDOSE("DD",+ORDRUG)) - . I DRUG,ORCAT="O" D RESETID^ORCDPS - . D SIG^ORCDPS2 - I +FLDS(1)=140 D ; outpatient meds - . K ORDIALOG($$PTR^ORCD("OR GTX START DATE"),1) ; remove effective dt - . S ORDIALOG($$PTR^ORCD("OR GTX REFILLS"),1)=$P(FLDS(1),U,4) - . S ORDIALOG($$PTR^ORCD("OR GTX ROUTING"),1)=$P(FLDS(1),U,5) - . S PRMT=$$PTR^ORCD("OR GTX WORD PROCESSING 1") - . K ^TMP("ORWORD",$J,PRMT,1) - . S I=1 F S I=$O(FLDS(I)) Q:'I S ^TMP("ORWORD",$J,PRMT,1,I-1,0)=FLDS(I) - . S ^TMP("ORWORD",$J,PRMT,1,0)=U_U_(I-1)_U_(I-1)_U_DT_U - . S ORDIALOG(PRMT,1)=$NA(^TMP("ORWORD",$J,PRMT,1)) - . N SIG,PI,X S SIG=$$PTR^ORCD("OR GTX SIG") - . S PI=$$PTR^ORCD("OR GTX PATIENT INSTRUCTIONS"),X=$$STR(PI) - . I $L(X),$$STR(SIG)[X S ORDIALOG(PI,"FORMAT")="@" ;PI in Sig - D RN^ORCSAVE - S REC="" S ORIFN=+ORIFN_";"_ORDA D GETBYIFN^ORWORR(.REC,ORIFN) - Q -RNWFLDS(LST,ORIFN) ; Return fields for renew action - ; LST(0)=RenewType^Start^Stop^Refills^Pickup LST(n)=Comments - N X0,DG,PKG,RNWTYPE,START,STOP,REFILLS,OROI - S ORIFN=+ORIFN,X0=^OR(100,ORIFN,0),DG=$P(X0,U,11),PKG=$P(X0,U,14) - S PKG=$E($P(^DIC(9.4,PKG,0),U,2),1,2),DG=$P(^ORD(100.98,DG,0),U,3) - S LST(0)=$S(PKG="OR":999,PKG="PS"&(DG="O RX"):140,PKG="PS"&(DG="UD RX"):130,PKG="PS"&(DG="NV RX"):145,1:0) - I +LST(0)=140 D - . S LST(0)=LST(0)_U_U_U_+$$VAL(ORIFN,"REFILLS")_U_$$VAL(ORIFN,"PICKUP") - . ;D WPVAL(.LST,ORIFN,"COMMENT") - I +LST(0)=999 S LST(0)=LST(0)_U_$$VAL(ORIFN,"START")_U_$$VAL(ORIFN,"STOP") - ; make sure start/stop times are relative times, otherwise use NOW, no Stop - I +$P(LST(0),U,2) S $P(LST(0),U,2)="NOW" - I +$P(LST(0),U,3)!($P(LST(0),U,3)="0") S $P(LST(0),U,3)="" - ;NEW STUFF AFTER THIS LINE OR*3*243 - S $P(LST(0),U,9)=0 - S OROI=$O(^OR(100,+ORIFN,4.5,"ID","ORDERABLE",0)) - Q:'OROI - S OROI=$G(^OR(100,+ORIFN,4.5,OROI,1)) - Q:'OROI - S $P(LST(0),U,9)=$$ISCLOZ^ORALWORD(OROI) - ; add to LST node specifying if patient of ORIFN passes clozapine lab tests - I $P(LST(0),U,9) D - .N ORY,ORDFN,ORTMP - .S ORTMP=LST(0) - .K LST - .S LST(0)=ORTMP - .S ORDFN=$P(^OR(100,ORIFN,0),U,2) - .I $P(ORDFN,";",2)'="DPT(" Q - .S ORDFN=+ORDFN - .D ALLWORD^ORALWORD(.ORY,ORDFN,ORIFN,"E") - .M LST(1)=ORY - Q -VAL(ORIFN,ID) ; Return value for order response - N DA S DA=+$O(^OR(100,ORIFN,4.5,"ID",ID,0)) - Q $G(^OR(100,ORIFN,4.5,DA,1)) -WPVAL(TXT,ORIFN,ID) ; Return word processing value - N DA S DA=+$O(^OR(100,ORIFN,4.5,"ID",ID,0)) - S I=0 F S I=$O(^OR(100,ORIFN,4.5,DA,2,I)) Q:'I S TXT(I)=^(I,0) - Q -STR(PTR) ; -- Return word processing text as long string for comparison - N X,Y,I,ARRY - S ARRY=$G(ORDIALOG(+$G(PTR),1)) Q:'$L(ARRY) "" - S I=+$O(@ARRY@(0)),Y=$$UP^XLFSTR($G(@ARRY@(I,0))) - F S I=+$O(@ARRY@(I)) Q:'I S X=$G(@ARRY@(I,0)),Y=Y_$$UP^XLFSTR(X) - S Y=$TR(Y," ") ;remove all spaces, compare only text - Q Y -CHKACT(ORDERID,ORWSIG,ORWREL,ORWNATR) ; Return error if can't sign/release order - N ORACT,ORWERR - ; begin case - S ORACT="" - I (ORWSIG=1),$D(^XUSEC("ORES",DUZ)) S ORACT="ES" G XC1 - I (ORWSIG=7),$D(^XUSEC("ORES",DUZ)) S ORACT="DS" G XC1 - I ORWREL,(ORWNATR="W") S ORACT="OC" G XC1 - I ORWREL S ORACT="RS" S:$P($G(^OR(100,+ORDERID,0)),U,16)<2 ORACT="ES" -XC1 ; end case - S ORWERR="" - I $L(ORACT),$$VALID^ORCACT0(ORDERID,ORACT,.ORWERR,ORWNATR) S ORWERR="" - Q ORWERR -GTORITM(Y,ORIFN) ;-- Get back the orderable item IEN - S ORIFN=+ORIFN - S Y=$$VALUE^ORCSAVE2(ORIFN,"ORDERABLE") - Q -GETPKG(Y,IFN) ;Get package for an order - N ORDERID,PKGID - Q:+IFN<1 - S ORDERID=+IFN,Y="" - S PKGID=$P(^OR(100,ORDERID,0),U,14) - S:PKGID>0 Y=$P(^DIC(9.4,PKGID,0),U,2) - Q -ISCPLX(ORY,ORID) ; 1: is complex order 0: is not - Q:'$D(^OR(100,+ORID,0)) - N PKG - S PKG=$P($G(^OR(100,+ORID,0)),U,14) - S PKG=$$NMSP^ORCD(PKG) - I PKG'="PS" Q - N NUMCHDS,NOWID,NOWVAL - S (NOWVAL,NOWID)=0 - S NUMCHDS=$P($G(^OR(100,+ORID,2,0)),U,4) - I NUMCHDS>2 S ORY=1 Q - I NUMCHDS=2 D - . S ORY=1 - . S:$D(^OR(100,+ORID,4.5,"ID","NOW")) NOWID=$O(^("NOW",0)) - . S:NOWID NOWVAL=$G(^OR(100,+ORID,4.5,NOWID,1)) - I NOWVAL=1 S ORY=0 Q - Q -ORCPLX(ORY,ORID,ORACT) ;Return children orders of the complex order - Q:'$D(^OR(100,+ORID,0)) - N PKG,LACT,OELACT,ISNOW - S PKG=$P($G(^OR(100,+ORID,0)),U,14) - S PKG=$$NMSP^ORCD(PKG) - I PKG'="PS" Q - N CHLDCNT,IDX,X3 - S (CHLDCNT,IDX)=0 - S:$L($G(^OR(100,+ORID,2,0))) CHLDCNT=$P(^(0),U,4) - I 'CHLDCNT Q - F S IDX=$O(^OR(100,+ORID,2,IDX)) Q:'IDX D - . S (LACT,OELACT,ISNOW)=0 - . D ISNOW(.ISNOW,IDX) - . Q:ISNOW - . S X3=$G(^OR(100,IDX,3)) - . S LACT=$P(X3,U,7) - . F S OELACT=$O(^OR(100,IDX,8,OELACT),-1) Q:OELACT - . S:OELACT>LACT LACT=OELACT - . S ORY(IDX)=IDX_";"_LACT - Q -CANRN(ORY,ORID) ; Check conjunction for renew. - ; All conjunctioni = "And" return 1 - ; Has a "Then" return 0 - Q:'$G(^OR(100,+ORID,0)) - N PKG - S PKG=$P($G(^OR(100,+ORID,0)),U,14) - S PKG=$$NMSP^ORCD(PKG) - I PKG'="PS" Q - N INDX,INDY,CANRENEW - S INDX=0 - S CANRENEW=1 - N CHID - S CHID=0 F S CHID=$O(^OR(100,+ORID,2,CHID)) Q:'CHID D - . N ORSTS,ACTIVE S ORSTS=0 - . S ORSTS=$P($G(^OR(100,CHID,3)),U,3) - . S ACTIVE=$O(^ORD(100.01,"B","ACTIVE",0)) - . I ACTIVE'=ORSTS S CANRENEW=0 - I 'CANRENEW S ORY=CANRENEW Q - F S INDX=$O(^OR(100,+ORID,4.5,"ID","CONJ",INDX)) Q:'INDX D - . S INDY=0 F S INDY=$O(^OR(100,+ORID,4.5,INDX,INDY)) Q:'INDY D - . . I $G(^(INDY))="T" S CANRENEW=0 Q - . I CANRENEW=0 Q - S ORY=CANRENEW - Q -ISNOW(ORY,ORID) ; Is first time now order? - N SCH - Q:'$D(^OR(100,+ORID,0)) - S SCH="" - S SCH=$O(^OR(100,+ORID,4.5,"ID","SCHEDULE",0)) - S:SCH SCH=$G(^OR(100,+ORID,4.5,SCH,1)) - S:SCH="NOW" ORY=1 - Q +ORWDXR ; SLC/KCM/JDL - Utilites for Order Actions ;5/6/04 14:50 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,125,131,134,141,149,187,190,213**;Dec 17, 1997 + ; +ISREL(VAL,ORIFN) ; Return true if an order has been released + N STS S STS=$P(^OR(100,+ORIFN,3),U,3) + S VAL=$S(STS=10:0,STS=11:0,1:1) ; false if delayed or unreleased order + Q +RENEW(REC,ORIFN,ORVP,ORNP,ORL,FLDS,CPLX,ORAPPT) ; Renew an order + N ORDG + N ORDUZ,ORSTS,OREVENT,ORCAT,ORDA,ORTS,ORNEW,ORCHECK,ORLOG,ORPKG + N ORDIALOG,PRMT,X0 + N FSTDOSE,FST + S (FSTDOSE,FST)=0 + I '$D(CPLX) S CPLX=0 + I '$G(ORAPPT) S ORAPPT="" + S ORVP=ORVP_";DPT(",ORL(2)=ORL_";SC(",ORL=ORL(2) + S X0=^OR(100,+ORIFN,0) + S ORDG=$P(X0,U,11) + S ORPKG=$P(X0,U,14) + I $D(FLDS("ORCHECK")) M ORCHECK=FLDS("ORCHECK") + I $P(X0,U,5)["101.41," D ; version 3 + . S ORDIALOG=+$P(X0,U,5),ORCAT=$P(^OR(100,+ORIFN,0),U,12) + . D GETDLG^ORCD(ORDIALOG),GETORDER^ORCD(+ORIFN) + . I CPLX S FSTDOSE=$P($G(ORDIALOG("B","FIRST DOSE")),U,2) S:'FSTDOSE FSTDOSE=$$PTR^ORCD("OR GTX NOW") + . I FSTDOSE,$G(ORDIALOG(FSTDOSE,1)) K ORDIALOG(FSTDOSE,1) + E D ; version 2.5 generic + . S ORDIALOG=$O(^ORD(101.41,"B","OR GXTEXT WORD PROCESSING ORDE",0)) + . D GETDLG^ORCD(ORDIALOG) + . S PRMT=$O(^ORD(101.41,"B","OR GTX WORD PROCESSING 1",0)) + . S ORDIALOG(PRMT,1)=$NA(^TMP("ORWORD",$J,PRMT,1)) + . M ^TMP("ORWORD",$J,PRMT,1)=^OR(100,+ORIFN,1) + . S PRMT=$O(^ORD(101.41,"B","OR GTX START DATE/TIME",0)) + . I $P(X0,U,9) S ORDIALOG(PRMT,1)=$P(X0,U,9) + I +FLDS(1)=999 D ; generic order + . S ORDIALOG($$PTR^ORCD("OR GTX START DATE/TIME"),1)=$P(FLDS(1),U,2) + . S ORDIALOG($$PTR^ORCD("OR GTX STOP DATE/TIME"),1)=$P(FLDS(1),U,3) + I ($O(^ORD(101.41,"AB","PS MEDS",0))>0),(+FLDS(1)=130)!(+FLDS(1)=135)!(+FLDS(1)=140),'$L($G(ORDIALOG($$PTR^ORCD("OR GTX SIG"),1))) D + . N ORDOSE,ORDRUG,ORCAT,ORWPSOI,PROMPT,DRUG + . S ORCAT=$P($G(^OR(100,+ORIFN,0)),U,12) + . S PROMPT=$$PTR^ORCD("OR GTX INSTRUCTIONS") + . S ORDRUG=$G(ORDIALOG($$PTR^ORCD("OR GTX DISPENSE DRUG"),1)) + . S ORWPSOI=+$G(ORDIALOG($$PTR^ORCD("OR GTX ORDERABLE ITEM"),1)) + . I ORWPSOI S ORWPSOI=+$P($G(^ORD(101.43,+ORWPSOI,0)),U,2) + . D DOSE^PSSORUTL(.ORDOSE,ORWPSOI,$S(ORCAT="I":"U",1:"O"),ORVP) ; dflt doses + . D D1^ORCDPS2 ; set up ORDOSE + . S DRUG=$G(ORDOSE("DD",+ORDRUG)) + . I DRUG,ORCAT="O" D RESETID^ORCDPS + . D SIG^ORCDPS2 + I +FLDS(1)=140 D ; outpatient meds + . K ORDIALOG($$PTR^ORCD("OR GTX START DATE"),1) ; remove effective dt + . S ORDIALOG($$PTR^ORCD("OR GTX REFILLS"),1)=$P(FLDS(1),U,4) + . S ORDIALOG($$PTR^ORCD("OR GTX ROUTING"),1)=$P(FLDS(1),U,5) + . S PRMT=$$PTR^ORCD("OR GTX WORD PROCESSING 1") + . K ^TMP("ORWORD",$J,PRMT,1) + . S I=1 F S I=$O(FLDS(I)) Q:'I S ^TMP("ORWORD",$J,PRMT,1,I-1,0)=FLDS(I) + . S ^TMP("ORWORD",$J,PRMT,1,0)=U_U_(I-1)_U_(I-1)_U_DT_U + . S ORDIALOG(PRMT,1)=$NA(^TMP("ORWORD",$J,PRMT,1)) + D RN^ORCSAVE + S REC="" S ORIFN=+ORIFN_";"_ORDA D GETBYIFN^ORWORR(.REC,ORIFN) + Q +RNWFLDS(LST,ORIFN) ; Return fields for renew action + ; LST(0)=RenewType^Start^Stop^Refills^Pickup LST(n)=Comments + N X0,DG,PKG,RNWTYPE,START,STOP,REFILLS + S ORIFN=+ORIFN,X0=^OR(100,ORIFN,0),DG=$P(X0,U,11),PKG=$P(X0,U,14) + S PKG=$E($P(^DIC(9.4,PKG,0),U,2),1,2),DG=$P(^ORD(100.98,DG,0),U,3) + S LST(0)=$S(PKG="OR":999,PKG="PS"&(DG="O RX"):140,PKG="PS"&(DG="UD RX"):130,PKG="PS"&(DG="NV RX"):145,1:0) + I +LST(0)=140 D + . S LST(0)=LST(0)_U_U_U_+$$VAL(ORIFN,"REFILLS")_U_$$VAL(ORIFN,"PICKUP") + . D WPVAL(.LST,ORIFN,"COMMENT") + I +LST(0)=999 S LST(0)=LST(0)_U_$$VAL(ORIFN,"START")_U_$$VAL(ORIFN,"STOP") + ; make sure start/stop times are relative times, otherwise use NOW, no Stop + I +$P(LST(0),U,2) S $P(LST(0),U,2)="NOW" + I +$P(LST(0),U,3)!($P(LST(0),U,3)="0") S $P(LST(0),U,3)="" + Q +VAL(ORIFN,ID) ; Return value for order response + N DA S DA=+$O(^OR(100,ORIFN,4.5,"ID",ID,0)) + Q $G(^OR(100,ORIFN,4.5,DA,1)) +WPVAL(TXT,ORIFN,ID) ; Return word processing value + N DA S DA=+$O(^OR(100,ORIFN,4.5,"ID",ID,0)) + S I=0 F S I=$O(^OR(100,ORIFN,4.5,DA,2,I)) Q:'I S TXT(I)=^(I,0) + Q +CHKACT(ORDERID,ORWSIG,ORWREL,ORWNATR) ; Return error if can't sign/release order + N ORACT,ORWERR + ; begin case + S ORACT="" + I (ORWSIG=1),$D(^XUSEC("ORES",DUZ)) S ORACT="ES" G XC1 + I (ORWSIG=7),$D(^XUSEC("ORES",DUZ)) S ORACT="DS" G XC1 + I ORWREL,(ORWNATR="W") S ORACT="OC" G XC1 + I ORWREL S ORACT="RS" S:$P($G(^OR(100,+ORDERID,0)),U,16)<2 ORACT="ES" +XC1 ; end case + S ORWERR="" + I $L(ORACT),$$VALID^ORCACT0(ORDERID,ORACT,.ORWERR,ORWNATR) S ORWERR="" + Q ORWERR +GTORITM(Y,ORIFN) ;-- Get back the orderable item IEN + S ORIFN=+ORIFN + S Y=$$VALUE^ORCSAVE2(ORIFN,"ORDERABLE") + Q +GETPKG(Y,IFN) ;Get package for an order + N ORDERID,PKGID + Q:+IFN<1 + S ORDERID=+IFN,Y="" + S PKGID=$P(^OR(100,ORDERID,0),U,14) + S:PKGID>0 Y=$P(^DIC(9.4,PKGID,0),U,2) + Q +ISCPLX(ORY,ORID) ; 1: is complex order 0: is not + Q:'$D(^OR(100,+ORID,0)) + N PKG + S PKG=$P($G(^OR(100,+ORID,0)),U,14) + S PKG=$$NMSP^ORCD(PKG) + I PKG'="PS" Q + N NUMCHDS,NOWID,NOWVAL + S (NOWVAL,NOWID)=0 + S NUMCHDS=$P($G(^OR(100,+ORID,2,0)),U,4) + I NUMCHDS>2 S ORY=1 Q + I NUMCHDS=2 D + . S ORY=1 + . S:$D(^OR(100,+ORID,4.5,"ID","NOW")) NOWID=$O(^("NOW",0)) + . S:NOWID NOWVAL=$G(^OR(100,+ORID,4.5,NOWID,1)) + I NOWVAL=1 S ORY=0 Q + Q +ORCPLX(ORY,ORID,ORACT) ;Return children orders of the complex order + Q:'$D(^OR(100,+ORID,0)) + N PKG,LACT,OELACT,ISNOW + S PKG=$P($G(^OR(100,+ORID,0)),U,14) + S PKG=$$NMSP^ORCD(PKG) + I PKG'="PS" Q + N CHLDCNT,IDX,X3 + S (CHLDCNT,IDX)=0 + S:$L($G(^OR(100,+ORID,2,0))) CHLDCNT=$P(^(0),U,4) + I 'CHLDCNT Q + F S IDX=$O(^OR(100,+ORID,2,IDX)) Q:'IDX D + . S (LACT,OELACT,ISNOW)=0 + . D ISNOW(.ISNOW,IDX) + . Q:ISNOW + . S X3=$G(^OR(100,IDX,3)) + . S LACT=$P(X3,U,7) + . F S OELACT=$O(^OR(100,IDX,8,OELACT),-1) Q:OELACT + . S:OELACT>LACT LACT=OELACT + . S ORY(IDX)=IDX_";"_LACT + Q +CANRN(ORY,ORID) ; Check conjunction for renew. + ; All conjunctioni = "And" return 1 + ; Has a "Then" return 0 + Q:'$G(^OR(100,+ORID,0)) + N PKG + S PKG=$P($G(^OR(100,+ORID,0)),U,14) + S PKG=$$NMSP^ORCD(PKG) + I PKG'="PS" Q + N INDX,INDY,CANRENEW + S INDX=0 + S CANRENEW=1 + N CHID + S CHID=0 F S CHID=$O(^OR(100,+ORID,2,CHID)) Q:'CHID D + . N ORSTS,ACTIVE S ORSTS=0 + . S ORSTS=$P($G(^OR(100,CHID,3)),U,3) + . S ACTIVE=$O(^ORD(100.01,"B","ACTIVE",0)) + . I ACTIVE'=ORSTS S CANRENEW=0 + I 'CANRENEW S ORY=CANRENEW Q + F S INDX=$O(^OR(100,+ORID,4.5,"ID","CONJ",INDX)) Q:'INDX D + . S INDY=0 F S INDY=$O(^OR(100,+ORID,4.5,INDX,INDY)) Q:'INDY D + . . I $G(^(INDY))="T" S CANRENEW=0 Q + . I CANRENEW=0 Q + S ORY=CANRENEW + Q +ISNOW(ORY,ORID) ; Is first time now order? + N SCH + Q:'$D(^OR(100,+ORID,0)) + S SCH="" + S SCH=$O(^OR(100,+ORID,4.5,"ID","SCHEDULE",0)) + S:SCH SCH=$G(^OR(100,+ORID,4.5,SCH,1)) + S:SCH="NOW" ORY=1 + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXVB.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXVB.m index 766e54ef..6c0c8226 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXVB.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXVB.m @@ -1,138 +1,119 @@ -ORWDXVB ;slc/dcm - Order dialog utilities for Blood Bank ;12/7/05 17:11 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,243**;Dec 17 1997;Build 242 - ; - ; DBIA 2503 RR^LR7OR1 ^TMP("LRRR",$J) - ; -GETPAT(ORX,DFN,ORL) ;Get Patient data from VBECS - ;Needs patient DFN and Location (ORL) - N ORSTN,DIV - S DIV=+$P($G(^SC(+$G(ORL),0)),U,15),ORSTN=$P($$SITE^VASITE(DT,DIV),U,3) - D OEAPI^VBECA3(.ORX,DFN,ORSTN) - Q -PTINFO(OROOT,ORX) ;Format patient BB info - Q:'$D(ORX) - D PTINFO^ORWDXVB1 - Q -RESULTS(OROOT,DFN,ORX) ;Get test results - Q:'$O(ORX(0)) ;ORX contains a list of tests to retrieve results for - N ORCOM,ORT,ORTST,ORTDT,ORTMP,GCNT,CCNT,GIOSL,GIOM,I,ORZ - S GCNT=0,CCNT=1,GIOSL=999999,GIOM=80 - S OROOT=$NA(^TMP("ORVBEC",$J)) - K ^TMP("ORVBEC",$J) - D LN - S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"RECENT LAB RESULTS:",.CCNT) - D LN - S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"Test Result Units Range Collected Accession Sts",.CCNT) - D LN - S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"---- ------ ----- ----- --------- --------- ---",.CCNT) - S ORT=0 F S ORT=$O(ORX(ORT)) Q:'ORT S ORTST=$P(ORX(ORT),"^",1) D - . K ^TMP("LRRR",$J) D RR^LR7OR1(DFN,,,,,ORTST,,1) ;DBIA 2503 - . S ORTMP="^TMP(""LRRR"",$J,DFN)",ORTMP=$Q(@ORTMP) - . Q:$P(ORTMP,",",1,3)'=("^TMP(""LRRR"","_$J_","_DFN) - . S ORTDT=9999999-+$P(ORTMP,",",5),ORZ=@ORTMP - . D LN - . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,$P(ORZ,"^",15),.CCNT)_$$S^ORU4(8,CCNT,$J($P(ORZ,"^",2),7),.CCNT)_$$S^ORU4(16,CCNT,$P(ORZ,"^",3),.CCNT)_$$S^ORU4(19,CCNT,$P(ORZ,"^",4),.CCNT)_$$S^ORU4(30,CCNT,$P(ORZ,"^",5),.CCNT) - . S ^(0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(40,CCNT,$$DATETIME^ORCHTAB(ORTDT),.CCNT)_$$S^ORU4(56,CCNT,$P(ORZ,"^",16),.CCNT)_$$S^ORU4(71,CCNT,$P(ORZ,"^",6),.CCNT) - . S ORCOM=$P(ORTMP,",",1,5)_",""N""" ;check for comments - . F S ORTMP=$Q(@ORTMP) Q:$P(ORTMP,",",1,6)'=ORCOM D - .. D LN - .. S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,@ORTMP,.CCNT) - K ^TMP("LRRR",$J) - Q -RAW(OROOT,DFN,ORX) ;Get RAW test results - Q:'$O(ORX(0)) ;ORX contains a list of tests to retrieve results for - N ORCOM,ORT,ORTST,ORTDT,ORTMP,GCNT,CCNT,GIOSL,GIOM,I - S GCNT=0,CCNT=1,GIOSL=999999,GIOM=80 - S OROOT=$NA(^TMP("ORVBEC",$J)) - K ^TMP("ORVBEC",$J) - S ORT=0 F S ORT=$O(ORX(ORT)) Q:'ORT S ORTST=$P(ORX(ORT),"^",1) D - . K ^TMP("LRRR",$J) D RR^LR7OR1(DFN,,,,,ORTST,,1) - . S ORTMP="^TMP(""LRRR"",$J,DFN)",ORTMP=$Q(@ORTMP) - . Q:$P(ORTMP,",",1,3)'=("^TMP(""LRRR"","_$J_","_DFN) - . S ORTDT=9999999-+$P(ORTMP,",",5),ORZ=@ORTMP - . D LN - . S ^TMP("ORVBEC",$J,GCNT,0)=$P(ORZ,"^",1,6)_"^"_ORTDT - K ^TMP("LRRR",$J) - Q -SURG(OROOT,ORX) ;Get list of surgeries - N I,CNT,X - S (I,CNT)=0 - F S I=$O(ORX("SURGERY",I)) Q:'I S X=$G(ORX("SURGERY",I)) D - . S CNT=CNT+1,OROOT(CNT)=X_U_X - Q -LN ;Increment counts - S GCNT=GCNT+1,CCNT=1 - Q -PATINFO(OROOT,DFN,LOC) ;Test ^TMP global output - N ORX - D GETPAT(.ORX,DFN,LOC) - I $L($G(ORX("SPECIMEN"))) S:$P(ORX("SPECIMEN"),"^") $P(ORX("SPECIMEN"),"^")=$$HL7TFM^XLFDT($P(ORX("SPECIMEN"),"^")) - D PTINFO(.OROOT,.ORX) - ;S I=0 F S I=$O(@OROOT@(I)) Q:'I W !,^(I,0) - ;K @OROOT - Q -GETALL(OROOT,DFN,LOC) ;Get all data in one call and let the GUI divide it up - N ORX,INFO,CNT,I,J,K - S OROOT=$NA(^TMP("ORVBECINFO",$J)),CNT=1 - D GETPAT(.ORX,DFN,LOC) - ;S ^TMP("ORVBECINFO",$J,CNT)="~RAWDATA",I=0 - ;F S I=$O(ORX(I)) Q:'I S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)=ORX(I) - I $L($G(ORX("SPECIMEN"))) S:$P(ORX("SPECIMEN"),"^") $P(ORX("SPECIMEN"),"^")=$$HL7TFM^XLFDT($P(ORX("SPECIMEN"),"^")) S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~SPECIMEN",CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_ORX("SPECIMEN") - I $L($G(ORX("ABORH"))) S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~ABORH",CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_ORX("ABORH") - S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~TYPE AND SCREEN",CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_$O(^ORD(101.43,"ID","1;99VBC",0)) - S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~OTHER",CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_$O(^ORD(101.43,"ID","6;99VBC",0)) - S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~SPECIMENS",I=0 - F S I=$O(ORX(I)) Q:'I S J="" F S J=$O(ORX(I,J)) Q:J="" I J="SPECIMEN" S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_I_"^"_ORX(I,J) - S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~TESTS",I=0 - F S I=$O(ORX(I)) Q:'I S J="" F S J=$O(ORX(I,J)) Q:J="" I J="TEST" S K=0 F S K=$O(ORX(I,J,K)) Q:'K S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_I_"^"_K_"^"_ORX(I,J,K) - S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~MSBOS",I=0 - F S I=$O(ORX(I)) Q:'I S J="" F S J=$O(ORX(I,J)) Q:J="" I J="MSBOS" S K=0 F S K=$O(ORX(I,J,K)) Q:'K S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_I_"^"_K_"^"_ORX(I,J,K),$P(^(CNT),"^",4)=+$P(ORX(I,J,K),"^",2) - S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~SURGERIES",I=0 - F S I=$O(ORX("SURGERY",I)) Q:'I S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_I_"^"_ORX("SURGERY",I) - S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~URGENCIES",I="" - F S I=$O(^ORD(101.42,"S.VBEC",I)) Q:I="" S J=0 F S J=$O(^ORD(101.42,"S.VBEC",I,J)) Q:'J S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_J_"^"_I - S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~MODIFIERS",I="" - N ORMODS D GETLST^XPAR(.ORMODS,"ALL","OR VBECS MODIFIERS","I") - F S I=$O(ORMODS(I)) Q:'I S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_ORMODS(I) - ;F I="W^Washed","I^Irradiated","L^Leuko Reduced","V^Volume Reduced","D^Divided","E^Leuko Reduced/Irradiated" S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_I - S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~REASONS",I="" - N ORMODS D GETLST^XPAR(.ORMODS,"ALL","OR VBECS REASON FOR REQUEST","I") - F S I=$O(ORMODS(I)) Q:'I S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_ORMODS(I) - S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~INFO" - D PTINFO(.INFO,.ORX) - S I=0 F S I=$O(^TMP("ORVBEC",$J,I)) Q:'I S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_^TMP("ORVBEC",$J,I,0) - S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~TNS ORDERS" - N ORMODS D PULL^ORWDXVB2(.ORMODS,DFN) - S I=0 F S I=$O(ORMODS(I)) Q:'I S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_ORMODS(I) - K ^TMP("ORVBEC",$J) - Q -STATALOW(OROOT,DFN) ;Allow stat for ORES ORELSE users - S OROOT=$D(^XUSEC("ORES",DUZ))!($D(^XUSEC("ORELSE",DUZ))) - Q -NURSADMN(OROOT) ;Suppress Nursing Adiminstration Order Prompt - S OROOT=+$$GET^XPAR("DIV^SYS^PKG","OR VBECS SUPPRESS NURS ADMIN") - Q -VBTNS(RETURN) ;RPC to get Days back to check for Type & Screen order - S RETURN=$$GET^XPAR("ALL","ORWDXVB VBECS TNS CHECK",1,"I") - Q -COMPORD(OROOT) ;Get sequence order of Blood Components - N ORLIST,I,X - D GETLST^XPAR(.ORLIST,"ALL","OR VBECS COMPONENT ORDER") - S I=0 F S I=$O(ORLIST(I)) Q:'I S X=ORLIST(I) I $D(^ORD(101.43,$P(X,"^",2),0)) S OROOT(I)=$P(X,"^",2)_"^"_$P(^(0),"^",1)_"^"_$P(^(0),"^",1) - Q -SUBCHK(OROOT,TSTNM) ;Check to see if selected test is a Blood Component or a Diagnostic Test - S OROOT="" - Q:'$L($G(TSTNM)) - I $O(^ORD(101.43,"S.VBT",TSTNM,0)) S OROOT="t" - I $O(^ORD(101.43,"S.VBC",TSTNM,0)) S OROOT="c" - Q -TESTR ;Test results call - N ORX - S ORX(3)="3" ;HGB - S ORX(4)="4" ;HCT - S ORX(1)="1" ;WBC - S ORX(113)="113" ;FERRITIN - D RESULTS(.OROOT,66,.ORX) - S I=0 F S I=$O(@OROOT@(I)) Q:'I W !,^(I,0) - K @OROOT - Q +ORWDXVB ;slc/dcm - Order dialog utilities for Blood Bank ;12/7/05 17:11 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215**;Dec 17 1997 + ; + ; DBIA 2503 RR^LR7OR1 ^TMP("LRRR",$J) + ; +GETPAT(ORX,DFN,ORL) ;Get Patient data from VBECS + ;Needs patient DFN and Location (ORL) + N ORSTN,DIV + S DIV=+$P($G(^SC(+$G(ORL),0)),U,15),ORSTN=$P($$SITE^VASITE(DT,DIV),U,3) + D OEAPI^VBECA3(.ORX,DFN,ORSTN) + Q +PTINFO(OROOT,ORX) ;Format patient BB info + Q:'$D(ORX) + D PTINFO^ORWDXVB1 + Q +RESULTS(OROOT,DFN,ORX) ;Get test results + Q:'$O(ORX(0)) ;ORX contains a list of tests to retrieve results for + N ORCOM,ORT,ORTST,ORTDT,ORTMP,GCNT,CCNT,GIOSL,GIOM,I,ORZ + S GCNT=0,CCNT=1,GIOSL=999999,GIOM=80 + S OROOT=$NA(^TMP("ORVBEC",$J)) + K ^TMP("ORVBEC",$J) + D LN + S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"RECENT LAB RESULTS:",.CCNT) + D LN + S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"Test Result Units Range Collected Accession Sts",.CCNT) + D LN + S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"---- ------ ----- ----- --------- --------- ---",.CCNT) + S ORT=0 F S ORT=$O(ORX(ORT)) Q:'ORT S ORTST=$P(ORX(ORT),"^",1) D + . K ^TMP("LRRR",$J) D RR^LR7OR1(DFN,,,,,ORTST,,1) ;DBIA 2503 + . S ORTMP="^TMP(""LRRR"",$J,DFN)",ORTMP=$Q(@ORTMP) + . Q:$P(ORTMP,",",1,3)'=("^TMP(""LRRR"","_$J_","_DFN) + . S ORTDT=9999999-+$P(ORTMP,",",5),ORZ=@ORTMP + . D LN + . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,$P(ORZ,"^",15),.CCNT)_$$S^ORU4(8,CCNT,$J($P(ORZ,"^",2),7),.CCNT)_$$S^ORU4(16,CCNT,$P(ORZ,"^",3),.CCNT)_$$S^ORU4(19,CCNT,$P(ORZ,"^",4),.CCNT)_$$S^ORU4(30,CCNT,$P(ORZ,"^",5),.CCNT) + . S ^(0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(40,CCNT,$$DATETIME^ORCHTAB(ORTDT),.CCNT)_$$S^ORU4(56,CCNT,$P(ORZ,"^",16),.CCNT)_$$S^ORU4(71,CCNT,$P(ORZ,"^",6),.CCNT) + . S ORCOM=$P(ORTMP,",",1,5)_",""N""" ;check for comments + . F S ORTMP=$Q(@ORTMP) Q:$P(ORTMP,",",1,6)'=ORCOM D + .. D LN + .. S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,@ORTMP,.CCNT) + K ^TMP("LRRR",$J) + Q +RAW(OROOT,DFN,ORX) ;Get RAW test results + Q:'$O(ORX(0)) ;ORX contains a list of tests to retrieve results for + N ORCOM,ORT,ORTST,ORTDT,ORTMP,GCNT,CCNT,GIOSL,GIOM,I + S GCNT=0,CCNT=1,GIOSL=999999,GIOM=80 + S OROOT=$NA(^TMP("ORVBEC",$J)) + K ^TMP("ORVBEC",$J) + S ORT=0 F S ORT=$O(ORX(ORT)) Q:'ORT S ORTST=$P(ORX(ORT),"^",1) D + . K ^TMP("LRRR",$J) D RR^LR7OR1(DFN,,,,,ORTST,,1) + . S ORTMP="^TMP(""LRRR"",$J,DFN)",ORTMP=$Q(@ORTMP) + . Q:$P(ORTMP,",",1,3)'=("^TMP(""LRRR"","_$J_","_DFN) + . S ORTDT=9999999-+$P(ORTMP,",",5),ORZ=@ORTMP + . D LN + . S ^TMP("ORVBEC",$J,GCNT,0)=$P(ORZ,"^",1,6)_"^"_ORTDT + K ^TMP("LRRR",$J) + Q +SURG(OROOT,ORX) ;Get list of surgeries + N I,CNT,X + S (I,CNT)=0 + F S I=$O(ORX("SURGERY",I)) Q:'I S X=$G(ORX("SURGERY",I)) D + . S CNT=CNT+1,OROOT(CNT)=X_U_X + Q +LN ;Increment counts + S GCNT=GCNT+1,CCNT=1 + Q +PATINFO(OROOT,DFN,LOC) ;Test ^TMP global output + N ORX + D GETPAT(.ORX,DFN,LOC) + I $L($G(ORX("SPECIMEN"))) S:$P(ORX("SPECIMEN"),"^") $P(ORX("SPECIMEN"),"^")=$$HL7TFM^XLFDT($P(ORX("SPECIMEN"),"^")) + D PTINFO(.OROOT,.ORX) + ;S I=0 F S I=$O(@OROOT@(I)) Q:'I W !,^(I,0) + ;K @OROOT + Q +GETALL(OROOT,DFN,LOC) ;Get all data in one call and let the GUI divide it up + N ORX,INFO,CNT,I,J,K + S OROOT=$NA(^TMP("ORVBECINFO",$J)),CNT=1 + D GETPAT(.ORX,DFN,LOC) + ;S ^TMP("ORVBECINFO",$J,CNT)="~RAWDATA",I=0 + ;F S I=$O(ORX(I)) Q:'I S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)=ORX(I) + I $L($G(ORX("SPECIMEN"))) S:$P(ORX("SPECIMEN"),"^") $P(ORX("SPECIMEN"),"^")=$$HL7TFM^XLFDT($P(ORX("SPECIMEN"),"^")) S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~SPECIMEN",CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_ORX("SPECIMEN") + I $L($G(ORX("ABORH"))) S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~ABORH",CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_ORX("ABORH") + S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~TYPE AND SCREEN",CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_$O(^ORD(101.43,"S.VBEC","TYPE & SCREEN",0)) + S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~SPECIMENS",I=0 + F S I=$O(ORX(I)) Q:'I S J="" F S J=$O(ORX(I,J)) Q:J="" I J="SPECIMEN" S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_I_"^"_ORX(I,J) + S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~TESTS",I=0 + F S I=$O(ORX(I)) Q:'I S J="" F S J=$O(ORX(I,J)) Q:J="" I J="TEST" S K=0 F S K=$O(ORX(I,J,K)) Q:'K S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_I_"^"_K_"^"_ORX(I,J,K) + S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~MSBOS",I=0 + F S I=$O(ORX(I)) Q:'I S J="" F S J=$O(ORX(I,J)) Q:J="" I J="MSBOS" S K=0 F S K=$O(ORX(I,J,K)) Q:'K S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_I_"^"_K_"^"_ORX(I,J,K),$P(^(CNT),"^",4)=+$P(ORX(I,J,K),"^",2) + S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~SURGERIES",I=0 + F S I=$O(ORX("SURGERY",I)) Q:'I S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_I_"^"_ORX("SURGERY",I) + S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~URGENCIES",I="" + F S I=$O(^ORD(101.42,"S.VBEC",I)) Q:I="" S J=0 F S J=$O(^ORD(101.42,"S.VBEC",I,J)) Q:'J S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_J_"^"_I + S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~MODIFIERS",I="" + N ORMODS D GETLST^XPAR(.ORMODS,"ALL","OR VBECS MODIFIERS","I") + F S I=$O(ORMODS(I)) Q:'I S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_ORMODS(I) + ;F I="W^Washed","I^Irradiated","L^Leuko Reduced","V^Volume Reduced","D^Divided","E^Leuko Reduced/Irradiated" S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_I + S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="~INFO",I=0 + D PTINFO(.INFO,.ORX) + F S I=$O(^TMP("ORVBEC",$J,I)) Q:'I S CNT=CNT+1,^TMP("ORVBECINFO",$J,CNT)="i"_^TMP("ORVBEC",$J,I,0) + K ^TMP("ORVBEC",$J) + Q +STATALOW(OROOT,DFN) ;Allow stat for ORES ORELSE users + S OROOT=$D(^XUSEC("ORES",DUZ))!($D(^XUSEC("ORELSE",DUZ))) + Q +COMPORD(OROOT) ;Get sequence order of Blood Components + N ORLIST,I,X + D GETLST^XPAR(.ORLIST,"ALL","OR VBECS COMPONENT ORDER") + S I=0 F S I=$O(ORLIST(I)) Q:'I S X=ORLIST(I) I $D(^ORD(101.43,$P(X,"^",2),0)) S OROOT(I)=$P(X,"^",2)_"^"_$P(^(0),"^",1)_"^"_$P(^(0),"^",1) + Q +TESTR ;Test results call + N ORX + S ORX(3)="3" ;HGB + S ORX(4)="4" ;HCT + S ORX(1)="1" ;WBC + S ORX(113)="113" ;FERRITIN + D RESULTS(.OROOT,66,.ORX) + S I=0 F S I=$O(@OROOT@(I)) Q:'I W !,^(I,0) + K @OROOT + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXVB1.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXVB1.m index fccd876c..392397a7 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXVB1.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXVB1.m @@ -1,98 +1,139 @@ -ORWDXVB1 ;slc/dcm - Order dialog utilities for Blood Bank Cont.;3/2/04 09:31 ;12/7/05 17:20 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,243**;Dec 17 1997;Build 242 - ; -PTINFO ;Format patient BB info - N GCNT,CCNT,GIOSL,GIOM,I,TYPE,ORUA,VBERROR,ABFND,LINE1,LINE2,NOABO,NOPAT,TREQFND - S (GCNT,NOPAT,NOABO)=0,CCNT=1,GIOSL=999999,GIOM=80 - S OROOT=$NA(^TMP("ORVBEC",$J)) - K ^TMP("ORVBEC",$J) - ; - I +$G(ORX("ERROR")) D ERROR^ORWDXVB2 Q - ; Patient Demographics - D LN - I '$D(ORX("PATIENT")) D Q - . D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN - . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(10,CCNT,"There is no previous record of this patient in VBECS.",.CCNT) Q - ; - S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"Name",.CCNT)_$$S^ORU4(27,CCNT,"SSN",.CCNT)_$$S^ORU4(42,CCNT,"ABO/Rh",.CCNT) - D LN - S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"----",.CCNT)_$$S^ORU4(27,CCNT,"---",.CCNT)_$$S^ORU4(42,CCNT,"------",.CCNT) D - . D LN - . S X=ORX("PATIENT"),^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,$P(X,"^",3)_", "_$P(X,"^",2),.CCNT)_$$S^ORU4(27,CCNT,$P(X,"^",4),.CCNT) - . I $P(ORX("ABORH"),"^")']"" S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(42,CCNT,"unknown",.CCNT) Q - . S X=ORX("ABORH"),^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(42,CCNT,$$STRIP^XLFSTR($P(X,"^")," ")_" "_$S($$STRIP^XLFSTR($P(X,"^",2)," ")="P":"Pos",$$STRIP^XLFSTR($P(X,"^",2)," ")="N":"Neg",1:"unknown"),.CCNT) Q - D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN - D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN - ; - ; Available Specimens - S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"Lab Specimen ID",.CCNT)_$$S^ORU4(27,CCNT,"Expiration Date",.CCNT) - D LN - S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"----------------------",.CCNT)_$$S^ORU4(27,CCNT,"---------------",.CCNT) D - . I '$D(ORX("SPECIMEN")) D LN S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT," none",.CCNT) Q - . D LN - . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,$P(ORX("SPECIMEN"),"^",2),.CCNT)_$$S^ORU4(27,CCNT,$$DATETIME^ORCHTAB($P(ORX("SPECIMEN"),"^")),.CCNT) Q - D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN - D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN - ; - ; Antibodies Identified section - S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"Antibodies Identified",.CCNT) - D LN - S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"---------------------",.CCNT) D - . I '$O(ORX("ABHIS",0)) D LN S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT," none",.CCNT) Q - . D LN - . S ABFND=0 - . S I=0 F S I=$O(ORX("ABHIS",I)) Q:I<1 D - . . S X=ORX("ABHIS",I) - . . I ABFND S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(2,CCNT,", "_$P(X,"^"),.CCNT) Q - . . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,$P(X,"^"),.CCNT),ABFND=1 - D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN - D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN - ; - ; Transfusion Requirements section - S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"Transfusion Requirements",.CCNT) - D LN - S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"------------------------",.CCNT) D - . I '$O(ORX("TRREQ",0)) D LN S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT," none",.CCNT) Q - . D LN - . S TREQFND=0 - . S I=0 F S I=$O(ORX("TRREQ",I)) Q:I<1 D - . . S X=ORX("TRREQ",I) - . . I TREQFND S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(2,CCNT,", "_X,.CCNT) Q - . . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,X,.CCNT),TREQFND=1 - D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN - D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN - ; - ; Transfusion Reactions section - S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"Transfusion Reactions",.CCNT)_$$S^ORU4(27,CCNT,"Date/Time",.CCNT) - D LN - S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"---------------------",.CCNT)_$$S^ORU4(27,CCNT,"---------",.CCNT) D - . I '$O(ORX("TRHX",0)) D LN S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT," none",.CCNT) Q - . S I=0 F S I=$O(ORX("TRHX",I)) Q:I<1 D - . . D LN - . . S X=ORX("TRHX",I),^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,$P(X,"^"),.CCNT)_$$S^ORU4(27,CCNT,$$DATETIME($P(X,"^",2)),.CCNT) - D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN - D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN - ; - ; New Units section - N INDEX,UNT,ORY,I,CNT,J,K,L,M,X - S CNT=0 - F INDEX="A","D","C","S" I $O(ORX("UNIT",INDEX,0)) D ; A:Autologous D:Directed C:Crossmatched A:Assigned - . S I=0 F S I=$O(ORX("UNIT",INDEX,I)) Q:I<1 D - .. S X=ORX("UNIT",INDEX,I),CNT=CNT+1,ORY("~"_$P(X,"^"),"~"_$P(X,"^",2),"~"_INDEX,"~"_$P(X,"^",4),CNT)=X - S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"Units Available",.CCNT) - D LN - S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"---------------",.CCNT) - D LN - S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"Unit ID",.CCNT)_$$S^ORU4(13,CCNT,"Component",.CCNT)_$$S^ORU4(27,CCNT,"Status",.CCNT)_$$S^ORU4(42,CCNT,"Exp Date",.CCNT)_$$S^ORU4(58,CCNT,"Division",.CCNT) - D LN - S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"-------",.CCNT)_$$S^ORU4(13,CCNT,"---------",.CCNT)_$$S^ORU4(27,CCNT,"------",.CCNT)_$$S^ORU4(42,CCNT,"--------",.CCNT)_$$S^ORU4(58,CCNT,"--------",.CCNT) - S I="" F S I=$O(ORY(I)) Q:I="" S J="" F S J=$O(ORY(I,J)) Q:J="" S K="" F S K=$O(ORY(I,J,K)) Q:K="" S L="" F S L=$O(ORY(I,J,K,L)) Q:L="" S M="" F S M=$O(ORY(I,J,K,L,M)) Q:M="" D LN D - . S X=ORY(I,J,K,L,M),INDEX=$E(K,2),UNT=$S(INDEX="A":"Autologous",INDEX="D":"Directed",INDEX="C":"Crossmatched",INDEX="S":"Assigned",1:"Unknown") - . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,$P(X,"^"),.CCNT)_$$S^ORU4(13,CCNT,$P(X,"^",2),.CCNT)_$$S^ORU4(27,CCNT,UNT,.CCNT)_$$S^ORU4(42,CCNT,$$DATETIME($P(X,"^",4)),.CCNT)_$$S^ORU4(58,CCNT,$P(X,"^",3),.CCNT) - Q -LN ;Increment counts - S GCNT=GCNT+1,CCNT=1 - Q -DATETIME(X) ; -- Return external form of YYYYMMDDHHNNSS date - N Y S Y=$$HL7TFM^XLFDT(X),Y=$$DATETIME^ORCHTAB(Y) - Q Y +ORWDXVB1 ;slc/dcm - Order dialog utilities for Blood Bank Cont.;3/2/04 09:31 ;12/7/05 17:20 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215**;Dec 17 1997 + ; +PTINFO ;Format patient BB info + N GCNT,CCNT,GIOSL,GIOM,I,TYPE,ORUA,VBERROR,ABFND,LINE1,LINE2,NOABO,NOPAT,TREQFND + S (GCNT,NOPAT,NOABO)=0,CCNT=1,GIOSL=999999,GIOM=80 + S OROOT=$NA(^TMP("ORVBEC",$J)) + K ^TMP("ORVBEC",$J) + ; + I +$G(ORX("ERROR")) D ERROR^ORWDXVB2 Q + ; Patient Demographics + D LN + I '$D(ORX("PATIENT")) D Q + . D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN + . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(10,CCNT,"There is no previous record of this patient in VBECS.",.CCNT) Q + ; + S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"Name",.CCNT)_$$S^ORU4(27,CCNT,"SSN",.CCNT)_$$S^ORU4(42,CCNT,"ABO/Rh",.CCNT) + D LN + S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"----",.CCNT)_$$S^ORU4(27,CCNT,"---",.CCNT)_$$S^ORU4(42,CCNT,"------",.CCNT) D + . D LN + . S X=ORX("PATIENT"),^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,$P(X,"^",3)_", "_$P(X,"^",2),.CCNT)_$$S^ORU4(27,CCNT,$P(X,"^",4),.CCNT) + . I $P(ORX("ABORH"),"^")']"" S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(42,CCNT,"unknown",.CCNT) Q + . S X=ORX("ABORH"),^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(42,CCNT,$$STRIP^XLFSTR($P(X,"^")," ")_" "_$S($$STRIP^XLFSTR($P(X,"^",2)," ")="P":"Pos",$$STRIP^XLFSTR($P(X,"^",2)," ")="N":"Neg",1:"unknown"),.CCNT) Q + D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN + D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN + ; + ; Available Specimens + S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"Available Specimen UID",.CCNT)_$$S^ORU4(27,CCNT,"Expiration Date",.CCNT) + D LN + S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"----------------------",.CCNT)_$$S^ORU4(27,CCNT,"---------------",.CCNT) D + . I '$D(ORX("SPECIMEN")) D LN S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT," none",.CCNT) Q + . D LN + . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,$P(ORX("SPECIMEN"),"^",2),.CCNT)_$$S^ORU4(27,CCNT,$$DATETIME^ORCHTAB($P(ORX("SPECIMEN"),"^")),.CCNT) Q + D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN + D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN + ; + ; Antibodies Identified section + S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"Antibodies Identified",.CCNT) + D LN + S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"---------------------",.CCNT) D + . I '$O(ORX("ABHIS",0)) D LN S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT," none",.CCNT) Q + . D LN + . S ABFND=0 + . S I=0 F S I=$O(ORX("ABHIS",I)) Q:I<1 D + . . S X=ORX("ABHIS",I) + . . I ABFND S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(2,CCNT,", "_$P(X,"^"),.CCNT) Q + . . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,$P(X,"^"),.CCNT),ABFND=1 + D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN + D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN + ; + ; Transfusion Requirements section + S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"Transfusion Requirements",.CCNT) + D LN + S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"------------------------",.CCNT) D + . I '$O(ORX("TRREQ",0)) D LN S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT," none",.CCNT) Q + . D LN + . S TREQFND=0 + . S I=0 F S I=$O(ORX("TRREQ",I)) Q:I<1 D + . . S X=ORX("TRREQ",I) + . . I TREQFND S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(2,CCNT,", "_X,.CCNT) Q + . . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,X,.CCNT),TREQFND=1 + D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN + D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN + ; + ; Transfusion Reactions section + S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"Transfusion Reactions",.CCNT)_$$S^ORU4(27,CCNT,"Date/Time",.CCNT) + D LN + S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"---------------------",.CCNT)_$$S^ORU4(27,CCNT,"---------",.CCNT) D + . I '$O(ORX("TRHX",0)) D LN S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT," none",.CCNT) Q + . S I=0 F S I=$O(ORX("TRHX",I)) Q:I<1 D + . . D LN + . . S X=ORX("TRHX",I),^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,$P(X,"^"),.CCNT)_$$S^ORU4(27,CCNT,$$DATETIME($P(X,"^",2)),.CCNT) + D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN + D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN + ; + ; Units section + S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"Units Available",.CCNT) + D LN + S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(1,CCNT,"---------------",.CCNT) + D LN + ; Autologous Units + S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"Autologous",.CCNT) + D LN + I $O(ORX("UNIT","A",0)) D + . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT,"Unit ID",.CCNT)_$$S^ORU4(13,CCNT,"Component",.CCNT)_$$S^ORU4(27,CCNT,"Expiration Date Division",.CCNT) + . D LN + . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT,"-------",.CCNT)_$$S^ORU4(13,CCNT,"---------",.CCNT)_$$S^ORU4(27,CCNT,"--------------- --------",.CCNT) D + . . S I=0 F S I=$O(ORX("UNIT","A",I)) Q:I<1 D + . . . D LN + . . . S X=ORX("UNIT","A",I),^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT,$P(X,"^"),.CCNT)_$$S^ORU4(13,CCNT,$P(X,"^",2),.CCNT)_$$S^ORU4(27,CCNT,$$DATETIME($P(X,"^",4)),.CCNT)_$$S^ORU4(44,CCNT,$P(X,"^",3),.CCNT) + E S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT," none",.CCNT) + ; + ; Directed Units + D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN + S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"Directed",.CCNT) + D LN + I $O(ORX("UNIT","D",0)) D + . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT,"Unit ID",.CCNT)_$$S^ORU4(13,CCNT,"Component",.CCNT)_$$S^ORU4(27,CCNT,"Expiration Date Division",.CCNT) + . D LN + . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT,"-------",.CCNT)_$$S^ORU4(13,CCNT,"---------",.CCNT)_$$S^ORU4(27,CCNT,"--------------- --------",.CCNT) D + . . S I=0 F S I=$O(ORX("UNIT","D",I)) Q:I<1 D + . . . D LN + . . . S X=ORX("UNIT","D",I),^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT,$P(X,"^"),.CCNT)_$$S^ORU4(13,CCNT,$P(X,"^",2),.CCNT)_$$S^ORU4(27,CCNT,$$DATETIME($P(X,"^",4)),.CCNT)_$$S^ORU4(44,CCNT,$P(X,"^",3),.CCNT) + E S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT," none",.CCNT) + ; + ; Crossmatched Units + D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN + S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"Crossmatched",.CCNT) + D LN + I $O(ORX("UNIT","C",0)) D + . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT,"Unit ID",.CCNT)_$$S^ORU4(13,CCNT,"Component",.CCNT)_$$S^ORU4(27,CCNT,"Available Until Division",.CCNT) + . D LN + . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT,"-------",.CCNT)_$$S^ORU4(13,CCNT,"---------",.CCNT)_$$S^ORU4(27,CCNT,"--------------- --------",.CCNT) D + . . S I=0 F S I=$O(ORX("UNIT","C",I)) Q:I<1 D + . . . D LN + . . . S X=ORX("UNIT","C",I),^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT,$P(X,"^"),.CCNT)_$$S^ORU4(13,CCNT,$P(X,"^",2),.CCNT)_$$S^ORU4(27,CCNT,$$DATETIME($P(X,"^",4)),.CCNT)_$$S^ORU4(44,CCNT,$P(X,"^",3),.CCNT) + E S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT," none",.CCNT) + ; + ; Assigned Units + D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN + S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"Assigned",.CCNT) + D LN + I $O(ORX("UNIT","S",0)) D + . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT,"Unit ID",.CCNT)_$$S^ORU4(13,CCNT,"Component",.CCNT)_$$S^ORU4(27,CCNT,"Available Until Division",.CCNT) + . D LN + . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT,"-------",.CCNT)_$$S^ORU4(13,CCNT,"---------",.CCNT)_$$S^ORU4(27,CCNT,"--------------- --------",.CCNT) D + . . S I=0 F S I=$O(ORX("UNIT","S",I)) Q:I<1 D + . . . D LN + . . . S X=ORX("UNIT","S",I),^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT,$P(X,"^"),.CCNT)_$$S^ORU4(13,CCNT,$P(X,"^",2),.CCNT)_$$S^ORU4(27,CCNT,$$DATETIME($P(X,"^",4)),.CCNT)_$$S^ORU4(44,CCNT,$P(X,"^",3),.CCNT) + E S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(3,CCNT," none",.CCNT) + D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN + ; + Q +LN ;Increment counts + S GCNT=GCNT+1,CCNT=1 + Q +DATETIME(X) ; -- Return external form of YYYYMMDDHHNNSS date + N Y S Y=$$HL7TFM^XLFDT(X),Y=$$DATETIME^ORCHTAB(Y) + Q Y diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXVB2.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXVB2.m index 93ee4a2e..a001d74c 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXVB2.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXVB2.m @@ -1,73 +1,45 @@ -ORWDXVB2 ;slc/dcm - Order dialog utilities for Blood Bank Cont.;3/2/04 09:31 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,243**;Dec 17 1997;Build 242 - ; -ERROR ;Process error - D LN - S VBERROR=$P(ORX("ERROR"),"^",2) - S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"******************************************************************",.CCNT) D LN - S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* *",.CCNT) D LN - S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* WARNING! *",.CCNT) D LN - S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* *",.CCNT) D LN - S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* An Error occurred attempting to *",.CCNT) D LN - S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* retrieve Blood Bank order data. *",.CCNT) D LN - S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* *",.CCNT) D LN - S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* This order cannot be completed at this time. *",.CCNT) D LN - S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* Revert to local downtime procedures to continue *",.CCNT) D LN - S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* order or retry this option at a later time. *",.CCNT) D LN - S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* *",.CCNT) D LN - S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* Contact the Blood Bank System Administrator *",.CCNT) D LN - S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* *",.CCNT) D LN - S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"******************************************************************",.CCNT) D LN - S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* *",.CCNT) D LN - S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* Error Message *",.CCNT) D LN - S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* *",.CCNT) D LN - S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*",.CCNT) - I $L(VBERROR)<68 D - . S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(70-$L(VBERROR)/2,CCNT,VBERROR,.CCNT) - . S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(67,CCNT,"*",.CCNT) D LN - I $L(VBERROR)>68 D - . I $L(VBERROR)>136 S VBERROR=$E(VBERROR,1,136)_"..." - . N L1 S L1=$E(VBERROR,1,$L(VBERROR)/2) - . I $E(L1,$L(L1))'=" " D - . . S LINE1=$E(L1,1,($L(L1)-($L($P(L1," ",$L(L1," ")))))),LINE2=$E(VBERROR,$L(LINE1)+1,$L(VBERROR)) - . E S LINE1=$E(L1),LINE2=$E(VBERROR,$L(LINE1)+1,$L(VBERROR)) - . S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(70-$L(LINE1)/2,CCNT,LINE1,.CCNT) - . S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(67,CCNT,"*",.CCNT) D LN - . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*",.CCNT) - . S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(70-$L(LINE2)/2,CCNT,LINE2,.CCNT) - . S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(67,CCNT,"*",.CCNT) D LN - S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* *",.CCNT) D LN - S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"******************************************************************",.CCNT) D LN - D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN - Q -PULL(OROOT,ORVP,ITEMID,SDATE,EDATE) ;Get list of orders matching ITEM - ;ITEM = Orderable Item ID e.g. "1;99VBC" for Type and Screen - ;SDATE = Start Date for search - ;EDATE = End Date for search - Q:'$G(ORVP) - N ORTNSB - I $P(ORVP,";",2)="" S ORVP=ORVP_";DPT(" - S ORTNSB=$$GET^XPAR("ALL","ORWDXVB VBECS TNS CHECK",1,"I") - S:'ORTNSB ORTNSB=3 ;Use Default of DT-3 or Parameter [ORWDXVB VBECS TNS CHECK] if no start date passed in - S ITEMID=$S($D(ITEMID):ITEMID,1:"1;99VBC") ;Default to Type and Screen if nothing passed in - S SDATE=$S($D(SDATE):SDATE,1:$$FMADD^XLFDT(DT-ORTNSB)) - S EDATE=$S($D(EDATE):EDATE,1:DT) ;Default to DT if no End date passed in - N ORDG,FLG,ORLIST,ORX0,ORX3,ORSTAT,ORIFN,I,X,J,CNT,ITEM,ITEMNM,ORLOC,DIV - S ITEM=+$O(^ORD(101.43,"ID",ITEMID,0)),ITEMNM=$P($G(^ORD(101.43,ITEM,0)),"^") - S CNT=0,ORDG=$O(^ORD(100.98,"B","VBEC",0)) Q:'ORDG - F FLG=4,23,19 D ;Get completed, active/pending, unreleased - . K ^TMP("ORR",$J) - . D EN^ORQ1(ORVP,ORDG,FLG,0,SDATE,EDATE) - . I '$O(^TMP("ORR",$J,ORLIST,0)) Q - . S I=0 - . F S I=$O(^TMP("ORR",$J,ORLIST,I)) Q:'I S X=^(I) D - .. S ORIFN=+X,J=0,DIV="" - .. Q:'$D(^OR(100,ORIFN,0)) S ORX0=^(0),ORX3=^(3) - .. S ORSTAT=$S($D(^ORD(100.01,+$P(ORX3,"^",3),0)):$P(^(0),"^"),1:""),ORLOC=$S($L($P($G(^SC(+$P(ORX0,"^",10),0)),"^")):$P(^(0),"^"),1:"UNKNOWN") - .. I +$P(ORX0,"^",10) S DIV=$P($G(^SC(+$P(ORX0,"^",10),0)),U,15),DIV=$S(DIV:$P($$SITE^VASITE(DT,DIV),"^",2),1:"") - .. F S J=$O(^OR(100,ORIFN,4.5,"ID","ORDERABLE",J)) Q:'J I +$G(^OR(100,ORIFN,4.5,J,1))=ITEM D - ... S CNT=CNT+1,OROOT(CNT)="Duplicate order: "_ITEMNM_" entered "_$$FMTE^XLFDT($P(ORX0,"^",7))_" Div/Loc: "_DIV_":"_ORLOC_" ["_ORSTAT_"]" - Q -LN ;Increment counts - S GCNT=GCNT+1,CCNT=1 - Q +ORWDXVB2 ;slc/dcm - Order dialog utilities for Blood Bank Cont.;3/2/04 09:31 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215**;Dec 17 1997 + ; +ERROR ;Process error + D LN + S VBERROR=$P(ORX("ERROR"),"^",2) + S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"******************************************************************",.CCNT) D LN + S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* *",.CCNT) D LN + S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* WARNING! *",.CCNT) D LN + S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* *",.CCNT) D LN + S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* An Error occurred attempting to *",.CCNT) D LN + S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* retrieve Blood Bank order data. *",.CCNT) D LN + S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* *",.CCNT) D LN + S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* This order cannot be completed at this time. *",.CCNT) D LN + S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* Revert to local downtime procedures to continue *",.CCNT) D LN + S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* order or retry this option at a later time. *",.CCNT) D LN + S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* *",.CCNT) D LN + S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* Contact the Blood Bank System Administrator *",.CCNT) D LN + S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* *",.CCNT) D LN + S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"******************************************************************",.CCNT) D LN + S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* *",.CCNT) D LN + S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* Error Message *",.CCNT) D LN + S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* *",.CCNT) D LN + S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*",.CCNT) + I $L(VBERROR)<68 D + . S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(70-$L(VBERROR)/2,CCNT,VBERROR,.CCNT) + . S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(67,CCNT,"*",.CCNT) D LN + I $L(VBERROR)>68 D + . I $L(VBERROR)>136 S VBERROR=$E(VBERROR,1,136)_"..." + . N L1 S L1=$E(VBERROR,1,$L(VBERROR)/2) + . I $E(L1,$L(L1))'=" " D + . . S LINE1=$E(L1,1,($L(L1)-($L($P(L1," ",$L(L1," ")))))),LINE2=$E(VBERROR,$L(LINE1)+1,$L(VBERROR)) + . E S LINE1=$E(L1),LINE2=$E(VBERROR,$L(LINE1)+1,$L(VBERROR)) + . S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(70-$L(LINE1)/2,CCNT,LINE1,.CCNT) + . S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(67,CCNT,"*",.CCNT) D LN + . S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"*",.CCNT) + . S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(70-$L(LINE2)/2,CCNT,LINE2,.CCNT) + . S ^TMP("ORVBEC",$J,GCNT,0)=^TMP("ORVBEC",$J,GCNT,0)_$$S^ORU4(67,CCNT,"*",.CCNT) D LN + S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"* *",.CCNT) D LN + S ^TMP("ORVBEC",$J,GCNT,0)=$$S^ORU4(2,CCNT,"******************************************************************",.CCNT) D LN + D LINE^ORU4("^TMP(""ORVBEC"",$J)",GIOM),LN + Q +LN ;Increment counts + S GCNT=GCNT+1,CCNT=1 + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPI.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPI.m index b3bf21ec..a13e6dae 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPI.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPI.m @@ -1,176 +1,157 @@ -ORWGAPI ; SLC/STAFF - Graph API ;12/21/05 08:14 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,243**;Dec 17, 1997;Build 242 - ; -ALLITEMS(ITEMS,DFN) ; API - return all items of data on patient (procedures, tests, codes,..) - N CNT,SUB,TMP,TYPE - K ^TMP("ORWGAPI",$J) - S DFN=+$G(DFN) I 'DFN Q - D TYPES("ORWGAPI",DFN) - D RETURN^ORWGAPIW(.TMP,.ITEMS) - S CNT=0 - S SUB="" - F S SUB=$O(^TMP("ORWGAPI",$J,SUB)) Q:SUB="" D - . S TYPE=$P(^TMP("ORWGAPI",$J,SUB),U) - . D ITEMS^ORWGAPIR(.ITEMS,DFN,TYPE,0,,,.CNT,TMP) - D SETLAST^ORWGTASK(DFN) - K ^TMP("ORWGAPI",$J) - Q - ; -ALLVIEWS(DATA,VIEW,USER) ; API - get all graph views - D ALLVIEWS^ORWGAPIP(.DATA,+$G(VIEW),+$G(USER)) - Q - ; -CLASS(DATA,TYPE) ; API - get classification - I TYPE=50.605 D DRUGC^ORWGAPIC(.DATA) - I TYPE=68 D ACC^ORWGAPIC(.DATA) - I TYPE=8925.1 D TIUTITLE^ORWGAPIA(.DATA) - I TYPE=100.98 D OITEM^ORWGAPIA(.DATA) - Q - ; -DATEDATA(DATA,OLDEST,NEWEST,TYPEITEM,DFN) ; API - return all data for an item on patient for date range - N CNT,ITEM,SUB,TMP,TYPE - S DFN=+$G(DFN) I 'DFN Q - S OLDEST=+$G(OLDEST) - S NEWEST=+$G(NEWEST,$$NOW^ORWGAPIX) - S TYPEITEM=$G(TYPEITEM) I TYPEITEM'[U Q - I 'OLDEST D ITEMDATA(.DATA,TYPEITEM,NEWEST,DFN,OLDEST) Q - I OLDEST 1 if user can edit public settings and views - Q $$PUBLIC^ORWGAPIP(USER) - ; -RPTPARAM(IEN) ; API - $$(ien) -> PARAM1^PARAM2 for graph report else "" - Q $$RPTPARAM^ORWGAPIP(IEN) - ; -SETPREF(DATA,VAL,PUBLIC) ; API - set a graph setting - D SETPREF^ORWGAPIP(.DATA,$G(VAL),$G(PUBLIC)) - Q - ; -SETSIZE(DATA,VAL) ; API - set graph positions and settings - D SETSIZE^ORWGAPIP(.DATA,.VAL) - Q - ; -SETVIEWS(DATA,NAME,PUBLIC,VAL) ; API - set a graph view - D SETVIEWS^ORWGAPIP(.DATA,$G(NAME),$G(PUBLIC),.VAL) - Q - ; -TAX(DATA,ALL,REMTAX) ; API - get reminder taxonomies - D TAX^ORWGAPID(.DATA,+$G(ALL),.REMTAX) - Q - ; -TESTING(DATA) ; API - return test data - D TESTING^ORWGTEST(.DATA) - Q - ; -TESTSPEC(DATA) ; API - return test/spec info on all lab tests - D TESTSPEC^ORWGAPIC(.DATA) - Q - ; -TYPES(TYPES,DFN,SUB) ; API - return all types of data on patient (if no dfn, return all) - N TMP - S DFN=+$G(DFN) - S SUB=+$G(SUB) - D RETURN^ORWGAPIW(.TMP,.TYPES) - D TYPES^ORWGAPIT(.TYPES,DFN,SUB,TMP) - Q +ORWGAPI ; SLC/STAFF - Graph API ;12/21/05 08:14 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215**;Dec 17, 1997 + ; +ALLITEMS(ITEMS,DFN) ; API - return all items of data on patient (procedures, tests, codes,..) + N CNT,SUB,TMP,TYPE + K ^TMP("ORWGAPI",$J) + S DFN=+$G(DFN) I 'DFN Q + D TYPES("ORWGAPI",DFN) + D RETURN^ORWGAPIU(.TMP,.ITEMS) + S CNT=0 + S SUB="" + F S SUB=$O(^TMP("ORWGAPI",$J,SUB)) Q:SUB="" D + . S TYPE=$P(^TMP("ORWGAPI",$J,SUB),U) + . D ITEMS^ORWGAPIR(.ITEMS,DFN,TYPE,0,,,.CNT,TMP) + K ^TMP("ORWGAPI",$J) + Q + ; +CLASS(DATA,TYPE) ; API - get classification + I TYPE=50.605 D DRUGC^ORWGAPIA(.DATA) + I TYPE=68 D ACC^ORWGAPIA(.DATA) + I TYPE=8925.1 D TIUTITLE^ORWGAPIA(.DATA) + I TYPE=100.98 D OITEM^ORWGAPIA(.DATA) + Q + ; +DATEITEM(ITEMS,OLDEST,NEWEST,TYPE,DFN) ; API - return all file items on patient for date range + N CNT,SUB,TMP + K ^TMP("ORWGAPI",$J) + S DFN=+$G(DFN) I 'DFN Q + S OLDEST=+$G(OLDEST),NEWEST=+$G(NEWEST),TYPE=$G(TYPE) + I $L(TYPE) S ^TMP("ORWGAPI",$J,1)=TYPE + I '$L(TYPE) D TYPES("ORWGAPI",DFN) + D RETURN^ORWGAPIU(.TMP,.ITEMS) + S CNT=0 + S SUB="" + F S SUB=$O(^TMP("ORWGAPI",$J,SUB)) Q:SUB="" D + . S TYPE=$P(^TMP("ORWGAPI",$J,SUB),U) + . D ITEMS^ORWGAPIR(.ITEMS,DFN,TYPE,6,OLDEST,NEWEST,.CNT,TMP) + K ^TMP("ORWGAPI",$J) + Q + ; +DELVIEWS(DATA,NAME,PUBLIC) ; API - delete a graph view + D DELVIEWS^ORWGAPIP(.DATA,$G(NAME),$G(PUBLIC)) + Q + ; +DETAIL(DATA,DFN,DATE1,DATE2,VAL,COMP) ; API - get all reports for types of data from items and date range + D DETAIL^ORWGAPID("ORWGRPC",DFN,DATE1,DATE2,.VAL) + S DATA=$NA(^TMP("ORWGRPC",$J)) + Q + ; +DETAILS(DATA,DFN,DATE1,DATE2,TYPE,COMP) ; API - get report for type of data for a date or date range + D DETAILS^ORWGAPID("ORWGRPC",DFN,DATE1,DATE2,TYPE) + S DATA=$NA(^TMP("ORWGRPC",$J)) + Q + ; +GETDATES(DATA,REPORTID) ; API - get graph date ranges + N DAT,TMP K DAT + S REPORTID=$G(REPORTID) + D RETURN^ORWGAPIU(.TMP,.DATA) + S DAT(1)="S^Date Range..." + S DAT(2)="1^Today" + S DAT(3)="2^One Week" + S DAT(4)="3^Two Weeks" + S DAT(5)="4^One Month" + S DAT(6)="5^Six Months" + S DAT(7)="6^One Year" + S DAT(8)="7^Two Years" + S DAT(9)="8^All Results" + D DATES^ORWGAPIP(.DAT,REPORTID) + I TMP M ^TMP(DATA,$J)=DAT + I 'TMP M DATA=DAT + Q + ; +GETPREF(DATA) ; API - get graph settings + D GETPREF^ORWGAPIP(.DATA) + Q + ; +GETSIZE(DATA) ; API - get graph positions and sizes + D GETSIZE^ORWGAPIP(.DATA) + Q + ; +GETVIEWS(DATA,ALL,PUBLIC,EXT) ; API - get graph views + D GETVIEWS^ORWGAPIP(.DATA,$G(ALL),$G(PUBLIC),$G(EXT)) + Q + ; +ITEMDATA(DATA,ITEM,START,DFN) ; API - return data of an item on patient (glucose results) + N CNT,FILE,TMP + S DFN=+$G(DFN) I 'DFN Q + S ITEM=$G(ITEM) I ITEM'[U Q + S START=$G(START,$$NOW^ORWGAPIX) + D RETURN^ORWGAPIU(.TMP,.DATA) + S FILE=$P(ITEM,U) + S ITEM=$P(ITEM,U,2) + S CNT=0 + D DATA^ORWGAPIR(.DATA,ITEM,FILE,START,DFN,.CNT,TMP) + Q + ; +ITEMS(ITEMS,DFN,TYPE) ; API - return items of a type of data on patient (lab tests) + N CNT,TMP + S DFN=+$G(DFN) I 'DFN Q + S TYPE=$G(TYPE) I '$L(TYPE) Q + D RETURN^ORWGAPIU(.TMP,.ITEMS) + S CNT=0 + D ITEMS^ORWGAPIR(.ITEMS,DFN,TYPE,3,,,.CNT,TMP) + Q + ; +LOOKUP(VAL,FILE,FROM,DIR) ; API - get item names for long lookup + N REF,SCREEN,XREF + D FILE^ORWGAPIU($G(FILE),.REF,.XREF,.SCREEN) + I '$L(REF) Q + D GENERIC^ORWGAPIU(.VAL,.FROM,DIR,FILE,REF,XREF,SCREEN) + Q + ; +PUBLIC(USER) ; API - $$(user) -> 1 if user can edit public settings and views + Q $$PUBLIC^ORWGAPIP(USER) + ; +RPTPARAM(IEN) ; API - $$(ien) -> PARAM1^PARAM2 for graph report else "" + Q $$RPTPARAM^ORWGAPIP(IEN) + ; +SETPREF(DATA,VAL,PUBLIC) ; API - set a graph setting + D SETPREF^ORWGAPIP(.DATA,$G(VAL),$G(PUBLIC)) + Q + ; +SETSIZE(DATA,VAL) ; API - set graph positions and settings + D SETSIZE^ORWGAPIP(.DATA,.VAL) + Q + ; +SETVIEWS(DATA,NAME,PUBLIC,VAL) ; API - set a graph view + D SETVIEWS^ORWGAPIP(.DATA,$G(NAME),$G(PUBLIC),.VAL) + Q + ; +TAX(DATA,ALL,REMTAX) ; API - get reminder taxonomies + D TAX^ORWGAPID(.DATA,+$G(ALL),.REMTAX) + Q + ; +TESTSPEC(DATA) ; API - return test/spec info on all lab tests + N CNT,LINE,TEST,TMP,SPEC + D RETURN^ORWGAPIU(.TMP,.DATA) + S CNT=0 + S TEST=0 + F S TEST=$O(^LAB(60,TEST)) Q:TEST<1 D + . S SPEC=0 + . F S SPEC=$O(^LAB(60,TEST,1,SPEC)) Q:SPEC<1 D + .. S CNT=CNT+1 + .. S LINE=TEST_U_$G(^LAB(60,TEST,1,SPEC,0)) + .. I $P(LINE,U,3)[$C(34) S $P(LINE,U,3)=$$TRIM^ORWGAPIX($P(LINE,U,3),"LR",$C(34)) + .. I $P(LINE,U,4)[$C(34) S $P(LINE,U,4)=$$TRIM^ORWGAPIX($P(LINE,U,4),"LR",$C(34)) + .. I TMP S ^TMP(DATA,$J,CNT)=LINE Q + .. S DATA(CNT)=LINE + Q + ; +TYPES(TYPES,DFN,SUB) ; API - return all types of data on patient (if no dfn, return all) + N TMP + S DFN=+$G(DFN) + S SUB=+$G(SUB) + D RETURN^ORWGAPIU(.TMP,.TYPES) + D TYPES^ORWGAPIT(.TYPES,DFN,SUB,TMP) + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPI1.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPI1.m index d2756ee1..63443a66 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPI1.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPI1.m @@ -1,161 +1,267 @@ -ORWGAPI1 ; SLC/STAFF - Graph Items ;12/21/05 08:15 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,243**;Dec 17, 1997;Build 242 - ; -AA(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR - ; FMT,OLDEST,NEWEST not used - N ITEM,FILE,NUM,REF,RESULT - K ^TMP("ORWGRPC DC",$J) - S ITEM="" - F S ITEM=$O(^PXRMINDX(63,"PI",DFN,ITEM)) Q:ITEM="" D - . I $E(ITEM)="A" Q - . I $E(ITEM)="M" Q - . S RESULT=$$AALAB^ORWGAPIC(ITEM) - . I RESULT="" Q - . S RESULT="68^"_RESULT - . S ^TMP("ORWGRPC DC",$J,RESULT)="" - S RESULT="" - F S RESULT=$O(^TMP("ORWGRPC DC",$J,RESULT)) Q:RESULT="" S CNT=CNT+1 D - . D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT) - K ^TMP("ORWGRPC DC",$J) - Q - ; -AP(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR - N DATE,ITEM,OK,RESULT - S ITEM="A" - F S ITEM=$O(^PXRMINDX(63,"PI",DFN,ITEM)) Q:ITEM="" Q:ITEM]"AZ" D - . S OK=0 - . I FMT=6 D - .. S DATE=OLDEST - .. F S DATE=$O(^PXRMINDX(63,"PI",DFN,ITEM,DATE)) Q:DATE="" Q:DATE>NEWEST D Q:OK - ... S CNT=CNT+1 - ... S OK=1 - ... S RESULT="63AP"_U_ITEM - . I FMT=3 D - .. S DATE=$O(^PXRMINDX(63,"PI",DFN,ITEM,""),-1) - .. I 'DATE Q - .. S OK=1 - .. S CNT=CNT+1 - .. S RESULT="63AP^"_ITEM_"^^"_$$ITEMPRFX^ORWGAPIU(ITEM)_": "_$$EVALUE^ORWGAPIU(ITEM,63,.01)_"^^"_DATE - . I FMT=0 D - .. S OK=1 - .. S CNT=CNT+1 - .. S RESULT="63AP^"_ITEM_U_$$ITEMPRFX^ORWGAPIU(ITEM)_": "_$$EVALUE^ORWGAPIU(ITEM,63,.01) - . I OK D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT) - Q - ; -LAB(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR - N DATE,ITEM,OK,RESULT - S ITEM=0 - F S ITEM=$O(^PXRMINDX(63,"PI",DFN,ITEM)) Q:ITEM<1 D - . S OK=0 - . I FMT=6 D - .. S DATE=OLDEST - .. F S DATE=$O(^PXRMINDX(63,"PI",DFN,ITEM,DATE)) Q:DATE="" Q:DATE>NEWEST D Q:OK - ... S CNT=CNT+1 - ... S OK=1 - ... S RESULT=63_U_ITEM - . I FMT=3 D - .. S DATE=$O(^PXRMINDX(63,"PI",DFN,ITEM,""),-1) - .. I 'DATE Q - .. S CNT=CNT+1 - .. S OK=1 - .. S RESULT=63_U_ITEM_"^^"_$$EVALUE^ORWGAPIU(ITEM,63,.01)_"^^"_DATE - . I FMT=0 D - .. S CNT=CNT+1 - .. S OK=1 - .. S RESULT=63_U_ITEM_U_$$EVALUE^ORWGAPIU(ITEM,63,.01) - . I OK D - .. S RESULT=RESULT_U_$$AALAB^ORWGAPIC(ITEM) - .. D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT) - Q - ; -MI(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR - N DATE,ITEM,OK,RESULT - S ITEM="M" - F S ITEM=$O(^PXRMINDX(63,"PI",DFN,ITEM)) Q:ITEM="" Q:ITEM]"MZ" D - . S OK=0 - . I FMT=6 D - .. S DATE=OLDEST - .. F S DATE=$O(^PXRMINDX(63,"PI",DFN,ITEM,DATE)) Q:DATE="" Q:DATE>NEWEST D Q:OK - ... S CNT=CNT+1 - ... S OK=1 - ... S RESULT="63MI"_U_ITEM - . I FMT=3 D - .. S DATE=$O(^PXRMINDX(63,"PI",DFN,ITEM,""),-1) - .. I 'DATE Q - .. S CNT=CNT+1 - .. S OK=1 - .. S RESULT="63MI^"_ITEM_"^^"_$$ITEMPRFX^ORWGAPIU(ITEM)_": "_$$EVALUE^ORWGAPIU(ITEM,63,.01)_"^^"_DATE - . I FMT=0 D - .. S CNT=CNT+1 - .. S OK=1 - .. S RESULT="63MI^"_ITEM_U_$$ITEMPRFX^ORWGAPIU(ITEM)_": "_$$EVALUE^ORWGAPIU(ITEM,63,.01) - . I OK D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT) - Q - ; -MED(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR - D MED1^ORWGAPIE(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,.TMP) - Q - ; -NOTES(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR - N DATE,DOC,DOCCLASS,DOCIEN,DOCTYPE,DUMMY,RESULT,RESULTS,TITLE K DUMMY - K ^TMP("ORWGRPC TEMP",$J),^TMP("TIUR",$J) - S CNT=$G(CNT) - I FMT=6 D - . F DOCTYPE="P","D","C" D - .. S DOCCLASS=$$DOCCLASS^ORWGAPIA(DOCTYPE) - .. K ^TMP("TIUR",$J) - .. D TIU^ORWGAPIA(.DUMMY,DOCCLASS,5,DFN,$G(OLDEST),$G(NEWEST)) - .. S DOC=0 - .. F S DOC=$O(^TMP("TIUR",$J,DOC)) Q:DOC<1 D - ... S RESULTS=^TMP("TIUR",$J,DOC) - ... S TITLE=$P(RESULTS,U,2) - ... S DATE=$P(RESULTS,U,3) - ... I '$L(TITLE) Q - ... S ^TMP("ORWGRPC TEMP",$J,TITLE,DATE)=RESULTS - I FMT'=6 D - . F DOCTYPE="P","D","C" D - .. S DOCCLASS=$$DOCCLASS^ORWGAPIA(DOCTYPE) - .. K ^TMP("TIUR",$J) - .. D TIU^ORWGAPIA(.DUMMY,DOCCLASS,5,DFN) - .. S DOC=0 - .. F S DOC=$O(^TMP("TIUR",$J,DOC)) Q:DOC<1 D - ... S RESULTS=^TMP("TIUR",$J,DOC) - ... S TITLE=$P(RESULTS,U,2) - ... S DATE=$P(RESULTS,U,3) - ... I '$L(TITLE) Q - ... S ^TMP("ORWGRPC TEMP",$J,TITLE,DATE)=RESULTS - S TITLE="" - F S TITLE=$O(^TMP("ORWGRPC TEMP",$J,TITLE)) Q:TITLE="" D - . S CNT=CNT+1 - . I FMT=6 S RESULT=8925_U_TITLE - . I FMT=3 D - .. S DATE=+$O(^TMP("ORWGRPC TEMP",$J,TITLE,""),-1) - .. S DOCIEN=+$G(^TMP("ORWGRPC TEMP",$J,TITLE,DATE)) - .. S RESULT=8925_U_TITLE_"^^"_TITLE_"^^" - .. S RESULT=RESULT_DATE - .. S RESULT=RESULT_U_$$TITLE^ORWGAPIA(DOCIEN) - . I FMT=0 S RESULT=8925_U_TITLE_U_TITLE - . S RESULT=$$UP^ORWGAPIX(RESULT) - . D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT) - K ^TMP("ORWGRPC TEMP",$J),^TMP("TIUR",$J) - Q - ; -TITLE(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR - ; FMT,OLDEST,NEWEST not used - N ITEM,FILE,NUM,REF,RESULT - K ^TMP("ORWGRPC DC",$J) - S ITEM="" - F S ITEM=$O(^PXRMINDX(63,"PI",DFN,ITEM)) Q:ITEM="" D - . I $E(ITEM)="A" Q - . I $E(ITEM)="M" Q - . S RESULT=$$AALAB^ORWGAPIC(ITEM) - . I RESULT="" Q - . S RESULT="68^"_RESULT - . S ^TMP("ORWGRPC DC",$J,RESULT)="" - S RESULT="" - F S RESULT=$O(^TMP("ORWGRPC DC",$J,RESULT)) Q:RESULT="" S CNT=CNT+1 D - . D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT) - K ^TMP("ORWGRPC DC",$J) - Q - ; +ORWGAPI1 ; SLC/STAFF - Graph Items ;12/21/05 08:15 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215**;Dec 17, 1997 + ; +AA(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR + ; FMT,OLDEST,NEWEST not used + N ITEM,FILE,NUM,REF,RESULT + K ^TMP("ORWGRPC DC",$J) + S ITEM="" + F S ITEM=$O(^PXRMINDX(63,"PI",DFN,ITEM)) Q:ITEM="" D + . I $E(ITEM)="A" Q + . I $E(ITEM)="M" Q + . S RESULT=$$AALAB^ORWGAPIA(ITEM) + . I RESULT="" Q + . S RESULT="68^"_RESULT + . S ^TMP("ORWGRPC DC",$J,RESULT)="" + S RESULT="" + F S RESULT=$O(^TMP("ORWGRPC DC",$J,RESULT)) Q:RESULT="" S CNT=CNT+1 D + . D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) + K ^TMP("ORWGRPC DC",$J) + Q + ; +AP(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR + N DATE,ITEM,OK,RESULT + S ITEM="A" + F S ITEM=$O(^PXRMINDX(63,"PI",DFN,ITEM)) Q:ITEM="" Q:ITEM]"AZ" D + . S OK=0 + . I FMT=6 D + .. S DATE=OLDEST + .. F S DATE=$O(^PXRMINDX(63,"PI",DFN,ITEM,DATE)) Q:DATE="" Q:DATE>NEWEST D Q:OK + ... S CNT=CNT+1 + ... S OK=1 + ... S RESULT="63AP"_U_ITEM + . I FMT=3 D + .. S DATE=$O(^PXRMINDX(63,"PI",DFN,ITEM,""),-1) + .. I 'DATE Q + .. S OK=1 + .. S CNT=CNT+1 + .. S RESULT="63AP^"_ITEM_"^^"_$$ITEMPRFX^ORWGAPIU(ITEM)_": "_$$EVALUE^ORWGAPIU(ITEM,63,.01)_"^^"_DATE + . I FMT=0 D + .. S OK=1 + .. S CNT=CNT+1 + .. S RESULT="63AP^"_ITEM_U_$$ITEMPRFX^ORWGAPIU(ITEM)_": "_$$EVALUE^ORWGAPIU(ITEM,63,.01) + . I OK D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) + Q + ; +BCMA(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR + N DATE,DRUG,ITEM,NUM,RESULT + K ^TMP("ORWGRPC TEMP",$J) + I FMT=6 D + . S DATE=OLDEST + . F S DATE=$O(^PSB(53.79,"AADT",DFN,DATE)) Q:DATE<1 Q:DATE>NEWEST D + .. S NUM=0 + .. F S NUM=$O(^PSB(53.79,"AADT",DFN,DATE,NUM)) Q:NUM<1 D + ... S ITEM=$P($G(^PSB(53.79,NUM,0)),U,8) I 'ITEM Q + ... I $D(^TMP("ORWGRPC TEMP",$J,ITEM)) Q + ... S ^TMP("ORWGRPC TEMP",$J,ITEM)="" + ... S CNT=CNT+1 + ... S RESULT="53.79^"_ITEM + ... D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) + I FMT'=6 D + . S ITEM="" + . F S ITEM=$O(^PSB(53.79,"AOIP",DFN,ITEM)) Q:ITEM="" D + .. S DATE=$O(^PSB(53.79,"AOIP",DFN,ITEM,""),-1) + .. I 'DATE Q + .. S NUM=$O(^PSB(53.79,"AOIP",DFN,ITEM,DATE,""),-1) + .. I 'NUM Q + .. S CNT=CNT+1 + .. I FMT=3 S RESULT="53.79^"_ITEM_"^^"_$$POINAME^ORWGAPIA(ITEM)_"^^"_DATE + .. I FMT=0 S RESULT="53.79^"_ITEM_U_$$POINAME^ORWGAPIA(ITEM) + .. S DRUG=$$DRUG^ORWGAPIA(NUM) + .. I DRUG S RESULT=RESULT_U_$$DRGCLASS^ORWGAPIA(DRUG) + .. D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) + K ^TMP("ORWGRPC TEMP",$J) + Q + ; +DC(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR + ; FMT,OLDEST,NEWEST not used + N DATA,DATE,DATE1,DRUG,ITEM,FILE,NUM,REF,RESULT K DATA + K ^TMP("ORWGRPC DC",$J) + F FILE=52,55 D + . S ITEM="" + . F S ITEM=$O(^PXRMINDX(FILE,"PI",DFN,ITEM)) Q:ITEM="" D + .. S RESULT=$$DRGCLASS^ORWGAPIA(ITEM) + .. I RESULT="" Q + .. S RESULT="50.605^"_RESULT + .. S ^TMP("ORWGRPC DC",$J,RESULT)="" + S ITEM="" + F S ITEM=$O(^PSB(53.79,"AOIP",DFN,ITEM)) Q:ITEM="" D + . S DATE=$O(^PSB(53.79,"AOIP",DFN,ITEM,""),-1) + . I 'DATE Q + . S NUM=$O(^PSB(53.79,"AOIP",DFN,ITEM,DATE,""),-1) + . I 'NUM Q + . S DRUG=$$DRUG^ORWGAPIA(NUM) + . I 'DRUG Q + . S RESULT=$$DRGCLASS^ORWGAPIA(DRUG) + . I 'RESULT Q + . S RESULT="50.605^"_RESULT + . S ^TMP("ORWGRPC DC",$J,RESULT)="" + S ITEM="" + F S ITEM=$O(^PXRMINDX("55NVA","PI",DFN,ITEM)) Q:ITEM="" D + . S DATE=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,""),-1) + . I 'DATE Q + . S DATE1=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,DATE,""),-1) + . I '$L(DATE1) Q + . S REF=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,DATE,DATE1,""),-1) + . I '$L(REF) Q + . D RXNVA^ORWGAPIA(REF,.DATA) + . S DRUG=+$G(DATA("DISPENSE DRUG")) + . I 'DRUG Q + . S RESULT=$$DRGCLASS^ORWGAPIA(DRUG) + . I 'RESULT Q + . S RESULT="50.605^"_RESULT + . S ^TMP("ORWGRPC DC",$J,RESULT)="" + S RESULT="" + F S RESULT=$O(^TMP("ORWGRPC DC",$J,RESULT)) Q:RESULT="" S CNT=CNT+1 D + . D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) + K ^TMP("ORWGRPC DC",$J) + Q + ; +LAB(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR + N DATE,ITEM,OK,RESULT + S ITEM=0 + F S ITEM=$O(^PXRMINDX(63,"PI",DFN,ITEM)) Q:ITEM<1 D + . S OK=0 + . I FMT=6 D + .. S DATE=OLDEST + .. F S DATE=$O(^PXRMINDX(63,"PI",DFN,ITEM,DATE)) Q:DATE="" Q:DATE>NEWEST D Q:OK + ... S CNT=CNT+1 + ... S OK=1 + ... S RESULT=63_U_ITEM + . I FMT=3 D + .. S DATE=$O(^PXRMINDX(63,"PI",DFN,ITEM,""),-1) + .. I 'DATE Q + .. S CNT=CNT+1 + .. S OK=1 + .. S RESULT=63_U_ITEM_"^^"_$$EVALUE^ORWGAPIU(ITEM,63,.01)_"^^"_DATE + . I FMT=0 D + .. S CNT=CNT+1 + .. S OK=1 + .. S RESULT=63_U_ITEM_U_$$EVALUE^ORWGAPIU(ITEM,63,.01) + . I OK D + .. S RESULT=RESULT_U_$$AALAB^ORWGAPIA(ITEM) + .. D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) + Q + ; +MI(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR + N DATE,ITEM,OK,RESULT + S ITEM="M" + F S ITEM=$O(^PXRMINDX(63,"PI",DFN,ITEM)) Q:ITEM="" Q:ITEM]"MZ" D + . S OK=0 + . I FMT=6 D + .. S DATE=OLDEST + .. F S DATE=$O(^PXRMINDX(63,"PI",DFN,ITEM,DATE)) Q:DATE="" Q:DATE>NEWEST D Q:OK + ... S CNT=CNT+1 + ... S OK=1 + ... S RESULT="63MI"_U_ITEM + . I FMT=3 D + .. S DATE=$O(^PXRMINDX(63,"PI",DFN,ITEM,""),-1) + .. I 'DATE Q + .. S CNT=CNT+1 + .. S OK=1 + .. S RESULT="63MI^"_ITEM_"^^"_$$ITEMPRFX^ORWGAPIU(ITEM)_": "_$$EVALUE^ORWGAPIU(ITEM,63,.01)_"^^"_DATE + . I FMT=0 D + .. S CNT=CNT+1 + .. S OK=1 + .. S RESULT="63MI^"_ITEM_U_$$ITEMPRFX^ORWGAPIU(ITEM)_": "_$$EVALUE^ORWGAPIU(ITEM,63,.01) + . I OK D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) + Q + ; +MED(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR + D MED1^ORWGAPID(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,.TMP) + Q + ; +NOTES(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR + N DATE,DOC,DOCCLASS,DOCIEN,DOCTYPE,DUMMY,RESULT,RESULTS,TITLE K DUMMY + K ^TMP("ORWGRPC TEMP",$J),^TMP("TIUR",$J) + S CNT=$G(CNT) + I FMT=6 D + . F DOCTYPE="P","D","C" D + .. S DOCCLASS=$$DOCCLASS^ORWGAPIA(DOCTYPE) + .. K ^TMP("TIUR",$J) + .. D TIU^ORWGAPIA(.DUMMY,DOCCLASS,5,DFN,$G(OLDEST),$G(NEWEST)) + .. S DOC=0 + .. F S DOC=$O(^TMP("TIUR",$J,DOC)) Q:DOC<1 D + ... S RESULTS=^TMP("TIUR",$J,DOC) + ... S TITLE=$P(RESULTS,U,2) + ... S DATE=$P(RESULTS,U,3) + ... I '$L(TITLE) Q + ... S ^TMP("ORWGRPC TEMP",$J,TITLE,DATE)=RESULTS + I FMT'=6 D + . F DOCTYPE="P","D","C" D + .. S DOCCLASS=$$DOCCLASS^ORWGAPIA(DOCTYPE) + .. K ^TMP("TIUR",$J) + .. D TIU^ORWGAPIA(.DUMMY,DOCCLASS,5,DFN) + .. S DOC=0 + .. F S DOC=$O(^TMP("TIUR",$J,DOC)) Q:DOC<1 D + ... S RESULTS=^TMP("TIUR",$J,DOC) + ... S TITLE=$P(RESULTS,U,2) + ... S DATE=$P(RESULTS,U,3) + ... I '$L(TITLE) Q + ... S ^TMP("ORWGRPC TEMP",$J,TITLE,DATE)=RESULTS + S TITLE="" + F S TITLE=$O(^TMP("ORWGRPC TEMP",$J,TITLE)) Q:TITLE="" D + . S CNT=CNT+1 + . I FMT=6 S RESULT=8925_U_TITLE + . I FMT=3 D + .. S DATE=+$O(^TMP("ORWGRPC TEMP",$J,TITLE,""),-1) + .. S DOCIEN=+$G(^TMP("ORWGRPC TEMP",$J,TITLE,DATE)) + .. S RESULT=8925_U_TITLE_"^^"_TITLE_"^^" + .. S RESULT=RESULT_DATE + .. S RESULT=RESULT_U_$$TITLE^ORWGAPIA(DOCIEN) + . I FMT=0 S RESULT=8925_U_TITLE_U_TITLE + . S RESULT=$$UP^ORWGAPIX(RESULT) + . D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) + K ^TMP("ORWGRPC TEMP",$J),^TMP("TIUR",$J) + Q + ; +NVAE(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR + N DATA,DATE,DATE1,DRUG,ITEM,OK,REF,RESULT K DATA + S ITEM="" + F S ITEM=$O(^PXRMINDX("55NVA","PI",DFN,ITEM)) Q:ITEM="" D + . S OK=0 + . I FMT=6 D + .. S DATE=OLDEST + .. F S DATE=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,DATE)) Q:DATE="" Q:DATE>NEWEST D Q:OK + ... S CNT=CNT+1 + ... S OK=1 + ... S RESULT="55NVAE"_U_ITEM + . I FMT'=6 D + .. S DATE=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,""),-1) + .. I 'DATE Q + .. S DATE1=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,DATE,""),-1) + .. I '$L(DATE1) Q + .. S REF=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,DATE,DATE1,""),-1) + .. I '$L(REF) Q + .. D RXNVA^ORWGAPIA(REF,.DATA) + .. S DRUG=+$G(DATA("DISPENSE DRUG")) + .. S CNT=CNT+1 + .. S OK=1 + .. I FMT=3 S RESULT="55NVAE"_U_ITEM_"^^"_$$EVALUE^ORWGAPIU(ITEM,"55NVA",.01)_"^^"_DATE + .. I FMT=0 S RESULT="55NVAE"_U_ITEM_U_$$EVALUE^ORWGAPIU(ITEM,"55NVA",.01) + .. I DRUG S RESULT=RESULT_U_$$DRGCLASS^ORWGAPIA(DRUG) + . I OK D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) + Q + ; +NVA(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR + D NVA1^ORWGAPID(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,.TMP) + Q + ; +TITLE(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR + ; FMT,OLDEST,NEWEST not used + N ITEM,FILE,NUM,REF,RESULT + K ^TMP("ORWGRPC DC",$J) + S ITEM="" + F S ITEM=$O(^PXRMINDX(63,"PI",DFN,ITEM)) Q:ITEM="" D + . I $E(ITEM)="A" Q + . I $E(ITEM)="M" Q + . S RESULT=$$AALAB^ORWGAPIA(ITEM) + . I RESULT="" Q + . S RESULT="68^"_RESULT + . S ^TMP("ORWGRPC DC",$J,RESULT)="" + S RESULT="" + F S RESULT=$O(^TMP("ORWGRPC DC",$J,RESULT)) Q:RESULT="" S CNT=CNT+1 D + . D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) + K ^TMP("ORWGRPC DC",$J) + Q + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPI2.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPI2.m index d7cc4818..a3bdcf79 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPI2.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPI2.m @@ -1,112 +1,252 @@ -ORWGAPI2 ; SLC/STAFF - Graph API Items ;12/21/05 08:16 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,243**;Dec 17, 1997;Build 242 - ; -ADVERSE(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR - N DATE,IEN,ITEM,RESULT - K ^TMP("ORWGRPC SORT",$J),^TMP("ORWGRPC TEMP",$J) - S IEN=0 - F S IEN=$O(^GMR(120.8,"B",DFN,IEN)) Q:IEN<1 D - . I '$D(^GMR(120.8,IEN,0)) Q - . I $G(^GMR(120.8,IEN,"ER")) Q - . I '$P(^GMR(120.8,IEN,0),U,12) Q - . S DATE=+$P($G(^GMR(120.8,IEN,0)),U,4) I 'DATE Q - . S ITEM=$P(^GMR(120.8,IEN,0),U,2) I '$L(ITEM) Q - . S ^TMP("ORWGRPC SORT",$J,DATE,ITEM)="" ;ADVERSE - I FMT=6 D - . S DATE=OLDEST - . F S DATE=$O(^TMP("ORWGRPC SORT",$J,DATE)) Q:DATE<1 Q:DATE>NEWEST D - .. S ITEM="" - .. F S ITEM=$O(^TMP("ORWGRPC SORT",$J,DATE,ITEM)) Q:ITEM="" D - ... I $D(^TMP("ORWGRPC TEMP",$J,ITEM)) Q - ... S ^TMP("ORWGRPC TEMP",$J,ITEM)="" - ... S CNT=CNT+1 - ... S RESULT="120.8^"_ITEM - ... D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT) - I FMT'=6 D - . S DATE=0 - . F S DATE=$O(^TMP("ORWGRPC SORT",$J,DATE)) Q:DATE<1 D - .. S ITEM="" - .. F S ITEM=$O(^TMP("ORWGRPC SORT",$J,DATE,ITEM)) Q:ITEM="" D - ... I $D(^TMP("ORWGRPC TEMP",$J,ITEM)) Q - ... S ^TMP("ORWGRPC TEMP",$J,ITEM)="" - ... S CNT=CNT+1 - ... I FMT=3 S RESULT="120.8^"_ITEM_"^^"_ITEM_"^^"_DATE - ... I FMT=0 S RESULT="120.8^"_ITEM_U_ITEM - ... D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT) - K ^TMP("ORWGRPC SORT",$J),^TMP("ORWGRPC TEMP",$J) - Q - ; -PL(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR - N DATE,ICD9,OK,PRIORITY,RESULT,STATUS - K ^TMP("ORWGRPC TEMP",$J) - S STATUS="" - F S STATUS=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS)) Q:STATUS="" D - . S PRIORITY="" - . F S PRIORITY=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY)) Q:PRIORITY="" D - .. S ICD9="" - .. F S ICD9=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ICD9)) Q:ICD9="" D - ... S OK=0 - ... I FMT=6 D - .... S DATE=OLDEST - .... F S DATE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ICD9,DATE)) Q:DATE="" Q:DATE>NEWEST D Q:OK - ..... S CNT=CNT+1 - ..... S OK=1 - ..... S RESULT=9000011_U_ICD9 - ... I FMT=3 D - .... S DATE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ICD9,""),-1) - .... I DATE S ^TMP("ORWGRPC TEMP",$J,ICD9,DATE)="" - ... I FMT=0 D - .... S CNT=CNT+1 - .... S OK=1 - .... S RESULT=9000011_U_ICD9_U_$$EVALUE^ORWGAPIU(ICD9,9000011,.01) - ... I OK D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT) - I FMT=3 D - . S ICD9="" - . F S ICD9=$O(^TMP("ORWGRPC TEMP",$J,ICD9)) Q:ICD9="" D - .. S DATE=$O(^TMP("ORWGRPC TEMP",$J,ICD9,""),-1) - .. I 'DATE Q - .. S CNT=CNT+1 - .. S RESULT=9000011_U_ICD9_"^^"_$$EVALUE^ORWGAPIU(ICD9,9000011,.01)_"^^"_DATE - .. D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT) - K ^TMP("ORWGRPC TEMP",$J) - Q - ; -PLX(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR - D PLX2^ORWGAPID(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,.TMP) - Q - ; -REG(ITEMS,DFN,FILE,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR - N DATE,ICD,ITEM,NUM,OK,RESULT - K ^TMP("ORWGRPC TEMP",$J) - I $E(FILE,3,4)="DX" S ICD="ICD9" - I $E(FILE,3,4)="OP" S ICD="ICD0" - S NUM="" - F S NUM=$O(^PXRMINDX(45,ICD,"PNI",DFN,NUM)) Q:NUM="" D - . S ITEM="" - . F S ITEM=$O(^PXRMINDX(45,ICD,"PNI",DFN,NUM,ITEM)) Q:ITEM="" D - .. S OK=0 - .. I FMT=6 D - ... S DATE=OLDEST - ... F S DATE=$O(^PXRMINDX(45,ICD,"PNI",DFN,NUM,ITEM,DATE)) Q:DATE="" Q:DATE>NEWEST D Q:OK - .... S CNT=CNT+1 - .... S OK=1 - .... S RESULT=FILE_U_ITEM - .. I FMT=3 D - ... S DATE=$O(^PXRMINDX(45,ICD,"PNI",DFN,NUM,ITEM,""),-1) - ... I DATE S ^TMP("ORWGRPC TEMP",$J,ITEM,DATE)="" - .. I FMT=0 D - ... S CNT=CNT+1 - ... S OK=1 - ... S RESULT=FILE_U_ITEM_U_$$EVALUE^ORWGAPIU(ITEM,45_";"_ICD,.01) - .. I OK D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT) - I FMT=3 D - . S ITEM="" - . F S ITEM=$O(^TMP("ORWGRPC TEMP",$J,ITEM)) Q:ITEM="" D - .. S DATE=$O(^TMP("ORWGRPC TEMP",$J,ITEM,""),-1) - .. I 'DATE Q - .. S CNT=CNT+1 - .. S RESULT=FILE_U_ITEM_"^^"_$$EVALUE^ORWGAPIU(ITEM,45_";"_ICD,.01)_"^^"_DATE - .. D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT) - K ^TMP("ORWGRPC TEMP",$J) - Q - ; +ORWGAPI2 ; SLC/STAFF - Graph API Items ;12/21/05 08:16 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215**;Dec 17, 1997 + ; +ADMITS(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR + N DATE,DATE2,DISCH,LINE,LST,NUM,OK,RESULT K LST + K ^TMP("ORWGRPC TEMP",$J) + D ADMITLST^ORWPT(.LST,DFN) + S OK=0 + S NUM=0 + F S NUM=$O(LST(NUM)) Q:NUM<1 D Q:OK + . S LINE=LST(NUM) + . S DATE=$P(LINE,U) + . S DISCH=$P(LINE,U,5) + . S DATE2=$$DISCH^ORWGAPIA(DISCH) + . I DATE2="" S DATE2=DATE2\1 + . I FMT=6 D Q + .. I DATE>NEWEST Q + .. I DATE2>0,DATE2NEWEST D + .. S ITEM="" + .. F S ITEM=$O(^TMP("ORWGRPC SORT",$J,DATE,ITEM)) Q:ITEM="" D + ... I $D(^TMP("ORWGRPC TEMP",$J,ITEM)) Q + ... S ^TMP("ORWGRPC TEMP",$J,ITEM)="" + ... S CNT=CNT+1 + ... S RESULT="120.8^"_ITEM + ... D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) + I FMT'=6 D + . S DATE=0 + . F S DATE=$O(^TMP("ORWGRPC SORT",$J,DATE)) Q:DATE<1 D + .. S ITEM="" + .. F S ITEM=$O(^TMP("ORWGRPC SORT",$J,DATE,ITEM)) Q:ITEM="" D + ... I $D(^TMP("ORWGRPC TEMP",$J,ITEM)) Q + ... S ^TMP("ORWGRPC TEMP",$J,ITEM)="" + ... S CNT=CNT+1 + ... I FMT=3 S RESULT="120.8^"_ITEM_"^^"_ITEM_"^^"_DATE + ... I FMT=0 S RESULT="120.8^"_ITEM_U_ITEM + ... D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) + K ^TMP("ORWGRPC SORT",$J),^TMP("ORWGRPC TEMP",$J) + Q + ; +PL(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR + N DATE,ICD9,OK,PRIORITY,RESULT,STATUS + K ^TMP("ORWGRPC TEMP",$J) + S STATUS="" + F S STATUS=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS)) Q:STATUS="" D + . S PRIORITY="" + . F S PRIORITY=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY)) Q:PRIORITY="" D + .. S ICD9="" + .. F S ICD9=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ICD9)) Q:ICD9="" D + ... S OK=0 + ... I FMT=6 D + .... S DATE=OLDEST + .... F S DATE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ICD9,DATE)) Q:DATE="" Q:DATE>NEWEST D Q:OK + ..... S CNT=CNT+1 + ..... S OK=1 + ..... S RESULT=9000011_U_ICD9 + ... I FMT=3 D + .... S DATE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ICD9,""),-1) + .... I DATE S ^TMP("ORWGRPC TEMP",$J,ICD9,DATE)="" + ... I FMT=0 D + .... S CNT=CNT+1 + .... S OK=1 + .... S RESULT=9000011_U_ICD9_U_$$EVALUE^ORWGAPIU(ICD9,9000011,.01) + ... I OK D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) + I FMT=3 D + . S ICD9="" + . F S ICD9=$O(^TMP("ORWGRPC TEMP",$J,ICD9)) Q:ICD9="" D + .. S DATE=$O(^TMP("ORWGRPC TEMP",$J,ICD9,""),-1) + .. I 'DATE Q + .. S CNT=CNT+1 + .. S RESULT=9000011_U_ICD9_"^^"_$$EVALUE^ORWGAPIU(ICD9,9000011,.01)_"^^"_DATE + .. D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) + K ^TMP("ORWGRPC TEMP",$J) + Q + ; +PLX(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR + D PLX2^ORWGAPID(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,.TMP) + Q + ; +REG(ITEMS,DFN,FILE,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR + N DATE,ICD,ITEM,NUM,OK,RESULT + K ^TMP("ORWGRPC TEMP",$J) + I $E(FILE,3,4)="DX" S ICD="ICD9" + I $E(FILE,3,4)="OP" S ICD="ICD0" + S NUM="" + F S NUM=$O(^PXRMINDX(45,ICD,"PNI",DFN,NUM)) Q:NUM="" D + . S ITEM="" + . F S ITEM=$O(^PXRMINDX(45,ICD,"PNI",DFN,NUM,ITEM)) Q:ITEM="" D + .. S OK=0 + .. I FMT=6 D + ... S DATE=OLDEST + ... F S DATE=$O(^PXRMINDX(45,ICD,"PNI",DFN,NUM,ITEM,DATE)) Q:DATE="" Q:DATE>NEWEST D Q:OK + .... S CNT=CNT+1 + .... S OK=1 + .... S RESULT=FILE_U_ITEM + .. I FMT=3 D + ... S DATE=$O(^PXRMINDX(45,ICD,"PNI",DFN,NUM,ITEM,""),-1) + ... I DATE S ^TMP("ORWGRPC TEMP",$J,ITEM,DATE)="" + .. I FMT=0 D + ... S CNT=CNT+1 + ... S OK=1 + ... S RESULT=FILE_U_ITEM_U_$$EVALUE^ORWGAPIU(ITEM,45_";"_ICD,.01) + .. I OK D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) + I FMT=3 D + . S ITEM="" + . F S ITEM=$O(^TMP("ORWGRPC TEMP",$J,ITEM)) Q:ITEM="" D + .. S DATE=$O(^TMP("ORWGRPC TEMP",$J,ITEM,""),-1) + .. I 'DATE Q + .. S CNT=CNT+1 + .. S RESULT=FILE_U_ITEM_"^^"_$$EVALUE^ORWGAPIU(ITEM,45_";"_ICD,.01)_"^^"_DATE + .. D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) + K ^TMP("ORWGRPC TEMP",$J) + Q + ; +SURGERY(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR + N CASE,DATE,PROC,RESULT,RESULTS,SURG,SURGPROC K SURG,SURGPROC + D SURG^ORWGAPIA(.SURG,DFN) + K SURG(0),SURG(1) + I FMT=6 D + . S CASE=0 + . F S CASE=$O(SURG(CASE)) Q:CASE<1 D + .. S RESULTS=SURG(CASE) + .. S PROC=$P(RESULTS,U,3) + .. I '$L(PROC) Q + .. S DATE=$P(RESULTS,U,5) + .. I DATE>NEWEST Q + .. I DATEOLDEST1 D + .. S IEN=0 + .. F S IEN=$O(^AUPNVTRT("AA",DFN,DATE,IEN)) Q:IEN<1 D + ... S ITEM=+$G(^AUPNVTRT(IEN,0)) I 'ITEM Q + ... I $D(^TMP("ORWGRPC TEMP",$J,ITEM)) Q + ... S ^TMP("ORWGRPC TEMP",$J,ITEM)="" + ... S CNT=CNT+1 + ... S RESULT="9000010.15^"_ITEM + ... D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) + I FMT'=6 D + . S OLDEST1=9999999-OLDEST + . S DATE=9999999-NEWEST + . F S DATE=$O(^AUPNVTRT("AA",DFN,DATE)) Q:DATE<1 Q:DATE>OLDEST D + .. S IEN=0 + .. F S IEN=$O(^AUPNVTRT("AA",DFN,DATE,IEN)) Q:IEN<1 D + ... S ITEM=+$G(^AUPNVTRT(IEN,0)) I 'ITEM Q + ... I $D(^TMP("ORWGRPC TEMP",$J,ITEM)) Q + ... S ^TMP("ORWGRPC TEMP",$J,ITEM)="" + ... S CNT=CNT+1 + ... I FMT=3 S RESULT="9000010.15^"_ITEM_"^^"_$$EVALUE^ORWGAPIU(ITEM,9000010.15)_"^^"_DATE + ... I FMT=0 S RESULT="9000010.15^"_ITEM_U_$$EVALUE^ORWGAPIU(ITEM,9000010.15) + ... D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) + K ^TMP("ORWGRPC TEMP",$J) + Q + ; +VISITS(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR + N DATE,DATE2,ITEM,NODE,NUM,OK,RESULT + K ^TMP("ORWGRPC TEMP",$J) + I FMT=6 D + . S DATE=0 + . F S DATE=$O(^AUPNVSIT("AET",DFN,DATE)) Q:DATE<1 Q:DATE>NEWEST D + .. S ITEM="" + .. F S ITEM=$O(^AUPNVSIT("AET",DFN,DATE,ITEM)) Q:ITEM="" D + ... S NODE="" + ... F S NODE=$O(^AUPNVSIT("AET",DFN,DATE,ITEM,NODE)) Q:NODE="" D + .... S NUM=0 + .... F S NUM=$O(^AUPNVSIT("AET",DFN,DATE,ITEM,NODE,NUM)) Q:NUM="" D + ..... S DATE2=+$P($G(^AUPNVSIT(NUM,0)),U,18) + ..... I 'DATE2 S DATE2=DATE+.01 + ..... I +$E($P(DATE2,".",2),1,2)>24 S DATE2=(DATE\1)+.2359 + ..... S ^TMP("ORWGRPC TEMP",$J,ITEM,DATE)=DATE2 + . S ITEM=0 + . F S ITEM=$O(^TMP("ORWGRPC TEMP",$J,ITEM)) Q:ITEM<1 D + .. S OK=0 + .. S DATE=0 + .. F S DATE=$O(^TMP("ORWGRPC TEMP",$J,ITEM,DATE)) Q:DATE<1 Q:DATE>NEWEST D Q:OK + ... S DATE2=$G(^TMP("ORWGRPC TEMP",$J,ITEM,DATE)) + ... I DATE2START Q - . I DATE0 S ADVERSE=$E(ADVERSE,1,$L(ADVERSE)-2) - . S CNT=CNT+1 - . S RESULT=120.8_U_ITEM_U_DATE_U_DATE2_U_ADVERSE - . D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT) - Q - ; -DX(DATA,ITEM,START,DFN,CNT,TMP,BACKTO) ; from ORWGAPIR - N DATE,DATE2,NODE,NUM,RESULT,VALUE,VALUES K VALUE - K ^TMP("ORWGRPC TEMP",$J) - S DATE2="",CNT=$G(CNT),BACKTO=+$G(BACKTO) - S NUM="" - F S NUM=$O(^PXRMINDX(45,"ICD9","PNI",DFN,NUM)) Q:NUM="" D - . S DATE="" - . F S DATE=$O(^PXRMINDX(45,"ICD9","PNI",DFN,NUM,ITEM,DATE)) Q:DATE="" D - .. I DATE>START Q - .. I DATESTART Q - . I DATESTART Q - .. I DATESTART Q - . I DATESTART Q - . I DATESTART Q + . I ITEM'=$P(^GMR(120.8,NODE,0),U,2) Q + . S RXN=0 + . F S RXN=$O(^GMR(120.8,NODE,10,"B",RXN)) Q:RXN<1 D + .. S ADVERSE=ADVERSE_$$EVALUE^ORWGAPIU(RXN,120.8)_", " + . I $L(ADVERSE)>0 S ADVERSE=$E(ADVERSE,1,$L(ADVERSE)-2) + . S CNT=CNT+1 + . S RESULT=120.8_U_ITEM_U_DATE_U_DATE2_U_ADVERSE + . D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) + Q + ; +BCMA(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR + N DATE,NODE,RESULT,VALUE + S DATE="",CNT=$G(CNT) + F S DATE=$O(^PSB(53.79,"AOIP",DFN,ITEM,DATE)) Q:DATE="" D + . I DATE>START Q + . S NODE="" + . F S NODE=$O(^PSB(53.79,"AOIP",DFN,ITEM,DATE,NODE)) Q:NODE="" D + .. S VALUE=$P($G(^PSB(53.79,NODE,0)),U,9) I VALUE'="G" Q + .. S RESULT=53.79_U_ITEM_U_DATE_"^^" + .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) + Q + ; +DX(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR + N DATE,DATE2,NODE,NUM,RESULT,VALUE K VALUE + K ^TMP("ORWGRPC TEMP",$J) + S DATE2="",CNT=$G(CNT) + S NUM="" + F S NUM=$O(^PXRMINDX(45,"ICD9","PNI",DFN,NUM)) Q:NUM="" D + . S DATE="" + . F S DATE=$O(^PXRMINDX(45,"ICD9","PNI",DFN,NUM,ITEM,DATE)) Q:DATE="" D + .. I DATE>START Q + .. S NODE="" + .. F S NODE=$O(^PXRMINDX(45,"ICD9","PNI",DFN,NUM,ITEM,DATE,NODE)) Q:NODE="" D + ... I '$D(^TMP("ORWGRPC TEMP",$J,ITEM,DATE)) S ^TMP("ORWGRPC TEMP",$J,ITEM,DATE)=NODE_U_NUM + S ITEM="" + F S ITEM=$O(^TMP("ORWGRPC TEMP",$J,ITEM)) Q:ITEM="" D + . S DATE="" + . F S DATE=$O(^TMP("ORWGRPC TEMP",$J,ITEM,DATE)) Q:DATE="" D + .. S NODE=$G(^TMP("ORWGRPC TEMP",$J,ITEM,DATE)) I '$L(NODE) Q + .. S NUM=$P(NODE,U,2) + .. S NODE=$P(NODE,U) + .. D PTF^ORWGAPIA(NODE,.VALUE) S VALUE=$$EXT^ORWGAPIX($G(VALUE("DISCHARGE STATUS")),45,6) + .. I NUM="DXLS" S VALUE="(DXLS) "_VALUE + .. S RESULT=45_"DX"_U_ITEM_U_DATE_U_DATE2_U_" "_VALUE + .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) + K ^TMP("ORWGRPC TEMP",$J) + Q + ; +INRX(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR + N DATE,DATE2,NODE,RESULT,VALUE K VALUE + S DATE="",CNT=$G(CNT) + F S DATE=$O(^PXRMINDX(55,"PI",DFN,ITEM,DATE)) Q:DATE="" D + . I DATE>START Q + . S DATE2="" + . F S DATE2=$O(^PXRMINDX(55,"PI",DFN,ITEM,DATE,DATE2)) Q:DATE2="" D + .. S NODE="" + .. F S NODE=$O(^PXRMINDX(55,"PI",DFN,ITEM,DATE,DATE2,NODE)) Q:NODE="" D + ... D RXIN^ORWGAPIA(NODE,.VALUE) S VALUE=VALUE("STAT") + ... S VALUE=VALUE_" "_$$INSIG^ORWGAPIA(NODE) + ... S RESULT=55_U_ITEM_U_DATE_U_DATE2_U_VALUE + ... D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) + Q + ; +LAB(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR + N COMMENT,DATE,DATE2,NODE,RESULT,TYPE,VALUE K VALUE + S DATE="",DATE2="",CNT=$G(CNT) + D + . I $E(ITEM)="A" S TYPE="AP" Q + . I $E(ITEM)="M" S TYPE="MI" Q + . S TYPE="" Q + F S DATE=$O(^PXRMINDX(63,"PI",DFN,ITEM,DATE)) Q:DATE="" D + . I DATE>START Q + . S NODE="" + . F S NODE=$O(^PXRMINDX(63,"PI",DFN,ITEM,DATE,NODE)) Q:NODE="" D + .. K VALUE + .. D LAB^ORWGAPIA(.VALUE,NODE,ITEM) + .. I TYPE="AP" S RESULT="63AP^"_ITEM_U_DATE_U_DATE2 ;_U_$P(VALUE,U,2) + .. I TYPE="MI" S RESULT="63MI^"_ITEM_U_DATE_U_DATE2_U_$P(VALUE,U,4) + .. I TYPE="" D + ... S COMMENT="" + ... I $L($G(VALUE("COMMENTS",1))) S COMMENT=1 + ... S RESULT="63^"_ITEM_U_DATE_U_DATE2_U_$P(VALUE,U,3)_U_$P(VALUE,U,4)_U_$G(VALUE("SPECIMEN"))_U_COMMENT + .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) + Q + ; +MED(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR + D MED3^ORWGAPID(.DATA,ITEM,START,DFN,.CNT,.TMP) + Q + ; +NOTE(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR + N DATE,DOC,DOCCLASS,DOCTYPE,DUM,IEN,RESULT,RESULTS,TITLE,VALUE K DUM + K ^TMP("ORWGRPC TEMP",$J),^TMP("TIUR",$J) + S CNT=$G(CNT),ITEM=$$UP^ORWGAPIX(ITEM) + F DOCTYPE="P","D","C" D + . S DOCCLASS=$$DOCCLASS^ORWGAPIA(DOCTYPE) + . K ^TMP("TIUR",$J) + . D TIU^ORWGAPIA(.DUM,DOCCLASS,5,DFN) + . S DOC=0 + . F S DOC=$O(^TMP("TIUR",$J,DOC)) Q:DOC<1 D + .. S RESULTS=^TMP("TIUR",$J,DOC) + .. S IEN=+$P(RESULTS,U) + .. S TITLE=$$UP^ORWGAPIX($P(RESULTS,U,2)) + .. I TITLE'=ITEM Q + .. ; do not use admission date S DATE=$P($G(^AUPNVSIT(+$P($G(^TIU(8925,IEN,0)),U,3),0)),U) + .. S DATE=$P(RESULTS,U,3) + .. I DATE>START Q + .. S VALUE=$P(RESULTS,U,7) + .. S CNT=CNT+1 + .. S RESULT=8925_U_TITLE_U_DATE_"^^"_VALUE + .. I $D(^TMP("ORWGRPC TEMP",$J,RESULT)) Q + .. S ^TMP("ORWGRPC TEMP",$J,RESULT)="" + .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) + K ^TMP("ORWGRPC TEMP",$J),^TMP("TIUR",$J) + Q + ; +NVAE(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR + N DATE,DATE2,NODE,RESULT,VALUE K VALUE + S DATE="",CNT=$G(CNT) + F S DATE=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,DATE)) Q:DATE="" D + . I DATE>START Q + . S DATE2="" + . F S DATE2=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,DATE,DATE2)) Q:DATE2="" D + .. S NODE="" + .. F S NODE=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,DATE,DATE2,NODE)) Q:NODE="" D + ... D RXNVA^ORWGAPIA(NODE,.VALUE) S VALUE=$G(VALUE("STATUS")) + ... S VALUE=VALUE_" "_$$NVASIG^ORWGAPIA(NODE) + ... S RESULT="55NVAE"_U_ITEM_U_DATE_"^^"_VALUE ; DATE2 is not used, NVA defined as an event + ... ;S RESULT="55NVAE"_U_ITEM_U_DATE_U_$S(DATE2["U":DT,1:DATE2)_U_VALUE ; DATE2 is not used, NVA defined as an event + ... D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) + Q + ; +NVA(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR + D NVA3^ORWGAPID(.DATA,ITEM,START,DFN,.CNT,.TMP) + Q + ; +ORDER(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR + N DATE,DATE2,NODE,ORUPCHUK,RESULT,VALUE K ORUPCHUK + S DATE="",CNT=$G(CNT) + F S DATE=$O(^PXRMINDX(100,"PI",DFN,ITEM,DATE)) Q:DATE="" D + . I DATE>START Q + . S DATE2="" + . F S DATE2=$O(^PXRMINDX(100,"PI",DFN,ITEM,DATE,DATE2)) Q:DATE2="" D + .. S NODE="" + .. F S NODE=$O(^PXRMINDX(100,"PI",DFN,ITEM,DATE,DATE2,NODE)) Q:NODE="" D + ... D EN^ORX8($P(NODE,";")) S VALUE=$P($G(ORUPCHUK("ORSTS")),U,2) + ... S RESULT=100_U_ITEM_U_DATE_"^^"_VALUE + ... D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) + Q + ; +OUTRX(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR + N DATE1,DATE2,LNUM,NODE,RESULT,VALUE K VALUE + S DATE1="",DATE2="",CNT=$G(CNT) + F S DATE1=$O(^PXRMINDX(52,"PI",DFN,ITEM,DATE1)) Q:DATE1="" D + . I DATE1>START Q + . S DATE2="" + . F S DATE2=$O(^PXRMINDX(52,"PI",DFN,ITEM,DATE1,DATE2)) Q:DATE2="" D + .. S NODE="" + .. F S NODE=$O(^PXRMINDX(52,"PI",DFN,ITEM,DATE1,DATE2,NODE)) Q:NODE="" D + ... D RXOUT^ORWGAPIA(NODE,.VALUE) S VALUE=$$EXTERNAL^ORWGAPIX(52,100,"",VALUE("STATUS")) + ... S VALUE=VALUE_" "_$$SIG^ORWGAPIA(DFN,+NODE) + ... S RESULT=52_U_ITEM_U_DATE1_U_DATE2_U_VALUE + ... D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) + Q + ; +RAD(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR + N DATE,DATE2,NODE,RESULT,VALUE K VALUE + S DATE="",DATE2="",CNT=$G(CNT) + F S DATE=$O(^PXRMINDX(70,"PI",DFN,ITEM,DATE)) Q:DATE="" D + . I DATE>START Q + . S NODE="" + . F S NODE=$O(^PXRMINDX(70,"PI",DFN,ITEM,DATE,NODE)) Q:NODE="" D + .. D RAD^ORWGAPIA(NODE,.VALUE) S VALUE=$G(VALUE("PDX"))_"-"_$G(VALUE("EXAM STATUS")) + .. S RESULT=70_U_ITEM_U_DATE_U_DATE2_U_VALUE + .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) + Q + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPI4.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPI4.m index 801064da..2fefe8b5 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPI4.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPI4.m @@ -1,187 +1,258 @@ -ORWGAPI4 ; SLC/STAFF - Graph Data, indexed ;8/21/06 07:52 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,260,243**;Dec 17, 1997;Build 242 - ; -EDU(DATA,ITEM,START,DFN,CNT,TMP,BACKTO) ; from ORWGAPIR - N DATE,DATE2,NODE,RESULT,VALUE,VALUES K VALUE - S DATE="",DATE2="",CNT=$G(CNT),BACKTO=+$G(BACKTO) - F S DATE=$O(^PXRMINDX(9000010.16,"PI",DFN,ITEM,DATE)) Q:DATE="" D - . I DATE>START Q - . I DATESTART Q - . I DATESTART Q - . I DATESTART Q - . I DATESTART Q - . I DATESTART Q - .. I DATESTART Q - .. I DATESTART Q - ... I DATESTART Q - .. I DATESTART Q - . I DATESTART Q - . I DATESTART Q + . S DISCH=$P(LINE,U,5) + . S DATE2=$$DISCH^ORWGAPIA(DISCH) + . I DATE2="" D + .. S DATE2=$$FMADD^ORWGAPIX(DATE,$$LOS^ORWGAPIA(DISCH)+1) + .. I DATE2=-1 S DATE2=$$FMADD^ORWGAPIX(DT,1) ; just make it today + 1 + .. S DATE2=DATE2\1 + . S VALUE=$P(LINE,U,3)_" "_$P(LINE,U,4)_U_$P(LINE,U,5,6) + . S CNT=CNT+1 + . S RESULT=405_U_ITEM_U_DATE_U_DATE2_U_VALUE + . D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) + Q + ; +EDU(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR + N DATE,DATE2,NODE,RESULT,VALUE K VALUE + S DATE="",DATE2="",CNT=$G(CNT) + F S DATE=$O(^PXRMINDX(9000010.16,"PI",DFN,ITEM,DATE)) Q:DATE="" D + . I DATE>START Q + . S NODE="" + . F S NODE=$O(^PXRMINDX(9000010.16,"PI",DFN,ITEM,DATE,NODE)) Q:NODE="" D + .. D EDU^ORWGAPIA(NODE,.VALUE) + .. S VALUE=VALUE("VALUE"),VALUE=VALUE_U_$$EVALUE^ORWGAPIU(VALUE,9000010.16,.06) + .. S RESULT=9000010.16_U_ITEM_U_DATE_"^^" ;_VALUE + .. S RESULT=9000010.16_U_ITEM_U_DATE_U_DATE2_U ;_VALUE + .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) + Q + ; +EXAM(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR + N DATE,DATE2,NODE,RESULT,VALUE K VALUE + S DATE="",DATE2="",CNT=$G(CNT) + F S DATE=$O(^PXRMINDX(9000010.13,"PI",DFN,ITEM,DATE)) Q:DATE="" D + . I DATE>START Q + . S NODE="" + . F S NODE=$O(^PXRMINDX(9000010.13,"PI",DFN,ITEM,DATE,NODE)) Q:NODE="" D + .. D EXAM^ORWGAPIA(NODE,.VALUE) + .. S VALUE=$G(VALUE("VALUE")),VALUE=VALUE_U_$$EVALUE^ORWGAPIU(VALUE,9000010.13,.04) + .. S RESULT=9000010.13_U_ITEM_U_DATE_U_DATE2_U_VALUE + .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) + Q + ; +HF(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR + N DATE,DATE2,NODE,RESULT,VALUE K VALUE + S DATE="",DATE2="",CNT=$G(CNT) + F S DATE=$O(^PXRMINDX(9000010.23,"PI",DFN,ITEM,DATE)) Q:DATE="" D + . I DATE>START Q + . S NODE="" + . F S NODE=$O(^PXRMINDX(9000010.23,"PI",DFN,ITEM,DATE,NODE)) Q:NODE="" D + .. D HF^ORWGAPIA(NODE,.VALUE) + .. S VALUE=VALUE("VALUE"),VALUE=VALUE_U_$$EVALUE^ORWGAPIU(VALUE,9000010.23,.04) + .. S RESULT=9000010.23_U_ITEM_U_DATE_U_DATE2_U_VALUE + .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) + Q + ; +IMM(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR + N DATE,DATE2,NODE,RESULT,VALUE K VALUE + S DATE="",DATE2="",CNT=$G(CNT) + F S DATE=$O(^PXRMINDX(9000010.11,"PI",DFN,ITEM,DATE)) Q:DATE="" D + . I DATE>START Q + . S NODE="" + . F S NODE=$O(^PXRMINDX(9000010.11,"PI",DFN,ITEM,DATE,NODE)) Q:NODE="" D + .. D IMM^ORWGAPIA(NODE,.VALUE) + .. S VALUE=$G(VALUE("VALUE")),VALUE=VALUE_U_$$EVALUE^ORWGAPIU(VALUE,9000010.11,.04) + .. S CNT=CNT+1 + .. S RESULT=9000010.11_U_ITEM_U_DATE_U_DATE2_U_VALUE + .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) + Q + ; +MH(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR + N DATE,DATE2,NODE,RESULT,VALUE K VALUE + S DATE="",DATE2="",CNT=$G(CNT) + F S DATE=$O(^PXRMINDX(601.2,"PI",DFN,ITEM,DATE)) Q:DATE="" D + . I DATE>START Q + . S NODE="" + . F S NODE=$O(^PXRMINDX(601.2,"PI",DFN,ITEM,DATE,NODE)) Q:NODE="" D + .. D MH^ORWGAPIA(.VALUE,NODE) S VALUE=$P($G(VALUE(2)),U,2,3) + .. S RESULT=601.2_U_ITEM_U_DATE_U_DATE2_U ;_VALUE + .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) + Q + ; +OP(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR + N DATE,DATE2,NODE,NUM,RESULT,VALUE K VALUE + S DATE2="",CNT=$G(CNT) + S NUM="" + F S NUM=$O(^PXRMINDX(45,"ICD0","PNI",DFN,NUM)) Q:NUM="" D + . S DATE="" + . F S DATE=$O(^PXRMINDX(45,"ICD0","PNI",DFN,NUM,ITEM,DATE)) Q:DATE="" D + .. I DATE>START Q + .. S NODE="" + .. F S NODE=$O(^PXRMINDX(45,"ICD0","PNI",DFN,NUM,ITEM,DATE,NODE)) Q:NODE="" D + ... D PTF^ORWGAPIA(NODE,.VALUE) S VALUE=$G(VALUE("DISCHARGE STATUS")) + ... S RESULT=45_"OP"_U_ITEM_U_DATE_U_DATE2_U ;_VALUE + ... D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) + Q + ; +POV(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR + N DATE,DATE2,NODE,RESULT,TYPE,VALUE K VALUE + S DATE2="",CNT=$G(CNT) + S TYPE="" + F S TYPE=$O(^PXRMINDX(9000010.07,"PPI",DFN,TYPE)) Q:TYPE="" D + . S DATE="" + . F S DATE=$O(^PXRMINDX(9000010.07,"PPI",DFN,TYPE,ITEM,DATE)) Q:DATE="" D + .. I DATE>START Q + .. S NODE="" + .. F S NODE=$O(^PXRMINDX(9000010.07,"PPI",DFN,TYPE,ITEM,DATE,NODE)) Q:NODE="" D + ... D POV^ORWGAPIA(NODE,.VALUE) + ... S VALUE=VALUE("CLINICAL TERM"),VALUE=VALUE_U_$$EVALUE^ORWGAPIU(VALUE,9000010.07,.15) + ... S CNT=CNT+1 + ... S RESULT=9000010.07_U_ITEM_U_DATE_U_DATE2_U_VALUE + ... D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) + Q + ; +PROB(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR + N DATE,DATE2,DTONSET,DTRESOLV,ICD9,NODE,PRIORITY,PROB,PROBDX,PSTATUS,RESULT,STATUS,VALUE + K ^TMP("ORWGRPC TEMP",$J) + S DATE2="",CNT=$G(CNT) + S STATUS="" + F S STATUS=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS)) Q:STATUS="" D + . S PRIORITY="" + . F S PRIORITY=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY)) Q:PRIORITY="" D + .. S DATE="" + .. F S DATE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE)) Q:DATE="" D + ... I DATE>START Q + ... S NODE="" + ... F S NODE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE,NODE)) Q:NODE="" D + .... S ^TMP("ORWGRPC TEMP",$J,ITEM,DATE,NODE)="" + S ICD9="" + F S ICD9=$O(^TMP("ORWGRPC TEMP",$J,ICD9)) Q:ICD9="" D + . S DATE="" + . F S DATE=$O(^TMP("ORWGRPC TEMP",$J,ICD9,DATE)) Q:DATE="" D + .. S NODE="" + .. F S NODE=$O(^TMP("ORWGRPC TEMP",$J,ICD9,DATE,NODE)) Q:NODE="" D + ... D PROB^ORWGAPIA(.PROB,.PSTATUS,.PROBDX,.DTONSET,.DTRESOLV,NODE) + ... S RESULT=9000011_U_ITEM_U_DTONSET_U_DATE2_U_$$EXT^ORWGAPIX(PSTATUS,9000011,.12) + ... D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) + K ^TMP("ORWGRPC TEMP",$J) + Q + ; +PROBX(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR + D PROBX4^ORWGAPID(.DATA,ITEM,START,DFN,.CNT,.TMP) + Q + ; +PROC(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR + N DATE,DATE2,NODE,RESULT,TYPE,VALUE K VALUE + S DATE2="",CNT=$G(CNT) + S TYPE="" + F S TYPE=$O(^PXRMINDX(9000010.18,"PPI",DFN,TYPE)) Q:TYPE="" D + . S DATE="" + . F S DATE=$O(^PXRMINDX(9000010.18,"PPI",DFN,TYPE,ITEM,DATE)) Q:DATE="" D + .. I DATE>START Q + .. S NODE="" + .. F S NODE=$O(^PXRMINDX(9000010.18,"PPI",DFN,TYPE,ITEM,DATE,NODE)) Q:NODE="" D + ... D CPT^ORWGAPIA(NODE,.VALUE) + ... S VALUE=VALUE("PRINCIPAL PROCEDURE"),VALUE=VALUE_U_$$EVALUE^ORWGAPIU(VALUE,9000010.18,.07) + ... S RESULT=9000010.18_U_ITEM_U_DATE_U_DATE2_U_VALUE + ... D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) + Q + ; +SKIN(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR + N DATE,DATE2,NODE,RESULT,VALUE K VALUE + S DATE="",DATE2="",CNT=$G(CNT) + F S DATE=$O(^PXRMINDX(9000010.12,"PI",DFN,ITEM,DATE)) Q:DATE="" D + . I DATE>START Q + . S NODE="" + . F S NODE=$O(^PXRMINDX(9000010.12,"PI",DFN,ITEM,DATE,NODE)) Q:NODE="" D + .. D SKIN^ORWGAPIA(NODE,.VALUE) + .. S VALUE=$G(VALUE("VALUE")),VALUE=VALUE_U_$$EVALUE^ORWGAPIU(VALUE,9000010.12,.04) + .. S CNT=CNT+1 + .. S RESULT=9000010.12_U_ITEM_U_DATE_U_DATE2_U_VALUE + .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) + Q + ; +SURG(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR + N CASE,DATE,DATE2,NUM,PROC,RESULT,RESULTS,SURG,SURGPROC,VALUE K SURG,SURGPROC + S DATE2="",CNT=$G(CNT) + D SURG^ORWGAPIA(.SURG,DFN) + K SURG(0),SURG(1) + S ITEM=$$UP^ORWGAPIX(ITEM) + S NUM=0 + S CASE=0 + F S CASE=$O(SURG(CASE)) Q:CASE<1 D + . S RESULTS=SURG(CASE) + . S PROC=$P(RESULTS,U,3) + . I '$L(PROC) Q + . S PROC=$$UP^ORWGAPIX(PROC) + . I PROC'=ITEM Q + . S NUM=NUM+1 + . S SURGPROC(PROC,NUM)=RESULTS + K SURG + S PROC="" + F S PROC=$O(SURGPROC(PROC)) Q:PROC="" D + . S NUM=0 + . F S NUM=$O(SURGPROC(PROC,NUM)) Q:NUM<1 D + .. S RESULTS=SURGPROC(PROC,NUM) + .. S DATE=$P(RESULTS,U,5) + .. I DATE>START Q + .. S VALUE="" + .. S RESULT=130_U_PROC_U_DATE_U_DATE2_U_VALUE + .. S CNT=CNT+1 + .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) + Q + ; +TREAT(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR + N DATE,DATE2,NODE,RESULT,VALUE + S DATE="",DATE2="",CNT=$G(CNT) + S NODE="" + F S NODE=$O(^AUPNVTRT("C",DFN,NODE)) Q:NODE="" D + . I '$D(^AUPNVTRT("B",ITEM,NODE)) Q + . S DATE=+$G(^AUPNVSIT(+$P($G(^AUPNVTRT(NODE,0)),U,3),0)) I 'DATE Q + . I DATE>START Q + . S VALUE=+$P($G(^AUPNVTRT(NODE,0)),U,4) + . S CNT=CNT+1 + . S RESULT=9000010.15_U_ITEM_U_DATE_U_DATE2_U_VALUE + . D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) + Q + ; +VISIT(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR + N DATE,DATE2,NODE,NUM,RESULT,VALUE + S DATE="",DATE2="",CNT=$G(CNT) + F S DATE=$O(^AUPNVSIT("AET",DFN,DATE)) Q:DATE="" D + . I DATE>START Q + . S NODE="" + . F S NODE=$O(^AUPNVSIT("AET",DFN,DATE,ITEM,NODE)) Q:NODE="" D + .. S NUM=0 + .. F S NUM=$O(^AUPNVSIT("AET",DFN,DATE,ITEM,NODE,NUM)) Q:NUM="" D + ... S DATE2=+$P($G(^AUPNVSIT(NUM,0)),U,18) + ... I 'DATE2 S DATE2=DATE+.01 + ... I +$E($P(DATE2,".",2),1,2)>24 S DATE2=(DATE\1)+.2359 + ... S VALUE="" + ... S CNT=CNT+1 + ... S RESULT=9000010_U_ITEM_U_DATE_U_DATE2_U_VALUE + ... D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) + Q + ; +VITAL(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR + I ITEM=99999 D BMIDATA^ORWGAPIX(.DATA,ITEM,START,DFN,.CNT,TMP) Q + N DATE,DATE2,NODE,RESULT,VALUE K VALUE + S DATE="",DATE2="",CNT=$G(CNT) + F S DATE=$O(^PXRMINDX(120.5,"PI",DFN,ITEM,DATE)) Q:DATE="" D + . I DATE>START Q + . S NODE="" + . F S NODE=$O(^PXRMINDX(120.5,"PI",DFN,ITEM,DATE,NODE)) Q:NODE="" D + .. D VITAL^ORWGAPIA(.VALUE,NODE) S VALUE=$P($G(VALUE(7)),U) + .. I $P($G(VALUE(3)),U,2)="PAIN",VALUE=99 S VALUE="(99)" + .. S RESULT=120.5_U_ITEM_U_DATE_U_DATE2_U_VALUE + .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) + Q + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPIA.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPIA.m index b3f22b95..6156191e 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPIA.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPIA.m @@ -1,196 +1,315 @@ -ORWGAPIA ; SLC/STAFF - Graph Application Calls ;2/22/07 11:16 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,251,260,243**;Dec 17, 1997;Build 242 - ; -ADMITX(DFN) ; $$(dfn) -> 1 if patient has data else 0 - Q $O(^DGPM("C",+$G(DFN),0))>0 - ; -ALLERGYX(DFN) ; $$(dfn) -> 1 if patient has data else 0 - Q $O(^GMR(120.8,"B",+$G(DFN),0))>0 - ; -ALLG(IEN) ; $$(ien) -> external display of allergies - I IEN Q $P($G(^GMRD(120.83,IEN,0)),U) ; this is for rxn, allergy is free text - Q IEN - ; -CPT(NODE,ORVALUE,VALUES) ; from ORWGAPI4 - D VCPT^PXPXRM(NODE,.ORVALUE) - S VALUES=$$DATA^ORWGAPIW(.ORVALUE) ;***************************** - Q - ; -DISCH(IEN) ; $$(pt movement ien) -> discharge date - Q $P($G(^DGPM(+$P($G(^DGPM(+$G(IEN),0)),U,17),0)),U) - ; -DOCCLASS(DOCTYPE) ; $$(doc type) -> ien of tiu doc class - N CONSULTS - S DOCTYPE=$E(DOCTYPE,1) - I DOCTYPE="P" Q 3 - I DOCTYPE="D" Q 244 - I DOCTYPE="C" D CNSLCLAS^TIUSRVD(.CONSULTS) Q CONSULTS - Q 0 - ; -EDU(NODE,ORVALUE,VALUES) ; from ORWGAPI4 - D VPEDU^PXPXRM(NODE,.ORVALUE) - S VALUES=$$DATA^ORWGAPIW(.ORVALUE) ;***************************** - Q - ; -EXAM(NODE,ORVALUE,VALUES) ; from ORWGAPI4 - D VXAM^PXPXRM(NODE,.ORVALUE) - S VALUES=$$DATA^ORWGAPIW(.ORVALUE) ;***************************** - Q - ; -GETTIU(ORDATA,IEN) ; from ORWGAPID - D TGET^TIUSRVR1(.ORDATA,IEN) - Q - ; -HF(NODE,ORVALUE,VALUES) ; from ORWGAPI4 - D VHF^PXPXRM(NODE,.ORVALUE) - S VALUES=$$DATA^ORWGAPIW(.ORVALUE) ;***************************** - Q - ; -ICD0(IEN) ; $$(ien) -> external display of IDC0 - Q $P($G(^ICD0(IEN,0)),U)_" "_$P($G(^ICD0(IEN,0)),U,4) - ; -ICD9(IEN) ; $$(ien) -> external display of IDC9 - Q $P($G(^ICD9(IEN,0)),U)_" "_$P($G(^ICD9(IEN,0)),U,3) - ; -ICPT(IEN,CSD) ; $$(ien) -> external display of CPT - N X S X=$$CPT^ICPTCOD($G(IEN),$G(CSD)) - Q $P(X,U,2)_" "_$E($P(X,U,3),1,30) - ; -IMM(NODE,ORVALUE,VALUES) ; from ORWGAPI4 - D VIMM^PXPXRM(NODE,.ORVALUE) - S VALUES=$$DATA^ORWGAPIW(.ORVALUE) ;***************************** - Q - ; -ISA(USER,CLASS,ORERR) ; $$(user,user class,err) -> 1 if user in class, else 0 - Q $$ISA^USRLM(USER,CLASS,.ORERR) - ; -LOS(DGPMIFN) ; $$(pt movement ien) -> length of stay - N X D ^DGPMLOS - Q +$P($G(X),U,5) - ; -MEDICINE(ARRAY,DFN) ; - N DATE,FILE,IEN,NAME,NUM,REF,VALUES,XREF - K ARRAY,^TMP("MCAR",$J),^TMP("OR",$J,"MCAR") - D FILE^ORWGAPIU(690,.REF,.XREF) - I '$L(REF) Q - I $E(REF,$L(REF))="," S REF=$E(REF,1,$L(REF)-1)_")" - I $E(REF,$L(REF))="(" S REF=$P(REF,"(") - D EN^MCARPS2(DFN) - S NUM=0 - F S NUM=$O(^TMP("OR",$J,"MCAR","OT",NUM)) Q:NUM<1 D - . S VALUES=^TMP("OR",$J,"MCAR","OT",NUM) - . S DATE=$$DATETFM^ORWGAPIW($P(VALUES,U,6)) - . S NAME=$P(VALUES,U) I '$L(NAME) Q - . S IEN=+$O(@REF@(XREF,NAME,"")) - . I DATE,IEN S ARRAY(IEN,DATE)=NAME - K ^TMP("MCAR",$J),^TMP("OR",$J,"MCAR") - Q - ; -MEDVAL(VAL) ; - N IEN,NAME,NAMES,REF,SEQ,XREF K NAMES,VAL - D FILE^ORWGAPIU(690,.REF,.XREF) - I '$L(REF) Q - I $E(REF,$L(REF))="," S REF=$E(REF,1,$L(REF)-1)_")" - I $E(REF,$L(REF))="(" S REF=$P(REF,"(") - S NAME="" - F S NAME=$O(@REF@(XREF,NAME)) Q:NAME="" D - . S IEN=0 - . F S IEN=$O(@REF@(XREF,NAME,IEN)) Q:IEN<1 D - .. S NAMES(IEN)=NAME - S SEQ=0 - S IEN=0 - F S IEN=$O(NAMES(IEN)) Q:IEN<1 D - . S SEQ=SEQ+1 - . S VAL(SEQ)=690_U_IEN_U_NAMES(IEN) - Q - ; -MH(ORVALUE,NODE,VALUES) ; from ORWGAPI4 - D ENDAS^YTAPI10(.ORVALUE,NODE) - S VALUES=$$DATA^ORWGAPIW(.ORVALUE) ;***************************** - Q - ; -NOTEX(DFN) ; $$(dfn) -> 1 if patient has data else 0 - Q $$HASDOCMT^TIULX($G(DFN)) - ; -OITEM(DATA) ; API - get order display groups - from ORWGAPI - N CNT,IEN,RESULT,TMP,ZERO - D RETURN^ORWGAPIW(.TMP,.DATA) - S CNT=0 - S IEN=0 - F S IEN=$O(^ORD(100.98,IEN)) Q:IEN<1 D - . S ZERO=$G(^ORD(100.98,IEN,0)) I '$L(ZERO) Q - . S RESULT="100.98^"_IEN_U_$P(ZERO,U)_U_$P(ZERO,U,3) - . D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT) - Q - ; -POV(NODE,ORVALUE,VALUES) ; from ORWGAPI4 - D VPOV^PXPXRM(NODE,.ORVALUE) - S VALUES=$$DATA^ORWGAPIW(.ORVALUE) ;***************************** - Q - ; -PROB(GMPLLEX,GMPLSTAT,GMPLICD,GMPLODAT,GMPLXDAT,NODE) ; from ORWGAPI4 - N GMPLPNAM,GMPLDLM,GMPLTXT,GMPLCOND,GMPLPRV,GMPLPRIO - D CALL2^GMPLUTL3(NODE) - Q - ; -PTF(NODE,ORVALUE,VALUES) ; from ORWGAPI3, ORWGAPI4 - D PTF^DGPTPXRM(NODE,.ORVALUE) - S VALUES=$$DATA^ORWGAPIW(.ORVALUE) ;***************************** - Q - ; -RAD(NODE,ORVALUE,VALUES) ; from ORWGAPI3 - D EN1^RAPXRM(NODE,.ORVALUE) - S VALUES=$$DATA^ORWGAPIW(.ORVALUE) ;***************************** - Q - ; -SKIN(NODE,ORVALUE,VALUES) ; from ORWGAPI4 - D VSKIN^PXPXRM(NODE,.ORVALUE) - S VALUES=$$DATA^ORWGAPIW(.ORVALUE) ;***************************** - Q - ; -SURG(ORSURG,DFN,VALUES) ; from ORWGAPI2, ORWGAPI4 - D GET^SROGTSR(.ORSURG,DFN) - S VALUES=$$DATA^ORWGAPIW(.ORSURG) ;***************************** - Q - ; -SURGX(DFN) ; $$(dfn) -> 1 if patient has data else 0 - Q $O(^SRF("B",+$G(DFN),0))>0 - ; -TAX(IEN) ; $$(ien) -> external display of reminder taxonomy - Q $P($G(^PXD(811.2,+$G(IEN),0)),U) - ; -TITLE(DOCTYPE) ; $$(document type) -> parent ien^parent^parent abbrev - N IEN,RESULTS K RESULTS - S DOCTYPE=+$G(^TIU(8925,+$G(DOCTYPE),0)) - S IEN=+$$DOCCLASS^TIULC1(DOCTYPE) I 'IEN Q "" - D GETDATA^ORWGAPIX(.RESULTS,8925.1,".01;.02",IEN) - I '$L($G(RESULTS(.01))) Q "" - Q IEN_U_"note - "_RESULTS(.01)_U_$G(RESULTS(.02)) - ; -TIU(ORVALUE,DOCIEN,ONE,DFN,OLDEST,NEWEST) ; from ORWGAPI1, ORWGAPI3 - D CONTEXT^TIUSRVLO(.ORVALUE,DOCIEN,ONE,DFN,$G(OLDEST),$G(NEWEST)) - Q - ; -TIUTITLE(DATA) ; API - get tiu document titles - from ORWGAPI - N CNT,IEN,RESULT,RESULTS,TMP K ^TMP("TIUTLS",$J) - D RETURN^ORWGAPIW(.TMP,.DATA) - S CNT=0 - D TITLIENS^TIULX - S IEN=0 - F S IEN=$O(^TMP("TIUTLS",$J,IEN)) Q:IEN<1 D - . K RESULTS - . D GETDATA^ORWGAPIX(.RESULTS,8925.1,".01;.02",IEN) - . I '$L($G(RESULTS(.01))) Q - . S RESULT="8925.1^"_IEN_U_RESULTS(.01)_U_$G(RESULTS(.02)) - . D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT) - K ^TMP("TIUTLS",$J) - Q - ; -VISITX(DFN) ; $$(dfn) -> 1 if patient has data else 0 - Q $O(^AUPNVSIT("AET",+$G(DFN),0))>0 - ; -VITAL(ORVALUE,NODE,VALUES) ; from ORWGAPI4 - D EN^GMVPXRM(.ORVALUE,NODE) - S VALUES=$$DATA^ORWGAPIW(.ORVALUE) ;***************************** - Q - ; +ORWGAPIA ; SLC/STAFF - Graph Application Calls ;11/1/06 12:49 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,251,260**;Dec 17, 1997;Build 26 + ; +AA(IEN) ; $$(ien) -> external display of accession area + Q $P($G(^LRO(68,IEN,0)),U) +AALAB(TEST) ; $$(lab test) -> accession ien^acc name^acc abbrev + N AA,DIV + S TEST=+$G(TEST) + S DIV=+$G(DUZ(2)) + S AA=+$P($G(^LAB(60,+TEST,8,DIV,0)),U,2) + I AA Q AA_U_$$ACCLAB(AA) + S AA=+$P($G(^LAB(60,+TEST,8,+$O(^LAB(60,+TEST,8,0)),0)),U,2) + I AA Q AA_U_$$ACCLAB(AA) + Q "" +ACC(DATA) ; API - get accession areas - from ORWGAPI + N CNT,IEN,TMP,RESULT,ZERO + D RETURN^ORWGAPIU(.TMP,.DATA) + S CNT=0 + S IEN=0 + F S IEN=$O(^LRO(68,IEN)) Q:IEN<1 D + . S ZERO=$G(^LRO(68,IEN,0)) I '$L(ZERO) Q + . S RESULT="68^"_IEN_U_$P(ZERO,U)_U_$P(ZERO,U,11) + . D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) + Q +ACCLAB(AA) ; $$(accession ien) -> acc name^acc abbrev + N ZERO + S ZERO=$G(^LRO(68,AA,0)) I '$L(ZERO) Q "" + Q "lab - "_$P(ZERO,U)_U_$P(ZERO,U,11) +ADDDRUG(NUM1) ; $$(additive) -> drug in 50 else "" + N RESULT K ^TMP($J,"RX") + I '$G(IEN) Q "" + D ZERO^PSS52P6(IEN,,,"RX") + S RESULT=$P($G(^TMP($J,"RX",IEN,1)),U) + K ^TMP($J,"RX") + Q RESULT +ALLG(IEN) ; $$(ien) -> external display of allergies + I IEN Q $P($G(^GMRD(120.83,IEN,0)),U) ; this is for rxn, allergy is free text + Q IEN +CPT(NODE,ORVALUE) ; from ORWGAPI4 + D VCPT^PXPXRM(NODE,.ORVALUE) + Q +DC(IEN) ; $$(ien) -> external display of drug class + N RESULT K ^TMP($J,"RX") + I '$G(IEN) Q "" + D IEN^PSN50P65(IEN,,"RX") + S RESULT=$G(^TMP($J,"RX",IEN,1)) + K ^TMP($J,"RX") + Q RESULT +DISCH(IEN) ; $$(pt movement ien) -> discharge date + Q $P($G(^DGPM(+$P($G(^DGPM(+$G(IEN),0)),U,17),0)),U) +DOCCLASS(DOCTYPE) ; $$(doc type) -> ien of tiu doc class + N CONSULTS + S DOCTYPE=$E(DOCTYPE,1) + I DOCTYPE="P" Q 3 + I DOCTYPE="D" Q 244 + I DOCTYPE="C" D CNSLCLAS^TIUSRVD(.CONSULTS) Q CONSULTS + Q 0 +DRGCLASS(DRUG) ; $$(drug) -> drug class^classification + N RESULT K ^TMP($J,"RX") + I '$G(DRUG) Q "" + D DATA^PSS50(DRUG,,,,,"RX") + S RESULT=+$G(^TMP($J,"RX",DRUG,25)) + K ^TMP($J,"RX") + Q RESULT_U_"drug - "_$$DC(RESULT) +DRUG(NUM) ; $$(bcma entry) -> drug in 50 else "" + N DONE,DRUG,NUM1 + S DONE=0,NUM=+$G(NUM) + S NUM1=0 + F S NUM1=$O(^PSB(53.79,NUM,.5,"B",NUM1)) Q:NUM1<1 S DONE=1 Q + I DONE Q NUM1 + S DRUG=0 + S NUM1=0 + F S NUM1=$O(^PSB(53.79,NUM,.6,"B",NUM1)) Q:NUM1<1 D I DONE Q + . S DRUG=$$ADDDRUG(NUM1) + . I DRUG S DONE=1 + I DONE Q DRUG + S DRUG=0 + S NUM1=0 + F S NUM1=$O(^PSB(53.79,NUM,.7,"B",NUM1)) Q:NUM1<1 D I DONE Q + . S DRUG=$$SOLDRUG(NUM1) + . I DRUG S DONE=1 + I DONE Q DRUG + Q "" +DRUGC(VALUES) ; API - get drug classes - from ORWGAPI + N CLASS,IEN,NUM,ROOT K VALUES + S NUM=0 + S ROOT=$$ROOT^PSN50P65(1) + S CLASS="" + F S CLASS=$O(@ROOT@(CLASS)) Q:CLASS="" D + . S IEN=0 + . F S IEN=$O(@ROOT@(CLASS,IEN)) Q:IEN="" D + .. S NUM=NUM+1 + .. S VALUES(NUM)="50.605^"_IEN_U_CLASS + M ^TMP("ORWGRPC",$J)=VALUES K VALUES + Q +EDU(NODE,ORVALUE) ; from ORWGAPI4 + D VPEDU^PXPXRM(NODE,.ORVALUE) + Q +EXAM(NODE,ORVALUE) ; from ORWGAPI4 + D VXAM^PXPXRM(NODE,.ORVALUE) + Q +GETTIU(ORDATA,IEN) ; from ORWGAPID + D TGET^TIUSRVR1(.ORDATA,IEN) + Q +HF(NODE,ORVALUE) ; from ORWGAPI4 + D VHF^PXPXRM(NODE,.ORVALUE) + Q +ICD0(IEN) ; $$(ien) -> external display of IDC0 + Q $P($G(^ICD0(IEN,0)),U)_" "_$P($G(^ICD0(IEN,0)),U,4) +ICD9(IEN) ; $$(ien) -> external display of IDC9 + Q $P($G(^ICD9(IEN,0)),U)_" "_$P($G(^ICD9(IEN,0)),U,3) +ICPT(IEN,CSD) ; $$(ien) -> external display of CPT + N X S X=$$CPT^ICPTCOD($G(IEN),$G(CSD)) + Q $P(X,U,2)_" "_$E($P(X,U,3),1,30) +IMM(NODE,ORVALUE) ; from ORWGAPI4 + D VIMM^PXPXRM(NODE,.ORVALUE) + Q +INSIG(NODE) ; $$(node) -> sig + N DFN,DNUM,IEN,LNUM,SIG,SUB ; replace this code in v27 with INSIG^ORWGAPIX + S DFN=+$G(NODE) + S SUB=$P($G(NODE),";",2) + S IEN=+$P($G(NODE),";",3) + S SIG="" + I SUB=5 D + . S LNUM=$G(^PS(55,DFN,5,IEN,0)) + . S DNUM=$G(^PS(55,DFN,5,IEN,.2)) + . I $L(DNUM),$L(LNUM) D + .. S SIG=" Give: "_$$EXT^ORWGAPIX($P(LNUM,U,3),55.06,3) + .. S SIG=SIG_" "_$$EXT^ORWGAPIX($P(LNUM,U,7),55.06,7) + I SUB="IV" D + . S LNUM=$G(^PS(55,DFN,"IV",IEN,0)) + . S DNUM=$G(^PS(55,DFN,"IV",IEN,.2)) + . I $L(DNUM),$L(LNUM) D + .. S SIG=" Give: "_$P(DNUM,U,2) + .. S SIG=SIG_" "_$$EXT^ORWGAPIX($P(LNUM,U,2),55.01,.02)_" "_$P(LNUM,U,9) + Q SIG +ISA(USER,CLASS,ORERR) ; $$(user,user class,err) -> 1 if user in class, else 0 + Q $$ISA^USRLM(USER,CLASS,.ORERR) +LAB(ORVALUE,NODE,ITEM) ; from ORWGAPI3 + D LRPXRM^LRPXAPI(.ORVALUE,NODE,ITEM,"VSC") + Q +LABNAME(Y) ; $$(item ien) -> item name + I $P(Y,";")="A",$P(Y,";",2)="S" Q $P(Y,".",2,99) + Q $$ITEMNM^LRPXAPIU(Y) +LABSUM(ORDATA,DFN,DATE1,DATE2,ORSUB) ; from ORWGAPID + D EN^LR7OSUM(.ORDATA,DFN,DATE1,DATE2,,80,.ORSUB) + Q +LOS(DGPMIFN) ; $$(pt movement ien) -> length of stay + N X D ^DGPMLOS + Q +$P($G(X),U,5) +LRDFN(DFN) ; $$(dfn) -> lrdfn + Q $$LRDFN^LRPXAPIU(DFN) +LRIDT(LRDT) ; $$(date) -> inverse date + Q $$LRIDT^LRPXAPIU(LRDT) +MEDICINE(ARRAY,DFN) ; + N DATE,FILE,IEN,NAME,NUM,REF,VALUES,XREF + K ARRAY,^TMP("MCAR",$J),^TMP("OR",$J,"MCAR") + D FILE^ORWGAPIU(690,.REF,.XREF) + I '$L(REF) Q + I $E(REF,$L(REF))="," S REF=$E(REF,1,$L(REF)-1)_")" + I $E(REF,$L(REF))="(" S REF=$P(REF,"(") + D EN^MCARPS2(DFN) + S NUM=0 + F S NUM=$O(^TMP("OR",$J,"MCAR","OT",NUM)) Q:NUM<1 D + . S VALUES=^TMP("OR",$J,"MCAR","OT",NUM) + . S DATE=$$DATETFM^ORWGAPIU($P(VALUES,U,6)) + . S NAME=$P(VALUES,U) I '$L(NAME) Q + . S IEN=+$O(@REF@(XREF,NAME,"")) + . I DATE,IEN S ARRAY(IEN,DATE)=NAME + K ^TMP("MCAR",$J),^TMP("OR",$J,"MCAR") + Q +MEDVAL(VAL) ; + N IEN,NAME,NAMES,REF,SEQ,XREF K NAMES,VAL + D FILE^ORWGAPIU(690,.REF,.XREF) + I '$L(REF) Q + I $E(REF,$L(REF))="," S REF=$E(REF,1,$L(REF)-1)_")" + I $E(REF,$L(REF))="(" S REF=$P(REF,"(") + S NAME="" + F S NAME=$O(@REF@(XREF,NAME)) Q:NAME="" D + . S IEN=0 + . F S IEN=$O(@REF@(XREF,NAME,IEN)) Q:IEN<1 D + .. S NAMES(IEN)=NAME + S SEQ=0 + S IEN=0 + F S IEN=$O(NAMES(IEN)) Q:IEN<1 D + . S SEQ=SEQ+1 + . S VAL(SEQ)=690_U_IEN_U_NAMES(IEN) + Q +MH(ORVALUE,NODE) ; from ORWGAPI4 + D ENDAS^YTAPI10(.ORVALUE,NODE) + Q +NVASIG(NODE) ; $$(node) -> sig on non-va drug + N RESULTS,SIG K RESULTS + I '$L(NODE) Q "" + D RXNVA(NODE,.RESULTS) + S SIG=RESULTS("DOSAGE") + S SIG=SIG_" "_RESULTS("MEDICATION ROUTE") + S SIG=SIG_" "_RESULTS("SCHEDULE") + Q SIG +OITEM(DATA) ; API - get order display groups - from ORWGAPI + N CNT,IEN,RESULT,TMP,ZERO + D RETURN^ORWGAPIU(.TMP,.DATA) + S CNT=0 + S IEN=0 + F S IEN=$O(^ORD(100.98,IEN)) Q:IEN<1 D + . S ZERO=$G(^ORD(100.98,IEN,0)) I '$L(ZERO) Q + . S RESULT="100.98^"_IEN_U_$P(ZERO,U)_U_$P(ZERO,U,3) + . D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) + Q +POINAME(IEN) ; $$(poi entry) - > name and dosage form else "" + N NAME,RESULT K ^TMP($J,"RX") + I '$G(IEN) Q "" + D ZERO^PSS50P7(IEN,,,"RX") + S NAME=$P($G(^TMP($J,"RX",IEN,.01)),U) + S NAME=NAME_" "_$P($G(^TMP($J,"BOB",IEN,.02)),U,2) + K ^TMP($J,"RX") + I NAME'=" " Q NAME + Q "" +POV(NODE,ORVALUE) ; from ORWGAPI4 + D VPOV^PXPXRM(NODE,.ORVALUE) + Q +PROB(GMPLLEX,GMPLSTAT,GMPLICD,GMPLODAT,GMPLXDAT,NODE) ; from ORWGAPI4 + N GMPLPNAM,GMPLDLM,GMPLTXT,GMPLCOND,GMPLPRV,GMPLPRIO + D CALL2^GMPLUTL3(NODE) + Q +PTF(NODE,ORVALUE) ; from ORWGAPI3, ORWGAPI4 + D PTF^DGPTPXRM(NODE,.ORVALUE) + Q +RAD(NODE,ORVALUE) ; from ORWGAPI3 + D EN1^RAPXRM(NODE,.ORVALUE) + Q +RXIN(NODE,ORVALUE) ; from ORWGAPI3 + D OEL^PSJPXRM1(NODE,.ORVALUE) + Q +RXNVA(NODE,ORVALUE,XSTART,XSTOP) ; from ORWGAPI1, ORWGAPI3, ORWGAPID + S XSTART=1,XSTOP=1 + D NVA^PSOPXRM1(NODE,.ORVALUE) + I '$G(ORVALUE("START DATE")) D + . S ORVALUE("START DATE")=$G(ORVALUE("DOCUMENTED DATE")) + . S XSTART=0 + I '$G(ORVALUE("DISCONTINUED DATE")) D + . S XSTOP=0 + Q +RXOUT(NODE,ORVALUE) ; from ORWGAPI3 + D PSRX^PSOPXRM1(NODE,.ORVALUE) + Q +SIG(DFN,RXIEN) ; $$(dfn,prescription ien) -> sig + N LNUM,SIG K ^TMP($J,"RX") + S RXIEN=+$G(RXIEN) + D RX^PSO52API(DFN,"RX",RXIEN,,"M",,) + S SIG="" + S LNUM=0 + F S LNUM=$O(^TMP($J,"RX",DFN,RXIEN,"M",LNUM)) Q:LNUM<1 D + . S SIG=SIG_$G(^TMP($J,"RX",DFN,RXIEN,"M",LNUM,0))_" " + I $L(SIG) S SIG=" Sig: "_$$LOW^ORWGAPIX(SIG) + K ^TMP($J,"RX") + Q SIG +SKIN(NODE,ORVALUE) ; from ORWGAPI4 + D VSKIN^PXPXRM(NODE,.ORVALUE) + Q +SOLDRUG(NUM1) ; $$(iv solution) -> drug in 50 else "" + N RESULT K ^TMP($J,"RX") + I '$G(IEN) Q "" + D ZERO^PSS52P7(IEN,,,"RX") + S RESULT=$P($G(^TMP($J,"RX",IEN,1)),U) + K ^TMP($J,"RX") + Q RESULT +SURG(ORSURG,DFN) ; from ORWGAPI2, ORWGAPI4 + D GET^SROGTSR(.ORSURG,DFN) + Q +TAX(IEN) ; $$(ien) -> external display of reminder taxonomy + Q $P($G(^PXD(811.2,+$G(IEN),0)),U) +TITLE(DOCTYPE) ; $$(document type) -> parent ien^parent^parent abbrev + N IEN,RESULTS K RESULTS + S DOCTYPE=+$G(^TIU(8925,+$G(DOCTYPE),0)) + S IEN=+$$DOCCLASS^TIULC1(DOCTYPE) I 'IEN Q "" + D GETDATA^ORWGAPIX(.RESULTS,8925.1,".01;.02",IEN) + I '$L($G(RESULTS(.01))) Q "" + Q IEN_U_"note - "_RESULTS(.01)_U_$G(RESULTS(.02)) +TIU(ORVALUE,DOCIEN,ONE,DFN,OLDEST,NEWEST) ; from ORWGAPI1, ORWGAPI3 + D CONTEXT^TIUSRVLO(.ORVALUE,DOCIEN,ONE,DFN,$G(OLDEST),$G(NEWEST)) + Q +TIUTITLE(DATA) ; API - get tiu document titles - from ORWGAPI + N CNT,IEN,RESULT,RESULTS,TMP + D RETURN^ORWGAPIU(.TMP,.DATA) + S CNT=0 + S IEN=0 + F S IEN=$O(^TIU(8925.1,IEN)) Q:IEN<1 D + . I $P($G(^TIU(8925.1,IEN,0)),U,4)'="DOC" Q + . K RESULTS + . D GETDATA^ORWGAPIX(.RESULTS,8925.1,".01;.02",IEN) + . I '$L($G(RESULTS(.01))) Q + . S RESULT="8925.1^"_IEN_U_RESULTS(.01)_U_$G(RESULTS(.02)) + . D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) + Q +VITAL(ORVALUE,NODE) ; from ORWGAPI4 + D EN^GMVPXRM(.ORVALUE,NODE) + Q + ; $$(dfn) -> 1 if patient has data else 0 +ADMITX(DFN) ; + Q $O(^DGPM("C",+$G(DFN),0))>0 +ALLERGYX(DFN) ; + Q $O(^GMR(120.8,"B",+$G(DFN),0))>0 +BCMAX(DFN) ; + Q $O(^PSB(53.79,"B",+$G(DFN),0))>0 +NOTEX(DFN) ; + Q $O(^TIU(8925,"C",+$G(DFN),0))>0 +NVAX(DFN) ; + Q $L($O(^PXRMINDX("55NVA","PI",+$G(DFN),"")))>0 +SURGX(DFN) ; + Q $O(^SRF("B",+$G(DFN),0))>0 +TREATX(DFN) ; + Q $L($O(^AUPNVTRT("AA",+$G(DFN),"")))>0 +VISITX(DFN) ; + Q $O(^AUPNVSIT("AET",+$G(DFN),0))>0 diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPIB.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPIB.m index 12d190b2..3a30028e 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPIB.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPIB.m @@ -1,50 +1,49 @@ -ORWGAPIB ; SLC/STAFF - Graph Blood Bank ;12/21/05 08:21 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,243**;Dec 17, 1997;Build 242 - ; -BBITEM(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR - N DATE,IDATE,INEWEST,IOLDEST,ITEM,LRDFN,OK,RESULT - K ^TMP("ORWGRPC TEMP",$J) - S INEWEST=$$LRIDT^ORWGAPIC(NEWEST),IOLDEST=$$LRIDT^ORWGAPIC(OLDEST) - S LRDFN=$$LRDFN^ORWGAPIC(DFN) - S IDATE=0 - F S IDATE=$O(^LR(LRDFN,1.6,IDATE)) Q:IDATE<1 D - . S ITEM=+$P($G(^LR(LRDFN,1.6,IDATE,0)),U,2) - . I 'ITEM Q - . S OK=0 - . I FMT=6 D - .. Q:IDATEIOLDEST - .. S OK=1 - .. S CNT=CNT+1 - .. S RESULT="63BB"_U_ITEM - . I FMT=3 D - .. I '$D(^TMP("ORWGRPC TEMP",$J,ITEM)) D - ... S OK=1 - ... S ^TMP("ORWGRPC TEMP",$J,ITEM)="" - ... S DATE=$$LRIDT^ORWGAPIC(IDATE) - ... S CNT=CNT+1 - ... S RESULT="63BB^"_ITEM_"^^"_$P($G(^LAB(66,ITEM,0)),U)_"^^"_DATE - . I FMT=0 D - .. S OK=1 - .. S CNT=CNT+1 - .. S RESULT="63BB^"_ITEM_U_$P($G(^LAB(66,ITEM,0)),U) - . I OK D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT) - K ^TMP("ORWGRPC TEMP",$J) - Q - ; -BBDATA(DATA,ITEM,START,DFN,CNT,TMP,BACKTO) ; from ORWGAPIR - N DATE,IDATE,LRDFN,NITEM,RESULT - S LRDFN=$$LRDFN^ORWGAPIC(DFN) - S IDATE="",CNT=$G(CNT),BACKTO=+$G(BACKTO) - F S IDATE=$O(^LR(LRDFN,1.6,IDATE)) Q:IDATE="" D - . S NITEM=+$P($G(^LR(LRDFN,1.6,IDATE,0)),U,2) - . I NITEM'=ITEM Q - . S DATE=$$LRIDT^ORWGAPIC(IDATE) - . I DATE>START Q - . I DATE 1 if patient has blood bank data ,else 0 - Q $L($O(^LR(+$$LRDFN^ORWGAPIC($G(DFN)),1.6,"")))>0 - ; +ORWGAPIB ; SLC/STAFF - Graph Blood Bank ;12/21/05 08:21 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215**;Dec 17, 1997 + ; +BBITEM(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR + N DATE,IDATE,INEWEST,IOLDEST,ITEM,LRDFN,OK,RESULT + K ^TMP("ORWGRPC TEMP",$J) + S INEWEST=$$LRIDT^ORWGAPIA(NEWEST),IOLDEST=$$LRIDT^ORWGAPIA(OLDEST) + S LRDFN=$$LRDFN^ORWGAPIA(DFN) + S IDATE=0 + F S IDATE=$O(^LR(LRDFN,1.6,IDATE)) Q:IDATE<1 D + . S ITEM=+$P($G(^LR(LRDFN,1.6,IDATE,0)),U,2) + . I 'ITEM Q + . S OK=0 + . I FMT=6 D + .. Q:IDATEIOLDEST + .. S OK=1 + .. S CNT=CNT+1 + .. S RESULT="63BB"_U_ITEM + . I FMT=3 D + .. I '$D(^TMP("ORWGRPC TEMP",$J,ITEM)) D + ... S OK=1 + ... S ^TMP("ORWGRPC TEMP",$J,ITEM)="" + ... S DATE=$$LRIDT^ORWGAPIA(IDATE) + ... S CNT=CNT+1 + ... S RESULT="63BB^"_ITEM_"^^"_$P($G(^LAB(66,ITEM,0)),U)_"^^"_DATE + . I FMT=0 D + .. S OK=1 + .. S CNT=CNT+1 + .. S RESULT="63BB^"_ITEM_U_$P($G(^LAB(66,ITEM,0)),U) + . I OK D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) + K ^TMP("ORWGRPC TEMP",$J) + Q + ; +BBDATA(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR + N DATE,IDATE,LRDFN,NITEM,RESULT + S LRDFN=$$LRDFN^ORWGAPIA(DFN) + S IDATE="",CNT=$G(CNT) + F S IDATE=$O(^LR(LRDFN,1.6,IDATE)) Q:IDATE="" D + . S NITEM=+$P($G(^LR(LRDFN,1.6,IDATE,0)),U,2) + . I NITEM'=ITEM Q + . S DATE=$$LRIDT^ORWGAPIA(IDATE) + . I DATE>START Q + . S RESULT="63BB^"_ITEM_U_DATE_U + . D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) + Q + ; +BBX(DFN) ; $$(dfn) -> 1 if patient has blood bank data ,else 0 + Q $L($O(^LR(+$$LRDFN^ORWGAPIA($G(DFN)),1.6,"")))>0 + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPID.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPID.m index 62f070b4..74335a50 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPID.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPID.m @@ -1,221 +1,283 @@ -ORWGAPID ; SLC/STAFF - Graph API Details ;12/21/05 08:19 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,243**;Dec 17, 1997;Build 242 - ; -DETAILS(DATA,DFN,DATE1,DATE2,FILEITEM) ; from ORWGAPI (series click) - N ITEM,FILE,SUBHEAD,TYPEITEM K SUBHEAD,TYPEITEM - K ^TMP("LR7OGX",$J),^TMP("LRC",$J) - K ^TMP("ORLRC",$J),^TMP("PSBO",$J),^TMP("TIUVIEW",$J) - S FILE=$P(FILEITEM,U) - S ITEM=$$UP^ORWGAPIX($P(FILEITEM,U,2)) - I '$L(ITEM) Q - D - . I FILE=63 D Q - .. D INTERIM^ORWLRR(.DATA,DFN,DATE1,DATE2) - .. M ^TMP("ORWGRPC",$J)=^TMP("LR7OGX",$J,"OUTPUT") - . I FILE="63MI" D Q - .. D MICRO^ORWLRR(.DATA,DFN,DATE1,DATE2) - .. M ^TMP("ORWGRPC",$J)=^TMP("LR7OGX",$J,"OUTPUT") - . I FILE="63AP" D Q - .. S SUBHEAD("CYTOPATHOLOGY")="" - .. S SUBHEAD("SURGICAL PATHOLOGY")="" - .. S SUBHEAD("EM")="" - .. S SUBHEAD("AUTOPSY")="" - .. D LABSUM^ORWGAPIC(.DATA,DFN,DATE1,DATE2,.SUBHEAD) - .. M ^TMP("ORWGRPC",$J)=^TMP("LRC",$J) - . I FILE="63BB" D Q - .. D BLR^ORWRP1(.DATA,DFN,"",DATE1,DATE2) - .. M ^TMP("ORWGRPC",$J)=^TMP("ORLRC",$J) - . I FILE="53.79" D Q - .. ;D BCMA1^ORWRP1A(.DATA,DFN,"",DATE1,DATE2) ***** BA 12/14/07 - .. D BCMA1^ORWRP1A(.DATA,DFN,"",DATE2,DATE1) - .. M ^TMP("ORWGRPC",$J)=^TMP("PSBO",$J) - . I FILE="8925" D Q - .. D NOTE(.DATA,DFN,DATE1,DATE2,ITEM) - .. ;M ^TMP("ORWGRPC",$J)=^TMP("TIUVIEW",$J) - . S TYPEITEM(1)=FILE_"^0" - . D DETAIL(.DATA,DFN,DATE1,DATE2,.TYPEITEM) - K ^TMP("LR7OGX",$J),^TMP("LRC",$J) - K ^TMP("ORLRC",$J),^TMP("PSBO",$J),^TMP("TIUVIEW",$J) - Q - ; -DETAIL(DATA,DFN,DATE1,DATE2,TYPEITEM) ; from ORWGAPI (legend click) - N CNT,FILE,GMTSPX1,GMTSPX2,ITEM,TITEMS,TYPE - N COMP,NEWITEMS K COMP,NEWITEMS - K ^TMP("ORDATA",$J) - S DFN=+$G(DFN) I 'DFN Q - I '$L($O(TYPEITEM(0))) Q - S TYPE="" - F S TYPE=$O(TYPEITEM(TYPE)) Q:TYPE="" D - . S TITEMS=TYPEITEM(TYPE) - . S FILE=$P(TITEMS,U) I '$L(FILE) Q - . S ITEM=$P(TITEMS,U,2) I '$L(ITEM) Q - . S NEWITEMS(FILE,ITEM)="" - S CNT=0 - S FILE="" - F S FILE=$O(NEWITEMS(FILE)) Q:FILE="" D - . S CNT=CNT+1 - . S COMP(CNT)=$$COMPTYPE^ORWGAPIT(FILE) - S GMTSPX1=DATE1,GMTSPX2=DATE2 - D REPORT^ORWRP2(.DATA,.COMP,DFN) - M ^TMP("ORWGRPC",$J)=^TMP("ORDATA",$J) - ;K ^TMP("ORDATA",$J) - ;Q - ; - S CNT=0 - S TYPE="" - F S TYPE=$O(TYPEITEM(TYPE)) Q:TYPE="" D - . S TITEMS=TYPEITEM(TYPE) - . S CNT=CNT+1 - . S ^TMP("ORWGRPC",$J,CNT/10000)="~~~^"_TITEMS - ; - K ^TMP("ORDATA",$J) - Q - ; -GETDATES(DATA,REPORTID) ; from ORWGAPI - N DAT,TMP K DAT - D RETURN^ORWGAPIW(.TMP,.DATA) - S DAT(1)="S^Date Range..." - S DAT(2)="1^Today" - S DAT(3)="2^One Week" - S DAT(4)="3^Two Weeks" - S DAT(5)="4^One Month" - S DAT(6)="5^Six Months" - S DAT(7)="6^One Year" - S DAT(8)="7^Two Years" - S DAT(9)="8^All Results" - D DATES^ORWGAPIP(.DAT,REPORTID) - I TMP M ^TMP(DATA,$J)=DAT - I 'TMP M DATA=DAT - Q - ; -NOTE(DATA,DFN,DATE1,DATE2,ITEM) ; - N CNT,DATE,DOC,DOCCLASS,DOCTYPE,DUM,IEN,LINE,NUM,RESULTS K DUM - K ^TMP("TIUR",$J),^TMP("TIUVIEW",$J) - S CNT=$G(CNT) - F DOCTYPE="P","D","C" D - . S DOCCLASS=$$DOCCLASS^ORWGAPIA(DOCTYPE) - . K ^TMP("TIUR",$J) - . D TIU^ORWGAPIA(.DUM,DOCCLASS,5,DFN,DATE1,DATE2) - . S DOC=0 - . F S DOC=$O(^TMP("TIUR",$J,DOC)) Q:DOC<1 D - .. S RESULTS=^TMP("TIUR",$J,DOC) - .. S IEN=+$P(RESULTS,U) - .. K ^TMP("TIUVIEW",$J) - .. D GETTIU^ORWGAPIA(.DATA,IEN) - .. S NUM=0 - .. F S NUM=$O(^TMP("TIUVIEW",$J,NUM)) Q:NUM<1 D - ... S LINE=$G(^TMP("TIUVIEW",$J,NUM)) - ... S CNT=CNT+1 - ... S ^TMP("ORWGRPC",$J,CNT)=LINE - .. I CNT>1 D - ... S CNT=CNT+1 - ... S ^TMP("ORWGRPC",$J,CNT)=" " - ... S CNT=CNT+1 - ... S ^TMP("ORWGRPC",$J,CNT)=" " - ... S ^TMP("ORWGRPC",$J,CNT/10000)="~~~^"_^TMP("TIUR",$J,DOC) - K ^TMP("TIUR",$J),^TMP("TIUVIEW",$J) - Q - ; -TAX(DATA,ALL,REMTAX) ; from ORWGAPI - N CNT,REM,CODE,NUM,TMP - K ^TMP("ORWG TEMP",$J) - D RETURN^ORWGAPIW(.TMP,.DATA) - S CNT=0 - S REM=0 - I ALL F S REM=$O(^PXD(811.2,REM)) Q:REM<1 D TEMP(REM) - I 'ALL D - . S NUM=0 - . F S NUM=$O(REMTAX(NUM)) Q:NUM<1 D - .. S REM=REMTAX(NUM) - .. D TEMP(REM) - S CODE="" - F S CODE=$O(^TMP("ORWG TEMP",$J,CODE)) Q:CODE="" D - . D SETUP^ORWGAPIW(.DATA,CODE,TMP,.CNT) - K ^TMP("ORWG TEMP",$J) - Q - ; -TEMP(REM) ; - N NODE,NUM,SUB - I $P($G(^PXD(811.2,REM,0)),U,6)=1 Q - F SUB=80,80.1,81 D - . S NUM=0 - . F S NUM=$O(^PXD(811.3,REM,SUB,NUM)) Q:NUM<1 D - .. S NODE=+$G(^PXD(811.3,REM,SUB,NUM,0)) - .. I 'NODE Q - .. I SUB=80 D Q - ... S ^TMP("ORWG TEMP",$J,"45DX;"_NODE)="" - ... S ^TMP("ORWG TEMP",$J,"9000010.07;"_NODE)="" - ... S ^TMP("ORWG TEMP",$J,"9000011;"_NODE)="" - .. I SUB=80.1 D Q - ... S ^TMP("ORWG TEMP",$J,"45OP;"_NODE)="" - .. I SUB=81 D Q - ... S ^TMP("ORWG TEMP",$J,"9000010.18;"_NODE)="" - Q - ; -PLX2(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR - N DATE,DTONSET,DTPLUS1,DTRESOLV,NODE,PRIORITY,PROB,PROBDX,PSTATUS,RESULT,STATUS,VALUE - K ^TMP("ORWGRPC TEMP",$J) - S DTPLUS1=$$FMADD^ORWGAPIX(DT,1) - S STATUS="" - F S STATUS=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS)) Q:STATUS="" D - . S PRIORITY="" - . F S PRIORITY=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY)) Q:PRIORITY="" D - .. S ITEM="" - .. F S ITEM=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ITEM)) Q:ITEM="" D - ... S DATE="" - ... F S DATE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE)) Q:DATE="" D - .... S NODE="" - .... F S NODE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE,NODE)) Q:NODE="" D - ..... D PROB^ORWGAPIA(.PROB,.PSTATUS,.PROBDX,.DTONSET,.DTRESOLV,NODE) - ..... I 'DTRESOLV S ^TMP("ORWGRPC TEMP",$J,PROBDX,DTONSET)=DTPLUS1 Q - ..... S ^TMP("ORWGRPC TEMP",$J,PROBDX,DTONSET)=DTRESOLV - S PROB="" - F S PROB=$O(^TMP("ORWGRPC TEMP",$J,PROB)) Q:PROB="" D - . S VALUE=$$EVALUE^ORWGAPIU(PROB,9000011,.01) - . I FMT=0 D - .. S CNT=CNT+1 - .. S RESULT=9999911_U_PROB_U_VALUE - .. D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT) - . I FMT=6 D - .. S OK=0 - .. S DATE=0 - .. F S DATE=$O(^TMP("ORWGRPC TEMP",$J,PROB,DATE)) Q:DATE="" Q:DATE>NEWEST D Q:OK - ... S DTRESOLV=^TMP("ORWGRPC TEMP",$J,PROB,DATE) - ... I DTRESOLVSTART Q - ... S NODE="" - ... F S NODE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE,NODE)) Q:NODE="" D - .... S ^TMP("ORWGRPC TEMP",$J,NODE)="" - S NODE="" - F S NODE=$O(^TMP("ORWGRPC TEMP",$J,NODE)) Q:NODE="" D - . D PROB^ORWGAPIA(.PROB,.PSTATUS,.PROBDX,.DTONSET,.DTRESOLV,NODE) - . I 'DTONSET Q - . I 'DTRESOLV S DTRESOLV=DTPLUS1 - . S RESULT=9999911_U_PROBDX_U_DTONSET_U_DTRESOLV_U_$$EXT^ORWGAPIX(PSTATUS,9000011,.12) - . D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT) - K ^TMP("ORWGRPC TEMP",$J) - Q - ; +ORWGAPID ; SLC/STAFF - Graph API Details ;12/21/05 08:19 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215**;Dec 17, 1997 + ; +DETAILS(DATA,DFN,DATE1,DATE2,FILEITEM) ; from ORWGAPI (series click) + N ITEM,FILE,SUBHEAD,TYPEITEM K SUBHEAD,TYPEITEM + K ^TMP("LR7OGX",$J),^TMP("LRC",$J) + K ^TMP("ORLRC",$J),^TMP("PSBO",$J),^TMP("TIUVIEW",$J) + S FILE=$P(FILEITEM,U) + S ITEM=$$UP^ORWGAPIX($P(FILEITEM,U,2)) + I '$L(ITEM) Q + D + . I FILE=63 D Q + .. D INTERIM^ORWLRR(.DATA,DFN,DATE1,DATE2) + .. M ^TMP("ORWGRPC",$J)=^TMP("LR7OGX",$J,"OUTPUT") + . I FILE="63MI" D Q + .. D MICRO^ORWLRR(.DATA,DFN,DATE1,DATE2) + .. M ^TMP("ORWGRPC",$J)=^TMP("LR7OGX",$J,"OUTPUT") + . I FILE="63AP" D Q + .. S SUBHEAD("CYTOPATHOLOGY")="" + .. S SUBHEAD("SURGICAL PATHOLOGY")="" + .. S SUBHEAD("EM")="" + .. S SUBHEAD("AUTOPSY")="" + .. D LABSUM^ORWGAPIA(.DATA,DFN,DATE1,DATE2,.SUBHEAD) + .. M ^TMP("ORWGRPC",$J)=^TMP("LRC",$J) + . I FILE="63BB" D Q + .. D BLR^ORWRP1(.DATA,DFN,"",DATE1,DATE2) + .. M ^TMP("ORWGRPC",$J)=^TMP("ORLRC",$J) + . I FILE="53.79" D Q + .. D BCMA1^ORWRP1A(.DATA,DFN,"",DATE1,DATE2) + .. M ^TMP("ORWGRPC",$J)=^TMP("PSBO",$J) + . I FILE="8925" D Q + .. D NOTE(.DATA,DFN,DATE1,DATE2,ITEM) + .. ;M ^TMP("ORWGRPC",$J)=^TMP("TIUVIEW",$J) + . S TYPEITEM(1)=FILE_"^0" + . D DETAIL(.DATA,DFN,DATE1,DATE2,.TYPEITEM) + K ^TMP("LR7OGX",$J),^TMP("LRC",$J) + K ^TMP("ORLRC",$J),^TMP("PSBO",$J),^TMP("TIUVIEW",$J) + Q + ; +DETAIL(DATA,DFN,DATE1,DATE2,TYPEITEM) ; from ORWGAPI (legend click) + N CNT,FILE,GMTSPX1,GMTSPX2,ITEM,TITEMS,TYPE + N COMP,NEWITEMS K COMP,NEWITEMS + K ^TMP("ORDATA",$J) + S DFN=+$G(DFN) I 'DFN Q + I '$L($O(TYPEITEM(0))) Q + S TYPE="" + F S TYPE=$O(TYPEITEM(TYPE)) Q:TYPE="" D + . S TITEMS=TYPEITEM(TYPE) + . S FILE=$P(TITEMS,U) I '$L(FILE) Q + . S ITEM=$P(TITEMS,U,2) I '$L(ITEM) Q + . S NEWITEMS(FILE,ITEM)="" + S CNT=0 + S FILE="" + F S FILE=$O(NEWITEMS(FILE)) Q:FILE="" D + . S CNT=CNT+1 + . S COMP(CNT)=$$COMPTYPE^ORWGAPIT(FILE) + S GMTSPX1=DATE1,GMTSPX2=DATE2 + D REPORT^ORWRP2(.DATA,.COMP,DFN) + M ^TMP("ORWGRPC",$J)=^TMP("ORDATA",$J) + K ^TMP("ORDATA",$J) + Q + ; +NOTE(DATA,DFN,DATE1,DATE2,ITEM) ; + N CNT,DATE,DOC,DOCCLASS,DOCTYPE,DUM,IEN,LINE,NUM,RESULTS K DUM + K ^TMP("TIUR",$J),^TMP("TIUVIEW",$J) + S CNT=$G(CNT) + F DOCTYPE="P","D","C" D + . S DOCCLASS=$$DOCCLASS^ORWGAPIA(DOCTYPE) + . K ^TMP("TIUR",$J) + . D TIU^ORWGAPIA(.DUM,DOCCLASS,5,DFN,DATE1,DATE2) + . S DOC=0 + . F S DOC=$O(^TMP("TIUR",$J,DOC)) Q:DOC<1 D + .. S RESULTS=^TMP("TIUR",$J,DOC) + .. S IEN=+$P(RESULTS,U) + .. K ^TMP("TIUVIEW",$J) + .. D GETTIU^ORWGAPIA(.DATA,IEN) + .. S NUM=0 + .. F S NUM=$O(^TMP("TIUVIEW",$J,NUM)) Q:NUM<1 D + ... S LINE=$G(^TMP("TIUVIEW",$J,NUM)) + ... S CNT=CNT+1 + ... S ^TMP("ORWGRPC",$J,CNT)=LINE + .. I CNT>1 D + ... S CNT=CNT+1 + ... S ^TMP("ORWGRPC",$J,CNT)=" " + ... S CNT=CNT+1 + ... S ^TMP("ORWGRPC",$J,CNT)=" " + K ^TMP("TIUR",$J),^TMP("TIUVIEW",$J) + Q + ; +TAX(DATA,ALL,REMTAX) ; from ORWGAPI + N CNT,REM,CODE,NUM,TMP + K ^TMP("ORWG TEMP",$J) + D RETURN^ORWGAPIU(.TMP,.DATA) + S CNT=0 + S REM=0 + I ALL F S REM=$O(^PXD(811.2,REM)) Q:REM<1 D TEMP(REM) + I 'ALL D + . S NUM=0 + . F S NUM=$O(REMTAX(NUM)) Q:NUM<1 D + .. S REM=REMTAX(NUM) + .. D TEMP(REM) + S CODE="" + F S CODE=$O(^TMP("ORWG TEMP",$J,CODE)) Q:CODE="" D + . D SETUP^ORWGAPIU(.DATA,CODE,TMP,.CNT) + K ^TMP("ORWG TEMP",$J) + Q + ; +TEMP(REM) ; + N NODE,NUM,SUB + I $P($G(^PXD(811.2,REM,0)),U,6)=1 Q + F SUB=80,80.1,81 D + . S NUM=0 + . F S NUM=$O(^PXD(811.3,REM,SUB,NUM)) Q:NUM<1 D + .. S NODE=+$G(^PXD(811.3,REM,SUB,NUM,0)) + .. I 'NODE Q + .. I SUB=80 D Q + ... S ^TMP("ORWG TEMP",$J,"45DX;"_NODE)="" + ... S ^TMP("ORWG TEMP",$J,"9000010.07;"_NODE)="" + ... S ^TMP("ORWG TEMP",$J,"9000011;"_NODE)="" + .. I SUB=80.1 D Q + ... S ^TMP("ORWG TEMP",$J,"45OP;"_NODE)="" + .. I SUB=81 D Q + ... S ^TMP("ORWG TEMP",$J,"9000010.18;"_NODE)="" + Q + ; +MED1(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR + N DATE,ITEM,OK,MEDARRAY,RESULT K MEDARRAY + D MEDICINE^ORWGAPIA(.MEDARRAY,DFN) + S ITEM=0 + F S ITEM=$O(MEDARRAY(ITEM)) Q:ITEM<1 D + . S OK=0 + . I FMT=6 D + .. S DATE=OLDEST + .. F S DATE=$O(MEDARRAY(ITEM,DATE)) Q:DATE="" Q:DATE>NEWEST D Q:OK + ... S CNT=CNT+1 + ... S OK=1 + ... S RESULT=690_U_ITEM + ... D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) + . I FMT'=6 D + .. S DATE=$O(MEDARRAY(ITEM,""),-1) + .. I 'DATE Q + .. S NAME=MEDARRAY(ITEM,DATE) + .. I '$L(NAME) Q + .. S CNT=CNT+1 + .. S OK=1 + .. I FMT=3 S RESULT=690_U_ITEM_"^^"_NAME_"^^"_DATE + .. I FMT=0 S RESULT=690_U_ITEM_U_NAME + . I OK D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) + Q + ; +MED3(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPIR + N DATE,DATE2,DATESTOP,DATESTRT,DTPLUS1,NODE,RESULT,STATUS,VALUE K VALUE + D MEDICINE^ORWGAPIA(.MEDARRAY,DFN) + S ITEM=+$G(ITEM) + S CNT=$G(CNT) + S DATE="" + F S DATE=$O(MEDARRAY(ITEM,DATE)) Q:DATE="" D + . I DATE>START Q + . S RESULT=690_U_ITEM_U_DATE_"^^" + . D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) + Q + ; +NVA1(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR + N DATA,DATE,DATE1,DATESTRT,DRUG,ITEM,OK,REF,RESULT K DATA + S ITEM="" + F S ITEM=$O(^PXRMINDX("55NVA","PI",DFN,ITEM)) Q:ITEM="" D + . S OK=0 + . I FMT=6 D + .. S DATE=0 + .. F S DATE=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,DATE)) Q:DATE="" Q:DATE>NEWEST D Q:OK + ... S DATE1="" + ... F S DATE1=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,DATE,DATE1)) Q:DATE1="" D Q:OK + .... I DATE1'["U",DATE1START Q + . S DATE2="" + . F S DATE2=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,DATE1,DATE2)) Q:DATE2="" D + .. S NODE="" + .. F S NODE=$O(^PXRMINDX("55NVA","PI",DFN,ITEM,DATE1,DATE2,NODE)) Q:NODE="" D + ... D RXNVA^ORWGAPIA(NODE,.VALUE) + ... S STATUS=$G(VALUE("STATUS")) + ... S DATESTRT=+$G(VALUE("START DATE")) + ... I 'DATESTRT Q + ... S DATESTOP=+$G(VALUE("DISCONTINUED DATE")) + ... I 'DATESTOP S DATESTOP=DTPLUS1 + ... S STATUS=STATUS_" "_$$NVASIG^ORWGAPIA(NODE) + ... S RESULT="55NVA"_U_ITEM_U_DATESTRT_U_DATESTOP_U_STATUS + ... D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) + Q + ; +PLX2(ITEMS,DFN,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPIR + N DATE,DTPLUS1,ICD9,OK,PRIORITY,RESULT,STATUS + K ^TMP("ORWGRPC TEMP",$J) + S DTPLUS1=$$FMADD^ORWGAPIX(DT,1) + S STATUS="" + F S STATUS=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS)) Q:STATUS="" D + . S PRIORITY="" + . F S PRIORITY=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY)) Q:PRIORITY="" D + .. S ITEM="" + .. F S ITEM=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ITEM)) Q:ITEM="" D + ... S DATE="" + ... F S DATE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE)) Q:DATE="" D + .... S NODE="" + .... F S NODE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE,NODE)) Q:NODE="" D + ..... D PROB^ORWGAPIA(.PROB,.PSTATUS,.PROBDX,.DTONSET,.DTRESOLV,NODE) + ..... I 'DTRESOLV S ^TMP("ORWGRPC TEMP",$J,PROBDX,DTONSET)=DTPLUS1 Q + ..... S ^TMP("ORWGRPC TEMP",$J,PROBDX,DTONSET)=DTRESOLV + S PROB="" + F S PROB=$O(^TMP("ORWGRPC TEMP",$J,PROB)) Q:PROB="" D + . S VALUE=$$EVALUE^ORWGAPIU(PROB,9000011,.01) + . I FMT=0 D + .. S CNT=CNT+1 + .. S RESULT=9999911_U_PROB_U_VALUE + .. D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) + . I FMT=6 D + .. S OK=0 + .. S DATE=0 + .. F S DATE=$O(^TMP("ORWGRPC TEMP",$J,PROB,DATE)) Q:DATE="" Q:DATE>NEWEST D Q:OK + ... S DTRESOLV=^TMP("ORWGRPC TEMP",$J,PROB,DATE) + ... I DTRESOLVSTART Q + ... S NODE="" + ... F S NODE=$O(^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIORITY,ITEM,DATE,NODE)) Q:NODE="" D + .... S ^TMP("ORWGRPC TEMP",$J,NODE)="" + S NODE="" + F S NODE=$O(^TMP("ORWGRPC TEMP",$J,NODE)) Q:NODE="" D + . D PROB^ORWGAPIA(.PROB,.PSTATUS,.PROBDX,.DTONSET,.DTRESOLV,NODE) + . I 'DTONSET Q + . I 'DTRESOLV S DTRESOLV=DTPLUS1 + . S RESULT=9999911_U_PROBDX_U_DTONSET_U_DTRESOLV_U_$$EXT^ORWGAPIX(PSTATUS,9000011,.12) + . D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) + K ^TMP("ORWGRPC TEMP",$J) + Q + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPIP.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPIP.m index decc6a6a..c17f24e0 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPIP.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPIP.m @@ -1,249 +1,193 @@ -ORWGAPIP ; SLC/STAFF - Graph Parameters ;11/20/06 08:59 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,260,243**;Dec 17, 1997;Build 242 - ; -ALLVIEWS(DATA,VTYPE,USER) ; from ORWGAPI - N CNT,ENT,NUM,NUM1,PARAM,PROF,RESULT,TEST,TG,TGNUM,TGNAME,TMP,VIEW,VNUM K PROF,VIEW - D RETURN^ORWGAPIW(.TMP,.DATA) - S CNT=0 - I VTYPE=-2 D - . S ENT="SYS" - . S USER=0 - I VTYPE=-1 D - . S ENT="USR" - . I USER S ENT="USR.`"_USER - I VTYPE=-3 D Q - . ;LAB GROUPS - . I 'USER S USER=DUZ - . D TG^ORWLRR(.PROF,USER) - . S NUM=0 - . F S NUM=$O(PROF(NUM)) Q:NUM<1 D - .. S TG=PROF(NUM) - .. S TGNUM=+TG - .. S TGNAME=$P(TG,U,2) - .. ;I TGNAME[") " S TGNAME=$P(TGNAME,") ",2,99) - .. S VNUM=CNT+1 - .. S RESULT="-3^V^"_VNUM_U_TGNAME_"^^^"_USER - .. D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT) - .. K VIEW - .. D ATG^ORWLRR(.VIEW,TGNUM,USER) - .. S NUM1=0 - .. F S NUM1=$O(VIEW(NUM1)) Q:NUM1<1 D - ... S TEST=VIEW(NUM1) - ... S RESULT="-3^C^"_VNUM_U_$P(TEST,U,2)_"^63^"_+TEST_U - ... D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT) - D XGETLST^ORWGAPIX(.PROF,ENT,"ORWG GRAPH VIEW") - S NUM=0 - F S NUM=$O(PROF(NUM)) Q:NUM<1 D - . S PARAM=$P(PROF(NUM),U) - . S VNUM=CNT+1 - . S RESULT=VTYPE_"^V^"_VNUM_U_PARAM_"^^^"_USER - . D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT) - . K VIEW - . D XGETWP^ORWGAPIX(.VIEW,ENT,"ORWG GRAPH VIEW",PARAM) - . D DEFVIEWS(.DATA,.VIEW,VTYPE,VNUM,TMP,.CNT) - Q - ; -DATES(DAT,REPORTID) ; from ORWGAPI - N BEGIN,END,INFO,NEXT,PARAM1,PARAM2,RPT,START,STOP - S RPT=+$O(^ORD(101.24,"AC",+$G(REPORTID),0)) - I 'RPT Q ; RPT=1150 is exported graph report - S PARAM1=$P($G(^ORD(101.24,RPT,2)),U) - S PARAM2=$P($G(^ORD(101.24,RPT,2)),U,2) - S INFO=$$XGET^ORWGAPIX("ALL","ORWRP TIME/OCC LIMITS INDV",RPT,"I") - S BEGIN=$P(INFO,";"),START=$$DATE^ORWGAPIX(BEGIN) - S END=$P(INFO,";",2),STOP=$$DATE^ORWGAPIX(END) - I START<1 Q - I STOP<1 Q - S NEXT=1+$O(DAT(""),-1) - S DAT(NEXT)=U_BEGIN_" to "_END_"^^^"_INFO_U_START_U_STOP_U_PARAM1_U_PARAM2 - Q - ; -DEFVIEWS(DATA,VIEW,VTYPE,VNUM,TMP,CNT) ; - N FIRST,NUM,PIECE,RESULT,RESULT1,SECOND,VALUE - S NUM="" - F S NUM=$O(VIEW(NUM)) Q:NUM="" D - . S RESULT=$G(VIEW(NUM,0)) - . S PIECE=0 - . F S PIECE=PIECE+1 S VALUE=$P(RESULT,"|",PIECE) D:$L(VALUE) Q:'$L($P(RESULT,"|",PIECE+1,999)) - .. S FIRST=$P(VALUE,"~"),SECOND=$P(VALUE,"~",2) - .. I FIRST=0 D - ... I $E(SECOND,1,5)="63AP;" S RESULT1=VTYPE_"^C^"_VNUM_U_"Anatomic Path: "_$$ITEMPRFX^ORWGAPIU($E(SECOND,3,6))_" "_U_SECOND_"^0^" Q - ... I $E(SECOND,1,5)="63MI;" S RESULT1=VTYPE_"^C^"_VNUM_U_"Microbiology: "_$$ITEMPRFX^ORWGAPIU($E(SECOND,3,6))_" "_U_SECOND_"^0^" Q - ... S RESULT1=VTYPE_"^C^"_VNUM_U_$$FILENAME^ORWGAPIT(SECOND)_" "_U_SECOND_"^0^" - .. I FIRST'=0 S RESULT1=VTYPE_"^C^"_VNUM_U_$$EVALUE^ORWGAPIU(SECOND,FIRST)_U_FIRST_U_SECOND_U - .. D SETUP^ORWGAPIW(.DATA,RESULT1,TMP,.CNT) - Q - ; -DELVIEWS(DATA,NAME,PUBLIC) ; from ORWGAPI - N ERR,TMP - D RETURN^ORWGAPIW(.TMP,.DATA) - S ERR=0 - I '$L(NAME) S ERR=1 - I 'ERR D - . S NAME=$$UP^ORWGAPIX(NAME) - . I PUBLIC D XDEL^ORWGAPIX("SYS","ORWG GRAPH VIEW",NAME,.ERR) - . I 'PUBLIC D XDEL^ORWGAPIX("USR","ORWG GRAPH VIEW",NAME,.ERR) - I TMP S ^TMP(DATA,$J)=ERR,^TMP(DATA,$J,1)=ERR - I 'TMP S DATA=ERR,DATA(1)=ERR - Q - ; -GETPREF(DATA) ; from ORWGAPI - N CNT,NUM,PROF,RESULT,TMP,VAL K PROF - I '$O(^PXRMINDX(63,"PI","")) Q ; graphing is not used if no indexes - S VAL=$$XGET^ORWGAPIX("PKG","ORWG GRAPH SETTING",1,"I") - I '$L(VAL) Q ; graphing not used if no pkg param on settings - D RETURN^ORWGAPIW(.TMP,.DATA) - S PROF(2)=1 - I '$L($G(^XTMP("ORGRAPH",0))) S PROF(2)=-1 - S VAL=$$XGET^ORWGAPIX("DIV^SYS^PKG","ORWG GRAPH SETTING",1,"I") - S PROF(1)=VAL - S VAL=$$XGET^ORWGAPIX("ALL","ORWG GRAPH SETTING",1,"I") - S PROF(0)=VAL - S CNT=0 - S NUM="" - F S NUM=$O(PROF(NUM)) Q:NUM="" D - . S RESULT=$G(PROF(NUM)) - . D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT) - Q - ; -GETSIZE(DATA) ; from ORWGAPI - N CNT,NUM,PROF,RESULT,TMP K PROF - D RETURN^ORWGAPIW(.TMP,.DATA) - D XGETLST^ORWGAPIX(.PROF,"USR","ORWG GRAPH SIZING") - S CNT=0 - S NUM="" - F S NUM=$O(PROF(NUM)) Q:NUM="" D - . S RESULT=$G(PROF(NUM)) - . D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT) - Q - ; - ;GETVIEWS(DATA,ALL,PUBLIC,EXT,USER) ; from ORWGAPI - ;N CNT,NUM,PROF,RESULT,TMP,USERPRM K PROF - ;D RETURN^ORWGAPIW(.TMP,.DATA) - ;I PUBLIC D - ;. I ALL=1 D XGETLST^ORWGAPIX(.PROF,"SYS","ORWG GRAPH VIEW") ; get list of public views - ;. I ALL'=1 D XGETWP^ORWGAPIX(.PROF,"SYS","ORWG GRAPH VIEW",ALL) ; get a public view definition - ;I 'PUBLIC D - ;. S USERPRM="USR" - ;. I USER S USERPRM="USR.`"_USER - ;. I ALL=1 D XGETLST^ORWGAPIX(.PROF,USERPRM,"ORWG GRAPH VIEW") ; get list of personal views - ;. I ALL'=1 D XGETWP^ORWGAPIX(.PROF,USERPRM,"ORWG GRAPH VIEW",ALL) ; get a personal view definition - ;S CNT=0 - ;I 'EXT D Q - ;. S NUM="" - ;. F S NUM=$O(PROF(NUM)) Q:NUM="" D - ;.. I ALL=1 S RESULT=$P($G(PROF(NUM)),U) - ;.. I ALL'=1 S RESULT=$G(PROF(NUM,0)) - ;.. D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT) - ;D DEFVIEWS(.DATA,.PROF,"",TMP,.CNT) - ;Q - ; -GETVIEWS(DATA,ALL,PUBLIC,EXT,USER) ; from ORWGAPI - N CNT,FIRST,NUM,PIECE,PROF,RESULT,RESULT1,SECOND,TMP,VALUE K PROF - D RETURN^ORWGAPIW(.TMP,.DATA) - I PUBLIC D - . I ALL=1 D XGETLST^ORWGAPIX(.PROF,"SYS","ORWG GRAPH VIEW") ; get list of public views - . I ALL'=1 D XGETWP^ORWGAPIX(.PROF,"SYS","ORWG GRAPH VIEW",ALL) ; get a public view definition - I 'PUBLIC D - . S USERPRM="USR" - . I USER S USERPRM="USR.`"_USER - . I ALL=1 D XGETLST^ORWGAPIX(.PROF,USERPRM,"ORWG GRAPH VIEW") ; get list of personal views - . I ALL'=1 D XGETWP^ORWGAPIX(.PROF,USERPRM,"ORWG GRAPH VIEW",ALL) ; get a personal view definition - S CNT=0 - I 'EXT D Q - . S NUM="" - . F S NUM=$O(PROF(NUM)) Q:NUM="" D - .. I ALL=1 S RESULT=$P($G(PROF(NUM)),U) - .. I ALL'=1 S RESULT=$G(PROF(NUM,0)) - .. D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT) - S NUM="" - F S NUM=$O(PROF(NUM)) Q:NUM="" D - . S RESULT=$G(PROF(NUM,0)) - . S PIECE=0 - . F S PIECE=PIECE+1 S VALUE=$P(RESULT,"|",PIECE) D:$L(VALUE) Q:'$L($P(RESULT,"|",PIECE+1,999)) - .. S FIRST=$P(VALUE,"~"),SECOND=$P(VALUE,"~",2) - .. I FIRST=0 S CNT=CNT+1,RESULT1="0^"_SECOND_U_$$FILENAME^ORWGAPIT(SECOND)_" " - .. I FIRST'=0 S CNT=CNT+1,RESULT1=FIRST_U_SECOND_U_$$EVALUE^ORWGAPIU(SECOND,FIRST) - .. D SETUP^ORWGAPIW(.DATA,RESULT1,TMP,.CNT) - Q - ; -INISET ; from ORWGAPIU initial setup of package parameters - N ERR,RPTNUM - S RPTNUM=1150 - D SETPREF(.ERR,"63;53.79;55;55NVA;52;70;120.5|BCEFGHIKN|1|4|90|1|100||",9) ; default public settings - I '$D(^ORD(101.24,RPTNUM,0)) D ; make sure report has been added - . L +^ORD(101.24,0):20 I '$T Q - . S $P(^ORD(101.24,0),U,3)=RPTNUM,$P(^(0),U,4)=$P(^(0),U,4)+1 - . S ^ORD(101.24,RPTNUM,0)="ORWG GRAPHING^OR_GRAPHS^^2^^^1^R^^^^G^^T" - . S ^ORD(101.24,RPTNUM,2)="^^Graphing (local only)^Graphing" - . L -^ORD(101.24,0) - . D INDEX^ORWGAPIX("^ORD(101.24,",RPTNUM) - D XEN^ORWGAPIX("PKG","ORWRP REPORT LIST",12,RPTNUM) - Q - ; -PUBLIC(USER) ; from ORWGAPI - N ERR,IDX,ORSRV,USRCLASS,VAL K USRCLASS - S VAL=0 - I '$G(USER) Q VAL - S ORSRV=$$GET1^DIQ(200,DUZ,29,"I") - D XGETLST1^ORWGAPIX(.USRCLASS,"SYS","ORWG GRAPH PUBLIC EDITOR CLASS","Q",.ERR) - I ERR Q VAL - S IDX=0 - F S IDX=$O(USRCLASS(IDX)) Q:'IDX D Q:VAL - . I $$ISA^ORWGAPIA(USER,$P(USRCLASS(IDX),U,2),.ERR) S VAL=1 - Q VAL - ; -RPTPARAM(IEN) ; from ORWGAPI - N DATES,NODE,VAL - S IEN=+$G(IEN) - S VAL="" - S NODE=$$UP^XLFSTR($P($G(^ORD(101.24,IEN,2)),U,1,2)) - I $L(NODE)<2 Q VAL - Q NODE - ; -SETPREF(DATA,VAL,PUBLIC) ; from ORWGAPI - N ERR,TMP - D RETURN^ORWGAPIW(.TMP,.DATA) - S ERR=0 - I '$L(VAL) S ERR=1 - I 'ERR D - . S VAL=$$UP^ORWGAPIX(VAL) - . I PUBLIC=9 D XEN^ORWGAPIX("PKG","ORWG GRAPH SETTING",1,VAL,.ERR) ; only on postinit - . I PUBLIC D XEN^ORWGAPIX("SYS","ORWG GRAPH SETTING",1,VAL,.ERR) - . I 'PUBLIC D XEN^ORWGAPIX("USR","ORWG GRAPH SETTING",1,VAL,.ERR) - I TMP S ^TMP(DATA,$J)=ERR,^TMP(DATA,$J,1)=ERR - I 'TMP S DATA=ERR,DATA(1)=ERR - Q - ; -SETSIZE(DATA,VAL) ; from ORWGAPI - N ERR,NAME,NUM,VALUE,VALUES,TMP - D RETURN^ORWGAPIW(.TMP,.DATA) - S ERR=0 - I '$L($O(VAL(0))) S ERR=1 - I 'ERR D - . S NUM=0 - . F S NUM=$O(VAL(NUM)) Q:NUM<1 D Q:ERR - .. S VALUES=VAL(NUM) - .. S VALUES=$$UP^ORWGAPIX(VALUES) - .. S NAME=$P(VALUES,U) - .. S VALUE=$P(VALUES,U,2) - .. D XEN^ORWGAPIX("USR","ORWG GRAPH SIZING",NAME,VALUE,.ERR) - I TMP S ^TMP(DATA,$J)=ERR,^TMP(DATA,$J,1)=ERR - I 'TMP S DATA=ERR,DATA(1)=ERR - Q - ; -SETVIEWS(DATA,NAME,PUBLIC,VAL) ; from ORWGAPI - N ERR,TMP - D RETURN^ORWGAPIW(.TMP,.DATA) - S ERR=0 - I '$L(NAME) S ERR=1 - I '$L($O(VAL(""))) S ERR=1 - I 'ERR D - . S NAME=$$UP^ORWGAPIX(NAME) - . S VAL=NAME - . I PUBLIC D XEN^ORWGAPIX("SYS","ORWG GRAPH VIEW",NAME,.VAL,.ERR) - . I 'PUBLIC D XEN^ORWGAPIX("USR","ORWG GRAPH VIEW",NAME,.VAL,.ERR) - I TMP S ^TMP(DATA,$J)=ERR,^TMP(DATA,$J,1)=ERR - I 'TMP S DATA=ERR,DATA(1)=ERR - Q - ; +ORWGAPIP ; SLC/STAFF - Graph Parameters ;11/20/06 08:59 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,260**;Dec 17, 1997;Build 26 + ; +DATES(DAT,REPORTID) ; from ORWGAPI + N BEGIN,END,INFO,NEXT,PARAM1,PARAM2,RPT,START,STOP + S RPT=+$O(^ORD(101.24,"AC",+$G(REPORTID),0)) + I 'RPT Q ; RPT=1150 is exported graph report + S PARAM1=$P($G(^ORD(101.24,RPT,2)),U) + S PARAM2=$P($G(^ORD(101.24,RPT,2)),U,2) + S INFO=$$XGET^ORWGAPIX("ALL","ORWRP TIME/OCC LIMITS INDV",RPT,"I") + S BEGIN=$P(INFO,";"),START=$$DATE^ORWGAPIX(BEGIN) + S END=$P(INFO,";",2),STOP=$$DATE^ORWGAPIX(END) + I START<1 Q + I STOP<1 Q + S NEXT=1+$O(DAT(""),-1) + S DAT(NEXT)=U_BEGIN_" to "_END_"^^^"_INFO_U_START_U_STOP_U_PARAM1_U_PARAM2 + Q + ; +DELVIEWS(DATA,NAME,PUBLIC) ; from ORWGAPI + N ERR,TMP + D RETURN^ORWGAPIU(.TMP,.DATA) + S ERR=0 + I '$L(NAME) S ERR=1 + I 'ERR D + . S NAME=$$UP^ORWGAPIX(NAME) + . I PUBLIC D XDEL^ORWGAPIX("SYS","ORWG GRAPH VIEW",NAME,.ERR) + . I 'PUBLIC D XDEL^ORWGAPIX("USR","ORWG GRAPH VIEW",NAME,.ERR) + I TMP S ^TMP(DATA,$J)=ERR,^TMP(DATA,$J,1)=ERR + I 'TMP S DATA=ERR,DATA(1)=ERR + Q + ; +GETPREF(DATA) ; from ORWGAPI + N CNT,NUM,PROF,RESULT,TMP,VAL K PROF + I '$O(^PXRMINDX(63,"PI","")) Q ; graphing is not used if no indexes + S VAL=$$XGET^ORWGAPIX("PKG","ORWG GRAPH SETTING",1,"I") + I '$L(VAL) Q ; graphing not used if no pkg param on settings + D RETURN^ORWGAPIU(.TMP,.DATA) + S VAL=$$XGET^ORWGAPIX("DIV^SYS^PKG","ORWG GRAPH SETTING",1,"I") + S PROF(1)=VAL + S VAL=$$XGET^ORWGAPIX("ALL","ORWG GRAPH SETTING",1,"I") + S PROF(0)=VAL + S CNT=0 + S NUM="" + F S NUM=$O(PROF(NUM)) Q:NUM="" D + . S RESULT=$G(PROF(NUM)) + . D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) + Q + ; +GETSIZE(DATA) ; from ORWGAPI + N CNT,NUM,PROF,RESULT,TMP K PROF + D RETURN^ORWGAPIU(.TMP,.DATA) + D XGETLST^ORWGAPIX(.PROF,"USR","ORWG GRAPH SIZING") + S CNT=0 + S NUM="" + F S NUM=$O(PROF(NUM)) Q:NUM="" D + . S RESULT=$G(PROF(NUM)) + . D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) + Q + ; +GETVIEWS(DATA,ALL,PUBLIC,EXT) ; from ORWGAPI + N CNT,FIRST,NUM,PIECE,PROF,RESULT,RESULT1,SECOND,TMP,VALUE K PROF + D RETURN^ORWGAPIU(.TMP,.DATA) + I PUBLIC D + . I ALL=1 D XGETLST^ORWGAPIX(.PROF,"SYS","ORWG GRAPH VIEW") ; get list of public views + . I ALL'=1 D XGETWP^ORWGAPIX(.PROF,"SYS","ORWG GRAPH VIEW",ALL) ; get a public view definition + I 'PUBLIC D + . I ALL=1 D XGETLST^ORWGAPIX(.PROF,"USR","ORWG GRAPH VIEW") ; get list of personal views + . I ALL'=1 D XGETWP^ORWGAPIX(.PROF,"USR","ORWG GRAPH VIEW",ALL) ; get a personal view definition + S CNT=0 + I 'EXT D Q + . S NUM="" + . F S NUM=$O(PROF(NUM)) Q:NUM="" D + .. I ALL=1 S RESULT=$P($G(PROF(NUM)),U) + .. I ALL'=1 S RESULT=$G(PROF(NUM,0)) + .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) + S NUM="" + F S NUM=$O(PROF(NUM)) Q:NUM="" D + . S RESULT=$G(PROF(NUM,0)) + . S PIECE=0 + . F S PIECE=PIECE+1 S VALUE=$P(RESULT,"|",PIECE) D:$L(VALUE) Q:'$L($P(RESULT,"|",PIECE+1,999)) + .. S FIRST=$P(VALUE,"~"),SECOND=$P(VALUE,"~",2) + .. I FIRST=0 S CNT=CNT+1,RESULT1="0^"_SECOND_U_$$FILENAME^ORWGAPIT(SECOND)_" " + .. I FIRST'=0 S CNT=CNT+1,RESULT1=FIRST_U_SECOND_U_$$EVALUE^ORWGAPIU(SECOND,FIRST) + .. D SETUP^ORWGAPIU(.DATA,RESULT1,TMP,.CNT) + Q + ; +INISET ; from ORWGAPIU initial setup of package parameters + N ERR,RPTNUM + S RPTNUM=1150 + D SETPREF(.ERR,"63;53.79;55;55NVA;52;70;120.5|BCEFGHIK|1|4|90||100||",9) ; default public settings + I '$D(^ORD(101.24,RPTNUM,0)) D ; make sure report has been added + . L +^ORD(101.24,0):20 I '$T Q + . S $P(^ORD(101.24,0),U,3)=RPTNUM,$P(^(0),U,4)=$P(^(0),U,4)+1 + . S ^ORD(101.24,RPTNUM,0)="ORWG GRAPHING^OR_GRAPHS^^2^^^1^R^^^^G^^T" + . S ^ORD(101.24,RPTNUM,2)="^^Graphing (local only)^Graphing" + . L -^ORD(101.24,0) + . D INDEX^ORWGAPIX("^ORD(101.24,",RPTNUM) + D XEN^ORWGAPIX("PKG","ORWRP REPORT LIST",12,RPTNUM) + D XVIEWS ; ***** + Q + ; +PUBLIC(USER) ; from ORWGAPI + N ERR,IDX,ORSRV,USRCLASS,VAL K USRCLASS + S VAL=0 + I '$G(USER) Q VAL + S ORSRV=$$GET1^DIQ(200,DUZ,29,"I") + D XGETLST1^ORWGAPIX(.USRCLASS,"SYS","ORWG GRAPH PUBLIC EDITOR CLASS","Q",.ERR) + I ERR Q VAL + S IDX=0 + F S IDX=$O(USRCLASS(IDX)) Q:'IDX D Q:VAL + . I $$ISA^ORWGAPIA(USER,$P(USRCLASS(IDX),U,2),.ERR) S VAL=1 + Q VAL + ; +RPTPARAM(IEN) ; from ORWGAPI + N NODE,VAL + S VAL="" + S NODE=$$UP^XLFSTR($P($G(^ORD(101.24,+$G(IEN),2)),U,1,2)) + I $L(NODE)<2 Q VAL + Q NODE + ; +SETPREF(DATA,VAL,PUBLIC) ; from ORWGAPI + N ERR,TMP + D RETURN^ORWGAPIU(.TMP,.DATA) + S ERR=0 + I '$L(VAL) S ERR=1 + I 'ERR D + . S VAL=$$UP^ORWGAPIX(VAL) + . I PUBLIC=9 D XEN^ORWGAPIX("PKG","ORWG GRAPH SETTING",1,VAL,.ERR) ; only on postinit + . I PUBLIC D XEN^ORWGAPIX("SYS","ORWG GRAPH SETTING",1,VAL,.ERR) + . I 'PUBLIC D XEN^ORWGAPIX("USR","ORWG GRAPH SETTING",1,VAL,.ERR) + I TMP S ^TMP(DATA,$J)=ERR,^TMP(DATA,$J,1)=ERR + I 'TMP S DATA=ERR,DATA(1)=ERR + Q + ; +SETSIZE(DATA,VAL) ; from ORWGAPI + N ERR,NAME,NUM,VALUE,VALUES,TMP + D RETURN^ORWGAPIU(.TMP,.DATA) + S ERR=0 + I '$L($O(VAL(0))) S ERR=1 + I 'ERR D + . S NUM=0 + . F S NUM=$O(VAL(NUM)) Q:NUM<1 D Q:ERR + .. S VALUES=VAL(NUM) + .. S VALUES=$$UP^ORWGAPIX(VALUES) + .. S NAME=$P(VALUES,U) + .. S VALUE=$P(VALUES,U,2) + .. D XEN^ORWGAPIX("USR","ORWG GRAPH SIZING",NAME,VALUE,.ERR) + I TMP S ^TMP(DATA,$J)=ERR,^TMP(DATA,$J,1)=ERR + I 'TMP S DATA=ERR,DATA(1)=ERR + Q + ; +SETVIEWS(DATA,NAME,PUBLIC,VAL) ; from ORWGAPI + N ERR,TMP + D RETURN^ORWGAPIU(.TMP,.DATA) + S ERR=0 + I '$L(NAME) S ERR=1 + I '$L($O(VAL(""))) S ERR=1 + I 'ERR D + . S NAME=$$UP^ORWGAPIX(NAME) + . S VAL=NAME + . I PUBLIC D XEN^ORWGAPIX("SYS","ORWG GRAPH VIEW",NAME,.VAL,.ERR) + . I 'PUBLIC D XEN^ORWGAPIX("USR","ORWG GRAPH VIEW",NAME,.VAL,.ERR) + I TMP S ^TMP(DATA,$J)=ERR,^TMP(DATA,$J,1)=ERR + I 'TMP S DATA=ERR,DATA(1)=ERR + Q + ; +XVIEWS ; conversion on v26t41 ***** + N CNT,DATA,ERR,NAME,NUM,NUM1,SYSNAME,VIEWS,VIEWDEF,VIEWDIV + K DATA,SYSNAME,VIEWS,VIEWDEF,VIEWDIV + D XGETLST^ORWGAPIX(.VIEWS,"SYS","ORWG GRAPH VIEW") + S NUM=0 + F S NUM=$O(VIEWS(NUM)) Q:NUM<1 D + . S NAME=$P(VIEWS(NUM),U) + . I NAME="" Q + . S SYSNAME(NAME)="" + K VIEWS + D XGETLST^ORWGAPIX(.VIEWS,"DIV","ORWG GRAPH VIEW") + S NUM=0 + F S NUM=$O(VIEWS(NUM)) Q:NUM<1 D + . S NAME=$P(VIEWS(NUM),U) + . I NAME="" Q + . I '$D(SYSNAME(NAME)) D + .. K VIEWDEF,VIEWDIV + .. D XGETWP^ORWGAPIX(.VIEWDIV,"DIV","ORWG GRAPH VIEW",NAME) + .. S CNT=0 + .. S NUM1="" + .. F S NUM1=$O(VIEWDIV(NUM1)) Q:NUM1="" D + ... S CNT=CNT+1 + ... S VIEWDEF(CNT)=$G(VIEWDIV(NUM1,0)) + .. D SETVIEWS^ORWGAPIP(.DATA,NAME,1,.VIEWDEF) + . D XDEL^ORWGAPIX("DIV","ORWG GRAPH VIEW",NAME,.ERR) + Q + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPIR.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPIR.m index d2d47405..df5a9f77 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPIR.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPIR.m @@ -1,155 +1,158 @@ -ORWGAPIR ; SLC/STAFF - Graph API Router ;8/21/06 07:52 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,260,243**;Dec 17, 1997;Build 242 - ; -DATA(DATA,ITEM,FILE,START,DFN,CNT,TMP,BACKTO) ; from ORWGAPI - S DFN=+$G(DFN) I 'DFN Q - S FILE=$G(FILE) I '$L(FILE) Q - S ITEM=$G(ITEM) I '$L(ITEM) Q - S BACKTO=+$G(BACKTO) - I FILE=52 D OUTRX^ORWGAPI7(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q - I FILE=53.79 D BCMA^ORWGAPI7(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q - I FILE=55 D INRX^ORWGAPI7(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q - I FILE="55NVA" D NVA^ORWGAPI7(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q - I FILE=63 D LAB^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q - I FILE="63AP" D LAB^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q - ;I FILE="63BB" D BBDATA^ORWGAPIB(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q - I FILE="63MI" D LAB^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q - I FILE=70 D RAD^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q - I FILE=100 D ORDER^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q - I FILE=120.5 D VITAL^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q - I FILE=120.8 D ADVERSE^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q - I FILE=601.2 D MH^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q - I FILE=9000010.07 D POV^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q - I FILE=9000010.11 D IMM^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q - I FILE=9000010.12 D SKIN^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q - I FILE=9000010.13 D EXAM^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q - I FILE=9000010.16 D EDU^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q - I FILE=9000010.18 D PROC^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q - I FILE=9000010.23 D HF^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q - I FILE=9000011 D PROB^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q - I FILE=9999911 D PROBX^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q - I FILE="45OP" D OP^ORWGAPI4(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q - I FILE="45DX" D DX^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q - I FILE=9000010 D VISIT^ORWGAPI8(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q - I FILE=405 D ADMIT^ORWGAPI8(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q - I FILE=130 D SURG^ORWGAPI8(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q - I FILE=8925 D NOTE^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q - I FILE=690 D MED^ORWGAPI3(.DATA,ITEM,START,DFN,.CNT,TMP,BACKTO) Q - Q - ; -ITEMS(ITEMS,DFN,TYPE,FMT,OLDEST,NEWEST,CNT,TMP) ; from ORWGAPI - S FMT=$G(FMT,3),OLDEST=+$G(OLDEST),NEWEST=+$G(NEWEST),CNT=+$G(CNT) - I (TYPE=70)!(TYPE=100)!(TYPE=120.5)!(TYPE=601.2) D STD(.ITEMS,DFN,TYPE,FMT,OLDEST,NEWEST,.CNT,TMP) Q - I (TYPE=9000010.11)!(TYPE=9000010.12)!(TYPE=9000010.13) D STD(.ITEMS,DFN,TYPE,FMT,OLDEST,NEWEST,.CNT,TMP) Q - I (TYPE=9000010.16)!(TYPE=9000010.23) D STD(.ITEMS,DFN,TYPE,FMT,OLDEST,NEWEST,.CNT,TMP) Q - I (TYPE=9000010.07)!(TYPE=9000010.18) D STD1(.ITEMS,DFN,TYPE,FMT,OLDEST,NEWEST,.CNT,TMP) Q - I (TYPE=52)!(TYPE=55) D STD2(.ITEMS,DFN,TYPE,FMT,OLDEST,NEWEST,.CNT,TMP) Q - I TYPE=63 D LAB^ORWGAPI1(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q - I TYPE=9000010 D VISITS^ORWGAPI6(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q - I TYPE=9000011 D PL^ORWGAPI2(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q - I TYPE=9999911 D PLX^ORWGAPI2(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q - I TYPE=405 D ADMITS^ORWGAPI6(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q - I TYPE=50.605 D DC^ORWGAPI5(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q - I TYPE=68 D AA^ORWGAPI1(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q - I TYPE=8925.1 D TITLE^ORWGAPI1(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q - I TYPE=53.79 D BCMA^ORWGAPI5(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q - I TYPE=120.8 D ADVERSE^ORWGAPI2(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q - I TYPE=130 D SURGERY^ORWGAPI6(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q - I TYPE=8925 D NOTES^ORWGAPI1(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q - I TYPE=690 D MED^ORWGAPI1(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q - S TYPE=$$UP^ORWGAPIX(TYPE) - I $E(TYPE,1,2)=45 D REG^ORWGAPI2(.ITEMS,DFN,TYPE,FMT,OLDEST,NEWEST,.CNT,TMP) Q - I TYPE="55NVA" D NVA^ORWGAPI5(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q - I TYPE="63AP" D AP^ORWGAPI1(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q - I TYPE="63BB" D BBITEM^ORWGAPIB(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q - I TYPE="63MI" D MI^ORWGAPI1(.ITEMS,DFN,FMT,OLDEST,NEWEST,.CNT,TMP) Q - Q - ; -STD(ITEMS,DFN,FILE,FMT,OLDEST,NEWEST,CNT,TMP) ; - N DATE,ITEM,OK,RESULT - S ITEM="" - F S ITEM=$O(^PXRMINDX(FILE,"PI",DFN,ITEM)) Q:ITEM="" D - . S OK=0 - . I FMT=6 D - .. S DATE=OLDEST - .. F S DATE=$O(^PXRMINDX(FILE,"PI",DFN,ITEM,DATE)) Q:DATE="" Q:DATE>NEWEST D Q:OK - ... S CNT=CNT+1 - ... S OK=1 - ... S RESULT=FILE_U_ITEM - . I FMT=3 D - .. S DATE=$O(^PXRMINDX(FILE,"PI",DFN,ITEM,""),-1) - .. I 'DATE Q - .. S CNT=CNT+1 - .. S OK=1 - .. S RESULT=FILE_U_ITEM_"^^"_$$EVALUE^ORWGAPIU(ITEM,FILE,.01)_"^^"_DATE - .. I FILE=100 S RESULT=RESULT_U_$$OGROUP^ORWGAPIW(ITEM) - . I FMT=0 D - .. S CNT=CNT+1 - .. S OK=1 - .. S RESULT=FILE_U_ITEM_U_$$EVALUE^ORWGAPIU(ITEM,FILE,.01) - . I OK D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT) - I FILE=120.5 D BMIITEMS^ORWGAPIX(.ITEMS,.CNT,TMP) Q - Q - ; -STD1(ITEMS,DFN,FILE,FMT,OLDEST,NEWEST,CNT,TMP) ; - N DATE,ITEM,OK,RESULT,TYPE - K ^TMP("ORWGRPC TEMP",$J) - S TYPE="" - F S TYPE=$O(^PXRMINDX(FILE,"PPI",DFN,TYPE)) Q:TYPE="" D - . S ITEM="" - . F S ITEM=$O(^PXRMINDX(FILE,"PPI",DFN,TYPE,ITEM)) Q:ITEM="" D - .. S OK=0 - .. I FMT=6 D - ... S DATE=OLDEST - ... F S DATE=$O(^PXRMINDX(FILE,"PPI",DFN,TYPE,ITEM,DATE)) Q:DATE="" Q:DATE>NEWEST D Q:OK - .... S CNT=CNT+1 - .... S OK=1 - .... S RESULT=FILE_U_ITEM - .. I FMT=3 D - ... S DATE=$O(^PXRMINDX(FILE,"PPI",DFN,TYPE,ITEM,""),-1) - ... I DATE S ^TMP("ORWGRPC TEMP",$J,ITEM,DATE)="" - .. I FMT=0 D - ... S CNT=CNT+1 - ... S OK=1 - ... S RESULT=FILE_U_ITEM_U_$$EVALUE^ORWGAPIU(ITEM,FILE,.01) - .. I OK D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT) - I FMT=3 D - . S ITEM="" - . F S ITEM=$O(^TMP("ORWGRPC TEMP",$J,ITEM)) Q:ITEM="" D - .. S DATE=$O(^TMP("ORWGRPC TEMP",$J,ITEM,""),-1) - .. I 'DATE Q - .. S CNT=CNT+1 - .. S RESULT=FILE_U_ITEM_"^^"_$$EVALUE^ORWGAPIU(ITEM,FILE,.01)_"^^"_DATE - .. D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT) - K ^TMP("ORWGRPC TEMP",$J) - Q - ; -STD2(ITEMS,DFN,FILE,FMT,OLDEST,NEWEST,CNT,TMP) ; - N DATE,DATE2,ITEM,OK,RESULT - S ITEM="" - F S ITEM=$O(^PXRMINDX(FILE,"PI",DFN,ITEM)) Q:ITEM="" D - . S OK=0 - . I FMT=6 D - .. S DATE=0 - .. F S DATE=$O(^PXRMINDX(FILE,"PI",DFN,ITEM,DATE)) Q:DATE="" Q:DATE>NEWEST D Q:OK - ... S DATE2="" - ... F S DATE2=$O(^PXRMINDX(FILE,"PI",DFN,ITEM,DATE,DATE2)) Q:DATE2="" D - .... I DATE2NEWEST D Q:OK + ... S CNT=CNT+1 + ... S OK=1 + ... S RESULT=FILE_U_ITEM + . I FMT=3 D + .. S DATE=$O(^PXRMINDX(FILE,"PI",DFN,ITEM,""),-1) + .. I 'DATE Q + .. S CNT=CNT+1 + .. S OK=1 + .. S RESULT=FILE_U_ITEM_"^^"_$$EVALUE^ORWGAPIU(ITEM,FILE,.01)_"^^"_DATE + .. I FILE=100 S RESULT=RESULT_U_$$OGROUP^ORWGAPIU(ITEM) + . I FMT=0 D + .. S CNT=CNT+1 + .. S OK=1 + .. S RESULT=FILE_U_ITEM_U_$$EVALUE^ORWGAPIU(ITEM,FILE,.01) + . I OK D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) + I FILE=120.5 D BMIITEMS^ORWGAPIX(.ITEMS,.CNT,TMP) Q + Q + ; +STD1(ITEMS,DFN,FILE,FMT,OLDEST,NEWEST,CNT,TMP) ; + N DATE,ITEM,OK,RESULT,TYPE + K ^TMP("ORWGRPC TEMP",$J) + S TYPE="" + F S TYPE=$O(^PXRMINDX(FILE,"PPI",DFN,TYPE)) Q:TYPE="" D + . S ITEM="" + . F S ITEM=$O(^PXRMINDX(FILE,"PPI",DFN,TYPE,ITEM)) Q:ITEM="" D + .. S OK=0 + .. I FMT=6 D + ... S DATE=OLDEST + ... F S DATE=$O(^PXRMINDX(FILE,"PPI",DFN,TYPE,ITEM,DATE)) Q:DATE="" Q:DATE>NEWEST D Q:OK + .... S CNT=CNT+1 + .... S OK=1 + .... S RESULT=FILE_U_ITEM + .. I FMT=3 D + ... S DATE=$O(^PXRMINDX(FILE,"PPI",DFN,TYPE,ITEM,""),-1) + ... I DATE S ^TMP("ORWGRPC TEMP",$J,ITEM,DATE)="" + .. I FMT=0 D + ... S CNT=CNT+1 + ... S OK=1 + ... S RESULT=FILE_U_ITEM_U_$$EVALUE^ORWGAPIU(ITEM,FILE,.01) + .. I OK D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) + I FMT=3 D + . S ITEM="" + . F S ITEM=$O(^TMP("ORWGRPC TEMP",$J,ITEM)) Q:ITEM="" D + .. S DATE=$O(^TMP("ORWGRPC TEMP",$J,ITEM,""),-1) + .. I 'DATE Q + .. S CNT=CNT+1 + .. S RESULT=FILE_U_ITEM_"^^"_$$EVALUE^ORWGAPIU(ITEM,FILE,.01)_"^^"_DATE + .. D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) + K ^TMP("ORWGRPC TEMP",$J) + Q + ; +STD2(ITEMS,DFN,FILE,FMT,OLDEST,NEWEST,CNT,TMP) ; + N DATE,DATE2,ITEM,OK,RESULT + S ITEM="" + F S ITEM=$O(^PXRMINDX(FILE,"PI",DFN,ITEM)) Q:ITEM="" D + . S OK=0 + . I FMT=6 D + .. S DATE=0 + .. F S DATE=$O(^PXRMINDX(FILE,"PI",DFN,ITEM,DATE)) Q:DATE="" Q:DATE>NEWEST D Q:OK + ... S DATE2="" + ... F S DATE2=$O(^PXRMINDX(FILE,"PI",DFN,ITEM,DATE,DATE2)) Q:DATE2="" D + .... I DATE2 hs component abbrv - from ORWGAPID - N COMP,COMPNAME,COMPS,NUM,OK K COMPS - S COMPNAME=$$COMPNAME(FILE)_"]" - D COMP^ORWRP2(.COMPS) - S COMP="" - S OK=0 - S NUM=0 - D - . F S NUM=$O(COMPS(NUM)) Q:NUM<1 D I OK Q - .. S COMP=COMPS(NUM) - .. I COMP[COMPNAME,COMPNAME=$P($P(COMP,U,2),"[",2) S OK=1 - Q COMP - ; -COMPNAME(FILE) ; $$(file) -> hs component abbrv - I FILE=63 Q "CH" - I FILE=120.5 Q "VSD" - I FILE=120.8 Q "ADR" - I FILE=52 Q "RXOP" - I FILE=55 Q "RXUD" - I FILE=70 Q "II" - I FILE=9000010.11 Q "IM" - I FILE=9000010.12 Q "ST" - I FILE=9000010.13 Q "EXAM" - I FILE=9000010.18 Q "CPT" - I FILE=9000011 Q "PLL" - I FILE=9999911 Q "PLL" - I FILE=9000010.23 Q "HF" - I FILE=9000010.07 Q "OD" - I FILE=9000010.16 Q "ED" - I FILE=601.2 Q "MHPE" - I FILE=100 Q "ORC" - I FILE="45OP" Q "PRC" - I FILE="45DX" Q "DD" - I FILE="63AP" Q "SP" - I FILE="63BB" Q "BT" - I FILE="63MI" Q "MIC" - I FILE=9000010 Q "CVP" - I FILE=405 Q "ADC" - I FILE="55NVA" Q "RXNV" - I FILE=53.79 Q "BCMA" - I FILE=130 Q "SR" - I FILE=8925 Q "CNB" - I FILE=690 Q "MEDF" - Q "" - ; -FILENAME(FILE) ; $$(file) -> filename - from ORWGAPIP - I FILE=63 Q "LAB TESTS" - I FILE=120.5 Q "VITALS" - I FILE=120.8 Q "ALLERGIES" - I FILE=52 Q "MEDICATION,OUTPATIENT" - I FILE=55 Q "MEDICATION,INPATIENT" - I FILE=70 Q "RADIOLOGY EXAMS" - I FILE=9000010.11 Q "IMMUNIZATIONS" - I FILE=9000010.12 Q "SKIN TESTS" - I FILE=9000010.13 Q "EXAMS" - I FILE=9000010.18 Q "PROCEDURES" - I FILE=9000011 Q "PROBLEMS" - I FILE=9999911 Q "PROBLEMS-DURATION" ;************** - I FILE=9000010.23 Q "HEALTH FACTORS" - I FILE=9000010.07 Q "PURPOSE OF VISIT" - I FILE=9000010.16 Q "PATIENT EDUCATION" - I FILE=601.2 Q "MENTAL HEALTH" - I FILE=100 Q "ORDERS" - I FILE="45OP" Q "REGISTRATION OP/PROC" - I FILE="45DX" Q "REGISTRATION DX" - I FILE="63AP" Q "ANATOMIC PATHOLOGY" - I FILE="63BB" Q "BLOOD PRODUCTS" - I FILE="63MI" Q "MICROBIOLOGY" - I FILE=9000010 Q "VISITS" - I FILE=405 Q "ADMISSIONS" - I FILE="55NVA" Q "MEDICATION,NON-VA" - I FILE=53.79 Q "MEDICATION,BCMA" - I FILE=50.605 Q "DRUG CLASS" - I FILE=68 Q "LAB ACC AREA" - I FILE=8925.1 Q "NOTE TITLE" - I FILE=100.98 Q "ORDER DISPLAY GROUP" - I FILE=811.2 Q "REMINDER TAXONOMY" - I FILE=130 Q "SURGERY" - I FILE=8925 Q "NOTES" - I FILE=690 Q "MEDICINE" - Q "" - ; -FILECHK(FILES) ; - ; get parameter string of excluded files - N CHECK,NUM,ORSRV,VAL - S ORSRV=$$GET1^DIQ(200,DUZ,29,"I") - S CHECK=$$XGET^ORWGAPIX("USR^SRV.`"_+$G(ORSRV)_"^DIV^SYS^PKG","ORWG GRAPH EXCLUDE DATA TYPE",1,"I") - S CHECK=CHECK_";" - S NUM=0 - F S NUM=$O(FILES(NUM)) Q:NUM<1 D - . S VAL=FILES(NUM) - . S VAL=$P(VAL,U)_";" - . I CHECK[VAL K FILES(NUM) - Q - ; -GETFILES(FILES) ; - ; file #^file name^graph type^lookup file^lookup global^lookup index^prefix^abbrev^hint format - ; commenting out a line setting FILES will inactivate that type - S FILES(1)="63^LAB TESTS^1^60^LAB(60,^B^^CH^~ ~units~flag~|" - S FILES(2)="120.5^VITALS^1^120.51^GMRD(120.51,^B^^VSD^~ ~" - S FILES(3)="52^MEDICATION,OUTPATIENT^3^50^PSDRUG(^B^^RXOP^~ ~" - S FILES(4)="55^MEDICATION,INPATIENT^3^50^PSDRUG(^B^^RXUD^~ ~" - S FILES(5)="70^RADIOLOGY EXAMS^2^71^RAMIS(71,^B^rad^II^~ ~" - S FILES(6)="9000010.11^IMMUNIZATIONS^2^9999999.14^AUTTIMM(^B^imm^IM^~ ~" - S FILES(7)="9000010.12^SKIN TESTS^2^9999999.28^AUTTSK(^B^skin^ST^~ ~" - S FILES(8)="9000010.13^EXAMS^2^9999999.15,^AUTTEXAM(^B^exam^EXAM^~ ~" - S FILES(9)="9000010.18^PROCEDURES^2^81^ICPT(^C^proc^CPT^~ ~" - S FILES(10)="9000011^PROBLEMS^2^80^ICD9(^B^prob^PLL^~ ~" ;*** - S FILES(11)="9000010.23^HEALTH FACTORS^2^9999999.64^AUTTHF(,^B^hf^HF^~ ~" - S FILES(12)="9000010.07^PURPOSE OF VISIT^2^80^ICD9(^B^pov^OD^" - S FILES(13)="9000010.16^PATIENT EDUCATION^2^9999999.09^AUTTEDT(^B^edu^ED^~ ~" - S FILES(14)="601.2^MENTAL HEALTH^2^601^YTT(601,^B^mh^MHPE^~ ~" - S FILES(15)="100^ORDERS^2^101.43^ORD(101.43,^B^order^ORC^~ ~" - S FILES(16)="45OP^REGISTRATION OP/PROC^2^*^^^op^PRC^~ ~" - S FILES(17)="45DX^REGISTRATION DX^2^*^^^dx^DD^~ ~" - S FILES(18)="63AP^ANATOMIC PATHOLOGY^2^*^^^ap^SP^~ ~" - S FILES(19)="63MI^MICROBIOLOGY^2^*^^^micro^MIC^~ ~" - S FILES(20)="9000010^VISITS^3^44^SC(^B^^CVP^~ ~" - S FILES(21)="405^ADMISSIONS^3^*^^^^ADC^~ ~" - S FILES(23)="53.79^MEDICATION,BCMA^2^50.7^PS(50.7,^B^^BCMA^~ ~" - S FILES(24)="130^SURGERY^2^81^ICPT(^C^surg^SR^~ ~" - S FILES(25)="8925^NOTES^2^*^^^note^CNB^~ ~" - S FILES(27)="120.8^ALLERGIES^2^*^^^allg^ADR^~ ~" - S FILES(28)="63BB^BLOOD BANK^2^66^LAB(66,^B^bb^BT^~ ~" - ;S FILES(29)="9999911^PROBLEMS-DURATION^3^80^ICD9(^B^prob^PLL^~ ~" ;*** - S FILES(30)="55NVA^MEDICATION,NON-VA^3^50.7^PS(50.7,^B^^RXNV^~ ~" - S FILES(31)="690^MEDICINE^2^*^^^med^MEDF^~ ~" - S FILES(2000)="811.2^Reminder Taxonomy" - S FILES(3000)="50.605^Drug Class" - Q - ; -TYPES(TYPES,DFN,SUB,TMP) ; from ORWGAPI - N CNT,FILES,ITEM,MEDARRAY,NUM,OK,SEQ K FILES,MEDARRAY - S TMP=$G(TMP) - D GETFILES(.FILES) - D FILECHK(.FILES) - I SUB D - . I $D(FILES(18)) D - .. S FILES(1801)="63AP;O^AP: Organ" - .. S FILES(1802)="63AP;T^AP: Test" - .. S FILES(1803)="63AP;D^AP: Disease" - .. S FILES(1804)="63AP;I^AP: ICD9" - .. S FILES(1805)="63AP;E^AP: Etiology" - .. S FILES(1806)="63AP;F^AP: Function" - .. S FILES(1807)="63AP;P^AP: Procedure" - .. S FILES(1808)="63AP;M^AP: Morphology" - .. S FILES(1809)="63AP;S^AP: Specimen" - . I $D(FILES(19)) D - .. S FILES(1901)="63MI;A^Microbiology: Antibiotic" - .. S FILES(1902)="63MI;T^Microbiology: Test" - .. S FILES(1903)="63MI;S^Microbiology: Specimen" - .. S FILES(1904)="63MI;O^Microbiology: Organism" - .. ;S FILES(1905)="63MI;M^Microbiology: TB Drug" - I 'SUB D - . K FILES(2000) - . K FILES(3000) - I DFN D - . I '$L($O(^PXRMINDX(63,"PI",DFN,""))) K FILES(1) - . I '$L($O(^PXRMINDX(120.5,"PI",DFN,""))) K FILES(2) - . I '$L($O(^PXRMINDX(52,"PI",DFN,""))) K FILES(3) - . I '$L($O(^PXRMINDX(55,"PI",DFN,""))) K FILES(4) - . I '$L($O(^PXRMINDX(70,"PI",DFN,""))) K FILES(5) - . I '$L($O(^PXRMINDX(9000010.11,"PI",DFN,""))) K FILES(6) - . I '$L($O(^PXRMINDX(9000010.12,"PI",DFN,""))) K FILES(7) - . I '$L($O(^PXRMINDX(9000010.13,"PI",DFN,""))) K FILES(8) - . I '$L($O(^PXRMINDX(9000010.18,"PPI",DFN,""))) K FILES(9) - . I '$L($O(^PXRMINDX(9000011,"PSPI",DFN,""))) K FILES(10),FILES(29) - . I '$L($O(^PXRMINDX(9000010.23,"PI",DFN,""))) K FILES(11) - . I '$L($O(^PXRMINDX(9000010.07,"PPI",DFN,""))) K FILES(12) - . I '$L($O(^PXRMINDX(9000010.16,"PI",DFN,""))) K FILES(13) - . I '$L($O(^PXRMINDX(601.2,"PI",DFN,""))) K FILES(14) - . I '$L($O(^PXRMINDX(100,"PI",DFN,""))) K FILES(15) - . I '$L($O(^PXRMINDX(45,"ICD0","PNI",DFN,0))) K FILES(16) - . I '$L($O(^PXRMINDX(45,"ICD9","PNI",DFN,0))) K FILES(17) - . I $E($O(^PXRMINDX(63,"PI",DFN,"A")))'="A" K FILES(18) D - .. F NUM=1:1:9 K FILES(180+NUM) - . I $E($O(^PXRMINDX(63,"PI",DFN,"M")))'="M" K FILES(19) D - .. F NUM=1:1:5 K FILES(190+NUM) - . I '$$VISITX^ORWGAPIA(DFN) K FILES(20) - . I '$$ADMITX^ORWGAPIA(DFN) K FILES(21) - . I '$$NVAX^ORWGAPIC(DFN) K FILES(22),FILES(30) - . I '$$BCMAX^ORWGAPIC(DFN) K FILES(23) - . I '$$SURGX^ORWGAPIA(DFN) K FILES(24) - . I '$$NOTEX^ORWGAPIA(DFN) K FILES(25) - . I '$$ALLERGYX^ORWGAPIA(DFN) K FILES(27) - . I '$$BBX^ORWGAPIB(DFN) K FILES(28) - . S OK=0 - . D MEDICINE^ORWGAPIA(.MEDARRAY,DFN) - . I $O(MEDARRAY(0)) S OK=1 - . I 'OK K FILES(31) - S CNT=0,SEQ=0 - F S SEQ=$O(FILES(SEQ)) Q:SEQ<1 D - . S CNT=CNT+1 - . I TMP S ^TMP(TYPES,$J,CNT)=FILES(SEQ) - . I 'TMP S TYPES(CNT)=FILES(SEQ) - Q - ; +ORWGAPIT ; SLC/STAFF - Graph Item Types ;11/20/06 08:58 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,260**;Dec 17, 1997;Build 26 + ; +COMPTYPE(FILE) ; $$(file) -> hs component abbrv - from ORWGAPID + N COMP,COMPNAME,COMPS,NUM,OK K COMPS + S COMPNAME=$$COMPNAME(FILE)_"]" + D COMP^ORWRP2(.COMPS) + S COMP="" + S OK=0 + S NUM=0 + D + . F S NUM=$O(COMPS(NUM)) Q:NUM<1 D I OK Q + .. S COMP=COMPS(NUM) + .. I COMP[COMPNAME,COMPNAME=$P($P(COMP,U,2),"[",2) S OK=1 + Q COMP + ; +COMPNAME(FILE) ; $$(file) -> hs component abbrv + I FILE=63 Q "CH" + I FILE=120.5 Q "VSD" + I FILE=120.8 Q "ADR" + I FILE=52 Q "RXOP" + I FILE=55 Q "RXUD" + I FILE=70 Q "II" + I FILE=9000010.11 Q "IM" + I FILE=9000010.12 Q "ST" + I FILE=9000010.13 Q "EXAM" + I FILE=9000010.18 Q "CPT" + I FILE=9000011 Q "PLL" + I FILE=9999911 Q "PLL" + I FILE=9000010.23 Q "HF" + I FILE=9000010.07 Q "OD" + I FILE=9000010.16 Q "ED" + I FILE=601.2 Q "MHPE" + I FILE=100 Q "ORC" + I FILE="45OP" Q "PRC" + I FILE="45DX" Q "DD" + I FILE="63AP" Q "SP" + I FILE="63BB" Q "BT" + I FILE="63MI" Q "MIC" + I FILE=9000010 Q "CVP" + I FILE=405 Q "ADC" + I FILE="55NVAE" Q "RXNV" + I FILE="55NVA" Q "RXNV" + I FILE=53.79 Q "BCMA" + I FILE=130 Q "SR" + I FILE=8925 Q "CNB" + I FILE=9000010.15 Q "TP" + I FILE=690 Q "MEDF" + Q "" + ; +FILENAME(FILE) ; $$(file) -> filename - from ORWGAPIP + I FILE=63 Q "LAB TESTS" + I FILE=120.5 Q "VITALS" + I FILE=120.8 Q "ALLERGIES" + I FILE=52 Q "MEDICATION,OUTPATIENT" + I FILE=55 Q "MEDICATION,INPATIENT" + I FILE=70 Q "RADIOLOGY EXAMS" + I FILE=9000010.11 Q "IMMUNIZATIONS" + I FILE=9000010.12 Q "SKIN TESTS" + I FILE=9000010.13 Q "EXAMS" + I FILE=9000010.18 Q "PROCEDURES" + I FILE=9000011 Q "PROBLEMS" + I FILE=9999911 Q "PROBLEMS-DURATION" ;************** + I FILE=9000010.23 Q "HEALTH FACTORS" + I FILE=9000010.07 Q "PURPOSE OF VISIT" + I FILE=9000010.16 Q "PATIENT EDUCATION" + I FILE=601.2 Q "MENTAL HEALTH" + I FILE=100 Q "ORDERS" + I FILE="45OP" Q "REGISTRATION OP/PROC" + I FILE="45DX" Q "REGISTRATION DX" + I FILE="63AP" Q "ANATOMIC PATHOLOGY" + I FILE="63BB" Q "BLOOD PRODUCTS" + I FILE="63MI" Q "MICROBIOLOGY" + I FILE=9000010 Q "VISITS" + I FILE=405 Q "ADMISSIONS" + I FILE="55NVAE" Q "MEDICATION,NON-VA-EVENT" ;***** + I FILE="55NVA" Q "MEDICATION,NON-VA" + I FILE=53.79 Q "MEDICATION,BCMA" + I FILE=50.605 Q "DRUG CLASS" + I FILE=68 Q "LAB ACC AREA" + I FILE=8925.1 Q "NOTE TITLE" + I FILE=100.98 Q "ORDER DISPLAY GROUP" + I FILE=811.2 Q "REMINDER TAXONOMY" + I FILE=130 Q "SURGERY" + I FILE=8925 Q "NOTES" + I FILE=9000010.15 Q "TREATMENTS" + I FILE=690 Q "MEDICINE" + Q "" + ; +FILECHK(FILES) ; + ; get parameter string of excluded files + N CHECK,NUM,ORSRV,VAL + S ORSRV=$$GET1^DIQ(200,DUZ,29,"I") + S CHECK=$$XGET^ORWGAPIX("USR^SRV.`"_+$G(ORSRV)_"^DIV^SYS^PKG","ORWG GRAPH EXCLUDE DATA TYPE",1,"I") + S CHECK=CHECK_";" + S NUM=0 + F S NUM=$O(FILES(NUM)) Q:NUM<1 D + . S VAL=FILES(NUM) + . S VAL=$P(VAL,U)_";" + . I CHECK[VAL K FILES(NUM) + Q + ; +GETFILES(FILES) ; + ; file #^file name^graph type^lookup file^lookup global^lookup index + ; commenting out a line setting FILES will inactivate that type + S FILES(1)="63^LAB TESTS^1^60^LAB(60,^B^^CH^" + S FILES(2)="120.5^VITALS^1^120.51^GMRD(120.51,^B^^VSD^" + S FILES(3)="52^MEDICATION,OUTPATIENT^3^50^PSDRUG(^B^^RXOP^" + S FILES(4)="55^MEDICATION,INPATIENT^3^50^PSDRUG(^B^^RXUD^" + S FILES(5)="70^RADIOLOGY EXAMS^2^71^RAMIS(71,^B^rad^II^" + S FILES(6)="9000010.11^IMMUNIZATIONS^2^9999999.14^AUTTIMM(^B^imm^IM^" + S FILES(7)="9000010.12^SKIN TESTS^2^9999999.28^AUTTSK(^B^skin^ST^" + S FILES(8)="9000010.13^EXAMS^2^9999999.15,^AUTTEXAM(^B^exam^EXAM^" + S FILES(9)="9000010.18^PROCEDURES^2^81^ICPT(^C^proc^CPT^" + S FILES(10)="9000011^PROBLEMS^2^80^ICD9(^B^prob^PLL^" ;*** + S FILES(11)="9000010.23^HEALTH FACTORS^2^9999999.64^AUTTHF(,^B^hf^HF^" + S FILES(12)="9000010.07^PURPOSE OF VISIT^2^80^ICD9(^B^pov^OD^" + S FILES(13)="9000010.16^PATIENT EDUCATION^2^9999999.09^AUTTEDT(^B^edu^ED^" + S FILES(14)="601.2^MENTAL HEALTH^2^601^YTT(601,^B^mh^MHPE^" + S FILES(15)="100^ORDERS^2^101.43^ORD(101.43,^B^order^ORC^" + S FILES(16)="45OP^REGISTRATION OP/PROC^2^*^^^op^PRC^" + S FILES(17)="45DX^REGISTRATION DX^2^*^^^dx^DD^" + S FILES(18)="63AP^ANATOMIC PATHOLOGY^2^*^^^ap^SP^" + S FILES(19)="63MI^MICROBIOLOGY^2^*^^^micro^MIC^" + S FILES(20)="9000010^VISITS^3^44^SC(^B^^CVP^" + S FILES(21)="405^ADMISSIONS^3^*^^^^ADC^" + ;S FILES(22)="55NVAE^MEDICATION,NON-VA-EVENT^2^50.7^PS(50.7,^B^^RXNV^" + S FILES(23)="53.79^MEDICATION,BCMA^2^50.7^PS(50.7,^B^^BCMA^" + S FILES(24)="130^SURGERY^2^81^ICPT(^C^surg^SR^" + S FILES(25)="8925^NOTES^2^*^^^note^CNB^" + ;S FILES(26)="9000010.15^TREATMENTS^2^9999999.17,^AUTTTRT(^B^treat^TP^" + S FILES(27)="120.8^ALLERGIES^2^*^^^allg^ADR^" + S FILES(28)="63BB^BLOOD BANK^2^66^LAB(66,^B^bb^BT^" + ;S FILES(29)="9999911^PROBLEMS-DURATION^3^80^ICD9(^B^prob^PLL^" ;*** + S FILES(30)="55NVA^MEDICATION,NON-VA^3^50.7^PS(50.7,^B^^RXNV^" + S FILES(31)="690^MEDICINE^2^*^^^med^MEDF^" + S FILES(2000)="811.2^Reminder Taxonomy" + S FILES(3000)="50.605^Drug Class" + Q + ; +TYPES(TYPES,DFN,SUB,TMP) ; from ORWGAPI + N CNT,FILES,ITEM,MEDARRAY,NUM,OK,SEQ K FILES,MEDARRAY + S TMP=$G(TMP) + D GETFILES(.FILES) + D FILECHK(.FILES) + I SUB D + . I $D(FILES(18)) D + .. S FILES(1801)="63AP;O^AP: Organ" + .. S FILES(1802)="63AP;T^AP: Test" + .. S FILES(1803)="63AP;D^AP: Disease" + .. S FILES(1804)="63AP;I^AP: ICD9" + .. S FILES(1805)="63AP;E^AP: Etiology" + .. S FILES(1806)="63AP;F^AP: Function" + .. S FILES(1807)="63AP;P^AP: Procedure" + .. S FILES(1808)="63AP;M^AP: Morphology" + .. S FILES(1809)="63AP;S^AP: Specimen" + . I $D(FILES(19)) D + .. S FILES(1901)="63MI;A^Microbiology: Antibiotic" + .. S FILES(1902)="63MI;T^Microbiology: Test" + .. S FILES(1903)="63MI;S^Microbiology: Specimen" + .. S FILES(1904)="63MI;O^Microbiology: Organism" + .. ;S FILES(1905)="63MI;M^Microbiology: TB Drug" + I 'SUB D + . K FILES(2000) + . K FILES(3000) + I DFN D + . I '$L($O(^PXRMINDX(63,"PI",DFN,""))) K FILES(1) + . I '$L($O(^PXRMINDX(120.5,"PI",DFN,""))) K FILES(2) + . I '$L($O(^PXRMINDX(52,"PI",DFN,""))) K FILES(3) + . I '$L($O(^PXRMINDX(55,"PI",DFN,""))) K FILES(4) + . I '$L($O(^PXRMINDX(70,"PI",DFN,""))) K FILES(5) + . I '$L($O(^PXRMINDX(9000010.11,"PI",DFN,""))) K FILES(6) + . I '$L($O(^PXRMINDX(9000010.12,"PI",DFN,""))) K FILES(7) + . I '$L($O(^PXRMINDX(9000010.13,"PI",DFN,""))) K FILES(8) + . I '$L($O(^PXRMINDX(9000010.18,"PPI",DFN,""))) K FILES(9) + . I '$L($O(^PXRMINDX(9000011,"PSPI",DFN,""))) K FILES(10),FILES(29) + . I '$L($O(^PXRMINDX(9000010.23,"PI",DFN,""))) K FILES(11) + . I '$L($O(^PXRMINDX(9000010.07,"PPI",DFN,""))) K FILES(12) + . I '$L($O(^PXRMINDX(9000010.16,"PI",DFN,""))) K FILES(13) + . I '$L($O(^PXRMINDX(601.2,"PI",DFN,""))) K FILES(14) + . I '$L($O(^PXRMINDX(100,"PI",DFN,""))) K FILES(15) + . I '$L($O(^PXRMINDX(45,"ICD0","PNI",DFN,0))) K FILES(16) + . I '$L($O(^PXRMINDX(45,"ICD9","PNI",DFN,0))) K FILES(17) + . I $E($O(^PXRMINDX(63,"PI",DFN,"A")))'="A" K FILES(18) D + .. F NUM=1:1:9 K FILES(180+NUM) + . I $E($O(^PXRMINDX(63,"PI",DFN,"M")))'="M" K FILES(19) D + .. F NUM=1:1:5 K FILES(190+NUM) + . I '$$VISITX^ORWGAPIA(DFN) K FILES(20) + . I '$$ADMITX^ORWGAPIA(DFN) K FILES(21) + . I '$$NVAX^ORWGAPIA(DFN) K FILES(22),FILES(30) + . I '$$BCMAX^ORWGAPIA(DFN) K FILES(23) + . I '$$SURGX^ORWGAPIA(DFN) K FILES(24) + . I '$$NOTEX^ORWGAPIA(DFN) K FILES(25) + . I '$$TREATX^ORWGAPIA(DFN) K FILES(26) + . I '$$ALLERGYX^ORWGAPIA(DFN) K FILES(27) + . I '$$BBX^ORWGAPIB(DFN) K FILES(28) + . S OK=0 + . D MEDICINE^ORWGAPIA(.MEDARRAY,DFN) + . I $O(MEDARRAY(0)) S OK=1 + . I 'OK K FILES(31) + S CNT=0,SEQ=0 + F S SEQ=$O(FILES(SEQ)) Q:SEQ<1 D + . S CNT=CNT+1 + . I TMP S ^TMP(TYPES,$J,CNT)=FILES(SEQ) + . I 'TMP S TYPES(CNT)=FILES(SEQ) + Q + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPIU.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPIU.m index 8c3a5ec4..7b01c359 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPIU.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPIU.m @@ -1,117 +1,199 @@ -ORWGAPIU ; SLC/STAFF - Graph API Utilities ;3/17/08 10:27 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,260,243**;Dec 17, 1997;Build 242 - ; -EVALUE(VAL,FILE,FIELD) ; $$(internal value,file,field) -> external value or "" - ; from ORWGAPI1, ORWGAPI2, ORWGAPI3, ORWGAPI4, ORWGAPIP, ORWGAPIR - I VAL="" Q "" - S FIELD=$G(FIELD,.01) - I $E(FILE,1,2)=63 Q $$LABNAME^ORWGAPIC(VAL) - I FILE="63AP;I" Q $$ICD9^ORWGAPIA(VAL) - I FILE="45DX" Q $$ICD9^ORWGAPIA(VAL) - I FILE="45OP" Q $$ICD0^ORWGAPIA(VAL) - I FILE="45;ICD9" Q $$ICD9^ORWGAPIA(VAL) - I FILE="45;ICD0" Q $$ICD0^ORWGAPIA(VAL) - I FIELD=.01,'$L(VAL) Q "" - I FILE=9000010.07 Q $$ICD9^ORWGAPIA(VAL) - I FILE=9000010.18 Q $$ICPT^ORWGAPIA(VAL) - I FILE=9000011 Q $$ICD9^ORWGAPIA(VAL) - I FILE=9999911 Q $$ICD9^ORWGAPIA(VAL) - I FILE=130 Q $$ICPT^ORWGAPIA(VAL) - I FILE=120.8 Q $$ALLG^ORWGAPIA(VAL) - I FILE=50.605 Q $$DC^ORWGAPIC(VAL) - I FILE=68 Q $$AA^ORWGAPIC(VAL) - I FILE=811.2 Q $$TAX^ORWGAPIA(VAL) - D - . I FILE=52 S FIELD=6 Q - . I FILE=53.79 S FIELD=.08 Q - . I FILE=55 S FILE=55.07 Q - . I FILE="55NVA" S FILE=55.05 Q - . I FILE=70 S FILE=70.03,FIELD=2 Q - . I FILE=100 S FILE=100.001 Q - . I FILE=120.5 S FIELD=.03 Q - . I FILE=601.2 S FILE=601.21 Q - Q $$EXT^ORWGAPIX(VAL,FILE,FIELD) - ; -FILE(FILE,REF,XREF,SCREEN) ; from ORWGAPI - S REF="",SCREEN="I 1",XREF="B" - I FILE="" Q - D - . I FILE="45DX" S REF=$$GBLREF(80),XREF="AB" Q - . I FILE="45OP" S REF=$$GBLREF(80.1),XREF="AB" Q - . I FILE=50.605 S REF=$$GBLREF(50.605),XREF="C" Q - . I FILE=52 S REF=$$GBLREF(50) Q - . I FILE=53.79 S REF=$$GBLREF(50.7),SCREEN="I $P(ZERO,U,10)'=1" Q - . I FILE=55 S REF=$$GBLREF(50) Q - . I FILE="55NVA" S REF=$$GBLREF(50.7),SCREEN="I $P(ZERO,U,10)=1" Q - . I FILE=63 S REF=$$GBLREF(60),SCREEN="I $L($P(ZERO,U,5)),""BO""[$P(ZERO,U,3),$P(ZERO,U,4)=""CH""" Q - . I FILE="63AP" S REF=$$GBLREF(60),SCREEN="I 0" Q - . I FILE="63AP;D" S REF=$$GBLREF(61.4) Q - . I FILE="63AP;E" S REF=$$GBLREF(61.2) Q - . I FILE="63AP;F" S REF=$$GBLREF(61.3) Q - . I FILE="63AP;I" S REF=$$GBLREF(80),XREF="AB" Q - . I FILE="63AP;M" S REF=$$GBLREF(61.1) Q - . I FILE="63AP;O" S REF=$$GBLREF(61) Q - . I FILE="63AP;P" S REF=$$GBLREF(61.5) Q - . I FILE="63AP;T" S REF=$$GBLREF(60),SCREEN="I ""BO""[$P(ZERO,U,3),(($P(ZERO,U,4)=""CY"")!($P(ZERO,U,4)=""SP"")!($P(ZERO,U,4)=""EM"")!($P(ZERO,U,4)=""AU""))" Q - . I FILE="63BB" S REF=$$GBLREF(66),SCREEN="I $P(ZERO,U,15)=1" Q - . I FILE="63MI" S REF=$$GBLREF(60),SCREEN="I 0" Q - . I FILE="63MI;A" S REF=$$GBLREF(62.06) Q - . I FILE="63MI;M" S REF=$$GBLREF(60) Q ; mycobacteria not currently used - . I FILE="63MI;O" S REF=$$GBLREF(61.2),SCREEN="I $L($P(ZERO,U,5)),""BFPMV""[$P(ZERO,U,5)" Q - . I FILE="63MI;S" S REF=$$GBLREF(61) Q - . I FILE="63MI;T" S REF=$$GBLREF(60),SCREEN="I ""BO""[$P(ZERO,U,3),$P(ZERO,U,4)=""MI""" Q - . I FILE=70 S REF=$$GBLREF(71) Q - . I FILE=100 S REF=$$GBLREF(101.43) Q - . I FILE=120.5 S REF=$$GBLREF(120.51),SCREEN="I ""BP^P^T^R^P^HT^WT^CVP^CG^PO2^PN""[$P(ZERO,U,2)" Q - . ;I FILE=120.8 S REF=$$GBLREF(120.83) Q - . I FILE=130 S REF=$$GBLREF(81),SCREEN="I '$P(ZERO,U,4)" Q - . I FILE=405 S REF=$$GBLREF(44),SCREEN="I 0" Q - . I FILE=601.2 S REF=$$GBLREF(601) Q - . I FILE=690 S REF=$$GBLREF(697.2),XREF="BA" Q - . I FILE=811.2 S REF=$$GBLREF(811.2),SCREEN="I $P(ZERO,U,6)'=1" Q - . I FILE=8925 S REF=$$GBLREF(8925.1),SCREEN="I $P(ZERO,U,4)=""DOC""" Q - . I FILE=9000010 S REF=$$GBLREF(44) Q - . I FILE=9000010.07 S REF=$$GBLREF(80),XREF="AB" Q - . I FILE=9000010.11 S REF=$$GBLREF(9999999.14),SCREEN="I $P(ZERO,U,7)'=1" Q - . I FILE=9000010.12 S REF=$$GBLREF(9999999.28),SCREEN="I $P(ZERO,U,3)'=1" Q - . I FILE=9000010.13 S REF=$$GBLREF(9999999.15),SCREEN="I $P(ZERO,U,4)'=1" Q - . I FILE=9000010.16 S REF=$$GBLREF(9999999.09),SCREEN="I $P(ZERO,U,3)'=1" Q - . I FILE=9000010.18 S REF=$$GBLREF(81),XREF="BA",SCREEN="I '$P(ZERO,U,4)" Q - . I FILE=9000010.23 S REF=$$GBLREF(9999999.64),SCREEN="I $P(ZERO,U,10)=""F"",$P(ZERO,U,11)'=1" Q - . I FILE=9000011 S REF=$$GBLREF(80),XREF="AB",SCREEN="I $E(ZERO)'=""E"",'$L($P(ZERO,U,9))" Q - . I FILE=9999911 S REF=$$GBLREF(80),XREF="AB",SCREEN="I $E(ZERO)'=""E"",'$L($P(ZERO,U,9))" Q - I $E(REF)'="^" S REF="" - S REF=REF ;_""""_XREF_""")" - Q - ; -GBLREF(FN) ; $$(file#) -> global reference - Q $$GBLREF^ORWGAPIX($G(FN)) - ; -INISET ; postinit, set initial public graph setting - from ORY215, ORY243 - D INISET^ORWGAPIP - D RESOURCE^ORWGTASK - Q - ; -ITEMPRFX(ITEM) ; $$(item) -> item prefix - from ORWGAPI1 - N ABBREV,PREFIX - S PREFIX="" - S ABBREV=$P(ITEM,";",2) - I $E(ITEM)="A" D Q PREFIX - . I ABBREV="T" S PREFIX="TEST" Q - . I ABBREV="S" S PREFIX="SPECIMEN" Q - . I ABBREV="O" S PREFIX="ORGAN" Q - . I ABBREV="M" S PREFIX="MORPHOLOGY" Q - . I ABBREV="E" S PREFIX="ETIOLOGY" Q - . I ABBREV="D" S PREFIX="DISEASE" Q - . I ABBREV="P" S PREFIX="PROCEDURE" Q - . I ABBREV="F" S PREFIX="FUNCTION" Q - . I ABBREV="I" S PREFIX="ICD9" Q - I $E(ITEM)="B" Q "BLOOD COMPONENT" - I $E(ITEM)="M" D Q PREFIX - . I ABBREV="T" S PREFIX="TEST" Q - . I ABBREV="S" S PREFIX="SPECIMEN" Q - . I ABBREV="O" S PREFIX="ORGANISM" Q - . I ABBREV="A" S PREFIX="ANTIBIOTIC" Q - . I ABBREV="M" S PREFIX="TB ANTIBIOTIC" Q - Q PREFIX - ; +ORWGAPIU ; SLC/STAFF - Graph API Utilities ;8/19/06 15:20 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,260**;Dec 17, 1997;Build 26 + ; +EVALUE(VAL,FILE,FIELD) ; $$(internal value,file,field) -> external value or "" + ; from ORWGAPI1, ORWGAPI2, ORWGAPI3, ORWGAPI4, ORWGAPIP, ORWGAPIR + I VAL="" Q "" + S FIELD=$G(FIELD,.01) + I $E(FILE,1,2)=63 Q $$LABNAME^ORWGAPIA(VAL) + I FILE="63AP;I" Q $$ICD9^ORWGAPIA(VAL) + I FILE="45DX" Q $$ICD9^ORWGAPIA(VAL) + I FILE="45OP" Q $$ICD0^ORWGAPIA(VAL) + I FILE="45;ICD9" Q $$ICD9^ORWGAPIA(VAL) + I FILE="45;ICD0" Q $$ICD0^ORWGAPIA(VAL) + I FIELD=.01,'$L(VAL) Q "" + I FILE=9000010.07 Q $$ICD9^ORWGAPIA(VAL) + I FILE=9000010.18 Q $$ICPT^ORWGAPIA(VAL) + I FILE=9000011 Q $$ICD9^ORWGAPIA(VAL) + I FILE=9999911 Q $$ICD9^ORWGAPIA(VAL) + I FILE=130 Q $$ICPT^ORWGAPIA(VAL) + I FILE=120.8 Q $$ALLG^ORWGAPIA(VAL) + I FILE=50.605 Q $$DC^ORWGAPIA(VAL) + I FILE=68 Q $$AA^ORWGAPIA(VAL) + I FILE=811.2 Q $$TAX^ORWGAPIA(VAL) + D + . I FILE=52 S FIELD=6 Q + . I FILE=53.79 S FIELD=.08 Q + . I FILE=55 S FILE=55.07 Q + . I FILE="55NVAE" S FILE=55.05 Q + . I FILE="55NVA" S FILE=55.05 Q + . I FILE=70 S FILE=70.03,FIELD=2 Q + . I FILE=100 S FILE=100.001 Q + . I FILE=120.5 S FIELD=.03 Q + . I FILE=601.2 S FILE=601.21 Q + Q $$EXT^ORWGAPIX(VAL,FILE,FIELD) + ; +FILE(FILE,REF,XREF,SCREEN) ; from ORWGAPI + S REF="",SCREEN="I 1",XREF="B" + I FILE="" Q + D + . I FILE="45DX" S REF=$$GBLREF(80),XREF="AB" Q + . I FILE="45OP" S REF=$$GBLREF(80.1),XREF="AB" Q + . I FILE=50.605 S REF=$$GBLREF(50.605),XREF="C" Q + . I FILE=52 S REF=$$GBLREF(50) Q + . I FILE=53.79 S REF=$$GBLREF(50.7),SCREEN="I $P(ZERO,U,10)'=1" Q + . I FILE=55 S REF=$$GBLREF(50) Q + . I FILE="55NVAE" S REF=$$GBLREF(50.7),SCREEN="I $P(ZERO,U,10)=1" Q + . I FILE="55NVA" S REF=$$GBLREF(50.7),SCREEN="I $P(ZERO,U,10)=1" Q + . I FILE=63 S REF=$$GBLREF(60),SCREEN="I $L($P(ZERO,U,5)),""BO""[$P(ZERO,U,3),$P(ZERO,U,4)=""CH""" Q + . I FILE="63AP" S REF=$$GBLREF(60),SCREEN="I 0" Q + . I FILE="63AP;D" S REF=$$GBLREF(61.4) Q + . I FILE="63AP;E" S REF=$$GBLREF(61.2) Q + . I FILE="63AP;F" S REF=$$GBLREF(61.3) Q + . I FILE="63AP;I" S REF=$$GBLREF(80),XREF="AB" Q + . I FILE="63AP;M" S REF=$$GBLREF(61.1) Q + . I FILE="63AP;O" S REF=$$GBLREF(61) Q + . I FILE="63AP;P" S REF=$$GBLREF(61.5) Q + . I FILE="63AP;T" S REF=$$GBLREF(60),SCREEN="I ""BO""[$P(ZERO,U,3),(($P(ZERO,U,4)=""CY"")!($P(ZERO,U,4)=""SP"")!($P(ZERO,U,4)=""EM"")!($P(ZERO,U,4)=""AU""))" Q + . I FILE="63BB" S REF=$$GBLREF(66),SCREEN="I $P(ZERO,U,15)=1" Q + . I FILE="63MI" S REF=$$GBLREF(60),SCREEN="I 0" Q + . I FILE="63MI;A" S REF=$$GBLREF(62.06) Q + . I FILE="63MI;M" S REF=$$GBLREF(60) Q ; mycobacteria not currently used + . I FILE="63MI;O" S REF=$$GBLREF(61.2),SCREEN="I $L($P(ZERO,U,5)),""BFPMV""[$P(ZERO,U,5)" Q + . I FILE="63MI;S" S REF=$$GBLREF(61) Q + . I FILE="63MI;T" S REF=$$GBLREF(60),SCREEN="I ""BO""[$P(ZERO,U,3),$P(ZERO,U,4)=""MI""" Q + . I FILE=70 S REF=$$GBLREF(71) Q + . I FILE=100 S REF=$$GBLREF(101.43) Q + . I FILE=120.5 S REF=$$GBLREF(120.51),SCREEN="I ""BP^P^T^R^P^HT^WT^CVP^CG^PO2^PN""[$P(ZERO,U,2)" Q + . ;I FILE=120.8 S REF=$$GBLREF(120.83) Q + . I FILE=130 S REF=$$GBLREF(81),SCREEN="I '$P(ZERO,U,4)" Q + . I FILE=405 S REF=$$GBLREF(44),SCREEN="I 0" Q + . I FILE=601.2 S REF=$$GBLREF(601) Q + . I FILE=690 S REF=$$GBLREF(697.2),XREF="BA" Q + . I FILE=811.2 S REF=$$GBLREF(811.2),SCREEN="I $P(ZERO,U,6)'=1" Q + . I FILE=8925 S REF=$$GBLREF(8925.1),SCREEN="I $P(ZERO,U,4)=""DOC""" Q + . I FILE=9000010 S REF=$$GBLREF(44) Q + . I FILE=9000010.07 S REF=$$GBLREF(80),XREF="AB" Q + . I FILE=9000010.11 S REF=$$GBLREF(9999999.14),SCREEN="I $P(ZERO,U,7)'=1" Q + . I FILE=9000010.12 S REF=$$GBLREF(9999999.28),SCREEN="I $P(ZERO,U,3)'=1" Q + . I FILE=9000010.13 S REF=$$GBLREF(9999999.15),SCREEN="I $P(ZERO,U,4)'=1" Q + . I FILE=9000010.15 S REF=$$GBLREF(9999999.17),SCREEN="I $P(ZERO,U,4)'=1" Q + . I FILE=9000010.16 S REF=$$GBLREF(9999999.09),SCREEN="I $P(ZERO,U,3)'=1" Q + . I FILE=9000010.18 S REF=$$GBLREF(81),SCREEN="I '$P(ZERO,U,4)" Q + . I FILE=9000010.23 S REF=$$GBLREF(9999999.64),SCREEN="I $P(ZERO,U,10)=""F"",$P(ZERO,U,11)'=1" Q + . I FILE=9000011 S REF=$$GBLREF(80),XREF="AB",SCREEN="I $E(ZERO)'=""E"",'$L($P(ZERO,U,9))" Q + . I FILE=9999911 S REF=$$GBLREF(80),XREF="AB",SCREEN="I $E(ZERO)'=""E"",'$L($P(ZERO,U,9))" Q + I $E(REF)'="^" S REF="" + S REF=REF ;_""""_XREF_""")" + Q + ; +GBLREF(FN) ; $$(file#) -> global reference + Q $$GBLREF^ORWGAPIX($G(FN)) + ; +GENERIC(VAL,FROM,DIR,FILE,REF,XREF,SCREEN) ; Return a set of entries from xref in REF + ; from ORWGAPI + ; .VAL=returned list, FROM=text to $O from, DIR=$O direction, + N CNT,IEN,NAME,NEXTNAME,NUM,OK,ROOT,ZERO S NUM=0,CNT=44 K VAL + I FILE=405 Q + S ROOT="" + S FROM=$$UP^ORWGAPIX(FROM) + I $E(REF,$L(REF))="," S ROOT=$E(REF,1,$L(REF)-1)_")" + I $E(REF,$L(REF))="(" S ROOT=$P(REF,"(") + I '$L(ROOT) Q + S REF=REF_""""_XREF_""")" + F Q:NUM'0 Q + .. S ZERO=$G(@ROOT@(IEN,0)) I '$L(ZERO) Q + .. X SCREEN I '$T Q + .. S NUM=NUM+1 + .. I FILE="45DX"!(FILE=9000010.07)!(FILE=9000011)!(FILE="63AP;I") D Q + ... S VAL(NUM)=FILE_U_IEN_U_$$ICD9^ORWGAPIA(IEN) Q + .. I FILE="45OP" S VAL(NUM)=FILE_U_IEN_U_$$ICD0^ORWGAPIA(IEN) Q + .. I FILE="55NVAE"!(FILE=53.79) S VAL(NUM)=FILE_U_IEN_U_$$POINAME^ORWGAPIA(IEN) Q + .. I FILE="55NVA" S VAL(NUM)=FILE_U_IEN_U_$$POINAME^ORWGAPIA(IEN) Q + .. I FILE=9000010.18 S VAL(NUM)=FILE_U_IEN_U_$$ICPT^ORWGAPIA(IEN) Q + .. I FILE=130 S VAL(NUM)=FILE_U_IEN_U_$$ICPT^ORWGAPIA(IEN) Q + .. S VAL(NUM)=FILE_U_IEN_U_FROM + I FILE=120.5 D + . S (NUM,OK)=0 + . F S NUM=$O(VAL(NUM)) Q:NUM<1 D Q:OK + .. S NAME=$P(VAL(NUM),U,3) + .. S NEXTNAME=$P($G(VAL(NUM+1)),U,3) + .. I "BODY MASS INDEX"]NAME,NEXTNAME]"BODY MASS INDEX" D + ... S OK=1 + ... S VAL(NUM+.5)="120.5^99999^BODY MASS INDEX" + Q + ; +INISET ; postinit, set initial public graph setting - from ORY215 + D INISET^ORWGAPIP + Q + ; +ITEMPRFX(ITEM) ; $$(item) -> item prefix - from ORWGAPI1 + N ABBREV,PREFIX + S PREFIX="" + S ABBREV=$P(ITEM,";",2) + I $E(ITEM)="A" D Q PREFIX + . I ABBREV="T" S PREFIX="TEST" Q + . I ABBREV="S" S PREFIX="SPECIMEN" Q + . I ABBREV="O" S PREFIX="ORGAN" Q + . I ABBREV="M" S PREFIX="MORPHOLOGY" Q + . I ABBREV="E" S PREFIX="ETIOLOGY" Q + . I ABBREV="D" S PREFIX="DISEASE" Q + . I ABBREV="P" S PREFIX="PROCEDURE" Q + . I ABBREV="F" S PREFIX="FUNCTION" Q + . I ABBREV="I" S PREFIX="ICD9" Q + I $E(ITEM)="B" Q "BLOOD COMPONENT" + I $E(ITEM)="M" D Q PREFIX + . I ABBREV="T" S PREFIX="TEST" Q + . I ABBREV="S" S PREFIX="SPECIMEN" Q + . I ABBREV="O" S PREFIX="ORGANISM" Q + . I ABBREV="A" S PREFIX="ANTIBIOTIC" Q + . I ABBREV="M" S PREFIX="TB ANTIBIOTIC" Q + Q PREFIX + ; +OGROUP(OITEM) ; $$(orderable item) -> ien display group^display group - from ORWGAPIR + N IEN + S IEN=+$P($G(^ORD(101.43,+$G(OITEM),0)),U,5) + Q IEN_U_"order - "_$P($G(^ORD(100.98,IEN,0)),U) + ; +RETURN(TMP,ITEMS) ; return TMP (0 use local, 1 use ^TMP(ITEMS,$J, where ITEMS is a namespaced string) + ; from ORWGAPI, ORWGAPIP, ORWGAPIX + N NMSP + S NMSP=$G(ITEMS) K ITEMS S ITEMS="" + S TMP=NMSP?1U1UN1.14UNP + I TMP S ITEMS=NMSP + Q + ; +SETUP(DATA,RESULT,TMP,CNT) ; from ORWGAPI1, ORWGAPI2, ORWGAPI3, ORWGAPI4, ORWGAPIP, ORWGAPIR, ORWGAPIX + S CNT=CNT+1 + I TMP S ^TMP(DATA,$J,CNT)=RESULT + I 'TMP S DATA(CNT)=RESULT + Q + ; +DATETFM(DATETIME) ; $$(external date/time) -> fm date/time else 0 + N DATE,DAY,FMDT,HOUR,MIN,SEC,TIME,YEAR + S DATE=$P(DATETIME,"@"),TIME=$P(DATETIME,"@",2) + S YEAR=$P(DATE,",",2) I $L(YEAR)'=4 Q 0 + S YEAR=YEAR-1700 I YEAR<270 Q 0 + S MONTH=$P(DATE," ") + S MONTH=$$MTN(MONTH) I MONTH<1 Q 0 + I MONTH<10 S MONTH="0"_MONTH + S DAY=$P(DATE," ",2),DAY=$P(DAY,",") + I DAY<1 Q 0 + I DAY<10 S DAY="0"_DAY + S HOUR=$P(TIME,":") + S MIN=$P(TIME,":",2) + S SEC=$P(TIME,":",3) + S TIME=HOUR_MIN_SEC + S FMDT=YEAR_MONTH_DAY + I '$L(TIME) Q FMDT + Q FMDT_"."_TIME + ; +MTN(MONTH) ; $$(external month) -> month number + N MONTHS,NUM + I $L(MONTH)'=3 Q 0 + S MONTHS="JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC" + F NUM=1:1:13 I $P(MONTHS,U,NUM)=MONTH Q + I NUM=13 Q 0 + Q NUM diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPIX.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPIX.m index 2f6f1bed..31a01964 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPIX.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGAPIX.m @@ -1,154 +1,163 @@ -ORWGAPIX ; SLC/STAFF - Graph External Calls ;9/29/06 11:49 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,260,243**;Dec 17, 1997;Build 242 - ; -DATE(X) ; $$(date/time) -> date/time - N Y D ^%DT - Q Y -ENDIQ1(RESULTS,DIC,DR,DA,DIQ) ; use file # for DIC - N NUMDIC K RESULTS,^UTILITY("DIQ1",$J) - Q:'$G(DIC) Q:'$L(DR) Q:'$G(DA) - S NUMDIC=DIC - D EN^DIQ1 - M RESULTS=^UTILITY("DIQ1",$J,NUMDIC,DA) - K ^UTILITY("DIQ1",$J) - Q -EXT(Y,FILE,FIELD) ; $$(value,file,field) -> external value - N C S C=$P($G(^DD(FILE,FIELD,0)),U,2) D Y^DIQ - Q Y -EXTERNAL(FILE,FIELD,FLAG,VAL) ; $$(file,field,flag,internal value) -> external value - Q $$EXTERNAL^DILFD(FILE,FIELD,FLAG,VAL) -EXTNAME(IEN,FN) ; $$(ien,file#) -> external form of pointer - N REF - S REF=$G(^DIC(FN,0,"GL")) - I $L(REF),+IEN Q $P($G(@(REF_IEN_",0)")),U) - Q "" -FILENM(FILENUM) ; $$(file#) -> file name - N DIC,DO,NAME K DIC,DO - S FILENUM=$$GBLREF(+$G(FILENUM)) - I '$L($G(FILENUM)) Q "" - S DIC=FILENUM - D DO^DIC1 - S NAME=$P(DO,U) - Q NAME -GETDATA(RESULTS,DIC,DR,DA,DIQ) ; use file # for DIC - N NUMDIC K RESULTS,^UTILITY("DIQ1",$J) - Q:'$G(DIC) Q:'$L(DR) Q:'$G(DA) - S NUMDIC=DIC - D EN^DIQ1 - M RESULTS=^UTILITY("DIQ1",$J,NUMDIC,DA) - K ^UTILITY("DIQ1",$J) - Q -GBLREF(FILENUM) ; $$(file#) -> global reference - I '$G(FILENUM) Q "" - Q $$ROOT^DILFD(+FILENUM) -INDEX(DIK,DA) ; index entry in file - from ORWGAPIP - D IX1^DIK - Q -XDEL(ENTITY,PARAM,NAME,ORERR) ; from ORWGAPIP - D DEL^XPAR(ENTITY,PARAM,NAME,.ORERR) - Q -XEN(ENTITY,PARAM,NAME,ORVAL,ORERR) ; from ORWGAPIP - D EN^XPAR(ENTITY,PARAM,NAME,.ORVAL,.ORERR) - Q -XENVAL(ORVALUES,PARAM) ; - D ENVAL^XPAR(.ORVALUES,PARAM) - Q -XGET(ENTITY,PARAM,INST,FORMAT) ; $$(...) -> parameter values - Q $$GET^XPAR(ENTITY,PARAM,INST,FORMAT) -XGETLST(ORLIST,ENTITY,PARAM) ; from ORWGAPIP - D GETLST^XPAR(.ORLIST,ENTITY,PARAM) - Q -XGETLST1(ORLIST,ENTITY,PARAM,FORMAT,ORERR) ; from ORWGAPIP - D GETLST^XPAR(.ORLIST,ENTITY,PARAM,FORMAT,.ORERR) - Q -XGETWP(ORWP,ENTITY,PARAM,ALL) ; from ORWGAPIP - D GETWP^XPAR(.ORWP,ENTITY,PARAM,ALL) - Q - ; kernel functions -FMADD(X,D,H,M,S) ; - Q $$FMADD^XLFDT(X,$G(D),$G(H),$G(M),$G(S)) -NOW() ; - Q $$NOW^XLFDT -LOW(X) ; - Q $$LOW^XLFSTR(X) -REPLACE(STRING,ORARRAY) ; - Q $$REPLACE^XLFSTR(STRING,.ORARRAY) -TRIM(X,F,V) ; - Q $$TRIM^XLFSTR(X,$G(F,"LR"),$G(V," ")) -UP(X) ; - Q $$UP^XLFSTR(X) -BMIITEMS(ITEMS,CNT,TMP) ; from ORWGAPIR - N BMI,NUM,REPLACE K REPLACE - S REPLACE("WEIGHT")="BODY MASS INDEX" - S BMI="" - S NUM=0 - I 'TMP D - . F S NUM=$O(ITEMS(NUM)) Q:NUM<1 D - .. I $P(ITEMS(NUM),U,2)=8 S $P(BMI,U)=1 - .. I $P(ITEMS(NUM),U,2)=9 S $P(BMI,U,2)=ITEMS(NUM) - I TMP D - . F S NUM=$O(^TMP(ITEMS,$J,NUM)) Q:NUM<1 D - .. I $P(^TMP(ITEMS,$J,NUM),U,2)=8 S $P(BMI,U)=1 - .. I $P(^TMP(ITEMS,$J,NUM),U,2)=9 S $P(BMI,U,2)=^TMP(ITEMS,$J,NUM) - I BMI,$L(BMI)>3 D - . S CNT=CNT+1 - . S RESULT=$P(BMI,U,2,99) - . S RESULT=$$REPLACE^ORWGAPIX(RESULT,.REPLACE) - . S $P(RESULT,U,2)=99999 - . D SETUP^ORWGAPIW(.ITEMS,RESULT,TMP,.CNT) - Q - ; -BMIDATA(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPI4 - N DATE,DATE2,NODE,RESULT,VALUE,W K VALUE - S DATE="",DATE2="",CNT=$G(CNT) - F S DATE=$O(^PXRMINDX(120.5,"PI",DFN,9,DATE)) Q:DATE="" D - . I DATE>START Q - . S NODE="" - . F S NODE=$O(^PXRMINDX(120.5,"PI",DFN,9,DATE,NODE)) Q:NODE="" D - .. D VITAL^ORWGAPIA(.VALUE,NODE) S WT=$P($G(VALUE(7)),U) I 'WT Q - .. S BMI=$$BMI(DFN,WT,DATE) I 'BMI Q - .. S RESULT=120.5_U_ITEM_U_DATE_U_DATE2_U_BMI - .. D SETUP^ORWGAPIW(.DATA,RESULT,TMP,.CNT) - Q - ; -BMI(DFN,WT,DATE) ; $$(dfn,wt,date) -> bmi, else "" - N HDATE,HT,NEXT,NODE,PREV - I '$O(^PXRMINDX(120.5,"PI",DFN,8,0)) Q "" - S NODE=$O(^PXRMINDX(120.5,"PI",DFN,8,DATE,"")) - I '$L(NODE) D - . S NEXT=+$O(^PXRMINDX(120.5,"PI",DFN,8,DATE)) - . S PREV=+$O(^PXRMINDX(120.5,"PI",DFN,8,DATE),-1) - . S NODE=$O(^PXRMINDX(120.5,"PI",DFN,8,$$CLOSEST(DATE,NEXT,PREV),"")) - I '$L(NODE) Q "" - D VITAL^ORWGAPIA(.VALUE,NODE) S HT=$P($G(VALUE(7)),U) I 'HT Q "" - Q $$CALCBMI(HT,WT) - ; -CALCBMI(HT,WT) ; $$(ht,wt) -> bmi uses (inches,lbs) - S WT=WT/2.2 ;+$$WEIGHT^XLFMSMT(WT,"LB","KG") - S HT=HT*2.54/100 ;+$$LENGTH^XLFMSMT(HT,"IN","M") - Q $J(WT/(HT*HT),0,2) - ; -CLOSEST(DATE,NEXT,PREV) ; - I $$FMDIFF^XLFDT(DATE,NEXT,2)>$$FMDIFF^XLFDT(DATE,PREV,2) Q PREV - Q NEXT - ; -BMILAST(DFN,ARRAY,CNT) ; - N BMI,DATE,NUM,WT - S (DATE,NUM,WT)=0 - F S NUM=$O(ARRAY(NUM)) Q:NUM<1 D Q:WT - . I $P(ARRAY(NUM),U,2)'="WT" Q - . S WT=+$P(ARRAY(NUM),U,3) - . S DATE=$P(ARRAY(NUM),U,4) - I 'WT Q - I 'DATE Q - S BMI=$$BMI(DFN,WT,DATE) - I 'BMI Q - S CNT=CNT+1 - S ARRAY(CNT)="-1^BMI^"_BMI_U_DATE_U_BMI_"^^" - Q - ; -ZZ() ; test use only - this code will be removed before v27 release - N X,ZIP,ZZ - S ZZ=$C(36)_$C(90)_$C(72) - S ZIP="S X="_ZZ X ZIP - Q X +ORWGAPIX ; SLC/STAFF - Graph External Calls ;9/29/06 11:49 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,260**;Dec 17, 1997;Build 26 + ; +DATE(X) ; $$(date/time) -> date/time + N Y D ^%DT + Q Y +ENDIQ1(RESULTS,DIC,DR,DA,DIQ) ; use file # for DIC + N NUMDIC K RESULTS,^UTILITY("DIQ1",$J) + Q:'$G(DIC) Q:'$L(DR) Q:'$G(DA) + S NUMDIC=DIC + D EN^DIQ1 + M RESULTS=^UTILITY("DIQ1",$J,NUMDIC,DA) + K ^UTILITY("DIQ1",$J) + Q +EXT(Y,FILE,FIELD) ; $$(value,file,field) -> external value + N C S C=$P($G(^DD(FILE,FIELD,0)),U,2) D Y^DIQ + Q Y +EXTERNAL(FILE,FIELD,FLAG,VAL) ; $$(file,field,flag,internal value) -> external value + Q $$EXTERNAL^DILFD(FILE,FIELD,FLAG,VAL) +EXTNAME(IEN,FN) ; $$(ien,file#) -> external form of pointer + N REF + S REF=$G(^DIC(FN,0,"GL")) + I $L(REF),+IEN Q $P($G(@(REF_IEN_",0)")),U) + Q "" +FILENM(FILENUM) ; $$(file#) -> file name + N DIC,DO,NAME K DIC,DO + S FILENUM=$$GBLREF(+$G(FILENUM)) + I '$L($G(FILENUM)) Q "" + S DIC=FILENUM + D DO^DIC1 + S NAME=$P(DO,U) + Q NAME +GETDATA(RESULTS,DIC,DR,DA,DIQ) ; use file # for DIC + N NUMDIC K RESULTS,^UTILITY("DIQ1",$J) + Q:'$G(DIC) Q:'$L(DR) Q:'$G(DA) + S NUMDIC=DIC + D EN^DIQ1 + M RESULTS=^UTILITY("DIQ1",$J,NUMDIC,DA) + K ^UTILITY("DIQ1",$J) + Q +GBLREF(FILENUM) ; $$(file#) -> global reference + I '$G(FILENUM) Q "" + Q $$ROOT^DILFD(+FILENUM) +INDEX(DIK,DA) ; index entry in file - from ORWGAPIP + D IX1^DIK + Q +XDEL(ENTITY,PARAM,NAME,ORERR) ; from ORWGAPIP + D DEL^XPAR(ENTITY,PARAM,NAME,.ORERR) + Q +XEN(ENTITY,PARAM,NAME,ORVAL,ORERR) ; from ORWGAPIP + D EN^XPAR(ENTITY,PARAM,NAME,.ORVAL,.ORERR) + Q +XENVAL(ORVALUES,PARAM) ; + D ENVAL^XPAR(.ORVALUES,PARAM) + Q +XGET(ENTITY,PARAM,INST,FORMAT) ; $$(...) -> parameter values + Q $$GET^XPAR(ENTITY,PARAM,INST,FORMAT) +XGETLST(ORLIST,ENTITY,PARAM) ; from ORWGAPIP + D GETLST^XPAR(.ORLIST,ENTITY,PARAM) + Q +XGETLST1(ORLIST,ENTITY,PARAM,FORMAT,ORERR) ; from ORWGAPIP + D GETLST^XPAR(.ORLIST,ENTITY,PARAM,FORMAT,.ORERR) + Q +XGETWP(ORWP,ENTITY,PARAM,ALL) ; from ORWGAPIP + D GETWP^XPAR(.ORWP,ENTITY,PARAM,ALL) + Q + ; kernel functions +FMADD(X,D,H,M,S) ; + Q $$FMADD^XLFDT(X,$G(D),$G(H),$G(M),$G(S)) +NOW() ; + Q $$NOW^XLFDT +LOW(X) ; + Q $$LOW^XLFSTR(X) +REPLACE(STRING,ORARRAY) ; + Q $$REPLACE^XLFSTR(STRING,.ORARRAY) +TRIM(X,F,V) ; + Q $$TRIM^XLFSTR(X,$G(F,"LR"),$G(V," ")) +UP(X) ; + Q $$UP^XLFSTR(X) +INSIG(NODE) ; $$(node) -> sig ; replace INSIG^ORWGAPIA with this code in v27 + N SIG,SUB,VALUES K VALUES + S SUB=$P($G(NODE),";",2) + D RXIN^ORWGAPIA(NODE,.VALUES) + S SIG="" + I SUB=5 D + . S SIG=" Give: "_$G(VALUES("MR")) + . S SIG=SIG_" "_$P($G(VALUES("SCH",1,0)),U) + . S SIG=SIG_" "_$P($G(VALUES("SCH",1,0)),U,2) + I SUB="IV" D + . S SIG=" Give: "_$G(VALUES("DO")) + . S SIG=SIG_" "_$$EXT^ORWGAPIX($G(VALUES("START")),55.01,.02) + . S SIG=SIG_" "_$G(VALUES("SCH",1,0)) + Q SIG + ; +BMIITEMS(ITEMS,CNT,TMP) ; from ORWGAPIR + N BMI,NUM,REPLACE K REPLACE + S REPLACE("WEIGHT")="BODY MASS INDEX" + S BMI="" + S NUM=0 + I 'TMP D + . F S NUM=$O(ITEMS(NUM)) Q:NUM<1 D + .. I $P(ITEMS(NUM),U,2)=8 S $P(BMI,U)=1 + .. I $P(ITEMS(NUM),U,2)=9 S $P(BMI,U,2)=ITEMS(NUM) + I TMP D + . F S NUM=$O(^TMP(ITEMS,$J,NUM)) Q:NUM<1 D + .. I $P(^TMP(ITEMS,$J,NUM),U,2)=8 S $P(BMI,U)=1 + .. I $P(^TMP(ITEMS,$J,NUM),U,2)=9 S $P(BMI,U,2)=^TMP(ITEMS,$J,NUM) + I BMI,$L(BMI)>3 D + . S CNT=CNT+1 + . S RESULT=$P(BMI,U,2,99) + . S RESULT=$$REPLACE^ORWGAPIX(RESULT,.REPLACE) + . S $P(RESULT,U,2)=99999 + . D SETUP^ORWGAPIU(.ITEMS,RESULT,TMP,.CNT) + Q + ; +BMIDATA(DATA,ITEM,START,DFN,CNT,TMP) ; from ORWGAPI4 + N DATE,DATE2,NODE,RESULT,VALUE,W K VALUE + S DATE="",DATE2="",CNT=$G(CNT) + F S DATE=$O(^PXRMINDX(120.5,"PI",DFN,9,DATE)) Q:DATE="" D + . I DATE>START Q + . S NODE="" + . F S NODE=$O(^PXRMINDX(120.5,"PI",DFN,9,DATE,NODE)) Q:NODE="" D + .. D VITAL^ORWGAPIA(.VALUE,NODE) S WT=$P($G(VALUE(7)),U) I 'WT Q + .. S BMI=$$BMI(DFN,WT,DATE) I 'BMI Q + .. S RESULT=120.5_U_ITEM_U_DATE_U_DATE2_U_BMI + .. D SETUP^ORWGAPIU(.DATA,RESULT,TMP,.CNT) + Q + ; +BMI(DFN,WT,DATE) ; $$(dfn,wt,date) -> bmi, else "" + N HDATE,HT,NEXT,NODE,PREV + I '$O(^PXRMINDX(120.5,"PI",DFN,8,0)) Q "" + S NODE=$O(^PXRMINDX(120.5,"PI",DFN,8,DATE,"")) + I '$L(NODE) D + . S NEXT=+$O(^PXRMINDX(120.5,"PI",DFN,8,DATE)) + . S PREV=+$O(^PXRMINDX(120.5,"PI",DFN,8,DATE),-1) + . S NODE=$O(^PXRMINDX(120.5,"PI",DFN,8,$$CLOSEST(DATE,NEXT,PREV),"")) + I '$L(NODE) Q "" + D VITAL^ORWGAPIA(.VALUE,NODE) S HT=$P($G(VALUE(7)),U) I 'HT Q "" + Q $$CALCBMI(HT,WT) + ; +CALCBMI(HT,WT) ; $$(ht,wt) -> bmi uses (inches,lbs) + S WT=WT/2.2 ;+$$WEIGHT^XLFMSMT(WT,"LB","KG") + S HT=HT*2.54/100 ;+$$LENGTH^XLFMSMT(HT,"IN","M") + Q $J(WT/(HT*HT),0,2) + ; +CLOSEST(DATE,NEXT,PREV) ; + I $$FMDIFF^XLFDT(DATE,NEXT,2)>$$FMDIFF^XLFDT(DATE,PREV,2) Q PREV + Q NEXT + ; +BMILAST(DFN,ARRAY,CNT) ; + N BMI,DATE,NUM,WT + S (DATE,NUM,WT)=0 + F S NUM=$O(ARRAY(NUM)) Q:NUM<1 D Q:WT + . I $P(ARRAY(NUM),U,2)'="WT" Q + . S WT=+$P(ARRAY(NUM),U,3) + . S DATE=$P(ARRAY(NUM),U,4) + I 'WT Q + I 'DATE Q + S BMI=$$BMI(DFN,WT,DATE) + I 'BMI Q + S CNT=CNT+1 + S ARRAY(CNT)="-1^BMI^"_BMI_U_DATE_U_BMI_"^^" + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGRPC.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGRPC.m index 7a73a5af..9fdf1e2b 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGRPC.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWGRPC.m @@ -1,136 +1,106 @@ -ORWGRPC ; SLC/STAFF - Graph RPC ;3/9/06 13:59 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,243**;Dec 17, 1997;Build 242 - ; -ALLITEMS(ITEMS,DFN) ; RPC - get all items of data on patient (procedures, tests, codes,..) - D ALLITEMS^ORWGAPI("ORWGRPC",DFN) - S ITEMS=$NA(^TMP("ORWGRPC",$J)) - Q - ; -ALLVIEWS(DATA,VIEW,USER) ; RPC - get all graph views - D ALLVIEWS^ORWGAPI("ORWGRPC",+$G(VIEW),+$G(USER)) - S DATA=$NA(^TMP("ORWGRPC",$J)) - Q - ; -CLASS(DATA,TYPE) ; RPC - get classifications - D CLASS^ORWGAPI("ORWGRPC",TYPE) - S DATA=$NA(^TMP("ORWGRPC",$J)) - Q - ; -DATEDATA(DATA,OLDEST,NEWEST,TYPEITEM,DFN) ; RPC - get data for an item on patient in date range - D DATEDATA^ORWGAPI("ORWGRPC",OLDEST,NEWEST,TYPEITEM,DFN) - S DATA=$NA(^TMP("ORWGRPC",$J)) - Q - ; -DATEITEM(DATA,OLDEST,NEWEST,FNUM,DFN) ; RPC - get patient items in date range for a type - D DATEITEM^ORWGAPI("ORWGRPC",OLDEST,NEWEST,FNUM,DFN) - S DATA=$NA(^TMP("ORWGRPC",$J)) - Q - ; -DELVIEWS(ERR,NAME,PUBLIC) ; RPC - delete a graph view - D DELVIEWS^ORWGAPI("ORWGRPC",NAME,+$G(PUBLIC)) - S ERR=$NA(^TMP("ORWGRPC",$J)) - Q - ; -DETAIL(ITEMS,DFN,DATE1,DATE2,VAL,COMP) ; RPC - get all reports for types of data from items and date range - D DETAIL^ORWGAPI("ORWGRPC",DFN,DATE1,DATE2,.VAL,$G(COMP)) - S ITEMS=$NA(^TMP("ORWGRPC",$J)) - Q - ; -DETAILS(ITEMS,DFN,DATE1,DATE2,TYPE,COMP) ; RPC - get report for type of data for a date or date range - D DETAILS^ORWGAPI("ORWGRPC",DFN,DATE1,DATE2,TYPE,$G(COMP)) - S ITEMS=$NA(^TMP("ORWGRPC",$J)) - Q - ; -FASTDATA(DATA,DFN) ; RPC - get all data (non-lab) set up on patient - D FASTDATA^ORWGAPI(.DATA,DFN) - Q - ; -FASTITEM(ITEMS,DFN) ; RPC - get all items set up on patient - D FASTITEM^ORWGAPI(.ITEMS,DFN) - Q - ; -FASTLABS(DATA,DFN) ; RPC - get all lab data set up on patient - D FASTLABS^ORWGAPI(.DATA,DFN) - Q - ; -FASTTASK(STATUS,DFN,OLDDFN) ; set up all data and items on patient - D FASTTASK^ORWGAPI(.STATUS,DFN,$G(OLDDFN)) - Q - ; -GETDATES(DATA,REPORTID) ; RPC - get graph date range - D GETDATES^ORWGAPI("ORWGRPC",$G(REPORTID)) - S DATA=$NA(^TMP("ORWGRPC",$J)) - Q - ; -GETPREF(DATA) ; RPC - get graph settings - D GETPREF^ORWGAPI("ORWGRPC") - S DATA=$NA(^TMP("ORWGRPC",$J)) - Q - ; -GETSIZE(DATA) ; RPC - get graph positions and sizes - D GETSIZE^ORWGAPI("ORWGRPC") - S DATA=$NA(^TMP("ORWGRPC",$J)) - Q - ; -GETVIEWS(DATA,ALL,PUBLIC,EXT,USER) ; RPC - get graph views - D GETVIEWS^ORWGAPI("ORWGRPC",ALL,+$G(PUBLIC),+$G(EXT),+$G(USER)) - S DATA=$NA(^TMP("ORWGRPC",$J)) - Q - ; -ITEMDATA(DATA,ITEM,START,DFN) ; RPC - get data of an item on patient (glucose results) - D ITEMDATA^ORWGAPI("ORWGRPC",ITEM,START,DFN) - S DATA=$NA(^TMP("ORWGRPC",$J)) - Q - ; -ITEMS(ITEMS,DFN,TYPE) ; RPC - get items of a type of data on patient (lab tests) - D ITEMS^ORWGAPI("ORWGRPC",DFN,TYPE) - S ITEMS=$NA(^TMP("ORWGRPC",$J)) - Q - ; -LOOKUP(VAL,INFO,FROM,DIR) ; RPC - get item names for long lookup - D LOOKUP^ORWGAPI(.VAL,INFO,.FROM,DIR) - Q - ; -PUBLIC(VAL) ; RPC - check if user can edit public views and settings - S VAL=$$PUBLIC^ORWGAPI(DUZ) - Q - ; -RPTPARAM(VAL,IEN) ; RPC - return PARAM1^PARAM2 for graph report - S VAL=$$RPTPARAM^ORWGAPI(IEN) - Q - ; -SETPREF(ERR,SETTING,PUBLIC) ; RPC - set a graph setting - D SETPREF^ORWGAPI("ORWGRPC",SETTING,+$G(PUBLIC)) - S ERR=$NA(^TMP("ORWGRPC",$J)) - Q - ; -SETSIZE(ERR,VAL) ; RPC - set graph positions and sizes - D SETSIZE^ORWGAPI("ORWGRPC",.VAL) - S ERR=$NA(^TMP("ORWGRPC",$J)) - Q - ; -SETVIEWS(ERR,NAME,PUBLIC,VAL) ; RPC - set a graph view - D SETVIEWS^ORWGAPI("ORWGRPC",NAME,+$G(PUBLIC),.VAL) - S ERR=$NA(^TMP("ORWGRPC",$J)) - Q - ; -TAX(DATA,ALL,REMTAX) ; RPC - get reminder taxonomies - D TAX^ORWGAPI("ORWGRPC",+$G(ALL),.REMTAX) - S DATA=$NA(^TMP("ORWGRPC",$J)) - Q - ; -TESTING(DATA) ; RPC - cache data - D TESTING^ORWGAPI("ORWGRPC") - S DATA=$NA(^TMP("ORWGRPC",$J)) - Q - ; -TESTSPEC(DATA) ; RPC - get test/spec info on all lab tests - D TESTSPEC^ORWGAPI("ORWGRPC") - S DATA=$NA(^TMP("ORWGRPC",$J)) - Q - ; -TYPES(TYPES,DFN,SUB) ; RPC - get all the types of data on a patient (SUB=1, gets subtypes, DFN=0 gets all types), - D TYPES^ORWGAPI("ORWGRPC",DFN,+$G(SUB)) - S TYPES=$NA(^TMP("ORWGRPC",$J)) - Q - ; +ORWGRPC ; SLC/STAFF - Graph RPC ;3/9/06 13:59 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215**;Dec 17, 1997 + ; +ALLITEMS(ITEMS,DFN) ; RPC - get all items of data on patient (procedures, tests, codes,..) + D ALLITEMS^ORWGAPI("ORWGRPC",DFN) + S ITEMS=$NA(^TMP("ORWGRPC",$J)) + Q + ; +CLASS(DATA,TYPE) ; RPC - get classifications + D CLASS^ORWGAPI("ORWGRPC",TYPE) + S DATA=$NA(^TMP("ORWGRPC",$J)) + Q + ; +DATEITEM(DATA,OLDEST,NEWEST,FNUM,DFN) ; RPC - get patient items in date range for a type + D DATEITEM^ORWGAPI("ORWGRPC",OLDEST,NEWEST,FNUM,DFN) + S DATA=$NA(^TMP("ORWGRPC",$J)) + Q + ; +DELVIEWS(ERR,NAME,PUBLIC) ; RPC - delete a graph view + D DELVIEWS^ORWGAPI("ORWGRPC",NAME,+$G(PUBLIC)) + S ERR=$NA(^TMP("ORWGRPC",$J)) + Q + ; +DETAIL(ITEMS,DFN,DATE1,DATE2,VAL,COMP) ; RPC - get all reports for types of data from items and date range + D DETAIL^ORWGAPI("ORWGRPC",DFN,DATE1,DATE2,.VAL,$G(COMP)) + S ITEMS=$NA(^TMP("ORWGRPC",$J)) + Q + ; +DETAILS(ITEMS,DFN,DATE1,DATE2,TYPE,COMP) ; RPC - get report for type of data for a date or date range + D DETAILS^ORWGAPI("ORWGRPC",DFN,DATE1,DATE2,TYPE,$G(COMP)) + S ITEMS=$NA(^TMP("ORWGRPC",$J)) + Q + ; +GETDATES(DATA,REPORTID) ; RPC - get graph date range + D GETDATES^ORWGAPI("ORWGRPC",$G(REPORTID)) + S DATA=$NA(^TMP("ORWGRPC",$J)) + Q + ; +GETPREF(DATA) ; RPC - get graph settings + D GETPREF^ORWGAPI("ORWGRPC") + S DATA=$NA(^TMP("ORWGRPC",$J)) + Q + ; +GETSIZE(DATA) ; RPC - get graph positions and sizes + D GETSIZE^ORWGAPI("ORWGRPC") + S DATA=$NA(^TMP("ORWGRPC",$J)) + Q + ; +GETVIEWS(DATA,ALL,PUBLIC,EXT) ; RPC - get graph views + D GETVIEWS^ORWGAPI("ORWGRPC",ALL,+$G(PUBLIC),+$G(EXT)) + S DATA=$NA(^TMP("ORWGRPC",$J)) + Q + ; +ITEMDATA(DATA,ITEM,START,DFN) ; RPC - get data of an item on patient (glucose results) + S ITEM=$$UP^ORWGAPIX(ITEM) + D ITEMDATA^ORWGAPI("ORWGRPC",ITEM,START,DFN) + S DATA=$NA(^TMP("ORWGRPC",$J)) + Q + ; +ITEMS(ITEMS,DFN,TYPE) ; RPC - get items of a type of data on patient (lab tests) + D ITEMS^ORWGAPI("ORWGRPC",DFN,TYPE) + S ITEMS=$NA(^TMP("ORWGRPC",$J)) + Q + ; +LOOKUP(VAL,INFO,FROM,DIR) ; RPC - get item names for long lookup + D LOOKUP^ORWGAPI(.VAL,INFO,.FROM,DIR) + Q + ; +PUBLIC(VAL) ; RPC - check if user can edit public views and settings + S VAL=$$PUBLIC^ORWGAPI(DUZ) + Q + ; +RPTPARAM(VAL,IEN) ; RPC - return PARAM1^PARAM2 for graph report + S VAL=$$RPTPARAM^ORWGAPI(IEN) + Q + ; +SETPREF(ERR,SETTING,PUBLIC) ; RPC - set a graph setting + D SETPREF^ORWGAPI("ORWGRPC",SETTING,+$G(PUBLIC)) + S ERR=$NA(^TMP("ORWGRPC",$J)) + Q + ; +SETSIZE(ERR,VAL) ; RPC - set graph positions and sizes + D SETSIZE^ORWGAPI("ORWGRPC",.VAL) + S ERR=$NA(^TMP("ORWGRPC",$J)) + Q + ; +SETVIEWS(ERR,NAME,PUBLIC,VAL) ; RPC - set a graph view + D SETVIEWS^ORWGAPI("ORWGRPC",NAME,+$G(PUBLIC),.VAL) + S ERR=$NA(^TMP("ORWGRPC",$J)) + Q + ; +TAX(DATA,ALL,REMTAX) ; RPC - get reminder taxonomies + D TAX^ORWGAPI("ORWGRPC",+$G(ALL),.REMTAX) + S DATA=$NA(^TMP("ORWGRPC",$J)) + Q + ; +TESTSPEC(DATA) ; RPC - get test/spec info on all lab tests + D TESTSPEC^ORWGAPI("ORWGRPC") + S DATA=$NA(^TMP("ORWGRPC",$J)) + Q + ; +TYPES(TYPES,DFN,SUB) ; RPC - get all the types of data on a patient (SUB=1, gets subtypes, DFN=0 gets all types), + D TYPES^ORWGAPI("ORWGRPC",DFN,+$G(SUB)) + S TYPES=$NA(^TMP("ORWGRPC",$J)) + Q + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWNSS.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWNSS.m index af79ee99..76821808 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWNSS.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWNSS.m @@ -1,50 +1,50 @@ -ORWNSS ;JDL/SLC Non-Standard Schedule ;11/24/06 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**195,243**;Dec 17, 1997;Build 242 -NSSOK(ORY,ORX) ;Check availability for Non-standard schedule - N VAL - S VAL=$$PATCH^XPDUTL("PSJ*5.0*113") - S ORY=VAL - Q -NSSMSG(ORY) ;Retrieve site message for None-Standard Schedule - N ORSRV - S ORY="" - S ORSRV=$G(^VA(200,DUZ,5)) I +ORSRV>0 S ORSRV=$P(ORSRV,U) - S ORY=$$GET^XPAR("SRV.`"_+$G(ORSRV)_"^DIV^SYS","ORWIM NSS MESSAGE",1,"I") - Q -VALSCH(ORY,ORID) ;Validate a schedule for IM order; 1: valid, 0: invalid - ; - S ORY=0 - Q:'$D(^OR(100,+ORID,0)) - N IPGRP,ORGRP - S IPGRP=$O(^ORD(100.98,"B","UD RX",0)) - S ORGRP=$P($G(^OR(100,+ORID,0)),U,11) - I ORGRP'=IPGRP S ORY=1 Q - N SCH,IDX,SCHVAL S (SCH,SCHVAL)="" - I $D(^OR(100,+ORID,4.5,"ID","SCHEDULE")) S SCH=$O(^OR(100,+ORID,4.5,"ID","SCHEDULE",0)) - I SCH="" S ORY=1 Q - S IDX=0 F S IDX=$O(^OR(100,+ORID,4.5,SCH,IDX)) Q:'IDX D - . S SCHVAL=$G(^OR(100,+ORID,4.5,SCH,IDX)) - . Q:'$L(SCHVAL) - . D VALSCH^ORWDPS33(.ORY,SCHVAL,"I") - . I ORY=0 Q - Q -QOSCH(ORY,QOID) ;Validate IM QO schedule - ;QOID: Inpt Pharmacy QO - S ORY="" - N QOSCH,SCHID,SCHVAL,RST - S SCHID=$O(^ORD(101.41,"B","OR GTX SCHEDULE",0)) - S (QOSCH,SCHVAL)="",RST=1 - I '$D(^ORD(101.41,+QOID,6,"D",SCHID)) S ORY="schedule is not defined." Q - S QOSCH=$O(^ORD(101.41,+QOID,6,"D",SCHID,0)) - I 'QOSCH S ORY="schedule is not defined." Q - N IDX S IDX=0 - F S IDX=$O(^ORD(101.41,+QOID,6,QOSCH,IDX)) Q:'IDX!('RST) D - . S SCHVAL=^ORD(101.41,+QOID,6,QOSCH,IDX) - . I $$UP^XLFSTR(SCHVAL)="OTHER" S ORY="OTHER" Q - . D VALSCH^ORWDPS33(.RST,SCHVAL,"I") - . I RST=0 S ORY="This quick order contains a non-standard administration schedule." Q - Q -CHKSCH(ORY,SCH) ;Validate schedule - Q:SCH="" - D VALSCH^ORWDPS33(.ORY,SCH,"I") - Q +ORWNSS ;JDL/SLC Non-Standard Schedule ;12/9/04 12:02 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**195**;Dec 17, 1997 +NSSOK(ORY,ORX) ;Check availability for Non-standard schedule + N VAL + S VAL=$$PATCH^XPDUTL("PSJ*5.0*113") + S ORY=VAL + Q +NSSMSG(ORY) ;Retrieve site message for None-Standard Schedule + N ORSRV + S ORY="" + S ORSRV=$G(^VA(200,DUZ,5)) I +ORSRV>0 S ORSRV=$P(ORSRV,U) + S ORY=$$GET^XPAR("SRV.`"_+$G(ORSRV)_"^DIV^SYS","ORWIM NSS MESSAGE",1,"I") + Q +VALSCH(ORY,ORID) ;Validate a schedule for IM order; 1: valid, 0: invalid + ; + S ORY=0 + Q:'$D(^OR(100,+ORID,0)) + N IPGRP,ORGRP + S IPGRP=$O(^ORD(100.98,"B","UD RX",0)) + S ORGRP=$P($G(^OR(100,+ORID,0)),U,11) + I ORGRP'=IPGRP S ORY=1 Q + N SCH,IDX,SCHVAL S (SCH,SCHVAL)="" + I $D(^OR(100,+ORID,4.5,"ID","SCHEDULE")) S SCH=$O(^OR(100,+ORID,4.5,"ID","SCHEDULE",0)) + I SCH="" S ORY=1 Q + S IDX=0 F S IDX=$O(^OR(100,+ORID,4.5,SCH,IDX)) Q:'IDX D + . S SCHVAL=$G(^OR(100,+ORID,4.5,SCH,IDX)) + . Q:'$L(SCHVAL) + . D VALSCH^ORWDPS32(.ORY,SCHVAL,"I") + . I ORY=0 Q + Q +QOSCH(ORY,QOID) ;Validate IM QO schedule + ;QOID: Inpt Pharmacy QO + S ORY="" + N QOSCH,SCHID,SCHVAL,RST + S SCHID=$O(^ORD(101.41,"B","OR GTX SCHEDULE",0)) + S (QOSCH,SCHVAL)="",RST=1 + I '$D(^ORD(101.41,+QOID,6,"D",SCHID)) S ORY="schedule is not defined." Q + S QOSCH=$O(^ORD(101.41,+QOID,6,"D",SCHID,0)) + I 'QOSCH S ORY="schedule is not defined." Q + N IDX S IDX=0 + F S IDX=$O(^ORD(101.41,+QOID,6,QOSCH,IDX)) Q:'IDX!('RST) D + . S SCHVAL=^ORD(101.41,+QOID,6,QOSCH,IDX) + . I $$UP^XLFSTR(SCHVAL)="OTHER" S ORY="OTHER" Q + . D VALSCH^ORWDPS32(.RST,SCHVAL,"I") + . I RST=0 S ORY="This quick order contains a non-standard administration schedule." Q + Q +CHKSCH(ORY,SCH) ;Validate schedule + Q:SCH="" + D VALSCH^ORWDPS32(.ORY,SCH,"I") + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWOR.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWOR.m index 0a5c57d3..7c2e4cf7 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWOR.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWOR.m @@ -1,152 +1,152 @@ -ORWOR ; SLC/KCM - Orders Calls;10:54 PM 08/15/2006 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,132,141,163,187,190,215,243**;Dec 17, 1997;Build 242 - ; -CURRENT(LST,DFN) ; Get Current Orders for a Patient - ; Returns two lists in ^TMP("ORW",$J), fields and text - N TM,IEN,X,X0,X3,CTR,IDX,I - K ^TMP("ORW",$J) - S IDX=0,DFN=DFN_";DPT(" - S TM=0 F S TM=$O(^OR(100,"AC",DFN,TM)) Q:TM<1 D - . S IEN=0 F S IEN=$O(^OR(100,"AC",DFN,TM,IEN)) Q:IEN<1 D - . . S X0=^OR(100,IEN,0),X3=^(3) - . . S X=IEN_U_$P(X0,U,7)_U_$P(X0,U,11)_U_$P(X3,U,6)_U_$P(X3,U,3) - . . S ^TMP("ORW",$J,IDX+1)=X - . . S (CTR,I)=0,X="" - . . F S I=$O(^OR(100,IEN,1,I)) Q:I<1 D Q:CTR>244 - . . . S X=X_$E(^OR(100,IEN,1,I,0),1,(245-CTR)),CTR=$L(X) - . . S ^TMP("ORW",$J,IDX+2)=X,IDX=IDX+2 - ; S LST=$NA(^TMP("ORW",$J)) - M LST=^TMP("ORW",$J) - Q -DETAIL(LST,ORID,DFN) ; Return details of ORID (shell to kill VIDEO subs) - Q:'+ORID - I $G(DFN) N ORVP S ORVP=DFN_";DPT(" - S LST="^TMP(""ORTXT"",$J)" - D DETAIL^ORQ2(.LST,ORID) - K @LST@("VIDEO") - S LST=$NA(^TMP("ORTXT",$J)),@LST="" - Q -RESULT(REF,DFN,ORID,ID) ; Return results of order identified by ID - K ^TMP("ORXPND",$J) - N ORESULTS,ORVP,LCNT S ORESULTS=1,LCNT=0,ORVP=DFN_";DPT(" - D ORDERS^ORCXPND1 - K ^TMP("ORXPND",$J,"VIDEO") - S REF=$NA(^TMP("ORXPND",$J)) - Q -RESHIST(REF,DFN,ORID,ID) ; Return result history of associated tests identified by ID - K ^TMP("ORXPND",$J) - N ORESULTS,ORVP,LCNT - S ORESULTS=1,LCNT=0,ORVP=DFN_";DPT(" - D ORDHIST^ORWOR2 - K ^TMP("ORXPND",$J,"VIDEO") - S REF=$NA(^TMP("ORXPND",$J)) - Q -TSALL(LST) ; Return list of treating specialties - N Y S Y=0 - F S Y=$O(^DIC(45.7,Y)) Q:'Y I $$ACTIVE^DGACT(45.7,Y) S LST(Y)=Y_U_$P(^DIC(45.7,Y,0),U) - Q -DT(X) ; -- Returns FM date for X (SEE ORCHTAB1) - N Y,%DT S %DT="T",Y="" D:X'="" ^%DT - Q +Y -VWSET(ORERR,VIEW) ; Set the preferred view for orders - ; VIEW: semi-colon delimited record - ; 1 - Relative From Date/Time or "" - ; 2 - Relative Thru Date/Time or "" - ; 3 - Filter - ; 4 - Display Group Pointer - ; 5 - Format (preserve for list manager) - ; 6 - chronological display (R or F) - ; 7 - sort by display group - N FMT - ; use short name for display group instead of pointer - I $E($P(VIEW,";",2))="T" S $P(VIEW,";",2)=$P($P(VIEW,";",2),"@") ;allows all orders for Today - S $P(VIEW,";",4)=$P($G(^ORD(100.98,+$P(VIEW,";",4),0)),U,3) - ; use last saved format, since this is used only by LM - S FMT=$P($$GET^XPAR("ALL","ORCH CONTEXT ORDERS",1,"I"),";",5) - S:'$L(FMT) FMT="L" S $P(VIEW,";",5)=FMT - ; and save the parameter - D EN^XPAR(DUZ_";VA(200,","ORCH CONTEXT ORDERS",1,VIEW,.ORERR) - Q -VWGET(REC) ; Get the preferred view for orders - N FROM,THRU,FILTER,DGRP,FRMT,CHRN,BYGRP,S,VNAME,FL - S REC=$$GET^XPAR("ALL","ORCH CONTEXT ORDERS",1,"I"),S=";" - S FROM=$$DT($P(REC,S)),THRU=$$DT($P(REC,S,2)),FILTER=$P(REC,S,3) - S DGRP=$P(REC,S,4),FRMT=$P(REC,S,5),CHRN=$P(REC,S,6),BYGRP=$P(REC,S,7) - S:'$L(DGRP) DGRP="ALL" S DGRP=+$O(^ORD(100.98,"B",DGRP,0)) - I FILTER="" S FILTER=2 ; active orders - I CHRN="" S CHRN="R" ; reverse chronological - I BYGRP="" S BYGRP=1 ; sort by display group - ; set up view name - D REVSTS^ORWORDG(.FL) - S I=0 F S I=$O(FL(I)) Q:'I Q:+FL(I)=FILTER - S VNAME=$P($G(FL(+I)),U,2) - I '("^6^8^9^10^19^20^"[(U_FILTER_U)) S VNAME=VNAME_" Orders" - I FILTER=2 S VNAME="Active Orders (includes Pending & Recent Activity)" - I FILTER=23 S VNAME="Current Orders (Active & Pending Status Only)" - S VNAME=VNAME_" - "_$P($G(^ORD(100.98,DGRP,0)),U) - I (FROM>0)!(THRU>0) D - . S VNAME=VNAME_" ("_$$FMTE^XLFDT(FROM,"2D")_" thru " - . S VNAME=VNAME_$S(THRU>0:$$FMTE^XLFDT(THRU,"2D"),1:"")_")" - S REC=FROM_S_THRU_S_FILTER_S_DGRP_S_FRMT_S_CHRN_S_BYGRP_S_VNAME - Q -SHEETS(LST,ORVP) ; Return Order Sheets for a patient - N ELST,ETYP,ORIFN,TS,I - S ORVP=ORVP_";DPT(" - S ETYP="" F S ETYP=$O(^OR(100,"AEVNT",ORVP,ETYP)) Q:ETYP="" D - . S ORIFN=0 F S ORIFN=$O(^OR(100,"AEVNT",ORVP,ETYP,ORIFN)) Q:'ORIFN D - . . I (ETYP="A")!(ETYP="T") S ELST(ETYP,$P($G(^OR(100,+ORIFN,0)),U,13))="" - S LST(1)="C;O^Current View",I=1 - S TS="" F S TS=$O(ELST("A",TS)) Q:TS="" D - . S I=I+1,LST(I)="A;"_TS_U_"Admit to "_$P($G(^DIC(45.7,TS,0)),U) - S I=I+1,LST(I)="A;-1^Admit..." - S TS="" F S TS=$O(ELST("T",TS)) Q:TS="" D - . S I=I+1,LST(I)="T;"_TS_U_"Transfer to "_$P($G(^DIC(45.7,TS,0)),U) - I $L($G(^DPT(+ORVP,.1))) D - . S I=I+1,LST(I)="T;-1^Transfer..." - . S I=I+1,LST(I)="D;0^Discharge" - Q -EVENTS(LST,EVT) ; Return general delayed events categories for a patient - N EVTI - S EVTI=0 - S EVTI=EVTI+1,LST(EVTI)="A;-1^Admit..." - S EVTI=EVTI+1,LST(EVTI)="T;-1^Transfer..." - S EVTI=EVTI+1,LST(EVTI)="D;0^Discharge" - Q -UNSIGN(LST,ORVP,HAVE) ; Return Unsigned Orders that are not on client - N IFN,ACT,X8,ENT,LVL,TM,ILST S ILST=0 - Q:'$D(^XUSEC("ORES",DUZ)) - S ORVP=ORVP_";DPT(" - S ENT="ALL"_$S($G(^VA(200,DUZ,5)):"^SRV.`"_+^(5),1:"") - S LVL=$$GET^XPAR(ENT,"OR UNSIGNED ORDERS ON EXIT") - Q:'LVL - S TM=0 F S TM=$O(^OR(100,"AS",ORVP,TM)) Q:TM<1 D - . S IFN=0 F S IFN=$O(^OR(100,"AS",ORVP,TM,IFN)) Q:IFN<1 D - . . S ACT=0 F S ACT=$O(^OR(100,"AS",ORVP,TM,IFN,ACT)) Q:ACT<1 D - . . . Q:$D(HAVE(IFN_";"_ACT)) ;in Changes - . . . S X8=$G(^OR(100,IFN,8,ACT,0)) - . . . I '$S(LVL=1&($P(X8,U,3)=DUZ):1,LVL=2:1,1:0) Q ;chk user - . . . S ILST=ILST+1,LST(ILST)=IFN_";"_ACT_U_$P(X8,U,3) - Q -PKIUSE(RETURN) ; RPC determines user can use PKI Digital Signature - S RETURN=0 - I $$GET^XPAR("ALL^USR.`"_DUZ,"ORWOR PKI USE",1,"Q") S RETURN=1 - Q -PKISITE(RETURN) ; RPC determines if PKI is turned on at the site - S RETURN=0 - Q:'$L($T(STORESIG^XUSSPKI)) ;Check for Kernel piece - Q:'$L($T(DOSE^PSSOPKI1)) ;Check for Pharmacy piece - I $$GET^XPAR("ALL","ORWOR PKI SITE",1,"Q") S RETURN=1 - Q -ACTXT(ORY,ORIFN) ;Return detail action information - N ORI,CNT,OR0,OR3,OR6 - K ^TMP("ORACTXT",$J) - S ORY="^TMP(""ORACTXT"",$J)",ORI=$P(ORIFN,";",2) - S CNT=0,ORIFN=+ORIFN,OR0=$G(^OR(100,ORIFN,0)),OR3=$G(^(3)),OR6=$G(^(6)) - F S ORI=$O(^OR(100,+ORIFN,8,ORI)) Q:ORI'>0 S ACTION=$G(^(ORI,0)) D ACT^ORQ20 - S ORY=$NA(^TMP("ORACTXT",$J)),@ORY="" - Q -EXPIRED(ORY) ;return FM date/time to begin search for expired orders - N HRS - S HRS=$$GET^XPAR("ALL","ORWOR EXPIRED ORDERS",1,"I") - S ORY=$$FMADD^XLFDT($$NOW^XLFDT,"","-"_HRS,"","") - Q +ORWOR ; SLC/KCM - Orders Calls;10:54 PM 02 Feb 2003 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,132,141,163,187,190,215**;Dec 17, 1997 + ; +CURRENT(LST,DFN) ; Get Current Orders for a Patient + ; Returns two lists in ^TMP("ORW",$J), fields and text + N TM,IEN,X,X0,X3,CTR,IDX,I + K ^TMP("ORW",$J) + S IDX=0,DFN=DFN_";DPT(" + S TM=0 F S TM=$O(^OR(100,"AC",DFN,TM)) Q:TM<1 D + . S IEN=0 F S IEN=$O(^OR(100,"AC",DFN,TM,IEN)) Q:IEN<1 D + . . S X0=^OR(100,IEN,0),X3=^(3) + . . S X=IEN_U_$P(X0,U,7)_U_$P(X0,U,11)_U_$P(X3,U,6)_U_$P(X3,U,3) + . . S ^TMP("ORW",$J,IDX+1)=X + . . S (CTR,I)=0,X="" + . . F S I=$O(^OR(100,IEN,1,I)) Q:I<1 D Q:CTR>244 + . . . S X=X_$E(^OR(100,IEN,1,I,0),1,(245-CTR)),CTR=$L(X) + . . S ^TMP("ORW",$J,IDX+2)=X,IDX=IDX+2 + ; S LST=$NA(^TMP("ORW",$J)) + M LST=^TMP("ORW",$J) + Q +DETAIL(LST,ORID,DFN) ; Return details of ORID (shell to kill VIDEO subs) + Q:'+ORID + I $G(DFN) N ORVP S ORVP=DFN_";DPT(" + S LST="^TMP(""ORTXT"",$J)" + D DETAIL^ORQ2(.LST,ORID) + K @LST@("VIDEO") + S LST=$NA(^TMP("ORTXT",$J)),@LST="" + Q +RESULT(REF,DFN,ORID,ID) ; Return results of order identified by ID + K ^TMP("ORXPND",$J) + N ORESULTS,ORVP,LCNT S ORESULTS=1,LCNT=0,ORVP=DFN_";DPT(" + D ORDERS^ORCXPND1 + K ^TMP("ORXPND",$J,"VIDEO") + S REF=$NA(^TMP("ORXPND",$J)) + Q +RESHIST(REF,DFN,ORID,ID) ; Return result history of associated tests identified by ID + K ^TMP("ORXPND",$J) + N ORESULTS,ORVP,LCNT + S ORESULTS=1,LCNT=0,ORVP=DFN_";DPT(" + D ORDHIST^ORWOR2 + K ^TMP("ORXPND",$J,"VIDEO") + S REF=$NA(^TMP("ORXPND",$J)) + Q +TSALL(LST) ; Return list of treating specialties + N Y S Y=0 + F S Y=$O(^DIC(45.7,Y)) Q:'Y I $$ACTIVE^DGACT(45.7,Y) S LST(Y)=Y_U_$P(^DIC(45.7,Y,0),U) + Q +DT(X) ; -- Returns FM date for X (SEE ORCHTAB1) + N Y,%DT S %DT="T",Y="" D:X'="" ^%DT + Q +Y +VWSET(ORERR,VIEW) ; Set the preferred view for orders + ; VIEW: semi-colon delimited record + ; 1 - Relative From Date/Time or "" + ; 2 - Relative Thru Date/Time or "" + ; 3 - Filter + ; 4 - Display Group Pointer + ; 5 - Format (preserve for list manager) + ; 6 - chronological display (R or F) + ; 7 - sort by display group + N FMT + ; use short name for display group instead of pointer + I $E($P(VIEW,";",2))="T" S $P(VIEW,";",2)=$P($P(VIEW,";",2),"@") ;allows all orders for Today + S $P(VIEW,";",4)=$P($G(^ORD(100.98,+$P(VIEW,";",4),0)),U,3) + ; use last saved format, since this is used only by LM + S FMT=$P($$GET^XPAR("ALL","ORCH CONTEXT ORDERS",1,"I"),";",5) + S:'$L(FMT) FMT="L" S $P(VIEW,";",5)=FMT + ; and save the parameter + D EN^XPAR(DUZ_";VA(200,","ORCH CONTEXT ORDERS",1,VIEW,.ORERR) + Q +VWGET(REC) ; Get the preferred view for orders + N FROM,THRU,FILTER,DGRP,FRMT,CHRN,BYGRP,S,VNAME,FL + S REC=$$GET^XPAR("ALL","ORCH CONTEXT ORDERS",1,"I"),S=";" + S FROM=$$DT($P(REC,S)),THRU=$$DT($P(REC,S,2)),FILTER=$P(REC,S,3) + S DGRP=$P(REC,S,4),FRMT=$P(REC,S,5),CHRN=$P(REC,S,6),BYGRP=$P(REC,S,7) + S:'$L(DGRP) DGRP="ALL" S DGRP=+$O(^ORD(100.98,"B",DGRP,0)) + I FILTER="" S FILTER=2 ; active orders + I CHRN="" S CHRN="R" ; reverse chronological + I BYGRP="" S BYGRP=1 ; sort by display group + ; set up view name + D REVSTS^ORWORDG(.FL) + S I=0 F S I=$O(FL(I)) Q:'I Q:+FL(I)=FILTER + S VNAME=$P($G(FL(+I)),U,2) + I '("^6^8^9^10^19^20^"[(U_FILTER_U)) S VNAME=VNAME_" Orders" + I FILTER=2 S VNAME="Active Orders (includes Pending & Recent Activity)" + I FILTER=23 S VNAME="Current Orders (Active & Pending Status Only)" + S VNAME=VNAME_" - "_$P($G(^ORD(100.98,DGRP,0)),U) + I (FROM>0)!(THRU>0) D + . S VNAME=VNAME_" ("_$$FMTE^XLFDT(FROM,"2D")_" thru " + . S VNAME=VNAME_$S(THRU>0:$$FMTE^XLFDT(THRU,"2D"),1:"")_")" + S REC=FROM_S_THRU_S_FILTER_S_DGRP_S_FRMT_S_CHRN_S_BYGRP_S_VNAME + Q +SHEETS(LST,ORVP) ; Return Order Sheets for a patient + N ELST,ETYP,ORIFN,TS,I + S ORVP=ORVP_";DPT(" + S ETYP="" F S ETYP=$O(^OR(100,"AEVNT",ORVP,ETYP)) Q:ETYP="" D + . S ORIFN=0 F S ORIFN=$O(^OR(100,"AEVNT",ORVP,ETYP,ORIFN)) Q:'ORIFN D + . . I (ETYP="A")!(ETYP="T") S ELST(ETYP,$P($G(^OR(100,+ORIFN,0)),U,13))="" + S LST(1)="C;O^Current View",I=1 + S TS="" F S TS=$O(ELST("A",TS)) Q:TS="" D + . S I=I+1,LST(I)="A;"_TS_U_"Admit to "_$P($G(^DIC(45.7,TS,0)),U) + S I=I+1,LST(I)="A;-1^Admit..." + S TS="" F S TS=$O(ELST("T",TS)) Q:TS="" D + . S I=I+1,LST(I)="T;"_TS_U_"Transfer to "_$P($G(^DIC(45.7,TS,0)),U) + I $L($G(^DPT(+ORVP,.1))) D + . S I=I+1,LST(I)="T;-1^Transfer..." + . S I=I+1,LST(I)="D;0^Discharge" + Q +EVENTS(LST,EVT) ; Return general delayed events categories for a patient + N EVTI + S EVTI=0 + S EVTI=EVTI+1,LST(EVTI)="A;-1^Admit..." + S EVTI=EVTI+1,LST(EVTI)="T;-1^Transfer..." + S EVTI=EVTI+1,LST(EVTI)="D;0^Discharge" + Q +UNSIGN(LST,ORVP,HAVE) ; Return Unsigned Orders that are not on client + N IFN,ACT,X8,ENT,LVL,TM,ILST S ILST=0 + Q:'$D(^XUSEC("ORES",DUZ)) + S ORVP=ORVP_";DPT(" + S ENT="ALL"_$S($G(^VA(200,DUZ,5)):"^SRV.`"_+^(5),1:"") + S LVL=$$GET^XPAR(ENT,"OR UNSIGNED ORDERS ON EXIT") + Q:'LVL + S TM=0 F S TM=$O(^OR(100,"AS",ORVP,TM)) Q:TM<1 D + . S IFN=0 F S IFN=$O(^OR(100,"AS",ORVP,TM,IFN)) Q:IFN<1 D + . . S ACT=0 F S ACT=$O(^OR(100,"AS",ORVP,TM,IFN,ACT)) Q:ACT<1 D + . . . Q:$D(HAVE(IFN_";"_ACT)) ;in Changes + . . . S X8=$G(^OR(100,IFN,8,ACT,0)) + . . . I '$S(LVL=1&($P(X8,U,3)=DUZ):1,LVL=2:1,1:0) Q ;chk user + . . . S ILST=ILST+1,LST(ILST)=IFN_";"_ACT + Q +PKIUSE(RETURN) ; RPC determines user can use PKI Digital Signature + S RETURN=0 + I $$GET^XPAR("ALL^USR.`"_DUZ,"ORWOR PKI USE",1,"Q") S RETURN=1 + Q +PKISITE(RETURN) ; RPC determines if PKI is turned on at the site + S RETURN=0 + Q:'$L($T(STORESIG^XUSSPKI)) ;Check for Kernel piece + Q:'$L($T(DOSE^PSSOPKI1)) ;Check for Pharmacy piece + I $$GET^XPAR("ALL","ORWOR PKI SITE",1,"Q") S RETURN=1 + Q +ACTXT(ORY,ORIFN) ;Return detail action information + N ORI,CNT,OR0,OR3,OR6 + K ^TMP("ORACTXT",$J) + S ORY="^TMP(""ORACTXT"",$J)",ORI=$P(ORIFN,";",2) + S CNT=0,ORIFN=+ORIFN,OR0=$G(^OR(100,ORIFN,0)),OR3=$G(^(3)),OR6=$G(^(6)) + F S ORI=$O(^OR(100,+ORIFN,8,ORI)) Q:ORI'>0 S ACTION=$G(^(ORI,0)) D ACT^ORQ20 + S ORY=$NA(^TMP("ORACTXT",$J)),@ORY="" + Q +EXPIRED(ORY) ;return FM date/time to begin search for expired orders + N HRS + S HRS=$$GET^XPAR("ALL","ORWOR EXPIRED ORDERS",1,"I") + S ORY=$$FMADD^XLFDT($$NOW^XLFDT,"","-"_HRS,"","") + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWORB.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWORB.m index 3c631686..e1439c1d 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWORB.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWORB.m @@ -1,201 +1,201 @@ -ORWORB ; slc/dee/REV/CLA - RPC functions which return user alert ;10:12 am JAN 31, 2001 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,148,173,190,215,243**;Dec 17, 1997;Build 242 - ; -URGENLST(ORY) ;return array of the urgency for the notification - N ORSRV,ORERROR - S ORSRV=$G(^VA(200,DUZ,5)) I +ORSRV>0 S ORSRV=$P(ORSRV,U) - D GETLST^XPAR(.ORY,"USR^SRV.`"_$G(ORSRV)_"^DIV^SYS^PKG","ORB URGENCY","I",.ORERROR) - Q - ; -FASTUSER(ORY) ;return current user's notifications across all patients - N STRTDATE,STOPDATE,ORTOT,I,ORURG,URG,ORN,SORT,ORN0,URGLIST,REMLIST,REM,NONORLST,NONOR - N ALRT,ALRTDT,ALRTPT,ALRTMSG,ALRTI,ALRTLOC,ALRTXQA,J,FWDBY,PRE,ALRTDFN - K ^TMP("ORBG",$J) - S STRTDATE="",STOPDATE="",FWDBY="Forwarded by: " - D GETUSER1^XQALDATA("^TMP(""ORB"",$J)",DUZ,STRTDATE,STOPDATE) - S ORTOT=^TMP("ORB",$J) - D URGLIST^ORQORB(.URGLIST) - D REMLIST^ORQORB(.REMLIST) - D REMNONOR^ORQORB(.NONORLST) - S J=0 - F I=1:1:ORTOT D - .S ALRTDFN="" - .S ALRT=^TMP("ORB",$J,I) - .S PRE=$E(ALRT,1,1) - .S ALRTXQA=$P(ALRT,U,2) ;XQAID - .S NONOR="" F S NONOR=$O(NONORLST(NONOR)) Q:NONOR="" D - ..I ALRTXQA[NONOR S REM=1 ;allow this type of alert to be Removed - .S ALRTMSG=$P($P(ALRT,U),PRE_" ",2) - .I $E(ALRT,4,8)'="-----" D ;not forwarded alert info/comment - ..S ORURG="n/a" - ..S ALRTI=$P(ALRT," ") - ..S ALRTPT="" - ..S ALRTLOC="" - ..I $E($P(ALRTXQA,";"),1,3)="TIU" S ORURG="Moderate" - ..I $P(ALRTXQA,",")="OR" D - ...S ORN=$P($P(ALRTXQA,";"),",",3) - ...S URG=$G(URGLIST(ORN)) - ...S ORURG=$S(URG=1:"HIGH",URG=2:"Moderate",1:"low") - ...S REM=$G(REMLIST(ORN)) - ...S ORN0=^ORD(100.9,ORN,0) - ...S ALRTI=$S($P(ORN0,U,6)="INFODEL":"I",1:"") - ...S ALRTDFN=$P(ALRTXQA,",",2) - ...S ALRTLOC=$G(^DPT(+$G(ALRTDFN),.1)) - ..S ALRTI=$S(ALRTI="I":"I",1:"") - ..I ALRT["): " D - ...S ALRTPT=$P(ALRT,": ") - ...S ALRTPT=$E(ALRTPT,4,$L(ALRTPT)) - ...S ALRTMSG=$P($P(ALRT,U),"): ",2) - ...I $E(ALRTMSG,1,1)="[" D - ....S:'$L(ALRTLOC) ALRTLOC=$P($P(ALRTMSG,"]"),"[",2) - ....S ALRTMSG=$P(ALRTMSG,"] ",2) - ..I '$L($G(ALRTPT)) S ALRTPT="no patient" - ..S ALRTDT=$P(ALRTXQA,";",3) - ..S ALRTDT=$P(ALRTDT,".")_"."_$E($P(ALRTDT,".",2)_"0000",1,4) - ..S ALRTDT=$E(ALRTDT,4,5)_"/"_$E(ALRTDT,6,7)_"/"_($E(ALRTDT,1,3)+1700)_"@"_$E($P(ALRTDT,".",2),1,2)_":"_$E($P(ALRTDT,".",2),3,4) - ..;S ALRTDT=($E(ALRTDT,1,3)+1700)_"/"_$E(ALRTDT,4,5)_"/"_$E(ALRTDT,6,7)_"@"_$E($P(ALRTDT,".",2),1,2)_":"_$E($P(ALRTDT,".",2),3,4) - ..S J=J+1,^TMP("ORBG",$J,J)=ALRTI_U_ALRTPT_U_ALRTLOC_U_ORURG_U_ALRTDT_U - ..S ^TMP("ORBG",$J,J)=^TMP("ORBG",$J,J)_ALRTMSG_U_U_ALRTXQA_U_$G(REM)_U - .; - .;if alert forward info/comment: - .I $E(ALRTMSG,1,5)="-----" D - ..S ALRTMSG=$P(ALRTMSG,"-----",2) - ..I $E(ALRTMSG,1,14)=FWDBY D - ...S J=J+1,^TMP("ORBG",$J,J)=FWDBY_U_$P($P(ALRTMSG,FWDBY,2),"Generated: ")_$P($P(ALRTMSG,FWDBY,2),"Generated: ",2) - ..E S ^TMP("ORBG",$J,J)=^TMP("ORBG",$J,J)_U_""""_ALRTMSG_"""" - S ^TMP("ORBG",$J)="" - S ORY=$NA(^TMP("ORBG",$J)) - Q - ; -GETDATA(ORY,XQAID) ; return XQADATA for an alert - N SHOWADD - S ORY="" - Q:$G(XQAID)=""!('$D(^XTV(8992,"AXQA",XQAID))) - D GETACT^XQALERT(XQAID) - S ORY=XQADATA - I ($E(XQAID,1,3)="TIU"),(+ORY>0) D - . S SHOWADD=1 - . S ORY=ORY_$$RESOLVE^TIUSRVLO(+ORY) - K XQAID,XQADATA,XQAOPT,XQAROU - Q - ; -KILUNSNO(Y,ORVP) ; Delete unsigned order alerts if no unsigned orders remaining - S ORVP=ORVP_";DPT(" - D UNOTIF^ORCSIGN - Q - ; -UNFLORD(ORY,DFN,XQAID) ; -- auto-unflag orders?/delete alert - Q:'$L(DFN)!('$L(XQAID)) - N ORI,ORIFN,ORA,XQAKILL,ORN,ORBY,ORAUTO,ORUNF - S ORN=+$O(^ORD(100.9,"B","FLAGGED ORDERS",0)) - S XQAKILL=$$XQAKILL^ORB3F1(ORN) - D LIST^ORQOR1(.ORBY,DFN,"ALL",12,"","") - S ORAUTO=+$$GET^XPAR("ALL","ORPF AUTO UNFLAG") - S ORI=0 F S ORI=$O(ORBY(ORI)) Q:ORI'>0 D - . I ORAUTO D ; unflag - . . S ORUNF=+$E($$NOW^XLFDT,1,12)_U_DUZ_"^Auto-Unflagged" - . . S ORIFN=$P(ORBY(ORI),U),ORA=+$P(ORIFN,";",2) - . . I ORIFN,$D(^OR(100,+ORIFN,0)) S $P(^(8,ORA,3),U)=0,$P(^(3),U,6,8)=ORUNF D MSG^ORCFLAG(ORIFN) ; unflag - I ORAUTO!(+$G(ORBY(1))=0) D DELETE^XQALERT - Q -KILEXMED(Y,ORDFN) ; -- Delete expiring meds notification if no expiring meds remaining - N ORDG,ORLST S ORDG=$$DG^ORQOR1("RX") - D AGET^ORWORR(.ORLST,ORDFN,5,ORDG) - Q:+(@ORLST@(.1)) ;more left - N XQAKILL,ORNIFN,ORVP,ORIO S OROI="" - F OROI="INPT","OUTPT" D - .S ORNIFN=$O(^ORD(100.9,"B","MEDICATIONS EXPIRING - "_OROI,0)),ORVP=ORDFN_";DPT(" - .Q:'$L($G(ORNIFN)) - .S XQAKILL=$$XQAKILL^ORB3F1(ORNIFN) ; expiring meds notif - .I $D(XQAID) D DELETE^XQALERT - .I '$D(XQAID) S XQAID=$P($G(^ORD(100.9,ORNIFN,0)),U,2)_","_+ORVP_","_ORNIFN D DELETEA^XQALERT K XQAID - Q -KILEXOI(Y,ORDFN,ORNIFN) ; -- Delete expiring flagged OI notification if no flagged expiring OI remaining - N ORDG,ORLST S ORDG=$$DG^ORQOR1("ALL") - D AGET^ORWORR(.ORLST,ORDFN,5,ORDG) - Q:+(@ORLST@(.1)) ;more left - N XQAKILL,ORVP - S ORVP=ORDFN_";DPT(" - S XQAKILL=$$XQAKILL^ORB3F1(ORNIFN) ; flagged expiring OI notifications - I $D(XQAID) D DELETE^XQALERT - I '$D(XQAID) S XQAID=$P($G(^ORD(100.9,ORNIFN,0)),U,2)_","_+ORVP_","_ORNIFN D DELETEA^XQALERT K XQAID - Q -KILUNVOR(Y,ORDFN) ; -- Delete UNVERIFIED ORDER notification if none remaining within current admission/30 days - N DFN,ORDG,ORLST,ORBDT,OREDT,ORDDT S ORDG=$$DG^ORQOR1("ALL") - S OREDT=$$NOW^XLFDT - S ORDDT=$$FMADD^XLFDT(OREDT,"-90") - ;get current admission date/time: - S DFN=ORDFN,VA200="" D INP^VADPT - S ORBDT=$P($G(VAIN(7)),U) - S ORBDT=$S('$L($G(ORBDT)):$$FMADD^XLFDT(OREDT,"-30"),1:ORBDT) ;<= if no admission use past 30 days - S ORBDT=$S(ORDDT>ORBDT:ORDDT,1:ORBDT) ;max past days to use is 90 days - D AGET^ORWORR(.ORLST,ORDFN,9,ORDG,ORBDT,OREDT) - Q:+(@ORLST@(.1)) ;more left - N XQAKILL,ORVP,ORNIFN - S ORNIFN=$O(^ORD(100.9,"B","UNVERIFIED ORDER",0)),ORVP=ORDFN_";DPT(" - S XQAKILL=$$XQAKILL^ORB3F1(ORNIFN) - I $D(XQAID) D DELETE^XQALERT - I '$D(XQAID) S XQAID=$P($G(^ORD(100.9,ORNIFN,0)),U,2)_","_+ORVP_","_ORNIFN D DELETEA^XQALERT K XQAID - Q -KILUNVMD(Y,ORDFN) ; -- Delete UNVERIFIED MEDS notification if none remaining within current admission/30 days - N DFN,ORDG,ORLST,ORBDT,OREDT,ORDDT S ORDG=$$DG^ORQOR1("RX") - S OREDT=$$NOW^XLFDT - S ORDDT=$$FMADD^XLFDT(OREDT,"-90") - ;get current admission date/time: - S DFN=ORDFN,VA200="" D INP^VADPT - S ORBDT=$P($G(VAIN(7)),U) - S ORBDT=$S('$L($G(ORBDT)):$$FMADD^XLFDT(OREDT,"-30"),1:ORBDT) ;<= if no admission use past 30 days - S ORBDT=$S(ORDDT>ORBDT:ORDDT,1:ORBDT) ;max past days to use is 90 days - D AGET^ORWORR(.ORLST,ORDFN,9,ORDG,ORBDT,OREDT) - Q:+(@ORLST@(.1)) ;more left - N XQAKILL,ORVP,ORNIFN - S ORNIFN=$O(^ORD(100.9,"B","UNVERIFIED MEDICATION ORDER",0)),ORVP=ORDFN_";DPT(" - S XQAKILL=$$XQAKILL^ORB3F1(ORNIFN) - I $D(XQAID) D DELETE^XQALERT - I '$D(XQAID) S XQAID=$P($G(^ORD(100.9,ORNIFN,0)),U,2)_","_+ORVP_","_ORNIFN D DELETEA^XQALERT K XQAID - Q -ESORD(ORY,XQAID) ;order(s) requiring electronic signature follow-up - K XQAKILL - N ORPT,ORDG,ORBXQAID,ORY,ORX,ORZ,ORDERS,ORDNUM,ORQUIT,ORBLMDEL - S ORBXQAID=XQAID,ORDERS=0,ORQUIT=0 - S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid - S ORDG=$$DG^ORQOR1("ALL") - ;the FLG code for UNSIGNED orders in ORQ1 is '11' - ;get unsigned orders - if none exist, delete alert then quit: - D EN^ORQ1(ORPT_";DPT(",ORDG,11,"","","",0,0) - S ORX="",ORX=$O(^TMP("ORR",$J,ORX)) Q:ORX="" I +$G(^TMP("ORR",$J,ORX,"TOT"))<1 D DEL^ORB3FUP1(.ORY,ORBXQAID) K ^TMP("ORR",$J) Q - ; - ;user does not have ORES key, delete user's alert: - I '$D(^XUSEC("ORES",DUZ)) S XQAKILL=1 D DEL^ORB3FUP1(.ORY,ORBXQAID) K ^TMP("ORR",$J) Q - ; - ;if prov is NOT linked to pt via attending, primary or teams: - I $$PPLINK^ORQPTQ1(DUZ,ORPT)=0 D - .S ORX="" F S ORX=$O(^TMP("ORR",$J,ORX)) Q:ORX=""!(ORDERS=1) D - ..S ORZ="" F S ORZ=$O(^TMP("ORR",$J,ORX,ORZ)) Q:+ORZ=0!(ORDERS=1) D - ...S ORDNUM=^TMP("ORR",$J,ORX,ORZ) - ...;quit if this unsigned order's last action was made by the user - ...I DUZ=+$$UNSIGNOR^ORQOR2(ORDNUM) S ORDERS=1 - .I ORDERS'=1 D ;provider has no outstanding unsigned orders for pt - ..S XQAKILL=1 D DEL^ORB3FUP1(.ORY,ORBXQAID) ;delete alert for this user - K ^TMP("ORR",$J) - Q - ; -TXTFUP(ROOT,DFN,NOTIF,XQADATA) ; Follow-up for text messages - ; - I NOTIF=67 D CHGRAD - Q - ; -CHGRAD ;GUI follow-up for Imaging Request Changed (#67) - S ROOT=$NA(^TMP($J,"RAE4")) - K @ROOT - D SET1^RAO7PC4 ;DBIA #3563 - Q - ; -GETSORT(ORY) ;return notification sort method^direction for user/division/system/pkg - S ORY=$$GET^XPAR("ALL","ORB SORT METHOD",1,"I")_U_$$GET^XPAR("ALL","ORB SORT DIRECTION",1,"I") - Q - ; -SETSORT(ORERR,SORT,DIR) ;set notification sort method^direction for user - D EN^XPAR(DUZ_";VA(200,","ORB SORT METHOD",1,SORT,.ORERR) - I $L($G(DIR)) D EN^XPAR(DUZ_";VA(200,","ORB SORT DIRECTION",1,DIR,.ORERR) - Q +ORWORB ; slc/dee/REV/CLA - RPC functions which return user alert ;10:12 am JAN 31, 2001 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,148,173,190,215**;Dec 17, 1997 + ; +URGENLST(ORY) ;return array of the urgency for the notification + N ORSRV,ORERROR + S ORSRV=$G(^VA(200,DUZ,5)) I +ORSRV>0 S ORSRV=$P(ORSRV,U) + D GETLST^XPAR(.ORY,"USR^SRV.`"_$G(ORSRV)_"^DIV^SYS^PKG","ORB URGENCY","I",.ORERROR) + Q + ; +FASTUSER(ORY) ;return current user's notifications across all patients + N STRTDATE,STOPDATE,ORTOT,I,ORURG,URG,ORN,SORT,ORN0,URGLIST,REMLIST,REM,NONORLST,NONOR + N ALRT,ALRTDT,ALRTPT,ALRTMSG,ALRTI,ALRTLOC,ALRTXQA,J,FWDBY,PRE,ALRTDFN + K ^TMP("ORBG",$J) + S STRTDATE="",STOPDATE="",FWDBY="Forwarded by: " + D GETUSER1^XQALDATA("^TMP(""ORB"",$J)",DUZ,STRTDATE,STOPDATE) + S ORTOT=^TMP("ORB",$J) + D URGLIST^ORQORB(.URGLIST) + D REMLIST^ORQORB(.REMLIST) + D REMNONOR^ORQORB(.NONORLST) + S J=0 + F I=1:1:ORTOT D + .S ALRTDFN="" + .S ALRT=^TMP("ORB",$J,I) + .S PRE=$E(ALRT,1,1) + .S ALRTXQA=$P(ALRT,U,2) ;XQAID + .S NONOR="" F S NONOR=$O(NONORLST(NONOR)) Q:NONOR="" D + ..I ALRTXQA[NONOR S REM=1 ;allow this type of alert to be Removed + .S ALRTMSG=$P($P(ALRT,U),PRE_" ",2) + .I $E(ALRT,4,8)'="-----" D ;not forwarded alert info/comment + ..S ORURG="n/a" + ..S ALRTI=$P(ALRT," ") + ..S ALRTPT="" + ..S ALRTLOC="" + ..I $E($P(ALRTXQA,";"),1,3)="TIU" S ORURG="Moderate" + ..I $P(ALRTXQA,",")="OR" D + ...S ORN=$P($P(ALRTXQA,";"),",",3) + ...S URG=$G(URGLIST(ORN)) + ...S ORURG=$S(URG=1:"HIGH",URG=2:"Moderate",1:"low") + ...S REM=$G(REMLIST(ORN)) + ...S ORN0=^ORD(100.9,ORN,0) + ...S ALRTI=$S($P(ORN0,U,6)="INFODEL":"I",1:"") + ...S ALRTDFN=$P(ALRTXQA,",",2) + ...S ALRTLOC=$G(^DPT(+$G(ALRTDFN),.1)) + ..S ALRTI=$S(ALRTI="I":"I",1:"") + ..I ALRT["): " D + ...S ALRTPT=$P(ALRT,": ") + ...S ALRTPT=$E(ALRTPT,4,$L(ALRTPT)) + ...S ALRTMSG=$P($P(ALRT,U),"): ",2) + ...I $E(ALRTMSG,1,1)="[" D + ....S:'$L(ALRTLOC) ALRTLOC=$P($P(ALRTMSG,"]"),"[",2) + ....S ALRTMSG=$P(ALRTMSG,"] ",2) + ..I '$L($G(ALRTPT)) S ALRTPT="no patient" + ..S ALRTDT=$P(ALRTXQA,";",3) + ..S ALRTDT=$P(ALRTDT,".")_"."_$E($P(ALRTDT,".",2)_"0000",1,4) + ..S ALRTDT=$E(ALRTDT,4,5)_"/"_$E(ALRTDT,6,7)_"/"_($E(ALRTDT,1,3)+1700)_"@"_$E($P(ALRTDT,".",2),1,2)_":"_$E($P(ALRTDT,".",2),3,4) + ..;S ALRTDT=($E(ALRTDT,1,3)+1700)_"/"_$E(ALRTDT,4,5)_"/"_$E(ALRTDT,6,7)_"@"_$E($P(ALRTDT,".",2),1,2)_":"_$E($P(ALRTDT,".",2),3,4) + ..S J=J+1,^TMP("ORBG",$J,J)=ALRTI_U_ALRTPT_U_ALRTLOC_U_ORURG_U_ALRTDT_U + ..S ^TMP("ORBG",$J,J)=^TMP("ORBG",$J,J)_ALRTMSG_U_U_ALRTXQA_U_$G(REM)_U + .; + .;if alert forward info/comment: + .I $E(ALRTMSG,1,5)="-----" D + ..S ALRTMSG=$P(ALRTMSG,"-----",2) + ..I $E(ALRTMSG,1,14)=FWDBY D + ...S J=J+1,^TMP("ORBG",$J,J)=FWDBY_U_$P($P(ALRTMSG,FWDBY,2),"Generated: ")_$P($P(ALRTMSG,FWDBY,2),"Generated: ",2) + ..E S ^TMP("ORBG",$J,J)=^TMP("ORBG",$J,J)_U_""""_ALRTMSG_"""" + S ^TMP("ORBG",$J)="" + S ORY=$NA(^TMP("ORBG",$J)) + Q + ; +GETDATA(ORY,XQAID) ; return XQADATA for an alert + N SHOWADD + S ORY="" + Q:$G(XQAID)=""!('$D(^XTV(8992,"AXQA",XQAID))) + D GETACT^XQALERT(XQAID) + S ORY=XQADATA + I ($E(XQAID,1,3)="TIU"),(+ORY>0) D + . S SHOWADD=1 + . S ORY=ORY_$$RESOLVE^TIUSRVLO(+ORY) + K XQAID,XQADATA,XQAOPT,XQAROU + Q + ; +KILUNSNO(Y,ORVP) ; Delete unsigned order alerts if no unsigned orders remaining + S ORVP=ORVP_";DPT(" + D UNOTIF^ORCSIGN + Q + ; +UNFLORD(Y,DFN,XQAID) ; -- auto-unflag orders?/delete alert + Q:'$L(DFN)!('$L(XQAID)) + N ORI,ORIFN,ORA,XQAKILL,ORN,ORBY,ORAUTO,ORUNF + S ORN=+$O(^ORD(100.9,"B","FLAGGED ORDERS",0)) + S XQAKILL=$$XQAKILL^ORB3F1(ORN) + D LIST^ORQOR1(.ORBY,DFN,"ALL",12,"","") + S ORAUTO=+$$GET^XPAR("ALL","ORPF AUTO UNFLAG") + S ORI=0 F S ORI=$O(ORBY(ORI)) Q:ORI'>0 D + . I ORAUTO D ; unflag + . . S ORUNF=+$E($$NOW^XLFDT,1,12)_U_DUZ_"^Auto-Unflagged" + . . S ORIFN=$P(ORBY(ORI),U),ORA=+$P(ORIFN,";",2) + . . I ORIFN,$D(^OR(100,+ORIFN,0)) S $P(^(8,ORA,3),U)=0,$P(^(3),U,6,8)=ORUNF ; unflag + I ORAUTO!(+$G(ORBY(1))=0) D DELETE^XQALERT + Q +KILEXMED(Y,ORDFN) ; -- Delete expiring meds notification if no expiring meds remaining + N ORDG,ORLST S ORDG=$$DG^ORQOR1("RX") + D AGET^ORWORR(.ORLST,ORDFN,5,ORDG) + Q:+(@ORLST@(.1)) ;more left + N XQAKILL,ORNIFN,ORVP,ORIO S OROI="" + F OROI="INPT","OUTPT" D + .S ORNIFN=$O(^ORD(100.9,"B","MEDICATIONS EXPIRING - "_OROI,0)),ORVP=ORDFN_";DPT(" + .Q:'$L($G(ORNIFN)) + .S XQAKILL=$$XQAKILL^ORB3F1(ORNIFN) ; expiring meds notif + .I $D(XQAID) D DELETE^XQALERT + .I '$D(XQAID) S XQAID=$P($G(^ORD(100.9,ORNIFN,0)),U,2)_","_+ORVP_","_ORNIFN D DELETEA^XQALERT K XQAID + Q +KILEXOI(Y,ORDFN,ORNIFN) ; -- Delete expiring flagged OI notification if no flagged expiring OI remaining + N ORDG,ORLST S ORDG=$$DG^ORQOR1("ALL") + D AGET^ORWORR(.ORLST,ORDFN,5,ORDG) + Q:+(@ORLST@(.1)) ;more left + N XQAKILL,ORVP + S ORVP=ORDFN_";DPT(" + S XQAKILL=$$XQAKILL^ORB3F1(ORNIFN) ; flagged expiring OI notifications + I $D(XQAID) D DELETE^XQALERT + I '$D(XQAID) S XQAID=$P($G(^ORD(100.9,ORNIFN,0)),U,2)_","_+ORVP_","_ORNIFN D DELETEA^XQALERT K XQAID + Q +KILUNVOR(Y,ORDFN) ; -- Delete UNVERIFIED ORDER notification if none remaining within current admission/30 days + N DFN,ORDG,ORLST,ORBDT,OREDT,ORDDT S ORDG=$$DG^ORQOR1("ALL") + S OREDT=$$NOW^XLFDT + S ORDDT=$$FMADD^XLFDT(OREDT,"-90") + ;get current admission date/time: + S DFN=ORDFN,VA200="" D INP^VADPT + S ORBDT=$P($G(VAIN(7)),U) + S ORBDT=$S('$L($G(ORBDT)):$$FMADD^XLFDT(OREDT,"-30"),1:ORBDT) ;<= if no admission use past 30 days + S ORBDT=$S(ORDDT>ORBDT:ORDDT,1:ORBDT) ;max past days to use is 90 days + D AGET^ORWORR(.ORLST,ORDFN,9,ORDG,ORBDT,OREDT) + Q:+(@ORLST@(.1)) ;more left + N XQAKILL,ORVP,ORNIFN + S ORNIFN=$O(^ORD(100.9,"B","UNVERIFIED ORDER",0)),ORVP=ORDFN_";DPT(" + S XQAKILL=$$XQAKILL^ORB3F1(ORNIFN) + I $D(XQAID) D DELETE^XQALERT + I '$D(XQAID) S XQAID=$P($G(^ORD(100.9,ORNIFN,0)),U,2)_","_+ORVP_","_ORNIFN D DELETEA^XQALERT K XQAID + Q +KILUNVMD(Y,ORDFN) ; -- Delete UNVERIFIED MEDS notification if none remaining within current admission/30 days + N DFN,ORDG,ORLST,ORBDT,OREDT,ORDDT S ORDG=$$DG^ORQOR1("RX") + S OREDT=$$NOW^XLFDT + S ORDDT=$$FMADD^XLFDT(OREDT,"-90") + ;get current admission date/time: + S DFN=ORDFN,VA200="" D INP^VADPT + S ORBDT=$P($G(VAIN(7)),U) + S ORBDT=$S('$L($G(ORBDT)):$$FMADD^XLFDT(OREDT,"-30"),1:ORBDT) ;<= if no admission use past 30 days + S ORBDT=$S(ORDDT>ORBDT:ORDDT,1:ORBDT) ;max past days to use is 90 days + D AGET^ORWORR(.ORLST,ORDFN,9,ORDG,ORBDT,OREDT) + Q:+(@ORLST@(.1)) ;more left + N XQAKILL,ORVP,ORNIFN + S ORNIFN=$O(^ORD(100.9,"B","UNVERIFIED MEDICATION ORDER",0)),ORVP=ORDFN_";DPT(" + S XQAKILL=$$XQAKILL^ORB3F1(ORNIFN) + I $D(XQAID) D DELETE^XQALERT + I '$D(XQAID) S XQAID=$P($G(^ORD(100.9,ORNIFN,0)),U,2)_","_+ORVP_","_ORNIFN D DELETEA^XQALERT K XQAID + Q +ESORD(ORY,XQAID) ;order(s) requiring electronic signature follow-up + K XQAKILL + N ORPT,ORDG,ORBXQAID,ORY,ORX,ORZ,ORDERS,ORDNUM,ORQUIT,ORBLMDEL + S ORBXQAID=XQAID,ORDERS=0,ORQUIT=0 + S ORPT=$P($P(XQAID,";"),",",2) ;get pt dfn from xqaid + S ORDG=$$DG^ORQOR1("ALL") + ;the FLG code for UNSIGNED orders in ORQ1 is '11' + ;get unsigned orders - if none exist, delete alert then quit: + D EN^ORQ1(ORPT_";DPT(",ORDG,11,"","","",0,0) + S ORX="",ORX=$O(^TMP("ORR",$J,ORX)) Q:ORX="" I +$G(^TMP("ORR",$J,ORX,"TOT"))<1 D DEL^ORB3FUP1(.ORY,ORBXQAID) K ^TMP("ORR",$J) Q + ; + ;user does not have ORES key, delete user's alert: + I '$D(^XUSEC("ORES",DUZ)) S XQAKILL=1 D DEL^ORB3FUP1(.ORY,ORBXQAID) K ^TMP("ORR",$J) Q + ; + ;if prov is NOT linked to pt via attending, primary or teams: + I $$PPLINK^ORQPTQ1(DUZ,ORPT)=0 D + .S ORX="" F S ORX=$O(^TMP("ORR",$J,ORX)) Q:ORX=""!(ORDERS=1) D + ..S ORZ="" F S ORZ=$O(^TMP("ORR",$J,ORX,ORZ)) Q:+ORZ=0!(ORDERS=1) D + ...S ORDNUM=^TMP("ORR",$J,ORX,ORZ) + ...;quit if this unsigned order's last action was made by the user + ...I DUZ=+$$UNSIGNOR^ORQOR2(ORDNUM) S ORDERS=1 + .I ORDERS'=1 D ;provider has no outstanding unsigned orders for pt + ..S XQAKILL=1 D DEL^ORB3FUP1(.ORY,ORBXQAID) ;delete alert for this user + K ^TMP("ORR",$J) + Q + ; +TXTFUP(ROOT,DFN,NOTIF,XQADATA) ; Follow-up for text messages + ; + I NOTIF=67 D CHGRAD + Q + ; +CHGRAD ;GUI follow-up for Imaging Request Changed (#67) + S ROOT=$NA(^TMP($J,"RAE4")) + K @ROOT + D SET1^RAO7PC4 ;DBIA #3563 + Q + ; +GETSORT(ORY) ;return notification sort method^direction for user/division/system/pkg + S ORY=$$GET^XPAR("ALL","ORB SORT METHOD",1,"I")_U_$$GET^XPAR("ALL","ORB SORT DIRECTION",1,"I") + Q + ; +SETSORT(ORERR,SORT,DIR) ;set notification sort method^direction for user + D EN^XPAR(DUZ_";VA(200,","ORB SORT METHOD",1,SORT,.ORERR) + I $L($G(DIR)) D EN^XPAR(DUZ_";VA(200,","ORB SORT DIRECTION",1,DIR,.ORERR) + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWORR.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWORR.m index 01e221a2..b604a3fe 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWORR.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWORR.m @@ -1,206 +1,205 @@ -ORWORR ; SLC/KCM/JLI - Retrieve Orders for Broker ;7/24/05 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,92,116,110,132,141,163,189,195,215,243**;Dec 17, 1997;Build 242 - ; -GET(LST,DFN,FILTER,GROUPS) ; procedure - Q ; don't call until using same treating specialty logic as AGET - ; & until MULT, ORWARD, & ORIGVIEW implemented - ; & until the date ranges implemented - ; Get orders for patient - ; 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 - ; .LST=~IFN^Grp^ActTm^StrtTm^StopTm^Sts^Sig^Nrs^Clk^PrvID^PrvNam^ActDA^Flag^DCType^ChrtRev^DEA#^^Schedule - ; .LST=tOrder Text (repeating as necessary) - ; DFN=Patient ID - ; FILTER=# indicates which orders to return, default=2 (current) - ; GROUPS=display grp of orders to show (default=ALL) - ; -- section uses ORQ1 to get orders list rather than XGET -- - N ORLIST,ORIFN,X0,X3,X8,IDX,IFN,ACT,PRV,LN,TXT,STRT,STOP,CSTS,EYE,DEA ;PKI - K ^TMP("ORR",$J) - S (IDX,LST)=0 S:'$D(GROUPS) GROUPS=1 S:'$D(FILTER) FILTER=2 - D EN^ORQ1(DFN_";DPT(",GROUPS,FILTER,"","","",0,1) - S EYE=0 F S EYE=$O(^TMP("ORR",$J,ORLIST,EYE)) Q:'EYE S IFN=^(EYE) D - . S ACT=$P(IFN,";",2),IFN=+IFN,X0=^OR(100,IFN,0),X3=^(3),X8=^(8,ACT,0) - . D GETFLDS - K ^TMP("ORR",$J) - G EXIT -AGET(REF,DFN,FILTER,GROUPS,DTFROM,DTTHRU,EVENT,ORRECIP) ;Get abbrev. event delayed order list for patient - ; returns ^TMP("ORR",$J,ORLIST,n)=IFN^DGrp^ActTm - ; see input parameters above - ; -- from ORWORR - ; -- section uses ORQ1 to get orders list rather than XGET -- - N ORLIST,ORIFN,IFN,I,ORWTS,TOT,MULT,ORWARD,TXTVW,ORYD,PTEVTID,EVTNAME - S (PTEVTID,EVTNAME)="" - K ^TMP("ORR",$J),^TMP("ORRJD",$J) - S:'$D(GROUPS) GROUPS=1 S:'$D(FILTER) FILTER=2 - S ORWTS=+$P(FILTER,U,2),FILTER=+FILTER - S MULT=$S("^1^6^8^9^10^11^13^14^20^22^"[(U_FILTER_U):1,1:0) - I $L($G(^DPT(DFN,.1))) S ORWARD=1 ; normally ptr to 42 - S:'$L($G(DTFROM)) DTFROM=0 - S:'$L($G(DTTHRU)) DTTHRU=0 - I $P(DTFROM,".")=$P(DTTHRU,"."),$P(DTFROM,".",2)>$P(DTTHRU,".",2),$P(DTTHRU,".",2)="" S $P(DTTHRU,".",2)=2359 - S:'$L($G(EVENT)) EVENT=0 - I $G(EVTDCREL)="TRUE" D - . D EN^ORQ1(DFN_";DPT(",GROUPS,FILTER,"",DTFROM,DTTHRU,2,MULT,"",1,EVENT) - . D GET2^ORWORR1 - E D - . D EN^ORQ1(DFN_";DPT(",GROUPS,FILTER,"",DTFROM,DTTHRU,0,MULT,"",1,EVENT) - . D GET1^ORWORR1 - Q -RGET(REF,DFN,FILTER,GROUPS,DTFROM,DTTHRU,EVENT) ;Orders of AutoDC/Release Event - N EVTDCREL - S EVTDCREL="TRUE" - D AGET(.REF,DFN,FILTER,GROUPS,DTFROM,DTTHRU,EVENT) - Q -XGET ; retrieval algorithm before all the AC xref changes - N X,X0,X3,IDX,IFN,LN,TIME,DGRP,MASK,TXT,ACT,PRV,ID,DEA,PASS ;PKI - S DFN=DFN_";DPT(",IDX=0,LST=0 - I '$G(FILTER) S FILTER=2 ; Default: Current/Active - I $D(GROUPS)=1 D - . S:'GROUPS GROUPS=$O(^ORD(100.98,"B",GROUPS,0)) - . D XPND(GROUPS) - I FILTER=1 D DOALL G EXIT ; All - I FILTER=2 D DOCUR G EXIT ; Current - I FILTER=3 S PASS=";1;" ; Discontinued - I FILTER=4 S PASS=";2;7;" ; Comp/Expired - I FILTER=5 S PASS=";3;4;5;6;8;9;" ; Expiring - I FILTER=6 S PASS=";1;2;3;4;5;6;7;8;9;11;" ; New Activity - I FILTER=7 S PASS=";5;" ; Pending - I FILTER=8 Q ; Expanded - I FILTER=9 S PASS=";3;4;5;6;8;9;11;" ; Unverified by Nurse - I FILTER=10 S PASS=";3;4;5;6;8;9;11;" ; Unverified by Clerk - I FILTER=11 S PASS=";3;4;5;6;7;8;11;" ; Unsigned - I FILTER=12 S PASS=";4;" ; Flagged - I FILTER=13 S PASS="" ; Verbal/Phone - I FILTER=14 S PASS="" ; Verbal/Phone Unsigned - D DOGET -EXIT I LST=0 D - . N %,X,%I D NOW^%DTC - . S LST(1)="~0^0^"_%_"^^^97",LST(2)="tNo Orders Found." - Q -DOGET ; Here to filter orders - S TIME=0 F S TIME=$O(^OR(100,"AO",DFN,TIME)) Q:'TIME D - . S DGRP=0 F S DGRP=$O(^OR(100,"AO",DFN,TIME,DGRP)) Q:'DGRP D - . . I $D(GROUPS)>1 Q:'$D(GROUPS(DGRP)) ;filter by display grp - . . S IFN=0 F S IFN=$O(^OR(100,"AO",DFN,TIME,DGRP,IFN)) Q:'IFN D - . . . S X0=^OR(100,IFN,0),X3=^(3) ;get main nodes - . . . I $P(X3,U,8)!$P(X3,U,9)!($P(X3,U,3)=99) Q ;skip veil,chld,sts=99 - . . . I $L(PASS),(PASS'[(";"_$P(X3,U,3)_";")) Q ;filter by status - . . . ; any other filtering - . . . D GETFLDS - Q -DOALL ; Here to get all orders (no filter by status) - S TIME=0 F S TIME=$O(^OR(100,"AO",DFN,TIME)) Q:'TIME D - . S DGRP=0 F S DGRP=$O(^OR(100,"AO",DFN,TIME,DGRP)) Q:'DGRP D - . . I $D(GROUPS)>1 Q:'$D(GROUPS(DGRP)) ;filter by display grp - . . S IFN=0 F S IFN=$O(^OR(100,"AO",DFN,TIME,DGRP,IFN)) Q:'IFN D - . . . S X0=^OR(100,IFN,0),X3=^(3) ;get main nodes - . . . I $P(X3,U,8)!$P(X3,U,9)!($P(X3,U,3)=99) Q ;skip veil,chld,sts=99 - . . . D GETFLDS - Q -DOCUR ; Here to get all current orders - N AOCTXT,STS,STOP,% - S X=-$$GET^XPAR("ALL","ORPF ACTIVE ORDERS CONTEXT HRS") - S %H=$H,X=(%H*86400+$P(%H,",",2))+(X*3600),%H=(X\86400)_","_(X#86400) - D YMD^%DTC S AOCTXT=X_% - S MASK="110000100101110" ; mask out STS=1,2,7,10,12,13,14 - S TIME=0 F S TIME=$O(^OR(100,"AC",DFN,TIME)) Q:'TIME D - . S IFN=0 F S IFN=$O(^OR(100,"AC",DFN,TIME,IFN)) Q:'IFN D - . . ; filter out display groups here - . . S ACT=0 F S ACT=$O(^OR(100,"AC",DFN,TIME,IFN,ACT)) Q:'ACT D - . . . S X0=^OR(100,IFN,0),X3=^(3),X8=^(8,ACT,0) - . . . S STS=$P(X3,U,3),STOP=$P(X0,U,9) - . . . I $P(X3,U,8)!$P(X3,U,9)!(STS=99) Q - . . . I $P(X8,U,15)=13,($P(X8,U)0 Y=$P(^DIC(9.4,PKGID,0),U,2) - Q +ORWORR ; SLC/KCM/JLI - Retrieve Orders for Broker ;7/24/05 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,92,116,110,132,141,163,189,195,215**;Dec 17, 1997 + ; +GET(LST,DFN,FILTER,GROUPS) ; procedure + Q ; don't call until using same treating specialty logic as AGET + ; & until MULT, ORWARD, & ORIGVIEW implemented + ; & until the date ranges implemented + ; Get orders for patient + ; 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 + ; .LST=~IFN^Grp^ActTm^StrtTm^StopTm^Sts^Sig^Nrs^Clk^PrvID^PrvNam^ActDA^Flag^DCType^ChrtRev^DEA#^^Schedule + ; .LST=tOrder Text (repeating as necessary) + ; DFN=Patient ID + ; FILTER=# indicates which orders to return, default=2 (current) + ; GROUPS=display grp of orders to show (default=ALL) + ; -- this section uses ORQ1 to get orders list rather than XGET -- + N ORLIST,ORIFN,X0,X3,X8,IDX,IFN,ACT,PRV,LN,TXT,STRT,STOP,CSTS,EYE,DEA ;PKI + K ^TMP("ORR",$J) + S (IDX,LST)=0 S:'$D(GROUPS) GROUPS=1 S:'$D(FILTER) FILTER=2 + D EN^ORQ1(DFN_";DPT(",GROUPS,FILTER,"","","",0,1) + S EYE=0 F S EYE=$O(^TMP("ORR",$J,ORLIST,EYE)) Q:'EYE S IFN=^(EYE) D + . S ACT=$P(IFN,";",2),IFN=+IFN,X0=^OR(100,IFN,0),X3=^(3),X8=^(8,ACT,0) + . D GETFLDS + K ^TMP("ORR",$J) + G EXIT +AGET(REF,DFN,FILTER,GROUPS,DTFROM,DTTHRU,EVENT) ;Get an abbrev. event delayed order list for patient + ; returns ^TMP("ORR",$J,ORLIST,n)=IFN^DGrp^ActTm + ; see input parameters above + ; -- from ORWORR + ; -- section uses ORQ1 to get the orders list rather than XGET -- + N ORLIST,ORIFN,IFN,I,ORWTS,TOT,MULT,ORWARD,TXTVW,ORYD,PTEVTID,EVTNAME + S (PTEVTID,EVTNAME)="" + K ^TMP("ORR",$J),^TMP("ORRJD",$J) + S:'$D(GROUPS) GROUPS=1 S:'$D(FILTER) FILTER=2 + S ORWTS=+$P(FILTER,U,2),FILTER=+FILTER + S MULT=$S("^1^6^8^9^10^11^13^14^20^22^"[(U_FILTER_U):1,1:0) + I $L($G(^DPT(DFN,.1))) S ORWARD=1 ; normally ptr to 42 + S:'$L($G(DTFROM)) DTFROM=0 + S:'$L($G(DTTHRU)) DTTHRU=0 + S:'$L($G(EVENT)) EVENT=0 + I $G(EVTDCREL)="TRUE" D + . D EN^ORQ1(DFN_";DPT(",GROUPS,FILTER,"",DTFROM,DTTHRU,2,MULT,"",1,EVENT) + . D GET2^ORWORR1 + E D + . D EN^ORQ1(DFN_";DPT(",GROUPS,FILTER,"",DTFROM,DTTHRU,0,MULT,"",1,EVENT) + . D GET1^ORWORR1 + Q +RGET(REF,DFN,FILTER,GROUPS,DTFROM,DTTHRU,EVENT) ;Orders of AutoDC/Release Event + N EVTDCREL + S EVTDCREL="TRUE" + D AGET(.REF,DFN,FILTER,GROUPS,DTFROM,DTTHRU,EVENT) + Q +XGET ; -- the retrieval algorithm before all the AC xref changes + N X,X0,X3,IDX,IFN,LN,TIME,DGRP,MASK,TXT,ACT,PRV,ID,DEA,PASS ;PKI + S DFN=DFN_";DPT(",IDX=0,LST=0 + I '$G(FILTER) S FILTER=2 ; Default: Current/Active + I $D(GROUPS)=1 D + . S:'GROUPS GROUPS=$O(^ORD(100.98,"B",GROUPS,0)) + . D XPND(GROUPS) + I FILTER=1 D DOALL G EXIT ; All + I FILTER=2 D DOCUR G EXIT ; Current + I FILTER=3 S PASS=";1;" ; Discontinued + I FILTER=4 S PASS=";2;7;" ; Comp/Expired + I FILTER=5 S PASS=";3;4;5;6;8;9;" ; Expiring + I FILTER=6 S PASS=";1;2;3;4;5;6;7;8;9;11;" ; New Activity + I FILTER=7 S PASS=";5;" ; Pending + I FILTER=8 Q ; Expanded + I FILTER=9 S PASS=";3;4;5;6;8;9;11;" ; Unverified by Nurse + I FILTER=10 S PASS=";3;4;5;6;8;9;11;" ; Unverified by Clerk + I FILTER=11 S PASS=";3;4;5;6;7;8;11;" ; Unsigned + I FILTER=12 S PASS=";4;" ; Flagged + I FILTER=13 S PASS="" ; Verbal/Phone + I FILTER=14 S PASS="" ; Verbal/Phone Unsigned + D DOGET +EXIT I LST=0 D + . N %,X,%I D NOW^%DTC + . S LST(1)="~0^0^"_%_"^^^97",LST(2)="tNo Orders Found." + Q +DOGET ; Come here to filter orders + S TIME=0 F S TIME=$O(^OR(100,"AO",DFN,TIME)) Q:'TIME D + . S DGRP=0 F S DGRP=$O(^OR(100,"AO",DFN,TIME,DGRP)) Q:'DGRP D + . . I $D(GROUPS)>1 Q:'$D(GROUPS(DGRP)) ;filter by display grp + . . S IFN=0 F S IFN=$O(^OR(100,"AO",DFN,TIME,DGRP,IFN)) Q:'IFN D + . . . S X0=^OR(100,IFN,0),X3=^(3) ;get main nodes + . . . I $P(X3,U,8)!$P(X3,U,9)!($P(X3,U,3)=99) Q ;skip veil,chld,sts=99 + . . . I $L(PASS),(PASS'[(";"_$P(X3,U,3)_";")) Q ;filter by status + . . . ; do any other filtering + . . . D GETFLDS + Q +DOALL ; Come here to get all orders (no filter by status) + S TIME=0 F S TIME=$O(^OR(100,"AO",DFN,TIME)) Q:'TIME D + . S DGRP=0 F S DGRP=$O(^OR(100,"AO",DFN,TIME,DGRP)) Q:'DGRP D + . . I $D(GROUPS)>1 Q:'$D(GROUPS(DGRP)) ;filter by display grp + . . S IFN=0 F S IFN=$O(^OR(100,"AO",DFN,TIME,DGRP,IFN)) Q:'IFN D + . . . S X0=^OR(100,IFN,0),X3=^(3) ;get main nodes + . . . I $P(X3,U,8)!$P(X3,U,9)!($P(X3,U,3)=99) Q ;skip veil,chld,sts=99 + . . . D GETFLDS + Q +DOCUR ; Come here to get all current orders + N AOCTXT,STS,STOP,% + S X=-$$GET^XPAR("ALL","ORPF ACTIVE ORDERS CONTEXT HRS") + S %H=$H,X=(%H*86400+$P(%H,",",2))+(X*3600),%H=(X\86400)_","_(X#86400) + D YMD^%DTC S AOCTXT=X_% + S MASK="110000100101110" ; mask out STS=1,2,7,10,12,13,14 + S TIME=0 F S TIME=$O(^OR(100,"AC",DFN,TIME)) Q:'TIME D + . S IFN=0 F S IFN=$O(^OR(100,"AC",DFN,TIME,IFN)) Q:'IFN D + . . ; filter out display groups here + . . S ACT=0 F S ACT=$O(^OR(100,"AC",DFN,TIME,IFN,ACT)) Q:'ACT D + . . . S X0=^OR(100,IFN,0),X3=^(3),X8=^(8,ACT,0) + . . . S STS=$P(X3,U,3),STOP=$P(X0,U,9) + . . . I $P(X3,U,8)!$P(X3,U,9)!(STS=99) Q + . . . I $P(X8,U,15)=13,($P(X8,U)0 Y=$P(^DIC(9.4,PKGID,0),U,2) + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWORR1.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWORR1.m index 1bb5b72e..92328192 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWORR1.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWORR1.m @@ -1,59 +1,34 @@ -ORWORR1 ; SLC/JLI - Utilities for Retrieve Orders for Broker ; 4/3/08 7:47am - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141,243**;Dec 17, 1997;Build 242 - ;Called from ORWORR -GET1 ; - S TOT=^TMP("ORR",$J,ORLIST,"TOT") K ^TMP("ORR",$J,ORLIST,"TOT") - S I=.1 F S I=$O(^TMP("ORR",$J,ORLIST,I)) Q:'I S IFN=^(I) D - . I $G(ORRECIP)&&($G(FILTER)=12&&($$FLAGRULE(+IFN))) K ^TMP("ORR",$J,ORLIST,I) S TOT=TOT-1 Q - . I ORWTS,(+$P($G(^OR(100,+IFN,0)),U,13)'=ORWTS) K ^TMP("ORR",$J,ORLIST,I) S TOT=TOT-1 Q - . S PTEVTID=$P($G(^OR(100,+IFN,0)),U,17) - . S:PTEVTID>0 EVTNAME=$$NAME^OREVNTX(PTEVTID) - . S ^TMP("ORR",$J,ORLIST,I)=IFN_U_$P($G(^OR(100,+IFN,0)),U,11)_U_$P($G(^(8,+$P(IFN,";",2),0)),U)_U_PTEVTID_U_EVTNAME - S TXTVW=$S(MULT:0,FILTER=2:2,1:1) D:FILTER=2 ORYD^ORDD100 - S ^TMP("ORR",$J,ORLIST,.1)=TOT_U_TXTVW_U_$G(ORYD,0) - S REF=$NA(^TMP("ORR",$J,ORLIST)) - Q -GET2 ; For AUTO DC/Event Release Orders - N JDND,JDIX,JDCNT,DCSPLIT - S JDCNT=1,DCSPLIT=0 - S TOT=^TMP("ORR",$J,ORLIST,"TOT") K ^TMP("ORR",$J,ORLIST,"TOT") - F JDND="RL","DC" D - . S I=.1 F S I=$O(^TMP("ORR",$J,ORLIST,I)) Q:'I D - . . I '$D(^TMP("ORR",$J,ORLIST,I,JDND)) Q - . . S JDIX=0 F S JDIX=$O(^TMP("ORR",$J,ORLIST,I,JDND,JDIX)) Q:'JDIX S IFN=^(JDIX) D - . . . I 'DCSPLIT,(JDND="DC") D - . . . . S ^TMP("ORRJD",$J,JDCNT)="DC START" - . . . . S DCSPLIT=1,JDCNT=JDCNT+1,TOT=TOT+1 - . . . I ORWTS,(+$P($G(^OR(100,+IFN,0)),U,13)'=ORWTS) S TOT=TOT-1 Q - . . . S PTEVTID=$P($G(^OR(100,+IFN,0)),U,17) - . . . S:PTEVTID>0 EVTNAME=$$NAME^OREVNTX(PTEVTID) - . . . S ^TMP("ORRJD",$J,JDCNT)=IFN_U_$P($G(^OR(100,+IFN,0)),U,11)_U_$P($G(^(8,+$P(IFN,";",2),0)),U)_U_PTEVTID_U_EVTNAME - . . . S JDCNT=JDCNT+1 - S TXTVW=$S(MULT:0,FILTER=2:2,1:1) D:FILTER=2 ORYD^ORDD100 - S ^TMP("ORRJD",$J,.1)=TOT_U_TXTVW_U_$G(ORYD,0) - S REF=$NA(^TMP("ORRJD",$J)) - Q -FLAGRULE(ORNUM,USR) ; - ;returns 0 if we should keep ORNUM in the list - ;returns 1 if we should remove ORNUM from the list - ;determines based on whether the user USR should see these flagged orders - ; based on presence in file 100 NODE 8 FIELD 39 and - ; based on whether the user should have gotten the flag due to provider recipients - N ORI,ORRET,ORQUIT,I,LST,ORDFN - I '$G(USR) S USR=DUZ - S ORRET=1,ORQUIT=0 - S ORI=0 F S ORI=$O(^OR(100,ORNUM,8,ORI)) Q:'ORI D - .I '$P($G(^OR(100,ORNUM,8,ORI,3)),U,6)&($P($G(^OR(100,ORNUM,8,ORI,3)),U,9)) S LST($P($G(^OR(100,ORNUM,8,ORI,3)),U,9))="" - S ORDFN=+$P($G(^OR(100,ORNUM,0)),U,2) - D START^ORBPRCHK(.LST,ORNUM,6,ORDFN) - ;add ordering provider - N ORDPROV - S ORDPROV=$$ORDERER^ORQOR2(ORNUM) - I $G(ORDPROV) S LST(ORDPROV)="" - D ADDSURR(.LST) - I $D(LST(USR)) S ORRET=0 - Q ORRET -ADDSURR(LST) ;TAKE LIST OF USERS AND ADD SURROGATES TO THE LIST - N I - S I=0 F S I=$O(LST(I)) Q:'I S LST($$CURRSURO^XQALSURO(I))="" - Q +ORWORR1 ; SLC/JLI - Utilities for Retrieve Orders for Broker ;9/10/02 3PM [9/16/02 2:56pm] + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141**;Dec 17, 1997 + ;Called from ORWORR +GET1 ; + S TOT=^TMP("ORR",$J,ORLIST,"TOT") K ^TMP("ORR",$J,ORLIST,"TOT") + S I=.1 F S I=$O(^TMP("ORR",$J,ORLIST,I)) Q:'I S IFN=^(I) D + . I ORWTS,(+$P($G(^OR(100,+IFN,0)),U,13)'=ORWTS) K ^TMP("ORR",$J,ORLIST,I) S TOT=TOT-1 Q + . S PTEVTID=$P($G(^OR(100,+IFN,0)),U,17) + . S:PTEVTID>0 EVTNAME=$$NAME^OREVNTX(PTEVTID) + . S ^TMP("ORR",$J,ORLIST,I)=IFN_U_$P($G(^OR(100,+IFN,0)),U,11)_U_$P($G(^(8,+$P(IFN,";",2),0)),U)_U_PTEVTID_U_EVTNAME + S TXTVW=$S(MULT:0,FILTER=2:2,1:1) D:FILTER=2 ORYD^ORDD100 + S ^TMP("ORR",$J,ORLIST,.1)=TOT_U_TXTVW_U_$G(ORYD,0) + S REF=$NA(^TMP("ORR",$J,ORLIST)) + Q +GET2 ; For AUTO DC/Event Release Orders + N JDND,JDIX,JDCNT,DCSPLIT + S JDCNT=1,DCSPLIT=0 + S TOT=^TMP("ORR",$J,ORLIST,"TOT") K ^TMP("ORR",$J,ORLIST,"TOT") + F JDND="RL","DC" D + . S I=.1 F S I=$O(^TMP("ORR",$J,ORLIST,I)) Q:'I D + . . I '$D(^TMP("ORR",$J,ORLIST,I,JDND)) Q + . . S JDIX=0 F S JDIX=$O(^TMP("ORR",$J,ORLIST,I,JDND,JDIX)) Q:'JDIX S IFN=^(JDIX) D + . . . I 'DCSPLIT,(JDND="DC") D + . . . . S ^TMP("ORRJD",$J,JDCNT)="DC START" + . . . . S DCSPLIT=1,JDCNT=JDCNT+1,TOT=TOT+1 + . . . I ORWTS,(+$P($G(^OR(100,+IFN,0)),U,13)'=ORWTS) S TOT=TOT-1 Q + . . . S PTEVTID=$P($G(^OR(100,+IFN,0)),U,17) + . . . S:PTEVTID>0 EVTNAME=$$NAME^OREVNTX(PTEVTID) + . . . S ^TMP("ORRJD",$J,JDCNT)=IFN_U_$P($G(^OR(100,+IFN,0)),U,11)_U_$P($G(^(8,+$P(IFN,";",2),0)),U)_U_PTEVTID_U_EVTNAME + . . . S JDCNT=JDCNT+1 + S TXTVW=$S(MULT:0,FILTER=2:2,1:1) D:FILTER=2 ORYD^ORDD100 + S ^TMP("ORRJD",$J,.1)=TOT_U_TXTVW_U_$G(ORYD,0) + S REF=$NA(^TMP("ORRJD",$J)) + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPCE.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPCE.m index 8137bea0..c63bd19e 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPCE.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPCE.m @@ -1,186 +1,186 @@ -ORWPCE ; SLC/JM/REV - wrap calls to PCE and AICS;04/01/2003 ;10/11/06 16:05 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,173,190,195,215,243**;Dec 17, 1997;Build 242 - ; - ; DBIA 2950 LOOK^LEXA ^TMP("LEXFND",$J) - ; DBIA 1609 CONFIG^LEXSET ^TMP("LEXSCH",$J) - ; DBIA 1365 DSELECT^GMPLENFM ^TMP("IB",$J) - ; DBIA 3991 $$STATCHK^ICDAPIU - ; - Q -VISIT(LST,CLINIC,ORDATE) ; get list of visit types for clinic - S:'+$G(ORDATE) ORDATE=DT - D GETLST^IBDF18A(CLINIC,"DG SELECT VISIT TYPE CPT PROCEDURES","LST",,,,ORDATE) - Q -PROC(LST,CLINIC,ORDATE) ; get list of procedures for clinic P12 for CPTMods - S:'+$G(ORDATE) ORDATE=DT - D GETLST^IBDF18A(CLINIC,"DG SELECT CPT PROCEDURE CODES","LST",,,1,ORDATE) - N IDX,MOD,CODES,FIRST S IDX=0 - F S IDX=$O(LST(IDX)) Q:'+IDX D - . I LST(IDX)="" K LST(IDX) Q - . S MOD=0,CODES="",FIRST=1 - . F S MOD=$O(LST(IDX,"MODIFIER",MOD)) Q:(MOD="") D - . . I FIRST S FIRST=0 - . . E S CODES=CODES_";" - . . S CODES=CODES_LST(IDX,"MODIFIER",MOD) - . K LST(IDX,"MODIFIER") - . I 'FIRST S $P(LST(IDX),U,12)=CODES - Q -CPTMODS(LST,ORCPTCOD,ORDATE) ;Return CPT Modifiers for a CPT Code - N ORM,ORIDX,ORI,MODNAME - S:'+$G(ORDATE) ORDATE=DT - I +($$CODM^ICPTCOD(ORCPTCOD,$NA(ORM),0,ORDATE)),+$D(ORM) D - . S ORIDX="",ORI=0 - . F S ORIDX=$O(ORM(ORIDX)) Q:(ORIDX="") D - . . S ORI=ORI+1,MODNAME=$P(ORM(ORIDX),U,1) - . . S LST(MODNAME_ORI)=$P(ORM(ORIDX),U,2)_U_MODNAME_U_ORIDX - Q -GETMOD(MODINFO,ORMODIEN,ORDATE) ;Returns info for a specific CPT Modifier - N ORDATA - S:'+$G(ORDATE) ORDATE=DT - S ORDATA=$$MOD^ICPTMOD(ORMODIEN,"I",ORDATE,1) - I +ORDATA>0 S MODINFO=ORMODIEN_U_$P(ORDATA,U,3)_U_$P(ORDATA,U,2) - Q -DIAG(LST,CLINIC,ORDATE) ; get list of diagnoses for clinic - S:'+$G(ORDATE) ORDATE=DT - D GETLST^IBDF18A(CLINIC,"DG SELECT ICD-9 DIAGNOSIS CODES","LST",,,,ORDATE) - Q -IMM(LST,CLINIC) ;get list of immunizations for clinic - D GETLST^IBDF18A(CLINIC,"PX SELECT IMMUNIZATIONS","LST") - Q -SK(LST,CLINIC) ;get list of skin test for clinic - D GETLST^IBDF18A(CLINIC,"PX SELECT SKIN TESTS","LST") - Q -HF(LST,CLINIC) ;get list of health factors for clinic - D GETLST^IBDF18A(CLINIC,"PX SELECT HEALTH FACTORS","LST") - Q -PED(LST,CLINIC) ;get list of education topices for clinic - D GETLST^IBDF18A(CLINIC,"PX SELECT EDUCATION TOPICS","LST") - Q -TRT(LST,CLINIC) ;get list of treatments for clinic - D GETLST^IBDF18A(CLINIC,"PX SELECT TREATMENTS","LST") - Q -XAM(LST,CLINIC) ;get list of exams for clinic - D GETLST^IBDF18A(CLINIC,"PX SELECT EXAMS","LST") - Q -ACTPROB(GLST,DFN,ORDATE) ;get list of patient's active problems - K ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS") - S:'+$G(ORDATE) ORDATE=DT - D DSELECT^GMPLENFM ;DBIA 1365 - N ORPROB,ORPROBIX,ORPRCNT - S ORPRCNT=0 - S ORPROBIX=0 - F S ORPROBIX=$O(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORPROBIX)) Q:'ORPROBIX D ;DBIA 1365 - . S ORPROB=$P(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORPROBIX),"^",2,3) - . I $E(ORPROB,1)="$" S ORPROB=$E(ORPROB,2,255) - . I '$D(ORPROB(ORPROB)) D - .. S ORPROB(ORPROB)="" - .. S ORPRCNT=ORPRCNT+1 - .. S $P(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORPROBIX),"^",2,3)=ORPROB - . E K ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORPROBIX) - ; DBIA 10082 NAME: ICD DIAGNOSIS FILE - N ORWINDEX,ORITEM - S ORWINDEX=0 - F S ORWINDEX=$O(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORWINDEX)) Q:'ORWINDEX D:$P(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORWINDEX),"^",1)]"" - . S ORITEM=^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORWINDEX) - . I '+$$STATCHK^ICDAPIU($P(ORITEM,"^",3),ORDATE) S $P(ORITEM,"^",11)="#" ;DBIA 3991 - . S ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORWINDEX)=ORITEM - S ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",0)=ORPRCNT - S GLST="^TMP(""IB"","_$J_",""INTERFACES"",""GMP SELECT PATIENT ACTIVE PROBLEMS"")" - Q -SCSEL(VAL,DFN,ATM,LOC,VST) ; return SC conditions that may be selected - ; VAL=SCallow^SCdflt;AOallow^AOdflt;IRallow^IRdflt;ECallow^ECdflt; - ; MSTallow^MSTdflt;HNCallow^HNCdflt;CVAllow^CVDflt;SHADAllow^SHADDflt - N ORX,S S S=";" - D SCCOND^PXUTLSCC(DFN,ATM,LOC,$G(VST),.ORX) - S VAL=$G(ORX("SC"))_S_$G(ORX("AO"))_S_$G(ORX("IR"))_S_$G(ORX("EC"))_S_$G(ORX("MST"))_S_$G(ORX("HNC"))_S_$G(ORX("CV"))_S_$G(ORX("SHAD")) - Q -SCDIS(LST,DFN) ; Return service connected % and rated disabilities - N VAEL,VAERR,I,ILST,DIS,SC,X - D ELIG^VADPT - S LST(1)="Service Connected: "_$S(+VAEL(3):$P(VAEL(3),U,2)_"%",1:"NO") - I 'VAEL(4),'$P($G(^DG(391,+VAEL(6),0)),U,2) S LST(2)="NOT A VETERAN." Q - S I=0,ILST=1 F S I=$O(^DPT(DFN,.372,I)) Q:'I S X=^(I,0) D - . S DIS=$P($G(^DIC(31,+X,0)),U) Q:DIS="" - . S SC=$S($P(X,U,3):"SC",$P(X,U,3)']"":"not specified",1:"NSC") - . S ILST=ILST+1,LST(ILST)=DIS_" ("_$P(X,U,2)_"% "_SC_")" - I ILST=1 S LST(2)="Rated Disabilities: NONE STATED" - Q -CPTREQD(VAL,IEN) ; return 1 in VAL if note still needs a CPT code - S VAL=+$P(^TIU(8925,IEN,0),U,11) - Q -NOTEVSTR(VAL,IEN) ; return the VSTR^AUTHOR for a note - N X0,X12,VISIT - S X0=$G(^TIU(8925,+IEN,0)),X12=$G(^(12)),VISIT=$P(X12,U,7) - I +VISIT S VAL=$$VSTRBLD^TIUSRVP(VISIT) I 1 - E S VAL=$P(X12,U,11)_";"_$P(X0,U,7)_";"_$P(X0,U,13) - Q -HASVISIT(ORY,IEN,DFN,ORLOC,ORDTE) ;Has visit or is stand alone - N ORVISIT - S ORY=-1 - I +$G(IEN)>0 S ORVISIT=+$P($G(^TIU(8925,+IEN,0)),U,3) - I +$G(ORVISIT)'>0 S ORVISIT=$$GETENC^PXAPI(DFN,ORDTE,ORLOC) - I +$G(ORVISIT)>0 S ORY=$$VST2APPT^PXAPI(ORVISIT) - Q -DELETE(VAL,VSTR,DFN) ; delete PCE info when deleting a note - N VISIT,ORCOUNT - N ZTIO,ZTRTN,ZTDTH,ZTSAVE,ZTDESC,ZTSYNC,ZTSK - I '$D(^TMP("ORWPCE",$J,VSTR)) S VAL=0 Q ; no PCE data saved yet - I $P(VSTR,";",3)="H" S VAL=0 Q ; leave inpatient alone - I $L($T(DOCCNT^TIUSRVLV))=0 S VAL=0 Q ; leave if no tiu entry point - D DOCCNT^TIUSRVLV(.ORCOUNT,DFN,VSTR) ; Do not delete if another - I ORCOUNT>0 S VAL=0 Q ; title points to visit - S ZTIO="ORW/PXAPI RESOURCE",ZTRTN="DQDEL^ORWPCE1",ZTDTH=$H - S (ZTSAVE("VSTR"),ZTSAVE("DFN"))="",ZTDESC="CPRS Delete Note/PCE" - S ZTSYNC="ORW"_VSTR - D ^%ZTLOAD I '$D(ZTSK) D DQDEL^ORWPCE1 - Q -SAVE(OK,PCELIST,NOTEIEN,ORLOC) ; save PCE information - N VSTR,GMPLUSER - N ZTIO,ZTRTN,ZTDTH,ZTSAVE,ZTDESC,ZTSYNC,ZTSK - S VSTR=$P(PCELIST(1),U,4) K ^TMP("ORWPCE",$J,VSTR) - M ^TMP("ORWPCE",$J,VSTR)=PCELIST - S GMPLUSER=$$CLINUSER^ORQQPL1(DUZ),NOTEIEN=+$G(NOTEIEN) - S ZTIO="ORW/PXAPI RESOURCE",ZTRTN="DQSAVE^ORWPCE1",ZTDTH=$H - S ZTSAVE("PCELIST(")="",ZTDESC="Data from CPRS to PCE" - S ZTSAVE("GMPLUSER")="",ZTSAVE("NOTEIEN")="",ZTSAVE("DUZ")="" - I VSTR'["E" S ZTSYNC="ORW"_VSTR - S ZTSAVE("ORLOC")="" - D ^%ZTLOAD I '$D(ZTSK) D DQSAVE^ORWPCE1 - Q -LEX(LST,X,APP,ORDATE) ; return list after lexicon lookup - N LEX,ILST,I,IEN - S:APP="CPT" APP="CHP" ; LEX PATCH 10 - S:'+$G(ORDATE) ORDATE=DT - D CONFIG^LEXSET(APP,APP,ORDATE) ;DBIA 1609 - I APP="CHP" D - . ; Set the filter for CPT only using CS APIs - format is the same as for DIC("S") - . S ^TMP("LEXSCH",$J,"FIL",0)="I $L($$CPTONE^LEXU(+Y,$G(ORDATE)))!($L($$CPCONE^LEXU(+Y,$G(ORDATE))))" ;DBIA 1609 - . ; Set Applications Default Flag (Lexicon can not overwrite filter) - . S ^TMP("LEXSCH",$J,"ADF",0)=1 - D LOOK^LEXA(X,APP,1,"",ORDATE) - I '$D(LEX("LIST",1)) S LST(1)="-1^No matches found." Q - S LST(1)=LEX("LIST",1),ILST=1 - S (I,IEN)="" - F S I=$O(^TMP("LEXFND",$J,I)) Q:I="" D ;DBIA 2950 - .F S IEN=$O(^TMP("LEXFND",$J,I,IEN)) Q:IEN="" D - ..S ILST=ILST+1,LST(ILST)=IEN_U_^TMP("LEXFND",$J,I,IEN) - K ^TMP("LEXFND",$J),^TMP("LEXHIT",$J),^TMP("LEXSCH",$J) - Q -LEXCODE(VAL,IEN,APP,ORDATE) ; return code for a lexicon entry - S VAL="" - S:'+$G(ORDATE) ORDATE=DT - I APP="ICD" S VAL=$$ICDONE^LEXU(IEN,ORDATE) - I APP="CPT"!(APP="CHP") S VAL=$$CPTONE^LEXU(IEN,ORDATE) ; LEX PATCH 10 - I VAL="",(APP="CHP") S VAL=$$CPCONE^LEXU(IEN,ORDATE) ; LEX PATCH 10 - Q -ADDRES ; Add the ORW/PXAPI RESOURCE device - N X - S X=$$RES^XUDHSET("ORW/PXAPI RESOURCE",,5,"CPRS to PCE transactions") - Q -GETSVC(NEWSVC,SVC,LOC,INP) ; Returns the correct Service Connected Category - N DSS,ORWSVC - S DSS=$P($G(^SC(+LOC,0)),U,7) - Q:'+DSS - M ORWSVC=SVC - S NEWSVC=$$SVC^PXKCO(.ORWSVC,DSS,INP,LOC) ; DBIA #3225 - Q +ORWPCE ; SLC/JM/REV - wrap calls to PCE and AICS;04/01/2003 ;07/05/04 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,173,190,195,215**;Dec 17, 1997 + ; + ; DBIA 2950 LOOK^LEXA ^TMP("LEXFND",$J) + ; DBIA 1609 CONFIG^LEXSET ^TMP("LEXSCH",$J) + ; DBIA 1365 DSELECT^GMPLENFM ^TMP("IB",$J) + ; DBIA 3991 $$STATCHK^ICDAPIU + ; + Q +VISIT(LST,CLINIC,ORDATE) ; get list of visit types for clinic + S:'+$G(ORDATE) ORDATE=DT + D GETLST^IBDF18A(CLINIC,"DG SELECT VISIT TYPE CPT PROCEDURES","LST",,,,ORDATE) + Q +PROC(LST,CLINIC,ORDATE) ; get list of procedures for clinic P12 for CPTMods + S:'+$G(ORDATE) ORDATE=DT + D GETLST^IBDF18A(CLINIC,"DG SELECT CPT PROCEDURE CODES","LST",,,1,ORDATE) + N IDX,MOD,CODES,FIRST S IDX=0 + F S IDX=$O(LST(IDX)) Q:'+IDX D + . I LST(IDX)="" K LST(IDX) Q + . S MOD=0,CODES="",FIRST=1 + . F S MOD=$O(LST(IDX,"MODIFIER",MOD)) Q:(MOD="") D + . . I FIRST S FIRST=0 + . . E S CODES=CODES_";" + . . S CODES=CODES_LST(IDX,"MODIFIER",MOD) + . K LST(IDX,"MODIFIER") + . I 'FIRST S $P(LST(IDX),U,12)=CODES + Q +CPTMODS(LST,ORCPTCOD,ORDATE) ;Return CPT Modifiers for a CPT Code + N ORM,ORIDX,ORI,MODNAME + S:'+$G(ORDATE) ORDATE=DT + I +($$CODM^ICPTCOD(ORCPTCOD,$NA(ORM),0,ORDATE)),+$D(ORM) D + . S ORIDX="",ORI=0 + . F S ORIDX=$O(ORM(ORIDX)) Q:(ORIDX="") D + . . S ORI=ORI+1,MODNAME=$P(ORM(ORIDX),U,1) + . . S LST(MODNAME_ORI)=$P(ORM(ORIDX),U,2)_U_MODNAME_U_ORIDX + Q +GETMOD(MODINFO,ORMODIEN,ORDATE) ;Returns info for a specific CPT Modifier + N ORDATA + S:'+$G(ORDATE) ORDATE=DT + S ORDATA=$$MOD^ICPTMOD(ORMODIEN,"I",ORDATE,1) + I +ORDATA>0 S MODINFO=ORMODIEN_U_$P(ORDATA,U,3)_U_$P(ORDATA,U,2) + Q +DIAG(LST,CLINIC,ORDATE) ; get list of diagnoses for clinic + S:'+$G(ORDATE) ORDATE=DT + D GETLST^IBDF18A(CLINIC,"DG SELECT ICD-9 DIAGNOSIS CODES","LST",,,,ORDATE) + Q +IMM(LST,CLINIC) ;get list of immunizations for clinic + D GETLST^IBDF18A(CLINIC,"PX SELECT IMMUNIZATIONS","LST") + Q +SK(LST,CLINIC) ;get list of skin test for clinic + D GETLST^IBDF18A(CLINIC,"PX SELECT SKIN TESTS","LST") + Q +HF(LST,CLINIC) ;get list of health factors for clinic + D GETLST^IBDF18A(CLINIC,"PX SELECT HEALTH FACTORS","LST") + Q +PED(LST,CLINIC) ;get list of education topices for clinic + D GETLST^IBDF18A(CLINIC,"PX SELECT EDUCATION TOPICS","LST") + Q +TRT(LST,CLINIC) ;get list of treatments for clinic + D GETLST^IBDF18A(CLINIC,"PX SELECT TREATMENTS","LST") + Q +XAM(LST,CLINIC) ;get list of exams for clinic + D GETLST^IBDF18A(CLINIC,"PX SELECT EXAMS","LST") + Q +ACTPROB(GLST,DFN,ORDATE) ;get list of patient's active problems + K ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS") + S:'+$G(ORDATE) ORDATE=DT + D DSELECT^GMPLENFM ;DBIA 1365 + N ORPROB,ORPROBIX,ORPRCNT + S ORPRCNT=0 + S ORPROBIX=0 + F S ORPROBIX=$O(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORPROBIX)) Q:'ORPROBIX D ;DBIA 1365 + . S ORPROB=$P(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORPROBIX),"^",2,3) + . I $E(ORPROB,1)="$" S ORPROB=$E(ORPROB,2,255) + . I '$D(ORPROB(ORPROB)) D + .. S ORPROB(ORPROB)="" + .. S ORPRCNT=ORPRCNT+1 + .. S $P(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORPROBIX),"^",2,3)=ORPROB + . E K ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORPROBIX) + ; DBIA 10082 NAME: ICD DIAGNOSIS FILE + N ORWINDEX,ORITEM + S ORWINDEX=0 + F S ORWINDEX=$O(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORWINDEX)) Q:'ORWINDEX D:$P(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORWINDEX),"^",1)]"" + . S ORITEM=^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORWINDEX) + . I '+$$STATCHK^ICDAPIU($P(ORITEM,"^",3),ORDATE) S $P(ORITEM,"^",11)="#" ;DBIA 3991 + . S ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORWINDEX)=ORITEM + S ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",0)=ORPRCNT + S GLST="^TMP(""IB"","_$J_",""INTERFACES"",""GMP SELECT PATIENT ACTIVE PROBLEMS"")" + Q +SCSEL(VAL,DFN,ATM,LOC,VST) ; return SC conditions that may be selected + ; VAL=SCallow^SCdflt;AOallow^AOdflt;IRallow^IRdflt;ECallow^ECdflt; + ; MSTallow^MSTdflt;HNCallow^HNCdflt;CVAllow^CVDflt + N ORX,S S S=";" + D SCCOND^PXUTLSCC(DFN,ATM,LOC,$G(VST),.ORX) + S VAL=$G(ORX("SC"))_S_$G(ORX("AO"))_S_$G(ORX("IR"))_S_$G(ORX("EC"))_S_$G(ORX("MST"))_S_$G(ORX("HNC"))_S_$G(ORX("CV")) + Q +SCDIS(LST,DFN) ; Return service connected % and rated disabilities + N VAEL,VAERR,I,ILST,DIS,SC,X + D ELIG^VADPT + S LST(1)="Service Connected: "_$S(+VAEL(3):$P(VAEL(3),U,2)_"%",1:"NO") + I 'VAEL(4),'$P($G(^DG(391,+VAEL(6),0)),U,2) S LST(2)="NOT A VETERAN." Q + S I=0,ILST=1 F S I=$O(^DPT(DFN,.372,I)) Q:'I S X=^(I,0) D + . S DIS=$P($G(^DIC(31,+X,0)),U) Q:DIS="" + . S SC=$S($P(X,U,3):"SC",$P(X,U,3)']"":"not specified",1:"NSC") + . S ILST=ILST+1,LST(ILST)=DIS_" ("_$P(X,U,2)_"% "_SC_")" + I ILST=1 S LST(2)="Rated Disabilities: NONE STATED" + Q +CPTREQD(VAL,IEN) ; return 1 in VAL if note still needs a CPT code + S VAL=+$P(^TIU(8925,IEN,0),U,11) + Q +NOTEVSTR(VAL,IEN) ; return the VSTR^AUTHOR for a note + N X0,X12,VISIT + S X0=$G(^TIU(8925,+IEN,0)),X12=$G(^(12)),VISIT=$P(X12,U,7) + I +VISIT S VAL=$$VSTRBLD^TIUSRVP(VISIT) I 1 + E S VAL=$P(X12,U,11)_";"_$P(X0,U,7)_";"_$P(X0,U,13) + Q +HASVISIT(ORY,IEN,DFN,ORLOC,ORDTE) ;Has visit or is stand alone + N ORVISIT + S ORY=-1 + I +$G(IEN)>0 S ORVISIT=+$P($G(^TIU(8925,+IEN,0)),U,3) + I +$G(ORVISIT)'>0 S ORVISIT=$$GETENC^PXAPI(DFN,ORDTE,ORLOC) + I +$G(ORVISIT)>0 S ORY=$$VST2APPT^PXAPI(ORVISIT) + Q +DELETE(VAL,VSTR,DFN) ; delete PCE info when deleting a note + N VISIT,ORCOUNT + N ZTIO,ZTRTN,ZTDTH,ZTSAVE,ZTDESC,ZTSYNC,ZTSK + I '$D(^TMP("ORWPCE",$J,VSTR)) S VAL=0 Q ; no PCE data saved yet + I $P(VSTR,";",3)="H" S VAL=0 Q ; leave inpatient alone + I $L($T(DOCCNT^TIUSRVLV))=0 S VAL=0 Q ; leave if no tiu entry point + D DOCCNT^TIUSRVLV(.ORCOUNT,DFN,VSTR) ; Do not delete if another + I ORCOUNT>0 S VAL=0 Q ; title points to visit + S ZTIO="ORW/PXAPI RESOURCE",ZTRTN="DQDEL^ORWPCE1",ZTDTH=$H + S (ZTSAVE("VSTR"),ZTSAVE("DFN"))="",ZTDESC="CPRS Delete Note/PCE" + S ZTSYNC="ORW"_VSTR + D ^%ZTLOAD I '$D(ZTSK) D DQDEL^ORWPCE1 + Q +SAVE(OK,PCELIST,NOTEIEN,ORLOC) ; save PCE information + N VSTR,GMPLUSER + N ZTIO,ZTRTN,ZTDTH,ZTSAVE,ZTDESC,ZTSYNC,ZTSK + S VSTR=$P(PCELIST(1),U,4) K ^TMP("ORWPCE",$J,VSTR) + M ^TMP("ORWPCE",$J,VSTR)=PCELIST + S GMPLUSER=$$CLINUSER^ORQQPL1(DUZ),NOTEIEN=+$G(NOTEIEN) + S ZTIO="ORW/PXAPI RESOURCE",ZTRTN="DQSAVE^ORWPCE1",ZTDTH=$H + S ZTSAVE("PCELIST(")="",ZTDESC="Data from CPRS to PCE" + S ZTSAVE("GMPLUSER")="",ZTSAVE("NOTEIEN")="",ZTSAVE("DUZ")="" + I VSTR'["E" S ZTSYNC="ORW"_VSTR + S ZTSAVE("ORLOC")="" + D ^%ZTLOAD I '$D(ZTSK) D DQSAVE^ORWPCE1 + Q +LEX(LST,X,APP,ORDATE) ; return list after lexicon lookup + N LEX,ILST,I,IEN + S:APP="CPT" APP="CHP" ; LEX PATCH 10 + S:'+$G(ORDATE) ORDATE=DT + D CONFIG^LEXSET(APP,APP,ORDATE) ;DBIA 1609 + I APP="CHP" D + . ; Set the filter for CPT only using CS APIs - format is the same as for DIC("S") + . S ^TMP("LEXSCH",$J,"FIL",0)="I $L($$CPTONE^LEXU(+Y,$G(ORDATE)))!($L($$CPCONE^LEXU(+Y,$G(ORDATE))))" ;DBIA 1609 + . ; Set Applications Default Flag (Lexicon can not overwrite filter) + . S ^TMP("LEXSCH",$J,"ADF",0)=1 + D LOOK^LEXA(X,APP,1,"",ORDATE) + I '$D(LEX("LIST",1)) S LST(1)="-1^No matches found." Q + S LST(1)=LEX("LIST",1),ILST=1 + S (I,IEN)="" + F S I=$O(^TMP("LEXFND",$J,I)) Q:I="" D ;DBIA 2950 + .F S IEN=$O(^TMP("LEXFND",$J,I,IEN)) Q:IEN="" D + ..S ILST=ILST+1,LST(ILST)=IEN_U_^TMP("LEXFND",$J,I,IEN) + K ^TMP("LEXFND",$J),^TMP("LEXHIT",$J) + Q +LEXCODE(VAL,IEN,APP,ORDATE) ; return code for a lexicon entry + S VAL="" + S:'+$G(ORDATE) ORDATE=DT + I APP="ICD" S VAL=$$ICDONE^LEXU(IEN,ORDATE) + I APP="CPT"!(APP="CHP") S VAL=$$CPTONE^LEXU(IEN,ORDATE) ; LEX PATCH 10 + I VAL="",(APP="CHP") S VAL=$$CPCONE^LEXU(IEN,ORDATE) ; LEX PATCH 10 + Q +ADDRES ; Add the ORW/PXAPI RESOURCE device + N X + S X=$$RES^XUDHSET("ORW/PXAPI RESOURCE",,5,"CPRS to PCE transactions") + Q +GETSVC(NEWSVC,SVC,LOC,INP) ; Returns the correct Service Connected Category + N DSS,ORWSVC + S DSS=$P($G(^SC(+LOC,0)),U,7) + Q:'+DSS + M ORWSVC=SVC + S NEWSVC=$$SVC^PXKCO(.ORWSVC,DSS,INP,LOC) ; DBIA #3225 + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPCE1.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPCE1.m index 55fb8d8e..9efe965f 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPCE1.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPCE1.m @@ -1,207 +1,206 @@ -ORWPCE1 ;SLC/KCM - PCE Calls from CPRS GUI; 10/26/04 ;4/9/08 07:44 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,132,148,187,190,215,243**;Dec 17, 1997;Build 242 - ; - ; DBIA 1365 DSELECT^GMPLENFM ^TMP("IB",$J) - ; -GETVSIT(VSTR,DFN) ; lookup a visit - N PKG,SRC,ORPXAPI,OK,ORVISIT - S PKG=$O(^DIC(9.4,"B","ORDER ENTRY/RESULTS REPORTING",0)) - S SRC="TEXT INTEGRATION UTILITIES" - S ORPXAPI("ENCOUNTER",1,"ENC D/T")=$P(VSTR,";",2) - S ORPXAPI("ENCOUNTER",1,"PATIENT")=DFN - S ORPXAPI("ENCOUNTER",1,"HOS LOC")=+VSTR - S ORPXAPI("ENCOUNTER",1,"SERVICE CATEGORY")=$P(VSTR,";",3) - S ORPXAPI("ENCOUNTER",1,"ENCOUNTER TYPE")="P" - S OK=$$DATA2PCE^PXAPI("ORPXAPI",PKG,SRC,.ORVISIT) - Q ORVISIT -DQDEL ; background call to DATA2PCE and DELVFILE - N VISIT,VAL - I $D(ZTQUEUED) S ZTREQ="@" - S VISIT=$$GETVSIT(VSTR,DFN) - S VAL=$$DELVFILE^PXAPI("ALL",VISIT,"","TEXT INTEGRATION UTILITIES") - S ZTSTAT=0 ; clear sync flag - Q -DQSAVE ; Background Call to DATA2PCE - N PKG,SRC,TYP,CODE,IEN,OK,I,X,ORPXAPI,ORPXDEL - N CAT,NARR,ROOT,ROOT2,ORAVST - N PRV,CPT,ICD,IMM,SK,PED,HF,XAM,TRT,MOD,MODCNT,MODIDX,MODS - N COM,COMMENT,COMMENTS - N DFN,PROBLEMS,PXAPREDT,ORCPTDEL - I $D(ZTQUEUED) S ZTREQ="@" - S PKG=$O(^DIC(9.4,"B","ORDER ENTRY/RESULTS REPORTING",0)) - S SRC="TEXT INTEGRATION UTILITIES" - S (PRV,CPT,ICD,IMM,SK,PED,HF,XAM,TRT)=0 - S I="" F S I=$O(PCELIST(I)) Q:'I S X=PCELIST(I) D - . S X=PCELIST(I),TYP=$P(X,U),CODE=$P(X,U,2),CAT=$P(X,U,3),NARR=$P(X,U,4) - . I $E(TYP,1,3)="PRV" D Q - . . Q:'$L(CODE) - . . S PRV=PRV+1 - . . S ROOT="ORPXAPI(""PROVIDER"","_PRV_")" - . . S ROOT2="ORPXDEL(""PROVIDER"","_PRV_")" - . . I $E(TYP,4)'="-" D - . . . S @ROOT@("NAME")=CODE - . . . S @ROOT@("PRIMARY")=$P(X,U,6) - . . S @ROOT2@("NAME")=CODE - . . S @ROOT2@("DELETE")=1 - . . S PXAPREDT=1 ;Allow edit of primary flag - . I TYP="VST" D Q - . . S ROOT="ORPXAPI(""ENCOUNTER"",1)" - . . I CODE="DT" S @ROOT@("ENC D/T")=$P(X,U,3) Q - . . I CODE="PT" S @ROOT@("PATIENT")=$P(X,U,3),DFN=$P(X,U,3) Q - . . I CODE="HL" S @ROOT@("HOS LOC")=$P(X,U,3) Q - . . I CODE="PR" S @ROOT@("PARENT")=$P(X,U,3) Q - . . ;prevents checkout! - . . I CODE="VC" S @ROOT@("SERVICE CATEGORY")=$P(X,U,3) Q - . . I CODE="SC" S @ROOT@("SC")=$P(X,U,3) Q - . . I CODE="AO" S @ROOT@("AO")=$P(X,U,3) Q - . . I CODE="IR" S @ROOT@("IR")=$P(X,U,3) Q - . . I CODE="EC" S @ROOT@("EC")=$P(X,U,3) Q - . . I CODE="MST" S @ROOT@("MST")=$P(X,U,3) Q - . . I CODE="HNC" S @ROOT@("HNC")=$P(X,U,3) Q - . . I CODE="CV" S @ROOT@("CV")=$P(X,U,3) Q - . . I CODE="SHD" S @ROOT@("SHAD")=$P(X,U,3) Q - . . I CODE="OL" D Q - . . . I +$P(X,U,3) S @ROOT@("INSTITUTION")=$P(X,U,3) - . . . E I $P(X,U,4)'="",$P(X,U,4)'="0" D - . . . . I $$PATCH^XPDUTL("PX*1.0*96") S @ROOT@("OUTSIDE LOCATION")=$P(X,U,4) - . . . . E S @ROOT@("COMMENT")="OUTSIDE LOCATION: "_$P(X,U,4) - . I $E(TYP,1,3)="CPT" D Q - . . Q:'$L(CODE) - . . S CPT=CPT+1,ROOT="ORPXAPI(""PROCEDURE"","_CPT_")" - . . S IEN=+$O(^ICPT("B",CODE,0)) - . . S @ROOT@("PROCEDURE")=IEN - . . I +$P(X,U,9) D - . . . S MODS=$P(X,U,9),MODCNT=+MODS - . . . F MODIDX=1:1:MODCNT D - . . . . S MOD=$P($P(MODS,";",MODIDX+1),"/") - . . . . S @ROOT@("MODIFIERS",MOD)="" - . . S:$L(CAT) @ROOT@("CATEGORY")=CAT - . . S:$L(NARR) @ROOT@("NARRATIVE")=NARR - . . S:$L($P(X,U,5)) @ROOT@("QTY")=$P(X,U,5) - . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6) - . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="PROCEDURE^"_CPT - . . I $E(TYP,4)="-" S @ROOT@("DELETE")=1,@ROOT@("QTY")=0,ORCPTDEL=CPT - . I $E(TYP,1,3)="POV" D Q - . . Q:'$L(CODE) - . . S ICD=ICD+1,ROOT="ORPXAPI(""DX/PL"","_ICD_")" - . . S IEN=+$O(^ICD9("AB",CODE_" ",0)) - . . S @ROOT@("DIAGNOSIS")=IEN - . . S @ROOT@("PRIMARY")=$P(X,U,5) - . . S:$L(CAT) @ROOT@("CATEGORY")=CAT - . . S:$L(NARR) @ROOT@("NARRATIVE")=NARR - . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6) - . . I $L($P(X,U,7)),$P(X,U,7)=1 S @ROOT@("PL ADD")=$P(X,U,7),PROBLEMS(ICD)=NARR_U_CODE - . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="DX/PL^"_ICD - . . I $E(TYP,4)="-" S @ROOT@("DELETE")=1 - . I $E(TYP,1,3)="IMM" D Q - . . Q:'$L(CODE) - . . S IMM=IMM+1,ROOT="ORPXAPI(""IMMUNIZATION"","_IMM_")" - . . S @ROOT@("IMMUN")=CODE - . . S:$L($P(X,U,5)) @ROOT@("SERIES")=$P(X,U,5) - . . S:$L($P(X,U,5)) @ROOT@("REACTION")=$P(X,U,7) - . . S:$L($P(X,U,8)) @ROOT@("CONTRAINDICATED")=$P(X,U,8) - . . S:$L($P(X,U,9)) @ROOT@("REFUSED")=$P(X,U,9) - . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6) - . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="IMMUNIZATION^"_IMM - . . I $E(TYP,4)="-" S @ROOT@("DELETE")=1 - . I $E(TYP,1,2)="SK" D Q - . . Q:'$L(CODE) - . . S SK=SK+1,ROOT="ORPXAPI(""SKIN TEST"","_SK_")" - . . S @ROOT@("TEST")=CODE - . . S:$L($P(X,U,5)) @ROOT@("RESULT")=$P(X,U,5) - . . S:$L($P(X,U,7)) @ROOT@("READING")=$P(X,U,7) - . . S:$L($P(X,U,8)) @ROOT@("D/T READ")=$P(X,U,8) - . . S:$L($P(X,U,9)) @ROOT@("EVENT D/T")=$P(X,U,9) - . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6) - . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="SKIN TEST^"_SK - . . I $E(TYP,3)="-" S @ROOT@("DELETE")=1 - . I $E(TYP,1,3)="PED" D Q - . . Q:'$L(CODE) - . . S PED=PED+1,ROOT="ORPXAPI(""PATIENT ED"","_PED_")" - . . S @ROOT@("TOPIC")=CODE - . . S:$L($P(X,U,5)) @ROOT@("UNDERSTANDING")=$P(X,U,5) - . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6) - . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="PATIENT ED^"_PED - . . I $E(TYP,4)="-" S @ROOT@("DELETE")=1 - . I $E(TYP,1,2)="HF" D Q - . . Q:'$L(CODE) - . . S HF=HF+1,ROOT="ORPXAPI(""HEALTH FACTOR"","_HF_")" - . . S @ROOT@("HEALTH FACTOR")=CODE - . . S:$L($P(X,U,5)) @ROOT@("LEVEL/SEVERITY")=$P(X,U,5) - . . S:$P(X,U,6)'>0 $P(X,U,6)=$G(ORPXAPI("PROVIDER",1,"NAME")) - . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6) - . . S:$L($P(X,U,11)) @ROOT@("EVENT D/T")=$P($P(X,U,11),";",1) - . . S:$L($P(X,U,11)) SRC=$P($P(X,U,11),";",2) - . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="HEALTH FACTOR^"_HF - . . I $E(TYP,3)="-" S @ROOT@("DELETE")=1 - . I $E(TYP,1,3)="XAM" D Q - . . Q:'$L(CODE) - . . S XAM=XAM+1,ROOT="ORPXAPI(""EXAM"","_XAM_")" - . . S @ROOT@("EXAM")=CODE - . . S:$L($P(X,U,5)) @ROOT@("RESULT")=$P(X,U,5) - . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6) - . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="EXAM^"_XAM - . . I $E(TYP,4)="-" S @ROOT@("DELETE")=1 - . I $E(TYP,1,3)="TRT" D Q - . . Q:'$L(CODE) - . . S TRT=TRT+1,ROOT="ORPXAPI(""TREATMENT"","_TRT_")" - . . S @ROOT@("IMMUN")=CODE - . . S:$L(CAT) @ROOT@("CATEGORY")=CAT - . . S:$L(NARR) @ROOT@("NARRATIVE")=NARR - . . S:$L($P(X,U,5)) @ROOT@("QTY")=$P(X,U,5) - . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6) - . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="TREATMENT^"_TRT - . . I $E(TYP,4)="-" S @ROOT@("DELETE")=1,@ROOT@("QTY")=0 - . I $E(TYP,1,3)="COM" D Q - . . Q:'$L(CODE) - . . Q:'$L(CAT) - . . S COMMENTS(CODE)=$P(X,U,3,999) - ;Store the comments - S COM="" - F S COM=$O(COMMENT(COM)) Q:COM="" S:$D(COMMENTS(COM)) ORPXAPI($P(COMMENT(COM),"^",1),$P(COMMENT(COM),"^",2),"COMMENT")=COMMENTS(COM) - ; - ;Remove any problems to add that the patient already has as active problems - I $D(PROBLEMS),$D(DFN) D - . N ORWPROB,ORPROBIX - . K ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS") - . D DSELECT^GMPLENFM ;DBIA 1365 - . S ORPROBIX=0 - . F S ORPROBIX=$O(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORPROBIX)) Q:'ORPROBIX D ;DBIA 1365 - .. S ORWPROB=$P(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORPROBIX),"^",2,3) - .. S ORWPROB($S($E(ORWPROB,1)="$":$E(ORWPROB,2,255),1:ORWPROB))="" - . K ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS") - . Q:'$D(ORWPROB) - . S ORPROBIX="" - . F S ORPROBIX=$O(PROBLEMS(ORPROBIX)) Q:'ORPROBIX D - .. S:$D(ORWPROB(PROBLEMS(ORPROBIX))) ORPXAPI("DX/PL",ORPROBIX,"PL ADD")=0 - ; - I $$MDS(.ORPXAPI,$G(ORLOC)) S ORPXAPI("ENCOUNTER",1,"CHECKOUT D/T")=$$NOW^XLFDT - S ORPXAPI("ENCOUNTER",1,"ENCOUNTER TYPE")="P" -DATA2PCE ; - I $G(PXAPREDT)!($G(ORCPTDEL)) D - . M ORPXDEL("ENCOUNTER")=ORPXAPI("ENCOUNTER") - . I $G(ORCPTDEL) M ORPXDEL("PROCEDURE",ORCPTDEL)=ORPXAPI("PROCEDURE",ORCPTDEL) - . S OK=$$DATA2PCE^PXAPI("ORPXDEL",PKG,SRC,.ORAVST) - S OK=$$DATA2PCE^PXAPI("ORPXAPI",PKG,SRC,.ORAVST) - I OK>0,+NOTEIEN,+ORAVST D ; NOTEIEN only set on inpatient encounters - .N OROK,ORX - .S ORX(1207)=ORAVST - .D FILE^TIUSRVP(.OROK,NOTEIEN,.ORX,1) - S ZTSTAT=0 ; clear sync flag - Q - ; -MDS(X,ORLOC) ; return TRUE if checkout is needed - I $$CHKOUT^ORWPCE2(ORLOC) Q 1 - N I,ORAUTO,OROK - S (OROK,I)=0 - F S I=$O(X("DX/PL",I)) Q:'I D Q:OROK - . I $G(X("DX/PL",I,"DIAGNOSIS")) S OROK=1 - I 'OROK D - .S I=0 F S I=$O(X("PROCEDURE",I)) Q:'I D Q:OROK - .. I $G(X("PROCEDURE",I,"PROCEDURE")) S OROK=1 - I $D(X("PROVIDER",1,"NAME")) S OROK=1 - Q OROK -NONCOUNT(ORY,ORLOC) ; Is the location a non-count clinic? (DBIA #964) - Q:'ORLOC - S ORY=$S($P($G(^SC(ORLOC,0)),U,17)="Y":1,1:0) - Q +ORWPCE1 ;SLC/KCM - PCE Calls from CPRS GUI; 10/26/04 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,132,148,187,190,215**;Dec 17, 1997 + ; + ; DBIA 1365 DSELECT^GMPLENFM ^TMP("IB",$J) + ; +GETVSIT(VSTR,DFN) ; lookup a visit + N PKG,SRC,ORPXAPI,OK,ORVISIT + S PKG=$O(^DIC(9.4,"B","ORDER ENTRY/RESULTS REPORTING",0)) + S SRC="TEXT INTEGRATION UTILITIES" + S ORPXAPI("ENCOUNTER",1,"ENC D/T")=$P(VSTR,";",2) + S ORPXAPI("ENCOUNTER",1,"PATIENT")=DFN + S ORPXAPI("ENCOUNTER",1,"HOS LOC")=+VSTR + S ORPXAPI("ENCOUNTER",1,"SERVICE CATEGORY")=$P(VSTR,";",3) + S ORPXAPI("ENCOUNTER",1,"ENCOUNTER TYPE")="P" + S OK=$$DATA2PCE^PXAPI("ORPXAPI",PKG,SRC,.ORVISIT) + Q ORVISIT +DQDEL ; background call to DATA2PCE and DELVFILE + N VISIT,VAL + I $D(ZTQUEUED) S ZTREQ="@" + S VISIT=$$GETVSIT(VSTR,DFN) + S VAL=$$DELVFILE^PXAPI("ALL",VISIT,"","TEXT INTEGRATION UTILITIES") + S ZTSTAT=0 ; clear sync flag + Q +DQSAVE ; Background Call to DATA2PCE + N PKG,SRC,TYP,CODE,IEN,OK,I,X,ORPXAPI,ORPXDEL + N CAT,NARR,ROOT,ROOT2,ORAVST + N PRV,CPT,ICD,IMM,SK,PED,HF,XAM,TRT,MOD,MODCNT,MODIDX,MODS + N COM,COMMENT,COMMENTS + N DFN,PROBLEMS,PXAPREDT,ORCPTDEL + I $D(ZTQUEUED) S ZTREQ="@" + S PKG=$O(^DIC(9.4,"B","ORDER ENTRY/RESULTS REPORTING",0)) + S SRC="TEXT INTEGRATION UTILITIES" + S (PRV,CPT,ICD,IMM,SK,PED,HF,XAM,TRT)=0 + S I="" F S I=$O(PCELIST(I)) Q:'I S X=PCELIST(I) D + . S X=PCELIST(I),TYP=$P(X,U),CODE=$P(X,U,2),CAT=$P(X,U,3),NARR=$P(X,U,4) + . I $E(TYP,1,3)="PRV" D Q + . . Q:'$L(CODE) + . . S PRV=PRV+1 + . . S ROOT="ORPXAPI(""PROVIDER"","_PRV_")" + . . S ROOT2="ORPXDEL(""PROVIDER"","_PRV_")" + . . I $E(TYP,4)'="-" D + . . . S @ROOT@("NAME")=CODE + . . . S @ROOT@("PRIMARY")=$P(X,U,6) + . . S @ROOT2@("NAME")=CODE + . . S @ROOT2@("DELETE")=1 + . . S PXAPREDT=1 ;Allow edit of primary flag + . I TYP="VST" D Q + . . S ROOT="ORPXAPI(""ENCOUNTER"",1)" + . . I CODE="DT" S @ROOT@("ENC D/T")=$P(X,U,3) Q + . . I CODE="PT" S @ROOT@("PATIENT")=$P(X,U,3),DFN=$P(X,U,3) Q + . . I CODE="HL" S @ROOT@("HOS LOC")=$P(X,U,3) Q + . . I CODE="PR" S @ROOT@("PARENT")=$P(X,U,3) Q + . . ;prevents checkout! + . . I CODE="VC" S @ROOT@("SERVICE CATEGORY")=$P(X,U,3) Q + . . I CODE="SC" S @ROOT@("SC")=$P(X,U,3) Q + . . I CODE="AO" S @ROOT@("AO")=$P(X,U,3) Q + . . I CODE="IR" S @ROOT@("IR")=$P(X,U,3) Q + . . I CODE="EC" S @ROOT@("EC")=$P(X,U,3) Q + . . I CODE="MST" S @ROOT@("MST")=$P(X,U,3) Q + . . I CODE="HNC" S @ROOT@("HNC")=$P(X,U,3) Q + . . I CODE="CV" S @ROOT@("CV")=$P(X,U,3) Q + . . I CODE="OL" D Q + . . . I +$P(X,U,3) S @ROOT@("INSTITUTION")=$P(X,U,3) + . . . E I $P(X,U,4)'="",$P(X,U,4)'="0" D + . . . . I $$PATCH^XPDUTL("PX*1.0*96") S @ROOT@("OUTSIDE LOCATION")=$P(X,U,4) + . . . . E S @ROOT@("COMMENT")="OUTSIDE LOCATION: "_$P(X,U,4) + . I $E(TYP,1,3)="CPT" D Q + . . Q:'$L(CODE) + . . S CPT=CPT+1,ROOT="ORPXAPI(""PROCEDURE"","_CPT_")" + . . S IEN=+$O(^ICPT("B",CODE,0)) + . . S @ROOT@("PROCEDURE")=IEN + . . I +$P(X,U,9) D + . . . S MODS=$P(X,U,9),MODCNT=+MODS + . . . F MODIDX=1:1:MODCNT D + . . . . S MOD=$P($P(MODS,";",MODIDX+1),"/") + . . . . S @ROOT@("MODIFIERS",MOD)="" + . . S:$L(CAT) @ROOT@("CATEGORY")=CAT + . . S:$L(NARR) @ROOT@("NARRATIVE")=NARR + . . S:$L($P(X,U,5)) @ROOT@("QTY")=$P(X,U,5) + . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6) + . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="PROCEDURE^"_CPT + . . I $E(TYP,4)="-" S @ROOT@("DELETE")=1,@ROOT@("QTY")=0,ORCPTDEL=CPT + . I $E(TYP,1,3)="POV" D Q + . . Q:'$L(CODE) + . . S ICD=ICD+1,ROOT="ORPXAPI(""DX/PL"","_ICD_")" + . . S IEN=+$O(^ICD9("AB",CODE_" ",0)) + . . S @ROOT@("DIAGNOSIS")=IEN + . . S @ROOT@("PRIMARY")=$P(X,U,5) + . . S:$L(CAT) @ROOT@("CATEGORY")=CAT + . . S:$L(NARR) @ROOT@("NARRATIVE")=NARR + . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6) + . . I $L($P(X,U,7)),$P(X,U,7)=1 S @ROOT@("PL ADD")=$P(X,U,7),PROBLEMS(ICD)=NARR_U_CODE + . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="DX/PL^"_ICD + . . I $E(TYP,4)="-" S @ROOT@("DELETE")=1 + . I $E(TYP,1,3)="IMM" D Q + . . Q:'$L(CODE) + . . S IMM=IMM+1,ROOT="ORPXAPI(""IMMUNIZATION"","_IMM_")" + . . S @ROOT@("IMMUN")=CODE + . . S:$L($P(X,U,5)) @ROOT@("SERIES")=$P(X,U,5) + . . S:$L($P(X,U,5)) @ROOT@("REACTION")=$P(X,U,7) + . . S:$L($P(X,U,8)) @ROOT@("CONTRAINDICATED")=$P(X,U,8) + . . S:$L($P(X,U,9)) @ROOT@("REFUSED")=$P(X,U,9) + . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6) + . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="IMMUNIZATION^"_IMM + . . I $E(TYP,4)="-" S @ROOT@("DELETE")=1 + . I $E(TYP,1,2)="SK" D Q + . . Q:'$L(CODE) + . . S SK=SK+1,ROOT="ORPXAPI(""SKIN TEST"","_SK_")" + . . S @ROOT@("TEST")=CODE + . . S:$L($P(X,U,5)) @ROOT@("RESULT")=$P(X,U,5) + . . S:$L($P(X,U,7)) @ROOT@("READING")=$P(X,U,7) + . . S:$L($P(X,U,8)) @ROOT@("D/T READ")=$P(X,U,8) + . . S:$L($P(X,U,9)) @ROOT@("EVENT D/T")=$P(X,U,9) + . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6) + . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="SKIN TEST^"_SK + . . I $E(TYP,3)="-" S @ROOT@("DELETE")=1 + . I $E(TYP,1,3)="PED" D Q + . . Q:'$L(CODE) + . . S PED=PED+1,ROOT="ORPXAPI(""PATIENT ED"","_PED_")" + . . S @ROOT@("TOPIC")=CODE + . . S:$L($P(X,U,5)) @ROOT@("UNDERSTANDING")=$P(X,U,5) + . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6) + . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="PATIENT ED^"_PED + . . I $E(TYP,4)="-" S @ROOT@("DELETE")=1 + . I $E(TYP,1,2)="HF" D Q + . . Q:'$L(CODE) + . . S HF=HF+1,ROOT="ORPXAPI(""HEALTH FACTOR"","_HF_")" + . . S @ROOT@("HEALTH FACTOR")=CODE + . . S:$L($P(X,U,5)) @ROOT@("LEVEL/SEVERITY")=$P(X,U,5) + . . S:$P(X,U,6)'>0 $P(X,U,6)=$G(ORPXAPI("PROVIDER",1,"NAME")) + . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6) + . . S:$L($P(X,U,11)) @ROOT@("EVENT D/T")=$P($P(X,U,11),";",1) + . . S:$L($P(X,U,11)) SRC=$P($P(X,U,11),";",2) + . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="HEALTH FACTOR^"_HF + . . I $E(TYP,3)="-" S @ROOT@("DELETE")=1 + . I $E(TYP,1,3)="XAM" D Q + . . Q:'$L(CODE) + . . S XAM=XAM+1,ROOT="ORPXAPI(""EXAM"","_XAM_")" + . . S @ROOT@("EXAM")=CODE + . . S:$L($P(X,U,5)) @ROOT@("RESULT")=$P(X,U,5) + . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6) + . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="EXAM^"_XAM + . . I $E(TYP,4)="-" S @ROOT@("DELETE")=1 + . I $E(TYP,1,3)="TRT" D Q + . . Q:'$L(CODE) + . . S TRT=TRT+1,ROOT="ORPXAPI(""TREATMENT"","_TRT_")" + . . S @ROOT@("IMMUN")=CODE + . . S:$L(CAT) @ROOT@("CATEGORY")=CAT + . . S:$L(NARR) @ROOT@("NARRATIVE")=NARR + . . S:$L($P(X,U,5)) @ROOT@("QTY")=$P(X,U,5) + . . S:$P(X,U,6)>0 @ROOT@("ENC PROVIDER")=$P(X,U,6) + . . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="TREATMENT^"_TRT + . . I $E(TYP,4)="-" S @ROOT@("DELETE")=1,@ROOT@("QTY")=0 + . I $E(TYP,1,3)="COM" D Q + . . Q:'$L(CODE) + . . Q:'$L(CAT) + . . S COMMENTS(CODE)=$P(X,U,3,999) + ;Store the comments + S COM="" + F S COM=$O(COMMENT(COM)) Q:COM="" S:$D(COMMENTS(COM)) ORPXAPI($P(COMMENT(COM),"^",1),$P(COMMENT(COM),"^",2),"COMMENT")=COMMENTS(COM) + ; + ;Remove any problems to add that the patient already has as active problems + I $D(PROBLEMS),$D(DFN) D + . N ORWPROB,ORPROBIX + . K ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS") + . D DSELECT^GMPLENFM ;DBIA 1365 + . S ORPROBIX=0 + . F S ORPROBIX=$O(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORPROBIX)) Q:'ORPROBIX D ;DBIA 1365 + .. S ORWPROB=$P(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORPROBIX),"^",2,3) + .. S ORWPROB($S($E(ORWPROB,1)="$":$E(ORWPROB,2,255),1:ORWPROB))="" + . K ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS") + . Q:'$D(ORWPROB) + . S ORPROBIX="" + . F S ORPROBIX=$O(PROBLEMS(ORPROBIX)) Q:'ORPROBIX D + .. S:$D(ORWPROB(PROBLEMS(ORPROBIX))) ORPXAPI("DX/PL",ORPROBIX,"PL ADD")=0 + ; + I $$MDS(.ORPXAPI,$G(ORLOC)) S ORPXAPI("ENCOUNTER",1,"CHECKOUT D/T")=$$NOW^XLFDT + S ORPXAPI("ENCOUNTER",1,"ENCOUNTER TYPE")="P" +DATA2PCE ; + I $G(PXAPREDT)!($G(ORCPTDEL)) D + . M ORPXDEL("ENCOUNTER")=ORPXAPI("ENCOUNTER") + . I $G(ORCPTDEL) M ORPXDEL("PROCEDURE",ORCPTDEL)=ORPXAPI("PROCEDURE",ORCPTDEL) + . S OK=$$DATA2PCE^PXAPI("ORPXDEL",PKG,SRC,.ORAVST) + S OK=$$DATA2PCE^PXAPI("ORPXAPI",PKG,SRC,.ORAVST) + I OK>0,+NOTEIEN,+ORAVST D ; NOTEIEN only set on inpatient encounters + .N OROK,ORX + .S ORX(1207)=ORAVST + .D FILE^TIUSRVP(.OROK,NOTEIEN,.ORX,1) + S ZTSTAT=0 ; clear sync flag + Q + ; +MDS(X,ORLOC) ; return TRUE if checkout is needed + I $$CHKOUT^ORWPCE2(ORLOC) Q 1 + N I,ORAUTO,OROK + S (OROK,I)=0 + F S I=$O(X("DX/PL",I)) Q:'I D Q:OROK + . I $G(X("DX/PL",I,"DIAGNOSIS")) S OROK=1 + I 'OROK D + .S I=0 F S I=$O(X("PROCEDURE",I)) Q:'I D Q:OROK + .. I $G(X("PROCEDURE",I,"PROCEDURE")) S OROK=1 + I $D(X("PROVIDER",1,"NAME")) S OROK=1 + Q OROK +NONCOUNT(ORY,ORLOC) ; Is the location a non-count clinic? (DBIA #964) + Q:'ORLOC + S ORY=$S($P($G(^SC(ORLOC,0)),U,17)="Y":1,1:0) + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPCE2.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPCE2.m index 36930488..80bede15 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPCE2.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPCE2.m @@ -1,199 +1,193 @@ -ORWPCE2 ; ISL/JM/RV - wrap calls to PCE ;04/06/2006 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,116,173,195,243**;Dec 17, 1997;Build 242 -GETSET(ORWLST,ORWFILE,ORWFIELD,ORWNULL) ;gets set of codes - ; ORWLST(n)=code^text for code - N ORWPCE,ORWPCEL,ORWPCEC,ORWPCELO,ORWPCEHI,ORWPCECD,ORWPCET - S ORWPCELO="abcdefghijklmnopqrstuvwxyz" - S ORWPCEHI="ABCDEFGHIJKLMNOPQRSTUVWXYZ" - D FIELD^DID(ORWFILE,ORWFIELD,"","POINTER","ORWPCE","ORWPCE") - S ORWPCEL=$L(ORWPCE("POINTER"),";")-1 - F ORWPCEC=1:1:ORWPCEL D - . S ORWPCECD=$P($P(ORWPCE("POINTER"),";",ORWPCEC),":",1) - . S ORWPCET=$P($P(ORWPCE("POINTER"),";",ORWPCEC),":",2) - . S ORWLST(ORWPCEC)=ORWPCECD_"^"_$E(ORWPCET)_$TR($E(ORWPCET,2,99),ORWPCEHI,ORWPCELO) - S:$G(ORWNULL) ORWLST(0)="@^(None selected)" - Q - ; -IMMTYPE(ORWLST,ORDT) ;get the list of active immunizations - N IEN,CNT,BINDEX S (IEN,CNT,BINDEX)=0 - S:'$G(ORDT) ORDT=DT - F S BINDEX=$O(^AUTTIMM("B",BINDEX)) Q:BINDEX']"" F S IEN=$O(^(BINDEX,IEN)) Q:'+IEN D - . I $D(^AUTTIMM(IEN,0))#2,+$P(^(0),"^",7)=0 S CNT=CNT+1,ORWLST(CNT)=IEN_"^"_$P(^(0),"^") - . ;I $D(^AUTTIMM(IEN,0))#2,+$$SCREEN^XTID(9999999.14,,IEN,ORDT)=0 S CNT=CNT+1,ORWLST(CNT)=IEN_"^"_$P(^(0),"^") - Q - ; -SKTYPE(ORWLST,ORDT) ;get the list of active skin test - N IEN,CNT,BINDEX S (IEN,CNT,BINDEX)=0 - S:'$G(ORDT) ORDT=DT - F S BINDEX=$O(^AUTTSK("B",BINDEX)) Q:BINDEX']"" F S IEN=$O(^(BINDEX,IEN)) Q:'+IEN D - . I $D(^AUTTSK(IEN,0))#2,+$P(^(0),"^",3)=0 S CNT=CNT+1,ORWLST(CNT)=IEN_"^"_$P(^(0),"^") - . ;I $D(^AUTTSK(IEN,0))#2,+$$SCREEN^XTID(9999999.28,,IEN,ORDT)=0 S CNT=CNT+1,ORWLST(CNT)=IEN_"^"_$P(^(0),"^") - Q - ; -EDTTYPE(ORWLST) ;get the list of active education topics - N IEN,CNT,BINDEX S (IEN,CNT,BINDEX)=0 - F S BINDEX=$O(^AUTTEDT("B",BINDEX)) Q:BINDEX']"" F S IEN=$O(^(BINDEX,IEN)) Q:'+IEN I $D(^AUTTEDT(IEN,0))#2,+$P(^(0),"^",3)=0 S CNT=CNT+1,ORWLST(CNT)=IEN_"^"_$P(^(0),"^") - Q - ; -HFTYPE(ORWLST,ADDCATS) ;get the list of active health factors - N IEN,CNT,BINDEX,REC - S (IEN,CNT,BINDEX)=0,ADDCATS=+$G(ADDCATS) - F S BINDEX=$O(^AUTTHF("B",BINDEX)) Q:BINDEX']"" D - .F S IEN=$O(^AUTTHF("B",BINDEX,IEN)) Q:'+IEN D - ..S REC=$G(^AUTTHF(IEN,0)) - ..I +$P(REC,U,11) S REC="" - ..I 'ADDCATS,$P(REC,U,10)="C" S REC="" - ..I REC'="" D - ...S CNT=CNT+1,ORWLST(CNT)=IEN_U_$P(REC,U) - ...I ADDCATS S ORWLST(CNT)=ORWLST(CNT)_U_$P(REC,U,10)_U_$P(REC,U,3) - Q - ; -EXAMTYPE(ORWLST) ;get the list of active exams - N IEN,CNT,BINDEX S (IEN,CNT,BINDEX)=0 - F S BINDEX=$O(^AUTTEXAM("B",BINDEX)) Q:BINDEX']"" F S IEN=$O(^(BINDEX,IEN)) Q:'+IEN I $D(^AUTTEXAM(IEN,0))#2,+$P(^(0),"^",4)=0 S CNT=CNT+1,ORWLST(CNT)=IEN_"^"_$P(^(0),"^") - Q - ; -TRTTYPE(ORWLST) ;get the list of active treatments - N IEN,CNT,BINDEX S (IEN,CNT,BINDEX)=0 - F S BINDEX=$O(^AUTTTRT("B",BINDEX)) Q:BINDEX']"" F S IEN=$O(^(BINDEX,IEN)) Q:'+IEN I $D(^AUTTTRT(IEN,0))#2,+$P(^(0),"^",4)=0 S CNT=CNT+1,ORWLST(CNT)=IEN_"^"_$P(^(0),"^") - Q - ; -ACTIVPRV(ORRETURN,ORWPROV,ORWDT) ;get if provider is active or not - S ORRETURN=$$ACTIVPRV^PXAPI(ORWPROV,ORWDT) - Q -GETVISIT(VISIT,IEN,DFN,VSITSTR) ;Get the visit IEN - I +$G(IEN)<1 D I 1 - .S VISIT=$$GETENC^PXAPI(DFN,$P(VSITSTR,";",2),$P(VSITSTR,";")) - E S VISIT=$P(^TIU(8925,IEN,0),U,3) - Q -GAFOK(ORY) ; Returns true if all supporting MH GAF Code exists - S ORY=0 - I $T(GAFHX^YSGAFAPI)'="",$T(ENT^YSGAFAP1)'="" S ORY=1 - Q -MHCLINIC(ORY,ORIEN) ; See if this is a mental health clinic - I $T(MHCLIN^SDUTL2)="" S ORY=1 - E S ORY=$$MHCLIN^SDUTL2(ORIEN) - Q -LOADGAF(ORY,ORINPUT) ; Retrieve GAF scores - D GAFHX^YSGAFAPI(.ORY,.ORINPUT) - Q -SAVEGAF(ORY,ORINPUT) ; Save new GAF score - N ORDATA - D ENT^YSGAFAP1(.ORDATA,.ORINPUT) - S ORY=($G(ORDATA(1))="[DATA]") - Q -FORCE(ORY,USER,LOC) ; Retrieve FORCE GUI PCE Entry for a given User/Location - N SRV,ORTMP,ORERR - S USER=$G(USER,DUZ) - S SRV=$P($G(^VA(200,USER,5)),U) - D GETLST^XPAR(.ORTMP,"USR^LOC.`"_$G(LOC)_"^SRV.`"_+$G(SRV)_"^DIV^SYS^PKG","ORWPCE FORCE PCE ENTRY","Q",.ORERR) - S ORY=+$P($G(ORTMP(1)),U,2) - Q -HASCPT(ORY,ORLIST) ; Returns true if there are any mapped CPT Codes - N IEN,IDX,FOUND - S IDX=0 - F S IDX=$O(ORLIST(IDX)) Q:'+IDX D - . S FOUND=0 - . S IEN=$$FIND1^DIC(811.1,"","QX",ORLIST(IDX)) - . I +IEN S FOUND=+$$GET1^DIQ(811.1,IEN,.05,"I") - . S ORY(IDX)=ORLIST(IDX)_"="_FOUND - Q -ASKPCE(ORY,USER,LOC) ; Returns ORWPCE ASK ENCOUNTER UPDATE parameter value - N SRV,ORTMP,ORERR - S USER=$G(USER,DUZ) - S SRV=$P($G(^VA(200,USER,5)),U) - D GETLST^XPAR(.ORTMP,"USR^LOC.`"_$G(LOC)_"^SRV.`"_+$G(SRV)_"^DIV^SYS^PKG","ORWPCE ASK ENCOUNTER UPDATE","Q",.ORERR) - S ORY=+$P($G(ORTMP(1)),U,2) - Q -GAFURL(URL) ;Returns the MH GAF Web Page URL - S URL="" - I $T(GAFURL^YTAPI5)'="" D - .N ORY - .D GAFURL^YTAPI5(.ORY) - .I $G(ORY(1))="[DATA]" S URL=$G(ORY(2)) - Q -MHTESTOK(ORY) ; Returns True if all supporting MH Test APIs exist - D GAFOK(.ORY) - I +ORY,+$G(DUZ),$T(SAVEIT^YTAPI1)'="",$T(PREVIEW^YTAPI4)'="",$T(SHOWALL^YTAPI3)'="",$T(LISTONE^YTAPI)'="",$T(MHS^PXRMRPCC)'="",$T(MHR^PXRMRPCC)'="",$T(MH^PXRMRPCC)'="" D - . N SRV - . S SRV=$P($G(^VA(200,DUZ,5)),U) - . S ORY=$$GET^XPAR(DUZ_";VA(200,^SRV.`"_+$G(SRV)_"^DIV^SYS","PXRM MENTAL HEALTH ACTIVE",1,"Q") - . I +ORY S ORY=1 - Q -MHATHRZD(ORY,TEST,USER) ;Indicates that user can score test - N ORYS,ORANS - I $T(PRIVL^YTAPI5)="" S ORY=1 Q - S ORY=0 - S ORYS("CODE")=TEST - S ORYS("STAFF")=USER - D PRIVL^YTAPI5(.ORANS,.ORYS) - I $G(ORANS(1))="[DATA]" S ORY=+$P($G(ORANS(2)),U,1) - Q -ANYTIME(ORY) ;Returns status of the ORWPCE ANYTIME ENCOUNTERS parameter - N SRV - S SRV=$P($G(^VA(200,DUZ,5)),U) - S ORY=$$GET^XPAR(DUZ_";VA(200,^SRV.`"_+$G(SRV)_"^DIV^SYS","ORWPCE ANYTIME ENCOUNTERS",1,"Q") - I +ORY S ORY=1 - Q -AUTOVSIT(ORY,LOC) ; Returns TRUE if automatic selection of Visit Type - N SRV - S SRV=$P($G(^VA(200,DUZ,5)),U) - S ORY=$$GET^XPAR(DUZ_";VA(200,^LOC.`"_$G(LOC)_"^SRV.`"_+$G(SRV)_"^DIV^SYS","ORWPCE DISABLE AUTO VISIT TYPE",1,"Q") - I +ORY S ORY=1 - S ORY='ORY - Q -DOCHKOUT(ORY,LOC) ; Returns TRUE if automatic selection of Visit Type - N SRV - S SRV=$P($G(^VA(200,DUZ,5)),U) - S ORY=$$GET^XPAR(DUZ_";VA(200,^LOC.`"_$G(LOC)_"^SRV.`"_+$G(SRV)_"^DIV^SYS","ORWPCE DISABLE AUTO CHECKOUT",1,"Q") - I +ORY S ORY=1 - S ORY='ORY - Q -CHKOUT(LOC) ; Returns TRUE if automatic selection of Visit Type - N ORY - D DOCHKOUT(.ORY,LOC) - Q ORY -EXCLUDED(ORY,LOC,TYPE) ; Returns list of excluded PCE data elements - N SRV,PARAM - S PARAM=$S(TYPE=1:"IMMUNIZATIONS",TYPE=2:"SKIN TESTS",TYPE=3:"PATIENT ED",TYPE=4:"HEALTH FACTORS",TYPE=5:"EXAMS",1:"") - Q:PARAM="" - S SRV=$P($G(^VA(200,DUZ,5)),U) - S PARAM="ORWPCE EXCLUDE "_PARAM - D GETLST^XPAR(.ORY,"USR^LOC.`"_$G(LOC)_"^SRV.`"_+$G(SRV)_"^DIV^SYS^PKG",PARAM,"Q",.ORERR) - Q -ISCLINIC(ORY,ORLOC) ; Returns TRUE if location is a clinic - N ORTYP - S ORY=0 - S ORTYP=$$GET1^DIQ(44,+ORLOC,2,"I") - I (ORTYP="C")!(ORTYP="M") S ORY=1 - Q -HNCOK(ORY) ; Returns true if Head and/or Neck Cancer is enabled - S ORY=0 - I $$PATCH^XPDUTL("DG*5.3*397"),$$PATCH^XPDUTL("SD*5.3*244"),$$PATCH^XPDUTL("PX*1.0*111"),$$PATCH^XPDUTL("IVM*2.0*46") S ORY=1 - Q - ; -CODACTIV(ORY,ORCODE,ORAPP,ORDATE) ; Is code active on the given date? - ; Remote procedure: ORWPCE ACTIVE CODE - ; ORCODE = ICD or CPT code to be checked - ; ORAPP = "ICD" or "CHP" - ; ORDATE = Date to be checked (defaults to current date) - S:'+$G(ORDATE) ORDATE=DT - S ORY=1 - I ORAPP="ICD" D - . S ORY=+$$STATCHK^ICDAPIU(ORCODE,ORDATE) - E I ORAPP="CHP" D - . S ORY=+$$STATCHK^ICPTAPIU(ORCODE,ORDATE) - Q -ICDACTIV(ORCODE,ORDATE) ; Check for active ICD code - D CODACTIV(.ORY,ORCODE,"ICD",$G(ORDATE)) - Q +ORY -CPTACTIV(ORCODE,ORDATE) ; Check for active CPT code - D CODACTIV(.ORY,ORCODE,"CHP",$G(ORDATE)) - Q +ORY -CXNOSHOW(ORY,ORDOCIEN) ; Should workload requirement be skipped for this note's visit? - ; RETURN VALUE: 0=SKIP ALL GUI WORKLOAD REQUIREMENTS - ; 1=CONTINUE WITH OTHER GUI WORKLOAD LOGIC - N ORTIU - D DOCPARM^TIUSRVP1(.ORTIU,ORDOCIEN) ; DBIA #4331 - S ORY=+$$CHKWKL^TIUPXAP2(ORDOCIEN,ORTIU(0)) ; DBIA #4332 - Q +ORWPCE2 ; ISL/JM - wrap calls to PCE ;9/25/2001 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,116,173,195**;Dec 17, 1997 +GETSET(ORWLST,ORWFILE,ORWFIELD,ORWNULL) ;gets set of codes + ; ORWLST(n)=code^text for code + N ORWPCE,ORWPCEL,ORWPCEC,ORWPCELO,ORWPCEHI,ORWPCECD,ORWPCET + S ORWPCELO="abcdefghijklmnopqrstuvwxyz" + S ORWPCEHI="ABCDEFGHIJKLMNOPQRSTUVWXYZ" + D FIELD^DID(ORWFILE,ORWFIELD,"","POINTER","ORWPCE","ORWPCE") + S ORWPCEL=$L(ORWPCE("POINTER"),";")-1 + F ORWPCEC=1:1:ORWPCEL D + . S ORWPCECD=$P($P(ORWPCE("POINTER"),";",ORWPCEC),":",1) + . S ORWPCET=$P($P(ORWPCE("POINTER"),";",ORWPCEC),":",2) + . S ORWLST(ORWPCEC)=ORWPCECD_"^"_$E(ORWPCET)_$TR($E(ORWPCET,2,99),ORWPCEHI,ORWPCELO) + S:$G(ORWNULL) ORWLST(0)="@^(None selected)" + Q + ; +IMMTYPE(ORWLST) ;get the list of active immunizations + N IEN,CNT,BINDEX S (IEN,CNT,BINDEX)=0 + F S BINDEX=$O(^AUTTIMM("B",BINDEX)) Q:BINDEX']"" F S IEN=$O(^(BINDEX,IEN)) Q:'+IEN I $D(^AUTTIMM(IEN,0))#2,+$P(^(0),"^",7)=0 S CNT=CNT+1,ORWLST(CNT)=IEN_"^"_$P(^(0),"^") + Q + ; +SKTYPE(ORWLST) ;get the list of active skin test + N IEN,CNT,BINDEX S (IEN,CNT,BINDEX)=0 + F S BINDEX=$O(^AUTTSK("B",BINDEX)) Q:BINDEX']"" F S IEN=$O(^(BINDEX,IEN)) Q:'+IEN I $D(^AUTTSK(IEN,0))#2,+$P(^(0),"^",3)=0 S CNT=CNT+1,ORWLST(CNT)=IEN_"^"_$P(^(0),"^") + Q + ; +EDTTYPE(ORWLST) ;get the list of active education topics + N IEN,CNT,BINDEX S (IEN,CNT,BINDEX)=0 + F S BINDEX=$O(^AUTTEDT("B",BINDEX)) Q:BINDEX']"" F S IEN=$O(^(BINDEX,IEN)) Q:'+IEN I $D(^AUTTEDT(IEN,0))#2,+$P(^(0),"^",3)=0 S CNT=CNT+1,ORWLST(CNT)=IEN_"^"_$P(^(0),"^") + Q + ; +HFTYPE(ORWLST,ADDCATS) ;get the list of active health factors + N IEN,CNT,BINDEX,REC + S (IEN,CNT,BINDEX)=0,ADDCATS=+$G(ADDCATS) + F S BINDEX=$O(^AUTTHF("B",BINDEX)) Q:BINDEX']"" D + .F S IEN=$O(^AUTTHF("B",BINDEX,IEN)) Q:'+IEN D + ..S REC=$G(^AUTTHF(IEN,0)) + ..I +$P(REC,U,11) S REC="" + ..I 'ADDCATS,$P(REC,U,10)="C" S REC="" + ..I REC'="" D + ...S CNT=CNT+1,ORWLST(CNT)=IEN_U_$P(REC,U) + ...I ADDCATS S ORWLST(CNT)=ORWLST(CNT)_U_$P(REC,U,10)_U_$P(REC,U,3) + Q + ; +EXAMTYPE(ORWLST) ;get the list of active exams + N IEN,CNT,BINDEX S (IEN,CNT,BINDEX)=0 + F S BINDEX=$O(^AUTTEXAM("B",BINDEX)) Q:BINDEX']"" F S IEN=$O(^(BINDEX,IEN)) Q:'+IEN I $D(^AUTTEXAM(IEN,0))#2,+$P(^(0),"^",4)=0 S CNT=CNT+1,ORWLST(CNT)=IEN_"^"_$P(^(0),"^") + Q + ; +TRTTYPE(ORWLST) ;get the list of active treatments + N IEN,CNT,BINDEX S (IEN,CNT,BINDEX)=0 + F S BINDEX=$O(^AUTTTRT("B",BINDEX)) Q:BINDEX']"" F S IEN=$O(^(BINDEX,IEN)) Q:'+IEN I $D(^AUTTTRT(IEN,0))#2,+$P(^(0),"^",4)=0 S CNT=CNT+1,ORWLST(CNT)=IEN_"^"_$P(^(0),"^") + Q + ; +ACTIVPRV(ORRETURN,ORWPROV,ORWDT) ;get if provider is active or not + S ORRETURN=$$ACTIVPRV^PXAPI(ORWPROV,ORWDT) + Q +GETVISIT(VISIT,IEN,DFN,VSITSTR) ;Get the visit IEN + I +$G(IEN)<1 D I 1 + .S VISIT=$$GETENC^PXAPI(DFN,$P(VSITSTR,";",2),$P(VSITSTR,";")) + E S VISIT=$P(^TIU(8925,IEN,0),U,3) + Q +GAFOK(ORY) ; Returns true if all supporting MH GAF Code exists + S ORY=0 + I $T(GAFHX^YSGAFAPI)'="",$T(ENT^YSGAFAP1)'="" S ORY=1 + Q +MHCLINIC(ORY,ORIEN) ; See if this is a mental health clinic + I $T(MHCLIN^SDUTL2)="" S ORY=1 + E S ORY=$$MHCLIN^SDUTL2(ORIEN) + Q +LOADGAF(ORY,ORINPUT) ; Retrieve GAF scores + D GAFHX^YSGAFAPI(.ORY,.ORINPUT) + Q +SAVEGAF(ORY,ORINPUT) ; Save new GAF score + N ORDATA + D ENT^YSGAFAP1(.ORDATA,.ORINPUT) + S ORY=($G(ORDATA(1))="[DATA]") + Q +FORCE(ORY,USER,LOC) ; Retrieve FORCE GUI PCE Entry for a given User/Location + N SRV,ORTMP,ORERR + S USER=$G(USER,DUZ) + S SRV=$P($G(^VA(200,USER,5)),U) + D GETLST^XPAR(.ORTMP,"USR^LOC.`"_$G(LOC)_"^SRV.`"_+$G(SRV)_"^DIV^SYS^PKG","ORWPCE FORCE PCE ENTRY","Q",.ORERR) + S ORY=+$P($G(ORTMP(1)),U,2) + Q +HASCPT(ORY,ORLIST) ; Returns true if there are any mapped CPT Codes + N IEN,IDX,FOUND + S IDX=0 + F S IDX=$O(ORLIST(IDX)) Q:'+IDX D + . S FOUND=0 + . S IEN=$$FIND1^DIC(811.1,"","QX",ORLIST(IDX)) + . I +IEN S FOUND=+$$GET1^DIQ(811.1,IEN,.05,"I") + . S ORY(IDX)=ORLIST(IDX)_"="_FOUND + Q +ASKPCE(ORY,USER,LOC) ; Returns ORWPCE ASK ENCOUNTER UPDATE parameter value + N SRV,ORTMP,ORERR + S USER=$G(USER,DUZ) + S SRV=$P($G(^VA(200,USER,5)),U) + D GETLST^XPAR(.ORTMP,"USR^LOC.`"_$G(LOC)_"^SRV.`"_+$G(SRV)_"^DIV^SYS^PKG","ORWPCE ASK ENCOUNTER UPDATE","Q",.ORERR) + S ORY=+$P($G(ORTMP(1)),U,2) + Q +GAFURL(URL) ;Returns the MH GAF Web Page URL + S URL="" + I $T(GAFURL^YTAPI5)'="" D + .N ORY + .D GAFURL^YTAPI5(.ORY) + .I $G(ORY(1))="[DATA]" S URL=$G(ORY(2)) + Q +MHTESTOK(ORY) ; Returns True if all supporting MH Test APIs exist + D GAFOK(.ORY) + I +ORY,+$G(DUZ),$T(SAVEIT^YTAPI1)'="",$T(PREVIEW^YTAPI4)'="",$T(SHOWALL^YTAPI3)'="",$T(LISTONE^YTAPI)'="",$T(MHS^PXRMRPCC)'="",$T(MHR^PXRMRPCC)'="",$T(MH^PXRMRPCC)'="" D + . N SRV + . S SRV=$P($G(^VA(200,DUZ,5)),U) + . S ORY=$$GET^XPAR(DUZ_";VA(200,^SRV.`"_+$G(SRV)_"^DIV^SYS","PXRM MENTAL HEALTH ACTIVE",1,"Q") + . I +ORY S ORY=1 + Q +MHATHRZD(ORY,TEST,USER) ;Indicates that user can score test + N ORYS,ORANS + I $T(PRIVL^YTAPI5)="" S ORY=1 Q + S ORY=0 + S ORYS("CODE")=TEST + S ORYS("STAFF")=USER + D PRIVL^YTAPI5(.ORANS,.ORYS) + I $G(ORANS(1))="[DATA]" S ORY=+$P($G(ORANS(2)),U,1) + Q +ANYTIME(ORY) ;Returns status of the ORWPCE ANYTIME ENCOUNTERS parameter + N SRV + S SRV=$P($G(^VA(200,DUZ,5)),U) + S ORY=$$GET^XPAR(DUZ_";VA(200,^SRV.`"_+$G(SRV)_"^DIV^SYS","ORWPCE ANYTIME ENCOUNTERS",1,"Q") + I +ORY S ORY=1 + Q +AUTOVSIT(ORY,LOC) ; Returns TRUE if automatic selection of Visit Type + N SRV + S SRV=$P($G(^VA(200,DUZ,5)),U) + S ORY=$$GET^XPAR(DUZ_";VA(200,^LOC.`"_$G(LOC)_"^SRV.`"_+$G(SRV)_"^DIV^SYS","ORWPCE DISABLE AUTO VISIT TYPE",1,"Q") + I +ORY S ORY=1 + S ORY='ORY + Q +DOCHKOUT(ORY,LOC) ; Returns TRUE if automatic selection of Visit Type + N SRV + S SRV=$P($G(^VA(200,DUZ,5)),U) + S ORY=$$GET^XPAR(DUZ_";VA(200,^LOC.`"_$G(LOC)_"^SRV.`"_+$G(SRV)_"^DIV^SYS","ORWPCE DISABLE AUTO CHECKOUT",1,"Q") + I +ORY S ORY=1 + S ORY='ORY + Q +CHKOUT(LOC) ; Returns TRUE if automatic selection of Visit Type + N ORY + D DOCHKOUT(.ORY,LOC) + Q ORY +EXCLUDED(ORY,LOC,TYPE) ; Returns list of excluded PCE data elements + N SRV,PARAM + S PARAM=$S(TYPE=1:"IMMUNIZATIONS",TYPE=2:"SKIN TESTS",TYPE=3:"PATIENT ED",TYPE=4:"HEALTH FACTORS",TYPE=5:"EXAMS",1:"") + Q:PARAM="" + S SRV=$P($G(^VA(200,DUZ,5)),U) + S PARAM="ORWPCE EXCLUDE "_PARAM + D GETLST^XPAR(.ORY,"USR^LOC.`"_$G(LOC)_"^SRV.`"_+$G(SRV)_"^DIV^SYS^PKG",PARAM,"Q",.ORERR) + Q +ISCLINIC(ORY,ORLOC) ; Returns TRUE if location is a clinic + N ORTYP + S ORY=0 + S ORTYP=$$GET1^DIQ(44,+ORLOC,2,"I") + I (ORTYP="C")!(ORTYP="M") S ORY=1 + Q +HNCOK(ORY) ; Returns true if Head and/or Neck Cancer is enabled + S ORY=0 + I $$PATCH^XPDUTL("DG*5.3*397"),$$PATCH^XPDUTL("SD*5.3*244"),$$PATCH^XPDUTL("PX*1.0*111"),$$PATCH^XPDUTL("IVM*2.0*46") S ORY=1 + Q + ; +CODACTIV(ORY,ORCODE,ORAPP,ORDATE) ; Is code active on the given date? + ; Remote procedure: ORWPCE ACTIVE CODE + ; ORCODE = ICD or CPT code to be checked + ; ORAPP = "ICD" or "CHP" + ; ORDATE = Date to be checked (defaults to current date) + S:'+$G(ORDATE) ORDATE=DT + S ORY=1 + I ORAPP="ICD" D + . S ORY=+$$STATCHK^ICDAPIU(ORCODE,ORDATE) + E I ORAPP="CHP" D + . S ORY=+$$STATCHK^ICPTAPIU(ORCODE,ORDATE) + Q +ICDACTIV(ORCODE,ORDATE) ; Check for active ICD code + D CODACTIV(.ORY,ORCODE,"ICD",$G(ORDATE)) + Q +ORY +CPTACTIV(ORCODE,ORDATE) ; Check for active CPT code + D CODACTIV(.ORY,ORCODE,"CHP",$G(ORDATE)) + Q +ORY +CXNOSHOW(ORY,ORDOCIEN) ; Should workload requirement be skipped for this note's visit? + ; RETURN VALUE: 0=SKIP ALL GUI WORKLOAD REQUIREMENTS + ; 1=CONTINUE WITH OTHER GUI WORKLOAD LOGIC + N ORTIU + D DOCPARM^TIUSRVP1(.ORTIU,ORDOCIEN) ; DBIA #4331 + S ORY=+$$CHKWKL^TIUPXAP2(ORDOCIEN,ORTIU(0)) ; DBIA #4332 + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPS.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPS.m index 90451638..2918461c 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPS.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPS.m @@ -1,211 +1,192 @@ -ORWPS ; SLC/KCM/JLI/REV/CLA - Meds Tab; 02/11/2008 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,132,141,173,203,190,195,265,275,243**;Dec 17, 1997;Build 242 - ;;Per VHA Directive 2004-038, this routine should not be modified. -COVER(LST,DFN) ; retrieve meds for cover sheet - K ^TMP("PS",$J) - D OCL^PSOORRL(DFN,"","") - N ILST,ITMP,X S ILST=0 - S ITMP="" F S ITMP=$O(^TMP("PS",$J,ITMP)) Q:'ITMP D - . S X=^TMP("PS",$J,ITMP,0) - . I '$L($P(X,U,2)) S X="??" ; show something if drug empty - . I $D(^TMP("PS",$J,ITMP,"CLINIC",0)) S LST($$NXT)=$P(X,U,1,2)_U_$P(X,U,8,9)_U_"C" - . E S LST($$NXT)=$P(X,U,1,2)_U_$P(X,U,8,9) - K ^TMP("PS",$J) - Q -DT(X) ; -- Returns FM date for X - N Y,%DT S %DT="T",Y="" D:X'="" ^%DT - Q Y - ; -ACTIVE(LST,DFN,USER,VIEW,UPDATE) ; retrieve active inpatient & outpatient meds - K ^TMP("PS",$J) - K ^TMP("ORACT",$J) - N BEG,END,ERROR,CTX,STVIEW - S (BEG,END,CTX)="" - S VIEW=+$G(VIEW) - S UPDATE=+$G(UPDATE) - I VIEW=0,UPDATE=0 S VIEW=1 - S CTX=$$GET^XPAR("ALL","ORCH CONTEXT MEDS") - I CTX=";" D DEL^XPAR("USR.`"_DUZ,"ORCH CONTEXT MEDS") - S CTX=$$GET^XPAR("ALL","ORCH CONTEXT MEDS") - S BEG=$$DT($P(CTX,";")),END=$$DT($P(CTX,";",2)) - I +$G(USER)=0 S USER=DUZ - I UPDATE=1 D - .S STVIEW=$$GET^XPAR($G(USER)_";VA(200,","OR MEDS TAB SORT",1,"I") - .I VIEW>0,+STVIEW'=VIEW D PUT^XPAR(DUZ_";VA(200,","OR MEDS TAB SORT",,VIEW,.ERROR) S STVIEW=VIEW - .I VIEW=0,+STVIEW=0 D PUT^XPAR(DUZ_";VA(200,","OR MEDS TAB SORT",,"1",.ERROR) S STVIEW=1,VIEW=1 - .I VIEW=0,+STVIEW'=VIEW S VIEW=+STVIEW - .S LST(0)=STVIEW - D OCL^PSOORRL(DFN,BEG,END,VIEW) - N ITMP,FIELDS,INSTRUCT,COMMENTS,REASON,NVSDT,TYPE,ILST,J S ILST=0 - S ITMP="" F S ITMP=$O(^TMP("PS",$J,ITMP)) Q:'ITMP D - . K INSTRUCT,COMMENTS,REASON - . K ^TMP("ORACT",$J,"COMMENTS") - . S COMMENTS="^TMP(""ORACT"",$J,""COMMENTS"")" - . S (INSTRUCT,@COMMENTS)="",FIELDS=^TMP("PS",$J,ITMP,0) - . I +$P(FIELDS,"^",8),$D(^OR(100,+$P(FIELDS,"^",8),8,"C","XX")) D - . . S $P(^TMP("PS",$J,ITMP,0),"^",2)="*"_$P(^TMP("PS",$J,ITMP,0),"^",2) ;dan testing - . S TYPE=$S($P($P(FIELDS,U),";",2)="O":"OP",1:"UD") - . I $D(^TMP("PS",$J,ITMP,"CLINIC",0)) S TYPE="CP" - . N LOC,LOCEX S (LOC,LOCEX)="" - . I TYPE="CP" S LOC=$G(^TMP("PS",$J,ITMP,"CLINIC",0)) - . S:LOC LOCEX=$P($G(^SC(+LOC,0)),U)_":"_+LOC ;IMO NEW - . I TYPE="OP",$P(FIELDS,";")["N" S TYPE="NV" ;non-VA med - . I $O(^TMP("PS",$J,ITMP,"A",0))>0 S TYPE="IV" - . I $O(^TMP("PS",$J,ITMP,"B",0))>0 S TYPE="IV" - . I (TYPE="UD")!(TYPE="CP") D UDINST(.INSTRUCT,ITMP) - . I TYPE="OP" D OPINST(.INSTRUCT,ITMP) - . I TYPE="IV" D IVINST(.INSTRUCT,ITMP) - . I TYPE="NV" D NVINST(.INSTRUCT,ITMP),NVREASON(.REASON,.NVSDT,ITMP) - . I (TYPE="UD")!(TYPE="IV")!(TYPE="NV")!(TYPE="CP") D SETMULT(COMMENTS,ITMP,"SIO") - . M COMMENTS=@COMMENTS - . I $D(COMMENTS(1)) S COMMENTS(1)="\"_COMMENTS(1) - . S:TYPE="NV" $P(FIELDS,U,4)=$G(NVSDT) - . I LOC S LST($$NXT)="~CP:"_LOCEX_U_FIELDS - . E S LST($$NXT)="~"_TYPE_U_FIELDS - . S J=0 F S J=$O(INSTRUCT(J)) Q:'J S LST($$NXT)=INSTRUCT(J) - . S J=0 F S J=$O(COMMENTS(J)) Q:'J S LST($$NXT)="t"_COMMENTS(J) - . S J=0 F S J=$O(REASON(J)) Q:'J S LST($$NXT)="t"_REASON(J) - K ^TMP("PS",$J) - K ^TMP("ORACT",$J) - Q -NXT() ; increment ILST - S ILST=ILST+1 - Q ILST - ; -UDINST(Y,INDEX) ; assembles instructions for a unit dose order - N I,X,RST - S X=^TMP("PS",$J,INDEX,0) - S RST="^TMP(""ORACT"",$J,""INSTRUCT"")" - S @RST@(1)=" "_$P(X,U,2),@RST=1 - S X=$S($L($P(X,U,6)):$P(X,U,6),1:$P(X,U,7)) - I $L(X) S @RST=2,@RST@(2)=X - E S @RST=1 D SETMULT(.RST,INDEX,"SIG") - S @RST@(2)="\Give: "_$G(@RST@(2)),@RST=$G(@RST,2) - D SETMULT(RST,INDEX,"MDR"),SETMULT(RST,INDEX,"SCH") - F I=3:1:@RST S @RST@(I)=" "_@RST@(I) - M Y=@RST K @RST - Q -OPINST(Y,INDEX) ; assembles instructions for an outpatient prescription - N I,X,RST - S X=^TMP("PS",$J,INDEX,0) - S RST="^TMP(""ORACT"",$J,""INSTRUCT"")" - S @RST@(1)=" "_$P(X,U,2),@RST=1 - I $L($P(X,U,12)) S @RST@(1)=@RST@(1)_" Qty: "_$P(X,U,12) - I $L($P(X,U,11)) S @RST@(1)=@RST@(1)_" for "_$P(X,U,11)_" days" - D SETMULT(RST,INDEX,"SIG") - I @RST=1 D - . D SETMULT(RST,INDEX,"SIO") - . D SETMULT(RST,INDEX,"MDR") - . D SETMULT(RST,INDEX,"SCH") - S @RST@(2)="\ Sig: "_$G(@RST@(2)) - F I=3:1:@RST S @RST@(I)=" "_@RST@(I) - M Y=@RST K @RST - Q -IVINST(Y,INDEX) ; assembles instructions for an IV order - N SOLN1,I,RST,IVDUR,CNT - S IVDUR="" - S RST="^TMP(""ORACT"",$J,""INSTRUCT"")" - S @RST=0 D SETMULT(RST,INDEX,"A") S SOLN1=@RST+1 - D SETMULT(RST,INDEX,"B") - I $D(@RST@(SOLN1)),$L($P(FIELDS,U,2)) S @RST@(SOLN1)="in "_@RST@(SOLN1) - S SOLN1=@RST+1 - S CNT=@RST - D SETMULT(RST,INDEX,"MDR") - I $D(^TMP("PS",$J,INDEX,"SCH",1,0)) S @RST@(@RST)=@RST@(@RST)_" "_^TMP("PS",$J,INDEX,"SCH",1,0) - F I=1:1:@RST S @RST@(I)="\"_$TR(@RST@(I),U," ") - I $D(@RST@(1)) S @RST@(1)=" "_$E(@RST@(1),2,999) - S @RST@(@RST)=@RST@(@RST)_" "_$P(^TMP("PS",$J,INDEX,0),U,3) - S:$D(^TMP("PS",$J,INDEX,"IVLIM",0)) IVDUR=$G(^TMP("PS",$J,INDEX,"IVLIM",0)) - I $L(IVDUR) D - . N DURU,DURV S DURU="",DURV=0 - . I IVDUR["dose" D Q - . .S DURV=$P(IVDUR,"doses",2) - . .S IVDUR="for a total of "_+DURV_$S(+DURV=1:"dose",+DURV>1:" doses",1:" dose") - . .S @RST@(@RST)=@RST@(@RST)_" "_IVDUR - . S DURU=$E(IVDUR,1),DURV=$E(IVDUR,2,$L(IVDUR)) - . I (DURU="D")!(DURU="d") S IVDUR="for "_+DURV_$S(+DURV=1:" day",+DURV>1:" days",1:" day") - . I (DURU="H")!(DURU="h") S IVDUR="for "_+DURV_$S(+DURV=1:" hours",+DURV>1:" hours",1:" hour") - . I (DURU="M")!(DURU="m") S IVDUR="with total volume "_+DURV_" ml" - . I (DURU="L")!(DURU="l") S IVDUR="with total volume "_+DURV_" L" - . S @RST@(@RST)=@RST@(@RST)_" "_IVDUR - M Y=@RST K @RST - Q -NVINST(Y,INDEX) ; assembles instructions for a non-VA med - N I,X,RST - S X=^TMP("PS",$J,INDEX,0) - S RST="^TMP(""ORACT"",$J,""INSTRUCT"")" - S @RST@(1)=" "_$P(X,U,2),@RST=1 - D SETMULT(RST,INDEX,"SIG") - I @RST=1 D - . D SETMULT(RST,INDEX,"SIO") - . D SETMULT(RST,INDEX,"MDR") - . D SETMULT(RST,INDEX,"SCH") - S @RST@(2)="\ "_$G(@RST@(2)) - F I=3:1:@RST S @RST@(I)=" "_@RST@(I) - M Y=@RST K @RST - Q -NVREASON(ORR,NVSDT,INDEX) ; assembles start date and reasons for a non-VA med - N ORI,J,X,ORN,ORA - S ORI=0 K ORR - S X=^TMP("PS",$J,INDEX,0) - S ORN=+$P(X,U,8) - I $D(^OR(100,ORN,0)) D - .S NVSDT=$P(^OR(100,ORN,0),U,8) - .D WPVAL^ORWDXR(.ORA,ORN,"STATEMENTS") I $D(ORA) D - ..S J=0 F S J=$O(ORA(J)) Q:J<1 S ORI=ORI+1,ORR(ORI)=ORA(J) - Q -SETMULT(Y,INDEX,SUB) ; appends the multiple at the subscript to Y - N I,X,J - S J=$G(@Y) - S I=0 F S I=$O(^TMP("PS",$J,INDEX,SUB,I)) Q:'I S X=$G(^(I,0)) D - . I SUB="B",$L($P(X,U,3)) S X=$P(X,U)_" "_$P(X,U,3)_"^"_$P(X,U,2) - . S J=J+1,@Y@(J)=X - S @Y=J - Q -COMPRESS(Y) ; concatenate Y subscripts into smallest possible number - N I,J,X S J=1,X(J)="" - S I=0 F S I=$O(Y(I)) Q:'I D - . I ($L(Y(I))+$L(X(J)))>245 S J=J+1,X(J)="" - . S X(J)=X(J)_$S($L(X(J)):" ",1:"")_Y(I) - K Y M Y=X - Q -DETAIL(ROOT,DFN,ID) ; -- show details for a med order - K ^TMP("ORXPND",$J) - N LCNT,ORVP - S LCNT=0,ORVP=DFN_";DPT(" - D MEDS^ORCXPND1 - S ROOT=$NA(^TMP("ORXPND",$J)) - Q -MEDHIST(ORROOT,DFN,ORIFN) ; -- show admin history for a med (RV) - N ORPSID,HPIV,ISIV,CKPKG,ORPHMID - N CLINDISP,IVDIAL - S ORPSID=+$P($$OI^ORX8(ORIFN),U,3),ISIV=0,HPIV=0 - S ORROOT=$NA(^TMP("ORHIST",$J)) K @ORROOT - S ORPHMID=$G(^OR(100,+ORIFN,4)) ;Pharmacy order number - S ISIV=$O(^ORD(100.98,"B","IV RX",ISIV)) - S HPIV=$O(^ORD(100.98,"B","TPN",HPIV)) - S CLINDISP=$O(^ORD(100.98,"B","C RX","")) - S IVDIAL=$O(^ORD(101.41,"B","PSJI OR PAT FLUID OE","")) - S CKPKG=$$PATCH^XPDUTL("PSB*2.0*19") - ;if the order is pending or the order has no pharmacy # - ;or the order is not in the Display Group IV MEDICATION - ; then use the Orderable item number to get the MAH. - I (ORPHMID["P")!(ORPHMID="") D Q - . I '$L($T(HISTORY^PSBMLHS)) D Q - . . S @ORROOT@(0)="This report is only available using BCMA version 2.0." - . D HISTORY^PSBMLHS(.ORROOT,DFN,ORPSID) ; DBIA #3459 for BCMA v2.0 - ; If the order has a Display Group of IV MEDICATION the use the Pharmacy order number to get the MA - I ($P($G(^OR(100,+ORIFN,0)),U,11)=ISIV)!($P($G(^OR(100,+ORIFN,0)),U,11)=HPIV)!(($P($G(^OR(100,+ORIFN,0)),U,11)=CLINDISP)&(+$P($G(^OR(100,+ORIFN,0)),U,5)=IVDIAL)) D Q - . I 'CKPKG S @ORROOT@(0)="Medication Administration History is not available at this time for IV fluids." - . I CKPKG D - . . D RPC^PSBO(.ORROOT,"PM",DFN,"","","","","","","","","",ORPHMID) ;DBIA #3955 - . . I '$D(@ORROOT) S @ORROOT@(0)="No Medication Administration History found for the IV order." - I '$L($T(HISTORY^PSBMLHS)) D Q - . S @ORROOT@(0)="This report is only available using BCMA version 2.0." - D HISTORY^PSBMLHS(.ORROOT,DFN,ORPSID) ; DBIA #3459 for BCMA v2.0 - Q - ; -REASON(ORY) ; -- Return Non-VA Med Statement/Reasons - N ORE - D GETLST^XPAR(.ORY,"ALL","ORWD NONVA REASON","E") - Q +ORWPS ; SLC/KCM/JLI/REV/CLA - Meds Tab; 05/22/03 ; 5/18/07 10:18am + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,132,141,173,203,190,195,265,275**;Dec 17, 1997;Build 7 + ;;Per VHA Directive 2004-038, this routine should not be modified. +COVER(LST,DFN) ; retrieve meds for cover sheet + K ^TMP("PS",$J) + D OCL^PSOORRL(DFN,"","") ;DBIA #2400 + N ILST,ITMP,X S ILST=0 + S ITMP="" F S ITMP=$O(^TMP("PS",$J,ITMP)) Q:'ITMP D + . S X=^TMP("PS",$J,ITMP,0) + . I '$L($P(X,U,2)) S X="??" ; show something if drug empty + . I $D(^TMP("PS",$J,ITMP,"CLINIC",0)) S LST($$NXT)=$P(X,U,1,2)_U_$P(X,U,8,9)_U_"C" + . E S LST($$NXT)=$P(X,U,1,2)_U_$P(X,U,8,9) + K ^TMP("PS",$J) + Q +DT(X) ; -- Returns FM date for X + N Y,%DT S %DT="T",Y="" D:X'="" ^%DT + Q Y + ; +ACTIVE(LST,DFN) ; retrieve active inpatient & outpatient meds + K ^TMP("PS",$J) + K ^TMP("ORACT",$J) + N BEG,END,CTX + S (BEG,END,CTX)="" + S CTX=$$GET^XPAR("ALL","ORCH CONTEXT MEDS") + I CTX=";" D DEL^XPAR("USR.`"_DUZ,"ORCH CONTEXT MEDS") + S CTX=$$GET^XPAR("ALL","ORCH CONTEXT MEDS") + S BEG=$$DT($P(CTX,";")),END=$$DT($P(CTX,";",2)) + D OCL^PSOORRL(DFN,BEG,END) ;DBIA #2400 + N ITMP,FIELDS,INSTRUCT,COMMENTS,REASON,NVSDT,TYPE,ILST,J S ILST=0 + S ITMP="" F S ITMP=$O(^TMP("PS",$J,ITMP),-1) Q:'ITMP D + . K INSTRUCT,COMMENTS,REASON + . K ^TMP("ORACT",$J,"COMMENTS") + . S COMMENTS="^TMP(""ORACT"",$J,""COMMENTS"")" + . S (INSTRUCT,@COMMENTS)="",FIELDS=^TMP("PS",$J,ITMP,0) + . I +$P(FIELDS,"^",8),$D(^OR(100,+$P(FIELDS,"^",8),8,"C","XX")) D + . . S $P(^TMP("PS",$J,ITMP,0),"^",2)="*"_$P(^TMP("PS",$J,ITMP,0),"^",2) ;dan testing + . S TYPE=$S($P($P(FIELDS,U),";",2)="O":"OP",1:"UD") + . I $D(^TMP("PS",$J,ITMP,"CLINIC",0)) S TYPE="CP" + . N LOC,LOCEX S (LOC,LOCEX)="" + . I TYPE="CP" S LOC=$G(^TMP("PS",$J,ITMP,"CLINIC",0)) + . S:LOC LOCEX=$P($G(^SC(+LOC,0)),U)_":"_+LOC ;IMO NEW DBIA #964 + . I TYPE="OP",$P(FIELDS,";")["N" S TYPE="NV" ;non-VA med + . I $O(^TMP("PS",$J,ITMP,"A",0))>0 S TYPE="IV" + . I $O(^TMP("PS",$J,ITMP,"B",0))>0 S TYPE="IV" + . I (TYPE="UD")!(TYPE="CP") D UDINST(.INSTRUCT,ITMP) + . I TYPE="OP" D OPINST(.INSTRUCT,ITMP) + . I TYPE="IV" D IVINST(.INSTRUCT,ITMP) + . I TYPE="NV" D NVINST(.INSTRUCT,ITMP),NVREASON(.REASON,.NVSDT,ITMP) + . I (TYPE="UD")!(TYPE="IV")!(TYPE="NV")!(TYPE="CP") D SETMULT(COMMENTS,ITMP,"SIO") + . M COMMENTS=@COMMENTS + . I $D(COMMENTS(1)) S COMMENTS(1)="\"_COMMENTS(1) + . S:TYPE="NV" $P(FIELDS,U,4)=$G(NVSDT) + . I LOC S LST($$NXT)="~CP:"_LOCEX_U_FIELDS + . E S LST($$NXT)="~"_TYPE_U_FIELDS + . S J=0 F S J=$O(INSTRUCT(J)) Q:'J S LST($$NXT)=INSTRUCT(J) + . S J=0 F S J=$O(COMMENTS(J)) Q:'J S LST($$NXT)="t"_COMMENTS(J) + . S J=0 F S J=$O(REASON(J)) Q:'J S LST($$NXT)="t"_REASON(J) + K ^TMP("PS",$J) + K ^TMP("ORACT",$J) + Q +NXT() ; increment ILST + S ILST=ILST+1 + Q ILST + ; +UDINST(Y,INDEX) ; assembles instructions for a unit dose order + N I,X,RST + S X=^TMP("PS",$J,INDEX,0) + S RST="^TMP(""ORACT"",$J,""INSTRUCT"")" + S @RST@(1)=" "_$P(X,U,2),@RST=1 + S X=$S($L($P(X,U,6)):$P(X,U,6),1:$P(X,U,7)) + I $L(X) S @RST=2,@RST@(2)=X + E S @RST=1 D SETMULT(.RST,INDEX,"SIG") + S @RST@(2)="\Give: "_$G(@RST@(2)),@RST=$G(@RST,2) + D SETMULT(RST,INDEX,"MDR"),SETMULT(RST,INDEX,"SCH") + F I=3:1:@RST S @RST@(I)=" "_@RST@(I) + M Y=@RST K @RST + Q +OPINST(Y,INDEX) ; assembles instructions for an outpatient prescription + N I,X,RST + S X=^TMP("PS",$J,INDEX,0) + S RST="^TMP(""ORACT"",$J,""INSTRUCT"")" + S @RST@(1)=" "_$P(X,U,2),@RST=1 + I $L($P(X,U,12)) S @RST@(1)=@RST@(1)_" Qty: "_$P(X,U,12) + I $L($P(X,U,11)) S @RST@(1)=@RST@(1)_" for "_$P(X,U,11)_" days" + D SETMULT(RST,INDEX,"SIG") + I @RST=1 D + . D SETMULT(RST,INDEX,"SIO") + . D SETMULT(RST,INDEX,"MDR") + . D SETMULT(RST,INDEX,"SCH") + S @RST@(2)="\ Sig: "_$G(@RST@(2)) + F I=3:1:@RST S @RST@(I)=" "_@RST@(I) + M Y=@RST K @RST + Q +IVINST(Y,INDEX) ; assembles instructions for an IV order + N SOLN1,I,RST,IVDUR + S IVDUR="" + S RST="^TMP(""ORACT"",$J,""INSTRUCT"")" + S @RST=0 D SETMULT(RST,INDEX,"A") S SOLN1=@RST+1 + D SETMULT(RST,INDEX,"B") + I $D(@RST@(SOLN1)),$L($P(FIELDS,U,2)) S @RST@(SOLN1)="in "_@RST@(SOLN1) + S SOLN1=@RST+1 + D SETMULT(RST,INDEX,"SCH") S:$D(@RST@(SOLN1)) @RST@(SOLN1)=" "_@RST@(SOLN1) + F I=1:1:@RST S @RST@(I)="\"_$TR(@RST@(I),U," ") + I $D(@RST@(1)) S @RST@(1)=" "_$E(@RST@(1),2,999) + S @RST@(@RST)=@RST@(@RST)_" "_$P(^TMP("PS",$J,INDEX,0),U,3) + S:$D(^TMP("PS",$J,INDEX,"IVLIM",0)) IVDUR=$G(^TMP("PS",$J,INDEX,"IVLIM",0)) + I $L(IVDUR) D + . N DURU,DURV S DURU="",DURV=0 + . S DURU=$E(IVDUR,1),DURV=$E(IVDUR,2,$L(IVDUR)) + . I (DURU="D")!(DURU="d") S IVDUR="for "_+DURV_$S(+DURV=1:" day",+DURV>1:" days",1:" day") + . I (DURU="H")!(DURU="h") S IVDUR="for "_+DURV_$S(+DURV=1:" hours",+DURV>1:" hours",1:" hour") + . I (DURU="M")!(DURU="m") S IVDUR="with total volume "_+DURV_" ml" + . I (DURU="L")!(DURU="l") S IVDUR="with total volume "_+DURV_" L" + . S @RST@(@RST)=@RST@(@RST)_" "_IVDUR + M Y=@RST K @RST + Q +NVINST(Y,INDEX) ; assembles instructions for a non-VA med + N I,X,RST + S X=^TMP("PS",$J,INDEX,0) + S RST="^TMP(""ORACT"",$J,""INSTRUCT"")" + S @RST@(1)=" "_$P(X,U,2),@RST=1 + D SETMULT(RST,INDEX,"SIG") + I @RST=1 D + . D SETMULT(RST,INDEX,"SIO") + . D SETMULT(RST,INDEX,"MDR") + . D SETMULT(RST,INDEX,"SCH") + S @RST@(2)="\ "_$G(@RST@(2)) + F I=3:1:@RST S @RST@(I)=" "_@RST@(I) + M Y=@RST K @RST + Q +NVREASON(ORR,NVSDT,INDEX) ; assembles start date and reasons for a non-VA med + N ORI,J,X,ORN,ORA + S ORI=0 K ORR + S X=^TMP("PS",$J,INDEX,0) + S ORN=+$P(X,U,8) + I $D(^OR(100,ORN,0)) D + .S NVSDT=$P(^OR(100,ORN,0),U,8) + .D WPVAL^ORWDXR(.ORA,ORN,"STATEMENTS") I $D(ORA) D + ..S J=0 F S J=$O(ORA(J)) Q:J<1 S ORI=ORI+1,ORR(ORI)=ORA(J) + Q +SETMULT(Y,INDEX,SUB) ; appends the multiple at the subscript to Y + N I,X,J + S J=$G(@Y) + S I=0 F S I=$O(^TMP("PS",$J,INDEX,SUB,I)) Q:'I S X=$G(^(I,0)) D + . I SUB="B",$L($P(X,U,3)) S X=$P(X,U)_" "_$P(X,U,3)_"^"_$P(X,U,2) + . S J=J+1,@Y@(J)=X + S @Y=J + Q +COMPRESS(Y) ; concatenate Y subscripts into smallest possible number + N I,J,X S J=1,X(J)="" + S I=0 F S I=$O(Y(I)) Q:'I D + . I ($L(Y(I))+$L(X(J)))>245 S J=J+1,X(J)="" + . S X(J)=X(J)_$S($L(X(J)):" ",1:"")_Y(I) + K Y M Y=X + Q +DETAIL(ROOT,DFN,ID) ; -- show details for a med order + K ^TMP("ORXPND",$J) + N LCNT,ORVP + S LCNT=0,ORVP=DFN_";DPT(" + D MEDS^ORCXPND1 + S ROOT=$NA(^TMP("ORXPND",$J)) + Q +MEDHIST(ORROOT,DFN,ORIFN) ; -- show admin history for a med (RV) + N ORPSID,HPIV,ISIV,CKPKG,ORPHMID + S ORPSID=+$P($$OI^ORX8(ORIFN),U,3),(HPIV,ISIV)=0 + S ORROOT=$NA(^TMP("ORHIST",$J)) K @ORROOT + S ORPHMID=$G(^OR(100,+ORIFN,4)) ;Pharmacy order number + S ISIV=$O(^ORD(100.98,"B","IV RX",ISIV)) + S HPIV=$O(^ORD(100.98,"B","TPN",HPIV)) + S CKPKG=$$PATCH^XPDUTL("PSB*2.0*19") + ;if the order is pending or the order has no pharmacy # + ;or the order is not in the Display Group IV MEDICATION + ; then use the Orderable item number to get the MAH. + I (ORPHMID["P")!(ORPHMID="") D Q + . I '$L($T(HISTORY^PSBMLHS)) D Q + . . S @ORROOT@(0)="This report is only available using BCMA version 2.0." + . D HISTORY^PSBMLHS(.ORROOT,DFN,ORPSID) ; DBIA #3459 for BCMA v2.0 + ; If the order has a Display Group of IV MEDICATION the use the Pharmacy order number to get the MAH + I $P($G(^OR(100,+ORIFN,0)),U,11)=ISIV!($P($G(^OR(100,+ORIFN,0)),U,11)=HPIV) D Q + . I 'CKPKG S @ORROOT@(0)="Medication Administration History is not available at this time for IV fluids." + . I CKPKG D + . . D RPC^PSBO(.ORROOT,"PM",DFN,"","","","","","","","","",ORPHMID) ;DBIA #3955 + . . I '$D(@ORROOT) S @ORROOT@(0)="No Medication Administration History found for the IV order." + I '$L($T(HISTORY^PSBMLHS)) D Q + . S @ORROOT@(0)="This report is only available using BCMA version 2.0." + D HISTORY^PSBMLHS(.ORROOT,DFN,ORPSID) ; DBIA #3459 for BCMA v2.0 + Q + ; +REASON(ORY) ; -- Return Non-VA Med Statement/Reasons + N ORE + D GETLST^XPAR(.ORY,"ALL","ORWD NONVA REASON","E") + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPT.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPT.m index c574aebe..9c82ee9f 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPT.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPT.m @@ -1,238 +1,258 @@ -ORWPT ; SLC/KCM/REV - Patient Lookup Functions ;3/18/05 10:50 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,132,149,206,187,190,215,243**;Dec 17, 1997;Build 242 - ; - ; Ref. to ^UTILITY via IA 10061 - ; -IDINFO(REC,DFN) ; Return identifying information for a patient - ; PID^DOB^SEX^VET^SC%^WARD^RM-BED^NAME - N X0,X1,X101,X3,XV ; name/dob/sex/ssn, ward, room-bed, sc%, vet - S X0=$G(^DPT(DFN,0)),X1=$G(^(.1)),X101=$G(^(.101)),X3=$G(^(.3)),XV=$G(^("VET")) - S REC=$$SSN^DPTLK1(DFN)_U_$$DOB^DPTLK1(DFN,2)_U_$P(X0,U,2)_U_$P(XV,U)_U_$P(X3,U,2)_U_$P(X1,U)_U_$P(X101,U)_U_$P(X0,U) ;DG249 - Q -PTINQ(REF,DFN) ; Return formatted pt inquiry report - K ^TMP("ORDATA",$J,1) - D DGINQ^ORCXPND1(DFN) - S REF=$NA(^TMP("ORDATA",$J,1)) - Q -SCDIS(LST,DFN) ; Return service connected % and rated disabilities - N VAEL,VAERR,I,ILST,DIS,SC,X - D ELIG^VADPT - S LST(1)="Service Connected: "_$S(+VAEL(3):$P(VAEL(3),U,2)_"%",1:"NO") - I 'VAEL(4),'$P($G(^DG(391,+VAEL(6),0)),U,2) S LST(2)="NOT A VETERAN." Q - S I=0,ILST=1 F S I=$O(^DPT(DFN,.372,I)) Q:'I S X=^(I,0) D - . S DIS=$P($G(^DIC(31,+X,0)),U) Q:DIS="" - . S SC=$S($P(X,U,3):"SC",$P(X,U,3)']"":"not specified",1:"NSC") - . S ILST=ILST+1,LST(ILST)=DIS_" ("_$P(X,U,2)_"% "_SC_")" - I ILST=1 S LST(2)="Rated Disabilities: NONE STATED" - Q -SHOW ; temporary - show patient inquiry screen - N I,Y,DIC S DIC=2,DIC(0)="AEMQ" D ^DIC Q:'Y - K ^TMP("ORDATA",$J,1) - D DGINQ^ORCXPND1(+Y) - S I=0 F S I=$O(^TMP("ORDATA",$J,1,I)) Q:'I W !,^(I) - K ^TMP("ORDATA",$J,1) - Q -SELCHK(REC,DFN) ; Check for sensitive pt - ; SENSITIVE - S REC=$$EN1^ORQPT2(DFN) - Q -DIEDON(VAL,DFN) ; Check for a date of death - S VAL=+$G(^DPT(DFN,.35)) - Q -SELECT(REC,DFN) ; Selects patient & returns key information - ; 1 2 3 4 5 6 7 8 9 10 11 12 - ; NAME^SEX^DOB^SSN^LOCIEN^LOCNM^RMBD^CWAD^SENSITIVE^ADMITTED^CONV^SC^ - ; 13 14 15 16 - ; SC%^ICN^AGE^TS - ; - ; for CCOW (RV - 2/27/03) name="-1", location=error message - I '$D(^DPT(+DFN,0)) S REC="-1^^^^^Patient is unknown to CPRS." Q - ; - N X - K ^TMP("ORWPCE",$J) ; delete PCE 'cache' when switching patients - S X=^DPT(DFN,0),REC=$P(X,U,1,3)_U_$P(X,U,9)_U_U_$G(^(.1))_U_$G(^(.101)) - S X=$P(REC,U,6) I $L(X) S $P(REC,U,5)=+$G(^DIC(42,+$O(^DIC(42,"B",X,0)),44)) - S $P(REC,U,8)=$$CWAD^ORQPT2(DFN)_U_$$EN1^ORQPT2(DFN) - ; I $P(REC,U,9) D EN2^ORQPT2(DFN) ;update DG security log ; DG249 - S X=$G(^DPT(DFN,.105)) I X S $P(REC,U,10)=$P($G(^DGPM(X,0)),U) - S:'$D(IOST) IOST="P-OTHER" - S $P(REC,U,11)=0 - D ELIG^VADPT S $P(REC,U,12)=$G(VAEL(3)) ;two pieces: SC^SC% - I $L($T(GETICN^MPIF001)) S X=+$$GETICN^MPIF001(DFN) S:X>0 $P(REC,U,14)=X - S $P(REC,U,15)=$$AGE(DFN,$P(REC,U,3)) - S $P(REC,U,16)=+$G(^DPT(DFN,.103)) ; treating specialty - K VAEL,VAERR ;VADPT call to kill? - S ^DISV(DUZ,"^DPT(")=DFN - Q -SHARE(VAL,IP,HWND,DFN) ; Set global to share DFN with other applications - K ^TMP("ORWCHART",$J),^TMP("ORECALL",$J),^TMP("ORWORD",$J) - K ^TMP("ORWDXMQ",$J) - S ^TMP("ORWCHART",$J,IP,HWND)=DFN - Q -BYWARD(LST,WARD) ; Return a list of patients in a ward - N ILST,DFN - I +$G(WARD)<1 S LST(1)="^No ward identified" Q - S (ILST,DFN)=0 - S WARD=$P(^DIC(42,WARD,0),"^") ;DBIA #36 - F S DFN=$O(^DPT("CN",WARD,DFN)) Q:DFN'>0 D - . S ILST=ILST+1,LST(ILST)=+DFN_U_$P(^DPT(+DFN,0),U)_U_$G(^DPT(+DFN,.101)) - I ILST<1 S LST(1)="^No patients found." - Q -LAST5(LST,ID) ; Return a list of patients matching A9999 identifiers - N I,IEN,XREF - S (I,IEN)=0,XREF=$S($L(ID)=5:"BS5",1:"BS") - F S IEN=$O(^DPT(XREF,ID,IEN)) Q:'IEN D - . S I=I+1,LST(I)=IEN_U_$P(^DPT(IEN,0),U)_U_$$DOB^DPTLK1(IEN,2)_U_$$SSN^DPTLK1(IEN) ; DG249 - Q - ; -LAST5RPL(LST,ID) ; ; Return list matching A9999 id's, but from RPL only. - N ORRPL,ORCNT,ORPT,ORPIEN - ; IA ____ allows read access to NEW PERSON file node 101: - S ORRPL=$G(^VA(200,DUZ,101)) - S ORRPL=$P(ORRPL,U,2) - I (('ORRPL)!(ORRPL="")) S LST(0)="" Q - ; - S (ORCNT,ORPT)=0 - F S ORPT=$O(^OR(100.21,ORRPL,10,ORPT)) Q:'ORPT D - .S ORPIEN=+$G(^OR(100.21,ORRPL,10,ORPT,0)) - .I ((ORPIEN<0)!(ORPIEN="")) Q - .S ORCNT=ORCNT+1 - .S LST(ORCNT)=ORPIEN_U_$P(^DPT(ORPIEN,0),U)_U_$$DOB^DPTLK1(ORPIEN,2)_U_$$SSN^DPTLK1(ORPIEN) ; DG249. - ; - Q - ; -FULLSSN(LST,ID) ; Return a list of patients matching full SSN entered - N I,IEN - S (I,IEN)=0 - F S IEN=$O(^DPT("SSN",ID,IEN)) Q:'IEN D - . S I=I+1,LST(I)=IEN_U_$P(^DPT(IEN,0),U)_U_$$DOB^DPTLK1(IEN,2)_U_$$SSN^DPTLK1(IEN) ; DG249 - Q - ; -FSSNRPL(LST,ID) ; Return list matching Full SSN, but from RPL only. - N ORRPL,ORCNT,ORPT,ORLPT,ORPIEN - ; IA ____ allows read access to NEW PERSON file node 101: - S ORRPL=$G(^VA(200,DUZ,101)) - S ORRPL=$P(ORRPL,U,2) - I (('ORRPL)!(ORRPL="")) S LST(0)="" Q - ; - S (ORCNT,ORPT)=0 - F S ORPT=$O(^DPT("SSN",ID,ORPT)) Q:'ORPT D - .S ORLPT=0 - .F S ORLPT=$O(^OR(100.21,ORRPL,10,ORLPT)) Q:'ORLPT D - ..S ORPIEN=+$G(^OR(100.21,ORRPL,10,ORLPT,0)) - ..I ((ORPIEN<0)!(ORPIEN="")) Q - ..I (ORPIEN'=ORPT) Q - ..S ORCNT=ORCNT+1 - ..S LST(ORCNT)=ORPIEN_U_$P(^DPT(ORPIEN,0),U)_U_$$DOB^DPTLK1(ORPIEN,2)_U_$$SSN^DPTLK1(ORPIEN) ; DG249. - ; - Q - ; -TOP(LST) ; Return top for all patients list (last selected for now) - N IEN - S IEN=$G(^DISV(DUZ,"^DPT(")) - I IEN S LST(1)=IEN_U_$P($G(^DPT(IEN,0)),U) - Q -ENCTITL(REC,DFN,LOC,PROV) ; Return external values for encounter - ; LOCNAME^LOCABBR^ROOMBED^PROVNAME - S $P(REC,U,1)=$P($G(^SC(+LOC,0)),U,1,2) - S $P(REC,U,3)=$P($G(^DPT(DFN,.101)),U) - S $P(REC,U,4)=$P($G(^VA(200,+PROV,0)),U) - Q -LISTALL(Y,FROM,DIR) ; Return a bolus of patient names. From is either Name or IEN^Name. - N I,IEN,CNT,FROMIEN,ORIDNAME S CNT=44,I=0,FROMIEN=0 - I $P(FROM,U,2)'="" S FROMIEN=$P(FROM,U,1),FROM=$O(^DPT("B",$P(FROM,U,2)),-DIR) - F S FROM=$O(^DPT("B",FROM),DIR) Q:FROM="" D Q:I=CNT - . S IEN=FROMIEN,FROMIEN=0 F S IEN=$O(^DPT("B",FROM,IEN)) Q:'IEN D Q:I=CNT - . . S ORIDNAME="" - . . S ORIDNAME=$G(^DPT(IEN,0)) ; Get zero node name. - . . ; S X1=$G(^DPT(IEN,.1))_" "_$G(^DPT(IEN,.101)) - . . S I=I+1 S Y(I)=IEN_U_FROM_U_U_U_U_$P(ORIDNAME,U) ;_"^"_X ; _"^"_X1 ;" ("_X_")" - Q -APPTLST(LST,DFN) ; return a list of appointments - ; APPTTIME^LOCIEN^LOCNAME^EXTSTATUS - N ERR,ERRMSG,VASD,VAERR K ^UTILITY("VASD",$J) ;IA 10061 - S VASD("F")=$$HTFM^XLFDT($H-30,1) - S VASD("T")=$$HTFM^XLFDT($H+1,1)_".2359" - S VASD("W")="123456789" - D SDA^ORQRY01(.ERR,.ERRMSG) - I ERR K ^UTILITY("VASD",$J) K LST S LST(1)=ERRMSG Q - S I=0 F S I=$O(^UTILITY("VASD",$J,I)) Q:'I D - . S LST(I)=$P(^UTILITY("VASD",$J,I,"I"),U,1,2)_U_$P(^("E"),U,2,3) - K ^UTILITY("VASD",$J) - Q -ADMITLST(LST,DFN) ; return a list of admissions - ; MOVETIME^LOCIEN^LOCNAME^TYPE - N TIM,MOV,X0,Y,MTIM,XTYP,XLOC,HLOC,ILST S ILST=0 - S TIM="" F S TIM=$O(^DGPM("ATID1",DFN,TIM)) Q:TIM'>0 D - . S MOV=0 F S MOV=$O(^DGPM("ATID1",DFN,TIM,MOV)) Q:MOV'>0 D - . . N VSTR,TIUDA - . . S X0=$G(^DGPM(MOV,0)) I X0']"" Q - . . S MTIM=$P(X0,U) - . . S XTYP=$P($G(^DG(405.1,+$P(X0,U,4),0)),U,1) - . . S XLOC=$P($G(^DIC(42,+$P(X0,U,6),0)),U,1),HLOC=+$G(^(44)) - . . S VSTR=HLOC_";"_MTIM_";H",TIUDA=$$HASDS^TIULX(DFN,VSTR) - . . S ILST=ILST+1,LST(ILST)=MTIM_U_HLOC_U_XLOC_U_XTYP_U_MOV_U_TIUDA - Q -CLINRNG(LST) ; return date ranges for clinic appointments - S LST(1)="T;T^Today" - S LST(2)="T+1;T+1^Tomorrow" - S LST(3)="T-1;T-1^Yesterday" - S LST(4)="T-7;T^Past Week" - S LST(5)="T-31;T^Past Month" - S LST(6)="S^Specify Date Range..." - Q - ; - N %,%H,X,SUNDAY,START - S LST(1)=DT_";"_DT_"^Today",X=$$HTFM^XLFDT($H+1,1) - S LST(2)=X_";"_X_"^Tomorrow" - S X=+$H F Q:X#7=3 S X=X-1 ; $H#7=3 is Sunday - S LST(3)=$$HTFM^XLFDT(X)_";"_$$HTFM^XLFDT(X+6)_"^This Week" - S LST(4)=$$HTFM^XLFDT(X+7)_";"_$$HTFM^XLFDT(X+13)_"^Next Week" - S LST(5)=$E(DT,1,5)_"01;"_$E(DT,1,5)_"31^This Month" - S X=$E(DT,4,5)+1 S:X=13 X=1 S X=$E(DT,1,3)_$TR($J(X,2)," ",0) - S LST(6)=X_"01;"_X_"31^Next Month" - S LST(7)="^Specify Dates" - Q -DFLTSRC(VAL) ; return default patient list source (T, W, C, P, S) - N SRV S SRV=+$G(^VA(200,DUZ,5)) - S VAL=$$GET^XPAR("ALL^SRV.`"_SRV,"ORLP DEFAULT LIST SOURCE") - Q -SAVDFLT(OK,X) ; save new default patient list settings (X=type^ien^sdt;edt) - G SAVDFLT^ORWPT1 - ; -DISCHRG(Y,DFN,ADMITDT) ; Get discharge movement information - N VAIP - I +$G(ADMITDT)=0 S Y=DT Q - S VAIP("D")=ADMITDT D 52^VADPT - I +VAIP(17)=0 S Y=DT Q - S Y=+VAIP(17,1) - Q -CWAD(Y,DFN) ; returns CWAD flags for a patient - S Y=$$CWAD^ORQPT2(DFN) - Q -LEGACY(ORLST,DFN) ; return message if data on the legacy system - ; ORLST(0)=1 if data, ORLST(n)=display message if data - S ORLST(0)=0 - I $L($T(HXDATA^A7RDPAGU)) D - . D HXDATA^A7RDPAGU(.ORLST,DFN) - . I $O(ORLST(0)) S ORLST(0)=1 - Q -INPLOC(REC,DFN) ; Return a patient's current location - N X - S X=$G(^DPT(DFN,.102)),REC=0 - I X S X=$P($G(^DGPM(X,0)),U,6) - I X S REC=+$G(^DIC(42,X,44)) - I X S $P(REC,U,2)=$P($G(^DIC(42,X,0)),U,1) - I X S X=$P($G(^DIC(42,X,0)),U,3) - S $P(REC,U,3)=X - Q -AGE(DFN,BEG) ; returns age based on date of birth and date of death (or DT) - N END,X - S END=+$G(^DPT(DFN,.35)),END=$S(END:END,1:DT) - S X=$E(END,1,3)-$E(BEG,1,3)-($E(END,4,7)<$E(BEG,4,7)) - Q X -ROK(X) ; Routine OK (in UCI) (NDBI) - S X=$G(X) Q:'$L(X) 0 Q:$L(X)>8 0 X ^%ZOSF("TEST") Q:$T 1 Q 0 - ; - ;NDBI(X) ; National Database Integration site 1 = yes 0 = no - ; N R,G S X="A7RDUP" X ^%ZOSF("TEST") S R=$T,G=$S($D(^A7RCP):1,1:0),X=R+G,X=$S(X=2:1,1:0) Q X +ORWPT ; SLC/KCM/REV - Patient Lookup Functions ;11/23/06 10:50 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,132,149,206,187,190,215,269**;Dec 17, 1997 LOCAL ;Build 28 + ; 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 + ;;VOE VWPT PACKAGE ENHANCEMENT UPDATES ADDED 11/14/06 + ; + Q +IDINFO(REC,DFN) ; Return identifying information for a patient + ;VWPT BELOW ADD HRN AND ALT HRN + ; PID^DOB^SEX^VET^SC%^WARD^RM-BED^NAME^HRN^ALTHRN + ; PID^DOB^SEX^VET^SC%^WARD^RM-BED^NAME + N X0,X1,X101,X3,XV ; name/dob/sex/ssn, ward, room-bed, sc%, vet + S X0=$G(^DPT(DFN,0)),X1=$G(^(.1)),X101=$G(^(.101)),X3=$G(^(.3)),XV=$G(^("VET")) + ;VWPT ENHANCED + N HRN,ID + S HRN=$$HRN^DGLBPID(DFN) + S ID=$$ID^DGLBPID(DFN) + I (ID=HRN)&(HRN'="") D + .S REC=U_$$DOB^DPTLK1(DFN,2)_U_$P(X0,U,2)_U_$P(XV,U)_U_$P(X3,U,2)_U_$P(X1,U)_U_$P(X101,U)_U_$P(X0,U)_U_$$HRNRET(DFN)_U_$$ALTHRN^ORWPT2(DFN) ;DG249 + E D + .S REC=$$ID^DGLBPID(DFN)_U_$$DOB^DPTLK1(DFN,2)_U_$P(X0,U,2)_U_$P(XV,U)_U_$P(X3,U,2)_U_$P(X1,U)_U_$P(X101,U)_U_$P(X0,U)_U_$$HRNRET(DFN)_U_$$ALTHRN^ORWPT2(DFN) ;DG249 + ;S REC=$$SSN^DPTLK1(DFN)_U_$$DOB^DPTLK1(DFN,2)_U_$P(X0,U,2)_U_$P(XV,U)_U_$P(X3,U,2)_U_$P(X1,U)_U_$P(X101,U)_U_$P(X0,U) ;DG249 + ;END VWPT + Q + ;VWPT RETURN HRN .CHECK FOR "sensitive" patients +HRNRET(DFN) ; + N IRET + S IRET=$$HRN^DGLBPID(DFN) ;$$HRN^VWVOEDPT(DFN) + ;I (IRET'="")&$$SCREEN^DPTLK1(DFN) Q "*SENSITIVE*" ;"HRN SENSITIVE" + I (IRET'="") Q "'"_IRET_"'" ;"HRN:"_"'"_IRET_"'" + Q "" + ; END VWPT +PTINQ(REF,DFN) ; Return formatted pt inquiry report + K ^TMP("ORDATA",$J,1) + D DGINQ^ORCXPND1(DFN) + S REF=$NA(^TMP("ORDATA",$J,1)) + Q +SCDIS(LST,DFN) ; Return service connected % and rated disabilities + N VAEL,VAERR,I,ILST,DIS,SC,X + D ELIG^VADPT + S LST(1)="Service Connected: "_$S(+VAEL(3):$P(VAEL(3),U,2)_"%",1:"NO") + I 'VAEL(4),'$P($G(^DG(391,+VAEL(6),0)),U,2) S LST(2)="NOT A VETERAN." Q + S I=0,ILST=1 F S I=$O(^DPT(DFN,.372,I)) Q:'I S X=^(I,0) D + . S DIS=$P($G(^DIC(31,+X,0)),U) Q:DIS="" + . S SC=$S($P(X,U,3):"SC",$P(X,U,3)']"":"not specified",1:"NSC") + . S ILST=ILST+1,LST(ILST)=DIS_" ("_$P(X,U,2)_"% "_SC_")" + I ILST=1 S LST(2)="Rated Disabilities: NONE STATED" + Q +SHOW ; temporary - show patient inquiry screen + N I,Y,DIC S DIC=2,DIC(0)="AEMQ" D ^DIC Q:'Y + K ^TMP("ORDATA",$J,1) + D DGINQ^ORCXPND1(+Y) + S I=0 F S I=$O(^TMP("ORDATA",$J,1,I)) Q:'I W !,^(I) + K ^TMP("ORDATA",$J,1) + Q +SELCHK(REC,DFN) ; Check for sensitive pt + ; SENSITIVE + S REC=$$EN1^ORQPT2(DFN) + Q +DIEDON(VAL,DFN) ; Check for a date of death + S VAL=+$G(^DPT(DFN,.35)) + Q +SELECT(REC,DFN) ; Selects patient & returns key information + ; 1 2 3 4 5 6 7 8 9 10 11 12 + ; NAME^SEX^DOB^SSN^LOCIEN^LOCNM^RMBD^CWAD^SENSITIVE^ADMITTED^CONV^SC^ + ;VWPT HRN , ALTERNATE HRN + ; 13 14 15 16 17 18 + ; SC%^ICN^AGE^TS^HRN^AltHRN + ; ; + ; ;end vwpt + ; + ; + ; for CCOW (RV - 2/27/03) name="-1", location=error message + I '$D(^DPT(DFN,0)) S REC="-1^^^^^Patient is unknown to CPRS." Q + ; + N X,ID,HRN + K ^TMP("ORWPCE",$J) ; delete PCE 'cache' when switching patients + D VWPT1^ORWPT2 ;moved code to ORWPT2 to save space + S $P(REC,U,15)=$$AGE(DFN,$P(REC,U,3)) + S $P(REC,U,16)=+$G(^DPT(DFN,.103)) ; treating specialty + D VWPT2^ORWPT2 + Q +SHARE(VAL,IP,HWND,DFN) ; Set global to share DFN with other applications + K ^TMP("ORWCHART",$J),^TMP("ORECALL",$J),^TMP("ORWORD",$J) + K ^TMP("ORWDXMQ",$J) + S ^TMP("ORWCHART",$J,IP,HWND)=DFN + Q +BYWARD(LST,WARD) ; Return a list of patients in a ward + N ILST,DFN + I +$G(WARD)<1 S LST(1)="^No ward identified" Q + S (ILST,DFN)=0 + S WARD=$P(^DIC(42,WARD,0),"^") ;DBIA #36 + F S DFN=$O(^DPT("CN",WARD,DFN)) Q:DFN'>0 D + . S ILST=ILST+1,LST(ILST)=+DFN_U_$P(^DPT(+DFN,0),U)_U_$G(^DPT(+DFN,.101)) + I ILST<1 S LST(1)="^No patients found." + Q +LAST5(LST,ID) ; Return a list of patients matching A9999 identifiers + N I,IEN,XREF + S (I,IEN)=0,XREF=$S($L(ID)=5:"BS5",1:"BS") + F S IEN=$O(^DPT(XREF,ID,IEN)) Q:'IEN D + . S I=I+1,LST(I)=IEN_U_$P(^DPT(IEN,0),U)_U_$$DOB^DPTLK1(IEN,2)_U_$$ID^DGLBPID(IEN) ;$$SSN^DPTLK1(IEN) ; DG249 + Q + ; +LAST5RPL(LST,ID) ; ; Return list matching A9999 id's, but from RPL only. + N ORRPL,ORCNT,ORPT,ORPIEN + ; IA ____ allows read access to NEW PERSON file node 101: + S ORRPL=$G(^VA(200,DUZ,101)) + S ORRPL=$P(ORRPL,U,2) + I (('ORRPL)!(ORRPL="")) S LST(0)="" Q + ; + S (ORCNT,ORPT)=0 + F S ORPT=$O(^OR(100.21,ORRPL,10,ORPT)) Q:'ORPT D + .S ORPIEN=+$G(^OR(100.21,ORRPL,10,ORPT,0)) + .I ((ORPIEN<0)!(ORPIEN="")) Q + .S ORCNT=ORCNT+1 + .S LST(ORCNT)=ORPIEN_U_$P(^DPT(ORPIEN,0),U)_U_$$DOB^DPTLK1(ORPIEN,2)_U_$$ID^DGLBPID(ORPIEN) ;$$SSN^DPTLK1(ORPIEN) ; DG249. + ; + Q + ; +FULLSSN(LST,ID) ; Return a list of patients matching full SSN entered + N I,IEN + S (I,IEN)=0 + F S IEN=$O(^DPT("SSN",ID,IEN)) Q:'IEN D + . S I=I+1,LST(I)=IEN_U_$P(^DPT(IEN,0),U)_U_$$DOB^DPTLK1(IEN,2)_U_$$ID^DGLBPID(IEN) ;$$SSN^DPTLK1(IEN) ; DG249 + Q + ; +FSSNRPL(LST,ID) ; Return list matching Full SSN, but from RPL only. + N ORRPL,ORCNT,ORPT,ORLPT,ORPIEN + ; IA ____ allows read access to NEW PERSON file node 101: + S ORRPL=$G(^VA(200,DUZ,101)) + S ORRPL=$P(ORRPL,U,2) + I (('ORRPL)!(ORRPL="")) S LST(0)="" Q + ; + S (ORCNT,ORPT)=0 + F S ORPT=$O(^DPT("SSN",ID,ORPT)) Q:'ORPT D + .S ORLPT=0 + .F S ORLPT=$O(^OR(100.21,ORRPL,10,ORLPT)) Q:'ORLPT D + ..S ORPIEN=+$G(^OR(100.21,ORRPL,10,ORLPT,0)) + ..I ((ORPIEN<0)!(ORPIEN="")) Q + ..I (ORPIEN'=ORPT) Q + ..S ORCNT=ORCNT+1 + ..S LST(ORCNT)=ORPIEN_U_$P(^DPT(ORPIEN,0),U)_U_$$DOB^DPTLK1(ORPIEN,2)_U_$$ID^DGLBPID(ORPIEN) ;SSN^DPTLK1(ORPIEN) ; DG249. + ; + Q + ; +TOP(LST) ; Return top for all patients list (last selected for now) + N IEN + S IEN=$G(^DISV(DUZ,"^DPT(")) + I IEN S LST(1)=IEN_U_$P($G(^DPT(IEN,0)),U) + Q +ENCTITL(REC,DFN,LOC,PROV) ; Return external values for encounter + ; LOCNAME^LOCABBR^ROOMBED^PROVNAME + S $P(REC,U,1)=$P($G(^SC(+LOC,0)),U,1,2) + S $P(REC,U,3)=$P($G(^DPT(DFN,.101)),U) + S $P(REC,U,4)=$P($G(^VA(200,+PROV,0)),U) + Q +LISTALL(Y,FROM,DIR) ; Return a bolus of patient names. From is either Name or IEN^Name. + N I,IEN,CNT,FROMIEN,ORIDNAME S CNT=44,I=0,FROMIEN=0 + I $P(FROM,U,2)'="" S FROMIEN=$P(FROM,U,1),FROM=$O(^DPT("B",$P(FROM,U,2)),-DIR) + F S FROM=$O(^DPT("B",FROM),DIR) Q:FROM="" D Q:I=CNT + . S IEN=FROMIEN,FROMIEN=0 F S IEN=$O(^DPT("B",FROM,IEN)) Q:'IEN D Q:I=CNT + . . S ORIDNAME="" + . . S ORIDNAME=$G(^DPT(IEN,0)) ; Get zero node name. + . . ; S X1=$G(^DPT(IEN,.1))_" "_$G(^DPT(IEN,.101)) + . . S I=I+1 S Y(I)=IEN_U_FROM_U_U_U_U_$P(ORIDNAME,U) ;_"^"_X ; _"^"_X1 ;" ("_X_")" + Q +APPTLST(LST,DFN) ; return a list of appointments + ; APPTTIME^LOCIEN^LOCNAME^EXTSTATUS + N ERR,ERRMSG,VASD,VAERR K ^UTILITY("VASD",$J) ;IA 10061 + S VASD("F")=$$HTFM^XLFDT($H-30,1) + S VASD("T")=$$HTFM^XLFDT($H+1,1)_".2359" + S VASD("W")="123456789" + D SDA^ORQRY01(.ERR,.ERRMSG) + I ERR K ^UTILITY("VASD",$J) K LST S LST(1)=ERRMSG Q + S I=0 F S I=$O(^UTILITY("VASD",$J,I)) Q:'I D + . S LST(I)=$P(^UTILITY("VASD",$J,I,"I"),U,1,2)_U_$P(^("E"),U,2,3) + K ^UTILITY("VASD",$J) + Q +ADMITLST(LST,DFN) ; return a list of admissions + ; MOVETIME^LOCIEN^LOCNAME^TYPE + N TIM,MOV,X0,Y,MTIM,XTYP,XLOC,HLOC,ILST S ILST=0 + S TIM="" F S TIM=$O(^DGPM("ATID1",DFN,TIM)) Q:TIM'>0 D + . S MOV=0 F S MOV=$O(^DGPM("ATID1",DFN,TIM,MOV)) Q:MOV'>0 D + . . N VSTR,TIUDA + . . S X0=$G(^DGPM(MOV,0)) I X0']"" Q + . . S MTIM=$P(X0,U) + . . S XTYP=$P($G(^DG(405.1,+$P(X0,U,4),0)),U,1) + . . S XLOC=$P($G(^DIC(42,+$P(X0,U,6),0)),U,1),HLOC=+$G(^(44)) + . . S VSTR=HLOC_";"_MTIM_";H",TIUDA=$$HASDS^TIULX(DFN,VSTR) + . . S ILST=ILST+1,LST(ILST)=MTIM_U_HLOC_U_XLOC_U_XTYP_U_MOV_U_TIUDA + Q +CLINRNG(LST) ; return date ranges for clinic appointments + S LST(1)="T;T^Today" + S LST(2)="T+1;T+1^Tomorrow" + S LST(3)="T-1;T-1^Yesterday" + S LST(4)="T-7;T^Past Week" + S LST(5)="T-31;T^Past Month" + S LST(6)="S^Specify Date Range..." + Q + ; + N %,%H,X,SUNDAY,START + S LST(1)=DT_";"_DT_"^Today",X=$$HTFM^XLFDT($H+1,1) + S LST(2)=X_";"_X_"^Tomorrow" + S X=+$H F Q:X#7=3 S X=X-1 ; $H#7=3 is Sunday + S LST(3)=$$HTFM^XLFDT(X)_";"_$$HTFM^XLFDT(X+6)_"^This Week" + S LST(4)=$$HTFM^XLFDT(X+7)_";"_$$HTFM^XLFDT(X+13)_"^Next Week" + S LST(5)=$E(DT,1,5)_"01;"_$E(DT,1,5)_"31^This Month" + S X=$E(DT,4,5)+1 S:X=13 X=1 S X=$E(DT,1,3)_$TR($J(X,2)," ",0) + S LST(6)=X_"01;"_X_"31^Next Month" + S LST(7)="^Specify Dates" + Q +DFLTSRC(VAL) ; return default patient list source (T, W, C, P, S) + N SRV S SRV=+$G(^VA(200,DUZ,5)) + S VAL=$$GET^XPAR("ALL^SRV.`"_SRV,"ORLP DEFAULT LIST SOURCE") + Q +SAVDFLT(OK,X) ; save new default patient list settings (X=type^ien^sdt;edt) + G SAVDFLT^ORWPT1 + ; +DISCHRG(Y,DFN,ADMITDT) ; Get discharge movement information + N VAIP + I +$G(ADMITDT)=0 S Y=DT Q + S VAIP("D")=ADMITDT D 52^VADPT + I +VAIP(17)=0 S Y=DT Q + S Y=+VAIP(17,1) + Q +CWAD(Y,DFN) ; returns CWAD flags for a patient + S Y=$$CWAD^ORQPT2(DFN) + Q +LEGACY(ORLST,DFN) ; return message if data on the legacy system + ; ORLST(0)=1 if data, ORLST(n)=display message if data + S ORLST(0)=0 + I $L($T(HXDATA^A7RDPAGU)) D + . D HXDATA^A7RDPAGU(.ORLST,DFN) + . I $O(ORLST(0)) S ORLST(0)=1 + Q +INPLOC(REC,DFN) ; Return a patient's current location + N X + S X=$G(^DPT(DFN,.102)),REC=0 + I X S X=$P($G(^DGPM(X,0)),U,6) + I X S REC=+$G(^DIC(42,X,44)) + I X S $P(REC,U,2)=$P($G(^DIC(42,X,0)),U,1) + I X S X=$P($G(^DIC(42,X,0)),U,3) + S $P(REC,U,3)=X + Q +AGE(DFN,BEG) ; returns age based on date of birth and date of death (or DT) + N END,X + S END=+$G(^DPT(DFN,.35)),END=$S(END:END,1:DT) + S X=$E(END,1,3)-$E(BEG,1,3)-($E(END,4,7)<$E(BEG,4,7)) + Q X +ROK(X) ; Routine OK (in UCI) (NDBI) + S X=$G(X) Q:'$L(X) 0 Q:$L(X)>8 0 X ^%ZOSF("TEST") Q:$T 1 Q 0 + ; + ;NDBI(X) ; National Database Integration site 1 = yes 0 = no + ; N R,G S X="A7RDUP" X ^%ZOSF("TEST") S R=$T,G=$S($D(^A7RCP):1,1:0),X=R+G,X=$S(X=2:1,1:0) Q X + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPT16.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPT16.m index c121a0f0..58a727c5 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPT16.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPT16.m @@ -1,86 +1,91 @@ -ORWPT16 ; SLC/KCM - Patient Lookup Functions - 16bit ;7/20/96 15:43 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**243**;Dec 17, 1997;Build 242 - ; -IDINFO(ORY,DFN) ; Return identifying information for a patient - ; PID^DOB^AGE^SEX^SC%^TYPE^WARD^RM-BED^NAME - N OR0,OR36,OR1,OR101,VAEL,VAERR - S OR0=$G(^DPT(DFN,0)),OR36=$G(^(.36)),OR1=$G(^(.1)),OR101=$G(^(.101)) - D ELIG^VADPT - S ORY=$P(OR36,U,3)_U_$P(OR0,U,3)_U_U_$P(OR0,U,2) - S ORY=ORY_U_$P(VAEL(3),U,2)_U_$P(VAEL(6),U,2)_U_$P(OR1,U)_U_$P(OR101,U) - I $P(OR0,U,3) S $P(ORY,U,3)=DT-$P(OR0,U,3)\10000 - I '$L($P(ORY,U,1)) D - . S X=$P(OR0,U,9),$P(ORY,U,1)=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,99) - S $P(ORY,U,9)=$P(OR0,U,1) - Q -DEMOG(VAL,DFN) ; procedure - ; Return common patient demographic info - ; NAME^SEX^DOB^SSN^WARDID^WARDNAME^RMBED^ADMITTIME^DIED ;^SC%^ELIGTYPE - S X=^DPT(DFN,0),VAL=$P(X,U,1,3)_U_$P(X,U,9)_U_U_$G(^(.1))_U_$G(^(.101)) - S X=$P(VAL,U,6) I $L(X) S $P(VAL,U,5)=$O(^SC("B",X,0)) - S X=$G(^DPT(DFN,.105)) I X S $P(VAL,U,8)=$P(^DGPM(X,0),U,1) - I $L($P($G(^DPT(DFN,.35)),U,1)) S $P(VAL,U,9)=$P(^(.35),U,1) - Q -PSCNVT(VAL,DFN) ; procedure - ; Call conversion routine for pharmacy (both inpatient and outpatient) - S VAL=0 - Q -LISTALL(Y,DIR,FROM) ; Return a bolus of patient names - N I,IEN,CNT S CNT=44,I=0 - ; - I DIR=0 D ; Forward direction - . F S FROM=$O(^DPT("B",FROM)) Q:FROM="" D Q:I=CNT - . . S IEN=0 F S IEN=$O(^DPT("B",FROM,IEN)) Q:'IEN D Q:I=CNT - . . . ; S X=$P($G(^DPT(IEN,0)),"^",9) - . . . ; S X=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,99) - . . . ; S X1=$G(^DPT(IEN,.1))_" "_$G(^DPT(IEN,.101)) - . . . S I=I+1 S Y(I)=IEN_"^"_FROM ;_"^"_X ; _"^"_X1 ;" ("_X_")" - . I $G(Y(CNT))="" S I=I+1,Y(I)="" - ; - I DIR=1 D ; Reverse direction - . F S FROM=$O(^DPT("B",FROM),-1) Q:FROM="" D Q:I=CNT - . . S IEN=0 F S IEN=$O(^DPT("B",FROM,IEN)) Q:'IEN D Q:I=CNT - . . . ; S X=$P($G(^DPT(IEN,0)),"^",9) - . . . ; S X=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,99) - . . . ; S X1=$G(^DPT(IEN,.1))_" "_$G(^DPT(IEN,.101)) - . . . S I=I+1 S Y(I)=IEN_"^"_FROM ;_"^"_X ; _"^"_X1 ;" ("_X_")" - Q -LOOKUP(Y,FROM) ; Return a set of patient names - N I,X - D FIND^DIC(2,"","","M",FROM) - S I=0,Y="" - F S I=$O(^TMP("DILIST",$J,1,I)) Q:'I D - . S X=^TMP("DILIST",$J,"ID",I,.09) - . S X=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,99) - . S Y(I)=^TMP("DILIST",$J,2,I)_"^"_^TMP("DILIST",$J,1,I)_"^"_X - K ^TMP("DILIST",$J) - Q -GETVSIT(Y,DFN,LOC,ADATE) ; procedure - ; Return a visit given a patient, location, and date/time - N VSIT,VSITPKG - S (VSIT,VSIT("VDT"))=ADATE,VSIT("PAT")=DFN,VSIT("LOC")=LOC - S VSIT("SVC")="A",VSIT("PRI")="P",VSIT(0)="NMD1",VSITPKG="OR" - D ^VSIT - S Y=VSIT("IEN") I +VSIT("IEN")'>0 S Y="" Q - I +VSIT("LOC") S Y=Y_U_VSIT("LOC")_U_$P(^SC(+VSIT("LOC"),0),U,1,2) - Q -APPTLST(LST,DFN) ; procedure - ; Return a list of appointments - N I,ILST S ILST=0 - D GETAPPT^TIUVSIT(DFN) - S I=0 F S I=$O(^TMP("TIUVNI",$J,I)) Q:'I D - . S ILST=ILST+1 - . S LST(ILST)=$P(^TMP("TIUVNI",$J,I),U,1,2)_U_$P(^TMP("TIUVN",$J,I),U,1,2) - K ^TMP("TIUVN",$J),^TMP("TIUVNI",$J) - Q -ADMITLST(LST,DFN) ; procedure - ; Return a list of admissions - N TIM,MOV,X0,Y,MTIM,XTIM,XTYP,XLOC,HLOC,ILST S ILST=0 - S TIM="" F S TIM=$O(^DGPM("ATID1",DFN,TIM)) Q:TIM'>0 D - . S MOV=0 F S MOV=$O(^DGPM("ATID1",DFN,TIM,MOV)) Q:MOV'>0 D - . . S X0=^DGPM(MOV,0) - . . S MTIM=$P(X0,U,1),Y=MTIM D DD^%DT S XTIM=Y - . . S XTYP=$P($G(^DG(405.1,+$P(X0,U,4),0)),U,1) - . . S XLOC=$P($G(^DIC(42,+$P(X0,U,6),0)),U,1),HLOC=+$G(^(44)) - . . S ILST=ILST+1,LST(ILST)=MTIM_U_HLOC_U_XTIM_U_XTYP_U_"TO: "_XLOC - Q +ORWPT16 ; SLC/KCM - Patient Lookup Functions - 16bit ;7/20/96 15:43 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997 + ; +IDINFO(ORY,DFN) ; Return identifying information for a patient + ; PID^DOB^AGE^SEX^SC%^TYPE^WARD^RM-BED^NAME + N OR0,OR36,OR1,OR101,VAEL,VAERR + S OR0=$G(^DPT(DFN,0)),OR36=$G(^(.36)),OR1=$G(^(.1)),OR101=$G(^(.101)) + D ELIG^VADPT + S ORY=$P(OR36,U,3)_U_$P(OR0,U,3)_U_U_$P(OR0,U,2) + S ORY=ORY_U_$P(VAEL(3),U,2)_U_$P(VAEL(6),U,2)_U_$P(OR1,U)_U_$P(OR101,U) + I $P(OR0,U,3) S $P(ORY,U,3)=DT-$P(OR0,U,3)\10000 + I '$L($P(ORY,U,1)) D + . S X=$P(OR0,U,9),$P(ORY,U,1)=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,99) + S $P(ORY,U,9)=$P(OR0,U,1) + Q +DEMOG(VAL,DFN) ; procedure + ; Return common patient demographic info + ; NAME^SEX^DOB^SSN^WARDID^WARDNAME^RMBED^ADMITTIME^DIED ;^SC%^ELIGTYPE + S X=^DPT(DFN,0),VAL=$P(X,U,1,3)_U_$P(X,U,9)_U_U_$G(^(.1))_U_$G(^(.101)) + S X=$P(VAL,U,6) I $L(X) S $P(VAL,U,5)=$O(^SC("B",X,0)) + S X=$G(^DPT(DFN,.105)) I X S $P(VAL,U,8)=$P(^DGPM(X,0),U,1) + I $L($P($G(^DPT(DFN,.35)),U,1)) S $P(VAL,U,9)=$P(^(.35),U,1) + Q +PSCNVT(VAL,DFN) ; procedure + ; Call conversion routine for pharmacy (both inpatient and outpatient) + S VAL=0 + S:'$D(IOST) IOST="P-OTHER" ; don't know why broker doesn't define IOST + S VAL=$$OTF^OR3CONV(DFN,1) + ; D EN1^PSOHLUP(DFN,0) + ; D EN^LR7OV2(DFN,0) + ; S VAL=1 + Q +LISTALL(Y,DIR,FROM) ; Return a bolus of patient names + N I,IEN,CNT S CNT=44,I=0 + ; + I DIR=0 D ; Forward direction + . F S FROM=$O(^DPT("B",FROM)) Q:FROM="" D Q:I=CNT + . . S IEN=0 F S IEN=$O(^DPT("B",FROM,IEN)) Q:'IEN D Q:I=CNT + . . . ; S X=$P($G(^DPT(IEN,0)),"^",9) + . . . ; S X=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,99) + . . . ; S X1=$G(^DPT(IEN,.1))_" "_$G(^DPT(IEN,.101)) + . . . S I=I+1 S Y(I)=IEN_"^"_FROM ;_"^"_X ; _"^"_X1 ;" ("_X_")" + . I $G(Y(CNT))="" S I=I+1,Y(I)="" + ; + I DIR=1 D ; Reverse direction + . F S FROM=$O(^DPT("B",FROM),-1) Q:FROM="" D Q:I=CNT + . . S IEN=0 F S IEN=$O(^DPT("B",FROM,IEN)) Q:'IEN D Q:I=CNT + . . . ; S X=$P($G(^DPT(IEN,0)),"^",9) + . . . ; S X=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,99) + . . . ; S X1=$G(^DPT(IEN,.1))_" "_$G(^DPT(IEN,.101)) + . . . S I=I+1 S Y(I)=IEN_"^"_FROM ;_"^"_X ; _"^"_X1 ;" ("_X_")" + Q +LOOKUP(Y,FROM) ; Return a set of patient names + N I,X + D FIND^DIC(2,"","","M",FROM) + S I=0,Y="" + F S I=$O(^TMP("DILIST",$J,1,I)) Q:'I D + . S X=^TMP("DILIST",$J,"ID",I,.09) + . S X=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,99) + . S Y(I)=^TMP("DILIST",$J,2,I)_"^"_^TMP("DILIST",$J,1,I)_"^"_X + K ^TMP("DILIST",$J) + Q +GETVSIT(Y,DFN,LOC,ADATE) ; procedure + ; Return a visit given a patient, location, and date/time + N VSIT,VSITPKG + S (VSIT,VSIT("VDT"))=ADATE,VSIT("PAT")=DFN,VSIT("LOC")=LOC + S VSIT("SVC")="A",VSIT("PRI")="P",VSIT(0)="NMD1",VSITPKG="OR" + D ^VSIT + S Y=VSIT("IEN") I +VSIT("IEN")'>0 S Y="" Q + I +VSIT("LOC") S Y=Y_U_VSIT("LOC")_U_$P(^SC(+VSIT("LOC"),0),U,1,2) + Q +APPTLST(LST,DFN) ; procedure + ; Return a list of appointments + N I,ILST S ILST=0 + D GETAPPT^TIUVSIT(DFN) + S I=0 F S I=$O(^TMP("TIUVNI",$J,I)) Q:'I D + . S ILST=ILST+1 + . S LST(ILST)=$P(^TMP("TIUVNI",$J,I),U,1,2)_U_$P(^TMP("TIUVN",$J,I),U,1,2) + K ^TMP("TIUVN",$J),^TMP("TIUVNI",$J) + Q +ADMITLST(LST,DFN) ; procedure + ; Return a list of admissions + N TIM,MOV,X0,Y,MTIM,XTIM,XTYP,XLOC,HLOC,ILST S ILST=0 + S TIM="" F S TIM=$O(^DGPM("ATID1",DFN,TIM)) Q:TIM'>0 D + . S MOV=0 F S MOV=$O(^DGPM("ATID1",DFN,TIM,MOV)) Q:MOV'>0 D + . . S X0=^DGPM(MOV,0) + . . S MTIM=$P(X0,U,1),Y=MTIM D DD^%DT S XTIM=Y + . . S XTYP=$P($G(^DG(405.1,+$P(X0,U,4),0)),U,1) + . . S XLOC=$P($G(^DIC(42,+$P(X0,U,6),0)),U,1),HLOC=+$G(^(44)) + . . S ILST=ILST+1,LST(ILST)=MTIM_U_HLOC_U_XTIM_U_XTYP_U_"TO: "_XLOC + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPT2.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPT2.m index e1ae4930..639fc033 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPT2.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPT2.m @@ -1,207 +1,207 @@ -ORWPT2 ; VOE//GT/GOW REV - Patient Lookup Functions ;8/13/07 17:45 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**269**;Dec 17, 1997 LOCAL ;Build 29 - ; 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 - ; - ;;VOE VWPT PACKAGE ENHANCEMENT UPDATES ADDED 11/14/06 - ;GFT PATIENT LOOKUP' RPC CALLS HERE FOR GENERAL PATIENT LOOKUP - ; Ref. to ^UTILITY via IA 10061 - ; - Q - ;VWVOEDPT ;GFT VOE PATIENT LOOKUP;6OCT2006 - ;;5.3;Registration;VWVF VOE LOCAL - ; - ;;Q - ; -LOOKUP(LST,X1) ;'GFT PATIENT LOOKUP' RPC CALLS HERE FOR GENERAL PATIENT LOOKUP - K LST - N GFTI,I,X,ILEN,IEN2,IENN,TAB,ILENP,X3,IEND,CR,XX - N IRET - N IDTMP,AJJTMP,AJJTMP1 - ; - S X=X1 - I X="" Q - S IEND=0 - ;UPPERCASE IT - X "F %=1:1:$L(X) S:$E(X,%)?1L X=$E(X,0,%-1)_$C($A(X,%)-32)_$E(X,%+1,999)" - S ILEN=$L(X) - ;CHECK INPUT TAB POSTION 20, 25, 30 WITH PRECEDING TRAILING BLANKS - ;CHECK FOR INITITAL LOOKUP BY DFN AS !DFN - ;CHECK FOR LOOKUP BY DFN AS 3 TAB POSITION FOR CLICKING AFTER PREVIOUS LOOKUP - S TAB=$C(9) - S X3=$P(X,TAB,3) - I X3'="",X3'="OPT" D - .S X=X3 - .S ILENP=$L(X) - .S X=$E(X,2,ILENP) ;TAKEOUT ! - .S U="^",(GFTI,I)=0 - .D LISTPOPD(X) - .S IEND=1 - E D - .S X=$P(X,TAB,1) - I IEND=1 Q - I $E(X1,1,1)="'" D - .I ILEN'=1 S X=$E(X1,2,ILEN) - .;CHECK FOR ENDING "'" - .S CR=$C(13) - .I $E(X1,ILEN,ILEN)'="'" S IEND=1 - .S X=$P(X,"'",1) - S U="^",(GFTI,I)=0 - I IEND=1 Q - S XX=X ; NO CR FOR HRN - F S IRET=$$CHKX(X) Q:IRET'=1 S I=$O(^AUPNPAT("D",X,I)) Q:'I I X=$$HRN^DGLBPID(I) D LISTPOPH(I) ;I X=$P($$HRN^DGLBPID(I),"#",2 - Q:GFTI - ; - S X=XX - ;NOW CHECK FOR B CROSS REFERENCE - D FIND^DIC(2,,,"MPC",X,,"B") ; ^SSN^BS5") - F I=0:0 S I=$O(^TMP("DILIST",$J,I)) Q:'I D LISTPOPB(+^(I,0)) - K ^TMP("DILIST",$J) - Q:GFTI>0 -OVETT ; - Q:ILEN<4 ;USE ADOB LOOKUP XXX- - ; - ; - ; - ; NEW EDITS/GOW 8/12/07 BELOW. CHECK TO PREVENT ASSUMED CURRENT YEAR TRIGGER - ; SELECTION AUTOMATICALLY WITH JUST MONTH DAY OR MM/DD INPUT. REQUIRE REMAINING YR ( 2 DIGIT MINIMUM) - ; WE CAN USE NUMERIC ENTRY ( IE 2-3-56, 2/3/56 OR 2.3.56, JUN 12,68, ETC OR 4 DIGIT YEAR FOR EXPLICIT YEAR ENTRY, IE JUNE 1,1903 - S NOCONTIN=0 - D - .S NOCONTIN=1 - .S IDTMP=$E($TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"),1,30) - .I IDTMP'=X D - ..S AJJTMP=$L($TR($P(X,",",2)," ")) I AJJTMP>1 S NOCONTIN=0 Q ;CASE FOR SPECIFIC DATE ENTRY BY ALPHABETIC MONTH DAY AND "," AND AT LEAST 2 YR DATE - ..S AJJTMP=$L($TR($P(X," ",2),",")) I AJJTMP>3 S NOCONTIN=0 Q ;CASE FOR SPECIFIC ( MONTH DAY followed by " " (space) and Year ( 2 or4 digit yr) - .I IDTMP'=X Q ; ALPHABETICAL DATE OF SOME KIND WHICH HAS BEEN TESTED ALREADY - .S AJJTMP=$L($TR($P(X,"-",3)," ")) I AJJTMP>1 S NOCONTIN=0 ;NUMERIC INPUT - .S AJJTMP=$L($TR($P(X,"/",3)," ")) I AJJTMP>1 S NOCONTIN=0 ; NUMERIC INPUT - .S AJJTMP=$L($TR($P(X,".",3)," ")) I AJJTMP>1 S NOCONTIN=0 ; NUMERIC INPUT - I NOCONTIN=1 G TRYPH ; TRY PHONE # - ;END EDITS/GOW - ; - ; - D FIND^DIC(2,,,"MPC",X,,"ADOB^B") ;^SSN^BS5") - F I=0:0 S I=$O(^TMP("DILIST",$J,I)) Q:'I D LISTPOP(+^(I,0),X1) - K ^TMP("DILIST",$J) - Q:GFTI>0 - ;TRY PHONE # WITH TRANSLATE -TRYPH ; - Q:ILEN<10 - S X=$E($TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!@#$%^&*()-_=+[]{}<>,./?:;'\|"),1,30) - D FIND^DIC(2,,,"MPC",X,,"AZVWVOE^B") ;^SSN^BS5") - F I=0:0 S I=$O(^TMP("DILIST",$J,I)) Q:'I D LISTPOPP(+^(I,0),X1) - K ^TMP("DILIST",$J) - Q -CHKX(X) ;CHECK TO SEE IF LEGITIMATE HRN EXISTS FOR IHS PATIENT HRN - N IDX,ILENM1,IFLAG - S IFLAG=0 - S IDX=X - ;TO SEE blank char inserts - S ILENM1=$L(X)-1 - I ILENM1>0 D - .S IDX=$E(X,1,ILENM1) - E D - .S IDX="" - F S IDX=$O(^AUPNPAT("D",IDX)) Q:(IDX="")!(IFLAG=1) D - . I IDX=X S IFLAG=1 - Q IFLAG -CHKXB(X1) ;CHECK TO SEE IF PATIENT NAME ENTERED TO ALLOW LOOKUP EVEN FOR SENSITIVE PATIENT - N IDX,ILENM1,IFLAG,X - S IFLAG=0 - S X=X1 - ;CONVERT UPPER CASE - X "F %=1:1:$L(X) S:$E(X,%)?1L X=$E(X,0,%-1)_$C($A(X,%)-32)_$E(X,%+1,999)" - S IDX=X - ;TO SEE blank char inserts - S ILENM1=$L(X)-1 - I ILENM1>0 D - .S IDX=$E(X,1,ILENM1) - E D - .S IDX="" - F S IDX=$O(^DPT("B",IDX)) Q:(IDX="")!(IFLAG=1) D - . I IDX=X S IFLAG=1 - Q IFLAG -LISTPOPB(DFN) ;PATIENT NAME B X-REF - N IEN - N HRN,PHONE,X - Q:($$SCREEN^DPTLK1(DFN)) ;SCREEN FOR VIP - Q:GFTI=-1 I GFTI>500 K LST S GFTI=-1 ;WE RETURN 500 VALUES MAX - S PHONE=$P($G(^DPT(DFN,.13)),U),HRN=$$HRN^DGLBPID(DFN) - S GFTI=GFTI+1,LST(GFTI)=DFN_U_$P(^DPT(DFN,0),U)_U_$$FMTE^XLFDT($P(^(0),U,3))_TAB_"!"_DFN_U_$$ID^DGLBPID(DFN)_U_"'"_HRN_"'"_U_PHONE - Q -LISTPOP(DFN,X1) ;DOB - N IEN - N HRN,PHONE,X - S IEN=$$CHKXB(X1) ;ALLOW INPUT BY NAME ON CLICK - Q:($$SCREEN^DPTLK1(DFN))&(IEN=0) ;SCREEN FOR VIP - Q:GFTI=-1 I GFTI>500 K LST S GFTI=-1 ;WE RETURN 500 VALUES MAX - S PHONE=$P($G(^DPT(DFN,.13)),U),HRN=$$HRN^DGLBPID(DFN) - S GFTI=GFTI+1,LST(GFTI)=DFN_U_$P(^DPT(DFN,0),U)_U_$$FMTE^XLFDT($P(^(0),U,3))_TAB_"!"_DFN_U_$$ID^DGLBPID(DFN)_U_"'"_HRN_"'"_U_PHONE - Q -LISTPOPP(DFN,X1) ;PHONE # - N IEN - N HRN,PHONE,X - S IEN=$$CHKXB(X1) ;ALLOW INPUT BY NAME ON CLICK - Q:($$SCREEN^DPTLK1(DFN))&(IEN=0) ;SCREEN FOR VIP - Q:GFTI=-1 I GFTI>500 K LST S GFTI=-1 ;WE RETURN 500 VALUES MAX - S PHONE=$P($G(^DPT(DFN,.13)),U),HRN=$$HRN^DGLBPID(DFN) - S GFTI=GFTI+1,LST(GFTI)=DFN_U_$P(^DPT(DFN,0),U)_U_PHONE_TAB_"!"_DFN_U_$$ID^DGLBPID(DFN)_U_"'"_HRN_"'"_U_PHONE - Q - ; -LISTPOPH(DFN) ;Q:$$SCREEN^DPTLK1(DFN) ;SCREEN FOR VIP FOR HRN - N HRN,PHONE - Q:GFTI=-1 I GFTI>500 K LST S GFTI=-1 ;WE RETURN 500 VALUES MAX - S PHONE=$P($G(^DPT(DFN,.13)),U),HRN=$$HRN^DGLBPID(DFN) - S GFTI=GFTI+1,LST(GFTI)=DFN_U_$P(^DPT(DFN,0),U)_U_"'"_HRN_"'"_TAB_"!"_DFN_U_$$FMTE^XLFDT($P(^(0),U,3))_U_$$ID^DGLBPID(DFN)_U_"'"_HRN_"'"_U_PHONE - Q -LISTPOPD(DFN) ; - N IEN - N HRN,PHONE,X - ;NO SCREEN FOR VIP - Q:GFTI=-1 I GFTI>500 K LST S GFTI=-1 ;WE RETURN 500 VALUES MAX - S PHONE=$P($G(^DPT(DFN,.13)),U),HRN=$$HRN^DGLBPID(DFN) - S GFTI=GFTI+1,LST(GFTI)=DFN_U_$P(^DPT(DFN,0),U)_U_$$FMTE^XLFDT($P(^(0),U,3))_TAB_"!"_DFN_U_$$ID^DGLBPID(DFN)_U_"'"_HRN_"'"_U_PHONE - Q - ; -VWPT1 ;VWPT NEW LOGIC . 4TH PIECE BELOW REPLACE $P(X,U,9)=SSN WITH ID AS $$ID^DGLBPID(DFN) - ; THEN IF THIS VALUE = HRN AND BOTH '="" THEN PUT SINGLE QUOTES - ; AROUND 4TH PIECE AS THIS IS SAME AS HRN. - S ID=$$ID^DGLBPID(DFN) S HRN=$$HRN^DGLBPID(DFN) - I (ID=HRN)&(HRN'="") S ID="'"_ID_"'" - ; - ;VWPT LINE BELOW WITH ID SUBSTITUTED FOR 9TH PIECE OF X - S X=^DPT(DFN,0),REC=$P(X,U,1,3)_U_ID_U_U_$G(^(.1))_U_$G(^(.101)) - ; End VOE mod - ; - ; Following taken from ORWPT call to VWPT1 to save space - ; - S X=$P(REC,U,6) I $L(X) S $P(REC,U,5)=+$G(^DIC(42,+$O(^DIC(42,"B",X,0)),44)) - S $P(REC,U,8)=$$CWAD^ORQPT2(DFN)_U_$$EN1^ORQPT2(DFN) - S X=$G(^DPT(DFN,.105)) I X S $P(REC,U,10)=$P($G(^DGPM(X,0)),U) - S:'$D(IOST) IOST="P-OTHER" - S $P(REC,U,11)=$$OTF^OR3CONV(DFN,1) - D ELIG^VADPT S $P(REC,U,12)=$G(VAEL(3)) ;two pieces: SC^SC% - I $L($T(GETICN^MPIF001)) S X=+$$GETICN^MPIF001(DFN) S:X>0 $P(REC,U,14)=X - Q -VWPT2 ;VWPT GET HRN AND ALTERNATE HRN - S $P(REC,U,17)="'"_$$HRN^DGLBPID(DFN)_"'" ;$$HRN^VWVOEDPT(DFN) - S $P(REC,U,18)=$$ALTHRN(DFN) - K VAEL,VAERR ;VADPT call to kill? - S ^DISV(DUZ,"^DPT(")=DFN - Q -ALTHRN(DFN) ; - Q "" +ORWPT2 ; VOE//GT/GOW REV - Patient Lookup Functions ;8/13/07 17:45 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**269**;Dec 17, 1997 LOCAL ;Build 28 + ; 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 + ; + ;;VOE VWPT PACKAGE ENHANCEMENT UPDATES ADDED 11/14/06 + ;GFT PATIENT LOOKUP' RPC CALLS HERE FOR GENERAL PATIENT LOOKUP + ; Ref. to ^UTILITY via IA 10061 + ; + Q + ;VWVOEDPT ;GFT VOE PATIENT LOOKUP;6OCT2006 + ;;5.3;Registration;VWVF VOE LOCAL + ; + ;;Q + ; +LOOKUP(LST,X1) ;'GFT PATIENT LOOKUP' RPC CALLS HERE FOR GENERAL PATIENT LOOKUP + K LST + N GFTI,I,X,ILEN,IEN2,IENN,TAB,ILENP,X3,IEND,CR,XX + N IRET + N IDTMP,AJJTMP,AJJTMP1 + ; + S X=X1 + I X="" Q + S IEND=0 + ;UPPERCASE IT + X "F %=1:1:$L(X) S:$E(X,%)?1L X=$E(X,0,%-1)_$C($A(X,%)-32)_$E(X,%+1,999)" + S ILEN=$L(X) + ;CHECK INPUT TAB POSTION 20, 25, 30 WITH PRECEDING TRAILING BLANKS + ;CHECK FOR INITITAL LOOKUP BY DFN AS !DFN + ;CHECK FOR LOOKUP BY DFN AS 3 TAB POSITION FOR CLICKING AFTER PREVIOUS LOOKUP + S TAB=$C(9) + S X3=$P(X,TAB,3) + I X3'="",X3'="OPT" D + .S X=X3 + .S ILENP=$L(X) + .S X=$E(X,2,ILENP) ;TAKEOUT ! + .S U="^",(GFTI,I)=0 + .D LISTPOPD(X) + .S IEND=1 + E D + .S X=$P(X,TAB,1) + I IEND=1 Q + I $E(X1,1,1)="'" D + .I ILEN'=1 S X=$E(X1,2,ILEN) + .;CHECK FOR ENDING "'" + .S CR=$C(13) + .I $E(X1,ILEN,ILEN)'="'" S IEND=1 + .S X=$P(X,"'",1) + S U="^",(GFTI,I)=0 + I IEND=1 Q + S XX=X ; NO CR FOR HRN + F S IRET=$$CHKX(X) Q:IRET'=1 S I=$O(^AUPNPAT("D",X,I)) Q:'I I X=$$HRN^DGLBPID(I) D LISTPOPH(I) ;I X=$P($$HRN^DGLBPID(I),"#",2 + Q:GFTI + ; + S X=XX + ;NOW CHECK FOR B CROSS REFERENCE + D FIND^DIC(2,,,"MPC",X,,"B") ; ^SSN^BS5") + F I=0:0 S I=$O(^TMP("DILIST",$J,I)) Q:'I D LISTPOPB(+^(I,0)) + K ^TMP("DILIST",$J) + Q:GFTI>0 +OVETT ; + Q:ILEN<4 ;USE ADOB LOOKUP XXX- + ; + ; + ; + ; NEW EDITS/GOW 8/12/07 BELOW. CHECK TO PREVENT ASSUMED CURRENT YEAR TRIGGER + ; SELECTION AUTOMATICALLY WITH JUST MONTH DAY OR MM/DD INPUT. REQUIRE REMAINING YR ( 2 DIGIT MINIMUM) + ; WE CAN USE NUMERIC ENTRY ( IE 2-3-56, 2/3/56 OR 2.3.56, JUN 12,68, ETC OR 4 DIGIT YEAR FOR EXPLICIT YEAR ENTRY, IE JUNE 1,1903 + S NOCONTIN=0 + D + .S NOCONTIN=1 + .S IDTMP=$E($TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"),1,30) + .I IDTMP'=X D + ..S AJJTMP=$L($TR($P(X,",",2)," ")) I AJJTMP>1 S NOCONTIN=0 Q ;CASE FOR SPECIFIC DATE ENTRY BY ALPHABETIC MONTH DAY AND "," AND AT LEAST 2 YR DATE + ..S AJJTMP=$L($TR($P(X," ",2),",")) I AJJTMP>3 S NOCONTIN=0 Q ;CASE FOR SPECIFIC ( MONTH DAY followed by " " (space) and Year ( 2 or4 digit yr) + .I IDTMP'=X Q ; ALPHABETICAL DATE OF SOME KIND WHICH HAS BEEN TESTED ALREADY + .S AJJTMP=$L($TR($P(X,"-",3)," ")) I AJJTMP>1 S NOCONTIN=0 ;NUMERIC INPUT + .S AJJTMP=$L($TR($P(X,"/",3)," ")) I AJJTMP>1 S NOCONTIN=0 ; NUMERIC INPUT + .S AJJTMP=$L($TR($P(X,".",3)," ")) I AJJTMP>1 S NOCONTIN=0 ; NUMERIC INPUT + I NOCONTIN=1 G TRYPH ; TRY PHONE # + ;END EDITS/GOW + ; + ; + D FIND^DIC(2,,,"MPC",X,,"ADOB^B") ;^SSN^BS5") + F I=0:0 S I=$O(^TMP("DILIST",$J,I)) Q:'I D LISTPOP(+^(I,0),X1) + K ^TMP("DILIST",$J) + Q:GFTI>0 + ;TRY PHONE # WITH TRANSLATE +TRYPH ; + Q:ILEN<10 + S X=$E($TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!@#$%^&*()-_=+[]{}<>,./?:;'\|"),1,30) + D FIND^DIC(2,,,"MPC",X,,"AZVWVOE^B") ;^SSN^BS5") + F I=0:0 S I=$O(^TMP("DILIST",$J,I)) Q:'I D LISTPOPP(+^(I,0),X1) + K ^TMP("DILIST",$J) + Q +CHKX(X) ;CHECK TO SEE IF LEGITIMATE HRN EXISTS FOR IHS PATIENT HRN + N IDX,ILENM1,IFLAG + S IFLAG=0 + S IDX=X + ;TO SEE blank char inserts + S ILENM1=$L(X)-1 + I ILENM1>0 D + .S IDX=$E(X,1,ILENM1) + E D + .S IDX="" + F S IDX=$O(^AUPNPAT("D",IDX)) Q:(IDX="")!(IFLAG=1) D + . I IDX=X S IFLAG=1 + Q IFLAG +CHKXB(X1) ;CHECK TO SEE IF PATIENT NAME ENTERED TO ALLOW LOOKUP EVEN FOR SENSITIVE PATIENT + N IDX,ILENM1,IFLAG,X + S IFLAG=0 + S X=X1 + ;CONVERT UPPER CASE + X "F %=1:1:$L(X) S:$E(X,%)?1L X=$E(X,0,%-1)_$C($A(X,%)-32)_$E(X,%+1,999)" + S IDX=X + ;TO SEE blank char inserts + S ILENM1=$L(X)-1 + I ILENM1>0 D + .S IDX=$E(X,1,ILENM1) + E D + .S IDX="" + F S IDX=$O(^DPT("B",IDX)) Q:(IDX="")!(IFLAG=1) D + . I IDX=X S IFLAG=1 + Q IFLAG +LISTPOPB(DFN) ;PATIENT NAME B X-REF + N IEN + N HRN,PHONE,X + Q:($$SCREEN^DPTLK1(DFN)) ;SCREEN FOR VIP + Q:GFTI=-1 I GFTI>500 K LST S GFTI=-1 ;WE RETURN 500 VALUES MAX + S PHONE=$P($G(^DPT(DFN,.13)),U),HRN=$$HRN^DGLBPID(DFN) + S GFTI=GFTI+1,LST(GFTI)=DFN_U_$P(^DPT(DFN,0),U)_U_$$FMTE^XLFDT($P(^(0),U,3))_TAB_"!"_DFN_U_$$ID^DGLBPID(DFN)_U_"'"_HRN_"'"_U_PHONE + Q +LISTPOP(DFN,X1) ;DOB + N IEN + N HRN,PHONE,X + S IEN=$$CHKXB(X1) ;ALLOW INPUT BY NAME ON CLICK + Q:($$SCREEN^DPTLK1(DFN))&(IEN=0) ;SCREEN FOR VIP + Q:GFTI=-1 I GFTI>500 K LST S GFTI=-1 ;WE RETURN 500 VALUES MAX + S PHONE=$P($G(^DPT(DFN,.13)),U),HRN=$$HRN^DGLBPID(DFN) + S GFTI=GFTI+1,LST(GFTI)=DFN_U_$P(^DPT(DFN,0),U)_U_$$FMTE^XLFDT($P(^(0),U,3))_TAB_"!"_DFN_U_$$ID^DGLBPID(DFN)_U_"'"_HRN_"'"_U_PHONE + Q +LISTPOPP(DFN,X1) ;PHONE # + N IEN + N HRN,PHONE,X + S IEN=$$CHKXB(X1) ;ALLOW INPUT BY NAME ON CLICK + Q:($$SCREEN^DPTLK1(DFN))&(IEN=0) ;SCREEN FOR VIP + Q:GFTI=-1 I GFTI>500 K LST S GFTI=-1 ;WE RETURN 500 VALUES MAX + S PHONE=$P($G(^DPT(DFN,.13)),U),HRN=$$HRN^DGLBPID(DFN) + S GFTI=GFTI+1,LST(GFTI)=DFN_U_$P(^DPT(DFN,0),U)_U_PHONE_TAB_"!"_DFN_U_$$ID^DGLBPID(DFN)_U_"'"_HRN_"'"_U_PHONE + Q + ; +LISTPOPH(DFN) ;Q:$$SCREEN^DPTLK1(DFN) ;SCREEN FOR VIP FOR HRN + N HRN,PHONE + Q:GFTI=-1 I GFTI>500 K LST S GFTI=-1 ;WE RETURN 500 VALUES MAX + S PHONE=$P($G(^DPT(DFN,.13)),U),HRN=$$HRN^DGLBPID(DFN) + S GFTI=GFTI+1,LST(GFTI)=DFN_U_$P(^DPT(DFN,0),U)_U_"'"_HRN_"'"_TAB_"!"_DFN_U_$$FMTE^XLFDT($P(^(0),U,3))_U_$$ID^DGLBPID(DFN)_U_"'"_HRN_"'"_U_PHONE + Q +LISTPOPD(DFN) ; + N IEN + N HRN,PHONE,X + ;NO SCREEN FOR VIP + Q:GFTI=-1 I GFTI>500 K LST S GFTI=-1 ;WE RETURN 500 VALUES MAX + S PHONE=$P($G(^DPT(DFN,.13)),U),HRN=$$HRN^DGLBPID(DFN) + S GFTI=GFTI+1,LST(GFTI)=DFN_U_$P(^DPT(DFN,0),U)_U_$$FMTE^XLFDT($P(^(0),U,3))_TAB_"!"_DFN_U_$$ID^DGLBPID(DFN)_U_"'"_HRN_"'"_U_PHONE + Q + ; +VWPT1 ;VWPT NEW LOGIC . 4TH PIECE BELOW REPLACE $P(X,U,9)=SSN WITH ID AS $$ID^DGLBPID(DFN) + ; THEN IF THIS VALUE = HRN AND BOTH '="" THEN PUT SINGLE QUOTES + ; AROUND 4TH PIECE AS THIS IS SAME AS HRN. + S ID=$$ID^DGLBPID(DFN) S HRN=$$HRN^DGLBPID(DFN) + I (ID=HRN)&(HRN'="") S ID="'"_ID_"'" + ; + ;VWPT LINE BELOW WITH ID SUBSTITUTED FOR 9TH PIECE OF X + S X=^DPT(DFN,0),REC=$P(X,U,1,3)_U_ID_U_U_$G(^(.1))_U_$G(^(.101)) + ; End VOE mod + ; + ; Following taken from ORWPT call to VWPT1 to save space + ; + S X=$P(REC,U,6) I $L(X) S $P(REC,U,5)=+$G(^DIC(42,+$O(^DIC(42,"B",X,0)),44)) + S $P(REC,U,8)=$$CWAD^ORQPT2(DFN)_U_$$EN1^ORQPT2(DFN) + S X=$G(^DPT(DFN,.105)) I X S $P(REC,U,10)=$P($G(^DGPM(X,0)),U) + S:'$D(IOST) IOST="P-OTHER" + S $P(REC,U,11)=$$OTF^OR3CONV(DFN,1) + D ELIG^VADPT S $P(REC,U,12)=$G(VAEL(3)) ;two pieces: SC^SC% + I $L($T(GETICN^MPIF001)) S X=+$$GETICN^MPIF001(DFN) S:X>0 $P(REC,U,14)=X + Q +VWPT2 ;VWPT GET HRN AND ALTERNATE HRN + S $P(REC,U,17)="'"_$$HRN^DGLBPID(DFN)_"'" ;$$HRN^VWVOEDPT(DFN) + S $P(REC,U,18)=$$ALTHRN(DFN) + K VAEL,VAERR ;VADPT call to kill? + S ^DISV(DUZ,"^DPT(")=DFN + Q +ALTHRN(DFN) ; + Q "" diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPT3.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPT3.m index dd171843..73b70354 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPT3.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPT3.m @@ -1,159 +1,159 @@ -ORWPT3 ; VOE/GOW /REV - Patient Lookup Functions ;8/13/07 17:49 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**269**;Dec 17, 1997 LOCAL ;Build 29 - ; 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 - ;'Modified' MAS Patient Look-up Check Cross-References June 1987 - ;;VOE VWPT PACKAGE ENHANCEMENT UPDATES ADDED WITH "OTHER" RADIOBUTTON LOOKUPS FOR DOB AND PHONE NO 11/14/06 - ; - ; Ref. to ^UTILITY via IA 10061 - ; - Q - ; - ;VWPT ENHANCEMENTS folow for "other" RADIO BUTTONlookup -OTHER(LST,IDIN,OTHER) ; RADIO BUTTON Return a list of patients matching other ID identifier - N I,ID,IEN,ILENX,XREF,IDM1,ILEN1,ILNM1,ILENM1,IDD1,IPAST1,IDXX,IDSS,IDD2,LEN1,IFDN,IDX,IDS,DATEF,ILEN1,IPAST,ZVW,TEMP,IVAL,IVAR1,IFIND,IFDNS,IVAR,ARRAY,ERRARRAY,IENS - N IEN2,IENN,TAB,IX - N ILENP,X3,IEND,IDXS,IENNNN - N IDTMP,AJJTMP,AJJTMP1 - I IDIN="" Q - S (I,IEN,IEND)=0 - S ID=IDIN - S X=ID - S ILENX=$L(X) - ;REMOVES TABS - ;CHECK INPUT TAB POSTION 20, 25, 30 WITH PRECEDING TRAILING BLANKS - S TAB=$C(9) - S IX=$P(X,TAB,3) ; WAS 2ND POS - I IX'="" D - .S ILENP=$L(IX) - .S X=$E(IX,2,ILENP) ; JUMP OVER ! - .S LST(1)=X_U_$P(^DPT(X,0),U)_U_$$FMTE^XLFDT($P(^(0),U,3))_TAB_"!"_X_U_$$ID^DGLBPID(X) ; $$SSN^DPTLK1_U_IVAL ; RETURN OTHER AS 5TH PIECE - .; - .S IEND=1 - E D - .;JUST UPPER CASE IT - .;UPPERCASE IT - .X "F %=1:1:$L(X) S:$E(X,%)?1L X=$E(X,0,%-1)_$C($A(X,%)-32)_$E(X,%+1,999)" - I IEND=1 Q - S ID=X - ;OTHER IS FIELD NAME - ;GET THE FIELD NUMBER - S IFDN=0 - S IFDN=$O(^DD(2,"B",OTHER,IFDN)) - I IFDN="" Q - ;FOR NOW JUST USE ONE OF TWO CROSS-REFERENCES , - ;ONE FOR DOB AS ADOB AND THE OTHER FOR PHONE # AS AZVWVOE - I OTHER="DATE OF BIRTH" S ICREF="ADOB" - I OTHER="PHONE NUMBER [RESIDENCE]" D - .S ICREF="AZVWVOE" - .S ID=$E($TR(ID,"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!@#$%^&*()-_=+[]{}<>,./?:;'\|"),1,30) - I ICREF="AZVWVOE" I ILENX<7 Q - ; - ; NEW EDITS/GOW 8/12/07 BELOW. RADIO BUTTON HAS SLIGHTLY DIFFERENT FUNCTIONALITY THAN - ; WITH GENERIC MULTI-SOURCE LOOKUP. ALSO, CHECK TO PREVENT ASSUMED CURRENT YEAR TRIGGER - ; SELECTION AUTOMATICALLY WITH JUST MONTH DAY OR MM/DD INPUT. REQUIRE REMAINING YR ( 2 DIGIT MINIMUM) - ; THE LOGIC ALLOWED A FUZZY MONTH ONLY LOOKUP FOR DOB AS A SPECIFIC DOB MAY NOT BE KNOWN ,OR REMEMBERED. - ; FOR FUZZY LOGIC REQUIRE 4 DIGIT YEAR ON DATE RANGE W/O SPECIFIC DAY(DATE) ENTERED - ; EXAMPLE, AS MONTH/YEAR ( IE, JUN 2005). NOW, MAKE CHANGE TO ALLOW THIS ONLY BY APHABETIC MONTH AND NUMERIC YEAR (2 OR 4 DIGIT) LOOKUP - ; THEN FOR SPECIFIC DOB LOOKUP WITH RADIO BUTTON SELECTION, WE CAN USE NUMERIC ENTRY ( IE 2-3-56, 2/3/56 OR 2.3.56 - ; FOR WHICH WAIT FOR SELECTION WILL OCCUR UNTIL AT A TRAILING 2 DIGIT YEAR IS INPUT WITH THE FORMER FORMATS ABOVE - S NOCONTIN=0 - I ICREF="ADOB" D - .S NOCONTIN=1 - .S IDTMP=$E($TR(ID,"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"),1,30) - .I IDTMP'=ID D - ..;ALPHABETIC FUZZY MONTH ALLOWED or a specific date for at least a 4 DIGIT year that must specified after a "," ( ie June 15,1968) - ..;OTHERWISE CHECK FOR TRAILING YEAR - ..S AJJTMP=$L($TR($P(ID,",",2)," ")) I AJJTMP>1 S NOCONTIN=0 Q ;CASE FOR SPECIFIC DATE ENTRY BY ALPHABETIC MONTH DAY AND "," AND AT LEAST 2 YR DATE - ..S AJJTMP=$L($TR($P(ID," ",2),",")) I AJJTMP>3 S NOCONTIN=0 Q ;CASE FOR SPECIFIC ( MONTH DAY followed by " " (space) and Year ( 2 or4 digit yr) - ..S AJJTMP=$L($TR($P(ID," ",2)," ")) I AJJTMP>3 S AJJTMP1=$TR(AJJTMP,",") I AJJTMP1=AJJTMP S NOCONTIN=0 Q ;CASE FOR FUZZY DATE ( MONTH followed by " " (space) and Year (4 digit yr) - .I IDTMP'=ID Q ; ALPHABETICAL DATE OF SOME KIND WHICH HAS BEEN TESTED ALREADY - .S AJJTMP=$L($TR($P(ID,"-",3)," ")) I AJJTMP>1 S NOCONTIN=0 ;NUMERIC INPUT - .S AJJTMP=$L($TR($P(ID,"/",3)," ")) I AJJTMP>1 S NOCONTIN=0 ; NUMERIC INPUT - .S AJJTMP=$L($TR($P(ID,".",3)," ")) I AJJTMP>1 S NOCONTIN=0 ; NUMERIC INPUT - I NOCONTIN=1 Q - ;END EDITS/GOW - ; - S IDX=ID - ;TO SEE blank char inserts - S ILENM1=$L(ID)-1 - I ILENM1>0 D - .;S IDLC=$E(ID,1,ILENM1) - .S IDX=$E(ID,1,ILENM1) S IDXS=IDX - E D - .S IDX="" S IDXS=IDX - Q:ILENX<4 ;USE PHONE NUMBER LOOKUP XXX- - ;HOWEVER ID DATE OR DATE/TIME FIELD CONVERT ID TO - ;INTERNAL TIME - S DATEF=$P($G(^DD(2,IFDN,0)),"^",2) - I DATEF["D" D - .;NEW BELOW - .S X=ID D ^%DT S IDX=Y S IDS=Y - .I Y'=-1 D - . . S ILNM1=$L(IDX)-1 - . . S IDX=$E(IDX,1,ILNM1) - . . ;W !,"IDX=",IDX,"IDS=",IDS - S IPAST=0 - S IPAST1=0 - S ILEN1=$L(ID) - F S IDX=$O(^DPT(ICREF,IDX)) Q:(IDX="")!(IPAST1=1) D - . S IEN=0 - . ;EXTRA TO GET TRAILING SPACES - . I DATEF'["D" D - . . S IDD1=$E(IDX,1,ILEN1) I $L(IDD1),./?:;'\|"),1,30) + I ICREF="AZVWVOE" I ILENX<7 Q + ; + ; NEW EDITS/GOW 8/12/07 BELOW. RADIO BUTTON HAS SLIGHTLY DIFFERENT FUNCTIONALITY THAN + ; WITH GENERIC MULTI-SOURCE LOOKUP. ALSO, CHECK TO PREVENT ASSUMED CURRENT YEAR TRIGGER + ; SELECTION AUTOMATICALLY WITH JUST MONTH DAY OR MM/DD INPUT. REQUIRE REMAINING YR ( 2 DIGIT MINIMUM) + ; THE LOGIC ALLOWED A FUZZY MONTH ONLY LOOKUP FOR DOB AS A SPECIFIC DOB MAY NOT BE KNOWN ,OR REMEMBERED. + ; FOR FUZZY LOGIC REQUIRE 4 DIGIT YEAR ON DATE RANGE W/O SPECIFIC DAY(DATE) ENTERED + ; EXAMPLE, AS MONTH/YEAR ( IE, JUN 2005). NOW, MAKE CHANGE TO ALLOW THIS ONLY BY APHABETIC MONTH AND NUMERIC YEAR (2 OR 4 DIGIT) LOOKUP + ; THEN FOR SPECIFIC DOB LOOKUP WITH RADIO BUTTON SELECTION, WE CAN USE NUMERIC ENTRY ( IE 2-3-56, 2/3/56 OR 2.3.56 + ; FOR WHICH WAIT FOR SELECTION WILL OCCUR UNTIL AT A TRAILING 2 DIGIT YEAR IS INPUT WITH THE FORMER FORMATS ABOVE + S NOCONTIN=0 + I ICREF="ADOB" D + .S NOCONTIN=1 + .S IDTMP=$E($TR(ID,"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"),1,30) + .I IDTMP'=ID D + ..;ALPHABETIC FUZZY MONTH ALLOWED or a specific date for at least a 4 DIGIT year that must specified after a "," ( ie June 15,1968) + ..;OTHERWISE CHECK FOR TRAILING YEAR + ..S AJJTMP=$L($TR($P(ID,",",2)," ")) I AJJTMP>1 S NOCONTIN=0 Q ;CASE FOR SPECIFIC DATE ENTRY BY ALPHABETIC MONTH DAY AND "," AND AT LEAST 2 YR DATE + ..S AJJTMP=$L($TR($P(ID," ",2),",")) I AJJTMP>3 S NOCONTIN=0 Q ;CASE FOR SPECIFIC ( MONTH DAY followed by " " (space) and Year ( 2 or4 digit yr) + ..S AJJTMP=$L($TR($P(ID," ",2)," ")) I AJJTMP>3 S AJJTMP1=$TR(AJJTMP,",") I AJJTMP1=AJJTMP S NOCONTIN=0 Q ;CASE FOR FUZZY DATE ( MONTH followed by " " (space) and Year (4 digit yr) + .I IDTMP'=ID Q ; ALPHABETICAL DATE OF SOME KIND WHICH HAS BEEN TESTED ALREADY + .S AJJTMP=$L($TR($P(ID,"-",3)," ")) I AJJTMP>1 S NOCONTIN=0 ;NUMERIC INPUT + .S AJJTMP=$L($TR($P(ID,"/",3)," ")) I AJJTMP>1 S NOCONTIN=0 ; NUMERIC INPUT + .S AJJTMP=$L($TR($P(ID,".",3)," ")) I AJJTMP>1 S NOCONTIN=0 ; NUMERIC INPUT + I NOCONTIN=1 Q + ;END EDITS/GOW + ; + S IDX=ID + ;TO SEE blank char inserts + S ILENM1=$L(ID)-1 + I ILENM1>0 D + .;S IDLC=$E(ID,1,ILENM1) + .S IDX=$E(ID,1,ILENM1) S IDXS=IDX + E D + .S IDX="" S IDXS=IDX + Q:ILENX<4 ;USE PHONE NUMBER LOOKUP XXX- + ;HOWEVER ID DATE OR DATE/TIME FIELD CONVERT ID TO + ;INTERNAL TIME + S DATEF=$P($G(^DD(2,IFDN,0)),"^",2) + I DATEF["D" D + .;NEW BELOW + .S X=ID D ^%DT S IDX=Y S IDS=Y + .I Y'=-1 D + . . S ILNM1=$L(IDX)-1 + . . S IDX=$E(IDX,1,ILNM1) + . . ;W !,"IDX=",IDX,"IDS=",IDS + S IPAST=0 + S IPAST1=0 + S ILEN1=$L(ID) + F S IDX=$O(^DPT(ICREF,IDX)) Q:(IDX="")!(IPAST1=1) D + . S IEN=0 + . ;EXTRA TO GET TRAILING SPACES + . I DATEF'["D" D + . . S IDD1=$E(IDX,1,ILEN1) I $L(IDD1)^ - ;;S^Date Range... - ;;0^Today - ;;7^One Week Back - ;;14^Two Weeks Back - ;;30^One Month Back - ;;180^Six Months Back - ;;365^One Year Back - ;;732^Two Years Back - ;;50000^All Results - ;;$$END - ; -SETITEM(ROOT,X) ; -- set item in list - S @ROOT@($O(@ROOT@(9999),-1)+1)=X - Q -RPT(ROOT,DFN,RPTID,HSTYPE,DTRANGE,EXAMID,ALPHA,OMEGA) ; -- return report text - ;ROOT=Output in ^TMP("ORDATA",$J) - ;DFN=Patient DFN ; ICN for remote sites - ;RPTID=Unique report ID_";"_Remote ID_"~"_HSComponent for listview (ent;rtn;0;MaxOcc) or text (ent;rtn;#component;MaxOcc) - ;HSTYPE=Health Sum Type - ;DTRANGE=# days back from today - ;EXAMID=Rad exam ID - ;ALPHA=Start date - ;OMEGA=End date - ; RPC: ORWRP REPORT TEXT - ; - N X,X0,X2,X4,I,J,ENT,RTN,ID,REMOTE,GO,OUT,MAX,SITE,ORFHIE,%ZIS,HSTAG,DIRECT,TAB - K ^TMP("ORDATA",$J) - S TAB="R" - I $E(RPTID,1,2)="L:" S TAB="L",RPTID=$P(RPTID,":",2,999) ;an ID beginning with "L:" forces TAB to LAB - "L:" added in GUI code - S HSTAG=$P($G(RPTID),"~",2),RPTID=$P($G(RPTID),"~"),ROOT=$NA(^TMP("ORDATA",$J,1)),REMOTE=+$P(RPTID,";",2),RPTID=$P($P(RPTID,";"),":") - I 'REMOTE S DFN=+DFN ;DFN = DFN;ICN for remote calls - S I=0,X0="",X2="",X4="",SITE=$$SITE^VASITE,SITE=$P(SITE,"^",2)_";"_$P(SITE,"^",3) - F S I=$O(^ORD(101.24,"AC",I)) Q:I="" S J=0 F S J=$O(^ORD(101.24,"AC",I,J)) Q:'J D - . I $P($G(^ORD(101.24,J,0)),"^",2)=RPTID,$P(^(0),"^",8)=TAB S X0=^(0),X2=$G(^(2)),ORFHIE=$G(^(4)),DIRECT=$P(ORFHIE,"^",4),X4=$P(ORFHIE,"^",2),ORFHIE=$P(ORFHIE,"^",3) - I '$L(X0) D NOTYET(.ROOT) Q - S RTN=$P(X0,"^",5),ENT=$P(X0,"^",6) - I '$L(RTN)!'$L(ENT) D NOTYET(.ROOT) Q - I '$L($T(@(ENT_"^"_RTN))) D NOTYET(.ROOT) Q - ;I $G(ALPHA) S X=ALPHA-$G(OMEGA) D ;jeh 243 - I $G(ALPHA) D - . N X1,X2 - . S X=ALPHA - . S X1=ALPHA,X2=$G(OMEGA) D:X2 ^%DTC ;X returned, # of days diff - . I X<0 S X=X*(-1) - . I X4,X>X4 S:ALPHA>OMEGA OMEGA=$$FMADD^XLFDT(ALPHA,-X4) S:ALPHA'>OMEGA ALPHA=$$FMADD^XLFDT(OMEGA,-X4) S DTRANGE="" - I X4,$G(DTRANGE)>X4 S DTRANGE=X4,ALPHA="" - I $L($G(DTRANGE)),'$G(ALPHA) S ALPHA=$$FMADD^XLFDT(DT,-DTRANGE),OMEGA=DT_".235959" - I $G(OMEGA),$E(OMEGA,8)'="." S OMEGA=OMEGA_".235959" - S ID=$G(HSTAG),$P(ID,";",5,10)=SITE_";"_$P(X2,"^",8)_";"_$P(X2,"^",9)_";"_RPTID_";"_$G(DIRECT) ;HDRHX CHANGE - I $L($P($G(HSTAG),";",4)) S MAX=$P(HSTAG,";",4) - I $L($G(HSTYPE)) M ID=HSTYPE - I $L($G(EXAMID)) M ID=EXAMID - S OUT=ENT_"^"_RTN_"(.ROOT,DFN,.ID,.ALPHA,.OMEGA,.DTRANGE,.REMOTE,.MAX,.ORFHIE)" - I REMOTE S GO=0 D Q:'GO - . I '$L($T(GETDFN^MPIF001)) D SETITEM(.ROOT,"MPI routines missing on remote system ("_SITE_")") S GO=0 Q - . S ICN=+$P(DFN,";",2),DFN=+$$GETDFN^MPIF001(ICN) - . I DFN<0 D SETITEM(.ROOT,"Patient not found on remote system ("_SITE_")") S GO=0 Q - . S GO=+$P(X0,"^",3) - . I 'GO D SETITEM(.ROOT,"Remote access not available for this report ("_SITE_")") - S %ZIS="0N" - D @OUT - Q -NOTYET(ROOT) ; -- not available - D SETITEM(.ROOT,"Report not available at this time.") - Q -START(RM,GOTO,ORIOSL) ; - ;RM=Right margin - N ZTQUEUED,ORHFS,ORSUB,ORIO,ORHANDLE,IOM,IOSL,IOST,IOF,IOT,IOS - S ORHFS=$$HFS(),ORSUB="ORDATA",ORHANDLE="ORWRP" - D HFSOPEN(ORHANDLE,ORHFS,"W") - I POP D Q - . I $D(ROOT) D SETITEM(.ROOT,"ERROR: Unable to open HFS file") - D IOVAR(.ORIO,.RM,.ORIOSL) - N $ETRAP,$ESTACK - S $ETRAP="D ERR^ORWRP Q" - U IO - D @GOTO - D HFSCLOSE(ORHANDLE,ORHFS) - Q -ERR ;Error trap - S $ETRAP="D UNWIND^ORWRP Q" - N %ZIS - S %ZIS="0N" - D @^%ZOSF("ERRTN") ;file error - I $D(ORHANDLE) D CLOSE^%ZISH(ORHANDLE) - I $D(ORHFS) D - . N ORARR,OROK - . S ORARR(ORHFS)="",OROK=$$DEL^%ZISH("",$NA(ORARR)) ;delete HFS file - S $ECODE=",UOR69 error during CPRS report build," - Q -UNWIND ;Unwind Error stack - Q:$ESTACK>1 ;pop stack - ; - Q -HFS() ; -- get hfs file name - N H - S H=$H - Q "ORU_"_$J_"_"_$P(H,",")_"_"_$P(H,",",2)_".DAT" -HFSOPEN(HANDLE,ORHFS,ORMODE) ; - D OPEN^%ZISH(HANDLE,,ORHFS,$G(ORMODE,"W")) Q:POP - Q -IOVAR(ORIO,ORRM,ORIOSL,ORIOST,ORIOF,ORIOT) ;Setup IO variables based on IO Device - N IFN,IFN1 - S ORIO=$G(ORIO,"OR WORKSTATION"),ION=ORIO,IOM=$G(ORRM,80),IOSL=$G(ORIOSL,62),IOST=$G(ORIOST,"P-OTHER"),IOF=$G(ORIOF,""""""),IOT=$G(ORIOT,"HFS") - I $O(^%ZIS(1,"B",ORIO,0)) S IFN=$O(^(0)),IOS=IFN - I $D(^%ZIS(1,IFN,0)) S IOST(0)=+$G(^("SUBTYPE")),IOT=$G(ORIOT,^("TYPE")),IOST=$G(ORIOST,$P($G(^%ZIS(2,IOST(0),0),IOST),"^")) - I $O(^%ZIS(2,"B",IOST,0)) S IFN=$O(^(0)) I IFN S IOST(0)=IFN,IFN1=$G(^%ZIS(2,IFN,1)),IOM=$G(ORRM,$P(IFN1,"^")),IOF=$G(ORIOF,$P(IFN1,"^",2)),IOSL=$G(ORIOSL,$P(IFN1,"^",3)) - Q -HFSCLOSE(HANDLE,ORHFS) ;Close HFS and unload data - N ORDEL,X,%ZIS - S %ZIS="0N" - I IO[ORHFS D CLOSE^%ZISH(HANDLE) - S ROOT=$NA(^TMP(ORSUB,$J,1)),ORDEL(ORHFS)="" - K @ROOT - S X=$$FTG^%ZISH(,ORHFS,$NA(@ROOT@(1)),4) - D STRIP - S X=$$DEL^%ZISH(,$NA(ORDEL)) - Q -USEHFS ; -- use host file to build global array - N OROK,SECTION - S SECTION=0 - D INIT - S OROK=$$FTG^%ZISH(,ORHFS,$NA(@ROOT@(1)),4) I 'OROK Q - D STRIP - N ORARR S ORARR(ORHFS)="" - S OROK=$$DEL^%ZISH("",$NA(ORARR)) - Q -INIT ; -- initialize counts and global section - S (INC,CNT)=0,SECTION=SECTION+1,ROOT=$NA(^TMP(ORSUB,$J,SECTION)) - K @ROOT - Q -FINAL ; -- set 'x of y' for each section CALLED FROM ^ORWLR - N I - F I=1:1:SECTION S ^TMP(ORSUB,$J,I,.1)=I_U_SECTION - Q -STRIP ; -- strip off control chars - N I,X - S I=0 F S I=$O(@ROOT@(I)) Q:'I S X=^(I) D - . I X[$C(8) D ;BS - .. I $L(X,$C(8))=$L(X,$C(95)) S (X,@ROOT@(I))=$TR(X,$C(8,95),"") Q ;BS & _ - .. S (X,@ROOT@(I))=$TR(X,$C(8),"") - . I X[$C(7)!(X[$C(12)) S @ROOT@(I)=$TR(X,$C(7,12),"") ;BEL or FF - Q -WINDFLT(ORY) ;Windows printer as default? - S ORY=+$$GET^XPAR("ALL","ORWDP WINPRINT DEFAULT") - Q -GETDFPRT(Y,ORUSER,ORLOC) ; Returns default printer for user - N IEN,X0,ENT - S ENT="ALL" - I $G(ORLOC) S ORLOC=+ORLOC_";SC(",ENT=ENT_"^"_ORLOC - I +$$GET^XPAR(ENT,"ORWDP WINPRINT DEFAULT") S Y="WIN;Windows Printer" Q - S IEN=$$GET^XPAR(ENT,"ORWDP DEFAULT PRINTER",1) Q:+IEN=0 - Q:'$D(^%ZIS(1,IEN,0)) S X0=^(0) - S Y=IEN_";"_$P(X0,U) - Q -SAVDFPRT(Y,ORDEV) ; Save new default printer for user - N ORPAR,ORERR,ORWINDEF - Q:$L(ORDEV)=0 - ; Reset Windows printer default to True/False - S ORPAR="ORWDP WINPRINT DEFAULT" - I ORDEV="WIN" S ORWINDEF="Y" - E S ORWINDEF="N" - I $$GET^XPAR(DUZ_";VA(200,",ORPAR,1)'="" D CHG^XPAR(DUZ_";VA(200,",ORPAR,1,ORWINDEF,.ORERR) - E D ADD^XPAR(DUZ_";VA(200,",ORPAR,1,ORWINDEF,.ORERR) - Q:ORDEV="WIN" - ; If not Windows printer selected, save VistA default printer - S ORPAR="ORWDP DEFAULT PRINTER",ORDEV="`"_ORDEV - I $$GET^XPAR(DUZ_";VA(200,",ORPAR,1)'="" D CHG^XPAR(DUZ_";VA(200,",ORPAR,1,ORDEV,.ORERR) - E D ADD^XPAR(DUZ_";VA(200,",ORPAR,1,ORDEV,.ORERR) - Q +ORWRP ; ALB/MJK,dcm Report Calls ; 12/05/02 11:03 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**1,10,85,109,132,160,194,227,215,262**;Dec 17, 1997;Build 3 + ; +LABLIST(LST) ; -- report list for labs tab + ; RPC: ORWRP LAB REPORT LIST + N I,J,X,X0,X2,CNT,EOF,IFN,ROOT,RPC,ORLIST,HEAD + S EOF="$$END",ROOT=$NA(LST),(CNT,I)=0 + D SETITEM(ROOT,"[LAB REPORT LIST]") + D GETLST^XPAR(.ORLIST,"ALL","ORWRP REPORT LAB LIST") + F S I=$O(ORLIST(I)) Q:'I Q:'$D(^ORD(101.24,$P(ORLIST(I),"^",2),0)) S X0=^(0),X2=$G(^(2)) D + . Q:$P(X0,"^",12)="L" + . S RPC=$$GET1^DIQ(8994,+$P(X0,"^",13),.01),IFN=ORLIST(I),HEAD=$P(X0,"^") + . I $L($P(X2,"^",3)) S HEAD=$P(X2,"^",3) + . S X=$P(X0,"^",2)_"^"_HEAD_"^"_$P(X0,"^",3)_"^"_$P(X0,"^",12)_"^"_$P(X0,"^",7)_"^"_RPC_"^"_IFN + . D SETITEM(.ROOT,X) + D SETITEM(.ROOT,"$$END") + Q +LIST(LST) ; -- report lists for reports tab + ; RPC: ORWRP REPORT LIST + N EOF,ROOT + S EOF="$$END",ROOT=$NA(LST) + K @ROOT + D GETRPTS(.ROOT,.EOF) ; -report list + D GETHS(.ROOT,.EOF) ; -health summary types + D GETDT(.ROOT,.EOF) ; -date ranges + Q +GETCOL(ROOT,IFN) ; -- get Column headers for ListView + N I,J,X,VAL + Q:'$G(IFN) + S I=0,ROOT=$NA(ROOT) + F S I=$O(^ORD(101.24,IFN,3,"C",I)) Q:'I D + . S VAL=$$GET^XPAR(DUZ_";VA(200,","ORWCH COLUMNS REPORTS",IFN,"I"),J=0 + . F S J=$O(^ORD(101.24,IFN,3,"C",I,J)) Q:'J I $D(^ORD(101.24,IFN,3,J)) S X=^(J,0) D + .. I $L(VAL),$P(VAL,",",I) S $P(X,"^",10)=$P(VAL,",",I) + .. D SETITEM(.ROOT,X) + Q +GETRPTS(ROOT,EOF) ; -- get report list + N I,J,X,X0,X2,CNT,IFN,ORLIST,HEAD + D SETITEM(.ROOT,"[REPORT LIST]"),GETLST^XPAR(.ORLIST,"ALL","ORWRP REPORT LIST") + S (CNT,I)=0 + F S I=$O(ORLIST(I)) Q:'I Q:'$D(^ORD(101.24,$P(ORLIST(I),"^",2),0)) S X0=^(0),X2=$G(^(2)) D + . Q:$P(X0,"^",12)="L" + . S RPC=$$GET1^DIQ(8994,+$P(X0,"^",13),.01),IFN=ORLIST(I),HEAD=$P(X0,"^") + . I $L($P(X2,"^",3)) S HEAD=$P(X2,"^",3) + . S X=$P(X0,"^",2)_"^"_HEAD_"^"_$P(X0,"^",4)_"^"_$P(X0,"^",19)_";"_$P(X0,"^",20)_"^"_$P(X0,"^",6)_"^"_$P(X0,"^",5)_"^"_$P(X0,"^",3)_"^"_$P(X0,"^",12)_"^"_$P(X0,"^",7)_"^"_RPC_"^"_IFN + . D SETITEM(.ROOT,X) + D SETITEM(.ROOT,"$$END") + Q +GETHS(ROOT,EOF) ; --get health summary types + N C,I,IFN,ORHSPARM,ORERR,X,T + K ^TMP("ORHSPARM",$J) + S ORHSROOT="^TMP(""ORHSPARM"",$J)" + I $$GET^XPAR("ALL","ORWRP HEALTH SUMMARY LIST ALL",1) S I="",C=0 D + . F S I=$O(^GMT(142,"B",I)) Q:I="" S IFN=$O(^(I,0)) Q:'IFN D + .. S X=$G(^GMT(142,IFN,0)) Q:'$L(X) + .. S T=$G(^GMT(142,IFN,"T")),C=C+1,@ORHSROOT@(C)=IFN_"^"_$S($L(T):T,1:$P(X,"^"))_"^^^^^1" + .. I I="GMTS HS ADHOC OPTION" S @ORHSROOT@(C)="0^GMTS Adhoc Report" + I '$$GET^XPAR("ALL","ORWRP HEALTH SUMMARY LIST ALL",1) D + . D:$L($T(GETLIST^GMTSXAL)) GETLIST^GMTSXAL($NA(@ORHSROOT),$G(DUZ),1,.ORERR) + . Q:$G(ORERR) + . S I=0 F S I=$O(@ORHSROOT@(I)) Q:'I S @ORHSROOT@(I)=@ORHSROOT@(I)_"^^^^^1" I $P(@ORHSROOT@(I),"^",2)="GMTS HS ADHOC OPTION" S @ORHSROOT@(I)="0^Adhoc Report" + D SETITEM(.ROOT,"[HEALTH SUMMARY TYPES]") + S I=0 F S I=$O(@ORHSROOT@(I)) Q:'I D SETITEM(.ROOT,"h"_@ORHSROOT@(I)) + D SETITEM(.ROOT,EOF) + Q +GETDT(ROOT,EOF) ; -- get date range choices + N I,X + D SETITEM(.ROOT,"[DATE RANGES]") + F I=2:1 S X=$P($T(DTLIST+I),";",3) Q:X=EOF D SETITEM(.ROOT,"d"_X) + Q +DTLIST ; -- list of date ranges + ;^ + ;;S^Date Range... + ;;0^Today + ;;7^One Week Back + ;;14^Two Weeks Back + ;;30^One Month Back + ;;180^Six Months Back + ;;365^One Year Back + ;;$$END + ; +SETITEM(ROOT,X) ; -- set item in list + S @ROOT@($O(@ROOT@(9999),-1)+1)=X + Q +RPT(ROOT,DFN,RPTID,HSTYPE,DTRANGE,EXAMID,ALPHA,OMEGA) ; -- return report text + ;ROOT=Output in ^TMP("ORDATA",$J) + ;DFN=Patient DFN ; ICN for foriegn sites + ;RPTID=Unique id for the report_";"_Remote Id_"~"_HSComponent for listview (ent;rtn;0;MaxOcc) or text (ent;rtn;#component;MaxOcc) + ;HSTYPE=Health Sum Type + ;DTRANGE=# days back from today + ;EXAMID=Rad exam ID + ;ALPHA=Start date (lieu of DTRANGE) + ;OMEGA=End date (lieu of DTRANGE) + ; RPC: ORWRP REPORT TEXT + ; + N X,X0,X2,X4,I,J,ENT,RTN,ID,REMOTE,GO,OUT,MAX,SITE,ORFHIE,%ZIS,HSTAG,DIRECT + K ^TMP("ORDATA",$J) + S HSTAG=$P($G(RPTID),"~",2),RPTID=$P($G(RPTID),"~"),ROOT=$NA(^TMP("ORDATA",$J,1)),REMOTE=+$P(RPTID,";",2),RPTID=$P($P(RPTID,";"),":") + I 'REMOTE S DFN=+DFN ;DFN = DFN;ICN for remote calls + S I=0,X0="",X2="",X4="",SITE=$$SITE^VASITE,SITE=$P(SITE,"^",2)_";"_$P(SITE,"^",3) + F S I=$O(^ORD(101.24,"AC",I)) Q:I="" S J=0 F S J=$O(^ORD(101.24,"AC",I,J)) Q:'J D + . I $P($G(^ORD(101.24,J,0)),"^",2)=RPTID,$P(^(0),"^",8)="R" S X0=^(0),X2=$G(^(2)),ORFHIE=$G(^(4)),DIRECT=$P(ORFHIE,"^",4),X4=$P(ORFHIE,"^",2),ORFHIE=$P(ORFHIE,"^",3) + I '$L(X0) D NOTYET(.ROOT) Q + S RTN=$P(X0,"^",5),ENT=$P(X0,"^",6) + I '$L(RTN)!'$L(ENT) D NOTYET(.ROOT) Q + I '$L($T(@(ENT_"^"_RTN))) D NOTYET(.ROOT) Q + I $G(ALPHA) S X=ALPHA-$G(OMEGA) D + . I X<0 S X=X*(-1) + . I X4,X>X4 S:ALPHA>OMEGA OMEGA=$$FMADD^XLFDT(ALPHA,-X4) S:ALPHA'>OMEGA ALPHA=$$FMADD^XLFDT(OMEGA,-X4) S DTRANGE="" + I X4,$G(DTRANGE)>X4 S DTRANGE=X4,ALPHA="" + I $L($G(DTRANGE)),'$G(ALPHA) S ALPHA=$$FMADD^XLFDT(DT,-DTRANGE),OMEGA=DT_".235959" + I $G(OMEGA),$E(OMEGA,8)'="." S OMEGA=OMEGA_".235959" + ;S ID=$G(HSTAG),$P(ID,";",5,8)=SITE_";"_$P(X2,"^",8)_";"_$P(X2,"^",9) + S ID=$G(HSTAG),$P(ID,";",5,10)=SITE_";"_$P(X2,"^",8)_";"_$P(X2,"^",9)_";"_RPTID_";"_$G(DIRECT) ;HDRHX CHANGE + I $L($P($G(HSTAG),";",4)) S MAX=$P(HSTAG,";",4) + I $L($G(HSTYPE)) M ID=HSTYPE + I $L($G(EXAMID)) M ID=EXAMID + S OUT=ENT_"^"_RTN_"(.ROOT,DFN,.ID,.ALPHA,.OMEGA,.DTRANGE,.REMOTE,.MAX,.ORFHIE)" + I REMOTE S GO=0 D Q:'GO + . I '$L($T(GETDFN^MPIF001)) D SETITEM(.ROOT,"MPI routines missing on remote system ("_SITE_")") S GO=0 Q + . S ICN=+$P(DFN,";",2),DFN=+$$GETDFN^MPIF001(ICN) + . I DFN<0 D SETITEM(.ROOT,"Patient not found on remote system ("_SITE_")") S GO=0 Q + . S GO=+$P(X0,"^",3) + . I 'GO D SETITEM(.ROOT,"Remote access not available for this report ("_SITE_")") + S %ZIS="0N" + D @OUT + Q +NOTYET(ROOT) ; -- not available + D SETITEM(.ROOT,"Report not available at this time.") + Q +START(RM,GOTO,ORIOSL) ; + ;RM=Right margin + N ZTQUEUED,ORHFS,ORSUB,ORIO,ORHANDLE,IOM,IOSL,IOST,IOF,IOT,IOS + S ORHFS=$$HFS(),ORSUB="ORDATA",ORHANDLE="ORWRP" + D HFSOPEN(ORHANDLE,ORHFS,"W") + I POP D Q + . I $D(ROOT) D SETITEM(.ROOT,"ERROR: Unable to open HFS file") + D IOVAR(.ORIO,.RM,.ORIOSL) + N $ETRAP,$ESTACK + S $ETRAP="D ERR^ORWRP Q" + U IO + D @GOTO + D HFSCLOSE(ORHANDLE,ORHFS) + Q +ERR ;Error trap + S $ETRAP="D UNWIND^ORWRP Q" + N %ZIS + S %ZIS="0N" + D @^%ZOSF("ERRTN") ;file error + I $D(ORHANDLE) D CLOSE^%ZISH(ORHANDLE) + I $D(ORHFS) D + . N ORARR,OROK + . S ORARR(ORHFS)="",OROK=$$DEL^%ZISH("",$NA(ORARR)) ;delete HFS file + S $ECODE=",UOR69 error during CPRS report build," + Q +UNWIND ;Unwind Error stack + Q:$ESTACK>1 ;pop stack + ; + Q +HFS() ; -- get hfs file name + N H + S H=$H + Q "ORU_"_$J_"_"_$P(H,",")_"_"_$P(H,",",2)_".DAT" +HFSOPEN(HANDLE,ORHFS,ORMODE) ; + D OPEN^%ZISH(HANDLE,,ORHFS,$G(ORMODE,"W")) Q:POP + Q +IOVAR(ORIO,ORRM,ORIOSL,ORIOST,ORIOF,ORIOT) ;Setup IO variables based on IO Device + N IFN,IFN1 + S ORIO=$G(ORIO,"OR WORKSTATION"),ION=ORIO,IOM=$G(ORRM,80),IOSL=$G(ORIOSL,62),IOST=$G(ORIOST,"P-OTHER"),IOF=$G(ORIOF,""""""),IOT=$G(ORIOT,"HFS") + I $O(^%ZIS(1,"B",ORIO,0)) S IFN=$O(^(0)),IOS=IFN + I $D(^%ZIS(1,IFN,0)) S IOST(0)=+$G(^("SUBTYPE")),IOT=$G(ORIOT,^("TYPE")),IOST=$G(ORIOST,$P($G(^%ZIS(2,IOST(0),0),IOST),"^")) + I $O(^%ZIS(2,"B",IOST,0)) S IFN=$O(^(0)) I IFN S IOST(0)=IFN,IFN1=$G(^%ZIS(2,IFN,1)),IOM=$G(ORRM,$P(IFN1,"^")),IOF=$G(ORIOF,$P(IFN1,"^",2)),IOSL=$G(ORIOSL,$P(IFN1,"^",3)) + Q +HFSCLOSE(HANDLE,ORHFS) ;Close HFS and unload data + N ORDEL,X,%ZIS + S %ZIS="0N" + I IO[ORHFS D CLOSE^%ZISH(HANDLE) + S ROOT=$NA(^TMP(ORSUB,$J,1)),ORDEL(ORHFS)="" + K @ROOT + S X=$$FTG^%ZISH(,ORHFS,$NA(@ROOT@(1)),4) + D STRIP + S X=$$DEL^%ZISH(,$NA(ORDEL)) + Q +USEHFS ; -- use host file to build global array + N OROK,SECTION + S SECTION=0 + D INIT + S OROK=$$FTG^%ZISH(,ORHFS,$NA(@ROOT@(1)),4) I 'OROK Q + D STRIP + N ORARR S ORARR(ORHFS)="" + S OROK=$$DEL^%ZISH("",$NA(ORARR)) + Q +INIT ; -- initialize counts and global section + S (INC,CNT)=0,SECTION=SECTION+1,ROOT=$NA(^TMP(ORSUB,$J,SECTION)) + K @ROOT + Q +FINAL ; -- set 'x of y' for each section CALLED FROM ^ORWLR + N I + F I=1:1:SECTION S ^TMP(ORSUB,$J,I,.1)=I_U_SECTION + Q +STRIP ; -- strip off control chars + N I,X + S I=0 F S I=$O(@ROOT@(I)) Q:'I S X=^(I) D + . I X[$C(8) D ;BS + .. I $L(X,$C(8))=$L(X,$C(95)) S (X,@ROOT@(I))=$TR(X,$C(8,95),"") Q ;BS & _ + .. S (X,@ROOT@(I))=$TR(X,$C(8),"") + . I X[$C(7)!(X[$C(12)) S @ROOT@(I)=$TR(X,$C(7,12),"") ;BEL or FF + Q +WINDFLT(ORY) ;Windows printer as default? + S ORY=+$$GET^XPAR("ALL","ORWDP WINPRINT DEFAULT") + Q +GETDFPRT(Y,ORUSER,ORLOC) ; Returns default printer for user + N IEN,X0,ENT + S ENT="ALL" + I $G(ORLOC) S ORLOC=+ORLOC_";SC(",ENT=ENT_"^"_ORLOC + I +$$GET^XPAR(ENT,"ORWDP WINPRINT DEFAULT") S Y="WIN;Windows Printer" Q + S IEN=$$GET^XPAR(ENT,"ORWDP DEFAULT PRINTER",1) Q:+IEN=0 + Q:'$D(^%ZIS(1,IEN,0)) S X0=^(0) + S Y=IEN_";"_$P(X0,U) + Q +SAVDFPRT(Y,ORDEV) ; Save new default printer for user + N ORPAR,ORERR,ORWINDEF + Q:$L(ORDEV)=0 + ; Reset Windows printer default to True/False + S ORPAR="ORWDP WINPRINT DEFAULT" + I ORDEV="WIN" S ORWINDEF="Y" + E S ORWINDEF="N" + I $$GET^XPAR(DUZ_";VA(200,",ORPAR,1)'="" D CHG^XPAR(DUZ_";VA(200,",ORPAR,1,ORWINDEF,.ORERR) + E D ADD^XPAR(DUZ_";VA(200,",ORPAR,1,ORWINDEF,.ORERR) + Q:ORDEV="WIN" + ; If not Windows printer selected, save VistA default printer + S ORPAR="ORWDP DEFAULT PRINTER",ORDEV="`"_ORDEV + I $$GET^XPAR(DUZ_";VA(200,",ORPAR,1)'="" D CHG^XPAR(DUZ_";VA(200,",ORPAR,1,ORDEV,.ORERR) + E D ADD^XPAR(DUZ_";VA(200,",ORPAR,1,ORDEV,.ORERR) + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWRP1.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWRP1.m index 636af201..d8f6d2e4 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWRP1.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWRP1.m @@ -1,210 +1,210 @@ -ORWRP1 ; ALB/MJK,dcm Report Calls ;7/20/07 14:43 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,160,262,269**;Dec 17, 1997;Build 29 - ; -AHS(ROOT,ORDFN,ORHS,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ; - get adhoc health summary report - D START^ORWRP(80,"AHSB^ORWRP1(.ROOT,.ORDFN,.ORHS,.ALPHA,.OMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)") - Q -AHSB(ROOT,ORDFN,ORHS,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ; -build adhoc health summary - N ORVP,GMTYP,Y - S ORVP=ORDFN_";DPT(",Y=$P($G(^GMT(142,+ORHS,0)),U),GMTSTYP=+ORHS - D ADHOC^ORPRS13 - Q -HS(ROOT,ORDFN,ORHS,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ; - get health summary report - D START^ORWRP(80,"HSB^ORWRP1(.ROOT,.ORDFN,.ORHS,.ALPHA,.OMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)") - Q -HSB(ROOT,ORDFN,ORHS,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ; - build health summary report - N I,ICN,ORVP,GMTYP,Y,GMARXN,GMTSDLM,GMTSDTC,GMTSE,GMTSEGH,GMTSEGL,GMTSEGN,GMTSEGR,GMSEQ,GMTSHDR,GMTSLCMP,GMTSNDM,GMTSNPK,GMTSPG,GMTSPHDR,X - I $G(REMOTE) D Q:'ORHS - . S Y=$O(^GMT(142,"E",$P(ORHS,";",2),0)) - . I 'Y S Y=$O(^GMT(142,"E",$P($$UPPER^ORU(ORHS),";",2),0)) - . I 'Y S I=0 F S I=$O(^GMT(142,I)) Q:'I I $L($P($G(^GMT(142,I,"T")),"^")),$P($$UPPER^ORU(ORHS),";",2)=$$UPPER^ORU(^("T")) S Y=I Q - . I 'Y S Y=$O(^GMT(142,"B",$P(ORHS,";",2),0)) - . I 'Y S Y=$O(^GMT(142,"B",$P($$UPPER^ORU(ORHS),";",2),0)) - . I 'Y S I=0 F S I=$O(^GMT(142,I)) Q:'I S X=$P(^(I,0),"^") I $P($$UPPER^ORU(ORHS),";",2)=$$UPPER^ORU(X) S Y=I Q - . I 'Y U IO W !,ORHS_" not found on remote system",! S ORHS=Y Q - . S ORHS=Y - I +$G(ORHS)<1 W !,"Report not Available" Q - S ORVP=ORDFN_";DPT(",Y=$P($G(^GMT(142,+ORHS,0)),U),GMTYP(0)=1,GMTYP(1)=+ORHS_U_Y_U_Y_U_Y - D PQ^ORPRS13 - Q -HSTYPE(ROOT,ORDFN,ORHS,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ; - Get HS type report - D START^ORWRP(80,"HSTYPEB^ORWRP1(.ROOT,.ORDFN,.ORHS,.ALPHA,.OMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)") - Q -HSTYPEB(ROOT,ORDFN,ORHS,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ; - Build HS type report - N GMTSQIT,GMTSPRM,GMTSTITL,GMTSPX2,GMTSPX1 - I $L($G(DTRANGE)),'$G(ALPHA) S ALPHA=$$FMADD^XLFDT(DT,-DTRANGE),OMEGA=$$NOW^XLFDT - Q:'$G(ALPHA) Q:'$G(OMEGA) - I +$G(ORHS)<1 W !,"Report not Available" Q - S GMTSQIT=1,GMTSPRM=$P($G(^GMT(142.1,+ORHS,0)),"^",4),GMTSTITL="",GMTSPX2=ALPHA,GMTSPX1=OMEGA,DFN=ORDFN - D ENCWA^GMTS - Q -HSGUI(DFN,GMTSTYP) ; - Call ENX^GMTSDVR to print HS Type for Patient - D ENX^GMTSDVR(DFN,GMTSTYP) - Q -BLR(ROOT,ORDFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ; -- get 'enhanced' blood bank report - N DFN,ORY,ORSBHEAD - S DFN=ORDFN - I $L($T(EN^ORWLR1)),$L($T(CPRS^VBECA3B)) D Q ;Transition to VBEC's interface - . K ^TMP("ORLRC",$J) - . D EN^ORWLR1(DFN) - . I '$O(^TMP("ORLRC",$J,0)) S ^TMP("ORLRC",$J,1,0)="",^TMP("ORLRC",$J,2,0)="No Blood Bank report available..." - . S ROOT=$NA(^TMP("ORLRC",$J)) - K ^TMP("LRC",$J) - S ORSBHEAD("BLOOD BANK")="" - D EN^LR7OSUM(.ORY,DFN,,,,,.ORSBHEAD) - I '$O(^TMP("LRC",$J,0)) S ^TMP("LRC",$J,1,0)="",^TMP("LRC",$J,2,0)="No Blood Bank report available..." - S ROOT=$NA(^TMP("LRC",$J)) - Q -AP(ROOT,ORDFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ; -- get Anatomic path report - N I,C,LINES,X - K ^TMP("LRC",$J),^TMP("LRH",$J) - D AP^LR7OSUM(ORDFN) - I '$O(^TMP("LRC",$J,0)) S ^TMP("LRC",$J,1,0)="",^TMP("LRC",$J,2,0)="No Anatomic Pathology reports available..." - S I=0 - I $L($O(^TMP("LRH",$J,0))) S I=.001,^TMP("LRC",$J,I)="[HIDDEN TEXT]^" D - . S X="",C=2 F S X=$O(^TMP("LRH",$J,X)) Q:X="" S LINES(^(X))=X,C=C+1 - . S $P(^TMP("LRC",$J,.001),"^",2)=C - . S X="" F S X=$O(LINES(X)) Q:X="" D - .. S I=I+.001,^TMP("LRC",$J,I)=X_"^"_LINES(X) - . S I=I+.001,^TMP("LRC",$J,I)="[REPORT TEXT]" - S ROOT=$NA(^TMP("LRC",$J)) - K ^TMP("LRH",$J) - Q -DIET(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ; -- get dietetics profile - N LCNT,ORVP - S LCNT=0,ORVP=DFN_";DPT(" - D FHP^ORCXPNDR - S ROOT=$NA(^TMP("ORXPND",$J)) - Q -LISTNUTR(ROOT,DFN) ; -- list nutritional assessments - N OK,I,X - K ^TMP($J,"FHADT") - S OK=$$FHWORADT^FHWORA(DFN) - S I=0,SITE=$$SITE^VASITE,SITE=$P(SITE,"^",2)_";"_$P(SITE,"^",3) - F S I=$O(^TMP($J,"FHADT",DFN,I)) Q:'I S X=SITE_U_I_U_^(I),^(I)=X - S ROOT=$NA(^TMP($J,"FHADT",DFN)) - Q -NUTR(ROOT,DFN,ID,ALPHA,OMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE) ; -- get nutritional assessment - N LCNT,ORVP - K ^TMP("ORXPND",$J) - S LCNT=0,ORVP=DFN_";DPT(",ID=DFN_";"_ID - D FHA^ORCXPNDR - S ROOT=$NA(^TMP("ORXPND",$J)) - Q -VITALS(ROOT,ORDFN,ID,ALPHA,OMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE) ; -- get vitals report - D START^ORWRP(132,"VITALSB^ORWRP1(.ROOT,.ORDFN,.ID,.ALPHA,.OMEGA,.ORDTRNG,.REMOTE,.ORMAX,.ORFHIE)") - D EN^GMRVPGC(ORDFN) Q -VITALSB(ROOT,ORDFN,ID,ALPHA,OMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE) ; -- build vitals report - N ORVP,XQORNOD,ORSSTRT,ORSSTOP - Q:'$G(ORDFN) - I $L(ORDTRNG),'$G(ALPHA) S ALPHA=$$FMADD^XLFDT(DT,-ORDTRNG),OMEGA=$$NOW^XLFDT - Q:'$G(ALPHA) Q:'$G(OMEGA) - I '$P(OMEGA,".",2) S OMEGA=OMEGA_".2359" - S ORVP=ORDFN_";DPT(",XQORNOD=1,ORSSTRT(XQORNOD)=ALPHA,ORSSTOP(XQORNOD)=OMEGA - D VITCUM^ORPRS14 - Q -STAT(ROOT,ORDFN,ID,ORALPHA,OROMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE) ;Lab Order Status - N ORVP - K ^TMP("ORDATA",$J) - S ORVP=ORDFN_";DPT(" - D EN1^LR7OSOS1(.ORY,ORVP,.ORALPHA,.OROMEGA,.ORDTRNG) - I '$O(^TMP("ORDATA",$J,1,0)) S ^TMP("ORDATA",$J,1,1,0)="",^TMP("ORDATA",$J,1,2,0)="No Orders found..." - S ROOT=ORY - Q -INTERIM(ROOT,ORDFN,ID,ORALPHA,OROMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Lab Interim - D START^ORWRP(80,"INTERIMB^ORWRP1(.ROOT,.ORDFN,.ID,.ORALPHA,.OROMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)") - Q -INTERIMB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Build Interim - Q:'$G(DFN) Q:'$G(ALPHA) Q:'$G(OMEGA) - N ORVP,XQORNOD,ORSSTRT,ORSSTOP,LRACC,LRAD,LRAN,LRRT,LRPG,LRSB,LREDT,LRIDT - S ORVP=DFN_";DPT(",XQORNOD=1,(ORSSTRT(XQORNOD),LREDT)=(9999999-ALPHA),(ORSSTOP(XQORNOD),LRIDT)=(9999999-OMEGA) - D OERR^LRRP4,CLEAN^LRRP4 - Q -LRGEN(ROOT,ORDFN,ID,ORALPHA,OROMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Lab results by test - D START^ORWRP(80,"LRGENB^ORWRP1(.ROOT,.ORDFN,.ID,.ORALPHA,.OROMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)") - Q -LRGENB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Build Results - Q:'$G(DFN) Q:'$G(ALPHA) Q:'$G(OMEGA) - N ORVP,ORSSTRT,ORSSTOP,LREDT,LRSDT,XQORNOD - S ORVP=DFN_";DPT(",XQORNOD=1,(ORSSTRT(XQORNOD),LREDT)=(9999999-ALPHA),(ORSSTOP(XQORNOD),LRSDT)=(9999999-OMEGA) - D SET1^LRGEN,CLEAN^LRRP4 - K LRPR - Q -GRAPH(ROOT,ORDFN,ID,ORALPHA,OROMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Graph labs - D START^ORWRP(80,"GRAPHB^ORWRP1(.ROOT,.ORDFN,.ID,.ORALPHA,.OROMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)") - Q -GRAPHB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Graph labs - Q:'$G(DFN) Q:'$G(ALPHA) Q:'$G(OMEGA) - N ORVP,XQORNOD,ORSSTRT,ORSSTOP,LREDT,LRSDT - S ORVP=DFN_";DPT(",XQORNOD=1,(ORSSTRT(XQORNOD),LREDT)=ALPHA,(ORSSTOP(XQORNOD),LRSDT)=OMEGA - D OERR^LRDIST4,CLEAN^LRDIST4 - Q -ORS(ROOT,ORDFN,ID,ALPHA,OMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE) ;Daily order summary - D START^ORWRP(80,"ORSB^ORWRP1(.ROOT,.ORDFN,.ID,.ALPHA,.OMEGA,.ORDTRNG,.REMOTE,.ORMAX,.ORFHIE)") - Q -ORSB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Daily order summary - N ORVP,XQORNOD,ORSSTRT,ORSSTOP - S ORVP=DFN_";DPT(",XQORNOD=1,X1=DT,X2=-$S(DTRANGE:DTRANGE-1,1:0) - D C^%DTC - S ORSSTRT=X-.7641,ORSSTOP=DT+.2359 - D DAY^ORPRS02 - Q -ORD(ROOT,ORDFN,ID,ORALPHA,OROMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE) ;Order Summary for Date Range - D START^ORWRP(80,"ORDB^ORWRP1(.ROOT,.ORDFN,.ID,.ORALPHA,.OROMEGA,.ORDTRNG,.REMOTE,.ORMAX,.ORFHIE)") - Q -ORDB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Order Summary for Date Range - Q:'$G(DFN) - I $L($G(DTRANGE)),'$G(ALPHA) S ALPHA=$$FMADD^XLFDT(DT,-DTRANGE),OMEGA=$$NOW^XLFDT - Q:'$G(ALPHA) Q:'$G(OMEGA) - N ORVP,XQORNOD,ORSSTRT,ORSSTOP - S ORVP=DFN_";DPT(",XQORNOD=1,ORSSTRT=ALPHA,ORSSTOP=OMEGA - D RANGE^ORPRS02 - Q -ORC(ROOT,ORDFN,ID,ORALPHA,OROMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Custom order summary - D START^ORWRP(80,"ORCB^ORWRP1(.ROOT,.ORDFN,.ID,.ORALPHA,.OROMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)") - Q -ORCB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Custom order summary build - Q:'$G(DFN) Q:'$G(ALPHA) Q:'$G(OMEGA) - N ORVP,XQORNOD,ORSSTRT,ORSSTOP - S ORVP=DFN_";DPT(",XQORNOD=1,ORSSTRT=ALPHA,ORSSTOP=OMEGA - D CUSTOM^ORPRS02 - Q -ORP(ROOT,ORDFN,ID,ORALPHA,OROMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE) ;Chart copy summary - D START^ORWRP(80,"ORPB^ORWRP1(.ROOT,.ORDFN,.ID,.ORALPHA,.OROMEGA,.ORDTRNG,.REMOTE,.ORFHIE)") - Q -ORPB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Chart copy summary - Q:'$G(DFN) - I $L($G(DTRANGE)),'$G(ALPHA) S ALPHA=$$FMADD^XLFDT(DT,-DTRANGE),OMEGA=$$NOW^XLFDT - Q:'$G(ALPHA) Q:'$G(OMEGA) - N ORVP,XQORNOD,ORSSTRT,ORSSTOP - S ORVP=DFN_";DPT(",XQORNOD=1,ORSSTRT=ALPHA,ORSSTOP=OMEGA - D CHART^ORPRS02 - Q -PSO(ROOT,ORDFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Outpatient RX Profile - D START^ORWRP(80,"PSOB^ORWRP1(.ROOT,.ORDFN,.ID,.ALPHA,.OMEGA,.DTRANGE,.REMOTE,.ORFHIE)") - Q -PSOB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Outpatient RX Action Profile - N ORVP,PSTYPE,PSONOPG - S ORVP=DFN_";DPT(",PSTYPE=1,PSONOPG=2 - D DFN^PSOSD1 - Q -MED(ROOT,ORDFN,IID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Medicine Summary of Procedures - D START^ORWRP(80,"MEDB^ORWRP1(.ROOT,.ORDFN,.IID,.ALPHA,.OMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)") - Q -MEDB(ROOT,DFN,IID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Medicine Summary of Procedures - Q:'$L($G(IID)) - N ORVP,XQY0,OT,MCARPPS,MCPRO,MCARGRTN,DXS,SSN,I,J,L,DA,MCARGDA - S ORVP=DFN_";DPT(",XQY0="",OT=$G(^TMP("OR",$J,"MCAR","OT",IID)) - Q:'$L(OT) - S (DA,MCARGDA)=$P(OT,U,2),MCARPPS=$P(OT,U,3,4),MCPRO=$P(OT,U,11) - D MCPPROC^MCARP - S MCARGRTN=$P(OT,U,5) - D @MCARPPS - Q -PROB(ROOT,ORDFN,IID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ; Problem List (Problem Tab) - D START^ORWRP(80,"PROBB^ORWRP1(.ROOT,.ORDFN,.IID,.ALPHA,.OMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)") - Q -PROBB(ROOT,DFN,IID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Problem List - N ORSILENT S ORSILENT=1 - D VAF^GMPLUTL2(DFN,ORSILENT) - Q +ORWRP1 ; ALB/MJK,dcm Report Calls ;7/20/07 14:43 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,160,262,269**;Dec 17, 1997;Build 28 + ; +AHS(ROOT,ORDFN,ORHS,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ; - get adhoc health summary report + D START^ORWRP(80,"AHSB^ORWRP1(.ROOT,.ORDFN,.ORHS,.ALPHA,.OMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)") + Q +AHSB(ROOT,ORDFN,ORHS,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ; -build adhoc health summary + N ORVP,GMTYP,Y + S ORVP=ORDFN_";DPT(",Y=$P($G(^GMT(142,+ORHS,0)),U),GMTSTYP=+ORHS + D ADHOC^ORPRS13 + Q +HS(ROOT,ORDFN,ORHS,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ; - get health summary report + D START^ORWRP(80,"HSB^ORWRP1(.ROOT,.ORDFN,.ORHS,.ALPHA,.OMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)") + Q +HSB(ROOT,ORDFN,ORHS,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ; - build health summary report + N I,ICN,ORVP,GMTYP,Y,GMARXN,GMTSDLM,GMTSDTC,GMTSE,GMTSEGH,GMTSEGL,GMTSEGN,GMTSEGR,GMSEQ,GMTSHDR,GMTSLCMP,GMTSNDM,GMTSNPK,GMTSPG,GMTSPHDR,X + I $G(REMOTE) D Q:'ORHS + . S Y=$O(^GMT(142,"E",$P(ORHS,";",2),0)) + . I 'Y S Y=$O(^GMT(142,"E",$P($$UPPER^ORU(ORHS),";",2),0)) + . I 'Y S I=0 F S I=$O(^GMT(142,I)) Q:'I I $L($P($G(^GMT(142,I,"T")),"^")),$P($$UPPER^ORU(ORHS),";",2)=$$UPPER^ORU(^("T")) S Y=I Q + . I 'Y S Y=$O(^GMT(142,"B",$P(ORHS,";",2),0)) + . I 'Y S Y=$O(^GMT(142,"B",$P($$UPPER^ORU(ORHS),";",2),0)) + . I 'Y S I=0 F S I=$O(^GMT(142,I)) Q:'I S X=$P(^(I,0),"^") I $P($$UPPER^ORU(ORHS),";",2)=$$UPPER^ORU(X) S Y=I Q + . I 'Y U IO W !,ORHS_" not found on remote system",! S ORHS=Y Q + . S ORHS=Y + I +$G(ORHS)<1 W !,"Report not Available" Q + S ORVP=ORDFN_";DPT(",Y=$P($G(^GMT(142,+ORHS,0)),U),GMTYP(0)=1,GMTYP(1)=+ORHS_U_Y_U_Y_U_Y + D PQ^ORPRS13 + Q +HSTYPE(ROOT,ORDFN,ORHS,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ; - Get HS type report + D START^ORWRP(80,"HSTYPEB^ORWRP1(.ROOT,.ORDFN,.ORHS,.ALPHA,.OMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)") + Q +HSTYPEB(ROOT,ORDFN,ORHS,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ; - Build HS type report + N GMTSQIT,GMTSPRM,GMTSTITL,GMTSPX2,GMTSPX1 + I $L($G(DTRANGE)),'$G(ALPHA) S ALPHA=$$FMADD^XLFDT(DT,-DTRANGE),OMEGA=$$NOW^XLFDT + Q:'$G(ALPHA) Q:'$G(OMEGA) + I +$G(ORHS)<1 W !,"Report not Available" Q + S GMTSQIT=1,GMTSPRM=$P($G(^GMT(142.1,+ORHS,0)),"^",4),GMTSTITL="",GMTSPX2=ALPHA,GMTSPX1=OMEGA,DFN=ORDFN + D ENCWA^GMTS + Q +HSGUI(DFN,GMTSTYP) ; - Call ENX^GMTSDVR to print HS Type for Patient + D ENX^GMTSDVR(DFN,GMTSTYP) + Q +BLR(ROOT,ORDFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ; -- get 'enhanced' blood bank report + N DFN,ORY,ORSBHEAD + S DFN=ORDFN + I $L($T(EN^ORWLR1)),$L($T(CPRS^VBECA3B)) D Q ;Transition to VBEC's interface + . K ^TMP("ORLRC",$J) + . D EN^ORWLR1(DFN) + . I '$O(^TMP("ORLRC",$J,0)) S ^TMP("ORLRC",$J,1,0)="",^TMP("ORLRC",$J,2,0)="No Blood Bank report available..." + . S ROOT=$NA(^TMP("ORLRC",$J)) + K ^TMP("LRC",$J) + S ORSBHEAD("BLOOD BANK")="" + D EN^LR7OSUM(.ORY,DFN,,,,,.ORSBHEAD) + I '$O(^TMP("LRC",$J,0)) S ^TMP("LRC",$J,1,0)="",^TMP("LRC",$J,2,0)="No Blood Bank report available..." + S ROOT=$NA(^TMP("LRC",$J)) + Q +AP(ROOT,ORDFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ; -- get Anatomic path report + N I,C,LINES,X + K ^TMP("LRC",$J),^TMP("LRH",$J) + D AP^LR7OSUM(ORDFN) + I '$O(^TMP("LRC",$J,0)) S ^TMP("LRC",$J,1,0)="",^TMP("LRC",$J,2,0)="No Anatomic Pathology reports available..." + S I=0 + I $L($O(^TMP("LRH",$J,0))) S I=.001,^TMP("LRC",$J,I)="[HIDDEN TEXT]^" D + . S X="",C=2 F S X=$O(^TMP("LRH",$J,X)) Q:X="" S LINES(^(X))=X,C=C+1 + . S $P(^TMP("LRC",$J,.001),"^",2)=C + . S X="" F S X=$O(LINES(X)) Q:X="" D + .. S I=I+.001,^TMP("LRC",$J,I)=X_"^"_LINES(X) + . S I=I+.001,^TMP("LRC",$J,I)="[REPORT TEXT]" + S ROOT=$NA(^TMP("LRC",$J)) + K ^TMP("LRH",$J) + Q +DIET(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ; -- get dietetics profile + N LCNT,ORVP + S LCNT=0,ORVP=DFN_";DPT(" + D FHP^ORCXPNDR + S ROOT=$NA(^TMP("ORXPND",$J)) + Q +LISTNUTR(ROOT,DFN) ; -- list nutritional assessments + N OK,I,X + K ^TMP($J,"FHADT") + S OK=$$FHWORADT^FHWORA(DFN) + S I=0,SITE=$$SITE^VASITE,SITE=$P(SITE,"^",2)_";"_$P(SITE,"^",3) + F S I=$O(^TMP($J,"FHADT",DFN,I)) Q:'I S X=SITE_U_I_U_^(I),^(I)=X + S ROOT=$NA(^TMP($J,"FHADT",DFN)) + Q +NUTR(ROOT,DFN,ID,ALPHA,OMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE) ; -- get nutritional assessment + N LCNT,ORVP + K ^TMP("ORXPND",$J) + S LCNT=0,ORVP=DFN_";DPT(",ID=DFN_";"_ID + D FHA^ORCXPNDR + S ROOT=$NA(^TMP("ORXPND",$J)) + Q +VITALS(ROOT,ORDFN,ID,ALPHA,OMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE) ; -- get vitals report + D START^ORWRP(132,"VITALSB^ORWRP1(.ROOT,.ORDFN,.ID,.ALPHA,.OMEGA,.ORDTRNG,.REMOTE,.ORMAX,.ORFHIE)") + D EN^GMRVPGC(ORDFN) Q +VITALSB(ROOT,ORDFN,ID,ALPHA,OMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE) ; -- build vitals report + N ORVP,XQORNOD,ORSSTRT,ORSSTOP + Q:'$G(ORDFN) + I $L(ORDTRNG),'$G(ALPHA) S ALPHA=$$FMADD^XLFDT(DT,-ORDTRNG),OMEGA=$$NOW^XLFDT + Q:'$G(ALPHA) Q:'$G(OMEGA) + I '$P(OMEGA,".",2) S OMEGA=OMEGA_".2359" + S ORVP=ORDFN_";DPT(",XQORNOD=1,ORSSTRT(XQORNOD)=ALPHA,ORSSTOP(XQORNOD)=OMEGA + D VITCUM^ORPRS14 + Q +STAT(ROOT,ORDFN,ID,ORALPHA,OROMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE) ;Lab Order Status + N ORVP + K ^TMP("ORDATA",$J) + S ORVP=ORDFN_";DPT(" + D EN1^LR7OSOS1(.ORY,ORVP,.ORALPHA,.OROMEGA,.ORDTRNG) + I '$O(^TMP("ORDATA",$J,1,0)) S ^TMP("ORDATA",$J,1,1,0)="",^TMP("ORDATA",$J,1,2,0)="No Orders found..." + S ROOT=ORY + Q +INTERIM(ROOT,ORDFN,ID,ORALPHA,OROMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Lab Interim + D START^ORWRP(80,"INTERIMB^ORWRP1(.ROOT,.ORDFN,.ID,.ORALPHA,.OROMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)") + Q +INTERIMB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Build Interim + Q:'$G(DFN) Q:'$G(ALPHA) Q:'$G(OMEGA) + N ORVP,XQORNOD,ORSSTRT,ORSSTOP,LRACC,LRAD,LRAN,LRRT,LRPG,LRSB,LREDT,LRIDT + S ORVP=DFN_";DPT(",XQORNOD=1,(ORSSTRT(XQORNOD),LREDT)=(9999999-ALPHA),(ORSSTOP(XQORNOD),LRIDT)=(9999999-OMEGA) + D OERR^LRRP4,CLEAN^LRRP4 + Q +LRGEN(ROOT,ORDFN,ID,ORALPHA,OROMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Lab results by test + D START^ORWRP(80,"LRGENB^ORWRP1(.ROOT,.ORDFN,.ID,.ORALPHA,.OROMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)") + Q +LRGENB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Build Results + Q:'$G(DFN) Q:'$G(ALPHA) Q:'$G(OMEGA) + N ORVP,ORSSTRT,ORSSTOP,LREDT,LRSDT,XQORNOD + S ORVP=DFN_";DPT(",XQORNOD=1,(ORSSTRT(XQORNOD),LREDT)=(9999999-ALPHA),(ORSSTOP(XQORNOD),LRSDT)=(9999999-OMEGA) + D SET1^LRGEN,CLEAN^LRRP4 + K LRPR + Q +GRAPH(ROOT,ORDFN,ID,ORALPHA,OROMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Graph labs + D START^ORWRP(80,"GRAPHB^ORWRP1(.ROOT,.ORDFN,.ID,.ORALPHA,.OROMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)") + Q +GRAPHB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Graph labs + Q:'$G(DFN) Q:'$G(ALPHA) Q:'$G(OMEGA) + N ORVP,XQORNOD,ORSSTRT,ORSSTOP,LREDT,LRSDT + S ORVP=DFN_";DPT(",XQORNOD=1,(ORSSTRT(XQORNOD),LREDT)=ALPHA,(ORSSTOP(XQORNOD),LRSDT)=OMEGA + D OERR^LRDIST4,CLEAN^LRDIST4 + Q +ORS(ROOT,ORDFN,ID,ALPHA,OMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE) ;Daily order summary + D START^ORWRP(80,"ORSB^ORWRP1(.ROOT,.ORDFN,.ID,.ALPHA,.OMEGA,.ORDTRNG,.REMOTE,.ORMAX,.ORFHIE)") + Q +ORSB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Daily order summary + N ORVP,XQORNOD,ORSSTRT,ORSSTOP + S ORVP=DFN_";DPT(",XQORNOD=1,X1=DT,X2=-$S(DTRANGE:DTRANGE-1,1:0) + D C^%DTC + S ORSSTRT=X-.7641,ORSSTOP=DT+.2359 + D DAY^ORPRS02 + Q +ORD(ROOT,ORDFN,ID,ORALPHA,OROMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE) ;Order Summary for Date Range + D START^ORWRP(80,"ORDB^ORWRP1(.ROOT,.ORDFN,.ID,.ORALPHA,.OROMEGA,.ORDTRNG,.REMOTE,.ORMAX,.ORFHIE)") + Q +ORDB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Order Summary for Date Range + Q:'$G(DFN) + I $L($G(DTRANGE)),'$G(ALPHA) S ALPHA=$$FMADD^XLFDT(DT,-DTRANGE),OMEGA=$$NOW^XLFDT + Q:'$G(ALPHA) Q:'$G(OMEGA) + N ORVP,XQORNOD,ORSSTRT,ORSSTOP + S ORVP=DFN_";DPT(",XQORNOD=1,ORSSTRT=ALPHA,ORSSTOP=OMEGA + D RANGE^ORPRS02 + Q +ORC(ROOT,ORDFN,ID,ORALPHA,OROMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Custom order summary + D START^ORWRP(80,"ORCB^ORWRP1(.ROOT,.ORDFN,.ID,.ORALPHA,.OROMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)") + Q +ORCB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Custom order summary build + Q:'$G(DFN) Q:'$G(ALPHA) Q:'$G(OMEGA) + N ORVP,XQORNOD,ORSSTRT,ORSSTOP + S ORVP=DFN_";DPT(",XQORNOD=1,ORSSTRT=ALPHA,ORSSTOP=OMEGA + D CUSTOM^ORPRS02 + Q +ORP(ROOT,ORDFN,ID,ORALPHA,OROMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE) ;Chart copy summary + D START^ORWRP(80,"ORPB^ORWRP1(.ROOT,.ORDFN,.ID,.ORALPHA,.OROMEGA,.ORDTRNG,.REMOTE,.ORFHIE)") + Q +ORPB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Chart copy summary + Q:'$G(DFN) + I $L($G(DTRANGE)),'$G(ALPHA) S ALPHA=$$FMADD^XLFDT(DT,-DTRANGE),OMEGA=$$NOW^XLFDT + Q:'$G(ALPHA) Q:'$G(OMEGA) + N ORVP,XQORNOD,ORSSTRT,ORSSTOP + S ORVP=DFN_";DPT(",XQORNOD=1,ORSSTRT=ALPHA,ORSSTOP=OMEGA + D CHART^ORPRS02 + Q +PSO(ROOT,ORDFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Outpatient RX Profile + D START^ORWRP(80,"PSOB^ORWRP1(.ROOT,.ORDFN,.ID,.ALPHA,.OMEGA,.DTRANGE,.REMOTE,.ORFHIE)") + Q +PSOB(ROOT,DFN,ID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Outpatient RX Action Profile + N ORVP,PSTYPE,PSONOPG + S ORVP=DFN_";DPT(",PSTYPE=1,PSONOPG=2 + D DFN^PSOSD1 + Q +MED(ROOT,ORDFN,IID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Medicine Summary of Procedures + D START^ORWRP(80,"MEDB^ORWRP1(.ROOT,.ORDFN,.IID,.ALPHA,.OMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)") + Q +MEDB(ROOT,DFN,IID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Medicine Summary of Procedures + Q:'$L($G(IID)) + N ORVP,XQY0,OT,MCARPPS,MCPRO,MCARGRTN,DXS,SSN,I,J,L,DA,MCARGDA + S ORVP=DFN_";DPT(",XQY0="",OT=$G(^TMP("OR",$J,"MCAR","OT",IID)) + Q:'$L(OT) + S (DA,MCARGDA)=$P(OT,U,2),MCARPPS=$P(OT,U,3,4),MCPRO=$P(OT,U,11) + D MCPPROC^MCARP + S MCARGRTN=$P(OT,U,5) + D @MCARPPS + Q +PROB(ROOT,ORDFN,IID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ; Problem List (Problem Tab) + D START^ORWRP(80,"PROBB^ORWRP1(.ROOT,.ORDFN,.IID,.ALPHA,.OMEGA,.DTRANGE,.REMOTE,.ORMAX,.ORFHIE)") + Q +PROBB(ROOT,DFN,IID,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ;Problem List + N ORSILENT S ORSILENT=1 + D VAF^GMPLUTL2(DFN,ORSILENT) + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWRP3.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWRP3.m index 59a83c40..80fe231c 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWRP3.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWRP3.m @@ -1,53 +1,47 @@ -ORWRP3 ; slc/dcm - OE/RR Report Extract RPC's ; 08 May 2001 13:32PM - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**109,120,132,215,243**;Dec 17, 1997;Build 242 - ; - ; DBIA 4011 Access ^XWB(8994) - ; -EX(ROOT,TST) ;Expand columns - ;TST=ptr to file 101.24 - ;Y(i)=id^Name^Qualifier^IOM^Entry^Routine^Remote^Type^Category^RPC^ifn^sort_order^max_days^direct^hdr^fhie - Q:'$G(TST) - N J,X,X0,X1,X2,X4,RPC,HEAD,ORX0,ORX2,ORX4,ORX,ORTIMOCC,MAX - I '$L($G(C)) S C=0 - S ORTIMOCC=$$GET^XPAR("USR.`"_DUZ_"^SYS^PKG","ORWRP TIME/OCC LIMITS INDV",+TST,"I") - I '$L(ORTIMOCC) S ORTIMOCC=$$GET^XPAR("USR.`"_DUZ_"^SYS^PKG","ORWRP TIME/OCC LIMITS ALL",1,"I") - S X0=$G(^ORD(101.24,+TST,0)),X2=$G(^(2)),X4=$G(^(4)),MAX=$P(X4,"^",2),X=$P($P(ORTIMOCC,";"),"-",2) - I $P(X4,"^",10) Q - I X,MAX,X>MAX S ORTIMOCC="T-"_MAX_";"_$P(ORTIMOCC,";",2,99) - I '$L(ORTIMOCC) S ORTIMOCC=";;" - I '$O(^ORD(101.24,+TST,10,0)) D Q - . Q:$P(X0,"^",12)="L" - . S RPC=$P($G(^XWB(8994,+$P(X0,"^",13),0)),"^") ;DBIA 4011 - . S HEAD=$P(X0,"^") - . I $L($P(X2,"^",3)) S HEAD=$P(X2,"^",3) - . S X1=$P(X0,U,2)_U_HEAD_U_ORTIMOCC_";"_$P(X0,U,4)_U_$P(X0,U,19)_";"_$P(X0,U,20)_";" - . S X=X1_+$P(X0,U,21)_U_$P(X0,U,6)_U_$P(X0,U,5)_U_$P(X0,U,3)_U_$P(X0,U,12)_U_$P(X0,U,7)_U_RPC_U_+TST_U_$P(X4,U)_U_$P(X4,U,2)_U_$P(X4,U,4)_U_$P(X4,U,5)_U_$P(X4,U,8)_U_$P(X4,U,9) - . D SETITEM(.ROOT,X) - I $O(^ORD(101.24,+TST,10,0)) S ORX0=^ORD(101.24,+TST,0),ORX2=$G(^(2)),ORX4=$G(^(4)) D - . I $P(ORX4,"^",10) Q - . S RPC=$P($G(^XWB(8994,+$P(X0,"^",13),0)),"^") ;DBIA 4011 - . S X=ORX0,HEAD=$P(X,"^") - . I $L($P(ORX2,"^",3)) S HEAD=$P(ORX2,"^",3) - . S X1=$P(X,U,2)_U_HEAD_U_ORTIMOCC_";"_$P(X,U,4)_U_$P(X,U,19)_";"_$P(X,U,20)_";" - . S ORX=X1_+$P(X,U,21)_U_$P(X,U,6)_U_$P(X,U,5)_U_$P(X,U,3)_U_$P(X,U,12)_U_$P(X,U,7)_U_RPC_U_+TST_U_$P(ORX4,U)_U_$P(ORX4,U,2)_U_$P(ORX4,U,4)_U_$P(ORX4,U,5)_U_$P(ORX4,U,8)_U_$P(X4,U,9) - . D SETITEM(.ROOT,"[PARENT START]^"_ORX) - . S J=0 F S J=$O(^ORD(101.24,+TST,10,J)) Q:J<1 S X=^(J,0) D EX(.ROOT,+X) - . D SETITEM(.ROOT,"[PARENT END]^"_ORX) - Q -LIST(LST,TAB) ;Get list for Reports & Labs Tab Treeview - N ROOT - S ROOT=$NA(LST) - K @ROOT - D TRY1(.ROOT,$G(TAB)) - Q -TRY1(ROOT,TAB) ;Test expanding reports using established parameters - N I,ORLIST - D SETITEM(.ROOT,"[REPORT LIST]") - D GETLST^XPAR(.ORLIST,"ALL",$S($G(TAB)="LABS":"ORWRP REPORT LAB LIST",1:"ORWRP REPORT LIST")) - S I=0 - F S I=$O(ORLIST(I)) Q:'I Q:'$D(^ORD(101.24,$P(ORLIST(I),"^",2),0)) D EX(.ROOT,$P(ORLIST(I),"^",2)) - D SETITEM(.ROOT,"$$END") - Q -SETITEM(ROOT,X) ; -- set item in list - S @ROOT@($O(@ROOT@(9999),-1)+1)=X - Q +ORWRP3 ; slc/dcm - OE/RR Report Extract RPC's ; 08 May 2001 13:32PM + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**109,120,132,215**;Dec 17, 1997 + ; + ; DBIA 4011 Access ^XWB(8994) + ; +EX(ROOT,TST) ;Expand columns + ;TST=ptr to file 101.24 + ;Y(i)=id^Name^Qualifier^IOM^Entry^Routine^Remote^Type^Category^RPC^ifn^sort_order^max_days^direct + Q:'$G(TST) + N J,X,X0,X2,X4,RPC,HEAD,ORX0,ORX2,ORX4,ORX,ORTIMOCC,MAX + I '$L($G(C)) S C=0 + S ORTIMOCC=$$GET^XPAR("USR.`"_DUZ_"^SYS^PKG","ORWRP TIME/OCC LIMITS INDV",+TST,"I") + I '$L(ORTIMOCC) S ORTIMOCC=$$GET^XPAR("USR.`"_DUZ_"^SYS^PKG","ORWRP TIME/OCC LIMITS ALL",1,"I") + S X0=$G(^ORD(101.24,+TST,0)),X2=$G(^(2)),X4=$G(^(4)),MAX=$P(X4,"^",2),X=$P($P(ORTIMOCC,";"),"-",2) + I X,MAX,X>MAX S ORTIMOCC="T-"_MAX_";"_$P(ORTIMOCC,";",2,99) + I '$L(ORTIMOCC) S ORTIMOCC=";;" + I '$O(^ORD(101.24,+TST,10,0)) D Q + . Q:$P(X0,"^",12)="L" + . S RPC=$P($G(^XWB(8994,+$P(X0,"^",13),0)),"^") ;DBIA 4011 + . S HEAD=$P(X0,"^") I $L($P(X2,"^",3)) S HEAD=$P(X2,"^",3) + . S X=$P(X0,U,2)_U_HEAD_U_ORTIMOCC_";"_$P(X0,U,4)_U_$P(X0,U,19)_";"_$P(X0,U,20)_";"_+$P(X0,U,21)_U_$P(X0,U,6)_U_$P(X0,U,5)_U_$P(X0,U,3)_U_$P(X0,U,12)_U_$P(X0,U,7)_U_RPC_U_+TST_U_$P(X4,U)_U_$P(X4,U,2)_U_$P(X4,U,4)_U_$P(X4,U,5) + . D SETITEM(.ROOT,X) + I $O(^ORD(101.24,+TST,10,0)) S ORX0=^ORD(101.24,+TST,0),ORX2=$G(^(2)),ORX4=$G(^(4)) D + . S X=ORX0,HEAD=$P(X,"^") + . I $L($P(ORX2,"^",3)) S HEAD=$P(ORX2,"^",3) + . S ORX=$P(X,U,2)_U_HEAD_U_ORTIMOCC_";"_$P(X,U,4)_U_$P(X,U,19)_";"_$P(X,U,20)_";"_+$P(X,U,21)_U_$P(X,U,6)_U_$P(X,U,5)_U_$P(X,U,3)_U_$P(X,U,12)_U_$P(X,U,7)_"^^"_+TST_U_$P(ORX4,U)_U_$P(ORX4,U,2)_U_$P(ORX4,U,4)_U_$P(ORX4,U,5) + . D SETITEM(.ROOT,"[PARENT START]^"_ORX) + . S J=0 F S J=$O(^ORD(101.24,+TST,10,J)) Q:J<1 S X=^(J,0) D EX(.ROOT,+X) + . D SETITEM(.ROOT,"[PARENT END]^"_ORX) + Q +LIST(LST) ;Get list for Treeview + N ROOT + S ROOT=$NA(LST) + K @ROOT + D TRY1(.ROOT) + Q +TRY1(ROOT) ;Test expanding reports using established parameters + N I,ORLIST + D SETITEM(.ROOT,"[REPORT LIST]") + D GETLST^XPAR(.ORLIST,"ALL","ORWRP REPORT LIST") + S I=0 + F S I=$O(ORLIST(I)) Q:'I Q:'$D(^ORD(101.24,$P(ORLIST(I),"^",2),0)) D EX(.ROOT,$P(ORLIST(I),"^",2)) + D SETITEM(.ROOT,"$$END") + Q +SETITEM(ROOT,X) ; -- set item in list + S @ROOT@($O(@ROOT@(9999),-1)+1)=X + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWRP4P.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWRP4P.m index 2c9200b7..5afee410 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWRP4P.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWRP4P.m @@ -1,35 +1,35 @@ -ORWRP4P ; slc/dcm - OE/RR HDR Report Extract RPC's Outpatient Pharmacy ;9/21/05 13:21 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,243**;Dec 17, 1997;Build 242 -PSO ;Outpatient RX for HDR - N IFN,IFN1,IFN2,X,X1,X2,X3,X10,X16,X17,XIFN,ORX,COL,CODE,I1,CNT,%DT,Y,FAC,FACU - K ^TMP("ORXS",$J) - S IFN="" - F S IFN=$O(^XTMP(HANDLE,"D",IFN)) Q:IFN="" S XIFN=^(IFN) D - . S X16=$P(XIFN,"^",16),X17=$P(XIFN,"^",17),X2=$P(XIFN,"^",2),FACU=X17 - . I X17="",X16,X16'=200 S FACU=$O(^DIC(4,"D",X16,0)) I FACU S FACU=$P(^DIC(4,FACU,0),"^") - . I '$L(FACU) S FACU=$S($L($P(XIFN,"^",2)):$P(XIFN,"^",2),1:"Unknown") - . S $P(XIFN,"^",2)=FACU,X10=$P($P(XIFN,"^",10),":",1,2),X3=$P($P(XIFN,"^",3),"~",2) - . I X3="" S X3=$P($P(XIFN,"^",4),"~",2) ;Get NDC name if Drug name not sent - . I $L(X10),$L(X3) D - .. S X10=9999999-$$SETDATE^ORWRP4(X10),^TMP("ORXS",$J,FACU,X10,X3,IFN)=XIFN - K ^TMP("ORXS1",$J) - S FAC="",CNT=-1 - F S FAC=$O(^TMP("ORXS",$J,FAC)) Q:FAC="" S IFN="" F S IFN=$O(^TMP("ORXS",$J,FAC,IFN)) Q:IFN="" D - . S IFN1="" - . F S IFN1=$O(^TMP("ORXS",$J,FAC,IFN,IFN1)) Q:IFN1="" S IFN2="" F S IFN2=$O(^TMP("ORXS",$J,FAC,IFN,IFN1,IFN2)) Q:IFN2="" S X=^(IFN2) D - .. D XSET^ORWRP4("1^"_$P(X,"^",2)) ; Facility - .. D XSET^ORWRP4("2^"_IFN1) ; Drug Name - .. D XSET^ORWRP4("3^"_$P($P(X,"^",3),"~")) ; Drug IEN - .. D XSET^ORWRP4("4^"_$P(X,"^",5)) ; RX # - .. D XSET^ORWRP4("5^"_$P($P(X,"^",6),"~",2)) ; Status - .. D XSET^ORWRP4("6^"_$P(X,"^",7)) ; Qty - .. S Y=$$SETDATE^ORWRP4($P(X,"^",9)) D XSET^ORWRP4("7^"_$$DATE^ORDVU(Y)) ; Exp/Canc Date - .. S Y=$$SETDATE^ORWRP4($P(X,"^",10)) D XSET^ORWRP4("8^"_$$DATE^ORDVU(Y)) ; Issue Date - .. S Y=$$SETDATE^ORWRP4($P(X,"^",11)) D XSET^ORWRP4("9^"_$$DATE^ORDVU(Y)) ; Last Fill Date - .. D XSET^ORWRP4("10^"_$P(X,"^",12)) ; Refills - .. D XSET^ORWRP4("11^"_$P(X,"^",13)) ; Provider - .. D XSET^ORWRP4("12^"_$P(X,"^",14)) ; Cost/Fill - .. D XSET^ORWRP4("13^"_$S($L($P(X,"^",15))>60:"[+]",1:"")) ; [+] - .. D XSET^ORWRP4("14^"_$P(X,"^",15)) ; SIG - K ^XTMP(HANDLE,"D") M ^XTMP(HANDLE,"D")=^TMP("ORXS1",$J) K ^TMP("ORXS",$J),^TMP("ORXS1",$J) - Q +ORWRP4P ; slc/dcm - OE/RR HDR Report Extract RPC's Outpatient Pharmacy ;9/21/05 13:21 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215**;Dec 17, 1997 +PSO ;Outpatient RX for HDR + N IFN,IFN1,IFN2,X,X1,X2,X3,X10,X16,X17,XIFN,ORX,COL,CODE,I1,CNT,%DT,Y,FAC,FACU + K ^TMP("ORXS",$J) + S IFN="" + F S IFN=$O(^XTMP(HANDLE,"D",IFN)) Q:IFN="" S XIFN=^(IFN) D + . S X16=$P(XIFN,"^",16),X17=$P(XIFN,"^",17),X2=$P(XIFN,"^",2),FACU=X17 + . I X17="",X16,X16'=200 S FACU=$O(^DIC(4,"D",X16,0)) I FACU S FACU=$P(^DIC(4,FACU,0),"^") + . I '$L(FACU) S FACU=$S($L($P(XIFN,"^",2)):$P(XIFN,"^",2),1:"Unknown") + . S $P(XIFN,"^",2)=FACU,X10=$P($P(XIFN,"^",10),":",1,2),X3=$P($P(XIFN,"^",3),"~",2) + . I X3="" S X3=$P($P(XIFN,"^",4),"~",2) ;Get NDC name if Drug name not sent + . I $L(X10),$L(X3) D + .. S X10=9999999-$$SETDATE^ORWRP4(X10),^TMP("ORXS",$J,FACU,X10,X3,IFN)=XIFN + K ^TMP("ORXS1",$J) + S FAC="",CNT=-1 + F S FAC=$O(^TMP("ORXS",$J,FAC)) Q:FAC="" S IFN="" F S IFN=$O(^TMP("ORXS",$J,FAC,IFN)) Q:IFN="" D + . S IFN1="" + . F S IFN1=$O(^TMP("ORXS",$J,FAC,IFN,IFN1)) Q:IFN1="" S IFN2="" F S IFN2=$O(^TMP("ORXS",$J,FAC,IFN,IFN1,IFN2)) Q:IFN2="" S X=^(IFN2) D + .. D XSET^ORWRP4("1^"_$P(X,"^",2)) ; Facility + .. D XSET^ORWRP4("2^"_IFN1) ; Drug Name + .. D XSET^ORWRP4("3^"_$P($P(X,"^",3),"~")) ; Drug IEN + .. D XSET^ORWRP4("4^"_$P(X,"^",5)) ; RX # + .. D XSET^ORWRP4("5^"_$P($P(X,"^",6),"~",2)) ; Status + .. D XSET^ORWRP4("6^"_$P(X,"^",7)) ; Qty + .. S Y=$$SETDATE^ORWRP4($P(X,"^",9)) D XSET^ORWRP4("7^"_$$DATE^ORDVU(Y)) ; Exp/Canc Date + .. S Y=$$SETDATE^ORWRP4($P(X,"^",10)) D XSET^ORWRP4("8^"_$$DATE^ORDVU(Y)) ; Issue Date + .. S Y=$$SETDATE^ORWRP4($P(X,"^",11)) D XSET^ORWRP4("9^"_$$DATE^ORDVU(Y)) ; Last Fill Date + .. D XSET^ORWRP4("10^"_$P(X,"^",12)) ; Refills + .. D XSET^ORWRP4("11^"_$P(X,"^",13)) ; Provider + .. D XSET^ORWRP4("12^"_$P(X,"^",14)) ; Cost/Fill + .. D XSET^ORWRP4("13^") ; [+] + .. D XSET^ORWRP4("14^"_$P(X,"^",15)) ; SIG + K ^XTMP(HANDLE,"D") M ^XTMP(HANDLE,"D")=^TMP("ORXS1",$J) K ^TMP("ORXS",$J),^TMP("ORXS1",$J) + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWRP4V.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWRP4V.m index 0bdcdcaf..a01e0435 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWRP4V.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWRP4V.m @@ -1,80 +1,54 @@ -ORWRP4V ; slc/dcm - OE/RR HDR Report Extract RPC's Vitals;9/21/05 13:21 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,243**;Dec 17, 1997;Build 242 -VS ;Vitals code for HDR - N I,IFN,IFN1,IFN2,X,X1,X2,X4,X5,XIFN,ORX,COL,CODE,I1,CNT,%DT,FAC,FACU,NODE,QUALIF,METHOD,UNIT - K ^TMP("ORXS",$J) - S IFN="" - F S IFN=$O(^XTMP(HANDLE,"D",IFN)) Q:IFN="" S XIFN=^(IFN) D - . S X11=$P(XIFN,"^",11),X12=$P(XIFN,"^",12),X2=$P(XIFN,"^",2),FACU=X12 - . I X12="",X11,X11'=200 S FACU=$O(^DIC(4,"D",X11,0)) I FACU S FACU=$P(^DIC(4,FACU,0),"^") - . I '$L(FACU) S FACU=$S($L($P(XIFN,"^",2)):$P(XIFN,"^",2),1:"Unknown") - . S $P(XIFN,"^",2)=FACU,X4=$P($P(XIFN,"^",4),":",1,2),X5=$P($P(XIFN,"^",5),"~",2) - . I $P(XIFN,"^",10)'="W",$L(X5) D - .. S X4=9999999-$$SETDATE^ORWRP4(X4) - .. I X4=9999999 F I=.01:.01 S X4=X4+I I '$D(^TMP("ORXS",$J,FACU,X4)) Q - .. S ^TMP("ORXS",$J,FACU,X4)=$P(XIFN,"^",2),^TMP("ORXS",$J,FACU,X4,X5,IFN)=XIFN - K ^TMP("ORXS1",$J),^TMP("ORXS2",$J) - S FAC="",CNT=-1 - F S FAC=$O(^TMP("ORXS",$J,FAC)) Q:FAC="" S IFN="" F S IFN=$O(^TMP("ORXS",$J,FAC,IFN)) Q:IFN="" S NODE=^(IFN) D - . D XVSET("1^"_$P(NODE,"^"),1,FAC,IFN,NODE) ;Facility - . I $P(IFN,".")'=9999999 D XVSET("2^"_$$DATE^ORDVU(9999999-IFN),2,FAC,IFN,NODE) ; Measurement Date/Time - . I $P(IFN,".")=9999999 D XVSET("2^"_" ",2,FAC,IFN,NODE) ; Measurement Date/Time = "" - . S IFN1="" - . F S IFN1=$O(^TMP("ORXS",$J,FAC,IFN,IFN1)) Q:IFN1="" S IFN2="" F S IFN2=$O(^TMP("ORXS",$J,FAC,IFN,IFN1,IFN2)) Q:IFN2="" S X=^(IFN2) D - .. I $$UPPER^ORU(IFN1)="TEMPERATURE" D XVSET("3^"_$P(X,"^",6),3,FAC,IFN,X) D METH(X) - .. I $$UPPER^ORU(IFN1)="PULSE" D XVSET("4^"_$P(X,"^",6),4,FAC,IFN,X) D METH(X) - .. I $$UPPER^ORU(IFN1)="RESPIRATION" D XVSET("5^"_$P(X,"^",6),5,FAC,IFN,X) D METH(X) - .. I $$UPPER^ORU(IFN1)="BLOOD PRESSURE" D XVSET("6^"_$P(X,"^",6),6,FAC,IFN,X) D METH(X) - .. I $$UPPER^ORU(IFN1)="HEIGHT" D XVSET("7^"_$P(X,"^",6),7,FAC,IFN,X) D METH(X) - .. I $$UPPER^ORU(IFN1)="WEIGHT" D XVSET("8^"_$P(X,"^",6),8,FAC,IFN,X) D METH(X) - .. I $$UPPER^ORU(IFN1)="PAIN" D XVSET("9^"_$P(X,"^",6),9,FAC,IFN,X) D METH(X) - .. I $$UPPER^ORU(IFN1)="PULSE OXIMETRY" D - ... D XVSET("10^"_$P(X,"^",6),10,FAC,IFN,X) D METH(X) - ... F I=1:1:2 D - .... I $L($P(X,"^",13)),$P($P($P(X,"^",13),"|",I)," ",2)["l/min" D XVSET("13^"_$P($P($P(X,"^",13),"|",I)," "),13,FAC,IFN,X) ;Flow Rate - .... I $L($P(X,"^",13)),$P($P($P(X,"^",13),"|",I)," ",2)["%" D XVSET("14^"_$P($P($P(X,"^",13),"|",I)," "),14,FAC,IFN,X) ;O2 Concentration - .. I $$UPPER^ORU(IFN1)="CENTRAL VENOUS PRESSURE" D XVSET("11^"_$P(X,"^",6),11,FAC,IFN,X) D METH(X) - .. I $$UPPER^ORU(IFN1)="CIRCUMFERENCE/GIRTH" D XVSET("12^"_$P(X,"^",6),12,FAC,IFN,X) D METH(X) - S FAC="" - F S FAC=$O(^TMP("ORXS2",$J,"METH",FAC)) Q:FAC="" S IFN="" F S IFN=$O(^TMP("ORXS2",$J,"METH",FAC,IFN)) Q:IFN="" S METHOD=^(IFN,1),DATA=^(0) D - .I $L(METHOD) S X=METHOD D - .. D XVSET("16^"_X,16,FAC,IFN,DATA) ;Methods - S FAC="" - F S FAC=$O(^TMP("ORXS2",$J,"QUAL",FAC)) Q:FAC="" S IFN="" F S IFN=$O(^TMP("ORXS2",$J,"QUAL",FAC,IFN)) Q:IFN="" S QUALIF=^(IFN,1),DATA=^(0) D - .I $L(QUALIF) S X=QUALIF D - .. D XVSET("15^"_X,15,FAC,IFN,DATA) ;Qualifiers - S FAC="" - F S FAC=$O(^TMP("ORXS2",$J,"UNIT",FAC)) Q:FAC="" S IFN="" F S IFN=$O(^TMP("ORXS2",$J,"UNIT",FAC,IFN)) Q:IFN="" S UNIT=^(IFN,1),DATA=^(0) D - .I $L(UNIT) S X=UNIT D - .. D XVSET("17^"_X,17,FAC,IFN,DATA) ;Units - K ^XTMP(HANDLE,"D") - S FAC="",CNT=-1 - F S FAC=$O(^TMP("ORXS1",$J,FAC)) Q:FAC="" S IFN="" F S IFN=$O(^TMP("ORXS1",$J,FAC,IFN)) Q:IFN="" S IFN1="" D - . F S IFN1=$O(^TMP("ORXS1",$J,FAC,IFN,IFN1)) Q:IFN1="" S X=^(IFN1) D - .. S CNT=CNT+1,^XTMP(HANDLE,"D",CNT)=X - K ^TMP("ORXS",$J),^TMP("ORXS1",$J),^TMP("ORXS2",$J) - Q -METH(DATA) ;Get Methods, Units & Qualifiers - Q:'$D(DATA) - N X,D,T - S X=$P($P(DATA,"^",3),"~",2),D=$P($G(DATA),"^",4),T=$P($P(DATA,"^",5),"~",2) - I $L(X),$L(T),$L(D) S METHOD=$G(^TMP("ORXS2",$J,"METH",FAC,IFN,1)),METHOD=$S($L(METHOD):METHOD_" | "_T_":",1:T_":")_X,^TMP("ORXS2",$J,"METH",FAC,IFN,1)=METHOD,^(0)=DATA - S X=$P($P(DATA,"^",8),"~",2) - I $L(X),$L(T),$L(D) S QUALIF=$G(^TMP("ORXS2",$J,"QUAL",FAC,IFN,1)),QUALIF=$S($L(QUALIF):QUALIF_" | "_T_":",1:T_":")_X,^TMP("ORXS2",$J,"QUAL",FAC,IFN,1)=QUALIF,^(0)=DATA - S X=$P($P(DATA,"^",7),"~",2) - I $L(X),$L(T),$L(D) S UNIT=$G(^TMP("ORXS2",$J,"UNIT",FAC,IFN,1)),UNIT=$S($L(UNIT):UNIT_" | "_T_":",1:T_":")_X,^TMP("ORXS2",$J,"UNIT",FAC,IFN,1)=UNIT,^(0)=DATA - Q -XVSET(X,IFN,FAC,IDT,NODE) ;Setup Vitals nodes - Q:'$D(X) Q:'$L($G(IDT)) - N SAVE,OIDT - S SAVE=X - I '$L($G(IFN)) S CNT=CNT+1,^TMP("ORXS1",$J,IDT,FAC,CNT)=$$ESCP^ORWRP4(SAVE) Q - I $D(^TMP("ORXS1",$J,IDT,FAC,IFN)) D Q ;Get data where item, facility, date/time are the same - . S OIDT=IDT - . F S IDT=IDT+.0001 Q:'$D(^TMP("ORXS1",$J,IDT,IFN)) - . I '$D(^TMP("ORXS1",$J,IDT,FAC,IFN)) D - .. S ^TMP("ORXS1",$J,IDT,FAC,1)=$$ESCP^ORWRP4("1^"_$P($G(NODE),"^",2)) ;Facility - .. S ^TMP("ORXS1",$J,IDT,FAC,2)=$$ESCP^ORWRP4("2^"_$$DATE^ORDVU($$SETDATE^ORWRP4($P($G(NODE),"^",4)))) ;Date/Time - . S ^TMP("ORXS1",$J,IDT,FAC,IFN)=$$ESCP^ORWRP4(SAVE),IDT=OIDT - S ^TMP("ORXS1",$J,IDT,FAC,IFN)=$$ESCP^ORWRP4(SAVE) - Q +ORWRP4V ; slc/dcm - OE/RR HDR Report Extract RPC's Vitals;9/21/05 13:21 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215**;Dec 17, 1997 +VS ;Vitals code for HDR + N I,IFN,IFN1,IFN2,X,X1,X2,X4,X5,XIFN,ORX,COL,CODE,I1,CNT,%DT,FAC,FACU,NODE + K ^TMP("ORXS",$J) + S IFN="" + F S IFN=$O(^XTMP(HANDLE,"D",IFN)) Q:IFN="" S XIFN=^(IFN) D + . S X11=$P(XIFN,"^",11),X12=$P(XIFN,"^",12),X2=$P(XIFN,"^",2),FACU=X12 + . I X12="",X11,X11'=200 S FACU=$O(^DIC(4,"D",X11,0)) I FACU S FACU=$P(^DIC(4,FACU,0),"^") + . I '$L(FACU) S FACU=$S($L($P(XIFN,"^",2)):$P(XIFN,"^",2),1:"Unknown") + . S $P(XIFN,"^",2)=FACU,X4=$P($P(XIFN,"^",4),":",1,2),X5=$P($P(XIFN,"^",5),"~",2) + . I $P(XIFN,"^",10)'="W",$L(X5) D + .. S X4=9999999-$$SETDATE^ORWRP4(X4) + .. I X4=9999999 F I=.01:.01 S X4=X4+I I '$D(^TMP("ORXS",$J,FACU,X4)) Q + .. S ^TMP("ORXS",$J,FACU,X4)=$P(XIFN,"^",2),^TMP("ORXS",$J,FACU,X4,X5,IFN)=XIFN + K ^TMP("ORXS1",$J) + S FAC="",CNT=-1 + F S FAC=$O(^TMP("ORXS",$J,FAC)) Q:FAC="" S IFN="" F S IFN=$O(^TMP("ORXS",$J,FAC,IFN)) Q:IFN="" S NODE=^(IFN) D + . D XVSET("1^"_$P(NODE,"^"),1,FAC,IFN,NODE) ;Facility + . I $P(IFN,".")'=9999999 D XVSET("2^"_$$DATE^ORDVU(9999999-IFN),2,FAC,IFN,NODE) ; Measurement Date/Time + . I $P(IFN,".")=9999999 D XVSET("2^"_" ",2,FAC,IFN,NODE) ; Measurement Date/Time = "" + . S IFN1="" + . F S IFN1=$O(^TMP("ORXS",$J,FAC,IFN,IFN1)) Q:IFN1="" S IFN2="" F S IFN2=$O(^TMP("ORXS",$J,FAC,IFN,IFN1,IFN2)) Q:IFN2="" S X=^(IFN2) D + .. I $$UPPER^ORU(IFN1)="TEMPERATURE" D XVSET("3^"_$P(X,"^",6),3,FAC,IFN,X) + .. I $$UPPER^ORU(IFN1)="PULSE" D XVSET("4^"_$P(X,"^",6),4,FAC,IFN,X) + .. I $$UPPER^ORU(IFN1)="RESPIRATION" D XVSET("5^"_$P(X,"^",6),5,FAC,IFN,X) + .. I $$UPPER^ORU(IFN1)="BLOOD PRESSURE" D XVSET("6^"_$P(X,"^",6),6,FAC,IFN,X) + .. I $$UPPER^ORU(IFN1)="HEIGHT" D XVSET("7^"_$P(X,"^",6),7,FAC,IFN,X) + .. I $$UPPER^ORU(IFN1)="WEIGHT" D XVSET("8^"_$P(X,"^",6),8,FAC,IFN,X) + .. I $$UPPER^ORU(IFN1)="PAIN" D XVSET("9^"_$P(X,"^",6),9,FAC,IFN,X) + .. I $$UPPER^ORU(IFN1)="PULSE OXIMETRY" D XVSET("10^"_$P(X,"^",6),10,FAC,IFN,X) + .. I $$UPPER^ORU(IFN1)="CENTRAL VENOUS PRESSURE" D XVSET("11^"_$P(X,"^",6),11,FAC,IFN,X) + .. I $$UPPER^ORU(IFN1)="CIRCUMFERENCE/GIRTH" D XVSET("12^"_$P(X,"^",6),12,FAC,IFN,X) + K ^XTMP(HANDLE,"D") + S FAC="",CNT=-1 + F S FAC=$O(^TMP("ORXS1",$J,FAC)) Q:FAC="" S IFN="" F S IFN=$O(^TMP("ORXS1",$J,FAC,IFN)) Q:IFN="" S IFN1="" D + . F S IFN1=$O(^TMP("ORXS1",$J,FAC,IFN,IFN1)) Q:IFN1="" S X=^(IFN1) D + .. S CNT=CNT+1,^XTMP(HANDLE,"D",CNT)=X + K ^TMP("ORXS",$J),^TMP("ORXS1",$J) + Q +XVSET(X,IFN,FAC,IDT,NODE) ;Setup Vitals nodes + Q:'$D(X) Q:'$L($G(IDT)) + N SAVE,OIDT + S SAVE=X + I '$L($G(IFN)) S CNT=CNT+1,^TMP("ORXS1",$J,IDT,FAC,CNT)=$$ESCP^ORWRP4(SAVE) Q + I $D(^TMP("ORXS1",$J,IDT,FAC,IFN)) D Q ;Get data where item, facility, date/time are the same + . S OIDT=IDT + . F S IDT=IDT+.0001 Q:'$D(^TMP("ORXS1",$J,IDT,IFN)) + . I '$D(^TMP("ORXS1",$J,IDT,FAC,IFN)) D + .. S ^TMP("ORXS1",$J,IDT,FAC,1)=$$ESCP^ORWRP4("1^"_$P($G(NODE),"^",2)) ;Facility + .. S ^TMP("ORXS1",$J,IDT,FAC,2)=$$ESCP^ORWRP4("2^"_$$DATE^ORDVU($$SETDATE^ORWRP4($P($G(NODE),"^",4)))) ;Date/Time + . S ^TMP("ORXS1",$J,IDT,FAC,IFN)=$$ESCP^ORWRP4(SAVE),IDT=OIDT + S ^TMP("ORXS1",$J,IDT,FAC,IFN)=$$ESCP^ORWRP4(SAVE) + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWTIU.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWTIU.m index daf4679c..16871e18 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWTIU.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWTIU.m @@ -1,81 +1,80 @@ -ORWTIU ; slc/REV - Functions for GUI PARAMETER ACTIONS ; 08 Feb 2001 09:02AM - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,132,195,243**;Dec 17, 1997;Build 242 - ; -GTTIUCTX(Y,ORUSER) ; Returns current Notes view context for user - N OCCLIM,SHOWSUB - S Y=$$GET^XPAR("ALL","ORCH CONTEXT NOTES",1) - I +$P(Y,";",5)=0 D - . S OCCLIM=$P($$PERSPRF^TIULE(DUZ),U,10) - . S:+OCCLIM>0 $P(Y,";",5)=OCCLIM - S SHOWSUB=$P(Y,";",6) - S $P(Y,";",6)=$S(SHOWSUB'="":SHOWSUB,1:0) - Q -SVTIUCTX(Y,ORCTXT) ; Save new Notes view preferences for user - N TMP - S TMP=$$GET^XPAR(DUZ_";VA(200,","ORCH CONTEXT NOTES",1) - I TMP'="" D Q - . D CHG^XPAR(DUZ_";VA(200,","ORCH CONTEXT NOTES",1,ORCTXT) - D ADD^XPAR(DUZ_";VA(200,","ORCH CONTEXT NOTES",1,ORCTXT) - Q - ; -GTDCCTX(Y,ORUSER) ; Returns current DC Summary view context for user - N OCCLIM,SHOWSUB - S Y=$$GET^XPAR("ALL","ORCH CONTEXT SUMMRIES",1) - I +$P(Y,";",5)=0 D - . S OCCLIM=$P($$PERSPRF^TIULE(DUZ),U,10) - . S:+OCCLIM>0 $P(Y,";",5)=OCCLIM - S SHOWSUB=$P(Y,";",6) - S $P(Y,";",6)=$S(SHOWSUB'="":SHOWSUB,1:0) - Q -SVDCCTX(Y,ORCTXT) ; Save new DC Summary view preferences for user - N TMP - S TMP=$$GET^XPAR(DUZ_";VA(200,","ORCH CONTEXT SUMMRIES",1) - I TMP'="" D Q - . D CHG^XPAR(DUZ_";VA(200,","ORCH CONTEXT SUMMRIES",1,ORCTXT) - D ADD^XPAR(DUZ_";VA(200,","ORCH CONTEXT SUMMRIES",1,ORCTXT) - Q - ; -PRINTW(ORY,ORDA,ORFLG) ;TIU print to windows printer - N ZTQUEUED,ORHFS,ORSUB,ORIO,ORSTATUS,ROOT,ORERR,ORWIN,ORHANDLE - N IOM,IOSL,IOST,IOF,IOT,IOS - S (ORSUB,ROOT)="ORDATA",ORIO="OR WINDOWS HFS",ORWIN=1,ORHANDLE="ORWTIU" - S ORY=$NA(^TMP(ORSUB,$J,1)) - S ORHFS=$$HFS^ORWRP() - D HFSOPEN^ORWRP(ORHANDLE,ORHFS,"W") - I POP D Q - . I $D(ROOT) D SETITEM^ORWRP(.ROOT,"ERROR: Unable to open HFS file for TIU print") - D IOVAR^ORWRP(.ORIO,,,"P-WINHFS80") - N $ETRAP,$ESTACK - S $ETRAP="D ERR^ORWRP Q" - U IO - D RPC^TIUPD(.ORERR,ORDA,ORIO,ORFLG,ORWIN) - D HFSCLOSE^ORWRP(ORHANDLE,ORHFS) - Q -GTLSTITM(ORY,ORTIUDA) ; Return single listbox item for document - Q:+$G(ORTIUDA)=0 - S ORY=ORTIUDA_U_$$RESOLVE^TIUSRVLO(ORTIUDA) - Q -IDNOTES(ORY) ; Is ID Notes installed? - S ORY=$$PATCH^XPDUTL("TIU*1.0*100") - Q -CANLINK(ORY,ORTITLE) ;Can the title be an ID child? - ; DBIA #2322 - S ORY=$$CANLINK^TIULP(ORTITLE) - Q -GETCP(ORY,ORTIUDA) ; Checks required CP fields before signature - S ORY="" - N ORTITLE,ORAUTH,ORCOS,ORPSUMCD,ORPROCDT,ORROOT,ORERR,ORREFDT - S ORERR="",ORROOT=$NA(^TMP("ORTIU",$J)) - D EXTRACT^TIULQ(ORTIUDA,.ORROOT,.ORERR,".01;1202;1208;70201;70202;1301",,,"I") - S ORTITLE=@ORROOT@(ORTIUDA,".01","I") - S ORAUTH=@ORROOT@(ORTIUDA,"1202","I") - S ORCOS=@ORROOT@(ORTIUDA,"1208","I") - S ORPSUMCD=@ORROOT@(ORTIUDA,"70201","I") - S ORPROCDT=@ORROOT@(ORTIUDA,"70202","I") - S ORREFDT=@ORROOT@(ORTIUDA,"1301","I") - S ORY=ORAUTH_U_ORCOS_U_ORPSUMCD_U_ORPROCDT_U_ORTITLE_U_ORREFDT - K @ORROOT - Q -CHKTXT(ORY,ORTIUDA) ; Checks for presence of text before signature - S ORY='$$EMPTYDOC^TIULF(ORTIUDA) ;DBIA #4426 - Q +ORWTIU ; slc/REV - Functions for GUI PARAMETER ACTIONS ; 08 Feb 2001 09:02AM + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,132,195**;Dec 17, 1997 + ; +GTTIUCTX(Y,ORUSER) ; Returns current Notes view context for user + N OCCLIM,SHOWSUB + S Y=$$GET^XPAR("ALL","ORCH CONTEXT NOTES",1) + I +$P(Y,";",5)=0 D + . S OCCLIM=$P($$PERSPRF^TIULE(DUZ),U,10) + . S:+OCCLIM>0 $P(Y,";",5)=OCCLIM + S SHOWSUB=$P(Y,";",6) + S $P(Y,";",6)=$S(SHOWSUB'="":SHOWSUB,1:0) + Q +SVTIUCTX(Y,ORCTXT) ; Save new Notes view preferences for user + N TMP + S TMP=$$GET^XPAR(DUZ_";VA(200,","ORCH CONTEXT NOTES",1) + I TMP'="" D Q + . D CHG^XPAR(DUZ_";VA(200,","ORCH CONTEXT NOTES",1,ORCTXT) + D ADD^XPAR(DUZ_";VA(200,","ORCH CONTEXT NOTES",1,ORCTXT) + Q + ; +GTDCCTX(Y,ORUSER) ; Returns current DC Summary view context for user + N OCCLIM,SHOWSUB + S Y=$$GET^XPAR("ALL","ORCH CONTEXT SUMMRIES",1) + I +$P(Y,";",5)=0 D + . S OCCLIM=$P($$PERSPRF^TIULE(DUZ),U,10) + . S:+OCCLIM>0 $P(Y,";",5)=OCCLIM + S SHOWSUB=$P(Y,";",6) + S $P(Y,";",6)=$S(SHOWSUB'="":SHOWSUB,1:0) + Q +SVDCCTX(Y,ORCTXT) ; Save new DC Summary view preferences for user + N TMP + S TMP=$$GET^XPAR(DUZ_";VA(200,","ORCH CONTEXT SUMMRIES",1) + I TMP'="" D Q + . D CHG^XPAR(DUZ_";VA(200,","ORCH CONTEXT SUMMRIES",1,ORCTXT) + D ADD^XPAR(DUZ_";VA(200,","ORCH CONTEXT SUMMRIES",1,ORCTXT) + Q + ; +PRINTW(ORY,ORDA,ORFLG) ;TIU print to windows printer + N ZTQUEUED,ORHFS,ORSUB,ORIO,ORSTATUS,ROOT,ORERR,ORWIN,ORHANDLE + N IOM,IOSL,IOST,IOF,IOT,IOS + S (ORSUB,ROOT)="ORDATA",ORIO="OR WINDOWS HFS",ORWIN=1,ORHANDLE="ORWTIU" + S ORY=$NA(^TMP(ORSUB,$J,1)) + S ORHFS=$$HFS^ORWRP() + D HFSOPEN^ORWRP(ORHANDLE,ORHFS,"W") + I POP D Q + . I $D(ROOT) D SETITEM^ORWRP(.ROOT,"ERROR: Unable to open HFS file for TIU print") + D IOVAR^ORWRP(.ORIO,,,"P-WINHFS80") + N $ETRAP,$ESTACK + S $ETRAP="D ERR^ORWRP Q" + U IO + D RPC^TIUPD(.ORERR,ORDA,ORIO,ORFLG,ORWIN) + D HFSCLOSE^ORWRP(ORHANDLE,ORHFS) + Q +GTLSTITM(ORY,ORTIUDA) ; Return single listbox item for document + Q:+$G(ORTIUDA)=0 + S ORY=ORTIUDA_U_$$RESOLVE^TIUSRVLO(ORTIUDA) + Q +IDNOTES(ORY) ; Is ID Notes installed? + S ORY=$$PATCH^XPDUTL("TIU*1.0*100") + Q +CANLINK(ORY,ORTITLE) ;Can the title be an ID child? + ; DBIA #2322 + S ORY=$$CANLINK^TIULP(ORTITLE) + Q +GETCP(ORY,ORTIUDA) ; Checks required CP fields before signature + S ORY="" + N ORTITLE,ORAUTH,ORCOS,ORPSUMCD,ORPROCDT,ORROOT,ORERR + S ORERR="",ORROOT=$NA(^TMP("ORTIU",$J)) + D EXTRACT^TIULQ(ORTIUDA,.ORROOT,.ORERR,".01;1202;1208;70201;70202",,,"I") + S ORTITLE=@ORROOT@(ORTIUDA,".01","I") + S ORAUTH=@ORROOT@(ORTIUDA,"1202","I") + S ORCOS=@ORROOT@(ORTIUDA,"1208","I") + S ORPSUMCD=@ORROOT@(ORTIUDA,"70201","I") + S ORPROCDT=@ORROOT@(ORTIUDA,"70202","I") + S ORY=ORAUTH_U_ORCOS_U_ORPSUMCD_U_ORPROCDT_U_ORTITLE + K @ORROOT + Q +CHKTXT(ORY,ORTIUDA) ; Checks for presence of text before signature + S ORY='$$EMPTYDOC^TIULF(ORTIUDA) ;DBIA #4426 + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWTPD.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWTPD.m index d7d11538..93b190aa 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWTPD.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWTPD.m @@ -1,102 +1,100 @@ -ORWTPD ; slc/jdl - Personal Reference Tool ;6/20/02 11:40am [7/22/03 11:27am] - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**109,120,132,148,141,173,195,243**;Dec 17,1997;Build 242 - ;; Allow user to customize the CPRS reports date/time - ;; and max occurences setting - ; -SUDF(Y,VALUE) ;----Set user default for all CPRS reports - N ORERR S ORERR="" - I VALUE=$$GET^XPAR("DIV^SYS^PKG","ORWRP TIME/OCC LIMITS ALL",1,"I") D DEL^XPAR(DUZ_";VA(200,","ORWRP TIME/OCC LIMITS ALL",1,.ORERR) K ORERR Q - E D EN^XPAR(DUZ_";VA(200,","ORWRP TIME/OCC LIMITS ALL",1,VALUE,.ORERR) - S Y=1 - K ORERR,VALUES1 - Q - ; -SUINDV(Y,RPTS,VALUE) ;----Set user individual time/occ setting - ; RPTS format: RPTIen^RPTIen^RPTIen such as 1^2^3 - I $L(RPTS)=0 Q - N ORERR,RPTID,P1,P7 S ORERR=0 - S (P1,P7)="" - F I=1:1:$L(RPTS,"^") S RPTID=$P(RPTS,U,I) D - . S P1=$P($G(^ORD(101.24,RPTID,0)),U),P7=$P($G(^(0)),U,7) - . I "02345"[P7,(P1'="ORRP IMAGING") D DEL^XPAR("USR.`"_DUZ,"ORWRP TIME/OCC LIMITS INDV",RPTID,.ORERR) Q - . D EN^XPAR(DUZ_";VA(200,","ORWRP TIME/OCC LIMITS INDV",RPTID,VALUE,.ORERR) - Q - ; -GETIMG(Y,RPT) ; ----Get Image (local only) Time/Occ - N IMGID,BEG,END,MAX - S IMGID=0,Y="" - S IMGID=$O(^ORD(101.24,"B","ORRP IMAGING",0)) - D GETINDV(.Y,IMGID) - I $L(Y) D - . S BEG=$$DT^ORCHTAB1($P(Y,";")) - . S END=$$DT^ORCHTAB1($P(Y,";",2)) - . S MAX=$P(Y,";",3) - . S Y=BEG_"^"_END_"^"_MAX - I Y="" D GETDEF^ORWRA(.Y) - Q - ; -GETINDV(Y,RPT) ;----Get time/occ limits for this report - ;RPT: Report IEN of 101.24 - N CTX,X0,X4,X,IMGCTX - S X0=$G(^ORD(101.24,RPT,0)),X4=$G(^(4)) - I "02345"[($P(X0,U,7)),($P(X0,U)'="ORRP IMAGING") Q - S CTX="^DIV^SYS^PKG" - S Y=$$GET^XPAR("USR.`"_DUZ_CTX,"ORWRP TIME/OCC LIMITS INDV",RPT,"I") - S:'$L(Y) Y=$$GET^XPAR("USR.`"_DUZ_CTX,"ORWRP TIME/OCC LIMITS ALL",1,"I") - I $P(^ORD(101.24,RPT,0),U,7)=1 S $P(Y,";",3)="" - I $P(X4,"^",2) S X=$P($P(Y,";"),"-",2) I X,X>$P(X4,"^",2) S Y="T-"_$P(X4,"^",2)_";"_$P(Y,";",2,99) - Q - ; -GETSETS(Y) ;----Get time/occ limit set for each report - N I,CNT,CAT,SEC - S I=0,CNT=1,RST="" - F S I=$O(^ORD(101.24,I)) Q:'I D - . I $P($G(^ORD(101.24,I,0)),U,12)'="M" D - .. S CAT=$P(^ORD(101.24,I,0),U,7),SEC=$P(^(0),U,8) - .. I $S(CAT=1:1,CAT=6:1,1:0)!($P(^(0),U)="ORRP IMAGING") D - ... D GETINDV(.RST,I) - ... I $L($P(^ORD(101.24,I,2),U,4))>0 S Y(CNT)=I_U_$P(^(2),U,4)_" ["_SEC_"]"_U_RST - ... E S Y(CNT)=I_U_$P(^ORD(101.24,I,2),U,3)_" ["_SEC_"]"_U_RST - ... S CNT=CNT+1 - K I,CNT,RST,CAT - Q - ; -GETDFLT(Y) ;----Get default time/occ limits for all reports - N VALUE - S Y=$$GET^XPAR("USR.`"_DUZ_"^DIV^SYS^PKG","ORWRP TIME/OCC LIMITS ALL",1,"I") - K VALUE - Q - ; -RSDFLT(Y) ;----Retrieve sys/pkg level default time/occ setting - N VALUE - S Y=$$GET^XPAR("DIV^SYS^PKG","ORWRP TIME/OCC LIMITS ALL",1,"I") - Q - ; -DELDFLT(Y) ;----Delete user's default setting - N ORERR S ORERR="" - D NDEL^XPAR(DUZ_";VA(200,","ORWRP TIME/OCC LIMITS INDV",.ORERR) - D DEL^XPAR(DUZ_";VA(200,","ORWRP TIME/OCC LIMITS ALL",1,.ORERR) - K ORERR - Q - ; -ACTDF(Y) ;----Make default setting take action for each report - N IND,DFLT,VALUE,X,X0,X4,MAX,DFLT1 - S DFLT=$$GET^XPAR("USR.`"_DUZ_"^DIV^SYS^PKG","ORWRP TIME/OCC LIMITS ALL",1,"I") - S IND=0,X=$P($P(DFLT,";"),"-",2) - F S IND=$O(^ORD(101.24,IND)) Q:'IND S X0=$G(^(IND,0)),X4=$G(^(4)) D - . I $P(X0,"^",8)="R",$P(X0,"^",12)'="M" D - .. S MAX=$P(X4,"^",2),DFLT1=DFLT - .. I MAX,X,X>MAX S DFLT1="T-"_MAX_";"_$P(DFLT,";",2,99) - .. D SUINDV(.Y,IND,DFLT1) - Q -GETOCM(ORY) ;Get value of "ORCH CONTEXT MEDS" - S ORY=$$GET^XPAR("ALL","ORCH CONTEXT MEDS") - Q - ; -PUTOCM(ORY,ORVAL) ;Set value of "ORCH CONTEXT MEDS" - I '$L(ORVAL) D DEL^XPAR("USR.`"_DUZ,"ORCH CONTEXT MEDS",1) Q - N ORERR S ORERR="" - D EN^XPAR(DUZ_";VA(200,","ORCH CONTEXT MEDS",1,ORVAL,.ORERR) - S ORY=ORERR - Q - ; +ORWTPD ; slc/jdl - Personal Reference Tool ;6/20/02 11:40am [7/22/03 11:27am] + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**109,120,132,148,141,173,195**;Dec 17,1997 + ;; Allow user to customize the CPRS reports date/time + ;; and max occurences setting + ; +SUDF(Y,VALUE) ;----Set user default for all CPRS reports + N ORERR S ORERR="" + I VALUE=$$GET^XPAR("DIV^SYS^PKG","ORWRP TIME/OCC LIMITS ALL",1,"I") D DEL^XPAR(DUZ_";VA(200,","ORWRP TIME/OCC LIMITS ALL",1,.ORERR) K ORERR Q + E D EN^XPAR(DUZ_";VA(200,","ORWRP TIME/OCC LIMITS ALL",1,VALUE,.ORERR) + S Y=1 + K ORERR,VALUES1 + Q + ; +SUINDV(Y,RPTS,VALUE) ;----Set user individual time/occ setting + ; RPTS format: RPTIen^RPTIen^RPTIen such as 1^2^3 + I $L(RPTS)=0 Q + N ORERR,RPTID,P1,P7 S ORERR=0 + S (P1,P7)="" + F I=1:1:$L(RPTS,"^") S RPTID=$P(RPTS,U,I) D + . S P1=$P($G(^ORD(101.24,RPTID,0)),U),P7=$P($G(^(0)),U,7) + . I "02345"[P7,(P1'="ORRP IMAGING") D DEL^XPAR("USR.`"_DUZ,"ORWRP TIME/OCC LIMITS INDV",RPTID,.ORERR) Q + . D EN^XPAR(DUZ_";VA(200,","ORWRP TIME/OCC LIMITS INDV",RPTID,VALUE,.ORERR) + Q + ; +GETIMG(Y,RPT) ; ----Get Image (local only) Time/Occ + N IMGID,BEG,END,MAX + S IMGID=0,Y="" + S IMGID=$O(^ORD(101.24,"B","ORRP IMAGING",0)) + D GETINDV(.Y,IMGID) + I $L(Y) D + . S BEG=$$DT^ORCHTAB1($P(Y,";")) + . S END=$$DT^ORCHTAB1($P(Y,";",2)) + . S MAX=$P(Y,";",3) + . S Y=BEG_"^"_END_"^"_MAX + I Y="" D GETDEF^ORWRA(.Y) + Q + ; +GETINDV(Y,RPT) ;----Get time/occ limits for this report + ;RPT: Report IEN of 101.24 + N CTX,X0,X4,X,IMGCTX + S X0=$G(^ORD(101.24,RPT,0)),X4=$G(^(4)) + I "02345"[($P(X0,U,7)),($P(X0,U)'="ORRP IMAGING") Q + S CTX="^DIV^SYS^PKG" + S Y=$$GET^XPAR("USR.`"_DUZ_CTX,"ORWRP TIME/OCC LIMITS INDV",RPT,"I") + S:'$L(Y) Y=$$GET^XPAR("USR.`"_DUZ_CTX,"ORWRP TIME/OCC LIMITS ALL",1,"I") + I $P(^ORD(101.24,RPT,0),U,7)=1 S $P(Y,";",3)="" + I $P(X4,"^",2) S X=$P($P(Y,";"),"-",2) I X,X>$P(X4,"^",2) S Y="T-"_$P(X4,"^",2)_";"_$P(Y,";",2,99) + Q + ; +GETSETS(Y) ;----Get time/occ limit set for each report + N I,CNT,CAT S I=0,CNT=1,RST="" + F S I=$O(^ORD(101.24,I)) Q:'I D + .I $P($G(^ORD(101.24,I,0)),U,8)="R",$P($G(^ORD(101.24,I,0)),U,12)'="M" D + ..S CAT=$P(^ORD(101.24,I,0),U,7) I $S(CAT=1:1,CAT=6:1,1:0)!($P(^(0),U)="ORRP IMAGING") D + ...D GETINDV(.RST,I) + ...I $L($P(^ORD(101.24,I,2),U,4))>0 S Y(CNT)=I_U_$P(^ORD(101.24,I,2),U,4)_U_RST + ...E S Y(CNT)=I_U_$P(^ORD(101.24,I,2),U,3)_U_RST + ... S CNT=CNT+1 + K I,CNT,RST,CAT + Q + ; +GETDFLT(Y) ;----Get default time/occ limits for all reports + N VALUE + S Y=$$GET^XPAR("USR.`"_DUZ_"^DIV^SYS^PKG","ORWRP TIME/OCC LIMITS ALL",1,"I") + K VALUE + Q + ; +RSDFLT(Y) ;----Retrieve sys/pkg level default time/occ setting + N VALUE + S Y=$$GET^XPAR("DIV^SYS^PKG","ORWRP TIME/OCC LIMITS ALL",1,"I") + Q + ; +DELDFLT(Y) ;----Delete user's default setting + N ORERR S ORERR="" + D NDEL^XPAR(DUZ_";VA(200,","ORWRP TIME/OCC LIMITS INDV",.ORERR) + D DEL^XPAR(DUZ_";VA(200,","ORWRP TIME/OCC LIMITS ALL",1,.ORERR) + K ORERR + Q + ; +ACTDF(Y) ;----Make default setting take action for each report + N IND,DFLT,VALUE,X,X0,X4,MAX,DFLT1 + S DFLT=$$GET^XPAR("USR.`"_DUZ_"^DIV^SYS^PKG","ORWRP TIME/OCC LIMITS ALL",1,"I") + S IND=0,X=$P($P(DFLT,";"),"-",2) + F S IND=$O(^ORD(101.24,IND)) Q:'IND S X0=$G(^(IND,0)),X4=$G(^(4)) D + . I $P(X0,"^",8)="R",$P(X0,"^",12)'="M" D + .. S MAX=$P(X4,"^",2),DFLT1=DFLT + .. I MAX,X,X>MAX S DFLT1="T-"_MAX_";"_$P(DFLT,";",2,99) + .. D SUINDV(.Y,IND,DFLT1) + Q +GETOCM(ORY) ;Get value of "ORCH CONTEXT MEDS" + S ORY=$$GET^XPAR("ALL","ORCH CONTEXT MEDS") + Q + ; +PUTOCM(ORY,ORVAL) ;Set value of "ORCH CONTEXT MEDS" + I '$L(ORVAL) D DEL^XPAR("USR.`"_DUZ,"ORCH CONTEXT MEDS",1) Q + N ORERR S ORERR="" + D EN^XPAR(DUZ_";VA(200,","ORCH CONTEXT MEDS",1,ORVAL,.ORERR) + S ORY=ORERR + Q + ; diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWTPL.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWTPL.m index b45161a8..4320946a 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWTPL.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWTPL.m @@ -1,129 +1,127 @@ -ORWTPL ; SLC/STAFF Personal Preference - Lists ; 3/11/08 6:36am - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,109,173,243**;Oct 24, 2000;Build 242 - ; -NEWLIST(VAL,LISTNAME,USER,ORVIZ) ; from ORWTPP - ; set user's new personal list - S LISTNAME=$G(LISTNAME) - I '$L(LISTNAME) S VAL="^invalid list name" Q - I $O(^OR(100.21,"B",LISTNAME,0)) S VAL="^invalid list name - duplicate of another name" Q - ;*** check input transform, duplicate name for same user - N DA,DIK,NUM - L +^OR(100.21,0):20 I '$T S VAL="^unable to set up" Q - S NUM=1+$P(^OR(100.21,0),U,3) - F Q:'$D(^OR(100.21,NUM,0)) S NUM=NUM+1 - S $P(^OR(100.21,0),U,3)=NUM,$P(^(0),U,4)=$P(^(0),U,4)+1 - S ^OR(100.21,NUM,0)=LISTNAME_"^P" - L -^OR(100.21,0) - K ^OR(100.21,NUM,1),^(2),^(10) - S ^OR(100.21,NUM,1,0)="^100.212PA^"_USER_"^1" - S ^OR(100.21,NUM,1,USER,0)=USER - S ^OR(100.21,NUM,11)=$G(ORVIZ)_U - S DIK="^OR(100.21,",DA=NUM - D IX1^DIK - S VAL=NUM_U_LISTNAME_"^^^^^^^"_$G(ORVIZ) - Q - ; -DELLIST(OK,LISTNUM,USER) ; from ORWTPP - ; delete user's personal list - N DA,DIK - S LISTNUM=+$G(LISTNUM),OK=1 - I '$O(^OR(100.21,"C",USER,LISTNUM,0)) S OK=0 Q - I $P($G(^OR(100.21,LISTNUM,0)),U,2)'="P" S OK=0 Q - S DA=LISTNUM,DIK="^OR(100.21," - D ^DIK - Q - ; -SAVELIST(OK,PLIST,LISTNUM,USER,ORVIZ) ; from ORWTPP - ; save user's personal list changes - N CNT,DA,DFN,DIK,NUM K DA - S LISTNUM=+$G(LISTNUM),OK=1 - I $P($G(^OR(100.21,LISTNUM,0)),U,2)'="P" S OK=0 Q - I '$D(^OR(100.21,"C",USER,LISTNUM)) S OK=0 Q - I '$D(^OR(100.21,LISTNUM,10,0))#2 S ^(0)="^100.2101AV^" - S DA(1)=LISTNUM,DIK="^OR(100.21,"_LISTNUM_",10," - S DA=0 F S DA=$O(^OR(100.21,LISTNUM,10,DA)) Q:DA<1 D ^DIK - K DA - S CNT=0 - S NUM=0 F S NUM=$O(PLIST(NUM)) Q:NUM<1 D - .S DFN=+PLIST(NUM) I 'DFN Q - .S CNT=CNT+1 - .S ^OR(100.21,LISTNUM,10,CNT,0)=DFN_";DPT(" - S ^OR(100.21,LISTNUM,10,0)="^100.2101AV^"_CNT_U_CNT - S ^OR(100.21,LISTNUM,11)=$G(ORVIZ)_U - S DA=LISTNUM,DIK="^OR(100.21," - D IX1^DIK - Q - ; -LSDEF(INFO,USER) ; from ORWTPP - ; get user's list sources - N TYPE - S INFO="" - F TYPE="P","S","T","W","C" D - .S INFO=INFO_$P($$LISTSRC^ORQPTQ11(USER,TYPE),U)_U - Q - ; -SORTDEF(SORT,USER) ; from ORWTPP - ; get user's sort order - Modified by PKS - 8/30/2001 - N ORSECT - S ORSECT=$G(^VA(200,USER,5)) - I +ORSECT>0 S ORSECT=$P(ORSECT,U) - S SORT=$$GET^XPAR("USR.`"_USER_"^SRV.`"_$G(ORSECT)_"^DIV^SYS^PKG","ORLP DEFAULT LIST ORDER",1,"I") I SORT']"" S SORT="A" - Q - ; -CLDAYS(DAYS,USER) ; from ORWTPP - ; get user's clinic defaults - N DAY - S DAYS="" - F DAY="MONDAY","TUESDAY","WEDNESDAY","THURSDAY","FRIDAY","SATURDAY","SUNDAY" D - .S DAYS=DAYS_$$GET^XPAR("USR.`"_USER,"ORLP DEFAULT CLINIC "_DAY,1,"I")_U - Q - ; -CLRANGE(RANGE,USER) ; from ORWTPP - ; get user's default clinic start, stop dates - N RNG - S RANGE="" - F RNG="START","STOP" D - .S RANGE=RANGE_$$GET^XPAR("USR.`"_USER,"ORLP DEFAULT CLINIC "_RNG_" DATE",1,"I")_U - Q - ; -SAVECD(OK,INFO,USER) ; from ORWTPP - ; save user's clinic defaults - N FRI,MON,SAT,START,STOP,SUN,THURS,TUES,WED - S OK=1 - S START=+$P(INFO,U,1) S START=$S(START=0:"T",START<0:"T"_START,1:"T+"_START) - S STOP=+$P(INFO,U,2) S STOP=$S(STOP=0:"T",STOP<0:"T"_STOP,1:"T+"_STOP) - S MON=+$P(INFO,U,3),MON=$S('MON:"@",1:"`"_MON) - S TUES=+$P(INFO,U,4),TUES=$S('TUES:"@",1:"`"_TUES) - S WED=+$P(INFO,U,5),WED=$S('WED:"@",1:"`"_WED) - S THURS=+$P(INFO,U,6),THURS=$S('THURS:"@",1:"`"_THURS) - S FRI=+$P(INFO,U,7),FRI=$S('FRI:"@",1:"`"_FRI) - S SAT=+$P(INFO,U,8),SAT=$S('SAT:"@",1:"`"_SAT) - S SUN=+$P(INFO,U,9),SUN=$S('SUN:"@",1:"`"_SUN) - D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC START DATE",1,START) - D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC STOP DATE",1,STOP) - D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC MONDAY",1,MON) - D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC TUESDAY",1,TUES) - D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC WEDNESDAY",1,WED) - D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC THURSDAY",1,THURS) - D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC FRIDAY",1,FRI) - D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC SATURDAY",1,SAT) - D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC SUNDAY",1,SUN) - Q - ; -SAVEPLD(OK,INFO,USER) ; from ORWTPP - ; save user's clinic defaults - N PROV,SORT,SOURCE,SPEC,TEAM,WARD - S OK=1 - S SOURCE=$P(INFO,U,1) - S SORT=$P(INFO,U,2) - S PROV=+$P(INFO,U,3),PROV=$S('PROV:"@",1:"`"_PROV) - S SPEC=+$P(INFO,U,4),SPEC=$S('SPEC:"@",1:"`"_SPEC) - S TEAM=+$P(INFO,U,5),TEAM=$S('TEAM:"@",1:"`"_TEAM) - S WARD=+$P(INFO,U,6),WARD=$S('WARD:"@",1:"`"_WARD) - D EN^XPAR(USER_";VA(200,","ORLP DEFAULT LIST SOURCE",1,SOURCE) - D EN^XPAR(USER_";VA(200,","ORLP DEFAULT LIST ORDER",1,SORT) - D EN^XPAR(USER_";VA(200,","ORLP DEFAULT PROVIDER",1,PROV) - D EN^XPAR(USER_";VA(200,","ORLP DEFAULT SPECIALTY",1,SPEC) - D EN^XPAR(USER_";VA(200,","ORLP DEFAULT TEAM",1,TEAM) - D EN^XPAR(USER_";VA(200,","ORLP DEFAULT WARD",1,WARD) - Q +ORWTPL ; SLC/STAFF Personal Preference - Lists ;4/30/01 11:04 [5/19/03 3:11pm] + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,109,173**;Oct 24, 2000 + ; +NEWLIST(VAL,LISTNAME,USER) ; from ORWTPP + ; set user's new personal list + S LISTNAME=$G(LISTNAME) + I '$L(LISTNAME) S VAL="^invalid list name" Q + I $O(^OR(100.21,"B",LISTNAME,0)) S VAL="^invalid list name - duplicate of another name" Q + ;*** check input transform, duplicate name for same user + N DA,DIK,NUM + L +^OR(100.21,0):20 I '$T S VAL="^unable to set up" Q + S NUM=1+$P(^OR(100.21,0),U,3) + F Q:'$D(^OR(100.21,NUM,0)) S NUM=NUM+1 + S $P(^OR(100.21,0),U,3)=NUM,$P(^(0),U,4)=$P(^(0),U,4)+1 + S ^OR(100.21,NUM,0)=LISTNAME_"^P" + L -^OR(100.21,0) + K ^OR(100.21,NUM,1),^(2),^(10) + S ^OR(100.21,NUM,1,0)="^100.212PA^"_USER_"^1" + S ^OR(100.21,NUM,1,USER,0)=USER + S DIK="^OR(100.21,",DA=NUM + D IX1^DIK + S VAL=NUM_U_LISTNAME + Q + ; +DELLIST(OK,LISTNUM,USER) ; from ORWTPP + ; delete user's personal list + N DA,DIK + S LISTNUM=+$G(LISTNUM),OK=1 + I '$O(^OR(100.21,"C",USER,LISTNUM,0)) S OK=0 Q + I $P($G(^OR(100.21,LISTNUM,0)),U,2)'="P" S OK=0 Q + S DA=LISTNUM,DIK="^OR(100.21," + D ^DIK + Q + ; +SAVELIST(OK,PLIST,LISTNUM,USER) ; from ORWTPP + ; save user's personal list changes + N CNT,DA,DFN,DIK,NUM K DA + S LISTNUM=+$G(LISTNUM),OK=1 + I $P($G(^OR(100.21,LISTNUM,0)),U,2)'="P" S OK=0 Q + I '$D(^OR(100.21,"C",USER,LISTNUM)) S OK=0 Q + I '$D(^OR(100.21,LISTNUM,10,0))#2 S ^(0)="^100.2101AV^" + S DA(1)=LISTNUM,DIK="^OR(100.21,"_LISTNUM_",10," + S DA=0 F S DA=$O(^OR(100.21,LISTNUM,10,DA)) Q:DA<1 D ^DIK + K DA + S CNT=0 + S NUM=0 F S NUM=$O(PLIST(NUM)) Q:NUM<1 D + .S DFN=+PLIST(NUM) I 'DFN Q + .S CNT=CNT+1 + .S ^OR(100.21,LISTNUM,10,CNT,0)=DFN_";DPT(" + S ^OR(100.21,LISTNUM,10,0)="^100.2101AV^"_CNT_U_CNT + S DA=LISTNUM,DIK="^OR(100.21," + D IX1^DIK + Q + ; +LSDEF(INFO,USER) ; from ORWTPP + ; get user's list sources + N TYPE + S INFO="" + F TYPE="P","S","T","W","C" D + .S INFO=INFO_$P($$LISTSRC^ORQPTQ11(USER,TYPE),U)_U + Q + ; +SORTDEF(SORT,USER) ; from ORWTPP + ; get user's sort order - Modified by PKS - 8/30/2001 + N ORSECT + S ORSECT=$G(^VA(200,USER,5)) + I +ORSECT>0 S ORSECT=$P(ORSECT,U) + S SORT=$$GET^XPAR("USR.`"_USER_"^SRV.`"_$G(ORSECT)_"^DIV^SYS^PKG","ORLP DEFAULT LIST ORDER",1,"I") I SORT']"" S SORT="A" + Q + ; +CLDAYS(DAYS,USER) ; from ORWTPP + ; get user's clinic defaults + N DAY + S DAYS="" + F DAY="MONDAY","TUESDAY","WEDNESDAY","THURSDAY","FRIDAY","SATURDAY","SUNDAY" D + .S DAYS=DAYS_$$GET^XPAR("USR.`"_USER,"ORLP DEFAULT CLINIC "_DAY,1,"I")_U + Q + ; +CLRANGE(RANGE,USER) ; from ORWTPP + ; get user's default clinic start, stop dates + N RNG + S RANGE="" + F RNG="START","STOP" D + .S RANGE=RANGE_$$GET^XPAR("USR.`"_USER,"ORLP DEFAULT CLINIC "_RNG_" DATE",1,"I")_U + Q + ; +SAVECD(OK,INFO,USER) ; from ORWTPP + ; save user's clinic defaults + N FRI,MON,SAT,START,STOP,SUN,THURS,TUES,WED + S OK=1 + S START=+$P(INFO,U,1) S START=$S(START=0:"T",START<0:"T"_START,1:"T+"_START) + S STOP=+$P(INFO,U,2) S STOP=$S(STOP=0:"T",STOP<0:"T"_STOP,1:"T+"_STOP) + S MON=+$P(INFO,U,3),MON=$S('MON:"@",1:"`"_MON) + S TUES=+$P(INFO,U,4),TUES=$S('TUES:"@",1:"`"_TUES) + S WED=+$P(INFO,U,5),WED=$S('WED:"@",1:"`"_WED) + S THURS=+$P(INFO,U,6),THURS=$S('THURS:"@",1:"`"_THURS) + S FRI=+$P(INFO,U,7),FRI=$S('FRI:"@",1:"`"_FRI) + S SAT=+$P(INFO,U,8),SAT=$S('SAT:"@",1:"`"_SAT) + S SUN=+$P(INFO,U,9),SUN=$S('SUN:"@",1:"`"_SUN) + D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC START DATE",1,START) + D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC STOP DATE",1,STOP) + D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC MONDAY",1,MON) + D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC TUESDAY",1,TUES) + D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC WEDNESDAY",1,WED) + D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC THURSDAY",1,THURS) + D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC FRIDAY",1,FRI) + D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC SATURDAY",1,SAT) + D EN^XPAR(USER_";VA(200,","ORLP DEFAULT CLINIC SUNDAY",1,SUN) + Q + ; +SAVEPLD(OK,INFO,USER) ; from ORWTPP + ; save user's clinic defaults + N PROV,SORT,SOURCE,SPEC,TEAM,WARD + S OK=1 + S SOURCE=$P(INFO,U,1) + S SORT=$P(INFO,U,2) + S PROV=+$P(INFO,U,3),PROV=$S('PROV:"@",1:"`"_PROV) + S SPEC=+$P(INFO,U,4),SPEC=$S('SPEC:"@",1:"`"_SPEC) + S TEAM=+$P(INFO,U,5),TEAM=$S('TEAM:"@",1:"`"_TEAM) + S WARD=+$P(INFO,U,6),WARD=$S('WARD:"@",1:"`"_WARD) + D EN^XPAR(USER_";VA(200,","ORLP DEFAULT LIST SOURCE",1,SOURCE) + D EN^XPAR(USER_";VA(200,","ORLP DEFAULT LIST ORDER",1,SORT) + D EN^XPAR(USER_";VA(200,","ORLP DEFAULT PROVIDER",1,PROV) + D EN^XPAR(USER_";VA(200,","ORLP DEFAULT SPECIALTY",1,SPEC) + D EN^XPAR(USER_";VA(200,","ORLP DEFAULT TEAM",1,TEAM) + D EN^XPAR(USER_";VA(200,","ORLP DEFAULT WARD",1,WARD) + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWTPP.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWTPP.m index ee7b0bff..5bfa341f 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWTPP.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWTPP.m @@ -1,218 +1,218 @@ -ORWTPP ; SLC/STAFF Personal Preference - Personal ; 3/11/08 6:34am - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,149,243**;Oct 24, 2000;Build 242 - ; -NEWLIST(VAL,LISTNAME,ORVIZ) ; RPC - ; set current user's new personal list - D NEWLIST^ORWTPL(.VAL,LISTNAME,DUZ,$G(ORVIZ)) - Q - ; -DELLIST(OK,LISTNUM) ; RPC - ; delete current user's personal list - D DELLIST^ORWTPL(.OK,LISTNUM,DUZ) - Q - ; -SAVELIST(OK,PLIST,LISTNUM,ORVIZ) ; RPC - ; save current user's personal list changes - D SAVELIST^ORWTPL(.OK,.PLIST,LISTNUM,DUZ,$G(ORVIZ)) - Q - ; -LSDEF(INFO) ; RPC - ; get current user's list sources - D LSDEF^ORWTPL(.INFO,DUZ) - Q - ; -SORTDEF(VALUE) ; RPC - ; get current user's sort order - D SORTDEF^ORWTPL(.VALUE,DUZ) - Q - ; -CLDAYS(INFO) ; RPC - ; get current user's clinic defaults - D CLDAYS^ORWTPL(.INFO,DUZ) - Q - ; -CLRANGE(INFO) ; RPC - ; get current user's default clinic start, stop dates - D CLRANGE^ORWTPL(.INFO,DUZ) - Q - ; -SAVECD(OK,INFO) ; RPC - ; save current user's clinic defaults - D SAVECD^ORWTPL(.OK,INFO,DUZ) - Q - ; -SAVEPLD(OK,INFO) ; RPC - ; save current user's list selection defaults - D SAVEPLD^ORWTPL(.OK,INFO,DUZ) - Q - ; -CSLAB(INFO) ; RPC - ; get lab date range defaults - D CSLAB^ORWTPO(.INFO,DUZ) - Q - ; -CSARNG(INFO) ; RPC - ; get current user's start, stop defaults - D CSARNG^ORWTPO(.INFO,DUZ) - Q - ; -SAVECS(OK,INFO) ; RPC - ; save current user's date range defaults - D SAVECS^ORWTPO(.OK,INFO,DUZ) - Q - ; -GETIMG(INFO) ; RPC - ; get current user's image report defaults - D GETIMG^ORWTPO(.INFO,DUZ) - Q - ; -SETIMG(OK,MAX,START,STOP) ; RPC - ; save current user's image report defaults - D SETIMG^ORWTPO(.OK,MAX,START,STOP,DUZ) - Q - ; -GETREM(VALUES) ; RPC - ; get current user's reminders - D GETREM^ORWTPR(.VALUES,DUZ) - Q - ; -SETREM(OK,VALUES) ; RPC - ; set current user's reminders - D SETREM^ORWTPR(.OK,.VALUES,DUZ) - Q - ; -GETOC(VALUES) ; RPC - ; get current user's order checks - D GETOC^ORWTPR(.VALUES,DUZ) - Q - ; -SAVEOC(OK,VALUES) ; RPC - ; save current user's order checks - D SAVEOC^ORWTPR(.OK,.VALUES,DUZ) - Q - ; -GETNOT(VALUES) ; RPC - ; get current user's notifications - D GETNOT^ORWTPR(.VALUES,DUZ) - Q - ; -SAVENOT(OK,VALUES) ; RPC - ; save current user's notifications - D SAVENOT^ORWTPR(.OK,.VALUES,DUZ) - Q - ; -CLEARNOT(OK) ; RPC - ; clear current user's notifications - D CLEARNOT^ORWTPR(.OK,DUZ) - Q - ; -GETNOTO(INFO) ; RPC - ; get current user's other info for notifications - D GETNOTO^ORWTPR(.INFO,DUZ) - Q - ; -CHKSURR(OK,SURR) ; RPC - ; check if current user's surrogate is valid - S OK=$$CHKSURR^ORWTPUA(DUZ,SURR) - Q - ; -GETSURR(INFO) ; RPC - ; get current user's surrogate info - D GETSURR^ORWTPR(.INFO,DUZ) - Q - ; -SAVESURR(OK,INFO) ; RPC - ; save current user's surrogate info - D SAVESURR^ORWTPR(.OK,INFO,DUZ) - Q - ; -SAVENOTO(OK,INFO) ; RPC - ; save current user's notification info - D SAVENOTO^ORWTPR(.OK,INFO,DUZ) - Q - ; -GETOTHER(INFO) ; RPC - ; get user's other parameter settings - D GETOTHER^ORWTPO(.INFO,DUZ) - Q - ; -SETOTHER(OK,INFO) ; RPC - ; set current user's other parameter settings - D SETOTHER^ORWTPO(.OK,INFO,DUZ) - Q - ; -GETSUB(VALUE) ; RPC - ; get Ask for Subject on notes for current user - D GETSUB^ORWTPN(.VALUE,DUZ) - Q - ; -GETCOS(VALUES,FROM,DIR,VISITORS) ; RPC - ; get elgible cosigners for current user - I '$G(VISITORS) S VISITORS="" - D GETCOS^ORWTPN(.VALUES,DUZ,FROM,DIR,VISITORS) - Q - ; -GETDCOS(VALUE) ; RPC - ; get default cosigner for current user - D GETDCOS^ORWTPN(.VALUE,DUZ) - Q - ; -SETDCOS(OK,VALUE) ; RPC - ; set default cosigner for current user - D SETDCOS^ORWTPN(.OK,VALUE,DUZ) - Q - ; -SETSUB(OK,VALUE) ; RPC - ; set Ask for Subject on note for current user - D SETSUB^ORWTPN(.OK,VALUE,DUZ) - Q - ; -GETTU(VALUES,CLASS) ; RPC - ; get titles for current user - D GETTU^ORWTPN(.VALUES,CLASS,DUZ) - Q - ; -GETTD(VALUE,CLASS) ; RPC - ; get default title for current user - D GETTD^ORWTPN(.VALUE,CLASS,DUZ) - Q - ; -SAVET(OK,CLASS,DEFAULT,VALUES) ; RPC - ; save titles for current user - D SAVET^ORWTPN(.OK,CLASS,DEFAULT,.VALUES,DUZ) - Q - ; -PLISTS(VALUES) ; RPC - ; get current user's personal lists - D PLISTS^ORWTPT(.VALUES,DUZ) - Q - ; -PLTEAMS(VALUES) ; RPC - ; get current user's teams and personal lists - D PLTEAMS^ORWTPT(.VALUES,DUZ) - Q - ; -TEAMS(VALUES) ; RPC - ; get teams for current user - D TEAMS^ORWTPT(.VALUES,DUZ) - Q - ; -ADDLIST(OK,VALUE) ; RPC - ; adds current user to a team - D ADDLIST^ORWTPT(.OK,VALUE,DUZ) - Q - ; -REMLIST(OK,VALUE) ; RPC - ; removes current user from a team - D REMLIST^ORWTPT(.OK,VALUE,DUZ) - Q - ; -GETCOMBO(VALUES) ; RPC - ; get current user's combo list definition - D GETCOMBO^ORWTPT(.VALUES,DUZ) - Q - ; -SETCOMBO(OK,VALUES) ; RPC - ; set current user's combo list definition - D SETCOMBO^ORWTPT(.OK,.VALUES,DUZ) - Q +ORWTPP ; SLC/STAFF Personal Preference - Personal ;1/19/01 15:30 [12/12/02 3:05pm] + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,149**;Oct 24, 2000 + ; +NEWLIST(VAL,LISTNAME) ; RPC + ; set current user's new personal list + D NEWLIST^ORWTPL(.VAL,LISTNAME,DUZ) + Q + ; +DELLIST(OK,LISTNUM) ; RPC + ; delete current user's personal list + D DELLIST^ORWTPL(.OK,LISTNUM,DUZ) + Q + ; +SAVELIST(OK,PLIST,LISTNUM) ; RPC + ; save current user's personal list changes + D SAVELIST^ORWTPL(.OK,.PLIST,LISTNUM,DUZ) + Q + ; +LSDEF(INFO) ; RPC + ; get current user's list sources + D LSDEF^ORWTPL(.INFO,DUZ) + Q + ; +SORTDEF(VALUE) ; RPC + ; get current user's sort order + D SORTDEF^ORWTPL(.VALUE,DUZ) + Q + ; +CLDAYS(INFO) ; RPC + ; get current user's clinic defaults + D CLDAYS^ORWTPL(.INFO,DUZ) + Q + ; +CLRANGE(INFO) ; RPC + ; get current user's default clinic start, stop dates + D CLRANGE^ORWTPL(.INFO,DUZ) + Q + ; +SAVECD(OK,INFO) ; RPC + ; save current user's clinic defaults + D SAVECD^ORWTPL(.OK,INFO,DUZ) + Q + ; +SAVEPLD(OK,INFO) ; RPC + ; save current user's list selection defaults + D SAVEPLD^ORWTPL(.OK,INFO,DUZ) + Q + ; +CSLAB(INFO) ; RPC + ; get lab date range defaults + D CSLAB^ORWTPO(.INFO,DUZ) + Q + ; +CSARNG(INFO) ; RPC + ; get current user's start, stop defaults + D CSARNG^ORWTPO(.INFO,DUZ) + Q + ; +SAVECS(OK,INFO) ; RPC + ; save current user's date range defaults + D SAVECS^ORWTPO(.OK,INFO,DUZ) + Q + ; +GETIMG(INFO) ; RPC + ; get current user's image report defaults + D GETIMG^ORWTPO(.INFO,DUZ) + Q + ; +SETIMG(OK,MAX,START,STOP) ; RPC + ; save current user's image report defaults + D SETIMG^ORWTPO(.OK,MAX,START,STOP,DUZ) + Q + ; +GETREM(VALUES) ; RPC + ; get current user's reminders + D GETREM^ORWTPR(.VALUES,DUZ) + Q + ; +SETREM(OK,VALUES) ; RPC + ; set current user's reminders + D SETREM^ORWTPR(.OK,.VALUES,DUZ) + Q + ; +GETOC(VALUES) ; RPC + ; get current user's order checks + D GETOC^ORWTPR(.VALUES,DUZ) + Q + ; +SAVEOC(OK,VALUES) ; RPC + ; save current user's order checks + D SAVEOC^ORWTPR(.OK,.VALUES,DUZ) + Q + ; +GETNOT(VALUES) ; RPC + ; get current user's notifications + D GETNOT^ORWTPR(.VALUES,DUZ) + Q + ; +SAVENOT(OK,VALUES) ; RPC + ; save current user's notifications + D SAVENOT^ORWTPR(.OK,.VALUES,DUZ) + Q + ; +CLEARNOT(OK) ; RPC + ; clear current user's notifications + D CLEARNOT^ORWTPR(.OK,DUZ) + Q + ; +GETNOTO(INFO) ; RPC + ; get current user's other info for notifications + D GETNOTO^ORWTPR(.INFO,DUZ) + Q + ; +CHKSURR(OK,SURR) ; RPC + ; check if current user's surrogate is valid + S OK=$$CHKSURR^ORWTPUA(DUZ,SURR) + Q + ; +GETSURR(INFO) ; RPC + ; get current user's surrogate info + D GETSURR^ORWTPR(.INFO,DUZ) + Q + ; +SAVESURR(OK,INFO) ; RPC + ; save current user's surrogate info + D SAVESURR^ORWTPR(.OK,INFO,DUZ) + Q + ; +SAVENOTO(OK,INFO) ; RPC + ; save current user's notification info + D SAVENOTO^ORWTPR(.OK,INFO,DUZ) + Q + ; +GETOTHER(INFO) ; RPC + ; get user's other parameter settings + D GETOTHER^ORWTPO(.INFO,DUZ) + Q + ; +SETOTHER(OK,INFO) ; RPC + ; set current user's other parameter settings + D SETOTHER^ORWTPO(.OK,INFO,DUZ) + Q + ; +GETSUB(VALUE) ; RPC + ; get Ask for Subject on notes for current user + D GETSUB^ORWTPN(.VALUE,DUZ) + Q + ; +GETCOS(VALUES,FROM,DIR,VISITORS) ; RPC + ; get elgible cosigners for current user + I '$G(VISITORS) S VISITORS="" + D GETCOS^ORWTPN(.VALUES,DUZ,FROM,DIR,VISITORS) + Q + ; +GETDCOS(VALUE) ; RPC + ; get default cosigner for current user + D GETDCOS^ORWTPN(.VALUE,DUZ) + Q + ; +SETDCOS(OK,VALUE) ; RPC + ; set default cosigner for current user + D SETDCOS^ORWTPN(.OK,VALUE,DUZ) + Q + ; +SETSUB(OK,VALUE) ; RPC + ; set Ask for Subject on note for current user + D SETSUB^ORWTPN(.OK,VALUE,DUZ) + Q + ; +GETTU(VALUES,CLASS) ; RPC + ; get titles for current user + D GETTU^ORWTPN(.VALUES,CLASS,DUZ) + Q + ; +GETTD(VALUE,CLASS) ; RPC + ; get default title for current user + D GETTD^ORWTPN(.VALUE,CLASS,DUZ) + Q + ; +SAVET(OK,CLASS,DEFAULT,VALUES) ; RPC + ; save titles for current user + D SAVET^ORWTPN(.OK,CLASS,DEFAULT,.VALUES,DUZ) + Q + ; +PLISTS(VALUES) ; RPC + ; get current user's personal lists + D PLISTS^ORWTPT(.VALUES,DUZ) + Q + ; +PLTEAMS(VALUES) ; RPC + ; get current user's teams and personal lists + D PLTEAMS^ORWTPT(.VALUES,DUZ) + Q + ; +TEAMS(VALUES) ; RPC + ; get teams for current user + D TEAMS^ORWTPT(.VALUES,DUZ) + Q + ; +ADDLIST(OK,VALUE) ; RPC + ; adds current user to a team + D ADDLIST^ORWTPT(.OK,VALUE,DUZ) + Q + ; +REMLIST(OK,VALUE) ; RPC + ; removes current user from a team + D REMLIST^ORWTPT(.OK,VALUE,DUZ) + Q + ; +GETCOMBO(VALUES) ; RPC + ; get current user's combo list definition + D GETCOMBO^ORWTPT(.VALUES,DUZ) + Q + ; +SETCOMBO(OK,VALUES) ; RPC + ; set current user's combo list definition + D SETCOMBO^ORWTPT(.OK,.VALUES,DUZ) + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWTPR.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWTPR.m index 5198c88b..650f659c 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWTPR.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWTPR.m @@ -1,126 +1,125 @@ -ORWTPR ; SLC/STAFF Personal Preference - Reminders ; 4/20/07 10:00am - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,173,215,243**;Oct 24, 2000;Build 242 - ; -GETREM(VALUES,USER) ; from ORWTPP - ; get user's reminders - N CLASS,CNT,ERR,IEN,NUM,OK,TMPLIST,ZERO K VALUES - D GETLST^XPAR(.TMPLIST,"USR.`"_USER,"ORQQPX SEARCH ITEMS","Q",.ERR) - S CNT=0,IEN=0 F S IEN=$O(^PXD(811.9,IEN)) Q:IEN<1 S ZERO=$G(^(IEN,0)) I $L($P(ZERO,U,3)),'$P(ZERO,U,6) D - .S CNT=CNT+1 - .S VALUES(CNT)=IEN_"^0^"_$P(ZERO,U,3)_U_$P(ZERO,U) - .S CLASS=$P($G(^PXD(811.9,IEN,100)),U) - .S $P(VALUES(CNT),U,5)=$S(CLASS="N":"NATIONAL",CLASS="L":"LOCAL",1:CLASS) - .S OK=0,NUM=0 F S NUM=$O(TMPLIST(NUM)) Q:NUM<1 D Q:OK - ..I IEN=$P(TMPLIST(NUM),U,2) S OK=1 - .I OK S $P(VALUES(CNT),U,2)=$P(TMPLIST(NUM),U) - Q - ; -SETREM(OK,VALUES,USER) ; from ORWTPP - ; save user's reminders - N NUM,ERR - S OK=1 - D NDEL^XPAR("USR.`"_USER,"ORQQPX SEARCH ITEMS",.ERR) - S NUM=0 F S NUM=$O(VALUES(NUM)) Q:NUM<1 D - .D EN^XPAR(USER_";VA(200,","ORQQPX SEARCH ITEMS",$P(VALUES(NUM),U,1),"`"_$P(VALUES(NUM),U,2),.ERR) - Q - ; -GETOC(VALUES,USER) ; from ORWTPP - ; get user's order checks - N CNT,IEN,LIST,NUM,VAL,VALOK K LIST,VALUES - S IEN=0 F S IEN=$O(^ORD(100.8,IEN)) Q:IEN<1 D - .S VAL=$$GET^XPAR("ALL","ORK PROCESSING FLAG",IEN,"I") - .I '$L(VAL) Q - .S VALOK=$$GET^XPAR("ALL","ORK EDITABLE BY USER",IEN,"I") - .S LIST(IEN)=VAL_U_VALOK - S NUM=0,CNT=0 F S NUM=$O(LIST(NUM)) Q:NUM<1 D - .S CNT=CNT+1 - .S VALUES(CNT)=NUM_U_$P($G(^ORD(100.8,NUM,0)),U)_U_$S($P(LIST(NUM),U)="E":"ON",1:"OFF")_U_$S($P(LIST(NUM),U,2)="0":"MANDATORY",1:"") - Q - ; -SAVEOC(OK,VALUES,USER) ; from ORWTPP - ; save user's order checks - N NUM,ERR - S OK=1 - S NUM=0 F S NUM=$O(VALUES(NUM)) Q:NUM<1 D - .D EN^XPAR(USER_";VA(200,","ORK PROCESSING FLAG","`"_+VALUES(NUM),$S($P(VALUES(NUM),U,2)="ON":"E",1:"D"),.ERR) - Q - ; - ; -GETNOT(VALUES,USER) ; from ORWTPP - ; get user's notifications - N CNT,IEN,NAME,RESULT K VALUES - S CNT=0 - S NAME="" F S NAME=$O(^ORD(100.9,"B",NAME)) Q:NAME="" D - .S IEN=0 F S IEN=$O(^ORD(100.9,"B",NAME,IEN)) Q:IEN<1 D - ..S RESULT=$$ONOFF^ORB3USER(IEN,USER,"","") I $L($G(RESULT)) D - ...S CNT=CNT+1 - ...S VALUES(CNT)=IEN_U_NAME_U_$P(RESULT,U)_U_$S($$UP^XLFSTR($P(RESULT,U,3))["MANDATORY":"MANDATORY",1:"") - Q - ; -SAVENOT(OK,VALUES,USER) ; from ORWTPP - ; save user's notifications - N ERR,NUM - S OK=1 - S NUM=0 F S NUM=$O(VALUES(NUM)) Q:NUM<1 D - .D EN^XPAR(USER_";VA(200,","ORB PROCESSING FLAG","`"_+VALUES(NUM),$S($P(VALUES(NUM),U,2)="ON":"E",1:"D"),.ERR) - Q - ; -CLEARNOT(OK,USER) ; from ORWTPP - ; clear user's notifications - D RECIPURG^XQALBUTL(USER) - S OK=1 - Q - ; -GETNOTO(INFO,USER) ; from ORWTPP - ; get user's other info for notifications - I $$GET^XPAR("USR.`"_USER,"ORB FLAGGED ORDERS BULLETIN",1,"Q")="Y" S $P(INFO,U,2)=1 - I $$GET^XPAR("ALL^USR.`"_USER,"ORB ERASE ALL",1,"Q") S $P(INFO,U,3)=1 - Q - ; -GETSURR(INFO,USER) ; from ORWTPP - ; get user's surrogate info - N SURR - D SUROLIST^XQALSURO(USER,.SURR) - S INFO=$G(SURR(1)) - Q - ; -SAVESURR(OK,INFO,USER) ; from ORWTPP - ; save user's surrogate info - N START,STOP,SURR,RET - S OK=1 - S SURR=$P(INFO,U,1) - S START=$P(INFO,U,2) - S STOP=$P(INFO,U,3) - S RET=$$SAVESURR^ORWTPUA(USER,SURR,START,STOP) - I 'RET S OK="0^"_RET - Q - ; -SAVENOTO(OK,INFO,USER) ; from ORWTPP - ; save user's notification settings - N ERR,FLAG,VAL - S OK=1 - S FLAG=$P(INFO,U,3) - S VAL=$S(FLAG>0:"Y",1:"@") - D EN^XPAR(USER_";VA(200,","ORB FLAGGED ORDERS BULLETIN",1,VAL,.ERR) - Q - ; -OCDESC(TEXT,IEN) ; from RPC - N CNT,LINE,NUM K TEXT - S IEN=+$G(IEN) I IEN<1 Q - S TEXT(1)=$P($G(^ORD(100.8,IEN,0)),U) - S TEXT(2)="" - S CNT=2 - S NUM=0 F S NUM=$O(^ORD(100.8,IEN,1,NUM)) Q:NUM<1 S LINE=$G(^(NUM,0)) D - .S CNT=CNT+1 - .S TEXT(CNT)=LINE - S TEXT(CNT+1)="" - Q - ; -NOTDESC(TEXT,IEN) ; from RPC - K TEXT - S IEN=+$G(IEN) I IEN<1 Q - S TEXT(1)=$P($G(^ORD(100.9,IEN,0)),U) - S TEXT(2)="" - S TEXT(3)=$P($G(^ORD(100.9,IEN,4)),U) - S TEXT(4)="" - Q +ORWTPR ; SLC/STAFF Personal Preference - Reminders ;5/3/01 15:32 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,173,215**;Oct 24, 2000 + ; +GETREM(VALUES,USER) ; from ORWTPP + ; get user's reminders + N CLASS,CNT,ERR,IEN,NUM,OK,TMPLIST,ZERO K VALUES + D GETLST^XPAR(.TMPLIST,"USR.`"_USER,"ORQQPX SEARCH ITEMS","Q",.ERR) + S CNT=0,IEN=0 F S IEN=$O(^PXD(811.9,IEN)) Q:IEN<1 S ZERO=$G(^(IEN,0)) I $L($P(ZERO,U,3)),'$P(ZERO,U,6) D + .S CNT=CNT+1 + .S VALUES(CNT)=IEN_"^0^"_$P(ZERO,U,3)_U_$P(ZERO,U) + .S CLASS=$P($G(^PXD(811.9,IEN,100)),U) + .S $P(VALUES(CNT),U,5)=$S(CLASS="N":"NATIONAL",CLASS="L":"LOCAL",1:CLASS) + .S OK=0,NUM=0 F S NUM=$O(TMPLIST(NUM)) Q:NUM<1 D Q:OK + ..I IEN=$P(TMPLIST(NUM),U,2) S OK=1 + .I OK S $P(VALUES(CNT),U,2)=$P(TMPLIST(NUM),U) + Q + ; +SETREM(OK,VALUES,USER) ; from ORWTPP + ; save user's reminders + N NUM,ERR + S OK=1 + D NDEL^XPAR("USR.`"_USER,"ORQQPX SEARCH ITEMS",.ERR) + S NUM=0 F S NUM=$O(VALUES(NUM)) Q:NUM<1 D + .D EN^XPAR(USER_";VA(200,","ORQQPX SEARCH ITEMS",$P(VALUES(NUM),U,1),"`"_$P(VALUES(NUM),U,2),.ERR) + Q + ; +GETOC(VALUES,USER) ; from ORWTPP + ; get user's order checks + N CNT,IEN,LIST,NUM,VAL,VALOK K LIST,VALUES + S IEN=0 F S IEN=$O(^ORD(100.8,IEN)) Q:IEN<1 D + .S VAL=$$GET^XPAR("ALL","ORK PROCESSING FLAG",IEN,"I") + .I '$L(VAL) Q + .S VALOK=$$GET^XPAR("ALL","ORK EDITABLE BY USER",IEN,"I") + .S LIST(IEN)=VAL_U_VALOK + S NUM=0,CNT=0 F S NUM=$O(LIST(NUM)) Q:NUM<1 D + .S CNT=CNT+1 + .S VALUES(CNT)=NUM_U_$P($G(^ORD(100.8,NUM,0)),U)_U_$S($P(LIST(NUM),U)="E":"ON",1:"OFF")_U_$S($P(LIST(NUM),U,2)="0":"MANDATORY",1:"") + Q + ; +SAVEOC(OK,VALUES,USER) ; from ORWTPP + ; save user's order checks + N NUM,ERR + S OK=1 + S NUM=0 F S NUM=$O(VALUES(NUM)) Q:NUM<1 D + .D EN^XPAR(USER_";VA(200,","ORK PROCESSING FLAG","`"_+VALUES(NUM),$S($P(VALUES(NUM),U,2)="ON":"E",1:"D"),.ERR) + Q + ; + ; +GETNOT(VALUES,USER) ; from ORWTPP + ; get user's notifications + N CNT,IEN,NAME,RESULT K VALUES + S CNT=0 + S NAME="" F S NAME=$O(^ORD(100.9,"B",NAME)) Q:NAME="" D + .S IEN=0 F S IEN=$O(^ORD(100.9,"B",NAME,IEN)) Q:IEN<1 D + ..S RESULT=$$ONOFF^ORB3USER(IEN,USER,"","") I $L($G(RESULT)) D + ...S CNT=CNT+1 + ...S VALUES(CNT)=IEN_U_NAME_U_$P(RESULT,U)_U_$S($$UP^XLFSTR($P(RESULT,U,3))["MANDATORY":"MANDATORY",1:"") + Q + ; +SAVENOT(OK,VALUES,USER) ; from ORWTPP + ; save user's notifications + N ERR,NUM + S OK=1 + S NUM=0 F S NUM=$O(VALUES(NUM)) Q:NUM<1 D + .D EN^XPAR(USER_";VA(200,","ORB PROCESSING FLAG","`"_+VALUES(NUM),$S($P(VALUES(NUM),U,2)="ON":"E",1:"D"),.ERR) + Q + ; +CLEARNOT(OK,USER) ; from ORWTPP + ; clear user's notifications + D RECIPURG^XQALBUTL(USER) + S OK=1 + Q + ; +GETNOTO(INFO,USER) ; from ORWTPP + ; get user's other info for notifications + I $$GET^XPAR("USR.`"_USER,"ORB FLAGGED ORDERS BULLETIN",1,"Q")="Y" S $P(INFO,U,2)=1 + I $$GET^XPAR("ALL^USR.`"_USER,"ORB ERASE ALL",1,"Q") S $P(INFO,U,3)=1 + Q + ; +GETSURR(INFO,USER) ; from ORWTPP + ; get user's surrogate info + N SURR + D SUROLIST^XQALSURO(USER,.SURR) + S INFO=$G(SURR(1)) + Q + ; +SAVESURR(OK,INFO,USER) ; from ORWTPP + ; save user's surrogate info + N START,STOP,SURR + S OK=1 + S SURR=$P(INFO,U,1) + S START=$P(INFO,U,2) + S STOP=$P(INFO,U,3) + D SAVESURR^ORWTPUA(USER,SURR,START,STOP) + Q + ; +SAVENOTO(OK,INFO,USER) ; from ORWTPP + ; save user's notification settings + N ERR,FLAG,VAL + S OK=1 + S FLAG=$P(INFO,U,3) + S VAL=$S(FLAG>0:"Y",1:"@") + D EN^XPAR(USER_";VA(200,","ORB FLAGGED ORDERS BULLETIN",1,VAL,.ERR) + Q + ; +OCDESC(TEXT,IEN) ; from RPC + N CNT,LINE,NUM K TEXT + S IEN=+$G(IEN) I IEN<1 Q + S TEXT(1)=$P($G(^ORD(100.8,IEN,0)),U) + S TEXT(2)="" + S CNT=2 + S NUM=0 F S NUM=$O(^ORD(100.8,IEN,1,NUM)) Q:NUM<1 S LINE=$G(^(NUM,0)) D + .S CNT=CNT+1 + .S TEXT(CNT)=LINE + S TEXT(CNT+1)="" + Q + ; +NOTDESC(TEXT,IEN) ; from RPC + K TEXT + S IEN=+$G(IEN) I IEN<1 Q + S TEXT(1)=$P($G(^ORD(100.9,IEN,0)),U) + S TEXT(2)="" + S TEXT(3)=$P($G(^ORD(100.9,IEN,4)),U) + S TEXT(4)="" + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWTPT.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWTPT.m index 2306c91b..6cf558fa 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWTPT.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWTPT.m @@ -1,142 +1,140 @@ -ORWTPT ; SLC/STAFF Personal Preference - Teams ;5/4/01 15:55 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,243**;Oct 24, 2000;Build 242 - ; -GETTEAM(USERS,TEAM) ; RPC - ; returns members of a team - N CNT,NAME,NUM,USER K USERS - S TEAM=+$G(TEAM),CNT=0 - S NUM=0 F S NUM=$O(^OR(100.21,TEAM,1,NUM)) Q:NUM<1 S USER=+$G(^(NUM,0)) D - .S NAME=$P($G(^VA(200,USER,0)),U) - .I '$L(NAME) Q - .S CNT=CNT+1 - .S USERS(CNT)=USER_U_NAME - Q - ; -TEAMS(TEAMS,USER) ; from ORWTPP - ; returns all teams a user is a member of (exculdes personal lists) - N CNT,NUM,ZERO K TEAMS - S USER=+$G(USER),CNT=0 - S NUM=0 F S NUM=$O(^OR(100.21,"C",USER,NUM)) Q:NUM<1 D - .S ZERO=$G(^OR(100.21,NUM,0)) - .I $P(ZERO,U,2)="P" Q - .S CNT=CNT+1 - .S TEAMS(CNT)=NUM_U_ZERO - Q - ; -PLISTS(TEAMS,USER) ; from ORWTPP - ; returns a user's personal lists - N CNT,NUM,ZERO K TEAMS - S USER=+$G(USER),CNT=0 - S NUM=0 F S NUM=$O(^OR(100.21,"C",USER,NUM)) Q:NUM<1 D - .S ZERO=$G(^OR(100.21,NUM,0)) - .I $P(ZERO,U,2)'="P" Q - .S CNT=CNT+1 - .N VIS S VIS=$P($G(^OR(100.21,NUM,11)),U) - .I '$L(VIS) S VIS=1 - .S TEAMS(CNT)=NUM_U_ZERO_U_VIS - Q - ; -PLTEAMS(TEAMS,USER) ; from ORWTPP - ; returns all teams and personal lists for a user - N CNT,NUM,ZERO K TEAMS - S USER=+$G(USER),CNT=0 - S NUM=0 F S NUM=$O(^OR(100.21,"C",USER,NUM)) Q:NUM<1 D - .S ZERO=$G(^OR(100.21,NUM,0)) - .S CNT=CNT+1 - .S TEAMS(CNT)=NUM_U_ZERO - Q - ; -ATEAMS(TEAMS) ; RPC - ; all teams available to subscribe to - N CNT,NAME,NODE,NUM K TEAMS - S CNT=0 - S NUM=0 F S NUM=$O(^OR(100.21,NUM)) Q:NUM<1 S NODE=$G(^(NUM,0)) D - .I $P(NODE,U,6)'="Y" Q - .I $P(NODE,U,2)="P" Q - .S CNT=CNT+1 - .S TEAMS(CNT)=NUM_U_NODE ;$P(NODE,U) - Q - ; -ADDLIST(OK,VALUE,USER) ; from ORWTPP - ; adds a user to a team - N DA,DIC,DLAYGO,X,Y K DA,DIC,DLAYGO - S USER=+$G(USER) - S DA=USER,DA(1)=+$G(VALUE),OK=1 - I '$D(^OR(100.21,DA(1),0)) Q - S DIC(0)="LM" - S DLAYGO=100.212 - S X=$P($G(^VA(200,USER,0)),U) - S DIC="^OR(100.21,"_DA(1)_",1," - D - .L +^OR(100.21,DA(1)):5 I '$T Q - .D ^DIC - .L -^OR(100.21,DA(1)) - I Y=-1 S OK=0 - K DA,DIC,DLAYGO - Q - ; -REMLIST(OK,VALUE,USER) ; from ORWTPP - ; removes a user from a team - N DA,DIK K DA - S DA=+$G(USER),DA(1)=+$G(VALUE),OK=1 - I '$D(^OR(100.21,DA(1),0)) Q - S DIK="^OR(100.21,"_DA(1)_",1," - D - .L +^OR(100.21,DA(1)):5 I '$T S OK=0 Q - .D ^DIK - .L -^OR(100.21,DA(1)) - K DA,DIK - Q - ; -GETCOMBO(VALUES,USER) ; from ORWTPP - ; get user's combo list definition - N CNT,IEN,NAME,NODE,NUM,SOURCE K VALUES - S USER=+$G(USER) - I '$D(^OR(100.24,USER,0)) Q - S CNT=0 - S NUM=0 F S NUM=$O(^OR(100.24,USER,.01,NUM)) Q:NUM<1 S NODE=$G(^(NUM,0)) D - .I '$L(NODE) Q - .S IEN=+NODE,SOURCE=$P(NODE,";",2),NAME="" - .D - ..I SOURCE="DIC(42," S SOURCE="WARD",NAME=$P($G(^DIC(42,IEN,0)),U) Q - ..I SOURCE="VA(200," S SOURCE="PROVIDER",NAME=$P($G(^VA(200,IEN,0)),U) Q - ..I SOURCE="DIC(45.7," S SOURCE="SPECIALTY",NAME=$P($G(^DIC(45.7,IEN,0)),U) Q - ..I SOURCE="OR(100.21," S SOURCE="LIST",NAME=$P($G(^OR(100.21,IEN,0)),U) Q - ..I SOURCE="SC(" S SOURCE="CLINIC",NAME=$P($G(^SC(IEN,0)),U) Q - ..I SOURCE="DIC(42," S SOURCE="WARD",NAME=$P($G(^DIC(42,IEN,0)),U) Q - .I '$L(NAME) Q - .S CNT=CNT+1 - .S VALUES(CNT)=SOURCE_U_NAME_U_IEN - Q - ; -SETCOMBO(OK,VALUES,USER) ; from ORWTPP - ; set user's combo list definition - N CNT,DA,DIK,IEN,NUM,NVALUES,SOURCE,SOURCENM K NVALUES - S USER=+$G(USER),OK=1 - I 'USER Q - S NUM=0 F S NUM=$O(VALUES(NUM)) Q:NUM<1 D - .S IEN=+VALUES(NUM),SOURCENM=$$UP^XLFSTR($P(VALUES(NUM),U,2)),SOURCE="" - .I 'IEN Q - .I SOURCENM="WARD" S SOURCE=";DIC(42," - .I SOURCENM="PROVIDER" S SOURCE=";VA(200," - .I SOURCENM="SPECIALTY" S SOURCE=";DIC(45.7," - .I SOURCENM="LIST" S SOURCE=";OR(100.21," - .I SOURCENM="CLINIC" S SOURCE=";SC(" - .I '$L(SOURCE) Q - .S NVALUES(NUM)=IEN_SOURCE - I '$D(^OR(100.24,USER,0)) D I '$D(^OR(100.24,USER,0)) Q - .L +^OR(100.24,0):5 I '$T S OK=0 Q - .S ^OR(100.24,USER,0)=USER - .S $P(^OR(100.24,0),U,4)=$P(^OR(100.24,0),U,4)+1,$P(^(0),U,3)=USER - .L -^OR(100.24,0) - S CNT=0,DA=USER,DIK="^OR(100.24," - L +^OR(100.24,USER,0):5 I '$T Q - K ^OR(100.24,USER,.01) - S NUM=0 F S NUM=$O(NVALUES(NUM)) Q:NUM<1 D - .S CNT=CNT+1 - .S ^OR(100.24,USER,.01,CNT,0)=NVALUES(NUM) - S ^OR(100.24,USER,.01,0)="^100.241V^"_CNT_U_CNT - D IX1^DIK - L -^OR(100.24,USER,0) - K NVALUES - Q +ORWTPT ; SLC/STAFF Personal Preference - Teams ;5/4/01 16:01 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85**;Oct 24, 2000 + ; +GETTEAM(USERS,TEAM) ; RPC + ; returns members of a team + N CNT,NAME,NUM,USER K USERS + S TEAM=+$G(TEAM),CNT=0 + S NUM=0 F S NUM=$O(^OR(100.21,TEAM,1,NUM)) Q:NUM<1 S USER=+$G(^(NUM,0)) D + .S NAME=$P($G(^VA(200,USER,0)),U) + .I '$L(NAME) Q + .S CNT=CNT+1 + .S USERS(CNT)=USER_U_NAME + Q + ; +TEAMS(TEAMS,USER) ; from ORWTPP + ; returns all teams a user is a member of (exculdes personal lists) + N CNT,NUM,ZERO K TEAMS + S USER=+$G(USER),CNT=0 + S NUM=0 F S NUM=$O(^OR(100.21,"C",USER,NUM)) Q:NUM<1 D + .S ZERO=$G(^OR(100.21,NUM,0)) + .I $P(ZERO,U,2)="P" Q + .S CNT=CNT+1 + .S TEAMS(CNT)=NUM_U_ZERO + Q + ; +PLISTS(TEAMS,USER) ; from ORWTPP + ; returns a user's personal lists + N CNT,NUM,ZERO K TEAMS + S USER=+$G(USER),CNT=0 + S NUM=0 F S NUM=$O(^OR(100.21,"C",USER,NUM)) Q:NUM<1 D + .S ZERO=$G(^OR(100.21,NUM,0)) + .I $P(ZERO,U,2)'="P" Q + .S CNT=CNT+1 + .S TEAMS(CNT)=NUM_U_ZERO + Q + ; +PLTEAMS(TEAMS,USER) ; from ORWTPP + ; returns all teams and personal lists for a user + N CNT,NUM,ZERO K TEAMS + S USER=+$G(USER),CNT=0 + S NUM=0 F S NUM=$O(^OR(100.21,"C",USER,NUM)) Q:NUM<1 D + .S ZERO=$G(^OR(100.21,NUM,0)) + .S CNT=CNT+1 + .S TEAMS(CNT)=NUM_U_ZERO + Q + ; +ATEAMS(TEAMS) ; RPC + ; all teams available to subscribe to + N CNT,NAME,NODE,NUM K TEAMS + S CNT=0 + S NUM=0 F S NUM=$O(^OR(100.21,NUM)) Q:NUM<1 S NODE=$G(^(NUM,0)) D + .I $P(NODE,U,6)'="Y" Q + .I $P(NODE,U,2)="P" Q + .S CNT=CNT+1 + .S TEAMS(CNT)=NUM_U_NODE ;$P(NODE,U) + Q + ; +ADDLIST(OK,VALUE,USER) ; from ORWTPP + ; adds a user to a team + N DA,DIC,DLAYGO,X,Y K DA,DIC,DLAYGO + S USER=+$G(USER) + S DA=USER,DA(1)=+$G(VALUE),OK=1 + I '$D(^OR(100.21,DA(1),0)) Q + S DIC(0)="LM" + S DLAYGO=100.212 + S X=$P($G(^VA(200,USER,0)),U) + S DIC="^OR(100.21,"_DA(1)_",1," + D + .L +^OR(100.21,DA(1)):5 I '$T Q + .D ^DIC + .L -^OR(100.21,DA(1)) + I Y=-1 S OK=0 + K DA,DIC,DLAYGO + Q + ; +REMLIST(OK,VALUE,USER) ; from ORWTPP + ; removes a user from a team + N DA,DIK K DA + S DA=+$G(USER),DA(1)=+$G(VALUE),OK=1 + I '$D(^OR(100.21,DA(1),0)) Q + S DIK="^OR(100.21,"_DA(1)_",1," + D + .L +^OR(100.21,DA(1)):5 I '$T S OK=0 Q + .D ^DIK + .L -^OR(100.21,DA(1)) + K DA,DIK + Q + ; +GETCOMBO(VALUES,USER) ; from ORWTPP + ; get user's combo list definition + N CNT,IEN,NAME,NODE,NUM,SOURCE K VALUES + S USER=+$G(USER) + I '$D(^OR(100.24,USER,0)) Q + S CNT=0 + S NUM=0 F S NUM=$O(^OR(100.24,USER,.01,NUM)) Q:NUM<1 S NODE=$G(^(NUM,0)) D + .I '$L(NODE) Q + .S IEN=+NODE,SOURCE=$P(NODE,";",2),NAME="" + .D + ..I SOURCE="DIC(42," S SOURCE="WARD",NAME=$P($G(^DIC(42,IEN,0)),U) Q + ..I SOURCE="VA(200," S SOURCE="PROVIDER",NAME=$P($G(^VA(200,IEN,0)),U) Q + ..I SOURCE="DIC(45.7," S SOURCE="SPECIALTY",NAME=$P($G(^DIC(45.7,IEN,0)),U) Q + ..I SOURCE="OR(100.21," S SOURCE="LIST",NAME=$P($G(^OR(100.21,IEN,0)),U) Q + ..I SOURCE="SC(" S SOURCE="CLINIC",NAME=$P($G(^SC(IEN,0)),U) Q + ..I SOURCE="DIC(42," S SOURCE="WARD",NAME=$P($G(^DIC(42,IEN,0)),U) Q + .I '$L(NAME) Q + .S CNT=CNT+1 + .S VALUES(CNT)=SOURCE_U_NAME_U_IEN + Q + ; +SETCOMBO(OK,VALUES,USER) ; from ORWTPP + ; set user's combo list definition + N CNT,DA,DIK,IEN,NUM,NVALUES,SOURCE,SOURCENM K NVALUES + S USER=+$G(USER),OK=1 + I 'USER Q + S NUM=0 F S NUM=$O(VALUES(NUM)) Q:NUM<1 D + .S IEN=+VALUES(NUM),SOURCENM=$$UP^XLFSTR($P(VALUES(NUM),U,2)),SOURCE="" + .I 'IEN Q + .I SOURCENM="WARD" S SOURCE=";DIC(42," + .I SOURCENM="PROVIDER" S SOURCE=";VA(200," + .I SOURCENM="SPECIALTY" S SOURCE=";DIC(45.7," + .I SOURCENM="LIST" S SOURCE=";OR(100.21," + .I SOURCENM="CLINIC" S SOURCE=";SC(" + .I '$L(SOURCE) Q + .S NVALUES(NUM)=IEN_SOURCE + I '$D(^OR(100.24,USER,0)) D I '$D(^OR(100.24,USER,0)) Q + .L +^OR(100.24,0):5 I '$T S OK=0 Q + .S ^OR(100.24,USER,0)=USER + .S $P(^OR(100.24,0),U,4)=$P(^OR(100.24,0),U,4)+1,$P(^(0),U,3)=USER + .L -^OR(100.24,0) + S CNT=0,DA=USER,DIK="^OR(100.24," + L +^OR(100.24,USER,0):5 I '$T Q + K ^OR(100.24,USER,.01) + S NUM=0 F S NUM=$O(NVALUES(NUM)) Q:NUM<1 D + .S CNT=CNT+1 + .S ^OR(100.24,USER,.01,CNT,0)=NVALUES(NUM) + S ^OR(100.24,USER,.01,0)="^100.241V^"_CNT_U_CNT + D IX1^DIK + L -^OR(100.24,USER,0) + K NVALUES + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWTPUA.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWTPUA.m index d0400b30..58de566f 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWTPUA.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWTPUA.m @@ -1,28 +1,27 @@ -ORWTPUA ; SLC/STAFF Personal Preference - Utility Alerts ; 4/20/07 10:01am - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,243**;Oct 24, 2000;Build 242 - ; -START(USER) ; $$(user) -> user's surrogate start date/time - Q $P($G(^XTV(8992,+$G(USER),0)),U,3) - ; -STOP(USER) ; $$(user) -> user's surrogate stop date/time - Q $P($G(^XTV(8992,+$G(USER),0)),U,4) - ; -CHKSURR(USER,SURR) ; $$(user,surrogate) -> 1 if ok else 0^reason for reject - N OK,START - S USER=+$G(USER),SURR=+$G(SURR) - I USER=SURR Q "0^You cannot specify yourself as your own surrogate!" - S START=$$GET1^DIQ(8992,(SURR_","),.02,"I") - I START<.5 Q 1 - I START=USER Q "0^You are designated as the surrogate for this user - can't do it!" - S OK=1 F S START=$$GET1^DIQ(8992,(START_","),.02,"I") Q:START'>0 I START=USER S OK=0 Q - I 'OK Q "0^This forms a circle which leads back to you - can't do it!" - Q 1 - ; -GETSURR(USER) ; $$(user ien) -> surrogate ien - Q $$CURRSURO^XQALSURO(+$G(USER)) - ; -SAVESURR(USER,SURR,START,STOP) ; save user's surrogate info - N RET - D REMVSURO^XQALSURO(USER) - S RET=$$SETSURO1^XQALSURO(USER,SURR,START,STOP) - Q RET +ORWTPUA ; SLC/STAFF Personal Preference - Utility Alerts ;5/22/00 09:58 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85**;Oct 24, 2000 + ; +START(USER) ; $$(user) -> user's surrogate start date/time + Q $P($G(^XTV(8992,+$G(USER),0)),U,3) + ; +STOP(USER) ; $$(user) -> user's surrogate stop date/time + Q $P($G(^XTV(8992,+$G(USER),0)),U,4) + ; +CHKSURR(USER,SURR) ; $$(user,surrogate) -> 1 if ok else 0^reason for reject + N OK,START + S USER=+$G(USER),SURR=+$G(SURR) + I USER=SURR Q "0^You cannot specify yourself as your own surrogate!" + S START=$$GET1^DIQ(8992,(SURR_","),.02,"I") + I START<.5 Q 1 + I START=USER Q "0^You are designated as the surrogate for this user - can't do it!" + S OK=1 F S START=$$GET1^DIQ(8992,(START_","),.02,"I") Q:START'>0 I START=USER S OK=0 Q + I 'OK Q "0^This forms a circle which leads back to you - can't do it!" + Q 1 + ; +GETSURR(USER) ; $$(user ien) -> surrogate ien + Q $$CURRSURO^XQALSURO(+$G(USER)) + ; +SAVESURR(USER,SURR,START,STOP) ; save user's surrogate info + D REMVSURO^XQALSURO(USER) + D SETSURO^XQALSURO(USER,SURR,START,STOP) + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWU.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWU.m index 8da89734..dff7136f 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWU.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWU.m @@ -1,220 +1,216 @@ -ORWU ; SLC/KCM - General Utilites for Windows Calls; 2/28/01 [1/15/04 11:43am] - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,132,148,149,187,195,215,243**;Dec 17, 1997;Build 242 - ; -DT(Y,X,%DT) ; Internal Fileman Date/Time - ; change the '00:00' that could be passed so Fileman doesn't reject - I $L($P(X,"@",2)),("00000000"[$TR($P(X,"@",2),":","")) S $P(X,"@",2)="00:00:01" - S %DT=$G(%DT,"TS") D ^%DT K %DT - Q -VALDT(Y,X,%DT) ; Validate date/time - S:'$D(%DT) %DT="TX" D ^%DT - Q -USERINFO(REC) ; Relevant info for current user - ; return DUZ^NAME^USRCLS^CANSIGN^ISPROVIDER^ORDERROLE^NOORDER^DTIME^ - ; COUNTDOWN^ENABLEVERIFY^NOTIFYAPPS^MSGHANG^DOMAIN^SERVICE^ - ; AUTOSAVE^INITTAB^LASTTAB^WEBACCESS^ALLOWHOLD^ISRPL^RPLLIST^ - ; CORTABS^RPTTAB^STANUM^GECSTATUS^PRODACCT - N X,ORRPL,ORRPL1,ORRPL2,ORTAB,CORTABS,RPTTAB,ORDT,OREFF,OREXP,ORDATEOK - S REC=DUZ_U_$P(^VA(200,DUZ,0),U) - S $P(REC,U,3)=$S($D(^XUSEC("ORES",DUZ)):3,$D(^XUSEC("ORELSE",DUZ)):2,$D(^XUSEC("OREMAS",DUZ)):1,1:0) - S $P(REC,U,4)=$D(^XUSEC("ORES",DUZ))&$D(^XUSEC("PROVIDER",DUZ)) - S $P(REC,U,5)=$D(^XUSEC("PROVIDER",DUZ)) - S $P(REC,U,6)=$$ORDROLE - S $P(REC,U,7)=$$GET^XPAR("USR^SYS^PKG","ORWOR DISABLE ORDERING",1,"I") - S $P(REC,U,8)=$$GET^XPAR("USR^SYS","ORWOR TIMEOUT CHART",1,"I") - I '$P(REC,U,8),$G(DTIME) S $P(REC,U,8)=DTIME - S $P(REC,U,9)=$$GET^XPAR("USR^SYS^PKG","ORWOR TIMEOUT COUNTDOWN",1,"I") - S X=$$GET^XPAR("USR^SYS^PKG","ORWOR ENABLE VERIFY",1,"I") - S $P(REC,U,10)=$S(X=1:1,X=2:0,1:'$P(REC,U,7)) - S $P(REC,U,11)=$$GET^XPAR("USR^SYS^PKG","ORWOR BROADCAST MESSAGES",1,"I") - S $P(REC,U,12)=$$GET^XPAR("USR^SYS^PKG","ORWOR AUTO CLOSE PT MSG",1,"I") - S $P(REC,U,13)=$$KSP^XUPARAM("WHERE") ; domain - S $P(REC,U,14)=+$G(^VA(200,DUZ,5)) ; service/section - S $P(REC,U,15)=$$GET^XPAR("USR^SYS^PKG","ORWOR AUTOSAVE NOTE",1,"I") - S $P(REC,U,16)=$$GET^XPAR("USR^DIV^SYS^PKG","ORCH INITIAL TAB",1,"I") - S $P(REC,U,17)=$$GET^XPAR("USR^DIV^SYS^PKG","ORCH USE LAST TAB",1,"I") - S $P(REC,U,18)=$$GET^XPAR("USR^DIV^SYS^PKG","ORWOR DISABLE WEB ACCESS",1,"I") - S $P(REC,U,19)=$$GET^XPAR("SYS^PKG","ORWOR DISABLE HOLD ORDERS",1,"I") - ; 2 pieces added by PKS on 11/5/2001 for "Reports Only:" - ; IA# 10060 allows read access to ^VA(200 file. - S ORRPL=$G(^VA(200,DUZ,101)) ; RPL node. - S ORRPL1=$P(ORRPL,U) - S $P(REC,U,20)=ORRPL1 ; ISRPL piece. - S ORRPL2=$P(ORRPL,U,2) - S $P(REC,U,21)=ORRPL2 ; RPLLIST piece. - ; - ; Additional pieces for CPRS tabs access: - ; IA# 10060 allows read access to ^VA(200.01013 multiple. - S ORDT=DT ; Today. - S (CORTABS,RPTTAB)=0 - S ORRPL=0 - F S ORRPL=$O(^VA(200,DUZ,"ORD",ORRPL)) Q:ORRPL<1 D - .S ORTAB=$G(^VA(200,DUZ,"ORD",ORRPL,0)) - .I ORTAB="" Q - .S OREFF=$P(ORTAB,U,2) - .S OREXP=$P(ORTAB,U,3) - .S ORTAB=$P(ORTAB,U) - .I ORTAB="" Q - .S ORTAB=$G(^ORD(101.13,ORTAB,0)) - .I ORTAB="" Q - .S ORTAB=$P(ORTAB,U) - .I ORTAB="" Q - .S ORTAB=$$UP^XLFSTR(ORTAB) - .S ORDATEOK=1 ; Default. - .I ((OREFF="")!(OREFF>ORDT)) S ORDATEOK=0 ; Eff. date NG. - .I ORDATEOK D - ..I OREXP="" Q ; No exp. date. - ..I (OREXP0 S VAL=0 - E S VAL=1 - Q -NPHASKEY(VAL,NP,KEY) ; returns TRUE if the person has the security key - S VAL=''$D(^XUSEC(KEY,NP)) - Q -ORDROLE() ; returns the role a person takes in ordering - ; VAL: 0=nokey, 1=clerk, 2=nurse, 3=physician, 4=student, 5=bad keys - ;I '$G(ORWCLVER) Q 0 ; version of client is to old for ordering - I ($D(^XUSEC("OREMAS",DUZ))+$D(^XUSEC("ORELSE",DUZ))+$D(^XUSEC("ORES",DUZ)))>1 Q 5 - I $D(^XUSEC("OREMAS",DUZ)) Q 1 ; clerk - I $D(^XUSEC("ORELSE",DUZ)) Q 2 ; nurse - I $D(^XUSEC("ORES",DUZ)),$D(^XUSEC("PROVIDER",DUZ)) Q 3 ; doctor - I $D(^XUSEC("PROVIDER",DUZ)) Q 4 ; student - Q 0 -VALIDSIG(ESOK,X) ; returns TRUE if valid electronic signature - S X=$$DECRYP^XUSRB1(X),ESOK=0 ; network encrypted - D HASH^XUSHSHP - I X=$P($G(^VA(200,+DUZ,20)),U,4) S ESOK=1 - Q -TOOLMENU(ORLST) ; returns a list of items for the Tools menu - N ANENT - S ANENT="ALL^"_$S($G(^VA(200,DUZ,5)):"^SRV.`"_+$G(^(5)),1:"") - D GETLST^XPAR(.ORLST,ANENT,"ORWT TOOLS MENU","N") - Q -ACTLOC(LOC) ; Function: returns TRUE if active hospital location - ; IA# 10040. - N D0,X I +$G(^SC(LOC,"OOS")) Q 0 ; screen out OOS entry - S D0=+$G(^SC(LOC,42)) I D0 D WIN^DGPMDDCF Q 'X ; chk out of svc wards - S X=$G(^SC(LOC,"I")) I +X=0 Q 1 ; no inactivate date - I DT>$P(X,U)&($P(X,U,2)=""!(DT<$P(X,U,2))) Q 0 ; chk reactivate date - Q 1 ; must still be active - ; -CLINLOC(Y,FROM,DIR) ; Return a set of clinics from HOSPITAL LOCATION - ; .Y=returned list, FROM=text to $O from, DIR=$O direction, - N I,IEN,CNT S I=0,CNT=44 - F Q:I'DT) Q ;Out of Service - .. I XTIME]"" S ORA=$P(XTIME,"^"),ORPX=$P($H,",",2),ORPCNT=ORPX\60#60+(ORPX\3600*100),ORPX=$P(ORA,"-",2) I ORPX'ORPX&(ORPCNT'ORPX))) Q ;Prohibited Times - .. S POP=0 - .. I X95]"" S ORPX=$G(DUZ(0)) I ORPX'="@" S POP=1 F ORA=1:1:$L(ORPX) I X95[$E(ORPX,ORA) S POP=0 Q - .. Q:POP ;Security check - .. S SHOW=$P(X0,U) I SHOW'=FROM S SHOW=FROM_" <"_SHOW_">" - .. S I=I+1,Y(I)=IEN_";"_$P(X0,U)_U_SHOW_U_$P(X1,U)_U_$P(X91,U)_U_$P(X91,U,3) - Q -URGENCY(Y) ; -- retrieve set values from dd for discharge summary urgency - N ORDD,I,X - D FIELD^DID(8925,.09,"","POINTER","ORDD") - F I=1:1 S X=$P(ORDD("POINTER"),";",I) Q:X="" S Y(I)=$TR(X,":","^") - Q -PATCH(VAL,X) ; Return 1 if patch X is installed - S VAL=$$PATCH^XPDUTL(X) - Q -VERSION(VAL,X) ;Return version of package or namespace - S VAL=$$VERSION^XPDUTL(X) - Q -VERSRV(VAL,X,CLVER) ; Return server version of option name - S ORWCLVER=$G(CLVER) ; leave in partition for session - N BADVAL,ORLST - D FIND^DIC(19,"",1,"X",X,1,,,,"ORLST") - I 'ORLST("DILIST",0) S VAL="0.0.0.0" Q - S VAL=ORLST("DILIST","ID",1,1) - S VAL=$P(VAL,"version ",2) - S BADVAL=0 - I $P(VAL,".",1)="" S BADVAL=1 - I $P(VAL,".",2)="" S BADVAL=1 - I $P(VAL,".",3)="" S BADVAL=1 - I $P(VAL,".",4)="" S BADVAL=1 - I ((BADVAL)!('VAL)!(VAL="")) S VAL="0.0.0.0" - Q +ORWU ; SLC/KCM - General Utilites for Windows Calls; 2/28/01 [1/15/04 11:43am] + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,132,148,149,187,195,215**;Dec 17, 1997 + ; +DT(Y,X,%DT) ; Internal Fileman Date/Time + ; change the '00:00' that could be passed so Fileman doesn't reject + I $L($P(X,"@",2)),("00000000"[$TR($P(X,"@",2),":","")) S $P(X,"@",2)="00:00:01" + S %DT=$G(%DT,"TS") D ^%DT K %DT + Q +VALDT(Y,X,%DT) ; Validate date/time + S:'$D(%DT) %DT="TX" D ^%DT + Q +USERINFO(REC) ; Relevant info for current user + ; return DUZ^NAME^USRCLS^CANSIGN^ISPROVIDER^ORDERROLE^NOORDER^DTIME^ + ; COUNTDOWN^ENABLEVERIFY^NOTIFYAPPS^MSGHANG^DOMAIN^SERVICE^ + ; AUTOSAVE^INITTAB^LASTTAB^WEBACCESS^ALLOWHOLD^ISRPL^RPLLIST^ + ; CORTABS^RPTTAB^STANUM^GECSTATUS^PRODACCT + N X,ORRPL,ORRPL1,ORRPL2,ORTAB,CORTABS,RPTTAB,ORDT,OREFF,OREXP,ORDATEOK + S REC=DUZ_U_$P(^VA(200,DUZ,0),U) + S $P(REC,U,3)=$S($D(^XUSEC("ORES",DUZ)):3,$D(^XUSEC("ORELSE",DUZ)):2,$D(^XUSEC("OREMAS",DUZ)):1,1:0) + S $P(REC,U,4)=$D(^XUSEC("ORES",DUZ))&$D(^XUSEC("PROVIDER",DUZ)) + S $P(REC,U,5)=$D(^XUSEC("PROVIDER",DUZ)) + S $P(REC,U,6)=$$ORDROLE + S $P(REC,U,7)=$$GET^XPAR("USR^SYS^PKG","ORWOR DISABLE ORDERING",1,"I") + S $P(REC,U,8)=$$GET^XPAR("USR^SYS","ORWOR TIMEOUT CHART",1,"I") + I '$P(REC,U,8),$G(DTIME) S $P(REC,U,8)=DTIME + S $P(REC,U,9)=$$GET^XPAR("USR^SYS^PKG","ORWOR TIMEOUT COUNTDOWN",1,"I") + S X=$$GET^XPAR("USR^SYS^PKG","ORWOR ENABLE VERIFY",1,"I") + S $P(REC,U,10)=$S(X=1:1,X=2:0,1:'$P(REC,U,7)) + S $P(REC,U,11)=$$GET^XPAR("USR^SYS^PKG","ORWOR BROADCAST MESSAGES",1,"I") + S $P(REC,U,12)=$$GET^XPAR("USR^SYS^PKG","ORWOR AUTO CLOSE PT MSG",1,"I") + S $P(REC,U,13)=$$KSP^XUPARAM("WHERE") ; domain + S $P(REC,U,14)=+$G(^VA(200,DUZ,5)) ; service/section + S $P(REC,U,15)=$$GET^XPAR("USR^SYS^PKG","ORWOR AUTOSAVE NOTE",1,"I") + S $P(REC,U,16)=$$GET^XPAR("USR^DIV^SYS^PKG","ORCH INITIAL TAB",1,"I") + S $P(REC,U,17)=$$GET^XPAR("USR^DIV^SYS^PKG","ORCH USE LAST TAB",1,"I") + S $P(REC,U,18)=$$GET^XPAR("USR^DIV^SYS^PKG","ORWOR DISABLE WEB ACCESS",1,"I") + S $P(REC,U,19)=$$GET^XPAR("SYS^PKG","ORWOR DISABLE HOLD ORDERS",1,"I") + ; 2 pieces added by PKS on 11/5/2001 for "Reports Only:" + ; IA# 10060 allows read access to ^VA(200 file. + S ORRPL=$G(^VA(200,DUZ,101)) ; RPL node. + S ORRPL1=$P(ORRPL,U) + S $P(REC,U,20)=ORRPL1 ; ISRPL piece. + S ORRPL2=$P(ORRPL,U,2) + S $P(REC,U,21)=ORRPL2 ; RPLLIST piece. + ; + ; Additional pieces for CPRS tabs access: + ; IA# 10060 allows read access to ^VA(200.01013 multiple. + S ORDT=DT ; Today. + S (CORTABS,RPTTAB)=0 + S ORRPL=0 + F S ORRPL=$O(^VA(200,DUZ,"ORD",ORRPL)) Q:ORRPL<1 D + .S ORTAB=$G(^VA(200,DUZ,"ORD",ORRPL,0)) + .I ORTAB="" Q + .S OREFF=$P(ORTAB,U,2) + .S OREXP=$P(ORTAB,U,3) + .S ORTAB=$P(ORTAB,U) + .I ORTAB="" Q + .S ORTAB=$G(^ORD(101.13,ORTAB,0)) + .I ORTAB="" Q + .S ORTAB=$P(ORTAB,U) + .I ORTAB="" Q + .S ORTAB=$$UP^XLFSTR(ORTAB) + .S ORDATEOK=1 ; Default. + .I ((OREFF="")!(OREFF>ORDT)) S ORDATEOK=0 ; Eff. date NG. + .I ORDATEOK D + ..I OREXP="" Q ; No exp. date. + ..I (OREXP0 S VAL=0 + E S VAL=1 + Q +NPHASKEY(VAL,NP,KEY) ; returns TRUE if the person has the security key + S VAL=''$D(^XUSEC(KEY,NP)) + Q +ORDROLE() ; returns the role a person takes in ordering + ; VAL: 0=nokey, 1=clerk, 2=nurse, 3=physician, 4=student, 5=bad keys + ;I '$G(ORWCLVER) Q 0 ; version of client is to old for ordering + I ($D(^XUSEC("OREMAS",DUZ))+$D(^XUSEC("ORELSE",DUZ))+$D(^XUSEC("ORES",DUZ)))>1 Q 5 + I $D(^XUSEC("OREMAS",DUZ)) Q 1 ; clerk + I $D(^XUSEC("ORELSE",DUZ)) Q 2 ; nurse + I $D(^XUSEC("ORES",DUZ)),$D(^XUSEC("PROVIDER",DUZ)) Q 3 ; doctor + I $D(^XUSEC("PROVIDER",DUZ)) Q 4 ; student + Q 0 +VALIDSIG(ESOK,X) ; returns TRUE if valid electronic signature + S X=$$DECRYP^XUSRB1(X),ESOK=0 ; network encrypted + D HASH^XUSHSHP + I X=$P($G(^VA(200,+DUZ,20)),U,4) S ESOK=1 + Q +TOOLMENU(ORLST) ; returns a list of items for the Tools menu + N ANENT + S ANENT="ALL^"_$S($G(^VA(200,DUZ,5)):"^SRV.`"_+$G(^(5)),1:"") + D GETLST^XPAR(.ORLST,ANENT,"ORWT TOOLS MENU","N") + Q +ACTLOC(LOC) ; Function: returns TRUE if active hospital location + ; IA# 10040. + N D0,X I +$G(^SC(LOC,"OOS")) Q 0 ; screen out OOS entry + S D0=+$G(^SC(LOC,42)) I D0 D WIN^DGPMDDCF Q 'X ; chk out of svc wards + S X=$G(^SC(LOC,"I")) I +X=0 Q 1 ; no inactivate date + I DT>$P(X,U)&($P(X,U,2)=""!(DT<$P(X,U,2))) Q 0 ; chk reactivate date + Q 1 ; must still be active + ; +CLINLOC(Y,FROM,DIR) ; Return a set of clinics from HOSPITAL LOCATION + ; .Y=returned list, FROM=text to $O from, DIR=$O direction, + N I,IEN,CNT S I=0,CNT=44 + F Q:I'DT) Q ;Out of Service + .. I XTIME]"" S ORA=$P(XTIME,"^"),ORPX=$P($H,",",2),ORPCNT=ORPX\60#60+(ORPX\3600*100),ORPX=$P(ORA,"-",2) I ORPX'ORPX&(ORPCNT'ORPX))) Q ;Prohibited Times + .. S POP=0 + .. I X95]"" S ORPX=$G(DUZ(0)) I ORPX'="@" S POP=1 F ORA=1:1:$L(ORPX) I X95[$E(ORPX,ORA) S POP=0 Q + .. Q:POP ;Security check + .. S SHOW=$P(X0,U) I SHOW'=FROM S SHOW=FROM_" <"_SHOW_">" + .. S I=I+1,Y(I)=IEN_";"_$P(X0,U)_U_SHOW_U_$P(X1,U)_U_$P(X91,U)_U_$P(X91,U,3) + Q +URGENCY(Y) ; -- retrieve set values from dd for discharge summary urgency + N ORDD,I,X + D FIELD^DID(8925,.09,"","POINTER","ORDD") + F I=1:1 S X=$P(ORDD("POINTER"),";",I) Q:X="" S Y(I)=$TR(X,":","^") + Q +PATCH(VAL,X) ; Return 1 if patch X is installed + S VAL=$$PATCH^XPDUTL(X) + Q +VERSION(VAL,X) ;Return version of package or namespace + S VAL=$$VERSION^XPDUTL(X) + Q +VERSRV(VAL,X,CLVER) ; Return server version of option name + S ORWCLVER=$G(CLVER) ; leave in partition for session + N BADVAL,ORLST + D FIND^DIC(19,"",1,"X",X,1,,,,"ORLST") + I 'ORLST("DILIST",0) S VAL="0.0.0.0" Q + S VAL=ORLST("DILIST","ID",1,1) + S VAL=$P(VAL,"version ",2) + S BADVAL=0 + I $P(VAL,".",1)="" S BADVAL=1 + I $P(VAL,".",2)="" S BADVAL=1 + I $P(VAL,".",3)="" S BADVAL=1 + I $P(VAL,".",4)="" S BADVAL=1 + I ((BADVAL)!('VAL)!(VAL="")) S VAL="0.0.0.0" + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORY269.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORY269.m index d3cd1289..d74bd18e 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORY269.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORY269.m @@ -1,16 +1,16 @@ -ORY269 ;WV/CJS - POST INIT FOR OR*3*269 ;1/24/07 23:34 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**269**;Dec 17, 1997;Build 29 - ; Register Lookup RPCs - N MENU,RPC - S MENU="OR CPRS GUI CHART" - F RPC="ORWPT ENHANCED PATLOOKUP","ORWPT OTHER-RADIOBUTTONS" D INSERT(MENU,RPC) - Q -INSERT(OPTION,RPC) ; Call FM Updater with each RPC - ; Input -- OPTION Option file (#19) Name field (#.01) - ; RPC RPC sub-file (#19.05) RPC field (#.01) - ; Output -- None - N FDA,FDAIEN,ERR,DIERR - S FDA(19,"?1,",.01)=OPTION - S FDA(19.05,"?+2,?1,",.01)=RPC - D UPDATE^DIE("E","FDA","FDAIEN","ERR") - Q +ORY269 ;WV/CJS - POST INIT FOR OR*3*269 ;1/24/07 23:34 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**269**;Dec 17, 1997;Build 28 + ; Register Lookup RPCs + N MENU,RPC + S MENU="OR CPRS GUI CHART" + F RPC="ORWPT ENHANCED PATLOOKUP","ORWPT OTHER-RADIOBUTTONS" D INSERT(MENU,RPC) + Q +INSERT(OPTION,RPC) ; Call FM Updater with each RPC + ; Input -- OPTION Option file (#19) Name field (#.01) + ; RPC RPC sub-file (#19.05) RPC field (#.01) + ; Output -- None + N FDA,FDAIEN,ERR,DIERR + S FDA(19,"?1,",.01)=OPTION + S FDA(19.05,"?+2,?1,",.01)=RPC + D UPDATE^DIE("E","FDA","FDAIEN","ERR") + Q diff --git a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORYDLG.m b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORYDLG.m index 46d8d462..87ece5a1 100644 --- a/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORYDLG.m +++ b/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORYDLG.m @@ -1,98 +1,68 @@ -ORYDLG ;SLC/MKB -- Postinit bulletin for order dialogs ;7/28/04 08:18 - ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141,165,216,243**;Dec 17, 1997;Build 242 - ; -EN(PATCH,ORDLG,USERS) ; -- look for local copies of ORDLG(NAME) by package, - ; send list in bulletin to DUZ, POSTMASTER, USERS(DUZ) when done - ; - Q:$O(ORDLG(""))="" ;none - N ORZ,ORI,X,NM,I,OR0,PKG,DG,ORPKG,ORNATL,DLG,CNT,LR,PS - S ORZ(1)="The following nationally exported order dialogs have been modified by" - S X="this patch: ",ORI=1,NM="" F S NM=$O(ORDLG(NM)) Q:NM="" D - . S ORI=ORI+1,ORZ(ORI)=X_NM,X=" " - . S I=+$O(^ORD(101.41,"AB",NM,0)),OR0=$G(^ORD(101.41,I,0)) - . S PKG=+$P(OR0,U,7),DG=+$P(OR0,U,5) S:PKG ORPKG(PKG,DG)="" - . S:$P(NM," ")="LR" LR=1 S:"^PS^PSJ^PSO^PSH^"[(U_$P(NM," ")_U) PS=1 - D:$G(LR) LR D:$G(PS) PS ;reset FORMAT codes in changed dialogs - S I=0 F I=1:1 S X=$T(NATL+I) Q:X["ZZZZZ" S ORNATL($P(X,";",3))="" - S ORI=ORI+1,ORZ(ORI)="Please review and compare the following locally created order dialogs" - S ORI=ORI+1,ORZ(ORI)="that may be copies, for any necessary changes:",CNT=0 - S PKG=0 F S PKG=$O(ORPKG(PKG)) Q:PKG<1 S DLG=0 D - . F S DLG=+$O(^ORD(101.41,"APKG",PKG,DLG)) Q:DLG<1 D - .. S OR0=$G(^ORD(101.41,DLG,0)) Q:$P(OR0,U,4)'="D" - .. Q:'$D(ORPKG(PKG,+$P(OR0,U,5))) ;included DispGrp - .. Q:$D(ORNATL($P(OR0,U))) S CNT=CNT+1 - .. S ORI=ORI+1,ORZ(ORI)=$J(DLG,7)_" "_$P(OR0,U) -EN1 I CNT>0 D ;local copies found -> send bulletin - . N XMDUZ,XMY,I,XMSUB,XMTEXT,DIFROM - . S XMDUZ="PATCH OR*3*"_$G(PATCH)_" POSTINIT",XMY(.5)="" - . S:$G(DUZ) XMY(DUZ)="" S I=0 F S I=$O(USERS(I)) Q:I<1 S XMY(I)="" - . S XMSUB=XMDUZ_" COMPLETED",XMTEXT="ORZ(" D ^XMD - . D BMES^XPDUTL("Some national order dialogs have been modified in this patch;") - . D MES^XPDUTL("a bulletin has been sent to the installer listing local copies that") - . D MES^XPDUTL("may need to be reviewed and updated.") - Q - ; -NATL ;;Nationally exported dialogs - ;;FHW1 - ;;FHW2 - ;;FHW3 - ;;FHW7 - ;;FHW8 - ;;FHW OP MEAL - ;;FHW SPECIAL MEAL - ;;GMRAOR ALLERGY ENTER/EDIT - ;;GMRCOR CONSULT - ;;GMRCOR REQUEST - ;;GMRVOR - ;;LR OTHER LAB TESTS - ;;OR GWCOND CONDITION - ;;OR GWDIAG DIAGNOSIS - ;;OR GWINST DNR - ;;OR GXACTV OTHER ACTIVITY ORDER - ;;OR GXMISC GENERAL - ;;OR GXMOVE ADMIT PATIENT - ;;OR GXMOVE DISCHARGE - ;;OR GXMOVE EVENT - ;;OR GXMOVE TRANSFER - ;;OR GXMOVE TREATING SPECIALTY - ;;OR GXPARM CALL HO ON - ;;OR GXSKIN DRESSING CHANGE - ;;OR GXTEXT TEXT ONLY ORDER - ;;OR GXTEXT WORD PROCESSING ORDER - ;;ORWD GENERIC ACTIVITY - ;;ORWD GENERIC DIET - ;;ORWD GENERIC NURSING - ;;ORWD GENERIC VITALS - ;;PS MEDS - ;;PSH OERR - ;;PSJ OR PAT OE - ;;PSJI OR PAT FLUID OE - ;;PSO OERR - ;;PSO SUPPLY - ;;RA OERR EXAM - ;;ZZZZZ - ; -PS ; -- reset FORMAT values in PS dialogs - N DRUG,OI,STR,DLGNM,DLG,PRMT,DA - S DRUG=$$PTR("OR GTX DRUG NAME") - S OI=$$PTR("OR GTX ORDERABLE ITEM"),STR=$$PTR("OR GTX STRENGTH") - F DLGNM="PS MEDS","PSJ OR PAT OE","PSO OERR","PSO SUPPLY","PSH OERR" D - . S DLG=$$PTR(DLGNM) - . F PRMT=OI,STR D - .. S DA=+$O(^ORD(101.41,DLG,10,"D",PRMT,0)) - .. S:DA $P(^ORD(101.41,DLG,10,DA,2),U,2)=("@"_DRUG) - Q - ; IV dialog - S DLG=$$PTR("PSJI OR PAT FLUID OE"),PRMT=$$PTR("OR GTX INFUSION RATE") - S DA=+$O(^ORD(101.41,DLG,10,"D",PRMT,0)) - I DA S $P(^ORD(101.41,DLG,10,DA,2),U,2)=("@"_$$PTR("OR GTX SCHEDULE")) - Q - ; -LR ; -- reset FORMAT value in LR dialog - N DLG,PRMT,DA - S DLG=$$PTR("LR OTHER LAB TESTS"),PRMT=$$PTR("OR GTX SPECIMEN") - S DA=+$O(^ORD(101.41,DLG,10,"D",PRMT,0)) - I DA S $P(^ORD(101.41,DLG,10,DA,2),U,2)=("="_$$PTR("OR GTX COLLECTION SAMPLE")) - Q - ; -PTR(X) Q +$O(^ORD(101.41,"B",X,0)) +ORYDLG ;SLC/MKB -- Postinit bulletin for order dialogs ;7/28/04 08:18 + ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141,165,216**;Dec 17, 1997 + ; +EN(PATCH,ORDLG,USERS) ; -- look for local copies of ORDLG(NAME) by package, + ; send list in bulletin to DUZ, POSTMASTER, USERS(DUZ) when done + ; + Q:$O(ORDLG(""))="" ;none + N ORZ,ORI,X,NM,I,OR0,PKG,DG,ORPKG,ORNATL,DLG,CNT + S ORZ(1)="The following nationally exported order dialogs have been modified by" + S X="this patch: ",ORI=1,NM="" F S NM=$O(ORDLG(NM)) Q:NM="" D + . S ORI=ORI+1,ORZ(ORI)=X_NM,X=" " + . S I=+$O(^ORD(101.41,"AB",NM,0)),OR0=$G(^ORD(101.41,I,0)) + . S PKG=+$P(OR0,U,7),DG=+$P(OR0,U,5) S:PKG ORPKG(PKG,DG)="" + S I=0 F I=1:1 S X=$T(NATL+I) Q:X["ZZZZZ" S ORNATL($P(X,";",3))="" + S ORI=ORI+1,ORZ(ORI)="Please review and compare the following locally created order dialogs" + S ORI=ORI+1,ORZ(ORI)="that may be copies, for any necessary changes:",CNT=0 + S PKG=0 F S PKG=$O(ORPKG(PKG)) Q:PKG<1 S DLG=0 D + . F S DLG=+$O(^ORD(101.41,"APKG",PKG,DLG)) Q:DLG<1 D + .. S OR0=$G(^ORD(101.41,DLG,0)) Q:$P(OR0,U,4)'="D" + .. Q:'$D(ORPKG(PKG,+$P(OR0,U,5))) ;included DispGrp + .. Q:$D(ORNATL($P(OR0,U))) S CNT=CNT+1 + .. S ORI=ORI+1,ORZ(ORI)=$J(DLG,7)_" "_$P(OR0,U) +EN1 I CNT>0 D ;local copies found -> send bulletin + . N XMDUZ,XMY,I,XMSUB,XMTEXT,DIFROM + . S XMDUZ="PATCH OR*3*"_$G(PATCH)_" POSTINIT",XMY(.5)="" + . S:$G(DUZ) XMY(DUZ)="" S I=0 F S I=$O(USERS(I)) Q:I<1 S XMY(I)="" + . S XMSUB=XMDUZ_" COMPLETED",XMTEXT="ORZ(" D ^XMD + . D BMES^XPDUTL("Some national order dialogs have been modified in this patch;") + . D MES^XPDUTL("a bulletin has been sent to the installer listing local copies that") + . D MES^XPDUTL("may need to be reviewed and updated.") + Q + ; +NATL ;;Nationally exported dialogs + ;;FHW1 + ;;FHW2 + ;;FHW3 + ;;FHW7 + ;;FHW8 + ;;GMRAOR ALLERGY ENTER/EDIT + ;;GMRCOR CONSULT + ;;GMRCOR REQUEST + ;;GMRVOR + ;;LR OTHER LAB TESTS + ;;OR GWCOND CONDITION + ;;OR GWDIAG DIAGNOSIS + ;;OR GWINST DNR + ;;OR GXACTV OTHER ACTIVITY ORDER + ;;OR GXMISC GENERAL + ;;OR GXMOVE ADMIT PATIENT + ;;OR GXMOVE DISCHARGE + ;;OR GXMOVE EVENT + ;;OR GXMOVE TRANSFER + ;;OR GXMOVE TREATING SPECIALTY + ;;OR GXPARM CALL HO ON + ;;OR GXSKIN DRESSING CHANGE + ;;OR GXTEXT TEXT ONLY ORDER + ;;OR GXTEXT WORD PROCESSING ORDER + ;;ORWD GENERIC ACTIVITY + ;;ORWD GENERIC DIET + ;;ORWD GENERIC NURSING + ;;ORWD GENERIC VITALS + ;;PS MEDS + ;;PSJ OR PAT OE + ;;PSJI OR PAT FLUID OE + ;;PSO OERR + ;;PSO SUPPLY + ;;RA OERR EXAM + ;;ZZZZZ diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOAFIN.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOAFIN.m index 4e421bc2..b4dd0355 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOAFIN.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOAFIN.m @@ -1,109 +1,104 @@ -PSOAFIN ;VFA/HMS autofinish rx's from cprs ;2:33 PM 11 Nov 2008 - ;;7.0;OUTPATIENT PHARMACY;**208,250003**;DEC 1997;Build 41 - ; 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 - ; - ; Please note this routine is the gateway to modified routines that autofinish pending rxs entered by a provider. The modified routines allow rxs to be finished automatically & properly update File#100 and File#52. - ; The routines do not autocheck orders, check for duplicates, concatenate comments to sigs etc. All of the pharmacist checks will be done by the dispensing pharmacist. - ; $G(PSOAFYN) is tested at beginning of line to determine if the original code will run or if code modified to do AutoFinish,Rx will run -EN I '$D(^PS(52.41,"B",+ORDERID)) Q ;Check for pending order - N ZTRTN,ZTDESC,ZTDTH,ZTSAVE,ZTSK,ZTIO - S ZTRTN="EN1^PSOAFIN",ZTDESC="Autofinish,Rx",ZTDTH=$H,ZTDTH=$S(($P(ZTDTH,",",2)+10)\86400:(1+ZTDTH)_","_((($P(ZTDTH,",",2)+10)#86400)/100000),1:(+ZTDTH)_","_($P(ZTDTH,",",2)+10)) - S ZTSAVE("ORL")="",ZTSAVE("ORVP")="",ZTSAVE("VALMWD")="" - S ZTSAVE("ORL")="",ZTSAVE("ORDERID")="" - S ZTIO="NULL" ;WVEHR - 250003 - D ^%ZTLOAD - Q ;Quits back to ORWDX - ; -EN1 ;Autofinish Task Begins Here - ;D ^%ZTER ; For testing *ONLY* - ;S IOP="NULL" D ^%ZIS U IO - S PSOSITE=$G(^SC(+ORL,"AFRXSITE")) ;+ORL is hospital location from ORWDX - Q:PSOSITE="" ;Quits with no autofinish if File#44 does not point to File#59 - I $P($G(^PS(59,PSOSITE,"RXFIN")),"^",1)'="Y" Q ;Quits if Autofinish not turned on in File#59 Field#459001 - ;Check patient eligibility - S VFAELD="Y" - I $D(^PS(59,PSOSITE,"RXFINEL",1)) S VFAELD="N",DFN=+ORVP D ELIG^VADPT D - .S VFAEL=0 - .F L=1:1 S VFAEL=$O(^PS(59,PSOSITE,"RXFINEL",VFAEL)) Q:VFAEL=""!(VFAEL="B")!(VFAELD="Y") D - ..S VFAELL=$P(^PS(59,PSOSITE,"RXFINEL",VFAEL,0),"^",1) - ..I VFAELL=+VAEL(1) S VFAELD="Y" - Q:VFAELD="N" - ;Check Date Verify Code Last Changed and check Verify Code never expires. - S PSOAFYN="Y" ;Sets flag if Autofinish,Rx is turned on & is used throughout the routines - S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" - D ^DIC K DIC - Q:+Y=-1 ;Quits if AUTOFINISH,RX not a user - S DA=+Y - D DUZ^XUP(DA) ;Sets DUZ for AUTOFINISH,RX - K PSOAFDON ;Makes sure flag for quitting patient loop through File#52.41 is null - S PSOAFDFN=+ORVP ;From ORWDX CPRS Call is DFN of patient auto finishing rxs for - S PSOAFPAT=$P($G(^PS(55,PSOAFDFN,"PS")),"^") ;Sets patient status if it exists - I $G(PSOAFPAT)="" D - .I $P($G(^PS(59,PSOSITE,"RXFIN")),"^",2)'="" D - ..S ^PS(55,PSOAFDFN,"PS")=$P(^PS(59,PSOSITE,"RXFIN"),"^",2) - ..S PSOAFPAT=$P(^PS(59,PSOSITE,"RXFIN"),"^",2) - I $G(PSOAFPAT)="" D NOPATS ;Prints message if no patient status - S PSORX("PATIENT STATUS")=PSOAFPAT ;HMS 2007_03_11 - S PSOAFPNM=$P(^DPT(PSOAFDFN,0),"^",1) - S (PSODFN,PAT)=PSOAFDFN,PSOFINY=PSOAFDFN_"^"_PSOAFPNM - D ^PSOORFIN ;Begins execution of Rx Finishing routines - K PSOAFDFN,PSOAFYN,PSOAFDON,PSOAFDUZ,PSOAFPAT,PAT,PSODFN,PSOFINY,PSOSITE - Q ;Autofinish Task Quits Here - ; - ; - ; -NOPATS ;Quit message prints instead of prescription if no patient status - ;Checks for nw orders in File#52.41 - ;I $G(REA)'="" Q ;Quits if not signing a new rx - S PSOAFORB=+ORDERID-1,PSOAFORB=$O(^PS(52.41,"B",PSOAFORB)),PSOAFOB1="",PSOAFOB1=$O(^PS(52.41,"B",PSOAFORB,PSOAFOB1)),PSOAFRXS=$P(^PS(52.41,PSOAFOB1,0),"^",3) - I PSOAFRXS'="NW" K PSOAFORB,PSOAFOB1,PSOAFRXS Q ;Quits if no new pending rxs in File#52.41 - K PSOAFORB,PSOAFOB1,PSOAFRXS - I $G(PSOAFYN)="Y" S PSOLAP=$G(^SC(+ORL,"AFRXCLINPRNT")) ;vfah sets printer as defined in File#44 - I $G(PSOAFYN)="Y" I PSOLAP="" S DIRUT="^" G:$D(DIRUT)!($D(DUOUT)) EX ;vfah If DIRUT set to "^" will bypass label printing, queueing etc if no printer defined in File#44 - I $G(PSOAFYN)="Y" S PSOLAP=$P(^%ZIS(1,PSOLAP,0),"^",1) ;vhah sets PSOLAP to literal of printer name - S PSOAFPNM=$P(^DPT(PSOAFDFN,0),"^",1) - S PSOAFPNM=$P(^DPT(PSOAFDFN,0),"^",1) -QLBL ;Queues no patient status notice - D ^%ZISC - S ZTRTN="PLBL^PSOAFIN",ZTIO=$G(PSOLAP),ZTDESC="Autofinish,Rx No Patient Status Message",ZTDTH=$H ;Sets Taskman variables - Q:PSOLAP="" - S ZTSAVE("*")="" - D ^%ZTLOAD - H 1 - D ^%ZISC - K PSOAFDFN,PSOAFPNM - Q - ; -PLBL ;Prints no patient status notice - W !,"CAN NOT AUTO-FINISH or MANUALLY FINISH RX(S)" - W !!,"FOR PATIENT: ",PSOAFPNM_" "_$E($P($G(^DPT(PSOAFDFN,0)),"^",9),4,5)_"-"_$E($P($G(^DPT(PSOAFDFN,0)),"^",9),6,9) - W !!,"THERE IS NO PATIENT STATUS SET FOR THIS PATIENT." - W !!,"PLEASE ENTER A PATIENT STATUS FOR THIS PATIENT" - W !,"AND THEN SIGN RXS IN CPRS TO AUTOFINISH RXS" - W !!,"THANK YOU" - W !,"AUTOFINISH,RX" - W !,$$FMTE^XLFDT($$NOW^XLFDT()) - D ^%ZISC -EX K PSOAFDFN,PSOAFYN,PSOAFDON,PSOAFDUZ,PSOAFPNM,PSOAFPAT,PAT,PSODFN,PSOFINY,PSOSITE - Q - ; -DISPD ;Selects dispense drug if not selected in CPRS - S PSI=0 - F PSI=0:0 S PSI=$O(^PSDRUG("ASP",PSODRUG("OI"),PSI)) Q:'PSI I $S('$D(^PSDRUG(PSI,"I")):1,'^("I"):1,DT'>^("I"):1,1:0),$S($P($G(^PSDRUG(PSI,2)),"^",3)'["O":0,1:1) D Q:PSI>0 - .S $P(OR0,"^",9)=PSI,$P(^PS(52.41,ORD,0),"^",9)=PSI - S VFASDD="Y" - Q +PSOAFIN ;VFA/HMS autofinish rx's from cprs ;4/21/07 19:10 + ;;7.0;OUTPATIENT PHARMACY;**208**;DEC 1997;Build 39 + ; 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 + ; + ; Please note this routine is the gateway to modified routines that autofinish pending rxs entered by a provider. The modified routines allow rxs to be finished automatically & properly update File#100 and File#52. + ; The routines do not autocheck orders, check for duplicates, concatenate comments to sigs etc. All of the pharmacist checks will be done by the dispensing pharmacist. + ; $G(PSOAFYN) is tested at beginning of line to determine if the original code will run or if code modified to do AutoFinish,Rx will run +EN I '$D(^PS(52.41,"B",+ORDERID)) Q ;Check for pending order + N ZTRTN,ZTDESC,ZTDTH,ZTSAVE,ZTSK + S ZTRTN="EN1^PSOAFIN",ZTDESC="Autofinish,Rx",ZTDTH=$H,ZTDTH=$S(($P(ZTDTH,",",2)+10)\86400:(1+ZTDTH)_","_((($P(ZTDTH,",",2)+10)#86400)/100000),1:(+ZTDTH)_","_($P(ZTDTH,",",2)+10)) + S ZTSAVE("ORL")="",ZTSAVE("ORVP")="",ZTSAVE("IO*")="",ZTSAVE("VALMWD")="",ZTSAVE("ORL")="",ZTSAVE("ORDERID")="" D ^%ZTLOAD + Q ;Quits back to ORWDX + ; +EN1 ;Autofinish Task Begins Here + S PSOSITE=$G(^SC(+ORL,"AFRXSITE")) ;+ORL is hospital location from ORWDX + Q:PSOSITE="" ;Quits with no autofinish if File#44 does not point to File#59 + I $P($G(^PS(59,PSOSITE,"RXFIN")),"^",1)'="Y" Q ;Quits if Autofinish not turned on in File#59 Field#459001 + ;Check patient eligibility + S VFAELD="Y" + I $D(^PS(59,PSOSITE,"RXFINEL",1)) S VFAELD="N",DFN=+ORVP D ELIG^VADPT D + .S VFAEL=0 + .F L=1:1 S VFAEL=$O(^PS(59,PSOSITE,"RXFINEL",VFAEL)) Q:VFAEL=""!(VFAEL="B")!(VFAELD="Y") D + ..S VFAELL=$P(^PS(59,PSOSITE,"RXFINEL",VFAEL,0),"^",1) + ..I VFAELL=+VAEL(1) S VFAELD="Y" + Q:VFAELD="N" + ;Check Date Verify Code Last Changed and check Verify Code never expires. + S PSOAFYN="Y" ;Sets flag if Autofinish,Rx is turned on & is used throughout the routines + S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" + D ^DIC K DIC + Q:+Y=-1 ;Quits if AUTOFINISH,RX not a user + S DA=+Y + D DUZ^XUP(DA) ;Sets DUZ for AUTOFINISH,RX + K PSOAFDON ;Makes sure flag for quitting patient loop through File#52.41 is null + S PSOAFDFN=+ORVP ;From ORWDX CPRS Call is DFN of patient auto finishing rxs for + S PSOAFPAT=$P($G(^PS(55,PSOAFDFN,"PS")),"^") ;Sets patient status if it exists + I $G(PSOAFPAT)="" D + .I $P($G(^PS(59,PSOSITE,"RXFIN")),"^",2)'="" D + ..S ^PS(55,PSOAFDFN,"PS")=$P(^PS(59,PSOSITE,"RXFIN"),"^",2) + ..S PSOAFPAT=$P(^PS(59,PSOSITE,"RXFIN"),"^",2) + I $G(PSOAFPAT)="" D NOPATS ;Prints message if no patient status + S PSORX("PATIENT STATUS")=PSOAFPAT ;HMS 2007_03_11 + S PSOAFPNM=$P(^DPT(PSOAFDFN,0),"^",1) + S (PSODFN,PAT)=PSOAFDFN,PSOFINY=PSOAFDFN_"^"_PSOAFPNM + D ^PSOORFIN ;Begins execution of Rx Finishing routines + K PSOAFDFN,PSOAFYN,PSOAFDON,PSOAFDUZ,PSOAFPAT,PAT,PSODFN,PSOFINY,PSOSITE + Q ;Autofinish Task Quits Here + ; + ; + ; +NOPATS ;Quit message prints instead of prescription if no patient status + ;Checks for nw orders in File#52.41 + ;I $G(REA)'="" Q ;Quits if not signing a new rx + S PSOAFORB=+ORDERID-1,PSOAFORB=$O(^PS(52.41,"B",PSOAFORB)),PSOAFOB1="",PSOAFOB1=$O(^PS(52.41,"B",PSOAFORB,PSOAFOB1)),PSOAFRXS=$P(^PS(52.41,PSOAFOB1,0),"^",3) + I PSOAFRXS'="NW" K PSOAFORB,PSOAFOB1,PSOAFRXS Q ;Quits if no new pending rxs in File#52.41 + K PSOAFORB,PSOAFOB1,PSOAFRXS + I $G(PSOAFYN)="Y" S PSOLAP=$G(^SC(+ORL,"AFRXCLINPRNT")) ;vfah sets printer as defined in File#44 + I $G(PSOAFYN)="Y" I PSOLAP="" S DIRUT="^" G:$D(DIRUT)!($D(DUOUT)) EX ;vfah If DIRUT set to "^" will bypass label printing, queueing etc if no printer defined in File#44 + I $G(PSOAFYN)="Y" S PSOLAP=$P(^%ZIS(1,PSOLAP,0),"^",1) ;vhah sets PSOLAP to literal of printer name + S PSOAFPNM=$P(^DPT(PSOAFDFN,0),"^",1) + S PSOAFPNM=$P(^DPT(PSOAFDFN,0),"^",1) +QLBL ;Queues no patient status notice + D ^%ZISC + S ZTRTN="PLBL^PSOAFIN",ZTIO=$G(PSOLAP),ZTDESC="Autofinish,Rx No Patient Status Message",ZTDTH=$H ;Sets Taskman variables + Q:PSOLAP="" + S ZTSAVE("*")="" + D ^%ZTLOAD + H 1 + D ^%ZISC + K PSOAFDFN,PSOAFPNM + Q + ; +PLBL ;Prints no patient status notice + W !,"CAN NOT AUTO-FINISH or MANUALLY FINISH RX(S)" + W !!,"FOR PATIENT: ",PSOAFPNM_" "_$E($P($G(^DPT(PSOAFDFN,0)),"^",9),4,5)_"-"_$E($P($G(^DPT(PSOAFDFN,0)),"^",9),6,9) + W !!,"THERE IS NO PATIENT STATUS SET FOR THIS PATIENT." + W !!,"PLEASE ENTER A PATIENT STATUS FOR THIS PATIENT" + W !,"AND THEN SIGN RXS IN CPRS TO AUTOFINISH RXS" + W !!,"THANK YOU" + W !,"AUTOFINISH,RX" + W !,$$FMTE^XLFDT($$NOW^XLFDT()) + D ^%ZISC +EX K PSOAFDFN,PSOAFYN,PSOAFDON,PSOAFDUZ,PSOAFPNM,PSOAFPAT,PAT,PSODFN,PSOFINY,PSOSITE + Q + ; +DISPD ;Selects dispense drug if not selected in CPRS + S PSI=0 + F PSI=0:0 S PSI=$O(^PSDRUG("ASP",PSODRUG("OI"),PSI)) Q:'PSI I $S('$D(^PSDRUG(PSI,"I")):1,'^("I"):1,DT'>^("I"):1,1:0),$S($P($G(^PSDRUG(PSI,2)),"^",3)'["O":0,1:1) D Q:PSI>0 + .S $P(OR0,"^",9)=PSI,$P(^PS(52.41,ORD,0),"^",9)=PSI + S VFASDD="Y" + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOAFPT1.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOAFPT1.m index 0c6e15ad..9118625f 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOAFPT1.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOAFPT1.m @@ -1,19 +1,19 @@ -PSOAFPT1 ;VFA/HMS Autofinish Star Micronics Landscape print; 3/1/07 7:13pm ; 3/1/07 9:48pm - ;;7.0;OUTPATIENT PHARMACY;**208**;DEC 1997;Build 41 - ; 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 -BEGLP ; -PRNT D PRNT^PSOAFPTS ;For testing until landscape code completed +PSOAFPT1 ;VFA/HMS Autofinish Star Micronics Landscape print; 3/1/07 7:13pm ; 3/1/07 9:48pm + ;;7.0;OUTPATIENT PHARMACY;**208**;DEC 1997;Build 39 + ; 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 +BEGLP ; +PRNT D PRNT^PSOAFPTS ;For testing until landscape code completed diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOAFPTL.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOAFPTL.m index a3c4d5b7..6013dfac 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOAFPTL.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOAFPTL.m @@ -1,223 +1,223 @@ -PSOAFPTL ;VFA/HMS autofinish print for laser printer ; 3/6/07 9:25pm - ;;7.0;OUTPATIENT PHARMACY;**208**;DEC 1997;Build 41 - ; 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 -BEGLP ; - U IO ;hms fax stuff - ; - F DR=1:1 Q:$G(SGY(DR))="" S SN=19+DR D - .S AFSIG(SN)=$G(SGY(DR)) - S SIGL=DR-1 - ; - ;CHECK FOR ES - S AFESFLAG=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",3) - S AFORD=$P(^PSRX(RX,"OR1"),"^",2) - I $G(AFESFLAG)="Y" D - .S AFES=$P($G(^OR(100,AFORD,8,1,0)),"^",4) - .I $G(AFES)=1 S AFESYN="Y" - .I $G(AFESYN)="Y" S AFESIGN=$P($G(^OR(100,AFORD,8,1,0)),"^",5) - ; - ;CHECK FOR SCHEDULE II WET SIGNATUIRE - S AFWET2=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",6) - S AFDEA=$P(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),0),"^",3) - ; - I $G(AFWET2)="Y"&($G(AFDEA)["2") S AFESFLAG="" ;Turns off ES for Sch IIs if wet sig for IIs set in File#59 - I $G(AFWET2)="Y"&($G(AFDEA)["2") S AFESYN="" - ; - ;Get Synonym - S AFS=0,DONE="N",AFSYN="" F L=1:1 S AFS=$O(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),1,AFS)) Q:AFS=""!(DONE="Y") D - .I $P(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),1,AFS,0),"^",3)="0" D - ..S AFSYN=$P($G(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),1,AFS,0)),"^",1),DONE="Y" - K DONE - ; -FAX ; - K AFFAX - S FAXNUM=$G(PSOAFFXP) ;PSOAFFXP from PSOLBLN - S FAXLCNUM=$G(PSOAFFXL)_"@"_FAXNUM - S FAXSER=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",10) - I $G(FAXNUM)'=""&(FAXSER'="") D - . S AFFAX="Y" - I IO["AFFAX"!($G(AFFAX)="Y") D - .D NOW^%DTC - .S FAXDATE=$P(%,".",1)_"Z"_$P(%,".",2) - .S FAXJOB=RX_"Z"_DFN_"Z"_FAXDATE - .D OPEN^%ZISH("HFSFAX",FAXSER,FAXJOB_"+"_FAXLCNUM_".TXT","A") - .S AFFAX="Y" - .U IO - ; - ;Checks to see if 1st 3 lines should print - S PSOAFPFT=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",9) - ; -EN1 S OFF=$P(PS,"^",1) - W $S(PSOAFPFT="N":"",1:OFF) - ; - S OFFAD=$P(PS,"^",7)_","_STATE_" "_$G(PSOHZIP) - W ! - W $S(PSOAFPFT="N":"",1:OFFAD) - ; - S OFFTEL=$P(PS,"^",3)_"-"_$P(PS,"^",4) - W ! - W $S(PSOAFPFT="N":"",1:OFFTEL) - ; - S OFFFREE=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",4) - W !,OFFFREE - ; - W !,"---------------------------------------------------------------",! - ; - W !,"Rx for: " - ; - D 6^VADPT,PID^VADPT - S PSOAFPTI=$S(DUZ("AG")="V":$E($G(VA("PID")),5,12),1:$G(VA("PID"))) - S AFPNAM=PNM_" "_$G(PSOAFPTI) - W AFPNAM - ; - S AFPADD1=$G(VAPA(1)) - W !," ",AFPADD1 - ; - S AFPADD2=$G(ADDR(2)) - W !," ",AFPADD2 - ; - S AFPADD3=$G(ADDR(3)) - W !," ",AFPADD3 - ; - S AFPADD4=$G(ADDR(4)) - W !," ",AFPADD4 - ; - W !,"---------------------------------------------------------------",! - S AFDRUG=DRUG - W !,AFDRUG - ; - S SYNFLAG=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",5) - I SYNFLAG="Y"&(AFSYN'="") D - .W !,"Also known as: " - .W AFSYN - ; - I $P($G(^PSRX(RX,"RXFIN")),"^",1)="Y" S VFASDD="Y" - I $G(VFASDD)="Y" D - .W !,"Pharmacy may choose strength(s) of drug to meet requirements of directions" - ; - ; -SIG S SN=19 - W ! - F L=1:1:SIGL S SN=SN+1 W !,AFSIG(SN) - W ! - ; - W !," Dispense: " - S AFDISP=$G(QTY)_" "_$G(PSDU) - W AFDISP - ; - I $G(VFASDD)="Y" W " Pharmacy to adjust qty for # of days" - ; - W !,"Days Supply: " - S VFADAYS=$G(DAYS) - W VFADAYS - ; - W !," Refill(s): " - S AFRF=$P(RXY,"^",9) - W AFRF - ; - W !," Issue Date: " - W DATE - ; - ;Print Diagnosis - I $P($G(^PS(59,PSOSITE,"RXFIN")),"^",8)="Y" D -DIAG .W !," Diagnosis:" - .S AFICD9="None",AFICD="Not Available" - .I $D(^OR(100,AFORD,5.1,0)) D - ..S AFORL=0 - ..F L=1:1 S AFORL=$O(^OR(100,AFORD,5.1,AFORL)) Q:AFORL="B"!(AFORL=0)!(AFORL="") D - ...S AFORIN=$P($G(^OR(100,AFORD,5.1,AFORL,0)),"^",1) - ...I AFORIN>"" D - ....S AFICD9=$P($G(^ICD9(AFORIN,0)),"^",1) - ....S AFICD=$P($G(^ICD9(AFORIN,0)),"^",3) - ....W ?13,AFICD9,?23,AFICD - .I AFICD9="None" W ?13,AFICD9,?23,AFICD - ; - ;Prints DOB - I $P($G(^PS(59,PSOSITE,"RXFIN")),"^",7)="Y" D - .S PSOAFDOB=$P($G(VADM(3)),"^",2) - .W !," DOB: "_PSOAFDOB,! - ; - ;Prints Provider Comments - ;W "MD Comments:" - K ^UTILITY($J,"W") S PSNACNT=1,DIWL=0,DIWR=48,DIWF="",(PSSIXFL,PSSEVFL)=0 F ZZ=0:0 S ZZ=$O(^PSRX(RX,"PRC",ZZ)) Q:'ZZ I $D(^(ZZ,0)) S X=^(0) D ^DIWP - ;D ^DIWW - I $D(^UTILITY($J,"W")) D - .W "MD Comments:" - .F ZZ=0:0 S ZZ=$O(^UTILITY($J,"W",DIWL,ZZ)) Q:'ZZ I $D(^(ZZ,0)) W ?13,^(0),! - K ^UTILITY($J,"W") - ; -SIGN ;Prints DEA if it exists-if no DEA# prints VA# if it exists - I $G(AFESFLAG)="Y" D - .I $G(AFESYN)="Y" D - ..S AFDEA=$$GET1^DIQ(200,AFESIGN,53.2,"I") - ..I AFDEA="" D - ...S AFDEA=$$GET1^DIQ(200,AFESIGN,53.3,"I") - ..S AFESIGNN=$$GET1^DIQ(200,AFESIGN,.01,"I") - ..S AFSIGN=$G(AFESIGNN)_" "_AFDEA - ; -SIGN1 I $G(AFESFLAG)'="Y" D - .W !!!,"Signature:_________________________________________________" - .;vfah prints DEA if it exists-if no DEA# prints VA# if it exists - .S AFDEA=$$GET1^DIQ(200,PSOAFPRV,53.2,"I") - .I AFDEA="" D - ..S AFDEA=$$GET1^DIQ(200,PSOAFPRV,53.3,"I") - .S AFSIGN=" "_$G(PHYS)_" "_AFDEA - ; -SIGNP I $G(AFESYN)="Y" S AFSIGN="Signed: /ES/"_AFSIGN - W !,AFSIGN - ; - K AFESYN,AFESIGN,AFESIGNN - ; - W !!,"Must write BRAND NECESSARY to dispense brand drug" - ; - S AFPTIM=$S($D(REPRINT):"Re-Printed on: ",1:"Printed on: ") - W !!,AFPTIM - ; - D NOW^%DTC S Y=% X ^DD("DD") - S AFPRNDT=Y_" ("_RX_")" - W AFPRNDT - ; - I IO["AFFAX"!($G(AFFAX)="Y") D - .S FAXFROM=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",11) - .W !!,"Faxed from: ",FAXFROM," ON ",Y - ; - I $D(REPRINT)&($G(PSOCKHN)'=",") W @IOF - ; - K VFASDD - ; - I IO["AFFAX"!($G(AFFAX)="Y") D CLOSE^%ZISH("HFSFAX") ;HMS CLOSE HFS FILE - ; - I $G(REPRINT)'=1 D - .I IO["AFFAX"!($G(AFFAX)="Y") D - ..S PSOLAP=$G(^SC(+ORL,"AFRXCLINPRNT")) - ..S PSOLAP=$P(^%ZIS(1,PSOLAP,0),"^",1) - ..S IOP=PSOLAP D ^%ZIS - ..U IO - ; -ACT ;Set activity log if faxed - I IO["AFFAX"!($G(AFFAX)="Y") D - .S (X,PCOM,PCOMX)="Faxed to: "_PSOAFFXP_" on "_Y - .I '$D(PSOCLC) S PSOCLC=DUZ -ACT1 .S RXF=0 F J=0:0 S J=$O(^PSRX(RX,1,J)) Q:'J S RXF=J S:J>5 RXF=J+1 - .S IR=0 F J=0:0 S J=$O(^PSRX(RX,"A",J)) Q:'J S IR=J - .S PSOAFPTZ=$S($D(REPRINT):"W",1:"AFFAX") - .S IR=IR+1,^PSRX(RX,"A",0)="^52.3DA^"_IR_"^"_IR - .D NOW^%DTC S ^PSRX(RX,"A",IR,0)=%_"^"_PSOAFPTZ_"^"_DUZ_"^"_RXF_"^"_PCOM K PC,IR,PS,PCOM,XX,%,%H,%I,RXF - ; - K PSOAFFXP,PSOAFFXL - ; - Q +PSOAFPTL ;VFA/HMS autofinish print for laser printer ; 3/6/07 9:25pm + ;;7.0;OUTPATIENT PHARMACY;**208**;DEC 1997;Build 39 + ; 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 +BEGLP ; + U IO ;hms fax stuff + ; + F DR=1:1 Q:$G(SGY(DR))="" S SN=19+DR D + .S AFSIG(SN)=$G(SGY(DR)) + S SIGL=DR-1 + ; + ;CHECK FOR ES + S AFESFLAG=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",3) + S AFORD=$P(^PSRX(RX,"OR1"),"^",2) + I $G(AFESFLAG)="Y" D + .S AFES=$P($G(^OR(100,AFORD,8,1,0)),"^",4) + .I $G(AFES)=1 S AFESYN="Y" + .I $G(AFESYN)="Y" S AFESIGN=$P($G(^OR(100,AFORD,8,1,0)),"^",5) + ; + ;CHECK FOR SCHEDULE II WET SIGNATUIRE + S AFWET2=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",6) + S AFDEA=$P(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),0),"^",3) + ; + I $G(AFWET2)="Y"&($G(AFDEA)["2") S AFESFLAG="" ;Turns off ES for Sch IIs if wet sig for IIs set in File#59 + I $G(AFWET2)="Y"&($G(AFDEA)["2") S AFESYN="" + ; + ;Get Synonym + S AFS=0,DONE="N",AFSYN="" F L=1:1 S AFS=$O(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),1,AFS)) Q:AFS=""!(DONE="Y") D + .I $P(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),1,AFS,0),"^",3)="0" D + ..S AFSYN=$P($G(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),1,AFS,0)),"^",1),DONE="Y" + K DONE + ; +FAX ; + K AFFAX + S FAXNUM=$G(PSOAFFXP) ;PSOAFFXP from PSOLBLN + S FAXLCNUM=$G(PSOAFFXL)_"@"_FAXNUM + S FAXSER=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",10) + I $G(FAXNUM)'=""&(FAXSER'="") D + . S AFFAX="Y" + I IO["AFFAX"!($G(AFFAX)="Y") D + .D NOW^%DTC + .S FAXDATE=$P(%,".",1)_"Z"_$P(%,".",2) + .S FAXJOB=RX_"Z"_DFN_"Z"_FAXDATE + .D OPEN^%ZISH("HFSFAX",FAXSER,FAXJOB_"+"_FAXLCNUM_".TXT","A") + .S AFFAX="Y" + .U IO + ; + ;Checks to see if 1st 3 lines should print + S PSOAFPFT=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",9) + ; +EN1 S OFF=$P(PS,"^",1) + W $S(PSOAFPFT="N":"",1:OFF) + ; + S OFFAD=$P(PS,"^",7)_","_STATE_" "_$G(PSOHZIP) + W ! + W $S(PSOAFPFT="N":"",1:OFFAD) + ; + S OFFTEL=$P(PS,"^",3)_"-"_$P(PS,"^",4) + W ! + W $S(PSOAFPFT="N":"",1:OFFTEL) + ; + S OFFFREE=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",4) + W !,OFFFREE + ; + W !,"---------------------------------------------------------------",! + ; + W !,"Rx for: " + ; + D 6^VADPT,PID^VADPT + S PSOAFPTI=$S(DUZ("AG")="V":$E($G(VA("PID")),5,12),1:$G(VA("PID"))) + S AFPNAM=PNM_" "_$G(PSOAFPTI) + W AFPNAM + ; + S AFPADD1=$G(VAPA(1)) + W !," ",AFPADD1 + ; + S AFPADD2=$G(ADDR(2)) + W !," ",AFPADD2 + ; + S AFPADD3=$G(ADDR(3)) + W !," ",AFPADD3 + ; + S AFPADD4=$G(ADDR(4)) + W !," ",AFPADD4 + ; + W !,"---------------------------------------------------------------",! + S AFDRUG=DRUG + W !,AFDRUG + ; + S SYNFLAG=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",5) + I SYNFLAG="Y"&(AFSYN'="") D + .W !,"Also known as: " + .W AFSYN + ; + I $P($G(^PSRX(RX,"RXFIN")),"^",1)="Y" S VFASDD="Y" + I $G(VFASDD)="Y" D + .W !,"Pharmacy may choose strength(s) of drug to meet requirements of directions" + ; + ; +SIG S SN=19 + W ! + F L=1:1:SIGL S SN=SN+1 W !,AFSIG(SN) + W ! + ; + W !," Dispense: " + S AFDISP=$G(QTY)_" "_$G(PSDU) + W AFDISP + ; + I $G(VFASDD)="Y" W " Pharmacy to adjust qty for # of days" + ; + W !,"Days Supply: " + S VFADAYS=$G(DAYS) + W VFADAYS + ; + W !," Refill(s): " + S AFRF=$P(RXY,"^",9) + W AFRF + ; + W !," Issue Date: " + W DATE + ; + ;Print Diagnosis + I $P($G(^PS(59,PSOSITE,"RXFIN")),"^",8)="Y" D +DIAG .W !," Diagnosis:" + .S AFICD9="None",AFICD="Not Available" + .I $D(^OR(100,AFORD,5.1,0)) D + ..S AFORL=0 + ..F L=1:1 S AFORL=$O(^OR(100,AFORD,5.1,AFORL)) Q:AFORL="B"!(AFORL=0)!(AFORL="") D + ...S AFORIN=$P($G(^OR(100,AFORD,5.1,AFORL,0)),"^",1) + ...I AFORIN>"" D + ....S AFICD9=$P($G(^ICD9(AFORIN,0)),"^",1) + ....S AFICD=$P($G(^ICD9(AFORIN,0)),"^",3) + ....W ?13,AFICD9,?23,AFICD + .I AFICD9="None" W ?13,AFICD9,?23,AFICD + ; + ;Prints DOB + I $P($G(^PS(59,PSOSITE,"RXFIN")),"^",7)="Y" D + .S PSOAFDOB=$P($G(VADM(3)),"^",2) + .W !," DOB: "_PSOAFDOB,! + ; + ;Prints Provider Comments + ;W "MD Comments:" + K ^UTILITY($J,"W") S PSNACNT=1,DIWL=0,DIWR=48,DIWF="",(PSSIXFL,PSSEVFL)=0 F ZZ=0:0 S ZZ=$O(^PSRX(RX,"PRC",ZZ)) Q:'ZZ I $D(^(ZZ,0)) S X=^(0) D ^DIWP + ;D ^DIWW + I $D(^UTILITY($J,"W")) D + .W "MD Comments:" + .F ZZ=0:0 S ZZ=$O(^UTILITY($J,"W",DIWL,ZZ)) Q:'ZZ I $D(^(ZZ,0)) W ?13,^(0),! + K ^UTILITY($J,"W") + ; +SIGN ;Prints DEA if it exists-if no DEA# prints VA# if it exists + I $G(AFESFLAG)="Y" D + .I $G(AFESYN)="Y" D + ..S AFDEA=$$GET1^DIQ(200,AFESIGN,53.2,"I") + ..I AFDEA="" D + ...S AFDEA=$$GET1^DIQ(200,AFESIGN,53.3,"I") + ..S AFESIGNN=$$GET1^DIQ(200,AFESIGN,.01,"I") + ..S AFSIGN=$G(AFESIGNN)_" "_AFDEA + ; +SIGN1 I $G(AFESFLAG)'="Y" D + .W !!!,"Signature:_________________________________________________" + .;vfah prints DEA if it exists-if no DEA# prints VA# if it exists + .S AFDEA=$$GET1^DIQ(200,PSOAFPRV,53.2,"I") + .I AFDEA="" D + ..S AFDEA=$$GET1^DIQ(200,PSOAFPRV,53.3,"I") + .S AFSIGN=" "_$G(PHYS)_" "_AFDEA + ; +SIGNP I $G(AFESYN)="Y" S AFSIGN="Signed: /ES/"_AFSIGN + W !,AFSIGN + ; + K AFESYN,AFESIGN,AFESIGNN + ; + W !!,"Must write BRAND NECESSARY to dispense brand drug" + ; + S AFPTIM=$S($D(REPRINT):"Re-Printed on: ",1:"Printed on: ") + W !!,AFPTIM + ; + D NOW^%DTC S Y=% X ^DD("DD") + S AFPRNDT=Y_" ("_RX_")" + W AFPRNDT + ; + I IO["AFFAX"!($G(AFFAX)="Y") D + .S FAXFROM=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",11) + .W !!,"Faxed from: ",FAXFROM," ON ",Y + ; + I $D(REPRINT)&($G(PSOCKHN)'=",") W @IOF + ; + K VFASDD + ; + I IO["AFFAX"!($G(AFFAX)="Y") D CLOSE^%ZISH("HFSFAX") ;HMS CLOSE HFS FILE + ; + I $G(REPRINT)'=1 D + .I IO["AFFAX"!($G(AFFAX)="Y") D + ..S PSOLAP=$G(^SC(+ORL,"AFRXCLINPRNT")) + ..S PSOLAP=$P(^%ZIS(1,PSOLAP,0),"^",1) + ..S IOP=PSOLAP D ^%ZIS + ..U IO + ; +ACT ;Set activity log if faxed + I IO["AFFAX"!($G(AFFAX)="Y") D + .S (X,PCOM,PCOMX)="Faxed to: "_PSOAFFXP_" on "_Y + .I '$D(PSOCLC) S PSOCLC=DUZ +ACT1 .S RXF=0 F J=0:0 S J=$O(^PSRX(RX,1,J)) Q:'J S RXF=J S:J>5 RXF=J+1 + .S IR=0 F J=0:0 S J=$O(^PSRX(RX,"A",J)) Q:'J S IR=J + .S PSOAFPTZ=$S($D(REPRINT):"W",1:"AFFAX") + .S IR=IR+1,^PSRX(RX,"A",0)="^52.3DA^"_IR_"^"_IR + .D NOW^%DTC S ^PSRX(RX,"A",IR,0)=%_"^"_PSOAFPTZ_"^"_DUZ_"^"_RXF_"^"_PCOM K PC,IR,PS,PCOM,XX,%,%H,%I,RXF + ; + K PSOAFFXP,PSOAFFXL + ; + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOAFPTS.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOAFPTS.m index bf1c4e3a..14ba08e9 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOAFPTS.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOAFPTS.m @@ -1,305 +1,305 @@ -PSOAFPTS ;VFA/HMS autofinish print for star printer ;3/13/07 19:26 - ;;7.0;OUTPATIENT PHARMACY;**208**;DEC 1997;Build 41 - ; Copyright (C) GNU GPL 2007 WorldVistA - ; -PRNT ;PAGEMODE for Star Micronics - ; - U IO ;vfah fax - ; - F DR=1:1 Q:$G(SGY(DR))="" S SN=19+DR D - .S AFSIG(SN)=$G(SGY(DR)) - S SIGL=DR-1 - ; - S AFESFLAG=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",3) - S AFORD=$P(^PSRX(RX,"OR1"),"^",2) - I $G(AFESFLAG)="Y" D - .S AFES=$P($G(^OR(100,AFORD,8,1,0)),"^",4) - .I $G(AFES)=1 S AFESYN="Y" - .I $G(AFESYN)="Y" S AFESIGN=$P($G(^OR(100,AFORD,8,1,0)),"^",5) - ; - S AFWET2=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",6) - S AFDEA=$P(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),0),"^",3) - ; - I $G(AFWET2)="Y"&($G(AFDEA)["2") S AFESFLAG="" ;Turns off ES for Sch IIs if wet sig for IIs set in File#59 - I $G(AFWET2)="Y"&($G(AFDEA)["2") S AFESYN="" - ; - S AFS=0,DONE="N",AFSYN="" F L=1:1 S AFS=$O(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),1,AFS)) Q:AFS=""!(DONE="Y") D - .I $P(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),1,AFS,0),"^",3)="0" D - ..S AFSYN=$P($G(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),1,AFS,0)),"^",1),DONE="Y" - K DONE - ; -DIAG ; - S AFICD9(1)="None",AFICD(1)="Not Available",L=2 - I $D(^OR(100,AFORD,5.1,0)) D - .S AFORL=0 - .F L=1:1 S AFORL=$O(^OR(100,AFORD,5.1,AFORL)) Q:AFORL="B"!(AFORL=0)!(AFORL="") D - ..S AFORIN=$P($G(^OR(100,AFORD,5.1,AFORL,0)),"^",1) - ..I AFORIN>"" D - ...S AFICD9(L)=$P($G(^ICD9(AFORIN,0)),"^",1) - ...S AFICD(L)=$P($G(^ICD9(AFORIN,0)),"^",3) - S AFICDN=L-1 - ; -PRC ; - K ^UTILITY($J,"W") S PSNACNT=1,DIWL=0,DIWR=70,DIWF="",(PSSIXFL,PSSEVFL)=0 F ZZ=0:0 S ZZ=$O(^PSRX(RX,"PRC",ZZ)) Q:'ZZ I $D(^(ZZ,0)) S X=^(0) D ^DIWP - F ZZ=0:0 S ZZ=$O(^UTILITY($J,"W",DIWL,ZZ)) Q:'ZZ I $D(^(ZZ,0)) S PSOAFZZ=ZZ - ; - W $C(27),"C",$C(10),$C(0) ;Clear format - ; - W $C(27),"L00;0110,0030,0920,0030,0,6",$C(10),$C(0) ;T - W $C(27),"L01;0025,0100,0025,0230,1,6",$C(10),$C(0) ;L - W $C(27),"L02;1000,0100,1000,0238,1,6",$C(10),$C(0) ;R - W $C(27),"L03;0025,0230,1000,0230,0,6",$C(10),$C(0) ;B - W $C(27),"L10;0920,0030,0920,0100,1,6",$C(10),$C(0) ;R - W $C(27),"L11;0920,0100,1000,0100,0,6",$C(10),$C(0) ;B - W $C(27),"L12;0110,0030,0110,0102,1,6",$C(10),$C(0) ;R - W $C(27),"L13;0025,0100,0112,0100,0,6",$C(10),$C(0) ;B - ; - W $C(27),"L05;0025,0470,1000,0470,0,2",$C(10),$C(0) ;Div Line - ; - W $C(27),"PC00;0210,0055,1,1,4,00,00",$C(10),$C(0) ;Dr - W $C(27),"PC01;0025,0100,1,1,2,00,00",$C(10),$C(0) ;Dr - W $C(27),"PC02;0025,0145,1,1,2,00,00",$C(10),$C(0) ;Dr Phone - W $C(27),"PC70;0025,0190,1,1,2,00,00",$C(10),$C(0) ;Free line - ; - W $C(27),"PC03;0025,0285,1,1,1,00,03",$C(10),$C(0) ;Rx For - W $C(27),"PC04;0130,0280,1,1,2,00,00",$C(10),$C(0) ;Pat Name - W $C(27),"PC05;0130,0320,1,1,2,00,00",$C(10),$C(0) ;Pat Str1 - W $C(27),"PC06;0130,0360,1,1,2,00,00",$C(10),$C(0) ;Pat Str2 - W $C(27),"PC07;0130,0400,1,1,2,00,00",$C(10),$C(0) ;Pat Str3 - W $C(27),"PC08;0130,0440,1,1,2,00,00",$C(10),$C(0) ;Pat City - ; - S DHL=4 - S:$L(DRUG)>33 DHL=2 ;Reduce size for L>33 - W $C(27),"PC09;0025,0500,1,1,"_DHL_",00,00",$C(10),$C(0) ;Drug - ; - W $C(27),"PC72;0025,0558,1,1,1,00,03",$C(10),$C(0) ;AKA Notice - W $C(27),"PC71;0225,0550,1,1,2,00,00",$C(10),$C(0) ;Drug Syn - ; - W $C(27),"PC10;0025,0590,1,1,1,00,03",$C(10),$C(0) ;SDD Disclaimer - ; - S SL=19,VP=590 - F L=1:1:SIGL D - .S SL=SL+1,VP=VP+40 - .D SVP - .W $C(27),"PC"_SL_";0025,"_VP_",1,1,2,00,00",$C(10),$C(0) - ; - S VP=VP+60 D SVP - W $C(27),"PC50;0085,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Disp: - W $C(27),"PC51;0300,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Disp Num - ; - ;S VP=VP+40 D SVP - W $C(27),"PC52;0450,"_VP_",1,1,1,00,03",$C(10),$C(0) ;Disp Disclaimer - ; - S VP=VP+40 D SVP - W $C(27),"PC53;0025,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Days - W $C(27),"PC54;0300,"_VP_",1,1,2,00,00",$C(10),$C(0) ; Supply - ; - S VP=VP+40 D SVP - W $C(27),"PC55;0065,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Refill - W $C(27),"PC56;0300,"_VP_",1,1,2,00,00",$C(10),$C(0) - ; - S VP=VP+40 D SVP - W $C(27),"PC57;0045,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Issue - W $C(27),"PC58;0300,"_VP_",1,1,2,00,00",$C(10),$C(0) ; Date # - ; - ;Diag Line Logo - S VP=VP+40 D SVP - W $C(27),"PC79;0065,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Diag - ; - S SL=79,VP=VP-40 ;Diag lines - F L=1:1:AFICDN D - .S SL=SL+1,VP=VP+40 - .D SVP - .W $C(27),"PC"_SL_";0300,"_VP_",1,1,2,00,00",$C(10),$C(0) - .S SL=SL+1 - .W $C(27),"PC"_SL_";0475,"_VP_",1,1,2,00,00",$C(10),$C(0) - ; - ;DOB Line - S SL=SL+1,VP=VP+40 D SVP - W $C(27),"PC"_SL_";0065,"_VP_",1,1,2,00,00",$C(10),$C(0) ;DOB: - S SL=SL+1 - W $C(27),"PC"_SL_";0300,"_VP_",1,1,2,00,00",$C(10),$C(0) ;DOB - ; - ;Comment Line Logo - I $G(PSOAFZZ)>0 D - .S SL=SL+1,VP=VP+40 D SVP - .W $C(27),"PC"_SL_";0008,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Comment Logo - ; - I $G(PSOAFZZ)>0 D - .S VP=VP-40 ;Comment lines - .F L=1:1:PSOAFZZ D - ..S SL=SL+1,VP=VP+$S(L=1:48,1:25) - ..D SVP - ..W $C(27),"PC"_SL_";0300,"_VP_",1,1,1,00,00",$C(10),$C(0) - ; - ;Signature lines start here - I $G(AFESYN)="Y" S VP=VP+130 D SVP G SIGNL - S VP=VP+130 D SVP - W $C(27),"PC59;0025,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Sig: - ; - S VP=VP+30 D SVP - W $C(27),"L04;0230,"_VP_",1000,"_VP_",0,2",$C(10),$C(0) ;Line - ; -SIGNL S VP=VP+10 D SVP - I $G(AFESYN)="Y" G SIGNL1 - W $C(27),"PC60;0240,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Prov Name -SIGNL1 W $C(27),"PC60;0025,"_VP_",1,1,2,00,00",$C(10),$C(0) ;ES Prov Name - ; - S VP=VP+110 D SVP - W $C(27),"PC61;0025,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Trail - ; - S VP=VP+90 D SVP - W $C(27),"PC62;0025,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Printed On: - W $C(27),"PC63;0320,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Printed On D/T - ; - ;Testing form length on Star - S PA=$S(VP>1501:1900,1:1500) - W $C(27),"D"_PA_"",$C(10),$C(0) ;Set print area - ; - W $C(27),"B",$C(10),$C(0) ;Enable cutter - ; - S OFF=$P(PS,"^",1) - S VFAX=OFF,VFAM=20 - D CENTER - S OFF=VFAX - W $C(27),"RC00;"_OFF_"",$C(10),$C(0) - ; - S OFFAD=$P(PS,"^",7)_","_STATE_" "_$G(PSOHZIP) - S VFAX=OFFAD,VFAM=49 - D CENTER - S OFFAD=VFAX - W $C(27),"RC01;"_OFFAD_"",$C(10),$C(0) - ; - S OFFTEL=$P(PS,"^",3)_"-"_$P(PS,"^",4) - S VFAX=OFFTEL,VFAM=49 - D CENTER - S OFFTEL=VFAX - W $C(27),"RC02;"_OFFTEL_"",$C(10),$C(0) - ; - S OFFFREE=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",4) - S VFAX=OFFFREE,VFAM=49 - D CENTER - S OFFFREE=VFAX - W $C(27),"RC70;"_OFFFREE_"",$C(10),$C(0) - ; - W $C(27),"RC03;Rx for:",$C(10),$C(0) - ; - D 6^VADPT,PID^VADPT - S PSOAFPTI=$S(DUZ("AG")="V":$E($G(VA("PID")),5,12),1:$G(VA("PID"))) - S AFPNAM=PNM_" "_$G(PSOAFPTI) - W $C(27),"RC04;"_AFPNAM_"",$C(10),$C(0) - ; - S AFPADD1=$G(VAPA(1)) - W $C(27),"RC05;"_AFPADD1_"",$C(10),$C(0) - ; - S AFPADD2=$G(ADDR(2)) - W $C(27),"RC06;"_AFPADD2_"",$C(10),$C(0) - ; - S AFPADD3=$G(ADDR(3)) - W $C(27),"RC07;"_AFPADD3_"",$C(10),$C(0) - ; - S AFPADD4=$G(ADDR(4)) - W $C(27),"RC08;"_AFPADD4_"",$C(10),$C(0) - ; - S AFDRUG=DRUG - W $C(27),"RC09;"_AFDRUG_"",$C(10),$C(0) - ; - S SYNFLAG=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",5) - I SYNFLAG="Y"&(AFSYN'="") D - .W $C(27),"RC72;Also known as:",$C(10),$C(0) ;L-72 - .W $C(27),"RC71;"_AFSYN_"",$C(10),$C(0) ;L-71 - ; - I $P($G(^PSRX(RX,"RXFIN")),"^",1)="Y" S VFASDD="Y" - I $G(VFASDD)="Y" D - .W $C(27),"RC10;Pharmacy may choose strength(s) of drug to meet requirements of directions",$C(10),$C(0) - ; - ; -SIG S SN=19 - F L=1:1:SIGL S SN=SN+1 W $C(27),"RC"_SN_";"_AFSIG(SN)_"",$C(10),$C(0) - ; - W $C(27),"RC50;Dispense:",$C(10),$C(0) - S AFDISP=$G(QTY)_" "_$G(PSDU) - W $C(27),"RC51;"_AFDISP_"",$C(10),$C(0) - ; - I $G(VFASDD)="Y" W $C(27),"RC52;Pharmacy to adjust qty for # of days",$C(10),$C(0) - ; - W $C(27),"RC53;Days Supply:",$C(10),$C(0) - S VFADAYS=$G(DAYS) - W $C(27),"RC54;"_VFADAYS_"",$C(10),$C(0) - ; - W $C(27),"RC55;Refill(s):",$C(10),$C(0) - S AFRF=$P(RXY,"^",9) - W $C(27),"RC56;"_AFRF_"",$C(10),$C(0) - ; - W $C(27),"RC57;Issue Date:",$C(10),$C(0) - W $C(27),"RC58;"_DATE_"",$C(10),$C(0) - ; -DIA S PSOAFDOB=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",8) - I PSOAFDOB="Y" D - .W $C(27),"RC79;Diagnosis:",$C(10),$C(0) - .S SN=79 - .F L=1:1:AFICDN S SN=SN+1 D - ..W $C(27),"RC"_SN_";"_AFICD9(L)_"",$C(10),$C(0) - ..S SN=SN+1 - ..W $C(27),"RC"_SN_";"_AFICD(L)_"",$C(10),$C(0) - I PSOAFDOB="" S SN=80+AFICDN - ; -DOB ;DOB - S PSOAFDIG=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",7) - I PSOAFDIG="Y" D - .S PSOAFDOB=$P($G(VADM(3)),"^",2),PSOAFDOL=" DOB:" - .S SN=SN+1 - .W $C(27),"RC"_SN_"; DOB:",$C(10),$C(0) - .S SN=SN+1 - .W $C(27),"RC"_SN_";"_PSOAFDOB_"",$C(10),$C(0) - I PSOAFDIG="" S SN=SN+2 - ; -COM ; - I $D(^UTILITY($J,"W")) D - .S SN=SN+1 - .W $C(27),"RC"_SN_"; MD Comments:",$C(10),$C(0) - .F ZZ=0:0:PSOAFZZ S ZZ=$O(^UTILITY($J,"W",DIWL,ZZ)) Q:'ZZ I $D(^(ZZ,0)) S PSOAFCOM=^(0),SN=SN+1 W $C(27),"RC"_SN_";"_PSOAFCOM_"",$C(10),$C(0) - K PSOZAFZZ,^UTILITY($J,"W") - ; - ;Signature Block -SIGN ;Prints DEA if it exists-if no DEA# prints VA# if it exists - I $G(AFESFLAG)="Y" D - .I $G(AFESYN)="Y" D - ..S AFDEA=$$GET1^DIQ(200,AFESIGN,53.2,"I") - ..I AFDEA="" D - ...S AFDEA=$$GET1^DIQ(200,AFESIGN,53.3,"I") - ..S AFESIGNN=$$GET1^DIQ(200,AFESIGN,.01,"I") - ..S AFSIGN=$G(AFESIGNN)_" "_AFDEA - ; -SIGN1 I $G(AFESFLAG)'="Y" D - .W $C(27),"RC59;Signature:",$C(10),$C(0) ;SCD - .;vfah prints DEA if it exists-if no DEA# prints VA# if it exists - .S AFDEA=$$GET1^DIQ(200,PSOAFPRV,53.2,"I") - .I AFDEA="" D - ..S AFDEA=$$GET1^DIQ(200,PSOAFPRV,53.3,"I") - .S AFSIGN=" "_$G(PHYS)_" "_AFDEA - ; -SIGNP I $G(AFESYN)="Y" S AFSIGN="Signed: /ES/"_AFSIGN - W $C(27),"RC60;"_AFSIGN_"",$C(10),$C(0) ;SCD - ; - K AFESYN,AFESIGN,AFESIGNN - ; - W $C(27),"RC61;Must write BRAND NECESSARY to dispense brand drug",$C(10),$C(0) ;SCD - ; - S AFPTIM=$S($D(REPRINT):"Re-Printed on:",1:"Printed on:") - W $C(27),"RC62;"_AFPTIM_"",$C(10),$C(0) ;SCD - D NOW^%DTC S Y=% X ^DD("DD") - S AFPRNDT=Y_" ("_RX_")" - W $C(27),"RC63;"_AFPRNDT_"",$C(10),$C(0) ;SCD - ; -WRITE W $C(27),"I",$C(10),$C(0) ;Print label - ; - K VFASDD - Q - ; -SVP S VP=$S($L(VP)=1:"000"_VP,$L(VP)=2:"00"_VP,$L(VP)=3:"0"_VP,1:VP) - Q - ; -CENTER ;Center header - S VFAS=(VFAM-$L(VFAX))\2 - F L=1:1:VFAS S VFAX=" "_VFAX +PSOAFPTS ;VFA/HMS autofinish print for star printer ;3/13/07 19:26 + ;;7.0;OUTPATIENT PHARMACY;**208**;DEC 1997;Build 39 + ; Copyright (C) GNU GPL 2007 WorldVistA + ; +PRNT ;PAGEMODE for Star Micronics + ; + U IO ;vfah fax + ; + F DR=1:1 Q:$G(SGY(DR))="" S SN=19+DR D + .S AFSIG(SN)=$G(SGY(DR)) + S SIGL=DR-1 + ; + S AFESFLAG=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",3) + S AFORD=$P(^PSRX(RX,"OR1"),"^",2) + I $G(AFESFLAG)="Y" D + .S AFES=$P($G(^OR(100,AFORD,8,1,0)),"^",4) + .I $G(AFES)=1 S AFESYN="Y" + .I $G(AFESYN)="Y" S AFESIGN=$P($G(^OR(100,AFORD,8,1,0)),"^",5) + ; + S AFWET2=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",6) + S AFDEA=$P(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),0),"^",3) + ; + I $G(AFWET2)="Y"&($G(AFDEA)["2") S AFESFLAG="" ;Turns off ES for Sch IIs if wet sig for IIs set in File#59 + I $G(AFWET2)="Y"&($G(AFDEA)["2") S AFESYN="" + ; + S AFS=0,DONE="N",AFSYN="" F L=1:1 S AFS=$O(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),1,AFS)) Q:AFS=""!(DONE="Y") D + .I $P(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),1,AFS,0),"^",3)="0" D + ..S AFSYN=$P($G(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),1,AFS,0)),"^",1),DONE="Y" + K DONE + ; +DIAG ; + S AFICD9(1)="None",AFICD(1)="Not Available",L=2 + I $D(^OR(100,AFORD,5.1,0)) D + .S AFORL=0 + .F L=1:1 S AFORL=$O(^OR(100,AFORD,5.1,AFORL)) Q:AFORL="B"!(AFORL=0)!(AFORL="") D + ..S AFORIN=$P($G(^OR(100,AFORD,5.1,AFORL,0)),"^",1) + ..I AFORIN>"" D + ...S AFICD9(L)=$P($G(^ICD9(AFORIN,0)),"^",1) + ...S AFICD(L)=$P($G(^ICD9(AFORIN,0)),"^",3) + S AFICDN=L-1 + ; +PRC ; + K ^UTILITY($J,"W") S PSNACNT=1,DIWL=0,DIWR=70,DIWF="",(PSSIXFL,PSSEVFL)=0 F ZZ=0:0 S ZZ=$O(^PSRX(RX,"PRC",ZZ)) Q:'ZZ I $D(^(ZZ,0)) S X=^(0) D ^DIWP + F ZZ=0:0 S ZZ=$O(^UTILITY($J,"W",DIWL,ZZ)) Q:'ZZ I $D(^(ZZ,0)) S PSOAFZZ=ZZ + ; + W $C(27),"C",$C(10),$C(0) ;Clear format + ; + W $C(27),"L00;0110,0030,0920,0030,0,6",$C(10),$C(0) ;T + W $C(27),"L01;0025,0100,0025,0230,1,6",$C(10),$C(0) ;L + W $C(27),"L02;1000,0100,1000,0238,1,6",$C(10),$C(0) ;R + W $C(27),"L03;0025,0230,1000,0230,0,6",$C(10),$C(0) ;B + W $C(27),"L10;0920,0030,0920,0100,1,6",$C(10),$C(0) ;R + W $C(27),"L11;0920,0100,1000,0100,0,6",$C(10),$C(0) ;B + W $C(27),"L12;0110,0030,0110,0102,1,6",$C(10),$C(0) ;R + W $C(27),"L13;0025,0100,0112,0100,0,6",$C(10),$C(0) ;B + ; + W $C(27),"L05;0025,0470,1000,0470,0,2",$C(10),$C(0) ;Div Line + ; + W $C(27),"PC00;0210,0055,1,1,4,00,00",$C(10),$C(0) ;Dr + W $C(27),"PC01;0025,0100,1,1,2,00,00",$C(10),$C(0) ;Dr + W $C(27),"PC02;0025,0145,1,1,2,00,00",$C(10),$C(0) ;Dr Phone + W $C(27),"PC70;0025,0190,1,1,2,00,00",$C(10),$C(0) ;Free line + ; + W $C(27),"PC03;0025,0285,1,1,1,00,03",$C(10),$C(0) ;Rx For + W $C(27),"PC04;0130,0280,1,1,2,00,00",$C(10),$C(0) ;Pat Name + W $C(27),"PC05;0130,0320,1,1,2,00,00",$C(10),$C(0) ;Pat Str1 + W $C(27),"PC06;0130,0360,1,1,2,00,00",$C(10),$C(0) ;Pat Str2 + W $C(27),"PC07;0130,0400,1,1,2,00,00",$C(10),$C(0) ;Pat Str3 + W $C(27),"PC08;0130,0440,1,1,2,00,00",$C(10),$C(0) ;Pat City + ; + S DHL=4 + S:$L(DRUG)>33 DHL=2 ;Reduce size for L>33 + W $C(27),"PC09;0025,0500,1,1,"_DHL_",00,00",$C(10),$C(0) ;Drug + ; + W $C(27),"PC72;0025,0558,1,1,1,00,03",$C(10),$C(0) ;AKA Notice + W $C(27),"PC71;0225,0550,1,1,2,00,00",$C(10),$C(0) ;Drug Syn + ; + W $C(27),"PC10;0025,0590,1,1,1,00,03",$C(10),$C(0) ;SDD Disclaimer + ; + S SL=19,VP=590 + F L=1:1:SIGL D + .S SL=SL+1,VP=VP+40 + .D SVP + .W $C(27),"PC"_SL_";0025,"_VP_",1,1,2,00,00",$C(10),$C(0) + ; + S VP=VP+60 D SVP + W $C(27),"PC50;0085,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Disp: + W $C(27),"PC51;0300,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Disp Num + ; + ;S VP=VP+40 D SVP + W $C(27),"PC52;0450,"_VP_",1,1,1,00,03",$C(10),$C(0) ;Disp Disclaimer + ; + S VP=VP+40 D SVP + W $C(27),"PC53;0025,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Days + W $C(27),"PC54;0300,"_VP_",1,1,2,00,00",$C(10),$C(0) ; Supply + ; + S VP=VP+40 D SVP + W $C(27),"PC55;0065,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Refill + W $C(27),"PC56;0300,"_VP_",1,1,2,00,00",$C(10),$C(0) + ; + S VP=VP+40 D SVP + W $C(27),"PC57;0045,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Issue + W $C(27),"PC58;0300,"_VP_",1,1,2,00,00",$C(10),$C(0) ; Date # + ; + ;Diag Line Logo + S VP=VP+40 D SVP + W $C(27),"PC79;0065,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Diag + ; + S SL=79,VP=VP-40 ;Diag lines + F L=1:1:AFICDN D + .S SL=SL+1,VP=VP+40 + .D SVP + .W $C(27),"PC"_SL_";0300,"_VP_",1,1,2,00,00",$C(10),$C(0) + .S SL=SL+1 + .W $C(27),"PC"_SL_";0475,"_VP_",1,1,2,00,00",$C(10),$C(0) + ; + ;DOB Line + S SL=SL+1,VP=VP+40 D SVP + W $C(27),"PC"_SL_";0065,"_VP_",1,1,2,00,00",$C(10),$C(0) ;DOB: + S SL=SL+1 + W $C(27),"PC"_SL_";0300,"_VP_",1,1,2,00,00",$C(10),$C(0) ;DOB + ; + ;Comment Line Logo + I $G(PSOAFZZ)>0 D + .S SL=SL+1,VP=VP+40 D SVP + .W $C(27),"PC"_SL_";0008,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Comment Logo + ; + I $G(PSOAFZZ)>0 D + .S VP=VP-40 ;Comment lines + .F L=1:1:PSOAFZZ D + ..S SL=SL+1,VP=VP+$S(L=1:48,1:25) + ..D SVP + ..W $C(27),"PC"_SL_";0300,"_VP_",1,1,1,00,00",$C(10),$C(0) + ; + ;Signature lines start here + I $G(AFESYN)="Y" S VP=VP+130 D SVP G SIGNL + S VP=VP+130 D SVP + W $C(27),"PC59;0025,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Sig: + ; + S VP=VP+30 D SVP + W $C(27),"L04;0230,"_VP_",1000,"_VP_",0,2",$C(10),$C(0) ;Line + ; +SIGNL S VP=VP+10 D SVP + I $G(AFESYN)="Y" G SIGNL1 + W $C(27),"PC60;0240,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Prov Name +SIGNL1 W $C(27),"PC60;0025,"_VP_",1,1,2,00,00",$C(10),$C(0) ;ES Prov Name + ; + S VP=VP+110 D SVP + W $C(27),"PC61;0025,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Trail + ; + S VP=VP+90 D SVP + W $C(27),"PC62;0025,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Printed On: + W $C(27),"PC63;0320,"_VP_",1,1,2,00,00",$C(10),$C(0) ;Printed On D/T + ; + ;Testing form length on Star + S PA=$S(VP>1501:1900,1:1500) + W $C(27),"D"_PA_"",$C(10),$C(0) ;Set print area + ; + W $C(27),"B",$C(10),$C(0) ;Enable cutter + ; + S OFF=$P(PS,"^",1) + S VFAX=OFF,VFAM=20 + D CENTER + S OFF=VFAX + W $C(27),"RC00;"_OFF_"",$C(10),$C(0) + ; + S OFFAD=$P(PS,"^",7)_","_STATE_" "_$G(PSOHZIP) + S VFAX=OFFAD,VFAM=49 + D CENTER + S OFFAD=VFAX + W $C(27),"RC01;"_OFFAD_"",$C(10),$C(0) + ; + S OFFTEL=$P(PS,"^",3)_"-"_$P(PS,"^",4) + S VFAX=OFFTEL,VFAM=49 + D CENTER + S OFFTEL=VFAX + W $C(27),"RC02;"_OFFTEL_"",$C(10),$C(0) + ; + S OFFFREE=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",4) + S VFAX=OFFFREE,VFAM=49 + D CENTER + S OFFFREE=VFAX + W $C(27),"RC70;"_OFFFREE_"",$C(10),$C(0) + ; + W $C(27),"RC03;Rx for:",$C(10),$C(0) + ; + D 6^VADPT,PID^VADPT + S PSOAFPTI=$S(DUZ("AG")="V":$E($G(VA("PID")),5,12),1:$G(VA("PID"))) + S AFPNAM=PNM_" "_$G(PSOAFPTI) + W $C(27),"RC04;"_AFPNAM_"",$C(10),$C(0) + ; + S AFPADD1=$G(VAPA(1)) + W $C(27),"RC05;"_AFPADD1_"",$C(10),$C(0) + ; + S AFPADD2=$G(ADDR(2)) + W $C(27),"RC06;"_AFPADD2_"",$C(10),$C(0) + ; + S AFPADD3=$G(ADDR(3)) + W $C(27),"RC07;"_AFPADD3_"",$C(10),$C(0) + ; + S AFPADD4=$G(ADDR(4)) + W $C(27),"RC08;"_AFPADD4_"",$C(10),$C(0) + ; + S AFDRUG=DRUG + W $C(27),"RC09;"_AFDRUG_"",$C(10),$C(0) + ; + S SYNFLAG=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",5) + I SYNFLAG="Y"&(AFSYN'="") D + .W $C(27),"RC72;Also known as:",$C(10),$C(0) ;L-72 + .W $C(27),"RC71;"_AFSYN_"",$C(10),$C(0) ;L-71 + ; + I $P($G(^PSRX(RX,"RXFIN")),"^",1)="Y" S VFASDD="Y" + I $G(VFASDD)="Y" D + .W $C(27),"RC10;Pharmacy may choose strength(s) of drug to meet requirements of directions",$C(10),$C(0) + ; + ; +SIG S SN=19 + F L=1:1:SIGL S SN=SN+1 W $C(27),"RC"_SN_";"_AFSIG(SN)_"",$C(10),$C(0) + ; + W $C(27),"RC50;Dispense:",$C(10),$C(0) + S AFDISP=$G(QTY)_" "_$G(PSDU) + W $C(27),"RC51;"_AFDISP_"",$C(10),$C(0) + ; + I $G(VFASDD)="Y" W $C(27),"RC52;Pharmacy to adjust qty for # of days",$C(10),$C(0) + ; + W $C(27),"RC53;Days Supply:",$C(10),$C(0) + S VFADAYS=$G(DAYS) + W $C(27),"RC54;"_VFADAYS_"",$C(10),$C(0) + ; + W $C(27),"RC55;Refill(s):",$C(10),$C(0) + S AFRF=$P(RXY,"^",9) + W $C(27),"RC56;"_AFRF_"",$C(10),$C(0) + ; + W $C(27),"RC57;Issue Date:",$C(10),$C(0) + W $C(27),"RC58;"_DATE_"",$C(10),$C(0) + ; +DIA S PSOAFDOB=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",8) + I PSOAFDOB="Y" D + .W $C(27),"RC79;Diagnosis:",$C(10),$C(0) + .S SN=79 + .F L=1:1:AFICDN S SN=SN+1 D + ..W $C(27),"RC"_SN_";"_AFICD9(L)_"",$C(10),$C(0) + ..S SN=SN+1 + ..W $C(27),"RC"_SN_";"_AFICD(L)_"",$C(10),$C(0) + I PSOAFDOB="" S SN=80+AFICDN + ; +DOB ;DOB + S PSOAFDIG=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",7) + I PSOAFDIG="Y" D + .S PSOAFDOB=$P($G(VADM(3)),"^",2),PSOAFDOL=" DOB:" + .S SN=SN+1 + .W $C(27),"RC"_SN_"; DOB:",$C(10),$C(0) + .S SN=SN+1 + .W $C(27),"RC"_SN_";"_PSOAFDOB_"",$C(10),$C(0) + I PSOAFDIG="" S SN=SN+2 + ; +COM ; + I $D(^UTILITY($J,"W")) D + .S SN=SN+1 + .W $C(27),"RC"_SN_"; MD Comments:",$C(10),$C(0) + .F ZZ=0:0:PSOAFZZ S ZZ=$O(^UTILITY($J,"W",DIWL,ZZ)) Q:'ZZ I $D(^(ZZ,0)) S PSOAFCOM=^(0),SN=SN+1 W $C(27),"RC"_SN_";"_PSOAFCOM_"",$C(10),$C(0) + K PSOZAFZZ,^UTILITY($J,"W") + ; + ;Signature Block +SIGN ;Prints DEA if it exists-if no DEA# prints VA# if it exists + I $G(AFESFLAG)="Y" D + .I $G(AFESYN)="Y" D + ..S AFDEA=$$GET1^DIQ(200,AFESIGN,53.2,"I") + ..I AFDEA="" D + ...S AFDEA=$$GET1^DIQ(200,AFESIGN,53.3,"I") + ..S AFESIGNN=$$GET1^DIQ(200,AFESIGN,.01,"I") + ..S AFSIGN=$G(AFESIGNN)_" "_AFDEA + ; +SIGN1 I $G(AFESFLAG)'="Y" D + .W $C(27),"RC59;Signature:",$C(10),$C(0) ;SCD + .;vfah prints DEA if it exists-if no DEA# prints VA# if it exists + .S AFDEA=$$GET1^DIQ(200,PSOAFPRV,53.2,"I") + .I AFDEA="" D + ..S AFDEA=$$GET1^DIQ(200,PSOAFPRV,53.3,"I") + .S AFSIGN=" "_$G(PHYS)_" "_AFDEA + ; +SIGNP I $G(AFESYN)="Y" S AFSIGN="Signed: /ES/"_AFSIGN + W $C(27),"RC60;"_AFSIGN_"",$C(10),$C(0) ;SCD + ; + K AFESYN,AFESIGN,AFESIGNN + ; + W $C(27),"RC61;Must write BRAND NECESSARY to dispense brand drug",$C(10),$C(0) ;SCD + ; + S AFPTIM=$S($D(REPRINT):"Re-Printed on:",1:"Printed on:") + W $C(27),"RC62;"_AFPTIM_"",$C(10),$C(0) ;SCD + D NOW^%DTC S Y=% X ^DD("DD") + S AFPRNDT=Y_" ("_RX_")" + W $C(27),"RC63;"_AFPRNDT_"",$C(10),$C(0) ;SCD + ; +WRITE W $C(27),"I",$C(10),$C(0) ;Print label + ; + K VFASDD + Q + ; +SVP S VP=$S($L(VP)=1:"000"_VP,$L(VP)=2:"00"_VP,$L(VP)=3:"0"_VP,1:VP) + Q + ; +CENTER ;Center header + S VFAS=(VFAM-$L(VFAX))\2 + F L=1:1:VFAS S VFAX=" "_VFAX diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOAFRP1.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOAFRP1.m index a01cf9ec..860c7124 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOAFRP1.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOAFRP1.m @@ -1,108 +1,108 @@ -PSOAFRP1 ;VFA/HMS autofinish rx speed reprint for listman ;1/30/07 19:48 - ;;7.0;OUTPATIENT PHARMACY;**208**;DEC 1997;Build 41 - ; 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 - ;'Modified' MAS Patient Look-up Check Cross-References June 1987 - ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789 -SEL N PSODISP,VALMCNT I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!" S VALMBCK="" Q - S PSOAFYN="Y" - S RXCNT=0 K PSOFDR,DIR,DUOUT,DIRUT S DIR("A")="Select Orders by number",DIR(0)="LO^1:"_PSOCNT D ^DIR S LST=Y I $D(DTOUT)!($D(DUOUT)) K DIR,DIRUT,DTOUT,DUOUT S VALMBCK="" Q - ; - ;F ORD=1:1:$L(LST,",") Q:$P(LST,",",ORD)']"" S ORN=$P(LST,",",ORD),QFLG=0 D:+PSOLST(ORN)=52 - ;.S PSORPSRX=$P(PSOLST(ORN),"^",2) - ; - K DIR,DIRUT,DTOUT,PSOOELSE,PSOREPX I +LST S PSOOELSE=1 D - .;D FULL^VALM1 K DIR S DIR("A")="Number of Copies? ",DIR(0)="N^1:99:0",DIR("?")="Enter the number of copies you want (1 TO 99)",DIR("B")=1 - .;D ^DIR K DIR S:$D(DIRUT) PSOREPX=1 Q:$D(DIRUT) S COPIES=Y - .S COPIES=1 - .;K DIR S DIR("A")="Print adhesive portion of label only? ",DIR(0)="Y",DIR("B")="No",DIR("?",1)="If entire label, including trailers are to print press RETURN for default." - .;S DIR("?")="Else if only bottle and mailing labels are to print enter Y or YES." D ^DIR K DIR S:$D(DIRUT) PSOREPX=1 Q:$D(DIRUT) S SIDE=Y - .S SIDE=0 - .I $P(PSOPAR,"^",30),$$GET1^DIQ(59,PSOSITE_",",105,"I")=2.4 D Q:$G(PSOREPX) - ..;K DIR,DIRUT S DIR("A")="Do you want to resend to Dispensing System Device",DIR(0)="Y",DIR("B")="No" - ..;D ^DIR K DIR S:$D(DIRUT) PSOREPX=1 Q:$D(DIRUT) S PSODISP=$S(Y:0,1:1) - ..S PSODISP=1 - .K DIRUT,DIR S DIR("A")="Comments(Required): ",DIR(0)="FA^5:60",DIR("?")="5-60 characters input required for activity log." S:$G(PCOMX)]"" DIR("B")=$G(PCOMX) - .D ^DIR K DIR S:$D(DIRUT) PSOREPX=1 Q:$D(DIRUT) S (PCOM,PCOMX)=Y - .S PSOCLC=DUZ - .F ORD=1:1:$L(LST,",") Q:$P(LST,",",ORD)']"" S ORN=$P(LST,",",ORD),QFLG=0 D:+PSOLST(ORN)=52 RX - .S VALMBCK="R" - I $G(PSOREPX) S VALMBCK="R",VALMSG="No Labels Reprinted." - K PSOREPX - I '$G(PSOOELSE) S VALMBCK="" - D ^PSOBUILD - K PSOMSG,PSORPSRX,QFLG,%,DIR,DUOUT,DTOUT,DIROUT,DIRUT,PCOM,PCOMX,C,I,J,JJJ,K,RX,RXF,X,Y,Z,P,PDA,PSPRXN,COPIES,SIDE,PPL,REPRINT,PSOOELSE,ORD,LST,ORN D KVA^VADPT - Q - ; -RX ;process reprint request - ; - S PSORPSRX=$P(PSOLST(ORN),"^",2) - ;S PSOZAF="" S PSOZAF=$O(^VA(200,"B","AUTOFINISH,RX",PSOZAF)) ;vfah - S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" - D ^DIC K DIC - S PSOZAF=+Y - I $P($G(^PSRX(PSORPSRX,"OR1")),"^",5)'=$G(PSOZAF) S VFANRP=1 ;vfah - I $G(VFANRP)=1 W $C(7),!,"Re-Print only available for Autofinished Rxs" D PAUSE^VALM1 K PSORPSRX,VFANRP Q - ;Q:$G(VFANRP)=1 - ; - Q:$P(^PSRX($P(PSOLST(ORN),"^",2),"STA"),"^")>11 - S PSORPSRX=$P(PSOLST(ORN),"^",2) D PSOL^PSSLOCK(PSORPSRX) I '$G(PSOMSG) W $C(7),!!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing Rx "_$P($G(^PSRX(PSORPSRX,0)),"^")),! D PAUSE^VALM1 K PSORPSRX,PSOMSG Q - S RX=$P(PSOLST(ORN),"^",2),STA=$P(^PSRX($P(PSOLST(ORN),"^",2),"STA"),"^") D CHK I $G(QFLG) D ULR Q - S RXF=0,ZD(RX)=DT,REPRINT=1 - S RXRP($P(PSOLST(ORN),"^",2))=1_"^"_COPIES_"^"_SIDE - I $G(PSODISP)=1 S RXRP($P(PSOLST(ORN),"^",2),"RP")=1 - S RXFL($P(PSOLST(ORN),"^",2))=0 F ZZZ=0:0 S ZZZ=$O(^PSRX($P(PSOLST(ORN),"^",2),1,ZZZ)) Q:'ZZZ S RXFL($P(PSOLST(ORN),"^",2))=ZZZ - K ZZZ - I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=RX_"," S ST="" D ACT1,ULR Q - F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1 S PSOX2=PSOX1 - I $L(PSORX("PSOL",PSOX2))+$L(RX)<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_RX_"," - E S PSORX("PSOL",PSOX2+1)=RX_"," - S ST="" D ACT1 - D ULR - Q -CHK ;check for valid reprint - I DT>$P(^PSRX(RX,2),"^",6) D S QFLG=1 Q - .I $P(^PSRX(RX,"STA"),"^")<11 S $P(^PSRX(RX,"STA"),"^")=11 D - ..S COMM="Medication Expired on "_$E($P(^PSRX(RX,2),6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) D EN^PSOHLSN1(RX,"SC","ZE",COMM) K COMM - S DFN=PSODFN D DEM^VADPT I $P(VADM(6),"^",2)]"" D S QFLG=1 Q - .S $P(^PSRX(RX,"STA"),"^")=12,PCOM="Patient Expired "_$P(VADM(6),"^",2),ST="C" D EN^PSOHLSN1(RX,"OD","",PCOM,"A") - .D ACT1 - I $D(RXPR($P(PSOLST(ORN),"^",2)))!$D(RXRP($P(PSOLST(ORN),"^",2))) S QFLG=1 Q - D VALID Q:$G(QFLG) - S X=$O(^PS(52.5,"B",RX,0)) I X,'$G(^PS(52.5,X,"P")) S QFLG=1 Q - I $G(X)'>0 G GOOD - I $P($G(^PS(52.5,X,0)),"^",7)']"" G GOOD - I $P($G(^PS(52.5,X,0)),"^",7)="Q" K X,XX S QFLG=1 Q - I $P($G(^PS(52.5,X,0)),"^",7)="L" K X,XX S QFLG=1 Q -GOOD K X - I $D(^PS(52.4,RX)) S QFLG=1 Q - I $D(^PS(52.4,"AREF",PSODFN,RX)) S QFLG=1 Q - I $G(PSODIV),$D(^PSRX(RX,2)),+$P(^(2),"^",9),+$P(^(2),"^",9)'=PSOSITE S PSPOP=0,PSPRXN=RX D CHK1^PSOUTLA I $G(POERR)&(PSPOP) S QFLG=1 Q - I STA=3!(STA=4)!(STA=12) S QFLG=1 Q - Q -ACT1 S RXF=0 F J=0:0 S J=$O(^PSRX(RX,1,J)) Q:'J S RXF=J S:J>5 RXF=J+1 - S IR=0 F J=0:0 S J=$O(^PSRX(RX,"A",J)) Q:'J S IR=J - S IR=IR+1,^PSRX(RX,"A",0)="^52.3DA^"_IR_"^"_IR - D NOW^%DTC S ^PSRX(RX,"A",IR,0)=%_"^"_$S($G(ST)'="C":"W",1:"C")_"^"_DUZ_"^"_RXF_"^"_PCOM_$S($G(ST)'="C":" ("_COPIES_" COPIES)",1:""),PCOMX=PCOM K PC,IR,PS,XX,%,%H,%I,RXF - S:$P(^PSRX(RX,2),"^",15)&($G(ST)'="C") $P(^PSRX(RX,2),"^",14)=1 - Q -VALID ;check for rx in label array - I $O(PSORX("PSOL",0)) D - .F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1 I PSORX("PSOL",PSOX1)[RX_"," S QFLG=1 Q - Q -ULR ; - I $G(PSORPSRX) D PSOUL^PSSLOCK(PSORPSRX) - Q +PSOAFRP1 ;VFA/HMS autofinish rx speed reprint for listman ;1/30/07 19:48 + ;;7.0;OUTPATIENT PHARMACY;**208**;DEC 1997;Build 39 + ; 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 + ;'Modified' MAS Patient Look-up Check Cross-References June 1987 + ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789 +SEL N PSODISP,VALMCNT I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!" S VALMBCK="" Q + S PSOAFYN="Y" + S RXCNT=0 K PSOFDR,DIR,DUOUT,DIRUT S DIR("A")="Select Orders by number",DIR(0)="LO^1:"_PSOCNT D ^DIR S LST=Y I $D(DTOUT)!($D(DUOUT)) K DIR,DIRUT,DTOUT,DUOUT S VALMBCK="" Q + ; + ;F ORD=1:1:$L(LST,",") Q:$P(LST,",",ORD)']"" S ORN=$P(LST,",",ORD),QFLG=0 D:+PSOLST(ORN)=52 + ;.S PSORPSRX=$P(PSOLST(ORN),"^",2) + ; + K DIR,DIRUT,DTOUT,PSOOELSE,PSOREPX I +LST S PSOOELSE=1 D + .;D FULL^VALM1 K DIR S DIR("A")="Number of Copies? ",DIR(0)="N^1:99:0",DIR("?")="Enter the number of copies you want (1 TO 99)",DIR("B")=1 + .;D ^DIR K DIR S:$D(DIRUT) PSOREPX=1 Q:$D(DIRUT) S COPIES=Y + .S COPIES=1 + .;K DIR S DIR("A")="Print adhesive portion of label only? ",DIR(0)="Y",DIR("B")="No",DIR("?",1)="If entire label, including trailers are to print press RETURN for default." + .;S DIR("?")="Else if only bottle and mailing labels are to print enter Y or YES." D ^DIR K DIR S:$D(DIRUT) PSOREPX=1 Q:$D(DIRUT) S SIDE=Y + .S SIDE=0 + .I $P(PSOPAR,"^",30),$$GET1^DIQ(59,PSOSITE_",",105,"I")=2.4 D Q:$G(PSOREPX) + ..;K DIR,DIRUT S DIR("A")="Do you want to resend to Dispensing System Device",DIR(0)="Y",DIR("B")="No" + ..;D ^DIR K DIR S:$D(DIRUT) PSOREPX=1 Q:$D(DIRUT) S PSODISP=$S(Y:0,1:1) + ..S PSODISP=1 + .K DIRUT,DIR S DIR("A")="Comments(Required): ",DIR(0)="FA^5:60",DIR("?")="5-60 characters input required for activity log." S:$G(PCOMX)]"" DIR("B")=$G(PCOMX) + .D ^DIR K DIR S:$D(DIRUT) PSOREPX=1 Q:$D(DIRUT) S (PCOM,PCOMX)=Y + .S PSOCLC=DUZ + .F ORD=1:1:$L(LST,",") Q:$P(LST,",",ORD)']"" S ORN=$P(LST,",",ORD),QFLG=0 D:+PSOLST(ORN)=52 RX + .S VALMBCK="R" + I $G(PSOREPX) S VALMBCK="R",VALMSG="No Labels Reprinted." + K PSOREPX + I '$G(PSOOELSE) S VALMBCK="" + D ^PSOBUILD + K PSOMSG,PSORPSRX,QFLG,%,DIR,DUOUT,DTOUT,DIROUT,DIRUT,PCOM,PCOMX,C,I,J,JJJ,K,RX,RXF,X,Y,Z,P,PDA,PSPRXN,COPIES,SIDE,PPL,REPRINT,PSOOELSE,ORD,LST,ORN D KVA^VADPT + Q + ; +RX ;process reprint request + ; + S PSORPSRX=$P(PSOLST(ORN),"^",2) + ;S PSOZAF="" S PSOZAF=$O(^VA(200,"B","AUTOFINISH,RX",PSOZAF)) ;vfah + S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" + D ^DIC K DIC + S PSOZAF=+Y + I $P($G(^PSRX(PSORPSRX,"OR1")),"^",5)'=$G(PSOZAF) S VFANRP=1 ;vfah + I $G(VFANRP)=1 W $C(7),!,"Re-Print only available for Autofinished Rxs" D PAUSE^VALM1 K PSORPSRX,VFANRP Q + ;Q:$G(VFANRP)=1 + ; + Q:$P(^PSRX($P(PSOLST(ORN),"^",2),"STA"),"^")>11 + S PSORPSRX=$P(PSOLST(ORN),"^",2) D PSOL^PSSLOCK(PSORPSRX) I '$G(PSOMSG) W $C(7),!!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing Rx "_$P($G(^PSRX(PSORPSRX,0)),"^")),! D PAUSE^VALM1 K PSORPSRX,PSOMSG Q + S RX=$P(PSOLST(ORN),"^",2),STA=$P(^PSRX($P(PSOLST(ORN),"^",2),"STA"),"^") D CHK I $G(QFLG) D ULR Q + S RXF=0,ZD(RX)=DT,REPRINT=1 + S RXRP($P(PSOLST(ORN),"^",2))=1_"^"_COPIES_"^"_SIDE + I $G(PSODISP)=1 S RXRP($P(PSOLST(ORN),"^",2),"RP")=1 + S RXFL($P(PSOLST(ORN),"^",2))=0 F ZZZ=0:0 S ZZZ=$O(^PSRX($P(PSOLST(ORN),"^",2),1,ZZZ)) Q:'ZZZ S RXFL($P(PSOLST(ORN),"^",2))=ZZZ + K ZZZ + I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=RX_"," S ST="" D ACT1,ULR Q + F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1 S PSOX2=PSOX1 + I $L(PSORX("PSOL",PSOX2))+$L(RX)<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_RX_"," + E S PSORX("PSOL",PSOX2+1)=RX_"," + S ST="" D ACT1 + D ULR + Q +CHK ;check for valid reprint + I DT>$P(^PSRX(RX,2),"^",6) D S QFLG=1 Q + .I $P(^PSRX(RX,"STA"),"^")<11 S $P(^PSRX(RX,"STA"),"^")=11 D + ..S COMM="Medication Expired on "_$E($P(^PSRX(RX,2),6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) D EN^PSOHLSN1(RX,"SC","ZE",COMM) K COMM + S DFN=PSODFN D DEM^VADPT I $P(VADM(6),"^",2)]"" D S QFLG=1 Q + .S $P(^PSRX(RX,"STA"),"^")=12,PCOM="Patient Expired "_$P(VADM(6),"^",2),ST="C" D EN^PSOHLSN1(RX,"OD","",PCOM,"A") + .D ACT1 + I $D(RXPR($P(PSOLST(ORN),"^",2)))!$D(RXRP($P(PSOLST(ORN),"^",2))) S QFLG=1 Q + D VALID Q:$G(QFLG) + S X=$O(^PS(52.5,"B",RX,0)) I X,'$G(^PS(52.5,X,"P")) S QFLG=1 Q + I $G(X)'>0 G GOOD + I $P($G(^PS(52.5,X,0)),"^",7)']"" G GOOD + I $P($G(^PS(52.5,X,0)),"^",7)="Q" K X,XX S QFLG=1 Q + I $P($G(^PS(52.5,X,0)),"^",7)="L" K X,XX S QFLG=1 Q +GOOD K X + I $D(^PS(52.4,RX)) S QFLG=1 Q + I $D(^PS(52.4,"AREF",PSODFN,RX)) S QFLG=1 Q + I $G(PSODIV),$D(^PSRX(RX,2)),+$P(^(2),"^",9),+$P(^(2),"^",9)'=PSOSITE S PSPOP=0,PSPRXN=RX D CHK1^PSOUTLA I $G(POERR)&(PSPOP) S QFLG=1 Q + I STA=3!(STA=4)!(STA=12) S QFLG=1 Q + Q +ACT1 S RXF=0 F J=0:0 S J=$O(^PSRX(RX,1,J)) Q:'J S RXF=J S:J>5 RXF=J+1 + S IR=0 F J=0:0 S J=$O(^PSRX(RX,"A",J)) Q:'J S IR=J + S IR=IR+1,^PSRX(RX,"A",0)="^52.3DA^"_IR_"^"_IR + D NOW^%DTC S ^PSRX(RX,"A",IR,0)=%_"^"_$S($G(ST)'="C":"W",1:"C")_"^"_DUZ_"^"_RXF_"^"_PCOM_$S($G(ST)'="C":" ("_COPIES_" COPIES)",1:""),PCOMX=PCOM K PC,IR,PS,XX,%,%H,%I,RXF + S:$P(^PSRX(RX,2),"^",15)&($G(ST)'="C") $P(^PSRX(RX,2),"^",14)=1 + Q +VALID ;check for rx in label array + I $O(PSORX("PSOL",0)) D + .F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1 I PSORX("PSOL",PSOX1)[RX_"," S QFLG=1 Q + Q +ULR ; + I $G(PSORPSRX) D PSOUL^PSSLOCK(PSORPSRX) + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOAFRPT.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOAFRPT.m index 822f4b17..7d0efb41 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOAFRPT.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOAFRPT.m @@ -1,112 +1,112 @@ -PSOAFRPT ;VFA/HMS autofinish reprint of a prescription label ;1/30/07 19:40 - ;;7.0;OUTPATIENT PHARMACY;**208**;DEC 1997;Build 41 - ; 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 - ;'Modified' MAS Patient Look-up Check Cross-References June 1987 - ;External reference to ^PSDRUG supported by DBIA 221 - ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789 -BCK I $G(PSOBEDT) W $C(7),$C(7) S VALMSG="Invalid Action at this time !",VALMBCK="" Q - S PSOAFYN="Y" - N PSODISP S PSORPLRX=$P(PSOLST(ORN),"^",2) - ; - ;S PSOZAF="" S PSOZAF=$O(^VA(200,"B","AUTOFINISH,RX",PSOZAF)) ;vfah - S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" - D ^DIC K DIC - S PSOZAF=+Y - I $P($G(^PSRX(PSORPLRX,"OR1")),"^",5)'=$G(PSOZAF) S VALMBCK="",VALMSG="Re-Print option is only available for Autofinshed Rxs",QFLG=1 D ULR,KILL K PSOZAF Q ;vfah - ; - D PSOL^PSSLOCK(PSORPLRX) I '$G(PSOMSG) S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG Q - I $G(POERR) K QFLG D I $G(QFLG) D ULR G KILL - .D FULL^VALM1 S X=$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^"),Y=$P(PSOLST(ORN),"^",2)_"^"_X,Y(0)=$G(^PSRX($P(PSOLST(ORN),"^",2),0)) - .I $D(RXPR($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Partial Rx has been requested!",QFLG=1 Q - .I $D(RXRP($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Reprint Label has been requested!",QFLG=1 Q - .I $D(RXRS($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="Rx is being pulled from suspense!",QFLG=1 Q - .S RX=$P(PSOLST(ORN),"^",2) D VALID^PSORXRP1 S:$G(QFLG) VALMBCK="",VALMSG="A New Label has been requested already!" - S (PPL,DA,RX)=+Y,PDA=Y(0),RXF=0,ZD(DA)=DT,REPRINT=1,STA=+$G(^PSRX(+Y,"STA")) - I $P(^PSRX(RX,"STA"),"^")=14 S VALMBCK="",VALMSG="Cannot Reprint! Discontinued by Provider.",QFLG=1 D ULR,KILL Q - I $P(^PSRX(RX,"STA"),"^")=15 S VALMBCK="",VALMSG="Cannot Reprint! Discontinued due to editing.",QFLG=1 D ULR,KILL Q - I $P(^PSRX(RX,"STA"),"^")=16 S VALMBCK="",VALMSG="Cannot Reprint! Placed on HOLD by Provider.",QFLG=1 D ULR,KILL Q - I DT>$P(^PSRX(RX,2),"^",6) D G PAUSE - .W !,$C(7),"Medication Expired on "_$E($P(^PSRX(RX,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) I $P(^PSRX(DA,"STA"),"^")<11 S $P(^PSRX(DA,"STA"),"^")=11 D - ..S COMM="Medication Expired on "_$E($P(^PSRX(RX,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) D EN^PSOHLSN1(DA,"SC","ZE",COMM) K COMM - S DFN=$P(PDA,"^",2) D DEM^VADPT I $P(VADM(6),"^",2)]"" D G PAUSE - .W $C(7),!!,$P(^DPT($P(PDA,"^",2),0),"^")_" Died "_$P(VADM(6),"^",2)_".",! - .S $P(^PSRX(RX,"STA"),"^")=12,PCOM="Patient Expired "_$P(VADM(6),"^",2),ST="C" D EN^PSOHLSN1(RX,"OD","",PCOM,"A") - .D ACT1,ULR,KILL - S X=$O(^PS(52.5,"B",DA,0)) I X,'$G(^PS(52.5,X,"P")) W !,$C(7),"RX MAY NOT BE PRINTED using this option, use SUSPENSE FUNCTIONS Options." K X G PAUSE - S PSX=0 F J=0:0 S J=$O(^PSRX(DA,1,J)) Q:'J S PSX=J - K X - I $D(^PS(52.4,DA)) W !,"Prescription is Non-Verified",!! G PAUSE - S DFN=$P(^PSRX(DA,0),"^",2) I $D(^PS(52.4,"AREF",DFN,DA)) W !,"Prescription is waiting for others to be verified",!! G PAUSE - I $G(PSODIV),$D(^PSRX(DA,2)),+$P(^(2),"^",9),+$P(^(2),"^",9)'=PSOSITE S PSPOP=0,PSPRXN=DA D CHK1^PSOUTLA G:$G(POERR)&(PSPOP) PAUSE G:PSPOP PAUSE - I STA=3 W !?3,"Prescription is on Hold" G PAUSE - I STA=4 W !?3,"Prescription is Pending Due to Drug Interactions" G PAUSE - I STA=12 W !?3,"Prescription is Discontinued" G PAUSE - S COPIES=1 - S SIDE=0 - S PSODISP=0 - I $D(DIRUT) D ULR G KILL - D ACT I $D(DIRUT) D ULR,KILL G PAUSE - Q:$G(POERR)&($D(PCOM)) G PAUSE:$D(PCOM) - F I=1,2,4,6,7,9,13,16 S P(I)=$P(PDA,"^",I) - S P(6)=+P(6) I $D(^PSRX(DA,"TN")),^("TN")]"" S P(6)=^("TN") - W !!,"Rx # "_P(1),?23,$E(P(13),4,5)_"/"_$E(P(13),6,7)_"/"_$E(P(13),2,3),!,$S($D(^DPT(+P(2),0)):$P(^(0),"^"),1:"Not on File"),?30,"#"_P(7),! - I $P($G(^PSRX(DA,"SIG")),"^",2) S D=0 D K D,FSIG - .D FSIG^PSOUTLA("R",DA,75) F S D=$O(FSIG(D)) W !,FSIG(D) Q:'$O(FSIG(D)) - E D EN3^PSOUTLA1(DA,75) S D=0 F S D=$O(BSIG(D)) W !,BSIG(D) Q:'$O(BSIG(D)) - K D,BSIG - ; - ;W !!,$S((P(6)=+P(6))&$D(^PSDRUG(P(6),0)):$P(^(0),"^"),1:P(6)),! S PHYS=$S($D(^VA(200,+P(4),0)):$P(^(0),"^"),1:"Unknown") W PHYS K PHYS - W !!,$S((P(6)=+P(6))&$D(^PSDRUG(P(6),0)):$P(^(0),"^"),1:P(6)),! - S PHYS=$$GET1^DIQ(200,+P(4),.01,"I") - I PHYS="" S PHYS="Unknown" - W PHYS K PHYS - ; - ;W ?25,$S($D(^VA(200,+P(16),0)):$P(^(0),"^"),1:"Unknown"),!,"# of Refills: "_$G(P(9)) - W ?25 - S PSOAFENT=$$GET1^DIQ(200,+P(16),.01,"I") - I PSOAFENT="" S PHYS="Unknown" - W PSOAFENT,!,"# of Refills: "_$G(P(9)) - ; - I $G(RX) S RXFL(RX)=0 F ZZZ=0:0 S ZZZ=$O(^PSRX(RX,1,ZZZ)) Q:'ZZZ S RXFL(RX)=ZZZ - K PSOELSE I '$G(POERR) S PSOELSE=1 D @$S($P($G(PSOPAR),"^",26):"^PSORXL",1:"Q^PSORXL") - I '$G(PSOELSE) D - .S RXRP($P(PSOLST(ORN),"^",2))=1_"^"_COPIES_"^"_SIDE - .I $G(PSODISP)=1 S RXRP($P(PSOLST(ORN),"^",2),"RP")=1 - .I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=DA_"," Q - .F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1 S PSOX2=PSOX1 - .I $L(PSORX("PSOL",PSOX2))+$L(DA)<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_DA_"," - .E S PSORX("PSOL",PSOX2+1)=DA_"," - K PCOMX,PSPOP,PPL,COPIES,SIDE,PCOM,IOP,PSL,PSNP,PSOELSE,ZZZ -PAUSE K RX,PPL,ZD(+$G(DA)),DA I $G(POERR) K DIR,DIRUT,DUOUT,DTOUT S DIR(0)="E",DIR("A",1)=" ",DIR("A")="Press Return to Continue" D ^DIR K DIR,DIRUT,DUOUT,DTOUT S VALMBCK="R" - D ULR K PSORPLRX - Q - ; -ACT K DIR S DIR("A")="Comments: ",DIR(0)="FA^5:60",DIR("?")="5-60 characters input required for activity log." S:$G(PCOMX)]"" DIR("B")=$G(PCOMX) - D ^DIR K DIR Q:$D(DIRUT)!($D(DIROUT)) S (PCOM,PCOMX)=X - I '$D(PSOCLC) S PSOCLC=DUZ -ACT1 S RXF=0 F J=0:0 S J=$O(^PSRX(DA,1,J)) Q:'J S RXF=J S:J>5 RXF=J+1 - S IR=0 F J=0:0 S J=$O(^PSRX(DA,"A",J)) Q:'J S IR=J - S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR - D NOW^%DTC S ^PSRX(DA,"A",IR,0)=%_"^"_$S($G(ST)'="C":"W",1:"C")_"^"_DUZ_"^"_RXF_"^"_PCOM_$S($G(ST)'="C":" ("_COPIES_" COPIES)",1:""),PCOMX=PCOM K PC,IR,PS,PCOM,XX,%,%H,%I,RXF - S:$P(^PSRX(DA,2),"^",15)&($G(ST)'="C") $P(^PSRX(DA,2),"^",14)=1 - Q - ; -KILL K QFLG,%,DIR,DUOUT,DTOUT,DIROUT,DIRUT,PCOM,PCOMX,C,DA,DIC,I,J,JJJ,K,RX,RXF,X,Y,Z,DFN,P,PDA,PSPRXN,COPIES,SIDE,PPL,REPRINT,PSOMSG,PSORPLRX D KVA^VADPT Q - ; -ULR ; - I $G(PSORPLRX) D PSOUL^PSSLOCK(PSORPLRX) - Q +PSOAFRPT ;VFA/HMS autofinish reprint of a prescription label ;1/30/07 19:40 + ;;7.0;OUTPATIENT PHARMACY;**208**;DEC 1997;Build 39 + ; 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 + ;'Modified' MAS Patient Look-up Check Cross-References June 1987 + ;External reference to ^PSDRUG supported by DBIA 221 + ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789 +BCK I $G(PSOBEDT) W $C(7),$C(7) S VALMSG="Invalid Action at this time !",VALMBCK="" Q + S PSOAFYN="Y" + N PSODISP S PSORPLRX=$P(PSOLST(ORN),"^",2) + ; + ;S PSOZAF="" S PSOZAF=$O(^VA(200,"B","AUTOFINISH,RX",PSOZAF)) ;vfah + S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" + D ^DIC K DIC + S PSOZAF=+Y + I $P($G(^PSRX(PSORPLRX,"OR1")),"^",5)'=$G(PSOZAF) S VALMBCK="",VALMSG="Re-Print option is only available for Autofinshed Rxs",QFLG=1 D ULR,KILL K PSOZAF Q ;vfah + ; + D PSOL^PSSLOCK(PSORPLRX) I '$G(PSOMSG) S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG Q + I $G(POERR) K QFLG D I $G(QFLG) D ULR G KILL + .D FULL^VALM1 S X=$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^"),Y=$P(PSOLST(ORN),"^",2)_"^"_X,Y(0)=$G(^PSRX($P(PSOLST(ORN),"^",2),0)) + .I $D(RXPR($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Partial Rx has been requested!",QFLG=1 Q + .I $D(RXRP($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Reprint Label has been requested!",QFLG=1 Q + .I $D(RXRS($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="Rx is being pulled from suspense!",QFLG=1 Q + .S RX=$P(PSOLST(ORN),"^",2) D VALID^PSORXRP1 S:$G(QFLG) VALMBCK="",VALMSG="A New Label has been requested already!" + S (PPL,DA,RX)=+Y,PDA=Y(0),RXF=0,ZD(DA)=DT,REPRINT=1,STA=+$G(^PSRX(+Y,"STA")) + I $P(^PSRX(RX,"STA"),"^")=14 S VALMBCK="",VALMSG="Cannot Reprint! Discontinued by Provider.",QFLG=1 D ULR,KILL Q + I $P(^PSRX(RX,"STA"),"^")=15 S VALMBCK="",VALMSG="Cannot Reprint! Discontinued due to editing.",QFLG=1 D ULR,KILL Q + I $P(^PSRX(RX,"STA"),"^")=16 S VALMBCK="",VALMSG="Cannot Reprint! Placed on HOLD by Provider.",QFLG=1 D ULR,KILL Q + I DT>$P(^PSRX(RX,2),"^",6) D G PAUSE + .W !,$C(7),"Medication Expired on "_$E($P(^PSRX(RX,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) I $P(^PSRX(DA,"STA"),"^")<11 S $P(^PSRX(DA,"STA"),"^")=11 D + ..S COMM="Medication Expired on "_$E($P(^PSRX(RX,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) D EN^PSOHLSN1(DA,"SC","ZE",COMM) K COMM + S DFN=$P(PDA,"^",2) D DEM^VADPT I $P(VADM(6),"^",2)]"" D G PAUSE + .W $C(7),!!,$P(^DPT($P(PDA,"^",2),0),"^")_" Died "_$P(VADM(6),"^",2)_".",! + .S $P(^PSRX(RX,"STA"),"^")=12,PCOM="Patient Expired "_$P(VADM(6),"^",2),ST="C" D EN^PSOHLSN1(RX,"OD","",PCOM,"A") + .D ACT1,ULR,KILL + S X=$O(^PS(52.5,"B",DA,0)) I X,'$G(^PS(52.5,X,"P")) W !,$C(7),"RX MAY NOT BE PRINTED using this option, use SUSPENSE FUNCTIONS Options." K X G PAUSE + S PSX=0 F J=0:0 S J=$O(^PSRX(DA,1,J)) Q:'J S PSX=J + K X + I $D(^PS(52.4,DA)) W !,"Prescription is Non-Verified",!! G PAUSE + S DFN=$P(^PSRX(DA,0),"^",2) I $D(^PS(52.4,"AREF",DFN,DA)) W !,"Prescription is waiting for others to be verified",!! G PAUSE + I $G(PSODIV),$D(^PSRX(DA,2)),+$P(^(2),"^",9),+$P(^(2),"^",9)'=PSOSITE S PSPOP=0,PSPRXN=DA D CHK1^PSOUTLA G:$G(POERR)&(PSPOP) PAUSE G:PSPOP PAUSE + I STA=3 W !?3,"Prescription is on Hold" G PAUSE + I STA=4 W !?3,"Prescription is Pending Due to Drug Interactions" G PAUSE + I STA=12 W !?3,"Prescription is Discontinued" G PAUSE + S COPIES=1 + S SIDE=0 + S PSODISP=0 + I $D(DIRUT) D ULR G KILL + D ACT I $D(DIRUT) D ULR,KILL G PAUSE + Q:$G(POERR)&($D(PCOM)) G PAUSE:$D(PCOM) + F I=1,2,4,6,7,9,13,16 S P(I)=$P(PDA,"^",I) + S P(6)=+P(6) I $D(^PSRX(DA,"TN")),^("TN")]"" S P(6)=^("TN") + W !!,"Rx # "_P(1),?23,$E(P(13),4,5)_"/"_$E(P(13),6,7)_"/"_$E(P(13),2,3),!,$S($D(^DPT(+P(2),0)):$P(^(0),"^"),1:"Not on File"),?30,"#"_P(7),! + I $P($G(^PSRX(DA,"SIG")),"^",2) S D=0 D K D,FSIG + .D FSIG^PSOUTLA("R",DA,75) F S D=$O(FSIG(D)) W !,FSIG(D) Q:'$O(FSIG(D)) + E D EN3^PSOUTLA1(DA,75) S D=0 F S D=$O(BSIG(D)) W !,BSIG(D) Q:'$O(BSIG(D)) + K D,BSIG + ; + ;W !!,$S((P(6)=+P(6))&$D(^PSDRUG(P(6),0)):$P(^(0),"^"),1:P(6)),! S PHYS=$S($D(^VA(200,+P(4),0)):$P(^(0),"^"),1:"Unknown") W PHYS K PHYS + W !!,$S((P(6)=+P(6))&$D(^PSDRUG(P(6),0)):$P(^(0),"^"),1:P(6)),! + S PHYS=$$GET1^DIQ(200,+P(4),.01,"I") + I PHYS="" S PHYS="Unknown" + W PHYS K PHYS + ; + ;W ?25,$S($D(^VA(200,+P(16),0)):$P(^(0),"^"),1:"Unknown"),!,"# of Refills: "_$G(P(9)) + W ?25 + S PSOAFENT=$$GET1^DIQ(200,+P(16),.01,"I") + I PSOAFENT="" S PHYS="Unknown" + W PSOAFENT,!,"# of Refills: "_$G(P(9)) + ; + I $G(RX) S RXFL(RX)=0 F ZZZ=0:0 S ZZZ=$O(^PSRX(RX,1,ZZZ)) Q:'ZZZ S RXFL(RX)=ZZZ + K PSOELSE I '$G(POERR) S PSOELSE=1 D @$S($P($G(PSOPAR),"^",26):"^PSORXL",1:"Q^PSORXL") + I '$G(PSOELSE) D + .S RXRP($P(PSOLST(ORN),"^",2))=1_"^"_COPIES_"^"_SIDE + .I $G(PSODISP)=1 S RXRP($P(PSOLST(ORN),"^",2),"RP")=1 + .I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=DA_"," Q + .F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1 S PSOX2=PSOX1 + .I $L(PSORX("PSOL",PSOX2))+$L(DA)<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_DA_"," + .E S PSORX("PSOL",PSOX2+1)=DA_"," + K PCOMX,PSPOP,PPL,COPIES,SIDE,PCOM,IOP,PSL,PSNP,PSOELSE,ZZZ +PAUSE K RX,PPL,ZD(+$G(DA)),DA I $G(POERR) K DIR,DIRUT,DUOUT,DTOUT S DIR(0)="E",DIR("A",1)=" ",DIR("A")="Press Return to Continue" D ^DIR K DIR,DIRUT,DUOUT,DTOUT S VALMBCK="R" + D ULR K PSORPLRX + Q + ; +ACT K DIR S DIR("A")="Comments: ",DIR(0)="FA^5:60",DIR("?")="5-60 characters input required for activity log." S:$G(PCOMX)]"" DIR("B")=$G(PCOMX) + D ^DIR K DIR Q:$D(DIRUT)!($D(DIROUT)) S (PCOM,PCOMX)=X + I '$D(PSOCLC) S PSOCLC=DUZ +ACT1 S RXF=0 F J=0:0 S J=$O(^PSRX(DA,1,J)) Q:'J S RXF=J S:J>5 RXF=J+1 + S IR=0 F J=0:0 S J=$O(^PSRX(DA,"A",J)) Q:'J S IR=J + S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR + D NOW^%DTC S ^PSRX(DA,"A",IR,0)=%_"^"_$S($G(ST)'="C":"W",1:"C")_"^"_DUZ_"^"_RXF_"^"_PCOM_$S($G(ST)'="C":" ("_COPIES_" COPIES)",1:""),PCOMX=PCOM K PC,IR,PS,PCOM,XX,%,%H,%I,RXF + S:$P(^PSRX(DA,2),"^",15)&($G(ST)'="C") $P(^PSRX(DA,2),"^",14)=1 + Q + ; +KILL K QFLG,%,DIR,DUOUT,DTOUT,DIROUT,DIRUT,PCOM,PCOMX,C,DA,DIC,I,J,JJJ,K,RX,RXF,X,Y,Z,DFN,P,PDA,PSPRXN,COPIES,SIDE,PPL,REPRINT,PSOMSG,PSORPLRX D KVA^VADPT Q + ; +ULR ; + I $G(PSORPLRX) D PSOUL^PSSLOCK(PSORPLRX) + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOAFSET.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOAFSET.m index 7542cfaa..73b3e81f 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOAFSET.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOAFSET.m @@ -1,80 +1,80 @@ -PSOAFSET ;VFA/HMS autofinish site parameter set up ;1/30/07 19:41 - ;;7.0;OUTPATIENT PHARMACY;**208**;DEC 1997;Build 41 - ; 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 - ;'Modified' MAS Patient Look-up Check Cross-References June 1987 -VERS ; - ;Is taken from PSOLSET ;vfah - ;Reference to ^PS(59.7 supported by DBIA 694 - ;Reference to ^PSX(550 supported by DBIA 2230 - ;Reference to ^%ZIS supported by DBIA 3435 - ; - ;Called by PSOORFIN if using AutoFinish,Rx - S PSOBAR1="",PSOBARS=0 ;make sure we have one - S PSOCNT=0 F I=0:0 S I=$O(^PS(59,I)) Q:'I S PSOCNT=PSOCNT+1,Y=I - S PSOPAR=$G(^PS(59,PSOSITE,1)),PSOPAR7=$G(^PS(59,PSOSITE,"IB")),PSOSYS=$G(^PS(59.7,1,40.1)) D CUTDATE^PSOFUNC ;HMS From DIV3 - S PSOPINST=$P($G(^PS(59,PSOSITE,"INI")),"^") - S (SITE,DA)=$P(^XMB(1,1,"XUS"),"^",17),DIC="4",DIQ(0)="IE",DR=".01;99",DIQ="PSXUTIL" D EN^DIQ1 S S3=$G(PSXUTIL(4,SITE,99,"I")),S2=$G(PSXUTIL(4,SITE,.01,"E")) K DA,DIC,DIQ(0),DR - S PSXSYS=+$O(^PSX(550,"C",""))_"^"_$G(S3)_"^"_$G(S2),PSOINST=S3 - K S3,S2,S1,PSXUTIL - I $G(PSXSYS) D - .K:($P($G(^PSX(550,+PSXSYS,0)),"^",2)'="A") PSXSYS - .S Y=$$VERSION^XPDUTL("PSO") I Y>6.0 S PSXVER=1 - E K PSXSYS - S PSODIV=$S(($P(PSOSYS,"^",2))&('$P(PSOSYS,"^",3)):0,1:1) - ; - ;I $D(DUZ),$D(^VA(200,+DUZ,0)) S PSOCLC=DUZ - I $D(DUZ) S DIC="^VA(200,",DIC(0)="NQEZ",X=DUZ - D ^DIC K DIC - I +Y S PSOCLC=DUZ - ; -PLBL Q ;HMS No printer selection PSOAFSET ends here -LBL S %ZIS="MNQ",%ZIS("A")="Select LABEL PRINTER: " S:$G(PSOCLBL)&($D(PSOLAP))!($G(SUSPT)) %ZIS("B")=$S($G(SUSPT):PSLION,1:PSOLAP) - D ^%ZIS K %ZIS,IO("Q"),IOP G:POP EXIT S @$S($G(SUSPT):"PSLION",1:"PSOLAP")=ION,PSOPIOST=$G(IOST(0)) - N PSOIOS S PSOIOS=IOS D DEVBAR^PSOBMST - S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$P(PSOPAR,"^",19),PSOIOS=IOS D ^%ZISC -LASK I $G(PSOPIOST),$D(^%ZIS(2,PSOPIOST,55,"B","LL")) G EXIT - K DIR S DIR("A")="OK to assume label alignment is correct",DIR("B")="YES",DIR(0)="Y",DIR("?")="Enter Y if labels are aligned, N if they need to be aligned." D ^DIR G:Y!($D(DIRUT)) EXIT -P2 S IOP=$G(PSOLAP) D ^%ZIS K IOP I POP W $C(7),!?5,"Printer is busy.",! G LASK - U IO(0) W !,"Align labels so that a perforation is at the top of the",!,"print head and the left side is at column zero." - W ! K DIR,DIRUT,DUOUT,DTOUT S DIR(0)="E" D ^DIR K DIR,DTOUT,DUOUT Q:$D(DIRUT) D ^PSOLBLT D ^%ZISC - K DIRUT,DIR S DIR("A")="Is this correct",DIR("B")="YES",DIR(0)="Y",DIR("?")="Enter Y if labels are aligned correctly, N if they need to be aligned." D ^DIR G:Y!($D(DIRUT)) EXIT - G P2 -LEAVE S XQUIT="" G FINAL -Q W !?10,$C(7),"Default printer for labels must be entered." G LBL - ; -EXIT D ^%ZISC Q:$G(PSOCLBL) - D:'$G(PSOBFLAG) GROUP K I,IOP,X,Y,%ZIS,DIC,J,DIR,X,Y,DTOUT,DIROUT,DIRUT,DUOUT Q - ; -FINAL ;exit action from main menu - kill and quit - K SITE,PSOCP,PSNP,PSL,PRCA,PSLION,PSOPINST - K GROUPCNT,DISGROUP,PSOCAP,PSOINST,PSOION,PSONULBL,PSOSITE7,PFIO,PSOIOS,X,Y,PSOSYS,PSODIV,PSOPAR,PSOPAR7,PSOLAP,PSOPROP,PSOCLC,PSOCNT - K PSODTCUT,PSOSITE,PSOPRPAS,PSOBAR1,PSOBAR0,PSOBARS,SIG,DIR,DIRUT,DTOUT,DIROUT,DUOUT,I,%ZIS,DIC,J,PSOREL - Q -GROUP ;display group - S GROUPCNT=0,AGROUP="" I $D(^PS(59.3,0)) F S AGROUP=$O(^PS(59.3,"B",AGROUP)) Q:AGROUP="" D - .S GROUPCNT=GROUPCNT+1 I GROUPCNT=1 S AGROUP1=AGROUP - S:GROUPCNT=1 GRPNME=AGROUP1,II="" G:GROUPCNT>1 GROUP1 - Q:'$D(GRPNME) F S II=$O(^PS(59.3,"B",GRPNME,II)) Q:II="" S DISGROUP=II - K AGROUP,AGROUP1,GRPNME,II - Q -GROUP1 W ! S DIC("A")="Bingo Board Display: ",DIC=59.3,DIC(0)="AEMQZ",DIR(0)="Y",DIR("?")="Enter 'Y' to select Bingo Board Display or 'N' to EXIT" - S:$P($G(^PS(59,PSOSITE,1)),"^",20) DIC("B")=$P($G(^PS(59,PSOSITE,1)),"^",20) - D ^DIC K DIC Q:$D(DTOUT)!($D(DUOUT)) - I +Y<0 W $C(7) S DIR("A",1)="A 'BINGO BOARD DISPLAY' should be selected!",DIR("A")="Do you want to try again",DIR("B")="YES",DIR("?")="A display group must be defined in order to run Bingo Board." D ^DIR Q:"Y"'[$E(X) G GROUP - S DISGROUP=+Y - K DIR,DIC,AGROUP,AGROUP1,GRPNME,II - Q +PSOAFSET ;VFA/HMS autofinish site parameter set up ;1/30/07 19:41 + ;;7.0;OUTPATIENT PHARMACY;**208**;DEC 1997;Build 39 + ; 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 + ;'Modified' MAS Patient Look-up Check Cross-References June 1987 +VERS ; + ;Is taken from PSOLSET ;vfah + ;Reference to ^PS(59.7 supported by DBIA 694 + ;Reference to ^PSX(550 supported by DBIA 2230 + ;Reference to ^%ZIS supported by DBIA 3435 + ; + ;Called by PSOORFIN if using AutoFinish,Rx + S PSOBAR1="",PSOBARS=0 ;make sure we have one + S PSOCNT=0 F I=0:0 S I=$O(^PS(59,I)) Q:'I S PSOCNT=PSOCNT+1,Y=I + S PSOPAR=$G(^PS(59,PSOSITE,1)),PSOPAR7=$G(^PS(59,PSOSITE,"IB")),PSOSYS=$G(^PS(59.7,1,40.1)) D CUTDATE^PSOFUNC ;HMS From DIV3 + S PSOPINST=$P($G(^PS(59,PSOSITE,"INI")),"^") + S (SITE,DA)=$P(^XMB(1,1,"XUS"),"^",17),DIC="4",DIQ(0)="IE",DR=".01;99",DIQ="PSXUTIL" D EN^DIQ1 S S3=$G(PSXUTIL(4,SITE,99,"I")),S2=$G(PSXUTIL(4,SITE,.01,"E")) K DA,DIC,DIQ(0),DR + S PSXSYS=+$O(^PSX(550,"C",""))_"^"_$G(S3)_"^"_$G(S2),PSOINST=S3 + K S3,S2,S1,PSXUTIL + I $G(PSXSYS) D + .K:($P($G(^PSX(550,+PSXSYS,0)),"^",2)'="A") PSXSYS + .S Y=$$VERSION^XPDUTL("PSO") I Y>6.0 S PSXVER=1 + E K PSXSYS + S PSODIV=$S(($P(PSOSYS,"^",2))&('$P(PSOSYS,"^",3)):0,1:1) + ; + ;I $D(DUZ),$D(^VA(200,+DUZ,0)) S PSOCLC=DUZ + I $D(DUZ) S DIC="^VA(200,",DIC(0)="NQEZ",X=DUZ + D ^DIC K DIC + I +Y S PSOCLC=DUZ + ; +PLBL Q ;HMS No printer selection PSOAFSET ends here +LBL S %ZIS="MNQ",%ZIS("A")="Select LABEL PRINTER: " S:$G(PSOCLBL)&($D(PSOLAP))!($G(SUSPT)) %ZIS("B")=$S($G(SUSPT):PSLION,1:PSOLAP) + D ^%ZIS K %ZIS,IO("Q"),IOP G:POP EXIT S @$S($G(SUSPT):"PSLION",1:"PSOLAP")=ION,PSOPIOST=$G(IOST(0)) + N PSOIOS S PSOIOS=IOS D DEVBAR^PSOBMST + S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$P(PSOPAR,"^",19),PSOIOS=IOS D ^%ZISC +LASK I $G(PSOPIOST),$D(^%ZIS(2,PSOPIOST,55,"B","LL")) G EXIT + K DIR S DIR("A")="OK to assume label alignment is correct",DIR("B")="YES",DIR(0)="Y",DIR("?")="Enter Y if labels are aligned, N if they need to be aligned." D ^DIR G:Y!($D(DIRUT)) EXIT +P2 S IOP=$G(PSOLAP) D ^%ZIS K IOP I POP W $C(7),!?5,"Printer is busy.",! G LASK + U IO(0) W !,"Align labels so that a perforation is at the top of the",!,"print head and the left side is at column zero." + W ! K DIR,DIRUT,DUOUT,DTOUT S DIR(0)="E" D ^DIR K DIR,DTOUT,DUOUT Q:$D(DIRUT) D ^PSOLBLT D ^%ZISC + K DIRUT,DIR S DIR("A")="Is this correct",DIR("B")="YES",DIR(0)="Y",DIR("?")="Enter Y if labels are aligned correctly, N if they need to be aligned." D ^DIR G:Y!($D(DIRUT)) EXIT + G P2 +LEAVE S XQUIT="" G FINAL +Q W !?10,$C(7),"Default printer for labels must be entered." G LBL + ; +EXIT D ^%ZISC Q:$G(PSOCLBL) + D:'$G(PSOBFLAG) GROUP K I,IOP,X,Y,%ZIS,DIC,J,DIR,X,Y,DTOUT,DIROUT,DIRUT,DUOUT Q + ; +FINAL ;exit action from main menu - kill and quit + K SITE,PSOCP,PSNP,PSL,PRCA,PSLION,PSOPINST + K GROUPCNT,DISGROUP,PSOCAP,PSOINST,PSOION,PSONULBL,PSOSITE7,PFIO,PSOIOS,X,Y,PSOSYS,PSODIV,PSOPAR,PSOPAR7,PSOLAP,PSOPROP,PSOCLC,PSOCNT + K PSODTCUT,PSOSITE,PSOPRPAS,PSOBAR1,PSOBAR0,PSOBARS,SIG,DIR,DIRUT,DTOUT,DIROUT,DUOUT,I,%ZIS,DIC,J,PSOREL + Q +GROUP ;display group + S GROUPCNT=0,AGROUP="" I $D(^PS(59.3,0)) F S AGROUP=$O(^PS(59.3,"B",AGROUP)) Q:AGROUP="" D + .S GROUPCNT=GROUPCNT+1 I GROUPCNT=1 S AGROUP1=AGROUP + S:GROUPCNT=1 GRPNME=AGROUP1,II="" G:GROUPCNT>1 GROUP1 + Q:'$D(GRPNME) F S II=$O(^PS(59.3,"B",GRPNME,II)) Q:II="" S DISGROUP=II + K AGROUP,AGROUP1,GRPNME,II + Q +GROUP1 W ! S DIC("A")="Bingo Board Display: ",DIC=59.3,DIC(0)="AEMQZ",DIR(0)="Y",DIR("?")="Enter 'Y' to select Bingo Board Display or 'N' to EXIT" + S:$P($G(^PS(59,PSOSITE,1)),"^",20) DIC("B")=$P($G(^PS(59,PSOSITE,1)),"^",20) + D ^DIC K DIC Q:$D(DTOUT)!($D(DUOUT)) + I +Y<0 W $C(7) S DIR("A",1)="A 'BINGO BOARD DISPLAY' should be selected!",DIR("A")="Do you want to try again",DIR("B")="YES",DIR("?")="A display group must be defined in order to run Bingo Board." D ^DIR Q:"Y"'[$E(X) G GROUP + S DISGROUP=+Y + K DIR,DIC,AGROUP,AGROUP1,GRPNME,II + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOBINGO.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOBINGO.m index 2e3c3ae5..16adf80d 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOBINGO.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOBINGO.m @@ -1,131 +1,125 @@ -PSOBINGO ;BHAM ISC/LC - BINGO BOARD OPTION DRIVER ;8/1/07 1:45pm - ;;7.0;OUTPATIENT PHARMACY;**12,28,56,125,152,232,268,275**;DEC 1997;Build 8 - ;External Ref. to ^PS(55 is supp. by DBIA# 2228 - ;External Ref. to ^PSDRUG(, is supp. by DBIA# 221 - ; - ;*232 add ATIC xref set/kill code here - ;*275 BA xref sometimes gets corrupted, kill bad BA xref and quit - ; - S (FLAG,FLAG1)=0,(TRIPS,JOES,ADV,DGP)="" G:'$G(PSOAP) END D:'$D(PSOPAR) ^PSOLSET G:'$D(PSOPAR) END -BEG ;PSOAP=1 NEW ENTRY; 2=DISPLAY; 3=REMOVE - D NOW^%DTC S TM=$E(%,1,12),TM1=$P(TM,".",2) G:PSOAP=1 NEW I PSOAP=3 D BCRMV^PSOBING1 G:'$D(X) END - I PSOAP=3 S DIC=52.11,DIC(0)="EMQZ",DIC("S")="I '$P($G(^PS(52.11,Y,0)),U,8)" D ^DIC K DIC G:+Y'>0 BEG G:($G(DTOUT))!($G(DUOUT)) END S DA=+Y,NAM=Y(0,0) - I PSOAP=2 W !! K DIC,DIE,DLAYGO S (DIC,DIE)=52.11,DIC(0)="AEMQZ",DIC("A")="Enter Patient Name to Display: ",DIC("S")="I $P($G(^PS(52.11,Y,0)),U,4)=PSOSITE&'$P($G(^PS(52.11,Y,0)),U,7)" - I PSOAP=2 D ^DIC K DIC G:+Y'>0!($G(DTOUT))!($G(DUOUT)) END S (DA,ODA)=+Y,NAM=Y(0,0) - I PSOAP=3 D STUF,REMOVE1 G BEG - I PSOAP=2,($P($G(^PS(52.11,DA,0)),"^",7)]"") W !!,NAM," is already in the display queue.",$C(7) G BEG - I PSOAP=2,$P($P($G(^PS(52.11,DA,0)),"^",5),".")'=DT S Y=$P($P($G(^PS(52.11,DA,0)),"^",5),".") D DD^%DT W !!,$C(7),NAM," was entered on "_Y_".",!,"It can't be displayed and is now deleted." S DIK="^PS(52.11," D ^DIK K DIK G BEG - I PSOAP=2&($P(^PS(52.11,ODA,0),"^",4)'=+PSOSITE) W !!,$C(7),NAM," was entered under the "_$P(^PS(59,$P(^(0),"^",4),0),"^")_" division." G BEG - I PSOAP=2 S PSODRF=0 D CREF^PSOBING1 G:PSODRF BEG D G BEG - .S NM=$P(^DPT($P(^PS(52.11,ODA,0),"^"),0),"^"),DR="6////"_$E(TM1_"0000",1,4)_";8////"_NM_"" - .D PASS,SETUP S DA=ODA D STATS1^PSOBRPRT,WTIME^PSOBING1 -NEW ;Init lookup - W !! K DIC S DIC=2,DIC(0)="AEMQZ",DIC("A")="Enter Patient Name : " D ^DIC K DIC G:Y<0!($G(DUOUT))!($G(DTOUT)) END S (DA,ADA,DFN)=+Y D DEM^VADPT Q:VAERR S NAM=VADM(1),SSN=$P(VADM(2),"^") - K DD,DO S:$D(DISGROUP) DGP=$P($G(^PS(59.3,DISGROUP,0)),"^") S (DIC,DIE)="^PS(52.11,",X=ADA,DIC("DR")=$S($G(GROUPCNT)=1&($G(DISGROUP)):"2////"_DISGROUP_"",1:"2//^S X=DGP") - S DIC(0)="LMNQZ",DLAYGO=59.3 D FILE^DICN K DD,DO,DIC G:Y'>0 NEW - S JOES=$P(Y(0),"^",3),ADV=$P($G(^PS(59.3,JOES,0)),"^",2),DA=+Y - I $G(DTOUT)!($G(DUOUT))!(X="") D WARN G NEW -TIC K TFLAG I ADV="T" S DIR(0)="NA^1:999999:0",DIR("A")="TICKET #:",DIR("?")="Ticket # must be numeric and unique" D ^DIR I $D(DUOUT)!($D(DTOUT))!($D(DIRUT)) D WARN G BEG - S TFLAG=1 I PSOAP=1,$G(ADV)="T" W !! S TIC=+Y D - .F TIEN=0:0 S TIEN=$O(^PS(52.11,"C",TIC,TIEN)) Q:'TIEN I DA'=TIEN,($G(PSOSITE)=+$P(^PS(52.11,TIEN,0),"^",4)) D - ..S TDFN=$P(^PS(52.11,TIEN,0),"^"),TSSN=$P(^PS(52.11,TIEN,1),"^",2),TFLAG=0 W !,$C(7),$P(^DPT(TDFN,0),"^")_" ("_TSSN_") was issued ticket # "_TIC,". Try again!",! - .K TDFN,TIEN,TSSN Q:'TFLAG - G:'TFLAG TIC I ADV="T" S DR="1////"_TIC_";3////"_PSOSITE_";4////"_TM_";5////"_$E(TM1_"0000",1,4)_";8////"_NAM_";9////"_SSN_";13////0",FLAG1=1 G PASS - S DR="3////"_PSOSITE_";4////"_TM_";5////"_$E(TM1_"0000",1,4)_";8////"_NAM_";9////"_SSN_";13////0" -PASS S NFLAG=1 L +^PS(52.11,DA):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) E W !!,$C(7),Y(0,0)," is being edited!",! Q - D ^DIE L -^PS(52.11,DA) I $G(DUOUT)!($G(DTOUT))!(X="") D WARN G BEG - S:$G(PSOAP)=1 FLGG=0 G:$G(PSOAP)'=1 STRX1 -STRX ;sto Rx #'s IN 52.11 - N BRXNUM,BBFTYP,BBFNUM,BBMW,MWDIR,II,FL,FLN,PR,PRN,PRNDT,FLNDT,Y -STRX0 S DIR(0)="FO^1:11",DIR("A")="Enter Rx #",DIR("?")="^D HELP^PSOBINGO",DIR("??")="^D HELP2^PSOBINGO" D ^DIR G:X=""&($G(FLGG)) STRX1 I $D(DIRUT) D WARN G BEG - S DIC=52,DIC(0)="EQM",DIC("S")="I $P($G(^PSRX(Y,0)),U,2)=ADA" D ^DIC K DIC I $D(DUOUT)!($D(DTOUT)) D WARN G BEG - G:Y=-1 STRX0 - I $G(Y)<0&('$G(FLGG)) D WARN G BEG - I $G(Y)<0&($G(FLGG)) G STRX1 - S BRXNUM=$P(Y,"^") - I $D(^PSRX(BRXNUM,1,0)) F II=0:0 S II=$O(^PSRX(BRXNUM,1,II)) Q:'II S FLN=II - I $D(FLN) S FLNDT=$P(^PSRX(BRXNUM,1,FLN,0),"^"),FL="F" - I $D(^PSRX(BRXNUM,"P",0)) F II=0:0 S II=$O(^PSRX(BRXNUM,"P",II)) Q:'II S PRN=II - I $D(PRN) S PRNDT=$P(^PSRX(BRXNUM,"P",PRN,0),"^"),PR="P" - S:$D(FLN)!($D(PRN)) BBFTYP=$S($G(PRNDT)>$G(FLNDT):PR,1:"F") - I $G(BBFTYP)="P" S BBFNUM=PRN,BBMW=$P(^PSRX(BRXNUM,"P",PRN,0),"^",2) - I $G(BBFTYP)="F" S BBFNUM=FLN,BBMW=$P(^PSRX(BRXNUM,1,FLN,0),"^",2) - I '$D(BBFTYP) S BBFTYP="F",BBFNUM=0,BBMW=$P(^PSRX(BRXNUM,0),"^",11) -MW ; - I $G(BBMW)="M" W !?5,$C(7),"Routing is set for Mail" D DIR - I $D(MWDIR) K BRXNUM,BBFTYP,BBFNUM,BBMW,MWDIR,II,FL,FLN,PR,PRN,PRNDT,FLNDT,Y G STRX - ; - S X=BRXNUM,DIC("DR")="1////"_BBFTYP_";2////"_BBFNUM_"",DLAYGO=52.11 - S DA(1)=DA,DIC="^PS(52.11,"_DA(1)_",2,",DIC(0)="L",DIC("P")=$P(^DD(52.11,12,0),"^",2) K DD,DO D FILE^DICN K Y,DD,DO,X,BRXNUM,BBFTYP,BBFNUM,II,FL,PR,PRNDT,FLNDT S FLGG=1 G STRX - ; -STRX1 D:PSOAP=1&($G(ADV)="N") CHKUP,NOTE G:'NFLAG BEG D STUF G:FLAG BEG Q:PSOAP=2 -SETUP S ZZZ=0 I '$D(^PS(59.2,DT,0)) K DD,DIC,DO,DA S X=DT,DIC="^PS(59.2,",DIC(0)="",DINUM=X,DLAYGO=59.2 D FILE^DICN K DD,DO S ZZZ=1 Q:Y'>0 - I ZZZ=1 K DD,DO S DLAYGO=59.2,DA(1)=+Y,DIC=DIC_DA(1)_",1,",(DINUM,X)=PSOSITE,DIC(0)="",DIC("P")=$P(^DD(59.2,1,0),"^",2) D FILE^DICN K DD,DO,DIC,DA Q:Y'>0 - Q:PSOAP=2&($P($G(^PS(59.2,DT,1,PSOSITE,0)),"^")) I ZZZ=0 K DD,DIC,DO,DA S DA(1)=DT,(DINUM,X)=PSOSITE,DIC="^PS(59.2,"_DT_",1,",DIC(0)="LZ",DLAYGO=59.2 D FILE^DICN K DD,DIC,DA,DO Q:PSOAP=2 G NEW - G BEG -STUF S RX0=^PS(52.11,DA,0),JOES=$P(RX0,"^",4),TICK=$P($G(RX0),"^",2) Q:PSOAP=3 G:ADV="T"&($G(FLAG1)=1)&('$G(TICK)) WARN G:'$G(JOES)!($G(NAM)']"") WARN - W:PSOAP=2 !!,"Patient added in display queue." W:PSOAP=1 !!,"Record is added." Q -WARN W !!!,$C(7),"Patient record incomplete!" S FLAG=1,DIK="^PS(52.11," D ^DIK G SHOW Q -REMOVE S DIK="^PS(52.11," D ^DIK -SHOW K DIK,DA,ADA W !!,"Record is removed." - Q -REMOVE1 ; - Q:'$D(^PS(52.11,"ANAM",$P(^PS(52.11,DA,0),"^",3),$P(^(1),"^",3)_$P(^(1),"^",4)_" "_$P(^DPT(+$P(^PS(52.11,DA,0),"^"),0),"^"),DA)) - N DIE,DR I $D(^PS(52.11,"ANAM",$P(^PS(52.11,DA,0),"^",3),$P(^(1),"^",3)_$P(^(1),"^",4)_" "_$P(^DPT(+$P(^PS(52.11,DA,0),"^"),0),"^"),DA)) S DIE="^PS(52.11,",DR="7////1" D - .D ^DIE - .K ^PS(52.11,"ANAM",$P(^PS(52.11,DA,0),"^",3),$P(^(1),"^",3)_$P(^(1),"^",4)_" "_$P(^DPT(+$P(^PS(52.11,DA,0),"^"),0),"^"),DA) - I $D(^PS(52.11,"ATIC",+$P(^PS(52.11,DA,0),"^",3),+$P(^(0),"^",2),DA)) S DIE="^PS(52.11,",DR="7////1" D - .D ^DIE - .K ^PS(52.11,"ATIC",+$P(^PS(52.11,DA,0),"^",3),+$P(^(0),"^",2),DA) - Q -CHKUP ;Multi & dupe names - S SDA=DA S:'$D(DFN) DFN=PSODFN G:$O(^PS(52.11,"B",DFN,0))=DA BROW F P=0:0 S P=$O(^PS(52.11,"B",DFN,P)) Q:'P!(P=DA) S LAST=P - Q:'$G(LAST) S TRIPS=$P($G(^PS(52.11,LAST,1)),"^",4) I TRIPS]"" S TRIPS=$A(TRIPS),TRIPS=TRIPS+1,TRIPS=$C(TRIPS) S DR="11////"_TRIPS_"" D ^DIE S F1=1 G BROW - K TRIPS -FIRST ;Set 1st dup - S DR="11////A" D ^DIE K DR,CNT -BROW S DA=SDA,NOPE=0,CNT=0 - F NIEN=0:0 S NIEN=$O(^PS(52.11,"BA",NAM,NIEN)) Q:'NIEN!(NIEN=$G(DA)) D Q:NOPE - . ;add check for bad xref and kill *275 - . I '$D(^PS(52.11,NIEN,0)) K ^PS(52.11,"BA",NAM,NIEN) Q - . D:$D(^PS(52.11,"BI")) BICK Q:CNT>0 - . D SETNEW - Q -SETNEW S SSN1=$O(^PS(52.11,"BA",NAM,NIEN,0)),ADFN=$P(^PS(52.11,NIEN,0),"^"),CNT=1 I SSN1=SSN S NOPE=1 Q - S DR="10////1" D ^DIE S F1=1 Q -BICK ;Chks "BI" Xref & assigns seq# - S SSN1=$O(^PS(52.11,"BA",NAM,NIEN,0)) I SSN1=SSN&('$P($G(^PS(52.11,SDA,1)),"^",3)) S NOPE=1 Q - S CNT=0 I $D(^PS(52.11,"BI",DFN)) S CNT=$O(^(DFN,0)),DA=SDA,DR="10////"_CNT_"" D ^DIE S F1=1 Q - F NDFN=0:0 S NDFN=$O(^PS(52.11,"BI",NDFN)) Q:'NDFN S CNT=$O(^(NDFN,0))+1 - S DR="10////"_CNT_"" D ^DIE S F1=1 Q -NOTE S DFN=$P($G(^PS(52.11,DA,0)),"^"),NFLAG=1 W !!,?5,"NAME",?30,"SSN",?45,"ID",?50,"ORDER" - F Z=0:0 S Z=$O(^PS(52.11,"B",DFN,Z)) Q:'Z S ZDA=Z S NODE=$G(^PS(52.11,ZDA,1)),Z1=$P(NODE,"^"),Z2=$P(NODE,"^",3),Z3=$P(NODE,"^",4),Z4=$P(NODE,"^",2) W:NODE'="" !,?5,Z1,?30,Z4,?46,Z2,?52,Z3 - W !! S DIR(0)="F,O",DIR("A")="Press return to add the last prescription or '^' to remove it." - S DIR("A",1)="Please advise the patient that the above ID # or ORDER Letter",DIR("A",2)="or both will be displayed with his/her name on the Bingo Display",DIR("A",3)=" " - D ^DIR K DIR K NODE,Z1,Z2,Z3 I $G(DTOUT)!(Y="^") S NFLAG=0 D REMOVE - Q -DIR K DIR,X,Y S DIR(0)="Y",DIR("A")="Continue ",DIR("B")="N",DIR("?")="Answer YES to continue, NO to bypass" - D ^DIR K DIR S:$D(DIRUT)!('Y) MWDIR=1 K DIRUT,DTOUT,DUOUT,X,Y - Q -HELP2 S (PA,PD)="",PL=0 F S PA=$O(^PS(55,ADA,"P","A",PA)) Q:'PA D:DT-115 N DIR S DIR(0)="E",DIR("A")="Press return to continue" D ^DIR K DIR S PL=0 - Q -HELP W !,"Enter the patient's Rx number.",! - Q -ATICSET ;Set ATIC xref PSO*232 - Q:'+$P(^PS(52.11,DA,0),"^",3) - Q:'+$P(^PS(52.11,DA,0),"^",2) - I $P(^PS(59.3,$P(^PS(52.11,DA,0),"^",3),0),"^",2)["T" D - .S ^PS(52.11,"ATIC",+$P(^PS(52.11,DA,0),"^",3),+$P(^(0),"^",2),DA)="" - Q -ATICKIL ;Kill ATIC xref PSO*232 - Q:'+$P(^PS(52.11,DA,0),"^",3) - Q:'+$P(^PS(52.11,DA,0),"^",2) - I $P(^PS(59.3,$P(^PS(52.11,DA,0),"^",3),0),"^",2)["T" D - .K ^PS(52.11,"ATIC",+$P(^PS(52.11,DA,0),"^",3),+$P(^(0),"^",2),DA) - Q - ; -END K %,ADA,ADFN,ADV,CNT,DA,DATE,DFN,DINUM,DLAYGO,DR,DTOUT,DUOUT,F1,FLAG,FLAG1,FLGG,JOES,LAST,NAM,NDFN,NIEN,NFLAG,NODE,NOPE,NM - K PSODRF,ODA,P,PSOAP,RX0,TM,TM1,SDA,SSN,SSN1,RX0,TIC,TICK,TFLAG,VADM,X,Y,Z,Z1,Z2,Z3,Z4,ZDA,ZZZ,PL,PD,PA - Q +PSOBINGO ;BHAM ISC/LC - BINGO BOARD OPTION DRIVER ;1/18/06 9:09am + ;;7.0;OUTPATIENT PHARMACY;**12,28,56,125,152,232,268**;DEC 1997;Build 9 + ;External Ref. to ^PS(55 is supp. by DBIA# 2228 + ;External Ref. to ^PSDRUG(, is supp. by DBIA# 221 + ; + ;PSO*7*232 add ATIC xref set/kill code here + ; + S (FLAG,FLAG1)=0,(TRIPS,JOES,ADV,DGP)="" G:'$G(PSOAP) END D:'$D(PSOPAR) ^PSOLSET G:'$D(PSOPAR) END +BEG ;PSOAP=1 NEW ENTRY; 2=DISPLAY; 3=REMOVE + D NOW^%DTC S TM=$E(%,1,12),TM1=$P(TM,".",2) G:PSOAP=1 NEW I PSOAP=3 D BCRMV^PSOBING1 G:'$D(X) END + I PSOAP=3 S DIC=52.11,DIC(0)="EMQZ",DIC("S")="I '$P($G(^PS(52.11,Y,0)),U,8)" D ^DIC K DIC G:+Y'>0 BEG G:($G(DTOUT))!($G(DUOUT)) END S DA=+Y,NAM=Y(0,0) + I PSOAP=2 W !! K DIC,DIE,DLAYGO S (DIC,DIE)=52.11,DIC(0)="AEMQZ",DIC("A")="Enter Patient Name to Display: ",DIC("S")="I $P($G(^PS(52.11,Y,0)),U,4)=PSOSITE&'$P($G(^PS(52.11,Y,0)),U,7)" + I PSOAP=2 D ^DIC K DIC G:+Y'>0!($G(DTOUT))!($G(DUOUT)) END S (DA,ODA)=+Y,NAM=Y(0,0) + I PSOAP=3 D STUF,REMOVE1 G BEG + I PSOAP=2,($P($G(^PS(52.11,DA,0)),"^",7)]"") W !!,NAM," is already in the display queue.",$C(7) G BEG + I PSOAP=2,$P($P($G(^PS(52.11,DA,0)),"^",5),".")'=DT S Y=$P($P($G(^PS(52.11,DA,0)),"^",5),".") D DD^%DT W !!,$C(7),NAM," was entered on "_Y_".",!,"It can't be displayed and is now deleted." S DIK="^PS(52.11," D ^DIK K DIK G BEG + I PSOAP=2&($P(^PS(52.11,ODA,0),"^",4)'=+PSOSITE) W !!,$C(7),NAM," was entered under the "_$P(^PS(59,$P(^(0),"^",4),0),"^")_" division." G BEG + I PSOAP=2 S PSODRF=0 D CREF^PSOBING1 G:PSODRF BEG D G BEG + .S NM=$P(^DPT($P(^PS(52.11,ODA,0),"^"),0),"^"),DR="6////"_$E(TM1_"0000",1,4)_";8////"_NM_"" + .D PASS,SETUP S DA=ODA D STATS1^PSOBRPRT,WTIME^PSOBING1 +NEW ;Init lookup + W !! K DIC S DIC=2,DIC(0)="AEMQZ",DIC("A")="Enter Patient Name : " D ^DIC K DIC G:Y<0!($G(DUOUT))!($G(DTOUT)) END S (DA,ADA,DFN)=+Y D DEM^VADPT Q:VAERR S NAM=VADM(1),SSN=$P(VADM(2),"^") + K DD,DO S:$D(DISGROUP) DGP=$P($G(^PS(59.3,DISGROUP,0)),"^") S (DIC,DIE)="^PS(52.11,",X=ADA,DIC("DR")=$S($G(GROUPCNT)=1&($G(DISGROUP)):"2////"_DISGROUP_"",1:"2//^S X=DGP") + S DIC(0)="LMNQZ",DLAYGO=59.3 D FILE^DICN K DD,DO,DIC G:Y'>0 NEW + S JOES=$P(Y(0),"^",3),ADV=$P($G(^PS(59.3,JOES,0)),"^",2),DA=+Y + I $G(DTOUT)!($G(DUOUT))!(X="") D WARN G NEW +TIC K TFLAG I ADV="T" S DIR(0)="NA^1:999999:0",DIR("A")="TICKET #:",DIR("?")="Ticket # must be numeric and unique" D ^DIR I $D(DUOUT)!($D(DTOUT))!($D(DIRUT)) D WARN G BEG + S TFLAG=1 I PSOAP=1,$G(ADV)="T" W !! S TIC=+Y D + .F TIEN=0:0 S TIEN=$O(^PS(52.11,"C",TIC,TIEN)) Q:'TIEN I DA'=TIEN,($G(PSOSITE)=+$P(^PS(52.11,TIEN,0),"^",4)) D + ..S TDFN=$P(^PS(52.11,TIEN,0),"^"),TSSN=$P(^PS(52.11,TIEN,1),"^",2),TFLAG=0 W !,$C(7),$P(^DPT(TDFN,0),"^")_" ("_TSSN_") was issued ticket # "_TIC,". Try again!",! + .K TDFN,TIEN,TSSN Q:'TFLAG + G:'TFLAG TIC I ADV="T" S DR="1////"_TIC_";3////"_PSOSITE_";4////"_TM_";5////"_$E(TM1_"0000",1,4)_";8////"_NAM_";9////"_SSN_";13////0",FLAG1=1 G PASS + S DR="3////"_PSOSITE_";4////"_TM_";5////"_$E(TM1_"0000",1,4)_";8////"_NAM_";9////"_SSN_";13////0" +PASS S NFLAG=1 L +^PS(52.11,DA):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) E W !!,$C(7),Y(0,0)," is being edited!",! Q + D ^DIE L -^PS(52.11,DA) I $G(DUOUT)!($G(DTOUT))!(X="") D WARN G BEG + S:$G(PSOAP)=1 FLGG=0 G:$G(PSOAP)'=1 STRX1 +STRX ;sto Rx #'s IN 52.11 + N BRXNUM,BBFTYP,BBFNUM,BBMW,MWDIR,II,FL,FLN,PR,PRN,PRNDT,FLNDT,Y +STRX0 S DIR(0)="FO^1:11",DIR("A")="Enter Rx #",DIR("?")="^D HELP^PSOBINGO",DIR("??")="^D HELP2^PSOBINGO" D ^DIR G:X=""&($G(FLGG)) STRX1 I $D(DIRUT) D WARN G BEG + S DIC=52,DIC(0)="EQM",DIC("S")="I $P($G(^PSRX(Y,0)),U,2)=ADA" D ^DIC K DIC I $D(DUOUT)!($D(DTOUT)) D WARN G BEG + G:Y=-1 STRX0 + I $G(Y)<0&('$G(FLGG)) D WARN G BEG + I $G(Y)<0&($G(FLGG)) G STRX1 + S BRXNUM=$P(Y,"^") + I $D(^PSRX(BRXNUM,1,0)) F II=0:0 S II=$O(^PSRX(BRXNUM,1,II)) Q:'II S FLN=II + I $D(FLN) S FLNDT=$P(^PSRX(BRXNUM,1,FLN,0),"^"),FL="F" + I $D(^PSRX(BRXNUM,"P",0)) F II=0:0 S II=$O(^PSRX(BRXNUM,"P",II)) Q:'II S PRN=II + I $D(PRN) S PRNDT=$P(^PSRX(BRXNUM,"P",PRN,0),"^"),PR="P" + S:$D(FLN)!($D(PRN)) BBFTYP=$S($G(PRNDT)>$G(FLNDT):PR,1:"F") + I $G(BBFTYP)="P" S BBFNUM=PRN,BBMW=$P(^PSRX(BRXNUM,"P",PRN,0),"^",2) + I $G(BBFTYP)="F" S BBFNUM=FLN,BBMW=$P(^PSRX(BRXNUM,1,FLN,0),"^",2) + I '$D(BBFTYP) S BBFTYP="F",BBFNUM=0,BBMW=$P(^PSRX(BRXNUM,0),"^",11) +MW ; + I $G(BBMW)="M" W !?5,$C(7),"Routing is set for Mail" D DIR + I $D(MWDIR) K BRXNUM,BBFTYP,BBFNUM,BBMW,MWDIR,II,FL,FLN,PR,PRN,PRNDT,FLNDT,Y G STRX + ; + S X=BRXNUM,DIC("DR")="1////"_BBFTYP_";2////"_BBFNUM_"",DLAYGO=52.11 + S DA(1)=DA,DIC="^PS(52.11,"_DA(1)_",2,",DIC(0)="L",DIC("P")=$P(^DD(52.11,12,0),"^",2) K DD,DO D FILE^DICN K Y,DD,DO,X,BRXNUM,BBFTYP,BBFNUM,II,FL,PR,PRNDT,FLNDT S FLGG=1 G STRX + ; +STRX1 D:PSOAP=1&($G(ADV)="N") CHKUP,NOTE G:'NFLAG BEG D STUF G:FLAG BEG Q:PSOAP=2 +SETUP S ZZZ=0 I '$D(^PS(59.2,DT,0)) K DD,DIC,DO,DA S X=DT,DIC="^PS(59.2,",DIC(0)="",DINUM=X,DLAYGO=59.2 D FILE^DICN K DD,DO S ZZZ=1 Q:Y'>0 + I ZZZ=1 K DD,DO S DLAYGO=59.2,DA(1)=+Y,DIC=DIC_DA(1)_",1,",(DINUM,X)=PSOSITE,DIC(0)="",DIC("P")=$P(^DD(59.2,1,0),"^",2) D FILE^DICN K DD,DO,DIC,DA Q:Y'>0 + Q:PSOAP=2&($P($G(^PS(59.2,DT,1,PSOSITE,0)),"^")) I ZZZ=0 K DD,DIC,DO,DA S DA(1)=DT,(DINUM,X)=PSOSITE,DIC="^PS(59.2,"_DT_",1,",DIC(0)="LZ",DLAYGO=59.2 D FILE^DICN K DD,DIC,DA,DO Q:PSOAP=2 G NEW + G BEG +STUF S RX0=^PS(52.11,DA,0),JOES=$P(RX0,"^",4),TICK=$P($G(RX0),"^",2) Q:PSOAP=3 G:ADV="T"&($G(FLAG1)=1)&('$G(TICK)) WARN G:'$G(JOES)!($G(NAM)']"") WARN + W:PSOAP=2 !!,"Patient added in display queue." W:PSOAP=1 !!,"Record is added." Q +WARN W !!!,$C(7),"Patient record incomplete!" S FLAG=1,DIK="^PS(52.11," D ^DIK G SHOW Q +REMOVE S DIK="^PS(52.11," D ^DIK +SHOW K DIK,DA,ADA W !!,"Record is removed." + Q +REMOVE1 ; + Q:'$D(^PS(52.11,"ANAM",$P(^PS(52.11,DA,0),"^",3),$P(^(1),"^",3)_$P(^(1),"^",4)_" "_$P(^DPT(+$P(^PS(52.11,DA,0),"^"),0),"^"),DA)) + N DIE,DR I $D(^PS(52.11,"ANAM",$P(^PS(52.11,DA,0),"^",3),$P(^(1),"^",3)_$P(^(1),"^",4)_" "_$P(^DPT(+$P(^PS(52.11,DA,0),"^"),0),"^"),DA)) S DIE="^PS(52.11,",DR="7////1" D + .D ^DIE + .K ^PS(52.11,"ANAM",$P(^PS(52.11,DA,0),"^",3),$P(^(1),"^",3)_$P(^(1),"^",4)_" "_$P(^DPT(+$P(^PS(52.11,DA,0),"^"),0),"^"),DA) + I $D(^PS(52.11,"ATIC",+$P(^PS(52.11,DA,0),"^",3),+$P(^(0),"^",2),DA)) S DIE="^PS(52.11,",DR="7////1" D + .D ^DIE + .K ^PS(52.11,"ATIC",+$P(^PS(52.11,DA,0),"^",3),+$P(^(0),"^",2),DA) + Q +CHKUP ;Multi & dupe names + S SDA=DA S:'$D(DFN) DFN=PSODFN G:$O(^PS(52.11,"B",DFN,0))=DA BROW F P=0:0 S P=$O(^PS(52.11,"B",DFN,P)) Q:'P!(P=DA) S LAST=P + Q:'$G(LAST) S TRIPS=$P($G(^PS(52.11,LAST,1)),"^",4) I TRIPS]"" S TRIPS=$A(TRIPS),TRIPS=TRIPS+1,TRIPS=$C(TRIPS) S DR="11////"_TRIPS_"" D ^DIE S F1=1 G BROW + K TRIPS +FIRST ;Set 1st dup + S DR="11////A" D ^DIE K DR,CNT +BROW S DA=SDA,NOPE=0,CNT=0 F NIEN=0:0 S NIEN=$O(^PS(52.11,"BA",NAM,NIEN)) Q:'NIEN!(NIEN=$G(DA)) D:$D(^PS(52.11,"BI")) BICK Q:CNT>0 D SETNEW Q:NOPE + Q +SETNEW S SSN1=$O(^PS(52.11,"BA",NAM,NIEN,0)),ADFN=$P(^PS(52.11,NIEN,0),"^"),CNT=1 I SSN1=SSN S NOPE=1 Q + S DR="10////1" D ^DIE S F1=1 Q +BICK ;Chks "BI" Xref & assigns seq# + S SSN1=$O(^PS(52.11,"BA",NAM,NIEN,0)) I SSN1=SSN&('$P($G(^PS(52.11,SDA,1)),"^",3)) S NOPE=1 Q + S CNT=0 I $D(^PS(52.11,"BI",DFN)) S CNT=$O(^(DFN,0)),DA=SDA,DR="10////"_CNT_"" D ^DIE S F1=1 Q + F NDFN=0:0 S NDFN=$O(^PS(52.11,"BI",NDFN)) Q:'NDFN S CNT=$O(^(NDFN,0))+1 + S DR="10////"_CNT_"" D ^DIE S F1=1 Q +NOTE S DFN=$P($G(^PS(52.11,DA,0)),"^"),NFLAG=1 W !!,?5,"NAME",?30,"SSN",?45,"ID",?50,"ORDER" + F Z=0:0 S Z=$O(^PS(52.11,"B",DFN,Z)) Q:'Z S ZDA=Z S NODE=$G(^PS(52.11,ZDA,1)),Z1=$P(NODE,"^"),Z2=$P(NODE,"^",3),Z3=$P(NODE,"^",4),Z4=$P(NODE,"^",2) W:NODE'="" !,?5,Z1,?30,Z4,?46,Z2,?52,Z3 + W !! S DIR(0)="F,O",DIR("A")="Press return to add the last prescription or '^' to remove it." + S DIR("A",1)="Please advise the patient that the above ID # or ORDER Letter",DIR("A",2)="or both will be displayed with his/her name on the Bingo Display",DIR("A",3)=" " + D ^DIR K DIR K NODE,Z1,Z2,Z3 I $G(DTOUT)!(Y="^") S NFLAG=0 D REMOVE + Q +DIR K DIR,X,Y S DIR(0)="Y",DIR("A")="Continue ",DIR("B")="N",DIR("?")="Answer YES to continue, NO to bypass" + D ^DIR K DIR S:$D(DIRUT)!('Y) MWDIR=1 K DIRUT,DTOUT,DUOUT,X,Y + Q +HELP2 S (PA,PD)="",PL=0 F S PA=$O(^PS(55,ADA,"P","A",PA)) Q:'PA D:DT-115 N DIR S DIR(0)="E",DIR("A")="Press return to continue" D ^DIR K DIR S PL=0 + Q +HELP W !,"Enter the patient's Rx number.",! + Q +ATICSET ;Set ATIC xref PSO*232 + Q:'+$P(^PS(52.11,DA,0),"^",3) + Q:'+$P(^PS(52.11,DA,0),"^",2) + I $P(^PS(59.3,$P(^PS(52.11,DA,0),"^",3),0),"^",2)["T" D + .S ^PS(52.11,"ATIC",+$P(^PS(52.11,DA,0),"^",3),+$P(^(0),"^",2),DA)="" + Q +ATICKIL ;Kill ATIC xref PSO*232 + Q:'+$P(^PS(52.11,DA,0),"^",3) + Q:'+$P(^PS(52.11,DA,0),"^",2) + I $P(^PS(59.3,$P(^PS(52.11,DA,0),"^",3),0),"^",2)["T" D + .K ^PS(52.11,"ATIC",+$P(^PS(52.11,DA,0),"^",3),+$P(^(0),"^",2),DA) + Q + ; +END K %,ADA,ADFN,ADV,CNT,DA,DATE,DFN,DINUM,DLAYGO,DR,DTOUT,DUOUT,F1,FLAG,FLAG1,FLGG,JOES,LAST,NAM,NDFN,NIEN,NFLAG,NODE,NOPE,NM + K PSODRF,ODA,P,PSOAP,RX0,TM,TM1,SDA,SSN,SSN1,RX0,TIC,TICK,TFLAG,VADM,X,Y,Z,Z1,Z2,Z3,Z4,ZDA,ZZZ,PL,PD,PA + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOBPSU1.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOBPSU1.m index f6dc3294..5e9b3855 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOBPSU1.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOBPSU1.m @@ -1,207 +1,205 @@ -PSOBPSU1 ;BIRM/MFR - BPS (ECME) Utilities 1 ;10/15/04 - ;;7.0;OUTPATIENT PHARMACY;**148,260,281**;DEC 1997;Build 41 - ;Reference to $$EN^BPSNCPDP supported by IA 4415 - ;References to $$NDCFMT^PSSNDCUT,$$GETNDC^PSSNDCUT supported by IA 4707 - ;References to $$ECMEON^BPSUTIL,$$CMOPON^BPSUTIL supported by IA 4410 - ;References to STORESP^IBNCPDP supported by IA 4299 - ; -ECMESND(RX,RFL,DATE,FROM,NDC,CMOP,RVTX,OVRC,CNDC,RESP,IGSW,ALTX,CLA,PA) ; - Sends Rx Release information to ECME/IB and - ; updates NDC in the DRUG/PRESCRIPTION files - ;Reference to routine EN^BPSNCPDP supported by DBIA #4304 - ;Input: (r) RX - Rx IEN (#52) - ; (o) RFL - Refill # (Default: most recent) - ; (r) DATE - Date of Service - ; (r) FROM - Function within OP (See BWHERE param. in EN^BPSNCPDP api) - ; (o) NDC - NDC Number (If not passed, will be retrieved from DRUG file) - ; (o) CMOP - CMOP Prescription (1-YES/0-NO) (Default: 0) - ; (o) RVTX - REVERSE text (e.g., RX EDIT, RX RELEASE-NDC CHANGE, etc) - ; (o) OVRC - Set of 3 NCPDP override codes separated by "^": - ; Piece 1: NCPDP Professional Service Code for overriding DUR REJECTS - ; Piece 2: NCPDP Reason for Service Code for overriding DUR REJECTS - ; Piece 3: NCPDP Result of Service Code for overriding DUR REJECTS - ; (o) CNDC - Changed NDC? 1 - Yes / 0 - No (Default: NO) - ; (o) IGSW - Ignore Switches (Master and CMOP)? 1 - Yes / 0 - No (Default: NO) - ; (o) ALTX - Alternative Text to be placed in the Rx ECME Activity Log - ; (o) CLA - NCPDP Clarification Code for overriding DUR/RTS REJECTS - ; (o) PA - NCPDP Prior Authorization Type and Number (separated by "^") - ;Output: RESP - Response from $$EN^BPSNCPDP api - ; - ; - Retrieving the NDC code from the DRUG file if not passed in, then save it in the DRUG file - N ACT,NDCACT,DA - ; - I '$D(RFL) S RFL=$$LSTRFL(RX) - ; - ; - ECME is not turned ON for the Rx's Division - I '$G(IGSW),'$$ECMEON^BPSUTIL($$RXSITE^PSOBPSUT(RX,RFL)) S RESP="-1^ECME SWITCH OFF" Q - ; - ; - ECME CMOP is not turned ON for the Rx's Division - I '$G(IGSW),$G(CMOP),'$$CMOPON^BPSUTIL($$RXSITE^PSOBPSUT(RX,RFL)) S RESP="-1^CMOP SWITCH OFF" Q - ; - ; - Saving the NDC to be displayed on the ECME Activity Log - I $G(CNDC) D - . I $G(NDC)'="" S NDCACT=NDC Q - . S NDCACT=$$GETNDC^PSONDCUT(RX,RFL) - ; - I $$NDCFMT^PSSNDCUT($G(NDC))="" D - . S NDC=$$GETNDC^PSSNDCUT($$GET1^DIQ(52,RX,6,"I"),$$RXSITE^PSOBPSUT(RX,RFL),+$G(CMOP)) - . I $G(NDC)'="" D SAVNDC^PSONDCUT(RX,RFL,NDC,+$G(CMOP),1) - ; - ; - Creating ECME Activity Log on the PRESCRIPTION file - S ACT="Submitted" I $$STATUS^PSOBPSUT(RX,RFL)="E PAYABLE" S ACT="Reversal/Re-submit sent" - S ACT=ACT_" to ECME:" - ; - ; - Marked any 'unresolved' REJECTS as 'resolved' (Reason: 1 - Claim re-submitted) - N CLSCOM,COD1,COD2,COD3 - S COD2=$P($G(OVRC),"^"),COD1=$P($G(OVRC),"^",2),COD3=$P($G(OVRC),"^",3) - I $G(COD3)'="" S CLSCOM="DUR Override Codes "_COD1_"/"_COD2_"/"_COD3_" submitted." - I $G(CLA)'="" S CLSCOM="Clarification Code "_CLA_" submitted." - I $G(PA)'="" S CLSCOM="Prior Authorization Code ("_$P(PA,"^")_"/"_$P(PA,"^",2)_") submitted." - D CLSALL^PSOREJUT(RX,RFL,DUZ,1,$G(CLSCOM),$G(COD1),$G(COD2),$G(COD3),$G(CLA),$G(PA)) - ; - ; - Call to ECME (NEWing STAT because ECME was overwriting it - Important variable for CMOP release PSXVND) - N STAT - I $G(RVTX)="",FROM="ED" S RVTX="RX EDITED" - S RESP=$$EN^BPSNCPDP(RX,RFL,$$DOS(RX,RFL,.DATE),FROM,NDC,$G(RVTX),$G(OVRC),,$G(CLA),$G(PA)) - I $$STATUS^PSOBPSUT(RX,RFL)="E PAYABLE" D SAVNDC^PSONDCUT(RX,RFL,NDC,+$G(CMOP),1) - ; - ; - Reseting the Re-transmission flag - D RETRXF^PSOREJU2(RX,RFL,0) - ; - ; - Logging ECME Activity Log to the PRESCRIPTION file - I $G(ALTX)="" D - . N X,ROUTE S (ROUTE,X)="" - . S ROUTE=$S(FROM="RF":$$GET1^DIQ(52.1,RFL_","_RX_",",2),FROM="OF":$$GET1^DIQ(52,RX_",",11),1:"") - . S:FROM="OF" X=ROUTE_" FILL(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")" - . S:FROM="RF" X=ROUTE_" REFILL(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")" - . S:FROM="RN" X="RX RENEWED(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")" - . S:FROM="PL" X="PRINTED FROM SUSPENSE(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")" - . S:FROM="PE"!(FROM="PP") X="PULLED FROM SUSPENSE(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")" - . S:FROM="PC" X="CMOP TRANSMISSION(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")" - . S:FROM="RRL" X="RELEASED RX PREVIOUSLY REVERSED" - . S:FROM="ED" X="RX EDITED" - . S:$G(RVTX)'="" X=RVTX - . S:$G(OVRC)'="" X="DUR OVERRIDE CODES("_$G(COD1)_"/"_$G(COD2)_"/"_$G(COD3)_")" - . S:$G(CNDC) X=X_"(NDC:"_NDCACT_")" S ACT=ACT_X - . S ACT=ACT_$$STS(RX,RFL,RESP) - I $G(ALTX)'="" S ACT=ACT_ALTX_$$STS(RX,RFL,RESP) - I +RESP=2 S ACT="Not ECME Billable: "_$P(RESP,"^",2) - I +RESP=10 S ACT="ECME reversed/NOT re-submitted: "_$P(RESP,"^",2) - D RXACT^PSOBPSU2(RX,RFL,ACT,"M",DUZ) - ; - ; -Logs an ECME Activity Log if Rx Quantity is different than Billing Quantity - I 'RESP,$T(NCPDPQTY^PSSBPSUT)'="" D - . N DRUG,RXQTY,BLQTY,BLDU,Z - . S DRUG=$$GET1^DIQ(52,RX,6,"I") - . S RXQTY=$S('RFL:$$GET1^DIQ(52,RX,7,"I"),1:$$GET1^DIQ(52.1,RFL_","_RX,1))/1 - . S Z=$$NCPDPQTY^PSSBPSUT(DRUG,RXQTY),BLQTY=Z/1,BLDU=$P(Z,"^",2) - . I RXQTY'=BLQTY D - . . D RXACT^PSOBPSU2(RX,RFL,"BILLING QUANTITY submitted: "_$J(BLQTY,0,$L($P(BLQTY,".",2)))_" ("_BLDU_")","M",DUZ) - ; - Q - ; -REVERSE(RX,RFL,FROM,RSN,RTXT,IGRL,NDC) ; - Reverse a claim and close all OPEN/UNRESOLVED Rejects - ;Input: (r) RX - Rx IEN (#52) - ; (o) RFL - Refill # (Default: most recent) - ; (r) FROM - Function within OP (See BWHERE param. in EN^BPSNCPDP api) - ; (o) RSN - Close Reason (2:RX ON HOLD;4: RX RETURNED TO STOCK,5:RX DELETED,etc...) - ; (o) RTXT - Close Reason TEXT (Usually no passed if RSN is passed) - ; (o) IGRL - Ignore RELEASE DATE, reverse anyway - ; (o) NDC - NDC number related to the reversal (Note: might be an invalid NDC) - ; - I '$D(RFL) S RFL=$$LSTRFL(RX) - ; - I $$STATUS^PSOBPSUT(RX,RFL)="" Q - ; - N RESP,STS,ACT,STAT,DA,STATUS,NOACT S RSN=+$G(RSN),RTXT=$G(RTXT) - I RTXT="",RSN D - . S:RSN=2 RTXT="RX PLACED ON HOLD" S:RSN=3 RTXT="RX SUSPENDED" S:RSN=4 RTXT="RX RETURNED TO STOCK" - . S:RSN=5 RTXT="RX DELETED" S:RSN=7 RTXT="RX DISCONTINUED" S:RSN=8 RTXT="RX EDITED" - ; - D CLSALL^PSOREJUT(RX,RFL,DUZ,RSN,RTXT) - ; - I '$G(IGRL),$$RXRLDT^PSOBPSUT(RX,RFL) Q - ; - ; - Reseting the Re-transmission flag if Rx is being suspended - I RSN=3!($$GET1^DIQ(52,RX,100,"I")=5) D RETRXF^PSOREJU2(RX,RFL,1) - ; - S STATUS=$$STATUS^PSOBPSUT(RX,RFL),NOACT=0 - I STATUS'="E PAYABLE",STATUS'="IN PROGRESS",STATUS'="E REVERSAL REJECTED",STATUS'="E REVERSAL STRANDED",STATUS'="E DUPLICATE" S NOACT=1 - ; - S RESP=$$EN^BPSNCPDP(RX,RFL,$$DOS(RX,RFL),FROM,$$GETNDC^PSONDCUT(RX,RFL),RTXT) - ; - ; - Logging ECME Activity Log - I '$G(NOACT) D - . S ACT="Reversal sent to ECME: "_RTXT_$S($G(NDC)'="":" ("_NDC_")",1:"")_$$STS(RX,RFL,+RESP) - . D RXACT^PSOBPSU2(RX,RFL,ACT,"M",DUZ) - ; - Q - ; -DOS(RX,RFL,DATE) ; Return the Date Of Service for ECME - ;Input: (r) RX - Rx IEN (#52) - ; (o) RFL - Refill # (Default: most recent) - ; (o) DATE - Possible Date Of Service - ;Output: DOS - Actual Date Of Service - ; - I '$D(RFL) S RFL=$$LSTRFL(RX) - ; - ; - Retrieving FILL DATE from the PRESCRIPTION file if not passed - I $G(DATE)="" S DATE=$$RXRLDT^PSOBPSUT(RX,RFL) - ; - Retrieving FILL DATE from the PRESCRIPTION file if not passed - I 'DATE S DATE=$$RXFLDT^PSOBPSUT(RX,RFL) - ; - Future Date not allowed - I DATE>DT!'DATE S DATE=DT - ; - Q (DATE\1) - ; -RELEASE(RX,RFL,USR) ; - Notifies IB that the Rx was RELEASED - ;Input: (r) RX - Rx IEN (#52) - ; (o) RFL - Refill # (Default: most recent) - ; (o) USR - User responsible for releasing the Rx (Default: .5 - Postmaster) - ; - N IBAR,RXAR,FLDT,RFAR - ; - S:'$D(RFL) RFL=$$LSTRFL(RX) - S:'$D(USR) USR=.5 - ; - D GETS^DIQ(52,RX_",",".01;2;6;7;8;22","I","RXAR") - S DFN=+$G(RXAR(52,RX_",",2,"I")) - S IBAR("PRESCRIPTION")=RX,IBAR("RX NO")=$G(RXAR(52,RX_",",.01,"I")) - S IBAR("CLAIMID")=$E((RX#10000000)+10000000,2,8),IBAR("USER")=USR - S IBAR("DRUG")=RXAR(52,RX_",",6,"I"),IBAR("NDC")=$$GETNDC^PSONDCUT(RX,RFL) - S FLDT=$$RXFLDT^PSOBPSUT(RX,RFL) I FLDT>DT S FLDT=DT - S IBAR("FILL NUMBER")=RFL,IBAR("FILL DATE")=FLDT - S IBAR("QTY")=$G(RXAR(52,RX_",",7,"I")),IBAR("DAYS SUPPLY")=$G(RXAR(52,RX_",",8,"I")) - ; - I RFL D - . D GETS^DIQ(52.1,RFL_","_RX_",",".01;1;1.1","I","RFAR") - . S IBAR("QTY")=$G(RFAR(52.1,RFL_","_RX_",",1,"I")) - . S IBAR("DAYS SUPPLY")=$G(RFAR(52.1,RFL_","_RX_",",1.1,"I")) - ; - S IBAR("STATUS")="RELEASED" D STORESP^IBNCPDP(DFN,.IBAR) - ; - Q - ; -LSTRFL(RX) ; - Returns the latest fill for the Prescription - ; Input: (r) RX - Rx IEN (#52) - ;Output: LSTRFL - Most recent refill # - N I,LSTRFL - S (I,LSTRFL)=0 F S I=$O(^PSRX(RX,1,I)) Q:'I S LSTRFL=I - Q LSTRFL - ; -ECMEACT(RX,RFL,COMM,USR) ; - Add an Activity to the ECME Activity Log (PRESCRIPTION file) - ;Input: (r) RX - Rx IEN (#52) - ; (o) RFL - Refill # (Default: most recent) - ; (r) COMM - Comments (up to 75 characters) - ; (o) USR - User logging the comments (Default: DUZ) - ; - S:'$D(RFL) RFL=$$LSTRFL^PSOBPSU1(RX) - D RXACT^PSOBPSU2(RX,RFL,COMM,"M",+$G(USR)) - Q - ; -STS(RX,RFL,RSP) ; Adds the Status to the ECME Activity Log according to Rx/fill claim status Response - N STS - S STS=$S($$STATUS^PSOBPSUT(RX,RFL)'="IN PROGRESS"&($$STATUS^PSOBPSUT(RX,RFL)'=""):"-"_$$STATUS^PSOBPSUT(RX,RFL),1:"") - S:+RSP=1 STS="-NO SUBMISSION THROUGH ECME" S:+RSP=3 STS="-NO REVERSAL NEEDED" S:+RSP=4 STS="-NOT PROCESSED" - S:+RSP=5 STS="-SOFTWARE ERROR" - I +RSP=2,$$STATUS^PSOBPSUT(RX,RFL)'="" S STS="-NOT BILLABLE:"_$P(RSP,"^",2) - Q STS +PSOBPSU1 ;BIRM/MFR - BPS (ECME) Utilities 1 ;10/15/04 + ;;7.0;OUTPATIENT PHARMACY;**148,260**;DEC 1997;Build 84 + ;Reference to $$EN^BPSNCPDP supported by IA 4415 + ;References to $$NDCFMT^PSSNDCUT,$$GETNDC^PSSNDCUT supported by IA 4707 + ;References to $$ECMEON^BPSUTIL,$$CMOPON^BPSUTIL supported by IA 4410 + ;References to STORESP^IBNCPDP supported by IA 4299 + ; +ECMESND(RX,RFL,DATE,FROM,NDC,CMOP,RVTX,OVRC,CNDC,RESP,IGSW,ALTX,CLA,PA) ; - Sends Rx Release information to ECME/IB and + ; updates NDC in the DRUG/PRESCRIPTION files + ;Reference to routine EN^BPSNCPDP supported by DBIA #4304 + ;Input: (r) RX - Rx IEN (#52) + ; (o) RFL - Refill # (Default: most recent) + ; (r) DATE - Date of Service + ; (r) FROM - Function within OP (See BWHERE param. in EN^BPSNCPDP api) + ; (o) NDC - NDC Number (If not passed, will be retrieved from DRUG file) + ; (o) CMOP - CMOP Prescription (1-YES/0-NO) (Default: 0) + ; (o) RVTX - REVERSE text (e.g., RX EDIT, RX RELEASE-NDC CHANGE, etc) + ; (o) OVRC - Set of 3 NCPDP override codes separated by "^": + ; Piece 1: NCPDP Professional Service Code for overriding DUR REJECTS + ; Piece 2: NCPDP Reason for Service Code for overriding DUR REJECTS + ; Piece 3: NCPDP Result of Service Code for overriding DUR REJECTS + ; (o) CNDC - Changed NDC? 1 - Yes / 0 - No (Default: NO) + ; (o) IGSW - Ignore Switches (Master and CMOP)? 1 - Yes / 0 - No (Default: NO) + ; (o) ALTX - Alternative Text to be placed in the Rx ECME Activity Log + ; (o) CLA - NCPDP Clarification Code for overriding DUR/RTS REJECTS + ; (o) PA - NCPDP Prior Authorization Type and Number (separated by "^") + ;Output: RESP - Response from $$EN^BPSNCPDP api + ; + ; - Retrieving the NDC code from the DRUG file if not passed in, then save it in the DRUG file + N ACT,NDCACT,DA + ; + I '$D(RFL) S RFL=$$LSTRFL(RX) + ; + ; - ECME is not turned ON for the Rx's Division + I '$G(IGSW),'$$ECMEON^BPSUTIL($$RXSITE^PSOBPSUT(RX,RFL)) S RESP="-1^ECME SWITCH OFF" Q + ; + ; - ECME CMOP is not turned ON for the Rx's Division + I '$G(IGSW),$G(CMOP),'$$CMOPON^BPSUTIL($$RXSITE^PSOBPSUT(RX,RFL)) S RESP="-1^CMOP SWITCH OFF" Q + ; + ; - Saving the NDC to be displayed on the ECME Activity Log + I $G(CNDC) D + . I $G(NDC)'="" S NDCACT=NDC Q + . S NDCACT=$$GETNDC^PSONDCUT(RX,RFL) + ; + I $$NDCFMT^PSSNDCUT($G(NDC))="" D + . S NDC=$$GETNDC^PSSNDCUT($$GET1^DIQ(52,RX,6,"I"),$$RXSITE^PSOBPSUT(RX,RFL),+$G(CMOP)) + . I $G(NDC)'="" D SAVNDC^PSONDCUT(RX,RFL,NDC,+$G(CMOP)) + ; + ; - Creating ECME Activity Log on the PRESCRIPTION file + S ACT="Submitted" I $$STATUS^PSOBPSUT(RX,RFL)="E PAYABLE" S ACT="Reversal/Re-submit sent" + S ACT=ACT_" to ECME:" + ; + ; - Marked any 'unresolved' REJECTS as 'resolved' (Reason: 1 - Claim re-submitted) + N CLSCOM,COD1,COD2,COD3 + S COD2=$P($G(OVRC),"^"),COD1=$P($G(OVRC),"^",2),COD3=$P($G(OVRC),"^",3) + I $G(COD3)'="" S CLSCOM="DUR Override Codes "_COD1_"/"_COD2_"/"_COD3_" submitted." + I $G(CLA)'="" S CLSCOM="Clarification Code "_CLA_" submitted." + I $G(PA)'="" S CLSCOM="Prior Authorization Code ("_$P(PA,"^")_"/"_$P(PA,"^",2)_") submitted." + D CLSALL^PSOREJUT(RX,RFL,DUZ,1,$G(CLSCOM),$G(COD1),$G(COD2),$G(COD3),$G(CLA),$G(PA)) + ; + ; - Call to ECME (NEWing STAT because ECME was overwriting it - Important variable for CMOP release PSXVND) + N STAT + I $G(RVTX)="",FROM="ED" S RVTX="RX EDITED" + S RESP=$$EN^BPSNCPDP(RX,RFL,$$DOS(RX,RFL,.DATE),FROM,NDC,$G(RVTX),$G(OVRC),,$G(CLA),$G(PA)) + ; + ; - Reseting the Re-transmission flag + D RETRXF^PSOREJU2(RX,RFL,0) + ; + ; - Logging ECME Activity Log to the PRESCRIPTION file + I $G(ALTX)="" D + . N X S X="" + . S:FROM="OF" X="WINDOW FILL(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")" + . S:FROM="RF" X="WINDOW REFILL(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")" + . S:FROM="RN" X="RX RENEWED(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")" + . S:FROM="PL" X="SUSP LABEL PRINTED(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")" + . S:FROM="PE"!(FROM="PP") X="PULLED FROM SUSPENSE(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")" + . S:FROM="PC" X="CMOP TRANSMISSION(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")" + . S:FROM="RRL" X="RELEASED RX PREVIOUSLY REVERSED" + . S:FROM="ED" X="RX EDITED" + . S:$G(RVTX)'="" X=RVTX + . S:$G(OVRC)'="" X="DUR OVERRIDE CODES("_$G(COD1)_"/"_$G(COD2)_"/"_$G(COD3)_")" + . S:$G(CNDC) X=X_"(NDC:"_NDCACT_")" S ACT=ACT_X + . S ACT=ACT_$$STS(RX,RFL,RESP) + I $G(ALTX)'="" S ACT=ACT_ALTX_$$STS(RX,RFL,RESP) + I +RESP=2 S ACT="Not ECME Billable: "_$P(RESP,"^",2) + I +RESP=10 S ACT="ECME reversed/NOT re-submitted: "_$P(RESP,"^",2) + D RXACT^PSOBPSU2(RX,RFL,ACT,"M",DUZ) + ; + ; -Logs an ECME Activity Log if Rx Quantity is different than Billing Quantity + I 'RESP,$T(NCPDPQTY^PSSBPSUT)'="" D + . N DRUG,RXQTY,BLQTY,BLDU,Z + . S DRUG=$$GET1^DIQ(52,RX,6,"I") + . S RXQTY=$S('RFL:$$GET1^DIQ(52,RX,7,"I"),1:$$GET1^DIQ(52.1,RFL_","_RX,1))/1 + . S Z=$$NCPDPQTY^PSSBPSUT(DRUG,RXQTY),BLQTY=Z/1,BLDU=$P(Z,"^",2) + . I RXQTY'=BLQTY D + . . D RXACT^PSOBPSU2(RX,RFL,"BILLING QUANTITY submitted: "_$J(BLQTY,0,$L($P(BLQTY,".",2)))_" ("_BLDU_")","M",DUZ) + ; + Q + ; +REVERSE(RX,RFL,FROM,RSN,RTXT,IGRL,NDC) ; - Reverse a claim and close all OPEN/UNRESOLVED Rejects + ;Input: (r) RX - Rx IEN (#52) + ; (o) RFL - Refill # (Default: most recent) + ; (r) FROM - Function within OP (See BWHERE param. in EN^BPSNCPDP api) + ; (o) RSN - Close Reason (2:RX ON HOLD;4: RX RETURNED TO STOCK,5:RX DELETED,etc...) + ; (o) RTXT - Close Reason TEXT (Usually no passed if RSN is passed) + ; (o) IGRL - Ignore RELEASE DATE, reverse anyway + ; (o) NDC - NDC number related to the reversal (Note: might be an invalid NDC) + ; + I '$D(RFL) S RFL=$$LSTRFL(RX) + ; + I $$STATUS^PSOBPSUT(RX,RFL)="" Q + ; + N RESP,STS,ACT,STAT,DA,STATUS,NOACT S RSN=+$G(RSN),RTXT=$G(RTXT) + I RTXT="",RSN D + . S:RSN=2 RTXT="RX PLACED ON HOLD" S:RSN=3 RTXT="RX SUSPENDED" S:RSN=4 RTXT="RX RETURNED TO STOCK" + . S:RSN=5 RTXT="RX DELETED" S:RSN=7 RTXT="RX DISCONTINUED" S:RSN=8 RTXT="RX EDITED" + ; + D CLSALL^PSOREJUT(RX,RFL,DUZ,RSN,RTXT) + ; + I '$G(IGRL),$$RXRLDT^PSOBPSUT(RX,RFL) Q + ; + ; - Reseting the Re-transmission flag if Rx is being suspended + I RSN=3!($$GET1^DIQ(52,RX,100,"I")=5) D RETRXF^PSOREJU2(RX,RFL,1) + ; + S STATUS=$$STATUS^PSOBPSUT(RX,RFL),NOACT=0 + I STATUS'="E PAYABLE",STATUS'="IN PROGRESS",STATUS'="E REVERSAL REJECTED",STATUS'="E REVERSAL STRANDED",STATUS'="E DUPLICATE" S NOACT=1 + ; + S RESP=$$EN^BPSNCPDP(RX,RFL,$$DOS(RX,RFL),FROM,$$GETNDC^PSONDCUT(RX,RFL),RTXT) + ; + ; - Logging ECME Activity Log + I '$G(NOACT) D + . S ACT="Reversal sent to ECME: "_RTXT_$S($G(NDC)'="":" ("_NDC_")",1:"")_$$STS(RX,RFL,+RESP) + . D RXACT^PSOBPSU2(RX,RFL,ACT,"M",DUZ) + ; + Q + ; +DOS(RX,RFL,DATE) ; Return the Date Of Service for ECME + ;Input: (r) RX - Rx IEN (#52) + ; (o) RFL - Refill # (Default: most recent) + ; (o) DATE - Possible Date Of Service + ;Output: DOS - Actual Date Of Service + ; + I '$D(RFL) S RFL=$$LSTRFL(RX) + ; + ; - Retrieving FILL DATE from the PRESCRIPTION file if not passed + I $G(DATE)="" S DATE=$$RXRLDT^PSOBPSUT(RX,RFL) + ; - Retrieving FILL DATE from the PRESCRIPTION file if not passed + I 'DATE S DATE=$$RXFLDT^PSOBPSUT(RX,RFL) + ; - Future Date not allowed + I DATE>DT!'DATE S DATE=DT + ; + Q (DATE\1) + ; +RELEASE(RX,RFL,USR) ; - Notifies IB that the Rx was RELEASED + ;Input: (r) RX - Rx IEN (#52) + ; (o) RFL - Refill # (Default: most recent) + ; (o) USR - User responsible for releasing the Rx (Default: .5 - Postmaster) + ; + N IBAR,RXAR,FLDT,RFAR + ; + S:'$D(RFL) RFL=$$LSTRFL(RX) + S:'$D(USR) USR=.5 + ; + D GETS^DIQ(52,RX_",",".01;2;6;7;8;22","I","RXAR") + S DFN=+$G(RXAR(52,RX_",",2,"I")) + S IBAR("PRESCRIPTION")=RX,IBAR("RX NO")=$G(RXAR(52,RX_",",.01,"I")) + S IBAR("CLAIMID")=$E((RX#10000000)+10000000,2,8),IBAR("USER")=USR + S IBAR("DRUG")=RXAR(52,RX_",",6,"I"),IBAR("NDC")=$$GETNDC^PSONDCUT(RX,RFL) + S FLDT=$$RXFLDT^PSOBPSUT(RX,RFL) I FLDT>DT S FLDT=DT + S IBAR("FILL NUMBER")=RFL,IBAR("FILL DATE")=FLDT + S IBAR("QTY")=$G(RXAR(52,RX_",",7,"I")),IBAR("DAYS SUPPLY")=$G(RXAR(52,RX_",",8,"I")) + ; + I RFL D + . D GETS^DIQ(52.1,RFL_","_RX_",",".01;1;1.1","I","RFAR") + . S IBAR("QTY")=$G(RFAR(52.1,RFL_","_RX_",",1,"I")) + . S IBAR("DAYS SUPPLY")=$G(RFAR(52.1,RFL_","_RX_",",1.1,"I")) + ; + S IBAR("STATUS")="RELEASED" D STORESP^IBNCPDP(DFN,.IBAR) + ; + Q + ; +LSTRFL(RX) ; - Returns the latest fill for the Prescription + ; Input: (r) RX - Rx IEN (#52) + ;Output: LSTRFL - Most recent refill # + N I,LSTRFL + S (I,LSTRFL)=0 F S I=$O(^PSRX(RX,1,I)) Q:'I S LSTRFL=I + Q LSTRFL + ; +ECMEACT(RX,RFL,COMM,USR) ; - Add an Activity to the ECME Activity Log (PRESCRIPTION file) + ;Input: (r) RX - Rx IEN (#52) + ; (o) RFL - Refill # (Default: most recent) + ; (r) COMM - Comments (up to 75 characters) + ; (o) USR - User logging the comments (Default: DUZ) + ; + S:'$D(RFL) RFL=$$LSTRFL^PSOBPSU1(RX) + D RXACT^PSOBPSU2(RX,RFL,COMM,"M",+$G(USR)) + Q + ; +STS(RX,RFL,RSP) ; Adds the Status to the ECME Activity Log according to Rx/fill claim status Response + N STS + S STS=$S($$STATUS^PSOBPSUT(RX,RFL)'="IN PROGRESS"&($$STATUS^PSOBPSUT(RX,RFL)'=""):"-"_$$STATUS^PSOBPSUT(RX,RFL),1:"") + S:+RSP=1 STS="-NO SUBMISSION THROUGH ECME" S:+RSP=3 STS="-NO REVERSAL NEEDED" S:+RSP=4 STS="-NOT PROCESSED" + S:+RSP=5 STS="-SOFTWARE ERROR" + I +RSP=2,$$STATUS^PSOBPSUT(RX,RFL)'="" S STS="-NOT BILLABLE:"_$P(RSP,"^",2) + Q STS diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOBPSUT.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOBPSUT.m index 71efd9ef..d215ad7f 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOBPSUT.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOBPSUT.m @@ -1,248 +1,246 @@ -PSOBPSUT ;BIRM/MFR - BPS (ECME) Utilities ; 07 Jun 2005 8:39 PM - ;;7.0;OUTPATIENT PHARMACY;**148,247,260,281**;DEC 1997;Build 41 - ;Reference to $$ECMEON^BPSUTIL supported by IA 4410 - ;Reference to IBSEND^BPSECMP2 supported by IA 4411 - ;Reference to $$STATUS^BPSOSRX supported by IA 4412 - ;Reference to $$NDCFMT^PSSNDCUT supported by IA 4707 - ;Reference to $$CLAIM^BPSBUTL supported by IA 4719 - ;Reference to ^PS(55 supported by IA 2228 - ;Reference to ^PSDRUG( supported by IA 221 - ;Reference to ^PSDRUG("AQ" supported by IA 3165 - ; -ECME(RX) ; Returns "e" if Rx/Refill is Electronically Billable (3rd party) - Q $S($$STATUS^BPSOSRX(RX,$$LSTRFL^PSOBPSU1(RX))'="":"e",1:"") - ; -STATUS(RX,RFL) ; Returns the Rx's ECME Status (calls STATUS^BPSOSRX) - ; Input: (r) RX - Rx IEN (#52) - ; (o) RFL - Refill # (Default: most recent) - I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) - Q $P($$STATUS^BPSOSRX(RX,RFL),"^") - ; -SUBMIT(RX,RFL,IGRL,IGCMP) ; Returns whether the Rx should be submitted to ECME at the moment or not - ; Input: (r) RX - Rx IEN (#52) - ; (o) RFL - Refill # (Def.: most recent) - ; (o) IGRL - Ignore Release Date? (1-YES/0-NO) (Def.: 0 - NO) - ; (o) IGCMP- Ignore CMOP/Suspense check? (1-YES/0-NO) (Def.: 0 - NO) - ; - ; - Get the REFILL # (multiple IEN) - N STATUS - I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) - ; - Not the latest fill for the prescription - I RFL'=$$LSTRFL^PSOBPSU1(RX) Q 0 - ; - Status not ACTIVE, DISCONTINUED, or EXPIRED - S STATUS=$$GET1^DIQ(52,RX,100,"I") - I STATUS'=0&(STATUS'=11)&(STATUS'=12) Q 0 - ; Will suspend for CMOP - I '$G(IGCMP),$$CMOP(RX,RFL) Q 0 - ; - ECME turned OFF for Rx's site - I '$$ECMEON^BPSUTIL($$RXSITE(RX,RFL)) Q 0 - ; - Rx is RELEASED - Do not submit - I '$G(IGRL),$$RXRLDT(RX,RFL) Q 0 - ; - Future Fill/AUTO SUSPENSE ON - will suspend - I '$G(IGCMP),$$RXFLDT(RX,RFL)>DT,$$GET1^DIQ(59,$$RXSITE(RX,RFL),.16,"I") Q 0 - Q 1 - ; -CMOP(RX,RFL) ; Returns if the Rx will be a CMOP Rx or not - ; Input: (r) RX - Rx IEN (#52) - ; (o) RFL - Refill # (Default: most recent) - ; Output: 1 - CMOP / 0 - NON-CMOP - ; - N DFN,CMOP,MAIL,MAILEXP,DRUG,WARNS,STATUS,MW,A - ; Get the REFILL # (multiple IEN) - I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) - ; MAIL=MAIL Code, MAILEXP=Mail Code Expiration Date - S CMOP=0 - S DFN=$$GET1^DIQ(52,RX,2,"I"),MAIL=$$GET1^DIQ(55,DFN,.03,"I"),MAILEXP=$$GET1^DIQ(55,DFN,.05,"I") - I MAIL>1,MAILEXP=""!(MAILEXP>DT) G QCMOP - ; Get drug IEN and cheDRUG if CMOP ,$S($G(MAILEXP)=""!($G(MAILEXP)>DT):1,1:0) - S DRUG=$$GET1^DIQ(52,RX,6,"I") G QCMOP:'DRUG,QCMOP:'$D(^PSDRUG("AQ",DRUG)) - ; Not marked for O.P. - I $$GET1^DIQ(50,DRUG,63)'["O" G QCMOP - ; Drug Warning >11 - S WARNS=$$GET1^DIQ(50,DRUG,8) I $L(WARNS)>11 G QCMOP - ; If tradename - I $$GET1^DIQ(52,RX,6.5)'="" G QCMOP - ; If Cancelled, Expired, Deleted, Hold - S STATUS=$$GET1^DIQ(52,RX,100,"I") I STATUS>9!(STATUS=4)!(STATUS=3) G QCMOP - ; Rx RELEASED - I $$RXRLDT^PSOBPSUT(RX,RFL) G QCMOP - ; MAIL/WINDOW - S MW=$S('RFL:$$GET1^DIQ(52,RX,11,"I"),1:$$GET1^DIQ(52.1,RFL_","_RX,2,"I")) - ; IF WINDOW/ORIGINAL/FUTURE FILL SETS MW = MAIL - I MW="W",$$RXFLDT^PSOBPSUT(RX,RFL)>DT S MW="M" - ; If not MAIL - I MW'="M" G QCMOP - S CMOP=1 - ; -QCMOP Q CMOP - ; -RXRLDT(RX,RFL) ; Returns the Rx Release Date - ; Input: (r) RX - Rx IEN (#52) - ; (o) RFL - Refill # (Default: most recent) - ; - ; Output: RXRLDT - Rx Release Date - N RXRLDT - I '$G(RX) Q "" - S RXRLDT=$$GET1^DIQ(52,RX,31,"I") - I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) - I RFL S RXRLDT=$$GET1^DIQ(52.1,RFL_","_RX,17,"I") - Q RXRLDT - ; -RXFLDT(RX,RFL) ; Returns the Rx Fill Date - ; Input: (r) RX - Rx IEN (#52) - ; (o) RFL - Refill # (Default: most recent) - ; Output: RXFLDT - Rx Fill Date - N RXFLDT - I '$G(RX) Q "" - S RXFLDT=$$GET1^DIQ(52,RX,22,"I") - I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) - I RFL S RXFLDT=$$GET1^DIQ(52.1,RFL_","_RX,.01,"I") - Q RXFLDT - ; -RXSUDT(RX,RFL) ; Returns the prescription/fill Suspense Date for the RX/Reject passed in - ;Input: (r) RX - Rx IEN (#52) - ; (o) RFL - Refill IEN (#52.1) - ;Output: SUSPENSE DATE (External format) or , if not suspended - ; - I $G(^PSRX(RX,"STA"))'=5 Q "" - N SURX,SURFL - S SURX=$O(^PS(52.5,"B",RX,0)) I 'SURX Q "" - I $$GET1^DIQ(52.5,SURX,.05,"I") Q "" - S SURFL=+$$GET1^DIQ(52.5,SURX,9) I RFL'=SURFL Q "" - Q $$GET1^DIQ(52.5,SURX,.02,"I") - ; -RXSITE(RX,RFL) ; Returns the Rx DIVISION - ; Input: (r) RX - Rx IEN (#52) - ; (o) RFL - Refill # - ; Output: SITE - Rx Fill Date - ; - N SITE - I '$G(RX) Q "" - I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) - I RFL S SITE=$$GET1^DIQ(52.1,RFL_","_RX,8,"I") - I 'RFL!'$G(SITE) S SITE=$$GET1^DIQ(52,RX,20,"I") - Q SITE - ; -MANREL(RX,RFL,PID) ; ePharmacy Manual Rx Release - ;Input: (r) RX - Rx IEN (#52) - ; (o) RFL - Refill # (Default: most recent) - ; (o) PID - Displays PID/Drug/Rx in the NDC prompts - ;Output: "" (null - OK to Release) OR "^" (User entered "^", or no valid NDC on file for ePharmacy Rx) - ; - N ACTION - ; - I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) - ; - ; - Checking for REJECTS before proceeding to Rx Release - I $$FIND^PSOREJUT(RX,RFL) D I ACTION="Q"!(ACTION="^") W ! Q "^" - . S ACTION=$$HDLG^PSOREJU1(RX,RFL,"79,88","ED","OIQ","Q") - ; - ; - ePharmacy switch is OFF - I '$$ECMEON^BPSUTIL($$RXSITE^PSOBPSUT(RX,RFL)) Q "" - ; - ; - Not an ePharmacy Rx - I $$STATUS^PSOBPSUT(RX,RFL)="" Q "" - ; - ; - NDC editing before Rx release - S ACTION=$$CHGNDC^PSONDCUT(RX,RFL,$G(PID)) I ACTION="^" D Q "^" - . W !!,$C(7),"A valid NDC must be entered before the Release function can be completed.",! H 1 - ; - ; - Checking for OPEN/UNRESOLVED 3rd. Party Payer Rejects (After possible NDC edit) - I $$FIND^PSOREJUT(RX,RFL) D I ACTION="Q"!(ACTION="^") W ! Q "^" - . S ACTION=$$HDLG^PSOREJU1(RX,RFL,"79,88","ED","OIQ","Q") - ; - ; - Notifying IB of a Rx RELEASE event - D RELEASE^PSOBPSU1(RX,RFL,DUZ) - ; - Q "" - ; -AUTOREL(RX,RFL,RLDT,NDC,SRC,STS,HNG) ; Sends Rx Release information to ECME/IB and updates NDC - ; in the DRUG/PRESCRIPTION files - ;Input: (r) RX - Rx IEN (#52) - ; (o) RFL - Refill # (Default: most recent) - ; (r) RLDT- Release Date - ; (r) NDC - NDC Number (Must be 11 digits) - ; (o) SRC - SOURCE: "C" - CMOP / "A" - OPAI - ; (o) STS - Status: (S)uccessful/(U)nsuccessful Release (Default: "S" - Successful) - ; (o) HNG - HANG time after resubmission and before checking the status of the claim (Default: 0) - ; - N RXNDC,SITE - ; - I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) - ; - S:'$D(STS) STS="S" S:'$D(SRC) SRC="" S HNG=+$G(HNG) - S RXNDC=$$GETNDC^PSONDCUT(RX,RFL) - ; - ; - Saves the NDC from CMOP/Automated Dispensing Machine in the Prescription file - I $$NDCFMT^PSSNDCUT(NDC)'="" D SAVNDC^PSONDCUT(RX,RFL,$$NDCFMT^PSSNDCUT(NDC),$S(SRC="C":1,1:0)) - ; - ; - Not an ePharmacy Rx - I $$STATUS^PSOBPSUT(RX,RFL)="" Q "" - ; - ; - Unsuccessful Release - I STS="U" D Q - . D REVERSE^PSOBPSU1(RX,RFL,"CRLX",,"UNSUCCESSFUL "_$S(SRC="C":"CMOP",1:"EXT INTERFACE")_" RELEASE",1) - ; - ; - Notifying IB of a Rx RELEASE event - D RELEASE^PSOBPSU1(RX,RFL) - ; - ; - Invalid NDC from Automated Dispensing Machine - I SRC="A",$$NDCFMT^PSSNDCUT(NDC)="" D Q - . D REVERSE^PSOBPSU1(RX,RFL,"CRLR",,"INVALID EXT INTERFACE NDC",1,NDC) - ; - ; - Invalid NDC number for CMOP - I SRC="C",$$NDCFMT^PSSNDCUT(NDC)="" D Q - . D REVERSE^PSOBPSU1(RX,RFL,"CRLR",,"INVALID CMOP NDC",1,NDC) - ; - ; - If NDC not equal RXNDC, issue reversal and submit new claim - I SRC="A",$$NDCFMT^PSSNDCUT(NDC)'=RXNDC D Q - . D ECMESND^PSOBPSU1(RX,RFL,RLDT,"CRLB",$$NDCFMT^PSSNDCUT(NDC),,"AUTO RELEASE",,1,,1) - . H HNG - . ; - If new claim returned PAYABLE, save new NDC in the DRUG/PRESCRIPTION files - . I $$STATUS^PSOBPSUT(RX,RFL)="E PAYABLE" D SAVNDC^PSONDCUT(RX,RFL,$$NDCFMT^PSSNDCUT(NDC),0,1) - ; - ; - If NDC not equal RXNDC, issue reversal and submit new claim - I SRC="C",$$NDCFMT^PSSNDCUT(NDC)'=RXNDC D Q - . ; - Reverse/Resubmit with correct NDC - . D ECMESND^PSOBPSU1(RX,RFL,RLDT,"CRLB",$$NDCFMT^PSSNDCUT(NDC),1,"CMOP RELEASE",,1,,1) - . ; - Wait for a response from the Payer for the submission above - . H HNG - . ; - If new claim returned PAYABLE, save new NDC in the DRUG/PRESCRIPTION files - . I $$STATUS^PSOBPSUT(RX,RFL)="E PAYABLE" D SAVNDC^PSONDCUT(RX,RFL,$$NDCFMT^PSSNDCUT(NDC),1,1) - ; - ; - Calls ECME api responsible for notifying IB to create a BILL - D IBSEND(RX,RFL) - ; - Q - ; -IBSEND(RX,RFL) ; Rx Release: Calls ECME, which will call IB to create a bill - ;Input: (r) RX - Rx IEN (#52) - ; (o) RFL - Refill # (Default: most recent) - ; - I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) - ; - ; - ECME turned OFF for Rx's site - I '$$ECMEON^BPSUTIL($$RXSITE^PSOBPSUT(RX,RFL)) Q - ; - ; - Not an ePharmacy Rx - I $$STATUS^PSOBPSUT(RX,RFL)="" Q "" - ; - ; - Calls ECME previously reversed, re-submit the claim to the payer - I $$STATUS^PSOBPSUT(RX,RFL)="E REVERSAL ACCEPTED"!($$STATUS^PSOBPSUT(RX,RFL)="IN PROGRESS") D Q - . D ECMESND^PSOBPSU1(RX,RFL,$$RXRLDT^PSOBPSUT(RX,RFL),"RRL") - ; - ; - Notifying ECME of a BILLING event - I $$STATUS^PSOBPSUT(RX,RFL)="E PAYABLE" D Q - . N PSOCLAIM S PSOCLAIM=$$CLAIM^BPSBUTL(RX,RFL) - . D IBSEND^BPSECMP2($P(PSOCLAIM,"^",2),$P(PSOCLAIM,"^",3),"BILL",DUZ) - ; - Q - ; -RETRX(RX,RFL) ; - Re-transmit a claim for the prescription/fill? - ;Input: (r) RX - Rx IEN (#52) - ; (o) RFL - Refill # (Default: most recent) - ;Output: 1 - Re-transmit / 0 - Don't re-transmit - I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) - ; - I RFL Q +$$GET1^DIQ(52.1,RFL_","_RX,82,"I") - Q +$$GET1^DIQ(52,RX,82,"I") +PSOBPSUT ;BIRM/MFR - BPS (ECME) Utilities ; 07 Jun 2005 8:39 PM + ;;7.0;OUTPATIENT PHARMACY;**148,247,260**;DEC 1997;Build 84 + ;Reference to $$ECMEON^BPSUTIL supported by IA 4410 + ;Reference to IBSEND^BPSECMP2 supported by IA 4411 + ;Reference to $$STATUS^BPSOSRX supported by IA 4412 + ;Reference to $$NDCFMT^PSSNDCUT supported by IA 4707 + ;Reference to $$CLAIM^BPSBUTL supported by IA 4719 + ;Reference to ^PS(55 supported by IA 2228 + ;Reference to ^PSDRUG( supported by IA 221 + ;Reference to ^PSDRUG("AQ" supported by IA 3165 + ; +ECME(RX) ; Returns "e" if Rx/Refill is Electronically Billable (3rd party) + Q $S($$STATUS^BPSOSRX(RX,$$LSTRFL^PSOBPSU1(RX))'="":"e",1:"") + ; +STATUS(RX,RFL) ; Returns the Rx's ECME Status (calls STATUS^BPSOSRX) + ; Input: (r) RX - Rx IEN (#52) + ; (o) RFL - Refill # (Default: most recent) + I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) + Q $P($$STATUS^BPSOSRX(RX,RFL),"^") + ; +SUBMIT(RX,RFL,IGRL,IGCMP) ; Returns whether the Rx should be submitted to ECME at the moment or not + ; Input: (r) RX - Rx IEN (#52) + ; (o) RFL - Refill # (Def.: most recent) + ; (o) IGRL - Ignore Release Date? (1-YES/0-NO) (Def.: 0 - NO) + ; (o) IGCMP- Ignore CMOP/Suspense check? (1-YES/0-NO) (Def.: 0 - NO) + ; + ; - Get the REFILL # (multiple IEN) + I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) + ; - Not the latest fill for the prescription + I RFL'=$$LSTRFL^PSOBPSU1(RX) Q 0 + ; - Status not ACTIVE + I $$GET1^DIQ(52,RX,100,"I")'=0 Q 0 + ; Will suspend for CMOP + I '$G(IGCMP),$$CMOP(RX,RFL) Q 0 + ; - ECME turned OFF for Rx's site + I '$$ECMEON^BPSUTIL($$RXSITE(RX,RFL)) Q 0 + ; - Rx is RELEASED - Do not submit + I '$G(IGRL),$$RXRLDT(RX,RFL) Q 0 + ; - Future Fill/AUTO SUSPENSE ON - will suspend + I '$G(IGCMP),$$RXFLDT(RX,RFL)>DT,$$GET1^DIQ(59,$$RXSITE(RX,RFL),.16,"I") Q 0 + Q 1 + ; +CMOP(RX,RFL) ; Returns if the Rx will be a CMOP Rx or not + ; Input: (r) RX - Rx IEN (#52) + ; (o) RFL - Refill # (Default: most recent) + ; Output: 1 - CMOP / 0 - NON-CMOP + ; + N DFN,CMOP,MAIL,MAILEXP,DRUG,WARNS,STATUS,MW,A + ; Get the REFILL # (multiple IEN) + I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) + ; MAIL=MAIL Code, MAILEXP=Mail Code Expiration Date + S CMOP=0 + S DFN=$$GET1^DIQ(52,RX,2,"I"),MAIL=$$GET1^DIQ(55,DFN,.03,"I"),MAILEXP=$$GET1^DIQ(55,DFN,.05,"I") + I MAIL>1,MAILEXP=""!(MAILEXP>DT) G QCMOP + ; Get drug IEN and cheDRUG if CMOP ,$S($G(MAILEXP)=""!($G(MAILEXP)>DT):1,1:0) + S DRUG=$$GET1^DIQ(52,RX,6,"I") G QCMOP:'DRUG,QCMOP:'$D(^PSDRUG("AQ",DRUG)) + ; Not marked for O.P. + I $$GET1^DIQ(50,DRUG,63)'["O" G QCMOP + ; Drug Warning >11 + S WARNS=$$GET1^DIQ(50,DRUG,8) I $L(WARNS)>11 G QCMOP + ; If tradename + I $$GET1^DIQ(52,RX,6.5)'="" G QCMOP + ; If Cancelled, Expired, Deleted, Hold + S STATUS=$$GET1^DIQ(52,RX,100,"I") I STATUS>9!(STATUS=4)!(STATUS=3) G QCMOP + ; Rx RELEASED + I $$RXRLDT^PSOBPSUT(RX,RFL) G QCMOP + ; MAIL/WINDOW + S MW=$S('RFL:$$GET1^DIQ(52,RX,11,"I"),1:$$GET1^DIQ(52.1,RFL_","_RX,2,"I")) + ; IF WINDOW/ORIGINAL/FUTURE FILL SETS MW = MAIL + I MW="W",$$RXFLDT^PSOBPSUT(RX,RFL)>DT S MW="M" + ; If not MAIL + I MW'="M" G QCMOP + S CMOP=1 + ; +QCMOP Q CMOP + ; +RXRLDT(RX,RFL) ; Returns the Rx Release Date + ; Input: (r) RX - Rx IEN (#52) + ; (o) RFL - Refill # (Default: most recent) + ; + ; Output: RXRLDT - Rx Release Date + N RXRLDT + I '$G(RX) Q "" + S RXRLDT=$$GET1^DIQ(52,RX,31,"I") + I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) + I RFL S RXRLDT=$$GET1^DIQ(52.1,RFL_","_RX,17,"I") + Q RXRLDT + ; +RXFLDT(RX,RFL) ; Returns the Rx Fill Date + ; Input: (r) RX - Rx IEN (#52) + ; (o) RFL - Refill # (Default: most recent) + ; Output: RXFLDT - Rx Fill Date + N RXFLDT + I '$G(RX) Q "" + S RXFLDT=$$GET1^DIQ(52,RX,22,"I") + I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) + I RFL S RXFLDT=$$GET1^DIQ(52.1,RFL_","_RX,.01,"I") + Q RXFLDT + ; +RXSUDT(RX,RFL) ; Returns the prescription/fill Suspense Date for the RX/Reject passed in + ;Input: (r) RX - Rx IEN (#52) + ; (o) RFL - Refill IEN (#52.1) + ;Output: SUSPENSE DATE (External format) or , if not suspended + ; + I $G(^PSRX(RX,"STA"))'=5 Q "" + N SURX,SURFL + S SURX=$O(^PS(52.5,"B",RX,0)) I 'SURX Q "" + I $$GET1^DIQ(52.5,SURX,.05,"I") Q "" + S SURFL=+$$GET1^DIQ(52.5,SURX,9) I RFL'=SURFL Q "" + Q $$GET1^DIQ(52.5,SURX,.02,"I") + ; +RXSITE(RX,RFL) ; Returns the Rx DIVISION + ; Input: (r) RX - Rx IEN (#52) + ; (o) RFL - Refill # + ; Output: SITE - Rx Fill Date + ; + N SITE + I '$G(RX) Q "" + I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) + I RFL S SITE=$$GET1^DIQ(52.1,RFL_","_RX,8,"I") + I 'RFL!'$G(SITE) S SITE=$$GET1^DIQ(52,RX,20,"I") + Q SITE + ; +MANREL(RX,RFL,PID) ; ePharmacy Manual Rx Release + ;Input: (r) RX - Rx IEN (#52) + ; (o) RFL - Refill # (Default: most recent) + ; (o) PID - Displays PID/Drug/Rx in the NDC prompts + ;Output: "" (null - OK to Release) OR "^" (User entered "^", or no valid NDC on file for ePharmacy Rx) + ; + N ACTION + ; + I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) + ; + ; - Checking for REJECTS before proceeding to Rx Release + I $$FIND^PSOREJUT(RX,RFL) D I ACTION="Q"!(ACTION="^") W ! Q "^" + . S ACTION=$$HDLG^PSOREJU1(RX,RFL,"79,88","ED","OIQ","Q") + ; + ; - ePharmacy switch is OFF + I '$$ECMEON^BPSUTIL($$RXSITE^PSOBPSUT(RX,RFL)) Q "" + ; + ; - Not an ePharmacy Rx + I $$STATUS^PSOBPSUT(RX,RFL)="" Q "" + ; + ; - NDC editing before Rx release + S ACTION=$$CHGNDC^PSONDCUT(RX,RFL,$G(PID)) I ACTION="^" D Q "^" + . W !!,$C(7),"A valid NDC must be entered before the Release function can be completed.",! H 1 + ; + ; - Checking for OPEN/UNRESOLVED 3rd. Party Payer Rejects (After possible NDC edit) + I $$FIND^PSOREJUT(RX,RFL) D I ACTION="Q"!(ACTION="^") W ! Q "^" + . S ACTION=$$HDLG^PSOREJU1(RX,RFL,"79,88","ED","OIQ","Q") + ; + ; - Notifying IB of a Rx RELEASE event + D RELEASE^PSOBPSU1(RX,RFL,DUZ) + ; + Q "" + ; +AUTOREL(RX,RFL,RLDT,NDC,SRC,STS,HNG) ; Sends Rx Release information to ECME/IB and updates NDC + ; in the DRUG/PRESCRIPTION files + ;Input: (r) RX - Rx IEN (#52) + ; (o) RFL - Refill # (Default: most recent) + ; (r) RLDT- Release Date + ; (r) NDC - NDC Number (Must be 11 digits) + ; (o) SRC - SOURCE: "C" - CMOP / "A" - OPAI + ; (o) STS - Status: (S)uccessful/(U)nsuccessful Release (Default: "S" - Successful) + ; (o) HNG - HANG time after resubmission and before checking the status of the claim (Default: 0) + ; + N RXNDC,SITE + ; + I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) + ; + S:'$D(STS) STS="S" S:'$D(SRC) SRC="" S HNG=+$G(HNG) + S RXNDC=$$GETNDC^PSONDCUT(RX,RFL) + ; + ; - Saves the NDC from CMOP/Automated Dispensing Machine in the Prescription file + I $$NDCFMT^PSSNDCUT(NDC)'="" D SAVNDC^PSONDCUT(RX,RFL,$$NDCFMT^PSSNDCUT(NDC),$S(SRC="C":1,1:0)) + ; + ; - Not an ePharmacy Rx + I $$STATUS^PSOBPSUT(RX,RFL)="" Q "" + ; + ; - Unsuccessful Release + I STS="U" D Q + . D REVERSE^PSOBPSU1(RX,RFL,"CRLX",,"UNSUCCESSFUL "_$S(SRC="C":"CMOP",1:"EXT INTERFACE")_" RELEASE",1) + ; + ; - Notifying IB of a Rx RELEASE event + D RELEASE^PSOBPSU1(RX,RFL) + ; + ; - Invalid NDC from Automated Dispensing Machine + I SRC="A",$$NDCFMT^PSSNDCUT(NDC)="" D Q + . D REVERSE^PSOBPSU1(RX,RFL,"CRLR",,"INVALID EXT INTERFACE NDC",1,NDC) + ; + ; - Invalid NDC number for CMOP + I SRC="C",$$NDCFMT^PSSNDCUT(NDC)="" D Q + . D REVERSE^PSOBPSU1(RX,RFL,"CRLR",,"INVALID CMOP NDC",1,NDC) + ; + ; - If NDC not equal RXNDC, issue reversal and submit new claim + I SRC="A",$$NDCFMT^PSSNDCUT(NDC)'=RXNDC D Q + . D ECMESND^PSOBPSU1(RX,RFL,RLDT,"CRLB",$$NDCFMT^PSSNDCUT(NDC),,"AUTO RELEASE",,1,,1) + . H HNG + . ; - If new claim returned PAYABLE, save new NDC in the DRUG/PRESCRIPTION files + . I $$STATUS^PSOBPSUT(RX,RFL)="E PAYABLE" D SAVNDC^PSONDCUT(RX,RFL,$$NDCFMT^PSSNDCUT(NDC),0,1) + ; + ; - If NDC not equal RXNDC, issue reversal and submit new claim + I SRC="C",$$NDCFMT^PSSNDCUT(NDC)'=RXNDC D Q + . ; - Reverse/Resubmit with correct NDC + . D ECMESND^PSOBPSU1(RX,RFL,RLDT,"CRLB",$$NDCFMT^PSSNDCUT(NDC),1,"CMOP RELEASE",,1,,1) + . ; - Wait for a response from the Payer for the submission above + . H HNG + . ; - If new claim returned PAYABLE, save new NDC in the DRUG/PRESCRIPTION files + . I $$STATUS^PSOBPSUT(RX,RFL)="E PAYABLE" D SAVNDC^PSONDCUT(RX,RFL,$$NDCFMT^PSSNDCUT(NDC),1,1) + ; + ; - Calls ECME api responsible for notifying IB to create a BILL + D IBSEND(RX,RFL) + ; + Q + ; +IBSEND(RX,RFL) ; Rx Release: Calls ECME, which will call IB to create a bill + ;Input: (r) RX - Rx IEN (#52) + ; (o) RFL - Refill # (Default: most recent) + ; + I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) + ; + ; - ECME turned OFF for Rx's site + I '$$ECMEON^BPSUTIL($$RXSITE^PSOBPSUT(RX,RFL)) Q + ; + ; - Not an ePharmacy Rx + I $$STATUS^PSOBPSUT(RX,RFL)="" Q "" + ; + ; - Calls ECME previously reversed, re-submit the claim to the payer + I $$STATUS^PSOBPSUT(RX,RFL)="E REVERSAL ACCEPTED"!($$STATUS^PSOBPSUT(RX,RFL)="IN PROGRESS") D Q + . D ECMESND^PSOBPSU1(RX,RFL,$$RXRLDT^PSOBPSUT(RX,RFL),"RRL") + ; + ; - Notifying ECME of a BILLING event + I $$STATUS^PSOBPSUT(RX,RFL)="E PAYABLE" D Q + . N PSOCLAIM S PSOCLAIM=$$CLAIM^BPSBUTL(RX,RFL) + . D IBSEND^BPSECMP2($P(PSOCLAIM,"^",2),$P(PSOCLAIM,"^",3),"BILL",DUZ) + ; + Q + ; +RETRX(RX,RFL) ; - Re-transmit a claim for the prescription/fill? + ;Input: (r) RX - Rx IEN (#52) + ; (o) RFL - Refill # (Default: most recent) + ;Output: 1 - Re-transmit / 0 - Don't re-transmit + I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX) + ; + I RFL Q +$$GET1^DIQ(52.1,RFL_","_RX,82,"I") + Q +$$GET1^DIQ(52,RX,82,"I") diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOBUILD.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOBUILD.m index d1da921f..906c31e1 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOBUILD.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOBUILD.m @@ -1,92 +1,92 @@ -PSOBUILD ;IHS/DSD/JCM - BUILD ARRAY OF PATIENTS CURRENT MEDS [ 07/15/96 5:25 PM ] ;6/21/07 8:20am - ;;7.0;OUTPATIENT PHARMACY;**23,82,119,132,235,206**;DEC 1997;Build 39 - ;External reference ^PS(50.606 supported by DBIA 2174 - ;External reference ^PS(50.7 supported by DBIA 2223 - ;External reference ^PS(55 supported by DBIA 2228 - ;External reference ^PSDRUG( supported by DBIA 221 - ; Input variables: PSODFN,DT,PSODTCUT -START N ORD K PSOSD I '$D(PSODFN)!('$D(DT)) G END - D EOJ,INIT G:PSOQFLG END D BUILD - S STA="ACTIVE^NON-VERIFIED^REFILL^HOLD^NON-VERIFIED^ACTIVE^^^^^^ACTIVE^DISCONTINUED^^DISCONTINUED^DISCONTINUED^HOLD" - S DRG="" F I=0:0 S DRG=$O(PSOSD(DRG)) Q:DRG="" I $G(PSOSD(DRG))]"" S PSOSD($P(STA,"^",$P(PSOSD(DRG),"^",2)+1),DRG)=PSOSD(DRG) D K PSOSD(DRG) - .S $P(PSOSD($P(STA,"^",$P(PSOSD(DRG),"^",2)+1),DRG),"^",9)=$G(^TMP("PS",$J,$P(STA,"^",$P(PSOSD(DRG),"^",2)+1),DRG)) - F PEN=0:0 S PEN=$O(^PS(52.41,"P",PSODFN,PEN)) Q:'PEN S ORD=^PS(52.41,PEN,0),PSOOI=$P(ORD,"^",8),PSODD=+$P(ORD,"^",9) D:$P(ORD,"^",3)'="DC"&($P(ORD,"^",3)'="DE")&($P(ORD,"^",3)'="HD") - .S DRG=$S(PSODD:$P($G(^PSDRUG(PSODD,0)),"^"),+PSOOI&('PSODD):$P(^PS(50.7,+PSOOI,0),"^")_" "_$P(^PS(50.606,$P(^PS(50.7,+PSOOI,0),"^",2),0),"^"),1:"") Q:DRG']"" - .I $D(PSOSD("PENDING",DRG)) S DRG=DRG_"^"_PEN - .S PSOSD("PENDING",DRG)="*****^17^Z^Z^"_$S(PSODD:$P(^PSDRUG(PSODD,0),"^",2),1:"")_"^"_$P(^PS(52.41,PEN,0),"^",11)_"^"_$S($G(^PSDRUG(PSODD,"ND"))]"":+^("ND")_"A"_$P(^("ND"),"^",3),1:"") - .S PSOSD("PENDING",DRG)=PSOSD("PENDING",DRG)_"^"_$P(ORD,"^",10)_"^"_$P(ORD,"^",6)_"^"_PEN_"^"_$S($G(PSODD):$G(PSODD),1:""),PSOSD=+$G(PSOSD)+1 K PSOOI,PSODD - F NVA=0:0 S NVA=$O(^PS(55,PSODFN,"NVA",NVA)) Q:'NVA S NON=^PS(55,PSODFN,"NVA",NVA,0) D:'$P(^PS(55,PSODFN,"NVA",NVA,0),"^",7) - .S PSODD=$P(NON,"^",2),PSOOI=$P(NON,"^") - .S DRG=$S(PSODD:$P($G(^PSDRUG(PSODD,0)),"^"),+PSOOI&('PSODD):$P(^PS(50.7,+PSOOI,0),"^")_" "_$P(^PS(50.606,$P(^PS(50.7,+PSOOI,0),"^",2),0),"^"),1:"") - .I $D(PSOSD("ZNONVA",DRG)) S DRG=DRG_"^"_NVA - .S PSOSD("ZNONVA",DRG)="****^9^Z^Z^"_$S($P(NON,"^",2):$P(^PSDRUG($P(NON,"^",2),0),"^",2),1:"")_"^"_$P(NON,"^",3)_"^^"_$P(NON,"^",5)_"^"_$P(NON,"^",10)_"^"_NVA_"^"_$P(NON,"^",2) - .I $P(NON,"^",2) S $P(PSOSD("ZNONVA",DRG),"^",7)=$S($G(^PSDRUG(PSODD,"ND"))]"":+^("ND")_"A"_$P(^("ND"),"^",3),1:"") - .S PSOSD=+$G(PSOSD)+1 -END D EOJ - Q -INIT ; - K PSOSD,PSOMED S PSOQFLG=0,U="^",PSOBUILD("COUNT")=0 G:$D(PSODTCUT) INITX - I '$D(^PS(53,"B","OUTPATIENT")) S PSOQFLG=1 G INITX - S PSOX=$O(^PS(53,"B","OUTPATIENT","")) I 'PSOX S PSOQFLG=1 G INITX - ;S DAYS=$S($D(DAYS360):360,1:45),X2=-$S($P($G(^PS(53,PSOX,0)),"^",3)+15>DAYS:$P($G(^(0)),"^",3)+15,1:DAYS),X1=DT D C^%DTC S PSODTCUT=X - S X2=-120,X1=DT D C^%DTC S PSODTCUT=X -INITX K X,X1,X2,PSOX - Q - ; -BUILD ;build profiles - F PSOEXPDT=(PSODTCUT-1):0 S PSOEXPDT=$O(^PS(55,PSODFN,"P","A",PSOEXPDT)) Q:'PSOEXPDT F PSOBUILD("RX")=0:0 S PSOBUILD("RX")=$O(^PS(55,PSODFN,"P","A",PSOEXPDT,PSOBUILD("RX"))) Q:'PSOBUILD("RX") I $D(^PSRX(PSOBUILD("RX"),0)) D GET -BUILDX I PSOBUILD("COUNT")>0 S PSOSD=PSOBUILD("COUNT") - Q -GET ;data for profiles - Q:'$P(^PSRX(PSOBUILD("RX"),0),"^",2) - S (PSOSTF,PSOSTN)="",PSORX0=^PSRX(PSOBUILD("RX"),0),PSOST0=+^PSRX(PSOBUILD("RX"),"STA"),$P(PSORX0,"^",15)=PSOST0 - G:PSOST0=13 GETX S PSORX2=$G(^PSRX(PSOBUILD("RX"),2)) - S PSORX3=$G(^PSRX(PSOBUILD("RX"),3)) S:PSORX3="" PSORX3=$P(PSORX2,"^",2) - S PSODRG=+$P(PSORX0,"^",6) G:'$D(^PSDRUG(PSODRG,0)) GETX S PSODRUG0=^PSDRUG(PSODRG,0),PSOVACL=$P(PSODRUG0,"^",2),PSODYS=$P(PSORX0,"^",8) - ; - I PSOST0<12!(PSOST0=16),PSOEXPDT
^("I") S PSOSTN=PSOSTN_"A" I $P($G(PSOPAR),"^",11)']"" S PSOSTF=PSOSTF_"A" - S PSONDF=$S($G(^PSDRUG(PSODRG,"ND"))]"":+^("ND")_"A"_$P(^("ND"),"^",3),1:0) - I $P($G(^PSDRUG(PSODRG,2)),"^",3)'["O" S PSOSTN=PSOSTN_"M" - S CLOZPT=$S($P($G(^PSDRUG(PSODRG,"CLOZ1")),"^")="PSOCLO1":1,1:0) - I 'CLOZPT,($P(PSODRUG0,"^",3)["A")&($P(PSODRUG0,"^",3)'["B") S PSOSTN=PSOSTN_"B",PSOSTF=PSOSTF_"B" - K CLOZPT I ($P(PSODRUG0,"^",3)["W")!($P(PSODRUG0,"^",3)[1)!($P(PSODRUG0,"^",3)[2) S PSOSTN=PSOSTN_"C" - I $D(^PS(53,+$P(PSORX0,"^",3),0)),'$P(^(0),"^",5) S PSOSTN=PSOSTN_"D" - I PSOST0=1 S PSOSTN=PSOSTN_"E" - S PSOLC=$P(PSORX0,"^"),PSOLC=$E(PSOLC,$L(PSOLC)) I $A(PSOLC)>90 S PSOSTN=PSOSTN_"F" - I PSOST0,PSOST0'=2,PSOST0'=6 S PSOSTF=PSOSTF_"Z" - I $G(PSORX("BAR CODE")),PSOST0,PSOST0'=2,PSOST0'=5,PSOST0'=6,PSOST0'=11,PSOST0'=12 S PSOSTN=PSOSTN_"Z" G BARC - I PSOST0,PSOST0'=2,PSOST0'=5,PSOST0'=6,PSOST0'=11,PSOST0'=12,PSOST0'=14 S PSOSTN=PSOSTN_"Z" -BARC S PSORFRM=$P(PSORX0,"^",9) F PSOJ=0:0 S PSOJ=$O(^PSRX(PSOBUILD("RX"),1,PSOJ)) Q:'PSOJ S PSORFRM=PSORFRM-1 - S:PSORFRM<0 PSORFRM=0 S:PSORFRM=0 PSOSTF=PSOSTF_"G" - S PSODRUGN=$P(PSODRUG0,"^") I $D(PSOSD(PSODRUGN)),PSOST0>10 Q:$P(PSOSD(PSODRUGN),"^",2)<11 Q:$P(PSOSD(PSODRUGN),"^",2)>10&($P(PSORX0,"^",13)<$P(^PSRX(+$P(PSOSD(PSODRUGN),"^"),0),"^",13)) - S:'$D(PSOSD(PSODRUGN)) PSOBUILD("COUNT")=PSOBUILD("COUNT")+1 - I $D(PSOSD(PSODRUGN)),$P(PSOSD(PSODRUGN),"^",2)<10,PSOST0<10 S PSOSD(PSODRUGN_"^"_PSOBUILD("RX"))=PSOBUILD("RX")_"^"_PSOST0_"^"_PSOSTN_"^"_PSOSTF_"^"_PSOVACL_"^"_PSORFRM_"^"_PSONDF_"^"_PSODYS,PSOBUILD("COUNT")=PSOBUILD("COUNT")+1 - E S PSOSD(PSODRUGN)=PSOBUILD("RX")_"^"_PSOST0_"^"_PSOSTN_"^"_PSOSTF_"^"_PSOVACL_"^"_PSORFRM_"^"_PSONDF_"^"_PSODYS -GETX Q -STAT N X S X=+$O(^PS(52.5,"B",PSOBUILD("RX"),0)) - I X,$D(^PS(52.5,X,0)),$P($G(^PS(52.5,X,0)),"^",7)'="X",'$G(^PS(52.5,X,"P")) S PSOST0=5 - I PSOST0 D FSTA - Q -FSTA S $P(PSORX0,"^",15)=PSOST0 - N DIE,DR,DA S DIE=52,DA=PSOBUILD("RX"),DR="100////"_PSOST0 D ^DIE K DIE,DR,DA - Q - ; -EOJ K ORD,PSOX,PSOEXPDT,PSODRG,PSODRUG0,PSOLC,PSONDF,PSOQFLG,PSORFRM,PSORX0,PSORX2,PSORX3,PSOST0,PSOSTF,PSOSTN,PSOJ,PSODRUGN,PSOVACL,PSOBUILD,PSODYS,PEN,DRG,NON,NVA - Q -INPAT(PSODFN) ;entry point for inpat meds to view patient's outpat. meds - D FULL^VALM1 - S INPAT=1,X2=-120,X1=DT D C^%DTC S PSODTCUT=X D START,^PSODSPL - K PSOSD,DDH,PSCNT,PSOCT,PSODD,PSOOI,PSOPAR,PSOSTA,STP,STR,PSODTCUT,PSODFN,INPAT,DRG - Q +PSOBUILD ;IHS/DSD/JCM - BUILD ARRAY OF PATIENTS CURRENT MEDS [ 07/15/96 5:25 PM ] + ;;7.0;OUTPATIENT PHARMACY;**23,82,119,132,235**;DEC 1997 + ;External reference ^PS(50.606 supported by DBIA 2174 + ;External reference ^PS(50.7 supported by DBIA 2223 + ;External reference ^PS(55 supported by DBIA 2228 + ;External reference ^PSDRUG( supported by DBIA 221 + ; Input variables: PSODFN,DT,PSODTCUT +START N ORD K PSOSD I '$D(PSODFN)!('$D(DT)) G END + D EOJ,INIT G:PSOQFLG END D BUILD + S STA="ACTIVE^NON-VERIFIED^REFILL^HOLD^NON-VERIFIED^ACTIVE^^^^^^ACTIVE^DISCONTINUED^^DISCONTINUED^DISCONTINUED^HOLD" + S DRG="" F I=0:0 S DRG=$O(PSOSD(DRG)) Q:DRG="" I $G(PSOSD(DRG))]"" S PSOSD($P(STA,"^",$P(PSOSD(DRG),"^",2)+1),DRG)=PSOSD(DRG) D K PSOSD(DRG) + .S $P(PSOSD($P(STA,"^",$P(PSOSD(DRG),"^",2)+1),DRG),"^",9)=$G(^TMP("PS",$J,$P(STA,"^",$P(PSOSD(DRG),"^",2)+1),DRG)) + F PEN=0:0 S PEN=$O(^PS(52.41,"P",PSODFN,PEN)) Q:'PEN S ORD=^PS(52.41,PEN,0),PSOOI=$P(ORD,"^",8),PSODD=+$P(ORD,"^",9) D:$P(ORD,"^",3)'="DC"&($P(ORD,"^",3)'="DE")&($P(ORD,"^",3)'="HD") + .S DRG=$S(PSODD:$P($G(^PSDRUG(PSODD,0)),"^"),+PSOOI&('PSODD):$P(^PS(50.7,+PSOOI,0),"^")_" "_$P(^PS(50.606,$P(^PS(50.7,+PSOOI,0),"^",2),0),"^"),1:"") Q:DRG']"" + .I $D(PSOSD("PENDING",DRG)) S DRG=DRG_"^"_PEN + .S PSOSD("PENDING",DRG)="*****^17^Z^Z^"_$S(PSODD:$P(^PSDRUG(PSODD,0),"^",2),1:"")_"^"_$P(^PS(52.41,PEN,0),"^",11)_"^"_$S($G(^PSDRUG(PSODD,"ND"))]"":+^("ND")_"A"_$P(^("ND"),"^",3),1:"") + .S PSOSD("PENDING",DRG)=PSOSD("PENDING",DRG)_"^"_$P(ORD,"^",10)_"^"_$P(ORD,"^",6)_"^"_PEN_"^"_$S($G(PSODD):$G(PSODD),1:""),PSOSD=+$G(PSOSD)+1 K PSOOI,PSODD + F NVA=0:0 S NVA=$O(^PS(55,PSODFN,"NVA",NVA)) Q:'NVA S NON=^PS(55,PSODFN,"NVA",NVA,0) D:'$P(^PS(55,PSODFN,"NVA",NVA,0),"^",7) + .S PSODD=$P(NON,"^",2),PSOOI=$P(NON,"^") + .S DRG=$S(PSODD:$P($G(^PSDRUG(PSODD,0)),"^"),+PSOOI&('PSODD):$P(^PS(50.7,+PSOOI,0),"^")_" "_$P(^PS(50.606,$P(^PS(50.7,+PSOOI,0),"^",2),0),"^"),1:"") + .I $D(PSOSD("ZNONVA",DRG)) S DRG=DRG_"^"_NVA + .S PSOSD("ZNONVA",DRG)="****^9^Z^Z^"_$S($P(NON,"^",2):$P(^PSDRUG($P(NON,"^",2),0),"^",2),1:"")_"^"_$P(NON,"^",3)_"^^"_$P(NON,"^",5)_"^"_$P(NON,"^",10)_"^"_NVA_"^"_$P(NON,"^",2) + .I $P(NON,"^",2) S $P(PSOSD("ZNONVA",DRG),"^",7)=$S($G(^PSDRUG(PSODD,"ND"))]"":+^("ND")_"A"_$P(^("ND"),"^",3),1:"") + .S PSOSD=+$G(PSOSD)+1 +END D EOJ + Q +INIT ; + K PSOSD,PSOMED S PSOQFLG=0,U="^",PSOBUILD("COUNT")=0 G:$D(PSODTCUT) INITX + I '$D(^PS(53,"B","OUTPATIENT")) S PSOQFLG=1 G INITX + S PSOX=$O(^PS(53,"B","OUTPATIENT","")) I 'PSOX S PSOQFLG=1 G INITX + ;S DAYS=$S($D(DAYS360):360,1:45),X2=-$S($P($G(^PS(53,PSOX,0)),"^",3)+15>DAYS:$P($G(^(0)),"^",3)+15,1:DAYS),X1=DT D C^%DTC S PSODTCUT=X + S X2=-120,X1=DT D C^%DTC S PSODTCUT=X +INITX K X,X1,X2,PSOX + Q + ; +BUILD ;build profiles + F PSOEXPDT=(PSODTCUT-1):0 S PSOEXPDT=$O(^PS(55,PSODFN,"P","A",PSOEXPDT)) Q:'PSOEXPDT F PSOBUILD("RX")=0:0 S PSOBUILD("RX")=$O(^PS(55,PSODFN,"P","A",PSOEXPDT,PSOBUILD("RX"))) Q:'PSOBUILD("RX") I $D(^PSRX(PSOBUILD("RX"),0)) D GET +BUILDX I PSOBUILD("COUNT")>0 S PSOSD=PSOBUILD("COUNT") + Q +GET ;data for profiles + Q:'$P(^PSRX(PSOBUILD("RX"),0),"^",2) + S (PSOSTF,PSOSTN)="",PSORX0=^PSRX(PSOBUILD("RX"),0),PSOST0=+^PSRX(PSOBUILD("RX"),"STA"),$P(PSORX0,"^",15)=PSOST0 + G:PSOST0=13 GETX S PSORX2=$G(^PSRX(PSOBUILD("RX"),2)) + S PSORX3=$G(^PSRX(PSOBUILD("RX"),3)) S:PSORX3="" PSORX3=$P(PSORX2,"^",2) + S PSODRG=+$P(PSORX0,"^",6) G:'$D(^PSDRUG(PSODRG,0)) GETX S PSODRUG0=^PSDRUG(PSODRG,0),PSOVACL=$P(PSODRUG0,"^",2),PSODYS=$P(PSORX0,"^",8) + ; + I PSOST0<12,PSOEXPDT
^("I") S PSOSTN=PSOSTN_"A" I $P($G(PSOPAR),"^",11)']"" S PSOSTF=PSOSTF_"A" + S PSONDF=$S($G(^PSDRUG(PSODRG,"ND"))]"":+^("ND")_"A"_$P(^("ND"),"^",3),1:0) + I $P($G(^PSDRUG(PSODRG,2)),"^",3)'["O" S PSOSTN=PSOSTN_"M" + S CLOZPT=$S($P($G(^PSDRUG(PSODRG,"CLOZ1")),"^")="PSOCLO1":1,1:0) + I 'CLOZPT,$P(PSODRUG0,"^",3)["A",$P(PSODRUG0,"^",3)'["B" S PSOSTN=PSOSTN_"B",PSOSTF=PSOSTF_"B" + K CLOZPT I $P(PSODRUG0,"^",3)["W" S PSOSTN=PSOSTN_"C" + I $D(^PS(53,+$P(PSORX0,"^",3),0)),'$P(^(0),"^",5) S PSOSTN=PSOSTN_"D" + I PSOST0=1 S PSOSTN=PSOSTN_"E" + S PSOLC=$P(PSORX0,"^"),PSOLC=$E(PSOLC,$L(PSOLC)) I $A(PSOLC)>90 S PSOSTN=PSOSTN_"F" + I PSOST0,PSOST0'=2,PSOST0'=6 S PSOSTF=PSOSTF_"Z" + I $G(PSORX("BAR CODE")),PSOST0,PSOST0'=2,PSOST0'=5,PSOST0'=6,PSOST0'=11,PSOST0'=12 S PSOSTN=PSOSTN_"Z" G BARC + I PSOST0,PSOST0'=2,PSOST0'=5,PSOST0'=6,PSOST0'=11,PSOST0'=12,PSOST0'=14 S PSOSTN=PSOSTN_"Z" +BARC S PSORFRM=$P(PSORX0,"^",9) F PSOJ=0:0 S PSOJ=$O(^PSRX(PSOBUILD("RX"),1,PSOJ)) Q:'PSOJ S PSORFRM=PSORFRM-1 + S:PSORFRM<0 PSORFRM=0 S:PSORFRM=0 PSOSTF=PSOSTF_"G" + S PSODRUGN=$P(PSODRUG0,"^") I $D(PSOSD(PSODRUGN)),PSOST0>10 Q:$P(PSOSD(PSODRUGN),"^",2)<11 Q:$P(PSOSD(PSODRUGN),"^",2)>10&($P(PSORX0,"^",13)<$P(^PSRX(+$P(PSOSD(PSODRUGN),"^"),0),"^",13)) + S:'$D(PSOSD(PSODRUGN)) PSOBUILD("COUNT")=PSOBUILD("COUNT")+1 + I $D(PSOSD(PSODRUGN)),$P(PSOSD(PSODRUGN),"^",2)<10,PSOST0<10 S PSOSD(PSODRUGN_"^"_PSOBUILD("RX"))=PSOBUILD("RX")_"^"_PSOST0_"^"_PSOSTN_"^"_PSOSTF_"^"_PSOVACL_"^"_PSORFRM_"^"_PSONDF_"^"_PSODYS,PSOBUILD("COUNT")=PSOBUILD("COUNT")+1 + E S PSOSD(PSODRUGN)=PSOBUILD("RX")_"^"_PSOST0_"^"_PSOSTN_"^"_PSOSTF_"^"_PSOVACL_"^"_PSORFRM_"^"_PSONDF_"^"_PSODYS +GETX Q +STAT N X S X=+$O(^PS(52.5,"B",PSOBUILD("RX"),0)) + I X,$D(^PS(52.5,X,0)),$P($G(^PS(52.5,X,0)),"^",7)'="X",'$G(^PS(52.5,X,"P")) S PSOST0=5 + I PSOST0 D FSTA + Q +FSTA S $P(PSORX0,"^",15)=PSOST0 + N DIE,DR,DA S DIE=52,DA=PSOBUILD("RX"),DR="100////"_PSOST0 D ^DIE K DIE,DR,DA + Q + ; +EOJ K ORD,PSOX,PSOEXPDT,PSODRG,PSODRUG0,PSOLC,PSONDF,PSOQFLG,PSORFRM,PSORX0,PSORX2,PSORX3,PSOST0,PSOSTF,PSOSTN,PSOJ,PSODRUGN,PSOVACL,PSOBUILD,PSODYS,PEN,DRG,NON,NVA + Q +INPAT(PSODFN) ;entry point for inpat meds to view patient's outpat. meds + D FULL^VALM1 + S INPAT=1,X2=-120,X1=DT D C^%DTC S PSODTCUT=X D START,^PSODSPL + K PSOSD,DDH,PSCNT,PSOCT,PSODD,PSOOI,PSOPAR,PSOSTA,STP,STR,PSODTCUT,PSODFN,INPAT,DRG + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCAN2.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCAN2.m index b4df37ff..2470a1ca 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCAN2.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCAN2.m @@ -1,148 +1,148 @@ -PSOCAN2 ;BHAM ISC/JMB - modular rx cancel with speed ability drug check ; 10/23/06 11:30am - ;;7.0;OUTPATIENT PHARMACY;**8,18,62,46,88,164,235,148,259,281**;DEC 1997;Build 41 - ;External reference to ^PSDRUG supported by dbia 221 -REINS N DODR - I $P(^PSRX(DA,2),"^",6)
DT W $S('RFCNT:"Filled",1:"Refilled # "_LREF)_": "_XFDT,?32,"Printed: "_$S(LREF=RFCNT:XLPDT,1:"") - I W ?56,"Released:" I '$G(DODR) W !?5,"Placing Rx on suspense. Please wait..." D SUS - K DODR - Q -SUS ;Adds rec to suspense - S ACT=1,RXN=DA,RX0=^PSRX(DA,0),RXS=$O(^PS(52.5,"B",DA,0)) I RXS S DA=RXS,DIK="^PS(52.5," D ^DIK S DA=RXN - S RXP=$S($D(RXP):RXP,1:0),DIC="^PS(52.5,",DIC(0)="L",X=RXN,DIC("DR")=".02///"_FDT_";.03///"_$P(RX0,"^",2)_";.04///M;.05///"_RXP_";.06////"_$G(PSOSITE)_";2///0" K DD,DO D FILE^DICN - I +$G(Y),$G(RFCNT)'="" S $P(^PS(52.5,+Y,0),"^",13)=$G(RFCNT) - S DA=RXN,$P(^PSRX(DA,"STA"),"^")=5,LFD=$E($P(^PSRX(DA,3),"^"),4,5)_"-"_$E($P(^(3),"^"),6,7)_"-"_$E($P(^(3),"^"),2,3) - S ACOM="RX Placed on Suspense until "_LFD D AREC^PSOCAN1 S ST="SC",PHST="ZS" D EN^PSOHLSN1(DA,ST,PHST,ACOM) K ST,PHST - Q -DRGDRG ;Checks for drug/drug interaction, duplicate drug and class - Q:$P(^PSRX(DA,2),"^",6)
5 RFCNT=$G(RFCNT)+1 - S ACNT=$G(ACNT)+1 - D NOW^%DTC S ^PSRX(DA,"A",0)="^52.3DA^"_ACNT_"^"_ACNT S ^PSRX(DA,"A",ACNT,0)=%_"^R^"_DUZ_"^"_RFCNT_"^"_ACOM - K ^PSRX("APSOD",PSODFN,DA),ACNT,RFCNT,RF,% - S $P(^PSRX(DA,3),"^")=$P(^PSRX(DA,3),"^",5),$P(^(3),"^",2)=$P(^(3),"^",8) - S $P(^PSRX(DA,3),"^",5)="",$P(^(3),"^",8)="" - Q -NVER ;Called from PSOCAN3, needs DA defined - N PSONVC,PSONVCP,PSONVCC - S PSONVC="SC",PSONVCP="IP",PSONVCC="Put in non-verified status" D EN^PSOHLSN1(DA,PSONVC,PSONVCP,PSONVCC) - Q -RMB(IDX) ;remove Rx if found in array BBRX() (Bingo Board) - N ST4,ST5,ST6,K - S ST4=BBRX(IDX) Q:ST4'[(DA_",") - S ST6="" - F K=1:1 S ST5=$P(ST4,",",K) Q:'ST5 D - . S:ST5'=DA ST6=ST6_$S('ST6:"",1:",")_ST5 - . S:ST6]"" BBRX(IDX)=ST6_"," K:ST6="" BBRX(IDX) - I '$D(BBRX) K BINGCRT - Q +PSOCAN2 ;BHAM ISC/JMB - modular rx cancel with speed ability drug check ; 10/23/06 11:30am + ;;7.0;OUTPATIENT PHARMACY;**8,18,62,46,88,164,235,148,259**;DEC 1997;Build 5 + ;External reference to ^PSDRUG supported by dbia 221 +REINS N DODR + I $P(^PSRX(DA,2),"^",6)
DT W $S('RFCNT:"Filled",1:"Refilled # "_LREF)_": "_XFDT,?32,"Printed: "_$S(LREF=RFCNT:XLPDT,1:"") + I W ?56,"Released:" I '$G(DODR) W !?5,"Placing Rx on suspense. Please wait..." D SUS + K DODR + Q +SUS ;Adds rec to suspense + S ACT=1,RXN=DA,RX0=^PSRX(DA,0),RXS=$O(^PS(52.5,"B",DA,0)) I RXS S DA=RXS,DIK="^PS(52.5," D ^DIK S DA=RXN + S RXP=$S($D(RXP):RXP,1:0),DIC="^PS(52.5,",DIC(0)="L",X=RXN,DIC("DR")=".02///"_FDT_";.03///"_$P(RX0,"^",2)_";.04///M;.05///"_RXP_";.06////"_$G(PSOSITE)_";2///0" K DD,DO D FILE^DICN + I +$G(Y),$G(RFCNT)'="" S $P(^PS(52.5,+Y,0),"^",13)=$G(RFCNT) + S DA=RXN,$P(^PSRX(DA,"STA"),"^")=5,LFD=$E($P(^PSRX(DA,3),"^"),4,5)_"-"_$E($P(^(3),"^"),6,7)_"-"_$E($P(^(3),"^"),2,3) + S ACOM="RX Placed on Suspense until "_LFD D AREC^PSOCAN1 S ST="SC",PHST="ZS" D EN^PSOHLSN1(DA,ST,PHST,ACOM) K ST,PHST + Q +DRGDRG ;Checks for drug/drug interaction, duplicate drug and class + Q:$P(^PSRX(DA,2),"^",6)
5 RFCNT=$G(RFCNT)+1 + S ACNT=$G(ACNT)+1 + D NOW^%DTC S ^PSRX(DA,"A",0)="^52.3DA^"_ACNT_"^"_ACNT S ^PSRX(DA,"A",ACNT,0)=%_"^R^"_DUZ_"^"_RFCNT_"^"_ACOM + K ^PSRX("APSOD",PSODFN,DA),ACNT,RFCNT,RF,% + S $P(^PSRX(DA,3),"^")=$P(^PSRX(DA,3),"^",5),$P(^(3),"^",2)=$P(^(3),"^",8) + S $P(^PSRX(DA,3),"^",5)="",$P(^(3),"^",8)="" + Q +NVER ;Called from PSOCAN3, needs DA defined + N PSONVC,PSONVCP,PSONVCC + S PSONVC="SC",PSONVCP="IP",PSONVCC="Put in non-verified status" D EN^PSOHLSN1(DA,PSONVC,PSONVCP,PSONVCC) + Q +RMB(IDX) ;remove Rx if found in array BBRX() (Bingo Board) + N ST4,ST5,ST6,K + S ST4=BBRX(IDX) Q:ST4'[(DA_",") + S ST6="" + F K=1:1 S ST5=$P(ST4,",",K) Q:'ST5 D + . S:ST5'=DA ST6=ST6_$S('ST6:"",1:",")_ST5 + . S:ST6]"" BBRX(IDX)=ST6_"," K:ST6="" BBRX(IDX) + I '$D(BBRX) K BINGCRT + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCAN3.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCAN3.m index 54d24c05..5d16b8ee 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCAN3.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCAN3.m @@ -1,152 +1,164 @@ -PSOCAN3 ;BIR/RTR/SAB - auto dc rxs due to death ;9/18/06 2:59pm - ;;7.0;OUTPATIENT PHARMACY;**15,24,27,32,36,94,88,117,131,146,139,132,223,235,148,249,225**;DEC 1997;Build 29 - ;External reference to File #55 supported by DBIA 2228 - ;External references to L, UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789 - Q -APSOD(PSODFN) ;called from file #2 date of death xref 'APOSD' - N D,DA,DB,DC,DE,DG,DH,DI,DIC,DIE,DIG,DIH,DIK,DIR,DIQ,DIU,DIV,DIW,DK,DL,DM,DP,DQ,DU,DV,DW,DR - S PSODEATH=1 D CAN K PSODEATH - Q -CAN ;discontinued rxs due to death - I $G(PSODFN),$D(^PS(52.91,PSODFN,0)) D - .I '$P($G(^PS(52.91,PSODFN,0)),"^",3)!($P($G(^(0)),"^",3)>DT) S $P(^PS(52.91,PSODFN,0),"^",3)=DT,$P(^PS(52.91,PSODFN,0),"^",4)=5,^PS(52.91,"AX",DT,PSODFN)="" D SET^PSOTPCAN(PSODFN) - F PSORXJ=0:0 S PSORXJ=$O(^PS(55,PSODFN,"P",PSORXJ)) Q:'PSORXJ I $D(^(PSORXJ,0)) S PSORX=^(0) S STA=$S($P($G(^PSRX(PSORX,"STA")),"^")<11:1,$P($G(^("STA")),"^")=16:1,1:0) D:STA - .I $D(^PSRX(PSORX,0)),$P($G(^PSRX(PSORX,"STA")),"^")="" D SETC - .D REVERSE^PSOBPSU1(PSORX,,"DC",7) - .I $D(^PSRX(PSORX,0)),$P($G(^PSRX(PSORX,2)),"^",6)'
DT) S $P(^PS(52.91,PSODFN,0),"^",3)=DT,$P(^PS(52.91,PSODFN,0),"^",4)=5,^PS(52.91,"AX",DT,PSODFN)="" D SET^PSOTPCAN(PSODFN) + F PSORXJ=0:0 S PSORXJ=$O(^PS(55,PSODFN,"P",PSORXJ)) Q:'PSORXJ I $D(^(PSORXJ,0)) S PSORX=^(0) S STA=$S($P($G(^PSRX(PSORX,"STA")),"^")<11:1,$P($G(^("STA")),"^")=16:1,1:0) D:STA + .I $D(^PSRX(PSORX,0)),$P($G(^PSRX(PSORX,"STA")),"^")="" D SETC + .D REVERSE^PSOBPSU1(PSORX,,"DC",7) + .I $D(^PSRX(PSORX,0)),$P($G(^PSRX(PSORX,2)),"^",6)'
11),$P(^("STA"),"^")<16 S PSINV(EN)="" Q - .S DA=+YY I $P($G(^PSRX(DA,"STA")),"^")=11!($P($G(^(2)),"^",6)11),$P(^("STA"),"^")<16 S PSINV(EN)="" Q + .S DA=+YY I $P($G(^PSRX(DA,"STA")),"^")=11!($P($G(^(2)),"^",6)0 S:'$G(COUNTED) COUNTED=1,PSOVETS=PSOVETS+1 S PSOCNT(J,I)=PSOCNT(J,I)+COUNT - F I=1:1:3 S PSOCNT=PSOCNT+$G(PSOCNT("YR2004",I))+$G(PSOCNT("YR2005",I))+$G(PSOCNT("YR2006",I)) - ; - S (I,J)=-"" - I '$D(PSOCVETS) S PSOCVETS=0 - F I=1:1:3 S (PSOCCNT("YR2004",I),PSOCCNT("YR2005",I),PSOCCNT("YR2006",I))=0 - S PSODFN=0 F S PSODFN=$O(^XTMP(NAMSP,"TOT CAN",PSODFN)) Q:'PSODFN D - .S CCOUNTED=0 - .F J="YR2004","YR2005","YR2006" F I=1:1:3 S CCOUNT=$G(^XTMP(NAMSP,"TOT CAN",PSODFN,J,I)) I CCOUNT>0 S:'$G(CCOUNTED) CCOUNTED=1,PSOCVETS=PSOCVETS+1 S PSOCCNT(J,I)=PSOCCNT(J,I)+CCOUNT - F I=1:1:3 S PSOCCNT=PSOCCNT+$G(PSOCCNT("YR2004",I))+$G(PSOCCNT("YR2005",I))+$G(PSOCCNT("YR2006",I)) - ; - S (I,J)="" - I '$D(PSOUVETS) S PSOUVETS=0 - F I=1:1:3 S (PSOUCNT("YR2004",I),PSOUCNT("YR2005",I),PSOUCNT("YR2006",I))=0 - S PSOUDFN=0 F S PSOUDFN=$O(^XTMP(NAMSP,"TOT UNREL",PSOUDFN)) Q:'PSOUDFN D - .S UCOUNTED=0 - .F J="YR2004","YR2005","YR2006" F I=1:1:3 S UCOUNT=$G(^XTMP(NAMSP,"TOT UNREL",PSOUDFN,J,I)) I UCOUNT>0 S:'$G(UCOUNTED) UCOUNTED=1,PSOUVETS=PSOUVETS+1 S PSOUCNT(J,I)=PSOUCNT(J,I)+UCOUNT - F I=1:1:3 S PSOUCNT=PSOUCNT+$G(PSOUCNT("YR2004",I))+$G(PSOUCNT("YR2005",I))+$G(PSOUCNT("YR2006",I)) - ; - Q - ; -CHECK ;check for ICD and IB nodes - ; - N PSOREF,PSOIB,PSOOICD,PSOBILLD - S PSOREF=YY - S PSOOICD=$P($G(^PSRX(RXP,"ICD",1,0)),"^",2,8) - ; see if bill already exists - I PSOREF=0 D - . I +$P($G(^PSRX(RXP,"IB")),"^",2)>0 D CHKIB^PSOCP1 - . S PSOREL=$P($G(^PSRX(RXP,2)),"^",13) - I PSOREF>0 D - . I +$G(^PSRX(RXP,1,PSOREF,"IB")) D CHKIB^PSOCP1 - . S PSOREL=$P($G(^PSRX(RXP,1,YY,0)),"^",18) - I $G(PSOIB)=1!($G(PSOIB)=3) S PSOBILLD=1 - ; if billed/RELEASED and no IBQ node for both sc<50 and nsc - I $G(PSOBILLD)&('$D(^PSRX(RXP,"IBQ"))) D - . I $TR(PSOOICD,"^")[1 S ^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)=$P(PSOREL,".")_"^"_PSODT_"^"_PSOSCP - . I $TR(PSOOICD,"^")[0 S ^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)=$P(PSOREL,".")_"^"_PSODT_"^"_PSOSCP - ; find unbilled ones with an ICD node and no IBQ node. - I '$G(PSOBILLD)&('$D(^PSRX(RXP,"IBQ"))) D - . Q:$TR(PSOOICD,"^")="" - . S ^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)=$P(PSOREL,".")_"^"_PSODT_"^"_PSOSCP - I YY S PSOTRF=PSOTRF+1 - Q - ; -CANCEL ;Cancel erroneous copays/set IBQ node if not there - ;released rx's - N PSOCAP,PSODIV,PSODV,PSOFILL,PSOLOG,PSONAM,PSOOUT,PSOPAR,PSOPAR7,PSOSITE - N PSOSITE7,PSOSQ,PSOTOT,PSOYEAR,PSOYR,SSN,SAVCPUN,SAVREF,PSOIB,PSOOIBQ,PSONIBQ,PSOOICD,PSOOIB - N I,IFN,PSOANSQ,PSOTYP,COM,CC,PREA,PSONW,PSOOLD,PSOREL,PSO,PSOCPUN,PSOFLD,PSOTYPE,CANCEL - S PSOTYPE="CAN" - S PSODFN=0 F CC=1:1 S PSODFN=$O(^XTMP(NAMSP,"CANCEL",PSODFN)) Q:'PSODFN D Q:STOP - .I CC#100=0,$D(^XTMP(NAMSP,0,"STOP")) D Q - .. S $P(^XTMP(NAMSP,0,"LAST"),"^",1,2)="STOP^"_$$NOW^XLFDT,STOP=1 - .S (PSOCAP(304),PSOCAP(305),PSOCAP(306))=0 ; INITIAL ANNUAL CAP FOR 2004 & 2005 - .F RXP=0:0 S RXP=$O(^XTMP(NAMSP,"CANCEL",PSODFN,RXP)) Q:'RXP D - ..S (SAVCPUN,PSOCPUN)=($P(^PSRX(RXP,0),"^",8)+29)\30 - ..S YY="" F S YY=$O(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)) Q:YY="" D - ...S (SAVREF,PSOREF)=YY - ...; verify again that it was billed and not already cancelled - ...S PSOBILLD=0 - ...I YY=0,+$P($G(^PSRX(RXP,"IB")),"^",2)>0 D CHKIB^PSOCP1 I $G(PSOIB)=1!($G(PSOIB)=3) S PSOBILLD=1 - ...I YY>0,+$P($G(^PSRX(RXP,1,PSOREF,"IB")),"^")>0 D CHKIB^PSOCP1 I $G(PSOIB)=1!($G(PSOIB)=3) S PSOBILLD=1 - ...Q:'PSOBILLD - ...S PSOREL=$P($G(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)),"^"),PSOFLD=$P($G(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)),"^",2),PSOSCP=$P($G(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)),"^",3) - ...S PSO=3 D NOW^%DTC S PSODT=%,PSODA=RXP,PSOCOMM="-BKGD CIDC COPAY CANCEL",PSOOLD="",PSONW="",PREA="" - ...D CHKACT - ...S PSOIB="",PSOIB=$S(PSOREF>0:$G(^PSRX(RXP,1,YY,"IB")),'PSOREF:$G(^PSRX(PSODA,"IB")),1:"") - ...S (PSOOIBQ,PSOOICD,PSOOIB)="" - ...S PSOOICD=$P($G(^PSRX(RXP,"ICD",1,0)),"^",2,8),PSOOIB=$G(^PSRX(RXP,"IB")),PSOOIBQ=$G(^PSRX(RXP,"IBQ")) - ...I PSOOIBQ=""&($TR(PSOOICD,"^")[0!($TR(PSOOICD,"^")[1)) D SETIBQ - ...D SITE S PSOCOMM="-BKGD CIDC COPAY CANCEL" D RXED^PSOCPA S:PSOOICD[1&($D(^PSRX(RXP,"IB"))) $P(^PSRX(RXP,"IB"),"^")="" - ...S PSOCPUN=SAVCPUN,PSOREF=SAVREF - ...D ACCUM - ; - ;ICD NODES WITHOUT IBQ NODE; set IBQ node but only set 1st piece of IB node if unreleased. - S PSOTYP="IBQ" - S PSODFN=0 F CC=1:1 S PSODFN=$O(^XTMP(NAMSP,"NOIBQ",PSODFN)) Q:'PSODFN D Q:STOP - .I CC#100=0,$D(^XTMP(NAMSP,0,"STOP")) D Q - .. S $P(^XTMP(NAMSP,0,"LAST"),"^",1,2)="STOP^"_$$NOW^XLFDT,STOP=1 - .S (PSOCAP(304),PSOCAP(305),PSOCAP(306))=0 ; INITIAL ANNUAL CAP FOR 2004 & 2005 - .F RXP=0:0 S RXP=$O(^XTMP(NAMSP,"NOIBQ",PSODFN,RXP)) Q:'RXP D - ..S (SAVCPUN,PSOCPUN)=($P(^PSRX(RXP,0),"^",8)+29)\30 - ..S YY="" F S YY=$O(^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)) Q:YY="" D - ...S (SAVREF,PSOREF)=YY - ...D SITE - ...S PSOREL=$P($G(^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)),"^"),PSOFLD=$P($G(^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)),"^",2),PSOSCP=$P($G(^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)),"^",3) - ...S (PSOOIBQ,PSOOICD,PSOOIB)="" - ...S PSOOICD=$P($G(^PSRX(RXP,"ICD",1,0)),"^",2,8),PSOOIB=$G(^PSRX(RXP,"IB")),PSOOIBQ=$G(^PSRX(RXP,"IBQ")) - ...I PSOOIBQ=""&($TR(PSOOICD,"^")[0!($TR(PSOOICD,"^")[1)) D SETIBQ D ;don't want to set again if already did it as part of copay cancel - ....S I="",IFN=0 F I=0:0 S I=$O(^PSRX(RXP,"A",I)) Q:'I S IFN=I - ....S COM=" BKGD CIDC UPDATE" - ....D NOW^%DTC S IFN=IFN+1,^PSRX(RXP,"A",0)="^52.3DA^"_IFN_"^"_IFN,^PSRX(RXP,"A",IFN,0)=%_"^I^.5^"_YY_"^"_COM - ....K DA - ....S:PSOOICD[1&($D(^PSRX(RXP,"IB"))) $P(^PSRX(RXP,"IB"),"^")="" - ...D:'$G(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)) ACCUM - ...S PSOCPUN=SAVCPUN,PSOREF=SAVREF - Q - ; -CHKACT ;check activity log for prev entry - N ZACT,ZPSI,ZACTI - S ZPSI=0 F S ZPSI=$O(^PSRX(PSODA,"COPAY",ZPSI)) Q:ZPSI="" S ZACTI="",ZACTI=$G(^PSRX(PSODA,"COPAY",ZPSI,0)) D Q:$G(ZACT) - . I ZACTI["BKGD CIDC COPAY CANCEL"&($P(ZACTI,"^",2)="R") S PSOOLD="",PSONW="",PREA="C",ZACT=1 Q - I '$G(ZACT) S PSOOLD="Copay",PSONW="No Copay",PREA="R" K PSOREF D ACTLOG^PSOCPA S PSOREF=YY,PSOOLD="",PSONW="",PREA="C" - Q - ; -SETIBQ ; get data from IBQ node, set IBQ node, and 1st piece of IB node - K PSOANSQ - N PSONIBQ - F PSOTYP=1:1:8 D - . I PSOTYP=1 S PSOANSQ("VEH")=$P(PSOOICD,"^",PSOTYP) - . I PSOTYP=2 S PSOANSQ("RAD")=$P(PSOOICD,"^",PSOTYP) - . I PSOTYP=3 S PSOANSQ("SC")=$P(PSOOICD,"^",PSOTYP) - . I PSOTYP=4 S PSOANSQ("PGW")=$P(PSOOICD,"^",PSOTYP) - . I PSOTYP=5 S PSOANSQ("MST")=$P(PSOOICD,"^",PSOTYP) - . I PSOTYP=6 S PSOANSQ("HNC")=$P(PSOOICD,"^",PSOTYP) - . I PSOTYP=7 S PSOANSQ("CV")=$P(PSOOICD,"^",PSOTYP) - . I PSOTYP=8 S PSOANSQ("SHAD")=$P(PSOOICD,"^",PSOTYP) - S ^PSRX(RXP,"IBQ")=PSOANSQ("SC")_"^"_PSOANSQ("MST")_"^"_PSOANSQ("VEH")_"^"_PSOANSQ("RAD")_"^"_PSOANSQ("PGW")_"^"_PSOANSQ("HNC")_"^"_PSOANSQ("CV")_"^"_PSOANSQ("SHAD") - Q - ; -ACCUM ; ACCUMULATE TOTALS - S (PSOTOT,PSOYR,PSOYEAR,PSOLOG,PSONAM,PSOCHRG)="" - ; get finished, but unreleased totals - I PSOREL="" S PSOYR=$E(PSOFLD,1,3) Q:PSOYR="" D S PSOYEAR="" Q - .S PSOYEAR=$S(PSOYR="304":"YR2004",PSOYR="305":"YR2005",PSOYR="306":"YR2006",1:"") Q:PSOYEAR="" - .S PSOCHRG=7 - .I PSOYEAR="YR2006" S PSOCHRG=8 - .S PSOTOT=$G(^XTMP(NAMSP,"TOT UNREL",PSODFN,PSOYEAR)) - .S ^XTMP(NAMSP,"TOT UNREL",PSODFN,PSOYEAR)=PSOTOT+(PSOCPUN*PSOCHRG) - .S ^XTMP(NAMSP,"TOT UNREL",PSODFN,PSOYEAR,PSOCPUN)=$G(^XTMP(NAMSP,"TOT UNREL",PSODFN,PSOYEAR,PSOCPUN))+1 - .S PSONAM=$P($G(^DPT(PSODFN,0)),"^"),PSONAM=$P(PSONAM,",") - .S PSONAM=$E(PSONAM,1,6) - .S ^XTMP(NAMSP,"IBQ UPD",PSONAM,PSODFN,RXP,PSOREF)=PSOFLD - ;for released ones - S PSOYR=$E(PSOREL,1,3) - S:PSOYR'="" PSOYEAR=$S(PSOYR="304":"YR2004",PSOYR="305":"YR2005",PSOYR="306":"YR2006",1:"") - Q:PSOYEAR="" - S PSOCHRG=7 - I PSOYEAR="YR2006" S PSOCHRG=8 - ; - ;get Xtmp billing amt which would be IBAM tot + any previous refills - S PSOTOT=$G(^XTMP(NAMSP,"TOT REL",PSODFN,PSOYEAR)) - ; - ;if none yet then init to the IBAM total for the year - I 'PSOTOT D - .F PSOSQ=0:0 S PSOSQ=$O(^IBAM(354.7,PSODFN,1,PSOSQ)) Q:'PSOSQ D - ..S PSOLOG=$G(^IBAM(354.7,PSODFN,1,PSOSQ,0)) - ..I $E(PSOLOG,1,3)=PSOYR S PSOTOT=PSOTOT+$P(PSOLOG,"^",2) - ; - ;update Xtmp tot nodes with current fill amounts - ; note: cancel copays and updated IBQ node released prescription are collected under TOT REL for the RPT^PSOCIDC3 - ; routine. Cancelled copays are denoted with an asterisk. - S ^XTMP(NAMSP,"TOT REL",PSODFN,PSOYEAR)=PSOTOT+(PSOCPUN*PSOCHRG) - S ^XTMP(NAMSP,"TOT REL",PSODFN,PSOYEAR,PSOCPUN)=$G(^XTMP(NAMSP,"TOT REL",PSODFN,PSOYEAR,PSOCPUN))+1 - ; - ;indicate COPAY CANCEL for this fill - ; ;by adding to Xtmp "BILLED" - S PSONAM=$P($G(^DPT(PSODFN,0)),"^"),PSONAM=$P(PSONAM,",") - S PSONAM=$E(PSONAM,1,6) - S ^XTMP(NAMSP,"REL",PSONAM,PSODFN,RXP,PSOREF)=PSOREL - ; -CAN I PSOTYPE="CAN"&($G(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY))) N PSOFILL S CANCEL="" S PSOFILL=YY D CHK^PSOCIDC3 I CANCEL D - . S ^XTMP(NAMSP,"TOT CAN",PSODFN,PSOYEAR)=PSOTOT+(PSOCPUN*PSOCHRG) - . S ^XTMP(NAMSP,"TOT CAN",PSODFN,PSOYEAR,PSOCPUN)=$G(^XTMP(NAMSP,"TOT CAN",PSODFN,PSOYEAR,PSOCPUN))+1 - Q - ; -SITE ; SET UP VARIABLES NEEDED BY BILLING - S PSOSITE=$S(YY=0:$P(^PSRX(RXP,2),"^",9),1:$P($G(^PSRX(RXP,1,YY,0)),"^",9)) - Q:PSOSITE="" - S PSOPAR=$G(^PS(59,PSOSITE,1)) - S PSOPAR7=$G(^PS(59,PSOSITE,"IB")) - S PSOSITE7=$P($G(^PS(59,PSOSITE,"IB")),"^") - Q - ; +PSOCIDC2 ;BIR/LE-continuation of Copay Correction of erroneous billed copays ;11/8/05 12:50pm + ;;7.0;OUTPATIENT PHARMACY;**226**;DEC 1997 + ;External reference to ^XUSEC supported by DBIA 10076 + ;External reference to IBARX supported by DBIA 125 + ;External reference to $$PROD^XUPROD(1) supported by DBIA 4440 + ; +TOTAL ; + N COUNT,COUNTED,UCOUNT,UCOUNTED,CCOUNT,CCOUNTED + I '$D(PSOVETS) S PSOVETS=0 + N I,J + F I=1:1:3 S (PSOCNT("YR2004",I),PSOCNT("YR2005",I),PSOCNT("YR2006",I))=0 + S PSODFN=0 F S PSODFN=$O(^XTMP(NAMSP,"TOT REL",PSODFN)) Q:'PSODFN D + .S COUNTED=0 + .F J="YR2004","YR2005","YR2006" F I=1:1:3 S COUNT=$G(^XTMP(NAMSP,"TOT REL",PSODFN,J,I)) I COUNT>0 S:'$G(COUNTED) COUNTED=1,PSOVETS=PSOVETS+1 S PSOCNT(J,I)=PSOCNT(J,I)+COUNT + F I=1:1:3 S PSOCNT=PSOCNT+$G(PSOCNT("YR2004",I))+$G(PSOCNT("YR2005",I))+$G(PSOCNT("YR2006",I)) + ; + S (I,J)=-"" + I '$D(PSOCVETS) S PSOCVETS=0 + F I=1:1:3 S (PSOCCNT("YR2004",I),PSOCCNT("YR2005",I),PSOCCNT("YR2006",I))=0 + S PSODFN=0 F S PSODFN=$O(^XTMP(NAMSP,"TOT CAN",PSODFN)) Q:'PSODFN D + .S CCOUNTED=0 + .F J="YR2004","YR2005","YR2006" F I=1:1:3 S CCOUNT=$G(^XTMP(NAMSP,"TOT CAN",PSODFN,J,I)) I CCOUNT>0 S:'$G(CCOUNTED) CCOUNTED=1,PSOCVETS=PSOCVETS+1 S PSOCCNT(J,I)=PSOCCNT(J,I)+CCOUNT + F I=1:1:3 S PSOCCNT=PSOCCNT+$G(PSOCCNT("YR2004",I))+$G(PSOCCNT("YR2005",I))+$G(PSOCCNT("YR2006",I)) + ; + S (I,J)="" + I '$D(PSOUVETS) S PSOUVETS=0 + F I=1:1:3 S (PSOUCNT("YR2004",I),PSOUCNT("YR2005",I),PSOUCNT("YR2006",I))=0 + S PSOUDFN=0 F S PSOUDFN=$O(^XTMP(NAMSP,"TOT UNREL",PSOUDFN)) Q:'PSOUDFN D + .S UCOUNTED=0 + .F J="YR2004","YR2005","YR2006" F I=1:1:3 S UCOUNT=$G(^XTMP(NAMSP,"TOT UNREL",PSOUDFN,J,I)) I UCOUNT>0 S:'$G(UCOUNTED) UCOUNTED=1,PSOUVETS=PSOUVETS+1 S PSOUCNT(J,I)=PSOUCNT(J,I)+UCOUNT + F I=1:1:3 S PSOUCNT=PSOUCNT+$G(PSOUCNT("YR2004",I))+$G(PSOUCNT("YR2005",I))+$G(PSOUCNT("YR2006",I)) + ; + Q + ; +CHECK ;check for ICD and IB nodes + ; + N PSOREF,PSOIB,PSOOICD,PSOBILLD + S PSOREF=YY + S PSOOICD=$P($G(^PSRX(RXP,"ICD",1,0)),"^",2,8) + ; see if bill already exists + I PSOREF=0 D + . I +$P($G(^PSRX(RXP,"IB")),"^",2)>0 D CHKIB^PSOCP1 + . S PSOREL=$P($G(^PSRX(RXP,2)),"^",13) + I PSOREF>0 D + . I +$G(^PSRX(RXP,1,PSOREF,"IB")) D CHKIB^PSOCP1 + . S PSOREL=$P($G(^PSRX(RXP,1,YY,0)),"^",18) + I $G(PSOIB)=1!($G(PSOIB)=3) S PSOBILLD=1 + ; if billed/RELEASED and no IBQ node for both sc<50 and nsc + I $G(PSOBILLD)&('$D(^PSRX(RXP,"IBQ"))) D + . I $TR(PSOOICD,"^")[1 S ^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)=$P(PSOREL,".")_"^"_PSODT_"^"_PSOSCP + . I $TR(PSOOICD,"^")[0 S ^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)=$P(PSOREL,".")_"^"_PSODT_"^"_PSOSCP + ; find unbilled ones with an ICD node and no IBQ node. + I '$G(PSOBILLD)&('$D(^PSRX(RXP,"IBQ"))) D + . Q:$TR(PSOOICD,"^")="" + . S ^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)=$P(PSOREL,".")_"^"_PSODT_"^"_PSOSCP + I YY S PSOTRF=PSOTRF+1 + Q + ; +CANCEL ;Cancel erroneous copays/set IBQ node if not there + ;released rx's + N PSOCAP,PSODIV,PSODV,PSOFILL,PSOLOG,PSONAM,PSOOUT,PSOPAR,PSOPAR7,PSOSITE + N PSOSITE7,PSOSQ,PSOTOT,PSOYEAR,PSOYR,SSN,SAVCPUN,SAVREF,PSOIB,PSOOIBQ,PSONIBQ,PSOOICD,PSOOIB + N I,IFN,PSOANSQ,PSOTYP,COM,CC,PREA,PSONW,PSOOLD,PSOREL,PSO,PSOCPUN,PSOFLD,PSOTYPE,CANCEL + S PSOTYPE="CAN" + S PSODFN=0 F CC=1:1 S PSODFN=$O(^XTMP(NAMSP,"CANCEL",PSODFN)) Q:'PSODFN D Q:STOP + .I CC#100=0,$D(^XTMP(NAMSP,0,"STOP")) D Q + .. S $P(^XTMP(NAMSP,0,"LAST"),"^",1,2)="STOP^"_$$NOW^XLFDT,STOP=1 + .S (PSOCAP(304),PSOCAP(305),PSOCAP(306))=0 ; INITIAL ANNUAL CAP FOR 2004 & 2005 + .F RXP=0:0 S RXP=$O(^XTMP(NAMSP,"CANCEL",PSODFN,RXP)) Q:'RXP D + ..S (SAVCPUN,PSOCPUN)=($P(^PSRX(RXP,0),"^",8)+29)\30 + ..S YY="" F S YY=$O(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)) Q:YY="" D + ...S (SAVREF,PSOREF)=YY + ...; verify again that it was billed and not already cancelled + ...S PSOBILLD=0 + ...I YY=0,+$P($G(^PSRX(RXP,"IB")),"^",2)>0 D CHKIB^PSOCP1 I $G(PSOIB)=1!($G(PSOIB)=3) S PSOBILLD=1 + ...I YY>0,+$P($G(^PSRX(RXP,1,PSOREF,"IB")),"^")>0 D CHKIB^PSOCP1 I $G(PSOIB)=1!($G(PSOIB)=3) S PSOBILLD=1 + ...Q:'PSOBILLD + ...S PSOREL=$P($G(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)),"^"),PSOFLD=$P($G(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)),"^",2),PSOSCP=$P($G(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)),"^",3) + ...S PSO=3 D NOW^%DTC S PSODT=%,PSODA=RXP,PSOCOMM="-BKGD CIDC COPAY CANCEL",PSOOLD="",PSONW="",PREA="" + ...D CHKACT + ...S PSOIB="",PSOIB=$S(PSOREF>0:$G(^PSRX(RXP,1,YY,"IB")),'PSOREF:$G(^PSRX(PSODA,"IB")),1:"") + ...S (PSOOIBQ,PSOOICD,PSOOIB)="" + ...S PSOOICD=$P($G(^PSRX(RXP,"ICD",1,0)),"^",2,8),PSOOIB=$G(^PSRX(RXP,"IB")),PSOOIBQ=$G(^PSRX(RXP,"IBQ")) + ...I PSOOIBQ=""&($TR(PSOOICD,"^")[0!($TR(PSOOICD,"^")[1)) D SETIBQ + ...D SITE S PSOCOMM="-BKGD CIDC COPAY CANCEL" D RXED^PSOCPA S:PSOOICD[1&($D(^PSRX(RXP,"IB"))) $P(^PSRX(RXP,"IB"),"^")="" + ...S PSOCPUN=SAVCPUN,PSOREF=SAVREF + ...D ACCUM + ; + ;ICD NODES WITHOUT IBQ NODE; set IBQ node but only set 1st piece of IB node if unreleased. + S PSOTYP="IBQ" + S PSODFN=0 F CC=1:1 S PSODFN=$O(^XTMP(NAMSP,"NOIBQ",PSODFN)) Q:'PSODFN D Q:STOP + .I CC#100=0,$D(^XTMP(NAMSP,0,"STOP")) D Q + .. S $P(^XTMP(NAMSP,0,"LAST"),"^",1,2)="STOP^"_$$NOW^XLFDT,STOP=1 + .S (PSOCAP(304),PSOCAP(305),PSOCAP(306))=0 ; INITIAL ANNUAL CAP FOR 2004 & 2005 + .F RXP=0:0 S RXP=$O(^XTMP(NAMSP,"NOIBQ",PSODFN,RXP)) Q:'RXP D + ..S (SAVCPUN,PSOCPUN)=($P(^PSRX(RXP,0),"^",8)+29)\30 + ..S YY="" F S YY=$O(^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)) Q:YY="" D + ...S (SAVREF,PSOREF)=YY + ...D SITE + ...S PSOREL=$P($G(^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)),"^"),PSOFLD=$P($G(^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)),"^",2),PSOSCP=$P($G(^XTMP(NAMSP,"NOIBQ",PSODFN,RXP,YY)),"^",3) + ...S (PSOOIBQ,PSOOICD,PSOOIB)="" + ...S PSOOICD=$P($G(^PSRX(RXP,"ICD",1,0)),"^",2,8),PSOOIB=$G(^PSRX(RXP,"IB")),PSOOIBQ=$G(^PSRX(RXP,"IBQ")) + ...I PSOOIBQ=""&($TR(PSOOICD,"^")[0!($TR(PSOOICD,"^")[1)) D SETIBQ D ;don't want to set again if already did it as part of copay cancel + ....S I="",IFN=0 F I=0:0 S I=$O(^PSRX(RXP,"A",I)) Q:'I S IFN=I + ....S COM=" BKGD CIDC UPDATE" + ....D NOW^%DTC S IFN=IFN+1,^PSRX(RXP,"A",0)="^52.3DA^"_IFN_"^"_IFN,^PSRX(RXP,"A",IFN,0)=%_"^I^.5^"_YY_"^"_COM + ....K DA + ....S:PSOOICD[1&($D(^PSRX(RXP,"IB"))) $P(^PSRX(RXP,"IB"),"^")="" + ...D:'$G(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY)) ACCUM + ...S PSOCPUN=SAVCPUN,PSOREF=SAVREF + Q + ; +CHKACT ;check activity log for prev entry + N ZACT,ZPSI,ZACTI + S ZPSI=0 F S ZPSI=$O(^PSRX(PSODA,"COPAY",ZPSI)) Q:ZPSI="" S ZACTI="",ZACTI=$G(^PSRX(PSODA,"COPAY",ZPSI,0)) D Q:$G(ZACT) + . I ZACTI["BKGD CIDC COPAY CANCEL"&($P(ZACTI,"^",2)="R") S PSOOLD="",PSONW="",PREA="C",ZACT=1 Q + I '$G(ZACT) S PSOOLD="Copay",PSONW="No Copay",PREA="R" K PSOREF D ACTLOG^PSOCPA S PSOREF=YY,PSOOLD="",PSONW="",PREA="C" + Q + ; +SETIBQ ; get data from IBQ node, set IBQ node, and 1st piece of IB node + K PSOANSQ + N PSONIBQ + F PSOTYP=1:1:7 D + . I PSOTYP=1 S PSOANSQ("VEH")=$P(PSOOICD,"^",PSOTYP) + . I PSOTYP=2 S PSOANSQ("RAD")=$P(PSOOICD,"^",PSOTYP) + . I PSOTYP=3 S PSOANSQ("SC")=$P(PSOOICD,"^",PSOTYP) + . I PSOTYP=4 S PSOANSQ("PGW")=$P(PSOOICD,"^",PSOTYP) + . I PSOTYP=5 S PSOANSQ("MST")=$P(PSOOICD,"^",PSOTYP) + . I PSOTYP=6 S PSOANSQ("HNC")=$P(PSOOICD,"^",PSOTYP) + . I PSOTYP=7 S PSOANSQ("CV")=$P(PSOOICD,"^",PSOTYP) + S ^PSRX(RXP,"IBQ")=PSOANSQ("SC")_"^"_PSOANSQ("MST")_"^"_PSOANSQ("VEH")_"^"_PSOANSQ("RAD")_"^"_PSOANSQ("PGW")_"^"_PSOANSQ("HNC")_"^"_PSOANSQ("CV") + Q + ; +ACCUM ; ACCUMULATE TOTALS + S (PSOTOT,PSOYR,PSOYEAR,PSOLOG,PSONAM,PSOCHRG)="" + ; get finished, but unreleased totals + I PSOREL="" S PSOYR=$E(PSOFLD,1,3) Q:PSOYR="" D S PSOYEAR="" Q + .S PSOYEAR=$S(PSOYR="304":"YR2004",PSOYR="305":"YR2005",PSOYR="306":"YR2006",1:"") Q:PSOYEAR="" + .S PSOCHRG=7 + .I PSOYEAR="YR2006" S PSOCHRG=8 + .S PSOTOT=$G(^XTMP(NAMSP,"TOT UNREL",PSODFN,PSOYEAR)) + .S ^XTMP(NAMSP,"TOT UNREL",PSODFN,PSOYEAR)=PSOTOT+(PSOCPUN*PSOCHRG) + .S ^XTMP(NAMSP,"TOT UNREL",PSODFN,PSOYEAR,PSOCPUN)=$G(^XTMP(NAMSP,"TOT UNREL",PSODFN,PSOYEAR,PSOCPUN))+1 + .S PSONAM=$P($G(^DPT(PSODFN,0)),"^"),PSONAM=$P(PSONAM,",") + .S PSONAM=$E(PSONAM,1,6) + .S ^XTMP(NAMSP,"IBQ UPD",PSONAM,PSODFN,RXP,PSOREF)=PSOFLD + ;for released ones + S PSOYR=$E(PSOREL,1,3) + S:PSOYR'="" PSOYEAR=$S(PSOYR="304":"YR2004",PSOYR="305":"YR2005",PSOYR="306":"YR2006",1:"") + Q:PSOYEAR="" + S PSOCHRG=7 + I PSOYEAR="YR2006" S PSOCHRG=8 + ; + ;get Xtmp billing amt which would be IBAM tot + any previous refills + S PSOTOT=$G(^XTMP(NAMSP,"TOT REL",PSODFN,PSOYEAR)) + ; + ;if none yet then init to the IBAM total for the year + I 'PSOTOT D + .F PSOSQ=0:0 S PSOSQ=$O(^IBAM(354.7,PSODFN,1,PSOSQ)) Q:'PSOSQ D + ..S PSOLOG=$G(^IBAM(354.7,PSODFN,1,PSOSQ,0)) + ..I $E(PSOLOG,1,3)=PSOYR S PSOTOT=PSOTOT+$P(PSOLOG,"^",2) + ; + ;update Xtmp tot nodes with current fill amounts + ; note: cancel copays and updated IBQ node released prescription are collected under TOT REL for the RPT^PSOCIDC3 + ; routine. Cancelled copays are denoted with an asterisk. + S ^XTMP(NAMSP,"TOT REL",PSODFN,PSOYEAR)=PSOTOT+(PSOCPUN*PSOCHRG) + S ^XTMP(NAMSP,"TOT REL",PSODFN,PSOYEAR,PSOCPUN)=$G(^XTMP(NAMSP,"TOT REL",PSODFN,PSOYEAR,PSOCPUN))+1 + ; + ;indicate COPAY CANCEL for this fill + ; ;by adding to Xtmp "BILLED" + S PSONAM=$P($G(^DPT(PSODFN,0)),"^"),PSONAM=$P(PSONAM,",") + S PSONAM=$E(PSONAM,1,6) + S ^XTMP(NAMSP,"REL",PSONAM,PSODFN,RXP,PSOREF)=PSOREL + ; +CAN I PSOTYPE="CAN"&($G(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,YY))) N PSOFILL S CANCEL="" S PSOFILL=YY D CHK^PSOCIDC3 I CANCEL D + . S ^XTMP(NAMSP,"TOT CAN",PSODFN,PSOYEAR)=PSOTOT+(PSOCPUN*PSOCHRG) + . S ^XTMP(NAMSP,"TOT CAN",PSODFN,PSOYEAR,PSOCPUN)=$G(^XTMP(NAMSP,"TOT CAN",PSODFN,PSOYEAR,PSOCPUN))+1 + Q + ; +SITE ; SET UP VARIABLES NEEDED BY BILLING + S PSOSITE=$S(YY=0:$P(^PSRX(RXP,2),"^",9),1:$P($G(^PSRX(RXP,1,YY,0)),"^",9)) + Q:PSOSITE="" + S PSOPAR=$G(^PS(59,PSOSITE,1)) + S PSOPAR7=$G(^PS(59,PSOSITE,"IB")) + S PSOSITE7=$P($G(^PS(59,PSOSITE,"IB")),"^") + Q + ; diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCMOP.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCMOP.m index d7997afe..fb538fce 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCMOP.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCMOP.m @@ -1,153 +1,153 @@ -PSOCMOP ;BIR/HTW-Rx Order Entry Screen for CMOP ; 6/28/07 7:35am - ;;7.0;OUTPATIENT PHARMACY;**2,16,21,27,43,61,126,148,274**;DEC 1997;Build 8 - ;External reference to ^PS(55 supported by DBIA 2228 - ;External reference to ^PSDRUG supported by DBIA 221 - ;External reference to ^PSDRUG supported by DBIA 3165 - ;External reference to ^PSSHUIDG supported by DBIA 3621 -TOP ; - I $G(PSOFROM)="EDIT" S PPL=$G(PSORX("PSOL",1)) Q:$G(PPL)']"" G TEST - I $G(PPL) G START - I '$G(RXLTOP) S PPL=$G(DA) G TEST - S:'$G(PPL) PPL=$G(PSORX("PSOL",1)) G:$G(PPL)']"" D1 -START ; Establish CMOP PPL -TEST N ACT,B,C,CK,COMM,CNT,DFLG,I,FLAG,MW,NEWDT,PI,P1,P2,REL,RFD,RX,RX0,RXN - N RXP,RXS,SD,VALMSG,X,X7,Y,ZD,DFN,TRX - S (P1,P2)=1,FLAG=0 - ; PSOMC=Mail Code, PSOMDT=Mail Code Expiration Date - S TRX=$P($G(PPL),",",1) - S DFN=$P(^PSRX(TRX,0),"^",2),PSOMDT=$P($G(^PS(55,DFN,0)),"^",5),PSOMC=$P($G(^PS(55,DFN,0)),"^",3) K DFN,TRX - I (PSOMC>1&(PSOMDT>DT))!(PSOMC>1&(PSOMDT<1)) K PSOMC,PSOMDT G RESET -LOOP F CNT=1:1 S RX=$P($G(PPL),",",CNT) Q:RX']"" D S:'FLAG $P(RX("PSO"),",",P1)=RX,P1=P1+1 S FLAG=0 - .; Get drug IEN and check if CMOP - .S CK=$P($G(^PSRX(RX,0)),"^",6) Q:'$D(^PSDRUG("AQ",CK)) - .; If not marked for O.P., unmark for CMOP... - .I $P($G(^PSDRUG(CK,2)),"^",3)'["O" D UNMARK^PSOCMOP Q - .; Check Drug Warning >11 - .N WARNS,COMM S WARNS=$P(^PSDRUG(CK,0),U,8) I $L(WARNS)>11 D Q - .. S COMM(1)="Rx# "_$P(^PSRX(RX,0),"^")_" CMOP cannot dispense - Drug warnings >11 characters." - .. S COMM(2)="Drug Name: "_$P(^PSDRUG(CK,0),U)_" (IEN: # "_CK_")" - .. D COMM(RX,.COMM) - .; Q:If partial or pull early - .Q:$G(RXPR(RX))!($G(RXRS(RX))) - .; Q:If standard reprint but allow edit reprint - .I $G(RXRP(RX))&($P($G(RXRP(RX)),"^",4)'=1) Q - .; Q:If tradename - .Q:$G(^PSRX(RX,"TN"))]"" - .; Q: If Cancelled, Expired, Deleted, Hold - .Q:$P(^PSRX(RX,"STA"),"^")>9!($P(^("STA"),"^")=4)!($P(^("STA"),"^")=3) - .; Find last fill - .S RFD=0 F X7=0:0 S X7=$O(^PSRX(RX,1,X7)) Q:'$G(X7) S (RFD)=X7 - .Q:$G(RXFL(RX))&(RFD)&($G(RXFL(RX))'=RFD) - .I '$O(^PSRX(RX,1,0)),'$P($G(^PSRX(RX,2)),"^",13),$P($G(^(0)),"^",11)="W",$S($P($G(^PSRX(RX,2)),"^",2):$P($G(^(2)),"^",2),1:+$G(PSOX("FILL DATE")))>DT D - ..S PSOCPDA=$G(DA) K DIE S DA=RX,DIE="^PSRX(",DR="11////M" D ^DIE K DIE S:$G(PSOCPDA) DA=$G(PSOCPDA) K PSOCPDA - .; Q:If not "Mail" - .S MW=$S($G(RFD)>0:$P(^PSRX(RX,1,RFD,0),"^",2),1:$P(^PSRX(RX,0),"^",11)) K X7 I $G(MW)="W" K RFD Q - .; - .; Q:If fill was CMOPed and other than a '3' 'not dispensed' - .Q:'$$FILTRAN(RX,RFD) - .; - .; Check if released, for use in Sus - .S REL=$S(RFD=0:$P($G(^PSRX(RX,2)),"^",13),1:$P($G(^PSRX(RX,1,RFD,0)),"^",18)) K RFD - .I $G(REL) Q - .; Save CMOP's in PSXPPL1 - .S $P(RX("CMOP"),",",P2)=RX,P2=P2+1,FLAG=1 Q - K PPL S PPL=$G(RX("PSO")),RX1("CMOP")=$G(RX("CMOP")) K RX("PSO") - G:$G(XFROM)="EDIT" D1 ; passed from PSXEDIT -RESET ; - G:'$G(RX("CMOP")) D1 - I $G(XFROM)="REINSTATE"!($G(XFROM)="UNHOLD") Q - I $G(PSOFROM)="EDIT",($G(REL)]"") S PPL=RX("CMOP") G D1 -S ; Auto-Suspend CMOPS - N DA,Y - F PI=1:1 S DA=$P($G(RX("CMOP")),",",PI) Q:'DA D SUS - S SUSPT="SUSPENSE" - G D1 -SUS ; - I $G(XFROM)="REINSTATE" W !,RX_" REINSTATED -- " - S ACT=1,RXN=DA,RX0=^PSRX(DA,0),SD=$S($G(ZD(DA)):$E(ZD(DA),1,7),1:$P(^(3),"^")),RXS=$O(^PS(52.5,"B",DA,0)) I RXS D Q:$G(DFLG) - .S DA=RXS,DIK="^PS(52.5," D ^DIK S DA=RXN - K X7 S RFD1=0 F X7=0:0 S X7=$O(^PSRX(DA,1,X7)) Q:'$G(X7) S (RFD1)=X7 -LOCK S RXP=+$G(RXPR(DA)),DIC="^PS(52.5,",DIC(0)="",X=RXN - S DIC("DR")=".02////"_SD_";.03////"_$P(^PSRX(DA,0),"^",2)_";.04////M;.05////"_RXP_";.06////"_PSOSITE_";2////0;3////Q;9////"_RFD1 - K DD,DO D FILE^DICN K DD,DO S DA=RXN I +Y S PSONAME=$P(^PSRX(DA,0),"^",2) K ^PS(52.5,"AC",PSONAME,SD,+Y),PSONAME - S $P(^PSRX(RXN,"STA"),"^")=5,LFD=$E(SD,4,5)_"-"_$E(SD,6,7)_"-"_$E(SD,2,3) D ACT - W !!,"RX# ",$P(^PSRX(RXN,0),"^")_" HAS BEEN SUSPENDED for CMOP Until "_LFD_"." - S VALMSG="Rx# "_$P(^PSRX(RXN,0),"^")_" Has Been Suspended for CMOP Until "_LFD_"." - S COMM="Rx# "_$P(^PSRX(RXN,0),"^")_" Has Been Suspended for CMOP Until "_LFD_"." - D EN^PSOHLSN1(RXN,"SC","ZS",COMM) K COMM - ;- Calling ECME to reverse any PAYABLE claim for the prescription/fill - D REVERSE^PSOBPSU1(RXN,,"DC",3) - Q -ACT S RXF=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I S RXF=I S:I>5 RXF=I+1 - S IR=0 F FDA=0:0 S FDA=$O(^PSRX(DA,"A",FDA)) Q:'FDA S IR=FDA - S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR - D NOW^%DTC S ^PSRX(DA,"A",IR,0)=%_"^S^"_DUZ_"^"_RXF_"^"_"RX Placed on Suspense for CMOP until "_LFD - K RXF,I,FDA,DIC,DIE,DR,Y,X,%,%H,%I - Q -D1 K CNT,COUNT,DFLG,DIRUT,DIROUT,DTOUT,DUOUT,EXDT,FLAG,FLD,L,PDUZ,PI,X7 - K PSOCMOP,REF,REPRINT,RFDATE,RFL1,RFLL,RXPD,SD,SUSPT,WARN,XFROM,ZY,RX1 - Q -RXL N FROM S FROM=$G(PSOFROM) - I ((FROM="NEW")!(FROM="REFILL")!(FROM="CANCEL")!(FROM="BATCH")!($G(XFROM)="HOLD")!($G(XFROM)="BATCH")) G TOP - Q -SUS1 ; - N PPL - S PPL=DA D TEST - I $G(PPL)']"" S XFLAG=1 - S RX("CMOP")=$G(RX1("CMOP")) - Q -A S:'$G(PPL) PPL=$G(PSORX("PSOL",PPL1)) G:$G(PPL)']"" D1 - G TEST -UNMARK ;Entry point to unmark drug for CMOP dispense - N X,Z,% - S $P(^PSDRUG(CK,3),"^",1)=0 K ^PSDRUG("AQ",CK) - S:'$D(^PSDRUG(CK,4,0)) ^PSDRUG(CK,4,0)="^50.0214DA^^" - S (X,Z)=0 F S Z=$O(^PSDRUG(CK,4,Z)) Q:'Z S X=Z - S X=X+1 D NOW^%DTC S ^PSDRUG(CK,4,X,0)=%_"^E^"_DUZ_"^CMOP Dispense^"_$S($G(^PSDRUG(CK,3))=1:"YES",$G(^PSDRUG(CK,3))=0:"NO",1:"") - S $P(^PSDRUG(CK,4,0),"^",3)=X,$P(^(0),"^",4)=$P(^(0),"^",4)+1 - I $$PATCH^XPDUTL("PSS*1.0*70") D DRG^PSSHUIDG(CK) - K X,Z,% - Q -FILTRAN(RX,RFD) ; Test fill's CMOP tran status, return 1 if OK to send - N DA,CMOP - S DA=RX - D ^PSOCMOPA - I '$D(CMOP(RFD)) Q 1 - I CMOP(RFD)=3 Q 1 - Q 0 -COMM(RXN,COMM) ;EP process problem message to g.cmop managers - N XMSUB,XMTEXT - S XMTEXT="COMM(",XMY("I:G.CMOP MANAGERS")="" - S XMSUB="CMOP RX PROBLEM ENCOUNTERED" - D ^XMD - Q -CMPRXTYP(SUSDA) ; given suspense record SUSDA returns RX CMOP TYPE C - CS, N -Non-CS - ;used in compound index ^PS(52.5,"CMP",STAT,TYP,DIV,DATE,DFN,DA) - N RXDA,DRGDA,DEA,TYP - S RXDA=$P(^PS(52.5,SUSDA,0),U),DRGDA=$P(^PSRX(RXDA,0),U,6) - S TYP="N",DEA=$P(^PSDRUG(DRGDA,0),U,3) F I=3,4,5 I DEA[I S TYP="C" - Q TYP -NOW() D NOW^%DTC Q % - ; -PIECE(REC,DLM,VP) ; VP="Variable^Piece" - ; Set Variable V = piece P of REC using delimiter DLM - N V,P S V=$P(VP,U),P=$P(VP,U,2),@V=$P(REC,DLM,P) - Q -PUT(REC,DLM,VP) ; VP="Variable^Piece" - ; pass by reference D PUT^PSOCMOP(.REC,DLM,VP) - ; Set Variable V into piece P of REC using delimiter DLM - N V,P S V=$P(VP,U),P=$P(VP,U,2) - S $P(REC,DLM,P)=$G(@V) - Q -KCMPX(SUS,VAL) ; Kill ^PS(52.5,"CMP",VAL index given SUS - N SDT,TYP,DFN,DIV,RX,F,XX - S F=$G(^PS(52.5,SUS,0)) Q:'+F S TYP=$$CMPRXTYP(SUS) - F XX="RX^1","SDT^2","DFN^3","DIV^6" D PIECE(F,U,XX) - K ^PS(52.5,"CMP",VAL,TYP,DIV,SDT,DFN,SUS) - Q -SCMPX(SUS,VAL) ; Set ^PS(52.5,"CMP",VAL index given SUS - N SDT,TYP,DFN,DIV,RX,F,XX - S F=$G(^PS(52.5,SUS,0)) Q:'+F S TYP=$$CMPRXTYP(SUS) - F XX="RX^1","SDT^2","DFN^3","DIV^6" D PIECE(F,U,XX) - S ^PS(52.5,"CMP",VAL,TYP,DIV,SDT,DFN,SUS)="" - Q +PSOCMOP ;BIR/HTW-Rx Order Entry Screen for CMOP ;02/19/98 9:21 AM + ;;7.0;OUTPATIENT PHARMACY;**2,16,21,27,43,61,126,148**;DEC 1997 + ;External reference to ^PS(55 supported by DBIA 2228 + ;External reference to ^PSDRUG supported by DBIA 221 + ;External reference to ^PSDRUG supported by DBIA 3165 + ;External reference to ^PSSHUIDG supported by DBIA 3621 +TOP ; + I $G(PSOFROM)="EDIT" S PPL=$G(PSORX("PSOL",1)) Q:$G(PPL)']"" G TEST + I $G(PPL) G START + I '$G(RXLTOP) S PPL=$G(DA) G TEST + S:'$G(PPL) PPL=$G(PSORX("PSOL",1)) G:$G(PPL)']"" D1 +START ; Establish CMOP PPL +TEST N ACT,B,C,CK,COMM,CNT,DFLG,I,FLAG,MW,NEWDT,PI,P1,P2,REL,RFD,RX,RX0,RXN + N RXP,RXS,SD,VALMSG,X,X7,Y,ZD,DFN,TRX + S (P1,P2)=1,FLAG=0 + ; PSOMC=Mail Code, PSOMDT=Mail Code Expiration Date + S TRX=$P($G(PPL),",",1) + S DFN=$P(^PSRX(TRX,0),"^",2),PSOMDT=$P($G(^PS(55,DFN,0)),"^",5),PSOMC=$P($G(^PS(55,DFN,0)),"^",3) K DFN,TRX + I (PSOMC>1&(PSOMDT>DT))!(PSOMC>1&(PSOMDT<1)) K PSOMC,PSOMDT G RESET +LOOP F CNT=1:1 S RX=$P($G(PPL),",",CNT) Q:RX']"" D S:'FLAG $P(RX("PSO"),",",P1)=RX,P1=P1+1 S FLAG=0 + .; Get drug IEN and check if CMOP + .S CK=$P($G(^PSRX(RX,0)),"^",6) Q:'$D(^PSDRUG("AQ",CK)) + .; If not marked for O.P., unmark for CMOP... + .I $P($G(^PSDRUG(CK,2)),"^",3)'["O" D UNMARK^PSOCMOP Q + .; Check Drug Warning >11 + .N WARNS,COMM S WARNS=$P(^PSDRUG(CK,0),U,8) I $L(WARNS)>11 D Q + .. S COMM(1)="Rx# "_$P(^PSRX(RX,0),"^")_" CMOP cannot dispense - Drug warnings >11 characters." + .. S COMM(2)="Drug Name: "_$P(^PSDRUG(CK,0),U)_" (IEN: # "_CK_")" + .. D COMM(RX,.COMM) + .; Q:If partial or pull early + .Q:$G(RXPR(RX))!($G(RXRS(RX))) + .; Q:If standard reprint but allow edit reprint + .I $G(RXRP(RX))&($P($G(RXRP(RX)),"^",4)'=1) Q + .; Q:If tradename + .Q:$G(^PSRX(RX,"TN"))]"" + .; Q: If Cancelled, Expired, Deleted, Hold + .Q:$P(^PSRX(RX,"STA"),"^")>9!($P(^("STA"),"^")=4)!($P(^("STA"),"^")=3) + .; Find last fill + .S RFD=0 F X7=0:0 S X7=$O(^PSRX(RX,1,X7)) Q:'$G(X7) S (RFD)=X7 + .Q:$G(RXFL(RX))&(RFD)&($G(RXFL(RX))'=RFD) + .I '$O(^PSRX(RX,1,0)),'$P($G(^PSRX(RX,2)),"^",13),$P($G(^(0)),"^",11)="W",$S($P($G(^PSRX(RX,2)),"^",2):$P($G(^(2)),"^",2),1:+$G(PSOX("FILL DATE")))>DT D + ..S PSOCPDA=$G(DA) K DIE S DA=RX,DIE="^PSRX(",DR="11////M" D ^DIE K DIE S:$G(PSOCPDA) DA=$G(PSOCPDA) K PSOCPDA + .; Q:If not "Mail" + .S MW=$S($G(RFD)>0:$P(^PSRX(RX,1,RFD,0),"^",2),1:$P(^PSRX(RX,0),"^",11)) K X7 I $G(MW)="W" K RFD Q + .; + .; Q:If fill was CMOPed and other than a '3' 'not dispensed' + .Q:'$$FILTRAN(RX,RFD) + .; + .; Check if released, for use in Sus + .S REL=$S(RFD=0:$P($G(^PSRX(RX,2)),"^",13),1:$P($G(^PSRX(RX,1,RFD,0)),"^",18)) K RFD + .I $G(REL) Q + .; Save CMOP's in PSXPPL1 + .S $P(RX("CMOP"),",",P2)=RX,P2=P2+1,FLAG=1 Q + K PPL S PPL=$G(RX("PSO")),RX1("CMOP")=$G(RX("CMOP")) K RX("PSO") + G:$G(XFROM)="EDIT" D1 ; passed from PSXEDIT +RESET ; + G:'$G(RX("CMOP")) D1 + I $G(XFROM)="REINSTATE"!($G(XFROM)="UNHOLD") Q + I $G(PSOFROM)="EDIT",($G(REL)]"") S PPL=RX("CMOP") G D1 +S ; Auto-Suspend CMOPS + N DA,Y + F PI=1:1 S DA=$P($G(RX("CMOP")),",",PI) Q:'DA D SUS + S SUSPT="SUSPENSE" + G D1 +SUS ; + I $G(XFROM)="REINSTATE" W !,RX_" REINSTATED -- " + S ACT=1,RXN=DA,RX0=^PSRX(DA,0),SD=$S($G(ZD(DA)):$E(ZD(DA),1,7),1:$P(^(3),"^")),RXS=$O(^PS(52.5,"B",DA,0)) I RXS D Q:$G(DFLG) + .S DA=RXS,DIK="^PS(52.5," D ^DIK S DA=RXN + K X7 S RFD1=0 F X7=0:0 S X7=$O(^PSRX(DA,1,X7)) Q:'$G(X7) S (RFD1)=X7 +LOCK S RXP=+$G(RXPR(DA)),DIC="^PS(52.5,",DIC(0)="",X=RXN + S DIC("DR")=".02////"_SD_";.03////"_$P(^PSRX(DA,0),"^",2)_";.04////M;.05////"_RXP_";.06////"_PSOSITE_";2////0;3////Q;9////"_RFD1 + K DD,DO D FILE^DICN K DD,DO S DA=RXN I +Y S PSONAME=$P(^PSRX(DA,0),"^",2) K ^PS(52.5,"AC",PSONAME,SD,+Y),PSONAME + S $P(^PSRX(RXN,"STA"),"^")=5,LFD=$E(SD,4,5)_"-"_$E(SD,6,7)_"-"_$E(SD,2,3) D ACT + W !!,"RX# ",$P(^PSRX(RXN,0),"^")_" HAS BEEN SUSPENDED for CMOP Until "_LFD_"." + S VALMSG="Rx# "_$P(^PSRX(RXN,0),"^")_" Has Been Suspended for CMOP Until "_LFD_"." + S COMM="Rx# "_$P(^PSRX(RXN,0),"^")_" Has Been Suspended for CMOP Until "_LFD_"." + D EN^PSOHLSN1(RXN,"SC","ZS",COMM) K COMM + ;- Calling ECME to reverse any PAYABLE claim for the prescription/fill + D REVERSE^PSOBPSU1(RXN,,"DC",3) + Q +ACT I '$D(RXF) S RXF=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I S RXF=I S:I>5 RXF=I+1 + S IR=0 F FDA=0:0 S FDA=$O(^PSRX(DA,"A",FDA)) Q:'FDA S IR=FDA + S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR + D NOW^%DTC S ^PSRX(DA,"A",IR,0)=%_"^S^"_DUZ_"^"_RXF_"^"_"RX Placed on Suspense for CMOP until "_LFD + K RXF,I,FDA,DIC,DIE,DR,Y,X,%,%H,%I + Q +D1 K CNT,COUNT,DFLG,DIRUT,DIROUT,DTOUT,DUOUT,EXDT,FLAG,FLD,L,PDUZ,PI,X7 + K PSOCMOP,REF,REPRINT,RFDATE,RFL1,RFLL,RXPD,SD,SUSPT,WARN,XFROM,ZY,RX1 + Q +RXL N FROM S FROM=$G(PSOFROM) + I ((FROM="NEW")!(FROM="REFILL")!(FROM="CANCEL")!(FROM="BATCH")!($G(XFROM)="HOLD")!($G(XFROM)="BATCH")) G TOP + Q +SUS1 ; + N PPL + S PPL=DA D TEST + I $G(PPL)']"" S XFLAG=1 + S RX("CMOP")=$G(RX1("CMOP")) + Q +A S:'$G(PPL) PPL=$G(PSORX("PSOL",PPL1)) G:$G(PPL)']"" D1 + G TEST +UNMARK ;Entry point to unmark drug for CMOP dispense + N X,Z,% + S $P(^PSDRUG(CK,3),"^",1)=0 K ^PSDRUG("AQ",CK) + S:'$D(^PSDRUG(CK,4,0)) ^PSDRUG(CK,4,0)="^50.0214DA^^" + S (X,Z)=0 F S Z=$O(^PSDRUG(CK,4,Z)) Q:'Z S X=Z + S X=X+1 D NOW^%DTC S ^PSDRUG(CK,4,X,0)=%_"^E^"_DUZ_"^CMOP Dispense^"_$S($G(^PSDRUG(CK,3))=1:"YES",$G(^PSDRUG(CK,3))=0:"NO",1:"") + S $P(^PSDRUG(CK,4,0),"^",3)=X,$P(^(0),"^",4)=$P(^(0),"^",4)+1 + I $$PATCH^XPDUTL("PSS*1.0*70") D DRG^PSSHUIDG(CK) + K X,Z,% + Q +FILTRAN(RX,RFD) ; Test fill's CMOP tran status, return 1 if OK to send + N DA,CMOP + S DA=RX + D ^PSOCMOPA + I '$D(CMOP(RFD)) Q 1 + I CMOP(RFD)=3 Q 1 + Q 0 +COMM(RXN,COMM) ;EP process problem message to g.cmop managers + N XMSUB,XMTEXT + S XMTEXT="COMM(",XMY("I:G.CMOP MANAGERS")="" + S XMSUB="CMOP RX PROBLEM ENCOUNTERED" + D ^XMD + Q +CMPRXTYP(SUSDA) ; given suspense record SUSDA returns RX CMOP TYPE C - CS, N -Non-CS + ;used in compound index ^PS(52.5,"CMP",STAT,TYP,DIV,DATE,DFN,DA) + N RXDA,DRGDA,DEA,TYP + S RXDA=$P(^PS(52.5,SUSDA,0),U),DRGDA=$P(^PSRX(RXDA,0),U,6) + S TYP="N",DEA=$P(^PSDRUG(DRGDA,0),U,3) F I=3,4,5 I DEA[I S TYP="C" + Q TYP +NOW() D NOW^%DTC Q % + ; +PIECE(REC,DLM,VP) ; VP="Variable^Piece" + ; Set Variable V = piece P of REC using delimiter DLM + N V,P S V=$P(VP,U),P=$P(VP,U,2),@V=$P(REC,DLM,P) + Q +PUT(REC,DLM,VP) ; VP="Variable^Piece" + ; pass by reference D PUT^PSOCMOP(.REC,DLM,VP) + ; Set Variable V into piece P of REC using delimiter DLM + N V,P S V=$P(VP,U),P=$P(VP,U,2) + S $P(REC,DLM,P)=$G(@V) + Q +KCMPX(SUS,VAL) ; Kill ^PS(52.5,"CMP",VAL index given SUS + N SDT,TYP,DFN,DIV,RX,F,XX + S F=$G(^PS(52.5,SUS,0)) Q:'+F S TYP=$$CMPRXTYP(SUS) + F XX="RX^1","SDT^2","DFN^3","DIV^6" D PIECE(F,U,XX) + K ^PS(52.5,"CMP",VAL,TYP,DIV,SDT,DFN,SUS) + Q +SCMPX(SUS,VAL) ; Set ^PS(52.5,"CMP",VAL index given SUS + N SDT,TYP,DFN,DIV,RX,F,XX + S F=$G(^PS(52.5,SUS,0)) Q:'+F S TYP=$$CMPRXTYP(SUS) + F XX="RX^1","SDT^2","DFN^3","DIV^6" D PIECE(F,U,XX) + S ^PS(52.5,"CMP",VAL,TYP,DIV,SDT,DFN,SUS)="" + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCP.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCP.m index be2f34e7..0afd29e2 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCP.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCP.m @@ -1,185 +1,184 @@ -PSOCP ;BIR/BAB - Pharmacy CO-PAY Application Utilities for IB ;02/06/92 - ;;7.0;OUTPATIENT PHARMACY;**20,46,71,85,137,157,143,219,239,201,225**;DEC 1997;Build 29 - ; - ;REF/IA - IBARX/125, SDCO22/1579, PS(55/2228, PSDRUG(/221, DGMSTAPI/2716, $$GETSHAD^DGUTL3/4462 -CP ;Check if COPAY-Requires RXP,PSOSITE7 - I '$D(PSOPAR) D ^PSOLSET G CP - K PSOCP - S PSOCPN=$P(^PSRX(RXP,0),"^",2) ; Set COPAY dfn PTR TO PATIENT - S PSOCP=$P($G(^PSRX(RXP,"IB")),"^") ; IB action type - S PSOSAVE=$S(PSOCP:1,1:"") ; save current copay status - ; Set x=service^dfn^actiontype^user duz - I +$G(PSOSITE7)'>0 S PSOSITE7=$P(^PS(59,PSOSITE,"IB"),"^") - S X=PSOSITE7_"^"_PSOCPN_"^"_PSOCP_"^"_$P(^PSRX(RXP,0),"^",16) - ; -RX ;Determine Orig or Refill for RX - N PSOIB,PSOPFS S (PSOIB,PSOREF)=0 - I $G(^PSRX(RXP,1,+$G(YY),0))]"" S PSOREF=YY - D PFSA^PSOPFSU1(RXP,PSOREF,2) G PFS:+PSOPFS - ; Check if bill exists - I 'PSOREF,+$P($G(^PSRX(RXP,"IB")),"^",2)>0 D CHKIB^PSOCP1 I PSOIB G QUIT - I 'PSOREF,+$P($G(^PSRX(RXP,"IB")),"^",4)>0 G QUIT ; 'POTENTIAL BILL' - ALREADY ATTEMPTED TO BILL, BUT EXCEEDED ANNUAL COPAY CAP - I PSOREF,+$G(^PSRX(RXP,1,PSOREF,"IB")) D CHKIB^PSOCP1 I PSOIB G QUIT - I PSOREF,+$P($G(^PSRX(RXP,1,PSOREF,"IB")),"^",2) G QUIT ; POTENTIAL BILL -PFS ; - S PSOCHG=1 ; set tem var to copay and check exception - N MAILMSG - D COPAYREL - I 'PSOCHG D D:PSOPFS CHRG^PSOPFSU1(RXP,PSOREF,"CG",PSOPFS) G QUIT - . I PSOSAVE S PSODA=RXP,PREA="R" D ACTLOG^PSOCPA S $P(^PSRX(RXP,"IB"),"^",1)="" - I PSOCHG=2 D I 'PSOCP D:PSOPFS CHRG^PSOPFSU1(RXP,PSOREF,"CG",PSOPFS) G QUIT ; IF 'SC' QUESTION APPLIES, BUT HAS NOT BEEN ANSWERED, SEND MAIL MSG AND KEEP COPAY STATUS AS IT WAS - . D MAIL2^PSOCPE ; SEND MAIL TO PHARMACIST, PROVIDER, AND HOLDERS OF THE PSO COPAY KEY - I PSOCHG=1,PSOSAVE="" D I PSOREF S PSOCOMM="",PSOOLD="No Copay",PSONW="Copay" S PSODA=RXP,PREA="R" D ACTLOG^PSOCPA - . I '$D(^PSRX(RXP,"IB")),'PSOREF S $P(^PSRX(RXP,"IB"),"^",1)=1 Q - . S $P(^PSRX(RXP,"IB"),"^",1)=1 - . S PSOCP=1,$P(X,"^",3)=PSOCP - I PSOCHG'=2 I $G(MAILMSG) D MAIL2^PSOCPE ; SEND MAIL TO PHARM, PROV, AND HOLDERS OF PSO COPAY KEY HOLDERS - ; Units for COPAY - S PSOCPUN=$P(($P(^PSRX(RXP,0),"^",8)+29)/30,".",1) - ; Build softlink for x(n)=softlink^units - S X(1)="52:"_RXP S:PSOREF>0 X(1)=X(1)_";1:"_PSOREF S X(1)=X(1)_"^"_PSOCPUN - ; Set correct user duz if refill - I PSOREF S:+$P(^PSRX(RXP,1,PSOREF,0),"^",7)>0 $P(X,"^",4)=$P(^PSRX(RXP,1,PSOREF,0),"^",7) - ; -IBNEW ; Load ^TMP global for IB call - Q:$G(RXP)'>0 - I PSOPFS D CHRG^PSOPFSU1(RXP,PSOREF,"CG",PSOPFS) - G QUIT:PSOPFS - N D0 - G QUIT:'$D(X) - S XTMP=X,XTMP(1)=X(1) - ; - ; Requires x=service^dfn^action type^user duz - ; x(n)=softlink^units - I $P(X,"^",3)="" S $P(X,"^",3)=$P(^PSRX(RXP,"IB"),"^",1) - D NEW^IBARX - ; Returns y=1^total charges for this group or Y=-1^error code - ; y(n)=IB number^charge for this Rx^AR bill #^Cap met^Partial or Full charge^Copay Exempt^Number from file 354.71 - ; Cap met ('1' - If patient has met cap amount or reached cap with this charge or '0' if not) - ; Partial or Full ('P' for partial billing, 'F' for full billing, null for no billing) - ; Copay Exempt - ('1' for exempt, '0' for non-exempt, '-1' for copay off (manila)), - ; ('1' - If patient has met cap amount or reach cap with this charge - ; Entry from file 354.71 will only be saved for fills that met the annual cap and could not be fully billed - ; - G QUIT:+Y=-1 - S XTMP=XTMP_"^"_Y,XTMP(1)=XTMP(1)_"^"_Y(1) - ; - ; see if exempt or copay cap was met - I $P(Y(1),"^",6) D G QUIT - . S PREA="R",PSOOLD="Copay",PSONW="No Copay" - . S PSOCOMM="RX COPAY INCOME EXEMPTION" S PSODA=RXP D ACTLOG^PSOCPA - . S $P(^PSRX(RXP,"IB"),"^",1)="" - I $P(Y(1),"^",4) D - . S PSOCOMM=$S($P(Y(1),"^",5)="F":" FULL BILLING FOR THIS FILL",$P(Y(1),"^",5)="P":" PARTIAL BILLING FOR THIS FILL ",1:" NO BILLING FOR THIS FILL") - . S PREA="A" - . S PSODA=RXP D ACTLOG^PSOCPA - . I $P(Y(1),"^",5)'="F" D - . . I PSOREF S $P(^PSRX(RXP,1,PSOREF,"IB"),"^",2)=$P(Y(1),"^",7) Q - . . S $P(^PSRX(RXP,"IB"),"^",4)=$P(Y(1),"^",7) - I $P(Y(1),"^",1)="" G QUIT - ; -FILE ;File IB number in ^PSRX - S PSOCP2=0 - S PSOCP2=+$P(XTMP(1),":",3) - S:PSOCP2>0 ^PSRX(RXP,1,PSOCP2,"IB")=$P(XTMP(1),U,3) ; Filing in refill node - I PSOCP2>0,'$D(^PSRX(RXP,"IB")) S ^PSRX(RXP,"IB")="1^^" ; If refill "IB" exists, need "IB" entry on original fill node - S:PSOCP2=0 $P(^PSRX(RXP,"IB"),"^",2)=$P(XTMP(1),U,3) ;Filing in original fill (zero node) -QUIT ; - K Y,PSOCP1,PSOCP2,QQ,PSOCPN,X,X2,XTMP,PSOCPUN,PSOREF,PSOCHG,PSOSAVE,PSOCOMM,PSOOLD,PSONW,PREA,PSORSN - Q -EN D ^PSOLSET -EN1 S DIR(0)="NO",DIR("A")="Enter PRESCRIPTION number" D ^DIR K DIR G:$D(DIRUT) EXIT S RXP=X I +$G(^PSRX(RXP,0))'>0!+$P($G(^PSRX(RXP,"IB")),"^",0)>0 W !,?10,"RE-CHECK PRESCRIPTION NUMBER AND RE-ENTER " G EN1 - S PSOSITE7=$P(^PS(59,PSOSITE,"IB"),"^") - S PSODFN=$P(^PSRX(RXP,0),"^",2) - D CP G EN1 -EXIT K RXP D FINAL^PSOLSET Q - ; -SC(PSODFN,PSODD) ;sup ref for CPRS, Pre-Copay enhancement - N PSOSC - I $$DT^PSOMLLDT S PSOSC="" G SCQ - I $G(PSODD),($P($G(^PSDRUG(PSODD,0)),"^",3)["S")!($P($G(^(0)),"^",3)["I") S PSOSC=1 G SCQ - I $P($G(^PS(55,+$G(PSODFN),"PS")),"^"),$P($G(^PS(53,+$P(^("PS"),"^"),0)),"^",7) S PSOSC=1 G SCQ - N I,J,X S (X,PSOSC)="" - S J=0 F S J=$O(^PS(59,J)) Q:'J I +$G(^(J,"IB")) S X=+^("IB") Q - G:'X SCQ - S X=X_"^"_PSODFN D XTYPE^IBARX - S J="" F S J=$O(Y(J)) Q:'J S I="" F S I=$O(Y(J,I)) Q:I="" S:I>0 PSOSC=I -SCQ Q $S($G(PSOSC)=2:0,1:1) - ; -COPAYREL ; Recheck copay status at release - ; check Rx patient status - I $P(^PSRX(RXP,0),"^",3)'="",$P($G(^PS(53,$P(^PSRX(RXP,0),"^",3),0)),"^",7)=1 S PSOCHG=0,PSOCOMM="Rx Patient Status Change",PSOOLD="Copay",PSONW="No Copay" Q - ; see if drug is investigational or supply - N DRG,DRGTYP,X - S DRG=+$P(^PSRX(RXP,0),"^",6),DRGTYP=$P($G(^PSDRUG(DRG,0)),"^",3) - I DRGTYP["I" S PSOCOMM="Investigational Drug",PSOCHG=0,PSOOLD="Copay",PSONW="No Copay",PSOCHG=0 - I DRGTYP["S" S PSOCOMM="Supply Item",PSOCHG=0,PSOOLD="Copay",PSONW="No Copay",PSOCHG=0 - K PSOTG,CHKXTYPE - I +$G(^PSRX(RXP,"IBQ")) D XTYPE1^PSOCP1 - I $G(^PSRX(RXP,"IBQ"))["1" D S PSOCHG=0,PSOOLD="Copay",PSONW="No Copay" Q ; COPAY EXEMPT - . N EXMT,II,PSOCIBQ - . S PSOCIBQ=$G(^PSRX(RXP,"IBQ")) - . F II=1,7,3,4,5,6,2,8 I $P(PSOCIBQ,"^",II)=1 S EXMT=$S(II=1:"SC",II=7:"CV",II=3:"AO",II=4:"IR",II=5:"EC",II=8:"SHAD",II=2:"MST",II=6:"HNC",1:"") D:EXMT'="" SETCOMM Q - D SCNEW(.PSOTG,PSOCPN,DRG,RXP) - N EXMT - I '$D(CHKXTYPE) D XTYPE - F EXMT="SC","CV","AO","IR","EC","SHAD","MST","HNC" I $D(PSOTG(EXMT)) D I 'PSOCHG Q - . I PSOTG(EXMT)=1 S PSOCHG=0 D SETCOMM - I 'PSOCHG S PSOOLD="Copay",PSONW="No Copay" Q - ; - ; If any of the applicable exemption quest have never been answered, send a mail msg with all of the quest - S EXMT="",MAILMSG=0 F S EXMT=$O(PSOTG(EXMT)) Q:EXMT="" I PSOTG(EXMT)="" S MAILMSG=1 Q - I MAILMSG,$D(PSOTG("SC")) I $G(PSOTG("SC"))="" S PSOCHG=2 ; 'SC' quest not answered, don't reset copay status to 'copay' - Q - ; -SCNEW(PSOTG,PSOPT,PSODR,PSORN) ;CPRS supported ref - I '$$DT^PSOMLLDT Q - I '$G(PSOPT) Q - ;I $G(PSODR),($P($G(^PSDRUG(PSODR,0)),"^",3)["S")!($P($G(^(0)),"^",3)["I") Q ;CIDC ALWAYS ASK - N PSOCIBQ,PSOQMSH,PSOQVEH,PSOQRQD,PSOQHNC,PSOQPGW,DFN,PSOSCA,ZXX - K PSOANSQ("SC>50") - S DFN=PSOPT - D SCP^PSORN52D S:PSOSCP>49&(PSOSCA) PSOANSQ("SC>50")=1 - I $G(PSORN) D - . S PSOCIBQ=$G(^PSRX(PSORN,"IBQ")) - . I $TR(PSOCIBQ,"^")="" S ZXX=$G(^PSRX(PSORN,"ICD",1,0)) D ICD:ZXX'="" - I '$G(PSORN) S PSOCIBQ="" - ;Rx Patient Status check is not being done here - N PSOSCMX,Y,I,J,X S (X,PSOSCMX)="" - S J=0 F S J=$O(^PS(59,J)) Q:'J I +$G(^(J,"IB")) S X=+^("IB") Q - G:'X SKIP - S X=X_"^"_PSOPT D XTYPE^IBARX - S J="" F S J=$O(Y(J)) Q:'J S I="" F S I=$O(Y(J,I)) Q:I="" S:I>0 PSOSCMX=I -SKIP ; - I $G(PSOSCA)!($G(PSOSCMX)=2) S PSOTG("SC")=$S($P(PSOCIBQ,"^")=1:1,$P(PSOCIBQ,"^")=0:0,$G(PSORN)&($P($G(^PSRX(+$G(PSORN),"IB")),"^")):0,1:"") - S:$$AO^SDCO22(PSOPT) PSOTG("AO")=$S($P(PSOCIBQ,"^",3)=1:1,$P(PSOCIBQ,"^",3)=0:0,1:"") - S:$$IR^SDCO22(PSOPT) PSOTG("IR")=$S($P(PSOCIBQ,"^",4)=1:1,$P(PSOCIBQ,"^",4)=0:0,1:"") - S:$$EC^SDCO22(PSOPT) PSOTG("EC")=$S($P(PSOCIBQ,"^",5)=1:1,$P(PSOCIBQ,"^",5)=0:0,1:"") - S:$P($$GETSTAT^DGMSTAPI(PSOPT),"^",2)="Y" PSOTG("MST")=$S($P(PSOCIBQ,"^",2)=1:1,$P(PSOCIBQ,"^",2)=0:0,1:"") - I $T(GETCUR^DGNTAPI)]"" N PSONC,PSONCX S PSONCX=$$GETCUR^DGNTAPI(PSOPT,"PSONC") I $P($G(PSONC("IND")),"^")="Y" S PSOTG("HNC")=$S($P(PSOCIBQ,"^",6)=1:1,$P(PSOCIBQ,"^",6)=0:0,1:"") - S:$P($$CVEDT^DGCV(PSOPT),"^",3) PSOTG("CV")=$S($P(PSOCIBQ,"^",7)=1:1,$P(PSOCIBQ,"^",7)=0:0,1:"") - I $L($T(GETSHAD^DGUTL3)) S:$$GETSHAD^DGUTL3(PSOPT)=1 PSOTG("SHAD")=$S($P(PSOCIBQ,"^",8)=1:1,$P(PSOCIBQ,"^",8)=0:0,1:"") - Q - ; -ICD ; - D ICD^PSOCP1 - Q -XTYPE ; - N PSOCIBQ,PSOSCMX,Y,I,J,X,SAVY,ZXX - S (X,PSOSCMX,SAVY)="" - S PSOCIBQ=$G(^PSRX(RXP,"IBQ")) I $TR(PSOCIBQ,"^")="" S ZXX=$G(^PSRX(RXP,"ICD",1,0)) D ICD:ZXX'="" - I $P(PSOCIBQ,"^",1)'="" S PSOTG("SC")=$P(PSOCIBQ,"^",1) - I $D(PSOTG("SC")),$P(PSOCIBQ,"^",1)="" S PSOTG("SC")="" ; USE "CURRENT" SETTING AS ANS TO SC QUEST IF IT APPLIES - S J=0 F S J=$O(^PS(59,J)) Q:'J I +$G(^(J,"IB")) S X=+^("IB") Q - I 'X Q - S X=X_"^"_PSOCPN D XTYPE^IBARX - I $G(Y)'=1 Q - S J="" F S J=$O(Y(J)) Q:'J S I="" F S SAVY=I,I=$O(Y(J,I)) Q:I="" S:I>0 PSOSCMX=I - I PSOSCMX="",SAVY=0 S PSOCHG=0 S PSOCOMM="Exempt from copayment" Q ; INCOME EXEMPT OR SC - I PSOSCMX=2,'$D(PSOTG("SC")) S PSOTG("SC")=$S(($G(RXP)&($P($G(^PSRX(+$G(RXP),"IB")),"^")))!($P(PSOCIBQ,"^")=0):0,$P(PSOCIBQ,"^")=1:1,1:"") Q - Q - ; -SETCOMM ; - D SETCOMM^PSOCP1 - Q - ; +PSOCP ;BIR/BAB - Pharmacy CO-PAY Application Utilities for IB ;02/06/92 + ;;7.0;OUTPATIENT PHARMACY;**20,46,71,85,137,157,143,219,239,201**;DEC 1997 + ; + ;REF/IA - IBARX/125, SDCO22/1579, PS(55/2228, PSDRUG(/221, DGMSTAPI/2716 +CP ;Check if COPAY-Requires RXP,PSOSITE7 + I '$D(PSOPAR) D ^PSOLSET G CP + K PSOCP + S PSOCPN=$P(^PSRX(RXP,0),"^",2) ; Set COPAY dfn PTR TO PATIENT + S PSOCP=$P($G(^PSRX(RXP,"IB")),"^") ; IB action type + S PSOSAVE=$S(PSOCP:1,1:"") ; save current copay status + ; Set x=service^dfn^actiontype^user duz + I +$G(PSOSITE7)'>0 S PSOSITE7=$P(^PS(59,PSOSITE,"IB"),"^") + S X=PSOSITE7_"^"_PSOCPN_"^"_PSOCP_"^"_$P(^PSRX(RXP,0),"^",16) + ; +RX ;Determine Orig or Refill for RX + N PSOIB,PSOPFS S (PSOIB,PSOREF)=0 + I $G(^PSRX(RXP,1,+$G(YY),0))]"" S PSOREF=YY + D PFSA^PSOPFSU1(RXP,PSOREF,2) G PFS:+PSOPFS + ; Check if bill exists + I 'PSOREF,+$P($G(^PSRX(RXP,"IB")),"^",2)>0 D CHKIB^PSOCP1 I PSOIB G QUIT + I 'PSOREF,+$P($G(^PSRX(RXP,"IB")),"^",4)>0 G QUIT ; 'POTENTIAL BILL' - ALREADY ATTEMPTED TO BILL, BUT EXCEEDED ANNUAL COPAY CAP + I PSOREF,+$G(^PSRX(RXP,1,PSOREF,"IB")) D CHKIB^PSOCP1 I PSOIB G QUIT + I PSOREF,+$P($G(^PSRX(RXP,1,PSOREF,"IB")),"^",2) G QUIT ; POTENTIAL BILL +PFS ; + S PSOCHG=1 ; set tem var to copay and check exception + N MAILMSG + D COPAYREL + I 'PSOCHG D D:PSOPFS CHRG^PSOPFSU1(RXP,PSOREF,"CG",PSOPFS) G QUIT + . I PSOSAVE S PSODA=RXP,PREA="R" D ACTLOG^PSOCPA S $P(^PSRX(RXP,"IB"),"^",1)="" + I PSOCHG=2 D I 'PSOCP D:PSOPFS CHRG^PSOPFSU1(RXP,PSOREF,"CG",PSOPFS) G QUIT ; IF 'SC' QUESTION APPLIES, BUT HAS NOT BEEN ANSWERED, SEND MAIL MSG AND KEEP COPAY STATUS AS IT WAS + . D MAIL2^PSOCPE ; SEND MAIL TO PHARMACIST, PROVIDER, AND HOLDERS OF THE PSO COPAY KEY + I PSOCHG=1,PSOSAVE="" D I PSOREF S PSOCOMM="",PSOOLD="No Copay",PSONW="Copay" S PSODA=RXP,PREA="R" D ACTLOG^PSOCPA + . I '$D(^PSRX(RXP,"IB")),'PSOREF S $P(^PSRX(RXP,"IB"),"^",1)=1 Q + . S $P(^PSRX(RXP,"IB"),"^",1)=1 + . S PSOCP=1,$P(X,"^",3)=PSOCP + I PSOCHG'=2 I $G(MAILMSG) D MAIL2^PSOCPE ; SEND MAIL TO PHARM, PROV, AND HOLDERS OF PSO COPAY KEY HOLDERS + ; Units for COPAY + S PSOCPUN=$P(($P(^PSRX(RXP,0),"^",8)+29)/30,".",1) + ; Build softlink for x(n)=softlink^units + S X(1)="52:"_RXP S:PSOREF>0 X(1)=X(1)_";1:"_PSOREF S X(1)=X(1)_"^"_PSOCPUN + ; Set correct user duz if refill + I PSOREF S:+$P(^PSRX(RXP,1,PSOREF,0),"^",7)>0 $P(X,"^",4)=$P(^PSRX(RXP,1,PSOREF,0),"^",7) + ; +IBNEW ; Load ^TMP global for IB call + Q:$G(RXP)'>0 + I PSOPFS D CHRG^PSOPFSU1(RXP,PSOREF,"CG",PSOPFS) + G QUIT:PSOPFS + N D0 + G QUIT:'$D(X) + S XTMP=X,XTMP(1)=X(1) + ; + ; Requires x=service^dfn^action type^user duz + ; x(n)=softlink^units + I $P(X,"^",3)="" S $P(X,"^",3)=$P(^PSRX(RXP,"IB"),"^",1) + D NEW^IBARX + ; Returns y=1^total charges for this group or Y=-1^error code + ; y(n)=IB number^charge for this Rx^AR bill #^Cap met^Partial or Full charge^Copay Exempt^Number from file 354.71 + ; Cap met ('1' - If patient has met cap amount or reached cap with this charge or '0' if not) + ; Partial or Full ('P' for partial billing, 'F' for full billing, null for no billing) + ; Copay Exempt - ('1' for exempt, '0' for non-exempt, '-1' for copay off (manila)), + ; ('1' - If patient has met cap amount or reach cap with this charge + ; Entry from file 354.71 will only be saved for fills that met the annual cap and could not be fully billed + ; + G QUIT:+Y=-1 + S XTMP=XTMP_"^"_Y,XTMP(1)=XTMP(1)_"^"_Y(1) + ; + ; see if exempt or copay cap was met + I $P(Y(1),"^",6) D G QUIT + . S PREA="R",PSOOLD="Copay",PSONW="No Copay" + . S PSOCOMM="RX COPAY INCOME EXEMPTION" S PSODA=RXP D ACTLOG^PSOCPA + . S $P(^PSRX(RXP,"IB"),"^",1)="" + I $P(Y(1),"^",4) D + . S PSOCOMM=$S($P(Y(1),"^",5)="F":" FULL BILLING FOR THIS FILL",$P(Y(1),"^",5)="P":" PARTIAL BILLING FOR THIS FILL ",1:" NO BILLING FOR THIS FILL") + . S PREA="A" + . S PSODA=RXP D ACTLOG^PSOCPA + . I $P(Y(1),"^",5)'="F" D + . . I PSOREF S $P(^PSRX(RXP,1,PSOREF,"IB"),"^",2)=$P(Y(1),"^",7) Q + . . S $P(^PSRX(RXP,"IB"),"^",4)=$P(Y(1),"^",7) + I $P(Y(1),"^",1)="" G QUIT + ; +FILE ;File IB number in ^PSRX + S PSOCP2=0 + S PSOCP2=+$P(XTMP(1),":",3) + S:PSOCP2>0 ^PSRX(RXP,1,PSOCP2,"IB")=$P(XTMP(1),U,3) ; Filing in refill node + I PSOCP2>0,'$D(^PSRX(RXP,"IB")) S ^PSRX(RXP,"IB")="1^^" ; If refill "IB" exists, need "IB" entry on original fill node + S:PSOCP2=0 $P(^PSRX(RXP,"IB"),"^",2)=$P(XTMP(1),U,3) ;Filing in original fill (zero node) +QUIT ; + K Y,PSOCP1,PSOCP2,QQ,PSOCPN,X,X2,XTMP,PSOCPUN,PSOREF,PSOCHG,PSOSAVE,PSOCOMM,PSOOLD,PSONW,PREA,PSORSN + Q +EN D ^PSOLSET +EN1 S DIR(0)="NO",DIR("A")="Enter PRESCRIPTION number" D ^DIR K DIR G:$D(DIRUT) EXIT S RXP=X I +$G(^PSRX(RXP,0))'>0!+$P($G(^PSRX(RXP,"IB")),"^",0)>0 W !,?10,"RE-CHECK PRESCRIPTION NUMBER AND RE-ENTER " G EN1 + S PSOSITE7=$P(^PS(59,PSOSITE,"IB"),"^") + S PSODFN=$P(^PSRX(RXP,0),"^",2) + D CP G EN1 +EXIT K RXP D FINAL^PSOLSET Q + ; +SC(PSODFN,PSODD) ;sup ref for CPRS, Pre-Copay enhancement + N PSOSC + I $$DT^PSOMLLDT S PSOSC="" G SCQ + I $G(PSODD),($P($G(^PSDRUG(PSODD,0)),"^",3)["S")!($P($G(^(0)),"^",3)["I") S PSOSC=1 G SCQ + I $P($G(^PS(55,+$G(PSODFN),"PS")),"^"),$P($G(^PS(53,+$P(^("PS"),"^"),0)),"^",7) S PSOSC=1 G SCQ + N I,J,X S (X,PSOSC)="" + S J=0 F S J=$O(^PS(59,J)) Q:'J I +$G(^(J,"IB")) S X=+^("IB") Q + G:'X SCQ + S X=X_"^"_PSODFN D XTYPE^IBARX + S J="" F S J=$O(Y(J)) Q:'J S I="" F S I=$O(Y(J,I)) Q:I="" S:I>0 PSOSC=I +SCQ Q $S($G(PSOSC)=2:0,1:1) + ; +COPAYREL ; Recheck copay status at release + ; check Rx patient status + I $P(^PSRX(RXP,0),"^",3)'="",$P($G(^PS(53,$P(^PSRX(RXP,0),"^",3),0)),"^",7)=1 S PSOCHG=0,PSOCOMM="Rx Patient Status Change",PSOOLD="Copay",PSONW="No Copay" Q + ; see if drug is investigational or supply + N DRG,DRGTYP,X + S DRG=+$P(^PSRX(RXP,0),"^",6),DRGTYP=$P($G(^PSDRUG(DRG,0)),"^",3) + I DRGTYP["I" S PSOCOMM="Investigational Drug",PSOCHG=0,PSOOLD="Copay",PSONW="No Copay",PSOCHG=0 + I DRGTYP["S" S PSOCOMM="Supply Item",PSOCHG=0,PSOOLD="Copay",PSONW="No Copay",PSOCHG=0 + K PSOTG,CHKXTYPE + I +$G(^PSRX(RXP,"IBQ")) D XTYPE1^PSOCP1 + I $G(^PSRX(RXP,"IBQ"))["1" D S PSOCHG=0,PSOOLD="Copay",PSONW="No Copay" Q ; COPAY EXEMPT + . N EXMT,II,PSOCIBQ + . S PSOCIBQ=$G(^PSRX(RXP,"IBQ")) + . F II=1,7,3,4,5,6,2 I $P(PSOCIBQ,"^",II)=1 S EXMT=$S(II=1:"SC",II=7:"CV",II=3:"AO",II=4:"IR",II=5:"EC",II=2:"MST",II=6:"HNC",1:"") D:EXMT'="" SETCOMM Q + D SCNEW(.PSOTG,PSOCPN,DRG,RXP) + N EXMT + I '$D(CHKXTYPE) D XTYPE + F EXMT="SC","CV","AO","IR","EC","MST","HNC" I $D(PSOTG(EXMT)) D I 'PSOCHG Q + . I PSOTG(EXMT)=1 S PSOCHG=0 D SETCOMM + I 'PSOCHG S PSOOLD="Copay",PSONW="No Copay" Q + ; + ; If any of the applicable exemption quest have never been answered, send a mail msg with all of the quest + S EXMT="",MAILMSG=0 F S EXMT=$O(PSOTG(EXMT)) Q:EXMT="" I PSOTG(EXMT)="" S MAILMSG=1 Q + I MAILMSG,$D(PSOTG("SC")) I $G(PSOTG("SC"))="" S PSOCHG=2 ; 'SC' quest not answered, don't reset copay status to 'copay' + Q + ; +SCNEW(PSOTG,PSOPT,PSODR,PSORN) ;CPRS supported ref + I '$$DT^PSOMLLDT Q + I '$G(PSOPT) Q + ;I $G(PSODR),($P($G(^PSDRUG(PSODR,0)),"^",3)["S")!($P($G(^(0)),"^",3)["I") Q ;CIDC ALWAYS ASK + N PSOCIBQ,PSOQMSH,PSOQVEH,PSOQRQD,PSOQHNC,PSOQPGW,DFN,PSOSCA,ZXX + K PSOANSQ("SC>50") + S DFN=PSOPT + D SCP^PSORN52D S:PSOSCP>49&(PSOSCA) PSOANSQ("SC>50")=1 + I $G(PSORN) D + . S PSOCIBQ=$G(^PSRX(PSORN,"IBQ")) + . I $TR(PSOCIBQ,"^")="" S ZXX=$G(^PSRX(PSORN,"ICD",1,0)) D ICD:ZXX'="" + I '$G(PSORN) S PSOCIBQ="" + ;Rx Patient Status check is not being done here + N PSOSCMX,Y,I,J,X S (X,PSOSCMX)="" + S J=0 F S J=$O(^PS(59,J)) Q:'J I +$G(^(J,"IB")) S X=+^("IB") Q + G:'X SKIP + S X=X_"^"_PSOPT D XTYPE^IBARX + S J="" F S J=$O(Y(J)) Q:'J S I="" F S I=$O(Y(J,I)) Q:I="" S:I>0 PSOSCMX=I +SKIP ; + I $G(PSOSCA)!($G(PSOSCMX)=2) S PSOTG("SC")=$S($P(PSOCIBQ,"^")=1:1,$P(PSOCIBQ,"^")=0:0,$G(PSORN)&($P($G(^PSRX(+$G(PSORN),"IB")),"^")):0,1:"") + S:$$AO^SDCO22(PSOPT) PSOTG("AO")=$S($P(PSOCIBQ,"^",3)=1:1,$P(PSOCIBQ,"^",3)=0:0,1:"") + S:$$IR^SDCO22(PSOPT) PSOTG("IR")=$S($P(PSOCIBQ,"^",4)=1:1,$P(PSOCIBQ,"^",4)=0:0,1:"") + S:$$EC^SDCO22(PSOPT) PSOTG("EC")=$S($P(PSOCIBQ,"^",5)=1:1,$P(PSOCIBQ,"^",5)=0:0,1:"") + S:$P($$GETSTAT^DGMSTAPI(PSOPT),"^",2)="Y" PSOTG("MST")=$S($P(PSOCIBQ,"^",2)=1:1,$P(PSOCIBQ,"^",2)=0:0,1:"") + I $T(GETCUR^DGNTAPI)]"" N PSONC,PSONCX S PSONCX=$$GETCUR^DGNTAPI(PSOPT,"PSONC") I $P($G(PSONC("IND")),"^")="Y" S PSOTG("HNC")=$S($P(PSOCIBQ,"^",6)=1:1,$P(PSOCIBQ,"^",6)=0:0,1:"") + S:$P($$CVEDT^DGCV(PSOPT),"^",3) PSOTG("CV")=$S($P(PSOCIBQ,"^",7)=1:1,$P(PSOCIBQ,"^",7)=0:0,1:"") + Q + ; +ICD ; + D ICD^PSOCP1 + Q +XTYPE ; + N PSOCIBQ,PSOSCMX,Y,I,J,X,SAVY,ZXX + S (X,PSOSCMX,SAVY)="" + S PSOCIBQ=$G(^PSRX(RXP,"IBQ")) I $TR(PSOCIBQ,"^")="" S ZXX=$G(^PSRX(RXP,"ICD",1,0)) D ICD:ZXX'="" + I $P(PSOCIBQ,"^",1)'="" S PSOTG("SC")=$P(PSOCIBQ,"^",1) + I $D(PSOTG("SC")),$P(PSOCIBQ,"^",1)="" S PSOTG("SC")="" ; USE "CURRENT" SETTING AS ANS TO SC QUEST IF IT APPLIES + S J=0 F S J=$O(^PS(59,J)) Q:'J I +$G(^(J,"IB")) S X=+^("IB") Q + I 'X Q + S X=X_"^"_PSOCPN D XTYPE^IBARX + I $G(Y)'=1 Q + S J="" F S J=$O(Y(J)) Q:'J S I="" F S SAVY=I,I=$O(Y(J,I)) Q:I="" S:I>0 PSOSCMX=I + I PSOSCMX="",SAVY=0 S PSOCHG=0 S PSOCOMM="Exempt from copayment" Q ; INCOME EXEMPT OR SC + I PSOSCMX=2,'$D(PSOTG("SC")) S PSOTG("SC")=$S(($G(RXP)&($P($G(^PSRX(+$G(RXP),"IB")),"^")))!($P(PSOCIBQ,"^")=0):0,$P(PSOCIBQ,"^")=1:1,1:"") Q + Q + ; +SETCOMM ; + D SETCOMM^PSOCP1 + Q + ; diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCP1.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCP1.m index 1a9b1079..f5391e6e 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCP1.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCP1.m @@ -1,53 +1,52 @@ -PSOCP1 ;BHAM ISC/EJW-PHARMACY CO-PAY APPLICATION UTILITIES FOR IB (CONT'D) ;12/12/02 - ;;7.0;OUTPATIENT PHARMACY;**137,239,225**;DEC 1997;Build 29 - ; - ;REF/IA - ;IBARX/125 -CHKIB ; SEE IF BILL # IS A CHARGE OR CANCELLATION # - N IBN,XX - I PSOREF=0 S XX=$G(^PSRX(RXP,"IB")) I $P(XX,"^",4)'="" S PSOIB=1 Q ;ALREADY BILLED - I PSOREF=0 S IBN=$P(XX,"^",2) - I PSOREF'=0 S XX=$G(^PSRX(RXP,1,PSOREF,"IB")) I $P(XX,"^",2)'="" S PSOIB=1 Q ;ALREADY BILLED - I PSOREF'=0 S IBN=$P(XX,"^",1) - I IBN'="" D STATUS - Q - ; -STATUS ; - N XX - S XX=$$STATUS^IBARX(IBN) - I XX'=1,XX'=3 Q - S PSOIB=1 ; ALREADY BILLED - Q - ; -XTYPE1 ; - N PSOCIBQ,PSOSCMX,Y,I,J,X,SAVY - S (X,PSOSCMX,SAVY)="" - S PSOCIBQ=$G(^PSRX(RXP,"IBQ")) - I $P(PSOCIBQ,"^",1)'=1 Q - S J=0 F S J=$O(^PS(59,J)) Q:'J I +$G(^(J,"IB")) S X=+^("IB") Q - I 'X Q - S X=X_"^"_PSOCPN D XTYPE^IBARX - I $G(Y)'=1 Q - S J="" F S J=$O(Y(J)) Q:'J S I="" F S SAVY=I,I=$O(Y(J,I)) Q:I="" S:I>0 PSOSCMX=I - I PSOSCMX="",SAVY=0 Q ; INCOME EXEMPT OR SERVICE-CONNECTED - I PSOSCMX=2 Q ; NEED TO ASK SC QUESTION - ; If get to here, service-connected question does not apply for this patient anymore. Update "IBQ" and CPRS - S $P(^PSRX(RXP,"IBQ"),"^",1)="",CHKXTYPE=1 - D EN^PSOHLSN1(RXP,"XX","","Order edited") - Q - ; -SETCOMM ; - I EXMT="SC" S PSOCOMM="Service Connected" Q - I EXMT="CV" S PSOCOMM="COMBAT VETERAN" Q - I EXMT="AO" S PSOCOMM="AGENT ORANGE RELATED" Q - I EXMT="IR" S PSOCOMM="IONIZING RAD RELATED" Q - I EXMT="EC" S PSOCOMM="SW ASIA COND. RELATED" Q - I EXMT="SHAD" S PSOCOMM="PROJ 112/SHAD" Q - I EXMT="MST" S PSOCOMM="MILITARY SEXUAL TRAUMA" Q - I EXMT="HNC" S PSOCOMM="Head and/or Neck Cancer" Q - Q - ; -ICD ; - S PSOCIBQ=$P(ZXX,U,4)_"^"_$P(ZXX,U,6)_"^"_$P(ZXX,U,2)_"^"_$P(ZXX,U,3)_"^"_$P(ZXX,U,5)_"^"_$P(ZXX,U,7)_"^"_$P(ZXX,U,8)_"^"_$P(ZXX,U,9) - Q - ; +PSOCP1 ;BHAM ISC/EJW-PHARMACY CO-PAY APPLICATION UTILITIES FOR IB (CONT'D) ;12/12/02 + ;;7.0;OUTPATIENT PHARMACY;**137,239**;DEC 1997 + ; + ;REF/IA + ;IBARX/125 +CHKIB ; SEE IF BILL # IS A CHARGE OR CANCELLATION # + N IBN,XX + I PSOREF=0 S XX=$G(^PSRX(RXP,"IB")) I $P(XX,"^",4)'="" S PSOIB=1 Q ;ALREADY BILLED + I PSOREF=0 S IBN=$P(XX,"^",2) + I PSOREF'=0 S XX=$G(^PSRX(RXP,1,PSOREF,"IB")) I $P(XX,"^",2)'="" S PSOIB=1 Q ;ALREADY BILLED + I PSOREF'=0 S IBN=$P(XX,"^",1) + I IBN'="" D STATUS + Q + ; +STATUS ; + N XX + S XX=$$STATUS^IBARX(IBN) + I XX'=1,XX'=3 Q + S PSOIB=1 ; ALREADY BILLED + Q + ; +XTYPE1 ; + N PSOCIBQ,PSOSCMX,Y,I,J,X,SAVY + S (X,PSOSCMX,SAVY)="" + S PSOCIBQ=$G(^PSRX(RXP,"IBQ")) + I $P(PSOCIBQ,"^",1)'=1 Q + S J=0 F S J=$O(^PS(59,J)) Q:'J I +$G(^(J,"IB")) S X=+^("IB") Q + I 'X Q + S X=X_"^"_PSOCPN D XTYPE^IBARX + I $G(Y)'=1 Q + S J="" F S J=$O(Y(J)) Q:'J S I="" F S SAVY=I,I=$O(Y(J,I)) Q:I="" S:I>0 PSOSCMX=I + I PSOSCMX="",SAVY=0 Q ; INCOME EXEMPT OR SERVICE-CONNECTED + I PSOSCMX=2 Q ; NEED TO ASK SC QUESTION + ; If get to here, service-connected question does not apply for this patient anymore. Update "IBQ" and CPRS + S $P(^PSRX(RXP,"IBQ"),"^",1)="",CHKXTYPE=1 + D EN^PSOHLSN1(RXP,"XX","","Order edited") + Q + ; +SETCOMM ; + I EXMT="SC" S PSOCOMM="Service Connected" Q + I EXMT="CV" S PSOCOMM="COMBAT VETERAN" Q + I EXMT="AO" S PSOCOMM="AGENT ORANGE RELATED" Q + I EXMT="IR" S PSOCOMM="IONIZING RAD RELATED" Q + I EXMT="EC" S PSOCOMM="ENV CONTAMINANTS RELATED" Q + I EXMT="MST" S PSOCOMM="MILITARY SEXUAL TRAUMA" Q + I EXMT="HNC" S PSOCOMM="Head and/or Neck Cancer" Q + Q + ; +ICD ; + S PSOCIBQ=$P(ZXX,U,4)_"^"_$P(ZXX,U,6)_"^"_$P(ZXX,U,2)_"^"_$P(ZXX,U,3)_"^"_$P(ZXX,U,5)_"^"_$P(ZXX,U,7)_"^"_$P(ZXX,U,8) + Q + ; diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCPC.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCPC.m index ac0e6ee9..106ea40c 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCPC.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCPC.m @@ -1,166 +1,157 @@ -PSOCPC ;BHAM ISC/BAB - PHARMACY CO-PAY APPLICATION ;06/09/92 - ;;7.0;OUTPATIENT PHARMACY;**10,9,71,85,114,157,143,239,201,275,225**;DEC 1997;Build 29 - ; - ;REF/IA - ;piece 9 of zero node of File 350 and APDT cross reference of File 350/2215 - ;$$STATUS^IBARX/125 - ;File 350.1/592 (DBIA125-B) -WARN ; Message when attempt is made to delete a refill date on COPAY - N PSOIB,PSOIBST - S PSOFLG=0 - G:'$D(^PSRX(DA(1),1,DA,"IB")) ENDW - S PSOIB=^PSRX(DA(1),1,DA,"IB") - I +PSOIB'>0 G ENDW - S PSOIBST=$$STATUS^IBARX(+PSOIB) I PSOIBST=2!(PSOIBST=0) G ENDW - I +PSOIB>0 D CANCEL G ENDW:PSOFLG=0 - I '$G(PSOXXDEL) D EN^DDIOL("This REFILL has COPAY charges, which MUST be removed","","$C(7),!!"),EN^DDIOL("BEFORE the refill date is deleted.","","!") - I '$G(PSOXXDEL) D EN^DDIOL("Use option RESET COPAY STATUS/CANCEL CHARGES, return to EDIT A PRESCRIPTION,","","!!"),EN^DDIOL("and delete the refill date.","","!"),EN^DDIOL(" ","","!!") - S PSOFLG=1 -ENDW ; - I PSOFLG - K PSOFLG - Q -CANCEL ;Check if charge is cancelled for this Refill date - S PSOFLG=1 ;indicates a charge not cancelled - S PSOX=+^PSRX(DA(1),1,DA,"IB") - D LAST I PSOLAST'=PSOPARNT,$D(^IB(PSOLAST,0)),$P(^IBE(350.1,$P(^IB(PSOLAST,0),"^",3),0),"^",5)=2 S PSOFLG=0 - K PSOLAST,PSOPARNT,PSOX,PSOL,PSOLDT - Q -LAST ;find last entry - S PSOLAST="" - S PSOPARNT=$P(^IB(+PSOX,0),"^",9) I 'PSOPARNT S PSOPARNT=+PSOX - S PSOLDT=$O(^IB("APDT",PSOPARNT,"")) I +PSOLDT F PSOL=0:0 S PSOL=$O(^IB("APDT",PSOPARNT,PSOLDT,PSOL)) Q:'PSOL S PSOLAST=PSOL - I PSOLAST="" S PSOLAST=PSOPARNT - Q - ; -EXEMCHK ; Allow reset of exemption answers - N PSOTG,PSOCPN,PSOEXMT,PSOANS,OLDIBQ,PSOSCP,PSOSCA - S PSOANS=0 D SCP^PSORN52D - S OLDIBQ=$G(^PSRX(PSODA,"IBQ")) - I OLDIBQ[0!(OLDIBQ)[1 D - . S PSOANS=1 - . I $P(OLDIBQ,"^",1)'="" S PSOTG("SC")=$P(OLDIBQ,"^",1) - . I $P(OLDIBQ,"^",2)'="" S PSOTG("MST")=$P(OLDIBQ,"^",2) - . I $P(OLDIBQ,"^",3)'="" S PSOTG("AO")=$P(OLDIBQ,"^",3) - . I $P(OLDIBQ,"^",4)'="" S PSOTG("IR")=$P(OLDIBQ,"^",4) - . I $P(OLDIBQ,"^",5)'="" S PSOTG("EC")=$P(OLDIBQ,"^",5) - . I $P(OLDIBQ,"^",6)'="" S PSOTG("HNC")=$P(OLDIBQ,"^",6) - . I $P(OLDIBQ,"^",7)'="" S PSOTG("CV")=$P(OLDIBQ,"^",7) - . I $P(OLDIBQ,"^",8)'="" S PSOTG("SHAD")=$P(OLDIBQ,"^",8) - S PSOCPN=$P(^PSRX(PSODA,0),"^",2) - S RXP=PSODA - D SCNEW^PSOCP(.PSOTG,PSOCPN,"",PSODA) - N EXMT - D XTYPE^PSOCP ; KEEP THIS CALL IN HERE TO SEE IF SC QUESTION APPLIES - ;I $D(PSOTG("SC")) S PSOTG("SC")=$P(OLDIBQ,"^",1) ; CHANGED TO JUST USE IBQ SETTING IF SC QUESTION APPLIES - DON'T RE-CALCULATE SERVICE-CONNECTED - S EXMT="" F S EXMT=$O(PSOTG(EXMT)) Q:EXMT="" I PSOTG(EXMT)'="" S PSOANS=1 Q - I $O(PSOTG(""))="" Q - I PSOANS W !!,"The following exemption flags have been set:" - F EXMT="SC","CV","AO","IR","EC","SHAD","MST","HNC" I $G(PSOTG(EXMT))'="" W !,$S(EXMT="EC":"SWAC",1:EXMT),": ",?6,$S(PSOTG(EXMT)=1:"Yes",PSOTG(EXMT)=0:"No",1:"") - W ! - W ! K DIR S DIR(0)="Y",DIR("B")="N" D S DIR("A")="Do you want to enter/edit any copay exemption flags" - . S EXMT="" F S EXMT=$O(PSOTG(EXMT)) Q:EXMT="" I PSOTG(EXMT)="" S DIR("B")="Y" Q - S DIR("?")="Enter 'Y' for Yes if you want to edit any applicable medication exemption flags." - S DIR("??")="^D HELPEXEM^PSOCPC" - D ^DIR K DIR S PSOEXMT=Y I Y'=1 Q - ; PRESENT ALL APPLICABLE EXEMPTIONS AND SAVE NEW ANSWERS - N PSOIBQ,PSOSUBS,PSOQUES,PSOLTAG,OLDIBQ,II,PSOCHG,PSOPATST - S PSOPATST=$$GET1^DIQ(52,PSODA_",",3,"I") - S PSOIBQ="" - S OLDIBQ=$G(^PSRX(PSODA,"IBQ")) - I '$D(^PSRX(PSODA,"IBQ")),+($G(^PSRX(PSODA,"IB")))=2 S $P(OLDIBQ,"^",1)=0 ; SC QUESTION WAS PREVIOUSLY ANSWERED AS N - S PSOCOMM="",PSOOLD="",PSONW="" - S II=0 - F EXMT="SC","CV","AO","IR","EC","SHAD","MST","HNC" I $D(PSOTG(EXMT)) D - . S PSOLTAG="REL"_EXMT_"^PSOCPE" - . S HELPTAG="HELP"_EXMT - . S PSOQUES=$P($T(@PSOLTAG),";",2) I PSOQUES="" Q - . S PSOQUES=$P(PSOQUES,"?") - . S PSOSUBS=$P($T(@PSOLTAG),";",3) I PSOSUBS="" Q - . D ASKEXEM - I $D(PSOCHG) D - . ;PSO*7*275 IBQ node should not be present in some cases. - . K ^PSRX(PSODA,"IBQ") - . S:PSOSCP<50&($TR(PSOIBQ,"^")'="")&($P($G(^PS(53,+$G(PSOPATST),0)),"^",7)'=1) ^PSRX(PSODA,"IBQ")=PSOIBQ - . D RESET^PSORN52D ;set SC/EI on ICD node - . S PSOPFSA=1 ;PFSS-denotes to calling routine that outpatient classifications changed. - . D EN^PSOHLSN1(PSODA,"XX","","Order edited") - . I PCOPAY,PSOIBQ["1" D ; RESET TO NO COPAY - . . W !,"Editing of exemption flag(s) has resulted in a copay status change.",!,"The status for this Rx will be reset to NO COPAY." - . . S $P(^PSRX(PSODA,"IB"),"^",1)="" - . . S PSOREF="",PSOOLD="Copay",PSONW="No Copay",PREA="R" D ACTLOG^PSOCPA - . . S PSOCOMM="Copay status reset due to exemption flag(s)" - . . S PSI=0 D SETSUMM - . I $G(II)>0 D - . . S PSOCOMM="The following exemption flags have been changed: ",PSI=0 D SETSUMM - . . S II="" F S II=$O(PSOCHG(II)) Q:II="" S PSOCOMM=PSOCHG(II),PSI=0 D SETSUMM - Q - ; -ASKEXEM ; ASK THE EXEMPTION QUESTIONS - K DIR S DIR("A")=PSOQUES,DIR(0)="YO" S:PSOTG(EXMT)=1 DIR("B")="Y" S:PSOTG(EXMT)=0 DIR("B")="N" D @HELPTAG -ASKEXEM1 D ^DIR I X="@" R !," Are you sure you want to delete this answer? ",X:DTIME I $E(X)'="Y",$E(X)'="y" G ASKEXEM1 - I X="^" S X=$G(DIR("B")) S Y=$S(X="Y":1,X="N":0,1:"") - S $P(PSOIBQ,"^",PSOSUBS)=$S(Y=1:1,Y=0:0,1:"") - I $P(PSOIBQ,"^",PSOSUBS)'=$P(OLDIBQ,"^",PSOSUBS) S II=II+1,PSOCHG(II)=$S(EXMT="EC":"SWAC",1:EXMT)_": "_$S($P(PSOIBQ,"^",PSOSUBS)=1:"Yes",$P(PSOIBQ,"^",PSOSUBS)=0:"No",1:"") - I Y=1 D - . I PSOCOMM'="" Q - . D SETCOMM^PSOCP - Q - ; -HELPEXEM ; help text for exemption edit question - W !,"Enter 'Y' for Yes if you want to edit any applicable exemption flags such as" - W !,"Service Connected (SC), Combat Veteran(CV), Agent Orange (AO), Ionizing" - W !,"Radiation (IR), Southwest Asia Conditions (SWAC), PROJ 112/SHAD," - W !,"Military Sexual Trauma (MST), or Head and/or Neck Cancer (HNC)." - Q - ; -HELPSC ; - S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is for a Service Connected condition." - S DIR("?",2)="This response will be used to determine whether or not a copay should be" - S DIR("?",3)="applied to the prescription." - Q - ; -HELPAO ; - S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition due to",DIR("?",2)="Vietnam-Era Herbicide (Agent Orange) exposure. This response will be used to" - S DIR("?",3)="determine whether or not a copay should be applied to the prescription." - Q - ; -HELPIR ; - S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition due to",DIR("?",2)="ionizing radiation exposure during military service. This response will be used" - S DIR("?",3)="to determine whether or not a copay should be applied to the prescription." - Q - ; -HELPEC ; - S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition related to",DIR("?",2)="service in Southwest Asia. This response will be used to determine whether" - S DIR("?",3)="or not a copay should be applied to the prescription." - Q - ; -HELPMST ; - S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition related",DIR("?",2)="to Military Sexual Trauma. This response will be used to determine whether or" - S DIR("?",3)="not a copay should be applied to the prescription." - Q - ; -HELPHNC ; - S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is being used to treat Head and/or Neck Cancer",DIR("?",2)="due to nose or throat radium treatments while in the military. This response" - S DIR("?",3)="will be used to determine whether or not a copay should be applied to the",DIR("?",4)="prescription." - Q - ; -HELPCV ; - S DIR("?")=" " - S DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition related" - S DIR("?",2)="to Combat Services. This response will be used to determine whether or" - S DIR("?",3)="not a copay should be applied to the prescription." - Q - ; -HELPSHAD ; - S DIR("?")=" " - S DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition related" - S DIR("?",2)="to PROJ 112/SHAD. This response will be used to determine whether or" - S DIR("?",3)="not a copay should be applied to the prescription." - Q -SETSUMM ; SET MESSAGE INTO SUMMARY - S PSI=$O(PSOSUMM(PSI)) G:$O(PSOSUMM(PSI)) SETSUMM - S PSI=PSI+1,PSOSUMM(PSI)=PSOCOMM - K PSOCOMM - Q - ; +PSOCPC ;BHAM ISC/BAB - PHARMACY CO-PAY APPLICATION ;06/09/92 + ;;7.0;OUTPATIENT PHARMACY;**10,9,71,85,114,157,143,239,201**;DEC 1997 + ; + ;REF/IA + ;piece 9 of zero node of File 350 and APDT cross reference of File 350/2215 + ;$$STATUS^IBARX/125 + ;File 350.1/592 (DBIA125-B) +WARN ; Message when attempt is made to delete a refill date on COPAY + N PSOIB,PSOIBST + S PSOFLG=0 + G:'$D(^PSRX(DA(1),1,DA,"IB")) ENDW + S PSOIB=^PSRX(DA(1),1,DA,"IB") + I +PSOIB'>0 G ENDW + S PSOIBST=$$STATUS^IBARX(+PSOIB) I PSOIBST=2!(PSOIBST=0) G ENDW + I +PSOIB>0 D CANCEL G ENDW:PSOFLG=0 + I '$G(PSOXXDEL) D EN^DDIOL("This REFILL has COPAY charges, which MUST be removed","","$C(7),!!"),EN^DDIOL("BEFORE the refill date is deleted.","","!") + I '$G(PSOXXDEL) D EN^DDIOL("Use option RESET COPAY STATUS/CANCEL CHARGES, return to EDIT A PRESCRIPTION,","","!!"),EN^DDIOL("and delete the refill date.","","!"),EN^DDIOL(" ","","!!") + S PSOFLG=1 +ENDW ; + I PSOFLG + K PSOFLG + Q +CANCEL ;Check if charge is cancelled for this Refill date + S PSOFLG=1 ;indicates a charge not cancelled + S PSOX=+^PSRX(DA(1),1,DA,"IB") + D LAST I PSOLAST'=PSOPARNT,$D(^IB(PSOLAST,0)),$P(^IBE(350.1,$P(^IB(PSOLAST,0),"^",3),0),"^",5)=2 S PSOFLG=0 + K PSOLAST,PSOPARNT,PSOX,PSOL,PSOLDT + Q +LAST ;find last entry + S PSOLAST="" + S PSOPARNT=$P(^IB(+PSOX,0),"^",9) I 'PSOPARNT S PSOPARNT=+PSOX + S PSOLDT=$O(^IB("APDT",PSOPARNT,"")) I +PSOLDT F PSOL=0:0 S PSOL=$O(^IB("APDT",PSOPARNT,PSOLDT,PSOL)) Q:'PSOL S PSOLAST=PSOL + I PSOLAST="" S PSOLAST=PSOPARNT + Q + ; +EXEMCHK ; Allow reset of exemption answers + N PSOTG,PSOCPN,PSOEXMT,PSOANS,OLDIBQ,PSOSCP,PSOSCA + S PSOANS=0 D SCP^PSORN52D + S OLDIBQ=$G(^PSRX(PSODA,"IBQ")) + I OLDIBQ[0!(OLDIBQ)[1 D + . S PSOANS=1 + . I $P(OLDIBQ,"^",1)'="" S PSOTG("SC")=$P(OLDIBQ,"^",1) + . I $P(OLDIBQ,"^",2)'="" S PSOTG("MST")=$P(OLDIBQ,"^",2) + . I $P(OLDIBQ,"^",3)'="" S PSOTG("AO")=$P(OLDIBQ,"^",3) + . I $P(OLDIBQ,"^",4)'="" S PSOTG("IR")=$P(OLDIBQ,"^",4) + . I $P(OLDIBQ,"^",5)'="" S PSOTG("EC")=$P(OLDIBQ,"^",5) + . I $P(OLDIBQ,"^",6)'="" S PSOTG("HNC")=$P(OLDIBQ,"^",6) + . I $P(OLDIBQ,"^",7)'="" S PSOTG("CV")=$P(OLDIBQ,"^",7) + S PSOCPN=$P(^PSRX(PSODA,0),"^",2) + S RXP=PSODA + D SCNEW^PSOCP(.PSOTG,PSOCPN,"",PSODA) + N EXMT + D XTYPE^PSOCP ; KEEP THIS CALL IN HERE TO SEE IF SC QUESTION APPLIES + ;I $D(PSOTG("SC")) S PSOTG("SC")=$P(OLDIBQ,"^",1) ; CHANGED TO JUST USE IBQ SETTING IF SC QUESTION APPLIES - DON'T RE-CALCULATE SERVICE-CONNECTED + S EXMT="" F S EXMT=$O(PSOTG(EXMT)) Q:EXMT="" I PSOTG(EXMT)'="" S PSOANS=1 Q + I $O(PSOTG(""))="" Q + I PSOANS W !!,"The following exemption flags have been set:" + F EXMT="SC","CV","AO","IR","EC","MST","HNC" I $G(PSOTG(EXMT))'="" W !,EXMT,": ",?6,$S(PSOTG(EXMT)=1:"Yes",PSOTG(EXMT)=0:"No",1:"") + W ! + W ! K DIR S DIR(0)="Y",DIR("B")="N" D S DIR("A")="Do you want to enter/edit any copay exemption flags" + . S EXMT="" F S EXMT=$O(PSOTG(EXMT)) Q:EXMT="" I PSOTG(EXMT)="" S DIR("B")="Y" Q + S DIR("?")="Enter 'Y' for Yes if you want to edit any applicable medication exemption flags." + S DIR("??")="^D HELPEXEM^PSOCPC" + D ^DIR K DIR S PSOEXMT=Y I Y'=1 Q + ; PRESENT ALL APPLICABLE EXEMPTIONS AND SAVE NEW ANSWERS + N PSOIBQ,PSOSUBS,PSOQUES,PSOLTAG,OLDIBQ,II,PSOCHG,PSOPATST + S PSOPATST=$$GET1^DIQ(52,PSODA_",",3,"I") + S PSOIBQ="" + S OLDIBQ=$G(^PSRX(PSODA,"IBQ")) + I '$D(^PSRX(PSODA,"IBQ")),+($G(^PSRX(PSODA,"IB")))=2 S $P(OLDIBQ,"^",1)=0 ; SC QUESTION WAS PREVIOUSLY ANSWERED AS N + S PSOCOMM="",PSOOLD="",PSONW="" + S II=0 + F EXMT="SC","CV","AO","IR","EC","MST","HNC" I $D(PSOTG(EXMT)) D + . S PSOLTAG="REL"_EXMT_"^PSOCPE" + . S HELPTAG="HELP"_EXMT + . S PSOQUES=$P($T(@PSOLTAG),";",2) I PSOQUES="" Q + . S PSOQUES=$P(PSOQUES,"?") + . S PSOSUBS=$P($T(@PSOLTAG),";",3) I PSOSUBS="" Q + . D ASKEXEM + I $D(PSOCHG) D + . S:PSOSCP<50&($TR(PSOIBQ,"^")'="")&($P($G(^PS(53,+$G(PSOPATST),0)),"^",7)'=1) ^PSRX(PSODA,"IBQ")=PSOIBQ + . D RESET^PSORN52D ;set SC/EI on ICD node + . S PSOPFSA=1 ;PFSS-denotes to calling routine that outpatient classifications changed. + . D EN^PSOHLSN1(PSODA,"XX","","Order edited") + . I PCOPAY,PSOIBQ["1" D ; RESET TO NO COPAY + . . W !,"Editing of exemption flag(s) has resulted in a copay status change.",!,"The status for this Rx will be reset to NO COPAY." + . . S $P(^PSRX(PSODA,"IB"),"^",1)="" + . . S PSOREF="",PSOOLD="Copay",PSONW="No Copay",PREA="R" D ACTLOG^PSOCPA + . . S PSOCOMM="Copay status reset due to exemption flag(s)" + . . S PSI=0 D SETSUMM + . I $G(II)>0 D + . . S PSOCOMM="The following exemption flags have been changed: ",PSI=0 D SETSUMM + . . S II="" F S II=$O(PSOCHG(II)) Q:II="" S PSOCOMM=PSOCHG(II),PSI=0 D SETSUMM + Q + ; +ASKEXEM ; ASK THE EXEMPTION QUESTIONS + K DIR S DIR("A")=PSOQUES,DIR(0)="YO" S:PSOTG(EXMT)=1 DIR("B")="Y" S:PSOTG(EXMT)=0 DIR("B")="N" D @HELPTAG +ASKEXEM1 D ^DIR I X="@" R !," Are you sure you want to delete this answer? ",X:DTIME I $E(X)'="Y",$E(X)'="y" G ASKEXEM1 + I X="^" S X=$G(DIR("B")) S Y=$S(X="Y":1,X="N":0,1:"") + S $P(PSOIBQ,"^",PSOSUBS)=$S(Y=1:1,Y=0:0,1:"") + I $P(PSOIBQ,"^",PSOSUBS)'=$P(OLDIBQ,"^",PSOSUBS) S II=II+1,PSOCHG(II)=EXMT_": "_$S($P(PSOIBQ,"^",PSOSUBS)=1:"Yes",$P(PSOIBQ,"^",PSOSUBS)=0:"No",1:"") + I Y=1 D + . I PSOCOMM'="" Q + . D SETCOMM^PSOCP + Q + ; +HELPEXEM ; help text for exemption edit question + W !,"Enter 'Y' for Yes if you want to edit any applicable exemption flags such as" + W !,"Service Connected (SC), Combat Veteran(CV), Agent Orange (AO), Ionizing Radiation (IR)," + W !,"Environmental Contaminants (EC), Military Sexual Trauma (MST), or" + W !,"Head and/or Neck Cancer (HNC)." + Q + ; +HELPSC ; + S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is for a Service Connected condition." + S DIR("?",2)="This response will be used to determine whether or not a copay should be" + S DIR("?",3)="applied to the prescription." + Q + ; +HELPAO ; + S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition due to",DIR("?",2)="Vietnam-Era Herbicide (Agent Orange) exposure. This response will be used to" + S DIR("?",3)="determine whether or not a copay should be applied to the prescription." + Q + ; +HELPIR ; + S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition due to",DIR("?",2)="ionizing radiation exposure during military service. This response will be used" + S DIR("?",3)="to determine whether or not a copay should be applied to the prescription." + Q + ; +HELPEC ; + S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition due to",DIR("?",2)="environmental contaminant exposure during the Persian Gulf War. This response" + S DIR("?",3)="will be used to determine whether or not a copay should be applied to the",DIR("?",4)="prescription." + Q + ; +HELPMST ; + S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition related",DIR("?",2)="to Military Sexual Trauma. This response will be used to determine whether or" + S DIR("?",3)="not a copay should be applied to the prescription." + Q + ; +HELPHNC ; + S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is being used to treat Head and/or Neck Cancer",DIR("?",2)="due to nose or throat radium treatments while in the military. This response" + S DIR("?",3)="will be used to determine whether or not a copay should be applied to the",DIR("?",4)="prescription." + Q + ; +HELPCV ; + S DIR("?")=" " + S DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition related" + S DIR("?",2)="to Combat Services. This response will be used to determine whether or" + S DIR("?",3)="not a copay should be applied to the prescription." + Q + ; +SETSUMM ; SET MESSAGE INTO SUMMARY + S PSI=$O(PSOSUMM(PSI)) G:$O(PSOSUMM(PSI)) SETSUMM + S PSI=PSI+1,PSOSUMM(PSI)=PSOCOMM + K PSOCOMM + Q + ; diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCPE.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCPE.m index f3b5abb8..3ad2290e 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCPE.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCPE.m @@ -1,165 +1,164 @@ -PSOCPE ;BIR/BAB - PHARMACY COPAY APPLICATION UTILITIES FOR IB ;10/26/92 - ;;7.0;OUTPATPSOCT PHARMACY;**26,71,85,114,157,219,268,225**;DEC 1997;Build 29 - ; - ;REF/IA - ;^XUSEC/10076 - ;^PSDRUG(/221 - ;Routine initially released as part of the copayment enhancement. - ;called from PSOLBL -INV ; Entry point from PSOCP - Prints one copay invoice - I '$D(PSOCPN)!($G(RXP)) Q - S PSOCPBAR=0 - I $D(PSOBARS),PSOBARS S PSOCPBAR=1 - D DEM^VADPT S Y=DT X ^DD("DD") S EDT=Y - W ?54,"PRESCRIPTION COPAYMENT INFORMATION" - W !!,?54,VADM(1)," ",VA("PID")," ",EDT - S PSZ1=0,PSZ2="",PSOCPBN=$P(VADM(2),"^"),PSOCPBN=$S(PSOCPBN]"":PSOCPBN,1:"Unavailable") - ;I '$G(PSOCPN) S PSOCPN=$P(^PSRX(RX,0),U,2) - I PSOCPBAR,(PSOCPBN]"") S X="S",X2=PSOCPBN W !,?54,@PSOBAR1,PSOCPBN,@PSOBAR0 - E W ! - W !,?54,"The following prescriptions are" - W !,?54,"eligible for prescription copayment.",!! -DRUG S PSZ2="" F S PSZ2=$O(^TMP($J,"PSOCP",PSOCPN,PSZ2)) Q:PSZ2']"" S PSZ=^(PSZ2) D PRT -NAR ; Print narrative from site parameter file - K ^UTILITY($J,"W") S DIWL=55,DIWR=99,DIWF="" W ! - G:'$D(^PS(59,PSOSITE,4,0)) END - G:$P(^PS(59,PSOSITE,4,0),"^",3)'>0 END - F PSO9=0:0 S PSO9=$O(^PS(59,PSOSITE,4,PSO9)) G:'PSO9 P1 I $D(^PS(59,PSOSITE,4,PSO9,0)) S X=^(0) D ^DIWP -P1 D ^DIWW - K DIWF,DIWL,DIWR,PSO9 -END ; - W @IOF - K ^TMP($J,"PSOCP",PSOCPN),PSOCPBAR,PSOCPBN,PSZ1,PSZ2,PSOCPN,DIWF,DIWL,DIWR,PSO9 - Q -PRT ; - W ?54,PSZ2 - W ?72," ",$P(^TMP($J,"PSOCP",PSOCPN,PSZ2),"^",3)," ","Days Supply",! - W ?56,$E($P(^TMP($J,"PSOCP",PSOCPN,PSZ2),U,2),1,45),! - Q -XMPT ; Entry point for menu option to select copay exemption - N PSORXPNM,PSORXPRE,PSOCPEDA - I '$D(PSOPAR) D ^PSOLSET G XMPT - W ! S (DIC,DIE)="^PS(53,",DIC(0)="AEQMZ" D ^DIC K DIC G:Y<0 QUIT - G:$D(DTOUT) QUIT - S PSORXPRE=$P($G(^PS(53,+$G(Y),0)),"^",7) - S PSORXPNM=$P($G(^PS(53,+$G(Y),0)),"^") - S DA=+Y,DR="15" L +^PS(53,DA):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T W !!,PSORXPNM_" is locked by another user. Try Later!" W ! D PAGE G QUIT - W ! D ^DIE - I PSORXPRE,$P($G(^PS(53,DA,0)),"^",7) W !!,"All Rx's entered with this Rx Patient Status will be EXEMPT from Copayment.",! D PAGE L -^PS(53,DA) G QUIT - I 'PSORXPRE,'$P($G(^PS(53,DA,0)),"^",7) W !!,"All Rx's entered with this Rx Patient Status will NOT be exempt from Copayment.",! D PAGE L -^PS(53,DA) G QUIT - D WARN L -^PS(53,DA) -QUIT K PSORXPRE,DIE,DIC,DA,DR,X,C,Y - Q -PAGE ; - I '$G(DUZ("AUTO")) K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR - Q -WARN ; - S PSOCPEDA=$G(DA) - W !!?28,"**** WARNING ****",! - I 'PSORXPRE W !,"By setting the Exempt from Copayment for the Rx Patient Status of",!,PSORXPNM," to 'YES', every prescription entered",!,"with this Rx Patient Status will NOT be charged a Copayment.",! - I PSORXPRE W !,"By setting the EXEMPT FROM COPAYMENT for the Rx Patient Status of ",!,PSORXPNM," to 'NO', prescriptions entered with this Rx",!,"Patient Status from this point on will NOT be exempt from Copayment.",! - W !,"A mail message will be sent to PSORPH and PSO COPAY Key holders informing",!,"them of your change." - W ! K DIR S DIR(0)="Y",DIR("A")="Are you sure you want to do this",DIR("B")="Y" D ^DIR K DIR - I $G(Y) D D MAIL G WARNX - .I 'PSORXPRE W !!,"Setting ",PSORXPNM," Rx Patient Status to Exempt from Copayment." Q - .W !!,"Setting Exempt from Copayment to 'NO' for the ",PSORXPNM,!,"Rx Patient Status." - I 'PSORXPRE W !!,"No action taken." S $P(^PS(53,PSOCPEDA,0),"^",7)=0 H 1 - I PSORXPRE W !!,"No action taken." S $P(^PS(53,PSOCPEDA,0),"^",7)=1 H 1 -WARNX W ! D PAGE - S DA=$G(PSOCPEDA) K PSOCPEDA - Q -MAIL ; - K PSOTXT,PSOCFN,PSODCPA - I $G(DUZ) S DIC=200,DR=".01",DA=DUZ,DIQ(0)="E",DIQ="PSODCPA(" D EN^DIQ1 S PSOCFN=$G(PSODCPA(200,DA,.01,"E")) K PSODCPA,DIC,DIQ,DR - I 'PSORXPRE S PSOTXT(1,0)="The "_PSORXPNM_" Rx Patient Status has been marked as",PSOTXT(2,0)="Exempt from Copayment by "_$G(PSOCFN)_".",PSOTXT(3,0)="Every prescription with this Rx Patient Status will not be charged a Copayment." - I PSORXPRE S PSOTXT(1,0)="The Exempt from Copayment status has been removed from the",PSOTXT(2,0)=PSORXPNM_" Rx Patient Status by "_$G(PSOCFN)_".",PSOTXT(3,0)="Prescriptions entered with this Rx Patient Status will not be exempt from" - I PSORXPRE S PSOTXT(4,0)="Copayment." - F PSOCXPDA=0:0 S PSOCXPDA=$O(^XUSEC("PSORPH",PSOCXPDA)) Q:'PSOCXPDA S XMY(PSOCXPDA)="" - F PSOCXPDA=0:0 S PSOCXPDA=$O(^XUSEC("PSO COPAY",PSOCXPDA)) Q:'PSOCXPDA S XMY(PSOCXPDA)="" - I $G(DUZ) S XMY(DUZ)="" - S XMSUB="Exempt from Copayment",XMTEXT="PSOTXT(",XMDUZ="Outpatient Pharmacy" D ^XMD - K PSOTXT,PSOCXPDA,XMDUZ,PSOCFN,XMTEXT,XMSUB,XMY - Q - ; -MAIL2 ; SEND MAIL TO PHARMACIST, PROVIDER, AND HOLDERS OF PSO COPAY KEY - N PSOC,PSOTXT,X - K XMY - S XMSUB="PRESCRIPTION QUESTIONS REVIEW NEEDED" - S XMDUZ="Outpatient Pharmacy Package" - S PSOTXT(1)=" " - S DFN=+$P($G(^PSRX(RXP,0)),"^",2) D PID^VADPT - S PSODIV=$P($G(^PSRX(RXP,2)),"^",9) S:PSODIV'="" XMSUB=XMSUB_" ("_$P($G(^PS(59,PSODIV,0)),"^",6)_")",PSODIV=$P($G(^PS(59,PSODIV,0)),"^",1) ; ADDED DIVISION NUMBER TO SUBJECT LINE - PATCH 85 - S PSOTXT(2)=$P($G(^DPT($P(^PSRX(RXP,0),"^",2),0)),"^",1)_" ("_$G(VA("BID"))_")"_" "_PSODIV - D ELIG - S PSOTXT(PSOC)="Rx# "_$P(^PSRX(RXP,0),"^",1)_" ("_PSOREF_") "_$S('$G(^PSRX(RXP,"IB")):"NO COPAY",1:"COPAY") - S PSOC=PSOC+1 - S DRG=+$P(^PSRX(RXP,0),"^",6) - S PSOC=PSOC+1 - S PSOTXT(PSOC)=$P($G(^PSDRUG(DRG,0)),"^",1) - S PSOC=PSOC+1 - S PSOTXT(PSOC)=" " - S PSOC=PSOC+1 - S PSOTXT(PSOC)="Due to a change in criteria, additional information listed below is needed" - S PSOC=PSOC+1 - S PSOTXT(PSOC)="to determine the final VA copay and/or insurance billable status for this Rx" - S PSOC=PSOC+1 - S PSOTXT(PSOC)="so that appropriate action can be taken by pharmacy personnel." - S PSOC=PSOC+1 - S PSOTXT(PSOC)=" " - S PSOC=PSOC+1 - F EXMT="SC","CV","AO","IR","EC","SHAD","MST","HNC" I $D(PSOTG(EXMT)) D - . I PSOTG(EXMT)'="" Q - . S PSOLTAG="REL"_EXMT - . S PSOQUES=$P($T(@PSOLTAG),";",2) I PSOQUES="" Q - . S PSOC=PSOC+1,PSOTXT(PSOC)=PSOQUES - . S PSOQUES=$P($T(@PSOLTAG),";",2) I PSOQUES="" Q - S PSOC=PSOC+1,PSOTXT(PSOC)=" " - S PSOC=PSOC+1,PSOTXT(PSOC)="This message has been sent to the provider of record, the pharmacist who" - S PSOC=PSOC+1,PSOTXT(PSOC)="finished the prescription order, and all holders of the PSO COPAY key." - S PSOC=PSOC+1,PSOTXT(PSOC)=" " - S PSOC=PSOC+1,PSOTXT(PSOC)="Providers:" - S PSOC=PSOC+1,PSOTXT(PSOC)="Please respond with your answer to the question(s) as a reply to this" - S PSOC=PSOC+1,PSOTXT(PSOC)="message. The prescription will be updated by the appropriate staff." - S PSOC=PSOC+1,PSOTXT(PSOC)=" " - S PSOC=PSOC+1,PSOTXT(PSOC)="Staff assigned to update the Prescription responses:" - S PSOC=PSOC+1,PSOTXT(PSOC)="Please use the RESET COPAY STATUS/CANCEL CHARGES option to enter the responses" - S PSOC=PSOC+1,PSOTXT(PSOC)="to the questions above, which may result in a Rx copay status change and/or" - S PSOC=PSOC+1,PSOTXT(PSOC)="the need to remove VA copay charges or may result in a charge to the patient's" - S PSOC=PSOC+1,PSOTXT(PSOC)="insurance carrier." - S PSOC=PSOC+1,PSOTXT(PSOC)=" " - S PSOC=PSOC+1,PSOTXT(PSOC)="Note: The SC question is now asked for Veterans who are SC>49% in order to" - S PSOC=PSOC+1,PSOTXT(PSOC)="determine if the Rx can be billed to a third party insurance. These Veterans" - S PSOC=PSOC+1,PSOTXT(PSOC)="will NOT be charged a VA copay." - S PSOC=PSOC+1,PSOTXT(PSOC)=" " - S PSOC=PSOC+1,PSOTXT(PSOC)="Supply and investigational drugs are not charged a VA copay but could be" - S PSOC=PSOC+1,PSOTXT(PSOC)="reimbursable by third party insurance." - ; S XMY() TO ALL THE RECIPIENTS - I '$G(PSOREF) S XMY(+$P(^PSRX(RXP,0),"^",4))="" ; ORIGINAL - I $G(PSOREF) S XMY(+$P(^PSRX(RXP,1,PSOREF,0),"^",17))="" ; REFILL - I $G(^PSRX(RXP,"OR1")) I $P(^PSRX(RXP,"OR1"),"^",5)'="" S XMY($P(^PSRX(RXP,"OR1"),"^",5))="" - F PSOCXPDA=0:0 S PSOCXPDA=$O(^XUSEC("PSO COPAY",PSOCXPDA)) Q:'PSOCXPDA S XMY(PSOCXPDA)="" - S XMTEXT="PSOTXT(" - D ^XMD K XMSUB,XMY,XMDUZ,XMTEXT,PSODIV,PSOCXPDA,PSOLTAG,PSOC,PSOQUES,PSOTG - Q - ; -ELIG D ELIG^VADPT S PSOC=3,PSOTXT(PSOC)="Eligibility: "_$P(VAEL(1),"^",2)_$S(+VAEL(3):" SC%: "_$P(VAEL(3),"^",2),1:""),PSOC=PSOC+1 - N N,I,I1,PSDIS,PSCNT - S N=0 F S N=$O(VAEL(1,N)) Q:'N S $P(PSOTXT(PSOC)," ",14)=$P(VAEL(1,N),"^",2),PSOC=PSOC+1 - S PSOTXT(PSOC)=" ",PSOC=PSOC+1,PSOTXT(PSOC)="Disabilities: " - F I=0:0 S I=$O(^DPT(DFN,.372,I)) Q:'I S I1=$S($D(^DPT(DFN,.372,I,0)):^(0),1:"") D:+I1 - .S PSDIS=$S($P($G(^DIC(31,+I1,0)),"^")]""&($P($G(^(0)),"^",4)']""):$P(^(0),"^"),$P($G(^DIC(31,+I1,0)),"^",4)]"":$P(^(0),"^",4),1:""),PSCNT=$P(I1,"^",2) - .S:$L(PSOTXT(PSOC)_PSDIS_"-"_PSCNT_"% ("_$S($P(I1,"^",3):"SC",1:"NSC")_"), ")>80 PSOC=PSOC+1,$P(PSOTXT(PSOC)," ",14)=" " - .S PSOTXT(PSOC)=$G(PSOTXT(PSOC))_PSDIS_"-"_PSCNT_"%("_$S($P(I1,"^",3):"SC",1:"NSC")_"), " - S PSOC=PSOC+1 S PSOTXT(PSOC)=" ",PSOC=PSOC+1 - Q - ; - ;EXEMPTION QUESTIONS - MAIL MESSAGE POSITION;SUBSCRIPT IN "IBQ" NODE -RELSC ;Is this Rx for a Service Connected Condition?;1 -RELMST ;Is this Rx related to the treatment of Military Sexual Trauma?;2 -RELAO ;Is this Rx for treatment of Vietnam-Era Herbicide (Agent Orange) exposure?;3 -RELIR ;Is this Rx for treatment of Ionizing Radiation exposure?;4 -RELEC ;Is this Rx for treatment related to service in SW Asia?;5 -RELHNC ;Is this Rx related to treatment of Head and/or Neck Cancer?;6 -RELCV ;Is this Rx potentially for treatment related to Combat?;7 -RELSHAD ;Is this Rx related to treatment of PROJ 112/SHAD?;8 - ; +PSOCPE ;BIR/BAB - PHARMACY COPAY APPLICATION UTILITIES FOR IB ;10/26/92 + ;;7.0;OUTPATPSOCT PHARMACY;**26,71,85,114,157,219,268**;DEC 1997;Build 9 + ; + ;REF/IA + ;^XUSEC/10076 + ;^PSDRUG(/221 + ;Routine initially released as part of the copayment enhancement. + ;called from PSOLBL +INV ; Entry point from PSOCP - Prints one copay invoice + I '$D(PSOCPN)!($G(RXP)) Q + S PSOCPBAR=0 + I $D(PSOBARS),PSOBARS S PSOCPBAR=1 + D DEM^VADPT S Y=DT X ^DD("DD") S EDT=Y + W ?54,"PRESCRIPTION COPAYMENT INFORMATION" + W !!,?54,VADM(1)," ",VA("PID")," ",EDT + S PSZ1=0,PSZ2="",PSOCPBN=$P(VADM(2),"^"),PSOCPBN=$S(PSOCPBN]"":PSOCPBN,1:"Unavailable") + ;I '$G(PSOCPN) S PSOCPN=$P(^PSRX(RX,0),U,2) + I PSOCPBAR,(PSOCPBN]"") S X="S",X2=PSOCPBN W !,?54,@PSOBAR1,PSOCPBN,@PSOBAR0 + E W ! + W !,?54,"The following prescriptions are" + W !,?54,"eligible for prescription copayment.",!! +DRUG S PSZ2="" F S PSZ2=$O(^TMP($J,"PSOCP",PSOCPN,PSZ2)) Q:PSZ2']"" S PSZ=^(PSZ2) D PRT +NAR ; Print narrative from site parameter file + K ^UTILITY($J,"W") S DIWL=55,DIWR=99,DIWF="" W ! + G:'$D(^PS(59,PSOSITE,4,0)) END + G:$P(^PS(59,PSOSITE,4,0),"^",3)'>0 END + F PSO9=0:0 S PSO9=$O(^PS(59,PSOSITE,4,PSO9)) G:'PSO9 P1 I $D(^PS(59,PSOSITE,4,PSO9,0)) S X=^(0) D ^DIWP +P1 D ^DIWW + K DIWF,DIWL,DIWR,PSO9 +END ; + W @IOF + K ^TMP($J,"PSOCP",PSOCPN),PSOCPBAR,PSOCPBN,PSZ1,PSZ2,PSOCPN,DIWF,DIWL,DIWR,PSO9 + Q +PRT ; + W ?54,PSZ2 + W ?72," ",$P(^TMP($J,"PSOCP",PSOCPN,PSZ2),"^",3)," ","Days Supply",! + W ?56,$E($P(^TMP($J,"PSOCP",PSOCPN,PSZ2),U,2),1,45),! + Q +XMPT ; Entry point for menu option to select copay exemption + N PSORXPNM,PSORXPRE,PSOCPEDA + I '$D(PSOPAR) D ^PSOLSET G XMPT + W ! S (DIC,DIE)="^PS(53,",DIC(0)="AEQMZ" D ^DIC K DIC G:Y<0 QUIT + G:$D(DTOUT) QUIT + S PSORXPRE=$P($G(^PS(53,+$G(Y),0)),"^",7) + S PSORXPNM=$P($G(^PS(53,+$G(Y),0)),"^") + S DA=+Y,DR="15" L +^PS(53,DA):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T W !!,PSORXPNM_" is locked by another user. Try Later!" W ! D PAGE G QUIT + W ! D ^DIE + I PSORXPRE,$P($G(^PS(53,DA,0)),"^",7) W !!,"All Rx's entered with this Rx Patient Status will be EXEMPT from Copayment.",! D PAGE L -^PS(53,DA) G QUIT + I 'PSORXPRE,'$P($G(^PS(53,DA,0)),"^",7) W !!,"All Rx's entered with this Rx Patient Status will NOT be exempt from Copayment.",! D PAGE L -^PS(53,DA) G QUIT + D WARN L -^PS(53,DA) +QUIT K PSORXPRE,DIE,DIC,DA,DR,X,C,Y + Q +PAGE ; + I '$G(DUZ("AUTO")) K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR + Q +WARN ; + S PSOCPEDA=$G(DA) + W !!?28,"**** WARNING ****",! + I 'PSORXPRE W !,"By setting the Exempt from Copayment for the Rx Patient Status of",!,PSORXPNM," to 'YES', every prescription entered",!,"with this Rx Patient Status will NOT be charged a Copayment.",! + I PSORXPRE W !,"By setting the EXEMPT FROM COPAYMENT for the Rx Patient Status of ",!,PSORXPNM," to 'NO', prescriptions entered with this Rx",!,"Patient Status from this point on will NOT be exempt from Copayment.",! + W !,"A mail message will be sent to PSORPH and PSO COPAY Key holders informing",!,"them of your change." + W ! K DIR S DIR(0)="Y",DIR("A")="Are you sure you want to do this",DIR("B")="Y" D ^DIR K DIR + I $G(Y) D D MAIL G WARNX + .I 'PSORXPRE W !!,"Setting ",PSORXPNM," Rx Patient Status to Exempt from Copayment." Q + .W !!,"Setting Exempt from Copayment to 'NO' for the ",PSORXPNM,!,"Rx Patient Status." + I 'PSORXPRE W !!,"No action taken." S $P(^PS(53,PSOCPEDA,0),"^",7)=0 H 1 + I PSORXPRE W !!,"No action taken." S $P(^PS(53,PSOCPEDA,0),"^",7)=1 H 1 +WARNX W ! D PAGE + S DA=$G(PSOCPEDA) K PSOCPEDA + Q +MAIL ; + K PSOTXT,PSOCFN,PSODCPA + I $G(DUZ) S DIC=200,DR=".01",DA=DUZ,DIQ(0)="E",DIQ="PSODCPA(" D EN^DIQ1 S PSOCFN=$G(PSODCPA(200,DA,.01,"E")) K PSODCPA,DIC,DIQ,DR + I 'PSORXPRE S PSOTXT(1,0)="The "_PSORXPNM_" Rx Patient Status has been marked as",PSOTXT(2,0)="Exempt from Copayment by "_$G(PSOCFN)_".",PSOTXT(3,0)="Every prescription with this Rx Patient Status will not be charged a Copayment." + I PSORXPRE S PSOTXT(1,0)="The Exempt from Copayment status has been removed from the",PSOTXT(2,0)=PSORXPNM_" Rx Patient Status by "_$G(PSOCFN)_".",PSOTXT(3,0)="Prescriptions entered with this Rx Patient Status will not be exempt from" + I PSORXPRE S PSOTXT(4,0)="Copayment." + F PSOCXPDA=0:0 S PSOCXPDA=$O(^XUSEC("PSORPH",PSOCXPDA)) Q:'PSOCXPDA S XMY(PSOCXPDA)="" + F PSOCXPDA=0:0 S PSOCXPDA=$O(^XUSEC("PSO COPAY",PSOCXPDA)) Q:'PSOCXPDA S XMY(PSOCXPDA)="" + I $G(DUZ) S XMY(DUZ)="" + S XMSUB="Exempt from Copayment",XMTEXT="PSOTXT(",XMDUZ="Outpatient Pharmacy" D ^XMD + K PSOTXT,PSOCXPDA,XMDUZ,PSOCFN,XMTEXT,XMSUB,XMY + Q + ; +MAIL2 ; SEND MAIL TO PHARMACIST, PROVIDER, AND HOLDERS OF PSO COPAY KEY + N PSOC,PSOTXT,X + K XMY + S XMSUB="PRESCRIPTION QUESTIONS REVIEW NEEDED" + S XMDUZ="Outpatient Pharmacy Package" + S PSOTXT(1)=" " + S DFN=+$P($G(^PSRX(RXP,0)),"^",2) D PID^VADPT + S PSODIV=$P($G(^PSRX(RXP,2)),"^",9) S:PSODIV'="" XMSUB=XMSUB_" ("_$P($G(^PS(59,PSODIV,0)),"^",6)_")",PSODIV=$P($G(^PS(59,PSODIV,0)),"^",1) ; ADDED DIVISION NUMBER TO SUBJECT LINE - PATCH 85 + S PSOTXT(2)=$P($G(^DPT($P(^PSRX(RXP,0),"^",2),0)),"^",1)_" ("_$G(VA("BID"))_")"_" "_PSODIV + D ELIG + S PSOTXT(PSOC)="Rx# "_$P(^PSRX(RXP,0),"^",1)_" ("_PSOREF_") "_$S('$G(^PSRX(RXP,"IB")):"NO COPAY",1:"COPAY") + S PSOC=PSOC+1 + S DRG=+$P(^PSRX(RXP,0),"^",6) + S PSOC=PSOC+1 + S PSOTXT(PSOC)=$P($G(^PSDRUG(DRG,0)),"^",1) + S PSOC=PSOC+1 + S PSOTXT(PSOC)=" " + S PSOC=PSOC+1 + S PSOTXT(PSOC)="Due to a change in criteria, additional information listed below is needed" + S PSOC=PSOC+1 + S PSOTXT(PSOC)="to determine the final VA copay and/or insurance billable status for this Rx" + S PSOC=PSOC+1 + S PSOTXT(PSOC)="so that appropriate action can be taken by pharmacy personnel." + S PSOC=PSOC+1 + S PSOTXT(PSOC)=" " + S PSOC=PSOC+1 + F EXMT="SC","CV","AO","IR","EC","MST","HNC" I $D(PSOTG(EXMT)) D + . I PSOTG(EXMT)'="" Q + . S PSOLTAG="REL"_EXMT + . S PSOQUES=$P($T(@PSOLTAG),";",2) I PSOQUES="" Q + . S PSOC=PSOC+1,PSOTXT(PSOC)=PSOQUES + . S PSOQUES=$P($T(@PSOLTAG),";",2) I PSOQUES="" Q + S PSOC=PSOC+1,PSOTXT(PSOC)=" " + S PSOC=PSOC+1,PSOTXT(PSOC)="This message has been sent to the provider of record, the pharmacist who" + S PSOC=PSOC+1,PSOTXT(PSOC)="finished the prescription order, and all holders of the PSO COPAY key." + S PSOC=PSOC+1,PSOTXT(PSOC)=" " + S PSOC=PSOC+1,PSOTXT(PSOC)="Providers:" + S PSOC=PSOC+1,PSOTXT(PSOC)="Please respond with your answer to the question(s) as a reply to this" + S PSOC=PSOC+1,PSOTXT(PSOC)="message. The prescription will be updated by the appropriate staff." + S PSOC=PSOC+1,PSOTXT(PSOC)=" " + S PSOC=PSOC+1,PSOTXT(PSOC)="Staff assigned to update the Prescription responses:" + S PSOC=PSOC+1,PSOTXT(PSOC)="Please use the RESET COPAY STATUS/CANCEL CHARGES option to enter the responses" + S PSOC=PSOC+1,PSOTXT(PSOC)="to the questions above, which may result in a Rx copay status change and/or" + S PSOC=PSOC+1,PSOTXT(PSOC)="the need to remove VA copay charges or may result in a charge to the patient's" + S PSOC=PSOC+1,PSOTXT(PSOC)="insurance carrier." + S PSOC=PSOC+1,PSOTXT(PSOC)=" " + S PSOC=PSOC+1,PSOTXT(PSOC)="Note: The SC question is now asked for Veterans who are SC>49% in order to" + S PSOC=PSOC+1,PSOTXT(PSOC)="determine if the Rx can be billed to a third party insurance. These Veterans" + S PSOC=PSOC+1,PSOTXT(PSOC)="will NOT be charged a VA copay." + S PSOC=PSOC+1,PSOTXT(PSOC)=" " + S PSOC=PSOC+1,PSOTXT(PSOC)="Supply and investigational drugs are not charged a VA copay but could be" + S PSOC=PSOC+1,PSOTXT(PSOC)="reimbursable by third party insurance." + ; S XMY() TO ALL THE RECIPIENTS + I '$G(PSOREF) S XMY(+$P(^PSRX(RXP,0),"^",4))="" ; ORIGINAL + I $G(PSOREF) S XMY(+$P(^PSRX(RXP,1,PSOREF,0),"^",17))="" ; REFILL + I $G(^PSRX(RXP,"OR1")) I $P(^PSRX(RXP,"OR1"),"^",5)'="" S XMY($P(^PSRX(RXP,"OR1"),"^",5))="" + F PSOCXPDA=0:0 S PSOCXPDA=$O(^XUSEC("PSO COPAY",PSOCXPDA)) Q:'PSOCXPDA S XMY(PSOCXPDA)="" + S XMTEXT="PSOTXT(" + D ^XMD K XMSUB,XMY,XMDUZ,XMTEXT,PSODIV,PSOCXPDA,PSOLTAG,PSOC,PSOQUES,PSOTG + Q + ; +ELIG D ELIG^VADPT S PSOC=3,PSOTXT(PSOC)="Eligibility: "_$P(VAEL(1),"^",2)_$S(+VAEL(3):" SC%: "_$P(VAEL(3),"^",2),1:""),PSOC=PSOC+1 + N N,I,I1,PSDIS,PSCNT + S N=0 F S N=$O(VAEL(1,N)) Q:'N S $P(PSOTXT(PSOC)," ",14)=$P(VAEL(1,N),"^",2),PSOC=PSOC+1 + S PSOTXT(PSOC)=" ",PSOC=PSOC+1,PSOTXT(PSOC)="Disabilities: " + F I=0:0 S I=$O(^DPT(DFN,.372,I)) Q:'I S I1=$S($D(^DPT(DFN,.372,I,0)):^(0),1:"") D:+I1 + .S PSDIS=$S($P($G(^DIC(31,+I1,0)),"^")]""&($P($G(^(0)),"^",4)']""):$P(^(0),"^"),$P($G(^DIC(31,+I1,0)),"^",4)]"":$P(^(0),"^",4),1:""),PSCNT=$P(I1,"^",2) + .S:$L(PSOTXT(PSOC)_PSDIS_"-"_PSCNT_"% ("_$S($P(I1,"^",3):"SC",1:"NSC")_"), ")>80 PSOC=PSOC+1,$P(PSOTXT(PSOC)," ",14)=" " + .S PSOTXT(PSOC)=$G(PSOTXT(PSOC))_PSDIS_"-"_PSCNT_"%("_$S($P(I1,"^",3):"SC",1:"NSC")_"), " + S PSOC=PSOC+1 S PSOTXT(PSOC)=" ",PSOC=PSOC+1 + Q + ; + ;EXEMPTION QUESTIONS - MAIL MESSAGE POSITION;SUBSCRIPT IN "IBQ" NODE +RELSC ;Is this Rx for a Service Connected Condition?;1 +RELMST ;Is this Rx related to the treatment of Military Sexual Trauma?;2 +RELAO ;Is this Rx for treatment of Vietnam-Era Herbicide (Agent Orange) exposure?;3 +RELIR ;Is this Rx for treatment of Ionizing Radiation exposure?;4 +RELEC ;Is this Rx for treatment of Environmental Contaminants exposure?;5 +RELHNC ;Is this Rx related to treatment of Head and/or Neck Cancer?;6 +RELCV ;Is this Rx potentially for treatment related to Combat?;7 + ; diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCSTM.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCSTM.m index da3c6656..29e10d54 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCSTM.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCSTM.m @@ -1,131 +1,125 @@ -PSOCSTM ;BHAM ISC/SAB - monthly rx cost compilation ;7/10/06 4:36pm - ;;7.0;OUTPATIENT PHARMACY;**4,17,19,28,89,212,246**;DEC 1997;Build 12 - ;External Ref. to ^PS(55 DBIA# 2228 - ;External Ref. to ^DPT DBIA# 10035 - ;External Ref. to ^PSDRUG DBIA# 221 - ; - ;*212 don't allow this request, if monthly compile is running - ;*246 alter SRCH1 For loop to not init to numeric values - ; - Q:$$MTHLCK(1) ;get lock, quit if already locked PSO*212 - K BDT,EDT W !!,"**** Date Range Selection ****" S LATE=$E(DT,1,5)_"00" -BEG W ! S %DT="APE",%DT("A")=" Beginning MONTH/YEAR : " D ^%DT G:Y<0 Q W:Y'STOP) K ^PSCST(PSDT),^PSCST("B",PSDT) - K STOP - ; -SRCH F PSDT=BDT:100:EDT S PSDTX=PSDT+100 D:$E(PSDT,4,5)<13 SRCH1,SET1 S:$E(PSDT,4,5)>12 PSDT=$E(PSDT,1,2)_($E(PSDT,3)+1)_"0000" - S PSOCNT=0 F PSDT=0:0 S PSDT=$O(^PSCST("B",PSDT)) Q:'PSDT S PSD=PSDT,PSOCNT=PSOCNT+1 - S ^PSCST(0)="DRUG COST^50.9D^"_PSD_"^"_PSOCNT D ZNODE -Q K ^TMP($J),%DT,A,B,BDT,COST,DATA,DATA1,DATA2,DRG,DFN,EDT,I,II,LATE,ML,OR,PAST,PHYS,PSOCNT,PSD,PSDT,PSDT1,PSDTX,RXF,PSG,QTY,RF,RX0 - K RX2,DIV,D,C,CLINIC,A1,B1,C1,D1,RX1,RXN,VAL,VAR,PGM,VALUE,CDT,NDT,VISITS,DV,VIS,WD,X,X1,X2,Y S:$D(ZTQUEUED) ZTREQ="@" - L -^PSOCSTM ;unlock month end flag - Q - ; -SRCH1 D INI - ;refill - S PSDT1=PSDT ;*246 - F S PSDT1=$O(^PSRX("AL",PSDT1)) Q:($E(PSDT1,1,7)PSDTX) D - .S CDT=$P(PSDT1,".") F RXN=0:0 S RXN=$O(^PSRX("AL",PSDT1,RXN)) Q:'RXN S RXF="" F S RXF=$O(^PSRX("AL",PSDT1,RXN,RXF)) Q:RXF="" D CHK - .S NDT=$O(^PSRX("AL",PSDT1)) D:$P(NDT,".")'=CDT VST - ;partial fill - S PSDT1=PSDT ;*246 - F S PSDT1=$O(^PSRX("AM",PSDT1)) Q:($E(PSDT1,1,7)PSDTX) D - .S CDT=$P(PSDT1,"."),RXN=0 F S RXN=$O(^PSRX("AM",PSDT1,RXN)) Q:'RXN S RXF=0 F S RXF=$O(^PSRX("AM",PSDT1,RXN,RXF)) Q:RXF="" S PAR=1 D CHK - .S NDT=$O(^PSRX("AM",PSDT1)) D:$P(NDT,".")'=CDT VST K PAR - Q -INI K VIS S (VISITS,DV)=0 F S DV=$O(^PS(59,DV)) Q:'+DV S VIS(DV)=0 - Q -VST S DV=0 F S DV=$O(^TMP($J,"PAT",DV)) Q:'DV D - .S DFN=0 F S DFN=$O(^TMP($J,"PAT",DV,DFN)) Q:'DFN S VIS(DV)=VIS(DV)+1,VISITS=VISITS+1 - K ^TMP($J,"PAT") Q -CHK I '$D(^PSRX(RXN,0)) K ^PSRX("AL",PSDT,RXN,RXF) Q - Q:'$D(^PSRX(RXN,2)) S RX0=^PSRX(RXN,0),RX2=^PSRX(RXN,2) - S DFN=+$P(RX0,"^",2) Q:'$D(^DPT(DFN,0)) D:$P($G(^PS(55,DFN,0)),"^",6)'=2 EN^PSOHLUP(DFN) - S DRG=+$P(RX0,"^",6) Q:'$D(^PSDRUG(DRG,0)) - ;S CLASS=+$P(^(0),"^",2) Q:'$D(^PS(50.605,CLASS,0)) - S DIV=+$P(RX2,"^",9) Q:'$D(^PS(59,DIV,0)) - S PHYS=+$P(RX0,"^",4) Q:'$D(^VA(200,PHYS,0)) - S PAST=+$P(RX0,"^",3) Q:'$D(^PS(53,PAST,0)) - S CLINIC=+$P(RX0,"^",5) K:'$D(^SC(CLINIC,0)) CLINIC - S COST=$S(+$P(RX0,"^",17):+$P(RX0,"^",17),$D(^PSDRUG(DRG,660)):+$P(^(660),"^",6),1:0) - I $G(PAR) D S PR=0 Q - .I '$D(^PSRX(RXN,"P",RXF,0)) K ^PSRX("AM",PSDT,RXN,RXF) Q - .I $P(^PSRX(RXN,"P",RXF,0),"^",19) D - ..S RX1=^PSRX(RXN,"P",RXF,0),DIV=$S($P(RX1,"^",9):$P(RX1,"^",9),1:$P(RX2,"^",9)) - ..S PHYS=$S($P(RX1,"^",17):$P(RX1,"^",17),1:$P(RX0,"^",4)) - ..S OR=0,RF=1,QTY=+$P(RX1,"^",4),ML=$S($P(RX1,"^",2)="M":1,1:0),WD=$S($P(RX1,"^",2)="W":1,1:0) S COST=QTY*COST D SET,SF - I $P(RX2,"^",13),'RXF D Q - .S OR=1,RF=0,QTY=+$P(RX0,"^",7),ML=$S($P(RX0,"^",11)="M":1,1:0),WD=$S($P(RX0,"^",11)="W":1,1:0),COST=QTY*COST D SET,SF - D:RXF - .I '$D(^PSRX(RXN,1,RXF,0)) K ^PSRX("AL",PSDT,RXN,RXF) Q - .Q:'$P(^PSRX(RXN,1,RXF,0),"^",18) S RX1=^PSRX(RXN,1,RXF,0) - .S OR=0,RF=1,QTY=+$P(RX1,"^",4),ML=$S($P(RX1,"^",2)="M":1,1:0),WD=$S($P(RX1,"^",2)="W":1,1:0) S COST=QTY*COST - .S PHYS=$S($P(RX1,"^",17):$P(RX1,"^",17),1:$P(RX0,"^",4)),DIV=$S($P(RX1,"^",9):$P(RX1,"^",9),1:$P(RX2,"^",9)) - .D SET,SF - Q -SF S DATA="^"_OR_"^"_RF_"^"_COST_"^"_QTY_"^"_ML_"^"_WD,^TMP($J,"PAT",DIV,DFN)="" - F I=1:1:PSG Q:('$D(CLINIC))&(I=PSG) S DATA1=$S($D(@A(I))#2:^(0),1:@(B(I))_"^0^0^0^0") S DATA2=+$P(DATA1,"^") D - .F II=2:1:7 S VALUE=$P(DATA,"^",II)+$P(DATA1,"^",II),DATA2=DATA2_"^"_VALUE S:II=7 @A(I)=DATA2 - .S:'$D(@A1(I)) @A1(I)=B1(I) S $P(@A1(I),"^",4)=+$P(@A1(I),"^",4)+1,$P(@A1(I),"^",3)=@B(I) - F I=1:1:PSD S DATA1=$S(($D(@(C(I)))#2):$G(^(0)),1:@(D(I))_"^0^0^0^0") S DATA2=+$P(DATA1,"^") D - .F II=2:1:7 S VALUE=$P(DATA,"^",II)+$P(DATA1,"^",II),DATA2=DATA2_"^"_VALUE S:II=7 @C(I)=DATA2 D - .S:'$D(@C1(I)) @C1(I)=D1(I) S $P(@C1(I),"^",4)=+$P(@C1(I),"^",4)+1,$P(@C1(I),"^",3)=@D(I) - Q - ; -SET S:'$D(^PSCST(PSDT,0)) ^PSCST(PSDT,0)=PSDT,^PSCST("B",PSDT,PSDT)="" Q -SET1 S ^PSCST(PSDT,1)=DT_"^"_VISITS - S DV=0 F S DV=$O(VIS(DV)) Q:'DV S $P(^PSCST(PSDT,"V",DV,0),"^",8)=+VIS(DV) - Q -QUES W !,$C(7),"??",!,"For example, September 1993 could be entered as 9/93 or SEP 93.",!,"For Year 2000 Compliance enter date as 9/2000 or SEP 2000." Q -ZNODE ;update zero nodes - F PSDT=BDT:$S('$D(BEGDATE):100,1:1):EDT S NDZ=0 F ND="D","P","PS","S","V" S NODE(ND)=0 D:$O(^PSCST(PSDT,"D",0)) - .F S NDZ=$O(^PSCST(PSDT,ND,NDZ)) Q:'NDZ S NODE(ND)=NODE(ND)+1,NDZ2=NDZ D:ND="V" - ..S NDZ1=0,NODE(ND,"P")=0 F S NDZ1=$O(^PSCST(PSDT,ND,NDZ2,"P",NDZ1)) Q:'NDZ1 S NODE(ND,"P")=NODE(ND,"P")+1 - ..S $P(^PSCST(PSDT,ND,NDZ2,"P",0),"^",4)=NODE(ND,"P"),NDZ1=0 - .S:$G(^PSCST(PSDT,ND,0))]"" $P(^PSCST(PSDT,ND,0),"^",4)=NODE(ND),NDZ=0 - K NDZ,ND,NODE,NDZ2,NDZ1 Q - ; -MTHLCK(GET) ;lock for month end run or query if month end is running - ; INPUT: GET = 1 try to get lock and keep locked - ; 0 query if locked only, leave as unlocked - ; RETURNS: 1 - already locked - ; 0 - was not already locked - ; - I '$D(ZTQUEUED) W !,"checking for duplicate job..." - N GOTLOCK - L +^PSOCSTM:10 S GOTLOCK=$T ;delay 10 secs to handle slower systems - I GOTLOCK,'GET L -^PSOCSTM Q 0 - I GOTLOCK,GET Q 0 - N AST S AST="",$P(AST,"*",79)="" - D:'($D(ZTQUEUED)) - .W !!,*7,AST,! - .W "Monthly Rx Cost Compilation is currently running, " - .W "Try your request later",! - .W AST,!! - Q 1 - ; - ; -G ;; - ;;^PSCST(PSDT,0);PSDT;^TMP($J,"A1");1 - ;;^PSCST(PSDT,"P",PHYS,0);PHYS;^PSCST(PSDT,"P",0);^50.9001PA^^ - ;;^PSCST(PSDT,"P",PHYS,"D",DRG,0);DRG;^PSCST(PSDT,"P",PHYS,"D",0);^50.9002PA^^ - ;;^PSCST(PSDT,"D",DRG,0);DRG;^PSCST(PSDT,"D",0);^50.9003PA^^ - ;;^PSCST(PSDT,"D",DRG,"P",PHYS,0);PHYS;^PSCST(PSDT,"D",DRG,"P",0);^50.9004PA^^ - ;;^PSCST(PSDT,"PS",PAST,0);PAST;^PSCST(PSDT,"PS",0);^50.9005PA^^ - ;;^PSCST(PSDT,"S",CLINIC,0);CLINIC;^PSCST(PSDT,"S",0);^50.9008PA^^ - ;; -D ;; - ;;^PSCST(PSDT,"V",DIV,0);DIV;^PSCST(PSDT,"V",0);^50.9006PA^^ - ;;^PSCST(PSDT,"V",DIV,"D",DRG,0);DRG;^PSCST(PSDT,"V",DIV,"D",0);^50.9007PA^^ - ;;^PSCST(PSDT,"V",DIV,"P",PHYS,0);PHYS;^PSCST(PSDT,"V",DIV,"P",0);^50.901PA^^ +PSOCSTM ;BHAM ISC/SAB - monthly rx cost compilation ;9/14/05 1:13pm + ;;7.0;OUTPATIENT PHARMACY;**4,17,19,28,89,212**;DEC 1997 + ;External Ref. to ^PS(55 DBIA# 2228 + ;External Ref. to ^DPT DBIA# 10035 + ;External Ref. to ^PSDRUG DBIA# 221 + ; + ;PSO*212 don't allow this request, if monthly compile is running + ; + Q:$$MTHLCK(1) ;get lock, quit if already locked PSO*212 + K BDT,EDT W !!,"**** Date Range Selection ****" S LATE=$E(DT,1,5)_"00" +BEG W ! S %DT="APE",%DT("A")=" Beginning MONTH/YEAR : " D ^%DT G:Y<0 Q W:Y'STOP) K ^PSCST(PSDT),^PSCST("B",PSDT) + K STOP + ; +SRCH F PSDT=BDT:100:EDT S PSDTX=PSDT+100 D:$E(PSDT,4,5)<13 SRCH1,SET1 S:$E(PSDT,4,5)>12 PSDT=$E(PSDT,1,2)_($E(PSDT,3)+1)_"0000" + S PSOCNT=0 F PSDT=0:0 S PSDT=$O(^PSCST("B",PSDT)) Q:'PSDT S PSD=PSDT,PSOCNT=PSOCNT+1 + S ^PSCST(0)="DRUG COST^50.9D^"_PSD_"^"_PSOCNT D ZNODE +Q K ^TMP($J),%DT,A,B,BDT,COST,DATA,DATA1,DATA2,DRG,DFN,EDT,I,II,LATE,ML,OR,PAST,PHYS,PSOCNT,PSD,PSDT,PSDT1,PSDTX,RXF,PSG,QTY,RF,RX0 + K RX2,DIV,D,C,CLINIC,A1,B1,C1,D1,RX1,RXN,VAL,VAR,PGM,VALUE,CDT,NDT,VISITS,DV,VIS,WD,X,X1,X2,Y S:$D(ZTQUEUED) ZTREQ="@" + L -^PSOCSTM ;unlock month end flag + Q + ; +SRCH1 D INI F PSDT1=PSDT:0:PSDTX S PSDT1=$O(^PSRX("AL",PSDT1)) Q:'PSDT1!($E(PSDT1,1,7)>PSDTX) D + .S CDT=$P(PSDT1,".") F RXN=0:0 S RXN=$O(^PSRX("AL",PSDT1,RXN)) Q:'RXN S RXF="" F S RXF=$O(^PSRX("AL",PSDT1,RXN,RXF)) Q:RXF="" D CHK + .S NDT=$O(^PSRX("AL",PSDT1)) D:$P(NDT,".")'=CDT VST + F PSDT1=PSDT:0:PSDTX S PSDT1=$O(^PSRX("AM",PSDT1)) Q:'PSDT1!($E(PSDT1,1,7)>PSDTX) D + .S CDT=$P(PSDT1,"."),RXN=0 F S RXN=$O(^PSRX("AM",PSDT1,RXN)) Q:'RXN S RXF=0 F S RXF=$O(^PSRX("AM",PSDT1,RXN,RXF)) Q:RXF="" S PAR=1 D CHK + .S NDT=$O(^PSRX("AM",PSDT1)) D:$P(NDT,".")'=CDT VST K PAR + Q +INI K VIS S (VISITS,DV)=0 F S DV=$O(^PS(59,DV)) Q:'+DV S VIS(DV)=0 + Q +VST S DV=0 F S DV=$O(^TMP($J,"PAT",DV)) Q:'DV D + .S DFN=0 F S DFN=$O(^TMP($J,"PAT",DV,DFN)) Q:'DFN S VIS(DV)=VIS(DV)+1,VISITS=VISITS+1 + K ^TMP($J,"PAT") Q +CHK I '$D(^PSRX(RXN,0)) K ^PSRX("AL",PSDT,RXN,RXF) Q + Q:'$D(^PSRX(RXN,2)) S RX0=^PSRX(RXN,0),RX2=^PSRX(RXN,2) + S DFN=+$P(RX0,"^",2) Q:'$D(^DPT(DFN,0)) D:$P($G(^PS(55,DFN,0)),"^",6)'=2 EN^PSOHLUP(DFN) + S DRG=+$P(RX0,"^",6) Q:'$D(^PSDRUG(DRG,0)) + ;S CLASS=+$P(^(0),"^",2) Q:'$D(^PS(50.605,CLASS,0)) + S DIV=+$P(RX2,"^",9) Q:'$D(^PS(59,DIV,0)) + S PHYS=+$P(RX0,"^",4) Q:'$D(^VA(200,PHYS,0)) + S PAST=+$P(RX0,"^",3) Q:'$D(^PS(53,PAST,0)) + S CLINIC=+$P(RX0,"^",5) K:'$D(^SC(CLINIC,0)) CLINIC + S COST=$S(+$P(RX0,"^",17):+$P(RX0,"^",17),$D(^PSDRUG(DRG,660)):+$P(^(660),"^",6),1:0) + I $G(PAR) D S PR=0 Q + .I '$D(^PSRX(RXN,"P",RXF,0)) K ^PSRX("AM",PSDT,RXN,RXF) Q + .I $P(^PSRX(RXN,"P",RXF,0),"^",19) D + ..S RX1=^PSRX(RXN,"P",RXF,0),DIV=$S($P(RX1,"^",9):$P(RX1,"^",9),1:$P(RX2,"^",9)) + ..S PHYS=$S($P(RX1,"^",17):$P(RX1,"^",17),1:$P(RX0,"^",4)) + ..S OR=0,RF=1,QTY=+$P(RX1,"^",4),ML=$S($P(RX1,"^",2)="M":1,1:0),WD=$S($P(RX1,"^",2)="W":1,1:0) S COST=QTY*COST D SET,SF + I $P(RX2,"^",13),'RXF D Q + .S OR=1,RF=0,QTY=+$P(RX0,"^",7),ML=$S($P(RX0,"^",11)="M":1,1:0),WD=$S($P(RX0,"^",11)="W":1,1:0),COST=QTY*COST D SET,SF + D:RXF + .I '$D(^PSRX(RXN,1,RXF,0)) K ^PSRX("AL",PSDT,RXN,RXF) Q + .Q:'$P(^PSRX(RXN,1,RXF,0),"^",18) S RX1=^PSRX(RXN,1,RXF,0) + .S OR=0,RF=1,QTY=+$P(RX1,"^",4),ML=$S($P(RX1,"^",2)="M":1,1:0),WD=$S($P(RX1,"^",2)="W":1,1:0) S COST=QTY*COST + .S PHYS=$S($P(RX1,"^",17):$P(RX1,"^",17),1:$P(RX0,"^",4)),DIV=$S($P(RX1,"^",9):$P(RX1,"^",9),1:$P(RX2,"^",9)) + .D SET,SF + Q +SF S DATA="^"_OR_"^"_RF_"^"_COST_"^"_QTY_"^"_ML_"^"_WD,^TMP($J,"PAT",DIV,DFN)="" + F I=1:1:PSG Q:('$D(CLINIC))&(I=PSG) S DATA1=$S($D(@A(I))#2:^(0),1:@(B(I))_"^0^0^0^0") S DATA2=+$P(DATA1,"^") D + .F II=2:1:7 S VALUE=$P(DATA,"^",II)+$P(DATA1,"^",II),DATA2=DATA2_"^"_VALUE S:II=7 @A(I)=DATA2 + .S:'$D(@A1(I)) @A1(I)=B1(I) S $P(@A1(I),"^",4)=+$P(@A1(I),"^",4)+1,$P(@A1(I),"^",3)=@B(I) + F I=1:1:PSD S DATA1=$S(($D(@(C(I)))#2):$G(^(0)),1:@(D(I))_"^0^0^0^0") S DATA2=+$P(DATA1,"^") D + .F II=2:1:7 S VALUE=$P(DATA,"^",II)+$P(DATA1,"^",II),DATA2=DATA2_"^"_VALUE S:II=7 @C(I)=DATA2 D + .S:'$D(@C1(I)) @C1(I)=D1(I) S $P(@C1(I),"^",4)=+$P(@C1(I),"^",4)+1,$P(@C1(I),"^",3)=@D(I) + Q + ; +SET S:'$D(^PSCST(PSDT,0)) ^PSCST(PSDT,0)=PSDT,^PSCST("B",PSDT,PSDT)="" Q +SET1 S ^PSCST(PSDT,1)=DT_"^"_VISITS + S DV=0 F S DV=$O(VIS(DV)) Q:'DV S $P(^PSCST(PSDT,"V",DV,0),"^",8)=+VIS(DV) + Q +QUES W !,$C(7),"??",!,"For example, September 1993 could be entered as 9/93 or SEP 93.",!,"For Year 2000 Compliance enter date as 9/2000 or SEP 2000." Q +ZNODE ;update zero nodes + F PSDT=BDT:$S('$D(BEGDATE):100,1:1):EDT S NDZ=0 F ND="D","P","PS","S","V" S NODE(ND)=0 D:$O(^PSCST(PSDT,"D",0)) + .F S NDZ=$O(^PSCST(PSDT,ND,NDZ)) Q:'NDZ S NODE(ND)=NODE(ND)+1,NDZ2=NDZ D:ND="V" + ..S NDZ1=0,NODE(ND,"P")=0 F S NDZ1=$O(^PSCST(PSDT,ND,NDZ2,"P",NDZ1)) Q:'NDZ1 S NODE(ND,"P")=NODE(ND,"P")+1 + ..S $P(^PSCST(PSDT,ND,NDZ2,"P",0),"^",4)=NODE(ND,"P"),NDZ1=0 + .S:$G(^PSCST(PSDT,ND,0))]"" $P(^PSCST(PSDT,ND,0),"^",4)=NODE(ND),NDZ=0 + K NDZ,ND,NODE,NDZ2,NDZ1 Q + ; +MTHLCK(GET) ;lock for month end run or query if month end is running + ; INPUT: GET = 1 try to get lock and keep locked + ; 0 query if locked only, leave as unlocked + ; RETURNS: 1 - already locked + ; 0 - was not already locked + ; + I '$D(ZTQUEUED) W !,"checking for duplicate job..." + N GOTLOCK + L +^PSOCSTM:10 S GOTLOCK=$T ;delay 10 secs to handle slower systems + I GOTLOCK,'GET L -^PSOCSTM Q 0 + I GOTLOCK,GET Q 0 + N AST S AST="",$P(AST,"*",79)="" + D:'($D(ZTQUEUED)) + .W !!,*7,AST,! + .W "Monthly Rx Cost Compilation is currently running, " + .W "Try your request later",! + .W AST,!! + Q 1 + ; + ; +G ;; + ;;^PSCST(PSDT,0);PSDT;^TMP($J,"A1");1 + ;;^PSCST(PSDT,"P",PHYS,0);PHYS;^PSCST(PSDT,"P",0);^50.9001PA^^ + ;;^PSCST(PSDT,"P",PHYS,"D",DRG,0);DRG;^PSCST(PSDT,"P",PHYS,"D",0);^50.9002PA^^ + ;;^PSCST(PSDT,"D",DRG,0);DRG;^PSCST(PSDT,"D",0);^50.9003PA^^ + ;;^PSCST(PSDT,"D",DRG,"P",PHYS,0);PHYS;^PSCST(PSDT,"D",DRG,"P",0);^50.9004PA^^ + ;;^PSCST(PSDT,"PS",PAST,0);PAST;^PSCST(PSDT,"PS",0);^50.9005PA^^ + ;;^PSCST(PSDT,"S",CLINIC,0);CLINIC;^PSCST(PSDT,"S",0);^50.9008PA^^ + ;; +D ;; + ;;^PSCST(PSDT,"V",DIV,0);DIV;^PSCST(PSDT,"V",0);^50.9006PA^^ + ;;^PSCST(PSDT,"V",DIV,"D",DRG,0);DRG;^PSCST(PSDT,"V",DIV,"D",0);^50.9007PA^^ + ;;^PSCST(PSDT,"V",DIV,"P",PHYS,0);PHYS;^PSCST(PSDT,"V",DIV,"P",0);^50.901PA^^ diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODEA.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODEA.m index f5d6e953..9f43c0d1 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODEA.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODEA.m @@ -1,28 +1,28 @@ -PSODEA ;BHAM ISC/ - HELP TEXT FOR DEA FIELD IN DRUG FILE ; 10/17/07 7:41am - ;;7.0;OUTPATIENT PHARMACY;**206**;DEC 1997;Build 39 - W !,"THE SPECIAL HANDLING CODE IS A 2 TO 6 POSTION FIELD. IF APPLICABLE,",!,"A SCHEDULE CODE MUST APPEAR IN THE FIRST POSITION. FOR EXAMPLE," - W !,"A SCHEDULE 3 NARCOTIC WILL BE CODED '3A' AND A SCHEDULE 2 DEPRESSANT",!,"WILL BE CODED '2L'. THE CODES ARE:",! - F I=1:1 S AA=$P($T(D+I),";",3,99) Q:AA="" W !?10,AA -D K AA Q - ;;0 MANUFACTURED IN PHARMACY - ;;1 SCHEDULE 1 ITEM - ;;2 SCHEDULE 2 ITEM - ;;3 SCHEDULE 3 ITEM - ;;4 SCHEDULE 4 ITEM - ;;5 SCHEDULE 5 ITEM - ;;6 LEGEND ITEM - ;;9 OVER-THE-COUNTER - ;;L DEPRESSANTS AND STIMULANTS - ;;A NARCOTICS AND ALCOHOLICS - ;;P DATED DRUGS - ;;I INVESTIGATIONAL DRUGS - ;;M BULK COMPOUND ITEMS - ;;C CONTROLLED SUBSTANCES - NON NARCOTIC - ;;R RESTRICTED ITEMS - ;;S SUPPLY ITEMS - ;;B ALLOW REFILL (SCH. 3, 4, 5 ONLY) - ;;W NOT RENEWABLE - ;; -EDIT ;INPUT XFORM FOR DEA FIELD IN DRUG FILE - I X["B",(+X<3) W !,"The B designation is only valid for schedule 3, 4, 5 !",$C(7) K X Q - Q +PSODEA ;BHAM ISC/ - HELP TEXT FOR DEA FIELD IN DRUG FILE ; 06/03/92 17:28 + ;;7.0;OUTPATIENT PHARMACY;;DEC 1997 + W !,"THE SPECIAL HANDLING CODE IS A 2 TO 6 POSTION FIELD. IF APPLICABLE,",!,"A SCHEDULE CODE MUST APPEAR IN THE FIRST POSITION. FOR EXAMPLE," + W !,"A SCHEDULE 3 NARCOTIC WILL BE CODED '3A' AND A SCHEDULE 2 DEPRESSANT",!,"WILL BE CODED '2L'. THE CODES ARE:",! + F I=1:1 S AA=$P($T(D+I),";",3,99) Q:AA="" W !?10,AA +D K AA Q + ;;0 MANUFACTURED IN PHARMACY + ;;1 SCHEDULE 1 ITEM + ;;2 SCHEDULE 2 ITEM + ;;3 SCHEDULE 3 ITEM + ;;4 SCHEDULE 4 ITEM + ;;5 SCHEDULE 5 ITEM + ;;6 LEGEND ITEM + ;;9 OVER-THE-COUNTER + ;;L DEPRESSANTS AND STIMULANTS + ;;A NARCOTICS AND ALCOHOLICS + ;;P DATED DRUGS + ;;I INVESTIGATIONAL DRUGS + ;;M BULK COMPOUND ITEMS + ;;C CONTROLLED SUBSTANCES - NON NARCOTIC + ;;R RESTRICTED ITEMS + ;;S SUPPLY ITEMS + ;;B ALLOW REFILL (SCH. 3, 4, 5 NARCOTICS ONLY) + ;;W NOT RENEWABLE + ;; +EDIT ;INPUT XFORM FOR DEA FIELD IN DRUG FILE + I X["B",(+X<3!(X'["A")) W !,"The B designation is only valid for schedule 3, 4, 5 narcotics !",$C(7) K X Q + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODGDGI.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODGDGI.m index 9b574dd0..9236312c 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODGDGI.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODGDGI.m @@ -1,120 +1,120 @@ -PSODGDGI ;BIR/SAB - drug drug interaction checker ; 6/28/07 7:36am - ;;7.0;OUTPATIENT PHARMACY;**10,27,48,130,144,132,188,207,243,274**;DEC 1997;Build 8 - ;External reference to ^PS(56 supported by DBIA 2229 - ;External reference to ^PSDRUG supported by DBIA 221 - ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789 - ;External reference to DDIEX^PSNAPIS supported by DBIA 2574 - ;External references to ^ORRDI1 supported by DBIA 4659 - ;External reference ^XTMP("ORRDI" supported by DBIA 4660 - Q:$$DDIEX^PSNAPIS($P(PSODRUG("NDF"),"A"),$P(PSODRUG("NDF"),"A",2)) - N PSOICT S (CRIT,DRG,LSI,DGI,DGS,SER,SERS,STA,PSOICT)="" - F S STA=$O(PSOSD(STA)) Q:STA=""!($G(PSORX("DFLG"))) F S DRG=$O(PSOSD(STA,DRG)) Q:DRG=""!($G(PSORX("DFLG"))) I $P(PSOSD(STA,DRG),"^",2)<10 D - .Q:$P(PSOSD(STA,DRG),"^",7)']"" - .S NDF=$P(PSOSD(STA,DRG),"^",7) - .;New logic to Loop All interactions and filter-up a critical if it exists - .S IT=0,PSOICT="" - .F S IT=$O(^PS(56,"APD",NDF,PSODRUG("NDF"),IT)) Q:'IT D - ..Q:$$DDIEX^PSNAPIS($P(NDF,"A"),$P(NDF,"A",2)) - ..Q:$P(^PS(56,IT,0),"^",7)&($P(^PS(56,IT,0),"^",7)2 W !,?15,"#"_J_": ",OLD(I),?30,$P($$ICDDX^ICDCODE(OLD(I),FILDAT),U,4) - Q -STATCHK(ICDIEN,FILDAT) ;called from above to check active/inactive date during FileMan call. - N X S X="" - S ICDIEN=$P(^ICD9(ICDIEN,0),"^",1) S X=$$STATCHK^ICDAPIU(ICDIEN,FILDAT) - Q +X -DELETE ;called from above to verify delete with user and to delete said entries - W !,"SURE YOU WANT TO DELETE? " S X="" R X:30 S X=$TR(X,"yn","YN") - I X'="Y"&(X'="N") W !,"Enter Y or N" G DELETE - I X="N" S I=I-1 Q - F J=I:1:8 Q:'$D(OLDI(J)) D - . I $D(OLDI(J+1)) S OLDI(J)=OLDI(J+1),OLD(J)=OLD(J+1) D - .. I CPRS&($D(PSONEW("ICD",J+1))) S PSONEW("ICD",J)=PSONEW("ICD",J+1) - .. E I CPRS&('$D(PSONEW("ICD",J+1))) S PSONEW("ICD",J)=OLDI(J+1) - .. I $G(PSOCOPY) D - ... I ($D(PSONEW("ICD",J+1))) S PSONEW("ICD",J)=PSONEW("ICD",J+1) - ... I ($D(PSORXED("ICD",J+1))) S PSORXED("ICD",J)=PSORXED("ICD",J+1) - . E K OLD(J),OLDI(J),PSONEW("ICD",J),PSORXED("ICD",J) - . ;I CPRS!($G(PSOCOPY)) K PSONEW("ICD",J),PSORXED("ICD",J) - S I=I-1,(X,Y)="" - Q - ; -ICD ;called from PSON52 cause PSON52'S too large. Stores ICD info for new Rx's (CPRS and backdoor) using variables from copy function and new order functions. - N D,DDATA,ICD,II - I $G(PSOCOPY)&('$D(PSOX("ICD")))&('$G(PSOICDD)) D - . S D=0 F D=1:1 Q:'$D(PSOX("ICD",D)) - . F D=D:1:8 K ^PSRX(PSOX("IRXN"),"ICD",D,0) ;remove any icd's del - . I $D(^PSRX(PSOX("OIRXN"),"ICD",0)) F D=1:1:8 Q:'$D(^PSRX(PSOX("OIRXN"),"ICD",D,0)) S PSOX("ICD",D)=$P(^PSRX(PSOX("OIRXN"),"ICD",D,0),U,1) - I $G(ORD) I $D(^PS(52.41,ORD,0))&($D(PSORX("ICD"))) M PSOX("ICD")=PSONEW("ICD") - I $D(PSOX("ICD")) F D=1:1:8 Q:'$D(PSOX("ICD",D)) S ICD=$G(PSOX("ICD",D)) D - . S DDATA=ICD_"^"_$G(PSOANSQ("VEH"))_"^"_$G(PSOANSQ("RAD"))_"^"_$S(PSOSCP>49:$G(PSOANSQ("SC>50")),PSOSCP<50&(PSOSCP'=""):$G(PSOANSQ("SC")),1:"")_"^"_$G(PSOANSQ("PGW"))_"^"_$G(PSOANSQ("MST"))_"^"_$G(PSOANSQ("HNC"))_"^"_$G(PSOANSQ("CV")) - . S DDATA=DDATA_"^"_$G(PSOANSQ("SHAD")) - . I $P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)=1 I PSOSCP<50&($D(PSOANSQ("SC>50"))) S $P(DDATA,"^",4)=PSOANSQ("SC>50") ;for times when sc has no % defined. - . S ^PSRX(PSOX("IRXN"),"ICD",D,0)=DDATA,II=D - E S D=1 D - . S DDATA="^"_$G(PSOANSQ("VEH"))_"^"_$G(PSOANSQ("RAD"))_"^"_$S(PSOSCP>49:$G(PSOANSQ("SC>50")),PSOSCP<50&(PSOSCP'=""):$G(PSOANSQ("SC")),1:"") - . S DDATA=DDATA_"^"_$G(PSOANSQ("PGW"))_"^"_$G(PSOANSQ("MST"))_"^"_$G(PSOANSQ("HNC"))_"^"_$G(PSOANSQ("CV"))_"^"_$G(PSOANSQ("SHAD")) - . S ^PSRX(PSOX("IRXN"),"ICD",D,0)=DDATA,II=D - . I $P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)=1 I PSOSCP<50&($D(PSOANSQ("SC>50"))) S $P(^PSRX(PSOX("IRXN"),"ICD",D,0),"^",4)=PSOANSQ("SC>50") - S ^PSRX(PSOX("IRXN"),"ICD",0)="^52.052311P^"_II_"^"_II - K PSOX("ICD"),PSORXED("ICD"),PSONEW("ICD"),PSORX("ICD") - Q - ; -UPDATE ;was in PSOORED6; now called from PSOORED6; removes deletes for edits and stores data. - ; - N TNEW,DA,DIK,SCEI,I,II - S DA=PSORXED("IRXN") - I '$D(PSORXED("ICD"))&($G(PSORXED("IDFLG"))) D K PSORXED("IDFLG") Q - . I $D(^PSRX(PSORXED("IRXN"),"ICD",1,0)) D - .. S TNEW=2 K ^PSRX(PSORXED("IRXN"),"ICD","B") S $P(^PSRX(PSORXED("IRXN"),"ICD",1,0),U,1)="" - .. F I=TNEW:1:8 Q:'$D(^PSRX(PSORXED("IRXN"),"ICD",I,0)) S DIK="^PSRX("_PSORXED("IRXN")_","_$C(34)_"ICD"_$C(34)_",",DA=I,DA(1)=PSORXED("IRXN") D ^DIK K DA,DIK - ; - I $D(PSORXED("ICD")) D - . S SCEI=$G(^PSRX(DA,"ICD",1,0)),$P(SCEI,"^")="" - . K ^PSRX(DA,"ICD") - . F I=1:1:8 Q:'$D(PSORXED("ICD",I)) S $P(SCEI,"^")=PSORXED("ICD",I),^PSRX(DA,"ICD",I,0)=SCEI,^PSRX(DA,"ICD","B",$P(SCEI,"^"),I)="",II=I - . S ^PSRX(DA,"ICD",0)="^52.052311P^"_II_U_II - Q - ; -CSET ;Called from PSOHLNEW due to it's routine size. Requires PSOICD & PENDING variable. Sets ICD node for orders passed from CPRS. - N EE,EEE - S (EE,EEE)=0 F S EE=$O(PSOICD(EE)) Q:EE="" D - .S EEE=EEE+1,^PS(52.41,PENDING,"ICD",EEE,0)=PSOICD(EE) S:$P(PSOICD(EE),"^")'="" ^PS(52.41,PENDING,"ICD","B",$P(PSOICD(EE),"^"),EEE)="" - .S ^PS(52.41,PENDING,"ICD",0)="^52.41311PA"_U_EEE_U_EEE - Q +PSODIAG ;BIR/LE - Diagnosis code prompts ;02/27/04 + ;;7.0;OUTPATIENT PHARMACY;**143,219,239,268**;DEC 1997;Build 9 + ;Ext ref to ^XUSEC sup by DBIA 10076 + ;Ext ref to $$ICDDX^ICDCODE sup DBIA 3990 + ;Ext ref to $$STATCHK^ICDAPIU sup DBIA 3991 +EN ; + ;don't ask icd's if user doesn't hold provider key + Q:$T(CIDC^IBBAPI)']"" + Q:'$D(^XUSEC("PROVIDER",DUZ)) + N PSODDFN S PSODDFN=$S($D(DFN):DFN,$D(PSODFN):PSODFN,1:"") ;need to do this since PU patient update deletes DFN and in case some other function does + I PSODDFN'="" I '$$CIDC^IBBAPI(PSODDFN) S:(+$G(PSONEW("DFLG")))&(+$G(PSOEDIT)=1)&('$D(DA)) PSONEW("DFLG")=0 Q ;is CIDC activated; does patient have insurance + ;new variables and initialize variables based on CPRS or backdoor order. + N DX,POP,I,J,X,Y,Z,OLD,OLDI,SOLDI,NEW,TNEW,RAR,CPRS,FILDAT,STATCHK,STATCHK2 + I '$G(PSOX("IRXN")) N PSOX S:$G(PSORXED("IRXN")) PSOX("IRXN")=PSORXED("IRXN") + K DIC + S CPRS=0 + I $G(PSORXED) S RAR="PSORXED",@RAR@("DFLG")=0,PSORXED("FLD",39.3)="" + E S RAR="PSONEW",@RAR@("DFLG")=0 I $G(ORD) D + . I $D(^PS(52.41,ORD)) S CPRS=1 M PSONEW("ICD")=PSORXED("ICD") K PSORXED("ICD"),PSORXED("FLD",39.3) + ; + S FILDAT="",FILDAT=DT I $G(PSOX("IRXN")) S FILDAT=$$GET1^DIQ(52,PSOX("IRXN")_",","22","I") + ;display any previously entered ICD's + W !!,"Previously entered ICD-9 diagnosis codes: " + I 'CPRS D ;&(RAR="PSORXED"!(RAR="PSONEW")) D + . I $D(PSOX("IRXN")) I '$D(PSORXED("ICD")) I $D(^PSRX(PSOX("IRXN"),"ICD")) F I=1:1:8 Q:'$D(^PSRX(PSOX("IRXN"),"ICD",I,0)) D + .. S OLD(I)=$$GET1^DIQ(52.052311,I_","_PSOX("IRXN")_",",".01") + .. S OLDI(I)=$$GET1^DIQ(52.052311,I_","_PSOX("IRXN")_",",".01","I") + . I ($D(@RAR@("ICD"))&('$D(OLD)))!($G(PSOCOPY)) D + .. F I=1:1:8 Q:'$D(@RAR@("ICD",I)) I @RAR@("ICD",I)'="" S OLDI(I)=@RAR@("ICD",I) D + ... S OLD(I)=$P(^ICD9(OLDI(I),0),"^",1) + ... S J=I-1 I I=1 W OLD(I) Q + . F I=1:1:8 Q:'$D(OLD(I)) D WRITE + E I CPRS D + . I '$G(PSONEW("ICD")) F I=1:1:8 Q:'$D(^PS(52.41,ORD,"ICD",I,0)) D + .. S OLD(I)=$$GET1^DIQ(52.41311,I_","_ORD_",",".01") + .. S OLDI(I)=$$GET1^DIQ(52.41311,I_","_ORD_",",".01","I") + . I $D(PSONEW("ICD")) K OLD,OLDI D + .. F I=1:1:8 Q:'$D(PSONEW("ICD",I)) S OLDI(I)=PSONEW("ICD",I) D + ... S OLD(I)=$P(^ICD9(OLDI(I),0),"^",1) + . F I=1:1:8 Q:'$D(OLD(I)) D WRITE + M SOLDI=OLDI + ; +EN2 ;ask for ICD's or display previously entered ones for editing + ;note: because ICD's are not longer required, could not use standard + ; FileMan calls everywhere because of need to control deleted + ; entries and cross-references. + W ! + F I=1:1:8 D Q:+$G(Y)=-1!(@RAR@("DFLG")) + . I '$G(PSORXED)&('$G(CPRS)) S RAR="PSONEW" + .K DIC S DIC("A")=$S(I=1:"Select Primary ICD-9 Code: ",1:"Select Secondary ICD-9 Code: ") + . I $D(OLD(I)),(OLD(I)'="") S DIC("B")=OLD(I) + . S X="" W !,DIC("A") D R X:60 ;did this so that I have control of the deletes + .. I $D(OLD(I)),(OLD(I)'="") W OLD(I)_"// " + . I $D(OLD(I)) S:X="" X=OLD(I) + . I X="" S Y=-1 Q + . I X["?" W !,"Enter a valid ICD-9 diagnosis code." S I=1-1 Q + . I X="@" D DELETE Q + . I X="^" S Y=-1 Q + . K DIC S DIC=80,DIC(0)="EMZQ" + . ;S DIC("S")="I $P($$ICDDX^ICDCODE(Y,FILDAT),U,10)&($P($$ICDDX^ICDCODE(Y,FILDAT),U,17)>$P($$ICDDX^ICDCODE(Y,FILDAT),U,12))" + . S DIC("S")="I $$STATCHK^PSODIAG(Y,FILDAT)" + . K DTOUT,DUOUT D ^DIC K DIC + . I X="^" S I=I-1,Y="" Q + . I $G(DUOUT)!($G(DTOUT)) S Y=-1,X="^" Q + . I +Y=-1&(X'=""!(X'="^")) I $D(^ICD9("BA",X)) S I=I-1,(X,Y)="" Q ;user said No to are you sure ?. + . I Y=-1&(X?1A.A) S I=I-1,Y="" Q ;user said not to Yes? question. + . I Y'=-1 D I STATCHK2=1 S I=I-1,Y="" Q + .. S (STATCHK,STATCHK2)="",STATCHK=$$STATCHK^ICDAPIU($P(Y,U,2),FILDAT) D + ... I $P(STATCHK,"^",2)=-1 W !!,"Invalid ICD-9 diagnosis code. Please choose another.",! S STATCHK2=1 Q + ... I +STATCHK=0 W !!,"Inactivated ICD-9 Diagnosis Code. Please choose another.",! S STATCHK2=1 Q + . I +Y=-1 S I=I-1,Y="" W !!,"Invalid or inactivated ICD-9 diagnosis code. Please choose another.",! Q + . S (POP,J)=0 F J=1:1:I D + ..I $G(DX(J))=+Y W $C(7),!," Duplicate entry. Please select a different ICD-9 diagnosis code.",! S I=I-1,(Y,X)="",POP=1 + . Q:POP + . S NEW("ICD",I)=$P(Y,U,1),DX(I)=+Y + ; + ;resequence entered ICD's and removed deleted ones from file + ;I X="^"&(RAR="PSONEW")&('CPRS) S @RAR@("DFLG")=0 K DUOUT,DTOUT,Y,X Q + ; + I '$D(NEW("ICD")) I $D(OLDI) M NEW("ICD")=OLDI ;if user ^ out on first icd + K PSOICDD I '$D(NEW("ICD"))&($G(PSOCOPY)) S PSOICDD=1 + ; + S J=0 F I=1:1:8 Q:'$D(NEW("ICD",I)) I NEW("ICD",I)'="" S J=J+1,@RAR@("ICD",J)=NEW("ICD",I) + S TNEW=I + I X="^" D ;if up arrow out, set all icd's past ^ point into array + . ;S Y=TNEW-1 F S Y=$O(OLDI(Y)) Q:Y="" S J=J+1,@RAR@("ICD",J)=OLDI(Y) + . K @RAR@("ICD") S Y="" F S Y=$O(SOLDI(Y)) Q:Y="" S @RAR@("ICD",Y)=SOLDI(Y) + . K PSORXED("FLD",39.3) ;7/12/04 + I $G(CPRS) K PSORX("ICD") M PSORXED("ICD")=@RAR@("ICD"),PSORX("ICD")=@RAR@("ICD") + I $G(PSORXED) K PSORX("ICD") M PSORX("ICD")=@RAR@("ICD") + I '$D(@RAR@("ICD"))&(CPRS) S PSONEW("IDFLG")=1 ;user deleted all in finish/complete order + Q:(RAR="PSONEW") + I '$D(@RAR@("ICD"))&('CPRS)&($D(^PSRX(PSOX("IRXN"),"ICD",1,0))) S PSORXED("IDFLG")=1 ;user deleted all + Q + ; + ;called from above to write previously entered ICD's to screen. +WRITE S J=I-1 I I=1 W !,?10,"Primary: ",OLD(I),?30,$P($$ICDDX^ICDCODE(OLD(I),FILDAT),U,4) Q +WRITE2 I I=2 W !,?3,"Secondaries #"_J_": ",OLD(I),?30,$P($$ICDDX^ICDCODE(OLD(I),FILDAT),U,4) Q + I I>2 W !,?15,"#"_J_": ",OLD(I),?30,$P($$ICDDX^ICDCODE(OLD(I),FILDAT),U,4) + Q +STATCHK(ICDIEN,FILDAT) ;called from above to check active/inactive date during FileMan call. + N X S X="" + S ICDIEN=$P(^ICD9(ICDIEN,0),"^",1) S X=$$STATCHK^ICDAPIU(ICDIEN,FILDAT) + Q +X +DELETE ;called from above to verify delete with user and to delete said entries + W !,"SURE YOU WANT TO DELETE? " S X="" R X:30 S X=$TR(X,"yn","YN") + I X'="Y"&(X'="N") W !,"Enter Y or N" G DELETE + I X="N" S I=I-1 Q + F J=I:1:8 Q:'$D(OLDI(J)) D + . I $D(OLDI(J+1)) S OLDI(J)=OLDI(J+1),OLD(J)=OLD(J+1) D + .. I CPRS&($D(PSONEW("ICD",J+1))) S PSONEW("ICD",J)=PSONEW("ICD",J+1) + .. E I CPRS&('$D(PSONEW("ICD",J+1))) S PSONEW("ICD",J)=OLDI(J+1) + .. I $G(PSOCOPY) D + ... I ($D(PSONEW("ICD",J+1))) S PSONEW("ICD",J)=PSONEW("ICD",J+1) + ... I ($D(PSORXED("ICD",J+1))) S PSORXED("ICD",J)=PSORXED("ICD",J+1) + . E K OLD(J),OLDI(J),PSONEW("ICD",J),PSORXED("ICD",J) + . ;I CPRS!($G(PSOCOPY)) K PSONEW("ICD",J),PSORXED("ICD",J) + S I=I-1,(X,Y)="" + Q + ; +ICD ;called from PSON52 cause PSON52'S too large. Stores ICD info for new Rx's (CPRS and backdoor) using variables from copy function and new order functions. + N D,DDATA,ICD,II + I $G(PSOCOPY)&('$D(PSOX("ICD")))&('$G(PSOICDD)) D + . S D=0 F D=1:1 Q:'$D(PSOX("ICD",D)) + . F D=D:1:8 K ^PSRX(PSOX("IRXN"),"ICD",D,0) ;remove any icd's del + . I $D(^PSRX(PSOX("OIRXN"),"ICD",0)) F D=1:1:8 Q:'$D(^PSRX(PSOX("OIRXN"),"ICD",D,0)) S PSOX("ICD",D)=$P(^PSRX(PSOX("OIRXN"),"ICD",D,0),U,1) + I $G(ORD) I $D(^PS(52.41,ORD,0))&($D(PSORX("ICD"))) M PSOX("ICD")=PSONEW("ICD") + I $D(PSOX("ICD")) F D=1:1:8 Q:'$D(PSOX("ICD",D)) S ICD=$G(PSOX("ICD",D)) D + . S DDATA="",DDATA=ICD_"^"_$G(PSOANSQ("VEH"))_"^"_$G(PSOANSQ("RAD"))_"^"_$S(PSOSCP>49:$G(PSOANSQ("SC>50")),PSOSCP<50&(PSOSCP'=""):$G(PSOANSQ("SC")),1:"")_"^"_$G(PSOANSQ("PGW"))_"^"_$G(PSOANSQ("MST"))_"^"_$G(PSOANSQ("HNC"))_"^"_$G(PSOANSQ("CV")) + . I $P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)=1 I PSOSCP<50&($D(PSOANSQ("SC>50"))) S $P(DDATA,"^",4)=PSOANSQ("SC>50") ;for times when sc has no % defined. + . S ^PSRX(PSOX("IRXN"),"ICD",D,0)=DDATA,II=D + E S D=1 D + . S DDATA="",DDATA="^"_$G(PSOANSQ("VEH"))_"^"_$G(PSOANSQ("RAD"))_"^"_$S(PSOSCP>49:$G(PSOANSQ("SC>50")),PSOSCP<50&(PSOSCP'=""):$G(PSOANSQ("SC")),1:"") + . S DDATA=DDATA_"^"_$G(PSOANSQ("PGW"))_"^"_$G(PSOANSQ("MST"))_"^"_$G(PSOANSQ("HNC"))_"^"_$G(PSOANSQ("CV")) + . S ^PSRX(PSOX("IRXN"),"ICD",D,0)=DDATA,II=D + . I $P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)=1 I PSOSCP<50&($D(PSOANSQ("SC>50"))) S $P(^PSRX(PSOX("IRXN"),"ICD",D,0),"^",4)=PSOANSQ("SC>50") + S ^PSRX(PSOX("IRXN"),"ICD",0)="^52.052311P^"_II_"^"_II + K PSOX("ICD"),PSORXED("ICD"),PSONEW("ICD"),PSORX("ICD") + Q + ; +UPDATE ;was in PSOORED6; now called from PSOORED6; removes deletes for edits and stores data. + ; + N TNEW,DA,DIK,SCEI,I,II + S DA=PSORXED("IRXN") + I '$D(PSORXED("ICD"))&($G(PSORXED("IDFLG"))) D K PSORXED("IDFLG") Q + . I $D(^PSRX(PSORXED("IRXN"),"ICD",1,0)) D + .. S TNEW=2 K ^PSRX(PSORXED("IRXN"),"ICD","B") S $P(^PSRX(PSORXED("IRXN"),"ICD",1,0),U,1)="" + .. F I=TNEW:1:8 Q:'$D(^PSRX(PSORXED("IRXN"),"ICD",I,0)) S DIK="^PSRX("_PSORXED("IRXN")_","_$C(34)_"ICD"_$C(34)_",",DA=I,DA(1)=PSORXED("IRXN") D ^DIK K DA,DIK + ; + I $D(PSORXED("ICD")) D + . S SCEI=$G(^PSRX(DA,"ICD",1,0)),$P(SCEI,"^")="" + . K ^PSRX(DA,"ICD") + . F I=1:1:8 Q:'$D(PSORXED("ICD",I)) S $P(SCEI,"^")=PSORXED("ICD",I),^PSRX(DA,"ICD",I,0)=SCEI,^PSRX(DA,"ICD","B",$P(SCEI,"^"),I)="",II=I + . S ^PSRX(DA,"ICD",0)="^52.052311P^"_II_U_II + Q + ; +CSET ;Called from PSOHLNEW due to it's routine size. Requires PSOICD & PENDING variable. Sets ICD node for orders passed from CPRS. + N EE,EEE + S (EE,EEE)=0 F S EE=$O(PSOICD(EE)) Q:EE="" D + .S EEE=EEE+1,^PS(52.41,PENDING,"ICD",EEE,0)=PSOICD(EE) S:$P(PSOICD(EE),"^")'="" ^PS(52.41,PENDING,"ICD","B",$P(PSOICD(EE),"^"),EEE)="" + .S ^PS(52.41,PENDING,"ICD",0)="^52.41311PA"_U_EEE_U_EEE + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODIR.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODIR.m index e6419077..05907e92 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODIR.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODIR.m @@ -1,114 +1,113 @@ -PSODIR ;BHAM ISC/SAB - asks data for rx order entry ; 9/17/07 5:03pm - ;;7.0;OUTPATIENT PHARMACY;**37,46,111,117,146,164,211,264,275**;DEC 1997;Build 8 - ;External reference PSDRUG( supported by DBIA 221 - ;External reference PS(50.7 supported by DBIA 2223 - ;External reference to VA(200 is supported by DBIA 10060 - ;---------------------------------------------------------------- - ; -PROV(PSODIR) ; -PROVEN ; Entry point for failed lookup - K DIC,X,Y S:$G(PSOFDR)&($G(OR0)) DIC("B")=$P(^VA(200,$P($G(OR0),"^",5),0),"^") - I $G(PSODIR("PROVIDER"))]"" S PSODIR("OLD VAL")=PSODIR("PROVIDER") - S DIC="^VA(200,",DIC(0)="QEAM",PSODIR("FIELD")=0 - S DIC("W")="W "" "",$P(^(""PS""),""^"",9)" - S DIC("A")="PROVIDER: ",DIC("S")="I $D(^(""PS"")),$P(^(""PS""),""^""),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)'1 D:'$G(PSOEDIT) JUMP G PROVX - I $D(DTOUT)!$D(DUOUT) S PSODIR("DFLG")=1 G PROVX - I '$G(SPEED),Y=-1 G PROVEN - Q:$G(SPEED)&(Y=-1) - ;PSO*7*211; ADD CHECK FOR DEA# AND VA# - I $P($G(PSODIR("CS")),"^",1)!($D(CLOZPAT)) I '$L($P($G(^VA(200,+Y,"PS")),U,2)),'$L($P($G(^VA(200,+Y,"PS")),U,3)) D G PROVEN - .W $C(7),!!,"Provider must have a DEA# or VA#"_$S($D(CLOZPAT):" to write prescriptions for clozapine.",1:""),! - I $D(CLOZPAT),'$D(^XUSEC("YSCL AUTHORIZED",+Y)) D G PROVEN - .W $C(7),!!,"Provider must hold YSCL AUTHORIZED key to write prescriptions for clozapine.",! - I '$G(PSODRUG("IEN")),'$G(PSORENW("DRUG IEN")) G NODRUG - ;I '$G(SPEED),$P($G(^PSDRUG($S($G(PSODRUG("IEN")):PSODRUG("IEN"),1:PSORENW("DRUG IEN")),"CLOZ1")),"^")="PSOCLO1",$P(^VA(200,+Y,"PS"),"^",2)'?2U7N D K Y,PSORX("PROVIDER NAME"),DIC("B") G PROVEN - ;.W $C(7),!!,"Only providers with DEA numbers can write prescriptions for clozapine.",! -NODRUG S PSODIR("PROVIDER")=+Y - S (PSODIR("PROVIDER NAME"),PSORX("PROVIDER NAME"))=$P(Y,"^",2) - I $G(PSODIR("OLD VAL"))'=+Y K PSODIR("GENERIC PROVIDER"),PSODIR("COSIGNING PROVIDER") - I $G(PSODIR("OLD VAL"))'=$G(PSODIR("PROVIDER")),$P(Y,"^",2)="PROVIDER,OTHER"!($P(Y,"^",2)="PROVIDER,OUTSIDE") D GENERIC - I $P(^VA(200,PSODIR("PROVIDER"),"PS"),"^",7),$P(^("PS"),"^",8) D COSIGN - I $G(PSODIR("COSIGNING PROVIDER")),'$P(^VA(200,PSODIR("PROVIDER"),"PS"),"^",7) K PSODIR("COSIGNING PROVIDER") -PROVX K X,Y - Q - ; -GENERIC ; - K DIR,DIC,PSODIR("GENERIC PROVIDER") - S DIR(0)="52,30" - D DIR G:PSODIR("DFLG")!PSODIR("FIELD") GENERICX - S PSODIR("GENERIC PROVIDER")=Y -GENERICX K X,Y - Q - ; -COSIGN ; - K DIC - I '$G(PSODIR("COSIGNING PROVIDER")),$P($G(RX3),"^",3) S PSODIR("COSIGNING PROVIDER")=$P(RX3,"^",3) G COSIGN1 - I $P($G(RX3),"^",3),$P($G(RX3),"^",3)'=$P(^VA(200,PSODIR("PROVIDER"),"PS"),"^",8) D - .W !!,"Previous Co-Signing Provider: "_$P(^VA(200,$P(RX3,"^",3),0),"^") - .S PSODIR("COSIGNING PROVIDER")=$S($P(RX3,"^",3)'=PSODIR("COSIGNING PROVIDER"):PSODIR("COSIGNING PROVIDER"),1:$P(^VA(200,PSODIR("PROVIDER"),"PS"),"^",8)) -COSIGN1 S DIC(0)="QEAM",DIC="^VA(200,",DIC("B")=$S($G(PSODIR("COSIGNING PROVIDER")):$P(^VA(200,PSODIR("COSIGNING PROVIDER"),0),"^"),1:$P(^VA(200,PSODIR("PROVIDER"),"PS"),"^",8)) - S DIC("S")="I $D(^(""PS"")),$P(^(""PS""),""^""),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)'0 PSODIR("COSIGNING PROVIDER")=+Y G:Y<0 COSIGN -COSIGNX K X,Y - Q -DOSE(PSODIR) ;add dosing info - D DOSE1^PSOORED5(.PSODIR) -EX K PSODOSE,PSOSCH,DOSE,DOOR,SCH,VERB,NOUN,DOSEOR,ENT,PSORTE,DRUA,DIR,X,Y,DIRUT,RTE,ERTE,DD,INS1,SINS1 - Q -INS(PSODIR) ;patient instructions - N DA K INS1,DD,DIR,DIRUT S D=0 F S D=$O(PSODIR("SIG",D)) Q:'D S DD=$G(DD)+1 - I $G(DD)=1 S PSODIR("INS")=$G(PSODIR("SIG",1)) G INSD - ;PSO*7*275 remove check for PSOINSFL just check for multi line sig - I $G(DD)>1 D G EX - .K ^TMP($J) S D=0 F S D=$O(PSODIR("SIG",D)) Q:'D S ^TMP($J,"SIG",D,0)=PSODIR("SIG",D) - .S DWPK=2,DWLW=80,DIC="^TMP($J,""SIG""," D EN^DIWE K PSODIR("SIG") - .S D=0 F S D=$O(^TMP($J,"SIG",D)) Q:'D S PSODIR("SIG",D)=^TMP($J,"SIG",D,0) - .D EN^PSOFSIG(.PSODIR,1) K DWLW,D,DWPK,^TMP($J) - I $G(PSOINSFL)=0 G INSD - I $G(PSOFDR),$G(ORD),$P($G(^PS(52.41,+$G(ORD),"EXT")),"^")'="" G INSD - I $G(PSODIR("INS"))']"",$G(^PS(50.7,PSODRUG("OI"),"INS"))]"" S DIR("B")=^PS(50.7,PSODRUG("OI"),"INS") -INSD S DIR(0)="52,114" S:$G(PSODIR("INS"))]"" DIR("B")=PSODIR("INS") - D DIR G:$G(PSODIR("DFLG"))!(PSODIR("FIELD")) EX - I X'="",X'="@" S PSODIR("INS")=Y D SIG^PSOHELP G INSD:'$D(X) - I $G(INS1)]"" D EN^DDIOL($E(INS1,2,9999999)) S (PSODIR("SIG",1),PSODIR("SIG"))=$E(INS1,2,9999999) - I X="@" K PSODIR("INS"),PSODIR("SIG") - D EN^PSOFSIG(.PSODIR,1) I $O(SIG(0)) S SIGOK=1 - G EX - Q -SINS(PSODIR) ;other lang. patient instructions - K SINS1,DIR - S DIR(0)="52,114.1" S:$G(PSODIR("SINS"))]"" DIR("B")=PSODIR("SINS") - I $G(PSODIR("SINS"))']"",$G(^PS(50.7,PSODRUG("OI"),"INS1"))]"" S DIR("B")=^PS(50.7,PSODRUG("OI"),"INS1") - D DIR G:$G(PSODIR("DFLG")) EX - I X'="",X'="@" S PSODIR("SINS")=Y D SSIG^PSOHELP - I $G(SINS1)]"" D EN^DDIOL($E(SINS1,2,9999999)) S PSODIR("SINS")=$E(SINS1,2,9999999) - I X="@" K PSODIR("SINS") - G EX - Q - ; -DIR ; - S PSODIR("FIELD")=0 - G:$G(DIR(0))']"" DIRX - D ^DIR K DIR,DIE,DIC,DA - I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)),$L($G(X))'>1 S PSODIR("DFLG")=1 G DIRX - I X[U,$L(X)>1 D:'$G(PSOEDIT) JUMP -DIRX K DIRUT,DTOUT,DUOUT,DIROUT,PSOX - Q - ; -JUMP ; - I $G(PSOEDIT)!($G(OR0)) S PSODIR("DFLG")=1 Q - S X=$P(X,"^",2),DIC="^DD(52,",DIC(0)="QM" D ^DIC K DIC - I Y=-1 S PSODIR("FIELD")=$G(PSODIR("FLD")) G JUMPX - I $G(PSONEW1)=0 D JUMP^PSONEW1 G JUMPX - I $G(PSOREF1)=0 D JUMP^PSOREF1 G JUMPX - I $G(PSONEW3)=0 D JUMP^PSONEW3 G JUMPX - I $G(PSORENW3)=0 D JUMP^PSORENW3 G JUMPX -JUMPX S X="^"_X - Q +PSODIR ;BHAM ISC/SAB - asks data for rx order entry ;02/12/93 8:49 + ;;7.0;OUTPATIENT PHARMACY;**37,46,111,117,146,164,211,264**;DEC 1997;Build 19 + ;External reference PSDRUG( supported by DBIA 221 + ;External reference PS(50.7 supported by DBIA 2223 + ;External reference to VA(200 is supported by DBIA 10060 + ;---------------------------------------------------------------- + ; +PROV(PSODIR) ; +PROVEN ; Entry point for failed lookup + K DIC,X,Y S:$G(PSOFDR)&($G(OR0)) DIC("B")=$P(^VA(200,$P($G(OR0),"^",5),0),"^") + I $G(PSODIR("PROVIDER"))]"" S PSODIR("OLD VAL")=PSODIR("PROVIDER") + S DIC="^VA(200,",DIC(0)="QEAM",PSODIR("FIELD")=0 + S DIC("W")="W "" "",$P(^(""PS""),""^"",9)" + S DIC("A")="PROVIDER: ",DIC("S")="I $D(^(""PS"")),$P(^(""PS""),""^""),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)'1 D:'$G(PSOEDIT) JUMP G PROVX + I $D(DTOUT)!$D(DUOUT) S PSODIR("DFLG")=1 G PROVX + I '$G(SPEED),Y=-1 G PROVEN + Q:$G(SPEED)&(Y=-1) + ;PSO*7*211; ADD CHECK FOR DEA# AND VA# + I $P($G(PSODIR("CS")),"^",1)!($D(CLOZPAT)) I '$L($P($G(^VA(200,+Y,"PS")),U,2)),'$L($P($G(^VA(200,+Y,"PS")),U,3)) D G PROVEN + .W $C(7),!!,"Provider must have a DEA# or VA#"_$S($D(CLOZPAT):" to write prescriptions for clozapine.",1:""),! + I $D(CLOZPAT),'$D(^XUSEC("YSCL AUTHORIZED",+Y)) D G PROVEN + .W $C(7),!!,"Provider must hold YSCL AUTHORIZED key to write prescriptions for clozapine.",! + I '$G(PSODRUG("IEN")),'$G(PSORENW("DRUG IEN")) G NODRUG + ;I '$G(SPEED),$P($G(^PSDRUG($S($G(PSODRUG("IEN")):PSODRUG("IEN"),1:PSORENW("DRUG IEN")),"CLOZ1")),"^")="PSOCLO1",$P(^VA(200,+Y,"PS"),"^",2)'?2U7N D K Y,PSORX("PROVIDER NAME"),DIC("B") G PROVEN + ;.W $C(7),!!,"Only providers with DEA numbers can write prescriptions for clozapine.",! +NODRUG S PSODIR("PROVIDER")=+Y + S (PSODIR("PROVIDER NAME"),PSORX("PROVIDER NAME"))=$P(Y,"^",2) + I $G(PSODIR("OLD VAL"))'=+Y K PSODIR("GENERIC PROVIDER"),PSODIR("COSIGNING PROVIDER") + I $G(PSODIR("OLD VAL"))'=$G(PSODIR("PROVIDER")),$P(Y,"^",2)="PROVIDER,OTHER"!($P(Y,"^",2)="PROVIDER,OUTSIDE") D GENERIC + I $P(^VA(200,PSODIR("PROVIDER"),"PS"),"^",7),$P(^("PS"),"^",8) D COSIGN + I $G(PSODIR("COSIGNING PROVIDER")),'$P(^VA(200,PSODIR("PROVIDER"),"PS"),"^",7) K PSODIR("COSIGNING PROVIDER") +PROVX K X,Y + Q + ; +GENERIC ; + K DIR,DIC,PSODIR("GENERIC PROVIDER") + S DIR(0)="52,30" + D DIR G:PSODIR("DFLG")!PSODIR("FIELD") GENERICX + S PSODIR("GENERIC PROVIDER")=Y +GENERICX K X,Y + Q + ; +COSIGN ; + K DIC + I '$G(PSODIR("COSIGNING PROVIDER")),$P($G(RX3),"^",3) S PSODIR("COSIGNING PROVIDER")=$P(RX3,"^",3) G COSIGN1 + I $P($G(RX3),"^",3),$P($G(RX3),"^",3)'=$P(^VA(200,PSODIR("PROVIDER"),"PS"),"^",8) D + .W !!,"Previous Co-Signing Provider: "_$P(^VA(200,$P(RX3,"^",3),0),"^") + .S PSODIR("COSIGNING PROVIDER")=$S($P(RX3,"^",3)'=PSODIR("COSIGNING PROVIDER"):PSODIR("COSIGNING PROVIDER"),1:$P(^VA(200,PSODIR("PROVIDER"),"PS"),"^",8)) +COSIGN1 S DIC(0)="QEAM",DIC="^VA(200,",DIC("B")=$S($G(PSODIR("COSIGNING PROVIDER")):$P(^VA(200,PSODIR("COSIGNING PROVIDER"),0),"^"),1:$P(^VA(200,PSODIR("PROVIDER"),"PS"),"^",8)) + S DIC("S")="I $D(^(""PS"")),$P(^(""PS""),""^""),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)'0 PSODIR("COSIGNING PROVIDER")=+Y G:Y<0 COSIGN +COSIGNX K X,Y + Q +DOSE(PSODIR) ;add dosing info + D DOSE1^PSOORED5(.PSODIR) +EX K PSODOSE,PSOSCH,DOSE,DOOR,SCH,VERB,NOUN,DOSEOR,ENT,PSORTE,DRUA,DIR,X,Y,DIRUT,RTE,ERTE,DD,INS1,SINS1 + Q +INS(PSODIR) ;patient instructions + N DA K INS1,DD,DIR,DIRUT S D=0 F S D=$O(PSODIR("SIG",D)) Q:'D S DD=$G(DD)+1 + I $G(DD)=1 S PSODIR("INS")=$G(PSODIR("SIG",1)) G INSD + I ($G(PSOINSFL)=1&($G(DD)>1))!($G(PSOFDR)&($G(ORD))&($P($G(^PS(52.41,+$G(ORD),"EXT")),"^")'="")&($G(DD)>1)) D G EX + .K ^TMP($J) S D=0 F S D=$O(PSODIR("SIG",D)) Q:'D S ^TMP($J,"SIG",D,0)=PSODIR("SIG",D) + .S DWPK=2,DWLW=80,DIC="^TMP($J,""SIG""," D EN^DIWE K PSODIR("SIG") + .S D=0 F S D=$O(^TMP($J,"SIG",D)) Q:'D S PSODIR("SIG",D)=^TMP($J,"SIG",D,0) + .D EN^PSOFSIG(.PSODIR,1) K DWLW,D,DWPK,^TMP($J) + I $G(PSOINSFL)=0 G INSD + I $G(PSOFDR),$G(ORD),$P($G(^PS(52.41,+$G(ORD),"EXT")),"^")'="" G INSD + I $G(PSODIR("INS"))']"",$G(^PS(50.7,PSODRUG("OI"),"INS"))]"" S DIR("B")=^PS(50.7,PSODRUG("OI"),"INS") +INSD S DIR(0)="52,114" S:$G(PSODIR("INS"))]"" DIR("B")=PSODIR("INS") + D DIR G:$G(PSODIR("DFLG"))!(PSODIR("FIELD")) EX + I X'="",X'="@" S PSODIR("INS")=Y D SIG^PSOHELP G INSD:'$D(X) + I $G(INS1)]"" D EN^DDIOL($E(INS1,2,9999999)) S (PSODIR("SIG",1),PSODIR("SIG"))=$E(INS1,2,9999999) + I X="@" K PSODIR("INS"),PSODIR("SIG") + D EN^PSOFSIG(.PSODIR,1) I $O(SIG(0)) S SIGOK=1 + G EX + Q +SINS(PSODIR) ;other lang. patient instructions + K SINS1,DIR + S DIR(0)="52,114.1" S:$G(PSODIR("SINS"))]"" DIR("B")=PSODIR("SINS") + I $G(PSODIR("SINS"))']"",$G(^PS(50.7,PSODRUG("OI"),"INS1"))]"" S DIR("B")=^PS(50.7,PSODRUG("OI"),"INS1") + D DIR G:$G(PSODIR("DFLG")) EX + I X'="",X'="@" S PSODIR("SINS")=Y D SSIG^PSOHELP + I $G(SINS1)]"" D EN^DDIOL($E(SINS1,2,9999999)) S PSODIR("SINS")=$E(SINS1,2,9999999) + I X="@" K PSODIR("SINS") + G EX + Q + ; +DIR ; + S PSODIR("FIELD")=0 + G:$G(DIR(0))']"" DIRX + D ^DIR K DIR,DIE,DIC,DA + I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)),$L($G(X))'>1 S PSODIR("DFLG")=1 G DIRX + I X[U,$L(X)>1 D:'$G(PSOEDIT) JUMP +DIRX K DIRUT,DTOUT,DUOUT,DIROUT,PSOX + Q + ; +JUMP ; + I $G(PSOEDIT)!($G(OR0)) S PSODIR("DFLG")=1 Q + S X=$P(X,"^",2),DIC="^DD(52,",DIC(0)="QM" D ^DIC K DIC + I Y=-1 S PSODIR("FIELD")=$G(PSODIR("FLD")) G JUMPX + I $G(PSONEW1)=0 D JUMP^PSONEW1 G JUMPX + I $G(PSOREF1)=0 D JUMP^PSOREF1 G JUMPX + I $G(PSONEW3)=0 D JUMP^PSONEW3 G JUMPX + I $G(PSORENW3)=0 D JUMP^PSORENW3 G JUMPX +JUMPX S X="^"_X + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODIR1.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODIR1.m index 2663ed0b..9cf5d7d1 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODIR1.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODIR1.m @@ -1,162 +1,162 @@ -PSODIR1 ;IHS/DSD - ASKS DATA FOR RX ORDER ENTRY CONT. ;6/21/07 8:22am - ;;7.0;OUTPATIENT PHARMACY;**23,46,78,102,121,131,146,166,184,222,268,206**;DEC 1997;Build 39 - ;Ext ref ^PS(55-DBIA 2228, ^PSDRUG(-DBIA 221 -PTSTAT(PSODIR) ; -PTSTATEN K DIC,DR,DIE S PSODIR("FIELD")=0 - I $G(PSOTPBFG),$G(PSOFROM)="NEW" K PSORX("PATIENT STATUS"),PSODIR("PATIENT STATUS") N PSOFNDRX,PSOFNDFL,PSOFNDPS D - .S PSOFNDFL=0 F PSOFNDPS=0:0 S PSOFNDPS=$O(^PS(53,PSOFNDPS)) Q:'PSOFNDPS!(PSOFNDFL) D - ..S PSOFNDRX=$P($G(^PS(53,PSOFNDPS,0)),"^") S PSOFNDRX=$$UP^XLFSTR(PSOFNDRX) I PSOFNDRX="NON-VA" S PSOFNDFL=1 S (PSORX("PATIENT STATUS"),DIC("B"))=$P($G(^PS(53,PSOFNDPS,0)),"^") - I $G(PSOTPBFG),$G(PSOFROM)="NEW",$G(PSORX("PATIENT STATUS"))="" W !,"Could not find a 'NON-VA' Patient Status in the RX PATIENT STATUS file (#53)!" D PSTPB D S PSODIR("DFLG")=1 G PTSTATX - .K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR - I $G(PSOTPBFG),$G(PSOFROM)="NEW" G TPBB - N PSOX - S PSOX=$G(^PS(55,PSODFN,"PS")) I PSOX]"" S PSORX("PATIENT STATUS")=$P($G(^PS(53,PSOX,0)),"^"),DIC("B")=PSORX("PATIENT STATUS") - S:$G(PSODIR("PATIENT STATUS"))]"" DIC("B")=PSODIR("PATIENT STATUS") -TPBB ; - D ELIG^VADPT W !,"Eligibility: "_$P(VAEL(1),"^",2)_$S(+VAEL(3):" SC%: "_$P(VAEL(3),"^",2),1:"") - S N=0 F S N=$O(VAEL(1,N)) Q:'N W !,?10,$P(VAEL(1,N),"^",2) - S DIC("A")="RX PATIENT STATUS: " - S DIC(0)="QEAMZ",DIC=53 D ^DIC K DIC - I $G(PSOTPBFG),$G(PSOFROM)="NEW" N PSOPSDIR,PSOFNDZZ,PSOPSUPA S (PSOPSDIR,PSOPSUPA)=0 D I PSOPSDIR S:PSOPSUPA PSODIR("DFLG")=1 G:PSOPSUPA PTSTATX W ! D PSTPB G PTSTATEN - .I +Y'>0!($D(DTOUT))!($D(DUOUT)) S (PSOPSDIR,PSOPSUPA)=1 Q - .S (PSODIR("PATIENT STATUS"),PSORX("PATIENT STATUS"))=+Y,PSODIR("PTST NODE")=Y(0) - .S PSOFNDZZ=$P($G(^PS(53,+Y,0)),"^") S PSOFNDZZ=$$UP^XLFSTR(PSOFNDZZ) I PSOFNDZZ'="NON-VA" S PSOPSDIR=1 K PSODIR("PATIENT STATUS"),PSORX("PATIENT STATUS"),PSODIR("PTST NODE") - I $G(PSOTPBFG),$G(PSOFROM)="NEW" G TPBSC - I X[U,$L(X)>1 D:'$G(PSOEDIT) JUMP G PTSTATX - I $D(DUOUT)!$D(DTOUT) S PSODIR("DFLG")=1 G PTSTATX - I Y=-1 W $C(7)," Required" G PTSTATEN - N PSOFNDX,PSOFNDXY,PSOFNDXX,PSOFNDYY - S PSOFNDXY=$G(Y),PSOFNDYY=$G(Y(0)) - I '$G(PSOTPBFG),$G(PSOFROM)="NEW" S PSOFNDX=$P($G(^PS(53,+Y,0)),"^") S PSOFNDXX=$$UP^XLFSTR(PSOFNDX) I PSOFNDXX="NON-VA" K PSOFNDX,PSOFNDXY,PSOFNDYY,PSOFNDXX,Y W !!,"Cannot select 'NON-VA' Rx Patient Status!",! G PTSTATEN - S Y=$G(PSOFNDXY),Y(0)=$G(PSOFNDYY) - K PSOFNDXY,PSOFNDYY,PSOFNDX,PSOFNDXX - S (PSODIR("PATIENT STATUS"),PSORX("PATIENT STATUS"))=+Y - S PSODIR("PTST NODE")=Y(0) -TPBSC ; - I $G(PSOFDR),$P($G(OR0),"^",17)="C" G PTSTATX - L +^PS(55,PSODFN):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T G PTSTATX - S DIE="55",DR="3////"_+Y,DA=PSODFN D ^DIE K DIE,DA,D0 - L -^PS(55,PSODFN) -PTSTATX K DTOUT,DUOUT,X,Y,DA - Q -SIG(PSODIR) ; - I $G(PSOFDR),$G(PSODIR("SIG"))']"" D SIGOK G:$G(SIGOK)!($G(PSODIR("DFLG"))) SIGX - K DIR,DIC - S DIR(0)="52,10" - S:$G(PSODRUG("SIG"))]"" DIR("B")=PSODRUG("SIG") - S:$G(PSODIR("SIG"))]"" DIR("B")=PSODIR("SIG") - D DIR G:PSODIR("DFLG")!PSODIR("FIELD") SIGX - S PSODIR("SIG")=Y,SIGOK=0 K SIG -SIGX K X,Y - Q -QTY(PSODIR) ; -QTYA K DIR,DIC - I $G(CLOZPAT)=1 S DIR("A",1)="Patient Eligible for 14 day supply or 7 day supply with 1 refill" - I $G(CLOZPAT)=2 S DIR("A",1)="Patient Eligible 28 day supply or 14 day supply with 1 refill or 7 day supply with 3 refill" - S DIR(0)="52,7" S:$G(PSODRUG("IEN")) DIR("A")="QTY ( "_$G(PSODRUG("UNIT"))_" ) "_$S($P($G(^PSDRUG(+PSODRUG("IEN"),5)),"^")]"":$P(^PSDRUG(+PSODRUG("IEN"),5),"^"),1:"") - K QTYHLD I $G(PSODIR("QTY"))]"" S QTYHLD=PSODIR("QTY") K PSODIR("QTY") - D:'$G(PSOQTY) QTY^PSOSIG(.PSODIR) - I '$G(SPEED),$G(QTYHLD),'$G(PSODIR("QTY")) S PSODIR("QTY")=QTYHLD - K QTYHLD K:'$G(PSODIR("QTY")) PSODIR("QTY") - I $G(SPEED),$G(PSODIR("QTY"))']"" S PSODIR("QTY")=$P(^PSRX(PSORENW("OIRXN"),0),"^",7) - S:$G(PSODIR("QTY"))]"" DIR("B")=PSODIR("QTY") - D DIR G:PSODIR("DFLG")!PSODIR("FIELD") QTYX - I $G(Y),$G(PSODRUG("MAXDOSE"))]"",$G(PSODIR("DAYS SUPPLY")),(Y/+PSODIR("DAYS SUPPLY")>PSODRUG("MAXDOSE")) D G:$G(PSODIR("DFLG")) QTYX G QTYA - .W !,$C(7)," Greater than Maximum dose of "_PSODRUG("MAXDOSE")_" per day" D DAYSEN - S PSODIR("QTY")=Y -QTYX K X,Y - Q -COPIES(PSODIR) ; - K DIR,DIC - S DIR(0)="52,10.6" - S DIR("B")=$S($G(PSODIR("COPIES"))]"":PSODIR("COPIES"),1:1) - D DIR G:PSODIR("DFLG")!PSODIR("FIELD") COPIESX - S PSODIR("COPIES")=Y -COPIESX K X,Y - Q -DAYS(PSODIR) ; -DAYSEN K DIR,DIC - S DIR(0)="N^1:"_$S($G(CLOZPAT)=2:28,$G(CLOZPAT)=1:14,$G(CLOZPAT)=0:7,1:90) - S DIR("B")=$S($D(CLOZPAT)&('$G(PSODIR("DAYS SUPPLY"))):7,$G(PSODIR("DAYS SUPPLY"))]"":PSODIR("DAYS SUPPLY"),$P($G(PSODIR("PTST NODE")),"^",3):$P(PSODIR("PTST NODE"),"^",3),1:30) - S DIR("A")="DAYS SUPPLY",DIR("?")="Enter a whole number between 1 and "_$S($G(CLOZPAT)=2:28,$G(CLOZPAT)=1:14,$G(CLOZPAT)=0:7,1:90) - D DIR G:PSODIR("DFLG")!PSODIR("FIELD") DAYSX - I $G(Y),$G(PSODRUG("MAXDOSE"))]"",$G(PSODIR("QTY"))]"",(+PSODIR("QTY")/Y>PSODRUG("MAXDOSE")) W !,$C(7)," Greater than Maximum dose of "_PSODRUG("MAXDOSE")_" per day" G DAYSEN - S PSODIR("DAYS SUPPLY")=Y D:$G(PSOFROM)="NEW" - .K QTYHLD S:$G(PSODIR("QTY")) QTYHLD=PSODIR("QTY") D QTY^PSOSIG(.PSODIR) - .I $G(QTYHLD),'$G(PSODIR("QTY")) S PSODIR("QTY")=QTYHLD - .K QTYHLD K:'$G(PSODIR("QTY")) PSODIR("QTY") - S:$G(CLOZPAT)=0 (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=0 - D:$G(CLOZPAT)=2 - .S:PSODIR("DAYS SUPPLY")=28 (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=0 - .S:PSODIR("DAYS SUPPLY")=14 (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=1 - .S:PSODIR("DAYS SUPPLY")=7 (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=3 - D:$G(CLOZPAT)=1 - .S:PSODIR("DAYS SUPPLY")=14 (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=0 - .S:PSODIR("DAYS SUPPLY")=7 (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=1 - K QTYHLD S:$G(PSODIR("QTY")) QTYHLD=PSODIR("QTY") D QTY^PSOSIG(.PSODIR) - I $G(QTYHLD),'$G(PSODIR("QTY")) S PSODIR("QTY")=QTYHLD - K QTYHLD K:'$G(PSODIR("QTY")) PSODIR("QTY") -DAYSX K X,Y - Q -REFILL(PSODIR) ; - I $G(OR0) G REFOR - S PSODIR("CS")=0 K DIR,DIC,PSOX - F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)="" I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S $P(PSODIR("CS"),"^")=1 S:$E(+PSODRUG("DEA"),DEA)=2 $P(PSODIR("CS"),"^",2)=1 - I PSODIR("CS") D - .S PSOX=5,PSOX1=$S($P($G(PSODIR("PTST NODE")),"^",4)>PSOX:PSOX,1:$P($G(PSODIR("PTST NODE")),"^",4)),PSOX=$S(PSOX1=5:PSOX,1:PSOX1) - .S PSOX=$S('PSOX:0,PSODIR("DAYS SUPPLY")=90:1,1:PSOX),PSDY=PSODIR("DAYS SUPPLY"),PSDY1=$S(PSDY<60:5,PSDY'<60&(PSDY'>89):2,PSDY=90:1,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1) - E D - .S PSOX=11,PSOX1=$S($P($G(PSODIR("PTST NODE")),"^",4)>PSOX:PSOX,1:$P($G(PSODIR("PTST NODE")),"^",4)),PSOX=$S(PSOX1=11:PSOX,1:PSOX1) - .S PSDY=PSODIR("DAYS SUPPLY"),PSDY1=$S(PSDY<60:11,PSDY'<60&(PSDY'>89):5,PSDY=90:3,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1) - I '$D(CLOZPAT) I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F")!(PSODRUG("DEA")[1)!(PSODRUG("DEA")[2) D G REFILLX - .I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")[1)!(PSODRUG("DEA")[2)!'$O(^PSRX(+$G(PSODIR("IRXN")),1,0))!('$G(PSOLOKED)) D Q - ..S VALMSG="No refills allowed on "_$S(PSODRUG("DEA")["F":"this drug.",1:"Narcotics.") W !,VALMSG,! - ..S:$D(PSODIR("FIELD")) PSODIR("FIELD")=0 S PSODIR("# OF REFILLS")=0 - ..Q - .;reset refills to the # given - .D RFRSET^PSODIR2 - .Q - I $P($G(PSODIR("CS")),"^",2)=1 W !,"No refills allowed on Schedule 2 drugs...",! S:$D(PSODIR("FIELD")) PSODIR("FIELD")=0 S PSODIR("# OF REFILLS")=0 G REFILLX - I $D(CLOZPAT) S PSOX=$S($G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=14):1,$G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=7):3,$G(CLOZPAT)=1&(PSODIR("DAYS SUPPLY")=7):1,1:0) - S DIR(0)="N^"_$S($G(RFTT):RFTT,1:0)_":"_PSOX,DIR("A")="# OF REFILLS" - S DIR("B")=$S($G(COPY):PSODIR("# OF REFILLS"),$G(PSODIR("N# REF"))]"":PSODIR("N# REF"),$G(PSODIR("# OF REFILLS"))]"":PSODIR("# OF REFILLS"),$G(PSOX1)]""&(PSOX>PSOX1):PSOX1,1:PSOX) - S DIR("?")="Enter a whole number. The maximum is set by the DAYS SUPPLY field." - D DIR G:PSODIR("DFLG")!PSODIR("FIELD") REFILLX - S (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=Y -REFILLX S:$G(PSODIR("# OF REFILLS"))']"" PSODIR("# OF REFILLS")=$S($G(PSODIR("N# REF"))]"":PSODIR("N# REF"),$G(PSOX1)]""&($G(PSOX)>PSOX1):PSOX1,1:PSOX) - K X,Y,PSOX,PSOX1,PSDY,PSDY1,DEA,PSOCS - Q - ;OERR CALL -REFOR ; - D REFOR^PSODIR3 - G REFILLX - Q -DIR ; - S (PSODIR("FIELD"),PSODIR("DFLG"))=0 - G:$G(DIR(0))']"" DIRX - D ^DIR K DIR,DIE,DIC,DA - I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)),$L($G(X))'>1!(Y="") S PSODIR("DFLG")=1 G DIRX - I $D(DIRUT)!($D(DIROUT)),$G(SPEED) S PSODIR("DFLG")=1 G DIRX - I X[U,$L(X)>1 D JUMP -DIRX K DIRUT,DTOUT,DUOUT,DIROUT - Q -JUMP ; - I $G(PSOEDIT)!($G(OR0)) S PSODIR("DFLG")=1 Q - S X=$P(X,"^",2),DIC="^DD(52,",DIC(0)="QM" D ^DIC K DIC - I Y=-1 S PSODIR("FIELD")=PSODIR("FLD") G JUMPX - I $G(PSONEW1)=0 D JUMP^PSONEW1 G JUMPX - I $G(PSOREF1)=0 D JUMP^PSOREF1 G JUMPX - I $G(PSONEW3)=0 D JUMP^PSONEW3 G JUMPX - I $G(PSORENW3)=0 D JUMP^PSORENW3 G JUMPX -JUMPX S X="^"_X - Q -SIGOK ;review and decide on oerr sig - I '$O(SIG(0)) S SIGOK=0 Q - K SIGOK W !,"SIG: " - F SIG=0:0 S SIG=$O(SIG(SIG)) W SIG(SIG)_" ",!?5 Q:'$O(SIG(SIG)) - K DIR,DIRUT,DUOUT,DTOUT S DIR("B")="YES",DIR(0)="Y",DIR("A")="Is this SIG correct" D ^DIR K DIR I $D(DIRUT) S PSODIR("DFLG")=1 K DIRUT,DUOUT,DTOUT Q - S SIGOK=Y I Y K PSODIR("SIG") - Q -PSTPB ; - W !,"New orders entered through this option must have a Patient Status of 'NON-VA'!",! - Q +PSODIR1 ;IHS/DSD - ASKS DATA FOR RX ORDER ENTRY CONT. ;02/17/93 17:03 + ;;7.0;OUTPATIENT PHARMACY;**23,46,78,102,121,131,146,166,184,222,268**;DEC 1997;Build 9 + ;Ext ref ^PS(55-DBIA 2228, ^PSDRUG(-DBIA 221 +PTSTAT(PSODIR) ; +PTSTATEN K DIC,DR,DIE S PSODIR("FIELD")=0 + I $G(PSOTPBFG),$G(PSOFROM)="NEW" K PSORX("PATIENT STATUS"),PSODIR("PATIENT STATUS") N PSOFNDRX,PSOFNDFL,PSOFNDPS D + .S PSOFNDFL=0 F PSOFNDPS=0:0 S PSOFNDPS=$O(^PS(53,PSOFNDPS)) Q:'PSOFNDPS!(PSOFNDFL) D + ..S PSOFNDRX=$P($G(^PS(53,PSOFNDPS,0)),"^") S PSOFNDRX=$$UP^XLFSTR(PSOFNDRX) I PSOFNDRX="NON-VA" S PSOFNDFL=1 S (PSORX("PATIENT STATUS"),DIC("B"))=$P($G(^PS(53,PSOFNDPS,0)),"^") + I $G(PSOTPBFG),$G(PSOFROM)="NEW",$G(PSORX("PATIENT STATUS"))="" W !,"Could not find a 'NON-VA' Patient Status in the RX PATIENT STATUS file (#53)!" D PSTPB D S PSODIR("DFLG")=1 G PTSTATX + .K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR + I $G(PSOTPBFG),$G(PSOFROM)="NEW" G TPBB + N PSOX + S PSOX=$G(^PS(55,PSODFN,"PS")) I PSOX]"" S PSORX("PATIENT STATUS")=$P($G(^PS(53,PSOX,0)),"^"),DIC("B")=PSORX("PATIENT STATUS") + S:$G(PSODIR("PATIENT STATUS"))]"" DIC("B")=PSODIR("PATIENT STATUS") +TPBB ; + D ELIG^VADPT W !,"Eligibility: "_$P(VAEL(1),"^",2)_$S(+VAEL(3):" SC%: "_$P(VAEL(3),"^",2),1:"") + S N=0 F S N=$O(VAEL(1,N)) Q:'N W !,?10,$P(VAEL(1,N),"^",2) + S DIC("A")="RX PATIENT STATUS: " + S DIC(0)="QEAMZ",DIC=53 D ^DIC K DIC + I $G(PSOTPBFG),$G(PSOFROM)="NEW" N PSOPSDIR,PSOFNDZZ,PSOPSUPA S (PSOPSDIR,PSOPSUPA)=0 D I PSOPSDIR S:PSOPSUPA PSODIR("DFLG")=1 G:PSOPSUPA PTSTATX W ! D PSTPB G PTSTATEN + .I +Y'>0!($D(DTOUT))!($D(DUOUT)) S (PSOPSDIR,PSOPSUPA)=1 Q + .S (PSODIR("PATIENT STATUS"),PSORX("PATIENT STATUS"))=+Y,PSODIR("PTST NODE")=Y(0) + .S PSOFNDZZ=$P($G(^PS(53,+Y,0)),"^") S PSOFNDZZ=$$UP^XLFSTR(PSOFNDZZ) I PSOFNDZZ'="NON-VA" S PSOPSDIR=1 K PSODIR("PATIENT STATUS"),PSORX("PATIENT STATUS"),PSODIR("PTST NODE") + I $G(PSOTPBFG),$G(PSOFROM)="NEW" G TPBSC + I X[U,$L(X)>1 D:'$G(PSOEDIT) JUMP G PTSTATX + I $D(DUOUT)!$D(DTOUT) S PSODIR("DFLG")=1 G PTSTATX + I Y=-1 W $C(7)," Required" G PTSTATEN + N PSOFNDX,PSOFNDXY,PSOFNDXX,PSOFNDYY + S PSOFNDXY=$G(Y),PSOFNDYY=$G(Y(0)) + I '$G(PSOTPBFG),$G(PSOFROM)="NEW" S PSOFNDX=$P($G(^PS(53,+Y,0)),"^") S PSOFNDXX=$$UP^XLFSTR(PSOFNDX) I PSOFNDXX="NON-VA" K PSOFNDX,PSOFNDXY,PSOFNDYY,PSOFNDXX,Y W !!,"Cannot select 'NON-VA' Rx Patient Status!",! G PTSTATEN + S Y=$G(PSOFNDXY),Y(0)=$G(PSOFNDYY) + K PSOFNDXY,PSOFNDYY,PSOFNDX,PSOFNDXX + S (PSODIR("PATIENT STATUS"),PSORX("PATIENT STATUS"))=+Y + S PSODIR("PTST NODE")=Y(0) +TPBSC ; + I $G(PSOFDR),$P($G(OR0),"^",17)="C" G PTSTATX + L +^PS(55,PSODFN):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T G PTSTATX + S DIE="55",DR="3////"_+Y,DA=PSODFN D ^DIE K DIE,DA,D0 + L -^PS(55,PSODFN) +PTSTATX K DTOUT,DUOUT,X,Y,DA + Q +SIG(PSODIR) ; + I $G(PSOFDR),$G(PSODIR("SIG"))']"" D SIGOK G:$G(SIGOK)!($G(PSODIR("DFLG"))) SIGX + K DIR,DIC + S DIR(0)="52,10" + S:$G(PSODRUG("SIG"))]"" DIR("B")=PSODRUG("SIG") + S:$G(PSODIR("SIG"))]"" DIR("B")=PSODIR("SIG") + D DIR G:PSODIR("DFLG")!PSODIR("FIELD") SIGX + S PSODIR("SIG")=Y,SIGOK=0 K SIG +SIGX K X,Y + Q +QTY(PSODIR) ; +QTYA K DIR,DIC + I $G(CLOZPAT)=1 S DIR("A",1)="Patient Eligible for 14 day supply or 7 day supply with 1 refill" + I $G(CLOZPAT)=2 S DIR("A",1)="Patient Eligible 28 day supply or 14 day supply with 1 refill or 7 day supply with 3 refill" + S DIR(0)="52,7" S:$G(PSODRUG("IEN")) DIR("A")="QTY ( "_$G(PSODRUG("UNIT"))_" ) "_$S($P($G(^PSDRUG(+PSODRUG("IEN"),5)),"^")]"":$P(^PSDRUG(+PSODRUG("IEN"),5),"^"),1:"") + K QTYHLD I $G(PSODIR("QTY"))]"" S QTYHLD=PSODIR("QTY") K PSODIR("QTY") + D:'$G(PSOQTY) QTY^PSOSIG(.PSODIR) + I '$G(SPEED),$G(QTYHLD),'$G(PSODIR("QTY")) S PSODIR("QTY")=QTYHLD + K QTYHLD K:'$G(PSODIR("QTY")) PSODIR("QTY") + I $G(SPEED),$G(PSODIR("QTY"))']"" S PSODIR("QTY")=$P(^PSRX(PSORENW("OIRXN"),0),"^",7) + S:$G(PSODIR("QTY"))]"" DIR("B")=PSODIR("QTY") + D DIR G:PSODIR("DFLG")!PSODIR("FIELD") QTYX + I $G(Y),$G(PSODRUG("MAXDOSE"))]"",$G(PSODIR("DAYS SUPPLY")),(Y/+PSODIR("DAYS SUPPLY")>PSODRUG("MAXDOSE")) D G:$G(PSODIR("DFLG")) QTYX G QTYA + .W !,$C(7)," Greater than Maximum dose of "_PSODRUG("MAXDOSE")_" per day" D DAYSEN + S PSODIR("QTY")=Y +QTYX K X,Y + Q +COPIES(PSODIR) ; + K DIR,DIC + S DIR(0)="52,10.6" + S DIR("B")=$S($G(PSODIR("COPIES"))]"":PSODIR("COPIES"),1:1) + D DIR G:PSODIR("DFLG")!PSODIR("FIELD") COPIESX + S PSODIR("COPIES")=Y +COPIESX K X,Y + Q +DAYS(PSODIR) ; +DAYSEN K DIR,DIC + S DIR(0)="N^1:"_$S($G(CLOZPAT)=2:28,$G(CLOZPAT)=1:14,$G(CLOZPAT)=0:7,1:90) + S DIR("B")=$S($D(CLOZPAT)&('$G(PSODIR("DAYS SUPPLY"))):7,$G(PSODIR("DAYS SUPPLY"))]"":PSODIR("DAYS SUPPLY"),$P($G(PSODIR("PTST NODE")),"^",3):$P(PSODIR("PTST NODE"),"^",3),1:30) + S DIR("A")="DAYS SUPPLY",DIR("?")="Enter a whole number between 1 and "_$S($G(CLOZPAT)=2:28,$G(CLOZPAT)=1:14,$G(CLOZPAT)=0:7,1:90) + D DIR G:PSODIR("DFLG")!PSODIR("FIELD") DAYSX + I $G(Y),$G(PSODRUG("MAXDOSE"))]"",$G(PSODIR("QTY"))]"",(+PSODIR("QTY")/Y>PSODRUG("MAXDOSE")) W !,$C(7)," Greater than Maximum dose of "_PSODRUG("MAXDOSE")_" per day" G DAYSEN + S PSODIR("DAYS SUPPLY")=Y D:$G(PSOFROM)="NEW" + .K QTYHLD S:$G(PSODIR("QTY")) QTYHLD=PSODIR("QTY") D QTY^PSOSIG(.PSODIR) + .I $G(QTYHLD),'$G(PSODIR("QTY")) S PSODIR("QTY")=QTYHLD + .K QTYHLD K:'$G(PSODIR("QTY")) PSODIR("QTY") + S:$G(CLOZPAT)=0 (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=0 + D:$G(CLOZPAT)=2 + .S:PSODIR("DAYS SUPPLY")=28 (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=0 + .S:PSODIR("DAYS SUPPLY")=14 (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=1 + .S:PSODIR("DAYS SUPPLY")=7 (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=3 + D:$G(CLOZPAT)=1 + .S:PSODIR("DAYS SUPPLY")=14 (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=0 + .S:PSODIR("DAYS SUPPLY")=7 (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=1 + K QTYHLD S:$G(PSODIR("QTY")) QTYHLD=PSODIR("QTY") D QTY^PSOSIG(.PSODIR) + I $G(QTYHLD),'$G(PSODIR("QTY")) S PSODIR("QTY")=QTYHLD + K QTYHLD K:'$G(PSODIR("QTY")) PSODIR("QTY") +DAYSX K X,Y + Q +REFILL(PSODIR) ; + I $G(OR0) G REFOR + S PSODIR("CS")=0 K DIR,DIC,PSOX + F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)="" I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S $P(PSODIR("CS"),"^")=1 S:$E(+PSODRUG("DEA"),DEA)=2 $P(PSODIR("CS"),"^",2)=1 + I PSODIR("CS") D + .S PSOX=5,PSOX1=$S($P($G(PSODIR("PTST NODE")),"^",4)>PSOX:PSOX,1:$P($G(PSODIR("PTST NODE")),"^",4)),PSOX=$S(PSOX1=5:PSOX,1:PSOX1) + .S PSOX=$S('PSOX:0,PSODIR("DAYS SUPPLY")=90:1,1:PSOX),PSDY=PSODIR("DAYS SUPPLY"),PSDY1=$S(PSDY<60:5,PSDY'<60&(PSDY'>89):2,PSDY=90:1,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1) + E D + .S PSOX=11,PSOX1=$S($P($G(PSODIR("PTST NODE")),"^",4)>PSOX:PSOX,1:$P($G(PSODIR("PTST NODE")),"^",4)),PSOX=$S(PSOX1=11:PSOX,1:PSOX1) + .S PSDY=PSODIR("DAYS SUPPLY"),PSDY1=$S(PSDY<60:11,PSDY'<60&(PSDY'>89):5,PSDY=90:3,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1) + I '$D(CLOZPAT) I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F") D G REFILLX + .I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!'$O(^PSRX(+$G(PSODIR("IRXN")),1,0))!('$G(PSOLOKED)) D Q + ..S VALMSG="No refills allowed on "_$S(PSODRUG("DEA")["F":"this drug.",1:"Narcotics.") W !,VALMSG,! + ..S:$D(PSODIR("FIELD")) PSODIR("FIELD")=0 S PSODIR("# OF REFILLS")=0 + ..Q + .;reset refills to the # given + .D RFRSET^PSODIR2 + .Q + I $P($G(PSODIR("CS")),"^",2)=1 W !,"No refills allowed on Schedule 2 drugs...",! S:$D(PSODIR("FIELD")) PSODIR("FIELD")=0 S PSODIR("# OF REFILLS")=0 G REFILLX + I $D(CLOZPAT) S PSOX=$S($G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=14):1,$G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=7):3,$G(CLOZPAT)=1&(PSODIR("DAYS SUPPLY")=7):1,1:0) + S DIR(0)="N^"_$S($G(RFTT):RFTT,1:0)_":"_PSOX,DIR("A")="# OF REFILLS" + S DIR("B")=$S($G(COPY):PSODIR("# OF REFILLS"),$G(PSODIR("N# REF"))]"":PSODIR("N# REF"),$G(PSODIR("# OF REFILLS"))]"":PSODIR("# OF REFILLS"),$G(PSOX1)]""&(PSOX>PSOX1):PSOX1,1:PSOX) + S DIR("?")="Enter a whole number. The maximum is set by the DAYS SUPPLY field." + D DIR G:PSODIR("DFLG")!PSODIR("FIELD") REFILLX + S (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=Y +REFILLX S:$G(PSODIR("# OF REFILLS"))']"" PSODIR("# OF REFILLS")=$S($G(PSODIR("N# REF"))]"":PSODIR("N# REF"),$G(PSOX1)]""&($G(PSOX)>PSOX1):PSOX1,1:PSOX) + K X,Y,PSOX,PSOX1,PSDY,PSDY1,DEA,PSOCS + Q + ;OERR CALL +REFOR ; + D REFOR^PSODIR3 + G REFILLX + Q +DIR ; + S (PSODIR("FIELD"),PSODIR("DFLG"))=0 + G:$G(DIR(0))']"" DIRX + D ^DIR K DIR,DIE,DIC,DA + I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)),$L($G(X))'>1!(Y="") S PSODIR("DFLG")=1 G DIRX + I $D(DIRUT)!($D(DIROUT)),$G(SPEED) S PSODIR("DFLG")=1 G DIRX + I X[U,$L(X)>1 D JUMP +DIRX K DIRUT,DTOUT,DUOUT,DIROUT + Q +JUMP ; + I $G(PSOEDIT)!($G(OR0)) S PSODIR("DFLG")=1 Q + S X=$P(X,"^",2),DIC="^DD(52,",DIC(0)="QM" D ^DIC K DIC + I Y=-1 S PSODIR("FIELD")=PSODIR("FLD") G JUMPX + I $G(PSONEW1)=0 D JUMP^PSONEW1 G JUMPX + I $G(PSOREF1)=0 D JUMP^PSOREF1 G JUMPX + I $G(PSONEW3)=0 D JUMP^PSONEW3 G JUMPX + I $G(PSORENW3)=0 D JUMP^PSORENW3 G JUMPX +JUMPX S X="^"_X + Q +SIGOK ;review and decide on oerr sig + I '$O(SIG(0)) S SIGOK=0 Q + K SIGOK W !,"SIG: " + F SIG=0:0 S SIG=$O(SIG(SIG)) W SIG(SIG)_" ",!?5 Q:'$O(SIG(SIG)) + K DIR,DIRUT,DUOUT,DTOUT S DIR("B")="YES",DIR(0)="Y",DIR("A")="Is this SIG correct" D ^DIR K DIR I $D(DIRUT) S PSODIR("DFLG")=1 K DIRUT,DUOUT,DTOUT Q + S SIGOK=Y I Y K PSODIR("SIG") + Q +PSTPB ; + W !,"New orders entered through this option must have a Patient Status of 'NON-VA'!",! + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODIR3.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODIR3.m index 5724d86b..58ea6d1d 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODIR3.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODIR3.m @@ -1,91 +1,91 @@ -PSODIR3 ;ISC-BIRM/SAB - rx order entry contd ;4/25/07 8:28am - ;;7.0;OUTPATIENT PHARMACY;**3,46,184,222,206**;DEC 1997;Build 39 - ; -EXP(PSODIR) ; - K DIC,DIR - I $G(PSODRUG("EXPIRATION DATE"))]"" S Y=PSODRUG("EXPIRATION DATE") X ^DD("DD") S PSORX("EXPIRATION DATE")=Y - S DIR("A")="EXPIRES",DIR("B")=$S($G(PSORX("EXPIRATION DATE"))]"":PSORX("EXPIRATION DATE"),1:"T+6M") - S DIR(0)="D^NOW::EX",DIR("?")="Both the month and date are required." D ^DIR - G:PSODIR("DFLG")!PSODIR("FIELD") EXPX - S PSODIR("EXPIRATION DATE")=Y -EXPX K X,Y - Q - ; -MW(PSODIR) ; - K DIR,DIC - S DIR(0)="52,11" - S DIR("B")=$S($G(PSORX("MAIL/WINDOW"))]"":PSORX("MAIL/WINDOW"),1:"WINDOW") - D DIR G:PSODIR("DFLG")!PSODIR("FIELD") MWX - I $G(Y(0))']"" S PSODIR("DFLG")=1 G MWX - S PSODIR("MAIL/WINDOW")=Y,PSORX("MAIL/WINDOW")=Y(0) - I $G(PSORX("EDIT"))]"",PSODIR("MAIL/WINDOW")'="W" K PSODIR("METHOD OF PICK-UP") -MW1 G:PSODIR("MAIL/WINDOW")'="W"!('$P($G(PSOPAR),"^",12)) MWX - S DIR(0)="52,35O" - S:$G(PSORX("METHOD OF PICK-UP"))]"" DIR("B")=PSORX("METHOD OF PICK-UP") - D DIR G:PSODIR("DFLG") MWX - I X[U W !,"Cannot jump to another field ..",! G MW1 - S (PSODIR("METHOD OF PICK-UP"),PSORX("METHOD OF PICK-UP"))=Y -MWX K X,Y - Q - ; -FILLDT(PSODIR) ; - K DIR,DIC - S DIR("A")="FILL DATE",DIR("B")=$S($G(PSORX("FILL DATE"))]"":PSORX("FILL DATE"),1:"TODAY") - S DIR(0)="D^"_$S($G(PSODIR("ISSUE DATE"))]"":PSODIR("ISSUE DATE"),1:DT)_$S($G(DUZ("AG"))="I":":"_DT_":EX",1:"::EX") - S DIR("?",1)="The earliest fill date allowed is determined by the ISSUE DATE," - S DIR("?",2)="the FILL DATE cannot be before the ISSUE DATE." - S DIR("?")="Both the month and date are required." - D DIR G:PSODIR("DFLG")!PSODIR("FIELD") FILLDTX - S PSODIR("FILL DATE")=Y - X ^DD("DD") S PSORX("FILL DATE")=Y -FILLDTX K X,Y - Q - ; -CLERK(PSODIR) ; - I $G(DUZ("AG"))'="I",$G(DUZ) S PSODIR("CLERK CODE")=DUZ,PSORX("CLERK CODE")=$P($G(^VA(200,DUZ,0)),"^") G CLERKX - K DIR,DIC - S DIR("A")="CLERK",DIR("B")=$S($G(PSORX("CLERK CODE"))]"":PSORX("CLERK CODE"),1:$P($G(^VA(200,DUZ,0)),"^",2)),DIR(0)="52,16" - D DIR G:PSODIR("DFLG")!PSODIR("FIELD") CLERKX - S PSODIR("CLERK CODE")=+Y,PSORX("CLERK CODE")=$P(Y,"^") -CLERKX Q - ; -DIR ; - S PSODIR("FIELD")=0 - G:$G(DIR(0))']"" DIRX - D ^DIR K DIR,DIE,DIC,DA - I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)),$L($G(X))'>1!(Y="") S PSODIR("DFLG")=1 G DIRX - I X[U,$L(X)>1 D JUMP -DIRX K DIRUT,DTOUT,DUOUT,DIROUT,PSOX - Q - ; -JUMP ; - I $G(PSOEDIT)!($G(OR0)) S PSODIR("DFLG")=1 Q - S X=$P(X,"^",2),DIC="^DD(52,",DIC(0)="QM" D ^DIC K DIC - I Y=-1 S PSODIR("FIELD")=PSODIR("FLD") G JUMPX - I $G(PSONEW1)=0 D JUMP^PSONEW1 G JUMPX - I $G(PSONEW3)=0 D JUMP^PSONEW3 G JUMPX - I $G(PSORENW3)=0 D JUMP^PSORENW3 G JUMPX -JUMPX S X="^"_X - Q - ;Continued from PSODIR1, Tag REFOR, Added PSOCS set and changed G REFILLX references to a QUIT -REFOR ; - F DEA=1:1 Q:$E($G(PSODRUG("DEA")),DEA)="" I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S $P(PSOCS,"^")=1 S:$E(+PSODRUG("DEA"),DEA)=2 $P(PSOCS,"^",2)=1 - I $G(PSOCS) D - .S (PSOX,PSOMAX)=$S($G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=14):1,$G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=7):3,$G(CLOZPAT)=1&(PSODIR("DAYS SUPPLY")=7):1,$D(CLOZPAT):0,1:5) - .S PSOX=$S('PSOX:0,PSODIR("DAYS SUPPLY")=90:1,1:PSOX),PSDY=PSODIR("DAYS SUPPLY"),PSDY1=$S(PSDY<60:5,PSDY'<60&(PSDY'>89):2,PSDY=90:1,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1) - E D - .S (PSOX,PSOMAX)=$S($G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=14):1,$G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=7):3,$G(CLOZPAT)=1&(PSODIR("DAYS SUPPLY")=7):1,$D(CLOZPAT):0,1:11) - .S PSDY=PSODIR("DAYS SUPPLY"),PSDY1=$S(PSDY<60:11,PSDY'<60&(PSDY'>89):5,PSDY=90:3,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1) - K PSOELSE I '$D(CLOZPAT) I $G(PSODRUG("DEA"))["A"&($G(PSODRUG("DEA"))'["B")!($G(PSODRUG("DEA"))["F")!($G(PSODRUG("DEA"))[1)!($G(PSODRUG("DEA"))[2) D Q - .S VALMSG="No refills allowed on "_$S($G(PSODRUG("DEA"))["A":"this narcotic drug.",1:"this drug.") - .W !,VALMSG,! - .S:$D(PSODIR("FIELD")) PSODIR("FIELD")=0 S PSODIR("# OF REFILLS")=0 - I $D(CLOZPAT) D - .S PSOX=$S($G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=14):1,$G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=7):3,$G(CLOZPAT)=1&(PSODIR("DAYS SUPPLY")=7):1,1:0) - .S (PSODIR("# OF REFILLS"),PSODIR("N# REF"))=PSOX - S DIR(0)="N^0:"_PSOX,DIR("A")="# OF REFILLS" - S DIR("B")=$S($G(POERR)&($G(PSODIR("# OF REFILLS"))):PSODIR("# OF REFILLS"),$G(PSODIR("N# REF"))]"":PSODIR("N# REF"),$G(PSODIR("# OF REFILLS"))]"":PSODIR("# OF REFILLS"),$G(PSOX1)]""&(PSOX>PSOX1):PSOX1,1:PSOX) - S DIR("?")="Enter a whole number. The maximum is set by the DAYS SUPPLY field." - D DIR Q:PSODIR("DFLG")!PSODIR("FIELD") - S (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=Y - Q +PSODIR3 ;ISC-BIRM/SAB - rx order entry contd ;09/27/96 + ;;7.0;OUTPATIENT PHARMACY;**3,46,184,222**;DEC 1997;Build 12 + ; +EXP(PSODIR) ; + K DIC,DIR + I $G(PSODRUG("EXPIRATION DATE"))]"" S Y=PSODRUG("EXPIRATION DATE") X ^DD("DD") S PSORX("EXPIRATION DATE")=Y + S DIR("A")="EXPIRES",DIR("B")=$S($G(PSORX("EXPIRATION DATE"))]"":PSORX("EXPIRATION DATE"),1:"T+6M") + S DIR(0)="D^NOW::EX",DIR("?")="Both the month and date are required." D ^DIR + G:PSODIR("DFLG")!PSODIR("FIELD") EXPX + S PSODIR("EXPIRATION DATE")=Y +EXPX K X,Y + Q + ; +MW(PSODIR) ; + K DIR,DIC + S DIR(0)="52,11" + S DIR("B")=$S($G(PSORX("MAIL/WINDOW"))]"":PSORX("MAIL/WINDOW"),1:"WINDOW") + D DIR G:PSODIR("DFLG")!PSODIR("FIELD") MWX + I $G(Y(0))']"" S PSODIR("DFLG")=1 G MWX + S PSODIR("MAIL/WINDOW")=Y,PSORX("MAIL/WINDOW")=Y(0) + I $G(PSORX("EDIT"))]"",PSODIR("MAIL/WINDOW")'="W" K PSODIR("METHOD OF PICK-UP") +MW1 G:PSODIR("MAIL/WINDOW")'="W"!('$P($G(PSOPAR),"^",12)) MWX + S DIR(0)="52,35O" + S:$G(PSORX("METHOD OF PICK-UP"))]"" DIR("B")=PSORX("METHOD OF PICK-UP") + D DIR G:PSODIR("DFLG") MWX + I X[U W !,"Cannot jump to another field ..",! G MW1 + S (PSODIR("METHOD OF PICK-UP"),PSORX("METHOD OF PICK-UP"))=Y +MWX K X,Y + Q + ; +FILLDT(PSODIR) ; + K DIR,DIC + S DIR("A")="FILL DATE",DIR("B")=$S($G(PSORX("FILL DATE"))]"":PSORX("FILL DATE"),1:"TODAY") + S DIR(0)="D^"_$S($G(PSODIR("ISSUE DATE"))]"":PSODIR("ISSUE DATE"),1:DT)_$S($G(DUZ("AG"))="I":":"_DT_":EX",1:"::EX") + S DIR("?",1)="The earliest fill date allowed is determined by the ISSUE DATE," + S DIR("?",2)="the FILL DATE cannot be before the ISSUE DATE." + S DIR("?")="Both the month and date are required." + D DIR G:PSODIR("DFLG")!PSODIR("FIELD") FILLDTX + S PSODIR("FILL DATE")=Y + X ^DD("DD") S PSORX("FILL DATE")=Y +FILLDTX K X,Y + Q + ; +CLERK(PSODIR) ; + I $G(DUZ("AG"))'="I",$G(DUZ) S PSODIR("CLERK CODE")=DUZ,PSORX("CLERK CODE")=$P($G(^VA(200,DUZ,0)),"^") G CLERKX + K DIR,DIC + S DIR("A")="CLERK",DIR("B")=$S($G(PSORX("CLERK CODE"))]"":PSORX("CLERK CODE"),1:$P($G(^VA(200,DUZ,0)),"^",2)),DIR(0)="52,16" + D DIR G:PSODIR("DFLG")!PSODIR("FIELD") CLERKX + S PSODIR("CLERK CODE")=+Y,PSORX("CLERK CODE")=$P(Y,"^") +CLERKX Q + ; +DIR ; + S PSODIR("FIELD")=0 + G:$G(DIR(0))']"" DIRX + D ^DIR K DIR,DIE,DIC,DA + I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)),$L($G(X))'>1!(Y="") S PSODIR("DFLG")=1 G DIRX + I X[U,$L(X)>1 D JUMP +DIRX K DIRUT,DTOUT,DUOUT,DIROUT,PSOX + Q + ; +JUMP ; + I $G(PSOEDIT)!($G(OR0)) S PSODIR("DFLG")=1 Q + S X=$P(X,"^",2),DIC="^DD(52,",DIC(0)="QM" D ^DIC K DIC + I Y=-1 S PSODIR("FIELD")=PSODIR("FLD") G JUMPX + I $G(PSONEW1)=0 D JUMP^PSONEW1 G JUMPX + I $G(PSONEW3)=0 D JUMP^PSONEW3 G JUMPX + I $G(PSORENW3)=0 D JUMP^PSORENW3 G JUMPX +JUMPX S X="^"_X + Q + ;Continued from PSODIR1, Tag REFOR, Added PSOCS set and changed G REFILLX references to a QUIT +REFOR ; + F DEA=1:1 Q:$E($G(PSODRUG("DEA")),DEA)="" I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S $P(PSOCS,"^")=1 S:$E(+PSODRUG("DEA"),DEA)=2 $P(PSOCS,"^",2)=1 + I $G(PSOCS) D + .S (PSOX,PSOMAX)=$S($G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=14):1,$G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=7):3,$G(CLOZPAT)=1&(PSODIR("DAYS SUPPLY")=7):1,$D(CLOZPAT):0,1:5) + .S PSOX=$S('PSOX:0,PSODIR("DAYS SUPPLY")=90:1,1:PSOX),PSDY=PSODIR("DAYS SUPPLY"),PSDY1=$S(PSDY<60:5,PSDY'<60&(PSDY'>89):2,PSDY=90:1,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1) + E D + .S (PSOX,PSOMAX)=$S($G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=14):1,$G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=7):3,$G(CLOZPAT)=1&(PSODIR("DAYS SUPPLY")=7):1,$D(CLOZPAT):0,1:11) + .S PSDY=PSODIR("DAYS SUPPLY"),PSDY1=$S(PSDY<60:11,PSDY'<60&(PSDY'>89):5,PSDY=90:3,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1) + K PSOELSE I '$D(CLOZPAT) I $G(PSODRUG("DEA"))["A"&($G(PSODRUG("DEA"))'["B")!($G(PSODRUG("DEA"))["F") D Q + .S VALMSG="No refills allowed on "_$S($G(PSODRUG("DEA"))["F":"this drug.",1:"Narcotics ..") + .W !,VALMSG,! + .S:$D(PSODIR("FIELD")) PSODIR("FIELD")=0 S PSODIR("# OF REFILLS")=0 + I $D(CLOZPAT) D + .S PSOX=$S($G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=14):1,$G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=7):3,$G(CLOZPAT)=1&(PSODIR("DAYS SUPPLY")=7):1,1:0) + .S (PSODIR("# OF REFILLS"),PSODIR("N# REF"))=PSOX + S DIR(0)="N^0:"_PSOX,DIR("A")="# OF REFILLS" + S DIR("B")=$S($G(POERR)&($G(PSODIR("# OF REFILLS"))):PSODIR("# OF REFILLS"),$G(PSODIR("N# REF"))]"":PSODIR("N# REF"),$G(PSODIR("# OF REFILLS"))]"":PSODIR("# OF REFILLS"),$G(PSOX1)]""&(PSOX>PSOX1):PSOX1,1:PSOX) + S DIR("?")="Enter a whole number. The maximum is set by the DAYS SUPPLY field." + D DIR Q:PSODIR("DFLG")!PSODIR("FIELD") + S (PSODIR("N# REF"),PSODIR("# OF REFILLS"))=Y + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODISP.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODISP.m index 518bca8f..116ed969 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODISP.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODISP.m @@ -1,133 +1,133 @@ -PSODISP ;BIR/SAB,PWC-MANUAL BARCODE RELEASE FUNCTION ;03/02/93 - ;;7.0;OUTPATIENT PHARMACY;**15,71,131,156,185,148,247,200,208**;DEC 1997;Build 41 - ; 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 - ;Reference to $$SERV^IBARX1 supported by DBIA 2245 - ;Reference to ^PSD(58.8 supported by DBIA 1036 - ;Reference to ^PS(55 supported by DBIA 2228 - ;Reference to ^PSDRUG supported by DBIA 221 - ;Reference to ^PSDRUG("AQ" supported by DBIA 3165 - ;Reference to ^XTMP("PSA" supported by DBIA 1036 - ;Reference to ^PS(59.7 supported by DBIA 694 - ;Reference to ^DIC(19.2 supported by DBIA 1064 -AC K CX,PSODA,PSODT,PSRH,DA,DR,DIE,X,X1,X2,Y,RXP,CX,PX,REC,DIR,YDT,REC,RDUZ,DIRUT,PSOCPN,PSOCPRX,YY,QDRUG,QTY,TYPE,XTYPE,DUOUT,PSOPID - K ^UTILITY($J,"PSOHL") S PSOPID=1 - I '$D(PSOPAR) D ^PSOLSET I '$D(PSOPAR) W $C(7),!!,?5,"Site Parameters must be defined to use the Release option!",! G EXIT - S Y=$G(^PS(59,PSOSITE,"IB")),PSOIBSS=$$SERV^IBARX1(+Y) I 'PSOIBSS D IBSSR^PSOUTL I 'PSOIBFL D G EXIT - .W $C(7),!!,"The IB SERVICE/SECTION defined in your site parameter file is not valid.",!,"You will not be able to release any medication until this is corrected!",! -AC1 I $G(PSOAFYN)'="Y" W !! S PSIN=+$P($G(^PS(59.7,1,49.99)),"^",2) ;vfah - VOE - I $G(PSOAFYN)="Y" S PSIN=+$P($G(^PS(59.7,1,49.99)),"^",2) ;vfah - VOE - I $G(PSOAFYN)'="Y" S DIC("S")="I $D(^XUSEC(""PSORPH"",+Y))",DIC("A")="Enter PHARMACIST: ",DIC="^VA(200,",DIC(0)="QEAM" D ^DIC G:"^"[X EXIT K DIC G:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!(Y=-1) EXIT S PSRH=+Y ;vfah - VOE - I $G(PSOAFYN)="Y" S PSRH=DUZ,PSZAR="0" ;vfah - VOE - ;check for Drug Acct background job K8 & K7.1 - S X="PSA IV ALL LOCATIONS",DIC(0)="MZ",DIC=19.2 D ^DIC I Y=-1 K DIC,X,Y G BC - I $P($G(Y(0)),U,2)>DT S PSODA=1 S:'$P($G(^XTMP("PSA",0)),U,2) $P(^(0),U,2)=DT G BC - S X="PSA IV ALL LOCATIONS",DIC(0)="MZ",DIC=19 D ^DIC K DIC,X G:Y=-1 BC - K DIQ,PSA S DA=+Y,DIC=19,DIQ="PSA",DR=200,DIQ(0)="IN" D EN^DIQ1 - I '$D(PSA(19,DA,200,"I")) K DIC,DA,X,Y,DIQ G BC - I PSA(19,DA,200,"I")>DT S PSODA=1 S:'$P($G(^XTMP("PSA",0)),U,2) $P(^(0),U,2)=DT - K PSA,DIC,DA,X,Y,DIQ -BC ; - I $G(PSOAFYN)="Y",$G(PSZAR)="1" Q ;vfah - VOE - K MAN I $G(RXP),$D(DISGROUP),$D(BINGNAM),($D(BINGDIV)!$D(BNGPDV)!$D(BNGRDV)),($D(BINGRO)!$D(BINGRPR)) D REL^PSOBING1 K BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV - I $G(PSOAFYN)'="Y" Q:$G(POERR) W !! K CMOP,ISUF,DIR,LBL,LBLP S DIR("A")="Enter/Wand PRESCRIPTION number",DIR("?")="^D HELP^PSODISP",DIR(0)="FO" D ^DIR ;vfah - VOE - I $G(PSOAFYN)="Y" S X=RXN,PSZAR="1" ;vfah - VOE - I $D(DIRUT)!($D(DTOUT))!($D(DUOUT)) K DIRUT,DTOUT,DUOUT G AC1 - I X'["-" D BCI W:'$G(RXP) !,"INVALID PRESCRIPTION NUMBER" G:'$G(RXP) BC S MAN=1 G BC1 - I X["-",$P(X,"-")'=$P($$SITE^VASITE(),"^",3) W !?7,$C(7),$C(7)," INVALID STATION NUMBER !!",$C(7),$C(7),! G BC - I X["-" S RXP=$P(X,"-",2) I '$D(^PSRX(+$G(RXP),0))!($G(RXP)']"") W !?7,$C(7),$C(7),$C(7)," NON-EXISTENT PRESCRIPTION" G BC - I $D(^PSRX(RXP,0)) D G BC1 - .S PSOLOUD=1 D:$P($G(^PS(55,+$P(^PSRX(+RXP,0),"^",2),0)),"^",6)'=2 EN^PSOHLUP($P(^PSRX(+RXP,0),"^",2)) K PSOLOUD - W !?7,$C(7),$C(7),$C(7)," IMPROPER BARCODE FORMAT" G BC -BC1 ; - D ICN^PSODPT(+$P(^PSRX(RXP,0),"^",2)) - I +$P($G(^PSRX(+RXP,"PKI")),"^") D Q:$G(POERR) G BC - .I $G(SPEED) W !!?7,$C(7),$C(7),"Rx# "_$P(^PSRX(RXP,0),"^") S PSOLIST=4 - .W !!,?7,"UNABLE TO RELEASE - THIS ORDER MUST BE RELEASED THROUGH THE OUTPATIENT",!,?7,"RX'S [PSD OUTPATIENT] OPTION IN THE CONTROLLED SUBSTANCE MENU" - I +$P($G(^PSRX(+RXP,"STA")),"^")=13!(+$P($G(^PSRX(+RXP,0)),"^",2)=0) W !?7,$C(7),$C(7)," PRESCRIPTION IS A DELETED PRESCRIPTION NUMBER" Q:$G(POERR) D DCHK G BC - I +$P($G(^PSRX(+RXP,"STA")),"^"),$S($P(^("STA"),"^")=2:0,$P(^("STA"),"^")=5:0,$P(^("STA"),"^")=11:0,$P(^("STA"),"^")=12:0,$P(^("STA"),"^")=14:0,$P(^("STA"),"^")=15:0,1:1) D STAT^PSODISPS Q:$G(POERR) D DCHK G BC - ;drug stocked in Drug Acct Location? - S PSODA(1)=$S($D(^PSD(58.8,+$O(^PSD(58.8,"AOP",+PSOSITE,0)),1,+$P(^PSRX(RXP,0),U,6))):1,1:0) - I $P(^PSRX(RXP,2),"^",13) S Y=$P(^PSRX(RXP,2),"^",13) X ^DD("DD") S OUT=1 D K OUT Q:$G(POERR) D DCHK G BC - .W !!?7,$C(7),$C(7),$S($G(SPEED):"Rx# "_$P(^PSRX(RXP,0),"^"),1:"Original prescription")_" was last released on "_Y,!?7,"Checking for unreleased refills/partials " D REF -BATCH ; - I $P(^PSRX(RXP,2),"^",15),'$P(^(2),"^",14) S RESK=$P(^(2),"^",15) W !!?5,"Rx# "_$P(^PSRX(RXP,0),"^")_" Original Fill returned to stock on "_$E(RESK,4,5)_"/"_$E(RESK,6,7)_"/"_$E(RESK,2,3),! G REF - ;flag to determine if site is running HL7 v.2.4 Dispense Machines - N PSODISP S PSODISP=$$GET1^DIQ(59,PSOSITE_",",105,"I") - S PSOCPN=$P(^PSRX(RXP,0),"^",2),QTY=$P($G(^PSRX(RXP,0)),"^",7),QDRUG=$P(^PSRX(RXP,0),"^",6) - ;original - I '$P($G(^PSRX(RXP,2)),"^",13),+$P($G(^(2)),"^",2)'DT S PSODA=1 S:'$P($G(^XTMP("PSA",0)),U,2) $P(^(0),U,2)=DT G BC + S X="PSA IV ALL LOCATIONS",DIC(0)="MZ",DIC=19 D ^DIC K DIC,X G:Y=-1 BC + K DIQ,PSA S DA=+Y,DIC=19,DIQ="PSA",DR=200,DIQ(0)="IN" D EN^DIQ1 + I '$D(PSA(19,DA,200,"I")) K DIC,DA,X,Y,DIQ G BC + I PSA(19,DA,200,"I")>DT S PSODA=1 S:'$P($G(^XTMP("PSA",0)),U,2) $P(^(0),U,2)=DT + K PSA,DIC,DA,X,Y,DIQ +BC ; + I $G(PSOAFYN)="Y",$G(PSZAR)="1" Q ;vfah - VOE + K MAN I $G(RXP),$D(DISGROUP),$D(BINGNAM),($D(BINGDIV)!$D(BNGPDV)!$D(BNGRDV)),($D(BINGRO)!$D(BINGRPR)) D REL^PSOBING1 K BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV + I $G(PSOAFYN)'="Y" Q:$G(POERR) W !! K CMOP,ISUF,DIR,LBL,LBLP S DIR("A")="Enter/Wand PRESCRIPTION number",DIR("?")="^D HELP^PSODISP",DIR(0)="FO" D ^DIR ;vfah - VOE + I $G(PSOAFYN)="Y" S X=RXN,PSZAR="1" ;vfah - VOE + I $D(DIRUT)!($D(DTOUT))!($D(DUOUT)) K DIRUT,DTOUT,DUOUT G AC1 + I X'["-" D BCI W:'$G(RXP) !,"INVALID PRESCRIPTION NUMBER" G:'$G(RXP) BC S MAN=1 G BC1 + I X["-",$P(X,"-")'=$P($$SITE^VASITE(),"^",3) W !?7,$C(7),$C(7)," INVALID STATION NUMBER !!",$C(7),$C(7),! G BC + I X["-" S RXP=$P(X,"-",2) I '$D(^PSRX(+$G(RXP),0))!($G(RXP)']"") W !?7,$C(7),$C(7),$C(7)," NON-EXISTENT PRESCRIPTION" G BC + I $D(^PSRX(RXP,0)) D G BC1 + .S PSOLOUD=1 D:$P($G(^PS(55,+$P(^PSRX(+RXP,0),"^",2),0)),"^",6)'=2 EN^PSOHLUP($P(^PSRX(+RXP,0),"^",2)) K PSOLOUD + W !?7,$C(7),$C(7),$C(7)," IMPROPER BARCODE FORMAT" G BC +BC1 ; + D ICN^PSODPT(+$P(^PSRX(RXP,0),"^",2)) + I +$P($G(^PSRX(+RXP,"PKI")),"^") D Q:$G(POERR) G BC + .I $G(SPEED) W !!?7,$C(7),$C(7),"Rx# "_$P(^PSRX(RXP,0),"^") S PSOLIST=4 + .W !!,?7,"UNABLE TO RELEASE - THIS ORDER MUST BE RELEASED THROUGH THE OUTPATIENT",!,?7,"RX'S [PSD OUTPATIENT] OPTION IN THE CONTROLLED SUBSTANCE MENU" + I +$P($G(^PSRX(+RXP,"STA")),"^")=13!(+$P($G(^PSRX(+RXP,0)),"^",2)=0) W !?7,$C(7),$C(7)," PRESCRIPTION IS A DELETED PRESCRIPTION NUMBER" Q:$G(POERR) D DCHK G BC + I +$P($G(^PSRX(+RXP,"STA")),"^"),$S($P(^("STA"),"^")=2:0,$P(^("STA"),"^")=5:0,$P(^("STA"),"^")=11:0,$P(^("STA"),"^")=12:0,$P(^("STA"),"^")=14:0,$P(^("STA"),"^")=15:0,1:1) D STAT^PSODISPS Q:$G(POERR) D DCHK G BC + ;drug stocked in Drug Acct Location? + S PSODA(1)=$S($D(^PSD(58.8,+$O(^PSD(58.8,"AOP",+PSOSITE,0)),1,+$P(^PSRX(RXP,0),U,6))):1,1:0) + I $P(^PSRX(RXP,2),"^",13) S Y=$P(^PSRX(RXP,2),"^",13) X ^DD("DD") S OUT=1 D K OUT Q:$G(POERR) D DCHK G BC + .W !!?7,$C(7),$C(7),$S($G(SPEED):"Rx# "_$P(^PSRX(RXP,0),"^"),1:"Original prescription")_" was last released on "_Y,!?7,"Checking for unreleased refills/partials " D REF +BATCH ; + I $P(^PSRX(RXP,2),"^",15),'$P(^(2),"^",14) S RESK=$P(^(2),"^",15) W !!?5,"Rx# "_$P(^PSRX(RXP,0),"^")_" Original Fill returned to stock on "_$E(RESK,4,5)_"/"_$E(RESK,6,7)_"/"_$E(RESK,2,3),! G REF + ;flag to determine if site is running HL7 v.2.4 Dispense Machines + N PSODISP S PSODISP=$$GET1^DIQ(59,PSOSITE_",",105,"I") + S PSOCPN=$P(^PSRX(RXP,0),"^",2),QTY=$P($G(^PSRX(RXP,0)),"^",7),QDRUG=$P(^PSRX(RXP,0),"^",6) + ;original + I '$P($G(^PSRX(RXP,2)),"^",13),+$P($G(^(2)),"^",2)'DT S PSODA=1 S:'$P($G(^XTMP("PSA",0)),U,2) $P(^(0),U,2)=DT G DOIT - S X="PSA IV ALL LOCATIONS",DIC(0)="MZ",DIC=19 D ^DIC K DIC,X G:Y=-1 DOIT - K DIQ,PSA S DA=+Y,DIC=19,DIQ="PSA",DR=200,DIQ(0)="IN" D EN^DIQ1 - I '$D(PSA(19,DA,200,"I")) K DIC,DA,X,Y,DIQ G DOIT - I PSA(19,DA,200,"I")>DT S PSODA=1 S:'$P($G(^XTMP("PSA",0)),U,2) $P(^(0),U,2)=DT - K PSA,DIC,DA,X,Y,DIQ - ; -DOIT S POERR=1 D FULL^VALM1,BC1^PSODISP - I $D(DISGROUP),$D(BINGNAM),($D(BINGDIV)!$D(BNGPDV)!$D(BNGRDV)),($D(BINGRO)!$D(BINGRPR)) N TM,TM1 D REL^PSOBING1 K BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV -EX ; - K OUT,RX2,RXFD,RESK,ISUF,SUPN,%,DIC,IFN,J,DA,DR,DIE,X,X1,X2,Y,RXP,CX,PX,REC,DIR,YDT,REC,RDUZ,DIRUT,PSOCPN,PSOCPRX,PSOIBSS,PSOIBFL,PSOIBLP,PSOIBST,YY,QDRUG,QTY,TYPE,XTYPE,DUOUT,PSRH,XX,Y,PSIN,POERR,SUB - K DIR S DIR("A",1)=" ",DIR("A")="Press Return to Continue",DIR(0)="E" D ^DIR K DIRUT,DUOUT,DTOUT,DIR S VALMBCK="R" - S PSORXED=1 D ^PSOBUILD,ACT^PSOORNE2 K PSORXED - Q - ; -CHKADDR(RXP) ; - N PSOTXT,PSOBADR,PSOTEMP,LBL - S LBL=$O(^PSRX(RXP,"L",99999),-1) I LBL>0 D - .S PSOTXT=$G(^PSRX(RXP,"L",LBL,0)) I PSOTXT'["(BAD ADDRESS)" Q - .S PSOBADR=$$CHKRX^PSOBAI(RXP) - .I '$G(PSOBADR) D SETLBL(LBL,"NO BAD ADDRESS INDICATOR AT RELEASE") Q - .I $P(PSOBADR,"^",2) D SETLBL(LBL,"ACTIVE TEMPORARY ADDRESS AT RELEASE") - Q - ; -SETLBL(LBL,PSOMSG) ; - N PSOTXT - S PSOTXT=$G(^PSRX(RXP,"L",LBL,0)),$P(PSOTXT,"^",3)=PSOMSG - S LBL=LBL+1,^PSRX(RXP,"L",0)="^52.032DA^"_LBL_"^"_LBL - S ^PSRX(RXP,"L",LBL,0)=PSOTXT - Q +PSODISPS ;BIR/SAB-CONTINUATION OF RELEASE FUNCTION ;3/2/93 + ;;7.0;OUTPATIENT PHARMACY;**15,13,9,27,67,71,156,118,148,247,200,208**;DEC 1997;Build 39 + ; 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 + ;External reference ^PS(59.7 supported by DBIA 694 + ;External reference to ^PSDRUG("AQ" supported by DBIA 3165 + ;External reference ^XTMP("PSA" supported by DBIA 1036 + ;External reference $$SERV^IBARX1 supported by DBIA 2245 + ;External reference ^PSDRUG( supported by DBIA 221 + ;Reference to ^DIC(19.2 supported by DBIA 1064 + ; +QTY ; Refill Release + S PSOCPN=$P(^PSRX(RXP,0),"^",2),QDRUG=$P(^PSRX(RXP,0),"^",6) K LBLP + F YY=0:0 S YY=$O(^PSRX(RXP,XTYPE,YY)) Q:'YY D:$P($G(^PSRX(RXP,XTYPE,YY,0)),"^")'DT S PSODA=1 S:'$P($G(^XTMP("PSA",0)),U,2) $P(^(0),U,2)=DT G DOIT + S X="PSA IV ALL LOCATIONS",DIC(0)="MZ",DIC=19 D ^DIC K DIC,X G:Y=-1 DOIT + K DIQ,PSA S DA=+Y,DIC=19,DIQ="PSA",DR=200,DIQ(0)="IN" D EN^DIQ1 + I '$D(PSA(19,DA,200,"I")) K DIC,DA,X,Y,DIQ G DOIT + I PSA(19,DA,200,"I")>DT S PSODA=1 S:'$P($G(^XTMP("PSA",0)),U,2) $P(^(0),U,2)=DT + K PSA,DIC,DA,X,Y,DIQ + ; +DOIT S POERR=1 D FULL^VALM1,BC1^PSODISP + I $D(DISGROUP),$D(BINGNAM),($D(BINGDIV)!$D(BNGPDV)!$D(BNGRDV)),($D(BINGRO)!$D(BINGRPR)) N TM,TM1 D REL^PSOBING1 K BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV +EX ; + K OUT,RX2,RXFD,RESK,ISUF,SUPN,%,DIC,IFN,J,DA,DR,DIE,X,X1,X2,Y,RXP,CX,PX,REC,DIR,YDT,REC,RDUZ,DIRUT,PSOCPN,PSOCPRX,PSOIBSS,PSOIBFL,PSOIBLP,PSOIBST,YY,QDRUG,QTY,TYPE,XTYPE,DUOUT,PSRH,XX,Y,PSIN,POERR,SUB + K DIR S DIR("A",1)=" ",DIR("A")="Press Return to Continue",DIR(0)="E" D ^DIR K DIRUT,DUOUT,DTOUT,DIR S VALMBCK="R" + S PSORXED=1 D ^PSOBUILD,ACT^PSOORNE2 K PSORXED + Q + ; +CHKADDR(RXP) ; + N PSOTXT,PSOBADR,PSOTEMP,LBL + S LBL=$O(^PSRX(RXP,"L",99999),-1) I LBL>0 D + .S PSOTXT=$G(^PSRX(RXP,"L",LBL,0)) I PSOTXT'["(BAD ADDRESS)" Q + .S PSOBADR=$$CHKRX^PSOBAI(RXP) + .I '$G(PSOBADR) D SETLBL(LBL,"NO BAD ADDRESS INDICATOR AT RELEASE") Q + .I $P(PSOBADR,"^",2) D SETLBL(LBL,"ACTIVE TEMPORARY ADDRESS AT RELEASE") + Q + ; +SETLBL(LBL,PSOMSG) ; + N PSOTXT + S PSOTXT=$G(^PSRX(RXP,"L",LBL,0)),$P(PSOTXT,"^",3)=PSOMSG + S LBL=LBL+1,^PSRX(RXP,"L",0)="^52.032DA^"_LBL_"^"_LBL + S ^PSRX(RXP,"L",LBL,0)=PSOTXT + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODRDUP.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODRDUP.m index 07280394..e6f615ad 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODRDUP.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODRDUP.m @@ -1,84 +1,84 @@ -PSODRDUP ;BIR/SAB - Dup drug class checker ;11/1/04 3:38pm - ;;7.0;OUTPATIENT PHARMACY;**11,23,27,32,39,56,130,132,192,207,222,243,208**;DEC 1997;Build 41 - ; 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 - ; - ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789 - I $G(PSOAFYN)="Y" Q ;vfam No Dup Drug Check by AutoFinish,Rx - VOE - S $P(PSONULN,"-",79)="-",(STA,DNM)="" K CLS - F S STA=$O(PSOSD(STA)) Q:STA="" F S DNM=$O(PSOSD(STA,DNM)) Q:DNM=""!$G(PSORX("DFLG")) I $P(PSOSD(STA,DNM),"^")'=$G(PSORENW("OIRXN")) D Q:$G(PSORX("DFLG")) - .I STA="PENDING" D ^PSODRDU1 Q - .I STA="ZNONVA" D NVA^PSODRDU1 Q - .D:PSODRUG("NAME")=$P(DNM,"^")&('$D(^XUSEC("PSORPH",DUZ))) Q:$G(PSORX("DFLG")) - ..I $P($G(PSOPAR),"^",16) D DUP Q:$G(PSORX("DFLG")) - ..I $P(PSOPAR,"^",2),'$P($G(PSOPAR),"^",16) D DUP Q:$G(PSORX("DFLG")) - ..I '$P(PSOPAR,"^",2),'$P($G(PSOPAR),"^",16) D DUP Q:$G(PSORX("DFLG")) - .D:PSODRUG("NAME")=$P(DNM,"^")&($D(^XUSEC("PSORPH",DUZ))) DUP Q:$G(PSORX("DFLG")) - .I PSODRUG("VA CLASS")]"",$E(PSODRUG("VA CLASS"),1,4)=$E($P(PSOSD(STA,DNM),"^",5),1,4),PSODRUG("NAME")'=$P(DNM,"^") D CLS - K ^TMP($J,"DD"),^TMP($J,"DC"),^TMP($J,"DI") - D REMOTE^PSOCPDUP -EXIT D ^PSOBUILD K CAN,DA,DIR,DNM,DUPRX0,ISSD,J,LSTFL,MSG,PHYS,PSOCLC,PSONULN,REA,RFLS,RX0,RX2,RXN,RXREC,ST,Y,ZZ,ACT,PSOCLOZ,PSOLR,PSOLDT,PSOCD,SIG - Q -DUP S:$P(PSOSD(STA,DNM),"^",2)<10!($P(PSOSD(STA,DNM),"^",2)=16) DUP=1 W !,PSONULN,!,$C(7),"Duplicate Drug "_$P(DNM,"^")_" in Prescription: ",$P(^PSRX(+PSOSD(STA,DNM),0),"^") - S RXREC=+PSOSD(STA,DNM),MSG="Discontinued During "_$S('$G(PSONV):"New Prescription Entry",1:"Verification")_" - Duplicate Drug" -DATA S DUPRX0=^PSRX(RXREC,0),RFLS=$P(DUPRX0,"^",9),ISSD=$P(^PSRX(RXREC,0),"^",13),RX0=DUPRX0,RX2=^PSRX(RXREC,2),$P(RX0,"^",15)=+$G(^PSRX(RXREC,"STA")) - S RXRECLOC=$G(RXREC) - W !!,$J("Status: ",24) S J=RXREC D STAT^PSOFUNC W ST K RX0,RX2 W ?40,$J("Issued: ",24),$E(ISSD,4,5)_"/"_$E(ISSD,6,7)_"/"_$E(ISSD,2,3) - S DA=RXREC D ^PSOCMOPA I $G(PSOCMOP)]"" D K CMOP,PSOTRANS,PSOREL - .S PSOTRANS=$E($P(PSOCMOP,"^",2),4,5)_"/"_$E($P(PSOCMOP,"^",2),6,7)_"/"_$E($P(PSOCMOP,"^",2),2,3) - .S PSOREL=$S(CMOP("L")=0:$P($G(^PSRX(DA,2)),"^",13),1:$P(^PSRX(DA,1,CMOP("L"),0),"^",18)) - .S PSOREL=$E(PSOREL,4,5)_"/"_$E(PSOREL,6,7)_"/"_$E(PSOREL,2,3)_"@"_$E($P(PSOREL,".",2),1,4) - .W !,$J("CMOP Status: ",24)_$S($P(PSOCMOP,"^")=0!($P(PSOCMOP,"^")=2):"Transmitted to on "_PSOTRANS,$P(PSOCMOP,"^")=1:"Released by CMOP on "_PSOREL,1:"Not Dispensed") - K FSIG,BSIG I $P($G(^PSRX(RXREC,"SIG")),"^",2) D FSIG^PSOUTLA("R",RXREC,54) F PSREV=1:1 Q:'$D(FSIG(PSREV)) S BSIG(PSREV)=FSIG(PSREV) - K FSIG,PSREV I '$P($G(^PSRX(RXREC,"SIG")),"^",2) D EN2^PSOUTLA1(RXREC,54) - W !,$J("SIG: ",24) W $G(BSIG(1)) - I $O(BSIG(1)) F PSREV=1:0 S PSREV=$O(BSIG(PSREV)) Q:'PSREV W !?24,$G(BSIG(PSREV)) - K BSIG,PSREV - W !,$J("QTY: ",24)_$P(DUPRX0,"^",7),?40,$J("# of refills: ",24)_RFLS S PHYS=$S($D(^VA(200,+$P(DUPRX0,"^",4),0)):$P(^(0),"^"),1:"UNKNOWN") - W !,$J("Provider: ",24)_PHYS,?40,$J("Refills remaining: ",24),RFLS-$S($D(^PSRX(RXREC,1,0)):$P(^(0),"^",4),1:0) - S LSTFL=+^PSRX(RXREC,3) W !?40,$J("Last filled on: ",24)_$E(LSTFL,4,5)_"/"_$E(LSTFL,6,7)_"/"_$E(LSTFL,2,3),!?40,$J("Days Supply: ",24)_$P(DUPRX0,"^",8) - W !,PSONULN,! I $P($G(^PS(53,+$P($G(PSORX("PATIENT STATUS")),"^"),0)),"^")["AUTH ABS"!($G(PSORX("PATIENT STATUS"))["AUTH ABS")&'$P(PSOPAR,"^",5) W !,"PATIENT ON AUTHORIZED ABSENCE!" K RXRECLOC Q -ASKCAN I $P(PSOSD(STA,DNM),"^",2)>10,$P(PSOSD(STA,DNM),"^",2)'=16 K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR,DTOUT,DUOUT,DIRUT,RXRECLOC Q - I '$P(PSOPAR,"^",2),'$P(PSOPAR,"^",16),'$D(^XUSEC("PSORPH",DUZ)),'$G(CLS) S PSORX("DFLG")=1 K RXRECLOC Q - I $P(PSOPAR,"^",2),'$P(PSOPAR,"^",16),'$D(^XUSEC("PSORPH",DUZ)),'$G(CLS) S PSORX("DFLG")=1 K RXRECLOC Q - I $P(PSOSD(STA,DNM),"^",2)=16,$G(DUP) W !!,"Prescription "_$P($G(^PSRX(+$G(RXRECLOC),0)),"^")_" is on Provider Hold, it cannot be discontinued.",! K DUP,RXRECLOC S PSORX("DFLG")=1 Q - D PSOL^PSSLOCK(RXRECLOC) I '$G(PSOMSG) D K PSOMSG,DIR,DUP,RXRECLOC S DIR("A")="Press Return to continue",DIR(0)="E" D ^DIR K DIR S PSORX("DFLG")=1 Q - .I $P($G(PSOMSG),"^",2)'="" W !!,$P(PSOMSG,"^",2),! Q - .W !!,"Another person is editing Rx "_$P($G(^PSRX(RXRECLOC,0)),"^"),! - K PSOMSG S DIR("A")=$S($P(PSOSD(STA,DNM),"^",2)=12:"Reinstate",1:"Discontinue")_" RX # "_$P(^PSRX(+PSOSD(STA,DNM),0),"^"),DIR(0)="Y",DIR("?")="Enter Y to "_$S($P(PSOSD(STA,DNM),"^",2)=12:"reinstate",1:"discontinue")_" this RX." - D ^DIR K DIR S DA=RXREC S ACT=$S($D(SPCANC):"Reinstated during Rx cancel.",1:$S($P(PSOSD(STA,DNM),"^",2)=12:"Reinstated",1:"Discontinued")_" while "_$S('$G(PSONV):"entering",1:"verifying")_" new RX") - D CMOP^PSOUTL I $G(CMOP("S"))="L" W !,"A CMOP Rx cannot be discontinued during transmission!",! S Y=0 K CMOP - I 'Y W $C(7)," -Prescription was not "_$S($P(PSOSD(STA,DNM),"^",2)=12:"reinstated",1:"discontinued")_"..." D Q - .S:'$D(PSOCLC) PSOCLC=DUZ S MSG=ACT,REA=$S($P(PSOSD(STA,DNM),"^",2)=12:"R",1:"C") S:$G(DUP) PSORX("DFLG")=1 K DUP D ULRX K RXRECLOC - .I $D(^TMP("PSORXDC",$J,RXREC,0)) K ^TMP("PSORXDC",$J,RXREC,0) - I $P(PSOSD(STA,DNM),"^",2)=16,$G(CLS) W !!,"Prescription "_$P($G(^PSRX(+$G(RXRECLOC),0)),"^")_" is on Provider Hold, it cannot be discontinued.",! D ULRX K CLS,DUP,RXRECLOC S PSORX("DFLG")=1 H 2 Q - S PSOCLC=DUZ,MSG=$S($G(MSG)]"":MSG,1:ACT_" During New RX "_$S('$G(PSONV):"Entry",1:"Verification")_" - Duplicate Rx"),REA=$S($P(PSOSD(STA,DNM),"^",2)=12:"R",1:"C") - W !!,"Duplicate "_$S($G(CLS):"Class",1:"Drug")_" will be discontinued after the acceptance of the new order.",! - S ^TMP("PSORXDC",$J,RXREC,0)="52^"_DA_"^"_MSG_"^"_REA_"^"_ACT_"^"_STA_"^"_DNM,PSONOOR="D" - K RXRECLOC,DUP,CLS,PSONOOR Q -CLS K DUP - I $E($G(PSODRUG("VA CLASS")),1,2)="HA",$E($P($G(PSOSD(STA,DNM)),"^",5),1,2)="HA" K PSOELSE Q - S CLS=1,MSG="Discontinued During "_$S('$G(PSONV):"New Prescription Entry",1:"Verification")_" - Duplicate Class" W !,PSONULN - W !?5,$C(7),"*** SAME CLASS *** OF DRUG IN RX #"_$P(^PSRX(+PSOSD(STA,DNM),0),"^")_" FOR "_$P(DNM,"^"),!,"CLASS: "_PSODRUG("VA CLASS") - S CAN=$P(PSOSD(STA,DNM),"^",2)'<11!($P(PSOSD(STA,DNM),"^",2)=1) S RXREC=+PSOSD(STA,DNM) I $P($G(PSOPAR),"^",10) D DATA Q - E W !,PSONULN K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR,DTOUT,DUOUT,DIRUT - K PSOELSE Q -ULRX ; - I '$G(RXRECLOC) Q - D PSOUL^PSSLOCK(RXRECLOC) - Q - ; +PSODRDUP ;BIR/SAB - Dup drug class checker ;11/1/04 3:38pm + ;;7.0;OUTPATIENT PHARMACY;**11,23,27,32,39,56,130,132,192,207,222,243,208**;DEC 1997;Build 39 + ; 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 + ; + ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789 + I $G(PSOAFYN)="Y" Q ;vfam No Dup Drug Check by AutoFinish,Rx - VOE + S $P(PSONULN,"-",79)="-",(STA,DNM)="" K CLS + F S STA=$O(PSOSD(STA)) Q:STA="" F S DNM=$O(PSOSD(STA,DNM)) Q:DNM=""!$G(PSORX("DFLG")) I $P(PSOSD(STA,DNM),"^")'=$G(PSORENW("OIRXN")) D Q:$G(PSORX("DFLG")) + .I STA="PENDING" D ^PSODRDU1 Q + .I STA="ZNONVA" D NVA^PSODRDU1 Q + .D:PSODRUG("NAME")=$P(DNM,"^")&('$D(^XUSEC("PSORPH",DUZ))) Q:$G(PSORX("DFLG")) + ..I $P($G(PSOPAR),"^",16) D DUP Q:$G(PSORX("DFLG")) + ..I $P(PSOPAR,"^",2),'$P($G(PSOPAR),"^",16) D DUP Q:$G(PSORX("DFLG")) + ..I '$P(PSOPAR,"^",2),'$P($G(PSOPAR),"^",16) D DUP Q:$G(PSORX("DFLG")) + .D:PSODRUG("NAME")=$P(DNM,"^")&($D(^XUSEC("PSORPH",DUZ))) DUP Q:$G(PSORX("DFLG")) + .I PSODRUG("VA CLASS")]"",$E(PSODRUG("VA CLASS"),1,4)=$E($P(PSOSD(STA,DNM),"^",5),1,4),PSODRUG("NAME")'=$P(DNM,"^") D CLS + K ^TMP($J,"DD"),^TMP($J,"DC"),^TMP($J,"DI") + D REMOTE^PSOCPDUP +EXIT D ^PSOBUILD K CAN,DA,DIR,DNM,DUPRX0,ISSD,J,LSTFL,MSG,PHYS,PSOCLC,PSONULN,REA,RFLS,RX0,RX2,RXN,RXREC,ST,Y,ZZ,ACT,PSOCLOZ,PSOLR,PSOLDT,PSOCD,SIG + Q +DUP S:$P(PSOSD(STA,DNM),"^",2)<10!($P(PSOSD(STA,DNM),"^",2)=16) DUP=1 W !,PSONULN,!,$C(7),"Duplicate Drug "_$P(DNM,"^")_" in Prescription: ",$P(^PSRX(+PSOSD(STA,DNM),0),"^") + S RXREC=+PSOSD(STA,DNM),MSG="Discontinued During "_$S('$G(PSONV):"New Prescription Entry",1:"Verification")_" - Duplicate Drug" +DATA S DUPRX0=^PSRX(RXREC,0),RFLS=$P(DUPRX0,"^",9),ISSD=$P(^PSRX(RXREC,0),"^",13),RX0=DUPRX0,RX2=^PSRX(RXREC,2),$P(RX0,"^",15)=+$G(^PSRX(RXREC,"STA")) + S RXRECLOC=$G(RXREC) + W !!,$J("Status: ",24) S J=RXREC D STAT^PSOFUNC W ST K RX0,RX2 W ?40,$J("Issued: ",24),$E(ISSD,4,5)_"/"_$E(ISSD,6,7)_"/"_$E(ISSD,2,3) + S DA=RXREC D ^PSOCMOPA I $G(PSOCMOP)]"" D K CMOP,PSOTRANS,PSOREL + .S PSOTRANS=$E($P(PSOCMOP,"^",2),4,5)_"/"_$E($P(PSOCMOP,"^",2),6,7)_"/"_$E($P(PSOCMOP,"^",2),2,3) + .S PSOREL=$S(CMOP("L")=0:$P($G(^PSRX(DA,2)),"^",13),1:$P(^PSRX(DA,1,CMOP("L"),0),"^",18)) + .S PSOREL=$E(PSOREL,4,5)_"/"_$E(PSOREL,6,7)_"/"_$E(PSOREL,2,3)_"@"_$E($P(PSOREL,".",2),1,4) + .W !,$J("CMOP Status: ",24)_$S($P(PSOCMOP,"^")=0!($P(PSOCMOP,"^")=2):"Transmitted to on "_PSOTRANS,$P(PSOCMOP,"^")=1:"Released by CMOP on "_PSOREL,1:"Not Dispensed") + K FSIG,BSIG I $P($G(^PSRX(RXREC,"SIG")),"^",2) D FSIG^PSOUTLA("R",RXREC,54) F PSREV=1:1 Q:'$D(FSIG(PSREV)) S BSIG(PSREV)=FSIG(PSREV) + K FSIG,PSREV I '$P($G(^PSRX(RXREC,"SIG")),"^",2) D EN2^PSOUTLA1(RXREC,54) + W !,$J("SIG: ",24) W $G(BSIG(1)) + I $O(BSIG(1)) F PSREV=1:0 S PSREV=$O(BSIG(PSREV)) Q:'PSREV W !?24,$G(BSIG(PSREV)) + K BSIG,PSREV + W !,$J("QTY: ",24)_$P(DUPRX0,"^",7),?40,$J("# of refills: ",24)_RFLS S PHYS=$S($D(^VA(200,+$P(DUPRX0,"^",4),0)):$P(^(0),"^"),1:"UNKNOWN") + W !,$J("Provider: ",24)_PHYS,?40,$J("Refills remaining: ",24),RFLS-$S($D(^PSRX(RXREC,1,0)):$P(^(0),"^",4),1:0) + S LSTFL=+^PSRX(RXREC,3) W !?40,$J("Last filled on: ",24)_$E(LSTFL,4,5)_"/"_$E(LSTFL,6,7)_"/"_$E(LSTFL,2,3),!?40,$J("Days Supply: ",24)_$P(DUPRX0,"^",8) + W !,PSONULN,! I $P($G(^PS(53,+$P($G(PSORX("PATIENT STATUS")),"^"),0)),"^")["AUTH ABS"!($G(PSORX("PATIENT STATUS"))["AUTH ABS")&'$P(PSOPAR,"^",5) W !,"PATIENT ON AUTHORIZED ABSENCE!" K RXRECLOC Q +ASKCAN I $P(PSOSD(STA,DNM),"^",2)>10,$P(PSOSD(STA,DNM),"^",2)'=16 K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR,DTOUT,DUOUT,DIRUT,RXRECLOC Q + I '$P(PSOPAR,"^",2),'$P(PSOPAR,"^",16),'$D(^XUSEC("PSORPH",DUZ)),'$G(CLS) S PSORX("DFLG")=1 K RXRECLOC Q + I $P(PSOPAR,"^",2),'$P(PSOPAR,"^",16),'$D(^XUSEC("PSORPH",DUZ)),'$G(CLS) S PSORX("DFLG")=1 K RXRECLOC Q + I $P(PSOSD(STA,DNM),"^",2)=16,$G(DUP) W !!,"Prescription "_$P($G(^PSRX(+$G(RXRECLOC),0)),"^")_" is on Provider Hold, it cannot be discontinued.",! K DUP,RXRECLOC S PSORX("DFLG")=1 Q + D PSOL^PSSLOCK(RXRECLOC) I '$G(PSOMSG) D K PSOMSG,DIR,DUP,RXRECLOC S DIR("A")="Press Return to continue",DIR(0)="E" D ^DIR K DIR S PSORX("DFLG")=1 Q + .I $P($G(PSOMSG),"^",2)'="" W !!,$P(PSOMSG,"^",2),! Q + .W !!,"Another person is editing Rx "_$P($G(^PSRX(RXRECLOC,0)),"^"),! + K PSOMSG S DIR("A")=$S($P(PSOSD(STA,DNM),"^",2)=12:"Reinstate",1:"Discontinue")_" RX # "_$P(^PSRX(+PSOSD(STA,DNM),0),"^"),DIR(0)="Y",DIR("?")="Enter Y to "_$S($P(PSOSD(STA,DNM),"^",2)=12:"reinstate",1:"discontinue")_" this RX." + D ^DIR K DIR S DA=RXREC S ACT=$S($D(SPCANC):"Reinstated during Rx cancel.",1:$S($P(PSOSD(STA,DNM),"^",2)=12:"Reinstated",1:"Discontinued")_" while "_$S('$G(PSONV):"entering",1:"verifying")_" new RX") + D CMOP^PSOUTL I $G(CMOP("S"))="L" W !,"A CMOP Rx cannot be discontinued during transmission!",! S Y=0 K CMOP + I 'Y W $C(7)," -Prescription was not "_$S($P(PSOSD(STA,DNM),"^",2)=12:"reinstated",1:"discontinued")_"..." D Q + .S:'$D(PSOCLC) PSOCLC=DUZ S MSG=ACT,REA=$S($P(PSOSD(STA,DNM),"^",2)=12:"R",1:"C") S:$G(DUP) PSORX("DFLG")=1 K DUP D ULRX K RXRECLOC + .I $D(^TMP("PSORXDC",$J,RXREC,0)) K ^TMP("PSORXDC",$J,RXREC,0) + I $P(PSOSD(STA,DNM),"^",2)=16,$G(CLS) W !!,"Prescription "_$P($G(^PSRX(+$G(RXRECLOC),0)),"^")_" is on Provider Hold, it cannot be discontinued.",! D ULRX K CLS,DUP,RXRECLOC S PSORX("DFLG")=1 H 2 Q + S PSOCLC=DUZ,MSG=$S($G(MSG)]"":MSG,1:ACT_" During New RX "_$S('$G(PSONV):"Entry",1:"Verification")_" - Duplicate Rx"),REA=$S($P(PSOSD(STA,DNM),"^",2)=12:"R",1:"C") + W !!,"Duplicate "_$S($G(CLS):"Class",1:"Drug")_" will be discontinued after the acceptance of the new order.",! + S ^TMP("PSORXDC",$J,RXREC,0)="52^"_DA_"^"_MSG_"^"_REA_"^"_ACT_"^"_STA_"^"_DNM,PSONOOR="D" + K RXRECLOC,DUP,CLS,PSONOOR Q +CLS K DUP + I $E($G(PSODRUG("VA CLASS")),1,2)="HA",$E($P($G(PSOSD(STA,DNM)),"^",5),1,2)="HA" K PSOELSE Q + S CLS=1,MSG="Discontinued During "_$S('$G(PSONV):"New Prescription Entry",1:"Verification")_" - Duplicate Class" W !,PSONULN + W !?5,$C(7),"*** SAME CLASS *** OF DRUG IN RX #"_$P(^PSRX(+PSOSD(STA,DNM),0),"^")_" FOR "_$P(DNM,"^"),!,"CLASS: "_PSODRUG("VA CLASS") + S CAN=$P(PSOSD(STA,DNM),"^",2)'<11!($P(PSOSD(STA,DNM),"^",2)=1) S RXREC=+PSOSD(STA,DNM) I $P($G(PSOPAR),"^",10) D DATA Q + E W !,PSONULN K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR,DTOUT,DUOUT,DIRUT + K PSOELSE Q +ULRX ; + I '$G(RXRECLOC) Q + D PSOUL^PSSLOCK(RXRECLOC) + Q + ; diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODRG.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODRG.m index 97b6ebd0..9d017590 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODRG.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODRG.m @@ -1,154 +1,154 @@ -PSODRG ;IHS/DSD/JCM-ORDER ENTRY DRUG SELECTION ;03/30/93 - ;;7.0;OUTPATIENT PHARMACY;**20,23,36,53,54,46,112,139,207,148,243,268,208**;DEC 1997;Build 41 - ; 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 - ;Reference ^PSDRUG supported by DBIA 221 - ;Reference ^PS(50.7 supported by DBIA 2223 - ;Reference to PSSDIN supported by DBIA 3166 - ;Reference to $$NDCFMT^PSSNDCUT supported by IA 4707 - ;---------------------------------------------------------- -START ; - S (PSONEW("DFLG"),PSONEW("FIELD"),PSODRG("QFLG"))=0 - D @($S(+$G(PSOEDIT)=1&('$D(DA)):"SELECT^PSODRGN",1:"SELECT")) - G:$G(PSORXED("DFLG")) END ; Select Drug - I $G(PSORX("EDIT")),$G(PSOY),$G(PSODRUG("IEN"))=+PSOY D G:$G(PSORXED("DFLG")) END - . N NDC D NDC(+$G(PSORXED("IRXN")),0,+PSOY,.NDC) I $G(NDC)="^" S PSORXED("DFLG")=1 Q - . I $G(NDC)'="" S (PSODRUG("NDC"),PSORXED("FLD",27))=NDC - ; - I $G(PSORX("EDIT"))]"",'PSONEW("FIELD") D TRADE - G:PSONEW("DFLG")!(PSODRG("QFLG"))!($G(PSORXED("DFLG"))) END - D SET ; Set various drug information - D NFI ; Display dispense drug/orderable item text - D:'$G(PSOEDIT) POST I $G(PSORX("DFLG")) S PSONEW("DFLG")=1 K:'$G(PSORX("EDIT")) PSORX("DFLG") ; Do any post selection action -END ;D EOJ - Q - ;------------------------------------------------------------ - ; -SELECT ; - K:'$G(PSORXED) CLOZPAT - K DIC,X,Y,PSODRUG("TRADE NAME"),PSODRUG("NDC"),PSODRUG("DAW") S:$G(POERR)&($P($G(OR0),"^",9)) Y=$P(^PSDRUG($P(OR0,"^",9),0),"^") - I $G(PSODRUG("IEN"))]"" S Y=PSODRUG("NAME"),PSONEW("OLD VAL")=PSODRUG("IEN") - W !,"DRUG: "_$S($G(Y)]"":Y_"// ",1:"") R X:$S($D(DTIME):DTIME,1:300) I '$T S DTOUT=1 - I X="",$G(Y)]"" S:Y X=Y S:'X X=$G(PSODRUG("IEN")) S:X X="`"_X - G:X="" SELECT - I X?1."?" W !!,"Answer with DRUG NUMBER, or GENERIC NAME, or VA PRODUCT NAME, or",!,"NATIONAL DRUG CLASS, or SYNONYM" G SELECT - I $G(PSORXED),X["^" S PSORXED("DFLG")=1 G SELECTX - I X="^"!(X["^^")!($D(DTOUT)) S PSONEW("DFLG")=1 G SELECTX - I '$G(POERR),X[U,$L(X)>1 S PSODIR("FLD")=PSONEW("FLD") D JUMP^PSODIR1 S:$G(PSODIR("FIELD")) PSONEW("FIELD")=PSODIR("FIELD") K PSODIR S PSODRG("QFLG")=1 G SELECTX - S DIC=50,DIC(0)="EMQZVT",DIC("T")="",D="B^C^VAPN^VAC" - S DIC("S")="I $S('$D(^PSDRUG(+Y,""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:0),$S($P($G(^PSDRUG(+Y,2)),""^"",3)'[""O"":0,1:1),$D(^PSDRUG(""ASP"",+$G(^(2)),+Y))" - D MIX^DIC1 K DIC,D - I $D(DTOUT) S PSONEW("DFLG")=1 G SELECTX - I $D(DUOUT) K DUOUT G SELECT - I Y<0 G SELECT - S:$G(PSONEW("OLD VAL"))=+Y&('$G(PSOEDIT)) PSODRG("QFLG")=1 - K PSOY S PSOY=Y,PSOY(0)=Y(0) - I $P(PSOY(0),"^")="OTHER DRUG"!($P(PSOY(0),"^")="OUTSIDE DRUG") D TRADE -SELECTX K X,Y,DTOUT,DUOUT,PSONEW("OLD VAL") - Q - ; -NDC(RX,RFL,DRG,NDC) ; Editing NDC for ECME Released Rx's - S NDC=$S($G(NDC)'="":$G(NDC),1:$$GETNDC^PSONDCUT(RX,.RFL)) - I $$STATUS^PSOBPSUT(RX,RFL)="" Q - I '$$RXRLDT^PSOBPSUT(RX,RFL) Q - ; - S NDC=$S($G(NDC)'="":$G(NDC),1:$$GETNDC^PSONDCUT(RX,.RFL)) - D NDCEDT^PSONDCUT(RX,.RFL,$G(DRG),$G(PSOSITE),.NDC) - Q - ; -TRADE ; - K DIR,DIC,DA,X,Y - S DIR(0)="52,6.5" S:$G(PSOTRN)]"" DIR("B")=$G(PSOTRN) D ^DIR K DIR,DIC - I X="@" S Y=X K DIRUT - I $D(DIRUT) S:$D(DUOUT)!$D(DTOUT)&('$D(PSORX("EDIT"))) PSONEW("DFLG")=1 G TRADEX - S PSODRUG("TRADE NAME")=Y -TRADEX I $G(PSORXED("DFLG")),$D(DIRUT) S PSORXED("DFLG")=1 - K DIRUT,DTOUT,DUOUT,X,Y,DA,DR,DIE - Q -SET ; - N STAT S PSODRUG("IEN")=+PSOY,PSODRUG("VA CLASS")=$P(PSOY(0),"^",2) - S PSODRUG("NAME")=$P(PSOY(0),"^") - S:+$G(^PSDRUG(+PSOY,2)) PSODRUG("OI")=+$G(^(2)),PSODRUG("OIN")=$P(^PS(50.7,+$G(^(2)),0),"^") - S PSODRUG("NDF")=$S($G(^PSDRUG(+PSOY,"ND"))]"":+^("ND")_"A"_$P(^("ND"),"^",3),1:0) - S PSODRUG("MAXDOSE")=$P(PSOY(0),"^",4),PSODRUG("DEA")=$P(PSOY(0),"^",3) - S PSODRUG("CLN")=$S($D(^PSDRUG(+PSOY,"ND")):+$P(^("ND"),"^",6),1:0) - S PSODRUG("SIG")=$P(PSOY(0),"^",5) - I $G(PSODRUG("NDC"))="" S PSODRUG("NDC")=$$GETNDC^PSSNDCUT(+PSOY,$G(PSOSITE)) - S PSODRUG("DAW")=+$$GET1^DIQ(50,+PSOY,81) - S PSODRUG("STKLVL")=$G(^PSDRUG(+PSOY,660.1)) - G:$G(^PSDRUG(+PSOY,660))']"" SETX - S PSOX1=$G(^PSDRUG(+PSOY,660)) - S PSODRUG("COST")=$P($G(PSOX1),"^",6) - S PSODRUG("UNIT")=$P($G(PSOX1),"^",8) - S PSODRUG("EXPIRATION DATE")=$P($G(PSOX1),"^",9) -SETX K PSOX1,PSOY - Q -NFI ;display restriction/guidelines - D EN^PSSDIN(PSODRUG("OI"),PSODRUG("IEN")) S NFI=$$PROMPT^PSSDIN - I NFI]"","ODY"[NFI D TD^PSONFI - K NFI Q -POST ;order checks - I $G(PSOAFYN)="Y" G POSTX ;vfam - VOE - K PSORX("INTERVENE") N STAT,SIG,PTR,NDF,VAP S PSORX("DFLG")=0 - D ^PSOBUILD - D @$S($G(COPY):"^PSOCPDUP",1:"^PSODRDUP") ; Set PSORX("DFLG")=1 if process to stop - Q:$G(PSORX("DFLG")) - W:$G(PSOFIN)']"" !,"Now doing drug interaction and allergy checks. Please wait...",! - D ^PSODGDGI - I $G(PSORX("INTERVENE"))]"" D FULL^VALM1,^PSORXI S VALMBCK="R" - G:PSORX("DFLG") POSTX - D:$P($G(^PSDRUG(PSODRUG("IEN"),"CLOZ1")),"^")]"" CLOZ G:PSORX("DFLG") POSTX - K PSORX("INTERVENE") - S PSONOAL="" D ALLERGY^PSOORUT2 D:PSONOAL'="" NOALRGY K PSONOAL - G:PSORX("DFLG") POSTX - I $D(PSODRUG("NDF")) S NDF=$P(PSODRUG("NDF"),"A"),VAP=$P(PSODRUG("NDF"),"A",2),PTR=NDF_"."_VAP - I $G(NDF) D CHK^PSODGAL(PSODFN,"DR",PTR) K NDF,VAP,PTR - I $P($G(PSODRUG("NDF")),"A")=0 D CHK1^PSODGAL(PSODFN) - I $D(PSODRUG("VA CLASS")) D CLASS^PSODGAL(PSODFN) -POSTX ; - K ^TMP($J,"DI"_PSODFN),^TMP($J,"DI") - K PSORX("INTERVENE"),DA - Q - ; -EOJ ; - K PSODRG - Q - ; -CLOZ ; - S ANQRTN=$P(^PSDRUG(PSODRUG("IEN"),"CLOZ1"),"^"),ANQX=0 - S P(5)=PSODRUG("IEN"),DFN=PSODFN,X=ANQRTN - X ^%ZOSF("TEST") I D @("^"_ANQRTN) S:$G(ANQX) PSORX("DFLG")=1 - K P(5),ANQRTN,ANQX,X - Q - ; -EN(DRG) ;returns lab test identified for clozapine order checking - K LAB I $P($G(^PSDRUG(DRG,"CLOZ1")),"^")'="PSOCLO1" S LAB("NOT")=0 Q - I $P($G(^PSDRUG(DRG,"CLOZ1")),"^")="PSOCLO1" D - .S (CNT,I)=0 F S I=$O(^PSDRUG(DRG,"CLOZ2",I)) Q:'I S CNT=$G(CNT)+1 - .I CNT'=2 S LAB("BAD TEST")=0 K CNT Q - .K CNT F I=0:0 S I=$O(^PSDRUG(DRG,"CLOZ2",I)) Q:'I D - ..S LABT=$S($P(^PSDRUG(DRG,"CLOZ2",I,0),"^",4)=1:"WBC",1:"ANC"),LAB(LABT)=$P(^PSDRUG(DRG,"CLOZ2",I,0),"^")_"^"_$P(^(0),"^",3)_"^"_$P(^(0),"^",4) - K LABT,I - Q -NOALRGY ; - W $C(7),!,"There is no allergy assessment on file for this patient." - W !,"You will be prompted to intervene if you continue with this prescription" - K DIR - S DIR(0)="SA^1:YES;0:NO",DIR("A")="Do you want to Continue?: ",DIR("B")="N" D ^DIR - I 'Y S PSORX("DFLG")=1 Q - D ^PSORXI - Q +PSODRG ;IHS/DSD/JCM-ORDER ENTRY DRUG SELECTION ;03/30/93 + ;;7.0;OUTPATIENT PHARMACY;**20,23,36,53,54,46,112,139,207,148,243,268,208**;DEC 1997;Build 39 + ; 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 + ;Reference ^PSDRUG supported by DBIA 221 + ;Reference ^PS(50.7 supported by DBIA 2223 + ;Reference to PSSDIN supported by DBIA 3166 + ;Reference to $$NDCFMT^PSSNDCUT supported by IA 4707 + ;---------------------------------------------------------- +START ; + S (PSONEW("DFLG"),PSONEW("FIELD"),PSODRG("QFLG"))=0 + D @($S(+$G(PSOEDIT)=1&('$D(DA)):"SELECT^PSODRGN",1:"SELECT")) + G:$G(PSORXED("DFLG")) END ; Select Drug + I $G(PSORX("EDIT")),$G(PSOY),$G(PSODRUG("IEN"))=+PSOY D G:$G(PSORXED("DFLG")) END + . N NDC D NDC(+$G(PSORXED("IRXN")),0,+PSOY,.NDC) I $G(NDC)="^" S PSORXED("DFLG")=1 Q + . I $G(NDC)'="" S (PSODRUG("NDC"),PSORXED("FLD",27))=NDC + ; + I $G(PSORX("EDIT"))]"",'PSONEW("FIELD") D TRADE + G:PSONEW("DFLG")!(PSODRG("QFLG"))!($G(PSORXED("DFLG"))) END + D SET ; Set various drug information + D NFI ; Display dispense drug/orderable item text + D:'$G(PSOEDIT) POST I $G(PSORX("DFLG")) S PSONEW("DFLG")=1 K:'$G(PSORX("EDIT")) PSORX("DFLG") ; Do any post selection action +END ;D EOJ + Q + ;------------------------------------------------------------ + ; +SELECT ; + K:'$G(PSORXED) CLOZPAT + K DIC,X,Y,PSODRUG("TRADE NAME"),PSODRUG("NDC"),PSODRUG("DAW") S:$G(POERR)&($P($G(OR0),"^",9)) Y=$P(^PSDRUG($P(OR0,"^",9),0),"^") + I $G(PSODRUG("IEN"))]"" S Y=PSODRUG("NAME"),PSONEW("OLD VAL")=PSODRUG("IEN") + W !,"DRUG: "_$S($G(Y)]"":Y_"// ",1:"") R X:$S($D(DTIME):DTIME,1:300) I '$T S DTOUT=1 + I X="",$G(Y)]"" S:Y X=Y S:'X X=$G(PSODRUG("IEN")) S:X X="`"_X + G:X="" SELECT + I X?1."?" W !!,"Answer with DRUG NUMBER, or GENERIC NAME, or VA PRODUCT NAME, or",!,"NATIONAL DRUG CLASS, or SYNONYM" G SELECT + I $G(PSORXED),X["^" S PSORXED("DFLG")=1 G SELECTX + I X="^"!(X["^^")!($D(DTOUT)) S PSONEW("DFLG")=1 G SELECTX + I '$G(POERR),X[U,$L(X)>1 S PSODIR("FLD")=PSONEW("FLD") D JUMP^PSODIR1 S:$G(PSODIR("FIELD")) PSONEW("FIELD")=PSODIR("FIELD") K PSODIR S PSODRG("QFLG")=1 G SELECTX + S DIC=50,DIC(0)="EMQZVT",DIC("T")="",D="B^C^VAPN^VAC" + S DIC("S")="I $S('$D(^PSDRUG(+Y,""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:0),$S($P($G(^PSDRUG(+Y,2)),""^"",3)'[""O"":0,1:1),$D(^PSDRUG(""ASP"",+$G(^(2)),+Y))" + D MIX^DIC1 K DIC,D + I $D(DTOUT) S PSONEW("DFLG")=1 G SELECTX + I $D(DUOUT) K DUOUT G SELECT + I Y<0 G SELECT + S:$G(PSONEW("OLD VAL"))=+Y&('$G(PSOEDIT)) PSODRG("QFLG")=1 + K PSOY S PSOY=Y,PSOY(0)=Y(0) + I $P(PSOY(0),"^")="OTHER DRUG"!($P(PSOY(0),"^")="OUTSIDE DRUG") D TRADE +SELECTX K X,Y,DTOUT,DUOUT,PSONEW("OLD VAL") + Q + ; +NDC(RX,RFL,DRG,NDC) ; Editing NDC for ECME Released Rx's + S NDC=$S($G(NDC)'="":$G(NDC),1:$$GETNDC^PSONDCUT(RX,.RFL)) + I $$STATUS^PSOBPSUT(RX,RFL)="" Q + I '$$RXRLDT^PSOBPSUT(RX,RFL) Q + ; + S NDC=$S($G(NDC)'="":$G(NDC),1:$$GETNDC^PSONDCUT(RX,.RFL)) + D NDCEDT^PSONDCUT(RX,.RFL,$G(DRG),$G(PSOSITE),.NDC) + Q + ; +TRADE ; + K DIR,DIC,DA,X,Y + S DIR(0)="52,6.5" S:$G(PSOTRN)]"" DIR("B")=$G(PSOTRN) D ^DIR K DIR,DIC + I X="@" S Y=X K DIRUT + I $D(DIRUT) S:$D(DUOUT)!$D(DTOUT)&('$D(PSORX("EDIT"))) PSONEW("DFLG")=1 G TRADEX + S PSODRUG("TRADE NAME")=Y +TRADEX I $G(PSORXED("DFLG")),$D(DIRUT) S PSORXED("DFLG")=1 + K DIRUT,DTOUT,DUOUT,X,Y,DA,DR,DIE + Q +SET ; + N STAT S PSODRUG("IEN")=+PSOY,PSODRUG("VA CLASS")=$P(PSOY(0),"^",2) + S PSODRUG("NAME")=$P(PSOY(0),"^") + S:+$G(^PSDRUG(+PSOY,2)) PSODRUG("OI")=+$G(^(2)),PSODRUG("OIN")=$P(^PS(50.7,+$G(^(2)),0),"^") + S PSODRUG("NDF")=$S($G(^PSDRUG(+PSOY,"ND"))]"":+^("ND")_"A"_$P(^("ND"),"^",3),1:0) + S PSODRUG("MAXDOSE")=$P(PSOY(0),"^",4),PSODRUG("DEA")=$P(PSOY(0),"^",3) + S PSODRUG("CLN")=$S($D(^PSDRUG(+PSOY,"ND")):+$P(^("ND"),"^",6),1:0) + S PSODRUG("SIG")=$P(PSOY(0),"^",5) + I $G(PSODRUG("NDC"))="" S PSODRUG("NDC")=$$GETNDC^PSSNDCUT(+PSOY,$G(PSOSITE)) + S PSODRUG("DAW")=+$$GET1^DIQ(50,+PSOY,81) + S PSODRUG("STKLVL")=$G(^PSDRUG(+PSOY,660.1)) + G:$G(^PSDRUG(+PSOY,660))']"" SETX + S PSOX1=$G(^PSDRUG(+PSOY,660)) + S PSODRUG("COST")=$P($G(PSOX1),"^",6) + S PSODRUG("UNIT")=$P($G(PSOX1),"^",8) + S PSODRUG("EXPIRATION DATE")=$P($G(PSOX1),"^",9) +SETX K PSOX1,PSOY + Q +NFI ;display restriction/guidelines + D EN^PSSDIN(PSODRUG("OI"),PSODRUG("IEN")) S NFI=$$PROMPT^PSSDIN + I NFI]"","ODY"[NFI D TD^PSONFI + K NFI Q +POST ;order checks + I $G(PSOAFYN)="Y" G POSTX ;vfam - VOE + K PSORX("INTERVENE") N STAT,SIG,PTR,NDF,VAP S PSORX("DFLG")=0 + D ^PSOBUILD + D @$S($G(COPY):"^PSOCPDUP",1:"^PSODRDUP") ; Set PSORX("DFLG")=1 if process to stop + Q:$G(PSORX("DFLG")) + W:$G(PSOFIN)']"" !,"Now doing drug interaction and allergy checks. Please wait...",! + D ^PSODGDGI + I $G(PSORX("INTERVENE"))]"" D FULL^VALM1,^PSORXI S VALMBCK="R" + G:PSORX("DFLG") POSTX + D:$P($G(^PSDRUG(PSODRUG("IEN"),"CLOZ1")),"^")]"" CLOZ G:PSORX("DFLG") POSTX + K PSORX("INTERVENE") + S PSONOAL="" D ALLERGY^PSOORUT2 D:PSONOAL'="" NOALRGY K PSONOAL + G:PSORX("DFLG") POSTX + I $D(PSODRUG("NDF")) S NDF=$P(PSODRUG("NDF"),"A"),VAP=$P(PSODRUG("NDF"),"A",2),PTR=NDF_"."_VAP + I $G(NDF) D CHK^PSODGAL(PSODFN,"DR",PTR) K NDF,VAP,PTR + I $P($G(PSODRUG("NDF")),"A")=0 D CHK1^PSODGAL(PSODFN) + I $D(PSODRUG("VA CLASS")) D CLASS^PSODGAL(PSODFN) +POSTX ; + K ^TMP($J,"DI"_PSODFN),^TMP($J,"DI") + K PSORX("INTERVENE"),DA + Q + ; +EOJ ; + K PSODRG + Q + ; +CLOZ ; + S ANQRTN=$P(^PSDRUG(PSODRUG("IEN"),"CLOZ1"),"^"),ANQX=0 + S P(5)=PSODRUG("IEN"),DFN=PSODFN,X=ANQRTN + X ^%ZOSF("TEST") I D @("^"_ANQRTN) S:$G(ANQX) PSORX("DFLG")=1 + K P(5),ANQRTN,ANQX,X + Q + ; +EN(DRG) ;returns lab test identified for clozapine order checking + K LAB I $P($G(^PSDRUG(DRG,"CLOZ1")),"^")'="PSOCLO1" S LAB("NOT")=0 Q + I $P($G(^PSDRUG(DRG,"CLOZ1")),"^")="PSOCLO1" D + .S (CNT,I)=0 F S I=$O(^PSDRUG(DRG,"CLOZ2",I)) Q:'I S CNT=$G(CNT)+1 + .I CNT'=2 S LAB("BAD TEST")=0 K CNT Q + .K CNT F I=0:0 S I=$O(^PSDRUG(DRG,"CLOZ2",I)) Q:'I D + ..S LABT=$S($P(^PSDRUG(DRG,"CLOZ2",I,0),"^",4)=1:"WBC",1:"ANC"),LAB(LABT)=$P(^PSDRUG(DRG,"CLOZ2",I,0),"^")_"^"_$P(^(0),"^",3)_"^"_$P(^(0),"^",4) + K LABT,I + Q +NOALRGY ; + W $C(7),!,"There is no allergy assessment on file for this patient." + W !,"You will be prompted to intervene if you continue with this prescription" + K DIR + S DIR(0)="SA^1:YES;0:NO",DIR("A")="Do you want to Continue?: ",DIR("B")="N" D ^DIR + I 'Y S PSORX("DFLG")=1 Q + D ^PSORXI + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHELP.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHELP.m index 37597d7c..c5f44b85 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHELP.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHELP.m @@ -1,111 +1,111 @@ -PSOHELP ;BHAM ISC/SAB-outpatient utility routine ; 10/17/07 7:41am - ;;7.0;OUTPATIENT PHARMACY;**3,23,29,48,46,117,131,222,268,206**;DEC 1997;Build 39 - ;External reference ^PS(51 supported by DBIA 2224 - ;External reference ^PSDRUG( supported by DBIA 221 - ;External reference ^PS(56 supported by DBIA 2229 - ;External reference ^PSNPPIP supported by DBIA 2261 - ; -XREF D XREF^PSOHELP3 - Q -SIG ;checks PI for RXs - K VALMSG - I $E(X)=" " D EN^DDIOL("Leading spaces should not entered in the Patient Instructions! ","","$C(7),!") S VALMSG="There are leading spaces in Patient Instructions!" -SIGONE K INS1 Q:$L(X)<1 F Z0=1:1:$L(X," ") G:Z0="" EN S Z1=$P(X," ",Z0) D G:'$D(X) EN - .I $L(Z1)>32 W $C(7),!?5,"MAX OF 32 CHARACTERS ALLOWED BETWEEN SPACES.",! K X Q - .D:$D(X)&($G(Z1)]"") S INS1=$G(INS1)_" "_Z1 - ..S Y=$O(^PS(51,"B",Z1,0)) Q:'Y!($P($G(^PS(51,+Y,0)),"^",4)>1) S Z1=$P(^PS(51,Y,0),"^",2) - ..I $G(^PS(51,+Y,9))]"" S Y=$P(X," ",Z0-1),Y=$E(Y,$L(Y)) S:Y>1 Z1=^(9) -EN K Z1,Z0 - Q -SSIG ;other lang. mods - K VALMSG - I $E(X)=" " D EN^DDIOL("Leading spaces should not entered in the Patient Instructions! ","","$C(7),!") S VALMSG="There are leading spaces in Patient Instructions!" - K SINS1 Q:$L(X)<1 F Z0=1:1:$L(X," ") G:Z0="" EX S Z1=$P(X," ",Z0) D G:'$D(X) EX - .I $L(Z1)>32 W $C(7),!?5,"MAX OF 32 CHARACTERS ALLOWED BETWEEN SPACES.",! K X Q - .D:$D(X)&($G(Z1)]"") S SINS1=$G(SINS1)_" "_Z1 - ..S Y=$O(^PS(51,"B",Z1,0)) Q:'Y S Z1=$P(^PS(51,Y,0),"^",2) - ..I $G(^PS(51,+Y,4))]"" S Z1=^PS(51,+Y,4) ;,Y=$P(X," ",Z0-1),Y=$E(Y,$L(Y)) S:Y>1 Z1=^(9) -EX K Z1,Z0 - Q -QTY ;Check quantity dispensed against inventory - Q:'$G(PSODRUG("IEN")) - S Z0=$S($G(PSODRUG("IEN"))]"":PSODRUG("IEN"),$G(PSXYES):$P(^PSRX(ZRX,0),"^",6),$D(^PSRX(DA,0)):+$P(^(0),"^",6),1:0) - I $D(^PSDRUG("AQ",Z0)),(+X'=X) K X,Z0 Q - S Z1=$S($D(^PSDRUG(Z0,660.1)):^(660.1),1:0)+(+X) D:X>Z1 EN^DDIOL(" Greater Than Current Inventory!","","$C(7)") K Z1 - S ZX=X,ZZ0=$G(D0),D0=Z0 - S Y(18,2)=$S($D(^PSDRUG(D0,660)):^(660),1:""),Y(18,1)=$S($D(^(660.1)):^(660.1),1:"") - S X=$P(Y(18,1),"^",1),X=$S($P(Y(18,2),"^",5):X/$P(Y(18,2),"^",5),1:"*******") - S X=$J(X,0,2) - D:X<$S($D(^PSDRUG(Z0,660)):+^(660),1:1) EN^DDIOL(" Below Reorder Level.","","$C(7)") S X=ZX,D0=$G(ZZ0) K ZZ0,Z0,ZX - Q -HELP ;qty help - G:$G(PSOFDR) HLP - S Z0=$S($G(PSODRUG("IEN"))]"":PSODRUG("IEN"),$G(PSXYES):$P(^PSRX(ZRX,0),"^",6),$D(^PSRX(DA,0)):$P(^PSRX(DA,0),"^",6),1:0) -HLP S Z0=+$G(PSODRUG("IEN")) I $D(^PSDRUG("AQ",Z0)) D EN^DDIOL("This is a CMOP drug. The quantity may not contain alpha characters (i.e.; ML)","","!!") D EN^DDIOL("or more than two fractional decimal places (i.e.; .01).","","!") D K Z0 Q - .D EN^DDIOL("Enter a number between 0 and 99999999 inclusive. The total entry cannot","","!") D EN^DDIOL("exceed 11 characters.","","!") - D EN^DDIOL("Enter a whole number between 0 and 99999999 inclusive. Alpha characters are","","!!") - D EN^DDIOL("not allowed, and the entry cannot exceed 11 characters, or contain more than","","!") D EN^DDIOL("two fractional decimal places (i.e.; .01).","","!") - K Z0 - Q -ADD ;add/edited local drug/drug interactions - W ! S DIC("A")="Select Drug Interaction: ",DIC(0)="AEMQL",DLAYGO=56 - S (DIC,DIE)="^PS(56,",DIC("S")="I '$P(^(0),""^"",5)" D ^DIC G:"^"[X QU G:Y<0 ADD S DA=+Y,DR="[PSO INTERACT]" L +^PS(56,DA):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T W !,"Entry is being edited by another user. Try Later!",! G ADD - D ^DIE L:$G(DA) -^PS(56,DA) K DA G ADD -QU L -^PS(56,DA) K X,DIC,DIE,DA - Q -CRI ;change drug interaction severity to critical from significant - W ! S DIC("A")="Select Drug Interaction: ",DIC(0)="AEQM",(DIC,DIE)="^PS(56,",DIC("S")="I $P(^(0),""^"",4)=2" D ^DIC G:"^"[X QU G:Y<0 CRI S DA=+Y,DR=3 - L +^PS(56,DA):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T W !,"Entry is being edited by another user. Try Later!",! G CRI - D ^DIE L -^PS(56,DA) K DA G CRI - G QU - Q -MAX S:$G(EXH) P(7)=$P(^PSRX(DA,0),"^",8),P(5)=$P(^(0),"^",6),P(2)=+$P(^(0),"^",3) S:P(2) PTST=$G(^PS(53,P(2),0)),PTDY=$P($G(^(0)),"^",3),PTRF=$P($G(^(0)),"^",4) - S PSODEA=$P(^PSDRUG(P(5),0),"^",3),CS=0 - I $D(CLOZPAT) S MAX=$S(CLOZPAT=2&($P(^PSRX(DA,0),"^",8)=14):1,CLOZPAT=2&($P(^PSRX(DA,0),"^",8)=7):3,CLOZPAT=1&($P(^PSRX(DA,0),"^",8)=7):1,1:0),MIN=0 Q - I PSODEA["A"&(PSODEA'["B")!(PSODEA["F")!(PSODEA[1)!(PSODEA[2) D EN^DDIOL("No refills allowed on "_$S(PSODEA["A":"this narcotic drug.",1:"this drug."),"","!") D EN^DDIOL(" ","","!") S $P(^PSRX(DA,0),"^",9)=0 K X,Y,PSODEA,CS,PTST Q - F DEA=1:1 Q:$E(PSODEA,DEA)="" I $E(+PSODEA,DEA)>1,$E(+PSODEA,DEA)<6 S CS=1 - S PSOELSE=CS I PSOELSE D - .S PSOX1=$S(PTRF>5:5,1:PTRF),PSOT=$S(PSOX1=5:5,1:PSOX1) - .S PSOT=$S('PSOT:0,P(7)=90:1,1:PSOT),PSDY1=$S(P(7)<60:5,P(7)'<60&(P(7)'>89):2,P(7)=90:1,1:0) S MAX=$S(PSOT'>PSDY1:PSOT,1:PSDY1) - I 'PSOELSE D - .S PSOX1=PTRF,PSOT=$S(PSOX1=11:11,1:PSOX1),PSOT=$S('PSOT:0,P(7)=90:3,1:PSOT) - .S PSDY1=$S(P(7)<60:11,P(7)'<60&(P(7)'>89):5,P(7)=90:3,1:0) S MAX=$S(PSOT'>PSDY1:PSOT,1:PSDY1) - K PSODEA,PSOELSE,PSOT,PSOX1,PSDY,PSDY1,DEA,CS - I $D(X) S MIN=0 I $D(DA) F REF=0:0 S REF=$O(^PSRX(DA,1,REF)) Q:'REF I $D(^(REF,0)) S MIN=MIN+1 - I $G(EXH) D EN^DDIOL("Enter a number Between "_MIN_" AND "_MAX_".","","!?10") K P(2),P(5),P(7),MAX,MAX1,MIN,REF - Q - ; -REF S PSRF=X,P(7)=$P(^PSRX(DA,0),"^",8),P(5)=$P(^(0),"^",6),P(2)=+$P(^(0),"^",3) S:P(2) PTST=$G(^PS(53,P(2),0)) S PTDY=$P(^(0),"^",3),PTRF=$P(^(0),"^",4) - D MAX Q:'$D(X) I (+X'=X)!(X<0)!(X>MAX)!(X?.E1"."1N.N) D EN^DDIOL(" ** MAX REFILLS ALLOWED ARE "_MAX_" ** ","","$C(7)") K X - I $D(X),X32 W $C(7),!?5,"MAX OF 32 CHARACTERS ALLOWED BETWEEN SPACES.",! K X Q + .D:$D(X)&($G(Z1)]"") S INS1=$G(INS1)_" "_Z1 + ..S Y=$O(^PS(51,"B",Z1,0)) Q:'Y!($P($G(^PS(51,+Y,0)),"^",4)>1) S Z1=$P(^PS(51,Y,0),"^",2) + ..I $G(^PS(51,+Y,9))]"" S Y=$P(X," ",Z0-1),Y=$E(Y,$L(Y)) S:Y>1 Z1=^(9) +EN K Z1,Z0 + Q +SSIG ;other lang. mods + K VALMSG + I $E(X)=" " D EN^DDIOL("Leading spaces should not entered in the Patient Instructions! ","","$C(7),!") S VALMSG="There are leading spaces in Patient Instructions!" + K SINS1 Q:$L(X)<1 F Z0=1:1:$L(X," ") G:Z0="" EX S Z1=$P(X," ",Z0) D G:'$D(X) EX + .I $L(Z1)>32 W $C(7),!?5,"MAX OF 32 CHARACTERS ALLOWED BETWEEN SPACES.",! K X Q + .D:$D(X)&($G(Z1)]"") S SINS1=$G(SINS1)_" "_Z1 + ..S Y=$O(^PS(51,"B",Z1,0)) Q:'Y S Z1=$P(^PS(51,Y,0),"^",2) + ..I $G(^PS(51,+Y,4))]"" S Z1=^PS(51,+Y,4) ;,Y=$P(X," ",Z0-1),Y=$E(Y,$L(Y)) S:Y>1 Z1=^(9) +EX K Z1,Z0 + Q +QTY ;Check quantity dispensed against inventory + Q:'$G(PSODRUG("IEN")) + S Z0=$S($G(PSODRUG("IEN"))]"":PSODRUG("IEN"),$G(PSXYES):$P(^PSRX(ZRX,0),"^",6),$D(^PSRX(DA,0)):+$P(^(0),"^",6),1:0) + I $D(^PSDRUG("AQ",Z0)),(+X'=X) K X,Z0 Q + S Z1=$S($D(^PSDRUG(Z0,660.1)):^(660.1),1:0)+(+X) D:X>Z1 EN^DDIOL(" Greater Than Current Inventory!","","$C(7)") K Z1 + S ZX=X,ZZ0=$G(D0),D0=Z0 + S Y(18,2)=$S($D(^PSDRUG(D0,660)):^(660),1:""),Y(18,1)=$S($D(^(660.1)):^(660.1),1:"") + S X=$P(Y(18,1),"^",1),X=$S($P(Y(18,2),"^",5):X/$P(Y(18,2),"^",5),1:"*******") + S X=$J(X,0,2) + D:X<$S($D(^PSDRUG(Z0,660)):+^(660),1:1) EN^DDIOL(" Below Reorder Level.","","$C(7)") S X=ZX,D0=$G(ZZ0) K ZZ0,Z0,ZX + Q +HELP ;qty help + G:$G(PSOFDR) HLP + S Z0=$S($G(PSODRUG("IEN"))]"":PSODRUG("IEN"),$G(PSXYES):$P(^PSRX(ZRX,0),"^",6),$D(^PSRX(DA,0)):$P(^PSRX(DA,0),"^",6),1:0) +HLP S Z0=+$G(PSODRUG("IEN")) I $D(^PSDRUG("AQ",Z0)) D EN^DDIOL("This is a CMOP drug. The quantity may not contain alpha characters (i.e.; ML)","","!!") D EN^DDIOL("or more than two fractional decimal places (i.e.; .01).","","!") D K Z0 Q + .D EN^DDIOL("Enter a number between 0 and 99999999 inclusive. The total entry cannot","","!") D EN^DDIOL("exceed 11 characters.","","!") + D EN^DDIOL("Enter a whole number between 0 and 99999999 inclusive. Alpha characters are","","!!") + D EN^DDIOL("not allowed, and the entry cannot exceed 11 characters, or contain more than","","!") D EN^DDIOL("two fractional decimal places (i.e.; .01).","","!") + K Z0 + Q +ADD ;add/edited local drug/drug interactions + W ! S DIC("A")="Select Drug Interaction: ",DIC(0)="AEMQL",DLAYGO=56 + S (DIC,DIE)="^PS(56,",DIC("S")="I '$P(^(0),""^"",5)" D ^DIC G:"^"[X QU G:Y<0 ADD S DA=+Y,DR="[PSO INTERACT]" L +^PS(56,DA):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T W !,"Entry is being edited by another user. Try Later!",! G ADD + D ^DIE L:$G(DA) -^PS(56,DA) K DA G ADD +QU L -^PS(56,DA) K X,DIC,DIE,DA + Q +CRI ;change drug interaction severity to critical from significant + W ! S DIC("A")="Select Drug Interaction: ",DIC(0)="AEQM",(DIC,DIE)="^PS(56,",DIC("S")="I $P(^(0),""^"",4)=2" D ^DIC G:"^"[X QU G:Y<0 CRI S DA=+Y,DR=3 + L +^PS(56,DA):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T W !,"Entry is being edited by another user. Try Later!",! G CRI + D ^DIE L -^PS(56,DA) K DA G CRI + G QU + Q +MAX S:$G(EXH) P(7)=$P(^PSRX(DA,0),"^",8),P(5)=$P(^(0),"^",6),P(2)=+$P(^(0),"^",3) S:P(2) PTST=$G(^PS(53,P(2),0)),PTDY=$P($G(^(0)),"^",3),PTRF=$P($G(^(0)),"^",4) + S PSODEA=$P(^PSDRUG(P(5),0),"^",3),CS=0 + I $D(CLOZPAT) S MAX=$S(CLOZPAT=2&($P(^PSRX(DA,0),"^",8)=14):1,CLOZPAT=2&($P(^PSRX(DA,0),"^",8)=7):3,CLOZPAT=1&($P(^PSRX(DA,0),"^",8)=7):1,1:0),MIN=0 Q + I PSODEA["A"&(PSODEA'["B")!(PSODEA["F") D EN^DDIOL("No refills allowed on "_$S(PSODEA["F":"this drug.",1:"Narcotics .."),"","!") D EN^DDIOL(" ","","!") S $P(^PSRX(DA,0),"^",9)=0 K X,Y,PSODEA,CS,PTST Q + F DEA=1:1 Q:$E(PSODEA,DEA)="" I $E(+PSODEA,DEA)>1,$E(+PSODEA,DEA)<6 S CS=1 + S PSOELSE=CS I PSOELSE D + .S PSOX1=$S(PTRF>5:5,1:PTRF),PSOT=$S(PSOX1=5:5,1:PSOX1) + .S PSOT=$S('PSOT:0,P(7)=90:1,1:PSOT),PSDY1=$S(P(7)<60:5,P(7)'<60&(P(7)'>89):2,P(7)=90:1,1:0) S MAX=$S(PSOT'>PSDY1:PSOT,1:PSDY1) + I 'PSOELSE D + .S PSOX1=PTRF,PSOT=$S(PSOX1=11:11,1:PSOX1),PSOT=$S('PSOT:0,P(7)=90:3,1:PSOT) + .S PSDY1=$S(P(7)<60:11,P(7)'<60&(P(7)'>89):5,P(7)=90:3,1:0) S MAX=$S(PSOT'>PSDY1:PSOT,1:PSDY1) + K PSODEA,PSOELSE,PSOT,PSOX1,PSDY,PSDY1,DEA,CS + I $D(X) S MIN=0 I $D(DA) F REF=0:0 S REF=$O(^PSRX(DA,1,REF)) Q:'REF I $D(^(REF,0)) S MIN=MIN+1 + I $G(EXH) D EN^DDIOL("Enter a number Between "_MIN_" AND "_MAX_".","","!?10") K P(2),P(5),P(7),MAX,MAX1,MIN,REF + Q + ; +REF S PSRF=X,P(7)=$P(^PSRX(DA,0),"^",8),P(5)=$P(^(0),"^",6),P(2)=+$P(^(0),"^",3) S:P(2) PTST=$G(^PS(53,P(2),0)) S PTDY=$P(^(0),"^",3),PTRF=$P(^(0),"^",4) + D MAX Q:'$D(X) I (+X'=X)!(X<0)!(X>MAX)!(X?.E1"."1N.N) D EN^DDIOL(" ** MAX REFILLS ALLOWED ARE "_MAX_" ** ","","$C(7)") K X + I $D(X),X(DT-1) S PSOFUTR=1 D - .W !!,"Since you selected an end fill date of today or in the future, this option" - .W !,"will update the cost for all existing and suspended fills that have a" - .W !,"fill date in the future.",! - K DIR,X,Y S DIR(0)="Y",DIR("A")="Do you want to Queue to run at a specific Time",DIR("B")="Yes" D ^DIR K DIR I $D(DIRUT) G OUT - I Y S PSOQ=1 K ZTDTH D G OUT - .S ZTRTN="EN^PSOHELP3",ZTIO="",ZTDESC="Outpatient Pharmacy Rx Cost Update" - .F G="REF","COST","DRG","FBCK","FAHD","PSOQ","PSOFUTR" S:$D(@G) ZTSAVE(G)="" - .D ^%ZTLOAD I $D(ZTSK) W !!,"Rxs Cost Update Queued",! K ZTSK -EN W:'$G(PSOQ) !,"Updating cost. Please wait... " - S FDT=FBCK-1 F S FDT=$O(^PSRX("ADL",FDT)) Q:'FDT D Q:FDT>FAHD - .I '$G(PSOFUTR) I FDT>FAHD Q - .S RXN=0 F S RXN=$O(^PSRX("ADL",FDT,DRG,RXN)) Q:'RXN D W:'$G(PSOQ) "." - ..I $P($G(^PSRX(RXN,0)),"^",6)=DRG,$P($G(^(2)),"^",2)=FDT S $P(^PSRX(RXN,0),"^",17)=COST - I 'REF G OUT - D REFILL,PARTIAL -OUT K G,COST,I,X,Y,REF,RXN,FDT,FAHD,FBCK,DRG,PSOQ,DIRUT,PSOFUTR I $D(ZTQUEUED) S ZTREQ="@" - Q -POST ;post install entry point. builds new "ADL" xref for file 52 pso*7*20 - S ZTRTN="EN1^PSOHELP3",ZTIO="",ZTDESC="Outpatient Pharmacy Rx XREF Update" - S ZTDTH=$H D ^%ZTLOAD I $D(ZTSK) D BMES^XPDUTL(" Post Install Background Job Queued.") K ZTSK - Q -EN1 K ^PSRX("ADL") S X1=DT,X2=-485 D C^%DTC S DEF=X-1 W !,"DEF: "_DEF - F S DEF=$O(^PSRX("AD",DEF)) Q:'DEF F IFN=0:0 S IFN=$O(^PSRX("AD",DEF,IFN)) Q:'IFN S FTY="" F S FTY=$O(^PSRX("AD",DEF,IFN,FTY)) Q:FTY="" I FTY=0 D - .I $P($G(^PSRX(IFN,2)),"^",2),$P($G(^(0)),"^",6) S ^PSRX("ADL",$P($G(^PSRX(IFN,2)),"^",2),$P($G(^(0)),"^",6),IFN)="" - K X,Y,DEF,FTY,IFN S ZTREQ="@" - Q -REFILL ; - N FILL,FDT,RXN - S FDT=FBCK-1 F S FDT=$O(^PSRX("AD",FDT)) Q:'FDT D Q:FDT>FAHD - .I '$G(PSOFUTR),FDT>FAHD Q - .S RXN="" F S RXN=$O(^PSRX("AD",FDT,RXN)) Q:'RXN D - ..I $P($G(^PSRX(RXN,0)),"^",6)'=DRG Q - ..S FILL=0 F S FILL=$O(^PSRX("AD",FDT,RXN,FILL)) Q:'FILL I $D(^PSRX(RXN,1,FILL,0)) S $P(^(0),"^",11)=COST - Q -PARTIAL ; - N FILL,FDT,RXN - S FDT=FBCK-1 F S FDT=$O(^PSRX("ADP",FDT)) Q:'FDT D Q:FDT>FAHD - .I '$G(PSOFUTR),FDT>FAHD Q - .S RXN="" F S RXN=$O(^PSRX("ADP",FDT,RXN)) Q:'RXN D - ..I $P($G(^PSRX(RXN,0)),"^",6)'=DRG Q - ..S FILL=0 F S FILL=$O(^PSRX("ADP",FDT,RXN,FILL)) Q:'FILL I $D(^PSRX(RXN,"P",FILL,0)) S $P(^(0),"^",11)=COST - Q +PSOHELP3 ;BHAM ISC/SAB - outpatient utility routine #4 ;2/17/93 18:00:36 + ;;7.0;OUTPATIENT PHARMACY;**20**;DEC 1997 +XREF ;code to create 'APD' xref on Drug Interaction file (#56) + ;I '$D(ZTSK),'$D(PSMSG) D WAIT^DICD W "Building 'APD' X-Ref." + ;The following code accessing files 56 and 50.416 is no longer executed + S ID1=$P(^PS(56,DA,0),"^",2),ID2=$P(^(0),"^",3),TOT=0 + F I1=0:0 S I1=$O(^PS(50.416,ID1,1,I1)) Q:'I1 S R2=$P(^(I1,0),"^") F I2=0:0 S I2=$O(^PS(50.416,ID2,1,I2)) Q:'I2 S D2=$P(^(I2,0),"^") W:+$G(PSMSG) "." D SEC + F I1=0:0 S I1=$O(^PS(50.416,"APS",ID1,I1)) Q:'I1 F I3=0:0 S I3=$O(^PS(50.416,I1,1,I3)) Q:'I3 S R2=$P(^(I3,0),"^") F I5=0:0 S I5=$O(^PS(50.416,"APS",ID2,I5)) Q:'I5 F I6=0:0 S I6=$O(^PS(50.416,I5,1,I6)) Q:'I6 S D2=$P(^(I6,0),"^") D SEC + F I1=0:0 S I1=$O(^PS(50.416,ID1,1,I1)) Q:'I1 S R2=$P(^(I1,0),"^") F I5=0:0 S I5=$O(^PS(50.416,"APS",ID2,I5)) Q:'I5 F I6=0:0 S I6=$O(^PS(50.416,I5,1,I6)) Q:'I6 S D2=$P(^(I6,0),"^") D SEC + F I2=0:0 S I2=$O(^PS(50.416,ID2,1,I2)) Q:'I2 S D2=$P(^(I2,0),"^") F I1=0:0 S I1=$O(^PS(50.416,"APS",ID1,I1)) Q:'I1 F I3=0:0 S I3=$O(^PS(50.416,I1,1,I3)) Q:'I3 S R2=$P(^(I3,0),"^") D SEC + S $P(^PS(56,DA,0),"^",6)=TOT +EX K TOT,I5,I6,D2,I4,I3,PRI,I1,I2,R2,PS1,PS2,ID2,ID1 + Q +SEC I +$G(DEL) K ^PS(56,"APD",R2,D2,DA),^PS(56,"APD",D2,R2,DA) Q + S ^PS(56,"APD",R2,D2,DA)="",^PS(56,"APD",D2,R2,DA)="",TOT=TOT+2 + Q +DRUG ;selects drug and updates Rx file with cost (pso*7*20) + K X,Y,DA,DIC S DIC(0)="AQEM",DIC=50 D ^DIC I $G(DUOUT) K DIC,Y,X,DA Q + I Y<0 G OUT + S (DRG,DA)=+Y K DIC,DR,DIQ S DIC=50,DR=16,DIQ="PSODRG",DIQ(0)="I" + D EN^DIQ1 S COST=PSODRG(50,DA,16,"I") K PSODRG,DIC,DA,DR,DIQ,DIR + W ! S DIR("A")="Do you want to update cost on Refills and Partials too",DIR(0)="Y",DIR("B")="No" D ^DIR K DIR I $G(DIRUT) K COST,X,DRG,Y Q + S REF=$S(Y:Y,1:0),X1=DT,X2=-485 D C^%DTC S (DEF,Y)=X X ^DD("DD") + W !!,"You can only go back One Year plus 120 days." + S %DT(0)=DEF,%DT="AQEX",%DT("A")="How far BACK do you want to go: ",%DT("B")=Y D ^%DT K %DT("B"),DEF I Y<0!($D(DTOUT)) K REF,COST,DRG,X,Y Q + S (FBCK,%DT(0))=Y,%DT("A")="How far AHEAD do you want to go: " D ^%DT + K %DT I Y<0!($D(DTOUT)) K FBCK,REF,COST,DRG,X,Y Q + S FAHD=Y K DIR,X,Y S DIR(0)="Y",DIR("A")="Do you want to Queue to run at a specific Time",DIR("B")="Yes" D ^DIR K DIR I $D(DIRUT) G OUT + I Y S PSOQ=1 K ZTDTH D G OUT + .S ZTRTN="EN^PSOHELP3",ZTIO="",ZTDESC="Outpatient Pharmacy Rx Cost Update" + .F G="REF","COST","DRG","FBCK","FAHD","PSOQ" S:$D(@G) ZTSAVE(G)="" + .D ^%ZTLOAD I $D(ZTSK) W !,"Rxs Cost Update Queued" K ZTSK +EN W:'$G(PSOQ) ! S FDT=FBCK-1 F S FDT=$O(^PSRX("ADL",FDT)) Q:'FDT!(FDT>FAHD) F RXN=0:0 S RXN=$O(^PSRX("ADL",FDT,DRG,RXN)) Q:'RXN D W:'$G(PSOQ) "." + .I $P($G(^PSRX(RXN,0)),"^",6)=DRG,$P($G(^(2)),"^",2)=FDT S $P(^PSRX(RXN,0),"^",17)=COST + .Q:'REF + .F I=0:0 S I=$O(^PSRX(RXN,1,I)) Q:'I S $P(^PSRX(RXN,1,I,0),"^",11)=COST + .F I=0:0 S I=$O(^PSRX(RXN,"P",I)) Q:'I S $P(^PSRX(RXN,"P",I,0),"^",11)=COST +OUT K G,COST,I,X,Y,REF,RXN,FDT,FAHD,FBCK,DRG,PSOQ,DIRUT I $D(ZTQUEUED) S ZTREQ="@" + Q +POST ;post install entry point. builds new "ADL" xref for file 52 pso*7*20 + S ZTRTN="EN1^PSOHELP3",ZTIO="",ZTDESC="Outpatient Pharmacy Rx XREF Update" + S ZTDTH=$H D ^%ZTLOAD I $D(ZTSK) D BMES^XPDUTL(" Post Install Background Job Queued.") K ZTSK + Q +EN1 K ^PSRX("ADL") S X1=DT,X2=-485 D C^%DTC S DEF=X-1 W !,"DEF: "_DEF + F S DEF=$O(^PSRX("AD",DEF)) Q:'DEF F IFN=0:0 S IFN=$O(^PSRX("AD",DEF,IFN)) Q:'IFN S FTY="" F S FTY=$O(^PSRX("AD",DEF,IFN,FTY)) Q:FTY="" I FTY=0 D + .I $P($G(^PSRX(IFN,2)),"^",2),$P($G(^(0)),"^",6) S ^PSRX("ADL",$P($G(^PSRX(IFN,2)),"^",2),$P($G(^(0)),"^",6),IFN)="" + K X,Y,DEF,FTY,IFN S ZTREQ="@" + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLD.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLD.m index ca6bfd59..372c79af 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLD.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLD.m @@ -1,115 +1,115 @@ -PSOHLD ;BIR/SAB - hold unhold functionality ;07/15/96 - ;;7.0;OUTPATIENT PHARMACY;**1,16,21,24,27,32,55,82,114,130,166,148,268,281**;DEC 1997;Build 41 - ;External reference to ^DD(52-DBIA 999, VA(200-DBIA 224, NA^ORX1-DBIA 2186, - ; L, UL, PSOL, and PSOUL^PSSLOCK-DBIA 2789, ^%DTC-DBIA 10000, ^DIE-DBIA 10018, ^DIR-DBIA 10026, - ; ^DIK-DBIA 10013, ^VALM1-DBIA 10016, ^XUSEC(-DBIA 10076 -UHLD I '$D(PSOPAR) D ^PSOLSET G:'$D(PSOPAR) EX - I $G(PSOBEDT) W $C(7),$C(7) S VALMSG="Invalid Action at this time !",VALMBCK="" Q - I $G(PSONACT) W $C(7),$C(7) S VALMSG="No Pharmacy Orderable Item !",VALMBCK="" Q - S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.") K PSOPLCK S VALMBCK="" Q - ;W !! S DIC("A")="Unhold Prescription #: ",(DIE,DIC)="^PSRX(",DIC(0)="AEMQZ",DIC("S")="I $G(^PSRX(+Y,""H""))]"""",$P(^(""STA""),""^"")'=16" D ^DIC G:"^"[$E(X) EX G:Y<0 UHLD S (DA,PPL)=+Y,DFN=$P(Y(0),"^",2) - K PSOPLCK D PSOL^PSSLOCK(DA) I '$G(PSOMSG) S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG D ULP Q - S Y(0)=^PSRX(DA,0),STA=+$G(^("STA")) - I STA=16 S VALMSG="Placed on HOLD by Provider!" K Y,STA D PSOUL^PSSLOCK(DA) D ULP S VALMBCK="" Q - I STA'=3!('$D(^XUSEC("PSORPH",DUZ))) S VALMSG="Invalid Action Selection!",VALMBCK="" K Y,STA D PSOUL^PSSLOCK(DA) D ULP Q - D FULL^VALM1 K DIR,DTOUT,DUOUT,DIRUT D NOOR I $D(DIRUT) D ULP G EX - I DT>$P(^PSRX(DA,2),"^",6) D D ULP G EX - .S VALMSG="Medication Expired on "_$E($P(^PSRX(DA,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) I $P(^PSRX(DA,"STA"),"^")<11 S $P(^PSRX(DA,"STA"),"^")=11 - .S ^PSRX(DA,"H")="",COMM="Medication Expired on "_$E($P(^(2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) D EN^PSOHLSN1(DA,"SC","ZE",COMM,"") K COMM -EN S RXF=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I S RXF=I,RSDT=$P(^(0),"^") - I RXF D I $D(Y) D ULP G EX - .S (PSDA,DA(1))=DA,DA=RXF,DIE="^PSRX("_DA(1)_",1," - .S RLDT=$P(^PSRX(DA(1),1,DA,0),"^",18) - .S DR=$S('RLDT:".01R;2;",1:"")_"3COMMENTS" - .S PSOUNHLD=1 D ^DIE K PSOUNHLD - .S ZD(PSDA)=$P(^PSRX(DA(1),1,DA,0),"^") - .Q:$D(Y) S PSORX("FILL DATE")=$P(^PSRX(DA(1),1,DA,0),"^"),DA=PSDA K DA(1) - ; - S ACT=1,DIE="^PSRX(",FDT=$S($P(^PSRX(DA,2),"^",2):$P(^PSRX(DA,2),"^",2),1:DT) - S RLDT=$P(^PSRX(DA,2),"^",13),DR="",RLDTP1=$P(RLDT,".",1) - I 'RXF&'RLDT S DR="22//^S X=FDT;11;Q;" - I RLDT&($P(^PSRX(DA,2),"^",2)="") S DR="22//^S X=RLDTP1;11;Q;" - S DR=DR_"100///0;101///^S X=$S(RXF:$G(ZD(PSDA)),1:$P(^PSRX(PSDA,2),""^"",2))" - ; - D ^DIE K FDT I $D(Y) S VALMBCK="R" D ULP G EX - S COMM="Medication Removed from Hold by Pharmacy" D EN^PSOHLSN1(DA,"OE","",COMM,PSONOOR) K COMM,PSONOOR - S PSORX("FILL DATE")=$S('RXF:$P(^PSRX(DA,2),"^",2),1:ZD(PSDA)) K ^PSRX("AH",$P(^PSRX(DA,"H"),"^"),DA) S ^PSRX(DA,"H")="" D ACT^PSOHLDA S (NEW1,NEW11)="^^" - S (RXF,RXFL(DA))=0 F JJ=0:0 S JJ=$O(^PSRX(DA,1,JJ)) Q:'JJ S (RXFL(DA),RXF)=JJ - I $G(PSXSYS) D UNHOLD^PSOCMOPA I $G(XFLAG) D ULP G EX - I $G(DA) D RELC I $G(PSOHRL) D ULP G EX - I PSORX("FILL DATE")>DT,$P(PSOPAR,"^",6) D S^PSORXL,EX,ULP Q - S PCOMH(DA)="Medication Removed from Hold by Pharmacy" - I $G(DA) S RXRH(DA)=DA - I $P($G(^PSRX(DA,2)),"^",15)'="" S $P(^PSRX(DA,2),"^",14)=1,RXRP(DA)=1,$P(RXRP(DA),"^",2)=$P($G(^PSRX(DA,0)),"^",18) ; MARK PRESCRIPTION AND LABEL AS BEING REPRINTED WHEN UNHOLDING A RETURNED TO SOTCK PRESCRIPTION - ; - ; - Submitting Rx to ECME - N ACTION - I $$SUBMIT^PSOBPSUT(DA,+$G(RXFL(DA))) D I ACTION="Q"!(ACTION="^") D ULP G EX - . N RX,RFL S RX=DA,RFL=+$G(RXFL(DA)) - . N DA S ACTION="" - . D ECMESND^PSOBPSU1(RX,RFL,,$S(RFL:"RF",1:"OF")) - . I $$FIND^PSOREJUT(RX,RFL) D - . . S ACTION=$$HDLG^PSOREJU1(RX,RFL,"79,88","ED","IOQ","Q") - ; - I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=DA_"," D ULP G EX - F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1 S PSOX2=PSOX1 - I $L(PSORX("PSOL",PSOX2))+$L(DA)<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_DA_"," - E S PSORX("PSOL",PSOX2+1)=DA_"," - ; - D ULP -EX D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) D ^PSOBUILD - K PSOHRL,PSOMSG,PSOPLCK,ST,PSL,PSNP,IR,NOW,DR,NEW1,NEW11,RTN,DA,PPL,RXN,RX0,RXS,DIK,RXP,FLD,ACT,DIE,DIC,DIR,DIE,X,Y,DIRUT,DUOUT,SUSPT,C,D0,LFD,I,PSDA,RFDATE,DI,DQ,%,RFN,XFLAG - K HRX,PSHLD,PSOLIST,PSORX("FILL DATE"),STA,QTY,RFDT,PSORX0,PSRXN,RXF,JJ Q - ; -HLD ; - I $G(PSOBEDT) W $C(7),$C(7) S VALMSG="Invalid Action at this time !",VALMBCK="" Q - I $G(PSONACT) W $C(7),$C(7) S VALMSG="No Pharmacy Orderable Item !",VALMBCK="" Q - I '$D(^XUSEC("PSORPH",DUZ)) S VALMSG="Invalid Action Selection!",VALMBCK="" Q - S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient."),VALMBCK="" K PSOPLCK Q - K PSOPLCK D PSOL^PSSLOCK(DA) I '$G(PSOMSG) S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG D ULP Q - S Y(0)=^PSRX(DA,0),STA=+$G(^("STA")) I DT>$P(^PSRX(DA,2),"^",6) D D ULP G D1 - .S VALMSG="Medication Expired on "_$E($P(^PSRX(DA,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3),VALMBCK="R" - .I $P(^PSRX(DA,"STA"),"^")<11 S $P(^PSRX(DA,"STA"),"^")=11 D - ..S COMM="Medication Expired on "_$E($P(^PSRX(DA,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) D EN^PSOHLSN1(DA,"SC","ZE",COMM) K COMM - S ST=$P("ERROR^ACTIVE^NON-VERIFIED^REFILL^HOLD^NON-VERIFIED^SUSPENDED^^^^^DONE^EXPIRED^DISCONTINUED^DELETED^DISCONTINUED^DISCONTINUED (EDIT)^PROVIDER HOLD^","^",STA+2) - I STA,STA'>4!(STA>11) D D ULP G D1 - .S VALMSG="Rx: "_$P(Y(0),"^")_" is currently in a status of "_ST,VALMBCK="R" K ST,Y Q - D FULL^VALM1 D NOOR I $D(DIRUT) D ULP G D1 - D HLD^PSOCMOPA I $G(XFLAG) K XFLAG D ULP G D1 - K DIR S DIR("A")=$P(^DD(52,99,0),"^"),DIR(0)="52,99" D ^DIR S FLD(99)=Y I $D(DUOUT)!($D(DIRUT)) K DIRUT,DUOUT,DIR D ULP G D1 - I $G(FLD(99))=99 K DIR S DIR("A")=$P(^DD(52,99.1,0),"^"),DIR(0)="52,99.1" D ^DIR S FLD(99.1)=Y G AR - E K DIR S DIR(0)="FO^10:100",DIR("A")="HOLD COMMENTS" D ^DIR S FLD(99.1)=Y -AR I $D(DUOUT)!($D(DTOUT)) K DIRUT,DUOUT,DIR S VALMBCK="R" D ULP G D1 - F PI=1:1 Q:$P(PPL,",",PI)="" S DA=$P(PPL,",",PI) D H S DA=PSDA K PSDA D:$D(PSORX("PSOL")) RMP^PSOHLDA - K PI D ^PSOBUILD - D ULP -D1 D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) K PSOMSG,PSOPLCK,RFN,DIR,RSDT,FLD,DA,ACT,X,Y,DIRUT,DUOUT,DTOUT,DIROUT - Q - ; -H ; - Rx HOLD update - D HOLD^PSOHLDA - Q - ; -FLD N DA K DIR S DIR("A")=$P(^DD(52,99,0),"^"),DIR(0)="52,99" D ^DIR Q:$D(DUOUT)!($D(DIRUT)) S FLD(99)=Y - S COMM=Y(0) - I $G(FLD(99))=99 K DIR S DIR("A")=$P(^DD(52,99.1,0),"^"),DIR(0)="52,99.1" D ^DIR Q:$D(DUOUT)!($D(DIRUT)) S (FLD(99.1),COMM)=Y Q - E S FLD(99.1)="" - Q -NOOR ;ask nature of order - K DIR,DTOUT,DTOUT,DIRUT I $T(NA^ORX1)]"" D Q - .S PSONOOR=$$NA^ORX1("W",0,"B","Nature of Order",0,"WPSDIVR"_$S(+$G(^VA(200,DUZ,"PS")):"E",1:"")) - .I +PSONOOR S PSONOOR=$P(PSONOOR,"^",3) Q - .S DIRUT=1 K PSONOOR - S DIR("A")="Nature of Order: ",DIR("B")="WRITTEN" - S DIR(0)="SA^W:WRITTEN;V:VERBAL;P:TELEPHONE;S:SERVICE CORRECTED;D:DUPLICATE;I:POLICY;R:SERVICE REJECTED"_$S(+$G(^VA(200,DUZ,"PS")):";E:PROVIDER ENTERED",1:"") -NOORX D ^DIR K DIR,DTOUT,DTOUT Q:$D(DIRUT) S PSONOOR=Y - Q -ULP ; - D UL^PSSLOCK(+$G(PSODFN)) - Q -RELC ; - S (PSOHRL,PSOHTX)=0 F PSOHT=0:0 S PSOHT=$O(^PSRX(DA,1,PSOHT)) Q:'PSOHT S:$D(^PSRX(DA,1,PSOHT,0)) PSOHTX=PSOHT - I $G(PSOHTX) S PSOHRL=$S($P($G(^PSRX(DA,1,PSOHTX,0)),"^",18):1,1:0) - I '$G(PSOHTX) S PSOHRL=$S($P($G(^PSRX(DA,2)),"^",13):1,1:0) - K PSOHTX,PSOHT - Q +PSOHLD ;BIR/SAB - hold unhold functionality ;07/15/96 + ;;7.0;OUTPATIENT PHARMACY;**1,16,21,24,27,32,55,82,114,130,166,148,268**;DEC 1997;Build 9 + ;External reference to ^DD(52-DBIA 999, VA(200-DBIA 224, NA^ORX1-DBIA 2186, + ; L, UL, PSOL, and PSOUL^PSSLOCK-DBIA 2789, ^%DTC-DBIA 10000, ^DIE-DBIA 10018, ^DIR-DBIA 10026, + ; ^DIK-DBIA 10013, ^VALM1-DBIA 10016, ^XUSEC(-DBIA 10076 +UHLD I '$D(PSOPAR) D ^PSOLSET G:'$D(PSOPAR) EX + I $G(PSOBEDT) W $C(7),$C(7) S VALMSG="Invalid Action at this time !",VALMBCK="" Q + I $G(PSONACT) W $C(7),$C(7) S VALMSG="No Pharmacy Orderable Item !",VALMBCK="" Q + S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.") K PSOPLCK S VALMBCK="" Q + ;W !! S DIC("A")="Unhold Prescription #: ",(DIE,DIC)="^PSRX(",DIC(0)="AEMQZ",DIC("S")="I $G(^PSRX(+Y,""H""))]"""",$P(^(""STA""),""^"")'=16" D ^DIC G:"^"[$E(X) EX G:Y<0 UHLD S (DA,PPL)=+Y,DFN=$P(Y(0),"^",2) + K PSOPLCK D PSOL^PSSLOCK(DA) I '$G(PSOMSG) S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG D ULP Q + S Y(0)=^PSRX(DA,0),STA=+$G(^("STA")) + I STA=16 S VALMSG="Placed on HOLD by Provider!" K Y,STA D PSOUL^PSSLOCK(DA) D ULP S VALMBCK="" Q + I STA'=3!('$D(^XUSEC("PSORPH",DUZ))) S VALMSG="Invalid Action Selection!",VALMBCK="" K Y,STA D PSOUL^PSSLOCK(DA) D ULP Q + D FULL^VALM1 K DIR,DTOUT,DUOUT,DIRUT D NOOR I $D(DIRUT) D ULP G EX + I DT>$P(^PSRX(DA,2),"^",6) D D ULP G EX + .S VALMSG="Medication Expired on "_$E($P(^PSRX(DA,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) I $P(^PSRX(DA,"STA"),"^")<11 S $P(^PSRX(DA,"STA"),"^")=11 + .S ^PSRX(DA,"H")="",COMM="Medication Expired on "_$E($P(^(2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) D EN^PSOHLSN1(DA,"SC","ZE",COMM,"") K COMM +EN S RXF=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I S RXF=I,RSDT=$P(^(0),"^") + I RXF D I $D(Y) D ULP G EX + .S (PSDA,DA(1))=DA,DA=RXF,DIE="^PSRX("_DA(1)_",1," + .S RLDT=$P(^PSRX(DA(1),1,DA,0),"^",18) + .S DR=$S('RLDT:".01R;2;",1:"")_"3COMMENTS" + .S PSOUNHLD=1 D ^DIE K PSOUNHLD + .S ZD(PSDA)=$P(^PSRX(DA(1),1,DA,0),"^") + .Q:$D(Y) S PSORX("FILL DATE")=$P(^PSRX(DA(1),1,DA,0),"^"),DA=PSDA K DA(1) + ; + S ACT=1,DIE="^PSRX(",FDT=$S($P(^PSRX(DA,2),"^",2):$P(^PSRX(DA,2),"^",2),1:DT) + S RLDT=$P(^PSRX(DA,2),"^",13),DR="",RLDTP1=$P(RLDT,".",1) + I 'RXF&'RLDT S DR="22//^S X=FDT;11;Q;" + I RLDT&($P(^PSRX(DA,2),"^",2)="") S DR="22//^S X=RLDTP1;11;Q;" + S DR=DR_"100///0;101///^S X=$S(RXF:$G(ZD(PSDA)),1:$P(^PSRX(PSDA,2),""^"",2))" + ; + D ^DIE K FDT I $D(Y) S VALMBCK="R" D ULP G EX + S COMM="Medication Removed from Hold by Pharmacy" D EN^PSOHLSN1(DA,"OE","",COMM,PSONOOR) K COMM,PSONOOR + S PSORX("FILL DATE")=$S('RXF:$P(^PSRX(DA,2),"^",2),1:ZD(PSDA)) K ^PSRX("AH",$P(^PSRX(DA,"H"),"^"),DA) S ^PSRX(DA,"H")="" D ACT^PSOHLDA S (NEW1,NEW11)="^^" + S (RXF,RXFL(DA))=0 F JJ=0:0 S JJ=$O(^PSRX(DA,1,JJ)) Q:'JJ S (RXFL(DA),RXF)=JJ + I $G(PSXSYS) D UNHOLD^PSOCMOPA I $G(XFLAG) D ULP G EX + I $G(DA) D RELC I $G(PSOHRL) D ULP G EX + I PSORX("FILL DATE")>DT,$P(PSOPAR,"^",6) D S^PSORXL,EX,ULP Q + S PCOMH(DA)="Medication Removed from Hold by Pharmacy" + I $G(DA) S RXRH(DA)=DA + I $P($G(^PSRX(DA,2)),"^",15)'="" S $P(^PSRX(DA,2),"^",14)=1,RXRP(DA)=1,$P(RXRP(DA),"^",2)=$P($G(^PSRX(DA,0)),"^",18) ; MARK PRESCRIPTION AND LABEL AS BEING REPRINTED WHEN UNHOLDING A RETURNED TO SOTCK PRESCRIPTION + ; + ; - Submitting Rx to ECME + N ACTION + I $$SUBMIT^PSOBPSUT(DA,+$G(RXFL(DA))) D I ACTION="Q"!(ACTION="^") D ULP G EX + . N RX,RFL S RX=DA,RFL=+$G(RXFL(DA)) + . N DA S ACTION="" + . D ECMESND^PSOBPSU1(RX,RFL,,$S(RFL:"RF",1:"OF")) + . I $$FIND^PSOREJUT(RX,RFL) D + . . S ACTION=$$HDLG^PSOREJU1(RX,RFL,"79,88","ED","IOQ","I") + ; + I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=DA_"," D ULP G EX + F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1 S PSOX2=PSOX1 + I $L(PSORX("PSOL",PSOX2))+$L(DA)<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_DA_"," + E S PSORX("PSOL",PSOX2+1)=DA_"," + ; + D ULP +EX D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) D ^PSOBUILD + K PSOHRL,PSOMSG,PSOPLCK,ST,PSL,PSNP,IR,NOW,DR,NEW1,NEW11,RTN,DA,PPL,RXN,RX0,RXS,DIK,RXP,FLD,ACT,DIE,DIC,DIR,DIE,X,Y,DIRUT,DUOUT,SUSPT,C,D0,LFD,I,PSDA,RFDATE,DI,DQ,%,RFN,XFLAG + K HRX,PSHLD,PSOLIST,PSORX("FILL DATE"),STA,QTY,RFDT,PSORX0,PSRXN,RXF,JJ Q + ; +HLD ; + I $G(PSOBEDT) W $C(7),$C(7) S VALMSG="Invalid Action at this time !",VALMBCK="" Q + I $G(PSONACT) W $C(7),$C(7) S VALMSG="No Pharmacy Orderable Item !",VALMBCK="" Q + I '$D(^XUSEC("PSORPH",DUZ)) S VALMSG="Invalid Action Selection!",VALMBCK="" Q + S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient."),VALMBCK="" K PSOPLCK Q + K PSOPLCK D PSOL^PSSLOCK(DA) I '$G(PSOMSG) S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG D ULP Q + S Y(0)=^PSRX(DA,0),STA=+$G(^("STA")) I DT>$P(^PSRX(DA,2),"^",6) D D ULP G D1 + .S VALMSG="Medication Expired on "_$E($P(^PSRX(DA,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3),VALMBCK="R" + .I $P(^PSRX(DA,"STA"),"^")<11 S $P(^PSRX(DA,"STA"),"^")=11 D + ..S COMM="Medication Expired on "_$E($P(^PSRX(DA,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) D EN^PSOHLSN1(DA,"SC","ZE",COMM) K COMM + S ST=$P("ERROR^ACTIVE^NON-VERIFIED^REFILL^HOLD^NON-VERIFIED^SUSPENDED^^^^^DONE^EXPIRED^DISCONTINUED^DELETED^DISCONTINUED^DISCONTINUED (EDIT)^PROVIDER HOLD^","^",STA+2) + I STA,STA'>4!(STA>11) D D ULP G D1 + .S VALMSG="Rx: "_$P(Y(0),"^")_" is currently in a status of "_ST,VALMBCK="R" K ST,Y Q + D FULL^VALM1 D NOOR I $D(DIRUT) D ULP G D1 + D HLD^PSOCMOPA I $G(XFLAG) K XFLAG D ULP G D1 + K DIR S DIR("A")=$P(^DD(52,99,0),"^"),DIR(0)="52,99" D ^DIR S FLD(99)=Y I $D(DUOUT)!($D(DIRUT)) K DIRUT,DUOUT,DIR D ULP G D1 + I $G(FLD(99))=99 K DIR S DIR("A")=$P(^DD(52,99.1,0),"^"),DIR(0)="52,99.1" D ^DIR S FLD(99.1)=Y G AR + E K DIR S DIR(0)="FO^10:100",DIR("A")="HOLD COMMENTS" D ^DIR S FLD(99.1)=Y +AR I $D(DUOUT)!($D(DTOUT)) K DIRUT,DUOUT,DIR S VALMBCK="R" D ULP G D1 + F PI=1:1 Q:$P(PPL,",",PI)="" S DA=$P(PPL,",",PI) D H S DA=PSDA K PSDA D:$D(PSORX("PSOL")) RMP^PSOHLDA + K PI D ^PSOBUILD + D ULP +D1 D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) K PSOMSG,PSOPLCK,RFN,DIR,RSDT,FLD,DA,ACT,X,Y,DIRUT,DUOUT,DTOUT,DIROUT + Q + ; +H ; - Rx HOLD update + D HOLD^PSOHLDA + Q + ; +FLD N DA K DIR S DIR("A")=$P(^DD(52,99,0),"^"),DIR(0)="52,99" D ^DIR Q:$D(DUOUT)!($D(DIRUT)) S FLD(99)=Y + S COMM=Y(0) + I $G(FLD(99))=99 K DIR S DIR("A")=$P(^DD(52,99.1,0),"^"),DIR(0)="52,99.1" D ^DIR Q:$D(DUOUT)!($D(DIRUT)) S (FLD(99.1),COMM)=Y Q + E S FLD(99.1)="" + Q +NOOR ;ask nature of order + K DIR,DTOUT,DTOUT,DIRUT I $T(NA^ORX1)]"" D Q + .S PSONOOR=$$NA^ORX1("W",0,"B","Nature of Order",0,"WPSDIVR"_$S(+$G(^VA(200,DUZ,"PS")):"E",1:"")) + .I +PSONOOR S PSONOOR=$P(PSONOOR,"^",3) Q + .S DIRUT=1 K PSONOOR + S DIR("A")="Nature of Order: ",DIR("B")="WRITTEN" + S DIR(0)="SA^W:WRITTEN;V:VERBAL;P:TELEPHONE;S:SERVICE CORRECTED;D:DUPLICATE;I:POLICY;R:SERVICE REJECTED"_$S(+$G(^VA(200,DUZ,"PS")):";E:PROVIDER ENTERED",1:"") +NOORX D ^DIR K DIR,DTOUT,DTOUT Q:$D(DIRUT) S PSONOOR=Y + Q +ULP ; + D UL^PSSLOCK(+$G(PSODFN)) + Q +RELC ; + S (PSOHRL,PSOHTX)=0 F PSOHT=0:0 S PSOHT=$O(^PSRX(DA,1,PSOHT)) Q:'PSOHT S:$D(^PSRX(DA,1,PSOHT,0)) PSOHTX=PSOHT + I $G(PSOHTX) S PSOHRL=$S($P($G(^PSRX(DA,1,PSOHTX,0)),"^",18):1,1:0) + I '$G(PSOHTX) S PSOHRL=$S($P($G(^PSRX(DA,2)),"^",13):1,1:0) + K PSOHTX,PSOHT + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLDA.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLDA.m index 58ed2fd7..a2f78e04 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLDA.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLDA.m @@ -1,49 +1,50 @@ -PSOHLDA ;BIR/MFR - HOLD/UNHOLD functionality (cont.) ;07/15/96 - ;;7.0;OUTPATIENT PHARMACY;**148,225**;DEC 1997;Build 29 - ; -HOLD ;hold function - I $P($G(^PSRX(DA,"STA")),"^")=3 Q - S RSDT=$S($P(^PSRX(DA,2),"^",13):$P(^PSRX(DA,3),"^"),1:"@"),(PSUS,ACT,RXF,RFN,I)=0 F S I=$O(^PSRX(DA,1,I)) Q:'I D - .S RXF=I,RFN=RFN+1 S:RFN=1 RSDT=$S('$P(^PSRX(DA,1,I,0),"^",18):$P(^PSRX(DA,2),"^",2),1:$P(^PSRX(DA,1,I,0),"^")) - .I RFN>1,'$P(^PSRX(DA,1,I,0),"^",18) S RSDT=$P(^PSRX(DA,1,RXF-1,0),"^") Q - .S:RFN>1 RSDT=$P(^PSRX(DA,1,RXF,0),"^") - I RXF D - .S (PSDA,DA(1))=DA,DA=RXF,DIE="^PSRX("_DA(1)_",1,",DR="4" D ^DIE - .S $P(^PSRX(DA(1),1,DA,0),"^",3)=$S($G(FLD(99.1))]"":$E(FLD(99.1),1,60),1:"") - .S DA=PSDA K DA(1) - S DIE="^PSRX(",DR=$S('RXF&('$P(^PSRX(DA,2),"^",13)):"22///@;",1:"")_"99///"_FLD(99)_";99.1///^S X=FLD(99.1);99.2///"_DT_";100///3;101///"_RSDT D ^DIE Q:$D(Y) - S:$G(PSOHD) VALMSG="RX# "_$P(^PSRX(DA,0),"^")_" has been placed in a hold status." - K RXRS(DA) - I +$G(PSDA) S DA=$O(^PS(52.5,"B",PSDA,0)) I DA S:$P($G(^PS(52.5,DA,"P")),"^")=0 PSUS=1 S DIK="^PS(52.5," D ^DIK K DA,DIK - S:+$G(PSDA) DA=PSDA D ACT - S PSOHNX=+$P($G(^PSRX(+$G(DA),"H")),"^") D - .I $G(PSOHNX),$P($G(^PSRX(DA,"H")),"^",2)'="" S COMM=$P($G(^("H")),"^",2) Q - .S COMM="Medication placed on Hold "_$E(DT,4,5)_"-"_$E(DT,6,7)_"-"_$E(DT,2,3) - D EN^PSOHLSN1(DA,"OH","",COMM,PSONOOR) K COMM,PSOHNX - ; - ; - Closes any OPEN/UNRESOLVED REJECTs and Reverses ECME Claim - D REVERSE^PSOBPSU1(DA,+$G(RXF),"HLD",2) - Q - ; -ACT ;adds activity info for rx removed or placed on hold - D NOW^%DTC S NOW=% - S IR=0 F FDA=0:0 S FDA=$O(^PSRX(DA,"A",FDA)) Q:'FDA S IR=FDA - S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR - S ^PSRX(DA,"A",IR,0)=NOW_"^"_$S(ACT:"U",1:"H")_"^"_DUZ_"^"_$S(RXF>5:RXF+1,1:RXF)_"^"_"RX "_$S('ACT:"placed in a",1:"removed from")_" HOLD status "_$S(+$G(PSUS):"and removed from SUSPENSE ",1:"")_"("_$E(DT,4,5)_"-"_$E(DT,6,7)_"-"_$E(DT,2,3)_")" - K PSUS,RXF,I,FDA,DIC,DIE,DR,Y,X,%,%I,%H,RSDT - Q - ; -RMP ;remove Rx if found in array PSORX("PSOL") - Q:'$G(DA) - N I,J,K,PSOX2,PSOX3,PSOX9 S I=0 - F S I=$O(PSORX("PSOL",I)) Q:'I S PSOX2=PSORX("PSOL",I) D:PSOX2[(DA_",") - .S PSOX9="",K=0 F J=1:1 S PSOX3=$P(PSOX2,",",J) Q:'PSOX3 D - ..I PSOX3=DA,$P($G(^PSRX(DA,"STA")),"^")=3 S K=1 Q - ..S PSOX9=PSOX9_$S('PSOX9:"",1:",")_PSOX3 - .I K S:PSOX9]"" PSORX("PSOL",I)=PSOX9_"," K:PSOX9="" PSORX("PSOL",I) D:$D(BBRX(I)) RMB - Q -RMB ;remove Rx if found in array BBRX() - S PSOX2=BBRX(I) D:PSOX2[(DA_",") - .S PSOX9="" F J=1:1 S PSOX3=$P(PSOX2,",",J) Q:'PSOX3 S:PSOX3'=DA PSOX9=PSOX9_$S('PSOX9:"",1:",")_PSOX3 - .S:PSOX9]"" BBRX(I)=PSOX9_"," K:PSOX9="" BBRX(I) - Q +PSOHLDA ;BIR/MFR - HOLD/UNHOLD functionality (cont.) ;07/15/96 + ;;7.0;OUTPATIENT PHARMACY;**148**;DEC 1997 + ; +HOLD ;hold function + I $P($G(^PSRX(DA,"STA")),"^")=3 Q + S RSDT=$S($P(^PSRX(DA,2),"^",13):$P(^PSRX(DA,3),"^"),1:"@"),(PSUS,ACT,RXF,RFN,I)=0 F S I=$O(^PSRX(DA,1,I)) Q:'I D + .S RXF=I,RFN=RFN+1 S:RFN=1 RSDT=$S('$P(^PSRX(DA,1,I,0),"^",18):$P(^PSRX(DA,2),"^",2),1:$P(^PSRX(DA,1,I,0),"^")) + .I RFN>1,'$P(^PSRX(DA,1,I,0),"^",18) S RSDT=$P(^PSRX(DA,1,RXF-1,0),"^") Q + .S:RFN>1 RSDT=$P(^PSRX(DA,1,RXF,0),"^") + I RXF D + .S (PSDA,DA(1))=DA,DA=RXF,DIE="^PSRX("_DA(1)_",1,",DR="4" D ^DIE + .S $P(^PSRX(DA(1),1,DA,0),"^",3)=$S($G(FLD(99.1))]"":$E(FLD(99.1),1,60),1:"") + .S DA=PSDA K DA(1) + S DIE="^PSRX(",DR=$S('RXF&('$P(^PSRX(DA,2),"^",13)):"22///@;",1:"")_"99///"_FLD(99)_";99.1///^S X=FLD(99.1);99.2///"_DT_";100///3;101///"_RSDT D ^DIE Q:$D(Y) + S:$G(PSOHD) VALMSG="RX# "_$P(^PSRX(DA,0),"^")_" has been placed in a hold status." + K RXRS(DA) + I +$G(PSDA) S DA=$O(^PS(52.5,"B",PSDA,0)) I DA S:$P($G(^PS(52.5,DA,"P")),"^")=0 PSUS=1 S DIK="^PS(52.5," D ^DIK K DA,DIK + S:+$G(PSDA) DA=PSDA D ACT + S PSOHNX=+$P($G(^PSRX(+$G(DA),"H")),"^") D + .I $G(PSOHNX),$G(PSOHNX)'=99 S COMM=$P($P($P(^DD(52,99,0),"^",3),";",PSOHNX),":",2) Q + .I $G(PSOHNX)=99,$P($G(^PSRX(DA,"H")),"^",2)'="" S COMM=$P($G(^("H")),"^",2) Q + .S COMM="Medication placed on Hold "_$E(DT,4,5)_"-"_$E(DT,6,7)_"-"_$E(DT,2,3) + D EN^PSOHLSN1(DA,"OH","",COMM,PSONOOR) K COMM,PSOHNX + ; + ; - Closes any OPEN/UNRESOLVED REJECTs and Reverses ECME Claim + D REVERSE^PSOBPSU1(DA,+$G(RXF),"HLD",2) + Q + ; +ACT ;adds activity info for rx removed or placed on hold + D NOW^%DTC S NOW=% + S IR=0 F FDA=0:0 S FDA=$O(^PSRX(DA,"A",FDA)) Q:'FDA S IR=FDA + S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR + S ^PSRX(DA,"A",IR,0)=NOW_"^"_$S(ACT:"U",1:"H")_"^"_DUZ_"^"_$S(RXF>5:RXF+1,1:RXF)_"^"_"RX "_$S('ACT:"placed in a",1:"removed from")_" HOLD status "_$S(+$G(PSUS):"and removed from SUSPENSE ",1:"")_"("_$E(DT,4,5)_"-"_$E(DT,6,7)_"-"_$E(DT,2,3)_")" + K PSUS,RXF,I,FDA,DIC,DIE,DR,Y,X,%,%I,%H,RSDT + Q + ; +RMP ;remove Rx if found in array PSORX("PSOL") + Q:'$G(DA) + N I,J,K,PSOX2,PSOX3,PSOX9 S I=0 + F S I=$O(PSORX("PSOL",I)) Q:'I S PSOX2=PSORX("PSOL",I) D:PSOX2[(DA_",") + .S PSOX9="",K=0 F J=1:1 S PSOX3=$P(PSOX2,",",J) Q:'PSOX3 D + ..I PSOX3=DA,$P($G(^PSRX(DA,"STA")),"^")=3 S K=1 Q + ..S PSOX9=PSOX9_$S('PSOX9:"",1:",")_PSOX3 + .I K S:PSOX9]"" PSORX("PSOL",I)=PSOX9_"," K:PSOX9="" PSORX("PSOL",I) D:$D(BBRX(I)) RMB + Q +RMB ;remove Rx if found in array BBRX() + S PSOX2=BBRX(I) D:PSOX2[(DA_",") + .S PSOX9="" F J=1:1 S PSOX3=$P(PSOX2,",",J) Q:'PSOX3 S:PSOX3'=DA PSOX9=PSOX9_$S('PSOX9:"",1:",")_PSOX3 + .S:PSOX9]"" BBRX(I)=PSOX9_"," K:PSOX9="" BBRX(I) + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLDS4.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLDS4.m index eeadbd8d..8e9efbbf 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLDS4.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLDS4.m @@ -1,84 +1,83 @@ -PSOHLDS4 ;BIR/PWC-Build HL7 Segments for Automated Interface ; 2/13/08 3:21pm - ;;7.0;OUTPATIENT PHARMACY;**156,255,279**;DEC 1997;Build 9 - ;HLFNC supp. by DBIA 10106 - ;DIC(5 supp. by DBIA 10056 - ;EN^PSNPPIO supp. by DBIA 3794 - ;This routine is called from PSOHLDS1 - ; - ;*255 moved tag NTEPMI from PSOHLDS2 - Q -IAM(PSI) ;allergy list segment - Q:'$D(DFN)!$D(PAS3) - N IAM,IDX,SEV,SEV1,DAT,X,TYP,TYP1,VER,VER1 - S IAM="",CNT=0,GMRA="0^0^111" D EN1^GMRADPT - I $G(GMRAL)="" G ZALQT - F AIEN=0:0 S AIEN=$O(GMRAL(AIEN)) Q:'AIEN D - .K ADTL D EN1^GMRAOR2(AIEN,"ADTL") S CNT=CNT+1 - .S TYP1=$P(GMRAL(AIEN),"^",7) - .S TYP=$S(TYP1="D":"DRUG",TYP1="F":"FOOD",TYP1="O":"OTHER",TYP1="DF":"DRUG/FOOD",TYP1="DO":"DRUG/OTHER",TYP1="DFO":"DRUG/FOOD/OTHER",1:"""""") - .S VER=$S($P(GMRAL(AIEN),"^",4)=1:"VERIFIED",1:"NON-VERIFIED") - .S VER1=$S($P(GMRAL(AIEN),"^",4)=1:"C",1:"U") ;confirmed or unconfirmed - .S $P(IAM,"|",2)=TYP1_CS_TYP_CS_"LGMR120.8" - .S $P(IAM,"|",3)=AIEN_CS_$P(GMRAL(AIEN),"^",2)_CS_"LGMR120.8" - .S IDX=$O(ADTL("O","")),X="" S:IDX'="" X=$G(ADTL("O",IDX)) - .S DAT=$P(X,"^"),DAT=$S(DAT'="":$$HLDATE^HLFNC(DAT,"DT"),1:"") - .S SEV=$P(X,"^",2) S:SEV="" SEV="""""",DAT="" - .S SEV1=$S(SEV="MILD":"MI",SEV="MODERATE":"MO",SEV="SEVERE":"SV",1:"U") - .S $P(IAM,"|",4)=SEV1 - .S $P(IAM,"|",5)=$P($P(GMRAL(AIEN),"^",8),";") - .S $P(IAM,"|",13)=DAT - .S $P(IAM,"|",17)=VER1 - .S ^TMP("PSO",$J,PSI)="IAM|"_IAM,PSI=PSI+1 - .F S IDX=$O(ADTL("O",IDX)) Q:IDX="" D ;repeat for all reactions - ..S X=$G(ADTL("O",IDX)),DAT=$P(X,"^"),SEV=$P(X,"^",2) I SEV="" Q - ..S DAT=$S(DAT'="":$$HLDATE^HLFNC(DAT,"DT"),1:"") - ..S $P(IAM,FS,4)=SEV,$P(IAM,FS,13)=DAT - ..S ^TMP("PSO",$J,PSI)="IAM|"_IAM,PSI=PSI+1 - S PAS3=1 - ; -ZALQT K GMRAL,ADTL,AIEN,CNT,CNT,GMRA,TYP,TYP1,SEV,SEV1,VER,VER1 - Q - ; -ORC(PSI) ;common order segment - Q:'$D(DFN) - N ORC S ORC="" - S $P(ORC,"|",1)="NW" - S $P(ORC,"|",2)=IRXN_CS_"OP7.0" - S $P(ORC,"|",9)=ISDT - S $P(ORC,"|",10)=EBY_CS_EBY1 - S $P(ORC,"|",12)=PVDR_CS_PVDR1 - S $P(ORC,"|",13)=$G(PSOLAP) - S $P(ORC,"|",15)=EFDT - S $P(ORC,"|",16)=$S($G(RXPR(IRXN)):"PARTIAL",$G(RXFL(IRXN)):"REFILL",$G(RXRP(IRXN)):"REPRINT",1:"NEW") - S $P(ORC,"|",17)=CLN_CS_CLN1_CS_"99PSC" - S $P(ORC,"|",19)=$S(CSINER'="":CSINER_CS_CSINER1,1:"") - S $P(ORC,"|",21)=$P(SITE,"^",1)_CS_CS_$P(SITE,"^",6) - S PSZIP=$P(SITE,"^",5),PSOHZIP=$S(PSZIP["-":PSZIP,1:$E(PSZIP,1,5)_$S($E(PSZIP,6,9)]"":"-"_$E(PSZIP,6,9),1:"")) - S $P(ORC,"|",22)=$P(SITE,"^",2)_CS_CS_$P(SITE,"^",7)_CS_$S($D(^DIC(5,+$P(SITE,"^",8),0)):$P(^(0),"^",2),1:"UKN")_CS_PSOHZIP - S $P(ORC,"|",23)="("_$P(SITE,"^",3)_")"_$P(SITE,"^",4) - S ^TMP("PSO",$J,PSI)="ORC|"_ORC,PSI=PSI+1 - Q - ; -NTEPMI(PSI) ;build NTE segment for PMI sheets ;*255 - Q:'$D(DFN) N A,I,PREVLN,CURRLN,PMI,PSNMSG,PSDRUG - S PSDRUG=+$P(^PSRX(IRXN,0),"^",6),PMI=$$EN^PSNPPIO(PSDRUG,.PSNMSG) - Q:'$D(^TMP($J,"PSNPMI")) - ;PSO*7*279 Add missing PMI ID(7) to NTE Segment - S ^TMP("PSO",$J,PSI)="NTE"_FS_7_FS_FS_^TMP($J,"PSNPMI",0) - K A S CNT1=1,CNT=0 - F A="W","U","H","S","M","P","I","O","N","D","R" S CNT=CNT+1,A(CNT)=A - F I=1:1:11 I $D(^TMP($J,"PSNPMI",A(I))) D - .S CNT=$P(^TMP($J,"PSNPMI",A(I),0),"^",3) - .S (PREVLN,CURRLN)="" - .F J=1:1:CNT D - .. S ^TMP("PSO",$J,PSI,CNT1)=^TMP($J,"PSNPMI",A(I),J,0) - .. ;PSO*198 check if " " should be inserted - .. S CURRLN=^TMP("PSO",$J,PSI,CNT1) - .. S:CNT1>1 PREVLN=$S(CNT>1:^TMP("PSO",$J,PSI,CNT1-1),1:"") - .. I CNT1>1,$$SPACE^PSOHLDS3(PREVLN,CURRLN) D - ... S ^TMP("PSO",$J,PSI,CNT1)=" "_^TMP("PSO",$J,PSI,CNT1) - .. I J=1 S $P(^TMP("PSO",$J,PSI,CNT1),":",1)="\H\"_$P(^TMP("PSO",$J,PSI,CNT1),":",1)_"\N\" - .. S CNT1=CNT1+1 - S ^TMP("PSO",$J,PSI,CNT1-1)=^TMP("PSO",$J,PSI,CNT1-1)_FS_"Patient Medication Instructions" - S PSI=PSI+1 K A,I,J,CNT,CNT1,^TMP($J,"PSNPMI") - Q +PSOHLDS4 ;BIR/PWC-Build HL7 Segments for Automated Interface ;11/13/06 1:13pm + ;;7.0;OUTPATIENT PHARMACY;**156,255**;DEC 1997;Build 9 + ;HLFNC supp. by DBIA 10106 + ;DIC(5 supp. by DBIA 10056 + ;EN^PSNPPIO supp. by DBIA 3794 + ;This routine is called from PSOHLDS1 + ; + ;*255 moved tag NTEPMI from PSOHLDS2 + Q +IAM(PSI) ;allergy list segment + Q:'$D(DFN)!$D(PAS3) + N IAM,IDX,SEV,SEV1,DAT,X,TYP,TYP1,VER,VER1 + S IAM="",CNT=0,GMRA="0^0^111" D EN1^GMRADPT + I $G(GMRAL)="" G ZALQT + F AIEN=0:0 S AIEN=$O(GMRAL(AIEN)) Q:'AIEN D + .K ADTL D EN1^GMRAOR2(AIEN,"ADTL") S CNT=CNT+1 + .S TYP1=$P(GMRAL(AIEN),"^",7) + .S TYP=$S(TYP1="D":"DRUG",TYP1="F":"FOOD",TYP1="O":"OTHER",TYP1="DF":"DRUG/FOOD",TYP1="DO":"DRUG/OTHER",TYP1="DFO":"DRUG/FOOD/OTHER",1:"""""") + .S VER=$S($P(GMRAL(AIEN),"^",4)=1:"VERIFIED",1:"NON-VERIFIED") + .S VER1=$S($P(GMRAL(AIEN),"^",4)=1:"C",1:"U") ;confirmed or unconfirmed + .S $P(IAM,"|",2)=TYP1_CS_TYP_CS_"LGMR120.8" + .S $P(IAM,"|",3)=AIEN_CS_$P(GMRAL(AIEN),"^",2)_CS_"LGMR120.8" + .S IDX=$O(ADTL("O","")),X="" S:IDX'="" X=$G(ADTL("O",IDX)) + .S DAT=$P(X,"^"),DAT=$S(DAT'="":$$HLDATE^HLFNC(DAT,"DT"),1:"") + .S SEV=$P(X,"^",2) S:SEV="" SEV="""""",DAT="" + .S SEV1=$S(SEV="MILD":"MI",SEV="MODERATE":"MO",SEV="SEVERE":"SV",1:"U") + .S $P(IAM,"|",4)=SEV1 + .S $P(IAM,"|",5)=$P($P(GMRAL(AIEN),"^",8),";") + .S $P(IAM,"|",13)=DAT + .S $P(IAM,"|",17)=VER1 + .S ^TMP("PSO",$J,PSI)="IAM|"_IAM,PSI=PSI+1 + .F S IDX=$O(ADTL("O",IDX)) Q:IDX="" D ;repeat for all reactions + ..S X=$G(ADTL("O",IDX)),DAT=$P(X,"^"),SEV=$P(X,"^",2) I SEV="" Q + ..S DAT=$S(DAT'="":$$HLDATE^HLFNC(DAT,"DT"),1:"") + ..S $P(IAM,FS,4)=SEV,$P(IAM,FS,13)=DAT + ..S ^TMP("PSO",$J,PSI)="IAM|"_IAM,PSI=PSI+1 + S PAS3=1 + ; +ZALQT K GMRAL,ADTL,AIEN,CNT,CNT,GMRA,TYP,TYP1,SEV,SEV1,VER,VER1 + Q + ; +ORC(PSI) ;common order segment + Q:'$D(DFN) + N ORC S ORC="" + S $P(ORC,"|",1)="NW" + S $P(ORC,"|",2)=IRXN_CS_"OP7.0" + S $P(ORC,"|",9)=ISDT + S $P(ORC,"|",10)=EBY_CS_EBY1 + S $P(ORC,"|",12)=PVDR_CS_PVDR1 + S $P(ORC,"|",13)=$G(PSOLAP) + S $P(ORC,"|",15)=EFDT + S $P(ORC,"|",16)=$S($G(RXPR(IRXN)):"PARTIAL",$G(RXFL(IRXN)):"REFILL",$G(RXRP(IRXN)):"REPRINT",1:"NEW") + S $P(ORC,"|",17)=CLN_CS_CLN1_CS_"99PSC" + S $P(ORC,"|",19)=$S(CSINER'="":CSINER_CS_CSINER1,1:"") + S $P(ORC,"|",21)=$P(SITE,"^",1)_CS_CS_$P(SITE,"^",6) + S PSZIP=$P(SITE,"^",5),PSOHZIP=$S(PSZIP["-":PSZIP,1:$E(PSZIP,1,5)_$S($E(PSZIP,6,9)]"":"-"_$E(PSZIP,6,9),1:"")) + S $P(ORC,"|",22)=$P(SITE,"^",2)_CS_CS_$P(SITE,"^",7)_CS_$S($D(^DIC(5,+$P(SITE,"^",8),0)):$P(^(0),"^",2),1:"UKN")_CS_PSOHZIP + S $P(ORC,"|",23)="("_$P(SITE,"^",3)_")"_$P(SITE,"^",4) + S ^TMP("PSO",$J,PSI)="ORC|"_ORC,PSI=PSI+1 + Q + ; +NTEPMI(PSI) ;build NTE segment for PMI sheets ;*255 + Q:'$D(DFN) N A,I,PREVLN,CURRLN,PMI,PSNMSG,PSDRUG + S PSDRUG=+$P(^PSRX(IRXN,0),"^",6),PMI=$$EN^PSNPPIO(PSDRUG,.PSNMSG) + Q:'$D(^TMP($J,"PSNPMI")) + S ^TMP("PSO",$J,PSI)="NTE"_FS_^TMP($J,"PSNPMI",0)_FS + K A S CNT1=1,CNT=0 + F A="W","U","H","S","M","P","I","O","N","D","R" S CNT=CNT+1,A(CNT)=A + F I=1:1:11 I $D(^TMP($J,"PSNPMI",A(I))) D + .S CNT=$P(^TMP($J,"PSNPMI",A(I),0),"^",3) + .S (PREVLN,CURRLN)="" + .F J=1:1:CNT D + .. S ^TMP("PSO",$J,PSI,CNT1)=^TMP($J,"PSNPMI",A(I),J,0) + .. ;PSO*198 check if " " should be inserted + .. S CURRLN=^TMP("PSO",$J,PSI,CNT1) + .. S:CNT1>1 PREVLN=$S(CNT>1:^TMP("PSO",$J,PSI,CNT1-1),1:"") + .. I CNT1>1,$$SPACE^PSOHLDS3(PREVLN,CURRLN) D + ... S ^TMP("PSO",$J,PSI,CNT1)=" "_^TMP("PSO",$J,PSI,CNT1) + .. I J=1 S $P(^TMP("PSO",$J,PSI,CNT1),":",1)="\H\"_$P(^TMP("PSO",$J,PSI,CNT1),":",1)_"\N\" + .. S CNT1=CNT1+1 + S ^TMP("PSO",$J,PSI,CNT1-1)=^TMP("PSO",$J,PSI,CNT1-1)_FS_"Patient Medication Instructions" + S PSI=PSI+1 K A,I,J,CNT,CNT1,^TMP($J,"PSNPMI") + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLEXP.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLEXP.m index 54de57ba..11a71266 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLEXP.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLEXP.m @@ -1,66 +1,43 @@ -PSOHLEXP ;BIR/RTR-Auto expire prescriptions ; 10/10/07 11:16am - ;;7.0;OUTPATIENT PHARMACY;**10,22,36,73,148,257**;DEC 1997;Build 19 - ; - ;External reference to ^PS(59.7 supported by DBIA 694 - ;External reference to STATUS^ORQOR2 is supported by DBIA 3458 - ;External references to LOCK1^ORX2 and UNLK1^ORX2 are supported by DBIA 867 -EN N PSOEXRX,PSOEXCOM,PSOEXSTS,SUSD,PSOEXSTA,ZZDT,ZZEDT,IFN,NODE,RF,PIFN,PSUSD,PRFDT,PDA,PSDTEST,ORN,CPRSDC - I '$G(DT) S DT=$$DT^XLFDT - S X1=DT,X2=-1 D C^%DTC S ZZEDT=X - S ZZDT=$P($G(^PS(59.7,1,49.99)),"^",8) I +ZZDT=0 S X1=DT,X2=-2 D C^%DTC S ZZDT=X - F S ZZDT=$O(^PSRX("AG",ZZDT)) Q:ZZDT>ZZEDT Q:ZZDT="" D EN1 - Q -EN1 F PSOEXRX=0:0 S PSOEXRX=$O(^PSRX("AG",ZZDT,PSOEXRX)) Q:'PSOEXRX D:$D(^PSRX(PSOEXRX,0)) - .N CPRSDC,CPRSSTA - .S CPRSDC=",1,7,12,13," - .S ORN=$P($G(^PSRX(PSOEXRX,"OR1")),"^",2),CPRSSTA="" - .I ORN S CPRSSTA=+$$STATUS^ORQOR2(ORN) I CPRSSTA=0 S ORN="" - .Q:$P($G(^PSRX(PSOEXRX,2)),"^",6)'=ZZDT - .K CMOP S DA=PSOEXRX I DA D ^PSOCMOPA ;*257 ;SET UP CMOP() ARRAY - .S DA=$O(^PS(52.5,"B",PSOEXRX,0)) - .I DA S SUSD=$P($G(^PS(52.5,DA,0)),"^",2) I SUSD,$P($G(^(0)),"^",3) S DIK="^PS(52.5," D ^DIK K DIK - .I $D(^PS(52.4,PSOEXRX,0)) S DIK="^PS(52.4,",DA=PSOEXRX D ^DIK K DIK - .I $G(^PSRX(PSOEXRX,"H"))]"" K:$P(^PSRX(PSOEXRX,"H"),"^") ^PSRX("AH",$P(^PSRX(PSOEXRX,"H"),"^"),PSOEXRX) S ^PSRX(PSOEXRX,"H")="" - .S PSOEXSTA=$P($G(^PSRX(PSOEXRX,"STA")),"^") - .I PSOEXSTA=13 D Q - ..I 'ORN D EN^PSOHDR("PRES",PSOEXRX) - .I PSOEXSTA=12!(PSOEXSTA=14)!(PSOEXSTA=15) I ORN,CPRSDC'[(","_CPRSSTA_",") D - ..D EN^PSOHLSN1(PSOEXRX,"OD","","","A") - ..I ORN S CPRSSTA=+$$STATUS^ORQOR2(ORN) - .I PSOEXSTA=11 I ORN,CPRSDC'[(","_CPRSSTA_",") D - ..S $P(^PSRX(PSOEXRX,0),"^",19)=1 - ..D EN^PSOHLSN1(PSOEXRX,"SC","ZE","Prescription is expired") - .I PSOEXSTA>9&(PSOEXSTA'=16) Q - .S $P(^PSRX(PSOEXRX,"STA"),"^")=11 - .D REVERSE^PSOBPSU1(PSOEXRX,0,"DE",5,"RX EXPIRED") - .S (PIFN,PSUSD,PRFDT)=0 F S PIFN=$O(^PSRX(PSOEXRX,1,PIFN)) Q:'PIFN S PSUSD=PIFN,PRFDT=+$P($G(^PSRX(PSOEXRX,1,PIFN,0)),"^") - .S ORN=$P($G(^PSRX(PSOEXRX,"OR1")),"^",2) - .I $G(PSUSD) I '$P($G(^PSRX(PSOEXRX,1,PSUSD,0)),"^",18) S PSDTEST=0 D I 'PSDTEST K ^PSRX(PSOEXRX,1,PSUSD),^PSRX("AD",PRFDT,PSOEXRX,PSUSD),^PSRX(PSOEXRX,1,"B",PRFDT,PSUSD) D NSET - ..D REVERSE^PSOBPSU1(PSOEXRX,PSUSD,"DE",5,"RX EXPIRED") - ..F PDA=0:0 S PDA=$O(^PSRX(PSOEXRX,"L",PDA)) Q:'PDA I $P($G(^PSRX(PSOEXRX,"L",PDA,0)),"^",2)=PSUSD S PSDTEST=1 - ..I $G(CMOP(CMOP("L")))="",".L.X."[("."_$G(CMOP("S"))_".") S PSDTEST=1 - ..N PSOORL - ..S PSOORL=$$LOCK1^ORX2(ORN) S:'PSOORL PSDTEST=1 I PSOORL D UNLK1^ORX2(ORN) - ..N PDA0 - ..;S PDAQ=0 - ..F PDA=0:0 S PDA=$O(^PSRX(PSOEXRX,4,PDA)) Q:'PDA D - ...S PDA0=$G(^PSRX(PSOEXRX,4,PDA,0)) - ...I $P(PDA0,"^",3)=PSUSD S PSDTEST=1 ;*257 - ..;Q:'PDAQ - ..;S PSDTEST=1 - .I 'ORN D EN^PSOHDR("PRES",PSOEXRX) Q - .I CPRSDC[(","_CPRSSTA_",") D EN^PSOHDR("PRES",PSOEXRX) Q - .S $P(^PSRX(PSOEXRX,0),"^",19)=1 - .S PSOEXCOM="Prescription past expiration date" D EN^PSOHLSN1(PSOEXRX,"SC","ZE",PSOEXCOM) - S DIE=59.7,DA=1,DR="49.95///"_ZZDT D ^DIE K DIE,DA,DR - Q -NSET ; - N PSONM,PSONMX - S PSONM="" F PSONMX=0:0 S PSONMX=$O(^PSRX(PSOEXRX,1,PSONMX)) Q:'PSONMX S PSONM=PSONMX - S ^PSRX(PSOEXRX,1,0)="^52.1DA^"_$G(PSONM)_"^"_$G(PSONM) - Q -SETUP ; - K %DT,DIC,DTOUT S DIC(0)="XZM",DIC="^DIC(19.2,",X="PSO EXPIRE PRESCRIPTIONS" D ^DIC - I +Y>0 D EDIT^XUTMOPT("PSO EXPIRE PRESCRIPTIONS") K DIC,Y,X Q - D RESCH^XUTMOPT("PSO EXPIRE PRESCRIPTIONS","","","24H","L"),EDIT^XUTMOPT("PSO EXPIRE PRESCRIPTIONS") K DIC,Y,X -OUT Q +PSOHLEXP ;BIR/RTR-Auto expire prescriptions ;10/10/96 + ;;7.0;OUTPATIENT PHARMACY;**10,22,36,73,148**;DEC 1997 + ;External reference to STATUS^ORQOR2 is supported by DBIA 3458 + ; +EN N PSOEXRX,PSOEXCOM,PSOEXSTS,SUSD,PSOEXSTA,ZZDT,IFN,NODE,RF,PIFN,PSUSD,PRFDT,PDA,PSDTEST,ORN + I '$G(DT) S DT=$$DT^XLFDT + S X1=DT,X2=-1 D C^%DTC S ZZDT=X + F PSOEXRX=0:0 S PSOEXRX=$O(^PSRX("AG",ZZDT,PSOEXRX)) Q:'PSOEXRX D:$D(^PSRX(PSOEXRX,0)) + .Q:$P($G(^PSRX(PSOEXRX,2)),"^",6)'=ZZDT + .S DA=$O(^PS(52.5,"B",PSOEXRX,0)) + .I DA S SUSD=$P($G(^PS(52.5,DA,0)),"^",2) I SUSD,$P($G(^(0)),"^",3) S DIK="^PS(52.5," D ^DIK K DIK + .I $D(^PS(52.4,PSOEXRX,0)) S DIK="^PS(52.4,",DA=PSOEXRX D ^DIK K DIK + .I $G(^PSRX(PSOEXRX,"H"))]"" K:$P(^PSRX(PSOEXRX,"H"),"^") ^PSRX("AH",$P(^PSRX(PSOEXRX,"H"),"^"),PSOEXRX) S ^PSRX(PSOEXRX,"H")="" + .S PSOEXSTA=$P($G(^PSRX(PSOEXRX,"STA")),"^") + .Q:PSOEXSTA=13!(PSOEXSTA="") + .I '$P($G(^PSRX(PSOEXRX,"OR1")),"^",2) D EN^PSOHLSN1(PSOEXRX,"ZC","") I $P($G(^PSRX(PSOEXRX,"OR1")),"^",2) D + ..I PSOEXSTA=12!(PSOEXSTA=14)!(PSOEXSTA=15) D EN^PSOHLSN1(PSOEXRX,"OD","","","A") + .I PSOEXSTA=11 S ORN=$P($G(^PSRX(PSOEXRX,"OR1")),"^",2) I ORN,+$$STATUS^ORQOR2(ORN)=6 D + ..S $P(^PSRX(PSOEXRX,0),"^",19)=1 + ..D EN^PSOHLSN1(PSOEXRX,"SC","ZE","Prescription is expired") + .Q:PSOEXSTA>9 + .S $P(^PSRX(PSOEXRX,"STA"),"^")=11 + .I '$G(PSUSD) D REVERSE^PSOBPSU1(PSOEXRX,0,"DE",5,"RX EXPIRED") + .S (PIFN,PSUSD,PRFDT)=0 F S PIFN=$O(^PSRX(PSOEXRX,1,PIFN)) Q:'PIFN S PSUSD=PIFN,PRFDT=+$P($G(^PSRX(PSOEXRX,1,PIFN,0)),"^") + .I $G(PSUSD) I '$P($G(^PSRX(PSOEXRX,1,PSUSD,0)),"^",18) S PSDTEST=0 D I 'PSDTEST K ^PSRX(PSOEXRX,1,PSUSD),^PSRX("AD",PRFDT,PSOEXRX,PSUSD),^PSRX(PSOEXRX,1,"B",PRFDT,PSUSD) D NSET + ..D REVERSE^PSOBPSU1(PSOEXRX,PSUSD,"DE",5,"RX EXPIRED") + ..F PDA=0:0 S PDA=$O(^PSRX(PSOEXRX,"L",PDA)) Q:'PDA I $P($G(^PSRX(PSOEXRX,"L",PDA,0)),"^",2)=PSUSD S PSDTEST=1 + ..S DA=PSOEXRX K CMOP D ^PSOCMOPA I $G(CMOP(CMOP("L")))="",$G(CMOP("S"))'="L" Q + ..S PSDTEST=1 + .Q:'$P($G(^PSRX(PSOEXRX,"OR1")),"^",2) + .S $P(^PSRX(PSOEXRX,0),"^",19)=1 + .S PSOEXCOM="Prescription past expiration date" D EN^PSOHLSN1(PSOEXRX,"SC","ZE",PSOEXCOM) + Q +NSET ; + N PSONM,PSONMX + S PSONM="" F PSONMX=0:0 S PSONMX=$O(^PSRX(PSOEXRX,1,PSONMX)) Q:'PSONMX S PSONM=PSONMX + S ^PSRX(PSOEXRX,1,0)="^52.1DA^"_$G(PSONM)_"^"_$G(PSONM) + Q +SETUP ; + K %DT,DIC,DTOUT S DIC(0)="XZM",DIC="^DIC(19.2,",X="PSO EXPIRE PRESCRIPTIONS" D ^DIC + I +Y>0 D EDIT^XUTMOPT("PSO EXPIRE PRESCRIPTIONS") K DIC,Y,X Q + D RESCH^XUTMOPT("PSO EXPIRE PRESCRIPTIONS","","","24H","L"),EDIT^XUTMOPT("PSO EXPIRE PRESCRIPTIONS") K DIC,Y,X +OUT Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLNE1.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLNE1.m index 56c18245..a73e2fde 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLNE1.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLNE1.m @@ -1,174 +1,175 @@ -PSOHLNE1 ;BIR/RTR-Parsing out segments from OERR ;01/20/95 - ;;7.0;OUTPATIENT PHARMACY;**1,9,46,71,98,111,117,131,157,181,143,235,239,225**;DEC 1997;Build 29 - ;External reference to EN^ORERR supported by DBIA 2187 - ;External reference to PS(50.607 supported by DBIA 2221 - ;External reference to OR(100 supported by DBIA 2219 - ;External reference to PSDRUG( supported by DBIA 221 - ;External reference VADPT supported by DBIA 10061 - ; -EN ;ORC segment - N Q1,Q2,Q3,Q4,Q5,Q6,Q7,PSOPOSSD - K PSOLQ1I,PSOLQ1II,PSOLQ1IX - I '$O(MSG(ZZ,0)) D - .S PSOOC="NW",PLACER=+$P(PSOSEG,"|",2),PLACERXX=+$P($P(PSOSEG,"|",2),";",2),ENTERED=$P(PSOSEG,"|",10),PROV=$P(PSOSEG,"|",12) - .S X=$P(PSOSEG,"|",15) S EFFECT=$$HL7TFM^XLFDT(X) K X - .D NOW^%DTC S PSOLOG=% K % - .;S RSN=$P(PSOSEG,"|",16) - .S ORCSEG=$P(PSOSEG,"|",7),QCOUNT=1 Q:$G(ORCSEG)'["~" - .F JJ=1:1:$L(ORCSEG) S:$E(ORCSEG,JJ)="~" QCOUNT=QCOUNT+1 - I '$O(MSG(ZZ,0)) D Q - .F JJJ=1:1:QCOUNT S QQQ=$P(ORCSEG,"~",JJJ) D:QQQ'="" - ..S PSOPOSSD=$S($P($P(QQQ,"^"),"&"):1,1:0) ;PSOPOSSD=1 if possible dose - ..S Q1I(JJJ)=$S(PSOPOSSD:$P(QQQ,"^"),1:$P(QQQ,"^",8)),PSOLQ1IX(JJJ)=$P($P(QQQ,"^"),"&",5) S PSOLQ1I(JJJ)=$P(QQQ,"^",8),PSOLQ1II(JJJ)=PSOPOSSD ;ORC piece 1 if Possible Dosage, ORC piece 8 if Local Possible Dosage - ..S Q1(JJJ)=$P(QQQ,"^",2) ;schedule - ..S Q2(JJJ)=$P(QQQ,"^",3) ;duration - ..S Q3(JJJ)=$P(QQQ,"^",4) I Q3(JJJ) S X=Q3(JJJ) S Q3(JJJ)=$$HL7TFM^XLFDT(X) K X ;start date - ..S Q4(JJJ)=$P(QQQ,"^",5) ;end date - ..S:$G(PRIOR)="" PRIOR=$P(QQQ,"^",6) - ..S Q6(JJJ)=$P(QQQ,"^",9) ;conjunction - ..S Q7(JJJ)=$P(QQQ,"^",10) ;sequencing - ..S QTARRAY(JJJ)=Q1(JJJ)_"^"_Q2(JJJ)_"^"_Q3(JJJ)_"^"_Q4(JJJ)_"^^"_Q6(JJJ)_"^"_Q7(JJJ) - ..S QTARRAY2(JJJ)=$S(PSOPOSSD:$P(Q1I(JJJ),"&"),1:Q1I(JJJ))_"^"_$S(PSOPOSSD:$P(Q1I(JJJ),"&",3),1:"") - ..I PSOPOSSD S $P(QTARRAY(JJJ),"^",5)=$P(Q1I(JJJ),"&",4) - ..I PSOPOSSD S PSOUNN=$P(Q1I(JJJ),"&",2) I PSOUNN'="" S PSOUNN=$O(^PS(50.607,"B",PSOUNN,0)) S $P(QTARRAY(JJJ),"^",9)=$G(PSOUNN) - ..K PSOUNN - ;For multiple ORC subscripts - S (POVAR,POVAR1)="",(NNCK,NNN,NNNN)=0,PSOIII=1,MSG(ZZ,0)=$E(MSG(ZZ),5,$L(MSG(ZZ))) - S AAA="" F S AAA=$O(MSG(ZZ,AAA)) Q:AAA="" S NNN=0 F OOO=1:1:$L(MSG(ZZ,AAA)) S NNN=NNN+1 D D:$G(POVAR1)="~"&(NNNN=6) PARSE D:$G(POVAR1)="|" PARSE - .I $E(MSG(ZZ,AAA),OOO)="|" S NNNN=NNNN+1 - .S POVAR1=$E(MSG(ZZ,AAA),OOO) - .S POLIM=POVAR - .S POVAR=$S(POVAR="":POVAR1,1:POVAR_POVAR1) - .;I NNNN=6 I $G(POVAR1)="~"!($G(POVAR1)="|") -END ;16 OF ORC? - ;I $G(POVAR)'="" I NNNN=14!(NNNN=15) S EFFECT=$G(POVAR) - S QCOUNT=0 F JJJ=0:0 S JJJ=$O(QTVAR(JJJ)) Q:'JJJ I $L($G(QTVAR(JJJ))) S QCOUNT=QCOUNT+1 D - .S PSOPOSSD=$S($P($P(QTVAR(JJJ),"^"),"&"):1,1:0) ;PSOPOSSD =1 if possible dose - .S Q1I(JJJ)=$S(PSOPOSSD:$P(QTVAR(JJJ),"^"),1:$P(QTVAR(JJJ),"^",8)),PSOLQ1IX(JJJ)=$P($P(QTVAR(JJJ),"^"),"&",5) S PSOLQ1I(JJJ)=$P(QTVAR(JJJ),"^",8),PSOLQ1II(JJJ)=PSOPOSSD ;piece 1 if possible dose, piece 8 if not - .S Q1(JJJ)=$P(QTVAR(JJJ),"^",2) - .S Q2(JJJ)=$P(QTVAR(JJJ),"^",3) - .;S Q2(JJJ)=$S($E($P(QTVAR(JJJ),"^",3)):"D"_$P(QTVAR(JJJ),"^",3),$E($P(QTVAR(JJJ),"^",3))=0:"D"_$P(QTVAR(JJJ),"^",3),1:$P(QTVAR(JJJ),"^",3)) - .S Q3(JJJ)=$P(QTVAR(JJJ),"^",4) I Q3(JJJ) S X=Q3(JJJ) S Q3(JJJ)=$$HL7TFM^XLFDT(X) K X - .S Q4(JJJ)=$P(QTVAR(JJJ),"^",5) - .S:$G(PRIOR)="" PRIOR=$P(QTVAR(JJJ),"^",6) - .S Q6(JJJ)=$P(QTVAR(JJJ),"^",9) - .S Q7(JJJ)=$P(QTVAR(JJJ),"^",10) - .S QTARRAY(JJJ)=Q1(JJJ)_"^"_Q2(JJJ)_"^"_Q3(JJJ)_"^"_Q4(JJJ)_"^^"_Q6(JJJ)_"^"_Q7(JJJ) - .S QTARRAY2(JJJ)=$S(PSOPOSSD:$P(Q1I(JJJ),"&"),1:Q1I(JJJ))_"^"_$S(PSOPOSSD:$P(Q1I(JJJ),"&",3),1:"") - .I PSOPOSSD S $P(QTARRAY(JJJ),"^",5)=$P(Q1I(JJJ),"&",4) - .I PSOPOSSD S PSOUNN=$P(Q1I(JJJ),"&",2) I PSOUNN'="" S PSOUNN=$O(^PS(50.607,"B",PSOUNN,0)) S $P(QTARRAY(JJJ),"^",9)=$G(PSOUNN) - .K PSOUNN - I $G(EFFECT) S X=EFFECT S EFFECT=$$HL7TFM^XLFDT(X) K X - D NOW^%DTC S PSOLOG=% S:'$G(EFFECT) EFFECT=% K % - K MSG(ZZ,0) - Q -PARSE I NNNN=1 S PSOOC="NW" G SET - I NNNN=2 S PLACER=+$G(POLIM),PLACERXX=+$P($G(POLIM),";",2) G SET - I NNNN=3!(NNNN=4)!(NNNN=5) G SET - I NNNN=6,$G(POVAR1)="~" S NNCK=NNCK+1,QTVAR(NNCK)=$G(POLIM) G SET - I NNNN=7 S NNCK=NNCK+1 S QTVAR(NNCK)=$G(POLIM) G SET - I NNNN=8!(NNNN=9) G SET - I NNNN=10 S ENTERED=$G(POLIM) G SET - I NNNN=11 G SET - I NNNN=12 S PROV=$G(POLIM) G SET - I NNNN=13!(NNNN=14) G SET - I NNNN=15 S EFFECT=$G(POLIM) -SET S (POVAR,POLIM)="" Q - ; -EXP ; - ;Q:'$G(OR("PLACE")) - Q:'$G(PSOFILNM) - S PSOMSORR=1 - N PSOSSMES S PSOSSMES="CPRSUP" - I $G(PSOFILNM),$G(PSOFILNM)["S" S LL=+$G(PSOFILNM) I $D(^PS(52.41,LL,0)),$P($G(^(0)),"^",3)'="RF" G EXPEN - S LL=$G(PSOFILNM) I 'LL!('$D(^PSRX(+$G(LL),0))) S COMM="Order was not located by Pharmacy" D EN^ORERR(COMM,.MSG) D G EXPQ - .F EER=0:0 S EER=$O(MSG(EER)) Q:'EER S:$P(MSG(EER),"|")="PV1" PSERRPV1=MSG(EER) S:$P(MSG(EER),"|")="PID" PSERRPID=MSG(EER) S:$P(MSG(EER),"|")="ORC"&($G(PSERRORC)="") PSERRORC=MSG(EER) - .N MSG,PSOHINST D INIT^PSOHLSN S MSG(2)=$G(PSERRPID),MSG(3)=$G(PSERRPV1),MSG(4)="ORC|DE|"_$G(OR("PLACE"))_$S($G(PLACERXX):";"_PLACERXX,1:"")_"^OR"_"|"_$S($P($G(PSERRORC),"|",4)'="":$P(PSERRORC,"|",4),1:"") S:$G(COMM)'="" MSG(5)="NTE|16||"_COMM - .D SEND^PSOHLSN - Q:'$D(^PSRX(LL,0)) - I +$P($G(^PSRX(LL,2)),"^",6)
$P($G(^("I")),"^"):1,1:0),$P($G(^PSDRUG(PSOCDD,2)),"^",3)["O" S PSOCDDI=PSOCDDI+1,PSOCDDIZ=PSOCDD - I PSOCDDI'=1 Q - S PSOQWX=$G(PSOCDDIZ) - Q -CP ;ZSC segment (replaced by ZCL segment) - S SERV=$S($P(PSOSEG,"|")=1:"SC",$P(PSOSEG,"|")=0:"NSC",1:$P(PSOSEG,"|")) - S PSOIBY=$P(PSOSEG,"|",2)_"^"_$P(PSOSEG,"|",3)_"^"_$P(PSOSEG,"|",4)_"^"_$P(PSOSEG,"|",5)_"^"_$P(PSOSEG,"|",6)_"^"_$P(PSOSEG,"|",7)_"^"_$P(PSOSEG,"|",8) - Q - ; -ZCL ;ZCL segment - SC/EI related to ICDs - N SEQ,SEQ2,SEQ3 S SEQ3=$P(PSOSEG,"|",2),SEQ2=$P(PSOSEG,"|",1) - S:'$D(PSOICD(SEQ2)) PSOICD(SEQ2)="" - S $P(PSOICD(SEQ2),"^",(SEQ3+1))=$P(PSOSEG,"|",3) ;set sc/ei for ICD node - D SCP^PSORN52D K PSOSCA - S:'$D(PSOIBY) PSOIBY="" - I PSOSCP<50 D ;set IBQ node variables if <50% SC - . Q:$P(PSOIBY,U,$S(SEQ3=1:2,SEQ3=2:3,SEQ3=4:4,SEQ3=5:1,SEQ3=6:5,SEQ3=7:6,SEQ3=8:7,1:""))>0 - . S:SEQ3=1 $P(PSOIBY,U,2)=$P(PSOSEG,"|",3) ;AO - . S:SEQ3=2 $P(PSOIBY,U,3)=$P(PSOSEG,"|",3) ;IR - . S:SEQ3=3 SERV=$S($P(PSOSEG,"|",3)=1:"SC",$P(PSOSEG,"|",3)=0:"NSC",1:$P(PSOSEG,"|",3)) ;SC - . S:SEQ3=4 $P(PSOIBY,U,4)=$P(PSOSEG,"|",3) ;EC - . S:SEQ3=5 $P(PSOIBY,U,1)=$P(PSOSEG,"|",3) ;MST - . S:SEQ3=6 $P(PSOIBY,U,5)=$P(PSOSEG,"|",3) ;HNC - . S:SEQ3=7 $P(PSOIBY,U,6)=$P(PSOSEG,"|",3) ;CV - . S:SEQ3=8 $P(PSOIBY,U,7)=$P(PSOSEG,"|",3) ;SHAD - Q -MISX ;Mismatch patient on CPRS New Order - S RCOMM="Patient mismatch on New Order from CPRS." D EN^ORERR(RCOMM,.MSG) S NWFLAG=1 D RERROR^PSOHLSN D KL^PSOHLSIH - Q -MISRN ;Mismatch on CPRS renewal - N PSOCINV - I $G(PDFN)'=$P($G(^PSRX(+$G(PREV),0)),"^",2) D S PSOMO=1 Q - .S RCOMM="Patient mismatch on CPRS Renewal." D EN^ORERR(RCOMM,.MSG) S PSOXRP=1 D RERROR^PSOHLSN D KL^PSOHLSIH - S PSOCINV=+$P($G(^OR(100,+$G(PLACER),3)),"^",5) - I PSOCINV'=$P($G(^PSRX(+$G(PREV),"OR1")),"^",2) D S PSOMO=1 Q - .S RCOMM="Order mismatch on CPRS Renewal." D EN^ORERR(RCOMM,.MSG) S PSOCVI=1 D RERROR^PSOHLSN D KL^PSOHLSIH - Q -ZRX ;Process ZRX segment - I $P(PSOSEG,"|",3)="R" S PSOOC="RNW",PSRNFLAG=1 - S PREV=$S(+$P(PSOSEG,"|"):+$P(PSOSEG,"|"),1:"") - I $P(PSOSEG,"|")["P"!($P(PSOSEG,"|")["S") S PFLAG=1 - S NATURE=$P(PSOSEG,"|",2) - S PSORSO=$P(PSOSEG,"|",3) - S ROUTING=$P(PSOSEG,"|",4) - I ROUTING="" S ROUTING="M" - I $P(PSOSEG,"|",7) S DSIG=1 - Q -CHCS ;Replace CHCS number with CPRS number in .01 field - N PSOHTMP - I $G(PDFN),PDFN'=+$P($G(^PS(52.41,+$G(PSOCHFFL),0)),"^",2) S COMM="Patient does not match" D EN^ORERR(COMM,.MSG) K PSOPLC,PSOFFL,PSOSND Q - I '$D(^PS(52.41,+$G(PSOCHFFL),0)) S COMM="Order was not located by Pharmacy" D EN^ORERR(COMM,.MSG) K PSOPLC,PSOFFL,PSOSND Q - S PSOHTMP=$P($G(^PS(52.41,+$G(PSOCHFFL),0)),"^") - I PSOHTMP'="" K ^PS(52.41,"B",PSOHTMP,+$G(PSOCHFFL)) - S $P(^PS(52.41,+$G(PSOCHFFL),0),"^")=PSOPLC,^PS(52.41,"B",PSOPLC,+$G(PSOCHFFL))="" - S $P(^PS(52.41,+$G(PSOCHFFL),"EXT"),"^",2)=1 - Q -CNT ; - S TAC=0 F TACA=0:0 S TACA=$O(^PSRX(PREV,"A",TACA)) Q:'TACA S TAC=TACA - S PAC=0 F PACA=0:0 S PACA=$O(^PSRX(PREV,1,PACA)) Q:'PACA S PAC=PACA - D NOW^%DTC S TAC=TAC+1,^PSRX(PREV,"A",0)="^52.3DA^"_TAC_"^"_TAC,^PSRX(PREV,"A",TAC,0)=%_"^"_"C"_"^"_$S(+$G(PROV):$G(PROV),1:+$G(ENTERED))_"^"_PAC_"^"_"Discontinued due to CPRS edit" - K TAC,PAC,TACA,PACA - Q -NTE ; - S WPCT=1,WORDP=$S($P(MSG(LL),"|",2):$P(MSG(LL),"|",2),1:$P(MSG(LL),"|",3)) S:$P(MSG(LL),"|",4)'="" WPARRAY(WORDP,WPCT)=$P(MSG(LL),"|",4) S:$P(MSG(LL),"|",4)'="" WPCT=WPCT+1 F LLL=0:0 S LLL=$O(MSG(LL,LLL)) Q:'LLL D - .I $G(MSG(LL,LLL))'="" S WPARRAY(WORDP,WPCT)=$G(MSG(LL,LLL)),WPCT=WPCT+1 - Q +PSOHLNE1 ;BIR/RTR-Parsing out segments from OERR ;01/20/95 + ;;7.0;OUTPATIENT PHARMACY;**1,9,46,71,98,111,117,131,157,181,143,235,239**;DEC 1997 + ;External reference to EN^ORERR supported by DBIA 2187 + ;External reference to PS(50.607 supported by DBIA 2221 + ;External reference to OR(100 supported by DBIA 2219 + ;External reference to PSDRUG( supported by DBIA 221 + ;External reference VADPT supported by DBIA 10061 + ; +EN ;ORC segment + N Q1,Q2,Q3,Q4,Q5,Q6,Q7,PSOPOSSD + K PSOLQ1I,PSOLQ1II,PSOLQ1IX + I '$O(MSG(ZZ,0)) D + .S PSOOC="NW",PLACER=+$P(PSOSEG,"|",2),PLACERXX=+$P($P(PSOSEG,"|",2),";",2),ENTERED=$P(PSOSEG,"|",10),PROV=$P(PSOSEG,"|",12) + .S X=$P(PSOSEG,"|",15) S EFFECT=$$HL7TFM^XLFDT(X) K X + .D NOW^%DTC S PSOLOG=% K % + .;S RSN=$P(PSOSEG,"|",16) + .S ORCSEG=$P(PSOSEG,"|",7),QCOUNT=1 Q:$G(ORCSEG)'["~" + .F JJ=1:1:$L(ORCSEG) S:$E(ORCSEG,JJ)="~" QCOUNT=QCOUNT+1 + I '$O(MSG(ZZ,0)) D Q + .F JJJ=1:1:QCOUNT S QQQ=$P(ORCSEG,"~",JJJ) D:QQQ'="" + ..S PSOPOSSD=$S($P($P(QQQ,"^"),"&"):1,1:0) ;PSOPOSSD=1 if possible dose + ..S Q1I(JJJ)=$S(PSOPOSSD:$P(QQQ,"^"),1:$P(QQQ,"^",8)),PSOLQ1IX(JJJ)=$P($P(QQQ,"^"),"&",5) S PSOLQ1I(JJJ)=$P(QQQ,"^",8),PSOLQ1II(JJJ)=PSOPOSSD ;ORC piece 1 if Possible Dosage, ORC piece 8 if Local Possible Dosage + ..S Q1(JJJ)=$P(QQQ,"^",2) ;schedule + ..S Q2(JJJ)=$P(QQQ,"^",3) ;duration + ..S Q3(JJJ)=$P(QQQ,"^",4) I Q3(JJJ) S X=Q3(JJJ) S Q3(JJJ)=$$HL7TFM^XLFDT(X) K X ;start date + ..S Q4(JJJ)=$P(QQQ,"^",5) ;end date + ..S:$G(PRIOR)="" PRIOR=$P(QQQ,"^",6) + ..S Q6(JJJ)=$P(QQQ,"^",9) ;conjunction + ..S Q7(JJJ)=$P(QQQ,"^",10) ;sequencing + ..S QTARRAY(JJJ)=Q1(JJJ)_"^"_Q2(JJJ)_"^"_Q3(JJJ)_"^"_Q4(JJJ)_"^^"_Q6(JJJ)_"^"_Q7(JJJ) + ..S QTARRAY2(JJJ)=$S(PSOPOSSD:$P(Q1I(JJJ),"&"),1:Q1I(JJJ))_"^"_$S(PSOPOSSD:$P(Q1I(JJJ),"&",3),1:"") + ..I PSOPOSSD S $P(QTARRAY(JJJ),"^",5)=$P(Q1I(JJJ),"&",4) + ..I PSOPOSSD S PSOUNN=$P(Q1I(JJJ),"&",2) I PSOUNN'="" S PSOUNN=$O(^PS(50.607,"B",PSOUNN,0)) S $P(QTARRAY(JJJ),"^",9)=$G(PSOUNN) + ..K PSOUNN + ;For multiple ORC subscripts + S (POVAR,POVAR1)="",(NNCK,NNN,NNNN)=0,PSOIII=1,MSG(ZZ,0)=$E(MSG(ZZ),5,$L(MSG(ZZ))) + S AAA="" F S AAA=$O(MSG(ZZ,AAA)) Q:AAA="" S NNN=0 F OOO=1:1:$L(MSG(ZZ,AAA)) S NNN=NNN+1 D D:$G(POVAR1)="~"&(NNNN=6) PARSE D:$G(POVAR1)="|" PARSE + .I $E(MSG(ZZ,AAA),OOO)="|" S NNNN=NNNN+1 + .S POVAR1=$E(MSG(ZZ,AAA),OOO) + .S POLIM=POVAR + .S POVAR=$S(POVAR="":POVAR1,1:POVAR_POVAR1) + .;I NNNN=6 I $G(POVAR1)="~"!($G(POVAR1)="|") +END ;16 OF ORC? + ;I $G(POVAR)'="" I NNNN=14!(NNNN=15) S EFFECT=$G(POVAR) + S QCOUNT=0 F JJJ=0:0 S JJJ=$O(QTVAR(JJJ)) Q:'JJJ I $L($G(QTVAR(JJJ))) S QCOUNT=QCOUNT+1 D + .S PSOPOSSD=$S($P($P(QTVAR(JJJ),"^"),"&"):1,1:0) ;PSOPOSSD =1 if possible dose + .S Q1I(JJJ)=$S(PSOPOSSD:$P(QTVAR(JJJ),"^"),1:$P(QTVAR(JJJ),"^",8)),PSOLQ1IX(JJJ)=$P($P(QTVAR(JJJ),"^"),"&",5) S PSOLQ1I(JJJ)=$P(QTVAR(JJJ),"^",8),PSOLQ1II(JJJ)=PSOPOSSD ;piece 1 if possible dose, piece 8 if not + .S Q1(JJJ)=$P(QTVAR(JJJ),"^",2) + .S Q2(JJJ)=$P(QTVAR(JJJ),"^",3) + .;S Q2(JJJ)=$S($E($P(QTVAR(JJJ),"^",3)):"D"_$P(QTVAR(JJJ),"^",3),$E($P(QTVAR(JJJ),"^",3))=0:"D"_$P(QTVAR(JJJ),"^",3),1:$P(QTVAR(JJJ),"^",3)) + .S Q3(JJJ)=$P(QTVAR(JJJ),"^",4) I Q3(JJJ) S X=Q3(JJJ) S Q3(JJJ)=$$HL7TFM^XLFDT(X) K X + .S Q4(JJJ)=$P(QTVAR(JJJ),"^",5) + .S:$G(PRIOR)="" PRIOR=$P(QTVAR(JJJ),"^",6) + .S Q6(JJJ)=$P(QTVAR(JJJ),"^",9) + .S Q7(JJJ)=$P(QTVAR(JJJ),"^",10) + .S QTARRAY(JJJ)=Q1(JJJ)_"^"_Q2(JJJ)_"^"_Q3(JJJ)_"^"_Q4(JJJ)_"^^"_Q6(JJJ)_"^"_Q7(JJJ) + .S QTARRAY2(JJJ)=$S(PSOPOSSD:$P(Q1I(JJJ),"&"),1:Q1I(JJJ))_"^"_$S(PSOPOSSD:$P(Q1I(JJJ),"&",3),1:"") + .I PSOPOSSD S $P(QTARRAY(JJJ),"^",5)=$P(Q1I(JJJ),"&",4) + .I PSOPOSSD S PSOUNN=$P(Q1I(JJJ),"&",2) I PSOUNN'="" S PSOUNN=$O(^PS(50.607,"B",PSOUNN,0)) S $P(QTARRAY(JJJ),"^",9)=$G(PSOUNN) + .K PSOUNN + I $G(EFFECT) S X=EFFECT S EFFECT=$$HL7TFM^XLFDT(X) K X + D NOW^%DTC S PSOLOG=% S:'$G(EFFECT) EFFECT=% K % + K MSG(ZZ,0) + Q +PARSE I NNNN=1 S PSOOC="NW" G SET + I NNNN=2 S PLACER=+$G(POLIM),PLACERXX=+$P($G(POLIM),";",2) G SET + I NNNN=3!(NNNN=4)!(NNNN=5) G SET + I NNNN=6,$G(POVAR1)="~" S NNCK=NNCK+1,QTVAR(NNCK)=$G(POLIM) G SET + I NNNN=7 S NNCK=NNCK+1 S QTVAR(NNCK)=$G(POLIM) G SET + I NNNN=8!(NNNN=9) G SET + I NNNN=10 S ENTERED=$G(POLIM) G SET + I NNNN=11 G SET + I NNNN=12 S PROV=$G(POLIM) G SET + I NNNN=13!(NNNN=14) G SET + I NNNN=15 S EFFECT=$G(POLIM) +SET S (POVAR,POLIM)="" Q + ; +EXP ; + ;Q:'$G(OR("PLACE")) + Q:'$G(PSOFILNM) + S PSOMSORR=1 + N PSOSSMES S PSOSSMES="CPRSUP" + I $G(PSOFILNM),$G(PSOFILNM)["S" S LL=+$G(PSOFILNM) I $D(^PS(52.41,LL,0)),$P($G(^(0)),"^",3)'="RF" G EXPEN + S LL=$G(PSOFILNM) I 'LL!('$D(^PSRX(+$G(LL),0))) S COMM="Order was not located by Pharmacy" D EN^ORERR(COMM,.MSG) D G EXPQ + .F EER=0:0 S EER=$O(MSG(EER)) Q:'EER S:$P(MSG(EER),"|")="PV1" PSERRPV1=MSG(EER) S:$P(MSG(EER),"|")="PID" PSERRPID=MSG(EER) S:$P(MSG(EER),"|")="ORC"&($G(PSERRORC)="") PSERRORC=MSG(EER) + .N MSG,PSOHINST D INIT^PSOHLSN S MSG(2)=$G(PSERRPID),MSG(3)=$G(PSERRPV1),MSG(4)="ORC|DE|"_$G(OR("PLACE"))_$S($G(PLACERXX):";"_PLACERXX,1:"")_"^OR"_"|"_$S($P($G(PSERRORC),"|",4)'="":$P(PSERRORC,"|",4),1:"") S:$G(COMM)'="" MSG(5)="NTE|16||"_COMM + .D SEND^PSOHLSN + Q:'$D(^PSRX(LL,0)) + I +$P($G(^PSRX(LL,2)),"^",6)
$P($G(^("I")),"^"):1,1:0),$P($G(^PSDRUG(PSOCDD,2)),"^",3)["O" S PSOCDDI=PSOCDDI+1,PSOCDDIZ=PSOCDD + I PSOCDDI'=1 Q + S PSOQWX=$G(PSOCDDIZ) + Q +CP ;ZSC segment (replaced by ZCL segment) + S SERV=$S($P(PSOSEG,"|")=1:"SC",$P(PSOSEG,"|")=0:"NSC",1:$P(PSOSEG,"|")) + S PSOIBY=$P(PSOSEG,"|",2)_"^"_$P(PSOSEG,"|",3)_"^"_$P(PSOSEG,"|",4)_"^"_$P(PSOSEG,"|",5)_"^"_$P(PSOSEG,"|",6)_"^"_$P(PSOSEG,"|",7) + Q + ; +ZCL ;ZCL segment - SC/EI related to ICDs + N SEQ,SEQ2,SEQ3 S SEQ3=$P(PSOSEG,"|",2),SEQ2=$P(PSOSEG,"|",1) + S:'$D(PSOICD(SEQ2)) PSOICD(SEQ2)="" + S $P(PSOICD(SEQ2),"^",(SEQ3+1))=$P(PSOSEG,"|",3) ;set sc/ei for ICD node + D SCP^PSORN52D K PSOSCA + S:'$D(PSOIBY) PSOIBY="" + I PSOSCP<50 D ;set IBQ node variables if <50% SC + . Q:$P(PSOIBY,U,$S(SEQ3=1:2,SEQ3=2:3,SEQ3=4:4,SEQ3=5:1,SEQ3=6:5,SEQ3=7:6,1:""))>0 + . S:SEQ3=1 $P(PSOIBY,U,2)=$P(PSOSEG,"|",3) ;AO + . S:SEQ3=2 $P(PSOIBY,U,3)=$P(PSOSEG,"|",3) ;IR + . S:SEQ3=3 SERV=$S($P(PSOSEG,"|",3)=1:"SC",$P(PSOSEG,"|",3)=0:"NSC",1:$P(PSOSEG,"|",3)) ;SC + . S:SEQ3=4 $P(PSOIBY,U,4)=$P(PSOSEG,"|",3) ;EC + . S:SEQ3=5 $P(PSOIBY,U,1)=$P(PSOSEG,"|",3) ;MST + . S:SEQ3=6 $P(PSOIBY,U,5)=$P(PSOSEG,"|",3) ;HNC + . S:SEQ3=7 $P(PSOIBY,U,6)=$P(PSOSEG,"|",3) ;CV + ;E D + ;. S PSOIBY="^^^^^^",SERV="" + Q +MISX ;Mismatch patient on CPRS New Order + S RCOMM="Patient mismatch on New Order from CPRS." D EN^ORERR(RCOMM,.MSG) S NWFLAG=1 D RERROR^PSOHLSN D KL^PSOHLSIH + Q +MISRN ;Mismatch on CPRS renewal + N PSOCINV + I $G(PDFN)'=$P($G(^PSRX(+$G(PREV),0)),"^",2) D S PSOMO=1 Q + .S RCOMM="Patient mismatch on CPRS Renewal." D EN^ORERR(RCOMM,.MSG) S PSOXRP=1 D RERROR^PSOHLSN D KL^PSOHLSIH + S PSOCINV=+$P($G(^OR(100,+$G(PLACER),3)),"^",5) + I PSOCINV'=$P($G(^PSRX(+$G(PREV),"OR1")),"^",2) D S PSOMO=1 Q + .S RCOMM="Order mismatch on CPRS Renewal." D EN^ORERR(RCOMM,.MSG) S PSOCVI=1 D RERROR^PSOHLSN D KL^PSOHLSIH + Q +ZRX ;Process ZRX segment + I $P(PSOSEG,"|",3)="R" S PSOOC="RNW",PSRNFLAG=1 + S PREV=$S(+$P(PSOSEG,"|"):+$P(PSOSEG,"|"),1:"") + I $P(PSOSEG,"|")["P"!($P(PSOSEG,"|")["S") S PFLAG=1 + S NATURE=$P(PSOSEG,"|",2) + S PSORSO=$P(PSOSEG,"|",3) + S ROUTING=$P(PSOSEG,"|",4) + I ROUTING="" S ROUTING="M" + I $P(PSOSEG,"|",7) S DSIG=1 + Q +CHCS ;Replace CHCS number with CPRS number in .01 field + N PSOHTMP + I $G(PDFN),PDFN'=+$P($G(^PS(52.41,+$G(PSOCHFFL),0)),"^",2) S COMM="Patient does not match" D EN^ORERR(COMM,.MSG) K PSOPLC,PSOFFL,PSOSND Q + I '$D(^PS(52.41,+$G(PSOCHFFL),0)) S COMM="Order was not located by Pharmacy" D EN^ORERR(COMM,.MSG) K PSOPLC,PSOFFL,PSOSND Q + S PSOHTMP=$P($G(^PS(52.41,+$G(PSOCHFFL),0)),"^") + I PSOHTMP'="" K ^PS(52.41,"B",PSOHTMP,+$G(PSOCHFFL)) + S $P(^PS(52.41,+$G(PSOCHFFL),0),"^")=PSOPLC,^PS(52.41,"B",PSOPLC,+$G(PSOCHFFL))="" + S $P(^PS(52.41,+$G(PSOCHFFL),"EXT"),"^",2)=1 + Q +CNT ; + S TAC=0 F TACA=0:0 S TACA=$O(^PSRX(PREV,"A",TACA)) Q:'TACA S TAC=TACA + S PAC=0 F PACA=0:0 S PACA=$O(^PSRX(PREV,1,PACA)) Q:'PACA S PAC=PACA + D NOW^%DTC S TAC=TAC+1,^PSRX(PREV,"A",0)="^52.3DA^"_TAC_"^"_TAC,^PSRX(PREV,"A",TAC,0)=%_"^"_"C"_"^"_$S(+$G(PROV):$G(PROV),1:+$G(ENTERED))_"^"_PAC_"^"_"Discontinued due to CPRS edit" + K TAC,PAC,TACA,PACA + Q +NTE ; + S WPCT=1,WORDP=$S($P(MSG(LL),"|",2):$P(MSG(LL),"|",2),1:$P(MSG(LL),"|",3)) S:$P(MSG(LL),"|",4)'="" WPARRAY(WORDP,WPCT)=$P(MSG(LL),"|",4) S:$P(MSG(LL),"|",4)'="" WPCT=WPCT+1 F LLL=0:0 S LLL=$O(MSG(LL,LLL)) Q:'LLL D + .I $G(MSG(LL,LLL))'="" S WPARRAY(WORDP,WPCT)=$G(MSG(LL,LLL)),WPCT=WPCT+1 + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLNE2.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLNE2.m index 08ccb83d..30b33790 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLNE2.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLNE2.m @@ -1,146 +1,146 @@ -PSOHLNE2 ;BIR/RTR-Parsing out more OERR segments ;1/20/95 - ;;7.0;OUTPATIENT PHARMACY;**1,7,59,46,225**;DEC 1997;Build 29 - ;External reference to DG(40.8 supported by DBIA 728 - ;External reference to PS(50.606 supported by DBIA 2174 - ;External reference to PS(50.7 supported by DBIA 2223 - ;External reference to PSDRUG( supported by DBIA 221 - ;External reference to PS(55 supported by DBIA 2228 - ;External reference to SC( supported by DBIA 2675 - ; -EN ;RXO segment on new orders with multiple subscripts - S (POVAR,POVAR1)="",(NNN,NNNN)=0,PSOIII=1,MSG(ZZ,0)=$E(MSG(ZZ),5,$L(MSG(ZZ))) - S AAA="" F S AAA=$O(MSG(ZZ,AAA)) Q:AAA="" S NNN=0 F OOO=1:1:$L(MSG(ZZ,AAA)) S NNN=NNN+1 D D:$G(POVAR1)="|" PARSE - .I $E(MSG(ZZ,AAA),OOO)="|" S NNNN=NNNN+1 - .S POVAR1=$E(MSG(ZZ,AAA),OOO) - .S POLIM=POVAR - .S POVAR=$S(POVAR="":POVAR1,1:POVAR_POVAR1) - I $G(POVAR)'="" I NNNN=13!(NNNN=12) S PSOREFIL=POVAR - K MSG(ZZ,0) - Q -PARSE ; - I NNNN=1 S PSORDITE=$P(POLIM,"^",4) G SET - I NNNN=10 S PSODDRUG=$P(POLIM,"^",4) I $G(PSODDRUG),('$D(^PSDRUG(PSODDRUG,0))) S PSODDRUG="" G SET - I NNNN=10 G SET - I NNNN=11 S PSOXQTY=POLIM G SET - I NNNN=13 S PSOREFIL=POLIM G SET - I NNNN=17 S PSODYSPL=POLIM -SET S (POVAR,POLIM)="" Q - ; -OBXX ;Parse out OBX segments - S OCOUNT=OCOUNT+1 - S (POVAR,POVAR)="",(NNCK,NNN,NNNN)=0,PSOIII=1,MSG(ZZ,0)=$E(MSG(ZZ),5,$L(MSG(ZZ))) - S AAA="" F S AAA=$O(MSG(ZZ,AAA)) Q:AAA="" S NNN=0 F OOO=1:1:$L(MSG(ZZ,AAA)) S NNN=NNN+1 D D:$G(POVAR1)="&"&(NNNN=4) OPARSE D:$G(POVAR1)="|" OPARSE - .I $E(MSG(ZZ,AAA),OOO)="|" S NNNN=NNNN+1 - .S POVAR1=$E(MSG(ZZ,AAA),OOO) - .S POLIM=POVAR - .S POVAR=$S(POVAR="":POVAR1,1:POVAR_POVAR1) - I $G(POVAR)'="" I NNNN=4!(NNNN=5) S NNCK=NNCK+1 S OBXAR(OCOUNT,NNCK)=POVAR - K MSG(ZZ,0) - F OOO=2:1 Q:'$D(OBXAR(OCOUNT,OOO)) S OBXAR(OCOUNT,1)=OBXAR(OCOUNT,1)_"&"_OBXAR(OCOUNT,OOO) K OBXAR(OCOUNT,OOO) - Q -OPARSE ; - I NNNN=4,$G(POVAR1)="&" S NNCK=NNCK+1,OBXAR(OCOUNT,NNCK)=$G(POLIM) G OSET - I NNNN=5 S NNCK=NNCK+1 S OBXAR(OCOUNT,NNCK)=$G(POLIM) -OSET S (POVAR,POLIM)="" Q - ; -PURGE ;Purge order initiated by CPRS - N DA,PREER,PRG,PPG,PND,PRGFLAG,PURGCOMM,PEER,PURGPV1,PURGPID,PURGORC,PURGRX,PURGPLC,PRGSTAT,PSCC,PSARC,PSCA,PSACOUNT,PURGEXRX,PLAST,PURGLTH,PURGNODE - S PSOMSORR=1 - S PRGFLAG=0 - ;S PURGRX=$O(^PSRX("APL",OR("PLACE"),0)) I PURGRX G PRX - I $G(PSOFILNM),$G(PSOFILNM)'["S" S PURGRX=PSOFILNM G PRX - S PND=+$G(PSOFILNM) I PND D G PDNO - .I '$D(^PS(52.41,PND,0)) Q - .I $G(PDFN),$G(PDFN)'=$P($G(^PS(52.41,PND,0)),"^",2) S PURGCOMM="Patient does not match" D PDERR Q - .S PRGSTAT=$P($G(^PS(52.41,PND,0)),"^",3) I PRGSTAT="NW"!(PRGSTAT="RNW")!(PRGSTAT="HD") S PRGFLAG=1 Q - .K DIK S DA=PND,DIK="^PS(52.41," D ^DIK K DIK Q - S PURGCOMM="Order was not located by Pharmacy." - D PDERR G PDNO -PDERR D EN^ORERR(PURGCOMM,.MSG) - Q -PDNO F PEER=0:0 S PEER=$O(MSG(PEER)) Q:'PEER S:$P(MSG(PEER),"|")="PV1" PURGPV1=MSG(PEER) S:$P(MSG(PEER),"|")="PID" PURGPID=MSG(PEER) S:$P(MSG(PEER),"|")="ORC"&($G(PURGORC)="") PURGORC=MSG(PEER) - N MSG,PSOHINST D INIT^PSOHLSN S MSG(2)=$G(PURGPID),MSG(3)=$G(PURGPV1),MSG(4)="ORC|"_$S($G(PRGFLAG):"ZU",1:"ZR")_"|"_$G(OR("PLACE"))_$S($G(PLACERXX):";"_PLACERXX,1:"")_"^OR"_"|"_$S($P($G(PURGORC),"|",4)'="":$P(PURGORC,"|",4),1:"") - F PREER=11,13 I $P($G(PURGORC),"|",PREER)'="" S $P(MSG(4),"|",PREER)=$P($G(PURGORC),"|",PREER) - S $P(MSG(4),"|",17)="^^^^"_$S($G(PRGFLAG):"Unable to Purge order.",1:"OK to Purge order.")_"^" - D SEND^PSOHLSN -PURGEX K PSOMSORR Q -PRX ;Purge from PSRX here - I '$D(^PSRX(PURGRX,0)) G PDNO - I $G(PDFN),$G(PDFN)'=$P($G(^PSRX(PURGRX,0)),"^",2) S PURGCOMM="Patient does not match" D PDERR G PDNO - I '$P($G(^PSRX(PURGRX,"ARC")),"^") S PRGFLAG=1 G PDNO - ;purge from PSRX - S PURGEXRX=$P(^PSRX(PURGRX,0),"^") - S PSOSUSPA=1 K DIK S DA=PURGRX,PSCC=$P($G(^PSRX(PURGRX,0)),"^",2),DIK="^PSRX(" D ^DIK K DIK,PSOSUSPA - I $D(^PS(55,+$G(PSCC),0)) S DA(1)=PSCC,DIK="^PS(55,"_DA(1)_",""P""," F PSCA=0:0 S PSCA=$O(^PS(55,+$G(PSCC),"P",PSCA)) Q:'PSCA I ^PS(55,+$G(PSCC),"P",PSCA,0)=PURGRX S DA=PSCA D ^DIK K DA,DIK - I $D(^PS(52.4,PURGRX,0)) S DA=PURGRX,DIK="^PS(52.4," D ^DIK K DA,DIK - S DA=$O(^PS(52.5,"B",PURGRX,"")) I DA S DIK="^PS(52.5," D ^DIK K DIK,DA - I '$G(DT) S DT=$$DT^XLFDT - I '$G(PSCC) G PUQUIT - I '$D(^PS(55,PSCC,"ARC",DT)) S DA=PSCC,DIE=55,DR="101///"_DT,DR(2,55.13)="1///"_$G(PURGEXRX) D ^DIE K DIE G PUQUIT - S PLAST=0 F PSARC=0:0 S PSARC=$O(^PS(55,PSCC,"ARC",DT,1,PSARC)) Q:'PSARC S PLAST=PSARC - I $G(PLAST),$D(^PS(55,PSCC,"ARC",DT,1,PLAST,0)) S PURGNODE=^PS(55,PSCC,"ARC",DT,1,PLAST,0) S PURGLTH=$L(PURGNODE) I $G(PURGLTH),PURGLTH<220 S ^PS(55,PSCC,"ARC",DT,1,PLAST,0)=PURGNODE_$S($E(PURGNODE,PURGLTH)'="*":"*",1:"")_PURGEXRX G PUQUIT - S DA=PSCC,DIE=55,DR="101///"_DT,DR(2,55.13)="1///"_$G(PURGEXRX) D ^DIE K DIE -PUQUIT G PDNO - ; -REF ;Refill request from CPRS - N PSORXFL,PSORFX,REFXXX,REFCOM,REFCOMXX,REFEER,REFPV1,REFPID,REFORC,RREER,RFLOOP,REFSEG,RFTYPE,REFILLER,REFVR - ;S PSOMSORR=1 - ;S PSORXFL=$O(^PSRX("APL",OR("PLACE"),0)) I PSORXFL G REFRX - I $G(PSOFILNM),$G(PSOFILNM)'["S" S PSORXFL=PSOFILNM G REFRX - I $G(PSOFILNM) S PSORFX=+$G(PSOFILNM) D S REFXXX=1 G REFSND - .I '$D(^PS(52.41,PSORFX,0)) S (REFCOMXX,REFCOM)="Order was not located by Pharmacy." D REFERR Q - .I $G(PDFN),$G(PDFN)'=$P($G(^PS(52.41,PSORFX,0)),"^",2) S (REFCOMXX,REFCOM)="Patient does not match." D REFERR Q - .I $P($G(^PS(52.41,PSORFX,0)),"^",3)="RF" S REFCOM="Refill has already been requested." Q - .S REFCOM="Refill request not allowed on Pending order." - S (REFCOMXX,REFCOM)="Order was not located by Pharmacy." D REFERR S REFXXX=1 G REFSND -REFERR D EN^ORERR(REFCOMXX,.MSG) - Q -REFSND ;REBUILD AND SEND MESSAGE REFXXX IS VARIABL, REFCOM IS COMMENT - ;F REFEER=0:0 S REFEER=$O(MSG(REFEER)) Q:'REFEER S:$P(MSG(REFEER),"|")="PV1" REFPV1=MSG(REFEER) S:$P(MSG(REFEER),"|")="PID" REFPID=MSG(REFEER) S:$P(MSG(REFEER),"|")="ORC"&($G(REFORC)="") REFORC=MSG(REFEER) - ;N MSG,PSOHINST D INIT^PSOHLSN S MSG(2)=$G(REFPID),MSG(3)=$G(REFPV1),MSG(4)="ORC|"_$S($G(REFXXX):"UF",1:"FL")_"|"_$G(OR("PLACE"))_$S($G(PLACERXX):";"_PLACERXX,1:"")_"^OR"_"|"_$S($P($G(REFORC),"|",4)'="":$P(REFORC,"|",4),1:"") - ;use commented out code if response message is ever required - ;F RREER=11,13 I $P($G(REFORC),"|",RREER)'="" S $P(MSG(4),"|",RREER)=$P($G(REFORC),"|",RREER) - ;S $P(MSG(4),"|",17)="^^^^"_$S($G(REFXXX):$G(REFCOM),1:"Refill request sent to Pharmacy.")_"^" - ;D SEND^PSOHLSN -REFSNDX ;K PSOMSORR - Q -REFRX ; - I $O(^PS(52.41,"ARF",PSORXFL,0)) S REFXXX=1,REFCOM="Refill request already exists." G REFSND - I '$D(^PSRX(PSORXFL,0)) S (REFCOMXX,REFCOM)="Order was not located by Pharmacy." D REFERR S REFXXX=1 G REFSND - I $G(PDFN),$G(PDFN)'=$P($G(^PSRX(PSORXFL,0)),"^",2) S (REFCOMXX,REFCOM)="Patient does not match." D REFERR S REFXXX=1 G REFSND - ;S REFVR=$$REFILL^PSOREF(OR("PLACE")) I $P($G(REFVR),"^")'=1 S REFXXX=1,REFCOM=$P($G(REFVR),"^",2) G REFSND - F RFLOOP=0:0 S RFLOOP=$O(MSG(RFLOOP)) Q:'RFLOOP S REFSEG=$G(MSG(RFLOOP)),RFTYPE=$P(REFSEG,"|")_"Z" S REFSEG=$E(REFSEG,5,$L(REFSEG)) I RFTYPE="PIDZ"!(RFTYPE="PV1Z")!(RFTYPE="ORCZ")!(RFTYPE="ZRXZ") D @RFTYPE - I '$G(PLACER) S REFXXX=1,REFCOM="Unable to process refill request." G REFSND - I $G(REFILLER),$G(REFILLER)'=$G(PSORXFL) S REFCOMXX="Filler number mismatch" D REFERR S REFXXX=1,REFCOM="Unable to process refill request." G REFSND - K DD,DO S DIC="^PS(52.41,",DIC(0)="L",X=PLACER,DIC("DR")="1////"_$G(DFN)_";2////"_"RF"_";4////"_$G(ENTERED)_";5////"_$G(PROV) D FILE^DICN K DIC,DR I Y<0 S REFXXX=1,REFCOM="Unable to process refill request." G REFSND - S PENDING=+Y S $P(^PS(52.41,PENDING,0),"^",13)=$G(LOCATION),$P(^(0),"^",17)=$S($G(ROUTING)'="":$G(ROUTING),1:"W"),$P(^(0),"^",19)=$G(PSORXFL),$P(^(0),"^",20)="F",$P(^(0),"^",14)="R" - S $P(^PS(52.41,PENDING,0),"^",8)=$P($G(^PSRX(PSORXFL,"OR1")),"^"),$P(^PS(52.41,PENDING,0),"^",9)=$P($G(^PSRX(PSORXFL,0)),"^",6) - S $P(^PS(52.41,PENDING,"INI"),"^")=$G(PSINPTR) D NOW^%DTC S $P(^PS(52.41,PENDING,0),"^",12)=% K % - K DIK S DA=PENDING,DIK="^PS(52.41," D IX1^DIK K DIK - G REFSND -PIDZ ; - S DFN=+$P(REFSEG,"|",3) - Q -PV1Z ; - S LOCATION=+$P(+$P(REFSEG,"|",3),"^") - S:'$D(^SC(LOCATION,0)) LOCATION="" - S INPTRX=0 I $G(LOCATION) S PSINPTR=$P($G(^SC(LOCATION,0)),"^",4) I PSINPTR Q - I $G(LOCATION) S INPTRX=$P($G(^SC(LOCATION,0)),"^",15) - I '$G(INPTRX) S INPTRX=$O(^DG(40.8,0)) - I '$G(DT) S DT=$$DT^XLFDT - S PSINPTR=+$$SITE^VASITE(DT,INPTRX) - Q -ORCZ ; - S PLACER=+$P(REFSEG,"|",2),REFILLER=+$P(REFSEG,"|",3),ENTERED=+$P(REFSEG,"|",10),PROV=+$P(REFSEG,"|",12) - Q -ZRXZ ; - S ROUTING=$P(REFSEG,"|",4) - Q -STUFF ; - S PSOVRBD=$P($G(^PS(50.7,+$G(PSORDITE),0)),"^",2) - I '$G(PSOVRBD) K PSOVRBD Q - ;K PSONUNN F PSONUN=0:0 S PSONUN=$O(^PS(50.606,PSOVRBD,"NOUN",PSONUN)) Q:'PSONUN!($D(PSONUNN)) S:$P($G(^(PSONUN,0)),"^")'="" PSONUNN=$P($G(^(0)),"^") - S PSOVRB=$P($G(^PS(50.606,PSOVRBD,"MISC")),"^") - F EE=0:0 S EE=$O(^PS(52.41,PENDING,1,EE)) Q:'EE S $P(^PS(52.41,PENDING,1,EE,1),"^",10)=$$UNESC^ORHLESC($G(PSOVRB)) - K PSOVRBD,PSONUNN,PSONUN,PSOVRB - Q +PSOHLNE2 ;BIR/RTR-Parsing out more OERR segments ; 1/20/95 + ;;7.0;OUTPATIENT PHARMACY;**1,7,59,46**;DEC 1997 + ;External reference to DG(40.8 supported by DBIA 728 + ;External reference to PS(50.606 supported by DBIA 2174 + ;External reference to PS(50.7 supported by DBIA 2223 + ;External reference to PSDRUG( supported by DBIA 221 + ;External reference to PS(55 supported by DBIA 2228 + ;External reference to SC( supported by DBIA 2675 + ; +EN ;RXO segment on new orders with multiple subscripts + S (POVAR,POVAR1)="",(NNN,NNNN)=0,PSOIII=1,MSG(ZZ,0)=$E(MSG(ZZ),5,$L(MSG(ZZ))) + S AAA="" F S AAA=$O(MSG(ZZ,AAA)) Q:AAA="" S NNN=0 F OOO=1:1:$L(MSG(ZZ,AAA)) S NNN=NNN+1 D D:$G(POVAR1)="|" PARSE + .I $E(MSG(ZZ,AAA),OOO)="|" S NNNN=NNNN+1 + .S POVAR1=$E(MSG(ZZ,AAA),OOO) + .S POLIM=POVAR + .S POVAR=$S(POVAR="":POVAR1,1:POVAR_POVAR1) + I $G(POVAR)'="" I NNNN=13!(NNNN=12) S PSOREFIL=POVAR + K MSG(ZZ,0) + Q +PARSE ; + I NNNN=1 S PSORDITE=$P(POLIM,"^",4) G SET + I NNNN=10 S PSODDRUG=$P(POLIM,"^",4) I $G(PSODDRUG),('$D(^PSDRUG(PSODDRUG,0))) S PSODDRUG="" G SET + I NNNN=10 G SET + I NNNN=11 S PSOXQTY=POLIM G SET + I NNNN=13 S PSOREFIL=POLIM G SET + I NNNN=17 S PSODYSPL=POLIM +SET S (POVAR,POLIM)="" Q + ; +OBXX ;Parse out OBX segments + S OCOUNT=OCOUNT+1 + S (POVAR,POVAR)="",(NNCK,NNN,NNNN)=0,PSOIII=1,MSG(ZZ,0)=$E(MSG(ZZ),5,$L(MSG(ZZ))) + S AAA="" F S AAA=$O(MSG(ZZ,AAA)) Q:AAA="" S NNN=0 F OOO=1:1:$L(MSG(ZZ,AAA)) S NNN=NNN+1 D D:$G(POVAR1)="&"&(NNNN=4) OPARSE D:$G(POVAR1)="|" OPARSE + .I $E(MSG(ZZ,AAA),OOO)="|" S NNNN=NNNN+1 + .S POVAR1=$E(MSG(ZZ,AAA),OOO) + .S POLIM=POVAR + .S POVAR=$S(POVAR="":POVAR1,1:POVAR_POVAR1) + I $G(POVAR)'="" I NNNN=4!(NNNN=5) S NNCK=NNCK+1 S OBXAR(OCOUNT,NNCK)=POVAR + K MSG(ZZ,0) + F OOO=2:1 Q:'$D(OBXAR(OCOUNT,OOO)) S OBXAR(OCOUNT,1)=OBXAR(OCOUNT,1)_"&"_OBXAR(OCOUNT,OOO) K OBXAR(OCOUNT,OOO) + Q +OPARSE ; + I NNNN=4,$G(POVAR1)="&" S NNCK=NNCK+1,OBXAR(OCOUNT,NNCK)=$G(POLIM) G OSET + I NNNN=5 S NNCK=NNCK+1 S OBXAR(OCOUNT,NNCK)=$G(POLIM) +OSET S (POVAR,POLIM)="" Q + ; +PURGE ;Purge order initiated by CPRS + N DA,PREER,PRG,PPG,PND,PRGFLAG,PURGCOMM,PEER,PURGPV1,PURGPID,PURGORC,PURGRX,PURGPLC,PRGSTAT,PSCC,PSARC,PSCA,PSACOUNT,PURGEXRX,PLAST,PURGLTH,PURGNODE + S PSOMSORR=1 + S PRGFLAG=0 + ;S PURGRX=$O(^PSRX("APL",OR("PLACE"),0)) I PURGRX G PRX + I $G(PSOFILNM),$G(PSOFILNM)'["S" S PURGRX=PSOFILNM G PRX + S PND=+$G(PSOFILNM) I PND D G PDNO + .I '$D(^PS(52.41,PND,0)) Q + .I $G(PDFN),$G(PDFN)'=$P($G(^PS(52.41,PND,0)),"^",2) S PURGCOMM="Patient does not match" D PDERR Q + .S PRGSTAT=$P($G(^PS(52.41,PND,0)),"^",3) I PRGSTAT="NW"!(PRGSTAT="RNW")!(PRGSTAT="HD") S PRGFLAG=1 Q + .K DIK S DA=PND,DIK="^PS(52.41," D ^DIK K DIK Q + S PURGCOMM="Order was not located by Pharmacy." + D PDERR G PDNO +PDERR D EN^ORERR(PURGCOMM,.MSG) + Q +PDNO F PEER=0:0 S PEER=$O(MSG(PEER)) Q:'PEER S:$P(MSG(PEER),"|")="PV1" PURGPV1=MSG(PEER) S:$P(MSG(PEER),"|")="PID" PURGPID=MSG(PEER) S:$P(MSG(PEER),"|")="ORC"&($G(PURGORC)="") PURGORC=MSG(PEER) + N MSG,PSOHINST D INIT^PSOHLSN S MSG(2)=$G(PURGPID),MSG(3)=$G(PURGPV1),MSG(4)="ORC|"_$S($G(PRGFLAG):"ZU",1:"ZR")_"|"_$G(OR("PLACE"))_$S($G(PLACERXX):";"_PLACERXX,1:"")_"^OR"_"|"_$S($P($G(PURGORC),"|",4)'="":$P(PURGORC,"|",4),1:"") + F PREER=11,13 I $P($G(PURGORC),"|",PREER)'="" S $P(MSG(4),"|",PREER)=$P($G(PURGORC),"|",PREER) + S $P(MSG(4),"|",17)="^^^^"_$S($G(PRGFLAG):"Unable to Purge order.",1:"OK to Purge order.")_"^" + D SEND^PSOHLSN +PURGEX K PSOMSORR Q +PRX ;Purge from PSRX here + I '$D(^PSRX(PURGRX,0)) G PDNO + I $G(PDFN),$G(PDFN)'=$P($G(^PSRX(PURGRX,0)),"^",2) S PURGCOMM="Patient does not match" D PDERR G PDNO + I '$P($G(^PSRX(PURGRX,"ARC")),"^") S PRGFLAG=1 G PDNO + ;purge from PSRX + S PURGEXRX=$P(^PSRX(PURGRX,0),"^") + S PSOSUSPA=1 K DIK S DA=PURGRX,PSCC=$P($G(^PSRX(PURGRX,0)),"^",2),DIK="^PSRX(" D ^DIK K DIK,PSOSUSPA + I $D(^PS(55,+$G(PSCC),0)) S DA(1)=PSCC,DIK="^PS(55,"_DA(1)_",""P""," F PSCA=0:0 S PSCA=$O(^PS(55,+$G(PSCC),"P",PSCA)) Q:'PSCA I ^PS(55,+$G(PSCC),"P",PSCA,0)=PURGRX S DA=PSCA D ^DIK K DA,DIK + I $D(^PS(52.4,PURGRX,0)) S DA=PURGRX,DIK="^PS(52.4," D ^DIK K DA,DIK + S DA=$O(^PS(52.5,"B",PURGRX,"")) I DA S DIK="^PS(52.5," D ^DIK K DIK,DA + I '$G(DT) S DT=$$DT^XLFDT + I '$G(PSCC) G PUQUIT + I '$D(^PS(55,PSCC,"ARC",DT)) S DA=PSCC,DIE=55,DR="101///"_DT,DR(2,55.13)="1///"_$G(PURGEXRX) D ^DIE K DIE G PUQUIT + S PLAST=0 F PSARC=0:0 S PSARC=$O(^PS(55,PSCC,"ARC",DT,1,PSARC)) Q:'PSARC S PLAST=PSARC + I $G(PLAST),$D(^PS(55,PSCC,"ARC",DT,1,PLAST,0)) S PURGNODE=^PS(55,PSCC,"ARC",DT,1,PLAST,0) S PURGLTH=$L(PURGNODE) I $G(PURGLTH),PURGLTH<220 S ^PS(55,PSCC,"ARC",DT,1,PLAST,0)=PURGNODE_$S($E(PURGNODE,PURGLTH)'="*":"*",1:"")_PURGEXRX G PUQUIT + S DA=PSCC,DIE=55,DR="101///"_DT,DR(2,55.13)="1///"_$G(PURGEXRX) D ^DIE K DIE +PUQUIT G PDNO + ; +REF ;Refill request from CPRS + N PSORXFL,PSORFX,REFXXX,REFCOM,REFCOMXX,REFEER,REFPV1,REFPID,REFORC,RREER,RFLOOP,REFSEG,RFTYPE,REFILLER,REFVR + ;S PSOMSORR=1 + ;S PSORXFL=$O(^PSRX("APL",OR("PLACE"),0)) I PSORXFL G REFRX + I $G(PSOFILNM),$G(PSOFILNM)'["S" S PSORXFL=PSOFILNM G REFRX + I $G(PSOFILNM) S PSORFX=+$G(PSOFILNM) D S REFXXX=1 G REFSND + .I '$D(^PS(52.41,PSORFX,0)) S (REFCOMXX,REFCOM)="Order was not located by Pharmacy." D REFERR Q + .I $G(PDFN),$G(PDFN)'=$P($G(^PS(52.41,PSORFX,0)),"^",2) S (REFCOMXX,REFCOM)="Patient does not match." D REFERR Q + .I $P($G(^PS(52.41,PSORFX,0)),"^",3)="RF" S REFCOM="Refill has already been requested." Q + .S REFCOM="Refill request not allowed on Pending order." + S (REFCOMXX,REFCOM)="Order was not located by Pharmacy." D REFERR S REFXXX=1 G REFSND +REFERR D EN^ORERR(REFCOMXX,.MSG) + Q +REFSND ;REBUILD AND SEND MESSAGE REFXXX IS VARIABL, REFCOM IS COMMENT + ;F REFEER=0:0 S REFEER=$O(MSG(REFEER)) Q:'REFEER S:$P(MSG(REFEER),"|")="PV1" REFPV1=MSG(REFEER) S:$P(MSG(REFEER),"|")="PID" REFPID=MSG(REFEER) S:$P(MSG(REFEER),"|")="ORC"&($G(REFORC)="") REFORC=MSG(REFEER) + ;N MSG,PSOHINST D INIT^PSOHLSN S MSG(2)=$G(REFPID),MSG(3)=$G(REFPV1),MSG(4)="ORC|"_$S($G(REFXXX):"UF",1:"FL")_"|"_$G(OR("PLACE"))_$S($G(PLACERXX):";"_PLACERXX,1:"")_"^OR"_"|"_$S($P($G(REFORC),"|",4)'="":$P(REFORC,"|",4),1:"") + ;use commented out code if response message is ever required + ;F RREER=11,13 I $P($G(REFORC),"|",RREER)'="" S $P(MSG(4),"|",RREER)=$P($G(REFORC),"|",RREER) + ;S $P(MSG(4),"|",17)="^^^^"_$S($G(REFXXX):$G(REFCOM),1:"Refill request sent to Pharmacy.")_"^" + ;D SEND^PSOHLSN +REFSNDX ;K PSOMSORR + Q +REFRX ; + I $O(^PS(52.41,"ARF",PSORXFL,0)) S REFXXX=1,REFCOM="Refill request already exists." G REFSND + I '$D(^PSRX(PSORXFL,0)) S (REFCOMXX,REFCOM)="Order was not located by Pharmacy." D REFERR S REFXXX=1 G REFSND + I $G(PDFN),$G(PDFN)'=$P($G(^PSRX(PSORXFL,0)),"^",2) S (REFCOMXX,REFCOM)="Patient does not match." D REFERR S REFXXX=1 G REFSND + ;S REFVR=$$REFILL^PSOREF(OR("PLACE")) I $P($G(REFVR),"^")'=1 S REFXXX=1,REFCOM=$P($G(REFVR),"^",2) G REFSND + F RFLOOP=0:0 S RFLOOP=$O(MSG(RFLOOP)) Q:'RFLOOP S REFSEG=$G(MSG(RFLOOP)),RFTYPE=$P(REFSEG,"|")_"Z" S REFSEG=$E(REFSEG,5,$L(REFSEG)) I RFTYPE="PIDZ"!(RFTYPE="PV1Z")!(RFTYPE="ORCZ")!(RFTYPE="ZRXZ") D @RFTYPE + I '$G(PLACER) S REFXXX=1,REFCOM="Unable to process refill request." G REFSND + I $G(REFILLER),$G(REFILLER)'=$G(PSORXFL) S REFCOMXX="Filler number mismatch" D REFERR S REFXXX=1,REFCOM="Unable to process refill request." G REFSND + K DD,DO S DIC="^PS(52.41,",DIC(0)="L",X=PLACER,DIC("DR")="1////"_$G(DFN)_";2////"_"RF"_";4////"_$G(ENTERED)_";5////"_$G(PROV) D FILE^DICN K DIC,DR I Y<0 S REFXXX=1,REFCOM="Unable to process refill request." G REFSND + S PENDING=+Y S $P(^PS(52.41,PENDING,0),"^",13)=$G(LOCATION),$P(^(0),"^",17)=$S($G(ROUTING)'="":$G(ROUTING),1:"W"),$P(^(0),"^",19)=$G(PSORXFL),$P(^(0),"^",20)="F",$P(^(0),"^",14)="R" + S $P(^PS(52.41,PENDING,0),"^",8)=$P($G(^PSRX(PSORXFL,"OR1")),"^"),$P(^PS(52.41,PENDING,0),"^",9)=$P($G(^PSRX(PSORXFL,0)),"^",6) + S $P(^PS(52.41,PENDING,"INI"),"^")=$G(PSINPTR) D NOW^%DTC S $P(^PS(52.41,PENDING,0),"^",12)=% K % + K DIK S DA=PENDING,DIK="^PS(52.41," D IX1^DIK K DIK + G REFSND +PIDZ ; + S DFN=+$P(REFSEG,"|",3) + Q +PV1Z ; + S LOCATION=+$P(+$P(REFSEG,"|",3),"^") + S:'$D(^SC(LOCATION,0)) LOCATION="" + S INPTRX=0 I $G(LOCATION) S PSINPTR=$P($G(^SC(LOCATION,0)),"^",4) I PSINPTR Q + I $G(LOCATION) S INPTRX=$P($G(^SC(LOCATION,0)),"^",15) + I '$G(INPTRX) S INPTRX=$O(^DG(40.8,0)) + I '$G(DT) S DT=$$DT^XLFDT + S PSINPTR=+$$SITE^VASITE(DT,INPTRX) + Q +ORCZ ; + S PLACER=+$P(REFSEG,"|",2),REFILLER=+$P(REFSEG,"|",3),ENTERED=+$P(REFSEG,"|",10),PROV=+$P(REFSEG,"|",12) + Q +ZRXZ ; + S ROUTING=$P(REFSEG,"|",4) + Q +STUFF ; + S PSOVRBD=$P($G(^PS(50.7,+$G(PSORDITE),0)),"^",2) + I '$G(PSOVRBD) K PSOVRBD Q + ;K PSONUNN F PSONUN=0:0 S PSONUN=$O(^PS(50.606,PSOVRBD,"NOUN",PSONUN)) Q:'PSONUN!($D(PSONUNN)) S:$P($G(^(PSONUN,0)),"^")'="" PSONUNN=$P($G(^(0)),"^") + S PSOVRB=$P($G(^PS(50.606,PSOVRBD,"MISC")),"^") + F EE=0:0 S EE=$O(^PS(52.41,PENDING,1,EE)) Q:'EE S $P(^PS(52.41,PENDING,1,EE,1),"^",10)=$G(PSOVRB) + K PSOVRBD,PSONUNN,PSONUN,PSOVRB + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLNE3.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLNE3.m index c1c2ee42..e6f67c9b 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLNE3.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLNE3.m @@ -1,161 +1,151 @@ -PSOHLNE3 ;BIR/LE - Process Edit Information from CPRS ;02/27/04 - ;;7.0;OUTPATIENT PHARMACY;**143,239,201,225**;DEC 1997;Build 29 - ;External reference to ^OR(100 private DBIA 2219 - ;External reference VADPT supported by DBIA 10061 - ; - ;This API is used to update the prescription file when ICD-9 diagnosis and SC/EI's are updated as a result of an e-sig in CPRS. - ; -EN(DFN,ORITEM,ORIEN,ORDX,ORSCEI) ;ENTRY POINT - ; Used to import edit information from CPRS - ;Where Input: - ;DFN = Patient IEN - ;ORITEM = Package reference number from file 100 - ;ORIEN = ien from file 100 - ;ORDX(1)= (pointer to file 80) up to 8 accepted and first is primary ICD - ;ORDX(2)= (pointer to file 80) - ;ORSCEI= seven pieces - where 1=yes, 0=no, null or ? =not asked - ; ORSCEI=AO^IR^SC^EC^MST^HNC^CV^SHAD - N %,DX,DX2,DX3,RXN,PSOSCP,PSOX,ORDPROV,PSOSCP2,DA,RET,PSOANSQ,PSORX,PTSTATUS,ARRAY,PSOOI,ORITEM2,ORID,OICHK,PSORENW - N PSODCPY,PSONEW,PSOOIBQ,PSOFLD,PSODCZ,PSOSTAZ,PREA,PSOPIBQ,PSOIBQC,PSOSCA,PSOPICD,PSODGUP,PSOOICD,PSOPFS,TYPE,PSONW,PSOOLD,PSODA - N PSODD,PSOSI,X,PSOSITE,PSOBILL,PSOCPAY,PSOCICD - S:'$D(ORIEN) ORIEN="" S:'$D(ORSCEI) ORSCEI="" S:'$D(ORITEM) ORITEM="" - ; - ;validate prescription IEN with DFN, ord item, and placer# - S RET=1,PSODCZ=",12,14,15," - S RXN=ORITEM I '$D(^PSRX(RXN)) S RET="0^1" Q RET ;invalid RX ien - I $D(^PSRX(RXN,"STA")) S PSOSTAZ=^PSRX(RXN,"STA") - ; get prescription file patient ien, drug, and placer order # - D GETS^DIQ(52,RXN_",","2;6;39.3","I","ARRAY") - I '$D(ARRAY(52,RXN_",",2,"I")) S RET="0^3" Q RET ;quit if you don't have a patient ien - I ARRAY(52,RXN_",",2,"I")'=DFN S RET="0^3" Q RET ;quit if patient dfn is different - I '$D(ARRAY(52,RXN_",",39.3,"I")) S ARRAY(52,RXN_",",39.3,"I")="" ;if don't have it; treat is as null - I ARRAY(52,RXN_",",39.3,"I")'="" I ARRAY(52,RXN_",",39.3,"I")'=ORIEN S RET="0^5" Q RET ;placer # is different - I ARRAY(52,RXN_",",39.3,"I")="" S OICHK=0 D CHKOI I OICHK S RET="0^4" Q RET ;quit if placer # is null and orderable item is different or null. - ;end of validation process - ; - S PSODD=$$GET1^DIQ(52,RXN_",",6,"I") S:($P($G(^PSDRUG(PSODD,0)),"^",3)["S")!($P($G(^(0)),"^",3)["I") PSOSI=1 - S PSOPIBQ=$G(^PSRX(RXN,"IBQ")),PSOPICD=$P($G(^PSRX(RXN,"ICD",1,0)),"^",2,8) - S PSOX("IRXN")=RXN,PSORENW("IRXN")=RXN - S (PSONEW("PATIENT STATUS"),PTSTATUS)=$$GET1^DIQ(52,RXN_",","3","I") - I '$D(PTSTATUS) S (PSONEW("PATIENT STATUS"),PTSTATUS)="" - ;if patient status is null, treat same as PSONEW2, PSORN52, PSONEWG, AND PSONEWF. If piece 7 of ^PS(53 doesn't equal 1, it's not exempt from copay. - I ORSCEI["?" S ORSCEI=$TR(ORSCEI,"?","") - D SCP^PSORN52D - S PSOANSQ(PSOX("IRXN"),"VEH")=$P(ORSCEI,U,1) - S PSOANSQ(PSOX("IRXN"),"RAD")=$P(ORSCEI,U,2) - I PSOSCP<50&($P($G(^PS(53,+$G(PTSTATUS),0)),"^",7)'=1) S PSOANSQ(PSOX("IRXN"),"SC")=$P(ORSCEI,U,3),PSOANSQ("SC")=$P(ORSCEI,U,3) - I PSOSCP>49!($P($G(^PS(53,+$G(PTSTATUS),0)),"^",7)=1) S PSOANSQ(PSOX("IRXN"),"SC>50")=$P(ORSCEI,U,3),PSOANSQ("SC>50")=$P(ORSCEI,U,3) - I PSOSCP=""&('$D(PSOANSQ("SC")))&($D(^PSRX(RXN,"ICD",1))) S PSOANSQ("SC")=$P(^PSRX(RXN,"ICD",1,0),"^",4),PSOANSQ(PSOX("IRXN"),"SC")=PSOANSQ("SC") ;for SC with no percentage defined/ legacy - S PSOANSQ(PSOX("IRXN"),"PGW")=$P(ORSCEI,U,4) - S PSOANSQ(PSOX("IRXN"),"MST")=$P(ORSCEI,U,5) - S PSOANSQ(PSOX("IRXN"),"HNC")=$P(ORSCEI,U,6) - S PSOANSQ(PSOX("IRXN"),"CV")=$P(ORSCEI,U,7) - S PSOANSQ(PSOX("IRXN"),"SHAD")=$P(ORSCEI,U,8) - D:'$$PATCH^XPDUTL("OR*3.0*243") SHAD^PSORN52D - S DX="",DX2=0 F S DX=$O(ORDX(DX)) Q:DX="" S DX2=DX2+1,PSORX("ICD",DX2)=ORDX(DX) ;Multi signed Rx's come in consecutively and the diagnosis subscript doesn't start with 1 for each Rx - S PSOSCP2=1 ;used in PSORN52D - ; -ICD2 ;Check to see if SC/EI changed during CPRS sign order - D GETS^DIQ(52,PSOX("IRXN")_",","52311*","I","PSOOICD") - S PSODCPY=0,PSOFLD="" - F TYPE="VEH","RAD","SC>50","PGW","MST","HNC","CV","SHAD" Q:PSODCPY F PSOFLD=1:1:8 D Q:PSODCPY - . I TYPE="VEH"&(PSOFLD=1) D CHOC - . I TYPE="RAD"&(PSOFLD=2) D CHOC - . I TYPE="SC>50"&(PSOFLD=3)&($D(PSOANSQ(PSOX("IRXN"),TYPE))) D CHOC - . I TYPE="PGW"&(PSOFLD=4) D CHOC - . I TYPE="MST"&(PSOFLD=5) D CHOC - . I TYPE="HNC"&(PSOFLD=6) D CHOC - . I TYPE="CV"&(PSOFLD=7) D CHOC - . I TYPE="SHAD"&(PSOFLD=8) D:$$PATCH^XPDUTL("OR*3.0*243") CHOC - I $D(PSOANSQ("SC")) S PSOFLD=3 S:PSOANSQ("SC")'=PSOOICD(52.052311,1_","_PSOX("IRXN")_",",PSOFLD,"I") PSODCPY=1,PSOFLD="" - ; IF NO SC/EI DIFFERENCES, CHECK FOR ICD CHANGES. If there were SC/EI difference, don't need to check ICD because they are sent anyway when copay update is done. - I '$G(PSODCPY) D - .I '$D(PSORX("ICD"))&($G(PSOOICD(52.052311,1_","_RXN_",",.01,"I"))) S PSODGUP=1 Q ;if no ICD's passed and ICD's defined in 52, CPRS overrides OP - .S (DX3,DX2,DX)="" F S DX=$O(PSOOICD(52.052311,DX)) Q:DX="" S DX2=+DX ;get last entry for file 52 - .S DX="" F S DX=$O(PSORX("ICD",DX)) Q:DX="" S DX3=DX D ;get last entry for new ICD's from CPRS - .. I $G(PSOOICD(52.052311,DX_","_PSOX("IRXN")_",",.01,"I"))'=PSORX("ICD",DX) S PSODGUP=1 ;if ICD'S changed or more new ICD's than old ones. - .I DX2>DX3 S PSODGUP=1 ;if more old ICD's than new ones - Q:'$G(PSODCPY)&('$G(PSODGUP)) 1 - D FILE2^PSORN52D ;file SC/EI/ICD'S into Rx file - ;S PSOCIDC=$P($G(^PSRX(RXN,"ICD",1,0)),"^",2,8) - ;only do copay if SC/EI changed and SC is less than 50%. - I PSODCZ[(","_$G(PSOSTAZ)_",") S RET="0^6" Q RET ;discontinue's no copay changes allowed. - ; - ;Get last fill number - N PSOLFIL S PSOLFIL=$$LF^PSOPFSU1(RXN) - S PSOPFS=$P($S('PSOLFIL:$G(^PSRX(RXN,"PFS")),1:$G(^PSRX(RXN,1,PSOLFIL,"PFS"))),"^",1,2) - ; No-copay to copay updates - S PSOIBQC=$G(^PSRX(RXN,"IBQ")),PSOCICD=$P($G(^PSRX(RXN,"ICD",1,0)),"^",2,8) - D CPAY - ; must check IBQ node in case it's a pre-CIDC rx/copay, ICD node for exempt/supply items, and for diagnosis updates for NSC Rx's - I (PSOPIBQ[1&(PSOIBQC'[1))!(PSOIBQC=""&(PSOPICD[1&(PSOCICD'[1)))!($G(PSODGUP)) D Q RET ;don't do no copay to copay bills, but update status - . D ALOG - . I (PSOSCP<50)&($G(PSODCPY)) D - .. I $P($G(^PS(53,+$G(PTSTATUS),0)),"^",7)'=1&('$G(PSOSI)) D - ... S:+$G(PSOCPAY)<1&($D(^PSRX(RXN,"IB"))) $P(^PSRX(RXN,"IB"),"^",1)="" - ... I +$G(PSOCPAY)>0 S $P(^PSRX(RXN,"IB"),"^",1)=+$G(PSOCPAY),PSOOLD="No Copay",PSONW="Copay",PREA="R",PSODA=RXN D:'$G(PSOSI) ACTLOG^PSOCPA - . I +$G(PSOPFS)>0&('$P($G(PSOPFS),"^",2)) K PSOPFS Q ;don't send unreleased charge msg - . I +$G(PSOPFS)<1 K PSOPFS ;invalid PFSS ACCT REF/ SEND TO IB - . I +$G(PSOPFS)>0 S PSOPFS="1^"_PSOPFS - . ; - . I +$G(PSOPFS) D CHRG^PSOPFSU1(RXN,PSOLFIL,"CG",PSOPFS) ;always send to external bill sys - ; - ; Copay to no-copay updates - I $G(PSODCPY) D COPAY^PSOHLNE4 - ;ICD UPDATE ONLY FOR COPAYS - I ('$G(PSODCPY)&($G(PSODGUP)))&($P($G(PSOPFS),"^",2)) D CHRG^PSOPFSU1(RXN,PSOLFIL,"CG",PSOPFS) ;DIAGNOSIS UPDATE ONLY - I ($G(PSODCPY)!($G(PSODGUP))) D ALOG - Q RET - ; -CPAY ; - N X,Y,III,ACTYP,BL - S PSOSITE=$P(^PSRX(RXN,2),"^",9) - S X=$P($G(^PS(59,+PSOSITE,"IB")),"^")_"^"_DFN D XTYPE^IBARX - S (ACTYP,BL)="",(PSOBILL,PSOCPAY)=0 -CPAY1 ; - S ACTYP=$O(Y(ACTYP)) G:'ACTYP CSKP F III=0:0 S BL=$O(Y(ACTYP,BL)) Q:BL="" I BL>0 S PSOBILL=BL,PSOCPAY=BL_"^"_Y(ACTYP,BL) - G CPAY1 -CSKP ; - S:$G(PSOSI) PSOCPAY=0 ;Supply item/investigational drug - S:$P($G(^PS(53,+$G(PTSTATUS),0)),"^",7)=1 PSOCPAY=0 ;Rx Patient Status exempt - I PSOIBQC'="" S:PSOIBQC'[1 PSOCPAY=1 ;Yes SC/EI from CPRS - I (PSOBILL'>0)!(PSOCPAY=0) S PSOCPAY=0 ;INELIGIBLE - Q - ; -CHOC ;check outpatient classifications - S:PSOANSQ(PSOX("IRXN"),TYPE)'=PSOOICD(52.052311,1_","_PSOX("IRXN")_",",PSOFLD,"I") PSODCPY=1 - Q - ; -ALOG ;set activity log with edit info from cprs - N ACNT,SUB,RF,RFCNT - S ACNT=0 F SUB=0:0 S SUB=$O(^PSRX(RXN,"A",SUB)) Q:'SUB S ACNT=SUB - S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(RXN,1,RF)) Q:'RF S RFCNT=RF S:RF>5 RFCNT=RF+1 - D NOW^%DTC S ACNT=ACNT+1 - S ^PSRX(RXN,"A",0)="^52.3DA^"_ACNT_"^"_ACNT S ^PSRX(RXN,"A",ACNT,0)=%_"^"_"E"_"^^"_RFCNT_"^Clinical Indicators and SC/EI's were updated from a CPRS e-sig edit at "_$E($P(%,".",2),1,2)_":"_$E($P(%,".",2),3,4)_"." - Q - ; -CHKOI ;get and compare orderable items in file #100 and #52; don't process - ; if it's different and the placer # is null. - I '$D(ARRAY(52,RXN_",",6,"I")) S OICHK=1 Q - D GETS^DIQ(50,ARRAY(52,RXN_",",6,"I")_",","2.1","I","PSOOI") - S ORITEM2=$$GET1^DIQ(100.001,"1,"_ORIEN_",",".01","I") - S ORID=$$GET1^DIQ(101.43,ORITEM2_",","2","I") S ORID=$P(ORID,";",1) - I PSOOI(50,ARRAY(52,RXN_",",6,"I")_",",2.1,"I")'="" I PSOOI(50,ARRAY(52,RXN_",",6,"I")_",",2.1,"I")'=ORID S OICHK=1 - Q -TEST(ORIEN) ;manually test an individual order record - N I,X,ORSCEIS,ORSCEI,ORDX,EDFLG,ORITEM,DFN,JJ - S (JJ,I)=0 F S I=$O(^OR(100,ORIEN,5.1,I)) Q:I=""!(I'?1N.NN) S JJ=JJ+1,ORDX(JJ)=$G(^OR(100,ORIEN,5.1,I,0)) - S ORSCEIS=^OR(100,ORIEN,5.2),ORITEM=$P($G(^OR(100,ORIEN,4)),"^",1) - S ORSCEI="" F I=3,4,1,5,2,6,7 S ORSCEI=ORSCEI_"^"_$P(ORSCEIS,"^",I) - S:$$PATCH^XPDUTL("OR*3.0*243") ORSCEI=ORSCEI_"^"_$P(ORSCEIS,"^",8) - S ORSCEI=$E(ORSCEI,2,99) - S RXN=ORITEM,DFN=$P($P(^OR(100,ORIEN,0),"^",2),";",1) - D EN^PSOHLNE3(DFN,ORITEM,ORIEN,.ORDX,ORSCEI) - Q -OBXNTE ; Called from PSOHLNEW due to it's routine size. - S LL=ZZ+1,PSOBCT=2 - I $P($G(MSG(LL)),"|")="NTE" D - .I $P(MSG(LL),"|",4)'="" S PSOBCT=3,OBXAR(OCOUNT,2)=$P(MSG(LL),"|",4) - .F LLL=0:0 S LLL=$O(MSG(LL,LLL)) Q:'LLL D - ..I $P($G(MSG(LL,LLL)),"|",4)'="" S OBXAR(OCOUNT,PSOBCT)=$P(MSG(LL,LLL),"|",4),PSOBCT=PSOBCT+1 - Q +PSOHLNE3 ;BIR/LE - Process Edit Information from CPRS ;02/27/04 + ;;7.0;OUTPATIENT PHARMACY;**143,239,201**;DEC 1997 + ;External reference to ^OR(100 private DBIA 2219 + ;External reference VADPT supported by DBIA 10061 + ; + ;This API is used to update the prescription file when ICD-9 diagnosis and SC/EI's are updated as a result of an e-sig in CPRS. + ; +EN(DFN,ORITEM,ORIEN,ORDX,ORSCEI) ;ENTRY POINT + ; Used to import edit information from CPRS + ;Where Input: + ;DFN = Patient IEN + ;ORITEM = Package reference number from file 100 + ;ORIEN = ien from file 100 + ;ORDX(1)= (pointer to file 80) up to 8 accepted and first is primary ICD + ;ORDX(2)= (pointer to file 80) + ;ORSCEI= seven pieces - where 1=yes, 0=no, null or ? =not asked + ; ORSCEI=AO^IR^SC^EC^MST^HNC^CV + N %,DX,DX2,DX3,RXN,PSOSCP,PSOX,ORDPROV,PSOSCP2,DA,RET,PSOANSQ,PSORX,PTSTATUS,ARRAY,PSOOI,ORITEM2,ORID,OICHK,PSORENW + N PSODCPY,PSONEW,PSOOIBQ,PSOFLD,PSODCZ,PSOSTAZ,PREA,PSOPIBQ,PSOIBQC,PSOSCA,PSOPICD,PSODGUP,PSOOICD,PSOPFS,TYPE,PSONW,PSOOLD,PSODA + N PSODD,PSOSI,X,PSOSITE,PSOBILL,PSOCPAY,PSOCICD + S:'$D(ORIEN) ORIEN="" S:'$D(ORSCEI) ORSCEI="" S:'$D(ORITEM) ORITEM="" + ; + ;validate prescription IEN with DFN, ord item, and placer# + S RET=1,PSODCZ=",12,14,15," + S RXN=ORITEM I '$D(^PSRX(RXN)) S RET="0^1" Q RET ;invalid RX ien + I $D(^PSRX(RXN,"STA")) S PSOSTAZ=^PSRX(RXN,"STA") + ; get prescription file patient ien, drug, and placer order # + D GETS^DIQ(52,RXN_",","2;6;39.3","I","ARRAY") + I '$D(ARRAY(52,RXN_",",2,"I")) S RET="0^3" Q RET ;quit if you don't have a patient ien + I ARRAY(52,RXN_",",2,"I")'=DFN S RET="0^3" Q RET ;quit if patient dfn is different + I '$D(ARRAY(52,RXN_",",39.3,"I")) S ARRAY(52,RXN_",",39.3,"I")="" ;if don't have it; treat is as null + I ARRAY(52,RXN_",",39.3,"I")'="" I ARRAY(52,RXN_",",39.3,"I")'=ORIEN S RET="0^5" Q RET ;placer # is different + I ARRAY(52,RXN_",",39.3,"I")="" S OICHK=0 D CHKOI I OICHK S RET="0^4" Q RET ;quit if placer # is null and orderable item is different or null. + ;end of validation process + ; + S PSODD=$$GET1^DIQ(52,RXN_",",6,"I") S:($P($G(^PSDRUG(PSODD,0)),"^",3)["S")!($P($G(^(0)),"^",3)["I") PSOSI=1 + S PSOPIBQ=$G(^PSRX(RXN,"IBQ")),PSOPICD=$P($G(^PSRX(RXN,"ICD",1,0)),"^",2,7) + S PSOX("IRXN")=RXN,PSORENW("IRXN")=RXN + S (PSONEW("PATIENT STATUS"),PTSTATUS)=$$GET1^DIQ(52,RXN_",","3","I") + I '$D(PTSTATUS) S (PSONEW("PATIENT STATUS"),PTSTATUS)="" + ;if patient status is null, treat same as PSONEW2, PSORN52, PSONEWG, AND PSONEWF. If piece 7 of ^PS(53 doesn't equal 1, it's not exempt from copay. + I ORSCEI["?" S ORSCEI=$TR(ORSCEI,"?","") + D SCP^PSORN52D + S PSOANSQ(PSOX("IRXN"),"VEH")=$P(ORSCEI,U,1) + S PSOANSQ(PSOX("IRXN"),"RAD")=$P(ORSCEI,U,2) + I PSOSCP<50&($P($G(^PS(53,+$G(PTSTATUS),0)),"^",7)'=1) S PSOANSQ(PSOX("IRXN"),"SC")=$P(ORSCEI,U,3),PSOANSQ("SC")=$P(ORSCEI,U,3) + I PSOSCP>49!($P($G(^PS(53,+$G(PTSTATUS),0)),"^",7)=1) S PSOANSQ(PSOX("IRXN"),"SC>50")=$P(ORSCEI,U,3),PSOANSQ("SC>50")=$P(ORSCEI,U,3) + I PSOSCP=""&('$D(PSOANSQ("SC")))&($D(^PSRX(RXN,"ICD",1))) S PSOANSQ("SC")=$P(^PSRX(RXN,"ICD",1,0),"^",4),PSOANSQ(PSOX("IRXN"),"SC")=PSOANSQ("SC") ;for SC with no percentage defined/ legacy + S PSOANSQ(PSOX("IRXN"),"PGW")=$P(ORSCEI,U,4) + S PSOANSQ(PSOX("IRXN"),"MST")=$P(ORSCEI,U,5) + S PSOANSQ(PSOX("IRXN"),"HNC")=$P(ORSCEI,U,6) + S PSOANSQ(PSOX("IRXN"),"CV")=$P(ORSCEI,U,7) + ; + S DX="",DX2=0 F S DX=$O(ORDX(DX)) Q:DX="" S DX2=DX2+1,PSORX("ICD",DX2)=ORDX(DX) ;Multi signed Rx's come in consecutively and the diagnosis subscript doesn't start with 1 for each Rx + S PSOSCP2=1 ;used in PSORN52D + ; +ICD2 ;Check to see if SC/EI changed during CPRS sign order + D GETS^DIQ(52,PSOX("IRXN")_",","52311*","I","PSOOICD") + S PSODCPY=0,PSOFLD="" + F TYPE="VEH","RAD","SC>50","PGW","MST","HNC","CV" Q:PSODCPY F PSOFLD=1:1:7 D Q:PSODCPY + . I TYPE="VEH"&(PSOFLD=1) D CHOC + . I TYPE="RAD"&(PSOFLD=2) D CHOC + . I TYPE="SC>50"&(PSOFLD=3)&($D(PSOANSQ(PSOX("IRXN"),TYPE))) D CHOC + . I TYPE="PGW"&(PSOFLD=4) D CHOC + . I TYPE="MST"&(PSOFLD=5) D CHOC + . I TYPE="HNC"&(PSOFLD=6) D CHOC + . I TYPE="CV"&(PSOFLD=7) D CHOC + I $D(PSOANSQ("SC")) S PSOFLD=3 S:PSOANSQ("SC")'=PSOOICD(52.052311,1_","_PSOX("IRXN")_",",PSOFLD,"I") PSODCPY=1,PSOFLD="" + ; IF NO SC/EI DIFFERENCES, CHECK FOR ICD CHANGES. If there were SC/EI difference, don't need to check ICD because they are sent anyway when copay update is done. + I '$G(PSODCPY) D + .I '$D(PSORX("ICD"))&($G(PSOOICD(52.052311,1_","_RXN_",",.01,"I"))) S PSODGUP=1 Q ;if no ICD's passed and ICD's defined in 52, CPRS overrides OP + .S (DX3,DX2,DX)="" F S DX=$O(PSOOICD(52.052311,DX)) Q:DX="" S DX2=+DX ;get last entry for file 52 + .S DX="" F S DX=$O(PSORX("ICD",DX)) Q:DX="" S DX3=DX D ;get last entry for new ICD's from CPRS + .. I $G(PSOOICD(52.052311,DX_","_PSOX("IRXN")_",",.01,"I"))'=PSORX("ICD",DX) S PSODGUP=1 ;if ICD'S changed or more new ICD's than old ones. + .I DX2>DX3 S PSODGUP=1 ;if more old ICD's than new ones + Q:'$G(PSODCPY)&('$G(PSODGUP)) 1 + D FILE2^PSORN52D ;file SC/EI/ICD'S into Rx file + ;S PSOCIDC=$P($G(^PSRX(RXN,"ICD",1,0)),"^",2,7) + ;only do copay if SC/EI changed and SC is less than 50%. + I PSODCZ[(","_$G(PSOSTAZ)_",") S RET="0^6" Q RET ;discontinue's no copay changes allowed. + ; + ;Get last fill number + N PSOLFIL S PSOLFIL=$$LF^PSOPFSU1(RXN) + S PSOPFS=$P($S('PSOLFIL:$G(^PSRX(RXN,"PFS")),1:$G(^PSRX(RXN,1,PSOLFIL,"PFS"))),"^",1,2) + ; No-copay to copay updates + S PSOIBQC=$G(^PSRX(RXN,"IBQ")),PSOCICD=$P($G(^PSRX(RXN,"ICD",1,0)),"^",2,7) + D CPAY + ; must check IBQ node in case it's a pre-CIDC rx/copay, ICD node for exempt/supply items, and for diagnosis updates for NSC Rx's + I (PSOPIBQ[1&(PSOIBQC'[1))!(PSOIBQC=""&(PSOPICD[1&(PSOCICD'[1)))!($G(PSODGUP)) D Q RET ;don't do no copay to copay bills, but update status + . D ALOG + . I (PSOSCP<50)&($G(PSODCPY)) D + .. I $P($G(^PS(53,+$G(PTSTATUS),0)),"^",7)'=1&('$G(PSOSI)) D + ... S:+$G(PSOCPAY)<1&($D(^PSRX(RXN,"IB"))) $P(^PSRX(RXN,"IB"),"^",1)="" + ... I +$G(PSOCPAY)>0 S $P(^PSRX(RXN,"IB"),"^",1)=+$G(PSOCPAY),PSOOLD="No Copay",PSONW="Copay",PREA="R",PSODA=RXN D:'$G(PSOSI) ACTLOG^PSOCPA + . I +$G(PSOPFS)>0&('$P($G(PSOPFS),"^",2)) K PSOPFS Q ;don't send unreleased charge msg + . I +$G(PSOPFS)<1 K PSOPFS ;invalid PFSS ACCT REF/ SEND TO IB + . I +$G(PSOPFS)>0 S PSOPFS="1^"_PSOPFS + . ; + . I +$G(PSOPFS) D CHRG^PSOPFSU1(RXN,PSOLFIL,"CG",PSOPFS) ;always send to external bill sys + ; + ; Copay to no-copay updates + I $G(PSODCPY) D COPAY^PSOHLNE4 + ;ICD UPDATE ONLY FOR COPAYS + I ('$G(PSODCPY)&($G(PSODGUP)))&($P($G(PSOPFS),"^",2)) D CHRG^PSOPFSU1(RXN,PSOLFIL,"CG",PSOPFS) ;DIAGNOSIS UPDATE ONLY + I ($G(PSODCPY)!($G(PSODGUP))) D ALOG + Q RET + ; +CPAY ; + N X,Y,III,ACTYP,BL + S PSOSITE=$P(^PSRX(RXN,2),"^",9) + S X=$P($G(^PS(59,+PSOSITE,"IB")),"^")_"^"_DFN D XTYPE^IBARX + S (ACTYP,BL)="",(PSOBILL,PSOCPAY)=0 +CPAY1 ; + S ACTYP=$O(Y(ACTYP)) G:'ACTYP CSKP F III=0:0 S BL=$O(Y(ACTYP,BL)) Q:BL="" I BL>0 S PSOBILL=BL,PSOCPAY=BL_"^"_Y(ACTYP,BL) + G CPAY1 +CSKP ; + S:$G(PSOSI) PSOCPAY=0 ;Supply item/investigational drug + S:$P($G(^PS(53,+$G(PTSTATUS),0)),"^",7)=1 PSOCPAY=0 ;Rx Patient Status exempt + I PSOIBQC'="" S:PSOIBQC'[1 PSOCPAY=1 ;Yes SC/EI from CPRS + I (PSOBILL'>0)!(PSOCPAY=0) S PSOCPAY=0 ;INELIGIBLE + Q + ; +CHOC ;check outpatient classifications + S:PSOANSQ(PSOX("IRXN"),TYPE)'=PSOOICD(52.052311,1_","_PSOX("IRXN")_",",PSOFLD,"I") PSODCPY=1 + Q + ; +ALOG ;set activity log with edit info from cprs + N ACNT,SUB,RF,RFCNT + S ACNT=0 F SUB=0:0 S SUB=$O(^PSRX(RXN,"A",SUB)) Q:'SUB S ACNT=SUB + S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(RXN,1,RF)) Q:'RF S RFCNT=RF S:RF>5 RFCNT=RF+1 + D NOW^%DTC S ACNT=ACNT+1 + S ^PSRX(RXN,"A",0)="^52.3DA^"_ACNT_"^"_ACNT S ^PSRX(RXN,"A",ACNT,0)=%_"^"_"E"_"^^"_RFCNT_"^Clinical Indicators and SC/EI's were updated from a CPRS e-sig edit at "_$E($P(%,".",2),1,2)_":"_$E($P(%,".",2),3,4)_"." + Q + ; +CHKOI ;get and compare orderable items in file #100 and #52; don't process + ; if it's different and the placer # is null. + I '$D(ARRAY(52,RXN_",",6,"I")) S OICHK=1 Q + D GETS^DIQ(50,ARRAY(52,RXN_",",6,"I")_",","2.1","I","PSOOI") + S ORITEM2=$$GET1^DIQ(100.001,"1,"_ORIEN_",",".01","I") + S ORID=$$GET1^DIQ(101.43,ORITEM2_",","2","I") S ORID=$P(ORID,";",1) + I PSOOI(50,ARRAY(52,RXN_",",6,"I")_",",2.1,"I")'="" I PSOOI(50,ARRAY(52,RXN_",",6,"I")_",",2.1,"I")'=ORID S OICHK=1 + Q +TEST(ORIEN) ;manually test an individual order record + N I,X,ORSCEIS,ORSCEI,ORDX,EDFLG,ORITEM,DFN,JJ + S (JJ,I)=0 F S I=$O(^OR(100,ORIEN,5.1,I)) Q:I=""!(I'?1N.NN) S JJ=JJ+1,ORDX(JJ)=$G(^OR(100,ORIEN,5.1,I,0)) + S ORSCEIS=^OR(100,ORIEN,5.2),ORITEM=$P($G(^OR(100,ORIEN,4)),"^",1) + S ORSCEI="" F I=3,4,1,5,2,6,7 S ORSCEI=ORSCEI_"^"_$P(ORSCEIS,"^",I) + S ORSCEI=$E(ORSCEI,2,99) + S RXN=ORITEM,DFN=$P($P(^OR(100,ORIEN,0),"^",2),";",1) + D EN^PSOHLNE3(DFN,ORITEM,ORIEN,.ORDX,ORSCEI) + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLNE4.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLNE4.m index f0885941..a29b9f33 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLNE4.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLNE4.m @@ -1,74 +1,53 @@ -PSOHLNE4 ;BIR/LE - Process Edit Information from CPRS - CONTINUED FROM PSOHLNE3 ;02/27/04 - ;;7.0;OUTPATIENT PHARMACY;**201,225**;DEC 1997;Build 29 - ; - ;This API is used to update the prescription file when ICD-9 diagnosis - ; and SC/EI's are updated as a result of an e-sig in CPRS. - Q -COPAY ;For IB, cancel copay charges if SC<50% and SC/EI changed and released; For PFS, send charge update msgs for SC 0-100% - ; must have PSODA,PSO,PSODAYS,PSOFLAG,PSOREF,PSOIB,PSOPAR7,PSOOLD,PSONW before call to PSOCPA - N PSODA,PSO,PSODAYS,PSOFLAG,PSOREF,PSOIB,PSZ,PSOPAR7,PSOCSEQ,PSZ1,PSZ2,RELDAT,PSOOLD,PSONW,PSOSITE,PREA,PSOFLD,PSOPFS - S PSODA=RXN,PSO=3,PSODAYS=$$GET1^DIQ(52,PSODA_",","8") - S PSOOLD="Copay" - S PSONW="No Copay" - S PSOSITE=$P(^PSRX(PSODA,2),"^",9) - S PSOPAR7=$G(^PS(59,PSOSITE,"IB")) - S PSOFLAG=1 ;1 used here to eliminate display/print of messages. -CSORT ; get orig fill copay info if released. - S RELDAT=$$GET1^DIQ(52,PSODA_",","31","I") - I RELDAT'="" S PSOCSEQ("A",0)=$G(^PSRX(PSODA,"IB")) - ;I RELDAT="" S PREA="R" D:'$G(PSOSI)&(PSOSCP<50)&($P($G(^PS(53,+$G(PTSTATUS),0)),"^",7)'=1) ACTLOG^PSOCPA G SET ;set act log when unreleased, but SC/EI changed copay - I RELDAT="" S PREA="R" D:+$G(PSOCPAY)>0&(PSOIBQC[1&(PSOPIBQ'[1)) ACTLOG^PSOCPA G SET ;set act log when unreleased, but SC/EI changed copay - ; get copay info for all released refills; if any - F PSZ=0:0 S PSZ=$O(^PSRX(PSODA,1,PSZ)) Q:PSZ'>0 D - . S RELDAT="",RELDAT=$$GET1^DIQ(52.1,PSZ_","_PSODA_",","17","I") - . Q:RELDAT="" - . S PSOCSEQ("A",PSZ)=$G(^PSRX(PSODA,1,PSZ,"IB")) - ; Sort potential refills to be cancelled first starting with last fill - ; then orig fill then the rest of the entries. - S (PSZ1,PSZ2,PSZ)="" F S PSZ=$O(PSOCSEQ("A",PSZ),-1) Q:PSZ="" D - . I PSZ>0&($P(PSOCSEQ("A",PSZ),"^",2)'="") S PSZ1=PSZ1+1,PSOCSEQ("B",PSZ1,PSZ)="" Q - . I PSZ>0&($P(PSOCSEQ("A",PSZ),"^",2)="") S PSZ2=PSZ2+1000,PSOCSEQ("B",PSZ2,PSZ)="" Q - . I PSZ=0&($P(PSOCSEQ("A",PSZ),"^",4)'="") S PSZ1=PSZ1+1,PSOCSEQ("B",PSZ1,PSZ)="" Q - . I PSZ=0&($P(PSOCSEQ("A",PSZ),"^",4)="") S PSZ2=PSZ2+1000,PSOCSEQ("B",PSZ2,PSZ)="" Q - ; - ;S (PSZ,PSZ1)="",PSOFLD=0,PREA="R" D:'$G(PSOSI)&(PSOSCP<50)&($P($G(^PS(53,+$G(PTSTATUS),0)),"^",7)'=1) ACTLOG^PSOCPA F S PSZ1=$O(PSOCSEQ("B",PSZ1)) Q:PSZ1="" D - S (PSZ,PSZ1)="",PSOFLD=0,PREA="R" D:+$G(PSOCPAY)>0&(PSOIBQC[1&(PSOPIBQ'[1)) ACTLOG^PSOCPA F S PSZ1=$O(PSOCSEQ("B",PSZ1)) Q:PSZ1="" D - . F S PSZ=$O(PSOCSEQ("B",PSZ1,PSZ)) Q:PSZ="" D - .. S (PSOREF,PSOIB)="",PSOFLD=PSOFLD+1 S PREA="C" ;$S(PSOFLD=1:"R",1:"C") - .. ;I PSOFLD>1 - .. S (PSOOLD,PSONW)="" - .. S PSOREF=PSZ - .. ; - .. S PSOPFS="",PSOPFS=$P($S('PSOREF:$G(^PSRX(PSODA,"PFS")),1:$G(^PSRX(PSODA,1,PSOREF,"PFS"))),"^",1,2) - .. I +$G(PSOPFS)>0&('$P($G(PSOPFS),"^",2)) K PSOPFS Q ;don't send unreleased charge msg - .. I +$G(PSOPFS)<1 K PSOPFS ;invalid PFSS ACCT REF/ SEND TO IB - .. I +$G(PSOPFS)>0 S PSOPFS="1^"_PSOPFS - .. ; - .. N TYPE S PSOIB=PSOCSEQ("A",PSOREF),TYPE=PSOREF - .. I +$G(PSOPFS) D CHRG^PSOPFSU1(PSODA,PSOREF,"CG",PSOPFS) D:+$G(PSOCPAY)>0&(PSOIBQC[1&(PSOPIBQ'[1)) ACTLOG^PSOCPA Q ;PFSS charge update only - .. I PSOSCP<50 D RXED^PSOCPA ;IB - if SC<50 and not billed via PFSS -SET S:$D(^PSRX(RXN,"IB"))&(PSOSCP<50)&('$G(PSOSI)) $P(^PSRX(RXN,"IB"),"^",1)="" - K PSOSCP - Q - ; -OBR ;Flag/Unflag orders - I PSOTYPE'="OBR"!($G(PSOSEG)="") Q - N PSOFLAG,PSORDER,PSOPEN,DR,PSOREA,PSOBY,PSONOW - S PSORDER=+$P($P(PSOSEG,"|",2),"^") ; Pointer to ORDER file (#100) - S PSOPEN=+$O(^PS(52.41,"B",PSORDER,0)) ; Pointer to PENDING OUTPATIENT ORDERS file (#52.41) - S PSOFLAG=$P(PSOSEG,"|",4) ; "FL" for Flag and "UF" for Unflag action - S PSOREA=$P(PSOSEG,"|",13) ; Reason for Flag/Unflag (Freetext up to 80chars) - S PSOBY=$P(PSOSEG,"|",16) ; Flagged/Unflagged By - Pointer to NEW PERSON file (#200) - S PSONOW=$E($$NOW^XLFDT(),1,12) ; CURRENT DATE/TIME wihtout seconds - ; - I 'PSOPEN!'$P($G(^PS(52.41,PSOPEN,0)),"^") D EN^ORERR("Invalid Pending Order/Flag Msg",.MSG) Q - ; - I PSOFLAG="FL" D - . S $P(^PS(52.41,PSOPEN,"FLG"),"^",1,3)=PSONOW_"^"_PSOBY_"^"_$E(PSOREA,1,80) - . S $P(^PS(52.41,PSOPEN,"FLG"),"^",4,6)="^^" - . S $P(^PS(52.41,PSOPEN,0),"^",23)=1 - E D - . S $P(^PS(52.41,PSOPEN,"FLG"),"^",4,6)=PSONOW_"^"_PSOBY_"^"_$E(PSOREA,1,80) - . S $P(^PS(52.41,PSOPEN,0),"^",23)="" - ; - Q +PSOHLNE4 ;BIR/LE - Process Edit Information from CPRS - CONTINUED FROM PSOHLNE3 ;02/27/04 + ;;7.0;OUTPATIENT PHARMACY;**201**;DEC 1997 + ; + ;This API is used to update the prescription file when ICD-9 diagnosis + ; and SC/EI's are updated as a result of an e-sig in CPRS. + Q +COPAY ;For IB, cancel copay charges if SC<50% and SC/EI changed and released; For PFS, send charge update msgs for SC 0-100% + ; must have PSODA,PSO,PSODAYS,PSOFLAG,PSOREF,PSOIB,PSOPAR7,PSOOLD,PSONW before call to PSOCPA + N PSODA,PSO,PSODAYS,PSOFLAG,PSOREF,PSOIB,PSZ,PSOPAR7,PSOCSEQ,PSZ1,PSZ2,RELDAT,PSOOLD,PSONW,PSOSITE,PREA,PSOFLD,PSOPFS + S PSODA=RXN,PSO=3,PSODAYS=$$GET1^DIQ(52,PSODA_",","8") + S PSOOLD="Copay" + S PSONW="No Copay" + S PSOSITE=$P(^PSRX(PSODA,2),"^",9) + S PSOPAR7=$G(^PS(59,PSOSITE,"IB")) + S PSOFLAG=1 ;1 used here to eliminate display/print of messages. +CSORT ; get orig fill copay info if released. + S RELDAT=$$GET1^DIQ(52,PSODA_",","31","I") + I RELDAT'="" S PSOCSEQ("A",0)=$G(^PSRX(PSODA,"IB")) + ;I RELDAT="" S PREA="R" D:'$G(PSOSI)&(PSOSCP<50)&($P($G(^PS(53,+$G(PTSTATUS),0)),"^",7)'=1) ACTLOG^PSOCPA G SET ;set act log when unreleased, but SC/EI changed copay + I RELDAT="" S PREA="R" D:+$G(PSOCPAY)>0&(PSOIBQC[1&(PSOPIBQ'[1)) ACTLOG^PSOCPA G SET ;set act log when unreleased, but SC/EI changed copay + ; get copay info for all released refills; if any + F PSZ=0:0 S PSZ=$O(^PSRX(PSODA,1,PSZ)) Q:PSZ'>0 D + . S RELDAT="",RELDAT=$$GET1^DIQ(52.1,PSZ_","_PSODA_",","17","I") + . Q:RELDAT="" + . S PSOCSEQ("A",PSZ)=$G(^PSRX(PSODA,1,PSZ,"IB")) + ; Sort potential refills to be cancelled first starting with last fill + ; then orig fill then the rest of the entries. + S (PSZ1,PSZ2,PSZ)="" F S PSZ=$O(PSOCSEQ("A",PSZ),-1) Q:PSZ="" D + . I PSZ>0&($P(PSOCSEQ("A",PSZ),"^",2)'="") S PSZ1=PSZ1+1,PSOCSEQ("B",PSZ1,PSZ)="" Q + . I PSZ>0&($P(PSOCSEQ("A",PSZ),"^",2)="") S PSZ2=PSZ2+1000,PSOCSEQ("B",PSZ2,PSZ)="" Q + . I PSZ=0&($P(PSOCSEQ("A",PSZ),"^",4)'="") S PSZ1=PSZ1+1,PSOCSEQ("B",PSZ1,PSZ)="" Q + . I PSZ=0&($P(PSOCSEQ("A",PSZ),"^",4)="") S PSZ2=PSZ2+1000,PSOCSEQ("B",PSZ2,PSZ)="" Q + ; + ;S (PSZ,PSZ1)="",PSOFLD=0,PREA="R" D:'$G(PSOSI)&(PSOSCP<50)&($P($G(^PS(53,+$G(PTSTATUS),0)),"^",7)'=1) ACTLOG^PSOCPA F S PSZ1=$O(PSOCSEQ("B",PSZ1)) Q:PSZ1="" D + S (PSZ,PSZ1)="",PSOFLD=0,PREA="R" D:+$G(PSOCPAY)>0&(PSOIBQC[1&(PSOPIBQ'[1)) ACTLOG^PSOCPA F S PSZ1=$O(PSOCSEQ("B",PSZ1)) Q:PSZ1="" D + . F S PSZ=$O(PSOCSEQ("B",PSZ1,PSZ)) Q:PSZ="" D + .. S (PSOREF,PSOIB)="",PSOFLD=PSOFLD+1 S PREA="C" ;$S(PSOFLD=1:"R",1:"C") + .. ;I PSOFLD>1 + .. S (PSOOLD,PSONW)="" + .. S PSOREF=PSZ + .. ; + .. S PSOPFS="",PSOPFS=$P($S('PSOREF:$G(^PSRX(PSODA,"PFS")),1:$G(^PSRX(PSODA,1,PSOREF,"PFS"))),"^",1,2) + .. I +$G(PSOPFS)>0&('$P($G(PSOPFS),"^",2)) K PSOPFS Q ;don't send unreleased charge msg + .. I +$G(PSOPFS)<1 K PSOPFS ;invalid PFSS ACCT REF/ SEND TO IB + .. I +$G(PSOPFS)>0 S PSOPFS="1^"_PSOPFS + .. ; + .. N TYPE S PSOIB=PSOCSEQ("A",PSOREF),TYPE=PSOREF + .. I +$G(PSOPFS) D CHRG^PSOPFSU1(PSODA,PSOREF,"CG",PSOPFS) D:+$G(PSOCPAY)>0&(PSOIBQC[1&(PSOPIBQ'[1)) ACTLOG^PSOCPA Q ;PFSS charge update only + .. I PSOSCP<50 D RXED^PSOCPA ;IB - if SC<50 and not billed via PFSS +SET S:$D(^PSRX(RXN,"IB"))&(PSOSCP<50)&('$G(PSOSI)) $P(^PSRX(RXN,"IB"),"^",1)="" + K PSOSCP + Q + ; diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLNEW.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLNEW.m index 9f6cf580..e898123c 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLNEW.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLNEW.m @@ -1,148 +1,149 @@ -PSOHLNEW ;BIR/RTR - CPRS orders ;11/30/06 11:49am - ;;7.0;OUTPATIENT PHARMACY;**1,7,15,46,71,98,111,124,117,131,146,132,143,223,235,148,239,249,225**;DEC 1997;Build 29 - ;40.8-728,50-221,SC-2675,100-2219,50.7-2223,EN^ORERR-2187 -EN(MSG) ; - N PSODDRUG,ENTERED,LOCATION,PLACER,PSOOC,ROUTE,NATURE,PREV,ROUTING,OO,OR,STAT,ZZ,DFN,COMM,QCOUNT,OCOUNT,Q1I,QTARRAY,QTARRAY2,EE,PP,XOFLAG,PSODYSPL,PSOFILNM - N ONEFLAG,SERV,WPCT,EFFECT,PROV,PENDING,RRX,PSOLQ1I,PSOLQ1II,PSOQWX,PSOLQ1IX,PSONVA,PSOICD,PSOSCP,EEE - N OBXAR,AA,II,SIG1,FILLER,COMM,GG,FF,JJ,JJJ,CT,LIM,VAR,VAR1,QQQ,PSRNFLAG,PSRNQFLG,RCOMM,XOFLAGZ,NWFLAG,PFLAG,PSINPTR,INPTRX,PSOIBN,PSOIBY - N DSIG,PSOCHFFL,PSOCVI,PSOMO,PSOXRP,NN,LL,LLL,WPARRAY,QTVAR,POVAR,POVAR1,ORCSEG,NNN,OOO,AAA,NNNN,POLIM,NNCK,PRIOR,IPPLACER,PLACERXX,EER,PSERRPID,PSERRPV1,PSERRORC,PSOEXFLG,PSOMSORR,PDFN,VAL - S (SEND,PSOSND,OCOUNT)=0 K PSOPLC,PSOFFL,PSORSO,PSOSUSZ - F OO=0:0 S OO=$O(MSG(OO)) Q:'OO!(SEND)!(PSOSND) D:$P(MSG(OO),"|")="PID" SPDFN I $P(MSG(OO),"|")="ORC",$P(MSG(OO),"|",2)'="NW",$P(MSG(OO),"|",2)'="XO" D - .S OR("STAT")=$P(MSG(OO),"|",2),OR("PLACE")=+$P(MSG(OO),"|",3),PLACERXX=+$P($P(MSG(OO),"|",3),";",2),OR("COMM")=$P(MSG(OO),"|",17),OR("USER")=$P(MSG(OO),"|",11) I $P(MSG(OO),"|",2)'="DE",$P(MSG(OO),"|",2)'="NA" S SEND=1 D FILL Q - .S PSOPLC=+$P(MSG(OO),"|",3),PSOFFL=+$P(MSG(OO),"|",4),PSOSND=1,PSOCHFFL=$P($P(MSG(OO),"|",4),"^") - I $G(OR("COMM"))["^" S OR("COMM")=$P(OR("COMM"),"^",5) - I PSOSND,$G(PSOCHFFL)["S",$G(OR("STAT"))="NA" D CHCS^PSOHLNE1 Q - I PSOSND,'$D(^PSRX(+$G(PSOFFL),0)) S COMM="Order was not located by Pharmacy" D EN^ORERR(COMM,.MSG) D KL Q - I PSOSND,$G(PDFN),PDFN'=+$P($G(^PSRX(+$G(PSOFFL),0)),"^",2) S COMM="Patient does not match" D EN^ORERR(COMM,.MSG) D KL Q - I PSOSND,$G(OR("STAT"))'="DE" N PSONAS S PSONAS=$S($P($G(^PSRX(PSOFFL,"OR1")),"^",2)="":1,1:0) S $P(^PSRX(PSOFFL,"OR1"),"^",2)=PSOPLC,^PSRX("APL",PSOPLC,PSOFFL)="" D:PSONAS EN^PSOHDR("PRES",PSOFFL) D KL Q - D KL - I SEND,$G(OR("STAT"))="Z@" G PURGE^PSOHLNE2 - I SEND,$G(OR("STAT"))="ZF" G REF^PSOHLNE2 - I SEND,$G(OR("STAT"))'="CA",$G(OR("STAT"))'="DC",$G(OR("STAT"))'="HD",$G(OR("STAT"))'="RL",$G(OR("STAT"))'="SS" S RCOMM="Invalid Order Control Code" D EN^ORERR(RCOMM,.MSG) Q - I SEND K SEND G:$G(OR("STAT"))="SS" ESTAT D EN^PSOORUTL(.OR) S PLACER=OR("PLACE"),STAT=OR("STAT"),COMM=OR("COMM") S PSOMSORR=1 D K PSOMSORR Q - .I $G(OR("FILLER"))="" D D ERROR^PSOHLSN Q - ..F EER=0:0 S EER=$O(MSG(EER)) Q:'EER S:$P(MSG(EER),"|")="PV1" PSERRPV1=MSG(EER) S:$P(MSG(EER),"|")="PID" PSERRPID=MSG(EER) S:$P(MSG(EER),"|")="ORC"&($G(PSERRORC)="") PSERRORC=MSG(EER) - .I $P(OR("FILLER"),"^",2)="R" S FILLER=$P(OR("FILLER"),"^") D EN^PSOHLSN1(FILLER,STAT,$G(OR("PHARMST")),COMM) K:$G(PSOEXFLG) PSOMSORR,PLACERXX D:$G(PSOEXFLG) EN^PSOHLSN1(FILLER,"SC","ZE","") D:$G(PSOSUSZ) SUS^PSOORUT1 K PSOSUSZ Q - .D EN^PSOHLSN(PLACER,STAT,COMM) Q - D KL^PSOHLSIH S RRX=1 F ZZ=0:0 S ZZ=$O(MSG(ZZ)) Q:'ZZ S PSOSEG=$G(MSG(ZZ)),PSOTYPE=$P(PSOSEG,"|") S PSOSEG=$E(PSOSEG,5,$L(PSOSEG)) I PSOTYPE'="NTE" D @PSOTYPE - I $G(PSRNFLAG) S PSOMO=0 D MISRN^PSOHLNE1 I $G(PSOMO) Q - S PSRNQFLG=0 I $G(PSRNFLAG),$G(PREV) D I $G(PSRNQFLG) S RCOMM="Duplicate Renewal Request. Order rejected by Pharmacy." D EN^ORERR(RCOMM,.MSG) D RERROR^PSOHLSN D KL^PSOHLSIH Q - .I $P($G(^PSRX(PREV,"OR1")),"^",4) S PSRNQFLG=1 Q - .I $O(^PS(52.41,"AQ",PREV,0)) S PSRNQFLG=1 - .I $G(XOFLAG),$G(DFN)'=$S($G(PFLAG):$P($G(^PS(52.41,+$G(PREV),0)),"^",2),1:$P($G(^PSRX(+$G(PREV),0)),"^",2)) S RCOMM="Patient mismatch on previous order." D EN^ORERR(RCOMM,.MSG) S XOFLAGZ=1 D RERROR^PSOHLSN D KL^PSOHLSIH Q - I $G(PLACER) I $G(DFN)'=+$P($G(^OR(100,+PLACER,0)),"^",2) G MISX^PSOHLNE1 - I $G(PLACER) D NFILE - D KL^PSOHLSIH - Q -ESTAT ; - D EXP^PSOHLNE1 - Q -MSH Q -PID S DFN=+$P(PSOSEG,"|",3) - Q -PV1 S LOCATION=+$P(+$P(PSOSEG,"|",3),"^") - S:'$D(^SC(LOCATION,0)) LOCATION="" - S INPTRX=0 I $G(LOCATION) S PSINPTR=$P($G(^SC(LOCATION,0)),"^",4) I PSINPTR Q - I $G(LOCATION) S INPTRX=$P($G(^SC(LOCATION,0)),"^",15) - I '$G(INPTRX) S INPTRX=$O(^DG(40.8,0)) - I '$G(DT) S DT=$$DT^XLFDT - S PSINPTR=+$$SITE^VASITE(DT,INPTRX) - Q -OBR ;This segment is used to pass flagging information from CPRS. - D OBR^PSOHLNE4 - Q -DG1 S $P(PSOICD($P(PSOSEG,"|",1)),"^")=$P($P(PSOSEG,"|",3),"^") - Q -ORC ; - Q:$P(PSOSEG,"|")="DE" - S:$P(PSOSEG,"|")="XO" XOFLAG=1 D ^PSOHLNE1 S:$G(PRIOR)="A" PRIOR="E" S:$G(PRIOR)="" PRIOR="R" - Q - ; -RXO I $O(MSG(ZZ,0)) D ^PSOHLNE2 G RXOPS - S PSORDITE=$P($P(PSOSEG,"|"),"^",4) - S PSODDRUG=$P($P(PSOSEG,"|",10),"^",4) I $G(PSODDRUG) S:'$D(^PSDRUG(PSODDRUG,0)) PSODDRUG="" - S PSOXQTY=$P(PSOSEG,"|",11) - S PSOREFIL=$P(PSOSEG,"|",13) - S PSODYSPL=$P(PSOSEG,"|",17) -RXOPS S ONEFLAG=0,WPCT=1,LL=ZZ+1 - I $P($G(MSG(LL)),"|")="NTE" D - .S ONEFLAG=1,WORDP=$S($P(MSG(LL),"|",2):$P(MSG(LL),"|",2),1:$P(MSG(LL),"|",3)) S:$P(MSG(LL),"|",4)'="" WPARRAY(WORDP,WPCT)=$P(MSG(LL),"|",4) S:$P(MSG(LL),"|",4)'="" WPCT=WPCT+1 F LLL=0:0 S LLL=$O(MSG(LL,LLL)) Q:'LLL D - ..I $G(MSG(LL,LLL))'="" S WPARRAY(WORDP,WPCT)=$G(MSG(LL,LLL)),WPCT=WPCT+1 - I ONEFLAG S LL=LL+1 I $P($G(MSG(LL)),"|")="NTE" D NTE^PSOHLNE1 - K WORDP - Q -RXR I $P($P(PSOSEG,"|"),"^",4) S ROUTE(RRX)=$P($P(PSOSEG,"|"),"^",4) S RRX=RRX+1 - Q -OBX I $O(MSG(ZZ,0)) D OBXX^PSOHLNE2 G OBXNTE - S OCOUNT=OCOUNT+1 - S OBXAR(OCOUNT,1)=$P(PSOSEG,"|",5) -OBXNTE ; - D OBXNTE^PSOHLNE3 - Q -ZRN S PSODSC=1_"^"_$P(PSOSEG,"|",2) - I $O(MSG(ZZ,0)) F T=0:0 S T=$O(MSG(ZZ,T)) Q:'T S PSODSC(T)=MSG(ZZ,T) - K T - Q - ; -ZRX D ZRX^PSOHLNE1 - Q - ; -ZCL D ZCL^PSOHLNE1 - Q -ZSC D CP^PSOHLNE1 - Q -NFILE ; - I $G(PSODSC) D ^PSONVNEW Q ;adds non-va med to #55 - ; - K DD,DO,DIC S DLAYGO="52.41",DIC="^PS(52.41,",DIC(0)="L",X=PLACER,DIC("DR")="1////"_DFN_";2////"_PSOOC_";6////"_$G(EFFECT)_";12////"_$G(PSOXQTY)_";25////"_$G(PRIOR) - S DIC("DR")=DIC("DR")_";22////"_$G(PSORSO)_";22.1////"_$G(PREV)_";19////"_$G(ROUTING)_";17////"_$$UNESC^ORHLESC($G(SERV))_";7////"_$G(NATURE)_";13////"_$G(PSOREFIL)_";1.1////"_$G(LOCATION)_";117////"_$G(DSIG) - D FILE^DICN K DIC,DR I Y<0 Q - S PENDING=+Y - S $P(^PS(52.41,PENDING,0),"^",4)=$S($G(ENTERED):+$G(ENTERED),1:""),$P(^(0),"^",5)=$S($G(PROV):+$G(PROV),1:""),$P(^(0),"^",8)=$S($G(PSORDITE):+$G(PSORDITE),1:""),$P(^(0),"^",9)=$S($G(PSODDRUG):+$G(PSODDRUG),1:""),$P(^(0),"^",15)=$G(ROUTE) - S ^PS(52.41,PENDING,"IBQ")=$G(PSOIBY) - I $G(PSODYSPL)'="",$E(PSODYSPL)?1A S PSODYSPL=$E(PSODYSPL,2,$L(PSODYSPL)) - S $P(^PS(52.41,PENDING,"INI"),"^")=$G(PSINPTR),$P(^(0),"^",12)=$G(PSOLOG),$P(^(0),"^",22)=$G(PSODYSPL) - I $G(QCOUNT) S ^PS(52.41,PENDING,1,0)="^52.413^"_QCOUNT_"^"_QCOUNT - S PSOQWX=$G(PSODDRUG) D:'$G(PSOQWX) OID^PSOHLNE1 - F PP=0:0 S PP=$O(Q1I(PP)) Q:'PP S VAL=$S($G(PSOQWX)&($G(PSOLQ1II(PP))):Q1I(PP),$G(PSOQWX)&($G(PSOLQ1IX(PP))'="")&('$G(PSOLQ1II(PP))):PSOLQ1IX(PP),1:PSOLQ1I(PP)) S ^PS(52.41,PENDING,1,PP,0)=$$UNESC^ORHLESC(VAL) - F EE=0:0 S EE=$O(QTARRAY(EE)) Q:'EE S ^PS(52.41,PENDING,1,EE,1)=$$UNESC^ORHLESC(QTARRAY(EE)) S VAL=$S($G(PSOQWX)&($G(PSOLQ1II(EE))):$G(QTARRAY2(EE)),$G(PSOQWX)&($G(PSOLQ1IX(EE))'="")&('$G(PSOLQ1II(EE))):PSOLQ1IX(EE),1:$G(PSOLQ1I(EE))) D - .S ^PS(52.41,PENDING,1,EE,2)=$$UNESC^ORHLESC(VAL) S $P(^PS(52.41,PENDING,1,EE,1),"^",8)=+$G(ROUTE(EE)) - S:$P($G(^PS(52.41,PENDING,1,1,1)),"^",3) $P(^PS(52.41,PENDING,0),"^",18)=$E($P($G(^PS(52.41,PENDING,1,1,1)),"^",3),1,7) - D STUFF^PSOHLNE2 - D ^PSOHLPII - S LL=0 I $O(WPARRAY(6,0)) F LLL=0:0 S LLL=$O(WPARRAY(6,LLL)) Q:'LLL S LL=LL+1 S ^PS(52.41,PENDING,3,LL,0)=$$UNESC^ORHLESC($G(WPARRAY(6,LLL))) - I LL S ^PS(52.41,PENDING,3,0)="^52.42^"_LL_"^"_LL - S LL=0 I $O(WPARRAY(7,0)) F LLL=0:0 S LLL=$O(WPARRAY(7,LLL)) Q:'LLL S LL=LL+1 S ^PS(52.41,PENDING,"INS1",LL,0)=$$UNESC^ORHLESC($G(WPARRAY(7,LLL))) - I LL S ^PS(52.41,PENDING,"INS1",0)="^^"_LL_"^"_LL_"^"_$G(DT)_"^" - I $P($G(^PS(50.7,+$G(PSORDITE),"INS")),"^")'="" S $P(^PS(52.41,PENDING,"INS"),"^",2)=$S($O(^PS(52.41,PENDING,"INS1",0)):1,1:0) - I $G(OCOUNT) S ^PS(52.41,PENDING,"OBX",0)="^52.4118A^"_OCOUNT_"^"_OCOUNT F OCOUNT=1:1:OCOUNT D - .S ^PS(52.41,PENDING,"OBX",OCOUNT,0)=$$UNESC^ORHLESC($G(OBXAR(OCOUNT,1))) - .D USER^PSOORFI2(+$G(PROV)) S ^PS(52.41,PENDING,"OBX",OCOUNT,1)=$$UNESC^ORHLESC(USER1) K USER1 - .S PSOBCT=1 F LLL=2:1 Q:'$D(OBXAR(OCOUNT,LLL)) S ^PS(52.41,PENDING,"OBX",OCOUNT,2,PSOBCT,0)=$$UNESC^ORHLESC(OBXAR(OCOUNT,LLL)),^PS(52.41,PENDING,"OBX",OCOUNT,2,0)="^^"_PSOBCT_"^"_PSOBCT_"^"_$G(DT)_"^" - D ^PSOHLPIS - K DIK S DIK="^PS(52.41,",DA=PENDING D IX^DIK - I $G(PSOOC)="RNW",$G(PREV),$D(^PSRX(+$G(PREV),0)) D EN^PSOHLSN1(PREV,"SC","ZZ","") - S PSOMSORR=1,IPPLACER=$P($G(^PS(52.41,PENDING,0)),"^") I IPPLACER D - .I '$G(XOFLAG) D EN^PSOHLSN(IPPLACER,"OK","IP") Q - .D EN^PSOHLSN(IPPLACER,"XR","IP") I $G(PFLAG) D DCP^PSOHLSN Q - .K PSOMSORR I $D(^PSRX(+$G(PREV),0)) D D EN^PSOHLSN1(PREV,"RP","","","A") - ..S $P(^PSRX(PREV,"STA"),"^")=15,$P(^PSRX(PREV,3),"^",5)=DT,$P(^PSRX(PREV,3),"^",10)=$P(^PSRX(PREV,3),"^") ;;PSO*7*249 - ..D REVERSE^PSOBPSU1(PREV,,"DC",7),CAN^PSOTPCAN(PREV),CAN^PSOUTL(PREV) - ..D CNT^PSOHLNE1 - ..D:$G(^PS(52.41,PENDING,1,1,0))=""&($P($G(^PS(52.41,PENDING,1,1,1)),"^")="")&($G(^PS(52.41,PENDING,"SIG",1,0))="") - ...N FSIG,BSIG - ...I '$P($G(^PSRX(PREV,"SIG")),"^",2),$P($G(^("SIG")),"^")'="" D - ....D EN3^PSOUTLA1(PREV,70) - ....I $G(BSIG(1))'="" S ^PS(52.41,PENDING,"SIG",1,0)=$$UNESC^ORHLESC($G(BSIG(1))) I $O(BSIG(1)) F EE=1:0 S EE=$O(BSIG(EE)) Q:'EE S ^PS(52.41,PENDING,"SIG",EE,0)=$$UNESC^ORHLESC($G(BSIG(EE))) - ...I $P($G(^PSRX(PREV,"SIG")),"^",2),$G(^PSRX(PREV,"SIG1",1,0))'="" D - ....D FSIG^PSOUTLA("R",PREV,70) - ....I $G(FSIG(1))'="" S ^PS(52.41,PENDING,"SIG",1,0)=$$UNESC^ORHLESC($G(FSIG(1))) I $O(FSIG(1)) F EE=1:0 S EE=$O(FSIG(EE)) Q:'EE S ^PS(52.41,PENDING,"SIG",EE,0)=$$UNESC^ORHLESC($G(FSIG(EE))) - ...F EE=0:0 S EE=$O(^PS(52.41,PENDING,"SIG",EE)) Q:'EE S ^PS(52.41,PENDING,"SIG",0)="^52.4124A^"_EE_"^"_EE - D CSET^PSODIAG - Q -SPDFN S PDFN=$P($G(MSG(OO)),"|",4) Q -KL K PSOPLC,PSOFFL,PSOSND - Q -FILL ; - S (PSOFILNM,OR("PSOFILNM"))=$P($P(MSG(OO),"|",4),"^") - Q +PSOHLNEW ;BIR/RTR - CPRS orders ; 11/30/06 11:49am + ;;7.0;OUTPATIENT PHARMACY;**1,7,15,46,71,98,111,124,117,131,146,132,143,223,235,148,239,249**;DEC 1997;Build 9 + ;40.8-728,50-221,SC-2675,100-2219,50.7-2223,EN^ORERR-2187 +EN(MSG) ; + N PSODDRUG,ENTERED,LOCATION,PLACER,PSOOC,ROUTE,NATURE,PREV,ROUTING,OO,OR,STAT,ZZ,DFN,COMM,QCOUNT,OCOUNT,Q1I,QTARRAY,QTARRAY2,EE,PP,XOFLAG,PSODYSPL,PSOFILNM + N ONEFLAG,SERV,WPCT,EFFECT,PROV,PENDING,RRX,PSOLQ1I,PSOLQ1II,PSOQWX,PSOLQ1IX,PSONVA,PSOICD,PSOSCP,EEE + N OBXAR,AA,II,SIG1,FILLER,COMM,GG,FF,JJ,JJJ,CT,LIM,VAR,VAR1,QQQ,PSRNFLAG,PSRNQFLG,RCOMM,XOFLAGZ,NWFLAG,PFLAG,PSINPTR,INPTRX,PSOIBN,PSOIBY + N DSIG,PSOCHFFL,PSOCVI,PSOMO,PSOXRP,NN,LL,LLL,WPARRAY,QTVAR,POVAR,POVAR1,ORCSEG,NNN,OOO,AAA,NNNN,POLIM,NNCK,PRIOR,IPPLACER,PLACERXX,EER,PSERRPID,PSERRPV1,PSERRORC,PSOEXFLG,PSOMSORR,PDFN + S (SEND,PSOSND,OCOUNT)=0 K PSOPLC,PSOFFL,PSORSO,PSOSUSZ + F OO=0:0 S OO=$O(MSG(OO)) Q:'OO!(SEND)!(PSOSND) D:$P(MSG(OO),"|")="PID" SPDFN I $P(MSG(OO),"|")="ORC",$P(MSG(OO),"|",2)'="NW",$P(MSG(OO),"|",2)'="XO" D + .S OR("STAT")=$P(MSG(OO),"|",2),OR("PLACE")=+$P(MSG(OO),"|",3),PLACERXX=+$P($P(MSG(OO),"|",3),";",2),OR("COMM")=$P(MSG(OO),"|",17),OR("USER")=$P(MSG(OO),"|",11) I $P(MSG(OO),"|",2)'="DE",$P(MSG(OO),"|",2)'="NA" S SEND=1 D FILL Q + .S PSOPLC=+$P(MSG(OO),"|",3),PSOFFL=+$P(MSG(OO),"|",4),PSOSND=1,PSOCHFFL=$P($P(MSG(OO),"|",4),"^") + I $G(OR("COMM"))["^" S OR("COMM")=$P(OR("COMM"),"^",5) + I PSOSND,$G(PSOCHFFL)["S",$G(OR("STAT"))="NA" D CHCS^PSOHLNE1 Q + I PSOSND,'$D(^PSRX(+$G(PSOFFL),0)) S COMM="Order was not located by Pharmacy" D EN^ORERR(COMM,.MSG) D KL Q + I PSOSND,$G(PDFN),PDFN'=+$P($G(^PSRX(+$G(PSOFFL),0)),"^",2) S COMM="Patient does not match" D EN^ORERR(COMM,.MSG) D KL Q + I PSOSND,$G(OR("STAT"))'="DE" N PSONAS S PSONAS=$S($P($G(^PSRX(PSOFFL,"OR1")),"^",2)="":1,1:0) S $P(^PSRX(PSOFFL,"OR1"),"^",2)=PSOPLC,^PSRX("APL",PSOPLC,PSOFFL)="" D:PSONAS EN^PSOHDR("PRES",PSOFFL) D KL Q + D KL + I SEND,$G(OR("STAT"))="Z@" G PURGE^PSOHLNE2 + I SEND,$G(OR("STAT"))="ZF" G REF^PSOHLNE2 + I SEND,$G(OR("STAT"))'="CA",$G(OR("STAT"))'="DC",$G(OR("STAT"))'="HD",$G(OR("STAT"))'="RL",$G(OR("STAT"))'="SS" S RCOMM="Invalid Order Control Code" D EN^ORERR(RCOMM,.MSG) Q + I SEND K SEND G:$G(OR("STAT"))="SS" ESTAT D EN^PSOORUTL(.OR) S PLACER=OR("PLACE"),STAT=OR("STAT"),COMM=OR("COMM") S PSOMSORR=1 D K PSOMSORR Q + .I $G(OR("FILLER"))="" D D ERROR^PSOHLSN Q + ..F EER=0:0 S EER=$O(MSG(EER)) Q:'EER S:$P(MSG(EER),"|")="PV1" PSERRPV1=MSG(EER) S:$P(MSG(EER),"|")="PID" PSERRPID=MSG(EER) S:$P(MSG(EER),"|")="ORC"&($G(PSERRORC)="") PSERRORC=MSG(EER) + .I $P(OR("FILLER"),"^",2)="R" S FILLER=$P(OR("FILLER"),"^") D EN^PSOHLSN1(FILLER,STAT,$G(OR("PHARMST")),COMM) K:$G(PSOEXFLG) PSOMSORR,PLACERXX D:$G(PSOEXFLG) EN^PSOHLSN1(FILLER,"SC","ZE","") D:$G(PSOSUSZ) SUS^PSOORUT1 K PSOSUSZ Q + .D EN^PSOHLSN(PLACER,STAT,COMM) Q + D KL^PSOHLSIH S RRX=1 F ZZ=0:0 S ZZ=$O(MSG(ZZ)) Q:'ZZ S PSOSEG=$G(MSG(ZZ)),PSOTYPE=$P(PSOSEG,"|") S PSOSEG=$E(PSOSEG,5,$L(PSOSEG)) I PSOTYPE'="NTE" D @PSOTYPE + I $G(PSRNFLAG) S PSOMO=0 D MISRN^PSOHLNE1 I $G(PSOMO) Q + S PSRNQFLG=0 I $G(PSRNFLAG),$G(PREV) D I $G(PSRNQFLG) S RCOMM="Duplicate Renewal Request. Order rejected by Pharmacy." D EN^ORERR(RCOMM,.MSG) D RERROR^PSOHLSN D KL^PSOHLSIH Q + .I $P($G(^PSRX(PREV,"OR1")),"^",4) S PSRNQFLG=1 Q + .I $O(^PS(52.41,"AQ",PREV,0)) S PSRNQFLG=1 + .I $G(XOFLAG),$G(DFN)'=$S($G(PFLAG):$P($G(^PS(52.41,+$G(PREV),0)),"^",2),1:$P($G(^PSRX(+$G(PREV),0)),"^",2)) S RCOMM="Patient mismatch on previous order." D EN^ORERR(RCOMM,.MSG) S XOFLAGZ=1 D RERROR^PSOHLSN D KL^PSOHLSIH Q + I $G(DFN)'=+$P($G(^OR(100,+$G(PLACER),0)),"^",2) G MISX^PSOHLNE1 + I $G(PLACER) D NFILE + D KL^PSOHLSIH + Q +ESTAT ; + D EXP^PSOHLNE1 + Q +MSH Q +PID S DFN=+$P(PSOSEG,"|",3) + Q +PV1 S LOCATION=+$P(+$P(PSOSEG,"|",3),"^") + S:'$D(^SC(LOCATION,0)) LOCATION="" + S INPTRX=0 I $G(LOCATION) S PSINPTR=$P($G(^SC(LOCATION,0)),"^",4) I PSINPTR Q + I $G(LOCATION) S INPTRX=$P($G(^SC(LOCATION,0)),"^",15) + I '$G(INPTRX) S INPTRX=$O(^DG(40.8,0)) + I '$G(DT) S DT=$$DT^XLFDT + S PSINPTR=+$$SITE^VASITE(DT,INPTRX) + Q +DG1 S $P(PSOICD($P(PSOSEG,"|",1)),"^")=$P($P(PSOSEG,"|",3),"^") + Q +ORC ; + Q:$P(PSOSEG,"|")="DE" + S:$P(PSOSEG,"|")="XO" XOFLAG=1 D ^PSOHLNE1 S:$G(PRIOR)="A" PRIOR="E" S:$G(PRIOR)="" PRIOR="R" + Q + ; +RXO I $O(MSG(ZZ,0)) D ^PSOHLNE2 G RXOPS + S PSORDITE=$P($P(PSOSEG,"|"),"^",4) + S PSODDRUG=$P($P(PSOSEG,"|",10),"^",4) I $G(PSODDRUG) S:'$D(^PSDRUG(PSODDRUG,0)) PSODDRUG="" + S PSOXQTY=$P(PSOSEG,"|",11) + S PSOREFIL=$P(PSOSEG,"|",13) + S PSODYSPL=$P(PSOSEG,"|",17) +RXOPS S ONEFLAG=0,WPCT=1,LL=ZZ+1 + I $P($G(MSG(LL)),"|")="NTE" D + .S ONEFLAG=1,WORDP=$S($P(MSG(LL),"|",2):$P(MSG(LL),"|",2),1:$P(MSG(LL),"|",3)) S:$P(MSG(LL),"|",4)'="" WPARRAY(WORDP,WPCT)=$P(MSG(LL),"|",4) S:$P(MSG(LL),"|",4)'="" WPCT=WPCT+1 F LLL=0:0 S LLL=$O(MSG(LL,LLL)) Q:'LLL D + ..I $G(MSG(LL,LLL))'="" S WPARRAY(WORDP,WPCT)=$G(MSG(LL,LLL)),WPCT=WPCT+1 + I ONEFLAG S LL=LL+1 I $P($G(MSG(LL)),"|")="NTE" D NTE^PSOHLNE1 + K WORDP + Q +RXR I $P($P(PSOSEG,"|"),"^",4) S ROUTE(RRX)=$P($P(PSOSEG,"|"),"^",4) S RRX=RRX+1 + Q +OBX I $O(MSG(ZZ,0)) D OBXX^PSOHLNE2 G OBXNTE + S OCOUNT=OCOUNT+1 + S OBXAR(OCOUNT,1)=$P(PSOSEG,"|",5) +OBXNTE ; + S LL=ZZ+1,PSOBCT=2 + I $P($G(MSG(LL)),"|")="NTE" D + .I $P(MSG(LL),"|",4)'="" S PSOBCT=3,OBXAR(OCOUNT,2)=$P(MSG(LL),"|",4) + .F LLL=0:0 S LLL=$O(MSG(LL,LLL)) Q:'LLL D + ..I $P($G(MSG(LL,LLL)),"|",4)'="" S OBXAR(OCOUNT,PSOBCT)=$P(MSG(LL,LLL),"|",4),PSOBCT=PSOBCT+1 + Q +ZRN S PSODSC=1_"^"_$P(PSOSEG,"|",2) + I $O(MSG(ZZ,0)) F T=0:0 S T=$O(MSG(ZZ,T)) Q:'T S PSODSC(T)=MSG(ZZ,T) + K T + Q + ; +ZRX D ZRX^PSOHLNE1 + Q + ; +ZCL D ZCL^PSOHLNE1 + Q +ZSC D CP^PSOHLNE1 + Q +NFILE ; + I $G(PSODSC) D ^PSONVNEW Q ;adds non-va med to #55 + ; + K DD,DO,DIC S DLAYGO="52.41",DIC="^PS(52.41,",DIC(0)="L",X=PLACER,DIC("DR")="1////"_DFN_";2////"_PSOOC_";6////"_$G(EFFECT)_";12////"_$G(PSOXQTY)_";25////"_$G(PRIOR) + S DIC("DR")=DIC("DR")_";22////"_$G(PSORSO)_";22.1////"_$G(PREV)_";19////"_$G(ROUTING)_";17////"_$G(SERV)_";7////"_$G(NATURE)_";13////"_$G(PSOREFIL)_";1.1////"_$G(LOCATION)_";117////"_$G(DSIG) + D FILE^DICN K DIC,DR I Y<0 Q + S PENDING=+Y + S $P(^PS(52.41,PENDING,0),"^",4)=$S($G(ENTERED):+$G(ENTERED),1:""),$P(^(0),"^",5)=$S($G(PROV):+$G(PROV),1:""),$P(^(0),"^",8)=$S($G(PSORDITE):+$G(PSORDITE),1:""),$P(^(0),"^",9)=$S($G(PSODDRUG):+$G(PSODDRUG),1:""),$P(^(0),"^",15)=$G(ROUTE) + S ^PS(52.41,PENDING,"IBQ")=$G(PSOIBY) + I $G(PSODYSPL)'="",$E(PSODYSPL)?1A S PSODYSPL=$E(PSODYSPL,2,$L(PSODYSPL)) + S $P(^PS(52.41,PENDING,"INI"),"^")=$G(PSINPTR),$P(^(0),"^",12)=$G(PSOLOG),$P(^(0),"^",22)=$G(PSODYSPL) + I $G(QCOUNT) S ^PS(52.41,PENDING,1,0)="^52.413^"_QCOUNT_"^"_QCOUNT + S PSOQWX=$G(PSODDRUG) D:'$G(PSOQWX) OID^PSOHLNE1 + F PP=0:0 S PP=$O(Q1I(PP)) Q:'PP S ^PS(52.41,PENDING,1,PP,0)=$S($G(PSOQWX)&($G(PSOLQ1II(PP))):Q1I(PP),$G(PSOQWX)&($G(PSOLQ1IX(PP))'="")&('$G(PSOLQ1II(PP))):PSOLQ1IX(PP),1:PSOLQ1I(PP)) + F EE=0:0 S EE=$O(QTARRAY(EE)) Q:'EE S ^PS(52.41,PENDING,1,EE,1)=QTARRAY(EE),^PS(52.41,PENDING,1,EE,2)=$S($G(PSOQWX)&($G(PSOLQ1II(EE))):$G(QTARRAY2(EE)),$G(PSOQWX)&($G(PSOLQ1IX(EE))'="")&('$G(PSOLQ1II(EE))):PSOLQ1IX(EE),1:$G(PSOLQ1I(EE))) D + .S $P(^PS(52.41,PENDING,1,EE,1),"^",8)=+$G(ROUTE(EE)) + S:$P($G(^PS(52.41,PENDING,1,1,1)),"^",3) $P(^PS(52.41,PENDING,0),"^",18)=$E($P($G(^PS(52.41,PENDING,1,1,1)),"^",3),1,7) + D STUFF^PSOHLNE2 + D ^PSOHLPII + S LL=0 I $O(WPARRAY(6,0)) F LLL=0:0 S LLL=$O(WPARRAY(6,LLL)) Q:'LLL S LL=LL+1 S ^PS(52.41,PENDING,3,LL,0)=$G(WPARRAY(6,LLL)) + I LL S ^PS(52.41,PENDING,3,0)="^52.42^"_LL_"^"_LL + S LL=0 I $O(WPARRAY(7,0)) F LLL=0:0 S LLL=$O(WPARRAY(7,LLL)) Q:'LLL S LL=LL+1 S ^PS(52.41,PENDING,"INS1",LL,0)=$G(WPARRAY(7,LLL)) + I LL S ^PS(52.41,PENDING,"INS1",0)="^^"_LL_"^"_LL_"^"_$G(DT)_"^" + I $P($G(^PS(50.7,+$G(PSORDITE),"INS")),"^")'="" S $P(^PS(52.41,PENDING,"INS"),"^",2)=$S($O(^PS(52.41,PENDING,"INS1",0)):1,1:0) + I $G(OCOUNT) S ^PS(52.41,PENDING,"OBX",0)="^52.4118A^"_OCOUNT_"^"_OCOUNT F OCOUNT=1:1:OCOUNT D + .S ^PS(52.41,PENDING,"OBX",OCOUNT,0)=$G(OBXAR(OCOUNT,1)) + .D USER^PSOORFI2(+$G(PROV)) S ^PS(52.41,PENDING,"OBX",OCOUNT,1)=USER1 K USER1 + .S PSOBCT=1 F LLL=2:1 Q:'$D(OBXAR(OCOUNT,LLL)) S ^PS(52.41,PENDING,"OBX",OCOUNT,2,PSOBCT,0)=OBXAR(OCOUNT,LLL),^PS(52.41,PENDING,"OBX",OCOUNT,2,0)="^^"_PSOBCT_"^"_PSOBCT_"^"_$G(DT)_"^" + D ^PSOHLPIS + K DIK S DIK="^PS(52.41,",DA=PENDING D IX^DIK + I $G(PSOOC)="RNW",$G(PREV),$D(^PSRX(+$G(PREV),0)) D EN^PSOHLSN1(PREV,"SC","ZZ","") + S PSOMSORR=1,IPPLACER=$P($G(^PS(52.41,PENDING,0)),"^") I IPPLACER D + .I '$G(XOFLAG) D EN^PSOHLSN(IPPLACER,"OK","IP") Q + .D EN^PSOHLSN(IPPLACER,"XR","IP") I $G(PFLAG) D DCP^PSOHLSN Q + .K PSOMSORR I $D(^PSRX(+$G(PREV),0)) D D EN^PSOHLSN1(PREV,"RP","","","A") + ..S $P(^PSRX(PREV,"STA"),"^")=15,$P(^PSRX(PREV,3),"^",5)=DT,$P(^PSRX(PREV,3),"^",10)=$P(^PSRX(PREV,3),"^") ;;PSO*7*249 + ..D REVERSE^PSOBPSU1(PREV,,"DC",7),CAN^PSOTPCAN(PREV),CAN^PSOUTL(PREV) + ..D CNT^PSOHLNE1 + ..D:$G(^PS(52.41,PENDING,1,1,0))=""&($P($G(^PS(52.41,PENDING,1,1,1)),"^")="")&($G(^PS(52.41,PENDING,"SIG",1,0))="") + ...N FSIG,BSIG + ...I '$P($G(^PSRX(PREV,"SIG")),"^",2),$P($G(^("SIG")),"^")'="" D + ....D EN3^PSOUTLA1(PREV,70) + ....I $G(BSIG(1))'="" S ^PS(52.41,PENDING,"SIG",1,0)=$G(BSIG(1)) I $O(BSIG(1)) F EE=1:0 S EE=$O(BSIG(EE)) Q:'EE S ^PS(52.41,PENDING,"SIG",EE,0)=$G(BSIG(EE)) + ...I $P($G(^PSRX(PREV,"SIG")),"^",2),$G(^PSRX(PREV,"SIG1",1,0))'="" D + ....D FSIG^PSOUTLA("R",PREV,70) + ....I $G(FSIG(1))'="" S ^PS(52.41,PENDING,"SIG",1,0)=$G(FSIG(1)) I $O(FSIG(1)) F EE=1:0 S EE=$O(FSIG(EE)) Q:'EE S ^PS(52.41,PENDING,"SIG",EE,0)=$G(FSIG(EE)) + ...F EE=0:0 S EE=$O(^PS(52.41,PENDING,"SIG",EE)) Q:'EE S ^PS(52.41,PENDING,"SIG",0)="^52.4124A^"_EE_"^"_EE + D CSET^PSODIAG + Q +SPDFN S PDFN=$P($G(MSG(OO)),"|",4) Q +KL K PSOPLC,PSOFFL,PSOSND + Q +FILL ; + S (PSOFILNM,OR("PSOFILNM"))=$P($P(MSG(OO),"|",4),"^") + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLPII.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLPII.m index aab194ab..0ac348cb 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLPII.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLPII.m @@ -1,134 +1,134 @@ -PSOHLPII ;BIR/RTR-Parse out and create CPRS Instructions ;7/21/96 - ;;7.0;OUTPATIENT PHARMACY;**46,225**;DEC 1997;Build 29 - ;External reference to File #50.7 supported by DBIA 2223 - ;External reference to File #51 supported by DBIA 2224 - ;External reference to File #51.1 supported by DBIA 2225 - ;External reference to File #51.2 supported by DBIA 2226 - ;External reference to File #50.606 supported by DBIA 2174 -EN ; - Q:'$D(^PS(52.41,PENDING,1,0)) - N PISI,PSOFX,SDF,SZZ,ZZS,ZZSB,SSZZ,SCHHOLD,GGGZ,SGLFLAG,SGLOOP,ZSCHED,SPFG,PSNOUN,MEDEXP,PSDUR,NOUN,SCHED,INTERVAL,SIG0,SIG2,SIG3,SDL,WW,TODOSE,PDAYS,WWFL,PSOCJI - N SSS,TT,DCOUNT,PREP,VERB,FFF,GGG,SIGDS,SIGRT,PSOROUTE,PSOSG1,PSOSG2 - N SIG - F PISI=0:0 S PISI=$O(^PS(52.41,PENDING,1,PISI)) Q:'PISI D:$D(^(PISI,0)) - .S PSOFX("DOSE",PISI)=$P($G(^PS(52.41,PENDING,1,PISI,2)),"^") I $P($G(^(2)),"^",2)'="" S PSOFX("DOSE ORDERED",PISI)=$P($G(^(2)),"^",2) - .S PSOFX("SCHEDULE",PISI)=$P($G(^PS(52.41,PENDING,1,PISI,1)),"^"),PSOFX("ROUTE",PISI)=$P($G(^(1)),"^",8),PSOFX("DURATION",PISI)=$P($G(^(1)),"^",2),PSOFX("NOUN",PISI)=$P($G(^(1)),"^",5),PSOFX("CONJUNCTION",PISI)=$P($G(^(1)),"^",6) - .I $G(PSOFX("DURATION",PISI)) S PSOFX("DURATION",PISI)="D"_$G(PSOFX("DURATION",PISI)) - .I $G(PSOFX("DURATION",PISI))'="" S PSOFX("DURATION",PISI)=$E(PSOFX("DURATION",PISI),2,999)_$E(PSOFX("DURATION",PISI)) - S TODOSE=0 F WW=0:0 S WW=$O(PSOFX("DOSE",WW)) Q:'WW S TODOSE=WW - Q:'TODOSE - S SIGDS=+$P($G(^PS(50.7,+$G(PSORDITE),0)),"^",2),VERB=$P($G(^PS(50.606,SIGDS,"MISC")),"^"),PREP=$P($G(^("MISC")),"^",3) - F SSS=1:1:TODOSE D - .S SIG0(SSS)=$S($G(PSOFX("DOSE ORDERED",SSS))'="":$G(PSOFX("DOSE ORDERED",SSS)),1:$G(PSOFX("DOSE",SSS))) - .S PSNOUN(SSS)=$G(PSOFX("NOUN",SSS)) - .;S PSOROUTE(SSS)=$S($P($G(^PS(51.2,+$G(PSOFX("ROUTE",SSS)),0)),"^",2)'="":$P(^(0),"^",2),$P($G(^(0)),"^",3)'="":$P(^(0),"^",3),1:$P($G(^(0)),"^")) S MEDEXP(SSS)=$S($P($G(^PS(51.2,+$G(PSOFX("ROUTE",SSS)),0)),"^",2)="":0,1:1) - .S PSOROUTE(SSS)=$S($P($G(^PS(51.2,+$G(PSOFX("ROUTE",SSS)),0)),"^",3)'="":$P($G(^(0)),"^",3),1:$P($G(^(0)),"^")) - .S PDAYS(SSS)=$G(PSOFX("DURATION",SSS)) - .I $G(PSOFX("DURATION",SSS))'="",($E(PSOFX("DURATION",SSS),$L(PSOFX("DURATION",SSS)))'?1A) S PDAYS(SSS)=PDAYS(SSS)_"D" - .S PSDUR(SSS)=$S($G(PDAYS(SSS))="":"NULL",1:"FOR "_$E($G(PDAYS(SSS)),1,($L($G(PDAYS(SSS)))-1))) D I PSDUR(SSS)'="NULL" S PSDUR(SSS)=PSDUR(SSS)_" "_INTERVAL - ..I PSDUR(SSS)'="NULL" S INTERVAL=$E(PDAYS(SSS),$L(PDAYS(SSS))),INTERVAL=$S(INTERVAL="D":"DAYS",INTERVAL="W":"WEEKS",INTERVAL="H":"HOURS",INTERVAL="L":"MONTHS",INTERVAL="M":"MINUTES",INTERVAL="S":"SECONDS",1:"") D - ...I $G(INTERVAL)'="",$G(PSOFX("DURATION",SSS)),$G(PSOFX("DURATION",SSS))'>1 S INTERVAL=$E(INTERVAL,1,($L(INTERVAL)-1)) - F GGG=1:1:TODOSE S ZSCHED(GGG)=$G(PSOFX("SCHEDULE",GGG)) - ;.I $G(ZSCHED(GGG))="" S SCHED(GGG)="" Q - ;.S SGLFLAG=0 F WW=0:0 S WW=$O(^PS(51.1,"B",ZSCHED(GGG),WW)) Q:'WW!($G(SGLFLAG)) I $P($G(^PS(51.1,WW,0)),"^",8)'="" S SCHED(GGG)=$P($G(^(0)),"^",8),SGLFLAG=1 - ;.Q:$G(SGLFLAG) - ;.I $G(^PS(51,"A",ZSCHED(GGG)))'="" S SCHED(GGG)=$P(^(ZSCHED(GGG)),"^") Q - ;.S ZZSB=0 F ZZS=1:1:$L(ZSCHED(GGG)) S SZZ=$E(ZSCHED(GGG),ZZS) I SZZ=" " S ZZSB=ZZSB+1 - ;.S ZZSB=ZZSB+1 - ;.K SCHHOLD F GGGZ=1:1:ZZSB S (SDL,SCHHOLD(GGGZ))=$P(ZSCHED(GGG)," ",GGGZ) D - ;..Q:$G(SDL)="" - ;..S SGLFLAG=0 F WW=0:0 S WW=$O(^PS(51.1,"B",SDL,WW)) Q:'WW!($G(SGLFLAG)) I $P($G(^PS(51.1,WW,0)),"^",8)'="" S SCHHOLD(GGGZ)=$P($G(^(0)),"^",8),SGLFLAG=1 - ;..Q:$G(SGLFLAG) - ;..I $G(^PS(51,"A",SDL))'="" S SCHHOLD(GGGZ)=$P(^(SDL),"^") - ;.S SCHED(GGG)="",SGLFLAG=0 F WW=1:1:ZZSB S SCHED(GGG)=SCHED(GGG)_$S($G(SGLFLAG):" ",1:"")_$G(SCHHOLD(WW)),SGLFLAG=1 - S PREP="" - F FFF=0:0 S FFF=$O(SIG0(FFF)) Q:'FFF D - .K PSOSG1,PSOSG2 D VERB D:$G(PSNOUN(FFF))'=""&('$G(PSOSG1)) SSS - .D FRAC - .S SIG2(FFF)=$S(VERB'=""&('$G(PSOSG1)):VERB_" ",1:"")_$S($G(PSOFX("DOSE ORDERED",FFF))'="":$S($G(PSOFRAC)'="":$G(PSOFRAC),1:$G(PSOFX("DOSE ORDERED",FFF)))_" ",1:$G(PSOFX("DOSE",FFF))_" ") - .K PSOFRAC,PSOFRACX - .S SIG2(FFF)=SIG2(FFF)_$S($G(PSNOUN(FFF))'=""&('$G(PSOSG2)):$G(PSNOUN(FFF))_" ",1:"")_$S(PREP'=""&($G(MEDEXP(FFF))):PREP_" ",1:"") - .S SIG2(FFF)=SIG2(FFF)_$S(PSOROUTE(FFF)'="":PSOROUTE(FFF)_" ",1:"") - .;S SIG2(FFF)=SIG2(FFF)_$S(SCHED(FFF)'="":SCHED(FFF)_" ",1:"")_$S(PSDUR(FFF)'="NULL":PSDUR(FFF)_" ",1:"")_$S($G(PSOFX("CONJUNCTION",FFF))="A":"AND",$G(PSOFX("CONJUNCTION",FFF))="T":"THEN",$G(PSOFX("CONJUNCTION",FFF))="S":"THEN",1:"") - .S SIG2(FFF)=SIG2(FFF)_$S(ZSCHED(FFF)'="":ZSCHED(FFF)_$S($G(PSDUR(FFF))="NULL"&($G(PSOFX("CONJUNCTION",FFF))="")&('$O(SIG0(FFF))):"",1:" "),1:"") - .S PSOCJI=$G(PSOFX("CONJUNCTION",FFF)) - .S SIG2(FFF)=SIG2(FFF)_$S(PSDUR(FFF)'="NULL":PSDUR(FFF)_$S($G(PSOFX("CONJUNCTION",FFF))=""&('$O(SIG0(FFF))):"",1:", "),1:"")_$S($G(PSOCJI)="A":"AND",$G(PSOCJI)="T":"THEN",$G(PSOCJI)="S":"THEN",$G(PSOCJI)="X":"EXCEPT",1:"") - .K PSOSG1,PSOSG2 - .K PSOUCS S SIG2(FFF)=$$UPPER(SIG2(FFF)) K PSOUCS - ;I $G(PSOFX("INS"))'="" S TODOSE=TODOSE+1,SIG2(TODOSE)=$G(PSOFX("INS")) -STUFF ; - S DCOUNT=0 - I '$D(SIG2(1)) G QUIT - ;I '$O(SIG2(1)),$L(SIG2(1))<71 S ^PS(52.41,PENDING,"SIG",0)="^52.4124A^"_1_"^"_1 S ^PS(52.41,PENDING,"SIG",1,0)=SIG2(1) G QUIT - S (VAR,VAR1)="",II=1 - F FF=0:0 S FF=$O(SIG2(FF)) Q:'FF S CT=0 F NN=1:1:$L(SIG2(FF)) I $E(SIG2(FF),NN)=" "!($L(SIG2(FF))=NN) S CT=CT+1 D I $L(VAR)>200 S SIG(II)=LIM_" ",II=II+1,VAR=VAR1 - .S VAR1=$P(SIG2(FF)," ",(CT)) - .S LIM=VAR - .S VAR=$S(VAR="":VAR1,1:VAR_" "_VAR1) - I $G(VAR)'="" S SIG(II)=VAR - F II=0:0 S II=$O(SIG(II)) Q:'II S DCOUNT=DCOUNT+1 S ^PS(52.41,PENDING,2,DCOUNT,0)=$$UNESC^ORHLESC(SIG(II)) - I DCOUNT S ^PS(52.41,PENDING,2,0)="^52.419A^"_DCOUNT_"^"_DCOUNT -QUIT K SSS,TT,DCOUNT,PREP,VERB,FFF,GGG,SIGDS,SIGRT,PSOROUTE,PSOSG1,PSOSG2 Q -SIG1 ; - F FFF=0:0 S FFF=$O(SIG0(FFF)) Q:'FFF S SIG2(FFF)=SIG0(FFF) - Q -DAYS I +$E($P(SIG1(TT),"^",2))!($E($P(SIG1(TT),"^",2))=0) S $P(SIG1(TT),"^",2)="D"_$P(SIG1(TT),"^",2) - Q -NON ; - I $P($G(SIG0(SSS)),"&",2)'="" S PSNOUN(SSS)=$P($G(SIG0(SSS)),"&",2) Q - Q - F NOUN=0:0 S NOUN=$O(^PS(50.606,SIGDS,"NOUN",NOUN)) Q:'NOUN!($G(PSNOUN(SSS))'="") I $P($G(^PS(50.606,SIGDS,"NOUN",NOUN,0)),"^")'="" S PSNOUN(SSS)=$P(^(0),"^") - Q -VERB ;Check if verb and noun need to be added to SIG - K PSOLCS,PSOUCS,PSOISL,PSOVL - I $G(VERB)'="" S PSOVL=$L(VERB),PSOISL=$E($G(SIG0(FFF)),1,$G(PSOVL)) I $G(PSOISL)'="" D - .S PSOUCS=VERB - .S PSOUCS=$$UPPER(PSOUCS) I PSOUCS=PSOISL S PSOSG1=1 Q - .S PSOUCS=$$LOWER(PSOUCS) I PSOUCS=PSOISL S PSOSG1=1 Q - .S PSOUCS=$$UPPER($E(PSOUCS,1))_$$LOWER($E(PSOUCS,2,99)) I PSOUCS=PSOISL S PSOSG1=1 Q - I $G(PSNOUN(FFF))="" G VERBEX - S PSOISL=$G(SIG0(FFF)) I $G(PSOISL)="" G VERBEX - S PSOVL=$F(PSNOUN(FFF),"(") - I $G(PSOVL)>2 S PSOUCS=$E(PSNOUN(FFF),1,(PSOVL-2)) - I $G(PSOVL)'>2 S PSOUCS=PSNOUN(FFF) - I $G(PSOISL)'="" D - .S PSOUCS=$$UPPER(PSOUCS) I PSOISL[PSOUCS S PSOSG2=1 Q - .S PSOUCS=$$LOWER(PSOUCS) I PSOISL[PSOUCS S PSOSG2=1 Q - .S PSOUCS=$$UPPER($E(PSOUCS,1))_$$LOWER($E(PSOUCS,2,99)) I PSOISL[PSOUCS S PSOSG2=1 -VERBEX K PSOLCS,PSOUCS,PSOISL,PSOVL Q - ; -UPPER(PSOUCS) ; - Q $TR(PSOUCS,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") - ; -LOWER(PSOLCS) ; - Q $TR(PSOLCS,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz") - Q - ; -SSS ; - K PSOFNL,PSOFNLF,PSOFNLX - Q:$G(PSNOUN(FFF))="" - Q:$L(PSNOUN(FFF))'>3 - Q:'$G(PSOFX("DOSE ORDERED",FFF)) - ;Q:$G(PSOFX("DOSE ORDERED",FFF))>1 - S PSOFNL=$E(PSNOUN(FFF),($L(PSNOUN(FFF))-2),$L(PSNOUN(FFF))) - I $G(PSOFNL)="(S)"!($G(PSOFNL)="(s)") D - .I $G(PSOFX("DOSE ORDERED",FFF))'>1 S PSNOUN(FFF)=$E(PSNOUN(FFF),1,($L(PSNOUN(FFF))-3)) - .I $G(PSOFX("DOSE ORDERED",FFF))>1 S PSNOUN(FFF)=$E(PSNOUN(FFF),1,($L(PSNOUN(FFF))-3))_$E(PSOFNL,2) - Q -FRAC ; - K PSOFRAC,PSOFRACX,PSOFRAC1,PSOFRAC2 - I $G(PSOFX("DOSE ORDERED",FFF))="" Q - I $G(PSOFX("DOSE ORDERED",FFF))'["." S (PSOFRAC1,PSOFRAC)=$G(PSOFX("DOSE ORDERED",FFF)) D NUM D G FRACQ - .I $G(PSOFRAC1)=$G(PSOFRAC) K PSOFRAC,PSOFRAC1 Q - .S PSOFRAC=$G(PSOFRAC1) - S PSOFRAC1=$P(PSOFX("DOSE ORDERED",FFF),"."),PSOFRAC2=$P(PSOFX("DOSE ORDERED",FFF),".",2) - S PSOFRACX="."_$G(PSOFRAC2) - S PSOFRAC=$S(PSOFRACX=".5":"ONE-HALF",PSOFRACX=".25":"ONE-FOURTH",PSOFRACX=".33":"ONE-THIRD",PSOFRACX=".34":"ONE-THIRD",PSOFRACX=".50":"ONE-HALF",PSOFRACX=".66":"TWO-THIRDS",PSOFRACX=".67":"TWO-THIRDS",PSOFRACX=".75":"THREE-FOURTHS",1:"") - I $G(PSOFRAC)="" K PSOFRAC G FRACQ - I $G(PSOFRAC1)'="",+$G(PSOFRAC1) D NUM S PSOFRAC=$G(PSOFRAC1)_" AND "_$G(PSOFRAC) -FRACQ K PSOFRAC1,PSOFRAC2 - Q -NUM ; - Q:$G(PSOFRAC1)="" - S PSOFRAC1=$S(PSOFRAC1="1":"ONE",PSOFRAC1="2":"TWO",PSOFRAC1="3":"THREE",PSOFRAC1="4":"FOUR",PSOFRAC1="5":"FIVE",PSOFRAC1="6":"SIX",PSOFRAC1="7":"SEVEN",PSOFRAC1="8":"EIGHT",PSOFRAC1="9":"NINE",PSOFRAC1="10":"TEN",1:PSOFRAC1) - Q +PSOHLPII ;BIR/RTR-Parse out and create CPRS Instructions ;7/21/96 + ;;7.0;OUTPATIENT PHARMACY;**46**;DEC 1997 + ;External reference to File #50.7 supported by DBIA 2223 + ;External reference to File #51 supported by DBIA 2224 + ;External reference to File #51.1 supported by DBIA 2225 + ;External reference to File #51.2 supported by DBIA 2226 + ;External reference to File #50.606 supported by DBIA 2174 +EN ; + Q:'$D(^PS(52.41,PENDING,1,0)) + N PISI,PSOFX,SDF,SZZ,ZZS,ZZSB,SSZZ,SCHHOLD,GGGZ,SGLFLAG,SGLOOP,ZSCHED,SPFG,PSNOUN,MEDEXP,PSDUR,NOUN,SCHED,INTERVAL,SIG0,SIG2,SIG3,SDL,WW,TODOSE,PDAYS,WWFL,PSOCJI + N SSS,TT,DCOUNT,PREP,VERB,FFF,GGG,SIGDS,SIGRT,PSOROUTE,PSOSG1,PSOSG2 + N SIG + F PISI=0:0 S PISI=$O(^PS(52.41,PENDING,1,PISI)) Q:'PISI D:$D(^(PISI,0)) + .S PSOFX("DOSE",PISI)=$P($G(^PS(52.41,PENDING,1,PISI,2)),"^") I $P($G(^(2)),"^",2)'="" S PSOFX("DOSE ORDERED",PISI)=$P($G(^(2)),"^",2) + .S PSOFX("SCHEDULE",PISI)=$P($G(^PS(52.41,PENDING,1,PISI,1)),"^"),PSOFX("ROUTE",PISI)=$P($G(^(1)),"^",8),PSOFX("DURATION",PISI)=$P($G(^(1)),"^",2),PSOFX("NOUN",PISI)=$P($G(^(1)),"^",5),PSOFX("CONJUNCTION",PISI)=$P($G(^(1)),"^",6) + .I $G(PSOFX("DURATION",PISI)) S PSOFX("DURATION",PISI)="D"_$G(PSOFX("DURATION",PISI)) + .I $G(PSOFX("DURATION",PISI))'="" S PSOFX("DURATION",PISI)=$E(PSOFX("DURATION",PISI),2,999)_$E(PSOFX("DURATION",PISI)) + S TODOSE=0 F WW=0:0 S WW=$O(PSOFX("DOSE",WW)) Q:'WW S TODOSE=WW + Q:'TODOSE + S SIGDS=+$P($G(^PS(50.7,+$G(PSORDITE),0)),"^",2),VERB=$P($G(^PS(50.606,SIGDS,"MISC")),"^"),PREP=$P($G(^("MISC")),"^",3) + F SSS=1:1:TODOSE D + .S SIG0(SSS)=$S($G(PSOFX("DOSE ORDERED",SSS))'="":$G(PSOFX("DOSE ORDERED",SSS)),1:$G(PSOFX("DOSE",SSS))) + .S PSNOUN(SSS)=$G(PSOFX("NOUN",SSS)) + .;S PSOROUTE(SSS)=$S($P($G(^PS(51.2,+$G(PSOFX("ROUTE",SSS)),0)),"^",2)'="":$P(^(0),"^",2),$P($G(^(0)),"^",3)'="":$P(^(0),"^",3),1:$P($G(^(0)),"^")) S MEDEXP(SSS)=$S($P($G(^PS(51.2,+$G(PSOFX("ROUTE",SSS)),0)),"^",2)="":0,1:1) + .S PSOROUTE(SSS)=$S($P($G(^PS(51.2,+$G(PSOFX("ROUTE",SSS)),0)),"^",3)'="":$P($G(^(0)),"^",3),1:$P($G(^(0)),"^")) + .S PDAYS(SSS)=$G(PSOFX("DURATION",SSS)) + .I $G(PSOFX("DURATION",SSS))'="",($E(PSOFX("DURATION",SSS),$L(PSOFX("DURATION",SSS)))'?1A) S PDAYS(SSS)=PDAYS(SSS)_"D" + .S PSDUR(SSS)=$S($G(PDAYS(SSS))="":"NULL",1:"FOR "_$E($G(PDAYS(SSS)),1,($L($G(PDAYS(SSS)))-1))) D I PSDUR(SSS)'="NULL" S PSDUR(SSS)=PSDUR(SSS)_" "_INTERVAL + ..I PSDUR(SSS)'="NULL" S INTERVAL=$E(PDAYS(SSS),$L(PDAYS(SSS))),INTERVAL=$S(INTERVAL="D":"DAYS",INTERVAL="W":"WEEKS",INTERVAL="H":"HOURS",INTERVAL="L":"MONTHS",INTERVAL="M":"MINUTES",INTERVAL="S":"SECONDS",1:"") D + ...I $G(INTERVAL)'="",$G(PSOFX("DURATION",SSS)),$G(PSOFX("DURATION",SSS))'>1 S INTERVAL=$E(INTERVAL,1,($L(INTERVAL)-1)) + F GGG=1:1:TODOSE S ZSCHED(GGG)=$G(PSOFX("SCHEDULE",GGG)) + ;.I $G(ZSCHED(GGG))="" S SCHED(GGG)="" Q + ;.S SGLFLAG=0 F WW=0:0 S WW=$O(^PS(51.1,"B",ZSCHED(GGG),WW)) Q:'WW!($G(SGLFLAG)) I $P($G(^PS(51.1,WW,0)),"^",8)'="" S SCHED(GGG)=$P($G(^(0)),"^",8),SGLFLAG=1 + ;.Q:$G(SGLFLAG) + ;.I $G(^PS(51,"A",ZSCHED(GGG)))'="" S SCHED(GGG)=$P(^(ZSCHED(GGG)),"^") Q + ;.S ZZSB=0 F ZZS=1:1:$L(ZSCHED(GGG)) S SZZ=$E(ZSCHED(GGG),ZZS) I SZZ=" " S ZZSB=ZZSB+1 + ;.S ZZSB=ZZSB+1 + ;.K SCHHOLD F GGGZ=1:1:ZZSB S (SDL,SCHHOLD(GGGZ))=$P(ZSCHED(GGG)," ",GGGZ) D + ;..Q:$G(SDL)="" + ;..S SGLFLAG=0 F WW=0:0 S WW=$O(^PS(51.1,"B",SDL,WW)) Q:'WW!($G(SGLFLAG)) I $P($G(^PS(51.1,WW,0)),"^",8)'="" S SCHHOLD(GGGZ)=$P($G(^(0)),"^",8),SGLFLAG=1 + ;..Q:$G(SGLFLAG) + ;..I $G(^PS(51,"A",SDL))'="" S SCHHOLD(GGGZ)=$P(^(SDL),"^") + ;.S SCHED(GGG)="",SGLFLAG=0 F WW=1:1:ZZSB S SCHED(GGG)=SCHED(GGG)_$S($G(SGLFLAG):" ",1:"")_$G(SCHHOLD(WW)),SGLFLAG=1 + S PREP="" + F FFF=0:0 S FFF=$O(SIG0(FFF)) Q:'FFF D + .K PSOSG1,PSOSG2 D VERB D:$G(PSNOUN(FFF))'=""&('$G(PSOSG1)) SSS + .D FRAC + .S SIG2(FFF)=$S(VERB'=""&('$G(PSOSG1)):VERB_" ",1:"")_$S($G(PSOFX("DOSE ORDERED",FFF))'="":$S($G(PSOFRAC)'="":$G(PSOFRAC),1:$G(PSOFX("DOSE ORDERED",FFF)))_" ",1:$G(PSOFX("DOSE",FFF))_" ") + .K PSOFRAC,PSOFRACX + .S SIG2(FFF)=SIG2(FFF)_$S($G(PSNOUN(FFF))'=""&('$G(PSOSG2)):$G(PSNOUN(FFF))_" ",1:"")_$S(PREP'=""&($G(MEDEXP(FFF))):PREP_" ",1:"") + .S SIG2(FFF)=SIG2(FFF)_$S(PSOROUTE(FFF)'="":PSOROUTE(FFF)_" ",1:"") + .;S SIG2(FFF)=SIG2(FFF)_$S(SCHED(FFF)'="":SCHED(FFF)_" ",1:"")_$S(PSDUR(FFF)'="NULL":PSDUR(FFF)_" ",1:"")_$S($G(PSOFX("CONJUNCTION",FFF))="A":"AND",$G(PSOFX("CONJUNCTION",FFF))="T":"THEN",$G(PSOFX("CONJUNCTION",FFF))="S":"THEN",1:"") + .S SIG2(FFF)=SIG2(FFF)_$S(ZSCHED(FFF)'="":ZSCHED(FFF)_$S($G(PSDUR(FFF))="NULL"&($G(PSOFX("CONJUNCTION",FFF))="")&('$O(SIG0(FFF))):"",1:" "),1:"") + .S PSOCJI=$G(PSOFX("CONJUNCTION",FFF)) + .S SIG2(FFF)=SIG2(FFF)_$S(PSDUR(FFF)'="NULL":PSDUR(FFF)_$S($G(PSOFX("CONJUNCTION",FFF))=""&('$O(SIG0(FFF))):"",1:", "),1:"")_$S($G(PSOCJI)="A":"AND",$G(PSOCJI)="T":"THEN",$G(PSOCJI)="S":"THEN",$G(PSOCJI)="X":"EXCEPT",1:"") + .K PSOSG1,PSOSG2 + .K PSOUCS S SIG2(FFF)=$$UPPER(SIG2(FFF)) K PSOUCS + ;I $G(PSOFX("INS"))'="" S TODOSE=TODOSE+1,SIG2(TODOSE)=$G(PSOFX("INS")) +STUFF ; + S DCOUNT=0 + I '$D(SIG2(1)) G QUIT + ;I '$O(SIG2(1)),$L(SIG2(1))<71 S ^PS(52.41,PENDING,"SIG",0)="^52.4124A^"_1_"^"_1 S ^PS(52.41,PENDING,"SIG",1,0)=SIG2(1) G QUIT + S (VAR,VAR1)="",II=1 + F FF=0:0 S FF=$O(SIG2(FF)) Q:'FF S CT=0 F NN=1:1:$L(SIG2(FF)) I $E(SIG2(FF),NN)=" "!($L(SIG2(FF))=NN) S CT=CT+1 D I $L(VAR)>200 S SIG(II)=LIM_" ",II=II+1,VAR=VAR1 + .S VAR1=$P(SIG2(FF)," ",(CT)) + .S LIM=VAR + .S VAR=$S(VAR="":VAR1,1:VAR_" "_VAR1) + I $G(VAR)'="" S SIG(II)=VAR + F II=0:0 S II=$O(SIG(II)) Q:'II S DCOUNT=DCOUNT+1 S ^PS(52.41,PENDING,2,DCOUNT,0)=SIG(II) + I DCOUNT S ^PS(52.41,PENDING,2,0)="^52.419A^"_DCOUNT_"^"_DCOUNT +QUIT K SSS,TT,DCOUNT,PREP,VERB,FFF,GGG,SIGDS,SIGRT,PSOROUTE,PSOSG1,PSOSG2 Q +SIG1 ; + F FFF=0:0 S FFF=$O(SIG0(FFF)) Q:'FFF S SIG2(FFF)=SIG0(FFF) + Q +DAYS I +$E($P(SIG1(TT),"^",2))!($E($P(SIG1(TT),"^",2))=0) S $P(SIG1(TT),"^",2)="D"_$P(SIG1(TT),"^",2) + Q +NON ; + I $P($G(SIG0(SSS)),"&",2)'="" S PSNOUN(SSS)=$P($G(SIG0(SSS)),"&",2) Q + Q + F NOUN=0:0 S NOUN=$O(^PS(50.606,SIGDS,"NOUN",NOUN)) Q:'NOUN!($G(PSNOUN(SSS))'="") I $P($G(^PS(50.606,SIGDS,"NOUN",NOUN,0)),"^")'="" S PSNOUN(SSS)=$P(^(0),"^") + Q +VERB ;Check if verb and noun need to be added to SIG + K PSOLCS,PSOUCS,PSOISL,PSOVL + I $G(VERB)'="" S PSOVL=$L(VERB),PSOISL=$E($G(SIG0(FFF)),1,$G(PSOVL)) I $G(PSOISL)'="" D + .S PSOUCS=VERB + .S PSOUCS=$$UPPER(PSOUCS) I PSOUCS=PSOISL S PSOSG1=1 Q + .S PSOUCS=$$LOWER(PSOUCS) I PSOUCS=PSOISL S PSOSG1=1 Q + .S PSOUCS=$$UPPER($E(PSOUCS,1))_$$LOWER($E(PSOUCS,2,99)) I PSOUCS=PSOISL S PSOSG1=1 Q + I $G(PSNOUN(FFF))="" G VERBEX + S PSOISL=$G(SIG0(FFF)) I $G(PSOISL)="" G VERBEX + S PSOVL=$F(PSNOUN(FFF),"(") + I $G(PSOVL)>2 S PSOUCS=$E(PSNOUN(FFF),1,(PSOVL-2)) + I $G(PSOVL)'>2 S PSOUCS=PSNOUN(FFF) + I $G(PSOISL)'="" D + .S PSOUCS=$$UPPER(PSOUCS) I PSOISL[PSOUCS S PSOSG2=1 Q + .S PSOUCS=$$LOWER(PSOUCS) I PSOISL[PSOUCS S PSOSG2=1 Q + .S PSOUCS=$$UPPER($E(PSOUCS,1))_$$LOWER($E(PSOUCS,2,99)) I PSOISL[PSOUCS S PSOSG2=1 +VERBEX K PSOLCS,PSOUCS,PSOISL,PSOVL Q + ; +UPPER(PSOUCS) ; + Q $TR(PSOUCS,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") + ; +LOWER(PSOLCS) ; + Q $TR(PSOLCS,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz") + Q + ; +SSS ; + K PSOFNL,PSOFNLF,PSOFNLX + Q:$G(PSNOUN(FFF))="" + Q:$L(PSNOUN(FFF))'>3 + Q:'$G(PSOFX("DOSE ORDERED",FFF)) + ;Q:$G(PSOFX("DOSE ORDERED",FFF))>1 + S PSOFNL=$E(PSNOUN(FFF),($L(PSNOUN(FFF))-2),$L(PSNOUN(FFF))) + I $G(PSOFNL)="(S)"!($G(PSOFNL)="(s)") D + .I $G(PSOFX("DOSE ORDERED",FFF))'>1 S PSNOUN(FFF)=$E(PSNOUN(FFF),1,($L(PSNOUN(FFF))-3)) + .I $G(PSOFX("DOSE ORDERED",FFF))>1 S PSNOUN(FFF)=$E(PSNOUN(FFF),1,($L(PSNOUN(FFF))-3))_$E(PSOFNL,2) + Q +FRAC ; + K PSOFRAC,PSOFRACX,PSOFRAC1,PSOFRAC2 + I $G(PSOFX("DOSE ORDERED",FFF))="" Q + I $G(PSOFX("DOSE ORDERED",FFF))'["." S (PSOFRAC1,PSOFRAC)=$G(PSOFX("DOSE ORDERED",FFF)) D NUM D G FRACQ + .I $G(PSOFRAC1)=$G(PSOFRAC) K PSOFRAC,PSOFRAC1 Q + .S PSOFRAC=$G(PSOFRAC1) + S PSOFRAC1=$P(PSOFX("DOSE ORDERED",FFF),"."),PSOFRAC2=$P(PSOFX("DOSE ORDERED",FFF),".",2) + S PSOFRACX="."_$G(PSOFRAC2) + S PSOFRAC=$S(PSOFRACX=".5":"ONE-HALF",PSOFRACX=".25":"ONE-FOURTH",PSOFRACX=".33":"ONE-THIRD",PSOFRACX=".34":"ONE-THIRD",PSOFRACX=".50":"ONE-HALF",PSOFRACX=".66":"TWO-THIRDS",PSOFRACX=".67":"TWO-THIRDS",PSOFRACX=".75":"THREE-FOURTHS",1:"") + I $G(PSOFRAC)="" K PSOFRAC G FRACQ + I $G(PSOFRAC1)'="",+$G(PSOFRAC1) D NUM S PSOFRAC=$G(PSOFRAC1)_" AND "_$G(PSOFRAC) +FRACQ K PSOFRAC1,PSOFRAC2 + Q +NUM ; + Q:$G(PSOFRAC1)="" + S PSOFRAC1=$S(PSOFRAC1="1":"ONE",PSOFRAC1="2":"TWO",PSOFRAC1="3":"THREE",PSOFRAC1="4":"FOUR",PSOFRAC1="5":"FIVE",PSOFRAC1="6":"SIX",PSOFRAC1="7":"SEVEN",PSOFRAC1="8":"EIGHT",PSOFRAC1="9":"NINE",PSOFRAC1="10":"TEN",1:PSOFRAC1) + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLPIS.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLPIS.m index 6b9cef93..fccce45f 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLPIS.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLPIS.m @@ -1,140 +1,140 @@ -PSOHLPIS ;BIR/RTR-Parse out and create CPRS Sig ;7/21/96 - ;;7.0;OUTPATIENT PHARMACY;**46,225**;DEC 1997;Build 29 - ;External reference to File #50.7 supported by DBIA 2223 - ;External reference to File #51 supported by DBIA 2224 - ;External reference to File #51.1 supported by DBIA 2225 - ;External reference to File #51.2 supported by DBIA 2226 - ;External reference to File #50.606 supported by DBIA 2174 -EN ; - Q:'$D(^PS(52.41,PENDING,1,0)) - N PISI,PSOFX,SDF,SZZ,ZZS,ZZSB,SSZZ,SCHHOLD,GGGZ,SGLFLAG,SGLOOP,ZSCHED,SPFG,PSNOUN,MEDEXP,PSDUR,NOUN,SCHED,INTERVAL,SIG0,SIG2,SIG3,SDL,WW,TODOSE,PDAYS,WWFL,PSOCJS,PSOFDCT,PSODCT - N SSS,TT,DCOUNT,PREP,VERB,FFF,GGG,SIGDS,SIGRT,PSOROUTE,PSOSG1,PSOSG2,FTC,FTCA,FTCF,FTCNT - N SIG - F PISI=0:0 S PISI=$O(^PS(52.41,PENDING,1,PISI)) Q:'PISI D:$D(^(PISI,0)) - .S PSOFX("DOSE",PISI)=$P($G(^PS(52.41,PENDING,1,PISI,2)),"^") I $P($G(^(2)),"^",2)'="" S PSOFX("DOSE ORDERED",PISI)=$P($G(^(2)),"^",2) - .S PSOFX("SCHEDULE",PISI)=$P($G(^PS(52.41,PENDING,1,PISI,1)),"^"),PSOFX("ROUTE",PISI)=$P($G(^(1)),"^",8),PSOFX("DURATION",PISI)=$P($G(^(1)),"^",2),PSOFX("NOUN",PISI)=$P($G(^(1)),"^",5),PSOFX("CONJUNCTION",PISI)=$P($G(^(1)),"^",6) - .I $G(PSOFX("DURATION",PISI)) S PSOFX("DURATION",PISI)="D"_$G(PSOFX("DURATION",PISI)) - .I $G(PSOFX("DURATION",PISI))'="" S PSOFX("DURATION",PISI)=$E(PSOFX("DURATION",PISI),2,999)_$E(PSOFX("DURATION",PISI)) - S TODOSE=0 F WW=0:0 S WW=$O(PSOFX("DOSE",WW)) Q:'WW S TODOSE=WW - Q:'TODOSE - S SIGDS=+$P($G(^PS(50.7,+$G(PSORDITE),0)),"^",2),VERB=$P($G(^PS(50.606,SIGDS,"MISC")),"^"),PREP=$P($G(^("MISC")),"^",3) - S FTCNT=0 K FTC,FTCA,FTCF F SSS=1:1:TODOSE D - .S SIG0(SSS)=$S($G(PSOFX("DOSE ORDERED",SSS))'="":$G(PSOFX("DOSE ORDERED",SSS)),1:$G(PSOFX("DOSE",SSS))) - .S PSNOUN(SSS)=$G(PSOFX("NOUN",SSS)) - .S FTC=+$G(PSOFX("ROUTE",SSS)) I FTC S:'FTCNT FTCA=FTC S FTCNT=FTCNT+1 - .I FTCNT>1,$G(FTC),$G(FTC)'=$G(FTCA) S FTCF=1 - .S PSOROUTE(SSS)=$S($P($G(^PS(51.2,+$G(PSOFX("ROUTE",SSS)),0)),"^",2)'="":$P(^(0),"^",2),$P($G(^(0)),"^",3)'="":$P(^(0),"^",3),1:$P($G(^(0)),"^")) S MEDEXP(SSS)=$S($P($G(^PS(51.2,+$G(PSOFX("ROUTE",SSS)),0)),"^",2)="":0,1:1) - .S PDAYS(SSS)=$G(PSOFX("DURATION",SSS)) - .I $G(PSOFX("DURATION",SSS))'="",($E(PSOFX("DURATION",SSS),$L(PSOFX("DURATION",SSS)))'?1A) S PDAYS(SSS)=PDAYS(SSS)_"D" - .S PSDUR(SSS)=$S($G(PDAYS(SSS))="":"NULL",1:"FOR "_$E($G(PDAYS(SSS)),1,($L($G(PDAYS(SSS)))-1))) D I PSDUR(SSS)'="NULL" S PSDUR(SSS)=PSDUR(SSS)_" "_INTERVAL - ..I PSDUR(SSS)'="NULL" S INTERVAL=$E(PDAYS(SSS),$L(PDAYS(SSS))),INTERVAL=$S(INTERVAL="D":"DAYS",INTERVAL="W":"WEEKS",INTERVAL="H":"HOURS",INTERVAL="L":"MONTHS",INTERVAL="M":"MINUTES",INTERVAL="S":"SECONDS",1:"") D - ...I $G(INTERVAL)'="",$G(PSOFX("DURATION",SSS)),$G(PSOFX("DURATION",SSS))'>1 S INTERVAL=$E(INTERVAL,1,($L(INTERVAL)-1)) - F GGG=1:1:TODOSE S ZSCHED(GGG)=$G(PSOFX("SCHEDULE",GGG)) D - .I $G(ZSCHED(GGG))="" S SCHED(GGG)="" Q - .S SGLFLAG=0 F WW=0:0 S WW=$O(^PS(51.1,"B",ZSCHED(GGG),WW)) Q:'WW!($G(SGLFLAG)) I $P($G(^PS(51.1,WW,0)),"^",8)'="" S SCHED(GGG)=$P($G(^(0)),"^",8),SGLFLAG=1 - .Q:$G(SGLFLAG) - .I $G(^PS(51,"A",ZSCHED(GGG)))'="" S SCHED(GGG)=$P(^(ZSCHED(GGG)),"^") Q - .S ZZSB=0 F ZZS=1:1:$L(ZSCHED(GGG)) S SZZ=$E(ZSCHED(GGG),ZZS) I SZZ=" " S ZZSB=ZZSB+1 - .S ZZSB=ZZSB+1 - .K SCHHOLD F GGGZ=1:1:ZZSB S (SDL,SCHHOLD(GGGZ))=$P(ZSCHED(GGG)," ",GGGZ) D - ..Q:$G(SDL)="" - ..S SGLFLAG=0 F WW=0:0 S WW=$O(^PS(51.1,"B",SDL,WW)) Q:'WW!($G(SGLFLAG)) I $P($G(^PS(51.1,WW,0)),"^",8)'="" S SCHHOLD(GGGZ)=$P($G(^(0)),"^",8),SGLFLAG=1 - ..Q:$G(SGLFLAG) - ..I $G(^PS(51,"A",SDL))'="" S SCHHOLD(GGGZ)=$P(^(SDL),"^") - .S SCHED(GGG)="",SGLFLAG=0 F WW=1:1:ZZSB S SCHED(GGG)=SCHED(GGG)_$S($G(SGLFLAG):" ",1:"")_$G(SCHHOLD(WW)),SGLFLAG=1 - S (FTC,FTCA,PSOFDCT)=0 F FFF=0:0 S FFF=$O(SIG0(FFF)) Q:'FFF D - .K PSOSG1,PSOSG2 D VERB D:$G(PSNOUN(FFF))'=""&('$G(PSOSG1)) SSS - .D FRAC - .S SIG2(FFF)=$S(VERB'=""&('$G(PSOSG1)):VERB_" ",1:"")_$S($G(PSOFX("DOSE ORDERED",FFF))'="":$S($G(PSOFRAC)'="":$G(PSOFRAC),1:$G(PSOFX("DOSE ORDERED",FFF)))_" ",1:$G(PSOFX("DOSE",FFF))_" ") - .S PSOFDCT=PSOFDCT+1 - .K PSOFRAC,PSOFRACX - .I FTC>0,$G(PSOROUTE(FFF))'="",'$G(FTCF) S FTCA=1 - .I $G(PSOROUTE(FFF))'="" S FTC=FTC+1 - .S SIG2(FFF)=SIG2(FFF)_$S($G(PSNOUN(FFF))'=""&('$G(PSOSG2)):$G(PSNOUN(FFF))_" ",1:"")_$S(PREP'=""&($G(MEDEXP(FFF)))&('FTCA):PREP_" ",1:"") - .S SIG2(FFF)=SIG2(FFF)_$S(PSOROUTE(FFF)'=""&('FTCA):PSOROUTE(FFF)_" ",1:"") - .;S SIG2(FFF)=SIG2(FFF)_$S(SCHED(FFF)'="":SCHED(FFF)_" ",1:"")_$S(PSDUR(FFF)'="NULL":PSDUR(FFF)_" ",1:"")_$S($G(PSOFX("CONJUNCTION",FFF))="A":"AND",$G(PSOFX("CONJUNCTION",FFF))="T":"THEN",$G(PSOFX("CONJUNCTION",FFF))="S":"THEN",1:"") - .S SIG2(FFF)=SIG2(FFF)_$S(SCHED(FFF)'="":SCHED(FFF)_$S($G(PSDUR(FFF))="NULL"&($G(PSOFX("CONJUNCTION",FFF))="")&('$O(SIG0(FFF))):"",1:" "),1:"") - .S PSOCJS=$G(PSOFX("CONJUNCTION",FFF)) - .S SIG2(FFF)=SIG2(FFF)_$S(PSDUR(FFF)'="NULL":PSDUR(FFF)_$S($G(PSOFX("CONJUNCTION",FFF))=""&('$O(SIG0(FFF))):"",1:", "),1:"")_$S($G(PSOCJS)="A":"AND",$G(PSOCJS)="T":"THEN",$G(PSOCJS)="S":"THEN",$G(PSOCJS)="X":"EXCEPT",1:"") - .K PSOSG1,PSOSG2 - .K PSOUCS S SIG2(FFF)=$$UPPER(SIG2(FFF)) K PSOUCS - ;I $G(PSOFX("INS"))'="" S TODOSE=TODOSE+1,SIG2(TODOSE)=$G(PSOFX("INS")) - S PSODCT="" F S PSODCT=$O(^PS(52.41,PENDING,"INS1",PSODCT)) Q:PSODCT="" I $D(^(PSODCT,0)) S PSOFDCT=PSOFDCT+1 S SIG2(PSOFDCT)=$G(^(0)) K PSOUCS S SIG2(PSOFDCT)=$$UPPER(SIG2(PSOFDCT)) K PSOUCS -STUFF ; - S DCOUNT=0 - I '$D(SIG2(1)) G QUIT - I '$O(SIG2(1)),$L(SIG2(1))<71 S ^PS(52.41,PENDING,"SIG",0)="^52.4124A^"_1_"^"_1 S ^PS(52.41,PENDING,"SIG",1,0)=$$UNESC^ORHLESC(SIG2(1)) S DCOUNT=1 G QUITIN - S (VAR,VAR1)="",II=1 - F FF=0:0 S FF=$O(SIG2(FF)) Q:'FF S CT=0 F NN=1:1:$L(SIG2(FF)) I $E(SIG2(FF),NN)=" "!($L(SIG2(FF))=NN) S CT=CT+1 D I $L(VAR)>70 S SIG(II)=LIM_" ",II=II+1,VAR=VAR1 - .S VAR1=$P(SIG2(FF)," ",(CT)) - .S LIM=VAR - .S VAR=$S(VAR="":VAR1,1:VAR_" "_VAR1) - I $G(VAR)'="" S SIG(II)=VAR - F II=0:0 S II=$O(SIG(II)) Q:'II S DCOUNT=DCOUNT+1 S ^PS(52.41,PENDING,"SIG",DCOUNT,0)=$$UNESC^ORHLESC(SIG(II)) - I DCOUNT S ^PS(52.41,PENDING,"SIG",0)="^52.4124A^"_DCOUNT_"^"_DCOUNT -QUITIN ;I $P($G(^PS(50.7,+$G(PSORDITE),"INS")),"^")'="",DCOUNT S DCOUNT=DCOUNT+1,^PS(52.41,PENDING,"SIG",0)="^52.4124A^"_DCOUNT_"^"_DCOUNT,^PS(52.41,PENDING,"SIG",DCOUNT,0)=$P($G(^PS(50.7,+$G(PSORDITE),"INS")),"^") - ;I $P($G(^PS(50.7,+$G(PSORDITE),"INS")),"^")'="" S $P(^PS(52.41,PENDING,"INS"),"^")=$P(^PS(50.7,+$G(PSORDITE),"INS"),"^") -QUIT K SSS,TT,DCOUNT,PREP,VERB,FFF,GGG,SIGDS,SIGRT,PSOROUTE,PSOSG1,PSOSG2 Q -SIG1 ; - F FFF=0:0 S FFF=$O(SIG0(FFF)) Q:'FFF S SIG2(FFF)=SIG0(FFF) - Q -DAYS I +$E($P(SIG1(TT),"^",2))!($E($P(SIG1(TT),"^",2))=0) S $P(SIG1(TT),"^",2)="D"_$P(SIG1(TT),"^",2) - Q -NON ; - I $P($G(SIG0(SSS)),"&",2)'="" S PSNOUN(SSS)=$P($G(SIG0(SSS)),"&",2) Q - Q - F NOUN=0:0 S NOUN=$O(^PS(50.606,SIGDS,"NOUN",NOUN)) Q:'NOUN!($G(PSNOUN(SSS))'="") I $P($G(^PS(50.606,SIGDS,"NOUN",NOUN,0)),"^")'="" S PSNOUN(SSS)=$P(^(0),"^") - Q -VERB ;Check if verb and noun need to be added to SIG - K PSOLCS,PSOUCS,PSOISL,PSOVL - I $G(VERB)'="" S PSOVL=$L(VERB),PSOISL=$E($G(SIG0(FFF)),1,$G(PSOVL)) I $G(PSOISL)'="" D - .S PSOUCS=VERB - .S PSOUCS=$$UPPER(PSOUCS) I PSOUCS=PSOISL S PSOSG1=1 Q - .S PSOUCS=$$LOWER(PSOUCS) I PSOUCS=PSOISL S PSOSG1=1 Q - .S PSOUCS=$$UPPER($E(PSOUCS,1))_$$LOWER($E(PSOUCS,2,99)) I PSOUCS=PSOISL S PSOSG1=1 Q - I $G(PSNOUN(FFF))="" G VERBEX - S PSOISL=$G(SIG0(FFF)) I $G(PSOISL)="" G VERBEX - S PSOVL=$F(PSNOUN(FFF),"(") - I $G(PSOVL)>2 S PSOUCS=$E(PSNOUN(FFF),1,(PSOVL-2)) - I $G(PSOVL)'>2 S PSOUCS=PSNOUN(FFF) - I $G(PSOISL)'="" D - .S PSOUCS=$$UPPER(PSOUCS) I PSOISL[PSOUCS S PSOSG2=1 Q - .S PSOUCS=$$LOWER(PSOUCS) I PSOISL[PSOUCS S PSOSG2=1 Q - .S PSOUCS=$$UPPER($E(PSOUCS,1))_$$LOWER($E(PSOUCS,2,99)) I PSOISL[PSOUCS S PSOSG2=1 -VERBEX K PSOLCS,PSOUCS,PSOISL,PSOVL Q - ; -UPPER(PSOUCS) ; - Q $TR(PSOUCS,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") - ; -LOWER(PSOLCS) ; - Q $TR(PSOLCS,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz") - Q - ; -SSS ; - K PSOFNL,PSOFNLF,PSOFNLX - Q:$G(PSNOUN(FFF))="" - Q:$L(PSNOUN(FFF))'>3 - Q:'$G(PSOFX("DOSE ORDERED",FFF)) - ;Q:$G(PSOFX("DOSE ORDERED",FFF))>1 - S PSOFNL=$E(PSNOUN(FFF),($L(PSNOUN(FFF))-2),$L(PSNOUN(FFF))) - I $G(PSOFNL)="(S)"!($G(PSOFNL)="(s)") D - .I $G(PSOFX("DOSE ORDERED",FFF))'>1 S PSNOUN(FFF)=$E(PSNOUN(FFF),1,($L(PSNOUN(FFF))-3)) - .I $G(PSOFX("DOSE ORDERED",FFF))>1 S PSNOUN(FFF)=$E(PSNOUN(FFF),1,($L(PSNOUN(FFF))-3))_$E(PSOFNL,2) - Q -FRAC ; - K PSOFRAC,PSOFRACX,PSOFRAC1,PSOFRAC2 - I $G(PSOFX("DOSE ORDERED",FFF))="" Q - I $G(PSOFX("DOSE ORDERED",FFF))'["." S (PSOFRAC1,PSOFRAC)=$G(PSOFX("DOSE ORDERED",FFF)) D NUM D G FRACQ - .I $G(PSOFRAC1)=$G(PSOFRAC) K PSOFRAC,PSOFRAC1 Q - .S PSOFRAC=$G(PSOFRAC1) - S PSOFRAC1=$P(PSOFX("DOSE ORDERED",FFF),"."),PSOFRAC2=$P(PSOFX("DOSE ORDERED",FFF),".",2) - S PSOFRACX="."_$G(PSOFRAC2) - S PSOFRAC=$S(PSOFRACX=".5":"ONE-HALF",PSOFRACX=".25":"ONE-FOURTH",PSOFRACX=".33":"ONE-THIRD",PSOFRACX=".34":"ONE-THIRD",PSOFRACX=".50":"ONE-HALF",PSOFRACX=".66":"TWO-THIRDS",PSOFRACX=".67":"TWO-THIRDS",PSOFRACX=".75":"THREE-FOURTHS",1:"") - I $G(PSOFRAC)="" K PSOFRAC G FRACQ - I $G(PSOFRAC1)'="",+$G(PSOFRAC1) D NUM S PSOFRAC=$G(PSOFRAC1)_" AND "_$G(PSOFRAC) -FRACQ K PSOFRAC1,PSOFRAC2 - Q -NUM ; - Q:$G(PSOFRAC1)="" - S PSOFRAC1=$S(PSOFRAC1="1":"ONE",PSOFRAC1="2":"TWO",PSOFRAC1="3":"THREE",PSOFRAC1="4":"FOUR",PSOFRAC1="5":"FIVE",PSOFRAC1="6":"SIX",PSOFRAC1="7":"SEVEN",PSOFRAC1="8":"EIGHT",PSOFRAC1="9":"NINE",PSOFRAC1="10":"TEN",1:PSOFRAC1) - Q +PSOHLPIS ;BIR/RTR-Parse out and create CPRS Sig ;7/21/96 + ;;7.0;OUTPATIENT PHARMACY;**46**;DEC 1997 + ;External reference to File #50.7 supported by DBIA 2223 + ;External reference to File #51 supported by DBIA 2224 + ;External reference to File #51.1 supported by DBIA 2225 + ;External reference to File #51.2 supported by DBIA 2226 + ;External reference to File #50.606 supported by DBIA 2174 +EN ; + Q:'$D(^PS(52.41,PENDING,1,0)) + N PISI,PSOFX,SDF,SZZ,ZZS,ZZSB,SSZZ,SCHHOLD,GGGZ,SGLFLAG,SGLOOP,ZSCHED,SPFG,PSNOUN,MEDEXP,PSDUR,NOUN,SCHED,INTERVAL,SIG0,SIG2,SIG3,SDL,WW,TODOSE,PDAYS,WWFL,PSOCJS,PSOFDCT,PSODCT + N SSS,TT,DCOUNT,PREP,VERB,FFF,GGG,SIGDS,SIGRT,PSOROUTE,PSOSG1,PSOSG2,FTC,FTCA,FTCF,FTCNT + N SIG + F PISI=0:0 S PISI=$O(^PS(52.41,PENDING,1,PISI)) Q:'PISI D:$D(^(PISI,0)) + .S PSOFX("DOSE",PISI)=$P($G(^PS(52.41,PENDING,1,PISI,2)),"^") I $P($G(^(2)),"^",2)'="" S PSOFX("DOSE ORDERED",PISI)=$P($G(^(2)),"^",2) + .S PSOFX("SCHEDULE",PISI)=$P($G(^PS(52.41,PENDING,1,PISI,1)),"^"),PSOFX("ROUTE",PISI)=$P($G(^(1)),"^",8),PSOFX("DURATION",PISI)=$P($G(^(1)),"^",2),PSOFX("NOUN",PISI)=$P($G(^(1)),"^",5),PSOFX("CONJUNCTION",PISI)=$P($G(^(1)),"^",6) + .I $G(PSOFX("DURATION",PISI)) S PSOFX("DURATION",PISI)="D"_$G(PSOFX("DURATION",PISI)) + .I $G(PSOFX("DURATION",PISI))'="" S PSOFX("DURATION",PISI)=$E(PSOFX("DURATION",PISI),2,999)_$E(PSOFX("DURATION",PISI)) + S TODOSE=0 F WW=0:0 S WW=$O(PSOFX("DOSE",WW)) Q:'WW S TODOSE=WW + Q:'TODOSE + S SIGDS=+$P($G(^PS(50.7,+$G(PSORDITE),0)),"^",2),VERB=$P($G(^PS(50.606,SIGDS,"MISC")),"^"),PREP=$P($G(^("MISC")),"^",3) + S FTCNT=0 K FTC,FTCA,FTCF F SSS=1:1:TODOSE D + .S SIG0(SSS)=$S($G(PSOFX("DOSE ORDERED",SSS))'="":$G(PSOFX("DOSE ORDERED",SSS)),1:$G(PSOFX("DOSE",SSS))) + .S PSNOUN(SSS)=$G(PSOFX("NOUN",SSS)) + .S FTC=+$G(PSOFX("ROUTE",SSS)) I FTC S:'FTCNT FTCA=FTC S FTCNT=FTCNT+1 + .I FTCNT>1,$G(FTC),$G(FTC)'=$G(FTCA) S FTCF=1 + .S PSOROUTE(SSS)=$S($P($G(^PS(51.2,+$G(PSOFX("ROUTE",SSS)),0)),"^",2)'="":$P(^(0),"^",2),$P($G(^(0)),"^",3)'="":$P(^(0),"^",3),1:$P($G(^(0)),"^")) S MEDEXP(SSS)=$S($P($G(^PS(51.2,+$G(PSOFX("ROUTE",SSS)),0)),"^",2)="":0,1:1) + .S PDAYS(SSS)=$G(PSOFX("DURATION",SSS)) + .I $G(PSOFX("DURATION",SSS))'="",($E(PSOFX("DURATION",SSS),$L(PSOFX("DURATION",SSS)))'?1A) S PDAYS(SSS)=PDAYS(SSS)_"D" + .S PSDUR(SSS)=$S($G(PDAYS(SSS))="":"NULL",1:"FOR "_$E($G(PDAYS(SSS)),1,($L($G(PDAYS(SSS)))-1))) D I PSDUR(SSS)'="NULL" S PSDUR(SSS)=PSDUR(SSS)_" "_INTERVAL + ..I PSDUR(SSS)'="NULL" S INTERVAL=$E(PDAYS(SSS),$L(PDAYS(SSS))),INTERVAL=$S(INTERVAL="D":"DAYS",INTERVAL="W":"WEEKS",INTERVAL="H":"HOURS",INTERVAL="L":"MONTHS",INTERVAL="M":"MINUTES",INTERVAL="S":"SECONDS",1:"") D + ...I $G(INTERVAL)'="",$G(PSOFX("DURATION",SSS)),$G(PSOFX("DURATION",SSS))'>1 S INTERVAL=$E(INTERVAL,1,($L(INTERVAL)-1)) + F GGG=1:1:TODOSE S ZSCHED(GGG)=$G(PSOFX("SCHEDULE",GGG)) D + .I $G(ZSCHED(GGG))="" S SCHED(GGG)="" Q + .S SGLFLAG=0 F WW=0:0 S WW=$O(^PS(51.1,"B",ZSCHED(GGG),WW)) Q:'WW!($G(SGLFLAG)) I $P($G(^PS(51.1,WW,0)),"^",8)'="" S SCHED(GGG)=$P($G(^(0)),"^",8),SGLFLAG=1 + .Q:$G(SGLFLAG) + .I $G(^PS(51,"A",ZSCHED(GGG)))'="" S SCHED(GGG)=$P(^(ZSCHED(GGG)),"^") Q + .S ZZSB=0 F ZZS=1:1:$L(ZSCHED(GGG)) S SZZ=$E(ZSCHED(GGG),ZZS) I SZZ=" " S ZZSB=ZZSB+1 + .S ZZSB=ZZSB+1 + .K SCHHOLD F GGGZ=1:1:ZZSB S (SDL,SCHHOLD(GGGZ))=$P(ZSCHED(GGG)," ",GGGZ) D + ..Q:$G(SDL)="" + ..S SGLFLAG=0 F WW=0:0 S WW=$O(^PS(51.1,"B",SDL,WW)) Q:'WW!($G(SGLFLAG)) I $P($G(^PS(51.1,WW,0)),"^",8)'="" S SCHHOLD(GGGZ)=$P($G(^(0)),"^",8),SGLFLAG=1 + ..Q:$G(SGLFLAG) + ..I $G(^PS(51,"A",SDL))'="" S SCHHOLD(GGGZ)=$P(^(SDL),"^") + .S SCHED(GGG)="",SGLFLAG=0 F WW=1:1:ZZSB S SCHED(GGG)=SCHED(GGG)_$S($G(SGLFLAG):" ",1:"")_$G(SCHHOLD(WW)),SGLFLAG=1 + S (FTC,FTCA,PSOFDCT)=0 F FFF=0:0 S FFF=$O(SIG0(FFF)) Q:'FFF D + .K PSOSG1,PSOSG2 D VERB D:$G(PSNOUN(FFF))'=""&('$G(PSOSG1)) SSS + .D FRAC + .S SIG2(FFF)=$S(VERB'=""&('$G(PSOSG1)):VERB_" ",1:"")_$S($G(PSOFX("DOSE ORDERED",FFF))'="":$S($G(PSOFRAC)'="":$G(PSOFRAC),1:$G(PSOFX("DOSE ORDERED",FFF)))_" ",1:$G(PSOFX("DOSE",FFF))_" ") + .S PSOFDCT=PSOFDCT+1 + .K PSOFRAC,PSOFRACX + .I FTC>0,$G(PSOROUTE(FFF))'="",'$G(FTCF) S FTCA=1 + .I $G(PSOROUTE(FFF))'="" S FTC=FTC+1 + .S SIG2(FFF)=SIG2(FFF)_$S($G(PSNOUN(FFF))'=""&('$G(PSOSG2)):$G(PSNOUN(FFF))_" ",1:"")_$S(PREP'=""&($G(MEDEXP(FFF)))&('FTCA):PREP_" ",1:"") + .S SIG2(FFF)=SIG2(FFF)_$S(PSOROUTE(FFF)'=""&('FTCA):PSOROUTE(FFF)_" ",1:"") + .;S SIG2(FFF)=SIG2(FFF)_$S(SCHED(FFF)'="":SCHED(FFF)_" ",1:"")_$S(PSDUR(FFF)'="NULL":PSDUR(FFF)_" ",1:"")_$S($G(PSOFX("CONJUNCTION",FFF))="A":"AND",$G(PSOFX("CONJUNCTION",FFF))="T":"THEN",$G(PSOFX("CONJUNCTION",FFF))="S":"THEN",1:"") + .S SIG2(FFF)=SIG2(FFF)_$S(SCHED(FFF)'="":SCHED(FFF)_$S($G(PSDUR(FFF))="NULL"&($G(PSOFX("CONJUNCTION",FFF))="")&('$O(SIG0(FFF))):"",1:" "),1:"") + .S PSOCJS=$G(PSOFX("CONJUNCTION",FFF)) + .S SIG2(FFF)=SIG2(FFF)_$S(PSDUR(FFF)'="NULL":PSDUR(FFF)_$S($G(PSOFX("CONJUNCTION",FFF))=""&('$O(SIG0(FFF))):"",1:", "),1:"")_$S($G(PSOCJS)="A":"AND",$G(PSOCJS)="T":"THEN",$G(PSOCJS)="S":"THEN",$G(PSOCJS)="X":"EXCEPT",1:"") + .K PSOSG1,PSOSG2 + .K PSOUCS S SIG2(FFF)=$$UPPER(SIG2(FFF)) K PSOUCS + ;I $G(PSOFX("INS"))'="" S TODOSE=TODOSE+1,SIG2(TODOSE)=$G(PSOFX("INS")) + S PSODCT="" F S PSODCT=$O(^PS(52.41,PENDING,"INS1",PSODCT)) Q:PSODCT="" I $D(^(PSODCT,0)) S PSOFDCT=PSOFDCT+1 S SIG2(PSOFDCT)=$G(^(0)) K PSOUCS S SIG2(PSOFDCT)=$$UPPER(SIG2(PSOFDCT)) K PSOUCS +STUFF ; + S DCOUNT=0 + I '$D(SIG2(1)) G QUIT + I '$O(SIG2(1)),$L(SIG2(1))<71 S ^PS(52.41,PENDING,"SIG",0)="^52.4124A^"_1_"^"_1 S ^PS(52.41,PENDING,"SIG",1,0)=SIG2(1) S DCOUNT=1 G QUITIN + S (VAR,VAR1)="",II=1 + F FF=0:0 S FF=$O(SIG2(FF)) Q:'FF S CT=0 F NN=1:1:$L(SIG2(FF)) I $E(SIG2(FF),NN)=" "!($L(SIG2(FF))=NN) S CT=CT+1 D I $L(VAR)>70 S SIG(II)=LIM_" ",II=II+1,VAR=VAR1 + .S VAR1=$P(SIG2(FF)," ",(CT)) + .S LIM=VAR + .S VAR=$S(VAR="":VAR1,1:VAR_" "_VAR1) + I $G(VAR)'="" S SIG(II)=VAR + F II=0:0 S II=$O(SIG(II)) Q:'II S DCOUNT=DCOUNT+1 S ^PS(52.41,PENDING,"SIG",DCOUNT,0)=SIG(II) + I DCOUNT S ^PS(52.41,PENDING,"SIG",0)="^52.4124A^"_DCOUNT_"^"_DCOUNT +QUITIN ;I $P($G(^PS(50.7,+$G(PSORDITE),"INS")),"^")'="",DCOUNT S DCOUNT=DCOUNT+1,^PS(52.41,PENDING,"SIG",0)="^52.4124A^"_DCOUNT_"^"_DCOUNT,^PS(52.41,PENDING,"SIG",DCOUNT,0)=$P($G(^PS(50.7,+$G(PSORDITE),"INS")),"^") + ;I $P($G(^PS(50.7,+$G(PSORDITE),"INS")),"^")'="" S $P(^PS(52.41,PENDING,"INS"),"^")=$P(^PS(50.7,+$G(PSORDITE),"INS"),"^") +QUIT K SSS,TT,DCOUNT,PREP,VERB,FFF,GGG,SIGDS,SIGRT,PSOROUTE,PSOSG1,PSOSG2 Q +SIG1 ; + F FFF=0:0 S FFF=$O(SIG0(FFF)) Q:'FFF S SIG2(FFF)=SIG0(FFF) + Q +DAYS I +$E($P(SIG1(TT),"^",2))!($E($P(SIG1(TT),"^",2))=0) S $P(SIG1(TT),"^",2)="D"_$P(SIG1(TT),"^",2) + Q +NON ; + I $P($G(SIG0(SSS)),"&",2)'="" S PSNOUN(SSS)=$P($G(SIG0(SSS)),"&",2) Q + Q + F NOUN=0:0 S NOUN=$O(^PS(50.606,SIGDS,"NOUN",NOUN)) Q:'NOUN!($G(PSNOUN(SSS))'="") I $P($G(^PS(50.606,SIGDS,"NOUN",NOUN,0)),"^")'="" S PSNOUN(SSS)=$P(^(0),"^") + Q +VERB ;Check if verb and noun need to be added to SIG + K PSOLCS,PSOUCS,PSOISL,PSOVL + I $G(VERB)'="" S PSOVL=$L(VERB),PSOISL=$E($G(SIG0(FFF)),1,$G(PSOVL)) I $G(PSOISL)'="" D + .S PSOUCS=VERB + .S PSOUCS=$$UPPER(PSOUCS) I PSOUCS=PSOISL S PSOSG1=1 Q + .S PSOUCS=$$LOWER(PSOUCS) I PSOUCS=PSOISL S PSOSG1=1 Q + .S PSOUCS=$$UPPER($E(PSOUCS,1))_$$LOWER($E(PSOUCS,2,99)) I PSOUCS=PSOISL S PSOSG1=1 Q + I $G(PSNOUN(FFF))="" G VERBEX + S PSOISL=$G(SIG0(FFF)) I $G(PSOISL)="" G VERBEX + S PSOVL=$F(PSNOUN(FFF),"(") + I $G(PSOVL)>2 S PSOUCS=$E(PSNOUN(FFF),1,(PSOVL-2)) + I $G(PSOVL)'>2 S PSOUCS=PSNOUN(FFF) + I $G(PSOISL)'="" D + .S PSOUCS=$$UPPER(PSOUCS) I PSOISL[PSOUCS S PSOSG2=1 Q + .S PSOUCS=$$LOWER(PSOUCS) I PSOISL[PSOUCS S PSOSG2=1 Q + .S PSOUCS=$$UPPER($E(PSOUCS,1))_$$LOWER($E(PSOUCS,2,99)) I PSOISL[PSOUCS S PSOSG2=1 +VERBEX K PSOLCS,PSOUCS,PSOISL,PSOVL Q + ; +UPPER(PSOUCS) ; + Q $TR(PSOUCS,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") + ; +LOWER(PSOLCS) ; + Q $TR(PSOLCS,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz") + Q + ; +SSS ; + K PSOFNL,PSOFNLF,PSOFNLX + Q:$G(PSNOUN(FFF))="" + Q:$L(PSNOUN(FFF))'>3 + Q:'$G(PSOFX("DOSE ORDERED",FFF)) + ;Q:$G(PSOFX("DOSE ORDERED",FFF))>1 + S PSOFNL=$E(PSNOUN(FFF),($L(PSNOUN(FFF))-2),$L(PSNOUN(FFF))) + I $G(PSOFNL)="(S)"!($G(PSOFNL)="(s)") D + .I $G(PSOFX("DOSE ORDERED",FFF))'>1 S PSNOUN(FFF)=$E(PSNOUN(FFF),1,($L(PSNOUN(FFF))-3)) + .I $G(PSOFX("DOSE ORDERED",FFF))>1 S PSNOUN(FFF)=$E(PSNOUN(FFF),1,($L(PSNOUN(FFF))-3))_$E(PSOFNL,2) + Q +FRAC ; + K PSOFRAC,PSOFRACX,PSOFRAC1,PSOFRAC2 + I $G(PSOFX("DOSE ORDERED",FFF))="" Q + I $G(PSOFX("DOSE ORDERED",FFF))'["." S (PSOFRAC1,PSOFRAC)=$G(PSOFX("DOSE ORDERED",FFF)) D NUM D G FRACQ + .I $G(PSOFRAC1)=$G(PSOFRAC) K PSOFRAC,PSOFRAC1 Q + .S PSOFRAC=$G(PSOFRAC1) + S PSOFRAC1=$P(PSOFX("DOSE ORDERED",FFF),"."),PSOFRAC2=$P(PSOFX("DOSE ORDERED",FFF),".",2) + S PSOFRACX="."_$G(PSOFRAC2) + S PSOFRAC=$S(PSOFRACX=".5":"ONE-HALF",PSOFRACX=".25":"ONE-FOURTH",PSOFRACX=".33":"ONE-THIRD",PSOFRACX=".34":"ONE-THIRD",PSOFRACX=".50":"ONE-HALF",PSOFRACX=".66":"TWO-THIRDS",PSOFRACX=".67":"TWO-THIRDS",PSOFRACX=".75":"THREE-FOURTHS",1:"") + I $G(PSOFRAC)="" K PSOFRAC G FRACQ + I $G(PSOFRAC1)'="",+$G(PSOFRAC1) D NUM S PSOFRAC=$G(PSOFRAC1)_" AND "_$G(PSOFRAC) +FRACQ K PSOFRAC1,PSOFRAC2 + Q +NUM ; + Q:$G(PSOFRAC1)="" + S PSOFRAC1=$S(PSOFRAC1="1":"ONE",PSOFRAC1="2":"TWO",PSOFRAC1="3":"THREE",PSOFRAC1="4":"FOUR",PSOFRAC1="5":"FIVE",PSOFRAC1="6":"SIX",PSOFRAC1="7":"SEVEN",PSOFRAC1="8":"EIGHT",PSOFRAC1="9":"NINE",PSOFRAC1="10":"TEN",1:PSOFRAC1) + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLSN.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLSN.m index f949c42e..1d5b58ed 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLSN.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLSN.m @@ -1,167 +1,161 @@ -PSOHLSN ;BIR/RTR-Send order information to OERR from file 52.41 ;10/10/94 - ;;7.0;OUTPATIENT PHARMACY;**1,7,15,24,27,30,55,46,98,88,121,292**;DEC 1997;Build 1 - ;Externel reference EN^ORERR supported by DBIA 2187 - ; - ; PS EVSEND OR PROTOCOL MUST BE OUR DRIVER RTN, (52 OR 52.41 INDICATOR - ; IS SENT THERE, THEN IT ROUTES, (NO NEED TO SEND FILE NUMBER HERE) -EN(PLACER,STAT,COMM,PSNOO) ; - N DA,FIELD,J,JJ,MSG,LIMIT,NULLFLDS,PSIEN,PSOHINST,PSZERO,SEGMENT,NAME,DFN,COUNT,GG,CC,CT,MM,PVAR,PVAR1,PLIM,SEG1,SUBCOUNT,PSOPSTRT,PSOPSTOP,PSODFN,EDUZ,PSNOOTX,PSOHSTAT,PSOPSIEN - S (PSIEN,PSOPSIEN)=$O(^PS(52.41,"B",PLACER,0)) - S COUNT=0 - ;I '$G(PSIEN) W !!,?5,"PROBLEM WITH ENTRY IN PENDING FILE!",! Q - I '$G(PSIEN) Q - I $G(STAT)="OC"!($G(STAT)="OD")!($G(STAT)="CR")!($G(STAT)="DR") D - .D CHKOLDRX - .I $D(^PS(52.41,PSIEN,0)) K ^PS(52.41,"AD",$P(^PS(52.41,PSIEN,0),"^",12),+$P($G(^("INI")),"^"),PSIEN),^PS(52.41,"ACL",+$P(^PS(52.41,PSIEN,0),"^",13),+$P(^(0),"^",12),PSIEN),^PS(52.41,"AQ",+$P($G(^PS(52.41,PSIEN,0)),"^",21),PSIEN) - S PSZERO=$G(^PS(52.41,PSIEN,0)),PSOHSTAT=$G(STAT) - S NULLFLDS="F JJ=0:1:LIMIT S FIELD(JJ)=""""" - D INIT - I $G(STAT)="Z@" S COUNT=1 D PID,PV1,ORC,SEND Q - S COUNT=1 D PID,PV1,ORC,RXE,ZRX,SEND,REN Q -INIT K ^UTILITY("DIQ1",$J),DIQ S DA=$P($$SITE^VASITE(),"^") I $G(DA) S DIC=4,DIQ(0)="I",DR="99" D EN^DIQ1 S PSOHINST=$G(^UTILITY("DIQ1",$J,4,DA,99,"I")) K ^UTILITY("DIQ1",$J),DA,DR,DIQ,DIC - S MSG(1)="MSH|^~\&|PHARMACY|"_$G(PSOHINST)_"|||||"_$S($G(PSOMSORR):"ORR",1:"ORM") - Q -PID S LIMIT=5 X NULLFLDS - S FIELD(0)="PID" - S DFN=+$P(PSZERO,"^",2) D DEM^VADPT S NAME=$G(VADM(1)) K VADM - S FIELD(3)=DFN - S FIELD(5)=NAME - D SEG Q -PV1 S LIMIT=19 X NULLFLDS - S FIELD(0)="PV1" - S FIELD(2)="O" - S:$P($G(^PS(52.41,PSIEN,0)),"^",13) FIELD(3)=$P(^(0),"^",13) - D SEG Q -ORC S LIMIT=15 X NULLFLDS - S FIELD(0)="ORC" - S FIELD(1)=STAT - S FIELD(2)=PLACER_$S($G(PLACERXX):";"_PLACERXX,1:"")_"^OR" - S FIELD(3)=PSIEN_"S"_"^PS" - I $G(FIELD(5))="" I $G(STAT)="OR"!($G(STAT)="OE") S FIELD(5)="IP" - S:$G(COMM)="IP" FIELD(5)="IP" - I $G(STAT)="SC" S FIELD(5)=$S($G(COMM)="IP":"IP",$G(COMM)="HD":"HD",$G(COMM)="DC":"DC",1:"") - I $G(PSORPV),$G(STAT)="OC" S FIELD(5)="RP" - ;S (PSOPSTRT,PSOPSTOP)="" S X=$P($G(^PS(52.41,PSIEN,0)),"^",6) I X S PSOPSTRT=$$FMTHL7^XLFDT(X) - ;I $G(STAT)="CR"!($G(STAT)="OC") D:'$G(DT) S X=DT S PSOPSTOP=$$FMTHL7^XLFDT(X) - ;.S DT=$$DT^XLFDT - ;K X S FIELD(7)="^^^"_$G(PSOPSTRT)_"^"_$G(PSOPSTOP) - S EDUZ=$P($G(^PS(52.41,PSIEN,0)),"^",4) I EDUZ D USER^PSOORFI2(EDUZ) S FIELD(10)=EDUZ_"^"_USER1 K USER1 - I $G(PSOCANRC),$G(PSOCANRN)'="" I $G(STAT)="OC"!($G(STAT)="OD") S FIELD(12)=$G(PSOCANRC)_"^"_$G(PSOCANRN) - I '$G(FIELD(12)) D USER^PSOORFI2($P(^PS(52.41,PSIEN,0),"^",5)) - I '$G(FIELD(12)) S FIELD(12)=$P(^PS(52.41,PSIEN,0),"^",5)_"^"_USER1 K USER1 - S FIELD(15)=$G(PSOPSTRT) - D SEG - I $G(COMM)'=""!($G(PSNOO)'="") D - .I $G(PSNOO)="" I $G(COMM)="IP"!($G(COMM)="HD")!($G(COMM)="DC") Q - .I $G(PSNOO)'="" D NOO^PSOHLSN1 - .I '$D(COMM) S COMM="" - .I $L($G(COMM))+($L(MSG(COUNT)))+($L($G(PSNOOTX)))+($S($G(PSNOO)'="":11,1:5))<245 S MSG(COUNT)=MSG(COUNT)_"|"_$G(PSNOO)_"^"_$G(PSNOOTX)_"^"_$S($G(PSNOO)'="":"99ORN",1:"")_"^^"_$S(COMM="IP"!(COMM="DC")!(COMM="HD"):"",1:$G(COMM))_"^" Q - .S MSG(COUNT,1)="|"_$G(PSNOO)_"^"_$G(PSNOOTX)_"^"_$S($G(PSNOO)'="":"99ORN",1:"")_"^^"_$S(COMM="IP"!(COMM="DC")!(COMM="HD"):"",1:$G(COMM))_"^" Q - Q -RXE S LIMIT=1 X NULLFLDS - S FIELD(0)="RXE" - S (PSOPSTRT,PSOPSTOP)="" S X=$P($G(^PS(52.41,PSIEN,0)),"^",6) I X S PSOPSTRT=$$FMTHL7^XLFDT(X) - I $G(STAT)="CR"!($G(STAT)="OC") D:'$G(DT) S X=DT S PSOPSTOP=$$FMTHL7^XLFDT(X) - .S DT=$$DT^XLFDT - K X S FIELD(1)="^^^"_$G(PSOPSTRT)_"^"_$G(PSOPSTOP) - D SEG Q - ; -ZRX ; - ;Only send if DC is from an external system - I $G(STAT)'="OC",$G(STAT)'="OD" Q - I '$G(PSOHUIOR)!('$G(PSOCANRC)) Q - I $P($G(^PS(52.41,PSIEN,"EXT")),"^")="" Q - S LIMIT=5 X NULLFLDS - S FIELD(0)="ZRX" - S FIELD(5)=PSOCANRC_"^"_$P($G(^VA(200,PSOCANRC,0)),"^")_"^"_"99NP" - D SEG - Q - ; -SEG S SEGMENT="" F J=0:1:LIMIT S SEGMENT=$S(SEGMENT="":FIELD(J),1:SEGMENT_"|"_FIELD(J)) - S COUNT=COUNT+1,MSG(COUNT)=SEGMENT - Q -SEND D MSG^XQOR("PS EVSEND OR",.MSG) - Q - ; -SEGPAR ;Parse out fields for sending segments to OERR that can be >245 - K PSOFIELD - S COUNT=COUNT+1,CT=1,(PVAR,PVAR1)="" - F MM=0:1:LIMIT S FIELD(MM)=$S(FIELD(MM)="":"|",1:FIELD(MM)_"|") - I $L(FIELD(LIMIT))>1 S FIELD(LIMIT)=$E(FIELD(LIMIT),1,($L(FIELD(LIMIT))-1)) - F MM=0:1:LIMIT S SEG1=FIELD(MM) F CC=1:1:$L(SEG1) D I $L(PVAR)=245 S PSOFIELD(CT)=PVAR,CT=CT+1,PVAR="" - .S PVAR1=$E(SEG1,CC) - .S PLIM=PVAR - .S PVAR=$S(PVAR="":PVAR1,1:PVAR_PVAR1) - I $G(PVAR)'="" S PSOFIELD(CT)=PVAR - S MSG(COUNT)=PSOFIELD(1),SUBCOUNT=1 F GG=2:1 Q:'$D(PSOFIELD(GG)) S MSG(COUNT,SUBCOUNT)=PSOFIELD(GG),SUBCOUNT=SUBCOUNT+1 - K PSOFIELD - Q -ERROR ;Builds error message from PSOHLNEW, usually means we can't find order - D EN^ORERR(COMM,.MSG) - N MSG,PSOHINST - S PSOMSORR=1 D INIT - S MSG(2)=$G(PSERRPID) - S MSG(3)=$G(PSERRPV1) - S MSG(4)="ORC|"_$S($G(STAT)'="":$G(STAT),1:"DE")_"|"_PLACER_$S($G(PLACERXX):";"_PLACERXX,1:"")_"^OR"_"|"_$S($P($G(PSERRORC),"|",4)'="":$P(PSERRORC,"|",4),1:"") - F EER=11,13 I $P($G(PSERRORC),"|",EER)'="" S $P(MSG(4),"|",EER)=$P($G(PSERRORC),"|",EER) - I $G(COMM)'="" S $P(MSG(4),"|",17)="^^^^"_$G(COMM) - D SEND K PSOMSORR Q - ; -RERROR ; - F EER=0:0 S EER=$O(MSG(EER)) Q:'EER S:$P(MSG(EER),"|")="PV1" PSERRPV1=MSG(EER) S:$P(MSG(EER),"|")="PID" PSERRPID=MSG(EER) S:$P(MSG(EER),"|")="ORC"&($G(PSERRORC)="") PSERRORC=MSG(EER) - N MSG - S PSOMSORR=1 D INIT - S MSG(2)=$G(PSERRPID),MSG(3)=$G(PSERRPV1) - S MSG(4)="ORC|"_$S($G(XOFLAGZ):"UX",1:"UA")_"|"_$G(PLACER)_$S($G(PLACERXX):";"_PLACERXX,1:"")_"^OR"_"|"_$S($P($G(PSERRORC),"|",4)'="":$P(PSERRORC,"|",4),1:"") - F EER=11,13 I $P($G(PSERRORC),"|",EER)'="" S $P(MSG(4),"|",EER)=$P($G(PSERRORC),"|",EER) - S $P(MSG(4),"|",17)="D^Duplicate^99ORN^^"_$S($G(XOFLAGZ):"Patient mismatch on previous order.",$G(NWFLAG):"Patient Mismatch on new CPRS order",$G(PSOXRP):"Patient mismatch on Renewal.",1:"Duplicate Renewal Request. Order rejected by Pharmacy.") - I $G(PSOCVI) S $P(MSG(4),"|",17)="D^Duplicate^99ORN^^Order mismatch on Renewal." - D SEND K PSOMSORR Q - ; -DCP ; - K ^PS(52.41,"AOR",+$G(DFN),+$P($G(^PS(52.41,+$G(PREV),"INI")),"^"),+$G(PREV)) S $P(^PS(52.41,+$G(PREV),0),"^",3)="DE" - S PSORPV=1 N PSOMSORR - D EN^PSOHLSN(+$P($G(^PS(52.41,+$G(PREV),0)),"^"),"OC","","A") - K PSORPV - Q -REN ;Update previous Rx on Cancel/Discontinue - N RPREV,RENOC,RENOCP,RENSTA,PSOMSORR - I $G(PSOHSTAT)'="OC",$G(PSOHSTAT)'="CR",$G(PSOHSTAT)'="DR",$G(PSOHSTAT)'="OD" Q - Q:'$D(^PS(52.41,+$G(PSOPSIEN),0)) - S RPREV=$P($G(^PS(52.41,+$G(PSOPSIEN),0)),"^",21) Q:'$G(RPREV)!('$D(^PSRX(+$G(RPREV),0))) - S RENSTA=$P($G(^PSRX(+$G(RPREV),"STA")),"^") Q:$G(RENSTA)="" - S RENOC="SC",RENOCP=$S(RENSTA=0:"CM",(RENSTA=1!(RENSTA=4)):"IP",(RENSTA=3!(RENSTA=16)):"HD",RENSTA=5:"ZS",RENSTA=11:"ZE",RENSTA=15:"RP",1:"DC") - D EN^PSOHLSN1(RPREV,RENOC,RENOCP,"","") - Q - ; -DELP ;Delete refill requests - I $G(PSODEATH) Q - N DA,PENDDA - S PENDDA=$P($G(^PSRX(+$G(PSRXIEN),"OR1")),"^",2) I 'PENDDA Q - S DA=$O(^PS(52.41,"B",PENDDA,0)) I '$G(DA) Q - I $P($G(^PS(52.41,DA,0)),"^",3)="RF" S DIK="^PS(52.41," D ^DIK K DIK - Q -SEGPARX ; - N PSOFIELD - S COUNT=COUNT+1,CT=1,(PVAR,PVAR1)="" - F MM=0:1:LIMIT I MM'=1 S FIELD(MM)=$S(FIELD(MM)="":"|",1:FIELD(MM)_"|") - F MM=0:0 S MM=$O(FIELD(1,MM)) I '$O(FIELD(1,MM)) S FIELD(1,MM)=$S(FIELD(1,MM)="":"|",1:FIELD(1,MM)_"|") Q - I $L(FIELD(LIMIT))>1 S FIELD(LIMIT)=$E(FIELD(LIMIT),1,($L(FIELD(LIMIT))-1)) - F MM=0:1:LIMIT S SEG1=FIELD(MM) D:MM=1 SEGXX I MM'=1 F CC=1:1:$L(SEG1) D I $L(PVAR)=245 S PSOFIELD(CT)=PVAR,CT=CT+1,PVAR="" - .S PVAR1=$E(SEG1,CC) - .S PLIM=PVAR - .S PVAR=$S(PVAR="":PVAR1,1:PVAR_PVAR1) - I $G(PVAR)'="" S PSOFIELD(CT)=PVAR - S MSG(COUNT)=PSOFIELD(1),SUBCOUNT=1 F GG=2:1 Q:'$D(PSOFIELD(GG)) S MSG(COUNT,SUBCOUNT)=PSOFIELD(GG),SUBCOUNT=SUBCOUNT+1 - Q -SEGXX ; - N MMZ F MMZ=0:0 S MMZ=$O(FIELD(MM,MMZ)) Q:'MMZ S SEG1=FIELD(MM,MMZ) F CC=1:1:$L(SEG1) D I $L(PVAR)=245 S PSOFIELD(CT)=PVAR,CT=CT+1,PVAR="" - .S PVAR1=$E(SEG1,CC) - .S PLIM=PVAR - .S PVAR=$S(PVAR="":PVAR1,1:PVAR_PVAR1) - Q -CHKOLDRX ; when dc a pending renewal - if prior Rx is expired, set piece 19 to 1 so will update CPRS from 'renewed' to 'expired' in PSOHLSN1 - N PSOOLD - S PSOOLD=$P($G(^PS(52.41,PSIEN,0)),"^",21) - I PSOOLD'="",$P($G(^PSRX(PSOOLD,"STA")),"^")=11 S $P(^PSRX(PSOOLD,0),"^",19)=1 - Q +PSOHLSN ;BIR/RTR-Send order information to OERR from file 52.41 ;10/10/94 + ;;7.0;OUTPATIENT PHARMACY;**1,7,15,24,27,30,55,46,98,88,121**;DEC 1997 + ;Externel reference EN^ORERR supported by DBIA 2187 + ; + ; PS EVSEND OR PROTOCOL MUST BE OUR DRIVER RTN, (52 OR 52.41 INDICATOR + ; IS SENT THERE, THEN IT ROUTES, (NO NEED TO SEND FILE NUMBER HERE) +EN(PLACER,STAT,COMM,PSNOO) ; + N DA,FIELD,J,JJ,MSG,LIMIT,NULLFLDS,PSIEN,PSOHINST,PSZERO,SEGMENT,NAME,DFN,COUNT,GG,CC,CT,MM,PVAR,PVAR1,PLIM,SEG1,SUBCOUNT,PSOPSTRT,PSOPSTOP,PSODFN,EDUZ,PSNOOTX,PSOHSTAT,PSOPSIEN + S (PSIEN,PSOPSIEN)=$O(^PS(52.41,"B",PLACER,0)) + S COUNT=0 + ;I '$G(PSIEN) W !!,?5,"PROBLEM WITH ENTRY IN PENDING FILE!",! Q + I '$G(PSIEN) Q + I $G(STAT)="OC"!($G(STAT)="OD")!($G(STAT)="CR")!($G(STAT)="DR") D + .I $D(^PS(52.41,PSIEN,0)) K ^PS(52.41,"AD",$P(^PS(52.41,PSIEN,0),"^",12),+$P($G(^("INI")),"^"),PSIEN),^PS(52.41,"ACL",+$P(^PS(52.41,PSIEN,0),"^",13),+$P(^(0),"^",12),PSIEN),^PS(52.41,"AQ",+$P($G(^PS(52.41,PSIEN,0)),"^",21),PSIEN) + S PSZERO=$G(^PS(52.41,PSIEN,0)),PSOHSTAT=$G(STAT) + S NULLFLDS="F JJ=0:1:LIMIT S FIELD(JJ)=""""" + D INIT + I $G(STAT)="Z@" S COUNT=1 D PID,PV1,ORC,SEND Q + S COUNT=1 D PID,PV1,ORC,RXE,ZRX,SEND,REN Q +INIT K ^UTILITY("DIQ1",$J),DIQ S DA=$P($$SITE^VASITE(),"^") I $G(DA) S DIC=4,DIQ(0)="I",DR="99" D EN^DIQ1 S PSOHINST=$G(^UTILITY("DIQ1",$J,4,DA,99,"I")) K ^UTILITY("DIQ1",$J),DA,DR,DIQ,DIC + S MSG(1)="MSH|^~\&|PHARMACY|"_$G(PSOHINST)_"|||||"_$S($G(PSOMSORR):"ORR",1:"ORM") + Q +PID S LIMIT=5 X NULLFLDS + S FIELD(0)="PID" + S DFN=+$P(PSZERO,"^",2) D DEM^VADPT S NAME=$G(VADM(1)) K VADM + S FIELD(3)=DFN + S FIELD(5)=NAME + D SEG Q +PV1 S LIMIT=19 X NULLFLDS + S FIELD(0)="PV1" + S FIELD(2)="O" + S:$P($G(^PS(52.41,PSIEN,0)),"^",13) FIELD(3)=$P(^(0),"^",13) + D SEG Q +ORC S LIMIT=15 X NULLFLDS + S FIELD(0)="ORC" + S FIELD(1)=STAT + S FIELD(2)=PLACER_$S($G(PLACERXX):";"_PLACERXX,1:"")_"^OR" + S FIELD(3)=PSIEN_"S"_"^PS" + I $G(FIELD(5))="" I $G(STAT)="OR"!($G(STAT)="OE") S FIELD(5)="IP" + S:$G(COMM)="IP" FIELD(5)="IP" + I $G(STAT)="SC" S FIELD(5)=$S($G(COMM)="IP":"IP",$G(COMM)="HD":"HD",$G(COMM)="DC":"DC",1:"") + I $G(PSORPV),$G(STAT)="OC" S FIELD(5)="RP" + ;S (PSOPSTRT,PSOPSTOP)="" S X=$P($G(^PS(52.41,PSIEN,0)),"^",6) I X S PSOPSTRT=$$FMTHL7^XLFDT(X) + ;I $G(STAT)="CR"!($G(STAT)="OC") D:'$G(DT) S X=DT S PSOPSTOP=$$FMTHL7^XLFDT(X) + ;.S DT=$$DT^XLFDT + ;K X S FIELD(7)="^^^"_$G(PSOPSTRT)_"^"_$G(PSOPSTOP) + S EDUZ=$P($G(^PS(52.41,PSIEN,0)),"^",4) I EDUZ D USER^PSOORFI2(EDUZ) S FIELD(10)=EDUZ_"^"_USER1 K USER1 + I $G(PSOCANRC),$G(PSOCANRN)'="" I $G(STAT)="OC"!($G(STAT)="OD") S FIELD(12)=$G(PSOCANRC)_"^"_$G(PSOCANRN) + I '$G(FIELD(12)) D USER^PSOORFI2($P(^PS(52.41,PSIEN,0),"^",5)) + I '$G(FIELD(12)) S FIELD(12)=$P(^PS(52.41,PSIEN,0),"^",5)_"^"_USER1 K USER1 + S FIELD(15)=$G(PSOPSTRT) + D SEG + I $G(COMM)'=""!($G(PSNOO)'="") D + .I $G(PSNOO)="" I $G(COMM)="IP"!($G(COMM)="HD")!($G(COMM)="DC") Q + .I $G(PSNOO)'="" D NOO^PSOHLSN1 + .I '$D(COMM) S COMM="" + .I $L($G(COMM))+($L(MSG(COUNT)))+($L($G(PSNOOTX)))+($S($G(PSNOO)'="":11,1:5))<245 S MSG(COUNT)=MSG(COUNT)_"|"_$G(PSNOO)_"^"_$G(PSNOOTX)_"^"_$S($G(PSNOO)'="":"99ORN",1:"")_"^^"_$S(COMM="IP"!(COMM="DC")!(COMM="HD"):"",1:$G(COMM))_"^" Q + .S MSG(COUNT,1)="|"_$G(PSNOO)_"^"_$G(PSNOOTX)_"^"_$S($G(PSNOO)'="":"99ORN",1:"")_"^^"_$S(COMM="IP"!(COMM="DC")!(COMM="HD"):"",1:$G(COMM))_"^" Q + Q +RXE S LIMIT=1 X NULLFLDS + S FIELD(0)="RXE" + S (PSOPSTRT,PSOPSTOP)="" S X=$P($G(^PS(52.41,PSIEN,0)),"^",6) I X S PSOPSTRT=$$FMTHL7^XLFDT(X) + I $G(STAT)="CR"!($G(STAT)="OC") D:'$G(DT) S X=DT S PSOPSTOP=$$FMTHL7^XLFDT(X) + .S DT=$$DT^XLFDT + K X S FIELD(1)="^^^"_$G(PSOPSTRT)_"^"_$G(PSOPSTOP) + D SEG Q + ; +ZRX ; + ;Only send if DC is from an external system + I $G(STAT)'="OC",$G(STAT)'="OD" Q + I '$G(PSOHUIOR)!('$G(PSOCANRC)) Q + I $P($G(^PS(52.41,PSIEN,"EXT")),"^")="" Q + S LIMIT=5 X NULLFLDS + S FIELD(0)="ZRX" + S FIELD(5)=PSOCANRC_"^"_$P($G(^VA(200,PSOCANRC,0)),"^")_"^"_"99NP" + D SEG + Q + ; +SEG S SEGMENT="" F J=0:1:LIMIT S SEGMENT=$S(SEGMENT="":FIELD(J),1:SEGMENT_"|"_FIELD(J)) + S COUNT=COUNT+1,MSG(COUNT)=SEGMENT + Q +SEND D MSG^XQOR("PS EVSEND OR",.MSG) + Q + ; +SEGPAR ;Parse out fields for sending segments to OERR that can be >245 + K PSOFIELD + S COUNT=COUNT+1,CT=1,(PVAR,PVAR1)="" + F MM=0:1:LIMIT S FIELD(MM)=$S(FIELD(MM)="":"|",1:FIELD(MM)_"|") + I $L(FIELD(LIMIT))>1 S FIELD(LIMIT)=$E(FIELD(LIMIT),1,($L(FIELD(LIMIT))-1)) + F MM=0:1:LIMIT S SEG1=FIELD(MM) F CC=1:1:$L(SEG1) D I $L(PVAR)=245 S PSOFIELD(CT)=PVAR,CT=CT+1,PVAR="" + .S PVAR1=$E(SEG1,CC) + .S PLIM=PVAR + .S PVAR=$S(PVAR="":PVAR1,1:PVAR_PVAR1) + I $G(PVAR)'="" S PSOFIELD(CT)=PVAR + S MSG(COUNT)=PSOFIELD(1),SUBCOUNT=1 F GG=2:1 Q:'$D(PSOFIELD(GG)) S MSG(COUNT,SUBCOUNT)=PSOFIELD(GG),SUBCOUNT=SUBCOUNT+1 + K PSOFIELD + Q +ERROR ;Builds error message from PSOHLNEW, usually means we can't find order + D EN^ORERR(COMM,.MSG) + N MSG,PSOHINST + S PSOMSORR=1 D INIT + S MSG(2)=$G(PSERRPID) + S MSG(3)=$G(PSERRPV1) + S MSG(4)="ORC|"_$S($G(STAT)'="":$G(STAT),1:"DE")_"|"_PLACER_$S($G(PLACERXX):";"_PLACERXX,1:"")_"^OR"_"|"_$S($P($G(PSERRORC),"|",4)'="":$P(PSERRORC,"|",4),1:"") + F EER=11,13 I $P($G(PSERRORC),"|",EER)'="" S $P(MSG(4),"|",EER)=$P($G(PSERRORC),"|",EER) + I $G(COMM)'="" S $P(MSG(4),"|",17)="^^^^"_$G(COMM) + D SEND K PSOMSORR Q + ; +RERROR ; + F EER=0:0 S EER=$O(MSG(EER)) Q:'EER S:$P(MSG(EER),"|")="PV1" PSERRPV1=MSG(EER) S:$P(MSG(EER),"|")="PID" PSERRPID=MSG(EER) S:$P(MSG(EER),"|")="ORC"&($G(PSERRORC)="") PSERRORC=MSG(EER) + N MSG + S PSOMSORR=1 D INIT + S MSG(2)=$G(PSERRPID),MSG(3)=$G(PSERRPV1) + S MSG(4)="ORC|"_$S($G(XOFLAGZ):"UX",1:"UA")_"|"_$G(PLACER)_$S($G(PLACERXX):";"_PLACERXX,1:"")_"^OR"_"|"_$S($P($G(PSERRORC),"|",4)'="":$P(PSERRORC,"|",4),1:"") + F EER=11,13 I $P($G(PSERRORC),"|",EER)'="" S $P(MSG(4),"|",EER)=$P($G(PSERRORC),"|",EER) + S $P(MSG(4),"|",17)="D^Duplicate^99ORN^^"_$S($G(XOFLAGZ):"Patient mismatch on previous order.",$G(NWFLAG):"Patient Mismatch on new CPRS order",$G(PSOXRP):"Patient mismatch on Renewal.",1:"Duplicate Renewal Request. Order rejected by Pharmacy.") + I $G(PSOCVI) S $P(MSG(4),"|",17)="D^Duplicate^99ORN^^Order mismatch on Renewal." + D SEND K PSOMSORR Q + ; +DCP ; + K ^PS(52.41,"AOR",+$G(DFN),+$P($G(^PS(52.41,+$G(PREV),"INI")),"^"),+$G(PREV)) S $P(^PS(52.41,+$G(PREV),0),"^",3)="DE" + S PSORPV=1 N PSOMSORR + D EN^PSOHLSN(+$P($G(^PS(52.41,+$G(PREV),0)),"^"),"OC","","A") + K PSORPV + Q +REN ;Update previous Rx on Cancel/Discontinue + N RPREV,RENOC,RENOCP,RENSTA,PSOMSORR + I $G(PSOHSTAT)'="OC",$G(PSOHSTAT)'="CR",$G(PSOHSTAT)'="DR",$G(PSOHSTAT)'="OD" Q + Q:'$D(^PS(52.41,+$G(PSOPSIEN),0)) + S RPREV=$P($G(^PS(52.41,+$G(PSOPSIEN),0)),"^",21) Q:'$G(RPREV)!('$D(^PSRX(+$G(RPREV),0))) + S RENSTA=$P($G(^PSRX(+$G(RPREV),"STA")),"^") Q:$G(RENSTA)="" + S RENOC="SC",RENOCP=$S(RENSTA=0:"CM",(RENSTA=1!(RENSTA=4)):"IP",(RENSTA=3!(RENSTA=16)):"HD",RENSTA=5:"ZS",RENSTA=11:"ZE",RENSTA=15:"RP",1:"DC") + D EN^PSOHLSN1(RPREV,RENOC,RENOCP,"","") + Q + ; +DELP ;Delete refill requests + I $G(PSODEATH) Q + N DA,PENDDA + S PENDDA=$P($G(^PSRX(+$G(PSRXIEN),"OR1")),"^",2) I 'PENDDA Q + S DA=$O(^PS(52.41,"B",PENDDA,0)) I '$G(DA) Q + I $P($G(^PS(52.41,DA,0)),"^",3)="RF" S DIK="^PS(52.41," D ^DIK K DIK + Q +SEGPARX ; + N PSOFIELD + S COUNT=COUNT+1,CT=1,(PVAR,PVAR1)="" + F MM=0:1:LIMIT I MM'=1 S FIELD(MM)=$S(FIELD(MM)="":"|",1:FIELD(MM)_"|") + F MM=0:0 S MM=$O(FIELD(1,MM)) I '$O(FIELD(1,MM)) S FIELD(1,MM)=$S(FIELD(1,MM)="":"|",1:FIELD(1,MM)_"|") Q + I $L(FIELD(LIMIT))>1 S FIELD(LIMIT)=$E(FIELD(LIMIT),1,($L(FIELD(LIMIT))-1)) + F MM=0:1:LIMIT S SEG1=FIELD(MM) D:MM=1 SEGXX I MM'=1 F CC=1:1:$L(SEG1) D I $L(PVAR)=245 S PSOFIELD(CT)=PVAR,CT=CT+1,PVAR="" + .S PVAR1=$E(SEG1,CC) + .S PLIM=PVAR + .S PVAR=$S(PVAR="":PVAR1,1:PVAR_PVAR1) + I $G(PVAR)'="" S PSOFIELD(CT)=PVAR + S MSG(COUNT)=PSOFIELD(1),SUBCOUNT=1 F GG=2:1 Q:'$D(PSOFIELD(GG)) S MSG(COUNT,SUBCOUNT)=PSOFIELD(GG),SUBCOUNT=SUBCOUNT+1 + Q +SEGXX ; + N MMZ F MMZ=0:0 S MMZ=$O(FIELD(MM,MMZ)) Q:'MMZ S SEG1=FIELD(MM,MMZ) F CC=1:1:$L(SEG1) D I $L(PVAR)=245 S PSOFIELD(CT)=PVAR,CT=CT+1,PVAR="" + .S PVAR1=$E(SEG1,CC) + .S PLIM=PVAR + .S PVAR=$S(PVAR="":PVAR1,1:PVAR_PVAR1) + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLSN1.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLSN1.m index cd778f79..75fa2ff2 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLSN1.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLSN1.m @@ -1,159 +1,176 @@ -PSOHLSN1 ;BIR/RTR - Send order info to OERR from file 52 ;10/10/94 - ;;7.0;OUTPATIENT PHARMACY;**1,10,24,27,55,46,71,101,99,121,139,157,181,143,235,239,292,225**;DEC 1997;Build 29 - ;Ref #50.606-DBIA 2174 - ;#50.607-2221 - ;#50.7-2223 - ;#51.2-2226 - ;#50-221 - ;PSNDF-2195 - ;EN^PSSUTIL1-3179 - ; -EN(PSRXIEN,STAT,PSSTAT,COMM,PSNOO) ; - N COUNT,DFN,J,LIMIT,NAME,NULLFLDS,PSDIEN,PSFLAG,PSND1,PSND2,PSND3,PRODUCT,UNIT,POIPTR,PSOHINST,PODOSE,PODOSENM,PSROUTE,RTNAME,SEGMENT,CCC,BBB,CSCOUNT,PPTR,MSG,PSOHSTRT,PSOHSTOP,PSOHISSD,PSORTLP,ZRXFLAG,RXE2FLAG,RXE2ONLY,PSODFN,EDUZ - N PSOCDDUZ,DA,FSIG,BSIG,PSHRX,PSHORX,PSNOOTX,ZPRE,PSOZSTAT,CCCX,PSOCPS,PSOICD - K FIELD - I $G(STAT)="" Q - I STAT="CR"!(STAT="DR")!(STAT="HR")!(STAT="OC")!(STAT="OD")!(STAT="OH")!(STAT="Z@")!(STAT="RP") S PSOZSTAT=STAT D DELP^PSOHLSN S STAT=PSOZSTAT G SKIP - I STAT="SC" I $G(PSSTAT)="ZE"!($G(PSSTAT)="HD")!($G(PSSTAT)="DC") S PSOZSTAT=STAT D DELP^PSOHLSN S STAT=PSOZSTAT -SKIP ; - I $G(STAT)="SC",$G(PSSTAT)="ZE",$P($G(^PSRX(+$G(PSRXIEN),0)),"^",19)=2 Q - I $G(STAT)="RP" S STAT="OD",PSSTAT="RP" - S COUNT=0,NULLFLDS="F JJ=0:1:LIMIT S FIELD(JJ)=""""" - I '$D(^PSRX(PSRXIEN,0)) Q - I ($G(STAT)="SC"&($G(PSSTAT)="ZE"))!($G(STAT)="OC")!($G(STAT)="OD") I $D(^PS(52.41,"AQ",PSRXIEN)) D EN^PSOHDR("PRES",PSRXIEN) Q - I STAT'="SN",STAT'="ZC",'$P($G(^PSRX(PSRXIEN,"OR1")),"^",2) Q - I $G(STAT)="SC",$G(PSSTAT)="ZE" S $P(^PSRX(PSRXIEN,0),"^",19)=2 - D INIT - S COUNT=1,(ZRXFLAG,RXE2FLAG,RXE2ONLY)=0 D PID,PV1,ORC - I $G(STAT)="Z@" G NCM - I $G(STAT)="OK"!($G(STAT)="SN")!($G(STAT)="ZC")!($G(STAT)="XX")!($G(STAT)="SC")!($G(STAT)="RO") D RXO,RXE,RXR,ZRX,DG1,ZSC,ZCL G NCM - I $G(STAT)="SC",$G(PSSTAT)="CM" D RXO,RXE,RXR,ZRX,DG1,ZSC,ZCL - I '$G(RXE2FLAG) S RXE2ONLY=1 D RXE,SEGPARX^PSOHLSN - I '$G(ZRXFLAG) D ZRX -NCM D SEND - K PSRXIEN Q -INIT K ^UTILITY("DIQ1",$J),DIQ S DA=$P($$SITE^VASITE(),"^") I $G(DA) S DIC=4,DIQ(0)="I",DR="99" D EN^DIQ1 S PSOHINST=$G(^UTILITY("DIQ1",$J,4,DA,99,"I")) K ^UTILITY("DIQ1",$J),DA,DR,DIQ,DIC - S MSG(1)="MSH|^~\&|PHARMACY|"_$G(PSOHINST)_"|||||"_$S($G(PSOMSORR):"ORR",1:"ORM") - Q -PID S LIMIT=5 X NULLFLDS - S DFN=+$P(^PSRX(PSRXIEN,0),"^",2) D DEM^VADPT S NAME=$G(VADM(1)) K VADM - S FIELD(0)="PID" - S FIELD(3)=DFN - S FIELD(5)=NAME - D SEG Q -DG1 D DG1^PSOHLSN2 - Q -PV1 ; - S LIMIT=19 X NULLFLDS - S FIELD(0)="PV1" - S FIELD(2)="O" - S:$P(^PSRX(PSRXIEN,0),"^",5) FIELD(3)=$P(^(0),"^",5) - D SEG Q -ORC ; - D ORC^PSOHLSN3 - Q - ; -RXO ; - S LIMIT=1 X NULLFLDS - S FIELD(0)="RXO" - S PPTR=+$P($G(^PSRX(PSRXIEN,"OR1")),"^") - S FIELD(1)=$S('PPTR:"^^^^^",1:"^^^"_PPTR_"^"_$P($G(^PS(50.7,PPTR,0)),"^")_" "_$P($G(^PS(50.606,+$P($G(^(0)),"^",2),0)),"^")_"^99PSP") - D SEG Q - ; -RXE ; - S RXE2FLAG=1 - S LIMIT=$S('$G(RXE2ONLY):26,1:2) X NULLFLDS - S FIELD(0)="RXE" - S (PSOHSTRT,PSOHSTOP)="" S X=$P($G(^PSRX(PSRXIEN,2)),"^",2) I X S PSOHSTRT=$$FMTHL7^XLFDT(X) - I '$G(DT) S DT=$$DT^XLFDT - S X=$S($P($G(^PSRX(PSRXIEN,3)),"^",5):$P($G(^(3)),"^",5),$G(STAT)="OD"!($G(STAT)="OC"):$G(DT),$P($G(^(2)),"^",6):$P($G(^(2)),"^",6),1:$G(DT)) I X S PSOHSTOP=$$FMTHL7^XLFDT(X) - K X N PSOMZT,MMZZ,MMZZT S MMZZT=1 F MMZZ=0:0 S MMZZ=$O(^PSRX(PSRXIEN,6,MMZZ)) Q:'MMZZ D:$D(^(MMZZ,0)) - .S FIELD(1,MMZZT)=$S($P($G(^PSRX(PSRXIEN,6,MMZZ,0)),"^",2):$$ESC^ORHLESC($P($G(^(0)),"^"))_"\T\"_$P($G(^PS(50.607,+$P($G(^(0)),"^",3),0)),"^")_"\T\"_$P($G(^PSRX(PSRXIEN,6,MMZZ,0)),"^",2)_"\T\"_$P($G(^(0)),"^",4),1:"") - .S FIELD(1,MMZZT)=FIELD(1,MMZZT)_"^"_$$ESC^ORHLESC($P($G(^PSRX(PSRXIEN,6,MMZZ,0)),"^",8)) - .I $P($G(FIELD(1,MMZZT)),"^")'="" F PSOMZT=1,3 I $E($P(FIELD(1,MMZZT),"\T\",PSOMZT),1)="." S $P(FIELD(1,MMZZT),"\T\",PSOMZT)="0"_$P(FIELD(1,MMZZT),"\T\",PSOMZT) - .S FIELD(1,MMZZT)=$G(FIELD(1,MMZZT))_"^"_$$DUR(PSRXIEN,MMZZ)_"^^^^^"_$S($P($G(FIELD(1,MMZZT)),"^")'="":$P($G(FIELD(1,MMZZT)),"\T\")_$P($G(FIELD(1,MMZZT)),"\T\",2),1:$P($G(^PSRX(PSRXIEN,6,MMZZ,0)),"^")) - .S FIELD(1,MMZZT)=$G(FIELD(1,MMZZT))_"^"_$P($G(^PSRX(PSRXIEN,6,MMZZ,0)),"^",6) - .I $O(^PSRX(PSRXIEN,6,MMZZ)) S FIELD(1,MMZZT)=$G(FIELD(1,MMZZT))_"~" - .S MMZZT=MMZZT+1 - S $P(FIELD(1,1),"^",4)=$G(PSOHSTRT),$P(FIELD(1,1),"^",5)=$G(PSOHSTOP) - S PSFLAG=0,PSDIEN=+$P(^PSRX(PSRXIEN,0),"^",6),PSND1=$P($G(^PSDRUG(PSDIEN,"ND")),"^"),PSND2=$P($G(^("ND")),"^",2),PSND3=$P($G(^("ND")),"^",3) I PSND1,PSND3 S PSFLAG=1 - S FIELD(2)=$S(PSFLAG:PSND1_"."_PSND3_"^"_$$ESC^ORHLESC(PSND2)_"^"_"99NDF",1:"^^")_"^"_PSDIEN_"^"_$$ESC^ORHLESC($P($G(^PSDRUG(PSDIEN,0)),"^"))_"^"_"99PSD" - Q:$G(RXE2ONLY) - I PSFLAG D - .I $T(^PSNAPIS)]"" S PSOXN=$$DFSU^PSNAPIS(PSND1,PSND3) S FIELD(5)="^^^"_$P($G(PSOXN),"^",5)_"^"_$$ESC^ORHLESC($P($G(PSOXN),"^",6))_"^"_"99PSU" K PSOXN Q - .S PRODUCT=$G(^PSNDF(PSND1,5,PSND3,0)) S UNIT=$P($G(^PSNDF(PSND1,2,+$P(PRODUCT,"^",2),3,+$P(PRODUCT,"^",3),4,+$P(PRODUCT,"^",4),0)),"^") - .S FIELD(5)="^^^"_UNIT_"^"_$$ESC^ORHLESC($P($G(^PS(50.607,+UNIT,0)),"^"))_"^"_"99PSU" - S POIPTR=$P($G(^PSRX(PSRXIEN,"OR1")),"^") I POIPTR S PODOSE=$P($G(^PS(50.7,POIPTR,0)),"^",2),PODOSENM=$P($G(^PS(50.606,+PODOSE,0)),"^") - I POIPTR S FIELD(6)="^^^"_$G(PODOSE)_"^"_$$ESC^ORHLESC($G(PODOSENM))_"^"_"99PSF" - S FIELD(10)=$P(^PSRX(PSRXIEN,0),"^",7) - S FIELD(12)=$P(^PSRX(PSRXIEN,0),"^",9) - S FIELD(14)=$P(^PSRX(PSRXIEN,0),"^",4) - S FIELD(15)=$P(^PSRX(PSRXIEN,0),"^") - S FIELD(22)=$P(^PSRX(PSRXIEN,0),"^",8) - K MMZZ S MMZZ=$$EN^PSSUTIL1(PSDIEN) S FIELD(25)=$S($E($P(MMZZ,"|"),1)=".":"0",1:"")_$P(MMZZ,"|"),FIELD(26)=$P(MMZZ,"|",2) - N PLIM,PVAR,PVAR1,SUBCOUNT D SEGPARX^PSOHLSN - ; - I $O(^PSRX(PSRXIEN,"PRC",0)) D - .S COUNT=COUNT+1,CCC=$O(^PSRX(PSRXIEN,"PRC",0)) - .S MSG(COUNT)="NTE|6||"_$$ESC^ORHLESC($G(^PSRX(PSRXIEN,"PRC",CCC,0))) - .S CSCOUNT=1 F CCC=CCC:0 S CCC=$O(^PSRX(PSRXIEN,"PRC",CCC)) Q:'CCC S MSG(COUNT,CSCOUNT)=$$ESC^ORHLESC($G(^PSRX(PSRXIEN,"PRC",CCC,0))),CSCOUNT=CSCOUNT+1 - I $O(^PSRX(PSRXIEN,"INS1",0)) D - .S COUNT=COUNT+1,CCC=$O(^PSRX(PSRXIEN,"INS1",0)) - .S MSG(COUNT)="NTE|7|L|"_$$ESC^ORHLESC($G(^PSRX(PSRXIEN,"INS1",CCC,0))) - .S CCCX=1 F S CCC=$O(^PSRX(PSRXIEN,"INS1",CCC)) Q:'CCC I $D(^PSRX(PSRXIEN,"INS1",CCC,0)) S MSG(COUNT,CCCX)=$$ESC^ORHLESC($G(^(0))) S CCCX=CCCX+1 - S COUNT=COUNT+1 - I $P($G(^PSRX(PSRXIEN,"SIG")),"^",2) D Q - .D FSIG^PSOUTLA("R",PSRXIEN,238) S MSG(COUNT)="NTE|21||"_$S($G(FSIG(1))'="":$$ESC^ORHLESC($G(FSIG(1))),1:"No SIG available") I $O(FSIG(1)) F CCC=1:0 S CCC=$O(FSIG(CCC)) Q:'CCC S MSG(COUNT,(CCC-1))=$$ESC^ORHLESC($G(FSIG(CCC))) - I '$P($G(^PSRX(PSRXIEN,"SIG")),"^",2) D Q - .D EN3^PSOUTLA1(PSRXIEN,238) S MSG(COUNT)="NTE|21||"_$S($G(BSIG(1))'="":$$ESC^ORHLESC($G(BSIG(1))),1:"No SIG available") I $O(BSIG(1)) F CCC=1:0 S CCC=$O(BSIG(CCC)) Q:'CCC S MSG(COUNT,(CCC-1))=$$ESC^ORHLESC($G(BSIG(CCC))) - Q - ; -RXR ; - F PSORTLP=0:0 S PSORTLP=$O(^PSRX(PSRXIEN,6,PSORTLP)) Q:'PSORTLP D - .S LIMIT=1 X NULLFLDS - .S FIELD(0)="RXR" - .S PSROUTE=$P($G(^PSRX(PSRXIEN,6,PSORTLP,0)),"^",7) I PSROUTE,$D(^PS(51.2,PSROUTE,0)) S RTNAME=$P(^PS(51.2,PSROUTE,0),"^") - .S FIELD(1)="^^^"_$G(PSROUTE)_"^"_$G(RTNAME)_"^"_"99PSR" - .D SEG - Q - ; -ZCL D ZCL^PSOHLSN2 - Q -ZSC D ZSC^PSOHLSN2 - Q - ; -ZRX ; - S ZRXFLAG=1 - S LIMIT=6 X NULLFLDS - S FIELD(0)="ZRX" - S ZPRE=$P($G(^PSRX(PSRXIEN,"OR1")),"^",3) I ZPRE S FIELD(1)=$P($G(^PSRX(ZPRE,"OR1")),"^",2) - I '$G(FIELD(1)),$G(PSORDEDT) S FIELD(1)=$P($G(^PS(52.41,$G(PSORDEDT),0)),"^") - S FIELD(2)=$G(PSNOO) - I $G(STAT)="SN"!($G(STAT)="RO") S FIELD(3)=$S($G(STAT)="RO"!($G(PSOEDIT)):"E",$G(PSOOPT)=3:"R",1:"N") - S FIELD(4)=$P(^PSRX(PSRXIEN,0),"^",11) - S PSOCDDUZ=$S($G(PSOROPCH)="PATCH":$P($G(^PSRX(PSRXIEN,"OR1")),"^",5),$G(PSOHUIOR)&($P($G(^PSRX(PSRXIEN,"EXT")),"^")'=""):+$G(PSOCANRC),1:$G(DUZ)) - I $G(PSOCDDUZ) S FIELD(5)=PSOCDDUZ_"^"_$P($G(^VA(200,PSOCDDUZ,0)),"^")_"^"_"99NP" - I $G(STAT)="ZD",$G(PSODISPP) S FIELD(6)="P" - D SEG Q -SEG S SEGMENT="" F J=0:1:LIMIT S SEGMENT=$S(SEGMENT="":FIELD(J),1:SEGMENT_"|"_FIELD(J)) - S COUNT=COUNT+1,MSG(COUNT)=SEGMENT - Q -SEND D:$G(PSRXIEN)&($T(EN^PSOHDR)]"")&($G(PSOSSMES)'="CPRSUP") K FIELD D MSG^XQOR("PS EVSEND OR",.MSG) Q - .I $G(STAT)="ZC"!($G(STAT)="UC")!($G(STAT)="UD")!($G(STAT)="UH")!($G(STAT)="UR")!($G(STAT)="DE")!($G(STAT)="ZD")!($G(STAT)="SN")!($G(STAT)="Z@") Q - .I $G(STAT)="SC",$G(PSSTAT)="ZZ" Q - .D EN^PSOHDR("PRES",PSRXIEN) - ; -NOO ; - I $G(PSNOO)="" S PSNOOTX="" Q - S PSNOOTX=$S(PSNOO="W":"Written",PSNOO="V":"Verbal",PSNOO="P":"Telephoned",PSNOO="S":"Service Correction",PSNOO="X":"Rejected",PSNOO="D":"Duplicate",PSNOO="I":"Policy",PSNOO="E":"Physician Entered",PSNOO="A":"Auto DC",1:"") Q - Q - ; -DUR(PSODX1,PSODX2) ; - N PSODX,PSODX4,PSODX5,PSODX6,PSODX7 S PSODX=$P($G(^PSRX(PSODX1,6,PSODX2,0)),"^",5) - I 'PSODX Q PSODX - S PSODX4=$L(PSODX),PSODX5=$E(PSODX,PSODX4) - S PSODX=$S(PSODX5?1A:PSODX,1:PSODX_"D") - S PSODX6=$L(PSODX) - S PSODX7=$E(PSODX,PSODX6)_$E(PSODX,1,(PSODX6-1)) - Q PSODX7 - Q +PSOHLSN1 ;BIR/RTR - Send order info to OERR from file 52 ;10/10/94 + ;;7.0;OUTPATIENT PHARMACY;**1,10,24,27,55,46,71,101,99,121,139,157,181,143,235,239**;DEC 1997 + ;Ref #50.606-DBIA 2174 + ;#50.607-2221 + ;#50.7-2223 + ;#51.2-2226 + ;#50-221 + ;PSNDF-2195 + ;EN^PSSUTIL1-3179 + ; +EN(PSRXIEN,STAT,PSSTAT,COMM,PSNOO) ; + N COUNT,DFN,J,LIMIT,NAME,NULLFLDS,PSDIEN,PSFLAG,PSND1,PSND2,PSND3,PRODUCT,UNIT,POIPTR,PSOHINST,PODOSE,PODOSENM,PSROUTE,RTNAME,SEGMENT,CCC,BBB,CSCOUNT,PPTR,MSG,PSOHSTRT,PSOHSTOP,PSOHISSD,PSORTLP,ZRXFLAG,RXE2FLAG,RXE2ONLY,PSODFN,EDUZ + N PSOCDDUZ,DA,FSIG,BSIG,PSHRX,PSHORX,PSNOOTX,ZPRE,PSOZSTAT,CCCX,PSOCPS,PSOICD + K FIELD + I $G(STAT)="" Q + I STAT="CR"!(STAT="DR")!(STAT="HR")!(STAT="OC")!(STAT="OD")!(STAT="OH")!(STAT="Z@")!(STAT="RP") S PSOZSTAT=STAT D DELP^PSOHLSN S STAT=PSOZSTAT G SKIP + I STAT="SC" I $G(PSSTAT)="ZE"!($G(PSSTAT)="HD")!($G(PSSTAT)="DC") S PSOZSTAT=STAT D DELP^PSOHLSN S STAT=PSOZSTAT +SKIP ; + I $G(STAT)="SC",$G(PSSTAT)="ZE",$P($G(^PSRX(+$G(PSRXIEN),0)),"^",19)=2 Q + I $G(STAT)="RP" S STAT="OD",PSSTAT="RP" + S COUNT=0,NULLFLDS="F JJ=0:1:LIMIT S FIELD(JJ)=""""" + I '$D(^PSRX(PSRXIEN,0)) Q + I STAT'="SN",STAT'="ZC",'$P($G(^PSRX(PSRXIEN,"OR1")),"^",2) Q + I $G(STAT)="SC",$G(PSSTAT)="ZE" S $P(^PSRX(PSRXIEN,0),"^",19)=2 + D INIT + S COUNT=1,(ZRXFLAG,RXE2FLAG,RXE2ONLY)=0 D PID,PV1,ORC + I $G(STAT)="Z@" G NCM + I $G(STAT)="OK"!($G(STAT)="SN")!($G(STAT)="ZC")!($G(STAT)="XX")!($G(STAT)="SC")!($G(STAT)="RO") D RXO,RXE,RXR,ZRX,DG1,ZSC,ZCL G NCM + I $G(STAT)="SC",$G(PSSTAT)="CM" D RXO,RXE,RXR,ZRX,DG1,ZSC,ZCL + I '$G(RXE2FLAG) S RXE2ONLY=1 D RXE,SEGPARX^PSOHLSN + I '$G(ZRXFLAG) D ZRX +NCM D SEND + K PSRXIEN Q +INIT K ^UTILITY("DIQ1",$J),DIQ S DA=$P($$SITE^VASITE(),"^") I $G(DA) S DIC=4,DIQ(0)="I",DR="99" D EN^DIQ1 S PSOHINST=$G(^UTILITY("DIQ1",$J,4,DA,99,"I")) K ^UTILITY("DIQ1",$J),DA,DR,DIQ,DIC + S MSG(1)="MSH|^~\&|PHARMACY|"_$G(PSOHINST)_"|||||"_$S($G(PSOMSORR):"ORR",1:"ORM") + Q +PID S LIMIT=5 X NULLFLDS + S DFN=+$P(^PSRX(PSRXIEN,0),"^",2) D DEM^VADPT S NAME=$G(VADM(1)) K VADM + S FIELD(0)="PID" + S FIELD(3)=DFN + S FIELD(5)=NAME + D SEG Q +DG1 D DG1^PSOHLSN2 + Q +PV1 ; + S LIMIT=19 X NULLFLDS + S FIELD(0)="PV1" + S FIELD(2)="O" + S:$P(^PSRX(PSRXIEN,0),"^",5) FIELD(3)=$P(^(0),"^",5) + D SEG Q +ORC ; + S LIMIT=15 X NULLFLDS + S FIELD(0)="ORC" + S FIELD(1)=$G(STAT) + I $G(STAT)'="SN",$G(STAT)'="ZC" S FIELD(2)=$P($G(^PSRX(PSRXIEN,"OR1")),"^",2) + S:FIELD(2)'="" FIELD(2)=FIELD(2)_$S($G(PLACERXX):";"_PLACERXX,1:"")_"^OR" + S FIELD(3)=PSRXIEN_"^PS" + S FIELD(5)=$G(PSSTAT) + I $G(STAT)="RO",$G(PSOROPCH)'="PATCH" S FIELD(5)="CM" + I $G(FIELD(5))="" I $G(STAT)="OR"!($G(STAT)="OE") S FIELD(5)="CM" + S X=$P($G(^PSRX(PSRXIEN,2)),"^") I X S FIELD(9)=$$FMTHL7^XLFDT(X) + S EDUZ=$P($G(^PSRX(PSRXIEN,0)),"^",16) I EDUZ S FIELD(10)=EDUZ_"^"_$P($G(^VA(200,EDUZ,0)),"^") + I $G(PSOCANRC),$G(PSOCANRN)'="" I $G(STAT)="OD"!($G(STAT)="OC") S FIELD(12)=$G(PSOCANRC)_"^"_$G(PSOCANRN) + I '$G(FIELD(12)) S FIELD(12)=$P($G(^PSRX(PSRXIEN,0)),"^",4)_"^"_$P($G(^VA(200,+$P($G(^PSRX(PSRXIEN,0)),"^",4),0)),"^") + S PSOHISSD="",X=$P($G(^PSRX(PSRXIEN,0)),"^",13) I X S PSOHISSD=$$FMTHL7^XLFDT(X) + S FIELD(15)=$G(PSOHISSD) K X + D SEG + I $G(COMM)'=""!($G(PSNOO)'="") D + .I $G(PSNOO)'="" D NOO + .I $L($G(COMM))+($L(MSG(COUNT)))+($L($G(PSNOOTX)))+($S($G(PSNOO)'="":11,1:5))<245 S MSG(COUNT)=MSG(COUNT)_"|"_$G(PSNOO)_"^"_$G(PSNOOTX)_"^"_$S($G(PSNOO)'="":"99ORN",1:"")_"^^"_$G(COMM)_"^" Q + .S MSG(COUNT,1)="|"_$G(PSNOO)_"^"_$G(PSNOOTX)_"^"_$S($G(PSNOO)'="":"99ORN",1:"")_"^^"_$G(COMM)_"^" + Q + ; +RXO ; + S LIMIT=1 X NULLFLDS + S FIELD(0)="RXO" + S PPTR=+$P($G(^PSRX(PSRXIEN,"OR1")),"^") + S FIELD(1)=$S('PPTR:"^^^^^",1:"^^^"_PPTR_"^"_$P($G(^PS(50.7,PPTR,0)),"^")_" "_$P($G(^PS(50.606,+$P($G(^(0)),"^",2),0)),"^")_"^99PSP") + D SEG Q + ; +RXE ; + S RXE2FLAG=1 + S LIMIT=$S('$G(RXE2ONLY):26,1:2) X NULLFLDS + S FIELD(0)="RXE" + S (PSOHSTRT,PSOHSTOP)="" S X=$P($G(^PSRX(PSRXIEN,2)),"^",2) I X S PSOHSTRT=$$FMTHL7^XLFDT(X) + I '$G(DT) S DT=$$DT^XLFDT + S X=$S($P($G(^PSRX(PSRXIEN,3)),"^",5):$P($G(^(3)),"^",5),$G(STAT)="OD"!($G(STAT)="OC"):$G(DT),$P($G(^(2)),"^",6):$P($G(^(2)),"^",6),1:$G(DT)) I X S PSOHSTOP=$$FMTHL7^XLFDT(X) + K X N PSOMZT,MMZZ,MMZZT S MMZZT=1 F MMZZ=0:0 S MMZZ=$O(^PSRX(PSRXIEN,6,MMZZ)) Q:'MMZZ D:$D(^(MMZZ,0)) + .S FIELD(1,MMZZT)=$S($P($G(^PSRX(PSRXIEN,6,MMZZ,0)),"^",2):$P($G(^(0)),"^")_"&"_$P($G(^PS(50.607,+$P($G(^(0)),"^",3),0)),"^")_"&"_$P($G(^PSRX(PSRXIEN,6,MMZZ,0)),"^",2)_"&"_$P($G(^(0)),"^",4),1:"")_"^"_$P($G(^(0)),"^",8) + .I $P($G(FIELD(1,MMZZT)),"^")'="" F PSOMZT=1,3 I $E($P(FIELD(1,MMZZT),"&",PSOMZT),1)="." S $P(FIELD(1,MMZZT),"&",PSOMZT)="0"_$P(FIELD(1,MMZZT),"&",PSOMZT) + .S FIELD(1,MMZZT)=$G(FIELD(1,MMZZT))_"^"_$$DUR(PSRXIEN,MMZZ)_"^^^^^"_$S($P($G(FIELD(1,MMZZT)),"^")'="":$P($G(FIELD(1,MMZZT)),"&")_$P($G(FIELD(1,MMZZT)),"&",2),1:$P($G(^PSRX(PSRXIEN,6,MMZZ,0)),"^")) + .S FIELD(1,MMZZT)=$G(FIELD(1,MMZZT))_"^"_$P($G(^PSRX(PSRXIEN,6,MMZZ,0)),"^",6) + .I $O(^PSRX(PSRXIEN,6,MMZZ)) S FIELD(1,MMZZT)=$G(FIELD(1,MMZZT))_"~" + .S MMZZT=MMZZT+1 + S $P(FIELD(1,1),"^",4)=$G(PSOHSTRT),$P(FIELD(1,1),"^",5)=$G(PSOHSTOP) + S PSFLAG=0,PSDIEN=+$P(^PSRX(PSRXIEN,0),"^",6),PSND1=$P($G(^PSDRUG(PSDIEN,"ND")),"^"),PSND2=$P($G(^("ND")),"^",2),PSND3=$P($G(^("ND")),"^",3) I PSND1,PSND3 S PSFLAG=1 + S FIELD(2)=$S(PSFLAG:PSND1_"."_PSND3_"^"_PSND2_"^"_"99NDF",1:"^^")_"^"_PSDIEN_"^"_$P($G(^PSDRUG(PSDIEN,0)),"^")_"^"_"99PSD" + Q:$G(RXE2ONLY) + I PSFLAG D + .I $T(^PSNAPIS)]"" S PSOXN=$$DFSU^PSNAPIS(PSND1,PSND3) S FIELD(5)="^^^"_$P($G(PSOXN),"^",5)_"^"_$P($G(PSOXN),"^",6)_"^"_"99PSU" K PSOXN Q + .S PRODUCT=$G(^PSNDF(PSND1,5,PSND3,0)) S UNIT=$P($G(^PSNDF(PSND1,2,+$P(PRODUCT,"^",2),3,+$P(PRODUCT,"^",3),4,+$P(PRODUCT,"^",4),0)),"^") + .S FIELD(5)="^^^"_UNIT_"^"_$P($G(^PS(50.607,+UNIT,0)),"^")_"^"_"99PSU" + S POIPTR=$P($G(^PSRX(PSRXIEN,"OR1")),"^") I POIPTR S PODOSE=$P($G(^PS(50.7,POIPTR,0)),"^",2),PODOSENM=$P($G(^PS(50.606,+PODOSE,0)),"^") + I POIPTR S FIELD(6)="^^^"_$G(PODOSE)_"^"_$G(PODOSENM)_"^"_"99PSF" + S FIELD(10)=$P(^PSRX(PSRXIEN,0),"^",7) + S FIELD(12)=$P(^PSRX(PSRXIEN,0),"^",9) + S FIELD(14)=$P(^PSRX(PSRXIEN,0),"^",4) + S FIELD(15)=$P(^PSRX(PSRXIEN,0),"^") + S FIELD(22)=$P(^PSRX(PSRXIEN,0),"^",8) + K MMZZ S MMZZ=$$EN^PSSUTIL1(PSDIEN) S FIELD(25)=$S($E($P(MMZZ,"|"),1)=".":"0",1:"")_$P(MMZZ,"|"),FIELD(26)=$P(MMZZ,"|",2) + N PLIM,PVAR,PVAR1,SUBCOUNT D SEGPARX^PSOHLSN + ; + I $O(^PSRX(PSRXIEN,"PRC",0)) D + .S COUNT=COUNT+1,CCC=$O(^PSRX(PSRXIEN,"PRC",0)) + .S MSG(COUNT)="NTE|6||"_$G(^PSRX(PSRXIEN,"PRC",CCC,0)) + .S CSCOUNT=1 F CCC=CCC:0 S CCC=$O(^PSRX(PSRXIEN,"PRC",CCC)) Q:'CCC S MSG(COUNT,CSCOUNT)=$G(^PSRX(PSRXIEN,"PRC",CCC,0)),CSCOUNT=CSCOUNT+1 + I $O(^PSRX(PSRXIEN,"INS1",0)) D + .S COUNT=COUNT+1,CCC=$O(^PSRX(PSRXIEN,"INS1",0)) + .S MSG(COUNT)="NTE|7|L|"_$G(^PSRX(PSRXIEN,"INS1",CCC,0)) + .S CCCX=1 F CCC=CCC:0 S CCC=$O(^PSRX(PSRXIEN,"INS1",CCC,0)) Q:'CCC I $D(^(0)) S MSG(COUNT,CCCX)=$G(^(0)) S CCCX=CCCX+1 + S COUNT=COUNT+1 + I $P($G(^PSRX(PSRXIEN,"SIG")),"^",2) D Q + .D FSIG^PSOUTLA("R",PSRXIEN,238) S MSG(COUNT)="NTE|21||"_$S($G(FSIG(1))'="":$G(FSIG(1)),1:"No SIG available") I $O(FSIG(1)) F CCC=1:0 S CCC=$O(FSIG(CCC)) Q:'CCC S MSG(COUNT,(CCC-1))=$G(FSIG(CCC)) + I '$P($G(^PSRX(PSRXIEN,"SIG")),"^",2) D Q + .D EN3^PSOUTLA1(PSRXIEN,238) S MSG(COUNT)="NTE|21||"_$S($G(BSIG(1))'="":$G(BSIG(1)),1:"No SIG available") I $O(BSIG(1)) F CCC=1:0 S CCC=$O(BSIG(CCC)) Q:'CCC S MSG(COUNT,(CCC-1))=$G(BSIG(CCC)) + Q + ; +RXR ; + F PSORTLP=0:0 S PSORTLP=$O(^PSRX(PSRXIEN,6,PSORTLP)) Q:'PSORTLP D + .S LIMIT=1 X NULLFLDS + .S FIELD(0)="RXR" + .S PSROUTE=$P($G(^PSRX(PSRXIEN,6,PSORTLP,0)),"^",7) I PSROUTE,$D(^PS(51.2,PSROUTE,0)) S RTNAME=$P(^PS(51.2,PSROUTE,0),"^") + .S FIELD(1)="^^^"_$G(PSROUTE)_"^"_$G(RTNAME)_"^"_"99PSR" + .D SEG + Q + ; +ZCL D ZCL^PSOHLSN2 + Q +ZSC D ZSC^PSOHLSN2 + Q + ; +ZRX ; + S ZRXFLAG=1 + S LIMIT=6 X NULLFLDS + S FIELD(0)="ZRX" + S ZPRE=$P($G(^PSRX(PSRXIEN,"OR1")),"^",3) I ZPRE S FIELD(1)=$P($G(^PSRX(ZPRE,"OR1")),"^",2) + I '$G(FIELD(1)),$G(PSORDEDT) S FIELD(1)=$P($G(^PS(52.41,$G(PSORDEDT),0)),"^") + S FIELD(2)=$G(PSNOO) + I $G(STAT)="SN"!($G(STAT)="RO") S FIELD(3)=$S($G(STAT)="RO"!($G(PSOEDIT)):"E",$G(PSOOPT)=3:"R",1:"N") + S FIELD(4)=$P(^PSRX(PSRXIEN,0),"^",11) + S PSOCDDUZ=$S($G(PSOROPCH)="PATCH":$P($G(^PSRX(PSRXIEN,"OR1")),"^",5),$G(PSOHUIOR)&($P($G(^PSRX(PSRXIEN,"EXT")),"^")'=""):+$G(PSOCANRC),1:$G(DUZ)) + I $G(PSOCDDUZ) S FIELD(5)=PSOCDDUZ_"^"_$P($G(^VA(200,PSOCDDUZ,0)),"^")_"^"_"99NP" + I $G(STAT)="ZD",$G(PSODISPP) S FIELD(6)="P" + D SEG Q +SEG S SEGMENT="" F J=0:1:LIMIT S SEGMENT=$S(SEGMENT="":FIELD(J),1:SEGMENT_"|"_FIELD(J)) + S COUNT=COUNT+1,MSG(COUNT)=SEGMENT + Q +SEND D:$G(PSRXIEN)&($T(EN^PSOHDR)]"")&($G(PSOSSMES)'="CPRSUP") K FIELD D MSG^XQOR("PS EVSEND OR",.MSG) Q + .I $G(STAT)="ZC"!($G(STAT)="UC")!($G(STAT)="UD")!($G(STAT)="UH")!($G(STAT)="UR")!($G(STAT)="DE")!($G(STAT)="ZD")!($G(STAT)="SN")!($G(STAT)="Z@") Q + .I $G(STAT)="SC",$G(PSSTAT)="ZZ" Q + .D EN^PSOHDR("PRES",PSRXIEN) + ; +NOO ; + I $G(PSNOO)="" S PSNOOTX="" Q + S PSNOOTX=$S(PSNOO="W":"Written",PSNOO="V":"Verbal",PSNOO="P":"Telephoned",PSNOO="S":"Service Correction",PSNOO="X":"Rejected",PSNOO="D":"Duplicate",PSNOO="I":"Policy",PSNOO="E":"Physician Entered",PSNOO="A":"Auto DC",1:"") Q + Q + ; +DUR(PSODX1,PSODX2) ; + N PSODX,PSODX4,PSODX5,PSODX6,PSODX7 S PSODX=$P($G(^PSRX(PSODX1,6,PSODX2,0)),"^",5) + I 'PSODX Q PSODX + S PSODX4=$L(PSODX),PSODX5=$E(PSODX,PSODX4) + S PSODX=$S(PSODX5?1A:PSODX,1:PSODX_"D") + S PSODX6=$L(PSODX) + S PSODX7=$E(PSODX,PSODX6)_$E(PSODX,1,(PSODX6-1)) + Q PSODX7 + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLSN2.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLSN2.m index 7220806a..7e230216 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLSN2.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLSN2.m @@ -1,58 +1,57 @@ -PSOHLSN2 ;BIR/LE - Utilities for PSOHLSN1 ;02/27/04 - ;;7.0;OUTPATIENT PHARMACY;**143,226,239,225**;DEC 1997;Build 29 - ; -DG1 ;this section builds both DG1 segments - Q:'$D(^PSRX(PSRXIEN,"ICD",1,0)) - N LP,DG,DXDESC,I - S LIMIT=4,FIELD(0)="DG1",FIELD(4)="" - ;I '$D(^PSRX(PSRXIEN,"ICD",1,0)) S FIELD(1)=1,FIELD(2)="",FIELD(3)="^^^^^" D SEG^PSOHLSN1 Q - I $P(^PSRX(PSRXIEN,"ICD",1,0),"^",1)="" Q ;S FIELD(1)=1,FIELD(2)="",FIELD(3)="^^^^^" D SEG^PSOHLSN1 Q - F I=1:1:8 D - . Q:'$D(^PSRX(PSRXIEN,"ICD",I,0)) - . S PSOICD="",PSOICD=^PSRX(PSRXIEN,"ICD",I,0) Q:$P(PSOICD,U,1)="" - . S (DG,DXDESC)="" - . I $P(PSOICD,U,1)'="" D - .. S DXDESC=$$GET1^DIQ(80,$P(PSOICD,U,1)_",",10),FIELD(1)=I,FIELD(2)="" - .. S FIELD(3)=$P(PSOICD,U,1)_U_DXDESC_U_"80"_U_$$GET1^DIQ(80,$P(PSOICD,U,1)_",",.01)_U_DXDESC_U_"ICD9" - .. D SEG^PSOHLSN1 - K PSOICD("K") - Q -ZCL N STOP,IBQ,ICD,I,JJJ,EI - S LIMIT=3,FIELD(0)="ZCL" - I '$D(^PSRX(PSRXIEN,"ICD"))&($D(^PSRX(PSRXIEN,"IBQ"))) D ;For edits; currently CPRS doesn't update SC/EI for edits, but just in case they start - . S FIELD(1)=1,FIELD(2)=3 - . S EI="",EI=^PSRX(PSRXIEN,"IBQ") - . S JJJ=0 F I=3,4,1,5,2,6,7,8 S JJJ=JJJ+1,FIELD(3)=$P(EI,U,I) S FIELD(1)=1,FIELD(2)=JJJ D SEG^PSOHLSN1 - E F I=1:1:8 D - . Q:'$D(^PSRX(PSRXIEN,"ICD",I,0)) - . S PSOICD=^PSRX(PSRXIEN,"ICD",I,0),ICD=$P(PSOICD,"^",1) - . Q:ICD=""&(I>1) - . F JJJ=2:1:9 S EI=$P(PSOICD,U,JJJ),FIELD(2)=JJJ-1 D - .. S FIELD(1)=$S(ICD="":1,1:I) - .. ;S FIELD(3)=$S(EI=1:EI,1:0) - .. S FIELD(3)=$S(EI=1:EI,EI=0:EI,1:"") - .. D SEG^PSOHLSN1 - K PSOICD - Q - ;CPRS doesn't look at the ZCL segment when their CIDC switch is off. Always send both ZCL and ZSC for consistency -ZSC S PSOCPS=$$DT^PSOMLLDT S LIMIT=$S($G(PSOCPS):8,1:1) X NULLFLDS - S FIELD(0)="ZSC" N JJJ,PSOICD - I '$D(^PSRX(PSRXIEN,"ICD",1,0)) D - . I '$G(PSOCPS) S FIELD(1)=$S($P($G(^PSRX(PSRXIEN,"IB")),"^"):"NSC",1:"SC") - . I $G(PSOCPS) D - .. S FIELD(1)=$P($G(^PSRX(PSRXIEN,"IBQ")),"^") - .. F JJJ=2:1:8 S FIELD(JJJ)=$P($G(^PSRX(PSRXIEN,"IBQ")),"^",JJJ) - .D SEG^PSOHLSN1 - I $D(^PSRX(PSRXIEN,"ICD",1,0)) D - . S PSOICD=$G(^PSRX(PSRXIEN,"ICD",1,0)) - . F JJJ=2:1:9 D - .. I JJJ=2 S FIELD(3)=$P(PSOICD,"^",JJJ) ;AO - .. I JJJ=3 S FIELD(4)=$P(PSOICD,"^",JJJ) ;IR - .. I JJJ=4 S FIELD(1)=$P(PSOICD,"^",JJJ) ;SC - .. I JJJ=5 S FIELD(5)=$P(PSOICD,"^",JJJ) ;EC - .. I JJJ=6 S FIELD(2)=$P(PSOICD,"^",JJJ) ;MST - .. I JJJ=7 S FIELD(6)=$P(PSOICD,"^",JJJ) ;HNC - .. I JJJ=8 S FIELD(7)=$P(PSOICD,"^",JJJ) ;CV - .. I JJJ=9 S FIELD(8)=$P(PSOICD,"^",JJJ) ;SHAD - . D SEG^PSOHLSN1 - Q +PSOHLSN2 ;BIR/LE - Utilities for PSOHLSN1 ;02/27/04 + ;;7.0;OUTPATIENT PHARMACY;**143,226,239**;DEC 1997 + ; +DG1 ;this section builds both DG1 segments + Q:'$D(^PSRX(PSRXIEN,"ICD",1,0)) + N LP,DG,DXDESC,I + S LIMIT=4,FIELD(0)="DG1",FIELD(4)="" + ;I '$D(^PSRX(PSRXIEN,"ICD",1,0)) S FIELD(1)=1,FIELD(2)="",FIELD(3)="^^^^^" D SEG^PSOHLSN1 Q + I $P(^PSRX(PSRXIEN,"ICD",1,0),"^",1)="" Q ;S FIELD(1)=1,FIELD(2)="",FIELD(3)="^^^^^" D SEG^PSOHLSN1 Q + F I=1:1:8 D + . Q:'$D(^PSRX(PSRXIEN,"ICD",I,0)) + . S PSOICD="",PSOICD=^PSRX(PSRXIEN,"ICD",I,0) Q:$P(PSOICD,U,1)="" + . S (DG,DXDESC)="" + . I $P(PSOICD,U,1)'="" D + .. S DXDESC=$$GET1^DIQ(80,$P(PSOICD,U,1)_",",10),FIELD(1)=I,FIELD(2)="" + .. S FIELD(3)=$P(PSOICD,U,1)_U_DXDESC_U_"80"_U_$$GET1^DIQ(80,$P(PSOICD,U,1)_",",.01)_U_DXDESC_U_"ICD9" + .. D SEG^PSOHLSN1 + K PSOICD("K") + Q +ZCL N STOP,IBQ,ICD,I,JJJ,EI + S LIMIT=3,FIELD(0)="ZCL" + I '$D(^PSRX(PSRXIEN,"ICD"))&($D(^PSRX(PSRXIEN,"IBQ"))) D ;For edits; currently CPRS doesn't update SC/EI for edits, but just in case they start + . S FIELD(1)=1,FIELD(2)=3 + . S EI="",EI=^PSRX(PSRXIEN,"IBQ") + . S JJJ=0 F I=3,4,1,5,2,6,7 S JJJ=JJJ+1,FIELD(3)=$P(EI,U,I) S FIELD(1)=1,FIELD(2)=JJJ D SEG^PSOHLSN1 + E F I=1:1:8 D + . Q:'$D(^PSRX(PSRXIEN,"ICD",I,0)) + . S PSOICD=^PSRX(PSRXIEN,"ICD",I,0),ICD=$P(PSOICD,"^",1) + . Q:ICD=""&(I>1) + . F JJJ=2:1:8 S EI=$P(PSOICD,U,JJJ),FIELD(2)=JJJ-1 D + .. S FIELD(1)=$S(ICD="":1,1:I) + .. ;S FIELD(3)=$S(EI=1:EI,1:0) + .. S FIELD(3)=$S(EI=1:EI,EI=0:EI,1:"") + .. D SEG^PSOHLSN1 + K PSOICD + Q + ;CPRS doesn't look at the ZCL segment when thier CIDC switch is off. Always send both ZCL and ZSC for consistency +ZSC S PSOCPS=$$DT^PSOMLLDT S LIMIT=$S($G(PSOCPS):7,1:1) X NULLFLDS + S FIELD(0)="ZSC" + I '$D(^PSRX(PSRXIEN,"ICD",1,0)) D + . I '$G(PSOCPS) S FIELD(1)=$S($P($G(^PSRX(PSRXIEN,"IB")),"^"):"NSC",1:"SC") + . I $G(PSOCPS) D + .. S FIELD(1)=$P($G(^PSRX(PSRXIEN,"IBQ")),"^"),FIELD(2)=$P($G(^("IBQ")),"^",2),FIELD(3)=$P($G(^("IBQ")),"^",3),FIELD(4)=$P($G(^("IBQ")),"^",4),FIELD(5)=$P($G(^("IBQ")),"^",5),FIELD(6)=$P($G(^("IBQ")),"^",6),FIELD(7)=$P($G(^("IBQ")),"^",7) + .D SEG^PSOHLSN1 + N JJJ,PSOICD + I $D(^PSRX(PSRXIEN,"ICD",1,0)) D + . S PSOICD=$G(^PSRX(PSRXIEN,"ICD",1,0)) + . F JJJ=2:1:8 D + .. I JJJ=2 S FIELD(3)=$P(PSOICD,"^",JJJ) ;AO + .. I JJJ=3 S FIELD(4)=$P(PSOICD,"^",JJJ) ;IR + .. I JJJ=4 S FIELD(1)=$P(PSOICD,"^",JJJ) ;SC + .. I JJJ=5 S FIELD(5)=$P(PSOICD,"^",JJJ) ;EC + .. I JJJ=6 S FIELD(2)=$P(PSOICD,"^",JJJ) ;MST + .. I JJJ=7 S FIELD(6)=$P(PSOICD,"^",JJJ) ;HNC + .. I JJJ=8 S FIELD(7)=$P(PSOICD,"^",JJJ) ;CV + . D SEG^PSOHLSN1 + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLSNC.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLSNC.m index fce0eb5c..f47c4a62 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLSNC.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLSNC.m @@ -1,160 +1,160 @@ -PSOHLSNC ;BIR/RTR - Send CHCS message to CPRS ;07/03/02 - ;;7.0;OUTPATIENT PHARMACY;**111,157,143,225**;DEC 1997;Build 29 - ;External reference to ^PS(50.7 supported by DBIA 2223 - ;External reference to ^PS(51.2 supported by DBIA 2226 - ;External reference to ^PSDRUG( supported by DBIA 221 - ;External reference to ^PS(50.607 supported by DBIA 2221 - ;External reference to ^PS(50.606 supported by DBIA 2174 - ;External reference to EN^PSSUTIL1 supported by DBIA 3179 - ; - ;PSOPND=Internal number from 52.41 - ;PSOPNDST=Order Control Code Status - ;PSOPNDPT=Pharmacy Status - ; -EN(PSOPND,PSOPNDST,PSOPNDPT) ; - N MSG,PSOHLIP,PSOHLIPX,PSOHLIPC,PSOHLTTL,PSOHUTL,PSOHND,PSOHNDD,PSOHNDU,PSONFLD,PSOXFLD,PSOLIMIT,PSONJJ,PSOHJJ,PSOHCT,PSOSEGMT,PSOHENT,PSOHPRO,PSOHIM,PSOHPC,PSOHPCTX,PSOHRT,PSOHRTE,PSOHRTEN,PSOHRTX,Y,DA,DIQ,DR - I $G(PSOPND)=""!($G(PSOPNDST)="") Q - I '$D(^PS(52.41,+$G(PSOPND),0)) Q - S PSONFLD="F PSONJJ=0:1:PSOLIMIT S PSOXFLD(PSONJJ)=""""" - S PSOHCT=1 - D INIT^PSOHLSN - D PID,PV1,ORC,RXO,RXE,RXR,ZRX,DG1,ZCL - D MSG^XQOR("PS EVSEND OR",.MSG) - Q -PID ;Build PID segment - S PSOLIMIT=5 X PSONFLD - ;What about this ICN number? - S PSOXFLD(0)="PID" - S PSOXFLD(3)=$P($G(^PS(52.41,PSOPND,0)),"^",2) - D SEG - Q -PV1 ;Build PV1 segment - S PSOLIMIT=19 X PSONFLD - S PSOXFLD(0)="PV1" - S PSOXFLD(2)="O" - I $P($G(^PS(52.41,PSOPND,0)),"^",13) S PSOXFLD(3)=$P(^(0),"^",13) - D SEG - Q -DG1 ;Build DG1 segment - ;future use; chcs does not send ICD-9 codes. - Q:'$D(^PS(52.41,PSOPND,"ICD")) - S PSOLIMIT=4 X PSONFLD - S PSOXFLD(0)="DG1" - N LP,VDG,FLAG,DXDESC,DG - S FLAG="",PSOXFLD(4)="",PSOXFLD(2)="" - F LP=1:1:8 Q:'$D(^PS(52.41,PSOPND,"ICD",LP,0)) D - . S VDG="",VDG=^PS(52.41,PSOPND,"ICD",LP,0) Q:$P(VDG,U,1)="" - . S (DG,DXDESC)="" - . S DXDESC=$$GET1^DIQ(80,$P(VDG,U,1)_",",10),PSOXFLD(1)=LP - . S PSOXFLD(3)=$P(VDG,U,1)_U_DXDESC_U_"80"_U_$$GET1^DIQ(80,$P(VDG,U,1)_",",.01)_U_DXDESC_U_"ICD9" - . D SEG - Q -ORC ;Build ORC segment - S PSOLIMIT=15 X PSONFLD - S PSOXFLD(0)="ORC" - S PSOXFLD(1)=$G(PSOPNDST) - S PSOXFLD(3)=PSOPND_"S^PS" - S PSOXFLD(5)=$G(PSOPNDPT) - S X=$P($G(^PS(52.41,PSOPND,0)),"^",6) I X S PSOXFLD(9)=$$FMTHL7^XLFDT(X) - S PSOHENT=$P($G(^PS(52.41,PSOPND,0)),"^",4) I PSOHENT K ^UTILITY("DIQ1",$J) S DIC=200,DR=.01,DA=PSOHENT,DIQ(0)="E" D EN^DIQ1 S PSOXFLD(10)=PSOHENT_"^"_$P($G(^UTILITY("DIQ1",$J,200,PSOHENT,.01,"E")),"^") - S PSOHPRO=$P($G(^PS(52.41,PSOPND,0)),"^",5) I PSOHPRO K ^UTILITY("DIQ1",$J) S DIC=200,DR=.01,DA=PSOHPRO,DIQ(0)="E" D EN^DIQ1 S PSOXFLD(12)=PSOHPRO_"^"_$P($G(^UTILITY("DIQ1",$J,200,PSOHPRO,.01,"E")),"^") - K ^UTILITY("DIQ1",$J) - S X=$P($G(^PS(52.41,PSOPND,0)),"^",12) I X S PSOXFLD(15)=$$FMTHL7^XLFDT(X) - D SEG - Q -RXO ;Build RXO segment - S PSOLIMIT=1 X PSONFLD - S PSOXFLD(0)="RXO" - S PSOHITM=$P($G(^PS(52.41,PSOPND,0)),"^",8) - S PSOXFLD(1)=$S($G(PSOHITM):"^^^"_PSOHITM_"^"_$P($G(^PS(50.7,+$G(PSOHITM),0)),"^")_" "_$P($G(^PS(50.606,+$P($G(^(0)),"^",2),0)),"^")_"^99PSP",1:"^^^^^") - D SEG - Q -RXE ;Build RXE segment - K PSOXFLD S PSOLIMIT=26 X PSONFLD - S PSOXFLD(0)="RXE" - ;No Quantity Timing, since the Sig is entered as free text - S PSOHNDD=$P($G(^PS(52.41,PSOPND,0)),"^",9) - S PSOHND="" I PSOHNDD S PSOHND=$G(^PSDRUG(PSOHNDD,"ND")) - S PSOXFLD(2)=$S($P(PSOHND,"^")&($P(PSOHND,"^",3)):$P(PSOHND,"^")_"."_$P(PSOHND,"^",3)_"^"_$P(PSOHND,"^",2)_"^"_"99NDF",1:"^^")_"^"_$G(PSOHNDD)_"^"_$S($G(PSOHNDD):$P($G(^PSDRUG(PSOHNDD,0)),"^"),1:"")_"^"_"99PSD" - I $P(PSOHND,"^"),$P(PSOHND,"^",3) D - .I $T(^PSNAPIS)]"" S PSOHNDU=$$DFSU^PSNAPIS($P(PSOHND,"^"),$P(PSOHND,"^",3)) S PSOXFLD(5)="^^^"_$P($G(PSOHNDU),"^",5)_"^"_$P($G(PSOHNDU),"^",6)_"^"_"99PSU" - I $G(PSOHITM) S PSOXFLD(6)="^^^"_$P($G(^PS(50.7,$G(PSOHITM),0)),"^",2)_"^"_$P($G(^PS(50.606,+$P($G(^PS(50.7,$G(PSOHITM),0)),"^",2),0)),"^")_"^"_"99PSF" - S PSOXFLD(10)=$P(^PS(52.41,PSOPND,0),"^",10) - S PSOXFLD(12)=$P(^PS(52.41,PSOPND,0),"^",11) - S PSOXFLD(22)=$P(^PS(52.41,PSOPND,0),"^",22) - I $G(PSOHNDD) S PSOHUTL=$$EN^PSSUTIL1(PSOHNDD) S PSOXFLD(25)=$S($E($P(PSOHUTL,"|"),1)=".":"0",1:"")_$P(PSOHUTL,"|"),PSOXFLD(26)=$P(PSOHUTL,"|",2) - ;Create RXE segment, can possibly go over 245 in length - S PSOHCT=PSOHCT+1 - S (PSOHLIPX,PSOHLIPC,PSOHLTTL)=0,PSOHLIP="" F S PSOHLIP=$O(PSOXFLD(PSOHLIP)) Q:PSOHLIP="" D - .I PSOHLIP S PSOXFLD(PSOHLIP)="|"_PSOXFLD(PSOHLIP) - .I PSOHLTTL+$L(PSOXFLD(PSOHLIP))<246 D S PSOHLTTL=PSOHLTTL+$L(PSOXFLD(PSOHLIP)) Q - ..I 'PSOHLIPX S MSG(PSOHCT)=$G(MSG(PSOHCT))_PSOXFLD(PSOHLIP) Q - ..S MSG(PSOHCT,PSOHLIPX)=$G(MSG(PSOHCT,PSOHLIPX))_PSOXFLD(PSOHLIP) - .S PSOHLICP=245-PSOHLTTL - .I 'PSOHLIPX D S PSOHLTTL=$L(MSG(PSOHCT,PSOHLIPX)) Q - ..S MSG(PSOHCT)=$G(MSG(PSOHCT))_$E(PSOXFLD(PSOHLIP),1,PSOHLICP) - ..S PSOHLIPX=1,MSG(PSOHCT,PSOHLIPX)=$E(PSOXFLD(PSOHLIP),(PSOHLICP+1),999) - .S MSG(PSOHCT,PSOHLIPX)=$G(MSG(PSOHCT,PSOHLIPX))_$E(PSOXFLD(PSOHLIP),1,PSOHLICP) - .S PSOHLIPX=PSOHLIPX+1,MSG(PSOHCT,PSOHLIPX)=$E(PSOXFLD(PSOHLIP),(PSOHLICP+1),999) - .S PSOHLTTL=$L(MSG(PSOHCT,PSOHLIPX)) - ;Set NTE segments - S PSOHPCT=0,PSOHCT=PSOHCT+1 I $O(^PS(52.41,PSOPND,3,0)) F PSOHPC=0:0 S PSOHPC=$O(^PS(52.41,PSOPND,3,PSOHPC)) Q:'PSOHPC D - .I $G(^PS(52.41,PSOPND,3,PSOHPC,0))="" Q - .I 'PSOHPCT S MSG(PSOHCT)="NTE|6||"_$G(^PS(52.41,PSOPND,3,PSOHPC,0)) S PSOHPCT=1 Q - .S MSG(PSOHCT,PSOHPCT)=$G(^PS(52.41,PSOPND,3,PSOHPC,0)),PSOHPCT=PSOHPCT+1 - I 'PSOHPCT S PSOHCT=PSOHCT-1 - S PSOHCT=PSOHCT+1,PSOHPCT=0 I $O(^PS(52.41,PSOPND,"SIG",0)) F PSOHPC=0:0 S PSOHPC=$O(^PS(52.41,PSOPND,"SIG",PSOHPC)) Q:'PSOHPC D - .I $G(^PS(52.41,PSOPND,"SIG",PSOHPC,0))="" Q - .I 'PSOHPCT S MSG(PSOHCT)="NTE|21||"_$G(^PS(52.41,PSOPND,"SIG",PSOHPC,0)) S PSOHPCT=1 Q - .S MSG(PSOHCT,PSOHPCT)=$G(^PS(52.41,PSOPND,"SIG",PSOHPC,0)),PSOHPCT=PSOHPCT+1 - I 'PSOHPCT S MSG(PSOHCT)="NTE|21||"_"No SIG available" - Q -RXR ;Build RXR segment - S PSOHRTX="" F PSOHRT=0:0 S PSOHRT=$O(^PS(52.41,PSOPND,1,PSOHRT)) Q:'PSOHRT D - .S PSOHRTX=1 - .S PSOLIMIT=1 X PSONFLD - .S PSOXFLD(0)="RXR" - .S PSOHRTEN="" - .S PSOHRTE=$P($G(^PS(52.41,PSOPND,1,PSOHRT,1)),"^",8) I PSOHRTE,$D(^PS(51.2,PSOHRTE,0)) S PSOHRTEN=$P($G(^(0)),"^") - .S PSOXFLD(1)="^^^"_$G(PSOHRTE)_"^"_$G(PSOHRTEN)_"^"_"99PSR" - .D SEG - I '$G(PSOHRTX) S PSOLIMIT=1 X PSONFLD S PSOXFLD(0)="RXR",PSOXFLD(1)="^^^^^99PSR" D SEG - Q -ZRX ;Build ZRX segment - S PSOLIMIT=6 X PSONFLD - S PSOXFLD(0)="ZRX" - S PSOXFLD(3)="N" - S PSOXFLD(4)=$P($G(^PS(52.41,PSOPND,0)),"^",17) - D SEG - Q -ZCL ;Build ZCL segment - N I,JJJ,INODE,EI - S PSOXFLD(0)="ZCL",PSOLIMIT=3 X PSONFLD - I $D(^PS(52.41,PSOPND,"ICD")) D - .F I=1:1:8 D - ..Q:'$D(^PS(52.41,PSOPND,"ICD",I,0)) - ..S INODE="",INODE=^PS(52.41,PSOPND,"ICD",I,0) - ..F JJJ=2:1:9 S EI=$P(INODE,U,JJJ) D - ...S PSOXFLD(1)=I,PSOXFLD(2)=JJJ-1,PSOXFLD(3)=EI - ...;I JJJ=4 S EI=$S(EI=1:"SC",EI=0:"NSC",1:"") S PSOXFLD(3)=EI - ...D SEG - E D ;if no ICD node, send one ZCL segment - .S PSOXFLD(0)="ZCL",PSOXFLD(1)=1,PSOXFLD(2)=3 - .S PSOXFLD(3)=$S($P(^PS(52.41,PSOPND,0),"^",16)="SC":1,$P(^(0),"^",16)="NSC":0,1:"") - .D SEG - .Q:'$D(^PS(52.41,PSOPND,"IBQ")) - .S EI=^PS(52.41,PSOPND,"IBQ") - .F I=2,3,4,1,5,6,7 S PSOXFLD(3)=$P(EI,U,I) D - .. S PSOXFLD(2)=$S(I=2:1,I=3:2,I=4:4,I=1:5,I=5:6,I=6:7,I=7:8,1:"") D SEG - Q -ZSC ;Build ZSC segment - S PSOLIMIT=6 X PSONFLD - S PSOXFLD(0)="ZSC" - S PSOXFLD(1)=$S($P(^PS(52.41,PSOPND,0),"^",16)="SC":1,$P(^(0),"^",16)="NSC":0,1:"") - S PSOXFLD(2)=$P($G(^PS(52.41,PSOPND,"IBQ")),"^"),PSOXFLD(3)=$P($G(^("IBQ")),"^",2),PSOXFLD(4)=$P($G(^("IBQ")),"^",3),PSOXFLD(5)=$P($G(^("IBQ")),"^",4),PSOXFLD(6)=$P($G(^("IBQ")),"^",5),PSOXFLD(7)=$P($G(^("IBQ")),"^",6) - D SEG - Q -SEG ; - S PSOSEGMT="" F PSOHJJ=0:1:PSOLIMIT S PSOSEGMT=$S(PSOSEGMT="":PSOXFLD(PSOHJJ),1:PSOSEGMT_"|"_PSOXFLD(PSOHJJ)) - S PSOHCT=PSOHCT+1,MSG(PSOHCT)=PSOSEGMT - Q +PSOHLSNC ;BIR/RTR - Send CHCS message to CPRS ;07/03/02 + ;;7.0;OUTPATIENT PHARMACY;**111,157,143**;DEC 1997 + ;External reference to ^PS(50.7 supported by DBIA 2223 + ;External reference to ^PS(51.2 supported by DBIA 2226 + ;External reference to ^PSDRUG( supported by DBIA 221 + ;External reference to ^PS(50.607 supported by DBIA 2221 + ;External reference to ^PS(50.606 supported by DBIA 2174 + ;External reference to EN^PSSUTIL1 supported by DBIA 3179 + ; + ;PSOPND=Internal number from 52.41 + ;PSOPNDST=Order Control Code Status + ;PSOPNDPT=Pharmacy Status + ; +EN(PSOPND,PSOPNDST,PSOPNDPT) ; + N MSG,PSOHLIP,PSOHLIPX,PSOHLIPC,PSOHLTTL,PSOHUTL,PSOHND,PSOHNDD,PSOHNDU,PSONFLD,PSOXFLD,PSOLIMIT,PSONJJ,PSOHJJ,PSOHCT,PSOSEGMT,PSOHENT,PSOHPRO,PSOHIM,PSOHPC,PSOHPCTX,PSOHRT,PSOHRTE,PSOHRTEN,PSOHRTX,Y,DA,DIQ,DR + I $G(PSOPND)=""!($G(PSOPNDST)="") Q + I '$D(^PS(52.41,+$G(PSOPND),0)) Q + S PSONFLD="F PSONJJ=0:1:PSOLIMIT S PSOXFLD(PSONJJ)=""""" + S PSOHCT=1 + D INIT^PSOHLSN + D PID,PV1,ORC,RXO,RXE,RXR,ZRX,DG1,ZCL + D MSG^XQOR("PS EVSEND OR",.MSG) + Q +PID ;Build PID segment + S PSOLIMIT=5 X PSONFLD + ;What about this ICN number? + S PSOXFLD(0)="PID" + S PSOXFLD(3)=$P($G(^PS(52.41,PSOPND,0)),"^",2) + D SEG + Q +PV1 ;Build PV1 segment + S PSOLIMIT=19 X PSONFLD + S PSOXFLD(0)="PV1" + S PSOXFLD(2)="O" + I $P($G(^PS(52.41,PSOPND,0)),"^",13) S PSOXFLD(3)=$P(^(0),"^",13) + D SEG + Q +DG1 ;Build DG1 segment + ;future use; chcs does not send ICD-9 codes. + Q:'$D(^PS(52.41,PSOPND,"ICD")) + S PSOLIMIT=4 X PSONFLD + S PSOXFLD(0)="DG1" + N LP,VDG,FLAG,DXDESC,DG + S FLAG="",PSOXFLD(4)="",PSOXFLD(2)="" + F LP=1:1:8 Q:'$D(^PS(52.41,PSOPND,"ICD",LP,0)) D + . S VDG="",VDG=^PS(52.41,PSOPND,"ICD",LP,0) Q:$P(VDG,U,1)="" + . S (DG,DXDESC)="" + . S DXDESC=$$GET1^DIQ(80,$P(VDG,U,1)_",",10),PSOXFLD(1)=LP + . S PSOXFLD(3)=$P(VDG,U,1)_U_DXDESC_U_"80"_U_$$GET1^DIQ(80,$P(VDG,U,1)_",",.01)_U_DXDESC_U_"ICD9" + . D SEG + Q +ORC ;Build ORC segment + S PSOLIMIT=15 X PSONFLD + S PSOXFLD(0)="ORC" + S PSOXFLD(1)=$G(PSOPNDST) + S PSOXFLD(3)=PSOPND_"S^PS" + S PSOXFLD(5)=$G(PSOPNDPT) + S X=$P($G(^PS(52.41,PSOPND,0)),"^",6) I X S PSOXFLD(9)=$$FMTHL7^XLFDT(X) + S PSOHENT=$P($G(^PS(52.41,PSOPND,0)),"^",4) I PSOHENT K ^UTILITY("DIQ1",$J) S DIC=200,DR=.01,DA=PSOHENT,DIQ(0)="E" D EN^DIQ1 S PSOXFLD(10)=PSOHENT_"^"_$P($G(^UTILITY("DIQ1",$J,200,PSOHENT,.01,"E")),"^") + S PSOHPRO=$P($G(^PS(52.41,PSOPND,0)),"^",5) I PSOHPRO K ^UTILITY("DIQ1",$J) S DIC=200,DR=.01,DA=PSOHPRO,DIQ(0)="E" D EN^DIQ1 S PSOXFLD(12)=PSOHPRO_"^"_$P($G(^UTILITY("DIQ1",$J,200,PSOHPRO,.01,"E")),"^") + K ^UTILITY("DIQ1",$J) + S X=$P($G(^PS(52.41,PSOPND,0)),"^",12) I X S PSOXFLD(15)=$$FMTHL7^XLFDT(X) + D SEG + Q +RXO ;Build RXO segment + S PSOLIMIT=1 X PSONFLD + S PSOXFLD(0)="RXO" + S PSOHITM=$P($G(^PS(52.41,PSOPND,0)),"^",8) + S PSOXFLD(1)=$S($G(PSOHITM):"^^^"_PSOHITM_"^"_$P($G(^PS(50.7,+$G(PSOHITM),0)),"^")_" "_$P($G(^PS(50.606,+$P($G(^(0)),"^",2),0)),"^")_"^99PSP",1:"^^^^^") + D SEG + Q +RXE ;Build RXE segment + K PSOXFLD S PSOLIMIT=26 X PSONFLD + S PSOXFLD(0)="RXE" + ;No Quantity Timing, since the Sig is entered as free text + S PSOHNDD=$P($G(^PS(52.41,PSOPND,0)),"^",9) + S PSOHND="" I PSOHNDD S PSOHND=$G(^PSDRUG(PSOHNDD,"ND")) + S PSOXFLD(2)=$S($P(PSOHND,"^")&($P(PSOHND,"^",3)):$P(PSOHND,"^")_"."_$P(PSOHND,"^",3)_"^"_$P(PSOHND,"^",2)_"^"_"99NDF",1:"^^")_"^"_$G(PSOHNDD)_"^"_$S($G(PSOHNDD):$P($G(^PSDRUG(PSOHNDD,0)),"^"),1:"")_"^"_"99PSD" + I $P(PSOHND,"^"),$P(PSOHND,"^",3) D + .I $T(^PSNAPIS)]"" S PSOHNDU=$$DFSU^PSNAPIS($P(PSOHND,"^"),$P(PSOHND,"^",3)) S PSOXFLD(5)="^^^"_$P($G(PSOHNDU),"^",5)_"^"_$P($G(PSOHNDU),"^",6)_"^"_"99PSU" + I $G(PSOHITM) S PSOXFLD(6)="^^^"_$P($G(^PS(50.7,$G(PSOHITM),0)),"^",2)_"^"_$P($G(^PS(50.606,+$P($G(^PS(50.7,$G(PSOHITM),0)),"^",2),0)),"^")_"^"_"99PSF" + S PSOXFLD(10)=$P(^PS(52.41,PSOPND,0),"^",10) + S PSOXFLD(12)=$P(^PS(52.41,PSOPND,0),"^",11) + S PSOXFLD(22)=$P(^PS(52.41,PSOPND,0),"^",22) + I $G(PSOHNDD) S PSOHUTL=$$EN^PSSUTIL1(PSOHNDD) S PSOXFLD(25)=$S($E($P(PSOHUTL,"|"),1)=".":"0",1:"")_$P(PSOHUTL,"|"),PSOXFLD(26)=$P(PSOHUTL,"|",2) + ;Create RXE segment, can possibly go over 245 in length + S PSOHCT=PSOHCT+1 + S (PSOHLIPX,PSOHLIPC,PSOHLTTL)=0,PSOHLIP="" F S PSOHLIP=$O(PSOXFLD(PSOHLIP)) Q:PSOHLIP="" D + .I PSOHLIP S PSOXFLD(PSOHLIP)="|"_PSOXFLD(PSOHLIP) + .I PSOHLTTL+$L(PSOXFLD(PSOHLIP))<246 D S PSOHLTTL=PSOHLTTL+$L(PSOXFLD(PSOHLIP)) Q + ..I 'PSOHLIPX S MSG(PSOHCT)=$G(MSG(PSOHCT))_PSOXFLD(PSOHLIP) Q + ..S MSG(PSOHCT,PSOHLIPX)=$G(MSG(PSOHCT,PSOHLIPX))_PSOXFLD(PSOHLIP) + .S PSOHLICP=245-PSOHLTTL + .I 'PSOHLIPX D S PSOHLTTL=$L(MSG(PSOHCT,PSOHLIPX)) Q + ..S MSG(PSOHCT)=$G(MSG(PSOHCT))_$E(PSOXFLD(PSOHLIP),1,PSOHLICP) + ..S PSOHLIPX=1,MSG(PSOHCT,PSOHLIPX)=$E(PSOXFLD(PSOHLIP),(PSOHLICP+1),999) + .S MSG(PSOHCT,PSOHLIPX)=$G(MSG(PSOHCT,PSOHLIPX))_$E(PSOXFLD(PSOHLIP),1,PSOHLICP) + .S PSOHLIPX=PSOHLIPX+1,MSG(PSOHCT,PSOHLIPX)=$E(PSOXFLD(PSOHLIP),(PSOHLICP+1),999) + .S PSOHLTTL=$L(MSG(PSOHCT,PSOHLIPX)) + ;Set NTE segments + S PSOHPCT=0,PSOHCT=PSOHCT+1 I $O(^PS(52.41,PSOPND,3,0)) F PSOHPC=0:0 S PSOHPC=$O(^PS(52.41,PSOPND,3,PSOHPC)) Q:'PSOHPC D + .I $G(^PS(52.41,PSOPND,3,PSOHPC,0))="" Q + .I 'PSOHPCT S MSG(PSOHCT)="NTE|6||"_$G(^PS(52.41,PSOPND,3,PSOHPC,0)) S PSOHPCT=1 Q + .S MSG(PSOHCT,PSOHPCT)=$G(^PS(52.41,PSOPND,3,PSOHPC,0)),PSOHPCT=PSOHPCT+1 + I 'PSOHPCT S PSOHCT=PSOHCT-1 + S PSOHCT=PSOHCT+1,PSOHPCT=0 I $O(^PS(52.41,PSOPND,"SIG",0)) F PSOHPC=0:0 S PSOHPC=$O(^PS(52.41,PSOPND,"SIG",PSOHPC)) Q:'PSOHPC D + .I $G(^PS(52.41,PSOPND,"SIG",PSOHPC,0))="" Q + .I 'PSOHPCT S MSG(PSOHCT)="NTE|21||"_$G(^PS(52.41,PSOPND,"SIG",PSOHPC,0)) S PSOHPCT=1 Q + .S MSG(PSOHCT,PSOHPCT)=$G(^PS(52.41,PSOPND,"SIG",PSOHPC,0)),PSOHPCT=PSOHPCT+1 + I 'PSOHPCT S MSG(PSOHCT)="NTE|21||"_"No SIG available" + Q +RXR ;Build RXR segment + S PSOHRTX="" F PSOHRT=0:0 S PSOHRT=$O(^PS(52.41,PSOPND,1,PSOHRT)) Q:'PSOHRT D + .S PSOHRTX=1 + .S PSOLIMIT=1 X PSONFLD + .S PSOXFLD(0)="RXR" + .S PSOHRTEN="" + .S PSOHRTE=$P($G(^PS(52.41,PSOPND,1,PSOHRT,1)),"^",8) I PSOHRTE,$D(^PS(51.2,PSOHRTE,0)) S PSOHRTEN=$P($G(^(0)),"^") + .S PSOXFLD(1)="^^^"_$G(PSOHRTE)_"^"_$G(PSOHRTEN)_"^"_"99PSR" + .D SEG + I '$G(PSOHRTX) S PSOLIMIT=1 X PSONFLD S PSOXFLD(0)="RXR",PSOXFLD(1)="^^^^^99PSR" D SEG + Q +ZRX ;Build ZRX segment + S PSOLIMIT=6 X PSONFLD + S PSOXFLD(0)="ZRX" + S PSOXFLD(3)="N" + S PSOXFLD(4)=$P($G(^PS(52.41,PSOPND,0)),"^",17) + D SEG + Q +ZCL ;Build ZCL segment + N I,JJJ,INODE,EI + S PSOXFLD(0)="ZCL",PSOLIMIT=3 X PSONFLD + I $D(^PS(52.41,PSOPND,"ICD")) D + .F I=1:1:8 D + ..Q:'$D(^PS(52.41,PSOPND,"ICD",I,0)) + ..S INODE="",INODE=^PS(52.41,PSOPND,"ICD",I,0) + ..F JJJ=2:1:8 S EI=$P(INODE,U,JJJ) D + ...S PSOXFLD(1)=I,PSOXFLD(2)=JJJ-1,PSOXFLD(3)=EI + ...;I JJJ=4 S EI=$S(EI=1:"SC",EI=0:"NSC",1:"") S PSOXFLD(3)=EI + ...D SEG + E D ;if no ICD node, send one ZCL segment + .S PSOXFLD(0)="ZCL",PSOXFLD(1)=1,PSOXFLD(2)=3 + .S PSOXFLD(3)=$S($P(^PS(52.41,PSOPND,0),"^",16)="SC":1,$P(^(0),"^",16)="NSC":0,1:"") + .D SEG + .Q:'$D(^PS(52.41,PSOPND,"IBQ")) + .S EI=^PS(52.41,PSOPND,"IBQ") + .F I=2,3,4,1,5,6 S PSOXFLD(3)=$P(EI,U,I) D + .. S PSOXFLD(2)=$S(I=2:1,I=3:2,I=4:4,I=1:5,I=5:6,I=6:7,1:"") D SEG + Q +ZSC ;Build ZSC segment + S PSOLIMIT=6 X PSONFLD + S PSOXFLD(0)="ZSC" + S PSOXFLD(1)=$S($P(^PS(52.41,PSOPND,0),"^",16)="SC":1,$P(^(0),"^",16)="NSC":0,1:"") + S PSOXFLD(2)=$P($G(^PS(52.41,PSOPND,"IBQ")),"^"),PSOXFLD(3)=$P($G(^("IBQ")),"^",2),PSOXFLD(4)=$P($G(^("IBQ")),"^",3),PSOXFLD(5)=$P($G(^("IBQ")),"^",4),PSOXFLD(6)=$P($G(^("IBQ")),"^",5),PSOXFLD(7)=$P($G(^("IBQ")),"^",6) + D SEG + Q +SEG ; + S PSOSEGMT="" F PSOHJJ=0:1:PSOLIMIT S PSOSEGMT=$S(PSOSEGMT="":PSOXFLD(PSOHJJ),1:PSOSEGMT_"|"_PSOXFLD(PSOHJJ)) + S PSOHCT=PSOHCT+1,MSG(PSOHCT)=PSOSEGMT + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLUP.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLUP.m index 5b887517..74c0dbeb 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLUP.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLUP.m @@ -1,70 +1,69 @@ -PSOHLUP ;BIR/RTR-Backfill OERR from Pharmacy ;7/20/96 - ;;7.0;OUTPATIENT PHARMACY;**5,225**;DEC 1997;Build 29 - ; - ;Pass in patient DFN -EN(PSOEDFN) ; -INPT N PSOC - ;S PSOSHH=$$OTF^OR3CONV(PSOEDFN,$S($G(PSOLOUD):0,1:1)) - Q -EN2 ; - I '$P($G(^PS(55,PSOEDFN,0)),"^",6) D UPD S $P(^PS(55,PSOEDFN,0),"^",6)=1 - Q:'$D(^PS(55,+PSOEDFN,0))!('$G(PSOEDFN)) - Q:$P($G(^PS(55,PSOEDFN,0)),"^",6)=2 - N C,Y,DA,IFN,RXP,DFN,PAT,PSODFN,PSOPPQ,PSOPPQR,PSOYEAR,PSOEST,PSOERSTA,PSOPHSTA,X,T,PRU,PSOCV,PTFLAG,III - ;W:$G(PSOEWRT) !!,"Please wait. Updating CPRS with patient's Outpatient Meds." - ;F PSOCV=0:0 S PSOCV=$O(^PS(55,PSOEDFN,"P","A",PSOCV)) Q:'PSOCV F PSOPPQR=0:0 S PSOPPQR=$O(^PS(55,PSOEDFN,"P","A",PSOCV,PSOPPQR)) Q:'PSOPPQR D UPD - S X1=DT,X2=-121 D C^%DTC S PSOYEAR=X - F PSOPPQ=PSOYEAR:0 S PSOPPQ=$O(^PS(55,PSOEDFN,"P","A",PSOPPQ)) Q:'PSOPPQ F PSOPPQR=0:0 S PSOPPQR=$O(^PS(55,PSOEDFN,"P","A",PSOPPQ,PSOPPQR)) Q:'PSOPPQR D PAT D:$D(^PSRX(PSOPPQR,0))&('$P($G(^PSRX(PSOPPQR,"OR1")),"^",2))&('$G(PTFLAG)) - .Q:'$P($G(^PSRX(PSOPPQR,0)),"^",2) - .S PSOEST=$S($D(^PSRX(PSOPPQR,"STA")):$P($G(^PSRX(PSOPPQR,"STA")),"^"),1:$P($G(^PSRX(PSOPPQR,0)),"^",15)) Q:PSOEST=10!(PSOEST=13)!(PSOEST=16)!(PSOEST=14) - .D:'$P($G(^PSRX(PSOPPQR,0)),"^",19) - ..D:'$P($G(^PSRX(PSOPPQR,"SIG")),"^",2) POP^PSOSIGNO(PSOPPQR) - ..I $P($G(^PSRX(PSOPPQR,"OR1")),"^")']"",+$G(^PSDRUG(+$P(^PSRX(PSOPPQR,0),"^",6),2)) S $P(^PSRX(PSOPPQR,"OR1"),"^")=+$G(^PSDRUG($P(^PSRX(PSOPPQR,0),"^",6),2)) - ..I $G(^PSRX(PSOPPQR,"SIG"))']"" S ^PSRX(PSOPPQR,"SIG")=$P($G(^PSRX(PSOPPQR,0)),"^",10)_"^"_0 S $P(^PSRX(PSOPPQR,0),"^",10)="" - ..S ^PSRX(PSOPPQR,"STA")=$P($G(^PSRX(PSOPPQR,0)),"^",15) S $P(^PSRX(PSOPPQR,0),"^",15)="" - ..S PR=0 F S PR=$O(^PSRX(PSOPPQR,"P",PR)) Q:'PR D - ...I '$P($G(^PSRX(PSOPPQR,"P",PR,0)),"^") K ^PSRX(PSOPPQR,"P",PR,0) Q - ...S ^PSRX("ADP",$E($P(^PSRX(PSOPPQR,"P",PR,0),"^"),1,7),PSOPPQR,PR)="" - ..S $P(^PSRX(PSOPPQR,0),"^",19)=1 - .W:$G(PSOEWRT) "." D EN^PSOHLSN1(PSOPPQR,"ZC","") - .Q:'$P($G(^PSRX(PSOPPQR,"OR1")),"^",2) - .S PSOEST=$P($G(^PSRX(PSOPPQR,"STA")),"^") - .I +$P($G(^PSRX(PSOPPQR,2)),"^",6),$P($G(^(2)),"^",6)
11 - ; -DQ I $D(PSOIOS),PSOIOS]"" D DEVBAR^PSOBMST - I $G(PSOBAR0)]"",$G(PSOBAR1)]"",$D(^PS(59,PSOSITE,1)) S PSOBARS=1 -DQ1 D ^PSOLBL4 - I $G(IOST(0)),$D(^%ZIS(2,IOST(0),55,"B","LL")) G ^PSOLLLI - G:'$D(PPL) HLEX G:($P($G(PSOPAR),"^",30)=2)&('$G(PSOEXREP)) HLEX K RXFLX S PSOCKHN=","_$G(PPL) S PSRESOLV=+PPL D CHECK F PI=1:1 D S RX=$P(PPL,",",PI) D C Q:$G(PSOLAPPL) D:$G(PSDFNFLG) TRAIL^PSOLBL2 K RXP,REPRINT - .S (PSDFNFLG,PSOLAPPL)=0 S NEXTRX=$P(PPL,",",(PI+1)) I NEXTRX=""!(NEXTRX=",") S PSOLAPPL=1 Q - .I PSOPDFN'=$P(^PSRX(NEXTRX,0),"^",2) S PSDFNFLG=1,PSOPDFN=$P(^PSRX(NEXTRX,0),"^",2) Q - I $P(^PS(59,PSOSITE,1),"^",28) D ^PSOLBLN2 - D:'$P(^PS(59,PSOSITE,1),"^",28) ^PSOLBLS -DQ5 I $D(^TMP($J,"PSOCP",DFN)),'$P(^PS(59,PSOSITE,1),"^",28) D INV^PSOCPE -HLEX K RXPI,PSORX,RXP,PSOIOS,PSOLAPPL,XXX,COPAYVAR,TECH,PHYS,MFG,NURSE,STATE,SIDE,COPIES,EXDT,ISD,PSOINST,RXN,RXY,VADT,DEA,WARN,FDT,QTY,PATST,PDA,PS,PS1,PS2,PSL,PSNP,INRX,RR,XTYPE,SSNP,SSNPN,PNM,ADDR,PSODBQ,PSOLASTF,PSRESOLV,PSOEXREP,PSOSXQ - K ^TMP($J,"PSOCP",+$G(PSOCPN)),PSOCPN,PSOLBLDR,PSOLBLPS,PSOLBLCP,RXPR,RXRP,RXRS,PSOCKHN,RXFLX,PSOLAPPL,PSOPDFN,PSDFNFLG,PSOZERO,NEXTRX,PSOBLALL,STA S:'$G(PSOSUREP)&('$G(PSOSUSPR)) ZTREQ="@" Q -C I $G(IOST(0)),$D(^%ZIS(2,IOST(0),55,"B","LL")) G C^PSOLLLI - U IO S X=$S('$P(^PS(59,PSOSITE,1),"^",28):132,1:158) X ^%ZOSF("RM") Q:'$D(^PSRX(RX,0)) - S:$G(PSOBLALL) PSOBLRX=RX - S:$D(RXRP(RX)) REPRINT=1 S:$D(RXPR(RX)) RXP=RXPR(RX) - I $G(PSOSUREP)!($G(PSOEXREP)) S REPRINT=1 S:'$G(RXRP(RX)) RXRP(RX)=1 - S RXY=^PSRX(RX,0),RXSTA=$P(^PSRX(RX,"STA"),"^") I RXSTA>11 D AL("QT") K RXY,RXP,REPRINT Q ;*244 - I RXSTA=3 D AL("QT") K RXY,RXP,REPRINT Q - I $G(RXPR(RX)),'$D(^PSRX(RX,"P",RXP,0)) K RXY,RXP,REPRINT Q - I $P($G(RXFL(RX)),"^"),'$D(^PSRX(RX,1,$P($G(RXFL(RX)),"^"),0)) K RXY,RXP,REPRINT Q - I $G(PSODBQ)!($G(RXRS(RX))) S RR=$O(^PS(52.5,"B",RX,0)) Q:'RR I $G(^PS(52.5,RR,"P"))=1 K RXY,RXP,REPRINT Q - I $G(RXRS(RX))!($G(PSOPULL)) S PSOSXQ=0 N DR,DA,DIE D I $G(PSOSXQ) K RXY,RXP,REPRINT Q - .S DA=$O(^PS(52.5,"B",RX,0)) Q:'DA S A=$P($G(^PS(52.5,DA,0)),"^",7) Q:A="" - .I A="Q" S DIE="^PS(52.5,",DR="3////P" D ^DIE Q - .K RXRS(RX) S PSOSXQ=1 - I $G(PSRESOLV)=RX D ENLBL^PSOBSET K PSRESOLV - I RXSTA'=4 D:$G(PSOSUSPR) AREC^PSOSUTL D:$G(PSOPULL)!($G(RXRS(RX))) AREC1^PSOSUTL D:$G(PSOSUREP) AREC^PSOSUSRP D:$G(PSXREP) AREC^PSXSRP - K ^UTILITY("DIQ1",$J) S DA=$P($$SITE^VASITE(),"^") I $G(DA) S DIC=4,DIQ(0)="I",DR="99" D EN^DIQ1 S PSOINST=$G(^UTILITY("DIQ1",$J,4,DA,99,"I")) K ^UTILITY("DIQ1",$J),DA,DR,DIC - S RXN=$P(RXY,"^"),ISD=$P(RXY,"^",13),RXF=0,DFN=+$P(RXY,"^",2),SIG=$P($G(^PSRX(RX,"SIG")),"^"),ISD=$E(ISD,4,5)_"/"_$E(ISD,6,7)_"/"_($E(ISD,1,3)+1700),ZY=0,$P(LINE,"_",28)="_" - S PSOLBLPS=+$P(RXY,"^",3),PSOLBLDR=+$P(RXY,"^",6) - S NURSE=$S($P($G(^DPT(DFN,"NHC")),"^")="Y":1,$P($G(^PS(55,DFN,40)),"^"):1,1:0) S FDT=$P(^PSRX(RX,2),"^",2),PS=$S($D(^PS(59,PSOSITE,0)):^(0),1:""),PS1=$S($D(^(1)):^(1),1:""),PSOSITE7=$P(^("IB"),"^") - S PS2=$P(PS,"^")_"^"_$P(PS,"^",6) - S (EXPDT,EXDT)=$P(^PSRX(RX,2),"^",6),EXDT=$S('EXDT:"",1:$E(EXDT,4,5)_"/"_$E(EXDT,6,7)_"/"_($E(EXDT,1,3)+1700)) - S COPIES=$S($P($G(RXRP(RX)),"^",2):$P($G(RXRP(RX)),"^",2),$P(RXY,"^",18)]"":$P(RXY,"^",18),1:1) - K PSOCKHNX S PSOCKHL=$L(RX),PSOCKHN=$E($G(PSOCKHN),(PSOCKHL+2),999) D K PSOCKHNX,PSOCKHL,PSOCKHA - .S PSOCKHA=","_RX_"," - .I PSOCKHN'[PSOCKHA Q - .S PSOCKHA=$E(PSOCKHA,1,($L(PSOCKHA)-1)) - .S PSOCKHNX=$L(PSOCKHN,PSOCKHA)-1 - .I +$G(PSOCKHNX)>0 D DOUB - I $O(^PSRX(RX,1,0)),$G(RXFL(RX))'=0 S $P(^PSRX(RX,3),"^",6)="" K ^PSRX(RX,"DAI"),^PSRX(RX,"DRI") - I '$G(RXP),'$O(^PSRX(RX,1,0)) S RXFL(RX)=0 - I '$G(RXP) D OSET I '$O(^PSRX(RX,1,0))!($G(RXFL(RX))=0) G ORIG - I $O(^PSRX(RX,1,0)),'$G(RXP),'$G(RXFL(RX)) S XTYPE=1 D REF G STA - I $O(^PSRX(RX,1,0)),'$G(RXP),$G(RXFL(RX)) G STA - I $G(RXP) S XTYPE="P" D REF G STA -ORIG S TECH=$P($G(^VA(200,+$P(^PSRX(RX,0),"^",16),0)),"^"),QTY=$P(^PSRX(RX,0),"^",7),PHYS=$S($D(^VA(200,+$P(^PSRX(RX,0),"^",4),0)):$P(^(0),"^"),1:"UKN") D 6^VADPT,PID^VADPT S SSNPN=$E($G(VA("PID")),5,12) - S DAYS=$P(^PSRX(RX,0),"^",8),MFG="________",LOT="________" -STA S STATE=$S($D(^DIC(5,+$P(PS,"^",8),0)):$P(^(0),"^",2),1:"UKN") - S DRUG=$$ZZ^PSOSUTL(RX),DEA=$P($G(^PSDRUG(+$P(RXY,"^",6),0)),"^",3),WARN=$P($G(^(0)),"^",8) - S SIDE=$S($P($G(RXRP(RX)),"^",3):1,1:0) - I $G(^PSRX(RX,"P",+$G(RXP),0))]"" S RXPI=RXP D - .S RXP=^PSRX(RX,"P",RXP,0) - .S RXY=$P(RXP,"^")_"^"_$P(RXY,"^",2,6)_"^"_$P(RXP,"^",4)_"^"_$P(RXP,"^",10)_"^"_$P(RXY,"^",9)_"^"_$P($G(^PSRX(RX,"SIG")),"^",2)_"^"_$P(RXP,"^",2)_"^"_$P(RXY,"^",12,14)_"^"_$P(^PSRX(RX,"STA"),"^")_"^"_$P(RXP,"^",7)_"^"_$P(RXY,"^",17,99) - .S FDT=$P(RXP,"^") - S MW=$P(RXY,"^",11) I $G(RXFL(RX))'=0 D:$G(RXFL(RX)) I '$G(RXFL(RX)) F I=0:0 S I=$O(^PSRX(RX,1,I)) Q:'I S RXF=RXF+1 S:'$G(RXP) MW=$P(^PSRX(RX,1,I,0),"^",2) I +^PSRX(RX,1,I,0)'30) - .K PSMP(PSI) - S X=$S($D(^PS(55,DFN,0)):^(0),1:""),PSCAP=$P(X,"^",2),PS55=$P($G(X),"^",3),PS55X=$P($G(X),"^",5) - I (($G(PS55X)]"")&(PS55>1)&(PS55X0,$P(^("STA"),"^")'=2,'$G(PSODBQ) D SNO G LBL - I $G(PSOLBLCP)="" D IBCP - N PSOQI S PSOQI=$G(^PSRX(RX,"IBQ")) I $G(PSOLBLCP)=0 D SNO G LBL - I $G(PSOLBLCP)=1 I $P(PSOQI,"^",2)!($P(PSOQI,"^",3))!($P(PSOQI,"^",4))!($P(PSOQI,"^",5))!($P(PSOQI,"^",6))!($P(PSOQI,"^",7))!($P(PSOQI,"^",8)) D SNO G LBL - I $G(PSOLBLCP)=2 I $P(PSOQI,"^")!($P(PSOQI,"^",2))!($P(PSOQI,"^",3))!($P(PSOQI,"^",4))!($P(PSOQI,"^",5))!($P(PSOQI,"^",6))!($P(PSOQI,"^",7))!($P(PSOQI,"^",8)) D SNO G LBL - I $G(PSOLBLCP)=2,'$P($G(^PSRX(RX,"IB")),"^") D SNO G LBL - S PSOCPN=$P(^PSRX(RX,0),"^",2),INRX=$P(^(0),"^") I $G(^TMP($J,"PSOCP",PSOCPN))="" S ^(PSOCPN)=PSOCPN - S ^TMP($J,"PSOCP",PSOCPN,INRX)=INRX_"^"_$$ZZ^PSOSUTL(RX)_"^"_+$G(DAYS) S COPAYVAR="COPAY" K ZDRUG -LBL G ^PSOLBLD:$P(^PSRX(RX,"STA"),"^")=4 D ^PSOLBLD:$D(^PSRX(RX,"DRI"))&('$G(RXF))&('$G(RXP)) D:$P($G(^PSRX(RX,3)),"^",6)&('$G(RXF))&('$G(RXP)) ^PSOLBLD1 G ^PSOLBL1:'$P(^PS(59,PSOSITE,1),"^",28) - G ^PSOLBLN -REF F XXX=0:0 S XXX=$O(^PSRX(RX,XTYPE,XXX)) Q:+XXX'>0 D - .S TECH=$S($D(^VA(200,+$P(^PSRX(RX,XTYPE,XXX,0),"^",7),0)):$P(^(0),"^"),1:"UNKNOWN") - .S QTY=$P(^PSRX(RX,XTYPE,XXX,0),"^",4),PHYS=$S($D(^VA(200,+$P(^PSRX(RX,XTYPE,XXX,0),"^",17),0)):$P(^(0),"^"),$D(^VA(200,+$P(^PSRX(RX,0),"^",4),0)):$P(^(0),"^"),1:"UNKNOWN") D 6^VADPT,PID^VADPT S SSNPN=$E($G(VA("PID")),5,12) - .S DAYS=$P(^PSRX(RX,XTYPE,XXX,0),"^",10),LOT="________",MFG="________" - Q -CHECK S PSDFNFLG=0,PSOZERO=$P(PPL,","),PSOPDFN=$P(^PSRX(PSOZERO,0),"^",2) - Q -OSET D OSET^PSOLBL1 - Q -DOUB Q:'$D(RXFL(RX)) I +$G(RXFL(RX))-PSOCKHNX<0 Q - S RXFLX(RX)=$G(RXFL(RX)),RXFL(RX)=$G(RXFL(RX))-PSOCKHNX - Q -AL(T) N I,IR,RF,USR,TY,DES S USR="" - I T="UT" D - .N J,RX S USR=$G(DUZ),TY="B",DES="Label never queued to print by User" - .F J=1:1 S RX=+$P(PPL,",",J) Q:'RX D AL1 - I T="QT" D - .S I=+$P(^PSRX(RX,"STA"),"^"),TY=$S((I=3)!(I=16):"H",I=13:"D",1:"C") - .S DES=I_" "_$S((I=3)!(I=16):"HOLD"_$S(I=16:"(PROVIDER)",1:""),(I=12)!(I=14)!(I=15):"DISCONTINUED"_$S(I=14:"(PROVIDER)",I=15:"(EDIT)",1:""),I=13:"DELETED",1:"") - .S DES="Queued label terminated - "_DES D AL1 - K %,%H,%I Q -AL1 S (IR,I,RF)=0 F S I=$O(^PSRX(RX,1,I)) Q:'I S RF=I S:I>5 RF=I+1 - S I=0 F S I=$O(^PSRX(RX,"A",I)) Q:'I S IR=I - S IR=IR+1,^PSRX(RX,"A",0)="^52.3DA^"_IR_"^"_IR - D NOW^%DTC S ^PSRX(RX,"A",IR,0)=%_"^"_TY_"^"_USR_"^"_$S($G(RXPR(RX)):6,1:RF)_"^"_DES - Q -IBCP N X,Y,PSOJJ,PSOLL - S PSOLBLCP="",X=$P($G(^PS(59,+$G(PSOSITE),"IB")),"^")_"^"_$G(DFN) D XTYPE^IBARX - S PSOJJ="" F S PSOJJ=$O(Y(PSOJJ)) Q:'PSOJJ S PSOLL="" F S PSOLL=$O(Y(PSOJJ,PSOLL)) Q:PSOLL="" S:PSOLL>0 PSOLBLCP=PSOLL - I '$G(PSOLBLCP) S PSOLBLCP=0 - Q -SNO S COPAYVAR="NO COPAY" Q +PSOLBL ;BIR/SAB/RTR-BOTTLE LABEL ;6/29/06 11:39am + ;;7.0;OUTPATIENT PHARMACY;**8,19,30,36,47,71,92,120,157,244**;DEC 1997 + ;DBIAs PSDRUG-221, PS(55-2228, IBARX-125, PSXSRP-2201, %ZIS-3435, DPT-3097 + ; + ;*244 remove test for partial fill when testing status > 11 + ; +DQ I $D(PSOIOS),PSOIOS]"" D DEVBAR^PSOBMST + I $G(PSOBAR0)]"",$G(PSOBAR1)]"",$D(^PS(59,PSOSITE,1)) S PSOBARS=1 +DQ1 D ^PSOLBL4 + I $G(IOST(0)),$D(^%ZIS(2,IOST(0),55,"B","LL")) G ^PSOLLLI + G:'$D(PPL) HLEX G:($P($G(PSOPAR),"^",30)=2)&('$G(PSOEXREP)) HLEX K RXFLX S PSOCKHN=","_$G(PPL) S PSRESOLV=+PPL D CHECK F PI=1:1 D S RX=$P(PPL,",",PI) D C Q:$G(PSOLAPPL) D:$G(PSDFNFLG) TRAIL^PSOLBL2 K RXP,REPRINT + .S (PSDFNFLG,PSOLAPPL)=0 S NEXTRX=$P(PPL,",",(PI+1)) I NEXTRX=""!(NEXTRX=",") S PSOLAPPL=1 Q + .I PSOPDFN'=$P(^PSRX(NEXTRX,0),"^",2) S PSDFNFLG=1,PSOPDFN=$P(^PSRX(NEXTRX,0),"^",2) Q + I $P(^PS(59,PSOSITE,1),"^",28) D ^PSOLBLN2 + D:'$P(^PS(59,PSOSITE,1),"^",28) ^PSOLBLS +DQ5 I $D(^TMP($J,"PSOCP",DFN)),'$P(^PS(59,PSOSITE,1),"^",28) D INV^PSOCPE +HLEX K RXPI,PSORX,RXP,PSOIOS,PSOLAPPL,XXX,COPAYVAR,TECH,PHYS,MFG,NURSE,STATE,SIDE,COPIES,EXDT,ISD,PSOINST,RXN,RXY,VADT,DEA,WARN,FDT,QTY,PATST,PDA,PS,PS1,PS2,PSL,PSNP,INRX,RR,XTYPE,SSNP,SSNPN,PNM,ADDR,PSODBQ,PSOLASTF,PSRESOLV,PSOEXREP,PSOSXQ + K ^TMP($J,"PSOCP",+$G(PSOCPN)),PSOCPN,PSOLBLDR,PSOLBLPS,PSOLBLCP,RXPR,RXRP,RXRS,PSOCKHN,RXFLX,PSOLAPPL,PSOPDFN,PSDFNFLG,PSOZERO,NEXTRX,PSOBLALL,STA S:'$G(PSOSUREP)&('$G(PSOSUSPR)) ZTREQ="@" Q +C I $G(IOST(0)),$D(^%ZIS(2,IOST(0),55,"B","LL")) G C^PSOLLLI + U IO S X=$S('$P(^PS(59,PSOSITE,1),"^",28):132,1:158) X ^%ZOSF("RM") Q:'$D(^PSRX(RX,0)) + S:$G(PSOBLALL) PSOBLRX=RX + S:$D(RXRP(RX)) REPRINT=1 S:$D(RXPR(RX)) RXP=RXPR(RX) + I $G(PSOSUREP)!($G(PSOEXREP)) S REPRINT=1 S:'$G(RXRP(RX)) RXRP(RX)=1 + S RXY=^PSRX(RX,0),RXSTA=$P(^PSRX(RX,"STA"),"^") I RXSTA>11 D AL("QT") K RXY,RXP,REPRINT Q ;*244 + I RXSTA=3 D AL("QT") K RXY,RXP,REPRINT Q + I $G(RXPR(RX)),'$D(^PSRX(RX,"P",RXP,0)) K RXY,RXP,REPRINT Q + I $P($G(RXFL(RX)),"^"),'$D(^PSRX(RX,1,$P($G(RXFL(RX)),"^"),0)) K RXY,RXP,REPRINT Q + I $G(PSODBQ)!($G(RXRS(RX))) S RR=$O(^PS(52.5,"B",RX,0)) Q:'RR I $G(^PS(52.5,RR,"P"))=1 K RXY,RXP,REPRINT Q + I $G(RXRS(RX))!($G(PSOPULL)) S PSOSXQ=0 N DR,DA,DIE D I $G(PSOSXQ) K RXY,RXP,REPRINT Q + .S DA=$O(^PS(52.5,"B",RX,0)) Q:'DA S A=$P($G(^PS(52.5,DA,0)),"^",7) Q:A="" + .I A="Q" S DIE="^PS(52.5,",DR="3////P" D ^DIE Q + .K RXRS(RX) S PSOSXQ=1 + I $G(PSRESOLV)=RX D ENLBL^PSOBSET K PSRESOLV + I RXSTA'=4 D:$G(PSOSUSPR) AREC^PSOSUTL D:$G(PSOPULL)!($G(RXRS(RX))) AREC1^PSOSUTL D:$G(PSOSUREP) AREC^PSOSUSRP D:$G(PSXREP) AREC^PSXSRP + K ^UTILITY("DIQ1",$J) S DA=$P($$SITE^VASITE(),"^") I $G(DA) S DIC=4,DIQ(0)="I",DR="99" D EN^DIQ1 S PSOINST=$G(^UTILITY("DIQ1",$J,4,DA,99,"I")) K ^UTILITY("DIQ1",$J),DA,DR,DIC + S RXN=$P(RXY,"^"),ISD=$P(RXY,"^",13),RXF=0,DFN=+$P(RXY,"^",2),SIG=$P($G(^PSRX(RX,"SIG")),"^"),ISD=$E(ISD,4,5)_"/"_$E(ISD,6,7)_"/"_($E(ISD,1,3)+1700),ZY=0,$P(LINE,"_",28)="_" + S PSOLBLPS=+$P(RXY,"^",3),PSOLBLDR=+$P(RXY,"^",6) + S NURSE=$S($P($G(^DPT(DFN,"NHC")),"^")="Y":1,$P($G(^PS(55,DFN,40)),"^"):1,1:0) S FDT=$P(^PSRX(RX,2),"^",2),PS=$S($D(^PS(59,PSOSITE,0)):^(0),1:""),PS1=$S($D(^(1)):^(1),1:""),PSOSITE7=$P(^("IB"),"^") + S PS2=$P(PS,"^")_"^"_$P(PS,"^",6) + S (EXPDT,EXDT)=$P(^PSRX(RX,2),"^",6),EXDT=$S('EXDT:"",1:$E(EXDT,4,5)_"/"_$E(EXDT,6,7)_"/"_($E(EXDT,1,3)+1700)) + S COPIES=$S($P($G(RXRP(RX)),"^",2):$P($G(RXRP(RX)),"^",2),$P(RXY,"^",18)]"":$P(RXY,"^",18),1:1) + K PSOCKHNX S PSOCKHL=$L(RX),PSOCKHN=$E($G(PSOCKHN),(PSOCKHL+2),999) D K PSOCKHNX,PSOCKHL,PSOCKHA + .S PSOCKHA=","_RX_"," + .I PSOCKHN'[PSOCKHA Q + .S PSOCKHA=$E(PSOCKHA,1,($L(PSOCKHA)-1)) + .S PSOCKHNX=$L(PSOCKHN,PSOCKHA)-1 + .I +$G(PSOCKHNX)>0 D DOUB + I $O(^PSRX(RX,1,0)),$G(RXFL(RX))'=0 S $P(^PSRX(RX,3),"^",6)="" K ^PSRX(RX,"DAI"),^PSRX(RX,"DRI") + I '$G(RXP),'$O(^PSRX(RX,1,0)) S RXFL(RX)=0 + I '$G(RXP) D OSET I '$O(^PSRX(RX,1,0))!($G(RXFL(RX))=0) G ORIG + I $O(^PSRX(RX,1,0)),'$G(RXP),'$G(RXFL(RX)) S XTYPE=1 D REF G STA + I $O(^PSRX(RX,1,0)),'$G(RXP),$G(RXFL(RX)) G STA + I $G(RXP) S XTYPE="P" D REF G STA +ORIG S TECH=$P($G(^VA(200,+$P(^PSRX(RX,0),"^",16),0)),"^"),QTY=$P(^PSRX(RX,0),"^",7),PHYS=$S($D(^VA(200,+$P(^PSRX(RX,0),"^",4),0)):$P(^(0),"^"),1:"UKN") D 6^VADPT,PID^VADPT S SSNPN=$E($G(VA("PID")),5,12) + S DAYS=$P(^PSRX(RX,0),"^",8),MFG="________",LOT="________" +STA S STATE=$S($D(^DIC(5,+$P(PS,"^",8),0)):$P(^(0),"^",2),1:"UKN") + S DRUG=$$ZZ^PSOSUTL(RX),DEA=$P($G(^PSDRUG(+$P(RXY,"^",6),0)),"^",3),WARN=$P($G(^(0)),"^",8) + S SIDE=$S($P($G(RXRP(RX)),"^",3):1,1:0) + I $G(^PSRX(RX,"P",+$G(RXP),0))]"" S RXPI=RXP D + .S RXP=^PSRX(RX,"P",RXP,0) + .S RXY=$P(RXP,"^")_"^"_$P(RXY,"^",2,6)_"^"_$P(RXP,"^",4)_"^"_$P(RXP,"^",10)_"^"_$P(RXY,"^",9)_"^"_$P($G(^PSRX(RX,"SIG")),"^",2)_"^"_$P(RXP,"^",2)_"^"_$P(RXY,"^",12,14)_"^"_$P(^PSRX(RX,"STA"),"^")_"^"_$P(RXP,"^",7)_"^"_$P(RXY,"^",17,99) + .S FDT=$P(RXP,"^") + S MW=$P(RXY,"^",11) I $G(RXFL(RX))'=0 D:$G(RXFL(RX)) I '$G(RXFL(RX)) F I=0:0 S I=$O(^PSRX(RX,1,I)) Q:'I S RXF=RXF+1 S:'$G(RXP) MW=$P(^PSRX(RX,1,I,0),"^",2) I +^PSRX(RX,1,I,0)'30) + .K PSMP(PSI) + S X=$S($D(^PS(55,DFN,0)):^(0),1:""),PSCAP=$P(X,"^",2),PS55=$P($G(X),"^",3),PS55X=$P($G(X),"^",5) + I (($G(PS55X)]"")&(PS55>1)&(PS55X0,$P(^("STA"),"^")'=2,'$G(PSODBQ) D SNO G LBL + I $G(PSOLBLCP)="" D IBCP + N PSOQI S PSOQI=$G(^PSRX(RX,"IBQ")) I $G(PSOLBLCP)=0 D SNO G LBL + I $G(PSOLBLCP)=1 I $P(PSOQI,"^",2)!($P(PSOQI,"^",3))!($P(PSOQI,"^",4))!($P(PSOQI,"^",5))!($P(PSOQI,"^",6))!($P(PSOQI,"^",7)) D SNO G LBL + I $G(PSOLBLCP)=2 I $P(PSOQI,"^")!($P(PSOQI,"^",2))!($P(PSOQI,"^",3))!($P(PSOQI,"^",4))!($P(PSOQI,"^",5))!($P(PSOQI,"^",6))!($P(PSOQI,"^",7)) D SNO G LBL + I $G(PSOLBLCP)=2,'$P($G(^PSRX(RX,"IB")),"^") D SNO G LBL + S PSOCPN=$P(^PSRX(RX,0),"^",2),INRX=$P(^(0),"^") I $G(^TMP($J,"PSOCP",PSOCPN))="" S ^(PSOCPN)=PSOCPN + S ^TMP($J,"PSOCP",PSOCPN,INRX)=INRX_"^"_$$ZZ^PSOSUTL(RX)_"^"_+$G(DAYS) S COPAYVAR="COPAY" K ZDRUG +LBL G ^PSOLBLD:$P(^PSRX(RX,"STA"),"^")=4 D ^PSOLBLD:$D(^PSRX(RX,"DRI"))&('$G(RXF))&('$G(RXP)) D:$P($G(^PSRX(RX,3)),"^",6)&('$G(RXF))&('$G(RXP)) ^PSOLBLD1 G ^PSOLBL1:'$P(^PS(59,PSOSITE,1),"^",28) + G ^PSOLBLN +REF F XXX=0:0 S XXX=$O(^PSRX(RX,XTYPE,XXX)) Q:+XXX'>0 D + .S TECH=$S($D(^VA(200,+$P(^PSRX(RX,XTYPE,XXX,0),"^",7),0)):$P(^(0),"^"),1:"UNKNOWN") + .S QTY=$P(^PSRX(RX,XTYPE,XXX,0),"^",4),PHYS=$S($D(^VA(200,+$P(^PSRX(RX,XTYPE,XXX,0),"^",17),0)):$P(^(0),"^"),$D(^VA(200,+$P(^PSRX(RX,0),"^",4),0)):$P(^(0),"^"),1:"UNKNOWN") D 6^VADPT,PID^VADPT S SSNPN=$E($G(VA("PID")),5,12) + .S DAYS=$P(^PSRX(RX,XTYPE,XXX,0),"^",10),LOT="________",MFG="________" + Q +CHECK S PSDFNFLG=0,PSOZERO=$P(PPL,","),PSOPDFN=$P(^PSRX(PSOZERO,0),"^",2) + Q +OSET I $G(RXFL(RX))']""!($G(RXFL(RX))=0) D Q + .S TECH=$P($G(^VA(200,+$P(^PSRX(RX,0),"^",16),0)),"^"),QTY=$P(^PSRX(RX,0),"^",7),PHYS=$S($D(^VA(200,+$P(^PSRX(RX,0),"^",4),0)):$P(^(0),"^"),1:"UKN") D 6^VADPT,PID^VADPT S SSNPN=$E($G(VA("PID")),5,12) + .S DAYS=$P(^PSRX(RX,0),"^",8),MFG="________",LOT="________" + I '$D(^PSRX(RX,1,RXFL(RX),0)) K RXFL(RX) Q + S TECH=$S($D(^VA(200,+$P(^PSRX(RX,1,RXFL(RX),0),"^",7),0)):$P(^(0),"^"),1:"UNKNOWN") + S QTY=$P(^PSRX(RX,1,RXFL(RX),0),"^",4),PHYS=$S($D(^VA(200,+$P(^PSRX(RX,1,RXFL(RX),0),"^",17),0)):$P(^(0),"^"),$D(^VA(200,+$P(^PSRX(RX,0),"^",4),0)):$P(^(0),"^"),1:"UNKNOWN") D 6^VADPT,PID^VADPT S SSNPN=$E($G(VA("PID")),5,12) + S DAYS=$P(^PSRX(RX,1,RXFL(RX),0),"^",10),LOT="________",MFG="________" + Q +DOUB Q:'$D(RXFL(RX)) I +$G(RXFL(RX))-PSOCKHNX<0 Q + S RXFLX(RX)=$G(RXFL(RX)),RXFL(RX)=$G(RXFL(RX))-PSOCKHNX + Q +AL(T) N I,IR,RF,USR,TY,DES S USR="" + I T="UT" D + .N J,RX S USR=$G(DUZ),TY="B",DES="Label never queued to print by User" + .F J=1:1 S RX=+$P(PPL,",",J) Q:'RX D AL1 + I T="QT" D + .S I=+$P(^PSRX(RX,"STA"),"^"),TY=$S((I=3)!(I=16):"H",I=13:"D",1:"C") + .S DES=I_" "_$S((I=3)!(I=16):"HOLD"_$S(I=16:"(PROVIDER)",1:""),(I=12)!(I=14)!(I=15):"DISCONTINUED"_$S(I=14:"(PROVIDER)",I=15:"(EDIT)",1:""),I=13:"DELETED",1:"") + .S DES="Queued label terminated - "_DES D AL1 + K %,%H,%I Q +AL1 S (IR,I,RF)=0 F S I=$O(^PSRX(RX,1,I)) Q:'I S RF=I S:I>5 RF=I+1 + S I=0 F S I=$O(^PSRX(RX,"A",I)) Q:'I S IR=I + S IR=IR+1,^PSRX(RX,"A",0)="^52.3DA^"_IR_"^"_IR + D NOW^%DTC S ^PSRX(RX,"A",IR,0)=%_"^"_TY_"^"_USR_"^"_$S($G(RXPR(RX)):6,1:RF)_"^"_DES + Q +IBCP N X,Y,PSOJJ,PSOLL + S PSOLBLCP="",X=$P($G(^PS(59,+$G(PSOSITE),"IB")),"^")_"^"_$G(DFN) D XTYPE^IBARX + S PSOJJ="" F S PSOJJ=$O(Y(PSOJJ)) Q:'PSOJJ S PSOLL="" F S PSOLL=$O(Y(PSOJJ,PSOLL)) Q:PSOLL="" S:PSOLL>0 PSOLBLCP=PSOLL + I '$G(PSOLBLCP) S PSOLBLCP=0 + Q +SNO S COPAYVAR="NO COPAY" Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLBL1.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLBL1.m index 332c7aed..8effefd9 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLBL1.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLBL1.m @@ -1,55 +1,45 @@ -PSOLBL1 ;BHAM ISC/SAB - PRINTS LABEL ;1/20/93 14:25 - ;;7.0;OUTPATIENT PHARMACY;**107,110,225**;DEC 1997;Build 29 -START S COPIES=COPIES-1 - W $C(13) S $X=0 W "VA (119)",?10,$E(DT,4,5),"/",$E(DT,6,7),"/",$E(DT,2,3) W:('SIDE)&(PRTFL) ?40,"PLEASE REFER ONLY TO '",$S(REF:"1. REFILL REQUEST",1:"2. RENEWAL ORDER"),"'" W:+$G(RXP) ?100,"(PARTIAL)" W:$D(REPRINT) ?110,"(REPRINT)" - W !,$P(PS,"^",2) W:('SIDE)&(PRTFL) ?40,"INSTRUCTION ON REVERSE SIDE OF THIS FORM" W:'SIDE ?102,"(Filled at ",$P(PS2,"^",2),")" - W !,$P(PS,"^",7),", ",STATE," ",$P(PS,"^",5) W:'SIDE ?83,"*** ",$P(PS2,"^")," ***" - W !,?22,$S(MW["C":"CERTIFIED MAIL",1:"") W:'SIDE ?38,SSNP,?69,"RX: ",RXN - W !,?2,PNM W:'SIDE ?38,PNM,?64,"EXPIRES: ",EXDT W:('SIDE)&(PRTFL) ?83,"INDICATE ANY ADDRESS CHANGES" - W !,?2,$S($D(PSMP(1)):PSMP(1),1:VAPA(1)) W:'SIDE ?38,$E(VAPA(1),1,25),?64,"REFILLS: ",REF ;W:('SIDE)&(PRTFL) ?83,LINE - W:('SIDE)&(PRTFL) ?83,"_____PERM. _____TEMP." W:'PRTFL ?83,"* A 'NEW' RX IS REQUIRED. *" - S ADDR(3)=VAPA(4)_", "_$P($G(^DIC(5,+$P(VAPA(5),"^"),0)),"^",2)_" "_VAPA(6),ADDR(2)="" S:VAPA(2)]"" ADDR(2)=VAPA(2)_" "_VAPA(3) - I ADDR(2)="" S ADDR(2)=ADDR(3),ADDR(3)="" - S ADDR(5)=$E(VAPA(4),1,13)_", "_$P($G(^DIC(5,+$P(VAPA(5),"^"),0)),"^",2)_" "_VAPA(6) - W !,?2,$S($D(PSMP(2)):PSMP(2),$D(PSMP(1)):"",1:$E(ADDR(2),1,35)) W:'SIDE ?38,$S($G(ADDR(3))="":ADDR(5),1:$E(ADDR(2),1,24)),?62,$S(RFLMSG]"":"*",1:" "),"LST FILL: " - W:'SIDE $G(PSOLASTF) - I 'SIDE W:PRTFL ?83,"ADDRESS: ",$E(LINE,1,23) W:'PRTFL ?83,"********** PLEASE NOTE ***********" - W !,?2,$S($D(PSMP(3)):PSMP(3),$D(PSMP(1)):"",1:ADDR(3)) I 'SIDE W ?38,$S(ADDR(3)'="":ADDR(5),1:""),?64,"ROUTING: ",$S(MW="REGULAR":"MAIL",1:MW) W:PRTFL ?83,"CITY/STATE/ZIP: ",$E(LINE,1,16) W:'PRTFL ?83,"* THIS RX CAN NOT BE 'RENEWED'. *" - ;NEW LABEL WHITE SPACE - I +$G(PSOBARS),'SIDE,$P(PSOPAR,"^",19)'=1 S X="S",X2=PSOINST_"-"_RX W !,?40 S X1=$X W @PSOBAR1,X2,@PSOBAR0,$C(13),!,$S($G(PS55)=2:"***DO NOT MAIL***",1:"**CRITICAL MEDICAL SHIPMENT**"),! - E F NLWS=1:1:6 W ! W:NLWS=5 $S($G(PS55)=2:"***DO NOT MAIL***",1:"**CRITICAL MEDICAL SHIPMENT**") - W !,?8,"VA Medical Center" I 'SIDE W ?38,INT(1) - W !,$P(PS,"^")," ",$P(PS,"^",3),"-",$P(PS,"^",4) W:'SIDE ?38,INT(2) I 'SIDE W:PRTFL ?83 W:'PRTFL ?83,"* PLEASE CONTACT YOUR PHYSICIAN. *" - W !,?4,RXN,?15,$E(DATE,4,5),"/",$E(DATE,6,7),"/",$E(DATE,2,3)," (",RXF+1," OF ",1+$P(RXY,"^",9),")" I 'SIDE W ?38,INT(3) W:(PRTFL)&('REF) ?83,"***** FOR PHYSICIAN USE ONLY *****" W:'PRTFL ?83,"**********************************" - W !,PNM,?29,"#",$P(RXY,"^",7) - W:'SIDE ?38,"CAP: ",$S(PSCAP:"**NON-SFTY**",1:"SAFETY")," WARN:",WARN,?68,$E(DATE,4,5),"/",$E(DATE,6,7),"/",$E(DATE,2,3)," " S I1=$P($H,",",2)\60 W:'SIDE I1\60,":",(I1#60\10)_(I1#10) W:('SIDE)&(PRTFL) ?83,"SIGNATURE : ",$E(LINE,1,20) -SIG F DR=1:1:$S(SGC<5:4,1:6) D SIG1 - I SGC>4 F I=1:1:22 W ! I I>22-SGC S DR=DR+1,X=$S($D(SGY(DR)):SGY(DR),1:"") W X W:'SIDE ?38,X - ;I SGC>4 F I=1:1:$S($P($G(PSOPAR),"^",10):22,1:16) W ! I I>($S($P($G(PSOPAR),"^",10):28,1:22)-SGC) S DR=DR+1,X=$S($D(SGY(DR)):SGY(DR),1:"") W X W:'SIDE ?38,X - W !?3,$E(PHYS,1,14),?25,"(",$P(RXY,"^",16),"/",$S($D(VRPH):VRPH,1:" "),")" W:'SIDE ?38,DRUG,?38+$L(DRUG)," (QTY:",$P(RXY,"^",7)," DAYS:",$P(RXY,"^",8)," FILL: ",RXF+1," OF ",1+$P(RXY,"^",9)," ISD:",ISD,")" - W !,DRUG W:'SIDE ?38,PHYS,?62,RFLMSG,?100,PATST," ",PSCLN - I $D(PSOBARS),PSOBARS W $C(13),# S $X=0 - E W ! - I COPIES>0 S SIDE=1 G START - ;STORE LABEL PRINT NODE - D NOW^%DTC S NOW=% K %,%H,%I S RXF=0 F I=0:0 S I=$O(^PSRX(RX,1,I)) Q:'I S RXF=I - S IR=0 F FDA=0:0 S FDA=$O(^PSRX(RX,"L",FDA)) Q:'FDA S IR=FDA - S IR=IR+1,^PSRX(RX,"L",0)="^52.032DA^"_IR_"^"_IR - S ^PSRX(RX,"L",IR,0)=NOW_"^"_$S($G(RXP):99-RXPI,1:RXF)_"^"_$S($G(PCOMX)]"":$G(PCOMX),1:"From RX number "_$P(^PSRX(RX,0),"^"))_$S($G(RXP):" (Partial)",1:"")_$S($D(REPRINT):" (Reprint)",1:"")_"^"_PDUZ - S ^PSRX(RX,"TYPE")=0 K RXF,IR,FDA,NOW,I - I '$D(PSSPND),$P(PSOPAR,"^",18) D CHCK2^PSOTRLBL -END K PSCLN,%DT,ADDR,DATE,DEA,DR,DR1,DRX,DRUG,FDT,SGY,RXY,RXZ,RYY,RFLMSG,RFL,%H,COPIES,DOB,DRUG,LIM,LMI,LINE,PS,PS1,PS2,INT,ISD,I1,MW,MAIL,STATE,SIDE,SSNP,SS,ST,ST1,PATST,PRTFL,PHYS,PNM,S,SL,SGC,PSMP,PSI,PSJ,VRPH,REPRINT,PS55,PS55X Q - Q - ; -SIG1 S X=$S($D(SGY(DR)):SGY(DR),1:"") W !,X - I 'SIDE W ?38,X I PRTFL W ?83 W:DR=1 ?83,$S('REF:"PRINT NAME: "_$E(LINE,1,25),1:"") W:DR=2 "DATE: ",$E(LINE,1,10) W:(DR=2)&('REF) " DEA# ",$E(LINE,1,6) W:(DR=3)&('REF) "Refills: 0 1 2 3 4 5 6 7 8 9 10 11" - Q - ; -OSET I $G(RXFL(RX))']""!($G(RXFL(RX))=0) D Q - .S TECH=$P($G(^VA(200,+$P(^PSRX(RX,0),"^",16),0)),"^"),QTY=$P(^PSRX(RX,0),"^",7),PHYS=$S($D(^VA(200,+$P(^PSRX(RX,0),"^",4),0)):$P(^(0),"^"),1:"UKN") D 6^VADPT,PID^VADPT S SSNPN=$E($G(VA("PID")),5,12) - .S DAYS=$P(^PSRX(RX,0),"^",8),MFG="________",LOT="________" - I '$D(^PSRX(RX,1,RXFL(RX),0)) K RXFL(RX) Q - S TECH=$S($D(^VA(200,+$P(^PSRX(RX,1,RXFL(RX),0),"^",7),0)):$P(^(0),"^"),1:"UNKNOWN") - S QTY=$P(^PSRX(RX,1,RXFL(RX),0),"^",4),PHYS=$S($D(^VA(200,+$P(^PSRX(RX,1,RXFL(RX),0),"^",17),0)):$P(^(0),"^"),$D(^VA(200,+$P(^PSRX(RX,0),"^",4),0)):$P(^(0),"^"),1:"UNKNOWN") D 6^VADPT,PID^VADPT S SSNPN=$E($G(VA("PID")),5,12) - S DAYS=$P(^PSRX(RX,1,RXFL(RX),0),"^",10),LOT="________",MFG="________" - Q +PSOLBL1 ;BHAM ISC/SAB - PRINTS LABEL ;1/20/93 14:25 + ;;7.0;OUTPATIENT PHARMACY;**107,110**;DEC 1997 +START S COPIES=COPIES-1 + W $C(13) S $X=0 W "VA (119)",?10,$E(DT,4,5),"/",$E(DT,6,7),"/",$E(DT,2,3) W:('SIDE)&(PRTFL) ?40,"PLEASE REFER ONLY TO '",$S(REF:"1. REFILL REQUEST",1:"2. RENEWAL ORDER"),"'" W:+$G(RXP) ?100,"(PARTIAL)" W:$D(REPRINT) ?110,"(REPRINT)" + W !,$P(PS,"^",2) W:('SIDE)&(PRTFL) ?40,"INSTRUCTION ON REVERSE SIDE OF THIS FORM" W:'SIDE ?102,"(Filled at ",$P(PS2,"^",2),")" + W !,$P(PS,"^",7),", ",STATE," ",$P(PS,"^",5) W:'SIDE ?83,"*** ",$P(PS2,"^")," ***" + W !,?22,$S(MW["C":"CERTIFIED MAIL",1:"") W:'SIDE ?38,SSNP,?69,"RX: ",RXN + W !,?2,PNM W:'SIDE ?38,PNM,?64,"EXPIRES: ",EXDT W:('SIDE)&(PRTFL) ?83,"INDICATE ANY ADDRESS CHANGES" + W !,?2,$S($D(PSMP(1)):PSMP(1),1:VAPA(1)) W:'SIDE ?38,$E(VAPA(1),1,25),?64,"REFILLS: ",REF ;W:('SIDE)&(PRTFL) ?83,LINE + W:('SIDE)&(PRTFL) ?83,"_____PERM. _____TEMP." W:'PRTFL ?83,"* A 'NEW' RX IS REQUIRED. *" + S ADDR(3)=VAPA(4)_", "_$P($G(^DIC(5,+$P(VAPA(5),"^"),0)),"^",2)_" "_VAPA(6),ADDR(2)="" S:VAPA(2)]"" ADDR(2)=VAPA(2)_" "_VAPA(3) + I ADDR(2)="" S ADDR(2)=ADDR(3),ADDR(3)="" + S ADDR(5)=$E(VAPA(4),1,13)_", "_$P($G(^DIC(5,+$P(VAPA(5),"^"),0)),"^",2)_" "_VAPA(6) + W !,?2,$S($D(PSMP(2)):PSMP(2),$D(PSMP(1)):"",1:$E(ADDR(2),1,35)) W:'SIDE ?38,$S($G(ADDR(3))="":ADDR(5),1:$E(ADDR(2),1,24)),?62,$S(RFLMSG]"":"*",1:" "),"LST FILL: " + W:'SIDE $G(PSOLASTF) + I 'SIDE W:PRTFL ?83,"ADDRESS: ",$E(LINE,1,23) W:'PRTFL ?83,"********** PLEASE NOTE ***********" + W !,?2,$S($D(PSMP(3)):PSMP(3),$D(PSMP(1)):"",1:ADDR(3)) I 'SIDE W ?38,$S(ADDR(3)'="":ADDR(5),1:""),?64,"ROUTING: ",$S(MW="REGULAR":"MAIL",1:MW) W:PRTFL ?83,"CITY/STATE/ZIP: ",$E(LINE,1,16) W:'PRTFL ?83,"* THIS RX CAN NOT BE 'RENEWED'. *" + ;NEW LABEL WHITE SPACE + I +$G(PSOBARS),'SIDE,$P(PSOPAR,"^",19)'=1 S X="S",X2=PSOINST_"-"_RX W !,?40 S X1=$X W @PSOBAR1,X2,@PSOBAR0,$C(13),!,$S($G(PS55)=2:"***DO NOT MAIL***",1:"**CRITICAL MEDICAL SHIPMENT**"),! + E F NLWS=1:1:6 W ! W:NLWS=5 $S($G(PS55)=2:"***DO NOT MAIL***",1:"**CRITICAL MEDICAL SHIPMENT**") + W !,?8,"VA Medical Center" I 'SIDE W ?38,INT(1) + W !,$P(PS,"^")," ",$P(PS,"^",3),"-",$P(PS,"^",4) W:'SIDE ?38,INT(2) I 'SIDE W:PRTFL ?83 W:'PRTFL ?83,"* PLEASE CONTACT YOUR PHYSICIAN. *" + W !,?4,RXN,?15,$E(DATE,4,5),"/",$E(DATE,6,7),"/",$E(DATE,2,3)," (",RXF+1," OF ",1+$P(RXY,"^",9),")" I 'SIDE W ?38,INT(3) W:(PRTFL)&('REF) ?83,"***** FOR PHYSICIAN USE ONLY *****" W:'PRTFL ?83,"**********************************" + W !,PNM,?29,"#",$P(RXY,"^",7) + W:'SIDE ?38,"CAP: ",$S(PSCAP:"**NON-SFTY**",1:"SAFETY")," WARN:",WARN,?68,$E(DATE,4,5),"/",$E(DATE,6,7),"/",$E(DATE,2,3)," " S I1=$P($H,",",2)\60 W:'SIDE I1\60,":",(I1#60\10)_(I1#10) W:('SIDE)&(PRTFL) ?83,"SIGNATURE : ",$E(LINE,1,20) +SIG F DR=1:1:$S(SGC<5:4,1:6) D SIG1 + I SGC>4 F I=1:1:22 W ! I I>22-SGC S DR=DR+1,X=$S($D(SGY(DR)):SGY(DR),1:"") W X W:'SIDE ?38,X + ;I SGC>4 F I=1:1:$S($P($G(PSOPAR),"^",10):22,1:16) W ! I I>($S($P($G(PSOPAR),"^",10):28,1:22)-SGC) S DR=DR+1,X=$S($D(SGY(DR)):SGY(DR),1:"") W X W:'SIDE ?38,X + W !?3,$E(PHYS,1,14),?25,"(",$P(RXY,"^",16),"/",$S($D(VRPH):VRPH,1:" "),")" W:'SIDE ?38,DRUG,?38+$L(DRUG)," (QTY:",$P(RXY,"^",7)," DAYS:",$P(RXY,"^",8)," FILL: ",RXF+1," OF ",1+$P(RXY,"^",9)," ISD:",ISD,")" + W !,DRUG W:'SIDE ?38,PHYS,?62,RFLMSG,?100,PATST," ",PSCLN + I $D(PSOBARS),PSOBARS W $C(13),# S $X=0 + E W ! + I COPIES>0 S SIDE=1 G START + ;STORE LABEL PRINT NODE + D NOW^%DTC S NOW=% K %,%H,%I S RXF=0 F I=0:0 S I=$O(^PSRX(RX,1,I)) Q:'I S RXF=I + S IR=0 F FDA=0:0 S FDA=$O(^PSRX(RX,"L",FDA)) Q:'FDA S IR=FDA + S IR=IR+1,^PSRX(RX,"L",0)="^52.032DA^"_IR_"^"_IR + S ^PSRX(RX,"L",IR,0)=NOW_"^"_$S($G(RXP):99-RXPI,1:RXF)_"^"_$S($G(PCOMX)]"":$G(PCOMX),1:"From RX number "_$P(^PSRX(RX,0),"^"))_$S($G(RXP):" (Partial)",1:"")_$S($D(REPRINT):" (Reprint)",1:"")_"^"_PDUZ + S ^PSRX(RX,"TYPE")=0 K RXF,IR,FDA,NOW,I + I '$D(PSSPND),$P(PSOPAR,"^",18) D CHCK2^PSOTRLBL +END K PSCLN,%DT,ADDR,DATE,DEA,DR,DR1,DRX,DRUG,FDT,SGY,RXY,RXZ,RYY,RFLMSG,RFL,%H,COPIES,DOB,DRUG,LIM,LMI,LINE,PS,PS1,PS2,INT,ISD,I1,MW,MAIL,STATE,SIDE,SSNP,SS,ST,ST1,PATST,PRTFL,PHYS,PNM,S,SL,SGC,PSMP,PSI,PSJ,VRPH,REPRINT,PS55,PS55X Q + Q + ; +SIG1 S X=$S($D(SGY(DR)):SGY(DR),1:"") W !,X + I 'SIDE W ?38,X I PRTFL W ?83 W:DR=1 ?83,$S('REF:"PRINT NAME: "_$E(LINE,1,25),1:"") W:DR=2 "DATE: ",$E(LINE,1,10) W:(DR=2)&('REF) " DEA# ",$E(LINE,1,6) W:(DR=3)&('REF) "Refills: 0 1 2 3 4 5 6 7 8 9 10 11" diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLBL4.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLBL4.m index bb244e20..c91a0b7f 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLBL4.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLBL4.m @@ -1,112 +1,127 @@ -PSOLBL4 ;BIR/RTR-Set up routine for HL7 interface ;12/19/06 10:45am - ;;7.0;OUTPATIENT PHARMACY;**26,70,156,244,233,246**;DEC 1997;Build 12 - ;External reference to ^PSDRUG supported by DBIA 221 - ; - ;*244 - ignore RX's with a status > 11 - ;*246 - send marked drugs & print label (option 4) now working - ; - N DIC,AP,X,Y,DPRT,QPRT - I $G(ZTIO)]"" D - .Q:'$O(^PS(59,PSOSITE,"P",0)) - .S DIC=3.5,DIC(0)="",X=ZTIO D ^DIC K DIC,X Q:Y=-1 - .S DPRT=+Y - .F AP=0:0 S AP=$O(^PS(59,PSOSITE,"P",AP)) Q:'AP I +$P(^PS(59,PSOSITE,"P",AP,0),"^")=DPRT S QPRT=1 - .I '$G(QPRT) S $P(PSOPAR,"^",30)=0 - Q:'$P($G(PSOPAR),"^",30) ;HL7 interface turned off - Q:$G(PSOEXREP) -HL N PSODTM,HHHH,PSOQUE,HLFLAG,HLFOUR,HLINGF,HLINRX,HLINRX0,II,HLNEXT,HLRR,HLRX,HLRXY,LL,PPLHL,PSHALP,HDFN,HLDFN,HNEWDFN,HLDAI,HLOSITE,HLJUST,HLRXYZ,PSOLLN,PSOLLL,PSFLG,HDFN1,NOTMD - S HLOSITE=$P($G(PSOPAR),"^",30) - K ^UTILITY($J,"PSOHL"),^UTILITY($J,"PSOHLL"),HLRXY - S PPLHL=PPL - S HLFLAG=0 F II=1:1 S HLRX=$P(PPLHL,",",II) D Q:$G(HLFLAG) - .S HLNEXT=$P(PPLHL,",",(II+1)) I HLNEXT=""!(HLNEXT=",") S HLFLAG=1 - .Q:'$G(HLRX) - .Q:'$D(^PSRX(HLRX,0)) - .Q:$P($G(^PSRX(HLRX,"STA")),"^")=4 - .Q:$G(RXRP(HLRX,"RP")) - .I $P($G(^PSRX(HLRX,"STA")),"^")>11!('$P(^PSRX(HLRX,0),"^",2)) Q - .I $G(PSODBQ) S HLRR=$O(^PS(52.5,"B",HLRX,0)) Q:'HLRR I $G(^PS(52.5,+HLRR,"P"))=1 Q - .; marked drug options 3 & 4 - .I (HLOSITE=3)!(HLOSITE=4) S NOTMD=0 D Q:NOTMD ;quit, not marked - ..S HLJUST=+$P($G(^PSRX(HLRX,0)),"^",6) - ..S:'$P($G(^PSDRUG(HLJUST,6)),"^") NOTMD=1 - .S HLRXY(II,HLRX)="" ;Valid Rx for HL7 - .S:HLOSITE=3 HLRXYZ(HLRX)="" - ; - I $G(HLOSITE)=3,$D(HLRXY) D ;rebuild PPL print string - .K PPL F II=1:1 S HLRX=$P(PPLHL,",",II) Q:'HLRX D - ..Q:$D(HLRXYZ(HLRX)) - ..S PPL=$G(PPL)_HLRX_"," - ; -SOMDQ S (II,PSOQUE)=0 F S II=$O(HLRXY(II)) Q:'II S ^UTILITY($J,"PSOHLL",II)=$O(HLRXY(II,0)),PSOQUE=II - I PSOQUE=0 G ENDHL ;Nothing set, bypass Call to Queue - F II=0:0 S II=$O(^UTILITY($J,"PSOHLL",II)) Q:'II S HLINRX=^(II),HLINRX0=$G(^PSRX(HLINRX,0)) D - .S ^UTILITY($J,"PSOHLL",II)=HLINRX_"^"_+$P(HLINRX0,"^",6)_"^"_$S($G(RXPR(HLINRX)):"P",1:"F") - .I '$G(RXPR(HLINRX)) S HLFOUR=0 F HHHH=0:0 S HHHH=$O(^PSRX(HLINRX,1,HHHH)) Q:'HHHH I +^(HHHH,0) S HLFOUR=HHHH - .I '$G(RXPR(HLINRX)),$G(RXFL(HLINRX))'="" S HLFOUR=$S($G(RXFL(HLINRX))=0:0,$D(^PSRX(HLINRX,1,+$G(RXFL(HLINRX)),0)):+$G(RXFL(HLINRX)),1:$G(HLFOUR)) - .S ^UTILITY($J,"PSOHLL",II)=^UTILITY($J,"PSOHLL",II)_"^"_$S($G(RXPR(HLINRX)):RXPR(HLINRX),1:HLFOUR)_"^"_$S($P($G(^PSRX(HLINRX,3)),"^",6)&('$G(RXPR(HLINRX)))&('$G(RXFL(HLINRX))):1,1:0) D ACLOG - .S HLINGF=0 I $P(^UTILITY($J,"PSOHLL",II),"^",5),$O(^PSRX(HLINRX,"DAI",0)) S HLINGF=1 D - ..F LL=0:0 S LL=$O(^PSRX(HLINRX,"DAI",LL)) Q:'LL S ^UTILITY($J,"PSOHLL",II,HLINGF)=$G(^PSRX(HLINRX,"DAI",LL,0)),HLINGF=HLINGF+1 - .S $P(^UTILITY($J,"PSOHLL",II),"^",6)=$S($G(HLINGF):1,1:0) - .I $D(^PSRX(HLINRX,"DRI")),'$G(RXPR(HLINRX)),'$G(RXFL(HLINRX)) S ^UTILITY($J,"PSOHLL",II,"DRI")=^PSRX(HLINRX,"DRI"),$P(^UTILITY($J,"PSOHLL",II),"^",7)=1 - .E S $P(^UTILITY($J,"PSOHLL",II),"^",7)=0 - .S $P(^UTILITY($J,"PSOHLL",II),"^",8)=0 D RPT Q:'$G(^PSRX(HLINRX,"IB")) - .I $P(^PSRX(HLINRX,"STA"),"^")>0,$P(^("STA"),"^")'=2,'$G(PSODBQ) Q - .S $P(^UTILITY($J,"PSOHLL",II),"^",8)=1 - ; -AAA D STRT^PSOHLSG5 - S (HDFN,HDFN1)=$O(^UTILITY($J,"PSOHLL",0)),HDFN=$P(^PSRX($P(^(HDFN),"^"),0),"^",2),PSOLLL=$P(^UTILITY($J,"PSOHLL",HDFN1),"^",12) - F HLDFN=0:0 S HLDFN=$O(^UTILITY($J,"PSOHLL",HLDFN)) Q:'HLDFN D S ^UTILITY($J,"PSOHL",HLDFN)=^UTILITY($J,"PSOHLL",HLDFN) D OTHER - .S PSFLG=0,PSOLLN=$P(^UTILITY($J,"PSOHLL",HLDFN),"^",12),HNEWDFN=$P(^PSRX($P(^UTILITY($J,"PSOHLL",HLDFN),"^"),0),"^",2) D - ..I HDFN'=HNEWDFN S HDFN=HNEWDFN,PSFLG=1 - ..I PSOLLL'=PSOLLN S PSOLLL=PSOLLN,PSFLG=1 - ..I PSFLG=1 D SETZ - I '$D(^UTILITY($J,"PSOHL")) G ENDHL -CALL D SETZ -ENDHL K ^UTILITY($J,"PSOHL"),^UTILITY($J,"PSOHLL"),HLRXY - Q -OTHER I $G(^UTILITY($J,"PSOHLL",HLDFN,"DRI"))'="" S ^UTILITY($J,"PSOHL",HLDFN,"DRI")=^UTILITY($J,"PSOHLL",HLDFN,"DRI") - F HLDAI=0:0 S HLDAI=$O(^UTILITY($J,"PSOHLL",HLDFN,HLDAI)) Q:'HLDAI S ^UTILITY($J,"PSOHL",HLDFN,HLDAI)=^UTILITY($J,"PSOHLL",HLDFN,HLDAI) - Q -ACLOG ;Activity log (sending to Hl7 interface) - N DTTM,HCOM,HCNT,HJJ - D NOW^%DTC S DTTM=%,HCOM="Prescription"_$S($G(RXPR(HLINRX)):" (Partial)",1:"")_$S($G(PSOSUREP)!($G(RXRP(HLINRX))):" (Reprint)",1:"")_" sent to external interface." - S HCNT=0 F HJJ=0:0 S HJJ=$O(^PSRX(HLINRX,"A",HJJ)) Q:'HJJ S HCNT=HJJ - S HCNT=HCNT+1,^PSRX(HLINRX,"A",0)="^52.3DA^"_HCNT_"^"_HCNT S ^PSRX(HLINRX,"A",HCNT,0)=DTTM_"^X^"_$G(PDUZ)_"^"_$S($G(RXPR(HLINRX)):6,$G(HLFOUR)<6:$G(HLFOUR),1:(HLFOUR+1))_"^"_HCOM - Q -SUS(HSREX,HSFL,HSFILL,HSRP) ; - N DA,DIK,DTTM,HSCOM,HSCNT,HSJJ,HSLDUZ,PSHLCPRS - I $P($G(^PSRX(HSREX,"STA")),"^")=5 S $P(^PSRX(HSREX,"STA"),"^")=0 S PSHLCPRS="Removed from Suspense, External Interface." D EN^PSOHLSN1(HSREX,"SC","ZU",PSHLCPRS) - S DA=$O(^PS(52.5,"B",HSREX,0)) I DA K DIK S DIK="^PS(52.5," D ^DIK - I $G(HSFL)="P" S HSLDUZ=+$P($G(^PSRX(HSREX,"P",HSFILL,0)),"^",7) - E S HSLDUZ=$S('HSFILL:+$P($G(^PSRX(HSREX,0)),"^",16),1:+$P($G(^PSRX(HSREX,1,HSFILL,0)),"^",7)) - D NOW^%DTC S DTTM=%,HSCOM="Removed from Suspense"_$S($G(HSFL)="P":" (Partial)",1:"")_$S($G(HSRP):" (Reprint)",1:"")_" (External Interface)" - S HSCNT=0 F HSJJ=0:0 S HSJJ=$O(^PSRX(HSREX,"A",HSJJ)) Q:'HSJJ S HSCNT=HSJJ - S HSCNT=HSCNT+1,^PSRX(HSREX,"A",0)="^52.3DA^"_HSCNT_"^"_HSCNT S ^PSRX(HSREX,"A",HSCNT,0)=DTTM_"^X^"_$G(HSLDUZ)_"^"_$S($G(HSFL)="P":6,$G(HSFILL)<6:$G(HSFILL),1:(HSFILL+1))_"^"_$G(HSCOM) - Q -LAB(HLREX,HLFL,HLFILL,HLREPT) ; - N HLDUZ,NOW,DA,HCT,HFF - D NOW^%DTC S NOW=% S HCT=0 F HFF=0:0 S HFF=$O(^PSRX(HLREX,"L",HFF)) Q:'HFF S HCT=HFF - I HLFL="F" S HLDUZ=$S('HLFILL:+$P($G(^PSRX(HLREX,0)),"^",16),1:+$P($G(^PSRX(HLREX,1,HLFILL,0)),"^",7)) - I HLFL="P" S HLDUZ=+$P($G(^PSRX(HLREX,"P",HLFILL,0)),"^",7) - S HCT=HCT+1,^PSRX(HLREX,"L",0)="^52.032DA^"_HCT_"^"_HCT - S ^PSRX(HLREX,"L",HCT,0)=NOW_"^"_$S($G(HLFL)="F":HLFILL,1:(99-HLFILL))_"^"_"From Rx number "_$P(^PSRX(HLREX,0),"^")_$S($G(HLFL)="P":" (Partial)",1:"")_$S($G(HLREPT):" (Reprint)",1:"")_" (External Interface)"_"^"_$G(HLDUZ) - N PSOBADR,PSOTEMP - S PSOBADR=$$CHKRX^PSOBAI(HLREX) - I $G(PSOBADR) S PSOTEMP=$P(PSOBADR,"^",2),PSOBADR=$P(PSOBADR,"^") - I $G(PSOBADR),'$G(PSOTEMP) D - .S HCT=HCT+1,^PSRX(HLREX,"L",0)="^52.032DA^"_HCT_"^"_HCT - .S ^PSRX(HLREX,"L",HCT,0)=NOW_"^"_$S($G(HLFL)="F":HLFILL,1:(99-HLFILL))_"^"_"ROUTING="_$G(MW)_" (BAD ADDRESS)"_"^"_$G(HLDUZ) - Q -RPT ; - S $P(^UTILITY($J,"PSOHLL",II),"^",9)=$S($G(PSOSUREP)!($G(RXRP(HLINRX))):1,1:0) - S $P(^UTILITY($J,"PSOHLL",II),"^",10)=+$G(PDUZ) - Q -SETZ ; - D NOW^%DTC S PSODTM=% - S ZTRTN=$S($$GET1^DIQ(59,PSOSITE_",",105,"I")=2.4:"INIT^PSOHLDS",1:"INIT^PSOHLSG") - S ZTIO="",ZTDTH=$H,ZTSAVE("^UTILITY($J,""PSOHL"",")="",ZTSAVE("PSOPAR")="",ZTSAVE("PSOSITE")="",ZTSAVE("PSODTM")="",ZTSAVE("PSOLAP")="" - S ZTSAVE("RXRP(")="",ZTSAVE("RXPR(")="",ZTSAVE("RXFL(")="",ZTSAVE("RXRS(")="" - S ZTDESC=$S($$GET1^DIQ(59,PSOSITE_",",105,"I")=2.4:"Outpatient Automation External Interface",1:"GENERIC INTERFACE LABEL INFORMATION") - D ^%ZTLOAD - Q +PSOLBL4 ;BIR/RTR-Set up routine for HL7 interface ;10/20/96 + ;;7.0;OUTPATIENT PHARMACY;**26,70,156,244,233**;DEC 1997;Build 8 + ;External reference to ^PSDRUG supported by DBIA 221 + ; + ;*244 - ignore RX's with a status > 11 + ; + N DIC,AP,X,Y,DPRT,QPRT + I $G(ZTIO)]"" D + .Q:'$O(^PS(59,PSOSITE,"P",0)) + .S DIC=3.5,DIC(0)="",X=ZTIO D ^DIC K DIC,X Q:Y=-1 + .S DPRT=+Y + .F AP=0:0 S AP=$O(^PS(59,PSOSITE,"P",AP)) Q:'AP I +$P(^PS(59,PSOSITE,"P",AP,0),"^")=DPRT S QPRT=1 + .I '$G(QPRT) S $P(PSOPAR,"^",30)=0 + Q:'$P($G(PSOPAR),"^",30) + Q:$G(PSOEXREP) +HL N PSODTM,HHHH,HLCOT,HLFLAG,HLFOUR,HLINGF,HLINRX,HLINRX0,HLLOOP,HLNEXT,HLRR,HLRX,HLRXY,LL,PPLHL,PSHALP,HDFN,HLDFN,HNEWDFN,HLDAI,HLOSITE,HLJUST,HLRXYZ,PSOLLN,PSOLLL,PSFLG,HDFN1 + S HLOSITE=$P($G(PSOPAR),"^",30) + K ^UTILITY($J,"PSOHL"),^UTILITY($J,"PSOHLL"),HLRXY + S PPLHL=PPL G:HLOSITE=4 SOMD + S HLFLAG=0 F HLLOOP=1:1 S HLRX=$P(PPLHL,",",HLLOOP) D Q:$G(HLFLAG) + .S HLNEXT=$P(PPLHL,",",(HLLOOP+1)) I HLNEXT=""!(HLNEXT=",") S HLFLAG=1 + .Q:'$G(HLRX) + .Q:'$D(^PSRX(HLRX,0)) + .Q:$P($G(^PSRX(HLRX,"STA")),"^")=4 + .Q:$G(RXRP(HLRX,"RP")) + .I $P($G(^PSRX(HLRX,"STA")),"^")>11!('$P(^PSRX(HLRX,0),"^",2)) Q + .I $G(PSODBQ) S HLRR=$O(^PS(52.5,"B",HLRX,0)) Q:'HLRR I $G(^PS(52.5,+HLRR,"P"))=1 Q + .;Here, if Site Parameter is 3, check entry in Drug File for National Id + .I $G(HLOSITE)=3 S HLJUST=+$P($G(^PSRX(HLRX,0)),"^",6) I '$P($G(^PSDRUG(HLJUST,6)),"^") Q + .S HLRXY(HLLOOP,HLRX)="" ; VALID RXS + .S:$G(HLOSITE)=3 HLRXYZ(HLRX)="" + I $G(HLOSITE)=3,$D(HLRXY) D + .N HLZFLAG,HLZ,HLZRX,HLZNEXT + .S HLZFLAG=0 K PPL F HLZ=1:1 S HLZRX=$P(PPLHL,",",HLZ) D Q:$G(HLZFLAG) + ..S HLZNEXT=$P(PPLHL,",",(HLZ+1)) I HLZNEXT=""!(HLZNEXT=",") S HLZFLAG=1 + ..Q:'$G(HLZRX) + ..Q:$D(HLRXYZ(HLZRX)) + ..I $G(RXRP(HLZRX,"RP")) D Q + ...I $G(PPL)="" S PPL=HLZRX_"," Q + ...S PPL=PPL_HLZRX_"," + ..I $G(PPL)="" S PPL=HLZRX_"," Q + ..S PPL=PPL_HLZRX_"," +SOMDQ S HLCOT=1,PSHALP="" F S PSHALP=$O(HLRXY(PSHALP)) Q:PSHALP="" S ^UTILITY($J,"PSOHLL",HLCOT)=$O(HLRXY(PSHALP,0)),HLCOT=HLCOT+1 + I HLCOT=1 G ENDHL ; NOTHING SET, BYPASS CALL TO QUEUE + F HLCOT=0:0 S HLCOT=$O(^UTILITY($J,"PSOHLL",HLCOT)) Q:'HLCOT S HLINRX=^(HLCOT),HLINRX0=$G(^PSRX(HLINRX,0)) D + .S ^UTILITY($J,"PSOHLL",HLCOT)=HLINRX_"^"_+$P(HLINRX0,"^",6)_"^"_$S($G(RXPR(HLINRX)):"P",1:"F") + .I '$G(RXPR(HLINRX)) S HLFOUR=0 F HHHH=0:0 S HHHH=$O(^PSRX(HLINRX,1,HHHH)) Q:'HHHH I +^(HHHH,0) S HLFOUR=HHHH + .I '$G(RXPR(HLINRX)),$G(RXFL(HLINRX))'="" S HLFOUR=$S($G(RXFL(HLINRX))=0:0,$D(^PSRX(HLINRX,1,+$G(RXFL(HLINRX)),0)):+$G(RXFL(HLINRX)),1:$G(HLFOUR)) + .S ^UTILITY($J,"PSOHLL",HLCOT)=^UTILITY($J,"PSOHLL",HLCOT)_"^"_$S($G(RXPR(HLINRX)):RXPR(HLINRX),1:HLFOUR)_"^"_$S($P($G(^PSRX(HLINRX,3)),"^",6)&('$G(RXPR(HLINRX)))&('$G(RXFL(HLINRX))):1,1:0) D ACLOG + .S HLINGF=0 I $P(^UTILITY($J,"PSOHLL",HLCOT),"^",5),$O(^PSRX(HLINRX,"DAI",0)) S HLINGF=1 D + ..F LL=0:0 S LL=$O(^PSRX(HLINRX,"DAI",LL)) Q:'LL S ^UTILITY($J,"PSOHLL",HLCOT,HLINGF)=$G(^PSRX(HLINRX,"DAI",LL,0)),HLINGF=HLINGF+1 + .S $P(^UTILITY($J,"PSOHLL",HLCOT),"^",6)=$S($G(HLINGF):1,1:0) + .I $D(^PSRX(HLINRX,"DRI")),'$G(RXPR(HLINRX)),'$G(RXFL(HLINRX)) S ^UTILITY($J,"PSOHLL",HLCOT,"DRI")=^PSRX(HLINRX,"DRI"),$P(^UTILITY($J,"PSOHLL",HLCOT),"^",7)=1 + .E S $P(^UTILITY($J,"PSOHLL",HLCOT),"^",7)=0 + .S $P(^UTILITY($J,"PSOHLL",HLCOT),"^",8)=0 D RPT Q:'$G(^PSRX(HLINRX,"IB")) + .I $P(^PSRX(HLINRX,"STA"),"^")>0,$P(^("STA"),"^")'=2,'$G(PSODBQ) Q + .S $P(^UTILITY($J,"PSOHLL",HLCOT),"^",8)=1 + ; +AAA D STRT^PSOHLSG5 + S (HDFN,HDFN1)=$O(^UTILITY($J,"PSOHLL",0)),HDFN=$P(^PSRX($P(^(HDFN),"^"),0),"^",2),PSOLLL=$P(^UTILITY($J,"PSOHLL",HDFN1),"^",12) + F HLDFN=0:0 S HLDFN=$O(^UTILITY($J,"PSOHLL",HLDFN)) Q:'HLDFN D S ^UTILITY($J,"PSOHL",HLDFN)=^UTILITY($J,"PSOHLL",HLDFN) D OTHER + .S PSFLG=0,PSOLLN=$P(^UTILITY($J,"PSOHLL",HLDFN),"^",12),HNEWDFN=$P(^PSRX($P(^UTILITY($J,"PSOHLL",HLDFN),"^"),0),"^",2) D + ..I HDFN'=HNEWDFN S HDFN=HNEWDFN,PSFLG=1 + ..I PSOLLL'=PSOLLN S PSOLLL=PSOLLN,PSFLG=1 + ..I PSFLG=1 D SETZ + I '$D(^UTILITY($J,"PSOHL")) G ENDHL +CALL D SETZ +ENDHL K ^UTILITY($J,"PSOHL"),^UTILITY($J,"PSOHLL"),HLRXY + Q +OTHER I $G(^UTILITY($J,"PSOHLL",HLDFN,"DRI"))'="" S ^UTILITY($J,"PSOHL",HLDFN,"DRI")=^UTILITY($J,"PSOHLL",HLDFN,"DRI") + F HLDAI=0:0 S HLDAI=$O(^UTILITY($J,"PSOHLL",HLDFN,HLDAI)) Q:'HLDAI S ^UTILITY($J,"PSOHL",HLDFN,HLDAI)=^UTILITY($J,"PSOHLL",HLDFN,HLDAI) + Q +ACLOG ;Activity log (sending to Hl7 interface) + N DTTM,HCOM,HCNT,HJJ + D NOW^%DTC S DTTM=%,HCOM="Prescription"_$S($G(RXPR(HLINRX)):" (Partial)",1:"")_$S($G(PSOSUREP)!($G(RXRP(HLINRX))):" (Reprint)",1:"")_" sent to external interface." + S HCNT=0 F HJJ=0:0 S HJJ=$O(^PSRX(HLINRX,"A",HJJ)) Q:'HJJ S HCNT=HJJ + S HCNT=HCNT+1,^PSRX(HLINRX,"A",0)="^52.3DA^"_HCNT_"^"_HCNT S ^PSRX(HLINRX,"A",HCNT,0)=DTTM_"^X^"_$G(PDUZ)_"^"_$S($G(RXPR(HLINRX)):6,$G(HLFOUR)<6:$G(HLFOUR),1:(HLFOUR+1))_"^"_HCOM + Q +SUS(HSREX,HSFL,HSFILL,HSRP) ; + N DA,DIK,DTTM,HSCOM,HSCNT,HSJJ,HSLDUZ,PSHLCPRS + I $P($G(^PSRX(HSREX,"STA")),"^")=5 S $P(^PSRX(HSREX,"STA"),"^")=0 S PSHLCPRS="Removed from Suspense, External Interface." D EN^PSOHLSN1(HSREX,"SC","ZU",PSHLCPRS) + S DA=$O(^PS(52.5,"B",HSREX,0)) I DA K DIK S DIK="^PS(52.5," D ^DIK + I $G(HSFL)="P" S HSLDUZ=+$P($G(^PSRX(HSREX,"P",HSFILL,0)),"^",7) + E S HSLDUZ=$S('HSFILL:+$P($G(^PSRX(HSREX,0)),"^",16),1:+$P($G(^PSRX(HSREX,1,HSFILL,0)),"^",7)) + D NOW^%DTC S DTTM=%,HSCOM="Removed from Suspense"_$S($G(HSFL)="P":" (Partial)",1:"")_$S($G(HSRP):" (Reprint)",1:"")_" (External Interface)" + S HSCNT=0 F HSJJ=0:0 S HSJJ=$O(^PSRX(HSREX,"A",HSJJ)) Q:'HSJJ S HSCNT=HSJJ + S HSCNT=HSCNT+1,^PSRX(HSREX,"A",0)="^52.3DA^"_HSCNT_"^"_HSCNT S ^PSRX(HSREX,"A",HSCNT,0)=DTTM_"^X^"_$G(HSLDUZ)_"^"_$S($G(HSFL)="P":6,$G(HSFILL)<6:$G(HSFILL),1:(HSFILL+1))_"^"_$G(HSCOM) + Q +LAB(HLREX,HLFL,HLFILL,HLREPT) ; + N HLDUZ,NOW,DA,HCT,HFF + D NOW^%DTC S NOW=% S HCT=0 F HFF=0:0 S HFF=$O(^PSRX(HLREX,"L",HFF)) Q:'HFF S HCT=HFF + I HLFL="F" S HLDUZ=$S('HLFILL:+$P($G(^PSRX(HLREX,0)),"^",16),1:+$P($G(^PSRX(HLREX,1,HLFILL,0)),"^",7)) + I HLFL="P" S HLDUZ=+$P($G(^PSRX(HLREX,"P",HLFILL,0)),"^",7) + S HCT=HCT+1,^PSRX(HLREX,"L",0)="^52.032DA^"_HCT_"^"_HCT + S ^PSRX(HLREX,"L",HCT,0)=NOW_"^"_$S($G(HLFL)="F":HLFILL,1:(99-HLFILL))_"^"_"From Rx number "_$P(^PSRX(HLREX,0),"^")_$S($G(HLFL)="P":" (Partial)",1:"")_$S($G(HLREPT):" (Reprint)",1:"")_" (External Interface)"_"^"_$G(HLDUZ) + N PSOBADR,PSOTEMP + S PSOBADR=$$CHKRX^PSOBAI(HLREX) + I $G(PSOBADR) S PSOTEMP=$P(PSOBADR,"^",2),PSOBADR=$P(PSOBADR,"^") + I $G(PSOBADR),'$G(PSOTEMP) D + .S HCT=HCT+1,^PSRX(HLREX,"L",0)="^52.032DA^"_HCT_"^"_HCT + .S ^PSRX(HLREX,"L",HCT,0)=NOW_"^"_$S($G(HLFL)="F":HLFILL,1:(99-HLFILL))_"^"_"ROUTING="_$G(MW)_" (BAD ADDRESS)"_"^"_$G(HLDUZ) + Q +RPT ; + S $P(^UTILITY($J,"PSOHLL",HLCOT),"^",9)=$S($G(PSOSUREP)!($G(RXRP(HLINRX))):1,1:0) + S $P(^UTILITY($J,"PSOHLL",HLCOT),"^",10)=+$G(PDUZ) + Q +SETZ ; + D NOW^%DTC S PSODTM=% + S ZTRTN=$S($$GET1^DIQ(59,PSOSITE_",",105,"I")=2.4:"INIT^PSOHLDS",1:"INIT^PSOHLSG") + S ZTIO="",ZTDTH=$H,ZTSAVE("^UTILITY($J,""PSOHL"",")="",ZTSAVE("PSOPAR")="",ZTSAVE("PSOSITE")="",ZTSAVE("PSODTM")="",ZTSAVE("PSOLAP")="" + S ZTSAVE("RXRP(")="",ZTSAVE("RXPR(")="",ZTSAVE("RXFL(")="",ZTSAVE("RXRS(")="" + S ZTDESC=$S($$GET1^DIQ(59,PSOSITE_",",105,"I")=2.4:"Outpatient Automation External Interface",1:"GENERIC INTERFACE LABEL INFORMATION") + D ^%ZTLOAD + Q +SOMD ;send only mark drugs to external interface and print in vista + S HLFLG=0 F HLLP=1:1 S HLRX=$P(PPLHL,",",HLLP) D Q:$G(HLFLG) + .S HLNEXT=$P(PPLHL,",",(HLLP+1)) I HLNEXT=""!(HLNEXT=",") S HLFLG=1 + .Q:'$G(HLRX) + .Q:'$D(^PSRX(HLRX,0)) + .Q:$P($G(^PSRX(HLRX,"STA")),"^")=4 + .I $P($G(^PSRX(HLRX,"STA")),"^")>11!('$P(^PSRX(HLRX,0),"^",2)) Q + .Q:$G(RXRP(HLRX,"RP")) + .S HLRR=$O(^PS(52.5,"B",HLRX,0)) Q:'HLRR I $G(^PS(52.5,+HLRR,"P"))=1 K HLRR Q + .S DRG=+$P($G(^PSRX(HLRX,0)),"^",6) I '$P($G(^PSDRUG(DRG,6)),"^") Q + .S HLRXY(HLRX)="" ; VALID RXS + I $D(HLRXY) G SOMDQ + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLBLN.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLBLN.m index efcd5aa2..b45e9621 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLBLN.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLBLN.m @@ -1,136 +1,136 @@ -PSOLBLN ;BIR/RTR-NEW PRINTS LABEL ; 3/11/07 1:56pm - ;;7.0;OUTPATIENT PHARMACY;**16,36,71,107,110,117,135,233,208**;DEC 1997;Build 41 - ; 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 - ;External reference to ^PSDRUG supported by DBIA 221 - ;External reference to ^VA(200 supported by DBIA 224 - K PSOSTLK,ZTKDRUG I $L($T(PSOSTALK^PSOTALK1)) D PSOSTALK^PSOTALK1 S PSOSTLK=1 ; PRINT SCRIPTALK LABEL IF APPLICABLE - I $G(IOS),$G(PSOBARS) I $G(PSOBAR0)=""!($G(PSOBAR1)="") S PSOIOS=IOS D DEVBAR^PSOBMST - I $G(DFN) D ADD^VADPT - S ADDR(33)=$G(VAPA(4))_", "_$P($G(VAPA(5)),"^",2)_" "_$S($G(VAPA(11))]"":$P($G(VAPA(11)),"^",2),1:$G(VAPA(6))),ADDR(22)="" - S:$G(VAPA(2))]"" ADDR(22)=$G(VAPA(2))_" "_$G(VAPA(3)),ADDR(22)=$E(ADDR(22),1,46) S:ADDR(22)="" ADDR(22)=ADDR(33),ADDR(33)="" - S ADDR(4)=$S(ADDR(33)="":ADDR(22),1:ADDR(33)) I $G(VAPA(2))="",$G(VAPA(3))="" S ADDR(2)=ADDR(4),ADDR(3)="",ADDR(4)="" G ST - I $G(VAPA(2))'="",$G(VAPA(3))="" S ADDR(2)=VAPA(2),ADDR(3)=ADDR(4),ADDR(4)="" G ST - I $G(VAPA(2))="",$G(VAPA(3))'="" S ADDR(2)=VAPA(3),ADDR(3)=ADDR(4),ADDR(4)="" G ST - S ADDR(2)=$G(VAPA(2)),ADDR(3)=$G(VAPA(3)) -ST I $P($G(^PSRX(RX,3)),"^",3) S PSOPROV=+$P(^(0),"^",4) S PSOPROV=$S($G(RXP):+$P($G(RXP),"^",17),$G(RXF):+$P($G(^PSRX(RX,1,RXF,0)),"^",17),1:PSOPROV) S:'$G(PSOPROV) PSOPROV=+$P(^PSRX(RX,0),"^",4) D - .I +$P($G(^VA(200,PSOPROV,"PS")),"^",7) S:'$P($G(PHYS),"/",2) PHYS=$G(PHYS)_"/"_+$P($G(^PSRX(RX,3)),"^",3) - S COPIES=COPIES-1,$P(ULN,"_",34)="",PSOTRAIL=1 I $G(SIDE) D REP^PSOLBL2 G REP - S (Y,X1)=EXPDT X ^DD("DD") S EXPDT=Y,Y=$P(^PSRX(RX,0),"^",13) X ^DD("DD") S ISD=Y,X2=DT D ^%DTC S DIFF=X - S Y=DATE X ^DD("DD") S DATE=Y D NOW^%DTC S Y=% X ^DD("DD") S NOW=Y - S TECH="("_$S($P($G(^PSRX(+$G(RX),"OR1")),"^",5):$P($G(^PSRX(+$G(RX),"OR1")),"^",5),1:$P(RXY,"^",16))_"/"_$S($G(VRPH)&($P(PSOPAR,"^",32)):VRPH,1:" ")_")" - S PSZIP=$P(PS,"^",5) S PSOHZIP=$S(PSZIP["-":PSZIP,1:$E(PSZIP,1,5)_$S($E(PSZIP,6,9)]"":"-"_$E(PSZIP,6,9),1:"")) - ; - I $G(PSOAFYN)="Y" G PSOAFPL1 ;vfah - ; -L1 W ?3,"VAMC ",$P(PS,"^",7),", ",STATE," ",$G(PSOHZIP),?54,"VAMC ",$P(PS,"^",7),", ",STATE," ",$G(PSOHZIP),?102 W $S($D(REPRINT)&($G(PSOBLALL)):"(GROUP REPRINT)",$D(REPRINT):"(REPRINT)",1:"") W:$G(RXP) "(PARTIAL)" - W !?3,$P(PS2,"^",2)," ",$P(PS,"^",3),"-",$P(PS,"^",4)," ",TECH,?54,$P(PS2,"^",2)," ",$P(PS,"^",3),"-",$P(PS,"^",4)," ",TECH,?102,$P(PS2,"^",2)," ",TECH," ",NOW - W !,"Rx# ",RXN," ",DATE," Fill ",RXF+1," of ",1+$P(RXY,"^",9),?54,"Rx# ",RXN," ",DATE," Fill ",RXF+1," of ",1+$P(RXY,"^",9),?102,"Rx# ",RXN," ",DATE," Fill ",RXF+1," of ",1+$P(RXY,"^",9) - W !,PNM," ",$G(SSNPN),?54,PNM," ",$G(SSNPN),?102,PNM," ",$G(SSNPN) - F DR=1:1 Q:$G(SGY(DR))="" D:DR=4!(DR=7)!(DR=10)!(DR=13) W !,$G(SGY(DR)),?54,$G(SGY(DR)),?102,$S($G(OSGY(DR))]"":OSGY(DR),1:$G(SGY(DR))) - .F GG=1:1:27 W ! - I DR>4 S KK=$S(DR=5!(DR=8)!(DR=11):2,(DR=6)!(DR=9)!(DR=12):1,1:0) I KK F HH=1:1:KK W ! - I DR=2 W !! - I DR=3 W ! - W !,$G(PHYS),?54,$G(PHYS),?102,$G(PHYS) - S PSMF=$S($G(NURSE):"Mfg______Exp______",1:""),PSDU=$P($G(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),660)),"^",8),PSDU=$S(PSDU="":" "_PSMF,1:PSDU_" "_PSMF) - W !,"Qty: "_$G(QTY)," ",$G(PSDU),?54,"Qty: "_$G(QTY)," ",$G(PSDU),?102,"Qty: "_$G(QTY)," ",$G(PSDU) - S ZTKDRUG="XXXXXX SCRIPTALK RX XXXXXX" - I '$G(PSOSTLK) K PSDU,PSMF W !,DRUG,?54,DRUG,?102,DRUG - I $G(PSOSTLK) K PSDU,PSMF W !,$S($G(PSOSTALK):ZTKDRUG,1:DRUG),?54,DRUG,?102,DRUG - I $P(RXY,"^",9)-RXF'>0 D ^PSOLBLN1 G L13 - G:DIFF<30 L11 - W !?54,$P(RXY,"^",9)-RXF," Refills remain prior to ",EXPDT,?102,"Mfg "_$G(MFG)_" Lot# "_$G(LOT) G L12 -L11 W !?54,"Last fill prior to ",$G(EXPDT),?102,"Mfg "_$G(MFG)_" Lot# "_$G(LOT) -L12 W !,$P(PS,"^",2),?54,$S($L($G(COPAYVAR)):$G(COPAYVAR)_" ",1:""),"Days Supply: ",$G(DAYS),?102,"Tech__________RPh_________",!,$P(PS,"^",7),", ",STATE," ",$G(PSOHZIP) - ;send a CR for OPTIFIL (P-MT661BC) - I $G(PSOBARS),$P(PSOPAR,"^",19)'=1 S X="S",X2=PSOINST_"-"_RX S X1=$X W ?54,@PSOBAR1,X2,@PSOBAR0,$C(13) S $X=0 W:IOST["P-MT661BC" ! - E W !!! - W !,"FORWARDING SERVICE REQUESTED" W:"C"[$E(MW) !,?21,"CERTIFIED MAIL" W !?54,$G(VAPA(1)) - W !,$S($G(PS55)=2:"***DO NOT MAIL***",1:"***CRITICAL MEDICAL SHIPMENT***"),?54,$G(ADDR(2)),?102,"Routing: "_$S("W"[$E(MW):MW,1:MW_" MAIL") - W !?54,$G(ADDR(3)),?102,"Days supply: ",$G(DAYS)," Cap: ",$S(PSCAP:"**NON-SFTY**",1:"SAFETY") - W !?54,$G(ADDR(4)),?102,"Isd: ",ISD," Exp: ",EXPDT - W !,PNM,?54,"*Indicate address change on back of this form",?102,"Last Fill: ",$G(PSOLASTF) - W !,$S($D(PSMP(1)):PSMP(1),1:$G(VAPA(1))),?54,"[ ] Permanent",?102,"Pat. Stat ",PATST," Clinic: ",PSCLN - W !,$S($D(PSMP(2)):PSMP(2),$D(PSMP(1)):"",1:$G(ADDR(2))),?54,"[ ] Temporary until ",$S($P($G(VAPA(10)),"^",2)]"":$P($G(VAPA(10)),"^",2),1:"__/__/__"),?102,$S($G(WARN)'="":"DRUG WARNING "_$G(WARN),1:"") - W !,$S($D(PSMP(3)):PSMP(3),$D(PSMP(1)):"",1:$G(ADDR(3))),!,$S($D(PSMP(4)):PSMP(4),$D(PSMP(1)):"",1:$G(ADDR(4))),?54,"Signature",ULN - I $G(PSOBARS) S X="S",X2=PSOINST_"-"_RX S X1=$X W ?102,@PSOBAR1,X2,@PSOBAR0,$C(13) S $X=0 -L13 I $G(WARN)'="",'$G(PSOBLALL) I '$G(PSDFNFLG),'$G(PSOLAPPL) D WARN^PSOLBL2 - W @IOF - ; -PSOAFPL1 I $G(PSOAFYN)="Y" D PSOAFP ;vfah - ; -REP I COPIES>0 S SIDE=1 G ST - D NOW^%DTC S NOW=% K %,%H,%I I $G(RXF)="" S RXF=0 F I=0:0 S I=$O(^PSRX(RX,1,I)) Q:'I S RXF=I - S IR=0 F FDA=0:0 S FDA=$O(^PSRX(RX,"L",FDA)) Q:'FDA S IR=FDA - S IR=IR+1,^PSRX(RX,"L",0)="^52.032DA^"_IR_"^"_IR - S ^PSRX(RX,"L",IR,0)=NOW_"^"_$S($G(RXP):99-RXPI,1:RXF)_"^"_$S($G(PCOMX)]"":$G(PCOMX),$G(PCOMH(RX))]"":PCOMH(RX),1:"From RX number "_$P(^PSRX(RX,0),"^"))_$S($G(RXP):" (Partial)",1:"")_$S($D(REPRINT):" (Reprint)",1:"")_"^"_PDUZ - N PSOBADR,PSOTEMP - S PSOBADR=$$CHKRX^PSOBAI(RX) - I $G(PSOBADR) S PSOTEMP=$P(PSOBADR,"^",2),PSOBADR=$P(PSOBADR,"^") - I $G(PSOBADR),'$G(PSOTEMP) D - .S IR=IR+1,^PSRX(RX,"L",0)="^52.032DA^"_IR_"^"_IR - .S ^PSRX(RX,"L",IR,0)=NOW_"^"_$S($G(RXP):99-RXPI,1:RXF)_"^"_"ROUTING="_$G(MW)_" (BAD ADDRESS)"_"^"_PDUZ - S ^PSRX(RX,"TYPE")=0 K RXF,IR,FDA,NOW,I,PCOMH(RX) -PSOAFPL2 I $G(PSOAFYN)="Y" G PSOAFPL3 ;vfah - I $G(WARN)'="" I $G(PSDFNFLG)!($G(PSOLAPPL)) D ALLWARN^PSOLBLN1 - I $G(WARN)="" I $G(PSDFNFLG)!($G(PSOLAPPL)) D ALL^PSOLBLS - I $G(PSOBLALL) D:$G(WARN)="" ALL^PSOLBLS D:$G(WARN)'="" ALLWARN^PSOLBLN1 - I '$D(PSSPND),$P(PSOPAR,"^",18) I $G(PSDFNFLG)!($G(PSOLAPPL))!($G(PSOBLALL)) D CHCK2^PSOTRLBL -PSOAFPL3 ;vfah - D:$G(PSOBLALL) TRAIL^PSOLBL2 -END ; - I $D(RXFLX(RX)) S RXFL(RX)=$G(RXFLX(RX)) K RXFLX - ; - I '$D(REPRINT)&($G(PSOAFYN)="Y") D ^PSODISP ;vfah auto-release - ; - D KILL^PSOLBL2 Q - ; - Q ;vfah - ; -PSOAFP ;Patient prescription print starts here;vfah - S PSOAFPRV=$P($G(^PSRX(RX,0)),"^",4) - S PSDU=$P($G(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),660)),"^",8) ;vfah sets dispense units - I $G(VFASDD)="Y" S $P(^PSRX(RX,"RXFIN"),"^",1)="Y" ;Sets complex order flag in File#52 - K VFASDD - ; -AFFAX ; - I $G(REPRINT)'=1 D - .S LZ=0,STOP=0 F S LZ=$O(^PSRX(RX,"PRC",LZ)) Q:'LZ!(STOP=1) S LZZ=$P(^PSRX(RX,"PRC",LZ,0),"FAX: ",2) S LZZ=+LZZ I LZZ'=0 D - ..I $D(^DIZ(22900)) D - ...S DIC="^DIZ(22900,",DIC(0)="MOZ",X=LZZ - ...D ^DIC K DIC - ...I +Y'=-1 D - ....S PSOAFFXP=X - ....S PSOAFFXL=$P(Y,"^",2) - ....S ^PSRX(RX,"PRC",LZ,0)=$TR(^PSRX(RX,"PRC",LZ,0),":","+") - ....S STOP=1 - ...I +Y=-1 D - ....S ^PSRX(RX,"PRC",LZ,0)=$TR(^PSRX(RX,"PRC",LZ,0),":","-") - K STOP,LZ,LZZ - I $G(REPRINT)=1 S PSOAFFXP=$G(PSOAFFXR) - I $G(PSOAFFXP)>1 G AFPTL - ; -AFPTS I PSOLAP["STAR" D PRNT^PSOAFPTS - I PSOLAP["STAR" G AFKILL - I PSOLAP["STRL" D PRNT^PSOAFPT1 - I PSOLAP["STRL" G AFKILL - ; -AFPTL D BEGLP^PSOAFPTL - ; -AFKILL K PSOAFPRV - I $G(REPRINT)'=1 D ^%ZISC +PSOLBLN ;BIR/RTR-NEW PRINTS LABEL ; 3/11/07 1:56pm + ;;7.0;OUTPATIENT PHARMACY;**16,36,71,107,110,117,135,233,208**;DEC 1997;Build 39 + ; 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 + ;External reference to ^PSDRUG supported by DBIA 221 + ;External reference to ^VA(200 supported by DBIA 224 + K PSOSTLK,ZTKDRUG I $L($T(PSOSTALK^PSOTALK1)) D PSOSTALK^PSOTALK1 S PSOSTLK=1 ; PRINT SCRIPTALK LABEL IF APPLICABLE + I $G(IOS),$G(PSOBARS) I $G(PSOBAR0)=""!($G(PSOBAR1)="") S PSOIOS=IOS D DEVBAR^PSOBMST + I $G(DFN) D ADD^VADPT + S ADDR(33)=$G(VAPA(4))_", "_$P($G(VAPA(5)),"^",2)_" "_$S($G(VAPA(11))]"":$P($G(VAPA(11)),"^",2),1:$G(VAPA(6))),ADDR(22)="" + S:$G(VAPA(2))]"" ADDR(22)=$G(VAPA(2))_" "_$G(VAPA(3)),ADDR(22)=$E(ADDR(22),1,46) S:ADDR(22)="" ADDR(22)=ADDR(33),ADDR(33)="" + S ADDR(4)=$S(ADDR(33)="":ADDR(22),1:ADDR(33)) I $G(VAPA(2))="",$G(VAPA(3))="" S ADDR(2)=ADDR(4),ADDR(3)="",ADDR(4)="" G ST + I $G(VAPA(2))'="",$G(VAPA(3))="" S ADDR(2)=VAPA(2),ADDR(3)=ADDR(4),ADDR(4)="" G ST + I $G(VAPA(2))="",$G(VAPA(3))'="" S ADDR(2)=VAPA(3),ADDR(3)=ADDR(4),ADDR(4)="" G ST + S ADDR(2)=$G(VAPA(2)),ADDR(3)=$G(VAPA(3)) +ST I $P($G(^PSRX(RX,3)),"^",3) S PSOPROV=+$P(^(0),"^",4) S PSOPROV=$S($G(RXP):+$P($G(RXP),"^",17),$G(RXF):+$P($G(^PSRX(RX,1,RXF,0)),"^",17),1:PSOPROV) S:'$G(PSOPROV) PSOPROV=+$P(^PSRX(RX,0),"^",4) D + .I +$P($G(^VA(200,PSOPROV,"PS")),"^",7) S:'$P($G(PHYS),"/",2) PHYS=$G(PHYS)_"/"_+$P($G(^PSRX(RX,3)),"^",3) + S COPIES=COPIES-1,$P(ULN,"_",34)="",PSOTRAIL=1 I $G(SIDE) D REP^PSOLBL2 G REP + S (Y,X1)=EXPDT X ^DD("DD") S EXPDT=Y,Y=$P(^PSRX(RX,0),"^",13) X ^DD("DD") S ISD=Y,X2=DT D ^%DTC S DIFF=X + S Y=DATE X ^DD("DD") S DATE=Y D NOW^%DTC S Y=% X ^DD("DD") S NOW=Y + S TECH="("_$S($P($G(^PSRX(+$G(RX),"OR1")),"^",5):$P($G(^PSRX(+$G(RX),"OR1")),"^",5),1:$P(RXY,"^",16))_"/"_$S($G(VRPH)&($P(PSOPAR,"^",32)):VRPH,1:" ")_")" + S PSZIP=$P(PS,"^",5) S PSOHZIP=$S(PSZIP["-":PSZIP,1:$E(PSZIP,1,5)_$S($E(PSZIP,6,9)]"":"-"_$E(PSZIP,6,9),1:"")) + ; + I $G(PSOAFYN)="Y" G PSOAFPL1 ;vfah + ; +L1 W ?3,"VAMC ",$P(PS,"^",7),", ",STATE," ",$G(PSOHZIP),?54,"VAMC ",$P(PS,"^",7),", ",STATE," ",$G(PSOHZIP),?102 W $S($D(REPRINT)&($G(PSOBLALL)):"(GROUP REPRINT)",$D(REPRINT):"(REPRINT)",1:"") W:$G(RXP) "(PARTIAL)" + W !?3,$P(PS2,"^",2)," ",$P(PS,"^",3),"-",$P(PS,"^",4)," ",TECH,?54,$P(PS2,"^",2)," ",$P(PS,"^",3),"-",$P(PS,"^",4)," ",TECH,?102,$P(PS2,"^",2)," ",TECH," ",NOW + W !,"Rx# ",RXN," ",DATE," Fill ",RXF+1," of ",1+$P(RXY,"^",9),?54,"Rx# ",RXN," ",DATE," Fill ",RXF+1," of ",1+$P(RXY,"^",9),?102,"Rx# ",RXN," ",DATE," Fill ",RXF+1," of ",1+$P(RXY,"^",9) + W !,PNM," ",$G(SSNPN),?54,PNM," ",$G(SSNPN),?102,PNM," ",$G(SSNPN) + F DR=1:1 Q:$G(SGY(DR))="" D:DR=4!(DR=7)!(DR=10)!(DR=13) W !,$G(SGY(DR)),?54,$G(SGY(DR)),?102,$S($G(OSGY(DR))]"":OSGY(DR),1:$G(SGY(DR))) + .F GG=1:1:27 W ! + I DR>4 S KK=$S(DR=5!(DR=8)!(DR=11):2,(DR=6)!(DR=9)!(DR=12):1,1:0) I KK F HH=1:1:KK W ! + I DR=2 W !! + I DR=3 W ! + W !,$G(PHYS),?54,$G(PHYS),?102,$G(PHYS) + S PSMF=$S($G(NURSE):"Mfg______Exp______",1:""),PSDU=$P($G(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),660)),"^",8),PSDU=$S(PSDU="":" "_PSMF,1:PSDU_" "_PSMF) + W !,"Qty: "_$G(QTY)," ",$G(PSDU),?54,"Qty: "_$G(QTY)," ",$G(PSDU),?102,"Qty: "_$G(QTY)," ",$G(PSDU) + S ZTKDRUG="XXXXXX SCRIPTALK RX XXXXXX" + I '$G(PSOSTLK) K PSDU,PSMF W !,DRUG,?54,DRUG,?102,DRUG + I $G(PSOSTLK) K PSDU,PSMF W !,$S($G(PSOSTALK):ZTKDRUG,1:DRUG),?54,DRUG,?102,DRUG + I $P(RXY,"^",9)-RXF'>0 D ^PSOLBLN1 G L13 + G:DIFF<30 L11 + W !?54,$P(RXY,"^",9)-RXF," Refills remain prior to ",EXPDT,?102,"Mfg "_$G(MFG)_" Lot# "_$G(LOT) G L12 +L11 W !?54,"Last fill prior to ",$G(EXPDT),?102,"Mfg "_$G(MFG)_" Lot# "_$G(LOT) +L12 W !,$P(PS,"^",2),?54,$S($L($G(COPAYVAR)):$G(COPAYVAR)_" ",1:""),"Days Supply: ",$G(DAYS),?102,"Tech__________RPh_________",!,$P(PS,"^",7),", ",STATE," ",$G(PSOHZIP) + ;send a CR for OPTIFIL (P-MT661BC) + I $G(PSOBARS),$P(PSOPAR,"^",19)'=1 S X="S",X2=PSOINST_"-"_RX S X1=$X W ?54,@PSOBAR1,X2,@PSOBAR0,$C(13) S $X=0 W:IOST["P-MT661BC" ! + E W !!! + W !,"FORWARDING SERVICE REQUESTED" W:"C"[$E(MW) !,?21,"CERTIFIED MAIL" W !?54,$G(VAPA(1)) + W !,$S($G(PS55)=2:"***DO NOT MAIL***",1:"***CRITICAL MEDICAL SHIPMENT***"),?54,$G(ADDR(2)),?102,"Routing: "_$S("W"[$E(MW):MW,1:MW_" MAIL") + W !?54,$G(ADDR(3)),?102,"Days supply: ",$G(DAYS)," Cap: ",$S(PSCAP:"**NON-SFTY**",1:"SAFETY") + W !?54,$G(ADDR(4)),?102,"Isd: ",ISD," Exp: ",EXPDT + W !,PNM,?54,"*Indicate address change on back of this form",?102,"Last Fill: ",$G(PSOLASTF) + W !,$S($D(PSMP(1)):PSMP(1),1:$G(VAPA(1))),?54,"[ ] Permanent",?102,"Pat. Stat ",PATST," Clinic: ",PSCLN + W !,$S($D(PSMP(2)):PSMP(2),$D(PSMP(1)):"",1:$G(ADDR(2))),?54,"[ ] Temporary until ",$S($P($G(VAPA(10)),"^",2)]"":$P($G(VAPA(10)),"^",2),1:"__/__/__"),?102,$S($G(WARN)'="":"DRUG WARNING "_$G(WARN),1:"") + W !,$S($D(PSMP(3)):PSMP(3),$D(PSMP(1)):"",1:$G(ADDR(3))),!,$S($D(PSMP(4)):PSMP(4),$D(PSMP(1)):"",1:$G(ADDR(4))),?54,"Signature",ULN + I $G(PSOBARS) S X="S",X2=PSOINST_"-"_RX S X1=$X W ?102,@PSOBAR1,X2,@PSOBAR0,$C(13) S $X=0 +L13 I $G(WARN)'="",'$G(PSOBLALL) I '$G(PSDFNFLG),'$G(PSOLAPPL) D WARN^PSOLBL2 + W @IOF + ; +PSOAFPL1 I $G(PSOAFYN)="Y" D PSOAFP ;vfah + ; +REP I COPIES>0 S SIDE=1 G ST + D NOW^%DTC S NOW=% K %,%H,%I I $G(RXF)="" S RXF=0 F I=0:0 S I=$O(^PSRX(RX,1,I)) Q:'I S RXF=I + S IR=0 F FDA=0:0 S FDA=$O(^PSRX(RX,"L",FDA)) Q:'FDA S IR=FDA + S IR=IR+1,^PSRX(RX,"L",0)="^52.032DA^"_IR_"^"_IR + S ^PSRX(RX,"L",IR,0)=NOW_"^"_$S($G(RXP):99-RXPI,1:RXF)_"^"_$S($G(PCOMX)]"":$G(PCOMX),$G(PCOMH(RX))]"":PCOMH(RX),1:"From RX number "_$P(^PSRX(RX,0),"^"))_$S($G(RXP):" (Partial)",1:"")_$S($D(REPRINT):" (Reprint)",1:"")_"^"_PDUZ + N PSOBADR,PSOTEMP + S PSOBADR=$$CHKRX^PSOBAI(RX) + I $G(PSOBADR) S PSOTEMP=$P(PSOBADR,"^",2),PSOBADR=$P(PSOBADR,"^") + I $G(PSOBADR),'$G(PSOTEMP) D + .S IR=IR+1,^PSRX(RX,"L",0)="^52.032DA^"_IR_"^"_IR + .S ^PSRX(RX,"L",IR,0)=NOW_"^"_$S($G(RXP):99-RXPI,1:RXF)_"^"_"ROUTING="_$G(MW)_" (BAD ADDRESS)"_"^"_PDUZ + S ^PSRX(RX,"TYPE")=0 K RXF,IR,FDA,NOW,I,PCOMH(RX) +PSOAFPL2 I $G(PSOAFYN)="Y" G PSOAFPL3 ;vfah + I $G(WARN)'="" I $G(PSDFNFLG)!($G(PSOLAPPL)) D ALLWARN^PSOLBLN1 + I $G(WARN)="" I $G(PSDFNFLG)!($G(PSOLAPPL)) D ALL^PSOLBLS + I $G(PSOBLALL) D:$G(WARN)="" ALL^PSOLBLS D:$G(WARN)'="" ALLWARN^PSOLBLN1 + I '$D(PSSPND),$P(PSOPAR,"^",18) I $G(PSDFNFLG)!($G(PSOLAPPL))!($G(PSOBLALL)) D CHCK2^PSOTRLBL +PSOAFPL3 ;vfah + D:$G(PSOBLALL) TRAIL^PSOLBL2 +END ; + I $D(RXFLX(RX)) S RXFL(RX)=$G(RXFLX(RX)) K RXFLX + ; + I '$D(REPRINT)&($G(PSOAFYN)="Y") D ^PSODISP ;vfah auto-release + ; + D KILL^PSOLBL2 Q + ; + Q ;vfah + ; +PSOAFP ;Patient prescription print starts here;vfah + S PSOAFPRV=$P($G(^PSRX(RX,0)),"^",4) + S PSDU=$P($G(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),660)),"^",8) ;vfah sets dispense units + I $G(VFASDD)="Y" S $P(^PSRX(RX,"RXFIN"),"^",1)="Y" ;Sets complex order flag in File#52 + K VFASDD + ; +AFFAX ; + I $G(REPRINT)'=1 D + .S LZ=0,STOP=0 F S LZ=$O(^PSRX(RX,"PRC",LZ)) Q:'LZ!(STOP=1) S LZZ=$P(^PSRX(RX,"PRC",LZ,0),"FAX: ",2) S LZZ=+LZZ I LZZ'=0 D + ..I $D(^DIZ(22900)) D + ...S DIC="^DIZ(22900,",DIC(0)="MOZ",X=LZZ + ...D ^DIC K DIC + ...I +Y'=-1 D + ....S PSOAFFXP=X + ....S PSOAFFXL=$P(Y,"^",2) + ....S ^PSRX(RX,"PRC",LZ,0)=$TR(^PSRX(RX,"PRC",LZ,0),":","+") + ....S STOP=1 + ...I +Y=-1 D + ....S ^PSRX(RX,"PRC",LZ,0)=$TR(^PSRX(RX,"PRC",LZ,0),":","-") + K STOP,LZ,LZZ + I $G(REPRINT)=1 S PSOAFFXP=$G(PSOAFFXR) + I $G(PSOAFFXP)>1 G AFPTL + ; +AFPTS I PSOLAP["STAR" D PRNT^PSOAFPTS + I PSOLAP["STAR" G AFKILL + I PSOLAP["STRL" D PRNT^PSOAFPT1 + I PSOLAP["STRL" G AFKILL + ; +AFPTL D BEGLP^PSOAFPTL + ; +AFKILL K PSOAFPRV + I $G(REPRINT)'=1 D ^%ZISC diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLBLN2.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLBLN2.m index 75fd6f00..65a6cab9 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLBLN2.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLBLN2.m @@ -1,76 +1,76 @@ -PSOLBLN2 ;BHAM ISC/RTR - NEW LABEL TRAILER ; 11/12/06 8:02pm - ;;7.0;OUTPATIENT PHARMACY;**92,107,110,208**;DEC 1997;Build 41 - ; 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 - Q:'+$G(RXN)!('$G(PSOTRAIL))!('+$G(DFN)) - I $G(PSOBLALL),$P(PPL,",",PI+1)'="" Q - K ^TMP($J,"PSOMAIL"),^TMP($J,"PSONARR"),^TMP($J,"PSOSUSP") S PRCOPAY=$S('$D(PSOCPN):0,1:1) -START ;RETURN MAIL - S PS=$S($D(^PS(59,PSOSITE,0)):^(0),1:"") I $P(PSOSYS,"^",4),$D(^PS(59,+$P($G(PSOSYS),"^",4),0)) S PS=^PS(59,$P($G(PSOSYS),"^",4),0) - S VAADDR1=$P(PS,"^"),VASTREET=$P(PS,"^",2),STATE=$S($D(^DIC(5,+$P(PS,"^",8),0)):$P(^(0),"^",2),1:"UNKNOWN") - S PSZIP=$P(PS,"^",5) S PSOHZIP=$S(PSZIP["-":PSZIP,1:$E(PSZIP,1,5)_$S($E(PSZIP,6,9)]"":"-"_$E(PSZIP,6,9),1:"")) - S ^TMP($J,"PSOMAIL",$S(PRCOPAY:1,1:3))="Pharmacy Service (119)",^($S(PRCOPAY:2,1:4))=$G(VAADDR1),^($S(PRCOPAY:3,1:5))=$G(VASTREET),^($S(PRCOPAY:4,1:6))=$P(PS,"^",7)_", "_$G(STATE)_" "_$G(PSOHZIP) - I PRCOPAY F ZZZ=5:1:15 S ^TMP($J,"PSOMAIL",ZZZ)="" - I 'PRCOPAY F ZZZ=7:1:17 S ^TMP($J,"PSOMAIL",ZZZ)="" - S ^TMP($J,"PSOMAIL",$S(PRCOPAY:16,1:18))="Use the label above to mail the computer",^($S(PRCOPAY:17,1:19))="copies back to us. Apply enough postage",^($S(PRCOPAY:18,1:20))="to your envelope to ensure delivery." -NARR ;SET TMP GLOBAL FOR NARRATIVES - K ^UTILITY($J,"W") S (DIWL,PSNACNT)=1,DIWR=45,DIWF="",(PSSIXFL,PSSEVFL)=0 F ZZ=0:0 S ZZ=$O(^PS(59,PSOSITE,6,ZZ)) Q:'ZZ I $D(^(ZZ,0)) S X=^(0) D ^DIWP - F LLL=0:0 S LLL=$O(^UTILITY($J,"W",DIWL,LLL)) Q:'LLL S ^TMP($J,"PSONARR",PSNACNT)=^UTILITY($J,"W",DIWL,LLL,0) S PSNACNT=PSNACNT+1,PSSIXFL=1 - I PSSIXFL S ^TMP($J,"PSONARR",PSNACNT)="" S PSNACNT=PSNACNT+1 - S DIWL=1,DIWR=45,DIWF="" K ^UTILITY($J,"W") F ZZ=0:0 S ZZ=$O(^PS(59,PSOSITE,7,ZZ)) Q:'ZZ I $D(^(ZZ,0)) S X=^(0) D ^DIWP - F LLL=0:0 S LLL=$O(^UTILITY($J,"W",DIWL,LLL)) Q:'LLL S ^TMP($J,"PSONARR",PSNACNT)=^UTILITY($J,"W",DIWL,LLL,0) S PSNACNT=PSNACNT+1,PSSEVFL=1 - I $G(PSOCHAMP),$G(PSOTRAMT) D:PSSEVFL S ^TMP($J,"PSONARR",PSNACNT)="REMIT $"_PSOTRAMT_" TO AGENT CASHIER." G SUSP - .S ^TMP($J,"PSONARR",PSNACNT)="" S PSNACNT=PSNACNT+1 - I 'PRCOPAY G SUSP - I PSSEVFL S ^TMP($J,"PSONARR",PSNACNT)="" S PSNACNT=PSNACNT+1 - S DIWL=1,DIWR=45,DIWF="" K ^UTILITY($J,"W") F ZZ=0:0 S ZZ=$O(^PS(59,PSOSITE,4,ZZ)) Q:'ZZ I $D(^(ZZ,0)) S X=^(0) D ^DIWP - F LLL=0:0 S LLL=$O(^UTILITY($J,"W",DIWL,LLL)) Q:'LLL S ^TMP($J,"PSONARR",PSNACNT)=^UTILITY($J,"W",DIWL,LLL,0) S PSNACNT=PSNACNT+1 -SUSP ;SUSPENSE DOCUMENT - S (PSSUFLG,PSSPCNT)=0 S:'$D(DFN) DFN=+$P($G(^PSRX(RX,0)),"^",2) S PSODFN=DFN,(SPPL,RXX,STA)="" - I $G(PSODTCUT)']"" S X1=DT,X2=-120 D C^%DTC S PSODTCUT=X - D ^PSOBUILD S (STA,RXX)="" F S STA=$O(PSOSD(STA)) Q:STA="" F S RXX=$O(PSOSD(STA,RXX)) Q:RXX="" I $P(PSOSD(STA,RXX),"^",2)=5 S SPPL=$P(PSOSD(STA,RXX),"^")_","_SPPL - D 6^VADPT,PID^VADPT I SPPL="" S PSSUFLG=1 G PRINT - S ^TMP($J,"PSOSUSP",1)=$E($P(VADM(2),"^",2),5,12),^(2)=VADM(1),^(3)=$G(VAPA(1)),^(4)=$G(ADDR(2)) I $G(ADDR(3))="",$G(ADDR(4))="" S ^TMP($J,"PSOSUSP",5)="" G ADD - I $G(ADDR(3))'="",$G(ADDR(4))="" S ^TMP($J,"PSOSUSP",5)=$G(ADDR(3)) S ^TMP($J,"PSOSUSP",6)="" G ADD - S ^TMP($J,"PSOSUSP",5)=$G(ADDR(3)),^(6)=$G(ADDR(4)),^(7)="" -ADD F ZZ=0:0 S ZZ=$O(^TMP($J,"PSOSUSP",ZZ)) Q:'ZZ S PSSPCNT=ZZ - S PSSPCNT=PSSPCNT+1 S ^TMP($J,"PSOSUSP",PSSPCNT)=" The following prescriptions will be" S PSSPCNT=PSSPCNT+1 S ^TMP($J,"PSOSUSP",PSSPCNT)="mailed to you on or after the date indicated." S PSSPCNT=PSSPCNT+1 - S ^TMP($J,"PSOSUSP",PSSPCNT)="",PSSPCNT=PSSPCNT+1,^(PSSPCNT)="Rx# Date",PSSPCNT=PSSPCNT+1,^(PSSPCNT)="============================================",PSSPCNT=PSSPCNT+1,^(PSSPCNT)="",PSSPCNT=PSSPCNT+1 - F XX=1:1 Q:$P(SPPL,",",XX)="" S PSSSRX=$P(SPPL,",",XX) D - .S SPNUM=$O(^PS(52.5,"B",PSSSRX,0)) I SPNUM S SPDATE=$P($G(^PS(52.5,SPNUM,0)),"^",2) S Y=SPDATE D DD^%DT S SPDATE=Y - .S $P(PSOLGTH," ",(20-($L($P(^PSRX(PSSSRX,0),"^")))))="" S ^TMP($J,"PSOSUSP",PSSPCNT)=$P(^PSRX(PSSSRX,0),"^")_PSOLGTH_$G(SPDATE) S PSSPCNT=PSSPCNT+1 - .S ^TMP($J,"PSOSUSP",PSSPCNT)=" "_$$ZZ^PSOSUTL(PSSSRX) S PSSPCNT=PSSPCNT+1 K SPNUM,SPDATE,Y -PRINT S PSOTRDFN=$P(VADM(2),"^"),PSOTRDFN=$S(PSOTRDFN]"":PSOTRDFN,1:"Unavailable") S Y=DT X ^DD("DD") S EDT=Y - ;W ?54,VADM(1)_" "_$E($P(VADM(2),"^",2),5,12)_" "_EDT ;vfah - W ! I PRCOPAY,$G(PSOBARS) S X="S",X2=PSOTRDFN,X1=$X W ?54,@PSOBAR1,PSOTRDFN,@PSOBAR0,$C(13) S $X=0 - I PRCOPAY,'$G(PSOBARS) W !!! - I 'PRCOPAY W ! - I 'PSSUFLG D PRSUS G END - ;S (PSNONARR,PSNOADDR,PSNOBOTH)=0 F TTT=1:1 Q:$G(PSNOBOTH) D ;vfah - ;.W $G(^TMP($J,"PSOMAIL",TTT)) S:'$O(^(TTT)) PSNOADDR=1 ;vfah - ;.W ?54,$G(^TMP($J,"PSONARR",TTT)),! S:'$O(^(TTT)) PSNONARR=1 ;vfah - ;.I PSNOADDR,PSNONARR S PSNOBOTH=1 ;vfah -END K ^TMP($J,"PSONARR"),^TMP($J,"PSOMAIL"),^TMP($J,"PSOSUSP"),^UTILITY($J,"W") - K DIWF,DIWL,DIWR,EDT,LLL,PRCOPAY,PS,PSNACNT,PSNOADDR,PSNOBOTH,PSNONARR,PSNOSUSP,PSNTHREE,PSOLGTH,PSOSD,PSOTRAIL,PSOTRDFN,PSSEVFL,PSSIXFL,PSSPCNT,PSSSRX,PSSUFLG,RXX,SPDATE,SPNUM,SPPL,STATE,TTT,VAADDR1,VADM,VAEL,VAPA,VASTREET,ZZ,ZZZ W @IOF - ;I $P(PSOPAR,"^",31) D BLANK^PSOLBLD W @IOF - I $P(PSOPAR,"^",31)="1" D BLANK^PSOLBLD W @IOF ;vfah - Q -PRSUS S (PSNONARR,PSNOADDR,PSNOSUSP,PSNTHREE)=0 F TTT=1:1 Q:$G(PSNTHREE) D - .W $G(^TMP($J,"PSOMAIL",TTT)) S:'$O(^(TTT)) PSNOADDR=1 - .W ?54,$G(^TMP($J,"PSONARR",TTT)) S:'$O(^(TTT)) PSNONARR=1 - .W ?102,$G(^TMP($J,"PSOSUSP",TTT)),! S:'$O(^(TTT)) PSNOSUSP=1 - .I PSNOADDR,PSNONARR,PSNOSUSP S PSNTHREE=1 +PSOLBLN2 ;BHAM ISC/RTR - NEW LABEL TRAILER ; 11/12/06 8:02pm + ;;7.0;OUTPATIENT PHARMACY;**92,107,110,208**;DEC 1997;Build 39 + ; 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 + Q:'+$G(RXN)!('$G(PSOTRAIL))!('+$G(DFN)) + I $G(PSOBLALL),$P(PPL,",",PI+1)'="" Q + K ^TMP($J,"PSOMAIL"),^TMP($J,"PSONARR"),^TMP($J,"PSOSUSP") S PRCOPAY=$S('$D(PSOCPN):0,1:1) +START ;RETURN MAIL + S PS=$S($D(^PS(59,PSOSITE,0)):^(0),1:"") I $P(PSOSYS,"^",4),$D(^PS(59,+$P($G(PSOSYS),"^",4),0)) S PS=^PS(59,$P($G(PSOSYS),"^",4),0) + S VAADDR1=$P(PS,"^"),VASTREET=$P(PS,"^",2),STATE=$S($D(^DIC(5,+$P(PS,"^",8),0)):$P(^(0),"^",2),1:"UNKNOWN") + S PSZIP=$P(PS,"^",5) S PSOHZIP=$S(PSZIP["-":PSZIP,1:$E(PSZIP,1,5)_$S($E(PSZIP,6,9)]"":"-"_$E(PSZIP,6,9),1:"")) + S ^TMP($J,"PSOMAIL",$S(PRCOPAY:1,1:3))="Pharmacy Service (119)",^($S(PRCOPAY:2,1:4))=$G(VAADDR1),^($S(PRCOPAY:3,1:5))=$G(VASTREET),^($S(PRCOPAY:4,1:6))=$P(PS,"^",7)_", "_$G(STATE)_" "_$G(PSOHZIP) + I PRCOPAY F ZZZ=5:1:15 S ^TMP($J,"PSOMAIL",ZZZ)="" + I 'PRCOPAY F ZZZ=7:1:17 S ^TMP($J,"PSOMAIL",ZZZ)="" + S ^TMP($J,"PSOMAIL",$S(PRCOPAY:16,1:18))="Use the label above to mail the computer",^($S(PRCOPAY:17,1:19))="copies back to us. Apply enough postage",^($S(PRCOPAY:18,1:20))="to your envelope to ensure delivery." +NARR ;SET TMP GLOBAL FOR NARRATIVES + K ^UTILITY($J,"W") S (DIWL,PSNACNT)=1,DIWR=45,DIWF="",(PSSIXFL,PSSEVFL)=0 F ZZ=0:0 S ZZ=$O(^PS(59,PSOSITE,6,ZZ)) Q:'ZZ I $D(^(ZZ,0)) S X=^(0) D ^DIWP + F LLL=0:0 S LLL=$O(^UTILITY($J,"W",DIWL,LLL)) Q:'LLL S ^TMP($J,"PSONARR",PSNACNT)=^UTILITY($J,"W",DIWL,LLL,0) S PSNACNT=PSNACNT+1,PSSIXFL=1 + I PSSIXFL S ^TMP($J,"PSONARR",PSNACNT)="" S PSNACNT=PSNACNT+1 + S DIWL=1,DIWR=45,DIWF="" K ^UTILITY($J,"W") F ZZ=0:0 S ZZ=$O(^PS(59,PSOSITE,7,ZZ)) Q:'ZZ I $D(^(ZZ,0)) S X=^(0) D ^DIWP + F LLL=0:0 S LLL=$O(^UTILITY($J,"W",DIWL,LLL)) Q:'LLL S ^TMP($J,"PSONARR",PSNACNT)=^UTILITY($J,"W",DIWL,LLL,0) S PSNACNT=PSNACNT+1,PSSEVFL=1 + I $G(PSOCHAMP),$G(PSOTRAMT) D:PSSEVFL S ^TMP($J,"PSONARR",PSNACNT)="REMIT $"_PSOTRAMT_" TO AGENT CASHIER." G SUSP + .S ^TMP($J,"PSONARR",PSNACNT)="" S PSNACNT=PSNACNT+1 + I 'PRCOPAY G SUSP + I PSSEVFL S ^TMP($J,"PSONARR",PSNACNT)="" S PSNACNT=PSNACNT+1 + S DIWL=1,DIWR=45,DIWF="" K ^UTILITY($J,"W") F ZZ=0:0 S ZZ=$O(^PS(59,PSOSITE,4,ZZ)) Q:'ZZ I $D(^(ZZ,0)) S X=^(0) D ^DIWP + F LLL=0:0 S LLL=$O(^UTILITY($J,"W",DIWL,LLL)) Q:'LLL S ^TMP($J,"PSONARR",PSNACNT)=^UTILITY($J,"W",DIWL,LLL,0) S PSNACNT=PSNACNT+1 +SUSP ;SUSPENSE DOCUMENT + S (PSSUFLG,PSSPCNT)=0 S:'$D(DFN) DFN=+$P($G(^PSRX(RX,0)),"^",2) S PSODFN=DFN,(SPPL,RXX,STA)="" + I $G(PSODTCUT)']"" S X1=DT,X2=-120 D C^%DTC S PSODTCUT=X + D ^PSOBUILD S (STA,RXX)="" F S STA=$O(PSOSD(STA)) Q:STA="" F S RXX=$O(PSOSD(STA,RXX)) Q:RXX="" I $P(PSOSD(STA,RXX),"^",2)=5 S SPPL=$P(PSOSD(STA,RXX),"^")_","_SPPL + D 6^VADPT,PID^VADPT I SPPL="" S PSSUFLG=1 G PRINT + S ^TMP($J,"PSOSUSP",1)=$E($P(VADM(2),"^",2),5,12),^(2)=VADM(1),^(3)=$G(VAPA(1)),^(4)=$G(ADDR(2)) I $G(ADDR(3))="",$G(ADDR(4))="" S ^TMP($J,"PSOSUSP",5)="" G ADD + I $G(ADDR(3))'="",$G(ADDR(4))="" S ^TMP($J,"PSOSUSP",5)=$G(ADDR(3)) S ^TMP($J,"PSOSUSP",6)="" G ADD + S ^TMP($J,"PSOSUSP",5)=$G(ADDR(3)),^(6)=$G(ADDR(4)),^(7)="" +ADD F ZZ=0:0 S ZZ=$O(^TMP($J,"PSOSUSP",ZZ)) Q:'ZZ S PSSPCNT=ZZ + S PSSPCNT=PSSPCNT+1 S ^TMP($J,"PSOSUSP",PSSPCNT)=" The following prescriptions will be" S PSSPCNT=PSSPCNT+1 S ^TMP($J,"PSOSUSP",PSSPCNT)="mailed to you on or after the date indicated." S PSSPCNT=PSSPCNT+1 + S ^TMP($J,"PSOSUSP",PSSPCNT)="",PSSPCNT=PSSPCNT+1,^(PSSPCNT)="Rx# Date",PSSPCNT=PSSPCNT+1,^(PSSPCNT)="============================================",PSSPCNT=PSSPCNT+1,^(PSSPCNT)="",PSSPCNT=PSSPCNT+1 + F XX=1:1 Q:$P(SPPL,",",XX)="" S PSSSRX=$P(SPPL,",",XX) D + .S SPNUM=$O(^PS(52.5,"B",PSSSRX,0)) I SPNUM S SPDATE=$P($G(^PS(52.5,SPNUM,0)),"^",2) S Y=SPDATE D DD^%DT S SPDATE=Y + .S $P(PSOLGTH," ",(20-($L($P(^PSRX(PSSSRX,0),"^")))))="" S ^TMP($J,"PSOSUSP",PSSPCNT)=$P(^PSRX(PSSSRX,0),"^")_PSOLGTH_$G(SPDATE) S PSSPCNT=PSSPCNT+1 + .S ^TMP($J,"PSOSUSP",PSSPCNT)=" "_$$ZZ^PSOSUTL(PSSSRX) S PSSPCNT=PSSPCNT+1 K SPNUM,SPDATE,Y +PRINT S PSOTRDFN=$P(VADM(2),"^"),PSOTRDFN=$S(PSOTRDFN]"":PSOTRDFN,1:"Unavailable") S Y=DT X ^DD("DD") S EDT=Y + ;W ?54,VADM(1)_" "_$E($P(VADM(2),"^",2),5,12)_" "_EDT ;vfah + W ! I PRCOPAY,$G(PSOBARS) S X="S",X2=PSOTRDFN,X1=$X W ?54,@PSOBAR1,PSOTRDFN,@PSOBAR0,$C(13) S $X=0 + I PRCOPAY,'$G(PSOBARS) W !!! + I 'PRCOPAY W ! + I 'PSSUFLG D PRSUS G END + ;S (PSNONARR,PSNOADDR,PSNOBOTH)=0 F TTT=1:1 Q:$G(PSNOBOTH) D ;vfah + ;.W $G(^TMP($J,"PSOMAIL",TTT)) S:'$O(^(TTT)) PSNOADDR=1 ;vfah + ;.W ?54,$G(^TMP($J,"PSONARR",TTT)),! S:'$O(^(TTT)) PSNONARR=1 ;vfah + ;.I PSNOADDR,PSNONARR S PSNOBOTH=1 ;vfah +END K ^TMP($J,"PSONARR"),^TMP($J,"PSOMAIL"),^TMP($J,"PSOSUSP"),^UTILITY($J,"W") + K DIWF,DIWL,DIWR,EDT,LLL,PRCOPAY,PS,PSNACNT,PSNOADDR,PSNOBOTH,PSNONARR,PSNOSUSP,PSNTHREE,PSOLGTH,PSOSD,PSOTRAIL,PSOTRDFN,PSSEVFL,PSSIXFL,PSSPCNT,PSSSRX,PSSUFLG,RXX,SPDATE,SPNUM,SPPL,STATE,TTT,VAADDR1,VADM,VAEL,VAPA,VASTREET,ZZ,ZZZ W @IOF + ;I $P(PSOPAR,"^",31) D BLANK^PSOLBLD W @IOF + I $P(PSOPAR,"^",31)="1" D BLANK^PSOLBLD W @IOF ;vfah + Q +PRSUS S (PSNONARR,PSNOADDR,PSNOSUSP,PSNTHREE)=0 F TTT=1:1 Q:$G(PSNTHREE) D + .W $G(^TMP($J,"PSOMAIL",TTT)) S:'$O(^(TTT)) PSNOADDR=1 + .W ?54,$G(^TMP($J,"PSONARR",TTT)) S:'$O(^(TTT)) PSNONARR=1 + .W ?102,$G(^TMP($J,"PSOSUSP",TTT)),! S:'$O(^(TTT)) PSNOSUSP=1 + .I PSNOADDR,PSNONARR,PSNOSUSP S PSNTHREE=1 diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLLLI.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLLLI.m index cfca6a71..dcafc60a 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLLLI.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLLLI.m @@ -1,152 +1,152 @@ -PSOLLLI ;BIR/JLC - LASER LABELS INITIALIZATION ;4/25/07 9:00am - ;;7.0;OUTPATIENT PHARMACY;**120,157,189,161,244,200,206,225**;DEC 1997;Build 29 - ; - ;DBIAs PSDRUG-221, PS(55-2228, SC-10040, IBARX-125, PSXSRP-2201, %ZIS-3435, DPT-3097, ^TMP($J,"PSNPPIO"-3794 - ;External reference to DRUG^PSSWRNA supported by DBIA 4449 - ; - ;*244 remove test for partial fill when testing status > 11 - ; -DQ N PSOBIO S (I,PSOIO)=0 F S I=$O(^%ZIS(2,IOST(0),55,I)) Q:'I S X0=$G(^(I,0)) I X0]"" S PSOIO($P(X0,"^"))=^(1),PSOIO=1 -DQ1 I '$D(PPL) G HLEX - I $P($G(PSOPAR),"^",30)=2,'$G(PSOEXREP) G HLEX - K RXFLX S PSOCKHN=","_$G(PPL),PSRESOLV=+PPL D CHECK - S PSOINT=1 F PI=1:1 S RX=$P(PPL,",",PI) Q:RX="" D - . S RXY=$G(^PSRX(RX,0)) Q:RXY="" I PSOPDFN'=$P(RXY,"^",2),'PSOINT D TRAIL^PSOLLL1 S PSOPDFN=$P(RXY,"^",2) - . K RXP,REPRINT D C - I 'PSOINT D TRAIL^PSOLLL1 -HLEX K RXPI,PSORX,RXP,PSOIOS,PSOLAPPL,XXX,COPAYVAR,TECH,PHYS,MFG,NURSE,STATE,SIDE,COPIES,EXDT,ISD,PSOINST,RXN,RXY,VADT,DEA,WARN,FDT,QTY,PATST,PDA,PS,PS1,RXP,REPRINT - K SGY,OSGY,PS2,PSL,PSNP,INRX,RR,XTYPE,SSNP,SSNPN,PNM,ADDR,PSODBQ,PSOLASTF,PSRESOLV,PSOEXREP,PSOSXQ - K DATE,DR,DRUG,LINE,MW,PRTFL,VRPH,EXPDT,X2,DIFF,DAYS,PSZIP,PSOHZIP,PS55,PS55X - K ^TMP($J,"PSNPMI"),^TMP($J,"PSOCP",+$G(PSOCPN)),PSOCPN,PSOLBLDR,PSOLBLPS,PSOLBLCP,RXPR,RXRP,RXRS,PSOCKHN,RXFLX,PSOLAPPL,PSOPDFN,PSDFNFLG,PSOZERO,NEXTRX,PSOBLALL,STA - I '$G(PSOSUREP),'$G(PSOSUSPR) S ZTREQ="@" - Q -C N PSOBIO S (I,PSOIO)=0 F S I=$O(^%ZIS(2,IOST(0),55,I)) Q:'I S X0=$G(^(I,0)) I X0]"" S PSOIO($P(X0,"^"))=^(1),PSOIO=1 - U IO Q:'$D(^PSRX(RX,0)) S RXY=^(0),RX2=^(2),RXSTA=^("STA") K SGY,OSGY - S (SIGM,PFM,PMIM,L2,L3,L4,L5,FILLCONT,BOTTLBL)=0 - K SIGF,PFF,PMIF S (SIGF,PFF,PMIF)=0 F I="DR","T" S (SIGF(I),PFF(I))=1 - F I="A","B","I" S PMIF(I)=1 - D NOW^%DTC S Y=$P(%,"."),PSOFNOW=% X ^DD("DD") S PSONOW=Y,Y=PSOFNOW X ^DD("DD") S PSONOWT=Y - S:$G(PSOBLALL) PSOBLRX=RX S:$D(RXRP(RX)) REPRINT=1 S:$D(RXPR(RX)) RXP=RXPR(RX) - I $G(PSOSUREP)!($G(PSOEXREP)) S REPRINT=1 I '$G(RXRP(RX)) S RXRP(RX)=1 - S A=$P(RXSTA,"^") I A>11 D AL^PSOLBL("QT") K RXP,REPRINT Q ;*244 - I A=3 D AL^PSOLBL("QT") K RXP,REPRINT Q - I $G(RXPR(RX)),'$D(^PSRX(RX,"P",RXP,0)) K RXP,REPRINT Q - I $P($G(RXFL(RX)),"^"),'$D(^PSRX(RX,1,$P($G(RXFL(RX)),"^"),0)) K RXP,REPRINT Q - I $G(PSODBQ)!($G(RXRS(RX))) S RR=$O(^PS(52.5,"B",RX,0)) Q:'RR I $G(^PS(52.5,RR,"P"))=1 K RXP,REPRINT Q - I $G(RXRS(RX))!($G(PSOPULL)) S PSOSXQ=0 N DR,DA,DIE D I $G(PSOSXQ) K RXP,REPRINT Q - . S DA=$O(^PS(52.5,"B",RX,0)) Q:'DA - . S A=$P($G(^PS(52.5,DA,0)),"^",7) I A="" Q - . I A="Q" S DIE="^PS(52.5,",DR="3////P" D ^DIE Q - . K RXRS(RX) S PSOSXQ=1 - I $G(PSRESOLV)=RX D ENLBL^PSOBSET K PSRESOLV - I $P(RXSTA,"^")'=4 D - . I $G(PSOSUSPR) D AREC^PSOSUTL - . I $G(PSOPULL)!($G(RXRS(RX))) D AREC1^PSOSUTL - . I $G(PSOSUREP) D AREC^PSOSUSRP - . I $G(PSXREP) D AREC^PSXSRP - S RXY=^PSRX(RX,0),RX2=^(2),RXSTA=^("STA") - K ^UTILITY("DIQ1",$J) S DA=$P($$SITE^VASITE(),"^") - I $G(DA) S DIC=4,DIQ(0)="I",DR="99" D EN^DIQ1 S PSOINST=$G(^UTILITY("DIQ1",$J,4,DA,99,"I")) K ^UTILITY("DIQ1",$J),DA,DR,DIC - S RXN=$P(RXY,"^"),DFN=+$P(RXY,"^",2),PSOLBLPS=+$P(RXY,"^",3),PSOLBLDR=+$P(RXY,"^",6) - S ISD=$P(RXY,"^",13),RXF=0,SIG=$P($G(^PSRX(RX,"SIG")),"^"),ISD=$E(ISD,4,5)_"/"_$E(ISD,6,7)_"/"_($E(ISD,1,3)+1700),ZY=0,$P(LINE,"_",28)="_" - S NURSE=$S($P($G(^DPT(DFN,"NHC")),"^")="Y":1,$P($G(^PS(55,DFN,40)),"^"):1,1:0) - S FDT=$P(RX2,"^",2),PS=$S($D(^PS(59,PSOSITE,0)):^(0),1:""),PS1=$S($D(^(1)):^(1),1:""),PSOSITE7=$P(^("IB"),"^") - S PS2=$P(PS,"^")_"^"_$P(PS,"^",6) - S EXPDT=$P(RX2,"^",6),EXDT=$S('EXPDT:"",1:$E(EXPDT,4,5)_"/"_$E(EXPDT,6,7)_"/"_($E(EXPDT,1,3)+1700)) - S COPIES=$S($P($G(RXRP(RX)),"^",2):$P($G(RXRP(RX)),"^",2),$P(RXY,"^",18)]"":$P(RXY,"^",18),1:1) - K PSOCKHNX S PSOCKHL=$L(RX),PSOCKHN=$E($G(PSOCKHN),(PSOCKHL+2),999) D K PSOCKHNX,PSOCKHL,PSOCKHA - .S PSOCKHA=","_RX_"," - .I PSOCKHN'[PSOCKHA Q - .S PSOCKHA=$E(PSOCKHA,1,($L(PSOCKHA)-1)) - .S PSOCKHNX=$L(PSOCKHN,PSOCKHA)-1 - .I +$G(PSOCKHNX)>0 D DOUB - I $O(^PSRX(RX,1,0)),$G(RXFL(RX))'=0 S $P(^PSRX(RX,3),"^",6)="" K ^PSRX(RX,"DAI"),^PSRX(RX,"DRI") - I '$G(RXP),'$O(^PSRX(RX,1,0)) S RXFL(RX)=0 - I '$G(RXP) D OSET I '$O(^PSRX(RX,1,0))!($G(RXFL(RX))=0) G ORIG - I $O(^PSRX(RX,1,0)),'$G(RXP) D G STA - . I '$G(RXFL(RX)) S XTYPE=1 D REF - I $G(RXP) S XTYPE="P" D REF G STA -ORIG S TECH=$P($G(^VA(200,+$P(RXY,"^",16),0)),"^"),PHYS=$S($D(^VA(200,+$P(RXY,"^",4),0)):$P(^(0),"^"),1:"UKN") - S DAYS=$P(RXY,"^",8),QTY=$P(RXY,"^",7) - D 6^VADPT,PID^VADPT6 S SSNPN=$G(VA("BID")) -STA S STATE=$S($D(^DIC(5,+$P(PS,"^",8),0)):$P(^(0),"^",2),1:"UKN") - S DRUG=$$ZZ^PSOSUTL(RX),DEA=$P($G(^PSDRUG(+$P(RXY,"^",6),0)),"^",3),WARN=$P($G(^(0)),"^",8) - S WARN=$$DRUG^PSSWRNA(+$P(RXY,"^",6),+$P(RXY,"^",2)) - S SIDE=$S($P($G(RXRP(RX)),"^",3):1,1:0) - I $G(^PSRX(RX,"P",+$G(RXP),0))]"" S RXPI=RXP D - .S RXP=^PSRX(RX,"P",RXP,0) - .S RXY=$P(RXP,"^")_"^"_$P(RXY,"^",2,6)_"^"_$P(RXP,"^",4)_"^"_$P(RXP,"^",10)_"^"_$P(RXY,"^",9)_"^"_$P($G(^PSRX(RX,"SIG")),"^",2)_"^"_$P(RXP,"^",2)_"^"_$P(RXY,"^",12,14)_"^"_$P(^PSRX(RX,"STA"),"^")_"^"_$P(RXP,"^",7)_"^"_$P(RXY,"^",17,99) - .S FDT=$P(RXP,"^") - S MW=$P(RXY,"^",11) I $G(RXFL(RX))'=0 D:$G(RXFL(RX)) I '$G(RXFL(RX)) F I=0:0 S I=$O(^PSRX(RX,1,I)) Q:'I S RXF=RXF+1 S:'$G(RXP) MW=$P(^PSRX(RX,1,I,0),"^",2) I +^PSRX(RX,1,I,0)'30) - .K PSMP(PSI) - ;New mail codes for CMOP - S MAILCOM="" - S X=$G(^PS(55,DFN,0)),PSCAP=$P(X,"^",2),PS55=$P(X,"^",3),PS55X=$P(X,"^",5) - I PS55X]"",PS55>1,PS55X
0,$P(^("STA"),"^")'=2,'$G(PSODBQ) D SNO G LBL - I $G(PSOLBLCP)="" D IBCP - N PSOQI S PSOQI=$G(^PSRX(RX,"IBQ")) - I $G(PSOLBLCP)=0 D SNO G LBL - I $G(PSOLBLCP)=1 I $P(PSOQI,"^",2)!($P(PSOQI,"^",3))!($P(PSOQI,"^",4))!($P(PSOQI,"^",5))!($P(PSOQI,"^",6))!($P(PSOQI,"^",7))!($P(PSOQI,"^",8)) D SNO G LBL - I $G(PSOLBLCP)=2 I $P(PSOQI,"^")!($P(PSOQI,"^",2))!($P(PSOQI,"^",3))!($P(PSOQI,"^",4))!($P(PSOQI,"^",5))!($P(PSOQI,"^",6))!($P(PSOQI,"^",7))!($P(PSOQI,"^",8)) D SNO G LBL - I $G(PSOLBLCP)=2,'$P($G(^PSRX(RX,"IB")),"^") D SNO G LBL - S PSOCPN=$P(RXY,"^",2),INRX=$P(RXY,"^") - I $G(^TMP($J,"PSOCP",PSOCPN))="" S ^(PSOCPN)=PSOCPN - S ^TMP($J,"PSOCP",PSOCPN,INRX)=INRX_"^"_$$ZZ^PSOSUTL(RX)_"^"_+$G(DAYS),COPAYVAR="COPAY" K ZDRUG -LBL I $G(PSOIO("LLI"))]"" X PSOIO("LLI") - I $P(RXSTA,"^")=4 D ^PSOLLL8 Q ;for a critical interaction entered by a tech - don't allow a label to be printed - I $D(^PSRX(RX,"DRI")),'$G(RXF),'$G(RXP) D ^PSOLLL8 - I $P($G(^PSRX(RX,3)),"^",6),'$G(RXF),'$G(RXP) D ^PSOLLL9 - S PSOINT=0 G ^PSOLLL1 -REF F XXX=0:0 S XXX=$O(^PSRX(RX,XTYPE,XXX)) Q:+XXX'>0 D - .S TECH=$S($D(^VA(200,+$P(^PSRX(RX,XTYPE,XXX,0),"^",7),0)):$P(^(0),"^"),1:"UNKNOWN") - .S QTY=$P(^PSRX(RX,XTYPE,XXX,0),"^",4),PHYS=$S($D(^VA(200,+$P(^PSRX(RX,XTYPE,XXX,0),"^",17),0)):$P(^(0),"^"),$D(^VA(200,+$P(^PSRX(RX,0),"^",4),0)):$P(^(0),"^"),1:"UNKNOWN") D 6^VADPT,PID^VADPT6 S SSNPN=$G(VA("BID")) - .S DAYS=$P(^PSRX(RX,XTYPE,XXX,0),"^",10) - Q -CHECK S PSDFNFLG=0,PSOZERO=$P(PPL,","),PSOPDFN=$P(^PSRX(PSOZERO,0),"^",2) - Q -OSET ; - N A - I $G(RXFL(RX))']""!($G(RXFL(RX))=0) D Q - .S A=^PSRX(RX,0) - .S TECH=$P($G(^VA(200,+$P(A,"^",16),0)),"^"),QTY=$P(A,"^",7),PHYS=$S($D(^VA(200,+$P(A,"^",4),0)):$P(^(0),"^"),1:"UKN") D 6^VADPT,PID^VADPT6 S SSNPN=$G(VA("BID")) - .S DAYS=$P(A,"^",8) - I '$D(^PSRX(RX,1,RXFL(RX),0)) K RXFL(RX) Q - S A=^PSRX(RX,1,RXFL(RX),0) - S TECH=$S($D(^VA(200,+$P(A,"^",7),0)):$P(^(0),"^"),1:"UNKNOWN") - S QTY=$P(A,"^",4),PHYS=$S($D(^VA(200,+$P(A,"^",17),0)):$P(^(0),"^"),$D(^VA(200,+$P(^PSRX(RX,0),"^",4),0)):$P(^(0),"^"),1:"UNKNOWN") D 6^VADPT,PID^VADPT6 S SSNPN=$G(VA("BID")) - S DAYS=$P(A,"^",10) - Q -DOUB ; - Q:'$D(RXFL(RX)) - I +$G(RXFL(RX))-PSOCKHNX<0 Q - S RXFLX(RX)=$G(RXFL(RX)) - S RXFL(RX)=$G(RXFL(RX))-PSOCKHNX - Q -IBCP ; - N X,Y,PSOJJ,PSOLL - S PSOLBLCP="" - S X=$P($G(^PS(59,+$G(PSOSITE),"IB")),"^")_"^"_$G(DFN) D XTYPE^IBARX - S PSOJJ="" F S PSOJJ=$O(Y(PSOJJ)) Q:'PSOJJ S PSOLL="" F S PSOLL=$O(Y(PSOJJ,PSOLL)) Q:PSOLL="" S:PSOLL>0 PSOLBLCP=PSOLL - I '$G(PSOLBLCP) S PSOLBLCP=0 - Q -SNO ; - S COPAYVAR="NO COPAY" - Q +PSOLLLI ;BIR/JLC - LASER LABELS INITIALIZATION ;10 Oct 2006 4:56 PM + ;;7.0;OUTPATIENT PHARMACY;**120,157,189,161,244,200**;DEC 1997;Build 7 + ; + ;DBIAs PSDRUG-221, PS(55-2228, SC-10040, IBARX-125, PSXSRP-2201, %ZIS-3435, DPT-3097, ^TMP($J,"PSNPPIO"-3794 + ;External reference to DRUG^PSSWRNA supported by DBIA 4449 + ; + ;*244 remove test for partial fill when testing status > 11 + ; +DQ N PSOBIO S (I,PSOIO)=0 F S I=$O(^%ZIS(2,IOST(0),55,I)) Q:'I S X0=$G(^(I,0)) I X0]"" S PSOIO($P(X0,"^"))=^(1),PSOIO=1 +DQ1 I '$D(PPL) G HLEX + I $P($G(PSOPAR),"^",30)=2,'$G(PSOEXREP) G HLEX + K RXFLX S PSOCKHN=","_$G(PPL),PSRESOLV=+PPL D CHECK + S PSOINT=1 F PI=1:1 S RX=$P(PPL,",",PI) Q:RX="" D + . S RXY=$G(^PSRX(RX,0)) Q:RXY="" I PSOPDFN'=$P(RXY,"^",2),'PSOINT D TRAIL^PSOLLL1 S PSOPDFN=$P(RXY,"^",2) + . K RXP,REPRINT D C + I 'PSOINT D TRAIL^PSOLLL1 +HLEX K RXPI,PSORX,RXP,PSOIOS,PSOLAPPL,XXX,COPAYVAR,TECH,PHYS,MFG,NURSE,STATE,SIDE,COPIES,EXDT,ISD,PSOINST,RXN,RXY,VADT,DEA,WARN,FDT,QTY,PATST,PDA,PS,PS1,RXP,REPRINT + K SGY,OSGY,PS2,PSL,PSNP,INRX,RR,XTYPE,SSNP,SSNPN,PNM,ADDR,PSODBQ,PSOLASTF,PSRESOLV,PSOEXREP,PSOSXQ + K DATE,DR,DRUG,LINE,MW,PRTFL,VRPH,EXPDT,X2,DIFF,DAYS,PSZIP,PSOHZIP,PS55,PS55X + K ^TMP($J,"PSNPMI"),^TMP($J,"PSOCP",+$G(PSOCPN)),PSOCPN,PSOLBLDR,PSOLBLPS,PSOLBLCP,RXPR,RXRP,RXRS,PSOCKHN,RXFLX,PSOLAPPL,PSOPDFN,PSDFNFLG,PSOZERO,NEXTRX,PSOBLALL,STA + I '$G(PSOSUREP),'$G(PSOSUSPR) S ZTREQ="@" + Q +C N PSOBIO S (I,PSOIO)=0 F S I=$O(^%ZIS(2,IOST(0),55,I)) Q:'I S X0=$G(^(I,0)) I X0]"" S PSOIO($P(X0,"^"))=^(1),PSOIO=1 + U IO Q:'$D(^PSRX(RX,0)) S RXY=^(0),RX2=^(2),RXSTA=^("STA") K SGY,OSGY + S (SIGM,PFM,PMIM,L2,L3,L4,L5,FILLCONT,BOTTLBL)=0 + K SIGF,PFF,PMIF S (SIGF,PFF,PMIF)=0 F I="DR","T" S (SIGF(I),PFF(I))=1 + F I="A","B","I" S PMIF(I)=1 + D NOW^%DTC S Y=$P(%,"."),PSOFNOW=% X ^DD("DD") S PSONOW=Y,Y=PSOFNOW X ^DD("DD") S PSONOWT=Y + S:$G(PSOBLALL) PSOBLRX=RX S:$D(RXRP(RX)) REPRINT=1 S:$D(RXPR(RX)) RXP=RXPR(RX) + I $G(PSOSUREP)!($G(PSOEXREP)) S REPRINT=1 I '$G(RXRP(RX)) S RXRP(RX)=1 + S A=$P(RXSTA,"^") I A>11 D AL^PSOLBL("QT") K RXP,REPRINT Q ;*244 + I A=3 D AL^PSOLBL("QT") K RXP,REPRINT Q + I $G(RXPR(RX)),'$D(^PSRX(RX,"P",RXP,0)) K RXP,REPRINT Q + I $P($G(RXFL(RX)),"^"),'$D(^PSRX(RX,1,$P($G(RXFL(RX)),"^"),0)) K RXP,REPRINT Q + I $G(PSODBQ)!($G(RXRS(RX))) S RR=$O(^PS(52.5,"B",RX,0)) Q:'RR I $G(^PS(52.5,RR,"P"))=1 K RXP,REPRINT Q + I $G(RXRS(RX))!($G(PSOPULL)) S PSOSXQ=0 N DR,DA,DIE D I $G(PSOSXQ) K RXP,REPRINT Q + . S DA=$O(^PS(52.5,"B",RX,0)) Q:'DA + . S A=$P($G(^PS(52.5,DA,0)),"^",7) I A="" Q + . I A="Q" S DIE="^PS(52.5,",DR="3////P" D ^DIE Q + . K RXRS(RX) S PSOSXQ=1 + I $G(PSRESOLV)=RX D ENLBL^PSOBSET K PSRESOLV + I $P(RXSTA,"^")'=4 D + . I $G(PSOSUSPR) D AREC^PSOSUTL + . I $G(PSOPULL)!($G(RXRS(RX))) D AREC1^PSOSUTL + . I $G(PSOSUREP) D AREC^PSOSUSRP + . I $G(PSXREP) D AREC^PSXSRP + S RXY=^PSRX(RX,0),RX2=^(2),RXSTA=^("STA") + K ^UTILITY("DIQ1",$J) S DA=$P($$SITE^VASITE(),"^") + I $G(DA) S DIC=4,DIQ(0)="I",DR="99" D EN^DIQ1 S PSOINST=$G(^UTILITY("DIQ1",$J,4,DA,99,"I")) K ^UTILITY("DIQ1",$J),DA,DR,DIC + S RXN=$P(RXY,"^"),DFN=+$P(RXY,"^",2),PSOLBLPS=+$P(RXY,"^",3),PSOLBLDR=+$P(RXY,"^",6) + S ISD=$P(RXY,"^",13),RXF=0,SIG=$P($G(^PSRX(RX,"SIG")),"^"),ISD=$E(ISD,4,5)_"/"_$E(ISD,6,7)_"/"_($E(ISD,1,3)+1700),ZY=0,$P(LINE,"_",28)="_" + S NURSE=$S($P($G(^DPT(DFN,"NHC")),"^")="Y":1,$P($G(^PS(55,DFN,40)),"^"):1,1:0) + S FDT=$P(RX2,"^",2),PS=$S($D(^PS(59,PSOSITE,0)):^(0),1:""),PS1=$S($D(^(1)):^(1),1:""),PSOSITE7=$P(^("IB"),"^") + S PS2=$P(PS,"^")_"^"_$P(PS,"^",6) + S EXPDT=$P(RX2,"^",6),EXDT=$S('EXPDT:"",1:$E(EXPDT,4,5)_"/"_$E(EXPDT,6,7)_"/"_($E(EXPDT,1,3)+1700)) + S COPIES=$S($P($G(RXRP(RX)),"^",2):$P($G(RXRP(RX)),"^",2),$P(RXY,"^",18)]"":$P(RXY,"^",18),1:1) + K PSOCKHNX S PSOCKHL=$L(RX),PSOCKHN=$E($G(PSOCKHN),(PSOCKHL+2),999) D K PSOCKHNX,PSOCKHL,PSOCKHA + .S PSOCKHA=","_RX_"," + .I PSOCKHN'[PSOCKHA Q + .S PSOCKHA=$E(PSOCKHA,1,($L(PSOCKHA)-1)) + .S PSOCKHNX=$L(PSOCKHN,PSOCKHA)-1 + .I +$G(PSOCKHNX)>0 D DOUB + I $O(^PSRX(RX,1,0)),$G(RXFL(RX))'=0 S $P(^PSRX(RX,3),"^",6)="" K ^PSRX(RX,"DAI"),^PSRX(RX,"DRI") + I '$G(RXP),'$O(^PSRX(RX,1,0)) S RXFL(RX)=0 + I '$G(RXP) D OSET I '$O(^PSRX(RX,1,0))!($G(RXFL(RX))=0) G ORIG + I $O(^PSRX(RX,1,0)),'$G(RXP) D G STA + . I '$G(RXFL(RX)) S XTYPE=1 D REF + I $G(RXP) S XTYPE="P" D REF G STA +ORIG S TECH=$P($G(^VA(200,+$P(RXY,"^",16),0)),"^"),PHYS=$S($D(^VA(200,+$P(RXY,"^",4),0)):$P(^(0),"^"),1:"UKN") + S DAYS=$P(RXY,"^",8),QTY=$P(RXY,"^",7) + D 6^VADPT,PID^VADPT6 S SSNPN=$G(VA("BID")) +STA S STATE=$S($D(^DIC(5,+$P(PS,"^",8),0)):$P(^(0),"^",2),1:"UKN") + S DRUG=$$ZZ^PSOSUTL(RX),DEA=$P($G(^PSDRUG(+$P(RXY,"^",6),0)),"^",3),WARN=$P($G(^(0)),"^",8) + S WARN=$$DRUG^PSSWRNA(+$P(RXY,"^",6),+$P(RXY,"^",2)) + S SIDE=$S($P($G(RXRP(RX)),"^",3):1,1:0) + I $G(^PSRX(RX,"P",+$G(RXP),0))]"" S RXPI=RXP D + .S RXP=^PSRX(RX,"P",RXP,0) + .S RXY=$P(RXP,"^")_"^"_$P(RXY,"^",2,6)_"^"_$P(RXP,"^",4)_"^"_$P(RXP,"^",10)_"^"_$P(RXY,"^",9)_"^"_$P($G(^PSRX(RX,"SIG")),"^",2)_"^"_$P(RXP,"^",2)_"^"_$P(RXY,"^",12,14)_"^"_$P(^PSRX(RX,"STA"),"^")_"^"_$P(RXP,"^",7)_"^"_$P(RXY,"^",17,99) + .S FDT=$P(RXP,"^") + S MW=$P(RXY,"^",11) I $G(RXFL(RX))'=0 D:$G(RXFL(RX)) I '$G(RXFL(RX)) F I=0:0 S I=$O(^PSRX(RX,1,I)) Q:'I S RXF=RXF+1 S:'$G(RXP) MW=$P(^PSRX(RX,1,I,0),"^",2) I +^PSRX(RX,1,I,0)'30) + .K PSMP(PSI) + ;New mail codes for CMOP + S MAILCOM="" + S X=$G(^PS(55,DFN,0)),PSCAP=$P(X,"^",2),PS55=$P(X,"^",3),PS55X=$P(X,"^",5) + I PS55X]"",PS55>1,PS55X
0,$P(^("STA"),"^")'=2,'$G(PSODBQ) D SNO G LBL + I $G(PSOLBLCP)="" D IBCP + N PSOQI S PSOQI=$G(^PSRX(RX,"IBQ")) + I $G(PSOLBLCP)=0 D SNO G LBL + I $G(PSOLBLCP)=1 I $P(PSOQI,"^",2)!($P(PSOQI,"^",3))!($P(PSOQI,"^",4))!($P(PSOQI,"^",5))!($P(PSOQI,"^",6))!($P(PSOQI,"^",7)) D SNO G LBL + I $G(PSOLBLCP)=2 I $P(PSOQI,"^")!($P(PSOQI,"^",2))!($P(PSOQI,"^",3))!($P(PSOQI,"^",4))!($P(PSOQI,"^",5))!($P(PSOQI,"^",6))!($P(PSOQI,"^",7)) D SNO G LBL + I $G(PSOLBLCP)=2,'$P($G(^PSRX(RX,"IB")),"^") D SNO G LBL + S PSOCPN=$P(RXY,"^",2),INRX=$P(RXY,"^") + I $G(^TMP($J,"PSOCP",PSOCPN))="" S ^(PSOCPN)=PSOCPN + S ^TMP($J,"PSOCP",PSOCPN,INRX)=INRX_"^"_$$ZZ^PSOSUTL(RX)_"^"_+$G(DAYS),COPAYVAR="COPAY" K ZDRUG +LBL I $G(PSOIO("LLI"))]"" X PSOIO("LLI") + I $P(RXSTA,"^")=4 D ^PSOLLL8 Q ;for a critical interaction entered by a tech - don't allow a label to be printed + I $D(^PSRX(RX,"DRI")),'$G(RXF),'$G(RXP) D ^PSOLLL8 + I $P($G(^PSRX(RX,3)),"^",6),'$G(RXF),'$G(RXP) D ^PSOLLL9 + S PSOINT=0 G ^PSOLLL1 +REF F XXX=0:0 S XXX=$O(^PSRX(RX,XTYPE,XXX)) Q:+XXX'>0 D + .S TECH=$S($D(^VA(200,+$P(^PSRX(RX,XTYPE,XXX,0),"^",7),0)):$P(^(0),"^"),1:"UNKNOWN") + .S QTY=$P(^PSRX(RX,XTYPE,XXX,0),"^",4),PHYS=$S($D(^VA(200,+$P(^PSRX(RX,XTYPE,XXX,0),"^",17),0)):$P(^(0),"^"),$D(^VA(200,+$P(^PSRX(RX,0),"^",4),0)):$P(^(0),"^"),1:"UNKNOWN") D 6^VADPT,PID^VADPT6 S SSNPN=$G(VA("BID")) + .S DAYS=$P(^PSRX(RX,XTYPE,XXX,0),"^",10) + Q +CHECK S PSDFNFLG=0,PSOZERO=$P(PPL,","),PSOPDFN=$P(^PSRX(PSOZERO,0),"^",2) + Q +OSET ; + N A + I $G(RXFL(RX))']""!($G(RXFL(RX))=0) D Q + .S A=^PSRX(RX,0) + .S TECH=$P($G(^VA(200,+$P(A,"^",16),0)),"^"),QTY=$P(A,"^",7),PHYS=$S($D(^VA(200,+$P(A,"^",4),0)):$P(^(0),"^"),1:"UKN") D 6^VADPT,PID^VADPT6 S SSNPN=$G(VA("BID")) + .S DAYS=$P(A,"^",8) + I '$D(^PSRX(RX,1,RXFL(RX),0)) K RXFL(RX) Q + S A=^PSRX(RX,1,RXFL(RX),0) + S TECH=$S($D(^VA(200,+$P(A,"^",7),0)):$P(^(0),"^"),1:"UNKNOWN") + S QTY=$P(A,"^",4),PHYS=$S($D(^VA(200,+$P(A,"^",17),0)):$P(^(0),"^"),$D(^VA(200,+$P(^PSRX(RX,0),"^",4),0)):$P(^(0),"^"),1:"UNKNOWN") D 6^VADPT,PID^VADPT6 S SSNPN=$G(VA("BID")) + S DAYS=$P(A,"^",10) + Q +DOUB ; + Q:'$D(RXFL(RX)) + I +$G(RXFL(RX))-PSOCKHNX<0 Q + S RXFLX(RX)=$G(RXFL(RX)) + S RXFL(RX)=$G(RXFL(RX))-PSOCKHNX + Q +IBCP ; + N X,Y,PSOJJ,PSOLL + S PSOLBLCP="" + S X=$P($G(^PS(59,+$G(PSOSITE),"IB")),"^")_"^"_$G(DFN) D XTYPE^IBARX + S PSOJJ="" F S PSOJJ=$O(Y(PSOJJ)) Q:'PSOJJ S PSOLL="" F S PSOLL=$O(Y(PSOJJ,PSOLL)) Q:PSOLL="" S:PSOLL>0 PSOLBLCP=PSOLL + I '$G(PSOLBLCP) S PSOLBLCP=0 + Q +SNO ; + S COPAYVAR="NO COPAY" + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLMAO.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLMAO.m index 5f8ea8b4..240c8f3b 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLMAO.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLMAO.m @@ -1,28 +1,27 @@ -PSOLMAO ;BHAM ISC/LC - ACTIVE ORDERS ;03/14/1995 - ;;7.0;OUTPATIENT PHARMACY;**225**;DEC 1997;Build 29 -EN ; -- main entry point for PSO LM ACTION ORDER - D EN^VALM("PSO LM ACTIVE ORDERS") - Q - ; -HDR ; -- header code - ;S VALMHDR(1)="This is a test header for PSO LM ACTION ORDER." - ;S VALMHDR(2)="This is the second line" - D HDR^PSOLMUTL - Q - ; -INIT ; -- init variables and list array - ;F LINE=1:1:30 D SET^VALM10(LINE,LINE_" Line number "_LINE) - S VALMCNT=PSOPF - D RV^PSOORFL - Q - ; -HELP ; -- help code - S X="?" D DISP^XQORM1 W !! - Q - ; -EXIT ; -- exit code - S PSOQFLG=1 Q - ; -EXPND ; -- expand code - Q - ; +PSOLMAO ;BHAM ISC/LC - ACTIVE ORDERS ; 14-MAR-1995 + ;;7.0;OUTPATIENT PHARMACY;;DEC 1997 +EN ; -- main entry point for PSO LM ACTION ORDER + D EN^VALM("PSO LM ACTIVE ORDERS") + Q + ; +HDR ; -- header code + ;S VALMHDR(1)="This is a test header for PSO LM ACTION ORDER." + ;S VALMHDR(2)="This is the second line" + D HDR^PSOLMUTL + Q + ; +INIT ; -- init variables and list array + ;F LINE=1:1:30 D SET^VALM10(LINE,LINE_" Line number "_LINE) + S VALMCNT=PSOPF + Q + ; +HELP ; -- help code + S X="?" D DISP^XQORM1 W !! + Q + ; +EXIT ; -- exit code + S PSOQFLG=1 Q + ; +EXPND ; -- expand code + Q + ; diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLMPO.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLMPO.m index bd025548..983c9b86 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLMPO.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLMPO.m @@ -1,27 +1,42 @@ -PSOLMPO ;ISC-BHAM/LC - pending orders ;03/13/95 - ;;7.0;OUTPATIENT PHARMACY;**46,225**;DEC 1997;Build 29 -EN ; -- main entry point for PSO LM PENDING ORDER - S PSOLMC=0 D EN^VALM("PSO LM PENDING ORDER") K PSOLMC - Q - ; -HDR ; -- header code - D HDR^PSOLMUTL - Q - ; -INIT ; -- init variables and list array - ;F LINE=1:1:30 D SET^VALM10(LINE,LINE_" Line number "_LINE) - S VALMCNT=IEN,VALM("TITLE")=$S($P(OR0,"^",23):"FL-",1:"")_"Pending OP Orders ("_$S($P(OR0,"^",14)="S":"STAT",$P(OR0,"^",14)="E":"EMERGENCY",1:"ROUTINE")_")" - D RV^PSONFI - Q - ; -HELP ; -- help code - S X="?" D DISP^XQORM1 W !! - Q - ; -EXIT ; -- exit code - K FLAGLINE D CLEAN^VALM10 - Q - ; -EXPND ; -- expand code - Q - ; +PSOLMPO ;ISC-BHAM/LC - pending orders ; 11/3/06 9:58pm + ;;7.0;OUTPATIENT PHARMACY;**46,208**;DEC 1997;Build 39 + ; 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 +EN ; -- main entry point for PSO LM PENDING ORDER + I $G(PSOAFYN)'="Y" S PSOLMC=0 D EN^VALM("PSO LM PENDING ORDER") K PSOLMCP ;vfam + I $G(PSOAFYN)="Y" D ACP^PSOORNEW ;vfam + Q + ; +HDR ; -- header code + D HDR^PSOLMUTL + Q + ; +INIT ; -- init variables and list array + ;F LINE=1:1:30 D SET^VALM10(LINE,LINE_" Line number "_LINE) + S VALMCNT=IEN,VALM("TITLE")="Pending OP Orders ("_$S($P(OR0,"^",14)="S":"STAT",$P(OR0,"^",14)="E":"EMERGENCY",1:"ROUTINE")_")" + D RV^PSONFI Q + ; +HELP ; -- help code + S X="?" D DISP^XQORM1 W !! + Q + ; +EXIT ; -- exit code + Q + ; +EXPND ; -- expand code + Q + ; diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLMPO1.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLMPO1.m index 0cdd80af..db89e5fc 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLMPO1.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLMPO1.m @@ -1,26 +1,25 @@ -PSOLMPO1 ;ISC-BHAM/SAB - complete pending orders ;03/13/1995 - ;;7.0;OUTPATIENT PHARMACY;**46,71,225**;DEC 1997;Build 29 -EN ; -- main entry point for PSO LM COMPLETE ORDER - D EN^VALM("PSO LM COMPLETE ORDER") - K PSOANSQD - Q - ; -HDR ; -- header code - D HDR^PSOLMUTL - Q - ; -INIT ; -- init variables and list array - S VALMCNT=IEN,VALM("TITLE")=$S($P(OR0,"^",23):"FL-",1:"")_"Pending OP Orders ("_$S($P($G(OR0),"^",14)="S":"STAT",$P($G(OR0),"^",14)="E":"EMERGENCY",1:"ROUTINE")_")" - D RV^PSONFI Q - ; -HELP ; -- help code - S X="?" D DISP^XQORM1 W !! - Q - ; -EXIT ; -- exit code - K FLAGLINE D CLEAN^VALM10 - Q - ; -EXPND ; -- expand code - Q - ; +PSOLMPO1 ;ISC-BHAM/SAB - complete pending orders ; 13-MAR-1995 + ;;7.0;OUTPATIENT PHARMACY;**46,71**;DEC 1997 +EN ; -- main entry point for PSO LM COMPLETE ORDER + D EN^VALM("PSO LM COMPLETE ORDER") + K PSOANSQD + Q + ; +HDR ; -- header code + D HDR^PSOLMUTL + Q + ; +INIT ; -- init variables and list array + S VALMCNT=IEN,VALM("TITLE")="Pending OP Orders ("_$S($P($G(OR0),"^",14)="S":"STAT",$P($G(OR0),"^",14)="E":"EMERGENCY",1:"ROUTINE")_")" + D RV^PSONFI Q + ; +HELP ; -- help code + S X="?" D DISP^XQORM1 W !! + Q + ; +EXIT ; -- exit code + Q + ; +EXPND ; -- expand code + Q + ; diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLMPO2.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLMPO2.m index 6d722d0a..7733765f 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLMPO2.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLMPO2.m @@ -1,28 +1,26 @@ -PSOLMPO2 ;ISC-BHAM/SAB - list template to complete backdoor orders ;03/13/1995 - ;;7.0;OUTPATIENT PHARMACY;**46,71,225**;DEC 1997;Build 29 -EN ; -- main entry point for PSO LM BACKDOOR ORDER - D EN^VALM("PSO LM BACKDOOR ORDER") - Q - ; -HDR ; -- header code - D HDR^PSOLMUTL - Q - ; -INIT ; -- init variables and list array - S VALMCNT=IEN,VALM("TITLE")="New OP Order ("_$S($G(COPY):"COPY",1:"ROUTINE")_")" - S VALMCNT=PSOPF - D RV^PSONFI Q - ; -HELP ; -- help code - S X="?" D DISP^XQORM1 W !! - Q - ; -EXIT ; -- exit code - K PSOANSQD - S PSOQFLG=1 - K FLAGLINE D CLEAN^VALM10 - Q - ; -EXPND ; -- expand code - Q - ; +PSOLMPO2 ;ISC-BHAM/SAB - list template to complete backdoor orders ; 13-MAR-1995 + ;;7.0;OUTPATIENT PHARMACY;**46,71**;DEC 1997 +EN ; -- main entry point for PSO LM BACKDOOR ORDER + D EN^VALM("PSO LM BACKDOOR ORDER") + Q + ; +HDR ; -- header code + D HDR^PSOLMUTL + Q + ; +INIT ; -- init variables and list array + S VALMCNT=IEN,VALM("TITLE")="New OP Order ("_$S($G(COPY):"COPY",1:"ROUTINE")_")" + S VALMCNT=PSOPF + D RV^PSONFI Q + ; +HELP ; -- help code + S X="?" D DISP^XQORM1 W !! + Q + ; +EXIT ; -- exit code + K PSOANSQD + S PSOQFLG=1 Q + ; +EXPND ; -- expand code + Q + ; diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLMRN.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLMRN.m index fc9d72c2..9f14122b 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLMRN.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLMRN.m @@ -1,29 +1,28 @@ -PSOLMRN ;ISC-BHAM/SAB - displays renewal rxs ;04/21/1995 - ;;7.0;OUTPATIENT PHARMACY;**11,46,84,225**;DEC 1997;Build 29 -EN ; -- main entry point for PSO LM RENEW LIST - S VALMCNT=PSOPF,PSOLM=1 - D EN^VALM("PSO LM RENEW LIST") - Q - ; -HDR ; -- header code - K ^TMP("PSOHDR",$J) D HDR^PSOLMUTL - Q - ; -INIT ; -- init variables and list array - ;F LINE=1:1:30 D SET^VALM10(LINE,LINE_" Line number "_LINE) - S VALMCNT=PSOPF,PSOLM=1 - D RV^PSONFI Q - ; -HELP ; -- help code - S X="?" D DISP^XQORM1 W !! - Q - ; -EXIT ; -- exit code - I $G(Y)=-1!($G(Y)="Q") S PSOQUIT=1 - I $G(Y)="Q",$P($G(Y(1)),"^",3)="QU" S PSOQQ=1 - K FLAGLINE D CLEAN^VALM10 - Q - ; -EXPND ; -- expand code - Q - ; +PSOLMRN ;ISC-BHAM/SAB - displays renewal rxs ; 21-APR-1995 + ;;7.0;OUTPATIENT PHARMACY;**11,46,84**;DEC 1997 +EN ; -- main entry point for PSO LM RENEW LIST + S VALMCNT=PSOPF,PSOLM=1 + D EN^VALM("PSO LM RENEW LIST") + Q + ; +HDR ; -- header code + K ^TMP("PSOHDR",$J) D HDR^PSOLMUTL + Q + ; +INIT ; -- init variables and list array + ;F LINE=1:1:30 D SET^VALM10(LINE,LINE_" Line number "_LINE) + S VALMCNT=PSOPF,PSOLM=1 + D RV^PSONFI Q + ; +HELP ; -- help code + S X="?" D DISP^XQORM1 W !! + Q + ; +EXIT ; -- exit code + I $G(Y)=-1!($G(Y)="Q") S PSOQUIT=1 + I $G(Y)="Q",$P($G(Y(1)),"^",3)="QU" S PSOQQ=1 + Q + ; +EXPND ; -- expand code + Q + ; diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLMUTL.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLMUTL.m index ca78b1b3..78b77bcc 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLMUTL.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLMUTL.m @@ -1,84 +1,83 @@ -PSOLMUTL ;BIR/SAB - listman utilities ;03/07/95 - ;;7.0;OUTPATIENT PHARMACY;**19,46,84,99,131,132,148,268,225**;DEC 1997;Build 29 - ;External reference FULL^VALM1 supported by dbia 10116 - ;External reference $$SETSTR^VALM1 supported by dbia 10116 - ;External reference EN2^GMRAPEMO supported by dbia 190 - ;External reference to ^ORD(101 supported by DBIA 872 - ; -EN W @IOF S VALMCNT=0 - D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) W $C(7),!!?5,"Site parameter must be defined!",! G INITQ - D EN^PSOLMPI -INITQ Q -HDR ;patient med profile display - K VALMHDR S HDR=^TMP("PSOHDR",$J,1,0) - S:^TMP("PSOHDR",$J,8,0) X=IORVON_""_IORVOFF,HDR=$$SETSTR^VALM1(X,HDR,80-$L(X),80) S VALMHDR(1)=HDR - I '(^TMP("PSOHDR",$J,8,0)) S PSONOAL="" D ALLERGY^PSOORUT2 I PSONOAL'="" D K PSONOAL - .S X=IORVON_""_IORVOFF,HDR=$$SETSTR^VALM1(X,HDR,80-$L(X),80) S VALMHDR(1)=HDR - S HDR=" PID: "_^TMP("PSOHDR",$J,2,0) - S VALMHDR(2)=$$SETSTR^VALM1("Ht(cm): "_^TMP("PSOHDR",$J,7,0),HDR,52,27) - S HDR=" DOB: "_^TMP("PSOHDR",$J,3,0)_" ("_^TMP("PSOHDR",$J,4,0)_")" - S VALMHDR(3)=$$SETSTR^VALM1(" Wt(kg): "_^TMP("PSOHDR",$J,6,0),HDR,51,28) - S HDR=" SEX: "_$E(^TMP("PSOHDR",$J,5,0),1,44) - S VALMHDR(4)=HDR - S $P(VALMHDR(4)," ",30)=" "_$E(^TMP("PSOHDR",$J,5,0),48,80) - Q:$G(PS)="VIEW"!($G(PS)="DELETE") - S VALMHDR(5)=$G(^TMP("PSOHDR",$J,9,0)) - S VALMHDR(6)=$G(^TMP("PSOHDR",$J,10,0)) - Q - ; -NEWALL(DFN) ; Enter Allergy info. - N PSOID D FULL^VALM1,EN2^GMRAPEM0,^PSOORUT2 S VALMBCK="R" - Q -NEWSEL ;allows order selection by number instead of action - S Y=$P(XQORNOD(0),"=",2) N VALMCNT D NEWSEL^PSOORNE2 - Q -EDTSEL ;allows edit selection by number instead of action - active orders - N VALMCNT S Y=$P(XQORNOD(0),"=",2) D EDTSEL^PSOOREDT - Q -SELAL ;selection of allergy by number instead of action - select allergy - N VALMCNT S Y=$P(XQORNOD(0),"=",2) D SELAL^PSOORDA - Q -EDTNEW ;allows edit selection by number instead of action - new orders - N VALMCNT S Y=$P(XQORNOD(0),"=",2) D EDTSEL^PSOORNE1 - Q -EDTRNEW ;allows edit selection by number instead of action - renew orders - N VALMCNT S Y=$P(XQORNOD(0),"=",2) D EDTSEL^PSOORNE4 - Q -EDTPEN ;allows edit selection by number instead of action - pending orders - N VALMCNT S Y=$P(XQORNOD(0),"=",2),SEDT=1 G EDTSEL^PSOORNEW - Q -HLDHDR ;keeps patient's header info - S IOTM=VALM("TM"),IOBM=IOSL W IOSC W @IOSTBM W IORC - Q - ; -BYPASS S:$G(PSOFDR) SIGOK=1 S Y=-1,VALMBCK="Q" - Q -ACTIONS() ;screen actions on active orders - Q:$G(PKI1)=2 0 - N DIC,X,Y K DIC,Y S DIC="^ORD(101,"_DA(1)_",10,",X=DA,DIC(0)="ZN" D ^DIC Q:Y<0 0 - S Y=Y(0,0) - I Y="PSO REFILL" Q $S(PSOACT["R":1,1:0) - I Y="PSO RENEW" Q $S(PSOACT["N":1,1:0) - I Y="PSO REPRINT" Q $S(PSOACT["P":1,1:0) - I Y="PSO EDIT ORDERS" Q $S(PSOACT["E":1,1:0) - I Y="PSO RELEASE" Q $S(PSOACT["L":1,1:0) - I Y="PSO PARTIAL" Q $S(PSOACT["T":1,1:0) - I Y="PSO CANCEL" Q $S(PSOACT["D":1,1:0) - I Y="PSO HOLD" Q $S(PSOACT["H":1,1:0) - I Y="PSO UNHOLD" Q $S(PSOACT["U":1,1:0) - I Y="PSO LM BACKDOOR COPY" Q $S(PSOACT["C":1,1:0) - I Y="PSO VERIFY" Q $S(PSOACT["V":1,1:0) - I Y="PSO ACTIVITY LOGS" Q 1 - Q 1 -ACTIONS1() ;screen actions on pending orders - Q:$G(PKI1)=2 0 - N DIC,X,Y K DIC,Y S DIC="^ORD(101,"_DA(1)_",10,",X=DA,DIC(0)="ZN" D ^DIC Q:Y<0 0 - S Y=Y(0,0) - I Y="PSO LM DISCONTINUE" Q $S(PSOACT["D":1,1:0) - I Y="PSO LM EDIT" Q $S(PSOACT["E":1,1:0) - I Y="PSO LM FINISH" Q $S(PSOACT["F":1,1:0) - I Y="PSO LM FLAG" Q $S(PSOACT["X":1,1:0) - Q 1 -PKIACT() ;screen actions on pending orders DEA/PKI proj. - Q:$G(PKI1)=2 0 - Q 1 +PSOLMUTL ;BIR/SAB - listman utilities ;03/07/95 + ;;7.0;OUTPATIENT PHARMACY;**19,46,84,99,131,132,148,268**;DEC 1997;Build 9 + ;External reference FULL^VALM1 supported by dbia 10116 + ;External reference $$SETSTR^VALM1 supported by dbia 10116 + ;External reference EN2^GMRAPEMO supported by dbia 190 + ;External reference to ^ORD(101 supported by DBIA 872 + ; +EN W @IOF S VALMCNT=0 + D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) W $C(7),!!?5,"Site parameter must be defined!",! G INITQ + D EN^PSOLMPI +INITQ Q +HDR ;patient med profile display + K VALMHDR S HDR=^TMP("PSOHDR",$J,1,0) + S:^TMP("PSOHDR",$J,8,0) X=IORVON_""_IORVOFF,HDR=$$SETSTR^VALM1(X,HDR,80-$L(X),80) S VALMHDR(1)=HDR + I '(^TMP("PSOHDR",$J,8,0)) S PSONOAL="" D ALLERGY^PSOORUT2 I PSONOAL'="" D K PSONOAL + .S X=IORVON_""_IORVOFF,HDR=$$SETSTR^VALM1(X,HDR,80-$L(X),80) S VALMHDR(1)=HDR + S HDR=" PID: "_^TMP("PSOHDR",$J,2,0) + S VALMHDR(2)=$$SETSTR^VALM1("Ht(cm): "_^TMP("PSOHDR",$J,7,0),HDR,52,27) + S HDR=" DOB: "_^TMP("PSOHDR",$J,3,0)_" ("_^TMP("PSOHDR",$J,4,0)_")" + S VALMHDR(3)=$$SETSTR^VALM1(" Wt(kg): "_^TMP("PSOHDR",$J,6,0),HDR,51,28) + S HDR=" SEX: "_$E(^TMP("PSOHDR",$J,5,0),1,44) + S VALMHDR(4)=HDR + S $P(VALMHDR(4)," ",30)=" "_$E(^TMP("PSOHDR",$J,5,0),48,80) + Q:$G(PS)="VIEW"!($G(PS)="DELETE") + S VALMHDR(5)=$G(^TMP("PSOHDR",$J,9,0)) + S VALMHDR(6)=$G(^TMP("PSOHDR",$J,10,0)) + Q + ; +NEWALL(DFN) ; Enter Allergy info. + N PSOID D FULL^VALM1,EN2^GMRAPEM0,^PSOORUT2 S VALMBCK="R" + Q +NEWSEL ;allows order selection by number instead of action + S Y=$P(XQORNOD(0),"=",2) N VALMCNT D NEWSEL^PSOORNE2 + Q +EDTSEL ;allows edit selection by number instead of action - active orders + N VALMCNT S Y=$P(XQORNOD(0),"=",2) D EDTSEL^PSOOREDT + Q +SELAL ;selection of allergy by number instead of action - select allergy + N VALMCNT S Y=$P(XQORNOD(0),"=",2) D SELAL^PSOORDA + Q +EDTNEW ;allows edit selection by number instead of action - new orders + N VALMCNT S Y=$P(XQORNOD(0),"=",2) D EDTSEL^PSOORNE1 + Q +EDTRNEW ;allows edit selection by number instead of action - renew orders + N VALMCNT S Y=$P(XQORNOD(0),"=",2) D EDTSEL^PSOORNE4 + Q +EDTPEN ;allows edit selection by number instead of action - pending orders + N VALMCNT S Y=$P(XQORNOD(0),"=",2),SEDT=1 G EDTSEL^PSOORNEW + Q +HLDHDR ;keeps patient's header info + S IOTM=VALM("TM"),IOBM=IOSL W IOSC W @IOSTBM W IORC + Q + ; +BYPASS S:$G(PSOFDR) SIGOK=1 S Y=-1,VALMBCK="Q" + Q +ACTIONS() ;screen actions on active orders + Q:$G(PKI1)=2 0 + N DIC,X,Y K DIC,Y S DIC="^ORD(101,"_DA(1)_",10,",X=DA,DIC(0)="ZN" D ^DIC Q:Y<0 0 + S Y=Y(0,0) + I Y="PSO REFILL" Q $S(PSOACT["R":1,1:0) + I Y="PSO RENEW" Q $S(PSOACT["N":1,1:0) + I Y="PSO REPRINT" Q $S(PSOACT["P":1,1:0) + I Y="PSO EDIT ORDERS" Q $S(PSOACT["E":1,1:0) + I Y="PSO RELEASE" Q $S(PSOACT["L":1,1:0) + I Y="PSO PARTIAL" Q $S(PSOACT["T":1,1:0) + I Y="PSO CANCEL" Q $S(PSOACT["D":1,1:0) + I Y="PSO HOLD" Q $S(PSOACT["H":1,1:0) + I Y="PSO UNHOLD" Q $S(PSOACT["U":1,1:0) + I Y="PSO LM BACKDOOR COPY" Q $S(PSOACT["C":1,1:0) + I Y="PSO VERIFY" Q $S(PSOACT["V":1,1:0) + I Y="PSO ACTIVITY LOGS" Q 1 + Q 1 +ACTIONS1() ;screen actions on pending orders + Q:$G(PKI1)=2 0 + N DIC,X,Y K DIC,Y S DIC="^ORD(101,"_DA(1)_",10,",X=DA,DIC(0)="ZN" D ^DIC Q:Y<0 0 + S Y=Y(0,0) + I Y="PSO LM DISCONTINUE" Q $S(PSOACT["D":1,1:0) + I Y="PSO LM EDIT" Q $S(PSOACT["E":1,1:0) + I Y="PSO LM FINISH" Q $S(PSOACT["F":1,1:0) + Q 1 +PKIACT() ;screen actions on pending orders DEA/PKI proj. + Q:$G(PKI1)=2 0 + Q 1 diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLSET.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLSET.m index 52d9882d..40be9cc3 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLSET.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLSET.m @@ -1,106 +1,106 @@ -PSOLSET ;BHAM ISC/SAB - site parameter set up ;3/13/07 19:50 -VERS ;;7.0;OUTPATIENT PHARMACY;**10,22,32,40,120,247,208**;DEC 1997;Build 41 - ; 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 - ;Reference to ^PS(59.7 supported by DBIA 694 - ;Reference to ^PSX(550 supported by DBIA 2230 - ;Reference to ^%ZIS(2 supported by DBIA 3435 - ; - I '$D(DUZ) W !,$C(7),"DUZ Number must be defined !!",! G LEAVE - W !,"Outpatient Pharmacy software - Version "_$P($T(VERS),";",3) - I $D(^XTMP("PSO_V7 INSTALL",0)) W !!,"Outpatient Pharmacy software is being installed. PLEASE TRY LATER!",! G LEAVE - S PSOBAR1="",PSOBARS=0 ;make sure we have one - S PSOCNT=0 F I=0:0 S I=$O(^PS(59,I)) Q:'I S PSOCNT=PSOCNT+1,Y=I - G DIV1:PSOCNT W !,$C(7) S DIR("A",1)="Site parameters must be specified for at least one site." - S DIR("A",2)="This is usually done by the package Co-ordinator.",DIR("A")="Do you want to continue: ",DIR("B")="YES",DIR(0)="SA^Y:YES;N:NO",DIR("?")="Enter Y to edit site parameters or N to exit." D ^DIR - G LEAVE:"Y"'[$E(X) - W ! D ^PSOSITED G PSOLSET -DIV1 G:PSOCNT=1 DIV3 S DIR(0)="Y",DIR("?")="Enter 'Y' to select Division or 'N' to EXIT" -DIV2 I PSOCNT>1 W ! S DIC("A")="Division: ",DIC=59,DIC(0)="AEMQ" - S:$G(PSOVEX)'=1 DIC("S")="I $S('$D(^PS(59,+Y,""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:0)" - D ^DIC K DIC G:$D(DUOUT)!($D(DTOUT)) LEAVE - I +Y<0 W $C(7),! S DIR("A",1)="A 'DIVISION' must be selected!",DIR("A")="Do you want to try again",DIR("B")="YES" D ^DIR G:'Y LEAVE G DIV2 -DIV3 K DIR S PSOSITE=+Y W:PSOCNT>1 !!?10,"You are logged on under the ",$P(^PS(59,PSOSITE,0),"^")," division.",! S PSOPAR=$G(^PS(59,PSOSITE,1)),PSOPAR7=$G(^PS(59,PSOSITE,"IB")),PSOSYS=$G(^PS(59.7,1,40.1)) D CUTDATE^PSOFUNC - S PSOPINST=$P($G(^PS(59,PSOSITE,"INI")),"^") - S (SITE,DA)=$P(^XMB(1,1,"XUS"),"^",17),DIC="4",DIQ(0)="IE",DR=".01;99",DIQ="PSXUTIL" D EN^DIQ1 S S3=$G(PSXUTIL(4,SITE,99,"I")),S2=$G(PSXUTIL(4,SITE,.01,"E")) K DA,DIC,DIQ(0),DR - S PSXSYS=+$O(^PSX(550,"C",""))_"^"_$G(S3)_"^"_$G(S2),PSOINST=S3 - K S3,S2,S1,PSXUTIL - I $G(PSXSYS) D - .K:($P($G(^PSX(550,+PSXSYS,0)),"^",2)'="A") PSXSYS - .S Y=$$VERSION^XPDUTL("PSO") I Y>6.0 S PSXVER=1 - E K PSXSYS - S PSODIV=$S(($P(PSOSYS,"^",2))&('$P(PSOSYS,"^",3)):0,1:1) - I $D(DUZ),$D(^VA(200,+DUZ,0)) S PSOCLC=DUZ -PLBL I $P(PSOPAR,"^",8) D - .S %ZIS="MNQ",%ZIS("A")="Select PROFILE PRINTER: " S:$G(PSOCLBL)&($D(PSOPROP)) %ZIS("B")=PSOPROP - .D ^%ZIS K %ZIS,IO("Q"),IOP Q:POP S PSOPROP=ION D ^%ZISC - S PSOAFIN=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",1) ;vfah - S PSOAFPFX=$S(PSOAFIN="Y":"Select LABEL PRINTER or FAX DEVICE: ",1:"Select LABEL PRINT: ") ;vfah -LBL S %ZIS="MNQ",%ZIS("A")=PSOAFPFX S:$G(PSOCLBL)&($D(PSOLAP))!($G(SUSPT)) %ZIS("B")=$S($G(SUSPT):PSLION,1:PSOLAP) ;vfah - D ^%ZIS K %ZIS,IO("Q"),IOP S:POP PSOQUIT=1 G:POP EXIT S @$S($G(SUSPT):"PSLION",1:"PSOLAP")=ION,PSOPIOST=$G(IOST(0)) - N PSOIOS S PSOIOS=IOS D DEVBAR^PSOBMST - S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$P(PSOPAR,"^",19),PSOIOS=IOS D ^%ZISC -LASK I $G(PSOPIOST),$D(^%ZIS(2,PSOPIOST,55,"B","LL")) G EXIT - ; - ;vfah AutoFinish fax additions begin here - K PSOAFFXP,PSOAFFXL - I PSOLAP["FAX" D - .S PSOAFFXP="",PSOAFFXL="",PSOAFFXR="" - .S PSOLAP="AFFAX" D - ..S PSOION="" S PSOION=$O(^%ZIS(1,"B",PSOLAP,PSOION)) - ..I $D(^DIZ(22900)) D - ...S DIC="^DIZ(22900,",DIC(0)="AEQMZ",DIC("A")="SEND FAX TO: " - ...D ^DIC K DIC - ...I Y=-1 W !,"Invalid selection" G LBL - ...S PSOAFFXL=$P(Y,"^",2) - ...S PSOAFFXP=$P($G(^DIZ(22900,+Y,3)),"^",3) - ...S PSOAFFXR=PSOAFFXP - ...I PSOAFFXL=""!(PSOAFFXP="") G LBL - I $G(PSOAFFXP)&(PSOLAP="AFFAX")'="" G EXIT - ;vfah Autofinish fax additions end here - ; - K DIR S DIR("A")="OK to assume label alignment is correct",DIR("B")="YES",DIR(0)="Y",DIR("?")="Enter Y if labels are aligned, N if they need to be aligned." D ^DIR S:$D(DIRUT) PSOQUIT=1 G:Y!($D(DIRUT)) EXIT -P2 S IOP=$G(PSOLAP) D ^%ZIS K IOP I POP W $C(7),!?5,"Printer is busy.",! G LASK - U IO(0) W !,"Align labels so that a perforation is at the top of the",!,"print head and the left side is at column zero." - W ! K DIR,DIRUT,DUOUT,DTOUT S DIR(0)="E" D ^DIR K DIR,DTOUT,DUOUT Q:$D(DIRUT) D ^PSOLBLT D ^%ZISC - K DIRUT,DIR S DIR("A")="Is this correct",DIR("B")="YES",DIR(0)="Y",DIR("?")="Enter Y if labels are aligned correctly, N if they need to be aligned." D ^DIR S:$D(DIRUT) PSOQUIT=1 G:Y!($D(DIRUT)) EXIT - G P2 -LEAVE S XQUIT="" G FINAL -Q W !?10,$C(7),"Default printer for labels must be entered." G LBL - ; -EXIT D ^%ZISC Q:$G(PSOCLBL) - D:'$G(PSOBFLAG) GROUP K I,IOP,X,Y,%ZIS,DIC,J,DIR,X,Y,DTOUT,DIROUT,DIRUT,DUOUT Q - ; -FINAL ;exit action from main menu - kill and quit - K SITE,PSOCP,PSNP,PSL,PRCA,PSLION,PSOPINST - K GROUPCNT,DISGROUP,PSOCAP,PSOINST,PSOION,PSONULBL,PSOSITE7,PFIO,PSOIOS,X,Y,PSOSYS,PSODIV,PSOPAR,PSOPAR7,PSOLAP,PSOPROP,PSOCLC,PSOCNT - K PSODTCUT,PSOSITE,PSOPRPAS,PSOBAR1,PSOBAR0,PSOBARS,SIG,DIR,DIRUT,DTOUT,DIROUT,DUOUT,I,%ZIS,DIC,J,PSOREL - Q -GROUP ;display group - S GROUPCNT=0,AGROUP="" I $D(^PS(59.3,0)) F S AGROUP=$O(^PS(59.3,"B",AGROUP)) Q:AGROUP="" D - .S GROUPCNT=GROUPCNT+1 I GROUPCNT=1 S AGROUP1=AGROUP - S:GROUPCNT=1 GRPNME=AGROUP1,II="" G:GROUPCNT>1 GROUP1 - Q:'$D(GRPNME) F S II=$O(^PS(59.3,"B",GRPNME,II)) Q:II="" S DISGROUP=II - K AGROUP,AGROUP1,GRPNME,II - Q -GROUP1 W ! S DIC("A")="Bingo Board Display: ",DIC=59.3,DIC(0)="AEMQZ",DIR(0)="Y",DIR("?")="Enter 'Y' to select Bingo Board Display or 'N' to EXIT" - S:$P($G(^PS(59,PSOSITE,1)),"^",20) DIC("B")=$P($G(^PS(59,PSOSITE,1)),"^",20) - D ^DIC K DIC Q:$D(DTOUT)!($D(DUOUT)) - I +Y<0 W $C(7) S DIR("A",1)="A 'BINGO BOARD DISPLAY' should be selected!",DIR("A")="Do you want to try again",DIR("B")="YES",DIR("?")="A display group must be defined in order to run Bingo Board." D ^DIR Q:"Y"'[$E(X) G GROUP - S DISGROUP=+Y - K DIR,DIC,AGROUP,AGROUP1,GRPNME,II - Q +PSOLSET ;BHAM ISC/SAB - site parameter set up ;3/13/07 19:50 +VERS ;;7.0;OUTPATIENT PHARMACY;**10,22,32,40,120,247,208**;DEC 1997;Build 39 + ; 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 + ;Reference to ^PS(59.7 supported by DBIA 694 + ;Reference to ^PSX(550 supported by DBIA 2230 + ;Reference to ^%ZIS(2 supported by DBIA 3435 + ; + I '$D(DUZ) W !,$C(7),"DUZ Number must be defined !!",! G LEAVE + W !,"Outpatient Pharmacy software - Version "_$P($T(VERS),";",3) + I $D(^XTMP("PSO_V7 INSTALL",0)) W !!,"Outpatient Pharmacy software is being installed. PLEASE TRY LATER!",! G LEAVE + S PSOBAR1="",PSOBARS=0 ;make sure we have one + S PSOCNT=0 F I=0:0 S I=$O(^PS(59,I)) Q:'I S PSOCNT=PSOCNT+1,Y=I + G DIV1:PSOCNT W !,$C(7) S DIR("A",1)="Site parameters must be specified for at least one site." + S DIR("A",2)="This is usually done by the package Co-ordinator.",DIR("A")="Do you want to continue: ",DIR("B")="YES",DIR(0)="SA^Y:YES;N:NO",DIR("?")="Enter Y to edit site parameters or N to exit." D ^DIR + G LEAVE:"Y"'[$E(X) + W ! D ^PSOSITED G PSOLSET +DIV1 G:PSOCNT=1 DIV3 S DIR(0)="Y",DIR("?")="Enter 'Y' to select Division or 'N' to EXIT" +DIV2 I PSOCNT>1 W ! S DIC("A")="Division: ",DIC=59,DIC(0)="AEMQ" + S:$G(PSOVEX)'=1 DIC("S")="I $S('$D(^PS(59,+Y,""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:0)" + D ^DIC K DIC G:$D(DUOUT)!($D(DTOUT)) LEAVE + I +Y<0 W $C(7),! S DIR("A",1)="A 'DIVISION' must be selected!",DIR("A")="Do you want to try again",DIR("B")="YES" D ^DIR G:'Y LEAVE G DIV2 +DIV3 K DIR S PSOSITE=+Y W:PSOCNT>1 !!?10,"You are logged on under the ",$P(^PS(59,PSOSITE,0),"^")," division.",! S PSOPAR=$G(^PS(59,PSOSITE,1)),PSOPAR7=$G(^PS(59,PSOSITE,"IB")),PSOSYS=$G(^PS(59.7,1,40.1)) D CUTDATE^PSOFUNC + S PSOPINST=$P($G(^PS(59,PSOSITE,"INI")),"^") + S (SITE,DA)=$P(^XMB(1,1,"XUS"),"^",17),DIC="4",DIQ(0)="IE",DR=".01;99",DIQ="PSXUTIL" D EN^DIQ1 S S3=$G(PSXUTIL(4,SITE,99,"I")),S2=$G(PSXUTIL(4,SITE,.01,"E")) K DA,DIC,DIQ(0),DR + S PSXSYS=+$O(^PSX(550,"C",""))_"^"_$G(S3)_"^"_$G(S2),PSOINST=S3 + K S3,S2,S1,PSXUTIL + I $G(PSXSYS) D + .K:($P($G(^PSX(550,+PSXSYS,0)),"^",2)'="A") PSXSYS + .S Y=$$VERSION^XPDUTL("PSO") I Y>6.0 S PSXVER=1 + E K PSXSYS + S PSODIV=$S(($P(PSOSYS,"^",2))&('$P(PSOSYS,"^",3)):0,1:1) + I $D(DUZ),$D(^VA(200,+DUZ,0)) S PSOCLC=DUZ +PLBL I $P(PSOPAR,"^",8) D + .S %ZIS="MNQ",%ZIS("A")="Select PROFILE PRINTER: " S:$G(PSOCLBL)&($D(PSOPROP)) %ZIS("B")=PSOPROP + .D ^%ZIS K %ZIS,IO("Q"),IOP Q:POP S PSOPROP=ION D ^%ZISC + S PSOAFIN=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",1) ;vfah + S PSOAFPFX=$S(PSOAFIN="Y":"Select LABEL PRINTER or FAX DEVICE: ",1:"Select LABEL PRINT: ") ;vfah +LBL S %ZIS="MNQ",%ZIS("A")=PSOAFPFX S:$G(PSOCLBL)&($D(PSOLAP))!($G(SUSPT)) %ZIS("B")=$S($G(SUSPT):PSLION,1:PSOLAP) ;vfah + D ^%ZIS K %ZIS,IO("Q"),IOP S:POP PSOQUIT=1 G:POP EXIT S @$S($G(SUSPT):"PSLION",1:"PSOLAP")=ION,PSOPIOST=$G(IOST(0)) + N PSOIOS S PSOIOS=IOS D DEVBAR^PSOBMST + S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$P(PSOPAR,"^",19),PSOIOS=IOS D ^%ZISC +LASK I $G(PSOPIOST),$D(^%ZIS(2,PSOPIOST,55,"B","LL")) G EXIT + ; + ;vfah AutoFinish fax additions begin here + K PSOAFFXP,PSOAFFXL + I PSOLAP["FAX" D + .S PSOAFFXP="",PSOAFFXL="",PSOAFFXR="" + .S PSOLAP="AFFAX" D + ..S PSOION="" S PSOION=$O(^%ZIS(1,"B",PSOLAP,PSOION)) + ..I $D(^DIZ(22900)) D + ...S DIC="^DIZ(22900,",DIC(0)="AEQMZ",DIC("A")="SEND FAX TO: " + ...D ^DIC K DIC + ...I Y=-1 W !,"Invalid selection" G LBL + ...S PSOAFFXL=$P(Y,"^",2) + ...S PSOAFFXP=$P($G(^DIZ(22900,+Y,3)),"^",3) + ...S PSOAFFXR=PSOAFFXP + ...I PSOAFFXL=""!(PSOAFFXP="") G LBL + I $G(PSOAFFXP)&(PSOLAP="AFFAX")'="" G EXIT + ;vfah Autofinish fax additions end here + ; + K DIR S DIR("A")="OK to assume label alignment is correct",DIR("B")="YES",DIR(0)="Y",DIR("?")="Enter Y if labels are aligned, N if they need to be aligned." D ^DIR S:$D(DIRUT) PSOQUIT=1 G:Y!($D(DIRUT)) EXIT +P2 S IOP=$G(PSOLAP) D ^%ZIS K IOP I POP W $C(7),!?5,"Printer is busy.",! G LASK + U IO(0) W !,"Align labels so that a perforation is at the top of the",!,"print head and the left side is at column zero." + W ! K DIR,DIRUT,DUOUT,DTOUT S DIR(0)="E" D ^DIR K DIR,DTOUT,DUOUT Q:$D(DIRUT) D ^PSOLBLT D ^%ZISC + K DIRUT,DIR S DIR("A")="Is this correct",DIR("B")="YES",DIR(0)="Y",DIR("?")="Enter Y if labels are aligned correctly, N if they need to be aligned." D ^DIR S:$D(DIRUT) PSOQUIT=1 G:Y!($D(DIRUT)) EXIT + G P2 +LEAVE S XQUIT="" G FINAL +Q W !?10,$C(7),"Default printer for labels must be entered." G LBL + ; +EXIT D ^%ZISC Q:$G(PSOCLBL) + D:'$G(PSOBFLAG) GROUP K I,IOP,X,Y,%ZIS,DIC,J,DIR,X,Y,DTOUT,DIROUT,DIRUT,DUOUT Q + ; +FINAL ;exit action from main menu - kill and quit + K SITE,PSOCP,PSNP,PSL,PRCA,PSLION,PSOPINST + K GROUPCNT,DISGROUP,PSOCAP,PSOINST,PSOION,PSONULBL,PSOSITE7,PFIO,PSOIOS,X,Y,PSOSYS,PSODIV,PSOPAR,PSOPAR7,PSOLAP,PSOPROP,PSOCLC,PSOCNT + K PSODTCUT,PSOSITE,PSOPRPAS,PSOBAR1,PSOBAR0,PSOBARS,SIG,DIR,DIRUT,DTOUT,DIROUT,DUOUT,I,%ZIS,DIC,J,PSOREL + Q +GROUP ;display group + S GROUPCNT=0,AGROUP="" I $D(^PS(59.3,0)) F S AGROUP=$O(^PS(59.3,"B",AGROUP)) Q:AGROUP="" D + .S GROUPCNT=GROUPCNT+1 I GROUPCNT=1 S AGROUP1=AGROUP + S:GROUPCNT=1 GRPNME=AGROUP1,II="" G:GROUPCNT>1 GROUP1 + Q:'$D(GRPNME) F S II=$O(^PS(59.3,"B",GRPNME,II)) Q:II="" S DISGROUP=II + K AGROUP,AGROUP1,GRPNME,II + Q +GROUP1 W ! S DIC("A")="Bingo Board Display: ",DIC=59.3,DIC(0)="AEMQZ",DIR(0)="Y",DIR("?")="Enter 'Y' to select Bingo Board Display or 'N' to EXIT" + S:$P($G(^PS(59,PSOSITE,1)),"^",20) DIC("B")=$P($G(^PS(59,PSOSITE,1)),"^",20) + D ^DIC K DIC Q:$D(DTOUT)!($D(DUOUT)) + I +Y<0 W $C(7) S DIR("A",1)="A 'BINGO BOARD DISPLAY' should be selected!",DIR("A")="Do you want to try again",DIR("B")="YES",DIR("?")="A display group must be defined in order to run Bingo Board." D ^DIR Q:"Y"'[$E(X) G GROUP + S DISGROUP=+Y + K DIR,DIC,AGROUP,AGROUP1,GRPNME,II + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOMAUEX.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOMAUEX.m index c8ad106b..4ee77545 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOMAUEX.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOMAUEX.m @@ -1,106 +1,84 @@ -PSOMAUEX ;BIR/SAB-Auto expire of prescriptions ; 10/10/07 11:17am - ;;7.0;OUTPATIENT PHARMACY;**40,73,139,148,257**;DEC 1997;Build 19 - ;; - ;External reference to STATUS^ORQOR2 is supported by DBIA 3458 - ;External reference to ^PS(59.7 is supported by DBIA 694 - ;External reference to LOCK1^ORX2 and UNLK1^ORX2 are supported by DBIA 867 - ; - I '$G(DT) S DT=$$DT^XLFDT - W @IOF,!!?10," ******* Auto Expire of Prescriptions *******" - W !!,"You need to run this job only if expired prescriptions are showing up as active" - W !,"orders on the Orders tab in CPRS. This could be due to the following:" - W !,"1. The Expire Prescriptions [PSO EXPIRE PRESCRIPTIONS] option was not" - W !," queued as a daily task. ***** AND *****" - W !,"2. Those patient's prescription(s) were never being accessed/viewed in" - W !," Patient Prescription Processing [PSO LM BACKDOOR ORDERS] option.",! - W !,"*******************************************************************************" - W !,"* For sites that have not queued the Expire Prescriptions job on their *" - W !,"* daily task schedule, you should do so by selecting the Queue Background *" - W !,"* Jobs [PSO AUTOQUEUE JOBS] option from the Maintenance (Outpatient Pharmacy) *" - W !,"* [PSO MAINTENANCE] option and in the Edit Option Schedule template make an *" - W !,"* entry for Expire Prescriptions [PSO EXPIRE PRESCRIPTIONS] option and *" - W !,"* schedule it to run daily. *" - W !,"*******************************************************************************" - W !! - S ZZDT=$S($P($G(^PS(59.7,1,49.99)),"^",7):$P(^PS(59.7,1,49.99),"^",7),1:$P($G(^PS(59.7,1,49.99)),"^",4)) - I 'ZZDT D Q ; V7.0 inst. dt not found, quit this job - .W !!!,"***** Outpatient installation date was not found, *****" - .W !,"***** therefore this job cannot be run!!!!! *****",!! - ; - ; - Ask for START DATE - K %DT S %DT(0)=-DT,%DT="AEP",%DT("A")="Start Date: " - S %DT("B")=$$FMTE^XLFDT($$FMADD^XLFDT(ZZDT\1,-121)) - W ! D ^%DT I Y<0!($D(DTOUT)) Q - S ZZDT=Y - ; - K %DT D NOW^%DTC S %DT="RAEX",%DT(0)=%,%DT("A")="Select the Date/Time to queue this job: " - W ! D ^%DT K %DT I $D(DTOUT)!(Y<0) W !!!?10,"Job not queued!" Q - S ZTDTH=$G(Y),ZTSAVE("ZZDT")="",ZTIO="",ZTRTN="EN^PSOMAUEX",ZTDESC="Auto expire of Rxs " - D ^%ZTLOAD - W:$D(ZTSK) !!,"Task Queued !",! - Q -EN ; - N PSOSVDT - S PSOSVDT="" - S X1=DT,X2=-1 D C^%DTC S CDT=X ; setting the end date to to today-1 - F S ZZDT=$O(^PSRX("AG",ZZDT)) Q:'ZZDT!(ZZDT>CDT) D EN1 S PSOSVDT=ZZDT - I PSOSVDT>($P(^PS(59.7,1,49.99),"^",8)) D - .S DIE=59.7,DA=1,DR="49.95///"_PSOSVDT D ^DIE K DIE,DA,DR - K PSOEXRX,PSOEXSTA,ZZDT,CDT,ORN,PIFN,PSUSD,PRFDT,PDA,PSDTEST S:$D(ZTQUEUED) ZTREQ="@" - Q -EN1 ; - F PSOEXRX=0:0 S PSOEXRX=$O(^PSRX("AG",ZZDT,PSOEXRX)) Q:'PSOEXRX D - .Q:$P($G(^PSRX(PSOEXRX,2)),"^",6)'=ZZDT - .I $D(^PSRX(PSOEXRX,0)) D EN2 - Q -EN2 ; - N CPRSDC,CPRSSTA - S CPRSDC=",1,7,12,13," - S ORN=$P($G(^PSRX(PSOEXRX,"OR1")),"^",2),CPRSSTA="" - I ORN S CPRSSTA=+$$STATUS^ORQOR2(ORN) - S DA=PSOEXRX K CMOP D ^PSOCMOPA - S DA=$O(^PS(52.5,"B",PSOEXRX,0)) - I DA,$P($G(^PS(52.5,DA,0)),"^",2),$P($G(^(0)),"^",3) S DIK="^PS(52.5," D ^DIK K DIK - I $D(^PS(52.4,PSOEXRX,0)) S DIK="^PS(52.4,",DA=PSOEXRX D ^DIK K DIK - I $G(^PSRX(PSOEXRX,"H"))]"" K:$P(^PSRX(PSOEXRX,"H"),"^") ^PSRX("AH",$P(^PSRX(PSOEXRX,"H"),"^"),PSOEXRX) S ^PSRX(PSOEXRX,"H")="" - S PSOEXSTA=$P($G(^PSRX(PSOEXRX,"STA")),"^") - ; - I PSOEXSTA=11 S ORN=$P($G(^PSRX(PSOEXRX,"OR1")),"^",2) I ORN I CPRSDC'[(","_CPRSSTA_",") D - .S $P(^PSRX(PSOEXRX,0),"^",19)=1 - .D EN^PSOHLSN1(PSOEXRX,"SC","ZE","Prescription is expired") - ; - I PSOEXSTA=13 D Q - .I 'ORN D EN^PSOHDR("PRES",PSOEXRX) - ; - I PSOEXSTA>9&(PSOEXSTA'=16) Q - ; - I +$P($G(^PSRX(PSOEXRX,2)),"^",6),+$P($G(^(2)),"^",6)
CDT) D EN1 + K PSOEXRX,PSOEXSTA,ZZIDT,ZZDT,CDT,ORN,PIFN,PSUSD,PRFDT,PDA,PSDTEST S:$D(ZTQUEUED) ZTREQ="@" + Q +EN1 ; + F PSOEXRX=0:0 S PSOEXRX=$O(^PSRX("AG",ZZDT,PSOEXRX)) Q:'PSOEXRX D + .Q:$P($G(^PSRX(PSOEXRX,2)),"^",6)'=ZZDT + .I $D(^PSRX(PSOEXRX,0)) D EN2 + Q +EN2 ; + S DA=$O(^PS(52.5,"B",PSOEXRX,0)) + I DA,$P($G(^PS(52.5,DA,0)),"^",2),$P($G(^(0)),"^",3) S DIK="^PS(52.5," D ^DIK K DIK + I $D(^PS(52.4,PSOEXRX,0)) S DIK="^PS(52.4,",DA=PSOEXRX D ^DIK K DIK + I $G(^PSRX(PSOEXRX,"H"))]"" K:$P(^PSRX(PSOEXRX,"H"),"^") ^PSRX("AH",$P(^PSRX(PSOEXRX,"H"),"^"),PSOEXRX) S ^PSRX(PSOEXRX,"H")="" + S PSOEXSTA=$P($G(^PSRX(PSOEXRX,"STA")),"^") + I PSOEXSTA=11 D + .S $P(^PSRX(PSOEXRX,0),"^",19)=1 + .S ORN=$P($G(^PSRX(PSOEXRX,"OR1")),"^",2) + .I ORN,+$$STATUS^ORQOR2(ORN)=6 D + ..D EN^PSOHLSN1(PSOEXRX,"SC","ZE","Prescription is expired") + I (PSOEXSTA="")!(PSOEXSTA>9) Q + ; + ;get only those Rxs whoes status lies within 0 & 9 + I PSOEXSTA?1N,+$P($G(^PSRX(PSOEXRX,2)),"^",6),+$P($G(^(2)),"^",6)
50% ;02/27/04 - ;;7.0;OUTPATIENT PHARMACY;**143,219,239,225**;DEC 1997;Build 29 - ;External reference SDC022 supported by DBIA 1579 - ;External reference DIS^SDROUT2 private by DBIA 112 - ;External reference $$GETSHAD^DGUTL3 supported by DBIA 4462 -SC ;This routine is used for SC>50% - OUTSIDE OF COPAY - DFN AND PSOSCP VARIABLES ARE EXPECTED TO BE PRESENT WHEN CALLED - ; Requires: DFN, PSOSCP, PSOSCA - I '$G(DFN) N DFN S DFN=+$G(PSODFN) - ;I $G(DFN) I '$$SC^SDCO22(DFN) D Q ;if SC>49 don't ask if api says not to - ;. K PSOANSQ("SC>50"),PSOANSQD("SC>50") I $G(PSOX("IRXN")) K PSOANSQ(PSOX("IRXN"),"SC>50") -SC2 I $G(PSOMESOI)=1,$G(PSORXED) W !!,"The Pharmacy Orderable Item has changed for this order. Please review any",!,"existing SC or Environmental Indicator defaults carefully for appropriateness.",! S PSOMESOI=2 - I $G(PSOMESFI)=1 W !!,"The Pharmacy Orderable Item has changed for this order. Please review any",!,"existing SC or Environmental Indicator defaults carefully for appropriateness.",! S PSOMESFI=2 - D DIS^SDROUT2 - N PSOUFLAG S PSOUFLAG=0 K DIR S DIR(0)="Y" - S DIR("A")="Was treatment for a Service Connected condition" - S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition related",DIR("?",2)="to Service Connected." - I '$G(PSOFLAG) D - . I PSOSCP<50 S (DIR("B"),PSOUFLAG)=$S($G(PSORX(+$G(PSORENW("OIRXN")),"SC"))=0:"NO",$G(PSORX(+$G(PSORENW("OIRXN")),"SC"))=1:"YES",1:"") I DIR("B")="" K DIR("B") S PSOUFLAG=0 - . I PSOSCP<50&($D(PSORX(+$G(PSORENW("OIRXN")),"SC>50"))) S (DIR("B"),PSOUFLAG)=$S($G(PSORX(+$G(PSORENW("OIRXN")),"SC>50"))=0:"NO",$G(PSORX(+$G(PSORENW("OIRXN")),"SC>50"))=1:"YES",1:"") I DIR("B")="" K DIR("B") S PSOUFLAG=0 - . I PSOSCP>49 S (DIR("B"),PSOUFLAG)=$S($G(PSORX(+$G(PSORENW("OIRXN")),"SC>50"))=0:"NO",$G(PSORX(+$G(PSORENW("OIRXN")),"SC>50"))=1:"YES",1:"") I DIR("B")="" K DIR("B") S PSOUFLAG=0 - . I '$D(DIR("B"))&($D(PSOANSQD("SC>50"))!($D(PSOANSQD("SC")))) D I '$D(DIR("B")) K DIR("B") S PSOUFLAG=0 - .. I $D(PSOANSQD("SC>50")) I $G(PSOANSQD("SC>50"))=0!($G(PSOANSQD("SC>50"))=1) S (PSOUFLAG,DIR("B"))=$S($G(PSOANSQD("SC>50"))=1:"YES",1:"NO") - .. I $D(PSOANSQD("SC")) I $G(PSOANSQD("SC"))=0!($G(PSOANSQD("SC"))=1) S (PSOUFLAG,DIR("B"))=$S($G(PSOANSQD("SC"))=1:"YES",1:"NO") - I $G(PSORX("SC"))]""!($G(PSORX(+$G(PSORENW("OIRXN")),"SC"))'="") S DIR("B")=$S($G(PSORX("SC"))="SC":"YES",$G(PSORX("SC"))="NSC":"NO",$G(PSORX(+$G(PSORENW("OIRXN")),"SC"))=1:"YES",$G(PSORX(+$G(PSORENW("OIRXN")),"SC"))=0:"NO",1:"") - ; - I $G(PSOFLAG),$G(PSONEWFF) I $G(PSOANSQD("SC>50"))=0!($G(PSOANSQD("SC>50"))=1) S DIR("B")=$S($G(PSOANSQD("SC>50"))=1:"YES",1:"NO") - I $G(DIR("B"))="YES"!($G(DIR("B"))="NO") S PSOUFLAG=$G(DIR("B")) - I $G(DIR("B"))="" K DIR("B") - W ! D ^DIR K DIR - I $G(Y)=1!($G(Y)=0) D I $G(PSONEWFF),$G(PSOFLAG) S PSOANSQD("SC>50")=$G(Y) - . I $G(PSOX("IRXN")) S PSOANSQ(PSOX("IRXN"),"SC>50")=+Y - . S PSOANSQ("SC>50")=+Y - I PSOFLAG I Y["^"!($D(DTOUT))!($D(DUOUT)) S PSOCPZ("DFLG")=1 - S:Y=0 Y=2 - S PSOANSR=+Y I 'PSOANSR,'PSOFLAG D S $P(PSOCPAY,"^")=$S($G(PSOUFLAG)="NO":1,1:0) W ! K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR Q - .W !!,"This Renewal has been designated as "_$S($G(PSOUFLAG)="YES":"SERVICE CONNECTED",1:"NON-SERVICE CONNECTED.") - .;W !,"Please use the 'Reset Copay Status/Cancel Charges' option to make corrections." - .S PSOANSQ("SC>50")=$S($G(PSOUFLAG)="YES":1,1:0) - I $G(PSOFLAG),$G(PSOCPZ("DFLG")) G EXIT - S:PSOANSR=1 PSOCPAY=0 S:PSOANSR=2 $P(PSOCPAY,"^")=1 -EXIT ; - K PSOANSR,DIR,DUOUT,DIRUT,DTOUT,Y,X,PSOSCA - Q - ; -PAUSE K DIR W ! S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR - Q - ; -SHAD ; PROJ 112/SHAD Question - I $G(PSODFN),$L($T(GETSHAD^DGUTL3)) I $$GETSHAD^DGUTL3(PSODFN)'=1 D Q - . K PSOANSQ("SHAD"),PSOANSQD("SHAD") I $G(PSOX("IRXN")) K PSOANSQ(PSOX("IRXN"),"SHAD") - N PSOUFLAG S PSOUFLAG=0 - K DIR S DIR(0)="Y" - S DIR("A")="Was treatment related to PROJ 112/SHAD" - S DIR("?")=" " - S DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition due to" - S DIR("?",2)="Shipboard Hazard and Defense (SHAD) exposure." - S DIR("?",3)="This response will be used to determine whether or not a copay should" - S DIR("?",4)="be applied to the prescription." - I '$G(PSOFLAG) D - . S (DIR("B"),PSOUFLAG)=$S($G(PSORX(+$G(PSORENW("OIRXN")),"SHAD"))=0:"NO",$G(PSORX(+$G(PSORENW("OIRXN")),"SHAD"))=1:"YES",1:"") - . I DIR("B")="" K DIR("B") S PSOUFLAG=0 - I $G(PSOFLAG),$G(PSONEWFF) D - . I $G(PSOANSQD("SHAD"))=0!($G(PSOANSQD("SHAD"))=1) D - . . S DIR("B")=$S($G(PSOANSQD("SHAD"))=1:"YES",1:"NO") - W ! D ^DIR K DIR - I $G(PSOFLAG) W ! D Q - . I Y["^"!($D(DUOUT))!($G(DTOUT)) S PSOCPZ("DFLG")=1 Q - . S PSOANSQ("SHAD")=Y - . I $G(PSONEWFF) S PSOANSQD("SHAD")=Y - I Y["^"!($D(DUOUT))!($D(DTOUT)) D Q - . W !!,"This Renewal has been designated as"_$S($G(PSOUFLAG)="YES":"",1:" NOT")_" being used for treatment of " - . W !,"Shipboard Hazard and Defense (SHAD) exposure." D:$G(PSOSCP)<50 MESS^PSOMLLDT D PAUSE - . S PSOANSQ(PSOX("IRXN"),"SHAD")=$S($G(PSOUFLAG)="YES":1,1:0) - I $G(PSOX("IRXN")) S PSOANSQ(PSOX("IRXN"),"SHAD")=Y - E S PSOANSQ("SHAD")=Y - Q - ; +PSOMLLD2 ;BIR/LE - Service Connection Check for SC>50% ;02/27/04 + ;;7.0;OUTPATIENT PHARMACY;**143,219,239**;DEC 1997 + ;External reference SDC022 supported by DBIA 1579 + ;External reference DIS^SDROUT2 private by DBIA 112 +SC ;This routine is used for SC>50% - OUTSIDE OF COPAY - DFN AND PSOSCP VARIABLES ARE EXPECTED TO BE PRESENT WHEN CALLED + ; Requires: DFN, PSOSCP, PSOSCA + I '$G(DFN) N DFN S DFN=+$G(PSODFN) + ;I $G(DFN) I '$$SC^SDCO22(DFN) D Q ;if SC>49 don't ask if api says not to + ;. K PSOANSQ("SC>50"),PSOANSQD("SC>50") I $G(PSOX("IRXN")) K PSOANSQ(PSOX("IRXN"),"SC>50") +SC2 I $G(PSOMESOI)=1,$G(PSORXED) W !!,"The Pharmacy Orderable Item has changed for this order. Please review any",!,"existing SC or Environmental Indicator defaults carefully for appropriateness.",! S PSOMESOI=2 + I $G(PSOMESFI)=1 W !!,"The Pharmacy Orderable Item has changed for this order. Please review any",!,"existing SC or Environmental Indicator defaults carefully for appropriateness.",! S PSOMESFI=2 + D DIS^SDROUT2 + N PSOUFLAG S PSOUFLAG=0 K DIR S DIR(0)="Y" + S DIR("A")="Was treatment for a Service Connected condition" + S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition related",DIR("?",2)="to Service Connected." + I '$G(PSOFLAG) D + . I PSOSCP<50 S (DIR("B"),PSOUFLAG)=$S($G(PSORX(+$G(PSORENW("OIRXN")),"SC"))=0:"NO",$G(PSORX(+$G(PSORENW("OIRXN")),"SC"))=1:"YES",1:"") I DIR("B")="" K DIR("B") S PSOUFLAG=0 + . I PSOSCP<50&($D(PSORX(+$G(PSORENW("OIRXN")),"SC>50"))) S (DIR("B"),PSOUFLAG)=$S($G(PSORX(+$G(PSORENW("OIRXN")),"SC>50"))=0:"NO",$G(PSORX(+$G(PSORENW("OIRXN")),"SC>50"))=1:"YES",1:"") I DIR("B")="" K DIR("B") S PSOUFLAG=0 + . I PSOSCP>49 S (DIR("B"),PSOUFLAG)=$S($G(PSORX(+$G(PSORENW("OIRXN")),"SC>50"))=0:"NO",$G(PSORX(+$G(PSORENW("OIRXN")),"SC>50"))=1:"YES",1:"") I DIR("B")="" K DIR("B") S PSOUFLAG=0 + . I '$D(DIR("B"))&($D(PSOANSQD("SC>50"))!($D(PSOANSQD("SC")))) D I '$D(DIR("B")) K DIR("B") S PSOUFLAG=0 + .. I $D(PSOANSQD("SC>50")) I $G(PSOANSQD("SC>50"))=0!($G(PSOANSQD("SC>50"))=1) S (PSOUFLAG,DIR("B"))=$S($G(PSOANSQD("SC>50"))=1:"YES",1:"NO") + .. I $D(PSOANSQD("SC")) I $G(PSOANSQD("SC"))=0!($G(PSOANSQD("SC"))=1) S (PSOUFLAG,DIR("B"))=$S($G(PSOANSQD("SC"))=1:"YES",1:"NO") + I $G(PSORX("SC"))]""!($G(PSORX(+$G(PSORENW("OIRXN")),"SC"))'="") S DIR("B")=$S($G(PSORX("SC"))="SC":"YES",$G(PSORX("SC"))="NSC":"NO",$G(PSORX(+$G(PSORENW("OIRXN")),"SC"))=1:"YES",$G(PSORX(+$G(PSORENW("OIRXN")),"SC"))=0:"NO",1:"") + ; + I $G(PSOFLAG),$G(PSONEWFF) I $G(PSOANSQD("SC>50"))=0!($G(PSOANSQD("SC>50"))=1) S DIR("B")=$S($G(PSOANSQD("SC>50"))=1:"YES",1:"NO") + I $G(DIR("B"))="YES"!($G(DIR("B"))="NO") S PSOUFLAG=$G(DIR("B")) + I $G(DIR("B"))="" K DIR("B") + W ! D ^DIR K DIR + I $G(Y)=1!($G(Y)=0) D I $G(PSONEWFF),$G(PSOFLAG) S PSOANSQD("SC>50")=$G(Y) + . I $G(PSOX("IRXN")) S PSOANSQ(PSOX("IRXN"),"SC>50")=+Y + . S PSOANSQ("SC>50")=+Y + I PSOFLAG I Y["^"!($D(DTOUT))!($D(DUOUT)) S PSOCPZ("DFLG")=1 + S:Y=0 Y=2 + S PSOANSR=+Y I 'PSOANSR,'PSOFLAG D S $P(PSOCPAY,"^")=$S($G(PSOUFLAG)="NO":1,1:0) W ! K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR Q + .W !!,"This Renewal has been designated as "_$S($G(PSOUFLAG)="YES":"SERVICE CONNECTED",1:"NON-SERVICE CONNECTED.") + .;W !,"Please use the 'Reset Copay Status/Cancel Charges' option to make corrections." + .S PSOANSQ("SC>50")=$S($G(PSOUFLAG)="YES":1,1:0) + I $G(PSOFLAG),$G(PSOCPZ("DFLG")) G EXIT + S:PSOANSR=1 PSOCPAY=0 S:PSOANSR=2 $P(PSOCPAY,"^")=1 +EXIT ; + K PSOANSR,DIR,DUOUT,DIRUT,DTOUT,Y,X,PSOSCA + Q + ; +PAUSE K DIR W ! S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR + Q + ; diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOMLLDT.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOMLLDT.m index a3b1d355..33c168d9 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOMLLDT.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOMLLDT.m @@ -1,164 +1,163 @@ -PSOMLLDT ;BIR/RTR - Copay date routine ;08/24/01 - ;;7.0;OUTPATIENT PHARMACY;**71,157,143,219,278,225**;DEC 1997;Build 29 - ;External reference SDC022 supported by DBIA 1579 - ;External reference DGMSTAPI supported by DBIA2716 - ;CIDC: Before doing EI question, check to see if should ask ei question - ; because the flag could have changed in enrollment and we shouldn't - ; ask if not flagged and should set nulls for answer if Rx is renewed - ; or copied when flags changed. Also, CPRS sometimes sends zeros for - ; null answers. 5/12/04 -DT() ;function for Copay date - ;0 means Copay not in effect, 1 means Copay in effect - N PSOMILDT - S PSOMILDT=3020101 - I '$G(DT) S DT=$$DT^XLFDT - Q $S(DT1,$E(+PSODRUG("DEA"),DEA)<6 S $P(PSOX("CS"),"^")=1 S:$E(+PSODRUG("DEA"),DEA)=2 $P(PSOX("CS"),"^",2)=1 - S PSON52("QFLG")=0,X1=PSOX("ISSUE DATE"),X2=PSOX("DAYS SUPPLY")*(PSOX("# OF REFILLS")+1)\1 - I $D(CLOZPAT) S X2=$S(X2=14:14,X2=7:7,1:X2) G DT - S X2=$S(PSOX("DAYS SUPPLY")=X2:X2,+$G(PSOX("CS")):184,+$G(DEA("CS")):184,1:366) - I X2<30 D - . N % S %=$P($G(PSORX("PATIENT STATUS")),"^"),X2=30 - . S:%?.N %=$P($G(^PS(53,+%,0)),"^") I %["AUTH ABS" S X2=5 -DT D C^%DTC S PSOX("STOP DATE")=$P(X,".") K X - I PSOX("# OF REFILLS")>0 S X1=PSOX("FILL DATE"),X2=$S((PSOX("DAYS SUPPLY")-10\1)<1:1,1:PSOX("DAYS SUPPLY")-10\1) D C^%DTC S PSOX("NEXT POSSIBLE REFILL")=$P(X,".") K X - S PSOX("TYPE OF RX")=0,PSOX("DISPENSED DATE")=PSOX("FILL DATE") D NOW^%DTC S PSOX("LOGIN DATE")=$S($P($G(OR0),"^",12):$P($G(OR0),"^",12),1:%) K %,X - S PSOX("STATUS")=$S($G(PSOX("STATUS"))]"":PSOX("STATUS"),$D(PSORX("VERIFY")):1,1:0) - S PSOX("COPIES")=$S($G(PSOX("COPIES"))]"":PSOX("COPIES"),1:1) - I $G(PSORX("PHARM"))]"" S PSOX("PHARMACIST")=PSORX("PHARM") K PSORX("PHARM") -INITX Q - ; -NFILE I $G(OR0) D Q:$G(PSONEW("DFLG")) - .D NOOR^PSONEW Q:$G(PSONEW("DFLG")) - .I $G(PSOSIGFL)!($G(PSODRUG("OI"))'=$P(OR0,"^",8)) S PSONEW("CLERK CODE")=DUZ,PSONEW("REMARKS")=$G(PSONEW("REMARKS"))_" CPRS Order #"_$P(OR0,"^")_" Edited." - S DIC="^PSRX(",DLAYGO=52,DIC(0)="L",X=PSOX("RX #") K DD,DO D FILE^DICN S PSOX("IRXN")=+Y K DLAYGO,X,Y,DIC,DD,DO D:+$G(DGI) TECH^PSODGDGI - F PSOX1=0:1 S PSON52=$P($T(DD+PSOX1),";;",2,4) Q:PSON52="" K PSOY S PSOY=$P(PSON52,";;") I $G(@PSOY)]"" S $P(PSON52(PSOX("IRXN"),$P(PSON52,";;",2)),"^",$P(PSON52,";;",3))=@PSOY - F I=1:1:PSOX("ENT") S ^PSRX(PSOX("IRXN"),6,I,0)=PSOX("DOSE",I)_"^"_$G(PSOX("DOSE ORDERED",I))_"^"_$G(PSOX("UNITS",I))_"^"_$G(PSOX("NOUN",I))_"^" D - .S ^PSRX(PSOX("IRXN"),6,I,0)=^PSRX(PSOX("IRXN"),6,I,0)_$G(PSOX("DURATION",I))_"^"_$G(PSOX("CONJUNCTION",I))_"^"_$G(PSOX("ROUTE",I))_"^"_$G(PSOX("SCHEDULE",I))_"^"_$G(PSOX("VERB",I)) - .I $G(PSOX("ODOSE",I))]"" S ^PSRX(PSOX("IRXN"),6,I,1)=PSOX("ODOSE",I) - S ^PSRX(PSOX("IRXN"),6,0)="^52.0113^"_PSOX("ENT")_"^"_PSOX("ENT") - K PSOX1,PSOY - S PSOX1="" F S PSOX1=$O(PSON52(PSOX("IRXN"),PSOX1)) Q:PSOX1="" S ^PSRX(PSOX("IRXN"),PSOX1)=$G(PSON52(PSOX("IRXN"),PSOX1)) - I $O(PSOX("SIG",0)) D - .S D=0 F S D=$O(PSOX("SIG",D)) Q:'D S ^PSRX(PSOX("IRXN"),"INS1",D,0)=PSOX("SIG",D),TP=$G(TP)+1 - .S ^PSRX(PSOX("IRXN"),"INS1",0)="^52.0115^"_TP_"^"_TP_"^"_DT_"^^" K TP,D - I $G(PSOX("SINS"))]"" S ^PSRX(PSOX("IRXN"),"INSS")=PSOX("SINS") - I $G(SIGOK) D - .S $P(^PSRX(PSOX("IRXN"),"SIG"),"^",2)=1,^PSRX(PSOX("IRXN"),"SIG1",0)="^52.04A^^" - .S D=0 F S D=$O(SIG(D)) Q:'D S ^PSRX(PSOX("IRXN"),"SIG1",D,0)=SIG(D),$P(^PSRX(PSOX("IRXN"),"SIG1",0),"^",3)=+$P(^PSRX(PSOX("IRXN"),"SIG1",0),"^",3)+1,$P(^(0),"^",4)=+$P(^(0),"^",4)+1 Q:'$O(SIG(D)) - .K SIG - I $D(PSOINSFL) S ^PSRX(PSOX("IRXN"),"A",0)="^52.3DA^1^1",^PSRX(PSOX("IRXN"),"A",1,0)=DT_"^G^^0^Patient Instructions "_$S(PSOINSFL=1:"",1:"Not ")_"Sent By Provider." - I $G(OR0) S:$P(OR0,"^",24) ^PSRX(PSOX("IRXN"),"PKI")=1 - K PSOX1,PSOFINFL,HLDSIG,D,PSOINSFL,D - D:$G(^TMP("PSODAI",$J,0)) - .S $P(^PSRX(PSOX("IRXN"),3),"^",6)=1 - .I $O(^TMP("PSODAI",$J,0)) S DAI=0 F S DAI=$O(^TMP("PSODAI",$J,DAI)) Q:'DAI D - ..S:'$D(^PSRX(PSOX("IRXN"),"DAI",0)) ^PSRX(PSOX("IRXN"),"DAI",0)="^52.03^^" S ^PSRX(PSOX("IRXN"),"DAI",DAI,0)=^TMP("PSODAI",$J,DAI,0) - ..S $P(^PSRX(PSOX("IRXN"),"DAI",0),"^",3)=+$P(^PSRX(PSOX("IRXN"),"DAI",0),"^",3)+1,$P(^(0),"^",4)=+$P(^(0),"^",4)+1 - .K ^TMP("PSODAI",$J),DAI - I $G(PSOX("CHCS NUMBER"))'="" S $P(^PSRX(PSOX("IRXN"),"EXT"),"^")=$G(PSOX("CHCS NUMBER")) - I $G(PSOX("EXTERNAL SYSTEM"))'="" S $P(^PSRX(PSOX("IRXN"),"EXT"),"^",2)=$G(PSOX("EXTERNAL SYSTEM")) - I $G(PSOX("NEWCOPAY")) S ^PSRX(PSOX("IRXN"),"IB")=$G(PSOX("NEWCOPAY")) - ;Next line, set SC question based on Copay status? -IBQ ;I $G(PSOBILL)=2 S ^PSRX(PSOX("IRXN"),"IBQ")=$S($G(PSOX("NEWCOPAY")):0,1:1) - N PSOSCFLD S PSOSCFLD=$S(PSOSCP'="":$G(PSOANSQ("SC")),1:"")_"^"_$G(PSOANSQ("MST"))_"^"_$G(PSOANSQ("VEH"))_"^"_$G(PSOANSQ("RAD"))_"^"_$G(PSOANSQ("PGW"))_"^"_$G(PSOANSQ("HNC"))_"^"_$G(PSOANSQ("CV"))_"^"_$G(PSOANSQ("SHAD")) - I PSOSCP<50&($TR(PSOSCFLD,"^")'="")&($P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)'=1) D - . S ^PSRX(PSOX("IRXN"),"IBQ")=PSOSCFLD K PSOSCFLD ;don't set if SC % is null or 0, just set it in ICD node - D ICD^PSODIAG - D:$$SWSTAT^IBBAPI() GACT^PSOPFSU0(PSOX("IRXN"),0) - K PSOANSQ,PSOANSQD,PSOX("NEWCOPAY") - L -^PSRX("B",PSOX("IRXN")) - Q - ; -PS55 ; - L +^PS(55,PSODFN,"P"):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) - S:'$D(^PS(55,PSODFN,"P",0)) ^(0)="^55.03PA^^" - F PSOX1=$P(^PS(55,PSODFN,"P",0),"^",3):1 Q:'$D(^PS(55,PSODFN,"P",PSOX1)) - S PSOX("55 IEN")=PSOX1 - S ^PS(55,PSODFN,"P",PSOX1,0)=PSOX("IRXN"),$P(^PS(55,PSODFN,"P",0),"^",3,4)=PSOX1_"^"_($P(^PS(55,PSODFN,"P",0),"^",4)+1) - S ^PS(55,PSODFN,"P","A",PSONEW("STOP DATE"),PSOX("IRXN"))="" -PS55X L -^PS(55,PSODFN,"P") - K PSOX1 - Q -DIK ; - I $D(^XUSEC("PSORPH",DUZ)) S DA=PSOX("IRXN"),DIE=52,DR="41////"_PSOCOU_";S:'X Y=""@1"";42////"_PSOCOUU_";@1" D ^DIE K DIE,DR - K DIK,DA S DIK="^PSRX(",DA=PSOX("IRXN") D IX1^DIK K DIK - S DA=PSOX("IRXN") D ORC^PSORN52C - Q -FINISH ; -ANQ I $G(ANQDATA)]"" D NOW^%DTC G:$D(^PS(52.52,"B",%)) ANQ D - .K DD,DO S DIC="^PS(52.52,",DIC(0)="L",DLAYGO=52.52,X=% D FILE^DICN K DIC,DLAYGO,DD,DO - .S ^PS(52.52,+Y,0)=$P(Y,"^",2)_"^"_PSOX("IRXN")_"^"_ANQDATA,^PS(52.52,"A",PSOX("IRXN"),+Y)="" K ANQDATA,X,Y,%,ANQREM - G:PSOX("STATUS")=4 FINISHP - I $D(PSORX("VERIFY")) D G FINISHX - .K DIC,DLAYGO,DINUM,DIADD,X,DD,DO S DIC="^PS(52.4,",DLAYGO=52.4,DINUM=PSOX("IRXN"),DIC(0)="ML",X=PSOX("IRXN") - .D FILE^DICN K DD,DO,DIC,DLAYGO,DINUM S ^PS(52.4,PSOX("IRXN"),0)=PSOX("IRXN")_"^"_PSODFN_"^"_DUZ_"^"_"^"_$E(PSOX("LOGIN DATE"),1,7)_"^"_PSOX("IRXN")_"^"_PSOX("STOP DATE") - .K DIK,DA S DIK="^PS(52.4,",DA=PSOX("IRXN") D IX^DIK K DIK,DA - ; - I PSOX("FILL DATE")>DT,$P(PSOPAR,"^",6) S DA=PSOX("IRXN"),RXFL(PSOX("IRXN"))=0 D SUS^PSORXL K DA G FINISHX - ; - ; - Calling ECME for claims generation and transmission / REJECT handling - N ACTION,PSOERX - S PSOERX=PSOX("IRXN") - I $$SUBMIT^PSOBPSUT(PSOERX,0) D I ACTION="Q"!(ACTION="^") Q - . S ACTION="" D ECMESND^PSOBPSU1(PSOERX,0,PSOX("FILL DATE"),"OF") - . I $$FIND^PSOREJUT(PSOERX,0) D - . . S ACTION=$$HDLG^PSOREJU1(PSOERX,0,"79,88","OF","IOQ","I") - . I $$STATUS^PSOBPSUT(PSOERX,0)="E PAYABLE" D - . . D SAVNDC^PSSNDCUT(+$$GET1^DIQ(52,PSOERX,6,"I"),$G(PSOSITE),$$GETNDC^PSONDCUT(PSOERX,0)) - ; -FINISHP ; - I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=PSOX("IRXN")_",",RXFL(PSOX("IRXN"))=0 G FINISHX - F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1 S PSOX2=PSOX1 - I $L(PSORX("PSOL",PSOX2))+$L(PSOX("IRXN"))<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_PSOX("IRXN")_"," - E S PSORX("PSOL",PSOX2+1)=PSOX("IRXN")_"," - S RXFL(PSOX("IRXN"))=0 -FINISHX ;call to build Rx array for bingo board - I $G(PSORX("MAIL/WINDOW"))["W" S BINGCRT=1,BINGRTE="W",BBFLG=1 D BBRX^PSORN52C - K PSOX1,PSOX2 - Q -EOJ ; - ;B xref locked in routine PSONRXN - L -^PSRX("B",PSOX("IRXN")) K OTHDOS,DA,PSON52,PSOPRC,RTE,SCH,PSOX("INS"),PSONEW("INS"),PSORXED("INS"),PSONEW("ENT"),PSORXED("ENT"),OLENT - D PSOUL^PSSLOCK(PSOX("IRXN")) - Q - ; - ;;PSOX("SIG");;SIG;;1 -DD ;;PSOX("RX #");;0;;1 - ;;PSOX("ISSUE DATE");;0;;13 - ;;PSODFN;;0;;2 - ;;PSOX("PATIENT STATUS");;0;;3 - ;;PSOX("PROVIDER");;0;;4 - ;;PSOX("CLINIC");;0;;5 - ;;PSODRUG("IEN");;0;;6 - ;;PSODRUG("TRADE NAME");;TN;;1 - ;;PSOX("QTY");;0;;7 - ;;PSOX("DAYS SUPPLY");;0;;8 - ;;PSOX("# OF REFILLS");;0;;9 - ;;PSOX("COPIES");;0;;18 - ;;PSOX("MAIL/WINDOW");;0;;11 - ;;PSOX("REMARKS");;3;;7 - ;;PSOX("CLERK CODE");;0;;16 - ;;PSODRUG("COST");;0;;17 - ;;PSOSITE;;2;;9 - ;;PSOX("LOGIN DATE");;2;;1 - ;;PSOX("FILL DATE");;2;;2 - ;;PSOX("PHARMACIST");;2;;3 - ;;PSOX("LOT #");;2;;4 - ;;PSOX("DISPENSED DATE");;2;;5 - ;;PSOX("STOP DATE");;2;;6 - ;;PSODRUG("NDC");;2;;7 - ;;PSODRUG("DAW");;EPH;;1 - ;;PSODRUG("MANUFACTURER");;2;;8 - ;;PSOX("EXPIRATION DATE");;2;;11 - ;;PSOX("GENERIC PROVIDER");;2;;12 - ;;PSOX("RELEASED DATE/TIME");;2;;13 - ;;PSOX("METHOD OF PICK-UP");;MP;;1 - ;;PSOX("STATUS");;STA;;1 - ;;PSOX("LAST DISPENSED DATE");;3;;1 - ;;PSOX("NEXT POSSIBLE REFILL");;3;;2 - ;;PSOX("COSIGNING PROVIDER");;3;;3 - ;;PSOX("TYPE OF RX");;TYPE;;1 - ;;PSOX("SAND");;SAND;;1 - ;;PSOX("POE");;POE;;1 - ;;PSOX("INS");;INS;;1 +PSON52 ;BIR/DSD - files new entries in prescription file ;08/09/93 + ;;7.0;OUTPATIENT PHARMACY;**1,16,23,27,32,46,71,111,124,117,131,139,157,143,219,148,239,201,268,208**;DEC 1997;Build 39 + ; 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 + ;External reference ^PS(55 supported by DBIA 2228 + ;External reference to PSOUL^PSSLOCK supported by DBIA 2789 + ;External reference to ^XUSEC supported by DBIA 10076 + ;External reference SWSTAT^IBBAPI supported by DBIA 4663 +EN(PSOX) ;Entry Point +START ; + D:$D(XRTL) T0^%ZOSV ; Start RT Monitor + D INIT G:PSON52("QFLG") END D NFILE Q:$G(PSONEW("DFLG")) D PS55,DIK + S:$D(XRT0) XRTN=$T(+0) D:$D(XRT0) T1^%ZOSV ; Stop RT Monitor + D FINISH + I $P(^PSRX(PSOX("IRXN"),0),"^",11)="W",$G(^("IB")) S ^PSRX("ACP",$P(^PSRX(PSOX("IRXN"),0),"^",2),$P(^(2),"^",2),0,PSOX("IRXN"))="" +END D EOJ + Q +INIT ; + K X,%DT S:$G(PSOID) PSOX("ISSUE DATE")=PSOID + S PSOX("CS")=0 + F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)="" I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S $P(PSOX("CS"),"^")=1 S:$E(+PSODRUG("DEA"),DEA)=2 $P(PSOX("CS"),"^",2)=1 + S PSON52("QFLG")=0,X1=PSOX("ISSUE DATE"),X2=PSOX("DAYS SUPPLY")*(PSOX("# OF REFILLS")+1)\1 + I $D(CLOZPAT) S X2=$S(X2=14:14,X2=7:7,1:X2) G DT + S X2=$S(PSOX("DAYS SUPPLY")=X2:X2,+$G(PSOX("CS")):184,+$G(DEA("CS")):184,1:366) + I X2<30 D + . N % S %=$P($G(PSORX("PATIENT STATUS")),"^"),X2=30 + . S:%?.N %=$P($G(^PS(53,+%,0)),"^") I %["AUTH ABS" S X2=5 +DT D C^%DTC S PSOX("STOP DATE")=$P(X,".") K X + I PSOX("# OF REFILLS")>0 S X1=PSOX("FILL DATE"),X2=$S((PSOX("DAYS SUPPLY")-10\1)<1:1,1:PSOX("DAYS SUPPLY")-10\1) D C^%DTC S PSOX("NEXT POSSIBLE REFILL")=$P(X,".") K X + S PSOX("TYPE OF RX")=0,PSOX("DISPENSED DATE")=PSOX("FILL DATE") D NOW^%DTC S PSOX("LOGIN DATE")=$S($P($G(OR0),"^",12):$P($G(OR0),"^",12),1:%) K %,X + S PSOX("STATUS")=$S($G(PSOX("STATUS"))]"":PSOX("STATUS"),$D(PSORX("VERIFY")):1,1:0) + S PSOX("COPIES")=$S($G(PSOX("COPIES"))]"":PSOX("COPIES"),1:1) + I $G(PSORX("PHARM"))]"" S PSOX("PHARMACIST")=PSORX("PHARM") K PSORX("PHARM") +INITX Q + ; +NFILE I $G(OR0) D Q:$G(PSONEW("DFLG")) + .D NOOR^PSONEW Q:$G(PSONEW("DFLG")) + .I $G(PSOSIGFL)!($G(PSODRUG("OI"))'=$P(OR0,"^",8)) S PSONEW("CLERK CODE")=DUZ,PSONEW("REMARKS")=$G(PSONEW("REMARKS"))_" CPRS Order #"_$P(OR0,"^")_" Edited." + S DIC="^PSRX(",DLAYGO=52,DIC(0)="L",X=PSOX("RX #") K DD,DO D FILE^DICN S PSOX("IRXN")=+Y K DLAYGO,X,Y,DIC,DD,DO D:+$G(DGI) TECH^PSODGDGI + F PSOX1=0:1 S PSON52=$P($T(DD+PSOX1),";;",2,4) Q:PSON52="" K PSOY S PSOY=$P(PSON52,";;") I $G(@PSOY)]"" S $P(PSON52(PSOX("IRXN"),$P(PSON52,";;",2)),"^",$P(PSON52,";;",3))=@PSOY + F I=1:1:PSOX("ENT") S ^PSRX(PSOX("IRXN"),6,I,0)=PSOX("DOSE",I)_"^"_$G(PSOX("DOSE ORDERED",I))_"^"_$G(PSOX("UNITS",I))_"^"_$G(PSOX("NOUN",I))_"^" D + .S ^PSRX(PSOX("IRXN"),6,I,0)=^PSRX(PSOX("IRXN"),6,I,0)_$G(PSOX("DURATION",I))_"^"_$G(PSOX("CONJUNCTION",I))_"^"_$G(PSOX("ROUTE",I))_"^"_$G(PSOX("SCHEDULE",I))_"^"_$G(PSOX("VERB",I)) + .I $G(PSOX("ODOSE",I))]"" S ^PSRX(PSOX("IRXN"),6,I,1)=PSOX("ODOSE",I) + S ^PSRX(PSOX("IRXN"),6,0)="^52.0113^"_PSOX("ENT")_"^"_PSOX("ENT") + K PSOX1,PSOY + S PSOX1="" F S PSOX1=$O(PSON52(PSOX("IRXN"),PSOX1)) Q:PSOX1="" S ^PSRX(PSOX("IRXN"),PSOX1)=$G(PSON52(PSOX("IRXN"),PSOX1)) + I $O(PSOX("SIG",0)) D + .S D=0 F S D=$O(PSOX("SIG",D)) Q:'D S ^PSRX(PSOX("IRXN"),"INS1",D,0)=PSOX("SIG",D),TP=$G(TP)+1 + .S ^PSRX(PSOX("IRXN"),"INS1",0)="^52.0115^"_TP_"^"_TP_"^"_DT_"^^" K TP,D + I $G(PSOX("SINS"))]"" S ^PSRX(PSOX("IRXN"),"INSS")=PSOX("SINS") + I $G(SIGOK) D + .S $P(^PSRX(PSOX("IRXN"),"SIG"),"^",2)=1,^PSRX(PSOX("IRXN"),"SIG1",0)="^52.04A^^" + .S D=0 F S D=$O(SIG(D)) Q:'D S ^PSRX(PSOX("IRXN"),"SIG1",D,0)=SIG(D),$P(^PSRX(PSOX("IRXN"),"SIG1",0),"^",3)=+$P(^PSRX(PSOX("IRXN"),"SIG1",0),"^",3)+1,$P(^(0),"^",4)=+$P(^(0),"^",4)+1 Q:'$O(SIG(D)) + .K SIG + I $D(PSOINSFL) S ^PSRX(PSOX("IRXN"),"A",0)="^52.3DA^1^1",^PSRX(PSOX("IRXN"),"A",1,0)=DT_"^G^^0^Patient Instructions "_$S(PSOINSFL=1:"",1:"Not ")_"Sent By Provider." + I $G(OR0) S:$P(OR0,"^",24) ^PSRX(PSOX("IRXN"),"PKI")=1 + K PSOX1,PSOFINFL,HLDSIG,D,PSOINSFL,D + D:$G(^TMP("PSODAI",$J,0)) + .S $P(^PSRX(PSOX("IRXN"),3),"^",6)=1 + .I $O(^TMP("PSODAI",$J,0)) S DAI=0 F S DAI=$O(^TMP("PSODAI",$J,DAI)) Q:'DAI D + ..S:'$D(^PSRX(PSOX("IRXN"),"DAI",0)) ^PSRX(PSOX("IRXN"),"DAI",0)="^52.03^^" S ^PSRX(PSOX("IRXN"),"DAI",DAI,0)=^TMP("PSODAI",$J,DAI,0) + ..S $P(^PSRX(PSOX("IRXN"),"DAI",0),"^",3)=+$P(^PSRX(PSOX("IRXN"),"DAI",0),"^",3)+1,$P(^(0),"^",4)=+$P(^(0),"^",4)+1 + .K ^TMP("PSODAI",$J),DAI + I $G(PSOX("CHCS NUMBER"))'="" S $P(^PSRX(PSOX("IRXN"),"EXT"),"^")=$G(PSOX("CHCS NUMBER")) + I $G(PSOX("EXTERNAL SYSTEM"))'="" S $P(^PSRX(PSOX("IRXN"),"EXT"),"^",2)=$G(PSOX("EXTERNAL SYSTEM")) + I $G(PSOX("NEWCOPAY")) S ^PSRX(PSOX("IRXN"),"IB")=$G(PSOX("NEWCOPAY")) + ;Next line, set SC question based on Copay status? +IBQ ;I $G(PSOBILL)=2 S ^PSRX(PSOX("IRXN"),"IBQ")=$S($G(PSOX("NEWCOPAY")):0,1:1) + I $G(PSOAFYN)="Y" S PSOSCP="" ;vfah + N PSOSCFLD S PSOSCFLD=$S(PSOSCP'="":$G(PSOANSQ("SC")),1:"")_"^"_$G(PSOANSQ("MST"))_"^"_$G(PSOANSQ("VEH"))_"^"_$G(PSOANSQ("RAD"))_"^"_$G(PSOANSQ("PGW"))_"^"_$G(PSOANSQ("HNC"))_"^"_$G(PSOANSQ("CV")) + I PSOSCP<50&($TR(PSOSCFLD,"^")'="")&($P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)'=1) D + . S ^PSRX(PSOX("IRXN"),"IBQ")=PSOSCFLD K PSOSCFLD ;don't set if SC % is null or 0, just set it in ICD node + D ICD^PSODIAG + D:$$SWSTAT^IBBAPI() GACT^PSOPFSU0(PSOX("IRXN"),0) + K PSOANSQ,PSOANSQD,PSOX("NEWCOPAY") + L -^PSRX("B",PSOX("IRXN")) + Q + ; +PS55 ; + L +^PS(55,PSODFN,"P"):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) + S:'$D(^PS(55,PSODFN,"P",0)) ^(0)="^55.03PA^^" + F PSOX1=$P(^PS(55,PSODFN,"P",0),"^",3):1 Q:'$D(^PS(55,PSODFN,"P",PSOX1)) + S PSOX("55 IEN")=PSOX1 + S ^PS(55,PSODFN,"P",PSOX1,0)=PSOX("IRXN"),$P(^PS(55,PSODFN,"P",0),"^",3,4)=PSOX1_"^"_($P(^PS(55,PSODFN,"P",0),"^",4)+1) + S ^PS(55,PSODFN,"P","A",PSONEW("STOP DATE"),PSOX("IRXN"))="" +PS55X L -^PS(55,PSODFN,"P") + K PSOX1 + Q +DIK ; + I $D(^XUSEC("PSORPH",DUZ)) S DA=PSOX("IRXN"),DIE=52,DR="41////"_PSOCOU_";S:'X Y=""@1"";42////"_PSOCOUU_";@1" D ^DIE K DIE,DR + K DIK,DA S DIK="^PSRX(",DA=PSOX("IRXN") D IX1^DIK K DIK + S DA=PSOX("IRXN") D ORC^PSORN52C + Q +FINISH ; +ANQ I $G(ANQDATA)]"" D NOW^%DTC G:$D(^PS(52.52,"B",%)) ANQ D + .K DD,DO S DIC="^PS(52.52,",DIC(0)="L",DLAYGO=52.52,X=% D FILE^DICN K DIC,DLAYGO,DD,DO + .S ^PS(52.52,+Y,0)=$P(Y,"^",2)_"^"_PSOX("IRXN")_"^"_ANQDATA,^PS(52.52,"A",PSOX("IRXN"),+Y)="" K ANQDATA,X,Y,%,ANQREM + G:PSOX("STATUS")=4 FINISHP + I $D(PSORX("VERIFY")) D G FINISHX + .K DIC,DLAYGO,DINUM,DIADD,X,DD,DO S DIC="^PS(52.4,",DLAYGO=52.4,DINUM=PSOX("IRXN"),DIC(0)="ML",X=PSOX("IRXN") + .D FILE^DICN K DD,DO,DIC,DLAYGO,DINUM S ^PS(52.4,PSOX("IRXN"),0)=PSOX("IRXN")_"^"_PSODFN_"^"_DUZ_"^"_"^"_$E(PSOX("LOGIN DATE"),1,7)_"^"_PSOX("IRXN")_"^"_PSOX("STOP DATE") + .K DIK,DA S DIK="^PS(52.4,",DA=PSOX("IRXN") D IX^DIK K DIK,DA + ; + I PSOX("FILL DATE")>DT,$P(PSOPAR,"^",6) S DA=PSOX("IRXN"),RXFL(PSOX("IRXN"))=0 D SUS^PSORXL K DA G FINISHX + ; + ; - Calling ECME for claims generation and transmission / REJECT handling + N ACTION + I $$SUBMIT^PSOBPSUT(PSOX("IRXN"),0) D I ACTION="Q"!(ACTION="^") Q + . S ACTION="" D ECMESND^PSOBPSU1(PSOX("IRXN"),0,PSOX("FILL DATE"),"OF") + . I $$FIND^PSOREJUT(PSOX("IRXN"),0) D + . . S ACTION=$$HDLG^PSOREJU1(PSOX("IRXN"),0,"79,88","OF","IOQ","I") + ; +FINISHP ; + I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=PSOX("IRXN")_",",RXFL(PSOX("IRXN"))=0 G FINISHX + F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1 S PSOX2=PSOX1 + I $L(PSORX("PSOL",PSOX2))+$L(PSOX("IRXN"))<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_PSOX("IRXN")_"," + E S PSORX("PSOL",PSOX2+1)=PSOX("IRXN")_"," + S RXFL(PSOX("IRXN"))=0 +FINISHX ;call to build Rx array for bingo board + I $G(PSORX("MAIL/WINDOW"))["W" S BINGCRT=1,BINGRTE="W",BBFLG=1 D BBRX^PSORN52C + K PSOX1,PSOX2 + Q +EOJ ; + ;B xref locked in routine PSONRXN + L -^PSRX("B",PSOX("IRXN")) K OTHDOS,DA,PSON52,PSOPRC,RTE,SCH,PSOX("INS"),PSONEW("INS"),PSORXED("INS"),PSONEW("ENT"),PSORXED("ENT"),OLENT + D PSOUL^PSSLOCK(PSOX("IRXN")) + Q + ; + ;;PSOX("SIG");;SIG;;1 +DD ;;PSOX("RX #");;0;;1 + ;;PSOX("ISSUE DATE");;0;;13 + ;;PSODFN;;0;;2 + ;;PSOX("PATIENT STATUS");;0;;3 + ;;PSOX("PROVIDER");;0;;4 + ;;PSOX("CLINIC");;0;;5 + ;;PSODRUG("IEN");;0;;6 + ;;PSODRUG("TRADE NAME");;TN;;1 + ;;PSOX("QTY");;0;;7 + ;;PSOX("DAYS SUPPLY");;0;;8 + ;;PSOX("# OF REFILLS");;0;;9 + ;;PSOX("COPIES");;0;;18 + ;;PSOX("MAIL/WINDOW");;0;;11 + ;;PSOX("REMARKS");;3;;7 + ;;PSOX("CLERK CODE");;0;;16 + ;;PSODRUG("COST");;0;;17 + ;;PSOSITE;;2;;9 + ;;PSOX("LOGIN DATE");;2;;1 + ;;PSOX("FILL DATE");;2;;2 + ;;PSOX("PHARMACIST");;2;;3 + ;;PSOX("LOT #");;2;;4 + ;;PSOX("DISPENSED DATE");;2;;5 + ;;PSOX("STOP DATE");;2;;6 + ;;PSODRUG("NDC");;2;;7 + ;;PSODRUG("DAW");;EPH;;1 + ;;PSODRUG("MANUFACTURER");;2;;8 + ;;PSOX("EXPIRATION DATE");;2;;11 + ;;PSOX("GENERIC PROVIDER");;2;;12 + ;;PSOX("RELEASED DATE/TIME");;2;;13 + ;;PSOX("METHOD OF PICK-UP");;MP;;1 + ;;PSOX("STATUS");;STA;;1 + ;;PSOX("LAST DISPENSED DATE");;3;;1 + ;;PSOX("NEXT POSSIBLE REFILL");;3;;2 + ;;PSOX("COSIGNING PROVIDER");;3;;3 + ;;PSOX("TYPE OF RX");;TYPE;;1 + ;;PSOX("SAND");;SAND;;1 + ;;PSOX("POE");;POE;;1 + ;;PSOX("INS");;INS;;1 diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSONEW.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSONEW.m index 5089e168..c4210e64 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSONEW.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSONEW.m @@ -1,91 +1,108 @@ -PSONEW ;BIR/SAB-new rx order main driver ;07/26/96 - ;;7.0;OUTPATIENT PHARMACY;**11,27,32,46,94,130,268,225**;DEC 1997;Build 29 - ;External references L and UL^PSSLOCK supported by DBIA 2789 - ;External reference to ^VA(200 supported by DBIA 224 - ;External reference to ^XUSEC supported by DBIA 10076 - ;External reference to ^ORX1 supported by DBIA 2186 - ;External reference to ^ORX2 supported by DBIA 867 - ;External reference to ^TIUEDIT supported by DBIA 2410 - ;--------------------------------------------------------------- -OERR ;backdoor new rx for v7 - K PSOREEDT,COPY,SPEED,PSOEDIT,DUR,DRET - S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.") K PSOPLCK S VALMBCK="" Q - K PSOPLCK S X=PSODFN_";DPT(" D LK^ORX2 I 'Y S VALMSG="Another person is entering orders for this patient.",VALMBCK="" D UL^PSSLOCK(PSODFN) Q -AGAIN N VALMCNT K PSODRUG,PSOCOU,PSOCOUU,PSONOOR,PSORX("FN") W ! D HLDHDR^PSOLMUTL S (PSONEW("QFLG"),PSONEW("DFLG"))=0,PSOFROM="NEW",PSONOEDT=1 - K ORD D FULL^VALM1,^PSONEW1 ; Continue order entry - I PSONEW("QFLG") G END - I PSONEW("DFLG") W !,$C(7),"RX DELETED",! S:$G(POERR) POERR("DFLG")=1,VALMBCK="Q" G END - D:$P($G(PSOPAR),"^",7)=1 AUTO^PSONRXN I $P($G(PSOPAR),"^",7)'=1 S PSOX=PSONEW("RX #") D CHECK^PSONRXN - I PSONEW("DFLG")!PSONEW("QFLG") D DEL S:$G(POERR) POERR("DFLG")=1,VALMBCK="R" G END - D NOOR I PSONEW("DFLG") D DEL G END - D ^PSONEW2 I PSONEW("DFLG") D DEL S:$G(POERR) POERR("DFLG")=1,VALMBCK="R" G END ; Asks if correct - G:$G(PSORX("FN")) END - D EN^PSON52(.PSONEW) ; Files entry in File 52 - D NPSOSD^PSOUTIL(.PSONEW) ; Adds newly added rx to PSOSD array - S VALMBCK="R" -END D EOJ ; Clean up - I '$G(PSORX("FN")) W ! K DIR,DIRUT,DUOUT,DTOUT S DIR(0)="Y",DIR("B")="YES",DIR("A")="Another New Order for "_PSORX("NAME") D ^DIR K DIR,DIRUT,DUOUT,DTOUT I Y K PSONEW,PSDRUG,ORD G AGAIN - D ^PSOBUILD,BLD^PSOORUT1 S X=PSODFN_";DPT(" D ULK^ORX2 D UL^PSSLOCK(PSODFN) - D RV^PSOORFL - S VALMBCK="R" K PSORX("FN") Q - ;---------------------------------------------------------------- -DEL ; - W !,$C(7),"RX DELETED",! - I $P($G(PSOPAR),"^",7)=1 D - . S DIE="^PS(59,",DA=PSOSITE,PSOY=$O(PSONEW("OLD LAST RX#","")) - . S PSOX=PSONEW("OLD LAST RX#",PSOY) - . L +^PS(59,+PSOSITE,PSOY):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) - . S DR=$S(PSOY=8:"2003////"_PSOX,PSOY=3:"1002.1////"_PSOX,1:"2003////"_PSOX) - . D:PSOX<$P(^PS(59,+PSOSITE,PSOY),"^",3) ^DIE K DIE,X,Y - . L -^PS(59,+PSOSITE,PSOY) - . K PSOX,PSOY Q -EOJ ; - I $D(PSONEW("RX #")) L -^PSRX("B",PSONEW("RX #")) ; +Lock set in PSONRXN - K PSONOEDT,PSONEW,PSODRUG,ANQDATA,LSI,C,MAX,MIN,NDF,REF,SIG,SER,PSOFLAG,PSOHI,PSOLO,PSONOOR,PSOCOUU,PSOCOU,PSORX("EDIT") - D CLEAN^PSOVER1 - K ^TMP("PSORXDC",$J),RORD,ACOM,ACNT,CRIT,DEF,F1,GG,I1,IEN,INDT,LAST,MSG,NIEN,STA,DUR,DRET,PSOPRC - S RXN=$O(^TMP("PSORXN",$J,0)) I RXN D - .S RXN1=^TMP("PSORXN",$J,RXN) D EN^PSOHLSN1(RXN,$P(RXN1,"^"),$P(RXN1,"^",2),"",$P(RXN1,"^",3)) - .I $P(^PSRX(RXN,"STA"),"^")=5 D EN^PSOHLSN1(RXN,"SC","ZS","") - K RXN,RXN1,^TMP("PSORXN",$J) - I $G(PSONOTE) D FULL^VALM1,MAIN^TIUEDIT(3,.TIUDA,PSODFN,"","","","",1) - K PSONOTE - Q -NOOR ;asks nature of order - N PSONOODF - S PSONOODF=0 - I $G(OR0) D G NOORX ;front door - .S PSOI=$S($G(PSOSIGFL):1,$G(PSODRUG("OI"))'=$P(OR0,"^",8):1,1:0) I 'PSOI S PSONOOR="" D:$D(^XUSEC("PSORPH",DUZ)) COUN Q ;NoO $P(OR0,"^",7) - .S PSONOODF=1 - .D DIR I $D(DIRUT) S PSONEW("DFLG")=1 Q - .S PSONOOR=Y D:$D(^XUSEC("PSORPH",DUZ)) COUN K DIR,DTOUT,DTOUT,DIRUT - ;backdoor order - D DIR I $D(DIRUT) S PSONEW("DFLG")=1 Q - S PSONOOR=Y K DIK,DA,DIE,DR,PSOI,DIR,DUOUT,DTOUT,DIRUT - G:'$D(^XUSEC("PSORPH",DUZ)) NOORX -COUN ;patient counseling - G:$G(PSORX("EDIT"))&('$G(PSOSIGFL)) NOORX K DIR,DUOUT,DTOUT,DIRUT - S DIR("B")="NO",DIR(0)="52,41" D ^DIR S PSOCOU=$S(Y:Y,1:0) - I $D(DIRUT)!('PSOCOU) S PSOCOUU=0 D:'$G(SPEED) PRONTE Q - K:'$G(PSOCOU) PSOCOUU K DIR,DUOUT,DTOUT,DIRUT I Y S DIR(0)="52,42",DIR("B")="NO" D ^DIR S PSOCOUU=$S(Y:Y,1:0) -PRONTE K PSONOTE,DIR,DIRUT,DUOUT - I $T(MAIN^TIUEDIT)]"",'$G(SPEED) D K DIR,DIRUT,DUOUT - .S DIR(0)="Y",DIR("B")="No",DIR("A")="Do you want to enter a Progress Note",DIR("A",1)="" D ^DIR K DIR - .S PSONOTE=+Y Q ;I 'Y!($D(DIRUT)) Q -NOORX K X,Y,DIR,DUOUT,DTOUT,DIRUT - Q -DIR ;ask nature of order - K DIR,DTOUT,DTOUT,DIRUT I $T(NA^ORX1)]"" D Q - .S PSONOOR=$$NA^ORX1($S($G(PSONOODF)!($G(PSONOBCK)):"S",1:"W"),0,"B","Nature of Order",0,"WPSDIVR"_$S(+$G(^VA(200,DUZ,"PS")):"E",1:"")) - .I +PSONOOR S (Y,PSONOOR)=$P(PSONOOR,"^",3) Q - .S DIRUT=1 K PSONOOR - I $D(PSONOOR) S DF=PSONOOR,PSONODF=$S(DF="E":"PROVIDER ENTERED",DF="V":"VERBAL",DF="P":"TELEPHONE",DF="D":"DUPLICATE",DF="S":"SERVICE CORRECTED",DF="I":"POLICY",DF="R":"SERVICE REJECTED",1:"WRITTEN") - K DIR,DTOUT,DTOUT,DIRUT S DIR("A")="Nature of Order: ",DIR("B")=$S($D(PSONOOR):PSONODF,1:"WRITTEN") - S DIR(0)="SA^W:WRITTEN;V:VERBAL;P:TELEPHONE;S:SERVICE CORRECTED;D:DUPLICATE;I:POLICY;R:SERVICE REJECTED"_$S(+$G(^VA(200,DUZ,"PS")):";E:PROVIDER ENTERED",1:"") - D ^DIR K DF,PSONODF Q:$D(DIRUT) S PSONOOR=Y -DIRX Q - ; -NOORE(PSONEW) ;entry point for renew - D NOOR I $D(DIRUT) S PSONEW("DFLG")=1 Q - S PSONEW("NOO")=PSONOOR - Q +PSONEW ;BIR/SAB-new rx order main driver ; 11/5/06 6:35pm + ;;7.0;OUTPATIENT PHARMACY;**11,27,32,46,94,130,268,208**;DEC 1997;Build 39 + ; 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 + ;External references L and UL^PSSLOCK supported by DBIA 2789 + ;External reference to ^VA(200 supported by DBIA 224 + ;External reference to ^XUSEC supported by DBIA 10076 + ;External reference to ^ORX1 supported by DBIA 2186 + ;External reference to ^ORX2 supported by DBIA 867 + ;External reference to ^TIUEDIT supported by DBIA 2410 + ;--------------------------------------------------------------- +OERR ;backdoor new rx for v7 + K PSOREEDT,COPY,SPEED,PSOEDIT,DUR,DRET + S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.") K PSOPLCK S VALMBCK="" Q + K PSOPLCK S X=PSODFN_";DPT(" D LK^ORX2 I 'Y S VALMSG="Another person is entering orders for this patient.",VALMBCK="" D UL^PSSLOCK(PSODFN) Q +AGAIN N VALMCNT K PSODRUG,PSOCOU,PSOCOUU,PSONOOR,PSORX("FN") W ! D HLDHDR^PSOLMUTL S (PSONEW("QFLG"),PSONEW("DFLG"))=0,PSOFROM="NEW",PSONOEDT=1 + K ORD D FULL^VALM1,^PSONEW1 ; Continue order entry + I PSONEW("QFLG") G END + I PSONEW("DFLG") W !,$C(7),"RX DELETED",! S:$G(POERR) POERR("DFLG")=1,VALMBCK="Q" G END + D:$P($G(PSOPAR),"^",7)=1 AUTO^PSONRXN I $P($G(PSOPAR),"^",7)'=1 S PSOX=PSONEW("RX #") D CHECK^PSONRXN + I PSONEW("DFLG")!PSONEW("QFLG") D DEL S:$G(POERR) POERR("DFLG")=1,VALMBCK="R" G END + D NOOR I PSONEW("DFLG") D DEL G END + D ^PSONEW2 I PSONEW("DFLG") D DEL S:$G(POERR) POERR("DFLG")=1,VALMBCK="R" G END ; Asks if correct + G:$G(PSORX("FN")) END + D EN^PSON52(.PSONEW) ; Files entry in File 52 + D NPSOSD^PSOUTIL(.PSONEW) ; Adds newly added rx to PSOSD array + S VALMBCK="R" +END D EOJ ; Clean up + I '$G(PSORX("FN")) W ! K DIR,DIRUT,DUOUT,DTOUT S DIR(0)="Y",DIR("B")="YES",DIR("A")="Another New Order for "_PSORX("NAME") D ^DIR K DIR,DIRUT,DUOUT,DTOUT I Y K PSONEW,PSDRUG,ORD G AGAIN + D ^PSOBUILD,BLD^PSOORUT1 S X=PSODFN_";DPT(" D ULK^ORX2 D UL^PSSLOCK(PSODFN) + S VALMBCK="R" K PSORX("FN") Q + ;---------------------------------------------------------------- +DEL ; + W !,$C(7),"RX DELETED",! + I $P($G(PSOPAR),"^",7)=1 D + . S DIE="^PS(59,",DA=PSOSITE,PSOY=$O(PSONEW("OLD LAST RX#","")) + . S PSOX=PSONEW("OLD LAST RX#",PSOY) + . L +^PS(59,+PSOSITE,PSOY):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) + . S DR=$S(PSOY=8:"2003////"_PSOX,PSOY=3:"1002.1////"_PSOX,1:"2003////"_PSOX) + . D:PSOX<$P(^PS(59,+PSOSITE,PSOY),"^",3) ^DIE K DIE,X,Y + . L -^PS(59,+PSOSITE,PSOY) + . K PSOX,PSOY Q +EOJ ; + I $D(PSONEW("RX #")) L -^PSRX("B",PSONEW("RX #")) ; +Lock set in PSONRXN + K PSONOEDT,PSONEW,PSODRUG,ANQDATA,LSI,C,MAX,MIN,NDF,REF,SIG,SER,PSOFLAG,PSOHI,PSOLO,PSONOOR,PSOCOUU,PSOCOU,PSORX("EDIT") + D CLEAN^PSOVER1 + K ^TMP("PSORXDC",$J),RORD,ACOM,ACNT,CRIT,DEF,F1,GG,I1,IEN,INDT,LAST,MSG,NIEN,STA,DUR,DRET,PSOPRC + S RXN=$O(^TMP("PSORXN",$J,0)) I RXN D + .S RXN1=^TMP("PSORXN",$J,RXN) D EN^PSOHLSN1(RXN,$P(RXN1,"^"),$P(RXN1,"^",2),"",$P(RXN1,"^",3)) + .I $P(^PSRX(RXN,"STA"),"^")=5 D EN^PSOHLSN1(RXN,"SC","ZS","") + K RXN,RXN1,^TMP("PSORXN",$J) + I $G(PSONOTE) D FULL^VALM1,MAIN^TIUEDIT(3,.TIUDA,PSODFN,"","","","",1) + K PSONOTE + Q +NOOR ;asks nature of order + N PSONOODF + S PSONOODF=0 + I $G(OR0) D G NOORX ;front door + .S PSOI=$S($G(PSOSIGFL):1,$G(PSODRUG("OI"))'=$P(OR0,"^",8):1,1:0) I 'PSOI S PSONOOR="" D:$D(^XUSEC("PSORPH",DUZ)) COUN Q ;NoO $P(OR0,"^",7) + .S PSONOODF=1 + .D DIR I $D(DIRUT) S PSONEW("DFLG")=1 Q + .S PSONOOR=Y D:$D(^XUSEC("PSORPH",DUZ)) COUN K DIR,DTOUT,DTOUT,DIRUT + ;backdoor order + D DIR I $D(DIRUT) S PSONEW("DFLG")=1 Q + S PSONOOR=Y K DIK,DA,DIE,DR,PSOI,DIR,DUOUT,DTOUT,DIRUT + G:'$D(^XUSEC("PSORPH",DUZ)) NOORX +COUN ;patient counseling + G:$G(PSORX("EDIT"))&('$G(PSOSIGFL)) NOORX K DIR,DUOUT,DTOUT,DIRUT + I $G(PSOAFYN)'="Y" S DIR("B")="NO",DIR(0)="52,41" D ^DIR S PSOCOU=$S(Y:Y,1:0) ;vfam + I $G(PSOAFYN)="Y" S PSOCOU=0 ;vfam No Patient Counseling by AutoFinihs + I $D(DIRUT)!('PSOCOU) S PSOCOUU=0 D:'$G(SPEED) PRONTE Q + K:'$G(PSOCOU) PSOCOUU K DIR,DUOUT,DTOUT,DIRUT I Y S DIR(0)="52,42",DIR("B")="NO" D ^DIR S PSOCOUU=$S(Y:Y,1:0) +PRONTE K PSONOTE,DIR,DIRUT,DUOUT + I $T(MAIN^TIUEDIT)]"",'$G(SPEED) D K DIR,DIRUT,DUOUT + .I $G(PSOAFYN)'="Y" S DIR(0)="Y",DIR("B")="No",DIR("A")="Do you want to enter a Progress Note",DIR("A",1)="" D ^DIR K DIR ;vfam + .I $G(PSOAFYN)="Y" S Y="0" ;vfam No Progress Notes in AutoFinish + .S PSONOTE=+Y Q ;I 'Y!($D(DIRUT)) Q +NOORX K X,Y,DIR,DUOUT,DTOUT,DIRUT + Q +DIR ;ask nature of order + K DIR,DTOUT,DTOUT,DIRUT I $T(NA^ORX1)]"" D Q + .S PSONOOR=$$NA^ORX1($S($G(PSONOODF)!($G(PSONOBCK)):"S",1:"W"),0,"B","Nature of Order",0,"WPSDIVR"_$S(+$G(^VA(200,DUZ,"PS")):"E",1:"")) + .I +PSONOOR S (Y,PSONOOR)=$P(PSONOOR,"^",3) Q + .S DIRUT=1 K PSONOOR + I $D(PSONOOR) S DF=PSONOOR,PSONODF=$S(DF="E":"PROVIDER ENTERED",DF="V":"VERBAL",DF="P":"TELEPHONE",DF="D":"DUPLICATE",DF="S":"SERVICE CORRECTED",DF="I":"POLICY",DF="R":"SERVICE REJECTED",1:"WRITTEN") + K DIR,DTOUT,DTOUT,DIRUT S DIR("A")="Nature of Order: ",DIR("B")=$S($D(PSONOOR):PSONODF,1:"WRITTEN") + S DIR(0)="SA^W:WRITTEN;V:VERBAL;P:TELEPHONE;S:SERVICE CORRECTED;D:DUPLICATE;I:POLICY;R:SERVICE REJECTED"_$S(+$G(^VA(200,DUZ,"PS")):";E:PROVIDER ENTERED",1:"") + D ^DIR K DF,PSONODF Q:$D(DIRUT) S PSONOOR=Y +DIRX Q + ; +NOORE(PSONEW) ;entry point for renew + D NOOR I $D(DIRUT) S PSONEW("DFLG")=1 Q + S PSONEW("NOO")=PSONOOR + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSONEW2.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSONEW2.m index 9c96e943..d30303d8 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSONEW2.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSONEW2.m @@ -1,123 +1,122 @@ -PSONEW2 ;BIR/DSD - displays new rx information for edit ;7/17/06 6:59pm - ;;7.0;OUTPATIENT PHARMACY;**32,37,46,71,94,124,139,157,143,226,237,239,225**;DEC 1997;Build 29 - ;External reference to ^PSDRUG supported by DBIA 221 - ;External reference to ^DPT supported by DBIA 10035 - ;External reference to PSOUL^PSSLOCK supported by DBIA 2789 - ;External reference VADPT supported by DBIA 10061 - ; This routine displays the entered new rx information and - ; asks if correct, if not allows editing of the data. - ;------------------------------------------------------------ - ;PSO*237 issue expired error message - ; -START ; - S (PSONEW("DFLG"),PSONEW2("QFLG"))=0 - D STOP - D DISPLAY ; Displays information - ;Copay exemption checks - D SCP^PSORN52D - S PSONEWFF=1,PSOFLAG=1 K PSOANSQ,PSOANSQD S PSOCPZ("DFLG")=0,PSONEW("NEWCOPAY")=0 - ;can't check PSOSCA for <50 here because of PSOBILL check in PSOCPB - I (PSOSCP<50&($P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)'=1)),$G(DUZ("AG"))="V" D COPAY^PSOCPB W ! - I PSOSCA&(PSOSCP>49)!((PSOSCA!(PSOBILL=2))&($P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)=1))!(PSOSCP>49&(PSOBILL=2)) D SC^PSOMLLD2 - I $G(PSOCPZ("DFLG")) K PSONEWFF,PSOANSQD,PSOCPZ("DFLG"),PSONEW("NEWCOPAY") S DIRUT="",PSONEW("DFLG")=1 D ASKX G END - ;IF MILL BILL, AND COPAY (*******TEST THE COPAY CHECK) - I $$DT^PSOMLLDT D I $G(PSOCPZ("DFLG")) K PSONEWFF,PSOANSQD,PSOANSQ,PSOCPZ("DFLG"),PSONEW("NEWCOPAY") S DIRUT="",PSONEW("DFLG")=1 D ASKX G END - .;New prompts Quit after first '^' - .I $D(PSOIBQS(PSODFN,"CV")) D CV^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("CV"))) K PSONEW("NEWCOPAY") - .I $D(PSOIBQS(PSODFN,"VEH")) D VEH^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("VEH"))) K PSONEW("NEWCOPAY") - .I $D(PSOIBQS(PSODFN,"RAD")) D RAD^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("RAD"))) K PSONEW("NEWCOPAY") - .I $D(PSOIBQS(PSODFN,"PGW")) D PGW^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("PGW"))) K PSONEW("NEWCOPAY") - .I $D(PSOIBQS(PSODFN,"SHAD")) D SHAD^PSOMLLD2 I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("SHAD"))) K PSONEW("NEWCOPAY") - .I $D(PSOIBQS(PSODFN,"MST")) D MST^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("MST"))) K PSONEW("NEWCOPAY") - .I $D(PSOIBQS(PSODFN,"HNC")) D HNC^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("HNC"))) K PSONEW("NEWCOPAY") - K PSOCPZ("DFLG"),PSONEWFF - D ASK K:$G(PSONEW("DFLG")) PSOANSQ G:PSONEW2("QFLG")!PSONEW("DFLG") END - S PSORX("EDIT")=1 D EN^PSOORNE1(.PSONEW),FULL^VALM1 G:$G(PSORX("FN")) END I '$G(PSORX("FN")) S PSONEW("DFLG")=1 K PSOANSQ G END ;D EDIT - G:'$G(PSONEW("DFLG")) START - S PSONEW("QFLG")=1,PSONEW("DFLG")=0 -END D EOJ - Q - ;------------------------------------------------------------ -STOP K PSEXDT,X,%DT S PSON52("QFLG")=0 - S X1=PSOID,X2=PSONEW("DAYS SUPPLY")*(PSONEW("# OF REFILLS")+1)\1 - S X2=$S(PSONEW("DAYS SUPPLY")=X2:X2,+$G(PSONEW("CS")):184,1:366) - I X2<30 D - . N % S %=$P($G(PSORX("PATIENT STATUS")),"^"),X2=30 - . S:%?.N %=$P($G(^PS(53,+%,0)),"^") I %["AUTH ABS" S X2=5 - D C^%DTC I PSONEW("FILL DATE")>$P(X,".") S PSEXDT=1_"^"_$P(X,".") - K X1,X2,X,%DT - Q -DISPLAY ; - W !!,"Rx # ",PSONEW("RX #") - W ?23,$E(PSONEW("FILL DATE"),4,5),"/",$E(PSONEW("FILL DATE"),6,7),"/",$E(PSONEW("FILL DATE"),2,3),!,$G(PSORX("NAME")),?30,"#",PSONEW("QTY") - I $G(SIGOK),$O(SIG(0)) D K D G TRN - .F D=0:0 S D=$O(SIG(D)) W !,SIG(D) Q:'$O(SIG(D)) - E S X=PSONEW("SIG") D SIGONE^PSOHELP W !,$G(INS1) -TRN ;I $G(PSOPRC) F I=0:0 S I=$O(PRC(I)) Q:'I W !,PRC(I) - W !!,$S($G(PSODRUG("TRADE NAME"))]"":PSODRUG("TRADE NAME"),1:PSODRUG("NAME")) - W !,PSONEW("PROVIDER NAME"),?25,PSORX("CLERK CODE"),!,"# of Refills: ",PSONEW("# OF REFILLS"),! - Q - ; -ASK ; - K DIR,X,Y S DIR("A")="Is this correct" - S DIR(0)="Y",DIR("B")="YES" D ^DIR K DIR I $D(DIRUT) S PSONEW("DFLG")=1 G ASKX -ASK1 I Y D S PSONEW2("QFLG")=1 - .S:$G(PSONEW("MAIL/WINDOW"))["W" BINGCRT=Y,BINGRTE="W" - .D:+$G(PSEXDT) - ..S Y=PSONEW("FILL DATE") X ^DD("DD") W !!,$C(7),Y_" fill date is greater than possible expiration date of " S Y=$P(PSEXDT,"^",2) X ^DD("DD") W Y_"." - .D DCORD K RORD,^TMP("PSORXDC",$J) -ASKX I $D(DIRUT) D - .I +$G(PSEXDT) K DIRUT S (PSONEW2("QFLG"),PSONEW2("DFLG"),PSONEW("DFLG"),Y)=1 - K X,Y,DIRUT,DTOUT,DUOUT - D:+$G(PSEXDT) PAUSE^VALM1 - Q -DCORD ;dc rxs and pending orders after new order is entered - F RORD=0:0 S RORD=$O(^TMP("PSORXDC",$J,RORD)) Q:'RORD D @$S($P(^TMP("PSORXDC",$J,RORD,0),"^")="P":"PEN",1:"RX52") - K RORD - Q -PEN ;pending ^tmp("psorxdc",$j,rord,0)="p^"_rord_"^"_msg - S $P(^PS(52.41,RORD,0),"^",3)="DC",^PS(52.41,RORD,4)=$P(^TMP("PSORXDC",$J,RORD,0),"^",3) - K ^PS(52.41,"AOR",PSODFN,+$P($G(^PS(52.41,RORD,"INI")),"^"),RORD) - D EN^PSOHLSN($P(^PS(52.41,RORD,0),"^"),"OC",$P(^TMP("PSORXDC",$J,RORD,0),"^",3),"D") W $C(7),!," -Pending Order was discontinued..." - D PSOUL^PSSLOCK(RORD_"S") K ^TMP("PSORXDC",$J,RORD,0) - Q -RX52 ;rxs in file 52 ^tmp("psorxdc",$j,rord,0)=52^rord^msg^rea^act^sta^dnm - S PSCAN($P(^PSRX(RORD,0),"^"))=RORD_"^"_$P(^TMP("PSORXDC",$J,RORD,0),"^",4) - S MSG=$P(^TMP("PSORXDC",$J,RORD,0),"^",3),REA=$P(^(0),"^",4),ACT=$P(^(0),"^",5) - N PSONOOR S PSONOOR="D",DUP=1,DA=RORD D CAN^PSOCAN K PSONOOR - W !," -Rx "_$P(^PSRX(RORD,0),"^")_" has been discontinued...",! - K PSOSD($P(^TMP("PSORXDC",$J,RORD,0),"^",6),$P(^TMP("PSORXDC",$J,RORD,0),"^",7)) - D PSOUL^PSSLOCK(RORD) K ^TMP("PSORXDC",$J,RORD,0) - Q - ; -EDIT ; - S PSORX("EDIT")=1 - D ^PSONEW3 - S PSONEW("DFLG")=$S($G(PSORX("DFLG")):1,1:0) - Q - ; -EOJ ; - K PSONEW2,PSORX("EDIT"),PSORX("DFLG"),PSOEDIT,PSOSCA - Q - ; -EN1(PSONEW2) ; Entry point to just display and ask if okay - S PSONEW("DFLG")=0 - I $G(^PSRX(PSONEW2("IRXN"),0))']"" S PSONEW("DFLG")=1 G EN1X - S PSOX=^PSRX(PSONEW2("IRXN"),0),PSONEW("TRADE NAME")=$G(^("TN")),PSONEW("FILL DATE")=$P($G(^(2)),"^",2) - S PSONEW("RX #")=$P(PSOX,"^"),PSORX("NAME")=$P(^DPT($P(PSOX,"^",2),0),"^") - S PSONEW("QTY")=$P(PSOX,"^",7),PSODRUG("NAME")=$P(^PSDRUG($P(PSOX,"^",6),0),"^"),PSONEW("# OF REFILLS")=$P(PSOX,"^",9) - S PSORX("CLERK CODE")=$P(^VA(200,$P(PSOX,"^",16),0),"^") - S:$G(PSONEW("PROVIDER NAME"))="" PSONEW("PROVIDER NAME")=$P(^VA(200,$P(PSOX,"^",4),0),"^") - S PSONEW("SIG")=$P($G(^PSRX(PSONEW2("IRXN"),"SIG")),"^") - D DISPLAY - D ASK - I PSONEW("DFLG")=1 S PSONEW2("DFLG")=1 -EN1X ; - Q - ; -EXPR ;Display Expired error message ;PSO*237 - S PSONEW("DFLG")=1 - W $C(7) - S VALMSG="Order is older than 365 days and can't be finished" - S XQORM("B")="DC" - Q +PSONEW2 ;BIR/DSD - displays new rx information for edit ;7/17/06 6:59pm + ;;7.0;OUTPATIENT PHARMACY;**32,37,46,71,94,124,139,157,143,226,237,239**;DEC 1997 + ;External reference to ^PSDRUG supported by DBIA 221 + ;External reference to ^DPT supported by DBIA 10035 + ;External reference to PSOUL^PSSLOCK supported by DBIA 2789 + ;External reference VADPT supported by DBIA 10061 + ; This routine displays the entered new rx information and + ; asks if correct, if not allows editing of the data. + ;------------------------------------------------------------ + ;PSO*237 issue expired error message + ; +START ; + S (PSONEW("DFLG"),PSONEW2("QFLG"))=0 + D STOP + D DISPLAY ; Displays information + ;Copay exemption checks + D SCP^PSORN52D + S PSONEWFF=1,PSOFLAG=1 K PSOANSQ,PSOANSQD S PSOCPZ("DFLG")=0,PSONEW("NEWCOPAY")=0 + ;can't check PSOSCA for <50 here because of PSOBILL check in PSOCPB + I (PSOSCP<50&($P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)'=1)),$G(DUZ("AG"))="V" D COPAY^PSOCPB W ! + I PSOSCA&(PSOSCP>49)!((PSOSCA!(PSOBILL=2))&($P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)=1))!(PSOSCP>49&(PSOBILL=2)) D SC^PSOMLLD2 + I $G(PSOCPZ("DFLG")) K PSONEWFF,PSOANSQD,PSOCPZ("DFLG"),PSONEW("NEWCOPAY") S DIRUT="",PSONEW("DFLG")=1 D ASKX G END + ;IF MILL BILL, AND COPAY (*******TEST THE COPAY CHECK) + I $$DT^PSOMLLDT D I $G(PSOCPZ("DFLG")) K PSONEWFF,PSOANSQD,PSOANSQ,PSOCPZ("DFLG"),PSONEW("NEWCOPAY") S DIRUT="",PSONEW("DFLG")=1 D ASKX G END + .;New prompts Quit after first '^' + .I $D(PSOIBQS(PSODFN,"CV")) D CV^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("CV"))) K PSONEW("NEWCOPAY") + .I $D(PSOIBQS(PSODFN,"VEH")) D VEH^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("VEH"))) K PSONEW("NEWCOPAY") + .I $D(PSOIBQS(PSODFN,"RAD")) D RAD^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("RAD"))) K PSONEW("NEWCOPAY") + .I $D(PSOIBQS(PSODFN,"PGW")) D PGW^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("PGW"))) K PSONEW("NEWCOPAY") + .I $D(PSOIBQS(PSODFN,"MST")) D MST^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("MST"))) K PSONEW("NEWCOPAY") + .I $D(PSOIBQS(PSODFN,"HNC")) D HNC^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("HNC"))) K PSONEW("NEWCOPAY") + K PSOCPZ("DFLG"),PSONEWFF + D ASK K:$G(PSONEW("DFLG")) PSOANSQ G:PSONEW2("QFLG")!PSONEW("DFLG") END + S PSORX("EDIT")=1 D EN^PSOORNE1(.PSONEW),FULL^VALM1 G:$G(PSORX("FN")) END I '$G(PSORX("FN")) S PSONEW("DFLG")=1 K PSOANSQ G END ;D EDIT + G:'$G(PSONEW("DFLG")) START + S PSONEW("QFLG")=1,PSONEW("DFLG")=0 +END D EOJ + Q + ;------------------------------------------------------------ +STOP K PSEXDT,X,%DT S PSON52("QFLG")=0 + S X1=PSOID,X2=PSONEW("DAYS SUPPLY")*(PSONEW("# OF REFILLS")+1)\1 + S X2=$S(PSONEW("DAYS SUPPLY")=X2:X2,+$G(PSONEW("CS")):184,1:366) + I X2<30 D + . N % S %=$P($G(PSORX("PATIENT STATUS")),"^"),X2=30 + . S:%?.N %=$P($G(^PS(53,+%,0)),"^") I %["AUTH ABS" S X2=5 + D C^%DTC I PSONEW("FILL DATE")>$P(X,".") S PSEXDT=1_"^"_$P(X,".") + K X1,X2,X,%DT + Q +DISPLAY ; + W !!,"Rx # ",PSONEW("RX #") + W ?23,$E(PSONEW("FILL DATE"),4,5),"/",$E(PSONEW("FILL DATE"),6,7),"/",$E(PSONEW("FILL DATE"),2,3),!,$G(PSORX("NAME")),?30,"#",PSONEW("QTY") + I $G(SIGOK),$O(SIG(0)) D K D G TRN + .F D=0:0 S D=$O(SIG(D)) W !,SIG(D) Q:'$O(SIG(D)) + E S X=PSONEW("SIG") D SIGONE^PSOHELP W !,$G(INS1) +TRN ;I $G(PSOPRC) F I=0:0 S I=$O(PRC(I)) Q:'I W !,PRC(I) + W !!,$S($G(PSODRUG("TRADE NAME"))]"":PSODRUG("TRADE NAME"),1:PSODRUG("NAME")) + W !,PSONEW("PROVIDER NAME"),?25,PSORX("CLERK CODE"),!,"# of Refills: ",PSONEW("# OF REFILLS"),! + Q + ; +ASK ; + K DIR,X,Y S DIR("A")="Is this correct" + S DIR(0)="Y",DIR("B")="YES" D ^DIR K DIR I $D(DIRUT) S PSONEW("DFLG")=1 G ASKX +ASK1 I Y D S PSONEW2("QFLG")=1 + .S:$G(PSONEW("MAIL/WINDOW"))["W" BINGCRT=Y,BINGRTE="W" + .D:+$G(PSEXDT) + ..S Y=PSONEW("FILL DATE") X ^DD("DD") W !!,$C(7),Y_" fill date is greater than possible expiration date of " S Y=$P(PSEXDT,"^",2) X ^DD("DD") W Y_"." + .D DCORD K RORD,^TMP("PSORXDC",$J) +ASKX I $D(DIRUT) D + .I +$G(PSEXDT) K DIRUT S (PSONEW2("QFLG"),PSONEW2("DFLG"),PSONEW("DFLG"),Y)=1 + K X,Y,DIRUT,DTOUT,DUOUT + D:+$G(PSEXDT) PAUSE^VALM1 + Q +DCORD ;dc rxs and pending orders after new order is entered + F RORD=0:0 S RORD=$O(^TMP("PSORXDC",$J,RORD)) Q:'RORD D @$S($P(^TMP("PSORXDC",$J,RORD,0),"^")="P":"PEN",1:"RX52") + K RORD + Q +PEN ;pending ^tmp("psorxdc",$j,rord,0)="p^"_rord_"^"_msg + S $P(^PS(52.41,RORD,0),"^",3)="DC",^PS(52.41,RORD,4)=$P(^TMP("PSORXDC",$J,RORD,0),"^",3) + K ^PS(52.41,"AOR",PSODFN,+$P($G(^PS(52.41,RORD,"INI")),"^"),RORD) + D EN^PSOHLSN($P(^PS(52.41,RORD,0),"^"),"OC",$P(^TMP("PSORXDC",$J,RORD,0),"^",3),"D") W $C(7),!," -Pending Order was discontinued..." + D PSOUL^PSSLOCK(RORD_"S") K ^TMP("PSORXDC",$J,RORD,0) + Q +RX52 ;rxs in file 52 ^tmp("psorxdc",$j,rord,0)=52^rord^msg^rea^act^sta^dnm + S PSCAN($P(^PSRX(RORD,0),"^"))=RORD_"^"_$P(^TMP("PSORXDC",$J,RORD,0),"^",4) + S MSG=$P(^TMP("PSORXDC",$J,RORD,0),"^",3),REA=$P(^(0),"^",4),ACT=$P(^(0),"^",5) + N PSONOOR S PSONOOR="D",DUP=1,DA=RORD D CAN^PSOCAN K PSONOOR + W !," -Rx "_$P(^PSRX(RORD,0),"^")_" has been discontinued...",! + K PSOSD($P(^TMP("PSORXDC",$J,RORD,0),"^",6),$P(^TMP("PSORXDC",$J,RORD,0),"^",7)) + D PSOUL^PSSLOCK(RORD) K ^TMP("PSORXDC",$J,RORD,0) + Q + ; +EDIT ; + S PSORX("EDIT")=1 + D ^PSONEW3 + S PSONEW("DFLG")=$S($G(PSORX("DFLG")):1,1:0) + Q + ; +EOJ ; + K PSONEW2,PSORX("EDIT"),PSORX("DFLG"),PSOEDIT,PSOSCA + Q + ; +EN1(PSONEW2) ; Entry point to just display and ask if okay + S PSONEW("DFLG")=0 + I $G(^PSRX(PSONEW2("IRXN"),0))']"" S PSONEW("DFLG")=1 G EN1X + S PSOX=^PSRX(PSONEW2("IRXN"),0),PSONEW("TRADE NAME")=$G(^("TN")),PSONEW("FILL DATE")=$P($G(^(2)),"^",2) + S PSONEW("RX #")=$P(PSOX,"^"),PSORX("NAME")=$P(^DPT($P(PSOX,"^",2),0),"^") + S PSONEW("QTY")=$P(PSOX,"^",7),PSODRUG("NAME")=$P(^PSDRUG($P(PSOX,"^",6),0),"^"),PSONEW("# OF REFILLS")=$P(PSOX,"^",9) + S PSORX("CLERK CODE")=$P(^VA(200,$P(PSOX,"^",16),0),"^") + S:$G(PSONEW("PROVIDER NAME"))="" PSONEW("PROVIDER NAME")=$P(^VA(200,$P(PSOX,"^",4),0),"^") + S PSONEW("SIG")=$P($G(^PSRX(PSONEW2("IRXN"),"SIG")),"^") + D DISPLAY + D ASK + I PSONEW("DFLG")=1 S PSONEW2("DFLG")=1 +EN1X ; + Q + ; +EXPR ;Display Expired error message ;PSO*237 + S PSONEW("DFLG")=1 + W $C(7) + S VALMSG="Order is older than 365 days and can't be finished" + S XQORM("B")="DC" + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSONEWF.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSONEWF.m index 868f1ccc..fde39827 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSONEWF.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSONEWF.m @@ -1,101 +1,116 @@ -PSONEWF ;BIR/RTR - Copay finish questions ;07/26/96 - ;;7.0;OUTPATIENT PHARMACY;**71,157,143,219,226,239,225**;DEC 1997;Build 29 - ;External reference VADPT supported by DBIA 10061 -START ; - N PSOPENIB,PSOSCOTH,PSOSCOTX,PSOMESFI - S PSOPENIB=$S($G(ORD):$G(^PS(52.41,+$G(ORD),"IBQ")),1:"") - ;set PSOSCOTH for display of Provider Copay intent, used with PSORX(SC) - S PSOSCOTH=0 I $P(PSOPENIB,"^")=1!($P(PSOPENIB,"^",2)=1)!($P(PSOPENIB,"^",3)=1)!($P(PSOPENIB,"^",4)=1)!($P(PSOPENIB,"^",5)=1)!($P(PSOPENIB,"^",6)=1)!($P(PSOPENIB,"^",7)=1) S PSOSCOTH=1 - S PSOSCOTX=0 I $G(PSOSCOTH)!($G(PSORX("SC"))="SC")!($G(PSORX("SC"))="NSC") S PSOSCOTX=1 - ;Check for Orderable Item change to display message - S PSOMESFI=0 I $G(OR0),$G(PSODRUG("OI")) D - .I $G(PSODRUG("OI"))'=$P($G(OR0),"^",8) S PSOMESFI=1 - S PSONEWFF=1,PSOFLAG=1 - ;Copay exemption checks - D SCP^PSORN52D - K PSOANSQ D SET S PSOCPZ("DFLG")=0,PSONEW("NEWCOPAY")=0 - I (PSOSCP<50)&($P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)'=1),$G(DUZ("AG"))="V" D COPAY^PSOCPB W ! - I $G(PSOCPZ("DFLG")) K PSONEW("NEWCOPAY"),PSONEWFF,PSOSCOTH,PSOSCOTX,PSOMESFI Q - I PSOSCA&(PSOSCP>49)!((PSOSCA!(PSOBILL=2))&($P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)=1))!(PSOSCP>49&(PSOBILL=2)) D I $G(PSOCPZ("DFLG")) K PSOANSQ,PSONEW("NEWCOPAY"),PSONEWFF,PSOSCOTH,PSOSCOTX,PSOMESFI Q - . I PSOSCP<50 D MESS S:PSOSCP<50 PSOANSQD("SC>50")=$G(PSOANSQD("SC")) - . D SC^PSOMLLD2 - . I PSOSCP<50&($D(PSOANSQD("SC"))) S PSOANSQD("SC")=PSOANSQD("SC>50") K PSOANSQD("SC") - ;IF MILL BILL, AND COPAY (*******TEST THE COPAY CHECK) - I $$DT^PSOMLLDT D I $G(PSOCPZ("DFLG")) K PSOANSQ,PSONEW("NEWCOPAY"),PSONEWFF,PSOSCOTH,PSOSCOTX,PSOMESFI Q - .;New prompts Quit after first '^' - .I $D(PSOIBQS(PSODFN,"CV")) D D MESSOI,MESS D CV^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("CV"))) K PSONEW("NEWCOPAY") - ..I '$D(PSOANSQD("CV")),($P(PSOPENIB,"^",6)=0!($P(PSOPENIB,"^",6)=1)) S PSOANSQD("CV")=$P(PSOPENIB,"^",6) - .I $D(PSOIBQS(PSODFN,"VEH")) D D MESSOI,MESS D VEH^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("VEH"))) K PSONEW("NEWCOPAY") - ..I '$D(PSOANSQD("VEH")),($P(PSOPENIB,"^",2)=0!($P(PSOPENIB,"^",2)=1)) S PSOANSQD("VEH")=$P(PSOPENIB,"^",2) - .I $D(PSOIBQS(PSODFN,"RAD")) D D MESSOI,MESS D RAD^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("RAD"))) K PSONEW("NEWCOPAY") - ..I '$D(PSOANSQD("RAD")),($P(PSOPENIB,"^",3)=0!($P(PSOPENIB,"^",3)=1)) S PSOANSQD("RAD")=$P(PSOPENIB,"^",3) - .I $D(PSOIBQS(PSODFN,"PGW")) D D MESSOI,MESS D PGW^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("PGW"))) K PSONEW("NEWCOPAY") - ..I '$D(PSOANSQD("PGW")),($P(PSOPENIB,"^",4)=0!($P(PSOPENIB,"^",4)=1)) S PSOANSQD("PGW")=$P(PSOPENIB,"^",4) - .I $D(PSOIBQS(PSODFN,"SHAD")) D D MESSOI,MESS D SHAD^PSOMLLD2 I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("SHAD"))) K PSONEW("NEWCOPAY") - ..I '$D(PSOANSQD("SHAD")),($P(PSOPENIB,"^",7)=0!($P(PSOPENIB,"^",7)=1)) S PSOANSQD("SHAD")=$P(PSOPENIB,"^",7) - .I $D(PSOIBQS(PSODFN,"MST")) D D MESSOI,MESS D MST^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("MST"))) K PSONEW("NEWCOPAY") - ..I '$D(PSOANSQD("MST")),($P(PSOPENIB,"^")=0!($P(PSOPENIB,"^")=1)) S PSOANSQD("MST")=$P(PSOPENIB,"^") - .I $D(PSOIBQS(PSODFN,"HNC")) D D MESSOI,MESS D HNC^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("HNC"))) K PSONEW("NEWCOPAY") - ..I '$D(PSOANSQD("HNC")),($P(PSOPENIB,"^",5)=0!($P(PSOPENIB,"^",5)=1)) S PSOANSQD("HNC")=$P(PSOPENIB,"^",5) - K PSONEWFF,PSOSCOTH,PSOSCOTX,PSOMESFI,PSOSCA - Q -SET ;Set original answers that were passed from CPRS - Q:'$G(ORD) - Q:'$G(PSOFDR) - I $P($G(^PS(52.41,ORD,0)),"^",16)="SC"!($P($G(^(0)),"^",16)="NSC") D - . I PSOSCP<50 S PSOANSQ("SC")=$S($P($G(^(0)),"^",16)="SC":1,1:0),PSOANSQD("SC")=PSOANSQ("SC") S:PSOANSQ("SC")'="" PSOIBQS(PSODFN,"SC")=PSOANSQ("SC") - . I PSOSCP>49 S PSOANSQ("SC>50")=$S($P($G(^(0)),"^",16)="SC":1,1:0),PSOANSQD("SC>50")=PSOANSQ("SC>50") S:PSOANSQ("SC>50")'="" PSOIBQS(PSODFN,"SC>50")=PSOANSQ("SC>50") - I $G(PSOPENIB)="" G SET2 - I '$$DT^PSOMLLDT Q - I $P(PSOPENIB,"^")=0!($P(PSOPENIB,"^")=1) S PSOANSQ("MST")=$P(PSOPENIB,"^") - I $P(PSOPENIB,"^",2)=0!($P(PSOPENIB,"^",2)=1) S PSOANSQ("VEH")=$P(PSOPENIB,"^",2) - I $P(PSOPENIB,"^",3)=0!($P(PSOPENIB,"^",3)=1) S PSOANSQ("RAD")=$P(PSOPENIB,"^",3) - I $P(PSOPENIB,"^",4)=0!($P(PSOPENIB,"^",4)=1) S PSOANSQ("PGW")=$P(PSOPENIB,"^",4) - I $P(PSOPENIB,"^",5)=0!($P(PSOPENIB,"^",5)=1) S PSOANSQ("HNC")=$P(PSOPENIB,"^",5) - I $P(PSOPENIB,"^",6)=0!($P(PSOPENIB,"^",6)=1) S PSOANSQ("CV")=$P(PSOPENIB,"^",6) - I $P(PSOPENIB,"^",7)=0!($P(PSOPENIB,"^",7)=1) S PSOANSQ("SHAD")=$P(PSOPENIB,"^",7) - ; -SET2 ;for when patient status is exempt, null IBQ node was set for exempts or SC>50 - data is in ICD node - N PSOOICD - I $TR($G(^PS(52.41,+$G(ORD),"IBQ")),"^")="" S PSOOICD=$G(^PS(52.41,ORD,"ICD",1,0)) D SET3:PSOOICD'="" - ; -ICD1 ; - N PSONOCHG S PSONOCHG=0 - I ('$D(PSORXED("ICD"))) S PSONOCHG=1 - I $D(^PS(52.41,ORD,"ICD",0)) D - . N JJ,ICD,II,FLD,RXN S RXN=ORD - . S II=0 F S II=$O(^PS(52.41,ORD,"ICD",II)) Q:II=""!(II'?1N.N) D - .. S ICD=^PS(52.41,ORD,"ICD",II,0),FLD=$P(ICD,U) S:$G(PSONEW("IDFLG")) FLD="" D ICD - Q - ; -SET3 ; called from PSONEWF and PSONEWG; must have PSOOICD. For SC>50, exempt patient status, etc. - N JJJ - F JJJ=2:1:9 I $P(PSOOICD,"^",JJJ)=0!($P(PSOOICD,"^",JJJ)=1) D - . I JJJ=2 S (PSOANSQD("VEH"),PSOANSQ("VEH"))=$P(PSOOICD,"^",JJJ) - . I JJJ=3 S (PSOANSQD("RAD"),PSOANSQ("RAD"))=$P(PSOOICD,"^",JJJ) - . I JJJ=4 D - .. S:PSOSCP<50 (PSOANSQD("SC"),PSOANSQ("SC"))=$P(PSOOICD,"^",JJJ) - .. S:PSOSCP>49!($P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)=1) (PSOANSQD("SC>50"),PSOANSQ("SC>50"))=$P(PSOOICD,"^",JJJ) - . I JJJ=5 S (PSOANSQD("PGW"),PSOANSQ("PGW"))=$P(PSOOICD,"^",JJJ) - . I JJJ=6 S (PSOANSQD("MST"),PSOANSQ("MST"))=$P(PSOOICD,"^",JJJ) - . I JJJ=7 S (PSOANSQD("HNC"),PSOANSQ("HNC"))=$P(PSOOICD,"^",JJJ) - . I JJJ=8 S (PSOANSQD("CV"),PSOANSQ("CV"))=$P(PSOOICD,"^",JJJ) - . I JJJ=9 S (PSOANSQD("SHAD"),PSOANSQ("SHAD"))=$P(PSOOICD,"^",JJJ) - K PSOOICD - Q -MESS ; - I $G(PSOSCOTX)=1&(PSOSCP<50) W:$G(PSODRUG("DEA"))'["S"&($G(PSODRUG("DEA"))'["I") !,"This Rx has been flagged by the provider as: "_$S($G(PSOSCOTH):"NO COPAY",$G(PSORX("SC"))="SC":"NO COPAY",1:"COPAY"),! S PSOSCOTX=2 - Q -MESSOI ; - I $G(PSOMESFI)=1 W !!,"The Pharmacy Orderable Item has changed for this order. Please review any",!,"existing SC or Environmental Indicator defaults carefully for appropriateness.",! S PSOMESFI=2 - Q - ; -ICD ;called from PSONEWG,PSORENW1 and used by PSONEWF - I $G(PSOCOPY)&($D(PSORXED("ICD")))&($D(PSONEW("IDFLG"))) Q:'$D(PSORXED("ICD",II)) - I $G(PSOCOPY)&($D(PSORXED("ICD",II))) S PSONEW("ICD",II)=PSORXED("ICD",II) Q - Q:'$G(PSOCOPY)&('$D(PSORXED("ICD",II)))&('$G(PSONOCHG)) ;don't set deleted ones - Q:$G(PSONEW("IDFLG")) - I $D(PSORX("ICD",II)) S PSONEW("ICD",II)=PSORX("ICD",II) Q - S PSONEW("ICD",II)=FLD - Q - ; +PSONEWF ;BIR/RTR - Copay finish questions ;07/26/96 + ;;7.0;OUTPATIENT PHARMACY;**71,157,143,219,226,239,208**;DEC 1997;Build 39 + ; 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 + ;External reference VADPT supported by DBIA 10061 +START ; + I $G(PSOAFYN)="Y" Q ; vfam + N PSOPENIB,PSOSCOTH,PSOSCOTX,PSOMESFI + S PSOPENIB=$S($G(ORD):$G(^PS(52.41,+$G(ORD),"IBQ")),1:"") + ;set PSOSCOTH for display of Provider Copay intent, used with PSORX(SC) + S PSOSCOTH=0 I $P(PSOPENIB,"^")=1!($P(PSOPENIB,"^",2)=1)!($P(PSOPENIB,"^",3)=1)!($P(PSOPENIB,"^",4)=1)!($P(PSOPENIB,"^",5)=1)!($P(PSOPENIB,"^",6)=1) S PSOSCOTH=1 + S PSOSCOTX=0 I $G(PSOSCOTH)!($G(PSORX("SC"))="SC")!($G(PSORX("SC"))="NSC") S PSOSCOTX=1 + ;Check for Orderable Item change to display message + S PSOMESFI=0 I $G(OR0),$G(PSODRUG("OI")) D + .I $G(PSODRUG("OI"))'=$P($G(OR0),"^",8) S PSOMESFI=1 + S PSONEWFF=1,PSOFLAG=1 + ;Copay exemption checks + D SCP^PSORN52D + K PSOANSQ D SET S PSOCPZ("DFLG")=0,PSONEW("NEWCOPAY")=0 + I (PSOSCP<50)&($P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)'=1),$G(DUZ("AG"))="V" D COPAY^PSOCPB W ! + I $P(PSOPENIB,"^",6)=0!($P(PSOPENIB,"^",6)=1) S PSOANSQ("CV")=$P(PSOPENIB,"^",6) + I $G(PSOCPZ("DFLG")) K PSONEW("NEWCOPAY"),PSONEWFF,PSOSCOTH,PSOSCOTX,PSOMESFI Q + ; + I PSOSCA&(PSOSCP>49)!((PSOSCA!(PSOBILL=2))&($P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)=1))!(PSOSCP>49&(PSOBILL=2)) D I $G(PSOCPZ("DFLG")) K PSOANSQ,PSONEW("NEWCOPAY"),PSONEWFF,PSOSCOTH,PSOSCOTX,PSOMESFI Q + . I PSOSCP<50 D MESS S:PSOSCP<50 PSOANSQD("SC>50")=$G(PSOANSQD("SC")) + . D SC^PSOMLLD2 + . I PSOSCP<50&($D(PSOANSQD("SC"))) S PSOANSQD("SC")=PSOANSQD("SC>50") K PSOANSQD("SC") + ;IF MILL BILL, AND COPAY (*******TEST THE COPAY CHECK) + I $$DT^PSOMLLDT D I $G(PSOCPZ("DFLG")) K PSOANSQ,PSONEW("NEWCOPAY"),PSONEWFF,PSOSCOTH,PSOSCOTX,PSOMESFI Q + .;New prompts Quit after first '^' + .I $D(PSOIBQS(PSODFN,"CV")) D D MESSOI,MESS D CV^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("CV"))) K PSONEW("NEWCOPAY") + ..I '$D(PSOANSQD("CV")),($P(PSOPENIB,"^",6)=0!($P(PSOPENIB,"^",6)=1)) S PSOANSQD("CV")=$P(PSOPENIB,"^",6) + .I $D(PSOIBQS(PSODFN,"VEH")) D D MESSOI,MESS D VEH^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("VEH"))) K PSONEW("NEWCOPAY") + ..I '$D(PSOANSQD("VEH")),($P(PSOPENIB,"^",2)=0!($P(PSOPENIB,"^",2)=1)) S PSOANSQD("VEH")=$P(PSOPENIB,"^",2) + .I $D(PSOIBQS(PSODFN,"RAD")) D D MESSOI,MESS D RAD^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("RAD"))) K PSONEW("NEWCOPAY") + ..I '$D(PSOANSQD("RAD")),($P(PSOPENIB,"^",3)=0!($P(PSOPENIB,"^",3)=1)) S PSOANSQD("RAD")=$P(PSOPENIB,"^",3) + .I $D(PSOIBQS(PSODFN,"PGW")) D D MESSOI,MESS D PGW^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("PGW"))) K PSONEW("NEWCOPAY") + ..I '$D(PSOANSQD("PGW")),($P(PSOPENIB,"^",4)=0!($P(PSOPENIB,"^",4)=1)) S PSOANSQD("PGW")=$P(PSOPENIB,"^",4) + .I $D(PSOIBQS(PSODFN,"MST")) D D MESSOI,MESS D MST^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("MST"))) K PSONEW("NEWCOPAY") + ..I '$D(PSOANSQD("MST")),($P(PSOPENIB,"^")=0!($P(PSOPENIB,"^")=1)) S PSOANSQD("MST")=$P(PSOPENIB,"^") + .I $D(PSOIBQS(PSODFN,"HNC")) D D MESSOI,MESS D HNC^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("HNC"))) K PSONEW("NEWCOPAY") + ..I '$D(PSOANSQD("HNC")),($P(PSOPENIB,"^",5)=0!($P(PSOPENIB,"^",5)=1)) S PSOANSQD("HNC")=$P(PSOPENIB,"^",5) + K PSONEWFF,PSOSCOTH,PSOSCOTX,PSOMESFI,PSOSCA + Q +SET ;Set original answers that were passed from CPRS + Q:'$G(ORD) + Q:'$G(PSOFDR) + I $P($G(^PS(52.41,ORD,0)),"^",16)="SC"!($P($G(^(0)),"^",16)="NSC") D + . I PSOSCP<50 S PSOANSQ("SC")=$S($P($G(^(0)),"^",16)="SC":1,1:0),PSOANSQD("SC")=PSOANSQ("SC") S:PSOANSQ("SC")'="" PSOIBQS(PSODFN,"SC")=PSOANSQ("SC") + . I PSOSCP>49 S PSOANSQ("SC>50")=$S($P($G(^(0)),"^",16)="SC":1,1:0),PSOANSQD("SC>50")=PSOANSQ("SC>50") S:PSOANSQ("SC>50")'="" PSOIBQS(PSODFN,"SC>50")=PSOANSQ("SC>50") + I $G(PSOPENIB)="" G SET2 + I '$$DT^PSOMLLDT Q + I $P(PSOPENIB,"^")=0!($P(PSOPENIB,"^")=1) S PSOANSQ("MST")=$P(PSOPENIB,"^") + I $P(PSOPENIB,"^",2)=0!($P(PSOPENIB,"^",2)=1) S PSOANSQ("VEH")=$P(PSOPENIB,"^",2) + I $P(PSOPENIB,"^",3)=0!($P(PSOPENIB,"^",3)=1) S PSOANSQ("RAD")=$P(PSOPENIB,"^",3) + I $P(PSOPENIB,"^",4)=0!($P(PSOPENIB,"^",4)=1) S PSOANSQ("PGW")=$P(PSOPENIB,"^",4) + I $P(PSOPENIB,"^",5)=0!($P(PSOPENIB,"^",5)=1) S PSOANSQ("HNC")=$P(PSOPENIB,"^",5) + I $P(PSOPENIB,"^",6)=0!($P(PSOPENIB,"^",6)=1) S PSOANSQ("CV")=$P(PSOPENIB,"^",6) + ; +SET2 ;for when patient status is exempt, null IBQ node was set for exempts or SC>50 - data is in ICD node + N PSOOICD + I $TR($G(^PS(52.41,+$G(ORD),"IBQ")),"^")="" S PSOOICD=$G(^PS(52.41,ORD,"ICD",1,0)) D SET3:PSOOICD'="" + ; +ICD1 ; + N PSONOCHG S PSONOCHG=0 + I ('$D(PSORXED("ICD"))) S PSONOCHG=1 + I $D(^PS(52.41,ORD,"ICD",0)) D + . N JJ,ICD,II,FLD,RXN S RXN=ORD + . S II=0 F S II=$O(^PS(52.41,ORD,"ICD",II)) Q:II=""!(II'?1N.N) D + .. S ICD=^PS(52.41,ORD,"ICD",II,0),FLD=$P(ICD,U) S:$G(PSONEW("IDFLG")) FLD="" D ICD + Q + ; +SET3 ; called from PSONEWF and PSONEWG; must have PSOOICD. For SC>50, exempt patient status, etc. + N JJJ + F JJJ=2:1:8 I $P(PSOOICD,"^",JJJ)=0!($P(PSOOICD,"^",JJJ)=1) D + . I JJJ=2 S (PSOANSQD("VEH"),PSOANSQ("VEH"))=$P(PSOOICD,"^",JJJ) + . I JJJ=3 S (PSOANSQD("RAD"),PSOANSQ("RAD"))=$P(PSOOICD,"^",JJJ) + . I JJJ=4 D + .. S:PSOSCP<50 (PSOANSQD("SC"),PSOANSQ("SC"))=$P(PSOOICD,"^",JJJ) + .. S:PSOSCP>49!($P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)=1) (PSOANSQD("SC>50"),PSOANSQ("SC>50"))=$P(PSOOICD,"^",JJJ) + . I JJJ=5 S (PSOANSQD("PGW"),PSOANSQ("PGW"))=$P(PSOOICD,"^",JJJ) + . I JJJ=6 S (PSOANSQD("MST"),PSOANSQ("MST"))=$P(PSOOICD,"^",JJJ) + . I JJJ=7 S (PSOANSQD("HNC"),PSOANSQ("HNC"))=$P(PSOOICD,"^",JJJ) + . I JJJ=8 S (PSOANSQD("CV"),PSOANSQ("CV"))=$P(PSOOICD,"^",JJJ) + K PSOOICD + Q +MESS ; + I $G(PSOSCOTX)=1&(PSOSCP<50) W:$G(PSODRUG("DEA"))'["S"&($G(PSODRUG("DEA"))'["I") !,"This Rx has been flagged by the provider as: "_$S($G(PSOSCOTH):"NO COPAY",$G(PSORX("SC"))="SC":"NO COPAY",1:"COPAY"),! S PSOSCOTX=2 + Q +MESSOI ; + I $G(PSOMESFI)=1 W !!,"The Pharmacy Orderable Item has changed for this order. Please review any",!,"existing SC or Environmental Indicator defaults carefully for appropriateness.",! S PSOMESFI=2 + Q + ; +ICD ;called from PSONEWG,PSORENW1 and used by PSONEWF + I $G(PSOCOPY)&($D(PSORXED("ICD")))&($D(PSONEW("IDFLG"))) Q:'$D(PSORXED("ICD",II)) + I $G(PSOCOPY)&($D(PSORXED("ICD",II))) S PSONEW("ICD",II)=PSORXED("ICD",II) Q + Q:'$G(PSOCOPY)&('$D(PSORXED("ICD",II)))&('$G(PSONOCHG)) ;don't set deleted ones + Q:$G(PSONEW("IDFLG")) + I $D(PSORX("ICD",II)) S PSONEW("ICD",II)=PSORX("ICD",II) Q + S PSONEW("ICD",II)=FLD + Q + ; diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSONEWG.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSONEWG.m index e3d810d7..8ff39d58 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSONEWG.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSONEWG.m @@ -1,70 +1,67 @@ -PSONEWG ;BIR/RTR - Copay copy and edit questions ;07/26/96 - ;;7.0;OUTPATIENT PHARMACY;**71,157,143,219,226,239,225**;DEC 1997;Build 29 - ;External reference ^PSDRUG( supported by DBIA 221 - ;External reference VADPT supported by DBIA 10061 -START ; - N PSOPENIB,PSOMESOI - S PSOPENIB="" I $G(PSORXED)!($G(PSOCOPY)) I $G(PSORXED("IRXN")) S PSOPENIB=$G(^PSRX(PSORXED("IRXN"),"IBQ")) - S PSOMESOI=0 I $G(PSORXED) D - .I $G(PSODRUG("OI")),$P($G(PSORXED("RX0")),"^",6) D - ..I $G(PSODRUG("OI"))'=$P($G(^PSDRUG(+$P($G(PSORXED("RX0")),"^",6),2)),"^") S PSOMESOI=1 - S PSONEWFF=1,PSOFLAG=1 - ;Copay exemption checks - D SCP^PSORN52D - K PSOANSQ D SET S PSOCPZ("DFLG")=0,PSONEW("NEWCOPAY")=0 - I PSOSCP<50&($P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)'=1),$G(DUZ("AG"))="V" D D COPAY^PSOCPB W ! - .;I $G(PSOANSQD("SC"))=0!($G(PSOANSQD("SC"))=1) Q - .I $G(PSOANSQ("SC"))=0!($G(PSOANSQ("SC"))=1) S PSOANSQD("SC")=$G(PSOANSQ("SC")) - I PSOSCA&(PSOSCP>49)!((PSOSCA!(PSOBILL=2))&($P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)=1))!(PSOSCP>49&(PSOBILL=2)) D SC^PSOMLLD2 I $G(PSOCPZ("DFLG")) K PSOANSQ,PSONEW("NEWCOPAY"),PSONEWFF,PSOMESOI Q - I $G(PSOCPZ("DFLG")) K PSONEW("NEWCOPAY"),PSONEWFF,PSOMESOI Q - ;IF MILL BILL, AND COPAY (*******TEST THE COPAY CHECK) - I $$DT^PSOMLLDT D I $G(PSOCPZ("DFLG")) K PSOANSQ,PSONEW("NEWCOPAY"),PSONEWFF,PSOMESOI Q - .;New prompts Quit after first '^' - .I $D(PSOIBQS(PSODFN,"CV")) D D MESS D CV^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("CV"))) K PSONEW("NEWCOPAY") - ..I '$D(PSOANSQD("CV")),($P(PSOPENIB,"^",7)=0!($P(PSOPENIB,"^",7)=1)) S PSOANSQD("CV")=$P(PSOPENIB,"^",7) - .I $D(PSOIBQS(PSODFN,"VEH")) D D MESS D VEH^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("VEH"))) K PSONEW("NEWCOPAY") - ..I '$D(PSOANSQD("VEH")),($P(PSOPENIB,"^",3)=0!($P(PSOPENIB,"^",3)=1)) S PSOANSQD("VEH")=$P(PSOPENIB,"^",3) - .I $D(PSOIBQS(PSODFN,"RAD")) D D MESS D RAD^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("RAD"))) K PSONEW("NEWCOPAY") - ..I '$D(PSOANSQD("RAD")),($P(PSOPENIB,"^",4)=0!($P(PSOPENIB,"^",4)=1)) S PSOANSQD("RAD")=$P(PSOPENIB,"^",4) - .I $D(PSOIBQS(PSODFN,"PGW")) D D MESS D PGW^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("PGW"))) K PSONEW("NEWCOPAY") - ..I '$D(PSOANSQD("PGW")),($P(PSOPENIB,"^",5)=0!($P(PSOPENIB,"^",5)=1)) S PSOANSQD("PGW")=$P(PSOPENIB,"^",5) - .I $D(PSOIBQS(PSODFN,"SHAD")) D D MESS D SHAD^PSOMLLD2 I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("SHAD"))) K PSONEW("NEWCOPAY") - ..I '$D(PSOANSQD("SHAD")),($P(PSOPENIB,"^",8)=0!($P(PSOPENIB,"^",8)=1)) S PSOANSQD("SHAD")=$P(PSOPENIB,"^",8) - .I $D(PSOIBQS(PSODFN,"MST")) D D MESS D MST^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("MST"))) K PSONEW("NEWCOPAY") - ..I '$D(PSOANSQD("MST")),($P(PSOPENIB,"^",2)=0!($P(PSOPENIB,"^",2)=1)) S PSOANSQD("MST")=$P(PSOPENIB,"^",2) - .I $D(PSOIBQS(PSODFN,"HNC")) D D MESS D HNC^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("HNC"))) K PSONEW("NEWCOPAY") - ..I '$D(PSOANSQD("HNC")),($P(PSOPENIB,"^",6)=0!($P(PSOPENIB,"^",6)=1)) S PSOANSQD("HNC")=$P(PSOPENIB,"^",6) - K PSONEWFF,PSOMESOI,PSOSCA - Q -SET ;Set original answers that were passed from CPRS - Q:'$G(PSORXED("IRXN")) - S PSOANSQ("SC")=$S($P($G(^PSRX(PSORXED("IRXN"),"IBQ")),"^")'="":$P($G(^("IBQ")),"^"),$P($G(^PSRX(PSORXED("IRXN"),"IB")),"^"):0,1:"") - I $G(PSOANSQ("SC"))="" K PSOANSQ("SC") - I $G(PSOPENIB)="" G SET2 - I '$$DT^PSOMLLDT Q - I $P(PSOPENIB,"^",2)=0!($P(PSOPENIB,"^",2)=1) S PSOANSQ("MST")=$P(PSOPENIB,"^",2) - I $P(PSOPENIB,"^",3)=0!($P(PSOPENIB,"^",3)=1) S PSOANSQ("VEH")=$P(PSOPENIB,"^",3) - I $P(PSOPENIB,"^",4)=0!($P(PSOPENIB,"^",4)=1) S PSOANSQ("RAD")=$P(PSOPENIB,"^",4) - I $P(PSOPENIB,"^",5)=0!($P(PSOPENIB,"^",5)=1) S PSOANSQ("PGW")=$P(PSOPENIB,"^",5) - I $P(PSOPENIB,"^",6)=0!($P(PSOPENIB,"^",6)=1) S PSOANSQ("HNC")=$P(PSOPENIB,"^",6) - I $P(PSOPENIB,"^",7)=0!($P(PSOPENIB,"^",7)=1) S PSOANSQ("CV")=$P(PSOPENIB,"^",7) - I $P(PSOPENIB,"^",8)=0!($P(PSOPENIB,"^",8)=1) S PSOANSQ("SHAD")=$P(PSOPENIB,"^",8) - ; -SET2 ;for when patient status is exempt, null IBQ node was set for exempts or SC>50 - data is in ICD node - N PSOOICD,JJJ - I $TR($G(^PSRX(PSODFN,"IBQ")),"^")="" S PSOOICD=$G(^PSRX(PSORXED("IRXN"),"ICD",1,0)) D SET3^PSONEWF:PSOOICD'="" - ; -ICD ; - N JJ,ICD,II,FLD,RXN,TNEW,PSONOCHG S PSONOCHG=0 - S RXN=PSORXED("IRXN") - I '$D(PSONEW("ICD"))&('$D(PSORXED("ICD"))) S PSONOCHG=1 - I $D(^PSRX(RXN,"ICD",0)) D - . S II=0 F S II=$O(^PSRX(RXN,"ICD",II)) Q:II=""!(II'?1N.N)!($G(PSOCOPY)&(II>1)&('PSONOCHG)) D - .. S ICD=^PSRX(RXN,"ICD",II,0),FLD=$P(ICD,U) S:$G(PSONEW("IDFLG")) FLD="" D ICD^PSONEWF - E I $G(PSONEW("IDFLG")) K ^PSRX(RXN,"ICD","B") S $P(^PSRX(RXN,"ICD",1,0),"^",1)="",TNEW=2 D - . F TNEW=TNEW:1:8 Q:'$D(^PSRX(RXN,"ICD",TNEW,0)) S DIK="^PSRX("_RXN_","_$C(34)_"ICD"_$C(34)_",",DA=TNEW,DA(1)=RXN D ^DIK K DA,DIK ;user deleted all - K PSONEW("IDFLG"),PSORXED("IDFLG") - Q -MESS ; - I $G(PSOMESOI)=1,$G(PSORXED) W !!,"The Pharmacy Orderable Item has changed for this order. Please review any",!,"existing SC or Environmental Indicator defaults carefully for appropriateness.",! S PSOMESOI=2 - Q +PSONEWG ;BIR/RTR - Copay copy and edit questions ;07/26/96 + ;;7.0;OUTPATIENT PHARMACY;**71,157,143,219,226,239**;DEC 1997 + ;External reference ^PSDRUG( supported by DBIA 221 + ;External reference VADPT supported by DBIA 10061 +START ; + N PSOPENIB,PSOMESOI + S PSOPENIB="" I $G(PSORXED)!($G(PSOCOPY)) I $G(PSORXED("IRXN")) S PSOPENIB=$G(^PSRX(PSORXED("IRXN"),"IBQ")) + S PSOMESOI=0 I $G(PSORXED) D + .I $G(PSODRUG("OI")),$P($G(PSORXED("RX0")),"^",6) D + ..I $G(PSODRUG("OI"))'=$P($G(^PSDRUG(+$P($G(PSORXED("RX0")),"^",6),2)),"^") S PSOMESOI=1 + S PSONEWFF=1,PSOFLAG=1 + ;Copay exemption checks + D SCP^PSORN52D + K PSOANSQ D SET S PSOCPZ("DFLG")=0,PSONEW("NEWCOPAY")=0 + I PSOSCP<50&($P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)'=1),$G(DUZ("AG"))="V" D D COPAY^PSOCPB W ! + .;I $G(PSOANSQD("SC"))=0!($G(PSOANSQD("SC"))=1) Q + .I $G(PSOANSQ("SC"))=0!($G(PSOANSQ("SC"))=1) S PSOANSQD("SC")=$G(PSOANSQ("SC")) + I PSOSCA&(PSOSCP>49)!((PSOSCA!(PSOBILL=2))&($P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)=1))!(PSOSCP>49&(PSOBILL=2)) D SC^PSOMLLD2 I $G(PSOCPZ("DFLG")) K PSOANSQ,PSONEW("NEWCOPAY"),PSONEWFF,PSOMESOI Q + I $G(PSOCPZ("DFLG")) K PSONEW("NEWCOPAY"),PSONEWFF,PSOMESOI Q + ;IF MILL BILL, AND COPAY (*******TEST THE COPAY CHECK) + I $$DT^PSOMLLDT D I $G(PSOCPZ("DFLG")) K PSOANSQ,PSONEW("NEWCOPAY"),PSONEWFF,PSOMESOI Q + .;New prompts Quit after first '^' + .I $D(PSOIBQS(PSODFN,"CV")) D D MESS D CV^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("CV"))) K PSONEW("NEWCOPAY") + ..I '$D(PSOANSQD("CV")),($P(PSOPENIB,"^",7)=0!($P(PSOPENIB,"^",7)=1)) S PSOANSQD("CV")=$P(PSOPENIB,"^",7) + .I $D(PSOIBQS(PSODFN,"VEH")) D D MESS D VEH^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("VEH"))) K PSONEW("NEWCOPAY") + ..I '$D(PSOANSQD("VEH")),($P(PSOPENIB,"^",3)=0!($P(PSOPENIB,"^",3)=1)) S PSOANSQD("VEH")=$P(PSOPENIB,"^",3) + .I $D(PSOIBQS(PSODFN,"RAD")) D D MESS D RAD^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("RAD"))) K PSONEW("NEWCOPAY") + ..I '$D(PSOANSQD("RAD")),($P(PSOPENIB,"^",4)=0!($P(PSOPENIB,"^",4)=1)) S PSOANSQD("RAD")=$P(PSOPENIB,"^",4) + .I $D(PSOIBQS(PSODFN,"PGW")) D D MESS D PGW^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("PGW"))) K PSONEW("NEWCOPAY") + ..I '$D(PSOANSQD("PGW")),($P(PSOPENIB,"^",5)=0!($P(PSOPENIB,"^",5)=1)) S PSOANSQD("PGW")=$P(PSOPENIB,"^",5) + .I $D(PSOIBQS(PSODFN,"MST")) D D MESS D MST^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("MST"))) K PSONEW("NEWCOPAY") + ..I '$D(PSOANSQD("MST")),($P(PSOPENIB,"^",2)=0!($P(PSOPENIB,"^",2)=1)) S PSOANSQD("MST")=$P(PSOPENIB,"^",2) + .I $D(PSOIBQS(PSODFN,"HNC")) D D MESS D HNC^PSOMLLDT I $G(PSOCPZ("DFLG"))!($G(PSOANSQ("HNC"))) K PSONEW("NEWCOPAY") + ..I '$D(PSOANSQD("HNC")),($P(PSOPENIB,"^",6)=0!($P(PSOPENIB,"^",6)=1)) S PSOANSQD("HNC")=$P(PSOPENIB,"^",6) + K PSONEWFF,PSOMESOI,PSOSCA + Q +SET ;Set original answers that were passed from CPRS + Q:'$G(PSORXED("IRXN")) + S PSOANSQ("SC")=$S($P($G(^PSRX(PSORXED("IRXN"),"IBQ")),"^")'="":$P($G(^("IBQ")),"^"),$P($G(^PSRX(PSORXED("IRXN"),"IB")),"^"):0,1:"") + I $G(PSOANSQ("SC"))="" K PSOANSQ("SC") + I $G(PSOPENIB)="" G SET2 + I '$$DT^PSOMLLDT Q + I $P(PSOPENIB,"^",2)=0!($P(PSOPENIB,"^",2)=1) S PSOANSQ("MST")=$P(PSOPENIB,"^",2) + I $P(PSOPENIB,"^",3)=0!($P(PSOPENIB,"^",3)=1) S PSOANSQ("VEH")=$P(PSOPENIB,"^",3) + I $P(PSOPENIB,"^",4)=0!($P(PSOPENIB,"^",4)=1) S PSOANSQ("RAD")=$P(PSOPENIB,"^",4) + I $P(PSOPENIB,"^",5)=0!($P(PSOPENIB,"^",5)=1) S PSOANSQ("PGW")=$P(PSOPENIB,"^",5) + I $P(PSOPENIB,"^",6)=0!($P(PSOPENIB,"^",6)=1) S PSOANSQ("HNC")=$P(PSOPENIB,"^",6) + I $P(PSOPENIB,"^",7)=0!($P(PSOPENIB,"^",7)=1) S PSOANSQ("CV")=$P(PSOPENIB,"^",7) + ; +SET2 ;for when patient status is exempt, null IBQ node was set for exempts or SC>50 - data is in ICD node + N PSOOICD,JJJ + I $TR($G(^PSRX(PSODFN,"IBQ")),"^")="" S PSOOICD=$G(^PSRX(PSORXED("IRXN"),"ICD",1,0)) D SET3^PSONEWF:PSOOICD'="" + ; +ICD ; + N JJ,ICD,II,FLD,RXN,TNEW,PSONOCHG S PSONOCHG=0 + S RXN=PSORXED("IRXN") + I '$D(PSONEW("ICD"))&('$D(PSORXED("ICD"))) S PSONOCHG=1 + I $D(^PSRX(RXN,"ICD",0)) D + . S II=0 F S II=$O(^PSRX(RXN,"ICD",II)) Q:II=""!(II'?1N.N)!($G(PSOCOPY)&(II>1)&('PSONOCHG)) D + .. S ICD=^PSRX(RXN,"ICD",II,0),FLD=$P(ICD,U) S:$G(PSONEW("IDFLG")) FLD="" D ICD^PSONEWF + E I $G(PSONEW("IDFLG")) K ^PSRX(RXN,"ICD","B") S $P(^PSRX(RXN,"ICD",1,0),"^",1)="",TNEW=2 D + . F TNEW=TNEW:1:8 Q:'$D(^PSRX(RXN,"ICD",TNEW,0)) S DIK="^PSRX("_RXN_","_$C(34)_"ICD"_$C(34)_",",DA=TNEW,DA(1)=RXN D ^DIK K DA,DIK ;user deleted all + K PSONEW("IDFLG"),PSORXED("IDFLG") + Q +MESS ; + I $G(PSOMESOI)=1,$G(PSORXED) W !!,"The Pharmacy Orderable Item has changed for this order. Please review any",!,"existing SC or Environmental Indicator defaults carefully for appropriateness.",! S PSOMESOI=2 + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSONFI.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSONFI.m index 33947a77..cd205e73 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSONFI.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSONFI.m @@ -1,72 +1,65 @@ -PSONFI ;BIR/MHA - dispense drug/orderable item text display ;09/13/00 - ;;7.0;OUTPATIENT PHARMACY;**46,94,131,225**;DEC 1997;Build 29 - ;External reference to PSSDIN is supported by DBIA 3166 - ;External reference to ^PS(50.606 is supported by DBIA 2174 - ;External reference to ^PS(50.7 is supported by DBIA 2223 - ;External reference to ^PSDRUG( is supported by DBIA 221 - ; -NFI ;display restriction/guidelines - D EN^PSSDIN(PSODRUG("OI"),PSODRUG("IEN")) S NFI=$$PROMPT^PSSDIN - I NFI]"","ODY"[NFI D TD^PSONFI S DIR(0)="E" D ^DIR K DIR - K NFI Q -DDTX ;Display drug text for the hidden action DIN - N OI,DD - S:$D(PSODRUG("OI")) OI=PSODRUG("OI") S:$D(PSODRUG("IEN")) DD=PSODRUG("IEN") - I $G(OI),$G(DD) G 1 - I $D(PSORNSV),$G(PSORNSV)]"" S OI=+$P(OR0,"^",8),DD=+$P(OR0,"^",9) G 1 - S OI=+RXOR,DD=+$P(RX0,"^",6) -1 S OI=$S($G(OI):OI,1:""),DD=$S($G(DD):DD,1:"") - D EN^PSSDIN(OI,DD) - N N1,N2,N3,N4,TX,NX S NX="PSSDIN" - W @IOF,!!,"Drug restriction/guideline info:",!! - W !,"Orderable Item: "_$P(^PS(50.7,OI,0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^")_$S($P(^PS(50.7,OI,0),"^",12):" ***(N/F)***",1:""),!! - I $O(^TMP("PSSDIN",$J,"OI",0)) S N1="OI" D TXD - W:'$O(^TMP("PSSDIN",$J,"OI",0)) ?5,"No information available ",!! - I $G(DD),$D(^PSDRUG(DD,0)) W !,"Drug: "_$P(^PSDRUG(DD,0),"^")_$S($P(^PSDRUG(DD,0),"^",9):" ***(N/F)***",1:""),!! D - .I $O(^TMP("PSSDIN",$J,"DD",0)) S N1="DD" D TXD - .W:'$O(^TMP("PSSDIN",$J,"DD",0)) ?5,"No information available ",!! -HLD K DIR S DIR(0)="E" D ^DIR K DIR - Q -DIN(OI,DD) ;Setup DIN indicator - S (NFIO,NFID)="" - I $D(OI),$G(OI) S:$P($G(^PS(50.7,OI,0)),"^",12) NFIO=" ***(N/F)***" - I $D(DD),$G(DD) S:$P($G(^PSDRUG(DD,0)),"^",9) NFID=" ***(N/F)***" - D EN^PSSDIN(OI,DD) - S:$O(^TMP("PSSDIN",$J,"OI",0)) NFIO=NFIO_" " - S:$O(^TMP("PSSDIN",$J,"DD",0)) NFID=NFID_" " - K ^TMP("PSSDIN",$J) Q - Q -RV ;reverse video - I $G(PKID),$G(PKIE)]"" D - .I $O(^PS(52.41,ORD,"OBX",0)) D CNTRL^VALM10(1,1,13,IORVON,IORVOFF,0),RV^PSOPKIV1 Q - .D CNTRL^VALM10(1,1,$L(PKIE),IORVON,IORVOFF,0) - D:$G(NFIO) CNTRL^VALM10(+NFIO,$P(NFIO,",",2),5,IORVON,IORVOFF,0) - D:$G(NFID) CNTRL^VALM10(+NFID,$P(NFID,",",2),5,IORVON,IORVOFF,0) - K NFIO,NFID,PKID - ;- Reverses video for the words "Flagged" and "Unflagged" - N L - F L=1:1:VALMCNT D - . D:$D(FLAGLINE(L)) CNTRL^VALM10(L,1,FLAGLINE(L),IORVON,IORVOFF,0) - Q - ; -TD N N1,N2,N3,N4,TX,NX S NX="PSSDIN" - W @IOF - I NFI="O" D OIT - I NFI="D" D DDT - I NFI="Y" D DDT,OIT - Q -OIT ; - S N1="OI",TX="Orderable Item Text:" D TXT - Q -DDT ; - S N1="DD",TX="Dispense Drug Text:" D TXT - Q -TXT ; - W !,TX -TXD K ^UTILITY($J,"W") - S N2="" F S N2=$O(^TMP(NX,$J,N1,N2)) Q:'N2!($D(DIRUT)) D - .S N3="" F S N3=$O(^TMP(NX,$J,N1,N2,N3)) Q:'N3!($D(DIRUT)) D - ..S N4="" F S N4=$O(^TMP(NX,$J,N1,N2,N3,N4)) Q:'N4!($D(DIRUT)) D - ...W !?5,^TMP(NX,$J,N1,N2,N3,N4) I $Y>20 W ! D HLD Q:$D(DIRUT) W @IOF - W ! K ^UTILITY($J,"W") - Q +PSONFI ;BIR/MHA - dispense drug/orderable item text display ; 09/13/00 + ;;7.0;OUTPATIENT PHARMACY;**46,94,131**;DEC 1997 + ;External reference to PSSDIN is supported by DBIA 3166 + ;External reference to ^PS(50.606 is supported by DBIA 2174 + ;External reference to ^PS(50.7 is supported by DBIA 2223 + ;External reference to ^PSDRUG( is supported by DBIA 221 + ; +NFI ;display restriction/guidelines + D EN^PSSDIN(PSODRUG("OI"),PSODRUG("IEN")) S NFI=$$PROMPT^PSSDIN + I NFI]"","ODY"[NFI D TD^PSONFI S DIR(0)="E" D ^DIR K DIR + K NFI Q +DDTX ;Display drug text for the hidden action DIN + N OI,DD + S:$D(PSODRUG("OI")) OI=PSODRUG("OI") S:$D(PSODRUG("IEN")) DD=PSODRUG("IEN") + I $G(OI),$G(DD) G 1 + I $D(PSORNSV),$G(PSORNSV)]"" S OI=+$P(OR0,"^",8),DD=+$P(OR0,"^",9) G 1 + S OI=+RXOR,DD=+$P(RX0,"^",6) +1 S OI=$S($G(OI):OI,1:""),DD=$S($G(DD):DD,1:"") + D EN^PSSDIN(OI,DD) + N N1,N2,N3,N4,TX,NX S NX="PSSDIN" + W @IOF,!!,"Drug restriction/guideline info:",!! + W !,"Orderable Item: "_$P(^PS(50.7,OI,0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^")_$S($P(^PS(50.7,OI,0),"^",12):" ***(N/F)***",1:""),!! + I $O(^TMP("PSSDIN",$J,"OI",0)) S N1="OI" D TXD + W:'$O(^TMP("PSSDIN",$J,"OI",0)) ?5,"No information available ",!! + I $G(DD),$D(^PSDRUG(DD,0)) W !,"Drug: "_$P(^PSDRUG(DD,0),"^")_$S($P(^PSDRUG(DD,0),"^",9):" ***(N/F)***",1:""),!! D + .I $O(^TMP("PSSDIN",$J,"DD",0)) S N1="DD" D TXD + .W:'$O(^TMP("PSSDIN",$J,"DD",0)) ?5,"No information available ",!! +HLD K DIR S DIR(0)="E" D ^DIR K DIR + Q +DIN(OI,DD) ;Setup DIN indicator + S (NFIO,NFID)="" + I $D(OI),$G(OI) S:$P($G(^PS(50.7,OI,0)),"^",12) NFIO=" ***(N/F)***" + I $D(DD),$G(DD) S:$P($G(^PSDRUG(DD,0)),"^",9) NFID=" ***(N/F)***" + D EN^PSSDIN(OI,DD) + S:$O(^TMP("PSSDIN",$J,"OI",0)) NFIO=NFIO_" " + S:$O(^TMP("PSSDIN",$J,"DD",0)) NFID=NFID_" " + K ^TMP("PSSDIN",$J) Q + Q +RV ;reverse video + I $G(PKID),$G(PKIE)]"" D + .I $O(^PS(52.41,ORD,"OBX",0)) D CNTRL^VALM10(1,1,13,IORVON,IORVOFF,0),RV^PSOPKIV1 Q + .D CNTRL^VALM10(1,1,$L(PKIE),IORVON,IORVOFF,0) + D:$G(NFIO) CNTRL^VALM10(+NFIO,$P(NFIO,",",2),5,IORVON,IORVOFF,0) + D:$G(NFID) CNTRL^VALM10(+NFID,$P(NFID,",",2),5,IORVON,IORVOFF,0) + K NFIO,NFID,PKID Q +TD N N1,N2,N3,N4,TX,NX S NX="PSSDIN" + W @IOF + I NFI="O" D OIT + I NFI="D" D DDT + I NFI="Y" D DDT,OIT + Q +OIT ; + S N1="OI",TX="Orderable Item Text:" D TXT + Q +DDT ; + S N1="DD",TX="Dispense Drug Text:" D TXT + Q +TXT ; + W !,TX +TXD K ^UTILITY($J,"W") + S N2="" F S N2=$O(^TMP(NX,$J,N1,N2)) Q:'N2!($D(DIRUT)) D + .S N3="" F S N3=$O(^TMP(NX,$J,N1,N2,N3)) Q:'N3!($D(DIRUT)) D + ..S N4="" F S N4=$O(^TMP(NX,$J,N1,N2,N3,N4)) Q:'N4!($D(DIRUT)) D + ...W !?5,^TMP(NX,$J,N1,N2,N3,N4) I $Y>20 W ! D HLD Q:$D(DIRUT) W @IOF + W ! K ^UTILITY($J,"W") Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORAL.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORAL.m index f6723273..d14e822b 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORAL.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORAL.m @@ -1,27 +1,27 @@ -PSOORAL ;BHAM-ISC/SAB - activity log list ; 28-APR-1995 - ;;7.0;OUTPATIENT PHARMACY;**148,281**;DEC 1997;Build 41 -EN ; -- main entry point for PSO LM ACTIVITY LOGS - D EN^VALM("PSO LM ACTIVITY LOGS") - Q - ; -HDR ; -- header code - D HDR^PSOLMUTL - Q - ; -INIT ; -- init variables and list array - I $G(PS)="VIEW"!($G(PS)="DELETE")!($G(PS)="REJECT")!($G(PS)="REJECTMP") D - .I ST<12,$P(RX2,"^",6)
0&(RF<6):"REFILL "_RF,RF=6:"PARTIAL",RF>6:"REFILL "_(RF-1),1:"ORIGINAL") - .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_RFT_$E(RN,$L(RFT)+1,15)_$S($D(^VA(200,+$P(P1,"^",3),0)):$P(^(0),"^"),1:$P(P1,"^",3)) - .;S:$P(P1,"^",5)]"" IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_$P(P1,"^",5) - .I $P(P1,"^",5)]"" N PSOACBRK,PSOACBRV D - ..S PSOACBRV=$P(P1,"^",5) - ..;PSO*7*240 Use fileman for parsing - ..K ^UTILITY($J,"W") S X="Comments: "_PSOACBRV,(DIWR,DIWL)=1,DIWF="C80" D ^DIWP F I=1:1:^UTILITY($J,"W",1) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$G(^UTILITY($J,"W",1,I,0)) - .I $P($G(^PSRX(DA,"A",N,1)),"^")]"" S IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0)," ",5)=$P($G(^PSRX(DA,"A",N,1)),"^") I $P($G(^PSRX(DA,"A",N,1)),"^",2)]"" S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_":"_$P($G(^PSRX(DA,"A",N,1)),"^",2) - .I $O(^PSRX(DA,"A",N,2,0)) F I=0:0 S I=$O(^PSRX(DA,"A",N,2,I)) Q:'I S MIG=^PSRX(DA,"A",N,2,I,0) D - ..F SG=1:1:$L(MIG) S:$L(^TMP("PSOAL",$J,IEN,0)_" "_$P(MIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0)," ",9)=" " S:$P(MIG," ",SG)'="" ^TMP("PSOAL",$J,IEN,0)=$G(^TMP("PSOAL",$J,IEN,0))_" "_$P(MIG," ",SG) - K MIG,SG,I,^UTILITY($J,"W"),DIWF,DIWL,DIWR - Q -LBL ;label log - S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Label Log:" - S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="# Date Rx Ref Printed By",IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0),"=",79)="=" - I '$O(^PSRX(DA,"L",0)) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="There are NO Labels printed." Q - F L1=0:0 S L1=$O(^PSRX(DA,"L",L1)) Q:'L1 S LBL=^PSRX(DA,"L",L1,0),DTT=$P(^(0),"^") D DAT D - .S $P(RN," ",26)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=L1_" "_DAT_" ",RFT=$S($P(LBL,"^",2):"REFILL "_$P(LBL,"^",2),1:"ORIGINAL"),RFT=RFT_$E(RN,$L(RFT)+1,26) - .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_RFT_$P($G(^VA(200,$P(LBL,"^",4),0)),"^"),IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_$P(LBL,"^",3) - Q - ; -COPAY ;Copay activity log - S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Copay Activity Log:" - S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="# Date Reason Rx Ref Initiator Of Activity",IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0),"=",79)="=" - I '$O(^PSRX(DA,"COPAY",0)) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="There's NO Copay activity to report" Q - F N=0:0 S N=$O(^PSRX(DA,"COPAY",N)) Q:'N S P1=^(N,0),DTT=P1\1 D DAT D - .S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=N_" "_DAT_" ",$P(RN," ",21)=" ",REA=$P(P1,"^",2),REA=$F("ARICE",REA)-1 - .I REA D - ..S STA=$P("ANNUAL CAP REACHED^COPAY RESET^IB-INITIATED COPAY^REMOVE COPAY CHARGE^RX EDITED^","^",REA) - ..S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_STA_$E(RN,$L(STA)+1,21) - .E S $P(STA," ",21)=" ",^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_STA - .K STA,RN S $P(RN," ",15)=" ",RF=+$P(P1,"^",4) - .S RFT=$S(RF>0:"REFILL "_RF,1:"ORIGINAL") - .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_RFT_$E(RN,$L(RFT)+1,15)_$S($D(^VA(200,+$P(P1,"^",3),0)):$P(^(0),"^"),1:$P(P1,"^",3)) - .S:$P(P1,"^",5)]""!($P(P1,"^",6)]"")!($P(P1,"^",7)]"") IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comment: "_$P(P1,"^",5) - .I $P(P1,"^",6)]"" S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_" Old value="_$P(P1,"^",6)_" New value="_$P(P1,"^",7) - Q - ; -ECME ; ECME activity log - N N,P1,RFT,PSOACBRK,PSOACBRV,MIG,SG,I,NOTFND,CNT,LINE - S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="ECME Log:" - S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="# Date/Time Rx Ref Initiator Of Activity" - S IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0),"=",79)="=" - S NOTFND=1,I=0 F S I=$O(^PSRX(DA,"A",I)) Q:'I S Z=$G(^PSRX(DA,"A",I,0)) I $P(Z,"^",2)="M" S NOTFND=0 Q - I NOTFND S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="There's NO ECME Activity to report" Q - S CNT=0 - F N=0:0 S N=$O(^PSRX(DA,"A",N)) Q:'N S P1=^(N,0) D - .I $P(P1,"^",2)'="M" Q - .S IEN=IEN+1,CNT=CNT+1 - .K STA,RN S $P(RN," ",15)=" ",RF=+$P(P1,"^",4) - .S LINE=CNT,$E(LINE,5)=$$FMTE^XLFDT($P(P1,"^"),2),$E(LINE,25)=$S(RF:"REFILL "_RF,1:"ORIGINAL") - .S $E(LINE,41)=$$GET1^DIQ(200,+$P(P1,"^",3),.01) - .S ^TMP("PSOAL",$J,IEN,0)=LINE - .I $P(P1,"^",5)]"" D - ..S PSOACBRV=$P(P1,"^",5) - ..;PSO*7*240 Use fileman for parsing - ..K ^UTILITY($J,"W") S X="Comments: "_PSOACBRV,(DIWR,DIWL)=1,DIWF="C80" D ^DIWP F I=1:1:^UTILITY($J,"W",1) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$G(^UTILITY($J,"W",1,I,0)) - .I $O(^PSRX(DA,"A",N,2,0)) F I=0:0 S I=$O(^PSRX(DA,"A",N,2,I)) Q:'I S MIG=^PSRX(DA,"A",N,2,I,0) D - ..F SG=1:1:$L(MIG) D - ...S:$L(^TMP("PSOAL",$J,IEN,0)_" "_$P(MIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0)," ",9)=" " - ...S:$P(MIG," ",SG)'="" ^TMP("PSOAL",$J,IEN,0)=$G(^TMP("PSOAL",$J,IEN,0))_" "_$P(MIG," ",SG) - D DISPREJ - K ^UTILITY($J,"W"),DIWR,DIWF,DIWL - Q - ; -DISPREJ ; - N LN,SEQ,REJ,PRI,VAR,X,X1,X2,I,RFT - I '$D(^PSRX(DA,"REJ")) Q - S PRI="PSOAL",$P(LN,"=",80)="",SEQ=0 - S IEN=$G(IEN)+1,^TMP(PRI,$J,IEN,0)=" " - S IEN=IEN+1,^TMP(PRI,$J,IEN,0)="ECME REJECT Log:" - S IEN=IEN+1,^TMP(PRI,$J,IEN,0)="# Date/Time Rcvd Rx Ref Reject Type STATUS Date/Time Resolved" - S IEN=IEN+1,^TMP(PRI,$J,IEN,0)=LN - F REJ=0:0 S REJ=$O(^PSRX(DA,"REJ",REJ)) Q:'REJ D - . S VAR=$G(^PSRX(DA,"REJ",REJ,0)) - . S RFT=+$P(VAR,"^",4) - . S SEQ=SEQ+1,X=SEQ,$E(X,4)=$$FMTE^XLFDT($P(VAR,"^",2),2),$E(X,22)=$S(RFT:"REFILL "_RFT,1:"ORIGINAL") - . S $E(X,32)=$S(+VAR=79:"REFILL TOO SOON",1:"DUR") - . S $E(X,48)=$S($P(VAR,"^",5):"RESOLVED",1:"UNRESOLVED") - . S:$P(VAR,"^",6) $E(X,59)=$$FMTE^XLFDT($P(VAR,"^",6),2) - . ; S:$P(VAR,"^",14) $E(X,67)="(RE-OPENED)" - . S IEN=IEN+1,^TMP(PRI,$J,IEN,0)=X - . I $P(VAR,"^",5) D - . . S IEN=IEN+1,X=$$GET1^DIQ(52.25,REJ_","_DA,12) - . . S X1=$$GET1^DIQ(52.25,REJ_","_DA,13) S:X1'="" X=X1_" ("_X_")" - . . F I=1:1 Q:X="" D - . . . S ^TMP(PRI,$J,IEN,0)=$S(I=1:"Comments: ",1:" ")_$E(X,1,69) - . . . S X=$E(X,70,999) S:X'="" IEN=IEN+1 - Q - ; -DAT S DAT="",DTT=DTT\1 Q:DTT'?7N S DAT=$E(DTT,4,5)_"/"_$E(DTT,6,7)_"/"_$E(DTT,2,3) - Q +PSOORAL1 ;BHAM ISC/SAB - Build Listman activity logs ;11/16/92 13:11 + ;;7.0;OUTPATIENT PHARMACY;**71,156,148,247**;DEC 1997;Build 18 + N RX0,VALMCNT K DIR,DTOUT,DUOUT,DIRUT,^TMP("PSOAL",$J) S DA=$P(PSOLST(ORN),"^",2),RX0=^PSRX(DA,0),J=DA,RX2=$G(^(2)),R3=$G(^(3)),CMOP=$O(^PSRX(DA,4,0)) + S IEN=0,DIR(0)="LO^1:"_$S(CMOP:8,1:7),DIR("A",1)=" ",DIR("A",2)="Select Activity Log by number",DIR("A",3)="1. Refill 2. Partial 3. Activity 4. Labels" + S DIR("A")=$S(CMOP:"5. Copay 6. ECME 7. CMOP Events 8. All Logs",1:"5. Copay 6. ECME 7. All Logs") + S DIR("B")=$S(CMOP:8,1:7) D ^DIR S PSOELSE=+Y I +Y S Y=$S(CMOP&(Y[8):"1,2,3,4,5,6,7",'CMOP&(Y[7):"1,2,3,4,5,6",1:Y) S ACT=Y D FULL^VALM1 D + .S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Rx #: "_$P(RX0,"^")_" Original Fill Released: " I $P(RX2,"^",13) S DTT=$P(RX2,"^",13) D DAT S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_DAT K DAT,DTT + .I $P(RX2,"^",15) S DTT=$P(RX2,"^",15) D DAT S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_"(Returned to Stock "_DAT_")" K DAT,DTT + .S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Routing: "_$S($P(RX0,"^",11)="W":"Window",1:"Mail")_$S($P($G(^PSRX(DA,"OR1")),"^",5):" Finished by: "_$P(^VA(200,$P(^PSRX(DA,"OR1"),"^",5),0),"^"),1:"") + .D:$G(^PSRX(DA,"H"))]""&($P(PSOLST(ORN),"^",3)="HOLD") HLD^PSOORAL2 + .F LOG=1:1:$L(ACT,",") Q:$P(ACT,",",LOG)']"" S LBL=$P(ACT,",",LOG) D @$S(LBL=1:"RF^PSOORAL2",LBL=2:"PAR^PSOORAL2",LBL=3:"ACT",LBL=5:"COPAY",LBL=6:"ECME",LBL=7:"^PSORXVW2",1:"LBL") + I 'PSOELSE S VALMBCK="" K PSOELSE Q + K ST0,RFL,RFLL,RFL1,II,J,N,PHYS,L1,DIRUT,PSDIV,PSEXDT,MED,M1,FFX,DTT,DAT,R3,RTN,SIG,STA,P1,PL,P0,Z0,Z1,EXDT,IFN,DIR,DUOUT,DTOUT,PSOELSE + K LBL,I,RFDATE,%H,%I,RN,RFT + S PSOAL=IEN K IEN,ACT,LBL,LOG D EN^PSOORAL S VALMBCK="R" + Q +ACT ;activity log + N CNT + S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Activity Log:" + S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="# Date Reason Rx Ref Initiator Of Activity",IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0),"=",79)="=" + I '$O(^PSRX(DA,"A",0)) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="There's NO Activity to report" Q + S CNT=0 + F N=0:0 S N=$O(^PSRX(DA,"A",N)) Q:'N S P1=^(N,0),DTT=P1\1 D DAT D + .I $P(P1,"^",2)="M" Q + .S IEN=IEN+1,CNT=CNT+1,^TMP("PSOAL",$J,IEN,0)=CNT_" "_DAT_" ",$P(RN," ",15)=" ",REA=$P(P1,"^",2),REA=$F("HUCELPRWSIVDABXGKN",REA)-1 + .I REA D + ..S STA=$P("HOLD^UNHOLD^DISCONTINUED^EDIT^RENEWED^PARTIAL^REINSTATE^REPRINT^SUSPENSE^RETURNED^INTERVENTION^DELETED^DRUG INTERACTION^PROCESSED^X-INTERFACE^PATIENT INSTR.^PKI/DEA^DISP COMPLETED^","^",REA) + ..S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_STA_$E(RN,$L(STA)+1,15) + .E S $P(STA," ",15)=" ",^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_STA + .K STA,RN S $P(RN," ",15)=" ",RF=+$P(P1,"^",4) + .S RFT=$S(RF>0&(RF<6):"REFILL "_RF,RF=6:"PARTIAL",RF>6:"REFILL "_(RF-1),1:"ORIGINAL") + .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_RFT_$E(RN,$L(RFT)+1,15)_$S($D(^VA(200,+$P(P1,"^",3),0)):$P(^(0),"^"),1:$P(P1,"^",3)) + .;S:$P(P1,"^",5)]"" IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_$P(P1,"^",5) + .I $P(P1,"^",5)]"" N PSOACBRK,PSOACBRV D + ..S PSOACBRV=$P(P1,"^",5) + ..I $L(PSOACBRV)<71 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_PSOACBRV Q + ..I $E(PSOACBRV,1,70)'[" " S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_$E(PSOACBRV,1,70),IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$E(PSOACBRV,71,245) Q + ..F PSOACBRK=245:-1 Q:PSOACBRK=0 I $E(PSOACBRV,PSOACBRK)=" ",PSOACBRK<71 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_$E(PSOACBRV,1,PSOACBRK),IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$E(PSOACBRV,PSOACBRK,245) Q + .I $P($G(^PSRX(DA,"A",N,1)),"^")]"" S IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0)," ",5)=$P($G(^PSRX(DA,"A",N,1)),"^") I $P($G(^PSRX(DA,"A",N,1)),"^",2)]"" S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_":"_$P($G(^PSRX(DA,"A",N,1)),"^",2) + .I $O(^PSRX(DA,"A",N,2,0)) F I=0:0 S I=$O(^PSRX(DA,"A",N,2,I)) Q:'I S MIG=^PSRX(DA,"A",N,2,I,0) D + ..F SG=1:1:$L(MIG) S:$L(^TMP("PSOAL",$J,IEN,0)_" "_$P(MIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0)," ",9)=" " S:$P(MIG," ",SG)'="" ^TMP("PSOAL",$J,IEN,0)=$G(^TMP("PSOAL",$J,IEN,0))_" "_$P(MIG," ",SG) + K MIG,SG,I + Q +LBL ;label log + S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Label Log:" + S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="# Date Rx Ref Printed By",IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0),"=",79)="=" + I '$O(^PSRX(DA,"L",0)) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="There are NO Labels printed." Q + F L1=0:0 S L1=$O(^PSRX(DA,"L",L1)) Q:'L1 S LBL=^PSRX(DA,"L",L1,0),DTT=$P(^(0),"^") D DAT D + .S $P(RN," ",26)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=L1_" "_DAT_" ",RFT=$S($P(LBL,"^",2):"REFILL "_$P(LBL,"^",2),1:"ORIGINAL"),RFT=RFT_$E(RN,$L(RFT)+1,26) + .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_RFT_$P($G(^VA(200,$P(LBL,"^",4),0)),"^"),IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_$P(LBL,"^",3) + Q + ; +COPAY ;Copay activity log + S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Copay Activity Log:" + S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="# Date Reason Rx Ref Initiator Of Activity",IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0),"=",79)="=" + I '$O(^PSRX(DA,"COPAY",0)) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="There's NO Copay activity to report" Q + F N=0:0 S N=$O(^PSRX(DA,"COPAY",N)) Q:'N S P1=^(N,0),DTT=P1\1 D DAT D + .S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=N_" "_DAT_" ",$P(RN," ",21)=" ",REA=$P(P1,"^",2),REA=$F("ARICE",REA)-1 + .I REA D + ..S STA=$P("ANNUAL CAP REACHED^COPAY RESET^IB-INITIATED COPAY^REMOVE COPAY CHARGE^RX EDITED^","^",REA) + ..S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_STA_$E(RN,$L(STA)+1,21) + .E S $P(STA," ",21)=" ",^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_STA + .K STA,RN S $P(RN," ",15)=" ",RF=+$P(P1,"^",4) + .S RFT=$S(RF>0:"REFILL "_RF,1:"ORIGINAL") + .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_RFT_$E(RN,$L(RFT)+1,15)_$S($D(^VA(200,+$P(P1,"^",3),0)):$P(^(0),"^"),1:$P(P1,"^",3)) + .S:$P(P1,"^",5)]""!($P(P1,"^",6)]"")!($P(P1,"^",7)]"") IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comment: "_$P(P1,"^",5) + .I $P(P1,"^",6)]"" S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_" Old value="_$P(P1,"^",6)_" New value="_$P(P1,"^",7) + Q + ; +ECME ; ECME activity log + N N,P1,RFT,PSOACBRK,PSOACBRV,MIG,SG,I,NOTFND,CNT,LINE + S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="ECME Log:" + S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="# Date/Time Rx Ref Initiator Of Activity" + S IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0),"=",79)="=" + S NOTFND=1,I=0 F S I=$O(^PSRX(DA,"A",I)) Q:'I S Z=$G(^PSRX(DA,"A",I,0)) I $P(Z,"^",2)="M" S NOTFND=0 Q + I NOTFND S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="There's NO ECME Activity to report" Q + S CNT=0 + F N=0:0 S N=$O(^PSRX(DA,"A",N)) Q:'N S P1=^(N,0) D + .I $P(P1,"^",2)'="M" Q + .S IEN=IEN+1,CNT=CNT+1 + .K STA,RN S $P(RN," ",15)=" ",RF=+$P(P1,"^",4) + .S LINE=CNT,$E(LINE,5)=$$FMTE^XLFDT($P(P1,"^"),2),$E(LINE,25)=$S(RF:"REFILL "_RF,1:"ORIGINAL") + .S $E(LINE,41)=$$GET1^DIQ(200,+$P(P1,"^",3),.01) + .S ^TMP("PSOAL",$J,IEN,0)=LINE + .I $P(P1,"^",5)]"" D + ..S PSOACBRV=$P(P1,"^",5) + ..I $L(PSOACBRV)<71 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_PSOACBRV Q + ..I $E(PSOACBRV,1,70)'[" " S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_$E(PSOACBRV,1,70),IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$E(PSOACBRV,71,245) Q + ..F PSOACBRK=245:-1 Q:PSOACBRK=0 I $E(PSOACBRV,PSOACBRK)=" ",PSOACBRK<71 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_$E(PSOACBRV,1,PSOACBRK),IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$E(PSOACBRV,PSOACBRK,245) Q + .I $O(^PSRX(DA,"A",N,2,0)) F I=0:0 S I=$O(^PSRX(DA,"A",N,2,I)) Q:'I S MIG=^PSRX(DA,"A",N,2,I,0) D + ..F SG=1:1:$L(MIG) D + ...S:$L(^TMP("PSOAL",$J,IEN,0)_" "_$P(MIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0)," ",9)=" " + ...S:$P(MIG," ",SG)'="" ^TMP("PSOAL",$J,IEN,0)=$G(^TMP("PSOAL",$J,IEN,0))_" "_$P(MIG," ",SG) + D DISPREJ + Q + ; +DISPREJ ; + N LN,SEQ,REJ,PRI,VAR,X,X1,X2,I,RFT + I '$D(^PSRX(DA,"REJ")) Q + S PRI="PSOAL",$P(LN,"=",80)="",SEQ=0 + S IEN=$G(IEN)+1,^TMP(PRI,$J,IEN,0)=" " + S IEN=IEN+1,^TMP(PRI,$J,IEN,0)="ECME REJECT Log:" + S IEN=IEN+1,^TMP(PRI,$J,IEN,0)="# Date/Time Rcvd Rx Ref Reject Type STATUS Date/Time Resolved" + S IEN=IEN+1,^TMP(PRI,$J,IEN,0)=LN + F REJ=0:0 S REJ=$O(^PSRX(DA,"REJ",REJ)) Q:'REJ D + . S VAR=$G(^PSRX(DA,"REJ",REJ,0)) + . S RFT=+$P(VAR,"^",4) + . S SEQ=SEQ+1,X=SEQ,$E(X,4)=$$FMTE^XLFDT($P(VAR,"^",2),2),$E(X,22)=$S(RFT:"REFILL "_RFT,1:"ORIGINAL") + . S $E(X,32)=$S(+VAR=79:"REFILL TOO SOON",1:"DUR") + . S $E(X,48)=$S($P(VAR,"^",5):"RESOLVED",1:"UNRESOLVED") + . S:$P(VAR,"^",6) $E(X,59)=$$FMTE^XLFDT($P(VAR,"^",6),2) + . ; S:$P(VAR,"^",14) $E(X,67)="(RE-OPENED)" + . S IEN=IEN+1,^TMP(PRI,$J,IEN,0)=X + . I $P(VAR,"^",5) D + . . S IEN=IEN+1,X=$$GET1^DIQ(52.25,REJ_","_DA,12) + . . S X1=$$GET1^DIQ(52.25,REJ_","_DA,13) S:X1'="" X=X1_" ("_X_")" + . . F I=1:1 Q:X="" D + . . . S ^TMP(PRI,$J,IEN,0)=$S(I=1:"Comments: ",1:" ")_$E(X,1,69) + . . . S X=$E(X,70,999) S:X'="" IEN=IEN+1 + Q + ; +DAT S DAT="",DTT=DTT\1 Q:DTT'?7N S DAT=$E(DTT,4,5)_"/"_$E(DTT,6,7)_"/"_$E(DTT,2,3) + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORED1.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORED1.m index 184b7c1d..a1bce690 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORED1.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORED1.m @@ -1,141 +1,141 @@ -PSOORED1 ;ISC-BHAM/SAB - edit orders from backdoor ;5/10/07 8:25am - ;;7.0;OUTPATIENT PHARMACY;**5,23,46,78,114,117,131,146,223,148,244,249,268,206**;DEC 1997;Build 39 - ;External reference ^PS(55 supported by DBIA 2228 - ;External reference ^PS(50.7 supported by DBIA 2223 - ; - ;*244 call to remove DC'd Rx's from Rx ien strings - ; -EN(PSORENW) ; - N LST,ORD,ORN K VALMBCK,PSORX("FN") S PSOAC=1,(PSORX("QFLG"),PSORX("DFLG"))=0 ;D DREN^PSOORNW2,INIT - D INIT - D @$S($P(PSOPAR,"^",7):"AUTO^PSONRXN",1:"MANUAL^PSONRXN") - I '$D(PSONEW("RX #")),'$P(PSOPAR,"^",7) D PAUSE^VALM1 K VALMSG,PSONEW("QFLG") S VALMBCK="Q" Q - I '$D(PSONEW("RX #")) K VALMSG D DEL^PSONEW,PAUSE^VALM1 S VALMBCK="Q" Q - S PSORENW("RX #")=PSONEW("RX #") I '$P(PSOPAR,"^",7) D Q:$G(PSONEW("DFLG"))!($G(PSONEW("QFLG"))) - .S PSOX=PSORENW("RX #") D CHECK^PSONRXN - I $G(PSONEW("DFLG"))!$G(PSONEW("QFLG")) D DEL^PSONEW,PAUSE^VALM1 S VALMBCK="Q" K PSORENW Q - D EN^PSOORNE1(.PSORENW) I '$G(PSORX("FN")) D:$P($G(PSOPAR),"^",7)=1 S VALMBCK="Q" Q - .S DIE="^PS(59,",DA=PSOSITE,PSOY=$O(PSONEW("OLD LAST RX#","")),PSOX=PSONEW("OLD LAST RX#",PSOY) - .L +^PS(59,+PSOSITE,PSOY):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) - .S DR=$S(PSOY=8:"2003////"_PSOX,PSOY=3:"1002.1////"_PSOX,1:"2003////"_PSOX) - .D:PSOX<$P(^PS(59,+PSOSITE,PSOY),"^",3) ^DIE K DIE,X,Y L -^PS(59,+PSOSITE,PSOY) - .I $D(PSONEW("RX #")) L -^PSRX("B",PSONEW("RX #")) - .K PSOX,PSOY Q - Q:$G(COPY) -TRY S $P(^PSRX(PSORENW("OIRXN"),"STA"),"^")=15,DA=PSORENW("OIRXN") - S $P(^PSRX(DA,3),"^",5)=DT,$P(^PSRX(DA,3),"^",10)=$P(^PSRX(DA,3),"^") - D REVERSE^PSOBPSU1(DA,,"DC",7),CAN^PSOTPCAN(DA) - D RMP^PSOCAN3 ;*244 - ;cancel/discontinue action - S PHARM="",STAT="RP",COMM="Prescription discontinued due to editing." D EN^PSOHLSN1(DA,STAT,PHARM,COMM,PSONOOR) K STAT,PHARM,COMM - S ACOM="Discontinued due to editing. New Rx created "_$P(^PSRX(PSORENW("IRXN"),0),"^")_"." - I $G(^PSRX(DA,"H"))]"" D - .I $P(^PSRX(DA,"STA"),"^")=3!($P(^("STA"),"^")=16) D - ..S DIE=52,DR="22///"_$P(^PSRX(DA,3),"^") D ^DIE S ACOM="Discontinued due to editing while on hold. " K:$P(^PSRX(DA,"H"),"^") ^PSRX("AH",$P(^PSRX(DA,"H"),"^"),DA) - ..S ^PSRX(DA,"H")="" - S RXDA=DA,(DA,SUSDA)=$O(^PS(52.5,"B",RXDA,0)) D:DA - .S SUSD=$P($G(^PS(52.5,DA,0)),"^",2) - .S:+$G(^PS(52.5,DA,"P"))'=1 ACOM="Discontinued due to editing while suspended." - .I $O(^PSRX(RXDA,1,0)) S DA=RXDA D:'$G(^PS(52.5,+SUSDA,"P")) REF^PSOCAN2 - .S DA=SUSDA,DIK="^PS(52.5," D ^DIK K DIK - K SUSD,SUSDA S DA=RXDA,RXREF=0,PSODFN=+$P(^PSRX(DA,0),"^",2) D - .S ACNT=0 F SUB=0:0 S SUB=$O(^PSRX(DA,"A",SUB)) Q:'SUB S ACNT=SUB - .S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(DA,1,RF)) Q:'RF S RFCNT=RF S:RF>5 RFCNT=RF+1 - .D NOW^%DTC S ^PSRX(DA,"A",0)="^52.3DA^"_(ACNT+1)_"^"_(ACNT+1),^PSRX(DA,"A",ACNT+1,0)=%_"^C^"_DUZ_"^"_RFCNT_"^"_$G(ACOM) - .I $G(PSOOIFLG),'$G(PSOMRFLG) S $P(^PSRX(DA,"A",ACNT+1,1),"^")="Pharmacy Orderable Item Edited." - .I '$G(PSOOIFLG),$G(PSOMRFLG) S $P(^PSRX(DA,"A",ACNT+1,1),"^")="Medication Route/Schedule Edited." - .I $G(PSOOIFLG),$G(PSOMRFLG) S $P(^PSRX(DA,"A",ACNT+1,1),"^")="Pharmacy Orderable Item and Medication Route/Schedule Edited." - .S REA="C" D EXP^PSOHELP1 - I $G(^PS(52.4,DA,0))]"" S PSCDA=DA,DIK="^PS(52.4," D ^DIK S DA=PSCDA K DIK,PSCDA - Q -INS K X,QUIT,Y,DIR,DIRUT,DUOUT,DTOUT,DIC,INSDEL,UPMI,^TMP($J,"INS1") - I '$O(^PSRX(PSORXED("IRXN"),6,0)),'$O(PSORXED("DOSE",0)) D UPMI Q:$G(QUIT) ;G INS1 - I $G(^PSRX(PSORXED("IRXN"),"INS"))]"" S PSORXED("FLD",114)=^PSRX(PSORXED("IRXN"),"INS") K UPMI G INS1 - K DD,GG F I=0:0 S I=$O(^PSRX(PSORXED("IRXN"),"INS1",I)) Q:'I S DD=$G(DD)+1 - I $G(DD)=1 S PSORXED("FLD",114)=^PSRX(PSORXED("IRXN"),"INS1",$O(^PSRX(PSORXED("IRXN"),"INS1",0)),0) K UPMI,DD G INS1 - I $O(^PSRX(PSORXED("IRXN"),"INS1",0)) D G INSX - .F I=0:0 S I=$O(^PSRX(PSORXED("IRXN"),"INS1",I)) Q:'I S ^TMP($J,"INS1",I,0)=^PSRX(PSORXED("IRXN"),"INS1",I,0) - .S ^TMP($J,"INS1",0)=^PSRX(PSORXED("IRXN"),"INS1",0) - .S DIC="^TMP($J,""INS1"",",DWPK=2,DWLW=80 D EN^DIWE I $G(X)="^" K ^TMP($J,"INS1") Q - .I '$O(^TMP($J,"INS1",0)) S INSDEL=1 - .S D=0 F S D=$O(^PSRX(PSORXED("IRXN"),"INS1",D)) Q:'D S PSORXED("SIG",D)=^PSRX(PSORXED("IRXN"),"INS1",D,0) -INS1 K Y,DIR,DIRUT,DUOUT,DTOUT,DIC,X - I $G(UPMI) K UPMI I $G(^PS(50.7,PSODRUG("OI"),"INS"))]"" S PSORXED("FLD",114)=^PS(50.7,PSODRUG("OI"),"INS") - S:$G(PSORXED("FLD",114))]"" DIR("B")=PSORXED("FLD",114) - S DIR("?")="Enter Quick codes or Free Text",DIR(0)="52,114" D ^DIR - I $D(DTOUT)!($D(DUOUT))!($G(PSORXED("FLD",114))=X) K PSORXED("FLD",114) G INSX - I X'="",X'="@" D SIG^PSOHELP G INS1:'$D(X) - S PSORXED("FLD",114)=X - I $G(INS1)]"" W " ("_$E(INS1,2,9999999)_")" - G:(X']""!(X="@")) INSX - S (PSORXED("INS"),PSORXED("SIG",1))=$E(INS1,2,9999999) D EN^PSOFSIG(.PSORXED) -INSX I $P($G(^PS(55,PSODFN,"LAN")),"^") K DIR D - .I $G(^PSRX(PSORXED("IRXN"),"INSS"))]"" S PSORXED("SINS")=^PSRX(PSORXED("IRXN"),"INSS") - .D SINS^PSODIR(.PSORXED) I $G(PSORXED("SINS"))']"" K ^PSRX(PSORXED("IRXN"),"INSS") Q - .S PSORXED("FLD",114.1)=PSORXED("SINS") - K DIRUT,DUOUT,DTOUT,DIR,X,Y,DIC,DWPK - Q -INIT ;setup psorenw array - S PSORENW("RX0")=^PSRX(PSORENW("IRXN"),0),PSORENW("RX2")=^(2),PSORENW("RX3")=^(3),PSORENW("STA")=^("STA"),PSORENW("TN")=$G(^("TN")) - I $G(PSOSIGFL),$G(PSORX("SIG"))]"" S PSORENW("SIG")=PSORX("SIG"),SIGOK=0 - E D - .I '$P($G(^PSRX(PSORENW("IRXN"),"SIG")),"^",2) S PSORENW("SIG")=$P($G(^("SIG")),"^") - .E D - ..S SIGOK=1 Q:$O(SIG(0)) - ..S D=0 F I=0:0 S D=D+1,I=$O(^PSRX(PSORENW("IRXN"),"SIG1",I)) Q:'I S SIG(D)=^PSRX(PSORENW("IRXN"),"SIG1",I,0) - ..K PSOX1,D - S PSORENW("OIRXN")=PSORENW("IRXN") - S PSORENW("PROVIDER")=$S($G(PSORENW("PROVIDER")):PSORENW("PROVIDER"),1:$P(PSORENW("RX0"),"^",4)) - S (PSORENW("PROVIDER NAME"),PSORX("PROVIDER NAME"))=$P($G(^VA(200,PSORENW("PROVIDER"),0)),"^") - I $P($G(^VA(200,PSORENW("PROVIDER"),"PS")),"^",7),$P($G(^("PS")),"^",8) S PSORENW("COSIGNING PROVIDER")=$P($G(^("PS")),"^",8) - S PSORENW("CLINIC")=$S($G(PSORENW("CLINIC")):PSORENW("CLINIC"),1:$P(PSORENW("RX0"),"^",5)) - S PSORENW("REMARKS")="New Order Created by "_$S($G(COPY)&('$G(PSOEDIT)):"copying",1:"editing")_" Rx # "_$P(PSORENW("RX0"),"^")_"." - S PSORENW("COSIGNER")=$S($G(PSORENW("COSIGNER")):PSORENW("COSIGNER"),$P(PSORENW("RX3"),"^",3):$P(PSORENW("RX3"),"^",3),1:"") - K:PSORENW("COSIGNER")="" PSORENW("COSIGNER") - S PSORENW("PSODFN")=$P(PSORENW("RX0"),"^",2) - S PSORENW("ORX #")=$P(PSORENW("RX0"),"^") - S:$G(PSODRUG("IEN")) PSORENW("DRUG IEN")=PSODRUG("IEN") - I $G(PSORENW("DAYS SUPPLY")) G QTY - S PSORENW("DAYS SUPPLY")=$S($D(CLOZPAT):7,1:$P(PSORENW("RX0"),"^",8)) -QTY S PSORENW("QTY")=$S($G(PSORENW("QTY")):PSORENW("QTY"),1:$P(PSORENW("RX0"),"^",7)) -RFN S PSORENW("# OF REFILLS")=$S($D(CLOZPAT):0,$G(PSORENW("# OF REFILLS")):PSORENW("# OF REFILLS"),1:$P(PSORENW("RX0"),"^",9)) - S (PSOID,Y,PSORENW("FILL DATE"),PSORENW("ISSUE DATE"))=DT - S:PSORENW("CLINIC") PSORX("CLINIC")=$P(^SC(+PSORENW("CLINIC"),0),"^") - S PSORENW("PATIENT STATUS")=$S($G(PSORENW("PATIENT STATUS")):PSORENW("PATIENT STATUS"),'$P(PSORENW("RX0"),"^",3):$G(^PS(55,PSORENW("PSODFN"),"PS")),1:$P(PSORENW("RX0"),"^",3)) - S PSORENW("PTST NODE")=$G(^PS(53,PSORENW("PATIENT STATUS"),0)) - S PSDAYS=$S($G(PSORENW("DAYS SUPPLY")):PSORENW("DAYS SUPPLY"),'$P(PSORENW("RX0"),"^",8):$P(PSORENW("PTST NODE"),"^",3),1:$P(PSORENW("RX0"),"^",8)) - I $G(PSODRUG("IEN")) S DREN=PSODRUG("IEN"),POERR=1 D DRG^PSOORDRG K POERR - D:$G(PSORENW("# OF REFILLS"))']"" RF - S PSORENW("MAIL/WINDOW")=$S($G(PSORENW("MAIL/WINDOW"))]"":PSORENW("MAIL/WINDOW"),1:$P(PSORENW("RX0"),"^",11)) - S PSORX("MAIL/WINDOW")=$S(PSORENW("MAIL/WINDOW")="W":"WINDOW",1:"MAIL") - S PSORENW("COPIES")=$S($G(PSORENW("COPIES")):PSORENW("COPIES"),$P(PSORENW("RX0"),"^",18):$P(PSORENW("RX0"),"^",18),1:1) - S PSORENW("CLERK CODE")=DUZ - S:$G(PSORX("CLERK CODE"))']"" PSORX("CLERK CODE")=$P($G(^VA(200,DUZ,0)),"^") - Q:$D(COPY) S PSORENW("ENT")=0 ;Q:$G(PSOSIGFL)!($D(COPY)) - K PSORENW("ENT") F I=0:0 S I=$O(PSORENW("DOSE",I)) Q:'I S PSORENW("ENT")=$G(PSORENW("ENT"))+1 - I $O(^TMP($J,"INS1",0)) D - .K PSORXED("SIG"),DD - .F I=0:0 S I=$O(^TMP($J,"INS1",I)) Q:'I S PSORENW("SIG",I)=^TMP($J,"INS1",I,0) - .K ^TMP($J,"INS1") - I $G(^PSRX(PSORENW("IRXN"),"INS"))]"" S PSORENW("INS")=^PSRX(PSORENW("IRXN"),"INS") - I $G(^PSRX(PSORENW("IRXN"),"INSS"))]"" S PSORENW("SINS")=^PSRX(PSORENW("IRXN"),"INSS") - I '$G(PSORENW("ENT")),'$G(PSOSIGFL) D DOLST1^PSOORED3(.PSORENW) S PSORENW("ENT")=+$G(OLENT) - Q -RF ;# of refills - S PTRF=$S($P(PSORENW("PTST NODE"),"^",4)]"":$P(PSORENW("PTST NODE"),"^",4),1:11) - S CS=0 F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)="" I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S CS=1 - I CS D - .S PSOX1=$S(PTRF>5:5,1:PTRF),PSOX=$S(PSOX1=5:5,1:PSOX1) - .S PSOX=$S('PSOX:0,PSDAYS=90:1,1:PSOX),PSDY1=$S(PSDAYS<60:5,PSDAYS'<60&(PSDAYS'>89):2,PSDAYS=90:1,1:0) S PSORENW("# OF REFILLS")=$S(PSOX'>PSDY1:PSOX,1:PSDY1) - E D - .S PSOX1=PTRF,PSOX=$S(PSOX1=11:11,1:PSOX1),PSOX=$S('PSOX:0,PSDAYS=90:3,1:PSOX) - .S PSDY1=$S(PSDAYS<60:11,PSDAYS'<60&(PSDAYS'>89):5,PSDAYS=90:3,1:0) S PSORENW("# OF REFILLS")=$S(PSOX'>PSDY1:PSOX,1:PSDY1) - I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F")!(PSODRUG("DEA")[1)!(PSODRUG("DEA")[2) S PSORENW("# OF REFILLS")=0 - K PSDY,PSDY1,PTRF,PSOX,PSOX1,PSDAYS,CS - Q -UPMI ;add dosing data for pre-poe rxs - W !! K PSONEW("DFLG"),DIR,DIRUT,DTOUT,DUOUT S DIR(0)="Y",DIR("B")="No",DIR("A")="Dosing Instructions Are Missing!! Do You Want to Add Them" - D ^DIR I 'Y!($D(DIRUT)) S QUIT=1 K DIR,DIRUT,DUOT,DUOUT Q - S UPMI=1,EDTHLD=$G(PSORX("EDIT")) K PSORX("EDIT") - D DOSE1^PSOORED5(.PSORXED) S (PSORXED,PSORX("EDIT"))=EDTHLD K EDTHLD I $G(PSONEW("DFLG")) S QUIT=1 - Q +PSOORED1 ;ISC-BHAM/SAB - edit orders from backdoor ;6/30/06 10:21am + ;;7.0;OUTPATIENT PHARMACY;**5,23,46,78,114,117,131,146,223,148,244,249,268**;DEC 1997;Build 9 + ;External reference ^PS(55 supported by DBIA 2228 + ;External reference ^PS(50.7 supported by DBIA 2223 + ; + ;*244 call to remove DC'd Rx's from Rx ien strings + ; +EN(PSORENW) ; + N LST,ORD,ORN K VALMBCK,PSORX("FN") S PSOAC=1,(PSORX("QFLG"),PSORX("DFLG"))=0 ;D DREN^PSOORNW2,INIT + D INIT + D @$S($P(PSOPAR,"^",7):"AUTO^PSONRXN",1:"MANUAL^PSONRXN") + I '$D(PSONEW("RX #")),'$P(PSOPAR,"^",7) D PAUSE^VALM1 K VALMSG,PSONEW("QFLG") S VALMBCK="Q" Q + I '$D(PSONEW("RX #")) K VALMSG D DEL^PSONEW,PAUSE^VALM1 S VALMBCK="Q" Q + S PSORENW("RX #")=PSONEW("RX #") I '$P(PSOPAR,"^",7) D Q:$G(PSONEW("DFLG"))!($G(PSONEW("QFLG"))) + .S PSOX=PSORENW("RX #") D CHECK^PSONRXN + I $G(PSONEW("DFLG"))!$G(PSONEW("QFLG")) D DEL^PSONEW,PAUSE^VALM1 S VALMBCK="Q" K PSORENW Q + D EN^PSOORNE1(.PSORENW) I '$G(PSORX("FN")) D:$P($G(PSOPAR),"^",7)=1 S VALMBCK="Q" Q + .S DIE="^PS(59,",DA=PSOSITE,PSOY=$O(PSONEW("OLD LAST RX#","")),PSOX=PSONEW("OLD LAST RX#",PSOY) + .L +^PS(59,+PSOSITE,PSOY):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) + .S DR=$S(PSOY=8:"2003////"_PSOX,PSOY=3:"1002.1////"_PSOX,1:"2003////"_PSOX) + .D:PSOX<$P(^PS(59,+PSOSITE,PSOY),"^",3) ^DIE K DIE,X,Y L -^PS(59,+PSOSITE,PSOY) + .I $D(PSONEW("RX #")) L -^PSRX("B",PSONEW("RX #")) + .K PSOX,PSOY Q + Q:$G(COPY) +TRY S $P(^PSRX(PSORENW("OIRXN"),"STA"),"^")=15,DA=PSORENW("OIRXN") + S $P(^PSRX(DA,3),"^",5)=DT,$P(^PSRX(DA,3),"^",10)=$P(^PSRX(DA,3),"^") + D REVERSE^PSOBPSU1(DA,,"DC",7),CAN^PSOTPCAN(DA) + D RMP^PSOCAN3 ;*244 + ;cancel/discontinue action + S PHARM="",STAT="RP",COMM="Prescription discontinued due to editing." D EN^PSOHLSN1(DA,STAT,PHARM,COMM,PSONOOR) K STAT,PHARM,COMM + S ACOM="Discontinued due to editing. New Rx created "_$P(^PSRX(PSORENW("IRXN"),0),"^")_"." + I $G(^PSRX(DA,"H"))]"" D + .I $P(^PSRX(DA,"STA"),"^")=3!($P(^("STA"),"^")=16) D + ..S DIE=52,DR="22///"_$P(^PSRX(DA,3),"^") D ^DIE S ACOM="Discontinued due to editing while on hold. " K:$P(^PSRX(DA,"H"),"^") ^PSRX("AH",$P(^PSRX(DA,"H"),"^"),DA) + ..S ^PSRX(DA,"H")="" + S RXDA=DA,(DA,SUSDA)=$O(^PS(52.5,"B",RXDA,0)) D:DA + .S SUSD=$P($G(^PS(52.5,DA,0)),"^",2) + .S:+$G(^PS(52.5,DA,"P"))'=1 ACOM="Discontinued due to editing while suspended." + .I $O(^PSRX(RXDA,1,0)) S DA=RXDA D:'$G(^PS(52.5,+SUSDA,"P")) REF^PSOCAN2 + .S DA=SUSDA,DIK="^PS(52.5," D ^DIK K DIK + K SUSD,SUSDA S DA=RXDA,RXREF=0,PSODFN=+$P(^PSRX(DA,0),"^",2) D + .S ACNT=0 F SUB=0:0 S SUB=$O(^PSRX(DA,"A",SUB)) Q:'SUB S ACNT=SUB + .S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(DA,1,RF)) Q:'RF S RFCNT=RF S:RF>5 RFCNT=RF+1 + .D NOW^%DTC S ^PSRX(DA,"A",0)="^52.3DA^"_(ACNT+1)_"^"_(ACNT+1),^PSRX(DA,"A",ACNT+1,0)=%_"^C^"_DUZ_"^"_RFCNT_"^"_$G(ACOM) + .I $G(PSOOIFLG),'$G(PSOMRFLG) S $P(^PSRX(DA,"A",ACNT+1,1),"^")="Pharmacy Orderable Item Edited." + .I '$G(PSOOIFLG),$G(PSOMRFLG) S $P(^PSRX(DA,"A",ACNT+1,1),"^")="Medication Route/Schedule Edited." + .I $G(PSOOIFLG),$G(PSOMRFLG) S $P(^PSRX(DA,"A",ACNT+1,1),"^")="Pharmacy Orderable Item and Medication Route/Schedule Edited." + .S REA="C" D EXP^PSOHELP1 + I $G(^PS(52.4,DA,0))]"" S PSCDA=DA,DIK="^PS(52.4," D ^DIK S DA=PSCDA K DIK,PSCDA + Q +INS K X,QUIT,Y,DIR,DIRUT,DUOUT,DTOUT,DIC,INSDEL,UPMI,^TMP($J,"INS1") + I '$O(^PSRX(PSORXED("IRXN"),6,0)),'$O(PSORXED("DOSE",0)) D UPMI Q:$G(QUIT) ;G INS1 + I $G(^PSRX(PSORXED("IRXN"),"INS"))]"" S PSORXED("FLD",114)=^PSRX(PSORXED("IRXN"),"INS") K UPMI G INS1 + K DD,GG F I=0:0 S I=$O(^PSRX(PSORXED("IRXN"),"INS1",I)) Q:'I S DD=$G(DD)+1 + I $G(DD)=1 S PSORXED("FLD",114)=^PSRX(PSORXED("IRXN"),"INS1",$O(^PSRX(PSORXED("IRXN"),"INS1",0)),0) K UPMI,DD G INS1 + I $O(^PSRX(PSORXED("IRXN"),"INS1",0)) D G INSX + .F I=0:0 S I=$O(^PSRX(PSORXED("IRXN"),"INS1",I)) Q:'I S ^TMP($J,"INS1",I,0)=^PSRX(PSORXED("IRXN"),"INS1",I,0) + .S ^TMP($J,"INS1",0)=^PSRX(PSORXED("IRXN"),"INS1",0) + .S DIC="^TMP($J,""INS1"",",DWPK=2,DWLW=80 D EN^DIWE I $G(X)="^" K ^TMP($J,"INS1") Q + .I '$O(^TMP($J,"INS1",0)) S INSDEL=1 + .S D=0 F S D=$O(^PSRX(PSORXED("IRXN"),"INS1",D)) Q:'D S PSORXED("SIG",D)=^PSRX(PSORXED("IRXN"),"INS1",D,0) +INS1 K Y,DIR,DIRUT,DUOUT,DTOUT,DIC,X + I $G(UPMI) K UPMI I $G(^PS(50.7,PSODRUG("OI"),"INS"))]"" S PSORXED("FLD",114)=^PS(50.7,PSODRUG("OI"),"INS") + S:$G(PSORXED("FLD",114))]"" DIR("B")=PSORXED("FLD",114) + S DIR("?")="Enter Quick codes or Free Text",DIR(0)="52,114" D ^DIR + I $D(DTOUT)!($D(DUOUT))!($G(PSORXED("FLD",114))=X) K PSORXED("FLD",114) G INSX + I X'="",X'="@" D SIG^PSOHELP G INS1:'$D(X) + S PSORXED("FLD",114)=X + I $G(INS1)]"" W " ("_$E(INS1,2,9999999)_")" + G:(X']""!(X="@")) INSX + S (PSORXED("INS"),PSORXED("SIG",1))=$E(INS1,2,9999999) D EN^PSOFSIG(.PSORXED) +INSX I $P($G(^PS(55,PSODFN,"LAN")),"^") K DIR D + .I $G(^PSRX(PSORXED("IRXN"),"INSS"))]"" S PSORXED("SINS")=^PSRX(PSORXED("IRXN"),"INSS") + .D SINS^PSODIR(.PSORXED) I $G(PSORXED("SINS"))']"" K ^PSRX(PSORXED("IRXN"),"INSS") Q + .S PSORXED("FLD",114.1)=PSORXED("SINS") + K DIRUT,DUOUT,DTOUT,DIR,X,Y,DIC,DWPK + Q +INIT ;setup psorenw array + S PSORENW("RX0")=^PSRX(PSORENW("IRXN"),0),PSORENW("RX2")=^(2),PSORENW("RX3")=^(3),PSORENW("STA")=^("STA"),PSORENW("TN")=$G(^("TN")) + I $G(PSOSIGFL),$G(PSORX("SIG"))]"" S PSORENW("SIG")=PSORX("SIG"),SIGOK=0 + E D + .I '$P($G(^PSRX(PSORENW("IRXN"),"SIG")),"^",2) S PSORENW("SIG")=$P($G(^("SIG")),"^") + .E D + ..S SIGOK=1 Q:$O(SIG(0)) + ..S D=0 F I=0:0 S D=D+1,I=$O(^PSRX(PSORENW("IRXN"),"SIG1",I)) Q:'I S SIG(D)=^PSRX(PSORENW("IRXN"),"SIG1",I,0) + ..K PSOX1,D + S PSORENW("OIRXN")=PSORENW("IRXN") + S PSORENW("PROVIDER")=$S($G(PSORENW("PROVIDER")):PSORENW("PROVIDER"),1:$P(PSORENW("RX0"),"^",4)) + S (PSORENW("PROVIDER NAME"),PSORX("PROVIDER NAME"))=$P($G(^VA(200,PSORENW("PROVIDER"),0)),"^") + I $P($G(^VA(200,PSORENW("PROVIDER"),"PS")),"^",7),$P($G(^("PS")),"^",8) S PSORENW("COSIGNING PROVIDER")=$P($G(^("PS")),"^",8) + S PSORENW("CLINIC")=$S($G(PSORENW("CLINIC")):PSORENW("CLINIC"),1:$P(PSORENW("RX0"),"^",5)) + S PSORENW("REMARKS")="New Order Created by "_$S($G(COPY)&('$G(PSOEDIT)):"copying",1:"editing")_" Rx # "_$P(PSORENW("RX0"),"^")_"." + S PSORENW("COSIGNER")=$S($G(PSORENW("COSIGNER")):PSORENW("COSIGNER"),$P(PSORENW("RX3"),"^",3):$P(PSORENW("RX3"),"^",3),1:"") + K:PSORENW("COSIGNER")="" PSORENW("COSIGNER") + S PSORENW("PSODFN")=$P(PSORENW("RX0"),"^",2) + S PSORENW("ORX #")=$P(PSORENW("RX0"),"^") + S:$G(PSODRUG("IEN")) PSORENW("DRUG IEN")=PSODRUG("IEN") + I $G(PSORENW("DAYS SUPPLY")) G QTY + S PSORENW("DAYS SUPPLY")=$S($D(CLOZPAT):7,1:$P(PSORENW("RX0"),"^",8)) +QTY S PSORENW("QTY")=$S($G(PSORENW("QTY")):PSORENW("QTY"),1:$P(PSORENW("RX0"),"^",7)) +RFN S PSORENW("# OF REFILLS")=$S($D(CLOZPAT):0,$G(PSORENW("# OF REFILLS")):PSORENW("# OF REFILLS"),1:$P(PSORENW("RX0"),"^",9)) + S (PSOID,Y,PSORENW("FILL DATE"),PSORENW("ISSUE DATE"))=DT + S:PSORENW("CLINIC") PSORX("CLINIC")=$P(^SC(+PSORENW("CLINIC"),0),"^") + S PSORENW("PATIENT STATUS")=$S($G(PSORENW("PATIENT STATUS")):PSORENW("PATIENT STATUS"),'$P(PSORENW("RX0"),"^",3):$G(^PS(55,PSORENW("PSODFN"),"PS")),1:$P(PSORENW("RX0"),"^",3)) + S PSORENW("PTST NODE")=$G(^PS(53,PSORENW("PATIENT STATUS"),0)) + S PSDAYS=$S($G(PSORENW("DAYS SUPPLY")):PSORENW("DAYS SUPPLY"),'$P(PSORENW("RX0"),"^",8):$P(PSORENW("PTST NODE"),"^",3),1:$P(PSORENW("RX0"),"^",8)) + I $G(PSODRUG("IEN")) S DREN=PSODRUG("IEN"),POERR=1 D DRG^PSOORDRG K POERR + D:$G(PSORENW("# OF REFILLS"))']"" RF + S PSORENW("MAIL/WINDOW")=$S($G(PSORENW("MAIL/WINDOW"))]"":PSORENW("MAIL/WINDOW"),1:$P(PSORENW("RX0"),"^",11)) + S PSORX("MAIL/WINDOW")=$S(PSORENW("MAIL/WINDOW")="W":"WINDOW",1:"MAIL") + S PSORENW("COPIES")=$S($G(PSORENW("COPIES")):PSORENW("COPIES"),$P(PSORENW("RX0"),"^",18):$P(PSORENW("RX0"),"^",18),1:1) + S PSORENW("CLERK CODE")=DUZ + S:$G(PSORX("CLERK CODE"))']"" PSORX("CLERK CODE")=$P($G(^VA(200,DUZ,0)),"^") + Q:$D(COPY) S PSORENW("ENT")=0 ;Q:$G(PSOSIGFL)!($D(COPY)) + K PSORENW("ENT") F I=0:0 S I=$O(PSORENW("DOSE",I)) Q:'I S PSORENW("ENT")=$G(PSORENW("ENT"))+1 + I $O(^TMP($J,"INS1",0)) D + .K PSORXED("SIG"),DD + .F I=0:0 S I=$O(^TMP($J,"INS1",I)) Q:'I S PSORENW("SIG",I)=^TMP($J,"INS1",I,0) + .K ^TMP($J,"INS1") + I $G(^PSRX(PSORENW("IRXN"),"INS"))]"" S PSORENW("INS")=^PSRX(PSORENW("IRXN"),"INS") + I $G(^PSRX(PSORENW("IRXN"),"INSS"))]"" S PSORENW("SINS")=^PSRX(PSORENW("IRXN"),"INSS") + I '$G(PSORENW("ENT")),'$G(PSOSIGFL) D DOLST1^PSOORED3(.PSORENW) S PSORENW("ENT")=+$G(OLENT) + Q +RF ;# of refills + S PTRF=$S($P(PSORENW("PTST NODE"),"^",4)]"":$P(PSORENW("PTST NODE"),"^",4),1:11) + S CS=0 F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)="" I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S CS=1 + I CS D + .S PSOX1=$S(PTRF>5:5,1:PTRF),PSOX=$S(PSOX1=5:5,1:PSOX1) + .S PSOX=$S('PSOX:0,PSDAYS=90:1,1:PSOX),PSDY1=$S(PSDAYS<60:5,PSDAYS'<60&(PSDAYS'>89):2,PSDAYS=90:1,1:0) S PSORENW("# OF REFILLS")=$S(PSOX'>PSDY1:PSOX,1:PSDY1) + E D + .S PSOX1=PTRF,PSOX=$S(PSOX1=11:11,1:PSOX1),PSOX=$S('PSOX:0,PSDAYS=90:3,1:PSOX) + .S PSDY1=$S(PSDAYS<60:11,PSDAYS'<60&(PSDAYS'>89):5,PSDAYS=90:3,1:0) S PSORENW("# OF REFILLS")=$S(PSOX'>PSDY1:PSOX,1:PSDY1) + I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F") S PSORENW("# OF REFILLS")=0 + K PSDY,PSDY1,PTRF,PSOX,PSOX1,PSDAYS,CS + Q +UPMI ;add dosing data for pre-poe rxs + W !! K PSONEW("DFLG"),DIR,DIRUT,DTOUT,DUOUT S DIR(0)="Y",DIR("B")="No",DIR("A")="Dosing Instructions Are Missing!! Do You Want to Add Them" + D ^DIR I 'Y!($D(DIRUT)) S QUIT=1 K DIR,DIRUT,DUOT,DUOUT Q + S UPMI=1,EDTHLD=$G(PSORX("EDIT")) K PSORX("EDIT") + D DOSE1^PSOORED5(.PSORXED) S (PSORXED,PSORX("EDIT"))=EDTHLD K EDTHLD I $G(PSONEW("DFLG")) S QUIT=1 + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORED2.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORED2.m index 1b3773d8..dac58627 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORED2.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORED2.m @@ -1,148 +1,147 @@ -PSOORED2 ;ISC-BHAM/SAB-edit orders from backdoor con't ;03/06/95 10:24 - ;;7.0;OUTPATIENT PHARMACY;**2,51,46,78,102,114,117,133,159,148,247,260,281**;DEC 1997;Build 41 - ;Reference to $$DIVNCPDP^BPSBUTL supported by IA 4719 - ;Reference to $$ECMEON^BPSUTIL supported by IA 4410 - ;called from psooredt. cmop edit checks. - Q -ISDT D CHK K RF I $G(CMRL) W !,"Released by CMOP. No editing allowed on Issue Date." D PAUSE^VALM1 K CMRL Q - S %DT="AEX",%DT(0)=-$P(^PSRX(DA,2),"^",2),Y=$P(RX0,"^",13) X ^DD("DD") S %DT("A")="ISSUE DATE: ",%DT("B")=Y D ^%DT I "^"[$E(X) K X,Y,%DT,DTOUT,DUOUT Q - G:Y=-1 ISDT S PSORXED("FLD",1)=Y - ;S DR="1///"_Y,DIE=52 D ^DIE - D KV K X,Y,%DT - Q -FLDT D CHK K RF I $G(CMRL) W !,"Released by CMOP. No editing allowed on Fill Date." D PAUSE^VALM1 K CMRL Q - D KV S Y=$P(^PSRX(DA,2),"^",2) X ^DD("DD") S DIR("A")="FILL DATE",DIR("B")=Y - S DIR(0)="D^"_$P(RX0,"^",13)_":"_$P(PSORXED("RX2"),"^",6)_":EX" - S DIR("?",1)="The earliest fill date allowed is determined by the Issue Date,",DIR("?",2)="the Fill Date cannot be before the Issue Date or past the Expiration Date." - S DIR("?")="Both the month and day are required." D ^DIR - I $D(DIRUT) D KV K PSORXED("FLD",22),X,Y Q - S PSORXED("FLD",22)=Y ;S DR="22R///"_Y,DIE=52 D ^DIE - K X,Y -KV K DIR,DUOUT,DTOUT,DIRUT - Q -CHK I $D(^PSRX("AR",+$P(PSORXED("RX2"),"^",13),PSORXED("IRXN"))) S CMRL=1 Q - F RF=0:0 S RF=$O(^PSRX(PSORXED("IRXN"),1,RF)) Q:'RF I $D(^PSRX("AR",+$P(^PSRX(PSORXED("IRXN"),1,RF,0),"^",18),PSORXED("IRXN"))) S CMRL=1 - Q -CHK1 I +^PSRX(PSORXED("IRXN"),"STA")=5 D Q:'$G(CMRL) - .S SURX=$O(^PS(52.5,PSORXED("IRXN"),0)) Q:'SURX I $P(^PS(52.5,SURX,0),"^",7)']""!($P(^(0),"^",7)="Q") S CMRL=1 - .E S CMRL=0 - F FEV=0:0 S FEV=$O(^PSRX(PSORXED("IRXN"),4,FEV)) Q:'FEV I '$P(^PSRX(PSORXED("IRXN"),4,FEV,0),"^",3),$P(^(0),"^",4)<3 S CMRL=0 - Q -REF ;shows refill info - S RFN=0 F N=0:0 S N=$O(^PSRX(PSORXED("IRXN"),1,N)) Q:'N S RFM=N,RFN=RFN+1 - ;G:RFM=1 SRF - W ! K DA,DR D KV S DIR(0)="Y",DIR("B")="No",DIR("A")="There "_$S(RFN>1:"are ",1:"is ")_RFN_" refill"_$S(RFN>1:"s.",1:".")_" Do you want to edit" - D ^DIR D KV Q:'Y -SRF W !!,"# Log Date Refill Date Qty Routing Lot # Pharmacist",! F I=1:1:80 W "=" - F N=0:0 S N=$O(^PSRX(PSORXED("IRXN"),1,N)) Q:'N S P1=^(N,0) D - .S DTT=$P(P1,"^",8)\1 D DAT S LOG=DAT,DTT=$P(P1,"^"),$P(RN," ",10)=" " D DAT - .W !,N_" "_LOG_" "_DAT_" "_$P(P1,"^",4)_$E(" ",$L($P(P1,"^",4))+1,15)_" "_$S($P(P1,"^",2)="M":"MAIL ",1:"WINDOW")_" "_$P(P1,"^",6)_$E(RN,$L($P(P1,"^",6))+1,12) - .W $E($S($D(^VA(200,+$P(P1,"^",5),0)):$P(^(0),"^"),1:""),1,16) - .S PSDIV=$S($D(^PS(59,+$P(P1,"^",9),0)):$P(^(0),"^",6),1:"Unknown") W !,"Division: "_PSDIV_$E(" ",$L(PSDIV)+1,8)_" " - .W "Dispensed: "_$S($P(P1,"^",19):$E($P(P1,"^",19),4,5)_"/"_$E($P(P1,"^",19),6,7)_"/"_$E($P(P1,"^",19),2,3),1:"")_" " - .S RTS=$S($P(P1,"^",16):" Returned to Stock: "_$E($P(P1,"^",16),4,5)_"/"_$E($P(P1,"^",16),6,7)_"/"_$E($P(P1,"^",16),2,3),1:" Released: "_$S($P(P1,"^",18):$E($P(P1,"^",18),4,5)_"/"_$E($P(P1,"^",18),6,7)_"/"_$E($P(P1,"^",18),2,3),1:"")) - .W RTS W:$P(P1,"^",3)]"" !," Remarks: "_$P(P1,"^",3) - S DA(1)=PSORXED("IRXN") I RFN=1 S Y=RFM G RFM - W ! D KV S DIR("A")="Select a Refill",DIR(0)="NO^1:"_RFM_":0" D ^DIR Q:$D(DIRUT) -RFM I '$D(^PSRX(PSORXED("IRXN"),1,Y,0)) W !,$C(7),"Invalid selection.",! G SRF - S CMRL=0 I $D(^PSRX("AR",+$P(^PSRX(PSORXED("IRXN"),1,Y,0),"^",18),PSORXED("IRXN"),Y)) S CMRL=1 G RFX - F FEV=0:0 S FEV=$O(^PSRX(PSORXED("IRXN"),4,FEV)) Q:'FEV I $P(^PSRX(PSORXED("IRXN"),4,FEV,0),"^",3)=Y,$P(^(0),"^",4)<3 S CMRL=1 -RFX N RFL,NDC,DAW,FLDS,QUIT,CHGNDC,CHANGED - W ! S DA=Y,DIE="^PSRX("_DA(1)_",1,",DR=$S('CMRL:".01;1.1",1:"1.2:5;8") - D GETS^DIQ(52.1,DA_","_DA(1)_",",".01;1;1.1;8;11;81","I","FLDS") - S:$D(^PSRX(DA(1),1,DA,0)) PSORXED("RX1")=^PSRX(DA(1),1,DA,0),(RFED,RFL)=DA - I $G(ST)=11!($G(ST)=12),$$STATUS^PSOBPSUT(PSORXED("IRXN"),RFL)'="" S QUIT=0 D RFE Q ;short circuit for DC'd/Expired ECME RXs - D ^DIE S QUIT=$D(Y) K FEV,RFN,RFM,X,Y,DR - I '$G(DA) D REVERSE^PSOBPSU1(PSORXED("IRXN"),RFL,"DE",5) K CMRL,RFED D:$D(PSORX("PSOL"))&($G(DI)=.01) RFD Q - I 'CMRL,'QUIT S DR="1;1.2:5;8" D ^DIE S QUIT=$D(Y) -RFE I '$D(^PSRX(PSORXED("IRXN"),1,RFL)) Q - I 'QUIT,$$STATUS^PSOBPSUT(PSORXED("IRXN"),RFL)'="" D - . S NDC=$$GETNDC^PSONDCUT(PSORXED("IRXN"),RFL) - . D EDTDAW^PSODAWUT(PSORXED("IRXN"),RFL,.DAW) I $G(DAW)="^" Q - . D SAVDAW^PSODAWUT(PSORXED("IRXN"),RFL,+$G(DAW)) - . D NDC^PSODRG(PSORXED("IRXN"),RFL,,.NDC) I $G(NDC)="^",$G(NDC)="" Q - . I NDC'=$$GETNDC^PSONDCUT(PSORXED("IRXN"),RFL) D - . . S CHGNDC=1 D RXACT^PSOBPSU2(PSORXED("IRXN"),RFL,"NDC changed from "_$$GETNDC^PSONDCUT(PSORXED("IRXN"),RFL)_" to "_NDC_".","E") - . D SAVNDC^PSONDCUT(PSORXED("IRXN"),RFL,NDC) - S CHANGED=$$CHANGED(PSORXED("IRXN"),RFL,.FLDS) - I CHANGED D - . I $P(CHANGED,"^",2),'$$ECMEON^BPSUTIL($$RXSITE^PSOBPSUT(PSORXED("IRXN"),RFL)) D Q - . . D REVERSE^PSOBPSU1(PSORXED("IRXN"),RFL,"DC",99,"REFILL DIVISION CHANGED",1) - . I $$SUBMIT^PSOBPSUT(PSORXED("IRXN"),RFL,1,1) D - . . N RX S RX=PSORXED("IRXN") - . . I '$P(CHANGED,"^",2),$$STATUS^PSOBPSUT(RX,RFL)="" Q - . . D ECMESND^PSOBPSU1(RX,RFL,,"ED",$$GETNDC^PSONDCUT(RX,RFL),,$S($P(CHANGED,"^",2):"REFILL DIVISION CHANGED",1:"REFILL EDITED"),,+$G(CHGNDC)) - . . ;- Checking/Handling DUR/79 Rejects - . . I $$FIND^PSOREJUT(RX,RFL) S X=$$HDLG^PSOREJU1(RX,RFL,"79,88","ED","IOQ","Q") - K DIE,CMRL,DA,DR - Q -CHANGED(RX,RFL,PRIOR) ; - Check if fields have changed and should for 3rd Party Claim resubmission - ;Input: (r) RX - Rx IEN - ; (r) RFL - Refill # - ; (r) PRIOR - Array with fields - ;Output: CHANGED - 0 - Not changed / 1 - Refill field changed ^ Rx Division changed (1 - YES) - N CHANGED,SAVED - S CHANGED=0 D GETS^DIQ(52.1,RFL_","_RX_",",".01;1;1.1;8;11;81","I","SAVED") - F I=.01,1,1.1,11,81 I $G(PRIOR(52.1,RFL_","_RX_",",I,"I"))'=$G(SAVED(52.1,RFL_","_RX_",",I,"I")) S CHANGED=1 Q - I $$DIVNCPDP^BPSBUTL(+$G(PRIOR(52.1,RFL_","_RX_",",8,"I")))'=$$DIVNCPDP^BPSBUTL(+$G(SAVED(52.1,RFL_","_RX_",",8,"I"))) S CHANGED="1^1" - Q CHANGED - ; -DAT S DAT="",DTT=DTT\1 Q:DTT'?7N S DAT=$E(DTT,4,5)_"/"_$E(DTT,6,7)_"/"_$E(DTT,2,3) - Q -DIE S DIE=52 D ^DIE I $D(Y) S PSORXED("DFLG")=1 - K DIE,DR,X,Y - Q -RFD ;check for deleted refill - M PSOZ1("PSOL")=PSORX("PSOL") N I,J,K,PSOX2,PSOX3,PSOX9 S (I,K)=0 D - .F S I=$O(PSOZ1("PSOL",I)) Q:'I!(K) S PSOX2=PSOZ1("PSOL",I) I PSOX2[(PSORXED("IRXN")_",") S PSOX9="" D - ..F J=1:1 S PSOX3=$P(PSOX2,",",J) Q:'PSOX3 D - ...I 'K,PSOX3=PSORXED("IRXN") S K=1 - ...E S PSOX9=PSOX9_$S('PSOX9:"",1:",")_PSOX3 - ..I K S:PSOX9]"" PSORX("PSOL",I)=PSOX9_"," K:PSOX9="" PSORX("PSOL",I) - K PSOZ1("PSOL") - Q -EDTDOSE ;edit med instructions fields - I '$O(^PSRX(PSORXED("IRXN"),6,0)) D DOSE^PSOORED5 Q - D ^PSOORED3 - Q -UPD ;updates dosing array - S HENT=ENT -UPD1 I $G(PSORXED("CONJUNCTION",(HENT+1)))]"",'$D(PSORXED("DOSE",(HENT+2))) K PSORXED("CONJUNCTION",(HENT+1)) Q - I $G(PSORXED("CONJUNCTION",(HENT+1)))]"" S PSORXED("CONJUNCTION",HENT)=PSORXED("CONJUNCTION",(HENT+1)) D G UPD1 - .K PSORXED("CONJUNCTION",(HENT+1)) - .F Q:'$D(PSORXED("DOSE",(HENT+2))) D - ..S PSORXED("DOSE",(HENT+1))=PSORXED("DOSE",(HENT+2)) - ..S PSORXED("DOSE ORDERED",(HENT+1))=$G(PSORXED("DOSE ORDERED",(HENT+2))) - ..S PSORXED("UNITS",(HENT+1))=$G(PSORXED("UNITS",(HENT+2))) - ..S PSORXED("NOUN",(HENT+1))=$G(PSORXED("NOUN",(HENT+2))) - ..S PSORXED("DURATION",(HENT+1))=$G(PSORXED("DURATION",(HENT+2))) - ..S PSORXED("CONJUNCTION",(HENT+1))=$G(PSORXED("CONJUNCTION",(HENT+2))) - ..S PSORXED("ROUTE",(HENT+1))=$G(PSORXED("ROUTE",(HENT+2))) - ..S PSORXED("SCHEDULE",(HENT+1))=$G(PSORXED("SCHEDULE",(HENT+2))) - ..S PSORXED("ODOSE",(HENT+1))=$G(PSORXED("ODOSE",(HENT+2))) - ..S HENT=HENT+1 - ..I $G(PSORXED("CONJUNCTION",(HENT+2)))]"" Q - ..K PSORXED("UNITS",(HENT+1)),PSORXED("NOUN",(HENT+1)),PSORXED("DURATION",(HENT+1)),PSORXED("CONJUNCTION",(HENT+1)),PSORXED("ROUTE",(HENT+1)),PSORXED("SCHEDULE",(HENT+1)),PSORXED("DOSE",(HENT+1)),PSORXED("DOSE ORDERED",(HENT+1)) - ..K PSORXED("VERB",(HENT+1)),PSORXED("ODOSE",(HENT+1)) - S PSORXED("ENT")=HENT K HENT,SENT D EN^PSOFSIG(.PSORXED) - Q -UPD2 I $G(PSORXED("CONJUNCTION",(HENT+1)))]"",'$D(PSORXED("DOSE",(HENT+2))) K PSORXED("CONJUNCTION",(HENT+1)) Q - I $G(PSORXED("CONJUNCTION",(HENT+1)))]"" S PSORXED("CONJUNCTION",HENT)=PSORXED("CONJUNCTION",(HENT+1)) D G UPD1 - .K PSORXED("CONJUNCTION",(HENT+1)) I $D(PSORXED("DOSE",(HENT+2))) D - ..S PSORXED("DOSE",(HENT+1))=PSORXED("DOSE",(HENT+2)) - ..S PSORXED("DOSE ORDERED",(HENT+1))=$G(PSORXED("DOSE ORDERED",(HENT+2))) - ..S PSORXED("UNITS",(HENT+1))=$G(PSORXED("UNITS",(HENT+2))) - ..S PSORXED("NOUN",(HENT+1))=$G(PSORXED("NOUN",(HENT+2))) - ..S PSORXED("VERB",(HENT+1))=$G(PSORXED("VERB",(HENT+2))) - ..S PSORXED("DURATION",(HENT+1))=$G(PSORXED("DURATION",(HENT+2))) - ..S PSORXED("CONJUNCTION",(HENT+1))=$G(PSORXED("CONJUNCTION",(HENT+2))) - ..S PSORXED("ROUTE",(HENT+1))=$G(PSORXED("ROUTE",(HENT+2))) - ..S PSORXED("SCHEDULE",(HENT+1))=$G(PSORXED("SCHEDULE",(HENT+2))) - ..S PSORXED("ODOSE",(HENT+1))=$G(PSORXED("ODOSE",(HENT+2))) - ..S HENT=HENT+1 - ..I $G(PSORXED("CONJUNCTION",(HENT+1)))]"" Q - ..K PSORXED("UNITS",(HENT+1)),PSORXED("NOUN",(HENT+1)),PSORXED("DURATION",(HENT+1)),PSORXED("ROUTE",(HENT+1)),PSORXED("SCHEDULE",(HENT+1)),PSORXED("DOSE",(HENT+1)),PSORXED("DOSE ORDERED",(HENT+1)),PSORXED("VERB",(HENT+1)) - ..K PSORXED("ODOSE",(HENT+1)) - F I=0:0 S I=$O(PSORXED("DOSE",I)) Q:'I S SENT=$G(SENT)+1 - S PSORXED("ENT")=SENT K HENT,SENT D EN^PSOFSIG(.PSORXED) - Q +PSOORED2 ;ISC-BHAM/SAB-edit orders from backdoor con't ;03/06/95 10:24 + ;;7.0;OUTPATIENT PHARMACY;**2,51,46,78,102,114,117,133,159,148,247,260**;DEC 1997;Build 84 + ;Reference to $$DIVNCPDP^BPSBUTL supported by IA 4719 + ;Reference to $$ECMEON^BPSUTIL supported by IA 4410 + ;called from psooredt. cmop edit checks. + Q +ISDT D CHK K RF I $G(CMRL) W !,"Released by CMOP. No editing allowed on Issue Date." D PAUSE^VALM1 K CMRL Q + S %DT="AEX",%DT(0)=-$P(^PSRX(DA,2),"^",2),Y=$P(RX0,"^",13) X ^DD("DD") S %DT("A")="ISSUE DATE: ",%DT("B")=Y D ^%DT I "^"[$E(X) K X,Y,%DT,DTOUT,DUOUT Q + G:Y=-1 ISDT S PSORXED("FLD",1)=Y + ;S DR="1///"_Y,DIE=52 D ^DIE + D KV K X,Y,%DT + Q +FLDT D CHK K RF I $G(CMRL) W !,"Released by CMOP. No editing allowed on Fill Date." D PAUSE^VALM1 K CMRL Q + D KV S Y=$P(^PSRX(DA,2),"^",2) X ^DD("DD") S DIR("A")="FILL DATE",DIR("B")=Y + S DIR(0)="D^"_$P(RX0,"^",13)_":"_$P(PSORXED("RX2"),"^",6)_":EX" + S DIR("?",1)="The earliest fill date allowed is determined by the Issue Date,",DIR("?",2)="the Fill Date cannot be before the Issue Date or past the Expiration Date." + S DIR("?")="Both the month and day are required." D ^DIR + I $D(DIRUT) D KV K PSORXED("FLD",22),X,Y Q + S PSORXED("FLD",22)=Y ;S DR="22R///"_Y,DIE=52 D ^DIE + K X,Y +KV K DIR,DUOUT,DTOUT,DIRUT + Q +CHK I $D(^PSRX("AR",+$P(PSORXED("RX2"),"^",13),PSORXED("IRXN"))) S CMRL=1 Q + F RF=0:0 S RF=$O(^PSRX(PSORXED("IRXN"),1,RF)) Q:'RF I $D(^PSRX("AR",+$P(^PSRX(PSORXED("IRXN"),1,RF,0),"^",18),PSORXED("IRXN"))) S CMRL=1 + Q +CHK1 I +^PSRX(PSORXED("IRXN"),"STA")=5 D Q:'$G(CMRL) + .S SURX=$O(^PS(52.5,PSORXED("IRXN"),0)) Q:'SURX I $P(^PS(52.5,SURX,0),"^",7)']""!($P(^(0),"^",7)="Q") S CMRL=1 + .E S CMRL=0 + F FEV=0:0 S FEV=$O(^PSRX(PSORXED("IRXN"),4,FEV)) Q:'FEV I '$P(^PSRX(PSORXED("IRXN"),4,FEV,0),"^",3),$P(^(0),"^",4)<3 S CMRL=0 + Q +REF ;shows refill info + S RFN=0 F N=0:0 S N=$O(^PSRX(PSORXED("IRXN"),1,N)) Q:'N S RFM=N,RFN=RFN+1 + ;G:RFM=1 SRF + W ! K DA,DR D KV S DIR(0)="Y",DIR("B")="No",DIR("A")="There "_$S(RFN>1:"are ",1:"is ")_RFN_" refill"_$S(RFN>1:"s.",1:".")_" Do you want to edit" + D ^DIR D KV Q:'Y +SRF W !!,"# Log Date Refill Date Qty Routing Lot # Pharmacist",! F I=1:1:80 W "=" + F N=0:0 S N=$O(^PSRX(PSORXED("IRXN"),1,N)) Q:'N S P1=^(N,0) D + .S DTT=$P(P1,"^",8)\1 D DAT S LOG=DAT,DTT=$P(P1,"^"),$P(RN," ",10)=" " D DAT + .W !,N_" "_LOG_" "_DAT_" "_$P(P1,"^",4)_$E(" ",$L($P(P1,"^",4))+1,15)_" "_$S($P(P1,"^",2)="M":"MAIL ",1:"WINDOW")_" "_$P(P1,"^",6)_$E(RN,$L($P(P1,"^",6))+1,12) + .W $E($S($D(^VA(200,+$P(P1,"^",5),0)):$P(^(0),"^"),1:""),1,16) + .S PSDIV=$S($D(^PS(59,+$P(P1,"^",9),0)):$P(^(0),"^",6),1:"Unknown") W !,"Division: "_PSDIV_$E(" ",$L(PSDIV)+1,8)_" " + .W "Dispensed: "_$S($P(P1,"^",19):$E($P(P1,"^",19),4,5)_"/"_$E($P(P1,"^",19),6,7)_"/"_$E($P(P1,"^",19),2,3),1:"")_" " + .S RTS=$S($P(P1,"^",16):" Returned to Stock: "_$E($P(P1,"^",16),4,5)_"/"_$E($P(P1,"^",16),6,7)_"/"_$E($P(P1,"^",16),2,3),1:" Released: "_$S($P(P1,"^",18):$E($P(P1,"^",18),4,5)_"/"_$E($P(P1,"^",18),6,7)_"/"_$E($P(P1,"^",18),2,3),1:"")) + .W RTS W:$P(P1,"^",3)]"" !," Remarks: "_$P(P1,"^",3) + S DA(1)=PSORXED("IRXN") I RFN=1 S Y=RFM G RFM + W ! D KV S DIR("A")="Select a Refill",DIR(0)="NO^1:"_RFM_":0" D ^DIR Q:$D(DIRUT) +RFM I '$D(^PSRX(PSORXED("IRXN"),1,Y,0)) W !,$C(7),"Invalid selection.",! G SRF + S CMRL=0 I $D(^PSRX("AR",+$P(^PSRX(PSORXED("IRXN"),1,Y,0),"^",18),PSORXED("IRXN"),Y)) S CMRL=1 G RFX + F FEV=0:0 S FEV=$O(^PSRX(PSORXED("IRXN"),4,FEV)) Q:'FEV I $P(^PSRX(PSORXED("IRXN"),4,FEV,0),"^",3)=Y,$P(^(0),"^",4)<3 S CMRL=1 +RFX N RFL,NDC,DAW,FLDS,QUIT,CHGNDC,CHANGED + W ! S DA=Y,DIE="^PSRX("_DA(1)_",1,",DR=$S('CMRL:".01;1.1",1:"1.2:5;8") + D GETS^DIQ(52.1,DA_","_DA(1)_",",".01;1;1.1;8;11;81","I","FLDS") + S:$D(^PSRX(DA(1),1,DA,0)) PSORXED("RX1")=^PSRX(DA(1),1,DA,0),(RFED,RFL)=DA + D ^DIE S QUIT=$D(Y) K FEV,RFN,RFM,X,Y,DR + I '$G(DA) D REVERSE^PSOBPSU1(PSORXED("IRXN"),RFL,"DE",5) K CMRL,RFED D:$D(PSORX("PSOL"))&($G(DI)=.01) RFD Q + I 'CMRL,'QUIT S DR="1;1.2:5;8" D ^DIE S QUIT=$D(Y) + I '$D(^PSRX(PSORXED("IRXN"),1,RFL)) Q + I 'QUIT,$$STATUS^PSOBPSUT(PSORXED("IRXN"),RFL)'="" D + . S NDC=$$GETNDC^PSONDCUT(PSORXED("IRXN"),RFL) + . D EDTDAW^PSODAWUT(PSORXED("IRXN"),RFL,.DAW) I $G(DAW)="^" Q + . D SAVDAW^PSODAWUT(PSORXED("IRXN"),RFL,+$G(DAW)) + . D NDC^PSODRG(PSORXED("IRXN"),RFL,,.NDC) I $G(NDC)="^",$G(NDC)="" Q + . I NDC'=$$GETNDC^PSONDCUT(PSORXED("IRXN"),RFL) D + . . S CHGNDC=1 D RXACT^PSOBPSU2(PSORXED("IRXN"),RFL,"NDC changed from "_$$GETNDC^PSONDCUT(PSORXED("IRXN"),RFL)_" to "_NDC_".","E") + . D SAVNDC^PSONDCUT(PSORXED("IRXN"),RFL,NDC) + S CHANGED=$$CHANGED(PSORXED("IRXN"),RFL,.FLDS) + I CHANGED D + . I $P(CHANGED,"^",2),'$$ECMEON^BPSUTIL($$RXSITE^PSOBPSUT(PSORXED("IRXN"),RFL)) D Q + . . D REVERSE^PSOBPSU1(PSORXED("IRXN"),RFL,"DC",99,"REFILL DIVISION CHANGED",1) + . I $$SUBMIT^PSOBPSUT(PSORXED("IRXN"),RFL,1,1) D + . . N RX S RX=PSORXED("IRXN") + . . I '$P(CHANGED,"^",2),$$STATUS^PSOBPSUT(RX,RFL)="" Q + . . D ECMESND^PSOBPSU1(RX,RFL,,"ED",$$GETNDC^PSONDCUT(RX,RFL),,$S($P(CHANGED,"^",2):"REFILL DIVISION CHANGED",1:"REFILL EDITED"),,+$G(CHGNDC)) + . . ;- Checking/Handling DUR/79 Rejects + . . I $$FIND^PSOREJUT(RX,RFL) S X=$$HDLG^PSOREJU1(RX,RFL,"79,88","ED","IOQ","I") + K DIE,CMRL,DA,DR + Q +CHANGED(RX,RFL,PRIOR) ; - Check if fields have changed and should for 3rd Party Claim resubmission + ;Input: (r) RX - Rx IEN + ; (r) RFL - Refill # + ; (r) PRIOR - Array with fields + ;Output: CHANGED - 0 - Not changed / 1 - Refill field changed ^ Rx Division changed (1 - YES) + N CHANGED,SAVED + S CHANGED=0 D GETS^DIQ(52.1,RFL_","_RX_",",".01;1;1.1;8;11;81","I","SAVED") + F I=.01,1,1.1,11,81 I $G(PRIOR(52.1,RFL_","_RX_",",I,"I"))'=$G(SAVED(52.1,RFL_","_RX_",",I,"I")) S CHANGED=1 Q + I $$DIVNCPDP^BPSBUTL(+$G(PRIOR(52.1,RFL_","_RX_",",8,"I")))'=$$DIVNCPDP^BPSBUTL(+$G(SAVED(52.1,RFL_","_RX_",",8,"I"))) S CHANGED="1^1" + Q CHANGED + ; +DAT S DAT="",DTT=DTT\1 Q:DTT'?7N S DAT=$E(DTT,4,5)_"/"_$E(DTT,6,7)_"/"_$E(DTT,2,3) + Q +DIE S DIE=52 D ^DIE I $D(Y) S PSORXED("DFLG")=1 + K DIE,DR,X,Y + Q +RFD ;check for deleted refill + M PSOZ1("PSOL")=PSORX("PSOL") N I,J,K,PSOX2,PSOX3,PSOX9 S (I,K)=0 D + .F S I=$O(PSOZ1("PSOL",I)) Q:'I!(K) S PSOX2=PSOZ1("PSOL",I) I PSOX2[(PSORXED("IRXN")_",") S PSOX9="" D + ..F J=1:1 S PSOX3=$P(PSOX2,",",J) Q:'PSOX3 D + ...I 'K,PSOX3=PSORXED("IRXN") S K=1 + ...E S PSOX9=PSOX9_$S('PSOX9:"",1:",")_PSOX3 + ..I K S:PSOX9]"" PSORX("PSOL",I)=PSOX9_"," K:PSOX9="" PSORX("PSOL",I) + K PSOZ1("PSOL") + Q +EDTDOSE ;edit med instructions fields + I '$O(^PSRX(PSORXED("IRXN"),6,0)) D DOSE^PSOORED5 Q + D ^PSOORED3 + Q +UPD ;updates dosing array + S HENT=ENT +UPD1 I $G(PSORXED("CONJUNCTION",(HENT+1)))]"",'$D(PSORXED("DOSE",(HENT+2))) K PSORXED("CONJUNCTION",(HENT+1)) Q + I $G(PSORXED("CONJUNCTION",(HENT+1)))]"" S PSORXED("CONJUNCTION",HENT)=PSORXED("CONJUNCTION",(HENT+1)) D G UPD1 + .K PSORXED("CONJUNCTION",(HENT+1)) + .F Q:'$D(PSORXED("DOSE",(HENT+2))) D + ..S PSORXED("DOSE",(HENT+1))=PSORXED("DOSE",(HENT+2)) + ..S PSORXED("DOSE ORDERED",(HENT+1))=$G(PSORXED("DOSE ORDERED",(HENT+2))) + ..S PSORXED("UNITS",(HENT+1))=$G(PSORXED("UNITS",(HENT+2))) + ..S PSORXED("NOUN",(HENT+1))=$G(PSORXED("NOUN",(HENT+2))) + ..S PSORXED("DURATION",(HENT+1))=$G(PSORXED("DURATION",(HENT+2))) + ..S PSORXED("CONJUNCTION",(HENT+1))=$G(PSORXED("CONJUNCTION",(HENT+2))) + ..S PSORXED("ROUTE",(HENT+1))=$G(PSORXED("ROUTE",(HENT+2))) + ..S PSORXED("SCHEDULE",(HENT+1))=$G(PSORXED("SCHEDULE",(HENT+2))) + ..S PSORXED("ODOSE",(HENT+1))=$G(PSORXED("ODOSE",(HENT+2))) + ..S HENT=HENT+1 + ..I $G(PSORXED("CONJUNCTION",(HENT+2)))]"" Q + ..K PSORXED("UNITS",(HENT+1)),PSORXED("NOUN",(HENT+1)),PSORXED("DURATION",(HENT+1)),PSORXED("CONJUNCTION",(HENT+1)),PSORXED("ROUTE",(HENT+1)),PSORXED("SCHEDULE",(HENT+1)),PSORXED("DOSE",(HENT+1)),PSORXED("DOSE ORDERED",(HENT+1)) + ..K PSORXED("VERB",(HENT+1)),PSORXED("ODOSE",(HENT+1)) + S PSORXED("ENT")=HENT K HENT,SENT D EN^PSOFSIG(.PSORXED) + Q +UPD2 I $G(PSORXED("CONJUNCTION",(HENT+1)))]"",'$D(PSORXED("DOSE",(HENT+2))) K PSORXED("CONJUNCTION",(HENT+1)) Q + I $G(PSORXED("CONJUNCTION",(HENT+1)))]"" S PSORXED("CONJUNCTION",HENT)=PSORXED("CONJUNCTION",(HENT+1)) D G UPD1 + .K PSORXED("CONJUNCTION",(HENT+1)) I $D(PSORXED("DOSE",(HENT+2))) D + ..S PSORXED("DOSE",(HENT+1))=PSORXED("DOSE",(HENT+2)) + ..S PSORXED("DOSE ORDERED",(HENT+1))=$G(PSORXED("DOSE ORDERED",(HENT+2))) + ..S PSORXED("UNITS",(HENT+1))=$G(PSORXED("UNITS",(HENT+2))) + ..S PSORXED("NOUN",(HENT+1))=$G(PSORXED("NOUN",(HENT+2))) + ..S PSORXED("VERB",(HENT+1))=$G(PSORXED("VERB",(HENT+2))) + ..S PSORXED("DURATION",(HENT+1))=$G(PSORXED("DURATION",(HENT+2))) + ..S PSORXED("CONJUNCTION",(HENT+1))=$G(PSORXED("CONJUNCTION",(HENT+2))) + ..S PSORXED("ROUTE",(HENT+1))=$G(PSORXED("ROUTE",(HENT+2))) + ..S PSORXED("SCHEDULE",(HENT+1))=$G(PSORXED("SCHEDULE",(HENT+2))) + ..S PSORXED("ODOSE",(HENT+1))=$G(PSORXED("ODOSE",(HENT+2))) + ..S HENT=HENT+1 + ..I $G(PSORXED("CONJUNCTION",(HENT+1)))]"" Q + ..K PSORXED("UNITS",(HENT+1)),PSORXED("NOUN",(HENT+1)),PSORXED("DURATION",(HENT+1)),PSORXED("ROUTE",(HENT+1)),PSORXED("SCHEDULE",(HENT+1)),PSORXED("DOSE",(HENT+1)),PSORXED("DOSE ORDERED",(HENT+1)),PSORXED("VERB",(HENT+1)) + ..K PSORXED("ODOSE",(HENT+1)) + F I=0:0 S I=$O(PSORXED("DOSE",I)) Q:'I S SENT=$G(SENT)+1 + S PSORXED("ENT")=SENT K HENT,SENT D EN^PSOFSIG(.PSORXED) + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORED6.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORED6.m index b90dc6fd..4f85ad65 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORED6.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORED6.m @@ -1,163 +1,161 @@ -PSOORED6 ;BIR/SAB - edit orders from backdoor ;03/06/96 - ;;7.0;OUTPATIENT PHARMACY;**78,104,117,133,143,219,148,247,268,260,269**;DEC 1997;Build 4 - ;External reference to ^PSDRUG supported by DBIA 221 - ;External reference to ^PS(50.7 supported by DBIA 2223 - ;External reference ^PS(50.606 supported by DBIA 2174 -DRG ;select drug - S PSORX("EDIT")=1,RX0HLD=RX0 - S PSODRUG("IEN")=$S($G(PSODRUG("IEN"))]"":PSODRUG("IEN"),1:$P(RX0,"^",6)),PSODRUG("NAME")=$S($G(PSODRUG("NAME"))]"":PSODRUG("NAME"),1:$P(^PSDRUG($P(RX0,"^",6),0),"^")) - D ^PSODRG I PSODRUG("IEN")=$P(RX0,"^",6) K PSORXED("FLD",6) - D:PSODRUG("IEN")'=$P(RX0,"^",6) I $G(PSORX("DFLG")) K PSORXED("FLD",6) S PSORXED("DFLG")=1 Q - .D POST^PSODRG - .I '$O(^PSRX(PSORXED("IRXN"),1,0)) S PSORXED("FLD",17)=$G(PSODRUG("COST")) - .I $G(PSORX("DFLG")) K PSORXED("FLD",6),PSODRUG,PSOOIFLG,PSOSIGFL,VALMSG Q - .D KV S DIR(0)="Y",DIR("B")="YES" - .S DIR("A",1)="You have changed the dispense drug from" - .S DIR("A",2)=$P(^PSDRUG($P(PSORXED("RX0"),"^",6),0),"^")_" to "_$P(^PSDRUG(PSODRUG("IEN"),0),"^")_"." - .I $P($G(^PSRX(PSORXED("IRXN"),"SIG")),"^",2),$O(^PSRX(PSORXED("IRXN"),"SIG1",0)) S DIR("A",3)="" D - ..F I=0:0 S I=$O(^PSRX(PSORXED("IRXN"),"SIG1",I)) Q:'I S DIR("A",3+I)=$S(I=1:"Current SIG: ",1:"")_$G(^PSRX(PSORXED("IRXN"),"SIG1",I,0)) - .S DIR("A")="Do You want to Edit the SIG" - .D ^DIR K DIR I $D(DIRUT) S PSORX("DFLG")=1 D M1 - .Q:$D(DIRUT)!('Y) - .S PSOREEDQ=1 D DOLST^PSOORED3,DOSE^PSOORED3 K PSOREEDQ - .I '$O(PSORXED("DOSE",0)) S PSORX("DFLG")=1 Q - .D:$G(PSOSIGFL) M2 - S RX0=RX0HLD K RX0HLD I $G(PSODRUG("OI"))=$G(PSOI) D Q - .D:$O(^TMP("PSORXDC",$J,0)) - ..W !!,"This edit will discontinue the duplicate Rx & change the dispensed drug!" - ..K DIR,X,Y S DIR("A")="Do You Want to Proceed",DIR("B")="NO",DIR(0)="Y" - ..D ^DIR K DIR S:'Y!($D(DIRUT)) PSORXED("DFLG")=1 D:Y DCORD^PSONEW2 - .Q:$G(PSORXED("DFLG")) - .I PSODRUG("IEN")'=$P(RX0,"^",6) D - ..S PSORXED("FLD",6)=PSODRUG("IEN"),PSORXED("FLD",39.2)=PSOI - .S:$G(PSODRUG("TRADE NAME"))]"" PSORXED("FLD",6.5)=PSODRUG("TRADE NAME") - .S:$G(PSODRUG("NDC"))]"" PSORXED("FLD",27)=PSODRUG("NDC") - .S:$G(PSODRUG("DAW"))]"" PSORXED("FLD",81)=PSODRUG("DAW") - W !!,"New Orderable Item selected. This edit will create a new prescription!",! D PAUSE^VALM1 S VALMSG="New Orderable Item selected. This edit will create a new prescription!" S (PSOOIFLG,PSOSIGFL)=1 - Q -PSOCOU ;patient counseling - K DIC,DIQ S DIC=52,DA=PSORXED("IRXN"),DIQ="PSORXED",DR=41 D EN^DIQ1 K DIC,DIQ - D KV S DIR(0)="52,41" S:$G(PSORXED(52,DA,DR))]"" DIR("B")=PSORXED(52,DA,DR) D ^DIR K DIR,PSORXED(52,DA,DR) - I $D(DIRUT) K PSORXED("FLD",41) D KV Q - S PSORXED("FLD",DR)=Y D K DIRUT - .I Y D Q - ..K DIC,DIQ S DIC=52,DA=PSORXED("IRXN"),DIQ="PSORXED",DR=42 D EN^DIQ1 K DIC,DIQ - ..K DIR,DIRUT S DIR(0)="52,42" S:$G(PSORXED(52,DA,DR))]"" DIR("B")=PSORXED(52,DA,DR) D ^DIR K DIR,PSORXED(52,DA,DR) - ..I $D(DIRUT) K PSORXED("FLD",41),DUOUT,DTOUT Q - ..S PSORXED("FLD",42)=Y - .S PSORXED("FLD",41)=0,PSORXED("FLD",42)="@" - Q -PSOI ;select orderable item - W !!,"Current Orderable Item: "_$P(^PS(50.7,PSOI,0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^") - S DIC("B")=$P(^PS(50.7,PSOI,0),"^"),DIC="^PS(50.7,",DIC(0)="AEMQZ" - S DIC("S")="I '$P(^PS(50.7,+Y,0),""^"",4)!($P(^(0),""^"",4)'OLENT) S PSOSIGFL=1 Q - F I=1:1:OLENT D:$D(^PSRX(PSORXED("IRXN"),6,I,0)) - .I $P(^PSRX(PSORXED("IRXN"),6,I,0),"^")'=PSORXED("DOSE",I) S PSOSIGFL=1 - .I $P(^PSRX(PSORXED("IRXN"),6,I,0),"^")=PSORXED("DOSE",I) D - ..I $G(PSORXED("DOSE ORDERED",I)) S:PSORXED("DOSE ORDERED",I)'=$P(^PSRX(PSORXED("IRXN"),6,I,0),"^",2) PSOSIGFL=1 - .I $G(PSORXED("DURATION",I))]"" D - ..S DURATION=$S($E($P(^PSRX(PSORXED("IRXN"),6,I,0),"^",5),1)'?.N:$E($P(^PSRX(PSORXED("IRXN"),6,I,0),"^",5),2,99)_$E($P(^PSRX(PSORXED("IRXN"),6,I,0),"^",5),1),1:$P(^PSRX(PSORXED("IRXN"),6,I,0),"^",5)) - ..I +DURATION'=+$G(PSORXED("DURATION",I)) S PSOSIGFL=1 - .I $P(^PSRX(PSORXED("IRXN"),6,I,0),"^",6)'=$G(PSORXED("CONJUNCTION",I)) S PSOSIGFL=1 - .I $P(^PSRX(PSORXED("IRXN"),6,I,0),"^",7)'=$G(PSORXED("ROUTE",I)) S PSOSIGFL=1 - .I $P(^PSRX(PSORXED("IRXN"),6,I,0),"^",8)'=PSORXED("SCHEDULE",I) S PSOSIGFL=1 - .I $G(^PSRX(PSORXED("IRXN"),6,I,1))'=$G(PSORXED("ODOSE",I)) S PSOSIGFL=1 - K DURATION - Q - ; -RESUB ; Resubmits 3rd party claim in case of an edit (Original) - N CHANGED S CHANGED=$$CHANGED(PSORXED("IRXN"),.FLDS) - I CHANGED D - . N RX S RX=PSORXED("IRXN") Q:'RX - . I $P(CHANGED,"^",2),'$$ECMEON^BPSUTIL($$RXSITE^PSOBPSUT(RX,0)) D Q - . . D REVERSE^PSOBPSU1(RX,0,"DC",99,"RX DIVISION CHANGED",1) - . I $$SUBMIT^PSOBPSUT(RX,0,1,1) D - . . I '$P(CHANGED,"^",2),$$STATUS^PSOBPSUT(RX,0)="" Q - . . D ECMESND^PSOBPSU1(RX,0,,"ED",$$GETNDC^PSONDCUT(RX,0),,$S($P(CHANGED,"^",2):"RX DIVISION CHANGED",1:"RX EDITED"),,+$G(CHGNDC)) - . . ;- Checking/Handling DUR/79 Rejects - . . I $$FIND^PSOREJUT(RX,0) S X=$$HDLG^PSOREJU1(RX,0,"79,88","ED","IOQ","Q") - Q - ; -CHANGED(RX,PRIOR) ; - Check if fields have changed and should for 3rd Party Claim resubmission - ;Input: (r) RX - Rx IEN - ; (r) PRIOR - Array with fields - ;Output: CHANGED - 0 - Not changed / 1 - Original Rx field changed ^ Rx Division changed (1 - YES) - N CHANGED,SAVED - S CHANGED=0 D GETS^DIQ(52,RX_",","4;7;8;20;22;27;81","I","SAVED") - F I=4,7,8,22,27,81 D I CHANGED Q - . I $G(PRIOR(52,RX_",",I,"I"))'=$G(SAVED(52,RX_",",I,"I")) S CHANGED=1 Q - I $$DIVNCPDP^BPSBUTL(+$G(PRIOR(52,RX_",",20,"I")))'=$$DIVNCPDP^BPSBUTL(+$G(SAVED(52,RX_",",20,"I"))) S CHANGED="1^1" - Q CHANGED - ;; -NDCDAWDE(ST,FLN,RXN) ; allow edit of NDC & DAW for DC'd/expired ECME RXs - ;; input: (r) ST - the Rx status code - ;; (r) FLN - field number selected for editing - ;; (r) RXN - prescription # - ;; output: VALMSG for inappropriate field selection or use - ;; PSODRUG & RSORXED arrays updated if edited - Q:$G(ST)=""!($G(FLN)="")!($G(RXN)="") - I '((ST=11)!(ST=12)) S VALMSG=("Invalid selection!") Q - I '((FLN=2)!(FLN=20)!(FLN=21)) S VALMSG=("Invalid selection!") Q - I $$STATUS^PSOBPSUT(RXN,$$LSTRFL^PSOBPSU1(RXN))="" S VALMSG=("Invalid selection!") Q - ; - ; edit NDCs - I FLN=2 D Q - .N NDC - .S NDC=$$GETNDC^PSONDCUT(RXN,0) - .D NDCEDT^PSONDCUT(RXN,"",$G(DRG),$G(PSOSITE),.NDC) - .I $G(NDC)="^" Q - .S (PSODRUG("NDC"),PSORXED("FLD",27))=NDC - ;; - ; edit refill NDCs/DAWs - I FLN=20 D Q - .I $$LSTRFL^PSOBPSU1(RXN)=0 S VALMSG="Invalid selection!" Q - .D REF^PSOORED2 - ;; - ; edit DAW - I FLN=21 D Q - .N DAW - .D EDTDAW^PSODAWUT(RXN,0,.DAW) - .I $G(DAW)="^" Q - .S (PSODRUG("DAW"),PSORXED("FLD",81))=DAW - Q - ;; +PSOORED7 ;ISC-BHAM/MFR-edit orders from backdoor con't ;03/06/95 10:24 + ;;7.0;OUTPATIENT PHARMACY;**148,247**;DEC 1997;Build 18 + ;called from psooredt. cmop edit checks. + ;Reference to file #50 supported by IA 221 + ;Reference to $$ECMEON^BPSUTIL supported by IA 4410 + ;Reference to $$DIVNCPDP^BPSBUTL supported by IA 4719 + ; +NOCHG S CMRL=1 D CHK1^PSOORED2 I '$G(CMRL) W !,"No editing allowed of "_$S(FLN=9:"Day Supply",FLN=10:"Quantity",1:"# of Refills")_" (CMOP)." D PAUSE^VALM1 K CMRL Q + K CMRL,DIC,DIQ + S DIC=52,DA=PSORXED("IRXN"),DIQ="PSORXED" D EN^DIQ1 K DIC,DIQ + S PSORXED($S(FLN=9:"DAYS SUPPLY",FLN=10:"QTY",1:"# OF REFILLS"))=PSORXED(52,DA,DR) + D:'$O(PSORXED("DOSE",0)) DOLST^PSOORED3 + I FLN=9 D Q + .D DAYS^PSODIR1(.PSORXED) I $G(PSORXED("DFLG")) K PSORXED("FLD",8) Q + .S PSORXED("FLD",8)=PSORXED("DAYS SUPPLY") + I FLN=10 D Q + .D QTY^PSODIR1(.PSORXED) I $G(PSORXED("DFLG")) K PSORXED("FLD",7) Q + .S:$G(PSORXED("QTY")) PSORXED("FLD",7)=PSORXED("QTY") + I FLN=11 D Q + .S X=$G(PSORXED("PATIENT STATUS")) S:'X X=$P(RX0,"^",3) + .S DIC=53,DIC(0)="QXZ" D ^DIC K DIC + .S:+Y PSORXED("PTST NODE")=Y(0) + .S:'$G(PSORXED("PATIENT STATUS")) PSORXED("PATIENT STATUS")=+Y + .K X,Y + .I $G(PSODRUG("IEN"))=$P(RX0,"^",6) K PSODRUG S X="`"_$P(RX0,"^",6),DIC=50,DIC(0)="QXZ" D ^DIC K PSOY S PSOY=Y,PSOY(0)=Y(0) D SET^PSODRG + .S:'$G(PSORXED("DAYS SUPPLY")) PSORXED("DAYS SUPPLY")=$P(RX0,"^",8) + .F I=0:0 S I=$O(^PSRX(PSORXED("IRXN"),1,I)) Q:'I S RFTT=$G(RFTT)+1 + .D REFILL^PSODIR1(.PSORXED) K RFTT + .I $G(PSORXED("DFLG")) K PSORXED("FLD",9) Q + .I PSORXED("# OF REFILLS")=$P(RX0,"^",9) Q + .S PSORXED("FLD",9)=PSORXED("# OF REFILLS") + Q +VER ;checks for changes to dosing instructions + S ENTS=0 + F I=0:0 S I=$O(PSORXED("DOSE",I)) Q:'I S ENTS=$G(ENTS)+1 + I ENTSOLENT) S PSOSIGFL=1 Q + F I=1:1:OLENT D:$D(^PSRX(PSORXED("IRXN"),6,I,0)) + .I $P(^PSRX(PSORXED("IRXN"),6,I,0),"^")'=PSORXED("DOSE",I) S PSOSIGFL=1 + .I $P(^PSRX(PSORXED("IRXN"),6,I,0),"^")=PSORXED("DOSE",I) D + ..I $G(PSORXED("DOSE ORDERED",I)) S:PSORXED("DOSE ORDERED",I)'=$P(^PSRX(PSORXED("IRXN"),6,I,0),"^",2) PSOSIGFL=1 + .I $G(PSORXED("DURATION",I))]"" D + ..S DURATION=$S($E($P(^PSRX(PSORXED("IRXN"),6,I,0),"^",5),1)'?.N:$E($P(^PSRX(PSORXED("IRXN"),6,I,0),"^",5),2,99)_$E($P(^PSRX(PSORXED("IRXN"),6,I,0),"^",5),1),1:$P(^PSRX(PSORXED("IRXN"),6,I,0),"^",5)) + ..I +DURATION'=+$G(PSORXED("DURATION",I)) S PSOSIGFL=1 + .I $P(^PSRX(PSORXED("IRXN"),6,I,0),"^",6)'=$G(PSORXED("CONJUNCTION",I)) S PSOSIGFL=1 + .I $P(^PSRX(PSORXED("IRXN"),6,I,0),"^",7)'=$G(PSORXED("ROUTE",I)) S PSOSIGFL=1 + .I $P(^PSRX(PSORXED("IRXN"),6,I,0),"^",8)'=PSORXED("SCHEDULE",I) S PSOSIGFL=1 + .I $G(^PSRX(PSORXED("IRXN"),6,I,1))'=$G(PSORXED("ODOSE",I)) S PSOSIGFL=1 + K DURATION + Q + ; +RESUB ; Resubmits 3rd party claim in case of an edit (Original) + N CHANGED S CHANGED=$$CHANGED(PSORXED("IRXN"),.FLDS) + I CHANGED D + . N RX S RX=PSORXED("IRXN") Q:'RX + . I $P(CHANGED,"^",2),'$$ECMEON^BPSUTIL($$RXSITE^PSOBPSUT(RX,0)) D Q + . . D REVERSE^PSOBPSU1(RX,0,"DC",99,"RX DIVISION CHANGED",1) + . I $$SUBMIT^PSOBPSUT(RX,0,1,1) D + . . I '$P(CHANGED,"^",2),$$STATUS^PSOBPSUT(RX,0)="" Q + . . D ECMESND^PSOBPSU1(RX,0,,"ED",$$GETNDC^PSONDCUT(RX,0),,$S($P(CHANGED,"^",2):"RX DIVISION CHANGED",1:"RX EDITED"),,+$G(CHGNDC)) + . . ;- Checking/Handling DUR/79 Rejects + . . I $$FIND^PSOREJUT(RX,0) S X=$$HDLG^PSOREJU1(RX,0,"79,88","ED","IOQ","I") + Q + ; +CHANGED(RX,PRIOR) ; - Check if fields have changed and should for 3rd Party Claim resubmission + ;Input: (r) RX - Rx IEN + ; (r) PRIOR - Array with fields + ;Output: CHANGED - 0 - Not changed / 1 - Original Rx field changed ^ Rx Division changed (1 - YES) + N CHANGED,SAVED + S CHANGED=0 D GETS^DIQ(52,RX_",","4;7;8;20;22;27;81","I","SAVED") + F I=4,7,8,22,27,81 D I CHANGED Q + . I $G(PRIOR(52,RX_",",I,"I"))'=$G(SAVED(52,RX_",",I,"I")) S CHANGED=1 Q + I $$DIVNCPDP^BPSBUTL(+$G(PRIOR(52,RX_",",20,"I")))'=$$DIVNCPDP^BPSBUTL(+$G(SAVED(52,RX_",",20,"I"))) S CHANGED="1^1" + Q CHANGED diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOOREDT.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOOREDT.m index fdb6c581..b476049e 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOOREDT.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOOREDT.m @@ -1,163 +1,150 @@ -PSOOREDT ;BIR/SAB - edit orders from backdoor ;11:19 AM 1 Jan 2009 - ;;7.0;OUTPATIENT PHARMACY;**4,20,27,37,57,46,78,102,104,119,143,148,260,281,208**;DEC 1997;Build 41;WorldVistA 30-Jan-08 - ; - ;Modified from FOIA VISTA, - ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;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 Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - ;External reference to ^PSDRUG supported by DBIA 221 - ;External reference to PSSLOCK supported by DBIA 2789 - ;External reference to ^VA(200 supported by DBIA 10060 -SEL K PSOISLKD,PSOLOKED S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY D SVAL K PSOPLCK S VALMBCK="" Q - K PSOPLCK D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) D UL^PSSLOCK(+$G(PSODFN)) D SVALO K PSOMSG S VALMBCK="" Q - K PSOMSG S PSOLOKED=1 - K PSORX("DFLG"),DIR,DUOUT,DIRUT S DIR("A")="Select fields by number" - S DIR(0)="LO^1:"_$S($$STATUS^PSOBPSUT($P(PSOLST(ORN),"^",2))'="":21,$G(REF):20,1:19) - D ^DIR I $D(DIRUT) K DIR,DIRUT,DTOUT S VALMBCK="" D UL K PSOLOKED Q -EDTSEL N VALMCNT K PSOISLKD,PSORX("DFLG"),PSOOIFLG,PSOMRFLG,DIR,DIRUT,DTOUT,DTOUT,ZONE S (PSOEDIT,PSORXED)=1 I +Y S FST=Y D HLDHDR^PSOLMUTL D G EX ;PSO LM SELECT MENU protocol - .I '$G(PSOLOKED) S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY D SVAL K PSOPLCK S VALMBCK="",(PSOISLKD,PSODE)=1 Q - .I '$G(PSOLOKED) K PSOPLCK D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) D UL^PSSLOCK(+$G(PSODFN)) D SVALO K PSOMSG S VALMBCK="",(PSOISLKD,PSODE)=1 Q - .K PSOMSG,PSOPLCK S (NEWEDT,PSOLOKED)=1 D EDT - E S VALMBCK="",PSODE=1 -EX I $G(PSOISLKD) D UL K PSOISLKD G EX2 - I '$G(PSOSIGFL),'$G(PSORXED("DFLG")) D UPDATE^PSOORED6 D LOG^PSORXED,POST^PSORXED G EX1 - I $G(PSOSIGFL)=1 D Q:$G(PSORX("FN")) - .N PSOTMP - .S PSOTMP=$G(PSOFROM),PSOFROM="NEW" - .S VALMSG="This change will create a new prescription!",NCPDPFLG=1 - .D EN^PSOORED1(.PSORXED) - .I $G(PSORX("FN")) D Q - ..D ^PSOBUILD - ..K QUIT,PSORX("DFLG"),FST,FLD,IEN,FLN,INCOM,PSOI,PSODRUG,PSOEDIT - ..K PSORENW,PSOSIGFL,PSOOIFLG,PSOMRFLG,PSODIR,CHK,PSORX("SIG"),PSODE - ..K PSOTRN,PSORX("EDIT"),PSORXED("FLD"),NEWEDT - ..D EOJ^PSONEW - ..D UL K PSOLOKED S VALMBCK="Q" - .S PSOFROM=PSOTMP I PSOFROM="" K PSOFROM - ; -EX1 I '$G(PSODE)!('$G(ZONE)) I $G(PSORENW("OIRXN")) D EN^PSOHLSN1(PSORENW("OIRXN"),"XX","","Order edited") -QUIT D UL K PSOLOKED D ^PSOBUILD,ACT^PSOORNE2 D:+^PSRX($P(PSOLST(ORN),"^",2),"STA")=5 EN^PSOCMOPC($P(PSOLST(ORN),"^",2)) - K:'$O(^PSRX($P(PSOLST(ORN),"^",2),1,0)) REF -EX2 S VALMBCK=$S($G(PSORX("FN")):"Q",$G(ZONE):"Q",1:"R") K PSORXED,FST,FLD,IEN,FLN,INCOM,PSOI,PSODRUG,PSOEDIT,PSORENW,PSOSIGFL,PSODIR,CHK,PSORX("SIG"),PSODE,PSOTRN,PSORX("DFLG"),RFED,ZONE,PSORX("EDIT"),PSOOIFLG,PSOMRFLG,SIG,QUIT - K NEWEDT I $G(VALMBCK)="R" W ! D CLEAN^PSOVER1 H 2 - Q - ; -EDT ; Rx Edit (Backdoor) - K NCPDPFLG - S I=0 F S I=$O(^PSRX($P(PSOLST(ORN),"^",2),1,I)) Q:'I S PSORXED("RX1")=^PSRX($P(PSOLST(ORN),"^",2),1,I,0) - S (RX0,PSORXED("RX0"))=^PSRX($P(PSOLST(ORN),"^",2),0),PSORXED("RX2")=$G(^(2)),PSORXED("RX3")=$G(^(3)),PSOSIG=$P(^("SIG"),"^") - F FLD=1:1:$L(FST,",") Q:$P(FST,",",FLD)']""!($G(PSORXED("DFLG")))!($G(PSORX("DFLG"))) S FLN=+$P(FST,",",FLD) D - .S PSORXED("DFLG")=0,(DA,PSORXED("IRXN"),PSORENW("OIRXN"))=$P(PSOLST(ORN),"^",2),RX0=^PSRX(PSORXED("IRXN"),0) S:$G(PSOSIG)="" PSOSIG=$P(^("SIG"),"^") - .I '$G(PSOSIGFL) D - ..S PSOI=+^PSRX(DA,"OR1"),PSODAYS=$P(RX0,"^",8),PSORXST=+$P($G(^PS(53,$P(RX0,"^",3),0)),"^",7) - ..I 'PSOI S PSOI=+^PSDRUG($P(RX0,"^",6),2),$P(^PSRX(DA,"OR1"),"^")=PSOI - ..S:'$G(PSODRUG("IEN")) PSODRUG("IEN")=$P(RX0,"^",6),PSODRUG("NAME")=$P(^PSDRUG($P(RX0,"^",6),0),"^") - ..S PSODRUG("OI")=PSOI - .S PSORX("PROVIDER")=$P(RX0,"^",4),PSORX("PROVIDER NAME")=$P(^VA(200,$P(RX0,"^",4),0),"^"),PSOTRN=$G(^PSRX(DA,"TN")) - .D:'$G(CHK) POP^PSOSIGNO(DA),CHK Q:$G(PSORXED("DFLG")) - .S FDR="39.2^"_$S($P(PSOPAR,"^",3):"6",1:"")_";6.5^113^114^3^1^22R^24^8^7^9^4^11;"_$S($P(RX0,"^",11)="W"&($P(PSOPAR,"^",12)):"35;",1:"")_"^10.6^5^20^23^12^PSOCOU^RF^81" - .I $G(ST)=11!($G(ST)=12) D NDCDAWDE^PSOORED7(ST,FLN,$G(RXN)) Q - .I FLN=20,'$G(REF) S VALMSG="There is no Refill Data to be edited." Q - .S DR=$P(FDR,"^",FLN) I DR="RF" D REF^PSOORED2 Q - .I DR="PSOCOU" D PSOCOU^PSOORED6 Q - .I FLN=2,'$P(PSOPAR,"^",3),$$RXRLDT^PSOBPSUT(RXN,0),$$STATUS^PSOBPSUT(RXN,0)'="" D Q - ..N NDC D NDC^PSODRG(RXN,0,,.NDC) I $G(NDC)="^"!($G(NDC)="") Q - ..S (PSODRUG("NDC"),PSORXED("FLD",27))=NDC - .I FLN'>2,'$P(PSOPAR,"^",3) S VALMSG="Check site parameters, Drug data is not editable." Q - .I FLN=3 D EDTDOSE^PSOORED2 Q - .I FLN=4 D INS^PSOORED1 Q - .I FLN=1 D PSOI^PSOORED6 N PSOX S PSORXED=1,PSOX("IRXN")=$S($D(DA):DA,$D(PSORXED("IRXN")):PSORXED("IRXN"),$D(PSORENW("OIRXN")):PSORENW("OIRXN")) D:'$G(PSORXED("DFLG")) EN^PSODIAG Q - .I FLN=2 D DRG^PSOORED6 N PSOX S PSORXED=1,PSOX("IRXN")=PSORXED("IRXN") D:'$G(PSORXED("DFLG")) EN^PSODIAG S:$O(^PSRX(PSORXED("IRXN"),1,0)) REF=1 Q - .I FLN=12 D PROV Q - .I FLN=6 D ISDT^PSOORED2 Q - .I FLN=7 D FLDT^PSOORED2 Q - .I FLN=21,$$STATUS^PSOBPSUT(RXN,0)="" S VALMSG="Invalid selection!" Q - .I FLN=21 D Q - ..N DAW D EDTDAW^PSODAWUT(RXN,0,.DAW) I $G(DAW)="^" Q - ..S (PSODRUG("DAW"),PSORXED("FLD",81))=DAW - .I FLN=9!(FLN=10)!(FLN=11) D NOCHG^PSOORED7 Q - .S DR=+DR - .K DIR,DIRUT,DIROUT ;S DIE=52 D ^DIE I $D(Y) S PSORXED("DFLG")=1 - .K DIC,DIQ S DIC=52,DA=PSORXED("IRXN"),DIQ="PSORXED" D EN^DIQ1 K DIC,DIQ - .S DIR("B")=$S($G(PSORXED("FLD",DR))]"":PSORXED("FLD",DR),1:PSORXED(52,DA,DR)),DIR(0)="52,"_DR D ^DIR - .I DR=24!(DR=12) S PSORXED("FLD",DR)=X - .I $D(DIRUT) K DIR,DIRUT,DUOUT,DTOUT,PSORXED(52,DA,DR),PSORXED("FLD",DR) Q - .I DR'=5,X="@" W !,"Data Required!",! K DIC,DIQ,DR,DA,DIR,DIRUT,PSORXED(52,DA,DR),X,Y Q - .I DR=5,X'="@" S Y=+Y - .I DR=3!(DR=20)!(DR=23) S Y=+Y - .S PSORXED("FLD",DR)=$S(X="@":X,1:Y) K DIR,DIRUT,DIROUT,X,Y,PSORXED(52,DA,DR) - .I DR=11,PSORXED("FLD",DR)="W",$P(PSOPAR,"^",12) D - ..D FIELD^DID(52,DR,"","LABEL","ZZ") S PSORXED(ZZ("LABEL"))=PSORXED("FLD",DR) K ZZ - ..S DR=35,DIQ="PSORXED" D EN^DIQ1 K DIC,DIQ,DIRUT,DUOUT,DTOUT - ..S:$G(PSORXED(52,DA,DR))]"" DIR("B")=PSORXED(52,DA,DR) - ..S DIR(0)="52,"_(DR) D ^DIR I $D(DIRUT),X'="@" K DIR,DIRUT Q - ..S PSORXED("FLD",DR)=X K DIR,DIRUT,DIROUT,X,Y,PSORXED(52,DA,DR) - .I $G(PSORXED("FLD",DR))]"" D FIELD^DID(52,DR,"","LABEL","ZZ") S PSORXED(ZZ("LABEL"))=PSORXED("FLD",DR) K ZZ - Q:$G(PSOSIGFL) - S (RX1,I,RFD,RFDT)=0 F S I=$O(^PSRX(PSORXED("IRXN"),1,I)) Q:'I S RFD=I,RFDT=$P(^PSRX(PSORXED("IRXN"),1,I,0),"^"),RX1(I)=$G(RX1(I))+1 - Q -CHK S CHK=1 I $G(^PSDRUG($P(PSORXED("RX0"),"^",6),"I"))]"",^("I")
2,'$P(PSOPAR,"^",3) S VALMSG="Check site parameters, Drug data is not editable." Q + .I FLN=3 D EDTDOSE^PSOORED2 Q + .I FLN=4 D INS^PSOORED1 Q + .I FLN=1 D PSOI^PSOORED6 N PSOX S PSORXED=1,PSOX("IRXN")=$S($D(DA):DA,$D(PSORXED("IRXN")):PSORXED("IRXN"),$D(PSORENW("OIRXN")):PSORENW("OIRXN")) D:'$G(PSORXED("DFLG")) EN^PSODIAG Q + .I FLN=2 D DRG^PSOORED6 N PSOX S PSORXED=1,PSOX("IRXN")=PSORXED("IRXN") D:'$G(PSORXED("DFLG")) EN^PSODIAG S:$O(^PSRX(PSORXED("IRXN"),1,0)) REF=1 Q + .I FLN=12 D PROV Q + .I FLN=6 D ISDT^PSOORED2 Q + .I FLN=7 D FLDT^PSOORED2 Q + .I FLN=21,$$STATUS^PSOBPSUT(RXN,0)="" S VALMSG="Invalid selection!" Q + .I FLN=21 D Q + ..N DAW D EDTDAW^PSODAWUT(RXN,0,.DAW) I $G(DAW)="^" Q + ..S (PSODRUG("DAW"),PSORXED("FLD",81))=DAW + .I FLN=9!(FLN=10)!(FLN=11) D NOCHG^PSOORED7 Q + .S DR=+DR + .K DIR,DIRUT,DIROUT ;S DIE=52 D ^DIE I $D(Y) S PSORXED("DFLG")=1 + .K DIC,DIQ S DIC=52,DA=PSORXED("IRXN"),DIQ="PSORXED" D EN^DIQ1 K DIC,DIQ + .S DIR("B")=$S($G(PSORXED("FLD",DR))]"":PSORXED("FLD",DR),1:PSORXED(52,DA,DR)),DIR(0)="52,"_DR D ^DIR + .I DR=24!(DR=12) S PSORXED("FLD",DR)=X + .I $D(DIRUT) K DIR,DIRUT,DUOUT,DTOUT,PSORXED(52,DA,DR),PSORXED("FLD",DR) Q + .I DR'=5,X="@" W !,"Data Required!",! K DIC,DIQ,DR,DA,DIR,DIRUT,PSORXED(52,DA,DR),X,Y Q + .I DR=5,X'="@" S Y=+Y + .I DR=3!(DR=20)!(DR=23) S Y=+Y + .S PSORXED("FLD",DR)=$S(X="@":X,1:Y) K DIR,DIRUT,DIROUT,X,Y,PSORXED(52,DA,DR) + .I DR=11,PSORXED("FLD",DR)="W",$P(PSOPAR,"^",12) D + ..D FIELD^DID(52,DR,"","LABEL","ZZ") S PSORXED(ZZ("LABEL"))=PSORXED("FLD",DR) K ZZ + ..S DR=35,DIQ="PSORXED" D EN^DIQ1 K DIC,DIQ,DIRUT,DUOUT,DTOUT + ..S:$G(PSORXED(52,DA,DR))]"" DIR("B")=PSORXED(52,DA,DR) + ..S DIR(0)="52,"_(DR) D ^DIR I $D(DIRUT),X'="@" K DIR,DIRUT Q + ..S PSORXED("FLD",DR)=X K DIR,DIRUT,DIROUT,X,Y,PSORXED(52,DA,DR) + .I $G(PSORXED("FLD",DR))]"" D FIELD^DID(52,DR,"","LABEL","ZZ") S PSORXED(ZZ("LABEL"))=PSORXED("FLD",DR) K ZZ + Q:$G(PSOSIGFL) + S (RX1,I,RFD,RFDT)=0 F S I=$O(^PSRX(PSORXED("IRXN"),1,I)) Q:'I S RFD=I,RFDT=$P(^PSRX(PSORXED("IRXN"),1,I,0),"^"),RX1(I)=$G(RX1(I))+1 + Q +CHK S CHK=1 I $G(^PSDRUG($P(PSORXED("RX0"),"^",6),"I"))]"",^("I")
0 S PSONEW("DAYS SUPPLY")=$P(OR0,"^",22) G DS - S PSONEW("DAYS SUPPLY")=$S(+$G(^PS(55,PSODFN,"PS"))&($P($G(^PS(53,+$G(^PS(55,PSODFN,"PS")),0)),"^",3)):$P(^PS(53,+$G(^PS(55,PSODFN,"PS")),0),"^",3),1:30) -DS S:$D(CLOZPAT) PSONEW("DAYS SUPPLY")=$S(CLOZPAT=2&(PSONEW("DAYS SUPPLY")>28):28,CLOZPAT=1&(PSONEW("DAYS SUPPLY")>14):14,'CLOZPAT&(PSONEW("DAYS SUPPLY")>7):7,1:PSONEW("DAYS SUPPLY")) - S IEN=0 D OBX ; Display Order Checks Information - D LMDISP^PSOORFI5(+$G(ORD)) ; Display Flag/Unflag Information - D DIN^PSONFI(PSODRUG("OI"),$S($D(PSODRUG("IEN")):PSODRUG("IEN"),1:"")) ;Setup for N/F & DIN indicator - I $G(PKI1)!($G(PKI)=1) D L1^PSOPKIV1 K:$G(PKI)=1 PKI - S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="*(1) Orderable Item: "_$P(^PS(50.7,PSODRUG("OI"),0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^")_NFIO - S:NFIO["" NFIO=IEN_","_($L(^TMP("PSOPO",$J,IEN,0))-4) - D FULL^VALM1 K LST I $G(PSODRUG("NAME"))]"" D G PST - .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (2)"_$S($D(^PSDRUG("AQ",PSODRUG("IEN"))):" CMOP ",1:" ")_"Drug: "_PSODRUG("NAME")_NFID - .S:NFID["" NFID=IEN_","_($L(^TMP("PSOPO",$J,IEN,0))-4) - .I $P(^PSDRUG(PSODRUG("IEN"),0),"^",10)]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Drug Message:" D DRGMSG^PSOORNEW - S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (2) Drug: No Dispense Drug Selected" -PST D DOSE^PSOORFI4 K PSOINSFL - S PSOINSFL=$P($G(^PS(52.41,ORD,"INS")),"^",2) - S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (4) Pat Instruct:" D INST^PSOORFI4 - S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Provider Comments:" S TY=3 D INST - S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Instructions:" S TY=2 D INST - S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" SIG:" D SIG - S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (5) Patient Status: "_$P($G(^PS(53,+PSONEW("PATIENT STATUS"),0)),"^") - S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (6) Issue Date: "_PSONEW("ISSUE DATE") - S (Y,PSONEW("FILL DATE"))=$S($E($P(OR0,"^",6),1,7)+$P(^PS(53,RXPT,0),"^",4):+$P(^PS(53,RXPT,0),"^",4),1:+$P(OR0,"^",11)),PSOX=+$P(^PS(53,RXPT,0),"^",4) - .S PSONEW("# OF REFILLS")=$S(PSONEW("# OF REFILLS")>PSOMAX:PSOMAX,1:PSONEW("# OF REFILLS")) - .S PSOMAX=$S(PSOMAX>+$P(^PS(53,RXPT,0),"^",4):+$P(^PS(53,RXPT,0),"^",4),1:PSOMAX) K RXPT - .S MPSDY=PSONEW("DAYS SUPPLY") - .;I PSOMAX=5 S MAXRF=$S(MPSDY<60:5,MPSDY'<60&(MPSDY'>89):2,1:1) I PSONEW("# OF REFILLS")>MAXRF S PSONEW("# OF REFILLS")=MAXRF K MAXRF,MPSDY Q - .S MAXRF=$S(MPSDY<60:11,MPSDY'<60&(MPSDY'>89):5,MPSDY=90:3,1:0) - .I PSONEW("# OF REFILLS")>MAXRF S PSONEW("# OF REFILLS")=MAXRF K MAXRF,MPSDY - E D - . I $G(PSOMAX) S PSONEW("# OF REFILLS")=$S(+$P(OR0,"^",11)>PSOMAX:PSOMAX,1:+$P(OR0,"^",11)) Q - .S PSONEW("# OF REFILLS")=+$P(OR0,"^",11) - S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_" (9) QTY"_$S($P($G(^PSDRUG(+$G(PSODRUG("IEN")),660)),"^",8)]"":" ("_$P($G(^PSDRUG(+$G(PSODRUG("IEN")),660)),"^",8)_")",1:" ( )")_": " - S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_$S($D(CLOZPAT):+$G(PSONEW("QTY")),1:$P(OR0,"^",10)) - I $P($G(^PSDRUG(+$G(PSODRUG("IEN")),5)),"^")]"" D - .S $P(RN," ",79)=" ",IEN=IEN+1 - .S ^TMP("PSOPO",$J,IEN,0)=$E(RN,$L("QTY DSP MSG: "_$P(^PSDRUG(PSODRUG("IEN"),5),"^"))+1,79)_"QTY DSP MSG: "_$P(^PSDRUG(PSODRUG("IEN"),5),"^") K RN - S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Provider ordered "_+$P(OR0,"^",11)_" refills" - D:$D(CLOZPAT) PQTY^PSOORFI4 - S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="(10) # of Refills: "_PSONEW("# OF REFILLS")_$E(" ",$L(PSONEW("# OF REFILLS"))+1,2)_" (11) Routing: "_$S($G(PSONEW("MAIL/WINDOW"))="M":"MAIL",1:"WINDOW") - S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="(12) Clinic: "_PSORX("CLINIC") - S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="(13) Provider: "_PSONEW("PROVIDER NAME") - I $P($G(^VA(200,$S($G(PSONEW("PROVIDER")):PSONEW("PROVIDER"),1:$P(OR0,"^",5)),"PS")),"^",7)&($P($G(^("PS")),"^",8)) S PSONEW("COSIGNING PROVIDER")=$P(^("PS"),"^",8) D - .D USER^PSOORFI2(PSONEW("COSIGNING PROVIDER")) - .S IEN=IEN+1 S ^TMP("PSOPO",$J,IEN,0)=" Cos-Provider: "_USER1 - S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="(14) Copies: 1" - S PSONEW("REMARKS")=$S($P(OR0,"^",17)="C":"Administered in Clinic.",1:"") - S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="(15) Remarks: "_$S($G(PSONEW("REMARKS"))]"":PSONEW("REMARKS"),1:"") - D USER^PSOORFI2($P(OR0,"^",4)) - S $P(RN," ",35)=" ",IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Entry By: "_USER1_$E(RN,$L(USER1)+1,35) - S Y=$P(OR0,"^",12) X ^DD("DD") S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"Entry Date: "_$E($P(OR0,"^",12),4,5)_"/"_$E($P(OR0,"^",12),6,7)_"/"_$E($P(OR0,"^",12),2,3)_" "_$P(Y,"@",2) K RN - S PSOACT=$S($D(^XUSEC("PSORPH",DUZ)):"DEFX",'$D(^XUSEC("PSORPH",DUZ))&($P($G(PSOPAR),"^",2)):"F",1:"") - ; - PSOACTOV is used to force the Pending Order to be Read-Only (no updates) even if invoked by a Pharmacist - I $G(PSOACTOV) S PSOACT="" - D:'$G(ACP) EN^PSOLMPO S:$G(ACP) VALMBCK="Q" D:$G(PKI1)=2 DCP^PSOPKIV1 - Q -POST ;post patient selection - D POST^PSOORFI2 Q -SIG ;displays possible sig - D SIG^PSOORFI2 Q -INST ;displays provider comments and pharmacy instructions - S INST=0 F S INST=$O(^PS(52.41,ORD,TY,INST)) Q:'INST D ;PSO*210 - . S (MIG,INST(INST))=^PS(52.41,ORD,TY,INST,0) - . D WORDWRAP^PSOUTLA2(MIG,.IEN,$NA(^TMP("PSOPO",$J)),20) - K INST,TY,MIG,SG - Q -OBX ;formats obx section - D OBX^PSOORFI4 - Q -ST ;sort by route or patient - W !!,"Enter 'PA' to process orders by patients",!," 'RT' to process orders by route (mail/window)",!," 'PR' to process orders by priority",!," 'CL' to process orders by clinic" - W !," 'FL' to process flagged orders",!," or 'E' or '^' to exit" W ! Q -RT ;which route to sort by - W !!,"Enter 'W' to process window orders first",!," 'M' to process mail orders first",!," 'C' to process orders administered in clinic first",!," or 'E' or '^' to exit" Q -PT ;process for all or one patient - W !!,"Enter 'A' to process all patient orders",!," 'S' to process orders for a patient",!," or 'E' or '^' to exit" Q -EP ;continue processing or not - W !,"If you want to continue processing orders Press RETURN or enter '^' to exit" Q -LOCK S PSOPLCK=$$L^PSSLOCK(PAT,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S POERR("QFLG")=1 - K PSOPLCK - Q -ULK S X=PAT_";DPT(" D ULK^ORX2 S:$G(PSOQUIT) POERR("QFLG")=1 ; not called anymore - Q -LOCK1 S PSOACT=$S($D(^XUSEC("PSORPH",DUZ)):"DEFX",'$D(^XUSEC("PSORPH",DUZ))&($P($G(PSOPAR),"^",2)):"F",1:"") - Q -EX K DRET,SIG,PSODRUG,PRC,PHI - K DIR,DIRUT,DUOUT,DIRUT,X,Y,DIC,POERR,PSONEW,PSOSD,MAIL,CLI,WIN,OR0,OR1,OR2,ORD,SRT,PSRT,PSODFN,PSOFROM,T,OR3,PAT,%,%T,%Y,DI,DQ,DR,DRG,STA,I,T1,PSOSORT - K TO,TC,TZ,PSOCPAY,PSOBILL,PSOIBQS,GROUPCNT,AGROUP,AGROUP1,OBX,%,%I,%H,D0,DFN,PSORX,PSOPTPST,PSOQFLG,PT,RTN,TM,TM1,DIPGM,PSOID,PSOCNT,PSOLK,PSZFIN,PSZFZZ D KVA^VADPT - K PSOFDR,PSOQUIT,PSOFIN,^TMP("PSOAO",$J),^TMP("PSODA",$J),^TMP("PSOPO",$J),^TMP("PSOPF",$J),^TMP("PSOPI",$J),^TMP("PSOHDR",$J),MEDA,MEDP - K C,CC,CNT,CRIT,D,DGI,DGS,DREN,IT,JJ,LG,MM,NIEN,PSOD,PATA,PSDAYS,PSOACT,PSOBM,PSOCOU,PSOCOUU,PSOFLAG,PSON,PSONOOR,PSOOPT,PSOPF,PSOPI,PSRF,RXFL,SDA,SEG1,SER,SERS,SLPPL,STAT,Z,Z4,ZDA - D FULL^VALM1 - Q +PSOORFI1 ;BIR/SAB - finish OP orders from OE/RR continued ;1/27/07 13:24 + ;;7.0;OUTPATIENT PHARMACY;**7,15,23,27,32,44,51,46,71,90,108,131,152,186,210,222,258,208**;DEC 1997;Build 39 + ; Modified from FOIA VISTA, + ; GPL Copyright (C) 2007 WorldVistA + ;Ref. ^PS(50.7 supp. DBIA 2223 + ;Ref. ^PSDRUG( supp. DBIA 221 + ;Ref. L^PSSLOCK supp. DBIA 2789 + ;Ref. ^PS(50.606 supp. DBIA 2174 + ;Ref. ^PS(55 supp. DBIA 2228 + ;Ref. ULK^ORX2 supp. DBIA 867 + ; + ;PSO*186 add call to function $$DEACHK + ;PSO*210 add call to WORDWRAP api + ; + S SIGOK=1 +DSPL K ^TMP("PSOPO",$J),CLOZPAT,PSOPRC,PSODSPL + S (OI,PSODRUG("OI"))=$P(OR0,"^",8),PSODRUG("OIN")=$P(^PS(50.7,$P(OR0,"^",8),0),"^"),OID=$P(OR0,"^",9) + I $P($G(OR0),"^",9) S POERR=1,DREN=$P(OR0,"^",9) D DRG^PSOORDRG K POERR G DRG + I '$P(OR0,"^",9)&($G(PSOAFYN)="Y") D DISPD^PSOAFIN G DSPL ;vfah 060924 + I '$P(OR0,"^",9) D DREN^PSOORNW2 +DRG I $P($G(^PSDRUG(+$G(PSODRUG("IEN")),"CLOZ1")),"^")="PSOCLO1" D CLOZ^PSOORFI2 + ;PSO*186 modify If/Else below to use DEACHK + I $G(PSODRUG("DEA"))]"" D + .S PSOCS=0 K DIR,DIC,PSOX + .N PSDEA,PSDAYS S PSDEA=PSODRUG("DEA"),PSDAYS=+$P(OR0,"^",22) + .I $$DEACHK^PSOUTLA1("*",PSDEA,PSDAYS,$G(CLOZPAT),.PSOCS,.PSOMAX) + E D + .S PSOMAX=$S($G(CLOZPAT)=2:3,$G(CLOZPAT)=1:1,1:$P(OR0,"^",11)) +ISSDT S (PSOID,Y,PSONEW("ISSUE DATE"))=$S($G(PSONEW("ISSUE DATE")):PSONEW("ISSUE DATE"),$P($G(OR0),"^",6):$E($P(OR0,"^",6),1,7),1:DT) + X ^DD("DD") S PSONEW("ISSUE DATE")=Y + D USER^PSOORFI2($P(OR0,"^",4)) S PSONEW("CLERK CODE")=$P(OR0,"^",4),PSORX("CLERK CODE")=USER1 + S (PSONEW("DFLG"),PSONEW("QFLG"))=0,PSODFN=$P(OR0,"^",2),PSONEW("QTY")=$P(OR0,"^",10),PSONEW("MAIL/WINDOW")=$S($P(OR0,"^",17)="M":"M",1:"W") + S:$G(PSONEW("CLINIC"))']"" PSONEW("CLINIC")=+$P(OR0,"^",13),PSORX("CLINIC")=$S($D(^SC(PSONEW("CLINIC"),0)):$P(^SC(PSONEW("CLINIC"),0),"^"),1:"") + S:$G(PSORX("CLINIC"))']"" PSORX("CLINIC")=$S($D(^SC(+$P(OR0,"^",13),0)):$P(^SC($P(OR0,"^",13),0),"^"),1:"") + D USER^PSOORFI2($P(OR0,"^",5)) + S PSONEW("CLERK CODE")=$P(OR0,"^",4),PSONEW("PROVIDER")=$P(OR0,"^",5),PSONEW("PROVIDER NAME")=USER1 + S PSONEW("PATIENT STATUS")=$S(+$G(^PS(55,PSODFN,"PS")):+$G(^PS(55,PSODFN,"PS")),1:"") + S PSONEW("CHCS NUMBER")=$S($P($G(^PS(52.41,+$G(ORD),"EXT")),"^")'="":$P($G(^("EXT")),"^"),1:"") + S PSONEW("EXTERNAL SYSTEM")=$S($P($G(^PS(52.41,+$G(ORD),"EXT")),"^",3)'="":$P($G(^("EXT")),"^",3),1:"") + I $P(OR0,"^",22)>0 S PSONEW("DAYS SUPPLY")=$P(OR0,"^",22) G DS + S PSONEW("DAYS SUPPLY")=$S(+$G(^PS(55,PSODFN,"PS"))&($P($G(^PS(53,+$G(^PS(55,PSODFN,"PS")),0)),"^",3)):$P(^PS(53,+$G(^PS(55,PSODFN,"PS")),0),"^",3),1:30) +DS S:$D(CLOZPAT) PSONEW("DAYS SUPPLY")=$S(CLOZPAT=2&(PSONEW("DAYS SUPPLY")>28):28,CLOZPAT=1&(PSONEW("DAYS SUPPLY")>14):14,'CLOZPAT&(PSONEW("DAYS SUPPLY")>7):7,1:PSONEW("DAYS SUPPLY")) + S IEN=0 D OBX + D DIN^PSONFI(PSODRUG("OI"),$S($D(PSODRUG("IEN")):PSODRUG("IEN"),1:"")) ;Setup for N/F & DIN indicator + I $G(PKI1)!($G(PKI)=1) D L1^PSOPKIV1 K:$G(PKI)=1 PKI + S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="*(1) Orderable Item: "_$P(^PS(50.7,PSODRUG("OI"),0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^")_NFIO + S:NFIO["" NFIO=IEN_","_($L(^TMP("PSOPO",$J,IEN,0))-4) + D FULL^VALM1 K LST I $G(PSODRUG("NAME"))]"" D G PST + .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (2)"_$S($D(^PSDRUG("AQ",PSODRUG("IEN"))):" CMOP ",1:" ")_"Drug: "_PSODRUG("NAME")_NFID + .S:NFID["" NFID=IEN_","_($L(^TMP("PSOPO",$J,IEN,0))-4) + .I $P(^PSDRUG(PSODRUG("IEN"),0),"^",10)]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Drug Message:" D DRGMSG^PSOORNEW + S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (2) Drug: No Dispense Drug Selected" +PST D DOSE^PSOORFI4 K PSOINSFL + S PSOINSFL=$P($G(^PS(52.41,ORD,"INS")),"^",2) + S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (4) Pat Instruct:" D INST^PSOORFI4 + S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Provider Comments:" S TY=3 D INST + S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Instructions:" S TY=2 D INST + S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" SIG:" D SIG + S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (5) Patient Status: "_$P($G(^PS(53,+PSONEW("PATIENT STATUS"),0)),"^") + S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (6) Issue Date: "_PSONEW("ISSUE DATE") + S (Y,PSONEW("FILL DATE"))=$S($E($P(OR0,"^",6),1,7)+$P(^PS(53,RXPT,0),"^",4):+$P(^PS(53,RXPT,0),"^",4),1:+$P(OR0,"^",11)),PSOX=+$P(^PS(53,RXPT,0),"^",4) + .S PSONEW("# OF REFILLS")=$S(PSONEW("# OF REFILLS")>PSOMAX:PSOMAX,1:PSONEW("# OF REFILLS")) + .S PSOMAX=$S(PSOMAX>+$P(^PS(53,RXPT,0),"^",4):+$P(^PS(53,RXPT,0),"^",4),1:PSOMAX) K RXPT + .S MPSDY=PSONEW("DAYS SUPPLY") + .;I PSOMAX=5 S MAXRF=$S(MPSDY<60:5,MPSDY'<60&(MPSDY'>89):2,1:1) I PSONEW("# OF REFILLS")>MAXRF S PSONEW("# OF REFILLS")=MAXRF K MAXRF,MPSDY Q + .S MAXRF=$S(MPSDY<60:11,MPSDY'<60&(MPSDY'>89):5,MPSDY=90:3,1:0) + .I PSONEW("# OF REFILLS")>MAXRF S PSONEW("# OF REFILLS")=MAXRF K MAXRF,MPSDY + E D + . I $G(PSOMAX) S PSONEW("# OF REFILLS")=$S(+$P(OR0,"^",11)>PSOMAX:PSOMAX,1:+$P(OR0,"^",11)) Q + .S PSONEW("# OF REFILLS")=+$P(OR0,"^",11) + S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_" (9) QTY"_$S($P($G(^PSDRUG(+$G(PSODRUG("IEN")),660)),"^",8)]"":" ("_$P($G(^PSDRUG(+$G(PSODRUG("IEN")),660)),"^",8)_")",1:" ( )")_": "_$P(OR0,"^",10) + S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_$S($D(CLOZPAT):+$G(PSONEW("QTY")),1:$P(OR0,"^",10)) + I $P($G(^PSDRUG(+$G(PSODRUG("IEN")),5)),"^")]"" D + .S $P(RN," ",79)=" ",IEN=IEN+1 + .S ^TMP("PSOPO",$J,IEN,0)=$E(RN,$L("QTY DSP MSG: "_$P(^PSDRUG(PSODRUG("IEN"),5),"^"))+1,79)_"QTY DSP MSG: "_$P(^PSDRUG(PSODRUG("IEN"),5),"^") K RN + S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Provider ordered "_+$P(OR0,"^",11)_" refills" + D:$D(CLOZPAT) PQTY^PSOORFI4 + S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="(10) # of Refills: "_PSONEW("# OF REFILLS")_$E(" ",$L(PSONEW("# OF REFILLS"))+1,2)_" (11) Routing: "_$S($G(PSONEW("MAIL/WINDOW"))="M":"MAIL",1:"WINDOW") + S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="(12) Clinic: "_PSORX("CLINIC") + S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="(13) Provider: "_PSONEW("PROVIDER NAME") + I $P($G(^VA(200,$S($G(PSONEW("PROVIDER")):PSONEW("PROVIDER"),1:$P(OR0,"^",5)),"PS")),"^",7)&($P($G(^("PS")),"^",8)) S PSONEW("COSIGNING PROVIDER")=$P(^("PS"),"^",8) D + .D USER^PSOORFI2(PSONEW("COSIGNING PROVIDER")) + .S IEN=IEN+1 S ^TMP("PSOPO",$J,IEN,0)=" Cos-Provider: "_USER1 + S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="(14) Copies: 1" + S PSONEW("REMARKS")=$S($P(OR0,"^",17)="C":"Administered in Clinic.",1:"") + S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="(15) Remarks: "_$S($G(PSONEW("REMARKS"))]"":PSONEW("REMARKS"),1:"") + D USER^PSOORFI2($P(OR0,"^",4)) + S $P(RN," ",35)=" ",IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Entry By: "_USER1_$E(RN,$L(USER1)+1,35) + S Y=$P(OR0,"^",12) X ^DD("DD") S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"Entry Date: "_$E($P(OR0,"^",12),4,5)_"/"_$E($P(OR0,"^",12),6,7)_"/"_$E($P(OR0,"^",12),2,3)_" "_$P(Y,"@",2) K RN + S PSOACT=$S($D(^XUSEC("PSORPH",DUZ)):"DEF",'$D(^XUSEC("PSORPH",DUZ))&($P($G(PSOPAR),"^",2)):"F",1:"") + D:'$G(ACP) EN^PSOLMPO S:$G(ACP) VALMBCK="Q" D:$G(PKI1)=2 DCP^PSOPKIV1 + Q +POST ;post patient selection + I $G(PSOAFYN)'="Y" D POST^PSOORFI2 Q ;vfah + I $G(PSOAFYN)="Y" Q ;vfah +SIG ;displays possible sig + D SIG^PSOORFI2 Q +INST ;displays provider comments and pharmacy instructions + S INST=0 F S INST=$O(^PS(52.41,ORD,TY,INST)) Q:'INST D ;PSO*210 + . S (MIG,INST(INST))=^PS(52.41,ORD,TY,INST,0) + . D WORDWRAP^PSOUTLA2(MIG,.IEN,$NA(^TMP("PSOPO",$J)),20) + K INST,TY,MIG,SG + Q +OBX ;formats obx section + D OBX^PSOORFI4 + Q +ST ;sort by route or patient + W !!,"Enter 'PA' to process orders by patients",!," 'RT' to process orders by route (mail/window)",!," 'PR' to process orders by priority",!," 'CL' to process orders by clinic",!," or 'E' or '^' to exit" W ! Q +RT ;which route to sort by + W !!,"Enter 'W' to process window orders first",!," 'M' to process mail orders first",!," 'C' to process orders administered in clinic first",!," or 'E' or '^' to exit" Q +PT ;process for all or one patient + W !!,"Enter 'A' to process all patient orders",!," 'S' to process orders for a patient",!," or 'E' or '^' to exit" Q +EP ;continue processing or not + W !,"If you want to continue processing orders Press RETURN or enter '^' to exit" Q +LOCK S PSOPLCK=$$L^PSSLOCK(PAT,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S POERR("QFLG")=1 + K PSOPLCK + Q +ULK S X=PAT_";DPT(" D ULK^ORX2 S:$G(PSOQUIT) POERR("QFLG")=1 ; not called anymore + Q +LOCK1 S PSOACT=$S($D(^XUSEC("PSORPH",DUZ)):"DEF",'$D(^XUSEC("PSORPH",DUZ))&($P($G(PSOPAR),"^",2)):"F",1:"") + Q +EX K DRET,SIG,PSODRUG,PRC,PHI + K DIR,DIRUT,DUOUT,DIRUT,X,Y,DIC,POERR,PSONEW,PSOSD,MAIL,CLI,WIN,OR0,OR1,OR2,ORD,SRT,PSRT,PSODFN,PSOFROM,T,OR3,PAT,%,%T,%Y,DI,DQ,DR,DRG,STA,I,T1,PSOSORT + K TO,TC,TZ,PSOCPAY,PSOBILL,PSOIBQS,GROUPCNT,AGROUP,AGROUP1,OBX,%,%I,%H,D0,DFN,PSORX,PSOPTPST,PSOQFLG,PT,RTN,TM,TM1,DIPGM,PSOID,PSOCNT,PSOLK,PSZFIN,PSZFZZ D KVA^VADPT + K PSOFDR,PSOQUIT,PSOFIN,^TMP("PSOAO",$J),^TMP("PSODA",$J),^TMP("PSOPO",$J),^TMP("PSOPF",$J),^TMP("PSOPI",$J),^TMP("PSOHDR",$J),MEDA,MEDP + K C,CC,CNT,CRIT,D,DGI,DGS,DREN,IT,JJ,LG,MM,NIEN,PSOD,PATA,PSDAYS,PSOACT,PSOBM,PSOCOU,PSOCOUU,PSOFLAG,PSON,PSONOOR,PSOOPT,PSOPF,PSOPI,PSRF,RXFL,SDA,SEG1,SER,SERS,SLPPL,STAT,Z,Z4,ZDA + D FULL^VALM1 + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFI2.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFI2.m index 3aa8b55f..198de448 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFI2.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFI2.m @@ -1,168 +1,142 @@ -PSOORFI2 ;BIR/BHW-finish cprs orders cont. ;07/29/96 - ;;7.0;OUTPATIENT PHARMACY;**7,15,23,27,46,130,146,177,222,225**;DEC 1997;Build 29 - ;External reference ^YSCL(603.01 supported by DBIA 2697 - ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789 -HLP W !,"Enter 'S' to process orders with a priority of STAT",!," 'E' to process orders with an Emergency priority,",!," 'R' to process Routine orders.",! Q -HELP ; - W !,"Please enter a minimum of two (2) characters.",!,"Enter Patient's name whose med orders are to be completed.",! - S (PATN,DPT)=0 F S DPT=$O(^PS(52.41,"AOR",DPT)) Q:'DPT I $D(^PS(52.41,"AOR",DPT,PSOPINST)) W !,$P(^DPT(DPT,0),"^") S PATN=PATN+1 I PATN=20 D I $D(DUOUT)!($D(DTOUT)) G HELPX - .K DIR,DUOUT,DTOUT,DIRUT S DIR(0)="E" D ^DIR S PATN=0 K DIR -HELPX K DTOUT,DUOUT,DIRUT,PAINST S DIR(0)="FO^2:30",DIR("A")="Select Patient",DIR("?")="^D HELP^PSOORFIN" - K PATN,DPT Q -RTE ; - S PSZFIN=1 - F PSZFZZ=0:0 S PSZFZZ=$O(^PS(52.41,"AC",PAT,$E(PSRT),PSZFZZ)) Q:'PSZFZZ!('PSZFIN) D - .I $P($G(^PS(52.41,PSZFZZ,0)),"^",3)="NW"!($P($G(^(0)),"^",3)="RNW")!($P($G(^(0)),"^",3)="RF") I $P($G(^PS(52.41,PSZFZZ,"INI")),"^")=$G(PSOPINST) S PSZFIN=0 - Q -PRI ; - S PSZFIN=1 - F PSZFZZ=0:0 S PSZFZZ=$O(^PS(52.41,"AP",PAT,$E(PSRT),PSZFZZ)) Q:'PSZFZZ!('PSZFIN) D - .I $P($G(^PS(52.41,PSZFZZ,0)),"^",3)="NW"!($P($G(^(0)),"^",3)="RNW")!($P($G(^(0)),"^",3)="RF") I $P($G(^PS(52.41,PSZFZZ,"INI")),"^")=$G(PSOPINST) S PSZFIN=0 - Q -PROFILE ;display med profile - S MEDA=3 ;3=question asked already - W !!! K MEDP,DIR,DUOUT,DIRUT,DTOUT S DIR(0)="Y",DIR("B")="Yes",DIR("A")="Do you want to see Medication Profile" D ^DIR K DIR Q:$D(DIRUT)!('Y) - I Y S MEDP=1 - K DIR,DUOUT,DIRUT,DTOUT - Q -DC I '$G(PSOORRNW),$G(PSOOPT)=3 S PSORENW("DFLG")=1 S:'$D(PSOBBC1("FROM")) VALMBCK="Q",VALMSG="Renew Rx Request Canceled.",Y=-1 Q - G DC^PSOORFI6 - Q -DE Q:'$D(^PS(52.41,ORD,0)) - K ^PS(52.41,"AOR",$P(^PS(52.41,ORD,0),"^",2),+$P($G(^PS(52.41,ORD,"INI")),"^"),ORD),^PS(52.41,"AD",$P(^PS(52.41,ORD,0),"^",12),+$P($G(^PS(52.41,ORD,"INI")),"^"),ORD) - S $P(^PS(52.41,ORD,0),"^",3)="DC",POERR("PLACER")=$P(^(0),"^"),POERR("STAT")="OC" - S POERR("COMM")=$S($G(POERR("DEAD")):"Patient died on "_$G(PSOPTPST(2,PSODFN,.351))_".",1:ACOM),$P(^PS(52.41,ORD,4),"^")=POERR("COMM") - D EN^PSOHLSN(POERR("PLACER"),POERR("STAT"),POERR("COMM"),PSONOOR) - I '$G(POERR("DEAD")) S DIR("A")="Press Return to Continue" D PAUSE^VALM1 - K PSONOOR,PDORUG,ACOM,CMOP,DEA,DEF,DREN,FDR,HDR,PHI,PRC,SIGOK,DIR,DTOUT,DUOUT,DIRUT - S Y=-1 Q - ; -RF ;process refill request from CPRS - S PSOREF("IRXN")=$P(OR0,"^",19) D PSOL^PSSLOCK($P(OR0,"^",19)) I '$G(PSOMSG) D D PAUSE^VALM1 K PSOREF,PSOMSG Q - .I $P($G(PSOMSG),"^",2)'="" W $C(7),!!,$P(PSOMSG,"^",2),! Q - .W $C(7),!!,"Another person is editing Rx "_$P(^PSRX($P(OR0,"^",19),0),"^"),! - ; - D FULL^VALM1 - I '$P($G(^PS(52.41,ORD,0)),"^",23),+$G(^PS(52.41,ORD,"FLG")) D I $D(DIRUT)!'Y S VALMBCK="B" Q - . K DIRUT,DUOUT,DTOUT,DIR - . S DIR("A",1)="Flagged by "_$$GET1^DIQ(52.41,ORD,34)_" on "_$$GET1^DIQ(52.41,ORD,33)_": "_$$GET1^DIQ(52.41,ORD,35) - . S DIR("A",2)="" - . S DIR("A",3)="Unflagged by "_$$GET1^DIQ(52.41,ORD,37)_" on "_$$GET1^DIQ(52.41,ORD,36)_": "_$$GET1^DIQ(52.41,ORD,38) - . S DIR("A",4)="" - . S DIR(0)="Y",DIR("B")="YES",DIR("A")="Continue" - . W ! D ^DIR - ; - I $G(ORD),+$P($G(^PS(52.41,+ORD,0)),"^",23)=1 D Q:$D(DIRUT)!'Y D EN1^ORCFLAG(+$P($G(^PS(52.41,ORD,0)),"^")) H 1 - . K DIRUT,DUOUT,DTOUT,DIR - . S DIR("A",1)="This Refill Request is flagged. In order to process it" - . S DIR("A",2)="you must unflag it first." - . S DIR("A",3)="" - . S DIR(0)="Y",DIR("A")="Unflag Refill Request",DIR("B")="NO" - . W ! D ^DIR I $D(DIRUT)!'Y S VALMBCK="B" - I $G(ORD),+$P($G(^PS(52.41,+ORD,0)),"^",23)=1 Q - ; - K PSOMSG S (PSOREF("DFLG"),PSOREF("FIELD"),PSOREF1)=0,X="T-6M",%DT="X" D ^%DT - S (PSOID,PSOREF("ISSUE DATE"))=$S($P(^PSRX(PSOREF("IRXN"),0),"^",13)0:PSOCNT,1:"no")," flagged order",$S(PSOCNT=1:"",1:"s")," for ",PSODINST,">",! - K PSODINST - Q - ; -CNT(SITE) ; - Counter for flagged pending orders by Site - N CNT,ORD - S (CNT,LOGIN,ORD)=0 - F S LOGIN=$O(^PS(52.41,"AD",LOGIN)) Q:'LOGIN D - . F S ORD=$O(^PS(52.41,"AD",LOGIN,SITE,ORD)) Q:'ORD D - . . I $P(^PS(52.41,ORD,0),"^",3)="DC"!($P(^PS(52.41,ORD,0),"^",3)="DE") Q - . . I $P($G(^PS(52.41,ORD,0)),"^",23) S CNT=CNT+1 - Q CNT - ; -INST1 ; - K PSOPINST N PSIR - F PSIR=0:0 S PSIR=$O(^PS(59,PSOSITE,"INI1",PSIR)) Q:'PSIR!($G(PSOPINST)) I $P($G(^PS(59,PSOSITE,"INI1",PSIR,0)),"^") S PSOPINST=$P($G(^(0)),"^") - Q -CLOZ ;checks clozapine status of patient - S CLOZPAT=$O(^YSCL(603.01,"C",PSODFN,0)) - S CLOZPAT=$P($G(^YSCL(603.01,+CLOZPAT,0)),"^",3) - S CLOZPAT=$S(CLOZPAT="M":2,CLOZPAT="B":1,1:0) - S:'$D(PSONEW("# OF REFILLS")) (PSONEW("# OF REFILLS"),PSONEW("N# REF"))=0 - Q -ELIG I $G(CLOZPAT)=1 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Patient Eligible for 14 Day Supply or 7 Day Supply with 1 refill" - I $G(CLOZPAT)=2 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Patient Eligible for 28 Day Supply or 14 Day Supply with 1 refill or 7 Day Supply with 3 refill" - Q -USER(USER) ;returns .01 of 200 - K DIC,X,Y S DIC="^VA(200,",DIC(0)="M",X="`"_USER D ^DIC S USER1=$S(+Y:$P(Y,"^",2),1:"Unknown") K DIC,X,Y - Q -INSTNM ; - K PSOFINDA,PSODINST I $G(DA) S PSOFINDA=$G(DA) - K PSODNM S DA=$G(PSOPINST) I DA S DIC=4,DIQ(0)="E",DR=".01",DIQ="PSODNM" D EN^DIQ1 S PSODINST=$G(PSODNM(4,DA,.01,"E")) K PSODNM,DIC,DR,DA - I $G(PSOFINDA) S DA=$G(PSOFINDA) K PSOFINDA - Q -POST S PSOFINY=$G(Y) D ^PSOBUILD S Y=$G(PSOFINY) K PSOFINY D OERR^PSORX1 I $G(PSOQUIT) Q - K PSOQFLG F PT="GET","DEAD","INP","CNH","TPB","ADDRESS","COPAY" S RTN=PT_"^PSOPTPST" D @RTN K PSOXFLG Q:$G(POERR("DEAD"))!($G(PSOQFLG)) - I $G(POERR("DEAD")) S POERR("QFLG")=1 Q - K PSOERR("DEAD") I $G(PSOQFLG) Q - D ^PSOORUT2,BLD^PSOORUT1,EN^PSOLMUTL - Q -SIG ; - S SIG=0,PSOFINFL=1 F S SIG=$O(^PS(52.41,ORD,"SIG",SIG)) Q:'SIG D - .S (MIG,SIG(SIG))=^PS(52.41,ORD,"SIG",SIG,0) - .F SG=1:1:$L(MIG," ") S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(MIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " S ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(MIG," ",SG) D - ..I $E(^TMP("PSOPO",$J,IEN,0),$L(^TMP("PSOPO",$J,IEN,0)))=" " S ^TMP("PSOPO",$J,IEN,0)=$E(^TMP("PSOPO",$J,IEN,0),1,($L(^TMP("PSOPO",$J,IEN,0))-1)) - S:$O(SIG(0)) SIGOK=1 K MIG - F D=0:0 S D=$O(^PS(52.41,ORD,"INS1",D)) Q:'D S PSONEW("INS",D)=^PS(52.41,ORD,"INS1",D,0) - ;I PSONEW("INS")]"" S X=PSONEW("INS") D SIG^PSOHELP I $G(INS1)]"" S PSONEW("SIG")=$E(INS1,2,9999999) - Q +PSOORFI2 ;BIR/BHW-finish cprs orders cont. ;1/27/07 13:25 + ;;7.0;OUTPATIENT PHARMACY;**7,15,23,27,46,130,146,177,222,208**;DEC 1997;Build 39 + ; Modified from FOIA VISTA, + ; GPL Copyright (C) 2007 WorldVistA + ;Ext ref ^YSCL(603.01 supported by DBIA 2697 + ;Ext refs PSOL and PSOUL^PSSLOCK supported by DBIA 2789 +HLP W !,"Enter 'S' to process orders with a priority of STAT",!," 'E' to process orders with an Emergency priority,",!," 'R' to process Routine orders.",! Q +HELP ; + W !,"Please enter a minimum of two (2) characters.",!,"Enter Patient's name whose med orders are to be completed.",! + S (PATN,DPT)=0 F S DPT=$O(^PS(52.41,"AOR",DPT)) Q:'DPT I $D(^PS(52.41,"AOR",DPT,PSOPINST)) W !,$P(^DPT(DPT,0),"^") S PATN=PATN+1 I PATN=20 D I $D(DUOUT)!($D(DTOUT)) G HELPX + .K DIR,DUOUT,DTOUT,DIRUT S DIR(0)="E" D ^DIR S PATN=0 K DIR +HELPX K DTOUT,DUOUT,DIRUT,PAINST S DIR(0)="FO^2:30",DIR("A")="Select Patient",DIR("?")="^D HELP^PSOORFIN" + K PATN,DPT Q +RTE ; + S PSZFIN=1 + F PSZFZZ=0:0 S PSZFZZ=$O(^PS(52.41,"AC",PAT,$E(PSRT),PSZFZZ)) Q:'PSZFZZ!('PSZFIN) D + .I $P($G(^PS(52.41,PSZFZZ,0)),"^",3)="NW"!($P($G(^(0)),"^",3)="RNW")!($P($G(^(0)),"^",3)="RF") I $P($G(^PS(52.41,PSZFZZ,"INI")),"^")=$G(PSOPINST) S PSZFIN=0 + Q +PRI ; + S PSZFIN=1 + F PSZFZZ=0:0 S PSZFZZ=$O(^PS(52.41,"AP",PAT,$E(PSRT),PSZFZZ)) Q:'PSZFZZ!('PSZFIN) D + .I $P($G(^PS(52.41,PSZFZZ,0)),"^",3)="NW"!($P($G(^(0)),"^",3)="RNW")!($P($G(^(0)),"^",3)="RF") I $P($G(^PS(52.41,PSZFZZ,"INI")),"^")=$G(PSOPINST) S PSZFIN=0 + Q +PROFILE ; + S MEDA=3 + I $G(PSOAFYN)'="Y" W !!! K MEDP,DIR,DUOUT,DIRUT,DTOUT S DIR(0)="Y",DIR("B")="Yes",DIR("A")="Do you want to see Medication Profile" D ^DIR K DIR Q:$D(DIRUT)!('Y) + I $G(PSOAFYN)'="Y" I Y S MEDP=1 + I $G(PSOAFYN)="Y" K MEDP + K DIR,DUOUT,DIRUT,DTOUT + Q +DC I '$G(PSOORRNW),$G(PSOOPT)=3 S PSORENW("DFLG")=1 S:'$D(PSOBBC1("FROM")) VALMBCK="Q",VALMSG="Renew Rx Request Canceled.",Y=-1 Q + I $G(PSOAFYN)'="Y" N VALMCNT W ! K DIR,DUOUT,DIROUT,DTOUT,PSOELSE I '$G(PSOERR("DEAD")) S PSOELSE=1 D Q:$D(DIRUT) + .D NOOR^PSOCAN4 Q:$D(DIRUT) + .S DIR("A")="Comments",DIR(0)="F^10:75",DIR("B")="Per Pharmacy Request" D ^DIR K DIR + I $G(PSOAFYN)="Y" N VALMCNT K DIR,DUOUT,DIROUT,DTOUT,PSOELSE I '$G(PSOERR("DEAD")) S PSOELSE=1 D Q:$D(DIRUT) ;vfah + .D NOOR^PSOCAN4 Q:$D(DIRUT) ;vfah + .S Y="Rx AutoFinish" ;vfah + I $G(PSOAFYN)'="Y" S PSOELSE="1" + I '$G(PSOELSE) K PSOELSE S PSONOOR="A" G DE + K PSOELSE I $D(DIRUT) K DIRUT,DUOUT,DTOUT,Y Q + S ACOM=Y +DE I $G(PSOAFYN)="Y" Q + I $G(PSOAFYN)'="Y" Q:'$D(^PS(52.41,ORD,0)) + K ^PS(52.41,"AOR",$P(^PS(52.41,ORD,0),"^",2),+$P($G(^PS(52.41,ORD,"INI")),"^"),ORD),^PS(52.41,"AD",$P(^PS(52.41,ORD,0),"^",12),+$P($G(^PS(52.41,ORD,"INI")),"^"),ORD) + S $P(^PS(52.41,ORD,0),"^",3)="DC",POERR("PLACER")=$P(^(0),"^"),POERR("STAT")="OC" + S POERR("COMM")=$S($G(POERR("DEAD")):"Patient died on "_$G(PSOPTPST(2,PSODFN,.351))_".",1:ACOM),$P(^PS(52.41,ORD,4),"^")=POERR("COMM") + D EN^PSOHLSN(POERR("PLACER"),POERR("STAT"),POERR("COMM"),PSONOOR) + I '$G(POERR("DEAD")) S DIR("A")="Press Return to Continue" D PAUSE^VALM1 + K PSONOOR,PDORUG,ACOM,CMOP,DEA,DEF,DREN,FDR,HDR,PHI,PRC,SIGOK,DIR,DTOUT,DUOUT,DIRUT + S Y=-1 Q + ; +RF ; + S PSOREF("IRXN")=$P(OR0,"^",19) D PSOL^PSSLOCK($P(OR0,"^",19)) I '$G(PSOMSG) D D PAUSE^VALM1 K PSOREF,PSOMSG Q + .I $P($G(PSOMSG),"^",2)'="" W $C(7),!!,$P(PSOMSG,"^",2),! Q + .W $C(7),!!,"Another person is editing Rx "_$P(^PSRX($P(OR0,"^",19),0),"^"),! + K PSOMSG S (PSOREF("DFLG"),PSOREF("FIELD"),PSOREF1)=0,X="T-6M",%DT="X" D ^%DT + S (PSOID,PSOREF("ISSUE DATE"))=$S($P(^PSRX(PSOREF("IRXN"),0),"^",13)80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " S ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(MIG," ",SG) D + ..I $E(^TMP("PSOPO",$J,IEN,0),$L(^TMP("PSOPO",$J,IEN,0)))=" " S ^TMP("PSOPO",$J,IEN,0)=$E(^TMP("PSOPO",$J,IEN,0),1,($L(^TMP("PSOPO",$J,IEN,0))-1)) + S:$O(SIG(0)) SIGOK=1 K MIG + F D=0:0 S D=$O(^PS(52.41,ORD,"INS1",D)) Q:'D S PSONEW("INS",D)=^PS(52.41,ORD,"INS1",D,0) + ;I PSONEW("INS")]"" S X=PSONEW("INS") D SIG^PSOHELP I $G(INS1)]"" S PSONEW("SIG")=$E(INS1,2,9999999) + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFI3.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFI3.m index 3f9fe769..037e8ec9 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFI3.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFI3.m @@ -1,131 +1,133 @@ -PSOORFI3 ;BIR/RTR-finish CPRS orders by Clinic ;11/09/98 - ;;7.0;OUTPATIENT PHARMACY;**15,27,32,46,84,99,130,117,139,172,225**;DEC 1997;Build 29 - ;PPPPDA1-1374,SC(-2675,40.8-728,51.2-2226,50.607-2221,55-2228,PSSLOCK-2789,DPT-10035,ORX2-867 - ; - K ^TMP($J,"PSOCL"),^TMP($J,"PSOCLX"),PSOCLIN,PSOCLINF,PSOXINST - N PSOCFLAG,PSONPTRX,PSOINPTR,PSCLP,PSOCLINS,PSOSTC,PSOLGD,PSODIEN,PSOCTMP - K DIR S DIR(0)="SMB^C:CLINIC;S:SORT GROUP;E:EXIT",DIR("A")="Select By",DIR("B")="Clinic",DIR("?",1)="Enter 'C' to process orders for one individual Clinic," - S DIR("?",2)=" 'S' to process orders for all Clinics associated with a Sort Group,",DIR("?",3)=" '^' or 'E' to exit" S DIR("?")=" " - W ! D ^DIR K DIR I $D(DTOUT)!($D(DUOUT))!(Y="E") W ! G EXIT - I Y="S" G SORT -CLIN W ! K DIC S DIC="^SC(",DIC(0)="QEAMZ",DIC("A")="Select CLINIC: " D ^DIC K DIC I Y<1!($D(DTOUT))!($D(DUOUT)) G EXIT - S PSOCLIN=+Y,PSOCLINF=1 D CHECK I $G(PSOCFLAG) D INSTNM^PSOORFI2 W !!,"You are signed in under the "_$G(PSODINST)_" CPRS Ordering",!,"Institution, which does not match the Institution for this Clinic!",! K PSODINST G CLIN - S ^TMP($J,"PSOCL",PSOCLIN)=PSOCLIN K PSOCLIN G START -SORT W ! K DIC S DIC="^PS(59.8,",DIC(0)="QEAMZ",DIC("A")="Select CLINIC SORT GROUP: " D ^DIC K DIC I Y<1!($D(DTOUT))!($D(DUOUT)) G EXIT - S PSOCLINS=+Y - K ^TMP($J,"PSOCL"),^TMP($J,"PSOCLX") F PSCLP=0:0 S PSCLP=$O(^PS(59.8,PSOCLINS,1,PSCLP)) Q:'PSCLP S PSOSTC=+$P($G(^PS(59.8,PSOCLINS,1,PSCLP,0)),"^") S:$G(PSOSTC)&($D(^SC(PSOSTC,0))) ^TMP($J,"PSOCL",PSOSTC)=PSOSTC - I '$O(^TMP($J,"PSOCL",0)) W !!,"There are no Clinics associated with this Sort Group!",! K ^TMP($J,"PSOCL") G SORT - F PSCLP=0:0 S PSCLP=$O(^TMP($J,"PSOCL",PSCLP)) Q:'PSCLP S PSOCLIN=PSCLP D CHECK I $G(PSOCFLAG) S ^TMP($J,"PSOCLX",PSCLP)=PSCLP K ^TMP($J,"PSOCL",PSCLP) - I $O(^TMP($J,"PSOCLX",0)) H 1 W @IOF W !,"Orders for these Clinics in the Sort Group will not be displayed for Finishing",!,"because the CPRS Ordering Institution does not match the Institution that is",!,"associated with the Clinic:",! D - .F PSCLP=0:0 S PSCLP=$O(^TMP($J,"PSOCLX",PSCLP)) Q:'PSCLP D:($Y+4)>IOSL W !,$P($G(^SC(PSCLP,0)),"^") - ..W ! K DIR S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR K DIR W @IOF - I $O(^TMP($J,"PSOCLX",0)) D EOP - K ^TMP($J,"PSOCLX") I '$O(^TMP($J,"PSOCL",0)) W !!,"There are no Clinics that have a matching Institution!",! D EOP G SORT - ; - S PSOCLINF=2 -START K MEDP,MEDA,PSOQUIT,POERR("QFLG"),POERR("DFLG"),DIR - G:'$O(^TMP($J,"PSOCL",0)) EXIT - S PATA=0 F PSOCLIN=0:0 S PSOCLIN=$O(^TMP($J,"PSOCL",PSOCLIN)) Q:'PSOCLIN!($G(POERR("QFLG"))) F PSOLGD=0:0 S PSOLGD=$O(^PS(52.41,"ACL",PSOCLIN,PSOLGD)) Q:'PSOLGD!($G(POERR("QFLG"))) D - .F PSODIEN=0:0 S PSODIEN=$O(^PS(52.41,"ACL",PSOCLIN,PSOLGD,PSODIEN)) Q:'PSODIEN!($G(POERR("QFLG"))) D - ..I $P($G(^PS(52.41,PSODIEN,0)),"^",3)'="NW",$P($G(^(0)),"^",3)'="RNW",$P($G(^(0)),"^",3)'="RF" Q - ..I $G(PSOPINST)'=$P($G(^PS(52.41,PSODIEN,"INI")),"^") Q - ..Q:$G(PAT($P(^PS(52.41,PSODIEN,0),"^",2)))=$P(^PS(52.41,PSODIEN,0),"^",2) S PAT=$P(^PS(52.41,PSODIEN,0),"^",2) - ..I PAT'=PATA,$O(PSORX("PSOL",0))!($D(RXRS)) D LBL^PSOORFIN - ..D LK^PSOORFIN I $G(POERR("QFLG")) K POERR("QFLG") S PSOLK=1,PAT(PAT)=PAT Q - ..I $$CHK^PSODPT(PAT_"^"_$P($G(^DPT(PAT,0)),"^"),1,1)<0 S PSOLK=1,PAT(PAT)=PAT S X=PAT D ULP^PSOORFIN Q - ..S (PSODFN,Y)=PAT_"^"_$P($G(^DPT(+$G(PAT),0)),"^"),PATA=PAT - ..D:'$G(MEDA) PROFILE^PSOORFI2 S Y=PSODFN I $G(MEDP) K PSOFIN S POERR("QFLG")=0 S PSONOLCK=1,PSOPTLOK=PAT D OERR^PSORX1 S PSOFIN=1 D QU^PSOORFIN S X=PSOPTLOK D KLLP^PSOORFIN,ULP^PSOORFIN,KLL^PSOORFIN Q - ..D SDFN^PSOORFIN D POST^PSOORFI1 I $G(PSOQFLG)!($G(PSOQUIT)) S:$G(PSOQUIT) POERR("QFLG")=1 S:$G(PSOQFLG) PAT(PAT)=PAT S X=PAT D ULP^PSOORFIN K PSOQFLG Q - ..S PAT(PAT)=PAT - ..F ORD=0:0 S ORD=$O(^PS(52.41,"AOR",PAT,PSOPINST,ORD)) Q:'ORD!($G(POERR("QFLG"))) I '$P($G(^PS(52.41,ORD,0)),"^",23) D - ...S PSODFN=PAT D NOW^%DTC S TM=$E(%,1,12),TM1=$P(TM,".",2),X="PPPPDA1" X ^%ZOSF("TEST") S:$T X=$$PDA^PPPPDA1(PSODFN) - ...D LK1^PSOORFIN,ORD^PSOORFIN S X=PAT D ULP^PSOORFIN - I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL^PSOORFIN - ; -EXIT K ^TMP($J,"PSOCL"),^TMP($J,"PSOCLX"),PSOCLIN,PSOCLINF,PSOXINST G EX^PSOORFIN - Q -CHECK ; check Institution - K PSOXINST,PSOCFLAG - I $P($G(^SC(PSOCLIN,0)),"^",4),$P($G(^(0)),"^",4)'=$G(PSOPINST) S PSOCFLAG=1 Q - I $P($G(^SC(PSOCLIN,0)),"^",4) Q - S PSONPTRX=$P($G(^SC(PSOCLIN,0)),"^",15) - I '$G(PSONPTRX) S PSONPTRX=$O(^DG(40.8,0)) - I '$G(DT) S DT=$$DT^XLFDT - S PSOINPTR=+$$SITE^VASITE(DT,PSONPTRX) I PSOINPTR'=$G(PSOPINST) S PSOCFLAG=1 - Q -EOP W ! K DIR S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR K DIR - Q -L1 ;Lock single order - I '$G(ORD) Q - K PSOMSG D PSOL^PSSLOCK(+ORD_"S") I '$G(PSOMSG) W !!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"This Order is being edited by another person."),! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR - Q -UL1 ;Unlock single order - I '$G(ORD) Q - I '$D(^PS(52.41,ORD,0)) D Q - . D UNLK1^ORX2(+$G(OR0)) - . Q - D PSOUL^PSSLOCK(+ORD_"S") - Q -DOSE ;pending orders - K DOENT S DS=1 - F I=0:0 S I=$O(^PS(52.41,ORD,1,I)) Q:'I S DOSE=$G(^PS(52.41,ORD,1,I,1)),DOSE1=$G(^(2)) D D DOSE1 - .S PSONEW("DOSE",I)=$P(DOSE1,"^"),PSONEW("DOSE ORDERED",I)=$P(DOSE1,"^",2),PSONEW("UNITS",I)=$P(DOSE,"^",9),PSONEW("NOUN",I)=$P(DOSE,"^",5) - .S:$P(DOSE,"^",9) UNITS=$P(^PS(50.607,$P(DOSE,"^",9),0),"^") - .S PSONEW("VERB",I)=$P(DOSE,"^",10),PSONEW("ROUTE",I)=$P(DOSE,"^",8) - .S:$P(DOSE,"^",8) ROUTE=$P(^PS(51.2,$P(DOSE,"^",8),0),"^") - .S PSONEW("SCHEDULE",I)=$P(DOSE,"^"),PSONEW("DURATION",I)=$P(DOSE,"^",2) - .S DOENT=$G(DOENT)+1 S PSONEW("CONJUNCTION",I)=$S($P(DOSE,"^",6)="A":"AND",$P(DOSE,"^",6)="S":"THEN",$P(DOSE,"^",6)="X":"EXCEPT",1:"") - .I 'PSONEW("DOSE ORDERED",I),$G(PSONEW("VERB",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Verb: "_$G(PSONEW("VERB",I)) - .S:$G(DS) IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (3)" - S PSONEW("ENT")=DOENT K DOSE,DOSE1,I,UNITS,ROUTE,DOENT - Q -DOSE1 I $G(DS)=1 S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_" *Dosage:" D FMD G DU - S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Dosage:" D FMD -DU I 'PSONEW("DOSE ORDERED",I),$P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Oth. Lang. Dosage: "_$G(PSONEW("ODOSE",I)) - I PSONEW("DOSE ORDERED",I),$G(PSONEW("VERB",I))]"" D - .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Verb: "_$G(PSONEW("VERB",I)) - .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Dispense Units: "_$S($E(PSONEW("DOSE ORDERED",I),1)=".":"0",1:"")_PSONEW("DOSE ORDERED",I) - I PSONEW("NOUN",I) S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Noun: "_PSONEW("NOUN",I) - S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Route: "_$G(ROUTE) - S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Schedule: "_PSONEW("SCHEDULE",I) - I $P(DOSE,"^",2)]"" D - .S DUR=$S($E($P(DOSE,"^",2),1)'?.N:$E($P(DOSE,"^",2),2,99)_$E($P(DOSE,"^",2),1),1:$P(DOSE,"^",2)) - .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Duration: "_DUR_" ("_$S($P(DOSE,"^",2)["M":"MINUTES",$P(DOSE,"^",2)["H":"HOURS",$P(DOSE,"^",2)["L":"MONTHS",$P(DOSE,"^",2)["W":"WEEKS",1:"DAYS")_")" - I $P(DOSE,"^",6)]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Conjunction: "_$S($P(DOSE,"^",6)="A":"AND",$P(DOSE,"^",6)="S":"THEN",$P(DOSE,"^",6)="X":"EXCEPT",1:"") - Q -DOSE2 ;displays pending order after edits - S DS=1 - F I=1:1:PSONEW("ENT") Q:'I D D DOSE3 K COJ - .S:$G(PSONEW("UNITS",I))]"" UNITS=$P(^PS(50.607,PSONEW("UNITS",I),0),"^") S:$G(PSONEW("ROUTE",I))]"" ROUTE=$P(^PS(51.2,PSONEW("ROUTE",I),0),"^") - .S DUR=$G(PSONEW("DURATION",I)) S:$G(PSONEW("CONJUNCTION",I))]"" COJ=PSONEW("CONJUNCTION",I) - .S NOUN=PSONEW("NOUN",I),VERB=$G(PSONEW("VERB",I)) - .I 'PSONEW("DOSE ORDERED",I),$P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Oth. Lang. Dosage: "_$G(PSONEW("ODOSE",I)) - .I '$G(PSONEW("DOSE ORDERED",I)),$G(PSONEW("VERB",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Verb: "_$G(PSONEW("VERB",I)) - .S:$G(DS) IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (3)" - K I,UNITS,ROUTE,DUR,COJ,VERB,NOUN - Q -DOSE3 I $G(DS)=1 S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_" *Dosage:" D FMD G DO - S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Dosage:" D FMD -DO I 'PSONEW("DOSE ORDERED",I),$P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Oth. Lang. Dosage: "_$G(PSONEW("ODOSE",I)) - I $G(PSONEW("DOSE ORDERED",I)),$G(PSONEW("VERB",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Verb: "_$G(PSONEW("VERB",I)) - I $G(PSONEW("DOSE ORDERED",I)) S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Dispense Units: "_$S($E(PSONEW("DOSE ORDERED",I),1)=".":"0",1:"")_PSONEW("DOSE ORDERED",I) - I $G(PSONEW("DOSE ORDERED",I)) S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" NOUN: "_PSONEW("NOUN",I) - S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Route: "_$G(ROUTE) - S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Schedule: "_PSONEW("SCHEDULE",I) - I $G(DUR)]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Duration: "_DUR_" ("_$S(DUR["M":"MINUTES",DUR["H":"HOURS",DUR["L":"MONTHS",DUR["W":"WEEKS",1:"DAYS")_")" - I $G(COJ)]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Conjunction: "_$S(COJ="A":"AND",COJ="T":"THEN",COJ="X":"EXCEPT",1:"") - Q -FMD Q:$G(PSONEW("DOSE",II))']"" S MIG=PSONEW("DOSE",II) - I $E(MIG,1)=".",$G(PSONEW("DOSE ORDERED",II)) S MIG="0"_MIG - F SG=1:1:$L(MIG," ") S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(MIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " S ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(MIG," ",SG) - I $G(UNITS)]"" S:$L(^TMP("PSOPO",$J,IEN,0)_" ("_UNITS_")")>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " S ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" ("_UNITS_")" - K DS,MIG,SG - I '$G(PSONEW("DOSE ORDERED",II)),$P($G(^PS(55,PSODFN,"LAN")),"^") D LAN^PSOORED5 - Q -SQR ; - D SQR^PSOORFIN - Q -SQN ; - K MAXRF,PSOSIG,MPSDY,PSOMAX,STA,PSORX0,ORCHK,ORDRG - I $G(PSOQUIT) S PSOQQ=1 K PSOQUIT - Q +PSOORFI3 ;BIR/RTR-finish CPRS orders by Clinic ;5/14/07 10:07 + ;;7.0;OUTPATIENT PHARMACY;**15,27,32,46,84,99,130,117,139,172,208**;DEC 1997;Build 39 + ; Modified from FOIA VISTA, + ; GPL Copyright (C) 2007 WorldVistA + ;PPPPDA1-1374,SC(-2675,40.8-728,51.2-2226,50.607-2221,55-2228,PSSLOCK-2789,DPT-10035,ORX2-867 + ; + K ^TMP($J,"PSOCL"),^TMP($J,"PSOCLX"),PSOCLIN,PSOCLINF,PSOXINST + N PSOCFLAG,PSONPTRX,PSOINPTR,PSCLP,PSOCLINS,PSOSTC,PSOLGD,PSODIEN,PSOCTMP + K DIR S DIR(0)="SMB^C:CLINIC;S:SORT GROUP;E:EXIT",DIR("A")="Select By",DIR("B")="Clinic",DIR("?",1)="Enter 'C' to process orders for one individual Clinic," + S DIR("?",2)=" 'S' to process orders for all Clinics associated with a Sort Group,",DIR("?",3)=" '^' or 'E' to exit" S DIR("?")=" " + W ! D ^DIR K DIR I $D(DTOUT)!($D(DUOUT))!(Y="E") W ! G EXIT + I Y="S" G SORT +CLIN W ! K DIC S DIC="^SC(",DIC(0)="QEAMZ",DIC("A")="Select CLINIC: " D ^DIC K DIC I Y<1!($D(DTOUT))!($D(DUOUT)) G EXIT + S PSOCLIN=+Y,PSOCLINF=1 D CHECK I $G(PSOCFLAG) D INSTNM^PSOORFI2 W !!,"You are signed in under the "_$G(PSODINST)_" CPRS Ordering",!,"Institution, which does not match the Institution for this Clinic!",! K PSODINST G CLIN + S ^TMP($J,"PSOCL",PSOCLIN)=PSOCLIN K PSOCLIN G START +SORT W ! K DIC S DIC="^PS(59.8,",DIC(0)="QEAMZ",DIC("A")="Select CLINIC SORT GROUP: " D ^DIC K DIC I Y<1!($D(DTOUT))!($D(DUOUT)) G EXIT + S PSOCLINS=+Y + K ^TMP($J,"PSOCL"),^TMP($J,"PSOCLX") F PSCLP=0:0 S PSCLP=$O(^PS(59.8,PSOCLINS,1,PSCLP)) Q:'PSCLP S PSOSTC=+$P($G(^PS(59.8,PSOCLINS,1,PSCLP,0)),"^") S:$G(PSOSTC)&($D(^SC(PSOSTC,0))) ^TMP($J,"PSOCL",PSOSTC)=PSOSTC + I '$O(^TMP($J,"PSOCL",0)) W !!,"There are no Clinics associated with this Sort Group!",! K ^TMP($J,"PSOCL") G SORT + F PSCLP=0:0 S PSCLP=$O(^TMP($J,"PSOCL",PSCLP)) Q:'PSCLP S PSOCLIN=PSCLP D CHECK I $G(PSOCFLAG) S ^TMP($J,"PSOCLX",PSCLP)=PSCLP K ^TMP($J,"PSOCL",PSCLP) + I $O(^TMP($J,"PSOCLX",0)) H 1 W @IOF W !,"Orders for these Clinics in the Sort Group will not be displayed for Finishing",!,"because the CPRS Ordering Institution does not match the Institution that is",!,"associated with the Clinic:",! D + .F PSCLP=0:0 S PSCLP=$O(^TMP($J,"PSOCLX",PSCLP)) Q:'PSCLP D:($Y+4)>IOSL W !,$P($G(^SC(PSCLP,0)),"^") + ..W ! K DIR S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR K DIR W @IOF + I $O(^TMP($J,"PSOCLX",0)) D EOP + K ^TMP($J,"PSOCLX") I '$O(^TMP($J,"PSOCL",0)) W !!,"There are no Clinics that have a matching Institution!",! D EOP G SORT + ; + S PSOCLINF=2 +START K MEDP,MEDA,PSOQUIT,POERR("QFLG"),POERR("DFLG"),DIR + G:'$O(^TMP($J,"PSOCL",0)) EXIT + S PATA=0 F PSOCLIN=0:0 S PSOCLIN=$O(^TMP($J,"PSOCL",PSOCLIN)) Q:'PSOCLIN!($G(POERR("QFLG"))) F PSOLGD=0:0 S PSOLGD=$O(^PS(52.41,"ACL",PSOCLIN,PSOLGD)) Q:'PSOLGD!($G(POERR("QFLG"))) D + .F PSODIEN=0:0 S PSODIEN=$O(^PS(52.41,"ACL",PSOCLIN,PSOLGD,PSODIEN)) Q:'PSODIEN!($G(POERR("QFLG"))) D + ..I $P($G(^PS(52.41,PSODIEN,0)),"^",3)'="NW",$P($G(^(0)),"^",3)'="RNW",$P($G(^(0)),"^",3)'="RF" Q + ..I $G(PSOPINST)'=$P($G(^PS(52.41,PSODIEN,"INI")),"^") Q + ..Q:$G(PAT($P(^PS(52.41,PSODIEN,0),"^",2)))=$P(^PS(52.41,PSODIEN,0),"^",2) S PAT=$P(^PS(52.41,PSODIEN,0),"^",2) + ..I PAT'=PATA,$O(PSORX("PSOL",0))!($D(RXRS)) D LBL^PSOORFIN + ..D LK^PSOORFIN I $G(POERR("QFLG")) K POERR("QFLG") S PSOLK=1,PAT(PAT)=PAT Q + ..I $$CHK^PSODPT(PAT_"^"_$P($G(^DPT(PAT,0)),"^"),1,1)<0 S PSOLK=1,PAT(PAT)=PAT S X=PAT D ULP^PSOORFIN Q + ..S (PSODFN,Y)=PAT_"^"_$P($G(^DPT(+$G(PAT),0)),"^"),PATA=PAT + ..D:'$G(MEDA) PROFILE^PSOORFI2 S Y=PSODFN I $G(MEDP) K PSOFIN S POERR("QFLG")=0 S PSONOLCK=1,PSOPTLOK=PAT D OERR^PSORX1 S PSOFIN=1 D QU^PSOORFIN S X=PSOPTLOK D KLLP^PSOORFIN,ULP^PSOORFIN,KLL^PSOORFIN Q + ..D SDFN^PSOORFIN D POST^PSOORFI1 I $G(PSOQFLG)!($G(PSOQUIT)) S:$G(PSOQUIT) POERR("QFLG")=1 S:$G(PSOQFLG) PAT(PAT)=PAT S X=PAT D ULP^PSOORFIN K PSOQFLG Q + ..S PAT(PAT)=PAT + ..F ORD=0:0 S ORD=$O(^PS(52.41,"AOR",PAT,PSOPINST,ORD)) Q:'ORD!($G(POERR("QFLG"))) D + ...S PSODFN=PAT D NOW^%DTC S TM=$E(%,1,12),TM1=$P(TM,".",2),X="PPPPDA1" X ^%ZOSF("TEST") S:$T X=$$PDA^PPPPDA1(PSODFN) + ...D LK1^PSOORFIN,ORD^PSOORFIN S X=PAT D ULP^PSOORFIN + I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL^PSOORFIN + ; +EXIT K ^TMP($J,"PSOCL"),^TMP($J,"PSOCLX"),PSOCLIN,PSOCLINF,PSOXINST G EX^PSOORFIN + Q +CHECK ; check Institution + K PSOXINST,PSOCFLAG + I $P($G(^SC(PSOCLIN,0)),"^",4),$P($G(^(0)),"^",4)'=$G(PSOPINST) S PSOCFLAG=1 Q + I $P($G(^SC(PSOCLIN,0)),"^",4) Q + S PSONPTRX=$P($G(^SC(PSOCLIN,0)),"^",15) + I '$G(PSONPTRX) S PSONPTRX=$O(^DG(40.8,0)) + I '$G(DT) S DT=$$DT^XLFDT + S PSOINPTR=+$$SITE^VASITE(DT,PSONPTRX) I PSOINPTR'=$G(PSOPINST) S PSOCFLAG=1 + Q +EOP W ! K DIR S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR K DIR + Q +L1 ;Lock single order + I '$G(ORD) Q + K PSOMSG D PSOL^PSSLOCK(+ORD_"S") I '$G(PSOMSG),'$D(ZTSK) W !!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"This Order is being edited by another person."),! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR + Q +UL1 ;Unlock single order + I '$G(ORD) Q + I '$D(^PS(52.41,ORD,0)) D Q + . D UNLK1^ORX2(+$G(OR0)) + . Q + D PSOUL^PSSLOCK(+ORD_"S") + Q +DOSE ;pending orders + K DOENT S DS=1 + F I=0:0 S I=$O(^PS(52.41,ORD,1,I)) Q:'I S DOSE=$G(^PS(52.41,ORD,1,I,1)),DOSE1=$G(^(2)) D D DOSE1 + .S PSONEW("DOSE",I)=$P(DOSE1,"^"),PSONEW("DOSE ORDERED",I)=$P(DOSE1,"^",2),PSONEW("UNITS",I)=$P(DOSE,"^",9),PSONEW("NOUN",I)=$P(DOSE,"^",5) + .S:$P(DOSE,"^",9) UNITS=$P(^PS(50.607,$P(DOSE,"^",9),0),"^") + .S PSONEW("VERB",I)=$P(DOSE,"^",10),PSONEW("ROUTE",I)=$P(DOSE,"^",8) + .S:$P(DOSE,"^",8) ROUTE=$P(^PS(51.2,$P(DOSE,"^",8),0),"^") + .S PSONEW("SCHEDULE",I)=$P(DOSE,"^"),PSONEW("DURATION",I)=$P(DOSE,"^",2) + .S DOENT=$G(DOENT)+1 S PSONEW("CONJUNCTION",I)=$S($P(DOSE,"^",6)="A":"AND",$P(DOSE,"^",6)="S":"THEN",$P(DOSE,"^",6)="X":"EXCEPT",1:"") + .I 'PSONEW("DOSE ORDERED",I),$G(PSONEW("VERB",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Verb: "_$G(PSONEW("VERB",I)) + .S:$G(DS) IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (3)" + S PSONEW("ENT")=DOENT K DOSE,DOSE1,I,UNITS,ROUTE,DOENT + Q +DOSE1 I $G(DS)=1 S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_" *Dosage:" D FMD G DU + S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Dosage:" D FMD +DU I 'PSONEW("DOSE ORDERED",I),$P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Oth. Lang. Dosage: "_$G(PSONEW("ODOSE",I)) + I PSONEW("DOSE ORDERED",I),$G(PSONEW("VERB",I))]"" D + .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Verb: "_$G(PSONEW("VERB",I)) + .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Dispense Units: "_$S($E(PSONEW("DOSE ORDERED",I),1)=".":"0",1:"")_PSONEW("DOSE ORDERED",I) + I PSONEW("NOUN",I) S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Noun: "_PSONEW("NOUN",I) + S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Route: "_$G(ROUTE) + S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Schedule: "_PSONEW("SCHEDULE",I) + I $P(DOSE,"^",2)]"" D + .S DUR=$S($E($P(DOSE,"^",2),1)'?.N:$E($P(DOSE,"^",2),2,99)_$E($P(DOSE,"^",2),1),1:$P(DOSE,"^",2)) + .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Duration: "_DUR_" ("_$S($P(DOSE,"^",2)["M":"MINUTES",$P(DOSE,"^",2)["H":"HOURS",$P(DOSE,"^",2)["L":"MONTHS",$P(DOSE,"^",2)["W":"WEEKS",1:"DAYS")_")" + I $P(DOSE,"^",6)]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Conjunction: "_$S($P(DOSE,"^",6)="A":"AND",$P(DOSE,"^",6)="S":"THEN",$P(DOSE,"^",6)="X":"EXCEPT",1:"") + Q +DOSE2 ;displays pending order after edits + S DS=1 + F I=1:1:PSONEW("ENT") Q:'I D D DOSE3 K COJ + .S:$G(PSONEW("UNITS",I))]"" UNITS=$P(^PS(50.607,PSONEW("UNITS",I),0),"^") S:$G(PSONEW("ROUTE",I))]"" ROUTE=$P(^PS(51.2,PSONEW("ROUTE",I),0),"^") + .S DUR=$G(PSONEW("DURATION",I)) S:$G(PSONEW("CONJUNCTION",I))]"" COJ=PSONEW("CONJUNCTION",I) + .S NOUN=PSONEW("NOUN",I),VERB=$G(PSONEW("VERB",I)) + .I 'PSONEW("DOSE ORDERED",I),$P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Oth. Lang. Dosage: "_$G(PSONEW("ODOSE",I)) + .I '$G(PSONEW("DOSE ORDERED",I)),$G(PSONEW("VERB",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Verb: "_$G(PSONEW("VERB",I)) + .S:$G(DS) IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (3)" + K I,UNITS,ROUTE,DUR,COJ,VERB,NOUN + Q +DOSE3 I $G(DS)=1 S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_" *Dosage:" D FMD G DO + S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Dosage:" D FMD +DO I 'PSONEW("DOSE ORDERED",I),$P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Oth. Lang. Dosage: "_$G(PSONEW("ODOSE",I)) + I $G(PSONEW("DOSE ORDERED",I)),$G(PSONEW("VERB",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Verb: "_$G(PSONEW("VERB",I)) + I $G(PSONEW("DOSE ORDERED",I)) S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Dispense Units: "_$S($E(PSONEW("DOSE ORDERED",I),1)=".":"0",1:"")_PSONEW("DOSE ORDERED",I) + I $G(PSONEW("DOSE ORDERED",I)) S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" NOUN: "_PSONEW("NOUN",I) + S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Route: "_$G(ROUTE) + S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Schedule: "_PSONEW("SCHEDULE",I) + I $G(DUR)]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Duration: "_DUR_" ("_$S(DUR["M":"MINUTES",DUR["H":"HOURS",DUR["L":"MONTHS",DUR["W":"WEEKS",1:"DAYS")_")" + I $G(COJ)]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Conjunction: "_$S(COJ="A":"AND",COJ="T":"THEN",COJ="X":"EXCEPT",1:"") + Q +FMD Q:$G(PSONEW("DOSE",II))']"" S MIG=PSONEW("DOSE",II) + I $E(MIG,1)=".",$G(PSONEW("DOSE ORDERED",II)) S MIG="0"_MIG + F SG=1:1:$L(MIG," ") S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(MIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " S ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(MIG," ",SG) + I $G(UNITS)]"" S:$L(^TMP("PSOPO",$J,IEN,0)_" ("_UNITS_")")>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " S ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" ("_UNITS_")" + K DS,MIG,SG + I '$G(PSONEW("DOSE ORDERED",II)),$P($G(^PS(55,PSODFN,"LAN")),"^") D LAN^PSOORED5 + Q +SQR ; + K PSOORRNW,PSOOPT,PSOREEDT,PSOQUIT S POERR("DFLG")=0 + Q +SQN ; + K MAXRF,PSOSIG,MPSDY,PSOMAX,STA,PSORX0,ORCHK,ORDRG + I $G(PSOQUIT) S PSOQQ=1 K PSOQUIT + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFI4.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFI4.m index 7b85d64d..2c0dc7d0 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFI4.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFI4.m @@ -1,160 +1,138 @@ -PSOORFI4 ;BIR/SAB-CPRS order checks and display con't ;9:30 AM 31 Dec 2008 - ;;7.0;OUTPATIENT PHARMACY;**46,74,78,99,117,131,207,258,274,208**;DEC 1997;Build 41;WorldVistA 30-Jan-08 - ; - ;Modified from FOIA VISTA, - ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;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 Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - ;External reference to ^PS(51.2 supported by DBIA 2226 - ;External reference to ^PS(50.607 supported by DBIA 2221 - ;External reference ^PS(55 supported by DBIA 2228 - ;External reference to ^PS(50.7 is supported by DBIA 2223 - ;External reference to $$PDA^PPPPDA1 is supported by DBIA 1374 - ; -ORCHK D ORCHK^PSOORNE6 - Q -INST ;displays patient instructions - I $O(PSONEW("SIG",0)) G INST1 - S INST=0 F S INST=$O(^PS(52.41,ORD,"INS1",INST)) Q:'INST S (MIG,PSONEW("SIG",INST))=^PS(52.41,ORD,"INS1",INST,0) D - .F SG=1:1:$L(MIG," ") S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(MIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " S ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(MIG," ",SG) - I $P($G(^PS(55,PSODFN,"LAN")),"^"),$O(^PS(52.41,ORD,"INS1",0)) D - .I $G(^PS(50.7,PSODRUG("OI"),"INS1"))]"" S (X,PSONEW("SINS"))=^PS(50.7,PSODRUG("OI"),"INS1") D SSIG^PSOHELP - .I $G(SINS1)]"" S PSONEW("SINS")=$E(SINS1,2,250) - .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Other Pat Instruct: "_$S($G(PSONEW("SINS"))]"":PSONEW("SINS"),1:"") - K INST,TY,MIG,SG,SINS1 - Q -INST1 ; - S INS=0 F S INS=$O(PSONEW("SIG",INS)) Q:'INS S MIG=PSONEW("SIG",INS) D - .F SG=1:1:$L(MIG," ") S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(MIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " S ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(MIG," ",SG) - K INST,TY,MIG,SG - I $P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Other Pat Instruct: "_$S($G(PSONEW("SINS"))]"":PSONEW("SINS"),1:"") - Q -PROVCOM ; - I $G(PKI1)=1,'$G(PSORX("VERIFY")) D REA^PSOPKIV1 Q:$G(PSORX("DFLG")) - I $O(PRC(0)),'$G(PSOPRC) D D KV^PSOVER1 - .D EN^DDIOL("Provider Comments: ","","!") - .F I=0:0 S I=$O(PRC(I)) Q:'I D EN^DDIOL(PRC(I),"","!") - .;WVEHR ;begin p208 - .;D KV^PSOVER1 S DIR(0)="Y",DIR("A")="Copy Provider Comments into the Patient Instructions",DIR("B")="No" - .;D ^DIR Q:'Y!($D(DIRUT)) - .I $G(PSOAFYN)="Y" D KV^PSOVER1 ;vfam - .I $G(PSOAFYN)'="Y" D KV^PSOVER1 S DIR(0)="Y",DIR("A")="Copy Provider Comments into the Patient Instructions",DIR("B")="No" ;vfam - .I $G(PSOAFYN)'="Y" D ^DIR Q:'Y!($D(DIRUT)) ;vfam - .I $G(PSOAFYN)="Y" Q ;vfam Provider Comments NOT Copied Into Patient Instructions - .;WVEHR ;end p208 - .S PSOPRC=1,NI=0 F I=0:0 S I=$O(PSONEW("SIG",I)) Q:'I S NI=I - .S NC=0 F I=0:0 S I=$O(PRC(I)) Q:'I S NC=NC+1 - .I NI'>1,NC=1,($L($G(PSONEW("SIG",NI)))+$L(PRC(1)))'>250 D Q - ..S X=PRC(1) D SIGONE^PSOHELP - ..S PSONEW("SIG",1)=$G(PSONEW("SIG",NI))_INS1 K INS1,X - ..S:$E(PSONEW("SIG",1))=" " PSONEW("SIG",1)=$E(PSONEW("SIG",1),2,250) S PSONEW("INS")=PSONEW("SIG",1) D EN^PSOFSIG(.PSONEW,1) K NI,NC - .F I=0:0 S I=$O(PRC(I)) Q:'I S NI=NI+1,(PSONEW("INS",NI),X)=PRC(I) D SIGONE^PSOHELP S PSONEW("SIG",NI)=INS1 K INS1 - .I $E(PSONEW("SIG",1))=" " S PSONEW("SIG",1)=$E(PSONEW("SIG",1),2,250) - .D EN^PSOFSIG(.PSONEW,1) K NI,NC,X - Q -DOSE ;displays dosing info for pending orders. called from psoorfi1 - K II,UNITS S DS=1 - I '$O(^PS(52.41,ORD,1,0)) S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (3) *Dosage:" G DOSEX - F I=0:0 S I=$O(^PS(52.41,ORD,1,I)) Q:'I S DOSE=$G(^PS(52.41,ORD,1,I,1)),DOSE1=$G(^(2)) D D DOSE1 - .S II=$G(II)+1 K PSONEW("UNITS",II) - .S PSONEW("DOSE",II)=$P(DOSE1,"^"),PSONEW("DOSE ORDERED",II)=$P(DOSE1,"^",2),PSONEW("UNITS",II)=$P(DOSE,"^",9),PSONEW("NOUN",II)=$P(DOSE,"^",5) - .S:$P(DOSE,"^",9) UNITS=$P(^PS(50.607,$P(DOSE,"^",9),0),"^") - .S PSONEW("VERB",II)=$P(DOSE,"^",10),PSONEW("ROUTE",II)=$P(DOSE,"^",8) - .S:$P(DOSE,"^",8) ROUTE=$P(^PS(51.2,$P(DOSE,"^",8),0),"^") - .S PSONEW("SCHEDULE",II)=$P(DOSE,"^"),PSONEW("DURATION",II)=$P(DOSE,"^",2) - .S DOENT=$G(DOENT)+1 I $P(DOSE,"^",6)]"" S PSONEW("CONJUNCTION",II)=$S($P(DOSE,"^",6)="S":"T",$P(DOSE,"^",6)="X":"X",1:"A") - .I 'PSONEW("DOSE ORDERED",II),$G(PSONEW("VERB",II))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Verb: "_$G(PSONEW("VERB",II)) - .S:$G(DS) IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (3)" -DOSEX S PSONEW("ENT")=+$G(II) K DOSE,DOSE1,II,I,UNITS,ROUTE,DG - Q -DOSE1 I $G(DS)=1 S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_" *Dosage:" D FMD^PSOORFI3 G DU - S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Dosage:" D FMD^PSOORFI3 -DU I 'PSONEW("DOSE ORDERED",I),$P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Oth. Lang. Dosage: "_$G(PSONEW("ODOSE",I)) - I PSONEW("DOSE ORDERED",II),$G(PSONEW("VERB",II))]"" D - .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Verb: "_$G(PSONEW("VERB",II)) - .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Dispense Units: "_$S($E(PSONEW("DOSE ORDERED",II),1)=".":"0",1:"")_PSONEW("DOSE ORDERED",II) - I PSONEW("NOUN",II)]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Noun: "_PSONEW("NOUN",II) - I $G(ROUTE)]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Route: "_$G(ROUTE) - S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Schedule: "_PSONEW("SCHEDULE",II) - I $G(PSONEW("DURATION",II))]"" D - .S PSONEW("DURATION",II)=$S($E(PSONEW("DURATION",II),1)'?.N:$E(PSONEW("DURATION",II),2,99)_$E(PSONEW("DURATION",II),1),1:PSONEW("DURATION",II)) - .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Duration: "_PSONEW("DURATION",II)_" ("_$S(PSONEW("DURATION",II)["M":"MINUTES",PSONEW("DURATION",II)["H":"HOURS",PSONEW("DURATION",II)["L":"MONTHS",PSONEW("DURATION",II)["W":"WEEKS",1:"DAYS")_")" - I $G(PSONEW("CONJUNCTION",II))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Conjunction: "_$S(PSONEW("CONJUNCTION",II)="T":"THEN",PSONEW("CONJUNCTION",II)="X":"EXCEPT",1:"AND") - Q -DOSE2 ;displays pending order after edits. called from psoornew - I '$O(PSONEW("DOSE",0))!($O(PSONEW("DOSE",0))="") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (3) *Dosage:" Q - S DS=1 - F I=1:1:PSONEW("ENT") Q:'I D D DOSE3 K COJ - .S:$G(PSONEW("UNITS",I))]"" UNITS=$P(^PS(50.607,PSONEW("UNITS",I),0),"^") - .I $G(PSONEW("ROUTE",I))]"",$G(^PS(51.2,PSONEW("ROUTE",I),0))]"" S ROUTE=$P(^PS(51.2,PSONEW("ROUTE",I),0),"^") - .S DUR=$G(PSONEW("DURATION",I)) S:$G(PSONEW("CONJUNCTION",I))]"" COJ=PSONEW("CONJUNCTION",I) - .S NOUN=$G(PSONEW("NOUN",I)),VERB=$G(PSONEW("VERB",I)) - .I '$G(PSONEW("DOSE ORDERED",I)),$G(PSONEW("VERB",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Verb: "_$G(PSONEW("VERB",I)) - .S:$G(DS) IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (3)" - K I,UNITS,ROUTE,DUR,COJ,VERB,NOUN,DG - Q -DOSE3 I $G(DS)=1 S II=I,^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_" *Dosage:" D FMD^PSOORFI3 G DO - S II=I,IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Dosage:" D FMD^PSOORFI3 -DO I '$G(PSONEW("DOSE ORDERED",I)),$P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Oth. Lang. Dosage: "_$G(PSONEW("ODOSE",I)) - I $G(PSONEW("DOSE ORDERED",I)),$G(PSONEW("VERB",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Verb: "_$G(PSONEW("VERB",I)) - I $G(PSONEW("DOSE ORDERED",I)) S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Dispense Units: "_$S($E(PSONEW("DOSE ORDERED",I),1)=".":"0",1:"")_PSONEW("DOSE ORDERED",I) - I $G(PSONEW("NOUN",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" NOUN: "_PSONEW("NOUN",I) - I $G(ROUTE)]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Route: "_$G(ROUTE) - S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Schedule: "_PSONEW("SCHEDULE",I) - I $G(PSONEW("DURATION",I))]"" D - .S PSONEW("DURATION",I)=$S($E(PSONEW("DURATION",I),1)'?.N:$E(PSONEW("DURATION",I),2,99)_$E(PSONEW("DURATION",I),1),1:PSONEW("DURATION",I)) - .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Duration: "_PSONEW("DURATION",I)_" ("_$S(PSONEW("DURATION",I)["M":"MINUTES",PSONEW("DURATION",I)["H":"HOURS",PSONEW("DURATION",I)["L":"MONTHS",PSONEW("DURATION",I)["W":"WEEKS",1:"DAYS")_")" - I $G(PSONEW("CONJUNCTION",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Conjunction: "_$S(PSONEW("CONJUNCTION",I)="T":"THEN",PSONEW("CONJUNCTION",I)="X":"EXCEPT",1:"AND") - Q -OBX ;formats obx section - N COM,II - D:$G(PKI1) L1^PSOPKIV1 - I $O(^PS(52.41,ORD,"OBX",0)) S (T,IEN)=0,IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="Order Checks:" F S T=$O(^PS(52.41,ORD,"OBX",T)) Q:'T D S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" " - .S COM=$G(^PS(52.41,ORD,"OBX",T,0)) - .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" " F II=1:1:$L(COM," ") D - ..I $L(^TMP("PSOPO",$J,IEN,0)_" "_$P(COM," ",II))>80 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" " - ..S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_" "_$P(COM," ",II) - .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Overriding Provider: "_$G(^PS(52.41,ORD,"OBX",T,1)) - .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Overriding Reason:" - .F T1=0:0 S T1=$O(^PS(52.41,ORD,"OBX",T,2,T1)) Q:'T1 D - ..S MIG=^PS(52.41,ORD,"OBX",T,2,T1,0) - ..F SG=1:1:$L(MIG," ") S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(MIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",23)=" " S ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(MIG," ",SG) - Q -PP S PSODFN=PAT D NOW^%DTC S TM=$E(%,1,12),TM1=$P(TM,".",2),X="PPPPDA1" - X ^%ZOSF("TEST") S:$T X=$$PDA^PPPPDA1(PSODFN) - Q -SPL K PSOFIN S POERR("QFLG")=0 S PSONOLCK=1,PSOPTLOK=PAT - Q -CLQTY ; - K PSONEW("QTY") - D QTY^PSOSIG(.PSONEW) - S:'$G(PSONEW("QTY")) PSONEW("QTY")=0 - Q -PQTY ; - S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_", days supply of "_+$P(OR0,"^",22)_" and a qty of "_+$P(OR0,"^",10) - Q -REF Q:$G(PSODRUG("DEA"))']"" - S CS=0 F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)="" I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S CS=1 - S PTRF=PSONEW("# OF REFILLS"),PSDAYS=PSONEW("DAYS SUPPLY") - I CS D - .S PSOX1=$S(PTRF>5:5,1:PTRF),PSOX=$S(PSOX1=5:5,1:PSOX1) - .S PSOX=$S('PSOX:0,PSDAYS=90:1,1:PSOX),PSDY1=$S(PSDAYS<60:5,PSDAYS'<60&(PSDAYS'>89):2,PSDAYS=90:1,1:0) - E D - .S PSOX1=PTRF,PSOX=$S(PSOX1=11:11,1:PSOX1),PSOX=$S('PSOX:0,PSDAYS=90:3,1:PSOX) - .S PSDY1=$S(PSDAYS<60:11,PSDAYS'<60&(PSDAYS'>89):5,PSDAYS=90:3,1:0) - S PSONEW("# OF REFILLS")=$S(PSONEW("# OF REFILLS")>PSDY1:PSDY1,1:PSONEW("# OF REFILLS")) - Q +PSOORFI4 ;BIR/SAB-CPRS order checks and display con't ;1/27/07 13:26 + ;;7.0;OUTPATIENT PHARMACY;**46,74,78,99,117,131,207,258,208**;DEC 1997;Build 39 + ; Modified from FOIA VISTA, + ; GPL Copyright (C) 2007 WorldVistA + ;External reference to ^PS(51.2 supported by DBIA 2226 + ;External reference to ^PS(50.607 supported by DBIA 2221 + ;External reference ^PS(55 supported by DBIA 2228 + ;External reference to ^PS(50.7 is supported by DBIA 2223 + ;External reference to $$PDA^PPPPDA1 is supported by DBIA 1374 + ; +ORCHK D ORCHK^PSOORNE6 + Q +INST ;displays patient instructions + I $O(PSONEW("SIG",0)) G INST1 + S INST=0 F S INST=$O(^PS(52.41,ORD,"INS1",INST)) Q:'INST S (MIG,PSONEW("SIG",INST))=^PS(52.41,ORD,"INS1",INST,0) D + .F SG=1:1:$L(MIG," ") S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(MIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " S ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(MIG," ",SG) + I $P($G(^PS(55,PSODFN,"LAN")),"^"),$O(^PS(52.41,ORD,"INS1",0)) D + .I $G(^PS(50.7,PSODRUG("OI"),"INS1"))]"" S (X,PSONEW("SINS"))=^PS(50.7,PSODRUG("OI"),"INS1") D SSIG^PSOHELP + .I $G(SINS1)]"" S PSONEW("SINS")=$E(SINS1,2,250) + .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Other Pat Instruct: "_$S($G(PSONEW("SINS"))]"":PSONEW("SINS"),1:"") + K INST,TY,MIG,SG,SINS1 + Q +INST1 ; + S INS=0 F S INS=$O(PSONEW("SIG",INS)) Q:'INS S MIG=PSONEW("SIG",INS) D + .F SG=1:1:$L(MIG," ") S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(MIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " S ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(MIG," ",SG) + K INST,TY,MIG,SG + I $P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Other Pat Instruct: "_$S($G(PSONEW("SINS"))]"":PSONEW("SINS"),1:"") + Q +PROVCOM ; + I $G(PKI1)=1,'$G(PSORX("VERIFY")) D REA^PSOPKIV1 Q:$G(PSORX("DFLG")) + I $O(PRC(0)),'$G(PSOPRC) D D KV^PSOVER1 + .D EN^DDIOL("Provider Comments: ","","!") + .F I=0:0 S I=$O(PRC(I)) Q:'I D EN^DDIOL(PRC(I),"","!") + .I $G(PSOAFYN)="Y" D KV^PSOVER1 ;vfam + .I $G(PSOAFYN)'="Y" D KV^PSOVER1 S DIR(0)="Y",DIR("A")="Copy Provider Comments into the Patient Instructions",DIR("B")="No" ;vfam + .I $G(PSOAFYN)'="Y" D ^DIR Q:'Y!($D(DIRUT)) ;vfam + .I $G(PSOAFYN)="Y" Q ;vfam Provider Comments NOT Copied Into Patient Instructions + .S PSOPRC=1,NI=0 F I=0:0 S I=$O(PSONEW("SIG",I)) Q:'I S NI=I + .S NC=0 F I=0:0 S I=$O(PRC(I)) Q:'I S NC=NC+1 + .I NI'>1,NC=1,($L($G(PSONEW("SIG",NI)))+$L(PRC(1)))'>250 D Q + ..S PSONEW("SIG",1)=$G(PSONEW("SIG",NI))_" "_PRC(1) + ..S:$E(PSONEW("SIG",1))=" " PSONEW("SIG",1)=$E(PSONEW("SIG",1),2,250) S PSONEW("INS")=PSONEW("SIG",1) D EN^PSOFSIG(.PSONEW,1) K NI,NC + .F I=0:0 S I=$O(PRC(I)) Q:'I S NI=NI+1,(PSONEW("SIG",NI),PSONEW("INS",NI))=PRC(I) + .I $E(PSONEW("SIG",1))=" " S PSONEW("SIG",1)=$E(PSONEW("SIG",1),2,250) + .D EN^PSOFSIG(.PSONEW,1) K NI,NC + Q +DOSE ;displays dosing info for pending orders. called from psoorfi1 + K II,UNITS S DS=1 + I '$O(^PS(52.41,ORD,1,0)) S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (3) *Dosage:" G DOSEX + F I=0:0 S I=$O(^PS(52.41,ORD,1,I)) Q:'I S DOSE=$G(^PS(52.41,ORD,1,I,1)),DOSE1=$G(^(2)) D D DOSE1 + .S II=$G(II)+1 K PSONEW("UNITS",II) + .S PSONEW("DOSE",II)=$P(DOSE1,"^"),PSONEW("DOSE ORDERED",II)=$P(DOSE1,"^",2),PSONEW("UNITS",II)=$P(DOSE,"^",9),PSONEW("NOUN",II)=$P(DOSE,"^",5) + .S:$P(DOSE,"^",9) UNITS=$P(^PS(50.607,$P(DOSE,"^",9),0),"^") + .S PSONEW("VERB",II)=$P(DOSE,"^",10),PSONEW("ROUTE",II)=$P(DOSE,"^",8) + .S:$P(DOSE,"^",8) ROUTE=$P(^PS(51.2,$P(DOSE,"^",8),0),"^") + .S PSONEW("SCHEDULE",II)=$P(DOSE,"^"),PSONEW("DURATION",II)=$P(DOSE,"^",2) + .S DOENT=$G(DOENT)+1 I $P(DOSE,"^",6)]"" S PSONEW("CONJUNCTION",II)=$S($P(DOSE,"^",6)="S":"T",$P(DOSE,"^",6)="X":"X",1:"A") + .I 'PSONEW("DOSE ORDERED",II),$G(PSONEW("VERB",II))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Verb: "_$G(PSONEW("VERB",II)) + .S:$G(DS) IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (3)" +DOSEX S PSONEW("ENT")=+$G(II) K DOSE,DOSE1,II,I,UNITS,ROUTE,DG + Q +DOSE1 I $G(DS)=1 S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_" *Dosage:" D FMD^PSOORFI3 G DU + S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Dosage:" D FMD^PSOORFI3 +DU I 'PSONEW("DOSE ORDERED",I),$P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Oth. Lang. Dosage: "_$G(PSONEW("ODOSE",I)) + I PSONEW("DOSE ORDERED",II),$G(PSONEW("VERB",II))]"" D + .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Verb: "_$G(PSONEW("VERB",II)) + .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Dispense Units: "_$S($E(PSONEW("DOSE ORDERED",II),1)=".":"0",1:"")_PSONEW("DOSE ORDERED",II) + I PSONEW("NOUN",II)]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Noun: "_PSONEW("NOUN",II) + I $G(ROUTE)]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Route: "_$G(ROUTE) + S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Schedule: "_PSONEW("SCHEDULE",II) + I $G(PSONEW("DURATION",II))]"" D + .S PSONEW("DURATION",II)=$S($E(PSONEW("DURATION",II),1)'?.N:$E(PSONEW("DURATION",II),2,99)_$E(PSONEW("DURATION",II),1),1:PSONEW("DURATION",II)) + .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Duration: "_PSONEW("DURATION",II)_" ("_$S(PSONEW("DURATION",II)["M":"MINUTES",PSONEW("DURATION",II)["H":"HOURS",PSONEW("DURATION",II)["L":"MONTHS",PSONEW("DURATION",II)["W":"WEEKS",1:"DAYS")_")" + I $G(PSONEW("CONJUNCTION",II))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Conjunction: "_$S(PSONEW("CONJUNCTION",II)="T":"THEN",PSONEW("CONJUNCTION",II)="X":"EXCEPT",1:"AND") + Q +DOSE2 ;displays pending order after edits. called from psoornew + I '$O(PSONEW("DOSE",0))!($O(PSONEW("DOSE",0))="") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (3) *Dosage:" Q + S DS=1 + F I=1:1:PSONEW("ENT") Q:'I D D DOSE3 K COJ + .S:$G(PSONEW("UNITS",I))]"" UNITS=$P(^PS(50.607,PSONEW("UNITS",I),0),"^") + .I $G(PSONEW("ROUTE",I))]"",$G(^PS(51.2,PSONEW("ROUTE",I),0))]"" S ROUTE=$P(^PS(51.2,PSONEW("ROUTE",I),0),"^") + .S DUR=$G(PSONEW("DURATION",I)) S:$G(PSONEW("CONJUNCTION",I))]"" COJ=PSONEW("CONJUNCTION",I) + .S NOUN=$G(PSONEW("NOUN",I)),VERB=$G(PSONEW("VERB",I)) + .I '$G(PSONEW("DOSE ORDERED",I)),$G(PSONEW("VERB",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Verb: "_$G(PSONEW("VERB",I)) + .S:$G(DS) IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (3)" + K I,UNITS,ROUTE,DUR,COJ,VERB,NOUN,DG + Q +DOSE3 I $G(DS)=1 S II=I,^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_" *Dosage:" D FMD^PSOORFI3 G DO + S II=I,IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Dosage:" D FMD^PSOORFI3 +DO I '$G(PSONEW("DOSE ORDERED",I)),$P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Oth. Lang. Dosage: "_$G(PSONEW("ODOSE",I)) + I $G(PSONEW("DOSE ORDERED",I)),$G(PSONEW("VERB",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Verb: "_$G(PSONEW("VERB",I)) + I $G(PSONEW("DOSE ORDERED",I)) S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Dispense Units: "_$S($E(PSONEW("DOSE ORDERED",I),1)=".":"0",1:"")_PSONEW("DOSE ORDERED",I) + I $G(PSONEW("NOUN",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" NOUN: "_PSONEW("NOUN",I) + I $G(ROUTE)]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Route: "_$G(ROUTE) + S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Schedule: "_PSONEW("SCHEDULE",I) + I $G(PSONEW("DURATION",I))]"" D + .S PSONEW("DURATION",I)=$S($E(PSONEW("DURATION",I),1)'?.N:$E(PSONEW("DURATION",I),2,99)_$E(PSONEW("DURATION",I),1),1:PSONEW("DURATION",I)) + .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Duration: "_PSONEW("DURATION",I)_" ("_$S(PSONEW("DURATION",I)["M":"MINUTES",PSONEW("DURATION",I)["H":"HOURS",PSONEW("DURATION",I)["L":"MONTHS",PSONEW("DURATION",I)["W":"WEEKS",1:"DAYS")_")" + I $G(PSONEW("CONJUNCTION",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Conjunction: "_$S(PSONEW("CONJUNCTION",I)="T":"THEN",PSONEW("CONJUNCTION",I)="X":"EXCEPT",1:"AND") + Q +OBX ;formats obx section + N COM,II + D:$G(PKI1) L1^PSOPKIV1 + I $O(^PS(52.41,ORD,"OBX",0)) S (T,IEN)=0,IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="Order Checks:" F S T=$O(^PS(52.41,ORD,"OBX",T)) Q:'T D S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" " + .S COM=$G(^PS(52.41,ORD,"OBX",T,0)) + .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" " F II=1:1:$L(COM," ") D + ..I $L(^TMP("PSOPO",$J,IEN,0)_" "_$P(COM," ",II))>80 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" " + ..S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_" "_$P(COM," ",II) + .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Overriding Provider: "_$G(^PS(52.41,ORD,"OBX",T,1)) + .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Overriding Reason:" + .F T1=0:0 S T1=$O(^PS(52.41,ORD,"OBX",T,2,T1)) Q:'T1 D + ..S MIG=^PS(52.41,ORD,"OBX",T,2,T1,0) + ..F SG=1:1:$L(MIG," ") S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(MIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",23)=" " S ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(MIG," ",SG) + Q +PP S PSODFN=PAT D NOW^%DTC S TM=$E(%,1,12),TM1=$P(TM,".",2),X="PPPPDA1" + X ^%ZOSF("TEST") S:$T X=$$PDA^PPPPDA1(PSODFN) + Q +SPL K PSOFIN S POERR("QFLG")=0 S PSONOLCK=1,PSOPTLOK=PAT + Q +CLQTY ; + K PSONEW("QTY") + D QTY^PSOSIG(.PSONEW) + S:'$G(PSONEW("QTY")) PSONEW("QTY")=0 + Q +PQTY ; + S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_", days supply of "_+$P(OR0,"^",22)_" and a qty of "_+$P(OR0,"^",10) + Q +REF Q:$G(PSODRUG("DEA"))']"" + S CS=0 F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)="" I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S CS=1 + S PTRF=PSONEW("# OF REFILLS"),PSDAYS=PSONEW("DAYS SUPPLY") + I CS D + .S PSOX1=$S(PTRF>5:5,1:PTRF),PSOX=$S(PSOX1=5:5,1:PSOX1) + .S PSOX=$S('PSOX:0,PSDAYS=90:1,1:PSOX),PSDY1=$S(PSDAYS<60:5,PSDAYS'<60&(PSDAYS'>89):2,PSDAYS=90:1,1:0) + E D + .S PSOX1=PTRF,PSOX=$S(PSOX1=11:11,1:PSOX1),PSOX=$S('PSOX:0,PSDAYS=90:3,1:PSOX) + .S PSDY1=$S(PSDAYS<60:11,PSDAYS'<60&(PSDAYS'>89):5,PSDAYS=90:3,1:0) + S PSONEW("# OF REFILLS")=$S(PSONEW("# OF REFILLS")>PSDY1:PSDY1,1:PSONEW("# OF REFILLS")) + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFI5.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFI5.m index c8a9ef73..5655f906 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFI5.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFI5.m @@ -1,85 +1,38 @@ -PSOORFI5 ;BIR/SJA-finish cprs orders ;11/06/06 10:49am - ;;7.0;OUTPATIENT PHARMACY;**225**;DEC 1997;Build 29 - ;External references UL^PSSLOCK supported by DBIA 2789 - ;External reference to ^DPT supported by DBIA 10035 - ; -FLG W ! K MEDP,MEDA,POERR("DFLG"),DIR D KQ S PSOSORT="FLAGGED^FLAGGED" - S LG=0,PATA=0 F S LG=$O(^PS(52.41,"AD",LG)) Q:'LG!($G(POERR("QFLG"))) F PSOD=0:0 S PSOD=$O(^PS(52.41,"AD",LG,PSOPINST,PSOD)) Q:'PSOD!($G(POERR("QFLG"))) D - .Q:'$D(^PS(52.41,PSOD,0))!('$P($G(^PS(52.41,PSOD,0)),"^",23)) - .Q:$G(PAT($P(^PS(52.41,PSOD,0),"^",2)))=$P(^PS(52.41,PSOD,0),"^",2) S PAT=$P(^PS(52.41,PSOD,0),"^",2) - .I PAT'=PATA,$O(PSORX("PSOL",0))!($D(RXRS)) D LBL^PSOORFIN - .D LK I $G(POERR("QFLG")) K POERR("QFLG") S PSOLK=1,PAT(PAT)=PAT Q - .I $$CHK^PSODPT(PAT_"^"_$P($G(^DPT(PAT,0)),"^"),1,1)<0 S PSOLK=1,PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG,PSOQQ Q - .S (PSODFN,Y)=PAT_"^"_$P($G(^DPT(PAT,0)),"^"),PATA=PAT - .D:'$G(MEDA) PROFILE^PSOORFI2 S Y=PSODFN I $G(MEDP) D SPL D OERR^PSORX1 S PSOFIN=1 D QU S X=PSOPTLOK D KLLP,ULP,KLL Q - .D SDFN D POST^PSOORFI1 I $G(PSOQFLG)!($G(PSOQUIT)) S:$G(PSOQUIT) POERR("QFLG")=1 S:$G(PSOQFLG) PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG Q - .S PAT(PAT)=PAT - .F ORD=0:0 S ORD=$O(^PS(52.41,"AOR",PAT,PSOPINST,ORD)) Q:'ORD!($G(POERR("QFLG")))!($G(PSOQQ)) D - ..I $P($G(^PS(52.41,ORD,0)),"^",23) D PP,LK1,ORD^PSOORFIN - .S X=PAT D ULP K PSOQQ - I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL^PSOORFIN - I $G(PSOQUIT) K PSOQUIT D EX G ^PSOORFIN - G EX - ; -PRI ; Called from PSOORFIN due to it's routine size. - K DIR S PSOSORT="PRIORITY" - S DIR("A")="Select Priority",DIR(0)="SBM^S:STAT;E:EMERGENCY;R:ROUTINE",DIR("B")="ROUTINE" - D ^DIR G:$D(DIRUT) EX S PSOSORT=PSOSORT_"^"_Y,PSRT=Y - S LG=0,PATA=0 F S LG=$O(^PS(52.41,"AD",LG)) Q:'LG!($G(POERR("QFLG"))) F PSOD=0:0 S PSOD=$O(^PS(52.41,"AD",LG,PSOPINST,PSOD)) Q:'PSOD!($G(POERR("QFLG"))) D - .Q:$P($G(^PS(52.41,PSOD,0)),"^",23) - .Q:$G(PAT($P(^PS(52.41,PSOD,0),"^",2)))=$P(^PS(52.41,PSOD,0),"^",2) S PAT=$P(^PS(52.41,PSOD,0),"^",2) - .I PAT'=PATA,$O(PSORX("PSOL",0))!($D(RXRS)) D LBL^PSOORFIN - .I '$O(^PS(52.41,"AP",PAT,PSRT,0)) S PSOLK=1,PAT(PAT)=PAT Q - .D PRI^PSOORFI2 I $G(PSZFIN) S PSOLK=1,PAT(PAT)=PAT Q - .D LK I $G(POERR("QFLG")) K POERR("QFLG") S PSOLK=1,PAT(PAT)=PAT Q - .I $$CHK^PSODPT(PAT_"^"_$P($G(^DPT(PAT,0)),"^"),1,1)<0 S PSOLK=1,PAT(PAT)=PAT S X=PAT D ULP Q - .S (PSODFN,Y)=PAT_"^"_$P($G(^DPT(PAT,0)),"^"),PATA=PAT - .D:'$G(MEDA) PROFILE^PSOORFI2 S Y=PSODFN I $G(MEDP) D SPL D OERR^PSORX1 S PSOFIN=1 D QU S X=PSOPTLOK D KLLP,ULP,KLL Q - .D SDFN D POST^PSOORFI1 I $G(PSOQFLG)!($G(PSOQUIT)) S:$G(PSOQUIT) POERR("QFLG")=1 S:$G(PSOQFLG) PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG Q - .D PP S ORD=0 D @PSRT S PAT(PAT)=PAT - .S X=PAT D ULP - I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL^PSOORFIN - I $G(PSOQUIT) K PSOQUIT D EX G ^PSOORFIN -EX D EX^PSOORFI1 - Q -LK D LOCK^PSOORFI1 - Q -LK1 D LOCK1^PSOORFI1 Q -QU I $G(PSOQUIT) S POERR("QFLG")=1 K PSOQUIT - S:$G(PSOQFLG) PAT(PAT)=PAT - Q -ULP K PSORX("MAIL/WINDOW"),PSORX("METHOD OF PICK-UP") - D CLEAN^PSOVER1 - I '$G(X) Q - D UL^PSSLOCK(X) Q -KLL K PSOPTLOK - Q -KLLP K PSONOLCK - Q -SPL D SPL^PSOORFI4 - Q -SDFN S PSODFN=+$G(PSODFN) - Q -PP D PP^PSOORFI4 - Q -KQ K PSOQUIT,POERR("QFLG") - Q - ; -LMDISP(ORD) ; Backdoor ListManager Display of Flag/Unflag Informaiton - N FLAG - K FLAGLINE S ORD=+$G(ORD) I 'ORD Q - ; - I '$G(^PS(52.41,ORD,"FLG")) Q - ; S X=IORVON_"Flagged"_IORVOFF - D GETS^DIQ(52.41,ORD,"33;34;35;36;37;38","IE","FLAG") - S L1="Flagged by "_$E(FLAG(52.41,ORD_",",34,"E"),1,30)_" on "_$$FMTE^XLFDT(FLAG(52.41,ORD_",",33,"I"),2)_": " - S LEN=80-$L(L1),L1=L1_$E(FLAG(52.41,ORD_",",35,"E"),1,LEN),L2=$E(FLAG(52.41,ORD_",",35,"E"),LEN+1,999) - S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=L1,FLAGLINE(IEN)=7 - I L2'="" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=L2 - I FLAG(52.41,ORD_",",36,"I")'="" D - . S L1="Unflagged by "_$E(FLAG(52.41,ORD_",",37,"E"),1,30)_" on "_$$FMTE^XLFDT(FLAG(52.41,ORD_",",36,"I"),2)_": " - . S LEN=80-$L(L1),L1=L1_$E(FLAG(52.41,ORD_",",38,"E"),1,LEN),L2=$E(FLAG(52.41,ORD_",",38,"E"),LEN+1,999) - . S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=L1,FLAGLINE(IEN)=9 - . I L2'="" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=L2 - S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" " - Q +PSOORFI5 ;VOE/mpa -finish cprs orders ; 1/15/07 5:40pm + ;;7.0;OUTPATIENT PHARMACY;**208**;DEC 2006;Build 39 + ; 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 + ;'Modified' MAS Patient Look-up Check Cross-References June 1987 + ;Split from PSOORFIN +SUCC ; + D UL1^PSOORFI3,FULL^VALM1 + D:$P($G(^PS(52.41,+$G(ORD),0)),"^",3)'="NW"&($P($G(^(0)),"^",3)'="RNW")&($P($G(^(0)),"^",3)'="HD")&($P($G(^(0)),"^",3)'="RF") + .K PSOSD("PENDING",$S('$G(OID):$P(^PS(50.7,$P(OR0,"^",8),0),"^")_" "_$P(^PS(50.606,$P(^PS(50.7,$P(OR0,"^",8),0),"^",2),0),"^"),1:$P(^PSDRUG($P(OR0,"^",9),0),"^"))) + S:$G(POERR("DFLG")) POERR("QFLG")=1 K POERR("DFLG"),PSONEW,ACP,OR0,DRET,SIG,OID,OI,PSORX("SC"),PSORX("CLINIC"),PSODRUG + Q +LBL ;Begin DAOU + S PSOFROM="NEW" D ^PSORXL + K PSORX("PSOL"),PPL,RXRS + ;End 5/4/2005 + Q +CHK ; + D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) W !,$C(7),"Outpatient Division MUST be selected!",! G EX^PSOORFIN + D INST1^PSOORFI2 + S PSZCNT=0 F PSZZI=0:0 S PSZZI=$O(^PS(59,PSZZI)) Q:'PSZZI S PSZCNT=PSZCNT+1 + S TC=0 F TO=0:0 S TO=$O(^PS(52.41,"AOR",TO)) Q:'TO F TZ=0:0 S TZ=$O(^PS(52.41,"AOR",TO,TZ)) Q:'TZ F PSTZ=0:0 S PSTZ=$O(^PS(52.41,"AOR",TO,TZ,PSTZ)) Q:'PSTZ S TC=TC+1 + W !!?10,$C(7),"Orders to be completed"_$S(PSZCNT=1:": ",1:" for all divisions: ")_TC,! Q:'TC + D SUMM^PSOORNE1 K PSZZI,PSZCNT,PSTZ + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFIN.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFIN.m index 15438139..911c5e4d 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFIN.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFIN.m @@ -1,140 +1,160 @@ -PSOORFIN ;BIR/SAB-finish cprs orders ;12/21/04 3:24pm - ;;7.0;OUTPATIENT PHARMACY;**7,15,27,32,44,46,84,106,111,117,131,146,139,195,225**;DEC 1997;Build 29 - ;PSSLOCK-2789,PSDRUG-221,50.7-2223,55-2228,50.606-2174 - D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) D MSG^PSODPT G EX - D INST^PSOORFI2 I $G(PSOIQUIT) K PSOIQUIT G EX - I $P($G(PSOPAR),"^",2),'$D(^XUSEC("PSORPH",DUZ)) S PSORX("VERIFY")=1 - S (PSOFIN,POERR)=1 - K PSOBCK,MEDA,MEDP,SRT,DIR D KQ - S DIR("?")="^D ST^PSOORFI1",DIR("A")="Select By",DIR("B")="PATIENT",DIR(0)="SMB^PA:PATIENT;RT:ROUTE;PR:PRIORITY;CL:CLINIC;FL:FLAG;E:EXIT" - D ^DIR I $D(DIRUT)!(Y="E") G EX - G:Y="PA" PAT G:Y="PR" PRI^PSOORFI5 G:Y="CL" ^PSOORFI3 G:Y="FL" FLG^PSOORFI5 - K DIR S PSOSORT="ROUTE" - S DIR("?")="^D RT^PSOORFI1",DIR("A")="Route",DIR(0)="SBM^W:WINDOW;M:MAIL;C:CLINIC;E:EXIT",DIR("B")="WINDOW" - D ^DIR G:$D(DIRUT)!(Y="E") EX S PSOSORT=PSOSORT_"^"_Y,PSRT=Y - S LG=0,PATA=0 F S LG=$O(^PS(52.41,"AD",LG)) Q:'LG!($G(POERR("QFLG"))) F PSOD=0:0 S PSOD=$O(^PS(52.41,"AD",LG,PSOPINST,PSOD)) Q:'PSOD!($G(POERR("QFLG"))) D - .Q:$P($G(^PS(52.41,PSOD,0)),"^",23) - .Q:$G(PAT($P(^PS(52.41,PSOD,0),"^",2)))=$P(^PS(52.41,PSOD,0),"^",2) S PAT=$P(^PS(52.41,PSOD,0),"^",2) - .I PAT'=PATA,$O(PSORX("PSOL",0))!($D(RXRS)) D LBL - .I '$O(^PS(52.41,"AC",PAT,PSRT,0)) S PSOLK=1,PAT(PAT)=PAT Q - .D RTE^PSOORFI2 I $G(PSZFIN) S PSOLK=1,PAT(PAT)=PAT Q - .D LK I $G(POERR("QFLG")) K POERR("QFLG") S PSOLK=1,PAT(PAT)=PAT Q - .I $$CHK^PSODPT(PAT_"^"_$P($G(^DPT(PAT,0)),"^"),1,1)<0 S PSOLK=1,PAT(PAT)=PAT S X=PAT D ULP Q - .S (PSODFN,Y)=PAT_"^"_$P($G(^DPT(PAT,0)),"^"),PATA=PAT - .D:'$G(MEDA) PROFILE^PSOORFI2 S Y=PSODFN I $G(MEDP) D SPL D OERR^PSORX1 S PSOFIN=1 D QU S X=PSOPTLOK D KLLP,ULP,KLL Q - .D SDFN D POST^PSOORFI1 I $G(PSOQFLG)!($G(PSOQUIT)) S:$G(PSOQUIT) POERR("QFLG")=1 S:$G(PSOQFLG) PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG Q - .D PP S ORD=0 D @PSRT S PAT(PAT)=PAT - .S X=PAT D ULP - K POERR("QFLG"),PSOQFLG,PSOPTPST,MAIL,WIN,CLI I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL - I $G(PSOQUIT) K PSOQUIT D EX G PSOORFIN -EX D EX^PSOORFI1 - Q -W D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"W",ORD)) Q:'ORD!($G(POERR("QFLG"))) I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LK1,ORD S MAIL=1 - Q:$G(POERR("QFLG")) I $G(MAIL) S ORD=0 D - .D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"M",ORD)) Q:'ORD!($G(POERR("QFLG"))) D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE") LK1,ORD - .Q:$G(POERR("QFLG")) - .D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"C",ORD)) Q:'ORD!($G(POERR("QFLG"))) D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE") LK1,ORD - Q -M D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"M",ORD)) Q:'ORD!($G(POERR("QFLG"))) I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LK1,ORD S WIN=1 - Q:$G(POERR("QFLG")) I $G(WIN) S ORD=0 D - .D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"W",ORD)) Q:'ORD!($G(POERR("QFLG"))) I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LK1,ORD - .Q:$G(POERR("QFLG")) - .D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"C",ORD)) Q:'ORD!($G(POERR("QFLG"))) D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE") LK1,ORD - Q -C D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"C",ORD)) Q:'ORD!($G(POERR("QFLG"))) I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LK1,ORD S CLI=1 - Q:$G(POERR("QFLG")) I $G(CLI) S ORD=0 D - .D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"M",ORD)) Q:'ORD!($G(POERR("QFLG"))) I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LK1,ORD - .Q:$G(POERR("QFLG")) - .D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"W",ORD)) Q:'ORD!($G(POERR("QFLG"))) D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE") LK1,ORD - Q -PAT W ! K MEDP,MEDA,POERR("DFLG"),DIR D KQ S PSOSORT="PATIENT" - S DIR("?")="^D PT^PSOORFI1",DIR("A")="All Patients or Single Patient",DIR(0)="SBM^A:ALL;S:SINGLE;E:EXIT",DIR("B")="SINGLE" - D ^DIR K DIR G:$D(DIRUT)!(Y="E") EX I Y="S" S PSOSORT=PSOSORT_"^"_"SINGLE" G SPAT - S PSOSORT=PSOSORT_"^ALL" - S LG=0,PATA=0 F S LG=$O(^PS(52.41,"AD",LG)) Q:'LG!($G(POERR("QFLG"))) F PSOD=0:0 S PSOD=$O(^PS(52.41,"AD",LG,PSOPINST,PSOD)) Q:'PSOD!($G(POERR("QFLG"))) D - .Q:'$D(^PS(52.41,PSOD,0))!($P($G(^PS(52.41,PSOD,0)),"^",23)) - .Q:$G(PAT($P(^PS(52.41,PSOD,0),"^",2)))=$P(^PS(52.41,PSOD,0),"^",2) S PAT=$P(^PS(52.41,PSOD,0),"^",2) - .I PAT'=PATA,$O(PSORX("PSOL",0))!($D(RXRS)) D LBL - .D LK I $G(POERR("QFLG")) K POERR("QFLG") S PSOLK=1,PAT(PAT)=PAT Q - .I $$CHK^PSODPT(PAT_"^"_$P($G(^DPT(PAT,0)),"^"),1,1)<0 S PSOLK=1,PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG,PSOQQ Q - .S (PSODFN,Y)=PAT_"^"_$P($G(^DPT(PAT,0)),"^"),PATA=PAT - .D:'$G(MEDA) PROFILE^PSOORFI2 S Y=PSODFN I $G(MEDP) D SPL D OERR^PSORX1 S PSOFIN=1 D QU S X=PSOPTLOK D KLLP,ULP,KLL Q - .D SDFN D POST^PSOORFI1 I $G(PSOQFLG)!($G(PSOQUIT)) S:$G(PSOQUIT) POERR("QFLG")=1 S:$G(PSOQFLG) PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG Q - .S PAT(PAT)=PAT - .F ORD=0:0 S ORD=$O(^PS(52.41,"AOR",PAT,PSOPINST,ORD)) Q:'ORD!($G(POERR("QFLG")))!($G(PSOQQ)) D - ..I '$P($G(^PS(52.41,ORD,0)),"^",23) D PP,LK1,ORD - .S X=PAT D ULP K PSOQQ - I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL - I $G(PSOQUIT) K PSOQUIT D EX G PSOORFIN - G EX -SPAT K MEDA,MEDP,PSOQFLG,PSORX("FN") D KQ,KV^PSOVER1 - S DIR(0)="FO^2:30",DIR("A")="Select Patient",DIR("?")="^D HELP^PSOORFI2" D ^DIR I $E(X)="?" G SPAT - G:$D(DIRUT) EX D KV^PSOVER1 - S DIC(0)="EQM",DIC=2,DIC("S")="I $D(^PS(52.41,""AOR"",+Y,PSOPINST))" - D ^DIC K DIC G:"^"[X EX G:Y=-1 SPAT S (PSODFN,PAT)=+Y,PSOFINY=Y - D LK I $G(POERR("QFLG")) G SPAT - N SNGLPAT S SNGLPAT=1 - D:'$G(MEDA) PROFILE^PSOORFI2 S Y=PSOFINY I $G(MEDP) D SPL D OERR^PSORX1 D:$O(PSORX("PSOL",0))!($D(RXRS)) LBL S PSOFIN=1,X=PSOPTLOK D KLLP,ULP,KLL G SPAT - D PP,SDFN,POST^PSOORFI1 D:$G(PSOQFLG) G:$G(PSOQFLG) EX I $G(PSOQUIT) S:$G(PSOQUIT) POERR("QFLG")=1 S X=PAT D ULP G SPAT - .S X=PAT D ULP - S ORD=0 F S ORD=$O(^PS(52.41,"P",PAT,ORD)) Q:'ORD!($G(POERR("QFLG"))) D:'$P($G(^PS(52.41,ORD,0)),"^",23) - .D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE")&($P(^(0),"^",3)'="HD") LK1,ORD - I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL - S PSOFIN=1,X=PAT D ULP G SPAT -ORD I $G(PSOBCK) N LST,ORN - E S PSOLOUD=1 D:$P($G(^PS(55,PAT,0)),"^",6)'=2 EN^PSOHLUP(PAT) K PSOLOUD - K DRET,SIG,^TMP("PSORXDC",$J) Q:'$D(^PS(52.41,ORD,0)) - I $G(PSOFIN),$P($G(^PS(52.41,ORD,"INI")),"^")'=$G(PSOPINST) Q - D L1^PSOORFI3 I '$G(PSOMSG) K PSOMSG Q - I '$D(^PS(52.41,ORD,0)) K PSOMSG Q - K DRET,SIG,PSOPRC,PHI,PRC,PSOSIGFL,OBX,PSOMSG S PSOFDR=1,OR0=^PS(52.41,ORD,0),OI=$P(OR0,"^",8),PSORX("SC")=$P(OR0,"^",16) - I $O(^PS(52.41,ORD,2,0)) S PHI=^PS(52.41,ORD,2,0),T=0 F S T=$O(^PS(52.41,ORD,2,T)) Q:'T S PHI(T)=^PS(52.41,ORD,2,T,0) - I $P($G(^PS(52.41,ORD,"EXT")),"^")'="" K PHI I $O(^PS(52.41,ORD,"SIG",0)) S PHI=$G(^PS(52.41,ORD,"SIG",0)),T=0 F S T=$O(^PS(52.41,ORD,"SIG",T)) Q:'T S PHI(T)=$G(^PS(52.41,ORD,"SIG",T,0)) - I $O(^PS(52.41,ORD,3,0)) S PRC=^PS(52.41,ORD,3,0),T=0 F S T=$O(^PS(52.41,ORD,3,T)) Q:'T S PRC(T)=^PS(52.41,ORD,3,T,0) - I $P(OR0,"^",24),($P(OR0,"^",3)="RNW"!($P(OR0,"^",3)="NW")) N PKI,PKI1,PKIR,PKIE S PKI=0 D CER^PSOPKIV1 Q:PKI<1 - I $P(OR0,"^",3)="RNW",$D(^PSRX(+$P(OR0,"^",21),0)) D G SUCC ;process renews - .K PSOREEDT S (PSOORRNW,PSOFDR)=1,PSORENW("OIRXN")=$P(OR0,"^",21),PSOOPT=3,(PSORENW("DFLG"),PSORENW("QFLG"))=0 D ^PSOORRNW,SQR - I $P(OR0,"^",3)="RF",$D(^PSRX(+$P(OR0,"^",19),0)) D RF^PSOORFI2 G SUCC - N PSODRUG,PSONEW S PSOFROM="PENDING" D:'$G(PSOTPBFG) DSPL^PSOTPCAN(ORD) D DSPL^PSOORFI1,SQN^PSOORFI3 -SUCC ; - D UL1^PSOORFI3,FULL^VALM1 - D:$P($G(^PS(52.41,+$G(ORD),0)),"^",3)'="NW"&($P($G(^(0)),"^",3)'="RNW")&($P($G(^(0)),"^",3)'="HD")&($P($G(^(0)),"^",3)'="RF") - .K PSOSD("PENDING",$S('$G(OID):$P(^PS(50.7,$P(OR0,"^",8),0),"^")_" "_$P(^PS(50.606,$P(^PS(50.7,$P(OR0,"^",8),0),"^",2),0),"^"),1:$P(^PSDRUG($P(OR0,"^",9),0),"^"))) - S:$G(POERR("DFLG")) POERR("QFLG")=1 K POERR("DFLG"),PSONEW,ACP,OR0,DRET,SIG,OID,OI,PSORX("SC"),PSORX("CLINIC"),PSODRUG - Q -LBL S PSOFROM="NEW" D ^PSORXL K PSORX("PSOL"),PPL,RXRS - D:$D(BINGCRT)&($D(BINGRTE)&($D(DISGROUP))) ^PSOBING1 K BINGCRT,BINGRTE,PSONEW,BBFLG,BBRX - Q -CHK ; - D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) W !,$C(7),"Outpatient Division MUST be selected!",! G EX - D INST1^PSOORFI2 - S PSZCNT=0 F PSZZI=0:0 S PSZZI=$O(^PS(59,PSZZI)) Q:'PSZZI S PSZCNT=PSZCNT+1 - S TC=0 F TO=0:0 S TO=$O(^PS(52.41,"AOR",TO)) Q:'TO F TZ=0:0 S TZ=$O(^PS(52.41,"AOR",TO,TZ)) Q:'TZ F PSTZ=0:0 S PSTZ=$O(^PS(52.41,"AOR",TO,TZ,PSTZ)) Q:'PSTZ S TC=TC+1 - W !!?10,$C(7),"Orders to be completed"_$S(PSZCNT=1:": ",1:" for all divisions: ")_TC,! Q:'TC - D SUMM^PSOORNE1 K PSZZI,PSZCNT,PSTZ - Q -S D S^PSOORFI2 Q - ; -E D E^PSOORFI2 Q - ; -R D R^PSOORFI2 Q - ; -LK D LOCK^PSOORFI1 - Q -LK1 D LOCK1^PSOORFI1 Q -QU I $G(PSOQUIT) S POERR("QFLG")=1 K PSOQUIT - S:$G(PSOQFLG) PAT(PAT)=PAT - Q -ULP K PSORX("MAIL/WINDOW"),PSORX("METHOD OF PICK-UP") - D CLEAN^PSOVER1 - I '$G(X) Q - D UL^PSSLOCK(X) Q -KLL K PSOPTLOK Q -KLLP K PSONOLCK Q -SPL D SPL^PSOORFI4 Q -SDFN S PSODFN=+$G(PSODFN) Q -PP D PP^PSOORFI4 Q -KQ K PSOQUIT,POERR("QFLG") Q -SQR ; - K PSOORRNW,PSOOPT,PSOREEDT,PSOQUIT S POERR("DFLG")=0 - Q +PSOORFIN ;BIR/SAB-finish cprs orders ;5/14/07 09:47 + ;;7.0;OUTPATIENT PHARMACY;**7,15,27,32,44,46,84,106,111,117,131,146,139,195,208**;DEC 1997;Build 39 + ; Modified from FOIA VistA + ; Copyright (C) GNU GPL 2007 WorldVistA + ; + ;PSSLOCK-2789,PSDRUG-221,50.7-2223,55-2228,50.606-2174 + I $G(PSOAFYN)'="Y" D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) D MSG^PSODPT G EX ;vfah + I $G(PSOAFYN)="Y" D:'$D(PSOPAR) ^PSOAFSET I '$D(PSOPAR) D MSG^PSODPT G EX ;vfah + D INST^PSOORFI2 I $G(PSOIQUIT) K PSOIQUIT G EX + I $P($G(PSOPAR),"^",2),'$D(^XUSEC("PSORPH",DUZ)) S PSORX("VERIFY")=1 + I $G(PSOAFYN)'="Y" S (PSOFIN,POERR)=1 K PSOBCK,MEDA,MEDP,SRT,DIR D KQ S DIR("?")="^D ST^PSOORFI1",DIR("A")="Select By",DIR("B")="PATIENT",DIR(0)="SMB^PA:PATIENT;RT:ROUTE;PR:PRIORITY;CL:CLINIC;E:EXIT" D ^DIR I $D(DIRUT)!(Y="E") G EX ;vfah + I $G(PSOAFYN)'="Y" S (PSOFIN,POERR)=1 K PSOBCK,MEDA,MEDP,SRT,DIR D KQ ;vfah + I $G(PSOAFYN)="Y" S Y="PA" ;vfah + G:Y="PA" PAT G:Y="PR" PRI G:Y="CL" ^PSOORFI3 + K DIR S PSOSORT="ROUTE" + S DIR("?")="^D RT^PSOORFI1",DIR("A")="Route",DIR(0)="SBM^W:WINDOW;M:MAIL;C:CLINIC;E:EXIT",DIR("B")="WINDOW" + D ^DIR G:$D(DIRUT)!(Y="E") EX S PSOSORT=PSOSORT_"^"_Y,PSRT=Y + I $G(PSOAFYN)="Y" S PSOSORT="ROUTE^WINDOW",PSRT="WINDOW" ;vfah + S LG=0,PATA=0 F S LG=$O(^PS(52.41,"AD",LG)) Q:'LG!($G(POERR("QFLG"))) F PSOD=0:0 S PSOD=$O(^PS(52.41,"AD",LG,PSOPINST,PSOD)) Q:'PSOD!($G(POERR("QFLG"))) D + .Q:$G(PAT($P(^PS(52.41,PSOD,0),"^",2)))=$P(^PS(52.41,PSOD,0),"^",2) S PAT=$P(^PS(52.41,PSOD,0),"^",2) + .I PAT'=PATA,$O(PSORX("PSOL",0))!($D(RXRS)) D LBL + .I '$O(^PS(52.41,"AC",PAT,PSRT,0)) S PSOLK=1,PAT(PAT)=PAT Q + .D RTE^PSOORFI2 I $G(PSZFIN) S PSOLK=1,PAT(PAT)=PAT Q + .D LK I $G(POERR("QFLG")) K POERR("QFLG") S PSOLK=1,PAT(PAT)=PAT Q + .I $$CHK^PSODPT(PAT_"^"_$P($G(^DPT(PAT,0)),"^"),1,1)<0 S PSOLK=1,PAT(PAT)=PAT S X=PAT D ULP Q + .S (PSODFN,Y)=PAT_"^"_$P($G(^DPT(PAT,0)),"^"),PATA=PAT + .D:'$G(MEDA) PROFILE^PSOORFI2 S Y=PSODFN I $G(MEDP) D SPL D OERR^PSORX1 S PSOFIN=1 D QU S X=PSOPTLOK D KLLP,ULP,KLL Q + .D SDFN D POST^PSOORFI1 I $G(PSOQFLG)!($G(PSOQUIT)) S:$G(PSOQUIT) POERR("QFLG")=1 S:$G(PSOQFLG) PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG Q + .D PP S ORD=0 D @PSRT S PAT(PAT)=PAT + .S X=PAT D ULP + K POERR("QFLG"),PSOQFLG,PSOPTPST,MAIL,WIN,CLI I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL + I $G(PSOQUIT) K PSOQUIT D EX G PSOORFIN +EX D EX^PSOORFI1 + Q +W D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"W",ORD)) Q:'ORD!($G(POERR("QFLG"))) I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LK1,ORD S MAIL=1 + Q:$G(POERR("QFLG")) I $G(MAIL) S ORD=0 D + .D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"M",ORD)) Q:'ORD!($G(POERR("QFLG"))) D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE") LK1,ORD + .Q:$G(POERR("QFLG")) + .D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"C",ORD)) Q:'ORD!($G(POERR("QFLG"))) D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE") LK1,ORD + Q +M D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"M",ORD)) Q:'ORD!($G(POERR("QFLG"))) I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LK1,ORD S WIN=1 + Q:$G(POERR("QFLG")) I $G(WIN) S ORD=0 D + .D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"W",ORD)) Q:'ORD!($G(POERR("QFLG"))) I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LK1,ORD + .Q:$G(POERR("QFLG")) + .D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"C",ORD)) Q:'ORD!($G(POERR("QFLG"))) D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE") LK1,ORD + Q +C D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"C",ORD)) Q:'ORD!($G(POERR("QFLG"))) I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LK1,ORD S CLI=1 + Q:$G(POERR("QFLG")) I $G(CLI) S ORD=0 D + .D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"M",ORD)) Q:'ORD!($G(POERR("QFLG"))) I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LK1,ORD + .Q:$G(POERR("QFLG")) + .D KQ F S ORD=$O(^PS(52.41,"AC",PAT,"W",ORD)) Q:'ORD!($G(POERR("QFLG"))) D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE") LK1,ORD + Q +PAT I $G(PSOAFYN)'="Y" W ! K MEDP,MEDA,POERR("DFLG"),DIR D KQ S PSOSORT="PATIENT" ;vfah + I $G(PSOAFYN)="Y" K MEDP,MEDA,POERR("DFLG"),DIR D KQ S PSOSORT="PATIENT" ;vfah + I $G(PSOAFYN)'="Y" S DIR("?")="^D PT^PSOORFI1",DIR("A")="All Patients or Single Patient",DIR(0)="SBM^A:ALL;S:SINGLE;E:EXIT",DIR("B")="SINGLE" ;vfah + I $G(PSOAFYN)'="Y" D ^DIR K DIR G:$D(DIRUT)!(Y="E") EX I Y="S" S PSOSORT=PSOSORT_"^"_"SINGLE" G SPAT ;vfah + I $G(PSOAFYN)="Y" S PSOSORT=PSOSORT_"^"_"SINGLE" G SPAT ;vfah + S PSOSORT=PSOSORT_"^ALL" + S LG=0,PATA=0 F S LG=$O(^PS(52.41,"AD",LG)) Q:'LG!($G(POERR("QFLG"))) F PSOD=0:0 S PSOD=$O(^PS(52.41,"AD",LG,PSOPINST,PSOD)) Q:'PSOD!($G(POERR("QFLG"))) D:$D(^PS(52.41,PSOD,0)) + .Q:$G(PAT($P(^PS(52.41,PSOD,0),"^",2)))=$P(^PS(52.41,PSOD,0),"^",2) S PAT=$P(^PS(52.41,PSOD,0),"^",2) + .I PAT'=PATA,$O(PSORX("PSOL",0))!($D(RXRS)) D LBL + .D LK I $G(POERR("QFLG")) K POERR("QFLG") S PSOLK=1,PAT(PAT)=PAT Q + .I $$CHK^PSODPT(PAT_"^"_$P($G(^DPT(PAT,0)),"^"),1,1)<0 S PSOLK=1,PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG,PSOQQ Q + .S (PSODFN,Y)=PAT_"^"_$P($G(^DPT(PAT,0)),"^"),PATA=PAT + .D:'$G(MEDA) PROFILE^PSOORFI2 S Y=PSODFN I $G(MEDP) D SPL D OERR^PSORX1 S PSOFIN=1 D QU S X=PSOPTLOK D KLLP,ULP,KLL Q + .D SDFN D POST^PSOORFI1 I $G(PSOQFLG)!($G(PSOQUIT)) S:$G(PSOQUIT) POERR("QFLG")=1 S:$G(PSOQFLG) PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG Q + .S PAT(PAT)=PAT + .F ORD=0:0 S ORD=$O(^PS(52.41,"AOR",PAT,PSOPINST,ORD)) Q:'ORD!($G(POERR("QFLG")))!($G(PSOQQ)) D + ..D PP,LK1,ORD + .S X=PAT D ULP K PSOQQ + I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL + I $G(PSOQUIT) K PSOQUIT D EX G PSOORFIN + G EX +SPAT K MEDA,MEDP,PSOQFLG,PSORX("FN") D KQ,KV^PSOVER1 + ;PSOAFIN begin SPAT + I $G(PSOAFDON)=1 G EX ;vfah + I $G(PSOAFYN)'="Y" S DIR(0)="FO^2:30",DIR("A")="Select Patient",DIR("?")="^D HELP^PSOORFI2" D ^DIR I $E(X)="?" G SPAT ;vfah + I $G(PSOAFYN)'="Y" G:$D(DIRUT) EX D KV^PSOVER1 ;vfah + I $G(PSOAFYN)'="Y" S DIC(0)="EQM",DIC=2,DIC("S")="I $D(^PS(52.41,""AOR"",+Y,PSOPINST))" ;vfah + I $G(PSOAFYN)'="Y" D ^DIC K DIC G:"^"[X EX G:Y=-1 SPAT S (PSODFN,PAT)=+Y,PSOFINY=Y ;vfah + ;PSOAFIN end SPAT + D LK I $G(POERR("QFLG")) G SPAT + N SNGLPAT S SNGLPAT=1 + D:'$G(MEDA) PROFILE^PSOORFI2 S Y=PSOFINY I $G(MEDP) D SPL D OERR^PSORX1 D:$O(PSORX("PSOL",0))!($D(RXRS)) LBL S PSOFIN=1,X=PSOPTLOK D KLLP,ULP,KLL G SPAT + D PP,SDFN,POST^PSOORFI1 D:$G(PSOQFLG) G:$G(PSOQFLG) EX I $G(PSOQUIT) S:$G(PSOQUIT) POERR("QFLG")=1 S X=PAT D ULP G SPAT + .S X=PAT D ULP + I PSOAFYN'="Y" S ORD=0 F S ORD=$O(^PS(52.41,"P",PAT,ORD)) Q:'ORD!($G(POERR("QFLG"))) D ;vhah + .D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE")&($P(^(0),"^",3)'="HD") LK1,ORD + I PSOAFYN="Y" S ORD=0,ORD=$O(^PS(52.41,"B",+ORDERID,ORD)) D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE")&($P(^(0),"^",3)'="HD") LK1,ORD ;vfah + I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL + I $G(PSOAFYN)="Y" S PSOAFDON=1 ;vfah + S PSOFIN=1,X=PAT D ULP G SPAT +ORD I $G(PSOBCK) N LST,ORN + E S PSOLOUD=1 D:$P($G(^PS(55,PAT,0)),"^",6)'=2 EN^PSOHLUP(PAT) K PSOLOUD + K DRET,SIG,^TMP("PSORXDC",$J) Q:'$D(^PS(52.41,ORD,0)) + I $G(PSOFIN),$P($G(^PS(52.41,ORD,"INI")),"^")'=$G(PSOPINST) Q + D L1^PSOORFI3 I '$G(PSOMSG) K PSOMSG Q + I '$D(^PS(52.41,ORD,0)) K PSOMSG Q + K DRET,SIG,PSOPRC,PHI,PRC,PSOSIGFL,OBX,PSOMSG S PSOFDR=1,OR0=^PS(52.41,ORD,0),OI=$P(OR0,"^",8),PSORX("SC")=$P(OR0,"^",16) + I $O(^PS(52.41,ORD,2,0)) S PHI=^PS(52.41,ORD,2,0),T=0 F S T=$O(^PS(52.41,ORD,2,T)) Q:'T S PHI(T)=^PS(52.41,ORD,2,T,0) + I $P($G(^PS(52.41,ORD,"EXT")),"^")'="" K PHI I $O(^PS(52.41,ORD,"SIG",0)) S PHI=$G(^PS(52.41,ORD,"SIG",0)),T=0 F S T=$O(^PS(52.41,ORD,"SIG",T)) Q:'T S PHI(T)=$G(^PS(52.41,ORD,"SIG",T,0)) + I $O(^PS(52.41,ORD,3,0)) S PRC=^PS(52.41,ORD,3,0),T=0 F S T=$O(^PS(52.41,ORD,3,T)) Q:'T S PRC(T)=^PS(52.41,ORD,3,T,0) + I $P(OR0,"^",24),($P(OR0,"^",3)="RNW"!($P(OR0,"^",3)="NW")) N PKI,PKI1,PKIR,PKIE S PKI=0 D CER^PSOPKIV1 Q:PKI<1 + I $P(OR0,"^",3)="RNW",$D(^PSRX(+$P(OR0,"^",21),0)) D G SUCC ;process renews + .K PSOREEDT S (PSOORRNW,PSOFDR)=1,PSORENW("OIRXN")=$P(OR0,"^",21),PSOOPT=3,(PSORENW("DFLG"),PSORENW("QFLG"))=0 D ^PSOORRNW,SQR^PSOORFI3 + I $P(OR0,"^",3)="RF",$D(^PSRX(+$P(OR0,"^",19),0)) D RF^PSOORFI2 G SUCC + N PSODRUG,PSONEW S PSOFROM="PENDING" D:'$G(PSOTPBFG) DSPL^PSOTPCAN(ORD) D DSPL^PSOORFI1:'$D(ZTSK),SQN^PSOORFI3 +SUCC ; + D SUCC^PSOORFI5 + Q + ; +LBL ; + D LBL^PSOORFI5 + Q + ; +CHK ; + D CHK^PSOORFI5 + Q + ; +PRI K DIR S PSOSORT="PRIORITY" + S DIR("A")="Select Priority",DIR(0)="SBM^S:STAT;E:EMERGENCY;R:ROUTINE",DIR("B")="ROUTINE" + D ^DIR G:$D(DIRUT) EX S PSOSORT=PSOSORT_"^"_Y,PSRT=Y + S LG=0,PATA=0 F S LG=$O(^PS(52.41,"AD",LG)) Q:'LG!($G(POERR("QFLG"))) F PSOD=0:0 S PSOD=$O(^PS(52.41,"AD",LG,PSOPINST,PSOD)) Q:'PSOD!($G(POERR("QFLG"))) D + .Q:$G(PAT($P(^PS(52.41,PSOD,0),"^",2)))=$P(^PS(52.41,PSOD,0),"^",2) S PAT=$P(^PS(52.41,PSOD,0),"^",2) + .I PAT'=PATA,$O(PSORX("PSOL",0))!($D(RXRS)) D LBL + .I '$O(^PS(52.41,"AP",PAT,PSRT,0)) S PSOLK=1,PAT(PAT)=PAT Q + .D PRI^PSOORFI2 I $G(PSZFIN) S PSOLK=1,PAT(PAT)=PAT Q + .D LK I $G(POERR("QFLG")) K POERR("QFLG") S PSOLK=1,PAT(PAT)=PAT Q + .I $$CHK^PSODPT(PAT_"^"_$P($G(^DPT(PAT,0)),"^"),1,1)<0 S PSOLK=1,PAT(PAT)=PAT S X=PAT D ULP Q + .S (PSODFN,Y)=PAT_"^"_$P($G(^DPT(PAT,0)),"^"),PATA=PAT + .D:'$G(MEDA) PROFILE^PSOORFI2 S Y=PSODFN I $G(MEDP) D SPL D OERR^PSORX1 S PSOFIN=1 D QU S X=PSOPTLOK D KLLP,ULP,KLL Q + .D SDFN D POST^PSOORFI1 I $G(PSOQFLG)!($G(PSOQUIT)) S:$G(PSOQUIT) POERR("QFLG")=1 S:$G(PSOQFLG) PAT(PAT)=PAT S X=PAT D ULP K PSOQFLG Q + .D PP S ORD=0 D @PSRT S PAT(PAT)=PAT + .S X=PAT D ULP + I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL + I $G(PSOQUIT) K PSOQUIT D EX G PSOORFIN + G EX + Q +S D S^PSOORFI2 Q + ; +E D E^PSOORFI2 Q + ; +R D R^PSOORFI2 Q + ; +LK D LOCK^PSOORFI1 + Q +LK1 D LOCK1^PSOORFI1 Q +QU I $G(PSOQUIT) S POERR("QFLG")=1 K PSOQUIT + S:$G(PSOQFLG) PAT(PAT)=PAT + Q +ULP K PSORX("MAIL/WINDOW"),PSORX("METHOD OF PICK-UP") + D CLEAN^PSOVER1 + I '$G(X) Q + D UL^PSSLOCK(X) Q +KLL K PSOPTLOK Q +KLLP K PSONOLCK Q +SPL D SPL^PSOORFI4 Q +SDFN S PSODFN=+$G(PSODFN) Q +PP D PP^PSOORFI4 Q +KQ K PSOQUIT,POERR("QFLG") Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNE1.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNE1.m index 74782e3e..a278b6e4 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNE1.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNE1.m @@ -1,144 +1,142 @@ -PSOORNE1 ;BIR/SAB - Display new orders from backdoor ; 2/14/08 10:30am - ;;7.0;OUTPATIENT PHARMACY;**11,21,27,32,37,46,71,94,104,117,133,148,279**;DEC 1997;Build 9 - ;External reference to ^PS(55 is supported by DBIA 2228 -EN(PSONEW) D DSPL^PSOORNE3,^PSOLMPO2 - Q -EDT N FLD,LST K DIR,DUOUT,DIRUT S DIR("A")="Select Field to Edit by number",DIR(0)="LO^1:14" D ^DIR I $D(DTOUT)!($D(DUOUT)) K DIR,DIRUT,DTOUT,DTOUT S VALMBCK="" Q -EDTSEL S:'$G(COPY) PSOEDIT=1 S (PSONEW("DFLG"),PSONEW("FIELD"),PSONEW3)=0 - I +Y S LST=Y D HLDHDR^PSOLMUTL D Q:$G(PSORX("DFLG"))!($G(PSORX("QFLG"))) S VALMBCK="R" G DSPL^PSOORNE3 - .F FLD=1:1:$L(LST,",") Q:$P(LST,",",FLD)']"" D @(+$P(LST,",",FLD)) Q:$G(PSODIR("DFLG"))!($G(PSODIR("QFLG"))) - E S VALMBCK="" D FULL^VALM1 - D RDSPL G DSPL^PSOORNE3 - Q -ACP K VALMSG,DIR,PSORX("DFLG") D VER I $G(PSONEW2("QFLG"))!($G(PSORX("DFLG"))) S VALMBCK="Q" K PSONEW2 Q - N PSONOBCK S PSONOBCK=$S($G(PSOSIGFL):1,1:0) - D NOOR^PSONEW I $D(DIRUT) S PSONEW("DFLG")=1 K DIR,X,Y,DIRUT,DUOUT,DTOUT Q - D RXNCHK,RDSPL - I $G(PSONEW("QFLG")) S PSONEW("DFLG")=1 K DIR,X,Y,DIRUT,DUOUT,DTOUT Q - D DISPLAY^PSONEW2 - D ^PSONEWG I $G(PSOCPZ("DFLG")) S PSONEW("DFLG")=1 K PSOANSQ,DIR,X,Y,DIRUT,DUOUT,DTOUT,PSOCPZ("DFLG"),PSOANSQD Q - K PSOCPZ("DFLG") - K DIR,DIRUT,X,Y S DIR(0)="Y",DIR("B")="YES",DIR("A")="Is this correct" D ^DIR - I $D(DIRUT) S PSONEW("DFLG")=1 K PSOANSQ,PSOANSQD,DIR,X,Y,DIRUT,DUOUT,DTOUT Q - I 'Y S VALMBCK="R" K PSOANSQ,DIR,X,Y,DIRUT,DUOUT,DTOUT D DSPL^PSOORNE3 Q - W "..." K PSOANSQD,DIR,X,Y,DIRUT,DUOUT,DTOUT D DCORD^PSONEW2 - I $G(NCPDPFLG) D NCPDP^PSOORED6 - K:$G(COPY)!($G(PSOSIGFL)) PRC,PHI - S:'$G(PSOID) PSOID=DT S (PSORX("FN"),PSONEW("POE"))=1 D EN^PSON52(.PSONEW) ; Files entry in File 52 - I $G(PSOBEDT) D - .I '$D(^TMP("PSOBEDT",$J,PSODFN,0)) S ^TMP("PSOBEDT",$J,PSODFN,0)=PSORXED("IRXN") S:$G(PSONEW("MAIL/WINDOW"))["W" ^TMP("PSOBEDT",$J,PSODFN,1)=1 Q - .S ^TMP("PSOBEDT",$J,PSODFN,0)=^TMP("PSOBEDT",$J,PSODFN,0)_","_PSORXED("IRXN") - .I $G(PSONEW("MAIL/WINDOW"))["W" S ^TMP("PSOBEDT",$J,PSODFN,1)=1 - D NPSOSD^PSOUTIL(.PSONEW) ; Adds newly added rx to PSOSD array - D ^PSOBUILD S VALMBCK="Q" - K PSONEW("# OF REFILLS"),PSONEW("DAYS SUPPLY"),SDA,SEG1,SSN1,STA,Z4,ZDA - Q:$G(COPY) S PSONEW("DFLG")=0 - Q -VER I $G(PSOAC),$G(PSODRUG("NAME"))']"" D FULL^VALM1,2^PSOORNW1 - I $G(PSODRUG("NAME"))']"" S VALMSG="A Dispense Drug Must be Chosen!" S PSONEW2("QFLG")=1 Q - I '$G(PSONEW("ENT")) W !,"Dosing Instruction Missing!!",! D I PSONEW("DFLG")=1 S PSONEW2("QFLG")=1 Q - .S PSOORRNW=1 - .K VALMSG D FULL^VALM1 W !,"Drug: "_PSODRUG("NAME") - .I $O(SIG(0)) F I=1:1 Q:$G(SIG(I))']"" W !,SIG(I) - .E I $G(^PSRX(PSONEW("OIRXN"),"SIG"))]"" S X=$P(^PSRX(PSONEW("OIRXN"),"SIG"),"^") D SIGONE^PSOHELP W !,$E($G(INS1),2,250) - .W ! D 5 K PSOORRNW I PSONEW("DFLG")=1 D M3 Q - .D 6 D:PSONEW("DFLG")=1 M3 - D:$G(COPY) PROV^PSOUTIL(.PSORENW) I PSONEW("DFLG")=1 S PSONEW2("QFLG")=1 Q - D FULL^VALM1,POST^PSODRG:'$G(PSOSIGFL) K PSONOOR I $G(PSORX("DFLG")) S VALMBCK="Q" Q - I +$G(PSEXDT) D - .D FULL^VALM1 S:$G(PSONEW("MAIL/WINDOW"))["W" BINGCRT="Y",BINGRTE="W" - .D:+$G(PSEXDT) - ..S Y=PSONEW("FILL DATE") X ^DD("DD") W !!,$C(7),Y_" fill date is greater than possible expiration date of " S Y=$P(PSEXDT,"^",2) X ^DD("DD") W Y_"." - .S PSONEW2("QFLG")=1,VALMBCK="R" D PAUSE^VALM1 - Q -1 I $G(PSOSIGFL) S PSOAC=1 D 2^PSOORNW1 K PSOAC D RDSPL G DSPL^PSOORNE3 Q - D 6^PSOBKDED D RDSPL G DSPL^PSOORNE3 Q - ; -2 D 3^PSOBKDED Q - ; -3 D 1^PSOBKDED Q - ; -4 D 2^PSOBKDED Q - ; -5 I '$G(PSODRUG("IEN")) W !,"DRUG NAME REQUIRED!" D 2^PSOORNW1 I '$G(PSODRUG("IEN")) S VALMSG="No Dispense Drug Selected" Q - W !!,"Drug: "_PSODRUG("NAME") D 10^PSOBKDED Q - ; -6 D INS^PSOBKDED Q:$G(PSONEW("DFLG")) I $P($G(^PS(55,PSODFN,"LAN")),"^") D SINS^PSODIR(.PSONEW) - Q - ; -7 D 8^PSOBKDED Q - ; -8 D 7^PSOBKDED Q - ; -9 D 9^PSOBKDED Q - ; -10 D 12^PSOBKDED Q - ; -11 D 5^PSOBKDED Q - ; -12 D 4^PSOBKDED Q - ; -13 D 11^PSOBKDED Q - ; -14 D 13^PSOBKDED Q - ; -SUMM ;print break down of orders to be finished - K ^TMP($J,"PSOCZT"),^TMP($J,"PSODPAT"),PAT,RT,DIR,DUOUT,DIRUT,PSZLQUIT - S DIR("A")="Do you want an Order Summary",DIR(0)="Y",DIR("B")="No" - D ^DIR K DIR I 'Y!($D(DIRUT)) K Y,X,DIRUT Q - K PSOINPRT,DIQ,^UTILITY("DIQ1",$J) I $G(PSOPINST) S DA=PSOPINST,DIC=4,DIQ(0)="E",DR=".01" D EN^DIQ1 S PSOINPRT=$G(^UTILITY("DIQ1",$J,4,DA,.01,"E")) K ^UTILITY("DIQ1",$J),DA,DR,DIC,DIQ - I $D(^PS(52.41,"ACL")) N PSOCLSUM D SUMMCL I $G(PSOCLSUM) K PSOINPRT Q - F PSI=0:0 S PSI=$O(^PS(52.41,"AOR",PSI)) Q:'PSI F PSID=0:0 S PSID=$O(^PS(52.41,"AOR",PSI,PSID)) Q:'PSID F PIN=0:0 S PIN=$O(^PS(52.41,"AOR",PSI,PSID,PIN)) Q:'PIN D - .I '$D(^TMP($J,"PSOCZT",PSID,"PAT")) F PZA="PAT","WIN","MAIL","CLIN" S ^TMP($J,"PSOCZT",PSID,PZA)=0 - .I '$D(^TMP($J,"PSODPAT",PSID,PSI)) S ^TMP($J,"PSODPAT",PSID,PSI)=1,^TMP($J,"PSOCZT",PSID,"PAT")=^TMP($J,"PSOCZT",PSID,"PAT")+1 - .S PZROUT=$P($G(^PS(52.41,PIN,0)),"^",17) I PZROUT'="" S ^TMP($J,"PSOCZT",PSID,$S(PZROUT="C":"CLIN",PZROUT="M":"MAIL",1:"WIN"))=^TMP($J,"PSOCZT",PSID,$S(PZROUT="C":"CLIN",PZROUT="M":"MAIL",1:"WIN"))+1 - W @IOF W !?20,"Pending Outpatient Medication Orders",! I $G(PSZCNT)>1 W ?20,"(signed in under "_$G(PSOINPRT)_")",! - F PSOINL=0:0 S PSOINL=$O(^TMP($J,"PSOCZT",PSOINL)) Q:'PSOINL!($G(PSZLQUIT)) D - .I ($Y+6)>IOSL K DIR S DIR(0)="E" D ^DIR K DIR D:$G(Y) I '$G(Y) S PSZLQUIT=1 W ! Q - ..W @IOF W !?20,"Pending Outpatient Medication Orders",! I $G(PSZCNT)>1 W ?20,"(signed in under "_$G(PSOINPRT)_")",! - .K ^UTILITY("DIQ1",$J),DIQ,PSOINPRX S DA=$G(PSOINL),DIC=4,DIQ(0)="E",DR=".01" D EN^DIQ1 S PSOINPRX=$G(^UTILITY("DIQ1",$J,4,DA,.01,"E")) K ^UTILITY("DIQ1",$J),DA,DR,DIC,DIQ - .;PSO*7*279 Change division to Institution - .W !,"Institution: ",$G(PSOINPRX) - .W !,"Patients: "_$G(^TMP($J,"PSOCZT",PSOINL,"PAT"))_" Window: "_$G(^("WIN"))_" Mail: "_$G(^("MAIL"))_" Clinic: "_$G(^("CLIN")),! - K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR - K ^TMP($J,"PSOCZT"),^TMP($J,"PSODPAT"),RT,PSOINPRT,PSOINPRX,PSI,PSID,PIN,PZA,PZROUT,PSOINL,PSZLQUIT - Q -SUMMCL ; - ;PSO*7*279 Change Division to Institution - W ! K DIR S DIR(0)="SMB^I:INSTITUTION;C:CLINIC",DIR("A")="Do you want the summary by Institution or Clinic",DIR("B")="Institution",DIR("?")=" " - S DIR("?",1)="Enter 'I' to see the summary by Institution, and within Institution the orders",DIR("?",2)="shown by Mail, Window, or Administered in Clinic.",DIR("?",3)="Enter 'C' to see the summary by Clinic, along with Clinic Sort Groups." - D ^DIR K DIR I $D(DTOUT)!($D(DUOUT)) S PSOCLSUM=1 Q - Q:$G(Y)="I" - S PSOCLSUM=1 - K ^TMP($J,"PSOLOC"),^TMP($J,"PSOLOCP") N PSCX,PSCXL,PSLX,PSCIN,PSCPT,PSCNDE,PSNCL,PSNPAT,PSCLOUT,PSCSFLAG,PCCNT,PSOCAG - F PSCX=0:0 S PSCX=$O(^PS(52.41,"ACL",PSCX)) Q:'PSCX F PSLX=0:0 S PSLX=$O(^PS(52.41,"ACL",PSCX,PSLX)) Q:'PSLX F PSCIN=0:0 S PSCIN=$O(^PS(52.41,"ACL",PSCX,PSLX,PSCIN)) Q:'PSCIN S PSCPT=+$P($G(^PS(52.41,PSCIN,0)),"^",2) D:PSCPT - .S PSCNDE=$G(^PS(52.41,PSCIN,0)) - .I $P(PSCNDE,"^",3)'="NW",$P(PSCNDE,"^",3)'="RNW",$P(PSCNDE,"^",3)'="RF" Q - .I $P(PSCNDE,"^",13)="" Q - .S PSNCL=+$P(PSCNDE,"^",13),PSNPAT=+$P(PSCNDE,"^",2) - .I '$D(^TMP($J,"PSOLOC",PSNCL)) S ^TMP($J,"PSOLOC",PSNCL)="1^1",^TMP($J,"PSOLOCP",PSNCL,PSNPAT)="" Q - .S $P(^TMP($J,"PSOLOC",PSNCL),"^",2)=$P(^TMP($J,"PSOLOC",PSNCL),"^",2)+1 - .I '$D(^TMP($J,"PSOLOCP",PSNCL,PSNPAT)) S $P(^TMP($J,"PSOLOC",PSNCL),"^")=$P(^TMP($J,"PSOLOC",PSNCL),"^")+1 - .S ^TMP($J,"PSOLOCP",PSNCL,PSNPAT)="" - I '$O(^TMP($J,"PSOLOC",0)) G SUMMQ - W @IOF W !?20,"Pending Outpatient Medication Orders" I $G(PSZCNT)>1 W !?20,"(signed in under "_$G(PSOINPRT)_")" - F PSCXL=0:0 S PSCXL=$O(^TMP($J,"PSOLOC",PSCXL)) Q:'PSCXL!($G(PSCLOUT)) D - .I ($Y+7)>IOSL D CLDIR Q:$G(PSCLOUT) - .W !!,"Clinic: ",$P($G(^SC(+PSCXL,0)),"^") - .W !,"Patients: ",$P($G(^TMP($J,"PSOLOC",PSCXL)),"^"),?16,"Orders: ",$P($G(^TMP($J,"PSOLOC",PSCXL)),"^",2) - .W !,"In Sort Groups:" - .S (PCCNT,PSCSFLAG)=0 F PSCSORT=0:0 S PSCSORT=$O(^PS(59.8,PSCSORT)) Q:'PSCSORT!($G(PSCLOUT)) I $D(^PS(59.8,PSCSORT,1,"B",PSCXL)) S PSOCAG=0 D - ..S PSCSFLAG=1 S:($Y+5)>IOSL&(PCCNT) PSOCAG=1 D:($Y+5)>IOSL&(PCCNT) CLDIR Q:$G(PSCLOUT) W:$G(PSOCAG) !,"Clinic: "_$P($G(^SC(PSCXL,0)),"^")_" cont." W:$G(PCCNT)>0 ! W ?16,$P($G(^PS(59.8,PSCSORT,0)),"^") S PCCNT=1 - .I '$G(PSCSFLAG) W ?16,"*** NO CLINIC SORT GROUPS ***" - I '$G(PSCLOUT) K DIR S DIR(0)="E",DIR("A")="Press to continue" D ^DIR K DIR -SUMMQ K ^TMP($J,"PSOLOC"),^TMP($J,"PSOLOCP") - Q -CLDIR K DIR S DIR(0)="E",DIR("A")="Press to continue, '^' to exit" D ^DIR K DIR I Y'=1 S PSCLOUT=1 Q - W @IOF - Q -RXNCHK I $G(PSONEW("RX #"))']"" D RXNCHK^PSOORNE5 - Q -RDSPL D RDSPL^PSOORNE5 - Q -M3 D M3^PSOOREDX - Q +PSOORNE1 ;BIR/SAB - Display new orders from backdoor ;03/06/95 + ;;7.0;OUTPATIENT PHARMACY;**11,21,27,32,37,46,71,94,104,117,133,148**;DEC 1997 + ;External reference to ^PS(55 is supported by DBIA 2228 +EN(PSONEW) D DSPL^PSOORNE3,^PSOLMPO2 + Q +EDT N FLD,LST K DIR,DUOUT,DIRUT S DIR("A")="Select Field to Edit by number",DIR(0)="LO^1:14" D ^DIR I $D(DTOUT)!($D(DUOUT)) K DIR,DIRUT,DTOUT,DTOUT S VALMBCK="" Q +EDTSEL S:'$G(COPY) PSOEDIT=1 S (PSONEW("DFLG"),PSONEW("FIELD"),PSONEW3)=0 + I +Y S LST=Y D HLDHDR^PSOLMUTL D Q:$G(PSORX("DFLG"))!($G(PSORX("QFLG"))) S VALMBCK="R" G DSPL^PSOORNE3 + .F FLD=1:1:$L(LST,",") Q:$P(LST,",",FLD)']"" D @(+$P(LST,",",FLD)) Q:$G(PSODIR("DFLG"))!($G(PSODIR("QFLG"))) + E S VALMBCK="" D FULL^VALM1 + D RDSPL G DSPL^PSOORNE3 + Q +ACP K VALMSG,DIR,PSORX("DFLG") D VER I $G(PSONEW2("QFLG"))!($G(PSORX("DFLG"))) S VALMBCK="Q" K PSONEW2 Q + N PSONOBCK S PSONOBCK=$S($G(PSOSIGFL):1,1:0) + D NOOR^PSONEW I $D(DIRUT) S PSONEW("DFLG")=1 K DIR,X,Y,DIRUT,DUOUT,DTOUT Q + D RXNCHK,RDSPL + I $G(PSONEW("QFLG")) S PSONEW("DFLG")=1 K DIR,X,Y,DIRUT,DUOUT,DTOUT Q + D DISPLAY^PSONEW2 + D ^PSONEWG I $G(PSOCPZ("DFLG")) S PSONEW("DFLG")=1 K PSOANSQ,DIR,X,Y,DIRUT,DUOUT,DTOUT,PSOCPZ("DFLG"),PSOANSQD Q + K PSOCPZ("DFLG") + K DIR,DIRUT,X,Y S DIR(0)="Y",DIR("B")="YES",DIR("A")="Is this correct" D ^DIR + I $D(DIRUT) S PSONEW("DFLG")=1 K PSOANSQ,PSOANSQD,DIR,X,Y,DIRUT,DUOUT,DTOUT Q + I 'Y S VALMBCK="R" K PSOANSQ,DIR,X,Y,DIRUT,DUOUT,DTOUT D DSPL^PSOORNE3 Q + W "..." K PSOANSQD,DIR,X,Y,DIRUT,DUOUT,DTOUT D DCORD^PSONEW2 + I $G(NCPDPFLG) D NCPDP^PSOORED6 + K:$G(COPY)!($G(PSOSIGFL)) PRC,PHI + S:'$G(PSOID) PSOID=DT S (PSORX("FN"),PSONEW("POE"))=1 D EN^PSON52(.PSONEW) ; Files entry in File 52 + I $G(PSOBEDT) D + .I '$D(^TMP("PSOBEDT",$J,PSODFN,0)) S ^TMP("PSOBEDT",$J,PSODFN,0)=PSORXED("IRXN") S:$G(PSONEW("MAIL/WINDOW"))["W" ^TMP("PSOBEDT",$J,PSODFN,1)=1 Q + .S ^TMP("PSOBEDT",$J,PSODFN,0)=^TMP("PSOBEDT",$J,PSODFN,0)_","_PSORXED("IRXN") + .I $G(PSONEW("MAIL/WINDOW"))["W" S ^TMP("PSOBEDT",$J,PSODFN,1)=1 + D NPSOSD^PSOUTIL(.PSONEW) ; Adds newly added rx to PSOSD array + D ^PSOBUILD S VALMBCK="Q" + K PSONEW("# OF REFILLS"),PSONEW("DAYS SUPPLY"),SDA,SEG1,SSN1,STA,Z4,ZDA + Q:$G(COPY) S PSONEW("DFLG")=0 + Q +VER I $G(PSOAC),$G(PSODRUG("NAME"))']"" D FULL^VALM1,2^PSOORNW1 + I $G(PSODRUG("NAME"))']"" S VALMSG="A Dispense Drug Must be Chosen!" S PSONEW2("QFLG")=1 Q + I '$G(PSONEW("ENT")) W !,"Dosing Instruction Missing!!",! D I PSONEW("DFLG")=1 S PSONEW2("QFLG")=1 Q + .S PSOORRNW=1 + .K VALMSG D FULL^VALM1 W !,"Drug: "_PSODRUG("NAME") + .I $O(SIG(0)) F I=1:1 Q:$G(SIG(I))']"" W !,SIG(I) + .E I $G(^PSRX(PSONEW("OIRXN"),"SIG"))]"" S X=$P(^PSRX(PSONEW("OIRXN"),"SIG"),"^") D SIGONE^PSOHELP W !,$E($G(INS1),2,250) + .W ! D 5 K PSOORRNW I PSONEW("DFLG")=1 D M3 Q + .D 6 D:PSONEW("DFLG")=1 M3 + D:$G(COPY) PROV^PSOUTIL(.PSORENW) I PSONEW("DFLG")=1 S PSONEW2("QFLG")=1 Q + D FULL^VALM1,POST^PSODRG:'$G(PSOSIGFL) K PSONOOR I $G(PSORX("DFLG")) S VALMBCK="Q" Q + I +$G(PSEXDT) D + .D FULL^VALM1 S:$G(PSONEW("MAIL/WINDOW"))["W" BINGCRT="Y",BINGRTE="W" + .D:+$G(PSEXDT) + ..S Y=PSONEW("FILL DATE") X ^DD("DD") W !!,$C(7),Y_" fill date is greater than possible expiration date of " S Y=$P(PSEXDT,"^",2) X ^DD("DD") W Y_"." + .S PSONEW2("QFLG")=1,VALMBCK="R" D PAUSE^VALM1 + Q +1 I $G(PSOSIGFL) S PSOAC=1 D 2^PSOORNW1 K PSOAC D RDSPL G DSPL^PSOORNE3 Q + D 6^PSOBKDED D RDSPL G DSPL^PSOORNE3 Q + ; +2 D 3^PSOBKDED Q + ; +3 D 1^PSOBKDED Q + ; +4 D 2^PSOBKDED Q + ; +5 I '$G(PSODRUG("IEN")) W !,"DRUG NAME REQUIRED!" D 2^PSOORNW1 I '$G(PSODRUG("IEN")) S VALMSG="No Dispense Drug Selected" Q + W !!,"Drug: "_PSODRUG("NAME") D 10^PSOBKDED Q + ; +6 D INS^PSOBKDED Q:$G(PSONEW("DFLG")) I $P($G(^PS(55,PSODFN,"LAN")),"^") D SINS^PSODIR(.PSONEW) + Q + ; +7 D 8^PSOBKDED Q + ; +8 D 7^PSOBKDED Q + ; +9 D 9^PSOBKDED Q + ; +10 D 12^PSOBKDED Q + ; +11 D 5^PSOBKDED Q + ; +12 D 4^PSOBKDED Q + ; +13 D 11^PSOBKDED Q + ; +14 D 13^PSOBKDED Q + ; +SUMM ;print break down of orders to be finished + K ^TMP($J,"PSOCZT"),^TMP($J,"PSODPAT"),PAT,RT,DIR,DUOUT,DIRUT,PSZLQUIT + S DIR("A")="Do you want an Order Summary",DIR(0)="Y",DIR("B")="No" + D ^DIR K DIR I 'Y!($D(DIRUT)) K Y,X,DIRUT Q + K PSOINPRT,DIQ,^UTILITY("DIQ1",$J) I $G(PSOPINST) S DA=PSOPINST,DIC=4,DIQ(0)="E",DR=".01" D EN^DIQ1 S PSOINPRT=$G(^UTILITY("DIQ1",$J,4,DA,.01,"E")) K ^UTILITY("DIQ1",$J),DA,DR,DIC,DIQ + I $D(^PS(52.41,"ACL")) N PSOCLSUM D SUMMCL I $G(PSOCLSUM) K PSOINPRT Q + F PSI=0:0 S PSI=$O(^PS(52.41,"AOR",PSI)) Q:'PSI F PSID=0:0 S PSID=$O(^PS(52.41,"AOR",PSI,PSID)) Q:'PSID F PIN=0:0 S PIN=$O(^PS(52.41,"AOR",PSI,PSID,PIN)) Q:'PIN D + .I '$D(^TMP($J,"PSOCZT",PSID,"PAT")) F PZA="PAT","WIN","MAIL","CLIN" S ^TMP($J,"PSOCZT",PSID,PZA)=0 + .I '$D(^TMP($J,"PSODPAT",PSID,PSI)) S ^TMP($J,"PSODPAT",PSID,PSI)=1,^TMP($J,"PSOCZT",PSID,"PAT")=^TMP($J,"PSOCZT",PSID,"PAT")+1 + .S PZROUT=$P($G(^PS(52.41,PIN,0)),"^",17) I PZROUT'="" S ^TMP($J,"PSOCZT",PSID,$S(PZROUT="C":"CLIN",PZROUT="M":"MAIL",1:"WIN"))=^TMP($J,"PSOCZT",PSID,$S(PZROUT="C":"CLIN",PZROUT="M":"MAIL",1:"WIN"))+1 + W @IOF W !?20,"Pending Outpatient Medication Orders",! I $G(PSZCNT)>1 W ?20,"(signed in under "_$G(PSOINPRT)_")",! + F PSOINL=0:0 S PSOINL=$O(^TMP($J,"PSOCZT",PSOINL)) Q:'PSOINL!($G(PSZLQUIT)) D + .I ($Y+6)>IOSL K DIR S DIR(0)="E" D ^DIR K DIR D:$G(Y) I '$G(Y) S PSZLQUIT=1 W ! Q + ..W @IOF W !?20,"Pending Outpatient Medication Orders",! I $G(PSZCNT)>1 W ?20,"(signed in under "_$G(PSOINPRT)_")",! + .K ^UTILITY("DIQ1",$J),DIQ,PSOINPRX S DA=$G(PSOINL),DIC=4,DIQ(0)="E",DR=".01" D EN^DIQ1 S PSOINPRX=$G(^UTILITY("DIQ1",$J,4,DA,.01,"E")) K ^UTILITY("DIQ1",$J),DA,DR,DIC,DIQ + .W !,"Division: ",$G(PSOINPRX) + .W !,"Patients: "_$G(^TMP($J,"PSOCZT",PSOINL,"PAT"))_" Window: "_$G(^("WIN"))_" Mail: "_$G(^("MAIL"))_" Clinic: "_$G(^("CLIN")),! + K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR + K ^TMP($J,"PSOCZT"),^TMP($J,"PSODPAT"),RT,PSOINPRT,PSOINPRX,PSI,PSID,PIN,PZA,PZROUT,PSOINL,PSZLQUIT + Q +SUMMCL ; + W ! K DIR S DIR(0)="SMB^D:DIVISION;C:CLINIC",DIR("A")="Do you want the summary by Division or Clinic",DIR("B")="Division",DIR("?")=" " + S DIR("?",1)="Enter 'D' to see the summary by Division, and within Division the orders",DIR("?",2)="shown by Mail, Window, or Administered in Clinic.",DIR("?",3)="Enter 'C' to see the summary by Clinic, along with Clinic Sort Groups." + D ^DIR K DIR I $D(DTOUT)!($D(DUOUT)) S PSOCLSUM=1 Q + Q:$G(Y)="D" + S PSOCLSUM=1 + K ^TMP($J,"PSOLOC"),^TMP($J,"PSOLOCP") N PSCX,PSCXL,PSLX,PSCIN,PSCPT,PSCNDE,PSNCL,PSNPAT,PSCLOUT,PSCSFLAG,PCCNT,PSOCAG + F PSCX=0:0 S PSCX=$O(^PS(52.41,"ACL",PSCX)) Q:'PSCX F PSLX=0:0 S PSLX=$O(^PS(52.41,"ACL",PSCX,PSLX)) Q:'PSLX F PSCIN=0:0 S PSCIN=$O(^PS(52.41,"ACL",PSCX,PSLX,PSCIN)) Q:'PSCIN S PSCPT=+$P($G(^PS(52.41,PSCIN,0)),"^",2) D:PSCPT + .S PSCNDE=$G(^PS(52.41,PSCIN,0)) + .I $P(PSCNDE,"^",3)'="NW",$P(PSCNDE,"^",3)'="RNW",$P(PSCNDE,"^",3)'="RF" Q + .I $P(PSCNDE,"^",13)="" Q + .S PSNCL=+$P(PSCNDE,"^",13),PSNPAT=+$P(PSCNDE,"^",2) + .I '$D(^TMP($J,"PSOLOC",PSNCL)) S ^TMP($J,"PSOLOC",PSNCL)="1^1",^TMP($J,"PSOLOCP",PSNCL,PSNPAT)="" Q + .S $P(^TMP($J,"PSOLOC",PSNCL),"^",2)=$P(^TMP($J,"PSOLOC",PSNCL),"^",2)+1 + .I '$D(^TMP($J,"PSOLOCP",PSNCL,PSNPAT)) S $P(^TMP($J,"PSOLOC",PSNCL),"^")=$P(^TMP($J,"PSOLOC",PSNCL),"^")+1 + .S ^TMP($J,"PSOLOCP",PSNCL,PSNPAT)="" + I '$O(^TMP($J,"PSOLOC",0)) G SUMMQ + W @IOF W !?20,"Pending Outpatient Medication Orders" I $G(PSZCNT)>1 W !?20,"(signed in under "_$G(PSOINPRT)_")" + F PSCXL=0:0 S PSCXL=$O(^TMP($J,"PSOLOC",PSCXL)) Q:'PSCXL!($G(PSCLOUT)) D + .I ($Y+7)>IOSL D CLDIR Q:$G(PSCLOUT) + .W !!,"Clinic: ",$P($G(^SC(+PSCXL,0)),"^") + .W !,"Patients: ",$P($G(^TMP($J,"PSOLOC",PSCXL)),"^"),?16,"Orders: ",$P($G(^TMP($J,"PSOLOC",PSCXL)),"^",2) + .W !,"In Sort Groups:" + .S (PCCNT,PSCSFLAG)=0 F PSCSORT=0:0 S PSCSORT=$O(^PS(59.8,PSCSORT)) Q:'PSCSORT!($G(PSCLOUT)) I $D(^PS(59.8,PSCSORT,1,"B",PSCXL)) S PSOCAG=0 D + ..S PSCSFLAG=1 S:($Y+5)>IOSL&(PCCNT) PSOCAG=1 D:($Y+5)>IOSL&(PCCNT) CLDIR Q:$G(PSCLOUT) W:$G(PSOCAG) !,"Clinic: "_$P($G(^SC(PSCXL,0)),"^")_" cont." W:$G(PCCNT)>0 ! W ?16,$P($G(^PS(59.8,PSCSORT,0)),"^") S PCCNT=1 + .I '$G(PSCSFLAG) W ?16,"*** NO CLINIC SORT GROUPS ***" + I '$G(PSCLOUT) K DIR S DIR(0)="E",DIR("A")="Press to continue" D ^DIR K DIR +SUMMQ K ^TMP($J,"PSOLOC"),^TMP($J,"PSOLOCP") + Q +CLDIR K DIR S DIR(0)="E",DIR("A")="Press to continue, '^' to exit" D ^DIR K DIR I Y'=1 S PSCLOUT=1 Q + W @IOF + Q +RXNCHK I $G(PSONEW("RX #"))']"" D RXNCHK^PSOORNE5 + Q +RDSPL D RDSPL^PSOORNE5 + Q +M3 D M3^PSOOREDX + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNE2.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNE2.m index 4a022da8..73541b84 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNE2.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNE2.m @@ -1,116 +1,116 @@ -PSOORNE2 ;BIR/SAB-display finished orders from backdoor ; 9/11/06 10:24am - ;;7.0;OUTPATIENT PHARMACY;**11,21,23,27,32,37,46,84,103,117,131,146,156,210,148,222,238,264,281**;DEC 1997;Build 41 - ;^PSDRUG( - 221 - ;^YSCL(603.01 - 2697 - ;^PS(50.606 - 2174 - ;^PS(50.7 - 2223 - ;PSO*210 add call to WORDWRAP api - ;$$DAWEXT^PSSDAWUT - 4708 - ; -SEL N ORN,ORD I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!" S VALMBCK="" Q - D K1^PSOORNE6 S DIR("A")="Select Orders by number",DIR(0)="LO^1:"_PSOCNT D ^DIR I $D(DIRUT) D KV^PSOVER1 S VALMBCK="" Q -NEWSEL N ORN,ORD D K2^PSOORNE6 - I +Y S PSOOELSE=1,PSLST=Y K PSOREEDT D - .F ORD=1:1:$L(PSLST,",") Q:$P(PSLST,",",ORD)']"" S ORN=+$P(PSLST,",",ORD) D @$S(+PSOLST(ORN)=52:"ACT",1:"PEN^PSOORNE5") K PSOREEDT,PSOSIGFL,PSONACT,SIGOK,PSOFDR,DRET,SIG,INS1 D UL1 I $G(PSOQUIT) K PSOQUIT Q - K PRC,PHI,RTE I '$G(PSOOELSE) S VALMBCK="" - K PSONACT,PSOOELSE,CLOZPAT D ^PSOBUILD,BLD^PSOORUT1,K3^PSOORNE6 - Q - ; -ACT N REF K ^TMP("PSOAO",$J),PCOMX,PDA,PHI,PRC,ACOM,ANS,PSOFDR,CLOZPAT,ANQREM,DUR,DRET - S RXN=$P(PSOLST(ORN),"^",2),RX0=^PSRX(RXN,0),RX2=$G(^(2)),RX3=$G(^(3)),ST=+$G(^("STA")),RXOR=$G(^("OR1")),POE=$G(^("POE")),EXDT=$S($P($G(^(2)),"^",6)>DT:1,1:0) - I 'RX3 S RX3=$P(RX2,"^",2),$P(^PSRX(RXN,3),"^")=$P(RX2,"^",2) - S PSODRG=+$P(RX0,"^",6),PSODRUG0=^PSDRUG(PSODRG,0),INDT=$G(^("I")) - ;PSO*7*238;SET PSODRUG ARRAY ; PSOY KILLED AT END OF SET^PSODRG - K PSODRUG - S PSOY=PSODRG,PSOY(0)=PSODRUG0 D SET^PSODRG - I 'RXOR,$P(^PSDRUG(PSODRG,2),"^") S $P(^PSRX(RXN,"OR1"),"^")=$P(^PSDRUG(PSODRG,2),"^"),RXOR=$P(^PSDRUG(PSODRG,2),"^") - I $P($G(^PSDRUG(PSODRG,"CLOZ1")),"^")="PSOCLO1" D - .S CLOZPAT=$O(^YSCL(603.01,"C",PSODFN,0)) Q:'CLOZPAT - .;S CLOZPAT=$S($P(^YSCL(603.01,CLOZPAT,0),"^",3)="B":1,1:0) - .S CLOZPAT=$P(^YSCL(603.01,CLOZPAT,0),"^",3) - .S CLOZPAT=$S(CLOZPAT="M":2,CLOZPAT="B":1,1:0) - I $D(^XUSEC("PSORPH",DUZ)) S RPH=1 D - .S PSOACT=$S('ST&($G(INDT)]"")&(DT>$G(INDT)):"DHPLATC",ST=1:"DVE",ST=4:"DV",ST=3:"DU",ST=5:"ELTD",ST=11:"ETDPCL",ST=12&EXDT:"EDCL",ST=12&'EXDT:"ECL",ST>12&(ST'=16):"L",ST=16:"DL",1:"DHPEATCL") - .D GET^PSOORNE5 S PSOACT=PSOACT_$S(ACTREN:"N",1:""),PSOACT=PSOACT_$S(ACTREF:"R",1:"") - .I ST=5 S SURX=$O(^PS(52.5,"B",RXN,0)) I SURX,$P($G(^PS(52.5,SURX,0)),"^",7)="L" S PSOACT="TL" K SURX Q - .S:ST'=12&('$D(^PS(50.7,+$P(RXOR,"^"),0))) PSOACT="DL",VALMSG="No Pharmacy Orderable Item !",PSONACT=1 - .S:ST=12&('$D(^PS(50.7,+$P(RXOR,"^"),0))) PSOACT="L",VALMSG="No Pharmacy Orderable Item !",PSONACT=1 - .I ST=14!(ST=15) S VALMSG="Rx Discontinued By "_$S(ST=14:"Provider",1:"Edit")_". Cannot be Reinstated." - .S:ST=16 VALMSG="Rx Placed on HOLD by Provider." - E D - .I ST=5 S SURX=$O(^PS(52.5,"B",RXN,0)) I SURX,$P($G(^PS(52.5,SURX,0)),"^",7)="L" S PSOACT="TL" Q - .S PSOACT=$S(ST'<1&(ST'>4)!(ST>12):"",ST=12&EXDT&($P($G(PSOPAR),"^",2)):"CDPLT",1:"CPLT") - .D GET^PSOORNE5 S PSOACT=PSOACT_$S(ACTREN:"N",1:""),PSOACT=PSOACT_$S(ACTREF:"R",1:"") - .S:'$D(^PS(50.7,+$P(RXOR,"^"),0)) PSOACT="L",PSONACT=1,VALMSG="No Pharmacy Orderable Item !" - ;K PSOLKFL D PSOL^PSSLOCK(RXN) I '$G(PSOMSG) K PSOMSG S PSOLKFL=1 S PSOACT="",VALMSG="This Order is being edited by another user." - K PSOMSG S IEN=0,$P(RN," ",12)=" " - I $G(RPH),ST=1,$P($G(^PSRX(RXN,"PKI")),"^") N PKI,PKI1,PKIR,PKIE,DA S DA=RXN D CER^PSOPKIV1 K DA D:$G(PKI1) L1^PSOPKIV1 - D DIN^PSONFI(+RXOR,$P(RX0,"^",6)) - S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=$S($P($G(^PSRX(RXN,"TPB")),"^"):" TPB Rx #: ",1:" Rx #: ") - S ^TMP("PSOAO",$J,IEN,0)=^TMP("PSOAO",$J,IEN,0)_$P(RX0,"^")_$S($G(^PSRX(RXN,"IB")):"$",1:"")_$$ECME^PSOBPSUT(RXN)_$E(RN,$L($P(RX0,"^")_$S($G(^PSRX(RXN,"IB")):"$",1:"")_$$ECME^PSOBPSUT(RXN))+1,12) - S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" ("_$S($P(PSOPAR,"^",3):1,1:"#")_")"_" *Orderable Item: "_$S($D(^PS(50.7,$P(+RXOR,"^"),0)):$P(^PS(50.7,$P(+RXOR,"^"),0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^"),1:"")_NFIO - S:NFIO["" NFIO=IEN_","_($L(^TMP("PSOAO",$J,IEN,0))-4) - S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" ("_$S($P(PSOPAR,"^",3):2,1:"#")_")"_$S($D(^PSDRUG("AQ",$P(RX0,"^",6))):" CMOP ",1:" ")_"Drug: "_$P(^PSDRUG($P(RX0,"^",6),0),"^")_NFID - S:NFID["" NFID=IEN_","_($L(^TMP("PSOAO",$J,IEN,0))-4) - I $$STATUS^PSOBPSUT(RXN,0)'="",$$RXRLDT^PSOBPSUT(RXN,0) D - . S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" "_$S('$P(PSOPAR,"^",3):"(2)",1:" ")_" NDC: "_$$GETNDC^PSONDCUT(RXN,0) - S:$G(^PSRX(RXN,"TN"))]"" IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" Trade Name: "_$G(^PSRX(RXN,"TN")) - D DOSE^PSOORNE5 - S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" (4)Pat Instructions:" D INS^PSOORNE5 - D PC^PSOORNE5 - S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" SIG:" - I '$P($G(^PSRX(RXN,"SIG")),"^",2) S SIGOK=0 D G PTST - .S X=$P($G(^PSRX(RXN,"SIG")),"^") D SIGONE^PSOHELP S SIG=$E($G(INS1),2,250) - .F SG=1:1:$L(SIG) S:$L(^TMP("PSOAO",$J,IEN,0)_" "_$P(SIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOAO",$J,IEN,0)," ",21)=" " S:$P(SIG," ",SG)'="" ^TMP("PSOAO",$J,IEN,0)=$G(^TMP("PSOAO",$J,IEN,0))_" "_$P(SIG," ",SG) - S SIGOK=1 - F I=0:0 S I=$O(^PSRX(RXN,"SIG1",I)) Q:'I D ;PSO*210 - . S MIG=$P(^PSRX(RXN,"SIG1",I,0),"^") - . D WORDWRAP^PSOUTLA2(MIG,.IEN,$NA(^TMP("PSOAO",$J)),21) - S SIGOK=1 K MIG,SG -PTST S $P(RN," ",25)=" ",PTST=$S($G(^PS(53,+$P(RX0,"^",3),0))]"":$P($G(^PS(53,+$P(RX0,"^",3),0)),"^"),1:""),IEN=IEN+1 - S ^TMP("PSOAO",$J,IEN,0)=" (5) Patient Status: "_PTST_$E(RN,$L(PTST)+1,25) - S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" (6) Issue Date: "_$E($P(RX0,"^",13),4,5)_"/"_$E($P(RX0,"^",13),6,7)_"/"_$E($P(RX0,"^",13),2,3) - S ^TMP("PSOAO",$J,IEN,0)=^TMP("PSOAO",$J,IEN,0)_" (7) Fill Date: "_$E($P(RX2,"^",2),4,5)_"/"_$E($P(RX2,"^",2),6,7)_"/"_$E($P(RX2,"^",2),2,3) - S ROU=$S($P(RX0,"^",11)="W":"Window",1:"Mail") - S REFL=$P(RX0,"^",9),I=0 F S I=$O(^PSRX(RXN,1,I)) Q:'I S REFL=REFL-1,ROU=$S($P(^PSRX(RXN,1,I,0),"^",2)="W":"Window",1:"Mail") - S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" Last Fill Date: "_$E($P(RX3,"^"),4,5)_"/"_$E($P(RX3,"^"),6,7)_"/"_$E($P(RX3,"^"),2,3) - D CMOP^PSOORNE3 - S ^TMP("PSOAO",$J,IEN,0)=^TMP("PSOAO",$J,IEN,0)_" ("_ROU_$S($G(PSOCMOP)]"":", "_PSOCMOP,1:"")_")" K ROU,PSOCMOP - S IEN=IEN+1 I $P(RX2,"^",15) S ^TMP("PSOAO",$J,IEN,0)=" Returned to Stock: "_$E($P(RX2,"^",15),4,5)_"/"_$E($P(RX2,"^",15),6,7)_"/"_$E($P(RX2,"^",15),2,3)_$S($P(RX2,"^",14):" (Reprinted)",1:"") - E S ^TMP("PSOAO",$J,IEN,0)=" Last Release Date: " D - .S RLD=$S($P(RX2,"^",13):$E($P(RX2,"^",13),4,5)_"/"_$E($P(RX2,"^",13),6,7)_"/"_$E($P(RX2,"^",13),2,3),1:"") - .I $O(^PSRX(RXN,1,0)) F I=0:0 S I=$O(^PSRX(RXN,1,I)) Q:'I D - ..I $P(^PSRX(RXN,1,I,0),"^",18) S RLD=$E($P(^(0),"^",18),4,5)_"/"_$E($P(^(0),"^",18),6,7)_"/"_$E($P(^(0),"^",18),2,3) - .S ^TMP("PSOAO",$J,IEN,0)=^TMP("PSOAO",$J,IEN,0)_$S($G(RLD)]"":RLD,1:" ") - S ^TMP("PSOAO",$J,IEN,0)=^TMP("PSOAO",$J,IEN,0)_" (8) Lot #: "_$P($G(RX2),"^",4) - S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" Expires: "_$E($P(RX2,"^",6),4,5)_"/"_$E($P(RX2,"^",6),6,7)_"/"_$E($P(RX2,"^",6),2,3) - S ^TMP("PSOAO",$J,IEN,0)=^TMP("PSOAO",$J,IEN,0)_" MFG: "_$P($G(RX2),"^",8) - S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(9) Days Supply: "_$P(RX0,"^",8)_$S($L($P(RX0,"^",8))=1:" ",1:"") - S ^TMP("PSOAO",$J,IEN,0)=^TMP("PSOAO",$J,IEN,0)_" (10) QTY"_$S($P($G(^PSDRUG($P(RX0,"^",6),660)),"^",8)]"":" ("_$P($G(^PSDRUG($P(RX0,"^",6),660)),"^",8)_")",1:" ( )")_": "_$P(RX0,"^",7) - I $P($G(^PSDRUG($P(RX0,"^",6),5)),"^")]"" D - .S $P(RN," ",79)=" ",IEN=IEN+1 - .S ^TMP("PSOAO",$J,IEN,0)=$E(RN,$L("QTY DSP MSG: "_$P(^PSDRUG($P(RX0,"^",6),5),"^"))+1,79)_"QTY DSP MSG: "_$P(^PSDRUG($P(RX0,"^",6),5),"^") K RN - S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(11) # of Refills: "_$P(RX0,"^",9)_$S($L($P(RX0,"^",9))=1:" ",1:"")_" Remaining: "_REFL - S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(12) Provider: "_$S($D(^VA(200,$P(RX0,"^",4),0)):$P(^VA(200,$P(RX0,"^",4),0),"^"),1:"UNKNOWN") - I $P(RX3,"^",3) S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" Cos-Provider: "_$P(^VA(200,$S($G(PSORX("COSIGNING PROVIDER")):PSORX("COSIGNING PROVIDER"),1:$P(RX3,"^",3)),0),"^") - S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(13) Routing: "_$S($P(RX0,"^",11)="M":"MAIL",1:"WINDOW")_" (14) Copies: "_$S($P(RX0,"^",18):$P(RX0,"^",18),1:1) - S:$P(RX0,"^",11)="W"&($P(PSOPAR,"^",12)) IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" Method of Pickup: "_$G(^PSRX(RXN,"MP")) - S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(15) Clinic: "_$S($D(^SC(+$P(RX0,"^",5),0)):$P(^SC($P(RX0,"^",5),0),"^"),1:"Not on File") - S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(16) Division: "_$S($G(^PS(59,+$P(RX2,"^",9),0))]"":$P(^PS(59,$P(RX2,"^",9),0),"^")_" ("_$P(^(0),"^",6)_")",1:"UNKNOWN") - S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(17) Pharmacist: "_$S($P(RX2,"^",3):$P(^VA(200,$P(RX2,"^",3),0),"^"),1:"") - S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(18) Remarks:" D RMK^PSOORNE3 - S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(19) Counseling: "_$S($P($G(^PSRX(RXN,"PC")),"^"):"YES",1:"NO")_" "_$S($P($G(^PSRX(RXN,"PC")),"^"):"Was Counseling Understood: "_$S($P($G(^PSRX(RXN,"PC")),"^",2):"YES",1:"NO"),1:"") - S:$O(^PSRX(RXN,1,0)) REF=1,IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(20) Refill Data" - I $$STATUS^PSOBPSUT(RXN,0)'="" D - . N DAW S IEN=IEN+1,DAW=$$GETDAW^PSODAWUT(RXN,0) - . S ^TMP("PSOAO",$J,IEN,0)="(21) DAW Code: "_DAW_" - "_$$DAWEXT^PSSDAWUT(DAW) - D DISP^PSOORNE6 - I $G(PSOBEDT),PSOACT["E" S PSOACT="E" - I $G(PSOBEDT),PSOACT'["E" S PSOACT="" - Q:$G(PSORXED)!($G(COPY))!($G(UPMI)) S:$G(PSOBEDT) (PSOEDIT,PSORXED)=1 D ^PSOLMLST ; I '$G(PSOLKFL) D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) - K DRET,SIG - Q -UL1 ; - ;I +PSOLST(ORN)=52 D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) Q - ;I $D(^PS(52.41,$P(PSOLST(ORN),"^",2),0)) D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)_"S") - Q +PSOORNE2 ;BIR/SAB-display finished orders from backdoor ; 9/11/06 10:24am + ;;7.0;OUTPATIENT PHARMACY;**11,21,23,27,32,37,46,84,103,117,131,146,156,210,148,222,238,264**;DEC 1997;Build 19 + ;^PSDRUG( - 221 + ;^YSCL(603.01 - 2697 + ;^PS(50.606 - 2174 + ;^PS(50.7 - 2223 + ;PSO*210 add call to WORDWRAP api + ;$$DAWEXT^PSSDAWUT - 4708 + ; +SEL N ORN,ORD I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!" S VALMBCK="" Q + D K1^PSOORNE6 S DIR("A")="Select Orders by number",DIR(0)="LO^1:"_PSOCNT D ^DIR I $D(DIRUT) D KV^PSOVER1 S VALMBCK="" Q +NEWSEL N ORN,ORD D K2^PSOORNE6 + I +Y S PSOOELSE=1,PSLST=Y K PSOREEDT D + .F ORD=1:1:$L(PSLST,",") Q:$P(PSLST,",",ORD)']"" S ORN=+$P(PSLST,",",ORD) D @$S(+PSOLST(ORN)=52:"ACT",1:"PEN^PSOORNE5") K PSOREEDT,PSOSIGFL,PSONACT,SIGOK,PSOFDR,DRET,SIG,INS1 D UL1 I $G(PSOQUIT) K PSOQUIT Q + K PRC,PHI,RTE I '$G(PSOOELSE) S VALMBCK="" + K PSONACT,PSOOELSE,CLOZPAT D ^PSOBUILD,BLD^PSOORUT1,K3^PSOORNE6 + Q + ; +ACT N REF K ^TMP("PSOAO",$J),PCOMX,PDA,PHI,PRC,ACOM,ANS,PSOFDR,CLOZPAT,ANQREM,DUR,DRET + S RXN=$P(PSOLST(ORN),"^",2),RX0=^PSRX(RXN,0),RX2=$G(^(2)),RX3=$G(^(3)),ST=+$G(^("STA")),RXOR=$G(^("OR1")),POE=$G(^("POE")),EXDT=$S($P($G(^(2)),"^",6)>DT:1,1:0) + I 'RX3 S RX3=$P(RX2,"^",2),$P(^PSRX(RXN,3),"^")=$P(RX2,"^",2) + S PSODRG=+$P(RX0,"^",6),PSODRUG0=^PSDRUG(PSODRG,0),INDT=$G(^("I")) + ;PSO*7*238;SET PSODRUG ARRAY ; PSOY KILLED AT END OF SET^PSODRG + K PSODRUG + S PSOY=PSODRG,PSOY(0)=PSODRUG0 D SET^PSODRG + I 'RXOR,$P(^PSDRUG(PSODRG,2),"^") S $P(^PSRX(RXN,"OR1"),"^")=$P(^PSDRUG(PSODRG,2),"^"),RXOR=$P(^PSDRUG(PSODRG,2),"^") + I $P($G(^PSDRUG(PSODRG,"CLOZ1")),"^")="PSOCLO1" D + .S CLOZPAT=$O(^YSCL(603.01,"C",PSODFN,0)) Q:'CLOZPAT + .;S CLOZPAT=$S($P(^YSCL(603.01,CLOZPAT,0),"^",3)="B":1,1:0) + .S CLOZPAT=$P(^YSCL(603.01,CLOZPAT,0),"^",3) + .S CLOZPAT=$S(CLOZPAT="M":2,CLOZPAT="B":1,1:0) + I $D(^XUSEC("PSORPH",DUZ)) S RPH=1 D + .S PSOACT=$S('ST&($G(INDT)]"")&(DT>$G(INDT)):"DHPLATC",ST=1:"DVE",ST=4:"DV",ST=3:"DU",ST=5:"ELTD",ST=11:"TDPCL",ST=12&EXDT:"DCL",ST=12&'EXDT:"CL",ST>12&(ST'=16):"L",ST=16:"DL",1:"DHPEATCL") + .D GET^PSOORNE5 S PSOACT=PSOACT_$S(ACTREN:"N",1:""),PSOACT=PSOACT_$S(ACTREF:"R",1:"") + .I ST=5 S SURX=$O(^PS(52.5,"B",RXN,0)) I SURX,$P($G(^PS(52.5,SURX,0)),"^",7)="L" S PSOACT="TL" K SURX Q + .S:ST'=12&('$D(^PS(50.7,+$P(RXOR,"^"),0))) PSOACT="DL",VALMSG="No Pharmacy Orderable Item !",PSONACT=1 + .S:ST=12&('$D(^PS(50.7,+$P(RXOR,"^"),0))) PSOACT="L",VALMSG="No Pharmacy Orderable Item !",PSONACT=1 + .I ST=14!(ST=15) S VALMSG="Rx Discontinued By "_$S(ST=14:"Provider",1:"Edit")_". Cannot be Reinstated." + .S:ST=16 VALMSG="Rx Placed on HOLD by Provider." + E D + .I ST=5 S SURX=$O(^PS(52.5,"B",RXN,0)) I SURX,$P($G(^PS(52.5,SURX,0)),"^",7)="L" S PSOACT="TL" Q + .S PSOACT=$S(ST'<1&(ST'>4)!(ST>12):"",ST=12&EXDT&($P($G(PSOPAR),"^",2)):"CDPLT",1:"CPLT") + .D GET^PSOORNE5 S PSOACT=PSOACT_$S(ACTREN:"N",1:""),PSOACT=PSOACT_$S(ACTREF:"R",1:"") + .S:'$D(^PS(50.7,+$P(RXOR,"^"),0)) PSOACT="L",PSONACT=1,VALMSG="No Pharmacy Orderable Item !" + ;K PSOLKFL D PSOL^PSSLOCK(RXN) I '$G(PSOMSG) K PSOMSG S PSOLKFL=1 S PSOACT="",VALMSG="This Order is being edited by another user." + K PSOMSG S IEN=0,$P(RN," ",12)=" " + I $G(RPH),ST=1,$P($G(^PSRX(RXN,"PKI")),"^") N PKI,PKI1,PKIR,PKIE,DA S DA=RXN D CER^PSOPKIV1 K DA D:$G(PKI1) L1^PSOPKIV1 + D DIN^PSONFI(+RXOR,$P(RX0,"^",6)) + S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=$S($P($G(^PSRX(RXN,"TPB")),"^"):" TPB Rx #: ",1:" Rx #: ") + S ^TMP("PSOAO",$J,IEN,0)=^TMP("PSOAO",$J,IEN,0)_$P(RX0,"^")_$S($G(^PSRX(RXN,"IB")):"$",1:"")_$$ECME^PSOBPSUT(RXN)_$E(RN,$L($P(RX0,"^")_$S($G(^PSRX(RXN,"IB")):"$",1:"")_$$ECME^PSOBPSUT(RXN))+1,12) + S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" ("_$S($P(PSOPAR,"^",3):1,1:"#")_")"_" *Orderable Item: "_$S($D(^PS(50.7,$P(+RXOR,"^"),0)):$P(^PS(50.7,$P(+RXOR,"^"),0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^"),1:"")_NFIO + S:NFIO["" NFIO=IEN_","_($L(^TMP("PSOAO",$J,IEN,0))-4) + S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" ("_$S($P(PSOPAR,"^",3):2,1:"#")_")"_$S($D(^PSDRUG("AQ",$P(RX0,"^",6))):" CMOP ",1:" ")_"Drug: "_$P(^PSDRUG($P(RX0,"^",6),0),"^")_NFID + S:NFID["" NFID=IEN_","_($L(^TMP("PSOAO",$J,IEN,0))-4) + I $$STATUS^PSOBPSUT(RXN,0)'="",$$RXRLDT^PSOBPSUT(RXN,0) D + . S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" "_$S('$P(PSOPAR,"^",3):"(2)",1:" ")_" NDC: "_$$GETNDC^PSONDCUT(RXN,0) + S:$G(^PSRX(RXN,"TN"))]"" IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" Trade Name: "_$G(^PSRX(RXN,"TN")) + D DOSE^PSOORNE5 + S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" (4)Pat Instructions:" D INS^PSOORNE5 + D PC^PSOORNE5 + S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" SIG:" + I '$P($G(^PSRX(RXN,"SIG")),"^",2) S SIGOK=0 D G PTST + .S X=$P($G(^PSRX(RXN,"SIG")),"^") D SIGONE^PSOHELP S SIG=$E($G(INS1),2,250) + .F SG=1:1:$L(SIG) S:$L(^TMP("PSOAO",$J,IEN,0)_" "_$P(SIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOAO",$J,IEN,0)," ",21)=" " S:$P(SIG," ",SG)'="" ^TMP("PSOAO",$J,IEN,0)=$G(^TMP("PSOAO",$J,IEN,0))_" "_$P(SIG," ",SG) + S SIGOK=1 + F I=0:0 S I=$O(^PSRX(RXN,"SIG1",I)) Q:'I D ;PSO*210 + . S MIG=$P(^PSRX(RXN,"SIG1",I,0),"^") + . D WORDWRAP^PSOUTLA2(MIG,.IEN,$NA(^TMP("PSOAO",$J)),21) + S SIGOK=1 K MIG,SG +PTST S $P(RN," ",25)=" ",PTST=$S($G(^PS(53,+$P(RX0,"^",3),0))]"":$P($G(^PS(53,+$P(RX0,"^",3),0)),"^"),1:""),IEN=IEN+1 + S ^TMP("PSOAO",$J,IEN,0)=" (5) Patient Status: "_PTST_$E(RN,$L(PTST)+1,25) + S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" (6) Issue Date: "_$E($P(RX0,"^",13),4,5)_"/"_$E($P(RX0,"^",13),6,7)_"/"_$E($P(RX0,"^",13),2,3) + S ^TMP("PSOAO",$J,IEN,0)=^TMP("PSOAO",$J,IEN,0)_" (7) Fill Date: "_$E($P(RX2,"^",2),4,5)_"/"_$E($P(RX2,"^",2),6,7)_"/"_$E($P(RX2,"^",2),2,3) + S ROU=$S($P(RX0,"^",11)="W":"Window",1:"Mail") + S REFL=$P(RX0,"^",9),I=0 F S I=$O(^PSRX(RXN,1,I)) Q:'I S REFL=REFL-1,ROU=$S($P(^PSRX(RXN,1,I,0),"^",2)="W":"Window",1:"Mail") + S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" Last Fill Date: "_$E($P(RX3,"^"),4,5)_"/"_$E($P(RX3,"^"),6,7)_"/"_$E($P(RX3,"^"),2,3) + D CMOP^PSOORNE3 + S ^TMP("PSOAO",$J,IEN,0)=^TMP("PSOAO",$J,IEN,0)_" ("_ROU_$S($G(PSOCMOP)]"":", "_PSOCMOP,1:"")_")" K ROU,PSOCMOP + S IEN=IEN+1 I $P(RX2,"^",15) S ^TMP("PSOAO",$J,IEN,0)=" Returned to Stock: "_$E($P(RX2,"^",15),4,5)_"/"_$E($P(RX2,"^",15),6,7)_"/"_$E($P(RX2,"^",15),2,3)_$S($P(RX2,"^",14):" (Reprinted)",1:"") + E S ^TMP("PSOAO",$J,IEN,0)=" Last Release Date: " D + .S RLD=$S($P(RX2,"^",13):$E($P(RX2,"^",13),4,5)_"/"_$E($P(RX2,"^",13),6,7)_"/"_$E($P(RX2,"^",13),2,3),1:"") + .I $O(^PSRX(RXN,1,0)) F I=0:0 S I=$O(^PSRX(RXN,1,I)) Q:'I D + ..I $P(^PSRX(RXN,1,I,0),"^",18) S RLD=$E($P(^(0),"^",18),4,5)_"/"_$E($P(^(0),"^",18),6,7)_"/"_$E($P(^(0),"^",18),2,3) + .S ^TMP("PSOAO",$J,IEN,0)=^TMP("PSOAO",$J,IEN,0)_$S($G(RLD)]"":RLD,1:" ") + S ^TMP("PSOAO",$J,IEN,0)=^TMP("PSOAO",$J,IEN,0)_" (8) Lot #: "_$P($G(RX2),"^",4) + S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" Expires: "_$E($P(RX2,"^",6),4,5)_"/"_$E($P(RX2,"^",6),6,7)_"/"_$E($P(RX2,"^",6),2,3) + S ^TMP("PSOAO",$J,IEN,0)=^TMP("PSOAO",$J,IEN,0)_" MFG: "_$P($G(RX2),"^",8) + S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(9) Days Supply: "_$P(RX0,"^",8)_$S($L($P(RX0,"^",8))=1:" ",1:"") + S ^TMP("PSOAO",$J,IEN,0)=^TMP("PSOAO",$J,IEN,0)_" (10) QTY"_$S($P($G(^PSDRUG($P(RX0,"^",6),660)),"^",8)]"":" ("_$P($G(^PSDRUG($P(RX0,"^",6),660)),"^",8)_")",1:" ( )")_": "_$P(RX0,"^",7) + I $P($G(^PSDRUG($P(RX0,"^",6),5)),"^")]"" D + .S $P(RN," ",79)=" ",IEN=IEN+1 + .S ^TMP("PSOAO",$J,IEN,0)=$E(RN,$L("QTY DSP MSG: "_$P(^PSDRUG($P(RX0,"^",6),5),"^"))+1,79)_"QTY DSP MSG: "_$P(^PSDRUG($P(RX0,"^",6),5),"^") K RN + S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(11) # of Refills: "_$P(RX0,"^",9)_$S($L($P(RX0,"^",9))=1:" ",1:"")_" Remaining: "_REFL + S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(12) Provider: "_$S($D(^VA(200,$P(RX0,"^",4),0)):$P(^VA(200,$P(RX0,"^",4),0),"^"),1:"UNKNOWN") + I $P(RX3,"^",3) S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" Cos-Provider: "_$P(^VA(200,$S($G(PSORX("COSIGNING PROVIDER")):PSORX("COSIGNING PROVIDER"),1:$P(RX3,"^",3)),0),"^") + S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(13) Routing: "_$S($P(RX0,"^",11)="M":"MAIL",1:"WINDOW")_" (14) Copies: "_$S($P(RX0,"^",18):$P(RX0,"^",18),1:1) + S:$P(RX0,"^",11)="W"&($P(PSOPAR,"^",12)) IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" Method of Pickup: "_$G(^PSRX(RXN,"MP")) + S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(15) Clinic: "_$S($D(^SC(+$P(RX0,"^",5),0)):$P(^SC($P(RX0,"^",5),0),"^"),1:"Not on File") + S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(16) Division: "_$S($G(^PS(59,+$P(RX2,"^",9),0))]"":$P(^PS(59,$P(RX2,"^",9),0),"^")_" ("_$P(^(0),"^",6)_")",1:"UNKNOWN") + S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(17) Pharmacist: "_$S($P(RX2,"^",3):$P(^VA(200,$P(RX2,"^",3),0),"^"),1:"") + S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(18) Remarks:" D RMK^PSOORNE3 + S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(19) Counseling: "_$S($P($G(^PSRX(RXN,"PC")),"^"):"YES",1:"NO")_" "_$S($P($G(^PSRX(RXN,"PC")),"^"):"Was Counseling Understood: "_$S($P($G(^PSRX(RXN,"PC")),"^",2):"YES",1:"NO"),1:"") + S:$O(^PSRX(RXN,1,0)) REF=1,IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)="(20) Refill Data" + I $$STATUS^PSOBPSUT(RXN,0)'="" D + . N DAW S IEN=IEN+1,DAW=$$GETDAW^PSODAWUT(RXN,0) + . S ^TMP("PSOAO",$J,IEN,0)="(21) DAW Code: "_DAW_" - "_$$DAWEXT^PSSDAWUT(DAW) + D DISP^PSOORNE6 + I $G(PSOBEDT),PSOACT["E" S PSOACT="E" + I $G(PSOBEDT),PSOACT'["E" S PSOACT="" + Q:$G(PSORXED)!($G(COPY))!($G(UPMI)) S:$G(PSOBEDT) (PSOEDIT,PSORXED)=1 D ^PSOLMLST ; I '$G(PSOLKFL) D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) + K DRET,SIG + Q +UL1 ; + ;I +PSOLST(ORN)=52 D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) Q + ;I $D(^PS(52.41,$P(PSOLST(ORN),"^",2),0)) D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)_"S") + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNE4.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNE4.m index ec360a0a..d84e5bac 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNE4.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNE4.m @@ -1,125 +1,126 @@ -PSOORNE4 ;BIR/SAB-display renew RXs from backdoor ;07/29/96 - ;;7.0;OUTPATIENT PHARMACY;**11,27,32,36,46,75,96,103,99,117,131,225**;DEC 1997;Build 29 - ;^SC DBIA-10040;^PS(50.7-2223;^PS(50.606-2174;^PS(50.607-2221;^PS(51.2-2226;^PSDRUG-221;^PS(55-2228 -EN(PSONEW) N FLD,LST,VALMCNT -EN1 K PSOQUIT D:$G(PSONEW("ENT"))'>0 I $G(PSORENW("POE"))=1 S PSOREEDT=1 D SV - .S PSOREEDT=1 D SV - .K PSONEW("DOSE"),PSONEW("UNITS"),PSONEW("DOSE ORDERED"),PSONEW("ROUTE") - .K PSONEW("SCHEDULE"),PSONEW("DURATION"),PSONEW("CONJUNCTION"),PSONEW("NOUN"),PSONEW("VERB"),PSOPRC,PSONEW("ODOSE") -RDD D DSPL,^PSOLMRN D:$G(PKI1)=2 DCP^PSOPKIV1 I $G(PSORX("FN")) S VALMBCK="Q" K PSOREEDT Q - G:'$G(PSOQUIT) RDD - Q -EDT D KV^PSOVER1 S DIR("A")="Select Field to Edit by number",DIR(0)="LO^1:"_$S($G(PSOREEDT):10,1:8) - D ^DIR I $D(DTOUT)!($D(DUOUT)) D KV^PSOVER1 S VALMBCK="" Q -EDTSEL S PSOLM=1,(PSONEW("DFLG"),PSONEW("FIELD"),PSONEW3)=0 - I +Y S LST=Y D HLDHDR^PSOLMUTL S PSOEDT=1 D Q:$G(PSODIR("DFLG"))!($G(PSODIR("QFLG"))) - .F FLD=1:1:$L(LST,",") Q:$P(LST,",",FLD)']"" D @(+$P(LST,",",FLD)) Q:$G(PSODIR("DFLG"))!($G(PSODIR("QFLG"))) - E S VALMBCK="" D FULL^VALM1 - Q -ACP I $G(PKI1)=1 D REA^PSOPKIV1 G:$G(PSONEW("QFLG"))=1 PKI - D INST2^PSORENW S PSOFROM1=1 D:$D(^XUSEC("PSORPH",DUZ))!('$P(PSOPAR,"^",2)) VER - K PSOFROM1 -PKI I $G(PSONEW("QFLG")) S POERR("DFLG")=1,VALMBCK="R" K PSONEW2 Q - I PSONEW("ENT")>0,$G(NEWDOSE) K NEWDOSE G EN1 Q - S PSORX("FN")=1 D EN^PSORN52(.PSONEW) - D RNPSOSD^PSOUTIL,ACP1^PSOORNE6,^PSOBUILD S VALMBCK="Q" - Q -VER1(PSONEW) ; -VER S (PSONEW("DFLG"),PSONEW("QFLG"))=0 I PSONEW("ENT")=0 D K PSOORRNW,PSOFROM1 I PSONEW("DFLG")=1 S (PSONEW("QFLG"),POERR("DFLG"))=1 Q - .S (PSOREEDT,PSOORRNW)=1 W !!,"Dosing Instruction Missing!!",! - .S PSONEW("IRXN")=PSONEW("OIRXN") K VALMSG D FULL^VALM1 W !,"Drug: "_PSODRUG("NAME") D - ..I $O(SIG(0)) D Q - ...F I=1:1 Q:$G(SIG(I))']"" W !,SIG(I) - ..I $P($G(^PSRX(PSONEW("OIRXN"),"SIG")),"^")]"" S X=$P(^PSRX(PSONEW("OIRXN"),"SIG"),"^") D SIGONE^PSOHELP W !,$E($G(INS1),2,250) - .K DIRUT W ! D DOSE^PSODIR(.PSONEW) Q:$G(PSONEW("DFLG")) D EN^PSOFSIG(.PSONEW) - .I PSONEW("ENT")>0,$O(SIG(0)) S (SIGOK,NEWDOSE)=1 - .I '$G(SPEED),PSONEW("DFLG")=1 S VALMSG="Renewal Request Cancelled!" W:$G(SPEED) !,"Renewal Request Cancelled!" Q:$G(PSONEW("DFLG")) - .I +$G(PSONEW("ENT"))'>0 K DIRUT Q - .D INS^PSODIR(.PSONEW),EN^PSOFSIG(.PSONEW),SINS^PSODIR(.PSONEW):$G(^PS(55,PSODFN,"LAN")) - .S:'$G(SPEED)&(PSONEW("DFLG")=1) VALMSG="Renewal Request Cancelled!" W:$G(SPEED)&(PSONEW("DFLG")=1) !,"Renewal Request Cancelled!" - .I $G(SPEED),'$G(PSONEW("DFLG")) D KV^PSOVER1 S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR,KV^PSOVER1 K X,Y - I +$G(PSONEW("ENT"))'>0 G VER - D STOP^PSORENW1 I +$G(PSEXDT) D S PSORENW("QFLG")=1 - .S Y=PSORENW("FILL DATE") X ^DD("DD") S VALMSG=Y_" fill date is past expiration date " - .S Y=$P(PSEXDT,"^",2) X ^DD("DD") S VALMSG=VALMSG_Y_"." - Q -DSPL G:$G(PSONEW("ENT"))>0 DSP - S PSONEW("ENT")=0 F I=0:0 S I=$O(^PSRX(PSONEW("OIRXN"),6,I)) Q:'I S DOSE=^PSRX(PSONEW("OIRXN"),6,I,0) D - .S PSONEW("ENT")=PSONEW("ENT")+1,PSONEW("DOSE",PSONEW("ENT"))=$P(DOSE,"^") - .S PSONEW("UNITS",PSONEW("ENT"))=$P(DOSE,"^",3),PSONEW("DOSE ORDERED",PSONEW("ENT"))=$P(DOSE,"^",2),PSONEW("ROUTE",PSONEW("ENT"))=$P(DOSE,"^",7) - .S PSONEW("SCHEDULE",PSONEW("ENT"))=$P(DOSE,"^",8),PSONEW("DURATION",PSONEW("ENT"))=$P(DOSE,"^",5),PSONEW("CONJUNCTION",PSONEW("ENT"))=$P(DOSE,"^",6) - .S PSONEW("NOUN",PSONEW("ENT"))=$P(DOSE,"^",4),PSONEW("VERB",PSONEW("ENT"))=$P(DOSE,"^",9) - .I $G(^PSRX(PSONEW("OIRXN"),6,I,1))]"" S PSONEW("ODOSE",PSONEW("ENT"))=^PSRX(PSONEW("OIRXN"),6,I,1) - .K DOSE -DSP D ^PSOORUT2 K ^TMP("PSOPO",$J) S IEN=0 - D:$G(PSONEW("PENDING ORDER")) LMDISP^PSOORFI5(+PSONEW("PENDING ORDER")) - D:$G(PKI1) L1^PSOPKIV1 - D DIN^PSONFI(PSODRUG("OI"),$S($G(PSODRUG("IEN")):PSODRUG("IEN"),1:"")) - S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Rx#: "_PSONEW("NRX #") - I +$G(PSODRUG("OI")) D - .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Orderable Item: "_$P(^PS(50.7,+$G(PSODRUG("OI")),0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^")_NFIO - .S:NFIO["" NFIO=IEN_","_($L(^TMP("PSOPO",$J,IEN,0))-4) - S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" "_$S($D(^PSDRUG("AQ",PSODRUG("IEN"))):" CMOP ",1:" ")_"Drug: "_PSODRUG("NAME")_NFID - S:NFID["" NFID=IEN_","_($L(^TMP("PSOPO",$J,IEN,0))-4) - S:$G(PSONEW("TN"))]"" IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Trade Name: "_$G(PSONEW("TN")) - S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Patient Status: "_$P(PSONEW("PTST NODE"),"^"),PSONEW("PATIENT STATUS")=$P(PSONEW("PTST NODE"),"^") - S (PSOID,Y)=PSONEW("ISSUE DATE") X ^DD("DD") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (1) Issue Date: "_Y - S Y=PSONEW("FILL DATE") X ^DD("DD") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (2) Fill Date: "_Y - I PSONEW("ENT")=0 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=$S($G(PSOREEDT):" (9)",1:" ")_" Dosage:" G PAT - F I=1:1:PSONEW("ENT") D - .I '$G(PSONEW("DOSE ORDERED",I)),$G(PSONEW("VERB",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Verb: "_$G(PSONEW("VERB",I)) - .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=$S($G(PSOREEDT)&(I'>1):" (9)",1:" ")_" Dosage: "_$S($E(PSONEW("DOSE",I),1)="."&($G(PSONEW("DOSE ORDERED",I))):"0",1:"")_PSONEW("DOSE",I) - .S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_$S($G(PSONEW("UNITS",I))]"":" ("_$P(^PS(50.607,PSONEW("UNITS",I),0),"^")_")",1:"") - .I $P($G(^PS(55,PSODFN,"LAN")),"^"),'$G(PSONEW("DOSE ORDERED",I)) D - ..S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Oth. Lang. Dosage: "_$G(PSONEW("ODOSE",I)) - .I $G(PSONEW("DOSE ORDERED",I)),$G(PSONEW("VERB",I))]"" D - ..S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Verb: "_$G(PSONEW("VERB",I)) - ..S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Dispense Units: "_$S($E($G(PSONEW("DOSE ORDERED",I)),1)=".":"0",1:"")_$G(PSONEW("DOSE ORDERED",I)) - ..S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Noun: "_$G(PSONEW("NOUN",I)) - .I $G(PSONEW("ROUTE",I)) S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Route: "_$P(^PS(51.2,PSONEW("ROUTE",I),0),"^") - .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Schedule: "_PSONEW("SCHEDULE",I) - .I $G(PSONEW("DURATION",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Duration: "_$G(PSONEW("DURATION",I)) - .I $G(PSONEW("CONJUNCTION",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Conjunction: "_$S($G(PSONEW("CONJUNCTION",I))="A":"AND",$G(PSONEW("CONJUNCTION",I))="T":"THEN",$G(PSONEW("CONJUNCTION",I))="X":"EXCEPT",1:"") -PAT S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=$S($G(PSOREEDT):" (10)",1:" ")_"Pat Instruction:" D INS2^PSOBKDED - S RXN=PSONEW("OIRXN") D INST1^PSORENW - ;I $O(PRC(0)) D PC1^PSOORNE5 - K RXN S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" SIG:" - I $G(SIGOK),$O(SIG(0)) D K SG,MIG - .F I=0:0 S I=$O(SIG(I)) Q:'I F SG=1:1:$L(SIG(I)) D - ..S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(SIG(I)," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",21)=" " - ..S:$P(SIG(I)," ",SG)'="" ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(SIG(I)," ",SG) - E D - .S X=$S($G(PSONEW("SIG"))]"":PSONEW("SIG"),1:$P($G(^PSRX(PSONEW("OIRXN"),"SIG")),"^")) D SIGONE^PSOHELP S SIG=$E($G(INS1),2,250) - .F SG=1:1:$L(SIG) S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(SIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",21)=" " S:$P(SIG," ",SG)'="" ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(SIG," ",SG) - S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Days Supply: "_PSONEW("DAYS SUPPLY")_$S($L(PSONEW("DAYS SUPPLY"))=1:" ",1:"") - S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" QTY"_$S($G(PSODRUG("UNIT"))]"":" ("_PSODRUG("UNIT")_")",1:" ( )")_": "_PSONEW("QTY") - I $D(^PSDRUG("AQ",PSODRUG("IEN"))),$P($G(^PSDRUG(PSODRUG("IEN"),5)),"^")]"" D - .S $P(RN," ",79)=" ",IEN=IEN+1 - .S ^TMP("PSOPO",$J,IEN,0)=" QTY DSP MSG: "_$P(^PSDRUG(PSODRUG("IEN"),5),"^") - S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (3) # of Refills: "_PSONEW("# OF REFILLS")_$S($L(PSONEW("# OF REFILLS"))=1:" ",1:"") - S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (4) Routing: "_$S($G(PSORENW("MAIL/WINDOW"))["W":"WINDOW",1:"MAIL") - S:$G(PSONEW("METHOD OF PICK-UP"))]""&($P(PSOPAR,"^",12)) IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Method of Pickup: "_PSONEW("METHOD OF PICK-UP") - S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (5) Clinic: "_$S($G(PSONEW("CLINIC")):$P(^SC(PSONEW("CLINIC"),0),"^"),1:"") - S $P(RN," ",31)=" ",IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (6) Provider: "_PSONEW("PROVIDER NAME")_$E(RN,$L(PSONEW("PROVIDER NAME"))+1,31) K RN - I $G(PSONEW("COSIGNING PROVIDER"))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Cos-Provider: "_$P(^VA(200,PSONEW("COSIGNING PROVIDER"),0),"^") - S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (7) Copies: "_$S($G(PSONEW("COPIES")):PSONEW("COPIES"),1:1) -RMK S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (8) Remarks: "_$S($G(PSONEW("REMARKS"))]"":PSONEW("REMARKS"),1:"") - S $P(RN," ",35)=" ",IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Entry By: "_$P(^VA(200,DUZ,0),"^")_$E(RN,$L($P(^VA(200,DUZ,0),"^"))+1,35) - I $G(PSOFDR) S ^TMP("PSOPO",$J,IEN,0)=" Entry By: "_$P(^VA(200,$P(OR0,"^",4),0),"^")_$E(RN,$L($P(^VA(200,$P(OR0,"^",4),0),"^"))+1,35) - D NOW^%DTC S PSONEW("LOGIN DATE")=$S($P($G(OR0),"^",6):$P($G(OR0),"^",6),1:%) K %,X S Y=PSONEW("LOGIN DATE") X ^DD("DD") - S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"Entry Date: "_$P(Y,"@")_" "_$P(Y,"@",2) K RN - S (VALMCNT,PSOPF)=IEN - Q -1 D 1^PSOBKDED Q -2 D 2^PSOBKDED Q -3 D 9^PSOBKDED Q -4 D 12^PSOBKDED Q -5 D 5^PSOBKDED Q -6 D 4^PSOBKDED Q -7 D 11^PSOBKDED Q -8 D 13^PSOBKDED Q -9 W !!,"Drug: "_PSODRUG("NAME") S PSOORRNW=1 D DOSE1^PSOORED5(.PSONEW) - I $G(PSONEW("DFLG")) S PSODIR("DFLG")=1,VALMBCK="Q" Q - D SV Q -10 D INS^PSODIR(.PSONEW),SINS^PSODIR(.PSONEW) D SV Q -SV D SV^PSOORNE5 Q +PSOORNE4 ;BIR/SAB-display renew RXs from backdoor ;1/27/07 13:28 + ;;7.0;OUTPATIENT PHARMACY;**11,27,32,36,46,75,96,103,99,117,131,208**;DEC 1997;Build 39 + ; Modified from FOIA VISTA, + ; GPL Copyright (C) 2007 WorldVistA + ;^SC DBIA-10040;^PS(50.7-2223;^PS(50.606-2174;^PS(50.607-2221;^PS(51.2-2226;^PSDRUG-221;^PS(55-2228 +EN(PSONEW) N FLD,LST,VALMCNT +EN1 K PSOQUIT D:$G(PSONEW("ENT"))'>0 I $G(PSORENW("POE"))=1 S PSOREEDT=1 D SV + .S PSOREEDT=1 D SV + .K PSONEW("DOSE"),PSONEW("UNITS"),PSONEW("DOSE ORDERED"),PSONEW("ROUTE") + .K PSONEW("SCHEDULE"),PSONEW("DURATION"),PSONEW("CONJUNCTION"),PSONEW("NOUN"),PSONEW("VERB"),PSOPRC,PSONEW("ODOSE") +RDD I $G(PSOAFYN)'="Y" D DSPL,^PSOLMRN D:$G(PKI1)=2 DCP^PSOPKIV1 I $G(PSORX("FN")) S VALMBCK="Q" K PSOREEDT Q ;vfah + I $G(PSOAFYN)="Y" D ACP D:$G(PKI1)=2 DCP^PSOPKIV1 I $G(PSORX("FN")) S VALMBCK="Q" K PSOREEDT Q ;vfah D ACP from D ACP^PSOLMRN above + I $G(PSOAFYN)'="Y" G:'$G(PSOQUIT) RDD ;vfah + Q +EDT D KV^PSOVER1 S DIR("A")="Select Field to Edit by number",DIR(0)="LO^1:"_$S($G(PSOREEDT):10,1:8) + D ^DIR I $D(DTOUT)!($D(DUOUT)) D KV^PSOVER1 S VALMBCK="" Q +EDTSEL S PSOLM=1,(PSONEW("DFLG"),PSONEW("FIELD"),PSONEW3)=0 + I +Y S LST=Y D HLDHDR^PSOLMUTL S PSOEDT=1 D Q:$G(PSODIR("DFLG"))!($G(PSODIR("QFLG"))) + .F FLD=1:1:$L(LST,",") Q:$P(LST,",",FLD)']"" D @(+$P(LST,",",FLD)) Q:$G(PSODIR("DFLG"))!($G(PSODIR("QFLG"))) + E S VALMBCK="" D FULL^VALM1 + Q +ACP I $G(PKI1)=1 D REA^PSOPKIV1 G:$G(PSONEW("QFLG"))=1 PKI + D INST2^PSORENW S PSOFROM1=1 D:$D(^XUSEC("PSORPH",DUZ))!('$P(PSOPAR,"^",2)) VER + K PSOFROM1 +PKI I $G(PSONEW("QFLG")) S POERR("DFLG")=1,VALMBCK="R" K PSONEW2 Q + I PSONEW("ENT")>0,$G(NEWDOSE) K NEWDOSE G EN1 Q + S PSORX("FN")=1 D EN^PSORN52(.PSONEW) + D RNPSOSD^PSOUTIL,ACP1^PSOORNE6,^PSOBUILD S VALMBCK="Q" + Q +VER1(PSONEW) ; +VER S (PSONEW("DFLG"),PSONEW("QFLG"))=0 I PSONEW("ENT")=0 D K PSOORRNW,PSOFROM1 I PSONEW("DFLG")=1 S (PSONEW("QFLG"),POERR("DFLG"))=1 Q + .S (PSOREEDT,PSOORRNW)=1 W !!,"Dosing Instruction Missing!!",! + .S PSONEW("IRXN")=PSONEW("OIRXN") K VALMSG D FULL^VALM1 W !,"Drug: "_PSODRUG("NAME") D + ..I $O(SIG(0)) D Q + ...F I=1:1 Q:$G(SIG(I))']"" W !,SIG(I) + ..I $P($G(^PSRX(PSONEW("OIRXN"),"SIG")),"^")]"" S X=$P(^PSRX(PSONEW("OIRXN"),"SIG"),"^") D SIGONE^PSOHELP W !,$E($G(INS1),2,250) + .K DIRUT W ! D DOSE^PSODIR(.PSONEW) Q:$G(PSONEW("DFLG")) D EN^PSOFSIG(.PSONEW) + .I PSONEW("ENT")>0,$O(SIG(0)) S (SIGOK,NEWDOSE)=1 + .I '$G(SPEED),PSONEW("DFLG")=1 S VALMSG="Renewal Request Cancelled!" W:$G(SPEED) !,"Renewal Request Cancelled!" Q:$G(PSONEW("DFLG")) + .I +$G(PSONEW("ENT"))'>0 K DIRUT Q + .D INS^PSODIR(.PSONEW),EN^PSOFSIG(.PSONEW),SINS^PSODIR(.PSONEW):$G(^PS(55,PSODFN,"LAN")) + .S:'$G(SPEED)&(PSONEW("DFLG")=1) VALMSG="Renewal Request Cancelled!" W:$G(SPEED)&(PSONEW("DFLG")=1) !,"Renewal Request Cancelled!" + .I $G(SPEED),'$G(PSONEW("DFLG")) D KV^PSOVER1 S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR,KV^PSOVER1 K X,Y + I +$G(PSONEW("ENT"))'>0 G VER + D STOP^PSORENW1 I +$G(PSEXDT) D S PSORENW("QFLG")=1 + .S Y=PSORENW("FILL DATE") X ^DD("DD") S VALMSG=Y_" fill date is past expiration date " + .S Y=$P(PSEXDT,"^",2) X ^DD("DD") S VALMSG=VALMSG_Y_"." + Q +DSPL G:$G(PSONEW("ENT"))>0 DSP + S PSONEW("ENT")=0 F I=0:0 S I=$O(^PSRX(PSONEW("OIRXN"),6,I)) Q:'I S DOSE=^PSRX(PSONEW("OIRXN"),6,I,0) D + .S PSONEW("ENT")=PSONEW("ENT")+1,PSONEW("DOSE",PSONEW("ENT"))=$P(DOSE,"^") + .S PSONEW("UNITS",PSONEW("ENT"))=$P(DOSE,"^",3),PSONEW("DOSE ORDERED",PSONEW("ENT"))=$P(DOSE,"^",2),PSONEW("ROUTE",PSONEW("ENT"))=$P(DOSE,"^",7) + .S PSONEW("SCHEDULE",PSONEW("ENT"))=$P(DOSE,"^",8),PSONEW("DURATION",PSONEW("ENT"))=$P(DOSE,"^",5),PSONEW("CONJUNCTION",PSONEW("ENT"))=$P(DOSE,"^",6) + .S PSONEW("NOUN",PSONEW("ENT"))=$P(DOSE,"^",4),PSONEW("VERB",PSONEW("ENT"))=$P(DOSE,"^",9) + .I $G(^PSRX(PSONEW("OIRXN"),6,I,1))]"" S PSONEW("ODOSE",PSONEW("ENT"))=^PSRX(PSONEW("OIRXN"),6,I,1) + .K DOSE +DSP D ^PSOORUT2 K ^TMP("PSOPO",$J) S IEN=0 D:$G(PKI1) L1^PSOPKIV1 + D DIN^PSONFI(PSODRUG("OI"),$S($G(PSODRUG("IEN")):PSODRUG("IEN"),1:"")) + S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Rx#: "_PSONEW("NRX #") + I +$G(PSODRUG("OI")) D + .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Orderable Item: "_$P(^PS(50.7,+$G(PSODRUG("OI")),0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^")_NFIO + .S:NFIO["" NFIO=IEN_","_($L(^TMP("PSOPO",$J,IEN,0))-4) + S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" "_$S($D(^PSDRUG("AQ",PSODRUG("IEN"))):" CMOP ",1:" ")_"Drug: "_PSODRUG("NAME")_NFID + S:NFID["" NFID=IEN_","_($L(^TMP("PSOPO",$J,IEN,0))-4) + S:$G(PSONEW("TN"))]"" IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Trade Name: "_$G(PSONEW("TN")) + S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Patient Status: "_$P(PSONEW("PTST NODE"),"^"),PSONEW("PATIENT STATUS")=$P(PSONEW("PTST NODE"),"^") + S (PSOID,Y)=PSONEW("ISSUE DATE") X ^DD("DD") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (1) Issue Date: "_Y + S Y=PSONEW("FILL DATE") X ^DD("DD") S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (2) Fill Date: "_Y + I PSONEW("ENT")=0 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=$S($G(PSOREEDT):" (9)",1:" ")_" Dosage:" G PAT + F I=1:1:PSONEW("ENT") D + .I '$G(PSONEW("DOSE ORDERED",I)),$G(PSONEW("VERB",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Verb: "_$G(PSONEW("VERB",I)) + .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=$S($G(PSOREEDT)&(I'>1):" (9)",1:" ")_" Dosage: "_$S($E(PSONEW("DOSE",I),1)="."&($G(PSONEW("DOSE ORDERED",I))):"0",1:"")_PSONEW("DOSE",I) + .S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_$S($G(PSONEW("UNITS",I))]"":" ("_$P(^PS(50.607,PSONEW("UNITS",I),0),"^")_")",1:"") + .I $P($G(^PS(55,PSODFN,"LAN")),"^"),'$G(PSONEW("DOSE ORDERED",I)) D + ..S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Oth. Lang. Dosage: "_$G(PSONEW("ODOSE",I)) + .I $G(PSONEW("DOSE ORDERED",I)),$G(PSONEW("VERB",I))]"" D + ..S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Verb: "_$G(PSONEW("VERB",I)) + ..S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Dispense Units: "_$S($E($G(PSONEW("DOSE ORDERED",I)),1)=".":"0",1:"")_$G(PSONEW("DOSE ORDERED",I)) + ..S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Noun: "_$G(PSONEW("NOUN",I)) + .I $G(PSONEW("ROUTE",I)) S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Route: "_$P(^PS(51.2,PSONEW("ROUTE",I),0),"^") + .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Schedule: "_PSONEW("SCHEDULE",I) + .I $G(PSONEW("DURATION",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" *Duration: "_$G(PSONEW("DURATION",I)) + .I $G(PSONEW("CONJUNCTION",I))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Conjunction: "_$S($G(PSONEW("CONJUNCTION",I))="A":"AND",$G(PSONEW("CONJUNCTION",I))="T":"THEN",$G(PSONEW("CONJUNCTION",I))="X":"EXCEPT",1:"") +PAT S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=$S($G(PSOREEDT):" (10)",1:" ")_"Pat Instruction:" D INS2^PSOBKDED + S RXN=PSONEW("OIRXN") D INST1^PSORENW + I $O(PRC(0)) D PC1^PSOORNE5 + K RXN S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" SIG:" + I $G(SIGOK),$O(SIG(0)) D K SG,MIG + .F I=0:0 S I=$O(SIG(I)) Q:'I F SG=1:1:$L(SIG(I)) D + ..S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(SIG(I)," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",21)=" " + ..S:$P(SIG(I)," ",SG)'="" ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(SIG(I)," ",SG) + E D + .S X=$S($G(PSONEW("SIG"))]"":PSONEW("SIG"),1:$P($G(^PSRX(PSONEW("OIRXN"),"SIG")),"^")) D SIGONE^PSOHELP S SIG=$E($G(INS1),2,250) + .F SG=1:1:$L(SIG) S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(SIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",21)=" " S:$P(SIG," ",SG)'="" ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(SIG," ",SG) + S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Days Supply: "_PSONEW("DAYS SUPPLY")_$S($L(PSONEW("DAYS SUPPLY"))=1:" ",1:"") + S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" QTY"_$S($G(PSODRUG("UNIT"))]"":" ("_PSODRUG("UNIT")_")",1:" ( )")_": "_PSONEW("QTY") + I $D(^PSDRUG("AQ",PSODRUG("IEN"))),$P($G(^PSDRUG(PSODRUG("IEN"),5)),"^")]"" D + .S $P(RN," ",79)=" ",IEN=IEN+1 + .S ^TMP("PSOPO",$J,IEN,0)=" QTY DSP MSG: "_$P(^PSDRUG(PSODRUG("IEN"),5),"^") + S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (3) # of Refills: "_PSONEW("# OF REFILLS")_$S($L(PSONEW("# OF REFILLS"))=1:" ",1:"") + S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (4) Routing: "_$S($G(PSORENW("MAIL/WINDOW"))["W":"WINDOW",1:"MAIL") + S:$G(PSONEW("METHOD OF PICK-UP"))]""&($P(PSOPAR,"^",12)) IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Method of Pickup: "_PSONEW("METHOD OF PICK-UP") + S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (5) Clinic: "_$S($G(PSONEW("CLINIC")):$P(^SC(PSONEW("CLINIC"),0),"^"),1:"") + S $P(RN," ",31)=" ",IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (6) Provider: "_PSONEW("PROVIDER NAME")_$E(RN,$L(PSONEW("PROVIDER NAME"))+1,31) K RN + I $G(PSONEW("COSIGNING PROVIDER"))]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Cos-Provider: "_$P(^VA(200,PSONEW("COSIGNING PROVIDER"),0),"^") + S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (7) Copies: "_$S($G(PSONEW("COPIES")):PSONEW("COPIES"),1:1) +RMK S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (8) Remarks: "_$S($G(PSONEW("REMARKS"))]"":PSONEW("REMARKS"),1:"") + S $P(RN," ",35)=" ",IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Entry By: "_$P(^VA(200,DUZ,0),"^")_$E(RN,$L($P(^VA(200,DUZ,0),"^"))+1,35) + I $G(PSOFDR) S ^TMP("PSOPO",$J,IEN,0)=" Entry By: "_$P(^VA(200,$P(OR0,"^",4),0),"^")_$E(RN,$L($P(^VA(200,$P(OR0,"^",4),0),"^"))+1,35) + D NOW^%DTC S PSONEW("LOGIN DATE")=$S($P($G(OR0),"^",6):$P($G(OR0),"^",6),1:%) K %,X S Y=PSONEW("LOGIN DATE") X ^DD("DD") + S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"Entry Date: "_$P(Y,"@")_" "_$P(Y,"@",2) K RN + S (VALMCNT,PSOPF)=IEN + Q +1 D 1^PSOBKDED Q +2 D 2^PSOBKDED Q +3 D 9^PSOBKDED Q +4 D 12^PSOBKDED Q +5 D 5^PSOBKDED Q +6 D 4^PSOBKDED Q +7 D 11^PSOBKDED Q +8 D 13^PSOBKDED Q +9 W !!,"Drug: "_PSODRUG("NAME") S PSOORRNW=1 D DOSE1^PSOORED5(.PSONEW) + I $G(PSONEW("DFLG")) S PSODIR("DFLG")=1,VALMBCK="Q" Q + D SV Q +10 D INS^PSODIR(.PSONEW),SINS^PSODIR(.PSONEW) D SV Q +SV D SV^PSOORNE5 Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNE5.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNE5.m index 5ea08374..748248df 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNE5.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNE5.m @@ -1,130 +1,131 @@ -PSOORNE5 ;BIR/SAB - display orders from backdoor con't ;5/10/07 8:29am - ;;7.0;OUTPATIENT PHARMACY;**11,27,32,46,78,99,117,131,146,171,180,210,222,268,206,225**;DEC 1997;Build 29 - ;External reference to ^PSDRUG supported by DBIA 221 - ;External references L and UL^PSSLOCK supported by DBIA 2789 - ;External reference to ^PS(51.2 supported by DBIA 2226 - ;External reference to ^PS(50.607 supported by DBIA 2221 - ;External reference ^PS(55 supported by DBIA 2228 - ;called from PSOORNE2 - ;PSO*210 add call to WORDWRAP api - ; -PEN ;pending orders - K ^TMP("PSOPO",$J),PSORX("ISSUE DATE"),PSORX("FILL DATE") S ORSV=ORD,ORD=$P(PSOLST(ORN),"^",2) - I $P($G(^PS(52.41,ORD,0)),"^",3)="DC"!($P($G(^(0)),"^",3)="DE") S VALMBCK="R" Q - I $G(PSODFN)'=$P($G(^PS(52.41,ORD,0)),"^",2) S VALMBCK="" Q - I $G(PSOTPBFG) N PSOTPPEN,PSOTPPEX S PSOTPPEN=ORD,PSOTPPEX=0 D VOPNR^PSOTPCAN I PSOTPPEX K PSOTPPEX,PSOTPPEN S VALMBCK="R" Q - K PSOTPPEX,PSOTPPEN - ;I '$G(PSOTPBFG) D DSPL^PSOTPCAN(ORD) - ;S X=PSODFN_";DPT(" D LK^ORX2 I 'Y S VALMSG="Another person is entering orders for this patient.",VALMBCK="" Q - I '$G(PSOFIN) S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient."),VALMBCK="" K PSOPLCK Q - K PSOPLCK ; D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)_"S") I '$G(PSOMSG) S VAMLSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),PSOACT="" K PSOMSG G OK ;VALMBCK="" Q - S PSODRG=+$P($G(^PS(52.41,ORD,0)),"^",9) I $G(^PSDRUG(PSODRG,"I"))]"",DT>$G(^("I")) S VALMSG="This Drug has been Inactivated." - K PSOMSG S PSOACT=$S($D(^XUSEC("PSORPH",DUZ)):"DEFX",'$D(^XUSEC("PSORPH",DUZ))&($P($G(PSOPAR),"^",2)):"F",1:"") -OK S PAT=PSODFN,PSORNSV=ORN,PSORNLT=PSLST D ORD^PSOORFIN S PSLST=PSORNLT,ORD=ORSV,ORN=PSORNSV K ORSV,PSORNSV,PSORNLT,PSODRUG S VALMBCK="R" - K ORCHK,ORDRG,PSOFDR,SIGOK,PSONEW,PSORX("ISSUE DATE"),PSORX("FILL DATE"),PSORX("FN") - K:'$G(MEDP) PAT - D CLEAN^PSOVER1 ;S X=PSODFN_";DPT(" D ULK^ORX2 - I '$G(PSOFIN) D UL^PSSLOCK(PSODFN) - Q -RXNCHK S PSOY=$O(PSONEW("OLD LAST RX#","")) I PSOY="" D AUTO^PSONRXN Q - S PSONRXN("TYPE")=$S('+$G(^PS(59,+PSOSITE,2)):8,PSODRUG("DEA")["A"&(+$G(^PS(59,+PSOSITE,2))):3,1:8) - S PSONEW("QFLG")=0 I PSOY'=PSONRXN("TYPE"),$P($G(PSOPAR),"^",7)=1 D - .S DIE="^PS(59,",DA=PSOSITE,PSOX=PSONEW("OLD LAST RX#",PSOY) - .L +^PS(59,+PSOSITE,PSOY):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) - .S DR=$S(PSOY=8:"2003////"_PSOX,PSOY=3:"1002.1////"_PSOX,1:"2003////"_PSOX) - .D:PSOX<$P(^PS(59,+PSOSITE,PSOY),"^",3) ^DIE K DIE,X,Y L -^PS(59,+PSOSITE,PSOY) - .L +^PS(59,+PSOSITE,PSONRXN("TYPE")):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) - .S PSOX1=^PS(59,+PSOSITE,PSONRXN("TYPE")),PSONRXN("LO")=$P(PSOX1,"^") - .S PSONRXN("HI")=$P(PSOX1,"^",2),PSOI=$P(PSOX1,"^",3),PSONEW("OLD LAST RX#",PSONRXN("TYPE"))=PSOI - .S:PSOIPSONRXN("HI") FATAL^PSONRXN Q:'$D(^PSRX("B",PSOI))!PSONEW("QFLG") - L +^PSRX("B",PSOI):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I $D(^PSRX("B",PSOI))!'$T G LOOP2 - L -^PSRX("B",PSOI) - Q -RDSPL S PSODIR("CS")=0 - F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)="" I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S $P(PSODIR("CS"),"^")=1 S:$E(+PSODRUG("DEA"),DEA)=2 $P(PSODIR("CS"),"^",2)=1 - I $P($G(PSODIR("CS")),"^",2)=1 S (PSONEW("# OF REFILLS"),PSONEW("N# REF"))=0 Q - I '$D(CLOZPAT) I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F")!(PSODRUG("DEA")[1)!(PSODRUG("DEA")[2) S (PSONEW("# OF REFILLS"),PSONEW("N# REF"))=0 Q - I $D(CLOZPAT) S (PSONEW("# OF REFILLS"),PSONEW("N# REF"))=$S($G(CLOZPAT)=2&(PSONEW("DAYS SUPPLY")=14):1,$G(CLOZPAT)=2&(PSONEW("DAYS SUPPLY")=7):3,$G(CLOZPAT)=1&(PSONEW("DAYS SUPPLY")=7):1,1:0) Q - I PSODIR("CS") D - .S PSOX=5,PSOX1=$S($P($G(PSONEW("PTST NODE")),"^",4)>PSOX:PSOX,1:$P($G(PSONEW("PTST NODE")),"^",4)),PSOX=$S(PSOX1=5:PSOX,1:PSOX1) - .S PSOX=$S('PSOX:0,PSONEW("DAYS SUPPLY")=90:1,1:PSOX),PSDY=PSONEW("DAYS SUPPLY"),PSDY1=$S(PSDY<60:5,PSDY'<60&(PSDY'>89):2,PSDY=90:1,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1) - .I PSONEW("# OF REFILLS")>PSOX S (PSONEW("# OF REFILLS"),PSONEW("N# REF"))=PSOX - E D - .S PSOX=11,PSOX1=$S($P($G(PSONEW("PTST NODE")),"^",4)>PSOX:PSOX,1:$P($G(PSONEW("PTST NODE")),"^",4)),PSOX=$S(PSOX1=11:PSOX,1:PSOX1) - .S PSDY=PSONEW("DAYS SUPPLY"),PSDY1=$S(PSDY<60:11,PSDY'<60&(PSDY'>89):5,PSDY=90:3,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1) - .I PSONEW("# OF REFILLS")>PSOX S (PSONEW("# OF REFILLS"),PSONEW("N# REF"))=PSOX - Q -GET ; - I $P(PSODRUG0,"^",3)["2" S (ACTREF,ACTREN)=0 Q - S (ACTREF,ACTREN)=1 - ;refills - I ST S ACTREF=0 - I '$P(PSOPAR,"^",11),$G(^PSDRUG(PSODRG,"I"))]"",DT>$G(^("I")) S ACTREF=0,VALMSG="Inactive Drug, Non Refillable!" - ;I $P($G(^PSDRUG(PSODRG,2)),"^",3)'["O" S ACTREF=0 - S PSORFRM=$P(RX0,"^",9) F PSOJ=0:0 S PSOJ=$O(^PSRX(RXN,1,PSOJ)) Q:'PSOJ S PSORFRM=PSORFRM-1 - S:PSORFRM<0 PSORFRM=0 S:PSORFRM=0 ACTREF=0 - I $G(RXFL(RXN))]"",'$P(PSOPAR,"^",6) S ACTREF=0 - I $P(PSODRUG0,"^",3)["A"&($P(PSODRUG0,"^",3)'["B")!($P(PSODRUG0,"^",3)["F")!($P(PSODRUG0,"^",3)[1)!($P(PSODRUG0,"^",3)[2) S ACTREF=0 - ;renews - I $P(PSOPAR,"^",4)=0 S ACTREN=0 Q - I $P($G(^PSDRUG(PSODRG,2)),"^",3)'["O" S ACTREN=0 - I $G(^PSDRUG(PSODRG,"I"))]"",DT>$G(^("I")) S ACTREN=0,VALMSG="This Drug has been Inactivated." - I '$P($G(^PSDRUG(PSODRG,2)),"^"),'$P($G(^PSRX(RXN,"OR1")),"^") S ACTREN=0,VALMSG="Drug must be Matched to an Orderable Item!" - I ($P(PSODRUG0,"^",3)["W")!($P(PSODRUG0,"^",3)[1)!($P(PSODRUG0,"^",3)[2) S ACTREN=0 - I $D(^PS(53,+$P(RX0,"^",3),0)),'$P(^(0),"^",5) S ACTREN=0 - S PSOLC=$P(RX0,"^"),PSOLC=$E(PSOLC,$L(PSOLC)) I $A(PSOLC)'<90 S ACTREN=0 - I ST,ST'=2,ST'=5,ST'=6,ST'=11,ST'=12 S ACTREN=0 - K PSORFRM,PSOLC,PSODRG,PSODRUG0 - Q -INST ;formats instruction from front door - D INST^PSOORNE6 Q -PC ;displays provider comments - D PC^PSOORNE6 Q -INST1 ;formats instruction from front door - D INST1^PSOORNE6 Q -PC1 ;displays provider comments - D PC1^PSOORNE6 Q -DOSE ;displays dosing instruction for both simple and complex backdoor Rxs. - I '$O(^PSRX(RXN,6,0)) S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" (3) Dosage: " Q - S DS=1 F I=0:0 S I=$O(^PSRX(RXN,6,I)) Q:'I S DOSE=^PSRX(RXN,6,I,0) D - .I '$P(DOSE,"^",2),$P(DOSE,"^",9)]"" S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" Verb: "_$P(DOSE,"^",9) - .I $G(DS)=1 S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" (3)" - .D DOSE1 S PSORXED("ENT")=$G(PSORXED("ENT"))+1 - K DOSE,I - Q -DOSE1 ; - I $G(DS)=1 S ^TMP("PSOAO",$J,IEN,0)=^TMP("PSOAO",$J,IEN,0)_" *Dosage: "_$S($E($P(DOSE,"^"),1)="."&($P(DOSE,"^",2)):"0",1:"")_$P(DOSE,"^")_$S($P(DOSE,"^",3)]"":" ("_$P(^PS(50.607,$P(DOSE,"^",3),0),"^")_")",1:"") K DS G DU - S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" *Dosage: "_$S($E($P(DOSE,"^"),1)="."&($P(DOSE,"^",2)):"0",1:"")_$P(DOSE,"^")_$S($P(DOSE,"^",3)]"":" ("_$P(^PS(50.607,$P(DOSE,"^",3),0),"^")_")",1:"") -DU I '$P(DOSE,"^",2),$P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" Oth. Lang. Dosage: "_$G(^PSRX(RXN,6,I,1)) - I $P(DOSE,"^",2),$P(DOSE,"^",9)]"" D - .S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" Verb: "_$P(DOSE,"^",9) - .S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" Dispense Units: "_$S($E($P(DOSE,"^",2),1)=".":"0",1:"")_$P(DOSE,"^",2) - .S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" Noun: "_$P(DOSE,"^",4) - I $P(DOSE,"^",7) S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" *Route: "_$P(^PS(51.2,$P(DOSE,"^",7),0),"^") - S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" *Schedule: "_$P(DOSE,"^",8) - I $P(DOSE,"^",5)]"" D - .S DUR=$S($E($P(DOSE,"^",5),1)'?.N:$E($P(DOSE,"^",5),2,99)_$E($P(DOSE,"^",5),1),1:$P(DOSE,"^",5)) - .S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" *Duration: "_DUR_" ("_$S($P(DOSE,"^",5)["M":"MINUTES",$P(DOSE,"^",5)["H":"HOURS",$P(DOSE,"^",5)["L":"MONTHS",$P(DOSE,"^",5)["W":"WEEKS",1:"DAYS")_")" K DUR - I $P(DOSE,"^",6)]"" S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" *Conjunction: "_$S($P(DOSE,"^",6)="A":"AND",$P(DOSE,"^",6)="T":"THEN",$P(DOSE,"^",6)="X":"EXCEPT",1:"") - Q -INS ;patient instructions ;PSO*210 - I $G(^PSRX(RXN,"INS"))]"",'$O(^PSRX(RXN,"INS1",0)) D K SG G SPINS - .S PSORXED("SIG",1)=^PSRX(RXN,"INS") - .D WORDWRAP^PSOUTLA2(^PSRX(RXN,"INS"),.IEN,$NA(^TMP("PSOAO",$J)),21) - ; - I $O(^PSRX(RXN,"INS1",0)) D - .S T=0 F S T=$O(^PSRX(RXN,"INS1",T)) Q:'T D - .. S (PSORXED("SIG",T),MIG)=^PSRX(RXN,"INS1",T,0) - .. D WORDWRAP^PSOUTLA2(MIG,.IEN,$NA(^TMP("PSOAO",$J)),21) -SPINS K T,SG,MIG - I $P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" Other Pat. Instruc: "_$S($G(^PSRX(RXN,"INSS"))]"":^PSRX(RXN,"INSS"),1:"") - Q -SV S VALMSG="Pre-POE Rx. Please Compare Dosing Fields with SIG!" - Q +PSOORNE5 ;BIR/SAB - display orders from backdoor con't ;5/23/05 1:46pm + ;;7.0;OUTPATIENT PHARMACY;**11,27,32,46,78,99,117,131,146,171,180,210,222,268**;DEC 1997;Build 9 + ;External reference to ^PSDRUG supported by DBIA 221 + ;External references L and UL^PSSLOCK supported by DBIA 2789 + ;External reference to ^PS(51.2 supported by DBIA 2226 + ;External reference to ^PS(50.607 supported by DBIA 2221 + ;External reference ^PS(55 supported by DBIA 2228 + ;called from PSOORNE2 + ;PSO*210 add call to WORDWRAP api + ; +PEN ;pending orders + K ^TMP("PSOPO",$J),PSORX("ISSUE DATE"),PSORX("FILL DATE") S ORSV=ORD,ORD=$P(PSOLST(ORN),"^",2) + I $P($G(^PS(52.41,ORD,0)),"^",3)="DC"!($P($G(^(0)),"^",3)="DE") S VALMBCK="R" Q + I $G(PSODFN)'=$P($G(^PS(52.41,ORD,0)),"^",2) S VALMBCK="" Q + I $G(PSOTPBFG) N PSOTPPEN,PSOTPPEX S PSOTPPEN=ORD,PSOTPPEX=0 D VOPNR^PSOTPCAN I PSOTPPEX K PSOTPPEX,PSOTPPEN S VALMBCK="R" Q + K PSOTPPEX,PSOTPPEN + ;I '$G(PSOTPBFG) D DSPL^PSOTPCAN(ORD) + ;S X=PSODFN_";DPT(" D LK^ORX2 I 'Y S VALMSG="Another person is entering orders for this patient.",VALMBCK="" Q + I '$G(PSOFIN) S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient."),VALMBCK="" K PSOPLCK Q + K PSOPLCK ; D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)_"S") I '$G(PSOMSG) S VAMLSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),PSOACT="" K PSOMSG G OK ;VALMBCK="" Q + S PSODRG=+$P($G(^PS(52.41,ORD,0)),"^",9) I $G(^PSDRUG(PSODRG,"I"))]"",DT>$G(^("I")) S VALMSG="This Drug has been Inactivated." + K PSOMSG S PSOACT=$S($D(^XUSEC("PSORPH",DUZ)):"DEF",'$D(^XUSEC("PSORPH",DUZ))&($P($G(PSOPAR),"^",2)):"F",1:"") +OK S PAT=PSODFN,PSORNSV=ORN,PSORNLT=PSLST D ORD^PSOORFIN S PSLST=PSORNLT,ORD=ORSV,ORN=PSORNSV K ORSV,PSORNSV,PSORNLT,PSODRUG S VALMBCK="R" + K ORCHK,ORDRG,PSOFDR,SIGOK,PSONEW,PSORX("ISSUE DATE"),PSORX("FILL DATE"),PSORX("FN") + K:'$G(MEDP) PAT + D CLEAN^PSOVER1 ;S X=PSODFN_";DPT(" D ULK^ORX2 + I '$G(PSOFIN) D UL^PSSLOCK(PSODFN) + Q +RXNCHK S PSOY=$O(PSONEW("OLD LAST RX#","")) I PSOY="" D AUTO^PSONRXN Q + S PSONRXN("TYPE")=$S('+$G(^PS(59,+PSOSITE,2)):8,PSODRUG("DEA")["A"&(+$G(^PS(59,+PSOSITE,2))):3,1:8) + S PSONEW("QFLG")=0 I PSOY'=PSONRXN("TYPE"),$P($G(PSOPAR),"^",7)=1 D + .S DIE="^PS(59,",DA=PSOSITE,PSOX=PSONEW("OLD LAST RX#",PSOY) + .L +^PS(59,+PSOSITE,PSOY):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) + .S DR=$S(PSOY=8:"2003////"_PSOX,PSOY=3:"1002.1////"_PSOX,1:"2003////"_PSOX) + .D:PSOX<$P(^PS(59,+PSOSITE,PSOY),"^",3) ^DIE K DIE,X,Y L -^PS(59,+PSOSITE,PSOY) + .L +^PS(59,+PSOSITE,PSONRXN("TYPE")):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) + .S PSOX1=^PS(59,+PSOSITE,PSONRXN("TYPE")),PSONRXN("LO")=$P(PSOX1,"^") + .S PSONRXN("HI")=$P(PSOX1,"^",2),PSOI=$P(PSOX1,"^",3),PSONEW("OLD LAST RX#",PSONRXN("TYPE"))=PSOI + .S:PSOIPSONRXN("HI") FATAL^PSONRXN Q:'$D(^PSRX("B",PSOI))!PSONEW("QFLG") + L +^PSRX("B",PSOI):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I $D(^PSRX("B",PSOI))!'$T G LOOP2 + L -^PSRX("B",PSOI) + Q +RDSPL S PSODIR("CS")=0 + F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)="" I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S $P(PSODIR("CS"),"^")=1 S:$E(+PSODRUG("DEA"),DEA)=2 $P(PSODIR("CS"),"^",2)=1 + I $P($G(PSODIR("CS")),"^",2)=1 S (PSONEW("# OF REFILLS"),PSONEW("N# REF"))=0 Q + I '$D(CLOZPAT) I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F") S (PSONEW("# OF REFILLS"),PSONEW("N# REF"))=0 Q + I $D(CLOZPAT) S (PSONEW("# OF REFILLS"),PSONEW("N# REF"))=$S($G(CLOZPAT)=2&(PSONEW("DAYS SUPPLY")=14):1,$G(CLOZPAT)=2&(PSONEW("DAYS SUPPLY")=7):3,$G(CLOZPAT)=1&(PSONEW("DAYS SUPPLY")=7):1,1:0) Q + I PSODIR("CS") D + .S PSOX=5,PSOX1=$S($P($G(PSONEW("PTST NODE")),"^",4)>PSOX:PSOX,1:$P($G(PSONEW("PTST NODE")),"^",4)),PSOX=$S(PSOX1=5:PSOX,1:PSOX1) + .S PSOX=$S('PSOX:0,PSONEW("DAYS SUPPLY")=90:1,1:PSOX),PSDY=PSONEW("DAYS SUPPLY"),PSDY1=$S(PSDY<60:5,PSDY'<60&(PSDY'>89):2,PSDY=90:1,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1) + .I PSONEW("# OF REFILLS")>PSOX S (PSONEW("# OF REFILLS"),PSONEW("N# REF"))=PSOX + E D + .S PSOX=11,PSOX1=$S($P($G(PSONEW("PTST NODE")),"^",4)>PSOX:PSOX,1:$P($G(PSONEW("PTST NODE")),"^",4)),PSOX=$S(PSOX1=11:PSOX,1:PSOX1) + .S PSDY=PSONEW("DAYS SUPPLY"),PSDY1=$S(PSDY<60:11,PSDY'<60&(PSDY'>89):5,PSDY=90:3,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1) + .I PSONEW("# OF REFILLS")>PSOX S (PSONEW("# OF REFILLS"),PSONEW("N# REF"))=PSOX + Q +GET ; + I $P(PSODRUG0,"^",3)["2" S (ACTREF,ACTREN)=0 Q + S (ACTREF,ACTREN)=1 + ;refills + I ST S ACTREF=0 + I '$P(PSOPAR,"^",11),$G(^PSDRUG(PSODRG,"I"))]"",DT>$G(^("I")) S ACTREF=0,VALMSG="Inactive Drug, Non Refillable!" + ;I $P($G(^PSDRUG(PSODRG,2)),"^",3)'["O" S ACTREF=0 + S PSORFRM=$P(RX0,"^",9) F PSOJ=0:0 S PSOJ=$O(^PSRX(RXN,1,PSOJ)) Q:'PSOJ S PSORFRM=PSORFRM-1 + S:PSORFRM<0 PSORFRM=0 S:PSORFRM=0 ACTREF=0 + I $G(RXFL(RXN))]"",'$P(PSOPAR,"^",6) S ACTREF=0 + I $P(PSODRUG0,"^",3)["A"&($P(PSODRUG0,"^",3)'["B")!($P(PSODRUG0,"^",3)["F") S ACTREF=0 + ;renews + I $P(PSOPAR,"^",4)=0 S ACTREN=0 Q + I $P($G(^PSDRUG(PSODRG,2)),"^",3)'["O" S ACTREN=0 + I $G(^PSDRUG(PSODRG,"I"))]"",DT>$G(^("I")) S ACTREN=0,VALMSG="This Drug has been Inactivated." + I '$P($G(^PSDRUG(PSODRG,2)),"^"),'$P($G(^PSRX(RXN,"OR1")),"^") S ACTREN=0,VALMSG="Drug must be Matched to an Orderable Item!" + I $P(PSODRUG0,"^",3)["A",$P(PSODRUG0,"^",3)'["B" S ACTREN=0 + I $P(PSODRUG0,"^",3)["W" S ACTREN=0 + I $D(^PS(53,+$P(RX0,"^",3),0)),'$P(^(0),"^",5) S ACTREN=0 + S PSOLC=$P(RX0,"^"),PSOLC=$E(PSOLC,$L(PSOLC)) I $A(PSOLC)'<90 S ACTREN=0 + I ST,ST'=2,ST'=5,ST'=6,ST'=11,ST'=12 S ACTREN=0 + K PSORFRM,PSOLC,PSODRG,PSODRUG0 + Q +INST ;formats instruction from front door + D INST^PSOORNE6 Q +PC ;displays provider comments + D PC^PSOORNE6 Q +INST1 ;formats instruction from front door + D INST1^PSOORNE6 Q +PC1 ;displays provider comments + D PC1^PSOORNE6 Q +DOSE ;displays dosing instruction for both simple and complex backdoor Rxs. + I '$O(^PSRX(RXN,6,0)) S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" (3) Dosage: " Q + S DS=1 F I=0:0 S I=$O(^PSRX(RXN,6,I)) Q:'I S DOSE=^PSRX(RXN,6,I,0) D + .I '$P(DOSE,"^",2),$P(DOSE,"^",9)]"" S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" Verb: "_$P(DOSE,"^",9) + .I $G(DS)=1 S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" (3)" + .D DOSE1 S PSORXED("ENT")=$G(PSORXED("ENT"))+1 + K DOSE,I + Q +DOSE1 ; + I $G(DS)=1 S ^TMP("PSOAO",$J,IEN,0)=^TMP("PSOAO",$J,IEN,0)_" *Dosage: "_$S($E($P(DOSE,"^"),1)="."&($P(DOSE,"^",2)):"0",1:"")_$P(DOSE,"^")_$S($P(DOSE,"^",3)]"":" ("_$P(^PS(50.607,$P(DOSE,"^",3),0),"^")_")",1:"") K DS G DU + S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" *Dosage: "_$S($E($P(DOSE,"^"),1)="."&($P(DOSE,"^",2)):"0",1:"")_$P(DOSE,"^")_$S($P(DOSE,"^",3)]"":" ("_$P(^PS(50.607,$P(DOSE,"^",3),0),"^")_")",1:"") +DU I '$P(DOSE,"^",2),$P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" Oth. Lang. Dosage: "_$G(^PSRX(RXN,6,I,1)) + I $P(DOSE,"^",2),$P(DOSE,"^",9)]"" D + .S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" Verb: "_$P(DOSE,"^",9) + .S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" Dispense Units: "_$S($E($P(DOSE,"^",2),1)=".":"0",1:"")_$P(DOSE,"^",2) + .S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" Noun: "_$P(DOSE,"^",4) + I $P(DOSE,"^",7) S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" *Route: "_$P(^PS(51.2,$P(DOSE,"^",7),0),"^") + S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" *Schedule: "_$P(DOSE,"^",8) + I $P(DOSE,"^",5)]"" D + .S DUR=$S($E($P(DOSE,"^",5),1)'?.N:$E($P(DOSE,"^",5),2,99)_$E($P(DOSE,"^",5),1),1:$P(DOSE,"^",5)) + .S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" *Duration: "_DUR_" ("_$S($P(DOSE,"^",5)["M":"MINUTES",$P(DOSE,"^",5)["H":"HOURS",$P(DOSE,"^",5)["L":"MONTHS",$P(DOSE,"^",5)["W":"WEEKS",1:"DAYS")_")" K DUR + I $P(DOSE,"^",6)]"" S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" *Conjunction: "_$S($P(DOSE,"^",6)="A":"AND",$P(DOSE,"^",6)="T":"THEN",$P(DOSE,"^",6)="X":"EXCEPT",1:"") + Q +INS ;patient instructions ;PSO*210 + I $G(^PSRX(RXN,"INS"))]"",'$O(^PSRX(RXN,"INS1",0)) D K SG G SPINS + .S PSORXED("SIG",1)=^PSRX(RXN,"INS") + .D WORDWRAP^PSOUTLA2(^PSRX(RXN,"INS"),.IEN,$NA(^TMP("PSOAO",$J)),21) + ; + I $O(^PSRX(RXN,"INS1",0)) D + .S T=0 F S T=$O(^PSRX(RXN,"INS1",T)) Q:'T D + .. S (PSORXED("SIG",T),MIG)=^PSRX(RXN,"INS1",T,0) + .. D WORDWRAP^PSOUTLA2(MIG,.IEN,$NA(^TMP("PSOAO",$J)),21) +SPINS K T,SG,MIG + I $P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOAO",$J,IEN,0)=" Other Pat. Instruc: "_$S($G(^PSRX(RXN,"INSS"))]"":^PSRX(RXN,"INSS"),1:"") + Q +SV S VALMSG="Pre-POE Rx. Please Compare Dosing Fields with SIG!" + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNEW.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNEW.m index 10a72678..b272c9d8 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNEW.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNEW.m @@ -1,151 +1,151 @@ -PSOORNEW ;BIR/SAB - display orders from oerr ;4/25/07 8:50am - ;;7.0;OUTPATIENT PHARMACY;**11,23,27,32,55,46,71,90,94,106,131,133,143,237,222,258,206,225**;DEC 1997;Build 29 - ;^PS(50.7 -2223 - ;^PSDRUG -221 - ;^PS(50.606 -2174 - ;^PS(55 -2228 - ;EN1^ORCFLAG -3620 - ; - ;PSO*237 quit Finish if Today > Issue date + 365 - ; -DSPL I $G(PSODSPL) S VALMBCK="Q" K PSODSPL,PSOANSQD Q - Q:'$D(PSOLMC) K ^TMP("PSOPO",$J) S PSOLMC=PSOLMC+1 - I $D(CLOZPAT) S PSONEW("DAYS SUPPLY")=$S($G(PSONEW("DAYS SUPPLY")):PSONEW("DAYS SUPPLY"),1:7) G OI - S PSONEW("DAYS SUPPLY")=$S($G(PSONEW("DAYS SUPPLY")):PSONEW("DAYS SUPPLY"),+$G(^PS(55,PSODFN,"PS"))&($P(^PS(53,+$G(^PS(55,PSODFN,"PS")),0),"^",3))&('$G(PSONEW("DAYS SUPPLY"))):$P(^PS(53,+$G(^PS(55,PSODFN,"PS")),0),"^",3),1:30) -OI I '$G(PSODRUG("OI")) D - .S (OI,PSODRUG("OI"))=$P(OR0,"^",8),PSODRUG("OIN")=$P(^PS(50.7,$P(OR0,"^",8),0),"^"),OID=$P(OR0,"^",9) - .I $P($G(OR0),"^",9) S POERR=1,DREN=$P(OR0,"^",9) D DRG^PSOORDRG K POERR - I '$D(CLOZPAT) I $G(PSODRUG("DEA"))["A",$G(PSODRUG("DEA"))'["B"!($G(PSODRUG("DEA"))["F")!($G(PSODRUG("DEA"))[1)!($G(PSODRUG("DEA"))[2) S PSONEW("# OF REFILLS")=0 - I $D(CLOZPAT) S PSONEW("# OF REFILLS")=$S($D(PSONEW("# OF REFILLS")):PSONEW("# OF REFILLS"),$G(CLOZPAT)=2&($P(OR0,"^",11)>2):3,$G(CLOZPAT)&($P(OR0,"^",11)>1):1,1:0) - S IEN=0 D OBX^PSOORFI1,LMDISP^PSOORFI5(ORD),DIN^PSONFI(PSODRUG("OI"),$S($G(PSODRUG("IEN")):PSODRUG("IEN"),1:"")) - S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="*(1) Orderable Item: "_$P(^PS(50.7,PSODRUG("OI"),0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^")_NFIO - S:NFIO["" NFIO=IEN_","_($L(^TMP("PSOPO",$J,IEN,0))-4) - K LST I $G(PSODRUG("NAME"))]"" D G PT - .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (2)"_$S($D(^PSDRUG("AQ",PSODRUG("IEN"))):" CMOP ",1:" ")_"Drug: "_PSODRUG("NAME")_NFID - .S:NFID["" NFID=IEN_","_($L(^TMP("PSOPO",$J,IEN,0))-4) - .I $P($G(^PSDRUG(PSODRUG("IEN"),0)),"^",10)]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Drug Message:" D DRGMSG - S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (2) Drug: No Dispense Drug Selected" -PT D DOSE2^PSOORFI4 - S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (4) Pat Instruct:" D:$O(PSONEW("SIG",0)) INST^PSOORFI4 - S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Provider Comments:" S TY=3 D INST^PSOORFI1 - S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Instructions:" S TY=2 D INST^PSOORFI1 - K PSOELSE S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" SIG:" - F I=0:0 S I=$O(SIG(I)) Q:'I S SIG=SIG(I) D - .F SG=1:1:$L(SIG) S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(SIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " S:$P(SIG," ",SG)'="" ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(SIG," ",SG) - S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (5) Patient Status: "_$P($G(^PS(53,+PSONEW("PATIENT STATUS"),0)),"^") - K PSOELSE I $G(PSONEW("ISSUE DATE"))']"" S PSOELSE=1 S IEN=IEN+1,(PSOID,Y)=$E($P(OR0,"^",6),1,7) X ^DD("DD") S PSONEW("ISSUE DATE")=Y,^TMP("PSOPO",$J,IEN,0)=" (4) Issue Date: "_Y - I '$G(PSOELSE) S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (6) Issue Date: "_PSONEW("ISSUE DATE") - K PSOELSE I $G(PSORX("FILL DATE"))']"" S PSOELSE=1 D - .S (Y,PSORX("FILL DATE"))=$S($E($P(OR0,"^",6),1,7)80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " D - ..S:$P(PSONEW("REMARKS")," ",SG)'="" ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(PSONEW("REMARKS")," ",SG) - I $G(PSOSIGFL)!(PSODRUG("OI")'=$P(OR0,"^",8)) S PSONEW("CLERK CODE")=DUZ,PSORX("CLERK CODE")=$P(^VA(200,DUZ,0),"^"),VALMSG="This change will create a new prescription!" - S $P(RN," ",35)=" ",IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Entry By: "_$P(^VA(200,PSONEW("CLERK CODE"),0),"^")_$E(RN,$L($P(^VA(200,PSONEW("CLERK CODE"),0),"^"))+1,35) - S Y=$P(OR0,"^",12) X ^DD("DD") S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"Entry Date: "_$E($P(OR0,"^",12),4,5)_"/"_$E($P(OR0,"^",12),6,7)_"/"_$E($P(OR0,"^",12),2,3)_" "_$P(Y,"@",2) K RN - I PSOLMC<2 D ^PSOLMPO1 S VALMBCK="Q",PSOLMC=0 - S:PSOLMC>1 VALMBCK="R" - Q -ORCHK D PROVCOM^PSOORFI4,ORCHK^PSOORFI4 - Q -EDT D KV S DIR("A",1)="* Indicates which fields will create an new Order",DIR("A")="Select Field to Edit by number",DIR(0)="LO^1:15" D ^DIR Q:$D(DTOUT)!($D(DUOUT)) -EDTSEL N LST,FLD,OUT D KV S OUT=0 - I +Y S LST=Y D FULL^VALM1 N PSODOSE M PSODOSE=PSONEW D G DSPL - .F FLD=1:1:$L(LST,",") Q:$P(LST,",",FLD)']""!(OUT) D @(+$P(LST,",",FLD)) D:$P(LST,",",FLD)=8 REF D KV - E S VALMBCK="" Q - Q -ACP ; - I $G(ORD),+$P($G(^PS(52.41,+ORD,0)),"^",23)=1 D Q:$D(DIRUT)!'Y D EN1^ORCFLAG(+$P($G(^PS(52.41,ORD,0)),"^")) H 1 - . D FULL^VALM1 D KV - . S DIR("A",1)="This Order is flagged. In order to finish it" - . S DIR("A",2)="you must unflag it first." - . S DIR("A",3)="" - . S DIR(0)="Y",DIR("A")="Unflag Order",DIR("B")="NO" - . W ! D ^DIR I $D(DIRUT)!'Y S VALMBCK="Q" - I $G(ORD),+$P($G(^PS(52.41,+ORD,0)),"^",23)=1 Q - ; - I $D(CLOZPAT),+$G(PSONEW("QTY"))=0 S VALMSG="Unable to calculate the quantity, enter a quantity" G DSPL - S (PSODIR("DFLG"),PSORX("DFLG"),PSODIR("QFLD"))=0,ACP=1 D ORCHK - G:$G(PSONEW("QFLG")) DSPL - I $G(PSODIR("DFLG"))!$G(PSORX("DFLG")) Q - I $G(PSONEW("FLD"))!($G(PSODRUG("NAME"))']"")!('$O(SIG(0))) G DSPL - I $G(PSODRUG("NAME"))]"",'$G(ORCHK)!($G(ORDRG)'=PSODRUG("NAME")) D I $G(PSORX("DFLG")) D CLEAN^PSOVER1 G DSPL - .D POST^PSODRG S:'$G(PSORX("DFLG")) ORCHK=1,ORDRG=PSODRUG("NAME") - I '$D(PSONEW("RX #")) S PSOFROM="NEW",RTN=$S($P($G(PSOPAR),"^",7):"AUTO^PSONRXN",1:"MANUAL^PSONRXN") D @RTN Q:PSONEW("QFLG") I '$P($G(PSOPAR),"^",7) S PSOX=PSONEW("RX #") D CHECK^PSONRXN - D RXNCHK^PSOORNE1 I $G(PSONEW("QFLG")) S PSONEW("DFLG")=1 Q - I DT>$$FMADD^XLFDT($P(OR0,"^",6),365) D EXPR^PSONEW2 G DSPL - D STOP^PSONEW2,DISPLAY^PSONEW2,^PSONEWF - I $G(PSOCPZ("DFLG")) W !!,"No action taken!",! K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR,KV K PSOCPZ("DFLG"),DRET,PSOANSQD S VALMBCK="Q" Q - ; - K PSOCPZ("DFLG") D KV S DIR(0)="Y",DIR("A")="Are you sure you want to Accept this Order",DIR("B")="NO" D ^DIR I $D(DIRUT) D KV K DRET,PSOANSQ,PSOANSQD S VALMBCK="Q" Q - D KV I 'Y K PSOANSQ G DSPL - I $G(PSONEW("MAIL/WINDOW"))["W" D:$P($G(PSOPAR),"^",12) S BINGCRT="Y",BINGRTE="W",PSORX("MAIL/WINDOW")="WINDOW" K RTN - .W ! K DIR,DIRUT S DIR(0)="52,35O" - .S:$G(PSORX("METHOD OF PICK-UP"))]"" DIR("B")=PSORX("METHOD OF PICK-UP") D ^DIR I $D(DIRUT) K DIR,DIRUT Q - .S (PSONEW("METHOD OF PICK-UP"),PSORX("METHOD OF PICK-UP"))=Y K X,Y - S PSONEW("POE")=1 D EN^PSON52(.PSONEW) G:$G(PSONEW("DFLG")) ABORT D DCORD^PSONEW2 - D NPSOSD^PSOUTIL(.PSONEW),FULL^VALM1 K PSORX("MAIL/WINDOW") - D EOJ^PSONEW -ABORT S VALMBCK="Q",DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR,CLEAN^PSOVER1,KV - Q -KV K DIRUT,DUOUT,DTOUT,DIR - Q -REF D REF^PSOORFI4 - Q -1 N PSOBDR,PSOBDRG S PSOBDRG=1 D 1^PSOORNW2 Q ;oi - ; -4 D INS^PSOORNW2 Q - ; -3 D DOSE^PSOORED4(.PSONEW) Q - ; -6 D 4^PSOORNW2 Q ;idt - ; -7 D 5^PSOORNW2 Q ;fdt - ; -5 D 3^PSOORNW2 Q ;pstat - ; -13 D 12^PSOORNW2 Q ;doc - ; -12 D 11^PSOORNW2 Q ;cli - ; -2 N PSOCSIG I '$G(PSOBDRG) N PSOBDR,PSOBDRG S PSOBDRG=1 - D 2^PSOORNW1 Q:$G(PSOQFLG) D EN^PSODIAG ;drg/ICD - I $G(PSOCSIG) K PSOCSIG G 3 - Q - ; -9 D 8^PSOORNW2 Q ;qty - ; -8 D 7^PSOORNW2 Q ;ds - ; -10 D 9^PSOORNW2 Q ;#rfs - ; -14 D 13^PSOORNW2 Q ;cop - ; -11 D 10^PSOORNW2 Q ;m/w - ; -15 D 14^PSOORNW2 Q ;rem - ; -DRGMSG ; - F SG=1:1:$L($P(^PSDRUG(PSODRUG("IEN"),0),"^",10)) S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P($P(^PSDRUG(PSODRUG("IEN"),0),"^",10)," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " D - .S:$P($P(^PSDRUG(PSODRUG("IEN"),0),"^",10)," ",SG)'="" ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P($P(^PSDRUG(PSODRUG("IEN"),0),"^",10)," ",SG) - K SG Q +PSOORNEW ;BIR/SAB - display orders from oerr ;1/27/07 13:29 + ;;7.0;OUTPATIENT PHARMACY;**11,23,27,32,55,46,71,90,94,106,131,133,143,237,222,258,208**;DEC 1997;Build 39 + ; 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. + ; + ;^PS(50.7 -2223 + ;^PSDRUG -221 + ;^PS(50.606 -2174 + ;^PS(55 -2228 + ;PSO*237 quit Finish if Today > Issue date + 365 +DSPL I $G(PSODSPL) S VALMBCK="Q" K PSODSPL,PSOANSQD Q + Q:'$D(PSOLMC) K ^TMP("PSOPO",$J) S PSOLMC=PSOLMC+1 + I $D(CLOZPAT) S PSONEW("DAYS SUPPLY")=$S($G(PSONEW("DAYS SUPPLY")):PSONEW("DAYS SUPPLY"),1:7) G OI + S PSONEW("DAYS SUPPLY")=$S($G(PSONEW("DAYS SUPPLY")):PSONEW("DAYS SUPPLY"),+$G(^PS(55,PSODFN,"PS"))&($P(^PS(53,+$G(^PS(55,PSODFN,"PS")),0),"^",3))&('$G(PSONEW("DAYS SUPPLY"))):$P(^PS(53,+$G(^PS(55,PSODFN,"PS")),0),"^",3),1:30) +OI I '$G(PSODRUG("OI")) D + .S (OI,PSODRUG("OI"))=$P(OR0,"^",8),PSODRUG("OIN")=$P(^PS(50.7,$P(OR0,"^",8),0),"^"),OID=$P(OR0,"^",9) + .I $P($G(OR0),"^",9) S POERR=1,DREN=$P(OR0,"^",9) D DRG^PSOORDRG K POERR + I '$D(CLOZPAT) I $G(PSODRUG("DEA"))["A",$G(PSODRUG("DEA"))'["B"!($G(PSODRUG("DEA"))["F") S PSONEW("# OF REFILLS")=0 + I $D(CLOZPAT) S PSONEW("# OF REFILLS")=$S($D(PSONEW("# OF REFILLS")):PSONEW("# OF REFILLS"),$G(CLOZPAT)=2&($P(OR0,"^",11)>2):3,$G(CLOZPAT)&($P(OR0,"^",11)>1):1,1:0) + S IEN=0 D OBX^PSOORFI1,DIN^PSONFI(PSODRUG("OI"),$S($G(PSODRUG("IEN")):PSODRUG("IEN"),1:"")) + S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="*(1) Orderable Item: "_$P(^PS(50.7,PSODRUG("OI"),0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^")_NFIO + S:NFIO["" NFIO=IEN_","_($L(^TMP("PSOPO",$J,IEN,0))-4) + K LST I $G(PSODRUG("NAME"))]"" D G PT + .S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (2)"_$S($D(^PSDRUG("AQ",PSODRUG("IEN"))):" CMOP ",1:" ")_"Drug: "_PSODRUG("NAME")_NFID + .S:NFID["" NFID=IEN_","_($L(^TMP("PSOPO",$J,IEN,0))-4) + .I $P($G(^PSDRUG(PSODRUG("IEN"),0)),"^",10)]"" S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Drug Message:" D DRGMSG + S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (2) Drug: No Dispense Drug Selected" +PT D DOSE2^PSOORFI4 + S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (4) Pat Instruct:" D:$O(PSONEW("SIG",0)) INST^PSOORFI4 + S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Provider Comments:" S TY=3 D INST^PSOORFI1 + S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Instructions:" S TY=2 D INST^PSOORFI1 + K PSOELSE S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" SIG:" + F I=0:0 S I=$O(SIG(I)) Q:'I S SIG=SIG(I) D + .F SG=1:1:$L(SIG) S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(SIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " S:$P(SIG," ",SG)'="" ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(SIG," ",SG) + S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (5) Patient Status: "_$P($G(^PS(53,+PSONEW("PATIENT STATUS"),0)),"^") + K PSOELSE I $G(PSONEW("ISSUE DATE"))']"" S PSOELSE=1 S IEN=IEN+1,(PSOID,Y)=$E($P(OR0,"^",6),1,7) X ^DD("DD") S PSONEW("ISSUE DATE")=Y,^TMP("PSOPO",$J,IEN,0)=" (4) Issue Date: "_Y + I '$G(PSOELSE) S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" (6) Issue Date: "_PSONEW("ISSUE DATE") + K PSOELSE I $G(PSORX("FILL DATE"))']"" S PSOELSE=1 D + .S (Y,PSORX("FILL DATE"))=$S($E($P(OR0,"^",6),1,7)80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " D + ..S:$P(PSONEW("REMARKS")," ",SG)'="" ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(PSONEW("REMARKS")," ",SG) + I $G(PSOSIGFL)!(PSODRUG("OI")'=$P(OR0,"^",8)) S PSONEW("CLERK CODE")=DUZ,PSORX("CLERK CODE")=$P(^VA(200,DUZ,0),"^"),VALMSG="This change will create a new prescription!" + S $P(RN," ",35)=" ",IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Entry By: "_$P(^VA(200,PSONEW("CLERK CODE"),0),"^")_$E(RN,$L($P(^VA(200,PSONEW("CLERK CODE"),0),"^"))+1,35) + S Y=$P(OR0,"^",12) X ^DD("DD") S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"Entry Date: "_$E($P(OR0,"^",12),4,5)_"/"_$E($P(OR0,"^",12),6,7)_"/"_$E($P(OR0,"^",12),2,3)_" "_$P(Y,"@",2) K RN + I PSOLMC<2 D ^PSOLMPO1 S VALMBCK="Q",PSOLMC=0 + S:PSOLMC>1 VALMBCK="R" + Q +ORCHK D PROVCOM^PSOORFI4 + I $G(PSOAFYN)'="Y" D ORCHK^PSOORFI4 + Q +EDT D KV S DIR("A",1)="* Indicates which fields will create an new Order",DIR("A")="Select Field to Edit by number",DIR(0)="LO^1:15" D ^DIR Q:$D(DTOUT)!($D(DUOUT)) +EDTSEL N LST,FLD,OUT D KV S OUT=0 + I +Y S LST=Y D FULL^VALM1 N PSODOSE M PSODOSE=PSONEW D G DSPL + .F FLD=1:1:$L(LST,",") Q:$P(LST,",",FLD)']""!(OUT) D @(+$P(LST,",",FLD)) D:$P(LST,",",FLD)=8 REF D KV + E S VALMBCK="" Q + Q +ACP ; + I $D(CLOZPAT),+$G(PSONEW("QTY"))=0 S VALMSG="Unable to calculate the quantity, enter a quantity" G DSPL + S (PSODIR("DFLG"),PSORX("DFLG"),PSODIR("QFLD"))=0,ACP=1 D ORCHK + G:$G(PSONEW("QFLG")) DSPL + I $G(PSODIR("DFLG"))!$G(PSORX("DFLG")) Q + I $G(PSONEW("FLD"))!($G(PSODRUG("NAME"))']"")!('$O(SIG(0))) G DSPL + I $G(PSODRUG("NAME"))]"",'$G(ORCHK)!($G(ORDRG)'=PSODRUG("NAME")) D I $G(PSORX("DFLG")) D CLEAN^PSOVER1 G DSPL + .D POST^PSODRG S:'$G(PSORX("DFLG")) ORCHK=1,ORDRG=PSODRUG("NAME") + I '$D(PSONEW("RX #")) S PSOFROM="NEW",RTN=$S($P($G(PSOPAR),"^",7):"AUTO^PSONRXN",1:"MANUAL^PSONRXN") D @RTN Q:PSONEW("QFLG") I '$P($G(PSOPAR),"^",7) S PSOX=PSONEW("RX #") D CHECK^PSONRXN + D RXNCHK^PSOORNE1 I $G(PSONEW("QFLG")) S PSONEW("DFLG")=1 Q + I DT>$$FMADD^XLFDT($P(OR0,"^",6),365) D EXPR^PSONEW2 G DSPL + I $G(PSOAFYN)'="Y" D STOP^PSONEW2,DISPLAY^PSONEW2,^PSONEWF + I $G(PSOAFYN)="Y" D STOP^PSONEW2 + I $G(PSOCPZ("DFLG")) W !!,"No action taken!",! K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR,KV K PSOCPZ("DFLG"),DRET,PSOANSQD S VALMBCK="Q" Q + I $G(PSOAFYN)'="Y" K PSOCPZ("DFLG") D KV S DIR(0)="Y",DIR("A")="Are you sure you want to Accept this Order",DIR("B")="NO" D ^DIR I $D(DIRUT) D KV K DRET,PSOANSQ,PSOANSQD S VALMBCK="Q" Q + I $G(PSOAFYN)="Y" S Y="1" + D KV I 'Y K PSOANSQ G DSPL + I $G(PSONEW("MAIL/WINDOW"))["W" D:$P($G(PSOPAR),"^",12) S BINGCRT="Y",BINGRTE="W",PSORX("MAIL/WINDOW")="WINDOW" K RTN + .I $G(PSOAFYN)'="Y" W ! K DIR,DIRUT S DIR(0)="52,35O" + .I $G(PSOAFYN)'="Y" S:$G(PSORX("METHOD OF PICK-UP"))]"" DIR("B")=PSORX("METHOD OF PICK-UP") D ^DIR I $D(DIRUT) K DIR,DIRUT Q + .I $G(PSOAFYN)'="Y" S (PSONEW("METHOD OF PICK-UP"),PSORX("METHOD OF PICK-UP"))=Y K X,Y + .I $G(PSOAFYN)="Y" S (PSONEW("METHOD OF PICK-UP"),PSORX("METHOD OF PICK-UP"))="AutoFinished for Rx Printing" + S PSONEW("POE")=1 D EN^PSON52(.PSONEW) G:$G(PSONEW("DFLG")) ABORT D DCORD^PSONEW2 + D NPSOSD^PSOUTIL(.PSONEW),FULL^VALM1 K PSORX("MAIL/WINDOW") + D EOJ^PSONEW +ABORT ; + I $G(PSOAFYN)'="Y" S VALMBCK="Q",DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR,CLEAN^PSOVER1,KV ;vfah + I $G(PSOAFYN)="Y" D CLEAN^PSOVER1,KV ;vfah + Q +KV K DIRUT,DUOUT,DTOUT,DIR + Q +REF D REF^PSOORFI4 + Q +1 N PSOBDR,PSOBDRG S PSOBDRG=1 D 1^PSOORNW2 Q ;oi + ; +4 D INS^PSOORNW2 Q + ; +3 D DOSE^PSOORED4(.PSONEW) Q + ; +6 D 4^PSOORNW2 Q ;idt + ; +7 D 5^PSOORNW2 Q ;fdt + ; +5 D 3^PSOORNW2 Q ;pstat + ; +13 D 12^PSOORNW2 Q ;doc + ; +12 D 11^PSOORNW2 Q ;cli + ; +2 N PSOCSIG I '$G(PSOBDRG) N PSOBDR,PSOBDRG S PSOBDRG=1 + D 2^PSOORNW1 Q:$G(PSOQFLG) D EN^PSODIAG ;drg/ICD + I $G(PSOCSIG) K PSOCSIG G 3 + Q + ; +9 D 8^PSOORNW2 Q ;qty + ; +8 D 7^PSOORNW2 Q ;ds + ; +10 D 9^PSOORNW2 Q ;#rfs + ; +14 D 13^PSOORNW2 Q ;cop + ; +11 D 10^PSOORNW2 Q ;m/w + ; +15 D 14^PSOORNW2 Q ;rem + ; +DRGMSG ; + D DRGMSG^PSOORNW2 Q ;vfam + ; diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNW1.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNW1.m index 0d0ad9db..2db6e10c 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNW1.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNW1.m @@ -1,96 +1,96 @@ -PSOORNW1 ;ISC BHAM/SAB - continuation of finish of new order ;5/10/07 8:30am - ;;7.0;OUTPATIENT PHARMACY;**23,46,78,117,131,133,172,148,222,268,206**;DEC 1997;Build 39 - ;Reference ^YSCL(603.01 supported by DBIA 2697 - ;Reference ^PS(55 supported by DBIA 2228 - ;Reference ^PSDRUG( supported by DBIA 221 - ;Reference to $$GETNDC^PSSNDCUT supported by IA 4707 - ; -2 I $G(ORD) W !!,"Instructions: " D - .S INST=0 F S INST=$O(^PS(52.41,ORD,2,INST)) Q:'INST S (MIG,INST(INST))=^PS(52.41,ORD,2,INST,0) D - ..F SG=1:1:$L(MIG," ") W:$X+$L($P(MIG," ",SG)_" ")>IOM !?14 W $P(MIG," ",SG)_" " - .S:'$D(PSODRUG("OI")) PSODRUG("OI")=$P(OR0,"^",8) - .K INST,TY,MIG,SG - S (PSDC,PSI)=0 W !!,"The following Drug(s) are available for selection:" - F PSI=0:0 S PSI=$O(^PSDRUG("ASP",PSODRUG("OI"),PSI)) Q:'PSI I $S('$D(^PSDRUG(PSI,"I")):1,'^("I"):1,DT'>^("I"):1,1:0),$S($P($G(^PSDRUG(PSI,2)),"^",3)'["O":0,1:1) D - .S PSDC=PSDC+1 W !,PSDC_". "_$P(^PSDRUG(PSI,0),"^")_$S($P(^(0),"^",9):" (N/F)",1:"") - .S PSDC(PSDC)=PSI - I PSDC=0 D - . N X,DRG - . S DRG=+$P($G(^PS(52.41,+$G(ORD),0)),"^",9) - . S X=$$GET1^DIQ(50,DRG,100) - . I X'="",(DT>X) D - . . W !!," This Dispense Drug is now Inactive. You may select a" - . . W !," new Orderable Item, or you can enter a new Order with" - . . W !," an Active Drug.",! - . E W !!,"No drugs available!",! - . K DIR S DIR(0)="E",DIR("A")="Press return to continue" - . D ^DIR K DIR - G:'PSDC ETX I $G(PSOBDRG),'$D(PSOBDR) M PSOBDR=PSODRUG - I PSDC'=1 D - .I $P($G(^PSDRUG(+$G(PSODRUG("IEN")),2)),"^")=$G(PSODRUG("OI")) Q - .K PSODRUG("NAME"),PSODRUG("IEN") - W ! D KV S DIR(0)="N^1:"_PSDC,DIR("A")="Select Drug by number" D ^DIR - I $D(DIRUT) S OUT=1 G EX - D KV K PSOY S PSOY=PSDC(Y),PSOY(0)=^PSDRUG(PSOY,0),PSOCSIG=0 - I $G(PSOBDR("IEN")),PSOBDR("IEN")'=+PSOY D:$G(ORD) G:$D(DIRUT) EX - .D KV S DIR(0)="Y",DIR("B")="YES",DIR("A",1)="You have changed the dispense drug from",DIR("A",2)=PSOBDR("NAME")_" to "_$P(^PSDRUG(+PSOY,0),"^")_".",DIR("A")="Do You want to Edit the SIG" - .D ^DIR I $D(DIRUT) S OUT=1 Q - .S:Y PSOCSIG=1 - .I 'Y D URX I $D(DIRUT) S OUT=1 Q - D KV -CT1 I $P($G(^PSDRUG(PSOY,"CLOZ1")),"^")="PSOCLO1",'$O(^YSCL(603.01,"C",PSODFN,0)) S VALMSG="Patient Not Registered in Clozapine Program",VALMBCK="Q" K PSOY,PSDC Q - S PSODRUG("IEN")=+PSOY,PSODRUG("VA CLASS")=$P(PSOY(0),"^",2),PSODRUG("NAME")=$P(PSOY(0),"^") - S PSODRUG("NDF")=$S($G(^PSDRUG(+PSOY,"ND"))]"":+^("ND")_"A"_$P(^("ND"),"^",3),1:0) - S PSODRUG("MAXDOSE")=$P(PSOY(0),"^",4),PSODRUG("DEA")=$P(PSOY(0),"^",3),PSODRUG("CLN")=$S($D(^PSDRUG(+PSOY,"ND")):+$P(^("ND"),"^",6),1:0) - S PSODRUG("SIG")=$P(PSOY(0),"^",5),PSODRUG("NDC")=$$GETNDC^PSSNDCUT(+PSOY,$G(PSOSITE)),PSODRUG("STKLVL")=$G(^PSDRUG(+PSOY,660.1)) - S PSODRUG("DAW")=+$$GET1^DIQ(50,+PSOY,81) - I $G(^PSDRUG(+PSOY,660))']"" D:'$G(PSOFIN)&('$G(PSOCOPY)) POST^PSODRG G ETX - S PSOX1=$G(^PSDRUG(+PSOY,660)),PSODRUG("COST")=$P($G(PSOX1),"^",6),PSODRUG("UNIT")=$P($G(PSOX1),"^",8),PSODRUG("EXPIRATION DATE")=$P($G(PSOX1),"^",9) - D:'$G(PSOFIN)&('$G(PSOCOPY)) POST^PSODRG - I $G(PSORX("DFLG")) K PSODRUG N LST Q:$G(PSOAC)!($G(NEWEDT)) D DSPL^PSOORFI1 S VALMBCK="Q" Q -ETX D REF S VALMBCK="R" I 'PSDC S VALMSG="NO dispense drugs tied to this orderable item!" S PSOQFLG=1 -TX D KV K PSDC,PSI,X,Y,PSOX1,PSOY - Q -EX M PSODRUG=PSOBDR K PSOBDR,PSOBDRG S PSOQFLG=1,VALMBCK="R" D MP1^PSOOREDX - D TX Q -URX D KV S DIR(0)="Y",DIR("A")="Are You Sure You Want to Update Rx",DIR("B")="Yes" - D ^DIR S:$D(DIRUT)!('Y) DIRUT=1 - Q -REF Q:'$D(PSODRUG("DEA"))!('$G(PSODRUG("IEN")))!('$G(^PS(55,PSODFN,"PS"))) - S PSONEW("CS")=0,PTRF=$S(+$G(^PS(55,PSODFN,"PS"))&($P(^PS(53,+$G(^PS(55,PSODFN,"PS")),0),"^",4)]""):$P(^PS(53,+$G(^PS(55,PSODFN,"PS")),0),"^",4),1:5) - F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)="" I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S $P(PSONEW("CS"),"^")=1 S:$E(+PSODRUG("DEA"),DEA)=2 $P(PSONEW("CS"),"^",2)=1 - I $P($G(PSONEW("CS")),"^",2)=1 S PSONEW("# OF REFILLS")=0 Q - I +PSONEW("CS") D - .S PSOX=$S($P($G(OR0),"^",11)>5:5,1:+$P($G(OR0),"^",11)) - .S PSOX=$S(PSOX>PTRF:PTRF,1:PSOX) - .S PSONEW("# OF REFILLS")=PSOX - E D - .S PSOX=$S($P($G(OR0),"^",11)'>PTRF&($P($G(OR0),"^",11)'>11):11,1:PTRF) - I '$D(CLOZPAT) I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F")!(PSODRUG("DEA")[1)!(PSODRUG("DEA")[2) S PSOX=0,PSONEW("# OF REFILLS")=0 K PSDY,PSDY1,PTRF Q - I $D(CLOZPAT) S (PSOX,PSONEW("N# REF"),PSONEW("# OF REFILLS"))=$S(CLOZPAT=2&($G(PSONEW("# OF REFILLS"))>2):3,CLOZPAT&($G(PSONEW("# OF REFILLS"))>1):1,1:0),PSONEW("DAYS SUPPLY")=7,ORCHK=1 K PSDY,PSDY1,PTRF Q - S PSONEW("# OF REFILLS")=$S($G(PSONEW("# OF REFILLS"))'="":$G(PSONEW("# OF REFILLS")),1:PSOX) K PSDY,PSDY1,PTRF - Q -EDNEW K PSMAX,PSFMAX F DEA=1:1 Q:$E(PSODEA,DEA)="" I $E(+PSODEA,DEA)>1,$E(+PSODEA,DEA)<6 S CS=1 - I CS D - .S PSOX1=$S(PTRF>5:5,1:PTRF),PSOX=$S(PSOX1=5:5,1:PSOX1) - .S PSOX=$S('PSOX:0,PSDAYS=90:1,1:PSOX),PSDY1=$S(PSDAYS<60:5,PSDAYS'<60&(PSDAYS'>89):2,PSDAYS=90:1,1:0) S MAX=$S(PSOX'>PSDY1:PSOX,1:PSDY1) - E D - .S PSOX1=PTRF,PSOX=$S(PSOX1=11:11,1:PSOX1),PSOX=$S('PSOX:0,PSDAYS=90:3,1:PSOX) - .S PSDY1=$S(PSDAYS<60:11,PSDAYS'<60&(PSDAYS'>89):5,PSDAYS=90:3,1:0) S MAX=$S(PSOX'>PSDY1:PSOX,1:PSDY1) - I PSRF>MAX D - .W $C(7),!!,PSRF_" refills are not correct for a "_PSDAYS_" day supply.",!,"Please enter correct # of refills for a "_PSDAYS_" day supply. Max refills allowed is "_MAX_".",! - .S (PSMAX("MAX"),PSFMAX("MAX"))=MAX,(PSMAX("RF"),PSFMAX("RF"))=PSRF,(PSMAX("DAYS"),PSFMAX("DAYS"))=PSDAYS,(PSMAX,PSFMAX)=1 - K PSTMAX D EDSTAT - Q -STATDAY K PSMAX,PSRMAX,PSFMAX,PSTMAX S PSDAYS=$P(^PSRX(DA,0),"^",8),PSRF=$P(^PSRX(DA,0),"^",9),PTST=$P(^PS(53,X,0),"^"),PTDY=$P(^(0),"^",3),PTRF=$P(^(0),"^",4) -EDSTAT I PSRF>PTRF W !,$C(7),PSRF_" refills are greater than "_PTRF_" allowed for "_$P(PTST,"^")_" Rx Patient Status.",! S PSTMAX=1,PSTMAX("PTRF")=PTRF,PSTMAX("PSRF")=PSRF,PSTMAX("PT")=$P(PTST,"^") - Q -OERF S DIR(0)="N^0:"_PSOX,DIR("A")="# OF REFILLS" - S DIR("B")=$S($G(POERR):PSONEW("# OF REFILLS"),$G(PSONEW("N# REF"))]"":PSONEW("N# REF"),$G(PSONEW("# OF REFILLS"))]"":PSONEW("# OF REFILLS"),$G(PSOX1)]""&(PSOX>PSOX1):PSOX1,1:PSOX) - S DIR("?")="Enter a whole number. The maximum is set by the Rx Patient Status because there is no Dispense Drug." - D ^DIR G:$D(DIRUT) REFX - S (PSONEW("N# REF"),PSONEW("# OF REFILLS"))=Y -REFX S:'$D(PSONEW("# OF REFILLS")) PSONEW("# OF REFILLS")=$S($G(PSONEW("N# REF"))]"":PSONEW("N# REF"),$G(PSOX1)]""&($G(PSOX)>PSOX1):PSOX1,1:PSOX) - K X,Y,PSOX,PSOX1,PSDY,PSDY1,DEA -KV K DIR,DIRUT,DUOUT,DTOUT - Q +PSOORNW1 ;ISC BHAM/SAB - continuation of finish of new order ;07/19/96 12:58 PM + ;;7.0;OUTPATIENT PHARMACY;**23,46,78,117,131,133,172,148,222,268**;DEC 1997;Build 9 + ;Reference ^YSCL(603.01 supported by DBIA 2697 + ;Reference ^PS(55 supported by DBIA 2228 + ;Reference ^PSDRUG( supported by DBIA 221 + ;Reference to $$GETNDC^PSSNDCUT supported by IA 4707 + ; +2 I $G(ORD) W !!,"Instructions: " D + .S INST=0 F S INST=$O(^PS(52.41,ORD,2,INST)) Q:'INST S (MIG,INST(INST))=^PS(52.41,ORD,2,INST,0) D + ..F SG=1:1:$L(MIG," ") W:$X+$L($P(MIG," ",SG)_" ")>IOM !?14 W $P(MIG," ",SG)_" " + .S:'$D(PSODRUG("OI")) PSODRUG("OI")=$P(OR0,"^",8) + .K INST,TY,MIG,SG + S (PSDC,PSI)=0 W !!,"The following Drug(s) are available for selection:" + F PSI=0:0 S PSI=$O(^PSDRUG("ASP",PSODRUG("OI"),PSI)) Q:'PSI I $S('$D(^PSDRUG(PSI,"I")):1,'^("I"):1,DT'>^("I"):1,1:0),$S($P($G(^PSDRUG(PSI,2)),"^",3)'["O":0,1:1) D + .S PSDC=PSDC+1 W !,PSDC_". "_$P(^PSDRUG(PSI,0),"^")_$S($P(^(0),"^",9):" (N/F)",1:"") + .S PSDC(PSDC)=PSI + I PSDC=0 D + . N X,DRG + . S DRG=+$P($G(^PS(52.41,+$G(ORD),0)),"^",9) + . S X=$$GET1^DIQ(50,DRG,100) + . I X'="",(DT>X) D + . . W !!," This Dispense Drug is now Inactive. You may select a" + . . W !," new Orderable Item, or you can enter a new Order with" + . . W !," an Active Drug.",! + . E W !!,"No drugs available!",! + . K DIR S DIR(0)="E",DIR("A")="Press return to continue" + . D ^DIR K DIR + G:'PSDC ETX I $G(PSOBDRG),'$D(PSOBDR) M PSOBDR=PSODRUG + I PSDC'=1 D + .I $P($G(^PSDRUG(+$G(PSODRUG("IEN")),2)),"^")=$G(PSODRUG("OI")) Q + .K PSODRUG("NAME"),PSODRUG("IEN") + W ! D KV S DIR(0)="N^1:"_PSDC,DIR("A")="Select Drug by number" D ^DIR + I $D(DIRUT) S OUT=1 G EX + D KV K PSOY S PSOY=PSDC(Y),PSOY(0)=^PSDRUG(PSOY,0),PSOCSIG=0 + I $G(PSOBDR("IEN")),PSOBDR("IEN")'=+PSOY D:$G(ORD) G:$D(DIRUT) EX + .D KV S DIR(0)="Y",DIR("B")="YES",DIR("A",1)="You have changed the dispense drug from",DIR("A",2)=PSOBDR("NAME")_" to "_$P(^PSDRUG(+PSOY,0),"^")_".",DIR("A")="Do You want to Edit the SIG" + .D ^DIR I $D(DIRUT) S OUT=1 Q + .S:Y PSOCSIG=1 + .I 'Y D URX I $D(DIRUT) S OUT=1 Q + D KV +CT1 I $P($G(^PSDRUG(PSOY,"CLOZ1")),"^")="PSOCLO1",'$O(^YSCL(603.01,"C",PSODFN,0)) S VALMSG="Patient Not Registered in Clozapine Program",VALMBCK="Q" K PSOY,PSDC Q + S PSODRUG("IEN")=+PSOY,PSODRUG("VA CLASS")=$P(PSOY(0),"^",2),PSODRUG("NAME")=$P(PSOY(0),"^") + S PSODRUG("NDF")=$S($G(^PSDRUG(+PSOY,"ND"))]"":+^("ND")_"A"_$P(^("ND"),"^",3),1:0) + S PSODRUG("MAXDOSE")=$P(PSOY(0),"^",4),PSODRUG("DEA")=$P(PSOY(0),"^",3),PSODRUG("CLN")=$S($D(^PSDRUG(+PSOY,"ND")):+$P(^("ND"),"^",6),1:0) + S PSODRUG("SIG")=$P(PSOY(0),"^",5),PSODRUG("NDC")=$$GETNDC^PSSNDCUT(+PSOY,$G(PSOSITE)),PSODRUG("STKLVL")=$G(^PSDRUG(+PSOY,660.1)) + S PSODRUG("DAW")=+$$GET1^DIQ(50,+PSOY,81) + I $G(^PSDRUG(+PSOY,660))']"" D:'$G(PSOFIN)&('$G(PSOCOPY)) POST^PSODRG G ETX + S PSOX1=$G(^PSDRUG(+PSOY,660)),PSODRUG("COST")=$P($G(PSOX1),"^",6),PSODRUG("UNIT")=$P($G(PSOX1),"^",8),PSODRUG("EXPIRATION DATE")=$P($G(PSOX1),"^",9) + D:'$G(PSOFIN)&('$G(PSOCOPY)) POST^PSODRG + I $G(PSORX("DFLG")) K PSODRUG N LST Q:$G(PSOAC)!($G(NEWEDT)) D DSPL^PSOORFI1 S VALMBCK="Q" Q +ETX D REF S VALMBCK="R" I 'PSDC S VALMSG="NO dispense drugs tied to this orderable item!" S PSOQFLG=1 +TX D KV K PSDC,PSI,X,Y,PSOX1,PSOY + Q +EX M PSODRUG=PSOBDR K PSOBDR,PSOBDRG S PSOQFLG=1,VALMBCK="R" D MP1^PSOOREDX + D TX Q +URX D KV S DIR(0)="Y",DIR("A")="Are You Sure You Want to Update Rx",DIR("B")="Yes" + D ^DIR S:$D(DIRUT)!('Y) DIRUT=1 + Q +REF Q:'$D(PSODRUG("DEA"))!('$G(PSODRUG("IEN")))!('$G(^PS(55,PSODFN,"PS"))) + S PSONEW("CS")=0,PTRF=$S(+$G(^PS(55,PSODFN,"PS"))&($P(^PS(53,+$G(^PS(55,PSODFN,"PS")),0),"^",4)]""):$P(^PS(53,+$G(^PS(55,PSODFN,"PS")),0),"^",4),1:5) + F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)="" I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S $P(PSONEW("CS"),"^")=1 S:$E(+PSODRUG("DEA"),DEA)=2 $P(PSONEW("CS"),"^",2)=1 + I $P($G(PSONEW("CS")),"^",2)=1 S PSONEW("# OF REFILLS")=0 Q + I +PSONEW("CS") D + .S PSOX=$S($P($G(OR0),"^",11)>5:5,1:+$P($G(OR0),"^",11)) + .S PSOX=$S(PSOX>PTRF:PTRF,1:PSOX) + .S PSONEW("# OF REFILLS")=PSOX + E D + .S PSOX=$S($P($G(OR0),"^",11)'>PTRF&($P($G(OR0),"^",11)'>11):11,1:PTRF) + I '$D(CLOZPAT) I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F") S PSOX=0,PSONEW("# OF REFILLS")=0 K PSDY,PSDY1,PTRF Q + I $D(CLOZPAT) S (PSOX,PSONEW("N# REF"),PSONEW("# OF REFILLS"))=$S(CLOZPAT=2&($G(PSONEW("# OF REFILLS"))>2):3,CLOZPAT&($G(PSONEW("# OF REFILLS"))>1):1,1:0),PSONEW("DAYS SUPPLY")=7,ORCHK=1 K PSDY,PSDY1,PTRF Q + S PSONEW("# OF REFILLS")=$S($G(PSONEW("# OF REFILLS"))'="":$G(PSONEW("# OF REFILLS")),1:PSOX) K PSDY,PSDY1,PTRF + Q +EDNEW K PSMAX,PSFMAX F DEA=1:1 Q:$E(PSODEA,DEA)="" I $E(+PSODEA,DEA)>1,$E(+PSODEA,DEA)<6 S CS=1 + I CS D + .S PSOX1=$S(PTRF>5:5,1:PTRF),PSOX=$S(PSOX1=5:5,1:PSOX1) + .S PSOX=$S('PSOX:0,PSDAYS=90:1,1:PSOX),PSDY1=$S(PSDAYS<60:5,PSDAYS'<60&(PSDAYS'>89):2,PSDAYS=90:1,1:0) S MAX=$S(PSOX'>PSDY1:PSOX,1:PSDY1) + E D + .S PSOX1=PTRF,PSOX=$S(PSOX1=11:11,1:PSOX1),PSOX=$S('PSOX:0,PSDAYS=90:3,1:PSOX) + .S PSDY1=$S(PSDAYS<60:11,PSDAYS'<60&(PSDAYS'>89):5,PSDAYS=90:3,1:0) S MAX=$S(PSOX'>PSDY1:PSOX,1:PSDY1) + I PSRF>MAX D + .W $C(7),!!,PSRF_" refills are not correct for a "_PSDAYS_" day supply.",!,"Please enter correct # of refills for a "_PSDAYS_" day supply. Max refills allowed is "_MAX_".",! + .S (PSMAX("MAX"),PSFMAX("MAX"))=MAX,(PSMAX("RF"),PSFMAX("RF"))=PSRF,(PSMAX("DAYS"),PSFMAX("DAYS"))=PSDAYS,(PSMAX,PSFMAX)=1 + K PSTMAX D EDSTAT + Q +STATDAY K PSMAX,PSRMAX,PSFMAX,PSTMAX S PSDAYS=$P(^PSRX(DA,0),"^",8),PSRF=$P(^PSRX(DA,0),"^",9),PTST=$P(^PS(53,X,0),"^"),PTDY=$P(^(0),"^",3),PTRF=$P(^(0),"^",4) +EDSTAT I PSRF>PTRF W !,$C(7),PSRF_" refills are greater than "_PTRF_" allowed for "_$P(PTST,"^")_" Rx Patient Status.",! S PSTMAX=1,PSTMAX("PTRF")=PTRF,PSTMAX("PSRF")=PSRF,PSTMAX("PT")=$P(PTST,"^") + Q +OERF S DIR(0)="N^0:"_PSOX,DIR("A")="# OF REFILLS" + S DIR("B")=$S($G(POERR):PSONEW("# OF REFILLS"),$G(PSONEW("N# REF"))]"":PSONEW("N# REF"),$G(PSONEW("# OF REFILLS"))]"":PSONEW("# OF REFILLS"),$G(PSOX1)]""&(PSOX>PSOX1):PSOX1,1:PSOX) + S DIR("?")="Enter a whole number. The maximum is set by the Rx Patient Status because there is no Dispense Drug." + D ^DIR G:$D(DIRUT) REFX + S (PSONEW("N# REF"),PSONEW("# OF REFILLS"))=Y +REFX S:'$D(PSONEW("# OF REFILLS")) PSONEW("# OF REFILLS")=$S($G(PSONEW("N# REF"))]"":PSONEW("N# REF"),$G(PSOX1)]""&($G(PSOX)>PSOX1):PSOX1,1:PSOX) + K X,Y,PSOX,PSOX1,PSDY,PSDY1,DEA +KV K DIR,DIRUT,DUOUT,DTOUT + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNW2.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNW2.m index 4ed40cee..996b80a3 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNW2.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNW2.m @@ -1,133 +1,126 @@ -PSOORNW2 ;ISC-BHAM/SAB - edit orders from oerr ;9:45 AM 31 Dec 2008 - ;;7.0;OUTPATIENT PHARMACY;**10,23,37,46,117,131,133,148,222,269,206;208**;Build 41;Build 39;WorldVistA 30-Jan-08 - ; - ;Modified from FOIA VISTA, - ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;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 Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - ;Reference to ^YSCL(603.01 supported by DBIA 2697 - ;Reference to ^PS(55 supported by DBIA 2228 - ;Reference to ^PSDRUG( supported by DBIA 221 - ;Reference to ^PS(50.606 supported by DBIA 2174 - ;Reference to ^PS(50.7 supported by DBIA 2223 - ;Reference to $$GETNDC^PSSNDCUT supported by IA 4707 - ; -1 I $G(PSODRUG("OI")) M:$G(PSOBDRG) PSOBDR=PSODRUG W !!,"Current Orderable Item: "_$P(^PS(50.7,PSODRUG("OI"),0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^") - S DIC("B")=$S($G(PSODRUG("OIN"))]"":PSODRUG("OIN"),1:""),DIC="^PS(50.7,",DIC(0)="AEMQZ" - S DIC("S")="I '$P(^PS(50.7,+Y,0),""^"",4)!($P(^(0),""^"",4)'PSONEW("FILL DATE") S PSONEW("FILL DATE")=PSOID,PSORX("FILL DATE")=PSORX("ISSUE DATE") - Q - ; -5 S PSONEW("FLD")=2 D FILLDT^PSODIR2(.PSONEW) ; Fill date - Q - ; -INS S PSONEW("FLD")=114 D INS^PSODIR(.PSONEW) ; Pat Inst - I $P($G(^PS(55,PSODFN,"LAN")),"^") D SINS^PSODIR(.PSONEW) - Q - ; -3 S PSONEW("FLD")=3 D PTSTAT^PSODIR1(.PSONEW) ; Get Patient Status - I +$G(^PS(55,PSODFN,"PS")) S RXPT=+^("PS") I $G(^PS(53,RXPT,0))]"" D Q - .S PSONEW("# OF REFILLS")=$S(+$P(OR0,"^",11)>+$P(^PS(53,RXPT,0),"^",4):+$P(^PS(53,RXPT,0),"^",4),1:+$P(OR0,"^",11)),PSOMAX=+$P(^PS(53,RXPT,0),"^",4) - .S PSOMAX=$S($G(PSOCS):5,1:11),PSOMAX=$S(PSOMAX>+$P(^PS(53,RXPT,0),"^",4):+$P(^PS(53,RXPT,0),"^",4),1:PSOMAX) - .S PSONEW("# OF REFILLS")=$S(PSONEW("# OF REFILLS")>PSOMAX:PSOMAX,1:PSONEW("# OF REFILLS")) - I $G(PSOMAX) S PSONEW("# OF REFILLS")=$S(+$P(OR0,"^",11)>PSOMAX:PSOMAX,1:+$P(OR0,"^",11)) - I $G(PSODRUG("DEA"))["A"&($G(PSODRUG("DEA"))'["B")!($G(PSODRUG("DEA"))["F")!($G(PSODRUG("DEA"))[1)!($G(PSODRUG("DEA"))[2) D - .S PSONEW("# OF REFILLS")=0,VALMSG="No refills allowed on "_$S(PSODRUG("DEA")["A":"this narcotic drug.",1:"this drug.") - Q - ; -12 S PSONEW("FLD")=4 D PROV^PSODIR(.PSONEW) ; Get Provider - Q - ; -11 S PSONEW("FLD")=5 D CLINIC^PSODIR2(.PSONEW) ; Get Clinic - Q - ; -8 S PSONEW("FLD")=7 D QTY^PSODIR1(.PSONEW) ; Get quantity - Q - ; -7 I '$G(PSODRUG("IEN")) W $C(7),!!,"No Dispense Drug!",! K DIR,DUOUT,DIRUT,DTOUT D 2^PSOORNW1 - I '$G(PSODRUG("IEN")) W !,$C(7),"No Dispense Drug Selected! A new Orderable Item may need to be selected.",! Q - S PSONEW("FLD")=8 D DAYS^PSODIR1(.PSONEW) ; Get days supply - Q:'$G(PSONEW("PATIENT STATUS")) - K PSDY,PSDY1,PSMAX,PSTMAX S PSDAYS=PSONEW("DAYS SUPPLY"),PSRF=PSONEW("# OF REFILLS"),PTST=$P(^PS(53,PSONEW("PATIENT STATUS"),0),"^"),PTDY=$P(^(0),"^",3),PTRF=$P(^(0),"^",4),PSODEA=PSODRUG("DEA"),CS=0 ;D EDNEW^PSOORNW1 - Q -9 ; - I '$G(PSONEW("PATIENT STATUS")) W !!,"Rx Patient Status required!",! D 3 I '$G(PSONEW("PATIENT STATUS")) S VALMSG="Rx Patient Status required!",VALMBCK="R" Q - I +$G(^PS(55,PSODFN,"PS")) S RXPT=+^("PS") I $G(^PS(53,RXPT,0))]"" D G ASK - .S PSOMAX=$S($G(CLOZPAT)=2:3,$G(CLOZPAT)=1:1,$G(CLOZPAT)=0:0,1:+$P(^PS(53,RXPT,0),"^",4)) K RXPT - .S:'$G(PSONEW("# OF REFILLS")) PSONEW("# OF REFILLS")=$S(+$P(OR0,"^",11)>PSOMAX:PSOMAX,1:+$P(OR0,"^",11)) - .S (PSONEW("N# REF"),PSONEW("# OF REFILLS"))=$S(PSONEW("# OF REFILLS")>PSOMAX:PSOMAX,1:PSONEW("# OF REFILLS")) - .I '$D(CLOZPAT) I $G(PSODRUG("DEA"))["A"&($G(PSODRUG("DEA"))'["B")!($G(PSODRUG("DEA"))["F")!($G(PSODRUG("DEA"))[1)!($G(PSODRUG("DEA"))[2) D Q - ..S (PSOMAX,PSONEW("N# REF"),PSONEW("# OF REFILLS"))=0,VALMSG="No refills allowed on "_$S(PSODRUG("DEA")["A":"this narcotic drug.",1:"this drug.") - .I $D(PSODRUG("DEA")) F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)="" I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S PSOMAX=5 - I '$D(CLOZPAT) I $G(PSODRUG("DEA"))["A"&($G(PSODRUG("DEA"))'["B")!($G(PSODRUG("DEA"))["F")!($G(PSODRUG("DEA"))[1)!($G(PSODRUG("DEA"))[2) D Q - .S (PSONEW("N# REF"),PSONEW("# OF REFILLS"))=0,VALMSG="No refills allowed on "_$S(PSODRUG("DEA")["A":"this narcotic drug.",1:"this drug.") - S (PSONEW("N# REF"),PSOMAX,PSONEW("# OF REFILLS"))=+$P(OR0,"^",11) -ASK S PSONEW("FLD")=9 D REFILL^PSODIR1(.PSONEW) ; Get # of refills - K PSOMAX,PSMAX,PSTMAX S PSDAYS=PSONEW("DAYS SUPPLY"),PSRF=PSONEW("# OF REFILLS"),PTST=$P(^PS(53,PSONEW("PATIENT STATUS"),0),"^"),PTDY=$P(^(0),"^",3),PTRF=$P(^(0),"^",4),PSODEA=$G(PSODRUG("DEA")),CS=0 D EDNEW^PSOORNW1 - Q - ; -6 Q K DA S PSONEW("FLD")=10 D SIG^PSODIR1(.PSONEW) ; Get sig - I $G(PSONEW("SIG"))]"" D EN^PSOSIGNO(ORD,PSONEW("SIG")) S SIG(1)=PSONEW("SIG") - I $G(PSOSIGFL) D - .K DIRUT,DUOUT,DTOUT,DIR S DIR(0)="Y",DIR("B")="NO",DIR("A",1)="",DIR("A")="This edit will create a new order. Do you want to continue" D ^DIR - .I 'Y!($D(DIRUT)) K DIR,DIRUT,DUOUT,DTOUT,DIC,Y,PSOSIGFL,PSONEW("SIG") S SIGOK=1 - S PSONEW("CLERK CODE")=DUZ K DIR,DIRUT,DUOUT,DTOUT,DIC,Y - Q - ; -13 S PSONEW("FLD")=11 D COPIES^PSODIR1(.PSONEW) ; Get # of copies - Q - ; -10 S PSONEW("FLD")=12 D MW^PSODIR2(.PSONEW) ; Get Mail/Window Info - Q - ; -14 S PSONEW("FLD")=13 D RMK^PSODIR2(.PSONEW) ; Get Remarks - Q - ;WVEHR ;begin p208 - ; -DRGMSG ;From PSOORNEW - F SG=1:1:$L($P(^PSDRUG(PSODRUG("IEN"),0),"^",10)) S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P($P(^PSDRUG(PSODRUG("IEN"),0),"^",10)," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " D - .S:$P($P(^PSDRUG(PSODRUG("IEN"),0),"^",10)," ",SG)'="" ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P($P(^PSDRUG(PSODRUG("IEN"),0),"^",10),"",SG) - K SG Q - ; - ;WVEHR ;end p208 -DREN ; - S (PSDC,PSI)=0 - F S PSI=$O(^PSDRUG("ASP",PSODRUG("OI"),PSI)) Q:'PSI I $S('$D(^PSDRUG(PSI,"I")):1,'^("I"):1,DT'>^("I"):1,1:0),$S($P($G(^PSDRUG(PSI,2)),"^",3)'["O":0,1:1) S PSDC=PSDC+1,PSDC(PSDC)=PSI - I PSDC'=1 D G DRENX - .I $P($G(^PSDRUG(+$G(PSODRUG("IEN")),2)),"^")=$G(PSODRUG("OI")) Q - .K PSODRUG("NAME"),PSODRUG("IEN") - K PSOY S PSI=PSDC(1),PSOY=^PSDRUG(PSI,0) - I $P($G(^PSDRUG(PSI,"CLOZ1")),"^")="PSOCLO1",'$O(^YSCL(603.01,"C",PSODFN,0)) K PSOY,PSI Q - S PSODRUG("IEN")=+PSI,PSODRUG("VA CLASS")=$P(PSOY,"^",2),PSODRUG("NAME")=$P(PSOY,"^") - S PSODRUG("NDF")=$S($G(^PSDRUG(PSI,"ND"))]"":+^("ND")_"A"_$P(^("ND"),"^",3),1:0) - S PSODRUG("MAXDOSE")=$P(PSOY,"^",4),PSODRUG("DEA")=$P(PSOY,"^",3),PSODRUG("CLN")=$S($D(^PSDRUG(+PSI,"ND")):+$P(^("ND"),"^",6),1:0) - S PSODRUG("SIG")=$P(PSOY,"^",5),PSODRUG("NDC")=$$GETNDC^PSSNDCUT(+PSI,$G(PSOSITE)),PSODRUG("STKLVL")=$G(^PSDRUG(+PSI,660.1)) - S PSODRUG("DAW")=+$$GET1^DIQ(50,+PSI,81) - G:$G(^PSDRUG(+PSI,660))']"" DRENX - S PSOX1=$G(^PSDRUG(+PSI,660)),PSODRUG("COST")=$P($G(PSOX1),"^",6),PSODRUG("UNIT")=$P($G(PSOX1),"^",8),PSODRUG("EXPIRATION DATE")=$P($G(PSOX1),"^",9) -DRENX K PSDC,PSI,PSOY,Y,PSOXI,X Q -KV K DIR,DIRUT,DUOUT,DTOUT Q +PSOORNW2 ;ISC-BHAM/SAB - edit orders from oerr ; 12/10/06 9:55pm + ;;7.0;OUTPATIENT PHARMACY;**10,23,37,46,117,131,133,148,222,208**;DEC 1997;Build 39 + ; 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 + ;Reference to ^YSCL(603.01 supported by DBIA 2697 + ;Reference to ^PS(55 supported by DBIA 2228 + ;Reference to ^PSDRUG( supported by DBIA 221 + ;Reference to ^PS(50.606 supported by DBIA 2174 + ;Reference to ^PS(50.7 supported by DBIA 2223 + ;Reference to $$GETNDC^PSSNDCUT supported by IA 4707 + ; +1 I $G(PSODRUG("OI")) M:$G(PSOBDRG) PSOBDR=PSODRUG W !!,"Current Orderable Item: "_$P(^PS(50.7,PSODRUG("OI"),0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^") + S DIC("B")=$S($G(PSODRUG("OIN"))]"":PSODRUG("OIN"),1:""),DIC="^PS(50.7,",DIC(0)="AEMQZ" + S DIC("S")="I '$P(^PS(50.7,+Y,0),""^"",4)!($P(^(0),""^"",4)'PSONEW("FILL DATE") S PSONEW("FILL DATE")=PSOID,PSORX("FILL DATE")=PSORX("ISSUE DATE") + Q + ; +5 S PSONEW("FLD")=2 D FILLDT^PSODIR2(.PSONEW) ; Fill date + Q + ; +INS S PSONEW("FLD")=114 D INS^PSODIR(.PSONEW) ; Pat Inst + I $P($G(^PS(55,PSODFN,"LAN")),"^") D SINS^PSODIR(.PSONEW) + Q + ; +3 S PSONEW("FLD")=3 D PTSTAT^PSODIR1(.PSONEW) ; Get Patient Status + I +$G(^PS(55,PSODFN,"PS")) S RXPT=+^("PS") I $G(^PS(53,RXPT,0))]"" D Q + .S PSONEW("# OF REFILLS")=$S(+$P(OR0,"^",11)>+$P(^PS(53,RXPT,0),"^",4):+$P(^PS(53,RXPT,0),"^",4),1:+$P(OR0,"^",11)),PSOMAX=+$P(^PS(53,RXPT,0),"^",4) + .S PSOMAX=$S($G(PSOCS):5,1:11),PSOMAX=$S(PSOMAX>+$P(^PS(53,RXPT,0),"^",4):+$P(^PS(53,RXPT,0),"^",4),1:PSOMAX) + .S PSONEW("# OF REFILLS")=$S(PSONEW("# OF REFILLS")>PSOMAX:PSOMAX,1:PSONEW("# OF REFILLS")) + I $G(PSOMAX) S PSONEW("# OF REFILLS")=$S(+$P(OR0,"^",11)>PSOMAX:PSOMAX,1:+$P(OR0,"^",11)) + I $G(PSODRUG("DEA"))["A"&($G(PSODRUG("DEA"))'["B")!($G(PSODRUG("DEA"))["F") D + .S PSONEW("# OF REFILLS")=0,VALMSG="No refills allowed on "_$S(PSODRUG("DEA")["F":"this drug.",1:"Narcotics ...") + Q + ; +12 S PSONEW("FLD")=4 D PROV^PSODIR(.PSONEW) ; Get Provider + Q + ; +11 S PSONEW("FLD")=5 D CLINIC^PSODIR2(.PSONEW) ; Get Clinic + Q + ; +8 S PSONEW("FLD")=7 D QTY^PSODIR1(.PSONEW) ; Get quantity + Q + ; +7 I '$G(PSODRUG("IEN")) W $C(7),!!,"No Dispense Drug!",! K DIR,DUOUT,DIRUT,DTOUT D 2^PSOORNW1 + I '$G(PSODRUG("IEN")) W !,$C(7),"No Dispense Drug Selected! A new Orderable Item may need to be selected.",! Q + S PSONEW("FLD")=8 D DAYS^PSODIR1(.PSONEW) ; Get days supply + Q:'$G(PSONEW("PATIENT STATUS")) + K PSDY,PSDY1,PSMAX,PSTMAX S PSDAYS=PSONEW("DAYS SUPPLY"),PSRF=PSONEW("# OF REFILLS"),PTST=$P(^PS(53,PSONEW("PATIENT STATUS"),0),"^"),PTDY=$P(^(0),"^",3),PTRF=$P(^(0),"^",4),PSODEA=PSODRUG("DEA"),CS=0 ;D EDNEW^PSOORNW1 + Q +9 ; + I '$G(PSONEW("PATIENT STATUS")) W !!,"Rx Patient Status required!",! D 3 I '$G(PSONEW("PATIENT STATUS")) S VALMSG="Rx Patient Status required!",VALMBCK="R" Q + I +$G(^PS(55,PSODFN,"PS")) S RXPT=+^("PS") I $G(^PS(53,RXPT,0))]"" D G ASK + .S PSOMAX=$S($G(CLOZPAT)=2:3,$G(CLOZPAT)=1:1,$G(CLOZPAT)=0:0,1:+$P(^PS(53,RXPT,0),"^",4)) K RXPT + .S:'$G(PSONEW("# OF REFILLS")) PSONEW("# OF REFILLS")=$S(+$P(OR0,"^",11)>PSOMAX:PSOMAX,1:+$P(OR0,"^",11)) + .S (PSONEW("N# REF"),PSONEW("# OF REFILLS"))=$S(PSONEW("# OF REFILLS")>PSOMAX:PSOMAX,1:PSONEW("# OF REFILLS")) + .I '$D(CLOZPAT) I $G(PSODRUG("DEA"))["A"&($G(PSODRUG("DEA"))'["B")!($G(PSODRUG("DEA"))["F") D Q + ..S (PSOMAX,PSONEW("N# REF"),PSONEW("# OF REFILLS"))=0,VALMSG="No refills allowed on "_$S(PSODRUG("DEA")["F":"this drug.",1:"Narcotics ...") + .I $D(PSODRUG("DEA")) F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)="" I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S PSOMAX=5 + I '$D(CLOZPAT) I $G(PSODRUG("DEA"))["A"&($G(PSODRUG("DEA"))'["B")!($G(PSODRUG("DEA"))["F") D Q + .S (PSONEW("N# REF"),PSONEW("# OF REFILLS"))=0,VALMSG="No refills allowed on "_$S(PSODRUG("DEA")["F":"this drug.",1:"Narcotics ...") + S (PSONEW("N# REF"),PSOMAX,PSONEW("# OF REFILLS"))=+$P(OR0,"^",11) +ASK S PSONEW("FLD")=9 D REFILL^PSODIR1(.PSONEW) ; Get # of refills + K PSOMAX,PSMAX,PSTMAX S PSDAYS=PSONEW("DAYS SUPPLY"),PSRF=PSONEW("# OF REFILLS"),PTST=$P(^PS(53,PSONEW("PATIENT STATUS"),0),"^"),PTDY=$P(^(0),"^",3),PTRF=$P(^(0),"^",4),PSODEA=$G(PSODRUG("DEA")),CS=0 D EDNEW^PSOORNW1 + Q + ; +6 Q K DA S PSONEW("FLD")=10 D SIG^PSODIR1(.PSONEW) ; Get sig + I $G(PSONEW("SIG"))]"" D EN^PSOSIGNO(ORD,PSONEW("SIG")) S SIG(1)=PSONEW("SIG") + I $G(PSOSIGFL) D + .K DIRUT,DUOUT,DTOUT,DIR S DIR(0)="Y",DIR("B")="NO",DIR("A",1)="",DIR("A")="This edit will create a new order. Do you want to continue" D ^DIR + .I 'Y!($D(DIRUT)) K DIR,DIRUT,DUOUT,DTOUT,DIC,Y,PSOSIGFL,PSONEW("SIG") S SIGOK=1 + S PSONEW("CLERK CODE")=DUZ K DIR,DIRUT,DUOUT,DTOUT,DIC,Y + Q + ; +13 S PSONEW("FLD")=11 D COPIES^PSODIR1(.PSONEW) ; Get # of copies + Q + ; +10 S PSONEW("FLD")=12 D MW^PSODIR2(.PSONEW) ; Get Mail/Window Info + Q + ; +14 S PSONEW("FLD")=13 D RMK^PSODIR2(.PSONEW) ; Get Remarks + Q + ; +DRGMSG ;From PSOORNEW + F SG=1:1:$L($P(^PSDRUG(PSODRUG("IEN"),0),"^",10)) S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P($P(^PSDRUG(PSODRUG("IEN"),0),"^",10)," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " D + .S:$P($P(^PSDRUG(PSODRUG("IEN"),0),"^",10)," ",SG)'="" ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P($P(^PSDRUG(PSODRUG("IEN"),0),"^",10)," ",SG) + K SG Q + ; +DREN ; + S (PSDC,PSI)=0 + F S PSI=$O(^PSDRUG("ASP",PSODRUG("OI"),PSI)) Q:'PSI I $S('$D(^PSDRUG(PSI,"I")):1,'^("I"):1,DT'>^("I"):1,1:0),$S($P($G(^PSDRUG(PSI,2)),"^",3)'["O":0,1:1) S PSDC=PSDC+1,PSDC(PSDC)=PSI + I PSDC'=1 D G DRENX + .I $P($G(^PSDRUG(+$G(PSODRUG("IEN")),2)),"^")=$G(PSODRUG("OI")) Q + .K PSODRUG("NAME"),PSODRUG("IEN") + K PSOY S PSI=PSDC(1),PSOY=^PSDRUG(PSI,0) + I $P($G(^PSDRUG(PSI,"CLOZ1")),"^")="PSOCLO1",'$O(^YSCL(603.01,"C",PSODFN,0)) K PSOY,PSI Q + S PSODRUG("IEN")=+PSI,PSODRUG("VA CLASS")=$P(PSOY,"^",2),PSODRUG("NAME")=$P(PSOY,"^") + S PSODRUG("NDF")=$S($G(^PSDRUG(PSI,"ND"))]"":+^("ND")_"A"_$P(^("ND"),"^",3),1:0) + S PSODRUG("MAXDOSE")=$P(PSOY,"^",4),PSODRUG("DEA")=$P(PSOY,"^",3),PSODRUG("CLN")=$S($D(^PSDRUG(+PSI,"ND")):+$P(^("ND"),"^",6),1:0) + S PSODRUG("SIG")=$P(PSOY,"^",5),PSODRUG("NDC")=$$GETNDC^PSSNDCUT(+PSI,$G(PSOSITE)),PSODRUG("STKLVL")=$G(^PSDRUG(+PSI,660.1)) + S PSODRUG("DAW")=+$$GET1^DIQ(50,+PSI,81) + G:$G(^PSDRUG(+PSI,660))']"" DRENX + S PSOX1=$G(^PSDRUG(+PSI,660)),PSODRUG("COST")=$P($G(PSOX1),"^",6),PSODRUG("UNIT")=$P($G(PSOX1),"^",8),PSODRUG("EXPIRATION DATE")=$P($G(PSOX1),"^",9) +DRENX K PSDC,PSI,PSOY,Y,PSOXI,X Q +KV K DIR,DIRUT,DUOUT,DTOUT Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORRL.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORRL.m index 84318bb2..d6af9537 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORRL.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORRL.m @@ -1,139 +1,126 @@ -PSOORRL ;BHAM ISC/SAB - returns patient's outpatient meds ;07/21/96 - ;;7.0;OUTPATIENT PHARMACY;**4,20,9,34,54,82,124,132,159,214,225**;DEC 1997;Build 29 - ;External reference to ^PS(55 supported by DBIA 2228 - ;External reference to ^PSDRUG supported by DBIA 221 - ;External reference to ^VA(200 supported by DBIA 10060 - ;External reference to ^PS(51.2 supported by DBIA 2226 - ;External reference to ^PS(50.7 supported by DBIA 2223 - ;External reference to ^PS(50.606 supported by DBIA 2174 - ;External reference to OCL^PSJORRE supported by DBIA 2383 - ;External reference to OEL^PSJORRE1 supported by DBIA 2384 -OCL(DFN,BDT,EDT,VIEW) ;entry point to return condensed list - ; VIEW=0 - This returns the list as it was returned prior to GUI 27 - ; VIEW=1 - This returns the list in original view GUI 27 - ; VIEW=2 - This is the new sort with GUI 27 - ; VIEW=3 - New sort by Sort by Drug Name/status with GUI 27 - D @$S($G(VIEW)=3:"OCL^PSOORRL3",$G(VIEW)=1:"OCL^PSOORRLO",$G(VIEW)=2:"OCL^PSOORRLN",1:"ST") - Q - ;BHW;PSO*7*159;New SD* Variables -ST N SD,SDT,SDT1 - D:$P($G(^PS(55,DFN,0)),"^",6)'=2 EN^PSOHLUP(DFN) - K ^TMP("PS",$J) S TFN=0,PSBDT=$G(BDT),PSEDT=$G(EDT) I +$G(PSBDT)<1 S X1=DT,X2=-120 D C^%DTC S PSBDT=X - S EXDT=PSBDT-1,IFN=0 - F S EXDT=$O(^PS(55,DFN,"P","A",EXDT)) Q:'EXDT F S IFN=$O(^PS(55,DFN,"P","A",EXDT,IFN)) Q:'IFN D:$D(^PSRX(IFN,0)) - .Q:$P($G(^PSRX(IFN,"STA")),"^")=13 - .S TFN=TFN+1,RX0=^PSRX(IFN,0),RX2=$G(^(2)),RX3=$G(^(3)),STA=+$G(^("STA")),TRM=0,LSTFD=$P(RX2,"^",2),LSTRD=$P(RX2,"^",13),LSTDS=$P(RX0,"^",8) - .F I=0:0 S I=$O(^PSRX(IFN,1,I)) Q:'I S TRM=TRM+1,LSTFD=$P(^PSRX(IFN,1,I,0),"^"),LSTDS=$P(^(0),"^",10) S:$P(^(0),"^",18)]"" LSTRD=$P(^(0),"^",18) - .S ^TMP("PS",$J,TFN,0)=IFN_"R;O"_"^"_$P($G(^PSDRUG(+$P(RX0,"^",6),0)),"^")_"^^"_$P(RX2,"^",6)_"^"_($P(RX0,"^",9)-TRM)_"^^^"_$P($G(^PSRX(IFN,"OR1")),"^",2) - .S ^TMP("PS",$J,TFN,"P",0)=$P(RX0,"^",4)_"^"_$P($G(^VA(200,+$P(RX0,"^",4),0)),"^") - .S ST0=$S(STA<12&($P(RX2,"^",6)80 IEN=IEN+1,SD=SD+1,^TMP("PS",$J,TFN,"SIO",0)=SD S ^TMP("PS",$J,TFN,"SIO",IEN,0)=$G(^TMP("PS",$J,TFN,"SIO",IEN,0))_" "_$P(MIG," ",SG) - D NVA,OCL^PSJORRE(DFN,BDT,EDT,.TFN,+$G(VIEW)),END^PSOORRL1 - K SDT,SDT1,EDT,EDT1,BDT,DBT1,X - Q -OEL(DFN,RXNUM) ;returns expanded list on specific order - I $P(RXNUM,";",2)="I" D OEL^PSJORRE1(DFN,$P(RXNUM,";")) Q - D:$P($G(^PS(55,DFN,0)),"^",6)'=2 EN^PSOHLUP(DFN) Q:RXNUM="" - ;BHW;PSO*7*159;New SD - N SD - K INST,IFN,^TMP("PS",$J) S FL=$P(RXNUM,";"),IFN=+FL,RXNUM=$P(RXNUM,";",2) - I $G(FL)["P"!($G(FL)["S") D PEN^PSOORRL1 Q - I $G(FL)["N" D NVA^PSOORRL1 Q - Q:'$D(^PSRX(IFN,0)) - S RX0=^PSRX(IFN,0),RX2=$G(^(2)),RX3=$G(^(3)),STA=+$G(^("STA")),TRM=0,LSTFD=$P(RX2,"^",2) - S ^TMP("PS",$J,"RXN",0)=$P(RX0,"^")_"^"_$E($P(RX2,"^",13),1,7)_"^"_$S($P(RX0,"^",11)="W":"W",1:"M")_"^"_$P(RX3,"^",7)_"^"_$S($P($G(^PSRX(IFN,"OR1")),"^",5):$P(^PSRX(IFN,"OR1"),"^",5),1:"")_"^"_$E($P(RX2,"^",2),1,7)_"^"_$E($P(RX2,"^",13),1,7) - D RSTC(0) ;set return to stock node for original - F I=0:0 S I=$O(^PSRX(IFN,1,I)) Q:'I S TRM=TRM+1,LSTFD=$P(^PSRX(IFN,1,I,0),"^") D - .S ^TMP("PS",$J,"REF",I,0)=$P(^PSRX(IFN,1,I,0),"^")_"^"_$P(^(0),"^",10)_"^"_$P(^(0),"^",4)_"^"_$E($P(^(0),"^",18),1,7)_"^"_$S($P(^(0),"^",2)="W":"W",1:"M")_"^"_$P(^(0),"^",3) - .I $P(^PSRX(IFN,1,I,0),"^",18) S $P(^TMP("PS",$J,"RXN",0),"^",2)=$E($P(^PSRX(IFN,1,I,0),"^",18),1,7) - .S ^TMP("PS",$J,"REF",0)=$G(^TMP("PS",$J,"REF",0))+1 - .D RSTC(I) ;set return to stock node for refills - F I=0:0 S I=$O(^PSRX(IFN,"P",I)) Q:'I D - .S ^TMP("PS",$J,"PAR",I,0)=$P(^PSRX(IFN,"P",I,0),"^")_"^"_$P(^(0),"^",10)_"^"_$P(^(0),"^",4)_"^"_$E($P(^(0),"^",19),1,7)_"^"_$S($P(^(0),"^",2)="W":"W",1:"M")_"^"_$P(^(0),"^",3) - .S ^TMP("PS",$J,"PAR",0)=$G(^TMP("PS",$J,"PAR",0))+1 - S ^TMP("PS",$J,0)=$P($G(^PSDRUG(+$P(RX0,"^",6),0)),"^")_"^^"_$P(RX2,"^",6) - S ^TMP("PS",$J,"P",0)=$P(RX0,"^",4)_"^"_$P($G(^VA(200,+$P(RX0,"^",4),0)),"^") - S ST0=$S(STA<12&($P(RX2,"^",6)DT:1,1:0) - S ^TMP("PS",$J,"DD",1,0)=^TMP("PS",$J,"DD",1,0)_$S($P($G(^PSDRUG(+$P(RX0,"^",6),2)),"^",3)["U"&(COD):$P(RX0,"^",6),1:"") K COD - S ^TMP("PS",$J,"SCH",0)=0,(SCH,SC)=0 - F S SC=$O(^PSRX(IFN,"SCH",SC)) Q:'SC S SCH=SCH+1,^TMP("PS",$J,"SCH",SCH,0)=$P(^PSRX(IFN,"SCH",SC,0),"^") D - .S ^TMP("PS",$J,"SCH",0)=^TMP("PS",$J,"SCH",0)+1 - D MDR^PSOORRL1 - S PSOELSE=0 I $D(^PSRX(IFN,"SIG")),'$P(^PSRX(IFN,"SIG"),"^",2) S PSOELSE=1 S X=$P(^PSRX(IFN,"SIG"),"^") D SIG^PSOORRL1 - I '$G(PSOELSE) S ITFN=1 D - .S ^TMP("PS",$J,"SIG",ITFN,0)=$G(^PSRX(IFN,"SIG1",1,0)),^TMP("PS",$J,"SIG",0)=+$G(^TMP("PS",$J,"SIG",0))+1 - .F I=1:0 S I=$O(^PSRX(IFN,"SIG1",I)) Q:'I S ITFN=ITFN+1,^TMP("PS",$J,"SIG",ITFN,0)=^PSRX(IFN,"SIG1",I,0),^TMP("PS",$J,"SIG",0)=+$G(^TMP("PS",$J,"SIG",0))+1 - K PSOELSE - S ^TMP("PS",$J,"PC",0)=0,ITFN=0 - F I=0:0 S I=$O(^PSRX(IFN,"PRC",I)) Q:'I S ITFN=ITFN+1,^TMP("PS",$J,"PC",ITFN,0)=^PSRX(IFN,"PRC",I,0),^TMP("PS",$J,"PC",0)=^TMP("PS",$J,"PC",0)+1 - Q - ; -WAIT ; IF PENDING ENTRY STILL BEING BUILT SEE IF IT COMPLETES WITHIN ANOTHER SECOND - H 1 S PSOR=$G(^PS(52.41,IFN,0)) - Q - ; -NVA ; Set Non-VA Med Orders in the ^TMP Global - ;BHW;PSO*7*159;New SDT,SDT1 Variables - N SDT,SDT1 - F I=0:0 S I=$O(^PS(55,DFN,"NVA",I)) Q:'I S X=$G(^PS(55,DFN,"NVA",I,0)) D - .Q:'$P(X,"^") - .S DRG=$S($P(X,"^",2):$P($G(^PSDRUG($P(X,"^",2),0)),"^"),1:$P(^PS(50.7,$P(X,"^"),0),"^")_" "_$P(^PS(50.606,$P(^PS(50.7,$P(X,"^"),0),"^",2),0),"^")) - .S SDT=$P(X,"^",9) I 'SDT D TMPBLD Q - .I $E(SDT,4,5),$E(SDT,6,7) D - ..;I $P(X,"^",9) D Q - ..I $G(BDT),SDTEDT Q - ..I $G(BDT),$P(X,"^",7),$P(X,"^",7)EDT1 Q - ..I $G(BDT1),$P(X,"^",7),$E($P(X,"^",7),1,5)EDT1 Q - ..I $G(BDT1),$P(X,"^",7),$E($P(X,"^",7),1,3)0,'$$RXRLDT^PSOBPSUT(IFN,REF) S ^TMP("PS",$J,"REF",REF,"RSTC")=$P(II,"^")_"^"_$P(II,"^",3)_"^"_$P(II,"^",5) - Q +PSOORRL ;BHAM ISC/SAB - returns patient's outpatient meds ;07/21/96 + ;;7.0;OUTPATIENT PHARMACY;**4,20,9,34,54,82,124,132,159,214**;DEC 1997 + ;External reference to ^PS(55 supported by DBIA 2228 + ;External reference to ^PSDRUG supported by DBIA 221 + ;External reference to ^VA(200 supported by DBIA 10060 + ;External reference to ^PS(51.2 supported by DBIA 2226 + ;External reference to ^PS(50.7 supported by DBIA 2223 + ;External reference to ^PS(50.606 supported by DBIA 2174 + ;External reference to OCL^PSJORRE supported by DBIA 2383 + ;External reference to OEL^PSJORRE1 supported by DBIA 2384 +OCL(DFN,BDT,EDT) ;entry point to return condensed list + ;BHW;PSO*7*159;New SD* Variables + N SD,SDT,SDT1 + D:$P($G(^PS(55,DFN,0)),"^",6)'=2 EN^PSOHLUP(DFN) + K ^TMP("PS",$J) S TFN=0,PSBDT=$G(BDT),PSEDT=$G(EDT) I +$G(PSBDT)<1 S X1=DT,X2=-120 D C^%DTC S PSBDT=X + S EXDT=PSBDT-1,IFN=0 + F S EXDT=$O(^PS(55,DFN,"P","A",EXDT)) Q:'EXDT F S IFN=$O(^PS(55,DFN,"P","A",EXDT,IFN)) Q:'IFN D:$D(^PSRX(IFN,0)) + .Q:$P($G(^PSRX(IFN,"STA")),"^")=13 + .S TFN=TFN+1,RX0=^PSRX(IFN,0),RX2=$G(^(2)),RX3=$G(^(3)),STA=+$G(^("STA")),TRM=0,LSTFD=$P(RX2,"^",2),LSTRD=$P(RX2,"^",13),LSTDS=$P(RX0,"^",8) + .F I=0:0 S I=$O(^PSRX(IFN,1,I)) Q:'I S TRM=TRM+1,LSTFD=$P(^PSRX(IFN,1,I,0),"^"),LSTDS=$P(^(0),"^",10) S:$P(^(0),"^",18)]"" LSTRD=$P(^(0),"^",18) + .S ^TMP("PS",$J,TFN,0)=IFN_"R;O"_"^"_$P($G(^PSDRUG(+$P(RX0,"^",6),0)),"^")_"^^"_$P(RX2,"^",6)_"^"_($P(RX0,"^",9)-TRM)_"^^^"_$P($G(^PSRX(IFN,"OR1")),"^",2) + .S ^TMP("PS",$J,TFN,"P",0)=$P(RX0,"^",4)_"^"_$P($G(^VA(200,+$P(RX0,"^",4),0)),"^") + .S ST0=$S(STA<12&($P(RX2,"^",6)80 IEN=IEN+1,SD=SD+1,^TMP("PS",$J,TFN,"SIO",0)=SD S ^TMP("PS",$J,TFN,"SIO",IEN,0)=$G(^TMP("PS",$J,TFN,"SIO",IEN,0))_" "_$P(MIG," ",SG) + D NVA,OCL^PSJORRE(DFN,BDT,EDT,.TFN),END^PSOORRL1 + K SDT,SDT1,EDT,EDT1,BDT,DBT1,X + Q +OEL(DFN,RXNUM) ;returns expanded list on specific order + I $P(RXNUM,";",2)="I" D OEL^PSJORRE1(DFN,$P(RXNUM,";")) Q + D:$P($G(^PS(55,DFN,0)),"^",6)'=2 EN^PSOHLUP(DFN) Q:RXNUM="" + ;BHW;PSO*7*159;New SD + N SD + K INST,IFN,^TMP("PS",$J) S FL=$P(RXNUM,";"),IFN=+FL,RXNUM=$P(RXNUM,";",2) + I $G(FL)["P"!($G(FL)["S") D PEN^PSOORRL1 Q + I $G(FL)["N" D NVA^PSOORRL1 Q + Q:'$D(^PSRX(IFN,0)) + S RX0=^PSRX(IFN,0),RX2=$G(^(2)),RX3=$G(^(3)),STA=+$G(^("STA")),TRM=0,LSTFD=$P(RX2,"^",2) + S ^TMP("PS",$J,"RXN",0)=$P(RX0,"^")_"^"_$E($P(RX2,"^",13),1,7)_"^"_$S($P(RX0,"^",11)="W":"W",1:"M")_"^"_$P(RX3,"^",7)_"^"_$S($P($G(^PSRX(IFN,"OR1")),"^",5):$P(^PSRX(IFN,"OR1"),"^",5),1:"")_"^"_$E($P(RX2,"^",2),1,7)_"^"_$E($P(RX2,"^",13),1,7) + F I=0:0 S I=$O(^PSRX(IFN,1,I)) Q:'I S TRM=TRM+1,LSTFD=$P(^PSRX(IFN,1,I,0),"^") D + .S ^TMP("PS",$J,"REF",I,0)=$P(^PSRX(IFN,1,I,0),"^")_"^"_$P(^(0),"^",10)_"^"_$P(^(0),"^",4)_"^"_$E($P(^(0),"^",18),1,7)_"^"_$S($P(^(0),"^",2)="W":"W",1:"M")_"^"_$P(^(0),"^",3) + .I $P(^PSRX(IFN,1,I,0),"^",18) S $P(^TMP("PS",$J,"RXN",0),"^",2)=$E($P(^PSRX(IFN,1,I,0),"^",18),1,7) + .S ^TMP("PS",$J,"REF",0)=$G(^TMP("PS",$J,"REF",0))+1 + F I=0:0 S I=$O(^PSRX(IFN,"P",I)) Q:'I D + .S ^TMP("PS",$J,"PAR",I,0)=$P(^PSRX(IFN,"P",I,0),"^")_"^"_$P(^(0),"^",10)_"^"_$P(^(0),"^",4)_"^"_$E($P(^(0),"^",19),1,7)_"^"_$S($P(^(0),"^",2)="W":"W",1:"M")_"^"_$P(^(0),"^",3) + .S ^TMP("PS",$J,"PAR",0)=$G(^TMP("PS",$J,"PAR",0))+1 + S ^TMP("PS",$J,0)=$P($G(^PSDRUG(+$P(RX0,"^",6),0)),"^")_"^^"_$P(RX2,"^",6) + S ^TMP("PS",$J,"P",0)=$P(RX0,"^",4)_"^"_$P($G(^VA(200,+$P(RX0,"^",4),0)),"^") + S ST0=$S(STA<12&($P(RX2,"^",6)DT:1,1:0) + S ^TMP("PS",$J,"DD",1,0)=^TMP("PS",$J,"DD",1,0)_$S($P($G(^PSDRUG(+$P(RX0,"^",6),2)),"^",3)["U"&(COD):$P(RX0,"^",6),1:"") K COD + S ^TMP("PS",$J,"SCH",0)=0,(SCH,SC)=0 + F S SC=$O(^PSRX(IFN,"SCH",SC)) Q:'SC S SCH=SCH+1,^TMP("PS",$J,"SCH",SCH,0)=$P(^PSRX(IFN,"SCH",SC,0),"^") D + .S ^TMP("PS",$J,"SCH",0)=^TMP("PS",$J,"SCH",0)+1 + D MDR^PSOORRL1 + S PSOELSE=0 I $D(^PSRX(IFN,"SIG")),'$P(^PSRX(IFN,"SIG"),"^",2) S PSOELSE=1 S X=$P(^PSRX(IFN,"SIG"),"^") D SIG^PSOORRL1 + I '$G(PSOELSE) S ITFN=1 D + .S ^TMP("PS",$J,"SIG",ITFN,0)=$G(^PSRX(IFN,"SIG1",1,0)),^TMP("PS",$J,"SIG",0)=+$G(^TMP("PS",$J,"SIG",0))+1 + .F I=1:0 S I=$O(^PSRX(IFN,"SIG1",I)) Q:'I S ITFN=ITFN+1,^TMP("PS",$J,"SIG",ITFN,0)=^PSRX(IFN,"SIG1",I,0),^TMP("PS",$J,"SIG",0)=+$G(^TMP("PS",$J,"SIG",0))+1 + K PSOELSE + S ^TMP("PS",$J,"PC",0)=0,ITFN=0 + F I=0:0 S I=$O(^PSRX(IFN,"PRC",I)) Q:'I S ITFN=ITFN+1,^TMP("PS",$J,"PC",ITFN,0)=^PSRX(IFN,"PRC",I,0),^TMP("PS",$J,"PC",0)=^TMP("PS",$J,"PC",0)+1 + Q + ; +WAIT ; IF PENDING ENTRY STILL BEING BUILT SEE IF IT COMPLETES WITHIN ANOTHER SECOND + H 1 S PSOR=$G(^PS(52.41,IFN,0)) + Q + ; +NVA ; Set Non-VA Med Orders in the ^TMP Global + ;BHW;PSO*7*159;New SDT,SDT1 Variables + N SDT,SDT1 + F I=0:0 S I=$O(^PS(55,DFN,"NVA",I)) Q:'I S X=$G(^PS(55,DFN,"NVA",I,0)) D + .Q:'$P(X,"^") + .S DRG=$S($P(X,"^",2):$P($G(^PSDRUG($P(X,"^",2),0)),"^"),1:$P(^PS(50.7,$P(X,"^"),0),"^")_" "_$P(^PS(50.606,$P(^PS(50.7,$P(X,"^"),0),"^",2),0),"^")) + .S SDT=$P(X,"^",9) I 'SDT D TMPBLD Q + .I $E(SDT,4,5),$E(SDT,6,7) D + ..;I $P(X,"^",9) D Q + ..I $G(BDT),SDTEDT Q + ..I $G(BDT),$P(X,"^",7),$P(X,"^",7)EDT1 Q + ..I $G(BDT1),$P(X,"^",7),$E($P(X,"^",7),1,5)EDT1 Q + ..I $G(BDT1),$P(X,"^",7),$E($P(X,"^",7),1,3)DT:DT,PSORENW("FILL DATE")<$E($P(OR0,"^",6),1,7):PSORENW("FILL DATE"),1:$E($P(OR0,"^",6),1,7)) - .S PSORENW("# OF REFILLS")=+$P(OR0,"^",11),PSOFDR=1 - .S PSORENW("CLERK CODE")=$P(OR0,"^",4),PSORX("CLERK CODE")=$P(^VA(200,$P(OR0,"^",4),0),"^") - ;D CHK - S PSOFXRN=0,PSOFXRNX=1 - S PSORENW("POE")=$S($G(^PS(52.41,ORD,"POE"))=1:1,'$O(^PSRX($P(OR0,"^",21),6,0)):1,1:"") - S PSORENW("PENDING ORDER")=ORD - D EN^PSOORNE4(.PSORENW) K PSORENW,PSORX("FILL DATE") - I '$G(PSOFXRN) D UL - D KLIB^PSORENW1 - K PSOFXRN,PSOFXRNX - Q -CHK ;check for valid # of refills - I $G(PSODRUG("DEA"))]"" D - .S PSOCS=0 K DIR,DIC,PSOX - .F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)="" I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S $P(PSOCS,"^")=1 S:$E(+PSODRUG("DEA"),DEA)=2 $P(PSOCS,"^",2)=1 - .;PSO*7*206 - .S PSOMAX=$S(PSOCS:5,1:11) I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F")!(PSODRUG("DEA")[1)!(PSODRUG("DEA")[2) S PSOMAX=0 - E S PSOMAX=$P(OR0,"^",11) - S RXPT=+$P(PSORENW("RX0"),"^",3) I $G(^PS(53,RXPT,0))]"" D - .S PSORENW("# OF REFILLS")=$S(+$P(OR0,"^",11)>+$P(^PS(53,RXPT,0),"^",4):+$P(^PS(53,RXPT,0),"^",4),1:+$P(OR0,"^",11)),PSOX=+$P(^PS(53,RXPT,0),"^",4) - .S PSORENW("# OF REFILLS")=$S(PSORENW("# OF REFILLS")>PSOMAX:PSOMAX,1:PSORENW("# OF REFILLS")) - .S PSOMAX=$S(PSOMAX>+$P(^PS(53,RXPT,0),"^",4):+$P(^PS(53,RXPT,0),"^",4),1:PSOMAX) K RXPT - E D - . I $G(PSOMAX) S PSORENW("# OF REFILLS")=$S(+$P(OR0,"^",11)>PSOMAX:PSOMAX,1:+$P(OR0,"^",11)) - Q - ; -EDTPEN ;edit front door renews - N VALMCNT S Y=$P(XQORNOD(0),"=",2) D EDTSEL^PSOORNE4 - Q -UL I $G(PSORENXX) D PSOUL^PSSLOCK(PSORENXX) - K PSORENXX - Q +PSOORRNW ;BIR/SAB-finish OP renew orders from OE/RR ; 11/3/06 10:02pm + ;;7.0;OUTPATIENT PHARMACY;**11,27,51,46,71,94,130,131,146,208**;DEC 1997;Build 39 + ; 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 + ;External reference to ^PSDRUG supported by DBIA 221 + ;External reference to ^PS(50.607 supported by DBIA 2221 + ;External reference to ^PS(51.2 supported by DBIA 2226 + ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789 + S PSORENXX=$P($G(OR0),"^",21),PSOFROM="NEW" K PRC,PHI + I $G(PSOAFYN)'="Y" I $G(PSORENXX) D PSOL^PSSLOCK(PSORENXX) I '$G(PSOMSG) D K DIR,PSOMSG W ! S DIR("A")="Press Return to continue",DIR(0)="E" D ^DIR K DIR W ! Q ;vfah + .I $P($G(PSOMSG),"^",2)'="" W $C(7),!!,$P(PSOMSG,"^",2) Q + .W $C(7),!!,"Another person is editing Rx "_$P($G(^PSRX(PSORENXX,0)),"^") + I $G(PSOAFYN)="Y" I $G(PSORENXX) D PSOL^PSSLOCK(PSORENXX) ;vfah + I $G(PSOAFYN)'="Y" K PSOMSG N OI,VALMCNT K POERR("DFLG") D FULL^VALM1 S (PSORX("DFLG"),PSORENW("DFLG"))=0,(PSORNW("FILL DATE"),PSORENW("FILL DATE"))=DT ;vfah + I $G(PSOAFYN)="Y" K PSOMSG N OI,VALMCNT K POERR("DFLG") S (PSORX("DFLG"),PSORENW("DFLG"))=0,(PSORNW("FILL DATE"),PSORENW("FILL DATE"))=DT ;vfah + S Y=DT X ^DD("DD") S PSORX("FILL DATE")=Y K Y + I $G(PSOAFYN)'="Y" W !!,"Now Renewing Rx # "_$P(^PSRX($P(OR0,"^",21),0),"^")_" Drug: "_$P($G(^PSDRUG($P(^PSRX($P(OR0,"^",21),0),"^",6),0)),"^"),! H 2 ;vfah + I $P($G(^PSRX($P(OR0,"^",21),"OR1")),"^",4) D D PROCESSX^PSORENW0 D UL Q + .W !!,"Cannot Renew Rx # "_$P(^PSRX($P(OR0,"^",21),0),"^"),!," Drug: "_$P($G(^PSDRUG($P(^PSRX($P(OR0,"^",21),0),"^",6),0)),"^")_"." + .W !,"This Rx has already been RENEWED ("_$P(^PSRX($P(^PSRX($P(OR0,"^",21),"OR1"),"^",4),0),"^")_").",! + .S ACOM="Duplicate Renewal Request. Order rejected by Pharmacy.",PSONOOR="D" D DE^PSOORFI2 K ACOM,POERR("COMM"),POERR("PLACER"),POERR("STAT") + I '$G(PSOTPBFG) D DSPL^PSOTPCAN(ORD) + S (PSORX("PROVIDER NAME"),PSORENW("PROVIDER NAME"))=$P(^VA(200,$P(OR0,"^",5),0),"^"),PSORENW("NOO")=$P(OR0,"^",7) + S PSORENW("PROVIDER")=$P(OR0,"^",5),PSORENW("MAIL/WINDOW")=$S($P(OR0,"^",17)="M":"M",1:"W") + I $O(^PSRX($P(OR0,"^",21),"PRC",0)) F I=0:0 S I=$O(^PSRX($P(OR0,"^",21),"PRC",I)) Q:'I S PRC(I)=^PSRX($P(OR0,"^",21),"PRC",I,0) + K II F I=0:0 S I=$O(^PS(52.41,ORD,1,I)) Q:'I S DOSE=$G(^PS(52.41,ORD,1,I,1)),DOSE1=$G(^(2)) D + .S II=$G(II)+1 + .S PSORENW("DOSE",II)=$P(DOSE1,"^"),PSORENW("DOSE ORDERED",II)=$P(DOSE1,"^",2),PSORENW("UNITS",II)=$P(DOSE,"^",9),PSORENW("NOUN",II)=$P(DOSE,"^",5) + .S:$P(DOSE,"^",9) UNITS=$P(^PS(50.607,$P(DOSE,"^",9),0),"^") + .S PSORENW("VERB",II)=$P(DOSE,"^",10),PSORENW("ROUTE",II)=$P(DOSE,"^",8) + .S:$P(DOSE,"^",8) ROUTE=$P(^PS(51.2,$P(DOSE,"^",8),0),"^") + .S PSORENW("SCHEDULE",II)=$P(DOSE,"^"),PSORENW("DURATION",II)=$P(DOSE,"^",2) + .I $P(DOSE,"^",6)]"" S PSORENW("CONJUNCTION",II)=$S($P(DOSE,"^",6)="S":"T",$P(DOSE,"^",6)="X":"X",1:"A") + S PSORENW("ENT")=+$G(II) K II,I + F DR=1:1:PSORENW("ENT") I $G(PSORENW("DURATION",DR))]"" D + .S DUR1=PSORENW("DURATION",DR) + .S PSORENW("DURATION",DR)=$S($E(DUR1,1)'?.N:$E(DUR1,2,99)_$E(DUR1,1),1:DUR1) + D ^PSORENW1,CHECK^PSORENW0 I PSORENW("DFLG") D KLIB^PSORENW1 D PROCESSX^PSORENW0 D UL Q + D FILDATE^PSORENW0,DRUG^PSORENW0 I PSORENW("DFLG")!$G(PSORX("DFLG")) D KLIB^PSORENW1 D PROCESSX^PSORENW0 D UL Q + D RXN^PSORENW0 I PSORENW("DFLG") D KLIB^PSORENW1 D PROCESSX^PSORENW0 D UL Q + D STOP^PSORENW1,INIT^PSORENW3 + I $G(PSOORRNW) D + .S PSORENW("ISSUE DATE")=$S(PSORENW("FILL DATE")>DT:DT,PSORENW("FILL DATE")<$E($P(OR0,"^",6),1,7):PSORENW("FILL DATE"),1:$E($P(OR0,"^",6),1,7)) + .S PSORENW("# OF REFILLS")=+$P(OR0,"^",11),PSOFDR=1 + .S PSORENW("CLERK CODE")=$P(OR0,"^",4),PSORX("CLERK CODE")=$P(^VA(200,$P(OR0,"^",4),0),"^") + ;D CHK + S PSOFXRN=0,PSOFXRNX=1 + S PSORENW("POE")=$S($G(^PS(52.41,ORD,"POE"))=1:1,'$O(^PSRX($P(OR0,"^",21),6,0)):1,1:"") + D EN^PSOORNE4(.PSORENW) K PSORENW,PSORX("FILL DATE") + I '$G(PSOFXRN) D UL + D KLIB^PSORENW1 + K PSOFXRN,PSOFXRNX + Q +CHK ;check for valid # of refills + I $G(PSODRUG("DEA"))]"" D + .S PSOCS=0 K DIR,DIC,PSOX + .F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)="" I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S $P(PSOCS,"^")=1 S:$E(+PSODRUG("DEA"),DEA)=2 $P(PSOCS,"^",2)=1 + .S PSOMAX=$S(PSOCS:5,1:11) I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F") S PSOMAX=0 + E S PSOMAX=$P(OR0,"^",11) + S RXPT=+$P(PSORENW("RX0"),"^",3) I $G(^PS(53,RXPT,0))]"" D + .S PSORENW("# OF REFILLS")=$S(+$P(OR0,"^",11)>+$P(^PS(53,RXPT,0),"^",4):+$P(^PS(53,RXPT,0),"^",4),1:+$P(OR0,"^",11)),PSOX=+$P(^PS(53,RXPT,0),"^",4) + .S PSORENW("# OF REFILLS")=$S(PSORENW("# OF REFILLS")>PSOMAX:PSOMAX,1:PSORENW("# OF REFILLS")) + .S PSOMAX=$S(PSOMAX>+$P(^PS(53,RXPT,0),"^",4):+$P(^PS(53,RXPT,0),"^",4),1:PSOMAX) K RXPT + E D + . I $G(PSOMAX) S PSORENW("# OF REFILLS")=$S(+$P(OR0,"^",11)>PSOMAX:PSOMAX,1:+$P(OR0,"^",11)) + Q + ; +EDTPEN ;edit front door renews + N VALMCNT S Y=$P(XQORNOD(0),"=",2) D EDTSEL^PSOORNE4 + Q +UL I $G(PSORENXX) D PSOUL^PSSLOCK(PSORENXX) + K PSORENXX + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORUT1.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORUT1.m index ed920698..497a4a10 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORUT1.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORUT1.m @@ -1,143 +1,142 @@ -PSOORUT1 ;BIR/SAB - Utility routine for oerr interface ;6/28/07 7:36am - ;;7.0;OUTPATIENT PHARMACY;**1,14,30,46,132,148,233,274,225**;DEC 1997;Build 29 - ;External reference to ^PSDRUG supported by DBIA 221 - ;External reference to ^PSXOPUTL supported by DBIA 2203 - ;called from HD^PSOORUTL -REL ;removed order from hold - S ACT=1,ORS=0 - I POERR("PSOFILNM")["S" S DA=+POERR("PSOFILNM") D G EXIT^PSOORUTL - .Q:'$D(^PS(52.41,DA,0)) Q:$P(^PS(52.41,DA,0),"^",3)="RF" - .S $P(^PS(52.41,DA,0),"^",3)="NW",POERR("STAT")="OR",POERR("FILLER")=DA_"^P" - .S:$G(POERR("COMM"))']"" POERR("COMM")="Order RELEASED from HOLD by OE/RR before finished." S $P(^PS(52.41,DA,4),"^")=POERR("COMM"),ORS=1 - S DA=POERR("PSOFILNM") I $D(^PSRX(DA,0)) S ORS=1,PSDA=DA D G EXIT^PSOORUTL - .S POERR("FILLER")=DA_"^R",POERR("STAT")="OR" - .S:'$D(POERR("COMM")) POERR("COMM")="Prescription Released from HOLD by OE/RR" - .I DT>$P(^PSRX(DA,2),"^",6) D - ..S EXP=$P(^PSRX(DA,2),"^",6) S:$P(^PSRX(DA,"STA"),"^")<12 $P(^PSRX(DA,"STA"),"^")=11,PSOEXFLG=1 S POERR("STAT")="UR",POERR("COMM")="Medication Expired on "_$E(EXP,4,5)_"/"_$E(EXP,6,7)_"/"_$E(EXP,2,3)_".",POERR("PHARMST")="" D ECAN^PSOUTL(DA) Q - .I $P(^PSRX(DA,"STA"),"^")'=16 S POERR("STAT")="UR",POERR("COMM")="Unable to Release from Hold" Q - .S RXFL(DA)=0,FDT=$P(^PSRX(DA,2),"^",2) - .I $O(^PSRX(DA,1,0)) F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I S FDT=$P(^PSRX(DA,1,I,0),"^"),RXFL(DA)=I - .I FDT>DT N PSOSITEZ,ZPSOPAR6 S PSOSITEZ=$S($P($G(^PSRX(DA,2)),"^",9):$P(^(2),"^",9),1:$O(^PS(59,0))),ZPSOPAR6=$P($G(^PS(59,PSOSITEZ,1)),"^",6) I ZPSOPAR6 D Q - ..S RXXDA=DA,DA=$O(^PS(52.5,"B",RXXDA,0)) I DA S DIK="^PS(52.5," D ^DIK K DIK - ..S DA=RXXDA - ..S DIC="^PS(52.5,",DIC(0)="L",DLAYGO=52.5,X=RXXDA,DIC("DR")=".02///"_FDT_";.03////"_$P(^PSRX(DA,0),"^",2)_";.04///M;.05///0;.06////"_PSOSITEZ_";2///0;9///"_RXFL(DA) K DD,DO D FILE^DICN K RXFL,DD,DO - ..S DA=RXXDA K RXXDA S $P(^PSRX(DA,"STA"),"^")=5,LFD=$E(FDT,4,5)_"-"_$E(FDT,6,7)_"-"_$E(FDT,2,3) D ACT1 - ..S PSOSUSZ=1 - .E S $P(^PSRX(DA,"STA"),"^")=0 - .S RXF=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I S RXF=I S:I>5 RXF=I+1 - .D ACT^PSOORUTL - .I $$SUBMIT^PSOBPSUT(DA) D ECMESND^PSOBPSU1(DA,,$$RXFLDT^PSOBPSUT(DA),$S('$O(^PSRX(DA,1,0)):"OF",1:"RF")) - G EXIT^PSOORUTL -ACT1 S RXF=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I S RXF=I S:I>5 RXF=I+1 - S IR=0 F FDA=0:0 S FDA=$O(^PSRX(DA,"A",FDA)) Q:'FDA S IR=FDA - S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR - D NOW^%DTC S ^PSRX(DA,"A",IR,0)=%_"^S^"_POERR("USER")_"^"_RXF_"^"_"RX Placed on Suspense until "_LFD - Q -SUS ; - I $P($G(^PSRX(+$G(FILLER),"STA")),"^")=5 N PSOMSORR,PLACERXX D EN^PSOHLSN1(+$G(FILLER),"SC","ZS","") - Q -BLD ;builds med profile for Listman - K ^TMP("PSOPF",$J),PSOLST S:$G(PSOOPT)'=3 PSOOPT=0 I '$G(PSOSD) S ^TMP("PSOPF",$J,1,0)="This patient has no prescriptions" S PSOCNT=0,PSOPF=1 Q - D EOJ,SHOW -EOJ ; - K PSOQFLG,PSODRG,PSODATA,PSOLF - Q - ;----------------------------------------------------------------- -SHOW ; - ; - ePharmacy modification to create a section for Rx with REJECTs - N PSOTMP,PSOSTS,PSODRNM,I,PSORX - S (PSOSTS,PSODRNM)="" - F S PSOSTS=$O(PSOSD(PSOSTS)) Q:PSOSTS="" D - . F S PSODRNM=$O(PSOSD(PSOSTS,PSODRNM)) Q:PSODRNM="" D - . . S PSORX=+$G(PSOSD(PSOSTS,PSODRNM)) - . . I PSOSTS="ACTIVE",$$FIND^PSOREJUT(PSORX) D Q - . . . S PSOTMP(" REJECT",PSODRNM)=PSOSTS - . . S PSOTMP(PSOSTS,PSODRNM)=PSOSTS - ; - S (PSOSTS,PSODRG)="",(PSOCNT,PSOQFLG,IEN)=0 - K RN,DL S $P(RN," ",12)=" ",$P(DL," ",40)=" " - F PSCNT=0:0 S PSOSTS=$O(PSOTMP(PSOSTS)) Q:PSOSTS="" D - . D STA - . F PSOCT=0:0 S PSODRG=$O(PSOTMP(PSOSTS,PSODRG)) Q:PSODRG="" Q:PSOCNT>1000!PSOQFLG D - . . S PSOSTA=PSOTMP(PSOSTS,PSODRG) - . . S PSODATA=PSOSD(PSOSTA,PSODRG) I PSOSTA="ZNONVA" D NVA Q - . . S PSOCNT=PSOCNT+1 I PSOSTA="PENDING" D PEN Q - . . S:'$D(^PSRX(+PSODATA,0)) PSOCNT=PSOCNT-1 D:$D(^(0)) DISPL - S (VALMCNT,PSOPF)=IEN -SHOWX K DIRUT,DTOUT,DUOUT,DIROUT,PSODRG - Q - ; -DISPL S IEN=IEN+1 N PSOID,PSOCMOP,STATLTH,ECME - K PSOLNT,PSOQTL,PSOLSP S PSOLRX=$S($G(^PSRX(+PSODATA,"IB")):13,1:14)-$L($P(^PSRX(+PSODATA,0),"^")),$P(PSOLNT," ",PSOLRX)=" ",PSODQL=$L($P(PSODRG,"^"))+$L($P(^PSRX(+PSODATA,0),"^",7)) - I PSODQL<39 S $P(PSOQTL," ",(40-PSODQL))=" " - E S $P(PSOQTL," ",(52-$L($P(^PSRX(+PSODATA,0),"^",7))))=" ",$P(PSOLSP," ",(41-$L($P(PSODRG,"^"))))=" " - S ECME=$$ECME^PSOBPSUT(+PSODATA) I ECME'="" S PSOLNT=$E(PSOLNT,1,$L(PSOLNT)-1) - S ^TMP("PSOPF",$J,IEN,0)=$J(PSOCNT,2)_$S($L(PSOCNT)<3:" ",1:"")_$P(^PSRX(+PSODATA,0),"^")_$S($G(^PSRX(+PSODATA,"IB")):"$",1:"")_ECME_PSOLNT_$P(PSODRG,"^")_$S(PSODQL<39:PSOQTL_$P(^PSRX(+PSODATA,0),"^",7)_" ",1:$G(PSOLSP)) - S STA="A^N^R^H^N^S^^^^^^E^DC^^DC^DE^H^P^" - S PSOCMOP="" - I $D(^PSDRUG("AQ",$P(^PSRX(+PSODATA,0),"^",6))) S PSOCMOP=">" - N X S X="PSXOPUTL" X ^%ZOSF("TEST") K X I $T D - .N DA S DA=+PSODATA D ^PSXOPUTL K DA - .I $G(PSXZ(PSXZ("L")))=0!($G(PSXZ(PSXZ("L")))=2) S PSOCMOP="T" - .K PSXZ - N PSOBADR - S PSOBADR=$O(^PSRX(+PSODATA,"L",9999),-1) - I PSOBADR'="" S PSOBADR=$G(^PSRX(+PSODATA,"L",PSOBADR,0)) I PSOBADR["(BAD ADDRESS)" S PSOBADR="B" - I PSOBADR'="B" S PSOBADR="" - S STAPRT=$P(STA,"^",$P(PSODATA,"^",2)+1)_PSOCMOP_PSOBADR - S STATLTH=$L(STAPRT) - S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_STAPRT_$S(STATLTH=0:" ",STATLTH=1:" ",STATLTH=2:" ",1:"") - S PSOID=$P(^PSRX(+PSODATA,0),"^",13),PSOLF=+$G(^(3)),^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$E(PSOID,4,5)_"-"_$E(PSOID,6,7)_" " - F PSOX=0:0 S PSOX=$O(^PSRX(+PSODATA,1,PSOX)) Q:'PSOX D - . I +$G(^PSRX(+PSODATA,1,PSOX,0))=PSOLF,$P($G(^PSRX(+PSODATA,1,PSOX,0)),"^",16) S PSOLF=PSOLF_"^R" - K PSOX - I '$O(^PSRX(+PSODATA,1,0)),$P(^PSRX(+PSODATA,2),"^",15) S PSOLF=PSOLF_"^R" - S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$S($G(PSOLF):$E(PSOLF,4,5),1:" ")_"-"_$S($G(PSOLF):$E(PSOLF,6,7),1:" ")_$S($P(PSOLF,"^",2)="R":"R ",1:" ") - S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$J($P(PSODATA,"^",6),2)_" "_$J($P(PSODATA,"^",8),3) - I PSODQL>38 S IEN=IEN+1 S ^TMP("PSOPF",$J,IEN,0)=PSOQTL_"Qty: "_$P(^PSRX(+PSODATA,0),"^",7) - K PSOLNT,PSOQTL,PSOLSP,PSOLRX,PSODQL - S PSOLST(PSOCNT)="52^"_+PSODATA_"^"_PSOSTA - K PSODATA,PSOLF S PSOPF=IEN - Q - ; -STA N LABEL,LINE,POS - S LABEL=PSOSTS,IEN=IEN+1 - I PSOSTS="ZNONVA" S LABEL="Non-VA MEDS (Not dispensed by VA)" - I PSOSTS=" REJECT" S LABEL="REFILL TOO SOON/DUR REJECTS (Third Party)" - S POS=80-$L(LABEL)/2,$P(LINE,"-",81)="",$E(LINE,POS+1,POS+$L(LABEL))=LABEL - S ^TMP("PSOPF",$J,IEN,0)=LINE - Q -PENX S PSOLST(PSOCNT)="52.41^"_$P(PSODATA,"^",10)_"^"_PSOSTA - K PSODATA,PSOLF,RN,PSOLSP,PSOQTL,PSOLNT - Q -PEN ; - N PSOQTL,PSOLNT,PSOLNTZ,PSOQTLX,PSCMOPF,SPACEZ - Q:'$D(^PS(52.41,$P(PSODATA,"^",10),0)) - S PSCMOPF=0 I $P($G(PSODATA),"^",11),$D(^PSDRUG("AQ",$P(PSODATA,"^",11))) S PSCMOPF=1 - S IEN=IEN+1,^TMP("PSOPF",$J,IEN,0)=$J(PSOCNT,2)_$S($L(PSOCNT)<3:" ",1:"")_$P(PSODRG,"^") - I $P($G(^PS(52.41,+$P(PSODATA,"^",10),0)),"^",23)=1 S ^TMP("PSOPF",$J,IEN,"RV")="" - S PSOLNT=$L($P(PSODRG,"^")),PSOLNTZ=$L($P(PSODATA,"^",8)) - S $P(PSOQTLX," ",(11-PSOLNTZ))=" " - S:PSOLNT<37 $P(PSOQTL," ",(37-PSOLNT))=" " - I PSOLNT<38 D G PENX - .I PSOLNT=37 S PSOQTL="" - .I $P(^PS(52.41,$P(PSODATA,"^",10),0),"^",3)="RF" S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$G(PSOQTL)_" Refill Request Rx #: "_$P(^PSRX($P(^PS(52.41,$P(PSODATA,"^",10),0),"^",19),0),"^") Q - .S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$G(PSOQTL)_" "_"QTY: "_$P(PSODATA,"^",8)_$G(PSOQTLX)_" ISDT: "_$S('$P(PSODATA,"^",9):" ",1:$E($P(PSODATA,"^",9),4,5)_"-"_$E($P(PSODATA,"^",9),6,7))_$S($G(PSCMOPF):"> ",1:" ") - .S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_"REF: "_$S($L($P(PSODATA,"^",6))>1:"",1:" ")_$P(PSODATA,"^",6) - S IEN=IEN+1,$P(SPACEZ," ",42)=" " - I $P(^PS(52.41,$P(PSODATA,"^",10),0),"^",3)="RF" S ^TMP("PSOPF",$J,IEN,0)=SPACEZ_"Refill Request Rx #: "_$P(^PSRX($P(^PS(52.41,$P(PSODATA,"^",10),0),"^",19),0),"^") G PENX - S ^TMP("PSOPF",$J,IEN,0)=SPACEZ_"QTY: "_$P(PSODATA,"^",8)_$G(PSOQTLX)_" ISDT: "_$S('$P(PSODATA,"^",9):" ",1:$E($P(PSODATA,"^",9),4,5)_"-"_$E($P(PSODATA,"^",9),6,7))_$S($G(PSCMOPF):"> ",1:" ")_"REF: "_$S($L($P(PSODATA,"^",6))>1:"",1:" ") - S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$P(PSODATA,"^",6) - G PENX - ; -NVA ; Setting the Non-VA Meds on the Medication Profile Screen (ListMan) - S IEN=IEN+1,^TMP("PSOPF",$J,IEN,0)=" "_$P(PSODRG,"^")_" " - I ($L(^TMP("PSOPF",$J,IEN,0))+$L($P(PSODATA,"^",6))>70) S IEN=IEN+1,^TMP("PSOPF",$J,IEN,0)=" " - S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$P(PSODATA,"^",6)_" " - I ($L(^TMP("PSOPF",$J,IEN,0))+$L($P(PSODATA,"^",8))>70) S IEN=IEN+1,^TMP("PSOPF",$J,IEN,0)=" " - S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$P(PSODATA,"^",8) - I ($L(^TMP("PSOPF",$J,IEN,0))+20)>70 D Q - . S IEN=IEN+1,$P(^TMP("PSOPF",$J,IEN,0)," ",51)="Date Documented: "_$E($P(PSODATA,"^",9),4,5)_"/"_$E($P(PSODATA,"^",9),6,7)_"/"_$E($P(PSODATA,"^",9),2,3) - F I=0:0 S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_" " Q:$L(^TMP("PSOPF",$J,IEN,0))>49 - S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_"Date Documented: "_$E($P(PSODATA,"^",9),4,5)_"/"_$E($P(PSODATA,"^",9),6,7)_"/"_$E($P(PSODATA,"^",9),2,3) - Q +PSOORUT1 ;BIR/SAB - Utility routine for oerr interface ;02/22/95 + ;;7.0;OUTPATIENT PHARMACY;**1,14,30,46,132,148,233**;DEC 1997;Build 8 + ;External reference to ^PSDRUG supported by DBIA 221 + ;External reference to ^PSXOPUTL supported by DBIA 2203 + ;called from HD^PSOORUTL +REL ;removed order from hold + S ACT=1,ORS=0 + I POERR("PSOFILNM")["S" S DA=+POERR("PSOFILNM") D G EXIT^PSOORUTL + .Q:'$D(^PS(52.41,DA,0)) Q:$P(^PS(52.41,DA,0),"^",3)="RF" + .S $P(^PS(52.41,DA,0),"^",3)="NW",POERR("STAT")="OR",POERR("FILLER")=DA_"^P" + .S:$G(POERR("COMM"))']"" POERR("COMM")="Order RELEASED from HOLD by OE/RR before finished." S $P(^PS(52.41,DA,4),"^")=POERR("COMM"),ORS=1 + S DA=POERR("PSOFILNM") I $D(^PSRX(DA,0)) S ORS=1,PSDA=DA D G EXIT^PSOORUTL + .S POERR("FILLER")=DA_"^R",POERR("STAT")="OR" + .S:'$D(POERR("COMM")) POERR("COMM")="Prescription Released from HOLD by OE/RR" + .I DT>$P(^PSRX(DA,2),"^",6) D + ..S EXP=$P(^PSRX(DA,2),"^",6) S:$P(^PSRX(DA,"STA"),"^")<12 $P(^PSRX(DA,"STA"),"^")=11,PSOEXFLG=1 S POERR("STAT")="UR",POERR("COMM")="Medication Expired on "_$E(EXP,4,5)_"/"_$E(EXP,6,7)_"/"_$E(EXP,2,3)_".",POERR("PHARMST")="" D ECAN^PSOUTL(DA) Q + .I $P(^PSRX(DA,"STA"),"^")'=16 S POERR("STAT")="UR",POERR("COMM")="Unable to Release from Hold" Q + .S RXFL(DA)=0,FDT=$P(^PSRX(DA,2),"^",2) + .I $O(^PSRX(DA,1,0)) F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I S FDT=$P(^PSRX(DA,1,I,0),"^"),RXFL(DA)=I + .I FDT>DT N PSOSITEZ,ZPSOPAR6 S PSOSITEZ=$S($P($G(^PSRX(DA,2)),"^",9):$P(^(2),"^",9),1:$O(^PS(59,0))),ZPSOPAR6=$P($G(^PS(59,PSOSITEZ,1)),"^",6) I ZPSOPAR6 D Q + ..S RXXDA=DA,DA=$O(^PS(52.5,"B",RXXDA,0)) I DA S DIK="^PS(52.5," D ^DIK K DIK + ..S DA=RXXDA + ..S DIC="^PS(52.5,",DIC(0)="L",DLAYGO=52.5,X=RXXDA,DIC("DR")=".02///"_FDT_";.03////"_$P(^PSRX(DA,0),"^",2)_";.04///M;.05///0;.06////"_PSOSITEZ_";2///0;9///"_RXFL(DA) K DD,DO D FILE^DICN K RXFL,DD,DO + ..S DA=RXXDA K RXXDA S $P(^PSRX(DA,"STA"),"^")=5,LFD=$E(FDT,4,5)_"-"_$E(FDT,6,7)_"-"_$E(FDT,2,3) D ACT1 + ..S PSOSUSZ=1 + .E S $P(^PSRX(DA,"STA"),"^")=0 + .S RXF=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I S RXF=I S:I>5 RXF=I+1 + .D ACT^PSOORUTL + .I $$SUBMIT^PSOBPSUT(DA) D ECMESND^PSOBPSU1(DA,,$$RXFLDT^PSOBPSUT(DA),$S('$O(^PSRX(DA,1,0)):"OF",1:"RF")) + G EXIT^PSOORUTL +ACT1 I '$D(RXF) S RXF=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I S RXF=I S:I>5 RXF=I+1 + S IR=0 F FDA=0:0 S FDA=$O(^PSRX(DA,"A",FDA)) Q:'FDA S IR=FDA + S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR + D NOW^%DTC S ^PSRX(DA,"A",IR,0)=%_"^S^"_POERR("USER")_"^"_RXF_"^"_"RX Placed on Suspense until "_LFD + Q +SUS ; + I $P($G(^PSRX(+$G(FILLER),"STA")),"^")=5 N PSOMSORR,PLACERXX D EN^PSOHLSN1(+$G(FILLER),"SC","ZS","") + Q +BLD ;builds med profile for Listman + K ^TMP("PSOPF",$J),PSOLST S:$G(PSOOPT)'=3 PSOOPT=0 I '$G(PSOSD) S ^TMP("PSOPF",$J,1,0)="This patient has no prescriptions" S PSOCNT=0,PSOPF=1 Q + D EOJ,SHOW +EOJ ; + K PSOQFLG,PSODRG,PSODATA,PSOLF + Q + ;----------------------------------------------------------------- +SHOW ; + ; - ePharmacy modification to create a section for Rx with REJECTs + N PSOTMP,PSOSTS,PSODRNM,I,PSORX + S (PSOSTS,PSODRNM)="" + F S PSOSTS=$O(PSOSD(PSOSTS)) Q:PSOSTS="" D + . F S PSODRNM=$O(PSOSD(PSOSTS,PSODRNM)) Q:PSODRNM="" D + . . S PSORX=+$G(PSOSD(PSOSTS,PSODRNM)) + . . I PSOSTS="ACTIVE",$$FIND^PSOREJUT(PSORX) D Q + . . . S PSOTMP(" REJECT",PSODRNM)=PSOSTS + . . S PSOTMP(PSOSTS,PSODRNM)=PSOSTS + ; + S (PSOSTS,PSODRG)="",(PSOCNT,PSOQFLG,IEN)=0 + K RN,DL S $P(RN," ",12)=" ",$P(DL," ",40)=" " + F PSCNT=0:0 S PSOSTS=$O(PSOTMP(PSOSTS)) Q:PSOSTS="" D + . D STA + . F PSOCT=0:0 S PSODRG=$O(PSOTMP(PSOSTS,PSODRG)) Q:PSODRG="" Q:PSOCNT>1000!PSOQFLG D + . . S PSOSTA=PSOTMP(PSOSTS,PSODRG) + . . S PSODATA=PSOSD(PSOSTA,PSODRG) I PSOSTA="ZNONVA" D NVA Q + . . S PSOCNT=PSOCNT+1 I PSOSTA="PENDING" D PEN Q + . . S:'$D(^PSRX(+PSODATA,0)) PSOCNT=PSOCNT-1 D:$D(^(0)) DISPL + S (VALMCNT,PSOPF)=IEN +SHOWX K DIRUT,DTOUT,DUOUT,DIROUT,PSODRG + Q + ; +DISPL S IEN=IEN+1 N PSOID,PSOCMOP,STATLTH,ECME + K PSOLNT,PSOQTL,PSOLSP S PSOLRX=$S($G(^PSRX(+PSODATA,"IB")):13,1:14)-$L($P(^PSRX(+PSODATA,0),"^")),$P(PSOLNT," ",PSOLRX)=" ",PSODQL=$L($P(PSODRG,"^"))+$L($P(^PSRX(+PSODATA,0),"^",7)) + I PSODQL<39 S $P(PSOQTL," ",(40-PSODQL))=" " + E S $P(PSOQTL," ",(52-$L($P(^PSRX(+PSODATA,0),"^",7))))=" ",$P(PSOLSP," ",(41-$L($P(PSODRG,"^"))))=" " + S ECME=$$ECME^PSOBPSUT(+PSODATA) I ECME'="" S PSOLNT=$E(PSOLNT,1,$L(PSOLNT)-1) + S ^TMP("PSOPF",$J,IEN,0)=$J(PSOCNT,2)_$S($L(PSOCNT)<3:" ",1:"")_$P(^PSRX(+PSODATA,0),"^")_$S($G(^PSRX(+PSODATA,"IB")):"$",1:"")_ECME_PSOLNT_$P(PSODRG,"^")_$S(PSODQL<39:PSOQTL_$P(^PSRX(+PSODATA,0),"^",7)_" ",1:$G(PSOLSP)) + S STA="A^N^R^H^N^S^^^^^^E^DC^^DC^DE^H^P^" + S PSOCMOP="" + I $D(^PSDRUG("AQ",$P(^PSRX(+PSODATA,0),"^",6))) S PSOCMOP=">" + N X S X="PSXOPUTL" X ^%ZOSF("TEST") K X I $T D + .N DA S DA=+PSODATA D ^PSXOPUTL K DA + .I $G(PSXZ(PSXZ("L")))=0!($G(PSXZ(PSXZ("L")))=2) S PSOCMOP="T" + .K PSXZ + N PSOBADR + S PSOBADR=$O(^PSRX(+PSODATA,"L",9999),-1) + I PSOBADR'="" S PSOBADR=$G(^PSRX(+PSODATA,"L",PSOBADR,0)) I PSOBADR["(BAD ADDRESS)" S PSOBADR="B" + I PSOBADR'="B" S PSOBADR="" + S STAPRT=$P(STA,"^",$P(PSODATA,"^",2)+1)_PSOCMOP_PSOBADR + S STATLTH=$L(STAPRT) + S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_STAPRT_$S(STATLTH=0:" ",STATLTH=1:" ",STATLTH=2:" ",1:"") + S PSOID=$P(^PSRX(+PSODATA,0),"^",13),PSOLF=+$G(^(3)),^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$E(PSOID,4,5)_"-"_$E(PSOID,6,7)_" " + F PSOX=0:0 S PSOX=$O(^PSRX(+PSODATA,1,PSOX)) Q:'PSOX D + . I +$G(^PSRX(+PSODATA,1,PSOX,0))=PSOLF,$P($G(^PSRX(+PSODATA,1,PSOX,0)),"^",16) S PSOLF=PSOLF_"^R" + K PSOX + I '$O(^PSRX(+PSODATA,1,0)),$P(^PSRX(+PSODATA,2),"^",15) S PSOLF=PSOLF_"^R" + S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$S($G(PSOLF):$E(PSOLF,4,5),1:" ")_"-"_$S($G(PSOLF):$E(PSOLF,6,7),1:" ")_$S($P(PSOLF,"^",2)="R":"R ",1:" ") + S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$J($P(PSODATA,"^",6),2)_" "_$J($P(PSODATA,"^",8),3) + I PSODQL>38 S IEN=IEN+1 S ^TMP("PSOPF",$J,IEN,0)=PSOQTL_"Qty: "_$P(^PSRX(+PSODATA,0),"^",7) + K PSOLNT,PSOQTL,PSOLSP,PSOLRX,PSODQL + S PSOLST(PSOCNT)="52^"_+PSODATA_"^"_PSOSTA + K PSODATA,PSOLF S PSOPF=IEN + Q + ; +STA N LABEL,LINE,POS + S LABEL=PSOSTS,IEN=IEN+1 + I PSOSTS="ZNONVA" S LABEL="Non-VA MEDS (Not dispensed by VA)" + I PSOSTS=" REJECT" S LABEL="REFILL TOO SOON/DUR REJECTS (Third Party)" + S POS=80-$L(LABEL)/2,$P(LINE,"-",81)="",$E(LINE,POS+1,POS+$L(LABEL))=LABEL + S ^TMP("PSOPF",$J,IEN,0)=LINE + Q +PENX S PSOLST(PSOCNT)="52.41^"_$P(PSODATA,"^",10)_"^"_PSOSTA + K PSODATA,PSOLF,RN,PSOLSP,PSOQTL,PSOLNT + Q +PEN ; + N PSOQTL,PSOLNT,PSOLNTZ,PSOQTLX,PSCMOPF,SPACEZ + Q:'$D(^PS(52.41,$P(PSODATA,"^",10),0)) + S PSCMOPF=0 I $P($G(PSODATA),"^",11),$D(^PSDRUG("AQ",$P(PSODATA,"^",11))) S PSCMOPF=1 + S IEN=IEN+1,^TMP("PSOPF",$J,IEN,0)=$J(PSOCNT,2)_$S($L(PSOCNT)<3:" ",1:"")_$P(PSODRG,"^") + S PSOLNT=$L($P(PSODRG,"^")),PSOLNTZ=$L($P(PSODATA,"^",8)) + S $P(PSOQTLX," ",(11-PSOLNTZ))=" " + S:PSOLNT<37 $P(PSOQTL," ",(37-PSOLNT))=" " + I PSOLNT<38 D G PENX + .I PSOLNT=37 S PSOQTL="" + .I $P(^PS(52.41,$P(PSODATA,"^",10),0),"^",3)="RF" S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$G(PSOQTL)_" Refill Request Rx #: "_$P(^PSRX($P(^PS(52.41,$P(PSODATA,"^",10),0),"^",19),0),"^") Q + .S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$G(PSOQTL)_" "_"QTY: "_$P(PSODATA,"^",8)_$G(PSOQTLX)_" ISDT: "_$S('$P(PSODATA,"^",9):" ",1:$E($P(PSODATA,"^",9),4,5)_"-"_$E($P(PSODATA,"^",9),6,7))_$S($G(PSCMOPF):"> ",1:" ") + .S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_"REF: "_$S($L($P(PSODATA,"^",6))>1:"",1:" ")_$P(PSODATA,"^",6) + S IEN=IEN+1,$P(SPACEZ," ",42)=" " + I $P(^PS(52.41,$P(PSODATA,"^",10),0),"^",3)="RF" S ^TMP("PSOPF",$J,IEN,0)=SPACEZ_"Refill Request Rx #: "_$P(^PSRX($P(^PS(52.41,$P(PSODATA,"^",10),0),"^",19),0),"^") G PENX + S ^TMP("PSOPF",$J,IEN,0)=SPACEZ_"QTY: "_$P(PSODATA,"^",8)_$G(PSOQTLX)_" ISDT: "_$S('$P(PSODATA,"^",9):" ",1:$E($P(PSODATA,"^",9),4,5)_"-"_$E($P(PSODATA,"^",9),6,7))_$S($G(PSCMOPF):"> ",1:" ")_"REF: "_$S($L($P(PSODATA,"^",6))>1:"",1:" ") + S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$P(PSODATA,"^",6) + G PENX + ; +NVA ; Setting the Non-VA Meds on the Medication Profile Screen (ListMan) + S IEN=IEN+1,^TMP("PSOPF",$J,IEN,0)=" "_$P(PSODRG,"^")_" " + I ($L(^TMP("PSOPF",$J,IEN,0))+$L($P(PSODATA,"^",6))>70) S IEN=IEN+1,^TMP("PSOPF",$J,IEN,0)=" " + S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$P(PSODATA,"^",6)_" " + I ($L(^TMP("PSOPF",$J,IEN,0))+$L($P(PSODATA,"^",8))>70) S IEN=IEN+1,^TMP("PSOPF",$J,IEN,0)=" " + S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_$P(PSODATA,"^",8) + I ($L(^TMP("PSOPF",$J,IEN,0))+20)>70 D Q + . S IEN=IEN+1,$P(^TMP("PSOPF",$J,IEN,0)," ",51)="Date Documented: "_$E($P(PSODATA,"^",9),4,5)_"/"_$E($P(PSODATA,"^",9),6,7)_"/"_$E($P(PSODATA,"^",9),2,3) + F I=0:0 S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_" " Q:$L(^TMP("PSOPF",$J,IEN,0))>49 + S ^TMP("PSOPF",$J,IEN,0)=^TMP("PSOPF",$J,IEN,0)_"Date Documented: "_$E($P(PSODATA,"^",9),4,5)_"/"_$E($P(PSODATA,"^",9),6,7)_"/"_$E($P(PSODATA,"^",9),2,3) + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORUTL.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORUTL.m index 0c40fae7..a538bf78 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORUTL.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORUTL.m @@ -1,108 +1,107 @@ -PSOORUTL ;ISC BHAM/SAB - updates order status from oerr ;6/28/07 7:36am - ;;7.0;OUTPATIENT PHARMACY;**14,46,146,132,118,199,223,148,249,274,225**;DEC 1997;Build 29 - ;External reference to EN^ORERR - 2187 - ;External reference to ^PS(55 - 2228 - ;Input variables, poerr("psofilnm")=pharmacy pointer # from OE/RR, poerr("stat")=Order Control status - ;poerr("pharmst")=will contain 'ZE'if rx has expired, poerr("comm")=Comments, poerr("user")=Person placing request -EN(POERR) ; - N PSZORS,III - F OO=0:0 S OO=$O(MSG(OO)) Q:'OO I $P(MSG(OO),"|")="ZRN" S NVA=1 - I $G(NVA) G NVA - G:POERR("PSOFILNM")'["S" RXO S III=+POERR("PSOFILNM") - S ORS=0 I $D(^PS(52.41,III,0)) D G PEXIT - .Q:$P($G(^PS(52.41,III,0)),"^",3)="RF" - .I $G(PDFN),$P($G(^PS(52.41,III,0)),"^",2),PDFN'=$P(^PS(52.41,III,0),"^",2) S ORS=1 -RXO S III=POERR("PSOFILNM") I $D(^PSRX(III,0)) D G PEXIT - .I $G(PDFN),$P($G(^PSRX(III,0)),"^",2),PDFN'=$P(^PSRX(III,0),"^",2) S ORS=1 - S (ORS,PSZORS)=1 -PEXIT I $G(ORS) S POERR("STAT")=$S(POERR("STAT")="CA":"UC",POERR("STAT")="DC":"UD",POERR("STAT")="HD":"UH",1:"UR"),POERR("FILLER")="",POERR("COMM")=$S($G(PSZORS):"Invalid Pharmacy order number",1:"Patient does not match.") K ORS,PSZORS,III Q - S POERR("PHARMST")="" G:POERR("STAT")="HD"!(POERR("STAT")="RL") HD - S ORS=0 I POERR("PSOFILNM")["S" S DA=+POERR("PSOFILNM") I $D(^PS(52.41,DA,0)) D G EXIT - .Q:$P($G(^PS(52.41,DA,0)),"^",3)="RF" - .S $P(^PS(52.41,DA,0),"^",3)="DC",POERR("PLACE")=$P(^(0),"^"),POERR("STAT")="CR",POERR("FILLER")=DA_"^P" - .K ^PS(52.41,"AOR",+$P($G(^PS(52.41,DA,0)),"^",2),+$P($G(^PS(52.41,DA,"INI")),"^"),DA) - .S:$G(POERR("COMM"))']"" POERR("COMM")="Order Canceled by OE/RR before finishing." S ORS=1,$P(^PS(52.41,DA,4),"^")=$G(POERR("COMM")) - S DA=POERR("PSOFILNM") D:$D(^PSRX(DA,0)) REVERSE^PSOBPSU1(DA,,"DC",7) - I $D(^PSRX(DA,0)) D S $P(^PSRX(DA,"STA"),"^")=14,$P(^PSRX(DA,3),"^",5)=DT,$P(^PSRX(DA,3),"^",10)=$P(^PSRX(DA,3),"^") D CAN^PSOTPCAN(DA) G EXIT - .;cancel/discontinue action - .S POERR("PLACE")=+$P($G(^PSRX(DA,"OR1")),"^",2),POERR("STAT")=$S(POERR("STAT")="CA":"CR",1:"DR"),POERR("FILLER")=DA_"^R" - .S:'$D(POERR("COMM")) POERR("COMM")="Prescription DISCONTINUED by OERR" - .S ORS=1 D CAN -EXIT I '$G(ORS) D - .S POERR("STAT")=$S(POERR("STAT")="CA":"UC",POERR("STAT")="DC":"UD",POERR("STAT")="HD":"UH",1:"UR"),POERR("FILLER")="",POERR("COMM")="Order was not located by Pharmacy" - K EXP,ORS,DA,ACOM,RXDA,SUSD,PSUS,RXF,I,FDA,DIC,DIE,DR,Y,X,%,%I,%H,RSDT,ACNT,ACT,DIK,FDT,IR,LFD,NOW,ORD,PSDA,PSCDA,PSODFN,PSUS,RF,RFCNT,RXN,RXP,RXREF,SD,SUB - Q -CAN S ACOM="Discontinued by OE/RR." I $P(^PSRX(DA,"STA"),"^")=3!($P(^("STA"),"^")=16) D - .S ACOM="Discontinued by OE/RR while on hold. " K:$P(^PSRX(DA,"H"),"^") ^PSRX("AH",$P(^PSRX(DA,"H"),"^"),DA) S ^PSRX(DA,"H")="" - .I $P(^PSRX(DA,0),"^",13),'$O(^PSRX(DA,1,0)) S DIE=52,DR="22///"_$E($P(^PSRX(DA,0),"^",13),1,7) D ^DIE K DIE,DR Q - .S (IFN,SUSD)=0 F S IFN=$O(^PSRX(DA,1,IFN)) Q:'IFN S SUSD=IFN,RFDT=$P(^PSRX(DA,1,IFN,0),"^") - .Q:'$G(SUSD) I '$P(^PSRX(DA,1,SUSD,0),"^",18) S PSDTEST=0 D I 'PSDTEST K ^PSRX(DA,1,SUSD),^PSRX("AD",RFDT,DA,SUSD),^PSRX(DA,1,"B",RFDT,SUSD),IFN,SUSD,RFDT - ..F PDA=0:0 S PDA=$O(^PSRX(DA,"L",PDA)) Q:'PDA I $P($G(^PSRX(DA,"L",PDA,0)),"^",2)=SUSD S PSDTEST=1 - ..K CMOP D ^PSOCMOPA I $G(CMOP(CMOP("L")))="",$G(CMOP("S"))'="L" Q - ..S PSDTEST=1 - S RXDA=DA,(DA,SUSDA)=$O(^PS(52.5,"B",DA,0)) D:DA - .S SUSD=$P($G(^PS(52.5,DA,0)),"^",2) - .S:+$G(^PS(52.5,DA,"P"))'=1 ACOM="Discontinued by OE/RR while suspended." - .I $O(^PSRX(RXDA,1,0)) S DA=RXDA D:'$G(^PS(52.5,+SUSDA,"P")) REF^PSOCAN2 - .S DA=SUSDA,DIK="^PS(52.5," D ^DIK K DIK - K SUSD,SUSDA S DA=RXDA,RXREF=0,PSODFN=+$P(^PSRX(DA,0),"^",2) D - .S ACNT=0 F SUB=0:0 S SUB=$O(^PSRX(DA,"A",SUB)) Q:'SUB S ACNT=SUB - .S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(DA,1,RF)) Q:'RF S RFCNT=RF S:RF>5 RFCNT=RF+1 - .D NOW^%DTC S ^PSRX(DA,"A",0)="^52.3DA^"_(ACNT+1)_"^"_(ACNT+1),^PSRX(DA,"A",ACNT+1,0)=%_"^C^"_POERR("USER")_"^"_RFCNT_"^"_$G(ACOM) - .S REA="C" D EXP^PSOHELP1 - I $G(^PS(52.4,DA,0))]"" S PSCDA=DA,DIK="^PS(52.4," D ^DIK S DA=PSCDA K DIK,PSCDA - Q -HD ;place order on hold - G:POERR("STAT")="RL" REL^PSOORUT1 S (ACT,ORS)=0 I POERR("PSOFILNM")["S" D G EXIT - .S DA=+POERR("PSOFILNM") - .Q:'$D(^PS(52.41,DA,0)) Q:$P(^PS(52.41,DA,0),"^",3)="RF" - .S $P(^PS(52.41,DA,0),"^",3)="HD",POERR("STAT")="HR",POERR("FILLER")=DA_"^P" - .S:$G(POERR("COMM"))']"" POERR("COMM")="Order PLACED on HOLD by OERR before finished." S $P(^PS(52.41,DA,4),"^")=POERR("COMM"),ORS=1 - S DA=POERR("PSOFILNM") I $D(^PSRX(DA,0)) S ORS=1,PSDA=DA D G EXIT - .S POERR("FILLER")=DA_"^R" - .S:'$D(POERR("COMM")) POERR("COMM")="Prescription Placed on HOLD by OERR" - .I DT>$P(^PSRX(DA,2),"^",6) S EXP=$P(^(2),"^",6) S:$P(^PSRX(DA,"STA"),"^")<12 $P(^PSRX(DA,"STA"),"^")=11,PSOEXFLG=1 S POERR("STAT")="UH",POERR("COMM")="Prescription EXPIRED on "_$E(EXP,4,5)_"/"_$E(EXP,6,7)_"/"_$E(EXP,2,3)_"." D Q - ..D ECAN^PSOUTL(DA) - .I $P(^PSRX(DA,"STA"),"^")=3!($P(^("STA"),"^")>11) S POERR("STAT")="UH",POERR("COMM")="Unable to place on HOLD" Q - .S $P(^PSRX(DA,"STA"),"^")=16,POERR("STAT")="HR",^PSRX(DA,"H")=99_"^"_POERR("COMM")_"^"_DT - .S (PSUS,RXF)=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I S RXF=I S:RXF>1 RSDT=$P(^(RXF-1,0),"^") - .S DA=PSDA D ACT D REVERSE^PSOBPSU1(DA,,"HLD",2) - .S DA=$O(^PS(52.5,"B",PSDA,0)) I DA S DIK="^PS(52.5,",PSUS=1 D ^DIK K DA,DIK - I 'ORS S POERR("COMM")="Unable to place order on HOLD" G EXIT - Q -NVA ;non-va med action - N DIE,DR,DA K NVA - I POERR("PSOFILNM")'["N"!('$D(^PS(55,PDFN,"NVA",+POERR("PSOFILNM"),0))) D EN^ORERR("Order was not located by Pharmacy",.MSG) Q - I $G(OR("STAT"))'="CA",$G(OR("STAT"))'="DC" D EN^ORERR("Invalid Order Control Code",.MSG) Q -XO S ORD=+POERR("PSOFILNM") - N TMP - D NOW^%DTC - K TMP S TMP(55.05,ORD_","_PDFN_",",5)=$S($G(PSODEATH):2,1:1) - S TMP(55.05,ORD_","_PDFN_",",6)=% - D FILE^DIE("","TMP") - S PLACER=$P(^PS(55,PDFN,"NVA",ORD,0),"^",8) - K MSG S NULLFLDS="F JJ=0:1:LIMIT S FIELD(JJ)=""""" - K ^UTILITY("DIQ1",$J),DIQ S DA=$P($$SITE^VASITE(),"^") - I $G(DA) S DIC=4,DIQ(0)="I",DR="99" D EN^DIQ1 S PSOHINST=$G(^UTILITY("DIQ1",$J,4,DA,99,"I")) K ^UTILITY("DIQ1",$J),DA,DR,DIQ,DIC - S MSG(1)="MSH|^~\&|PHARMACY|"_$G(PSOHINST)_"|||||ORR" - ; - S DFN=PDFN,COUNT=1,LIMIT=5 X NULLFLDS D DEM^VADPT S NAME=$G(VADM(1)) K VADM - S FIELD(0)="PID",FIELD(3)=DFN,FIELD(5)=NAME - D SEG^PSOHLSN1 - ; - S LIMIT=15 X NULLFLDS - S FIELD(0)="ORC",FIELD(2)=PLACER_"^OR",FIELD(3)=+POERR("PSOFILNM")_"N^PS" - S FIELD(1)="SC",FIELD(5)="DC" - D SEG^PSOHLSN1 - I $G(PSODEATH) S MSG(COUNT)=MSG(COUNT)_"|^^^^DATE OF DEATH ENTERED BY MAS.^" - ; - D SEND^PSOHLSN1 K FIELDS,LIMIT,PSODSC,PSONVA,OI - Q - ; -ACT ;activity log - D NOW^%DTC S NOW=% - S IR=0 F FDA=0:0 S FDA=$O(^PSRX(DA,"A",FDA)) Q:'FDA S IR=FDA - S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR - S RXF=$S(RXF>5:RXF+1,1:RXF) - S ^PSRX(DA,"A",IR,0)=NOW_"^"_$S(ACT:"U",1:"H")_"^"_POERR("USER")_"^"_RXF_"^"_"RX "_$S('ACT:"placed in a",1:"removed from")_" HOLD status "_$S(+$G(PSUS):"and removed from SUSPENSE ",1:"")_"("_$E(DT,4,5)_"-"_$E(DT,6,7)_"-"_$E(DT,2,3)_") by OERR." - Q +PSOORUTL ;ISC BHAM/SAB - updates order status from oerr ;02/22/95 + ;;7.0;OUTPATIENT PHARMACY;**14,46,146,132,118,199,223,148,249**;DEC 1997;Build 9 + ;External reference to EN^ORERR - 2187 + ;External reference to ^PS(55 - 2228 + ;Input variables, poerr("psofilnm")=pharmacy pointer # from OE/RR, poerr("stat")=Order Control status + ;poerr("pharmst")=will contain 'ZE'if rx has expired, poerr("comm")=Comments, poerr("user")=Person placing request +EN(POERR) ; + N PSZORS,III + F OO=0:0 S OO=$O(MSG(OO)) Q:'OO I $P(MSG(OO),"|")="ZRN" S NVA=1 + I $G(NVA) G NVA + G:POERR("PSOFILNM")'["S" RXO S III=+POERR("PSOFILNM") + S ORS=0 I $D(^PS(52.41,III,0)) D G PEXIT + .Q:$P($G(^PS(52.41,III,0)),"^",3)="RF" + .I $G(PDFN),$P($G(^PS(52.41,III,0)),"^",2),PDFN'=$P(^PS(52.41,III,0),"^",2) S ORS=1 +RXO S III=POERR("PSOFILNM") I $D(^PSRX(III,0)) D G PEXIT + .I $G(PDFN),$P($G(^PSRX(III,0)),"^",2),PDFN'=$P(^PSRX(III,0),"^",2) S ORS=1 + S (ORS,PSZORS)=1 +PEXIT I $G(ORS) S POERR("STAT")=$S(POERR("STAT")="CA":"UC",POERR("STAT")="DC":"UD",POERR("STAT")="HD":"UH",1:"UR"),POERR("FILLER")="",POERR("COMM")=$S($G(PSZORS):"Unable to locate order.",1:"Patient does not match.") K ORS,PSZORS,III Q + S POERR("PHARMST")="" G:POERR("STAT")="HD"!(POERR("STAT")="RL") HD + S ORS=0 I POERR("PSOFILNM")["S" S DA=+POERR("PSOFILNM") I $D(^PS(52.41,DA,0)) D G EXIT + .Q:$P($G(^PS(52.41,DA,0)),"^",3)="RF" + .S $P(^PS(52.41,DA,0),"^",3)="DC",POERR("PLACE")=$P(^(0),"^"),POERR("STAT")="CR",POERR("FILLER")=DA_"^P" + .K ^PS(52.41,"AOR",+$P($G(^PS(52.41,DA,0)),"^",2),+$P($G(^PS(52.41,DA,"INI")),"^"),DA) + .S:$G(POERR("COMM"))']"" POERR("COMM")="Order Canceled by OE/RR before finishing." S ORS=1,$P(^PS(52.41,DA,4),"^")=$G(POERR("COMM")) + S DA=POERR("PSOFILNM") D:$D(^PSRX(DA,0)) REVERSE^PSOBPSU1(DA,,"DC",7) + I $D(^PSRX(DA,0)) D S $P(^PSRX(DA,"STA"),"^")=14,$P(^PSRX(DA,3),"^",5)=DT,$P(^PSRX(DA,3),"^",10)=$P(^PSRX(DA,3),"^") D CAN^PSOTPCAN(DA) G EXIT + .;cancel/discontinue action + .S POERR("PLACE")=+$P($G(^PSRX(DA,"OR1")),"^",2),POERR("STAT")=$S(POERR("STAT")="CA":"CR",1:"DR"),POERR("FILLER")=DA_"^R" + .S:'$D(POERR("COMM")) POERR("COMM")="Prescription DISCONTINUED by OERR" + .S ORS=1 D CAN +EXIT I '$G(ORS) D + .S POERR("STAT")=$S(POERR("STAT")="CA":"UC",POERR("STAT")="DC":"UD",POERR("STAT")="HD":"UH",1:"UR"),POERR("FILLER")="",POERR("COMM")="Order was not located by Pharmacy" + K EXP,ORS,DA,ACOM,RXDA,SUSD,PSUS,RXF,I,FDA,DIC,DIE,DR,Y,X,%,%I,%H,RSDT,ACNT,ACT,DIK,FDT,IR,LFD,NOW,ORD,PSDA,PSCDA,PSODFN,PSUS,RF,RFCNT,RXN,RXP,RXREF,SD,SUB + Q +CAN S ACOM="Discontinued by OE/RR." I $P(^PSRX(DA,"STA"),"^")=3!($P(^("STA"),"^")=16) D + .S ACOM="Discontinued by OE/RR while on hold. " K:$P(^PSRX(DA,"H"),"^") ^PSRX("AH",$P(^PSRX(DA,"H"),"^"),DA) S ^PSRX(DA,"H")="" + .I $P(^PSRX(DA,0),"^",13),'$O(^PSRX(DA,1,0)) S DIE=52,DR="22///"_$E($P(^PSRX(DA,0),"^",13),1,7) D ^DIE K DIE,DR Q + .S (IFN,SUSD)=0 F S IFN=$O(^PSRX(DA,1,IFN)) Q:'IFN S SUSD=IFN,RFDT=$P(^PSRX(DA,1,IFN,0),"^") + .Q:'$G(SUSD) I '$P(^PSRX(DA,1,SUSD,0),"^",18) S PSDTEST=0 D I 'PSDTEST K ^PSRX(DA,1,SUSD),^PSRX("AD",RFDT,DA,SUSD),^PSRX(DA,1,"B",RFDT,SUSD),IFN,SUSD,RFDT + ..F PDA=0:0 S PDA=$O(^PSRX(DA,"L",PDA)) Q:'PDA I $P($G(^PSRX(DA,"L",PDA,0)),"^",2)=SUSD S PSDTEST=1 + ..K CMOP D ^PSOCMOPA I $G(CMOP(CMOP("L")))="",$G(CMOP("S"))'="L" Q + ..S PSDTEST=1 + S RXDA=DA,(DA,SUSDA)=$O(^PS(52.5,"B",DA,0)) D:DA + .S SUSD=$P($G(^PS(52.5,DA,0)),"^",2) + .S:+$G(^PS(52.5,DA,"P"))'=1 ACOM="Discontinued by OE/RR while suspended." + .I $O(^PSRX(RXDA,1,0)) S DA=RXDA D:'$G(^PS(52.5,+SUSDA,"P")) REF^PSOCAN2 + .S DA=SUSDA,DIK="^PS(52.5," D ^DIK K DIK + K SUSD,SUSDA S DA=RXDA,RXREF=0,PSODFN=+$P(^PSRX(DA,0),"^",2) D + .S ACNT=0 F SUB=0:0 S SUB=$O(^PSRX(DA,"A",SUB)) Q:'SUB S ACNT=SUB + .S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(DA,1,RF)) Q:'RF S RFCNT=RF S:RF>5 RFCNT=RF+1 + .D NOW^%DTC S ^PSRX(DA,"A",0)="^52.3DA^"_(ACNT+1)_"^"_(ACNT+1),^PSRX(DA,"A",ACNT+1,0)=%_"^C^"_POERR("USER")_"^"_RFCNT_"^"_$G(ACOM) + .S REA="C" D EXP^PSOHELP1 + I $G(^PS(52.4,DA,0))]"" S PSCDA=DA,DIK="^PS(52.4," D ^DIK S DA=PSCDA K DIK,PSCDA + Q +HD ;place order on hold + G:POERR("STAT")="RL" REL^PSOORUT1 S (ACT,ORS)=0 I POERR("PSOFILNM")["S" D G EXIT + .S DA=+POERR("PSOFILNM") + .Q:'$D(^PS(52.41,DA,0)) Q:$P(^PS(52.41,DA,0),"^",3)="RF" + .S $P(^PS(52.41,DA,0),"^",3)="HD",POERR("STAT")="HR",POERR("FILLER")=DA_"^P" + .S:$G(POERR("COMM"))']"" POERR("COMM")="Order PLACED on HOLD by OERR before finished." S $P(^PS(52.41,DA,4),"^")=POERR("COMM"),ORS=1 + S DA=POERR("PSOFILNM") I $D(^PSRX(DA,0)) S ORS=1,PSDA=DA D G EXIT + .S POERR("FILLER")=DA_"^R" + .S:'$D(POERR("COMM")) POERR("COMM")="Prescription Placed on HOLD by OERR" + .I DT>$P(^PSRX(DA,2),"^",6) S EXP=$P(^(2),"^",6) S:$P(^PSRX(DA,"STA"),"^")<12 $P(^PSRX(DA,"STA"),"^")=11,PSOEXFLG=1 S POERR("STAT")="UH",POERR("COMM")="Prescription EXPIRED on "_$E(EXP,4,5)_"/"_$E(EXP,6,7)_"/"_$E(EXP,2,3)_"." D Q + ..D ECAN^PSOUTL(DA) + .I $P(^PSRX(DA,"STA"),"^")=3!($P(^("STA"),"^")>11) S POERR("STAT")="UH",POERR("COMM")="Unable to place on HOLD" Q + .S $P(^PSRX(DA,"STA"),"^")=16,POERR("STAT")="HR",^PSRX(DA,"H")=99_"^"_POERR("COMM")_"^"_DT + .S (PSUS,RXF)=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I S RXF=I S:RXF>1 RSDT=$P(^(RXF-1,0),"^") + .S DA=PSDA D ACT D REVERSE^PSOBPSU1(DA,,"HLD",2) + .S DA=$O(^PS(52.5,"B",PSDA,0)) I DA S DIK="^PS(52.5,",PSUS=1 D ^DIK K DA,DIK + I 'ORS S POERR("COMM")="Unable to place order on HOLD" G EXIT + Q +NVA ;non-va med action + N DIE,DR,DA K NVA + I POERR("PSOFILNM")'["N"!('$D(^PS(55,PDFN,"NVA",+POERR("PSOFILNM"),0))) D EN^ORERR("Order was not located by Pharmacy",.MSG) Q + I $G(OR("STAT"))'="CA",$G(OR("STAT"))'="DC" D EN^ORERR("Invalid Order Control Code",.MSG) Q +XO S ORD=+POERR("PSOFILNM") + N TMP + D NOW^%DTC + K TMP S TMP(55.05,ORD_","_PDFN_",",5)=$S($G(PSODEATH):2,1:1) + S TMP(55.05,ORD_","_PDFN_",",6)=% + D FILE^DIE("","TMP") + S PLACER=$P(^PS(55,PDFN,"NVA",ORD,0),"^",8) + K MSG S NULLFLDS="F JJ=0:1:LIMIT S FIELD(JJ)=""""" + K ^UTILITY("DIQ1",$J),DIQ S DA=$P($$SITE^VASITE(),"^") + I $G(DA) S DIC=4,DIQ(0)="I",DR="99" D EN^DIQ1 S PSOHINST=$G(^UTILITY("DIQ1",$J,4,DA,99,"I")) K ^UTILITY("DIQ1",$J),DA,DR,DIQ,DIC + S MSG(1)="MSH|^~\&|PHARMACY|"_$G(PSOHINST)_"|||||ORR" + ; + S DFN=PDFN,COUNT=1,LIMIT=5 X NULLFLDS D DEM^VADPT S NAME=$G(VADM(1)) K VADM + S FIELD(0)="PID",FIELD(3)=DFN,FIELD(5)=NAME + D SEG^PSOHLSN1 + ; + S LIMIT=15 X NULLFLDS + S FIELD(0)="ORC",FIELD(2)=PLACER_"^OR",FIELD(3)=+POERR("PSOFILNM")_"N^PS" + S FIELD(1)="SC",FIELD(5)="DC" + D SEG^PSOHLSN1 + I $G(PSODEATH) S MSG(COUNT)=MSG(COUNT)_"|^^^^DATE OF DEATH ENTERED BY MAS.^" + ; + D SEND^PSOHLSN1 K FIELDS,LIMIT,PSODSC,PSONVA,OI + Q + ; +ACT ;activity log + D NOW^%DTC S NOW=% + S IR=0 F FDA=0:0 S FDA=$O(^PSRX(DA,"A",FDA)) Q:'FDA S IR=FDA + S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR + S ^PSRX(DA,"A",IR,0)=NOW_"^"_$S(ACT:"U",1:"H")_"^"_POERR("USER")_"^"_RXF_"^"_"RX "_$S('ACT:"placed in a",1:"removed from")_" HOLD status "_$S(+$G(PSUS):"and removed from SUSPENSE ",1:"")_"("_$E(DT,4,5)_"-"_$E(DT,6,7)_"-"_$E(DT,2,3)_") by OERR." + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOPFSU0.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOPFSU0.m index 1fc1768d..59e5dcc9 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOPFSU0.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOPFSU0.m @@ -1,107 +1,107 @@ -PSOPFSU0 ;BIR/LE,AM - PFSS Get Account & Utilities ;08/09/93 - ;;7.0;OUTPATIENT PHARMACY;**201,225**;DEC 1997;Build 29 - ;External reference SWSTAT^IBBAPI supported by DBIA 4663 - ;External reference GETACCT^IBBAPI supported by DBIA 4664 - ;External reference ^DG(40.8,"AD" supported by DBIA 2817 - Q - ; -GACT(PSORXN,PSOREF) ;ENTRY POINT: Called from PSON52; PSOR52, PSORN52. Get a PFSS acct ref - ; This routine is only called when the PFSS Switch is on. - ; - N I,J,PSOPFSAC,PSOPV1,PSODG,PSOZCL,PSODFN,PSORX,PSOPV2,PSODIV - ;for sending to an external billing system, get data from file 52, build arrays for IBB API call - I PSOREF=0 D GACTOF - I PSOREF>0 D GACTRF - ;Get general Rx data fields - S PSODIV=$$MCDIV(PSORXN,PSOREF) - S PSODFN=$$GET1^DIQ(52,PSORXN,"2","I") - S PSOPV1(2)="O",PSOPV1(50)=PSORXN - S PSOPV1(3)=$$CHLOC() - Q:PSOPV1(3)="" 0 ;can't do GETACCT if CHARGE LOCATION is null; this is to be address in subsequent PFSS project phase - ;request the PFSS Acct Rev - S PSOPFSAC=$$GETACCT^IBBAPI(PSODFN,"","A04","GACT;PSOPFSU0",.PSOPV1,"","",.PSODG,.PSOZCL,PSODIV,"") - ;Store the PFS Acct Ref with speed in mind - Q:PSOPFSAC<1 "" - I PSOREF=0 S $P(^PSRX(PSORXN,"PFS"),"^")=PSOPFSAC - I PSOREF>0 S $P(^PSRX(PSORXN,1,PSOREF,"PFS"),"^")=PSOPFSAC - Q PSOPFSAC - ; -GACTOF ;Get orig fill data - D GETS^DIQ(52,PSORXN,"4;22","I","PSORX") - S PSOPV1(7)=$G(PSORX(52,PSORXN_",",4,"I")),PSOPV1(44)=$G(PSORX(52,PSORXN_",",22,"I")) - D GOC - Q - ; -GACTRF ;Called from GACT. Get refill data - D GETS^DIQ(52.1,PSOREF_","_PSORXN,".01;15","I","PSORX") - S PSOPV1(7)=$G(PSORX(52.1,PSOREF_","_PSORXN_",","15","I")) - S PSOPV1(44)=$G(PSORX(52.1,PSOREF_","_PSORXN_",",".01","I")) - D GOC - Q - ; -CHLOC() ;FIND CHARGE LOCATION - N CHLOC,CL,PDIV - I PSOREF=0 S PDIV=$$GET1^DIQ(52,PSORXN,"20","I") ;DIVISION - I PSOREF>0 S PDIV=$$GET1^DIQ(52.1,PSOREF_","_PSORXN_",","8","I") - S CHLOC=$$GET1^DIQ(59,PDIV,1007,"I") ;Charge location pointer - I CHLOC="" S CL="" D CLOK S:CL>0 CHLOC=CL - Q CHLOC - ; -GOC ;Called from GACTOF and GACTRF. Parse OP classifications and ICD's. Don't send null values. - D GETS^DIQ(52,PSORXN,"52311*","I","PSORX") - F I=1:1 Q:'$D(PSORX(52.052311,I_","_PSORXN_",")) D - . S:PSORX(52.052311,I_","_PSORXN_",",".01","I")'="" PSODG(I,3)=PSORX(52.052311,I_","_PSORXN_",",".01","I"),PSODG(I,6)="W" - . I I=1 F J=1:1:8 Q:'$D(PSORX(52.052311,I_","_PSORXN_",",J,"I")) D - . . S:PSORX(52.052311,I_","_PSORXN_",",J,"I")'="" PSOZCL(J,2)=J,PSOZCL(J,3)=PSORX(52.052311,I_","_PSORXN_",",J,"I") - S:'$D(PSOZCL) PSOZCL="" S:'$D(PSODG) PSODG="" - Q - ; -RPH(PSORXN,PSOREF) ;API entry point - ; Inputs: PSORXN = prescription IEN, PSOREF = fill number - ; Outputs: PSORPH = rel pharm IEN ^ user IEN who performed last activity or rel pharm iF no activity entries^ - ; IB Service Section pointer from file 59 - ; Returns null values when the Rx is not released or the input values are invalid (i.e. "^^"). - N I,II,IBSS,DIV,PSORPH,PSOEDPH,PSOA,PSORDT,PSOOK,PSOA,DATA - S PSOOK=$$CHKRX(PSORXN,PSOREF) Q:PSOOK'=1 "^^" - I 'PSOREF D GETS^DIQ(52,PSORXN,"20;23;31","I","DATA") - E D GETS^DIQ(52.1,PSOREF_","_PSORXN,"4;8;17","I","DATA") - I PSOREF=0 D - . S PSORPH=+$G(DATA(52,PSORXN_",",23,"I")) S:PSORPH=0 PSORPH="" - . S DIV=+$G(DATA(52,PSORXN_",",20,"I")) - . S PSORDT=+$G(DATA(52,PSORXN_",",31,"I")) - I PSOREF>0 D - . S PSORPH=+$G(DATA(52.1,PSOREF_","_PSORXN_",",4,"I")) S:PSORPH=0 PSORPH="" - . S DIV=+$G(DATA(52.1,PSOREF_","_PSORXN_",",8,"I")) - . S PSORDT=+$G(DATA(52.1,PSOREF_","_PSORXN_",",17,"I")) - Q:PSORDT=0 "^^" - ;last activity - get last one with a user - I $D(^PSRX(PSORXN,"A",0)) S PSOA=$P(^PSRX(PSORXN,"A",0),"^",3) D - . F II=PSOA:-1:1 S PSOEDPH=$$GET1^DIQ(52.3,II_","_PSORXN_",",".03","I") Q:PSOEDPH'="" - ;get IB Service Section (requested by Ed Z. on 6/29/05) - S IBSS=$P($G(^PS(59,DIV,"IB")),"^") - S:'$G(PSOEDPH) PSOEDPH=PSORPH - S PSORPH=$G(PSORPH)_"^"_$G(PSOEDPH)_"^"_$G(IBSS) - Q PSORPH - ; -CHKRX(PSORX,PSOF) ;validates Rx & fill. 0=not valid, 1=valid, 2=refill not valid - Q:PSORX=""!(PSOF="") 0 - Q:'$D(^PSRX(PSORX)) 0 - Q:PSOF>0&('$D(^PSRX(PSORX,1,PSOF))) 2 - Q 1 - ; -MCDIV(RX,FILL) ;Get MC DIVISION from the Rx/Fill - N DIV,INST - ; outpatient division - I 'FILL S DIV=$$GET1^DIQ(52,RX,20,"I") - E S DIV=$$GET1^DIQ(52.1,FILL_","_RX,8,"I") - Q:'DIV "" - ; related institution - S INST=$$GET1^DIQ(59,DIV,100,"I") Q:'INST "" - S DIV=$O(^DG(40.8,"AD",INST,0)) ; pointer to medical center division - Q DIV - ; -CLOK ; - N I S I=0 F S I=$O(^PS(59,I)) Q:'I!(CL>0) D - . I $S('$D(^PS(59,I,"I")):1,'+$P(^("I"),"^"):1,DT'>+$P(^("I"),"^"):1,1:0) S CL=$P($G(^PS(59,I,"PFS")),"^") - Q - ; +PSOPFSU0 ;BIR/LE,AM - PFSS Get Account & Utilities ;08/09/93 + ;;7.0;OUTPATIENT PHARMACY;**201**;DEC 1997 + ;External reference SWSTAT^IBBAPI supported by DBIA 4663 + ;External reference GETACCT^IBBAPI supported by DBIA 4664 + ;External reference ^DG(40.8,"AD" supported by DBIA 2817 + Q + ; +GACT(PSORXN,PSOREF) ;ENTRY POINT: Called from PSON52; PSOR52, PSORN52. Get a PFSS acct ref + ; This routine is only called when the PFSS Switch is on. + ; + N I,J,PSOPFSAC,PSOPV1,PSODG,PSOZCL,PSODFN,PSORX,PSOPV2,PSODIV + ;for sending to an external billing system, get data from file 52, build arrays for IBB API call + I PSOREF=0 D GACTOF + I PSOREF>0 D GACTRF + ;Get general Rx data fields + S PSODIV=$$MCDIV(PSORXN,PSOREF) + S PSODFN=$$GET1^DIQ(52,PSORXN,"2","I") + S PSOPV1(2)="O",PSOPV1(50)=PSORXN + S PSOPV1(3)=$$CHLOC() + Q:PSOPV1(3)="" 0 ;can't do GETACCT if CHARGE LOCATION is null; this is to be address in subsequent PFSS project phase + ;request the PFSS Acct Rev + S PSOPFSAC=$$GETACCT^IBBAPI(PSODFN,"","A04","GACT;PSOPFSU0",.PSOPV1,"","",.PSODG,.PSOZCL,PSODIV,"") + ;Store the PFS Acct Ref with speed in mind + Q:PSOPFSAC<1 "" + I PSOREF=0 S $P(^PSRX(PSORXN,"PFS"),"^")=PSOPFSAC + I PSOREF>0 S $P(^PSRX(PSORXN,1,PSOREF,"PFS"),"^")=PSOPFSAC + Q PSOPFSAC + ; +GACTOF ;Get orig fill data + D GETS^DIQ(52,PSORXN,"4;22","I","PSORX") + S PSOPV1(7)=$G(PSORX(52,PSORXN_",",4,"I")),PSOPV1(44)=$G(PSORX(52,PSORXN_",",22,"I")) + D GOC + Q + ; +GACTRF ;Called from GACT. Get refill data + D GETS^DIQ(52.1,PSOREF_","_PSORXN,".01;15","I","PSORX") + S PSOPV1(7)=$G(PSORX(52.1,PSOREF_","_PSORXN_",","15","I")) + S PSOPV1(44)=$G(PSORX(52.1,PSOREF_","_PSORXN_",",".01","I")) + D GOC + Q + ; +CHLOC() ;FIND CHARGE LOCATION + N CHLOC,CL,PDIV + I PSOREF=0 S PDIV=$$GET1^DIQ(52,PSORXN,"20","I") ;DIVISION + I PSOREF>0 S PDIV=$$GET1^DIQ(52.1,PSOREF_","_PSORXN_",","8","I") + S CHLOC=$$GET1^DIQ(59,PDIV,1007,"I") ;Charge location pointer + I CHLOC="" S CL="" D CLOK S:CL>0 CHLOC=CL + Q CHLOC + ; +GOC ;Called from GACTOF and GACTRF. Parse OP classifications and ICD's. Don't send null values. + D GETS^DIQ(52,PSORXN,"52311*","I","PSORX") + F I=1:1 Q:'$D(PSORX(52.052311,I_","_PSORXN_",")) D + . S:PSORX(52.052311,I_","_PSORXN_",",".01","I")'="" PSODG(I,3)=PSORX(52.052311,I_","_PSORXN_",",".01","I"),PSODG(I,6)="W" + . I I=1 F J=1:1:7 Q:'$D(PSORX(52.052311,I_","_PSORXN_",",J,"I")) D + . . S:PSORX(52.052311,I_","_PSORXN_",",J,"I")'="" PSOZCL(J,2)=J,PSOZCL(J,3)=PSORX(52.052311,I_","_PSORXN_",",J,"I") + S:'$D(PSOZCL) PSOZCL="" S:'$D(PSODG) PSODG="" + Q + ; +RPH(PSORXN,PSOREF) ;API entry point + ; Inputs: PSORXN = prescription IEN, PSOREF = fill number + ; Outputs: PSORPH = rel pharm IEN ^ user IEN who performed last activity or rel pharm iF no activity entries^ + ; IB Service Section pointer from file 59 + ; Returns null values when the Rx is not released or the input values are invalid (i.e. "^^"). + N I,II,IBSS,DIV,PSORPH,PSOEDPH,PSOA,PSORDT,PSOOK,PSOA,DATA + S PSOOK=$$CHKRX(PSORXN,PSOREF) Q:PSOOK'=1 "^^" + I 'PSOREF D GETS^DIQ(52,PSORXN,"20;23;31","I","DATA") + E D GETS^DIQ(52.1,PSOREF_","_PSORXN,"4;8;17","I","DATA") + I PSOREF=0 D + . S PSORPH=+$G(DATA(52,PSORXN_",",23,"I")) S:PSORPH=0 PSORPH="" + . S DIV=+$G(DATA(52,PSORXN_",",20,"I")) + . S PSORDT=+$G(DATA(52,PSORXN_",",31,"I")) + I PSOREF>0 D + . S PSORPH=+$G(DATA(52.1,PSOREF_","_PSORXN_",",4,"I")) S:PSORPH=0 PSORPH="" + . S DIV=+$G(DATA(52.1,PSOREF_","_PSORXN_",",8,"I")) + . S PSORDT=+$G(DATA(52.1,PSOREF_","_PSORXN_",",17,"I")) + Q:PSORDT=0 "^^" + ;last activity - get last one with a user + I $D(^PSRX(PSORXN,"A",0)) S PSOA=$P(^PSRX(PSORXN,"A",0),"^",3) D + . F II=PSOA:-1:1 S PSOEDPH=$$GET1^DIQ(52.3,II_","_PSORXN_",",".03","I") Q:PSOEDPH'="" + ;get IB Service Section (requested by Ed Z. on 6/29/05) + S IBSS=$P($G(^PS(59,DIV,"IB")),"^") + S:'$G(PSOEDPH) PSOEDPH=PSORPH + S PSORPH=$G(PSORPH)_"^"_$G(PSOEDPH)_"^"_$G(IBSS) + Q PSORPH + ; +CHKRX(PSORX,PSOF) ;validates Rx & fill. 0=not valid, 1=valid, 2=refill not valid + Q:PSORX=""!(PSOF="") 0 + Q:'$D(^PSRX(PSORX)) 0 + Q:PSOF>0&('$D(^PSRX(PSORX,1,PSOF))) 2 + Q 1 + ; +MCDIV(RX,FILL) ;Get MC DIVISION from the Rx/Fill + N DIV,INST + ; outpatient division + I 'FILL S DIV=$$GET1^DIQ(52,RX,20,"I") + E S DIV=$$GET1^DIQ(52.1,FILL_","_RX,8,"I") + Q:'DIV "" + ; related institution + S INST=$$GET1^DIQ(59,DIV,100,"I") Q:'INST "" + S DIV=$O(^DG(40.8,"AD",INST,0)) ; pointer to medical center division + Q DIV + ; +CLOK ; + N I S I=0 F S I=$O(^PS(59,I)) Q:'I!(CL>0) D + . I $S('$D(^PS(59,I,"I")):1,'+$P(^("I"),"^"):1,DT'>+$P(^("I"),"^"):1,1:0) S CL=$P($G(^PS(59,I,"PFS")),"^") + Q + ; diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOPFSU1.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOPFSU1.m index b44cbffa..3c365a65 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOPFSU1.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOPFSU1.m @@ -1,132 +1,132 @@ -PSOPFSU1 ;BIR/LE,AM - PFSS Charge Message & Utilities ;08/09/93 - ;;7.0;OUTPATIENT PHARMACY;**201,225**;DEC 1997;Build 29 - ;External reference CHARGE^IBBAPI and GETCHGID^IBBAPI supported by DBIA 4665 - Q - ; -CHRG(PSORXN,PSOREF,PSOCHTYP,PSOPFS) ;ENTRY POINT: - ;Used to pass charge msg info to an external billing system via IBB API's - ; Inputs: PSORXN = RX IEN, PSOREF = fill number, PSOCHTYP = "CG" for Charge or "CD" for Credit transaction, - ; PSOPFS = switch status (0 or 1) ^ PFSS Account Reference for the fill ^ PFSS Charge ID for the fill - ; Outputs: none - ; - N I,CLDIV,IFN,J,PSODG,PSOZCL,PSOCHID,PSOPFSA,PSODFN,PSORX,PSOFT1,PSODRG,PSODRUG,PSORXE,PSOCHG,PSOFD,PSOFT,PSOFLD - ; quit if PFSS switch is off or not defined - Q:'+$G(PSOPFS) - ; - ; check for CHARGE LOCATION before processing charge message. - S CLDIV=$$CHLOC^PSOPFSU0() - Q:CLDIV<1 ;if no CHARGE LOCATION, don't send charge message to either IB or external billing system. - ; - ; check for PFSS Acct Reference; if not one define, request one - S PSOPFSA=$P(PSOPFS,"^",2) - I PSOPFSA<1 D PFSI(PSORXN,PSOREF) S PSOPFSA=$P(PSOPFS,"^",2) I PSOPFSA<1 D ;because PSOCP is too large, need to check for/get them here - .S PSOPFSA=$$GACT^PSOPFSU0(PSORXN,PSOREF) - Q:PSOPFSA<1 ;Normally IB returns an acct ref or zero for unsuccessful if a problem is encountered. - ; If IBB didn't return a value, don't send charge message because IBB will produce a hard error. Subsequent phase of PFSS will provide further error handling. - ; - ; check for PFSS Charge ID. If no charge ID, means Rx never sent to external bill sys or there was a problem retrieve one. - S PSOCHID=$P(PSOPFS,"^",3) - ;If no Charge ID is defined, request a Unique Charge ID and store it in file 52 - I PSOCHID<1 S PSOCHID=$$GETCHGID^IBBAPI() I PSOCHID>0 D - . I PSOREF=0 S $P(^PSRX(PSORXN,"PFS"),"^",2)=PSOCHID ;set directly for speed (CMOPs, etc.) - . I PSOREF>0 S $P(^PSRX(PSORXN,1,PSOREF,"PFS"),"^",2)=PSOCHID - Q:PSOCHID<1 ;no charge message will be sent if can't get a PFSS CHARGE ID from IB. Subsequent phase of PFSS will provide error handling for this type problem. - ;Retrieve all fields to pass for the charge message - S PSOFT="4,10,21" I PSOREF=0 D CHRGOF - I PSOREF>0 D CHRGRF - ;Get general Rx data fields - D GETS^DIQ(52,PSORXN,"2;3;6;105","I","PSORX") - S PSOFT1(29)=$$NDC^PSOHDR(PSORXN,PSOREF,$S(PSOREF>0:"R",1:"")) - S PSODFN=$G(PSORX(52,PSORXN_",",2,"I")),PSODRG=$G(PSORX(52,PSORXN_",",6,"I")),PSOFT1(31)=$G(PSORX(52,PSORXN_",",105,"I")) - D DATA^PSS50(PSODRG,,,,,"PSOSC") - ;S PSOFT1(2)="PSO"_PSORXN_"F"_PSOREF ;12/6/05; DECISION MADE TO NOT SEND clinicial event indicator FOR OP - S PSOFT1(7)=$G(^TMP($J,"PSOSC",PSODRG,400)),PSOFT1(6)=PSOCHTYP,PSOFT1(13)=160 - S PSOFT1(18)=$G(PSORX(52,PSORXN_",",3,"I")),PSOFT1(18)=$$GET1^DIQ(53,PSOFT1(18)_",",15,"I") - S PSOFT1(22)=$FN($G(^TMP($J,"PSOSC",PSODRG,16)),"",2),PSOFT1(29)=PSOFT1(29)_";"_$G(^TMP($J,"PSOSC",PSODRG,.01)) - S PSORXE(31)=$G(^TMP($J,"PSOSC",PSODRG,3)),PSORXE(17)=PSOREF - S:(PSORXE(18)="") PSORXE(18)=$G(RELDT) ;CMOP - S PSORXE(15)=PSORXN - S PSOCHG=$$CHARGE^IBBAPI(PSODFN,PSOPFSA,PSOCHTYP,PSOCHID,.PSOFT1,"",.PSODG,.PSOZCL,.PSORXE,"","") - ;errors to be handled in subsequent phase - K ^TMP($J,"PSOSC") - Q - ; -CHRGOF ;Retrieve charge fields for orig fills - D GETS^DIQ(52,PSORXN,"4;7;8;22;31;125","I","PSORX") - S PSOFD="22,7,4" - F I=1:1 S PSOFLD=$P(PSOFD,",",I) Q:PSOFLD="" S PSOFT1($P(PSOFT,",",I))=$G(PSORX(52,PSORXN_",",$P(PSOFD,",",I),"I")) - S PSOPFSA=$G(PSORX(52,PSORXN_",",125,"I")),PSORXE(18)=$G(PSORX(52,PSORXN_",",31,"I")) - S PSORXE(1)=PSOFT1(10)_";;"_$G(PSORX(52,PSORXN_",",8,"I")) - D GOC - Q - ; -CHRGRF ;Retrieve charge fields for refills - D GETS^DIQ(52.1,PSOREF_","_PSORXN,".01;1;1.1;15;17;21","I","PSORX") - S PSOFD=".01,1,15" - F I=1:1 S PSOFLD=$P(PSOFD,",",I) Q:PSOFLD="" S PSOFT1($P(PSOFT,",",I))=$G(PSORX(52.1,PSOREF_","_PSORXN_",",$P(PSOFD,",",I),"I")) - S PSOPFSA=$G(PSORX(52.1,PSOREF_","_PSORXN_",",21,"I")),PSORXE(18)=$G(PSORX(52.1,PSOREF_","_PSORXN_",",17,"I")) - S PSORXE(1)=PSOFT1(10)_";;"_$G(PSORX(52.1,PSOREF_","_PSORXN_",",1.1,"I")) - D GOC - Q - ; -GOC ;Called from CHRGOF, CHRGRF. Parse OP classifications and ICD's. Don't send null values. - D GETS^DIQ(52,PSORXN,"52311*","I","PSORX") - F I=1:1 Q:'$D(PSORX(52.052311,I_","_PSORXN_",")) D - . S:PSORX(52.052311,I_","_PSORXN_",",".01","I")'="" PSODG(I,3)=PSORX(52.052311,I_","_PSORXN_",",".01","I"),PSODG(I,6)="F" - . I I=1 F J=1:1:8 Q:'$D(PSORX(52.052311,I_","_PSORXN_",",J,"I")) D - . . S:PSORX(52.052311,I_","_PSORXN_",",J,"I")'="" PSOZCL(J,2)=J,PSOZCL(J,3)=PSORX(52.052311,I_","_PSORXN_",",J,"I") - S:'$D(PSOZCL) PSOZCL="" S:'$D(PSODG) PSODG="" - Q - ; -CG ;Called from PSOCPB; for the last fill, send chrg message if released; PSOCPB too large for more code. - ; this is used for SC/EI changes when no charges are cancelled. Expects to have PSODA = RXIEN and PSOLFIL= fill# - ;N REL,PFS - ;I 'PSOLFIL S REL=$$GET1^DIQ(52,PSODA_",","31","I") - ;I PSOLFIL>0 S REL=$$GET1^DIQ(52.1,PSOLFIL_","_PSODA_",","17","I") ;REFILL - ;I REL'=""&(PSOPFS)&(+$G(PSOPFSA)) D CHRG(PSODA,PSOLFIL,"CG",PSOPFS) - Q - ; -LF(PSODA) ;return last fill number;CALLED from PSOCPB - N LF - I $D(^PSRX(PSODA,1,0)) S LF="A",LF=$O(^PSRX(PSODA,1,LF),-1) Q LF - Q 0 ;ORIG FILL - ; -PFSI(PSODA,PSOREF) ;get PFSS Acct Ref and Charge ID and store in PSOPFS; Called from multiple places in this routine - I PSOREF=0&($D(^PSRX(PSODA,"PFS"))) S PSOPFS=PSOPFS_"^"_$P(^PSRX(PSODA,"PFS"),"^",1,2) Q - I PSOREF>0&($D(^PSRX(PSODA,1,PSOREF,"PFS"))) S PSOPFS=PSOPFS_"^"_$P(^PSRX(PSODA,1,PSOREF,"PFS"),"^",1,2) - Q - ; -PFSA(PSODA,PSOREF,WR) ;called from PSOCP (WR=2) and PSOCPB (WR=3) - ;get switch status, acct ref, and charge ID, then validate switch vs availability of PFSS acct ref - Q:'$G(WR) - S PSOPFS=+$$SWSTAT^IBBAPI() - D PFSI(PSODA,PSOREF) - ; if switch is off, but have an PFSS Acct Ref for new orders, send charge to IDX - ; if switch is off, but have a Charge ID, send cancel charge to IDX - I '+PSOPFS,$P(PSOPFS,"^",WR)>0 S $P(PSOPFS,"^")=1 - Q - ; -PFS ;;Called from PSOCPB; PSOCPB is too large to hold more code. Processes copay cancels for PFS only. - ;find any fills being cancelled for PFSS, cancel them, and remove them from PSOCAN, then return to PSOCP to process any IB cancels - ; - N X,I,PSOREF,PSOOLD,PREA,PSONW - ;If it's a PFS fill, if released, and not previously cancelled, set the X array, then kill it out of PSOCAN array. - ;Killed out of PSOCAN because don't want the IB processing to look at PFSS billed fills. - ;Note that in PSOCPD, PFS entries are not stored in PSOCAN array if a charge ID is not defined. So, don't have to check for release date. - ;If prev cancelled and PFS, kill it from PSOCAN array - S I="" F S I=$O(PSOCAN(I)) Q:I="" S PSOREF=+PSOCAN(I) D - . I PSOREF=PSODA&($P(PSOCAN(I),"^",10)="PFS") D Q - . . I $P(PSOCAN(I),"^",5)["CANCEL" K PSOCAN(I) Q - . . S X(0)=$P(PSOCAN(I),"^",2)_"^"_PSORSN K PSOCAN(I) - . I PSOREF'=PSODA&($P(PSOCAN(I),"^",10)="PFS") D - . . I $P(PSOCAN(I),"^",5)["CANCEL" K PSOCAN(I) Q - . . S X(PSOREF)=$P(PSOCAN(I),"^",2)_"^"_PSORSN K PSOCAN(I) - I $G(CANTYPE)&('$D(X)) D MSGNOCAN^PSOCPB Q ;CANTYPE=1 means trying cancelling all fills;can't cancel twice - ; - ;send charge messages, set activity log, display message - S PREA="C",PSOREF="" - F S PSOREF=$O(X(PSOREF)) Q:PSOREF="" S PSOPFS=1 D PFSI(PSODA,PSOREF) D CHRG(PSODA,PSOREF,"CD",PSOPFS) D ACTLOG^PSOCPA D:'$G(CANTYPE) MSG^PSOCPB - I $G(CANTYPE)&('$D(PSOCAN)) D MSG^PSOCPB ;if cancelling all and no legacy IB bills to cancel, write msg - S PSOPFSA=0 ;reset variable so charge isn't sent twice if SC/EI's were also changed. - Q - ; +PSOPFSU1 ;BIR/LE,AM - PFSS Charge Message & Utilities ;08/09/93 + ;;7.0;OUTPATIENT PHARMACY;**201**;DEC 1997 + ;External reference CHARGE^IBBAPI and GETCHGID^IBBAPI supported by DBIA 4665 + Q + ; +CHRG(PSORXN,PSOREF,PSOCHTYP,PSOPFS) ;ENTRY POINT: + ;Used to pass charge msg info to an external billing system via IBB API's + ; Inputs: PSORXN = RX IEN, PSOREF = fill number, PSOCHTYP = "CG" for Charge or "CD" for Credit transaction, + ; PSOPFS = switch status (0 or 1) ^ PFSS Account Reference for the fill ^ PFSS Charge ID for the fill + ; Outputs: none + ; + N I,CLDIV,IFN,J,PSODG,PSOZCL,PSOCHID,PSOPFSA,PSODFN,PSORX,PSOFT1,PSODRG,PSODRUG,PSORXE,PSOCHG,PSOFD,PSOFT,PSOFLD + ; quit if PFSS switch is off or not defined + Q:'+$G(PSOPFS) + ; + ; check for CHARGE LOCATION before processing charge message. + S CLDIV=$$CHLOC^PSOPFSU0() + Q:CLDIV<1 ;if no CHARGE LOCATION, don't send charge message to either IB or external billing system. + ; + ; check for PFSS Acct Reference; if not one define, request one + S PSOPFSA=$P(PSOPFS,"^",2) + I PSOPFSA<1 D PFSI(PSORXN,PSOREF) S PSOPFSA=$P(PSOPFS,"^",2) I PSOPFSA<1 D ;because PSOCP is too large, need to check for/get them here + .S PSOPFSA=$$GACT^PSOPFSU0(PSORXN,PSOREF) + Q:PSOPFSA<1 ;Normally IB returns an acct ref or zero for unsuccessful if a problem is encountered. + ; If IBB didn't return a value, don't send charge message because IBB will produce a hard error. Subsequent phase of PFSS will provide further error handling. + ; + ; check for PFSS Charge ID. If no charge ID, means Rx never sent to external bill sys or there was a problem retrieve one. + S PSOCHID=$P(PSOPFS,"^",3) + ;If no Charge ID is defined, request a Unique Charge ID and store it in file 52 + I PSOCHID<1 S PSOCHID=$$GETCHGID^IBBAPI() I PSOCHID>0 D + . I PSOREF=0 S $P(^PSRX(PSORXN,"PFS"),"^",2)=PSOCHID ;set directly for speed (CMOPs, etc.) + . I PSOREF>0 S $P(^PSRX(PSORXN,1,PSOREF,"PFS"),"^",2)=PSOCHID + Q:PSOCHID<1 ;no charge message will be sent if can't get a PFSS CHARGE ID from IB. Subsequent phase of PFSS will provide error handling for this type problem. + ;Retrieve all fields to pass for the charge message + S PSOFT="4,10,21" I PSOREF=0 D CHRGOF + I PSOREF>0 D CHRGRF + ;Get general Rx data fields + D GETS^DIQ(52,PSORXN,"2;3;6;105","I","PSORX") + S PSOFT1(29)=$$NDC^PSOHDR(PSORXN,PSOREF,$S(PSOREF>0:"R",1:"")) + S PSODFN=$G(PSORX(52,PSORXN_",",2,"I")),PSODRG=$G(PSORX(52,PSORXN_",",6,"I")),PSOFT1(31)=$G(PSORX(52,PSORXN_",",105,"I")) + D DATA^PSS50(PSODRG,,,,,"PSOSC") + ;S PSOFT1(2)="PSO"_PSORXN_"F"_PSOREF ;12/6/05; DECISION MADE TO NOT SEND clinicial event indicator FOR OP + S PSOFT1(7)=$G(^TMP($J,"PSOSC",PSODRG,400)),PSOFT1(6)=PSOCHTYP,PSOFT1(13)=160 + S PSOFT1(18)=$G(PSORX(52,PSORXN_",",3,"I")),PSOFT1(18)=$$GET1^DIQ(53,PSOFT1(18)_",",15,"I") + S PSOFT1(22)=$FN($G(^TMP($J,"PSOSC",PSODRG,16)),"",2),PSOFT1(29)=PSOFT1(29)_";"_$G(^TMP($J,"PSOSC",PSODRG,.01)) + S PSORXE(31)=$G(^TMP($J,"PSOSC",PSODRG,3)),PSORXE(17)=PSOREF + S:(PSORXE(18)="") PSORXE(18)=$G(RELDT) ;CMOP + S PSORXE(15)=PSORXN + S PSOCHG=$$CHARGE^IBBAPI(PSODFN,PSOPFSA,PSOCHTYP,PSOCHID,.PSOFT1,"",.PSODG,.PSOZCL,.PSORXE,"","") + ;errors to be handled in subsequent phase + K ^TMP($J,"PSOSC") + Q + ; +CHRGOF ;Retrieve charge fields for orig fills + D GETS^DIQ(52,PSORXN,"4;7;8;22;31;125","I","PSORX") + S PSOFD="22,7,4" + F I=1:1 S PSOFLD=$P(PSOFD,",",I) Q:PSOFLD="" S PSOFT1($P(PSOFT,",",I))=$G(PSORX(52,PSORXN_",",$P(PSOFD,",",I),"I")) + S PSOPFSA=$G(PSORX(52,PSORXN_",",125,"I")),PSORXE(18)=$G(PSORX(52,PSORXN_",",31,"I")) + S PSORXE(1)=PSOFT1(10)_";;"_$G(PSORX(52,PSORXN_",",8,"I")) + D GOC + Q + ; +CHRGRF ;Retrieve charge fields for refills + D GETS^DIQ(52.1,PSOREF_","_PSORXN,".01;1;1.1;15;17;21","I","PSORX") + S PSOFD=".01,1,15" + F I=1:1 S PSOFLD=$P(PSOFD,",",I) Q:PSOFLD="" S PSOFT1($P(PSOFT,",",I))=$G(PSORX(52.1,PSOREF_","_PSORXN_",",$P(PSOFD,",",I),"I")) + S PSOPFSA=$G(PSORX(52.1,PSOREF_","_PSORXN_",",21,"I")),PSORXE(18)=$G(PSORX(52.1,PSOREF_","_PSORXN_",",17,"I")) + S PSORXE(1)=PSOFT1(10)_";;"_$G(PSORX(52.1,PSOREF_","_PSORXN_",",1.1,"I")) + D GOC + Q + ; +GOC ;Called from CHRGOF, CHRGRF. Parse OP classifications and ICD's. Don't send null values. + D GETS^DIQ(52,PSORXN,"52311*","I","PSORX") + F I=1:1 Q:'$D(PSORX(52.052311,I_","_PSORXN_",")) D + . S:PSORX(52.052311,I_","_PSORXN_",",".01","I")'="" PSODG(I,3)=PSORX(52.052311,I_","_PSORXN_",",".01","I"),PSODG(I,6)="F" + . I I=1 F J=1:1:7 Q:'$D(PSORX(52.052311,I_","_PSORXN_",",J,"I")) D + . . S:PSORX(52.052311,I_","_PSORXN_",",J,"I")'="" PSOZCL(J,2)=J,PSOZCL(J,3)=PSORX(52.052311,I_","_PSORXN_",",J,"I") + S:'$D(PSOZCL) PSOZCL="" S:'$D(PSODG) PSODG="" + Q + ; +CG ;Called from PSOCPB; for the last fill, send chrg message if released; PSOCPB too large for more code. + ; this is used for SC/EI changes when no charges are cancelled. Expects to have PSODA = RXIEN and PSOLFIL= fill# + ;N REL,PFS + ;I 'PSOLFIL S REL=$$GET1^DIQ(52,PSODA_",","31","I") + ;I PSOLFIL>0 S REL=$$GET1^DIQ(52.1,PSOLFIL_","_PSODA_",","17","I") ;REFILL + ;I REL'=""&(PSOPFS)&(+$G(PSOPFSA)) D CHRG(PSODA,PSOLFIL,"CG",PSOPFS) + Q + ; +LF(PSODA) ;return last fill number;CALLED from PSOCPB + N LF + I $D(^PSRX(PSODA,1,0)) S LF="A",LF=$O(^PSRX(PSODA,1,LF),-1) Q LF + Q 0 ;ORIG FILL + ; +PFSI(PSODA,PSOREF) ;get PFSS Acct Ref and Charge ID and store in PSOPFS; Called from multiple places in this routine + I PSOREF=0&($D(^PSRX(PSODA,"PFS"))) S PSOPFS=PSOPFS_"^"_$P(^PSRX(PSODA,"PFS"),"^",1,2) Q + I PSOREF>0&($D(^PSRX(PSODA,1,PSOREF,"PFS"))) S PSOPFS=PSOPFS_"^"_$P(^PSRX(PSODA,1,PSOREF,"PFS"),"^",1,2) + Q + ; +PFSA(PSODA,PSOREF,WR) ;called from PSOCP (WR=2) and PSOCPB (WR=3) + ;get switch status, acct ref, and charge ID, then validate switch vs availability of PFSS acct ref + Q:'$G(WR) + S PSOPFS=+$$SWSTAT^IBBAPI() + D PFSI(PSODA,PSOREF) + ; if switch is off, but have an PFSS Acct Ref for new orders, send charge to IDX + ; if switch is off, but have a Charge ID, send cancel charge to IDX + I '+PSOPFS,$P(PSOPFS,"^",WR)>0 S $P(PSOPFS,"^")=1 + Q + ; +PFS ;;Called from PSOCPB; PSOCPB is too large to hold more code. Processes copay cancels for PFS only. + ;find any fills being cancelled for PFSS, cancel them, and remove them from PSOCAN, then return to PSOCP to process any IB cancels + ; + N X,I,PSOREF,PSOOLD,PREA,PSONW + ;If it's a PFS fill, if released, and not previously cancelled, set the X array, then kill it out of PSOCAN array. + ;Killed out of PSOCAN because don't want the IB processing to look at PFSS billed fills. + ;Note that in PSOCPD, PFS entries are not stored in PSOCAN array if a charge ID is not defined. So, don't have to check for release date. + ;If prev cancelled and PFS, kill it from PSOCAN array + S I="" F S I=$O(PSOCAN(I)) Q:I="" S PSOREF=+PSOCAN(I) D + . I PSOREF=PSODA&($P(PSOCAN(I),"^",10)="PFS") D Q + . . I $P(PSOCAN(I),"^",5)["CANCEL" K PSOCAN(I) Q + . . S X(0)=$P(PSOCAN(I),"^",2)_"^"_PSORSN K PSOCAN(I) + . I PSOREF'=PSODA&($P(PSOCAN(I),"^",10)="PFS") D + . . I $P(PSOCAN(I),"^",5)["CANCEL" K PSOCAN(I) Q + . . S X(PSOREF)=$P(PSOCAN(I),"^",2)_"^"_PSORSN K PSOCAN(I) + I $G(CANTYPE)&('$D(X)) D MSGNOCAN^PSOCPB Q ;CANTYPE=1 means trying cancelling all fills;can't cancel twice + ; + ;send charge messages, set activity log, display message + S PREA="C",PSOREF="" + F S PSOREF=$O(X(PSOREF)) Q:PSOREF="" S PSOPFS=1 D PFSI(PSODA,PSOREF) D CHRG(PSODA,PSOREF,"CD",PSOPFS) D ACTLOG^PSOCPA D:'$G(CANTYPE) MSG^PSOCPB + I $G(CANTYPE)&('$D(PSOCAN)) D MSG^PSOCPB ;if cancelling all and no legacy IB bills to cancel, write msg + S PSOPFSA=0 ;reset variable so charge isn't sent twice if SC/EI's were also changed. + Q + ; diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOPMP0.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOPMP0.m index f19532cf..94af8e9e 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOPMP0.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOPMP0.m @@ -1,255 +1,250 @@ -PSOPMP0 ;BIRM/MFR - Patient Medication Profile - Listmanager ;10/28/06 - ;;7.0;OUTPATIENT PHARMACY;**260,281**;DEC 1997;Build 41 - ;Reference to EN1^GMRADPT supported by IA #10099 - ;Reference to EN6^GMRVUTL supported by IA #1120 - ;Reference to ^PS(55 supported by DBIA 2228 - ; -EN ; - Menu option entry point - N PSOEXPDC,PSOEXDCE,PSOSRTBY,PSORDER,PSOSIGDP,PSOSTSGP,PSOSTORD,PSORDCNT,PSOSTSEQ,PSORDSEQ,PSOCHNG - N GRPLN,DIC,Y,DFN,GRPLN,HIGHLN,LASTLINE,VALMCNT - ; - ; - Division selection - I '$G(PSOSITE) D ^PSOLSET I '$D(PSOPAR) W $C(7),!!,"Pharmacy Division Must be Selected!",! G EXIT - ; - ; - Patient selection - W !! S DIC=2,DIC(0)="QEAM" D ^DIC G EXIT:Y<0 S DFN=+Y - ; - S PSODFN=DFN D CHKADDR^PSOBAI(DFN,1,1) ;bad address flag/update - ; - D LST(PSOSITE,DFN) - Q - ; -LST(SITE,PSODFN) ; - ListManager entry point - ; Loading Division/User preferences - D LOAD^PSOPMPPF(SITE,DUZ) - ; - W !,"Please wait..." - D EN^VALM("PSO PMP MAIN") - D FULL^VALM1 - G EXIT - ; -HDR ; - Header - N LINE,POS,LINE1,LINE2,LINE3,LINE4,WT,WTDT,HT,HTDT,VADM,DFN,PNAME,DOB,SEX,X,GMRAL,ADVREA - ; - K VADM S DFN=PSODFN D DEM^VADPT - S PNAME=VADM(1) - S DOB=$S(+VADM(3):$P(VADM(3),"^",2)_" ("_$G(VADM(4))_")",1:"UNKNOWN") - S SEX=$P(VADM(5),"^",2) - S (WT,X)="",GMRVSTR="WT" D EN6^GMRVUTL I X'="" S WT=$J($P(X,"^",8)/2.2,6,2),WTDT=$$DAT^PSOPMP1($P(X,"^")\1,"/",1) - S (HT,X)="",GMRVSTR="HT" D EN6^GMRVUTL I X'="" S HT=$J($P(X,"^",8)*2.54,6,2),HTDT=$$DAT^PSOPMP1($P(X,"^")\1,"/",1) - S LINE1=PNAME - S LINE1=$$ALLERGY^PSOPMP1(LINE1,DFN) - S LINE2=" PID: "_$P(VADM(2),"^",2),$E(LINE2,50)="HEIGHT(cm): "_$S(HT'="":HT_" ("_HTDT_")",1:"NOT AVAILABLE") - S LINE3=" DOB: "_DOB,$E(LINE3,50)="WEIGHT(kg): "_$S(WT'="":WT_" ("_WTDT_")",1:"NOT AVAILABLE") - S LINE4=" SEX: "_SEX,$E(LINE4,43)="EXP/CANCEL CUTOFF: "_PSOEXDCE_" DAYS" - ; - K VALMHDR S VALMHDR(1)=LINE1,VALMHDR(2)=LINE2,VALMHDR(3)=LINE3,VALMHDR(4)=LINE4 - ; - D SETHDR^PSOPMP1() - Q - ; -INIT ; - Populates the Body section for ListMan - K ^TMP("PSOPMP0",$J) - ; - D SETSORT(PSOSRTBY),SETLINE - S VALMSG="Select the entry # to view or ?? for more actions" - Q - ; -SETLINE ; - Sets the line to be displayed in ListMan - N TYPE,STS,SUB,SEQ,LINE,Z,TOTAL,I,X,X1,ORDCNT,LBL,LN,IENSUB,GROUP,GRP,QTYL - I '$D(^TMP("PSOPMPSR",$J)) D Q - . F I=1:1:6 S ^TMP("PSOPMP0",$J,I,0)="" - . S ^TMP("PSOPMP0",$J,7,0)=" No prescriptions found for this patient." - . S VALMCNT=1 - ; - ; - Resetting list to NORMAL video attributes - F I=1:1:$G(LASTLINE) D RESTORE^VALM10(I) - K GRPLN,HIGHLN - ; - ; - Building the list (line by line) - S (GROUP,STS,SUB)="",LINE=0 K ^TMP("PSOPMP0",$J) - F S GROUP=$O(^TMP("PSOPMPSR",$J,GROUP)) Q:GROUP="" D - . S GRP=$P(GROUP,"^") - . I GRP'["R"!('PSOSTSGP&($O(^TMP("PSOPMPSR",$J,GROUP),-1)'="")) D - . . D GROUP^PSOPMP1($P(GROUP,"^",2),+$G(^TMP("PSOPMPSR",$J,GROUP)),.LINE) - . F S STS=$O(^TMP("PSOPMPSR",$J,GROUP,STS)) Q:STS="" D - . . I STS'="" D - . . . D GROUP^PSOPMP1($P(STS,"^",2),+$G(^TMP("PSOPMPSR",$J,GROUP,STS)),.LINE) - . . F S SUB=$O(^TMP("PSOPMPSR",$J,GROUP,STS,SUB),$S(PSORDER="A":1,1:-1)) Q:SUB="" D - . . . S Z=$G(^TMP("PSOPMPSR",$J,GROUP,STS,SUB)) - . . . S X1="",SEQ=$G(SEQ)+1,X1=$J(SEQ,3) - . . . S QTYL=$L($P(Z,"^",4)) S:QTYL<5 QTYL=5 - . . . I GRP["R"!(GRP["T") S $E(X1,5)=$P(Z,"^",2),$E(X1,19)=$E($P(Z,"^",3),1,(32-QTYL)) - . . . I GRP["P"!(GRP["N") S $E(X1,5)=$P(Z,"^",3) - . . . I GRP["N" S $E(X1,49)="Date Documented:" - . . . I GRP'["N" S $E(X1,52-QTYL)=$J($P(Z,"^",4),QTYL),$E(X1,53)=$P(Z,"^",5),$E(X1,57)=$P(Z,"^",6) - . . . S $E(X1,66)=$P(Z,"^",7) - . . . S $E(X1,74)=$J($P(Z,"^",8),3),$E(X1,78)=$J($P(Z,"^",9),3) - . . . S LINE=LINE+1,^TMP("PSOPMP0",$J,LINE,0)=X1,HIGHLN(LINE)="" - . . . S IENSUB=$S(GRP["R"!(GRP["T"):"RX",GRP["P":"PEN",1:"NVA") - . . . S ^TMP("PSOPMP0",$J,SEQ,IENSUB)=$P(Z,"^") - . . . I $G(PSOSIGDP) D SETSIG^PSOPMP1($S(GRP["R"!(GRP["T"):"R",GRP["P":"P",1:"N"),+Z,.LINE,PSODFN) - ; - ; - Saving NORMAL video attributes to be reset later - I LINE>$G(LASTLINE) D - . F I=($G(LASTLINE)+1):1:LINE D SAVE^VALM10(I) - . S LASTLINE=LINE - ; - D VIDEO^PSOPMP1() - ; - S VALMCNT=+$G(LINE) - Q - ; -SETSORT(FIELD) ; - Sets the data sorted by the FIELD specified - N SEQ,RX,RXNUM,DRUG,DRNAME,QTY,STATUS,STS,ISSDT,DOCDAT,LSTFD,REFREM,DAYSUP,SIG,Z,ORD,GRPCNT,GROUP,RFRX,OI,PSOBADR - ; - K ^TMP("PSOPMPSR",$J) - ; - ; - Loading prescription (file #55) - S SEQ=0 - F S SEQ=$O(^PS(55,PSODFN,"P",SEQ)) Q:'SEQ D - . S RX=+$G(^PS(55,PSODFN,"P",SEQ,0)) I 'RX!($G(^PSRX(RX,0))="") Q - . I $$FILTER^PSOPMP1(RX) Q - . S RXNUM=$$GET1^DIQ(52,RX,.01) - . S DRUG=$$GET1^DIQ(52,RX,6,"I") - . S DRNAME=$$GET1^DIQ(50,DRUG,.01) - . S QTY=$$GET1^DIQ(52,RX,7) - . S STATUS=$$STSINFO^PSOPMP1(RX) - . S ISSDT=$$ISSDT^PSOPMP1(RX,"R") - . S LSTFD=$$LSTFD^PSOPMP1(RX) - . S REFREM=$$REFREM^PSOPMP1(RX) - . S DAYSUP=$$GET1^DIQ(52,RX,8) - . S PSOBADR=$O(^PSRX(RX,"L",9999),-1) - . I PSOBADR'="" S PSOBADR=$G(^PSRX(RX,"L",PSOBADR,0)) I PSOBADR["(BAD ADDRESS)" S PSOBADR="B" - . I PSOBADR'="B" S PSOBADR="" - . S Z="",$P(Z,"^")=RX,$P(Z,"^",2)=RXNUM_$$COPAY^PSOPMP1(RX)_$$ECME^PSOBPSUT(RX),$P(Z,"^",3)=$E(DRNAME,1,30) - . S $P(Z,"^",4)=QTY,$P(Z,"^",5)=$P(STATUS,"^",3)_$$CMOP^PSOPMP1(DRUG,RX)_PSOBADR,$P(Z,"^",6)=$P(ISSDT,"^",2) - . S $P(Z,"^",7)=$P(LSTFD,"^",2),$P(Z,"^",8)=REFREM,$P(Z,"^",9)=DAYSUP - . S SORT=$S(FIELD="RX":RXNUM_" ",FIELD="DR":DRNAME_RXNUM,FIELD="ID":+ISSDT_RXNUM_" ",FIELD="LF":+LSTFD_RXNUM_" ") - . S STS="" I $G(PSOSTSGP) S STS=$P(STATUS,"^")_"^"_$P(STATUS,"^",2) - . S GROUP=$P(PSORDSEQ("R"),"^")_"R^"_$P(PSORDSEQ("R"),"^",2) - . I $$FIND^PSOREJUT(RX) S GROUP=$P(PSORDSEQ("T"),"^")_"T^"_$P(PSORDSEQ("T"),"^",2),STS="" - . S ^TMP("PSOPMPSR",$J,GROUP,STS,SORT)=Z - . S GRPCNT(GROUP)=$G(GRPCNT(GROUP))+1,GRPCNT(GROUP,STS)=$G(GRPCNT(GROUP,STS))+1 - ; - S GROUP="" - F S GROUP=$O(GRPCNT(GROUP)) Q:GROUP="" D - . S ^TMP("PSOPMPSR",$J,GROUP)=$G(GRPCNT(GROUP)) - . S STS="" F S STS=$O(GRPCNT(GROUP,STS)) Q:STS="" D - . . S ^TMP("PSOPMPSR",$J,GROUP,STS)=GRPCNT(GROUP,STS) - ; - ; - Loading pending orders (file #52.41) - S ORD=0,GROUP=$P(PSORDSEQ("P"),"^")_"P^"_$P(PSORDSEQ("P"),"^",2) - F S ORD=$O(^PS(52.41,"P",PSODFN,ORD)) Q:'ORD D - . S TYPE=$$GET1^DIQ(52.41,ORD,2,"I") - . I TYPE="DC"!(TYPE="DE")!(TYPE="HD") Q - . S DRNAME="",DRUG=+$$GET1^DIQ(52.41,ORD,11,"I") I DRUG S DRNAME=$$GET1^DIQ(50,DRUG,.01) - . I DRNAME="" D Q:DRNAME="" - . . S OI=$$GET1^DIQ(52.41,ORD,8,"I") I 'OI Q - . . S DRNAME=$$GET1^DIQ(50.7,OI,.01)_" "_$$GET1^DIQ(50.7,OI,.02) - . S QTY=$$GET1^DIQ(52.41,ORD,12) - . S STATUS=$$GET1^DIQ(52.41,ORD,2,"I") - . S ISSDT=$$ISSDT^PSOPMP1(ORD,"P") - . S REFREM=$$GET1^DIQ(52.41,ORD,13) - . S DAYSUP=$$GET1^DIQ(52.41,ORD,101) - . S RFRX="" I STATUS="RF" S RFRX=$$GET1^DIQ(52.41,ORD,21,"I") I RFRX S RFRX=$$GET1^DIQ(52,RFRX,.01) - . S Z="",$P(Z,"^")=ORD,$P(Z,"^",3)=$E(DRNAME,1,45),$P(Z,"^",4)=QTY,$P(Z,"^",5)=$E(STATUS,1,2)_$$CMOP^PSOPMP1(DRUG) - . S $P(Z,"^",6)=$S(RFRX'="":"Rx#: "_RFRX,1:$P(ISSDT,"^",2)),$P(Z,"^",8)=REFREM,$P(Z,"^",9)=DAYSUP - . S SORT=$S(FIELD="RX":DRNAME_ORD,FIELD="DR":DRNAME_ORD,FIELD="ID":+ISSDT_ORD,FIELD="LF":+ISSDT_ORD) - . S ^TMP("PSOPMPSR",$J,GROUP,"",SORT)=Z - . S GRPCNT(GROUP)=$G(GRPCNT(GROUP))+1 - ; - S:$G(GRPCNT(GROUP)) ^TMP("PSOPMPSR",$J,GROUP)=$G(GRPCNT(GROUP)) - ; - ; - Loading Non-VA Med orders (file #55, sub-file #55.05) - S ORD=0,GROUP=$P(PSORDSEQ("N"),"^")_"N^"_$P(PSORDSEQ("N"),"^",2) - F S ORD=$O(^PS(55,PSODFN,"NVA",ORD)) Q:'ORD D - . I $$GET1^DIQ(55.05,ORD_","_PSODFN,5,"I") Q - . S DRNAME=$$GET1^DIQ(55.05,ORD_","_PSODFN,1) - . I DRNAME="" D Q:DRNAME="" - . . S OI=$$GET1^DIQ(55.05,ORD_","_PSODFN,.01,"I") I 'OI Q - . . S DRNAME=$$GET1^DIQ(50.7,OI,.01)_" "_$$GET1^DIQ(50.7,OI,.02) - . S DOCDAT=$P($$GET1^DIQ(55.05,ORD_","_PSODFN_",",11,"I"),".") - . S Z="",$P(Z,"^")=ORD,$P(Z,"^",3)=$E(DRNAME,1,38),$P(Z,"^",7)=$$DAT^PSOPMP1(DOCDAT,"-") - . S SORT=$S(FIELD="RX":DRNAME_ORD,FIELD="DR":DRNAME_ORD,FIELD="ID":DOCDAT_ORD,FIELD="LF":DOCDAT_ORD) - . S ^TMP("PSOPMPSR",$J,GROUP,"",SORT)=Z - . S GRPCNT(GROUP)=$G(GRPCNT(GROUP))+1 - ; - S:$G(GRPCNT(GROUP)) ^TMP("PSOPMPSR",$J,GROUP)=$G(GRPCNT(GROUP)) - ; - Q - ; -RX ; - Sort by Rx - D SORT("RX") - Q -DR ; - Sort by Drug - D SORT("DR") - Q -ID ; - Sort by Issue Date - D SORT("ID") - Q -LF ; - Sort by Last Fill Date - D SORT("LF") - Q - ; -SORT(FIELD) ; - Sort entries by FIELD - I PSOSRTBY=FIELD S PSORDER=$S(PSORDER="A":"D",1:"A") - E S PSOSRTBY=FIELD,PSORDER="A" - D REF - Q - ; -REF ; - Screen Refresh - W ?52,"Please wait..." D INIT,HDR S VALMBCK="R" - Q -GS ; - Group by Status - W ?52,"Please wait..." S PSOSTSGP=$S($G(PSOSTSGP):0,1:1) D INIT,HDR S VALMBCK="R" - Q - ; -SIG ; - Display SIG - W ?52,"Please wait..." S PSOSIGDP=$S($G(PSOSIGDP):0,1:1) D INIT,HDR S VALMBCK="R" - I 'PSOSIGDP S VALMBG=VALMBG\2 - I PSOSIGDP S VALMBG=VALMBG*2-1 - S:VALMBG>(VALMCNT-10) VALMBG=VALMCNT-10 S:VALMBG<1 VALMBG=1 - Q - ; -PI ; - Patient Information - D EN^PSOLMPI S VALMBCK="R" - Q - ; -CV ; - Change View - D LST^PSOPMPPF(SITE,DUZ) W !?52,"Please wait..." D INIT,HDR - S VALMBG=1,VALMBCK="R" - Q - ; -SEL ; - Process selection of one entry - N PSOSEL,TYPE,XQORM,ORD,TITLE - S PSOSEL=+$P($P(Y(1),"^",4),"=",2) I 'PSOSEL S VALMSG="Invalid selection!",VALMBCK="R" Q - S TYPE=$O(^TMP("PSOPMP0",$J,PSOSEL,0)) I TYPE="" S VALMSG="Invalid selection!",VALMBCK="R" Q - S ORD=$G(^TMP("PSOPMP0",$J,PSOSEL,TYPE)) - I 'ORD S VALMSG="Invalid selection!",VALMBCK="R" Q - S TITLE=VALM("TITLE") - ; - ; - Regular prescription - I TYPE="RX" D S VALMBCK="R" D REF - . N PSOVDA,PSOSAVE,DA,PS - . S (PSOVDA,DA)=ORD,PS="REJECTMP" - . N LINE,TITLE,PSODFN D DP^PSORXVW - ; - ; - Pending Order - I TYPE="PEN" D - . N PSOACTOV,OR0 - . S OR0=^PS(52.41,ORD,0),PSOACTOV="" - . N LINE,TITLE D PENHDR^PSOPMP1(PSODFN),DSPL^PSOORFI1 - ; - ; - Pending Order - I TYPE="NVA" D - . N LINE,TITLE D EN^PSONVAVW(PSODFN,ORD) - ; - S VALMBCK="R",VALM("TITLE")=TITLE - Q - ; -EXIT ; - K ^TMP("PSOPMP0",$J),^TMP("PSOPMPSR",$J) - Q - ; -HELP Q +PSOPMP0 ;BIRM/MFR - Patient Medication Profile - Listmanager ;10/28/06 + ;;7.0;OUTPATIENT PHARMACY;**260**;DEC 1997;Build 84 + ;Reference to EN1^GMRADPT supported by IA #10099 + ;Reference to EN6^GMRVUTL supported by IA #1120 + ;Reference to ^PS(55 supported by DBIA 2228 + ; +EN ; - Menu option entry point + N PSOEXPDC,PSOEXDCE,PSOSRTBY,PSORDER,PSOSIGDP,PSOSTSGP,PSOSTORD,PSORDCNT,PSOSTSEQ,PSORDSEQ,PSOCHNG + N GRPLN,DIC,Y,DFN,GRPLN,HIGHLN,LASTLINE,VALMCNT + ; + ; - Division selection + I '$G(PSOSITE) D ^PSOLSET I '$D(PSOPAR) W $C(7),!!,"Pharmacy Division Must be Selected!",! G EXIT + ; + ; - Patient selection + W !! S DIC=2,DIC(0)="QEAM" D ^DIC G EXIT:Y<0 S DFN=+Y + ; + D LST(PSOSITE,DFN) + Q + ; +LST(SITE,PSODFN) ; - ListManager entry point + ; Loading Division/User preferences + D LOAD^PSOPMPPF(SITE,DUZ) + ; + W !,"Please wait..." + D EN^VALM("PSO PMP MAIN") + D FULL^VALM1 + G EXIT + ; +HDR ; - Header + N LINE,POS,LINE1,LINE2,LINE3,LINE4,WT,WTDT,HT,HTDT,VADM,DFN,PNAME,DOB,SEX,X,GMRAL,ADVREA + ; + K VADM S DFN=PSODFN D DEM^VADPT + S PNAME=VADM(1) + S DOB=$S(+VADM(3):$P(VADM(3),"^",2)_" ("_$G(VADM(4))_")",1:"UNKNOWN") + S SEX=$P(VADM(5),"^",2) + S (WT,X)="",GMRVSTR="WT" D EN6^GMRVUTL I X'="" S WT=$J($P(X,"^",8)/2.2,6,2),WTDT=$$DAT^PSOPMP1($P(X,"^")\1,"/",1) + S (HT,X)="",GMRVSTR="HT" D EN6^GMRVUTL I X'="" S HT=$J($P(X,"^",8)*2.54,6,2),HTDT=$$DAT^PSOPMP1($P(X,"^")\1,"/",1) + S LINE1=PNAME + S LINE1=$$ALLERGY^PSOPMP1(LINE1,DFN) + S LINE2=" PID: "_$P(VADM(2),"^",2),$E(LINE2,50)="HEIGHT(cm): "_$S(HT'="":HT_" ("_HTDT_")",1:"NOT AVAILABLE") + S LINE3=" DOB: "_DOB,$E(LINE3,50)="WEIGHT(kg): "_$S(WT'="":WT_" ("_WTDT_")",1:"NOT AVAILABLE") + S LINE4=" SEX: "_SEX,$E(LINE4,43)="EXP/CANCEL CUTOFF: "_PSOEXDCE_" DAYS" + ; + K VALMHDR S VALMHDR(1)=LINE1,VALMHDR(2)=LINE2,VALMHDR(3)=LINE3,VALMHDR(4)=LINE4 + ; + D SETHDR^PSOPMP1() + Q + ; +INIT ; - Populates the Body section for ListMan + K ^TMP("PSOPMP0",$J) + ; + D SETSORT(PSOSRTBY),SETLINE + S VALMSG="Select the entry # to view or ?? for more actions" + Q + ; +SETLINE ; - Sets the line to be displayed in ListMan + N TYPE,STS,SUB,SEQ,LINE,Z,TOTAL,I,X,X1,ORDCNT,LBL,LN,IENSUB,GROUP,GRP,QTYL + I '$D(^TMP("PSOPMPSR",$J)) D Q + . F I=1:1:6 S ^TMP("PSOPMP0",$J,I,0)="" + . S ^TMP("PSOPMP0",$J,7,0)=" No prescriptions found for this patient." + . S VALMCNT=1 + ; + ; - Resetting list to NORMAL video attributes + F I=1:1:$G(LASTLINE) D RESTORE^VALM10(I) + K GRPLN,HIGHLN + ; + ; - Building the list (line by line) + S (GROUP,STS,SUB)="",LINE=0 K ^TMP("PSOPMP0",$J) + F S GROUP=$O(^TMP("PSOPMPSR",$J,GROUP)) Q:GROUP="" D + . S GRP=$P(GROUP,"^") + . I GRP'["R"!('PSOSTSGP&($O(^TMP("PSOPMPSR",$J,GROUP),-1)'="")) D + . . D GROUP^PSOPMP1($P(GROUP,"^",2),+$G(^TMP("PSOPMPSR",$J,GROUP)),.LINE) + . F S STS=$O(^TMP("PSOPMPSR",$J,GROUP,STS)) Q:STS="" D + . . I STS'="" D + . . . D GROUP^PSOPMP1($P(STS,"^",2),+$G(^TMP("PSOPMPSR",$J,GROUP,STS)),.LINE) + . . F S SUB=$O(^TMP("PSOPMPSR",$J,GROUP,STS,SUB),$S(PSORDER="A":1,1:-1)) Q:SUB="" D + . . . S Z=$G(^TMP("PSOPMPSR",$J,GROUP,STS,SUB)) + . . . S X1="",SEQ=$G(SEQ)+1,X1=$J(SEQ,3) + . . . S QTYL=$L($P(Z,"^",4)) S:QTYL<5 QTYL=5 + . . . I GRP["R"!(GRP["T") S $E(X1,5)=$P(Z,"^",2),$E(X1,19)=$E($P(Z,"^",3),1,(32-QTYL)) + . . . I GRP["P"!(GRP["N") S $E(X1,5)=$P(Z,"^",3) + . . . I GRP["N" S $E(X1,49)="Date Documented:" + . . . I GRP'["N" S $E(X1,52-QTYL)=$J($P(Z,"^",4),QTYL),$E(X1,53)=$P(Z,"^",5),$E(X1,57)=$P(Z,"^",6) + . . . S $E(X1,66)=$P(Z,"^",7) + . . . S $E(X1,74)=$J($P(Z,"^",8),3),$E(X1,78)=$J($P(Z,"^",9),3) + . . . S LINE=LINE+1,^TMP("PSOPMP0",$J,LINE,0)=X1,HIGHLN(LINE)="" + . . . S IENSUB=$S(GRP["R"!(GRP["T"):"RX",GRP["P":"PEN",1:"NVA") + . . . S ^TMP("PSOPMP0",$J,SEQ,IENSUB)=$P(Z,"^") + . . . I $G(PSOSIGDP) D SETSIG^PSOPMP1($S(GRP["R"!(GRP["T"):"R",GRP["P":"P",1:"N"),+Z,.LINE,PSODFN) + ; + ; - Saving NORMAL video attributes to be reset later + I LINE>$G(LASTLINE) D + . F I=($G(LASTLINE)+1):1:LINE D SAVE^VALM10(I) + . S LASTLINE=LINE + ; + D VIDEO^PSOPMP1() + ; + S VALMCNT=+$G(LINE) + Q + ; +SETSORT(FIELD) ; - Sets the data sorted by the FIELD specified + N SEQ,RX,RXNUM,DRUG,DRNAME,QTY,STATUS,STS,ISSDT,DOCDAT,LSTFD,REFREM,DAYSUP,SIG,Z,ORD,GRPCNT,GROUP,RFRX,OI + ; + K ^TMP("PSOPMPSR",$J) + ; + ; - Loading prescription (file #55) + S SEQ=0 + F S SEQ=$O(^PS(55,PSODFN,"P",SEQ)) Q:'SEQ D + . S RX=+$G(^PS(55,PSODFN,"P",SEQ,0)) I 'RX!($G(^PSRX(RX,0))="") Q + . I $$FILTER^PSOPMP1(RX) Q + . S RXNUM=$$GET1^DIQ(52,RX,.01) + . S DRUG=$$GET1^DIQ(52,RX,6,"I") + . S DRNAME=$$GET1^DIQ(50,DRUG,.01) + . S QTY=$$GET1^DIQ(52,RX,7) + . S STATUS=$$STSINFO^PSOPMP1(RX) + . S ISSDT=$$ISSDT^PSOPMP1(RX,"R") + . S LSTFD=$$LSTFD^PSOPMP1(RX) + . S REFREM=$$REFREM^PSOPMP1(RX) + . S DAYSUP=$$GET1^DIQ(52,RX,8) + . S Z="",$P(Z,"^")=RX,$P(Z,"^",2)=RXNUM_$$COPAY^PSOPMP1(RX)_$$ECME^PSOBPSUT(RX),$P(Z,"^",3)=$E(DRNAME,1,30) + . S $P(Z,"^",4)=QTY,$P(Z,"^",5)=$P(STATUS,"^",3)_$$CMOP^PSOPMP1(DRUG,RX),$P(Z,"^",6)=$P(ISSDT,"^",2) + . S $P(Z,"^",7)=$P(LSTFD,"^",2),$P(Z,"^",8)=REFREM,$P(Z,"^",9)=DAYSUP + . S SORT=$S(FIELD="RX":RXNUM_" ",FIELD="DR":DRNAME_RXNUM,FIELD="ID":+ISSDT_RXNUM_" ",FIELD="LF":+LSTFD_RXNUM_" ") + . S STS="" I $G(PSOSTSGP) S STS=$P(STATUS,"^")_"^"_$P(STATUS,"^",2) + . S GROUP=$P(PSORDSEQ("R"),"^")_"R^"_$P(PSORDSEQ("R"),"^",2) + . I $$FIND^PSOREJUT(RX) S GROUP=$P(PSORDSEQ("T"),"^")_"T^"_$P(PSORDSEQ("T"),"^",2),STS="" + . S ^TMP("PSOPMPSR",$J,GROUP,STS,SORT)=Z + . S GRPCNT(GROUP)=$G(GRPCNT(GROUP))+1,GRPCNT(GROUP,STS)=$G(GRPCNT(GROUP,STS))+1 + ; + S GROUP="" + F S GROUP=$O(GRPCNT(GROUP)) Q:GROUP="" D + . S ^TMP("PSOPMPSR",$J,GROUP)=$G(GRPCNT(GROUP)) + . S STS="" F S STS=$O(GRPCNT(GROUP,STS)) Q:STS="" D + . . S ^TMP("PSOPMPSR",$J,GROUP,STS)=GRPCNT(GROUP,STS) + ; + ; - Loading pending orders (file #52.41) + S ORD=0,GROUP=$P(PSORDSEQ("P"),"^")_"P^"_$P(PSORDSEQ("P"),"^",2) + F S ORD=$O(^PS(52.41,"P",PSODFN,ORD)) Q:'ORD D + . S TYPE=$$GET1^DIQ(52.41,ORD,2,"I") + . I TYPE="DC"!(TYPE="DE")!(TYPE="HD") Q + . S DRNAME="",DRUG=+$$GET1^DIQ(52.41,ORD,11,"I") I DRUG S DRNAME=$$GET1^DIQ(50,DRUG,.01) + . I DRNAME="" D Q:DRNAME="" + . . S OI=$$GET1^DIQ(52.41,ORD,8,"I") I 'OI Q + . . S DRNAME=$$GET1^DIQ(50.7,OI,.01)_" "_$$GET1^DIQ(50.7,OI,.02) + . S QTY=$$GET1^DIQ(52.41,ORD,12) + . S STATUS=$$GET1^DIQ(52.41,ORD,2,"I") + . S ISSDT=$$ISSDT^PSOPMP1(ORD,"P") + . S REFREM=$$GET1^DIQ(52.41,ORD,13) + . S DAYSUP=$$GET1^DIQ(52.41,ORD,101) + . S RFRX="" I STATUS="RF" S RFRX=$$GET1^DIQ(52.41,ORD,21,"I") I RFRX S RFRX=$$GET1^DIQ(52,RFRX,.01) + . S Z="",$P(Z,"^")=ORD,$P(Z,"^",3)=$E(DRNAME,1,45),$P(Z,"^",4)=QTY,$P(Z,"^",5)=$E(STATUS,1,2)_$$CMOP^PSOPMP1(DRUG) + . S $P(Z,"^",6)=$S(RFRX'="":"Rx#: "_RFRX,1:$P(ISSDT,"^",2)),$P(Z,"^",8)=REFREM,$P(Z,"^",9)=DAYSUP + . S SORT=$S(FIELD="RX":DRNAME_ORD,FIELD="DR":DRNAME_ORD,FIELD="ID":+ISSDT_ORD,FIELD="LF":+ISSDT_ORD) + . S ^TMP("PSOPMPSR",$J,GROUP,"",SORT)=Z + . S GRPCNT(GROUP)=$G(GRPCNT(GROUP))+1 + ; + S:$G(GRPCNT(GROUP)) ^TMP("PSOPMPSR",$J,GROUP)=$G(GRPCNT(GROUP)) + ; + ; - Loading Non-VA Med orders (file #55, sub-file #55.05) + S ORD=0,GROUP=$P(PSORDSEQ("N"),"^")_"N^"_$P(PSORDSEQ("N"),"^",2) + F S ORD=$O(^PS(55,PSODFN,"NVA",ORD)) Q:'ORD D + . I $$GET1^DIQ(55.05,ORD_","_PSODFN,5,"I") Q + . S DRNAME=$$GET1^DIQ(55.05,ORD_","_PSODFN,1) + . I DRNAME="" D Q:DRNAME="" + . . S OI=$$GET1^DIQ(55.05,ORD_","_PSODFN,.01,"I") I 'OI Q + . . S DRNAME=$$GET1^DIQ(50.7,OI,.01)_" "_$$GET1^DIQ(50.7,OI,.02) + . S DOCDAT=$P($$GET1^DIQ(55.05,ORD_","_PSODFN_",",11,"I"),".") + . S Z="",$P(Z,"^")=ORD,$P(Z,"^",3)=$E(DRNAME,1,38),$P(Z,"^",7)=$$DAT^PSOPMP1(DOCDAT,"-") + . S SORT=$S(FIELD="RX":DRNAME_ORD,FIELD="DR":DRNAME_ORD,FIELD="ID":DOCDAT_ORD,FIELD="LF":DOCDAT_ORD) + . S ^TMP("PSOPMPSR",$J,GROUP,"",SORT)=Z + . S GRPCNT(GROUP)=$G(GRPCNT(GROUP))+1 + ; + S:$G(GRPCNT(GROUP)) ^TMP("PSOPMPSR",$J,GROUP)=$G(GRPCNT(GROUP)) + ; + Q + ; +RX ; - Sort by Rx + D SORT("RX") + Q +DR ; - Sort by Drug + D SORT("DR") + Q +ID ; - Sort by Issue Date + D SORT("ID") + Q +LF ; - Sort by Last Fill Date + D SORT("LF") + Q + ; +SORT(FIELD) ; - Sort entries by FIELD + I PSOSRTBY=FIELD S PSORDER=$S(PSORDER="A":"D",1:"A") + E S PSOSRTBY=FIELD,PSORDER="A" + D REF + Q + ; +REF ; - Screen Refresh + W ?52,"Please wait..." D INIT,HDR S VALMBCK="R" + Q +GS ; - Group by Status + W ?52,"Please wait..." S PSOSTSGP=$S($G(PSOSTSGP):0,1:1) D INIT,HDR S VALMBCK="R" + Q + ; +SIG ; - Display SIG + W ?52,"Please wait..." S PSOSIGDP=$S($G(PSOSIGDP):0,1:1) D INIT,HDR S VALMBCK="R" + I 'PSOSIGDP S VALMBG=VALMBG\2 + I PSOSIGDP S VALMBG=VALMBG*2-1 + S:VALMBG>(VALMCNT-10) VALMBG=VALMCNT-10 S:VALMBG<1 VALMBG=1 + Q + ; +PI ; - Patient Information + D EN^PSOLMPI S VALMBCK="R" + Q + ; +CV ; - Change View + D LST^PSOPMPPF(SITE,DUZ) W !?52,"Please wait..." D INIT,HDR + S VALMBG=1,VALMBCK="R" + Q + ; +SEL ; - Process selection of one entry + N PSOSEL,TYPE,XQORM,ORD,TITLE + S PSOSEL=+$P($P(Y(1),"^",4),"=",2) I 'PSOSEL S VALMSG="Invalid selection!",VALMBCK="R" Q + S TYPE=$O(^TMP("PSOPMP0",$J,PSOSEL,0)) I TYPE="" S VALMSG="Invalid selection!",VALMBCK="R" Q + S ORD=$G(^TMP("PSOPMP0",$J,PSOSEL,TYPE)) + I 'ORD S VALMSG="Invalid selection!",VALMBCK="R" Q + S TITLE=VALM("TITLE") + ; + ; - Regular prescription + I TYPE="RX" D + . N PSOVDA,PSOSAVE,DA,PS + . S (PSOVDA,DA)=ORD,PS="REJECT" + . N LINE,TITLE,PSODFN D DP^PSORXVW + ; + ; - Pending Order + I TYPE="PEN" D + . N PSOACTOV,OR0 + . S OR0=^PS(52.41,ORD,0),PSOACTOV="" + . N LINE,TITLE D PENHDR^PSOPMP1(PSODFN),DSPL^PSOORFI1 + ; + ; - Pending Order + I TYPE="NVA" D + . N LINE,TITLE D EN^PSONVAVW(PSODFN,ORD) + ; + S VALMBCK="R",VALM("TITLE")=TITLE + Q + ; +EXIT ; + K ^TMP("PSOPMP0",$J),^TMP("PSOPMPSR",$J) + Q + ; +HELP Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOPMP1.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOPMP1.m index 74010131..ad28da7e 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOPMP1.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOPMP1.m @@ -1,157 +1,157 @@ -PSOPMP1 ;BIRM/MFR - Patient Medication Profile - Listmanager ;04/28/05 - ;;7.0;OUTPATIENT PHARMACY;**260,285,281**;DEC 1997;Build 41 - ;Reference to ^PSDRUG("AQ" supported by IA 3165 - ;Reference to EN1^GMRADPT supported by IA 10099 - ;Reference to ^PSXOPUTL supported by IA 2200 - ; -VIDEO() ; - Changes the Video Attributes for the list - ; - ; - Highlighting the PRESCRIPTION line if SIG is displayed - I $G(PSOSIGDP) D - . F I=1:1:LINE D - . . I $D(HIGHLN(I)) D CNTRL^VALM10(I,1,80,IOINHI,IOINORM) - ; - ; - Highlighting the group lines (order type and status) - I $D(GRPLN) D - . S LN=0 F I=1:1 S LN=$O(GRPLN(LN)) Q:'LN D - . . S LBL=GRPLN(LN),POS=41-($L(LBL)\2) - . . D CNTRL^VALM10(LN,1,POS-1,IOUON_IOINHI,IOINORM) - . . D CNTRL^VALM10(LN,POS,$L(LBL),IORVON_IOINHI,IORVOFF_IOINORM) - . . D CNTRL^VALM10(LN,POS+$L(LBL),81-POS-$L(LBL),IOUON_IOINHI,IOINORM) - Q - ; -SETHDR() ; - Displays the Header Line - N HDR,ORD,POS - ; - ; - Line 1 - S $E(HDR,57)="ISSUE",$E(HDR,66)="LAST",$E(HDR,74)="REF",$E(HDR,78)="DAY" - S $E(HDR,81)="" D INSTR^VALM1(IORVON_HDR_IOINORM,1,6) - ; - Line 2 - S HDR=" #",$E(HDR,5)="Rx#",$E(HDR,19)="DRUG",$E(HDR,49)="QTY",$E(HDR,53)="ST" - S $E(HDR,57)="DATE",$E(HDR,66)="FILL",$E(HDR,74)="REM",$E(HDR,78)="SUP" - S $E(HDR,81)="" D INSTR^VALM1(IORVON_HDR_IOINORM,1,7) - S ORD=$S(PSORDER="A":"[^]",1:"[v]") - S:PSOSRTBY="RX" POS=9 S:PSOSRTBY="DR" POS=24 S:PSOSRTBY="ID" POS=61 S:PSOSRTBY="LF" POS=70 - D INSTR^VALM1(IOINHI_IORVON_ORD_IOINORM,POS,7) - Q - ; -SETSIG(TYPE,RX,LINE,DFN) ; Set the SIG line - N FSIG,L,X,DIWL,DIWR - ; - I TYPE="N" D Q - . K ^UTILITY($J,"W") - . S X=$$SCHED^PSONVNEW($$GET1^DIQ(55.05,RX_","_DFN,4)),DIWL=1,DIWR=71 D ^DIWP - . F L=1:1 Q:'$D(^UTILITY($J,"W",1,L)) D - . . S X="" S:L=1 $E(X,5)="SIG:" S $E(X,10)=^UTILITY($J,"W",1,L,0) - . . S LINE=LINE+1,^TMP("PSOPMP0",$J,LINE,0)=X - ; - D FSIG^PSOUTLA(TYPE,+RX,71) - F L=1:1 Q:'$D(FSIG(L)) D - . S X="" S:L=1 $E(X,5)="SIG:" S $E(X,10)=FSIG(L) - . S LINE=LINE+1,^TMP("PSOPMP0",$J,LINE,0)=X - Q - ; -GROUP(LBL,CNT,LINE) ; Sets a group delimiter line - N X,POS - S LBL=LBL_$S(PSORDCNT:" ("_CNT_" order"_$S(CNT>1:"s",1:"")_")",1:"") - S POS=41-($L(LBL)\2) - S X="",$P(X," ",81)="",$E(X,POS,POS-1+$L(LBL))=LBL - S LINE=LINE+1,^TMP("PSOPMP0",$J,LINE,0)=X,GRPLN(LINE)=LBL - Q - ; -PENHDR(DFN) ; Sets the Header in the ^TMP("PSOHDR",$J) global for displaying individual Pending Order - N VADM,WT,HT,PSOERR,GMRA - K ^TMP("PSOHDR",$J) D ^VADPT,ADD^VADPT - S ^TMP("PSOHDR",$J,1,0)=VADM(1),^TMP("PSOHDR",$J,2,0)=$P(VADM(2),"^",2) - S ^TMP("PSOHDR",$J,3,0)=$P(VADM(3),"^",2),^TMP("PSOHDR",$J,4,0)=VADM(4),^TMP("PSOHDR",$J,5,0)=$P(VADM(5),"^",2) - S POERR=1 D RE^PSODEM K PSOERR - S ^TMP("PSOHDR",$J,6,0)=$S(+$P(WT,"^",8):$J($P(WT,"^",9),6)_" ("_$P(WT,"^")_")",1:"_______ (______)") - S ^TMP("PSOHDR",$J,7,0)=$S($P(HT,"^",8):$J($P(HT,"^",9),6)_" ("_$P(HT,"^")_")",1:"_______ (______)") K VM,WT,HT S PSOHD=7 - S GMRA="0^0^111" D EN1^GMRADPT S ^TMP("PSOHDR",$J,8,0)=+$G(GMRAL) - Q - ; -FILTER(RX) ; - Filter Rx's that should not be displayed - I $$GET1^DIQ(52,RX,26,"I")11,$$GET1^DIQ(52,RX,100,"I")'=16 Q 1 - I $$GET1^DIQ(52,RX,100,"I")=""!($$GET1^DIQ(52,RX,100,"I")=13) Q 1 - I $$GET1^DIQ(52,RX,.01)="" Q 1 - Q 0 - ; -STSINFO(RX) ; Returns the Rx Status MNEMONIC^NAME - ; Input: RX - Prescription IEN (#52) - ;Output: Status Mnemonic ("A","DC",etc.)^Status Name ("ACTIVE","DISCONTINUED",etc.) - ; - N STS - I '$D(^PSRX(RX,"STA")) Q "" - S STS=$$GET1^DIQ(52,RX,100,"I") - I STS=0 Q:$$GET1^DIQ(52,RX,26,"I")>DT PSOSTSEQ("A") Q PSOSTSEQ("E") - I STS=1 Q PSOSTSEQ("N") - I STS=3 Q PSOSTSEQ("H") - I STS=5 Q PSOSTSEQ("S") - I STS=11 Q PSOSTSEQ("E") - I STS=12 Q PSOSTSEQ("DC") - I STS=14 Q PSOSTSEQ("DP") - I STS=15 Q PSOSTSEQ("DE") - I STS=16 Q PSOSTSEQ("PH") - Q "99^UNKNOWN^??" - ; -ISSDT(IEN,TYPE) ; Returns the Rx ISSUE DATE formatted MM-DD-YY - ;Input: RX - PrescrXiption IEN (#52) - ; TYPE - "R":Regular Rx, "P":Pending order - N ISSDT - I TYPE="R" S ISSDT=$$GET1^DIQ(52,IEN,1,"I") - I TYPE="P" S ISSDT=$$GET1^DIQ(52.41,IEN,6,"I") - I ISSDT'="" S ISSDT=ISSDT\1 - ; - Q (ISSDT_"^"_$$DAT(ISSDT,"-")) - ; -LSTFD(RX) ; Returns the Rx LAST FILL DATE formatted MM-DD-YY[R], where [R] = Returned to Stock - ;Input: RX - Prescription IEN (#52) - N LSTFD,RTSTK,RFL - S LSTFD=$$GET1^DIQ(52,RX,101,"I")\1 I LSTFD="" Q "" - I '$$LSTRFL^PSOBPSU1(RX) D - . I $$GET1^DIQ(52,RX,32.1,"I") S RTSTK="R" - E S RFL=0 F S RFL=$O(^PSRX(RX,1,RFL)) Q:'RFL D - . I $$RXFLDT^PSOBPSUT(RX,RFL)'=LSTFD Q - . I $$GET1^DIQ(52.1,RFL_","_RX,14,"I") S RTSTK="R" - ; - Q (LSTFD_"^"_$$DAT(LSTFD,"-")_$G(RTSTK)) - ; -REFREM(RX) ; - Returns the number of refills remaining - N REFREM,RFL - S REFREM=+$$GET1^DIQ(52,RX,9) - F RFL=0:1 S RFL=$O(^PSRX(RX,1,RFL)) Q:'RFL S REFREM=REFREM-1 - Q $S(REFREM<0:0,1:REFREM) - ; - ; -DAT(FMDT,SEP,Y4) ; - Formats FM dates to MM/DD/YY (SEP: Separator:"/","-",etc...) - ;Input: (r) FMDT - Fileman Date - ; (r) SEP - Separator - ; (o) Y4 - 4 digits year flag - I $G(FMDT)="" Q "" - I '$E(FMDT,6,7)!'$E(FMDT,4,7) Q $$UP^XLFSTR($TR($$FMTE^XLFDT(FMDT)," ","-")) - Q ($E(FMDT,4,5)_SEP_$E(FMDT,6,7)_SEP_$S($G(Y4):$E(FMDT,1,3)+1700,1:$E(FMDT,2,3))) - ; -COPAY(RX) ; Returns "$" is Rx has a copay and "" if not - Q $S($D(^PSRX(RX,"IB")):"$",1:"") - ; -CMOP(DRUG,RX) ; Returns the CMOP indicator (">", "T", etc) - N CMOP,X,DA,PSXZ - S CMOP="" I $D(^PSDRUG("AQ",DRUG)) S CMOP=">" - I $G(RX) S DA=RX D ^PSXOPUTL I $G(PSXZ(PSXZ("L")))=0!($G(PSXZ(PSXZ("L")))=2) S CMOP="T" - Q CMOP - ; -ALLERGY(LINE,DFN,POS) ; also called from PSONVAVW & PSOPMP0 - ; Input: LINE - (r) text to concatenate allergy information to - ; DFN - (r) patient IEN used for ^GMRADTP - ; POS - (o) position # to include text - ;Output: LINE - modified text - N ALLERGY,PSONOAL - S (PSONOAL,ALLERGY)="" - D EN1^GMRADPT - I GMRAL S ALLERGY="" - E D ALLERGY^PSOORUT2 I PSONOAL'="" S ALLERGY="" - S ALLERGY=IORVON_ALLERGY_IORVOFF_IOINORM - I '$G(POS) S POS=80-$L(ALLERGY) - S LINE=$$SETSTR^VALM1(ALLERGY,LINE,POS,80) - Q LINE +PSOPMP1 ;BIRM/MFR - Patient Medication Profile - Listmanager ;04/28/05 + ;;7.0;OUTPATIENT PHARMACY;**260**;DEC 1997;Build 84 + ;Reference to ^PSDRUG("AQ" supported by IA 3165 + ;Reference to EN1^GMRADPT supported by IA 10099 + ;Reference to ^PSXOPUTL supported by IA 2200 + ; +VIDEO() ; - Changes the Video Attributes for the list + ; + ; - Highlighting the PRESCRIPTION line if SIG is displayed + I $G(PSOSIGDP) D + . F I=1:1:LINE D + . . I $D(HIGHLN(I)) D CNTRL^VALM10(I,1,80,IOINHI,IOINORM) + ; + ; - Highlighting the group lines (order type and status) + I $D(GRPLN) D + . S LN=0 F I=1:1 S LN=$O(GRPLN(LN)) Q:'LN D + . . S LBL=GRPLN(LN),POS=41-($L(LBL)\2) + . . D CNTRL^VALM10(LN,1,POS-1,IOUON_IOINHI,IOINORM) + . . D CNTRL^VALM10(LN,POS,$L(LBL),IORVON_IOINHI,IOINORM) + . . D CNTRL^VALM10(LN,POS+$L(LBL),81-POS-$L(LBL),IOUON_IOINHI,IOINORM) + Q + ; +SETHDR() ; - Displays the Header Line + N HDR,ORD,POS + ; + ; - Line 1 + S $E(HDR,57)="ISSUE",$E(HDR,66)="LAST",$E(HDR,74)="REF",$E(HDR,78)="DAY" + S $E(HDR,81)="" D INSTR^VALM1(IORVON_HDR_IOINORM,1,6) + ; - Line 2 + S HDR=" #",$E(HDR,5)="Rx#",$E(HDR,19)="DRUG",$E(HDR,49)="QTY",$E(HDR,53)="ST" + S $E(HDR,57)="DATE",$E(HDR,66)="FILL",$E(HDR,74)="REM",$E(HDR,78)="SUP" + S $E(HDR,81)="" D INSTR^VALM1(IORVON_HDR_IOINORM,1,7) + S ORD=$S(PSORDER="A":"[^]",1:"[v]") + S:PSOSRTBY="RX" POS=9 S:PSOSRTBY="DR" POS=24 S:PSOSRTBY="ID" POS=61 S:PSOSRTBY="LF" POS=70 + D INSTR^VALM1(IOINHI_IORVON_ORD_IOINORM,POS,7) + Q + ; +SETSIG(TYPE,RX,LINE,DFN) ; Set the SIG line + N FSIG,L,X,DIWL,DIWR + ; + I TYPE="N" D Q + . K ^UTILITY($J,"W") + . S X=$$SCHED^PSONVNEW($$GET1^DIQ(55.05,RX_","_DFN,4)),DIWL=1,DIWR=71 D ^DIWP + . F L=1:1 Q:'$D(^UTILITY($J,"W",1,L)) D + . . S X="" S:L=1 $E(X,5)="SIG:" S $E(X,10)=^UTILITY($J,"W",1,L,0) + . . S LINE=LINE+1,^TMP("PSOPMP0",$J,LINE,0)=X + ; + D FSIG^PSOUTLA(TYPE,+RX,71) + F L=1:1 Q:'$D(FSIG(L)) D + . S X="" S:L=1 $E(X,5)="SIG:" S $E(X,10)=FSIG(L) + . S LINE=LINE+1,^TMP("PSOPMP0",$J,LINE,0)=X + Q + ; +GROUP(LBL,CNT,LINE) ; Sets a group delimiter line + N X,POS + S LBL=LBL_$S(PSORDCNT:" ("_CNT_" order"_$S(CNT>1:"s",1:"")_")",1:"") + S POS=41-($L(LBL)\2) + S X="",$P(X," ",81)="",$E(X,POS,POS-1+$L(LBL))=LBL + S LINE=LINE+1,^TMP("PSOPMP0",$J,LINE,0)=X,GRPLN(LINE)=LBL + Q + ; +PENHDR(DFN) ; Sets the Header in the ^TMP("PSOHDR",$J) global for displaying individual Pending Order + N VADM,WT,HT,PSOERR,GMRA + K ^TMP("PSOHDR",$J) D ^VADPT,ADD^VADPT + S ^TMP("PSOHDR",$J,1,0)=VADM(1),^TMP("PSOHDR",$J,2,0)=$P(VADM(2),"^",2) + S ^TMP("PSOHDR",$J,3,0)=$P(VADM(3),"^",2),^TMP("PSOHDR",$J,4,0)=VADM(4),^TMP("PSOHDR",$J,5,0)=$P(VADM(5),"^",2) + S POERR=1 D RE^PSODEM K PSOERR + S ^TMP("PSOHDR",$J,6,0)=$S(+$P(WT,"^",8):$J($P(WT,"^",9),6)_" ("_$P(WT,"^")_")",1:"_______ (______)") + S ^TMP("PSOHDR",$J,7,0)=$S($P(HT,"^",8):$J($P(HT,"^",9),6)_" ("_$P(HT,"^")_")",1:"_______ (______)") K VM,WT,HT S PSOHD=7 + S GMRA="0^0^111" D EN1^GMRADPT S ^TMP("PSOHDR",$J,8,0)=+$G(GMRAL) + Q + ; +FILTER(RX) ; - Filter Rx's that should not be displayed + I $$GET1^DIQ(52,RX,26,"I")11,$$GET1^DIQ(52,RX,100,"I")'=16 Q 1 + I $$GET1^DIQ(52,RX,100,"I")=""!($$GET1^DIQ(52,RX,100,"I")=13) Q 1 + I $$GET1^DIQ(52,RX,.01)="" Q 1 + Q 0 + ; +STSINFO(RX) ; Returns the Rx Status MNEMONIC^NAME + ; Input: RX - Prescription IEN (#52) + ;Output: Status Mnemonic ("A","DC",etc.)^Status Name ("ACTIVE","DISCONTINUED",etc.) + ; + N STS + I '$D(^PSRX(RX,"STA")) Q "" + S STS=$$GET1^DIQ(52,RX,100,"I") + I STS=0 Q:$$GET1^DIQ(52,RX,26,"I")>DT PSOSTSEQ("A") Q PSOSTSEQ("E") + I STS=1 Q PSOSTSEQ("N") + I STS=3 Q PSOSTSEQ("H") + I STS=5 Q PSOSTSEQ("S") + I STS=11 Q PSOSTSEQ("E") + I STS=12 Q PSOSTSEQ("DC") + I STS=14 Q PSOSTSEQ("DP") + I STS=15 Q PSOSTSEQ("DE") + I STS=16 Q PSOSTSEQ("PH") + Q "99^UNKNOWN^??" + ; +ISSDT(IEN,TYPE) ; Returns the Rx ISSUE DATE formatted MM-DD-YY + ;Input: RX - PrescrXiption IEN (#52) + ; TYPE - "R":Regular Rx, "P":Pending order + N ISSDT + I TYPE="R" S ISSDT=$$GET1^DIQ(52,IEN,1,"I") + I TYPE="P" S ISSDT=$$GET1^DIQ(52.41,IEN,6,"I") + I ISSDT'="" S ISSDT=ISSDT\1 + ; + Q (ISSDT_"^"_$$DAT(ISSDT,"-")) + ; +LSTFD(RX) ; Returns the Rx LAST FILL DATE formatted MM-DD-YY[R], where [R] = Returned to Stock + ;Input: RX - Prescription IEN (#52) + N LSTFD,RTSTK,RFL + S LSTFD=$$GET1^DIQ(52,RX,101,"I")\1 I LSTFD="" Q "" + I '$$LSTRFL^PSOBPSU1(RX) D + . I $$GET1^DIQ(52,RX,32.1,"I") S RTSTK="R" + E S RFL=0 F S RFL=$O(^PSRX(RX,1,RFL)) Q:'RFL D + . I $$RXFLDT^PSOBPSUT(RX,RFL)'=LSTFD Q + . I $$GET1^DIQ(52.1,RFL_","_RX,14,"I") S RTSTK="R" + ; + Q (LSTFD_"^"_$$DAT(LSTFD,"-")_$G(RTSTK)) + ; +REFREM(RX) ; - Returns the number of refills remaining + N REFREM,RFL + S REFREM=+$$GET1^DIQ(52,RX,9) + F RFL=0:1 S RFL=$O(^PSRX(RX,1,RFL)) Q:'RFL S REFREM=REFREM-1 + Q $S(REFREM<0:0,1:REFREM) + ; + ; +DAT(FMDT,SEP,Y4) ; - Formats FM dates to MM/DD/YY (SEP: Separator:"/","-",etc...) + ;Input: (r) FMDT - Fileman Date + ; (r) SEP - Separator + ; (o) Y4 - 4 digits year flag + I $G(FMDT)="" Q "" + I '$E(FMDT,6,7)!'$E(FMDT,4,7) Q $$UP^XLFSTR($TR($$FMTE^XLFDT(FMDT)," ","-")) + Q ($E(FMDT,4,5)_SEP_$E(FMDT,6,7)_SEP_$S($G(Y4):$E(FMDT,1,3)+1700,1:$E(FMDT,2,3))) + ; +COPAY(RX) ; Returns "$" is Rx has a copay and "" if not + Q $S($D(^PSRX(RX,"IB")):"$",1:"") + ; +CMOP(DRUG,RX) ; Returns the CMOP indicator (">", "T", etc) + N CMOP,X,DA,PSXZ + S CMOP="" I $D(^PSDRUG("AQ",DRUG)) S CMOP=">" + I $G(RX) S DA=RX D ^PSXOPUTL I $G(PSXZ(PSXZ("L")))=0!($G(PSXZ(PSXZ("L")))=2) S CMOP="T" + Q CMOP + ; +ALLERGY(LINE,DFN,POS) ; also called from PSONVAVW & PSOPMP0 + ; Input: LINE - (r) text to concatenate allergy information to + ; DFN - (r) patient IEN used for ^GMRADTP + ; POS - (o) position # to include text + ;Output: LINE - modified text + N ALLERGY,PSONOAL + S (PSONOAL,ALLERGY)="" + D EN1^GMRADPT + I GMRAL S ALLERGY="" + E D ALLERGY^PSOORUT2 I PSONOAL'="" S ALLERGY="" + S ALLERGY=IORVON_ALLERGY_IOINORM + I '$G(POS) S POS=80-$L(ALLERGY) + S LINE=$$SETSTR^VALM1(ALLERGY,LINE,POS,80) + Q LINE diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOPTPST.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOPTPST.m index 377d03a0..a916693a 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOPTPST.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOPTPST.m @@ -1,95 +1,93 @@ -PSOPTPST ;BIR/DSD - Post Patient Selection Action ;07/25/96 - ;;7.0;OUTPATIENT PHARMACY;**7,71,88,146,157,143,225**;DEC 1997;Build 29 - ;External reference to SDCO22 supported by DBIA 1579 - ;External reference to IBE(350.1,"ANEW" supported by DBIA 592 - ;External reference to PS(55 supported by DBIA 2228 - ;External reference to IBARX supported by DBIA 125 - ;External reference to $$GETSHAD^DGUTL3 supported by DBIA 4462 -START S PSOQFLG=0 - D GET ; Gets data from Patient file - D DEAD G:PSOQFLG END ; Checks to see if patient still alive - G:$G(PSOFROM("PTLKUP"))']"" END ; skips questions if not called by RX data entry - D INP G:PSOQFLG END ;Checks to see if inpatient and whether to continue - D CNH G:PSOQFLG END ; Checks to see if nursing home patient - D ELIG ; Checks eligibility - D:$G(DUZ("AG"))="V" COPAY ; Deals with copay - D ADDRESS ; Display address information - D:$G(^PS(55,PSODFN,1))]"" REMARKS ; Displays narrative about patient -END D EOJ - Q - ;---------------------------------------------------------- -GET K DIC,DR,DIQ S DIC=2,DA=PSODFN,DR=".1;.172;.351;.361;148",DIQ="PSOPTPST" - D EN^DIQ1 K DIC,DA,DR,DIQ - Q - ; -DEAD ; - I $G(PSOPTPST(2,PSODFN,.351))]"" S (PSODEATH,PSOQFLG)=1 S SSN=$P(^DPT(PSODFN,0),"^",9) W !?10,$C(7),PSORX("NAME")_" ("_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)_") DIED "_PSOPTPST(2,PSODFN,.351),! S:$G(POERR) POERR("DEAD")=1 D - .;I '$O(^PS(55,PSODFN,"P","A",DT)) Q - .S ACOM="Date of Death "_PSOPTPST(2,PSODFN,.351)_".",ZTRTN="CAN^PSOCAN3",ZTDESC="Outpatient Pharmacy Autocancel Due to Death of Patient",ZTSAVE("ACOM")="",ZTSAVE("PSODFN")="",ZTSAVE("PSODEATH")="" - .S ZTIO="",PSOCLC=DUZ,ZTSAVE("PSOCLC")="",ZTDTH=$H D ^%ZTLOAD K ACOM,ZTSK,PSODEATH - Q - ; -INP I '$G(PSOXFLG),'$G(PSOFIN),$G(PSOPTPST(2,PSODFN,.1))]"" S PSOXFLG=1,SSN=$P(^DPT(PSODFN,0),"^",9) W !!?10,$C(7),PSORX("NAME")_" ("_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)_")" K SSN - I $G(PSOPTPST(2,PSODFN,.1))]"" W !?10,$C(7),"Patient is an Inpatient on Ward "_PSOPTPST(2,PSODFN,.1)_" !!" D DIR - Q -TPB ; - N PSOTPSSN - I '$G(PSODFN) Q - I $D(^PS(52.91,PSODFN,0)) I '$P(^PS(52.91,PSODFN,0),"^",3)!($P(^(0),"^",3)>DT) D - .S PSOTPSSN=$P($G(^DPT(PSODFN,0)),"^",9) - .I $G(PSOFIN)!($G(MEDP)) D - ..I $G(MEDP) W !!?10,$C(7),$P($G(^DPT(PSODFN,0)),"^")_" ("_$E(PSOTPSSN,1,3)_"-"_$E(PSOTPSSN,4,5)_"-"_$E(PSOTPSSN,6,9)_")" Q - ..I $G(PSOFIN) I $G(PSOPTPST(2,PSODFN,148))="YES"!($G(PSOPTPST(2,PSODFN,.1))]"") W !!?10,$C(7),$P($G(^DPT(PSODFN,0)),"^")_" ("_$E(PSOTPSSN,1,3)_"-"_$E(PSOTPSSN,4,5)_"-"_$E(PSOTPSSN,6,9)_")" - .I '$G(PSOFIN),'$G(MEDP) W ! - .W !?10,"Patient is eligible for the Transitional Pharmacy Benefit!!" D DIR - Q - ; -CNH I $G(MEDP),$G(PSOPTPST(2,PSODFN,148))="YES",$G(PSOPTPST(2,PSODFN,.1))']"" D - .S SSN=$P(^DPT(PSODFN,0),"^",9) W !!?10,$C(7),PSORX("NAME")_" ("_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)_")" K SSN - K PSORX("CNH") I $G(PSOPTPST(2,PSODFN,148))="YES" W !?10,$C(7),"Patient is in a Contract Nursing Home !!" D DIR S:'$G(PSOQFLG) PSORX("CNH")=1 - Q - ; -ELIG I $G(PSOPTPST(2,PSODFN,.361))]"",$G(PSOPTPST(2,PSODFN,.172))'="I" W !,"MAS Eligibility: "_PSOPTPST(2,PSODFN,.361) - S DFN=PSODFN D RE^PSODEM - Q - ; -COPAY K PSOBILL,PSOCPAY S DFN=PSODFN,(X,PSOPTIB)=$P($G(^PS(59,+PSOSITE,"IB")),"^")_"^"_PSODFN D XTYPE^IBARX - I '$D(^IBE(350.1,"ANEW",+PSOPTIB,1,1)) S PSOQFLG=1 D K PSOPTIB Q - .W $C(7),!!,"There is a problem with the IB SERVICE/SECTION entry in your Pharmacy Site File." - .W !,"You will not be able to enter any new prescriptions until this is corrected!",! - S (ACTYP,BL)="",(PSOBILL,PSOCPAY)=0 I +Y=-1 W !,"ERROR IN COPAY ELIGIBILITY ENCOUNTERED." G COPAYX -COPAY1 S ACTYP=$O(Y(ACTYP)) G:'ACTYP COPAYX F III=0:0 S BL=$O(Y(ACTYP,BL)) Q:BL="" I BL>0 S PSOBILL=BL,PSOCPAY=BL_"^"_Y(ACTYP,BL) - G COPAY1 -COPAYX K X,Y,ACTYP,BL,III,PSOPTIB - ;I $G(PSOBILL) - D QST - Q - ; -ADDRESS N DFN S (DA,DFN)=PSODFN D ADD^VADPT K DFN,PSOI,DA,DR - Q - ; -REMARKS S PSOX=$G(^PS(55,PSODFN,1)) W !!,?5 - F PSOI=1:1 Q:$P(PSOX," ",PSOI,900)="" W:$X+$L($P(PSOX," ",PSOI))+$L(" ")>IOM !?5 W $P(PSOX," ",PSOI)_" " - K PSOX,PSOI - Q - ; -DIR K DIR W ! - S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do You Want To Continue" D ^DIR K DIR - S:'Y PSOQFLG=1 K X,Y,DIRUT,DTOUT,DUOUT - Q - ; -EOJ K:PSOQFLG PSORX("CNH") K PSOPTPST,VAPA - Q -QST ;Ask new questions for Copay - I '$$DT^PSOMLLDT Q - K PSOIBQS - I $G(PSOBILL) S PSOIBQS(PSODFN,"SC")="" - S PSOIBQS(PSODFN,"SC>50")="" - I +$P($$CVEDT^DGCV(PSODFN),"^",3) S PSOIBQS(PSODFN,"CV")="" - I $$AO^SDCO22(PSODFN) S PSOIBQS(PSODFN,"VEH")="" - I $$IR^SDCO22(PSODFN) S PSOIBQS(PSODFN,"RAD")="" - I $$EC^SDCO22(PSODFN) S PSOIBQS(PSODFN,"PGW")="" - I $L($T(GETSHAD^DGUTL3)) S:$$GETSHAD^DGUTL3(PSODFN)=1 PSOIBQS(PSODFN,"SHAD")="" - I $P($$GETSTAT^DGMSTAPI(PSODFN),"^",2)="Y" S PSOIBQS(PSODFN,"MST")="" - I $T(GETCUR^DGNTAPI)]"" N PSONCP,PSONCPX S PSONCPX=$$GETCUR^DGNTAPI(PSODFN,"PSONCP") I $P($G(PSONCP("IND")),"^")="Y" S PSOIBQS(PSODFN,"HNC")="" - Q +PSOPTPST ;BIR/DSD - Post Patient Selection Action ;07/25/96 + ;;7.0;OUTPATIENT PHARMACY;**7,71,88,146,157,143**;DEC 1997 + ;External reference to SDCO22 supported by DBIA 1579 + ;External reference to IBE(350.1,"ANEW" supported by DBIA 592 + ;External reference to PS(55 supported by DBIA 2228 + ;External reference to IBARX supported by DBIA 125 +START S PSOQFLG=0 + D GET ; Gets data from Patient file + D DEAD G:PSOQFLG END ; Checks to see if patient still alive + G:$G(PSOFROM("PTLKUP"))']"" END ; skips questions if not called by RX data entry + D INP G:PSOQFLG END ;Checks to see if inpatient and whether to continue + D CNH G:PSOQFLG END ; Checks to see if nursing home patient + D ELIG ; Checks eligibility + D:$G(DUZ("AG"))="V" COPAY ; Deals with copay + D ADDRESS ; Display address information + D:$G(^PS(55,PSODFN,1))]"" REMARKS ; Displays narrative about patient +END D EOJ + Q + ;---------------------------------------------------------- +GET K DIC,DR,DIQ S DIC=2,DA=PSODFN,DR=".1;.172;.351;.361;148",DIQ="PSOPTPST" + D EN^DIQ1 K DIC,DA,DR,DIQ + Q + ; +DEAD ; + I $G(PSOPTPST(2,PSODFN,.351))]"" S (PSODEATH,PSOQFLG)=1 S SSN=$P(^DPT(PSODFN,0),"^",9) W !?10,$C(7),PSORX("NAME")_" ("_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)_") DIED "_PSOPTPST(2,PSODFN,.351),! S:$G(POERR) POERR("DEAD")=1 D + .;I '$O(^PS(55,PSODFN,"P","A",DT)) Q + .S ACOM="Date of Death "_PSOPTPST(2,PSODFN,.351)_".",ZTRTN="CAN^PSOCAN3",ZTDESC="Outpatient Pharmacy Autocancel Due to Death of Patient",ZTSAVE("ACOM")="",ZTSAVE("PSODFN")="",ZTSAVE("PSODEATH")="" + .S ZTIO="",PSOCLC=DUZ,ZTSAVE("PSOCLC")="",ZTDTH=$H D ^%ZTLOAD K ACOM,ZTSK,PSODEATH + Q + ; +INP I '$G(PSOXFLG),'$G(PSOFIN),$G(PSOPTPST(2,PSODFN,.1))]"" S PSOXFLG=1,SSN=$P(^DPT(PSODFN,0),"^",9) W !!?10,$C(7),PSORX("NAME")_" ("_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)_")" K SSN + I $G(PSOPTPST(2,PSODFN,.1))]"" W !?10,$C(7),"Patient is an Inpatient on Ward "_PSOPTPST(2,PSODFN,.1)_" !!" D DIR + Q +TPB ; + N PSOTPSSN + I '$G(PSODFN) Q + I $D(^PS(52.91,PSODFN,0)) I '$P(^PS(52.91,PSODFN,0),"^",3)!($P(^(0),"^",3)>DT) D + .S PSOTPSSN=$P($G(^DPT(PSODFN,0)),"^",9) + .I $G(PSOFIN)!($G(MEDP)) D + ..I $G(MEDP) W !!?10,$C(7),$P($G(^DPT(PSODFN,0)),"^")_" ("_$E(PSOTPSSN,1,3)_"-"_$E(PSOTPSSN,4,5)_"-"_$E(PSOTPSSN,6,9)_")" Q + ..I $G(PSOFIN) I $G(PSOPTPST(2,PSODFN,148))="YES"!($G(PSOPTPST(2,PSODFN,.1))]"") W !!?10,$C(7),$P($G(^DPT(PSODFN,0)),"^")_" ("_$E(PSOTPSSN,1,3)_"-"_$E(PSOTPSSN,4,5)_"-"_$E(PSOTPSSN,6,9)_")" + .I '$G(PSOFIN),'$G(MEDP) W ! + .W !?10,"Patient is eligible for the Transitional Pharmacy Benefit!!" D DIR + Q + ; +CNH I $G(MEDP),$G(PSOPTPST(2,PSODFN,148))="YES",$G(PSOPTPST(2,PSODFN,.1))']"" D + .S SSN=$P(^DPT(PSODFN,0),"^",9) W !!?10,$C(7),PSORX("NAME")_" ("_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)_")" K SSN + K PSORX("CNH") I $G(PSOPTPST(2,PSODFN,148))="YES" W !?10,$C(7),"Patient is in a Contract Nursing Home !!" D DIR S:'$G(PSOQFLG) PSORX("CNH")=1 + Q + ; +ELIG I $G(PSOPTPST(2,PSODFN,.361))]"",$G(PSOPTPST(2,PSODFN,.172))'="I" W !,"MAS Eligibility: "_PSOPTPST(2,PSODFN,.361) + S DFN=PSODFN D RE^PSODEM + Q + ; +COPAY K PSOBILL,PSOCPAY S DFN=PSODFN,(X,PSOPTIB)=$P($G(^PS(59,+PSOSITE,"IB")),"^")_"^"_PSODFN D XTYPE^IBARX + I '$D(^IBE(350.1,"ANEW",+PSOPTIB,1,1)) S PSOQFLG=1 D K PSOPTIB Q + .W $C(7),!!,"There is a problem with the IB SERVICE/SECTION entry in your Pharmacy Site File." + .W !,"You will not be able to enter any new prescriptions until this is corrected!",! + S (ACTYP,BL)="",(PSOBILL,PSOCPAY)=0 I +Y=-1 W !,"ERROR IN COPAY ELIGIBILITY ENCOUNTERED." G COPAYX +COPAY1 S ACTYP=$O(Y(ACTYP)) G:'ACTYP COPAYX F III=0:0 S BL=$O(Y(ACTYP,BL)) Q:BL="" I BL>0 S PSOBILL=BL,PSOCPAY=BL_"^"_Y(ACTYP,BL) + G COPAY1 +COPAYX K X,Y,ACTYP,BL,III,PSOPTIB + ;I $G(PSOBILL) + D QST + Q + ; +ADDRESS N DFN S (DA,DFN)=PSODFN D ADD^VADPT K DFN,PSOI,DA,DR + Q + ; +REMARKS S PSOX=$G(^PS(55,PSODFN,1)) W !!,?5 + F PSOI=1:1 Q:$P(PSOX," ",PSOI,900)="" W:$X+$L($P(PSOX," ",PSOI))+$L(" ")>IOM !?5 W $P(PSOX," ",PSOI)_" " + K PSOX,PSOI + Q + ; +DIR K DIR W ! + S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do You Want To Continue" D ^DIR K DIR + S:'Y PSOQFLG=1 K X,Y,DIRUT,DTOUT,DUOUT + Q + ; +EOJ K:PSOQFLG PSORX("CNH") K PSOPTPST,VAPA + Q +QST ;Ask new questions for Copay + I '$$DT^PSOMLLDT Q + K PSOIBQS + I $G(PSOBILL) S PSOIBQS(PSODFN,"SC")="" + S PSOIBQS(PSODFN,"SC>50")="" + I +$P($$CVEDT^DGCV(PSODFN),"^",3) S PSOIBQS(PSODFN,"CV")="" + I $$AO^SDCO22(PSODFN) S PSOIBQS(PSODFN,"VEH")="" + I $$IR^SDCO22(PSODFN) S PSOIBQS(PSODFN,"RAD")="" + I $$EC^SDCO22(PSODFN) S PSOIBQS(PSODFN,"PGW")="" + I $P($$GETSTAT^DGMSTAPI(PSODFN),"^",2)="Y" S PSOIBQS(PSODFN,"MST")="" + I $T(GETCUR^DGNTAPI)]"" N PSONCP,PSONCPX S PSONCPX=$$GETCUR^DGNTAPI(PSODFN,"PSONCP") I $P($G(PSONCP("IND")),"^")="Y" S PSOIBQS(PSODFN,"HNC")="" + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOR52.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOR52.m index 55dde9e1..a13fb028 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOR52.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOR52.m @@ -1,132 +1,132 @@ -PSOR52 ;IHS/DSD/JCM - Files refill entries in prescription file ;03/10/93 - ;;7.0;OUTPATIENT PHARMACY;**10,22,27,181,148,201,260,281**;DEC 1997;Build 41 - ;Reference to ^PSDRUG supported by DBIA 221 - ;Reference to PSOUL^PSSLOCK supported by DBIA 2789 - ;Reference SWSTAT^IBBAPI supported by DBIA 4663 - ;Reference SAVNDC^PSSNDCUT supported by DBIA 4707 - ; This routine is responsible for the actual - ; filling of the refill prescription. - ;--------------------------------------------------------- -EN(PSOX) ;Entry Point -START ; - D:$D(XRTL) T0^%ZOSV ; Start RT monitor - D INIT G:PSOR52("QFLG") END - D FILE - D DIK - S:$D(XRT0) XRTN=$T(+0) D:$D(XRT0) T1^%ZOSV ; Stop RT Monitor - D FINISH -END D EOJ - Q - ;--------------------------------------------------------- - ; -INIT ; - S PSOR52("QFLG")=0 - S PSOX("QTY")=$P(PSOX("RX0"),"^",7),PSOX("DAYS SUPPLY")=$P(PSOX("RX0"),"^",8) - S:$G(^PSDRUG($P(PSOX("RX0"),"^",6),660))]"" PSOX("COST")=$P(^PSDRUG($P(PSOX("RX0"),"^",6),660),"^",6) - D NOW^%DTC S PSOX("LOGIN DATE")=$E(%,1,7) - S X1=PSOX("FILL DATE"),X2=PSOX("DAYS SUPPLY")-10\1 D C^%DTC S PSOX1=X - S X1=$P(PSOX("RX2"),"^",2) - S X2=PSOX("DAYS SUPPLY")*(PSOX("NUMBER")+1)-10\1 - D C^%DTC S PSOX2=X - S PSOX("NEXT POSSIBLE REFILL")=$S(PSOX1>PSOX2:PSOX1,1:PSOX2) - K X,PSOX1,PSOX2 - S (PSOX("LAST DISPENSED DATE"),PSOX("DISPENSED DATE"))=PSOX("FILL DATE") - I PSOX("FILL DATE")>$S($G(PSOX("LOGIN DATE")):$E(PSOX("LOGIN DATE"),1,7),1:DT),$P(PSOPAR,"^",6) D - .S PSOX("OLD MAIL/WINDOW")=$S($G(PSOX("MAIL/WINDOW"))]"":PSOX("MAIL/WINDOW"),1:"MAIL"),PSOX("MAIL/WINDOW")="M" - I $P(PSOX("RX2"),"^",12)]"" S PSOX("GENERIC PROVIDER")=$P(PSOX("RX2"),"^",12) - S PSOX("PROVIDER")=$P(PSOX("RX0"),"^",4) - S:'$D(PSOX("CLERK CODE")) PSOX("CLERK CODE")=DUZ - S PSOX("DAW")=$$GETDAW^PSODAWUT(+PSOX("IRXN")),PSOX("NDC")=$$GETNDC^PSSNDCUT($P(PSOX("RX0"),"^",6)) -INITX Q - ; -FILE ; - ;L +^PSRX(PSOX("IRXN")):0 - I '$D(^PSRX(PSOX("IRXN"),1,0)) S ^(0)="^52.1DA^1^1" - E S ^PSRX(PSOX("IRXN"),1,0)=$P(^PSRX(PSOX("IRXN"),1,0),"^",1,2)_"^"_PSOX("NUMBER")_"^"_($P(^(0),"^",4)+1) - F PSOX1=1:1 S PSOR52=$P($T(DD+PSOX1),";;",2,4) Q:PSOR52="" K PSOY S PSOY=$P(PSOR52,";;") I $D(@PSOY) S $P(PSOR52(PSOX("IRXN"),1,PSOX("NUMBER"),$P(PSOR52,";;",2)),"^",$P(PSOR52,";;",3))=@PSOY - K PSOX1,PSOY - S PSOX1="" F S PSOX1=$O(PSOR52(PSOX("IRXN"),1,PSOX("NUMBER"),PSOX1)) Q:PSOX1="" S ^PSRX(PSOX("IRXN"),1,PSOX("NUMBER"),PSOX1)=$G(PSOR52(PSOX("IRXN"),1,PSOX("NUMBER"),PSOX1)) - K PSOX1 - S:PSOX("STA")=6 $P(^PSRX(PSOX("IRXN"),"STA"),"^")=0 - S $P(^PSRX(PSOX("IRXN"),3),"^",1,2)=PSOX("LAST DISPENSED DATE")_"^"_PSOX("NEXT POSSIBLE REFILL") - S $P(^PSRX(PSOX("IRXN"),3),"^",4)=PSOX("LAST REFILL DATE") - I $D(PSOX("METHOD OF PICK-UP")),PSOX("FILL DATE")'>DT S $P(^PSRX(PSOX("IRXN"),"MP"),"^")=PSOX("METHOD OF PICK-UP") - D:$$SWSTAT^IBBAPI() GACT^PSOPFSU0(PSOX("IRXN"),PSOX("NUMBER")) - ;L -^PSRX(PSOX("IRXN")) - Q - ; -DIK ; - K DIK,DA - S DIK="^PSRX(",DA=PSOX("IRXN") D IX1^DIK K DIK - I +$G(^PSRX(DA,"IB")),$P(^PSRX(DA,1,PSOX("NUMBER"),0),"^",2)="W" S ^PSRX("ACP",$P(^PSRX(DA,0),"^",2),$P(^PSRX(DA,1,PSOX("NUMBER"),0),"^"),PSOX("NUMBER"),DA)="" K DA - D:$T(EN^PSOHDR)]"" EN^PSOHDR("PREF",PSOX("IRXN")) - Q - ; -FINISH ; - I $G(PSOX("QS"))="S" D G FINISHX - . S DA=PSOX("IRXN"),RXFL(PSOX("IRXN"))=PSOX("NUMBER") - . D SUS^PSORXL K DA - ; - ; - Previous ePharmacy Refill was Deleted and a new one is being entered - I '$$SUBMIT^PSOBPSUT(PSOX("IRXN"),PSOX("NUMBER")),$$STATUS^PSOBPSUT(PSOX("IRXN"),PSOX("NUMBER"))'="" D - . D RETRXF^PSOREJU2(PSOX("IRXN"),PSOX("NUMBER"),1) - ; - I PSOX("FILL DATE")>$S($G(PSOX("LOGIN DATE")):$E(PSOX("LOGIN DATE"),1,7),1:DT),$P(PSOPAR,"^",6) D G FINISHX - .K PSOXRXFL I $D(RXFL(PSOX("IRXN"))) S PSOXRXFL=$G(RXFL(PSOX("IRXN"))) - .S DA=PSOX("IRXN"),RXFL(PSOX("IRXN"))=PSOX("NUMBER") - .D SUS^PSORXL K DA - .I $G(PSOXRXFL)'="" S RXFL(PSOX("IRXN"))=$G(PSOXRXFL) K PSOXRXFL - ; - ; - Calling ECME for claims generation and transmission / REJECT handling - N ACTION,PSOERX,PSOERF - S PSOERX=PSOX("IRXN"),PSOERF=PSOX("NUMBER") - I $$SUBMIT^PSOBPSUT(PSOERX,PSOERF) D I ACTION="Q"!(ACTION="^") Q - . S ACTION="" D ECMESND^PSOBPSU1(PSOERX,PSOERF,PSOX("FILL DATE"),"RF") - . I $$FIND^PSOREJUT(PSOERX,PSOERF) D - . . S ACTION=$$HDLG^PSOREJU1(PSOERX,PSOERF,"79,88","OF","IOQ","Q") - . I $$STATUS^PSOBPSUT(PSOERX,PSOERF)="E PAYABLE" D - . . D SAVNDC^PSSNDCUT(+$$GET1^DIQ(52,PSOERX,6,"I"),$G(PSOSITE),$$GETNDC^PSONDCUT(PSOERX,PSOERF)) - ; - I $G(PSOX("QS"))="Q" D G FINISHX - . I $G(PPL),$L(PPL_PSOX("IRXN")_",")>240 D TRI^PSOBBC D Q^PSORXL K PPL,RXFL - . S RXFL(PSOX("IRXN"))=PSOX("NUMBER") - . I $G(PPL) S PPL=PPL_PSOX("IRXN")_"," - . E S PPL=PSOX("IRXN")_"," - ; - I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=PSOX("IRXN")_",",RXFL(PSOX("IRXN"))=PSOX("NUMBER") G FINISHX - F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1 S PSOX2=PSOX1 - I $L(PSORX("PSOL",PSOX2))+$L(PSOX("IRXN"))<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_PSOX("IRXN")_"," - E S PSORX("PSOL",PSOX2+1)=PSOX("IRXN")_"," - S RXFL(PSOX("IRXN"))=PSOX("NUMBER") - ; -FINISHX ; - I $G(PSORX("MAIL/WINDOW"))["W" S BINGCRT=1,BINGRTE="W",BBFLG=1 D BBRX^PSORN52C - K PSOX1,PSOX2 - Q -EOJ ; - I $D(PSOX("OLD MAIL/WINDOW")) S PSOX("MAIL/WINDOW")=PSOX("OLD MAIL/WINDOW") K PSOX("OLD MAIL/WINDOW") - S DA=$O(^PS(52.41,"ARF",PSOX("IRXN"),0)) I DA D S DIK="^PS(52.41," D ^DIK - .S PSORFKL=DA D PSOUL^PSSLOCK(PSORFKL_"S") K PSORFKL - K PSOR52,DA,DIK - Q - ; -DD ;rx data nodes - ;;PSOX("PROVIDER");;0;;17 - ;;PSOX("QTY");;0;;4 - ;;PSOX("DAYS SUPPLY");;0;;10 - ;;PSOX("MAIL/WINDOW");;0;;2 - ;;PSOX("REMARKS");;0;;3 - ;;PSOX("CLERK CODE");;0;;7 - ;;PSOX("COST");;0;;11 - ;;PSOSITE;;0;;9 - ;;PSOX("LOGIN DATE");;0;;8 - ;;PSOX("FILL DATE");;0;;1 - ;;PSOX("PHARMACIST");;0;;5 - ;;PSOX("LOT #");;0;;6 - ;;PSOX("DISPENSED DATE");;0;;19 - ;;PSOX("NDC");;1;;3 - ;;PSOX("DAW");;EPH;;1 - ;;PSOX("MANUFACTURER");;0;;14 - ;;PSOX("EXPIRATION DATE");;0;;15 - ;;PSOX("GENERIC PROVIDER");;1;;1 - ;;PSOX("RELEASED DATE/TIME");;0;;18 +PSOR52 ;IHS/DSD/JCM - Files refill entries in prescription file ;03/10/93 + ;;7.0;OUTPATIENT PHARMACY;**10,22,27,181,148,201,260**;DEC 1997;Build 84 + ;Reference to ^PSDRUG supported by DBIA 221 + ;Reference to PSOUL^PSSLOCK supported by DBIA 2789 + ;Reference SWSTAT^IBBAPI supported by DBIA 4663 + ;Reference SAVNDC^PSSNDCUT supported by DBIA 4707 + ; This routine is responsible for the actual + ; filling of the refill prescription. + ;--------------------------------------------------------- +EN(PSOX) ;Entry Point +START ; + D:$D(XRTL) T0^%ZOSV ; Start RT monitor + D INIT G:PSOR52("QFLG") END + D FILE + D DIK + S:$D(XRT0) XRTN=$T(+0) D:$D(XRT0) T1^%ZOSV ; Stop RT Monitor + D FINISH +END D EOJ + Q + ;--------------------------------------------------------- + ; +INIT ; + S PSOR52("QFLG")=0 + S PSOX("QTY")=$P(PSOX("RX0"),"^",7),PSOX("DAYS SUPPLY")=$P(PSOX("RX0"),"^",8) + S:$G(^PSDRUG($P(PSOX("RX0"),"^",6),660))]"" PSOX("COST")=$P(^PSDRUG($P(PSOX("RX0"),"^",6),660),"^",6) + D NOW^%DTC S PSOX("LOGIN DATE")=$E(%,1,7) + S X1=PSOX("FILL DATE"),X2=PSOX("DAYS SUPPLY")-10\1 D C^%DTC S PSOX1=X + S X1=$P(PSOX("RX2"),"^",2) + S X2=PSOX("DAYS SUPPLY")*(PSOX("NUMBER")+1)-10\1 + D C^%DTC S PSOX2=X + S PSOX("NEXT POSSIBLE REFILL")=$S(PSOX1>PSOX2:PSOX1,1:PSOX2) + K X,PSOX1,PSOX2 + S (PSOX("LAST DISPENSED DATE"),PSOX("DISPENSED DATE"))=PSOX("FILL DATE") + I PSOX("FILL DATE")>$S($G(PSOX("LOGIN DATE")):$E(PSOX("LOGIN DATE"),1,7),1:DT),$P(PSOPAR,"^",6) D + .S PSOX("OLD MAIL/WINDOW")=$S($G(PSOX("MAIL/WINDOW"))]"":PSOX("MAIL/WINDOW"),1:"MAIL"),PSOX("MAIL/WINDOW")="M" + I $P(PSOX("RX2"),"^",12)]"" S PSOX("GENERIC PROVIDER")=$P(PSOX("RX2"),"^",12) + S PSOX("PROVIDER")=$P(PSOX("RX0"),"^",4) + S:'$D(PSOX("CLERK CODE")) PSOX("CLERK CODE")=DUZ + S PSOX("DAW")=$$GETDAW^PSODAWUT(+PSOX("IRXN")),PSOX("NDC")=$$GETNDC^PSSNDCUT($P(PSOX("RX0"),"^",6)) +INITX Q + ; +FILE ; + ;L +^PSRX(PSOX("IRXN")):0 + I '$D(^PSRX(PSOX("IRXN"),1,0)) S ^(0)="^52.1DA^1^1" + E S ^PSRX(PSOX("IRXN"),1,0)=$P(^PSRX(PSOX("IRXN"),1,0),"^",1,2)_"^"_PSOX("NUMBER")_"^"_($P(^(0),"^",4)+1) + F PSOX1=1:1 S PSOR52=$P($T(DD+PSOX1),";;",2,4) Q:PSOR52="" K PSOY S PSOY=$P(PSOR52,";;") I $D(@PSOY) S $P(PSOR52(PSOX("IRXN"),1,PSOX("NUMBER"),$P(PSOR52,";;",2)),"^",$P(PSOR52,";;",3))=@PSOY + K PSOX1,PSOY + S PSOX1="" F S PSOX1=$O(PSOR52(PSOX("IRXN"),1,PSOX("NUMBER"),PSOX1)) Q:PSOX1="" S ^PSRX(PSOX("IRXN"),1,PSOX("NUMBER"),PSOX1)=$G(PSOR52(PSOX("IRXN"),1,PSOX("NUMBER"),PSOX1)) + K PSOX1 + S:PSOX("STA")=6 $P(^PSRX(PSOX("IRXN"),"STA"),"^")=0 + S $P(^PSRX(PSOX("IRXN"),3),"^",1,2)=PSOX("LAST DISPENSED DATE")_"^"_PSOX("NEXT POSSIBLE REFILL") + S $P(^PSRX(PSOX("IRXN"),3),"^",4)=PSOX("LAST REFILL DATE") + I $D(PSOX("METHOD OF PICK-UP")),PSOX("FILL DATE")'>DT S $P(^PSRX(PSOX("IRXN"),"MP"),"^")=PSOX("METHOD OF PICK-UP") + D:$$SWSTAT^IBBAPI() GACT^PSOPFSU0(PSOX("IRXN"),PSOX("NUMBER")) + ;L -^PSRX(PSOX("IRXN")) + Q + ; +DIK ; + K DIK,DA + S DIK="^PSRX(",DA=PSOX("IRXN") D IX1^DIK K DIK + I +$G(^PSRX(DA,"IB")),$P(^PSRX(DA,1,PSOX("NUMBER"),0),"^",2)="W" S ^PSRX("ACP",$P(^PSRX(DA,0),"^",2),$P(^PSRX(DA,1,PSOX("NUMBER"),0),"^"),PSOX("NUMBER"),DA)="" K DA + D:$T(EN^PSOHDR)]"" EN^PSOHDR("PREF",PSOX("IRXN")) + Q + ; +FINISH ; + I $G(PSOX("QS"))="S" D G FINISHX + . S DA=PSOX("IRXN"),RXFL(PSOX("IRXN"))=PSOX("NUMBER") + . D SUS^PSORXL K DA + ; + ; - Previous ePharmacy Refill was Deleted and a new one is being entered + I '$$SUBMIT^PSOBPSUT(PSOX("IRXN"),PSOX("NUMBER")),$$STATUS^PSOBPSUT(PSOX("IRXN"),PSOX("NUMBER"))'="" D + . D RETRXF^PSOREJU2(PSOX("IRXN"),PSOX("NUMBER"),1) + ; + I PSOX("FILL DATE")>$S($G(PSOX("LOGIN DATE")):$E(PSOX("LOGIN DATE"),1,7),1:DT),$P(PSOPAR,"^",6) D G FINISHX + .K PSOXRXFL I $D(RXFL(PSOX("IRXN"))) S PSOXRXFL=$G(RXFL(PSOX("IRXN"))) + .S DA=PSOX("IRXN"),RXFL(PSOX("IRXN"))=PSOX("NUMBER") + .D SUS^PSORXL K DA + .I $G(PSOXRXFL)'="" S RXFL(PSOX("IRXN"))=$G(PSOXRXFL) K PSOXRXFL + ; + ; - Calling ECME for claims generation and transmission / REJECT handling + N ACTION,PSOERX,PSOERF + S PSOERX=PSOX("IRXN"),PSOERF=PSOX("NUMBER") + I $$SUBMIT^PSOBPSUT(PSOERX,PSOERF) D I ACTION="Q"!(ACTION="^") Q + . S ACTION="" D ECMESND^PSOBPSU1(PSOERX,PSOERF,PSOX("FILL DATE"),"RF") + . I $$FIND^PSOREJUT(PSOERX,PSOERF) D + . . S ACTION=$$HDLG^PSOREJU1(PSOERX,PSOERF,"79,88","OF","IOQ","I") + . I $$STATUS^PSOBPSUT(PSOERX,PSOERF)="E PAYABLE" D + . . D SAVNDC^PSSNDCUT(+$$GET1^DIQ(52,PSOERX,6,"I"),$G(PSOSITE),$$GETNDC^PSONDCUT(PSOERX,PSOERF)) + ; + I $G(PSOX("QS"))="Q" D G FINISHX + . I $G(PPL),$L(PPL_PSOX("IRXN")_",")>240 D TRI^PSOBBC D Q^PSORXL K PPL,RXFL + . S RXFL(PSOX("IRXN"))=PSOX("NUMBER") + . I $G(PPL) S PPL=PPL_PSOX("IRXN")_"," + . E S PPL=PSOX("IRXN")_"," + ; + I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=PSOX("IRXN")_",",RXFL(PSOX("IRXN"))=PSOX("NUMBER") G FINISHX + F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1 S PSOX2=PSOX1 + I $L(PSORX("PSOL",PSOX2))+$L(PSOX("IRXN"))<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_PSOX("IRXN")_"," + E S PSORX("PSOL",PSOX2+1)=PSOX("IRXN")_"," + S RXFL(PSOX("IRXN"))=PSOX("NUMBER") + ; +FINISHX ; + I $G(PSORX("MAIL/WINDOW"))["W" S BINGCRT=1,BINGRTE="W",BBFLG=1 D BBRX^PSORN52C + K PSOX1,PSOX2 + Q +EOJ ; + I $D(PSOX("OLD MAIL/WINDOW")) S PSOX("MAIL/WINDOW")=PSOX("OLD MAIL/WINDOW") K PSOX("OLD MAIL/WINDOW") + S DA=$O(^PS(52.41,"ARF",PSOX("IRXN"),0)) I DA D S DIK="^PS(52.41," D ^DIK + .S PSORFKL=DA D PSOUL^PSSLOCK(PSORFKL_"S") K PSORFKL + K PSOR52,DA,DIK + Q + ; +DD ;rx data nodes + ;;PSOX("PROVIDER");;0;;17 + ;;PSOX("QTY");;0;;4 + ;;PSOX("DAYS SUPPLY");;0;;10 + ;;PSOX("MAIL/WINDOW");;0;;2 + ;;PSOX("REMARKS");;0;;3 + ;;PSOX("CLERK CODE");;0;;7 + ;;PSOX("COST");;0;;11 + ;;PSOSITE;;0;;9 + ;;PSOX("LOGIN DATE");;0;;8 + ;;PSOX("FILL DATE");;0;;1 + ;;PSOX("PHARMACIST");;0;;5 + ;;PSOX("LOT #");;0;;6 + ;;PSOX("DISPENSED DATE");;0;;19 + ;;PSOX("NDC");;1;;3 + ;;PSOX("DAW");;EPH;;1 + ;;PSOX("MANUFACTURER");;0;;14 + ;;PSOX("EXPIRATION DATE");;0;;15 + ;;PSOX("GENERIC PROVIDER");;1;;1 + ;;PSOX("RELEASED DATE/TIME");;0;;18 diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOREF.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOREF.m index 46423fb9..bd0731e7 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOREF.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOREF.m @@ -1,132 +1,123 @@ -PSOREF ;BIR/SAB-refill data entry ;12:03 PM 31 Dec 2008 - ;;7.0;OUTPATIENT PHARMACY;**1,23,27,36,46,78,130,131,148,206,208**;DEC 1997;Build 41;WorldVistA 30-Jan-08 - ; - ;Modified from FOIA VISTA, - ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;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 Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - ;External reference to ^PSDRUG supported by DBIA 221 - ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789 - ; -EOJ ; - K PSOMSG,PSOREF,PSORX("BAR CODE"),PSOLIST,LFD,MAX,MIN,NODE,PS,PSOERR,REF,RF,RXO,RXN,RXP,RXS,SD,VAERR,PSORX("FILL DATE") - D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) - Q -OERR ;single refil - ;WVEHR ;begin p208 - S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" ;vfah - D ^DIC K DIC ;vfah - S PSOZAF=+Y ;vfah - I $P($G(^PSRX(RXN,"OR1")),"^",5)=$G(PSOZAF) S VALMBCK="",VALMSG="Refill option is not available for Autofinshed Rxs" K PSOZAF Q ;vfah - ;WVEHR ;end p208 - I $$LMREJ^PSOREJU1($P(PSOLST(ORN),"^",2),,.VALMSG,.VALMBCK) Q - I $D(RXRP($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Reprint Label has been requested!" Q - I $D(RXPR($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Partial has already been requested!" Q - I $D(RXRS($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="Rx is being pulled from suspense!" Q - I $D(RXFL($P(PSOLST(ORN),"^",2))) S PTRX=$P(PSOLST(ORN),"^",2) D ^PSOCMOPT I '$G(PSOXFLAG) K PSOXFLAG S VALMBCK="",VALMSG="Fill already requested for CMOP!" Q - K PSOXFLAG - D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG Q - N RXN K PSORX("FILL DATE") D FULL^VALM1 S:$G(PSOFROM)'="NEW" PSOFROM="REFILL" S PSOREF("DFLG")=0,PSOREF("IRXN")=$P(PSOLST(ORN),"^",2),PSOREF("QFLG")=0 - K PSOID D ^PSOREF1 I PSOREF("DFLG") D EOJ S VALMBCK="R" Q - D ^PSOREF0 - W ! K DIR,DIRUT,DTOUT,DUOUT S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR,DIRUT,DTOUT,DUOUT S PSORXED=1 D ^PSOBUILD,ACT^PSOORNE2 K PSORXED S VALMBCK="Q" D EOJ - Q -SPEED ;speed refill - K LST,PSORX("FILL DATE") N VALMCNT I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!" S VALMBCK="" Q - K DIR,DIRUT S DIR(0)="Y",DIR("B")="NO",DIR("A")="Barcode Refill",DIR("?")="If you want to use a barcode reader to process refills enter 'Y'." - D ^DIR K DIR,DUOUT,DTOUT I $D(DIRUT) S VALMBCK="" Q - G BCREF:Y - K PSOREF,PSOFDR,DIR,DUOUT,DIRUT S DIR("A")="Select Orders by number",DIR(0)="LO^1:"_PSOCNT D ^DIR I $D(DTOUT)!($D(DUOUT)) K DIR,DIRUT,DTOUT,DUOUT S VALMBCK="" Q - K DIR,DIRUT,DTOUT,PSOOELSE,DTOUT I +Y S (ASK,SPEED,PSOOELSE)=1 D FULL^VALM1 S LST=Y D G:$G(PSOREF("DFLG"))!($G(PSOREF("QFLG"))) SPEEDX - .F ORD=1:1:$L(LST,",") Q:$P(LST,",",ORD)']""!($G(PSOREF("QFLG"))) S ORN=$P(LST,",",ORD) D:+PSOLST(ORN)=52 - ..;WVEHR ;begin p208 - ..S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" ;vfah - ..D ^DIC K DIC ;vfah - ..S PSOZAF=+Y ;vfah - ..I $P($G(^PSRX($P(PSOLST(ORN),"^",2),"OR1")),"^",5)=$G(PSOZAF) W $C(7),!!,"Rx "_$$GET1^DIQ(52,$P(PSOLST(ORN),"^",2),.01)_" is an Autofinish,Rx and can not be refilled" K PSOZAF D PAUSE^VALM1 Q ;vfah - ..;WVEHR ;end p208 - ..I $$LMREJ^PSOREJU1($P(PSOLST(ORN),"^",2)) W $C(7),!!,"Rx "_$$GET1^DIQ(52,$P(PSOLST(ORN),"^",2),.01)_" has OPEN/UNRESOLVED 3rd Party Payer Reject!" K DIR D PAUSE^VALM1 Q - ..D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) W $C(7),!!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing Rx "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^")),! D PAUSE^VALM1 K PSOMSG Q - ..K PSOMSG I $D(RXRP($P(PSOLST(ORN),"^",2))) W $C(7),!!,"A Reprint Label has been requested!" D ULK D PAUSE^VALM1 Q - ..I $D(RXPR($P(PSOLST(ORN),"^",2))) W $C(7),!!,"A Partial has already been requested!" D ULK D PAUSE^VALM1 Q - ..I $D(RXFL($P(PSOLST(ORN),"^",2))) S PTRX=$P(PSOLST(ORN),"^",2) D ^PSOCMOPT I '$G(PSOXFLAG) K PSOXFLAG W $C(7),!!,"A CMOP fill has already been requested for Rx "_$P($G(^PSRX($P(PSOLST(ORN),"^",2),0)),"^") D ULK D PAUSE^VALM1 Q - ..K PSOXFLAG I $D(RXRS($P(PSOLST(ORN),"^",2))) W $C(7),!!,"Rx is being pulled from suspense!" D ULK D PAUSE^VALM1 Q - ..I $P($G(^PSRX($P(PSOLST(ORN),"^",2),"STA")),"^")=11 D D ULK Q - ...W $C(7),!!?5,"RX "_$P($G(^PSRX($P(PSOLST(ORN),"^",2),0)),"^")_" is in an EXPIRED status." W ! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR - ..S PSOREF("IRXN")=$P(PSOLST(ORN),"^",2) I ASK D ^PSOREF1 S ASK=0 D:$G(PSOREF("QFLG")) ULK Q:$G(PSOREF("QFLG")) - ..N RXN D FULL^VALM1 S:$G(PSOFROM)'="NEW" PSOFROM="REFILL" S PSOREF("DFLG")=0,PSOREF("IRXN")=$P(PSOLST(ORN),"^",2) - ..I PSOREF("DFLG") D EOJ S VALMBCK="R" Q - ..D ^PSOREF0 D ULK - S:'$G(PSOOELSE) VALMBCK="" - S PSORXED=1 D ^PSOBUILD,BLD^PSOORUT1 -SPEEDX K PSOREF,PSORX("BAR CODE"),PSOLIST,LFD,MAX,MIN,NODE,PS,PSOERR,REF,RF,RXO,RXN,RXP,RXS,SD,VAERR,PSORX("FILL DATE") - K LST,SPEED,PSORXED,PSOREF,PSOFDR,PSOOELSE,ASK S:'$D(VALMBCK) VALMBCK="R" - K PSORX("FILL DATE"),PSORX("MAIL/WINDOW"),PSORX("METHOD OF PICK-UP") - Q -BCREF ;barcode refills - K LST,DIR,DIRUT,DUOUT,DTOUT D FULL^VALM1 -ASK S DIR(0)="FO^5:245^K:X'?3N1""-""1.N X",DIR("A")="WAND BARCODE" - S DIR("?",1)="Wand the barcoded number of the prescription to be processed." - S DIR("?",2)="The number should be of the form NNN-NNNNNN",DIR("?",3)="where the number before the dash is your station number." - S DIR("?")="Enter ""^"", or a RETURN to quit." - D ^DIR I $D(DUOUT)!($D(DTOUT)) S VALMBCK="" G BCREFX - I $G(X)']"",'$G(LST) S VALMBCK="" G BCREFX - I $D(DIRUT),+$G(LST) D S VALMBCK="R" G BCREFX - .K DIR,DIRUT,DTOUT,PSOOELSE,DTOUT - .S (BCREF,ASK,SPEED,PSOOELSE)=1 D FULL^VALM1 D - ..F ORD=1:1:$L(LST,",") Q:$P(LST,",",ORD)']""!($G(PSOREF("QFLG"))) S ORN=$P(LST,",",ORD) D:+PSOLST(ORN)=52 - ...I $$LMREJ^PSOREJU1($P(PSOLST(ORN),"^",2)) W $C(7),!!,"Rx "_$$GET1^DIQ(52,$P(PSOLST(ORN),"^",2),.01)_" has OPEN/UNRESOLVED 3rd Party Payer Reject!" K DIR D PAUSE^VALM1 Q - ...D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) W $C(7),!!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing Rx "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^")),! D PAUSE^VALM1 K PSOMSG Q - ...K PSOMSG I $D(RXRP($P(PSOLST(ORN),"^",2))) W $C(7),!!,"A Reprint Label has been requested for Rx "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^"),! D ULK D PAUSE^VALM1 Q - ...I $D(RXPR($P(PSOLST(ORN),"^",2))) W $C(7),!!,"A Partial has already been requested for Rx "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^"),! D ULK D PAUSE^VALM1 Q - ...I $D(RXFL($P(PSOLST(ORN),"^",2))) S PTRX=$P(PSOLST(ORN),"^",2) D ^PSOCMOPT I '$G(PSOXFLAG) K PSOXFLAG W $C(7),!!,"A CMOP fill has already been requested for Rx "_$P($G(^PSRX($P(PSOLST(ORN),"^",2),0)),"^") D ULK D PAUSE^VALM1 Q - ...K PSOXFLAG I $D(RXRS($P(PSOLST(ORN),"^",2))) W $C(7),!!,"Rx "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^")_" is being pulled from suspense!" D ULK D PAUSE^VALM1 Q - ...S PSOREF("IRXN")=$P(PSOLST(ORN),"^",2) I ASK D ^PSOREF1 S ASK=0 D:$G(PSOREF("DFLG")) ULK Q:$G(PSOREF("DFLG")) - ...N RXN D FULL^VALM1 S:$G(PSOFROM)'="NEW" PSOFROM="REFILL" S PSOREF("DFLG")=0,PSOREF("IRXN")=$P(PSOLST(ORN),"^",2) - ...I PSOREF("DFLG") D EOJ S VALMBCK="R" Q - ...D ^PSOREF0 D ULK - F RX=1:1:PSOCNT I $P(PSOLST(RX),"^",2)=$P(X,"-",2) D Q - .I $D(PSOBBC(RX)) Q - .S LST=$G(LST)_RX_",",PSOBBC(RX)=1 - G ASK -BCREFX K BCREF,ASK,LST,SPEED,RX,PSOBBC,DIR,DIRUT,PSORXED,PSOREF,PSOFDR,PSOOELSE S PSORXED=1 D ^PSOBUILD,BLD^PSOORUT1 - S VALMBCK="R" Q -REFILL(PLACER) ;passes flag to CPRS for front door refill request - ;PLACER=PHARMACY NUMBER - N PSORFRM,PSOLC,PSODRG,PSODRUG0,RXN,ST,PSODEA - I $G(PLACER)["S"!('$G(PLACER)) Q "-1^Not a Valid Outpatient Medication Order." - S RXN=PLACER I '$D(^PSRX(RXN,0)) Q "-1^Not a Valid Outpatient Medication Order." - S RX0=^PSRX(RXN,0),PSODRG=$P(^PSRX(RXN,0),"^",6),ST=+^("STA"),PSODRUG0=^PSDRUG(PSODRG,0),PSODEA=$P($G(^(0)),"^",3),DIV=$P(^PSRX(RXN,2),"^",9),PSORFRM=$P(RX0,"^",9) - I PSODEA["2" Q "0^Schedule 2 Drug. Order cannot be refilled." - I '$P($G(^PSRX(RXN,"OR1")),"^"),'$P($G(^PSDRUG(PSODRG,2)),"^") Q "0^Cannot Refill. Drug not matched to a Pharmacy Orderable Item." - I '$P($G(^PSRX(RXN,"OR1")),"^"),$P($G(^PSDRUG(PSODRG,2)),"^") S $P(^PSRX(RXN,"OR1"),"^")=$P(^PSDRUG(PSODRG,2),"^") - S CLOZPAT=$S($P($G(^PSDRUG(PSODRG,"CLOZ1")),"^")="PSOCLO1":1,1:0) - I 'CLOZPAT I PSODEA["A"&(PSODEA'["B")!(PSODEA["F")!(PSODEA[1)!(PSODEA[2) Q "0^"_$S(PSODEA["A":"Narcotic Drug. ",1:"")_"Order Non-Refillable." - K CLOZPAT I DT>$P($G(^PSRX(RXN,2)),"^",6) Q "0^Non-Refillable. Prescription has Expired." - I $P(^PSRX(RXN,3),"^",2)>$P(^PSRX(RXN,2),"^",6) Q "0^Next Refill Date Past Expiration Date. New Order Required." - I '$P($G(^PS(59,DIV,1)),"^",11),$G(^PSDRUG(PSODRG,"I"))]"",DT>$G(^("I")) Q "0^Inactive Drug, Non Refillable." - I ST Q "0^Prescription is in a Non-Refillable Status." - I $P($G(^PSDRUG(PSODRG,2)),"^",3)'["O" Q "0^Cannot Refill. Drug No Longer Used by Outpatient Pharmacy." - S PSORFRM=$P(RX0,"^",9) F PSOJ=0:0 S PSOJ=$O(^PSRX(RXN,1,PSOJ)) Q:'PSOJ S PSORFRM=PSORFRM-1 - I PSORFRM<1 Q "0^No Refills remaining. New Med order required." - I $P(^PSRX(RXN,3),"^"),DT=$P(^PSRX(RXN,3),"^") Q "0^Can't Refill, Fill Date already exists for "_$E($P(^PSRX(RXN,3),"^"),4,5)_"/"_$E($P(^PSRX(RXN,3),"^"),6,7)_"/"_$E($P(^PSRX(RXN,3),"^"),2,3)_"." - I $P(^PSRX(RXN,3),"^"),DT<$P(^PSRX(RXN,3),"^") Q "0^Can't Refill, later Refill Date already exists for "_$E($P(^PSRX(RXN,3),"^"),4,5)_"/"_$E($P(^PSRX(RXN,3),"^"),6,7)_"/"_$E($P(^PSRX(RXN,3),"^"),2,3)_"." - I $O(^PS(52.41,"ARF",RXN,0)) Q "0^Pending Refill Request already exists." - Q 1 - ; -ULK D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) - Q +PSOREF ;BIR/SAB-refill data entry ;1/27/07 13:31 + ;;7.0;OUTPATIENT PHARMACY;**1,23,27,36,46,78,130,131,148,208**;DEC 1997;Build 39 + ; 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. + ; + ;External reference to ^PSDRUG supported by DBIA 221 + ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789 + ; +EOJ ; + K PSOMSG,PSOREF,PSORX("BAR CODE"),PSOLIST,LFD,MAX,MIN,NODE,PS,PSOERR,REF,RF,RXO,RXN,RXP,RXS,SD,VAERR,PSORX("FILL DATE") + D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) + Q +OERR ;single refil + ; + S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" ;vfah + D ^DIC K DIC ;vfah + S PSOZAF=+Y ;vfah + I $P($G(^PSRX(RXN,"OR1")),"^",5)=$G(PSOZAF) S VALMBCK="",VALMSG="Refill option is not available for Autofinshed Rxs" K PSOZAF Q ;vfah + I $$LMREJ^PSOREJU1($P(PSOLST(ORN),"^",2),,.VALMSG,.VALMBCK) Q + I $D(RXRP($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Reprint Label has been requested!" Q + I $D(RXPR($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Partial has already been requested!" Q + I $D(RXRS($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="Rx is being pulled from suspense!" Q + I $D(RXFL($P(PSOLST(ORN),"^",2))) S PTRX=$P(PSOLST(ORN),"^",2) D ^PSOCMOPT I '$G(PSOXFLAG) K PSOXFLAG S VALMBCK="",VALMSG="Fill already requested for CMOP!" Q + K PSOXFLAG + D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG Q + N RXN K PSORX("FILL DATE") D FULL^VALM1 S:$G(PSOFROM)'="NEW" PSOFROM="REFILL" S PSOREF("DFLG")=0,PSOREF("IRXN")=$P(PSOLST(ORN),"^",2),PSOREF("QFLG")=0 + K PSOID D ^PSOREF1 I PSOREF("DFLG") D EOJ S VALMBCK="R" Q + D ^PSOREF0 + W ! K DIR,DIRUT,DTOUT,DUOUT S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR,DIRUT,DTOUT,DUOUT S PSORXED=1 D ^PSOBUILD,ACT^PSOORNE2 K PSORXED S VALMBCK="Q" D EOJ + Q +SPEED ;speed refill + K LST,PSORX("FILL DATE") N VALMCNT I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!" S VALMBCK="" Q + K DIR,DIRUT S DIR(0)="Y",DIR("B")="NO",DIR("A")="Barcode Refill",DIR("?")="If you want to use a barcode reader to process refills enter 'Y'." + D ^DIR K DIR,DUOUT,DTOUT I $D(DIRUT) S VALMBCK="" Q + G BCREF:Y + K PSOREF,PSOFDR,DIR,DUOUT,DIRUT S DIR("A")="Select Orders by number",DIR(0)="LO^1:"_PSOCNT D ^DIR I $D(DTOUT)!($D(DUOUT)) K DIR,DIRUT,DTOUT,DUOUT S VALMBCK="" Q + K DIR,DIRUT,DTOUT,PSOOELSE,DTOUT I +Y S (ASK,SPEED,PSOOELSE)=1 D FULL^VALM1 S LST=Y D G:$G(PSOREF("DFLG"))!($G(PSOREF("QFLG"))) SPEEDX + .F ORD=1:1:$L(LST,",") Q:$P(LST,",",ORD)']""!($G(PSOREF("QFLG"))) S ORN=$P(LST,",",ORD) D:+PSOLST(ORN)=52 + ..S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" ;vfah + ..D ^DIC K DIC ;vfah + ..S PSOZAF=+Y ;vfah + ..I $P($G(^PSRX($P(PSOLST(ORN),"^",2),"OR1")),"^",5)=$G(PSOZAF) W $C(7),!!,"Rx "_$$GET1^DIQ(52,$P(PSOLST(ORN),"^",2),.01)_" is an Autofinish,Rx and can not be refilled" K PSOZAF D PAUSE^VALM1 Q ;vfah + ..I $$LMREJ^PSOREJU1($P(PSOLST(ORN),"^",2)) W $C(7),!!,"Rx "_$$GET1^DIQ(52,$P(PSOLST(ORN),"^",2),.01)_" has OPEN/UNRESOLVED 3rd Party Payer Reject!" K DIR D PAUSE^VALM1 Q + ..D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) W $C(7),!!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing Rx "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^")),! D PAUSE^VALM1 K PSOMSG Q + ..K PSOMSG I $D(RXRP($P(PSOLST(ORN),"^",2))) W $C(7),!!,"A Reprint Label has been requested!" D ULK D PAUSE^VALM1 Q + ..I $D(RXPR($P(PSOLST(ORN),"^",2))) W $C(7),!!,"A Partial has already been requested!" D ULK D PAUSE^VALM1 Q + ..I $D(RXFL($P(PSOLST(ORN),"^",2))) S PTRX=$P(PSOLST(ORN),"^",2) D ^PSOCMOPT I '$G(PSOXFLAG) K PSOXFLAG W $C(7),!!,"A CMOP fill has already been requested for Rx "_$P($G(^PSRX($P(PSOLST(ORN),"^",2),0)),"^") D ULK D PAUSE^VALM1 Q + ..K PSOXFLAG I $D(RXRS($P(PSOLST(ORN),"^",2))) W $C(7),!!,"Rx is being pulled from suspense!" D ULK D PAUSE^VALM1 Q + ..I $P($G(^PSRX($P(PSOLST(ORN),"^",2),"STA")),"^")=11 D D ULK Q + ...W $C(7),!!?5,"RX "_$P($G(^PSRX($P(PSOLST(ORN),"^",2),0)),"^")_" is in an EXPIRED status." W ! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR + ..S PSOREF("IRXN")=$P(PSOLST(ORN),"^",2) I ASK D ^PSOREF1 S ASK=0 D:$G(PSOREF("QFLG")) ULK Q:$G(PSOREF("QFLG")) + ..N RXN D FULL^VALM1 S:$G(PSOFROM)'="NEW" PSOFROM="REFILL" S PSOREF("DFLG")=0,PSOREF("IRXN")=$P(PSOLST(ORN),"^",2) + ..I PSOREF("DFLG") D EOJ S VALMBCK="R" Q + ..D ^PSOREF0 D ULK + S:'$G(PSOOELSE) VALMBCK="" + S PSORXED=1 D ^PSOBUILD,BLD^PSOORUT1 +SPEEDX K PSOREF,PSORX("BAR CODE"),PSOLIST,LFD,MAX,MIN,NODE,PS,PSOERR,REF,RF,RXO,RXN,RXP,RXS,SD,VAERR,PSORX("FILL DATE") + K LST,SPEED,PSORXED,PSOREF,PSOFDR,PSOOELSE,ASK S:'$D(VALMBCK) VALMBCK="R" + K PSORX("FILL DATE"),PSORX("MAIL/WINDOW"),PSORX("METHOD OF PICK-UP") + Q +BCREF ;barcode refills + K LST,DIR,DIRUT,DUOUT,DTOUT D FULL^VALM1 +ASK S DIR(0)="FO^5:245^K:X'?3N1""-""1.N X",DIR("A")="WAND BARCODE" + S DIR("?",1)="Wand the barcoded number of the prescription to be processed." + S DIR("?",2)="The number should be of the form NNN-NNNNNN",DIR("?",3)="where the number before the dash is your station number." + S DIR("?")="Enter ""^"", or a RETURN to quit." + D ^DIR I $D(DUOUT)!($D(DTOUT)) S VALMBCK="" G BCREFX + I $G(X)']"",'$G(LST) S VALMBCK="" G BCREFX + I $D(DIRUT),+$G(LST) D S VALMBCK="R" G BCREFX + .K DIR,DIRUT,DTOUT,PSOOELSE,DTOUT + .S (BCREF,ASK,SPEED,PSOOELSE)=1 D FULL^VALM1 D + ..F ORD=1:1:$L(LST,",") Q:$P(LST,",",ORD)']""!($G(PSOREF("QFLG"))) S ORN=$P(LST,",",ORD) D:+PSOLST(ORN)=52 + ...I $$LMREJ^PSOREJU1($P(PSOLST(ORN),"^",2)) W $C(7),!!,"Rx "_$$GET1^DIQ(52,$P(PSOLST(ORN),"^",2),.01)_" has OPEN/UNRESOLVED 3rd Party Payer Reject!" K DIR D PAUSE^VALM1 Q + ...D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) W $C(7),!!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing Rx "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^")),! D PAUSE^VALM1 K PSOMSG Q + ...K PSOMSG I $D(RXRP($P(PSOLST(ORN),"^",2))) W $C(7),!!,"A Reprint Label has been requested for Rx "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^"),! D ULK D PAUSE^VALM1 Q + ...I $D(RXPR($P(PSOLST(ORN),"^",2))) W $C(7),!!,"A Partial has already been requested for Rx "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^"),! D ULK D PAUSE^VALM1 Q + ...I $D(RXFL($P(PSOLST(ORN),"^",2))) S PTRX=$P(PSOLST(ORN),"^",2) D ^PSOCMOPT I '$G(PSOXFLAG) K PSOXFLAG W $C(7),!!,"A CMOP fill has already been requested for Rx "_$P($G(^PSRX($P(PSOLST(ORN),"^",2),0)),"^") D ULK D PAUSE^VALM1 Q + ...K PSOXFLAG I $D(RXRS($P(PSOLST(ORN),"^",2))) W $C(7),!!,"Rx "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^")_" is being pulled from suspense!" D ULK D PAUSE^VALM1 Q + ...S PSOREF("IRXN")=$P(PSOLST(ORN),"^",2) I ASK D ^PSOREF1 S ASK=0 D:$G(PSOREF("DFLG")) ULK Q:$G(PSOREF("DFLG")) + ...N RXN D FULL^VALM1 S:$G(PSOFROM)'="NEW" PSOFROM="REFILL" S PSOREF("DFLG")=0,PSOREF("IRXN")=$P(PSOLST(ORN),"^",2) + ...I PSOREF("DFLG") D EOJ S VALMBCK="R" Q + ...D ^PSOREF0 D ULK + F RX=1:1:PSOCNT I $P(PSOLST(RX),"^",2)=$P(X,"-",2) D Q + .I $D(PSOBBC(RX)) Q + .S LST=$G(LST)_RX_",",PSOBBC(RX)=1 + G ASK +BCREFX K BCREF,ASK,LST,SPEED,RX,PSOBBC,DIR,DIRUT,PSORXED,PSOREF,PSOFDR,PSOOELSE S PSORXED=1 D ^PSOBUILD,BLD^PSOORUT1 + S VALMBCK="R" Q +REFILL(PLACER) ;passes flag to CPRS for front door refill request + ;PLACER=PHARMACY NUMBER + N PSORFRM,PSOLC,PSODRG,PSODRUG0,RXN,ST,PSODEA + I $G(PLACER)["S"!('$G(PLACER)) Q "-1^Not a Valid Outpatient Medication Order." + S RXN=PLACER I '$D(^PSRX(RXN,0)) Q "-1^Not a Valid Outpatient Medication Order." + S RX0=^PSRX(RXN,0),PSODRG=$P(^PSRX(RXN,0),"^",6),ST=+^("STA"),PSODRUG0=^PSDRUG(PSODRG,0),PSODEA=$P($G(^(0)),"^",3),DIV=$P(^PSRX(RXN,2),"^",9),PSORFRM=$P(RX0,"^",9) + I PSODEA["2" Q "0^Schedule 2 Drug. Order cannot be refilled." + I '$P($G(^PSRX(RXN,"OR1")),"^"),'$P($G(^PSDRUG(PSODRG,2)),"^") Q "0^Cannot Refill. Drug not matched to a Pharmacy Orderable Item." + I '$P($G(^PSRX(RXN,"OR1")),"^"),$P($G(^PSDRUG(PSODRG,2)),"^") S $P(^PSRX(RXN,"OR1"),"^")=$P(^PSDRUG(PSODRG,2),"^") + S CLOZPAT=$S($P($G(^PSDRUG(PSODRG,"CLOZ1")),"^")="PSOCLO1":1,1:0) + I 'CLOZPAT I PSODEA["A"&(PSODEA'["B")!(PSODEA["F") Q "0^"_$S(PSODEA["F":"",1:"Narcotic Drug. ")_"Order Non-Refillable." + K CLOZPAT I DT>$P($G(^PSRX(RXN,2)),"^",6) Q "0^Non-Refillable. Prescription has Expired." + I $P(^PSRX(RXN,3),"^",2)>$P(^PSRX(RXN,2),"^",6) Q "0^Next Refill Date Past Expiration Date. New Order Required." + I '$P($G(^PS(59,DIV,1)),"^",11),$G(^PSDRUG(PSODRG,"I"))]"",DT>$G(^("I")) Q "0^Inactive Drug, Non Refillable." + I ST Q "0^Prescription is in a Non-Refillable Status." + I $P($G(^PSDRUG(PSODRG,2)),"^",3)'["O" Q "0^Cannot Refill. Drug No Longer Used by Outpatient Pharmacy." + S PSORFRM=$P(RX0,"^",9) F PSOJ=0:0 S PSOJ=$O(^PSRX(RXN,1,PSOJ)) Q:'PSOJ S PSORFRM=PSORFRM-1 + I PSORFRM<1 Q "0^No Refills remaining. New Med order required." + I $P(^PSRX(RXN,3),"^"),DT=$P(^PSRX(RXN,3),"^") Q "0^Can't Refill, Fill Date already exists for "_$E($P(^PSRX(RXN,3),"^"),4,5)_"/"_$E($P(^PSRX(RXN,3),"^"),6,7)_"/"_$E($P(^PSRX(RXN,3),"^"),2,3)_"." + I $P(^PSRX(RXN,3),"^"),DT<$P(^PSRX(RXN,3),"^") Q "0^Can't Refill, later Refill Date already exists for "_$E($P(^PSRX(RXN,3),"^"),4,5)_"/"_$E($P(^PSRX(RXN,3),"^"),6,7)_"/"_$E($P(^PSRX(RXN,3),"^"),2,3)_"." + I $O(^PS(52.41,"ARF",RXN,0)) Q "0^Pending Refill Request already exists." + Q 1 + ; +ULK D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOREJP1.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOREJP1.m index 429c2c82..32b2b194 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOREJP1.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOREJP1.m @@ -1,274 +1,271 @@ -PSOREJP1 ;BIRM/MFR - Third Party Reject Display Screen ;04/29/05 - ;;7.0;OUTPATIENT PHARMACY;**148,247,260,281**;DEC 1997;Build 41 - ;Reference to File 9002313.93 - BPS NCPDP REJECT CODES supported by IA 4720 - ;Reference to ^PS(59.7 supported by IA 694 - ;Reference to ^PSDRUG("AQ" supported by IA 3165 - ; -EN(RX,REJ,CHANGE) ; Entry point - ; - ; - DO NOT change the IF logic below as both of them might get executed (intentional) - N FILL,LASTLN - S FILL=+$$GET1^DIQ(52.25,REJ_","_RX,5) - I $$CLOSED(RX,REJ) D EN^VALM("PSO REJECT DISPLAY - RESOLVED") - I '$$CLOSED(RX,REJ) D EN^VALM("PSO REJECT DISPLAY") - D FULL^VALM1 - Q - ; -HDR ; - Builds the Header section - N LINE1,LINE2,X - S VALMHDR(1)=$$DVINFO^PSOREJU2(RX,FILL,1),VALMHDR(2)=$$PTINFO^PSOREJU2(RX,1) - S VALMHDR(3)=$$RXINFO(RX,FILL,1),VALMHDR(4)=$$RXINFO(RX,FILL,2) - Q - ; -INIT ; Builds the Body section - N DATA,LINE - F I=1:1:$G(LASTLN) D RESTORE^VALM10(I) - K ^TMP("PSOREJP1",$J) S VALMCNT=0,LINE=0 - D GET^PSOREJU2(RX,FILL,.DATA,REJ,1) - D REJ ; Display REJECT Info - D OTH ; Display Other Rejects Info - D COM^PSOREJP3 ; Display Comment - D INS ; Display Insurance Info - D CLS ; Display Resolution Info - S VALMCNT=LINE - Q - ; -REJ ; - DUR Information - N TYPE,PFLDT - D SETLN("REJECT Information",1,1) - S TYPE=$S($G(DATA(REJ,"CODE"))=79:"79 - REFILL TOO SOON",1:"88 - DUR REJECT") - D SETLN("Reject Type : "_TYPE_" received on "_$$FMTE^XLFDT($G(DATA(REJ,"DATE/TIME"))),,,18) - D SETLN("Reject Status : "_$G(DATA(REJ,"STATUS")),,,18) - D SET("PAYER MESSAGE",63) - D SET("REASON",63) - S PFLDT=$$FMTE^XLFDT($G(DATA(REJ,"PLAN PREVIOUS FILL DATE"))) - D SET("DUR TEXT",63,$S(PFLDT="":1,1:0)) - I PFLDT'="" D SETLN("Last Fill Date : "_PFLDT_" (from payer)",,1,18) - Q - ; -OTH ; - Other Rejects Information - N LST,I,RJC,J,LAST - S LST=$G(DATA(REJ,"OTHER REJECTS")) I LST="" Q - D SETLN() - D SETLN("OTHER REJECTS",1,1) - F I=1:1:$L(LST,",") S RJC=$P(LST,",",I) D - . S LAST=1 F J=(I+1):1:$L(LST,",") I $P(LST,",",J)'="" S LAST=0 Q - . I RJC'="" D SETLN(RJC_" - "_$$EXP(RJC),,$S(LAST:1,1:0),6) - Q - ; -INS ; - Insurance Information - D SETLN() - D SETLN("INSURANCE Information",1,1) - D SETLN("Insurance : "_$G(DATA(REJ,"INSURANCE NAME")),,,18) - D SETLN("Contact : "_$G(DATA(REJ,"PLAN CONTACT")),,,18) - D SETLN("Group Name : "_$G(DATA(REJ,"GROUP NAME")),,,18) - D SETLN("Group Number : "_$G(DATA(REJ,"GROUP NUMBER")),,,18) - D SETLN("Cardholder ID : "_$G(DATA(REJ,"CARDHOLDER ID")),,1,18) - Q - ; -CLS ; - Resolution Information - N X - I '$$CLOSED(RX,REJ) Q - D SETLN() - D SETLN("RESOLUTION Information",1,1) - D SETLN("Resolved By : "_$G(DATA(REJ,"CLOSED BY")),,,18) - D SETLN("Date/Time : "_$G(DATA(REJ,"CLOSED DATE/TIME")),,,18) - I $G(DATA(REJ,"CLOSE COMMENTS"))'="" D SET("CLOSE COMMENTS",63) - I $G(DATA(REJ,"COD1"))'="" D SETLN("Reason for Svc : "_$$OVRX^PSOREJU1(1,$G(DATA(REJ,"COD1"))),,,18) - I $G(DATA(REJ,"COD2"))'="" D SETLN("Profes. Svc : "_$$OVRX^PSOREJU1(2,$G(DATA(REJ,"COD2"))),,,18) - I $G(DATA(REJ,"COD3"))'="" D SETLN("Result of Svc : "_$$OVRX^PSOREJU1(3,$G(DATA(REJ,"COD3"))),,,18) - I $G(DATA(REJ,"CLA CODE"))'="" D - . S X=$$GET1^DIQ(52.25,REJ_","_RX,24,"I")_" - "_(DATA(REJ,"CLA CODE")) - . D SETLN("Clarific. Code : "_X,,,18) - I $G(DATA(REJ,"PRIOR AUTH TYPE"))'="" D - . S X=$$GET1^DIQ(52.25,REJ_","_RX,25,"I")_" - "_(DATA(REJ,"PRIOR AUTH TYPE")) - . D SETLN("Prior Auth.Type: "_X,,,18),SETLN("Prior Auth. # : "_DATA(REJ,"PRIOR AUTH NUMBER"),,,18) - D SETLN("Reason : "_$G(DATA(REJ,"CLOSE REASON")),,1,18) - Q - ; - ; -SET(FIELD,L,UND) ; Sets the lines for fields that require text wrapping - N TXT,T - S TXT=DATA(REJ,FIELD) I $L(TXT)'>L D SETLN($$LABEL(FIELD)_TXT,,$S($G(UND):1,1:0),80-L) Q - F I=1:1 Q:TXT="" D - . I I=1 D SETLN($$LABEL(FIELD)_$E(TXT,1,L),,,80-L) S TXT=$E(TXT,L+1,999) Q - . S T="",$E(T,81-L)=$E(TXT,1,L) D SETLN(T,,$S($E(TXT,L+1,999)=""&$G(UND):1,1:0),80-L) S TXT=$E(TXT,L+1,999) - Q - ; -LABEL(FIELD) ; Sets the label for the field - I FIELD="REASON" Q "Reason : " - I FIELD="PAYER MESSAGE" Q "Payer Message : " - I FIELD="DUR TEXT" Q "DUR Text : " - I FIELD="CLOSE COMMENTS" Q "Comments : " - Q "" - ; -VIEW ; - Rx View hidden action - N VALMCNT,TITLE - I $G(PSOBACK) D Q - . S VALMSG="Not available through Backdoor!",VALMBCK="R" - S TITLE=VALM("TITLE") - ; - ; - DO structure used to avoid losing variables RX,FILL,REJ,LINE,TITLE - DO - . N PSOVDA,DA,PS - . S (PSOVDA,DA)=RX,PS="REJECT" - . N RX,REJ,FILL,LINE,TITLE D DP^PSORXVW - ; - S VALMBCK="R",VALM("TITLE")=TITLE - Q - ; -EDT ; - Rx Edit hidden action - N VALMCNT,TITLE - I $G(PSOBACK) D Q - . S VALMSG="Not available through Backdoor!",VALMBCK="R" - S TITLE=VALM("TITLE") - ; - ; - DO structure used to avoid losing variables RX,FILL,REJ,LINE,TITLE - DO - . N PSOSITE,ORN,PSOPAR,PSOLIST - . S PSOSITE=$$RXSITE^PSOBPSUT(RX,FILL),ORN=RX - . S PSOPAR=$G(^PS(59,PSOSITE,1)),PSOLIST(1)=ORN_"," - . N RX,REJ,FILL,LINE,TITLE D EPH^PSORXEDT - ; - K VALMBCK I $$CLOSED(RX,REJ),$D(PSOSTFLT),PSOSTFLT="U" S CHANGE=1 Q - S VALMBCK="R",VALM("TITLE")=TITLE - Q - ; -OVR ; - Override a REJECT action - I $$CLOSED(RX,REJ,1) Q - N COD1,COD2,COD3 - D FULL^VALM1 W ! - S COD1=$$OVRCOD^PSOREJU1(1,$$GET1^DIQ(52.25,REJ_","_RX,14)) I COD1="^" S VALMBCK="R" Q - S COD2=$$OVRCOD^PSOREJU1(2) I COD2="^" S VALMBCK="R" Q - S COD3=$$OVRCOD^PSOREJU1(3) I COD3="^" S VALMBCK="R" Q - D OVRDSP^PSOREJU1(COD1_"^"_COD2_"^"_COD3) - D SEND(COD1,COD2,COD3) - Q - ; -RES ; - Re-submit a claim action - I $$CLOSED(RX,REJ,1) Q - D FULL^VALM1 W ! - D SEND() - Q - ; -CLA ; - Submit Clarification Code - N CLA - I $$CLOSED(RX,REJ,1) Q - D FULL^VALM1 W ! - S CLA=$$CLA^PSOREJU1() I CLA="^" S VALMBCK="R" Q - W ! D SEND(,,,CLA) - Q - ; -PA ; - Submit Prior Authorization - N PA - I $$CLOSED(RX,REJ,1) Q - D FULL^VALM1 W ! - S PA=$$PA^PSOREJU2() I PA="^" S VALMBCK="R" Q - W ! D SEND(,,,,PA) - Q - ; -SEND(COD1,COD2,COD3,CLA,PA) ; - Sends Claim to ECME and closes Reject - N DIR,OVRC,RESP,ALTXT,COM - S DIR(0)="Y",DIR("A")=" Confirm",DIR("B")="YES" - S DIR("A",1)=" When you confirm, a new claim will be submitted for" - S DIR("A",2)=" the prescription and this REJECT will be marked" - S DIR("A",3)=" resolved." - S DIR("A",4)=" " - W ! D ^DIR I $G(Y)=0!$D(DIRUT) S VALMBCK="R" Q - I $G(COD1)'="" S OVRC=$G(COD2)_"^"_$G(COD1)_"^"_$G(COD3) - S ALTXT="REJECT WORKLIST" - S:$G(OVRC)'="" ALTXT=ALTXT_"-DUR OVERRIDE CODES("_$G(COD1)_"/"_$G(COD2)_"/"_$G(COD3)_")" - S:$G(CLA) ALTXT=ALTXT_"(CLARIF. CODE="_CLA_")" - S:$G(PA) ALTXT=ALTXT_"(PRIOR AUTH.="_$TR(PA,"^","/")_")" - D ECMESND^PSOBPSU1(RX,FILL,,"ED",$$GETNDC^PSONDCUT(RX,FILL),,,$G(OVRC),,.RESP,,ALTXT,$G(CLA),$G(PA)) - I $G(RESP) D Q - . W !!?10,"Claim could not be submitted. Please try again later!" - . W !,?10,"Reason: ",$S($P(RESP,"^",2)="":"UNKNOWN",1:$P(RESP,"^",2)),$C(7) H 2 - ; - I $$PTLBL^PSOREJP2(RX,FILL) D PRINT(RX,FILL) - ; - I $D(PSOSTFLT),PSOSTFLT'="B" S CHANGE=1 - Q - ; -MP ; - Patient Medication Profile - I $G(PSOBACK) D Q - . S VALMSG="Not available through Backdoor!",VALMBCK="R" - N SITE,PATIENT - D FULL^VALM1 W ! - S SITE=+$$RXSITE^PSOBPSUT(RX,FILL) S:$G(PSOSITE) SITE=PSOSITE - S PATIENT=+$$GET1^DIQ(52,RX,2,"I") - D LST^PSOPMP0(SITE,PATIENT) S VALMBCK="R" - Q - ; -EXIT ; - K ^TMP("PSOREJP1",$J) - Q - ; -SETLN(TEXT,REV,UND,HIG) ; Sets a line to be displayed in the Body section - N X - S:$G(TEXT)="" $E(TEXT,80)="" - S:$L(TEXT)>80 TEXT=$E(TEXT,1,80) - S LINE=LINE+1,^TMP("PSOREJP1",$J,LINE,0)=$G(TEXT) - ; - I LINE>$G(LASTLN) D SAVE^VALM10(LINE) S LASTLN=LINE - ; - I $G(REV) D Q - . D CNTRL^VALM10(LINE,1,$L(TEXT),IORVON,IOINORM) - . I $G(UND) D CNTRL^VALM10(LINE,$L(TEXT)+1,80,IOUON,IOINORM) - I $G(UND) D CNTRL^VALM10(LINE,1,80,IOUON,IOINORM) - I $G(HIG) D - . D CNTRL^VALM10(LINE,HIG,80,IOINHI_$S($G(UND):IOUON,1:""),IOINORM) - Q -HELP ; - Q - ; -RXINFO(RX,FILL,LINE) ; Returns header displayable Rx Information - N TXT,RXINFO,LBL,CMOP,DRG - I LINE=1 D - . S RXINFO="Rx# : "_$$GET1^DIQ(52,RX,.01)_"/"_FILL - . S $E(RXINFO,30)="ECME#: "_$E(10000000+RX,2,8) - . S $E(RXINFO,55)="Fill Date: "_$$FMTE^XLFDT($$RXFLDT^PSOBPSUT(RX,FILL)) - I LINE=2 D - . S DRG=$$GET1^DIQ(52,RX,6,"I"),CMOP=$S($D(^PSDRUG("AQ",DRG)):1,1:0) - . S RXINFO=$S(CMOP:"CMOP ",1:"")_"Drug",$E(RXINFO,10)=": "_$E($$GET1^DIQ(52,RX,6),1,43) - . S $E(RXINFO,56)="NDC Code: "_$$GETNDC^PSONDCUT(RX,FILL) - Q $G(RXINFO) - ; -CLOSED(RX,REJ,MSG) ; Returns whether the REJECT is RESOLVED or NOT - I $$GET1^DIQ(52.25,REJ_","_RX,10,"I") D:$G(MSG) Q 1 - . S VALMSG="This Reject is marked resolved!",VALMBCK="R" W $C(7) - Q 0 - ; -REOPN(RX,REJ) ; Returns whether the REJECT was RE-OPENED or NOT - Q $S($$GET1^DIQ(52.25,REJ_","_RX,23)="":0,1:1) - ; -EXP(CODE) ; - Returns the explanation field (.02) for a reject code - ; Input: (r) CODE - .01 field (Code) value from file 9002313.93 - ; Output: .02 field (Explanation) value from file 9002313.93 - N DIC,X,Y - S DIC=9002313.93,DIC(0)="Z",X=CODE D ^DIC - Q $P($G(Y(0)),"^",2) - ; -OUT(RX) ; - Supported call by outside PROTOCOLs to act on specific REJECTs - N I,RFL,DATA,REJ,PSOBACK,VALMCNT,RXN - I '$D(^XUSEC("PSORPH",DUZ)) S VALMSG="PSORPH key required to use the REJ action.",VALMBCK="R" Q - I $G(PS)="REJECT" D Q - . S VALMSG="REJ action is not available at this point.",VALMBCK="R" - S PSOBACK=1 - S (RFL,I)=0 F I=1:1 Q:'$D(^PSRX(RX,1,I)) S RFL=I - S X=$$FIND^PSOREJUT(RX,RFL,.DATA) S REJ=$O(DATA("")) - I '$G(REJ) S VALMSG="Invalid selection!",VALMBCK="R" Q - D EN(RX,REJ) S VALMBCK="R" - Q - ; -PRINT(RX,RFL) ; Print Label for specific Rx/Fill - N PPL,PSOSITE,PSOPAR,PSOSYS,PSOLAP,PSOBARS,PSOBAR0,PSOBAR1,PSOIOS,PSOBFLAG - N POP,DFN,PDUZ,RXFL - ; - S PSOSITE=$$RXSITE^PSOBPSUT(RX,RFL),PSOPAR=^PS(59,PSOSITE,1) - S DFN=$$GET1^DIQ(52,RX,2,"I"),PDUZ=DUZ,PSOSYS=$G(^PS(59.7,1,40.1)) - S PPL=RX I RFL S RXFL(RX)=RFL - W ! S PSOBFLAG=1 D LBL^PSOLSET I $G(PSOQUIT) Q - ; - S IOP=PSOLAP D ^%ZIS,DQ^PSOLBL,^%ZISC - Q +PSOREJP1 ;BIRM/MFR - Third Party Reject Display Screen ;04/29/05 + ;;7.0;OUTPATIENT PHARMACY;**148,247,260**;DEC 1997;Build 84 + ;Reference to File 9002313.93 - BPS NCPDP REJECT CODES supported by IA 4720 + ;Reference to ^PS(59.7 supported by IA 694 + ;Reference to ^PSDRUG("AQ" supported by IA 3165 + ; +EN(RX,REJ,CHANGE) ; Entry point + ; + ; - DO NOT change the IF logic below as both of them might get executed (intentional) + N FILL,LASTLN + S FILL=+$$GET1^DIQ(52.25,REJ_","_RX,5) + I $$CLOSED(RX,REJ) D EN^VALM("PSO REJECT DISPLAY - RESOLVED") + I '$$CLOSED(RX,REJ) D EN^VALM("PSO REJECT DISPLAY") + D FULL^VALM1 + Q + ; +HDR ; - Builds the Header section + N LINE1,LINE2,X + S VALMHDR(1)=$$DVINFO^PSOREJU2(RX,FILL,1),VALMHDR(2)=$$PTINFO^PSOREJU2(RX,1) + S VALMHDR(3)=$$RXINFO(RX,FILL,1),VALMHDR(4)=$$RXINFO(RX,FILL,2) + Q + ; +INIT ; Builds the Body section + N DATA,LINE + F I=1:1:$G(LASTLN) D RESTORE^VALM10(I) + K ^TMP("PSOREJP1",$J) S VALMCNT=0,LINE=0 + D GET^PSOREJU2(RX,FILL,.DATA,REJ,1) + D REJ ; Display the REJECT Information + D OTH ; Display the Other Rejects Information + D COM^PSOREJP3 ; Display the Comment + D INS ; Display the Insurance Information + D CLS ; Display the Resolution Information + S VALMCNT=LINE + Q + ; +REJ ; - DUR Information + N TYPE,PFLDT + D SETLN("REJECT Information",1,1) + S TYPE=$S($G(DATA(REJ,"CODE"))=79:"79 - REFILL TOO SOON",1:"88 - DUR REJECT") + D SETLN("Reject Type : "_TYPE_" received on "_$$FMTE^XLFDT($G(DATA(REJ,"DATE/TIME"))),,,18) + D SETLN("Reject Status : "_$G(DATA(REJ,"STATUS")),,,18) + D SET("PAYER MESSAGE",63) + D SET("REASON",63) + S PFLDT=$$FMTE^XLFDT($G(DATA(REJ,"PLAN PREVIOUS FILL DATE"))) + D SET("DUR TEXT",63,$S(PFLDT="":1,1:0)) + I PFLDT'="" D SETLN("Last Fill Date : "_PFLDT_" (from payer)",,1,18) + Q + ; +OTH ; - Other Rejects Information + N LST,I,RJC,J,LAST + S LST=$G(DATA(REJ,"OTHER REJECTS")) I LST="" Q + D SETLN() + D SETLN("OTHER REJECTS",1,1) + F I=1:1:$L(LST,",") S RJC=$P(LST,",",I) D + . S LAST=1 F J=(I+1):1:$L(LST,",") I $P(LST,",",J)'="" S LAST=0 Q + . I RJC'="" D SETLN(RJC_" - "_$$EXP(RJC),,$S(LAST:1,1:0),6) + Q + ; +INS ; - Insurance Information + D SETLN() + D SETLN("INSURANCE Information",1,1) + D SETLN("Insurance : "_$G(DATA(REJ,"INSURANCE NAME")),,,18) + D SETLN("Contact : "_$G(DATA(REJ,"PLAN CONTACT")),,,18) + D SETLN("Group Name : "_$G(DATA(REJ,"GROUP NAME")),,,18) + D SETLN("Group Number : "_$G(DATA(REJ,"GROUP NUMBER")),,,18) + D SETLN("Cardholder ID : "_$G(DATA(REJ,"CARDHOLDER ID")),,1,18) + Q + ; +CLS ; - Resolution Information + N X + I '$$CLOSED(RX,REJ) Q + D SETLN() + D SETLN("RESOLUTION Information",1,1) + D SETLN("Resolved By : "_$G(DATA(REJ,"CLOSED BY")),,,18) + D SETLN("Date/Time : "_$G(DATA(REJ,"CLOSED DATE/TIME")),,,18) + I $G(DATA(REJ,"CLOSE COMMENTS"))'="" D SET("CLOSE COMMENTS",63) + I $G(DATA(REJ,"COD1"))'="" D SETLN("Reason for Svc : "_$$OVRX^PSOREJU1(1,$G(DATA(REJ,"COD1"))),,,18) + I $G(DATA(REJ,"COD2"))'="" D SETLN("Profes. Svc : "_$$OVRX^PSOREJU1(2,$G(DATA(REJ,"COD2"))),,,18) + I $G(DATA(REJ,"COD3"))'="" D SETLN("Result of Svc : "_$$OVRX^PSOREJU1(3,$G(DATA(REJ,"COD3"))),,,18) + I $G(DATA(REJ,"CLA CODE"))'="" D + . S X=$$GET1^DIQ(52.25,REJ_","_RX,24,"I")_" - "_(DATA(REJ,"CLA CODE")) + . D SETLN("Clarific. Code : "_X,,,18) + I $G(DATA(REJ,"PRIOR AUTH TYPE"))'="" D + . S X=$$GET1^DIQ(52.25,REJ_","_RX,25,"I")_" - "_(DATA(REJ,"PRIOR AUTH TYPE")) + . D SETLN("Prior Auth.Type: "_X,,,18),SETLN("Prior Auth. # : "_DATA(REJ,"PRIOR AUTH NUMBER"),,,18) + D SETLN("Reason : "_$G(DATA(REJ,"CLOSE REASON")),,1,18) + Q + ; + ; +SET(FIELD,L,UND) ; Sets the lines for fields that require text wrapping + N TXT,T + S TXT=DATA(REJ,FIELD) I $L(TXT)'>L D SETLN($$LABEL(FIELD)_TXT,,$S($G(UND):1,1:0),80-L) Q + F I=1:1 Q:TXT="" D + . I I=1 D SETLN($$LABEL(FIELD)_$E(TXT,1,L),,,80-L) S TXT=$E(TXT,L+1,999) Q + . S T="",$E(T,81-L)=$E(TXT,1,L) D SETLN(T,,$S($E(TXT,L+1,999)=""&$G(UND):1,1:0),80-L) S TXT=$E(TXT,L+1,999) + Q + ; +LABEL(FIELD) ; Sets the label for the field + I FIELD="REASON" Q "Reason : " + I FIELD="PAYER MESSAGE" Q "Payer Message : " + I FIELD="DUR TEXT" Q "DUR Text : " + I FIELD="CLOSE COMMENTS" Q "Comments : " + Q "" + ; +VIEW ; - Rx View hidden action + N VALMCNT,TITLE + I $G(PSOBACK) D Q + . S VALMSG="Not available through Backdoor!",VALMBCK="R" + S TITLE=VALM("TITLE") + ; + ; - DO structure used to avoid losing variables RX,FILL,REJ,LINE,TITLE + DO + . N PSOVDA,DA,PS + . S (PSOVDA,DA)=RX,PS="REJECT" + . N RX,REJ,FILL,LINE,TITLE D DP^PSORXVW + ; + S VALMBCK="R",VALM("TITLE")=TITLE + Q + ; +EDT ; - Rx Edit hidden action + N VALMCNT,TITLE + I $G(PSOBACK) D Q + . S VALMSG="Not available through Backdoor!",VALMBCK="R" + S TITLE=VALM("TITLE") + ; + ; - DO structure used to avoid losing variables RX,FILL,REJ,LINE,TITLE + DO + . N PSOSITE,ORN,PSOPAR,PSOLIST + . S PSOSITE=$$RXSITE^PSOBPSUT(RX,FILL),ORN=RX + . S PSOPAR=$G(^PS(59,PSOSITE,1)),PSOLIST(1)=ORN_"," + . N RX,REJ,FILL,LINE,TITLE D EPH^PSORXEDT + ; + K VALMBCK I $$CLOSED(RX,REJ),$D(PSOSTFLT),PSOSTFLT="U" S CHANGE=1 Q + S VALMBCK="R",VALM("TITLE")=TITLE + Q + ; +OVR ; - Override a REJECT action + I $$CLOSED(RX,REJ,1) Q + N COD1,COD2,COD3 + D FULL^VALM1 W ! + S COD1=$$OVRCOD^PSOREJU1(1,$$GET1^DIQ(52.25,REJ_","_RX,14)) I COD1="^" S VALMBCK="R" Q + S COD2=$$OVRCOD^PSOREJU1(2) I COD2="^" S VALMBCK="R" Q + S COD3=$$OVRCOD^PSOREJU1(3) I COD3="^" S VALMBCK="R" Q + D OVRDSP^PSOREJU1(COD1_"^"_COD2_"^"_COD3) + D SEND(COD1,COD2,COD3) + Q + ; +RES ; - Re-submit a claim action + I $$CLOSED(RX,REJ,1) Q + D FULL^VALM1 W ! + D SEND() + Q + ; +CLA ; - Submit Clarification Code + N CLA + I $$CLOSED(RX,REJ,1) Q + D FULL^VALM1 W ! + S CLA=$$CLA^PSOREJU1() I CLA="^" S VALMBCK="R" Q + W ! D SEND(,,,CLA) + Q + ; +PA ; - Submit Prior Authorization + N PA + I $$CLOSED(RX,REJ,1) Q + D FULL^VALM1 W ! + S PA=$$PA^PSOREJU2() I PA="^" S VALMBCK="R" Q + W ! D SEND(,,,,PA) + Q + ; +SEND(COD1,COD2,COD3,CLA,PA) ; - Sends Claim to ECME and closes Reject + N DIR,OVRC,RESP,ALTXT,COM + S DIR(0)="Y",DIR("A")=" Confirm",DIR("B")="YES" + S DIR("A",1)=" When you confirm, a new claim will be submitted for" + S DIR("A",2)=" the prescription and this REJECT will be marked" + S DIR("A",3)=" resolved." + S DIR("A",4)=" " + W ! D ^DIR I $G(Y)=0!$D(DIRUT) S VALMBCK="R" Q + I $G(COD1)'="" S OVRC=$G(COD2)_"^"_$G(COD1)_"^"_$G(COD3) + S ALTXT="REJECT WORKLIST" + S:$G(OVRC)'="" ALTXT=ALTXT_"-DUR OVERRIDE CODES("_$G(COD1)_"/"_$G(COD2)_"/"_$G(COD3)_")" + S:$G(CLA) ALTXT=ALTXT_"(CLARIF. CODE="_CLA_")" + S:$G(PA) ALTXT=ALTXT_"(PRIOR AUTH.="_$TR(PA,"^","/")_")" + D ECMESND^PSOBPSU1(RX,FILL,,"ED",$$GETNDC^PSONDCUT(RX,FILL),,,$G(OVRC),,.RESP,,ALTXT,$G(CLA),$G(PA)) + I $G(RESP) D Q + . W !!?10,"Claim could not be submitted. Please try again later!" + . W !,?10,"Reason: ",$S($P(RESP,"^",2)="":"UNKNOWN",1:$P(RESP,"^",2)),$C(7) H 2 + ; + I $$PTLBL^PSOREJP2(RX,FILL) D PRINT(RX,FILL) + ; + I $D(PSOSTFLT),PSOSTFLT'="B" S CHANGE=1 + Q + ; +MP ; - Patient Medication Profile + I $G(PSOBACK) D Q + . S VALMSG="Not available through Backdoor!",VALMBCK="R" + N SITE,PATIENT + D FULL^VALM1 W ! + S SITE=+$$RXSITE^PSOBPSUT(RX,FILL) S:$G(PSOSITE) SITE=PSOSITE + S PATIENT=+$$GET1^DIQ(52,RX,2,"I") + D LST^PSOPMP0(SITE,PATIENT) S VALMBCK="R" + Q + ; +EXIT ; + K ^TMP("PSOREJP1",$J) + Q + ; +SETLN(TEXT,REV,UND,HIG) ; Sets a line to be displayed in the Body section + N X + S:$G(TEXT)="" $E(TEXT,80)="" + S:$L(TEXT)>80 TEXT=$E(TEXT,1,80) + S LINE=LINE+1,^TMP("PSOREJP1",$J,LINE,0)=$G(TEXT) + ; + I LINE>$G(LASTLN) D SAVE^VALM10(LINE) S LASTLN=LINE + ; + I $G(REV) D Q + . D CNTRL^VALM10(LINE,1,$L(TEXT),IORVON,IOINORM) + . I $G(UND) D CNTRL^VALM10(LINE,$L(TEXT)+1,80,IOUON,IOINORM) + I $G(UND) D CNTRL^VALM10(LINE,1,80,IOUON,IOINORM) + I $G(HIG) D + . D CNTRL^VALM10(LINE,HIG,80,IOINHI_$S($G(UND):IOUON,1:""),IOINORM) + Q +HELP ; + Q + ; +RXINFO(RX,FILL,LINE) ; Returns header displayable Rx Information + N TXT,RXINFO,LBL,CMOP,DRG + I LINE=1 D + . S RXINFO="Rx# : "_$$GET1^DIQ(52,RX,.01)_"/"_FILL + . S $E(RXINFO,30)="ECME#: "_$E(10000000+RX,2,8) + . S $E(RXINFO,55)="Fill Date: "_$$FMTE^XLFDT($$RXFLDT^PSOBPSUT(RX,FILL)) + I LINE=2 D + . S DRG=$$GET1^DIQ(52,RX,6,"I"),CMOP=$S($D(^PSDRUG("AQ",DRG)):1,1:0) + . S RXINFO=$S(CMOP:"CMOP ",1:"")_"Drug",$E(RXINFO,10)=": "_$E($$GET1^DIQ(52,RX,6),1,43) + . S $E(RXINFO,56)="NDC Code: "_$$GETNDC^PSONDCUT(RX,FILL) + Q $G(RXINFO) + ; +CLOSED(RX,REJ,MSG) ; Returns whether the REJECT is RESOLVED or NOT + I $$GET1^DIQ(52.25,REJ_","_RX,10,"I") D:$G(MSG) Q 1 + . S VALMSG="This Reject is marked resolved!",VALMBCK="R" W $C(7) + Q 0 + ; +REOPN(RX,REJ) ; Returns whether the REJECT was RE-OPENED or NOT + Q $S($$GET1^DIQ(52.25,REJ_","_RX,23)="":0,1:1) + ; +EXP(CODE) ; - Returns the explanation field (.02) for a reject code + ; Input: (r) CODE - .01 field (Code) value from file 9002313.93 + ; Output: .02 field (Explanation) value from file 9002313.93 + N DIC,X,Y + S DIC=9002313.93,DIC(0)="Z",X=CODE D ^DIC + Q $P($G(Y(0)),"^",2) + ; +OUT(RX) ; - Supported call by outside PROTOCOLs to act on specific REJECTs + N I,RFL,DATA,REJ,PSOBACK,VALMCNT + S PSOBACK=1 + S (RFL,I)=0 F I=1:1 Q:'$D(^PSRX(RX,1,I)) S RFL=I + S X=$$FIND^PSOREJUT(RX,RFL,.DATA) S REJ=$O(DATA("")) + I '$G(REJ) S VALMSG="Invalid selection!",VALMBCK="R" Q + D EN(RX,REJ) S VALMBCK="R" + Q + ; +PRINT(RX,RFL) ; Print Label for specific Rx/Fill + N PPL,PSOSITE,PSOPAR,PSOSYS,PSOLAP,PSOBARS,PSOBAR0,PSOBAR1,PSOIOS,PSOBFLAG + N POP,DFN,PDUZ,RXFL + ; + S PSOSITE=$$RXSITE^PSOBPSUT(RX,RFL),PSOPAR=^PS(59,PSOSITE,1) + S DFN=$$GET1^DIQ(52,RX,2,"I"),PDUZ=DUZ,PSOSYS=$G(^PS(59.7,1,40.1)) + S PPL=RX I RFL S RXFL(RX)=RFL + W ! S PSOBFLAG=1 D LBL^PSOLSET I $G(PSOQUIT) Q + ; + S IOP=PSOLAP D ^%ZIS,DQ^PSOLBL,^%ZISC + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORENW.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORENW.m index 5e095530..bd1e51e0 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORENW.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORENW.m @@ -1,82 +1,83 @@ -PSORENW ;BIR/SAB-renew main driver ;4/25/07 8:42am - ;;7.0;OUTPATIENT PHARMACY;**11,27,30,46,71,96,100,130,148,206**;DEC 1997;Build 39 - ;External reference to ^PSDRUG supported by DBIA 221 - ;External references L, UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789 - ;External reference to LK^ORX2 and ULK^ORX2 supported by DBIA 867 - ;External reference to ^PS(50.7 supported by DBIA 2223 - ;External reference to MAIN^TIUEDIT supported by DBIA 2410 - ; -ASK ; - K PSORENW("FILL DATE") D FILLDT^PSODIR2(.PSORENW) S:$G(PSORENW("DFLG")) VALMSG="Renew Rx request canceled",VALMBCK="R" - I PSORENW("DFLG")!('$D(PSORENW("FILL DATE"))) S PSORENW("QFLG")=1,PSORENW("DFLG")=0 G ASKX - S PSORNW("FILL DATE")=PSORENW("FILL DATE") - D MW^PSOCMOPA(.PSORENW) - I PSORENW("DFLG") S PSORENW("QFLG")=1,PSORENW("DFLG")=0 G ASKX - S PSORNW("MAIL/WINDOW")=PSORENW("MAIL/WINDOW") S PSORX("MAIL/WINDOW")=$S(PSORENW("MAIL/WINDOW")="M":"MAIL",1:"WINDOW") - D NOORE^PSONEW(.PSORENW) S:$G(PSORENW("DFLG")) VALMSG="Renew Rx request canceled",VALMBCK="R" - I PSORENW("DFLG")!('$D(PSORENW("FILL DATE"))) S PSORENW("QFLG")=1,PSORENW("DFLG")=0 -ASKX Q - ; -EOJ ; - K VERB,RTE,DRET,PSOMSG,PSORNW,PSOLIST,PSORENW,PSORX("BAR CODE"),PSORX("FILL DATE"),PSODIR,PSOID,PSONOOR,PSOCOU,PSOCOUU,PSOID,PSOFDMX,PSODRUG,COPY,PSOBCKDR - S RXN=$O(^TMP("PSORXN",$J,0)) I RXN D - .S RXN1=^TMP("PSORXN",$J,RXN) D EN^PSOHLSN1(RXN,$P(RXN1,"^"),$P(RXN1,"^",2),"",$P(RXN1,"^",3)) - .I $P(^PSRX(RXN,"STA"),"^")=5 D EN^PSOHLSN1(RXN,"SC","ZS",$P(RXN1,"^",4)) - K RXN,RXN1,^TMP("PSORXN",$J) - I $G(PSONOTE) D MAIN^TIUEDIT(3,.TIUDA,PSODFN,"","","","",1) - K PSONOTE - Q -OERR ;entry for renew backdoor - I $$LMREJ^PSOREJU1($P(PSOLST(ORN),"^",2),,.VALMSG,.VALMBCK) Q - S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.") K PSOPLCK S VALMBCK="" Q - K PSOPLCK S X=PSODFN_";DPT(" D LK^ORX2 I 'Y S VALMSG="Another person is entering orders for this patient.",VALMBCK="" D UL^PSSLOCK(PSODFN) Q - K PSOID,PSOFDMX,PSORX("FILL DATE"),PSORENW("FILL DATE"),PSORX("QS"),PSORENW("QS"),PSOBARCD,COPY - D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG D ULPAT Q - S PSOBCKDR=1,PSOFROM="NEW",PSORENW("OIRXN")=$P(PSOLST(ORN),"^",2),PSOOPT=3,(PSORENW("DFLG"),PSORENW("QFLG"),PSORX("DFLG"))=0 - S PSONEW("DAYS SUPPLY")=$P(^PSRX(PSORENW("OIRXN"),0),"^",8),PSONEW("# OF REFILLS")=$P(^(0),"^",9) - D FULL^VALM1,ASK D:PSORENW("QFLG") KLIB^PSORENW1 D:PSORENW("QFLG") ULPAT D:PSORENW("QFLG") PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) G:PSORENW("QFLG") EOJ D ^PSORENW0 - D ULPAT,EOJ,KLIB^PSORENW1 K PSOOPT,PSONEW,PSORX("DFLG") - Q -ULPAT K PSOMSG D UL^PSSLOCK(PSODFN) S X=PSODFN_";DPT(" D ULK^ORX2 - Q -RENEW(PLACER,PSOCPDRG) ;passes flag to CPRS for front door renews - ;-1=couldn't find order, 0=unable to renew, 1=renewable - ;Placer=Pharmacy number - N PSOSURX,PSORFRM,PSOLC,PSODRG,PSODRUG0,RXN,ST,PSONEWOI,PSOOLDOI,PSOIFLAG,PSOINA - I $G(PLACER)["S"!('$G(PLACER)) Q "-1^Not a Valid Outpatient Medication Order." - S RXN=PLACER I '$D(^PSRX(RXN,0)) Q "-1^Not a Valid Outpatient Medication Order." - S RX0=^PSRX(RXN,0),PSODRG=+$P(^PSRX(RXN,0),"^",6),ST=+^("STA"),PSODRUG0=^PSDRUG(PSODRG,0) - S PSOIFLAG=0,PSOOLDOI=+$P($G(^PSRX(RXN,"OR1")),"^"),PSONEWOI=+$P($G(^PSDRUG(+$G(PSODRG),2)),"^") I PSONEWOI,PSONEWOI'=PSOOLDOI S PSOIFLAG=1 - S PSOINA=$P($G(^PS(50.7,PSONEWOI,0)),"^",4) - I PSOINA,DT>PSOINA Q "0^This Orderable Item has been Inactivated." - I ST=5 S PSOSURX=$O(^PS(52.5,"B",RXN,0)) I PSOSURX,$P($G(^PS(52.5,PSOSURX,0)),"^",7)="L" Q "0^Rx loading into a CMOP Transmission." - S X1=DT,X2=-120 D C^%DTC I $P($G(^PSRX(RXN,2)),"^",6)$G(^("I")) Q "0^This Drug has been Inactivated." - I ($P(PSODRUG0,"^",3)[1)!($P(PSODRUG0,"^",3)[2)!($P(PSODRUG0,"^",3)["W") Q "0^Non-Renewable "_$S($P(PSODRUG0,"^",3)["A":"Drug Narcotic.",1:"Drug.") - I $D(^PS(53,+$P(RX0,"^",3),0)),'$P(^(0),"^",5) Q "0^Non-Renewable Prescription." - S PSOLC=$P(RX0,"^"),PSOLC=$E(PSOLC,$L(PSOLC)) I $A(PSOLC)'<90 Q "0^Max number of renewals (26) has been reached." - I ST,ST'=2,ST'=5,ST'=6,ST'=11,ST'=12,ST'=14 Q "0^Prescritpion is in a Non-Renewable Status." - I $P($G(^PSRX(RXN,"OR1")),"^",4) Q "0^Duplicate Rx Renewal Request." - I $O(^PS(52.41,"AQ",RXN,0)) Q "0^Duplicate Rx Renewal Request." - K PSORFRM,PSOLC,PSODRG,PSODRUG0,RXN,ST - Q 1_$S($G(PSOIFLAG):"^"_$G(PSONEWOI),1:"") - ; -INST1 ;Set Pharmacy Instructions array - N PSOTZ - I $O(^PSRX(RXN,"PI",0)) S PHI=$G(^PSRX(RXN,"PI",0)),PSOTZ=0 D - .F S PSOTZ=$O(^PSRX(RXN,"PI",PSOTZ)) Q:PSOTZ="" S PHI(PSOTZ)=$G(^PSRX(RXN,"PI",PSOTZ,0)) - Q -INST2 ;Set Instructions and Comments - I '$G(PSORENW("OIRXN")) Q - I $G(PSOFDR) Q - N PSOPHL,PSOPRL - I $O(^PSRX(PSORENW("OIRXN"),"PI",0)) K PHI S PHI=$G(^PSRX(PSORENW("OIRXN"),"PI",0)),PSOPHL="" D - .F S PSOPHL=$O(^PSRX(PSORENW("OIRXN"),"PI",PSOPHL)) Q:PSOPHL="" S PHI(PSOPHL)=$G(^PSRX(PSORENW("OIRXN"),"PI",PSOPHL,0)) - I $O(^PSRX(PSORENW("OIRXN"),"PRC",0)) K PRC S PRC=$G(^PSRX(PSORENW("OIRXN"),"PRC",0)),PSOPRL="" D - .F S PSOPRL=$O(^PSRX(PSORENW("OIRXN"),"PRC",PSOPRL)) Q:PSOPRL="" S PRC(PSOPRL)=$G(^PSRX(PSORENW("OIRXN"),"PRC",PSOPRL,0)) - Q +PSORENW ;BIR/SAB-renew main driver ;07/07/96 + ;;7.0;OUTPATIENT PHARMACY;**11,27,30,46,71,96,100,130,148**;DEC 1997 + ;External reference to ^PSDRUG supported by DBIA 221 + ;External references L, UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789 + ;External reference to LK^ORX2 and ULK^ORX2 supported by DBIA 867 + ;External reference to ^PS(50.7 supported by DBIA 2223 + ;External reference to MAIN^TIUEDIT supported by DBIA 2410 + ; +ASK ; + K PSORENW("FILL DATE") D FILLDT^PSODIR2(.PSORENW) S:$G(PSORENW("DFLG")) VALMSG="Renew Rx request canceled",VALMBCK="R" + I PSORENW("DFLG")!('$D(PSORENW("FILL DATE"))) S PSORENW("QFLG")=1,PSORENW("DFLG")=0 G ASKX + S PSORNW("FILL DATE")=PSORENW("FILL DATE") + D MW^PSOCMOPA(.PSORENW) + I PSORENW("DFLG") S PSORENW("QFLG")=1,PSORENW("DFLG")=0 G ASKX + S PSORNW("MAIL/WINDOW")=PSORENW("MAIL/WINDOW") S PSORX("MAIL/WINDOW")=$S(PSORENW("MAIL/WINDOW")="M":"MAIL",1:"WINDOW") + D NOORE^PSONEW(.PSORENW) S:$G(PSORENW("DFLG")) VALMSG="Renew Rx request canceled",VALMBCK="R" + I PSORENW("DFLG")!('$D(PSORENW("FILL DATE"))) S PSORENW("QFLG")=1,PSORENW("DFLG")=0 +ASKX Q + ; +EOJ ; + K VERB,RTE,DRET,PSOMSG,PSORNW,PSOLIST,PSORENW,PSORX("BAR CODE"),PSORX("FILL DATE"),PSODIR,PSOID,PSONOOR,PSOCOU,PSOCOUU,PSOID,PSOFDMX,PSODRUG,COPY,PSOBCKDR + S RXN=$O(^TMP("PSORXN",$J,0)) I RXN D + .S RXN1=^TMP("PSORXN",$J,RXN) D EN^PSOHLSN1(RXN,$P(RXN1,"^"),$P(RXN1,"^",2),"",$P(RXN1,"^",3)) + .I $P(^PSRX(RXN,"STA"),"^")=5 D EN^PSOHLSN1(RXN,"SC","ZS",$P(RXN1,"^",4)) + K RXN,RXN1,^TMP("PSORXN",$J) + I $G(PSONOTE) D MAIN^TIUEDIT(3,.TIUDA,PSODFN,"","","","",1) + K PSONOTE + Q +OERR ;entry for renew backdoor + I $$LMREJ^PSOREJU1($P(PSOLST(ORN),"^",2),,.VALMSG,.VALMBCK) Q + S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.") K PSOPLCK S VALMBCK="" Q + K PSOPLCK S X=PSODFN_";DPT(" D LK^ORX2 I 'Y S VALMSG="Another person is entering orders for this patient.",VALMBCK="" D UL^PSSLOCK(PSODFN) Q + K PSOID,PSOFDMX,PSORX("FILL DATE"),PSORENW("FILL DATE"),PSORX("QS"),PSORENW("QS"),PSOBARCD,COPY + D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG D ULPAT Q + S PSOBCKDR=1,PSOFROM="NEW",PSORENW("OIRXN")=$P(PSOLST(ORN),"^",2),PSOOPT=3,(PSORENW("DFLG"),PSORENW("QFLG"),PSORX("DFLG"))=0 + S PSONEW("DAYS SUPPLY")=$P(^PSRX(PSORENW("OIRXN"),0),"^",8),PSONEW("# OF REFILLS")=$P(^(0),"^",9) + D FULL^VALM1,ASK D:PSORENW("QFLG") KLIB^PSORENW1 D:PSORENW("QFLG") ULPAT D:PSORENW("QFLG") PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) G:PSORENW("QFLG") EOJ D ^PSORENW0 + D ULPAT,EOJ,KLIB^PSORENW1 K PSOOPT,PSONEW,PSORX("DFLG") + Q +ULPAT K PSOMSG D UL^PSSLOCK(PSODFN) S X=PSODFN_";DPT(" D ULK^ORX2 + Q +RENEW(PLACER,PSOCPDRG) ;passes flag to CPRS for front door renews + ;-1=couldn't find order, 0=unable to renew, 1=renewable + ;Placer=Pharmacy number + N PSOSURX,PSORFRM,PSOLC,PSODRG,PSODRUG0,RXN,ST,PSONEWOI,PSOOLDOI,PSOIFLAG,PSOINA + I $G(PLACER)["S"!('$G(PLACER)) Q "-1^Not a Valid Outpatient Medication Order." + S RXN=PLACER I '$D(^PSRX(RXN,0)) Q "-1^Not a Valid Outpatient Medication Order." + S RX0=^PSRX(RXN,0),PSODRG=+$P(^PSRX(RXN,0),"^",6),ST=+^("STA"),PSODRUG0=^PSDRUG(PSODRG,0) + S PSOIFLAG=0,PSOOLDOI=+$P($G(^PSRX(RXN,"OR1")),"^"),PSONEWOI=+$P($G(^PSDRUG(+$G(PSODRG),2)),"^") I PSONEWOI,PSONEWOI'=PSOOLDOI S PSOIFLAG=1 + S PSOINA=$P($G(^PS(50.7,PSONEWOI,0)),"^",4) + I PSOINA,DT>PSOINA Q "0^This Orderable Item has been Inactivated." + I ST=5 S PSOSURX=$O(^PS(52.5,"B",RXN,0)) I PSOSURX,$P($G(^PS(52.5,PSOSURX,0)),"^",7)="L" Q "0^Rx loading into a CMOP Transmission." + S X1=DT,X2=-120 D C^%DTC I $P($G(^PSRX(RXN,2)),"^",6)$G(^("I")) Q "0^This Drug has been Inactivated." + I $P(PSODRUG0,"^",3)["A",$P(PSODRUG0,"^",3)'["B" Q "0^Non-Renewable Drug Narcotic." + I $P(PSODRUG0,"^",3)["W" Q "0^Non-Renewable Drug." + I $D(^PS(53,+$P(RX0,"^",3),0)),'$P(^(0),"^",5) Q "0^Non-Renewable Prescription." + S PSOLC=$P(RX0,"^"),PSOLC=$E(PSOLC,$L(PSOLC)) I $A(PSOLC)'<90 Q "0^Max number of renewals (26) has been reached." + I ST,ST'=2,ST'=5,ST'=6,ST'=11,ST'=12,ST'=14 Q "0^Prescritpion is in a Non-Renewable Status." + I $P($G(^PSRX(RXN,"OR1")),"^",4) Q "0^Duplicate Rx Renewal Request." + I $O(^PS(52.41,"AQ",RXN,0)) Q "0^Duplicate Rx Renewal Request." + K PSORFRM,PSOLC,PSODRG,PSODRUG0,RXN,ST + Q 1_$S($G(PSOIFLAG):"^"_$G(PSONEWOI),1:"") + ; +INST1 ;Set Pharmacy Instructions array + N PSOTZ + I $O(^PSRX(RXN,"PI",0)) S PHI=$G(^PSRX(RXN,"PI",0)),PSOTZ=0 D + .F S PSOTZ=$O(^PSRX(RXN,"PI",PSOTZ)) Q:PSOTZ="" S PHI(PSOTZ)=$G(^PSRX(RXN,"PI",PSOTZ,0)) + Q +INST2 ;Set Instructions and Comments + I '$G(PSORENW("OIRXN")) Q + I $G(PSOFDR) Q + N PSOPHL,PSOPRL + I $O(^PSRX(PSORENW("OIRXN"),"PI",0)) K PHI S PHI=$G(^PSRX(PSORENW("OIRXN"),"PI",0)),PSOPHL="" D + .F S PSOPHL=$O(^PSRX(PSORENW("OIRXN"),"PI",PSOPHL)) Q:PSOPHL="" S PHI(PSOPHL)=$G(^PSRX(PSORENW("OIRXN"),"PI",PSOPHL,0)) + I $O(^PSRX(PSORENW("OIRXN"),"PRC",0)) K PRC S PRC=$G(^PSRX(PSORENW("OIRXN"),"PRC",0)),PSOPRL="" D + .F S PSOPRL=$O(^PSRX(PSORENW("OIRXN"),"PRC",PSOPRL)) Q:PSOPRL="" S PRC(PSOPRL)=$G(^PSRX(PSORENW("OIRXN"),"PRC",PSOPRL,0)) + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORENW0.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORENW0.m index efdb5fbf..7fc14385 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORENW0.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORENW0.m @@ -1,201 +1,201 @@ -PSORENW0 ;IHS/DSD/JCM-renew main driver continuation ;4/24/07 9:05am - ;;7.0;OUTPATIENT PHARMACY;**11,27,32,59,64,46,71,96,100,130,237,206**;DEC 1997;Build 39 - ;External reference to ^PS(50.7 supported by DBIA 2223 - ;External reference to ^PSDRUG supported by DBIA 221 - ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789 - ; - ;PSO*237 was not adding to Clozapine Override file, fix -PROCESS ; - D ^PSORENW1 - D INST2^PSORENW - I $D(PSORX("BAR CODE")),PSODFN'=PSORENW("PSODFN") D NEWPT - S PSORENW("DFLG")=0,PSORENW("FILL DATE")=PSORNW("FILL DATE") - I $G(PSORNW("MAIL/WINDOW"))]"" S PSORENW("MAIL/WINDOW")=PSORNW("MAIL/WINDOW") - W !!,"Now Renewing Rx # "_PSORENW("ORX #")_" Drug: "_$P($G(^PSDRUG(+$G(PSORENW("DRUG IEN")),0)),"^"),! - D CHECK G:PSORENW("DFLG") PROCESSX - D FILDATE - D DRUG G:PSORENW("DFLG")!PSORX("DFLG") PROCESSX - D RXN G:PSORENW("DFLG") PROCESSX - D STOP^PSORENW1,OERR^PSORENW1:$G(PSOFDR) -DSPL K PSOEDT,PSOLM D DSPLY^PSORENW3 G:PSORENW("DFLG") PROCESSX - S PSORENW("QFLG")=0 D:'$G(PSOFDR) EDIT - G:PSORENW("DFLG")!$G(PSORX("FN")) PROCESSX - G:'$G(PSORX("FN"))&('$G(PSORENW("QFLG"))) DSPL - D:$D(^XUSEC("PSORPH",DUZ))!('$P(PSOPAR,"^",2)) VER1^PSOORNE4(.PSORENW) I PSORENW("DFLG")=1 G PROCESSX - I $G(NEWDOSE),PSORENW("ENT")>0 K NEWDOSE G DSPL - D EN^PSORN52(.PSORENW) - D RNPSOSD^PSOUTIL - D CAN,DCORD^PSONEW2 - S BBRN="",BBRN1=$O(^PSRX("B",PSORENW("NRX #"),BBRN)) I $P($G(^PSRX(BBRN1,0)),"^",11)["W" S BINGCRT="Y",BINGRTE="W" - ;PSO*237 add to Clozapine Override file -ANQ I $G(ANQDATA)]"" D NOW^%DTC G:$D(^PS(52.52,"B",%)) ANQ D - . K DD,DO S DIC="^PS(52.52,",DIC(0)="L",DLAYGO=52.52,X=% - . D FILE^DICN K DIC,DLAYGO,DD,DO,DA,DR - . N PS52 S (PS52,DA)=+Y,DIE="^PS(52.52,",DR="1////"_PSORENW("IRXN") - . D ^DIE K DIE,DA,DR - . S $P(^PS(52.52,PS52,0),"^",3,6)=ANQDATA - . K ANQDATA,X,Y,%,ANQREM - ; -PROCESSX I PSORENW("DFLG")!$G(PSRX("DFLG")) S PSOBBCLK=1 W:'$G(POERR) !,$C(7),"RENEWED RX DELETED",! D:$P($G(PSOLST(+$G(ORN))),"^",2) PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) S POERR("DFLG")=1 D CLEAN^PSOVER1 - D:$G(PSORENW("OLD FILL DATE"))]"" SUSDATEK^PSOUTIL(.PSORENW) - K PRC,PHI,PSOQUIT,BBRN,BBRN1,PSORENW,PSODRUG,PSORX("PROVIDER NAME"),PSORX("CLINIC"),PSORX("FN") - K PSOEDT,PSOLM S:$G(PSORENW("FROM"))="" (PSORENW("DFLG"),PSORENW("QFLG"))=0 - D CLEAN^PSOVER1 - Q - ; -CHECK ; - I '$D(PSORX("BAR CODE")),PSORENW("PSODFN")'=PSODFN D G CHECKX - .W !!,?5,$C(7),"Can't renew Rx # "_$P(PSORENW("RX0"),"^")_", it is not for this patient." S PSORENW("DFLG")=1 - .S:$G(POERR) VALMSG="Can't renew Rx # "_$P(PSORENW("RX0"),"^")_", not for this patient.",VALMBCK="R" - ;Invalid dosage check - N PSOOCPRX,PSOOLPF,PSOOLPD,PSONOSIG S PSOOCPRX=PSORENW("OIRXN") D CDOSE - I PSOOLPF!(PSONOSIG) D G CHECKX - .S PSORENW("DFLG")=1 - .W !!,$C(7),"Cannot renew Rx # "_$P(PSORENW("RX0"),"^")_$S(PSOOLPF:", invalid dosage of "_$G(PSOOLPD),1:", Missing Sig") - .S:$G(POERR) VALMSG="Cannot renew Rx # "_$P(PSORENW("RX0"),"^")_$S(PSOOLPF:", invalid Dosage of "_$G(PSOOLPD),1:", Missing Sig") S VALMBCK="R" - .I '$G(PSORNSPD) W ! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR - .I $G(PSORNSPD) W ! - ; - S (PSOS,PSOX,PSOY)="" K ACOM,DIR,DIRUT,DIRUT,DUOUT - I $G(PSOSD) F S PSOS=$O(PSOSD(PSOS)) Q:PSOS="" F S PSOX=$O(PSOSD(PSOS,PSOX)) Q:PSOX']""!(PSORENW("DFLG")) I PSORENW("OIRXN")=+PSOSD(PSOS,PSOX) S PSOY=PSOSD(PSOS,PSOX) I $TR($P(PSOY,"^",3),"B")]"" D K ACOM,DIR,DIRUT,DIRUT,DUOUT - . S PSORENW("DFLG")=1 - . W !,$C(7),"Cannot renew Rx # ",$P(PSORENW("RX0"),"^") - . S PSOREA=$P(PSOY,"^",3),PSOSTAT=+PSORENW("STA") - . D STATUS^PSOUTIL(PSOREA,PSOSTAT) K PSOREA,PSOSTAT - .I $G(ACOM)]"" D - ..S DRG=$P(^PSDRUG($P(^PSRX(PSORENW("OIRXN"),0),"^",6),0),"^") - ..W ! S DIR(0)="Y",DIR("A",1)="Do you want to Discontinue this Pending Order",DIR("A")="for "_DRG,DIR("B")="No" - ..D ^DIR I 'Y!($D(DIRUT)) Q - ..D NOOR^PSOCAN4 Q:$D(DIRUT) D DE^PSOORFI2 - .Q - I PSOY="",'$G(PSOORRNW) D - .W !,$C(7),"Cannot renew Rx # ",$P(PSORENW("RX0"),"^")," later Rx exists." S PSORENW("DFLG")=1 - .S:$G(POERR) VALMSG="Cannot renew Rx # "_$P(PSORENW("RX0"),"^")_" later Rx exists.",VALMBCK="R" - K PSOX,PSOY G:PSORENW("DFLG") CHECKX - ; - I $A($E(PSORENW("ORX #"),$L(PSORENW("ORX #"))))'<90 D Q - . W !,$C(7),"Cannot renew Rx # "_PSORENW("ORX #")_", Max number of renewals reached." - .S:$G(POERR)!('$G(SPEED)) (ACOM,VALMSG)="Cannot renew Rx # "_PSORENW("ORX #")_", Max number reached.",VALMBCK="R" - . S PSORENW("DFLG")=1 - .I $G(OR0)]"" D - ..S DRG=$P(^PSDRUG($P(^PSRX(PSORENW("OIRXN"),0),"^",6),0),"^") - ..W ! S DIR(0)="Y",DIR("A",1)="Do you want to Discontinue this Pending Order",DIR("A")="for "_DRG,DIR("B")="No" - ..D ^DIR I 'Y!($D(DIRUT)) Q - ..D NOOR^PSOCAN4 Q:$D(DIRUT) D DE^PSOORFI2 - .K ACOM Q - D CHKDIV G:PSORENW("DFLG") CHECKX - ; - D CHKPRV^PSOUTIL -CHECKX Q - ; -CHKDIV ; - G:$P(PSORENW("RX2"),"^",9)=+PSOSITE CHKDIVX - W !?5,$C(7),"RX # ",$P(PSORENW("RX0"),"^")," is for (",$P(^PS(59,$P(PSORENW("RX2"),"^",9),0),"^"),") division." - I '$P($G(PSOSYS),"^",2) S PSORENW("DFLG")=1 G CHKDIVX - D:$P($G(PSOSYS),"^",3) DIR -CHKDIVX Q - ; -DRUG ; - K PSOY - S PSOY=PSORENW("DRUG IEN"),PSOY(0)=^PSDRUG(PSOY,0) - I '$P($G(^PSDRUG(PSOY,2)),"^") D Q:$G(PSORX("DFLG")) - .I $P($G(^PSRX(PSORENW("OIRXN"),"OR1")),"^") S PSODRUG("OI")=$P(^PSRX(PSORENW("OIRXN"),"OR1"),"^"),PSODRUG("OIN")=$P(^PS(50.7,+^("OR1"),0),"^") Q - .W !!,"Cannot Renew!! No Pharmacy Orderable Item!" S VALMSG="Cannot Renew!! No Pharmacy Orderable Item!",PSORX("DFLG")=1 - D SET^PSODRG - D POST^PSODRG S:PSORX("DFLG") PSORENW("DFLG")=1 ;remove order checks for v7. do allergy checks only - ;D ^PSODRDUP Q:$G(PSORX("DFLG")) ; Set PSORX("DFLG")=1 if process to stop - S PSONOOR=PSORENW("NOO") - ;I $G(PSODRUG("NDF")) S NDF=$P(PSODRUG("NDF"),"A"),VAP=$P(PSODRUG("NDF"),"A",2),PTR=NDF_"."_VAP D CHK^PSODGAL(PSODFN,"DR",PTR) K NDF,VAP,PTR - ;I '$G(PSODRUG("NDF")) D CHK1^PSODGAL(PSODFN) - K PSORX("INTERVENE") - S:$D(PSONEW("STATUS")) PSORENW("STATUS")=PSONEW("STATUS") - K PSOY,PSONEW("STATUS") - Q - ; -RXN ; - K PSOX - S PSOX=$E(PSORENW("ORX #"),$L(PSORENW("ORX #"))) - S PSORENW("NRX #")=$S(PSOX?1N:PSORENW("ORX #")_"A",1:$E(PSORENW("ORX #"),1,$L(PSORENW("ORX #"))-1)_$C($A(PSOX)+1)) -RETRY I $O(^PSRX("B",PSORENW("NRX #"),0)) D G:'$G(PSORENW("DFLG")) RETRY - .W:$A($E(PSORENW("NRX #"),$L(PSORENW("ORX #"))))'=90 !,"Rx # "_PSORENW("NRX #")_" is already on file." - .S:$G(PSOFDR) VALMSG="Rx # "_PSORENW("NRX #")_" is already on file." - .I $A($E(PSORENW("NRX #"),$L(PSORENW("ORX #"))))=90 D - ..W !,"Rx # "_PSORENW("NRX #")_" is already on file. Cannot renew Rx #"_PSORENW("ORX #")_".",!,"A new Rx must be entered.",! - ..S:$G(PSOFDR) VALMSG="Rx # "_PSORENW("NRX #")_" is already on file. Cannot renew Rx #"_PSORENW("ORX #")_". A new Rx must be entered." - ..K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR - ..S:$G(POERR)!($G(PSOFDR)) VALMSG="Cannot renew Rx # "_PSORENW("ORX #")_", Max number reached.",VALMBCK="R" S PSORENW("DFLG")=1 - .S PSOX=$E(PSORENW("NRX #"),$L(PSORENW("NRX #"))) - .S PSORENW("NRX #")=$S(PSOX?1N:PSORENW("NRX #")_"A",1:$E(PSORENW("NRX #"),1,$L(PSORENW("NRX #"))-1)_$C($A(PSOX)+1)) -RXNX K PSOX - Q - ; -FILDATE ; - S PSORENW("IRXN")=PSORENW("OIRXN") - D NEXT^PSOUTIL(.PSORENW) - I PSORENW("FILL DATE")<$P(PSORENW("RX3"),"^",2) D - .D RENFDT^PSOUTIL(.PSORENW) - .I PSORENW("FILL DATE")0 K NEWDOSE G DSPL + D EN^PSORN52(.PSORENW) + D RNPSOSD^PSOUTIL + D CAN,DCORD^PSONEW2 + S BBRN="",BBRN1=$O(^PSRX("B",PSORENW("NRX #"),BBRN)) I $P($G(^PSRX(BBRN1,0)),"^",11)["W" S BINGCRT="Y",BINGRTE="W" + ;PSO*237 add to Clozapine Override file +ANQ I $G(ANQDATA)]"" D NOW^%DTC G:$D(^PS(52.52,"B",%)) ANQ D + . K DD,DO S DIC="^PS(52.52,",DIC(0)="L",DLAYGO=52.52,X=% + . D FILE^DICN K DIC,DLAYGO,DD,DO,DA,DR + . N PS52 S (PS52,DA)=+Y,DIE="^PS(52.52,",DR="1////"_PSORENW("IRXN") + . D ^DIE K DIE,DA,DR + . S $P(^PS(52.52,PS52,0),"^",3,6)=ANQDATA + . K ANQDATA,X,Y,%,ANQREM + ; +PROCESSX I PSORENW("DFLG")!$G(PSRX("DFLG")) S PSOBBCLK=1 W:'$G(POERR) !,$C(7),"RENEWED RX DELETED",! D:$P($G(PSOLST(+$G(ORN))),"^",2) PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) S POERR("DFLG")=1 D CLEAN^PSOVER1 + D:$G(PSORENW("OLD FILL DATE"))]"" SUSDATEK^PSOUTIL(.PSORENW) + K PRC,PHI,PSOQUIT,BBRN,BBRN1,PSORENW,PSODRUG,PSORX("PROVIDER NAME"),PSORX("CLINIC"),PSORX("FN") + K PSOEDT,PSOLM S:$G(PSORENW("FROM"))="" (PSORENW("DFLG"),PSORENW("QFLG"))=0 + D CLEAN^PSOVER1 + Q + ; +CHECK ; + I '$D(PSORX("BAR CODE")),PSORENW("PSODFN")'=PSODFN D G CHECKX + .W !!,?5,$C(7),"Can't renew Rx # "_$P(PSORENW("RX0"),"^")_", it is not for this patient." S PSORENW("DFLG")=1 + .S:$G(POERR) VALMSG="Can't renew Rx # "_$P(PSORENW("RX0"),"^")_", not for this patient.",VALMBCK="R" + ;Invalid dosage check + N PSOOCPRX,PSOOLPF,PSOOLPD,PSONOSIG S PSOOCPRX=PSORENW("OIRXN") D CDOSE + I PSOOLPF!(PSONOSIG) D G CHECKX + .S PSORENW("DFLG")=1 + .W !!,$C(7),"Cannot renew Rx # "_$P(PSORENW("RX0"),"^")_$S(PSOOLPF:", invalid dosage of "_$G(PSOOLPD),1:", Missing Sig") + .S:$G(POERR) VALMSG="Cannot renew Rx # "_$P(PSORENW("RX0"),"^")_$S(PSOOLPF:", invalid Dosage of "_$G(PSOOLPD),1:", Missing Sig") S VALMBCK="R" + .I '$G(PSORNSPD) W ! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR + .I $G(PSORNSPD) W ! + ; + S (PSOS,PSOX,PSOY)="" K ACOM,DIR,DIRUT,DIRUT,DUOUT + I $G(PSOSD) F S PSOS=$O(PSOSD(PSOS)) Q:PSOS="" F S PSOX=$O(PSOSD(PSOS,PSOX)) Q:PSOX']""!(PSORENW("DFLG")) I PSORENW("OIRXN")=+PSOSD(PSOS,PSOX) S PSOY=PSOSD(PSOS,PSOX) I $P(PSOY,"^",3)]"" D K ACOM,DIR,DIRUT,DIRUT,DUOUT + . S PSORENW("DFLG")=1 + . W !,$C(7),"Cannot renew Rx # ",$P(PSORENW("RX0"),"^") + . S PSOREA=$P(PSOY,"^",3),PSOSTAT=+PSORENW("STA") + . D STATUS^PSOUTIL(PSOREA,PSOSTAT) K PSOREA,PSOSTAT + .I $G(ACOM)]"" D + ..S DRG=$P(^PSDRUG($P(^PSRX(PSORENW("OIRXN"),0),"^",6),0),"^") + ..W ! S DIR(0)="Y",DIR("A",1)="Do you want to Discontinue this Pending Order",DIR("A")="for "_DRG,DIR("B")="No" + ..D ^DIR I 'Y!($D(DIRUT)) Q + ..D NOOR^PSOCAN4 Q:$D(DIRUT) D DE^PSOORFI2 + .Q + I PSOY="",'$G(PSOORRNW) D + .W !,$C(7),"Cannot renew Rx # ",$P(PSORENW("RX0"),"^")," later Rx exists." S PSORENW("DFLG")=1 + .S:$G(POERR) VALMSG="Cannot renew Rx # "_$P(PSORENW("RX0"),"^")_" later Rx exists.",VALMBCK="R" + K PSOX,PSOY G:PSORENW("DFLG") CHECKX + ; + I $A($E(PSORENW("ORX #"),$L(PSORENW("ORX #"))))'<90 D Q + . W !,$C(7),"Cannot renew Rx # "_PSORENW("ORX #")_", Max number of renewals reached." + .S:$G(POERR)!('$G(SPEED)) (ACOM,VALMSG)="Cannot renew Rx # "_PSORENW("ORX #")_", Max number reached.",VALMBCK="R" + . S PSORENW("DFLG")=1 + .I $G(OR0)]"" D + ..S DRG=$P(^PSDRUG($P(^PSRX(PSORENW("OIRXN"),0),"^",6),0),"^") + ..W ! S DIR(0)="Y",DIR("A",1)="Do you want to Discontinue this Pending Order",DIR("A")="for "_DRG,DIR("B")="No" + ..D ^DIR I 'Y!($D(DIRUT)) Q + ..D NOOR^PSOCAN4 Q:$D(DIRUT) D DE^PSOORFI2 + .K ACOM Q + D CHKDIV G:PSORENW("DFLG") CHECKX + ; + D CHKPRV^PSOUTIL +CHECKX Q + ; +CHKDIV ; + G:$P(PSORENW("RX2"),"^",9)=+PSOSITE CHKDIVX + W !?5,$C(7),"RX # ",$P(PSORENW("RX0"),"^")," is for (",$P(^PS(59,$P(PSORENW("RX2"),"^",9),0),"^"),") division." + I '$P($G(PSOSYS),"^",2) S PSORENW("DFLG")=1 G CHKDIVX + D:$P($G(PSOSYS),"^",3) DIR +CHKDIVX Q + ; +DRUG ; + K PSOY + S PSOY=PSORENW("DRUG IEN"),PSOY(0)=^PSDRUG(PSOY,0) + I '$P($G(^PSDRUG(PSOY,2)),"^") D Q:$G(PSORX("DFLG")) + .I $P($G(^PSRX(PSORENW("OIRXN"),"OR1")),"^") S PSODRUG("OI")=$P(^PSRX(PSORENW("OIRXN"),"OR1"),"^"),PSODRUG("OIN")=$P(^PS(50.7,+^("OR1"),0),"^") Q + .W !!,"Cannot Renew!! No Pharmacy Orderable Item!" S VALMSG="Cannot Renew!! No Pharmacy Orderable Item!",PSORX("DFLG")=1 + D SET^PSODRG + D POST^PSODRG S:PSORX("DFLG") PSORENW("DFLG")=1 ;remove order checks for v7. do allergy checks only + ;D ^PSODRDUP Q:$G(PSORX("DFLG")) ; Set PSORX("DFLG")=1 if process to stop + S PSONOOR=PSORENW("NOO") + ;I $G(PSODRUG("NDF")) S NDF=$P(PSODRUG("NDF"),"A"),VAP=$P(PSODRUG("NDF"),"A",2),PTR=NDF_"."_VAP D CHK^PSODGAL(PSODFN,"DR",PTR) K NDF,VAP,PTR + ;I '$G(PSODRUG("NDF")) D CHK1^PSODGAL(PSODFN) + K PSORX("INTERVENE") + S:$D(PSONEW("STATUS")) PSORENW("STATUS")=PSONEW("STATUS") + K PSOY,PSONEW("STATUS") + Q + ; +RXN ; + K PSOX + S PSOX=$E(PSORENW("ORX #"),$L(PSORENW("ORX #"))) + S PSORENW("NRX #")=$S(PSOX?1N:PSORENW("ORX #")_"A",1:$E(PSORENW("ORX #"),1,$L(PSORENW("ORX #"))-1)_$C($A(PSOX)+1)) +RETRY I $O(^PSRX("B",PSORENW("NRX #"),0)) D G:'$G(PSORENW("DFLG")) RETRY + .W:$A($E(PSORENW("NRX #"),$L(PSORENW("ORX #"))))'=90 !,"Rx # "_PSORENW("NRX #")_" is already on file." + .S:$G(PSOFDR) VALMSG="Rx # "_PSORENW("NRX #")_" is already on file." + .I $A($E(PSORENW("NRX #"),$L(PSORENW("ORX #"))))=90 D + ..W !,"Rx # "_PSORENW("NRX #")_" is already on file. Cannot renew Rx #"_PSORENW("ORX #")_".",!,"A new Rx must be entered.",! + ..S:$G(PSOFDR) VALMSG="Rx # "_PSORENW("NRX #")_" is already on file. Cannot renew Rx #"_PSORENW("ORX #")_". A new Rx must be entered." + ..K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR + ..S:$G(POERR)!($G(PSOFDR)) VALMSG="Cannot renew Rx # "_PSORENW("ORX #")_", Max number reached.",VALMBCK="R" S PSORENW("DFLG")=1 + .S PSOX=$E(PSORENW("NRX #"),$L(PSORENW("NRX #"))) + .S PSORENW("NRX #")=$S(PSOX?1N:PSORENW("NRX #")_"A",1:$E(PSORENW("NRX #"),1,$L(PSORENW("NRX #"))-1)_$C($A(PSOX)+1)) +RXNX K PSOX + Q + ; +FILDATE ; + S PSORENW("IRXN")=PSORENW("OIRXN") + D NEXT^PSOUTIL(.PSORENW) + I PSORENW("FILL DATE")<$P(PSORENW("RX3"),"^",2) D + .D RENFDT^PSOUTIL(.PSORENW) + .I PSORENW("FILL DATE")0,'$O(^PSRX(PSORENW("OIRXN"),6,0)) S PSORENW("ENT")=0 G FDR - F I=0:0 S I=$O(^PSRX(PSORENW("OIRXN"),6,I)) Q:'I S DOSE=^PSRX(PSORENW("OIRXN"),6,I,0) D - .S PSORENW("ENT")=$G(PSORENW("ENT"))+1,PSORENW("DOSE",PSORENW("ENT"))=$P(DOSE,"^") - .S PSORENW("UNITS",PSORENW("ENT"))=$P(DOSE,"^",3),PSORENW("DOSE ORDERED",PSORENW("ENT"))=$P(DOSE,"^",2),PSORENW("ROUTE",PSORENW("ENT"))=$P(DOSE,"^",7) - .S PSORENW("SCHEDULE",PSORENW("ENT"))=$P(DOSE,"^",8),PSORENW("DURATION",PSORENW("ENT"))=$P(DOSE,"^",5),PSORENW("CONJUNCTION",PSORENW("ENT"))=$P(DOSE,"^",6) - .S PSORENW("NOUN",PSORENW("ENT"))=$P(DOSE,"^",4),PSORENW("VERB",PSORENW("ENT"))=$P(DOSE,"^",9) - .I $G(^PSRX(PSORENW("OIRXN"),6,I,1))]"" S PSORENW("ODOSE",PSORENW("ENT"))=^PSRX(PSORENW("OIRXN"),6,I,1) - .K DOSE -FDR I $G(PSOFDR) D - .F I=0:0 S I=$O(^PSRX(PSORENW("OIRXN"),6,I)) Q:'I I $G(^PSRX(PSORENW("OIRXN"),6,I,1))]"" S PSORENW("ODOSE",I)=^PSRX(PSORENW("OIRXN"),6,I,1) - .S $P(PSORENW("RX0"),"^",7)=$P(OR0,"^",10),$P(PSORENW("RX0"),"^",11)=$P(OR0,"^",17) - .S (PSORX("PROVIDER NAME"),PSORENW("PROVIDER NAME"))=$P(^VA(200,$P(OR0,"^",5),0),"^"),PSORENW("PROVIDER")=$P(OR0,"^",5) - .K PSORENW("COSIGNING PROVIDER") - .I $G(PSORENW("PROVIDER")),$P($G(^VA(200,PSORENW("PROVIDER"),"PS")),"^",7),$P($G(^("PS")),"^",8) S PSORENW("COSIGNING PROVIDER")=$P($G(^("PS")),"^",8) - .S (PSDY,PSORENW("DAYS SUPPLY"))=$P(PSORENW("RX0"),"^",8) - .S POERR=1,DREN=$P(PSORENW("RX0"),"^",6) D DRG^PSOORDRG K POERR S PSODIR("CS")=0 - .F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)="" I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S PSODIR("CS")=1 - .I PSODIR("CS") S RFMX=$S(PSDY<60:5,PSDY'<60&(PSDY'>89):2,PSDY=90:1,1:0) - .E S RFMX=$S(PSDY<60:11,PSDY'<60&(PSDY'>89):5,PSDY=90:3,1:0) - .S $P(PSORENW("RX0"),"^",9)=$S($P(OR0,"^",11)'>RFMX:$P(OR0,"^",11),1:RFMX),$P(OR0,"^",11)=$P(PSORENW("RX0"),"^",9) - .K RFMX,PSODIR("CS"),PSDY -END Q -STOP K PSEXDT,X,%DT S PSON52("QFLG")=0,DAYS=$S($G(PSORENW("DAYS SUPPLY")):PSORENW("DAYS SUPPLY"),1:$P(PSORENW("RX0"),"^",8)) - S DEA("CS")=0 K DIR,DIC - F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)="" I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S DEA("CS")=1 - S X1=$S($G(PSORENW("ISSUE DATE")):$G(PSORENW("ISSUE DATE")),1:DT),X2=DAYS*($P(PSORENW("RX0"),"^",9)+1)\1 - S X2=$S(DAYS=X2&('DEA("CS")):X2,DEA("CS"):184,1:366) D C^%DTC - I PSORENW("FILL DATE")>$P(X,".") S PSEXDT=1_"^"_$P(X,".") - K X1,X2,X,%DT - Q -OERR ;renewal finish from oe/rr - S PSORENW("RX0")=^PSRX(PSORENW("OIRXN"),0),PSORENW("RX2")=^(2),PSORENW("RX3")=^(3),PSORENW("STA")=^("STA"),PSORENW("TN")=$G(^("TN")) - S $P(PSORENW("RX0"),"^",4)=$P(OR0,"^",5) - S PSORENW("PROVIDER")=$P(OR0,"^",5) - S PSORX("PROVIDER NAME")=$P($G(^VA(200,PSORENW("PROVIDER"),0)),"^") - S $P(PSORENW("RX0"),"^",5)=$P(OR0,"^",13) - S PSORENW("CLINIC")=$P(OR0,"^",13) - S PSORENW("REMARKS")="RENEWED FROM RX # "_$P(PSORENW("RX0"),"^")_"."_$S($P(OR0,"^",17)="C":" Administered in Clinic.",1:"") - S PSORENW("SIG")=$P($G(^PSRX(PSORENW("OIRXN"),"SIG")),"^"),SIGOK=$P(^("SIG"),"^",2) I SIGOK D - .F I=0:0 S I=$O(^PSRX(PSORENW("OIRXN"),"SIG1",I)) Q:'I S SIG(I)=^PSRX(PSORENW("OIRXN"),"SIG1",I,0) - S:$P(PSORENW("RX3"),"^",3) PSORENW("COSIGNING PROVIDER")=$P(PSORENW("RX3"),"^",3) - S PSORENW("PSODFN")=$P(PSORENW("RX0"),"^",2) - S PSORENW("ORX #")=$P(PSORENW("RX0"),"^") - S PSORENW("DRUG IEN")=$P(PSORENW("RX0"),"^",6),$P(PSORENW("RX0"),"^",11)=$P(OR0,"^",17) - S PSORENW("INS")=$S($G(PSORENW("INS"))]"":PSORENW("INS"),1:$G(^PSRX(PSORENW("OIRXN"),"INS"))) - Q:$G(PSORENW("ENT"))>0 - F I=0:0 S I=$O(^PSRX(PSORENW("OIRXN"),6,I)) Q:'I S DOSE=^PSRX(PSORENW("OIRXN"),6,I,0) D - .S PSORENW("ENT")=PSORENW("ENT")+1,PSORENW("DOSE",PSORENW("ENT"))=$P(DOSE,"^") - .S PSORENW("UNITS",PSORENW("ENT"))=$P(DOSE,"^",3),PSORENW("DOSE ORDERED",PSORENW("ENT"))=$P(DOSE,"^",2),PSORENW("ROUTE",PSORENW("ENT"))=$P(DOSE,"^",7) - .S PSORENW("SCHEDULE",PSORENW("ENT"))=$P(DOSE,"^",8),PSORENW("DURATION",PSORENW("ENT"))=$P(DOSE,"^",5),PSORENW("CONJUNCTION",PSORENW("ENT"))=$P(DOSE,"^",6) - .S PSORENW("NOUN",PSORENW("ENT"))=$P(DOSE,"^",4),PSORENW("VERB",PSORENW("ENT"))=$P(DOSE,"^",9) - .I $G(^PSRX(PSORENW("OIRXN"),6,I,1))]"" S PSORENW("ODOSE",PSORENW("ENT"))=^PSRX(PSORENW("OIRXN"),6,I,1) - .K DOSE - Q - ; -SETIB ;Set defaults on Renewals with Copay information - ;If answer is in Pending File, use that, else look in Prescription file - N PSOOICD,JJJ - K PSOSCP,PSOANSQ("SC>50") D SCP^PSORN52D S PSOANSQ("SC>50")="" K PSOSCA - I '$G(PSOIBOLD) Q - I $G(PSOFDR),$G(ORD) D SETIBP Q - ;I '$$DT^PSOMLLDT Q - I $G(PSORX(PSOIBOLD,"SC"))'=0,$G(PSORX(PSOIBOLD,"SC"))'=1 S PSORX(PSOIBOLD,"SC")=$S($P($G(^PSRX(PSOIBOLD,"IBQ")),"^")'="":$P($G(^("IBQ")),"^"),$P($G(^PSRX(PSOIBOLD,"IB")),"^"):0,1:"") - I $G(PSORX(PSOIBOLD,"SC"))="" K PSORX(PSOIBOLD,"SC") - I '$$DT^PSOMLLDT Q - I $G(PSORX(PSOIBOLD,"MST"))'=0,$G(PSORX(PSOIBOLD,"MST"))'=1,$P($G(^PSRX(PSOIBOLD,"IBQ")),"^",2)'="" S PSORX(PSOIBOLD,"MST")=$P($G(^("IBQ")),"^",2) - I $G(PSORX(PSOIBOLD,"VEH"))'=0,$G(PSORX(PSOIBOLD,"VEH"))'=1,$P($G(^PSRX(PSOIBOLD,"IBQ")),"^",3)'="" S PSORX(PSOIBOLD,"VEH")=$P($G(^("IBQ")),"^",3) - I $G(PSORX(PSOIBOLD,"RAD"))'=0,$G(PSORX(PSOIBOLD,"RAD"))'=1,$P($G(^PSRX(PSOIBOLD,"IBQ")),"^",4)'="" S PSORX(PSOIBOLD,"RAD")=$P($G(^("IBQ")),"^",4) - I $G(PSORX(PSOIBOLD,"PGW"))'=0,$G(PSORX(PSOIBOLD,"PGW"))'=1,$P($G(^PSRX(PSOIBOLD,"IBQ")),"^",5)'="" S PSORX(PSOIBOLD,"PGW")=$P($G(^("IBQ")),"^",5) - I $G(PSORX(PSOIBOLD,"HNC"))'=0,$G(PSORX(PSOIBOLD,"HNC"))'=1,$P($G(^PSRX(PSOIBOLD,"IBQ")),"^",6)'="" S PSORX(PSOIBOLD,"HNC")=$P($G(^("IBQ")),"^",6) - I $G(PSORX(PSOIBOLD,"CV"))'=0,$G(PSORX(PSOIBOLD,"CV"))'=1,$P($G(^PSRX(PSOIBOLD,"IBQ")),"^",7)'="" S PSORX(PSOIBOLD,"CV")=$P($G(^("IBQ")),"^",7) - I $G(PSORX(PSOIBOLD,"SHAD"))'=0,$G(PSORX(PSOIBOLD,"SHAD"))'=1,$P($G(^PSRX(PSOIBOLD,"IBQ")),"^",8)'="" S PSORX(PSOIBOLD,"SHAD")=$P($G(^("IBQ")),"^",8) - ; -SET2 ;for when patient status is exempt or SC>50 - I $TR($G(^PSRX(PSOIBOLD,"IBQ")),"^")="" S PSOOICD=$G(^PSRX(PSOIBOLD,"ICD",1,0)) D SET3:PSOOICD'="" - ; -ICD I $D(^PSRX(PSORENW("OIRXN"),"ICD",0)) D - . N JJ,ICD,II,FLD,RXN S RXN=PSOIBOLD - . S II=0 F S II=$O(^PSRX(PSORENW("OIRXN"),"ICD",II)) Q:II=""!(II'?1N.N) D - .. S ICD=^PSRX(PSORENW("OIRXN"),"ICD",II,0),FLD=$P(ICD,U) D ICD^PSONEWF - Q -SET3 ;for when patient status is exempt or SC>50 - D SET3^PSORN52D - Q - ; -SETIBP ; - I $P($G(^PS(52.41,ORD,0)),"^",16)="SC"!($P($G(^(0)),"^",16)="NSC") S PSORX(PSOIBOLD,"SC")=$S($P($G(^(0)),"^",16)="SC":1,1:0) - I $G(PSORX(PSOIBOLD,"SC"))="" K PSORX(PSOIBOLD,"SC") - I '$$DT^PSOMLLDT Q - N PSOIBQFN S PSOIBQFN=$G(^PS(52.41,ORD,"IBQ")) - I $P(PSOIBQFN,"^",1)=0!($P(PSOIBQFN,"^",1)=1) S PSORX(PSOIBOLD,"MST")=$P(PSOIBQFN,"^") - I $P(PSOIBQFN,"^",2)=0!($P(PSOIBQFN,"^",2)=1) S PSORX(PSOIBOLD,"VEH")=$P(PSOIBQFN,"^",2) - I $P(PSOIBQFN,"^",3)=0!($P(PSOIBQFN,"^",3)=1) S PSORX(PSOIBOLD,"RAD")=$P(PSOIBQFN,"^",3) - I $P(PSOIBQFN,"^",4)=0!($P(PSOIBQFN,"^",4)=1) S PSORX(PSOIBOLD,"PGW")=$P(PSOIBQFN,"^",4) - I $P(PSOIBQFN,"^",5)=0!($P(PSOIBQFN,"^",5)=1) S PSORX(PSOIBOLD,"HNC")=$P(PSOIBQFN,"^",5) - I $P(PSOIBQFN,"^",6)=0!($P(PSOIBQFN,"^",6)=1) S PSORX(PSOIBOLD,"CV")=$P(PSOIBQFN,"^",6) - I $P(PSOIBQFN,"^",7)=0!($P(PSOIBQFN,"^",7)=1) S PSORX(PSOIBOLD,"SHAD")=$P(PSOIBQFN,"^",7) - ;for when patient status is exempt, null IBQ node was set for exempts or SC>50 - data is in ICD node - I $TR($G(^PS(52.41,ORD,"IBQ")),"^")="" S PSOOICD=$G(^PS(52.41,ORD,"ICD",1,0)) D SET3:PSOOICD'="" - ; -ICD2 ; - I $D(^PS(52.41,ORD,"ICD",0)) D - . N JJ,ICD,II,FLD,RXN S RXN=ORD - . S II=0 F S II=$O(^PS(52.41,ORD,"ICD",II)) Q:II=""!(II'?1N.N) D - .. S ICD="",ICD=^PS(52.41,ORD,"ICD",II,0) - .. I $G(PSOSCP)>49&(II=1) S PSORX(PSOIBOLD,"SC>50")=$P(ICD,"^",4) - .. S JJ="" F JJ=1:1:9 S FLD=$P(ICD,U,JJ) D ICD^PSONEWF - K PSOIBQFN - Q -KLIB ;Kill renewal IB array - I '$G(PSOIBOLD) Q - K PSORX(PSOIBOLD,"SC"),PSORX(PSOIBOLD,"MST"),PSORX(PSOIBOLD,"VEH"),PSORX(PSOIBOLD,"RAD"),PSORX(PSOIBOLD,"PGW"),PSORX(PSOIBOLD,"HNC"),PSORX(PSOIBOLD,"CV"),PSORX(PSOIBOLD,"SHAD") - K PSOIBOLD - Q +PSORENW1 ;BIR/DSD - Renew Main Driver Continuation ;03/29/93 + ;;7.0;OUTPATIENT PHARMACY;**20,37,51,46,71,117,157,143,219,239**;DEC 1997 + ;External reference ^VA(200 supported by DBIA 10060 + ; +START ; + S PSORENW("RX0")=^PSRX(PSORENW("OIRXN"),0),PSORENW("RX2")=^(2),PSORENW("RX3")=^(3),PSORENW("STA")=^("STA"),PSORENW("TN")=$G(^("TN")),SIGOK=+$P($G(^("SIG")),"^",2) + S PSOIBOLD=$G(PSORENW("OIRXN")) + D SETIB + S PSORENW("PROVIDER")=$P(PSORENW("RX0"),"^",4) + S PSORX("PROVIDER NAME")=$P($G(^VA(200,PSORENW("PROVIDER"),0)),"^") + S PSORENW("CLINIC")=$P(PSORENW("RX0"),"^",5),PSORENW("COPIES")=$P(PSORENW("RX0"),"^",18) + I $G(PSOFDR),$P($G(OR0),"^",13) S PSORENW("CLINIC")=$P($G(OR0),"^",13) + S PSORENW("REMARKS")="RENEWED FROM RX # "_$P(PSORENW("RX0"),"^") + S PSORENW("SIG")=$P($G(^PSRX(PSORENW("OIRXN"),"SIG")),"^") + S:$P(PSORENW("RX3"),"^",3) PSORENW("COSIGNING PROVIDER")=$P(PSORENW("RX3"),"^",3) + S (PSODFN,PSORENW("PSODFN"))=$P(PSORENW("RX0"),"^",2) + S PSORENW("ORX #")=$P(PSORENW("RX0"),"^") + S PSORENW("DRUG IEN")=$P(PSORENW("RX0"),"^",6) + S PSORENW("INS")=$S($G(PSORENW("INS"))]"":PSORENW("INS"),1:$G(^PSRX(PSORENW("OIRXN"),"INS"))) + S D=0 F S D=$O(^PSRX(PSORENW("OIRXN"),"INS1",D)) Q:'D S PSORENW("SIG",D)=^PSRX(PSORENW("OIRXN"),"INS1",D,0) + I '$O(PSORENW("SIG",0)),$G(PSORENW("INS"))]"" S PSORENW("SIG",1)=PSORENW("INS") + G:$G(PSORENW("ENT")) FDR + I $G(PSORENW("ENT"))'>0,'$O(^PSRX(PSORENW("OIRXN"),6,0)) S PSORENW("ENT")=0 G FDR + F I=0:0 S I=$O(^PSRX(PSORENW("OIRXN"),6,I)) Q:'I S DOSE=^PSRX(PSORENW("OIRXN"),6,I,0) D + .S PSORENW("ENT")=$G(PSORENW("ENT"))+1,PSORENW("DOSE",PSORENW("ENT"))=$P(DOSE,"^") + .S PSORENW("UNITS",PSORENW("ENT"))=$P(DOSE,"^",3),PSORENW("DOSE ORDERED",PSORENW("ENT"))=$P(DOSE,"^",2),PSORENW("ROUTE",PSORENW("ENT"))=$P(DOSE,"^",7) + .S PSORENW("SCHEDULE",PSORENW("ENT"))=$P(DOSE,"^",8),PSORENW("DURATION",PSORENW("ENT"))=$P(DOSE,"^",5),PSORENW("CONJUNCTION",PSORENW("ENT"))=$P(DOSE,"^",6) + .S PSORENW("NOUN",PSORENW("ENT"))=$P(DOSE,"^",4),PSORENW("VERB",PSORENW("ENT"))=$P(DOSE,"^",9) + .I $G(^PSRX(PSORENW("OIRXN"),6,I,1))]"" S PSORENW("ODOSE",PSORENW("ENT"))=^PSRX(PSORENW("OIRXN"),6,I,1) + .K DOSE +FDR I $G(PSOFDR) D + .F I=0:0 S I=$O(^PSRX(PSORENW("OIRXN"),6,I)) Q:'I I $G(^PSRX(PSORENW("OIRXN"),6,I,1))]"" S PSORENW("ODOSE",I)=^PSRX(PSORENW("OIRXN"),6,I,1) + .S $P(PSORENW("RX0"),"^",7)=$P(OR0,"^",10),$P(PSORENW("RX0"),"^",11)=$P(OR0,"^",17) + .S (PSORX("PROVIDER NAME"),PSORENW("PROVIDER NAME"))=$P(^VA(200,$P(OR0,"^",5),0),"^"),PSORENW("PROVIDER")=$P(OR0,"^",5) + .K PSORENW("COSIGNING PROVIDER") + .I $G(PSORENW("PROVIDER")),$P($G(^VA(200,PSORENW("PROVIDER"),"PS")),"^",7),$P($G(^("PS")),"^",8) S PSORENW("COSIGNING PROVIDER")=$P($G(^("PS")),"^",8) + .S (PSDY,PSORENW("DAYS SUPPLY"))=$P(PSORENW("RX0"),"^",8) + .S POERR=1,DREN=$P(PSORENW("RX0"),"^",6) D DRG^PSOORDRG K POERR S PSODIR("CS")=0 + .F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)="" I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S PSODIR("CS")=1 + .I PSODIR("CS") S RFMX=$S(PSDY<60:5,PSDY'<60&(PSDY'>89):2,PSDY=90:1,1:0) + .E S RFMX=$S(PSDY<60:11,PSDY'<60&(PSDY'>89):5,PSDY=90:3,1:0) + .S $P(PSORENW("RX0"),"^",9)=$S($P(OR0,"^",11)'>RFMX:$P(OR0,"^",11),1:RFMX),$P(OR0,"^",11)=$P(PSORENW("RX0"),"^",9) + .K RFMX,PSODIR("CS"),PSDY +END Q +STOP K PSEXDT,X,%DT S PSON52("QFLG")=0,DAYS=$S($G(PSORENW("DAYS SUPPLY")):PSORENW("DAYS SUPPLY"),1:$P(PSORENW("RX0"),"^",8)) + S DEA("CS")=0 K DIR,DIC + F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)="" I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S DEA("CS")=1 + S X1=$S($G(PSORENW("ISSUE DATE")):$G(PSORENW("ISSUE DATE")),1:DT),X2=DAYS*($P(PSORENW("RX0"),"^",9)+1)\1 + S X2=$S(DAYS=X2&('DEA("CS")):X2,DEA("CS"):184,1:366) D C^%DTC + I PSORENW("FILL DATE")>$P(X,".") S PSEXDT=1_"^"_$P(X,".") + K X1,X2,X,%DT + Q +OERR ;renewal finish from oe/rr + S PSORENW("RX0")=^PSRX(PSORENW("OIRXN"),0),PSORENW("RX2")=^(2),PSORENW("RX3")=^(3),PSORENW("STA")=^("STA"),PSORENW("TN")=$G(^("TN")) + S $P(PSORENW("RX0"),"^",4)=$P(OR0,"^",5) + S PSORENW("PROVIDER")=$P(OR0,"^",5) + S PSORX("PROVIDER NAME")=$P($G(^VA(200,PSORENW("PROVIDER"),0)),"^") + S $P(PSORENW("RX0"),"^",5)=$P(OR0,"^",13) + S PSORENW("CLINIC")=$P(OR0,"^",13) + S PSORENW("REMARKS")="RENEWED FROM RX # "_$P(PSORENW("RX0"),"^")_"."_$S($P(OR0,"^",17)="C":" Administered in Clinic.",1:"") + S PSORENW("SIG")=$P($G(^PSRX(PSORENW("OIRXN"),"SIG")),"^"),SIGOK=$P(^("SIG"),"^",2) I SIGOK D + .F I=0:0 S I=$O(^PSRX(PSORENW("OIRXN"),"SIG1",I)) Q:'I S SIG(I)=^PSRX(PSORENW("OIRXN"),"SIG1",I,0) + S:$P(PSORENW("RX3"),"^",3) PSORENW("COSIGNING PROVIDER")=$P(PSORENW("RX3"),"^",3) + S PSORENW("PSODFN")=$P(PSORENW("RX0"),"^",2) + S PSORENW("ORX #")=$P(PSORENW("RX0"),"^") + S PSORENW("DRUG IEN")=$P(PSORENW("RX0"),"^",6),$P(PSORENW("RX0"),"^",11)=$P(OR0,"^",17) + S PSORENW("INS")=$S($G(PSORENW("INS"))]"":PSORENW("INS"),1:$G(^PSRX(PSORENW("OIRXN"),"INS"))) + Q:$G(PSORENW("ENT"))>0 + F I=0:0 S I=$O(^PSRX(PSORENW("OIRXN"),6,I)) Q:'I S DOSE=^PSRX(PSORENW("OIRXN"),6,I,0) D + .S PSORENW("ENT")=PSORENW("ENT")+1,PSORENW("DOSE",PSORENW("ENT"))=$P(DOSE,"^") + .S PSORENW("UNITS",PSORENW("ENT"))=$P(DOSE,"^",3),PSORENW("DOSE ORDERED",PSORENW("ENT"))=$P(DOSE,"^",2),PSORENW("ROUTE",PSORENW("ENT"))=$P(DOSE,"^",7) + .S PSORENW("SCHEDULE",PSORENW("ENT"))=$P(DOSE,"^",8),PSORENW("DURATION",PSORENW("ENT"))=$P(DOSE,"^",5),PSORENW("CONJUNCTION",PSORENW("ENT"))=$P(DOSE,"^",6) + .S PSORENW("NOUN",PSORENW("ENT"))=$P(DOSE,"^",4),PSORENW("VERB",PSORENW("ENT"))=$P(DOSE,"^",9) + .I $G(^PSRX(PSORENW("OIRXN"),6,I,1))]"" S PSORENW("ODOSE",PSORENW("ENT"))=^PSRX(PSORENW("OIRXN"),6,I,1) + .K DOSE + Q +SETIB ;Set defaults on Renewals with Copay information + ;If answer is in Pending File, use that, else look in Prescription file + N PSOOICD,JJJ + K PSOSCP,PSOANSQ("SC>50") D SCP^PSORN52D S PSOANSQ("SC>50")="" K PSOSCA + I '$G(PSOIBOLD) Q + I $G(PSOFDR),$G(ORD) D SETIBP Q + ;I '$$DT^PSOMLLDT Q + I $G(PSORX(PSOIBOLD,"SC"))'=0,$G(PSORX(PSOIBOLD,"SC"))'=1 S PSORX(PSOIBOLD,"SC")=$S($P($G(^PSRX(PSOIBOLD,"IBQ")),"^")'="":$P($G(^("IBQ")),"^"),$P($G(^PSRX(PSOIBOLD,"IB")),"^"):0,1:"") + I $G(PSORX(PSOIBOLD,"SC"))="" K PSORX(PSOIBOLD,"SC") + I '$$DT^PSOMLLDT Q + I $G(PSORX(PSOIBOLD,"MST"))'=0,$G(PSORX(PSOIBOLD,"MST"))'=1,$P($G(^PSRX(PSOIBOLD,"IBQ")),"^",2)'="" S PSORX(PSOIBOLD,"MST")=$P($G(^("IBQ")),"^",2) + I $G(PSORX(PSOIBOLD,"VEH"))'=0,$G(PSORX(PSOIBOLD,"VEH"))'=1,$P($G(^PSRX(PSOIBOLD,"IBQ")),"^",3)'="" S PSORX(PSOIBOLD,"VEH")=$P($G(^("IBQ")),"^",3) + I $G(PSORX(PSOIBOLD,"RAD"))'=0,$G(PSORX(PSOIBOLD,"RAD"))'=1,$P($G(^PSRX(PSOIBOLD,"IBQ")),"^",4)'="" S PSORX(PSOIBOLD,"RAD")=$P($G(^("IBQ")),"^",4) + I $G(PSORX(PSOIBOLD,"PGW"))'=0,$G(PSORX(PSOIBOLD,"PGW"))'=1,$P($G(^PSRX(PSOIBOLD,"IBQ")),"^",5)'="" S PSORX(PSOIBOLD,"PGW")=$P($G(^("IBQ")),"^",5) + I $G(PSORX(PSOIBOLD,"HNC"))'=0,$G(PSORX(PSOIBOLD,"HNC"))'=1,$P($G(^PSRX(PSOIBOLD,"IBQ")),"^",6)'="" S PSORX(PSOIBOLD,"HNC")=$P($G(^("IBQ")),"^",6) + I $G(PSORX(PSOIBOLD,"CV"))'=0,$G(PSORX(PSOIBOLD,"CV"))'=1,$P($G(^PSRX(PSOIBOLD,"IBQ")),"^",7)'="" S PSORX(PSOIBOLD,"CV")=$P($G(^("IBQ")),"^",7) + ; +SET2 ;for when patient status is exempt or SC>50 + I $TR($G(^PSRX(PSOIBOLD,"IBQ")),"^")="" S PSOOICD=$G(^PSRX(PSOIBOLD,"ICD",1,0)) D SET3:PSOOICD'="" + ; +ICD I $D(^PSRX(PSORENW("OIRXN"),"ICD",0)) D + . N JJ,ICD,II,FLD,RXN S RXN=PSOIBOLD + . S II=0 F S II=$O(^PSRX(PSORENW("OIRXN"),"ICD",II)) Q:II=""!(II'?1N.N) D + .. S ICD=^PSRX(PSORENW("OIRXN"),"ICD",II,0),FLD=$P(ICD,U) D ICD^PSONEWF + Q +SET3 ;for when patient status is exempt or SC>50 + N PSOPATST S PSOPATST=PSORX("PATIENT STATUS") + I PSORX("PATIENT STATUS")'?1N.N S PSOPATST="",PSOPATST=$O(^PS(53,"B",PSORX("PATIENT STATUS"),PSOPATST)) + F JJJ=2:1:8 I $P(PSOOICD,"^",JJJ)=0!($P(PSOOICD,"^",JJJ)=1) D + . I JJJ=2 S PSORX(PSOIBOLD,"VEH")=$P(PSOOICD,"^",JJJ) + . I JJJ=3 S PSORX(PSOIBOLD,"RAD")=$P(PSOOICD,"^",JJJ) + . I JJJ=4 D + .. S:PSOSCP<50 PSORX(PSOIBOLD,"SC")=$P(PSOOICD,"^",JJJ) + .. S:PSOSCP>49!($P($G(^PS(53,+$G(PSOPATST),0)),"^",7)=1) PSORX(PSOIBOLD,"SC>50")=$P(PSOOICD,"^",JJJ) + . I JJJ=5 S PSORX(PSOIBOLD,"PGW")=$P(PSOOICD,"^",JJJ) + . I JJJ=6 S PSORX(PSOIBOLD,"MST")=$P(PSOOICD,"^",JJJ) + . I JJJ=7 S PSORX(PSOIBOLD,"HNC")=$P(PSOOICD,"^",JJJ) + . I JJJ=8 S PSORX(PSOIBOLD,"CV")=$P(PSOOICD,"^",JJJ) + K JJJ,PSOOICD + Q +SETIBP ; + I $P($G(^PS(52.41,ORD,0)),"^",16)="SC"!($P($G(^(0)),"^",16)="NSC") S PSORX(PSOIBOLD,"SC")=$S($P($G(^(0)),"^",16)="SC":1,1:0) + I $G(PSORX(PSOIBOLD,"SC"))="" K PSORX(PSOIBOLD,"SC") + I '$$DT^PSOMLLDT Q + N PSOIBQFN S PSOIBQFN=$G(^PS(52.41,ORD,"IBQ")) + I $P(PSOIBQFN,"^",1)=0!($P(PSOIBQFN,"^",1)=1) S PSORX(PSOIBOLD,"MST")=$P(PSOIBQFN,"^") + I $P(PSOIBQFN,"^",2)=0!($P(PSOIBQFN,"^",2)=1) S PSORX(PSOIBOLD,"VEH")=$P(PSOIBQFN,"^",2) + I $P(PSOIBQFN,"^",3)=0!($P(PSOIBQFN,"^",3)=1) S PSORX(PSOIBOLD,"RAD")=$P(PSOIBQFN,"^",3) + I $P(PSOIBQFN,"^",4)=0!($P(PSOIBQFN,"^",4)=1) S PSORX(PSOIBOLD,"PGW")=$P(PSOIBQFN,"^",4) + I $P(PSOIBQFN,"^",5)=0!($P(PSOIBQFN,"^",5)=1) S PSORX(PSOIBOLD,"HNC")=$P(PSOIBQFN,"^",5) + I $P(PSOIBQFN,"^",6)=0!($P(PSOIBQFN,"^",6)=1) S PSORX(PSOIBOLD,"CV")=$P(PSOIBQFN,"^",6) + ;for when patient status is exempt, null IBQ node was set for exempts or SC>50 - data is in ICD node + I $TR($G(^PS(52.41,ORD,"IBQ")),"^")="" S PSOOICD=$G(^PS(52.41,ORD,"ICD",1,0)) D SET3:PSOOICD'="" + ; +ICD2 ; + I $D(^PS(52.41,ORD,"ICD",0)) D + . N JJ,ICD,II,FLD,RXN S RXN=ORD + . S II=0 F S II=$O(^PS(52.41,ORD,"ICD",II)) Q:II=""!(II'?1N.N) D + .. S ICD="",ICD=^PS(52.41,ORD,"ICD",II,0) + .. I $G(PSOSCP)>49&(II=1) S PSORX(PSOIBOLD,"SC>50")=$P(ICD,"^",4) + .. S JJ="" F JJ=1:1:8 S FLD=$P(ICD,U,JJ) D ICD^PSONEWF + ; + K PSOIBQFN + Q +KLIB ;Kill renewal IB array + I '$G(PSOIBOLD) Q + K PSORX(PSOIBOLD,"SC"),PSORX(PSOIBOLD,"MST"),PSORX(PSOIBOLD,"VEH"),PSORX(PSOIBOLD,"RAD"),PSORX(PSOIBOLD,"PGW"),PSORX(PSOIBOLD,"HNC"),PSORX(PSOIBOLD,"CV") + K PSOIBOLD + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORENW4.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORENW4.m index ade60e82..6cb36e9a 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORENW4.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORENW4.m @@ -1,120 +1,120 @@ -PSORENW4 ;BIR/SAB - rx speed renew ;03/06/95 - ;;7.0;OUTPATIENT PHARMACY;**11,23,27,32,37,64,46,75,71,100,130,117,152,148,264,225**;DEC 1997;Build 29 - ;External reference to ^PSDRUG supported by DBIA 221 - ;External reference to ^PS(50.7 supported by DBIA 2223 - ;External references L, UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789 - ;External reference to LK^ORX2 and ULK^ORX2 supported by DBIA 867 -SEL I $P(PSOPAR,"^",4)=0 S VALMSG="Renewing is NOT Allowed. Check Site Parameters!",VALMBCK="" Q - N VALMCNT I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!",VALMBCK="" Q - S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.") K PSOPLCK S VALMBCK="" Q - K PSOPLCK S X=PSODFN_";DPT(" D LK^ORX2 I 'Y S VALMSG="Another person is entering orders for this patient.",VALMBCK="" D UL^PSSLOCK(PSODFN) Q - K PRC,PHI,PSORX("EDIT"),PSOFDR,DIR,DUOUT,DIRUT,PSORNSPD S DIR("A")="Select Orders by number",DIR(0)="LO^1:"_PSOCNT D ^DIR I $D(DTOUT)!($D(DUOUT)) K DIR,DIRUT,DTOUT,DUOUT S VALMBCK="" G SELQ - K DIR,DIRUT,DTOUT,PSOOELSE,DTOUT I +Y S (SPEED,PSOOELSE,PSORNSPD)=1 D FULL^VALM1 S LST=Y D - .S (PSODIR("DFLG"),PSODIR("FIELD"))=0,PSOOPT=3,(PSORENW("DFLG"),PSORENW("QFLG"),PSORX("DFLG"))=0 D INIT Q:PSORENW("DFLG") - .F ORD=1:1:$L(LST,",") Q:$P(LST,",",ORD)']"" S ORN=$P(LST,",",ORD) D:+PSOLST(ORN)=52 PROCESS S PSORENW("DFLG")=0 - I '$G(PSOOELSE) S VALMBCK="" G SELQ - S VALMBCK="R" - D ^PSOBUILD,BLD^PSOORUT1 K DIR,DIRUT,DTOUT,DUOUT,LST,ORD,IEN,ORN,RPH,ST,REFL,REF,PSOACT,ORSV,PSORNW,PSORENW,PSONO,PSOCO,PSOCU,PSODIR,DSMSG,SPEED,PSORENW,PSOOELSE,PSOOPT,PSORX("FILL DATE"),PSORX("ISSUE DATE"),PSOID,PSOMSG,PSORX("DFLG"),PSOQTY -SELQ K PSORNSPD,RTE,DRET,PRC,PHI S X=PSODFN_";DPT(" D ULK^ORX2,UL^PSSLOCK(PSODFN),CLEAN^PSOVER1 - Q - ; -PROCESS ; Process one order at a time - I $$LMREJ^PSOREJU1($P(PSOLST(ORN),"^",2)) W $C(7),!!,"Rx "_$$GET1^DIQ(52,$P(PSOLST(ORN),"^",2),.01)_" has OPEN/UNRESOLVED 3rd Party Payer Rejects!" K DIR,PSOMSG D PAUSE^VALM1 Q - D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) W $C(7),!!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing Rx "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^")),! K DIR,PSOMSG D PAUSE^VALM1 Q - K RET,DRET,PRC,PHI S PSORENW("OIRXN")=$P(PSOLST(ORN),"^",2),PSOFROM="NEW" - S PSORENW("RX0")=^PSRX(PSORENW("OIRXN"),0),PSORENW("RX2")=^(2),PSORENW("RX3")=^(3),PSORENW("STA")=^("STA"),PSORENW("TN")=$G(^("TN")),SIGOK=$P($G(^PSRX(PSORENW("OIRXN"),"SIG")),"^",2) - I SIGOK F I=0:0 S I=$O(^PSRX(PSORENW("OIRXN"),"SIG1",I)) Q:'I S SIG(I)=^PSRX(PSORENW("OIRXN"),"SIG1",I,0) - S PSOIBOLD=$G(PSORENW("OIRXN")) D SETIB^PSORENW1 - I '$G(PSORENW("PROVIDER")) D - .S PSORENW("PROVIDER")=$P(PSORENW("RX0"),"^",4) - .S:$P(PSORENW("RX3"),"^",3) PSORENW("COSIGNING PROVIDER")=$P(PSORENW("RX3"),"^",3) - S PSORX("PROVIDER NAME")=$P($G(^VA(200,PSORENW("PROVIDER"),0)),"^") - I '$G(PSORENW("CLINIC")) S PSORENW("CLINIC")=$P(PSORENW("RX0"),"^",5) - S PSORENW("REMARKS")="RENEWED FROM RX # "_$P(PSORENW("RX0"),"^") - S PSORENW("SIG")=$P($G(^PSRX(PSORENW("OIRXN"),"SIG")),"^") - S PSORENW("PSODFN")=$P(PSORENW("RX0"),"^",2) - S PSORENW("ORX #")=$P(PSORENW("RX0"),"^") - S PSORENW("DRUG IEN")=$P(PSORENW("RX0"),"^",6) - S PSORENW("QTY")=$P(PSORENW("RX0"),"^",7) - ;S PSORENW("DAYS SUPPLY")=$P(PSORENW("RX0"),"^",8) - ;S PSORENW("# OF REFILLS")=$P(PSORENW("RX0"),"^",9) - S PSORENW("INS")=$S($G(PSORENW("ENT"))]"":PSORENW("ENT"),1:$G(^PSRX(PSORENW("OIRXN"),"INS"))) - S:$G(PSORENW("ENT"))']"" PSORENW("ENT")=0 - F I=0:0 S I=$O(^PSRX(PSORENW("OIRXN"),6,I)) Q:'I S DOSE=^PSRX(PSORENW("OIRXN"),6,I,0) D - .S PSORENW("ENT")=PSORENW("ENT")+1,PSORENW("DOSE",PSORENW("ENT"))=$P(DOSE,"^") - .S PSORENW("UNITS",PSORENW("ENT"))=$P(DOSE,"^",3),PSORENW("DOSE ORDERED",PSORENW("ENT"))=$P(DOSE,"^",2),PSORENW("ROUTE",PSORENW("ENT"))=$P(DOSE,"^",7) - .S PSORENW("SCHEDULE",PSORENW("ENT"))=$P(DOSE,"^",8),PSORENW("DURATION",PSORENW("ENT"))=$P(DOSE,"^",5),PSORENW("CONJUNCTION",PSORENW("ENT"))=$P(DOSE,"^",6) - .S PSORENW("NOUN",PSORENW("ENT"))=$P(DOSE,"^",4),PSORENW("VERB",PSORENW("ENT"))=$P(DOSE,"^",9) - .I $G(^PSRX(PSORENW("OIRXN"),6,I,1))]"" S PSORENW("ODOSE",PSORENW("ENT"))=^PSRX(PSORENW("OIRXN"),6,I,1) - .K DOSE - I $P($G(^PSDRUG(PSORENW("DRUG IEN"),"CLOZ1")),"^")="PSOCLO1" N PSON S PSON=0 D I PSON K PSON D POZ,KLIB^PSORENW1 D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) Q - . I '$L($P(^VA(200,PSORENW("PROVIDER"),"PS"),"^",2)),'$L($P(^VA(200,PSORENW("PROVIDER"),"PS"),"^",3)) D Q - . . S PSON=1 W $C(7),!!,"Only providers with DEA# or a VA# can write prescriptions for clozapine.",! - . I '$D(^XUSEC("YSCL AUTHORIZED",PSORENW("PROVIDER"))) D - . . S PSON=1 W $C(7),!!,"Provider must hold YSCL AUTHORIZED key to write prescriptions for clozapine.",! - I $G(PSORNW("MAIL/WINDOW"))]"" S PSORENW("MAIL/WINDOW")=PSORNW("MAIL/WINDOW") - I $O(^PSRX(PSORENW("OIRXN"),"PI",0)) D K T - .S PHI=^PSRX(PSORENW("OIRXN"),"PI",0),T=0 - .F S T=$O(^PSRX(PSORENW("OIRXN"),"PI",T)) Q:'T S PHI(T)=^PSRX(PSORENW("OIRXN"),"PI",T,0) - ;I $O(^PSRX(PSORENW("OIRXN"),"PRC",0)) D K T - ;.S PRC=^PSRX(PSORENW("OIRXN"),"PRC",0),T=0 - ;.F S T=$O(^PSRX(PSORENW("OIRXN"),"PRC",T)) Q:'T S PRC(T)=^PSRX(PSORENW("OIRXN"),"PRC",T,0) - W !!,"Now Renewing Rx # "_PSORENW("ORX #")_" Drug: "_$P($G(^PSDRUG(+$G(PSORENW("DRUG IEN")),0)),"^"),! - I '$P($G(^PSDRUG($P(PSORENW("RX0"),"^",6),2)),"^") D G:$G(PSORENW("DFLG")) PROCESSX - .I $P($G(^PSRX(PSORENW("OIRXN"),"OR1")),"^") S PSODRUG("OI")=$P(^PSRX(PSORENW("OIRXN"),"OR1"),"^"),PSODRUG("OIN")=$P(^PS(50.7,+^("OR1"),0),"^") Q - .W !!,"Cannot Renew!! No Pharmacy Orderable Item!" S VALMSG="Cannot Renew!! No Pharmacy Orderable Item!",PSORX("DFLG")=1 - D CHECK^PSORENW0 G:PSORENW("DFLG") PROCESSX - D FILDATE^PSORENW0 - D DRUG^PSORENW0 G:PSORENW("DFLG") PROCESSX - D RXN^PSORENW0 G:PSORENW("DFLG") PROCESSX - D STOP^PSORENW1 -DSPL K PSOEDT,PSOLM S PSDY=PSORENW("DAYS SUPPLY"),PSRF=PSORENW("# OF REFILLS") - F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)="" I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S PSODIR("CS")=1 - I $G(PSODIR("CS")) D - .S PSORENW("# OF REFILLS")=$S(PSDY<60:5,PSDY'<60&(PSDY'>89):2,PSDY=90:1,1:0) - .I PSORENW("# OF REFILLS")>PSRF S PSORENW("# OF REFILLS")=PSRF - D DSPLY^PSORENW3 G:PSORENW("DFLG") PROCESSX - D:$D(^XUSEC("PSORPH",DUZ))!('$P(PSOPAR,"^",2)) VER1^PSOORNE4(.PSORENW) G:PSORENW("DFLG")=1 PROCESSX - I $G(PSOQTY) D QTY^PSODIR1(.PSORENW) G:PSORENW("DFLG")=1 PROCESSX - D EN^PSORN52(.PSORENW) - D RNPSOSD^PSOUTIL - D CAN^PSORENW0,DCORD^PSONEW2 - S PSORENW("# OF REFILLS")=PSRF K PSDY,PSRF,PSODIR("CS"),DEA,PSORENW("ENT") - S BBRN="",BBRN1=$O(^PSRX("B",PSORENW("NRX #"),BBRN)) I $P($G(^PSRX(BBRN1,0)),"^",11)["W" S BINGCRT="Y",BINGRTE="W",BBFLG=1,BBRX(1)=$G(BBRX(1))_BBRN1_"," -PROCESSX I PSORENW("DFLG") D W:'$G(POERR) !,$C(7),"Rx NOT RENEWED. RENEWED RX DELETED",! S POERR("DFLG")=1 D CLEAN^PSOVER1 - .K PHI,PRC,PSODRUG,SIG,PSORXED,SIGOK - .K PSORENW("DOSE"),PSORENW("DURATION"),PSORENW("DRUG IEN"),PSORENW("ENT"),PSORENW("INS"),PSORENW("NOUN"),PSORENW("ROUTE"),PSORENW("SCHEDULE"),PSORENW("SIG"),PSORENW("VERB"),PSORENW("UNITS") - .D POZ - K PSORDLOK I PSORENW("DFLG") S PSORDLOK=1 - D:$G(PSORENW("OLD FILL DATE"))]"" SUSDATEK^PSOUTIL(.PSORENW) - K BBRN,BBRN1,PSODRUG,PSORX("PROVIDER NAME"),PSORX("CLINIC") - K PSOEDT,PSOLM S:$G(PSORENW("FROM"))="" (PSORENW("DFLG"),PSORENW("QFLG"))=0 - I $G(PSORDLOK) D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) - D KLIB^PSORENW1 - K PSORDLOK - S RXN=$O(^TMP("PSORXN",$J,0)) I RXN D - .S RXN1=^TMP("PSORXN",$J,RXN) D EN^PSOHLSN1(RXN,$P(RXN1,"^"),$P(RXN1,"^",2),"",$P(RXN1,"^",3)) - .I $P(^PSRX(RXN,"STA"),"^")=5 D EN^PSOHLSN1(RXN,"SC","ZS",$P(RXN1,"^",4)) - K RXN,RXN1,^TMP("PSORXN",$J) - Q -INIT ; - D ASK Q:PSORENW("DFLG") - D NOORE^PSONEW(.PSORENW) Q:PSORENW("DFLG") - Q -ASK ;upfront questions - W !! D ISSDT^PSODIR2(.PSORENW) Q:PSORENW("DFLG") S PSORENW("ISSUE DATE")=PSOID - D FILLDT^PSODIR2(.PSORENW) K PSONEW("DAYS SUPPLY"),PSONEW("# OF REFILLS") Q:PSORENW("DFLG") - S PSORNW("FILL DATE")=PSORENW("FILL DATE") - D MW^PSODIR2(.PSORENW) Q:PSORENW("DFLG") - D PTSTAT^PSODIR1(.PSORENW) Q:PSORENW("DFLG") - D DAYS^PSODIR1(.PSORENW) Q:PSORENW("DFLG") - S PSODRUG("DEA")=0 D REFILL^PSODIR1(.PSORENW) K PSODRUG("DEA") Q:PSORENW("DFLG") - K DIR,DIRUT S DIR(0)="Y",DIR("B")="No",DIR("A")="Do you want to edit Renewed Rx(s) QTY " D ^DIR I $D(DIRUT) S PSORENW("DFLG")=1 K DIR,DIRUT Q - S PSOQTY=Y K DIR,DIRUT - D CLINIC^PSODIR2(.PSORENW) Q:PSORENW("DFLG") - D PROV^PSODIR(.PSORENW) S:PSORENW("DFLG") PSORENW("DFLG")=0 - Q - ; -POZ ; - K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR,DIRUT,DTOUT - Q +PSORENW4 ;BIR/SAB - rx speed renew ;03/06/95 + ;;7.0;OUTPATIENT PHARMACY;**11,23,27,32,37,64,46,75,71,100,130,117,152,148,264**;DEC 1997;Build 19 + ;External reference to ^PSDRUG supported by DBIA 221 + ;External reference to ^PS(50.7 supported by DBIA 2223 + ;External references L, UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789 + ;External reference to LK^ORX2 and ULK^ORX2 supported by DBIA 867 +SEL I $P(PSOPAR,"^",4)=0 S VALMSG="Renewing is NOT Allowed. Check Site Parameters!",VALMBCK="" Q + N VALMCNT I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!",VALMBCK="" Q + S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.") K PSOPLCK S VALMBCK="" Q + K PSOPLCK S X=PSODFN_";DPT(" D LK^ORX2 I 'Y S VALMSG="Another person is entering orders for this patient.",VALMBCK="" D UL^PSSLOCK(PSODFN) Q + K PRC,PHI,PSORX("EDIT"),PSOFDR,DIR,DUOUT,DIRUT,PSORNSPD S DIR("A")="Select Orders by number",DIR(0)="LO^1:"_PSOCNT D ^DIR I $D(DTOUT)!($D(DUOUT)) K DIR,DIRUT,DTOUT,DUOUT S VALMBCK="" G SELQ + K DIR,DIRUT,DTOUT,PSOOELSE,DTOUT I +Y S (SPEED,PSOOELSE,PSORNSPD)=1 D FULL^VALM1 S LST=Y D + .S (PSODIR("DFLG"),PSODIR("FIELD"))=0,PSOOPT=3,(PSORENW("DFLG"),PSORENW("QFLG"),PSORX("DFLG"))=0 D INIT Q:PSORENW("DFLG") + .F ORD=1:1:$L(LST,",") Q:$P(LST,",",ORD)']"" S ORN=$P(LST,",",ORD) D:+PSOLST(ORN)=52 PROCESS S PSORENW("DFLG")=0 + I '$G(PSOOELSE) S VALMBCK="" G SELQ + S VALMBCK="R" + D ^PSOBUILD,BLD^PSOORUT1 K DIR,DIRUT,DTOUT,DUOUT,LST,ORD,IEN,ORN,RPH,ST,REFL,REF,PSOACT,ORSV,PSORNW,PSORENW,PSONO,PSOCO,PSOCU,PSODIR,DSMSG,SPEED,PSORENW,PSOOELSE,PSOOPT,PSORX("FILL DATE"),PSORX("ISSUE DATE"),PSOID,PSOMSG,PSORX("DFLG"),PSOQTY +SELQ K PSORNSPD,RTE,DRET,PRC,PHI S X=PSODFN_";DPT(" D ULK^ORX2,UL^PSSLOCK(PSODFN),CLEAN^PSOVER1 + Q + ; +PROCESS ; Process one order at a time + I $$LMREJ^PSOREJU1($P(PSOLST(ORN),"^",2)) W $C(7),!!,"Rx "_$$GET1^DIQ(52,$P(PSOLST(ORN),"^",2),.01)_" has OPEN/UNRESOLVED 3rd Party Payer Rejects!" K DIR,PSOMSG D PAUSE^VALM1 Q + D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) W $C(7),!!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing Rx "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^")),! K DIR,PSOMSG D PAUSE^VALM1 Q + K RET,DRET,PRC,PHI S PSORENW("OIRXN")=$P(PSOLST(ORN),"^",2),PSOFROM="NEW" + S PSORENW("RX0")=^PSRX(PSORENW("OIRXN"),0),PSORENW("RX2")=^(2),PSORENW("RX3")=^(3),PSORENW("STA")=^("STA"),PSORENW("TN")=$G(^("TN")),SIGOK=$P($G(^PSRX(PSORENW("OIRXN"),"SIG")),"^",2) + I SIGOK F I=0:0 S I=$O(^PSRX(PSORENW("OIRXN"),"SIG1",I)) Q:'I S SIG(I)=^PSRX(PSORENW("OIRXN"),"SIG1",I,0) + S PSOIBOLD=$G(PSORENW("OIRXN")) D SETIB^PSORENW1 + I '$G(PSORENW("PROVIDER")) D + .S PSORENW("PROVIDER")=$P(PSORENW("RX0"),"^",4) + .S:$P(PSORENW("RX3"),"^",3) PSORENW("COSIGNING PROVIDER")=$P(PSORENW("RX3"),"^",3) + S PSORX("PROVIDER NAME")=$P($G(^VA(200,PSORENW("PROVIDER"),0)),"^") + I '$G(PSORENW("CLINIC")) S PSORENW("CLINIC")=$P(PSORENW("RX0"),"^",5) + S PSORENW("REMARKS")="RENEWED FROM RX # "_$P(PSORENW("RX0"),"^") + S PSORENW("SIG")=$P($G(^PSRX(PSORENW("OIRXN"),"SIG")),"^") + S PSORENW("PSODFN")=$P(PSORENW("RX0"),"^",2) + S PSORENW("ORX #")=$P(PSORENW("RX0"),"^") + S PSORENW("DRUG IEN")=$P(PSORENW("RX0"),"^",6) + S PSORENW("QTY")=$P(PSORENW("RX0"),"^",7) + ;S PSORENW("DAYS SUPPLY")=$P(PSORENW("RX0"),"^",8) + ;S PSORENW("# OF REFILLS")=$P(PSORENW("RX0"),"^",9) + S PSORENW("INS")=$S($G(PSORENW("ENT"))]"":PSORENW("ENT"),1:$G(^PSRX(PSORENW("OIRXN"),"INS"))) + S:$G(PSORENW("ENT"))']"" PSORENW("ENT")=0 + F I=0:0 S I=$O(^PSRX(PSORENW("OIRXN"),6,I)) Q:'I S DOSE=^PSRX(PSORENW("OIRXN"),6,I,0) D + .S PSORENW("ENT")=PSORENW("ENT")+1,PSORENW("DOSE",PSORENW("ENT"))=$P(DOSE,"^") + .S PSORENW("UNITS",PSORENW("ENT"))=$P(DOSE,"^",3),PSORENW("DOSE ORDERED",PSORENW("ENT"))=$P(DOSE,"^",2),PSORENW("ROUTE",PSORENW("ENT"))=$P(DOSE,"^",7) + .S PSORENW("SCHEDULE",PSORENW("ENT"))=$P(DOSE,"^",8),PSORENW("DURATION",PSORENW("ENT"))=$P(DOSE,"^",5),PSORENW("CONJUNCTION",PSORENW("ENT"))=$P(DOSE,"^",6) + .S PSORENW("NOUN",PSORENW("ENT"))=$P(DOSE,"^",4),PSORENW("VERB",PSORENW("ENT"))=$P(DOSE,"^",9) + .I $G(^PSRX(PSORENW("OIRXN"),6,I,1))]"" S PSORENW("ODOSE",PSORENW("ENT"))=^PSRX(PSORENW("OIRXN"),6,I,1) + .K DOSE + I $P($G(^PSDRUG(PSORENW("DRUG IEN"),"CLOZ1")),"^")="PSOCLO1" N PSON S PSON=0 D I PSON K PSON D POZ,KLIB^PSORENW1 D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) Q + . I '$L($P(^VA(200,PSORENW("PROVIDER"),"PS"),"^",2)),'$L($P(^VA(200,PSORENW("PROVIDER"),"PS"),"^",3)) D Q + . . S PSON=1 W $C(7),!!,"Only providers with DEA# or a VA# can write prescriptions for clozapine.",! + . I '$D(^XUSEC("YSCL AUTHORIZED",PSORENW("PROVIDER"))) D + . . S PSON=1 W $C(7),!!,"Provider must hold YSCL AUTHORIZED key to write prescriptions for clozapine.",! + I $G(PSORNW("MAIL/WINDOW"))]"" S PSORENW("MAIL/WINDOW")=PSORNW("MAIL/WINDOW") + I $O(^PSRX(PSORENW("OIRXN"),"PI",0)) D K T + .S PHI=^PSRX(PSORENW("OIRXN"),"PI",0),T=0 + .F S T=$O(^PSRX(PSORENW("OIRXN"),"PI",T)) Q:'T S PHI(T)=^PSRX(PSORENW("OIRXN"),"PI",T,0) + I $O(^PSRX(PSORENW("OIRXN"),"PRC",0)) D K T + .S PRC=^PSRX(PSORENW("OIRXN"),"PRC",0),T=0 + .F S T=$O(^PSRX(PSORENW("OIRXN"),"PRC",T)) Q:'T S PRC(T)=^PSRX(PSORENW("OIRXN"),"PRC",T,0) + W !!,"Now Renewing Rx # "_PSORENW("ORX #")_" Drug: "_$P($G(^PSDRUG(+$G(PSORENW("DRUG IEN")),0)),"^"),! + I '$P($G(^PSDRUG($P(PSORENW("RX0"),"^",6),2)),"^") D G:$G(PSORENW("DFLG")) PROCESSX + .I $P($G(^PSRX(PSORENW("OIRXN"),"OR1")),"^") S PSODRUG("OI")=$P(^PSRX(PSORENW("OIRXN"),"OR1"),"^"),PSODRUG("OIN")=$P(^PS(50.7,+^("OR1"),0),"^") Q + .W !!,"Cannot Renew!! No Pharmacy Orderable Item!" S VALMSG="Cannot Renew!! No Pharmacy Orderable Item!",PSORX("DFLG")=1 + D CHECK^PSORENW0 G:PSORENW("DFLG") PROCESSX + D FILDATE^PSORENW0 + D DRUG^PSORENW0 G:PSORENW("DFLG") PROCESSX + D RXN^PSORENW0 G:PSORENW("DFLG") PROCESSX + D STOP^PSORENW1 +DSPL K PSOEDT,PSOLM S PSDY=PSORENW("DAYS SUPPLY"),PSRF=PSORENW("# OF REFILLS") + F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)="" I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S PSODIR("CS")=1 + I $G(PSODIR("CS")) D + .S PSORENW("# OF REFILLS")=$S(PSDY<60:5,PSDY'<60&(PSDY'>89):2,PSDY=90:1,1:0) + .I PSORENW("# OF REFILLS")>PSRF S PSORENW("# OF REFILLS")=PSRF + D DSPLY^PSORENW3 G:PSORENW("DFLG") PROCESSX + D:$D(^XUSEC("PSORPH",DUZ))!('$P(PSOPAR,"^",2)) VER1^PSOORNE4(.PSORENW) G:PSORENW("DFLG")=1 PROCESSX + I $G(PSOQTY) D QTY^PSODIR1(.PSORENW) G:PSORENW("DFLG")=1 PROCESSX + D EN^PSORN52(.PSORENW) + D RNPSOSD^PSOUTIL + D CAN^PSORENW0,DCORD^PSONEW2 + S PSORENW("# OF REFILLS")=PSRF K PSDY,PSRF,PSODIR("CS"),DEA,PSORENW("ENT") + S BBRN="",BBRN1=$O(^PSRX("B",PSORENW("NRX #"),BBRN)) I $P($G(^PSRX(BBRN1,0)),"^",11)["W" S BINGCRT="Y",BINGRTE="W",BBFLG=1,BBRX(1)=$G(BBRX(1))_BBRN1_"," +PROCESSX I PSORENW("DFLG") D W:'$G(POERR) !,$C(7),"Rx NOT RENEWED. RENEWED RX DELETED",! S POERR("DFLG")=1 D CLEAN^PSOVER1 + .K PHI,PRC,PSODRUG,SIG,PSORXED,SIGOK + .K PSORENW("DOSE"),PSORENW("DURATION"),PSORENW("DRUG IEN"),PSORENW("ENT"),PSORENW("INS"),PSORENW("NOUN"),PSORENW("ROUTE"),PSORENW("SCHEDULE"),PSORENW("SIG"),PSORENW("VERB"),PSORENW("UNITS") + .D POZ + K PSORDLOK I PSORENW("DFLG") S PSORDLOK=1 + D:$G(PSORENW("OLD FILL DATE"))]"" SUSDATEK^PSOUTIL(.PSORENW) + K BBRN,BBRN1,PSODRUG,PSORX("PROVIDER NAME"),PSORX("CLINIC") + K PSOEDT,PSOLM S:$G(PSORENW("FROM"))="" (PSORENW("DFLG"),PSORENW("QFLG"))=0 + I $G(PSORDLOK) D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) + D KLIB^PSORENW1 + K PSORDLOK + S RXN=$O(^TMP("PSORXN",$J,0)) I RXN D + .S RXN1=^TMP("PSORXN",$J,RXN) D EN^PSOHLSN1(RXN,$P(RXN1,"^"),$P(RXN1,"^",2),"",$P(RXN1,"^",3)) + .I $P(^PSRX(RXN,"STA"),"^")=5 D EN^PSOHLSN1(RXN,"SC","ZS",$P(RXN1,"^",4)) + K RXN,RXN1,^TMP("PSORXN",$J) + Q +INIT ; + D ASK Q:PSORENW("DFLG") + D NOORE^PSONEW(.PSORENW) Q:PSORENW("DFLG") + Q +ASK ;upfront questions + W !! D ISSDT^PSODIR2(.PSORENW) Q:PSORENW("DFLG") S PSORENW("ISSUE DATE")=PSOID + D FILLDT^PSODIR2(.PSORENW) K PSONEW("DAYS SUPPLY"),PSONEW("# OF REFILLS") Q:PSORENW("DFLG") + S PSORNW("FILL DATE")=PSORENW("FILL DATE") + D MW^PSODIR2(.PSORENW) Q:PSORENW("DFLG") + D PTSTAT^PSODIR1(.PSORENW) Q:PSORENW("DFLG") + D DAYS^PSODIR1(.PSORENW) Q:PSORENW("DFLG") + S PSODRUG("DEA")=0 D REFILL^PSODIR1(.PSORENW) K PSODRUG("DEA") Q:PSORENW("DFLG") + K DIR,DIRUT S DIR(0)="Y",DIR("B")="No",DIR("A")="Do you want to edit Renewed Rx(s) QTY " D ^DIR I $D(DIRUT) S PSORENW("DFLG")=1 K DIR,DIRUT Q + S PSOQTY=Y K DIR,DIRUT + D CLINIC^PSODIR2(.PSORENW) Q:PSORENW("DFLG") + D PROV^PSODIR(.PSORENW) S:PSORENW("DFLG") PSORENW("DFLG")=0 + Q + ; +POZ ; + K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR,DIRUT,DTOUT + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORN52.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORN52.m index c1ce1510..41837f21 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORN52.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORN52.m @@ -1,119 +1,133 @@ -PSORN52 ;BIR/DSD - files renewal entries in prescription file ;08/09/93 - ;;7.0;OUTPATIENT PHARMACY;**1,11,27,37,46,79,71,100,117,157,143,219,148,239,201,225**;DEC 1997;Build 29 - ;Ext ref to ^PS(55 sup by DBIA 2228 - ;Ext ref to PSOUL^PSSLOCK sup by DBIA 2789 - ;Ext ref to ^VA(200 sup by DBIA 10060 - ;Ext ref to SWSTAT^IBBAPI sup by DBIA 4663 -EN(PSOX) ;EP -START ; - D:$D(XRTL) T0^%ZOSV ; Start RT Mon - N PSOIBHLD,PSOSCOTH,PSOSCOTX S (PSOSCOTH,PSOSCOTX)=0 S PSOIBHLD="" I $G(PSOFDR),$G(ORD) D - .S PSOIBHLD=$S($P($G(^PS(52.41,ORD,0)),"^",16)="SC":1,$P($G(^(0)),"^",16)="NSC":0,1:"") - .I '$$DT^PSOMLLDT Q - .N PSOIBHLX S PSOIBHLX=$G(^PS(52.41,ORD,"IBQ")) - .S PSOIBHLD=PSOIBHLD_"^"_$S($P(PSOIBHLX,"^")=1:1,$P(PSOIBHLX,"^")=0:0,1:"")_"^"_$S($P(PSOIBHLX,"^",2)=1:1,$P(PSOIBHLX,"^",2)=0:0,1:"")_"^"_$S($P(PSOIBHLX,"^",3)=1:1,$P(PSOIBHLX,"^",3)=0:0,1:"") - .S PSOIBHLD=PSOIBHLD_"^"_$S($P(PSOIBHLX,"^",4)=1:1,$P(PSOIBHLX,"^",4)=0:0,1:"")_"^"_$S($P(PSOIBHLX,"^",5)=1:1,$P(PSOIBHLX,"^",5)=0:0,1:"")_"^"_$S($P(PSOIBHLX,"^",6)=1:1,$P(PSOIBHLX,"^",6)=0:0,1:"") - .S PSOIBHLD=PSOIBHLD_"^"_$S($P(PSOIBHLX,"^",7)=1:1,$P(PSOIBHLX,"^",7)=0:0,1:"") - .I $P(PSOIBHLX,"^")=1!($P(PSOIBHLX,"^",2)=1)!($P(PSOIBHLX,"^",3)=1)!($P(PSOIBHLX,"^",4)=1)!($P(PSOIBHLX,"^",5)=1)!($P(PSOIBHLX,"^",6)=1)!($P(PSOIBHLX,"^",7)=1) S PSOSCOTH=1 - I $G(PSOSCOTH)!($G(PSORX("SC"))="SC")!($G(PSORX("SC"))="NSC") S PSOSCOTX=1 - S PSOANSQ("SC>50")="" D SCP^PSORN52D - I $G(PSOFDR),$G(ORD) I $D(^PS(52.41,ORD,"ICD")) S FILE=52.41 D GET^PSORN52D - ;Set ans to renew from Rx, only if no ans from Pend file - I $G(PSORENW("OIRXN")) D - .N PSOLDIBQ S PSOLDIBQ=$G(^PSRX(PSORENW("OIRXN"),"IBQ")) - .I $P(PSOIBHLD,"^")="" D - ..I $P($G(^PSRX(PSORENW("OIRXN"),"IB")),"^")=2 S $P(PSOIBHLD,"^")=0 - .I '$$DT^PSOMLLDT Q - .I PSOLDIBQ="" Q - .D IBHLD^PSORN52A - D INIT G:PSORN52("QFLG") END D FILE^PSORN52A - S:$D(XRT0) XRTN=$T(+0) D:$D(XRT0) T1^%ZOSV ; Stop RT Mon - K PSOANSQ,PSOANSQD,PSONEWFF - I $G(PSOIBHLD)'="" D - .;Set answers based on Pend Renew, prior to Phar call - .Q:'$G(PSOX("IRXN")) - .I $P(PSOIBHLD,"^")=1!($P(PSOIBHLD,"^")=0) S PSOANSQ("SC")=$P(PSOIBHLD,"^") - .I '$$DT^PSOMLLDT Q - .I $P(PSOIBHLD,"^",2)=1!($P(PSOIBHLD,"^",2)=0) S PSOANSQ(PSOX("IRXN"),"MST")=$P(PSOIBHLD,"^",2) - .I $P(PSOIBHLD,"^",3)=1!($P(PSOIBHLD,"^",3)=0) S PSOANSQ(PSOX("IRXN"),"VEH")=$P(PSOIBHLD,"^",3) - .I $P(PSOIBHLD,"^",4)=1!($P(PSOIBHLD,"^",4)=0) S PSOANSQ(PSOX("IRXN"),"RAD")=$P(PSOIBHLD,"^",4) - .I $P(PSOIBHLD,"^",5)=1!($P(PSOIBHLD,"^",5)=0) S PSOANSQ(PSOX("IRXN"),"PGW")=$P(PSOIBHLD,"^",5) - .I $P(PSOIBHLD,"^",6)=1!($P(PSOIBHLD,"^",6)=0) S PSOANSQ(PSOX("IRXN"),"HNC")=$P(PSOIBHLD,"^",6) - .I $P(PSOIBHLD,"^",7)=1!($P(PSOIBHLD,"^",7)=0) S PSOANSQ(PSOX("IRXN"),"CV")=$P(PSOIBHLD,"^",7) - .I $P(PSOIBHLD,"^",8)=1!($P(PSOIBHLD,"^",8)=0) S PSOANSQ(PSOX("IRXN"),"SHAD")=$P(PSOIBHLD,"^",8) - K PSOIBHLD - I '$G(PSOFDR) I $G(PSORENW("OIRXN")) S FILE=52 D GET^PSORN52D - S PSONEW("NEWCOPAY")="" - I (PSOSCP<50&('$P($G(^PS(53,+$P(^PSRX(PSOX("IRXN"),0),"^",3),0)),"^",7))),$G(DUZ("AG"))="V" S PSOFLAG=0 D COPAY^PSOCPB - ;I PSOSCP>49!($P($G(^PS(53,+$P(^PSRX(PSOX("IRXN"),0),"^",3),0)),"^",7)=1) S PSOFLAG=0 D SC^PSOMLLD2 - I PSOSCA&(PSOSCP>49)!((PSOSCA!(PSOBILL=2))&($P($G(^PS(53,+$P(^PSRX(PSOX("IRXN"),0),"^",3),0)),"^",7)=1)) S PSOFLAG=0 D SC^PSOMLLD2 - I $$DT^PSOMLLDT D - .I $D(PSOIBQS(PSODFN,"CV")) D MESS D CV^PSOMLLDT I $G(PSOANSQ(PSOX("IRXN"),"CV")) K PSONEW("NEWCOPAY") - .I $D(PSOIBQS(PSODFN,"VEH")) D MESS D VEH^PSOMLLDT I $G(PSOANSQ(PSOX("IRXN"),"VEH")) K PSONEW("NEWCOPAY") - .I $D(PSOIBQS(PSODFN,"RAD")) D MESS D RAD^PSOMLLDT I $G(PSOANSQ(PSOX("IRXN"),"RAD")) K PSONEW("NEWCOPAY") - .I $D(PSOIBQS(PSODFN,"PGW")) D MESS D PGW^PSOMLLDT I $G(PSOANSQ(PSOX("IRXN"),"PGW")) K PSONEW("NEWCOPAY") - .I $D(PSOIBQS(PSODFN,"SHAD")) D MESS D SHAD^PSOMLLD2 I $G(PSOANSQ(PSOX("IRXN"),"SHAD")) K PSONEW("NEWCOPAY") - .I $D(PSOIBQS(PSODFN,"MST")) D MESS D MST^PSOMLLDT I $G(PSOANSQ(PSOX("IRXN"),"MST")) K PSONEW("NEWCOPAY") - .I $D(PSOIBQS(PSODFN,"HNC")) D MESS D HNC^PSOMLLDT I $G(PSOANSQ(PSOX("IRXN"),"HNC")) K PSONEW("NEWCOPAY") - K PSOSCOTH,PSOSCOTX - I $G(PSONEW("NEWCOPAY")) S ^PSRX(PSOX("IRXN"),"IB")=PSONEW("NEWCOPAY") - ; - D FINISH,ACP^PSOUTIL - ; - N PSOSCFLD S PSOSCFLD=$S(PSOSCP'="":$G(PSOANSQ("SC")),1:"")_"^"_$G(PSOANSQ(PSOX("IRXN"),"MST"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"VEH"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"RAD")) - S PSOSCFLD=PSOSCFLD_"^"_$G(PSOANSQ(PSOX("IRXN"),"PGW"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"HNC"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"CV"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"SHAD")) - I PSOSCP<50&($TR(PSOSCFLD,"^")'="")&('$P($G(^PS(53,+$P(^PSRX(PSOX("IRXN"),0),"^",3),0)),"^",7)) S ^PSRX(PSOX("IRXN"),"IBQ")=PSOSCFLD K PSOSCFLD - ; - D FILE2^PSORN52D - D:$$SWSTAT^IBBAPI() GACT^PSOPFSU0(PSOX("IRXN"),0) - K PSONEW("NEWCOPAY"),PSOANSQ -END D EOJ - Q -INIT S PSORN52("QFLG")=0 S:'$D(PSOX("DAYS SUPPLY")) PSOX("DAYS SUPPLY")=$P(PSOX("RX0"),"^",8) - S:'$D(PSOX("# OF REFILLS")) PSOX("# OF REFILLS")=$P(PSOX("RX0"),"^",9) S:'$D(PSOX("ISSUE DATE")) PSOX("ISSUE DATE")=DT - D INIT^PSON52 K PSON52 - Q - ; -FINISH ; - G:PSOX("STATUS")=4 FINISHP - I $D(PSORX("VERIFY")) D G FINISHX - .K DIC,DLAYGO,DINUM,DIADD,X,DD,DO S DIC="^PS(52.4,",DLAYGO=52.4,DINUM=PSOX("IRXN"),DIC(0)="ML" - .S X=PSOX("IRXN") D FILE^DICN K DD,DO,DIC,DLAYGO,DINUM,X - .S ^PS(52.4,PSOX("IRXN"),0)=PSOX("IRXN")_"^"_$P(PSOX("NRX0"),"^",2)_"^"_DUZ_"^"_$G(PSOX("OIRXN"))_"^"_$E(PSOX("LOGIN DATE"),1,7)_"^"_PSOX("IRXN")_"^"_PSOX("STOP DATE") - .K DIK,DA S DIK="^PS(52.4,",DA=PSOX("IRXN") D IX^DIK K DIK,DA - ; - I $G(PSOX("QS"))="S",$G(PSOBARCD) S DA=PSOX("IRXN"),RXFL(PSOX("IRXN"))=0 D SUS^PSORXL K DA G FINISHX - ; - I PSOX("FILL DATE")>DT,$P(PSOPAR,"^",6) S DA=PSOX("IRXN"),RXFL(PSOX("IRXN"))=0 D SUS^PSORXL K DA G FINISHX - ; - ; - Submitting Rx to ECME for 3rd Party Billing - N ACTION - I $$SUBMIT^PSOBPSUT(PSOX("IRXN"),0) D I ACTION="Q"!(ACTION="^") Q - . S ACTION="" D ECMESND^PSOBPSU1(PSOX("IRXN"),0,PSOX("FILL DATE"),"RN") - . I $$FIND^PSOREJUT(PSOX("IRXN"),0) D - . . S ACTION=$$HDLG^PSOREJU1(PSOX("IRXN"),0,"79,88","RN","IOQ","I") - ; - I $G(PSOX("QS"))="Q",$G(PSOBARCD) D G FINISHX - . N PSOFROM S PSOFROM="BATCH" I $G(PPL),$L(PPL_PSOX("IRXN")_",")>240 D TRI^PSOBBC D Q^PSORXL K PPL,RXFL - .S RXFL(PSOX("IRXN"))=0 - . I $G(PPL) S PPL=PPL_PSOX("IRXN")_"," - . E S PPL=PSOX("IRXN")_"," - . Q -FINISHP I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=PSOX("IRXN")_",",RXFL(PSOX("IRXN"))=0 G FINISHX - F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1 S PSOX2=PSOX1 - I $L(PSORX("PSOL",PSOX2))+$L(PSOX("IRXN"))<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_PSOX("IRXN")_"," - E S PSORX("PSOL",PSOX2+1)=PSOX("IRXN")_"," - S RXFL(PSOX("IRXN"))=0 -FINISHX ; - ;call to build bingo board Rx array - S:'$G(PSORX("MAIL/WINDOW")) PSORX("MAIL/WINDOW")=$P(PSORENW("NRX0"),"^",11) - I $G(PSORX("MAIL/WINDOW"))["W" S BINGCRT=1,BINGRTE="W",BBFLG=1 D BBRX^PSORN52C - K PSOX1,PSOX2 - Q -EOJ ; - L -^PSRX("B",PSOX("IRXN")) K PSORN52,PSOX("INS"),PSORENW("INS"),PSORXED("INS"),PSONEW("ENT"),PSORXED("ENT"),OLENT,PSOIBHLD,PSOX("SINS"),PSORENW("SINS"),PSORXED("SINS"),FILE - D PSOUL^PSSLOCK(PSOX("IRXN")) D PSOUL^PSSLOCK(PSOX("OIRXN")) - Q -MESS ; - I $G(PSOSCOTX)=1&(PSOSCP<50) W:$G(PSODRUG("DEA"))'["S"&($G(PSODRUG("DEA"))'["I") !!,"This Rx has been flagged by the provider as: "_$S($G(PSOSCOTH):"NO COPAY",$G(PSORX("SC"))="SC":"NO COPAY",1:"COPAY"),! S PSOSCOTX=2 - Q +PSORN52 ;BIR/DSD - files renewal entries in prescription file ; 3/11/07 4:42pm + ;;7.0;OUTPATIENT PHARMACY;**1,11,27,37,46,79,71,100,117,157,143,219,148,239,201,208**;DEC 1997;Build 39 + ; 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 + ;Ext ref to ^PS(55 sup by DBIA 2228 + ;Ext ref to PSOUL^PSSLOCK sup by DBIA 2789 + ;Ext ref to ^VA(200 sup by DBIA 10060 + ;Ext ref to SWSTAT^IBBAPI sup by DBIA 4663 +EN(PSOX) ;EP +START ; + D:$D(XRTL) T0^%ZOSV ; Start RT Mon + N PSOIBHLD,PSOSCOTH,PSOSCOTX S (PSOSCOTH,PSOSCOTX)=0 S PSOIBHLD="" I $G(PSOFDR),$G(ORD) D + .S PSOIBHLD=$S($P($G(^PS(52.41,ORD,0)),"^",16)="SC":1,$P($G(^(0)),"^",16)="NSC":0,1:"") + .I '$$DT^PSOMLLDT Q + .N PSOIBHLX S PSOIBHLX=$G(^PS(52.41,ORD,"IBQ")) + .S PSOIBHLD=PSOIBHLD_"^"_$S($P(PSOIBHLX,"^")=1:1,$P(PSOIBHLX,"^")=0:0,1:"")_"^"_$S($P(PSOIBHLX,"^",2)=1:1,$P(PSOIBHLX,"^",2)=0:0,1:"")_"^"_$S($P(PSOIBHLX,"^",3)=1:1,$P(PSOIBHLX,"^",3)=0:0,1:"") + .S PSOIBHLD=PSOIBHLD_"^"_$S($P(PSOIBHLX,"^",4)=1:1,$P(PSOIBHLX,"^",4)=0:0,1:"")_"^"_$S($P(PSOIBHLX,"^",5)=1:1,$P(PSOIBHLX,"^",5)=0:0,1:"")_"^"_$S($P(PSOIBHLX,"^",6)=1:1,$P(PSOIBHLX,"^",6)=0:0,1:"") + .I $P(PSOIBHLX,"^")=1!($P(PSOIBHLX,"^",2)=1)!($P(PSOIBHLX,"^",3)=1)!($P(PSOIBHLX,"^",4)=1)!($P(PSOIBHLX,"^",5)=1)!($P(PSOIBHLX,"^",6)=1) S PSOSCOTH=1 + I $G(PSOSCOTH)!($G(PSORX("SC"))="SC")!($G(PSORX("SC"))="NSC") S PSOSCOTX=1 + S PSOANSQ("SC>50")="" D SCP^PSORN52D + I $G(PSOFDR),$G(ORD) I $D(^PS(52.41,ORD,"ICD")) S FILE=52.41 D GET^PSORN52D + ;Set ans to renew from Rx, only if no ans from Pend file + I $G(PSORENW("OIRXN")) D + .N PSOLDIBQ S PSOLDIBQ=$G(^PSRX(PSORENW("OIRXN"),"IBQ")) + .I $P(PSOIBHLD,"^")="" D + ..I $P($G(^PSRX(PSORENW("OIRXN"),"IB")),"^")=2 S $P(PSOIBHLD,"^")=0 + .I '$$DT^PSOMLLDT Q + .I PSOLDIBQ="" Q + .D IBHLD^PSORN52A + D INIT G:PSORN52("QFLG") END D FILE^PSORN52A + S:$D(XRT0) XRTN=$T(+0) D:$D(XRT0) T1^%ZOSV ; Stop RT Mon + K PSOANSQ,PSOANSQD,PSONEWFF + I $G(PSOIBHLD)'="" D + .;Set answers based on Pend Renew, prior to Phar call + .Q:'$G(PSOX("IRXN")) + .I $P(PSOIBHLD,"^")=1!($P(PSOIBHLD,"^")=0) S PSOANSQ("SC")=$P(PSOIBHLD,"^") + .I '$$DT^PSOMLLDT Q + .I $P(PSOIBHLD,"^",2)=1!($P(PSOIBHLD,"^",2)=0) S PSOANSQ(PSOX("IRXN"),"MST")=$P(PSOIBHLD,"^",2) + .I $P(PSOIBHLD,"^",3)=1!($P(PSOIBHLD,"^",3)=0) S PSOANSQ(PSOX("IRXN"),"VEH")=$P(PSOIBHLD,"^",3) + .I $P(PSOIBHLD,"^",4)=1!($P(PSOIBHLD,"^",4)=0) S PSOANSQ(PSOX("IRXN"),"RAD")=$P(PSOIBHLD,"^",4) + .I $P(PSOIBHLD,"^",5)=1!($P(PSOIBHLD,"^",5)=0) S PSOANSQ(PSOX("IRXN"),"PGW")=$P(PSOIBHLD,"^",5) + .I $P(PSOIBHLD,"^",6)=1!($P(PSOIBHLD,"^",6)=0) S PSOANSQ(PSOX("IRXN"),"HNC")=$P(PSOIBHLD,"^",6) + .I $P(PSOIBHLD,"^",7)=1!($P(PSOIBHLD,"^",7)=0) S PSOANSQ(PSOX("IRXN"),"CV")=$P(PSOIBHLD,"^",7) + K PSOIBHLD + I '$G(PSOFDR) I $G(PSORENW("OIRXN")) S FILE=52 D GET^PSORN52D + S PSONEW("NEWCOPAY")="" + I (PSOSCP<50&('$P($G(^PS(53,+$P(^PSRX(PSOX("IRXN"),0),"^",3),0)),"^",7))),$G(DUZ("AG"))="V" S PSOFLAG=0 D COPAY^PSOCPB + ;I PSOSCP>49!($P($G(^PS(53,+$P(^PSRX(PSOX("IRXN"),0),"^",3),0)),"^",7)=1) S PSOFLAG=0 D SC^PSOMLLD2 + I PSOAFYN="Y" G AFIN ;vfah + I PSOSCA&(PSOSCP>49)!((PSOSCA!(PSOBILL=2))&($P($G(^PS(53,+$P(^PSRX(PSOX("IRXN"),0),"^",3),0)),"^",7)=1)) S PSOFLAG=0 D SC^PSOMLLD2 + I $$DT^PSOMLLDT D + .I $D(PSOIBQS(PSODFN,"CV")) D MESS D CV^PSOMLLDT I $G(PSOANSQ(PSOX("IRXN"),"CV")) K PSONEW("NEWCOPAY") + .I $D(PSOIBQS(PSODFN,"VEH")) D MESS D VEH^PSOMLLDT I $G(PSOANSQ(PSOX("IRXN"),"VEH")) K PSONEW("NEWCOPAY") + .I $D(PSOIBQS(PSODFN,"RAD")) D MESS D RAD^PSOMLLDT I $G(PSOANSQ(PSOX("IRXN"),"RAD")) K PSONEW("NEWCOPAY") + .I $D(PSOIBQS(PSODFN,"PGW")) D MESS D PGW^PSOMLLDT I $G(PSOANSQ(PSOX("IRXN"),"PGW")) K PSONEW("NEWCOPAY") + .I $D(PSOIBQS(PSODFN,"MST")) D MESS D MST^PSOMLLDT I $G(PSOANSQ(PSOX("IRXN"),"MST")) K PSONEW("NEWCOPAY") + .I $D(PSOIBQS(PSODFN,"HNC")) D MESS D HNC^PSOMLLDT I $G(PSOANSQ(PSOX("IRXN"),"HNC")) K PSONEW("NEWCOPAY") + K PSOSCOTH,PSOSCOTX + I $G(PSONEW("NEWCOPAY")) S ^PSRX(PSOX("IRXN"),"IB")=PSONEW("NEWCOPAY") + ; +AFIN D FINISH,ACP^PSOUTIL ;vfah copay not evaluated by Autofinish,Rx + ; + N PSOSCFLD S PSOSCFLD=$S(PSOSCP'="":$G(PSOANSQ("SC")),1:"")_"^"_$G(PSOANSQ(PSOX("IRXN"),"MST"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"VEH"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"RAD")) + S PSOSCFLD=PSOSCFLD_"^"_$G(PSOANSQ(PSOX("IRXN"),"PGW"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"HNC"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"CV")) + I PSOSCP<50&($TR(PSOSCFLD,"^")'="")&('$P($G(^PS(53,+$P(^PSRX(PSOX("IRXN"),0),"^",3),0)),"^",7)) S ^PSRX(PSOX("IRXN"),"IBQ")=PSOSCFLD K PSOSCFLD + ; + D FILE2^PSORN52D + D:$$SWSTAT^IBBAPI() GACT^PSOPFSU0(PSOX("IRXN"),0) + K PSONEW("NEWCOPAY"),PSOANSQ +END D EOJ + Q +INIT S PSORN52("QFLG")=0 S:'$D(PSOX("DAYS SUPPLY")) PSOX("DAYS SUPPLY")=$P(PSOX("RX0"),"^",8) + S:'$D(PSOX("# OF REFILLS")) PSOX("# OF REFILLS")=$P(PSOX("RX0"),"^",9) S:'$D(PSOX("ISSUE DATE")) PSOX("ISSUE DATE")=DT + D INIT^PSON52 K PSON52 + Q + ; +FINISH ; + G:PSOX("STATUS")=4 FINISHP + I $D(PSORX("VERIFY")) D G FINISHX + .K DIC,DLAYGO,DINUM,DIADD,X,DD,DO S DIC="^PS(52.4,",DLAYGO=52.4,DINUM=PSOX("IRXN"),DIC(0)="ML" + .S X=PSOX("IRXN") D FILE^DICN K DD,DO,DIC,DLAYGO,DINUM,X + .S ^PS(52.4,PSOX("IRXN"),0)=PSOX("IRXN")_"^"_$P(PSOX("NRX0"),"^",2)_"^"_DUZ_"^"_$G(PSOX("OIRXN"))_"^"_$E(PSOX("LOGIN DATE"),1,7)_"^"_PSOX("IRXN")_"^"_PSOX("STOP DATE") + .K DIK,DA S DIK="^PS(52.4,",DA=PSOX("IRXN") D IX^DIK K DIK,DA + ; + I $G(PSOX("QS"))="S",$G(PSOBARCD) S DA=PSOX("IRXN"),RXFL(PSOX("IRXN"))=0 D SUS^PSORXL K DA G FINISHX + ; + I PSOX("FILL DATE")>DT,$P(PSOPAR,"^",6) S DA=PSOX("IRXN"),RXFL(PSOX("IRXN"))=0 D SUS^PSORXL K DA G FINISHX + ; + ; - Submitting Rx to ECME for 3rd Party Billing + N ACTION + I $$SUBMIT^PSOBPSUT(PSOX("IRXN"),0) D I ACTION="Q"!(ACTION="^") Q + . S ACTION="" D ECMESND^PSOBPSU1(PSOX("IRXN"),0,PSOX("FILL DATE"),"RN") + . I $$FIND^PSOREJUT(PSOX("IRXN"),0) D + . . S ACTION=$$HDLG^PSOREJU1(PSOX("IRXN"),0,"79,88","RN","IOQ","I") + ; + I $G(PSOX("QS"))="Q",$G(PSOBARCD) D G FINISHX + . N PSOFROM S PSOFROM="BATCH" I $G(PPL),$L(PPL_PSOX("IRXN")_",")>240 D TRI^PSOBBC D Q^PSORXL K PPL,RXFL + .S RXFL(PSOX("IRXN"))=0 + . I $G(PPL) S PPL=PPL_PSOX("IRXN")_"," + . E S PPL=PSOX("IRXN")_"," + . Q +FINISHP I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=PSOX("IRXN")_",",RXFL(PSOX("IRXN"))=0 G FINISHX + F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1 S PSOX2=PSOX1 + I $L(PSORX("PSOL",PSOX2))+$L(PSOX("IRXN"))<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_PSOX("IRXN")_"," + E S PSORX("PSOL",PSOX2+1)=PSOX("IRXN")_"," + S RXFL(PSOX("IRXN"))=0 +FINISHX ; + ;call to build bingo board Rx array + S:'$G(PSORX("MAIL/WINDOW")) PSORX("MAIL/WINDOW")=$P(PSORENW("NRX0"),"^",11) + I $G(PSORX("MAIL/WINDOW"))["W" S BINGCRT=1,BINGRTE="W",BBFLG=1 D BBRX^PSORN52C + K PSOX1,PSOX2 + Q +EOJ ; + L -^PSRX("B",PSOX("IRXN")) K PSORN52,PSOX("INS"),PSORENW("INS"),PSORXED("INS"),PSONEW("ENT"),PSORXED("ENT"),OLENT,PSOIBHLD,PSOX("SINS"),PSORENW("SINS"),PSORXED("SINS"),FILE + D PSOUL^PSSLOCK(PSOX("IRXN")) D PSOUL^PSSLOCK(PSOX("OIRXN")) + Q +MESS ; + I $G(PSOSCOTX)=1&(PSOSCP<50) W:$G(PSODRUG("DEA"))'["S"&($G(PSODRUG("DEA"))'["I") !!,"This Rx has been flagged by the provider as: "_$S($G(PSOSCOTH):"NO COPAY",$G(PSORX("SC"))="SC":"NO COPAY",1:"COPAY"),! S PSOSCOTX=2 + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORN52A.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORN52A.m index 8da23a6e..862ee871 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORN52A.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORN52A.m @@ -1,65 +1,64 @@ -PSORN52A ;IHS/DSD/JCM/SAB/FLS-Break up of PSORN52 ;08/09/93 - ;;7.0;OUTPATIENT PHARMACY;**157,148,268,225**;DEC 1997;Build 29 - Q ; Call from tag - ; -IBHLD ; - I $P(PSOIBHLD,"^",2)="" S $P(PSOIBHLD,"^",2)=$S($P(PSOLDIBQ,"^",2)=1:1,$P(PSOLDIBQ,"^",2)=0:0,1:"") - I $P(PSOIBHLD,"^",3)="" S $P(PSOIBHLD,"^",3)=$S($P(PSOLDIBQ,"^",3)=1:1,$P(PSOLDIBQ,"^",3)=0:0,1:"") - I $P(PSOIBHLD,"^",4)="" S $P(PSOIBHLD,"^",4)=$S($P(PSOLDIBQ,"^",4)=1:1,$P(PSOLDIBQ,"^",4)=0:0,1:"") - I $P(PSOIBHLD,"^",5)="" S $P(PSOIBHLD,"^",5)=$S($P(PSOLDIBQ,"^",5)=1:1,$P(PSOLDIBQ,"^",5)=0:0,1:"") - I $P(PSOIBHLD,"^",6)="" S $P(PSOIBHLD,"^",6)=$S($P(PSOLDIBQ,"^",6)=1:1,$P(PSOLDIBQ,"^",6)=0:0,1:"") - I $P(PSOIBHLD,"^",7)="" S $P(PSOIBHLD,"^",7)=$S($P(PSOLDIBQ,"^",7)=1:1,$P(PSOLDIBQ,"^",7)=0:0,1:"") - I $P(PSOIBHLD,"^",8)="" S $P(PSOIBHLD,"^",8)=$S($P(PSOLDIBQ,"^",8)=1:1,$P(PSOLDIBQ,"^",8)=0:0,1:"") - Q - ; -FILE ; - Filling ^PSRX and ^PS(55 entries - S PSOX("NRX0")=PSORENW("RX0"),PSOX("NRX2")=PSORENW("RX2"),PSOX("NRX3")=PSORENW("RX3"),$P(PSOX("NRX3"),"^",5)="" - S $P(PSOX("NRX0"),"^")=PSOX("NRX #") S:$G(PSOX("PROVIDER"))]"" $P(PSOX("NRX0"),"^",4)=PSOX("PROVIDER") - I $G(PSORNSPD),$G(PSOX("PATIENT STATUS")),$G(PSOX("PATIENT STATUS"))?.N S $P(PSOX("NRX0"),"^",3)=PSOX("PATIENT STATUS") - S:$G(PSOX("COSIGNING PROVIDER"))]"" $P(PSOX("NRX3"),"^",3)=PSOX("COSIGNING PROVIDER") - S $P(PSOX("NRX0"),"^",5)=PSOX("CLINIC"),$P(PSOX("NRX0"),"^",9)=PSOX("# OF REFILLS") - I $G(PSOX("DAYS SUPPLY")) S $P(PSOX("NRX0"),"^",8)=PSOX("DAYS SUPPLY") - I $G(PSOX("QTY")) S $P(PSOX("NRX0"),"^",7)=PSOX("QTY") - S $P(PSOX("NRX0"),"^",11)=$S(PSOX("FILL DATE")>DT&($P(PSOPAR,"^",6)):"M",$D(PSOX("MAIL/WINDOW")):PSOX("MAIL/WINDOW"),1:$P(PSOX("NRX0"),"^",11)) - S $P(PSOX("NRX0"),"^",13)=PSOX("ISSUE DATE"),$P(PSOX("STA"),"^")=PSOX("STATUS"),$P(PSOX("NRX0"),"^",16)=$S($G(PSOX("CLERK CODE"))]"":PSOX("CLERK CODE"),1:DUZ) - S $P(PSOX("NRX0"),"^",17)=$G(PSODRUG("COST")) - S $P(PSOX("NRX2"),"^")=PSOX("LOGIN DATE"),$P(PSOX("NRX2"),"^",2)=PSOX("FILL DATE"),$P(PSOX("NRX2"),"^",3)="",$P(PSOX("NRX2"),"^",5)=PSOX("DISPENSED DATE") - S $P(PSOX("NRX2"),"^",6)=PSOX("STOP DATE"),$P(PSOX("NRX2"),"^",7)=$S($G(PSOX("NDC"))]"":PSOX("NDC"),1:$G(PSODRUG("NDC"))) - S $P(PSOX("NRX2"),"^",8)=$S($G(PSOX("MANUFACTURER"))]"":PSOX("MANUFACTURER"),1:$G(PSODRUG("MANUFACTURER"))) - S $P(PSOX("NRX2"),"^",9)=+PSOSITE,$P(PSOX("NRX2"),"^",10)="" - S $P(PSOX("NRX2"),"^",11)=$S($G(PSOX("EXPIRATION DATE"))]"":PSOX("EXPIRATION DATE"),1:$G(PSODRUG("EXPIRATION DATE"))) - S:$G(PSOX("GENERIC PROVIDER"))]"" $P(PSOX("NRX2"),"^",12)=PSOX("GENERIC PROVIDER") - S $P(PSOX("NRX2"),"^",13)="",$P(PSOX("NRX2"),"^",15)="",$P(PSOX("NRX3"),"^",4)=$P(PSOX("NRX3"),"^") - S $P(PSOX("EPH"),"^")=$S($G(PSOX("DAW"))]"":PSOX("DAW"),1:$G(PSODRUG("DAW"))) - ;S PSOX("LAST DISPENSED DATE")=$P(PSOX("NRX3"),"^") - S PSOX("LAST DISPENSED DATE")=PSOX("DISPENSED DATE") - S $P(PSOX("NRX3"),"^")=PSOX("LAST DISPENSED DATE") - S:$G(PSOX("NEXT POSSIBLE REFILL"))]"" $P(PSOX("NRX3"),"^",2)=PSOX("NEXT POSSIBLE REFILL") - S:'$P(^VA(200,$P(PSOX("NRX0"),"^",4),"PS"),"^",7) $P(PSOX("NRX3"),"^",3)="" - S:$G(PSOX("REMARKS"))']"" PSOX("REMARKS")="RENEWED FROM RX # "_$P(PSOX("RX0"),"^") - S $P(PSOX("NRX3"),"^",7)=PSOX("REMARKS"),$P(PSOX("NRX3"),"^",8)="" - ; - ; - File OTHER PATIENT INSTRUCTIONS into ^PSRX - I $G(PSOFXRNX) S PSOFXRN=1 - D ^PSORN52C,FILE^PSORN52D - I $G(^PSRX(PSOX("OIRXN"),"INSS"))]"" S ^PSRX(PSOX("IRXN"),"INSS")=^PSRX(PSOX("OIRXN"),"INSS") K PSOX1 G F55 - I $G(PSOX("SINS"))]"" S ^PSRX(PSOX("IRXN"),"INSS")=PSOX("SINS") - K PSOX1 - ; - ; - File data into ^PS(55) -F55 L +^PS(55,PSODFN,"P"):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) S:'$D(^PS(55,PSODFN,"P",0)) ^(0)="^55.03PA^^" - F PSOX1=$P(^PS(55,PSODFN,"P",0),"^",3):1 Q:'$D(^PS(55,PSODFN,"P",PSOX1)) - S PSOX("55 IEN")=PSOX1 - S ^PS(55,PSODFN,"P",PSOX1,0)=PSOX("IRXN"),$P(^PS(55,PSODFN,"P",0),"^",3,4)=PSOX1_"^"_($P(^PS(55,PSODFN,"P",0),"^",4)+1) - S ^PS(55,PSODFN,"P","A",PSOX("STOP DATE"),PSOX("IRXN"))="" - L -^PS(55,PSODFN,"P") - K PSOX1 - ; - ; - Patient Counseling questions - I $G(OR0) D FULL^VALM1,COUN^PSONEW S PSONOOR="" - I $D(^XUSEC("PSORPH",DUZ)) S DA=PSOX("IRXN"),DIE=52,DR="41////"_PSOCOU_";S:'X Y=""@1"";42////"_PSOCOUU_";@1" D ^DIE K DIE,DR - ; - ; - Re-indexing file 52 entry - K DIK,DA S DIK="^PSRX(",DA=PSOX("IRXN") D IX1^DIK K DIK - S DA=PSOX("IRXN") D ORC^PSORN52C - Q +PSORN52A ;IHS/DSD/JCM/SAB/FLS-Break up of PSORN52 ;08/09/93 + ;;7.0;OUTPATIENT PHARMACY;**157,148,268**;DEC 1997;Build 9 + Q ; Call from tag + ; +IBHLD ; + I $P(PSOIBHLD,"^",2)="" S $P(PSOIBHLD,"^",2)=$S($P(PSOLDIBQ,"^",2)=1:1,$P(PSOLDIBQ,"^",2)=0:0,1:"") + I $P(PSOIBHLD,"^",3)="" S $P(PSOIBHLD,"^",3)=$S($P(PSOLDIBQ,"^",3)=1:1,$P(PSOLDIBQ,"^",3)=0:0,1:"") + I $P(PSOIBHLD,"^",4)="" S $P(PSOIBHLD,"^",4)=$S($P(PSOLDIBQ,"^",4)=1:1,$P(PSOLDIBQ,"^",4)=0:0,1:"") + I $P(PSOIBHLD,"^",5)="" S $P(PSOIBHLD,"^",5)=$S($P(PSOLDIBQ,"^",5)=1:1,$P(PSOLDIBQ,"^",5)=0:0,1:"") + I $P(PSOIBHLD,"^",6)="" S $P(PSOIBHLD,"^",6)=$S($P(PSOLDIBQ,"^",6)=1:1,$P(PSOLDIBQ,"^",6)=0:0,1:"") + I $P(PSOIBHLD,"^",7)="" S $P(PSOIBHLD,"^",7)=$S($P(PSOLDIBQ,"^",7)=1:1,$P(PSOLDIBQ,"^",7)=0:0,1:"") + Q + ; +FILE ; - Filling ^PSRX and ^PS(55 entries + S PSOX("NRX0")=PSORENW("RX0"),PSOX("NRX2")=PSORENW("RX2"),PSOX("NRX3")=PSORENW("RX3"),$P(PSOX("NRX3"),"^",5)="" + S $P(PSOX("NRX0"),"^")=PSOX("NRX #") S:$G(PSOX("PROVIDER"))]"" $P(PSOX("NRX0"),"^",4)=PSOX("PROVIDER") + I $G(PSORNSPD),$G(PSOX("PATIENT STATUS")),$G(PSOX("PATIENT STATUS"))?.N S $P(PSOX("NRX0"),"^",3)=PSOX("PATIENT STATUS") + S:$G(PSOX("COSIGNING PROVIDER"))]"" $P(PSOX("NRX3"),"^",3)=PSOX("COSIGNING PROVIDER") + S $P(PSOX("NRX0"),"^",5)=PSOX("CLINIC"),$P(PSOX("NRX0"),"^",9)=PSOX("# OF REFILLS") + I $G(PSOX("DAYS SUPPLY")) S $P(PSOX("NRX0"),"^",8)=PSOX("DAYS SUPPLY") + I $G(PSOX("QTY")) S $P(PSOX("NRX0"),"^",7)=PSOX("QTY") + S $P(PSOX("NRX0"),"^",11)=$S(PSOX("FILL DATE")>DT&($P(PSOPAR,"^",6)):"M",$D(PSOX("MAIL/WINDOW")):PSOX("MAIL/WINDOW"),1:$P(PSOX("NRX0"),"^",11)) + S $P(PSOX("NRX0"),"^",13)=PSOX("ISSUE DATE"),$P(PSOX("STA"),"^")=PSOX("STATUS"),$P(PSOX("NRX0"),"^",16)=$S($G(PSOX("CLERK CODE"))]"":PSOX("CLERK CODE"),1:DUZ) + S $P(PSOX("NRX0"),"^",17)=$G(PSODRUG("COST")) + S $P(PSOX("NRX2"),"^")=PSOX("LOGIN DATE"),$P(PSOX("NRX2"),"^",2)=PSOX("FILL DATE"),$P(PSOX("NRX2"),"^",3)="",$P(PSOX("NRX2"),"^",5)=PSOX("DISPENSED DATE") + S $P(PSOX("NRX2"),"^",6)=PSOX("STOP DATE"),$P(PSOX("NRX2"),"^",7)=$S($G(PSOX("NDC"))]"":PSOX("NDC"),1:$G(PSODRUG("NDC"))) + S $P(PSOX("NRX2"),"^",8)=$S($G(PSOX("MANUFACTURER"))]"":PSOX("MANUFACTURER"),1:$G(PSODRUG("MANUFACTURER"))) + S $P(PSOX("NRX2"),"^",9)=+PSOSITE,$P(PSOX("NRX2"),"^",10)="" + S $P(PSOX("NRX2"),"^",11)=$S($G(PSOX("EXPIRATION DATE"))]"":PSOX("EXPIRATION DATE"),1:$G(PSODRUG("EXPIRATION DATE"))) + S:$G(PSOX("GENERIC PROVIDER"))]"" $P(PSOX("NRX2"),"^",12)=PSOX("GENERIC PROVIDER") + S $P(PSOX("NRX2"),"^",13)="",$P(PSOX("NRX2"),"^",15)="",$P(PSOX("NRX3"),"^",4)=$P(PSOX("NRX3"),"^") + S $P(PSOX("EPH"),"^")=$S($G(PSOX("DAW"))]"":PSOX("DAW"),1:$G(PSODRUG("DAW"))) + ;S PSOX("LAST DISPENSED DATE")=$P(PSOX("NRX3"),"^") + S PSOX("LAST DISPENSED DATE")=PSOX("DISPENSED DATE") + S $P(PSOX("NRX3"),"^")=PSOX("LAST DISPENSED DATE") + S:$G(PSOX("NEXT POSSIBLE REFILL"))]"" $P(PSOX("NRX3"),"^",2)=PSOX("NEXT POSSIBLE REFILL") + S:'$P(^VA(200,$P(PSOX("NRX0"),"^",4),"PS"),"^",7) $P(PSOX("NRX3"),"^",3)="" + S:$G(PSOX("REMARKS"))']"" PSOX("REMARKS")="RENEWED FROM RX # "_$P(PSOX("RX0"),"^") + S $P(PSOX("NRX3"),"^",7)=PSOX("REMARKS"),$P(PSOX("NRX3"),"^",8)="" + ; + ; - File OTHER PATIENT INSTRUCTIONS into ^PSRX + I $G(PSOFXRNX) S PSOFXRN=1 + D ^PSORN52C,FILE^PSORN52D + I $G(^PSRX(PSOX("OIRXN"),"INSS"))]"" S ^PSRX(PSOX("IRXN"),"INSS")=^PSRX(PSOX("OIRXN"),"INSS") K PSOX1 G F55 + I $G(PSOX("SINS"))]"" S ^PSRX(PSOX("IRXN"),"INSS")=PSOX("SINS") + K PSOX1 + ; + ; - File data into ^PS(55) +F55 L +^PS(55,PSODFN,"P"):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) S:'$D(^PS(55,PSODFN,"P",0)) ^(0)="^55.03PA^^" + F PSOX1=$P(^PS(55,PSODFN,"P",0),"^",3):1 Q:'$D(^PS(55,PSODFN,"P",PSOX1)) + S PSOX("55 IEN")=PSOX1 + S ^PS(55,PSODFN,"P",PSOX1,0)=PSOX("IRXN"),$P(^PS(55,PSODFN,"P",0),"^",3,4)=PSOX1_"^"_($P(^PS(55,PSODFN,"P",0),"^",4)+1) + S ^PS(55,PSODFN,"P","A",PSOX("STOP DATE"),PSOX("IRXN"))="" + L -^PS(55,PSODFN,"P") + K PSOX1 + ; + ; - Patient Counseling questions + I $G(OR0) D FULL^VALM1,COUN^PSONEW S PSONOOR="" + I $D(^XUSEC("PSORPH",DUZ)) S DA=PSOX("IRXN"),DIE=52,DR="41////"_PSOCOU_";S:'X Y=""@1"";42////"_PSOCOUU_";@1" D ^DIE K DIE,DR + ; + ; - Re-indexing file 52 entry + K DIK,DA S DIK="^PSRX(",DA=PSOX("IRXN") D IX1^DIK K DIK + S DA=PSOX("IRXN") D ORC^PSORN52C + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORN52C.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORN52C.m index ae2246f8..96e446b0 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORN52C.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORN52C.m @@ -1,97 +1,97 @@ -PSORN52C ;BIR/SAB-files renewal entries con't ;08/09/93 - ;;7.0;OUTPATIENT PHARMACY;**1,7,11,27,46,75,87,100,111,124,117,131,146,148,200,225**;DEC 1997;Build 29 - ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789 - S DIC="^PSRX(",DLAYGO=52,DIC(0)="L",X=PSOX("NRX #") K DD,DO - D FILE^DICN S PSOX("IRXN")=+Y K DLAYGO,X,Y,DIC,DD,DO - D:+$G(DGI) TECH^PSODGDGI ; L +^PSRX(PSOX("IRXN")):0 - D:$G(^TMP("PSODAI",$J,0)) - .S $P(^PSRX(PSOX("IRXN"),3),"^",6)=1 - .I $O(^TMP("PSODAI",$J,0)) S DAI=0 F S DAI=$O(^TMP("PSODAI",$J,DAI)) Q:'DAI D - ..S:'$D(^PSRX(PSOX("IRXN"),"DAI",0)) ^PSRX(PSOX("IRXN"),"DAI",0)="^52.03^^" S ^PSRX(PSOX("IRXN"),"DAI",DAI,0)=^TMP("PSODAI",$J,DAI,0) - ..S $P(^PSRX(PSOX("IRXN"),"DAI",0),"^",3)=+$P(^PSRX(PSOX("IRXN"),"DAI",0),"^",3)+1,$P(^(0),"^",4)=+$P(^(0),"^",4)+1 - .K ^TMP("PSODAI",$J),DAI - S PSORN52(PSOX("IRXN"),0)=PSOX("NRX0"),PSORN52(PSOX("IRXN"),2)=PSOX("NRX2"),PSORN52(PSOX("IRXN"),3)=PSOX("NRX3") - S PSORN52(PSOX("IRXN"),"EPH")=PSOX("EPH") - S:'$G(PSOX("ENT")) PSORN52(PSOX("IRXN"),"SIG")=PSOX("SIG") - S PSORN52(PSOX("IRXN"),"STA")=PSOX("STA") - S:$G(PSOX("TN"))]"" PSORN52(PSOX("IRXN"),"TN")=PSOX("TN") - I $G(PSOX("METHOD OF PICK-UP"))]"",PSOX("FILL DATE")'>DT S PSORN52(PSOX("IRXN"),"MP")=PSOX("METHOD OF PICK-UP") - S PSORN52(PSOX("IRXN"),"TYPE")=0 - S PSOX1="" F S PSOX1=$O(PSORN52(PSOX("IRXN"),PSOX1)) Q:PSOX1="" S ^PSRX(PSOX("IRXN"),PSOX1)=$G(PSORN52(PSOX("IRXN"),PSOX1)) - I $O(SIG(0)) D G ENT - .S II=0 F I=0:0 S I=$O(SIG(I)) Q:'I S ^PSRX(PSOX("IRXN"),"SIG1",I,0)=SIG(I),II=II+1 - .S ^PSRX(PSOX("IRXN"),"SIG1",0)="^52.04A^"_II_"^"_II,$P(^PSRX(PSOX("IRXN"),"SIG"),"^",2)=1 K I,II - .S $P(^PSRX(PSOX("IRXN"),"SIG"),"^",2)=1 -ENT S ^PSRX(PSOX("IRXN"),"POE")=1,^PSRX(PSOX("IRXN"),"INS")=$G(PSOX("INS")) - I $G(OR0) S:$P(OR0,"^",24) ^PSRX(PSOX("IRXN"),"PKI")=1 - I $G(PSOX("SIG",1))]"",'$O(PSOX("SIG",1)) S ^PSRX(PSOX("IRXN"),"INS1",1,0)=PSOX("SIG",1),^PSRX(PSOX("IRXN"),"INS1",0)="^52.0115^1^1^"_DT_"^^" - I $O(^PSRX(PSOX("OIRXN"),"INS1",0)) D - .F D=0:0 S D=$O(^PSRX(PSOX("OIRXN"),"INS1",D)) Q:'D S ^PSRX(PSOX("IRXN"),"INS1",D,0)=^PSRX(PSOX("OIRXN"),"INS1",D,0) - .S ^PSRX(PSOX("IRXN"),"INS1",0)=^PSRX(PSOX("OIRXN"),"INS1",0) -TNT F I=1:1:PSOX("ENT") S ^PSRX(PSOX("IRXN"),6,I,0)=PSOX("DOSE",I)_"^"_$G(PSOX("DOSE ORDERED",I))_"^"_$G(PSOX("UNITS",I))_"^"_$G(PSOX("NOUN",I))_"^" D - .S ^PSRX(PSOX("IRXN"),6,I,0)=^PSRX(PSOX("IRXN"),6,I,0)_$G(PSOX("DURATION",I))_"^"_$G(PSOX("CONJUNCTION",I))_"^"_$G(PSOX("ROUTE",I))_"^"_$G(PSOX("SCHEDULE",I))_"^"_$G(PSOX("VERB",I)) - .I $G(PSOX("ODOSE",I))]"" S ^PSRX(PSOX("IRXN"),6,I,1)=PSOX("ODOSE",I) - S:$G(PSOX("ENT")) ^PSRX(PSOX("IRXN"),6,0)="^52.0113^"_PSOX("ENT")_"^"_PSOX("ENT") - Q -ORC ; - D MARK^PSOTPCAN - K PSORDEDT,GG,PSOHD,PSOID,PTST,PTDY,PTRF,RFCNT,RN,SEG1,SIG,SIGOK,DIC - K ST0,STA,STP,STR,JJ,LSI,MM,ORDG,ORIG,PHARMST,PSCAN,PSCNT,PSOI,GMRAL,DIC,DIE,HDR,IEN,NAME D KVA^VADPT - I $G(PSOFDR) D - .I $G(PKI1)=1,$G(PKIR)]"" D ACT^PSOPKIV1(PSOX("IRXN")) - .S $P(^PSRX(PSOX("IRXN"),"OR1"),"^",2)=$P(OR0,"^"),^PSRX("APL",$P(OR0,"^"),PSOX("IRXN"))="" - .I $P($G(^PS(52.41,+$G(ORD),"EXT")),"^")="" I $G(PSOSIGFL)!($G(PSODRUG("OI"))'=$P(OR0,"^",8)) K:'$G(PSOPRC) PRC K PHI - .I $O(PRC(0)) S T=0 F S T=$O(PRC(T)) Q:'T S ^PSRX(PSOX("IRXN"),"PRC",T,0)=PRC(T),^PSRX(PSOX("IRXN"),"PRC",0)="^^"_T_"^"_T_"^"_DT_"^" - .I $O(PHI(0)) S T=0 F S T=$O(PHI(T)) Q:'T S ^PSRX(PSOX("IRXN"),"PI",T,0)=PHI(T),^PSRX(PSOX("IRXN"),"PI",0)="^^"_T_"^"_T_"^"_DT_"^" - .I $G(PSOSIGFL)!($G(PSODRUG("OI"))'=$P(OR0,"^",8)) D S PSOI=1 Q - ..S POERR("PLACER")=$P(^PS(52.41,ORD,0),"^"),PSORDEDT=ORD - ..K ^PS(52.41,"AOR",PSODFN,+$P($G(^PS(52.41,ORD,"INI")),"^"),ORD) - ..S DA=ORD,DIK="^PS(52.41," D ^DIK - ..S $P(^PSRX(PSOX("IRXN"),"OR1"),"^")=$G(PSODRUG("OI")) - .E S $P(^PSRX(PSOX("IRXN"),"OR1"),"^")=$P(OR0,"^",8) - .D PSOUL^PSSLOCK(ORD_"S") S DIK="^PS(52.41,",DA=ORD D ^DIK K DIK,DA - I $G(PSOX("OIRXN")),'$G(COPY) S $P(^PSRX(PSOX("IRXN"),"OR1"),"^",3)=PSOX("OIRXN"),$P(^PSRX(PSOX("OIRXN"),"OR1"),"^",4)=PSOX("IRXN"),^PSRX("AQ",PSOX("IRXN"),PSOX("OIRXN"))="" K PRC - I $O(PRC(0)) S T=0 F S T=$O(PRC(T)) Q:'T S ^PSRX(PSOX("IRXN"),"PRC",T,0)=PRC(T),^PSRX(PSOX("IRXN"),"PRC",0)="^^"_T_"^"_T_"^"_DT_"^" - I $O(PHI(0)) S T=0 F S T=$O(PHI(T)) Q:'T S ^PSRX(PSOX("IRXN"),"PI",T,0)=PHI(T),^PSRX(PSOX("IRXN"),"PI",0)="^^"_T_"^"_T_"^"_DT_"^" - S $P(^PSRX(PSOX("IRXN"),"OR1"),"^",5)=DUZ - S $P(^PSRX(PSOX("IRXN"),"OR1"),"^",8)=$$NOW^XLFDT D - . N DA,DIK S DA=PSOX("IRXN"),DIK="^PSRX(",DIK(1)=38.3 D EN1^DIK K DIK,DA - S PHARMST="",$P(^PSRX(PSOX("IRXN"),"OR1"),"^")=$G(PSODRUG("OI")) - S RXN=PSOX("IRXN") D SAVE - S STAT=$S($G(OR0)]""&('$G(PSOI)):"SC",$G(PSOI):"RO",1:"SN") S PHARMST=$S('$G(PSORX("VERIFY")):"CM",1:"IP") ;D EN^PSOHLSN1(RXN,STAT,PHARMST,"",PSONOOR) - S ^TMP("PSORXN",$J,RXN)=STAT_"^"_PHARMST_"^"_PSONOOR D PSOL^PSSLOCK(RXN) - D RESTORE K PSORDEDT,PHI,PRC,STAT,COMM,PSOI,OR2,OR1,PHARMST,RXN,DRG,STA,ACT,OCXR,OCXD1,OCXDT,OCXI - Q -BBRX ;build bingo board Rx array; called by PSON52,PSOR52,PSORN52 - I $G(BBRX(1))']"" S BBRX(1)=PSOX("IRXN")_"," Q - F PSOX1=0:0 S PSOX1=$O(BBRX(PSOX1)) Q:'PSOX1 S PSOX2=PSOX1 - I $L(BBRX(PSOX2))+$L(PSOX("IRXN"))<220 S BBRX(PSOX2)=BBRX(PSOX2)_PSOX("IRXN")_"," - E S BBRX(PSOX2+1)=PSOX("IRXN")_"," - Q -SAVE ;this module will be used to save PSO arrays - K ^TMP("PSOLST",$J) F I=0:0 S I=$O(PSOLST(I)) Q:'I S ^TMP("PSOLST",$J,I,0)=PSOLST(I) - K ^TMP("PSOSD",$J) S (STA,DRG)="" F S STA=$O(PSOSD(STA)) Q:STA="" F S DRG=$O(PSOSD(STA,DRG)) Q:DRG="" S ^TMP("PSOSD",$J,STA,DRG)=PSOSD(STA,DRG) - I $G(PSOSD) S ^TMP("PSOSD",$J,0)=PSOSD - I $G(PSODRUG("NAME"))]"" K ^TMP("PSODRUG",$J) S STA="" F S STA=$O(PSODRUG(STA)) Q:STA="" S ^TMP("PSODRUG",$J,STA)=PSODRUG(STA) - I $G(PSOX("# OF REFILLS"))]"" K ^TMP("PSOX",$J),^TMP("PSORENW",$J),^TMP("PSONEW",$J),^TMP("PSORXED",$J) D - .S STA="" F S STA=$O(PSOX(STA)) Q:STA="" S ^TMP("PSOX",$J,STA)=$G(PSOX(STA)) D - ..I STA="OLD LAST RX#",$O(PSOX(STA,"")) K ^TMP("PSOX",$J,STA) S ^TMP("PSOX",$J,STA,$O(PSOX(STA,"")))=PSOX(STA,$O(PSOX(STA,""))) D Q - ...I $O(PSONEW(STA,"")) S ^TMP("PSONEW",$J,STA,$O(PSONEW(STA,"")))=PSONEW(STA,$O(PSONEW(STA,""))) - ...I $O(PSORENW(STA,"")) S ^TMP("PSORENW",$J,STA,$O(PSORENW(STA,"")))=PSORENW(STA,$O(PSORENW(STA,""))) - ...I $O(PSORXED(STA,"")) S ^TMP("PSORXED",$J,STA,$O(PSORXED(STA,"")))=PSORXED(STA,$O(PSORXED(STA,""))) - ..F ACT="PSORENW","PSONEW","PSORXED" I $G(@(ACT_"("""_STA_""")"))]"" S ^TMP(ACT,$J,STA)=@(ACT_"("""_STA_""")") - K PSOPTPST,PSOSD,PSONEW,PSOLST,PSORENW,PSORXED,PSODRUG - Q -RESTORE ;this module restore saved arrays - S STA=0 F S STA=$O(^TMP("PSOLST",$J,STA)) Q:'STA S PSOLST(STA)=^TMP("PSOLST",$J,STA,0) - I $G(^TMP("PSOSD",$J,0)) S PSOSD=$G(^TMP("PSOSD",$J,0)) - S (STA,DRG)="" F S STA=$O(^TMP("PSOSD",$J,STA)) Q:STA="" F S DRG=$O(^TMP("PSOSD",$J,STA,DRG)) Q:DRG="" S PSOSD(STA,DRG)=^TMP("PSOSD",$J,STA,DRG) - S STA="" F S STA=$O(^TMP("PSODRUG",$J,STA)) Q:STA="" S PSODRUG(STA)=^TMP("PSODRUG",$J,STA) - S STA="" F ACT="PSOX","PSORENW","PSONEW","PSORXED" D:$O(^TMP(ACT,$J,STA))]"" - .F S STA=$O(^TMP(ACT,$J,STA)) Q:STA="" I STA'="OLD LAST RX#" S @(ACT_"("""_STA_""")")=^TMP(ACT,$J,STA) - I $O(^TMP("PSOX",$J,"OLD LAST RX#","")) S PSOX("OLD LAST RX#",$O(^TMP("PSOX",$J,"OLD LAST RX#","")))=^TMP("PSOX",$J,"OLD LAST RX#",$O(^TMP("PSOX",$J,"OLD LAST RX#",""))) - I $O(^TMP("PSONEW",$J,"OLD LAST RX#","")) S PSONEW("OLD LAST RX#",$O(^TMP("PSONEW",$J,"OLD LAST RX#","")))=^TMP("PSONEW",$J,"OLD LAST RX#",$O(^TMP("PSONEW",$J,"OLD LAST RX#",""))) - I $O(^TMP("PSORENW",$J,"OLD LAST RX#","")) S PSORENW("OLD LAST RX#",$O(^TMP("PSORENW",$J,"OLD LAST RX#","")))=^TMP("PSORENW",$J,"OLD LAST RX#",$O(^TMP("PSORENW",$J,"OLD LAST RX#",""))) - I $O(^TMP("PSORXED",$J,"OLD LAST RX#","")) S PSORXED("OLD LAST RX#",$O(^TMP("PSORXED",$J,"OLD LAST RX#","")))=^TMP("PSORXED",$J,"OLD LAST RX#",$O(^TMP("PSORXED",$J,"OLD LAST RX#",""))) - K ^TMP("PSOSD",$J),^TMP("PSODRUG",$J),^TMP("PSOX",$J),^TMP("PSORENW",$J),^TMP("PSONEW",$J),^TMP("PSORXED",$J),^TMP("PSOLST",$J) - Q +PSORN52C ;BIR/SAB-files renewal entries con't ;08/09/93 + ;;7.0;OUTPATIENT PHARMACY;**1,7,11,27,46,75,87,100,111,124,117,131,146,148,200**;DEC 1997;Build 7 + ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789 + S DIC="^PSRX(",DLAYGO=52,DIC(0)="L",X=PSOX("NRX #") K DD,DO + D FILE^DICN S PSOX("IRXN")=+Y K DLAYGO,X,Y,DIC,DD,DO + D:+$G(DGI) TECH^PSODGDGI ; L +^PSRX(PSOX("IRXN")):0 + D:$G(^TMP("PSODAI",$J,0)) + .S $P(^PSRX(PSOX("IRXN"),3),"^",6)=1 + .I $O(^TMP("PSODAI",$J,0)) S DAI=0 F S DAI=$O(^TMP("PSODAI",$J,DAI)) Q:'DAI D + ..S:'$D(^PSRX(PSOX("IRXN"),"DAI",0)) ^PSRX(PSOX("IRXN"),"DAI",0)="^52.03^^" S ^PSRX(PSOX("IRXN"),"DAI",DAI,0)=^TMP("PSODAI",$J,DAI,0) + ..S $P(^PSRX(PSOX("IRXN"),"DAI",0),"^",3)=+$P(^PSRX(PSOX("IRXN"),"DAI",0),"^",3)+1,$P(^(0),"^",4)=+$P(^(0),"^",4)+1 + .K ^TMP("PSODAI",$J),DAI + S PSORN52(PSOX("IRXN"),0)=PSOX("NRX0"),PSORN52(PSOX("IRXN"),2)=PSOX("NRX2"),PSORN52(PSOX("IRXN"),3)=PSOX("NRX3") + S PSORN52(PSOX("IRXN"),"EPH")=PSOX("EPH") + S:'$G(PSOX("ENT")) PSORN52(PSOX("IRXN"),"SIG")=PSOX("SIG") + S PSORN52(PSOX("IRXN"),"STA")=PSOX("STA") + S:$G(PSOX("TN"))]"" PSORN52(PSOX("IRXN"),"TN")=PSOX("TN") + I $G(PSOX("METHOD OF PICK-UP"))]"",PSOX("FILL DATE")'>DT S PSORN52(PSOX("IRXN"),"MP")=PSOX("METHOD OF PICK-UP") + S PSORN52(PSOX("IRXN"),"TYPE")=0 + S PSOX1="" F S PSOX1=$O(PSORN52(PSOX("IRXN"),PSOX1)) Q:PSOX1="" S ^PSRX(PSOX("IRXN"),PSOX1)=$G(PSORN52(PSOX("IRXN"),PSOX1)) + I $O(SIG(0)) D G ENT + .S II=0 F I=0:0 S I=$O(SIG(I)) Q:'I S ^PSRX(PSOX("IRXN"),"SIG1",I,0)=SIG(I),II=II+1 + .S ^PSRX(PSOX("IRXN"),"SIG1",0)="^52.04A^"_II_"^"_II,$P(^PSRX(PSOX("IRXN"),"SIG"),"^",2)=1 K I,II + .S $P(^PSRX(PSOX("IRXN"),"SIG"),"^",2)=1 +ENT S ^PSRX(PSOX("IRXN"),"POE")=1,^PSRX(PSOX("IRXN"),"INS")=$G(PSOX("INS")) + I $G(OR0) S:$P(OR0,"^",24) ^PSRX(PSOX("IRXN"),"PKI")=1 + I $G(PSOX("SIG",1))]"",'$O(PSOX("SIG",1)) S ^PSRX(PSOX("IRXN"),"INS1",1,0)=PSOX("SIG",1),^PSRX(PSOX("IRXN"),"INS1",0)="^52.0115^1^1^"_DT_"^^" + I $O(^PSRX(PSOX("OIRXN"),"INS1",0)) D + .F D=0:0 S D=$O(^PSRX(PSOX("OIRXN"),"INS1",D)) Q:'D S ^PSRX(PSOX("IRXN"),"INS1",D,0)=^PSRX(PSOX("OIRXN"),"INS1",D,0) + .S ^PSRX(PSOX("IRXN"),"INS1",0)=^PSRX(PSOX("OIRXN"),"INS1",0) +TNT F I=1:1:PSOX("ENT") S ^PSRX(PSOX("IRXN"),6,I,0)=PSOX("DOSE",I)_"^"_$G(PSOX("DOSE ORDERED",I))_"^"_$G(PSOX("UNITS",I))_"^"_$G(PSOX("NOUN",I))_"^" D + .S ^PSRX(PSOX("IRXN"),6,I,0)=^PSRX(PSOX("IRXN"),6,I,0)_$G(PSOX("DURATION",I))_"^"_$G(PSOX("CONJUNCTION",I))_"^"_$G(PSOX("ROUTE",I))_"^"_$G(PSOX("SCHEDULE",I))_"^"_$G(PSOX("VERB",I)) + .I $G(PSOX("ODOSE",I))]"" S ^PSRX(PSOX("IRXN"),6,I,1)=PSOX("ODOSE",I) + S:$G(PSOX("ENT")) ^PSRX(PSOX("IRXN"),6,0)="^52.0113^"_PSOX("ENT")_"^"_PSOX("ENT") + Q +ORC ; + D MARK^PSOTPCAN + K PSORDEDT,GG,PSOHD,PSOID,PTST,PTDY,PTRF,RFCNT,RN,SEG1,SIG,SIGOK,DIC + K ST0,STA,STP,STR,JJ,LSI,MM,ORDG,ORIG,PHARMST,PSCAN,PSCNT,PSOI,GMRAL,DIC,DIE,HDR,IEN,NAME D KVA^VADPT + I $G(PSOFDR) D + .I $G(PKI1)=1,$G(PKIR)]"" D ACT^PSOPKIV1(PSOX("IRXN")) + .S $P(^PSRX(PSOX("IRXN"),"OR1"),"^",2)=$P(OR0,"^"),^PSRX("APL",$P(OR0,"^"),PSOX("IRXN"))="" + .I $P($G(^PS(52.41,+$G(ORD),"EXT")),"^")="" I $G(PSOSIGFL)!($G(PSODRUG("OI"))'=$P(OR0,"^",8)) K:'$G(PSOPRC) PRC K PHI + .I $O(PRC(0)) S T=0 F S T=$O(PRC(T)) Q:'T S ^PSRX(PSOX("IRXN"),"PRC",T,0)=PRC(T),^PSRX(PSOX("IRXN"),"PRC",0)="^^"_T_"^"_T_"^"_DT_"^" + .I $O(PHI(0)) S T=0 F S T=$O(PHI(T)) Q:'T S ^PSRX(PSOX("IRXN"),"PI",T,0)=PHI(T),^PSRX(PSOX("IRXN"),"PI",0)="^^"_T_"^"_T_"^"_DT_"^" + .I $G(PSOSIGFL)!($G(PSODRUG("OI"))'=$P(OR0,"^",8)) D S PSOI=1 Q + ..S POERR("PLACER")=$P(^PS(52.41,ORD,0),"^"),PSORDEDT=ORD + ..K ^PS(52.41,"AOR",PSODFN,+$P($G(^PS(52.41,ORD,"INI")),"^"),ORD) + ..S DA=ORD,DIK="^PS(52.41," D ^DIK + ..S $P(^PSRX(PSOX("IRXN"),"OR1"),"^")=$G(PSODRUG("OI")) + .E S $P(^PSRX(PSOX("IRXN"),"OR1"),"^")=$P(OR0,"^",8) + .D PSOUL^PSSLOCK(ORD_"S") S DIK="^PS(52.41,",DA=ORD D ^DIK K DIK,DA + S:$G(PSOX("OIRXN"))&('$G(COPY)) $P(^PSRX(PSOX("IRXN"),"OR1"),"^",3)=PSOX("OIRXN"),$P(^PSRX(PSOX("OIRXN"),"OR1"),"^",4)=PSOX("IRXN"),^PSRX("AQ",PSOX("IRXN"),PSOX("OIRXN"))="" + I $O(PRC(0)) S T=0 F S T=$O(PRC(T)) Q:'T S ^PSRX(PSOX("IRXN"),"PRC",T,0)=PRC(T),^PSRX(PSOX("IRXN"),"PRC",0)="^^"_T_"^"_T_"^"_DT_"^" + I $O(PHI(0)) S T=0 F S T=$O(PHI(T)) Q:'T S ^PSRX(PSOX("IRXN"),"PI",T,0)=PHI(T),^PSRX(PSOX("IRXN"),"PI",0)="^^"_T_"^"_T_"^"_DT_"^" + S $P(^PSRX(PSOX("IRXN"),"OR1"),"^",5)=DUZ + S $P(^PSRX(PSOX("IRXN"),"OR1"),"^",8)=$$NOW^XLFDT D + . N DA,DIK S DA=PSOX("IRXN"),DIK="^PSRX(",DIK(1)=38.3 D EN1^DIK K DIK,DA + S PHARMST="",$P(^PSRX(PSOX("IRXN"),"OR1"),"^")=$G(PSODRUG("OI")) + S RXN=PSOX("IRXN") D SAVE + S STAT=$S($G(OR0)]""&('$G(PSOI)):"SC",$G(PSOI):"RO",1:"SN") S PHARMST=$S('$G(PSORX("VERIFY")):"CM",1:"IP") ;D EN^PSOHLSN1(RXN,STAT,PHARMST,"",PSONOOR) + S ^TMP("PSORXN",$J,RXN)=STAT_"^"_PHARMST_"^"_PSONOOR D PSOL^PSSLOCK(RXN) + D RESTORE K PSORDEDT,PHI,PRC,STAT,COMM,PSOI,OR2,OR1,PHARMST,RXN,DRG,STA,ACT,OCXR,OCXD1,OCXDT,OCXI + Q +BBRX ;build bingo board Rx array; called by PSON52,PSOR52,PSORN52 + I $G(BBRX(1))']"" S BBRX(1)=PSOX("IRXN")_"," Q + F PSOX1=0:0 S PSOX1=$O(BBRX(PSOX1)) Q:'PSOX1 S PSOX2=PSOX1 + I $L(BBRX(PSOX2))+$L(PSOX("IRXN"))<220 S BBRX(PSOX2)=BBRX(PSOX2)_PSOX("IRXN")_"," + E S BBRX(PSOX2+1)=PSOX("IRXN")_"," + Q +SAVE ;this module will be used to save PSO arrays + K ^TMP("PSOLST",$J) F I=0:0 S I=$O(PSOLST(I)) Q:'I S ^TMP("PSOLST",$J,I,0)=PSOLST(I) + K ^TMP("PSOSD",$J) S (STA,DRG)="" F S STA=$O(PSOSD(STA)) Q:STA="" F S DRG=$O(PSOSD(STA,DRG)) Q:DRG="" S ^TMP("PSOSD",$J,STA,DRG)=PSOSD(STA,DRG) + I $G(PSOSD) S ^TMP("PSOSD",$J,0)=PSOSD + I $G(PSODRUG("NAME"))]"" K ^TMP("PSODRUG",$J) S STA="" F S STA=$O(PSODRUG(STA)) Q:STA="" S ^TMP("PSODRUG",$J,STA)=PSODRUG(STA) + I $G(PSOX("# OF REFILLS"))]"" K ^TMP("PSOX",$J),^TMP("PSORENW",$J),^TMP("PSONEW",$J),^TMP("PSORXED",$J) D + .S STA="" F S STA=$O(PSOX(STA)) Q:STA="" S ^TMP("PSOX",$J,STA)=$G(PSOX(STA)) D + ..I STA="OLD LAST RX#",$O(PSOX(STA,"")) K ^TMP("PSOX",$J,STA) S ^TMP("PSOX",$J,STA,$O(PSOX(STA,"")))=PSOX(STA,$O(PSOX(STA,""))) D Q + ...I $O(PSONEW(STA,"")) S ^TMP("PSONEW",$J,STA,$O(PSONEW(STA,"")))=PSONEW(STA,$O(PSONEW(STA,""))) + ...I $O(PSORENW(STA,"")) S ^TMP("PSORENW",$J,STA,$O(PSORENW(STA,"")))=PSORENW(STA,$O(PSORENW(STA,""))) + ...I $O(PSORXED(STA,"")) S ^TMP("PSORXED",$J,STA,$O(PSORXED(STA,"")))=PSORXED(STA,$O(PSORXED(STA,""))) + ..F ACT="PSORENW","PSONEW","PSORXED" I $G(@(ACT_"("""_STA_""")"))]"" S ^TMP(ACT,$J,STA)=@(ACT_"("""_STA_""")") + K PSOPTPST,PSOSD,PSONEW,PSOLST,PSORENW,PSORXED,PSODRUG + Q +RESTORE ;this module restore saved arrays + S STA=0 F S STA=$O(^TMP("PSOLST",$J,STA)) Q:'STA S PSOLST(STA)=^TMP("PSOLST",$J,STA,0) + I $G(^TMP("PSOSD",$J,0)) S PSOSD=$G(^TMP("PSOSD",$J,0)) + S (STA,DRG)="" F S STA=$O(^TMP("PSOSD",$J,STA)) Q:STA="" F S DRG=$O(^TMP("PSOSD",$J,STA,DRG)) Q:DRG="" S PSOSD(STA,DRG)=^TMP("PSOSD",$J,STA,DRG) + S STA="" F S STA=$O(^TMP("PSODRUG",$J,STA)) Q:STA="" S PSODRUG(STA)=^TMP("PSODRUG",$J,STA) + S STA="" F ACT="PSOX","PSORENW","PSONEW","PSORXED" D:$O(^TMP(ACT,$J,STA))]"" + .F S STA=$O(^TMP(ACT,$J,STA)) Q:STA="" I STA'="OLD LAST RX#" S @(ACT_"("""_STA_""")")=^TMP(ACT,$J,STA) + I $O(^TMP("PSOX",$J,"OLD LAST RX#","")) S PSOX("OLD LAST RX#",$O(^TMP("PSOX",$J,"OLD LAST RX#","")))=^TMP("PSOX",$J,"OLD LAST RX#",$O(^TMP("PSOX",$J,"OLD LAST RX#",""))) + I $O(^TMP("PSONEW",$J,"OLD LAST RX#","")) S PSONEW("OLD LAST RX#",$O(^TMP("PSONEW",$J,"OLD LAST RX#","")))=^TMP("PSONEW",$J,"OLD LAST RX#",$O(^TMP("PSONEW",$J,"OLD LAST RX#",""))) + I $O(^TMP("PSORENW",$J,"OLD LAST RX#","")) S PSORENW("OLD LAST RX#",$O(^TMP("PSORENW",$J,"OLD LAST RX#","")))=^TMP("PSORENW",$J,"OLD LAST RX#",$O(^TMP("PSORENW",$J,"OLD LAST RX#",""))) + I $O(^TMP("PSORXED",$J,"OLD LAST RX#","")) S PSORXED("OLD LAST RX#",$O(^TMP("PSORXED",$J,"OLD LAST RX#","")))=^TMP("PSORXED",$J,"OLD LAST RX#",$O(^TMP("PSORXED",$J,"OLD LAST RX#",""))) + K ^TMP("PSOSD",$J),^TMP("PSODRUG",$J),^TMP("PSOX",$J),^TMP("PSORENW",$J),^TMP("PSONEW",$J),^TMP("PSORXED",$J),^TMP("PSOLST",$J) + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORN52D.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORN52D.m index b42452b3..dccb3065 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORN52D.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORN52D.m @@ -1,130 +1,112 @@ -PSORN52D ;BIR/LE - files new and renewal entries con't ;02/27/04 - ;;7.0;OUTPATIENT PHARMACY;**143,219,239,225**;DEC 1997;Build 29 - ;External reference VADPT supported by DBIA 10061 - Q -GET ;must have FILE and PSORENW variables to pull default data for ICD and SC/EI for SC>50% Rx's from file 52 - N ARRAY,ERR,SUBF,RXN,II,JJ,ORXN,SUBFLD,PENDSC,PSOPATST,PSOIBQF - I FILE=52 S SUBF=52.052311,SUBFLD=52311,RXN=PSORENW("IRXN"),(SRXN,ORXN)=PSORENW("OIRXN") S:($TR($G(^PSRX(SRXN,"IBQ")),"^")'="") PSOIBQF=1 - ;$TR checks for when patient status is exempt, null IBQ node was set for exempts, or SC>50 - data is in ICD node - I FILE=52.41 S SUBF=52.41311,SUBFLD=311,(SRXN,RXN)=ORD,ORXN=PSORENW("OIRXN") S:($TR($G(^PS(52.41,SRXN,"IBQ")),"^")'="") PSOIBQF=1 - D GETS^DIQ(FILE,SRXN,SUBFLD_"*","I","ARRAY","ERR") - K PSORX("ICD"),PSOX("ICD") - Q:'$D(ARRAY) - I FILE=52.41 S PENDSC=$$GET1^DIQ(52.41,ORD,"17"),PENDSC=$S(PENDSC="SC":1,PENDSC="NSC":0,1:"") - S PSOPATST=$$GET1^DIQ(52,RXN_",",3,"I") - ; -G1 ;get ICD, if no IBQ node get SC/EI's - F II=1:1:8 Q:'$D(ARRAY(SUBF,(II_","_SRXN_","))) D - . S PSORX("ICD",II)=ARRAY(SUBF,(II_","_SRXN_","),.01,"I") S:FILE=52.41 PSONEW("ICD",II)=PSORX("ICD",II) - . Q:II>1!($G(PSOIBQF)) ;only need ei's from 1st node; all nodes same for SC/EI - . F JJ=1:1:8 I ARRAY(SUBF,(II_","_SRXN_","),JJ,"I")=1!(ARRAY(SUBF,(II_","_SRXN_","),JJ,"I")=0) D - .. I JJ=1 S (PSOANSQ(RXN,"VEH"),PSORX(ORXN,"VEH"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I") Q - .. I JJ=2 S (PSOANSQ(RXN,"RAD"),PSORX(ORXN,"RAD"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I") Q - .. I JJ=4 S (PSOANSQ(RXN,"PGW"),PSORX(ORXN,"PGW"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I") Q - .. I JJ=5 S (PSOANSQ(RXN,"MST"),PSORX(ORXN,"MST"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I") Q - .. I JJ=6 S (PSOANSQ(RXN,"HNC"),PSORX(ORXN,"HNC"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I") Q - .. I JJ=7 S (PSOANSQ(RXN,"CV"),PSORX(ORXN,"CV"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I") Q - .. I JJ=8 S (PSOANSQ(RXN,"SHAD"),PSORX(ORXN,"SHAD"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I") Q - I '$G(PSOIBQF) S II=1,JJ=3 D - . I PSOSCP>49&(FILE=52.41) S (PSOANSQ(RXN,"SC>50"),PSORX(ORXN,"SC>50"),PSOANSQ("SC>50"))=PENDSC Q - . I PSOSCP>49&(FILE'=52.41) S:$D(ARRAY(SUBF,(II_","_SRXN_","),JJ,"I")) (PSOANSQ(RXN,"SC>50"),PSOANSQ("SC>50"),PSORX(ORXN,"SC>50"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I") Q - . ; when patient status is exempt use SC>50 variable to differenciate regular SC<50 and exempt SC<50 - . I PSOSCP<50&($P($G(^PS(53,+$G(PSOPATST),0)),"^",7)=1) D - .. I FILE=52.41 S (PSOANSQ(RXN,"SC>50"),PSORX(ORXN,"SC>50"),PSOANSQ("SC>50"))=PENDSC Q - .. S:$G(ARRAY(SUBF,(II_","_SRXN_","),JJ,"I")) (PSOANSQ(RXN,"SC>50"),PSORX(ORXN,"SC>50"),PSOANSQ("SC>50"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I") - . I PSOSCP<50&($P($G(^PS(53,+$G(PSOPATST),0)),"^",7)'=1) D - .. I FILE=52.41 S (PSOANSQ(RXN,"SC"),PSORX(ORXN,"SC"),PSOANSQ("SC"))=PENDSC Q - .. S:$D(ARRAY(SUBF,(II_","_SRXN_","),JJ,"I")) (PSOANSQ(RXN,"SC"),PSORX(ORXN,"SC"),PSOANSQ("SC"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I") - Q - ; -FILE ; - Q:'$D(^PSRX(PSOX("OIRXN"),"ICD")) - N II F II=1:1:8 Q:$G(^PSRX(PSOX("OIRXN"),"ICD",II,0))="" D - . S ^PSRX(PSOX("IRXN"),"ICD",II,0)=$G(^PSRX(PSOX("OIRXN"),"ICD",II,0)) - . S:$P(^PSRX(PSOX("IRXN"),"ICD",II,0),"^",1)'="" ^PSRX(PSOX("IRXN"),"ICD","B",$P(^PSRX(PSOX("IRXN"),"ICD",II,0),"^",1),II)="" - I II>1 S ^PSRX(PSOX("IRXN"),"ICD",0)="^52.052311^"_(II-1)_"^"_(II-1) - Q -FILE2 ;file ICD's on existing node or build new nodes - ;note: variable PSOSCP2 is only available from CPRS Edit API and MISS - ; sub-routine below. - N D,RXN,II,TYPE,DATA,DATA1,PSOPATST - I $G(PSOX("IRXN")) S PSOPATST=$$GET1^DIQ(52,PSOX("IRXN")_",",3,"I") - ;I '$G(PSONEW("PATIENT STATUS")) I $G(PSOX("IRXN")) S PSONEW("PATIENT STATUS")=$$GET1^DIQ(52,PSOX("IRXN")_",",3,"I") - I $G(PSOSCP2)!($G(PSOFDR)&($G(ORD))) D - .;if RX edited in CPRS delete all but what is sent from CPRS - . K ^PSRX(PSOX("IRXN"),"ICD"),^PSRX(PSOX("IRXN"),"IBQ") - S DATA="^^^^^^^^",(DATA1,TYPE)="" - S $P(DATA,U,4)=$S(PSOSCP>49:$G(PSOANSQ("SC>50")),PSOSCP<50&($P($G(^PS(53,+$G(PSOPATST),0)),"^",7)=1):$G(PSOANSQ("SC>50")),PSOSCP<50&(PSOSCP'=""):$G(PSOANSQ("SC")),1:"") - F S TYPE=$O(PSOANSQ(PSOX("IRXN"),TYPE)) Q:TYPE="" D - . I TYPE="VEH" S $P(DATA,U,2)=PSOANSQ(PSOX("IRXN"),"VEH") - . I TYPE="RAD" S $P(DATA,U,3)=PSOANSQ(PSOX("IRXN"),"RAD") - . I TYPE="PGW" S $P(DATA,U,5)=PSOANSQ(PSOX("IRXN"),"PGW") - . I TYPE="MST" S $P(DATA,U,6)=PSOANSQ(PSOX("IRXN"),"MST") - . I TYPE="HNC" S $P(DATA,U,7)=PSOANSQ(PSOX("IRXN"),"HNC") - . I TYPE="CV" S $P(DATA,U,8)=PSOANSQ(PSOX("IRXN"),"CV") - . I TYPE="SHAD" S $P(DATA,U,9)=PSOANSQ(PSOX("IRXN"),"SHAD") - I $O(PSORX("ICD","")) F D=1:1:8 Q:'$D(PSORX("ICD",D)) S $P(DATA,"^")=PSORX("ICD",D) D - . S ^PSRX(PSOX("IRXN"),"ICD",D,0)=DATA,$P(DATA,"^")="",^PSRX(PSOX("IRXN"),"ICD",0)="^52.052311P^"_D_"^"_D - . S:PSORX("ICD",D)'="" ^PSRX(PSOX("IRXN"),"ICD","B",PSORX("ICD",D),D)="" - E S ^PSRX(PSOX("IRXN"),"ICD",0)="^52.052311P^1^1",^PSRX(PSOX("IRXN"),"ICD",1,0)=$G(DATA) - I PSOSCP<50&(($TR(DATA,"^")'=""))&(($P($G(^PS(53,+$G(PSOPATST),0)),"^",7)'=1)) D - .S DATA1=$G(PSOANSQ("SC"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"MST"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"VEH"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"RAD")) - .S DATA1=DATA1_"^"_$G(PSOANSQ(PSOX("IRXN"),"PGW"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"HNC"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"CV"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"SHAD")) - .S:($TR(DATA1,"^")'="") ^PSRX(PSOX("IRXN"),"IBQ")=DATA1 - K PSORX("ICD") - Q - ; -RESET ;called from reset copay status PSOCPC - ;Must be available at this point: PSODA, PSOIBQ=SC^MST^AO^IR^EC^HNC^CV^SHAD - Q:'$D(PSODA)!('$D(PSOIBQ)) - Q:'$D(^PSRX(PSODA)) - ;Q:'$D(^PSRX(PSODA,"ICD")) ;if old Rx and no ICD's defined; don't set - N I,DATA,PSOICD - S:$D(^PSRX(PSODA,"ICD")) PSOICD=1 - I '$G(DFN) S DFN=$$GET1^DIQ(52,PSODA_",",2,"I") - S DATA="^^^^^^^^" - F I=1:1:8 D - . I I=1 S $P(DATA,"^",4)=$P(PSOIBQ,"^",I) - . I I=2 S $P(DATA,"^",6)=$P(PSOIBQ,"^",I) - . I I=3 S $P(DATA,"^",2)=$P(PSOIBQ,"^",I) - . I I=4 S $P(DATA,"^",3)=$P(PSOIBQ,"^",I) - . I I=5 S $P(DATA,"^",5)=$P(PSOIBQ,"^",I) - . I I=6 S $P(DATA,"^",7)=$P(PSOIBQ,"^",I) - . I I=7 S $P(DATA,"^",8)=$P(PSOIBQ,"^",I) - . I I=8 S $P(DATA,"^",9)=$P(PSOIBQ,"^",I) - I $G(PSOICD) S I=0 F S I=$O(^PSRX(PSODA,"ICD",I)) Q:I=""!(I'?1N.NN) D - . Q:'$D(^PSRX(PSODA,"ICD",I,0)) - . S $P(^PSRX(PSODA,"ICD",I,0),"^",2,9)=$P(DATA,"^",2,9) - ; for pre-cidc RX - I '$G(PSOICD) S ^PSRX(PSODA,"ICD",1,0)="^"_$P(DATA,"^",2,9),^PSRX(PSODA,"ICD",0)="^52.052311P^1^1" - Q - ; -SCP ;Called from multiple routines - DFN or PSODFN variable must be available to call this subroutine. - I '$G(DFN) S DFN=+$G(PSODFN) - D ELIG^VADPT S PSOANSQ("SC>50")="",(PSOSCA,PSOSCP)="",PSOSCP=$P(VAEL(3),U,2) - S:PSOSCP=""&($P(VAEL(3),U)=1) PSOSCP=0 - S PSOSCA=$$SC^SDCO22(DFN) - K VAEL - Q -SHAD ; - N XX - I $P($G(PSOPIBQ),U,8)]"" S XX=$P(PSOPIBQ,U,8) I XX=0!(XX=1) S PSOANSQ(PSOX("IRXN"),"SHAD")=XX Q - I $P($G(^PSRX(RXN,"ICD",1,0)),U,9)]"" S XX=$P($G(^PSRX(PSOX("IRXN"),"ICD",1,0)),U,9) S:XX=0!(XX=1) PSOANSQ(PSOX("IRXN"),"SHAD")=XX - Q - ; -SET3 ;for when patient status is exempt or SC>50 - N PSOPATST S PSOPATST=PSORX("PATIENT STATUS") - I PSORX("PATIENT STATUS")'?1N.N S PSOPATST="",PSOPATST=$O(^PS(53,"B",PSORX("PATIENT STATUS"),PSOPATST)) - F JJJ=2:1:9 I $P(PSOOICD,"^",JJJ)=0!($P(PSOOICD,"^",JJJ)=1) D - . I JJJ=2 S PSORX(PSOIBOLD,"VEH")=$P(PSOOICD,"^",JJJ) - . I JJJ=3 S PSORX(PSOIBOLD,"RAD")=$P(PSOOICD,"^",JJJ) - . I JJJ=4 D - .. S:PSOSCP<50 PSORX(PSOIBOLD,"SC")=$P(PSOOICD,"^",JJJ) - .. S:PSOSCP>49!($P($G(^PS(53,+$G(PSOPATST),0)),"^",7)=1) PSORX(PSOIBOLD,"SC>50")=$P(PSOOICD,"^",JJJ) - . I JJJ=5 S PSORX(PSOIBOLD,"PGW")=$P(PSOOICD,"^",JJJ) - . I JJJ=6 S PSORX(PSOIBOLD,"MST")=$P(PSOOICD,"^",JJJ) - . I JJJ=7 S PSORX(PSOIBOLD,"HNC")=$P(PSOOICD,"^",JJJ) - . I JJJ=8 S PSORX(PSOIBOLD,"CV")=$P(PSOOICD,"^",JJJ) - . I JJJ=9 S PSORX(PSOIBOLD,"SHAD")=$P(PSOOICD,"^",JJJ) - K JJJ,PSOOICD - Q +PSORN52D ;BIR/LE - files new and renewal entries con't ;02/27/04 + ;;7.0;OUTPATIENT PHARMACY;**143,219,239**;DEC 1997 + ;External reference VADPT supported by DBIA 10061 + Q +GET ;must have FILE and PSORENW variables to pull default data for ICD and SC/EI for SC>50% Rx's from file 52 + N ARRAY,ERR,SUBF,RXN,II,JJ,ORXN,SUBFLD,PENDSC,PSOPATST,PSOIBQF + I FILE=52 S SUBF=52.052311,SUBFLD=52311,RXN=PSORENW("IRXN"),(SRXN,ORXN)=PSORENW("OIRXN") S:($TR($G(^PSRX(SRXN,"IBQ")),"^")'="") PSOIBQF=1 + ; $TR checks for when patient status is exempt, null IBQ node was set for exempts, or SC>50 - data is in ICD node + I FILE=52.41 S SUBF=52.41311,SUBFLD=311,(SRXN,RXN)=ORD,ORXN=PSORENW("OIRXN") S:($TR($G(^PS(52.41,SRXN,"IBQ")),"^")'="") PSOIBQF=1 + D GETS^DIQ(FILE,SRXN,SUBFLD_"*","I","ARRAY","ERR") + K PSORX("ICD"),PSOX("ICD") + Q:'$D(ARRAY) + I FILE=52.41 S PENDSC=$$GET1^DIQ(52.41,ORD,"17"),PENDSC=$S(PENDSC="SC":1,PENDSC="NSC":0,1:"") + S PSOPATST=$$GET1^DIQ(52,RXN_",",3,"I") + ; +G1 ;get ICD, if no IBQ node get SC/EI's + F II=1:1:8 Q:'$D(ARRAY(SUBF,(II_","_SRXN_","))) D + . S PSORX("ICD",II)=ARRAY(SUBF,(II_","_SRXN_","),.01,"I") S:FILE=52.41 PSONEW("ICD",II)=PSORX("ICD",II) + . Q:II>1!($G(PSOIBQF)) ;only need ei's from 1st node; all nodes same for SC/EI + . F JJ=1:1:7 I ARRAY(SUBF,(II_","_SRXN_","),JJ,"I")=1!(ARRAY(SUBF,(II_","_SRXN_","),JJ,"I")=0) D + .. I JJ=1 S (PSOANSQ(RXN,"VEH"),PSORX(ORXN,"VEH"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I") Q + .. I JJ=2 S (PSOANSQ(RXN,"RAD"),PSORX(ORXN,"RAD"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I") Q + .. I JJ=4 S (PSOANSQ(RXN,"PGW"),PSORX(ORXN,"PGW"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I") Q + .. I JJ=5 S (PSOANSQ(RXN,"MST"),PSORX(ORXN,"MST"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I") Q + .. I JJ=6 S (PSOANSQ(RXN,"HNC"),PSORX(ORXN,"HNC"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I") Q + .. I JJ=7 S (PSOANSQ(RXN,"CV"),PSORX(ORXN,"CV"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I") Q + ; + I '$G(PSOIBQF) S II=1,JJ=3 D + . I PSOSCP>49&(FILE=52.41) S (PSOANSQ(RXN,"SC>50"),PSORX(ORXN,"SC>50"),PSOANSQ("SC>50"))=PENDSC Q + . I PSOSCP>49&(FILE'=52.41) S:$D(ARRAY(SUBF,(II_","_SRXN_","),JJ,"I")) (PSOANSQ(RXN,"SC>50"),PSOANSQ("SC>50"),PSORX(ORXN,"SC>50"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I") Q + . ; when patient status is exempt use SC>50 variable to differenciate regular SC<50 and exempt SC<50 + . I PSOSCP<50&($P($G(^PS(53,+$G(PSOPATST),0)),"^",7)=1) D + .. I FILE=52.41 S (PSOANSQ(RXN,"SC>50"),PSORX(ORXN,"SC>50"),PSOANSQ("SC>50"))=PENDSC Q + .. S:$G(ARRAY(SUBF,(II_","_SRXN_","),JJ,"I")) (PSOANSQ(RXN,"SC>50"),PSORX(ORXN,"SC>50"),PSOANSQ("SC>50"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I") + . I PSOSCP<50&($P($G(^PS(53,+$G(PSOPATST),0)),"^",7)'=1) D + .. I FILE=52.41 S (PSOANSQ(RXN,"SC"),PSORX(ORXN,"SC"),PSOANSQ("SC"))=PENDSC Q + .. S:$D(ARRAY(SUBF,(II_","_SRXN_","),JJ,"I")) (PSOANSQ(RXN,"SC"),PSORX(ORXN,"SC"),PSOANSQ("SC"))=ARRAY(SUBF,(II_","_SRXN_","),JJ,"I") + ; + Q + ; +FILE ; + Q:'$D(^PSRX(PSOX("OIRXN"),"ICD")) + N II F II=1:1:8 Q:$G(^PSRX(PSOX("OIRXN"),"ICD",II,0))="" D + . S ^PSRX(PSOX("IRXN"),"ICD",II,0)=$G(^PSRX(PSOX("OIRXN"),"ICD",II,0)) + . S:$P(^PSRX(PSOX("IRXN"),"ICD",II,0),"^",1)'="" ^PSRX(PSOX("IRXN"),"ICD","B",$P(^PSRX(PSOX("IRXN"),"ICD",II,0),"^",1),II)="" + I II>1 S ^PSRX(PSOX("IRXN"),"ICD",0)="^52.052311^"_(II-1)_"^"_(II-1) + Q +FILE2 ;file ICD's on existing node or build new nodes + ;note: variable PSOSCP2 is only available from CPRS Edit API and MISS + ; sub-routine below. + N D,RXN,II,TYPE,DATA,DATA1,PSOPATST + I $G(PSOX("IRXN")) S PSOPATST=$$GET1^DIQ(52,PSOX("IRXN")_",",3,"I") + ;I '$G(PSONEW("PATIENT STATUS")) I $G(PSOX("IRXN")) S PSONEW("PATIENT STATUS")=$$GET1^DIQ(52,PSOX("IRXN")_",",3,"I") + I $G(PSOSCP2)!($G(PSOFDR)&($G(ORD))) D + .;if RX edited in CPRS delete all but what is sent from CPRS + . K ^PSRX(PSOX("IRXN"),"ICD"),^PSRX(PSOX("IRXN"),"IBQ") + ; + S DATA="^^^^^^^",(DATA1,TYPE)="" + S $P(DATA,U,4)=$S(PSOSCP>49:$G(PSOANSQ("SC>50")),PSOSCP<50&($P($G(^PS(53,+$G(PSOPATST),0)),"^",7)=1):$G(PSOANSQ("SC>50")),PSOSCP<50&(PSOSCP'=""):$G(PSOANSQ("SC")),1:"") + ; + F S TYPE=$O(PSOANSQ(PSOX("IRXN"),TYPE)) Q:TYPE="" D + . I TYPE="VEH" S $P(DATA,U,2)=PSOANSQ(PSOX("IRXN"),"VEH") + . I TYPE="RAD" S $P(DATA,U,3)=PSOANSQ(PSOX("IRXN"),"RAD") + . I TYPE="PGW" S $P(DATA,U,5)=PSOANSQ(PSOX("IRXN"),"PGW") + . I TYPE="MST" S $P(DATA,U,6)=PSOANSQ(PSOX("IRXN"),"MST") + . I TYPE="HNC" S $P(DATA,U,7)=PSOANSQ(PSOX("IRXN"),"HNC") + . I TYPE="CV" S $P(DATA,U,8)=PSOANSQ(PSOX("IRXN"),"CV") + ; + I $O(PSORX("ICD","")) F D=1:1:8 Q:'$D(PSORX("ICD",D)) S $P(DATA,"^")=PSORX("ICD",D) D + . S ^PSRX(PSOX("IRXN"),"ICD",D,0)=DATA,$P(DATA,"^")="",^PSRX(PSOX("IRXN"),"ICD",0)="^52.052311P^"_D_"^"_D + . S:PSORX("ICD",D)'="" ^PSRX(PSOX("IRXN"),"ICD","B",PSORX("ICD",D),D)="" + E S ^PSRX(PSOX("IRXN"),"ICD",0)="^52.052311P^1^1",^PSRX(PSOX("IRXN"),"ICD",1,0)=$G(DATA) + ; + I PSOSCP<50&(($TR(DATA,"^")'=""))&(($P($G(^PS(53,+$G(PSOPATST),0)),"^",7)'=1)) D + .S DATA1=$G(PSOANSQ("SC"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"MST"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"VEH"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"RAD")) + .S DATA1=DATA1_"^"_$G(PSOANSQ(PSOX("IRXN"),"PGW"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"HNC"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"CV")) + .S:($TR(DATA1,"^")'="") ^PSRX(PSOX("IRXN"),"IBQ")=DATA1 + K PSORX("ICD") + Q + ; +RESET ;called from reset copay status PSOCPC + ;Must be available at this point: PSODA, PSOIBQ=SC^MST^AO^IR^EC^HNC^CV + Q:'$D(PSODA)!('$D(PSOIBQ)) + Q:'$D(^PSRX(PSODA)) + ;Q:'$D(^PSRX(PSODA,"ICD")) ;if old Rx and no ICD's defined; don't set + N I,DATA,PSOICD + S:$D(^PSRX(PSODA,"ICD")) PSOICD=1 + I '$G(DFN) S DFN=$$GET1^DIQ(52,PSODA_",",2,"I") + S DATA="^^^^^^^" + F I=1:1:7 D + . I I=1 S $P(DATA,"^",4)=$P(PSOIBQ,"^",I) + . I I=2 S $P(DATA,"^",6)=$P(PSOIBQ,"^",I) + . I I=3 S $P(DATA,"^",2)=$P(PSOIBQ,"^",I) + . I I=4 S $P(DATA,"^",3)=$P(PSOIBQ,"^",I) + . I I=5 S $P(DATA,"^",5)=$P(PSOIBQ,"^",I) + . I I=6 S $P(DATA,"^",7)=$P(PSOIBQ,"^",I) + . I I=7 S $P(DATA,"^",8)=$P(PSOIBQ,"^",I) + ; + I $G(PSOICD) S I=0 F S I=$O(^PSRX(PSODA,"ICD",I)) Q:I=""!(I'?1N.NN) D + . Q:'$D(^PSRX(PSODA,"ICD",I,0)) + . S $P(^PSRX(PSODA,"ICD",I,0),"^",2,8)=$P(DATA,"^",2,8) + ; for pre-cidc RX + I '$G(PSOICD) S ^PSRX(PSODA,"ICD",1,0)="^"_$P(DATA,"^",2,8),^PSRX(PSODA,"ICD",0)="^52.052311P^1^1" + Q + ; +SCP ;Called from multiple routines - DFN or PSODFN variable must be available to call this subroutine. + I '$G(DFN) S DFN=+$G(PSODFN) + D ELIG^VADPT S PSOANSQ("SC>50")="",(PSOSCA,PSOSCP)="",PSOSCP=$P(VAEL(3),U,2) + S:PSOSCP=""&($P(VAEL(3),U)=1) PSOSCP=0 + S PSOSCA=$$SC^SDCO22(DFN) + K VAEL + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORX1.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORX1.m index dc780006..edcc3f54 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORX1.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORX1.m @@ -1,159 +1,159 @@ -PSORX1 ;BIR/SAB-medication processing driver ; 1/7/07 3:32pm - ;;7.0;OUTPATIENT PHARMACY;**7,22,23,57,62,46,74,71,90,95,115,117,146,139,135,182,195,233,268,208**;DEC 1997;Build 41 - ; 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 - ;External reference PDA^PPPPDA1 supported by DBIA 1374 - ;External reference ^PS(55 supported by DBIA 2228 - ;External reference ^DIC(31 supported by DBIA 658 - ;External reference ^DPT(D0,.372 supported by DBIA 1476 - ;External reference DISPPRF^DGPFAPI supported by DBIA #4563 - ;External reference ^ORRDI1 is supported by DBIA 4659 - ;External reference ^XTMP("ORRDI" is supported by DBIA 4660 - ; - ;PSO*195 add call to display Patient Record Flag (DISPPRF^DGPFAPI) - ; -START K PSOQFLG,PSOID,PSOFIN,PSOQUIT,PSODRUG S (PSOBCK,PSOERR)=1 D INIT G:PSORX("QFLG") END - D PT G:$G(PSORX("QFLG")) END D FULL^VALM1 I $G(NOPROC) K NOPROC G NX - ;call to add bingo board data to file 52.11 - F SLPPL=0:0 S SLPPL=$O(RXRS(SLPPL)) Q:'SLPPL D - .I $P($G(^PSRX(SLPPL,"STA")),"^")'=5 K RXRS(SLPPL) Q - .S RXREC=SLPPL D WIND^PSOSUPOE I $G(PBINGRTE) D BBADD^PSOSUPOE S (BINGCRT,BINGRTE)=1 S:$G(PSOFROM)'="NEW" PSOFROM="REFILL" - K TM,TM1 I $G(PSORX("PSOL",1))]""!($D(RXRS)) D ^PSORXL K PSORX S PSOPBM1=1 - G:$G(NOBG) NX - S TM=$P(^TMP("PSOBB",$J),"^"),TM1=$P(^TMP("PSOBB",$J),"^",2) K ^TMP("PSOBB",$J) - I $G(PSOFROM)="NEW"!($G(PSOFROM)="REFILL")!($G(PSOFROM)="PARTIAL") D:$D(BINGCRT)&($D(BINGRTE)&($D(DISGROUP))) ^PSOBING1 K BINGCRT,BINGRTE,BBRX,BBFLG - I $G(PSOPBM),$G(PSOPBM1) S $P(^PS(55,PSODFN,0),"^",7)=PSOPBM,$P(^(0),"^",8)="A" K PSOPBM,PSOPBM1 -NX I $G(POERR("DEAD"))!$G(PSOQFLG) D EOJ G START - D EOJ G START -END Q - ;--------------------------------------------------------- -INIT ; - S PSORX("QFLG")=0 - D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) S PSORX("QFLG")=1 - I $P($G(PSOPAR),"^",2),'$D(^XUSEC("PSORPH",DUZ)) S PSORX("VERIFY")=1 -INITX Q - ; -PT ; - K ^TMP("PSORXDC",$J),CLOZPAT,DIC,PSODFN,PSOPBM,PSOPBM1 S PSORX("QFLG")=0,DIC=2,DIC(0)="QEAM" D ^DIC K DIC,DA - I +Y'>0 S PSORX("QFLG")=1 G PTX -OERR N:$G(MEDP) PAT,POERR K PSOXFLG S (DFN,PSODFN)=+Y,PSORX("NAME")=$P(Y,"^",2) - K NPPROC,PSOQFLG,DIC,DR,DIQ S DIC=2,DA=PSODFN,DR=.351,DIQ="PSOPTPST" D EN^DIQ1 K DIC,DA,DR,DIQ D DEAD^PSOPTPST I $G(PSOQFLG) S NOPROC=1 Q - ;PSO*195 move SSN write to here and add DISPPRF call - D ^VADPT W !!?10,$C(7),PSORX("NAME") ; correction for VOE - W " ",VA("PID") ; Correction with VOE, VA shouldn't be using SSN here! - S PSONOAL="" D ALLERGY^PSOORUT2 D I PSONOAL'="" D PAUSE - .I PSONOAL'="" W !,$C(7)," No Allergy Assessment!" - D REMOTE - N PSOUPDT - S PSOUPDT=1 - I XQY0["PSO LMOE FINISH" S PSOUPDT=0 - D CHKADDR^PSOBAI(PSODFN,1,PSOUPDT) - D:(XQY0["PSO LMOE FINISH")&('$G(SNGLPAT)) DISPPRF^DGPFAPI(PSODFN) - ; - I $P($G(^PS(55,PSODFN,"LAN")),"^") W !?10,"Patient has another language preference!",! H 3 - I $G(^PS(55,"ASTALK",PSODFN)) W !,"Patient is enrolled to receive ScripTalk 'talking' prescription labels.",! H 2 D MAIL - D NOW^%DTC S TM=$E(%,1,12),TM1=$P(TM,".",2) S ^TMP("PSOBB",$J)=TM_"^"_TM1 - I '$G(MEDP) S X="PPPPDA1" X ^%ZOSF("TEST") S:$T X=$$PDA^PPPPDA1(PSODFN) - S PSOQFLG=0,DIC="^PS(55,",DLAYGO=55 - K PSOPBM ; KILL SO THAT WON'T CARRY OVER PRIOR PATIENT'S VALUE - I '$D(^PS(55,PSODFN,0)) D - .S PSOPBM=$P(TM,".") - .K DD,DO S DIC(0)="L",(DINUM,X)=PSODFN D FILE^DICN D:Y<1 K DIC,DA,DR,DD,DO - ..S $P(^PS(55,PSODFN,0),"^")=PSODFN K DIK S DA=PSODFN,DIK="^PS(55,",DIK(1)=.01 D EN^DIK K DIK - D RXSTA - S PSOLOUD=1 D:$P($G(^PS(55,PSODFN,0)),"^",6)'=2 EN^PSOHLUP(PSODFN) K PSOLOUD - I $G(^PS(55,PSODFN,"PS"))']"" D I $G(POERR("QFLG")) G EOJ - .L +^PS(55,PSODFN):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T W $C(7),!!,"Patient Data is Being Edited by Another User!",! S POERR("QFLG")=1 S:$G(PSOFIN) PSOQUIT=1 Q - .S PSOXFLG=1,SSN=$P(^DPT(PSODFN,0),"^",9) W !!?10,$C(7),PSORX("NAME")_" ("_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)_")",! K SSN - .S DIE=55,DR=".02;.03;.04;.05;1;D ELIG^PSORX1;3;50;106;106.1",DA=PSODFN W !!,?5,">>PHARMACY PATIENT DATA<<",! D ^DIE L -^PS(55,PSODFN) - S PSOX=$G(^PS(55,PSODFN,"PS")) I PSOX]"" S PSORX("PATIENT STATUS")=$P($G(^PS(53,PSOX,0)),"^") - I $G(^PS(55,PSODFN,"PS"))']"" D I $G(POERR("QFLG")) G EOJ - .W !!,"Patient Status Required!!",! D ELIG - .W ! K POERR("QFLG"),DIC,DR,DIE S DIC("A")="RX PATIENT STATUS: ",DIC(0)="QEAMZ",DIC=53 D ^DIC K DIC - .I $D(DIRUT)!(Y=-1) D Q - ..W $C(7),"Required Data!",! S POERR("QFLG")=1 S:$G(PSOFIN) PSOQUIT=1 - ..I $G(PSOPBM) D K PSOPBM - ...I $O(^PS(55,PSODFN,0))="" S DA=PSODFN,DIK="^PS(55," D ^DIK - .S ^PS(55,PSODFN,"PS")=+Y,PSORX("PATIENT STATUS")=$P(^PS(53,+Y,0),"^") - .K DIRUT,DTOUT,DUOUT,X,Y,DA - Q:$G(PSOFIN) - I '$G(PSOPBM),'$P(^PS(55,PSODFN,0),"^",7),$P(^(0),"^",8)']"" S PSOPBM=$P(TM,".") - D ^PSOBUILD - F PT="GET","DEAD","INP","CNH","TPB","ADDRESS","COPAY" S RTN=PT_"^PSOPTPST" D @RTN Q:$G(POERR("DEAD"))!($G(PSOQFLG)) - I $G(POERR("DEAD")) S POERR("QFLG")=1 F II=0:0 S II=$O(^PS(52.41,"P",PSODFN,II)) D:$P($G(^PS(52.41,II,0)),"^",3)'="DC"&($P($G(^(0)),"^",3)'="DE") DC^PSOORFI2 - K PSOERR("DEAD"),II I $G(PSOQFLG) S POERR("QFLG")=1 G EOJ Q - S (PAT,PSOXXDFN)=PSODFN,POERR=1 D ^PSOORUT2,BLD^PSOORUT1,EN^PSOLMUTL - D CLEAR^VALM1 G:$G(PSOQUIT) PTX D EN^PSOLMAO - S (DFN,PSODFN)=PSOXXDFN K DIE,DIC,DLAYGO,DR,DA,PSOX,PSORXED -PTX ; - K X,Y,^TMP("PS",$J),C,DEA,PRC,PSCNT,PSOACT,PSOCLC,PSOCS,PSOCT,PSOFINFL,PSOHD,PSOLST,PSOOPT,PSOPF,PSOX,PSOX1,PSOXXDFN,SIGOK,STP,STR - Q -EOJ ; - K PSOERR,PSOMED,PSORX,PSOSD,PSODRUG,PSODFN,PSOOPT,PSOBILL,PSOIBQS,PSOCPAY,PSOPF,PSOPI,COMM,DGI,DGS,PT,PTDY,PTRF,RN,RTN,SERS,ST0,STAT,DFN,STOP,SLPPL,RXREC,PSOPBM - K:'$G(MEDP) PSOQFLG - D KVA^VADPT,FULL^VALM1 K PSOLST,PSOXFLG,PSCNT,PSDIS,PSOAL,P1,LOG,%,%DT,%I,D0,DAT,DFN,DRG,ORX,PSON,PSOPTPST,PSORX,PTST,PSOBCK,PSOID,PSOBXPUL - K INCOM,SIG,SG,STP,RX0,RXN,RX2,RX3,RTS,C,DEAD,PS,PSOCLC,PSOCNT,PSOCT,PSODA,PSOFROM,PSOHD,R3,REA,RF,RFD,RFM,RLD,RXNUM,RXP,RXPR,RXRP,RXRS,STR,POERR,VALMSG - K ^TMP("PSORXDC",$J),^TMP("PSOAL",$J),^TMP("PSOAO",$J),^TMP("PSOSF",$J),^TMP("PSOPF",$J),^TMP("PSOPI",$J),^TMP("PSOPO",$J),^TMP("PSOHDR",$J) I '$G(MEDP),'$G(PSOQUIT) K PAT - K PSORX,RFN,PSOXXDFN,VALM,VALMKEY,PSOBCK,SPOERR,PSOFLAG,VALMBCK,D,GMRA,GMRAL,GMRAREC,PSOSTA,PSODT,RXFL,NOBG,BBRX,BBFLG - Q -ELIG ; shows eligibility and disabilities - D ELIG^VADPT W !,"Eligibility: "_$P(VAEL(1),"^",2)_$S(+VAEL(3):" SC%: "_$P(VAEL(3),"^",2),1:"") S N=0 F S N=$O(VAEL(1,N)) Q:'N W !,?10,$P(VAEL(1,N),"^",2) - W !,"Disabilities: " F I=0:0 S I=$O(^DPT(DFN,.372,I)) Q:'I S I1=$S($D(^DPT(DFN,.372,I,0)):^(0),1:"") D:+I1 - .S PSDIS=$S($P($G(^DIC(31,+I1,0)),"^")]""&($P($G(^(0)),"^",4)']""):$P(^(0),"^"),$P($G(^DIC(31,+I1,0)),"^",4)]"":$P(^(0),"^",4),1:""),PSCNT=$P(I1,"^",2) - .W:$L(PSDIS_"-"_PSCNT_"% ("_$S($P(I1,"^",3):"SC",1:"NSC")_"), ")>80 !,?15 - .W $S($G(PSDIS)]"":PSDIS_"-",1:"")_PSCNT_"% ("_$S($P(I1,"^",3):"SC",1:"NSC")_"), " - K N - Q -PROFILE ; - S (PSORX("REFILL"),PSORX("RENEW"))=0,PSOX="" D ^PSOBUILD - I '$G(PSOSD) W !,"This patient has no prescriptions" S:'$D(DFN) DFN=PSODFN D GMRA^PSODEM G PROFILEX - S (PSODRG,PSOX)="" F S PSODRG=$O(PSOSD(PSODRG)) Q:PSODRG="" F S PSOX=$O(PSOSD(PSODRG,PSOX)) Q:PSOX="" S:$P(PSOSD(PSODRG,PSOX),"^",3)="" PSORX("RENEW")=1 S:$P(PSOSD(PSODRG,PSOX),"^",4)="" PSORX("REFILL")=1 - K PSOX -PROFILEX Q - ; -MAIL ; MAKE SURE MAIL STATUS IS COMPATIBLE WITH SCRIPTALK PATIENT - I $P($G(^PS(59,PSOSITE,"STALK")),"^")="" Q ; NO SCRIPTALK PRINTER SET UP FOR THIS DIVISION - N MAIL - S MAIL=$G(^PS(55,PSODFN,0)) I $P(MAIL,"^",3)>1 Q -MAILP W !!,"REMINDER: CMOP does not fill ScripTalk prescriptions.Please select mail" - W !,"status: 2 (DO NOT MAIL), 3 (LOCAL REGULAR MAIL) or 4 (LOCAL CERTFIED MAIL)." - R !,"MAIL: ",MAIL:120 - I MAIL?1"^".E Q - I MAIL<2!(MAIL>4) W !,"INVALID MAIL SETTING - ENTER 2,3, OR 4" G MAILP - W " ",$S(MAIL=2:"DO NOT MAIL",MAIL=3:"LOCAL REGULAR MAIL",1:"LOCAL CERTIFIED MAIL") - S $P(^PS(55,PSODFN,0),"^",3)=MAIL - Q -REMOTE ; - I $T(HAVEHDR^ORRDI1)']"" Q - I '$$HAVEHDR^ORRDI1 Q - I $D(^XTMP("ORRDI","OUTAGE INFO","DOWN")) W !,"Remote data not available - Only local order checks processed." D Q - .K DIR W ! S DIR(0)="EA",DIR("A")="Press Return to continue..." D ^DIR W ! K DIR - Q -PAUSE ; - W ! K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR - Q - ; -RXSTA ; DISPLAY ELIGIBILITY & PROMPT FOR RX PATIENT STATUS - N DA,PSOSTA - I '$G(PSODFN) Q - S DA=PSODFN,PSOSTA=$G(^PS(55,PSODFN,"PS")) - I XQY0["PSO LMOE FINISH"!(XQY0["PSO LM BACKDOOR ORDERS") I PSOSTA]"" D - .D ELIG^VADPT W !,"Eligibility: "_$P(VAEL(1),"^",2)_$S(+VAEL(3):" SC%: "_$P(VAEL(3),"^",2),1:"") - .S N=0 F S N=$O(VAEL(1,N)) Q:'N W !,?10,$P(VAEL(1,N),"^",2) - .S DIC("A")="RX PATIENT STATUS: ",DIC("B")=PSOSTA,DIC(0)="QEAMZ",DIC=53 D ^DIC K DIC - .I +Y>0,+Y'=PSOSTA S DIE="^PS(55,",DR="3////"_+Y D ^DIE - Q +PSORX1 ;BIR/SAB-medication processing driver ; 1/7/07 3:32pm + ;;7.0;OUTPATIENT PHARMACY;**7,22,23,57,62,46,74,71,90,95,115,117,146,139,135,182,195,233,268,208**;DEC 1997;Build 39 + ; 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 + ;External reference PDA^PPPPDA1 supported by DBIA 1374 + ;External reference ^PS(55 supported by DBIA 2228 + ;External reference ^DIC(31 supported by DBIA 658 + ;External reference ^DPT(D0,.372 supported by DBIA 1476 + ;External reference DISPPRF^DGPFAPI supported by DBIA #4563 + ;External reference ^ORRDI1 is supported by DBIA 4659 + ;External reference ^XTMP("ORRDI" is supported by DBIA 4660 + ; + ;PSO*195 add call to display Patient Record Flag (DISPPRF^DGPFAPI) + ; +START K PSOQFLG,PSOID,PSOFIN,PSOQUIT,PSODRUG S (PSOBCK,PSOERR)=1 D INIT G:PSORX("QFLG") END + D PT G:$G(PSORX("QFLG")) END D FULL^VALM1 I $G(NOPROC) K NOPROC G NX + ;call to add bingo board data to file 52.11 + F SLPPL=0:0 S SLPPL=$O(RXRS(SLPPL)) Q:'SLPPL D + .I $P($G(^PSRX(SLPPL,"STA")),"^")'=5 K RXRS(SLPPL) Q + .S RXREC=SLPPL D WIND^PSOSUPOE I $G(PBINGRTE) D BBADD^PSOSUPOE S (BINGCRT,BINGRTE)=1 S:$G(PSOFROM)'="NEW" PSOFROM="REFILL" + K TM,TM1 I $G(PSORX("PSOL",1))]""!($D(RXRS)) D ^PSORXL K PSORX S PSOPBM1=1 + G:$G(NOBG) NX + S TM=$P(^TMP("PSOBB",$J),"^"),TM1=$P(^TMP("PSOBB",$J),"^",2) K ^TMP("PSOBB",$J) + I $G(PSOFROM)="NEW"!($G(PSOFROM)="REFILL")!($G(PSOFROM)="PARTIAL") D:$D(BINGCRT)&($D(BINGRTE)&($D(DISGROUP))) ^PSOBING1 K BINGCRT,BINGRTE,BBRX,BBFLG + I $G(PSOPBM),$G(PSOPBM1) S $P(^PS(55,PSODFN,0),"^",7)=PSOPBM,$P(^(0),"^",8)="A" K PSOPBM,PSOPBM1 +NX I $G(POERR("DEAD"))!$G(PSOQFLG) D EOJ G START + D EOJ G START +END Q + ;--------------------------------------------------------- +INIT ; + S PSORX("QFLG")=0 + D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) S PSORX("QFLG")=1 + I $P($G(PSOPAR),"^",2),'$D(^XUSEC("PSORPH",DUZ)) S PSORX("VERIFY")=1 +INITX Q + ; +PT ; + K ^TMP("PSORXDC",$J),CLOZPAT,DIC,PSODFN,PSOPBM,PSOPBM1 S PSORX("QFLG")=0,DIC=2,DIC(0)="QEAM" D ^DIC K DIC,DA + I +Y'>0 S PSORX("QFLG")=1 G PTX +OERR N:$G(MEDP) PAT,POERR K PSOXFLG S (DFN,PSODFN)=+Y,PSORX("NAME")=$P(Y,"^",2) + K NPPROC,PSOQFLG,DIC,DR,DIQ S DIC=2,DA=PSODFN,DR=.351,DIQ="PSOPTPST" D EN^DIQ1 K DIC,DA,DR,DIQ D DEAD^PSOPTPST I $G(PSOQFLG) S NOPROC=1 Q + ;PSO*195 move SSN write to here and add DISPPRF call + D ^VADPT W !!?10,$C(7),PSORX("NAME") ; correction for VOE + W " ",VA("PID") ; Correction with VOE, VA shouldn't be using SSN here! + S PSONOAL="" D ALLERGY^PSOORUT2 D I PSONOAL'="" D PAUSE + .I PSONOAL'="" W !,$C(7)," No Allergy Assessment!" + D REMOTE + N PSOUPDT + S PSOUPDT=1 + I XQY0["PSO LMOE FINISH" S PSOUPDT=0 + D CHKADDR^PSOBAI(PSODFN,1,PSOUPDT) + D:(XQY0["PSO LMOE FINISH")&('$G(SNGLPAT)) DISPPRF^DGPFAPI(PSODFN) + ; + I $P($G(^PS(55,PSODFN,"LAN")),"^") W !?10,"Patient has another language preference!",! H 3 + I $G(^PS(55,"ASTALK",PSODFN)) W !,"Patient is enrolled to receive ScripTalk 'talking' prescription labels.",! H 2 D MAIL + D NOW^%DTC S TM=$E(%,1,12),TM1=$P(TM,".",2) S ^TMP("PSOBB",$J)=TM_"^"_TM1 + I '$G(MEDP) S X="PPPPDA1" X ^%ZOSF("TEST") S:$T X=$$PDA^PPPPDA1(PSODFN) + S PSOQFLG=0,DIC="^PS(55,",DLAYGO=55 + K PSOPBM ; KILL SO THAT WON'T CARRY OVER PRIOR PATIENT'S VALUE + I '$D(^PS(55,PSODFN,0)) D + .S PSOPBM=$P(TM,".") + .K DD,DO S DIC(0)="L",(DINUM,X)=PSODFN D FILE^DICN D:Y<1 K DIC,DA,DR,DD,DO + ..S $P(^PS(55,PSODFN,0),"^")=PSODFN K DIK S DA=PSODFN,DIK="^PS(55,",DIK(1)=.01 D EN^DIK K DIK + D RXSTA + S PSOLOUD=1 D:$P($G(^PS(55,PSODFN,0)),"^",6)'=2 EN^PSOHLUP(PSODFN) K PSOLOUD + I $G(^PS(55,PSODFN,"PS"))']"" D I $G(POERR("QFLG")) G EOJ + .L +^PS(55,PSODFN):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T W $C(7),!!,"Patient Data is Being Edited by Another User!",! S POERR("QFLG")=1 S:$G(PSOFIN) PSOQUIT=1 Q + .S PSOXFLG=1,SSN=$P(^DPT(PSODFN,0),"^",9) W !!?10,$C(7),PSORX("NAME")_" ("_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)_")",! K SSN + .S DIE=55,DR=".02;.03;.04;.05;1;D ELIG^PSORX1;3;50;106;106.1",DA=PSODFN W !!,?5,">>PHARMACY PATIENT DATA<<",! D ^DIE L -^PS(55,PSODFN) + S PSOX=$G(^PS(55,PSODFN,"PS")) I PSOX]"" S PSORX("PATIENT STATUS")=$P($G(^PS(53,PSOX,0)),"^") + I $G(^PS(55,PSODFN,"PS"))']"" D I $G(POERR("QFLG")) G EOJ + .W !!,"Patient Status Required!!",! D ELIG + .W ! K POERR("QFLG"),DIC,DR,DIE S DIC("A")="RX PATIENT STATUS: ",DIC(0)="QEAMZ",DIC=53 D ^DIC K DIC + .I $D(DIRUT)!(Y=-1) D Q + ..W $C(7),"Required Data!",! S POERR("QFLG")=1 S:$G(PSOFIN) PSOQUIT=1 + ..I $G(PSOPBM) D K PSOPBM + ...I $O(^PS(55,PSODFN,0))="" S DA=PSODFN,DIK="^PS(55," D ^DIK + .S ^PS(55,PSODFN,"PS")=+Y,PSORX("PATIENT STATUS")=$P(^PS(53,+Y,0),"^") + .K DIRUT,DTOUT,DUOUT,X,Y,DA + Q:$G(PSOFIN) + I '$G(PSOPBM),'$P(^PS(55,PSODFN,0),"^",7),$P(^(0),"^",8)']"" S PSOPBM=$P(TM,".") + D ^PSOBUILD + F PT="GET","DEAD","INP","CNH","TPB","ADDRESS","COPAY" S RTN=PT_"^PSOPTPST" D @RTN Q:$G(POERR("DEAD"))!($G(PSOQFLG)) + I $G(POERR("DEAD")) S POERR("QFLG")=1 F II=0:0 S II=$O(^PS(52.41,"P",PSODFN,II)) D:$P($G(^PS(52.41,II,0)),"^",3)'="DC"&($P($G(^(0)),"^",3)'="DE") DC^PSOORFI2 + K PSOERR("DEAD"),II I $G(PSOQFLG) S POERR("QFLG")=1 G EOJ Q + S (PAT,PSOXXDFN)=PSODFN,POERR=1 D ^PSOORUT2,BLD^PSOORUT1,EN^PSOLMUTL + D CLEAR^VALM1 G:$G(PSOQUIT) PTX D EN^PSOLMAO + S (DFN,PSODFN)=PSOXXDFN K DIE,DIC,DLAYGO,DR,DA,PSOX,PSORXED +PTX ; + K X,Y,^TMP("PS",$J),C,DEA,PRC,PSCNT,PSOACT,PSOCLC,PSOCS,PSOCT,PSOFINFL,PSOHD,PSOLST,PSOOPT,PSOPF,PSOX,PSOX1,PSOXXDFN,SIGOK,STP,STR + Q +EOJ ; + K PSOERR,PSOMED,PSORX,PSOSD,PSODRUG,PSODFN,PSOOPT,PSOBILL,PSOIBQS,PSOCPAY,PSOPF,PSOPI,COMM,DGI,DGS,PT,PTDY,PTRF,RN,RTN,SERS,ST0,STAT,DFN,STOP,SLPPL,RXREC,PSOPBM + K:'$G(MEDP) PSOQFLG + D KVA^VADPT,FULL^VALM1 K PSOLST,PSOXFLG,PSCNT,PSDIS,PSOAL,P1,LOG,%,%DT,%I,D0,DAT,DFN,DRG,ORX,PSON,PSOPTPST,PSORX,PTST,PSOBCK,PSOID,PSOBXPUL + K INCOM,SIG,SG,STP,RX0,RXN,RX2,RX3,RTS,C,DEAD,PS,PSOCLC,PSOCNT,PSOCT,PSODA,PSOFROM,PSOHD,R3,REA,RF,RFD,RFM,RLD,RXNUM,RXP,RXPR,RXRP,RXRS,STR,POERR,VALMSG + K ^TMP("PSORXDC",$J),^TMP("PSOAL",$J),^TMP("PSOAO",$J),^TMP("PSOSF",$J),^TMP("PSOPF",$J),^TMP("PSOPI",$J),^TMP("PSOPO",$J),^TMP("PSOHDR",$J) I '$G(MEDP),'$G(PSOQUIT) K PAT + K PSORX,RFN,PSOXXDFN,VALM,VALMKEY,PSOBCK,SPOERR,PSOFLAG,VALMBCK,D,GMRA,GMRAL,GMRAREC,PSOSTA,PSODT,RXFL,NOBG,BBRX,BBFLG + Q +ELIG ; shows eligibility and disabilities + D ELIG^VADPT W !,"Eligibility: "_$P(VAEL(1),"^",2)_$S(+VAEL(3):" SC%: "_$P(VAEL(3),"^",2),1:"") S N=0 F S N=$O(VAEL(1,N)) Q:'N W !,?10,$P(VAEL(1,N),"^",2) + W !,"Disabilities: " F I=0:0 S I=$O(^DPT(DFN,.372,I)) Q:'I S I1=$S($D(^DPT(DFN,.372,I,0)):^(0),1:"") D:+I1 + .S PSDIS=$S($P($G(^DIC(31,+I1,0)),"^")]""&($P($G(^(0)),"^",4)']""):$P(^(0),"^"),$P($G(^DIC(31,+I1,0)),"^",4)]"":$P(^(0),"^",4),1:""),PSCNT=$P(I1,"^",2) + .W:$L(PSDIS_"-"_PSCNT_"% ("_$S($P(I1,"^",3):"SC",1:"NSC")_"), ")>80 !,?15 + .W $S($G(PSDIS)]"":PSDIS_"-",1:"")_PSCNT_"% ("_$S($P(I1,"^",3):"SC",1:"NSC")_"), " + K N + Q +PROFILE ; + S (PSORX("REFILL"),PSORX("RENEW"))=0,PSOX="" D ^PSOBUILD + I '$G(PSOSD) W !,"This patient has no prescriptions" S:'$D(DFN) DFN=PSODFN D GMRA^PSODEM G PROFILEX + S (PSODRG,PSOX)="" F S PSODRG=$O(PSOSD(PSODRG)) Q:PSODRG="" F S PSOX=$O(PSOSD(PSODRG,PSOX)) Q:PSOX="" S:$P(PSOSD(PSODRG,PSOX),"^",3)="" PSORX("RENEW")=1 S:$P(PSOSD(PSODRG,PSOX),"^",4)="" PSORX("REFILL")=1 + K PSOX +PROFILEX Q + ; +MAIL ; MAKE SURE MAIL STATUS IS COMPATIBLE WITH SCRIPTALK PATIENT + I $P($G(^PS(59,PSOSITE,"STALK")),"^")="" Q ; NO SCRIPTALK PRINTER SET UP FOR THIS DIVISION + N MAIL + S MAIL=$G(^PS(55,PSODFN,0)) I $P(MAIL,"^",3)>1 Q +MAILP W !!,"REMINDER: CMOP does not fill ScripTalk prescriptions.Please select mail" + W !,"status: 2 (DO NOT MAIL), 3 (LOCAL REGULAR MAIL) or 4 (LOCAL CERTFIED MAIL)." + R !,"MAIL: ",MAIL:120 + I MAIL?1"^".E Q + I MAIL<2!(MAIL>4) W !,"INVALID MAIL SETTING - ENTER 2,3, OR 4" G MAILP + W " ",$S(MAIL=2:"DO NOT MAIL",MAIL=3:"LOCAL REGULAR MAIL",1:"LOCAL CERTIFIED MAIL") + S $P(^PS(55,PSODFN,0),"^",3)=MAIL + Q +REMOTE ; + I $T(HAVEHDR^ORRDI1)']"" Q + I '$$HAVEHDR^ORRDI1 Q + I $D(^XTMP("ORRDI","OUTAGE INFO","DOWN")) W !,"Remote data not available - Only local order checks processed." D Q + .K DIR W ! S DIR(0)="EA",DIR("A")="Press Return to continue..." D ^DIR W ! K DIR + Q +PAUSE ; + W ! K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR + Q + ; +RXSTA ; DISPLAY ELIGIBILITY & PROMPT FOR RX PATIENT STATUS + N DA,PSOSTA + I '$G(PSODFN) Q + S DA=PSODFN,PSOSTA=$G(^PS(55,PSODFN,"PS")) + I XQY0["PSO LMOE FINISH"!(XQY0["PSO LM BACKDOOR ORDERS") I PSOSTA]"" D + .D ELIG^VADPT W !,"Eligibility: "_$P(VAEL(1),"^",2)_$S(+VAEL(3):" SC%: "_$P(VAEL(3),"^",2),1:"") + .S N=0 F S N=$O(VAEL(1,N)) Q:'N W !,?10,$P(VAEL(1,N),"^",2) + .S DIC("A")="RX PATIENT STATUS: ",DIC("B")=PSOSTA,DIC(0)="QEAMZ",DIC=53 D ^DIC K DIC + .I +Y>0,+Y'=PSOSTA S DIE="^PS(55,",DR="3////"_+Y D ^DIE + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXDL.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXDL.m index 0a18ae68..0f05fb16 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXDL.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXDL.m @@ -1,128 +1,126 @@ -PSORXDL ;BIR/SAB - Deletes one prescription ;06/10/96 - ;;7.0;OUTPATIENT PHARMACY;**4,17,9,27,117,131,148,201,291**;DEC 1997;Build 2 - ;External reference to ^PS(55 supported by DBIA 2228 - ;External references L, UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789 - ;External reference to ^PS(59.7 supported by DBIA 694 - ;External reference to ^PSDRUG( supported by DBIA 221 - I '$D(^XUSEC("PSORPH",DUZ)) W !,$C(7),"Requires Pharmacy Key (PSORPH) !" Q - I '$D(PSOPAR) D ^PSOLSET I '$D(PSOPAR) W $C(7),!!,"SITE PARAMETERS MUST BE DEFINED!",! Q - K DA,PSODEFLG,PSOHLRE,PSOHLDAH,QTY,PSOABCDA,PSOREF - S (PSDEL,PSOXXDEL)=1,PS="DELETE",DIC("S")="I $P($G(^(0)),""^"",2),$P($G(^(""STA"")),""^"")'=13,$G(^(2))" - D A1^PSORXVW K DIC("S") I $G(DA)<1 G KILL - D FULL^VALM1 - S RXN=+$G(DA) - S PSORXDFN=+$P($G(^PSRX(RXN,0)),"^",2) - S PSOPLCK=$$L^PSSLOCK(PSORXDFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY K PSOPLCK G PSORXDL - K PSOPLCK D PSOL^PSSLOCK(RXN) I '$G(PSOMSG) W !,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),! K PSOMSG D ULP G PSORXDL - S (REL,PSOGGFL)=0 F PSOGG=0:0 S PSOGG=$O(^PSRX(DA,1,PSOGG)) Q:'PSOGG S:$D(^PSRX(DA,1,PSOGG,0)) PSOGGFL=PSOGG - S REL=$S($G(PSOGGFL)&($P($G(^PSRX(DA,1,+$G(PSOGGFL),0)),"^",18))&('$P($G(^(0)),"^",16)):1,'$G(PSOGGFL)&($P($G(^PSRX(DA,2)),"^",13))&('$P($G(^(2)),"^",15)):1,1:0) - I REL W !!,$S($G(PSOGGFL):"Refill number "_$G(PSOGGFL),1:"The Original Fill")," has already been released for Rx # "_$P($G(^PSRX(DA,0)),"^") - I REL W !,"Drug: ",$P($G(^PSDRUG(+$P($G(^PSRX(DA,0)),"^",6),0)),"^"),?49,$P($G(^DPT(+$P($G(^PSRX(DA,0)),"^",2),0)),"^") - I REL W ! K DIR S DIR(0)="Y",DIR("A")="Return this fill to stock and delete the prescription",DIR("B")="N" D D ^DIR K DIR G:$G(Y)=1 PASS W !!?5,"No Action Taken.",! D ULK,ULP,KILL G PSORXDL - .S DIR("?")=" ",DIR("?",1)="Enter 'Y' to return this last fill to stock and continue with the deleting of",DIR("?",2)="this prescription, enter 'N' to exit." - K DIR S DIR(0)="Y",DIR("A",1)="Are you sure you want to DELETE Rx # "_$P(^PSRX(DA,0),"^"),DIR("A",2)="Drug: "_$P(^PSDRUG($P(^PSRX(DA,0),"^",6),0),"^") - S DIR("A")="for "_$P(^DPT($P(^PSRX(DA,0),"^",2),0),"^") - S DIR("B")="NO" D ^DIR D:$D(DTOUT) ULK,ULP G:$D(DTOUT) KILL I $D(DIRUT)!'Y D ULK,ULP,KILL G PSORXDL -PASS N PSORXDAC K PSOXYZF S PSORXDAC=$O(^PS(52.5,"B",DA,0)) I PSORXDAC,$P($G(^PS(52.5,PSORXDAC,0)),"^",7)="L" N PSOXYZ S PSOXYZF=0 W !!,"Please wait, Rx is Loading for CMOP Transmission.." D - .F PSOXYZ=1:1:5 W "." H 1 I $P($G(^PS(52.5,PSORXDAC,0)),"^",7)'="L" S PSOXYZF=1 - I $G(PSOXYZF)=0 W !!,"Sorry, still loading for CMOP transmission, try again later.",! D ULK,ULP,KILL K PSOXYZF G PSORXDL - K PSOXYZF - I $G(REL) S PSOHLRE=REL,PSOHLDAH=$G(DA) - I $G(REL) S RXP=DA S PSODEFLG=0 D RESK I $G(PSODEFLG) D ULK,ULP,KILL G PSORXDL - I $G(PSOHLRE) W !!?5,"Deleting prescription..",! S DA=$G(PSOHLDAH),REL=$G(PSOHLRE) - S PSOABCDA=$G(DA) D NOOR^PSOCAN4 I $D(DIRUT) W " NO ACTION TAKEN!",! D ULK,ULP,KILL G PSORXDL - S DA=$G(PSOABCDA) K DIR,PSOABCDA S DIR("A")="Comments",DIR("B")="Per Pharmacy Request",DIR(0)="F^5:100" D ^DIR K DIR I $D(DIRUT) W !!?5,"NO ACTION TAKEN!",! D ULK,ULP G KILL - I $G(PKI1) N INCOM S INCOM=Y D DCV^PSOPKIV1,ULK,ULP G PSORXDL -ENQ S PSOIB=$S($D(^PSRX(DA,"IB")):^PSRX(DA,"IB"),1:0) ;Check if copay - S RX=^PSRX(DA,0),RXN=DA - S $P(^PSRX(RXN,"STA"),"^")=13,$P(^PSRX(RXN,"D"),"^")=$G(Y) - S DA=RXN K ^PSRX("ACP",$P(^PSRX(DA,0),"^",2),+$P(^(2),"^",2),0,DA) D ACT - S DA=RXN I $G(^PSRX(DA,"H"))]"" K ^PSRX("AH",+$P(^PSRX(DA,"H"),"^"),DA) S ^PSRX(DA,"H")="" - D EN^PSOHLSN1(DA,"OC","",$P(^PSRX(DA,"D"),"^"),PSONOOR) - S DA=$O(^PS(52.5,"B",RXN,0)) I DA S DIK="^PS(52.5," D ^DIK - S DA=RXN I $D(^PS(52.4,RXN)) S DIK="^PS(52.4," D ^DIK - K PSOABCDA I $G(DA) S PSOABCDA=$G(DA) - I $O(^PS(52.41,"ARF",RXN,0)) S DA=$O(^PS(52.41,"ARF",RXN,0)),DIK="^PS(52.41," D ^DIK K DA,DIK - I $G(PSOABCDA) S DA=$G(PSOABCDA) - I $G(PSOABCDA) S DA=$G(PSOABCDA) K PSOABCDA - Q:+$G(PSORX("INTERVENE"))!($G(PSVFLAG)) I $D(DA),'$G(PSOZVER) D ULK,ULP G PSORXDL - S ^PSDRUG(+$P(RX,"^",6),660.1)=$S($D(^PSDRUG(+$P(RX,"^",6),660.1)):^(660.1),1:0)+$P(RX,"^",7) - S DFN=+$P(RX,"^",2) F I=0:0 S I=$O(^PS(55,DFN,"P",I)) Q:'I I +^(I,0)=RXN K ^(0) S ^(0)=$P(^PS(55,DFN,"P",0),"^",1,3)_"^"_($P(^(0),"^",4)-1) - F I=0:0 S I=$O(^PS(55,DFN,"P","A",I)) Q:'I I $D(^(I,RXN)) K ^(RXN) - K STAT,COM,RX,RXN Q:+$G(PSORX("INTERVENE"))!($G(PSVFLAG)) I $G(PSDEL) D ULK,ULP G PSORXDL - ; -KILL K PSORXDFN,PSOMSG,PSOPLCK,RXO,RX0,RX2,RESK,PSIN,PSODEF,PSOPCECT,PSDEL,I,II,J,N,PHYS,PS,RFDATE,RFL,RFL1,ST,ST0,%,%Y,D0,DA,DI,DIC,DIE,DIH,DIU,DIV,DR,Z,DIG,X,Y,PSOIB,RX,RXN,PSODEFLG,PSOREF,PSOHLRE,PSOHLDAH,PSOGG,PSODLCOM,COPAYFLG - K DIR,RXP,DIRUT,DUOUT,DTOUT,SIGOK,REL,PSONODF,PSONOOR,PSOGGFL,PSOXYZF,TYPE,XTYPE,QDRUG,QTY,PSOWHERE,PSOLOCRL,PSOCPRX,PSODT,PSODA,PSOINVTX,IFN,PSROF,PSOABCDA,PSOXXDEL,PSOPFS - Q -ACT ;adds activity info for deleted rx - S (RXF,PSOREF)=0 F I=0:0 S I=$O(^PSRX(RXN,1,I)) Q:'I S (RXF,PSOREF)=I S:I>5 RXF=I+1 K ^PSRX("ACP",$P(^PSRX(RXN,0),"^",2),$P(^PSRX(RXN,1,I,0),"^"),I,RXN) - S DA=0 F FDA=0:0 S FDA=$O(^PSRX(RXN,"A",FDA)) Q:'FDA S DA=FDA - D NOW^%DTC S DA=DA+1,^PSRX(RXN,"A",0)="^52.3DA^"_DA_"^"_DA,^PSRX(RXN,"A",DA,0)=%_"^"_"D"_"^"_DUZ_"^"_RXF_"^"_"RX DELETED on "_$E(DT,4,5)_"-"_$E(DT,6,7)_"-"_$E(DT,2,3) -EX W !,"...PRESCRIPTION #"_$P(RX,"^")_" MARKED DELETED!!" - K RXF,I,FDA,DIC,DIE,%,%I,%H S DA=RXN - ; - Sending Refill to ECME for claim REVERSAL (Rx Delete) - D REVERSE^PSOBPSU1(RXN,PSOREF,"DE",5,,1) - Q -RESK ; - S RESK=1,PSIN=+$P(^PS(59.7,1,49.99),"^",2) K PSODEF S PSOPCECT=1 - S PSOLOUD=1 D:$P($G(^PS(55,+$P(^PSRX(RXP,0),"^",2),0)),"^",6)'=2 EN^PSOHLUP($P(^PSRX(RXP,0),"^",2)) K PSOLOUD - I $S('+$P($G(^PSRX(+RXP,"STA")),"^"):0,$P(^("STA"),"^")=11:0,$P(^("STA"),"^")=12:0,$P(^("STA"),"^")=14:0,$P(^("STA"),"^")=15:0,1:1) D STAT^PSORESK1 S PSODEFLG=1 Q - W !!?5,"Returning Medication to Stock..",! - K DIR,PSODLCOM,COM S DIR(0)="F^10:75",DIR("A")="Comments",DIR("?")="Comments are required, 10-75 characters." W ! D ^DIR K DIR S (COM,PSODLCOM)=Y I Y["^"!($D(DIRUT)) W !!,"No Action Taken!",! S PSODEFLG=1 Q - S QDRUG=+$P($G(^PSRX(RXP,0)),"^",6),QTY=$P($G(^(0)),"^",7) I $O(^PSRX(RXP,1,0)) G REF - S XTYPE="O" I $P($G(^PSRX(RXP,2)),"^",15) Q - I $P($G(^PSRX(RXP,2)),"^",2)<$G(PSIN) Q - K PSOLOCRL,PSOWHERE S PSOLOCRL=$P($G(^PSRX(RXP,2)),"^",13) - Q:'$G(PSOLOCRL) - S PSOWHERE=$S($D(^PSRX("AR",$G(PSOLOCRL),RXP,0)):1,1:0) - I +$G(^PSRX(RXP,"IB"))!($P($G(^PSRX(RXP,"PFS")),"^",2)) S COPAYFLG=1 N PSOPFS S:$P($G(^PSRX(RXP,"PFS")),"^",2) PSOPFS="1^"_$P(^PSRX(RXP,"PFS"),"^",1,2) D CP^PSORESK1 I '$G(COPAYFLG) S PSODEFLG=1 Q - I $G(^PSDRUG(QDRUG,660.1)),$G(PSOWHERE) D INVT W:$G(PSODEFLG) !!?5,"No Action Taken!",! Q:$G(PSODEFLG) I $G(PSOINVTX) D INVINC - I $G(^PSDRUG(QDRUG,660.1)),'$G(PSOWHERE) D INVINC - I $G(PSOWHERE) K ^PSRX("AR",$G(PSOLOCRL),RXP,0) - D NOW^%DTC K DIE S DA=RXP,DIE="^PSRX(",DR="31///@;32.1///"_% D ^DIE K DIE - ;D EN^PSOHLSN1(RXP,"ZD") - D ACT^PSORESK1 - S DA=$O(^PS(52.5,"B",RXP,0)) I DA K DIK S DIK="^PS(52.5," D ^DIK K DIK - D EN^PSOHLSN1(RXP,"ZD") - W !,"Rx # "_$P($G(^PSRX(RXP,0)),"^")_" Returned to Stock.",! - ; - Sending Rx to ECME for claim REVERSAL (Return to Stock) - D REVERSE^PSOBPSU1(RXP,0,"RS",4,,1) - Q -REF ; - K TYPE F PSROF=0:0 S PSROF=$O(^PSRX(RXP,1,PSROF)) Q:'PSROF S:$P($G(^PSRX(RXP,1,PSROF,0)),"^") TYPE=PSROF - I '$G(TYPE) Q - S XTYPE=1 - I $P($G(^PSRX(RXP,1,TYPE,0)),"^",16) Q - I '$P($G(^PSRX(RXP,1,TYPE,0)),"^",18) Q - I '$P($G(^PSRX(RXP,1,TYPE,0)),"^",18),$P($G(^(0)),"^")'5 RXF=I+1 K ^PSRX("ACP",$P(^PSRX(RXN,0),"^",2),$P(^PSRX(RXN,1,I,0),"^"),I,RXN) + S DA=0 F FDA=0:0 S FDA=$O(^PSRX(RXN,"A",FDA)) Q:'FDA S DA=FDA + D NOW^%DTC S DA=DA+1,^PSRX(RXN,"A",0)="^52.3DA^"_DA_"^"_DA,^PSRX(RXN,"A",DA,0)=%_"^"_"D"_"^"_DUZ_"^"_RXF_"^"_"RX DELETED on "_$E(DT,4,5)_"-"_$E(DT,6,7)_"-"_$E(DT,2,3) +EX W !,"...PRESCRIPTION #"_$P(RX,"^")_" MARKED DELETED!!" + K RXF,I,FDA,DIC,DIE,%,%I,%H S DA=RXN + ; - Sending Refill to ECME for claim REVERSAL (Rx Delete) + D REVERSE^PSOBPSU1(RXN,PSOREF,"DE",5,,1) + Q +RESK ; + S RESK=1,PSIN=+$P(^PS(59.7,1,49.99),"^",2) K PSODEF S PSOPCECT=1 + S PSOLOUD=1 D:$P($G(^PS(55,+$P(^PSRX(RXP,0),"^",2),0)),"^",6)'=2 EN^PSOHLUP($P(^PSRX(RXP,0),"^",2)) K PSOLOUD + I $S('+$P($G(^PSRX(+RXP,"STA")),"^"):0,$P(^("STA"),"^")=11:0,$P(^("STA"),"^")=12:0,$P(^("STA"),"^")=14:0,$P(^("STA"),"^")=15:0,1:1) D STAT^PSORESK1 S PSODEFLG=1 Q + W !!?5,"Returning Medication to Stock..",! + K DIR,PSODLCOM,COM S DIR(0)="F^10:75",DIR("A")="Comments",DIR("?")="Comments are required, 10-75 characters." W ! D ^DIR K DIR S (COM,PSODLCOM)=Y I Y["^"!($D(DIRUT)) W !!,"No Action Taken!",! S PSODEFLG=1 Q + S QDRUG=+$P($G(^PSRX(RXP,0)),"^",6),QTY=$P($G(^(0)),"^",7) I $O(^PSRX(RXP,1,0)) G REF + S XTYPE="O" I $P($G(^PSRX(RXP,2)),"^",15) Q + I $P($G(^PSRX(RXP,2)),"^",2)<$G(PSIN) Q + K PSOLOCRL,PSOWHERE S PSOLOCRL=$P($G(^PSRX(RXP,2)),"^",13) + Q:'$G(PSOLOCRL) + S PSOWHERE=$S($D(^PSRX("AR",$G(PSOLOCRL),RXP,0)):1,1:0) + I +$G(^PSRX(RXP,"IB"))!($P($G(^PSRX(RXP,"PFS")),"^",2)) S COPAYFLG=1 N PSOPFS S:$P($G(^PSRX(RXP,"PFS")),"^",2) PSOPFS="1^"_$P(^PSRX(RXP,"PFS"),"^",1,2) D CP^PSORESK1 I '$G(COPAYFLG) S PSODEFLG=1 Q + I $G(^PSDRUG(QDRUG,660.1)),$G(PSOWHERE) D INVT W:$G(PSODEFLG) !!?5,"No Action Taken!",! Q:$G(PSODEFLG) I $G(PSOINVTX) D INVINC + I $G(^PSDRUG(QDRUG,660.1)),'$G(PSOWHERE) D INVINC + I $G(PSOWHERE) K ^PSRX("AR",$G(PSOLOCRL),RXP,0) + D NOW^%DTC K DIE S DA=RXP,DIE="^PSRX(",DR="31///@;32.1///"_% D ^DIE K DIE + ;D EN^PSOHLSN1(RXP,"ZD") + D ACT^PSORESK1 + S DA=$O(^PS(52.5,"B",RXP,0)) I DA K DIK S DIK="^PS(52.5," D ^DIK K DIK + D EN^PSOHLSN1(RXP,"ZD") + W !,"Rx # "_$P($G(^PSRX(RXP,0)),"^")_" Returned to Stock.",! + ; - Sending Rx to ECME for claim REVERSAL (Return to Stock) + D REVERSE^PSOBPSU1(RXP,0,"RS",4,,1) + Q +REF ; + K TYPE F PSROF=0:0 S PSROF=$O(^PSRX(RXP,1,PSROF)) Q:'PSROF S:$P($G(^PSRX(RXP,1,PSROF,0)),"^") TYPE=PSROF + I '$G(TYPE) Q + S XTYPE=1 + I $P($G(^PSRX(RXP,1,TYPE,0)),"^",16) Q + I '$P($G(^PSRX(RXP,1,TYPE,0)),"^",18) Q + I '$P($G(^PSRX(RXP,1,TYPE,0)),"^",18),$P($G(^(0)),"^")'0:+^DD("DILOCKTM"),1:3) I '$T W $C(7),!!,"Rx Number is Locked by Another User!",! S PSORXED("DFLG")=1 H 5 Q - I $G(^PSDRUG($P(PSORXED("RX0"),"^",6),"I"))]"",^("I")
0&('$P($G(PSOPFS),"^",2)) K PSOPFS Q - I +$G(PSOPFS)<1 K PSOPFS - E S PSOPFS="1^"_PSOPFS -CPCK1 N TYPE S PSO=2,PSODA=DA,PSOFLAG=1,PSOPAR7=$G(^PS(59,PSOSITE,"IB")),TYPE=RFD D RXED^PSOCPA K TYPE - Q -NEXT D NEXT^PSOUTIL(.PSORXED) K DIE,DR,DA S DIE="^PSRX(",DA=PSORXED("IRXN") - S DR="101///"_$P(PSORXED("RX3"),"^")_";102///"_$P(PSORXED("RX3"),"^",2) D ^DIE K DIE,DR,DA,X,Y - Q -EOJ K PSOSIG,PSORXED,PSOLIST,END,PSRX0 - D EX^PSORXED1 - Q -FILL ; - K PSOEDITF,PSOEDITR,PSOERF - F PSOEZ=0:0 S PSOEZ=$O(^PSRX(DA,1,PSOEZ)) Q:'PSOEZ S:$D(^PSRX(DA,1,PSOEZ,0)) PSOERF=PSOEZ - S PSOEDITF=$S($G(PSOERF):+$G(PSOERF),1:0) - I PSOEDITF S PSOEDITR=$S($P($G(^PSRX(DA,1,PSOEDITF,0)),"^",18):1,1:0) G FILLX - S PSOEDITR=$S($P($G(^PSRX(DA,2)),"^",13):1,1:0) -FILLX K PSOERF,PSOEZ - Q -LBL ; - S PSOEDITL=0 - I COM["PROV"!(COM["QTY")!(COM["DAYS")!(COM["MAIL")!(COM["UNIT")!(COM["FILL DATE")!(COM["REMARKS") I COM'["STATUS",COM'["CLINIC",COM'["DRUG",COM'["REFILLS",COM'["ISSUE",COM'["SIG",COM'["TRADE" D Q - .I $G(PSOEDITF) S PSOEDITL=1 Q - .I '$G(PSOEDITF),$G(PSOEDITR) S PSOEDITL=2 - I '$G(PSOEDITF),$G(PSOEDITR) S PSOEDITL=2 Q - I '$G(PSOEDITF),'$G(PSOEDITR) S PSOEDITL=0 Q - I $G(RXRP(DA)) S PSOEDITL=1 Q - I '$G(RXRP(DA)),$G(PSOEDITR) S PSOEDITL=2 Q - S PSOEDITL=0 - Q -ASKL ; - W ! K DIR S DIR("?",1)="You have edited a fill that has already been released. Do you want to",DIR("?",2)="include this prescription as one of the prescriptions to be acted upon",DIR("?",3)="at the label prompt." - S DIR("?")="Enter 'Yes' to generate a reprint label request." - S DIR(0)="Y",DIR("A")="The last fill has been released, do you want a reprint label",DIR("B")="Y" D ^DIR K DIR I Y=1 S PSOEDITL=0 Q - S PSOEDITL=1 - Q -SETRP I $P($G(^PSRX(PSORXED("IRXN"),"STA")),"^")'=5,$G(PSOEDITL)=0 S RXRP(PSORXED("IRXN"))="1^^^1",VALMSG="Label will reprint due to Edit" - Q +PSORXED ;IHS/DSD/JCM-edit rx utility ;02/18/98 3:14 PM + ;;7.0;OUTPATIENT PHARMACY;**2,16,21,26,56,71,125,201**;DEC 1997 + ;External reference to ^PSXEDIT supported by DBIA 2209 + ;External reference to ^DD(52 supported by DBIA 999 + ;External reference to ^PSDRUG supported by DBIA 221 + ;External reference to ^PS(55 supported by DBIA 2228 +START ;this entry point is no longer used. + ;D INIT,LKUP G:PSORXED("QFLG") END D PARSE,EOJ G START +END D EOJ + Q +INIT S PSORXED("QFLG")=0 Q +LKUP ; this line of code is no longer used S PSONUM="RX",PSONUM("A")="EDIT",PSOQFLG=0 D EN1^PSONUM I PSOQFLG!($Q(PSOLIST)']"") S PSORXED("QFLG")=1 + K PSOQFLG Q + ; +PARSE F PSORXED("LIST")=1:1 Q:'$D(PSOLIST(PSORXED("LIST")))!PSORXED("QFLG") F PSORXED("I")=1:1:$L(PSOLIST(PSORXED("LIST"))) S PSORXED("IRXN")=$P(PSOLIST(PSORXED("LIST")),",",PSORXED("I")) D:+PSORXED("IRXN") PROCESS + Q +PROCESS S PSORXED("DFLG")=0 G:$G(^PSRX(PSORXED("IRXN"),0))']"" PROCESSX + S PSORXED("RX0")=^PSRX(PSORXED("IRXN"),0),PSORXED("RX2")=^(2),PSORXED("RX3")=^(3),PSOSIG=$G(^PSRX(PSORXED("IRXN"),"SIG")),PSODAYS=$P(PSORXED("RX0"),"^",8) + S (I,RFED,RFDT)=0 F S I=$O(^PSRX(PSORXED("IRXN"),1,I)) Q:'I S RFED=I,PSORXED("RX1")=^PSRX(PSORXED("IRXN"),1,I,0),RFDT=$P(^(0),"^"),PSODAYS=$P(^(0),"^",10) S:$P(^(0),"^",17) PSONEW("PROVIDER NAME")=$P(^VA(200,$P(^(0),"^",17),0),"^") + S PSORXST=+$P($G(^PS(53,+$P(PSORXED("RX0"),"^",3),0)),"^",7) N DA S DA=PSORXED("IRXN") D EN^PSORXPR + D CHECK G:PSORXED("DFLG") PROCESSX + N X S X="PSXEDIT" X ^%ZOSF("TEST") K X I $T D ^PSXEDIT I $G(PSXOUT) K PSXOUT G L1 + D DIE^PSORXED1 +L1 D LOG,POST +PROCESSX Q +CHECK Q L +^PSRX(PSORXED("IRXN")):0 I '$T W $C(7),!!,"Rx Number is Locked by Another User!",! S PSORXED("DFLG")=1 H 5 Q + I $G(^PSDRUG($P(PSORXED("RX0"),"^",6),"I"))]"",^("I")
0&('$P($G(PSOPFS),"^",2)) K PSOPFS Q + I +$G(PSOPFS)<1 K PSOPFS + E S PSOPFS="1^"_PSOPFS +CPCK1 N TYPE S PSO=2,PSODA=DA,PSOFLAG=1,PSOPAR7=$G(^PS(59,PSOSITE,"IB")),TYPE=RFD D RXED^PSOCPA K TYPE + Q +NEXT D NEXT^PSOUTIL(.PSORXED) K DIE,DR,DA S DIE="^PSRX(",DA=PSORXED("IRXN") + S DR="101///"_$P(PSORXED("RX3"),"^")_";102///"_$P(PSORXED("RX3"),"^",2) D ^DIE K DIE,DR,DA,X,Y + Q +EOJ K PSOSIG,PSORXED,PSOLIST,END,PSRX0 + D EX^PSORXED1 + Q +FILL ; + K PSOEDITF,PSOEDITR,PSOERF + F PSOEZ=0:0 S PSOEZ=$O(^PSRX(DA,1,PSOEZ)) Q:'PSOEZ S:$D(^PSRX(DA,1,PSOEZ,0)) PSOERF=PSOEZ + S PSOEDITF=$S($G(PSOERF):+$G(PSOERF),1:0) + I PSOEDITF S PSOEDITR=$S($P($G(^PSRX(DA,1,PSOEDITF,0)),"^",18):1,1:0) G FILLX + S PSOEDITR=$S($P($G(^PSRX(DA,2)),"^",13):1,1:0) +FILLX K PSOERF,PSOEZ + Q +LBL ; + S PSOEDITL=0 + I COM["PROV"!(COM["QTY")!(COM["DAYS")!(COM["MAIL")!(COM["UNIT")!(COM["FILL DATE")!(COM["REMARKS") I COM'["STATUS",COM'["CLINIC",COM'["DRUG",COM'["REFILLS",COM'["ISSUE",COM'["SIG",COM'["TRADE" D Q + .I $G(PSOEDITF) S PSOEDITL=1 Q + .I '$G(PSOEDITF),$G(PSOEDITR) S PSOEDITL=2 + I '$G(PSOEDITF),$G(PSOEDITR) S PSOEDITL=2 Q + I '$G(PSOEDITF),'$G(PSOEDITR) S PSOEDITL=0 Q + I $G(RXRP(DA)) S PSOEDITL=1 Q + I '$G(RXRP(DA)),$G(PSOEDITR) S PSOEDITL=2 Q + S PSOEDITL=0 + Q +ASKL ; + W ! K DIR S DIR("?",1)="You have edited a fill that has already been released. Do you want to",DIR("?",2)="include this prescription as one of the prescriptions to be acted upon",DIR("?",3)="at the label prompt." + S DIR("?")="Enter 'Yes' to generate a reprint label request." + S DIR(0)="Y",DIR("A")="The last fill has been released, do you want a reprint label",DIR("B")="Y" D ^DIR K DIR I Y=1 S PSOEDITL=0 Q + S PSOEDITL=1 + Q +SETRP I $P($G(^PSRX(PSORXED("IRXN"),"STA")),"^")'=5,$G(PSOEDITL)=0 S RXRP(PSORXED("IRXN"))="1^^^1",VALMSG="Label will reprint due to Edit" + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXL.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXL.m index 4043e658..125b2408 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXL.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXL.m @@ -1,136 +1,136 @@ -PSORXL ;BHAM ISC/SAB - action to be taken on prescriptions ;3/13/07 19:21 - ;;7.0;OUTPATIENT PHARMACY;**8,21,24,32,47,135,148,208**;DEC 1997;Build 41 - ; Modified from FOIA VistA - ; Copyright (C) GNU GPL 2007 WorldVistA - ; - ;Ext ref to File #50 supported by DBIA 221 - ;Ext refs CHPUS^IBACUS and TRI^IBACUS supported by DBIA 203 - I $G(PSOTRVV),$G(PPL) S PSORX("PSOL",1)=PPL K PPL - N SLBL,PSOSONE,PSOKLRXS - S:'$G(PPL) PPL=$G(PSORX("PSOL",1)) G:$P(PSOPAR,"^",26) P -LBL I $G(PSOAFYN)'="Y" W !! S DIR("A",1)="Label Printer: "_$S($G(SUSPT):PSLION,1:$G(PSOLAP)) - S DIR("A")="LABEL: QUEUE/CHANGE PRINTER"_$S($P(PSOPAR,"^",23):"/HOLD",1:"")_$S($P(PSOPAR,"^",24):"/SUSPEND",1:"")_$S($P(PSOPAR,"^",26):"/LABEL",1:"")_" or '^' to bypass " - S DIR("?",1)="Enter 'Q' to queue labels to print",DIR("?")="Enter '^' to bypass label functions",DIR("?",4)="Enter 'S' to suspend labels to print later" - S DIR("?",2)="Enter 'H' to hold label until Rx can be filled",DIR("?",3)="Enter 'P' for Rx profile" - S DIR("?",5)="Enter 'C' to select another label printer" - S:$P(PSOPAR,"^",26) DIR("?",5)="Enter 'L' to print labels without queuing" -TRI ; - S X="IBACUS" X ^%ZOSF("TEST") K X I '$T G PASS - I '$$TRI^IBACUS() G PASS - I '$D(PSORX("PSOL",1))!($G(PSOSUREP))!($G(PSOEXREP)) G PASS - N GGG,PBILL,PSTRD,PSTRDZ,PSTRF,PSTRP,TRXI,TRIRX,PSTRIVAR,VV,VVV,VVCT - D DEV^PSOCPTRI - K ^TMP($J,"PSONOB"),^TMP($J,"PSOBILL") - S VVCT=0 F VV=0:0 S VV=$O(PSORX("PSOL",VV)) Q:'VV F VVV=1:1 S TRXI=$P(PSORX("PSOL",VV),",",VVV) Q:'TRXI D - .I '$G(DT) S DT=$$DT^XLFDT - .I $P($G(^PSRX(+TRXI,"STA")),"^")=3 Q - .S PSTRP=$P($G(^PSRX(+TRXI,0)),"^",2),PSTRD=+$G(PSOSITE),PSTRDZ=+$G(DUZ) - .S PSTRF=0 F GGG=0:0 S GGG=$O(^PSRX(+TRXI,1,GGG)) Q:'GGG S PSTRF=GGG - .S VVCT=VVCT+1 - .I $G(RXRP(TRXI))!($G(RXPR(TRXI)))!($G(RXRH(TRXI))) S ^TMP($J,"PSONOB",VVCT)=TRXI Q - .S PBILL=$$CHPUS^IBACUS(PSTRP,DT,TRXI,PSTRF,PSOLAP,PSTRD,PSTRDZ) S ^TMP($J,$S($G(PBILL):"PSOBILL",1:"PSONOB"),VVCT)=TRXI - I '$D(^TMP($J,"PSOBILL")) K ^TMP($J,"PSONOB") G PASS - I '$D(^TMP($J,"PSONOB")),$D(^TMP($J,"PSOBILL")) S (Y,LBL)="H" G H1 - ; -SETP K PSORX("PSOL"),PPL S VVCT=1 F VV=0:0 S VV=$O(^TMP($J,$S($G(PSTRIVAR):"PSONOB",1:"PSOBILL"),VV)) Q:'VV S TRIRX=^TMP($J,$S($G(PSTRIVAR):"PSONOB",1:"PSOBILL"),VV) I +TRIRX D - .I $G(PSORX("PSOL",1))="" S PSORX("PSOL",1)=TRIRX_"," Q - .I $L(PSORX("PSOL",VVCT))+$L(TRIRX)<220 S PSORX("PSOL",VVCT)=PSORX("PSOL",VVCT)_TRIRX_"," Q - .S VVCT=VVCT+1 S PSORX("PSOL",VVCT)=TRIRX_"," - I '$G(PSTRIVAR) S (Y,LBL)="H" S PSOKLRXS=1 K PSORSAVE,PSOPSAVE,PSOHSAVE D RSAVE D H1 D RREST K PSORSAVE,PSOPSAVE,PSOHSAVE K PSOKLRXS S PSTRIVAR=1 G SETP - K ^TMP($J,"PSONOB") S PPL=$G(PSORX("PSOL",1)) -PASS ; - I $G(PSOAFYN)'="Y" I $E($G(DIR("A")),1,6)'="LABEL:" D RESDIR^PSOCPTRI - I $G(PSOAFYN)'="Y" S DIR(0)="SA^P:PROFILE;Q:QUEUE;C:CHANGE PRINTER"_$S($P(PSOPAR,"^",23):";H:HOLD",1:"")_$S($P(PSOPAR,"^",24):";S:SUSPENSE",1:"")_$S($P(PSOPAR,"^",26):";L:PRINT",1:""),DIR("B")="Q" D ^DIR D G:$D(DIRUT)!($D(DUOUT)) EX - .I $G(PSOAFYN)'="Y" I $D(DIRUT)!($D(DUOUT)) D AL^PSOLBL("UT") I $G(PSOEXREP) S PSOEXREX=1 - .I $G(PSOAFYN)'="Y" I $G(PSOPULL) I $D(DIRUT)!($D(DUOUT)) S PSOQFLAG=1 - I $G(PSOAFYN)="Y" S PSOLAP=$G(^SC(+ORL,"AFRXCLINPRNT")) - I $G(PSOAFYN)="Y" I PSOLAP="" S DIRUT="^" G:$D(DIRUT)!($D(DUOUT)) EX - I $G(PSOAFYN)="Y" S PSOLAP=$P(^%ZIS(1,PSOLAP,0),"^",1) - S:$G(PSOBEDT) NOPP=Y - I $G(Y)="C" K PSOCLBL,%ZIS("B") S PSOCLBL=1 D @$S('$D(PSOPAR):"^PSOLSET",1:"PLBL^PSOLSET") K PSOCLBL G LBL - I $G(Y)="Q",$D(RXRS),'$G(PSOPULL) D PPLADD^PSOSUPOE - I $G(PSXSYS),($G(Y)'="H"),($G(Y)'="P"),('$G(PSOEXREP)) S LBL=Y,(RXLTOP,PPL1)=1 S:'$G(PSOPULL) SLBL=Y D A^PSOCMOP G:'$G(PPL) D1 - K DIR S LBL=Y S:'$G(PSOPULL) SLBL=Y G Q:Y="Q",S:Y="S",H1:Y="H",P:Y="L" I Y="P" W ! S PSDFN=DFN,PSFROM="" D ^PSODSPL K PSDFN,PSFROM G LBL -EX I $D(DUOUT)!$D(DIRUT) K BINGCRT,BINGRTE,BBRX,BBFLG S:$D(RXRS) SLBL="^" G:$D(RXRS) RXS K DIR,X,DIRUT,DUOUT,ACT,Y,DTOUT,PPL,REPRINT S NOBG=1 Q -Q S PPL1=1 G:$G(PPL)']"" D1 S PSNP=0,PSL=1 D I $G(PSOFROM)="NEW",$P(PSOPAR,"^",8) S PSNP=1 - .Q:'$P(PSOPAR,"^",8)!($G(PSONOPRT)) - .F SLPPL=0:0 S SLPPL=$O(RXRS(SLPPL)) Q:'SLPPL!($G(PSNP)) I '$O(^PSRX(SLPPL,1,0)),'$D(RXPR(SLPPL)) S PSNP=1 - I $G(PSOLAP)]"",$G(PSOLAP)'=ION G QLBL -Q1 W ! K POP S %ZIS("B")="",%ZIS="MNQ",%ZIS("A")="Select LABEL DEVICE: " D ^%ZIS S PSLION=ION K %ZIS("A") Q:$G(POP)&($G(PSPARTXX)) G:$G(POP)&($G(PSOSONE)) RXSQ D:$G(POP)&($G(PSONOPRT)) Q:$G(PSOQFLAG) G:POP!(IO=IO(0)) LBL S PSOLAP=ION - .S PSOQFLAG=1 - N PSOIOS S PSOIOS=IOS D DEVBAR^PSOBMST - S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$P(PSOPAR,"^",10) - D ^%ZISC S PSL=0 -QLBL I $G(PSXSYS),('$G(RXLTOP)),('$G(PSOEXREP)) D RXL^PSOCMOP G:'$G(PPL) D1 - ;- Submitting list of Rx to ECME for DUR/79 REJECT check and possible submission to 3rd Pary Payer - I $G(PSOAFYN)'="Y" D ECME^PSORXL1 ;vfah - ; - S ZTRTN="DQ^PSOLBL",ZTIO=$S($G(SUSPT):PSLION,1:PSOLAP),ZTDESC="Outpatient Pharmacy "_$S($G(SUSPT):"SUSPENSE ",$G(DG):"DRUG INTERACTION ",1:"")_"LABELS OUTPUT ROUTINE",ZTDTH=$S($G(PSOTIME):PSOTIME,1:$H),PDUZ=DUZ - F G="PPL1","PSOSYS","DFN","PSOPAR","PDUZ","PCOMX",$S($G(SUSPT):"PFION",1:"PSOLAP"),"PPL","PSOSITE","RXY","COPIES","SIDE","PSOSUSPR","PSOBARS","PSOBAR1","PSOBAR0","PSODELE","PSOPULL","PSTAT","PSODBQ","PSOEXREP","PSOTREP" S:$D(@G) ZTSAVE(G)="" - S ZTSAVE("PSOAFDFN")="",ZTSAVE("PSOAFDUZ")="",ZTSAVE("PSOAFYN")="",ZTSAVE("PSOAFPAT")="",ZTSAVE("PSOAFPNM")="",ZTSAVE("VFASDD")="",ZTSAVE("ORL")="" ;vfah - S ZTSAVE("PSORX(")="",ZTSAVE("RXRP(")="",ZTSAVE("RXPR(")="",ZTSAVE("RXRS(")="",ZTSAVE("RXFL(")="",ZTSAVE("PCOMH(")="" - D ^%ZISC,^%ZTLOAD K:$G(PSOSONE) RXRS W:$D(ZTSK)&('$G(SUSPT))&('$G(PSOEXREP)) !!,"LABEL(S) QUEUED TO PRINT",!! - Q:$G(PSPARTXX) K G,PDUZ K:'$G(SUSPT) ZTSK Q:$G(DG) - G:'$G(PSNP) QUEUP G:$G(PSOPRFLG) QUEUP S HOLDRPAS=$G(PSOPRPAS),PSOPRPAS=$P(PSOPAR,"^",13) -PLBL S PSOION=ION - I '$D(PSOPROP)!($G(PSOPROP)=ION) W $C(7),!,"PROFILES MUST BE SENT TO PRINTER !!",! K IOP,%ZIS,IO("Q"),POP S %ZIS="MNQ",%ZIS("A")="Select PROFILE DEVICE: " D ^%ZIS K %ZIS("A") G:POP QUEUP G:$E(IOST)["C"!(PSOION=ION) PLBL S PSOPROP=ION -QPRF S ZTRTN="DQ^PSOPRF",ZTIO=PSOPROP,ZTDESC="Outpatient Pharmacy "_$S($G(SUSPT):"SUSPENSE ",1:"")_"PATIENT PROFILES",ZTDTH=$S($G(PSOTIME):PSOTIME,1:$H) - F G="PSOPAR","PSODTCUT","PSOPRPAS","DFN","PSOSITE","NEW1","NEW11","PSOBMST","PFIO","PPL" S:$D(@G) ZTSAVE(G)="" - D ^%ZTLOAD W:$D(ZTSK)&('$G(SUSPT))&('$G(PSOEXREP)) !,"PROFILE IS QUEUED TO PRINT",!! K G K:'$G(SUSPT) ZTSK D ^%ZISC -QUEUP D:$G(POP)&($G(PSONOPRT)) Q:$G(PSOQFLAG) S PSNP=0,PSOPRPAS=$G(HOLDRPAS) K:PSOPRPAS']"" PSOPRPAS K HOLDRPAS G D1 - .S PSOQFLAG=1 - Q - ; -S G S^PSORXL1 -SUS S X="IBACUS" X ^%ZOSF("TEST") K X I '$T G SUSL1 - N TRIDA S TRIDA=DA I '$$TRI^IBACUS() S DA=TRIDA G SUSL1 - I $G(RXRP(TRIDA))!($G(RXPR(TRIDA)))!($G(RXRH(TRIDA))) S DA=TRIDA G SUSL1 - N PBILL,PSTRD,PSTRDZ,PSTRF,PSTRP,GGG - D DEV^PSOCPTRI - I '$G(DT) S DT=$$DT^XLFDT - S PSTRP=$P($G(^PSRX(+TRIDA,0)),"^",2),PSTRD=+$G(PSOSITE),PSTRDZ=+$G(DUZ) - S PSTRF=0 F GGG=0:0 S GGG=$O(^PSRX(+TRIDA,1,GGG)) Q:'GGG S PSTRF=GGG - S PBILL=$$CHPUS^IBACUS(PSTRP,DT,TRIDA,PSTRF,PSOLAP,PSTRD,PSTRDZ) - I '$G(PBILL) S DA=TRIDA G SUSL1 - S FLD(99)="99",FLD(99.1)="Awaiting CHAMPUS billing approval" - N RSDT,ACT,PSUS,RXF,RFN,I,PSDA,NOW,IR,FDA - S DA=TRIDA D H^PSOCPTRH - Q -SUSL1 G SUS^PSORXL1 -H1 S PPL1=1 S:'$G(PPL) PPL=$G(PSORX("PSOL",PPL1)) - D:'$D(^TMP($J,"PSOBILL")) NOOR^PSOHLD I $D(DIRUT) K DIRUT G PSORXL - I $D(^TMP($J,"PSOBILL")) S FLD(99)="99",FLD(99.1)="Awaiting CHAMPUS billing approval" G H - G:$G(PPL)']"" D1 D FLD^PSOHLD I $D(DUOUT)!($D(DIRUT)) K DIRUT,DUOUT,FLD,DIR G LBL -H K SPPL G:$D(DTOUT) D1 S SPPL="" F PI=1:1 Q:$P(PPL,",",PI)="" D - .S DA=$P(PPL,",",PI) I $P(^PSRX(DA,"STA"),"^")<10,$P(^("STA"),"^")'=4 D @$S($D(^TMP($J,"PSOBILL")):"H^PSOCPTRH",1:"H^PSOHLD") Q - .I $P(^PSRX(DA,"STA"),"^")=4 S SPPL=SPPL_DA_"," Q - I $G(SPPL)]"" D - .W !!,$C(7),"Drug Interaction Rx(s) " F I=1:1 Q:$P(SPPL,",",I)="" W $P(^PSRX($P(SPPL,",",I),0),"^")_", " - .S PPL=SPPL,DG=1 D Q K DG,SPPL -D1 K RXLTOP I $G(PPL1),$O(PSORX("PSOL",$G(PPL1))) S PPL1=$O(PSORX("PSOL",PPL1)),PPL=PSORX("PSOL",PPL1) G @$S(LBL="H":"H",LBL="L":"P1",1:"QLBL") -RXS I $D(RXRS),'$G(PSOKLRXS) I $G(SLBL)="H"!($G(SLBL)="S")!($G(SLBL)="^")!($G(SLBL)="") D G:$G(PPL)'="" Q - .K PPL,PSORX("PSOL") S PSOSONE=1 D PPLADD^PSOSUPOE - .Q:$G(PPL)="" W !!,"You have selected the following Rx(s) to be pulled from suspense:",! - .F RXSS=0:0 S RXSS=$O(RXRS(RXSS)) Q:'RXSS W !," Rx # ",$P($G(^PSRX(+$G(RXSS),0)),"^"),?23,$P($G(^PSDRUG(+$P($G(^PSRX(+$G(RXSS),0)),"^",6),0)),"^") - .K DIR W ! S DIR(0)="Y",DIR("B")="YES",DIR("A")="Do you still want to pull these Rx(s) from suspense" D ^DIR K DIR I Y'=1 W !!,"Rx(s) will remain in Suspense!",! D RESET^PSOSUPOE K RXRS,PPL - K:'$G(PSOKLRXS) RXRS K ^TMP($J,"PSOBILL"),RXPR,RXRP,RXRH,RXSS,LBL,PPL1,PPL,DIR,%DT,%,SD,COUNT,EXDT,L,PDUZ,REF,REPRINT,RFDATE,RFL1,RFLL,RXN,WARN,ZY,FLD,PI,ZD,ACT,X,Y,DIRUT,DUOUT,DTOUT,DIROUT Q -P S PPL1=1 S:'$G(PPL) PPL=$G(PSORX("PSOL",1)) G:$G(PPL)']"" D1 - I $G(PSOLAP)']"" W ! K POP,ZTSK S %ZIS="M",%ZIS("A")="Select LABEL DEVICE: " D ^%ZIS K %ZIS("A") G:POP LBL S PSOLAP=ION - S IOP=PSOLAP D ^%ZIS - N PSOIOS S PSOIOS=IOS D DEVBAR^PSOBMST -P1 S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$P(PSOPAR,"^",10),PDUZ=DUZ D DQ1^PSOLBL,^%ZISC - G:'$P(PSOPAR,"^",8)!(+$G(REPRINT))!($G(PSOFROM)'="NEW") D1 I $G(PSOPROP)']"" S PSOION=ION,%ZIS="M",%ZIS("A")="Select PROFILE DEVICE: " D ^%ZIS K %ZIS("A") G:POP D1 S PSOPROP=ION - S IOP=PSOPROP D ^%ZIS D DQ^PSOPRF,^%ZISC G D1 - Q -RXSQ K RXRS G RXS - Q -RSAVE N PMX - S PMX="" F S PMX=$O(RXRP(PMX)) Q:PMX="" S PSORSAVE(PMX)=RXRP(PMX) - S PMX="" F S PMX=$O(RXPR(PMX)) Q:PMX="" S PSOPSAVE(PMX)=RXPR(PMX) - S PMX="" F S PMX=$O(RXRH(PMX)) Q:PMX="" S PSOHSAVE(PMX)=RXRH(PMX) - Q -RREST N PMXZ - S PMXZ="" F S PMXZ=$O(PSORSAVE(PMXZ)) Q:PMXZ="" S RXRP(PMXZ)=PSORSAVE(PMXZ) - S PMXZ="" F S PMXZ=$O(PSOPSAVE(PMXZ)) Q:PMXZ="" S RXPR(PMXZ)=PSOPSAVE(PMXZ) - S PSMX="" F S PMXZ=$O(PSOHSAVE(PMXZ)) Q:PMXZ="" S RXRH(PMXZ)=PSOHSAVE(PMXZ) - Q +PSORXL ;BHAM ISC/SAB - action to be taken on prescriptions ;3/13/07 19:21 + ;;7.0;OUTPATIENT PHARMACY;**8,21,24,32,47,135,148,208**;DEC 1997;Build 39 + ; Modified from FOIA VistA + ; Copyright (C) GNU GPL 2007 WorldVistA + ; + ;Ext ref to File #50 supported by DBIA 221 + ;Ext refs CHPUS^IBACUS and TRI^IBACUS supported by DBIA 203 + I $G(PSOTRVV),$G(PPL) S PSORX("PSOL",1)=PPL K PPL + N SLBL,PSOSONE,PSOKLRXS + S:'$G(PPL) PPL=$G(PSORX("PSOL",1)) G:$P(PSOPAR,"^",26) P +LBL I $G(PSOAFYN)'="Y" W !! S DIR("A",1)="Label Printer: "_$S($G(SUSPT):PSLION,1:$G(PSOLAP)) + S DIR("A")="LABEL: QUEUE/CHANGE PRINTER"_$S($P(PSOPAR,"^",23):"/HOLD",1:"")_$S($P(PSOPAR,"^",24):"/SUSPEND",1:"")_$S($P(PSOPAR,"^",26):"/LABEL",1:"")_" or '^' to bypass " + S DIR("?",1)="Enter 'Q' to queue labels to print",DIR("?")="Enter '^' to bypass label functions",DIR("?",4)="Enter 'S' to suspend labels to print later" + S DIR("?",2)="Enter 'H' to hold label until Rx can be filled",DIR("?",3)="Enter 'P' for Rx profile" + S DIR("?",5)="Enter 'C' to select another label printer" + S:$P(PSOPAR,"^",26) DIR("?",5)="Enter 'L' to print labels without queuing" +TRI ; + S X="IBACUS" X ^%ZOSF("TEST") K X I '$T G PASS + I '$$TRI^IBACUS() G PASS + I '$D(PSORX("PSOL",1))!($G(PSOSUREP))!($G(PSOEXREP)) G PASS + N GGG,PBILL,PSTRD,PSTRDZ,PSTRF,PSTRP,TRXI,TRIRX,PSTRIVAR,VV,VVV,VVCT + D DEV^PSOCPTRI + K ^TMP($J,"PSONOB"),^TMP($J,"PSOBILL") + S VVCT=0 F VV=0:0 S VV=$O(PSORX("PSOL",VV)) Q:'VV F VVV=1:1 S TRXI=$P(PSORX("PSOL",VV),",",VVV) Q:'TRXI D + .I '$G(DT) S DT=$$DT^XLFDT + .I $P($G(^PSRX(+TRXI,"STA")),"^")=3 Q + .S PSTRP=$P($G(^PSRX(+TRXI,0)),"^",2),PSTRD=+$G(PSOSITE),PSTRDZ=+$G(DUZ) + .S PSTRF=0 F GGG=0:0 S GGG=$O(^PSRX(+TRXI,1,GGG)) Q:'GGG S PSTRF=GGG + .S VVCT=VVCT+1 + .I $G(RXRP(TRXI))!($G(RXPR(TRXI)))!($G(RXRH(TRXI))) S ^TMP($J,"PSONOB",VVCT)=TRXI Q + .S PBILL=$$CHPUS^IBACUS(PSTRP,DT,TRXI,PSTRF,PSOLAP,PSTRD,PSTRDZ) S ^TMP($J,$S($G(PBILL):"PSOBILL",1:"PSONOB"),VVCT)=TRXI + I '$D(^TMP($J,"PSOBILL")) K ^TMP($J,"PSONOB") G PASS + I '$D(^TMP($J,"PSONOB")),$D(^TMP($J,"PSOBILL")) S (Y,LBL)="H" G H1 + ; +SETP K PSORX("PSOL"),PPL S VVCT=1 F VV=0:0 S VV=$O(^TMP($J,$S($G(PSTRIVAR):"PSONOB",1:"PSOBILL"),VV)) Q:'VV S TRIRX=^TMP($J,$S($G(PSTRIVAR):"PSONOB",1:"PSOBILL"),VV) I +TRIRX D + .I $G(PSORX("PSOL",1))="" S PSORX("PSOL",1)=TRIRX_"," Q + .I $L(PSORX("PSOL",VVCT))+$L(TRIRX)<220 S PSORX("PSOL",VVCT)=PSORX("PSOL",VVCT)_TRIRX_"," Q + .S VVCT=VVCT+1 S PSORX("PSOL",VVCT)=TRIRX_"," + I '$G(PSTRIVAR) S (Y,LBL)="H" S PSOKLRXS=1 K PSORSAVE,PSOPSAVE,PSOHSAVE D RSAVE D H1 D RREST K PSORSAVE,PSOPSAVE,PSOHSAVE K PSOKLRXS S PSTRIVAR=1 G SETP + K ^TMP($J,"PSONOB") S PPL=$G(PSORX("PSOL",1)) +PASS ; + I $G(PSOAFYN)'="Y" I $E($G(DIR("A")),1,6)'="LABEL:" D RESDIR^PSOCPTRI + I $G(PSOAFYN)'="Y" S DIR(0)="SA^P:PROFILE;Q:QUEUE;C:CHANGE PRINTER"_$S($P(PSOPAR,"^",23):";H:HOLD",1:"")_$S($P(PSOPAR,"^",24):";S:SUSPENSE",1:"")_$S($P(PSOPAR,"^",26):";L:PRINT",1:""),DIR("B")="Q" D ^DIR D G:$D(DIRUT)!($D(DUOUT)) EX + .I $G(PSOAFYN)'="Y" I $D(DIRUT)!($D(DUOUT)) D AL^PSOLBL("UT") I $G(PSOEXREP) S PSOEXREX=1 + .I $G(PSOAFYN)'="Y" I $G(PSOPULL) I $D(DIRUT)!($D(DUOUT)) S PSOQFLAG=1 + I $G(PSOAFYN)="Y" S PSOLAP=$G(^SC(+ORL,"AFRXCLINPRNT")) + I $G(PSOAFYN)="Y" I PSOLAP="" S DIRUT="^" G:$D(DIRUT)!($D(DUOUT)) EX + I $G(PSOAFYN)="Y" S PSOLAP=$P(^%ZIS(1,PSOLAP,0),"^",1) + S:$G(PSOBEDT) NOPP=Y + I $G(Y)="C" K PSOCLBL,%ZIS("B") S PSOCLBL=1 D @$S('$D(PSOPAR):"^PSOLSET",1:"PLBL^PSOLSET") K PSOCLBL G LBL + I $G(Y)="Q",$D(RXRS),'$G(PSOPULL) D PPLADD^PSOSUPOE + I $G(PSXSYS),($G(Y)'="H"),($G(Y)'="P"),('$G(PSOEXREP)) S LBL=Y,(RXLTOP,PPL1)=1 S:'$G(PSOPULL) SLBL=Y D A^PSOCMOP G:'$G(PPL) D1 + K DIR S LBL=Y S:'$G(PSOPULL) SLBL=Y G Q:Y="Q",S:Y="S",H1:Y="H",P:Y="L" I Y="P" W ! S PSDFN=DFN,PSFROM="" D ^PSODSPL K PSDFN,PSFROM G LBL +EX I $D(DUOUT)!$D(DIRUT) K BINGCRT,BINGRTE,BBRX,BBFLG S:$D(RXRS) SLBL="^" G:$D(RXRS) RXS K DIR,X,DIRUT,DUOUT,ACT,Y,DTOUT,PPL,REPRINT S NOBG=1 Q +Q S PPL1=1 G:$G(PPL)']"" D1 S PSNP=0,PSL=1 D I $G(PSOFROM)="NEW",$P(PSOPAR,"^",8) S PSNP=1 + .Q:'$P(PSOPAR,"^",8)!($G(PSONOPRT)) + .F SLPPL=0:0 S SLPPL=$O(RXRS(SLPPL)) Q:'SLPPL!($G(PSNP)) I '$O(^PSRX(SLPPL,1,0)),'$D(RXPR(SLPPL)) S PSNP=1 + I $G(PSOLAP)]"",$G(PSOLAP)'=ION G QLBL +Q1 W ! K POP S %ZIS("B")="",%ZIS="MNQ",%ZIS("A")="Select LABEL DEVICE: " D ^%ZIS S PSLION=ION K %ZIS("A") Q:$G(POP)&($G(PSPARTXX)) G:$G(POP)&($G(PSOSONE)) RXSQ D:$G(POP)&($G(PSONOPRT)) Q:$G(PSOQFLAG) G:POP!(IO=IO(0)) LBL S PSOLAP=ION + .S PSOQFLAG=1 + N PSOIOS S PSOIOS=IOS D DEVBAR^PSOBMST + S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$P(PSOPAR,"^",10) + D ^%ZISC S PSL=0 +QLBL I $G(PSXSYS),('$G(RXLTOP)),('$G(PSOEXREP)) D RXL^PSOCMOP G:'$G(PPL) D1 + ;- Submitting list of Rx to ECME for DUR/79 REJECT check and possible submission to 3rd Pary Payer + I $G(PSOAFYN)'="Y" D ECME^PSORXL1 ;vfah + ; + S ZTRTN="DQ^PSOLBL",ZTIO=$S($G(SUSPT):PSLION,1:PSOLAP),ZTDESC="Outpatient Pharmacy "_$S($G(SUSPT):"SUSPENSE ",$G(DG):"DRUG INTERACTION ",1:"")_"LABELS OUTPUT ROUTINE",ZTDTH=$S($G(PSOTIME):PSOTIME,1:$H),PDUZ=DUZ + F G="PPL1","PSOSYS","DFN","PSOPAR","PDUZ","PCOMX",$S($G(SUSPT):"PFION",1:"PSOLAP"),"PPL","PSOSITE","RXY","COPIES","SIDE","PSOSUSPR","PSOBARS","PSOBAR1","PSOBAR0","PSODELE","PSOPULL","PSTAT","PSODBQ","PSOEXREP","PSOTREP" S:$D(@G) ZTSAVE(G)="" + S ZTSAVE("PSOAFDFN")="",ZTSAVE("PSOAFDUZ")="",ZTSAVE("PSOAFYN")="",ZTSAVE("PSOAFPAT")="",ZTSAVE("PSOAFPNM")="",ZTSAVE("VFASDD")="",ZTSAVE("ORL")="" ;vfah + S ZTSAVE("PSORX(")="",ZTSAVE("RXRP(")="",ZTSAVE("RXPR(")="",ZTSAVE("RXRS(")="",ZTSAVE("RXFL(")="",ZTSAVE("PCOMH(")="" + D ^%ZISC,^%ZTLOAD K:$G(PSOSONE) RXRS W:$D(ZTSK)&('$G(SUSPT))&('$G(PSOEXREP)) !!,"LABEL(S) QUEUED TO PRINT",!! + Q:$G(PSPARTXX) K G,PDUZ K:'$G(SUSPT) ZTSK Q:$G(DG) + G:'$G(PSNP) QUEUP G:$G(PSOPRFLG) QUEUP S HOLDRPAS=$G(PSOPRPAS),PSOPRPAS=$P(PSOPAR,"^",13) +PLBL S PSOION=ION + I '$D(PSOPROP)!($G(PSOPROP)=ION) W $C(7),!,"PROFILES MUST BE SENT TO PRINTER !!",! K IOP,%ZIS,IO("Q"),POP S %ZIS="MNQ",%ZIS("A")="Select PROFILE DEVICE: " D ^%ZIS K %ZIS("A") G:POP QUEUP G:$E(IOST)["C"!(PSOION=ION) PLBL S PSOPROP=ION +QPRF S ZTRTN="DQ^PSOPRF",ZTIO=PSOPROP,ZTDESC="Outpatient Pharmacy "_$S($G(SUSPT):"SUSPENSE ",1:"")_"PATIENT PROFILES",ZTDTH=$S($G(PSOTIME):PSOTIME,1:$H) + F G="PSOPAR","PSODTCUT","PSOPRPAS","DFN","PSOSITE","NEW1","NEW11","PSOBMST","PFIO","PPL" S:$D(@G) ZTSAVE(G)="" + D ^%ZTLOAD W:$D(ZTSK)&('$G(SUSPT))&('$G(PSOEXREP)) !,"PROFILE IS QUEUED TO PRINT",!! K G K:'$G(SUSPT) ZTSK D ^%ZISC +QUEUP D:$G(POP)&($G(PSONOPRT)) Q:$G(PSOQFLAG) S PSNP=0,PSOPRPAS=$G(HOLDRPAS) K:PSOPRPAS']"" PSOPRPAS K HOLDRPAS G D1 + .S PSOQFLAG=1 + Q + ; +S G S^PSORXL1 +SUS S X="IBACUS" X ^%ZOSF("TEST") K X I '$T G SUSL1 + N TRIDA S TRIDA=DA I '$$TRI^IBACUS() S DA=TRIDA G SUSL1 + I $G(RXRP(TRIDA))!($G(RXPR(TRIDA)))!($G(RXRH(TRIDA))) S DA=TRIDA G SUSL1 + N PBILL,PSTRD,PSTRDZ,PSTRF,PSTRP,GGG + D DEV^PSOCPTRI + I '$G(DT) S DT=$$DT^XLFDT + S PSTRP=$P($G(^PSRX(+TRIDA,0)),"^",2),PSTRD=+$G(PSOSITE),PSTRDZ=+$G(DUZ) + S PSTRF=0 F GGG=0:0 S GGG=$O(^PSRX(+TRIDA,1,GGG)) Q:'GGG S PSTRF=GGG + S PBILL=$$CHPUS^IBACUS(PSTRP,DT,TRIDA,PSTRF,PSOLAP,PSTRD,PSTRDZ) + I '$G(PBILL) S DA=TRIDA G SUSL1 + S FLD(99)="99",FLD(99.1)="Awaiting CHAMPUS billing approval" + N RSDT,ACT,PSUS,RXF,RFN,I,PSDA,NOW,IR,FDA + S DA=TRIDA D H^PSOCPTRH + Q +SUSL1 G SUS^PSORXL1 +H1 S PPL1=1 S:'$G(PPL) PPL=$G(PSORX("PSOL",PPL1)) + D:'$D(^TMP($J,"PSOBILL")) NOOR^PSOHLD I $D(DIRUT) K DIRUT G PSORXL + I $D(^TMP($J,"PSOBILL")) S FLD(99)="99",FLD(99.1)="Awaiting CHAMPUS billing approval" G H + G:$G(PPL)']"" D1 D FLD^PSOHLD I $D(DUOUT)!($D(DIRUT)) K DIRUT,DUOUT,FLD,DIR G LBL +H K SPPL G:$D(DTOUT) D1 S SPPL="" F PI=1:1 Q:$P(PPL,",",PI)="" D + .S DA=$P(PPL,",",PI) I $P(^PSRX(DA,"STA"),"^")<10,$P(^("STA"),"^")'=4 D @$S($D(^TMP($J,"PSOBILL")):"H^PSOCPTRH",1:"H^PSOHLD") Q + .I $P(^PSRX(DA,"STA"),"^")=4 S SPPL=SPPL_DA_"," Q + I $G(SPPL)]"" D + .W !!,$C(7),"Drug Interaction Rx(s) " F I=1:1 Q:$P(SPPL,",",I)="" W $P(^PSRX($P(SPPL,",",I),0),"^")_", " + .S PPL=SPPL,DG=1 D Q K DG,SPPL +D1 K RXLTOP I $G(PPL1),$O(PSORX("PSOL",$G(PPL1))) S PPL1=$O(PSORX("PSOL",PPL1)),PPL=PSORX("PSOL",PPL1) G @$S(LBL="H":"H",LBL="L":"P1",1:"QLBL") +RXS I $D(RXRS),'$G(PSOKLRXS) I $G(SLBL)="H"!($G(SLBL)="S")!($G(SLBL)="^")!($G(SLBL)="") D G:$G(PPL)'="" Q + .K PPL,PSORX("PSOL") S PSOSONE=1 D PPLADD^PSOSUPOE + .Q:$G(PPL)="" W !!,"You have selected the following Rx(s) to be pulled from suspense:",! + .F RXSS=0:0 S RXSS=$O(RXRS(RXSS)) Q:'RXSS W !," Rx # ",$P($G(^PSRX(+$G(RXSS),0)),"^"),?23,$P($G(^PSDRUG(+$P($G(^PSRX(+$G(RXSS),0)),"^",6),0)),"^") + .K DIR W ! S DIR(0)="Y",DIR("B")="YES",DIR("A")="Do you still want to pull these Rx(s) from suspense" D ^DIR K DIR I Y'=1 W !!,"Rx(s) will remain in Suspense!",! D RESET^PSOSUPOE K RXRS,PPL + K:'$G(PSOKLRXS) RXRS K ^TMP($J,"PSOBILL"),RXPR,RXRP,RXRH,RXSS,LBL,PPL1,PPL,DIR,%DT,%,SD,COUNT,EXDT,L,PDUZ,REF,REPRINT,RFDATE,RFL1,RFLL,RXN,WARN,ZY,FLD,PI,ZD,ACT,X,Y,DIRUT,DUOUT,DTOUT,DIROUT Q +P S PPL1=1 S:'$G(PPL) PPL=$G(PSORX("PSOL",1)) G:$G(PPL)']"" D1 + I $G(PSOLAP)']"" W ! K POP,ZTSK S %ZIS="M",%ZIS("A")="Select LABEL DEVICE: " D ^%ZIS K %ZIS("A") G:POP LBL S PSOLAP=ION + S IOP=PSOLAP D ^%ZIS + N PSOIOS S PSOIOS=IOS D DEVBAR^PSOBMST +P1 S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$P(PSOPAR,"^",10),PDUZ=DUZ D DQ1^PSOLBL,^%ZISC + G:'$P(PSOPAR,"^",8)!(+$G(REPRINT))!($G(PSOFROM)'="NEW") D1 I $G(PSOPROP)']"" S PSOION=ION,%ZIS="M",%ZIS("A")="Select PROFILE DEVICE: " D ^%ZIS K %ZIS("A") G:POP D1 S PSOPROP=ION + S IOP=PSOPROP D ^%ZIS D DQ^PSOPRF,^%ZISC G D1 + Q +RXSQ K RXRS G RXS + Q +RSAVE N PMX + S PMX="" F S PMX=$O(RXRP(PMX)) Q:PMX="" S PSORSAVE(PMX)=RXRP(PMX) + S PMX="" F S PMX=$O(RXPR(PMX)) Q:PMX="" S PSOPSAVE(PMX)=RXPR(PMX) + S PMX="" F S PMX=$O(RXRH(PMX)) Q:PMX="" S PSOHSAVE(PMX)=RXRH(PMX) + Q +RREST N PMXZ + S PMXZ="" F S PMXZ=$O(PSORSAVE(PMXZ)) Q:PMXZ="" S RXRP(PMXZ)=PSORSAVE(PMXZ) + S PMXZ="" F S PMXZ=$O(PSOPSAVE(PMXZ)) Q:PMXZ="" S RXPR(PMXZ)=PSOPSAVE(PMXZ) + S PSMX="" F S PMXZ=$O(PSOHSAVE(PMXZ)) Q:PMXZ="" S RXRH(PMXZ)=PSOHSAVE(PMXZ) + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXL1.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXL1.m index 54491401..93262aa4 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXL1.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXL1.m @@ -1,97 +1,96 @@ -PSORXL1 ;BIR/SAB-action to be taken on prescriptions ; 10/5/07 2:40pm - ;;7.0;OUTPATIENT PHARMACY;**36,46,148,260,274**;DEC 1997;Build 8 -S S SPPL="",PPL1=1 S:'$G(PPL) PPL=$G(PSORX("PSOL",PPL1)) G:$G(PPL)']"" D1 -S1 F PI=1:1 Q:$P(PPL,",",PI)="" S DA=$P(PPL,",",PI) D - .I $P(^PSRX(DA,"STA"),"^")<10,$P(^("STA"),"^")'=4 D SUS Q - .I $P(^PSRX(DA,"STA"),"^")=4 S SPPL=SPPL_DA_"," Q - I $G(SPPL)]"" D K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR,DUOUT,DTOUT,DIRUT - .W !!,$C(7),"Drug Interaction Rx(s) " F I=1:1 Q:$P(SPPL,",",I)="" W $P(^PSRX($P(SPPL,",",I),0),"^")_", " - .I $G(PSOLAP)=""!($G(PSOLAP)=$G(ION)) W !,"Label device must be selected for Drug Interaction label!" - .S PPL=SPPL,DG=1 N PPL1 D Q^PSORXL K DG,SPPL - S SUSPT="SUSPENSE" G D1 - Q -SUS S ACT=1,RXN=DA,RX0=^PSRX(DA,0),SD=$S($G(ZD(DA)):$E(ZD(DA),1,7),1:$P(^(3),"^")),RXS=$O(^PS(52.5,"B",DA,0)) I RXS S RXCMOP=$P($G(^PS(52.5,RXS,0)),"^",7) D Q:$G(DFLG)!($G(PSOWFLG)) - .;checks to see if future fill exists - .S PSOWFLG=0 I '$G(RXPR(DA)),$P($G(^PS(52.5,RXS,"P")),"^")=0,$P($G(^PSRX(DA,"STA")),"^")=5 D SWARN Q:$G(PSOWFLG) - .K PSOWFLG I $G(RXPR(DA)),'$P($G(^PS(52.5,RXS,"P")),"^") D WARN Q:$G(DFLG) - .S DA=RXS,DIK="^PS(52.5," D ^DIK S DA=RXN I $P($G(^PSRX(RXN,"STA")),"^")=5 S $P(^("STA"),"^")=0 - G:$G(RXRP(DA))!($G(RXPR(DA))) LOCK - I $G(PSXSYS) D SUS1^PSOCMOP I $G(XFLAG)=1 K XFLAG Q -LOCK I $P($G(^PSRX(RXN,"STA")),"^")=3 G SUSQ - S RXP=+$G(RXPR(DA)),DIC="^PS(52.5,",DIC(0)="L",X=RXN,DIC("DR")=".02///"_SD_";.03////"_$P(^PSRX(DA,0),"^",2)_";.04///M;.05///"_RXP_";.06////"_PSOSITE_";2///0" K DD,DO D FILE^DICN D I +Y,'$G(RXP),$G(RXRP(RXN)) S $P(^PS(52.5,+Y,0),"^",12)=1 - .K DD,DO I +Y,$G(PSOEXREP) S $P(^PS(52.5,+Y,0),"^",12)=1 - .I +Y S $P(^PS(52.5,+Y,0),"^",13)=$G(RXFL(RXN)) - S $P(^PSRX(RXN,"STA"),"^")=5,LFD=$E(SD,4,5)_"-"_$E(SD,6,7)_"-"_$E(SD,2,3) D ACT - W !!,$S(RXP:"Partial ",1:"")_"RX# ",$P(^PSRX(RXN,0),"^")_" has been suspended until "_LFD_"." - S VALMSG=$S(RXP:"Partial ",1:"")_"Rx# "_$P(^PSRX(RXN,0),"^")_" Has Been Suspended Until "_LFD_"."_$S($G(RXRP(RXN))&('$G(RXP)):" (Reprint)",1:"") - S COMM=$S(RXP:"Partial ",1:"")_"Rx# "_$P(^PSRX(RXN,0),"^")_" Has Been Suspended Until "_LFD_"."_$S($G(RXRP(RXN))&('$G(RXP)):" (Reprint)",1:"") - D:'$D(^TMP("PSORXN",$J,RXN)) EN^PSOHLSN1(RXN,"SC","ZS",COMM) - S:$D(^TMP("PSORXN",$J,RXN)) $P(^TMP("PSORXN",$J,RXN),"^",4)=COMM - ; - ; - If not a PARTIAL, reverse ECME Claim, if necessary - I '$G(RXP) D REVERSE^PSOBPSU1(RXN,,"DC",3) - K COMM -SUSQ Q - ;PSO*7*274 allways recalculate RXF -ACT S RXF=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I S RXF=I S:I>5 RXF=I+1 - S IR=0 F FDA=0:0 S FDA=$O(^PSRX(DA,"A",FDA)) Q:'FDA S IR=FDA - S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR - D NOW^%DTC S ^PSRX(DA,"A",IR,0)=%_"^S^"_DUZ_"^"_RXF_"^"_$S(RXP:"Partial ",1:"")_"RX "_$S($G(RXRP(DA))&('$G(RXP)):"Reprint ",1:"")_"Placed on Suspense until "_LFD K RXF,I,FDA,DIC,DIE,DR,Y,X,%,%H,%I - Q -D1 I $O(PSORX("PSOL",$G(PPL1))) S PPL1=$O(PSORX("PSOL",$G(PPL1))),PPL=PSORX("PSOL",PPL1) G S1 - G:$D(RXRS) RXS^PSORXL - K LBL,PPL1,PPL,DIR,%DT,%,SD,COUNT,EXDT,L,PDUZ,REF,REPRINT,RFDATE,RFL1,RFLL,RXN,WARN,ZY,FLD,PI,ZD,ACT,X,Y,DIRUT,DUOUT,DTOUT,DIROUT,DFLG,RXPD,PSOWFLG - Q -WARN W ! K DIR,DIRUT,DUOUT,DTOUT,DFLG S Y=$P(^PS(52.5,RXS,0),"^",2) X ^DD("DD") S RXPD=Y,DIR(0)="SA^S:SUSPEND;Q:QUEUE;E:EXIT" - S DIR("A",1)="Rx #"_$P(^PSRX(DA,0),"^")_" is suspended "_$S($G(RXCMOP)]"":"for CMOP ",1:"")_"until "_RXPD - I $G(RXCMOP)]"" D G WARN1 - .W !!,"A partial entered for this Rx cannot be suspended." - .W !,"You may pull this fill from suspense or print the label now.",!! - .S DIR("A",2)=" ",DIR("A",3)=" Do you want to Queue to print",DIR("A")=" or Exit: " - S DIR("A",2)=" ",DIR("A",3)=" Do you want to: Suspend Partial",DIR("A",4)=" Queue to print",DIR("A")=" or Exit: " -WARN1 S DIR("B")="EXIT",DIR("?")="^D HLP^PSORXL1" D ^DIR K DIR - I Y="E"!($D(DIRUT))!(Y="S"&($G(RXCMOP)]"")) S DA(1)=DA,DA=RXPR(DA),DIK="^PSRX("_DA(1)_",""P""," D ^DIK S ^PSRX(DA(1),"TYPE")=0,DFLG=1 W $C(7)," Partial Removed!" Q - I Y="Q" S DPPL=PPL,HOLDPPL1=$G(PPL1),DPI=PI,RXLTOP=1 S PPL=$G(RXN)_"," S PSPARTXX=1 D Q^PSORXL K PSPARTXX S DFLG=1,PPL=DPPL,PI=DPI,PPL1=$G(HOLDPPL1) K HOLDPPL1,DPPL,DPPI,DPI,RXLTOP Q - Q -HLP I $G(RXCMOP)']"" W !!,"If you choose to suspend this partial Rx, the current suspended fill will",!,"be replaced by the partial. You may want to pull this fill early instead.",! - I $G(RXCMOP)]"" W !!,"You cannot suspend a partial when a CMOP fill is in suspense, because the partial will replace the CMOP fill in suspense." - W !,"If you choose to queue this partial, the label will printout on the previous",!,"selected label printer.",! - W !,"You may exit without printing or suspending this partial. This will also delete",!,"the partial Rx entered." - Q -SWARN ; - S PSORXLDA=$G(DA),PSORXZD=$P($G(^PS(52.5,RXS,0)),"^",2) - W $C(7),!!,"Rx "_$P($G(^PSRX(DA,0)),"^")_" is already suspended "_$S($G(RXCMOP)]"":"for CMOP ",1:"")_"until "_$E(PSORXZD,4,5)_"-"_$E(PSORXZD,6,7)_"-"_$E(PSORXZD,2,3)_"." K PSORXZD - W !,"By suspending this fill, the fill that is already suspended will be overwritten",!,"and a label will not print for that fill!",! - K DIR S DIR(0)="SA^Q:QUEUE;S:SUSPEND",DIR("B")="Q",DIR("A")="Do you want to Queue to print or Suspend Rx "_$P($G(^PSRX(DA,0)),"^")_": " D ^DIR K DIR - I $G(Y)="S" K RXFL(PSORXLDA) G SWARNQ - I $G(Y)="Q" D G SWARNQ - . S PSOKSPPL=$G(PPL),PSOZXPPL=$G(PPL1),PSOZXPI=$G(PI),RXLTOP=1 - . S PPL=$G(RXN)_"," D SWARS D Q^PSORXL S PSOWFLG=1,PPL=PSOKSPPL - . S PI=PSOZXPI,PPL1=PSOZXPPL K PSOKSPPL,PSOZXPPL,PSOZXPI,RXLTOP,RXFL(+$G(PSORXLDA)) - W !!,"Nothing queued to print for Rx "_$P($G(^PSRX(PSORXLDA,0)),"^"),! S PSOWFLG=1 -SWARNQ ; - S DA=$G(PSORXLDA) K PSORXLDA - Q -SWARS ; - S PSOZXFL(PSORXLDA)=+$P($G(^PS(52.5,+$G(RXS),0)),"^",13) I '$G(PSOZXFL(PSORXLDA)) K PSOZXFL Q - S PSOZXFPL=$P(PSOKSPPL,",",+$G(PI),99) - S PSOZXFPN=$L(PSOZXFPL,PPL)-1 - I $G(PSOZXFL(PSORXLDA)),$G(PSOZXFPN) S RXFL(PSORXLDA)=$G(PSOZXFL(PSORXLDA))-$G(PSOZXFPN) - K PSOZXFL,PSOZXFPL,PSOZXFPN - Q -ECME ; - Looks for DUR/79 REJECTS and send Mail Rx's to ECME that have not been SUSPENDED - N PSOI,PSOJ,PSORX,PSORF,PSOACT,BWH,PPLTMP - S PPLTMP=$G(PPL) - F PSOI=1:1 S PSORX=+$P($G(PPL),",",PSOI) Q:'PSORX D - . I $G(RXPR(PSORX)) Q - . S PSOACT="",PSORF=$$LSTRFL^PSOBPSU1(PSORX) - . S BWH=$S(PSORF:"RF",1:"OF") - . I $$FIND^PSOREJUT(PSORX,PSORF) D I PSOACT="Q" D RMV(PSORX,.PPLTMP) Q - . . S PSOACT=$$HDLG^PSOREJU1(PSORX,PSORF,"79,88",BWH,"OIQ","Q") - S:$G(PPLTMP)'="" PPL=PPLTMP - Q -RMV(RX,PPL) ; Remove the Rx from the label print queue - N XPPL,I - S XPPL=PPL,PPL="" F I=1:1:$L(XPPL,",") I $P(XPPL,",",I)'="",$P(XPPL,",",I)'=RX S PPL=PPL_$P(XPPL,",",I)_"," - I PPL="" K PPL - Q +PSORXL1 ;BIR/SAB-action to be taken on prescriptions ;03/01/96 + ;;7.0;OUTPATIENT PHARMACY;**36,46,148,260**;DEC 1997;Build 84 +S S SPPL="",PPL1=1 S:'$G(PPL) PPL=$G(PSORX("PSOL",PPL1)) G:$G(PPL)']"" D1 +S1 F PI=1:1 Q:$P(PPL,",",PI)="" S DA=$P(PPL,",",PI) D + .I $P(^PSRX(DA,"STA"),"^")<10,$P(^("STA"),"^")'=4 D SUS Q + .I $P(^PSRX(DA,"STA"),"^")=4 S SPPL=SPPL_DA_"," Q + I $G(SPPL)]"" D K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR,DUOUT,DTOUT,DIRUT + .W !!,$C(7),"Drug Interaction Rx(s) " F I=1:1 Q:$P(SPPL,",",I)="" W $P(^PSRX($P(SPPL,",",I),0),"^")_", " + .I $G(PSOLAP)=""!($G(PSOLAP)=$G(ION)) W !,"Label device must be selected for Drug Interaction label!" + .S PPL=SPPL,DG=1 N PPL1 D Q^PSORXL K DG,SPPL + S SUSPT="SUSPENSE" G D1 + Q +SUS S ACT=1,RXN=DA,RX0=^PSRX(DA,0),SD=$S($G(ZD(DA)):$E(ZD(DA),1,7),1:$P(^(3),"^")),RXS=$O(^PS(52.5,"B",DA,0)) I RXS S RXCMOP=$P($G(^PS(52.5,RXS,0)),"^",7) D Q:$G(DFLG)!($G(PSOWFLG)) + .;checks to see if future fill exists + .S PSOWFLG=0 I '$G(RXPR(DA)),$P($G(^PS(52.5,RXS,"P")),"^")=0,$P($G(^PSRX(DA,"STA")),"^")=5 D SWARN Q:$G(PSOWFLG) + .K PSOWFLG I $G(RXPR(DA)),'$P($G(^PS(52.5,RXS,"P")),"^") D WARN Q:$G(DFLG) + .S DA=RXS,DIK="^PS(52.5," D ^DIK S DA=RXN I $P($G(^PSRX(RXN,"STA")),"^")=5 S $P(^("STA"),"^")=0 + G:$G(RXRP(DA))!($G(RXPR(DA))) LOCK + I $G(PSXSYS) D SUS1^PSOCMOP I $G(XFLAG)=1 K XFLAG Q +LOCK I $P($G(^PSRX(RXN,"STA")),"^")=3 G SUSQ + S RXP=+$G(RXPR(DA)),DIC="^PS(52.5,",DIC(0)="L",X=RXN,DIC("DR")=".02///"_SD_";.03////"_$P(^PSRX(DA,0),"^",2)_";.04///M;.05///"_RXP_";.06////"_PSOSITE_";2///0" K DD,DO D FILE^DICN D I +Y,'$G(RXP),$G(RXRP(RXN)) S $P(^PS(52.5,+Y,0),"^",12)=1 + .K DD,DO I +Y,$G(PSOEXREP) S $P(^PS(52.5,+Y,0),"^",12)=1 + .I +Y S $P(^PS(52.5,+Y,0),"^",13)=$G(RXFL(RXN)) + S $P(^PSRX(RXN,"STA"),"^")=5,LFD=$E(SD,4,5)_"-"_$E(SD,6,7)_"-"_$E(SD,2,3) D ACT + W !!,$S(RXP:"Partial ",1:"")_"RX# ",$P(^PSRX(RXN,0),"^")_" has been suspended until "_LFD_"." + S VALMSG=$S(RXP:"Partial ",1:"")_"Rx# "_$P(^PSRX(RXN,0),"^")_" Has Been Suspended Until "_LFD_"."_$S($G(RXRP(RXN))&('$G(RXP)):" (Reprint)",1:"") + S COMM=$S(RXP:"Partial ",1:"")_"Rx# "_$P(^PSRX(RXN,0),"^")_" Has Been Suspended Until "_LFD_"."_$S($G(RXRP(RXN))&('$G(RXP)):" (Reprint)",1:"") + D:'$D(^TMP("PSORXN",$J,RXN)) EN^PSOHLSN1(RXN,"SC","ZS",COMM) + S:$D(^TMP("PSORXN",$J,RXN)) $P(^TMP("PSORXN",$J,RXN),"^",4)=COMM + ; + ; - If not a PARTIAL, reverse ECME Claim, if necessary + I '$G(RXP) D REVERSE^PSOBPSU1(RXN,,"DC",3) + K COMM +SUSQ Q +ACT I '$D(RXF) S RXF=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I S RXF=I S:I>5 RXF=I+1 + S IR=0 F FDA=0:0 S FDA=$O(^PSRX(DA,"A",FDA)) Q:'FDA S IR=FDA + S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR + D NOW^%DTC S ^PSRX(DA,"A",IR,0)=%_"^S^"_DUZ_"^"_RXF_"^"_$S(RXP:"Partial ",1:"")_"RX "_$S($G(RXRP(DA))&('$G(RXP)):"Reprint ",1:"")_"Placed on Suspense until "_LFD K RXF,I,FDA,DIC,DIE,DR,Y,X,%,%H,%I + Q +D1 I $O(PSORX("PSOL",$G(PPL1))) S PPL1=$O(PSORX("PSOL",$G(PPL1))),PPL=PSORX("PSOL",PPL1) G S1 + G:$D(RXRS) RXS^PSORXL + K LBL,PPL1,PPL,DIR,%DT,%,SD,COUNT,EXDT,L,PDUZ,REF,REPRINT,RFDATE,RFL1,RFLL,RXN,WARN,ZY,FLD,PI,ZD,ACT,X,Y,DIRUT,DUOUT,DTOUT,DIROUT,DFLG,RXPD,PSOWFLG + Q +WARN W ! K DIR,DIRUT,DUOUT,DTOUT,DFLG S Y=$P(^PS(52.5,RXS,0),"^",2) X ^DD("DD") S RXPD=Y,DIR(0)="SA^S:SUSPEND;Q:QUEUE;E:EXIT" + S DIR("A",1)="Rx #"_$P(^PSRX(DA,0),"^")_" is suspended "_$S($G(RXCMOP)]"":"for CMOP ",1:"")_"until "_RXPD + I $G(RXCMOP)]"" D G WARN1 + .W !!,"A partial entered for this Rx cannot be suspended." + .W !,"You may pull this fill from suspense or print the label now.",!! + .S DIR("A",2)=" ",DIR("A",3)=" Do you want to Queue to print",DIR("A")=" or Exit: " + S DIR("A",2)=" ",DIR("A",3)=" Do you want to: Suspend Partial",DIR("A",4)=" Queue to print",DIR("A")=" or Exit: " +WARN1 S DIR("B")="EXIT",DIR("?")="^D HLP^PSORXL1" D ^DIR K DIR + I Y="E"!($D(DIRUT))!(Y="S"&($G(RXCMOP)]"")) S DA(1)=DA,DA=RXPR(DA),DIK="^PSRX("_DA(1)_",""P""," D ^DIK S ^PSRX(DA(1),"TYPE")=0,DFLG=1 W $C(7)," Partial Removed!" Q + I Y="Q" S DPPL=PPL,HOLDPPL1=$G(PPL1),DPI=PI,RXLTOP=1 S PPL=$G(RXN)_"," S PSPARTXX=1 D Q^PSORXL K PSPARTXX S DFLG=1,PPL=DPPL,PI=DPI,PPL1=$G(HOLDPPL1) K HOLDPPL1,DPPL,DPPI,DPI,RXLTOP Q + Q +HLP I $G(RXCMOP)']"" W !!,"If you choose to suspend this partial Rx, the current suspended fill will",!,"be replaced by the partial. You may want to pull this fill early instead.",! + I $G(RXCMOP)]"" W !!,"You cannot suspend a partial when a CMOP fill is in suspense, because the partial will replace the CMOP fill in suspense." + W !,"If you choose to queue this partial, the label will printout on the previous",!,"selected label printer.",! + W !,"You may exit without printing or suspending this partial. This will also delete",!,"the partial Rx entered." + Q +SWARN ; + S PSORXLDA=$G(DA),PSORXZD=$P($G(^PS(52.5,RXS,0)),"^",2) + W $C(7),!!,"Rx "_$P($G(^PSRX(DA,0)),"^")_" is already suspended "_$S($G(RXCMOP)]"":"for CMOP ",1:"")_"until "_$E(PSORXZD,4,5)_"-"_$E(PSORXZD,6,7)_"-"_$E(PSORXZD,2,3)_"." K PSORXZD + W !,"By suspending this fill, the fill that is already suspended will be overwritten",!,"and a label will not print for that fill!",! + K DIR S DIR(0)="SA^Q:QUEUE;S:SUSPEND",DIR("B")="Q",DIR("A")="Do you want to Queue to print or Suspend Rx "_$P($G(^PSRX(DA,0)),"^")_": " D ^DIR K DIR + I $G(Y)="S" K RXFL(PSORXLDA) G SWARNQ + I $G(Y)="Q" D G SWARNQ + . S PSOKSPPL=$G(PPL),PSOZXPPL=$G(PPL1),PSOZXPI=$G(PI),RXLTOP=1 + . S PPL=$G(RXN)_"," D SWARS D Q^PSORXL S PSOWFLG=1,PPL=PSOKSPPL + . S PI=PSOZXPI,PPL1=PSOZXPPL K PSOKSPPL,PSOZXPPL,PSOZXPI,RXLTOP,RXFL(+$G(PSORXLDA)) + W !!,"Nothing queued to print for Rx "_$P($G(^PSRX(PSORXLDA,0)),"^"),! S PSOWFLG=1 +SWARNQ ; + S DA=$G(PSORXLDA) K PSORXLDA + Q +SWARS ; + S PSOZXFL(PSORXLDA)=+$P($G(^PS(52.5,+$G(RXS),0)),"^",13) I '$G(PSOZXFL(PSORXLDA)) K PSOZXFL Q + S PSOZXFPL=$P(PSOKSPPL,",",+$G(PI),99) + S PSOZXFPN=$L(PSOZXFPL,PPL)-1 + I $G(PSOZXFL(PSORXLDA)),$G(PSOZXFPN) S RXFL(PSORXLDA)=$G(PSOZXFL(PSORXLDA))-$G(PSOZXFPN) + K PSOZXFL,PSOZXFPL,PSOZXFPN + Q +ECME ; - Looks for DUR/79 REJECTS and send Mail Rx's to ECME that have not been SUSPENDED + N PSOI,PSOJ,PSORX,PSORF,PSOACT,BWH,PPLTMP + S PPLTMP=$G(PPL) + F PSOI=1:1 S PSORX=+$P($G(PPL),",",PSOI) Q:'PSORX D + . I $G(RXPR(PSORX)) Q + . S PSOACT="",PSORF=$$LSTRFL^PSOBPSU1(PSORX) + . S BWH=$S(PSORF:"RF",1:"OF") + . I $$FIND^PSOREJUT(PSORX,PSORF) D I PSOACT="Q" D RMV(PSORX,.PPLTMP) Q + . . S PSOACT=$$HDLG^PSOREJU1(PSORX,PSORF,"79,88",BWH,"OIQ","Q") + S:$G(PPLTMP)'="" PPL=PPLTMP + Q +RMV(RX,PPL) ; Remove the Rx from the label print queue + N XPPL,I + S XPPL=PPL,PPL="" F I=1:1:$L(XPPL,",") I $P(XPPL,",",I)'="",$P(XPPL,",",I)'=RX S PPL=PPL_$P(XPPL,",",I)_"," + I PPL="" K PPL + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXPA1.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXPA1.m index 67499d42..41d02550 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXPA1.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXPA1.m @@ -1,88 +1,88 @@ -PSORXPA1 ;BIR/SAB - listman partial prescriptions ; 1/15/07 5:42pm - ;;7.0;OUTPATIENT PHARMACY;**11,27,56,77,130,152,181,174,208**;DEC 1997;Build 41 - ; 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 - ;External references L,UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789 - ;External reference to ^PSDRUG supported by DBIA 221 - ;External reference to ^DD(52 supported by DBIA 999 - S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" ;vfah - D ^DIC K DIC ;vfah - S PSOZAF=+Y ;vfah Quits if AUTOFINISH,RX not a user - I $P($G(^PSRX(RXN,"OR1")),"^",5)=$G(PSOZAF) S VALMBCK="",VALMSG="Partial option is not available for Autofinshed Rxs" K PSOZAF Q ;vfah - I $D(RXRP($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Reprint Label has been requested!" Q - ;I $D(RXPR($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Partial has already been requested!" Q - I $D(RXRS($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="Rx is being pulled from suspense!" Q - S PSORPDFN=+$P($G(^PSRX($P(PSOLST(ORN),"^",2),0)),"^",2) - S PSOPLCK=$$L^PSSLOCK(PSORPDFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.") K PSOPLCK,PSORPDFN D Q - .S VALMBCK="" - K PSOPLCK D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) D UL^PSSLOCK(PSORPDFN) S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG,PSORPDFN Q - I '$G(RXPR($P(PSOLST(ORN),"^",2))) S RX=$P(PSOLST(ORN),"^",2) D VALID^PSORXRP1 I $G(QFLG) S VALMBCK="",VALMSG="A New Label has been requested already!" K QFLG,RX D ULK Q - D FULL^VALM1 I '$D(PSOPAR) D ^PSOLSET D:'$D(PSOPAR) ULK G:'$D(PSOPAR) KL - S DA=$P(PSOLST(ORN),"^",2),RX0=^PSRX(DA,0),J=DA,RX2=$G(^(2)),R3=$G(^(3)) S:'$G(BBFLG) BBRX(1)="" - I +$P($G(^PSRX(DA,2)),"^",6)
PSOPRZ D ULK G KILL - I Z1,$G(PRMK)]"" D D:$T(EN^PSOHDR)]"" EN^PSOHDR("PPAR",RXN) K DIE,RXN,RXF - .D ACT S:$P($G(^PSRX(RXN,"P",Z1,0)),"^",2)["W" PSODFN=$P(^PSRX(RXN,0),"^",2),BINGRTE="W",BBFLG=1,BBRX(1)=$G(BBRX(1))_RXN_"," - .S ZD(RXN)=+^PSRX(RXN,"P",Z1,0),^PSRX(RXN,"TYPE")=Z1,$P(^PSRX(RXN,"P",Z1,0),"^",11)=$P($G(^PSDRUG(DRG,660)),"^",6),RXF=6,RXP=Z1,RXPR(RXN)=RXP - .;I $G(PSOZZ)=1,($G(Z1)) D Q1^PSORXL K Z1,PSOZZ Q - .I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=RXN_"," Q - .F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1 Q:PSORX("PSOL",PSOX1)[RXN_"," S PSOX2=PSOX1 - .I PSOX1 Q - .I $L(PSORX("PSOL",PSOX2))+$L(RXN)<220 S:PSORX("PSOL",PSOX2)'[RXN_"," PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_RXN_"," - .E S PSORX("PSOL",PSOX2+1)=RXN_"," - S:'$D(PSOFROM) PSOFROM="PARTIAL" S BINGCRT=1 ;D:$D(BINGRTE)&($D(DISGROUP)) ^PSOBING1 K BINGRTE,TM,TM1 -CLCX D ULK K DR,DIE,DRG,PPL,RXP,IOP,DA,PHYS,PSOPRZ S VALMBCK="R" Q - ; -KILL S DA=Z1,DIK="^PSRX("_RXN_",""P""," D ^DIK S ^PSRX(RXN,"TYPE")=0 - D ULK S VALMSG="No Partial Fill Dispensed",VALMBCK="R" Q -KL K DFN,RFDAT,RLL,%,PRMK,PM,%Y,%X,D0,D1,DA,DI,DIC,DIE,DLAYGO,DQ,DR,I,II,J,JJJ,N,PHYS,PS,PSDATE,RFL,RFL1,RXF,ST,ST0,Z,Z1,X,Y,PDT,PSL,PSNP - K PSOM,PSOP,PSOD,PSOU,DIK,DUOUT,IFN,RXN,DRG,HRX,I1,PSOCLC,PSOLIST,PSOLST,PSPAR,RXP D KVA^VADPT Q -ACT ;adds activity info for partial rx - S RXF=0 F I=0:0 S I=$O(^PSRX(RXN,1,I)) Q:'I S RXF=I S:I>5 RXF=I+1 - S DA=0 F FDA=0:0 S FDA=$O(^PSRX(RXN,"A",FDA)) Q:'FDA S DA=FDA - S DA=DA+1,^PSRX(RXN,"A",0)="^52.3DA^"_DA_"^"_DA,^PSRX(RXN,"A",DA,0)=DT_"^"_"P"_"^"_DUZ_"^"_RXF_"^"_PRMK -EX K RXF,I,FDA S DA=RXN - Q -ULK ; - D UL^PSSLOCK(+$G(PSORPDFN)) - D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) - K PSOMSG,PSOPLCK,PSORPDFN - Q +PSORXPA1 ;BIR/SAB - listman partial prescriptions ; 1/15/07 5:42pm + ;;7.0;OUTPATIENT PHARMACY;**11,27,56,77,130,152,181,174,208**;DEC 1997;Build 39 + ; 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 + ;External references L,UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789 + ;External reference to ^PSDRUG supported by DBIA 221 + ;External reference to ^DD(52 supported by DBIA 999 + S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" ;vfah + D ^DIC K DIC ;vfah + S PSOZAF=+Y ;vfah Quits if AUTOFINISH,RX not a user + I $P($G(^PSRX(RXN,"OR1")),"^",5)=$G(PSOZAF) S VALMBCK="",VALMSG="Partial option is not available for Autofinshed Rxs" K PSOZAF Q ;vfah + I $D(RXRP($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Reprint Label has been requested!" Q + ;I $D(RXPR($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Partial has already been requested!" Q + I $D(RXRS($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="Rx is being pulled from suspense!" Q + S PSORPDFN=+$P($G(^PSRX($P(PSOLST(ORN),"^",2),0)),"^",2) + S PSOPLCK=$$L^PSSLOCK(PSORPDFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.") K PSOPLCK,PSORPDFN D Q + .S VALMBCK="" + K PSOPLCK D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) D UL^PSSLOCK(PSORPDFN) S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG,PSORPDFN Q + I '$G(RXPR($P(PSOLST(ORN),"^",2))) S RX=$P(PSOLST(ORN),"^",2) D VALID^PSORXRP1 I $G(QFLG) S VALMBCK="",VALMSG="A New Label has been requested already!" K QFLG,RX D ULK Q + D FULL^VALM1 I '$D(PSOPAR) D ^PSOLSET D:'$D(PSOPAR) ULK G:'$D(PSOPAR) KL + S DA=$P(PSOLST(ORN),"^",2),RX0=^PSRX(DA,0),J=DA,RX2=$G(^(2)),R3=$G(^(3)) S:'$G(BBFLG) BBRX(1)="" + I +$P($G(^PSRX(DA,2)),"^",6)
PSOPRZ D ULK G KILL + I Z1,$G(PRMK)]"" D D:$T(EN^PSOHDR)]"" EN^PSOHDR("PPAR",RXN) K DIE,RXN,RXF + .D ACT S:$P($G(^PSRX(RXN,"P",Z1,0)),"^",2)["W" PSODFN=$P(^PSRX(RXN,0),"^",2),BINGRTE="W",BBFLG=1,BBRX(1)=$G(BBRX(1))_RXN_"," + .S ZD(RXN)=+^PSRX(RXN,"P",Z1,0),^PSRX(RXN,"TYPE")=Z1,$P(^PSRX(RXN,"P",Z1,0),"^",11)=$P($G(^PSDRUG(DRG,660)),"^",6),RXF=6,RXP=Z1,RXPR(RXN)=RXP + .;I $G(PSOZZ)=1,($G(Z1)) D Q1^PSORXL K Z1,PSOZZ Q + .I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=RXN_"," Q + .F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1 Q:PSORX("PSOL",PSOX1)[RXN_"," S PSOX2=PSOX1 + .I PSOX1 Q + .I $L(PSORX("PSOL",PSOX2))+$L(RXN)<220 S:PSORX("PSOL",PSOX2)'[RXN_"," PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_RXN_"," + .E S PSORX("PSOL",PSOX2+1)=RXN_"," + S:'$D(PSOFROM) PSOFROM="PARTIAL" S BINGCRT=1 ;D:$D(BINGRTE)&($D(DISGROUP)) ^PSOBING1 K BINGRTE,TM,TM1 +CLCX D ULK K DR,DIE,DRG,PPL,RXP,IOP,DA,PHYS,PSOPRZ S VALMBCK="R" Q + ; +KILL S DA=Z1,DIK="^PSRX("_RXN_",""P""," D ^DIK S ^PSRX(RXN,"TYPE")=0 + D ULK S VALMSG="No Partial Fill Dispensed",VALMBCK="R" Q +KL K DFN,RFDAT,RLL,%,PRMK,PM,%Y,%X,D0,D1,DA,DI,DIC,DIE,DLAYGO,DQ,DR,I,II,J,JJJ,N,PHYS,PS,PSDATE,RFL,RFL1,RXF,ST,ST0,Z,Z1,X,Y,PDT,PSL,PSNP + K PSOM,PSOP,PSOD,PSOU,DIK,DUOUT,IFN,RXN,DRG,HRX,I1,PSOCLC,PSOLIST,PSOLST,PSPAR,RXP D KVA^VADPT Q +ACT ;adds activity info for partial rx + S RXF=0 F I=0:0 S I=$O(^PSRX(RXN,1,I)) Q:'I S RXF=I S:I>5 RXF=I+1 + S DA=0 F FDA=0:0 S FDA=$O(^PSRX(RXN,"A",FDA)) Q:'FDA S DA=FDA + S DA=DA+1,^PSRX(RXN,"A",0)="^52.3DA^"_DA_"^"_DA,^PSRX(RXN,"A",DA,0)=DT_"^"_"P"_"^"_DUZ_"^"_RXF_"^"_PRMK +EX K RXF,I,FDA S DA=RXN + Q +ULK ; + D UL^PSSLOCK(+$G(PSORPDFN)) + D PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) + K PSOMSG,PSOPLCK,PSORPDFN + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXRP1.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXRP1.m index f72065cf..d7746062 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXRP1.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXRP1.m @@ -1,97 +1,97 @@ -PSORXRP1 ;BIR/SAB-rx speed reprint listman ; 12/10/06 9:50pm - ;;7.0;OUTPATIENT PHARMACY;**11,27,120,156,148,208**;DEC 1997;Build 41 - ; 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 - ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789 -SEL N PSODISP,VALMCNT I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!" S VALMBCK="" Q - S RXCNT=0 K PSOFDR,DIR,DUOUT,DIRUT S DIR("A")="Select Orders by number",DIR(0)="LO^1:"_PSOCNT D ^DIR S LST=Y I $D(DTOUT)!($D(DUOUT)) K DIR,DIRUT,DTOUT,DUOUT S VALMBCK="" Q - K DIR,DIRUT,DTOUT,PSOOELSE,PSOREPX I +LST S PSOOELSE=1 D - .D FULL^VALM1 K DIR S DIR("A")="Number of Copies? ",DIR(0)="N^1:99:0",DIR("?")="Enter the number of copies you want (1 TO 99)",DIR("B")=1 - .D ^DIR K DIR S:$D(DIRUT) PSOREPX=1 Q:$D(DIRUT) S COPIES=Y - .K DIR S DIR("A")="Print adhesive portion of label only? ",DIR(0)="Y",DIR("B")="No",DIR("?",1)="If entire label, including trailers are to print press RETURN for default." - .S DIR("?")="Else if only bottle and mailing labels are to print enter Y or YES." D ^DIR K DIR S:$D(DIRUT) PSOREPX=1 Q:$D(DIRUT) S SIDE=Y - .I $P(PSOPAR,"^",30),$$GET1^DIQ(59,PSOSITE_",",105,"I")=2.4 D Q:$G(PSOREPX) - ..K DIR,DIRUT S DIR("A")="Do you want to resend to Dispensing System Device",DIR(0)="Y",DIR("B")="No" - ..D ^DIR K DIR S:$D(DIRUT) PSOREPX=1 Q:$D(DIRUT) S PSODISP=$S(Y:0,1:1) - .K DIRUT,DIR S DIR("A")="Comments: ",DIR(0)="FA^5:60",DIR("?")="5-60 characters input required for activity log." S:$G(PCOMX)]"" DIR("B")=$G(PCOMX) - .D ^DIR K DIR S:$D(DIRUT) PSOREPX=1 Q:$D(DIRUT) S (PCOM,PCOMX)=Y - .S PSOCLC=DUZ - .F ORD=1:1:$L(LST,",") Q:$P(LST,",",ORD)']"" S ORN=$P(LST,",",ORD),QFLG=0 D:+PSOLST(ORN)=52 RX - .S VALMBCK="R" - I $G(PSOREPX) S VALMBCK="R",VALMSG="No Labels Reprinted." - K PSOREPX - I '$G(PSOOELSE) S VALMBCK="" - D ^PSOBUILD - K PSOMSG,PSORPSRX,QFLG,%,DIR,DUOUT,DTOUT,DIROUT,DIRUT,PCOM,PCOMX,C,I,J,JJJ,K,RX,RXF,X,Y,Z,P,PDA,PSPRXN,COPIES,SIDE,PPL,REPRINT,PSOOELSE,ORD,LST,ORN D KVA^VADPT - Q - ; -RX ;process reprint request - ; - S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" ;vfah - D ^DIC K DIC ;vfah - S PSOZAF=+Y ;vfah - I $P($G(^PSRX($P(PSOLST(ORN),"^",2),"OR1")),"^",5)=$G(PSOZAF) W $C(7),!!,"Rx "_$$GET1^DIQ(52,$P(PSOLST(ORN),"^",2),.01)_" is an Autofinish,Rx and labels can not be reprinted." K PSOZAF D PAUSE^VALM1 Q ;vfah - ; - Q:$P(^PSRX($P(PSOLST(ORN),"^",2),"STA"),"^")>11 - I $$LMREJ^PSOREJU1($P(PSOLST(ORN),"^",2)) W $C(7),!!,"Rx "_$$GET1^DIQ(52,$P(PSOLST(ORN),"^",2),.01)_" has OPEN/UNRESOLVED 3rd Party Payer Rejects!" K DIR D PAUSE^VALM1 Q - S PSORPSRX=$P(PSOLST(ORN),"^",2) D PSOL^PSSLOCK(PSORPSRX) I '$G(PSOMSG) W $C(7),!!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing Rx "_$P($G(^PSRX(PSORPSRX,0)),"^")),! D PAUSE^VALM1 K PSORPSRX,PSOMSG Q - S RX=$P(PSOLST(ORN),"^",2),STA=$P(^PSRX($P(PSOLST(ORN),"^",2),"STA"),"^") D CHK I $G(QFLG) D ULR Q - S RXF=0,ZD(RX)=DT,REPRINT=1 - S RXRP($P(PSOLST(ORN),"^",2))=1_"^"_COPIES_"^"_SIDE - I $G(PSODISP)=1 S RXRP($P(PSOLST(ORN),"^",2),"RP")=1 - S RXFL($P(PSOLST(ORN),"^",2))=0 F ZZZ=0:0 S ZZZ=$O(^PSRX($P(PSOLST(ORN),"^",2),1,ZZZ)) Q:'ZZZ S RXFL($P(PSOLST(ORN),"^",2))=ZZZ - K ZZZ - I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=RX_"," S ST="" D ACT1,ULR Q - F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1 S PSOX2=PSOX1 - I $L(PSORX("PSOL",PSOX2))+$L(RX)<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_RX_"," - E S PSORX("PSOL",PSOX2+1)=RX_"," - S ST="" D ACT1 - D ULR - Q -CHK ;check for valid reprint - I DT>$P(^PSRX(RX,2),"^",6) D S QFLG=1 Q - .I $P(^PSRX(RX,"STA"),"^")<11 S $P(^PSRX(RX,"STA"),"^")=11 D - ..S COMM="Medication Expired on "_$E($P(^PSRX(RX,2),6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) D EN^PSOHLSN1(RX,"SC","ZE",COMM) K COMM - S DFN=PSODFN D DEM^VADPT I $P(VADM(6),"^",2)]"" D S QFLG=1 Q - .S $P(^PSRX(RX,"STA"),"^")=12,PCOM="Patient Expired "_$P(VADM(6),"^",2),ST="C" D EN^PSOHLSN1(RX,"OD","",PCOM,"A") - .D ACT1 - I $D(RXPR($P(PSOLST(ORN),"^",2)))!$D(RXRP($P(PSOLST(ORN),"^",2))) S QFLG=1 Q - D VALID Q:$G(QFLG) - S X=$O(^PS(52.5,"B",RX,0)) I X,'$G(^PS(52.5,X,"P")) S QFLG=1 Q - I $G(X)'>0 G GOOD - I $P($G(^PS(52.5,X,0)),"^",7)']"" G GOOD - I $P($G(^PS(52.5,X,0)),"^",7)="Q" K X,XX S QFLG=1 Q - I $P($G(^PS(52.5,X,0)),"^",7)="L" K X,XX S QFLG=1 Q -GOOD K X - I $D(^PS(52.4,RX)) S QFLG=1 Q - I $D(^PS(52.4,"AREF",PSODFN,RX)) S QFLG=1 Q - I $G(PSODIV),$D(^PSRX(RX,2)),+$P(^(2),"^",9),+$P(^(2),"^",9)'=PSOSITE S PSPOP=0,PSPRXN=RX D CHK1^PSOUTLA I $G(POERR)&(PSPOP) S QFLG=1 Q - I STA=3!(STA=4)!(STA=12) S QFLG=1 Q - Q -ACT1 S RXF=0 F J=0:0 S J=$O(^PSRX(RX,1,J)) Q:'J S RXF=J S:J>5 RXF=J+1 - S IR=0 F J=0:0 S J=$O(^PSRX(RX,"A",J)) Q:'J S IR=J - S IR=IR+1,^PSRX(RX,"A",0)="^52.3DA^"_IR_"^"_IR - D NOW^%DTC S ^PSRX(RX,"A",IR,0)=%_"^"_$S($G(ST)'="C":"W",1:"C")_"^"_DUZ_"^"_RXF_"^"_PCOM_$S($G(ST)'="C":" ("_COPIES_" COPIES)",1:""),PCOMX=PCOM K PC,IR,PS,XX,%,%H,%I,RXF - S:$P(^PSRX(RX,2),"^",15)&($G(ST)'="C") $P(^PSRX(RX,2),"^",14)=1 - Q -VALID ;check for rx in label array - I $O(PSORX("PSOL",0)) D - .F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1 I PSORX("PSOL",PSOX1)[RX_"," S QFLG=1 Q - Q -ULR ; - I $G(PSORPSRX) D PSOUL^PSSLOCK(PSORPSRX) - Q +PSORXRP1 ;BIR/SAB-rx speed reprint listman ; 12/10/06 9:50pm + ;;7.0;OUTPATIENT PHARMACY;**11,27,120,156,148,208**;DEC 1997;Build 39 + ; 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 + ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789 +SEL N PSODISP,VALMCNT I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!" S VALMBCK="" Q + S RXCNT=0 K PSOFDR,DIR,DUOUT,DIRUT S DIR("A")="Select Orders by number",DIR(0)="LO^1:"_PSOCNT D ^DIR S LST=Y I $D(DTOUT)!($D(DUOUT)) K DIR,DIRUT,DTOUT,DUOUT S VALMBCK="" Q + K DIR,DIRUT,DTOUT,PSOOELSE,PSOREPX I +LST S PSOOELSE=1 D + .D FULL^VALM1 K DIR S DIR("A")="Number of Copies? ",DIR(0)="N^1:99:0",DIR("?")="Enter the number of copies you want (1 TO 99)",DIR("B")=1 + .D ^DIR K DIR S:$D(DIRUT) PSOREPX=1 Q:$D(DIRUT) S COPIES=Y + .K DIR S DIR("A")="Print adhesive portion of label only? ",DIR(0)="Y",DIR("B")="No",DIR("?",1)="If entire label, including trailers are to print press RETURN for default." + .S DIR("?")="Else if only bottle and mailing labels are to print enter Y or YES." D ^DIR K DIR S:$D(DIRUT) PSOREPX=1 Q:$D(DIRUT) S SIDE=Y + .I $P(PSOPAR,"^",30),$$GET1^DIQ(59,PSOSITE_",",105,"I")=2.4 D Q:$G(PSOREPX) + ..K DIR,DIRUT S DIR("A")="Do you want to resend to Dispensing System Device",DIR(0)="Y",DIR("B")="No" + ..D ^DIR K DIR S:$D(DIRUT) PSOREPX=1 Q:$D(DIRUT) S PSODISP=$S(Y:0,1:1) + .K DIRUT,DIR S DIR("A")="Comments: ",DIR(0)="FA^5:60",DIR("?")="5-60 characters input required for activity log." S:$G(PCOMX)]"" DIR("B")=$G(PCOMX) + .D ^DIR K DIR S:$D(DIRUT) PSOREPX=1 Q:$D(DIRUT) S (PCOM,PCOMX)=Y + .S PSOCLC=DUZ + .F ORD=1:1:$L(LST,",") Q:$P(LST,",",ORD)']"" S ORN=$P(LST,",",ORD),QFLG=0 D:+PSOLST(ORN)=52 RX + .S VALMBCK="R" + I $G(PSOREPX) S VALMBCK="R",VALMSG="No Labels Reprinted." + K PSOREPX + I '$G(PSOOELSE) S VALMBCK="" + D ^PSOBUILD + K PSOMSG,PSORPSRX,QFLG,%,DIR,DUOUT,DTOUT,DIROUT,DIRUT,PCOM,PCOMX,C,I,J,JJJ,K,RX,RXF,X,Y,Z,P,PDA,PSPRXN,COPIES,SIDE,PPL,REPRINT,PSOOELSE,ORD,LST,ORN D KVA^VADPT + Q + ; +RX ;process reprint request + ; + S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" ;vfah + D ^DIC K DIC ;vfah + S PSOZAF=+Y ;vfah + I $P($G(^PSRX($P(PSOLST(ORN),"^",2),"OR1")),"^",5)=$G(PSOZAF) W $C(7),!!,"Rx "_$$GET1^DIQ(52,$P(PSOLST(ORN),"^",2),.01)_" is an Autofinish,Rx and labels can not be reprinted." K PSOZAF D PAUSE^VALM1 Q ;vfah + ; + Q:$P(^PSRX($P(PSOLST(ORN),"^",2),"STA"),"^")>11 + I $$LMREJ^PSOREJU1($P(PSOLST(ORN),"^",2)) W $C(7),!!,"Rx "_$$GET1^DIQ(52,$P(PSOLST(ORN),"^",2),.01)_" has OPEN/UNRESOLVED 3rd Party Payer Rejects!" K DIR D PAUSE^VALM1 Q + S PSORPSRX=$P(PSOLST(ORN),"^",2) D PSOL^PSSLOCK(PSORPSRX) I '$G(PSOMSG) W $C(7),!!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing Rx "_$P($G(^PSRX(PSORPSRX,0)),"^")),! D PAUSE^VALM1 K PSORPSRX,PSOMSG Q + S RX=$P(PSOLST(ORN),"^",2),STA=$P(^PSRX($P(PSOLST(ORN),"^",2),"STA"),"^") D CHK I $G(QFLG) D ULR Q + S RXF=0,ZD(RX)=DT,REPRINT=1 + S RXRP($P(PSOLST(ORN),"^",2))=1_"^"_COPIES_"^"_SIDE + I $G(PSODISP)=1 S RXRP($P(PSOLST(ORN),"^",2),"RP")=1 + S RXFL($P(PSOLST(ORN),"^",2))=0 F ZZZ=0:0 S ZZZ=$O(^PSRX($P(PSOLST(ORN),"^",2),1,ZZZ)) Q:'ZZZ S RXFL($P(PSOLST(ORN),"^",2))=ZZZ + K ZZZ + I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=RX_"," S ST="" D ACT1,ULR Q + F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1 S PSOX2=PSOX1 + I $L(PSORX("PSOL",PSOX2))+$L(RX)<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_RX_"," + E S PSORX("PSOL",PSOX2+1)=RX_"," + S ST="" D ACT1 + D ULR + Q +CHK ;check for valid reprint + I DT>$P(^PSRX(RX,2),"^",6) D S QFLG=1 Q + .I $P(^PSRX(RX,"STA"),"^")<11 S $P(^PSRX(RX,"STA"),"^")=11 D + ..S COMM="Medication Expired on "_$E($P(^PSRX(RX,2),6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) D EN^PSOHLSN1(RX,"SC","ZE",COMM) K COMM + S DFN=PSODFN D DEM^VADPT I $P(VADM(6),"^",2)]"" D S QFLG=1 Q + .S $P(^PSRX(RX,"STA"),"^")=12,PCOM="Patient Expired "_$P(VADM(6),"^",2),ST="C" D EN^PSOHLSN1(RX,"OD","",PCOM,"A") + .D ACT1 + I $D(RXPR($P(PSOLST(ORN),"^",2)))!$D(RXRP($P(PSOLST(ORN),"^",2))) S QFLG=1 Q + D VALID Q:$G(QFLG) + S X=$O(^PS(52.5,"B",RX,0)) I X,'$G(^PS(52.5,X,"P")) S QFLG=1 Q + I $G(X)'>0 G GOOD + I $P($G(^PS(52.5,X,0)),"^",7)']"" G GOOD + I $P($G(^PS(52.5,X,0)),"^",7)="Q" K X,XX S QFLG=1 Q + I $P($G(^PS(52.5,X,0)),"^",7)="L" K X,XX S QFLG=1 Q +GOOD K X + I $D(^PS(52.4,RX)) S QFLG=1 Q + I $D(^PS(52.4,"AREF",PSODFN,RX)) S QFLG=1 Q + I $G(PSODIV),$D(^PSRX(RX,2)),+$P(^(2),"^",9),+$P(^(2),"^",9)'=PSOSITE S PSPOP=0,PSPRXN=RX D CHK1^PSOUTLA I $G(POERR)&(PSPOP) S QFLG=1 Q + I STA=3!(STA=4)!(STA=12) S QFLG=1 Q + Q +ACT1 S RXF=0 F J=0:0 S J=$O(^PSRX(RX,1,J)) Q:'J S RXF=J S:J>5 RXF=J+1 + S IR=0 F J=0:0 S J=$O(^PSRX(RX,"A",J)) Q:'J S IR=J + S IR=IR+1,^PSRX(RX,"A",0)="^52.3DA^"_IR_"^"_IR + D NOW^%DTC S ^PSRX(RX,"A",IR,0)=%_"^"_$S($G(ST)'="C":"W",1:"C")_"^"_DUZ_"^"_RXF_"^"_PCOM_$S($G(ST)'="C":" ("_COPIES_" COPIES)",1:""),PCOMX=PCOM K PC,IR,PS,XX,%,%H,%I,RXF + S:$P(^PSRX(RX,2),"^",15)&($G(ST)'="C") $P(^PSRX(RX,2),"^",14)=1 + Q +VALID ;check for rx in label array + I $O(PSORX("PSOL",0)) D + .F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1 I PSORX("PSOL",PSOX1)[RX_"," S QFLG=1 Q + Q +ULR ; + I $G(PSORPSRX) D PSOUL^PSSLOCK(PSORPSRX) + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXRP2.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXRP2.m index 56e4eb55..3d687979 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXRP2.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXRP2.m @@ -1,104 +1,98 @@ -PSORXRP2 ;BIR/SAB-main menu entry reprint of a Rx label ;7:37 AM 31 Dec 2008 - ;;7.0;OUTPATIENT PHARMACY;**11,27,120,138,135,156,185,280,208**;DEC 1997;Build 41;WorldVistA 30-Jan-08 - ; - ;Modified from FOIA VISTA, - ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;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 Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789 - ;External reference ^PS(55 supported by DBIA 2228 - ;External reference to ^PSDRUG supported by DBIA 221 - I '$D(PSOPAR) D ^PSOLSET I '$D(PSOPAR) G KILL -LRP N PSODISP - K REPRINT W !! S DIC("S")="I $P($G(^(0)),""^"",2),$D(^(""STA"")),$P($G(^(""STA"")),""^"")<10",DIC="^PSRX(",DIC("A")="Reprint Prescription Label: ",DIC(0)="QEAZ" D ^DIC K P,DIC("A") I Y<0!("^"[X) K PCOM,PCOMX G KILL - S (PPL,DA,RX,PSORPRX)=+Y,PDA=Y(0),RXF=0,ZD(DA)=DT,REPRINT=1,STA=+$G(^PSRX(+Y,"STA")) - D PSOL^PSSLOCK(PSORPRX) I '$G(PSOMSG) W !!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),! K PSOMSG G LRP - ;WVEHR ;begin p208 - S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" ;vfah - D ^DIC K DIC ;vfah - S PSOZAF=+Y ;vfah - I $P(^PSRX(RX,"OR1"),"^",5)=$G(PSOZAF) W $C(7),!,"Cannot Reprint Labels for Autofinished Rxs" D ULR,KILL Q ;vfah - ;WVEHR ;end p208 - I $P(^PSRX(RX,"STA"),"^")=14 W $C(7),!,"Cannot Reprint! Discontinued by Provider." D ULR,KILL Q - I $P(^PSRX(RX,"STA"),"^")=15 W $C(7),!,"Cannot Reprint! Discontinued due to editing." D ULR,KILL Q - I $P(^PSRX(RX,"STA"),"^")=16 W $C(7),!,"Cannot Reprint! Placed on HOLD by Provider." D ULR,KILL Q - I DT>$P(^PSRX(RX,2),"^",6) D D ULR,KILL G LRP - .W !,$C(7),"Medication Expired on "_$E($P(^PSRX(RX,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) I $P(^PSRX(DA,"STA"),"^")<11 S $P(^PSRX(DA,"STA"),"^")=11 D - ..S COMM="Medication Expired on "_$E($P(^PSRX(RX,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) D EN^PSOHLSN1(DA,"SC","ZE",COMM) K COMM - S DFN=$P(PDA,"^",2) D DEM^VADPT I $P(VADM(6),"^",2)]"" D G LRP - .W $C(7),!!,$P(^DPT($P(PDA,"^",2),0),"^")_" Died "_$P(VADM(6),"^",2)_".",! - .S $P(^PSRX(RX,"STA"),"^")=12,PCOM="Patient Expired "_$P(VADM(6),"^",2),ST="C" D EN^PSOHLSN1(RX,"OD","",PCOM,"A") - .D ACT1,ULR,KILL - S X=$O(^PS(52.5,"B",DA,0)) I X,'$G(^PS(52.5,X,"P")) W !,$C(7),"Rx may NOT be printed using this option, use SUSPENSE FUNCTIONS Options." K X D ULR,KILL G LRP - I $G(X)'>0 G GOOD - S XX=$P($G(^PS(52.5,X,0)),U,7) I $G(XX)']"" G GOOD - I $G(XX)="Q" W !,"RX CAN NOT BE PRINTED using this option, use SUSPENSE FUNCTIONS Options." K X,XX D ULR,KILL G LRP - I $G(XX)="L" W !,"RX is being transmitted to the CMOP and can not be reprinted now." K X,XX D ULR,KILL G LRP -GOOD K X - I $D(^PS(52.4,DA)) W !,"Prescription is Non-Verified",!! D ULR,KILL G LRP - S DFN=$P(^PSRX(DA,0),"^",2) I $D(^PS(52.4,"AREF",DFN,DA)) W !,"Prescription is waiting for others to be verified",!! D ULR,KILL G LRP - I $G(PSODIV),$D(^PSRX(DA,2)),+$P(^(2),"^",9),+$P(^(2),"^",9)'=PSOSITE S PSPOP=0,PSPRXN=DA D CHK1^PSOUTLA I PSPOP D ULR,KILL G LRP - I STA=3 W !?3,"Prescription is on Hold" D ULR,KILL G LRP - I STA=4 W !?3,"Prescription is Pending Due to Drug Interactions" D ULR,KILL G LRP - I STA=12 W !?3,"Prescription is Discontinued" D ULR,KILL G LRP - I $G(^PS(55,"ASTALK",DFN)) W !,"Patient is a ScripTalk patient. Use ScripTalk label for prescription bottle.",! - D ICN^PSODPT(DFN) - S COPIES=$S($P(PDA,"^",18)]"":$P(PDA,"^",18),1:1) - K DIR S DIR("A")="Number of Copies? ",DIR("B")=COPIES,DIR(0)="N^1:99:0",DIR("?")="Enter the number of copies you want (1 TO 99)" - D ^DIR K DIR I $D(DIRUT) D ULR,KILL G LRP - S COPIES=Y - K DIR S DIR("A")="Print adhesive portion of label only? ",DIR(0)="Y",DIR("B")="No",DIR("?",1)="If entire label, including trailers are to print press RETURN for default." - S DIR("?")="Else if only bottle and mailing labels are to print enter Y or YES." D ^DIR K DIR I $D(DUOUT) D ULR,KILL G LRP - I $D(DIRUT) D ULR G KILL - S SIDE=Y - I $P(PSOPAR,"^",30),$$GET1^DIQ(59,PSOSITE_",",105,"I")=2.4 D - .I $S($P(PSOPAR,"^",30)=3:1,$P(PSOPAR,"^",30)=4:1,1:0),'$$GET1^DIQ(50,$P(PDA,"^",6),28,"I") Q - .K DIR,DIRUT S DIR("A")="Do you want to resend to Dispensing System Device",DIR(0)="Y",DIR("B")="No" D ^DIR K DIR Q:$D(DIRUT) S PSODISP=$S(Y:0,1:1) - I $D(DIRUT) D ULR,KILL G LRP - D ACT I $D(DIRUT) D ULR,KILL G LRP - I $D(PCOM) D ULR,KILL G LRP - F I=1,2,4,6,7,9,13,16 S P(I)=$P(PDA,"^",I) - S P(6)=+P(6) I $D(^PSRX(DA,"TN")),^("TN")]"" S P(6)=^("TN") - W !!,"Rx # "_P(1),?23,$E(P(13),4,5)_"/"_$E(P(13),6,7)_"/"_$E(P(13),2,3),!,$S($D(^DPT(+P(2),0)):$P(^(0),"^"),1:"Not on File"),?30,"#"_P(7),! - I $P($G(^PSRX(DA,"SIG")),"^",2) S D=0 D K D,FSIG - .D FSIG^PSOUTLA("R",DA,75) F S D=$O(FSIG(D)) W !,FSIG(D) Q:'$O(FSIG(D)) - E D EN3^PSOUTLA1(DA,75) S D=0 F S D=$O(BSIG(D)) W !,BSIG(D) Q:'$O(BSIG(D)) - K D,BSIG - ;PSO*7*280 If Trade name, don't lookup in ^PSDRUG - W !!,$S($G(^PSRX(DA,"TN"))]"":P(6),(P(6)=+P(6))&$D(^PSDRUG(P(6),0)):$P(^(0),"^"),1:P(6)),! S PHYS=$S($D(^VA(200,+P(4),0)):$P(^(0),"^"),1:"Unknown") W PHYS K PHYS - W ?25,$S($D(^VA(200,+P(16),0)):$P(^(0),"^"),1:"Unknown"),!,"# of Refills: "_$G(P(9)) - I $G(RX) D - .S RXRP(RX)=1_"^"_COPIES_"^"_SIDE - .I $G(PSODISP)=1 S RXRP(RX,"RP")=1 - .S RXFL(RX)=0 F ZZZ=0:0 S ZZZ=$O(^PSRX(RX,1,ZZZ)) Q:'ZZZ S RXFL(RX)=ZZZ - D @$S($P($G(PSOPAR),"^",26):"^PSORXL",1:"Q^PSORXL") K PSPOP,PPL,COPIES,SIDE,REPRINT,PCOM,IOP,PSL,PSNP,ZZZ,RXFL(+$G(RX)) D ULR,KILL G LRP - ; -ACT K DIR S DIR("A")="Comments: ",DIR(0)="FA^5:60",DIR("?")="5-60 characters input required for activity log." S:$G(PCOMX)]"" DIR("B")=$G(PCOMX) - D ^DIR K DIR Q:$D(DIRUT)!($D(DIROUT)) S (PCOM,PCOMX)=X - I '$D(PSOCLC) S PSOCLC=DUZ -ACT1 S RXF=0 F J=0:0 S J=$O(^PSRX(DA,1,J)) Q:'J S RXF=J S:J>5 RXF=J+1 - S IR=0 F J=0:0 S J=$O(^PSRX(DA,"A",J)) Q:'J S IR=J - S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR - D NOW^%DTC S ^PSRX(DA,"A",IR,0)=%_"^"_$S($G(ST)'="C":"W",1:"C")_"^"_DUZ_"^"_RXF_"^"_PCOM_$S($G(ST)'="C":" ("_COPIES_" COPIES)",1:""),PCOMX=PCOM K PC,IR,PS,PCOM,XX,%,%H,%I,RXF - S:$P(^PSRX(DA,2),"^",15)&($G(ST)'="C") $P(^PSRX(DA,2),"^",14)=1 - Q - ; -KILL K %,DIR,DUOUT,DTOUT,DIROUT,DIRUT,C,DA,DIC,I,J,JJJ,K,RX,RXF,X,Y,Z,ZD,DFN,P,PDA,PSPRXN,COPIES,SIDE,PPL,REPRINT,PSXSTAT,PSORPRX,PSOMSG D KVA^VADPT Q - ; -ULR ; - I $G(PSORPRX) D PSOUL^PSSLOCK(PSORPRX) - Q +PSORXRP2 ;BIR/SAB-main menu entry reprint of a Rx label ; 12/10/06 9:51pm + ;;7.0;OUTPATIENT PHARMACY;**11,27,120,138,135,156,185,208**;DEC 1997;Build 39 + ; 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 + ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789 + ;External reference ^PS(55 supported by DBIA 2228 + ;External reference to ^PSDRUG supported by DBIA 221 + I '$D(PSOPAR) D ^PSOLSET I '$D(PSOPAR) G KILL +LRP N PSODISP + K REPRINT W !! S DIC("S")="I $P($G(^(0)),""^"",2),$D(^(""STA"")),$P($G(^(""STA"")),""^"")<10",DIC="^PSRX(",DIC("A")="Reprint Prescription Label: ",DIC(0)="QEAZ" D ^DIC K P,DIC("A") I Y<0!("^"[X) K PCOM,PCOMX G KILL + S (PPL,DA,RX,PSORPRX)=+Y,PDA=Y(0),RXF=0,ZD(DA)=DT,REPRINT=1,STA=+$G(^PSRX(+Y,"STA")) + D PSOL^PSSLOCK(PSORPRX) I '$G(PSOMSG) W !!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),! K PSOMSG G LRP + S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" ;vfah + D ^DIC K DIC ;vfah + S PSOZAF=+Y ;vfah + I $P(^PSRX(RX,"OR1"),"^",5)=$G(PSOZAF) W $C(7),!,"Cannot Reprint Labels for Autofinished Rxs" D ULR,KILL Q ;vfah + I $P(^PSRX(RX,"STA"),"^")=14 W $C(7),!,"Cannot Reprint! Discontinued by Provider." D ULR,KILL Q + I $P(^PSRX(RX,"STA"),"^")=15 W $C(7),!,"Cannot Reprint! Discontinued due to editing." D ULR,KILL Q + I $P(^PSRX(RX,"STA"),"^")=16 W $C(7),!,"Cannot Reprint! Placed on HOLD by Provider." D ULR,KILL Q + I DT>$P(^PSRX(RX,2),"^",6) D D ULR,KILL G LRP + .W !,$C(7),"Medication Expired on "_$E($P(^PSRX(RX,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) I $P(^PSRX(DA,"STA"),"^")<11 S $P(^PSRX(DA,"STA"),"^")=11 D + ..S COMM="Medication Expired on "_$E($P(^PSRX(RX,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) D EN^PSOHLSN1(DA,"SC","ZE",COMM) K COMM + S DFN=$P(PDA,"^",2) D DEM^VADPT I $P(VADM(6),"^",2)]"" D G LRP + .W $C(7),!!,$P(^DPT($P(PDA,"^",2),0),"^")_" Died "_$P(VADM(6),"^",2)_".",! + .S $P(^PSRX(RX,"STA"),"^")=12,PCOM="Patient Expired "_$P(VADM(6),"^",2),ST="C" D EN^PSOHLSN1(RX,"OD","",PCOM,"A") + .D ACT1,ULR,KILL + S X=$O(^PS(52.5,"B",DA,0)) I X,'$G(^PS(52.5,X,"P")) W !,$C(7),"Rx may NOT be printed using this option, use SUSPENSE FUNCTIONS Options." K X D ULR,KILL G LRP + I $G(X)'>0 G GOOD + S XX=$P($G(^PS(52.5,X,0)),U,7) I $G(XX)']"" G GOOD + I $G(XX)="Q" W !,"RX CAN NOT BE PRINTED using this option, use SUSPENSE FUNCTIONS Options." K X,XX D ULR,KILL G LRP + I $G(XX)="L" W !,"RX is being transmitted to the CMOP and can not be reprinted now." K X,XX D ULR,KILL G LRP +GOOD K X + I $D(^PS(52.4,DA)) W !,"Prescription is Non-Verified",!! D ULR,KILL G LRP + S DFN=$P(^PSRX(DA,0),"^",2) I $D(^PS(52.4,"AREF",DFN,DA)) W !,"Prescription is waiting for others to be verified",!! D ULR,KILL G LRP + I $G(PSODIV),$D(^PSRX(DA,2)),+$P(^(2),"^",9),+$P(^(2),"^",9)'=PSOSITE S PSPOP=0,PSPRXN=DA D CHK1^PSOUTLA I PSPOP D ULR,KILL G LRP + I STA=3 W !?3,"Prescription is on Hold" D ULR,KILL G LRP + I STA=4 W !?3,"Prescription is Pending Due to Drug Interactions" D ULR,KILL G LRP + I STA=12 W !?3,"Prescription is Discontinued" D ULR,KILL G LRP + I $G(^PS(55,"ASTALK",DFN)) W !,"Patient is a ScripTalk patient. Use ScripTalk label for prescription bottle.",! + D ICN^PSODPT(DFN) + S COPIES=$S($P(PDA,"^",18)]"":$P(PDA,"^",18),1:1) + K DIR S DIR("A")="Number of Copies? ",DIR("B")=COPIES,DIR(0)="N^1:99:0",DIR("?")="Enter the number of copies you want (1 TO 99)" + D ^DIR K DIR I $D(DIRUT) D ULR,KILL G LRP + S COPIES=Y + K DIR S DIR("A")="Print adhesive portion of label only? ",DIR(0)="Y",DIR("B")="No",DIR("?",1)="If entire label, including trailers are to print press RETURN for default." + S DIR("?")="Else if only bottle and mailing labels are to print enter Y or YES." D ^DIR K DIR I $D(DUOUT) D ULR,KILL G LRP + I $D(DIRUT) D ULR G KILL + S SIDE=Y + I $P(PSOPAR,"^",30),$$GET1^DIQ(59,PSOSITE_",",105,"I")=2.4 D + .I $S($P(PSOPAR,"^",30)=3:1,$P(PSOPAR,"^",30)=4:1,1:0),'$$GET1^DIQ(50,$P(PDA,"^",6),28,"I") Q + .K DIR,DIRUT S DIR("A")="Do you want to resend to Dispensing System Device",DIR(0)="Y",DIR("B")="No" D ^DIR K DIR Q:$D(DIRUT) S PSODISP=$S(Y:0,1:1) + I $D(DIRUT) D ULR,KILL G LRP + D ACT I $D(DIRUT) D ULR,KILL G LRP + I $D(PCOM) D ULR,KILL G LRP + F I=1,2,4,6,7,9,13,16 S P(I)=$P(PDA,"^",I) + S P(6)=+P(6) I $D(^PSRX(DA,"TN")),^("TN")]"" S P(6)=^("TN") + W !!,"Rx # "_P(1),?23,$E(P(13),4,5)_"/"_$E(P(13),6,7)_"/"_$E(P(13),2,3),!,$S($D(^DPT(+P(2),0)):$P(^(0),"^"),1:"Not on File"),?30,"#"_P(7),! + I $P($G(^PSRX(DA,"SIG")),"^",2) S D=0 D K D,FSIG + .D FSIG^PSOUTLA("R",DA,75) F S D=$O(FSIG(D)) W !,FSIG(D) Q:'$O(FSIG(D)) + E D EN3^PSOUTLA1(DA,75) S D=0 F S D=$O(BSIG(D)) W !,BSIG(D) Q:'$O(BSIG(D)) + K D,BSIG + W !!,$S((P(6)=+P(6))&$D(^PSDRUG(P(6),0)):$P(^(0),"^"),1:P(6)),! S PHYS=$S($D(^VA(200,+P(4),0)):$P(^(0),"^"),1:"Unknown") W PHYS K PHYS + W ?25,$S($D(^VA(200,+P(16),0)):$P(^(0),"^"),1:"Unknown"),!,"# of Refills: "_$G(P(9)) + I $G(RX) D + .S RXRP(RX)=1_"^"_COPIES_"^"_SIDE + .I $G(PSODISP)=1 S RXRP(RX,"RP")=1 + .S RXFL(RX)=0 F ZZZ=0:0 S ZZZ=$O(^PSRX(RX,1,ZZZ)) Q:'ZZZ S RXFL(RX)=ZZZ + D @$S($P($G(PSOPAR),"^",26):"^PSORXL",1:"Q^PSORXL") K PSPOP,PPL,COPIES,SIDE,REPRINT,PCOM,IOP,PSL,PSNP,ZZZ,RXFL(+$G(RX)) D ULR,KILL G LRP + ; +ACT K DIR S DIR("A")="Comments: ",DIR(0)="FA^5:60",DIR("?")="5-60 characters input required for activity log." S:$G(PCOMX)]"" DIR("B")=$G(PCOMX) + D ^DIR K DIR Q:$D(DIRUT)!($D(DIROUT)) S (PCOM,PCOMX)=X + I '$D(PSOCLC) S PSOCLC=DUZ +ACT1 S RXF=0 F J=0:0 S J=$O(^PSRX(DA,1,J)) Q:'J S RXF=J S:J>5 RXF=J+1 + S IR=0 F J=0:0 S J=$O(^PSRX(DA,"A",J)) Q:'J S IR=J + S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR + D NOW^%DTC S ^PSRX(DA,"A",IR,0)=%_"^"_$S($G(ST)'="C":"W",1:"C")_"^"_DUZ_"^"_RXF_"^"_PCOM_$S($G(ST)'="C":" ("_COPIES_" COPIES)",1:""),PCOMX=PCOM K PC,IR,PS,PCOM,XX,%,%H,%I,RXF + S:$P(^PSRX(DA,2),"^",15)&($G(ST)'="C") $P(^PSRX(DA,2),"^",14)=1 + Q + ; +KILL K %,DIR,DUOUT,DTOUT,DIROUT,DIRUT,C,DA,DIC,I,J,JJJ,K,RX,RXF,X,Y,Z,ZD,DFN,P,PDA,PSPRXN,COPIES,SIDE,PPL,REPRINT,PSXSTAT,PSORPRX,PSOMSG D KVA^VADPT Q + ; +ULR ; + I $G(PSORPRX) D PSOUL^PSSLOCK(PSORPRX) + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXRPT.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXRPT.m index 952600e7..5b5b64dd 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXRPT.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXRPT.m @@ -1,115 +1,109 @@ -PSORXRPT ;BIR/SAB-reprint of a prescription label ;7:48 AM 31 Dec 2008 - ;;7.0;OUTPATIENT PHARMACY;**3,21,27,34,120,138,156,148,280,208**;DEC 1997;Build 41;WorldVistA 30-Jan-08 - ; - ;Modified from FOIA VISTA, - ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;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 Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - ;External reference to ^PSDRUG supported by DBIA 221 - ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789 -BCK I $G(PSOBEDT) W $C(7),$C(7) S VALMSG="Invalid Action at this time !",VALMBCK="" Q - N PSODISP S PSORPLRX=$P(PSOLST(ORN),"^",2) - I $$LMREJ^PSOREJU1(PSORPLRX,,.VALMSG,.VALMBCK) Q - D PSOL^PSSLOCK(PSORPLRX) I '$G(PSOMSG) S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG Q - I $G(POERR) K QFLG D I $G(QFLG) D ULR G KILL - .D FULL^VALM1 S X=$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^"),Y=$P(PSOLST(ORN),"^",2)_"^"_X,Y(0)=$G(^PSRX($P(PSOLST(ORN),"^",2),0)) - .I $D(RXPR($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Partial Rx has been requested!",QFLG=1 Q - .I $D(RXRP($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Reprint Label has been requested!",QFLG=1 Q - .I $D(RXRS($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="Rx is being pulled from suspense!",QFLG=1 Q - .S RX=$P(PSOLST(ORN),"^",2) D VALID^PSORXRP1 S:$G(QFLG) VALMBCK="",VALMSG="A New Label has been requested already!" - S (PPL,DA,RX)=+Y,PDA=Y(0),RXF=0,ZD(DA)=DT,REPRINT=1,STA=+$G(^PSRX(+Y,"STA")) - ;WVERH ;begin p208 - ; - S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" ;vfah - D ^DIC K DIC ;vfah - S PSOZAF=+Y ;vfah - I $P($G(^PSRX(RX,"OR1")),"^",5)=$G(PSOZAF) S VALMBCK="",VALMSG="This reprint option is not available for Autofinshed Rxs",QFLG=1 K PSOZAF D ULR,KILL Q ;vfah - ;WVEHR ;end p208 - ; - I $P(^PSRX(RX,"STA"),"^")=14 S VALMBCK="",VALMSG="Cannot Reprint! Discontinued by Provider.",QFLG=1 D ULR,KILL Q - I $P(^PSRX(RX,"STA"),"^")=15 S VALMBCK="",VALMSG="Cannot Reprint! Discontinued due to editing.",QFLG=1 D ULR,KILL Q - I $P(^PSRX(RX,"STA"),"^")=16 S VALMBCK="",VALMSG="Cannot Reprint! Placed on HOLD by Provider.",QFLG=1 D ULR,KILL Q - I DT>$P(^PSRX(RX,2),"^",6) D G PAUSE - .W !,$C(7),"Medication Expired on "_$E($P(^PSRX(RX,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) I $P(^PSRX(DA,"STA"),"^")<11 S $P(^PSRX(DA,"STA"),"^")=11 D - ..S COMM="Medication Expired on "_$E($P(^PSRX(RX,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) D EN^PSOHLSN1(DA,"SC","ZE",COMM) K COMM - S DFN=$P(PDA,"^",2) D DEM^VADPT I $P(VADM(6),"^",2)]"" D G PAUSE - .W $C(7),!!,$P(^DPT($P(PDA,"^",2),0),"^")_" Died "_$P(VADM(6),"^",2)_".",! - .S $P(^PSRX(RX,"STA"),"^")=12,PCOM="Patient Expired "_$P(VADM(6),"^",2),ST="C" D EN^PSOHLSN1(RX,"OD","",PCOM,"A") - .D ACT1,ULR,KILL - S X=$O(^PS(52.5,"B",DA,0)) I X,'$G(^PS(52.5,X,"P")) W !,$C(7),"RX MAY NOT BE PRINTED using this option, use SUSPENSE FUNCTIONS Options." K X G PAUSE - S PSX=0 F J=0:0 S J=$O(^PSRX(DA,1,J)) Q:'J S PSX=J - K X - I $D(^PS(52.4,DA)) W !,"Prescription is Non-Verified",!! G PAUSE - S DFN=$P(^PSRX(DA,0),"^",2) I $D(^PS(52.4,"AREF",DFN,DA)) W !,"Prescription is waiting for others to be verified",!! G PAUSE - I $G(PSODIV),$D(^PSRX(DA,2)),+$P(^(2),"^",9),+$P(^(2),"^",9)'=PSOSITE S PSPOP=0,PSPRXN=DA D CHK1^PSOUTLA G:$G(POERR)&(PSPOP) PAUSE G:PSPOP PAUSE - I STA=3 W !?3,"Prescription is on Hold" G PAUSE - I STA=4 W !?3,"Prescription is Pending Due to Drug Interactions" G PAUSE - I STA=12 W !?3,"Prescription is Discontinued" G PAUSE - S COPIES=$S($P(PDA,"^",18)]"":$P(PDA,"^",18),1:1) - K DIR S DIR("A")="Number of Copies? ",DIR("B")=COPIES,DIR(0)="N^1:99:0",DIR("?")="Enter the number of copies you want (1 to 99)" - D ^DIR K DIR I $D(DIRUT) D ULR G KILL - S COPIES=Y - K DIR S DIR("A")="Print adhesive portion of label only? ",DIR(0)="Y",DIR("B")="No",DIR("?",1)="If entire label, including trailers are to print press RETURN for default." - S DIR("?")="Else if only bottle and mailing labels are to print enter Y or YES." D ^DIR K DIR I $D(DUOUT) D ULR,KILL G PAUSE - I $D(DIRUT) D ULR G KILL - S SIDE=Y - I $P(PSOPAR,"^",30),$$GET1^DIQ(59,PSOSITE_",",105,"I")=2.4 D - .I $S($P(PSOPAR,"^",30)=3:1,$P(PSOPAR,"^",30)=4:1,1:0),'$$GET1^DIQ(50,$P(PDA,"^",6),28,"I") Q - .K DIR,DIRUT S DIR("A")="Do you want to resend to Dispensing System Device",DIR(0)="Y",DIR("B")="No" - .D ^DIR K DIR Q:$D(DIRUT) S PSODISP=$S(Y:0,1:1) - I $D(DIRUT) D ULR G KILL - D ACT I $D(DIRUT) D ULR,KILL G PAUSE - Q:$G(POERR)&($D(PCOM)) G PAUSE:$D(PCOM) - F I=1,2,4,6,7,9,13,16 S P(I)=$P(PDA,"^",I) - S P(6)=+P(6) I $D(^PSRX(DA,"TN")),^("TN")]"" S P(6)=^("TN") - W !!,"Rx # "_P(1),?23,$E(P(13),4,5)_"/"_$E(P(13),6,7)_"/"_$E(P(13),2,3),!,$S($D(^DPT(+P(2),0)):$P(^(0),"^"),1:"Not on File"),?30,"#"_P(7),! - I $P($G(^PSRX(DA,"SIG")),"^",2) S D=0 D K D,FSIG - .D FSIG^PSOUTLA("R",DA,75) F S D=$O(FSIG(D)) W !,FSIG(D) Q:'$O(FSIG(D)) - E D EN3^PSOUTLA1(DA,75) S D=0 F S D=$O(BSIG(D)) W !,BSIG(D) Q:'$O(BSIG(D)) - K D,BSIG - ;PSO*7*280 If trade name is used Stop the DRUG Lookup. - W !!,$S($G(^PSRX(DA,"TN"))]"":P(6),(P(6)=+P(6))&$D(^PSDRUG(P(6),0)):$P(^(0),"^"),1:P(6)),! S PHYS=$S($D(^VA(200,+P(4),0)):$P(^(0),"^"),1:"Unknown") W PHYS K PHYS - W ?25,$S($D(^VA(200,+P(16),0)):$P(^(0),"^"),1:"Unknown"),!,"# of Refills: "_$G(P(9)) - I $G(RX) S RXFL(RX)=0 F ZZZ=0:0 S ZZZ=$O(^PSRX(RX,1,ZZZ)) Q:'ZZZ S RXFL(RX)=ZZZ - K PSOELSE I '$G(POERR) S PSOELSE=1 D @$S($P($G(PSOPAR),"^",26):"^PSORXL",1:"Q^PSORXL") - I '$G(PSOELSE) D - .S RXRP($P(PSOLST(ORN),"^",2))=1_"^"_COPIES_"^"_SIDE - .I $G(PSODISP)=1 S RXRP($P(PSOLST(ORN),"^",2),"RP")=1 - .I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=DA_"," Q - .F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1 S PSOX2=PSOX1 - .I $L(PSORX("PSOL",PSOX2))+$L(DA)<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_DA_"," - .E S PSORX("PSOL",PSOX2+1)=DA_"," - K PCOMX,PSPOP,PPL,COPIES,SIDE,PCOM,IOP,PSL,PSNP,PSOELSE,ZZZ -PAUSE K RX,PPL,ZD(+$G(DA)),DA I $G(POERR) K DIR,DIRUT,DUOUT,DTOUT S DIR(0)="E",DIR("A",1)=" ",DIR("A")="Press Return to Continue" D ^DIR K DIR,DIRUT,DUOUT,DTOUT S VALMBCK="R" - D ULR K PSORPLRX - Q - ; -ACT K DIR S DIR("A")="Comments: ",DIR(0)="FA^5:60",DIR("?")="5-60 characters input required for activity log." S:$G(PCOMX)]"" DIR("B")=$G(PCOMX) - D ^DIR K DIR Q:$D(DIRUT)!($D(DIROUT)) S (PCOM,PCOMX)=X - I '$D(PSOCLC) S PSOCLC=DUZ -ACT1 S RXF=0 F J=0:0 S J=$O(^PSRX(DA,1,J)) Q:'J S RXF=J S:J>5 RXF=J+1 - S IR=0 F J=0:0 S J=$O(^PSRX(DA,"A",J)) Q:'J S IR=J - S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR - D NOW^%DTC S ^PSRX(DA,"A",IR,0)=%_"^"_$S($G(ST)'="C":"W",1:"C")_"^"_DUZ_"^"_RXF_"^"_PCOM_$S($G(ST)'="C":" ("_COPIES_" COPIES)",1:""),PCOMX=PCOM K PC,IR,PS,PCOM,XX,%,%H,%I,RXF - S:$P(^PSRX(DA,2),"^",15)&($G(ST)'="C") $P(^PSRX(DA,2),"^",14)=1 - Q - ; -KILL K QFLG,%,DIR,DUOUT,DTOUT,DIROUT,DIRUT,PCOM,PCOMX,C,DA,DIC,I,J,JJJ,K,RX,RXF,X,Y,Z,DFN,P,PDA,PSPRXN,COPIES,SIDE,PPL,REPRINT,PSOMSG,PSORPLRX D KVA^VADPT Q - ; -ULR ; - I $G(PSORPLRX) D PSOUL^PSSLOCK(PSORPLRX) - Q +PSORXRPT ;BIR/SAB-reprint of a prescription label ; 12/10/06 8:42pm + ;;7.0;OUTPATIENT PHARMACY;**3,21,27,34,120,138,156,148,208**;DEC 1997;Build 39 + ; 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 + ;External reference to ^PSDRUG supported by DBIA 221 + ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789 +BCK I $G(PSOBEDT) W $C(7),$C(7) S VALMSG="Invalid Action at this time !",VALMBCK="" Q + N PSODISP S PSORPLRX=$P(PSOLST(ORN),"^",2) + I $$LMREJ^PSOREJU1(PSORPLRX,,.VALMSG,.VALMBCK) Q + D PSOL^PSSLOCK(PSORPLRX) I '$G(PSOMSG) S VALMSG=$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),VALMBCK="" K PSOMSG Q + I $G(POERR) K QFLG D I $G(QFLG) D ULR G KILL + .D FULL^VALM1 S X=$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^"),Y=$P(PSOLST(ORN),"^",2)_"^"_X,Y(0)=$G(^PSRX($P(PSOLST(ORN),"^",2),0)) + .I $D(RXPR($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Partial Rx has been requested!",QFLG=1 Q + .I $D(RXRP($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Reprint Label has been requested!",QFLG=1 Q + .I $D(RXRS($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="Rx is being pulled from suspense!",QFLG=1 Q + .S RX=$P(PSOLST(ORN),"^",2) D VALID^PSORXRP1 S:$G(QFLG) VALMBCK="",VALMSG="A New Label has been requested already!" + S (PPL,DA,RX)=+Y,PDA=Y(0),RXF=0,ZD(DA)=DT,REPRINT=1,STA=+$G(^PSRX(+Y,"STA")) + ; + S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" ;vfah + D ^DIC K DIC ;vfah + S PSOZAF=+Y ;vfah + I $P($G(^PSRX(RX,"OR1")),"^",5)=$G(PSOZAF) S VALMBCK="",VALMSG="This reprint option is not available for Autofinshed Rxs",QFLG=1 K PSOZAF D ULR,KILL Q ;vfah + ; + I $P(^PSRX(RX,"STA"),"^")=14 S VALMBCK="",VALMSG="Cannot Reprint! Discontinued by Provider.",QFLG=1 D ULR,KILL Q + I $P(^PSRX(RX,"STA"),"^")=15 S VALMBCK="",VALMSG="Cannot Reprint! Discontinued due to editing.",QFLG=1 D ULR,KILL Q + I $P(^PSRX(RX,"STA"),"^")=16 S VALMBCK="",VALMSG="Cannot Reprint! Placed on HOLD by Provider.",QFLG=1 D ULR,KILL Q + I DT>$P(^PSRX(RX,2),"^",6) D G PAUSE + .W !,$C(7),"Medication Expired on "_$E($P(^PSRX(RX,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) I $P(^PSRX(DA,"STA"),"^")<11 S $P(^PSRX(DA,"STA"),"^")=11 D + ..S COMM="Medication Expired on "_$E($P(^PSRX(RX,2),"^",6),4,5)_"-"_$E($P(^(2),"^",6),6,7)_"-"_$E($P(^(2),"^",6),2,3) D EN^PSOHLSN1(DA,"SC","ZE",COMM) K COMM + S DFN=$P(PDA,"^",2) D DEM^VADPT I $P(VADM(6),"^",2)]"" D G PAUSE + .W $C(7),!!,$P(^DPT($P(PDA,"^",2),0),"^")_" Died "_$P(VADM(6),"^",2)_".",! + .S $P(^PSRX(RX,"STA"),"^")=12,PCOM="Patient Expired "_$P(VADM(6),"^",2),ST="C" D EN^PSOHLSN1(RX,"OD","",PCOM,"A") + .D ACT1,ULR,KILL + S X=$O(^PS(52.5,"B",DA,0)) I X,'$G(^PS(52.5,X,"P")) W !,$C(7),"RX MAY NOT BE PRINTED using this option, use SUSPENSE FUNCTIONS Options." K X G PAUSE + S PSX=0 F J=0:0 S J=$O(^PSRX(DA,1,J)) Q:'J S PSX=J + K X + I $D(^PS(52.4,DA)) W !,"Prescription is Non-Verified",!! G PAUSE + S DFN=$P(^PSRX(DA,0),"^",2) I $D(^PS(52.4,"AREF",DFN,DA)) W !,"Prescription is waiting for others to be verified",!! G PAUSE + I $G(PSODIV),$D(^PSRX(DA,2)),+$P(^(2),"^",9),+$P(^(2),"^",9)'=PSOSITE S PSPOP=0,PSPRXN=DA D CHK1^PSOUTLA G:$G(POERR)&(PSPOP) PAUSE G:PSPOP PAUSE + I STA=3 W !?3,"Prescription is on Hold" G PAUSE + I STA=4 W !?3,"Prescription is Pending Due to Drug Interactions" G PAUSE + I STA=12 W !?3,"Prescription is Discontinued" G PAUSE + S COPIES=$S($P(PDA,"^",18)]"":$P(PDA,"^",18),1:1) + K DIR S DIR("A")="Number of Copies? ",DIR("B")=COPIES,DIR(0)="N^1:99:0",DIR("?")="Enter the number of copies you want (1 to 99)" + D ^DIR K DIR I $D(DIRUT) D ULR G KILL + S COPIES=Y + K DIR S DIR("A")="Print adhesive portion of label only? ",DIR(0)="Y",DIR("B")="No",DIR("?",1)="If entire label, including trailers are to print press RETURN for default." + S DIR("?")="Else if only bottle and mailing labels are to print enter Y or YES." D ^DIR K DIR I $D(DUOUT) D ULR,KILL G PAUSE + I $D(DIRUT) D ULR G KILL + S SIDE=Y + I $P(PSOPAR,"^",30),$$GET1^DIQ(59,PSOSITE_",",105,"I")=2.4 D + .I $S($P(PSOPAR,"^",30)=3:1,$P(PSOPAR,"^",30)=4:1,1:0),'$$GET1^DIQ(50,$P(PDA,"^",6),28,"I") Q + .K DIR,DIRUT S DIR("A")="Do you want to resend to Dispensing System Device",DIR(0)="Y",DIR("B")="No" + .D ^DIR K DIR Q:$D(DIRUT) S PSODISP=$S(Y:0,1:1) + I $D(DIRUT) D ULR G KILL + D ACT I $D(DIRUT) D ULR,KILL G PAUSE + Q:$G(POERR)&($D(PCOM)) G PAUSE:$D(PCOM) + F I=1,2,4,6,7,9,13,16 S P(I)=$P(PDA,"^",I) + S P(6)=+P(6) I $D(^PSRX(DA,"TN")),^("TN")]"" S P(6)=^("TN") + W !!,"Rx # "_P(1),?23,$E(P(13),4,5)_"/"_$E(P(13),6,7)_"/"_$E(P(13),2,3),!,$S($D(^DPT(+P(2),0)):$P(^(0),"^"),1:"Not on File"),?30,"#"_P(7),! + I $P($G(^PSRX(DA,"SIG")),"^",2) S D=0 D K D,FSIG + .D FSIG^PSOUTLA("R",DA,75) F S D=$O(FSIG(D)) W !,FSIG(D) Q:'$O(FSIG(D)) + E D EN3^PSOUTLA1(DA,75) S D=0 F S D=$O(BSIG(D)) W !,BSIG(D) Q:'$O(BSIG(D)) + K D,BSIG + W !!,$S((P(6)=+P(6))&$D(^PSDRUG(P(6),0)):$P(^(0),"^"),1:P(6)),! S PHYS=$S($D(^VA(200,+P(4),0)):$P(^(0),"^"),1:"Unknown") W PHYS K PHYS + W ?25,$S($D(^VA(200,+P(16),0)):$P(^(0),"^"),1:"Unknown"),!,"# of Refills: "_$G(P(9)) + I $G(RX) S RXFL(RX)=0 F ZZZ=0:0 S ZZZ=$O(^PSRX(RX,1,ZZZ)) Q:'ZZZ S RXFL(RX)=ZZZ + K PSOELSE I '$G(POERR) S PSOELSE=1 D @$S($P($G(PSOPAR),"^",26):"^PSORXL",1:"Q^PSORXL") + I '$G(PSOELSE) D + .S RXRP($P(PSOLST(ORN),"^",2))=1_"^"_COPIES_"^"_SIDE + .I $G(PSODISP)=1 S RXRP($P(PSOLST(ORN),"^",2),"RP")=1 + .I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=DA_"," Q + .F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1 S PSOX2=PSOX1 + .I $L(PSORX("PSOL",PSOX2))+$L(DA)<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_DA_"," + .E S PSORX("PSOL",PSOX2+1)=DA_"," + K PCOMX,PSPOP,PPL,COPIES,SIDE,PCOM,IOP,PSL,PSNP,PSOELSE,ZZZ +PAUSE K RX,PPL,ZD(+$G(DA)),DA I $G(POERR) K DIR,DIRUT,DUOUT,DTOUT S DIR(0)="E",DIR("A",1)=" ",DIR("A")="Press Return to Continue" D ^DIR K DIR,DIRUT,DUOUT,DTOUT S VALMBCK="R" + D ULR K PSORPLRX + Q + ; +ACT K DIR S DIR("A")="Comments: ",DIR(0)="FA^5:60",DIR("?")="5-60 characters input required for activity log." S:$G(PCOMX)]"" DIR("B")=$G(PCOMX) + D ^DIR K DIR Q:$D(DIRUT)!($D(DIROUT)) S (PCOM,PCOMX)=X + I '$D(PSOCLC) S PSOCLC=DUZ +ACT1 S RXF=0 F J=0:0 S J=$O(^PSRX(DA,1,J)) Q:'J S RXF=J S:J>5 RXF=J+1 + S IR=0 F J=0:0 S J=$O(^PSRX(DA,"A",J)) Q:'J S IR=J + S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR + D NOW^%DTC S ^PSRX(DA,"A",IR,0)=%_"^"_$S($G(ST)'="C":"W",1:"C")_"^"_DUZ_"^"_RXF_"^"_PCOM_$S($G(ST)'="C":" ("_COPIES_" COPIES)",1:""),PCOMX=PCOM K PC,IR,PS,PCOM,XX,%,%H,%I,RXF + S:$P(^PSRX(DA,2),"^",15)&($G(ST)'="C") $P(^PSRX(DA,2),"^",14)=1 + Q + ; +KILL K QFLG,%,DIR,DUOUT,DTOUT,DIROUT,DIRUT,PCOM,PCOMX,C,DA,DIC,I,J,JJJ,K,RX,RXF,X,Y,Z,DFN,P,PDA,PSPRXN,COPIES,SIDE,PPL,REPRINT,PSOMSG,PSORPLRX D KVA^VADPT Q + ; +ULR ; + I $G(PSORPLRX) D PSOUL^PSSLOCK(PSORPLRX) + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXVW.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXVW.m index 89013ee3..96025dfa 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXVW.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXVW.m @@ -1,116 +1,116 @@ -PSORXVW ;BHAM ISC/SAB - listman view of a prescription ;5/25/05 2:10pm - ;;7.0;OUTPATIENT PHARMACY;**14,35,46,96,103,88,117,131,146,156,185,210,148,233,260,264,281**;DEC 1997;Build 41 - ;External reference to File ^PS(55 supported by DBIA 2228 - ;External reference to ^PS(50.7 supported by DBIA 2223 - ;External reference ^PSDRUG( supported by DBIA 221 - ;External reference to ^VA(200 supported by DBIA 10060 - ;External reference to ^SC supported by DBIA 10040 - ;External reference to ^DPT supported by DBIA 10035 - ;External reference to ^PS(50.606 supported by DBIA 2174 - ;External reference to GMRADPT supported by DBIA 10099 - ; - S PS="VIEW" -A1 ; - Prescription prompt - S DIR(0)="FAO^1:30",DIR("A")=PS_" PRESCRIPTION: ",(DIR("?"),DIR("??"))="^D HLP^PSORXVW1" - W ! D ^DIR I X=""!$D(DIRUT) G KILL - S X=$$UP^XLFSTR(X),QUIT=0 - I $E(X,1,2)'="E." S (DA,PSOVDA)=+$$LKP^PSORXVW1(X) I DA<0 G A1 - I $E(X,1,2)="E." D I QUIT G A1 - . I $L(X)'=9 W !?5,"The ECME# must be 7 digits long!",$C(7) S QUIT=1 Q - . S (DA,PSOVDA)=+$$RXNUM^PSOBPSU2($E(X,3,9)) I DA<0 W " ??" S QUIT=1 - ; -DP S (PSODFN,DFN)=+$P(^PSRX(DA,0),"^",2) S PSOLOUD=1 D:$P($G(^PS(55,PSODFN,0)),"^",6)'=2 EN^PSOHLUP(PSODFN) K PSOLOUD - D ICN^PSODPT(PSODFN) - K ^TMP("PSOHDR",$J) D ^VADPT,ADD^VADPT - S ^TMP("PSOHDR",$J,1,0)=VADM(1) - N PSOBADR,PSOTEMP - S PSOBADR=$$BADADR^DGUTL3(DFN) I PSOBADR S PSOTEMP=$$CHKTEMP^PSOBAI(DFN) D - .S ^TMP("PSOHDR",$J,1,0)=^TMP("PSOHDR",$J,1,0)_" ** BAD ADDRESS INDICATED-("_$S(PSOBADR=1:"UNDELIVERABLE",PSOBADR=2:"HOMELESS",1:"OTHER")_")"_$S(PSOTEMP:" Active Temporary Address",1:"") - S ^TMP("PSOHDR",$J,2,0)=$P(VADM(2),"^",2) - S ^TMP("PSOHDR",$J,3,0)=$P(VADM(3),"^",2),^TMP("PSOHDR",$J,4,0)=VADM(4),^TMP("PSOHDR",$J,5,0)=$P(VADM(5),"^",2) - S POERR=1 D RE^PSODEM K PSOERR - S ^TMP("PSOHDR",$J,6,0)=$S(+$P(WT,"^",8):$P(WT,"^",9)_" ("_$P(WT,"^")_")",1:"_______ (______)") - S ^TMP("PSOHDR",$J,7,0)=$S($P(HT,"^",8):$P(HT,"^",9)_" ("_$P(HT,"^")_")",1:"_______ (______)") K VM,WT,HT S PSOHD=7 - S GMRA="0^0^111" D EN1^GMRADPT S ^TMP("PSOHDR",$J,8,0)=+$G(GMRAL) - D DEM^VADPT I +VADM(6) D - .S SSN=$P(^DPT(PSODFN,0),"^",9) W !,$C(7),?10,$P(^DPT(PSODFN,0),"^")_" ("_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)_") DIED "_$P(VADM(6),"^",2),! - .W "All Active Medications will be Autocanceled!",! H 2 S PSODEATH=1 - .S ACOM="Date of Death "_$P(VADM(6),"^",2)_".",ZTRTN="CAN^PSOCAN3",ZTDESC="Outpatient Pharmacy Autocancel Due to Death of Patient",ZTSAVE("ACOM")="",ZTSAVE("PSODFN")="",ZTSAVE("PSODEATH")="" - .S ZTIO="",PSOCLC=DUZ,ZTSAVE("PSOCLC")="",ZTDTH=$H D ^%ZTLOAD K ACOM,ZTSK,PSODEATH - K ^TMP("PSOAL",$J),PCOMX,PDA,PHI,PRC,ACOM,ANS - S (DA,RXN)=PSOVDA K PSOVDA S RX0=^PSRX(RXN,0),RX2=$G(^(2)),RX3=$G(^(3)),ST=+$G(^("STA")),RXOR=$G(^("OR1")) - I 'RXOR,$P(^PSDRUG($P(RX0,"^",6),2),"^") S $P(^PSRX(RXN,"OR1"),"^")=$P(^PSDRUG($P(RX0,"^",6),2),"^"),RXOR=$P(^PSDRUG($P(RX0,"^",6),2),"^") - S IEN=0,$P(RN," ",12)=" " - N APPND S APPND=$S($G(^PSRX(RXN,"IB")):"$",1:"") - I $$ECMENUM^PSOBPSU2(RXN)'="" S APPND=APPND_$$ECME^PSOBPSUT(RXN)_" (ECME#: "_$$ECMENUM^PSOBPSU2(RXN)_")" - S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$S($P($G(^PSRX(RXN,"TPB")),"^"):" TPB Rx #: ",1:" Rx #: ")_$P(RX0,"^")_APPND_$E(RN,$L($P(RX0,"^")_APPND)+1,12) - S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Orderable Item: "_$S($D(^PS(50.7,$P(+RXOR,"^"),0)):$P(^PS(50.7,$P(+RXOR,"^"),0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^"),1:"No Pharmacy Orderable Item") - S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$S($D(^PSDRUG("AQ",$P(RX0,"^",6))):" CMOP ",1:" ")_"Drug: "_$P(^PSDRUG($P(RX0,"^",6),0),"^") - S:$G(^PSRX(RXN,"TN"))]"" IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Trade Name: "_$G(^PSRX(RXN,"TN")) - I $$STATUS^PSOBPSUT(RXN,0)'="",$$RXRLDT^PSOBPSUT(RXN,0) D - . S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" NDC: "_$$GETNDC^PSONDCUT(RXN,0) - D DOSE^PSORXVW1 - S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Patient Instructions:" I $O(^PSRX(RXN,"INS1",0)) D - . F I=0:0 S I=$O(^PSRX(RXN,"INS1",I)) Q:'I D - .. S MIG=^PSRX(RXN,"INS1",I,0) - .. D WORDWRAP^PSOUTLA2(MIG,.IEN,$NA(^TMP("PSOAL",$J)),21) - K MIG,SG - I $P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Other Pat. Instruc: "_$S($G(^PSRX(RXN,"INSS"))]"":^PSRX(RXN,"INSS"),1:"") - S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" SIG:" - I '$P($G(^PSRX(RXN,"SIG")),"^",2) D G PTST - . S X=$P($G(^PSRX(RXN,"SIG")),"^") D SIGONE^PSOHELP S SIG=$E($G(INS1),2,250) - . D WORDWRAP^PSOUTLA2(SIG,.IEN,$NA(^TMP("PSOAL",$J)),21) - S SIGOK=1 - F I=0:0 S I=$O(^PSRX(RXN,"SIG1",I)) Q:'I D - . S MIG=^PSRX(RXN,"SIG1",I,0) - . D WORDWRAP^PSOUTLA2(MIG,.IEN,$NA(^TMP("PSOAL",$J)),21) - S SIGOK=1 K MIG,SG -PTST S $P(RN," ",25)=" ",PTST=$S($G(^PS(53,+$P(RX0,"^",3),0))]"":$P($G(^PS(53,+$P(RX0,"^",3),0)),"^"),1:""),IEN=IEN+1 - S ^TMP("PSOAL",$J,IEN,0)=" Patient Status: "_PTST_$E(RN,$L(PTST)+1,25) - S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Issue Date: "_$E($P(RX0,"^",13),4,5)_"/"_$E($P(RX0,"^",13),6,7)_"/"_$E($P(RX0,"^",13),2,3) - S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_" Fill Date: "_$E($P(RX2,"^",2),4,5)_"/"_$E($P(RX2,"^",2),6,7)_"/"_$E($P(RX2,"^",2),2,3) - S ROU=$S($P(RX0,"^",11)="W":"Window",1:"Mail") - S REFL=$P(RX0,"^",9),I=0 F S I=$O(^PSRX(RXN,1,I)) Q:'I S REFL=REFL-1,ROU=$S($P(^PSRX(RXN,1,I,0),"^",2)="W":"Window",1:"Mail") - S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Last Fill Date: "_$E($P(RX3,"^"),4,5)_"/"_$E($P(RX3,"^"),6,7)_"/"_$E($P(RX3,"^"),2,3) - D CMOP^PSOORNE3 S DA=RXN - S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_" ("_ROU_$S($G(PSOCMOP)]"":", "_PSOCMOP,1:"")_")" K ROU,PSOCMOP - S IEN=IEN+1 I $P(RX2,"^",15) S ^TMP("PSOAL",$J,IEN,0)=" Returned to Stock: "_$E($P(RX2,"^",15),4,5)_"/"_$E($P(RX2,"^",15),6,7)_"/"_$E($P(RX2,"^",15),2,3) - E S ^TMP("PSOAL",$J,IEN,0)=" Last Release Date: " D - .S RLD=$S($P(RX2,"^",13):$E($P(RX2,"^",13),4,5)_"/"_$E($P(RX2,"^",13),6,7)_"/"_$E($P(RX2,"^",13),2,3),1:"") - .I $O(^PSRX(RXN,1,0)) F I=0:0 S I=$O(^PSRX(RXN,1,I)) Q:'I D - ..I $P(^PSRX(RXN,1,I,0),"^",18) S RLD=$E($P(^(0),"^",18),4,5)_"/"_$E($P(^(0),"^",18),6,7)_"/"_$E($P(^(0),"^",18),2,3) - .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_$S($G(RLD)]"":RLD,1:" ") - S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_" Lot #: "_$P(RX2,"^",4) - S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Expires: "_$E($P(RX2,"^",6),4,5)_"/"_$E($P(RX2,"^",6),6,7)_"/"_$E($P(RX2,"^",6),2,3) - S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_" MFG: "_$P($G(RX2),"^",8) - S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Days Supply: "_$P(RX0,"^",8)_$S($L($P(RX0,"^",8))=1:" ",1:"") - S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_" QTY"_$S($P($G(^PSDRUG($P(RX0,"^",6),660)),"^",8)]"":" ("_$P($G(^PSDRUG($P(RX0,"^",6),660)),"^",8)_")",1:" ( )")_": "_$P(RX0,"^",7) - I $P($G(^PSDRUG($P(RX0,"^",6),5)),"^")]"" D - .S $P(RN," ",79)=" ",IEN=IEN+1 - .S ^TMP("PSOAL",$J,IEN,0)=$E(RN,$L("QTY DSP MSG: "_$P(^PSDRUG($P(RX0,"^",6),5),"^"))+1,79)_"QTY DSP MSG: "_$P(^PSDRUG($P(RX0,"^",6),5),"^") K RN - S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" # of Refills: "_$P(RX0,"^",9)_$S($L($P(RX0,"^",9))=1:" ",1:"")_" Remaining: "_REFL - S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Provider: "_$S($D(^VA(200,$P(RX0,"^",4),0)):$P(^VA(200,$P(RX0,"^",4),0),"^"),1:"UNKNOWN") - I $P(RX3,"^",3) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Cos-Provider: "_$P(^VA(200,$P(RX3,"^",3),0),"^") - S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Routing: "_$S($P(RX0,"^",11)="W":"Window",1:"Mail") - S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Copies: "_$S($P(RX0,"^",18):$P(RX0,"^",18),1:1) - S:$P(RX0,"^",11)="W" IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Method of Pickup: "_$G(^PSRX(RXN,"MP")) - S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Clinic: "_$S($D(^SC(+$P(RX0,"^",5),0)):$P(^SC($P(RX0,"^",5),0),"^"),1:"Not on File") - S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Division: "_$P(^PS(59,$P(RX2,"^",9),0),"^")_" ("_$P(^(0),"^",6)_")" - S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Pharmacist: "_$S($P(RX2,"^",3):$P(^VA(200,$P(RX2,"^",3),0),"^"),1:"") - S:$P(RX2,"^",10)&('$G(PSOCOPY)) IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Verified By: "_$P(^VA(200,$P(RX2,"^",10),0),"^") - S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Patient Counseling: "_$S($P($G(^PSRX(RXN,"PC")),"^"):"YES",1:"NO")_" "_$S($P($G(^PSRX(RXN,"PC")),"^"):"Was Counseling Understood: "_$S($P($G(^PSRX(RXN,"PC")),"^",2):"YES",1:"NO"),1:"") - S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Remarks: "_$P(RX3,"^",7) - D PC^PSORXVW1 - I $P($G(^PSRX(DA,"OR1")),"^",5) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Finished By: "_$P(^VA(200,$P(^PSRX(DA,"OR1"),"^",5),0),"^") - D ^PSORXVW1 S PSOAL=IEN K IEN,ACT,LBL,LOG - I ST<12,$P(RX2,"^",6)
0&(RF<6):"REFILL "_RF,RF=6:"PARTIAL",RF>6:"REFILL "_(RF-1),1:"ORIGINAL") - .K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=$P(P1,"^",3) D ^DIC - .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_RFT_$E(RN,$L(RFT)+1,15)_$S(+Y:$P(Y,"^",2),1:$P(P1,"^",3)) - .;S:$P(P1,"^",5)]"" IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_$P(P1,"^",5) - .I $P(P1,"^",5)]"" N PSOACBRK,PSOACBRV D - ..S PSOACBRV=$P(P1,"^",5) - ..;PSO*7*240 Use fileman to format - ..K ^UTILITY($J,"W") S X="Comments: "_PSOACBRV,(DIWR,DIWL)=1,DIWF="C80" D ^DIWP F I=1:1:^UTILITY($J,"W",1) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$G(^UTILITY($J,"W",1,I,0)) - .I $G(^PSRX(DA,"A",N,1))]"" S IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0)," ",5)=$P(^PSRX(DA,"A",N,1),"^") I $P(^PSRX(DA,"A",N,1),"^",2)]"" S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_":"_$P(^PSRX(DA,"A",N,1),"^",2) - .I $O(^PSRX(DA,"A",N,2,0)) F I=0:0 S I=$O(^PSRX(RXN,"A",N,2,I)) Q:'I S MIG=^PSRX(RXN,"A",N,2,I,0) D - ..F SG=1:1:$L(MIG) S:$L(^TMP("PSOAL",$J,IEN,0)_" "_$P(MIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0)," ",9)=" " S:$P(MIG," ",SG)'="" ^TMP("PSOAL",$J,IEN,0)=$G(^TMP("PSOAL",$J,IEN,0))_" "_$P(MIG," ",SG) - K MIG,SG,I,^UTILITY($J,"W"),DIWF,DIWL,DIWR - Q -LBL ;label log - S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Label Log:" - S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="# Date Rx Ref Printed By",IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0),"=",79)="=" - I '$O(^PSRX(DA,"L",0)) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="There are NO Labels printed." Q - F L1=0:0 S L1=$O(^PSRX(DA,"L",L1)) Q:'L1 S LBL=^PSRX(DA,"L",L1,0),DTT=$P(^(0),"^") D DAT D - .S $P(RN," ",26)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=L1_" "_DAT_" ",RFT=$S($P(LBL,"^",2):"REFILL "_$P(LBL,"^",2),1:"ORIGINAL"),RFT=RFT_$E(RN,$L(RFT)+1,26) - .K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=$P(LBL,"^",4) D ^DIC - .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_RFT_$P(Y,"^",2),IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_$P(LBL,"^",3) - K DIC,X,Y Q -RF ;refill log - S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Refill Log:" - S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="# Log Date Refill Date Qty Routing Lot # Pharmacist",IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0),"=",79)="=" - S (RF,PL)=0 F RF=0:0 S RF=$O(^PSRX(DA,1,RF)) Q:'RF S PL=PL+1 - I 'PL S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="There are NO Refills For this Prescription" Q - F N=0:0 S N=$O(^PSRX(DA,1,N)) Q:'N S P1=^(N,0) D - .S DTT=$P(P1,"^",8)\1 D DAT S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=N_" "_DAT_" " - .S DTT=$P(P1,"^"),$P(RN," ",10)=" " D DAT - .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_DAT_" "_$P(P1,"^",4)_$E(" ",$L($P(P1,"^",4))+1,15)_" "_$S($P(P1,"^",2)="M":"Mail",1:"Window")_" "_$P(P1,"^",6)_$E(RN,$L($P(P1,"^",6))+1,12) - .K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=+$P(P1,"^",5) D ^DIC - .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_$E($S(+Y:$P(Y,"^",2),1:""),1,16) K DIC,X,Y - .S PSDIV=$S($D(^PS(59,+$P(P1,"^",9),0)):$P(^(0),"^",6),1:"Unknown"),IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Division: "_PSDIV_$E(" ",$L(PSDIV)+1,8)_" " - .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_"Dispensed: "_$S($P(P1,"^",19):$E($P(P1,"^",19),4,5)_"/"_$E($P(P1,"^",19),6,7)_"/"_$E($P(P1,"^",19),2,3),1:"")_" " - .S RTS=$S($P(P1,"^",16):" Returned to Stock: "_$E($P(P1,"^",16),4,5)_"/"_$E($P(P1,"^",16),6,7)_"/"_$E($P(P1,"^",16),2,3),1:" Released: "_$S($$RXRLDT^PSOBPSUT(DA,N):$$FMTE^XLFDT($$RXRLDT^PSOBPSUT(DA,N)\1,2),1:"")) - .I $$STATUS^PSOBPSUT(DA,N)'="",$$RXRLDT^PSOBPSUT(DA,N) S RTS=RTS_" NDC: "_$$GETNDC^PSONDCUT(DA,N) - .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_RTS - .S:$P(P1,"^",3)]"" IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Remarks: "_$P(P1,"^",3) - K RTS Q -PAR ;partial log - S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Partial Fills:" - S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="# Log Date Date Qty Routing Lot # Pharmacist",IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0),"=",79)="=" - I '$O(^PSRX(DA,"P",0)) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="There are NO Partials for this Prescription" Q - S N=0 F S N=$O(^PSRX(DA,"P",N)) Q:'N S P1=^(N,0),DTT=$P(P1,"^",8)\1 D DAT D - .S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=N_" "_DAT_" ",QTY=$P(P1,"^",4)_$E(" ",$L($P(P1,"^",4))+1,15) - .S DTT=$P(P1,"^") D DAT S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_DAT_" "_QTY_" " - .S PSDIV=$S($D(^PS(59,+$P(P1,"^",9),0)):$P(^(0),"^",6),1:"UNKNOWN"),PSDIV=PSDIV_$E(" ",$L(PSDIV)+1,8) - .S MW=$S($P(P1,"^",2)="M":"Mail",1:"Window"),MW=MW_$E(" ",$L(MW)+1,10) - .K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=+$P(P1,"^",16) D ^DIC - .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_MW_" "_$P(P1,"^",6)_$E(" ",$L($P(P1,"^",6))+1,10)_$E($S(+Y:$P(Y,"^",2),1:""),1,16) - .S RTS=$S($P(P1,"^",16):" RETURNED TO STOCK: "_$E($P(P1,"^",16),4,5)_"/"_$E($P(P1,"^",16),6,7)_"/"_$E($P(P1,"^",16),2,3),1:" RELEASED: "_$S($P(P1,"^",19):$E($P(P1,"^",19),4,5)_"/"_$E($P(P1,"^",19),6,7)_"/"_$E($P(P1,"^",19),2,3),1:"")) - .K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=$P(P1,"^",7) D ^DIC - .S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Division: "_PSDIV_" "_RTS ;_" Entry By: "_$P(Y,"^",2) K DIC,X,Y - .S:$P(P1,"^",3)]"" IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" REMARKS: "_$P(P1,"^",3) K RTS - Q -HLD ;hold info - S DTT=$P(^PSRX(DA,"H"),"^",3) D DAT S HLDR=$P(^DD(52,99,0),"^",3),HLDR=$S($P(^PSRX(DA,"H"),"^")'>8:$P(HLDR,";",$P(^PSRX(DA,"H"),"^")),1:$P(HLDR,";",9)),HLDR=$P(HLDR,":",2) - S $P(RN," ",60)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Hold Reason: "_HLDR_$E(RN,$L("Hold Reason: "_HLDR)+1,60)_"Hold Date: "_DAT S:$P(^PSRX(DA,"H"),"^",2)]"" IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Hold Comments: "_$P(^PSRX(DA,"H"),"^",2) - K RN,DAT,DTT,HLDR - Q -DAT S DAT="",DTT=DTT\1 Q:DTT'?7N S DAT=$E(DTT,4,5)_"/"_$E(DTT,6,7)_"/"_$E(DTT,2,3) - Q -INST ;formats instruction from front door - I $O(^PSRX(DA,"PI",0)) D - .S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Instructions:" - .S T=0 F S T=$O(^PSRX(RXN,"PI",T)) Q:'T D ;PSO*210 - ..S MIG=^PSRX(RXN,"PI",T,0) - ..D WORDWRAP^PSOUTLA2(MIG,.IEN,$NA(^TMP("PSOAL",$J)),21) - K T,TY,MIG,SG - Q -PC ;displays provider comments - I $O(^PSRX(DA,"PRC",0)) D - .S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Provider Comments:" - .S T=0 F S T=$O(^PSRX(RXN,"PRC",T)) Q:'T D ;PSO*210 - ..S MIG=^PSRX(RXN,"PRC",T,0) - ..D WORDWRAP^PSOUTLA2(MIG,.IEN,$NA(^TMP("PSOAL",$J)),21) - K T,TY,MIG,SG - Q -DOSE ;displays dosing instruction for both simple and complex Rxs. - D DOSE^PSORXVW2 - Q - ; -HLP ; Help Text for the VIEW PRESCRIPTION prompt - W !," A prescription number or ECME # may be entered. The ECME" - W !," number must be entered in E.NNNNNNN format, where NNNNNNN" - W !," is the prescription ECME # (example: E.0289332). Or just" - D LKP("?") - Q -LKP(INPUT) ; - Peforms Lookup on the PRESCRIPTION file - N DIC,X,Y - S DIC="^PSRX(",DIC(0)="QE",D="B",X=INPUT - S DIC("S")="I $P($G(^(0)),""^"",2),$D(^(""STA"")),$P($G(^(""STA"")),""^"")'=13" - D IX^DIC - Q Y +PSORXVW1 ;BIR/SAB-view prescription con't ;5/26/05 10:07am + ;;7.0;OUTPATIENT PHARMACY;**35,47,46,71,99,117,156,193,210,148,258,260**;DEC 1997;Build 84 + ;External reference to ^DD(52 supported by DBIA 999 + ;External reference to ^VA(200 supported by DBIA 10060 + ;PSO*210 add call to WORDWRAP api + ; + I $P($G(^PSRX(RXN,"OR1")),"^",6) D + .K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=$P(^PSRX(RXN,"OR1"),"^",6) D ^DIC + .S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Filled By: "_$P(Y,"^",2) K DIC,X,Y + I $P($G(^PSRX(RXN,"OR1")),"^",7) D + .K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=$P(^PSRX(RXN,"OR1"),"^",7) D ^DIC + .S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Checked By: "_$P(Y,"^",2) K DIC,X,Y + K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=$P(RX0,"^",16) D ^DIC + S $P(RN," ",35)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Entry By: "_$P(Y,"^",2)_$E(RN,$L($P(Y,"^",2))+1,35) + S Y=$P(RX2,"^") X ^DD("DD") + S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_"Entry Date: "_$E($P(RX2,"^"),4,5)_"/"_$E($P(RX2,"^"),6,7)_"/"_$E($P(RX2,"^"),2,3)_" "_$P(Y,"@",2) K RN + S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" " ;,IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0),"=",79)="=" + S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Original Fill Released: " I $P(RX2,"^",13) S DTT=$P(RX2,"^",13) D DAT S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_DAT K DAT,DTT + I $P(RX2,"^",15) S DTT=$P(RX2,"^",15) D DAT S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_"(Returned to Stock "_DAT_")" K DAT,DTT + S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_" Routing: "_$S($P(RX0,"^",11)="W":"Window",1:"Mail") + I $G(^PSRX(DA,"H"))]"",$P(^("STA"),"^")=3 D HLD + D RF,PAR,ACT,COPAY^PSORXVW2,LBL,ECME^PSOORAL1,^PSORXVW2:$O(^PSRX(DA,4,0)) + Q +ACT ;activity log + N CNT + S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Activity Log:" + S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="# Date Reason Rx Ref Initiator Of Activity",IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0),"=",79)="=" + I '$O(^PSRX(DA,"A",0)) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="There's NO Activity to report" Q + S CNT=0 + F N=0:0 S N=$O(^PSRX(DA,"A",N)) Q:'N S P1=^(N,0),DTT=P1\1 D DAT D + .I $P(P1,"^",2)="M" Q + .S IEN=IEN+1,CNT=CNT+1,^TMP("PSOAL",$J,IEN,0)=CNT_" "_DAT_" ",$P(RN," ",15)=" ",REA=$P(P1,"^",2) + .S REA=$F("HUCELPRWSIVDABXGKNM",REA)-1 + .I REA D + ..S STA=$P("HOLD^UNHOLD^DISCONTINUED^EDIT^RENEWED^PARTIAL^REINSTATE^REPRINT^SUSPENSE^RETURNED^INTERVENTION^DELETED^DRUG INTERACTION^PROCESSED^X-INTERFACE^PATIENT INSTR.^PKI/DEA^DISP COMPLETED^ECME^","^",REA) + ..S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_STA_$E(RN,$L(STA)+1,15) + .E S $P(STA," ",15)=" ",^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_STA + .K STA,RN S $P(RN," ",15)=" ",RF=+$P(P1,"^",4) + .S RFT=$S(RF>0&(RF<6):"REFILL "_RF,RF=6:"PARTIAL",RF>6:"REFILL "_(RF-1),1:"ORIGINAL") + .K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=$P(P1,"^",3) D ^DIC + .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_RFT_$E(RN,$L(RFT)+1,15)_$S(+Y:$P(Y,"^",2),1:$P(P1,"^",3)) + .;S:$P(P1,"^",5)]"" IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_$P(P1,"^",5) + .I $P(P1,"^",5)]"" N PSOACBRK,PSOACBRV D + ..S PSOACBRV=$P(P1,"^",5) + ..I $L(PSOACBRV)<71 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_PSOACBRV Q + ..I $E(PSOACBRV,1,70)'[" " S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_$E(PSOACBRV,1,70),IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$E(PSOACBRV,71,245) Q + ..F PSOACBRK=245:-1 Q:PSOACBRK=0 I $E(PSOACBRV,PSOACBRK)=" ",PSOACBRK<71 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_$E(PSOACBRV,1,PSOACBRK),IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$E(PSOACBRV,PSOACBRK,245) Q + .I $G(^PSRX(DA,"A",N,1))]"" S IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0)," ",5)=$P(^PSRX(DA,"A",N,1),"^") I $P(^PSRX(DA,"A",N,1),"^",2)]"" S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_":"_$P(^PSRX(DA,"A",N,1),"^",2) + .I $O(^PSRX(DA,"A",N,2,0)) F I=0:0 S I=$O(^PSRX(RXN,"A",N,2,I)) Q:'I S MIG=^PSRX(RXN,"A",N,2,I,0) D + ..F SG=1:1:$L(MIG) S:$L(^TMP("PSOAL",$J,IEN,0)_" "_$P(MIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0)," ",9)=" " S:$P(MIG," ",SG)'="" ^TMP("PSOAL",$J,IEN,0)=$G(^TMP("PSOAL",$J,IEN,0))_" "_$P(MIG," ",SG) + K MIG,SG,I Q +LBL ;label log + S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Label Log:" + S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="# Date Rx Ref Printed By",IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0),"=",79)="=" + I '$O(^PSRX(DA,"L",0)) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="There are NO Labels printed." Q + F L1=0:0 S L1=$O(^PSRX(DA,"L",L1)) Q:'L1 S LBL=^PSRX(DA,"L",L1,0),DTT=$P(^(0),"^") D DAT D + .S $P(RN," ",26)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=L1_" "_DAT_" ",RFT=$S($P(LBL,"^",2):"REFILL "_$P(LBL,"^",2),1:"ORIGINAL"),RFT=RFT_$E(RN,$L(RFT)+1,26) + .K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=$P(LBL,"^",4) D ^DIC + .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_RFT_$P(Y,"^",2),IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_$P(LBL,"^",3) + K DIC,X,Y Q +RF ;refill log + S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Refill Log:" + S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="# Log Date Refill Date Qty Routing Lot # Pharmacist",IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0),"=",79)="=" + S (RF,PL)=0 F RF=0:0 S RF=$O(^PSRX(DA,1,RF)) Q:'RF S PL=PL+1 + I 'PL S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="There are NO Refills For this Prescription" Q + F N=0:0 S N=$O(^PSRX(DA,1,N)) Q:'N S P1=^(N,0) D + .S DTT=$P(P1,"^",8)\1 D DAT S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=N_" "_DAT_" " + .S DTT=$P(P1,"^"),$P(RN," ",10)=" " D DAT + .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_DAT_" "_$P(P1,"^",4)_$E(" ",$L($P(P1,"^",4))+1,15)_" "_$S($P(P1,"^",2)="M":"Mail",1:"Window")_" "_$P(P1,"^",6)_$E(RN,$L($P(P1,"^",6))+1,12) + .K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=+$P(P1,"^",5) D ^DIC + .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_$E($S(+Y:$P(Y,"^",2),1:""),1,16) K DIC,X,Y + .S PSDIV=$S($D(^PS(59,+$P(P1,"^",9),0)):$P(^(0),"^",6),1:"Unknown"),IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Division: "_PSDIV_$E(" ",$L(PSDIV)+1,8)_" " + .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_"Dispensed: "_$S($P(P1,"^",19):$E($P(P1,"^",19),4,5)_"/"_$E($P(P1,"^",19),6,7)_"/"_$E($P(P1,"^",19),2,3),1:"")_" " + .S RTS=$S($P(P1,"^",16):" Returned to Stock: "_$E($P(P1,"^",16),4,5)_"/"_$E($P(P1,"^",16),6,7)_"/"_$E($P(P1,"^",16),2,3),1:" Released: "_$S($$RXRLDT^PSOBPSUT(DA,N):$$FMTE^XLFDT($$RXRLDT^PSOBPSUT(DA,N)\1,2),1:"")) + .I $$STATUS^PSOBPSUT(DA,N)'="",$$RXRLDT^PSOBPSUT(DA,N) S RTS=RTS_" NDC: "_$$GETNDC^PSONDCUT(DA,N) + .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_RTS + .S:$P(P1,"^",3)]"" IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Remarks: "_$P(P1,"^",3) + K RTS Q +PAR ;partial log + S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Partial Fills:" + S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="# Log Date Date Qty Routing Lot # Pharmacist",IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0),"=",79)="=" + I '$O(^PSRX(DA,"P",0)) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="There are NO Partials for this Prescription" Q + S N=0 F S N=$O(^PSRX(DA,"P",N)) Q:'N S P1=^(N,0),DTT=$P(P1,"^",8)\1 D DAT D + .S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=N_" "_DAT_" ",QTY=$P(P1,"^",4)_$E(" ",$L($P(P1,"^",4))+1,15) + .S DTT=$P(P1,"^") D DAT S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_DAT_" "_QTY_" " + .S PSDIV=$S($D(^PS(59,+$P(P1,"^",9),0)):$P(^(0),"^",6),1:"UNKNOWN"),PSDIV=PSDIV_$E(" ",$L(PSDIV)+1,8) + .S MW=$S($P(P1,"^",2)="M":"Mail",1:"Window"),MW=MW_$E(" ",$L(MW)+1,10) + .K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=+$P(P1,"^",16) D ^DIC + .S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_MW_" "_$P(P1,"^",6)_$E(" ",$L($P(P1,"^",6))+1,10)_$E($S(+Y:$P(Y,"^",2),1:""),1,16) + .S RTS=$S($P(P1,"^",16):" RETURNED TO STOCK: "_$E($P(P1,"^",16),4,5)_"/"_$E($P(P1,"^",16),6,7)_"/"_$E($P(P1,"^",16),2,3),1:" RELEASED: "_$S($P(P1,"^",19):$E($P(P1,"^",19),4,5)_"/"_$E($P(P1,"^",19),6,7)_"/"_$E($P(P1,"^",19),2,3),1:"")) + .K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=$P(P1,"^",7) D ^DIC + .S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Division: "_PSDIV_" "_RTS ;_" Entry By: "_$P(Y,"^",2) K DIC,X,Y + .S:$P(P1,"^",3)]"" IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" REMARKS: "_$P(P1,"^",3) K RTS + Q +HLD ;hold info + S DTT=$P(^PSRX(DA,"H"),"^",3) D DAT S HLDR=$P(^DD(52,99,0),"^",3),HLDR=$S($P(^PSRX(DA,"H"),"^")'>8:$P(HLDR,";",$P(^PSRX(DA,"H"),"^")),1:$P(HLDR,";",9)),HLDR=$P(HLDR,":",2) + S $P(RN," ",60)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Hold Reason: "_HLDR_$E(RN,$L("Hold Reason: "_HLDR)+1,60)_"Hold Date: "_DAT S:$P(^PSRX(DA,"H"),"^",2)]"" IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Hold Comments: "_$P(^PSRX(DA,"H"),"^",2) + K RN,DAT,DTT,HLDR + Q +DAT S DAT="",DTT=DTT\1 Q:DTT'?7N S DAT=$E(DTT,4,5)_"/"_$E(DTT,6,7)_"/"_$E(DTT,2,3) + Q +INST ;formats instruction from front door + I $O(^PSRX(DA,"PI",0)) D + .S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Instructions:" + .S T=0 F S T=$O(^PSRX(RXN,"PI",T)) Q:'T D ;PSO*210 + ..S MIG=^PSRX(RXN,"PI",T,0) + ..D WORDWRAP^PSOUTLA2(MIG,.IEN,$NA(^TMP("PSOAL",$J)),21) + K T,TY,MIG,SG + Q +PC ;displays provider comments + I $O(^PSRX(DA,"PRC",0)) D + .S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Provider Comments:" + .S T=0 F S T=$O(^PSRX(RXN,"PRC",T)) Q:'T D ;PSO*210 + ..S MIG=^PSRX(RXN,"PRC",T,0) + ..D WORDWRAP^PSOUTLA2(MIG,.IEN,$NA(^TMP("PSOAL",$J)),21) + K T,TY,MIG,SG + Q +DOSE ;displays dosing instruction for both simple and complex Rxs. + D DOSE^PSORXVW2 + Q + ; +HLP ; Help Text for the VIEW PRESCRIPTION prompt + W !," You may enter E.NNNNNNN, where NNNNNNN is the" + W !," prescription ECME# (e.g., E.0289332) or," + D LKP("?") + Q +LKP(INPUT) ; - Peforms Lookup on the PRESCRIPTION file + N DIC,X,Y + S DIC="^PSRX(",DIC(0)="QE",D="B",X=INPUT + S DIC("S")="I $P($G(^(0)),""^"",2),$D(^(""STA"")),$P($G(^(""STA"")),""^"")'=13" + D IX^DIC + Q Y diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSD0.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSD0.m index b6fe4a69..4870cb54 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSD0.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSD0.m @@ -1,95 +1,95 @@ -PSOSD0 ;BHAM ISC/SAB - action or informational profile cont. ;6/21/07 8:20am - ;;7.0;OUTPATIENT PHARMACY;**2,19,40,66,107,110,258,206**;DEC 1997;Build 39 - ;External reference to ^PS(50.605 supported by DBIA 696 - ;External reference to ^SC supported by DBIA 10040 - ;External reference to ^PSDRUG supported by DBIA 221 -CLASS S (ZCLASS,CLASS)="",RXCNT=0 F Z0=0:0 S CLASS=$O(^TMP($J,"PRF",CLASS)) Q:CLASS="" S PCLASS=$S($D(^PS(50.605,+$O(^PS(50.605,"B",CLASS,0)),0)):CLASS_" - "_$P(^(0),"^",2),1:"UNCLASSIFIED") D DRUG Q:$D(DTOUT)!($D(DUOUT)) - Q -DRUG S DRUG="" F Z1=0:0 S DRUG=$O(^TMP($J,"PRF",CLASS,DRUG)) Q:DRUG="" S FDT="" F Z3=0:0 S FDT=$O(^TMP($J,"PRF",CLASS,DRUG,FDT)) Q:'FDT D RXN Q:$D(DTOUT)!($D(DUOUT)) - Q -RXN I PSORM D - .D:$S($P($G(PSOPAR),"^")&($G(PSTYPE))&('$D(DOD(DFN))):RXCNT=3,'$G(PSTYPE)!($D(DOD(DFN))):RXCNT=6,1:RXCNT=4) HD1^PSOSD2 - I 'PSORM D - .D:$S($P($G(PSOPAR),"^")&($G(PSTYPE))&('$D(DOD(DFN))):RXCNT=2,1:RXCNT=5) HD1^PSOSD2 - S RXN=0 F Z2=0:0 S RXN=$O(^TMP($J,"PRF",CLASS,DRUG,FDT,RXN)) Q:'RXN D Q:$D(DTOUT)!($D(DUOUT)) - .S RX0=^TMP($J,"PRF",CLASS,DRUG,FDT,RXN),J=RXN,RX2=$S($D(^PSRX(J,2)):^(2),1:""),RX3=$G(^(3)),RXNO=RXN - .S RXNODE=^PSRX(RXN,0),$P(RXNODE,"^",15)=+$G(^("STA")) D ENSAVE^PSODACT,RXN1 - Q -RXN1 S RFL=1,FILL(9999999-$P(RX2,"^",2))=+$P(RX2,"^",2)_"^"_$S($P(RX2,"^",15):"(R)",1:""),FILLS=+$P(RX0,"^",9) - F II=0:0 S II=$O(^PSRX(J,1,II)) Q:'II S FILL(9999999-^PSRX(J,1,II,0))=+^PSRX(J,1,II,0)_"^"_$S($P(^(0),"^",16):"(R)",1:"") S RFL=RFL+1 - S PHYS=$S($D(^VA(200,+$P(RX0,"^",4),0)):$P(^(0),"^"),1:"UNKNOWN") - I 'PSTYPE,ZCLASS=CLASS,$E(IOST)="C" K DIR S DIR(0)="E" D ^DIR Q:$D(DTOUT)!($D(DUOUT)) W ! - I $S($G(PSTYPE):$Y>48,1:$Y>60)!(ZCLASS]""&(ZCLASS'=CLASS)&($S($G(PSTYPE):$Y+16>IOSL,1:$Y+8>IOSL))) D HD1^PSOSD2 Q:$D(DTOUT)!($D(DUOUT)) - I ZCLASS'=CLASS D:$S($G(PSTYPE):$Y>48,1:$Y>60) HD1^PSOSD2 W !,$S('PSORM:"Class: ",1:"Classification: ")_PCLASS,! S ZCLASS=CLASS - I 'PSORM D EIGHTY Q - W !,$S('$D(^PSDRUG(+$P(RX0,"^",6),0)):"",+$P(^PSDRUG(+$P(RX0,"^",6),0),"^",9):"N/F",1:"")," ",$S($D(^PSDRUG(+$P(RX0,"^",6),0)):$P(^(0),"^"),1:"NOT ON FILE") - N ACTS D ACTS - W ?45,"Qty: "_$P(RX0,"^",7)_" for "_$P(RX0,"^",8)_" Days ",?74,$P(RX0,"^"),?84," ",ACTS,?99,$E($P(RX2,"^",6),4,5)_"-"_$E($P(RX2,"^",6),6,7)_"-"_($E($P(RX2,"^",6),1,3)+1700) - W ?110,$E(PHYS,1,30) D COS^PSOSDP - I $G(^PSDRUG(+$P(RX0,"^",6),"PSO"))]"" W !," Message: "_$G(^PSDRUG(+$P(RX0,"^",6),"PSO")) - S RXCNT=RXCNT+1 D SIG W !?9,"Sig: ",$G(BSIG(1)) - I $O(BSIG(1)) F PSREV=1:0 S PSREV=$O(BSIG(PSREV)) Q:'PSREV W !?14,$G(BSIG(PSREV)) - K BSIG,PSREV - S RFS=0 F RF=0:0 S RF=$O(^PSRX(RXN,1,RF)) Q:'RF S RFS=RFS+1 - W !?10,"Filled: " F PSIII=0:0 S PSIII=$O(FILL(PSIII)) Q:'PSIII S Y=FILL(PSIII) W:Y " ",$E($P(Y,"^"),4,5),"-",$E($P(Y,"^"),6,7),"-",($E($P(Y,"^"),1,3)+1700)_$P(Y,"^",2) - S DUPD=$O(^TMP($J,"PRF",CLASS,DRUG,FDT)) I DUPD,RFL<6 D - .S OLDRX2=RX2,OLDJ=J,OLDFILL=FDT,OLDRX=RXN W " Past Fills:" D DUP S FDT=OLDFILL,J=OLDJ,RX2=OLDRX2,RXN=OLDRX K OLDJ,OLDRX2,OLDFILL,OLDRX - W !?10,"Remaining Refills: "_($P(RX0,"^",9)-RFS),?45,"Clinic: ",$S($D(^SC(+$P(RX0,"^",5),0)):$E($P(^(0),"^"),1,30),1:"UNKNOWN") - W ?105,"Price: " S PRICE=$S($D(^PSDRUG($P(RX0,"^",6),660)):$P(^(660),"^",6),1:0),COST=$P(RX0,"^",7)*PRICE S:COST<1 COST="0"_COST W "$",$J(COST,3,2),! K COST - I 'PSTYPE D:$D(^PSDRUG(+$P(RX0,"^",6),"CLOZ"))&($P($G(^("CLOZ1")),"^")'="PSOCLO1") ^PSOLAB G RXN2 - G:$G(DOD(DFN))]"" RXN2 - D:+$G(PSOBAR4) BAR S PSRENW=0,PSODEA=$P($G(^PSDRUG(+$P(RX0,"^",6),0)),"^",3) I PSODEA'["1",PSODEA'["2",PSODEA'["W",$P($G(^PS(53,+$P(RX0,"^",3),0)),"^",5) S PSRENW=1 - S PSOIFSUP=$S(PSODEA']"":0,PSODEA["S":1,1:0),RXX=$P(RX0,"^"),RXX(1)="",RXX=$O(^PSRX("B",RXX,RXX(1))) - W:$P($G(^PSRX(RXX,"IB")),"^") !?11,"****COPAY****" D PSRENW^PSOSD2 - I PSRENW W !?1,$S(PSOIFSUP:"",'$D(PSOPRINT):"",PSOPRINT]"":PSOPRINT,1:""),?11,"RENEW/MD:" F T=1:1:30 W "_" I T=30 W "VA#:" F I=1:1:10 W "_" I I=10 D - .W "DATE__________ REFILL" - .W $S($P(RX0,"^",8)'<60&($P(RX0,"^",8)'>89):" 0 1 2"_$S('CS:" 3 4 5",1:""),$P(RX0,"^",8)<60:" 0 1 2 3 4 5"_$S('CS:" 6 7 8 9 10 11",1:""),1:" 0 1"_$S('CS:" 2 3",1:"")),! - I "ASH"[$E($P(RX0,"^",15)),PSTYPE D - .W !?21,"DISCONTINUE/MD:" F T=1:1:30 W "_" I T=30 W "VA#:" F I=1:1:10 W "_" I I=10 W "DATE__________",! - D:$D(^PSDRUG(+$P(RX0,"^",6),"CLOZ"))&($P($G(^("CLOZ1")),"^")'="PSOCLO1") PRINT^PSOLAB -RXN2 W ! K RX0,RX3,RX2,PRDT,LABEL,PHYS,PSI,PSII,PSIII,II,Y,SIG,X,FILL,FILLS,PHYS,Z9,PRICE,I,T,RXX - Q -SIG K FSIG,BSIG I $P($G(^PSRX(RXN,"SIG")),"^",2) D FSIG^PSOUTLA("R",RXN,$S('PSORM:64,$E(IOST)="C":64,1:114)) F PSREV=1:1 Q:'$D(FSIG(PSREV)) S BSIG(PSREV)=FSIG(PSREV) - K FSIG,PSREV I '$P($G(^PSRX(RXN,"SIG")),"^",2) D EN3^PSOUTLA1(RXN,$S('PSORM:64,$E(IOST)="C":64,1:114)) - Q -DUP ;DUP DRUG - F Z4=0:0 Q:RFL>9 S FDT=$O(^TMP($J,"PRF",CLASS,DRUG,FDT)) Q:'FDT D - .F Z5=0:0 S Z5=$O(^TMP($J,"PRF",CLASS,DRUG,FDT,Z5)) Q:'Z5 S RX2=$S($D(^PSRX(Z5,2)):^(2),1:"") D:"DE"[$E($P(^TMP($J,"PRF",CLASS,DRUG,FDT,Z5),"^",15)) - ..K FILL S FILL(9999999-$P(RX2,"^",2))=+$P(RX2,"^",2)_"^"_$S($P(RX2,"^",15):"(R)",1:"") F II=0:0 S II=$O(^PSRX(Z5,1,II)) Q:'II S FILL(9999999-$P(^PSRX(Z5,1,II,0),"^"))=$P(^PSRX(Z5,1,II,0),"^")_"^"_$S($P(^(0),"^",16):"(R)",1:"") - ..F PSII=0:0 S PSII=$O(FILL(PSII)) Q:'PSII W:($X+8)>$S('PSORM:80,1:IOM) !?9 S Y=FILL(PSII) W " ",$E($P(Y,"^"),4,5)_"-"_$E($P(Y,"^"),6,7)_"-"_($E($P(Y,"^"),1,3)+1700)_$P(Y,"^",2) - ..K ^TMP($J,"PRF",CLASS,DRUG,FDT,Z5) - Q -BAR ;barcode - I PSOBAR4 S X="S",X2=PSOINST_"-"_RXN W !?15 S X1=$X W @PSOBAR3,X2,@PSOBAR2,$C(13) S $X=0 - Q -EIGHTY ;prints profile in 80 column format - W !,$S('$D(^PSDRUG(+$P(RX0,"^",6),0)):"",+$P(^PSDRUG(+$P(RX0,"^",6),0),"^",9):"N/F",1:"")," ",$S($D(^PSDRUG(+$P(RX0,"^",6),0)):$P(^(0),"^"),1:"NOT ON FILE"),?45,"Rx #: "_$P(RX0,"^") - I $G(^PSDRUG(+$P(RX0,"^",6),"PSO"))]"" W !," Message: "_$G(^PSDRUG(+$P(RX0,"^",6),"PSO")) - N ACTS D ACTS - W !?1,"Qty: "_$P(RX0,"^",7)_" for "_$P(RX0,"^",8)_" Days "_ACTS," Exp: "_$E($P(RX2,"^",6),4,5)_"-"_$E($P(RX2,"^",6),6,7)_"-"_($E($P(RX2,"^",6),1,3)+1700) - W ?48," Prov: "_$E(PHYS,1,30) I $P($G(^PSRX(J,3)),"^",3),$D(^VA(200,+$P($G(^(3)),"^",3),0)) W !,?43,"COSIGNER: "_$P($G(^VA(200,+$P(^PSRX(J,3),"^",3),0)),"^") - S RXCNT=RXCNT+1 D SIG W !?9,"Sig: ",$G(BSIG(1)) - I $O(BSIG(1)) F PSREV=1:0 S PSREV=$O(BSIG(PSREV)) Q:'PSREV W !?14,$G(BSIG(PSREV)) - K BSIG,PSREV - S RFS=0 F RF=0:0 S RF=$O(^PSRX(RXN,1,RF)) Q:'RF S RFS=RFS+1 - W !?10,"Filled: " F PSIII=0:0 S PSIII=$O(FILL(PSIII)) Q:'PSIII S Y=FILL(PSIII) W:Y " ",$E($P(Y,"^"),4,5),"-",$E($P(Y,"^"),6,7),"-",($E($P(Y,"^"),1,3)+1700)_$P(Y,"^",2) - S DUPD=$O(^TMP($J,"PRF",CLASS,DRUG,FDT)) I DUPD,RFL<6 D - .S OLDRX2=RX2,OLDJ=J,OLDFILL=FDT,OLDRX=RXN W " Past Fills:" D DUP S FDT=OLDFILL,J=OLDJ,RX2=OLDRX2,RXN=OLDRX K OLDJ,OLDRX2,OLDFILL,OLDRX - W !?10,"Remaining Refills: "_($P(RX0,"^",9)-RFS),?45,"Clinic: ",$S($D(^SC(+$P(RX0,"^",5),0)):$E($P(^(0),"^"),1,30),1:"UNKNOWN") - W !?10,"Price: " S PRICE=$S($D(^PSDRUG($P(RX0,"^",6),660)):$P(^(660),"^",6),1:0),COST=$P(RX0,"^",7)*PRICE S:COST<1 COST="0"_COST W "$",$J(COST,3,2),! K COST - I 'PSTYPE D:$D(^PSDRUG(+$P(RX0,"^",6),"CLOZ"))&($P($G(^("CLOZ1")),"^")'="PSOCLO1") ^PSOLAB G RXN2 - G:$G(DOD(DFN))]"" RXN3 - D:+$G(PSOBAR4) BAR S PSRENW=0,PSODEA=$P($G(^PSDRUG(+$P(RX0,"^",6),0)),"^",3) I PSODEA'["1",PSODEA'["2",PSODEA'["W",$P($G(^PS(53,+$P(RX0,"^",3),0)),"^",5) S PSRENW=1 - S PSOIFSUP=$S(PSODEA']"":0,PSODEA["S":1,1:0),RXX=$P(RX0,"^"),RXX(1)="",RXX=$O(^PSRX("B",RXX,RXX(1))) - W:$P($G(^PSRX(RXX,"IB")),"^") !?11,"****COPAY****" D PSRENW^PSOSD2 - I PSRENW W !?1,$S(PSOIFSUP:"",'$D(PSOPRINT):"",PSOPRINT]"":PSOPRINT,1:""),?6,"RENEW/MD:" F T=1:1:30 W "_" I T=30 W "VA#:" F I=1:1:10 W "_" I I=10 D - .W "DATE__________",!?6,"REFILLS" - .W $S($P(RX0,"^",8)'<60&($P(RX0,"^",8)'>89):" 0 1 2"_$S('CS:" 3 4 5",1:""),$P(RX0,"^",8)<60:" 0 1 2 3 4 5"_$S('CS:" 6 7 8 9 10 11",1:""),1:" 0 1"_$S('CS:" 2 3",1:"")),! - I "ASH"[$E($P(RX0,"^",15)),PSTYPE D - .W !?11,"DISCONTINUE/MD:" F T=1:1:26 W "_" I T=26 W "VA#:" F I=1:1:10 W "_" I I=10 W "DATE__________",! - D:$D(^PSDRUG(+$P(RX0,"^",6),"CLOZ"))&($P($G(^("CLOZ1")),"^")'="PSOCLO1") PRINT^PSOLAB -RXN3 W ! K RX0,RX3,RX2,PRDT,LABEL,PHYS,PSI,PSII,PSIII,II,Y,SIG,X,FILL,FILLS,PHYS,Z9,PRICE,I,T,RXX - Q -ACTS ; - S ACTS=$S($P(RX0,"^",15)["PENDING":"PENDING",$P(RX0,"^",15)["Suspended":"Active/Susp",1:$P(RX0,"^",15)) - Q +PSOSD0 ;BHAM ISC/SAB - action or informational profile cont. ;3/24/93 + ;;7.0;OUTPATIENT PHARMACY;**2,19,40,66,107,110,258**;DEC 1997;Build 4 + ;External reference to ^PS(50.605 supported by DBIA 696 + ;External reference to ^SC supported by DBIA 10040 + ;External reference to ^PSDRUG supported by DBIA 221 +CLASS S (ZCLASS,CLASS)="",RXCNT=0 F Z0=0:0 S CLASS=$O(^TMP($J,"PRF",CLASS)) Q:CLASS="" S PCLASS=$S($D(^PS(50.605,+$O(^PS(50.605,"B",CLASS,0)),0)):CLASS_" - "_$P(^(0),"^",2),1:"UNCLASSIFIED") D DRUG Q:$D(DTOUT)!($D(DUOUT)) + Q +DRUG S DRUG="" F Z1=0:0 S DRUG=$O(^TMP($J,"PRF",CLASS,DRUG)) Q:DRUG="" S FDT="" F Z3=0:0 S FDT=$O(^TMP($J,"PRF",CLASS,DRUG,FDT)) Q:'FDT D RXN Q:$D(DTOUT)!($D(DUOUT)) + Q +RXN I PSORM D + .D:$S($P($G(PSOPAR),"^")&($G(PSTYPE))&('$D(DOD(DFN))):RXCNT=3,'$G(PSTYPE)!($D(DOD(DFN))):RXCNT=6,1:RXCNT=4) HD1^PSOSD2 + I 'PSORM D + .D:$S($P($G(PSOPAR),"^")&($G(PSTYPE))&('$D(DOD(DFN))):RXCNT=2,1:RXCNT=5) HD1^PSOSD2 + S RXN=0 F Z2=0:0 S RXN=$O(^TMP($J,"PRF",CLASS,DRUG,FDT,RXN)) Q:'RXN D Q:$D(DTOUT)!($D(DUOUT)) + .S RX0=^TMP($J,"PRF",CLASS,DRUG,FDT,RXN),J=RXN,RX2=$S($D(^PSRX(J,2)):^(2),1:""),RX3=$G(^(3)),RXNO=RXN + .S RXNODE=^PSRX(RXN,0),$P(RXNODE,"^",15)=+$G(^("STA")) D ENSAVE^PSODACT,RXN1 + Q +RXN1 S RFL=1,FILL(9999999-$P(RX2,"^",2))=+$P(RX2,"^",2)_"^"_$S($P(RX2,"^",15):"(R)",1:""),FILLS=+$P(RX0,"^",9) + F II=0:0 S II=$O(^PSRX(J,1,II)) Q:'II S FILL(9999999-^PSRX(J,1,II,0))=+^PSRX(J,1,II,0)_"^"_$S($P(^(0),"^",16):"(R)",1:"") S RFL=RFL+1 + S PHYS=$S($D(^VA(200,+$P(RX0,"^",4),0)):$P(^(0),"^"),1:"UNKNOWN") + I 'PSTYPE,ZCLASS=CLASS,$E(IOST)="C" K DIR S DIR(0)="E" D ^DIR Q:$D(DTOUT)!($D(DUOUT)) W ! + I $S($G(PSTYPE):$Y>48,1:$Y>60)!(ZCLASS]""&(ZCLASS'=CLASS)&($S($G(PSTYPE):$Y+16>IOSL,1:$Y+8>IOSL))) D HD1^PSOSD2 Q:$D(DTOUT)!($D(DUOUT)) + I ZCLASS'=CLASS D:$S($G(PSTYPE):$Y>48,1:$Y>60) HD1^PSOSD2 W !,$S('PSORM:"Class: ",1:"Classification: ")_PCLASS,! S ZCLASS=CLASS + I 'PSORM D EIGHTY Q + W !,$S('$D(^PSDRUG(+$P(RX0,"^",6),0)):"",+$P(^PSDRUG(+$P(RX0,"^",6),0),"^",9):"N/F",1:"")," ",$S($D(^PSDRUG(+$P(RX0,"^",6),0)):$P(^(0),"^"),1:"NOT ON FILE") + N ACTS D ACTS + W ?45,"Qty: "_$P(RX0,"^",7)_" for "_$P(RX0,"^",8)_" Days ",?74,$P(RX0,"^"),?84," ",ACTS,?99,$E($P(RX2,"^",6),4,5)_"-"_$E($P(RX2,"^",6),6,7)_"-"_($E($P(RX2,"^",6),1,3)+1700) + W ?110,$E(PHYS,1,30) D COS^PSOSDP + I $G(^PSDRUG(+$P(RX0,"^",6),"PSO"))]"" W !," Message: "_$G(^PSDRUG(+$P(RX0,"^",6),"PSO")) + S RXCNT=RXCNT+1 D SIG W !?9,"Sig: ",$G(BSIG(1)) + I $O(BSIG(1)) F PSREV=1:0 S PSREV=$O(BSIG(PSREV)) Q:'PSREV W !?14,$G(BSIG(PSREV)) + K BSIG,PSREV + S RFS=0 F RF=0:0 S RF=$O(^PSRX(RXN,1,RF)) Q:'RF S RFS=RFS+1 + W !?10,"Filled: " F PSIII=0:0 S PSIII=$O(FILL(PSIII)) Q:'PSIII S Y=FILL(PSIII) W:Y " ",$E($P(Y,"^"),4,5),"-",$E($P(Y,"^"),6,7),"-",($E($P(Y,"^"),1,3)+1700)_$P(Y,"^",2) + S DUPD=$O(^TMP($J,"PRF",CLASS,DRUG,FDT)) I DUPD,RFL<6 D + .S OLDRX2=RX2,OLDJ=J,OLDFILL=FDT,OLDRX=RXN W " Past Fills:" D DUP S FDT=OLDFILL,J=OLDJ,RX2=OLDRX2,RXN=OLDRX K OLDJ,OLDRX2,OLDFILL,OLDRX + W !?10,"Remaining Refills: "_($P(RX0,"^",9)-RFS),?45,"Clinic: ",$S($D(^SC(+$P(RX0,"^",5),0)):$E($P(^(0),"^"),1,30),1:"UNKNOWN") + W ?105,"Price: " S PRICE=$S($D(^PSDRUG($P(RX0,"^",6),660)):$P(^(660),"^",6),1:0),COST=$P(RX0,"^",7)*PRICE S:COST<1 COST="0"_COST W "$",$J(COST,3,2),! K COST + I 'PSTYPE D:$D(^PSDRUG(+$P(RX0,"^",6),"CLOZ"))&($P($G(^("CLOZ1")),"^")'="PSOCLO1") ^PSOLAB G RXN2 + G:$G(DOD(DFN))]"" RXN2 + D:+$G(PSOBAR4) BAR S PSRENW=0,PSODEA=$P($G(^PSDRUG(+$P(RX0,"^",6),0)),"^",3) I PSODEA'["2",PSODEA'["W",$P($G(^PS(53,+$P(RX0,"^",3),0)),"^",5) S PSRENW=1 + S PSOIFSUP=$S(PSODEA']"":0,PSODEA["S":1,1:0),RXX=$P(RX0,"^"),RXX(1)="",RXX=$O(^PSRX("B",RXX,RXX(1))) + W:$P($G(^PSRX(RXX,"IB")),"^") !?11,"****COPAY****" D PSRENW^PSOSD2 + I PSRENW W !?1,$S(PSOIFSUP:"",'$D(PSOPRINT):"",PSOPRINT]"":PSOPRINT,1:""),?11,"RENEW/MD:" F T=1:1:30 W "_" I T=30 W "VA#:" F I=1:1:10 W "_" I I=10 D + .W "DATE__________ REFILL" + .W $S($P(RX0,"^",8)'<60&($P(RX0,"^",8)'>89):" 0 1 2"_$S('CS:" 3 4 5",1:""),$P(RX0,"^",8)<60:" 0 1 2 3 4 5"_$S('CS:" 6 7 8 9 10 11",1:""),1:" 0 1"_$S('CS:" 2 3",1:"")),! + I "ASH"[$E($P(RX0,"^",15)),PSTYPE D + .W !?21,"DISCONTINUE/MD:" F T=1:1:30 W "_" I T=30 W "VA#:" F I=1:1:10 W "_" I I=10 W "DATE__________",! + D:$D(^PSDRUG(+$P(RX0,"^",6),"CLOZ"))&($P($G(^("CLOZ1")),"^")'="PSOCLO1") PRINT^PSOLAB +RXN2 W ! K RX0,RX3,RX2,PRDT,LABEL,PHYS,PSI,PSII,PSIII,II,Y,SIG,X,FILL,FILLS,PHYS,Z9,PRICE,I,T,RXX + Q +SIG K FSIG,BSIG I $P($G(^PSRX(RXN,"SIG")),"^",2) D FSIG^PSOUTLA("R",RXN,$S('PSORM:64,$E(IOST)="C":64,1:114)) F PSREV=1:1 Q:'$D(FSIG(PSREV)) S BSIG(PSREV)=FSIG(PSREV) + K FSIG,PSREV I '$P($G(^PSRX(RXN,"SIG")),"^",2) D EN3^PSOUTLA1(RXN,$S('PSORM:64,$E(IOST)="C":64,1:114)) + Q +DUP ;DUP DRUG + F Z4=0:0 Q:RFL>9 S FDT=$O(^TMP($J,"PRF",CLASS,DRUG,FDT)) Q:'FDT D + .F Z5=0:0 S Z5=$O(^TMP($J,"PRF",CLASS,DRUG,FDT,Z5)) Q:'Z5 S RX2=$S($D(^PSRX(Z5,2)):^(2),1:"") D:"DE"[$E($P(^TMP($J,"PRF",CLASS,DRUG,FDT,Z5),"^",15)) + ..K FILL S FILL(9999999-$P(RX2,"^",2))=+$P(RX2,"^",2)_"^"_$S($P(RX2,"^",15):"(R)",1:"") F II=0:0 S II=$O(^PSRX(Z5,1,II)) Q:'II S FILL(9999999-$P(^PSRX(Z5,1,II,0),"^"))=$P(^PSRX(Z5,1,II,0),"^")_"^"_$S($P(^(0),"^",16):"(R)",1:"") + ..F PSII=0:0 S PSII=$O(FILL(PSII)) Q:'PSII W:($X+8)>$S('PSORM:80,1:IOM) !?9 S Y=FILL(PSII) W " ",$E($P(Y,"^"),4,5)_"-"_$E($P(Y,"^"),6,7)_"-"_($E($P(Y,"^"),1,3)+1700)_$P(Y,"^",2) + ..K ^TMP($J,"PRF",CLASS,DRUG,FDT,Z5) + Q +BAR ;barcode + I PSOBAR4 S X="S",X2=PSOINST_"-"_RXN W !?15 S X1=$X W @PSOBAR3,X2,@PSOBAR2,$C(13) S $X=0 + Q +EIGHTY ;prints profile in 80 column format + W !,$S('$D(^PSDRUG(+$P(RX0,"^",6),0)):"",+$P(^PSDRUG(+$P(RX0,"^",6),0),"^",9):"N/F",1:"")," ",$S($D(^PSDRUG(+$P(RX0,"^",6),0)):$P(^(0),"^"),1:"NOT ON FILE"),?45,"Rx #: "_$P(RX0,"^") + I $G(^PSDRUG(+$P(RX0,"^",6),"PSO"))]"" W !," Message: "_$G(^PSDRUG(+$P(RX0,"^",6),"PSO")) + N ACTS D ACTS + W !?1,"Qty: "_$P(RX0,"^",7)_" for "_$P(RX0,"^",8)_" Days "_ACTS," Exp: "_$E($P(RX2,"^",6),4,5)_"-"_$E($P(RX2,"^",6),6,7)_"-"_($E($P(RX2,"^",6),1,3)+1700) + W ?48," Prov: "_$E(PHYS,1,30) I $P($G(^PSRX(J,3)),"^",3),$D(^VA(200,+$P($G(^(3)),"^",3),0)) W !,?43,"COSIGNER: "_$P($G(^VA(200,+$P(^PSRX(J,3),"^",3),0)),"^") + S RXCNT=RXCNT+1 D SIG W !?9,"Sig: ",$G(BSIG(1)) + I $O(BSIG(1)) F PSREV=1:0 S PSREV=$O(BSIG(PSREV)) Q:'PSREV W !?14,$G(BSIG(PSREV)) + K BSIG,PSREV + S RFS=0 F RF=0:0 S RF=$O(^PSRX(RXN,1,RF)) Q:'RF S RFS=RFS+1 + W !?10,"Filled: " F PSIII=0:0 S PSIII=$O(FILL(PSIII)) Q:'PSIII S Y=FILL(PSIII) W:Y " ",$E($P(Y,"^"),4,5),"-",$E($P(Y,"^"),6,7),"-",($E($P(Y,"^"),1,3)+1700)_$P(Y,"^",2) + S DUPD=$O(^TMP($J,"PRF",CLASS,DRUG,FDT)) I DUPD,RFL<6 D + .S OLDRX2=RX2,OLDJ=J,OLDFILL=FDT,OLDRX=RXN W " Past Fills:" D DUP S FDT=OLDFILL,J=OLDJ,RX2=OLDRX2,RXN=OLDRX K OLDJ,OLDRX2,OLDFILL,OLDRX + W !?10,"Remaining Refills: "_($P(RX0,"^",9)-RFS),?45,"Clinic: ",$S($D(^SC(+$P(RX0,"^",5),0)):$E($P(^(0),"^"),1,30),1:"UNKNOWN") + W !?10,"Price: " S PRICE=$S($D(^PSDRUG($P(RX0,"^",6),660)):$P(^(660),"^",6),1:0),COST=$P(RX0,"^",7)*PRICE S:COST<1 COST="0"_COST W "$",$J(COST,3,2),! K COST + I 'PSTYPE D:$D(^PSDRUG(+$P(RX0,"^",6),"CLOZ"))&($P($G(^("CLOZ1")),"^")'="PSOCLO1") ^PSOLAB G RXN2 + G:$G(DOD(DFN))]"" RXN3 + D:+$G(PSOBAR4) BAR S PSRENW=0,PSODEA=$P($G(^PSDRUG(+$P(RX0,"^",6),0)),"^",3) I PSODEA'["2",PSODEA'["W",$P($G(^PS(53,+$P(RX0,"^",3),0)),"^",5) S PSRENW=1 + S PSOIFSUP=$S(PSODEA']"":0,PSODEA["S":1,1:0),RXX=$P(RX0,"^"),RXX(1)="",RXX=$O(^PSRX("B",RXX,RXX(1))) + W:$P($G(^PSRX(RXX,"IB")),"^") !?11,"****COPAY****" D PSRENW^PSOSD2 + I PSRENW W !?1,$S(PSOIFSUP:"",'$D(PSOPRINT):"",PSOPRINT]"":PSOPRINT,1:""),?6,"RENEW/MD:" F T=1:1:30 W "_" I T=30 W "VA#:" F I=1:1:10 W "_" I I=10 D + .W "DATE__________",!?6,"REFILLS" + .W $S($P(RX0,"^",8)'<60&($P(RX0,"^",8)'>89):" 0 1 2"_$S('CS:" 3 4 5",1:""),$P(RX0,"^",8)<60:" 0 1 2 3 4 5"_$S('CS:" 6 7 8 9 10 11",1:""),1:" 0 1"_$S('CS:" 2 3",1:"")),! + I "ASH"[$E($P(RX0,"^",15)),PSTYPE D + .W !?11,"DISCONTINUE/MD:" F T=1:1:26 W "_" I T=26 W "VA#:" F I=1:1:10 W "_" I I=10 W "DATE__________",! + D:$D(^PSDRUG(+$P(RX0,"^",6),"CLOZ"))&($P($G(^("CLOZ1")),"^")'="PSOCLO1") PRINT^PSOLAB +RXN3 W ! K RX0,RX3,RX2,PRDT,LABEL,PHYS,PSI,PSII,PSIII,II,Y,SIG,X,FILL,FILLS,PHYS,Z9,PRICE,I,T,RXX + Q +ACTS ; + S ACTS=$S($P(RX0,"^",15)["PENDING":"PENDING",$P(RX0,"^",15)["Suspended":"Active/Susp",1:$P(RX0,"^",15)) + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSD1.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSD1.m index 0a0eee42..81763085 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSD1.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSD1.m @@ -1,99 +1,98 @@ -PSOSD1 ;BHAM ISC/SAB/JMB - action or informational profile cont. ; 10/30/07 10:39am - ;;7.0;OUTPATIENT PHARMACY;**2,17,19,22,40,49,66,107,110,132,233,258,240**;DEC 1997;Build 5 - ;External reference to ^PS(59.7 is supported by DBIA 694 - ; -INIT S PRF="" F PSOI=0:0 S DIC="^DPT(",DIC(0)="QEAM" D ^DIC Q:Y<0 D - .S PRF=PRF_+Y_",",DFN=+Y D DEM^VADPT I +VADM(6) W !,"Patient Expired on "_$P(VADM(6),"^",2),! S DOD(DFN)=$P(VADM(6),"^",2) K DFN - .I $L(PRF)>240 W !,$C(7),"MAX NUMBER OF PATIENTS HAS BEEN REACHED" Q - Q:'$L(PRF) D DAYS G:$D(DUOUT)!($D(DTOUT)) EXIT^PSOSD -DEV N PSOBARS,PSOBAR0,PSOBAR1 K %ZIS,IOP,ZTSK,ZTQUEUED S PSOION=ION,%ZIS="QM",%ZIS("B")="",%ZIS("A")=$S(PSTYPE:"Select a Printer: ",1:"DEVICE: ") D ^%ZIS K %ZIS I POP S IOP=PSOION D ^%ZIS K IOP,PSOION G EXIT - I $E(IOST)["C",PSTYPE D ^%ZISC W $C(7),!!,"Action Profiles MUST BE SENT TO A PRINTER !!",!,"ONLY INFORMATIONAL PROFILES ARE ALLOWED TO PRINT TO SCREEN !!",! G DEV - S PSOIOS=IOS D DEVBAR^PSOBMST S PSOBAR2=PSOBAR0,PSOBAR3=PSOBAR1 - S PSOBAR4=$G(PSOBAR3)]""&($G(PSOBAR2)]"")&(+$P($G(PSOPAR),"^")) - K PSOION I $D(IO("Q")) S ZTDESC="Outpatient Pharmacy Action Profile",ZTRTN="START^PSOSD1",ZTSAVE("ZTREQ")="@" D D EXIT Q:$G(LM) G ^PSOSD - .F G="PSORM","PSOPOL","PSONUM","PSOSYS","PSOINST","PSOBAR3","PSOBAR4","PSOBAR2","PSOPAR","PSOPAR7","PRF","PSDAYS","PSDATE","PSTYPE","PSOSITE","PSDATE","PSDAY" S:$D(@G) ZTSAVE(G)="" - .S ZTSAVE("DOD*")="",ZTSAVE("PSOBAR*")="" D ^%ZTLOAD W:$D(ZTSK) !,"Report Queued to Print !!",! K:'$G(LM) ZTSK,IO("Q") - D START G:'$G(LM) ^PSOSD - Q -START U IO S PSTYPE=$S($D(PSTYPE):PSTYPE,1:0),$P(LINE,"-",132)="-" - F PSIX=1:1 S DFN=$P(PRF,",",PSIX) G:DFN']"" EXIT D ELIG S PAGE=1 D G:$G(PSQFLG)!($D(DTOUT))!($D(DUOUT)) EXIT - .D PAT^PSOSD Q:$D(DTOUT)!($D(DUOUT)) D Q:PSQFLG D RXPAD:PSTYPE W:'$G(PSTYPE)&('$D(^TMP("PSOD",$J))) @IOF D ENSTUFF^PSODACT - ..Q:$D(DUOUT)!($D(DTOUT)) S PSQFLG=0 D ^PSOSD3,NVA^PSOSD3 -EXIT I '$D(PSONOPG) W ! D ^%ZISC K DFN - W:$D(PSONOPG)&('$D(ORVP)) @IOF - K ^TMP($J,"PRF"),^("ACT"),ADDR,ADDRFL,CLASS,CNDT,CNT,DRUG,CLAPP,HDFL,I,II,J,L,LINE,P,PAGE,PSDOB,PSIIX,PSNAME,PSOI,PSQFLG,PSSN,DFN,PSIX,PAGE,PGM,LINE,PRF,PSTYPE,PSDATE,PSDAYS,VAL,VAR,RX,RX0,RX3,RX2,ST,ST0,PSDAY,RF,RFS,PSOBAR3,PSOBAR4,PSOBAR2 - D KVA^VADPT K DOD,FILL,DIC,PSCNT,PSDT,PCLASS,PHYS,ZCLASS,PSOPRINT,RXNODE,DIR,X1,X2,PSONUM,PSOPOLP,PSSN4 - Q - ; -DAYS K DIR S DIR("A")="Profile Expiration/Discontinued Cutoff",DIR("B")=120,DIR(0)="N^0:9999:0",DIR("?",1)="Enter the number of days which will cut discontinued and expired Rx's from",DIR("?")="the profile." - D ^DIR Q:$D(DTOUT)!($D(DUOUT)) S PSDAYS=X K DIR S X1=DT,X2=-PSDAYS D C^%DTC S (PSDATE,PSDAY)=X - Q - ; -DFN S:'$D(PSORM) PSORM=1 - S PSOIOS=IOS D DEVBAR^PSOBMST S PSOBAR2=PSOBAR0,PSOBAR3=PSOBAR1 - S PSOBAR4=$G(PSOBAR3)]""&($G(PSOBAR2)]"")&(+$P($G(PSOPAR),"^")) - W:$D(PSONOPG)&($G(PSONOPG)'=2) @IOF I '$G(PSOSITE) S PSOSITE=$O(^PS(59,0)) - S PRF=DFN_"," D:'$G(PSDAYS) G START - .S PSDAYS=120,X1=DT,X2=-PSDAYS D C^%DTC S (PSDATE,PSDAY)=X - Q - ; -ELIG S PSOPRINT="" - D ELIG^VADPT - Q:'$D(VAEL(4)) - Q:+VAEL(4)'=1 - I $D(VAEL(3)),+VAEL(3)=1,($P(VAEL(3),"^",2)<50) S PSOPRINT="SC NSC" - D KVAR^VADPT - Q - ; -RXPAD N K Q:$G(DOD(DFN))]"" D HD F CNT=1:1:4 S LF="!?45" D Q:$Y+14>IOSL - .W !?4,"Name: "_PSNAME,?33,"ID#: "_PSSN4,?58,"DOB: "_PSDOB - .W !!,CNT,?4,"Medication: ",LN,$E(LN,1,11),!!?4,"Outpatient Directions: ",LN,!?4 - .W $E(LN,1,3),"SC",$E(LN,1,3),"NSC"," Quantity: _____ Days Supply _____ " - .W:'$G(PSORM) @LF W "Refills: 0 1 2 3 4 5 6 7 8 9 10 11" - .W !!?4,$E(LN,1,35)," ",$E(LN,1,14)," ",$E(LN,1,24) - .W !?4,"Provider's Signature",?40,"DEA #",?55,"Date/Time",!!,$E(LINE,1,$S('PSORM:80,1:IOM)) - K LF Q - ; -HD S FN=DFN S:'$D(PSORM) PSORM=1 - D ELIG^PSOSD1,DEM^VADPT,INP^VADPT,ADD^VADPT,PID^VADPT S PSSN=VA("PID"),PSSN4=VA("BID"),ADDRFL=$S(+VAPA(9):"Temporary ",1:"") - I +VADM(6) S DOD(DFN)=$P(VADM(6),"^",2) - S PSNAME=$E(VADM(1),1,28),PSDOB=$P(VADM(3),"^",2) I $D(IOF),$G(PAGE)'=1 W @IOF - W "Action Rx Profile",?47,"Run Date: " S Y=DT D DT^DIO2 W ?71,"Page: "_PAGE S PAGE=PAGE+1,X=$$SITE^VASITE - W !,"Sorted by drug classification for Rx's currently active"_$S('PSDAYS:" only.",1:"") W:PSDAYS !,"and for those Rx's that have been inactive less than "_PSDAYS_" days." - W @$S(PSORM:"?70",1:"!"),"Site: VAMC "_$P(X,"^",2)_" ("_$P(X,"^",3)_")",!,$E(LINE,1,$S('PSORM:80,1:IOM)-1) - I $P(VAIN(4),"^",2)]"",+$P($G(^PS(59.7,1,40.1)),"^") W !,"Outpatient prescriptions are discontinued 72 hours after admission.",! - W !?1,"Name : ",PSNAME,?30,"ID#: "_PSSN4 W ?58,"Action Date: ________" W !?1,"DOB : "_PSDOB - W:ADDRFL]"" ?30,ADDRFL,! W ?30,"Address :" - I $G(ADDRFL)="" D CHECKBAI - W ?41,VAPA(1) W:VAPA(2)]"" !?41,VAPA(2) W:VAPA(3)]"" !?41,VAPA(3) W !?41,VAPA(4)_", "_$P(VAPA(5),"^",2)_" "_$S(VAPA(11)]"":$P(VAPA(11),"^",2),1:VAPA(6)),!?30,"Phone : "_VAPA(8) - I PSOBAR4 S X="S",X2=PSSN W @$S('PSORM:"!?30",1:"?$X+5") S X1=$X W @PSOBAR3,X2,@PSOBAR2,$C(13) S $X=0 - S (WT,HT)="",X="GMRVUTL" X ^%ZOSF("TEST") I $T D - .F GMRVSTR="WT","HT" S VM=GMRVSTR D EN6^GMRVUTL S @VM=X,$P(@VM,"^")=$E($P(@VM,"^"),4,5)_"/"_$E($P(@VM,"^"),6,7)_"/"_($E($P(@VM,"^"),1,3)+1700) - .S X=$P(WT,"^",8),Y=$J(X/2.2,0,2),$P(WT,"^",9)=Y,X=$P(HT,"^",8),Y=$J(2.54*X,0,2),$P(HT,"^",9)=Y - W !!,"WEIGHT(Kg): " W:+$P(WT,"^",8) $P(WT,"^",9)_" ("_$P(WT,"^")_")" W ?41,"HEIGHT(cm): " W:$P(HT,"^",8) $P(HT,"^",9)_" ("_$P(HT,"^")_")" K VM,WT,HT - D GMRA^PSODEM W !,$E(LINE,1,$S('PSORM:80,1:IOM)-1),!,"Instructions to the provider:",!,"A prescription blank (VA FORM 10-2577f) must be used for All Class II NARCOTICS." - S (ELN,LN,LINE)="",$P(LN,"_",53)="",$P(LINE,"-",132)="" - W !,$E(LINE,1,$S('PSORM:80,1:IOM)-1),!?4,"OTHER MEDICATIONS:",! - Q -LM ;prints AP from listamn action - S X=$$SITE^VASITE,PSOINST=$P(X,"^",3) K X - K DIR S DIR("A")="Action or Informational (A or I): ",DIR("?",1)="Enter 'A' for action profile",DIR("?",2)=" 'I' for informational profile",DIR("?")=" 'E' to EXIT process",DIR("B")="A",DIR(0)="SAM^1:Action;0:Informational;E:Exit" - D ^DIR K DIR Q:Y="E"!($D(DIRUT)) S PSTYPE=Y,LM=1 - I '$P($G(PSOSYS),"^",6) S PSOPOL=0 G ASK - K DIR S DIR("A")="Do you want generate a Polypharmacy report?: ",DIR("?",1)="Enter 'Y' to generate report",DIR("?",2)=" 'N' if you do not want the report",DIR("?")=" 'E' to EXIT process",DIR("B")="NO",DIR(0)="SA^1:YES;0:NO;E:Exit" - D ^DIR S PSOPOL=$S(Y:1,1:0) G:Y="E"!($D(DIRUT)) EXIT G:'PSOPOL ASK - K DIR S DIR("A")="Minimum Number of Active Prescriptions",DIR("B")=7,DIR(0)="N^1:100:0" D ^DIR S PSONUM=Y G:$D(DIRUT) EXIT - K DIR,DTOUT,DIRUT,DUOUT S DIR("A")="Do you want this Profile to print in 132 columns or 80 columns: ",DIR("B")="132",DIR(0)="SAM^1:132;8:80;E:Exit" - D ^DIR G:Y="E"!($D(DUOUT))!($D(DIRUT)) EXIT S PSORM=$S(Y=1:1,1:0) K DIR,X,Y - ;PSO*7*240 Go to exit if DUOUT or DTOUT -ASK D DAYS G:($D(DUOUT))!($D(DTOUT)) EXIT S PRF=PSODFN_"," D DEV I $D(ZTSK) S VALMSG="Action Profile Queued to Printer." - D EXIT K LM - Q - ; -CHECKBAI ; - N PSOBADR - S PSOBADR=$$BADADR^DGUTL3(DFN) - I 'PSOBADR W " " Q - W ?40,"** BAD ADDRESS INDICATED **",! - Q - ; +PSOSD1 ;BHAM ISC/SAB/JMB - action or informational profile cont. ;11/18/92 + ;;7.0;OUTPATIENT PHARMACY;**2,17,19,22,40,49,66,107,110,132,233,258**;DEC 1997;Build 4 + ;External reference to ^PS(59.7 is supported by DBIA 694 + ; +INIT S PRF="" F PSOI=0:0 S DIC="^DPT(",DIC(0)="QEAM" D ^DIC Q:Y<0 D + .S PRF=PRF_+Y_",",DFN=+Y D DEM^VADPT I +VADM(6) W !,"Patient Expired on "_$P(VADM(6),"^",2),! S DOD(DFN)=$P(VADM(6),"^",2) K DFN + .I $L(PRF)>240 W !,$C(7),"MAX NUMBER OF PATIENTS HAS BEEN REACHED" Q + Q:'$L(PRF) D DAYS G:$D(DUOUT)!($D(DTOUT)) EXIT^PSOSD +DEV N PSOBARS,PSOBAR0,PSOBAR1 K %ZIS,IOP,ZTSK,ZTQUEUED S PSOION=ION,%ZIS="QM",%ZIS("B")="",%ZIS("A")=$S(PSTYPE:"Select a Printer: ",1:"DEVICE: ") D ^%ZIS K %ZIS I POP S IOP=PSOION D ^%ZIS K IOP,PSOION G EXIT + I $E(IOST)["C",PSTYPE D ^%ZISC W $C(7),!!,"Action Profiles MUST BE SENT TO A PRINTER !!",!,"ONLY INFORMATIONAL PROFILES ARE ALLOWED TO PRINT TO SCREEN !!",! G DEV + S PSOIOS=IOS D DEVBAR^PSOBMST S PSOBAR2=PSOBAR0,PSOBAR3=PSOBAR1 + S PSOBAR4=$G(PSOBAR3)]""&($G(PSOBAR2)]"")&(+$P($G(PSOPAR),"^")) + K PSOION I $D(IO("Q")) S ZTDESC="Outpatient Pharmacy Action Profile",ZTRTN="START^PSOSD1",ZTSAVE("ZTREQ")="@" D D EXIT Q:$G(LM) G ^PSOSD + .F G="PSORM","PSOPOL","PSONUM","PSOSYS","PSOINST","PSOBAR3","PSOBAR4","PSOBAR2","PSOPAR","PSOPAR7","PRF","PSDAYS","PSDATE","PSTYPE","PSOSITE","PSDATE","PSDAY" S:$D(@G) ZTSAVE(G)="" + .S ZTSAVE("DOD*")="",ZTSAVE("PSOBAR*")="" D ^%ZTLOAD W:$D(ZTSK) !,"Report Queued to Print !!",! K:'$G(LM) ZTSK,IO("Q") + D START G:'$G(LM) ^PSOSD + Q +START U IO S PSTYPE=$S($D(PSTYPE):PSTYPE,1:0),$P(LINE,"-",132)="-" + F PSIX=1:1 S DFN=$P(PRF,",",PSIX) G:DFN']"" EXIT D ELIG S PAGE=1 D G:$G(PSQFLG)!($D(DTOUT))!($D(DUOUT)) EXIT + .D PAT^PSOSD Q:$D(DTOUT)!($D(DUOUT)) D Q:PSQFLG D RXPAD:PSTYPE W:'$G(PSTYPE)&('$D(^TMP("PSOD",$J))) @IOF D ENSTUFF^PSODACT + ..Q:$D(DUOUT)!($D(DTOUT)) S PSQFLG=0 D ^PSOSD3,NVA^PSOSD3 +EXIT I '$D(PSONOPG) W ! D ^%ZISC K DFN + W:$D(PSONOPG)&('$D(ORVP)) @IOF + K ^TMP($J,"PRF"),^("ACT"),ADDR,ADDRFL,CLASS,CNDT,CNT,DRUG,CLAPP,HDFL,I,II,J,L,LINE,P,PAGE,PSDOB,PSIIX,PSNAME,PSOI,PSQFLG,PSSN,DFN,PSIX,PAGE,PGM,LINE,PRF,PSTYPE,PSDATE,PSDAYS,VAL,VAR,RX,RX0,RX3,RX2,ST,ST0,PSDAY,RF,RFS,PSOBAR3,PSOBAR4,PSOBAR2 + D KVA^VADPT K DOD,FILL,DIC,PSCNT,PSDT,PCLASS,PHYS,ZCLASS,PSOPRINT,RXNODE,DIR,X1,X2,PSONUM,PSOPOLP,PSSN4 + Q + ; +DAYS K DIR S DIR("A")="Profile Expiration/Discontinued Cutoff",DIR("B")=120,DIR(0)="N^0:9999:0",DIR("?",1)="Enter the number of days which will cut discontinued and expired Rx's from",DIR("?")="the profile." + D ^DIR Q:$D(DTOUT)!($D(DUOUT)) S PSDAYS=X K DIR S X1=DT,X2=-PSDAYS D C^%DTC S (PSDATE,PSDAY)=X + Q + ; +DFN S:'$D(PSORM) PSORM=1 + S PSOIOS=IOS D DEVBAR^PSOBMST S PSOBAR2=PSOBAR0,PSOBAR3=PSOBAR1 + S PSOBAR4=$G(PSOBAR3)]""&($G(PSOBAR2)]"")&(+$P($G(PSOPAR),"^")) + W:$D(PSONOPG)&($G(PSONOPG)'=2) @IOF I '$G(PSOSITE) S PSOSITE=$O(^PS(59,0)) + S PRF=DFN_"," D:'$G(PSDAYS) G START + .S PSDAYS=120,X1=DT,X2=-PSDAYS D C^%DTC S (PSDATE,PSDAY)=X + Q + ; +ELIG S PSOPRINT="" + D ELIG^VADPT + Q:'$D(VAEL(4)) + Q:+VAEL(4)'=1 + I $D(VAEL(3)),+VAEL(3)=1,($P(VAEL(3),"^",2)<50) S PSOPRINT="SC NSC" + D KVAR^VADPT + Q + ; +RXPAD N K Q:$G(DOD(DFN))]"" D HD F CNT=1:1:4 S LF="!?45" D Q:$Y+14>IOSL + .W !?4,"Name: "_PSNAME,?33,"ID#: "_PSSN4,?58,"DOB: "_PSDOB + .W !!,CNT,?4,"Medication: ",LN,$E(LN,1,11),!!?4,"Outpatient Directions: ",LN,!?4 + .W $E(LN,1,3),"SC",$E(LN,1,3),"NSC"," Quantity: _____ Days Supply _____ " + .W:'$G(PSORM) @LF W "Refills: 0 1 2 3 4 5 6 7 8 9 10 11" + .W !!?4,$E(LN,1,35)," ",$E(LN,1,14)," ",$E(LN,1,24) + .W !?4,"Provider's Signature",?40,"DEA #",?55,"Date/Time",!!,$E(LINE,1,$S('PSORM:80,1:IOM)) + K LF Q + ; +HD S FN=DFN S:'$D(PSORM) PSORM=1 + D ELIG^PSOSD1,DEM^VADPT,INP^VADPT,ADD^VADPT,PID^VADPT S PSSN=VA("PID"),PSSN4=VA("BID"),ADDRFL=$S(+VAPA(9):"Temporary ",1:"") + I +VADM(6) S DOD(DFN)=$P(VADM(6),"^",2) + S PSNAME=$E(VADM(1),1,28),PSDOB=$P(VADM(3),"^",2) I $D(IOF),$G(PAGE)'=1 W @IOF + W "Action Rx Profile",?47,"Run Date: " S Y=DT D DT^DIO2 W ?71,"Page: "_PAGE S PAGE=PAGE+1,X=$$SITE^VASITE + W !,"Sorted by drug classification for Rx's currently active"_$S('PSDAYS:" only.",1:"") W:PSDAYS !,"and for those Rx's that have been inactive less than "_PSDAYS_" days." + W @$S(PSORM:"?70",1:"!"),"Site: VAMC "_$P(X,"^",2)_" ("_$P(X,"^",3)_")",!,$E(LINE,1,$S('PSORM:80,1:IOM)-1) + I $P(VAIN(4),"^",2)]"",+$P($G(^PS(59.7,1,40.1)),"^") W !,"Outpatient prescriptions are discontinued 72 hours after admission.",! + W !?1,"Name : ",PSNAME,?30,"ID#: "_PSSN4 W ?58,"Action Date: ________" W !?1,"DOB : "_PSDOB + W:ADDRFL]"" ?30,ADDRFL,! W ?30,"Address :" + I $G(ADDRFL)="" D CHECKBAI + W ?41,VAPA(1) W:VAPA(2)]"" !?41,VAPA(2) W:VAPA(3)]"" !?41,VAPA(3) W !?41,VAPA(4)_", "_$P(VAPA(5),"^",2)_" "_$S(VAPA(11)]"":$P(VAPA(11),"^",2),1:VAPA(6)),!?30,"Phone : "_VAPA(8) + I PSOBAR4 S X="S",X2=PSSN W @$S('PSORM:"!?30",1:"?$X+5") S X1=$X W @PSOBAR3,X2,@PSOBAR2,$C(13) S $X=0 + S (WT,HT)="",X="GMRVUTL" X ^%ZOSF("TEST") I $T D + .F GMRVSTR="WT","HT" S VM=GMRVSTR D EN6^GMRVUTL S @VM=X,$P(@VM,"^")=$E($P(@VM,"^"),4,5)_"/"_$E($P(@VM,"^"),6,7)_"/"_($E($P(@VM,"^"),1,3)+1700) + .S X=$P(WT,"^",8),Y=$J(X/2.2,0,2),$P(WT,"^",9)=Y,X=$P(HT,"^",8),Y=$J(2.54*X,0,2),$P(HT,"^",9)=Y + W !!,"WEIGHT(Kg): " W:+$P(WT,"^",8) $P(WT,"^",9)_" ("_$P(WT,"^")_")" W ?41,"HEIGHT(cm): " W:$P(HT,"^",8) $P(HT,"^",9)_" ("_$P(HT,"^")_")" K VM,WT,HT + D GMRA^PSODEM W !,$E(LINE,1,$S('PSORM:80,1:IOM)-1),!,"Instructions to the provider:",!,"A prescription blank (VA FORM 10-2577f) must be used for All Class II NARCOTICS." + S (ELN,LN,LINE)="",$P(LN,"_",53)="",$P(LINE,"-",132)="" + W !,$E(LINE,1,$S('PSORM:80,1:IOM)-1),!?4,"OTHER MEDICATIONS:",! + Q +LM ;prints AP from listamn action + S X=$$SITE^VASITE,PSOINST=$P(X,"^",3) K X + K DIR S DIR("A")="Action or Informational (A or I): ",DIR("?",1)="Enter 'A' for action profile",DIR("?",2)=" 'I' for informational profile",DIR("?")=" 'E' to EXIT process",DIR("B")="A",DIR(0)="SAM^1:Action;0:Informational;E:Exit" + D ^DIR K DIR Q:Y="E"!($D(DIRUT)) S PSTYPE=Y,LM=1 + I '$P($G(PSOSYS),"^",6) S PSOPOL=0 G ASK + K DIR S DIR("A")="Do you want generate a Polypharmacy report?: ",DIR("?",1)="Enter 'Y' to generate report",DIR("?",2)=" 'N' if you do not want the report",DIR("?")=" 'E' to EXIT process",DIR("B")="NO",DIR(0)="SA^1:YES;0:NO;E:Exit" + D ^DIR S PSOPOL=$S(Y:1,1:0) G:Y="E"!($D(DIRUT)) EXIT G:'PSOPOL ASK + K DIR S DIR("A")="Minimum Number of Active Prescriptions",DIR("B")=7,DIR(0)="N^1:100:0" D ^DIR S PSONUM=Y G:$D(DIRUT) EXIT + K DIR,DTOUT,DIRUT,DUOUT S DIR("A")="Do you want this Profile to print in 132 columns or 80 columns: ",DIR("B")="132",DIR(0)="SAM^1:132;8:80;E:Exit" + D ^DIR G:Y="E"!($D(DUOUT))!($D(DIRUT)) EXIT S PSORM=$S(Y=1:1,1:0) K DIR,X,Y +ASK D DAYS S PRF=PSODFN_"," D DEV I $D(ZTSK) S VALMSG="Action Profile Queued to Printer." + D EXIT K LM + Q + ; +CHECKBAI ; + N PSOBADR + S PSOBADR=$$BADADR^DGUTL3(DFN) + I 'PSOBADR W " " Q + W ?40,"** BAD ADDRESS INDICATED **",! + Q + ; diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSIGMX.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSIGMX.m index 0c3c92a9..1c97e730 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSIGMX.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSIGMX.m @@ -1,51 +1,51 @@ -PSOSIGMX ;BIR/RTR-Utility routine to calculate Max Refills for CPRS ; 7/25/07 11:17am - ;;7.0;OUTPATIENT PHARMACY;**46,78,108,131,222,206**;DEC 1997;Build 39 - ;External reference to PS(55 supported by DBIA 2228 - ;External reference to PSDRUG( supported by DBIA 221 - ;External reference to YSCL(603.01 supported by DBIA 2697 - ;External reference to PS(50.7 supported by DBIA 2223 - ; - ;PSOQX("PATIENT")=patient DFN - ;PSOQX("DAYS SUPPLY")=Days Supply ->Optional ?? - ;PSOQX("DRUG")=File 50 ien ->Optional - ;PSOQX("ITEM")=File 50.7 ien -> we may not use this - ;PSOQX("DISCHARGE")=1 if the order is for a Discharge - ; - ;PSOQX("MAX")=Returned max refills allowed - ; -EN ; - S PSOQX("MAX")=11 - N DFN,VAROOT,PSOWRF,PSOMXAUT,PSOMXAUX,PSOCDEA,PSOCSX,PSOMXRX,PSOMX1,PSODYX,PSODYX1,PSOMXPAT,PSOMXSTA - S PSOMXAUT=0 - S PSOMXAUX=+$P($G(^PS(55,+$G(PSOQX("PATIENT")),"PS")),"^") - I PSOMXAUX,$P($G(^PS(53,+$G(PSOMXAUX),0)),"^")["AUTH ABS" S VAROOT="PSOWRF",DFN=$G(PSOQX("PATIENT")) D IN5^VADPT I '$G(PSOWRF(5)) S PSOMXAUT=1 - S PSOMXSTA=$S($G(PSOQX("DISCHARGE")):0,$G(PSOMXAUT):0,1:+$P($G(^PS(55,+$G(PSOQX("PATIENT")),"PS")),"^")) I PSOMXSTA S PSOMXRX=$P($G(^PS(53,PSOMXSTA,0)),"^",4) - I 'PSOMXSTA S PSOMXRX=11 - K PSOCDEA S PSOCSX=0 - S PSONODD=0 I '$G(PSOQX("DRUG")),$G(PSOQX("ITEM")) D S PSONODD=1 - . N A,B,PSOCDEA,DEA,PSOAPP,PSOINA,%,%H,%I,X,PSOFIRST - . S DEA=99,(A,PSOFIRST)="" - . F S A=$O(^PS(50.7,"A50",PSOQX("ITEM"),A)) Q:'A D - .. S PSOCDEA=$P($G(^PSDRUG(A,0)),"^",3),PSOAPP=$P($G(^(2)),"^",3),PSOINA=$G(^("I")) - .. I PSOAPP'["O" Q - .. D NOW^%DTC I PSOINA]"",PSOINA'>% Q - .. I PSOFIRST="" S PSOFIRST=A - .. I PSOCDEA?1N.E,PSOCDEAPSOQX("MAX"):PSOQX("MAX"),1:$G(PSOMXRX)),PSOQX("MAX")=$S(PSOMX1=5:PSOQX("MAX"),1:PSOMX1) - .S PSOQX("MAX")=$S('PSOQX("MAX"):0,$G(PSOQX("DAYS SUPPLY"))=90:1,1:PSOQX("MAX")),PSODYX=$G(PSOQX("DAYS SUPPLY")),PSODYX1=$S(PSODYX<60:5,PSODYX'<60&(PSODYX'>89):2,PSODYX=90:1,1:0) S PSOQX("MAX")=$S(PSOQX("MAX")'>PSODYX1:PSOQX("MAX"),1:PSODYX1) - I 'PSOCSX!('$G(PSOQX("DRUG"))) D - .S PSOQX("MAX")=11,PSOMX1=$S($G(PSOMXRX)>PSOQX("MAX"):PSOQX("MAX"),1:$G(PSOMXRX)),PSOQX("MAX")=$S(PSOMX1=11:PSOQX("MAX"),1:PSOMX1) - .S PSODYX=$G(PSOQX("DAYS SUPPLY")),PSODYX1=$S(PSODYX<60:11,PSODYX'<60&(PSODYX'>89):5,PSODYX=90:3,1:0) S PSOQX("MAX")=$S(PSOQX("MAX")'>PSODYX1:PSOQX("MAX"),1:PSODYX1) - I $P($G(^PSDRUG(+$G(PSOQX("DRUG")),"CLOZ1")),"^")="PSOCLO1" D Q - .S PSOMXPAT=$O(^YSCL(603.01,"C",+$G(PSOQX("PATIENT")),0)) I 'PSOMXPAT S PSOQX("MAX")=0 Q - .S PSOMXPAT=$P($G(^YSCL(603.01,PSOMXPAT,0)),"^",3) - .I $D(PSOQX("DAYS SUPPLY")) S PSOQX("MAX")=$S(PSOMXPAT="M"&($G(PSOQX("DAYS SUPPLY"))<8):3,PSOMXPAT="M"&($G(PSOQX("DAYS SUPPLY"))<15):1,PSOMXPAT="B"&($G(PSOQX("DAYS SUPPLY"))<8):1,1:0) Q - .S PSOQX("MAX")=$S(PSOMXPAT="M":3,PSOMXPAT="B":1,1:0) - I $G(PSOQX("DRUG")) I PSOCDEA["A"&(PSOCDEA'["B")!(PSOCDEA["F")!(PSOCDEA[1)!(PSOCDEA[2) S PSOQX("MAX")=0 - I PSONODD S PSOQX("DRUG")=0 - Q +PSOSIGMX ;BIR/RTR-Utility routine to calculate Max Refills for CPRS ;12/28/00 + ;;7.0;OUTPATIENT PHARMACY;**46,78,108,131,222**;DEC 1997;Build 12 + ;External reference to PS(55 supported by DBIA 2228 + ;External reference to PSDRUG( supported by DBIA 221 + ;External reference to YSCL(603.01 supported by DBIA 2697 + ;External reference to PS(50.7 supported by DBIA 2223 + ; + ;PSOQX("PATIENT")=patient DFN + ;PSOQX("DAYS SUPPLY")=Days Supply ->Optional ?? + ;PSOQX("DRUG")=File 50 ien ->Optional + ;PSOQX("ITEM")=File 50.7 ien -> we may not use this + ;PSOQX("DISCHARGE")=1 if the order is for a Discharge + ; + ;PSOQX("MAX")=Returned max refills allowed + ; +EN ; + S PSOQX("MAX")=11 + N DFN,VAROOT,PSOWRF,PSOMXAUT,PSOMXAUX,PSOCDEA,PSOCSX,PSOMXRX,PSOMX1,PSODYX,PSODYX1,PSOMXPAT,PSOMXSTA + S PSOMXAUT=0 + S PSOMXAUX=+$P($G(^PS(55,+$G(PSOQX("PATIENT")),"PS")),"^") + I PSOMXAUX,$P($G(^PS(53,+$G(PSOMXAUX),0)),"^")["AUTH ABS" S VAROOT="PSOWRF",DFN=$G(PSOQX("PATIENT")) D IN5^VADPT I '$G(PSOWRF(5)) S PSOMXAUT=1 + S PSOMXSTA=$S($G(PSOQX("DISCHARGE")):0,$G(PSOMXAUT):0,1:+$P($G(^PS(55,+$G(PSOQX("PATIENT")),"PS")),"^")) I PSOMXSTA S PSOMXRX=$P($G(^PS(53,PSOMXSTA,0)),"^",4) + I 'PSOMXSTA S PSOMXRX=11 + K PSOCDEA S PSOCSX=0 + S PSONODD=0 I '$G(PSOQX("DRUG")),$G(PSOQX("ITEM")) D S PSONODD=1 + . N A,B,PSOCDEA,DEA,PSOAPP,PSOINA,%,%H,%I,X,PSOFIRST + . S DEA=99,(A,PSOFIRST)="" + . F S A=$O(^PS(50.7,"A50",PSOQX("ITEM"),A)) Q:'A D + .. S PSOCDEA=$P($G(^PSDRUG(A,0)),"^",3),PSOAPP=$P($G(^(2)),"^",3),PSOINA=$G(^("I")) + .. I PSOAPP'["O" Q + .. D NOW^%DTC I PSOINA]"",PSOINA'>% Q + .. I PSOFIRST="" S PSOFIRST=A + .. I PSOCDEA?1N.E,PSOCDEAPSOQX("MAX"):PSOQX("MAX"),1:$G(PSOMXRX)),PSOQX("MAX")=$S(PSOMX1=5:PSOQX("MAX"),1:PSOMX1) + .S PSOQX("MAX")=$S('PSOQX("MAX"):0,$G(PSOQX("DAYS SUPPLY"))=90:1,1:PSOQX("MAX")),PSODYX=$G(PSOQX("DAYS SUPPLY")),PSODYX1=$S(PSODYX<60:5,PSODYX'<60&(PSODYX'>89):2,PSODYX=90:1,1:0) S PSOQX("MAX")=$S(PSOQX("MAX")'>PSODYX1:PSOQX("MAX"),1:PSODYX1) + I 'PSOCSX!('$G(PSOQX("DRUG"))) D + .S PSOQX("MAX")=11,PSOMX1=$S($G(PSOMXRX)>PSOQX("MAX"):PSOQX("MAX"),1:$G(PSOMXRX)),PSOQX("MAX")=$S(PSOMX1=11:PSOQX("MAX"),1:PSOMX1) + .S PSODYX=$G(PSOQX("DAYS SUPPLY")),PSODYX1=$S(PSODYX<60:11,PSODYX'<60&(PSODYX'>89):5,PSODYX=90:3,1:0) S PSOQX("MAX")=$S(PSOQX("MAX")'>PSODYX1:PSOQX("MAX"),1:PSODYX1) + I $P($G(^PSDRUG(+$G(PSOQX("DRUG")),"CLOZ1")),"^")="PSOCLO1" D Q + .S PSOMXPAT=$O(^YSCL(603.01,"C",+$G(PSOQX("PATIENT")),0)) I 'PSOMXPAT S PSOQX("MAX")=0 Q + .S PSOMXPAT=$P($G(^YSCL(603.01,PSOMXPAT,0)),"^",3) + .I $D(PSOQX("DAYS SUPPLY")) S PSOQX("MAX")=$S(PSOMXPAT="M"&($G(PSOQX("DAYS SUPPLY")))<8:3,PSOMXPAT="M"&($G(PSOQX("DAYS SUPPLY")))<15:1,PSOMXPAT="B"&($G(PSOQX("DAYS SUPPLY")))<8:1,1:0) Q + .S PSOQX("MAX")=$S(PSOMXPAT="M":3,PSOMXPAT="B":1,1:0) + I $G(PSOQX("DRUG")) I PSOCDEA["A"&(PSOCDEA'["B")!(PSOCDEA["F") S PSOQX("MAX")=0 + I PSONODD S PSOQX("DRUG")=0 + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSUPOE.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSUPOE.m index 36bfc3ca..2043c056 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSUPOE.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSUPOE.m @@ -1,125 +1,125 @@ -PSOSUPOE ;BIR/RTR - Suspense pull via Listman ;3/1/96 - ;;7.0;OUTPATIENT PHARMACY;**8,21,27,34,130,148,281**;DEC 1997;Build 41 - ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789 -SEL I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!" S VALMBCK="" Q - N PSOGETF,PSOGET,PSOGETFN,ORD,ORN,MW,PDUZ,PSLST,PSOSQ,PSOSQRTE,PSOSQMTH,PSPOP,PSOX1,PSOX2,RXLTOP,RXREC,SFN,SORD,SORN,VALMCNT - K DIR,DUOUT,DTOUT S DIR("A")="Select Orders by number",DIR(0)="LO^1:"_PSOCNT D ^DIR K DIR I $D(DTOUT)!($D(DUOUT))!('Y) S VALMSG="Nothing pulled from suspense!",VALMBCK="" Q - S PSLST=Y -SELQ D FULL^VALM1 - K DIR S DIR("A")="Select routing for Rx(s)",DIR(0)="S^M:MAIL;W:WINDOW",DIR("B")="WINDOW" D ^DIR K DIR I Y["^"!($D(DTOUT))!($D(DUOUT)) G END - S PSOSQRTE=Y I $G(PSOSQRTE)="W",$P(PSOPAR,"^",12) K DIR S DIR(0)="FO^2:60",DIR("A")="METHOD OF PICK-UP" D ^DIR S PSOSQMTH=$G(Y) K DIR I Y["^"!($D(DTOUT))!($D(DUOUT)) G END - W ! K DIR S DIR(0)="Y",DIR("A")="Pull Rx(s) and delete from suspense",DIR("B")="YES" D D ^DIR K DIR I Y'=1 G END - .S DIR("?",1)="Enter Yes to pull selected Rx(s) from suspense. Since(Rx(s) pulled early from",DIR("?",2)="suspense are not associated with a printed batch, these Rx(s) cannot be" - .S DIR("?",3)="reprinted from suspense using the 'Reprint batches from suspense' option.",DIR("?")="Therefore, any Rx(s) pulled early from suspense will be deleted from suspense." - Q:$G(PULLONE) - F SORD=1:1:$L(PSLST,",") Q:$P(PSLST,",",SORD)']"" S SORN=$P(PSLST,",",SORD) D:+PSOLST(SORN)=52 BEG - S VALMBCK="R" - I '$G(PSOSQ) S VALMSG="No Rx's pulled from suspense!" - Q -BEG ; - S RXREC=$P(PSOLST(SORN),"^",2) -BEGQ Q:'$D(^PSRX(+$G(RXREC),0)) - D PSOL^PSSLOCK(RXREC) I '$G(PSOMSG) W !!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing Rx "_$P($G(^PSRX(RXREC,0)),"^")),! K PSOMSG D DIR Q - K PSOMSG I $P($G(^PSRX(RXREC,"STA")),"^")'=5 W !!,"Rx# ",$P(^PSRX(RXREC,0),"^")," is not on Suspense!" D DIR,ULRX Q - S SFN=$O(^PS(52.5,"B",RXREC,0)) I 'SFN D DIR,ULRX Q - S PDUZ=DUZ I +$G(^PS(52.5,SFN,"P")) W !,">>> Rx #",$P(^PSRX(+$P(^(0),"^"),0),"^")," ALREADY PRINTED FROM SUSPENSE.",!,?5,"USE THE REPRINT OPTION TO REPRINT LABEL." D DIR,ULRX Q - I +$P($G(^PSRX(RXREC,2)),"^",6)>> Rx #",$P(^PSRX(+$P(^(0),"^"),0),"^")," ALREADY PRINTED FROM SUSPENSE.",!,?5,"USE THE REPRINT OPTION TO REPRINT LABEL." D DIR,ULRX Q + I +$P($G(^PSRX(RXREC,2)),"^",6)DT Q - ;Patient is active in the TPB File, and TPB Rx is being canceled - I PSOTPRC'=$P($G(^PSRX(PSOTPRCX,0)),"^",2) Q - N PSOTPCSS,PSOTCXFL,PSOTC1,PSOTC2,PSOTC3,X1,X2,DA,DR,DIE,X,Y - S PSOTCXFL=0 - S X1=DT,X2=-1 D C^%DTC S PSOTC3=X - F PSOTC1=PSOTC3:0 S PSOTC1=$O(^PS(55,PSOTPRC,"P","A",PSOTC1)) Q:'PSOTC1!(PSOTCXFL) S PSOTC2="" F S PSOTC2=$O(^PS(55,PSOTPRC,"P","A",PSOTC1,PSOTC2)) Q:PSOTC2=""!(PSOTCXFL) D - .I $P($G(^PSRX(PSOTC2,0)),"^",2)'=PSOTPRC Q - .S PSOTPCSS=$P($G(^PSRX(PSOTC2,"STA")),"^") - .I PSOTPCSS'=0,PSOTPCSS'=1,PSOTPCSS'=2,PSOTPCSS'=3,PSOTPCSS'=4,PSOTPCSS'=5,PSOTPCSS'=16 Q - .I $P($G(^PSRX(PSOTC2,"TPB")),"^"),$P($G(^(2)),"^",6)'
DT Q - ;Hard setting, to avoid DIE kiling any needed variables, no cross references on field, if added, need to use FileMan here - S $P(^PSRX(PSOX("IRXN"),"TPB"),"^")=1 - Q -MARKV ;Mark from Verify action - N PSOTPV1,PSOTPV2 - I '$G(PSONVLP) Q - I '$D(^PSRX(PSONVLP,0)) Q - I '$G(PSOTPBFG) Q - ;I $G(PSOFDR) Q - S PSOTPV1=$G(^PSRX(PSONVLP,0)) - I '$P(PSOTPV1,"^",2)!('$P(PSOTPV1,"^",3))!('$P(PSOTPV1,"^",4)) Q - S PSOTPV2=$P($G(^PS(53,+$P(PSOTPV1,"^",3),0)),"^") I $$UP^XLFSTR(PSOTPV2)'="NON-VA" Q - I '$P($G(^VA(200,+$P(PSOTPV1,"^",4),"TPB")),"^") Q - I $P($G(^VA(200,+$P(PSOTPV1,"^",4),"TPB")),"^",5)'=0 Q - I '$D(^PS(52.91,+$P(PSOTPV1,"^",2),0)) Q - I $P($G(^PS(52.91,+$P(PSOTPV1,"^",2),0)),"^",3),$P($G(^(0)),"^",3)'>DT Q - S $P(^PSRX(PSONVLP,"TPB"),"^")=1 - Q -RXPAT ;Sets Rx patient status to null - N PSOZZTRX - I $G(X),$G(X)'>DT D - .S PSOZZTRX=$P($G(^PS(53,+$P($G(^PS(55,DA,"PS")),"^"),0)),"^") S PSOZZTRX=$$UP^XLFSTR(PSOZZTRX) I PSOZZTRX="NON-VA" S $P(^PS(55,DA,"PS"),"^")="" - Q -SET(PSOTPPST) ;Pass in DFN on a hard set of INACTIVATION OF BENEFIT DATE - N PSOZXTRX - I $P($G(^PS(52.91,PSOTPPST,0)),"^",3),$P($G(^(0)),"^",3)'>DT S PSOZXTRX=$P($G(^PS(53,+$P($G(^PS(55,PSOTPPST,"PS")),"^"),0)),"^") I $$UP^XLFSTR(PSOZXTRX)="NON-VA" S $P(^PS(55,PSOTPPST,"PS"),"^")="" - Q -PCAP(PSOPAPPT) ;Find nearest Primary Care appointment - Q "TODAY AT NOON" - ; -PDIR(PSOTPEX) ; - Q:'$G(PSOTPEX) - N PSOTPEXS - S PSOTPEXT=0 - S PSOTPEXS=$P($G(^DPT(PSOTPEX,0)),"^",9) - W !!?10,$C(7),$P($G(^DPT(PSOTPEX,0)),"^")_" ("_$E(PSOTPEXS,1,3)_"-"_$E(PSOTPEXS,4,5)_"-"_$E(PSOTPEXS,6,9)_")" - W !?10,"Patient is eligible for the Transitional Pharmacy Benefit!!" - W ! K DIR S DIR(0)="E",DIR("A")="Press to continue, '^' to exit" D ^DIR K DIR I Y'=1 S PSOTPEXT=1 - Q -VOPN ; - I '$G(PSOTPPEN) Q - I '$D(^PSRX(PSOTPPEN,0)) Q - N PSOTPPE3,PSOTPPE4,PSOTPPE5,PSOTPPE6,PSOTPPE7,PSOTPPE8 - S PSOTPPE6=1 - S PSOTPPE3=$P($G(^PSRX(PSOTPPEN,0)),"^",3),PSOTPPE4=$P($G(^PSRX(PSOTPPEN,0)),"^",4) -VOPNX ; - I 'PSOTPPE4 S PSOTPPEX=1,PSOTPPE5(PSOTPPE6)="Unknown Provider!",PSOTPPE6=PSOTPPE6+1 - I 'PSOTPPE3 S PSOTPPEX=1 S PSOTPPE5(PSOTPPE6)="Unknown Patient Status!",PSOTPPE6=PSOTPPE6+1 - I PSOTPPE4,'$P($G(^VA(200,PSOTPPE4,"TPB")),"^") S PSOTPPE5(PSOTPPE6)="Provider is not flagged as a NON-VA PRESCRIBER!",PSOTPPE6=PSOTPPE6+1,PSOTPPEX=1 - I PSOTPPE4,$P($G(^VA(200,PSOTPPE4,"TPB")),"^",5)'=0 S PSOTPPE5(PSOTPPE6)="Provider is not flagged as not being on exclusionary list!",PSOTPPE6=PSOTPPE6+1,PSOTPPEX=1 - I PSOTPPE3 S PSOTPPE7=$P($G(^PS(53,PSOTPPE3,0)),"^") S PSOTPPE7=$$UP^XLFSTR(PSOTPPE7) I PSOTPPE7'="NON-VA" S PSOTPPE5(PSOTPPE6)="Rx Patient Status is not equal to 'NON-VA'!",PSOTPPE6=PSOTPPE6+1,PSOTPPEX=1 - I $G(PSOTPPEX) D I $G(PSOTPPE9) S VALMSG="Cannot Verify through this option" - .W ! F PSOTPPE8=0:0 S PSOTPPE8=$O(PSOTPPE5(PSOTPPE8)) Q:'PSOTPPE8 W !,$G(PSOTPPE5(PSOTPPE8)) - .K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR - Q -VOPNR ; - I '$G(PSOTPPEN) Q - I '$D(^PS(52.41,PSOTPPEN,0)) Q - N PSOTPPE3,PSOTPPE4,PSOTPPE5,PSOTPPE6,PSOTPPE7,PSOTPPE8 - S PSOTPPE6=1 - I $P(^PS(52.41,PSOTPPEN,0),"^",3)="RNW",$D(^PSRX(+$P(^PS(52.41,PSOTPPEN,0),"^",21),0)) S PSOTPPE3=$P($G(^PSRX(+$P(^PS(52.41,PSOTPPEN,0),"^",21),0)),"^",3) G NOREN - S PSOTPPE3=$P($G(^PS(55,+$P($G(^PS(52.41,PSOTPPEN,0)),"^",2),"PS")),"^") -NOREN ; - S PSOTPPE4=$P($G(^PS(52.41,PSOTPPEN,0)),"^",5) - G VOPNX - ; -DSPL(PSOTPWRN) ; - N DIR,PSOTPWR1,PSOTPWR2,PSOTPWR3 - I '$G(PSOTPWRN) Q - I '$D(^PS(52.41,PSOTPWRN,0)) Q - I $P(^PS(52.41,PSOTPWRN,0),"^",3)="RNW",$D(^PSRX(+$P(^PS(52.41,PSOTPWRN,0),"^",21),0)) D Q - . S PSOTPWR1=$P($G(^PSRX(+$P(^PS(52.41,PSOTPWRN,0),"^",21),0)),"^",3) - . S PSOTPWR2=$P($G(^PS(53,+PSOTPWR1,0)),"^"),PSOTPWR3=$$UP^XLFSTR(PSOTPWR2) - . I PSOTPWR3="NON-VA",DUZ("AG")="V" D ; Skip for VOE sites - . . K DIR W !!,"This order has an Rx Patient Status of 'NON-VA'!",! K DIR S DIR(0)="E",DIR("A")="Press return to continue" D ^DIR K DIR - . . Q - . Q - S PSOTPWR1=$P($G(^PS(55,+$P($G(^PS(52.41,PSOTPWRN,0)),"^",2),"PS")),"^") - S PSOTPWR2=$P($G(^PS(53,+PSOTPWR1,0)),"^") S PSOTPWR3=$$UP^XLFSTR(PSOTPWR2) - I PSOTPWR3="NON-VA",DUZ("AG")="V" D ; Skip for VOE sites - .W !!,"This order has an Rx Patient Status of 'NON-VA'!",! K DIR S DIR(0)="E",DIR("A")="Press return to continue" D ^DIR K DIR - Q -EXFLAG(PSOTPPX) ;Exit TPB RX option, reset TPG flag if necessary, - ;and possibly delete inactive date and reason code for patient in 52.91 - I '$G(DT) S DT=$$DT^XLFDT - I '$G(PSOTPPX) Q - I '$D(^PS(52.91,PSOTPPX,0)) Q - I $E($P(^PS(52.91,PSOTPPX,0),"^",3),1,7)'=DT Q - I $P(^PS(52.91,PSOTPPX,0),"^",4)'=6 Q - N DR,DIE,X1,X2,X,Y,DA,PSOTPPX1,PSOTPPX2,PSOTPPX3,PSOTPPX4,PSOTPPX5,PSOTPPX6,PSOTPPX7,PSOTPPX9 - S X1=DT,X2=-1 D C^%DTC S PSOTPPX1=X - S PSOTPPX9=0 - F PSOTPPX2=PSOTPPX1:0 S PSOTPPX2=$O(^PS(55,PSOTPPX,"P","A",PSOTPPX2)) Q:'PSOTPPX2 S PSOTPPX3="" F S PSOTPPX3=$O(^PS(55,PSOTPPX,"P","A",PSOTPPX2,PSOTPPX3)) Q:PSOTPPX3="" D - .I PSOTPPX'=$P($G(^PSRX(PSOTPPX3,0)),"^",2) Q - .I $P($G(^PSRX(PSOTPPX3,"TPB")),"^") Q - .I $E($P($G(^PSRX(PSOTPPX3,2)),"^"),1,7)'=DT Q - .S PSOTPPX4=$P($G(^PSRX(PSOTPPX3,"STA")),"^") I PSOTPPX4="" Q - .I PSOTPPX4'=0,PSOTPPX4'=1,PSOTPPX4'=2,PSOTPPX4'=3,PSOTPPX4'=4,PSOTPPX4'=5,PSOTPPX4'=16 Q - .S PSOTPPX5=$P(^PSRX(PSOTPPX3,0),"^",3),PSOTPPX6=$P(^(0),"^",4) - .I 'PSOTPPX5!('PSOTPPX6) Q - .S PSOTPPX7=$P($G(^PS(53,+PSOTPPX5,0)),"^") S PSOTPPX7=$$UP^XLFSTR(PSOTPPX7) I PSOTPPX7'="NON-VA" Q - .I '$P($G(^VA(200,PSOTPPX6,"TPB")),"^")!($P($G(^("TPB")),"^",5)'=0) Q - .S $P(^PSRX(PSOTPPX3,"TPB"),"^")=1,PSOTPPX9=1 - I PSOTPPX9 K DA,DIE,DR S DIE="^PS(52.91,",DA=PSOTPPX,DR="2////"_"@"_";3////"_"@" D ^DIE K DIE,DA,DR - Q - ; -SCH ;DBIA to return TPB patients to Scheduling - N PSOSCT,PSOSCTD - K ^TMP($J,"PSODFN") - F PSOSCT=0:0 S PSOSCT=$O(^PS(52.91,PSOSCT)) Q:'PSOSCT I PSOSCT=$P($G(^(PSOSCT,0)),"^") D - .S PSOSCTD=$P($G(^PS(52.91,PSOSCT,0)),"^",3) - .I 'PSOSCTD!(PSOSCTD>DT) D - ..I $P($G(^DPT(PSOSCT,0)),"^")="" Q - ..S ^TMP($J,"PSODFN",$P($G(^DPT(PSOSCT,0)),"^"),PSOSCT)="" - Q +PSOTPCAN ;BIR/RTR - TPB Utility routine ;3/13/07 21:21 + ;;7.0;OUTPATIENT PHARMACY;**146,153,163,227,208**;DEC 1997;Build 39 + ; 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 + ;External reference to PS(55 supported by DBIA 2228 + ;External reference to VA(200 supported by DBIA 224 + ; + ;Check Rx being DC'd, if it's a TPB Rx, check to inactivate patient + ;Called from all DC actions +CAN(PSOTPRCX) ; + Q ; placed out of order by PSO*7*227 + I '$G(PSOTPRCX) Q + N PSOTPRC + S PSOTPRC=$P($G(^PSRX(PSOTPRCX,0)),"^",2) + I '$G(PSOTPRC) Q + I '$P($G(^PSRX(PSOTPRCX,"TPB")),"^") Q + I '$D(^PS(52.91,PSOTPRC,0)) Q + I $P($G(^PS(52.91,PSOTPRC,0)),"^",3),$P($G(^(0)),"^",3)'>DT Q + ;Patient is active in the TPB File, and TPB Rx is being canceled + I PSOTPRC'=$P($G(^PSRX(PSOTPRCX,0)),"^",2) Q + N PSOTPCSS,PSOTCXFL,PSOTC1,PSOTC2,PSOTC3,X1,X2,DA,DR,DIE,X,Y + S PSOTCXFL=0 + S X1=DT,X2=-1 D C^%DTC S PSOTC3=X + F PSOTC1=PSOTC3:0 S PSOTC1=$O(^PS(55,PSOTPRC,"P","A",PSOTC1)) Q:'PSOTC1!(PSOTCXFL) S PSOTC2="" F S PSOTC2=$O(^PS(55,PSOTPRC,"P","A",PSOTC1,PSOTC2)) Q:PSOTC2=""!(PSOTCXFL) D + .I $P($G(^PSRX(PSOTC2,0)),"^",2)'=PSOTPRC Q + .S PSOTPCSS=$P($G(^PSRX(PSOTC2,"STA")),"^") + .I PSOTPCSS'=0,PSOTPCSS'=1,PSOTPCSS'=2,PSOTPCSS'=3,PSOTPCSS'=4,PSOTPCSS'=5,PSOTPCSS'=16 Q + .I $P($G(^PSRX(PSOTC2,"TPB")),"^"),$P($G(^(2)),"^",6)'
DT Q + ;Hard setting, to avoid DIE kiling any needed variables, no cross references on field, if added, need to use FileMan here + S $P(^PSRX(PSOX("IRXN"),"TPB"),"^")=1 + Q +MARKV ;Mark from Verify action + N PSOTPV1,PSOTPV2 + I '$G(PSONVLP) Q + I '$D(^PSRX(PSONVLP,0)) Q + I '$G(PSOTPBFG) Q + ;I $G(PSOFDR) Q + S PSOTPV1=$G(^PSRX(PSONVLP,0)) + I '$P(PSOTPV1,"^",2)!('$P(PSOTPV1,"^",3))!('$P(PSOTPV1,"^",4)) Q + S PSOTPV2=$P($G(^PS(53,+$P(PSOTPV1,"^",3),0)),"^") I $$UP^XLFSTR(PSOTPV2)'="NON-VA" Q + I '$P($G(^VA(200,+$P(PSOTPV1,"^",4),"TPB")),"^") Q + I $P($G(^VA(200,+$P(PSOTPV1,"^",4),"TPB")),"^",5)'=0 Q + I '$D(^PS(52.91,+$P(PSOTPV1,"^",2),0)) Q + I $P($G(^PS(52.91,+$P(PSOTPV1,"^",2),0)),"^",3),$P($G(^(0)),"^",3)'>DT Q + S $P(^PSRX(PSONVLP,"TPB"),"^")=1 + Q +RXPAT ;Sets Rx patient status to null + N PSOZZTRX + I $G(X),$G(X)'>DT D + .S PSOZZTRX=$P($G(^PS(53,+$P($G(^PS(55,DA,"PS")),"^"),0)),"^") S PSOZZTRX=$$UP^XLFSTR(PSOZZTRX) I PSOZZTRX="NON-VA" S $P(^PS(55,DA,"PS"),"^")="" + Q +SET(PSOTPPST) ;Pass in DFN on a hard set of INACTIVATION OF BENEFIT DATE + N PSOZXTRX + I $P($G(^PS(52.91,PSOTPPST,0)),"^",3),$P($G(^(0)),"^",3)'>DT S PSOZXTRX=$P($G(^PS(53,+$P($G(^PS(55,PSOTPPST,"PS")),"^"),0)),"^") I $$UP^XLFSTR(PSOZXTRX)="NON-VA" S $P(^PS(55,PSOTPPST,"PS"),"^")="" + Q +PCAP(PSOPAPPT) ;Find nearest Primary Care appointment + Q "TODAY AT NOON" + ; +PDIR(PSOTPEX) ; + Q:'$G(PSOTPEX) + N PSOTPEXS + S PSOTPEXT=0 + S PSOTPEXS=$P($G(^DPT(PSOTPEX,0)),"^",9) + W !!?10,$C(7),$P($G(^DPT(PSOTPEX,0)),"^")_" ("_$E(PSOTPEXS,1,3)_"-"_$E(PSOTPEXS,4,5)_"-"_$E(PSOTPEXS,6,9)_")" + W !?10,"Patient is eligible for the Transitional Pharmacy Benefit!!" + W ! K DIR S DIR(0)="E",DIR("A")="Press to continue, '^' to exit" D ^DIR K DIR I Y'=1 S PSOTPEXT=1 + Q +VOPN ; + I '$G(PSOTPPEN) Q + I '$D(^PSRX(PSOTPPEN,0)) Q + N PSOTPPE3,PSOTPPE4,PSOTPPE5,PSOTPPE6,PSOTPPE7,PSOTPPE8 + S PSOTPPE6=1 + S PSOTPPE3=$P($G(^PSRX(PSOTPPEN,0)),"^",3),PSOTPPE4=$P($G(^PSRX(PSOTPPEN,0)),"^",4) +VOPNX ; + I 'PSOTPPE4 S PSOTPPEX=1,PSOTPPE5(PSOTPPE6)="Unknown Provider!",PSOTPPE6=PSOTPPE6+1 + I 'PSOTPPE3 S PSOTPPEX=1 S PSOTPPE5(PSOTPPE6)="Unknown Patient Status!",PSOTPPE6=PSOTPPE6+1 + I PSOTPPE4,'$P($G(^VA(200,PSOTPPE4,"TPB")),"^") S PSOTPPE5(PSOTPPE6)="Provider is not flagged as a NON-VA PRESCRIBER!",PSOTPPE6=PSOTPPE6+1,PSOTPPEX=1 + I PSOTPPE4,$P($G(^VA(200,PSOTPPE4,"TPB")),"^",5)'=0 S PSOTPPE5(PSOTPPE6)="Provider is not flagged as not being on exclusionary list!",PSOTPPE6=PSOTPPE6+1,PSOTPPEX=1 + I PSOTPPE3 S PSOTPPE7=$P($G(^PS(53,PSOTPPE3,0)),"^") S PSOTPPE7=$$UP^XLFSTR(PSOTPPE7) I PSOTPPE7'="NON-VA" S PSOTPPE5(PSOTPPE6)="Rx Patient Status is not equal to 'NON-VA'!",PSOTPPE6=PSOTPPE6+1,PSOTPPEX=1 + I $G(PSOTPPEX) D I $G(PSOTPPE9) S VALMSG="Cannot Verify through this option" + .W ! F PSOTPPE8=0:0 S PSOTPPE8=$O(PSOTPPE5(PSOTPPE8)) Q:'PSOTPPE8 W !,$G(PSOTPPE5(PSOTPPE8)) + .K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR + Q +VOPNR ; + I '$G(PSOTPPEN) Q + I '$D(^PS(52.41,PSOTPPEN,0)) Q + N PSOTPPE3,PSOTPPE4,PSOTPPE5,PSOTPPE6,PSOTPPE7,PSOTPPE8 + S PSOTPPE6=1 + I $P(^PS(52.41,PSOTPPEN,0),"^",3)="RNW",$D(^PSRX(+$P(^PS(52.41,PSOTPPEN,0),"^",21),0)) S PSOTPPE3=$P($G(^PSRX(+$P(^PS(52.41,PSOTPPEN,0),"^",21),0)),"^",3) G NOREN + S PSOTPPE3=$P($G(^PS(55,+$P($G(^PS(52.41,PSOTPPEN,0)),"^",2),"PS")),"^") +NOREN ; + S PSOTPPE4=$P($G(^PS(52.41,PSOTPPEN,0)),"^",5) + G VOPNX + ; +DSPL(PSOTPWRN) ; + N DIR,PSOTPWR1,PSOTPWR2,PSOTPWR3 + I '$G(PSOTPWRN) Q + I '$D(^PS(52.41,PSOTPWRN,0)) Q + I $P(^PS(52.41,PSOTPWRN,0),"^",3)="RNW",$D(^PSRX(+$P(^PS(52.41,PSOTPWRN,0),"^",21),0)) D Q + . S PSOTPWR1=$P($G(^PSRX(+$P(^PS(52.41,PSOTPWRN,0),"^",21),0)),"^",3) + . S PSOTPWR2=$P($G(^PS(53,+PSOTPWR1,0)),"^"),PSOTPWR3=$$UP^XLFSTR(PSOTPWR2) + . I PSOTPWR3="NON-VA",DUZ("AG")="V" D ; Skip for VOE sites + . . K DIR W !!,"This order has an Rx Patient Status of 'NON-VA'!",! K DIR S DIR(0)="E",DIR("A")="Press return to continue" D ^DIR K DIR + . . Q + . Q + S PSOTPWR1=$P($G(^PS(55,+$P($G(^PS(52.41,PSOTPWRN,0)),"^",2),"PS")),"^") + S PSOTPWR2=$P($G(^PS(53,+PSOTPWR1,0)),"^") S PSOTPWR3=$$UP^XLFSTR(PSOTPWR2) + I PSOTPWR3="NON-VA",DUZ("AG")="V" D ; Skip for VOE sites + .W !!,"This order has an Rx Patient Status of 'NON-VA'!",! K DIR S DIR(0)="E",DIR("A")="Press return to continue" D ^DIR K DIR + Q +EXFLAG(PSOTPPX) ;Exit TPB RX option, reset TPG flag if necessary, + ;and possibly delete inactive date and reason code for patient in 52.91 + I '$G(DT) S DT=$$DT^XLFDT + I '$G(PSOTPPX) Q + I '$D(^PS(52.91,PSOTPPX,0)) Q + I $E($P(^PS(52.91,PSOTPPX,0),"^",3),1,7)'=DT Q + I $P(^PS(52.91,PSOTPPX,0),"^",4)'=6 Q + N DR,DIE,X1,X2,X,Y,DA,PSOTPPX1,PSOTPPX2,PSOTPPX3,PSOTPPX4,PSOTPPX5,PSOTPPX6,PSOTPPX7,PSOTPPX9 + S X1=DT,X2=-1 D C^%DTC S PSOTPPX1=X + S PSOTPPX9=0 + F PSOTPPX2=PSOTPPX1:0 S PSOTPPX2=$O(^PS(55,PSOTPPX,"P","A",PSOTPPX2)) Q:'PSOTPPX2 S PSOTPPX3="" F S PSOTPPX3=$O(^PS(55,PSOTPPX,"P","A",PSOTPPX2,PSOTPPX3)) Q:PSOTPPX3="" D + .I PSOTPPX'=$P($G(^PSRX(PSOTPPX3,0)),"^",2) Q + .I $P($G(^PSRX(PSOTPPX3,"TPB")),"^") Q + .I $E($P($G(^PSRX(PSOTPPX3,2)),"^"),1,7)'=DT Q + .S PSOTPPX4=$P($G(^PSRX(PSOTPPX3,"STA")),"^") I PSOTPPX4="" Q + .I PSOTPPX4'=0,PSOTPPX4'=1,PSOTPPX4'=2,PSOTPPX4'=3,PSOTPPX4'=4,PSOTPPX4'=5,PSOTPPX4'=16 Q + .S PSOTPPX5=$P(^PSRX(PSOTPPX3,0),"^",3),PSOTPPX6=$P(^(0),"^",4) + .I 'PSOTPPX5!('PSOTPPX6) Q + .S PSOTPPX7=$P($G(^PS(53,+PSOTPPX5,0)),"^") S PSOTPPX7=$$UP^XLFSTR(PSOTPPX7) I PSOTPPX7'="NON-VA" Q + .I '$P($G(^VA(200,PSOTPPX6,"TPB")),"^")!($P($G(^("TPB")),"^",5)'=0) Q + .S $P(^PSRX(PSOTPPX3,"TPB"),"^")=1,PSOTPPX9=1 + I PSOTPPX9 K DA,DIE,DR S DIE="^PS(52.91,",DA=PSOTPPX,DR="2////"_"@"_";3////"_"@" D ^DIE K DIE,DA,DR + Q + ; +SCH ;DBIA to return TPB patients to Scheduling + N PSOSCT,PSOSCTD + K ^TMP($J,"PSODFN") + F PSOSCT=0:0 S PSOSCT=$O(^PS(52.91,PSOSCT)) Q:'PSOSCT I PSOSCT=$P($G(^(PSOSCT,0)),"^") D + .S PSOSCTD=$P($G(^PS(52.91,PSOSCT,0)),"^",3) + .I 'PSOSCTD!(PSOSCTD>DT) D + ..I $P($G(^DPT(PSOSCT,0)),"^")="" Q + ..S ^TMP($J,"PSODFN",$P($G(^DPT(PSOSCT,0)),"^"),PSOSCT)="" + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOUTLA1.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOUTLA1.m index b69ef202..cc1e5131 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOUTLA1.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOUTLA1.m @@ -1,186 +1,186 @@ -PSOUTLA1 ;BHAM ISC/RTR-Pharmacy utility program cont. ;5/22/07 10:01am - ;;7.0;OUTPATIENT PHARMACY;**35,186,218,259,206**;DEC 1997;Build 39 - ;External reference to File ^PS(55 supported by DBIA 2228 - ;External reference to File ^PSDRUG supported by DBIA 221 - ;External reference to File ^PS(59.7 supported by DBIA 694 - ;External reference to File ^PS(51 supported by DBIA 2224 - ; - ;*186 - add DEACHK function - ;*218 - add REFIP function - ;*259 - reverse *218 delete restriction only warn of deleting - ; also add del of last refill only - ; -EN1 ;Formats condensed, back door sig in BSIG array - ;pass in 1) Internal Rx from 52 - ; 2) max length of BSIG array - ;Returned, still condensed, in BSIG array, when looping through, check for array=null, if so, juist don't print it -EN2(PSOBINTR,PSOBLGTH) ; - K BSIG - N BBSIG,BVAR,BVAR1,III,CNT,NNN,BLIM - S BBSIG=$P($G(^PSRX(PSOBINTR,"SIG")),"^") Q:BBSIG=""!($P($G(^("SIG")),"^",2)) - S (BVAR,BVAR1)="",III=1 - S CNT=0 F NNN=1:1:$L(BBSIG) I $E(BBSIG,NNN)=" "!($L(BBSIG)=NNN) S CNT=CNT+1 D I $L(BVAR)>PSOBLGTH S BSIG(III)=BLIM_" ",III=III+1,BVAR=BVAR1 - .S BVAR1=$P(BBSIG," ",(CNT)) - .S BLIM=BVAR - .S BVAR=$S(BVAR="":BVAR1,1:BVAR_" "_BVAR1) - I $G(BVAR)'="" S BSIG(III)=BVAR - I $G(BSIG(1))=""!($G(BSIG(1))=" ") S BSIG(1)=$G(BSIG(2)) K BSIG(2) - Q - ; -EN3(PSOBINTR,PSOBLGTH) ; - ;Pass in to EN3 the internal Rx number from 52, and the length of - ;the array you want. Returns expanded Sig, or warning from PSOHELP - ;concantenated with the condensed Sig in the BSIG array - ;BACK DOOR ONLY - K BSIG,X N BBSIG,BVAR,BVAR1,III,CNT,NNN,BLIM,Y,SIG,Z0,Z1,BBWARN - S BBSIG=$P($G(^PSRX(PSOBINTR,"SIG")),"^") Q:BBSIG=""!($P($G(^("SIG")),"^",2)) - S (SIG,X)=BBSIG - I $E(BBSIG)=" " S BBWARN="Leading spaces are not allowed in the SIG!" G START - S SIG="" Q:$L(X)<1 F Z0=1:1:$L(X," ") G:Z0="" START S Z1=$P(X," ",Z0) D G:'$D(X) START - .I $L(Z1)>32 S BBWARN="MAX OF 32 CHARACTERS ALLOWED BETWEEN SPACES!" K X Q - .D:$D(X)&($G(Z1)]"") S SIG=SIG_" "_Z1 - ..S Y=$O(^PS(51,"B",Z1,0)) Q:'Y!($P($G(^PS(51,+Y,0)),"^",4)>1) S Z1=$P(^PS(51,Y,0),"^",2) Q:'$D(^(9)) S Y=$P(X," ",Z0-1),Y=$E(Y,$L(Y)) S:Y>1 Z1=^(9) -START ; - S BBSIG=$S($G(BBWARN)="":SIG,1:BBWARN_" "_BBSIG) - S (BVAR,BVAR1)="",III=1 - S CNT=0 F NNN=1:1:$L(BBSIG) I $E(BBSIG,NNN)=" "!($L(BBSIG)=NNN) S CNT=CNT+1 D I $L(BVAR)>PSOBLGTH S BSIG(III)=BLIM_" ",III=III+1,BVAR=BVAR1 - .S BVAR1=$P(BBSIG," ",(CNT)) - .S BLIM=BVAR - .S BVAR=$S(BVAR="":BVAR1,1:BVAR_" "_BVAR1) - I $G(BVAR)'="" S BSIG(III)=BVAR - I $G(BSIG(1))=""!($G(BSIG(1))=" ") S BSIG(1)=$G(BSIG(2)) K BSIG(2) - Q -PATCH ;Allow sites to backfill more than what was done at install - N PSOBACKL,PSOBACKI,PSOBACKS,PSOBACKB,PSOBACKD,PSOBACKA - S PSOBACKL=$O(^PS(59.7,0)),PSOBACKI=$E($P($G(^PS(59.7,+$G(PSOBACKL),49.99)),"^",7),1,7) - I '$G(PSOBACKI) S PSOBACKI=$P($G(^PS(59.7,+$G(PSOBACKL),49.99)),"^",4) - I $G(PSOBACKI) S Y=PSOBACKI D DD^%DT S PSOBACKS=Y S X1=PSOBACKI,X2=-120 D C^%DTC S (Y,PSOBACKB)=X D DD^%DT S PSOBACKD=Y - I $G(PSOBACKD)'="" W !!,"Your CPRS/Outpatient installation date is "_$G(PSOBACKS)_","_" which",!,"means we have already backfilled all active prescriptions and all",!,"prescriptions canceled or expired after "_$G(PSOBACKD)_"." - I W !!,"If you want to backfill orders that were canceled or expired prior to this",!,"date of "_$G(PSOBACKD)_", enter an earlier date and those orders",!,"will be backfilled to CPRS.",! - I $G(PSOBACKD)="" W !!,"We cannot determine the date of the CPRS/Outpatient installation.",! - W !,"If you choose to backfill more orders to CPRS by utilizing this option,",!,"we remind you that disk storage can be significantly affected, depending on",!,"how many orders are backfilled.",! - K DIR S DIR(0)="Y",DIR("B")="N",DIR("A")="Do you want to backfill more prescriptions",DIR("?")="Enter Yes to backfill prescriptions canceled or expired before "_$G(PSOBACKD) D ^DIR K DIR I Y'=1 W ! G PATCHQ - W ! S %DT="AEPX",%DT("A")="Enter Date to begin backfill: " S:$G(PSOBACKB) %DT(0)=-PSOBACKB D ^%DT G:Y<0!($D(DTOUT)) PATCHQ S PSOBACKA=$E(Y,1,7) - W ! K ZTDTH S ZTSAVE("PSOBACKB")="",ZTSAVE("PSOBACKA")="",ZTRTN="PATCHR^PSOUTLA1",ZTDESC="BACKFILL PRSCRIPTIONS TO CPRS",ZTIO="" D ^%ZTLOAD W ! G PATCHQ -PATCHR ;Begin task - N PSOPAL,PSOLPD,PSOLPRX - S PSOBACKA=PSOBACKA-.01 - I '$G(PSOBACKB) S PSOBACKB=DT - F PSOPAL=0:0 S PSOPAL=$O(^PS(55,PSOPAL)) Q:'PSOPAL F PSOLPD=PSOBACKA:0 S PSOLPD=$O(^PS(55,PSOPAL,"P","A",PSOLPD)) Q:'PSOLPD!(PSOLPD>PSOBACKB) F PSOLPRX=0:0 S PSOLPRX=$O(^PS(55,PSOPAL,"P","A",PSOLPD,PSOLPRX)) Q:'PSOLPRX D - .I $P($G(^PSRX(PSOLPRX,0)),"^")=""!('$P($G(^(0)),"^",2))!('$P($G(^(0)),"^",6)) Q - .I $P($G(^PSRX(PSOLPRX,"OR1")),"^",2) Q - .I '$P($G(^PSRX(PSOLPRX,0)),"^",19) D - ..I $P($G(^PSRX(PSOLPRX,"OR1")),"^")="",+$G(^PSDRUG(+$P($G(^PSRX(PSOLPRX,0)),"^",6),2)) S $P(^PSRX(PSOLPRX,"OR1"),"^")=+$G(^PSDRUG(+$P($G(^PSRX(PSOLPRX,0)),"^",6),2)) - ..I $P($G(^PSRX(PSOLPRX,0)),"^",10)'="",$G(^PSRX(PSOLPRX,"SIG"))']"",'$O(^PSRX(PSOLPRX,"SIG1",0)) S ^PSRX(PSOLPRX,"SIG")=$P($G(^PSRX(PSOLPRX,0)),"^",10)_"^"_0 S $P(^PSRX(PSOLPRX,0),"^",10)="" - ..I $P($G(^PSRX(PSOLPRX,"STA")),"^")="",$P($G(^PSRX(PSOLPRX,0)),"^",15)'="" S $P(^PSRX(PSOLPRX,"STA"),"^")=$P($G(^PSRX(PSOLPRX,0)),"^",15) S $P(^PSRX(PSOLPRX,0),"^",15)="" - ..S $P(^PSRX(PSOLPRX,0),"^",19)=1 - .S PSOLPSTA=$P($G(^PSRX(PSOLPRX,"STA")),"^") Q:PSOLPSTA=""!(PSOLPSTA=13)!(PSOLPSTA=10) - .D EN^PSOHLSN1(PSOLPRX,"ZC","") - .I PSOLPSTA'="",PSOLPSTA<10 D - ..I +$P($G(^PSRX(PSOLPRX,2)),"^",6),+$P($G(^(2)),"^",6)
1,$E(+PSDEA,QQ)<6 D - . S PSOCS=1 - . S:$E(+PSDEA,QQ)=2 $P(PSOCS,"^",2)=1 - ; - ;no refills allowed on sched 2 - I $P(PSOCS,"^",2)=1 S PSMAXRF=$$NUMFILLS(PSIRXN) Q 1 - ; - ;set max refill for controlled substance & other based on days supply - S PSDAYS=+$G(PSDAYS) - I PSOCS D - . S PSMAXRF=$S(PSDAYS<60:5,PSDAYS'<60&(PSDAYS'>89):2,PSDAYS=90:1,1:0) - E D - . S PSMAXRF=$S(PSDAYS<60:11,PSDAYS'<60&(PSDAYS'>89):5,PSDAYS=90:3,1:0) - ; - ;get number of fills if applies & compare to Max refills - N PNFILLS S PNFILLS=$$NUMFILLS(PSIRXN) - I PNFILLS'PSOBLGTH S BSIG(III)=BLIM_" ",III=III+1,BVAR=BVAR1 + .S BVAR1=$P(BBSIG," ",(CNT)) + .S BLIM=BVAR + .S BVAR=$S(BVAR="":BVAR1,1:BVAR_" "_BVAR1) + I $G(BVAR)'="" S BSIG(III)=BVAR + I $G(BSIG(1))=""!($G(BSIG(1))=" ") S BSIG(1)=$G(BSIG(2)) K BSIG(2) + Q + ; +EN3(PSOBINTR,PSOBLGTH) ; + ;Pass in to EN3 the internal Rx number from 52, and the length of + ;the array you want. Returns expanded Sig, or warning from PSOHELP + ;concantenated with the condensed Sig in the BSIG array + ;BACK DOOR ONLY + K BSIG,X N BBSIG,BVAR,BVAR1,III,CNT,NNN,BLIM,Y,SIG,Z0,Z1,BBWARN + S BBSIG=$P($G(^PSRX(PSOBINTR,"SIG")),"^") Q:BBSIG=""!($P($G(^("SIG")),"^",2)) + S (SIG,X)=BBSIG + I $E(BBSIG)=" " S BBWARN="Leading spaces are not allowed in the SIG!" G START + S SIG="" Q:$L(X)<1 F Z0=1:1:$L(X," ") G:Z0="" START S Z1=$P(X," ",Z0) D G:'$D(X) START + .I $L(Z1)>32 S BBWARN="MAX OF 32 CHARACTERS ALLOWED BETWEEN SPACES!" K X Q + .D:$D(X)&($G(Z1)]"") S SIG=SIG_" "_Z1 + ..S Y=$O(^PS(51,"B",Z1,0)) Q:'Y!($P($G(^PS(51,+Y,0)),"^",4)>1) S Z1=$P(^PS(51,Y,0),"^",2) Q:'$D(^(9)) S Y=$P(X," ",Z0-1),Y=$E(Y,$L(Y)) S:Y>1 Z1=^(9) +START ; + S BBSIG=$S($G(BBWARN)="":SIG,1:BBWARN_" "_BBSIG) + S (BVAR,BVAR1)="",III=1 + S CNT=0 F NNN=1:1:$L(BBSIG) I $E(BBSIG,NNN)=" "!($L(BBSIG)=NNN) S CNT=CNT+1 D I $L(BVAR)>PSOBLGTH S BSIG(III)=BLIM_" ",III=III+1,BVAR=BVAR1 + .S BVAR1=$P(BBSIG," ",(CNT)) + .S BLIM=BVAR + .S BVAR=$S(BVAR="":BVAR1,1:BVAR_" "_BVAR1) + I $G(BVAR)'="" S BSIG(III)=BVAR + I $G(BSIG(1))=""!($G(BSIG(1))=" ") S BSIG(1)=$G(BSIG(2)) K BSIG(2) + Q +PATCH ;Allow sites to backfill more than what was done at install + N PSOBACKL,PSOBACKI,PSOBACKS,PSOBACKB,PSOBACKD,PSOBACKA + S PSOBACKL=$O(^PS(59.7,0)),PSOBACKI=$E($P($G(^PS(59.7,+$G(PSOBACKL),49.99)),"^",7),1,7) + I '$G(PSOBACKI) S PSOBACKI=$P($G(^PS(59.7,+$G(PSOBACKL),49.99)),"^",4) + I $G(PSOBACKI) S Y=PSOBACKI D DD^%DT S PSOBACKS=Y S X1=PSOBACKI,X2=-120 D C^%DTC S (Y,PSOBACKB)=X D DD^%DT S PSOBACKD=Y + I $G(PSOBACKD)'="" W !!,"Your CPRS/Outpatient installation date is "_$G(PSOBACKS)_","_" which",!,"means we have already backfilled all active prescriptions and all",!,"prescriptions canceled or expired after "_$G(PSOBACKD)_"." + I W !!,"If you want to backfill orders that were canceled or expired prior to this",!,"date of "_$G(PSOBACKD)_", enter an earlier date and those orders",!,"will be backfilled to CPRS.",! + I $G(PSOBACKD)="" W !!,"We cannot determine the date of the CPRS/Outpatient installation.",! + W !,"If you choose to backfill more orders to CPRS by utilizing this option,",!,"we remind you that disk storage can be significantly affected, depending on",!,"how many orders are backfilled.",! + K DIR S DIR(0)="Y",DIR("B")="N",DIR("A")="Do you want to backfill more prescriptions",DIR("?")="Enter Yes to backfill prescriptions canceled or expired before "_$G(PSOBACKD) D ^DIR K DIR I Y'=1 W ! G PATCHQ + W ! S %DT="AEPX",%DT("A")="Enter Date to begin backfill: " S:$G(PSOBACKB) %DT(0)=-PSOBACKB D ^%DT G:Y<0!($D(DTOUT)) PATCHQ S PSOBACKA=$E(Y,1,7) + W ! K ZTDTH S ZTSAVE("PSOBACKB")="",ZTSAVE("PSOBACKA")="",ZTRTN="PATCHR^PSOUTLA1",ZTDESC="BACKFILL PRSCRIPTIONS TO CPRS",ZTIO="" D ^%ZTLOAD W ! G PATCHQ +PATCHR ;Begin task + N PSOPAL,PSOLPD,PSOLPRX + S PSOBACKA=PSOBACKA-.01 + I '$G(PSOBACKB) S PSOBACKB=DT + F PSOPAL=0:0 S PSOPAL=$O(^PS(55,PSOPAL)) Q:'PSOPAL F PSOLPD=PSOBACKA:0 S PSOLPD=$O(^PS(55,PSOPAL,"P","A",PSOLPD)) Q:'PSOLPD!(PSOLPD>PSOBACKB) F PSOLPRX=0:0 S PSOLPRX=$O(^PS(55,PSOPAL,"P","A",PSOLPD,PSOLPRX)) Q:'PSOLPRX D + .I $P($G(^PSRX(PSOLPRX,0)),"^")=""!('$P($G(^(0)),"^",2))!('$P($G(^(0)),"^",6)) Q + .I $P($G(^PSRX(PSOLPRX,"OR1")),"^",2) Q + .I '$P($G(^PSRX(PSOLPRX,0)),"^",19) D + ..I $P($G(^PSRX(PSOLPRX,"OR1")),"^")="",+$G(^PSDRUG(+$P($G(^PSRX(PSOLPRX,0)),"^",6),2)) S $P(^PSRX(PSOLPRX,"OR1"),"^")=+$G(^PSDRUG(+$P($G(^PSRX(PSOLPRX,0)),"^",6),2)) + ..I $P($G(^PSRX(PSOLPRX,0)),"^",10)'="",$G(^PSRX(PSOLPRX,"SIG"))']"",'$O(^PSRX(PSOLPRX,"SIG1",0)) S ^PSRX(PSOLPRX,"SIG")=$P($G(^PSRX(PSOLPRX,0)),"^",10)_"^"_0 S $P(^PSRX(PSOLPRX,0),"^",10)="" + ..I $P($G(^PSRX(PSOLPRX,"STA")),"^")="",$P($G(^PSRX(PSOLPRX,0)),"^",15)'="" S $P(^PSRX(PSOLPRX,"STA"),"^")=$P($G(^PSRX(PSOLPRX,0)),"^",15) S $P(^PSRX(PSOLPRX,0),"^",15)="" + ..S $P(^PSRX(PSOLPRX,0),"^",19)=1 + .S PSOLPSTA=$P($G(^PSRX(PSOLPRX,"STA")),"^") Q:PSOLPSTA=""!(PSOLPSTA=13)!(PSOLPSTA=10) + .D EN^PSOHLSN1(PSOLPRX,"ZC","") + .I PSOLPSTA'="",PSOLPSTA<10 D + ..I +$P($G(^PSRX(PSOLPRX,2)),"^",6),+$P($G(^(2)),"^",6)
1,$E(+PSDEA,QQ)<6 D + . S PSOCS=1 + . S:$E(+PSDEA,QQ)=2 $P(PSOCS,"^",2)=1 + ; + ;no refills allowed on sched 2 + I $P(PSOCS,"^",2)=1 S PSMAXRF=$$NUMFILLS(PSIRXN) Q 1 + ; + ;set max refill for controlled substance & other based on days supply + S PSDAYS=+$G(PSDAYS) + I PSOCS D + . S PSMAXRF=$S(PSDAYS<60:5,PSDAYS'<60&(PSDAYS'>89):2,PSDAYS=90:1,1:0) + E D + . S PSMAXRF=$S(PSDAYS<60:11,PSDAYS'<60&(PSDAYS'>89):5,PSDAYS=90:3,1:0) + ; + ;get number of fills if applies & compare to Max refills + N PNFILLS S PNFILLS=$$NUMFILLS(PSIRXN) + I PNFILLS'IOM !?19 W $G(^PSRX(PSONV,"DAI",PSPPP,0))_", " - W ! K DIR,PSPPP S DIR(0)="Y",DIR("B")="Y",DIR("A")="Do you want to intervene?" D ^DIR K DIR I X["^"!($D(DTOUT))!($D(DUOUT)) K PSDTSTOP G OUT - I Y S PSORX("INTERVENE")=0 D EN1^PSORXI(PSONV) -EDIT I $G(PKI1)=2 D DCV1^PSOPKIV1 G OUT - K PSDTSTOP S DIR("A")="EDIT",DIR("B")="N",DIR(0)="SB^Y:YES;N:NO;P:PROFILE",DIR("?")="Enter Y to change this RX, P to see a profile, or N to procede with verification" - D ^DIR K DIR I Y="Y",$G(PSOACT)]"" S VALMBCK="R" G OUT - I $D(DIRUT),$G(PSOCLK) S PSOCQ=1 G OUT - I $D(DIRUT),$G(PSOACT)]"" S VALMBCK="R" G OUT - G VERIFY:Y="N",PROF:Y="P",OUT:"YNP"'[$E(Y) -CHANGE S DA=PSONV,(PSRX1,PSRX2)=$P(^PSRX(PSONV,0),"^",6) - S DEA1=1,DEA2=0,PSDOLD=+DA,DIE="^PSRX(",DR="3;7;8;9;4;5;12;1;22;11;"_$S($P(PSOPAR,"^",12):"35;",1:"")_$S($P(PSOPAR,"^",15):"10.6",1:"")_";@2" D ^DIE - ;I PSRX1'=PSRX2,DEA1'=DEA2 S DR="6////"_PSRX1 D ^DIE - D EXPIRE K DIE,DR,DEA1,DEA2,P(5),PSRX1,PSRX2 - K PSD(PSDOLD) S PSDNEW=$P(^PSDRUG($P(^PSRX(PSONV,0),"^",6),0),"^")_"^"_PSONV,PSD(PSDNEW)=PSONV_"^*^1^"_$P(^PSDRUG($P(^PSRX(PSONV,0),"^",6),0),"^",2) - S DA=PSONV D ^PSORXPR - G EDIT:PSDNEW=PSDOLD,REDO -PROF I '$D(PSOSD) W !,$C(7),"This patient has no other prescriptions on file",!! G EDIT Q - D ^PSODSPL G EDIT Q - ; -EXPIRE S RX0=^PSRX(DA,0),X1=$P($P(RX0,"^",13),"."),X2=$P(RX0,"^",9)+1*$P(RX0,"^",8),X2=$S($P(RX0,"^",8)=X2:X2,X2<181:184,X2=360:366,1:X2),X=X1 D:X1&X2 C^%DTC - K ^PS(55,PSDFN,"P","A",+$P(^PSRX(DA,2),"^",6),DA) S ^PS(55,PSDFN,"P","A",X,DA)="",$P(^PSRX(DA,2),"^",6)=X,$P(^PS(52.4,DA,0),"^",7)=X Q -VERIFY G:'$P(PSOPAR,"^",2) VERY - S DIR("A")="VERIFY FOR "_PSONAM_" ? (Y/N/Delete/Quit): ",DIR("B")="Y",DIR(0)="SA^Y:YES;N:NO;D:DELETE;Q:QUIT" - S DIR("?",1)="Enter Y (or return) to verify this prescription",DIR("?",2)="N to leave this prescription non-verified and to end this session of verification",DIR("?")="D to delete this prescription" - D ^DIR K DIR G OUT:Y="N",QUIT:"Q^"[$E(Y),DELETE:Y="D" -VERY I $G(PKI1)=1 D REA^PSOPKIV1 G:'$D(PKIR) VERIFY - K ^PSRX(PSONV,"DAI") S $P(^PSRX(PSONV,3),"^",6)="" - K ^PSRX(PSONV,"DRI"),SPFL - I '$O(^PSRX(PSONV,6,0)) D I $D(DUOUT)!($D(DTOUT)) W !!,"Rx: "_$P(^PSRX(DA,0),"^")_" not Verified!!",! H 2 G OUT - .W !!,"Dosing Instructions Missing. Please add!",! - .I $P($G(^PSRX(PSONV,"SIG")),"^")]"",'$P($G(^("SIG")),"^",2) W "SIG: "_$P(^PSRX(PSONV,"SIG"),"^"),! - .I $P($G(^PSRX(PSONV,"SIG")),"^",2),$O(^PSRX(PSONV,"SIG1",0)) D K I - ..W "SIG: " F I=0:0 S I=$O(^PSRX(PSONV,"SIG1",I)) Q:'I W ^PSRX(PSONV,"SIG1",I,0),! - .S DA=PSONV,PSOVER=1 K DIR,DIRUT,DUOUT,DTOUT - .S PSODRUG("IEN")=$P(^PSRX(DA,0),"^",6),PSODFN=$P(^(0),"^",2),PSORXED("IRXN")=DA,PSODRUG("OI")=$P(^PSRX(DA,"OR1"),"^") - .D DOSE^PSSORPH(.DOSE,PSODRUG("IEN"),"O",PSODFN),^PSOORED3 - .K PSODFN,PSODRUG("IEN"),DOSE,PSOVER - .I '$G(ENT) S DUOUT=1 - .Q:$D(DUOUT)!($D(DTOUT)) - .K DIR,DIRUT,DUOUT,DTOUT S DIE=52,DR=114 D ^DIE K DIE,DR,DTOUT - .I X'="" D SIG^PSOHELP D:$G(INS1)]"" EN^DDIOL($E(INS1,2,9999999)) S PSORXED("SIG",1)=$E(INS1,2,9999999) - .D EN^PSOFSIG(.PSORXED,1),UDSIG^PSOORED3 H 2 - S DA=PSONV,$P(^PSRX(DA,2),"^",10)=DUZ I $P(^PSRX(DA,2),"^",2)>DT,$P(PSOPAR,"^",6) S (SPFL1,PSOVER)="",PSORX("FILL DATE")=$P(^(2),"^",2),RXF=0 D UPSUS S PSTRIVER=1 D SUS^PSORXL K PSORX("FILL DATE"),PSTRIVER G KILL - S PSOVER(PSONV)="" S $P(^PSRX(PSONV,"STA"),"^")=0,$P(PSOSD("NON-VERIFIED",DRG),"^",2)=0,PSOSD("ACTIVE",DRG)=PSOSD("NON-VERIFIED",DRG) - I $G(PKI1)=1,$G(PKIR)]"" D ACT^PSOPKIV1(DA) - K PSOSD("NON-VERIFIED",DRG) D EN^PSOHLSN1(PSONV,"SC","CM","") - ; - ; - Calling ECME for claims generation and transmission / REJECT handling - N ACTION - I $$SUBMIT^PSOBPSUT(PSONV) D I ACTION="Q"!(ACTION="^") Q - . S ACTION="" D ECMESND^PSOBPSU1(PSONV,,,$S($O(^PSRX(PSONV,1,0)):"RF",1:"OF")) - . I $$FIND^PSOREJUT(PSONV) D - . . S ACTION=$$HDLG^PSOREJU1(PSONV,0,"79,88","OF","IOQ","Q") - ; -KILL S DA=PSONV,DIK="^PS(52.4," D ^DIK K DA,DIK D DCORD^PSONEW2 -OUT K DIRUT,DTOUT,DUOUT,UPFLAGX D CLEAN Q -DELETE K UPFLAGX D DELETE^PSOVER2 G:$G(UPFLAGX) OUT K PSOSD("NON-VERIFIED",$G(DRG)) Q -QUIT S PSOQUIT="" D CLEAN Q -UPSUS S $P(PSOSD("NON-VERIFIED",DRG),"^",2)=5,PSOSD("ACTIVE",DRG)=PSOSD("NON-VERIFIED",DRG) K PSOSD("NON-VERIFIED",DRG) D EN^PSOHLSN1(PSONV,"SC","CM","") - Q -CLEAN ;cleans up tmp("psorxdc") global - I $O(^TMP("PSORXDC",$J,0)) F RORD=0:0 S RORD=$O(^TMP("PSORXDC",$J,RORD)) Q:'RORD D - .D PSOUL^PSSLOCK(RORD_$S($P(^TMP("PSORXDC",$J,RORD,0),"^")="P":"S",1:"")) - .W !,$S($P(^TMP("PSORXDC",$J,RORD,0),"^")=52:"Prescription",1:"Pending Order")_" #"_$S($P(^TMP("PSORXDC",$J,RORD,0),"^")=52:$P(^PSRX(RORD,0),"^"),1:RORD)_" NOT Discontinued." - K ^TMP("PSORXDC",$J),RORD - Q -KV1 ; - K PSOANSQD,DRET,LST,PSOQUIT,PSODRUG,PSONEW,SIG,PSODIR,PHI,PRC,ORCHK,ORDRG,PSOSIGFL,PSORX("ISSUE DATE"),PSORX("FILL DATE"),CLOZPAT -KV K DIR,DIRUT,DTOUT,DUOUT - Q -NVA ; - I $P(PSOSD(STA,DNM),"^",11) D NVA^PSODRDU1 Q - N PSOOI,CLASS,FLG,X,Y,RXREC,IFN - S (Y,FLG)="" - S RXREC=$P(PSOSD(STA,DNM),"^",10),PSOOI=+$G(^PS(55,DFN,"NVA",RXREC,0)),IFN=RXREC N DNM - F S Y=$O(^PSDRUG("ASP",PSOOI,Y)) Q:Y=""!(FLG) S DNM=$P(^PSDRUG(Y,0),"^"),CLASS=$P(^PSDRUG(Y,0),"^",2) I PSODRUG("NAME")=DNM!(CLASS=PSODRUG("VA CLASS")) D DSP^PSODRDU1 S FLG=1 Q - Q -REMOTE ; - K ^TMP($J,"DD"),^TMP($J,"DC"),^TMP($J,"DI"),^TMP($J,"DI"_PSODFN) D - .I $T(HAVEHDR^ORRDI1)']"" Q - .I '$$HAVEHDR^ORRDI1 Q - .I $D(^XTMP("ORRDI","OUTAGE INFO","DOWN")) D Q - ..I $T(REMOTE^PSORX1)]"" Q - ..W !,"Remote data not available - Only local order checks processed." D PAUSE^PSOORRD2 - .W !,"Now doing remote order checks. Please wait..." - .D REMOTE^PSOORRDI(PSODFN,+$P($G(^PSRX(PSONV,0)),"^",6)) - .I $P($G(^XTMP("ORRDI","PSOO",PSODFN,0)),"^",3)<0 W !,"Remote data not available - Only local order checks processed." D PAUSE^PSOORRD2 Q - .I $D(^TMP($J,"DD")) D DUP^PSOORRD2 - .I $D(^TMP($J,"DC")) D CLS^PSOORRD2 - .I $D(^TMP($J,"DI"_PSODFN)) K ^TMP($J,"DI") M ^TMP($J,"DI")=^TMP($J,"DI"_PSODFN) D DRGINT^PSOORRD2 - K ^TMP($J,"DD"),^TMP($J,"DC"),^TMP($J,"DI"),^TMP($J,"DI"_PSODFN) - Q -NOALRGY ; - W $C(7),!,"There is no allergy assessment on file for this patient." - W !,"You will be prompted to intervene if you continue with this prescription" - K DIR - S DIR(0)="SA^1:YES;0:NO",DIR("A")="Do you want to Continue?: ",DIR("B")="N" D ^DIR - I 'Y S PSZZQUIT=1 Q - S PSORX("INTERVENE")=0 - D EN1^PSORXI(PSONV) - Q +PSOVER1 ;BHAM ISC/SAB - verify one rx ;3/9/05 12:53pm + ;;7.0;OUTPATIENT PHARMACY;**32,46,90,131,202,207,148,243,268**;DEC 1997;Build 9 + ;External reference ^PSDRUG( supported by DBIA 221 + ;External reference to PSOUL^PSSLOCK supported by DBIA 2789 + ;External reference ^PS(55 supported by DBIA 2228 + ;External reference to PSSORPH is supported by DBIA 3234 + ;External references to ^ORRDI1 supported by DBIA 4659 + ;External reference ^XTMP("ORRDI" supported by DBIA 4660 +REDO ; + S (DRG,PSODRUG("NAME"))=$P(^PSDRUG(+$P(^PSRX(PSONV,0),"^",6),0),"^"),PSODRUG("VA CLASS")=$P(^(0),"^",2) + I '$D(PSODFN) S PSODFN=$P(^PSRX(PSONV,0),"^",2) + S (STA,DNM)="",PSDPSTOP=0,$P(PSONULN,"-",79)="-" F S STA=$O(PSOSD(STA)) Q:STA="" F S DNM=$O(PSOSD(STA,DNM)) Q:DNM="" K PSZZZDUP I $P(PSOSD(STA,DNM),"^",2)<10 D + .I STA="ZNONVA" D NVA Q + .I PSODRUG("NAME")=$P(DNM,"^")&(PSONV'=$P(PSOSD(STA,DNM),"^")) S PSZZZDUP=1 K DIR S DIR(0)="E",DIR("A")="Press RETURN to continue" W ! D ^DIR K DIR S PSDTSTOP=1 + .I PSODRUG("VA CLASS")]"",$E(PSODRUG("VA CLASS"),1,4)=$E($P(PSOSD(STA,DNM),"^",5),1,4),PSODRUG("NAME")'=$P(DNM,"^") K DIR S DIR(0)="E",DIR("A")="Press RETURN to continue" W ! D ^DIR K DIR D CLS^PSODRDUP S PSDTSTOP=1 + .I $G(PSZZZDUP),$G(PSVFLAG),$P($G(^PSRX($P(PSOSD(STA,DNM),"^"),"STA")),"^")=12,$D(^PS(52.4,$P(PSOSD(STA,DNM),"^"),0)) S DA=$P(PSOSD(STA,DNM),"^"),DIK="^PS(52.4," D ^DIK K DIK + .I $G(PSZZZDUP),$G(PSVFLAG),$P($G(^PSRX($P(PSOSD(STA,DNM),"^"),"STA")),"^")'=12 S PSZZQUIT=1 + K MSG I $G(PSZZQUIT),$G(PSVFLAG) K PSZZQUIT,PSODRUG,PSODFN,PSZZZDUP,DNM,PSDTSTOP D CLEAN Q + D REMOTE + K PSODRUG,PSODFN,PSZZZDUP,DNM,PSZZQUIT +ALLR ;Allergy check + S PSONOAL="" D ALLERGY^PSOORUT2 D:PSONOAL'="" NOALRGY K PSONOAL I $G(PSZZQUIT) K MSG,PSZZQUIT,PSODRUG,PSODFN,PSZZZDUP,DNM,PSDTSTOP D CLEAN Q + G:'$P($G(^PSRX(PSONV,3)),"^",6) EDIT + I '$G(PSDTSTOP) K DIR S DIR(0)="E" D ^DIR K DIR I $D(DTOUT)!($D(DUOUT)) K PSDTSTOP G OUT + W !!,"A Drug-Allergy Reaction exists for this medication!",!!,"***SIGNIFICANT*** Allergy Reaction" + W !,"Drug: ",$P($G(^PSDRUG(+$P($G(^PSRX(PSONV,0)),"^",6),0)),"^") + I $O(^PSRX(PSONV,"DAI",0)) W !?6,"Ingredients: " D + .F PSPPP=0:0 S PSPPP=$O(^PSRX(PSONV,"DAI",PSPPP)) Q:'PSPPP I $G(^(PSPPP,0))'="" W:$X+$L($G(^PSRX(PSONV,"DAI",PSPPP,0)))+2>IOM !?19 W $G(^PSRX(PSONV,"DAI",PSPPP,0))_", " + W ! K DIR,PSPPP S DIR(0)="Y",DIR("B")="Y",DIR("A")="Do you want to intervene?" D ^DIR K DIR I X["^"!($D(DTOUT))!($D(DUOUT)) K PSDTSTOP G OUT + I Y S PSORX("INTERVENE")=0 D EN1^PSORXI(PSONV) +EDIT I $G(PKI1)=2 D DCV1^PSOPKIV1 G OUT + K PSDTSTOP S DIR("A")="EDIT",DIR("B")="N",DIR(0)="SB^Y:YES;N:NO;P:PROFILE",DIR("?")="Enter Y to change this RX, P to see a profile, or N to procede with verification" + D ^DIR K DIR I Y="Y",$G(PSOACT)]"" S VALMBCK="R" G OUT + I $D(DIRUT),$G(PSOCLK) S PSOCQ=1 G OUT + I $D(DIRUT),$G(PSOACT)]"" S VALMBCK="R" G OUT + G VERIFY:Y="N",PROF:Y="P",OUT:"YNP"'[$E(Y) +CHANGE S DA=PSONV,(PSRX1,PSRX2)=$P(^PSRX(PSONV,0),"^",6) + S DEA1=1,DEA2=0,PSDOLD=+DA,DIE="^PSRX(",DR="3;7;8;9;4;5;12;1;22;11;"_$S($P(PSOPAR,"^",12):"35;",1:"")_$S($P(PSOPAR,"^",15):"10.6",1:"")_";@2" D ^DIE + ;I PSRX1'=PSRX2,DEA1'=DEA2 S DR="6////"_PSRX1 D ^DIE + D EXPIRE K DIE,DR,DEA1,DEA2,P(5),PSRX1,PSRX2 + K PSD(PSDOLD) S PSDNEW=$P(^PSDRUG($P(^PSRX(PSONV,0),"^",6),0),"^")_"^"_PSONV,PSD(PSDNEW)=PSONV_"^*^1^"_$P(^PSDRUG($P(^PSRX(PSONV,0),"^",6),0),"^",2) + S DA=PSONV D ^PSORXPR + G EDIT:PSDNEW=PSDOLD,REDO +PROF I '$D(PSOSD) W !,$C(7),"This patient has no other prescriptions on file",!! G EDIT Q + D ^PSODSPL G EDIT Q + ; +EXPIRE S RX0=^PSRX(DA,0),X1=$P($P(RX0,"^",13),"."),X2=$P(RX0,"^",9)+1*$P(RX0,"^",8),X2=$S($P(RX0,"^",8)=X2:X2,X2<181:184,X2=360:366,1:X2),X=X1 D:X1&X2 C^%DTC + K ^PS(55,PSDFN,"P","A",+$P(^PSRX(DA,2),"^",6),DA) S ^PS(55,PSDFN,"P","A",X,DA)="",$P(^PSRX(DA,2),"^",6)=X,$P(^PS(52.4,DA,0),"^",7)=X Q +VERIFY G:'$P(PSOPAR,"^",2) VERY + S DIR("A")="VERIFY FOR "_PSONAM_" ? (Y/N/Delete/Quit): ",DIR("B")="Y",DIR(0)="SA^Y:YES;N:NO;D:DELETE;Q:QUIT" + S DIR("?",1)="Enter Y (or return) to verify this prescription",DIR("?",2)="N to leave this prescription non-verified and to end this session of verification",DIR("?")="D to delete this prescription" + D ^DIR K DIR G OUT:Y="N",QUIT:"Q^"[$E(Y),DELETE:Y="D" +VERY I $G(PKI1)=1 D REA^PSOPKIV1 G:'$D(PKIR) VERIFY + K ^PSRX(PSONV,"DAI") S $P(^PSRX(PSONV,3),"^",6)="" + K ^PSRX(PSONV,"DRI"),SPFL + I '$O(^PSRX(PSONV,6,0)) D I $D(DUOUT)!($D(DTOUT)) W !!,"Rx: "_$P(^PSRX(DA,0),"^")_" not Verified!!",! H 2 G OUT + .W !!,"Dosing Instructions Missing. Please add!",! + .I $P($G(^PSRX(PSONV,"SIG")),"^")]"",'$P($G(^("SIG")),"^",2) W "SIG: "_$P(^PSRX(PSONV,"SIG"),"^"),! + .I $P($G(^PSRX(PSONV,"SIG")),"^",2),$O(^PSRX(PSONV,"SIG1",0)) D K I + ..W "SIG: " F I=0:0 S I=$O(^PSRX(PSONV,"SIG1",I)) Q:'I W ^PSRX(PSONV,"SIG1",I,0),! + .S DA=PSONV,PSOVER=1 K DIR,DIRUT,DUOUT,DTOUT + .S PSODRUG("IEN")=$P(^PSRX(DA,0),"^",6),PSODFN=$P(^(0),"^",2),PSORXED("IRXN")=DA,PSODRUG("OI")=$P(^PSRX(DA,"OR1"),"^") + .D DOSE^PSSORPH(.DOSE,PSODRUG("IEN"),"O",PSODFN),^PSOORED3 + .K PSODFN,PSODRUG("IEN"),DOSE,PSOVER + .I '$G(ENT) S DUOUT=1 + .Q:$D(DUOUT)!($D(DTOUT)) + .K DIR,DIRUT,DUOUT,DTOUT S DIE=52,DR=114 D ^DIE K DIE,DR,DTOUT + .I X'="" D SIG^PSOHELP D:$G(INS1)]"" EN^DDIOL($E(INS1,2,9999999)) S PSORXED("SIG",1)=$E(INS1,2,9999999) + .D EN^PSOFSIG(.PSORXED,1),UDSIG^PSOORED3 H 2 + S DA=PSONV,$P(^PSRX(DA,2),"^",10)=DUZ I $P(^PSRX(DA,2),"^",2)>DT,$P(PSOPAR,"^",6) S (SPFL1,PSOVER)="",PSORX("FILL DATE")=$P(^(2),"^",2),RXF=0 D UPSUS S PSTRIVER=1 D SUS^PSORXL K PSORX("FILL DATE"),PSTRIVER G KILL + S PSOVER(PSONV)="" S $P(^PSRX(PSONV,"STA"),"^")=0,$P(PSOSD("NON-VERIFIED",DRG),"^",2)=0,PSOSD("ACTIVE",DRG)=PSOSD("NON-VERIFIED",DRG) + I $G(PKI1)=1,$G(PKIR)]"" D ACT^PSOPKIV1(DA) + K PSOSD("NON-VERIFIED",DRG) D EN^PSOHLSN1(PSONV,"SC","CM","") + ; + ; - Calling ECME for claims generation and transmission / REJECT handling + N ACTION + I $$SUBMIT^PSOBPSUT(PSONV) D I ACTION="Q"!(ACTION="^") Q + . S ACTION="" D ECMESND^PSOBPSU1(PSONV,,,$S($O(^PSRX(PSONV,1,0)):"RF",1:"OF")) + . I $$FIND^PSOREJUT(PSONV) D + . . S ACTION=$$HDLG^PSOREJU1(PSONV,0,"79,88","OF","IOQ","I") + ; +KILL S DA=PSONV,DIK="^PS(52.4," D ^DIK K DA,DIK D DCORD^PSONEW2 +OUT K DIRUT,DTOUT,DUOUT,UPFLAGX D CLEAN Q +DELETE K UPFLAGX D DELETE^PSOVER2 G:$G(UPFLAGX) OUT K PSOSD("NON-VERIFIED",$G(DRG)) Q +QUIT S PSOQUIT="" D CLEAN Q +UPSUS S $P(PSOSD("NON-VERIFIED",DRG),"^",2)=5,PSOSD("ACTIVE",DRG)=PSOSD("NON-VERIFIED",DRG) K PSOSD("NON-VERIFIED",DRG) D EN^PSOHLSN1(PSONV,"SC","CM","") + Q +CLEAN ;cleans up tmp("psorxdc") global + I $O(^TMP("PSORXDC",$J,0)) F RORD=0:0 S RORD=$O(^TMP("PSORXDC",$J,RORD)) Q:'RORD D + .D PSOUL^PSSLOCK(RORD_$S($P(^TMP("PSORXDC",$J,RORD,0),"^")="P":"S",1:"")) + .W !,$S($P(^TMP("PSORXDC",$J,RORD,0),"^")=52:"Prescription",1:"Pending Order")_" #"_$S($P(^TMP("PSORXDC",$J,RORD,0),"^")=52:$P(^PSRX(RORD,0),"^"),1:RORD)_" NOT Discontinued." + K ^TMP("PSORXDC",$J),RORD + Q +KV1 ; + K PSOANSQD,DRET,LST,PSOQUIT,PSODRUG,PSONEW,SIG,PSODIR,PHI,PRC,ORCHK,ORDRG,PSOSIGFL,PSORX("ISSUE DATE"),PSORX("FILL DATE"),CLOZPAT +KV K DIR,DIRUT,DTOUT,DUOUT + Q +NVA ; + I $P(PSOSD(STA,DNM),"^",11) D NVA^PSODRDU1 Q + N PSOOI,CLASS,FLG,X,Y,RXREC,IFN + S (Y,FLG)="" + S RXREC=$P(PSOSD(STA,DNM),"^",10),PSOOI=+$G(^PS(55,DFN,"NVA",RXREC,0)),IFN=RXREC N DNM + F S Y=$O(^PSDRUG("ASP",PSOOI,Y)) Q:Y=""!(FLG) S DNM=$P(^PSDRUG(Y,0),"^"),CLASS=$P(^PSDRUG(Y,0),"^",2) I PSODRUG("NAME")=DNM!(CLASS=PSODRUG("VA CLASS")) D DSP^PSODRDU1 S FLG=1 Q + Q +REMOTE ; + K ^TMP($J,"DD"),^TMP($J,"DC"),^TMP($J,"DI"),^TMP($J,"DI"_PSODFN) D + .I $T(HAVEHDR^ORRDI1)']"" Q + .I '$$HAVEHDR^ORRDI1 Q + .I $D(^XTMP("ORRDI","OUTAGE INFO","DOWN")) D Q + ..I $T(REMOTE^PSORX1)]"" Q + ..W !,"Remote data not available - Only local order checks processed." D PAUSE^PSOORRD2 + .W !,"Now doing remote order checks. Please wait..." + .D REMOTE^PSOORRDI(PSODFN,+$P($G(^PSRX(PSONV,0)),"^",6)) + .I $P($G(^XTMP("ORRDI","PSOO",PSODFN,0)),"^",3)<0 W !,"Remote data not available - Only local order checks processed." D PAUSE^PSOORRD2 Q + .I $D(^TMP($J,"DD")) D DUP^PSOORRD2 + .I $D(^TMP($J,"DC")) D CLS^PSOORRD2 + .I $D(^TMP($J,"DI"_PSODFN)) K ^TMP($J,"DI") M ^TMP($J,"DI")=^TMP($J,"DI"_PSODFN) D DRGINT^PSOORRD2 + K ^TMP($J,"DD"),^TMP($J,"DC"),^TMP($J,"DI"),^TMP($J,"DI"_PSODFN) + Q +NOALRGY ; + W $C(7),!,"There is no allergy assessment on file for this patient." + W !,"You will be prompted to intervene if you continue with this prescription" + K DIR + S DIR(0)="SA^1:YES;0:NO",DIR("A")="Do you want to Continue?: ",DIR("B")="N" D ^DIR + I 'Y S PSZZQUIT=1 Q + S PSORX("INTERVENE")=0 + D EN1^PSORXI(PSONV) + Q diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA.m index b88c0100..b1446b3f 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA.m @@ -1,4 +1,4 @@ -PSOXZA ; DRIVER FOR COMPILED XREFS FOR FILE #52 ; 11/08/09 +PSOXZA ; DRIVER FOR COMPILED XREFS FOR FILE #52 ; 01/17/08 ; N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2 I '$D(DIKSAT) S DIKLK=DIK_DA_")" L +@DIKLK:10 K:'$T DIKLK diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA1.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA1.m index 4332be31..7d8ef046 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA1.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA1.m @@ -1,4 +1,4 @@ -PSOXZA1 ; COMPILED XREF FOR FILE #52 ; 11/08/09 +PSOXZA1 ; COMPILED XREF FOR FILE #52 ; 01/17/08 ; S DIKZK=2 S DIKZ(0)=$G(^PSRX(DA,0)) diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA10.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA10.m index 46741363..05737484 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA10.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA10.m @@ -1,4 +1,4 @@ -PSOXZA10 ; COMPILED XREF FOR FILE #52.052311 ; 11/08/09 +PSOXZA10 ; COMPILED XREF FOR FILE #52.052311 ; 01/17/08 ; S DA=0 A1 ; diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA11.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA11.m index f0c41252..7b3ee39b 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA11.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA11.m @@ -1,4 +1,4 @@ -PSOXZA11 ; COMPILED XREF FOR FILE #52.1 ; 11/08/09 +PSOXZA11 ; COMPILED XREF FOR FILE #52.1 ; 01/17/08 ; S DA=0 A1 ; diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA12.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA12.m index 56d49161..2fae9766 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA12.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA12.m @@ -1,4 +1,4 @@ -PSOXZA12 ; COMPILED XREF FOR FILE #52.2 ; 11/08/09 +PSOXZA12 ; COMPILED XREF FOR FILE #52.2 ; 01/17/08 ; S DA=0 A1 ; diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA13.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA13.m index 7f971527..0216a172 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA13.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA13.m @@ -1,4 +1,4 @@ -PSOXZA13 ; COMPILED XREF FOR FILE #52.25 ; 11/08/09 +PSOXZA13 ; COMPILED XREF FOR FILE #52.25 ; 01/17/08 ; S DA=0 A1 ; diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA14.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA14.m index a77667cf..fc0a5b2e 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA14.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA14.m @@ -1,4 +1,4 @@ -PSOXZA14 ; COMPILED XREF FOR FILE #52.2551 ; 11/08/09 +PSOXZA14 ; COMPILED XREF FOR FILE #52.2551 ; 01/17/08 ; S DA(2)=DA(1) S DA(1)=0 S DA=0 A1 ; diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA2.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA2.m index 2903982a..738ce581 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA2.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA2.m @@ -1,4 +1,4 @@ -PSOXZA2 ; COMPILED XREF FOR FILE #52.01 ; 11/08/09 +PSOXZA2 ; COMPILED XREF FOR FILE #52.01 ; 01/17/08 ; S DA(1)=DA S DA=0 A1 ; diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA3.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA3.m index 72054548..eaa1bbbd 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA3.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA3.m @@ -1,4 +1,4 @@ -PSOXZA3 ; COMPILED XREF FOR FILE #52.052311 ; 11/08/09 +PSOXZA3 ; COMPILED XREF FOR FILE #52.052311 ; 01/17/08 ; S DA=0 A1 ; diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA4.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA4.m index 3c9382ed..7b7aedbb 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA4.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA4.m @@ -1,4 +1,4 @@ -PSOXZA4 ; COMPILED XREF FOR FILE #52.1 ; 11/08/09 +PSOXZA4 ; COMPILED XREF FOR FILE #52.1 ; 01/17/08 ; S DA=0 A1 ; diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA5.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA5.m index 209b768b..243a3c56 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA5.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA5.m @@ -1,4 +1,4 @@ -PSOXZA5 ; COMPILED XREF FOR FILE #52.2 ; 11/08/09 +PSOXZA5 ; COMPILED XREF FOR FILE #52.2 ; 01/17/08 ; S DA=0 A1 ; diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA6.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA6.m index 9ae314a4..a54a19b8 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA6.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA6.m @@ -1,4 +1,4 @@ -PSOXZA6 ; COMPILED XREF FOR FILE #52.25 ; 11/08/09 +PSOXZA6 ; COMPILED XREF FOR FILE #52.25 ; 01/17/08 ; S DA=0 A1 ; diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA7.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA7.m index e9e156e5..aaf6cea2 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA7.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA7.m @@ -1,4 +1,4 @@ -PSOXZA7 ; COMPILED XREF FOR FILE #52.2551 ; 11/08/09 +PSOXZA7 ; COMPILED XREF FOR FILE #52.2551 ; 01/17/08 ; S DA(2)=DA(1) S DA(1)=0 S DA=0 A1 ; diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA8.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA8.m index e6b2e18d..fbc1e52a 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA8.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA8.m @@ -1,4 +1,4 @@ -PSOXZA8 ; COMPILED XREF FOR FILE #52 ; 11/08/09 +PSOXZA8 ; COMPILED XREF FOR FILE #52 ; 01/17/08 ; S DIKZK=1 S DIKZ(0)=$G(^PSRX(DA,0)) diff --git a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA9.m b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA9.m index 7fed68a9..01e613fd 100644 --- a/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA9.m +++ b/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA9.m @@ -1,4 +1,4 @@ -PSOXZA9 ; COMPILED XREF FOR FILE #52.01 ; 11/08/09 +PSOXZA9 ; COMPILED XREF FOR FILE #52.01 ; 01/17/08 ; S DA(1)=DA S DA=0 A1 ; diff --git a/r/PAID-PRS/PRS8AC.m b/r/PAID-PRS/PRS8AC.m index bf5e9faf..4b36f27d 100644 --- a/r/PAID-PRS/PRS8AC.m +++ b/r/PAID-PRS/PRS8AC.m @@ -1,195 +1,159 @@ -PRS8AC ;HISC/MRL-DECOMPOSITION, ACTIVITY STRING ;05/18/07 - ;;4.0;PAID;**40,45,54,52,69,75,90,96,112**;Sep 21, 1995;Build 54 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ;The primary purpose of this routine is to create the activity - ;string [the "W" node] for each day of activity. While creating - ;this string certain counts will also be tallied. These include - ;Standby, On-Call and the various absence categories. Actual - ;Call Back hrs are also counted in this routine for the purpose - ;of reducing the OC later on in the process. - ; - ;Called by Routines: PRS8EX, PRS8ST. - ; - Q:VAR="" - I $S($P(V,"^",1)="":1,$P(V,"^",2)="":1,1:0) Q ;no times - S Q=0 - I DY>0,DY<15 D G END:Q - .I DAY(DY,"OFF"),"LSWARUHFGDr"[VAR S Q=1 ;exc invalid day off VAR - K OC,FLAG - ; - S DAYZ=DAY(DY,"W")_$G(DAY(DY,"N")),MTM=0 - S DAYH=$G(DAY(DY,"HOL"))_$G(DAY(DY+1,"HOL")) ;holiday node - N DAYR - S DAYR=DAY(DY,"r")_$G(DAY(DY,"rN")) ; Recess - ; - ;P 45 FIREFIGHTERS F NODE TO TRACK ADDITIONAL FF HRS - S DAYF=$G(DAY(DY,"F")) - ; - F T=+V:1:+$P(V,"^",2) D - .I +VAR,$E(DAYH,T),$E(DAYZ,T)?1A Q ;no override holiday - .; Don't override Recess but allow Unscheduled Regular (VAR=4) - .I +VAR,VAR'=4,$E(DAYR,T)="r" Q ; don't override Recess - .I VAR="A"&(JURY=1) S VAR="J" - .S VAR1=VAR Q:VAR1="" S DAYZ(1)=$E(DAYZ,T) - .I "HhJLSARWMNUnVXYTFGD"[VAR1,$E(DAYZ,T)="m" Q - .I T=+V,"12345E"[VAR1 S DAY(DY,"DWK")=1 ;count days worked - .I T=+V,"Vh"[VAR1,TYP["I" S DAY(DY,"DWK")=1 ;count days worked for cop - .I "JLSWNnARUXYFGD"[VAR1,T'>96,'$E(DAYZ,T) Q ;invalid outside tour - .; Regular employees can't earn ct/use ot during work - .I +NAWS'=9,"EOPQT4"[VAR1,T'>96,$E(DAYZ,T) Q - .; 9mo AWS checks - .I +NAWS=9,"PQT"[VAR1,T'>96,$E(DAYZ,T) Q ;can't earn ct/use ot during work - .; Allow CT/OT/UN/ON if posted over Recess otherwise don't allow - .I +NAWS=9,"4OEC"[VAR1,T'>96,$E(DAYZ,T),$E(DAYR,T)'="r" S $E(DAYR,T)=VAR1 Q - .I "OE"[VAR1,"BC"[DAYZ(1),$L(DAYZ(1)) D ; Change OT or CT to CB/SB OT - ..S VAR1=$C($A($E(DAYZ,T))+32) - ..I $E(DAYZ,T)="C",VAR="E" S VAR1="t" ; Comp time on on-call = "t" - .I "BC"[VAR1,DAYZ(1)="O",$L(DAYZ(1)) D ; Change CB/SB to CB/SB OT - ..S VAR1=$C($A($E(VAR1))+32) - .I "Hh"[VAR1 D Q:VAR1="H" - ..S DAYH=$E(DAYH,0,T-1)_$S(VAR1="H":1,$E(DAYZ,T)&($E(DAYZ,T)'=4)!(TYP["I")!(TYP["P"&(TYP["N"!(TYP["H")))!(VAR1="h"):2,1:0)_$E(DAYH,T+1,999) ;holiday node - ..I VAR1="h" S VAR1="O" ;convert HW to OT - ..I VAR="h",$E(DAYZ,T)=5 S FLAG=5 - .I $E(DAYZ,T)=5,"ALSRUFGD"[VAR1 S VAR1=$E(DAYZ,T) - .I $E(DAYZ,T)="-","BbCctes"[VAR1 Q ;unavail for oc/sb or sch ot/ct - .; - .I VAR'="r" D - ..S DAYZ=$E(DAYZ,0,T-1)_VAR1_$E(DAYZ,T+1,999) - ..I $E($G(DAY(DY-1,"N")),T)'="",VAR1'=$E($G(DAY(DY-1,"N")),T) D - ...S DAY(DY-1,"N")=$E(DAY(DY-1,"N"),0,T-1)_VAR1_$E(DAY(DY-1,"N"),T+1,999) ;save VAR - ..; When processing tour time also copy tour into DAYR - ..I "1235"[VAR1 D - ...S DAYR=$E(DAYZ,0,T-1)_VAR1_$E(DAYZ,T+1,999) - ...I $E($G(DAY(DY-1,"N")),T)'="",VAR1'=$E($G(DAY(DY-1,"N")),T) D - ....S DAY(DY-1,"rN")=$E(DAY(DY-1,"rN"),0,T-1)_VAR1_$E(DAY(DY-1,"rN"),T+1,999) - .; - .; The following check will record Recess and will then update VAR1 to 0 which - .; will result in the normally scheduled tour being marked as being no tour. - .; This will allow Unscheduled Regular, OT and CT to be posted over the tour. - .I VAR="r" D - ..S DAYR=$E(DAYR,0,T-1)_VAR1_$E(DAYR,T+1,999) - ..S DAYZ=$E(DAYZ,0,T-1)_0_$E(DAYZ,T+1,999) ; Overwrite tour - ..I $E($G(DAY(DY-1,"rN")),T)'="",VAR1'=$E($G(DAY(DY-1,"rN")),T) D - ...S DAY(DY-1,"rN")=$E(DAY(DY-1,"rN"),0,T-1)_VAR1_$E(DAY(DY-1,"rN"),T+1,999) - ...S DAY(DY-1,"N")=$E(DAY(DY-1,"N"),0,T-1)_0_$E(DAY(DY-1,"N"),T+1,999) - ..S Y=48 D SET ; Count Recess - .; - .I VAR1="J" S Y=5 D SET ;set authorized absence for jury duty - .I VAR1="M" S Y=5 D SET ; authorized absence for ML - .;ot on non-premium T&L - .I ("Eocb"[VAR1!(VAR1="O"&'$E(DAYH,T)))&("^^10^11^12^13^15^16^17^"[("^"_$P(V,"^",4)_"^"))!(VAR1=5&("ALSRUFGD"[VAR))!(VAR1=4&(TYP["P"!(TYP["I"&(TYP["N"!(TYP["H"!($$HYBRID^PRSAENT1($G(DFN)))))))&("^7^9^11^12^14^17^"[("^"_$P(V,"^",4)_"^"))) D - ..Q:$E(DAY(DY,"P"),T)=5&("ALSRUFGD"'[VAR) - ..I $D(FLAG) S FLAG=VAR1,VAR1=5 - ..N CODE D - ...I "^7^8^12^"[("^"_$P(V,"^",4)_"^")&(TYP["N"!(TYP["H")!($$HYBRID^PRSAENT1($G(DFN)))) S CODE="N" Q - ...I "^7^8^12^"[("^"_$P(V,"^",4)_"^")&(PMP'="")&("^S^T^U^V^"[(U_PMP_U)) S CODE="N" Q - ...I $P(V,"^",4)=11,($$HYBRID^PRSAENT1($G(DFN))) S CODE="N" Q - ...I $P(V,"^",4)=11&(PMP'="")&("^S^T^U^V^"[(U_PMP_U)) S CODE="N" Q - ...I "^7^8^9^11^"[("^"_$P(V,"^",4)_"^")&(TYP'["N")&(TYP'["H")&('$$HYBRID^PRSAENT1($G(DFN))) S CODE="n" Q - ...I "^7^8^9^11^"[("^"_$P(V,"^",4)_"^")&("^S^T^U^V^"'[(U_PMP_U)) S CODE="n" Q - ...I $P(V,"^",4)=17 S CODE="N" Q ; Code 17 - OT/CT with premiums - ...I VAR1=5 S CODE=VAR Q - ...S CODE=1 - ..S DAY(DY,"P")=$E(DAY(DY,"P"),0,T-1)_CODE_$E(DAY(DY,"P"),T+1,999) - .I "ALSRUFGD"[VAR,VAR1=5 S VAR1=VAR - .I $D(FLAG) S VAR1=FLAG K FLAG - .; -FOPTHR .; part time hrs (PT/PH 8b codes) for CODE O firefighters - .I +VAR1,"Ff"[TYP,PMP="O",(NH=448!(NH>320&(NH(1)'=NH(2)))) S Y=32 D SET - .; -FRCPTHR .; part time hrs (PT/PH 8b codes) for code R & C firefighters - .; don't include UNSCHEDULED REGULAR (var1=4) - .I +VAR1,VAR1'=4,"Ff"[TYP,"RC"[PMP S Y=32 D SET - .; - .;patch 45 & 54 - .; Set non pay hrs in the basic tour for firefighters with premium - .;pay indicator of C. - .I "nW"[VAR1,"Ff"[TYP,"C"=PMP D - ..; - ..; Y designates location in WK array where NT/NH will be stored. - ..; F node was set to 1 for periods of addtl ff hrs during 1st pass - ..; thru scheduled ToD. Count NT/NH if this is not addtl ff hrs. - ..; - ..I '$E(DAY(DY,"F"),T) S Y=47 D SET - .S S="LSWnAREUP HYXOVQTFGD" I S[VAR1&(DY>0&(DY<15)!(DY=0&(T>96))) D ;save in WK array - ..S S(1)=$F(S,VAR1)-1 - ..S S=$P("1^2^3^4^5^6^0^8^0^9^24^42^43^0^33^0^19^44^45^46","^",S(1)) ;WK location - ..Q:S=0 - ..; Patch *40 removed A (authorized absence) from leave counted in LU. - ..; LU is only used to determine if night differential granted for - ..; leave should be backed out. - ..I TYP'["D","LSRUFGD"[VAR1 S LU=LU+1 ;increment leave counter - ..I TYP'["D","LSRUFGD"[VAR1,(DY=0!(DY=14)&(T>96)),LU>0 S LU=LU-1 - ..S Y=S D SET S:TYP["D" Q=1 - ..K S,VAR1 - ; - S DAY(DY,"W")=$E(DAYZ,1,96) ;todays activity - S DAY(DY,"N")=$E(DAYZ,97,999) ;tomorrows activity from today/if any - S DAY(DY,"r")=$E(DAYR,1,96) ; Today's Recess - S DAY(DY,"rN")=$E(DAYR,97,999) ; Tomorrow's Recess/if any - S:$E(DAY(DY,"P"),97,999)'="" DAY(DY,"P1")=$E(DAY(DY,"P"),97,999) ;non-prem ot for next day - S DAY(DY,"P")=$E(DAY(DY,"P"),1,96) ;non-prem ot for today - I DAY(DY,"N")?1"0"."0",DAY(DY,"rN")'["r" S DAY(DY,"N")="" - S DAY(DY,"HOL")=$E(DAYH,1,96) - ; - ;P 45 FIREFIGHTER ADDITIONAL FIREFIGHTER HRS NODE FOR THIS DAY - I $G(PRS8AFFH) D - . N PRSFFHR,PRSF1,PRSF2,PRSF3,SEG1,SEG2 - .; - .;GET THE POSITIONAL START AND STOPS FOR THIS SEGMENT - . S SEG1=$P(V,U,1),SEG2=$P(V,U,2) - .;EXISTING PORTION OF F NODE UP TO CURRENT SEGMENT - . S PRSF1=$E(DAYF,1,SEG1-1) - .;CURRENT SEGMENT UP TO END OF DAY - . S PRSF2=$E(DAYZ,SEG1,SEG2) - .;CURRENT F NODE PAST CURRENT SEGMENT TO END OF THE TOUR WHICH - .;MAY FALL IN TODAY OR NEXT DAY. - .S PRSF3=$E(DAYF,SEG2+1,999) - .; - .;UPDATE THE DAY ARRAY AND THE TMP GLOBAL WITH WORK STRING. - .;EACH CHAR THAT IS SET TO 1 REPRESENTS A 15 MIN SEGMENT THAT - .;THE FIREFIGHTER WAS SCHEDULED FOR ADDITIONAL FF HRS. - .;FOR TOURS CROSSING MIDNIGHT THIS STRING WILL BE LONGER THAN 96 - .;CHARACTERS. CHARACTERS IN POSITIONS PAST 96 REPRESENT TIMES PAST - .;MIDNIGHT OF THE CURRENT DAY (TOMORROW). - .S PRSFFHR=PRSF1_PRSF2_PRSF3 - .S DAY(DY,"F")=PRSFFHR - .S ^TMP($J,"PRS8",DY,"F")=PRSFFHR - ; - I DY<15 S X=$E(DAYH,97,999) I X'?."0" S ^TMP($J,"PRS8",DY+1,"HOL")=X_$E($G(^TMP($J,"PRS8",DY+1,"HOL")),$L(X)+1,999),DAY(DY+1,"HOL")=X - ; -MOVE ; --- entry point for just moving previous days hrs to today - I $D(DAY(DY-1,"N")),$L(DAY(DY-1,"N")) D - .S X=DAY(DY-1,"N")_$E(DAY(DY,"W"),$L(DAY(DY-1,"N"))+1,96) - .S DAY(DY,"W")=X - I $D(DAY(DY-1,"P1")),$L(DAY(DY-1,"P1")) D - .S X=DAY(DY-1,"P1")_$E(DAY(DY,"P"),$L(DAY(DY-1,"P1"))+1,96) - .S DAY(DY,"P")=X - I $D(DAY(DY-1,"rN")),$L(DAY(DY-1,"rN")) D - .S X=DAY(DY-1,"rN")_$E(DAY(DY,"r"),$L(DAY(DY-1,"rN"))+1,96) - .S DAY(DY,"r")=X - ; -END ; --- all done here - K CNT,OC,Q,S,SB,SL,SLP,T,VAR1,X,Y Q - ; -SET ; --- set WK variable - I (DY=0&(T<97))!(DY=14&(T>96))!(DY>14) Q - S ZZ=WK,WK=$S(DY>7:2,1:1) - I TYP'["D",DY=7,T>96 S WK=2 - S $P(WK(WK),"^",Y)=$P(WK(WK),"^",Y)+1 - ; - ; The passing of Public Law 106-554 allows taking ML in hours. - ; ML will now be recorded in 15 minute segments in the WK(3) array - ; for employees entitled to take ML in hours. PRS*4.0*69 - ; - I VAR1="M",$$MLINHRS^PRSAENT(DFN) D - . S WK=3,Y=11 - . S $P(WK(WK),"^",Y)=$P(WK(WK),"^",Y)+1 - ; - ; IF a part-time employee and they have either LWOP or Non-Pay - ; THEN decrement total hours for the week and the pay period. - ; PRS*4.0*52. - ; - I "Wn"[VAR1,TYP["P" S TH=TH-1,TH(WK)=TH(WK)-1 - S WK=ZZ Q +PRS8AC ;HISC/MRL-DECOMPOSITION, ACTIVITY STRING ;01/22/04 + ;;4.0;PAID;**40,45,54,52,69,75,90,96**;Sep 21, 1995 + ; + ;The primary purpose of this routine is to create the activity + ;string [the "W" node] for each day of activity. While creating + ;this string certain counts will also be tallied. These include + ;Standby, On-Call and the various absence categories. Actual + ;Call Back hrs are also counted in this routine for the purpose + ;of reducing the OC later on in the process. + ; + ;Called by Routines: PRS8EX, PRS8ST. + ; + Q:VAR="" + I $S($P(V,"^",1)="":1,$P(V,"^",2)="":1,1:0) Q ;no times + S Q=0 + I DY>0,DY<15 D G END:Q + .I DAY(DY,"OFF"),"LSWARUHFGD"[VAR S Q=1 ;exc invalid day off VAR + K OC,FLAG + ; + S DAYZ=DAY(DY,"W")_$G(DAY(DY,"N")),MTM=0 + S DAYH=$G(DAY(DY,"HOL"))_$G(DAY(DY+1,"HOL")) ;holiday node + ; + ;P 45 FIREFIGHTERS F NODE TO TRACK ADDITIONAL FF HRS + S DAYF=$G(DAY(DY,"F")) + ; + F T=+V:1:+$P(V,"^",2) D + .I +VAR,$E(DAYH,T),$E(DAYZ,T)?1A Q ;no override holiday + .I VAR="A"&(JURY=1) S VAR="J" + .S VAR1=VAR Q:VAR1="" S DAYZ(1)=$E(DAYZ,T) + .I "HhJLSARWMNUnVXYTFGD"[VAR1,$E(DAYZ,T)="m" Q + .I T=+V,"12345E"[VAR1 S DAY(DY,"DWK")=1 ;count days worked + .I T=+V,"Vh"[VAR1,TYP["I" S DAY(DY,"DWK")=1 ;count days worked for cop + .I "JLSWNnARUXYFGD"[VAR1,T'>96,'$E(DAYZ,T) Q ;invalid outside tour + .I "EOPQT4"[VAR1,T'>96,$E(DAYZ,T) Q ;can't earn ct/use ot during work + .I "OE"[VAR1,"BC"[DAYZ(1),$L(DAYZ(1)) D ; Change OT or CT to CB/SB OT + ..S VAR1=$C($A($E(DAYZ,T))+32) + ..I $E(DAYZ,T)="C",VAR="E" S VAR1="t" ; Comp time on on-call = "t" + .I "BC"[VAR1,DAYZ(1)="O",$L(DAYZ(1)) D ; Change CB/SB to CB/SB OT + ..S VAR1=$C($A($E(VAR1))+32) + .I "Hh"[VAR1 D Q:VAR1="H" + ..S DAYH=$E(DAYH,0,T-1)_$S(VAR1="H":1,$E(DAYZ,T)&($E(DAYZ,T)'=4)!(TYP["I")!(TYP["P"&(TYP["N"!(TYP["H")))!(VAR1="h"):2,1:0)_$E(DAYH,T+1,999) ;holiday node + ..I VAR1="h" S VAR1="O" ;convert HW to OT + ..I VAR="h",$E(DAYZ,T)=5 S FLAG=5 + .I $E(DAYZ,T)=5,"ALSRUFGD"[VAR1 S VAR1=$E(DAYZ,T) + .I $E(DAYZ,T)="-","BbCctes"[VAR1 Q ;unavail for oc/sb or sch ot/ct + .S DAYZ=$E(DAYZ,0,T-1)_VAR1_$E(DAYZ,T+1,999) I $E($G(DAY(DY-1,"N")),T)'="",VAR1'=$E($G(DAY(DY-1,"N")),T) S DAY(DY-1,"N")=$E(DAY(DY-1,"N"),0,T-1)_VAR1_$E(DAY(DY-1,"N"),T+1,999) ;save VAR + .I VAR1="J" S Y=5 D SET ;set authorized absence for jury duty + .I VAR1="M" S Y=5 D SET ; authorized absence for ML + .;ot on non-premium T&L + .I ("Eocb"[VAR1!(VAR1="O"&'$E(DAYH,T)))&("^^10^11^12^13^15^16^"[("^"_$P(V,"^",4)_"^"))!(VAR1=5&("ALSRUFGD"[VAR))!(VAR1=4&(TYP["P"!(TYP["I"&(TYP["N"!(TYP["H"!($$HYBRID^PRSAENT1($G(DFN)))))))&("^7^9^11^12^14^"[("^"_$P(V,"^",4)_"^"))) D + ..Q:$E(DAY(DY,"P"),T)=5&("ALSRUFGD"'[VAR) + ..I $D(FLAG) S FLAG=VAR1,VAR1=5 + ..N CODE D + ...I "^7^8^12^"[("^"_$P(V,"^",4)_"^")&(TYP["N"!(TYP["H")!($$HYBRID^PRSAENT1($G(DFN)))) S CODE="N" Q + ...I "^7^8^12^"[("^"_$P(V,"^",4)_"^")&(PMP'="")&("^S^T^U^V^"[(U_PMP_U)) S CODE="N" Q + ...I $P(V,"^",4)=11,($$HYBRID^PRSAENT1($G(DFN))) S CODE="N" Q + ...I $P(V,"^",4)=11&(PMP'="")&("^S^T^U^V^"[(U_PMP_U)) S CODE="N" Q + ...I "^7^8^9^11^"[("^"_$P(V,"^",4)_"^")&(TYP'["N")&(TYP'["H")&('$$HYBRID^PRSAENT1($G(DFN))) S CODE="n" Q + ...I "^7^8^9^11^"[("^"_$P(V,"^",4)_"^")&("^S^T^U^V^"'[(U_PMP_U)) S CODE="n" Q + ...I VAR1=5 S CODE=VAR Q + ...S CODE=1 + ..S DAY(DY,"P")=$E(DAY(DY,"P"),0,T-1)_CODE_$E(DAY(DY,"P"),T+1,999) + .I "ALSRUFGD"[VAR,VAR1=5 S VAR1=VAR + .I $D(FLAG) S VAR1=FLAG K FLAG + .; +FOPTHR .; part time hrs (PT/PH 8b codes) for CODE O firefighters + .I +VAR1,"Ff"[TYP,PMP="O",(NH=448!(NH>320&(NH(1)'=NH(2)))) S Y=32 D SET + .; +FRCPTHR .; part time hrs (PT/PH 8b codes) for code R & C firefighters + .; don't include UNSCHEDULED REGULAR (var1=4) + .I +VAR1,VAR1'=4,"Ff"[TYP,"RC"[PMP S Y=32 D SET + .; + .;patch 45 & 54 + .; Set non pay hrs in the basic tour for firefighters with premium + .;pay indicator of C. + .I "nW"[VAR1,"Ff"[TYP,"C"=PMP D + ..; + ..; Y designates location in WK array where NT/NH will be stored. + ..; F node was set to 1 for periods of addtl ff hrs during 1st pass + ..; thru scheduled ToD. Count NT/NH if this is not addtl ff hrs. + ..; + ..I '$E(DAY(DY,"F"),T) S Y=47 D SET + .S S="LSWnAREUP HYXOVQTFGD" I S[VAR1&(DY>0&(DY<15)!(DY=0&(T>96))) D ;save in WK array + ..S S(1)=$F(S,VAR1)-1 + ..S S=$P("1^2^3^4^5^6^0^8^0^9^24^42^43^0^33^0^19^44^45^46","^",S(1)) ;WK location + ..Q:S=0 + ..; Patch *40 removed A (authorized absence) from leave counted in LU. + ..; LU is only used to determine if night differential granted for + ..; leave should be backed out. + ..I TYP'["D","LSRUFGD"[VAR1 S LU=LU+1 ;increment leave counter + ..I TYP'["D","LSRUFGD"[VAR1,(DY=0!(DY=14)&(T>96)),LU>0 S LU=LU-1 + ..S Y=S D SET S:TYP["D" Q=1 + ..K S,VAR1 + ; + ; + S DAY(DY,"W")=$E(DAYZ,1,96) ;todays activity + S DAY(DY,"N")=$E(DAYZ,97,999) ;tomorrows activity from today/if any + S:$E(DAY(DY,"P"),97,999)'="" DAY(DY,"P1")=$E(DAY(DY,"P"),97,999) ;non-prem ot for next day + S DAY(DY,"P")=$E(DAY(DY,"P"),1,96) ;non-prem ot for today + I DAY(DY,"N")?1"0"."0" S DAY(DY,"N")="" + S DAY(DY,"HOL")=$E(DAYH,1,96) + ; + ;P 45 FIREFIGHTER ADDITIONAL FIREFIGHTER HRS NODE FOR THIS DAY + I $G(PRS8AFFH) D + . N PRSFFHR,PRSF1,PRSF2,PRSF3,SEG1,SEG2 + .; + .;GET THE POSITIONAL START AND STOPS FOR THIS SEGMENT + . S SEG1=$P(V,U,1),SEG2=$P(V,U,2) + .;EXISTING PORTION OF F NODE UP TO CURRENT SEGMENT + . S PRSF1=$E(DAYF,1,SEG1-1) + .;CURRENT SEGMENT UP TO END OF DAY + . S PRSF2=$E(DAYZ,SEG1,SEG2) + .;CURRENT F NODE PAST CURRENT SEGMENT TO END OF THE TOUR WHICH + .;MAY FALL IN TODAY OR NEXT DAY. + .S PRSF3=$E(DAYF,SEG2+1,999) + .; + .;UPDATE THE DAY ARRAY AND THE TMP GLOBAL WITH WORK STRING. + .;EACH CHAR THAT IS SET TO 1 REPRESENTS A 15 MIN SEGMENT THAT + .;THE FIREFIGHTER WAS SCHEDULED FOR ADDITIONAL FF HRS. + .;FOR TOURS CROSSING MIDNIGHT THIS STRING WILL BE LONGER THAN 96 + .;CHARACTERS. CHARACTERS IN POSITIONS PAST 96 REPRESENT TIMES PAST + .;MIDNIGHT OF THE CURRENT DAY (TOMORROW). + .S PRSFFHR=PRSF1_PRSF2_PRSF3 + .S DAY(DY,"F")=PRSFFHR + .S ^TMP($J,"PRS8",DY,"F")=PRSFFHR + ; + I DY<15 S X=$E(DAYH,97,999) I X'?."0" S ^TMP($J,"PRS8",DY+1,"HOL")=X_$E($G(^TMP($J,"PRS8",DY+1,"HOL")),$L(X)+1,999),DAY(DY+1,"HOL")=X + ; +MOVE ; --- entry point for just moving previous days hrs to today + I $D(DAY(DY-1,"N")),$L(DAY(DY-1,"N")) D + .S X=DAY(DY-1,"N")_$E(DAY(DY,"W"),$L(DAY(DY-1,"N"))+1,96) + .S DAY(DY,"W")=X + I $D(DAY(DY-1,"P1")),$L(DAY(DY-1,"P1")) D + .S X=DAY(DY-1,"P1")_$E(DAY(DY,"P"),$L(DAY(DY-1,"P1"))+1,96) + .S DAY(DY,"P")=X + ; +END ; --- all done here + K CNT,OC,Q,S,SB,SL,SLP,T,VAR1,X,Y Q + ; +SET ; --- set WK variable + I (DY=0&(T<97))!(DY=14&(T>96))!(DY>14) Q + S ZZ=WK,WK=$S(DY>7:2,1:1) + I TYP'["D",DY=7,T>96 S WK=2 + S $P(WK(WK),"^",Y)=$P(WK(WK),"^",Y)+1 + ; + ; The passing of Public Law 106-554 allows taking ML in hours. + ; ML will now be recorded in 15 minute segments in the WK(3) array + ; for employees entitled to take ML in hours. PRS*4.0*69 + ; + I VAR1="M",$$MLINHRS^PRSAENT(DFN) D + . S WK=3,Y=11 + . S $P(WK(WK),"^",Y)=$P(WK(WK),"^",Y)+1 + ; + ; IF a part-time employee and they have either LWOP or Non-Pay + ; THEN decrement total hours for the week and the pay period. + ; PRS*4.0*52. + ; + I "Wn"[VAR1,TYP["P" S TH=TH-1,TH(WK)=TH(WK)-1 + S WK=ZZ Q diff --git a/r/PAID-PRS/PRS8CR.m b/r/PAID-PRS/PRS8CR.m index 617a1a27..30bd29af 100644 --- a/r/PAID-PRS/PRS8CR.m +++ b/r/PAID-PRS/PRS8CR.m @@ -1,80 +1,75 @@ -PRS8CR ;HISC/MRL-DECOMPOSITION, CREATE STRING ;01/17/07 - ;;4.0;PAID;**2,6,45,69,112**;Sep 21, 1995;Build 54 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ;This routine take the information contained in the WK array - ;and creates the activity string to be passed to Austin. The - ;WK(1) node contains those items pertaining to Week 1 activity, - ;WK(2) contains those items pertaining to Week 2 activity and - ;WK(3) contains the Miscellaneous information shown on the bottom - ;of the timecard. - ; - ;Called by Routines: PRS8DR - ; - ;Variable S contains the lengths of each of the Values for the - ;different time codes. Used to format values with leading and - ;trailing zero's - N MLINHRS - S MLINHRS=$$MLINHRS^PRSAENT(DFN) - S S="333333333333333333333333333333333443623233333333333" - S E(1)="ANSKWDNOAURTCECUUNNANBSPSASBSCDADBDCTFOAOBOCYAOKOMRARBRCHAHBHCPTPAONYDHDVCEA EB TATCFAFCADNTRSSRSDND" - S E(2)="ALSLWPNPABRLCTCOUSNRNSSQSESFSGDEDFDGTGOEOFOGYEOSOURERFRGHLHMHNPHPBCLYHHOVSEC ED TBTDFBFDAFNHRNSSSHNU" - S E(3)="NLDWINTLLULNLDDTTOLAMLCAPCCYRRFFFECD" - K V S V="" F I=1,2,3 S V(I)="" - ; - ;Next section gets Week 1 and Week 2 data and stores in V(WK) - F J=1,2 F I=1:1:38,40,42:1:51 S X=+$P(WK(J),"^",I) I X]"" D - .; Don't report PT/PT for nurses on AWS schedules - .Q:$E(AC,2)=1&($P(C0,U,16)=72)&(I=32) ; 36/40 AWS - .Q:$E(AC,2)=2&($P(C0,U,16)=80)&(I=32) ; 9month AWS - .; - .I TYP'["D",I'=38,I'=40 D QH - .I TYP["D" S X=+X_"0" - .I TYP["Pd",$E(ENT,2)'="D",$P(WK(J),"^",32)="",V(J)="" S V(J)=V(J)_$S(J=1:"PT000",J=2:"PH000",1:"") ;for p/t drs put PT,PH in 8B string even if they are 0 (PT+PH=NH) - .I I=32,TYP["P",TYP["N",TYP'["B"!(TYP["H"),'X D Q - ..S X=$E("0000000",0,+$E(S,I)-$L(X))_X - ..S V(J)=V(J)_$E(E(J),I+(I-1),I*2)_X - ..Q - .I I=37,$P(C0,"^",20)="P",$P(C0,"^",21)="U" D - ..S X=$E("0000000",0,+$E(S,I)-$L(X))_X - ..I 'X S V(J)=V(J)_$E(E(J),I+(I-1),I*2)_X - ..Q - .S X=+X I I=32,TYP["Pd",X=0 S X=1 - .Q:'X - .I I=32,TYP["Pd",X=1 S X=0 - .I I=38!(I=40) D - ..S Z=X,X=4*$P(WK(J),"^",I+1) D QH - ..S X=($E("00",0,$E(S,I)-$L(Z))_+Z)_($E("000",0,$E(S,I+1)-$L(+X))_+X) ;combine env. diff. % and hours - ..Q - .E S X=$E("0000000",0,+$E(S,I)-$L(X))_+X - .I +X S V(J)=V(J)_$E(E(J),I+(I-1),I*2)_X,V=V+X - ; - ;Now we get miscellaneous data - ; - S S="22134446114423146" - F I=1:1:17 S X=$P(WK(3),"^",I) I X'="" D - .I I=11 D - . . I MLINHRS D QH ; Convert to 1/4 hours. - . . I MLINHRS=0 S X=X_"0" ; Convert to 1/4 hours. - .S X=$E("000000",0,+$E(S,I)-$L(X))_X - .I $D(X) S V(3)=V(3)_$E(E(3),I+(I-1),I*2)_X,V=V+X - ; - ;finish up - ; - S VAL="" I $L(V(1))!($L(V(2)))!($L(V(3))) S X=V(1)_V(2)_V(3)_"CD"_$E("000000",0,6-$L(+V))_+V,VAL=X - ; -STUB ; --- enter here to create stub only - I '($D(VAL)#2) S VAL="" - ; code below to add CP field to STUB record (32nd position) - S CPFX="" - S CPFX=$P($G(^PRST(458,PY,"E",DFN,0)),"^",6) ;get CP from 458 - I CPFX="" S CPFX=$P($G(^PRSPC(DFN,1)),"^",7) ;if 458 null get from 450 - I "0"[CPFX S CPFX=" " ;if it is 0 or "" set CPFX = " " - S PPE=$G(^PRST(458,+PY,0)),PPE=$P(PPE,"^",1),PPI=+PY D ^PRSAXSR - S VAL=HDR_CPFX_VAL ;decomp no longer saves 8B in 5 node (6/95) - K I,J,S Q - ; -QH ; --- for persons paid hourly/convert to Quarter Hours - ; - I I'=37 S X1=X#4,X=X\4_+X1 K X1 - Q +PRS8CR ;HISC/MRL-DECOMPOSITION, CREATE STRING ;8/23/01 + ;;4.0;PAID;**2,6,45,69**;Sep 21, 1995 + ; + ;This routine take the information contained in the WK array + ;and creates the activity string to be passed to Austin. The + ;WK(1) node contains those items pertaining to Week 1 activity, + ;WK(2) contains those items pertaining to Week 2 activity and + ;WK(3) contains the Miscellaneous information shown on the bottom + ;of the timecard. + ; + ;Called by Routines: PRS8DR + ; + ;Variable S contains the lengths of each of the Values for the + ;different time codes. Used to format values with leading and + ;trailing zero's + N MLINHRS + S MLINHRS=$$MLINHRS^PRSAENT(DFN) + S S="33333333333333333333333333333333344362323333333" + S E(1)="ANSKWDNOAURTCECUUNNANBSPSASBSCDADBDCTFOAOBOCYAOKOMRARBRCHAHBHCPTPAONYDHDVCEA EB TATCFAFCADNT" + S E(2)="ALSLWPNPABRLCTCOUSNRNSSQSESFSGDEDFDGTGOEOFOGYEOSOURERFRGHLHMHNPHPBCLYHHOVSEC ED TBTDFBFDAFNH" + S E(3)="NLDWINTLLULNLDDTTOLAMLCAPCCYRRFFFECD" + K V S V="" F I=1,2,3 S V(I)="" + ; + ;Next section gets Week 1 and Week 2 data and stores in V(WK) + F J=1,2 F I=1:1:38,40,42,43,44,45,46,47 S X=+$P(WK(J),"^",I) I X]"" D + .I TYP'["D",I'=38,I'=40 D QH + .I TYP["D" S X=+X_"0" + .I TYP["Pd",$E(ENT,2)'="D",$P(WK(J),"^",32)="",V(J)="" S V(J)=V(J)_$S(J=1:"PT000",J=2:"PH000",1:"") ;for p/t drs put PT,PH in 8B string even if they are 0 (PT+PH=NH) + .I I=32,TYP["P",TYP["N",TYP'["B"!(TYP["H"),'X D Q + ..S X=$E("0000000",0,+$E(S,I)-$L(X))_X + ..S V(J)=V(J)_$E(E(J),I+(I-1),I*2)_X + ..Q + .I I=37,$P(C0,"^",20)="P",$P(C0,"^",21)="U" D + ..S X=$E("0000000",0,+$E(S,I)-$L(X))_X + ..I 'X S V(J)=V(J)_$E(E(J),I+(I-1),I*2)_X + ..Q + .S X=+X I I=32,TYP["Pd",X=0 S X=1 + .Q:'X + .I I=32,TYP["Pd",X=1 S X=0 + .I I=38!(I=40) D + ..S Z=X,X=4*$P(WK(J),"^",I+1) D QH + ..S X=($E("00",0,$E(S,I)-$L(Z))_+Z)_($E("000",0,$E(S,I+1)-$L(+X))_+X) ;combine env. diff. % and hours + ..Q + .E S X=$E("0000000",0,+$E(S,I)-$L(X))_+X + .I +X S V(J)=V(J)_$E(E(J),I+(I-1),I*2)_X,V=V+X + ; + ;Now we get miscellaneous data + ; + S S="22134446114423146" + F I=1:1:17 S X=$P(WK(3),"^",I) I X'="" D + .I I=11 D + . . I MLINHRS D QH ; Convert to 1/4 hours. + . . I MLINHRS=0 S X=X_"0" ; Convert to 1/4 hours. + .S X=$E("000000",0,+$E(S,I)-$L(X))_X + .I $D(X) S V(3)=V(3)_$E(E(3),I+(I-1),I*2)_X,V=V+X + ; + ;finish up + ; + S VAL="" I $L(V(1))!($L(V(2)))!($L(V(3))) S X=V(1)_V(2)_V(3)_"CD"_$E("000000",0,6-$L(+V))_+V,VAL=X + ; +STUB ; --- enter here to create stub only + I '($D(VAL)#2) S VAL="" + ; code below to add CP field to STUB record (32nd position) + S CPFX="" + S CPFX=$P($G(^PRST(458,PY,"E",DFN,0)),"^",6) ;get CP from 458 + I CPFX="" S CPFX=$P($G(^PRSPC(DFN,1)),"^",7) ;if 458 null get from 450 + I "0"[CPFX S CPFX=" " ;if it is 0 or "" set CPFX = " " + S PPE=$G(^PRST(458,+PY,0)),PPE=$P(PPE,"^",1),PPI=+PY D ^PRSAXSR + S VAL=HDR_CPFX_VAL ;decomp no longer saves 8B in 5 node (6/95) + K I,J,S Q + ; +QH ; --- for persons paid hourly/convert to Quarter Hours + ; + I I'=37 S X1=X#4,X=X\4_+X1 K X1 + Q diff --git a/r/PAID-PRS/PRS8DR.m b/r/PAID-PRS/PRS8DR.m index b8ce2cf6..a5807fe0 100644 --- a/r/PAID-PRS/PRS8DR.m +++ b/r/PAID-PRS/PRS8DR.m @@ -1,77 +1,68 @@ -PRS8DR ;HISC/MRL,JAH/WCIOFO-DECOMPOSITION, DRIVER ;4/09/2007 - ;;4.0;PAID;**22,29,56,90,111,112**;Sep 21, 1995;Build 54 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ;This routine determines whether or not the parameters necessary - ;to decompose time are in existence. The majority of variables - ;involving processing an individual employee are defined in this - ;routine. - ; - ;The following lines establish variables necessary to process a - ;specific employees time for the specified pay period. - ; - ;Called by Routines: PRS8, PRS8DR (tag 1) - ; - N PRVAL,RESTORE - ; - D ONE^PRS8CV ;clean up variables - S SAVE=+$G(SAVE),SEE=+$G(SEE) - S TMTD=$G(^PRST(458,+PY,"E",DFN,0)),TMTD=$S($P(TMTD,"^",2)="X":1,1:0) - K WK F I=1,2,3 S WK(I)="" ;weekly totals (wk3=misc data) - D ^PRSAENT S VAL="" ;get entitlement (ENT) - I PP="S" G END ;Manila citizen/don't decompose/no stub - I $G(PB)["$" G STUB^PRS8CR ;don't decompose stipend/create stub - ; Set NAWS to type of AWS - N NAWS - S NAWS=0 - I "KM"[$E(AC,1),$E(AC,2)=1,NH=72 S NAWS="36/40 AWS" - I $E(AC,1)="M",$E(AC,2)=2,NH=80 S NAWS="9Mo AWS" - ; - I "^P^X^"[(U_$P($G(^PRST(458,+PY,"E",DFN,0)),"^",2)_U) S RESTORE=1 - D AUTOPINI^PRS8(+PY,+DFN,$G(RESTORE),.PRVAL) ; remove auto-posted data - S DOUB=0 I $E(ENT,26),$E(ENT,29) S DOUB=1 ;count standby & oncall same - S FLX="" S FLX=$P($G(^PRST(458,+PY,"E",DFN,0)),"^",6) - I +NAWS=36 S FLX="C" - S (SST,TAL)="",X=$P(C0,"^",8) I X'="" D ;T&L Unit - .S X=$O(^PRST(455.5,"B",X,0)) ;get ien - .S TAL=$G(^PRST(455.5,+X,0)),X=$P(TAL,"^",8) ;get sleep start time - .I $L(X) S (NDAY,LAST,Y,Y1)=0 D 15^PRS8SU - .S SST=$S(+X:X,1:93) K X,Y1,LAST,X ;sleep start time - .K SL,SB,ST ;make sure standby variable don't exist - S (CAMISC,CYA,CYA2806,WPCYA,LU)=0 ; << ADDED >> calendar year adjust./leave used in pp - S (NH(1),NH(2))=0 ;normal hrs/pp total/week(1)/week(2) - S (TH,TH(1),TH(2))=0 ;total hours - N CT S (CT(1),CT(2))=0 ; counter for compensatory time - K DWK S DWK=0 ;count of days worked - for intermittents - S NH=NH/.25 ;turn Norm hrs into 15min increments - K TOUR S (TOUR(1),TOUR(2))="" ;tour code for wg/week(1)/week(2) - K TYP S TYP="" I $E(ENT)="D"!($E(ENT,1,2)="0D") S TYP=TYP_"D" ;daily pay basis - I PP?1N.E!(PP="U") S TYP=TYP_"W" ;wagegrade - I PP'="","KM"[PP S TYP=TYP_"N" ;nurse - I +$E(AC,2)=1,NH=192 S TYP=TYP_"B" ;baylor plan - I $G(PMP)'="","EF"[PMP S TYP=TYP_"H" ;Nurse Hybrid - I $E($G(AC),2)=3 S TYP=TYP_"I" ;intermittent - I NH>320 S TYP=TYP_"F" I NH'>448 S TYP=TYP_"f" ;firefighter - ; Nurses on the 9month AWS will be treated as FT employees during the 9 months - ; that they are working. Prevent a "P" from being added to TYP. - I NH,NH'>319,$E(AC,2)'=1 S TYP=TYP_"P" ;part-time - I PP="L",$E(AC,2)=2 S TYP=TYP_"d" ;doctor - I PP="L",$E(AC,2)=1 S TYP=TYP_"dR" ;doctor/resident or intern - S (PTH,PTH(1),PTH(2))=0 ;part-time hours - K WKL S (WKL(1),WKL(2))=0 ;count leave used in week during ND hours - K MEAL S $P(MEAL,"1^",14)="",MEAL=MEAL_1 ;mealtime - S (MILV,WCMP)=0 ;ML and PC indicators - S (CBCK(1),CBCK(2))=0 ;call back hrs by week counter - I TYP="" S TYP="*" - K I,PB,PP,X,X1,X2 - D ^PRS8SU ;set up employee variables and commence decomposing - D ^PRS8CR - D:$D(PRVAL) AUTOPRES^PRS8(+PY,+DFN,.PRVAL) ; restore auto-posted data - I SEE D ^PRS8VW - ; -END ; --- This is where we end this process - G ONE^PRS8CV ;clean up - Q - ; -1 ; --- enter here to print single entry and close device - D ^PRS8DR,^%ZISC Q +PRS8DR ;HISC/MRL,JAH/WCIOFO-DECOMPOSITION, DRIVER ;1/25/2007 + ;;4.0;PAID;**22,29,56,90,111**;Sep 21, 1995;Build 2 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; + ;This routine determines whether or not the parameters necessary + ;to decompose time are in existance. The majority of variables + ;involving processing an individual employee are defined in this + ;routine. + ; + ;The following lines establish variables necessary to process a + ;specific employees time for the specified pay period. + ; + ;Called by Routines: PRS8, PRS8DR (tag 1) + ; + N PRVAL,RESTORE + ; + D ONE^PRS8CV ;clean up variables + S SAVE=+$G(SAVE),SEE=+$G(SEE) + S TMTD=$G(^PRST(458,+PY,"E",DFN,0)),TMTD=$S($P(TMTD,"^",2)="X":1,1:0) + K WK F I=1,2,3 S WK(I)="" ;weekly totals (wk3=misc data) + D ^PRSAENT S VAL="" ;get entitlement (ENT) + I PP="S" G END ;manilla citizen/don't decompose/no stub + I $G(PB)["$" G STUB^PRS8CR ;don't decompose stipend/create stub + I "^P^X^"[(U_$P($G(^PRST(458,+PY,"E",DFN,0)),"^",2)_U) S RESTORE=1 + D AUTOPINI^PRS8(+PY,+DFN,$G(RESTORE),.PRVAL) ; remove auto-posted data + S DOUB=0 I $E(ENT,26),$E(ENT,29) S DOUB=1 ;count standby & oncall same + S FLX="" S FLX=$P($G(^PRST(458,+PY,"E",DFN,0)),"^",6) + S (SST,TAL)="",X=$P(C0,"^",8) I X'="" D ;T&L Unit + .S X=$O(^PRST(455.5,"B",X,0)) ;get ien + .S TAL=$G(^PRST(455.5,+X,0)),X=$P(TAL,"^",8) ;get sleep start time + .I $L(X) S (NDAY,LAST,Y,Y1)=0 D 15^PRS8SU + .S SST=$S(+X:X,1:93) K X,Y1,LAST,X ;sleep start time + .K SL,SB,ST ;make sure standby variable don't exist + S (CAMISC,CYA,CYA2806,WPCYA,LU)=0 ; << ADDED >> calendar year adjust./leave used in pp + S (NH(1),NH(2))=0 ;normal hrs/pp total/week(1)/week(2) + S (TH,TH(1),TH(2))=0 ;total hours + N CT S (CT(1),CT(2))=0 ; counter for compensatory time + K DWK S DWK=0 ;count of days worked - for intermittents + S NH=NH/.25 ;turn Norm hrs into 15min increments + K TOUR S (TOUR(1),TOUR(2))="" ;tour code for wg/week(1)/week(2) + K TYP S TYP="" I $E(ENT)="D"!($E(ENT,1,2)="0D") S TYP=TYP_"D" ;daily pay basis + I PP?1N.E!(PP="U") S TYP=TYP_"W" ;wagegrade + I PP'="","KM"[PP S TYP=TYP_"N" ;nurse + I +$E(AC,2)=1,NH=192 S TYP=TYP_"B" ;baylor plan + I $G(PMP)'="","EF"[PMP S TYP=TYP_"H" ;Nurse Hybrid + I $E($G(AC),2)=3 S TYP=TYP_"I" ;intermittent + I NH>320 S TYP=TYP_"F" I NH'>448 S TYP=TYP_"f" ;firefighter + I NH,NH'>319 S TYP=TYP_"P" ;part-time + I PP="L",$E(AC,2)=2 S TYP=TYP_"d" ;doctor + I PP="L",$E(AC,2)=1 S TYP=TYP_"dR" ;doctor/resident or intern + S (PTH,PTH(1),PTH(2))=0 ;part-time hours + K WKL S (WKL(1),WKL(2))=0 ;count leave used in week during ND hours + K MEAL S $P(MEAL,"1^",14)="",MEAL=MEAL_1 ;mealtime + S (MILV,WCMP)=0 ;ML and PC indicators + S (CBCK(1),CBCK(2))=0 ;call back hrs by week counter + I TYP="" S TYP="*" + K I,PB,PP,X,X1,X2 + D ^PRS8SU ;set up employee variables and commence decomposing + D ^PRS8CR + D:$D(PRVAL) AUTOPRES^PRS8(+PY,+DFN,.PRVAL) ; restore auto-posted data + I SEE D ^PRS8VW + ; +END ; --- This is where we end this process + G ONE^PRS8CV ;clean up + Q + ; +1 ; --- enter here to print single entry and close device + D ^PRS8DR,^%ZISC Q diff --git a/r/PAID-PRS/PRS8EX.m b/r/PAID-PRS/PRS8EX.m index 27375b7f..b07771fe 100644 --- a/r/PAID-PRS/PRS8EX.m +++ b/r/PAID-PRS/PRS8EX.m @@ -1,146 +1,145 @@ -PRS8EX ;HISC/MRL,WCIOFO/SAB-DECOMPOSITION, EXCEPTIONS ;1/31/2007 - ;;4.0;PAID;**2,40,56,69,111,112**;Sep 21, 1995;Build 54 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ;This routine is used to process most exceptions to the normal - ;tod. It is used, for example, to determine whether or not the - ;employee is entitled to such exceptions as Leave, OT, etc., - ;and then calls ^PRS8AC to process them. - ; - ;Called by Routines: PRS8ST - ; - S TT=$P(V,"^",3) ;type of time - I TT="OT",+$P(V,"^",4)=8,$E(ENT,18) S TT="TT" ;ot in travel status - I TT="CU",$P(V,"^",4)=6 Q ;comp for religious purposes/don't code - I TT="HW",$E(ENT,1,2)="0D" S TT="RG" - I TT="OT",TYP["P",TYP'["B" S TT="RG" ;To convert Pt ot to RG - I TT="HW",TYP'["D",+V,+$P(V,"^",2) D - .I $P(V,"^",2)-V-1<8 D ; <2 hrs HW - ..S ^TMP($J,"PRS8",DY,"HW")=$G(^TMP($J,"PRS8",DY,"HW"))_$P(V,U,1,2)_U - ..Q - .I TYP["P",$P(V,"^",2)>96 S LEN=$P(V,"^",2)-96 D ;two day tour of HW for part timers - ..S ^TMP($J,"PRS8",DY+1,"HWK")=$G(^TMP($J,"PRS8",DY+1,"HWK"))_1_U_LEN_U - ..K LEN - ..Q - .I TYP["P",TYP["N"!(TYP["H"),'$E(DAY(DY,"W"),+V) D ; part time nurses, uscheduled HW. - ..S ^TMP($J,"PRS8",DY,"HWK")=$G(^TMP($J,"PRS8",DY,"HWK"))_$P(V,U,1,2)_U - ..Q - .Q - S X="^AL^SL^WP^NP^AA^RL^CU^CT^CP^HX^ML^TR^TV^OT^RG^TT^SB^ON^NL^HW^CB^AD^DL^RS" ;code - S X=($F(X,"^"_TT)\3)+4,(X,TT(1))=$P($T(ACT+X),";;",2) ;parameters - S GO=0 I '+X!($E(ENT,+X)) S GO=1 ;entitlement exists-continue - I TT="RG",$E(ENT,2)'=0 S GO=1 ;intermittent - I TT="RG"!(TT="CP"),$E(ENT,2)="D" S DAY(DY,"DWK")=1 ;intrmtnt-count days worked (for RG or CP) - I TT="OT",'GO,$E(ENT,13)!$E(ENT,14) S GO=1 ;entitled to ot - I TT="UN" S GO=1,VAR="-" ;unavailable - I TYP["W",TT="RG",$P(V,"^",4)=7 D - .;wage grade employee working regular unscheduled hours for - .;shift coverage (7) can get shift differential based on the higher - .;of the unscheduled tour's shift or their normal shift. - .;The unscheduled tour and corresponding differential will be saved - .;in the "SD" node and used by PRS8PP when differentials are - .;computed. - .N ST,EN,SD,MID - .S ST=$P(V,"^"),EN=$P(V,"^",2) Q:'ST!'EN - .S MID=ST+EN/2 - .; check for 2day tour and if found use combined tour (recompute MID) - .; to determine appropriate shift differential. - .; if start is 1 (midnight) then check previous day for a similar tour - .; that ended at 96 (midnight). - . I ST=1 D - .. N PRSI,PRSX - .. S PRSX=$G(^TMP($J,"PRS8",DY-1,2)) - .. F PRSI=1:1:7 Q:$P(PRSX,U,(PRSI-1)*4+1)="" D - ... I $P(PRSX,U,(PRSI-1)*4+2)=96,$P(PRSX,U,(PRSI-1)*4+3)="RG",$P(PRSX,U,(PRSI-1)*4+4)=7 S MID=($P(PRSX,U,(PRSI-1)*4+1)+EN+96)/2 - .; if end is 96 (midnight) then check next day for a similar tour that - .; starts at 1 (midnight). - . I EN=96 D - .. N PRSI,PRSX - .. S PRSX=$G(^TMP($J,"PRS8",DY+1,2)) - .. F PRSI=1:1:7 Q:$P(PRSX,U,(PRSI-1)*4+1)="" D - ... I $P(PRSX,U,(PRSI-1)*4+1)=1,$P(PRSX,U,(PRSI-1)*4+3)="RG",$P(PRSX,U,(PRSI-1)*4+4)=7 S MID=(ST+$P(PRSX,U,(PRSI-1)*4+2)+96)/2 - .; determine shift differential (if any) based on unscheduled tour hours - .S SD=0 - .I MID<32.5 S SD=3 ; majority of tour before 8a - .I MID>60.5,MID'>94.5 S SD=2 ; majority of tour after 3p, upto 11:30p - .I MID>94.5,MID<128.5 S SD=3 ; majority of tour after 11:30p, before 8a - .; use employee's normal shift if higher than shift based on hours - .I TOUR>1,TOUR>SD S SD=TOUR - .S:SD ^TMP($J,"PRS8",DY,"SD")=$G(^TMP($J,"PRS8",DY,"SD"))_ST_U_EN_U_SD_U - .Q - I (TT="OT"!(TT="RG")!(TT="CT")),"^13^14^"[("^"_$P(V,"^",4)_"^")!($P(V,"^",4)=12&(TYP["N"!(TYP["H"))) D - .S ^TMP($J,"PRS8",DY,"CB")=$G(^TMP($J,"PRS8",DY,"CB"))_$P(V,"^",1,2)_"^" - .Q - I TYP'["D",TT="HX"!(TT="HW") S GO=1 ;process holiday excused/worked - G END:'GO ;nothing to process - I TT'="UN" S VAR=$P(X,"^",3) ;increment time code - I '$S(VAR'="W":1,'CYA:1,DY0,DY<15 D - ..; Post ML for employees who are charged in days. - ..I VAR="M",$$MLINHRS^PRSAENT(DFN)=0 D - ...S X=$P(TT(1),"^",4) D SET ; military leave & auth. absence - ..I VAR="V",'$G(^TMP($J,"PRS8",DY,"CP")) S X="M",^TMP($J,"PRS8",DY,"CP")=1 D SET ; COP - ..Q - .D ^PRS8AC ;update activity string - .Q - ; Employees with daily tours (TYP["D") - I DY>0,DY<15,VAR="M" S X=$P(TT(1),"^",4) D SET S X=5 D SET G END ;military leave & auth. absence - I DY>0,DY<15,$$HOLIDAY^PRS8UT(PY,DFN,DY) D G END ;holiday-no charge - .I TT="RG" S DAY(DY,"W")=VAR,X=$S('$E(ENT,TOUR+21):9,1:TOUR+28) D SET ; If worked on holiday count it. - .Q - S D=DY - I TT="NP"!($P(DAY(D,0),"^",2)'=1) S DAY(D,"W")=VAR,X=$P(TT(1),"^",4) I X'="",DY>0,DY<15 D SET I VAR="V" S X="M" D SET I VAR="V",TYP["DI",$E(ENT,2)="D" S X=9 D SET ; IF INT RESDNT PAID IN DAYS HAS COP POSTED PAY UN/US ALSO - D ENCAP^PRS8EX0 - ; -END ; --- all done here - K A,D,DD,GO,TT,X,Z - Q - ; -SET ; --- enter here to set without VAL defined - ; Quit if this day has already been counted through the encapsulation - ; check that is performed in ENCAP^PRS8EX0. - Q:$D(^TMP($J,"PRS8",DY,2,0)) - ; - Q:X="K"&($P(V,"^",1)>96)!((X="K")&($D(^TMP($J,"PRS8",DY,"ML")))) S ^TMP($J,"PRS8",DY,"ML")=1 ;stop counting ML twice for two day tours & split tours, but allow PC - I +X S $P(WK(WK),"^",+X)=$P(WK(WK),"^",+X)+1 - E S X=$A(X)-64,$P(WK(3),"^",+X)=$P(WK(3),"^",+X)+1 - Q - ; -ACT ; --- define variable X for action - ; - piece 1 = entitlement (ENT) string $Extract to check - ; - 2 = Literal name of exception - ; - 3 = Time String code (DAY(X,"W")) - ;; - ;;30^Annual Leave^L^1 - ;;31^Sick Leave^S^2 - ;;33^Without Pay^W^3 - ;;36^Non-Pay Status^n^4 - ;;35^Authorized Absence^A^5 - ;;30^Restored Leave^R^6 - ;;28^Comp Used^U^8 - ;;28^Comp Earned^E^7 - ;;37^Continuation of Pay^V^33 - ;;38^Holiday Excused^H - ;;34^Military Leave^M^K - ;;0^Training^X^43 - ;;0^Travel^Y^42 - ;;12^Overtime^O - ;;2^Unscheduled^4^9 - ;;18^OT in Travel Status^T - ;;29^Standby^B - ;;26^On-Call^C - ;;36^Nonpay A/L^N^A - ;;38^Holiday Worked^h - ;;31^Care and Bereavement^F^44 - ;;31^Adoption^G^45 - ;;35^Donor Leave^D^46 - ;;5^Recess^r^48 +PRS8EX ;HISC/MRL,WCIOFO/SAB-DECOMPOSITION, EXCEPTIONS ;1/25/2007 + ;;4.0;PAID;**2,40,56,69,111**;Sep 21, 1995;Build 2 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; + ;This routine is used to process most exceptions to the normal + ;tod. It is used, for example, to determine whether or not the + ;employee is entitled to such exceptions as Leave, OT, etc., + ;and then calls ^PRS8AC to process them. + ; + ;Called by Routines: PRS8ST + ; + S TT=$P(V,"^",3) ;type of time + I TT="OT",+$P(V,"^",4)=8,$E(ENT,18) S TT="TT" ;ot in travel status + I TT="CU",$P(V,"^",4)=6 Q ;comp for religious purposes/don't code + I TT="HW",$E(ENT,1,2)="0D" S TT="RG" + I TT="OT",TYP["P",TYP'["B" S TT="RG" ;To convert Pt ot to RG + I TT="HW",TYP'["D",+V,+$P(V,"^",2) D + .I $P(V,"^",2)-V-1<8 D ; <2 hrs HW + ..S ^TMP($J,"PRS8",DY,"HW")=$G(^TMP($J,"PRS8",DY,"HW"))_$P(V,U,1,2)_U + ..Q + .I TYP["P",$P(V,"^",2)>96 S LEN=$P(V,"^",2)-96 D ;two day tour of HW for part timers + ..S ^TMP($J,"PRS8",DY+1,"HWK")=$G(^TMP($J,"PRS8",DY+1,"HWK"))_1_U_LEN_U + ..K LEN + ..Q + .I TYP["P",TYP["N"!(TYP["H"),'$E(DAY(DY,"W"),+V) D ; part time nurses, uscheduled HW. + ..S ^TMP($J,"PRS8",DY,"HWK")=$G(^TMP($J,"PRS8",DY,"HWK"))_$P(V,U,1,2)_U + ..Q + .Q + S X="^AL^SL^WP^NP^AA^RL^CU^CT^CP^HX^ML^TR^TV^OT^RG^TT^SB^ON^NL^HW^CB^AD^DL" ;code + S X=($F(X,"^"_TT)\3)+4,(X,TT(1))=$P($T(ACT+X),";;",2) ;parameters + S GO=0 I '+X!($E(ENT,+X)) S GO=1 ;entitlement exists-continue + I TT="RG",$E(ENT,2)'=0 S GO=1 ;intermittent + I TT="RG"!(TT="CP"),$E(ENT,2)="D" S DAY(DY,"DWK")=1 ;intrmtnt-count days worked (for RG or CP) + I TT="OT",'GO,$E(ENT,13)!$E(ENT,14) S GO=1 ;entitled to ot + I TT="UN" S GO=1,VAR="-" ;unavailable + I TYP["W",TT="RG",$P(V,"^",4)=7 D + .;wage grade employee working regular unscheduled hours for + .;shift coverage (7) can get shift differential based on the higher + .;of the unscheduled tour's shift or their normal shift. + .;The unscheduled tour and corresponding differential will be saved + .;in the "SD" node and used by PRS8PP when differentials are + .;computed. + .N ST,EN,SD,MID + .S ST=$P(V,"^"),EN=$P(V,"^",2) Q:'ST!'EN + .S MID=ST+EN/2 + .; check for 2day tour and if found use combined tour (recompute MID) + .; to determine appropriate shift differential. + .; if start is 1 (midnight) then check previous day for a similar tour + .; that ended at 96 (midnight). + . I ST=1 D + .. N PRSI,PRSX + .. S PRSX=$G(^TMP($J,"PRS8",DY-1,2)) + .. F PRSI=1:1:7 Q:$P(PRSX,U,(PRSI-1)*4+1)="" D + ... I $P(PRSX,U,(PRSI-1)*4+2)=96,$P(PRSX,U,(PRSI-1)*4+3)="RG",$P(PRSX,U,(PRSI-1)*4+4)=7 S MID=($P(PRSX,U,(PRSI-1)*4+1)+EN+96)/2 + .; if end is 96 (midnight) then check next day for a similar tour that + .; starts at 1 (midnight). + . I EN=96 D + .. N PRSI,PRSX + .. S PRSX=$G(^TMP($J,"PRS8",DY+1,2)) + .. F PRSI=1:1:7 Q:$P(PRSX,U,(PRSI-1)*4+1)="" D + ... I $P(PRSX,U,(PRSI-1)*4+1)=1,$P(PRSX,U,(PRSI-1)*4+3)="RG",$P(PRSX,U,(PRSI-1)*4+4)=7 S MID=(ST+$P(PRSX,U,(PRSI-1)*4+2)+96)/2 + .; determine shift differential (if any) based on unscheduled tour hours + .S SD=0 + .I MID<32.5 S SD=3 ; majority of tour before 8a + .I MID>60.5,MID'>94.5 S SD=2 ; majority of tour after 3p, upto 11:30p + .I MID>94.5,MID<128.5 S SD=3 ; majority of tour after 11:30p, before 8a + .; use employee's normal shift if higher than shift based on hours + .I TOUR>1,TOUR>SD S SD=TOUR + .S:SD ^TMP($J,"PRS8",DY,"SD")=$G(^TMP($J,"PRS8",DY,"SD"))_ST_U_EN_U_SD_U + .Q + I (TT="OT"!(TT="RG")!(TT="CT")),"^13^14^"[("^"_$P(V,"^",4)_"^")!($P(V,"^",4)=12&(TYP["N"!(TYP["H"))) D + .S ^TMP($J,"PRS8",DY,"CB")=$G(^TMP($J,"PRS8",DY,"CB"))_$P(V,"^",1,2)_"^" + .Q + I TYP'["D",TT="HX"!(TT="HW") S GO=1 ;process holiday excused/worked + G END:'GO ;nothing to process + I TT'="UN" S VAR=$P(X,"^",3) ;increment time code + I '$S(VAR'="W":1,'CYA:1,DY0,DY<15 D + ..; Post ML for employees who are charged in days. + ..I VAR="M",$$MLINHRS^PRSAENT(DFN)=0 D + ...S X=$P(TT(1),"^",4) D SET ; military leave & auth. absence + ..I VAR="V",'$G(^TMP($J,"PRS8",DY,"CP")) S X="M",^TMP($J,"PRS8",DY,"CP")=1 D SET ; COP + ..Q + .D ^PRS8AC ;update activity string + .Q + ; Employees with daily tours (TYP["D") + I DY>0,DY<15,VAR="M" S X=$P(TT(1),"^",4) D SET S X=5 D SET G END ;military leave & auth. absence + I DY>0,DY<15,$$HOLIDAY^PRS8UT(PY,DFN,DY) D G END ;holiday-no charge + .I TT="RG" S DAY(DY,"W")=VAR,X=$S('$E(ENT,TOUR+21):9,1:TOUR+28) D SET ; If worked on holiday count it. + .Q + S D=DY + I TT="NP"!($P(DAY(D,0),"^",2)'=1) S DAY(D,"W")=VAR,X=$P(TT(1),"^",4) I X'="",DY>0,DY<15 D SET I VAR="V" S X="M" D SET I VAR="V",TYP["DI",$E(ENT,2)="D" S X=9 D SET ; IF INT RESDNT PAID IN DAYS HAS COP POSTED PAY UN/US ALSO + D ENCAP^PRS8EX0 + ; +END ; --- all done here + K A,D,DD,GO,TT,X,Z + Q + ; +SET ; --- enter here to set without VAL defined + ; Quit if this day has already been counted through the encapsulation + ; check that is performed in ENCAP^PRS8EX0. + Q:$D(^TMP($J,"PRS8",DY,2,0)) + ; + Q:X="K"&($P(V,"^",1)>96)!((X="K")&($D(^TMP($J,"PRS8",DY,"ML")))) S ^TMP($J,"PRS8",DY,"ML")=1 ;stop counting ML twice for two day tours & split tours, but allow PC + I +X S $P(WK(WK),"^",+X)=$P(WK(WK),"^",+X)+1 + E S X=$A(X)-64,$P(WK(3),"^",+X)=$P(WK(3),"^",+X)+1 + Q + ; +ACT ; --- define variable X for action + ; - piece 1 = entitlement (ENT) string $Extract to check + ; - 2 = Literal name of exception + ; - 3 = Time String code (DAY(X,"W")) + ;; + ;;30^Annual Leave^L^1 + ;;31^Sick Leave^S^2 + ;;33^Without Pay^W^3 + ;;36^Non-Pay Status^n^4 + ;;35^Authorized Absence^A^5 + ;;30^Restored Leave^R^6 + ;;28^Comp Used^U^8 + ;;28^Comp Earned^E^7 + ;;37^Continuation of Pay^V^33 + ;;38^Holiday Excused^H + ;;34^Military Leave^M^K + ;;0^Training^X^43 + ;;0^Travel^Y^42 + ;;12^Overtime^O + ;;2^Unscheduled^4^9 + ;;18^OT in Travel Status^T + ;;29^Standby^B + ;;26^On-Call^C + ;;36^Nonpay A/L^N^A + ;;38^Holiday Worked^h + ;;31^Care and Bereavement^F^44 + ;;31^Adoption^G^45 + ;;35^Donor Leave^D^46 diff --git a/r/PAID-PRS/PRS8HD.m b/r/PAID-PRS/PRS8HD.m index 647403cf..d6c3b315 100644 --- a/r/PAID-PRS/PRS8HD.m +++ b/r/PAID-PRS/PRS8HD.m @@ -1,177 +1,176 @@ -PRS8HD ;HISC/MGD-DECOMPOSITION, DETERMINE HOLIDAYS ;12/07/2007 - ;;4.0;PAID;**4,33,72,88,94,98,113,118**;Sep 21, 1995;Build 1 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ;This routine is used to determine legal holidays. One calls - ;^PRS8HD with nothing defined if one wants all holidays in the - ;next year. Tag EN can be called with PRS8D defined as a VA - ;FileManager format date from which to calculate holidays. See - ;later documentation in this routine regarding further processing - ;instructions. - ; - K PRS8D - ; -EN ;--- entry point - ; pass PRS8D as date you want in VA FileMan format - ; - where only year, i.e., 92 is passed, the first day is presumed - ; pass PRS8D(0) containing a holiday code if specific one wanted - ; if neither PRS8D or PRS8D(0) passed DT is assumed and all - ; holidays for next year are returned - ; - N CT,D,DD,DDQ,DN,DX,NY,%Y,PRSDT1 ;new variables used - K HD,HO,PRS8D(1) ;remove existing array if there - I '($D(DT)#2) D DT^DICRW ;get DT if none - S X=$G(PRS8D) I X']"" S X=DT ;use DT if no X - K %DT D ^%DT S X=Y I Y'>0 S PRS8D(1)=-1 G END ;bad date - I '+$E(X,4,5) S X=$E(X,1,3)_"01"_$S(+$E(X,6,7):$E(X,6,7),1:"01") - S PRSDT1=X - ; - ; Build sorted list (by month) of recurring holidays in array H() - ; If specific holiday code passed just get it, else get all. - ; Note that holiday code "E" is not a recurring holiday so it is - ; handled in another section after the recurring holidays are done. - S (CT,NY)=0,X1=$G(PRS8D(0)),X2="^K^P^M^I^L^C^V^T^X^N^" - I X1]"",X2[("^"_X1_"^") S X1=$F(X2,X1)-1\2+1,J=$P($T(H+(X1+6)),";;",2),H($P(J,"^",2),$P(J,"^",1))=$P(J,"^",3,5) - E I X1'="E" F I=1:1 S J=$P($T(H+(I+7)),";;",2) Q:J="" S H($P(J,"^",2),$P(J,"^",1))=$P(J,"^",3,5) ;get dates by month - ; - ; build output arrays for the recurring holidays -PASS ;--- come back here for a second pass if necessary - S DN=X,D(1)=+$E(X,1,3),D(2)=0 F S D(2)=$O(H(D(2))),D(3)="" Q:'D(2) F S D(3)=$O(H(D(2),D(3))) Q:D(3)="" D - .S DD=H(D(2),D(3)) - .S D=D(1)+($S(D(2)<(+$E(DN,4,5)):1,1:0))_$E("00",0,2-$L(D(2)))_D(2)_$E(DN,6,7) - .I '$P(DD,"^",2) D - ..S (DX,X)=$E(D,1,5)_$E("00",0,2-$L(+$P(DD,"^",1)))_+$P(DD,"^",1) - ..D DW^%DTC S Y=%Y,X=DX - ..Q ;I Y,Y'=6 Q - ..S X2=$S('Y:"",1:"-")_1,X1=X D C^%DTC - .E D - ..S (DX,X)=$E(D,1,5)_"01" - ..D DW^%DTC S Y=%Y,X=DX - ..I Y'=+DD D - ...I +Y<+DD S X2=DD-Y - ...E S X2=7-(+Y)+DD - ...S X1=X D C^%DTC - ..I +$P(DD,"^",2)=1 S DX=X Q - ..S DD(1)=X,(DD(2),DD(3),DDQ)=0 F Q:DD(2)&(DDQ) D - ...S X2=7,X1=DD(1) D C^%DTC - ...S DD(2)=X,DDQ=1 - ...I $E(DD(1),1,5)=$E(X,1,5) S DD(1)=X,DDQ=0 - ...S DD(3)=DD(3)+1 I DD(3)=2,+$P(DD,"^",2)=3 S DDQ=1 - ...I DD(3)=1,+$P(DD,"^",2)=4 S DDQ=1 - ...I DD(3)=3,+$P(DD,"^",2)=5 S DDQ=1 - ..S (DX,X)=DD(1) - .D DW^%DTC S Y=%Y,X=DX - .Q:X1 - ..S X=$E(DN,1,3)+1,(DX,X)=X_"0101" - ..D DW^%DTC S Y=%Y,X=DX - ..Q ;Q:Y'=6 - ..S X2=-1,X1=X D C^%DTC S DX=X - ..D DW^%DTC S Y=%Y,X=DX - ..D SET - .K H(D(2),D(3)) - I $O(H(0))>0 D - .S X=+$E(DN,4,5) - .S X=$S(X=12:1,1:(X+1)) - .S X1=$E(DN,1,3)+$S(X=1:1,1:0),X=X1_$E("00",0,2-$L(X))_X_"01" - .D PASS - ; - ;new section to add applicable extra (non-recurring) holidays - I $G(PRS8D(0))=""!($G(PRS8D(0))="E") D - . N PRSDT2,PRSI,PRSX - . S PRSDT2=$$FMADD^XLFDT(PRSDT1,364) - . ; - . ; loop thru the extra holiday list - . F PRSI=1:1 S PRSX=$P($T(EHOL+PRSI),";;",2) Q:PRSX="" D - . . Q:$P(PRSX,U)PRSDT2 ; skip if not within the next year - . . ; need to add this extra holiday to list - . . S HD($P(PRSX,U))=$P(PRSX,U,2,3) - . . S HO("E",$P(PRSX,U))="" - . . S CT=CT+1 - . ; - . ; quit if site is not in the Washington DC area - . Q:"^101^688^"'[(U_$E($$STA^XUAF4(+$$KSP^XUPARAM("INST")),1,3)_U) - . ; - . ; loop thru additional DC location extra holiday list - . F PRSI=1:1 S PRSX=$P($T(EHOLDC+PRSI),";;",2) Q:PRSX="" D - . . Q:$P(PRSX,U)PRSDT2 ; skip if not within the next year - . . ; need to add this extra holiday to list - . . S HD($P(PRSX,U))=$P(PRSX,U,2,3) - . . S HO("E",$P(PRSX,U))="" - . . S CT=CT+1 - ; - S PRS8D(1)=$S(CT:+CT,1:-1) - ; -END ;--- That's all folks - K %DT,H,I,J,X,X1,X2,Y Q - ; -SET ;--- set nodes - S HD(X)=D(3)_"^"_$P("SUN^MON^TUES^WEDNES^THURS^FRI^SATUR","^",Y+1)_"DAY",HO($P(DD,"^",3),X)="",CT=CT+1 Q - ; -H ;--- Actual Holidays - ; PIECE1 PIECE2 PIECE3 PIECE4 PIECE5 PIECE6 - ; actual month exact day 0=exact holiday how - ; holiday day-of-week 1=1st wk code deter- - ; 2=last wk mined - ; - pc3 and 4 are used in concert 3=3rd wk - ; 4=2nd wk,5=4th wk - ; - ;;M.L. King's Birthday^1^1^3^K^3rd Monday in January - ;;President's Day^2^1^3^P^3rd Monday in February - ;;Memorial Day^5^1^2^M^Last Monday in May - ;;Independence Day^7^4^0^I^July 4 - ;;Labor Day^9^1^1^L^First Monday in September - ;;Columbus Day^10^1^4^C^Second Monday in October - ;;Veterans Day^11^11^0^V^November 11 - ;;Thanksgiving Day^11^4^5^T^Fourth Thursday in November - ;;Christmas Day^12^25^0^X^December 25 - ;;New Year's Day^1^1^0^N^January 1 - ; - ;-Holiday Codes - ; - K = M.L. King P = President's Day M = Memorial Day - ; - I = Independence L = Labor Day C = Columbus Day - ; - V = Veterans Day T = Thanksgiving X = Christmas - ; - E = Extra Holiday (non-recurring) N = New Year's - ; - ;HD(HOLIDAY) is returned by routine equal to "literal^Dow" - ;HO("HOLIDAY CODE",HOLIDAY) is returned equal to null - ;PRS8D* is returned in value passed - ;PRS8D(1) is returned equal to # holidays found or -1 if none - ; - ;--------------------------------------------------------------------- - ;New Section Added for Extra Non-Recurring Holidays (holiday code E) - ; - ; format is - ; FM date of the declared holiday^text^day of week^patch number - ; - ; The following list will need to be updated for years that have an - ; extra Christmas Holiday declared or and declared memorial day for - ; past presidents. - ; -EHOL ; - ;;2940427^President Nixon Funeral^WEDNESDAY^PRS*3.1*2 - ;;2971226^Extra Christmas Day^FRIDAY^PRS*4*33 - ;;3011224^Extra Christmas Day^MONDAY^PRS*4*72 - ;;3031226^Extra Christmas Day^FRIDAY^PRS*4*88 - ;;3040611^President Reagan Funeral^FRIDAY^PRS*4*94 - ;;3070102^President Ford Funeral^TUESDAY^PRS*4*113 - ;;3071224^Extra Christmas Day^MONDAY^PRS*4*118 - ; - ;--------------------------------------------------------------------- - ;New Section Added for Extra Non-Recurring Holidays (holiday code E) - ;that are location specifc to the DC area - ; - ; format is - ; FM date of the declared holiday^text^day of week^patch number - ; - ; The following list will need to be updated when additional specific - ; holidays are declared that only apply to the DC area - ; -EHOLDC ; - ;;3050120^Presidential Inauguration Day^THURSDAY^PRS*4*98 - ; - ;PRS8HD +PRS8HD ;HISC/MGD-DECOMPOSITION, DETERMINE HOLIDAYS ;01/3/2007 + ;;4.0;PAID;**4,33,72,88,94,98,113**;Sep 21, 1995;Build 3 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; + ;This routine is used to determine legal holidays. One calls + ;^PRS8HD with nothing defined if one wants all holidays in the + ;next year. Tag EN can be called with PRS8D defined as a VA + ;FileManager format date from which to calculate holidays. See + ;later documentation in this routine regarding further processing + ;instructions. + ; + K PRS8D + ; +EN ;--- entry point + ; pass PRS8D as date you want in VA FileMan format + ; - where only year, i.e., 92 is passed, the first day is presumed + ; pass PRS8D(0) containing a holiday code if specific one wanted + ; if neither PRS8D or PRS8D(0) passed DT is assumed and all + ; holidays for next year are returned + ; + N CT,D,DD,DDQ,DN,DX,NY,%Y,PRSDT1 ;new variables used + K HD,HO,PRS8D(1) ;remove existing array if there + I '($D(DT)#2) D DT^DICRW ;get DT if none + S X=$G(PRS8D) I X']"" S X=DT ;use DT if no X + K %DT D ^%DT S X=Y I Y'>0 S PRS8D(1)=-1 G END ;bad date + I '+$E(X,4,5) S X=$E(X,1,3)_"01"_$S(+$E(X,6,7):$E(X,6,7),1:"01") + S PRSDT1=X + ; + ; Build sorted list (by month) of recurring holidays in array H() + ; If specific holiday code passed just get it, else get all. + ; Note that holiday code "E" is not a recurring holiday so it is + ; handled in another section after the recurring holidays are done. + S (CT,NY)=0,X1=$G(PRS8D(0)),X2="^K^P^M^I^L^C^V^T^X^N^" + I X1]"",X2[("^"_X1_"^") S X1=$F(X2,X1)-1\2+1,J=$P($T(H+(X1+6)),";;",2),H($P(J,"^",2),$P(J,"^",1))=$P(J,"^",3,5) + E I X1'="E" F I=1:1 S J=$P($T(H+(I+7)),";;",2) Q:J="" S H($P(J,"^",2),$P(J,"^",1))=$P(J,"^",3,5) ;get dates by month + ; + ; build output arrays for the recurring holidays +PASS ;--- come back here for a second pass if necessary + S DN=X,D(1)=+$E(X,1,3),D(2)=0 F S D(2)=$O(H(D(2))),D(3)="" Q:'D(2) F S D(3)=$O(H(D(2),D(3))) Q:D(3)="" D + .S DD=H(D(2),D(3)) + .S D=D(1)+($S(D(2)<(+$E(DN,4,5)):1,1:0))_$E("00",0,2-$L(D(2)))_D(2)_$E(DN,6,7) + .I '$P(DD,"^",2) D + ..S (DX,X)=$E(D,1,5)_$E("00",0,2-$L(+$P(DD,"^",1)))_+$P(DD,"^",1) + ..D DW^%DTC S Y=%Y,X=DX + ..Q ;I Y,Y'=6 Q + ..S X2=$S('Y:"",1:"-")_1,X1=X D C^%DTC + .E D + ..S (DX,X)=$E(D,1,5)_"01" + ..D DW^%DTC S Y=%Y,X=DX + ..I Y'=+DD D + ...I +Y<+DD S X2=DD-Y + ...E S X2=7-(+Y)+DD + ...S X1=X D C^%DTC + ..I +$P(DD,"^",2)=1 S DX=X Q + ..S DD(1)=X,(DD(2),DD(3),DDQ)=0 F Q:DD(2)&(DDQ) D + ...S X2=7,X1=DD(1) D C^%DTC + ...S DD(2)=X,DDQ=1 + ...I $E(DD(1),1,5)=$E(X,1,5) S DD(1)=X,DDQ=0 + ...S DD(3)=DD(3)+1 I DD(3)=2,+$P(DD,"^",2)=3 S DDQ=1 + ...I DD(3)=1,+$P(DD,"^",2)=4 S DDQ=1 + ...I DD(3)=3,+$P(DD,"^",2)=5 S DDQ=1 + ..S (DX,X)=DD(1) + .D DW^%DTC S Y=%Y,X=DX + .Q:X1 + ..S X=$E(DN,1,3)+1,(DX,X)=X_"0101" + ..D DW^%DTC S Y=%Y,X=DX + ..Q ;Q:Y'=6 + ..S X2=-1,X1=X D C^%DTC S DX=X + ..D DW^%DTC S Y=%Y,X=DX + ..D SET + .K H(D(2),D(3)) + I $O(H(0))>0 D + .S X=+$E(DN,4,5) + .S X=$S(X=12:1,1:(X+1)) + .S X1=$E(DN,1,3)+$S(X=1:1,1:0),X=X1_$E("00",0,2-$L(X))_X_"01" + .D PASS + ; + ;new section to add applicable extra (non-recurring) holidays + I $G(PRS8D(0))=""!($G(PRS8D(0))="E") D + . N PRSDT2,PRSI,PRSX + . S PRSDT2=$$FMADD^XLFDT(PRSDT1,364) + . ; + . ; loop thru the extra holiday list + . F PRSI=1:1 S PRSX=$P($T(EHOL+PRSI),";;",2) Q:PRSX="" D + . . Q:$P(PRSX,U)PRSDT2 ; skip if not within the next year + . . ; need to add this extra holiday to list + . . S HD($P(PRSX,U))=$P(PRSX,U,2,3) + . . S HO("E",$P(PRSX,U))="" + . . S CT=CT+1 + . ; + . ; quit if site is not in the Washington DC area + . Q:"^101^688^"'[(U_$E($$STA^XUAF4(+$$KSP^XUPARAM("INST")),1,3)_U) + . ; + . ; loop thru additional DC location extra holiday list + . F PRSI=1:1 S PRSX=$P($T(EHOLDC+PRSI),";;",2) Q:PRSX="" D + . . Q:$P(PRSX,U)PRSDT2 ; skip if not within the next year + . . ; need to add this extra holiday to list + . . S HD($P(PRSX,U))=$P(PRSX,U,2,3) + . . S HO("E",$P(PRSX,U))="" + . . S CT=CT+1 + ; + S PRS8D(1)=$S(CT:+CT,1:-1) + ; +END ;--- That's all folks + K %DT,H,I,J,X,X1,X2,Y Q + ; +SET ;--- set nodes + S HD(X)=D(3)_"^"_$P("SUN^MON^TUES^WEDNES^THURS^FRI^SATUR","^",Y+1)_"DAY",HO($P(DD,"^",3),X)="",CT=CT+1 Q + ; +H ;--- Actual Holidays + ; PIECE1 PIECE2 PIECE3 PIECE4 PIECE5 PIECE6 + ; actual month exact day 0=exact holiday how + ; holiday day-of-week 1=1st wk code deter- + ; 2=last wk mined + ; - pc3 and 4 are used in concert 3=3rd wk + ; 4=2nd wk,5=4th wk + ; + ;;M.L. King's Birthday^1^1^3^K^3rd Monday in January + ;;President's Day^2^1^3^P^3rd Monday in February + ;;Memorial Day^5^1^2^M^Last Monday in May + ;;Independence Day^7^4^0^I^July 4 + ;;Labor Day^9^1^1^L^First Monday in September + ;;Columbus Day^10^1^4^C^Second Monday in October + ;;Veterans Day^11^11^0^V^November 11 + ;;Thanksgiving Day^11^4^5^T^Fourth Thursday in November + ;;Christmas Day^12^25^0^X^December 25 + ;;New Year's Day^1^1^0^N^January 1 + ; + ;-Holiday Codes + ; - K = M.L. King P = President's Day M = Memorial Day + ; - I = Independence L = Labor Day C = Columbus Day + ; - V = Veterans Day T = Thanksgiving X = Christmas + ; - E = Extra Holiday (non-recurring) N = New Year's + ; + ;HD(HOLIDAY) is returned by routine equal to "literal^Dow" + ;HO("HOLIDAY CODE",HOLIDAY) is returned equal to null + ;PRS8D* is returned in value passed + ;PRS8D(1) is returned equal to # holidays found or -1 if none + ; + ;--------------------------------------------------------------------- + ;New Section Added for Extra Non-Recurring Holidays (holiday code E) + ; + ; format is + ; FM date of the declared holiday^text^day of week^patch number + ; + ; The following list will need to be updated for years that have an + ; extra Christmas Holiday declared or and declared memorial day for + ; past presidents. + ; +EHOL ; + ;;2940427^President Nixon Funeral^WEDNESDAY^PRS*3.1*2 + ;;2971226^Extra Christmas Day^FRIDAY^PRS*4*33 + ;;3011224^Extra Christmas Day^MONDAY^PRS*4*72 + ;;3031226^Extra Christmas Day^FRIDAY^PRS*4*88 + ;;3040611^President Reagan Funeral^FRIDAY^PRS*4*94 + ;;3070102^President Ford Funeral^TUESDAY^PRS*4*113 + ; + ;--------------------------------------------------------------------- + ;New Section Added for Extra Non-Recurring Holidays (holiday code E) + ;that are location specifc to the DC area + ; + ; format is + ; FM date of the declared holiday^text^day of week^patch number + ; + ; The following list will need to be updated when additional specific + ; holidays are declared that only apply to the DC area + ; +EHOLDC ; + ;;3050120^Presidential Inauguration Day^THURSDAY^PRS*4*98 + ; + ;PRS8HD diff --git a/r/PAID-PRS/PRS8HR.m b/r/PAID-PRS/PRS8HR.m index f523121c..042c9f7c 100644 --- a/r/PAID-PRS/PRS8HR.m +++ b/r/PAID-PRS/PRS8HR.m @@ -1,190 +1,210 @@ -PRS8HR ;HISC/MRL,WCIOFO/JAH-DECOMPOSITION, HOURS ;06/25/07 - ;;4.0;PAID;**2,22,29,42,52,102,108,112**;Sep 21, 1995;Build 54 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ;This routine is called by ^PRS8PP (premium pay calculator) - ;===================================================================== - ; ** indicates incompleted comments - ; - ;VARIABLE DEFINITION - ; - ; TYP = contains codes representing type of employee. - ; It's a composite code string w/ characters that - ; represent pay plan, duty basis, & normal hours. - ; CODE REPRESENTS CODE REPRESENTS - ; D daily f firefighter - ; W wagegrade P part-time - ; N nurse d doctor - ; B baylor plan dR doctor/resident or intern - ; H Nurse Hybrid "" * - ; I intermittent - ; VAL = Single char code represents employee's work status for - ; current 15 min increment. - ; FLX = Flex tour indicator. - ; TH(W) = Tour Hours for week 1, TH(1) & week 2, TH(2) - ; TH = Tour Hours - ; HTP = PAYABLE hours worked today. - ; HT = Hours worked today. - ; AV = String w/ most normal types of time (see bottom of PRS8EX) - ; does NOT contain premium times or unscheduled time (OoEes4) - ;==================================================================== - ; - S AV="1235nHMLSWNARUXYVJFGD" - ; - ; Loop thru each quarter hour segment of day. - ; Check for times in AV array. - ; Proceed w/ calculation if Overtime worked on Holiday. - ; - F M=1:1:96 D - . S VAL=$E(D,M) - .; - .; If non premium type of time or (overtime on holiday) - .; - . I AV[VAL!(VAL="O"&($E(DAY(DAY,"HOL"),M)=2)) D CALC - Q - ; - ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - ; -CALC ; --- Entry point for calculating placement of time - ; - ; Set up variables for calculations and comparisons in this routine - ; - N HOLWKD,HOLEX,HOLWKEX - D ^PRS8HRSV - ; - ; IF intermittent employee on continuation of pay OR overtime on - ; holiday THEN increment Pay Period tour hours and current weeks - ; tour hours. - ; - I TYP["I",VAL["V"!(VAL="O"&(HOLWKD)) S TH=TH+1,TH(W)=TH(W)+1 - ; - ; IF part time doctor & total hours = 80 & type of - ; time is unscheduled, overtime, comptime THEN quit - ; - I TYP["d",TYP["P",TH=320,"4OosEe"[VAL Q - ; - ; IF INT doctor & total hours = 80 THEN quit - ; - I TYP["I",$E(AC,1)="L",TH=320,"4OosEe"[VAL Q - ; - ; IF type of time is anything but Leave Without Pay "W" or Non-Pay "n" - ; THEN increment total hrs HT & increment HTP. Also update - ; ^TMP global for reference during the processing of On-Call (PRS8OC). - ; - I "Wn"'[VAL S HT=HT+1,HTP=HTP+1,^TMP($J,"PRS8",DAY,"HT")=HT - ; - ;--------------------------------------------------------- - ; IF entitled to VCS commission sales & normal time(1) ??(2,3) - ; & holiday excused set X to type of time=Piece Worker Hol excused. - ; Then IF part time set X to part time hours code. - ; - I $E(ENT,38),"123"[VAL,HOLEX S X=36 D CHK^PRS8HRSV D Q:X - . I TYP["P" S X=32 D CHK^PRS8HRSV - ; - ;--------------------------------------------------------------- - ; - ; Don't mess w/ fire fighters - ; - Q:"Ff"[TYP - ; - S GO=0 - ; IF compressed tour & parttime & tour hours are over 80 - ; OR tour hours = 80 & it's overtime, comptime, or unscheduled reg. - ; - ; Check for FT Compressed - I $E(AC,2)=1,NH>319,FLX="C",("OoseE4"[VAL) S GO=1 - ; - ; Check for week - I (TH(W)>160&("OoseE4"[VAL))!(TH(W)=160&("OosEe4"[VAL)) S GO=1 - ; - ; Check for day - I HT>32,"OoseE4"[VAL S GO=1 - ; - ; Following segment is concerned w/ variations of part time - ; employees (TYP["P"), & 1 baylor (TYP["B"). - ;------------------------------------------------------------------- - ; - ; Doctor over 8 hours - ; - I TYP["Pd",HT>32 S GO=0 ; part-time doctors PT + PH must = NH - ; - I TYP["P",HOLWKD S GO=0 - ; - ; Baylor plan & ct/ot/s - ; - I TYP["B","EeOos"[VAL S GO=1 - ; - ;------------------------------------------------------------------- - ; GO set in cases where employee maybe eligible for OT - ; due to over > 8/day OR > 40/week. - ; - S X=0 I GO D TH^PRS8HRSV D OVER840^PRS8HROT Q - ; - ;------------------------------------------------------------------- - ;------------------------------------------------------------------- - ; GO not set for compressed schedule of at least 80 hrs. - ; GO not set for non compressed schedule of over 40 hrs. - ; IF GO is set and we are evaluating normal hours or - ; HOLIDAY OVERTIME use NORMHRS to increment TIME - ; in week array. THEN QUIT. - ; - S GO=1 - I FLX="C",NH>319 S GO=0 - I FLX'="C",NH(WK)>160,TYP'["Pd" S GO=0 ;IF pt-doctor don't set GO=0 - I GO,"1235nHMLSWNARUXYVJFGD"[VAL!(VAL="O"&(HOLWKD)) D NORMHRS^PRS8HROT Q - ; - ;-------------------------------------------------------------------- - ; Check employees with Normal hours less than 80. (Baylor NH=320) - ; - I NH'>319!(($E(AC,2)=2)&(NH=320)) D TH^PRS8HRSV D Q - .I FLX="C" D Q:X - ..; - ..; For PT employees review hours worked to determine X - ..I "OosEe4"'[VAL S X=32 ; All tour time = PT/PH - ..; - ..; Checks for CT - ..I "Ee"[VAL D - ...; <8/DAY & <40/WK = UN/US - ...I HT'>32,TH(W)'>160 S X=9 Q - ...S X=7 ; CE/CT - ..; - ..; Checks for all other types of time - ..I "Oos4"[VAL D - ...I HT>32 S X=TOUR+15 Q ; DA/DE - ...I TH(W)>160 S X=TOUR+19 Q ; OA/OE - ...S X=9 ; UN/US - ..D CHK^PRS8HRSV - .; - .; Under 8/day, 40/week, and not coded as overtime or comptime - .; or overtime on holiday. - .; - .; Checks for non-compressed employees - .I HT'>32,TH(W)'>160,"OoseE"'[VAL!(VAL="O"&(HOLWKD)) S X=0 D Q:X - ..; - ..; Not intermittent, normal hours and not unscheduled reg. - ..; TIME gets parttime hours. - ..; - ..I TYP'["I",AV[VAL,VAL'=4 S X=32 D CHK^PRS8HRSV Q - ..; - ..; All else fails - TIME gets unscheduled regular. - ..; - ..S X=9 D CHK^PRS8HRSV Q - .; - .; Part time doctor w/ unscheduled reg. TIME gets unscheduled reg. - .; - .I TYP["P",TYP["d",VAL=4 S X=9 D CHK^PRS8HRSV Q - .; - .; Over 8/day - .; - .I HT>32 D G8^PRS8HRSV Q:X - .; - .; For all time left except comptime set TIME to appropriate OT - .; unless comptime has been worked earlier in the week making - .; the total hours less than 40, then TIME gets unscheduled reg. - .; COMPTIME OVER 8/DAY WILL BE CREDITED HERE - .; - .S X=$S("Ee"'[VAL:TOUR+19,(TH(W)'>160)&(HT'>32):9,1:7) - .I TYP["P",VAL[4,TH(W)'>160,HT'>32 S X=9 - .I TYP["P",VAL="O",TH(W)'>160,HT'>32 S X=9 - .D CHK^PRS8HRSV - Q +PRS8HR ;HISC/MRL,WCIOFO/JAH-DECOMPOSITION, HOURS ;05/05/06 + ;;4.0;PAID;**2,22,29,42,52,102,108**;Sep 21, 1995 + ; + ;This routine is called by ^PRS8PP (premium pay calculator) + ;===================================================================== + ; ** indicates incompleted comments + ; + ;VARIABLE DEFINITION + ; + ; TYP = contains codes representing type of employee. + ; It's a composite code string w/ characters that + ; represent pay plan, duty basis, & normal hours. + ; CODE REPRESENTS CODE REPRESENTS + ; D daily f firefighter + ; W wagegrade P part-time + ; N nurse d doctor + ; B baylor plan dR doctor/resident or intern + ; H Nurse Hybrid "" * + ; I intermittent + ; VAL = Single char code represents employee's work status for + ; current 15 min increment. + ; FLX = Flex tour indicator. + ; TH(W) = Tour Hours for week 1, TH(1) & week 2, TH(2) + ; TH = Tour Hours + ; HTP = PAYABLE hours worked today. + ; HT = Hours worked today. + ; AV = String w/ most normal types of time (see bottom of PRS8EX) + ; does NOT contain premium times or unscheduled time (OoEes4) + ;==================================================================== + ; + S AV="1235nHMLSWNARUXYVJFGD" + ; + ; Loop thru each quarter hour segment of day. + ; Check for times in AV array. + ; Proceed w/ calculation if Overtime worked on Holiday. + ; + F M=1:1:96 D + . S VAL=$E(D,M) + .; + .; If non premium type of time or (overtime on holiday) + .; + . I AV[VAL!(VAL="O"&($E(DAY(DAY,"HOL"),M)=2)) D CALC + Q + ; + ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ; +CALC ; --- Entry point for calculating placement of time + ; + ; Set up variables for calculations and comparisons in this routine + ; + N HOLWKD,HOLEX,HOLWKEX + D ^PRS8HRSV + ; + ; IF intermittent employee on continuation of pay OR overtime on + ; holiday THEN increment Pay Period tour hours and current weeks + ; tour hours. + ; + I TYP["I",VAL["V"!(VAL="O"&(HOLWKD)) S TH=TH+1,TH(W)=TH(W)+1 + ; + ; IF part time doctor & total hours = 80 & type of + ; time is unscheduled, overtime, comptime THEN quit + ; + I TYP["d",TYP["P",TH=320,"4OosEe"[VAL Q + ; + ; IF INT doctor & total hours = 80 THEN quit + ; + I TYP["I",$E(AC,1)="L",TH=320,"4OosEe"[VAL Q + ; + ; IF type of time is anything but (leave w/out pay, comp time) + ; THEN increment total hrs(HT) & increment HTP if type of + ; time not non pay or leave w/out pay. + ; + ; Update daily counter - *102 added non-pay back into daily count + ; + S HT=HT+1,HTP=HTP+1 + ; + ;--------------------------------------------------------- + ; IF entitled to VCS commission sales & normal time(1) ??(2,3) + ; & holiday excused set X to type of time=Piece Worker Hol excused. + ; Then IF part time set X to part time hours code. + ; + I $E(ENT,38),"123"[VAL,HOLEX S X=36 D CHK^PRS8HRSV D Q:X + . I TYP["P" S X=32 D CHK^PRS8HRSV + ; + ;--------------------------------------------------------------- + ; + ; Don't mess w/ fire fighters + ; + Q:"Ff"[TYP + ; + S GO=0 + ; IF compressed tour & parttime & tour hours are over 80 + ; OR tour hours = 80 & it's overtime, comptime, or unscheduled reg. + ; + ; Check for FT Compressed + I NH>319,FLX="C",("OoseE4"[VAL) S GO=1 + ; + ; Check for week + I (TH(W)>160&("OoseE4"[VAL))!(TH(W)=160&("OosEe4"[VAL)) S GO=1 + ; + ; Check for day + I HT>32,"OoseE4"[VAL S GO=1 + ; + ; Following segment is concerned w/ variations of part time + ; employees (TYP["P"), & 1 baylor (TYP["B"). + ;------------------------------------------------------------------- + ; + ; Doctor over 8 hours + ; + I TYP["Pd",HT>32 S GO=0 ; part-time doctors PT + PH must = NH + ; + I TYP["P",HOLWKD S GO=0 + ; + ; Baylor plan & ct/ot/s + ; + I TYP["B","EeOos"[VAL S GO=1 + ; + ;------------------------------------------------------------------- + ; GO set in cases where employee maybe eligible for OT + ; due to over > 8/day OR > 40/week. + ; + S X=0 I GO D TH^PRS8HRSV D OVER840^PRS8HROT Q + ; + ;------------------------------------------------------------------- + ;------------------------------------------------------------------- + ; GO not set for compressed schedule of at least 80 hrs. + ; GO not set for non compressed schedule of over 40 hrs. + ; IF GO is set and we are evaluating normal hours or + ; HOLIDAY OVERTIME use NORMHRS to increment TIME + ; in week array. THEN QUIT. + ; + S GO=1 + I FLX="C",NH>319 S GO=0 + I FLX'="C",NH(WK)>160,TYP'["Pd" S GO=0 ;IF pt-doctor don't set GO=0 + I GO,"1235nHMLSWNARUXYVJFGD"[VAL!(VAL="O"&(HOLWKD)) D NORMHRS^PRS8HROT Q + ; + ;-------------------------------------------------------------------- + ; Check employees with Normal hours less than 80. (Baylor NH=320) + ; + I NH'>319 D TH^PRS8HRSV D Q + .I FLX="C" D Q:X + ..; + ..; For PT employees review hours worked to determine X + ..I "OosEe4"'[VAL S X=32 ; All tour time = PT/PH + ..; + ..; Checks for CT + ..I "Ee"[VAL D + ...; <8/DAY & <40/WK = UN/US + ...I HT'>32,TH(W)'>160 S X=9 Q + ...S X=7 ; CE/CT + ..; + ..; Checks for all other types of time + ..I "Oos4"[VAL D + ...I HT>32 S X=TOUR+15 Q ; DA/DE + ...I TH(W)>160 S X=TOUR+19 Q ; OA/OE + ...S X=9 ; UN/US + ..D CHK^PRS8HRSV + .; + .; Under 8/day, 40/week, and not coded as overtime or comptime + .; or overtime on holiday. + .; + .; Checks for non-compressed employees + .I HT'>32,TH(W)'>160,"OoseE"'[VAL!(VAL="O"&(HOLWKD)) S X=0 D Q:X + ..; + ..; Not intermittent, normal hours and not unscheduled reg. + ..; TIME gets parttime hours. + ..; + ..I TYP'["I",AV[VAL,VAL'=4 S X=32 D CHK^PRS8HRSV Q + ..; + ..; All else fails - TIME gets unscheduled regular. + ..; + ..S X=9 D CHK^PRS8HRSV Q + .; + .; Part time doctor w/ unscheduled reg. TIME gets unscheduled reg. + .; + .I TYP["P",TYP["d",VAL=4 S X=9 D CHK^PRS8HRSV Q + .; + .; Over 8/day + .; + .I HT>32 D G8^PRS8HRSV Q:X + .; + .; For all time left except comptime set TIME to appropriate OT + .; unless comptime has been worked earlier in the week making + .; the total hours less than 40, then TIME gets unscheduled reg. + .; COMPTIME OVER 8/DAY WILL BE CREDITED HERE + .; + .S X=$S("Ee"'[VAL:TOUR+19,(TH(W)'>160)&(HT'>32):9,1:7) + .I TYP["P",VAL[4,TH(W)'>160,HT'>32 S X=9 + .D CHK^PRS8HRSV + Q + ; + ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ; ### DELETE UNLESS EARLIER CHECK WAS RESTORED +CT2DAY() ;Determine if comptime eligible including 2 day tour. + ; + N TOUREC,TWODAY + S (RTN,TWODAY)=0 + ; + ; IF time segment contains Scheduled or unscheduled comptime + ; or overtime and there is some time in tour hours worked THEN + ; check if it's a 2 day tour. For 2 day tours some of time worked + ; won't be in HT variable since it occured on other day of two + ; day tour, it's not valid to simply check the HT variable for + ; 8 hours of work. (patch PRS*4*22) + ; + I "OosEe4"[VAL,(HT>0),(NH>319) D + .S TOUREC=$P($G(DAY(DAY,0)),"^",2) + .I TOUREC>0 S TWODAY=$P($G(^PRST(457.1,TOUREC,0)),"^",5) + .I TWODAY="Y" S RTN=1 + Q RTN diff --git a/r/PAID-PRS/PRS8HRSV.m b/r/PAID-PRS/PRS8HRSV.m index 0c313751..05c8c2c2 100644 --- a/r/PAID-PRS/PRS8HRSV.m +++ b/r/PAID-PRS/PRS8HRSV.m @@ -1,219 +1,198 @@ -PRS8HRSV ;WCIOFO/JAH-HOLIDAY FLAG, TIME CHECKER, WK() SET; 04/05/07 - ;;4.0;PAID;**29,52,102,108,112**;Sep 21, 1995;Build 54 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; Set up variable for holiday worked or holiday excused - ; Holiday worked coded 2 in DAY array - ; Holiday excused coded 1 in DAY array - ; A NON holiday is coded as all zero's in day array. - ; - ; HOLIDAY WORKED - S HOLWKD=$E(DAY(DAY,"HOL"),M)=2 - ; - ; HOLIDAY EXCUSED - S HOLEX=$E(DAY(DAY,"HOL"),M)=1 - ; - ; HOLIDAY EXCUSED OR HOLIDAY WORKED - S HOLWKEX=$E(DAY(DAY,"HOL"),M) - Q - ; - ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - ; -CHK ; --- Check ENT for acceptable X value - ; Pieces of Y have values in locations corresponding to premium - ; times in value of X. Values in Y string are locations - ; in entitlement string where associated time in X is - ; located. - ; -------------------------------------------------- - ; | Fixed | Premium - ; Piece | Position in| Type Of Time - ; Of Y-String | Entitlement| - ; & **WK() | String | - ; ----------- | -----------| -------------------- - ; 7 | 28 | comp earned - ; 9 | 2 | unscheduled regular - ; 16 | 19 | hrs excess 8-d - ; 17 | 20 | hrs excess 8-d2 - ; 18 | 21 | hrs excess 8 d3 - ; 20 | 12 | OT total hrs d - ; 21 | 13 | OT total hrs d2 - ; 22 | 14 | OT total hrs d3 - ; --------------------------------------------------- - ; - N ZZ S Y="^^^^^^28^^2^^^^^^^19^20^21^^12^13^14^^^^3^4^^^^" - ; - ; Set Y to a premium time in Y string, based on X - ; OR set Y to zero if X is a non premium time or parttime hours. - ; - I X'=32 S Y=+$P(Y,"^",X) - ; - ; IF Y is premium time & not Unscheduled regular but employee not - ; ENTITLED to that type of time THEN set X to zero. - ; - I +Y,Y'=2,'$E(ENT,+Y) S X=0 - ; - ; Overtime & Not entitled set X & Y to unscheduled regular - ; - I "^12^13^14^"[("^"_Y_"^"),'X S X=9,Y=2 - ; - ; IF regular unscheduled (Y=2) & not hourly for regular unscheduled - ; THEN set X=0, unless Baylor then X gets regular unscheduled. - ; - I X,Y=2,$E(ENT,+Y)'="H" S X=$S(TYP'["B":0,1:9) - ; - ; IF 36/40 AWS with WP determine eligibility for OT/CT - ; Skip this check if time is HW (X=29) or OT on Hol (X=24) - ; - I "KM"[$E(AC,1),$E(AC,2)=1,$P(C0,U,16)=72,X'=32,X'=29,X'=24 D - . I HT>32 S X=$S(VAL="O":TOUR+15,VAL="e":7,1:X) Q - . I TH(W)>160 S X=$S(VAL="O":TOUR+19,VAL="e":7,1:X) Q - . I HT'>32,TH(W)'>160 S X=9 - ; - ; If X is hours in excess of 8/day & > 40/week & type of time - ; is compensatory time X = 0 - ; - I "^16^17^18^"[("^"_X_"^"),TH(WK)>160,"Ee"[VAL S X=0 - ; - ; ** Significance of checking "X" now as opposed to Y. - ; - K Y Q:'X - ; - ; (Hours excess 8/day, OT hours, Reg hours @ OT rate, Holiday hours, - ; part time hours) OR unscheduled regular & Nurse or Nurse Hybrid. - ; ### DO WE NEED TO ADD !HYBRID TO THIS CHECK ??? - I "^16^17^18^20^21^22^29^30^31^32^"[("^"_X_"^")!(X=9&(TYP["N"!(TYP["H"))) D - .; - .; If today holiday or holiday benefit day for employee - .; - .I $$HOLIDAY^PRS8UT(PY,DFN,DAY) D Q:'X - ..; - ..; If part time hours & entitled to (Holiday [Shift day, 2 or 3]) - ..; - ..I X=32,$E(ENT,TOUR+21),HOLWKD S ZZ=X,X=$S($G(DAY(DAY,"OFF"))'=1:TOUR+28,1:9) D SET S X=$S(TYP'["I":ZZ,1:9) Q - ..; - ..; IF not part time hours & intermittent employee & employee - ..; entitled to holiday overtime & holiday worked THEN set TIME - ..; to OT on Holiday and credit that TIME in SET. - ..; - ..I X'=32,TYP["I",$E(ENT,25),HOLWKD S ZZ=X,X=24 D SET S X=0 - ..; - ..; IF conditions same as above except employee is NOT entitled - ..; to Holiday OT THEN use X as coded to credit TIME. - ..; - ..I X'=32,TYP["I",'$E(ENT,25),HOLWKD S ZZ=0 D SET S X=9 - ..; - ..; IF not part time hours & emp. is entitled to Holiday OT But - ..; they did not work the holiday THEN if emp. is part time or - ..; intermittent set type of time to Regular hrs @ OT rate 3 - ..; otherwise OT @ Holiday rate & IF the original coded TIME - ..; NOT = reg hrs @ OT rate(shift D,2,3) THEN credit TIME at - ..; OT on holiday or Reg hours @ OT rate. THEN also credit time - ..; as unscheduled regular. ** why code time twice? - ..; - ..I X'=32,$E(ENT,25),'HOLWKD D - ...S ZZ=X - ...; for 36/40 AWS w/ WP or NP report OT on Holiday as (OK/OS) - ...; For 9mo AWS w/ Recess report OT on Holiday as (OK/OS) - ...I +NAWS,VAL["O",$E(DAY(DAY,"HOL"),M)=0 S X=24 D SET S X=0 Q - ...; - ...S X=$S(TYP["P"!(TYP["I"):TOUR+28,1:24) D SET - ...I TYP["P"!(TYP["I") S X=9 D SET - ...S X=0 - .; - .; IF type of time is part time hours for intermittent employee - .; THEN set TIME = unscheduled regular. - .; - .I X=32,TYP["I" S X=9 - .; - .; Part time hours or unscheduled regular. - .; - .Q:X=32!(X=9) - .; - .; IF employee worked holiday THEN set TIME to zero & if original - .; coded type of time is NOT regular hours @ OT rate DO - .; - .I HOLWKD S ZZ=X,X=0 D - ..; - ..; IF entitled to Holiday pay for this shift THEN set TIME - ..; to Holiday HRS (shift d, 2 or 3) - ..; - ..I $E(ENT,TOUR+21) S X=TOUR+28 - ; - ; IF employee is part time & either a nurse or nurse hybrid - ; & they worked the holiday - ; ### SHOULD HYBRID BE ADDED TO THIS CHECK HOW SHOULD THESE HYBRIDS - ; ### TREATED ON A HOLIDAY - I TYP["P",TYP["N"!(TYP["H"),HOLWKD,X=32 D - .; - .; J gets start & stop times for employee's holiday tour. - .; Start/stop times are represented w/ natural numbers - .; from 0-96. Each 15 minute segment of the 24 hour period - .; beginning & ending at midnight can be represented w/ - .; a positive integer. I.e. 1 = mid-12:15am, - .; 2 = 12:15-12:30a ... 96 = 11:45pm-mid. - .; - .; Loop thru each set of start & stop times. IF the single - .; 1/4 hr segment we're working w/ falls w/in any of the nurses - .; start & stop times THEN set TIME to Holiday Hours Day. - .; - .N I,J S J=$G(^TMP($J,"PRS8",DAY,"HWK")),ZZ=X - .; - .F I=1:2 Q:$P(J,U,I)="" I M'<$P(J,U,I),M'>$P(J,U,I+1) S X=29 - .; - .; Holiday hrs-Day. reset X if 2 day tour. Otherwise X = 0. - .; - .I X=29 D SET S X=$S($P(^PRST(457.1,$P(DAY(DAY-1,0),U,2),0),U,5)="Y":ZZ,1:0) - ; - ; -SET ; --- Set value into WK array - ; - ; Nurses on the 36/40 AWS are FT with Normal Hours of 72. Nurses on the 9 month - ; AWS are PT with Normal Hours of 80. Neither will not have Part Time Hours - ; counted in their 8B string. - ; - Q:$E(AC,2)=1&($P(C0,U,16)=72)&(X=32) ; 36/40 AWS - Q:$E(AC,2)=2&(NH=320)&(X=32) ; 9month AWS before any Recess processed - ; - ; Full time employee & part time hours & normal hours WK1 + WK2 - ; = biweekly normal hours. - ; - I $P(C0,"^",10)=1,X=32,NH(1)+NH(2)=NH Q - ; - ; For all types of TIME, increment the WK array. - ; - I +X D Q - . S $P(WK(W),"^",+X)=$P(WK(W),"^",+X)+1 - ; - ; When X is zero, reset to originally coded time. - ; - I 'X S X=ZZ Q - Q - ; - ; -TH ; --- increment total hours & compensatory time hours. - ; Posted RG/OT/CT that is >8/day but < 40/week and < 80/pp will not be - ; counted in TH or TH(W) - ; - ; I $S(VAL=4:1,"osEe"[VAL!(VAL="O"&('HOLWKD)):1,1:0) S TH=TH+1,TH(W)=TH(W)+1 - ; - I $S(VAL=4:1,"osEe"[VAL!(VAL="O"&('HOLWKD)):1,1:0) D - . Q:(HT>32)&(TH(W)<160)&(NH<320)&($E(ENT,19)=1) - . Q:(HT>32)&(TH(W)<160)&(NH=320)&($E(ENT,19)=1)&($E(AC,2)=2) ; 9month AWS - . S TH=TH+1,TH(W)=TH(W)+1 - Q - ; - ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - ; -G8 ; --- Check for greater than 8 hours in day - ; - Q:HTP'>32!(VAL="E") - ; - ; Checks for Hours Excess 8/day (DA/DE) - S X=TOUR+15 D CHK^PRS8HRSV - I X,NH<320,CYA2806>0 S CYA2806=CYA2806-1 - Q:X - ; - ; Checks for OT Total Hours (OA/OE) - I TYP["I"!(TYP["P"),TYP'["B",TH(W)>160 S X=TOUR+19 D CHK^PRS8HRSV - Q - ; - ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +PRS8HRSV ;WCIOFO/JAH-HOLIDAY FLAG, TIME CHECKER, WK() SET; 05/02/06 + ;;4.0;PAID;**29,52,102,108**;Sep 21, 1995 + ; Set up variable for holiday worked or holiday exused + ; Holiday worked coded 2 in DAY array + ; Holiday exused coded 1 in DAY array + ; A NON holiday is coded as all zero's in day array. + ; + ; HOLIDAY WORKED + S HOLWKD=$E(DAY(DAY,"HOL"),M)=2 + ; + ; HOLIDAY EXCUSED + S HOLEX=$E(DAY(DAY,"HOL"),M)=1 + ; + ; HOLIDAY EXCUSED OR HOLIDAY WORKED + S HOLWKEX=$E(DAY(DAY,"HOL"),M) + Q + ; + ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ; +CHK ; --- Check ENT for acceptable X value + ; Pieces of Y have values in locations corresponding to premium + ; times in value of X. Values in Y string are locations + ; in entitlement string where associated time in X is + ; located. + ; -------------------------------------------------- + ; | Fixed | Premium + ; Piece | Position in| Type Of Time + ; Of Y-String | Entitlement| + ; & **WK() | String | + ; ----------- | -----------| -------------------- + ; 7 | 28 | comp earned + ; 9 | 2 | unscheduled regular + ; 16 | 19 | hrs excess 8-d + ; 17 | 20 | hrs excess 8-d2 + ; 18 | 21 | hrs excess 8 d3 + ; 20 | 12 | OT total hrs d + ; 21 | 13 | OT total hrs d2 + ; 22 | 14 | OT total hrs d3 + ; --------------------------------------------------- + ; + N ZZ S Y="^^^^^^28^^2^^^^^^^19^20^21^^12^13^14^^^^3^4^^^^" + ; + ; Set Y to a premium time in Y string, based on X + ; OR set Y to zero if X is a non premium time or parttime hours. + ; + I X'=32 S Y=+$P(Y,"^",X) + ; + ; IF Y is premium time & not Unscheduled regular but employee not + ; ENTITLED to that type of time THEN set X to zero. + ; + I +Y,Y'=2,'$E(ENT,+Y) S X=0 + ; + ; Overtime & Not entitled set X & Y to unscheduled regular + ; + I "^12^13^14^"[("^"_Y_"^"),'X S X=9,Y=2 + ; + ; IF regular unscheduled (Y=2) & not hourly for regular unscheduled + ; THEN set X=0, unless Baylor then X gets regular unscheduled. + ; + I X,Y=2,$E(ENT,+Y)'="H" S X=$S(TYP'["B":0,1:9) + ; + ; If X is hours in excess of 8/day & > 40/week & type of time + ; is compensatory time X = 0 + ; + I "^16^17^18^"[("^"_X_"^"),TH(WK)>160,"Ee"[VAL S X=0 + ; + ; ** Significance of checking "X" now as opposed to Y. + ; + K Y Q:'X + ; + ; (Hours excess 8/day, OT hours, Reg hours @ OT rate, Holiday hours, + ; part time hours) OR unscheduled regular & Nurse or Nurse Hybrid. + ; ### DO WE NEED TO ADD !HYBRID TO THIS CHECK ??? + I "^16^17^18^20^21^22^29^30^31^32^"[("^"_X_"^")!(X=9&(TYP["N"!(TYP["H"))) D + .; + .; If today holiday or holiday benefit day for employee + .; + .I $$HOLIDAY^PRS8UT(PY,DFN,DAY) D Q:'X + ..; + ..; If part time hours & entitled to (Holiday [Shift day, 2 or 3]) + ..; + ..I X=32,$E(ENT,TOUR+21),HOLWKD S ZZ=X,X=$S($G(DAY(DAY,"OFF"))'=1:TOUR+28,1:9) D SET S X=$S(TYP'["I":ZZ,1:9) Q + ..; + ..; IF not part time hours & intermittent employee & employee + ..; entitled to holiday overtime & holiday worked THEN set TIME + ..; to OT on Holiday and credit that TIME in SET. + ..; + ..I X'=32,TYP["I",$E(ENT,25),HOLWKD S ZZ=X,X=24 D SET S X=0 + ..; + ..; IF conditions same as above except employee is NOT entitled + ..; to Holiday OT THEN use X as coded to credit TIME. + ..; + ..I X'=32,TYP["I",'$E(ENT,25),HOLWKD S ZZ=0 D SET S X=9 + ..; + ..; IF not part time hours & emp. is entitled to Holiday OT But + ..; they did not work the holiday THEN if emp. is part time or + ..; intermittent set type of time to Regular hrs @ OT rate 3 + ..; otherwise OT @ Holiday rate & IF the original coded TIME + ..; NOT = reg hrs @ OT rate(shift D,2,3) THEN credit TIME at + ..; OT on holiday or Reg hours @ OT rate. THEN also credit time + ..; as unscheduled regular. ** why code time twice? + ..; + ..I X'=32,$E(ENT,25),'HOLWKD D + ...S ZZ=X + ...S X=$S(TYP["P"!(TYP["I"):TOUR+28,1:24) D SET + ...I TYP["P"!(TYP["I") S X=9 D SET + ...S X=0 + .; + .; IF type of time is part time hours for intermittent employee + .; THEN set TIME = unscheduled regular. + .; + .I X=32,TYP["I" S X=9 + .; + .; Part time hours or unscheduled regular. + .; + .Q:X=32!(X=9) + .; + .; IF employee worked holiday THEN set TIME to zero & if original + .; coded type of time is NOT regular hours @ OT rate DO + .; + .I HOLWKD S ZZ=X,X=0 D + ..; + ..; IF entitled to Holiday pay for this shift THEN set TIME + ..; to Holiday HRS (shift d, 2 or 3) + ..; + ..I $E(ENT,TOUR+21) S X=TOUR+28 + ; + ; IF employee is part time & either a nurse or nurse hybrid + ; & they worked the holiday + ; ### SHOULD HYBRID BE ADDED TO THIS CHECK HOW SHOULD THESE HYBRIDS + ; ### TREATED ON A HOLIDAY + I TYP["P",TYP["N"!(TYP["H"),HOLWKD,X=32 D + .; + .; J gets start & stop times for employee's holiday tour. + .; Start/stop times are represented w/ natural numbers + .; from 0-96. Each 15 minute segment of the 24 hour period + .; beginning & ending at midnight can be represented w/ + .; a positive integer. I.e. 1 = mid-12:15am, + .; 2 = 12:15-12:30a ... 96 = 11:45pm-mid. + .; + .; Loop thru each set of start & stop times. IF the single + .; 1/4 hr segment we're working w/ falls w/in any of the nurses + .; start & stop times THEN set TIME to Holiday Hours Day. + .; + .N I,J S J=$G(^TMP($J,"PRS8",DAY,"HWK")),ZZ=X + .; + .F I=1:2 Q:$P(J,U,I)="" I M'<$P(J,U,I),M'>$P(J,U,I+1) S X=29 + .; + .; Holiday hrs-Day. reset X if 2 day tour. Otherwise X = 0. + .; + .I X=29 D SET S X=$S($P(^PRST(457.1,$P(DAY(DAY-1,0),U,2),0),U,5)="Y":ZZ,1:0) + ; + ; +SET ; --- Set value into WK array + ; + ; Full time employee & part time hours & normal hours WK1 + WK2 + ; = biweekly normal hours. + ; + I $P(C0,"^",10)=1,X=32,NH(1)+NH(2)=NH Q + ; + ; For all types of TIME, increment the WK array. + ; + I +X D Q + . S $P(WK(W),"^",+X)=$P(WK(W),"^",+X)+1 + ; + ; When X is zero, reset to originally coded time. + ; + I 'X S X=ZZ Q + Q + ; + ; +TH ; --- increment total hours & compensatory time hours. + ; Posted RG/OT/CT that is >8/day but < 40/week and < 80/pp will not be + ; counted in TH or TH(W) + ; + ; I $S(VAL=4:1,"osEe"[VAL!(VAL="O"&('HOLWKD)):1,1:0) S TH=TH+1,TH(W)=TH(W)+1 + ; + I $S(VAL=4:1,"osEe"[VAL!(VAL="O"&('HOLWKD)):1,1:0) D + . Q:(HT>32)&(TH(W)<160)&(NH<320)&($E(ENT,19)=1) + . S TH=TH+1,TH(W)=TH(W)+1 + Q + ; + ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ; +G8 ; --- Check for greater than 8 hours in day + ; + Q:HTP'>32!(VAL="E") + ; + ; Checks for Hours Excess 8/day (DA/DE) + S X=TOUR+15 D CHK^PRS8HRSV + I X,NH<320,CYA2806>0 S CYA2806=CYA2806-1 + Q:X + ; + ; Checks for OT Total Hours (OA/OE) + I TYP["I"!(TYP["P"),TYP'["B",TH(W)>160 S X=TOUR+19 D CHK^PRS8HRSV + Q + ; + ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% diff --git a/r/PAID-PRS/PRS8MSC0.m b/r/PAID-PRS/PRS8MSC0.m index b00d8750..50a48591 100644 --- a/r/PAID-PRS/PRS8MSC0.m +++ b/r/PAID-PRS/PRS8MSC0.m @@ -1,182 +1,160 @@ -PRS8MSC0 ;HISC/DAD,WCIOFO/JAH,SAB - MISC TIME CARD ADJUST(contd) ;4/04/2007 - ;;4.0;PAID;**22,35,40,56,111,112**;Sep 21, 1995;Build 54 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ; for employee on daily tour check if no duty performed during week - I TYP["D" D NODUTY^PRS8MSC1 - ; - S B="",Z0="" S $P(B,"B",97)="",$P(Z0,"0",97)="",FLAG=0 - F X=1:1:PEROWK S Y=$P(PEROWK(X),"^",4),DAT=$P(PEROWK(X),"^",1,3),DY=$P(DAT,"^",1),BEG=$P(DAT,"^",2),END=$P(DAT,"^",3) D - .I $L(Y)'<96,TYP'["Ff",$E(ENT,27) D ; slp for 24hr cvg - ..S SLMAX=32,(SLW,SLY,SLST,SLSTR,SLST1,SLY1,SL1,SL2,SL3)="" - ..I END=96 D - ...S SLST=$P($G(PEROWK(X)),"^",4),SL2=$E(SLST,SST,$L(SLST)),SL1=$E(SLST,1,SLMAX-$L(SL2)),SL3=$L(SL2) - ...S SLSTR=SL1_SL2 - ...I DOUB S SLSTR=$TR(SLSTR,"Cct","Bbb") ; if PPC = W then OC = SB - ...S SLSTR=$TR(SLSTR,$TR(SLSTR,"Bb"),Z0) - ...S SLY=$L($TR(SLSTR,"b0")),SLW=$L($TR(SLSTR,"B0")) - ...I SLW>12 Q - ...I DY=0 S FLAG=SL3 - ...S Y=$L(SLSTR)-SLW - ...I FLAG>0&(DY=1) S Y=Y-FLAG,FLAG=0 - ...S D=DY,P=25 D SET Q - ..E D - ...S SLST=$G(^TMP($J,"PRS8",DY,"W"))_$G(^TMP($J,"PRS8",DY+1,"W")) - ...S SLSTR=$E(SLST,1,SST+(SLMAX-1)) - ...I DOUB S SLSTR=$TR(SLSTR,"Cct","Bbb") ; if PPC = W then OC = SB - ...S SLSTR=$TR(SLSTR,$TR(SLSTR,"Bb"),Z0) - ...S SLY=$E(SLSTR,SST,96),SLY1=$E(SLSTR,97,$L(SLSTR)) - ...S SLSTR=SLY_SLY1,SLW=$L($TR(SLSTR,"B0")) - ...I SLW>12 Q - ...S D=DY,Y=$L($TR(SLY,"b0")),P=25 D SET - ...Q:DY=0 S D=DY+1,Y=$L($TR(SLY1,"b0")) D SET - ...Q - ..K BEG,DAT,END,NL,SLW,SLY,SLST,SLSTR,SLST1,SLY1,SL1,SL2,SL3 Q - .Q - S D="",(H,ROSS)=1 K OT,UN,DA,CT - F H=H:ROSS:PEROT D ; calculate CB OT and FF OT/sleep time - .S Y=PEROT(H),Z=$P(Y,"^",3) - .I "Ff"[TYP D ;K OT,UN,DA D ; FF sleep time - ..F M=1:1:$L(Z) D ; following FF OT per Mary Baker 4/1/93 - ...I D'=+Y+(($P(Y,"^",2)+M-2)\96) D - ....S D=+Y+(($P(Y,"^",2)+M-2)\96),HT=0 - ....Q - ...S HT=HT+1 - ...I $E(Z,H)="E" S CT(D)=$G(CT(D))+1 Q - ...I M'>32 S:HT'>32 OT(D)=$G(OT(D))+1 S:HT>32 DA(D)=$G(DA(D))+1 ; FF OT - ...I M>32,$L(Z)'<96&(M'>64)!($L(Z)<96) S DA(D)=$G(DA(D))+1 ; FF hrs>8 - ...I $L(Z)'<96,M>64 D ; FF 2/3 rule - ....I M'>96 S UN(D)=$G(UN(D))+1 ; first 8 sleep time - ....E S DA(D)=$G(DA(D))+1 ; rest hrs >8 - ....Q - ...Q - ..Q - .I $L(Z)<8 D ; call back OT at least 2 hrs - ..S YY=Y,ZZ=Z N X,Y,START,STOP,T,TT,Z,DD,TL S Y=YY,Z=ZZ - ..S CB=$G(^TMP($J,"PRS8",+Y,"CB")) - ..;no call back OT today or send bulletin - ..Q:(CB="")!($$OTNXTPP(+Y,CB,$P(C0,"^",1),PY,$P(C0,"^",8))) - ..S Q=0 F ZZ=1:2 Q:'$P(CB,"^",ZZ) I $P(Y,"^",2)=$P(CB,"^",ZZ) S Q=1 - ..Q:'Q ; this OT episode not call back - ..S OT=Y,START=$P(OT,"^",2),STOP=$P(OT,"^",2)+$L(Z)-1,T=START,TT=$S(T>96:T-96,1:T) - ..S W=$G(^TMP($J,"PRS8",+OT,"W")),WEEK=$S(+OT>7:2,1:1) - ..S W1=$G(^TMP($J,"PRS8",OT-1,"W")) - ..S W2=$G(^TMP($J,"PRS8",OT+1,"W")) - ..S (Z,X)=0 F Z=1:1:8-(STOP-START+1) D Q:X=0 - ...S DD=Z - ...I TT-DD>0 S X=$E(W,TT-DD) - ...E S X=$E(W1,96+T-DD) - ...I "123m"[X,$E($G(^TMP($J,"PRS8",$S(TT-DD>0:+OT,1:OT-1),"HOL")),$S(TT-DD>0:TT-DD,1:96+T-DD))=1 S X=0 ; HX becomes time off - ...Q - ..S ZZ=Z S:X=0&Z ZZ=ZZ-1 S X=0,T=STOP,TT=$S(T>96:T-96,1:T) - ..F Z=1:1:8-(STOP-START+1+ZZ) D Q:X=0 - ...S DD=STOP-START+1+ZZ+Z - ...I T+Z'>96 S X=$E(W,T+Z) - ...E S X=$E(W2,T-96+Z) - ...I "123m"[X,$E($G(^TMP($J,"PRS8",$S(T+Z'>96:+OT,1:OT+1),"HOL")),$S(T+Z'>96:T+Z,1:T-96+Z))=1 S X=0 ; HX becomes time off - ...Q - ..S Z=ZZ+Z-(X=0&Z) - ..I STOP-START+1+Z<8 D - ...I TYP["W",$E($P(PEROT(H),"^",3))'="E"&($G(^TMP($J,"PRS8",$P(PEROT(H),"^",1),"OFF"))=0) S TOUR=$G(^TMP($J,"PRS8",$P(PEROT(H),"^",1),"TOUR")) - ...S D=+OT,P=$S($E($P(PEROT(H),"^",3))'="E":TOUR+19,1:7),Y=8-(STOP-START+1+Z) - ...; - ...I TYP["P",TYP'["B",P'=7,'+NAWS D - ....I $P($G(^TMP($J,"PRS8",$P(PEROT(H),"^",1),"OFF")),"^",1)=1&(TH(WEEK)'>160) S Y=0 Q - ....I $P(C0,"^",12)="E" S P=$S($L($TR(W,"0O"))>31&(TH(WEEK)'>160):TOUR+25,1:P) D:Y SET S Y=$S(TH(WEEK)'>160:Y,1:0) S P=9 D:Y SET S Y=0 - ...I $P(C0,"^",12)="N",P'=7 S P=$S($L($TR(W,"0O"))>31:TOUR+15,1:P) D:Y SET S Y=0 - ...D:Y&('+NAWS) SET - ...; - ...I +NAWS D Q ; Checks for just the AWS nurses - ....N CNT,HT,I - ....S CNT=Y,Y=1,HT=$G(^TMP($J,"PRS8",D,"HT")) - ....F I=1:1:CNT D - .....I HT'<32 S P=$S(P'=7:TOUR+15,1:P) D SET1 Q ; DA/DE or CE/CT - .....I TH($S(+OT>7:2,1:1))'<160 S P=$S(P'=7:TOUR+19,1:P) D SET1 Q ; OA/OE or CE/CT - .....I HT<32,TH($S(+OT>7:2,1:1))<160 S P=9 D SET1 Q ; UN/US - ..Q - .Q - F X="OT","DA","UN","CT" D ; store FF OT into WK array - .N Y S P=$S(X="OT":TOUR+19,X="DA"&$E(ENT,TOUR+18):TOUR+15,X="DA":TOUR+19,X="CT":TOUR+6,1:9) - .F D=0:0 S D=$O(@(X_"("_D_")")) Q:D'>0 S Y=@(X_"("_D_")") D SET - .Q - ; - ; check/adjust night differential granted for leave - D LVND - Q -SET ; Set sleep time into WK array - Q:D<1!(D>14) - S WEEK=$S(D>7:2,1:1) - S $P(WK(WEEK),"^",P)=$P(WK(WEEK),"^",P)+Y - Q - ; -SET1 ; Set sleep time into WK array - Q:D<1!(D>14) - S WEEK=$S(D>7:2,1:1) - S $P(WK(WEEK),"^",P)=$P(WK(WEEK),"^",P)+Y - Q:(HT>32)&(TH(WEEK)<160)&(NH<320)&($E(ENT,19)=1) - Q:(HT>32)&(TH(WEEK)<160)&(NH=320)&($E(ENT,19)=1)&($E(AC,2)=2) ; 9month AWS - S HT=HT+1,TH(WEEK)=TH(WEEK)+1 - S ^TMP($J,"PRS8",D,"HT")=^TMP($J,"PRS8",D,"HT")+1 - Q - ; -OTNXTPP(DAY,CALLBK,EMPNM,PPIEN,TLU) ; - ;OT or CT connects to a tour of duty in the next pay period. - ;JAH-patch PRS*4*22 - ;If OT or CT are worked in last 2 hours of pay period & 1st day - ;of next pay period is missing a tour beginning at midnight, send - ;a bulletin warning that call back will be paid unless corrective - ;action is taken. - ;(i.e a nurse comes in before midnight on last saturday of - ;pay period & works for a period less than 2 hrs. before her tour - ;that begins at midnight on Sunday, first day of the next pp) - ; - ; CALLBK = start and stop position in 96 char BCD string. - ; RECORD = pointer from employee's tour info to a record - ; in tour of duty file. - ; DAY = day of the pay period - ; D1NXTPP = BOOLEAN; set to true if tour on day 1 of next pay period - ; begins at midnight, otherwise false - ; NEXTP = next pay period in 97-05 format. - ; CURP = current pay period in 99-02 format. - ; TLU = 3 digit time & leave unit of employee. - N D1NXTPP,RECORD,CURP,NEXTP,XMDUZ,XMB,XMY,XMDUZ - S (RTN,D1NXTPP)=0 - S RECORD=$P($G(^TMP($J,"PRS8",15,0)),"^",2) - I RECORD'="" S D1NXTPP=($P($G(^PRST(457.1,RECORD,1)),"^")="MID") - I (DAY=14)&($P(CALLBK,"^",2)=96) D - . I (D1NXTPP) S RTN=1 - . E D - .. S CURP=$P($G(^PRST(458,PPIEN,0)),"^",1) - .. S NXTP=$E($$NXTPP^PRSAPPU(CURP),3,7) - ..; Send bulletin to G.PAD - .. S XMY("G.PAD@"_^XMB("NETNAME"))="" - .. S XMDUZ="DHCP PAID package" - .. S XMB="PRS LAST SAT OT/CT" - ..; - ..; employee name, pay period number, next pay period - .. S XMB(1)=EMPNM,XMB(2)=CURP,XMB(3)=NXTP,XMB(4)=TLU - .. D ^XMB - Q RTN - ; -LVND ; Leave Night Differential - ; back out ND granted for leave if employee took 8 or more hrs of leave - ; a non-wage grade employee can receive night differential when - ; on leave as long as the employee has taken less than 8 hours of - ; leave during the pay period. - ; input (note: units are count of 15min time segments): - ; LU - leave taken during pay period (set in PRS8AC, PRS8MT) - ; WK(#) - piece 10 contains total shift-2 ND for week # - ; WKL(#) - ND granted for leave during week # (set in PRS8PP) - ; output: - ; WK(#) - piece 10 may be modified - ; WKL(#) - may be modified - N W - Q:TYP["W" ; Doesn't apply to Wage Grade - Q:LU'>31 ; Didn't take 8hrs of leave - F W=1,2 D ; For each week subtract leave ND from total ND - . Q:'WKL(W) ; No leave ND to subtract - . I +NAWS'=36 S $P(WK(W),"^",10)=$P(WK(W),"^",10)-WKL(W) ; Subtract - . ; For 36/40 AWS subtract time from Night Differential-AWS (piece 51) - . I +NAWS=36 S $P(WK(W),"^",51)=$P(WK(W),"^",51)-WKL(W) - . S WKL(W)=0 ; Reset leave ND amount - Q +PRS8MSC0 ;HISC/DAD,WCIOFO/JAH,SAB - MISC TIME CARD ADJUST(contd) ;1/25/2007 + ;;4.0;PAID;**22,35,40,56,111**;Sep 21, 1995;Build 2 + ;;Per VHA Directive 2004-038, this routine should not be modified. + ; + ; for employee on daily tour check if no duty performed during week + I TYP["D" D NODUTY^PRS8MSC1 + ; + S B="",Z0="" S $P(B,"B",97)="",$P(Z0,"0",97)="",FLAG=0 + F X=1:1:PEROWK S Y=$P(PEROWK(X),"^",4),DAT=$P(PEROWK(X),"^",1,3),DY=$P(DAT,"^",1),BEG=$P(DAT,"^",2),END=$P(DAT,"^",3) D + .I $L(Y)'<96,TYP'["Ff",$E(ENT,27) D ; slp for 24hr cvg + ..S SLMAX=32,(SLW,SLY,SLST,SLSTR,SLST1,SLY1,SL1,SL2,SL3)="" + ..I END=96 D + ...S SLST=$P($G(PEROWK(X)),"^",4),SL2=$E(SLST,SST,$L(SLST)),SL1=$E(SLST,1,SLMAX-$L(SL2)),SL3=$L(SL2) + ...S SLSTR=SL1_SL2 + ...I DOUB S SLSTR=$TR(SLSTR,"Cct","Bbb") ; if PPC = W then OC = SB + ...S SLSTR=$TR(SLSTR,$TR(SLSTR,"Bb"),Z0) + ...S SLY=$L($TR(SLSTR,"b0")),SLW=$L($TR(SLSTR,"B0")) + ...I SLW>12 Q + ...I DY=0 S FLAG=SL3 + ...S Y=$L(SLSTR)-SLW + ...I FLAG>0&(DY=1) S Y=Y-FLAG,FLAG=0 + ...S D=DY,P=25 D SET Q + ..E D + ...S SLST=$G(^TMP($J,"PRS8",DY,"W"))_$G(^TMP($J,"PRS8",DY+1,"W")) + ...S SLSTR=$E(SLST,1,SST+(SLMAX-1)) + ...I DOUB S SLSTR=$TR(SLSTR,"Cct","Bbb") ; if PPC = W then OC = SB + ...S SLSTR=$TR(SLSTR,$TR(SLSTR,"Bb"),Z0) + ...S SLY=$E(SLSTR,SST,96),SLY1=$E(SLSTR,97,$L(SLSTR)) + ...S SLSTR=SLY_SLY1,SLW=$L($TR(SLSTR,"B0")) + ...I SLW>12 Q + ...S D=DY,Y=$L($TR(SLY,"b0")),P=25 D SET + ...Q:DY=0 S D=DY+1,Y=$L($TR(SLY1,"b0")) D SET + ...Q + ..K BEG,DAT,END,NL,SLW,SLY,SLST,SLSTR,SLST1,SLY1,SL1,SL2,SL3 Q + .Q + S D="",(H,ROSS)=1 K OT,UN,DA,CT + F H=H:ROSS:PEROT D ; calculate CB OT and FF OT/sleep time + .S Y=PEROT(H),Z=$P(Y,"^",3) + .I "Ff"[TYP D ;K OT,UN,DA D ; FF sleep time + ..F M=1:1:$L(Z) D ; following FF OT per Mary Baker 4/1/93 + ...I D'=+Y+(($P(Y,"^",2)+M-2)\96) D + ....S D=+Y+(($P(Y,"^",2)+M-2)\96),HT=0 + ....Q + ...S HT=HT+1 + ...I $E(Z,H)="E" S CT(D)=$G(CT(D))+1 Q + ...I M'>32 S:HT'>32 OT(D)=$G(OT(D))+1 S:HT>32 DA(D)=$G(DA(D))+1 ; FF OT + ...I M>32,$L(Z)'<96&(M'>64)!($L(Z)<96) S DA(D)=$G(DA(D))+1 ; FF hrs>8 + ...I $L(Z)'<96,M>64 D ; FF 2/3 rule + ....I M'>96 S UN(D)=$G(UN(D))+1 ; first 8 sleep time + ....E S DA(D)=$G(DA(D))+1 ; rest hrs >8 + ....Q + ...Q + ..Q + .I $L(Z)<8 D ; call back OT at least 2 hrs + ..S YY=Y,ZZ=Z N X,Y,START,STOP,T,TT,Z,DD,TL S Y=YY,Z=ZZ + ..S CB=$G(^TMP($J,"PRS8",+Y,"CB")) + ..;no call back OT today or send bulletin + ..Q:(CB="")!($$OTNXTPP(+Y,CB,$P(C0,"^",1),PY,$P(C0,"^",8))) + ..S Q=0 F ZZ=1:2 Q:'$P(CB,"^",ZZ) I $P(Y,"^",2)=$P(CB,"^",ZZ) S Q=1 + ..Q:'Q ; this OT episode not call back + ..S OT=Y,START=$P(OT,"^",2),STOP=$P(OT,"^",2)+$L(Z)-1,T=START,TT=$S(T>96:T-96,1:T) + ..S W=$G(^TMP($J,"PRS8",+OT,"W")),WEEK=$S(+OT>7:2,1:1) + ..S W1=$G(^TMP($J,"PRS8",OT-1,"W")) + ..S W2=$G(^TMP($J,"PRS8",OT+1,"W")) + ..S (Z,X)=0 F Z=1:1:8-(STOP-START+1) D Q:X=0 + ...S DD=Z + ...I TT-DD>0 S X=$E(W,TT-DD) + ...E S X=$E(W1,96+T-DD) + ...I "123m"[X,$E($G(^TMP($J,"PRS8",$S(TT-DD>0:+OT,1:OT-1),"HOL")),$S(TT-DD>0:TT-DD,1:96+T-DD))=1 S X=0 ; HX becomes time off + ...Q + ..S ZZ=Z S:X=0&Z ZZ=ZZ-1 S X=0,T=STOP,TT=$S(T>96:T-96,1:T) + ..F Z=1:1:8-(STOP-START+1+ZZ) D Q:X=0 + ...S DD=STOP-START+1+ZZ+Z + ...I T+Z'>96 S X=$E(W,T+Z) + ...E S X=$E(W2,T-96+Z) + ...I "123m"[X,$E($G(^TMP($J,"PRS8",$S(T+Z'>96:+OT,1:OT+1),"HOL")),$S(T+Z'>96:T+Z,1:T-96+Z))=1 S X=0 ; HX becomes time off + ...Q + ..S Z=ZZ+Z-(X=0&Z) + ..I STOP-START+1+Z<8 D + ...I TYP["W",$E($P(PEROT(H),"^",3))'="E"&($G(^TMP($J,"PRS8",$P(PEROT(H),"^",1),"OFF"))=0) S TOUR=$G(^TMP($J,"PRS8",$P(PEROT(H),"^",1),"TOUR")) + ...S D=+OT,P=$S($E($P(PEROT(H),"^",3))'="E":TOUR+19,1:7),Y=8-(STOP-START+1+Z) + ...I TYP["P",TYP'["B",P'=7 D + ....I $P($G(^TMP($J,"PRS8",$P(PEROT(H),"^",1),"OFF")),"^",1)=1&(TH(WEEK)'>160) S Y=0 Q + ....I $P(C0,"^",12)="E" S P=$S($L($TR(W,"0O"))>31&(TH(WEEK)'>160):TOUR+25,1:P) D:Y SET S Y=$S(TH(WEEK)'>160:Y,1:0) S P=9 D:Y SET S Y=0 + ...I $P(C0,"^",12)="N",P'=7 S P=$S($L($TR(W,"0O"))>31:TOUR+15,1:P) D:Y SET S Y=0 + ...D:Y SET + ..Q + .Q + F X="OT","DA","UN","CT" D ; store FF OT into WK array + .N Y S P=$S(X="OT":TOUR+19,X="DA"&$E(ENT,TOUR+18):TOUR+15,X="DA":TOUR+19,X="CT":TOUR+6,1:9) + .F D=0:0 S D=$O(@(X_"("_D_")")) Q:D'>0 S Y=@(X_"("_D_")") D SET + .Q + ; + ; check/adjust night differential granted for leave + D LVND + Q +SET ; Set sleep time into WK array + Q:D<1!(D>14) + S WEEK=$S(D>7:2,1:1) + S $P(WK(WEEK),"^",P)=$P(WK(WEEK),"^",P)+Y + Q +OTNXTPP(DAY,CALLBK,EMPNM,PPIEN,TLU) ; + ;OT or CT connects to a tour of duty in the next pay period. + ;JAH-patch PRS*4*22 + ;If OT or CT are worked in last 2 hours of pay period & 1st day + ;of next pay period is missing a tour beginning at midnight, send + ;a bulletin warning that call back will be paid unless corrective + ;action is taken. + ;(i.e a nurse comes in before midnight on last saturday of + ;pay period & works for a period less than 2 hrs. before her tour + ;that begins at midnight on Sunday, first day of the next pp) + ; + ; CALLBK = start and stop position in 96 char BCD string. + ; RECORD = pointer from employee's tour info to a record + ; in tour of duty file. + ; DAY = day of the pay period + ; D1NXTPP = BOOLEAN; set to true if tour on day 1 of next pay period + ; begins at midnight, otherwise false + ; NEXTP = next pay period in 97-05 format. + ; CURP = current pay period in 99-02 format. + ; TLU = 3 digit time & leave unit of employee. + N D1NXTPP,RECORD,CURP,NEXTP,XMDUZ,XMB,XMY,XMDUZ + S (RTN,D1NXTPP)=0 + S RECORD=$P($G(^TMP($J,"PRS8",15,0)),"^",2) + I RECORD'="" S D1NXTPP=($P($G(^PRST(457.1,RECORD,1)),"^")="MID") + I (DAY=14)&($P(CALLBK,"^",2)=96) D + . I (D1NXTPP) S RTN=1 + . E D + .. S CURP=$P($G(^PRST(458,PPIEN,0)),"^",1) + .. S NXTP=$E($$NXTPP^PRSAPPU(CURP),3,7) + ..; Send bulletin to G.PAD + .. S XMY("G.PAD@"_^XMB("NETNAME"))="" + .. S XMDUZ="DHCP PAID package" + .. S XMB="PRS LAST SAT OT/CT" + ..; + ..; employee name, pay period number, next pay period + .. S XMB(1)=EMPNM,XMB(2)=CURP,XMB(3)=NXTP,XMB(4)=TLU + .. D ^XMB + Q RTN + ; +LVND ; Leave Night Differential + ; back out ND granted for leave if employee took 8 or more hrs of leave + ; a non-wage grade employee can receive night differential when + ; on leave as long as the employee has taken less than 8 hours of + ; leave during the pay period. + ; input (note: units are count of 15min time segments): + ; LU - leave taken during pay period (set in PRS8AC, PRS8MT) + ; WK(#) - piece 10 contains total shift-2 ND for week # + ; WKL(#) - ND granted for leave during week # (set in PRS8PP) + ; output: + ; WK(#) - piece 10 may be modified + ; WKL(#) - may be modified + N W + Q:TYP["W" ; Doesn't apply to Wage Grade + Q:LU'>31 ; Didn't take 8hrs of leave + F W=1,2 D ; For each week subtract leave ND from total ND + . Q:'WKL(W) ; No leave ND to subtract + . S $P(WK(W),"^",10)=$P(WK(W),"^",10)-WKL(W) ; Subtract + . S WKL(W)=0 ; Reset leave ND amount + Q diff --git a/r/PAID-PRS/PRS8MT.m b/r/PAID-PRS/PRS8MT.m index d51aa965..10ae94a0 100644 --- a/r/PAID-PRS/PRS8MT.m +++ b/r/PAID-PRS/PRS8MT.m @@ -1,152 +1,113 @@ -PRS8MT ;HISC/MRL-DECOMPOSITION, MEALTIME ;02/21/08 - ;;4.0;PAID;**2,40,69,102,109,112,116**;Sep 21, 1995;Build 23 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; - ;This routine is used to determine placement of mealtime where - ;necessary. - ; - ;Called by Routines: PRS8ST - ; -MULT ; --- checking 1 node - I $$HOLIDAY^PRS8UT(PY,DFN,MDY),$G(^PRST(458,PY,"E",DFN,"D",MDY,2))["MID^MID^ON" Q ;don't add meal if mid-mid on-call on a holiday, quit routine - S TWO=DAY(MDY,"TWO") - S S=1 D SET D:'Q I TWO S S=2 D SET D:'Q - .S D1="",$P(D1,"0",193)="",V(1)=97,V(2)=0 - .F I=1:3:28 S V=$P(N,"^",I,I+2) Q:$P(V,"^",1)="" D - ..S X=$P(V,"^",3) I "^^6^7^3^8^"'[("^"_X_"^") Q ;quit if not NH - ..F M=$P(V,"^"):1:$P(V,"^",2) D ; build up tour - ...S D1=$E(D1,1,M-1)_$S(X=""!(X=3):1,X=6:2,1:3)_$E(D1,M+1,192) - ...I V(1)>M S V(1)=M - ...I V(2)
SCDATE,SCUNDT
SCDATE D - . . S @SCOKAR@(SCNT,"TEAM",SCTEAM,1)=">>> Future team unassignment date was changed." - . . S @SCOKAR@(SCNT,"TEAM",SCTEAM,2)=" Old Date: "_$$FMTE^XLFDT(SCUNDT,"5Z")_" New Date: "_$$FMTE^XLFDT(SCDATE,"5Z")_" Entry#: "_SCIEN_")" - ; - Q SCOK - ; -TPDIS(SCDATE,SCPOS,SCNT,SCPTX) ; -- position unassignment for patient - ; input: SCDATE := effective date - ; SCTEAM := ien of TEAM POSITION entry (404.57) - ; SCNT := entry in @SCPTINFO@ & @SCPTALL@ arrays - ; SCPTX := format defined by output of $$PTTP^SCAPMC2 - ; - N SCNODE,SCOK,SCERRS,DFN,SCIEN,SCASDT,SCUNDT - S SCASDT=+$P(SCPTX,U,4) - S SCUNDT=+$P(SCPTX,U,5) - ; - S SCOK=1 - S SCERRS="SCERRLST" - ; - S DFN=+SCPTX - S SCIEN=+$P(SCPTX,U,3) - S SCNODE=$NA(^SCPT(404.43,SCIEN,0)) - S SCASDT=+$P(SCPTX,U,4) - S SCUNDT=+$P(SCPTX,U,5) - ; - ; if assignment date is in future then delete - IF SCOK D - . ; -- if assignment date is in future then delete - . IF SCASDT>DT,SCASDT>SCDATE D Q - . . N DA,DIE,DIK,DR - . . S DA=SCIEN,(DIE,DIK)="^SCPT(404.43,",DR=".04///"_DT D ^DIE ; og/sd/524 - . . D LOCK(SCNODE) - . . D ^DIK - . . D UNLOCK(SCNODE) - . . S @SCOKAR@(SCNT,"POS",SCPOS,1)=" >>> Future position assignment deleted." - . . S @SCOKAR@(SCNT,"POS",SCPOS,2)=" Assignment Date: "_$$FMTE^XLFDT(SCASDT,"5Z")_" Entry#: "_SCIEN - . . Q - . ; - . ; -- if assignment date is after effective date but before today - . IF SCASDT>SCDATE,SCASDT
SCDATE,SCUNDT
SCDATE D - . . S @SCOKAR@(SCNT,"POS",SCPOS,1)=" >>> Future position unassignment date was changed." - . . S @SCOKAR@(SCNT,"POS",SCPOS,2)=" Old Date: "_$$FMTE^XLFDT(SCUNDT,"5Z")_" New Date: "_$$FMTE^XLFDT(SCDATE,"5Z")_" Entry#: "_SCIEN_")" - . . Q - ; - IF SCOK D - . S @SCOKAR@(SCNT,"CLINIC",SCPOS,1)=$$CLDIS(SCPOS) - . Q - ; -TPDISQ Q SCOK - ; -CLDIS(SCPOS) ; -- discharge from clinic - N SCPOS0,SCCLN,SCREA,SCRET - S SCRET="" - ; - ; -- if user did not request clinic discharge, quit - IF '$G(SCTPDIS(+SCPOS)) G CLDISQ - ; - S SCPOS0=$G(^SCTM(404.57,SCPOS,0)) - S SCCLN=$P(SCPOS0,U,9) - IF SCCLN D - . S SCREA="Team position mass discharge" - . S SCRET=$$EN^SCMCMU3(DFN,SCCLN,SCDATE,SCREA) - . Q - ELSE D - . S SCRET="0^No clinic assignment to position" - . Q - ; -CLDISQ Q SCRET - ; -LOCK(NODE) ; -- lock node - F L +@NODE:5 IF $T Q - Q - ; -UNLOCK(NODE) ; -- unlock node - L -@NODE - Q - ; +SCMCMU2 ;ALB/MJK - PCMM Mass Team/Position Unassignment Processing ; 10-JUL-1998 + ;;5.3;Scheduling;**148,177**;AUG 13, 1993 + ; +QUE() ; -- queue mass unassignment + ;D START Q 99999 ; -- for interactive testing + N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSAVE,ZTSK + S ZTRTN="START^SCMCMU2" + S ZTDESC=VALM("TITLE") + S ZTDTH=$H + S ZTIO="" + F X="SCTEAM","SCPOS","SCTPDIS(","SCMUTYPE","SCDATE","SCSELCNT" S ZTSAVE(X)="" + F X="^TMP(""SCMU"",$J,""SELECTED"",","^TMP(""SCMU"",$J,""PATIENT INFO""," S ZTSAVE(X)="" + D ^%ZTLOAD + Q $G(ZTSK) + ; +START ; -- entry point for task + ; -- defined from task SCTEAM,SCPOS,SCTPDIS,SCMUTYPE,SCDATE,SCSELCNT + ; + N SCTOP,SCUNCNT,SCASCNT,SCOK + S SCUNCNT=0 + S SCASCNT=SCSELCNT + ; + ; -- lock top node + IF SCMUTYPE="T" D + . S SCTOP=$NA(^SCTM(404.51,+SCTEAM,0)) + ELSE IF SCMUTYPE="P" D + . S SCTOP=$NA(^SCTM(404.57,+SCPOS,0)) + D LOCK(SCTOP) + ; + ; -- use tmp data brought in by TaskMan + N SCPTSEL,SCPTINFO + S SCPTSEL=$NA(^TMP("SCMU",$J,"SELECTED")) + S SCPTINFO=$NA(^TMP("SCMU",$J,"PATIENT INFO")) + ; + N SCOKAR,SCBADAR,SCERRAR,SCPTTP + S SCOKAR=$NA(^TMP("SCMU",$J,"OK")) + S SCBADAR=$NA(^TMP("SCMU",$J,"BAD")) + S SCERRAR=$NA(^TMP("SCMU",$J,"ERROR")) + S SCPTTP=$NA(^TMP("SCMU",$J,"PATIENT-POSITION")) + K @SCOKAR,@SCBADAR,@SCERRAR,@SCPTTP + ; + N SCNT,SCNODE,SCPTX + ; + ; -- create patient-position array for team processing + IF SCMUTYPE="T" D PTTPLST^SCMCMU11(SCTEAM,SCDATE,SCPTTP) + ; + S SCNT=0 + F S SCNT=$O(@SCPTSEL@(SCNT)) Q:'SCNT D + . ;N SCDATE S SCDATE=2700101 ; -- use to force error/testing + . S SCPTX=$G(@SCPTINFO@(SCNT)) + . IF SCPTX="" Q + . IF SCMUTYPE="T" S SCOK=$$TMDIS(SCDATE,SCTEAM,SCNT,SCPTX) + . ; + . IF SCMUTYPE="P" S SCOK=$$TPDIS(SCDATE,SCPOS,SCNT,SCPTX) + . ; + . ; -- if successful + . IF SCOK D + . . S @SCOKAR@(SCNT)="" + . . S SCUNCNT=SCUNCNT+1 + . . S SCASCNT=SCASCNT-1 + . ; + . ; -- if not sucessful + . ELSE D + . . S @SCBADAR@(SCNT)="" + ; + ; -- unlock top node + D UNLOCK(SCTOP) + ; + ; -- send results + D BULL^SCMCMU4 + ; + K @SCOKAR,@SCBADAR,@SCERRAR,@SCPTTP + K @SCPTSEL,@SCPTINFO + Q + ; + ; **** May want to eventually combine TMDIS & TPDIS tags **** + ; +TMDIS(SCDATE,SCTEAM,SCNT,SCPTX) ; -- team unassignment for patient + ; input: SCDATE := effective date + ; SCTEAM := ien of TEAM entry (404.51) + ; SCNT := entry in @SCPTINFO@ & @SCPTALL@ arrays + ; SCPTX := format defined by output of $$PTTM^SCAPMC2 + ; + N SCNODE,SCPOS,SCPOSI,SCOK,SCERRS,DFN,SCIEN,SCASDT,SCUNDT + ; + S SCOK=1 + S SCERRS="SCERRLST" + ; + S DFN=+SCPTX + S SCIEN=+$P(SCPTX,U,3) + S SCNODE=$NA(^SCPT(404.42,SCIEN,0)) + S SCASDT=+$P(SCPTX,U,4) + S SCUNDT=+$P(SCPTX,U,5) + ; + ; -- unassign from positions first + S SCPOS=0 + F S SCPOS=$O(@SCPTTP@(DFN,SCPOS)) Q:'SCPOS D Q:'SCOK + . S SCOK=$$TPDIS(SCDATE,SCPOS,SCNT,$G(@SCPTTP@(DFN,SCPOS))) + ; + IF 'SCOK D + . S @SCERRAR@(SCNT,"TEAM",SCTEAM,1)="Team still assigned to patient." + . S @SCERRAR@(SCNT,"TEAM",SCTEAM,2)="Not able to unassign at least one position." + ; + IF SCOK D + . ; -- if assignment date is in future then delete + . IF SCASDT>DT,SCASDT>SCDATE D Q + . . N DA,DIK + . . S DA=SCIEN,DIK="^SCPT(404.42," + . . D LOCK(SCNODE) + . . D ^DIK + . . D UNLOCK(SCNODE) + . . S @SCOKAR@(SCNT,"TEAM",SCTEAM,1)=">>> Future team assignment deleted." + . . S @SCOKAR@(SCNT,"TEAM",SCTEAM,2)=" Assignment Date: "_$$FMTE^XLFDT(SCASDT,"5Z")_" Entry#: "_SCIEN + . . Q + . ; + . ; -- if assignment date is after effective date but before today + . IF SCASDT>SCDATE,SCASDT
SCDATE,SCUNDT
SCDATE D + . . S @SCOKAR@(SCNT,"TEAM",SCTEAM,1)=">>> Future team unassignment date was changed." + . . S @SCOKAR@(SCNT,"TEAM",SCTEAM,2)=" Old Date: "_$$FMTE^XLFDT(SCUNDT,"5Z")_" New Date: "_$$FMTE^XLFDT(SCDATE,"5Z")_" Entry#: "_SCIEN_")" + ; + Q SCOK + ; +TPDIS(SCDATE,SCPOS,SCNT,SCPTX) ; -- position unassignment for patient + ; input: SCDATE := effective date + ; SCTEAM := ien of TEAM POSITION entry (404.57) + ; SCNT := entry in @SCPTINFO@ & @SCPTALL@ arrays + ; SCPTX := format defined by output of $$PTTP^SCAPMC2 + ; + N SCNODE,SCOK,SCERRS,DFN,SCIEN,SCASDT,SCUNDT + S SCASDT=+$P(SCPTX,U,4) + S SCUNDT=+$P(SCPTX,U,5) + ; + S SCOK=1 + S SCERRS="SCERRLST" + ; + S DFN=+SCPTX + S SCIEN=+$P(SCPTX,U,3) + S SCNODE=$NA(^SCPT(404.43,SCIEN,0)) + S SCASDT=+$P(SCPTX,U,4) + S SCUNDT=+$P(SCPTX,U,5) + ; + ; if assignment date is in future then delete + IF SCOK D + . ; -- if assignment date is in future then delete + . IF SCASDT>DT,SCASDT>SCDATE D Q + . . N DA,DIK + . . S DA=SCIEN,DIK="^SCPT(404.43," + . . D LOCK(SCNODE) + . . D ^DIK + . . D UNLOCK(SCNODE) + . . S @SCOKAR@(SCNT,"POS",SCPOS,1)=" >>> Future position assignment deleted." + . . S @SCOKAR@(SCNT,"POS",SCPOS,2)=" Assignment Date: "_$$FMTE^XLFDT(SCASDT,"5Z")_" Entry#: "_SCIEN + . . Q + . ; + . ; -- if assignment date is after effective date but before today + . IF SCASDT>SCDATE,SCASDT
SCDATE,SCUNDT
SCDATE D + . . S @SCOKAR@(SCNT,"POS",SCPOS,1)=" >>> Future position unassignment date was changed." + . . S @SCOKAR@(SCNT,"POS",SCPOS,2)=" Old Date: "_$$FMTE^XLFDT(SCUNDT,"5Z")_" New Date: "_$$FMTE^XLFDT(SCDATE,"5Z")_" Entry#: "_SCIEN_")" + . . Q + ; + IF SCOK D + . S @SCOKAR@(SCNT,"CLINIC",SCPOS,1)=$$CLDIS(SCPOS) + . Q + ; +TPDISQ Q SCOK + ; +CLDIS(SCPOS) ; -- discharge from clinic + N SCPOS0,SCCLN,SCREA,SCRET + S SCRET="" + ; + ; -- if user did not request clinic discharge, quit + IF '$G(SCTPDIS(+SCPOS)) G CLDISQ + ; + S SCPOS0=$G(^SCTM(404.57,SCPOS,0)) + S SCCLN=$P(SCPOS0,U,9) + IF SCCLN D + . S SCREA="Team position mass discharge" + . S SCRET=$$EN^SCMCMU3(DFN,SCCLN,SCDATE,SCREA) + . Q + ELSE D + . S SCRET="0^No clinic assignment to position" + . Q + ; +CLDISQ Q SCRET + ; +LOCK(NODE) ; -- lock node + F L +@NODE:5 IF $T Q + Q + ; +UNLOCK(NODE) ; -- unlock node + L -@NODE + Q + ; diff --git a/r/SCHEDULING-SD-SC/SCMCQK1.m b/r/SCHEDULING-SD-SC/SCMCQK1.m index 17f46bd1..5c635849 100644 --- a/r/SCHEDULING-SD-SC/SCMCQK1.m +++ b/r/SCHEDULING-SD-SC/SCMCQK1.m @@ -1,268 +1,268 @@ -SCMCQK1 ;ALBOI/REW - Single Pt Tm/Pt Tm Pos Assign and Discharge;11/07/02 - ;;5.3;Scheduling;**148,177,231,264,436,297,446,524**;AUG 13, 1993;Build 29 - ; - ;04/25/2006 SD*5.3*446 INTER-FACILITY TRANSFER -UNTP ;unassign patient from pc prac position - I '$G(SCTP) W !,"No position defined" Q - N OK,SCER,SCCL,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS - S OK=0 - W !,"About to Unassign "_$$NAME(DFN)_" from: ",!,?8,$$POSITION(SCTP)_" position ["_$P($$GETPRTP^SCAPMCU2(SCTP,DT),U,2)_"]" - S SCDISCH=$$DATE("D") - G:SCDISCH<1 QTUNTP - G:'$$CONFIRM() QTUNTP - S OK=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER) ; og/sd/524 - G:OK'>0 QTUNTP - S SCCL=$P($G(^SCTM(404.57,+$G(SCTP),0)),U,9) - I SCCL D DISCL -QTUNTP W !,"Position Unassignment "_$S(OK:"made.",1:"NOT made.") - Q -ENRCL ; - N SCRESTA,SCREST,SCCLNM,SCTM - N SCCL - F SCCL=0:0 S SCCL=$O(^SCTM(404.57,+$G(SCTP),5,SCCL)) Q:'SCCL D - .Q:$$ACTCL(DFN,SCCL) - .W !!!,"The "_$$POSITION(SCTP)_" is associated with the ",$$CLINIC(SCCL)_" clinic." - .;SCRESTA = Array of pt's teams causing restricted consults - .N SCRESTA - .S SCREST=$$RESTPT^SCAPMCU4(DFN,DT,"SCRESTA") - .I SCREST D - ..N SCTM - ..S SCCLNM=Y - ..W !,?5,"Patient has restricted consults due to team assignment(s):" - ..S SCTM=0 - ..F S SCTM=$O(SCRESTA(SCTM)) Q:'SCTM W !,?10,SCRESTA(SCTM) - .I SCREST&'$G(SCOKCONS) D G QTECL - ..W !,?5,"This patient may only be enrolled in clinics via" - ..W !,?15,"Edit Clinic Enrollment Data option" - .W !,"Do you wish to enroll the patient from this clinic on " - .S Y=SCASSDT X ^DD("DD") W Y,"?" - .I $$YESNO() D - ..W !,"Clinic Enrollment" - ..I $$ACPTCL^SCAPMC18(DFN,SCCL,,SCASSDT,"SCENER") W " made" - ..E W "NOT made" -QTECL Q -DISCL ; - N SCCL F SCCL=0:0 S SCCL=$O(^SCTM(404.57,+$G(SCTP),5,SCCL)) Q:'SCCL D - .Q:'$$ACTCL(DFN,SCCL) - .W !,$$NAME(DFN)," is enrolled in the associated "_$$CLINIC(SCCL)_" clinic." - .W !,"Do you wish to discharge the patient from this clinic on " - .S Y=SCDISCH X ^DD("DD") W Y,"?" - .Q:'$$YESNO() - .N SDFN,SDCLN S SDFN=DFN,SDCLN=SCCL - .N DFN D ^SDCD -QTDCL Q -UNTM ; - ;assign patient from pc team (and pc position if possible) - N OK,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS,OK2,OK3 - S OK=0 - W !!,"About to Unassign "_$$NAME(DFN)_" from "_$$TEAMNM(SCTM)_" team" - W:'SCTPSTAT !,?5,"AND from "_$$POSITION(SCTP)_" position ["_$$WRITETP^SCMCDD1(SCTP)_"]" - S SCDISCH=$$DATE("D") - G:SCDISCH<1 QTUNTM - G:'$$CONFIRM() QTUNTM - IF 'SCTPSTAT D G:OK2'>0 QTUNTM - .W !,"PC assignment unassigned." - .S OK2=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER) - .IF OK2>0 D - ..W "made." - ..S SCCL=$P(^SCTM(404.57,SCTP,0),U,9) - ..D:SCCL DISCL - S OK3=$$ALLPOS() - IF $$OKINPTTM^SCMCTMU2(DFN,SCTM,SCDISCH) D - .S OK=$$INPTSCTM^SCAPMC7(DFN,SCTM,SCDISCH,.SCER) - ELSE D - .W !,"Future/Current Patient-Position Assignment exists" -QTUNTM W !,"Team Unassignment "_$S(OK:"made",1:"NOT made.") - Q -ALLPOS() ;unassign all patient-positions for team - ;not stand-alone - needs dfn,sctm - ;return 1=No positions left assigned|0=At least 1 position assigned - N OK,SCDT1,SCPTTPX,SCERRR,SCTP,SCCNT,SCPTTPI,SCLOC,SCNODE,SCPTTP2 - S SCDT1("BEGIN")=SCDISCH+1 - S SCDT1("END")=3990101 - S SCDT1("INCL")=0 ;anytime from now to future - S OK=$$TPPT^SCAPMC23(DFN,"SCDT1",,,,,,"SCPTTPX",.SCERRR) - S (SCTP,SCCNT)=0 - W !,"Checking for other position assignments to team..." - F S SCTP=$O(SCPTTPX("SCTP",SCTM,SCTP)) Q:'SCTP S SCCNT=SCCNT+1 D - .S SCPTTPI=$O(SCPTTPX("SCTP",SCTM,SCTP,9999999),-1) - .S SCLOC=$O(SCPTTPX("SCTP",SCTM,SCTP,SCPTTPI,0)) - .S SCNODE=SCPTTPX(SCLOC) - .S SCPTTP2(SCTP)="" - .W !,?3,$P(SCNODE,U,2)," ",$P(SCNODE,U,8) - .IF $P(SCNODE,U,6)!(SCDISCH'>$P(SCNODE,U,5)) D - ..W !,?5,"Unassignment date already exists or unassignment after assignment date" - ..W !,?15,"- Correct via PCMM GUI" - ..S OK=0 - W !,?5,$S(SCCNT:SCCNT,1:"No")_" current/future position assignment(s)" - G:'OK!('SCCNT) QTALL - W !!,"About to unassign the above patient-position assignments" - IF '$$CONFIRM S OK=0 G QTALL - S SCTP=0 - F S SCTP=$O(SCPTTP2(SCTP)) Q:'SCTP D Q:'OK - .S OK=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER) - .W:'OK !,?10,"Problem with unassignment, correct via PCMM GUI" -QTALL Q OK -ASTM ;assign patient to PC team - N DIC,Y,OK,SCTM,SCTMFLDS,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS - S OK=0 - W !!,"About to Assign "_$$NAME(DFN)_" to a primary care team" - I $$SC(DFN) W !!,"********** This patient is 50 percent or greater service-connected ************" - S DIC="^SCTM(404.51," - S DIC(0)="AEMQZ" - S DIC("S")="IF $$ACTTM^SCMCTMU(Y,DT)&($P($G(^SCTM(404.51,Y,0)),U,5))" - ;select from active teams that can be PC Teams - D ^DIC - G:Y<1 QTASTM - S SCTM=+Y - ;The following logic to present warning message added per SD*5.3*436 - I $P($G(^SCTM(404.51,SCTM,0)),U,10) D G:'SCFLAG QTASTM - .S SCFLAG=0 - .W !!,"This team is closed to further patient assignments. While you are" - .W !,"not currently prevented from assigning this patient, you may want to" - .W !,"check before continuing." - .Q:'$$YESNO1() ; new function call per SD*5.3*436 - .Q:'$$CONFIRM() - .S SCFLAG=1 W ! - S SCASSDT=$$DATE("A") - G:SCASSDT<1 QTASTM - S SCTMCT=$$TEAMCNT^SCAPMCU1(SCTM) - S SCTMMAX=$P($$GETEAM^SCAPMCU3(SCTM),"^",8) - I SCTMCT'0 -YESNO1() ; added per SD*5.3*436 - N DIR,X,Y - S DIR(0)="Y",DIR("A")="Do you wish to assign this patient now (Yes/No)?" - S DIR("B")="NO" - D ^DIR - Q Y>0 -YESNO2() ; - N DIR,X,Y - S DIR(0)="Y",DIR("B")="NO" - S DIR("A")="Do you wish to continue with the assignment (Yes/No)?" - D ^DIR - Q Y>0 -CONFIRM() ;confirmation call - N DIR,X,Y - S DIR("A")="Are you sure (Yes/No)" - S DIR(0)="Y" - D ^DIR - Q +Y=1 -SELPOS() ;return way to select position: 1=PRACT,2=POSIT,3=NONE - N DIR,X,Y - W !,"Choose way to select PC POSITION Assignment: " - S DIR(0)="SO^0:NONE;1:BY PRACTITIONER ASSIGNMENT;2:BY POSITION ASSIGNMENT" - S DIR("B")=1 - D ^DIR - Q $S(Y'>0:"",+Y=1:"PRACT",1:"POSIT") -DATE(TYPE) ;return date type=A or D - N DIR,X,Y - S DIR("A")=$S(TYPE="A":"Assignment",1:"Unassignment")_" date: " - S DIR(0)="DA^::EXP" - S Y=$S($D(SCDISCH):SCDISCH,$D(SCASSDT):SCASSDT,(TYPE="A"):"TODAY",1:"TODAY-1") - X ^DD("DD") - S DIR("B")=Y - D ^DIR - Q Y -ACTCL(DFN,SCCL) ;is patient enrolled in clinic? - N SCXX - S SCXX=$O(^DPT(DFN,"DE","B",SCCL,9999),-1) - Q $S('SCXX:0,($P(^DPT(DFN,"DE",+SCXX,0),U,2)="I"):0,1:1) -PRACSCR(SC40452) ;screen for for file 404.52 - N SCP,SCNODE,OK - S SCP=$G(^SCTM(404.52,SC40452,0)) - S OK=0 - G:'SCP QTPP - S SCNODE=$G(^SCTM(404.57,+SCP,0)) - S OK=$S($P(SCNODE,U,2)'=SCTM:0,'$P(SCNODE,U,4):0,($O(^SCTM(404.52,"AIDT",+SCP,1,""))'=-$P(SCP,U,2)):0,($O(^SCTM(404.52,"AIDT",+SCP,0,-$P(SCP,U,2)),-1)):0,($$ACTTP^SCMCTPU(+SCP)>0):1,1:0) -QTPP Q OK -POSSCR(SCTP) ;screen for file 404.57 - N SCNODE - S SCNODE=$G(^SCTM(404.57,SCTP,0)) - Q $S($P(SCNODE,U,2)'=SCTM:0,'$P(SCNODE,U,4):0,($$ACTTP^SCMCTPU(SCTP)>0):1,1:0) - Q -WAITYN() ; - N %,OK,Y - I SCTMCT1,1:1) Q 0 - N DIR,X,Y - S DIR(0)="Y",DIR("B")="NO" - S DIR("A")="Do you wish to place the patient on the wait list (Yes/No)?" - D ^DIR - I Y=1 S Y=$$WAITS^SCMCWAIT(DFN,SCTM,$G(SCTP),$G(SC)) I Y>0 W !,"Patient Placed on Wait List" - Q Y>0 -SC(DFN) ;Is patient 50 to 100% - D ELIG^VADPT Q $P($G(VAEL(3)),U,2)>49 +SCMCQK1 ;ALB/REW - Single Pt Tm/Pt Tm Pos Assign and Discharge ; 07 Oct 2002 12:10 PM ; Compiled April 12, 2007 10:03:59 + ;;5.3;Scheduling;**148,177,231,264,436,297,446**;AUG 13, 1993;Build 77 + ; + ;04/25/2006 SD*5.3*446 INTER-FACILITY TRANSFER +UNTP ;unassign patient from pc prac position + I '$G(SCTP) W !,"No position defined" Q + N OK,SCER,SCCL,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS + S OK=0 + W !,"About to Unassign "_$$NAME(DFN)_" from: ",!,?8,$$POSITION(SCTP)_" position ["_$P($$GETPRTP^SCAPMCU2(SCTP,DT),U,2)_"]" + S SCDISCH=$$DATE("D") + G:SCDISCH<1 QTUNTP + G:'$$CONFIRM() QTUNTP + S OK=1 ;$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER) + G:OK'>0 QTUNTP + S SCCL=$P($G(^SCTM(404.57,+$G(SCTP),0)),U,9) + I SCCL D DISCL +QTUNTP W !,"Position Unassignment "_$S(OK:"made.",1:"NOT made.") + Q +ENRCL ; + N SCRESTA,SCREST,SCCLNM,SCTM + N SCCL + F SCCL=0:0 S SCCL=$O(^SCTM(404.57,+$G(SCTP),5,SCCL)) Q:'SCCL D + .Q:$$ACTCL(DFN,SCCL) + .W !!!,"The "_$$POSITION(SCTP)_" is associated with the ",$$CLINIC(SCCL)_" clinic." + .;SCRESTA = Array of pt's teams causing restricted consults + .N SCRESTA + .S SCREST=$$RESTPT^SCAPMCU4(DFN,DT,"SCRESTA") + .I SCREST D + ..N SCTM + ..S SCCLNM=Y + ..W !,?5,"Patient has restricted consults due to team assignment(s):" + ..S SCTM=0 + ..F S SCTM=$O(SCRESTA(SCTM)) Q:'SCTM W !,?10,SCRESTA(SCTM) + .I SCREST&'$G(SCOKCONS) D G QTECL + ..W !,?5,"This patient may only be enrolled in clinics via" + ..W !,?15,"Edit Clinic Enrollment Data option" + .W !,"Do you wish to enroll the patient from this clinic on " + .S Y=SCASSDT X ^DD("DD") W Y,"?" + .I $$YESNO() D + ..W !,"Clinic Enrollment" + ..I $$ACPTCL^SCAPMC18(DFN,SCCL,,SCASSDT,"SCENER") W " made" + ..E W "NOT made" +QTECL Q +DISCL ; + N SCCL F SCCL=0:0 S SCCL=$O(^SCTM(404.57,+$G(SCTP),5,SCCL)) Q:'SCCL D + .Q:'$$ACTCL(DFN,SCCL) + .W !,$$NAME(DFN)," is enrolled in the associated "_$$CLINIC(SCCL)_" clinic." + .W !,"Do you wish to discharge the patient from this clinic on " + .S Y=SCDISCH X ^DD("DD") W Y,"?" + .Q:'$$YESNO() + .N SDFN,SDCLN S SDFN=DFN,SDCLN=SCCL + .N DFN D ^SDCD +QTDCL Q +UNTM ; + ;assign patient from pc team (and pc position if possible) + N OK,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS,OK2,OK3 + S OK=0 + W !!,"About to Unassign "_$$NAME(DFN)_" from "_$$TEAMNM(SCTM)_" team" + W:'SCTPSTAT !,?5,"AND from "_$$POSITION(SCTP)_" position ["_$$WRITETP^SCMCDD1(SCTP)_"]" + S SCDISCH=$$DATE("D") + G:SCDISCH<1 QTUNTM + G:'$$CONFIRM() QTUNTM + IF 'SCTPSTAT D G:OK2'>0 QTUNTM + .W !,"PC assignment unassigned." + .S OK2=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER) + .IF OK2>0 D + ..W "made." + ..S SCCL=$P(^SCTM(404.57,SCTP,0),U,9) + ..D:SCCL DISCL + S OK3=$$ALLPOS() + IF $$OKINPTTM^SCMCTMU2(DFN,SCTM,SCDISCH) D + .S OK=$$INPTSCTM^SCAPMC7(DFN,SCTM,SCDISCH,.SCER) + ELSE D + .W !,"Future/Current Patient-Position Assignment exists" +QTUNTM W !,"Team Unassignment "_$S(OK:"made",1:"NOT made.") + Q +ALLPOS() ;unassign all patient-positions for team + ;not stand-alone - needs dfn,sctm + ;return 1=No positions left assigned|0=At least 1 position assigned + N OK,SCDT1,SCPTTPX,SCERRR,SCTP,SCCNT,SCPTTPI,SCLOC,SCNODE,SCPTTP2 + S SCDT1("BEGIN")=SCDISCH+1 + S SCDT1("END")=3990101 + S SCDT1("INCL")=0 ;anytime from now to future + S OK=$$TPPT^SCAPMC23(DFN,"SCDT1",,,,,,"SCPTTPX",.SCERRR) + S (SCTP,SCCNT)=0 + W !,"Checking for other position assignments to team..." + F S SCTP=$O(SCPTTPX("SCTP",SCTM,SCTP)) Q:'SCTP S SCCNT=SCCNT+1 D + .S SCPTTPI=$O(SCPTTPX("SCTP",SCTM,SCTP,9999999),-1) + .S SCLOC=$O(SCPTTPX("SCTP",SCTM,SCTP,SCPTTPI,0)) + .S SCNODE=SCPTTPX(SCLOC) + .S SCPTTP2(SCTP)="" + .W !,?3,$P(SCNODE,U,2)," ",$P(SCNODE,U,8) + .IF $P(SCNODE,U,6)!(SCDISCH'>$P(SCNODE,U,5)) D + ..W !,?5,"Unassignment date already exists or unassignment after assignment date" + ..W !,?15,"- Correct via PCMM GUI" + ..S OK=0 + W !,?5,$S(SCCNT:SCCNT,1:"No")_" current/future position assignment(s)" + G:'OK!('SCCNT) QTALL + W !!,"About to unassign the above patient-position assignments" + IF '$$CONFIRM S OK=0 G QTALL + S SCTP=0 + F S SCTP=$O(SCPTTP2(SCTP)) Q:'SCTP D Q:'OK + .S OK=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER) + .W:'OK !,?10,"Problem with unassignment, correct via PCMM GUI" +QTALL Q OK +ASTM ;assign patient to PC team + N DIC,Y,OK,SCTM,SCTMFLDS,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS + S OK=0 + W !!,"About to Assign "_$$NAME(DFN)_" to a primary care team" + I $$SC(DFN) W !!,"********** This patient is 50 percent or greater service-connected ************" + S DIC="^SCTM(404.51," + S DIC(0)="AEMQZ" + S DIC("S")="IF $$ACTTM^SCMCTMU(Y,DT)&($P($G(^SCTM(404.51,Y,0)),U,5))" + ;select from active teams that can be PC Teams + D ^DIC + G:Y<1 QTASTM + S SCTM=+Y + ;The following logic to present warning message added per SD*5.3*436 + I $P($G(^SCTM(404.51,SCTM,0)),U,10) D G:'SCFLAG QTASTM + .S SCFLAG=0 + .W !!,"This team is closed to further patient assignments. While you are" + .W !,"not currently prevented from assigning this patient, you may want to" + .W !,"check before continuing." + .Q:'$$YESNO1() ; new function call per SD*5.3*436 + .Q:'$$CONFIRM() + .S SCFLAG=1 W ! + S SCASSDT=$$DATE("A") + G:SCASSDT<1 QTASTM + S SCTMCT=$$TEAMCNT^SCAPMCU1(SCTM) + S SCTMMAX=$P($$GETEAM^SCAPMCU3(SCTM),"^",8) + I SCTMCT'0 +YESNO1() ; added per SD*5.3*436 + N DIR,X,Y + S DIR(0)="Y",DIR("A")="Do you wish to assign this patient now (Yes/No)?" + S DIR("B")="NO" + D ^DIR + Q Y>0 +YESNO2() ; + N DIR,X,Y + S DIR(0)="Y",DIR("B")="NO" + S DIR("A")="Do you wish to continue with the assignment (Yes/No)?" + D ^DIR + Q Y>0 +CONFIRM() ;confirmation call + N DIR,X,Y + S DIR("A")="Are you sure (Yes/No)" + S DIR(0)="Y" + D ^DIR + Q +Y=1 +SELPOS() ;return way to select position: 1=PRACT,2=POSIT,3=NONE + N DIR,X,Y + W !,"Choose way to select PC POSITION Assignment: " + S DIR(0)="SO^0:NONE;1:BY PRACTITIONER ASSIGNMENT;2:BY POSITION ASSIGNMENT" + S DIR("B")=1 + D ^DIR + Q $S(Y'>0:"",+Y=1:"PRACT",1:"POSIT") +DATE(TYPE) ;return date type=A or D + N DIR,X,Y + S DIR("A")=$S(TYPE="A":"Assignment",1:"Unassignment")_" date: " + S DIR(0)="DA^::EXP" + S Y=$S($D(SCDISCH):SCDISCH,$D(SCASSDT):SCASSDT,(TYPE="A"):"TODAY",1:"TODAY-1") + X ^DD("DD") + S DIR("B")=Y + D ^DIR + Q Y +ACTCL(DFN,SCCL) ;is patient enrolled in clinic? + N SCXX + S SCXX=$O(^DPT(DFN,"DE","B",SCCL,9999),-1) + Q $S('SCXX:0,($P(^DPT(DFN,"DE",+SCXX,0),U,2)="I"):0,1:1) +PRACSCR(SC40452) ;screen for for file 404.52 + N SCP,SCNODE,OK + S SCP=$G(^SCTM(404.52,SC40452,0)) + S OK=0 + G:'SCP QTPP + S SCNODE=$G(^SCTM(404.57,+SCP,0)) + S OK=$S($P(SCNODE,U,2)'=SCTM:0,'$P(SCNODE,U,4):0,($O(^SCTM(404.52,"AIDT",+SCP,1,""))'=-$P(SCP,U,2)):0,($O(^SCTM(404.52,"AIDT",+SCP,0,-$P(SCP,U,2)),-1)):0,($$ACTTP^SCMCTPU(+SCP)>0):1,1:0) +QTPP Q OK +POSSCR(SCTP) ;screen for file 404.57 + N SCNODE + S SCNODE=$G(^SCTM(404.57,SCTP,0)) + Q $S($P(SCNODE,U,2)'=SCTM:0,'$P(SCNODE,U,4):0,($$ACTTP^SCMCTPU(SCTP)>0):1,1:0) + Q +WAITYN() ; + N %,OK,Y + I SCTMCT1,1:1) Q 0 + N DIR,X,Y + S DIR(0)="Y",DIR("B")="NO" + S DIR("A")="Do you wish to place the patient on the wait list (Yes/No)?" + D ^DIR + I Y=1 S Y=$$WAITS^SCMCWAIT(DFN,SCTM,$G(SCTP),$G(SC)) I Y>0 W !,"Patient Placed on Wait List" + Q Y>0 +SC(DFN) ;Is patient 50 to 100% + D ELIG^VADPT Q $P($G(VAEL(3)),U,2)>49 diff --git a/r/SCHEDULING-SD-SC/SCMCTSK1.m b/r/SCHEDULING-SD-SC/SCMCTSK1.m index d8fbec9f..44d2ad41 100644 --- a/r/SCHEDULING-SD-SC/SCMCTSK1.m +++ b/r/SCHEDULING-SD-SC/SCMCTSK1.m @@ -1,246 +1,244 @@ -SCMCTSK1 ;ALB/JDS - PCMM Inactivations; 18 Apr 2003 9:36 AM ; 10/24/07 12:24pm ; Compiled January 25, 2008 12:11:43 ; Compiled March 26, 2008 22:27:26 - ;;5.3;Scheduling;**297,498,527,499**;AUG 13, 1993;Build 21 - Q -INACTIVE ; - ;Flag patients - N I,CNT,SC297,TPZ,TYDT,TEAMN,STDT,Q,SDDT,STDD S CNT=0 - D DT^DICRW - N SD1 S SDDT="" F SD1=DT,DT-1 I $D(^XTMP("SCMCTSK2-"_SD1,$J,"START")) S SDDT=SD1 Q - I SDDT'>0 D DT^DICRW S SDDT=DT - S %DT="",X="T-11M" D ^%DT S STDD=+Y - S A="^SCPT(404.43,""ADFN""",L="""""" - S Q=A_")" - F S Q=$Q(@Q) Q:Q'[A D - .S ENTRY=+$P(Q,",",6) - .S ZERO=$G(^SCPT(404.43,+ENTRY,0)) - .I $P(ZERO,U,15) Q - .S POS=+$P(ZERO,U,2) - .I $P(ZERO,U,4) Q ;UNASS - .I '$P(ZERO,U,5) Q ;Not PC - .I $P(ZERO,U,3)>STDD Q ;<11 months - .I $P(ZERO,U,17) Q ;React - .;get preceptor - .S PREC=$$DATES^SCAPMCU1(404.53,+POS),PREC=$S(PREC:$P($G(^SCTM(404.53,+$P(PREC,U,4),0)),U,6),1:+POS) - .S DFN=$P(Q,",",3) - .I $G(XPDIDTOT),('(DFN#5)) D UPDATE^XPDID(DFN) - .S TEAM=$P(Q,",",4),TEAMNM=$P($G(^SCTM(404.51,+TEAM,0)),U) - .N STDT S %DT="",X="T-12M" D ^%DT S STDT=+Y - .;N-new or E-est - .N NEW - .I $P(ZERO,U,3)$P(SCPRO(PRO,SDX),U,2)) S SEEN=1 - Q -DIS ;disch - N ZERO S ZERO=$G(^SCPT(404.43,+ENTRY,0)) - I $P(ZERO,U,4) Q - D DIS2^SCMCTSK7 - Q -CHKENR(DATA,INFO) ;check if patient enrolled in teamposition clinic - S DATA(0)=-1 - Q -EXTEND(DATA,SCTEAM) ;to inact. in next 60 days - ;IEN^POSITION^PATIENT^EXTENDED^REASON - K DATA,SCDATA,SDDATA - N CNT,I,J,K,A,POSA S CNT=1 S SCTEAM=$G(SCTEAM),DATA(1)="" - D DT^DICRW - N SD1 S SDDT="" F SD1=DT,DT-1 I $D(^XTMP("SCMCTSK2-"_SD1,$J,"START")) S SDDT=SD1 Q - I SDDT'>0 D DT^DICRW S SDDT=DT - S X="T-9M" D ^%DT S STDT=Y - S X="T-21M" D ^%DT S TYDT=+Y ;MAKE THIS 21 - S POSA="" - S POS=+$P(SCTEAM,U,2) I POS D POS,EX1 Q - F S POSA=$O(^SCTM(404.57,"ATMPOS",+SCTEAM,POSA)) Q:POSA="" D Q:CNT>100 - .F POS=0:0 S POS=$O(^SCTM(404.57,"ATMPOS",+SCTEAM,POSA,POS)) Q:'POS D POS Q:CNT>100 - I CNT>100 S DATA(1)="TOO MANY" Q -EX1 S A="SDDATA",CNT=1 F S A=$Q(@A) Q:A="" D - .S B=@A - .S DATA(CNT)=(+$P(B,U,3))_U_$TR($P($P(A,"(",2),","),$C(34))_U_$TR($P(B,U,2),$C(34))_U_$P($G(^SCPT(404.43,+$P(B,U,3),0)),U,13)_U_$P($G(^SCPT(404.43,+$P(B,U,3),0)),U,14) - .S CNT=CNT+1 - Q -POS I '$$DATES^SCAPMCU1(404.59,POS) Q ;Position inact - I '$P($G(^SCTM(404.57,POS,0)),U,4) Q ;Not PC - ;patients for position - K ^TMP("SC TMP LIST",$J) - S X=$$PTTP^SCAPMC(POS,"",.SCLIST,.SCERR) - S J=0 F S J=$O(@SCLIST@(J)) Q:'J S SCDATA=^(J) D - .N J I $P(SCDATA,U,4)>STDT Q - .I '$P($G(^SCPT(404.43,+$P(SCDATA,U,3),0)),U,5) Q - .I '$P($G(^SCPT(404.43,+$P(SCDATA,U,3),0)),U,15) Q - .S DFN=+SCDATA - .D SEEN(DFN,POS,TYDT,SDDT,.PROV,.PRECP,.SEEN) Q:SEEN - .S SDDATA($P($G(^SCTM(404.57,POS,0)),U),$P(SCDATA,U,2),+SCDATA)=SCDATA,CNT=CNT+1 - K @SCLIST - Q -FILE(RES,DATA) ;File data on FTEE - N I - F I=1:1 Q:'$D(DATA(I)) D - .S $P(DATA(I),U,7)=$TR($P(DATA(I),U,7),"[]") - .S ZERO=$G(^SCPT(404.43,+DATA(I),0)) - .I $P(ZERO,U,13)=$P(DATA(I),U,6) I $P(ZERO,U,14)=$P(DATA(I),U,7) Q - .S FLDA(404.43,(+DATA(I))_",",.13)=$P(DATA(I),U,6) - .S FLDA(404.43,(+DATA(I))_",",.14)=$E($P(DATA(I),U,7),1,50) - .S FLDA(404.43,(+DATA(I))_",",.16)="`"_(+$G(DUZ)) - I $O(FLDA(0)) D FILE^DIE("E","FLDA","ERR") - Q -SCREEN ;Active assign. screen - N A S A=$G(^SCTM(404.52,D0,0)) - N J S J=-(DT+1),J=$O(^SCTM(404.52,"AIDT",+A,1,J)) I J="" S X=0 Q - I '$P($G(^SCTM(404.57,+A,0)),U,4) Q ;Not PC - I '$$DATES^SCAPMCU1(404.59,+A) Q ;Not an active position - I $O(^SCTM(404.52,"AIDT",+A,0,-(DT+1)))1 - N A S A=$G(^SCTM(404.52,+PAIEN,0)),FTEE=$$SUM(+$P(PAIEN,U,3),+A) - S DATA=0 - S DATA=FTEE+$P(PAIEN,U,2) - Q -SORT(DIPA,SDD) ;sort tmpl - N DIC - S DIC=4,DIC(0)="ZME" - S DIC("S")="I $D(^SCTM(404.51,""AINST"",+Y))" - S DIR("A")="Start with Institution",DIR("B")="FIRST",DIR(0)="F" D ^DIR - I X="FIRST" S DIPA("SI")="",DIPA("EI")="zzz",SDD=1 Q - D ^DIC I Y<0 S DIPA("SI")=X S SDD=X Q:SDD[U D - .S DIR("A")="Go to Institutiton",DIR("B")="LAST" S DIR(0)="F" D ^DIR - .I X="LAST" S DIPA("EI")="zzz" - I Y>0 S DIPA("SI")=$P(Y(0),U),DIC(0)="AZQME",DIC("A")="Go to Institution: " - D ^DIC - I Y>0 S DIPA("EI")=$P(Y(0),U) - I Y<0 S DIPA("EI")=X S SDD=X Q:SDD[U - S SDD=1 Q -FTEERPT ;FTEE REPORT - D FTERPT^SCMCTSK6 Q - Q -POSCHK(DATA,INFO) ; - N PCLASS - ;TEAM POSITION IEN^PC^STANDARD POSITITION IEN - I '$P(INFO,U,3) S DATA="1^Role Must be Entered" Q - I $P(INFO,U,2) I '$P($G(^SD(403.46,+$P(INFO,U,3),0)),U,3) S DATA="1^This Role cannot provide Primary Care" Q - I $P(INFO,U,2),($P($G(^SD(403.46,+$P(INFO,U,3),0)),U,3)=2) I '$$DATES^SCAPMCU1(404.53,+INFO) S DATA="1^This Role cannot provide Primary Care unless Precepted" Q - S DATA=0 - I ('INFO)!('$P(INFO,U,2)) Q - ;Is provider role acceptable? - S J=-(DT+1) S J=$O(^SCTM(404.52,"AIDT",+INFO,1,J)) Q:J="" - I $O(^SCTM(404.52,"AIDT",+INFO,0,-(DT+1)))0 - ;event filer for 1 patient - S SCDFN=+Y W !,SCDFN -SCDFN S SC1="^SCPT(404.43,""APCPOS"",SCDFN,1)" - ;quit if no PC assign - Q:'$D(@SC1) - S SCADT=0 - F S SCADT=$O(@SC1@(SCADT)) Q:SCADT="" D - .S SCTP=0 - .F S SCTP=$O(@SC1@(SCADT,SCTP)) Q:'SCTP D - ..; quit if team position does not exist - ..Q:'$D(^SCTM(404.57,SCTP,0)) - ..S SCPAI=0 - ..F S SCPAI=$O(@SC1@(SCADT,SCTP,SCPAI)) Q:'SCPAI D - ...S SCDDT=$P($G(^SCPT(404.43,SCPAI,0)),U,4) - ...;quit if not active within date range - ...Q:$$DTCHK^SCAPU1(SC177,DT,0,SCADT,SCDDT)<1 - ...N SCVAR S SCVAR=SCPAI_";SCPT(404.43," - ...;add to HL7 event file - ...Q:$D(^SCPT(404.48,"AACXMIT",SCVAR)) - ...Q:$$CHECK^SCMCHLB1(SCVAR)'=1 - ...D ADD^SCMCHLE("NOW",SCVAR,SCDFN,SCTP) - Q -PRSEED ;seed practitioner - N AH,SC177 - S SC177=$$PDAT^SCMCGU("SD*5.3*177") - I +SC177=0 D Q - . S SC2=" No SD*5.3*177 Installation Date." - . D MSG^SCMCCV6(SC1,SC2) - S DIC=200,DIC(0)="MEQA",DIC("A")="Select Provider: " D ^DIC Q:Y'>0 - S SCPROV=+Y - F AH=0:0 S AH=$O(^SCTM(404.52,"C",SCPROV,AH)) Q:'AH S TP=+$G(^SCTM(404.52,+AH,0)) D - . Q:$D(SCTP(TP)) - . S SCTP(TP)=1 - . F SCDFN=0:0 S SCDFN=$O(^SCPT(404.43,"ADFN",SCDFN)) Q:'SCDFN I $D(^(SCDFN,TP)) I '$D(SCU(SCDFN)) D SCDFN S SCU(SCDFN)=1 - . Q:'$P($G(^SCTM(404.57,TP,0)),U,4) - . S SCVAR=AH_";SCTM(404.52," - . ;Quit if an event entry already exists - . N QUIT,I S QUIT=0 - . F I=0:0 S I=$O(^SCPT(404.48,"AACXMIT",SCVAR,I)) Q:'I I $P($G(^SCPT(404.48,I,0)),U,8) S QUIT=1 Q - . Q:QUIT - . D ADD^SCMCHLE("NOW",SCVAR,,AH,1) - Q -INCON ;inconsistent PC assignments - N POS - D INCON^SCMCTSK3 - Q -INCONR ;inconsistent report - N BY - K ^TMP("SCMCTSK",$J) - S DIC="^SCTM(404.57,",(FLDS,BY)="[SCMC INCONSISTENT]",DIOBEG="D INCON^SCMCTSK1" - D EN1^DIP - Q -INACTDT(PA) ;Scheduled inactivation date. - D INACT^SCMCTSK3 Q -IU(DFN) ;is patient inactivity unassigned - Q $$IU^SCMCTSK3(DFN) - N I,A,B,DATA +SCMCTSK1 ;ALB/JDS - PCMM Inactivations; 18 Apr 2003 9:36 AM ; 10/24/07 12:24pm + ;;5.3;Scheduling;**297,498,527**;AUG 13, 1993;Build 6 + Q +INACTIVE ;run every night to determine if patient can be inactivated from + ;team + ;Inactivation happens for patients without activity for 24 months + N I,CNT,SC297,TPZ,TYDT,TEAMN,STDT,Q S CNT=0 + D DT^DICRW S %DT="",X="T-11M" D ^%DT S STDT=Y + S SC297=$$PDAT^SCMCGU("SD*5.3*297"),X1=DT,X2=SC297 D D^%DTC S SC297=X + S X="T-"_$S(SC297>330:"11M",1:"23M") D ^%DT S TYDT=+Y + S A="^SCPT(404.43,""ADFN""",L="""""" + S Q=A_")" + F S Q=$Q(@Q) Q:Q'[A D + .S ENTRY=+$P(Q,",",6) + .S ZERO=$G(^SCPT(404.43,+ENTRY,0)) + .S POS=+$P(ZERO,U,2) + .S TEAM=$P(Q,",",4) + .;I $P($G(^SCTM(404.51,+TEAM,0)),U,16) Q ;no automatic for this team + .;I $G(^DPT(DFN,.35)) D DIS Q ;Patient is deceased + .I $P(ZERO,U,3)>STDT Q ;Later + .I $P(ZERO,U,17) Q ;Already reactivated + .;get preceptor position + .S PREC=$$DATES^SCAPMCU1(404.53,+POS),PREC=$S(PREC:$P($G(^SCTM(404.53,+$P(PREC,U,4),0)),U,6),1:+POS) + .;see if provider changed + .I $O(^SCTM(404.52,"AIDT",+PREC,1,-STDT),-1) Q + .I $P(ZERO,U,4) Q ;Already unassigned + .I '$P(ZERO,U,5) Q ;Not primary care + .;I $P(ZERO,U,16) Q ;No Automatic unassign + .;Check if any activity + .S DFN=$P(Q,",",3) + .I $G(XPDIDTOT),('(DFN#5)) D UPDATE^XPDID(DFN) + .S TEAM=$P(Q,",",4),TEAMNM=$P($G(^SCTM(404.51,+TEAM,0)),U) + .D SEEN Q:SEEN + .I '$P(ZERO,U,15) D + ..S DIE="^SCPT(404.43,",DR=".15////"_DT,DA=ENTRY D ^DIE + ..S TPZ=$G(^SCTM(404.57,+POS,2)) + ..I "TP"[$P(TPZ,U,10) I $G(PROV) S CNT=CNT+1,^TMP("SCF",$J,PROV,CNT,ENTRY)="" + ..I $P(TPZ,U,9),$G(PRECP) S CNT=CNT+1,^TMP("SCF",$J,PRECP,CNT,ENTRY)="" + Q +SEEN ;was patient seen + S SEEN=0 + N SCPRO,I,PRECP,PRO + N X,SCPRDTS,SCPR + ;get list of providers for this position + S PROV=+$$GETPRTP^SCAPMCU2(POS,DT) S SCPRO(+PROV)="" + S SCPRDTS("BEGIN")=TYDT + S SCPRDTS("END")=DT + S X=$$PRTP^SCAPMC(POS,"SCPRDTS","SCPR") + F I=0:0 S I=$O(SCPR(I)) Q:'I S SCPRO(+SCPR(I))="" + S PRECP=0 I $G(PREC),$G(PREC)'=POS S PRECP=+$$GETPRTP^SCAPMCU2(PREC,DT),SCPRO(+PRECP)="" + F I=TYDT:0 S I=$O(^SCE("ADFN",DFN,I)) Q:'I D Q:SEEN + .F J=0:0 S J=$O(^SCE("ADFN",DFN,I,J)) Q:'J D Q:SEEN + ..N VISIT S VISIT=+$P($G(^SCE(J,0)),U,5) I $G(^SCE(J,0))<$G(TYDT) Q + ..F PRO=0:0 S PRO=$O(SCPRO(PRO)) Q:'PRO D Q:SEEN + ...I $D(^SDD(409.44,"AO",J,$G(PRO))) S SEEN=1 Q ;GET THE PROVIDERJ + ...N V F V=0:0 S V=$O(^AUPNVPRV("AD",VISIT,V)) Q:'V I PRO=(+$G(^AUPNVPRV(V,0))) S SEEN=1 Q + Q +DIS ;discharge + N ZERO S ZERO=$G(^SCPT(404.43,+ENTRY,0)) + I $P(ZERO,U,4) Q ;Already discharged + D DIS2^SCMCTSK7 + Q +EXTEND(DATA,SCTEAM) ;return list of patients to inactivate in next 60 days + ;IEN^POSITION^PATIENT^EXTENDED^REASON + K DATA,SCDATA,SDDATA + N CNT,I,J,K,A,POSA S CNT=1 S SCTEAM=$G(SCTEAM),DATA(1)="" + D DT^DICRW S X="T-9M" D ^%DT S STDT=Y + S X="T-21M" D ^%DT S TYDT=+Y ;MAKE THIS 21 + S POSA="" + S POS=+$P(SCTEAM,U,2) I POS D POS,EX1 Q + F S POSA=$O(^SCTM(404.57,"ATMPOS",+SCTEAM,POSA)) Q:POSA="" D Q:CNT>100 + .F POS=0:0 S POS=$O(^SCTM(404.57,"ATMPOS",+SCTEAM,POSA,POS)) Q:'POS D POS Q:CNT>100 + I CNT>100 S DATA(1)="TOO MANY" Q +EX1 S A="SDDATA",CNT=1 F S A=$Q(@A) Q:A="" D + .S B=@A + .S DATA(CNT)=(+$P(B,U,3))_U_$TR($P($P(A,"(",2),","),$C(34))_U_$TR($P(B,U,2),$C(34))_U_$P($G(^SCPT(404.43,+$P(B,U,3),0)),U,13)_U_$P($G(^SCPT(404.43,+$P(B,U,3),0)),U,14) + .S CNT=CNT+1 + Q +POS I '$$DATES^SCAPMCU1(404.59,POS) Q ;Not an active position + I '$P($G(^SCTM(404.57,POS,0)),U,4) Q ;Not PC + ;get patients for this position + K ^TMP("SC TMP LIST",$J) + S X=$$PTTP^SCAPMC(POS,"",.SCLIST,.SCERR) + S J=0 F S J=$O(@SCLIST@(J)) Q:'J S SCDATA=^(J) D + .N J I $P(SCDATA,U,4)>STDT Q + .I '$P($G(^SCPT(404.43,+$P(SCDATA,U,3),0)),U,5) Q + .I '$P($G(^SCPT(404.43,+$P(SCDATA,U,3),0)),U,15) Q + .S DFN=+SCDATA + .D SEEN Q:SEEN + .S SDDATA($P($G(^SCTM(404.57,POS,0)),U),$P(SCDATA,U,2),+SCDATA)=SCDATA,CNT=CNT+1 + K @SCLIST + Q +FILE(RES,DATA) ;File data on FTEE + N I + F I=1:1 Q:'$D(DATA(I)) D + .S $P(DATA(I),U,7)=$TR($P(DATA(I),U,7),"[]") + .S ZERO=$G(^SCPT(404.43,+DATA(I),0)) + .I $P(ZERO,U,13)=$P(DATA(I),U,6) I $P(ZERO,U,14)=$P(DATA(I),U,7) Q + .S FLDA(404.43,(+DATA(I))_",",.13)=$P(DATA(I),U,6) + .S FLDA(404.43,(+DATA(I))_",",.14)=$E($P(DATA(I),U,7),1,50) + .S FLDA(404.43,(+DATA(I))_",",.16)="`"_(+$G(DUZ)) + I $O(FLDA(0)) D FILE^DIE("E","FLDA","ERR") + Q +SCREEN ;Screen for active assignments + N A S A=$G(^SCTM(404.52,D0,0)) + N J S J=-(DT+1),J=$O(^SCTM(404.52,"AIDT",+A,1,J)) I J="" S X=0 Q + I '$P($G(^SCTM(404.57,+A,0)),U,4) Q ;Not PC + I '$$DATES^SCAPMCU1(404.59,+A) Q ;Not an active position + I $O(^SCTM(404.52,"AIDT",+A,0,-(DT+1)))0 S DIPA("SI")=$P(Y(0),U),DIC(0)="AZQME",DIC("A")="Go to Institution: " + D ^DIC + I Y>0 S DIPA("EI")=$P(Y(0),U) + I Y<0 S DIPA("EI")=X Q:X[U + S X=1 Q +FTEERPT ;FTEE REPORT + D FTERPT^SCMCTSK6 Q + Q +POSCHK(DATA,INFO) ; + N PCLASS + ;TEAM POSITION IEN^PC^STANDARD POSITITION IEN + I '$P(INFO,U,3) S DATA="1^Role Must be Entered" Q + I $P(INFO,U,2) I '$P($G(^SD(403.46,+$P(INFO,U,3),0)),U,3) S DATA="1^This Role cannot provide Primary Care" Q + I $P(INFO,U,2),($P($G(^SD(403.46,+$P(INFO,U,3),0)),U,3)=2) I '$$DATES^SCAPMCU1(404.53,+INFO) S DATA="1^This Role cannot provide Primary Care unless Precepted" Q + S DATA=0 + I ('INFO)!('$P(INFO,U,2)) Q + ;Check if provider can be in this role. + S J=-(DT+1) S J=$O(^SCTM(404.52,"AIDT",+INFO,1,J)) Q:J="" + I $O(^SCTM(404.52,"AIDT",+INFO,0,-(DT+1)))0 + ;event filer for 1 patient + S SCDFN=+Y W !,SCDFN +SCDFN S SC1="^SCPT(404.43,""APCPOS"",SCDFN,1)" + ; + ;quit if no PC assignments + Q:'$D(@SC1) + S SCADT=0 + F S SCADT=$O(@SC1@(SCADT)) Q:SCADT="" D + . S SCTP=0 + . F S SCTP=$O(@SC1@(SCADT,SCTP)) Q:'SCTP D + . . ; + . . ; quit if team position does not exist + . . Q:'$D(^SCTM(404.57,SCTP,0)) + . . S SCPAI=0 + . . F S SCPAI=$O(@SC1@(SCADT,SCTP,SCPAI)) Q:'SCPAI D + . . . S SCDDT=$P($G(^SCPT(404.43,SCPAI,0)),U,4) + . . . ; + . . . ; quit if not active within date range + . . . Q:$$DTCHK^SCAPU1(SC177,DT,0,SCADT,SCDDT)<1 + . . . N SCVAR S SCVAR=SCPAI_";SCPT(404.43," + . . . ; + . . . ; add to HL7 event file + . . . Q:$D(^SCPT(404.48,"AACXMIT",SCVAR)) + . . . Q:$$CHECK^SCMCHLB1(SCVAR)'=1 + . . . D ADD^SCMCHLE("NOW",SCVAR,SCDFN,SCTP) + Q +PRSEED ;seed practitioner + N AH,SC177 + S SC177=$$PDAT^SCMCGU("SD*5.3*177") + I +SC177=0 D Q + . S SC2=" Unable to obtain SD*5.3*177 Installation Date." + . D MSG^SCMCCV6(SC1,SC2) + . Q + S DIC=200,DIC(0)="MEQA",DIC("A")="Select Provider: " D ^DIC Q:Y'>0 + S SCPROV=+Y + F AH=0:0 S AH=$O(^SCTM(404.52,"C",SCPROV,AH)) Q:'AH S TP=+$G(^SCTM(404.52,+AH,0)) D + . Q:$D(SCTP(TP)) + . S SCTP(TP)=1 + . F SCDFN=0:0 S SCDFN=$O(^SCPT(404.43,"ADFN",SCDFN)) Q:'SCDFN I $D(^(SCDFN,TP)) I '$D(SCU(SCDFN)) D SCDFN S SCU(SCDFN)=1 + . Q:'$P($G(^SCTM(404.57,TP,0)),U,4) + . S SCVAR=AH_";SCTM(404.52," + . ;Quit if an event entry already exists + . N QUIT,I S QUIT=0 + . F I=0:0 S I=$O(^SCPT(404.48,"AACXMIT",SCVAR,I)) Q:'I I $P($G(^SCPT(404.48,I,0)),U,8) S QUIT=1 Q + . Q:QUIT + . D ADD^SCMCHLE("NOW",SCVAR,,AH,1) + Q +INCON ;get list of incositent provider assignments + N POS + D INCON^SCMCTSK3 + Q +INCONR ;inconsistent report + N BY + K ^TMP("SCMCTSK",$J) + S DIC="^SCTM(404.57,",(FLDS,BY)="[SCMC INCONSISTENT]",DIOBEG="D INCON^SCMCTSK1" + D EN1^DIP + Q +CHKENR(DATA,INFO) ;check if patient enrolled in teamposition clinic + S DATA(0)=-1 + N I + N POS,DFN S DFN=+$G(INFO) Q:'DFN S POS=+$P($G(INFO),U,2) Q:'POS + F I=0:0 S I=$O(^SCTM(404.57,POS,5,I)) Q:'I D CECHK^SCRPPAT2(I,.CNAME,DFN) I $L(CNAME) S:DATA(0)=-1 DATA(0)="" S DATA(0)=DATA(0)_CNAME_"." + I DATA(0)'=-1 S DATA(0)=$E(DATA(0),1,$L(DATA(0))-2) + Q +INACTDT(PA) ;Scheduled inactivation date. + D INACT^SCMCTSK3 Q +IU(DFN) ;is patient inactivity unassigned + Q $$IU^SCMCTSK3(DFN) + N I,A,B,DATA diff --git a/r/SCHEDULING-SD-SC/SCMCTSK2.m b/r/SCHEDULING-SD-SC/SCMCTSK2.m index 016a16c6..03428fc9 100644 --- a/r/SCHEDULING-SD-SC/SCMCTSK2.m +++ b/r/SCHEDULING-SD-SC/SCMCTSK2.m @@ -1,245 +1,238 @@ -SCMCTSK2 ;ALB/JDS - PCMM Inactivation Nightly Job; 18 Apr 2003 9:36 AM ; 10/24/07 12:23pm ; Compiled November 21, 2007 13:32:47 ; Compiled March 17, 2008 15:27:15 - ;;5.3;Scheduling;**297,498,527,499**;AUG 13, 1993;Build 21 - Q -NIGHT ; - N ENDDT,NOINAC,SIXM,FLGDT,L,PATDT,SEEN,SDDT - D DT^DICRW S SDDT=$P($G(^XTMP("SCMCTSK2-"_DT,0)),U,2) - I SDDT="" S SDDT=DT - S ALPHA=$G(^SCTM(404.44,1,1)),ALPHA=$P(ALPHA,U,8) I ALPHA12 months since flagging, not NEW, E-stbl) - ..N NEW - ..S NEW=0 S X1=DATE,X2=SDASS D ^%DTC I X<365 S NEW=1 - ..I NEW S %DT="",X="T-12M" D ^%DT S STDT=+Y D - ...S X1=STDT,X2=-7 D C^%DTC S TYDT=X - ..I 'NEW S %DT="",X="T-24M" D ^%DT S STDT=+Y D - ...S X1=STDT,X2=-7 D C^%DTC S TYDT=X - ..; - ..I $P(ZERO,U,17) D UNFLG Q ;react. - ..;get prec - ..;S %DT="",X="T-12M" D ^%DT S STDT=+Y - ..;S PREC=$$DATES^SCAPMCU1(404.53,+POS),PREC=$S(PREC:$P($G(^SCTM(404.53,+$P(PREC,U,4),0)),U,6),1:+POS) - ..I '$P(ZERO,U,5) D UNFLG Q ;Not PC - ..D SEEN^SCMCTSK1(DFN,POS,TYDT,SDDT,.PROV,.PRECP,.SEEN) - ..;S PC=$$GET^XUA4A72(+PROV) - ..I SEEN D UNFLG Q - ..I $P(ZERO,U,13) S X1=DATE,X2=$S(ALPHA:4,1:90) D C^%DTC S FLGDT=X I FLGDT>SDDT Q ;do not inactivate yet; extended - ..I ('NOINAC)&(SDDT'SDDT D - .D PRINAC - .N FLDA - .S FLDA(404.44,"1,",19)="" - .D FILE^DIE("I","FLDA","ERR") - D BULL K ^TMP($J,"SCMCTSK2") - Q -UNFLG ;Unflagging - N DR,DIE,DA - S DR=".15///@;.13///@;.12///@",DIE="^SCPT(404.43,",DA=ENTRY D ^DIE - Q -PRFLAG ;flag incorrect provider pos - N POS - ;prov inact. has run once - I $P($G(^SCTM(404.44,1,1)),U,11)'="" Q - D PRFLAG^SCMCTSK3 - Q -PRINAC ;inact. flagged providers - N I,II - ;Prov inact. run already - I $G(SDDT)="" S SDDT=DT - S II=$P($G(^SCTM(404.44,1,1)),U,11) I II'="",II'=SDDT Q - F I=0:0 S I=$O(^SCTM(404.52,I)) Q:'I S ZERO=$G(^(I,0)) I $P(ZERO,U,10) D - .;I $P(ZERO,U,10)>$G(ENDT) Q ;not time yet - .I $O(^SCTM(404.52,"AIDT",+ZERO,0,-9999999))<(-$P(ZERO,U,2)) Q ;inactivated - .;Check valid criteria - .S POS=+ZERO - .S PROV=+$$GETPRTP^SCAPMCU2(POS,SDDT) - .S PC=$$GET^XUA4A72(+PROV) - .S DR=".091///@",DIE="^SCTM(404.52,",DA=I D ^DIE ;remove flag - .S ZERO1=$G(^SCTM(404.57,POS,0)) - .I '$D(^SD(403.46,+$P(ZERO1,U,3),2,+PC)) D - ..;inactivation - ..S DIC="^SCTM(404.52,",X=+ZERO,DIC("DR")=".02////"_SDDT_";.03////"_$P(ZERO,U,3)_";.04////0;.05///EMPLOYEE LEAVES POSITION;.11////1" - ..S DIC(0)="LM" D ^DIC - ;only run inact. once - S $P(^SCTM(404.44,1,1),U,11)=SDDT - Q -FUTAPP(DFN) ;print future appts - N TAB,SCDT0 S TAB=$X - I $G(SDDT)="" S SDDT=DT - S SCDT=SDDT+.24 - F S SCDT=$O(^DPT(DFN,"S",SCDT)) Q:'SCDT D - . S SCDT0=$G(^DPT(DFN,"S",SCDT,0)) Q:$L($P(SCDT0,U,2)) - . S CLIEN=$P(SCDT0,"^") Q:'CLIEN - . S Y=SCDT X ^DD("DD") W $E(Y_" ",1,17)_" "_$E($P($G(^SC(+CLIEN,0)),U),1,10) - Q -GETASC(DATA,ENTRY) ;get assoc. clinics - N I,CNT S CNT=0 - F I=0:0 S I=$O(^SCTM(404.57,+$G(ENTRY),5,I)) Q:'I S CNT=CNT+1,DATA(CNT)=I_U_$P($G(^SC(I,0)),U) - Q -SETASC(RESULT,DATA) ;set assoc. clinics - D SETASC^SCMCTSK7(.RESULT,DATA) Q -MSG(SCTP,DFN) ;send inact. message - ;given valid positions get current practitioners - S SCLIST="SCL" - I $G(SDDT)="" S SDDT=DT - I "N"'[$P($G(^SCTM(404.57,SCTP,2)),U,9) D - .S SCOK=$$PRTP^SCAPMC(SCTP,"",.SCLIST,.SCERR) - .;if preceptor notice turned on for message type - I +$P($G(^SCTM(404.57,SCTP,2)),U,9) D - .S SCX=+$$OKPREC2^SCMCLK(SCTP,SDDT) - .;if preceptor duz returned, add to array - .I SCX S @SCLIST@("SCPR",SCX)="" - N XMY F I=0:0 S I=$O(@SCLIST@("SCPR",I)) Q:'I S XMY(I)="" - S SCTEXT(1,0)="PATIENT "_$P($G(^DPT(DFN,0)),U)_" has been inactivated from PC team position "_$P($G(^SCTM(404.57,SCTP,0)),U) - S XMSUB="Provider's Inactivated Primary Care Patients" D ^XMD - Q -BULL ;EOM Bulletin - N DISUPNO,BY,DHIT,HEAD - S DISUPNO=1,L=0 - S XMSUB="Patients Scheduled for Inactivation from PC Panel" - S XMY("G.PCMM PATIENT/PROVIDER INACTIVE")="" - K ^TMP("SCMC",$J),^TMP("SCMCTXT",$J),^TMP("SCML",$J) - S XMTEXT="^TMP(""SCMCTXT"",$J," ;S @XMTEXT@(0)="" - S DIC="^SCPT(404.43,",BY="[SCMC FLAGGED BULLETIN]",FLDS="[SC BULLETIN]",CNT=0 - S:0 FLDS="" S IOP="",DHD="@@",(FR,TO)="" D EN1^DIP - S ^TMP("SCMCTXT",$J,1,0)="There are "_$O(^TMP("SCMC",$J,""),-1)_" Patients scheduled for inactivation in next 30 days" - D LINES(1) - D ^XMD - D PRMAIL^SCMCTSK5(1) - F SCI=0:0 S SCI=$O(^TMP("SCF",$J,SCI)) Q:'SCI D - .K XMY S XMY(SCI)="" K ^TMP("SCMC",$J),^TMP("SCMCTXT",$J) - .M ^TMP("SCMC",$J)=^TMP("SCF",$J,SCI) - .S XMSUB="Patients Scheduled for Inactivation from PC Panel" - .S XMTEXT="^TMP(""SCMCTXT"",$J," - S DISUPNO=1 - K ^TMP("SCMC",$J),^TMP("SCMCTXT") - I $G(NOINAC) K ^TMP($J,"SCMCTSK2") Q ; SD/499 - S XMSUB="Patients With Extended PCMM Inactivation Dates" - S XMY("G.PCMM PATIENT/PROVIDER INACTIVE")="" - K ^TMP("SCMC",$J) - S XMTEXT="^TMP(""SCMCTXT"",$J," ;S @XMTEXT@(0)="" - S DIC="^SCPT(404.43,",BY="[SCMC EXTENDED BULLETIN]",DHIT="S CNT=$G(CNT)+1,^TMP(""SCMC"",$J,CNT,D0)=""""",CNT=0 - S FR=",,,",TO=FR,FLDS="",IOP="",DHD="@@" D EN1^DIP - S ^TMP("SCMCTXT",$J,1,0)="There are "_$O(^TMP("SCMC",$J,""),-1)_" Patients Extended from inactivation" - D LINES(3) - D ^XMD - D PRMAIL^SCMCTSK5(3) - S DISUPNO=1 - K ^TMP("SCMC",$J),^TMP("SCMCTXT") - S XMSUB="Patients Automated Inactivations from PC Panels" - S XMY("G.PCMM PATIENT/PROVIDER INACTIVE")="" - K ^TMP("SCMC",$J) - S XMTEXT="^TMP(""SCMCTXT"",$J," ;S @XMTEXT@(0)="" - S DIC="^SCPT(404.43,",BY="[SCMC INACTIVATED]",DHIT="S CNT=$G(CNT)+1,^TMP(""SCMC"",$J,CNT,D0)=""""",CNT=0 - S FLDS="",IOP="",DHD="@@",FR=",T-30,,",TO=",,,,," D EN1^DIP - S ^TMP("SCMCTXT",$J,1,0)="There are "_$O(^TMP("SCMC",$J,""),-1)_" Patients Inactivated in last 30 days" - D LINES(2) - D ^XMD - S DISUPNO=1 - D PRMAIL^SCMCTSK5(2) - K ^TMP("SCMC",$J),^TMP("SCMCTXT") - I $P($G(^SCTM(404.44,1,1)),U,11)="" D - . S XMSUB="PC Providers Scheduled for Inactivation" - . S XMY("G.PCMM PATIENT/PROVIDER INACTIVE")="" - . K ^TMP("SCMC",$J) - . S XMTEXT="^TMP(""SCMCTXT"",$J," - . S DIC="^SCTM(404.52,",BY="[SC PROVIDER FLAGGED BULLE]",DHIT="S CNT=$G(CNT)+1,^TMP(""SCMC"",$J,CNT,D0)=""""",CNT=0 - . S FLDS="",IOP="",DHD="@@",FR="",TO="" D EN1^DIP - . D LINES(4) - . D ^XMD - . D PRMAIL^SCMCTSK5(4) - . D BULL^SCMCTSK6 - Q -LINES(TYPE) ;Lines of Bulletin - D LINES^SCMCTSK5(TYPE) Q -ROLE(DATA,INFO) ;SCMC ROLE - N ROLE,TP,I - S ROLE=+$G(INFO),TP=+$P($G(INFO),U,2) - S DATA(0)="0^0^0" - I 'ROLE Q - I 'TP Q - S DATA(0)=+$P($G(^SD(403.46,ROLE,0)),U,3) ;I DATA(0)=3!(DATA(0)=0) S DATA(0)=DATA(0)_"^0^0" Q - I $$DATES^SCAPMCU1(404.53,+TP) S DATA(0)=DATA(0)_"^1^0" Q - N PREC S PREC=0 - F I=0:0 S I=$O(^SCTM(404.53,"AD",TP,I)) Q:'I D Q:PREC - .I $D(^SCTM(404.53,"AD",TP,I,1)) I '$D(^(0)) S PREC=1 - I PREC S DATA(0)=DATA(0)_"^0^1" Q - S DATA(0)=DATA(0)_"^0^0" - Q -INRPT ; REPORT - N DIOEND,SCDHD - D PROMPT^SCMCTSK3("** Date Range Selection **","DATE PATIENTS INACTIVATED FROM PC PANELS") - Q:'$D(^TMP("SC",$J,"XR")) - D UNASSIGN^SCMCTSK3 - S Q="""" - S DIC="^SCPT(404.43," ;=0,BY="[SCMC INACTIVATION SORT]" - D BY - S (SCDHD,DHD)="AUTOMATED PATIENT INACTIVATION FROM PRIMARY CARE PANELS REPORT" - S DIOBEG="D DIOBEG^SCMCTSK4" - S DIOEND="D DIOEND1^SCMCTSK4" - S FLDS="[SCMC INACTIVATED]" ;,FR="?,,"_$TR(DIPA("SI"),","," "),TO="T,,"_$TR(DIPA("EI")_"z",","," ") - D EN1^DIP - Q -IN30 ;inact. last month - N DIPA,SDD D SORT^SCMCTSK1(.DIPA,.SDD) Q:'SDD ;SD/499 - S Q="""" - S DIC="^SCPT(404.43,",L=0,BY="[SCMC INACTIVATION SORT]" - S DHD="Patients Inactivated from Primary Care Panels in the Past Month" - S FLDS="[SCMC INACTIVATED]",FR="T-31,,"_$TR(DIPA("SI"),","," "),TO="T,,"_$TR(DIPA("EI")_"z",","," ") - D EN1^DIP - Q -EXRPT ;EXTEND REPORT - K CLIN,TEAM,INST - D PROMPT^SCMCTSK3("PCMM Patients with Extended Inactivations","Scheduled Inactivation Date") - Q:'$D(^TMP("SC",$J,"XR")) - S Q="""",SORT=1 - D EXTEND^SCMCTSK3 - S DIC="^SCPT(404.43," ;,L=0,BY="[SCMC EXTENDED]" - S (SCDHD,DHD)="PCMM Patients with extended Inactivations" - S DIOBEG="D DIOBEG^SCMCTSK4",DIOEND="D EXTKEY^SCMCTSK9" - D BY - S FLDS="[SCMC EXTENDED]" - D EN1^DIP - Q -BY N DISPAR - S BY(0)="^TMP(""SCSORT"",$J)",L(0)=$O(^TMP("SC",$J,"SORT",99),-1)+1,DISPAR(0,1)="+",L=0 I $G(SCDHD)["FTEE" S DISPAR(0,1)="+#" ;BY="@'.01" - F I=1:1:$L(SORTN,U) S A=$P(SORTN,U,I) Q:'$L(A) S $P(DISPAR(0,I),U,2)=";"_Q_A_": "_Q D - .I A["PATIENT" I (I>1)!($G(SCDHD)["Patients Scheduled for Inactivation from PC Panel") S $P(DISPAR(0,I),U)="@" - .I $G(SCDHD)["FTEE" D - ..I A["PROV" S $P(DISPAR(0,I),U)="@" - ..I I>1 I (A["CLI")!(A["POS") S $P(DISPAR(0,I),U)="@"_$P($G(DISPAR(0,I)),U) - S ZTSAVE("^TMP(""SC"",$J,")="",ZTSAVE("^TMP(""SCSORT"",$J,")="" - Q -FLRPT ;FLAGGED REPORT - D PROMPT^SCMCTSK3("Patients Scheduled for Inactivation from PC Panels","Date Scheduled for Inactivation") - Q:'$D(^TMP("SC",$J,"XR")) - D FLAGG^SCMCTSK3 - S Q="""" - S DIC="^SCPT(404.43,",L=0 - S (SCDHD,DHD)="Patients Scheduled for Inactivation from PC Panels" - D BY - S DIOBEG="D DIOBEG^SCMCTSK4" - S FLDS="[SCMC PENDING UNASSIGN]" - I $G(DISPAR(0,1))["PATIENT" S FLDS="[SCMC PENDING UNASSIGN PAT]" - S DIOEND="D DIOEND^SCMCTSK4" - D EN1^DIP +SCMCTSK2 ;ALB/JDS - PCMM Inactivation Nightly Job; 18 Apr 2003 9:36 AM ; 10/24/07 12:23pm + ;;5.3;Scheduling;**297,498,527**;AUG 13, 1993;Build 6 + Q +NIGHT ;nightly task for inact. + N ENDDT,NOINAC,SIXM,FLGDT,L,PATDT,SEEN + K ^TMP("SCTSK",$J) + D DT^DICRW + S ALPHA=$G(^SCTM(404.44,1,1)),ALPHA=$P(ALPHA,U,8) I ALPHA
ENDDT))) D + .F ENTRY=0:0 S ENTRY=$O(^SCPT(404.43,"AFLG",DATE,ENTRY)) Q:'ENTRY D + ..S ZERO=$G(^SCPT(404.43,ENTRY,0)) Q:'ZERO + ..S DFN=+$G(^SCPT(404.42,+ZERO,0)) Q:'DFN + ..S POS=$P(ZERO,U,2) + ..I $P(ZERO,U,4) D UNFLG Q ;already unassigned + ..I $P(ZERO,U,13) S X1=DATE,X2=$S(ALPHA:4,1:90) D C^%DTC S FLGDT=X I FLGDT>DT Q ;ext + ..;check if criteria still met + ..I $P(ZERO,U,17) D UNFLG Q ;Already reactivated + ..;get preceptor position + ..S %DT="",X="T-12M" D ^%DT S STDT=+Y + ..S PREC=$$DATES^SCAPMCU1(404.53,+POS),PREC=$S(PREC:$P($G(^SCTM(404.53,+$P(PREC,U,4),0)),U,6),1:+POS) + ..;see if provider changed + ..I $O(^SCTM(404.52,"AIDT",+PREC,1,-STDT),-1) D UNFLG Q + ..I '$P(ZERO,U,5) D UNFLG Q ;Not primary care + ..S PROV=+$$GETPRTP^SCAPMCU2(POS,DT) + ..S PC=$$GET^XUA4A72(+PROV) + ..S SC297=$$PDAT^SCMCGU("SD*5.3*297") + ..N NEW S NEW=$S($P(ZERO,U,3)330:0,1:1) + ..S X1=DT,X2=SC297 D D^%DTC S SC297=X + ..S X="T-"_$S(SC297>365:"11M",NEW:"11M",1:"23M") D ^%DT S TYDT=+Y D SEEN^SCMCTSK1 I $G(SEEN) D UNFLG Q + ..S X="T-"_$S(SC297>365:"12M",NEW:"12M",1:"24M") D ^%DT S TYDT=+Y D SEEN^SCMCTSK1 I $G(SEEN) D:(DATE>ENDDT) UNFLG Q + ..I ('NOINAC)&(DATE'>ENDDT) D DIS^SCMCTSK1 + ..;D MSG(POS,DFN) + ;if 6 months after installation check to flag providers + I NOINAC D:ALPHA BULL Q + S PATDT=$$PDAT^SCMCGU("SD*5.3*297") Q:'PATDT + I SIXM,SIXM'>DT D + .D PRINAC + .N FLDA + .S FLDA(404.44,"1,",19)="" + .D FILE^DIE("I","FLDA","ERR") + D BULL + Q +UNFLG ;Remove the flag + N DR,DIE,DA + S DR=".15///@;.13///@;.12///@",DIE="^SCPT(404.43,",DA=ENTRY D ^DIE + Q +PRFLAG ;flag incorrect provider positions + N POS + ;provider inactivation has run once + I $P($G(^SCTM(404.44,1,1)),U,11)'="" Q + D PRFLAG^SCMCTSK3 + Q +PRINAC ;inactivate flagged providers + N I,II + ;Provider inactivation run already + S II=$P($G(^SCTM(404.44,1,1)),U,11) I II'="",II'=DT Q + F I=0:0 S I=$O(^SCTM(404.52,I)) Q:'I S ZERO=$G(^(I,0)) I $P(ZERO,U,10) D + .;I $P(ZERO,U,10)>$G(ENDT) Q ;not time yet + .I $O(^SCTM(404.52,"AIDT",+ZERO,0,-9999999))<(-$P(ZERO,U,2)) Q ;already inactivated + .;Check if criteria still valid + .S POS=+ZERO + .S PROV=+$$GETPRTP^SCAPMCU2(POS,DT) + .S PC=$$GET^XUA4A72(+PROV) + .S DR=".091///@",DIE="^SCTM(404.52,",DA=I D ^DIE ;remove flag + .S ZERO1=$G(^SCTM(404.57,POS,0)) + .I '$D(^SD(403.46,+$P(ZERO1,U,3),2,+PC)) D + ..;enter the inactivation + ..S DIC="^SCTM(404.52,",X=+ZERO,DIC("DR")=".02////"_DT_";.03////"_$P(ZERO,U,3)_";.04////0;.05///EMPLOYEE LEAVES POSITION;.11////1" + ..S DIC(0)="LM" D ^DIC + ;only run the inactivation once. + S $P(^SCTM(404.44,1,1),U,11)=DT + Q +FUTAPP(DFN) ;print future appointments + N TAB,SCDT0 S TAB=$X + S SCDT=DT+.24 + F S SCDT=$O(^DPT(DFN,"S",SCDT)) Q:'SCDT D + . S SCDT0=$G(^DPT(DFN,"S",SCDT,0)) Q:$L($P(SCDT0,U,2)) + . S CLIEN=$P(SCDT0,"^") Q:'CLIEN + . S Y=SCDT X ^DD("DD") W $E(Y_" ",1,17)_" "_$E($P($G(^SC(+CLIEN,0)),U),1,10) + Q +GETASC(DATA,ENTRY) ;get associated clinics + N I,CNT S CNT=0 + F I=0:0 S I=$O(^SCTM(404.57,+$G(ENTRY),5,I)) Q:'I S CNT=CNT+1,DATA(CNT)=I_U_$P($G(^SC(I,0)),U) + Q +SETASC(RESULT,DATA) ;set associated clinics + D SETASC^SCMCTSK7(.RESULT,DATA) Q +MSG(SCTP,DFN) ;send inactivation message + ;given list of valid positions get current practitioners + S SCLIST="SCL" + I "N"'[$P($G(^SCTM(404.57,SCTP,2)),U,9) D + .S SCOK=$$PRTP^SCAPMC(SCTP,"",.SCLIST,.SCERR) + .;if preceptor notice turned on for message type + I +$P($G(^SCTM(404.57,SCTP,2)),U,9) D + .S SCX=+$$OKPREC2^SCMCLK(SCTP,DT) + .;if preceptor duz returned, add to array + .I SCX S @SCLIST@("SCPR",SCX)="" + N XMY F I=0:0 S I=$O(@SCLIST@("SCPR",I)) Q:'I S XMY(I)="" + S SCTEXT(1,0)="PATIENT "_$P($G(^DPT(DFN,0)),U)_" has been inactivated from primary care team position "_$P($G(^SCTM(404.57,SCTP,0)),U) + S XMSUB="Provider's Inactivated Primary Care Patients" D ^XMD + Q +BULL ;end of Month Bulletin + N DISUPNO,BY,DHIT,HEAD + S DISUPNO=1,L=0 + S XMSUB="Patients Scheduled for Inactivation from Primary Care Panel" + S XMY("G.PCMM PATIENT/PROVIDER INACTIVE")="" + K ^TMP("SCMC",$J),^TMP("SCMCTXT",$J),^TMP("SCML",$J) + S XMTEXT="^TMP(""SCMCTXT"",$J," ;S @XMTEXT@(0)="" + S DIC="^SCPT(404.43,",BY="[SCMC FLAGGED BULLETIN]",FLDS="[SC BULLETIN]",CNT=0 + S:0 FLDS="" S IOP="",DHD="@@",(FR,TO)="" D EN1^DIP + S ^TMP("SCMCTXT",$J,1,0)="There are "_$O(^TMP("SCMC",$J,""),-1)_" Patients scheduled for inactivation in next 30 days" + D LINES(1) + D ^XMD + D PRMAIL^SCMCTSK5(1) + F SCI=0:0 S SCI=$O(^TMP("SCF",$J,SCI)) Q:'SCI D + .K XMY S XMY(SCI)="" K ^TMP("SCMC",$J),^TMP("SCMCTXT",$J) + .M ^TMP("SCMC",$J)=^TMP("SCF",$J,SCI) + .S XMSUB="Patients Scheduled for Inactivation from Primary Care Panel" + .S XMTEXT="^TMP(""SCMCTXT"",$J," + .;D LINES(1) D ^XMD + S DISUPNO=1 + K ^TMP("SCMC",$J),^TMP("SCMCTXT") + S XMSUB="Patients With Extended PCMM Inactivation Dates" + S XMY("G.PCMM PATIENT/PROVIDER INACTIVE")="" + K ^TMP("SCMC",$J) + S XMTEXT="^TMP(""SCMCTXT"",$J," ;S @XMTEXT@(0)="" + S DIC="^SCPT(404.43,",BY="[SCMC EXTENDED BULLETIN]",DHIT="S CNT=$G(CNT)+1,^TMP(""SCMC"",$J,CNT,D0)=""""",CNT=0 + S FR=",,,",TO=FR,FLDS="",IOP="",DHD="@@" D EN1^DIP + S ^TMP("SCMCTXT",$J,1,0)="There are "_$O(^TMP("SCMC",$J,""),-1)_" Patients Extended from inactivation" + D LINES(3) + D ^XMD + D PRMAIL^SCMCTSK5(3) + S DISUPNO=1 + K ^TMP("SCMC",$J),^TMP("SCMCTXT") + S XMSUB="Patients Automated Inactivations from Primary Care Panels" + S XMY("G.PCMM PATIENT/PROVIDER INACTIVE")="" + K ^TMP("SCMC",$J) + S XMTEXT="^TMP(""SCMCTXT"",$J," ;S @XMTEXT@(0)="" + S DIC="^SCPT(404.43,",BY="[SCMC INACTIVATED]",DHIT="S CNT=$G(CNT)+1,^TMP(""SCMC"",$J,CNT,D0)=""""",CNT=0 + S FLDS="",IOP="",DHD="@@",FR=",T-30,,",TO=",,,,," D EN1^DIP + S ^TMP("SCMCTXT",$J,1,0)="There are "_$O(^TMP("SCMC",$J,""),-1)_" Patients Inactivated in last 30 days" + D LINES(2) + D ^XMD + S DISUPNO=1 + D PRMAIL^SCMCTSK5(2) + K ^TMP("SCMC",$J),^TMP("SCMCTXT") + I $P($G(^SCTM(404.44,1,1)),U,11)="" D + . S XMSUB="Primary Care Providers Scheduled for Inactivation" + . S XMY("G.PCMM PATIENT/PROVIDER INACTIVE")="" + . K ^TMP("SCMC",$J) + . S XMTEXT="^TMP(""SCMCTXT"",$J," + . S DIC="^SCTM(404.52,",BY="[SC PROVIDER FLAGGED BULLE]",DHIT="S CNT=$G(CNT)+1,^TMP(""SCMC"",$J,CNT,D0)=""""",CNT=0 + . S FLDS="",IOP="",DHD="@@",FR="",TO="" D EN1^DIP + . D LINES(4) + . D ^XMD + . D PRMAIL^SCMCTSK5(4) + . D BULL^SCMCTSK6 + Q +LINES(TYPE) ;Lines of Bulletin + D LINES^SCMCTSK5(TYPE) Q +ROLE(DATA,INFO) ;SCMC ROLE + N ROLE,TP,I + S ROLE=+$G(INFO),TP=+$P($G(INFO),U,2) + S DATA(0)="0^0^0" + I 'ROLE Q + I 'TP Q + S DATA(0)=+$P($G(^SD(403.46,ROLE,0)),U,3) ;I DATA(0)=3!(DATA(0)=0) S DATA(0)=DATA(0)_"^0^0" Q + I $$DATES^SCAPMCU1(404.53,+TP) S DATA(0)=DATA(0)_"^1^0" Q + N PREC S PREC=0 + F I=0:0 S I=$O(^SCTM(404.53,"AD",TP,I)) Q:'I D Q:PREC + .I $D(^SCTM(404.53,"AD",TP,I,1)) I '$D(^(0)) S PREC=1 + I PREC S DATA(0)=DATA(0)_"^0^1" Q + S DATA(0)=DATA(0)_"^0^0" + Q +INRPT ; REPORT + N DIOEND,SCDHD + D PROMPT^SCMCTSK3("**** Date Range Selection ****","DATE PATIENTS INACTIVATED FROM PRIMARY CARE PANELS") + Q:'$D(^TMP("SC",$J,"XR")) + D UNASSIGN^SCMCTSK3 + S Q="""" + S DIC="^SCPT(404.43," ;=0,BY="[SCMC INACTIVATION SORT]" + D BY + S (SCDHD,DHD)="AUTOMATED PATIENT INACTIVATION FROM PRIMARY CARE PANELS REPORT" + S DIOBEG="D DIOBEG^SCMCTSK4" + S DIOEND="D DIOEND1^SCMCTSK4" + S FLDS="[SCMC INACTIVATED]" ;,FR="?,,"_$TR(DIPA("SI"),","," "),TO="T,,"_$TR(DIPA("EI")_"z",","," ") + D EN1^DIP + Q +IN30 ;inactivated last month + D SORT^SCMCTSK1 Q:'X + S Q="""" + S DIC="^SCPT(404.43,",L=0,BY="[SCMC INACTIVATION SORT]" + S DHD="Patients Inactivated from Primary Care Panels in the Past Month" + S FLDS="[SCMC INACTIVATED]",FR="T-31,,"_$TR(DIPA("SI"),","," "),TO="T,,"_$TR(DIPA("EI")_"z",","," ") + D EN1^DIP + Q +EXRPT ;EXTEND REPORT + K CLIN,TEAM,INST + D PROMPT^SCMCTSK3("PCMM Patients with Extended Inactivations","Scheduled Inactivation Date") + Q:'$D(^TMP("SC",$J,"XR")) + S Q="""",SORT=1 + D EXTEND^SCMCTSK3 + S DIC="^SCPT(404.43," ;,L=0,BY="[SCMC EXTENDED]" + S (SCDHD,DHD)="PCMM Patients with extended Inactivations" + S DIOBEG="D DIOBEG^SCMCTSK4",DIOEND="D EXTKEY^SCMCTSK9" + D BY + S FLDS="[SCMC EXTENDED]" + D EN1^DIP + Q +BY N DISPAR + S BY(0)="^TMP(""SCSORT"",$J)",L(0)=$O(^TMP("SC",$J,"SORT",99),-1)+1,DISPAR(0,1)="+",L=0 I $G(SCDHD)["FTEE" S DISPAR(0,1)="+#" ;BY="@'.01" + F I=1:1:$L(SORTN,U) S A=$P(SORTN,U,I) Q:'$L(A) S $P(DISPAR(0,I),U,2)=";"_Q_A_": "_Q D + .I A["PATIENT" I (I>1)!($G(SCDHD)["Patients Scheduled for Inactivation from PC Panel") S $P(DISPAR(0,I),U)="@" + .I $G(SCDHD)["FTEE" D + ..I A["PROV" S $P(DISPAR(0,I),U)="@" + ..I I>1 I (A["CLI")!(A["POS") S $P(DISPAR(0,I),U)="@"_$P($G(DISPAR(0,I)),U) + S ZTSAVE("^TMP(""SC"",$J,")="",ZTSAVE("^TMP(""SCSORT"",$J,")="" + Q +FLRPT ;FLAGGED REPORT + D PROMPT^SCMCTSK3("Patients Scheduled for Inactivation from PC Panels","Date Scheduled for Inactivation") + Q:'$D(^TMP("SC",$J,"XR")) + D FLAGG^SCMCTSK3 + S Q="""" + S DIC="^SCPT(404.43,",L=0 + S (SCDHD,DHD)="Patients Scheduled for Inactivation from PC Panels" + D BY + S DIOBEG="D DIOBEG^SCMCTSK4" + S FLDS="[SCMC PENDING UNASSIGN]" + I $G(DISPAR(0,1))["PATIENT" S FLDS="[SCMC PENDING UNASSIGN PAT]" + S DIOEND="D DIOEND^SCMCTSK4" + D EN1^DIP diff --git a/r/SCHEDULING-SD-SC/SCMCTSK3.m b/r/SCHEDULING-SD-SC/SCMCTSK3.m index 4c64aebd..20428f0a 100644 --- a/r/SCHEDULING-SD-SC/SCMCTSK3.m +++ b/r/SCHEDULING-SD-SC/SCMCTSK3.m @@ -1,223 +1,218 @@ -SCMCTSK3 ;ALB/JDS - PCMM Inactivation Reports ; 7/19/05 10:06am ; Compiled June 7, 2007 13:57:55 ; Compiled February 12, 2008 11:46:47 - ;;5.3;Scheduling;**297,499**;AUG 13, 1993;Build 21 - Q -SORTP ;sort template - N DIC - S DIC=200,DIC(0)="ZME" - S DIC("S")="I $D(^SCTM(404.52,""C"",+Y))" - S DIR("A")="Start with Provider",DIR("B")="FIRST",DIR(0)="F" D ^DIR - I X="FIRST" S DIPA("SP")="",DIPA("EI")="zzz",X=1 Q - D ^DIC I Y<0 S DIPA("SP")=X Q:X[U D - .S DIR("A")="Go to Provider",DIR("B")="LAST" S DIR(0)="F" D ^DIR - .I X="LAST" S DIPA("EP")="zzz" - I Y>0 S DIPA("SP")=$P(Y(0),U),DIC(0)="AZQME",DIC("A")="Go to Provider: " - D ^DIC - I Y>0 S DIPA("EP")=$P(Y(0),U) - I Y<0 S DIPA("EP")=X Q:X[U - S X=1 Q - Q -KEY ;Inactivated Report Key - D KEY^SCMCTSK3 Q -SORTYP() ; sort type - W !,"Sort report by" - S DIR(0)="SO^1:TEAM;2:ASSOCIATED CLINIC;" - S DIR("B")=1 - D ^DIR - Q Y -DV(PP) ;return institution sort of patient assignment entry and then IEN of team^ien of position - N A,B,C,T,I,INSTNM,INSTN - S A=$G(^SCPT(404.43,+PP,0)),T=+$P($G(^SCPT(404.42,+A,0)),U,3) I $D(INST(T)) Q INST(T)_U_T_U_$P(A,U,2) - S I=$P($G(^SCTM(404.51,T,0)),U,7) I $O(^TMP("SC",$J,"DIV",0)) I '$D(^TMP("SC",$J,"DIV",I)) Q -1 - S INSTNM=$$GET1^DIQ(4,(+I)_",",.01),INSTN=$$GET1^DIQ(4,(+I)_",",99) - S INST(T)=$S($L(INSTN)=3:INSTN_" ",1:"")_INSTNM Q INST(T)_U_T_U_$P(A,U,2) -EC(PP) ;return enrolled clinics - N I,A - S A="" - F I=0:0 S I=$O(^SCTM(404.57,+$P(ZERO,U,2),5,I)) Q:'I D - .I '$$PTCL^SCRPO2(DFN,U_I,0,DT) Q ;not enrolled - .I $D(CLIN(I)) S A=A_CLIN(I)_U Q - .I $O(^TMP("SC",$J,"CLINIC",0)) I '$D(^(I)) Q - .S CLIN(I)=$P($G(^SC(I,0)),U) I $L(CLIN(I)) S A=A_CLIN(I)_U - Q $S(A="":-1,1:A) -TM(PP) ;Return Team - N I,A,T - S T=+$P($G(^SCPT(404.42,+ZERO,0)),U,3) - I $D(TEAM(T)) Q TEAM(T) - I $O(^TMP("SC",$J,"TEAM",0)) I '$D(^(T)) Q -1 - S TEAM(T)=$P($G(^SCTM(404.51,+T,0)),U) - I '$L(TEAM(T)) K TEAM(T) Q -1 - Q TEAM(T) -IU(DFN) ;is patient inactivity unassigned - N I,A,B,DATA,QUIT - S DATA=-1,QUIT=0 - F I=0:0 S I=$O(^SCPT(404.42,"B",+$G(DFN),I)) Q:'I S A=$G(^SCPT(404.42,I,0)) D Q:QUIT - .F J=0:0 S J=$O(^SCPT(404.43,"B",I,J)) Q:'J S B=$G(^SCPT(404.43,+J,0)) D Q:QUIT - ..I $P(B,U,5),'$P(B,U,4) K A S QUIT=1 Q - ..I $P(B,U,12)="NA" S POS=+J D - ...S A("IU",I)=A - ...S A("IUA")=A - ...S A("IUB")=B - ...I $P(A,U,8),'$P(A,U,9) S A("A")=1 - ;Q:$D(A("A")) DATA - Q:'$D(A("IU")) DATA - ;S DATA="1~"_$P(^SCTM(404.51,+$P(A,U,3),0),U)_"~"_(+$P(A,U,3))_"~"_$P($G(^SCTM(404.57,+$P(B,U,2),0)),U)_"~"_($P(B,U,2))_"~"_POS - S DATA="1~"_$P(^SCTM(404.51,+$P(A("IUA"),U,3),0),U)_"~"_(+$P(A("IUA"),U,3))_"~"_$P($G(^SCTM(404.57,+$P(A("IUB"),U,2),0)),U)_"~"_($P(A("IUB"),U,2))_"~"_POS - Q DATA -PROMPT(SCDESC,DATESORT) ;Prompt for report parameters, queue report - ;Input: LIST=comma delimited string of list subscripts to prompt for - ;Input: SCRTN=report routine entry point - ;Input: SCDESC=tasked job description - ; - K TEAM,CLIN,INST,^TMP("SCSORT",$J) - N SCDIV,SCBDT,SCEDT,SC,SCI,SCX,SCOUT,SCT - D HOME^%ZIS - D ENS^%ZISS - S SC="^TMP(""SC"",$J)" K @SC S SCOUT=0 - D TITL^SCRPW50(SCDESC) - I $L($G(DATESORT)) D G:'$$DTR^SCRPO(.SC,.SCBDT,.SCEDT) END - .D SUBT^SCRPW50(DATESORT) - .S SCBDT("B")="T-30",SCEDT("B")="TODAY" - .I (DATESORT["Scheduled Ina")!(DATESORT["Scheduled for Inactivation") S SCEDT("B")="T+60" - S LIST="DIV,TEAM,POS,ASPR" - ;D SUBT^SCRPW50("**** Date Range Selection ****") - ;S (SCBDT("B"),SCEDT("B"))="TODAY" - ;G:'$$DTR^SCRPO(.SC,.SCBDT,.SCEDT) END - ;D SUBT^SCRPW50("**** Report Parameter Selection ****") - F SCI=1:1:$L(LIST,",") S SCX=$P(LIST,",",SCI) D Q:SCOUT - .S SCOUT='$$LIST^SCRPO(.SC,SCX,1) - .Q - G:SCOUT END - S SORT="DV,TM,TP,PR"_$S(SCDESC["FTEE":",AC",1:",PT") - D SUBT^SCRPW50("**** Output sort order (optional) ****") - G:'$$SORT^SCRPO(.SC,SORT,"") END - S SCT(1)="**** Report Parameters Selected ****" D SUBT^SCRPW50(SCT(1)) - G:'$$PPAR^SCRPO(.SC,1,.SCT) END - S SORTN="" - F SCI=0:0 S SCI=$O(^TMP("SC",$J,"SORT",SCI)) Q:'SCI S SORTN=SORTN_$P(^(SCI),U,2)_U - W:$G(IORESET)'[$C(99) $G(IORESET) - Q -END W:$G(IORESET)'[$C(99) $G(IORESET) K ^TMP("SC",$J) Q -EXTEND ;Sort Extend - K ^TMP("SCSORT",$J) - I '$D(^TMP("SC",$J,"SORT",1)) S ^(1)="DV^INSTITUTION^SCDIV",SORTN="DIVISION" - N SORT S A="" F S A=$O(^TMP("SC",$J,A)) Q:A="" I "XRSORTDTR"'[A I $G(^(A))'="ALL" S SORT($S(A="ASPR":"PR",A="DIV":"DV",A="POS":"TP",1:"TM",A="PATIENT":PT))="" - N I,A,ED,SD - F I=0:0 S I=$O(^SCPT(404.43,"AEXT",I)) Q:'I F J=0:0 S J=$O(^SCPT(404.43,"AEXT",I,J)) Q:'J D - .I '$P($G(^SCPT(404.43,J,0)),U,15) Q - .S SD=$G(^TMP("SC",$J,"DTR","BEGIN")) I SD S ED=$G(^("END")) S:'ED ED=9999999 D INACTDT^SCMCTSK1(J) I (XED) Q - .D SORT(0) - Q -FILEIN(DATA,INFO) ;undo a inactivation - ;INFO entry in PATIENT POSITION ASSIGNMENT file - N ZERO,FLDA S DATA=1 - S ZERO=$G(^SCPT(404.43,+$G(INFO),0)) - ;I $P(ZERO,U,12)'="IU" Q - S FLDA(404.43,(+INFO)_",",.12)="" - S FLDA(404.43,(+INFO)_",",.04)="" - S FLDA(404.43,(+INFO)_",",.15)="" - S FLDA(404.43,(+INFO)_",",.17)=DT - I $D(^SCPT(404.42,+ZERO,0)) S FLDA(404.42,(+ZERO)_",",.15)="",FLDA(404.42,(+ZERO)_",",.09)="" - D FILE^DIE("E","FLDA","ERR") - Q -UNASSIGN ;Sort UNASSIGNMENTS - N END,START - K ^TMP("SCSORT",$J) - S START=$G(^TMP("SC",$J,"DTR","BEGIN"))-.1,END=$G(^("END"))+.9 - I '$D(^TMP("SC",$J,"SORT",1)) S ^(1)="DV^INSTITUTION^SCDIV",SORTN="INSTITUTION" - N I,A,STAT - F STAT="NA","DU" F J=0:0 S J=$O(^SCPT(404.43,"ASTATB",STAT,J)) Q:'J D - .S ZERO=$G(^SCPT(404.43,J,0)) I ($P(ZERO,U,4)END) Q - .D SORT(1) - Q -DFN(A) ;Return patient from Position assigment - Q +$G(^SCPT(404.42,+$G(A),0)) -PA(A) ;return patient name - Q $P($G(^DPT(+$G(DFN),0)),U) -PR(PP) ;Return assigned provider - N A - S A=$$GETPRTP^SCAPMCU2(+$P(ZERO,U,2),DT) - I $O(^TMP("SC",$J,"ASPR",0)) I '$D(^(+A)) Q -1 - S A=$P(A,U,2) - Q $S(A="":-1,1:A) -TP(A) ;return the team position - N TP S TP=+$P($G(ZERO),U,2) - I $O(^TMP("SC",$J,"POS",0)) I '$D(^(TP)) Q -1 - Q $P($G(^SCTM(404.57,+TP,0)),U) -FLAGG ;Sort FLAGGED - K ^TMP("SCSORT",$J) - N I,A,J - I '$D(^TMP("SC",$J,"SORT",1)) S ^(1)="DV^INSTITUTION^SCDIV",SORTN="INSTITUTION",^(2)="TM^TEAM^SCTEAM",^(3)="PR^PROVIDER^SCPROV",^(4)="PA^PATIENT^SCPAT" - N SORT S A="" F S A=$O(^TMP("SC",$J,A)) Q:A="" I "XRSORTDTR"'[A I $G(^(A))'="ALL" S SORT($S(A="ASPR":"PR",A="DIV":"DV",A="POS":"TP",1:"TM",A="PATIENT":PT))="" - S SDT=$G(^TMP("SC",$J,"DTR","BEGIN")),END=$G(^("END"))+.9 - F I=0:0 S I=$O(^SCPT(404.43,"AFLG",I)) Q:'I F J=0:0 S J=$O(^SCPT(404.43,"AFLG",I,J)) Q:'J D - .I SDT>0 S:(END'>9) END=9999999 D INACTDT^SCMCTSK1(J) I (XEND) Q - .D SORT(0) - Q -SORT(INACTIVE) ; - N A,B,C,D,E,QUIT,SCA,K,KCNT,PIECE - S ZERO=$G(^SCPT(404.43,+J,0)) Q:$S('$G(INACTIVE):$P(ZERO,U,4),1:'$P(ZERO,U,4)) - S DFN=$$DFN(+ZERO) - S QUIT=0,KCNT=0 - F K=1:1 Q:'$D(^TMP("SC",$J,"SORT",K)) S A=^(K) K SORT($P(A,U)) S @("A("_K_")=$$"_$P(A,U)_"("_J_")") D I (A(K)=-1)!($P(A(K),U)="") S QUIT=1 Q - .I $P(A,U)="EC",$L(A(K),U)>2 S KCNT=K - Q:QUIT - S A="" F S A=$O(SORT(A)) Q:A="" S @("B=$$"_A_"("_J_")") I B=-1 S QUIT=1 Q - Q:QUIT - F PIECE=1:1:$S(KCNT:$L(A(KCNT),U)-1,1:1) D - .S B="E" K @B - .F K=1:1:$O(A(99),-1) S @B@($P(A(K),U,$S(K=KCNT:PIECE,1:1)))="" S C=$Q(@B) K @B S B=C - .S @B@(J)="" - .M ^TMP("SCSORT",$J)=E - Q -INACT ; - N ALPHA,ZERO - S ALPHA=$G(^SCTM(404.44,1,1)),ALPHA=$P(ALPHA,U,8) I ALPHA
$P(ZERO,U,2) S FLDA(404.52,POSH_",",.091)="" - I $O(FLDA(0)) D FILE^DIE("I","FLDA","ERR") - K ^TMP("SCMCTSK",$J) - Q +SCMCTSK3 ;ALB/JDS - PCMM Inactivation Reports ; 7/19/05 10:06am + ;;5.3;Scheduling;**297**;AUG 13, 1993 + Q +SORTP ;sort template + N DIC + S DIC=200,DIC(0)="ZME" + S DIC("S")="I $D(^SCTM(404.52,""C"",+Y))" + S DIR("A")="Start with Provider",DIR("B")="FIRST",DIR(0)="F" D ^DIR + I X="FIRST" S DIPA("SP")="",DIPA("EI")="zzz",X=1 Q + D ^DIC I Y<0 S DIPA("SP")=X Q:X[U D + .S DIR("A")="Go to Provider",DIR("B")="LAST" S DIR(0)="F" D ^DIR + .I X="LAST" S DIPA("EP")="zzz" + I Y>0 S DIPA("SP")=$P(Y(0),U),DIC(0)="AZQME",DIC("A")="Go to Provider: " + D ^DIC + I Y>0 S DIPA("EP")=$P(Y(0),U) + I Y<0 S DIPA("EP")=X Q:X[U + S X=1 Q + Q +KEY ;Inactivated Report Key + D KEY^SCMCTSK3 Q +SORTYP() ; sort type + W !,"Sort report by" + S DIR(0)="SO^1:TEAM;2:ASSOCIATED CLINIC;" + S DIR("B")=1 + D ^DIR + Q Y +DV(PP) ;return institution sort of patient assignment entry and then IEN of team^ien of position + N A,B,C,T,I,INSTNM,INSTN + S A=$G(^SCPT(404.43,+PP,0)),T=+$P($G(^SCPT(404.42,+A,0)),U,3) I $D(INST(T)) Q INST(T)_U_T_U_$P(A,U,2) + S I=$P($G(^SCTM(404.51,T,0)),U,7) I $O(^TMP("SC",$J,"DIV",0)) I '$D(^TMP("SC",$J,"DIV",I)) Q -1 + S INSTNM=$$GET1^DIQ(4,(+I)_",",.01),INSTN=$$GET1^DIQ(4,(+I)_",",99) + S INST(T)=$S($L(INSTN)=3:INSTN_" ",1:"")_INSTNM Q INST(T)_U_T_U_$P(A,U,2) +EC(PP) ;return enrolled clinics + N I,A + S A="" + F I=0:0 S I=$O(^SCTM(404.57,+$P(ZERO,U,2),5,I)) Q:'I D + .I '$$PTCL^SCRPO2(DFN,U_I,0,DT) Q ;not enrolled + .I $D(CLIN(I)) S A=A_CLIN(I)_U Q + .I $O(^TMP("SC",$J,"CLINIC",0)) I '$D(^(I)) Q + .S CLIN(I)=$P($G(^SC(I,0)),U) I $L(CLIN(I)) S A=A_CLIN(I)_U + Q $S(A="":-1,1:A) +TM(PP) ;Return Team + N I,A,T + S T=+$P($G(^SCPT(404.42,+ZERO,0)),U,3) + I $D(TEAM(T)) Q TEAM(T) + I $O(^TMP("SC",$J,"TEAM",0)) I '$D(^(T)) Q -1 + S TEAM(T)=$P($G(^SCTM(404.51,+T,0)),U) + I '$L(TEAM(T)) K TEAM(T) Q -1 + Q TEAM(T) +IU(DFN) ;is patient inactivity unassigned + N I,A,B,DATA,QUIT + S DATA=-1,QUIT=0 + F I=0:0 S I=$O(^SCPT(404.42,"B",+$G(DFN),I)) Q:'I S A=$G(^SCPT(404.42,I,0)) D Q:QUIT + .F J=0:0 S J=$O(^SCPT(404.43,"B",I,J)) Q:'J S B=$G(^SCPT(404.43,+J,0)) D Q:QUIT + ..I $P(B,U,5),'$P(B,U,4) K A S QUIT=1 Q + ..I $P(B,U,12)="NA" S POS=+J D + ...S A("IU",I)=A + ...S A("IUA")=A + ...S A("IUB")=B + ...I $P(A,U,8),'$P(A,U,9) S A("A")=1 + ;Q:$D(A("A")) DATA + Q:'$D(A("IU")) DATA + ;S DATA="1~"_$P(^SCTM(404.51,+$P(A,U,3),0),U)_"~"_(+$P(A,U,3))_"~"_$P($G(^SCTM(404.57,+$P(B,U,2),0)),U)_"~"_($P(B,U,2))_"~"_POS + S DATA="1~"_$P(^SCTM(404.51,+$P(A("IUA"),U,3),0),U)_"~"_(+$P(A("IUA"),U,3))_"~"_$P($G(^SCTM(404.57,+$P(A("IUB"),U,2),0)),U)_"~"_($P(A("IUB"),U,2))_"~"_POS + Q DATA +PROMPT(SCDESC,DATESORT) ;Prompt for report parameters, queue report + ;Input: LIST=comma delimited string of list subscripts to prompt for + ;Input: SCRTN=report routine entry point + ;Input: SCDESC=tasked job description + ; + K TEAM,CLIN,INST,^TMP("SCSORT",$J) + N SCDIV,SCBDT,SCEDT,SC,SCI,SCX,SCOUT,SCT + D HOME^%ZIS + D ENS^%ZISS + S SC="^TMP(""SC"",$J)" K @SC S SCOUT=0 + D TITL^SCRPW50(SCDESC) + I $L($G(DATESORT)) D G:'$$DTR^SCRPO(.SC,.SCBDT,.SCEDT) END + .D SUBT^SCRPW50(DATESORT) + .S SCBDT("B")="T-30",SCEDT("B")="TODAY" + .I (DATESORT["Scheduled Ina")!(DATESORT["Scheduled for Inactivation") S SCEDT("B")="T+30" + S LIST="DIV,TEAM,POS,ASPR" + ;D SUBT^SCRPW50("**** Date Range Selection ****") + ;S (SCBDT("B"),SCEDT("B"))="TODAY" + ;G:'$$DTR^SCRPO(.SC,.SCBDT,.SCEDT) END + ;D SUBT^SCRPW50("**** Report Parameter Selection ****") + F SCI=1:1:$L(LIST,",") S SCX=$P(LIST,",",SCI) D Q:SCOUT + .S SCOUT='$$LIST^SCRPO(.SC,SCX,1) + .Q + G:SCOUT END + S SORT="DV,TM,TP,PR"_$S(SCDESC["FTEE":",AC",1:",PT") + D SUBT^SCRPW50("**** Output sort order (optional) ****") + G:'$$SORT^SCRPO(.SC,SORT,"") END + S SCT(1)="**** Report Parameters Selected ****" D SUBT^SCRPW50(SCT(1)) + G:'$$PPAR^SCRPO(.SC,1,.SCT) END + S SORTN="" + F SCI=0:0 S SCI=$O(^TMP("SC",$J,"SORT",SCI)) Q:'SCI S SORTN=SORTN_$P(^(SCI),U,2)_U + W:$G(IORESET)'[$C(99) $G(IORESET) + Q +END W:$G(IORESET)'[$C(99) $G(IORESET) K ^TMP("SC",$J) Q +EXTEND ;Sort Extend + K ^TMP("SCSORT",$J) + I '$D(^TMP("SC",$J,"SORT",1)) S ^(1)="DV^INSTITUTION^SCDIV",SORTN="DIVISION" + N SORT S A="" F S A=$O(^TMP("SC",$J,A)) Q:A="" I "XRSORTDTR"'[A I $G(^(A))'="ALL" S SORT($S(A="ASPR":"PR",A="DIV":"DV",A="POS":"TP",1:"TM",A="PATIENT":PT))="" + N I,A,ED,SD + F I=0:0 S I=$O(^SCPT(404.43,"AEXT",I)) Q:'I F J=0:0 S J=$O(^SCPT(404.43,"AEXT",I,J)) Q:'J D + .I '$P($G(^SCPT(404.43,J,0)),U,15) Q + .S SD=$G(^TMP("SC",$J,"DTR","BEGIN")) I SD S ED=$G(^("END")) S:'ED ED=9999999 D INACTDT^SCMCTSK1(J) I (XED) Q + .D SORT(0) + Q +FILEIN(DATA,INFO) ;undo a inactivation + ;INFO entry in PATIENT POSITION ASSIGNMENT file + N ZERO,FLDA S DATA=1 + S ZERO=$G(^SCPT(404.43,+$G(INFO),0)) + ;I $P(ZERO,U,12)'="IU" Q + S FLDA(404.43,(+INFO)_",",.12)="" + S FLDA(404.43,(+INFO)_",",.04)="" + S FLDA(404.43,(+INFO)_",",.15)="" + S FLDA(404.43,(+INFO)_",",.17)=DT + I $D(^SCPT(404.42,+ZERO,0)) S FLDA(404.42,(+ZERO)_",",.15)="",FLDA(404.42,(+ZERO)_",",.09)="" + D FILE^DIE("E","FLDA","ERR") + Q +UNASSIGN ;Sort UNASSIGNMENTS + N END,START + K ^TMP("SCSORT",$J) + S START=$G(^TMP("SC",$J,"DTR","BEGIN"))-.1,END=$G(^("END"))+.9 + I '$D(^TMP("SC",$J,"SORT",1)) S ^(1)="DV^INSTITUTION^SCDIV",SORTN="INSTITUTION" + N I,A,STAT + F STAT="NA","DU" F J=0:0 S J=$O(^SCPT(404.43,"ASTATB",STAT,J)) Q:'J D + .S ZERO=$G(^SCPT(404.43,J,0)) I ($P(ZERO,U,4)END) Q + .D SORT(1) + Q +DFN(A) ;Return patient from Position assigment + Q +$G(^SCPT(404.42,+$G(A),0)) +PA(A) ;return patient name + Q $P($G(^DPT(+$G(DFN),0)),U) +PR(PP) ;Return assigned provider + N A + S A=$$GETPRTP^SCAPMCU2(+$P(ZERO,U,2),DT) + I $O(^TMP("SC",$J,"ASPR",0)) I '$D(^(+A)) Q -1 + S A=$P(A,U,2) + Q $S(A="":-1,1:A) +TP(A) ;return the team position + N TP S TP=+$P($G(ZERO),U,2) + I $O(^TMP("SC",$J,"POS",0)) I '$D(^(TP)) Q -1 + Q $P($G(^SCTM(404.57,+TP,0)),U) +FLAGG ;Sort FLAGGED + K ^TMP("SCSORT",$J) + N I,A,J + I '$D(^TMP("SC",$J,"SORT",1)) S ^(1)="DV^INSTITUTION^SCDIV",SORTN="INSTITUTION",^(2)="TM^TEAM^SCTEAM",^(3)="PR^PROVIDER^SCPROV",^(4)="PA^PATIENT^SCPAT" + N SORT S A="" F S A=$O(^TMP("SC",$J,A)) Q:A="" I "XRSORTDTR"'[A I $G(^(A))'="ALL" S SORT($S(A="ASPR":"PR",A="DIV":"DV",A="POS":"TP",1:"TM",A="PATIENT":PT))="" + S SDT=$G(^TMP("SC",$J,"DTR","BEGIN")),END=$G(^("END"))+.9 + F I=0:0 S I=$O(^SCPT(404.43,"AFLG",I)) Q:'I F J=0:0 S J=$O(^SCPT(404.43,"AFLG",I,J)) Q:'J D + .I SDT>0 S:(END'>9) END=9999999 D INACTDT^SCMCTSK1(J) I (XEND) Q + .D SORT(0) + Q +SORT(INACTIVE) ; + N A,B,C,D,E,QUIT,SCA,K,KCNT,PIECE + S ZERO=$G(^SCPT(404.43,+J,0)) Q:$S('$G(INACTIVE):$P(ZERO,U,4),1:'$P(ZERO,U,4)) + S DFN=$$DFN(+ZERO) + S QUIT=0,KCNT=0 + F K=1:1 Q:'$D(^TMP("SC",$J,"SORT",K)) S A=^(K) K SORT($P(A,U)) S @("A("_K_")=$$"_$P(A,U)_"("_J_")") D I (A(K)=-1)!($P(A(K),U)="") S QUIT=1 Q + .I $P(A,U)="EC",$L(A(K),U)>2 S KCNT=K + Q:QUIT + S A="" F S A=$O(SORT(A)) Q:A="" S @("B=$$"_A_"("_J_")") I B=-1 S QUIT=1 Q + Q:QUIT + F PIECE=1:1:$S(KCNT:$L(A(KCNT),U)-1,1:1) D + .S B="E" K @B + .F K=1:1:$O(A(99),-1) S @B@($P(A(K),U,$S(K=KCNT:PIECE,1:1)))="" S C=$Q(@B) K @B S B=C + .S @B@(J)="" + .M ^TMP("SCSORT",$J)=E + Q +INACT ; + N ALPHA,ZERO + S ALPHA=$G(^SCTM(404.44,1,1)),ALPHA=$P(ALPHA,U,8) I ALPHA
$P(ZERO,U,2) S FLDA(404.52,POSH_",",.091)="" + I $O(FLDA(0)) D FILE^DIE("I","FLDA","ERR") + K ^TMP("SCMCTSK",$J) + Q diff --git a/r/SCHEDULING-SD-SC/SCMCTSK4.m b/r/SCHEDULING-SD-SC/SCMCTSK4.m index 8c1c0914..1da9b15d 100644 --- a/r/SCHEDULING-SD-SC/SCMCTSK4.m +++ b/r/SCHEDULING-SD-SC/SCMCTSK4.m @@ -1,80 +1,80 @@ -SCMCTSK4 ;ALB/JDS - PCMM Inactivation Reports ; 18 Apr 2003 9:36 AM - ;;5.3;Scheduling;**297,526**;AUG 13, 1993;Build 8 - Q -POSCHK ; - N NAME S NAME=$P($G(^SD(403.46,+$P(INFO,U,3),0)),U) - I "RESIDENT (PHYSICIAN)INTERN (PHYSICIAN)"[NAME S $P(DATA,U,3)=1 Q - I "NURSE PRACTITIONERPHYSICIAN ASSISTANT"[NAME S $P(DATA,U,3)=2 Q - I "PHYSICIAN-ATTENDINGPHYSICIAN-PRIMARY CARENURSE PRACTITIONERPHYSICIAN ASSISTANTPHYSICIAN-PSYCHIATRIST"[NAME D Q - .S $P(DATA,U,3)=3 - Q -DIOBEG ; - N PG,DC - N Y,% W @IOF,!,$G(SCDHD) D NOW^%DTC S Y=% W:$X>(IOM-40) ! W ?(IOM-40) - W $P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$E(Y,4,5))_" " W:Y#100 $J(Y#100\1,2)_"," W Y\10000+1700 W:Y#1 " "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12) - W ?(IOM-15),"PAGE: 1" - S Y="",$P(Y,"-",IOM)="" W !,Y,!! - W ?(IOM/2-24),"**** Report Parameters Selected ****",! - S SC="^TMP(""SC"",$J)" - S X=$$PPAR^SCMCTSK8(.SC,.SCT) - S (PG,DC)=1 - F Q:$Y>(IOSL-3) W ! - ;I IOST["C" W !! R SCX:DT I SCX[U S DIOUT=1 - Q -DIOEND ;print key - N Y,% W @IOF,!,$G(SCDHD) D NOW^%DTC S Y=% W:$X>(IOM-40) ! W ?(IOM-40) - W $P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$E(Y,4,5))_" " W:Y#100 $J(Y#100\1,2)_"," W Y\10000+1700 W:Y#1 " "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12) - W ?(IOM-15),"PAGE: "_($G(DC)+1) - S Y="",$P(Y,"-",IOM)="" W !,Y,!! - W !," REPORT KEY" - W !," Field Name Explanation of field name" - W !," Patient Name Name of patient scheduled to be inactivated from their primary care team and position/provider" - W !," SSN Patient SSN." - W !," PC Team Patient's assigned Primary Care team in PCMM." - W !," Provider Name of primary care practitioner/provider currently assigned to the patient. This will be an" - W !," Associate PC Provider if the patient is assigned to an AP, or it will be a Primary Care Provider" - W !," (PCP) if the patient is not assigned to an Associate PC Provider (AP.)" - W !," Team Position The name of the team position to which the current practitioner/provider is assigned." - W !," Institution/Division Institution name, previously called Division, in which patient receives primary care." - W !," Sched Date for Inactiva Date patient will be inactivated from PCMM and their Primary Care team and provider/position" - W !," panels. If the patient has a completed outpatient encounter with their current PCP or an" - W !," assigned AP before this date, the patient will not be inactivated. If the patient's" - W !," inactivation date is extended for 60 days, with the PCMM Extend Patient's Inactivation Date" - W !," option, the patient's inactivation will not occur until the new extended date for inactivation." - W !," Note: There is a patient reassignment option, which allows an inactivated patient to be" - W !," reactivated to their previous Primary Care team and position if they return for care." - W !," Next Appt Date Patient is scheduled for an appointment on this date." - W !," May indicate patient wants to continue their assignment to their Primary Care team and provider." - W !," Clinic for next Appt The clinic in which the patient has their next scheduled appointment." - Q -DIOEND1 ;print Key - N Y,% W @IOF,!,$G(SCDHD) D NOW^%DTC S Y=% W:$X>(IOM-40) ! W ?(IOM-40) - W $P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$E(Y,4,5))_" " W:Y#100 $J(Y#100\1,2)_"," W Y\10000+1700 W:Y#1 " "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12) - W ?(IOM-15),"PAGE: "_($G(DC)+1) - S Y="",$P(Y,"-",IOM)="" W !,Y,!! - W !," REPORT KEY" - W !," Field Name Explanation of field name" - W !," Patient Name Name of patient scheduled to be inactivated from their primary care team and position/provider." - W !," SSN Patient SSN." - W !," Institution Institution name, previously called Division, in which patient receives primary care." - W !," PC Team Patient's assigned Primary Care team in PCMM." - W !," Provider/ Name of Primary Care practitioner/provider currently assigned to the patient." - W !," This may be an Associate PC Provider (AP,) if the patient is assigned to an AP, or" - W !," it may be a Primary Care Provider (PCP) if the patient is not assigned to an" - W !," Associate PC Provider (AP.)" - W !," Team Position The name of the team position to which the current provider is assigned." - W !," Preceptor Name of Preceptor/Primary Care Provider (PCP) if the patient is assigned to an Associate Provider." - W !," If this field is blank then the patient is assigned to a PCP, who displays in the Provider field." - W !," Date Patient Date patient was inactivated from PCMM and their Primary Care team and provider/position." - W !," Inactivated Note: There is a PCMM patient re-assignment option." - W !," Reason Patient Reason for patient's automated unassignment from their Primary Care team and provider/position." - W !," Inactivated No Appt The patient has been assigned to their current Primary Care Provider (PCP) for" - W !," 12 months, and does not have a completed appointment encounter with their PCP or any assigned" - W !," Associated Primary Care Provider (AP) within those 12 months. Therefore, they are considered" - W !," an inactive patient. Alternatively, the patient has been assigned to their current PCP for at" - W !," least 12 months, and does not have a completed appointment encounter with their PCP or any" - W !," assigned Associated Primary Care Provider (AP) in the past 24 months. Therefore, they are" - W !," considered an inactive patient." - W !," Death - Patient's death, a date of death was entered in the Registration Package" - Q -DIOEND2 ;print Key +SCMCTSK4 ;ALB/JDS - PCMM Inactivation Reports ; 18 Apr 2003 9:36 AM + ;;5.3;Scheduling;**297**;AUG 13, 1993 + Q +POSCHK ; + N NAME S NAME=$P($G(^SD(403.46,+$P(INFO,U,3),0)),U) + I "RESIDENT (PHYSICIAN)INTERN (PHYSICIAN)"[NAME S $P(DATA,U,3)=1 Q + I "NURSE PRACTITIONERPHYSICIAN ASSISTANT"[NAME S $P(DATA,U,3)=2 Q + I "PHYSICIAN-ATTENDINGPHYSICIAN-PRIMARY CARENURSE PRACTITIONERPHYSICIAN ASSISTANTPHYSICIAN-PSYCHIATRIST"[NAME D Q + .S $P(DATA,U,3)=3 + Q +DIOBEG ; + N PG,DC + N Y,% W @IOF,!,$G(SCDHD) D NOW^%DTC S Y=% W:$X>(IOM-40) ! W ?(IOM-40) + W $P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$E(Y,4,5))_" " W:Y#100 $J(Y#100\1,2)_"," W Y\10000+1700 W:Y#1 " "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12) + W ?(IOM-15),"PAGE: 1" + S Y="",$P(Y,"-",IOM)="" W !,Y,!! + W ?(IOM/2-24),"**** Report Parameters Selected ****",! + S SC="^TMP(""SC"",$J)" + S X=$$PPAR^SCMCTSK8(.SC,.SCT) + S (PG,DC)=1 + F Q:$Y>(IOSL-3) W ! + ;I IOST["C" W !! R SCX:DT I SCX[U S DIOUT=1 + Q +DIOEND ;print key + N Y,% W @IOF,!,$G(SCDHD) D NOW^%DTC S Y=% W:$X>(IOM-40) ! W ?(IOM-40) + W $P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$E(Y,4,5))_" " W:Y#100 $J(Y#100\1,2)_"," W Y\10000+1700 W:Y#1 " "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12) + W ?(IOM-15),"PAGE: "_($G(DC)+1) + S Y="",$P(Y,"-",IOM)="" W !,Y,!! + W !," REPORT KEY" + W !," Field Name Explanation of field name" + W !," Patient Name Name of patient scheduled to be inactivated from their primary care team and position/provider" + W !," SSN Patient's last 4 Social Security numbers." + W !," PC Team Patient's assigned Primary Care team in PCMM." + W !," Provider Name of primary care practitioner/provider currently assigned to the patient. This will be an" + W !," Associate PC Provider if the patient is assigned to an AP, or it will be a Primary Care Provider" + W !," (PCP) if the patient is not assigned to an Associate PC Provider (AP.)" + W !," Team Position The name of the team position to which the current practitioner/provider is assigned." + W !," Institution/Division Institution name, previously called Division, in which patient receives primary care." + W !," Sched Date for Inactiva Date patient will be inactivated from PCMM and their Primary Care team and provider/position" + W !," panels. If the patient has a completed outpatient encounter with their current PCP or an" + W !," assigned AP before this date, the patient will not be inactivated. If the patient's" + W !," inactivation date is extended for 60 days, with the PCMM Extend Patient's Inactivation Date" + W !," option, the patient's inactivation will not occur until the new extended date for inactivation." + W !," Note: There is a patient reassignment option, which allows an inactivated patient to be" + W !," reactivated to their previous Primary Care team and position if they return for care." + W !," Next Appt Date Patient is scheduled for an appointment on this date." + W !," May indicate patient wants to continue their assignment to their Primary Care team and provider." + W !," Clinic for next Appt The clinic in which the patient has their next scheduled appointment." + Q +DIOEND1 ;print Key + N Y,% W @IOF,!,$G(SCDHD) D NOW^%DTC S Y=% W:$X>(IOM-40) ! W ?(IOM-40) + W $P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$E(Y,4,5))_" " W:Y#100 $J(Y#100\1,2)_"," W Y\10000+1700 W:Y#1 " "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12) + W ?(IOM-15),"PAGE: "_($G(DC)+1) + S Y="",$P(Y,"-",IOM)="" W !,Y,!! + W !," REPORT KEY" + W !," Field Name Explanation of field name" + W !," Patient Name Name of patient scheduled to be inactivated from their primary care team and position/provider." + W !," SSN Patient's last 4 SSN numbers." + W !," Institution Institution name, previously called Division, in which patient receives primary care." + W !," PC Team Patient's assigned Primary Care team in PCMM." + W !," Provider/ Name of Primary Care practitioner/provider currently assigned to the patient." + W !," This may be an Associate PC Provider (AP,) if the patient is assigned to an AP, or" + W !," it may be a Primary Care Provider (PCP) if the patient is not assigned to an" + W !," Associate PC Provider (AP.)" + W !," Team Position The name of the team position to which the current provider is assigned." + W !," Preceptor Name of Preceptor/Primary Care Provider (PCP) if the patient is assigned to an Associate Provider." + W !," If this field is blank then the patient is assigned to a PCP, who displays in the Provider field." + W !," Date Patient Date patient was inactivated from PCMM and their Primary Care team and provider/position." + W !," Inactivated Note: There is a PCMM patient re-assignment option." + W !," Reason Patient Reason for patient's automated unassignment from their Primary Care team and provider/position." + W !," Inactivated No Appt The patient has been assigned to their current Primary Care Provider (PCP) for" + W !," 12 months, and does not have a completed appointment encounter with their PCP or any assigned" + W !," Associated Primary Care Provider (AP) within those 12 months. Therefore, they are considered" + W !," an inactive patient. Alternatively, the patient has been assigned to their current PCP for at" + W !," least 12 months, and does not have a completed appointment encounter with their PCP or any" + W !," assigned Associated Primary Care Provider (AP) in the past 24 months. Therefore, they are" + W !," considered an inactive patient." + W !," Death - Patient's death, a date of death was entered in the Registration Package" + Q +DIOEND2 ;print Key diff --git a/r/SCHEDULING-SD-SC/SCMCTSK9.m b/r/SCHEDULING-SD-SC/SCMCTSK9.m index 806b1d6d..eae9f62b 100644 --- a/r/SCHEDULING-SD-SC/SCMCTSK9.m +++ b/r/SCHEDULING-SD-SC/SCMCTSK9.m @@ -1,100 +1,100 @@ -SCMCTSK9 ;;BP/DMR - PCMM ; 18 Apr 2003 9:36 AM - ;;5.3;Scheduling;**297,526**;AUG 13, 1993;Build 8 - Q -EXTKEY ; - N Y,% W @IOF,!,$G(SCDHD) D NOW^%DTC S Y=% W:$X>(IOM-40) ! W ?(IOM-40) - W $P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$E(Y,4,5))_" " W:Y#100 $J(Y#100\1,2)_"," W Y\10000+1700 W:Y#1 " "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12) - W ?(IOM-15),"PAGE: "_($G(DC)+1) - S Y="",$P(Y,"-",IOM)="" W !,Y,!! - W !,"Column Heading Explanation of column headings" - W ! - W !,"Patient Name Name of patient scheduled to be inactivated from their primary care team and position/provider." - W !,"SSN SSN number." - W !,"Institution Institution name, previously called Division, in which patient receives primary care." - W !,"PC Team The patient's assigned Primary Care team in PCMM." - W !,"Provider/ Name of Associate Primary Care Provider (AP) assigned to patient, if there is one." - W !," Team Position The name of the team position to which the Associate Primary Care Provider (AP) is assigned." - W !,"Current Preceptor/ Name of Primary Care Provider (PCP) assigned to patient. Every Primary Care patient should" - W !," Team Position be assigned to one PCP. The name of the team position to which the Primary Care Provider (PCP)" - W !," is assigned." - W !,"Date Scheduled for Date patient will be inactivated from PCMM and their Primary Care team and provider/position unless" - W !," Inactivation they have a completed outpatient appointment encounter with their current PCP or AP before this date." - W !," Note: There is a patient reassignment option, which allows an inactivated patient to be reactivated" - W !," to their previous Primary Care team and position if they return for care." - W !,"Reason for Extended The reason entered for extending the patient's time before inactivation from PC panels." - W !," Inactivation Entry of this field is in the PCMM GUI, Patient drop down menu, and the Extend Patient's Date for" - W !," Inactivation from PC Panels option." - Q -EXTCHUI ;roll n scroll option to extend a patient - N DA,DIC,DIE,DR,SCTM,SCARRAY,SCHIGH,SCX,V1 - S SCTM=0 F D P1 Q:+SCTM<1 - Q -P1 D GCL S DIC="^SCTM(404.51,",DIC(0)="AEQMZ" D ^DIC S SCTM=+Y Q:+SCTM<1 - W !,"Searching...",! - D EXTEND(.SCARRAY,SCTM) - I $G(^TMP("SCMCTSK9","OUT",$J,1))="" W !,"No Patients to Extend..." D GCL Q - S SCHIGH=$O(^TMP("SCMCTSK9","OUT",$J,9999999),-1) - S SCX=999 F Q:(SCX="^")!(SCX="") D P2 - Q -P2 W !,"Select From: ",!! - S V1=0 F S V1=$O(^TMP("SCMCTSK9","OUT",$J,V1)) Q:'V1 D - . W $J(V1,2)_" ",$P(^TMP("SCMCTSK9","OUT",$J,V1),U,3),! - F W !,"Select 1-",SCHIGH," " R SCX:DTIME Q:(SCX="^")!(SCX="")!((SCX'>SCHIGH)&(SCX>0)) D - . I $E(SCX,1)="?" W !,"Select 1-",SCHIGH," or '^' to exit" Q - . I (+SCX<1)!(+SCX>SCHIGH) W !,"Select a valid number" Q - I SCX'?1.9N Q - S DIE="^SCPT(404.43," - S DA=$P(^TMP("SCMCTSK9","OUT",$J,SCX),U) - S DR=".13//DO NOT EXTEND;S Y=.16 I X=4 S Y=.14;.14;.16////"_DUZ - D ^DIE - Q -EXTEND(DATA,SCTEAM) ;return list of patients to inactivate in next 60 days - ;IEN^POSITION^PATIENT^EXTENDED^REASON - K DATA,SCDATA,SDDATA - N CNT,I,J,K,A,POSA S CNT=1 S SCTEAM=$G(SCTEAM),^TMP("SCMCTSK9","OUT",$J,1)="" - D DT^DICRW S X="T-9M" D ^%DT S STDT=Y - S X="T-21M" D ^%DT S TYDT=+Y ;MAKE THIS 21 - S POSA="" - F S POSA=$O(^SCTM(404.57,"ATMPOS",+SCTEAM,POSA)) Q:POSA="" D - .F POS=0:0 S POS=$O(^SCTM(404.57,"ATMPOS",+SCTEAM,POSA,POS)) Q:'POS D POS -EX1 S A="^TMP(""SCMCTSK9"",$J)",CNT=1 F S A=$Q(@A) Q:A=""!($P(A,",",2)'=$J) D - .S B=@A - .S ^TMP("SCMCTSK9","OUT",$J,CNT)=(+$P(B,U,3))_U_$TR($P($P(A,"(",4),","),$C(34))_U_$TR($P(B,U,2),$C(34))_U_$P($G(^SCPT(404.43,+$P(B,U,3),0)),U,13)_U_$P($G(^SCPT(404.43,+$P(B,U,3),0)),U,14) - .S CNT=CNT+1 - Q -POS I '$$DATES^SCAPMCU1(404.59,POS) Q ;Not an active position - I '$P($G(^SCTM(404.57,POS,0)),U,4) Q ;Not PC - ;get patients for this position - K ^TMP("SC TMP LIST",$J) - S X=$$PTTP^SCAPMC(POS,"",.SCLIST,.SCERR) - S J=0 F S J=$O(@SCLIST@(J)) Q:'J S SCDATA=^(J) D - .N J I $P(SCDATA,U,4)>STDT Q - .I '$P($G(^SCPT(404.43,+$P(SCDATA,U,3),0)),U,5) Q - .I '$P($G(^SCPT(404.43,+$P(SCDATA,U,3),0)),U,15) Q - .S DFN=+SCDATA - .D SEEN Q:SEEN - .S ^TMP("SCMCTSK9",$J,$P($G(^SCTM(404.57,POS,0)),U),$P(SCDATA,U,2),+SCDATA)=SCDATA,CNT=CNT+1 - K @SCLIST - Q -SEEN ;was patient seen - S SEEN=0 - N SCPRO,I,PRECP,PRO - N X,SCPRDTS,SCPR - ;get list of providers for this position - S PROV=+$$GETPRTP^SCAPMCU2(POS,DT) S SCPRO(+PROV)="" - S SCPRDTS("BEGIN")=TYDT - S SCPRDTS("END")=DT - S X=$$PRTP^SCAPMC(POS,"SCPRDTS","SCPR") - F I=0:0 S I=$O(SCPR(I)) Q:'I S SCPRO(+SCPR(I))="" - S PRECP=0 I $G(PREC),$G(PREC)'=POS S PRECP=+$$GETPRTP^SCAPMCU2(PREC,DT),SCPRO(+PRECP)="" - F I=TYDT:0 S I=$O(^SCE("ADFN",DFN,I)) Q:'I D Q:SEEN - .F J=0:0 S J=$O(^SCE("ADFN",DFN,I,J)) Q:'J D Q:SEEN - ..N VISIT S VISIT=+$P($G(^SCE(J,0)),U,5) I $G(^SCE(J,0))<$G(TYDT) Q - ..F PRO=0:0 S PRO=$O(SCPRO(PRO)) Q:'PRO D Q:SEEN - ...I $D(^SDD(409.44,"AO",J,$G(PRO))) S SEEN=1 Q ;GET THE PROVIDERJ - ...N V F V=0:0 S V=$O(^AUPNVPRV("AD",VISIT,V)) Q:'V I PRO=(+$G(^AUPNVPRV(V,0))) S SEEN=1 Q - Q -GCL ;clean temp globals - K ^TMP("SCMCTSK9",$J) - K ^TMP("SCMCTSK9","OUT",$J) - Q +SCMCTSK9 ;;BP/DMR - PCMM ; 18 Apr 2003 9:36 AM + ;;5.3;Scheduling;**297**;AUG 13, 1993 + Q +EXTKEY ; + N Y,% W @IOF,!,$G(SCDHD) D NOW^%DTC S Y=% W:$X>(IOM-40) ! W ?(IOM-40) + W $P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$E(Y,4,5))_" " W:Y#100 $J(Y#100\1,2)_"," W Y\10000+1700 W:Y#1 " "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12) + W ?(IOM-15),"PAGE: "_($G(DC)+1) + S Y="",$P(Y,"-",IOM)="" W !,Y,!! + W !,"Column Heading Explanation of column headings" + W ! + W !,"Patient Name Name of patient scheduled to be inactivated from their primary care team and position/provider." + W !,"SSN Patient's last 4 SSN numbers." + W !,"Institution Institution name, previously called Division, in which patient receives primary care." + W !,"PC Team The patient's assigned Primary Care team in PCMM." + W !,"Provider/ Name of Associate Primary Care Provider (AP) assigned to patient, if there is one." + W !," Team Position The name of the team position to which the Associate Primary Care Provider (AP) is assigned." + W !,"Current Preceptor/ Name of Primary Care Provider (PCP) assigned to patient. Every Primary Care patient should" + W !," Team Position be assigned to one PCP. The name of the team position to which the Primary Care Provider (PCP)" + W !," is assigned." + W !,"Date Scheduled for Date patient will be inactivated from PCMM and their Primary Care team and provider/position unless" + W !," Inactivation they have a completed outpatient appointment encounter with their current PCP or AP before this date." + W !," Note: There is a patient reassignment option, which allows an inactivated patient to be reactivated" + W !," to their previous Primary Care team and position if they return for care." + W !,"Reason for Extended The reason entered for extending the patient's time before inactivation from PC panels." + W !," Inactivation Entry of this field is in the PCMM GUI, Patient drop down menu, and the Extend Patient's Date for" + W !," Inactivation from PC Panels option." + Q +EXTCHUI ;roll n scroll option to extend a patient + N DA,DIC,DIE,DR,SCTM,SCARRAY,SCHIGH,SCX,V1 + S SCTM=0 F D P1 Q:+SCTM<1 + Q +P1 D GCL S DIC="^SCTM(404.51,",DIC(0)="AEQMZ" D ^DIC S SCTM=+Y Q:+SCTM<1 + W !,"Searching...",! + D EXTEND(.SCARRAY,SCTM) + I $G(^TMP("SCMCTSK9","OUT",$J,1))="" W !,"No Patients to Extend..." D GCL Q + S SCHIGH=$O(^TMP("SCMCTSK9","OUT",$J,9999999),-1) + S SCX=999 F Q:(SCX="^")!(SCX="") D P2 + Q +P2 W !,"Select From: ",!! + S V1=0 F S V1=$O(^TMP("SCMCTSK9","OUT",$J,V1)) Q:'V1 D + . W $J(V1,2)_" ",$P(^TMP("SCMCTSK9","OUT",$J,V1),U,3),! + F W !,"Select 1-",SCHIGH," " R SCX:DTIME Q:(SCX="^")!(SCX="")!((SCX'>SCHIGH)&(SCX>0)) D + . I $E(SCX,1)="?" W !,"Select 1-",SCHIGH," or '^' to exit" Q + . I (+SCX<1)!(+SCX>SCHIGH) W !,"Select a valid number" Q + I SCX'?1.9N Q + S DIE="^SCPT(404.43," + S DA=$P(^TMP("SCMCTSK9","OUT",$J,SCX),U) + S DR=".13//DO NOT EXTEND;S Y=.16 I X=4 S Y=.14;.14;.16////"_DUZ + D ^DIE + Q +EXTEND(DATA,SCTEAM) ;return list of patients to inactivate in next 60 days + ;IEN^POSITION^PATIENT^EXTENDED^REASON + K DATA,SCDATA,SDDATA + N CNT,I,J,K,A,POSA S CNT=1 S SCTEAM=$G(SCTEAM),^TMP("SCMCTSK9","OUT",$J,1)="" + D DT^DICRW S X="T-9M" D ^%DT S STDT=Y + S X="T-21M" D ^%DT S TYDT=+Y ;MAKE THIS 21 + S POSA="" + F S POSA=$O(^SCTM(404.57,"ATMPOS",+SCTEAM,POSA)) Q:POSA="" D + .F POS=0:0 S POS=$O(^SCTM(404.57,"ATMPOS",+SCTEAM,POSA,POS)) Q:'POS D POS +EX1 S A="^TMP(""SCMCTSK9"",$J)",CNT=1 F S A=$Q(@A) Q:A=""!($P(A,",",2)'=$J) D + .S B=@A + .S ^TMP("SCMCTSK9","OUT",$J,CNT)=(+$P(B,U,3))_U_$TR($P($P(A,"(",4),","),$C(34))_U_$TR($P(B,U,2),$C(34))_U_$P($G(^SCPT(404.43,+$P(B,U,3),0)),U,13)_U_$P($G(^SCPT(404.43,+$P(B,U,3),0)),U,14) + .S CNT=CNT+1 + Q +POS I '$$DATES^SCAPMCU1(404.59,POS) Q ;Not an active position + I '$P($G(^SCTM(404.57,POS,0)),U,4) Q ;Not PC + ;get patients for this position + K ^TMP("SC TMP LIST",$J) + S X=$$PTTP^SCAPMC(POS,"",.SCLIST,.SCERR) + S J=0 F S J=$O(@SCLIST@(J)) Q:'J S SCDATA=^(J) D + .N J I $P(SCDATA,U,4)>STDT Q + .I '$P($G(^SCPT(404.43,+$P(SCDATA,U,3),0)),U,5) Q + .I '$P($G(^SCPT(404.43,+$P(SCDATA,U,3),0)),U,15) Q + .S DFN=+SCDATA + .D SEEN Q:SEEN + .S ^TMP("SCMCTSK9",$J,$P($G(^SCTM(404.57,POS,0)),U),$P(SCDATA,U,2),+SCDATA)=SCDATA,CNT=CNT+1 + K @SCLIST + Q +SEEN ;was patient seen + S SEEN=0 + N SCPRO,I,PRECP,PRO + N X,SCPRDTS,SCPR + ;get list of providers for this position + S PROV=+$$GETPRTP^SCAPMCU2(POS,DT) S SCPRO(+PROV)="" + S SCPRDTS("BEGIN")=TYDT + S SCPRDTS("END")=DT + S X=$$PRTP^SCAPMC(POS,"SCPRDTS","SCPR") + F I=0:0 S I=$O(SCPR(I)) Q:'I S SCPRO(+SCPR(I))="" + S PRECP=0 I $G(PREC),$G(PREC)'=POS S PRECP=+$$GETPRTP^SCAPMCU2(PREC,DT),SCPRO(+PRECP)="" + F I=TYDT:0 S I=$O(^SCE("ADFN",DFN,I)) Q:'I D Q:SEEN + .F J=0:0 S J=$O(^SCE("ADFN",DFN,I,J)) Q:'J D Q:SEEN + ..N VISIT S VISIT=+$P($G(^SCE(J,0)),U,5) I $G(^SCE(J,0))<$G(TYDT) Q + ..F PRO=0:0 S PRO=$O(SCPRO(PRO)) Q:'PRO D Q:SEEN + ...I $D(^SDD(409.44,"AO",J,$G(PRO))) S SEEN=1 Q ;GET THE PROVIDERJ + ...N V F V=0:0 S V=$O(^AUPNVPRV("AD",VISIT,V)) Q:'V I PRO=(+$G(^AUPNVPRV(V,0))) S SEEN=1 Q + Q +GCL ;clean temp globals + K ^TMP("SCMCTSK9",$J) + K ^TMP("SCMCTSK9","OUT",$J) + Q diff --git a/r/SCHEDULING-SD-SC/SCMSVUT2.m b/r/SCHEDULING-SD-SC/SCMSVUT2.m index 9c05cc67..07207456 100644 --- a/r/SCHEDULING-SD-SC/SCMSVUT2.m +++ b/r/SCHEDULING-SD-SC/SCMSVUT2.m @@ -1,240 +1,240 @@ -SCMSVUT2 ;ALB/JLU;Utility routine for AMBCARE;06/28/99 - ;;5.3;Scheduling;**66,180,254,293,325,466,521**;AUG 13,1993;Build 1 - ;06/28/99 ACS Added CPT modifier validation - ; -COUNT(VALER) ;counts the number of errored encounters found. - ;INPUT VALER - The array containing the errors. - ;OUTPUT the number of errors - ; - N VAR,CNT - S VAR="",CNT=0 - F S VAR=$O(@VALER@(VAR)) Q:VAR']"" S CNT=CNT+1 - Q CNT - ; -IPERR(VALER) ;counts the number of inpatient errored encounters found. - ;INPUT VALER - The array containing the errors. - ;OUTPUT the number of errors - ; - N VAR,CNT - S VAR="",CNT=0 - F S VAR=$O(@VALER@(VAR)) Q:VAR']"" D - .I $$INPATENC^SCDXUTL(VAR) S CNT=CNT+1 - Q CNT - ; -FILEVERR(PTR,VALERR) ;files the errors found for an encounter - ;INPUT PTR - The pointer to the entry in the transmission file 409.73 - ; VALERR - The array holding the errors for the encounter. - ;OUTPUT 0 - did not file - ; 1 - did file - N SEG,FILE - I '$D(VALERR) Q 0 - S SEG="",FILE=-1 - F S SEG=$O(@VALERR@(SEG)) Q:SEG']"" D FILE(VALERR,SEG,PTR,.FILE) - Q $S(FILE=1:1,1:0) - ; -FILE(VALERR,SEG,PTR,FILE) ; - N NBR - S NBR=0 - F S NBR=$O(@VALERR@(SEG,NBR)) Q:'NBR DO - .N CODPTR,CODE - .S CODE=$G(@VALERR@(SEG,NBR)) - .I CODE']"" Q - .S CODPTR=$O(^SD(409.76,"B",CODE,"")) - .I 'CODPTR Q - .I $D(^SD(409.75,"AER",PTR,CODPTR)) S FILE=1 Q - .S FILE=$$CRTERR^SCDXFU02(PTR,CODE) - .Q - Q - ; -VALWL(CLIN) ;WORKLOAD VALIDATION AT CHECK OUT - ;INPUT CLIN - IEN OF CLINIC - ;OUTPUT 0 - DO NOT VALIDATE WORKLOAD - ; 1 - VALIDATE CLINIC WORKLOAD - N A1 - I '$D(CLIN) S CLIN=0 - S A1=$P($G(^SC(+CLIN,0)),U,30) - Q $S(A1=1:1,1:0) - ; -VALIDATE(XMITPTR) ;validates data that has a entry in the transmit file. - ; - ;INPUT XMITPTR - This is the point to an entry in file 409.73. - ; - ;OUTPUT -1 - the was a problem with the inputs - ; 0 - no errors were found - ; 1 - errors were found - ; - N VALERR,ERR,HL,HLEID,DFN - S ANS=-1 - S XMITPTR=+$G(XMITPTR) - I $G(^SD(409.73,XMITPTR,0))']"" G VALQ - D PATDFN^SCDXUTL2(XMITPTR) - ; - S HL7XMIT="^TMP(""HLS"","_$J_")",VALERR="^TMP(""SCDXVALID"","_$J_","_XMITPTR_")" - ;Initialze HL7 variables - S HLEID=+$O(^ORD(101,"B","SCDX AMBCARE SEND SERVER FOR ADT-Z00",0)) - I ('HLEID) G VALQ - D INIT^HLFNC2(HLEID,.HL) - I ($O(HL(""))="") G VALQ - ; - S ERR=$$BUILDHL7^SCDXMSG0(XMITPTR,.HL,1,HL7XMIT,1,VALERR) - ; - I ERR<0,$O(@VALERR@(0))']"" D VALIDATE^SCMSVUT0("INTERNAL","","V900",VALERR,0) - S ANS=0 - D DELAERR^SCDXFU02(XMITPTR,0) - D DEMUPDT(DFN,VALERR,"DEMO") - I $O(@VALERR@(0))]"" DO - .N FILE - .S ANS=1 - .S FILE=$$FILEVERR(XMITPTR,VALERR) - .Q - ; - K @VALERR,@HL7XMIT - ; -VALQ Q ANS - ; -DEMUPDT(DFN,VALERR,TYP) ; - ;This entry point updates all the other encoutners for this patient - ;that HAVE errors with a new set or demographic errors or deletes all - ;the demographic errors if none were found. - ;INPUT DFN - The patient's DFN - ; VALERR - errors to log - ; TYP - The type of errors to delete and log. - ; Right now demographic errors are the only kind "DEMO" - ; - S DFN=$G(DFN),TYP=$G(TYP),VALERR=$G(VALERR) - I DFN=""!(TYP="")!(VALERR="") Q - N PTRS,RNG,LP,PTR - S RNG=$P($T(@(TYP)),";;",2),PTRS="" - D CLEAN(DFN,RNG,.PTRS) - I '$D(@VALERR@("PID")) Q - I PTRS']"" Q - F LP=1:1 S PTR=$P(PTRS,U,LP) Q:PTR']"" DO - .I '$D(^SD(409.73,PTR,0)) Q - .N FILE - .D FILE(VALERR,"PID",PTR,.FILE) - .Q - Q - ; -CLEAN(DFN,RNG,PTRS) ;This subroutine cleans out all errors for a pateint - ;and returns a string of which entries in 409.73 were cleaned of errors - ; - N LP,COD,LP2,IEN - F LP=1:1 S COD=$P(RNG,U,LP) Q:COD']"" I $D(^SD(409.75,"ACOD",DFN,COD)) S IEN="" F LP2=1:1 S IEN=$O(^SD(409.75,"ACOD",DFN,COD,IEN)) Q:IEN']"" DO - .N VAR,RES - .S VAR=$P($G(^SD(409.75,IEN,0)),U,1)_"^" - .I $P(VAR,U,1)="" S PTR="" Q - .S RES=$$DELERR^SCDXFU02(IEN) - .I PTRS[VAR Q - .S PTRS=PTRS_VAR - .Q - Q - ; -MODCODE(DATA,ENCDT) ; - ; - ;--------------------------------------------------------------- - ; VALIDATE MODIFIER AND CPT+MODIFIER COMBINATION - ; - ; INPUT: DATA - The procedure and modifier code to be checked - ; format: CPT~modifier - ; ENCDT - The date of the encounter - ; - ;OUTPUT: 1 - valid modifier and CPT+modifier combination - ; 0 - invalid modifier or CPT+modifier combination - ; - ;**NOTE** This call makes the assumption that leading zeros are - ; intact in the input. - ;--------------------------------------------------------------- - ; - ;- validate modifier only - N DATAMOD - S DATAMOD=$P(DATA,"~",2) - I '$D(DATAMOD) Q 0 - I $$MOD^ICPTMOD(DATAMOD,"E",ENCDT,1)'>0 Q 0 - ; - ;- validate CPT+modifier pair - N DATAPROC - S DATAPROC=$P(DATA,"~",1) - I '$D(DATAPROC) Q 0 - I $$MODP^ICPTMOD(DATAPROC,DATAMOD,"E",ENCDT,1)'>0 Q 0 - Q 1 - ; -MODMETH(DATA) ; - ; - ;--------------------------------------------------------------- - ; VALIDATE MODIFIER CODING METHOD - ; - ; INPUT: DATA - The modifier coding method to be checked - ; - ;OUTPUT: 1 - valid modifier coding method - ; 0 - invalid modifier coding method - ; - ; Valid modifier coding methods: C and H - ;--------------------------------------------------------------- - ; - I '$D(DATA) Q 0 - S DATA=","_DATA_"," - I ",C,H,"'[DATA Q 0 - Q 1 - ; -ETHNIC(DATA) ; - ;INPUT DATA - the ethnicity code to be validated (NNNN-C-XXX) - ; - N VAL,MTHD - I '$D(DATA) Q 0 - I DATA="" Q 1 - S VAL=$P(DATA,"-",1,2) - S MTHD=$P(DATA,"-",3) - I VAL'?4N1"-"1N Q 0 - I ",SLF,UNK,PRX,OBS,"'[MTHD Q 0 - Q 1 -CONFDT(DATA,SUB) ;CONFIDENTIAL ADDRESS START/STOP DATE - N X,Y,%DT,DTOUT,STDT,ENDT - I '$D(DATA) Q 0 - S STDT=$P(DATA,SUB,1) - S ENDT=$P(DATA,SUB,2) - I STDT="" Q 0 - S STDT=$$FMDATE^HLFNC(STDT) - S X=STDT,%DT="X" D ^%DT I Y=-1 Q 0 ;SD/521 added %DT - I ENDT="" Q 1 - S ENDT=$$FMDATE^HLFNC(ENDT) - S X=ENDT,%DT="X" D ^%DT I Y=-1 Q 0 ;SD/521 added %DT - I $$FMDIFF^XLFDT(ENDT,STDT,1)<0 Q 0 - Q 1 - ; -CONFCAT(DATA) ;CONFIDENTIAL ADDRESS CATEGORY TYPE - I '$D(DATA) Q 0 - I DATA="" Q 0 - N VAL,GOOD - S GOOD=0 - F VAL="VACAA","VACAC","VACAE","VACAM","VACAO" I DATA=VAL S GOOD=1 Q - Q GOOD - ; -CVEDT(DATA) ;Combat vet end date (ZEL.38) - ;Input : DATA - CombatVetIndicator ^ CombatVetEndDate - ;Output : 1 = Good / 0 = Bad - ; - N CVI,CVEDT - S DATA=$G(DATA) - S CVI=$P(DATA,"^",1) - S CVEDT=$P(DATA,"^",2) - I 'CVI Q $S(CVEDT="":1,1:0) - Q CVEDT?8N - ; -CLCV(DATA,SDOE) ;Cross check for combat vet classification question - ;Input : DATA - Answer to classification question - ; SDOE - Pointer to encounter (file # 409.68) - ;Output : 1 = Good / 0 = Bad - ; - S DATA=$G(DATA) - Q:(DATA'=1) 1 - N VET,SDDT,SDOE0 - S SDOE=$G(SDOE) Q:'SDOE 0 - S SDOE0=$G(^SCE(SDOE,0)) - S SDDT=+SDOE0 Q:'SDDT 0 - S DFN=+$P(SDOE0,"^",2) Q:'DFN 0 - S VET=$P($$EL^SDCO22(DFN,SDOE),"^",5) - I VET'="Y" Q 0 - S VET=+$$CVEDT^DGCV(DFN,SDDT) - Q $S(VET=1:1,1:0) - ; -DEMO ;;2000^2030^2050^2100^2150^2200^2210^2220^2230^2240^2250^2300^2330^2360 +SCMSVUT2 ;ALB/JLU;Utility routine for AMBCARE;06/28/99 + ;;5.3;Scheduling;**66,180,254,293,325,466**;AUG 13,1993;Build 2 + ;06/28/99 ACS Added CPT modifier validation + ; +COUNT(VALER) ;counts the number of errored encounters found. + ;INPUT VALER - The array containing the errors. + ;OUTPUT the number of errors + ; + N VAR,CNT + S VAR="",CNT=0 + F S VAR=$O(@VALER@(VAR)) Q:VAR']"" S CNT=CNT+1 + Q CNT + ; +IPERR(VALER) ;counts the number of inpatient errored encounters found. + ;INPUT VALER - The array containing the errors. + ;OUTPUT the number of errors + ; + N VAR,CNT + S VAR="",CNT=0 + F S VAR=$O(@VALER@(VAR)) Q:VAR']"" D + .I $$INPATENC^SCDXUTL(VAR) S CNT=CNT+1 + Q CNT + ; +FILEVERR(PTR,VALERR) ;files the errors found for an encounter + ;INPUT PTR - The pointer to the entry in the transmission file 409.73 + ; VALERR - The array holding the errors for the encounter. + ;OUTPUT 0 - did not file + ; 1 - did file + N SEG,FILE + I '$D(VALERR) Q 0 + S SEG="",FILE=-1 + F S SEG=$O(@VALERR@(SEG)) Q:SEG']"" D FILE(VALERR,SEG,PTR,.FILE) + Q $S(FILE=1:1,1:0) + ; +FILE(VALERR,SEG,PTR,FILE) ; + N NBR + S NBR=0 + F S NBR=$O(@VALERR@(SEG,NBR)) Q:'NBR DO + .N CODPTR,CODE + .S CODE=$G(@VALERR@(SEG,NBR)) + .I CODE']"" Q + .S CODPTR=$O(^SD(409.76,"B",CODE,"")) + .I 'CODPTR Q + .I $D(^SD(409.75,"AER",PTR,CODPTR)) S FILE=1 Q + .S FILE=$$CRTERR^SCDXFU02(PTR,CODE) + .Q + Q + ; +VALWL(CLIN) ;WORKLOAD VALIDATION AT CHECK OUT + ;INPUT CLIN - IEN OF CLINIC + ;OUTPUT 0 - DO NOT VALIDATE WORKLOAD + ; 1 - VALIDATE CLINIC WORKLOAD + N A1 + I '$D(CLIN) S CLIN=0 + S A1=$P($G(^SC(+CLIN,0)),U,30) + Q $S(A1=1:1,1:0) + ; +VALIDATE(XMITPTR) ;validates data that has a entry in the transmit file. + ; + ;INPUT XMITPTR - This is the point to an entry in file 409.73. + ; + ;OUTPUT -1 - the was a problem with the inputs + ; 0 - no errors were found + ; 1 - errors were found + ; + N VALERR,ERR,HL,HLEID,DFN + S ANS=-1 + S XMITPTR=+$G(XMITPTR) + I $G(^SD(409.73,XMITPTR,0))']"" G VALQ + D PATDFN^SCDXUTL2(XMITPTR) + ; + S HL7XMIT="^TMP(""HLS"","_$J_")",VALERR="^TMP(""SCDXVALID"","_$J_","_XMITPTR_")" + ;Initialze HL7 variables + S HLEID=+$O(^ORD(101,"B","SCDX AMBCARE SEND SERVER FOR ADT-Z00",0)) + I ('HLEID) G VALQ + D INIT^HLFNC2(HLEID,.HL) + I ($O(HL(""))="") G VALQ + ; + S ERR=$$BUILDHL7^SCDXMSG0(XMITPTR,.HL,1,HL7XMIT,1,VALERR) + ; + I ERR<0,$O(@VALERR@(0))']"" D VALIDATE^SCMSVUT0("INTERNAL","","V900",VALERR,0) + S ANS=0 + D DELAERR^SCDXFU02(XMITPTR,0) + D DEMUPDT(DFN,VALERR,"DEMO") + I $O(@VALERR@(0))]"" DO + .N FILE + .S ANS=1 + .S FILE=$$FILEVERR(XMITPTR,VALERR) + .Q + ; + K @VALERR,@HL7XMIT + ; +VALQ Q ANS + ; +DEMUPDT(DFN,VALERR,TYP) ; + ;This entry point updates all the other encoutners for this patient + ;that HAVE errors with a new set or demographic errors or deletes all + ;the demographic errors if none were found. + ;INPUT DFN - The patient's DFN + ; VALERR - errors to log + ; TYP - The type of errors to delete and log. + ; Right now demographic errors are the only kind "DEMO" + ; + S DFN=$G(DFN),TYP=$G(TYP),VALERR=$G(VALERR) + I DFN=""!(TYP="")!(VALERR="") Q + N PTRS,RNG,LP,PTR + S RNG=$P($T(@(TYP)),";;",2),PTRS="" + D CLEAN(DFN,RNG,.PTRS) + I '$D(@VALERR@("PID")) Q + I PTRS']"" Q + F LP=1:1 S PTR=$P(PTRS,U,LP) Q:PTR']"" DO + .I '$D(^SD(409.73,PTR,0)) Q + .N FILE + .D FILE(VALERR,"PID",PTR,.FILE) + .Q + Q + ; +CLEAN(DFN,RNG,PTRS) ;This subroutine cleans out all errors for a pateint + ;and returns a string of which entries in 409.73 were cleaned of errors + ; + N LP,COD,LP2,IEN + F LP=1:1 S COD=$P(RNG,U,LP) Q:COD']"" I $D(^SD(409.75,"ACOD",DFN,COD)) S IEN="" F LP2=1:1 S IEN=$O(^SD(409.75,"ACOD",DFN,COD,IEN)) Q:IEN']"" DO + .N VAR,RES + .S VAR=$P($G(^SD(409.75,IEN,0)),U,1)_"^" + .I $P(VAR,U,1)="" S PTR="" Q + .S RES=$$DELERR^SCDXFU02(IEN) + .I PTRS[VAR Q + .S PTRS=PTRS_VAR + .Q + Q + ; +MODCODE(DATA,ENCDT) ; + ; + ;--------------------------------------------------------------- + ; VALIDATE MODIFIER AND CPT+MODIFIER COMBINATION + ; + ; INPUT: DATA - The procedure and modifier code to be checked + ; format: CPT~modifier + ; ENCDT - The date of the encounter + ; + ;OUTPUT: 1 - valid modifier and CPT+modifier combination + ; 0 - invalid modifier or CPT+modifier combination + ; + ;**NOTE** This call makes the assumption that leading zeros are + ; intact in the input. + ;--------------------------------------------------------------- + ; + ;- validate modifier only + N DATAMOD + S DATAMOD=$P(DATA,"~",2) + I '$D(DATAMOD) Q 0 + I $$MOD^ICPTMOD(DATAMOD,"E",ENCDT,1)'>0 Q 0 + ; + ;- validate CPT+modifier pair + N DATAPROC + S DATAPROC=$P(DATA,"~",1) + I '$D(DATAPROC) Q 0 + I $$MODP^ICPTMOD(DATAPROC,DATAMOD,"E",ENCDT,1)'>0 Q 0 + Q 1 + ; +MODMETH(DATA) ; + ; + ;--------------------------------------------------------------- + ; VALIDATE MODIFIER CODING METHOD + ; + ; INPUT: DATA - The modifier coding method to be checked + ; + ;OUTPUT: 1 - valid modifier coding method + ; 0 - invalid modifier coding method + ; + ; Valid modifier coding methods: C and H + ;--------------------------------------------------------------- + ; + I '$D(DATA) Q 0 + S DATA=","_DATA_"," + I ",C,H,"'[DATA Q 0 + Q 1 + ; +ETHNIC(DATA) ; + ;INPUT DATA - the ethnicity code to be validated (NNNN-C-XXX) + ; + N VAL,MTHD + I '$D(DATA) Q 0 + I DATA="" Q 1 + S VAL=$P(DATA,"-",1,2) + S MTHD=$P(DATA,"-",3) + I VAL'?4N1"-"1N Q 0 + I ",SLF,UNK,PRX,OBS,"'[MTHD Q 0 + Q 1 +CONFDT(DATA,SUB) ;CONFIDENTIAL ADDRESS START/STOP DATE + N X,Y,%DT,DTOUT,STDT,ENDT + I '$D(DATA) Q 0 + S STDT=$P(DATA,SUB,1) + S ENDT=$P(DATA,SUB,2) + I STDT="" Q 0 + S STDT=$$FMDATE^HLFNC(STDT) + S X=STDT D ^%DT I Y=-1 Q 0 + I ENDT="" Q 1 + S ENDT=$$FMDATE^HLFNC(ENDT) + S X=ENDT D ^%DT I Y=-1 Q 0 + I $$FMDIFF^XLFDT(ENDT,STDT,1)<0 Q 0 + Q 1 + ; +CONFCAT(DATA) ;CONFIDENTIAL ADDRESS CATEGORY TYPE + I '$D(DATA) Q 0 + I DATA="" Q 0 + N VAL,GOOD + S GOOD=0 + F VAL="VACAA","VACAC","VACAE","VACAM","VACAO" I DATA=VAL S GOOD=1 Q + Q GOOD + ; +CVEDT(DATA) ;Combat vet end date (ZEL.38) + ;Input : DATA - CombatVetIndicator ^ CombatVetEndDate + ;Output : 1 = Good / 0 = Bad + ; + N CVI,CVEDT + S DATA=$G(DATA) + S CVI=$P(DATA,"^",1) + S CVEDT=$P(DATA,"^",2) + I 'CVI Q $S(CVEDT="":1,1:0) + Q CVEDT?8N + ; +CLCV(DATA,SDOE) ;Cross check for combat vet classification question + ;Input : DATA - Answer to classification question + ; SDOE - Pointer to encounter (file # 409.68) + ;Output : 1 = Good / 0 = Bad + ; + S DATA=$G(DATA) + Q:(DATA'=1) 1 + N VET,SDDT,SDOE0 + S SDOE=$G(SDOE) Q:'SDOE 0 + S SDOE0=$G(^SCE(SDOE,0)) + S SDDT=+SDOE0 Q:'SDDT 0 + S DFN=+$P(SDOE0,"^",2) Q:'DFN 0 + S VET=$P($$EL^SDCO22(DFN,SDOE),"^",5) + I VET'="Y" Q 0 + S VET=+$$CVEDT^DGCV(DFN,SDDT) + Q $S(VET=1:1,1:0) + ; +DEMO ;;2000^2030^2050^2100^2150^2200^2210^2220^2230^2240^2250^2300^2330^2360 diff --git a/r/SCHEDULING-SD-SC/SCRPBK11.m b/r/SCHEDULING-SD-SC/SCRPBK11.m index 2100808a..366a82fc 100644 --- a/r/SCHEDULING-SD-SC/SCRPBK11.m +++ b/r/SCHEDULING-SD-SC/SCRPBK11.m @@ -1,97 +1,97 @@ -SCRPBK11 ;MJK/ALB - RPC Broker Utilities ; 27 FEB 96 - ;;5.3;Scheduling;**41,520**;AUG 13, 1993;Build 26 - ; -GETSEL(SCDATA,SCTYPE,SCIEN) ; - ; -- get SELECTION entity data for details form - ; - ; input: SCTYPE := type of autolink (DIVISIOND, TEAM, ectc.) - ; SCIEN := ien of entity - ; output: SCDATA(1..n) := info about entity - ; - ; -- SEE BOTTOM OF SCRPBK FOR VARIABLE DEFINITIONS - ; - ; Related RPC: SCRP FILE ENTRY GETSELECTION - ; - N SC0,SCI,SCINC - S SCINC=0,SCID=+SCIEN - ; - IF SCTYPE="DIVISION" D DIV G GETSELQ - ; - IF SCTYPE="TEAM" D TEAM G GETSELQ - ; - IF SCTYPE="PRACTITIONER" D PRAC G GETSELQ - ; - IF SCTYPE="ROLE" D ROLE G GETSELQ - ; - IF SCTYPE="CLINIC" D CLIN G GETSELQ - ; - IF SCTYPE="USERCLASS" D USER G GETSELQ - ; -GETSELQ Q - ; -SET(X,INC,SCDATA) ; -- set value in return array - S INC=$G(INC)+1,SCDATA(INC)=X - Q - ; -DIV ; -- get division details - D SET("Teams in Division:",.SCINC,.SCDATA) - D SET("------------------",.SCINC,.SCDATA) - S SCI=0 F S SCI=$O(^SCTM(404.51,"AINST",SCID,SCI)) Q:'SCI D - . D SET($P($G(^SCTM(404.51,SCI,0)),U),.SCINC,.SCDATA) - Q - ; -TEAM ; -- get team description - N SC,SCFLE,SCIEN,SCDEF - S SCFLE=404.51,SCIEN=SCID_",",SCDEF="" - D GETS^DIQ(SCFLE,SCID_",",50,"","SC") - D SET("Team Description:",.SCINC,.SCDATA) - D SET("-----------------",.SCINC,.SCDATA) - IF $O(SC(SCFLE,SCIEN,50,0)) D - . S SCI=0 F S SCI=$O(SC(SCFLE,SCIEN,50,SCI)) Q:'SCI S X=SC(SCFLE,SCIEN,50,SCI) D - . . D SET(X,.SCINC,.SCDATA) - ELSE D - . D SET(SCDEF,.SCINC,.SCDATA) - Q - ; -PRAC ; -- get practitioner details - N SC,SCFLE,SCIEN,SCDEF - S SCFLE=200,SCIEN=SCID_",",SCDEF="" - D GETS^DIQ(SCFLE,SCID_",","1;8;28","","SC") - D SET(" Initials: "_$S($G(SC(SCFLE,SCIEN,1))]"":SC(SCFLE,SCIEN,1),1:SCDEF),.SCINC,.SCDATA) - D SET("Mail Code: "_$S($G(SC(SCFLE,SCIEN,28))]"":SC(SCFLE,SCIEN,28),1:SCDEF),.SCINC,.SCDATA) - D SET(" Title: "_$S($G(SC(SCFLE,SCIEN,8))]"":SC(SCFLE,SCIEN,8),1:SCDEF),.SCINC,.SCDATA) - Q - ; -ROLE ; -- get standard role description - N SC,SCFLE,SCIEN,SCDEF - S SCFLE=403.46,SCIEN=SCID_",",SCDEF="" - D GETS^DIQ(SCFLE,SCID_",",1,"","SC") - D SET("Role Description:",.SCINC,.SCDATA) - D SET("-----------------",.SCINC,.SCDATA) - IF $O(SC(SCFLE,SCIEN,1,0)) D - . S SCI=0 F S SCI=$O(SC(SCFLE,SCIEN,1,SCI)) Q:'SCI S X=SC(SCFLE,SCIEN,1,SCI) D - . . D SET(X,.SCINC,.SCDATA) - ELSE D - . D SET(SCDEF,.SCINC,.SCDATA) - Q - ; -CLIN ; -- get clinic details - N SC,SCFLE,SCIEN,SCDEF - S SCFLE=44,SCIEN=SCID_",",SCDEF="" - D GETS^DIQ(SCFLE,SCID_",","1;3.5","","SC") - D SET("Abbreviation: "_$S($G(SC(SCFLE,SCIEN,1))]"":SC(SCFLE,SCIEN,1),1:SCDEF),.SCINC,.SCDATA) - D SET(" Division: "_$S($G(SC(SCFLE,SCIEN,3.5))]"":SC(SCFLE,SCIEN,3.5),1:SCDEF),.SCINC,.SCDATA) - D SET(" ",.SCINC,.SCDATA) - D SET("Associated Teams and Positions:",.SCINC,.SCDATA) - D SET("-------------------------------",.SCINC,.SCDATA) - S SCI=0 F S SCI=$O(^SCTM(404.57,"E",SCID,SCI)) Q:'SCI D - . S X=$G(^SCTM(404.57,SCI,0)) - . D SET(" Team: "_$P($G(^SCTM(404.51,+$P(X,U,2),0)),U),.SCINC,.SCDATA) - . D SET(" Position: "_$P(X,U),.SCINC,.SCDATA) - . D SET(" ",.SCINC,.SCDATA) - Q - ; -USER ; -- get user class details - D SET("No additional information available at this time. ",.SCINC,.SCDATA) - Q - ; +SCRPBK11 ;MJK/ALB - RPC Broker Utilities ; 27 FEB 96 + ;;5.3;Scheduling;**41**;AUG 13, 1993 + ; +GETSEL(SCDATA,SCTYPE,SCIEN) ; + ; -- get SELECTION entity data for details form + ; + ; input: SCTYPE := type of autolink (DIVISIOND, TEAM, ectc.) + ; SCIEN := ien of entity + ; output: SCDATA(1..n) := info about entity + ; + ; -- SEE BOTTOM OF SCRPBK FOR VARIABLE DEFINITIONS + ; + ; Related RPC: SCRP FILE ENTRY GETSELECTION + ; + N SC0,SCI,SCINC + S SCINC=0,SCID=+SCIEN + ; + IF SCTYPE="DIVISION" D DIV G GETSELQ + ; + IF SCTYPE="TEAM" D TEAM G GETSELQ + ; + IF SCTYPE="PRACTITIONER" D PRAC G GETSELQ + ; + IF SCTYPE="ROLE" D ROLE G GETSELQ + ; + IF SCTYPE="CLINIC" D CLIN G GETSELQ + ; + IF SCTYPE="USERCLASS" D USER G GETSELQ + ; +GETSELQ Q + ; +SET(X,INC,SCDATA) ; -- set value in return array + S INC=$G(INC)+1,SCDATA(INC)=X + Q + ; +DIV ; -- get division details + D SET("Teams in Division:",.SCINC,.SCDATA) + D SET("------------------",.SCINC,.SCDATA) + S SCI=0 F S SCI=$O(^SCTM(404.51,"AINST",SCID,SCI)) Q:'SCI D + . D SET($P($G(^SCTM(404.51,SCI,0)),U),.SCINC,.SCDATA) + Q + ; +TEAM ; -- get team description + N SC,SCFLE,SCIEN,SCDEF + S SCFLE=404.51,SCIEN=SCID_",",SCDEF="" + D GETS^DIQ(SCFLE,SCID_",",50,"","SC") + D SET("Team Description:",.SCINC,.SCDATA) + D SET("-----------------",.SCINC,.SCDATA) + IF $O(SC(SCFLE,SCIEN,50,0)) D + . S SCI=0 F S SCI=$O(SC(SCFLE,SCIEN,50,SCI)) Q:'SCI S X=SC(SCFLE,SCIEN,50,SCI) D + . . D SET(X,.SCINC,.SCDATA) + ELSE D + . D SET(SCDEF,.SCINC,.SCDATA) + Q + ; +PRAC ; -- get practitioner details + N SC,SCFLE,SCIEN,SCDEF + S SCFLE=200,SCIEN=SCID_",",SCDEF="" + D GETS^DIQ(SCFLE,SCID_",","1;8;28","","SC") + D SET(" Initials: "_$S($G(SC(SCFLE,SCIEN,1))]"":SC(SCFLE,SCIEN,1),1:SCDEF),.SCINC,.SCDATA) + D SET("Mail Code: "_$S($G(SC(SCFLE,SCIEN,28))]"":SC(SCFLE,SCIEN,28),1:SCDEF),.SCINC,.SCDATA) + D SET(" Title: "_$S($G(SC(SCFLE,SCIEN,8))]"":SC(SCFLE,SCIEN,8),1:SCDEF),.SCINC,.SCDATA) + Q + ; +ROLE ; -- get standard role description + N SC,SCFLE,SCIEN,SCDEF + S SCFLE=403.46,SCIEN=SCID_",",SCDEF="" + D GETS^DIQ(SCFLE,SCID_",",1,"","SC") + D SET("Role Description:",.SCINC,.SCDATA) + D SET("-----------------",.SCINC,.SCDATA) + IF $O(SC(SCFLE,SCIEN,1,0)) D + . S SCI=0 F S SCI=$O(SC(SCFLE,SCIEN,1,SCI)) Q:'SCI S X=SC(SCFLE,SCIEN,1,SCI) D + . . D SET(X,.SCINC,.SCDATA) + ELSE D + . D SET(SCDEF,.SCINC,.SCDATA) + Q + ; +CLIN ; -- get clinic details + N SC,SCFLE,SCIEN,SCDEF + S SCFLE=44,SCIEN=SCID_",",SCDEF="" + D GETS^DIQ(SCFLE,SCID_",","1;3.5","","SC") + D SET("Abbreviation: "_$S($G(SC(SCFLE,SCIEN,1))]"":SC(SCFLE,SCIEN,1),1:SCDEF),.SCINC,.SCDATA) + D SET(" Division: "_$S($G(SC(SCFLE,SCIEN,3.5))]"":SC(SCFLE,SCIEN,3.5),1:SCDEF),.SCINC,.SCDATA) + D SET(" ",.SCINC,.SCDATA) + D SET("Assoicated Teams and Positions:",.SCINC,.SCDATA) + D SET("-------------------------------",.SCINC,.SCDATA) + S SCI=0 F S SCI=$O(^SCTM(404.57,"D",SCID,SCI)) Q:'SCI D + . S X=$G(^SCTM(404.57,SCI,0)) + . D SET(" Team: "_$P($G(^SCTM(404.51,+$P(X,U,2),0)),U),.SCINC,.SCDATA) + . D SET(" Position: "_$P(X,U),.SCINC,.SCDATA) + . D SET(" ",.SCINC,.SCDATA) + Q + ; +USER ; -- get user class details + D SET("No additional information available at this time. ",.SCINC,.SCDATA) + Q + ; diff --git a/r/SCHEDULING-SD-SC/SCRPEC.m b/r/SCHEDULING-SD-SC/SCRPEC.m index 0ed5ef7f..b8838e6e 100644 --- a/r/SCHEDULING-SD-SC/SCRPEC.m +++ b/r/SCHEDULING-SD-SC/SCRPEC.m @@ -1,100 +1,104 @@ -SCRPEC ;ALB/CMM - Detail List of Pts & Enroll Clinics ; 29 Jun 99 04:11PM - ;;5.3;Scheduling;**41,140,174,177,431,526,520**;AUG 13, 1993;Build 26 - ; - ;Detailed Listing of Patients and Their Enrolled Clinics Report - ; -PROMPTS ; - ;Prompt for Institution, Team, Clinic, Assigned or Unassigned to Primary - ;Care, and Print device - ; - N VAUTD,VAUTT,VAUTC,VAUTA,QTIME,PRNT - K VAUTD,VAUTT,VAUTC,VAUTA,VAUTCA,SCUP - S QTIME="" - W ! D INST^SCRPU1 I Y=-1 G ERR - W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR - ;S VAUTCA="" ;allows for selection of any clinic in one of the selected divisions - W ! K Y D CLINIC^SCRPU1 I '$D(VAUTC) G ERR - W ! K Y D ASSUN^SCRPU2 I '$D(VAUTA) G ERR - W !!,"This report requires 132 column output!" - D QUE(.VAUTD,.VAUTT,.VAUTC,.VAUTA) Q - ; -QUE(INST,TEAM,CLINIC,ASSUN) ;queue report - ;Input Parameters: - ;INST - institutions selected (variable and array) - ;TEAM - teams selected (variable and array) - ;CLINIC - clinics selected (variable and array) - ;ASSUN - Assigned or Unassigned to PC - N ZTSAVE,II - F II="INST","TEAM","CLINIC","ASSUN","INST(","TEAM(","CLINIC(" S ZTSAVE(II)="" - W ! D EN^XUTMDEVQ("QENTRY^SCRPEC","Detailed Patient Enrollments",.ZTSAVE) - Q - ; -ENTRY2(INST,TEAM,CLINIC,ASSUN,IOP,ZTDTH) ; - ;Second entry point for GUI to use - ;Input Parameters: - ;INST - institutions selected (variable and array) - ;TEAM - teams selected (variable and array) - ;CLINIC - clinics selected (variable and array) - ;ASSUN - Assigned or Unassigned to PC - ;IOP - print device - ;ZTDTH - queue time (optional) - ; - ;validate parameters - I '$D(INST)!'$D(TEAM)!'$D(CLINIC)!'$D(ASSUN)!'$D(IOP)!(IOP="") Q - ; - N NUMBER - S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^") - I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2) - I IOST?1"C-".E D QENTRY G RET - I ZTDTH="" S ZTDTH=$H - S ZTRTN="QENTRY^SCRPEC" - S ZTDESC="Detailed Patient List & Enrolled Clinics",ZTIO=IOP - N II - F II="INST","TEAM","CLINIC","ASSUN","INST(","TEAM(","CLINIC(","IOP" S ZTSAVE(II)="" - D ^%ZTLOAD -RET S NUMBER=0 - I $D(ZTSK) S NUMBER=ZTSK - D EXIT1 - Q NUMBER - ; -QENTRY ; - ;driver entry point - S VAUTTN="" - S TITL="Detailed Patient Assignments - "_$S(ASSUN=1:"Assigned PC",1:"Not Assigned PC") - S STORE="^TMP("_$J_",""SCRPEC"")" - K @STORE - S @STORE=0 - D FIND^SCRPEC3 - I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL) - I '$D(NODATA) D HEADER^SCRPEC2,PRINTIT^SCRPEC3(STORE,TITL) - D EXIT2 - Q - ; -ERR ; -EXIT1 ; - K ZTSAVE,ZTSK,ZTIO,ZTDTH,ZTRTN,ZTDESC,VAUTCA,SCUP - Q -EXIT2 ; - K @STORE - K STORE,VAUTTN,PAGE,TITL,IOP,TITL,NODATA,CLINIC,ASSUN,INST,TEAM,STOP - Q - ; -PDATA(DFN,CLNEN,CNAME,FLAG) ; - ;Collect and format data for report - ; - N NODE,NAME,PID,PELIG,MT,PSTAT,STATD,DATA,LAST,NEXT - S DATA="" - S NODE=$G(^DPT(DFN,0)) - S NAME=$P(NODE,"^") ;patient name - S PID=$P($G(^DPT(DFN,.36)),"^",3),PID=$TR(PID,"-","") ;PID without '-'s - S MT=$$LST^DGMTU(DFN),MT=$P(MT,"^",4) ;means test status SD*5.3*431 - S PELIG=$$ELIG^SCRPU3(DFN) ;primary eligibility - S PSTAT="N/A" - S STATD="" - S LAST=$$GETLAST^SCRPU3(DFN,.CLNEN) ;last Clinic appointment - S NEXT=$$GETNEXT^SCRPU3(DFN,.CLNEN) ;next clinic appointment - ;I '$D(FLAG) S DATA=$$FORMAT^SCRPEC2(PTIEN,INS,TIEN,PDATA,CNAME,CIEN) - I '$D(FLAG) S DATA=$$FORMAT^SCRPEC2(NAME,PID,MT,PELIG,PSTAT,STATD,LAST,NEXT,CNAME),DATA=$E(NAME,1,12)_"^"_DATA - I $D(FLAG) S DATA=$E(NAME,1,12)_"^"_PID_"^"_MT_"^"_PELIG_"^"_PSTAT_"^"_STATD_"^"_LAST_"^"_NEXT - Q DATA - ; +SCRPEC ;ALB/CMM - Detail List of Pts & Enroll Clinics ; 29 Jun 99 04:11PM + ;;5.3;Scheduling;**41,140,174,177,431**;AUG 13, 1993 + ; + ;Detailed Listing of Patients and Their Enrolled Clinics Report + ; +PROMPTS ; + ;Prompt for Institution, Team, Clinic, Assigned or Unassigned to Primary + ;Care, and Print device + ; + N VAUTD,VAUTT,VAUTC,VAUTA,QTIME,PRNT + K VAUTD,VAUTT,VAUTC,VAUTA,VAUTCA,SCUP + S QTIME="" + W ! D INST^SCRPU1 I Y=-1 G ERR + W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR + ;S VAUTCA="" ;allows for selection of any clinic in one of the selected divisions + W ! K Y D CLINIC^SCRPU1 I '$D(VAUTC) G ERR + W ! K Y D ASSUN^SCRPU2 I '$D(VAUTA) G ERR + W !!,"This report requires 132 column output!" + D QUE(.VAUTD,.VAUTT,.VAUTC,.VAUTA) Q + ; +QUE(INST,TEAM,CLINIC,ASSUN) ;queue report + ;Input Parameters: + ;INST - institutions selected (variable and array) + ;TEAM - teams selected (variable and array) + ;CLINIC - clinics selected (variable and array) + ;ASSUN - Assigned or Unassigned to PC + N ZTSAVE,II + F II="INST","TEAM","CLINIC","ASSUN","INST(","TEAM(","CLINIC(" S ZTSAVE(II)="" + W ! D EN^XUTMDEVQ("QENTRY^SCRPEC","Detailed Patient Enrollments",.ZTSAVE) + Q + ; +ENTRY2(INST,TEAM,CLINIC,ASSUN,IOP,ZTDTH) ; + ;Second entry point for GUI to use + ;Input Parameters: + ;INST - institutions selected (variable and array) + ;TEAM - teams selected (variable and array) + ;CLINIC - clinics selected (variable and array) + ;ASSUN - Assigned or Unassigned to PC + ;IOP - print device + ;ZTDTH - queue time (optional) + ; + ;validate parameters + I '$D(INST)!'$D(TEAM)!'$D(CLINIC)!'$D(ASSUN)!'$D(IOP)!(IOP="") Q + ; + N NUMBER + S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^") + I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2) + I IOST?1"C-".E D QENTRY G RET + I ZTDTH="" S ZTDTH=$H + S ZTRTN="QENTRY^SCRPEC" + S ZTDESC="Detailed Patient List & Enrolled Clinics",ZTIO=IOP + N II + F II="INST","TEAM","CLINIC","ASSUN","INST(","TEAM(","CLINIC(","IOP" S ZTSAVE(II)="" + D ^%ZTLOAD +RET S NUMBER=0 + I $D(ZTSK) S NUMBER=ZTSK + D EXIT1 + Q NUMBER + ; +QENTRY ; + ;driver entry point + S VAUTTN="" + S TITL="Detailed Patient Assignments - "_$S(ASSUN=1:"Assigned PC",1:"Not Assigned PC") + S STORE="^TMP("_$J_",""SCRPEC"")" + K @STORE + S @STORE=0 + D FIND^SCRPEC3 + I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL) + I '$D(NODATA) D HEADER^SCRPEC2,PRINTIT^SCRPEC3(STORE,TITL) + D EXIT2 + Q + ; +ERR ; +EXIT1 ; + K ZTSAVE,ZTSK,ZTIO,ZTDTH,ZTRTN,ZTDESC,VAUTCA,SCUP + Q +EXIT2 ; + K @STORE + K STORE,VAUTTN,PAGE,TITL,IOP,TITL,NODATA,CLINIC,ASSUN,INST,TEAM,STOP + Q + ; +PDATA(DFN,CLNEN,FLAG) ; + ;Collect and format data for report + ; + N NODE,NAME,PID,PELIG,MT,PSTAT,STATD,DATA,LAST,NEXT,CEN,CNAME + S DATA="" + S NODE=$G(^DPT(DFN,0)) + S NAME=$P(NODE,"^") ;patient name + S PID=$P($G(^DPT(DFN,.36)),"^",3),PID=$TR(PID,"-","") ;PID without '-'s + S MT=$$LST^DGMTU(DFN),MT=$P(MT,"^",4) ;means test status SD*5.3*431 + S PELIG=$$ELIG^SCRPU3(DFN) ;primary eligibility + ; + S CNAME=$P($G(^SC(CLNEN,0)),"^") + S CEN=+$O(^DPT(DFN,"DE","B",CLNEN,"")) + S NODE=$G(^DPT(DFN,"DE",CEN,1,1,0)) + S PSTAT=$P(NODE,"^",2) S PSTAT=PSTAT_$S(PSTAT="A":"C",PSTAT="O":"PT",1:"") ;opt or ac status + I $P(NODE,"^")="" S STATD="" + I $P(NODE,"^")'="" S STATD=$TR($$FMTE^XLFDT($P(NODE,"^"),"5DF")," ","0") ;enrollment date + S LAST=$$GETLAST^SCRPU3(DFN,CLNEN) ;last clinic appointment + S NEXT=$$GETNEXT^SCRPU3(DFN,CLNEN) ;next clinic appointment + I '$D(FLAG) S DATA=$$FORMAT^SCRPEC2(NAME,PID,MT,PELIG,PSTAT,STATD,LAST,NEXT,CNAME),DATA=$E(NAME,1,20)_"^"_DATA + I $D(FLAG) S DATA=$E(NAME,1,20)_"^"_PID_"^"_MT_"^"_PELIG_"^"_PSTAT_"^"_STATD_"^"_LAST_"^"_NEXT + Q DATA + ; diff --git a/r/SCHEDULING-SD-SC/SCRPEC2.m b/r/SCHEDULING-SD-SC/SCRPEC2.m index f1b32e0c..526e931b 100644 --- a/r/SCHEDULING-SD-SC/SCRPEC2.m +++ b/r/SCHEDULING-SD-SC/SCRPEC2.m @@ -1,157 +1,157 @@ -SCRPEC2 ;ALB/CMM - Detail List of Pts & Enroll Clinics Continued ; 29 Jun 99 04:11PM - ;;5.3;Scheduling;**41,140,174,177,526**;AUG 13, 1993;Build 8 - ; - ;Detailed Listing of Patients and Their Enrolled Clinics Report - ; -PAT(TIEN,PTLIST) ; - ;TIEN - team ien - ;PTLIST - array holding patients assigned to team TIEN - ; - N PTIEN,ENT,NODE,OKAY,CLLIST,ERR,PC - S ENT=0,CLLIST="LIST2",ERR="ERROR2" - K @CLLIST - F S ENT=$O(@PTLIST@(ENT)) Q:ENT=""!(ENT'?.N) D - .S NODE=$G(@PTLIST@(ENT)) - .Q:NODE="" - .S PTIEN=+$P(NODE,"^") ;patient ien - .S PC=$$PCASSIGN(PTIEN,TIEN) - .Q:PC'=ASSUN ;not selected assigned/unassigned primary care - .K @CLLIST - .S OKAY=$$CLPT^SCAPMC29(PTIEN,"","",.CLLIST,.ERR) - .;all clinics for patient PTIEN - .Q:'OKAY - .D KEEP(TIEN,PTIEN,.CLLIST) - K @CLLIST - Q - ; -KEEP(TIEN,PTIEN,CLLIST) ;keep data for report - ;TIEN - team ien - ;PTIEN - patient ien - ;CLLIST - array holding clinics for patient PTIEN - ; - N ENT,TNAME,INS,NODE,INAME,PDATA,NODE,CIEN,CNAME,PNAME - N SCPCPR,SCPCAP,SCI,PCLIST - S TNAME=$P($G(^SCTM(404.51,TIEN,0)),"^") ;team name - S INS=+$P($G(^SCTM(404.51,TIEN,0)),"^",7) ;institution ien - S INAME=$P($G(^DIC(4,INS,0)),"^") ;institution name - S PNAME=$P($G(^DPT(PTIEN,0)),"^") ;patient name - K ^TMP("SC",$J,PTIEN) - S SCI=$$GETALL^SCAPMCA(PTIEN) D - .;Name of PC Provider - .S SCPCPR=$P($G(^TMP("SC",$J,PTIEN,"PCPR",1)),U,2) - .;Name of Associate Provider - .S SCPCAP=$P($G(^TMP("SC",$J,PTIEN,"PCAP",1)),U,2) - .Q - ; - S ENT=0 - F S ENT=$O(@CLLIST@(ENT)) Q:ENT=""!(ENT'?.N) D - .S NODE=$G(@CLLIST@(ENT)) - .S CIEN=+$P(NODE,"^") ;clinic ien - .I CLINIC'=1,'$D(CLINIC(CIEN)) Q - .S CNAME=$P(NODE,"^",2) ;clinic name - .D SETUP(INS,INAME,TIEN,TNAME,PTIEN,PNAME,CIEN,CNAME) - .S PDATA=$$PDATA^SCRPEC(PTIEN,CIEN,1) - .S $P(PDATA,U,9)=SCPCPR,$P(PDATA,U,10)=SCPCAP - .;name^pid^mt^pelig^pstat^statd^last^next^pc prov.^assoc. prov. - .D FORMAT(PTIEN,INS,TIEN,PDATA,CNAME,CIEN) - Q - ; -SETUP(INS,INAME,TIEN,TNAME,PTIEN,PNAME,CIEN,CNAME) ; - ;INS - institution ien - ;INAME - institution name - ;TIEN - team ien - ;TNAME - team name - ;PTIEN - patient ien - ;PNAME - patient name - ;CIEN - clinic ien - ;CNAME - clinic name - ; - I INAME="" S INAME="[BAD DATA]" - I TNAME="" S TNAME="[BAD DATA]" - I CNAME="" S CNAME="[BAD DATA]" - I PNAME="" S PNAME="[BAD DATA]" - I '$D(@STORE@("I",INAME,INS)) S @STORE@("I",INAME,INS)="",@STORE@(INS)="Division: "_INAME - I '$D(@STORE@("T",INS,TNAME,TIEN)) S @STORE@("T",INS,TNAME,TIEN)="",@STORE@(INS,TIEN)="Team: "_TNAME - I '$D(@STORE@("C",INS,TIEN,CNAME,CIEN)) S @STORE@("C",INS,TIEN,CNAME,CIEN)="" ;D HEADER(INS,TIEN,CIEN) - I '$D(@STORE@("PT",INS,TIEN,CIEN,PNAME,PTIEN)) S @STORE@("PT",INS,TIEN,CIEN,PNAME,PTIEN)="" - Q - ; -PCASSIGN(DFN,TIEN) ;patient assigned to team as primary care - ;DFN - patient ien - ;TIEN - team ien - ;1 - yes - ;0 - no - ; - N ADATE,ENTRY,PC - S PC=0 - I '$D(^SCPT(404.42,"AIDT",DFN,TIEN)) Q PC - S ADATE=$O(^SCPT(404.42,"AIDT",DFN,TIEN,"")) ; -team assignemtn date - S ENTRY=$O(^SCPT(404.42,"AIDT",DFN,TIEN,ADATE,"")) ;patient team assignemtn ien - I $P($G(^SCPT(404.42,+ENTRY,0)),"^",8)=1 S PC=1 - Q PC - ; -HEADER ;report column titles - N HLD - S HLD="H0" - S $E(@STORE@("SUBHEADER",HLD),25)="M.T." - S $E(@STORE@("SUBHEADER",HLD),31)="Prim" - ;Removed by patch 174 - ;S $E(@STORE@("SUBHEADER",HLD),31)="Pat" - ;S $E(@STORE@("SUBHEADER",HLD),36)="Status" - S $E(@STORE@("SUBHEADER",HLD),42)="Last" - S $E(@STORE@("SUBHEADER",HLD),54)="Next" - S $E(@STORE@("SUBHEADER",HLD),66)="Enrolled" - S $E(@STORE@("SUBHEADER",HLD),95)="Primary Care" - S $E(@STORE@("SUBHEADER",HLD),115)="Associate" - S HLD="H1" - S @STORE@("SUBHEADER",HLD)="Patient Name" - S $E(@STORE@("SUBHEADER",HLD),16)="Pt ID" - S $E(@STORE@("SUBHEADER",HLD),25)="Stat" - S $E(@STORE@("SUBHEADER",HLD),31)="Elig" - ;Removed by patch 174 - ;S $E(@STORE@("SUBHEADER",HLD),31)="Stat" - ;S $E(@STORE@("SUBHEADER",HLD),36)="Date" - S $E(@STORE@("SUBHEADER",HLD),42)="Appt" - S $E(@STORE@("SUBHEADER",HLD),54)="Appt" - S $E(@STORE@("SUBHEADER",HLD),66)="Clinic" - S $E(@STORE@("SUBHEADER",HLD),95)="Provider" - S $E(@STORE@("SUBHEADER",HLD),115)="Provider" - S HLD="H2" - S $P(@STORE@("SUBHEADER",HLD),"=",133)="" - Q - ; -FORMAT(PTIEN,INS,TIEN,PDATA,CNAME,CIEN) ;format data for report - ;PTIEN - patient ien - ;INS - institution ien - ;TIEN - team ien - ;PDATA - pt name^pid^mt^pelig^pstat^statd^last^next^pc prov.^assoc. prov. - ;CNAME - clinic name - ;CIEN - clinic ien - ; - S @STORE@(INS,TIEN,CIEN,PTIEN)=$E($P(PDATA,"^"),1,12) ;patient name - S $E(@STORE@(INS,TIEN,CIEN,PTIEN),14)=$P(PDATA,"^",2) ;primary long id 9 digit - S $E(@STORE@(INS,TIEN,CIEN,PTIEN),26)=$P(PDATA,"^",3) ;means test category - S $E(@STORE@(INS,TIEN,CIEN,PTIEN),31)=$P(PDATA,"^",4) ;primary eligibility - ;Removed by patch 174 - ;S $E(@STORE@(INS,TIEN,CIEN,PTIEN),31)=$P(PDATA,"^",5) ;patient status - ;S $E(@STORE@(INS,TIEN,CIEN,PTIEN),35)=$P(PDATA,"^",6) ;status date - S $E(@STORE@(INS,TIEN,CIEN,PTIEN),42)=$P(PDATA,"^",7) ;last appointment - S $E(@STORE@(INS,TIEN,CIEN,PTIEN),54)=$P(PDATA,"^",8) ;next appointment - S $E(@STORE@(INS,TIEN,CIEN,PTIEN),66)=$E(CNAME,1,27) ;clinic name - S $E(@STORE@(INS,TIEN,CIEN,PTIEN),95)=$E($P(PDATA,U,9),1,18) ;PC prov. - S $E(@STORE@(INS,TIEN,CIEN,PTIEN),115)=$E($P(PDATA,U,10),1,18) ;Assoc. Prov. - Q - ; -CHEAD(INS,TEAM,CLINIC) ; - ;column headings - ; - N EN,NEWP - W ! - S NEWP=0 - I IOST'?1"C-".E,$Y+5>(IOSL-6) D NEWP1^SCRPU3(.PAGE,TITL) S NEWP=1 - I IOST?1"C-".E,$Y+5>(IOSL-6) D HOLD^SCRPU3(.PAGE,TITL) S NEWP=1 - I STOP Q - I NEWP W !,$G(@STORE@(INS)),!!,$G(@STORE@(INS,TEAM)),! -CH2 F EN="H0","H1","H2" W !,$G(@STORE@("SUBHEADER",EN)) - Q - ; +SCRPEC2 ;ALB/CMM - Detail List of Pts & Enroll Clinics Continued ; 29 Jun 99 04:11PM + ;;5.3;Scheduling;**41,140,174,177**;AUG 13, 1993 + ; + ;Detailed Listing of Patients and Their Enrolled Clinics Report + ; +PAT(TIEN,PTLIST) ; + ;TIEN - team ien + ;PTLIST - array holding patients assigned to team TIEN + ; + N PTIEN,ENT,NODE,OKAY,CLLIST,ERR,PC + S ENT=0,CLLIST="LIST2",ERR="ERROR2" + K @CLLIST + F S ENT=$O(@PTLIST@(ENT)) Q:ENT=""!(ENT'?.N) D + .S NODE=$G(@PTLIST@(ENT)) + .Q:NODE="" + .S PTIEN=+$P(NODE,"^") ;patient ien + .S PC=$$PCASSIGN(PTIEN,TIEN) + .Q:PC'=ASSUN ;not selected assigned/unassigned primary care + .K @CLLIST + .S OKAY=$$CLPT^SCAPMC29(PTIEN,"","",.CLLIST,.ERR) + .;all clinics for patient PTIEN + .Q:'OKAY + .D KEEP(TIEN,PTIEN,.CLLIST) + K @CLLIST + Q + ; +KEEP(TIEN,PTIEN,CLLIST) ;keep data for report + ;TIEN - team ien + ;PTIEN - patient ien + ;CLLIST - array holding clinics for patient PTIEN + ; + N ENT,TNAME,INS,NODE,INAME,PDATA,NODE,CIEN,CNAME,PNAME + N SCPCPR,SCPCAP,SCI,PCLIST + S TNAME=$P($G(^SCTM(404.51,TIEN,0)),"^") ;team name + S INS=+$P($G(^SCTM(404.51,TIEN,0)),"^",7) ;institution ien + S INAME=$P($G(^DIC(4,INS,0)),"^") ;institution name + S PNAME=$P($G(^DPT(PTIEN,0)),"^") ;patient name + K ^TMP("SC",$J,PTIEN) + S SCI=$$GETALL^SCAPMCA(PTIEN) D + .;Name of PC Provider + .S SCPCPR=$P($G(^TMP("SC",$J,PTIEN,"PCPR",1)),U,2) + .;Name of Associate Provider + .S SCPCAP=$P($G(^TMP("SC",$J,PTIEN,"PCAP",1)),U,2) + .Q + ; + S ENT=0 + F S ENT=$O(@CLLIST@(ENT)) Q:ENT=""!(ENT'?.N) D + .S NODE=$G(@CLLIST@(ENT)) + .S CIEN=+$P(NODE,"^") ;clinic ien + .I CLINIC'=1,'$D(CLINIC(CIEN)) Q + .S CNAME=$P(NODE,"^",2) ;clinic name + .D SETUP(INS,INAME,TIEN,TNAME,PTIEN,PNAME,CIEN,CNAME) + .S PDATA=$$PDATA^SCRPEC(PTIEN,CIEN,1) + .S $P(PDATA,U,9)=SCPCPR,$P(PDATA,U,10)=SCPCAP + .;name^pid^mt^pelig^pstat^statd^last^next^pc prov.^assoc. prov. + .D FORMAT(PTIEN,INS,TIEN,PDATA,CNAME,CIEN) + Q + ; +SETUP(INS,INAME,TIEN,TNAME,PTIEN,PNAME,CIEN,CNAME) ; + ;INS - institution ien + ;INAME - institution name + ;TIEN - team ien + ;TNAME - team name + ;PTIEN - patient ien + ;PNAME - patient name + ;CIEN - clinic ien + ;CNAME - clinic name + ; + I INAME="" S INAME="[BAD DATA]" + I TNAME="" S TNAME="[BAD DATA]" + I CNAME="" S CNAME="[BAD DATA]" + I PNAME="" S PNAME="[BAD DATA]" + I '$D(@STORE@("I",INAME,INS)) S @STORE@("I",INAME,INS)="",@STORE@(INS)="Division: "_INAME + I '$D(@STORE@("T",INS,TNAME,TIEN)) S @STORE@("T",INS,TNAME,TIEN)="",@STORE@(INS,TIEN)="Team: "_TNAME + I '$D(@STORE@("C",INS,TIEN,CNAME,CIEN)) S @STORE@("C",INS,TIEN,CNAME,CIEN)="" ;D HEADER(INS,TIEN,CIEN) + I '$D(@STORE@("PT",INS,TIEN,CIEN,PNAME,PTIEN)) S @STORE@("PT",INS,TIEN,CIEN,PNAME,PTIEN)="" + Q + ; +PCASSIGN(DFN,TIEN) ;patient assigned to team as primary care + ;DFN - patient ien + ;TIEN - team ien + ;1 - yes + ;0 - no + ; + N ADATE,ENTRY,PC + S PC=0 + I '$D(^SCPT(404.42,"AIDT",DFN,TIEN)) Q PC + S ADATE=$O(^SCPT(404.42,"AIDT",DFN,TIEN,"")) ; -team assignemtn date + S ENTRY=$O(^SCPT(404.42,"AIDT",DFN,TIEN,ADATE,"")) ;patient team assignemtn ien + I $P($G(^SCPT(404.42,+ENTRY,0)),"^",8)=1 S PC=1 + Q PC + ; +HEADER ;report column titles + N HLD + S HLD="H0" + S $E(@STORE@("SUBHEADER",HLD),25)="M.T." + S $E(@STORE@("SUBHEADER",HLD),31)="Prim" + ;Removed by patch 174 + ;S $E(@STORE@("SUBHEADER",HLD),31)="Pat" + ;S $E(@STORE@("SUBHEADER",HLD),36)="Status" + S $E(@STORE@("SUBHEADER",HLD),42)="Last" + S $E(@STORE@("SUBHEADER",HLD),54)="Next" + S $E(@STORE@("SUBHEADER",HLD),66)="Enrolled" + S $E(@STORE@("SUBHEADER",HLD),95)="Primary Care" + S $E(@STORE@("SUBHEADER",HLD),115)="Associate" + S HLD="H1" + S @STORE@("SUBHEADER",HLD)="Patient Name" + S $E(@STORE@("SUBHEADER",HLD),18)="Pt ID" + S $E(@STORE@("SUBHEADER",HLD),25)="Stat" + S $E(@STORE@("SUBHEADER",HLD),31)="Elig" + ;Removed by patch 174 + ;S $E(@STORE@("SUBHEADER",HLD),31)="Stat" + ;S $E(@STORE@("SUBHEADER",HLD),36)="Date" + S $E(@STORE@("SUBHEADER",HLD),42)="Appt" + S $E(@STORE@("SUBHEADER",HLD),54)="Appt" + S $E(@STORE@("SUBHEADER",HLD),66)="Clinic" + S $E(@STORE@("SUBHEADER",HLD),95)="Provider" + S $E(@STORE@("SUBHEADER",HLD),115)="Provider" + S HLD="H2" + S $P(@STORE@("SUBHEADER",HLD),"=",133)="" + Q + ; +FORMAT(PTIEN,INS,TIEN,PDATA,CNAME,CIEN) ;format data for report + ;PTIEN - patient ien + ;INS - institution ien + ;TIEN - team ien + ;PDATA - pt name^pid^mt^pelig^pstat^statd^last^next^pc prov.^assoc. prov. + ;CNAME - clinic name + ;CIEN - clinic ien + ; + S @STORE@(INS,TIEN,CIEN,PTIEN)=$E($P(PDATA,"^"),1,15) ;patient name + S $E(@STORE@(INS,TIEN,CIEN,PTIEN),18)=$E($P(PDATA,"^",2),6,10) ;primary long id last 4 plus P + S $E(@STORE@(INS,TIEN,CIEN,PTIEN),25)=$P(PDATA,"^",3) ;means test category + S $E(@STORE@(INS,TIEN,CIEN,PTIEN),31)=$P(PDATA,"^",4) ;primary eligibility + ;Removed by patch 174 + ;S $E(@STORE@(INS,TIEN,CIEN,PTIEN),31)=$P(PDATA,"^",5) ;patient status + ;S $E(@STORE@(INS,TIEN,CIEN,PTIEN),35)=$P(PDATA,"^",6) ;status date + S $E(@STORE@(INS,TIEN,CIEN,PTIEN),42)=$P(PDATA,"^",7) ;last appointment + S $E(@STORE@(INS,TIEN,CIEN,PTIEN),54)=$P(PDATA,"^",8) ;next appointment + S $E(@STORE@(INS,TIEN,CIEN,PTIEN),66)=$E(CNAME,1,27) ;clinic name + S $E(@STORE@(INS,TIEN,CIEN,PTIEN),95)=$E($P(PDATA,U,9),1,18) ;PC prov. + S $E(@STORE@(INS,TIEN,CIEN,PTIEN),115)=$E($P(PDATA,U,10),1,18) ;Assoc. Prov. + Q + ; +CHEAD(INS,TEAM,CLINIC) ; + ;column headings + ; + N EN,NEWP + W ! + S NEWP=0 + I IOST'?1"C-".E,$Y+5>(IOSL-6) D NEWP1^SCRPU3(.PAGE,TITL) S NEWP=1 + I IOST?1"C-".E,$Y+5>(IOSL-6) D HOLD^SCRPU3(.PAGE,TITL) S NEWP=1 + I STOP Q + I NEWP W !,$G(@STORE@(INS)),!!,$G(@STORE@(INS,TEAM)),! +CH2 F EN="H0","H1","H2" W !,$G(@STORE@("SUBHEADER",EN)) + Q + ; diff --git a/r/SCHEDULING-SD-SC/SCRPITP.m b/r/SCHEDULING-SD-SC/SCRPITP.m index e56d3ea2..d09df74b 100644 --- a/r/SCHEDULING-SD-SC/SCRPITP.m +++ b/r/SCHEDULING-SD-SC/SCRPITP.m @@ -1,149 +1,144 @@ -SCRPITP ;ALB/CMM - Individual Team Profile ; 29 Jun 99 04:11PM - ;;5.3;Scheduling;**41,52,177,520**;AUG 13, 1993;Build 26 - ; - ;Individual Team Profile - ; -PROMPTS ; - ;Prompt for Institution, Team, and Print device - ; - N QTIME,PRNT,VAUTD,VAUTT,Y,NUMBER - K VAUTD,VAUTT,SCUP - S QTIME="" - W ! D INST^SCRPU1 I Y=-1 G ERR - W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR - W !!,"This report requires 132 column output!" - D QUE(.VAUTD,.VAUTT) Q - ; -QUE(INST,TEAM) ;queue report - ;Input Parameters: - ;INST - institutions selected (variable and array) - ;TEAM - teams selected (variable and array) - N ZTSAVE,II - F II="INST","TEAM","INST(","TEAM(" S ZTSAVE(II)="" - W ! D EN^XUTMDEVQ("QENTRY^SCRPITP","Individual Team Profile",.ZTSAVE) - Q - ; -ENTRY2(INST,TEAM,IOP,ZTDTH) ; - ;Second entry point for GUI to use - ;Input Parameters: - ;INST - institutions selected (variable and array) - ;TEAM - teams selected (variable and array) - ;IOP - print device - ;ZTDTH - queue time (optional) - ; - ;validate parameters - I '$D(INST)!'$D(TEAM)!'$D(IOP)!(IOP="") Q - ; - N NUMBER - S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^") - I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2) - I IOST?1"C-".E D QENTRY G RET - I ZTDTH="" S ZTDTH=$H - S ZTRTN="QENTRY^SCRPITP" - S ZTDESC="iIndividual Team Profile",ZTIO=IOP - N II - F II="INST","TEAM","INST(","TEAM(","IOP" S ZTSAVE(II)="" - D ^%ZTLOAD -RET S NUMBER=0 - I $D(ZTSK) S NUMBER=ZTSK - D EXIT1 - Q NUMBER - ; -QENTRY ; - ;driver entry point - S TITL="Individual Team Profile" - S STORE="^TMP("_$J_",""SCRPITP"")" - K @STORE - S @STORE=0 - I TEAM=1 D TALL^SCRPPAT3 S TEAM=0 - D FIND - I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL) - I '$D(NODATA) D PRINTIT(STORE,TITL) - D EXIT2 - Q - ; -ERR ; -EXIT1 ; - K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE - Q - ; -EXIT2 ; - K @STORE - K STOP,STORE,TITL,IOP,TEAM,INST,NODATA - Q - ; -FIND ; - N TM,EN,NODE,TMP,TPNAME - S TM="" K ^TMP("SCRATCH",$J) - F S TM=$O(^SCTM(404.57,"C",TM)) Q:TM="" D - .;$O through team position file - .I '$D(TEAM(TM))&(TEAM'=1) Q - .;Q above, not a selected team - .;selected team - .S EN="" - .F S EN=$O(^SCTM(404.57,"C",TM,EN)) Q:EN="" D - ..I '$D(^SCTM(404.57,EN,0)) Q - ..S NODE=$G(^SCTM(404.57,EN,0)) - ..Q:NODE="" - ..;active or inactive position - ..S TMP=$$DATES^SCAPMCU1(404.59,EN,DT) - ..S TPNAME=$P(NODE,U) S:'$L(TPNAME) TPNAME="~~~" - ..S ^TMP("SCRATCH",$J,TPNAME,EN)=NODE - ..I +TMP S ^TMP("SCRATCH",$J,TM,TPNAME,EN)=NODE - ..Q - .Q - S TM="" - F S TM=$O(^TMP("SCRATCH",$J,TM)) Q:TM="" S TPNAME="" D - .F S TPNAME=$O(^TMP("SCRATCH",$J,TM,TPNAME)) Q:TPNAME="" S EN="" D - ..F S EN=$O(^TMP("SCRATCH",$J,TM,TPNAME,EN)) Q:EN="" D - ...S NODE=^TMP("SCRATCH",$J,TM,TPNAME,EN) - ...D KEEP^SCRPITP2(NODE,EN,TM) - ...Q - ..Q - .Q - Q - ; -PRINTIT(STORE,TITL) ; - N INST,EINST,ETEAM,TEM,NEW,PAGE,TNAME,TIEN,EN,SUB,POS,CIEN,INF,ACL - S (INST,EINST)="",STOP=0,(PAGE,NEW)=1 W:$E(IOST)="C" @IOF - D FORHEAD^SCRPITP2 - F S EINST=$O(@STORE@("I",EINST)) Q:EINST=""!(STOP) D - .S INST=$O(@STORE@("I",EINST,"")) - .I INST="" Q - .I STOP Q - .;write team info - .S TNAME="" - .F S TNAME=$O(@STORE@("T",INST,TNAME)) Q:TNAME=""!(STOP) D - ..D:NEW TITLE^SCRPU3(.PAGE,TITL,132) - ..I 'NEW,$E(IOST)'="C" D NEWP1^SCRPU3(.PAGE,TITL,132) - ..I 'NEW,$E(IOST)="C" D HOLD^SCRPU3(.PAGE,TITL,132) - ..W !,$G(@STORE@(INST)),! S NEW="" - ..S TIEN=$O(@STORE@("T",INST,TNAME,"")) - ..I TIEN="" Q - ..F SUB="TI","D" D - ...Q:STOP - ...I '$D(@STORE@(INST,TIEN,SUB)) Q - ...S EN="" - ...F S EN=$O(@STORE@(INST,TIEN,SUB,EN)) Q:EN=""!(STOP) D - ....I IOST'?1"C-".E,$Y>(IOSL-5) D NEWP1^SCRPU3(.PAGE,TITL,132) - ....I IOST?1"C-".E,$Y>(IOSL-5) D HOLD^SCRPU3(.PAGE,TITL,132) - ....I STOP Q - ....I '$D(NEW) W !,$G(@STORE@(INST)),!,$G(@STORE@(INST,TIEN)),! - ....W !,$G(@STORE@(INST,TIEN,SUB,EN)) - ...W ! - ..;write position info - ..S POS="" - ..I $Y(IOSL-5) D NEWP1^SCRPU3(.PAGE,TITL,132) Q:STOP D CONT^SCRPITP2 - ....I IOST?1"C-".E,$Y>(IOSL-5) D HOLD^SCRPU3(.PAGE,TITL,132) Q:STOP D CONT^SCRPITP2 - ....I STOP Q - ...;W !,$G(@STORE@(INST,TIEN,"P",POS)) - ...;W !,$G(@STORE@(INST,TIEN,"P",POS,ACL)) - ...W ! - I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR - Q +SCRPITP ;ALB/CMM - Individual Team Profile ; 29 Jun 99 04:11PM + ;;5.3;Scheduling;**41,52,177**;AUG 13, 1993 + ; + ;Individual Team Profile + ; +PROMPTS ; + ;Prompt for Institution, Team, and Print device + ; + N QTIME,PRNT,VAUTD,VAUTT,Y,NUMBER + K VAUTD,VAUTT,SCUP + S QTIME="" + W ! D INST^SCRPU1 I Y=-1 G ERR + W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR + W !!,"This report requires 132 column output!" + D QUE(.VAUTD,.VAUTT) Q + ; +QUE(INST,TEAM) ;queue report + ;Input Parameters: + ;INST - institutions selected (variable and array) + ;TEAM - teams selected (variable and array) + N ZTSAVE,II + F II="INST","TEAM","INST(","TEAM(" S ZTSAVE(II)="" + W ! D EN^XUTMDEVQ("QENTRY^SCRPITP","Individual Team Profile",.ZTSAVE) + Q + ; +ENTRY2(INST,TEAM,IOP,ZTDTH) ; + ;Second entry point for GUI to use + ;Input Parameters: + ;INST - institutions selected (variable and array) + ;TEAM - teams selected (variable and array) + ;IOP - print device + ;ZTDTH - queue time (optional) + ; + ;validate parameters + I '$D(INST)!'$D(TEAM)!'$D(IOP)!(IOP="") Q + ; + N NUMBER + S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^") + I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2) + I IOST?1"C-".E D QENTRY G RET + I ZTDTH="" S ZTDTH=$H + S ZTRTN="QENTRY^SCRPITP" + S ZTDESC="iIndividual Team Profile",ZTIO=IOP + N II + F II="INST","TEAM","INST(","TEAM(","IOP" S ZTSAVE(II)="" + D ^%ZTLOAD +RET S NUMBER=0 + I $D(ZTSK) S NUMBER=ZTSK + D EXIT1 + Q NUMBER + ; +QENTRY ; + ;driver entry point + S TITL="Individual Team Profile" + S STORE="^TMP("_$J_",""SCRPITP"")" + K @STORE + S @STORE=0 + I TEAM=1 D TALL^SCRPPAT3 S TEAM=0 + D FIND + I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL) + I '$D(NODATA) D PRINTIT(STORE,TITL) + D EXIT2 + Q + ; +ERR ; +EXIT1 ; + K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE + Q + ; +EXIT2 ; + K @STORE + K STOP,STORE,TITL,IOP,TEAM,INST,NODATA + Q + ; +FIND ; + N TM,EN,NODE,TMP,TPNAME + S TM="" K ^TMP("SCRATCH",$J) + F S TM=$O(^SCTM(404.57,"C",TM)) Q:TM="" D + .;$O through team position file + .I '$D(TEAM(TM))&(TEAM'=1) Q + .;Q above, not a selected team + .;selected team + .S EN="" + .F S EN=$O(^SCTM(404.57,"C",TM,EN)) Q:EN="" D + ..I '$D(^SCTM(404.57,EN,0)) Q + ..S NODE=$G(^SCTM(404.57,EN,0)) + ..Q:NODE="" + ..;active or inactive position + ..S TMP=$$DATES^SCAPMCU1(404.59,EN,DT) + ..S TPNAME=$P(NODE,U) S:'$L(TPNAME) TPNAME="~~~" + ..S ^TMP("SCRATCH",$J,TPNAME,EN)=NODE + ..I +TMP S ^TMP("SCRATCH",$J,TM,TPNAME,EN)=NODE + ..Q + .Q + S TM="" + F S TM=$O(^TMP("SCRATCH",$J,TM)) Q:TM="" S TPNAME="" D + .F S TPNAME=$O(^TMP("SCRATCH",$J,TM,TPNAME)) Q:TPNAME="" S EN="" D + ..F S EN=$O(^TMP("SCRATCH",$J,TM,TPNAME,EN)) Q:EN="" D + ...S NODE=^TMP("SCRATCH",$J,TM,TPNAME,EN) + ...D KEEP^SCRPITP2(NODE,EN,TM) + ...Q + ..Q + .Q + Q + ; +PRINTIT(STORE,TITL) ; + N INST,EINST,ETEAM,TEM,NEW,PAGE,TNAME,TIEN,EN,SUB,POS,CIEN,INF + S (INST,EINST)="",STOP=0,(PAGE,NEW)=1 W:$E(IOST)="C" @IOF + D FORHEAD^SCRPITP2 + F S EINST=$O(@STORE@("I",EINST)) Q:EINST=""!(STOP) D + .S INST=$O(@STORE@("I",EINST,"")) + .I INST="" Q + .I STOP Q + .;write team info + .S TNAME="" + .F S TNAME=$O(@STORE@("T",INST,TNAME)) Q:TNAME=""!(STOP) D + ..D:NEW TITLE^SCRPU3(.PAGE,TITL,132) + ..I 'NEW,$E(IOST)'="C" D NEWP1^SCRPU3(.PAGE,TITL,132) + ..I 'NEW,$E(IOST)="C" D HOLD^SCRPU3(.PAGE,TITL,132) + ..W !,$G(@STORE@(INST)),! S NEW="" + ..S TIEN=$O(@STORE@("T",INST,TNAME,"")) + ..I TIEN="" Q + ..F SUB="TI","D" D + ...Q:STOP + ...I '$D(@STORE@(INST,TIEN,SUB)) Q + ...S EN="" + ...F S EN=$O(@STORE@(INST,TIEN,SUB,EN)) Q:EN=""!(STOP) D + ....I IOST'?1"C-".E,$Y>(IOSL-5) D NEWP1^SCRPU3(.PAGE,TITL,132) + ....I IOST?1"C-".E,$Y>(IOSL-5) D HOLD^SCRPU3(.PAGE,TITL,132) + ....I STOP Q + ....I '$D(NEW) W !,$G(@STORE@(INST)),!,$G(@STORE@(INST,TIEN)),! + ....W !,$G(@STORE@(INST,TIEN,SUB,EN)) + ...W ! + ..;write position info + ..S POS="" + ..I $Y(IOSL-5) D NEWP1^SCRPU3(.PAGE,TITL,132) Q:STOP D CONT^SCRPITP2 + ...I IOST?1"C-".E,$Y>(IOSL-5) D HOLD^SCRPU3(.PAGE,TITL,132) Q:STOP D CONT^SCRPITP2 + ...I STOP Q + ...W !,$G(@STORE@(INST,TIEN,"P",POS)) + ..W ! + I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR + Q diff --git a/r/SCHEDULING-SD-SC/SCRPITP2.m b/r/SCHEDULING-SD-SC/SCRPITP2.m index ef6058df..7ec4f78d 100644 --- a/r/SCHEDULING-SD-SC/SCRPITP2.m +++ b/r/SCHEDULING-SD-SC/SCRPITP2.m @@ -1,132 +1,121 @@ -SCRPITP2 ;ALB/CMM - Individual Team Profile Continued ;7/25/99 18:24 - ;;5.3;Scheduling;**41,177,520**;AUG 13, 1993;Build 26 - ; - ;Individual Team Profile - ; -KEEP(TNODE,TPOS,TM,SCEN) ; - ;TNODE - zero node of the team position file entry TPOS - ;TPOS - ien of team position file entry TNODE - ;TM - ien of team - ; - N POS,PPC,CLIEN,PCLIN,MAX,ROL,CIEN,DIV - N SCRDATE,SCI,PROVLIST,SCPROV,SCPTASS,ERR - ; - D TEAM(TM,.DIV) - ; - S POS=$P(TNODE,"^") ;position name - S ROL=$P($G(^SD(403.46,+$P(TNODE,"^",3),0)),"^") ;standard position - S PPC=$S($P(TNODE,"^",4)'=1:"NPC",+$$OKPREC3^SCMCLK(TPOS,DT)>0:" AP",1:"PCP") ;primary care position - S MAX=$P(TNODE,"^",8) - ; - S SCRDATE="SCRDATE",(SCRDATE("BEGIN"),SCRDATE("END"))=DT,SCRDATE("INCL")=0 - S SCI="PROVLIST",SCI=$$PRTP^SCAPMC(TPOS,.SCRDATE,SCI,"ERR",1,0) - S SCPROV=$P($G(PROVLIST(1)),U,2) - S SCPTASS=$$PCPOSCNT^SCAPMCU1(TPOS,DT,0) - ; - ;D FORMAT(POS,PPC,MAX,DIV,TM,TPOS,ROL,SCPROV,SCPTASS) - ; - D SETASCL^SCRPRAC2(TPOS,.CNAME,.CLIEN) - S CNAME=$G(CNAME(0)) - ;S CIEN=+$P(TNODE,"^",9) ;clinic ien ;USING MULTIPLE WITH SD*5.3*520 - ;S PCLIN="" - ;I CIEN>0 S PCLIN=$P($G(^SC(CIEN,0)),"^") ;associated clinic - ; - D FORMAT(POS,PPC,MAX,DIV,TM,TPOS,ROL,CNAME,SCPROV,SCPTASS) - N AC - S AC=0 - F S AC=$O(CNAME(AC)) Q:AC="" D FORMATAC(POS,DIV,TM,TPOS,CNAME(AC)) - K CNAME - Q - ; -TEAM(TM,DIV) ; - ; - N TMN,TNAME,TDIV,TPHONE,TPC,TSERV,STAT,PUR,MAX,CUR - S TMN=$G(^SCTM(404.51,TM,0)) ;zero node of team file - S TNAME=$P(TMN,"^") ;team name - S DIV=+$P(TMN,"^",7) ;division ien - S TDIV=$P($G(^DIC(4,DIV,0)),"^") ;team division - S TPHONE=$P(TMN,"^",2) ;team phone - S TPC=+$P(TMN,"^",5) ;Primary Care Team ien - S TSERV=$P($G(^DIC(49,+$P(TMN,"^",6),0)),"^") ;Service/section - S STAT=$S(+$$ACTTM^SCMCTMU(TM)=1:"ACTIVE",1:"INACTIVE") ;Team status - S PUR=$P($G(^SD(403.47,+$P(TMN,"^",3),0)),"^") - S MAX=$P(TMN,"^",8) - S CUR=$$TEAMCNT^SCAPMCU1(TM,DT) - D TFORMAT(TNAME,DIV,TDIV,TM,TPHONE,TPC,TSERV,STAT,PUR,MAX,CUR) - ; - ;GET TEAM DESCRIPTION (WORD PROCESSING FIELD) - D TDESC(TM,DIV) - Q -TDESC(TEM,DIV) ; - ;gets team description - word processing field - Q:'$O(^SCTM(404.51,TEM,"D",0)) - N EN - S EN=0 - S @STORE@(DIV,TEM,"D",0)="Team Description: " - S @STORE@(DIV,TEM,"D",.5)="" - F S EN=$O(^SCTM(404.51,TEM,"D",EN)) Q:EN="" D - .S @STORE@(DIV,TEM,"D",EN)=$G(^SCTM(404.51,TEM,"D",EN,0)) - Q - ; -TFORMAT(TNAME,DIV,TDIV,TM,TPHONE,TPC,TSERV,STAT,PUR,MAX,CUR) ; - ; - I TNAME="" S TNAME="[BAD DATA]" - I TDIV="" S TDIV="[BAD DATA]" - S @STORE@("I",TDIV,DIV)="" - S @STORE@("T",DIV,TNAME,TM)="" - S @STORE@(DIV)="Division: "_TDIV - ; - S @STORE@(DIV,TM,"TI",1)="Team Name: "_TNAME - S $E(@STORE@(DIV,TM,"TI",1),44)="Service/Section: "_$E(TSERV,1,30) - S $E(@STORE@(DIV,TM,"TI",1),(120-$L(TPHONE)))="Team Phone: "_TPHONE - S @STORE@(DIV,TM,"TI",2)="" - S @STORE@(DIV,TM,"TI",3)="Team Settings:" - S @STORE@(DIV,TM,"TI",4)="" - S @STORE@(DIV,TM,"TI",5)="Status: "_STAT - S $E(@STORE@(DIV,TM,"TI",5),19)="Maximum Patients: "_MAX - S $E(@STORE@(DIV,TM,"TI",5),47)="Unique Patients Assigned: "_CUR - S $E(@STORE@(DIV,TM,"TI",5),83)="Purpose: "_$E(PUR,1,35) - S @STORE@(DIV,TM,"TI",6)="" - I CUR+1>MAX S @STORE@(DIV,TM,"TI",7)="This team is not accepting patients." - I CUR1:" AP",1:"PCP") ;primary care position + S MAX=$P(TNODE,"^",8) + ; + S SCRDATE="SCRDATE",(SCRDATE("BEGIN"),SCRDATE("END"))=DT,SCRDATE("INCL")=0 + S SCI="PROVLIST",SCI=$$PRTP^SCAPMC(TPOS,.SCRDATE,SCI,"ERR",1,0) + S SCPROV=$P($G(PROVLIST(1)),U,2) + S SCPTASS=$$PCPOSCNT^SCAPMCU1(TPOS,DT,0) + ; + S CIEN=+$P(TNODE,"^",9) ;clinic ien + S PCLIN="" + I CIEN>0 S PCLIN=$P($G(^SC(CIEN,0)),"^") ;associated clinic + ; + D FORMAT(POS,PPC,MAX,DIV,TM,TPOS,ROL,PCLIN,SCPROV,SCPTASS) + ; + Q + ; +TEAM(TM,DIV) ; + ; + N TMN,TNAME,TDIV,TPHONE,TPC,TSERV,STAT,PUR,MAX,CUR + S TMN=$G(^SCTM(404.51,TM,0)) ;zero node of team file + S TNAME=$P(TMN,"^") ;team name + S DIV=+$P(TMN,"^",7) ;division ien + S TDIV=$P($G(^DIC(4,DIV,0)),"^") ;team division + S TPHONE=$P(TMN,"^",2) ;team phone + S TPC=+$P(TMN,"^",5) ;Primary Care Team ien + S TSERV=$P($G(^DIC(49,+$P(TMN,"^",6),0)),"^") ;Service/section + S STAT=$S(+$$ACTTM^SCMCTMU(TM)=1:"ACTIVE",1:"INACTIVE") ;Team status + S PUR=$P($G(^SD(403.47,+$P(TMN,"^",3),0)),"^") + S MAX=$P(TMN,"^",8) + S CUR=$$TEAMCNT^SCAPMCU1(TM,DT) + D TFORMAT(TNAME,DIV,TDIV,TM,TPHONE,TPC,TSERV,STAT,PUR,MAX,CUR) + ; + ;GET TEAM DESCRIPTION (WORD PROCESSING FIELD) + D TDESC(TM,DIV) + Q +TDESC(TEM,DIV) ; + ;gets team description - word processing field + Q:'$O(^SCTM(404.51,TEM,"D",0)) + N EN + S EN=0 + S @STORE@(DIV,TEM,"D",0)="Team Description: " + S @STORE@(DIV,TEM,"D",.5)="" + F S EN=$O(^SCTM(404.51,TEM,"D",EN)) Q:EN="" D + .S @STORE@(DIV,TEM,"D",EN)=$G(^SCTM(404.51,TEM,"D",EN,0)) + Q + ; +TFORMAT(TNAME,DIV,TDIV,TM,TPHONE,TPC,TSERV,STAT,PUR,MAX,CUR) ; + ; + I TNAME="" S TNAME="[BAD DATA]" + I TDIV="" S TDIV="[BAD DATA]" + S @STORE@("I",TDIV,DIV)="" + S @STORE@("T",DIV,TNAME,TM)="" + S @STORE@(DIV)="Division: "_TDIV + ; + S @STORE@(DIV,TM,"TI",1)="Team Name: "_TNAME + S $E(@STORE@(DIV,TM,"TI",1),44)="Service/Section: "_$E(TSERV,1,30) + S $E(@STORE@(DIV,TM,"TI",1),(120-$L(TPHONE)))="Team Phone: "_TPHONE + S @STORE@(DIV,TM,"TI",2)="" + S @STORE@(DIV,TM,"TI",3)="Team Settings:" + S @STORE@(DIV,TM,"TI",4)="" + S @STORE@(DIV,TM,"TI",5)="Status: "_STAT + S $E(@STORE@(DIV,TM,"TI",5),19)="Maximum Patients: "_MAX + S $E(@STORE@(DIV,TM,"TI",5),47)="Unique Patients Assigned: "_CUR + S $E(@STORE@(DIV,TM,"TI",5),83)="Purpose: "_$E(PUR,1,35) + S @STORE@(DIV,TM,"TI",6)="" + I CUR+1>MAX S @STORE@(DIV,TM,"TI",7)="This team is not accepting patients." + I CURDT S CNAME=$P($G(^SC(CLIEN,0)),"^") ;clinic name - Q - ; -FORMAT(CNAME,PINF,PC,TIEN,TNAME,PRAC,PNAME,POSN,TPI,PRCP) ; format data for display - ;CNAME - clinic name - ;PINF - patient/clinic data - ;PC - primary care 1/0 - ;TIEN - team file ien (#404.51) - ;TNAME - team name - ;PRAC - practitioner ien (#200) - ;PNAME - practitioner name - ;POSN - position name - ;TPI - team position ien (#404.57) - ;PRCP - preceptor name - ; - N IIEN,INAME,ERR - S ERR=$$SETUP^SCRPPAT3(.IIEN,.INAME,TIEN,TNAME,PRAC,PNAME,POSN,TPI,PRCP) - I ERR Q - ; - I SORT=1 D STOR(IIEN,TIEN,PRAC,PINF,PNAME,TNAME,TPI) ;sort division,team,practitioner - I SORT=2 D STOR(IIEN,PRAC,TIEN,PINF,PNAME,TNAME,TPI) ;sort division,practitioner,team - I SORT=3 D STOR(1,PRAC,1,PINF,PNAME,"T3",TPI) - Q - ; -FORMATAC(CNAME,PINF,PC,TIEN,TNAME,PRAC,PNAME,POSN,TPI,PRCP) ; format data for display - ;CNAME - clinic name - ;PINF - patient/clinic data - ;PC - primary care 1/0 - ;TIEN - team file ien (#404.51) - ;TNAME - team name - ;PRAC - practitioner ien (#200) - ;PNAME - practitioner name - ;POSN - position name - ;TPI - team position ien (#404.57) - ;PRCP - preceptor name - ; - N IIEN,INAME,ERR - S ERR=$$SETUP^SCRPPAT3(.IIEN,.INAME,TIEN,TNAME,PRAC,PNAME,POSN,TPI,PRCP) - I ERR Q - ; - I SORT=1 D STORA(IIEN,TIEN,PRAC,PINF,PNAME,TNAME,TPI,SCCNT) ;sort division,team,practitioner - I SORT=2 D STORA(IIEN,PRAC,TIEN,PINF,PNAME,TNAME,TPI,SCCNT) ;sort division,practitioner,team - I SORT=3 D STORA(1,PRAC,1,PINF,PNAME,"T3",TPI,SCCNT) - Q - ; -STOR(IIEN,SEC,TRD,PINF,PNAME,TNAME,TPI,SCCNT) ; - ;IIEN - ien institution - ;SEC - second sort subscript, IEN team or IEN practitioner - ;TRD - third sort subscript, IEN team or IEN practitioner - ;PINF - patient/clinic info - ;PNAME - practitioner name - ;TNAME - team name - ;TPI - team position ien - ; - N PIEN,PTNAME,PID - S PIEN=+$P(PINF,"^") ;patient ien - S PTNAME=$E($P(PINF,"^",2),1,10) ;patient name - Q:$D(@STORE@("PT",IIEN,SEC,TRD,TPI,PTNAME,PIEN)) - S @STORE@("PT",IIEN,SEC,TRD,TPI,PTNAME,PIEN)="" - I 'SUMM,'$D(@STORE@("PTOT",IIEN,SEC,TRD,PIEN)) D - .;count each unique patient for any given practitioner for grand total - .S @STORE@("PTOT",IIEN,SEC,TRD,PIEN)="" - .S @STORE@("TOTAL",IIEN,PRAC,0)=$G(@STORE@("TOTAL",IIEN,PRAC,0))+1 ;patient count by practitioner - ; - S @STORE@("TOTAL",IIEN,PRAC,$S(SORT=3:1,1:TIEN),TPI)=$G(@STORE@("TOTAL",IIEN,PRAC,$S(SORT=3:1,1:TIEN),TPI))+1 ;patient count by practitioner and team - Q:SUMM - ; - S @STORE@(IIEN,SEC,TRD,TPI,PIEN)=PTNAME - S PID=$P(PINF,"^",3),PID=$TR(PID,"-","") - S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),13)=PID ;ssn - S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),25)=$P(PINF,"^",4) ;means test status - S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),31)=$P(PINF,"^",5) ;eligibility - ;Removed by patch 174 - ;S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),40)=$P(PINF,"^",6) ;patient status - S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),42)=$P(PINF,"^",8) ;last appt - S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),54)=$P(PINF,"^",9) ;nxt appt - S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),66)=$E(CNAME,1,15) ;clinic - Q -STORA(IIEN,SEC,TRD,PINF,PNAME,TNAME,TPI,SCCNT) ; - I '$D(@STORE@(IIEN,SEC,TRD,TPI,PIEN,SCCNT)) D - .S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN,SCCNT),42)=$P(PINF,"^",8) ;last appt - .S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN,SCCNT),54)=$P(PINF,"^",9) ;nxt appt - .S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN,SCCNT),66)=$E(CNAME,1,15) ;clinic - .Q - Q +SCRPPAT2 ;ALB/CMM - Practitioner's Patients ; 12/12/00 3:46pm + ;;5.3;Scheduling;**41,48,174,181,177,231,433,297**;AUG 13, 1993 + ; + ;Listing of Practitioner's Patients + ; +DRIVE ; + ;driver module + N PRAC,INF,ARRY,ERROR,NXT,OKAY,PIEN,TPRC + S ARRY="^TMP(""SCARRAY"","_$J_")",ERROR="ERR" + S TPRC="^TMP(""SCRP"",$J,""PRACT"")" M @TPRC=PRACT + K @ARRY,@ERROR,PRACT + I @TPRC=1 D ALL^SCRPPAT3 ;all practitioners selected + S NXT=0 + F S NXT=$O(@TPRC@(NXT)) Q:NXT=""!(NXT'?.N) D + .I @TPRC=0 S PIEN=NXT + .I @TPRC=1 S PIEN=$P(@TPRC@(NXT),"^") + .K @ARRY,@ERROR + .S OKAY=$$PTPR^SCAPMC14(PIEN,"","","",ARRY,ERROR) ;patients for practitioner + .I '+OKAY Q + .D LOOPPT(ARRY,PIEN) ;loop through patients for practitioner + K @ARRY,@ERROR,@TPRC + K:SUMM @STORE@("PT") + Q + ; +LOOPPT(ARY,PRAC) ;loop through patients for practitioner + ;ARY - array of patients for selected practitioner + ;PRAC - practitioner ien + N NXT,PIEN,TPIEN,PNAME,TPIEN,NODE,PTP,TPI,TPN,CLIEN,CNAME,PTA,PTAN,TIEN + N PC,TNODE,TNAME,PINF,POSN,PRCP + S NXT=0 + F S NXT=$O(@ARY@(NXT)) Q:NXT=""!(NXT'?.N) D + .S NODE=$G(@ARY@(NXT)) + .Q:NODE="" + .S PIEN=+$P(NODE,"^") ;ien of patient file entry + .S TPIEN=+$P(NODE,"^",3) ;ien of patient team position assignment + .S PTP=$G(^SCPT(404.43,TPIEN,0)) + .Q:PTP="" + .S PTA=+$P(PTP,"^") ;patient team assignment ien (404.42) + .S PTAN=$G(^SCPT(404.42,PTA,0)) + .Q:PTAN="" + .S TIEN=+$P(PTAN,"^",3) ;team file ien (404.51) + .I $G(TEAM)'=1,'$D(TEAM(TIEN)) Q ;not a selected team + .S TNODE=$G(^SCTM(404.51,TIEN,0)) + .Q:TNODE="" I $G(INST)'=1,'$D(INST(+$P(TNODE,U,7))) Q + .S TNAME=$P(TNODE,"^") ;team name + .S TPI=+$P(PTP,"^",2) ;Team Position file ien (404.57) + .S TPN=$G(^SCTM(404.57,TPI,0)) + .Q:TPN="" + .I $G(ROLE)'=1,'$D(ROLE(+$P(TPN,U,3))) Q ;not a selected role + .S POSN=$P(TPN,"^") ;position name + .S CLIEN=+$P(TPN,"^",9) ;associated clinic ien + .;commented next line off - clinic enrollment no longer needed SD*5.3*433 + .;D CECHK(CLIEN,.CNAME,PIEN) ;is patient enrolled in associated clinic? + .S CNAME=$P($G(^SC(CLIEN,0)),"^") ; SD*5.3*433 remove enroll check + .S PC=$S($P(PTP,"^",5)=0:0,1:1) ;primary care position 1or2-yes/0-no + .S PNAME=$P($G(^VA(200,+PRAC,0)),"^") ;practitioner name + .Q:PNAME="" + .S PRCP=$P($$OKPREC2^SCMCLK(TPI,DT),U,2) + .S PINF=PIEN_"^"_$$PDATA^SCRPEC(PIEN,CLIEN,1) + .;$$PDATA returns pt name,pid,mt,pelig,status,status date,last appt,nxt appt + .D FORMAT(CNAME,PINF,PC,TIEN,TNAME,PRAC,PNAME,POSN,TPI,PRCP) ;formats data for display + Q + ; +CECHK(CLIEN,CNAME,PIEN) ; + ;CLIEN - clinic ien + ;CNAME - clinic name returned if patient is enrolled in clien clinic + ;PIEN - patien ien + ; + N EN,NODE + S CNAME="" + I $D(^DPT(PIEN,"DE","B",CLIEN)) D + .;enrolled at one time, check if discharged + .S EN=$O(^DPT(PIEN,"DE","B",CLIEN,"")) + .S NODE=$G(^DPT(PIEN,"DE",EN,0)) + .Q:NODE="" + .I $P(NODE,"^",3)="" S CNAME=$P($G(^SC(CLIEN,0)),"^") ;clinic name + .I $P(NODE,"^",3)'="",$P(NODE,"^",3)>DT S CNAME=$P($G(^SC(CLIEN,0)),"^") ;clinic name + Q + ; +FORMAT(CNAME,PINF,PC,TIEN,TNAME,PRAC,PNAME,POSN,TPI,PRCP) ; format data for display + ;CNAME - clinic name + ;PINF - patient/clinic data + ;PC - primary care 1/0 + ;TIEN - team file ien (#404.51) + ;TNAME - team name + ;PRAC - practitioner ien (#200) + ;PNAME - practitioner name + ;POSN - position name + ;TPI - team position ien (#404.57) + ;PRCP - preceptor name + ; + N IIEN,INAME,ERR + S ERR=$$SETUP^SCRPPAT3(.IIEN,.INAME,TIEN,TNAME,PRAC,PNAME,POSN,TPI,PRCP) + I ERR Q + ; + I SORT=1 D STOR(IIEN,TIEN,PRAC,PINF,PNAME,TNAME,TPI) ;sort division,team,practitioner + I SORT=2 D STOR(IIEN,PRAC,TIEN,PINF,PNAME,TNAME,TPI) ;sort division,practitioner,team + I SORT=3 D STOR(1,PRAC,1,PINF,PNAME,"T3",TPI) + Q + ; +STOR(IIEN,SEC,TRD,PINF,PNAME,TNAME,TPI) ; + ;IIEN - ien institution + ;SEC - second sort subscript, IEN team or IEN practitioner + ;TRD - third sort subscript, IEN team or IEN practitioner + ;PINF - patient/clinic info + ;PNAME - practitioner name + ;TNAME - team name + ;TPI - team position ien + ; + N PIEN,PTNAME,PID + S PIEN=+$P(PINF,"^") ;patient ien + S PTNAME=$E($P(PINF,"^",2),1,15) ;patient name + Q:$D(@STORE@("PT",IIEN,SEC,TRD,TPI,PTNAME,PIEN)) + S @STORE@("PT",IIEN,SEC,TRD,TPI,PTNAME,PIEN)="" + ; + I 'SUMM,'$D(@STORE@("PTOT",IIEN,SEC,TRD,PIEN)) D + .;count each unique patient for any given practitioner for grand total + .S @STORE@("PTOT",IIEN,SEC,TRD,PIEN)="" + .S @STORE@("TOTAL",IIEN,PRAC,0)=$G(@STORE@("TOTAL",IIEN,PRAC,0))+1 ;patient count by practitioner + ; + S @STORE@("TOTAL",IIEN,PRAC,$S(SORT=3:1,1:TIEN),TPI)=$G(@STORE@("TOTAL",IIEN,PRAC,$S(SORT=3:1,1:TIEN),TPI))+1 ;patient count by practitioner and team + Q:SUMM + ; + S @STORE@(IIEN,SEC,TRD,TPI,PIEN)=PTNAME + S PID=$P(PINF,"^",3),PID=$TR(PID,"-","") + S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),18)=$E(PID,6,10) ;last 4 pid - 5 places is for any pseudo + S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),25)=$P(PINF,"^",4) ;means test status + S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),31)=$P(PINF,"^",5) ;eligibility + ;Removed by patch 174 + ;S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),40)=$P(PINF,"^",6) ;patient status + S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),42)=$P(PINF,"^",8) ;last appt + S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),54)=$P(PINF,"^",9) ;nxt appt + S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),66)=$E(CNAME,1,15) ;clinic + Q diff --git a/r/SCHEDULING-SD-SC/SCRPPAT3.m b/r/SCHEDULING-SD-SC/SCRPPAT3.m index 719ab3c8..132e052a 100644 --- a/r/SCHEDULING-SD-SC/SCRPPAT3.m +++ b/r/SCHEDULING-SD-SC/SCRPPAT3.m @@ -1,146 +1,139 @@ -SCRPPAT3 ;ALB/CMM - Practitioner's Patients ; 8/30/99 3:14pm - ;;5.3;Scheduling;**41,52,148,174,181,177,297,526,520**;AUG 13, 1993;Build 26 - ; - ;Listing of Practitioner's Patients - ; -PAT(INS,SEC,TRD,SEC3,ST3,ST4,POS) ; - ;writes patients for position/practitioner - N PTN,PT,FIRST - S PTN="",FIRST=1 - I SUMM D TOTAL1^SCRPPAT3(INS,SEC,TRD,POS) Q ;Summary only - F S PTN=$O(@STORE@("PT",INS,SEC,TRD,POS,PTN)) Q:PTN=""!(STOP) D - .S PT=0 - .F S PT=$O(@STORE@("PT",INS,SEC,TRD,POS,PTN,PT)) Q:'PT!(STOP) D - ..I FIRST D HEADER S FIRST=0 - ..W !,$G(@STORE@(INS,SEC,TRD,POS,PT)) ;print patient detail line - ..;I FIRST D HEADER S FIRST=0 - ..N SCCN - ..S SCCN="" - ..F S SCCN=$O(@STORE@(INS,SEC,TRD,POS,PT,SCCN)) Q:SCCN="" D - ...W !,$G(@STORE@(INS,SEC,TRD,POS,PT,SCCN)) ;print patient detail line - ...I (IOST'?1"C-".E),$Y>(IOSL-5) S MORE=0 D NEWP1^SCRPU3(.PAGE,TITL) D:'STOP HEAD2(INS,SEC,TRD,SEC3,ST3,ST4,POS) D:(('FIRST&'STOP)!($G(SORT)=3)) HEADER - ...I (IOST?1"C-".E),$Y>(IOSL-5) S MORE=0 D HOLD^SCRPU3(.PAGE,TITL) D:'STOP HEAD2(INS,SEC,TRD,SEC3,ST3,ST4,POS) D:'FIRST&'STOP HEADER - ...Q:STOP - ...;I FIRST D HEADER S FIRST=0 - ...Q - ..Q - .Q - Q - ; -SPRINT(STORE,IOP,TITL,SORT) ; Summary Print Only - ;STORE - global location of data - ;IOP - device to print to - ;TITL - title of report - ;SORT - sort order 1-div,team,pract/2-div,pract,team - ; - N PAGE - S PAGE=1,STOP=0 - D OPEN^SCRPU3 - Q:$G(POP) - D TITLE^SCRPU3(.PAGE,TITL) - D CLOSE^SCRPU3 - Q - ; -TOTAL1(INS,SEC,TRD,POS) ; - ;print team/practitioner total - N TEM,PRC - I SORT=1 S TEM=SEC,PRC=TRD - I SORT=2!(SORT=3) S TEM=TRD,PRC=SEC - W !!,$G(@STORE@("TH",INS,PRC,TEM,POS)),$G(@STORE@("TOTAL",INS,PRC,TEM,POS)) - Q - ; -HEAD2(INS,SEC,TRD,SEC3,ST3,ST4,POS) ; - I (SEC3="""TN""")&($D(@ST4@(INS,TRD,SEC))) D - .W !,$G(@ST3@(INS,SEC)) ;write team (sort 1) - .W !,$G(@STORE@(INS)) - .W !,$G(@ST4@(INS,TRD,SEC,POS)) ;write practitioner (sort 2) - .I $L($G(@STORE@("PN",INS,TRD,SEC,POS,"PRCP"))) W !,@STORE@("PN",INS,TRD,SEC,POS,"PRCP") - .W ! - I (SEC3="""PN""")&($D(@ST3@(INS,SEC,TRD))) D - .W !,$G(@ST3@(INS,SEC,TRD,POS)) ;write practitioner (sort 1) - .I $G(SORT)'=3 I $L($G(@STORE@("PN",INS,SEC,TRD,POS,"PRCP"))) W !,@STORE@("PN",INS,SEC,TRD,POS,"PRCP") - .I $G(SORT)'=3 W !,$G(@ST4@(INS,TRD)) ;write team (sort 2) - .W !,$G(@STORE@(INS)) - Q - ; -HEADER ; - Q:$G(MORE) - I SORT=3 S MORE=1 - N NXT - F NXT="H1","H2","H3" W !,$G(@STORE@(NXT)) - W ! - Q - ; -SHEAD ; - S @STORE@("H2")="Pt Name" - S $E(@STORE@("H2"),15)="Pt ID" - S $E(@STORE@("H1"),25)="M.T." - S $E(@STORE@("H2"),25)="Stat" - S $E(@STORE@("H1"),31)="Prim" - S $E(@STORE@("H2"),31)="Elig" - ;Removed by patch 174 - ;S $E(@STORE@("H1"),39)="Pat" - ;S $E(@STORE@("H2"),39)="Stat" - S $E(@STORE@("H1"),42)="Last" - S $E(@STORE@("H2"),42)="Appt" - S $E(@STORE@("H1"),54)="Next" - S $E(@STORE@("H2"),54)="Appt" - S $E(@STORE@("H2"),66)="Clinic" - S $P(@STORE@("H3"),"=",81)="" - Q -ALL ; - ;get all practitioners for all teams selected - I TEAM=1 D TALL ;all teams selected - N TIEN,OKAY,XLIST,YLIST,SCTP,SCI,SCDT - S TIEN="" - F S TIEN=$O(TEAM(TIEN)) Q:TIEN=""!(TIEN'?.N) D - .I $D(TEAM(TIEN)) D - ..K XLIST - ..S OKAY=$$TPTM^SCAPMC(TIEN,"","","","XLIST","ERROR") - ..S SCTP=0 F S SCTP=$O(XLIST("SCTP",TIEN,SCTP)) Q:'SCTP D - ...K YLIST S SCDT="SCDT",(SCDT("BEGIN"),SCDT("END"))=DT,SCDT("INCL")=0 - ...S OKAY=$$PRTP^SCAPMC(SCTP,.SCDT,"YLIST","ERROR",1,0) - ...S SCI=0 F S SCI=$O(YLIST(SCI)) Q:'SCI D - ....S @TPRC@(0)=$G(@TPRC@(0))+1 - ....S @TPRC@(@TPRC@(0))=YLIST(SCI) - Q - ; -TALL ; - ;get all active team for divisions selected - N NXT,IIEN,NODE - S NXT=0,IIEN="" - ;$O through team file and find all active teams for selected divisions - F S IIEN=$O(^SCTM(404.51,"AINST",IIEN)) Q:IIEN="" D - .I INST=1!$D(INST(IIEN)) D - ..S TIEN=0 - ..F S TIEN=$O(^SCTM(404.51,"AINST",IIEN,TIEN)) Q:TIEN="" D - ...I $$ACTTM^SCMCTMU(TIEN) S TEAM(TIEN)="" - Q - ; -SETUP(IIEN,INAME,TIEN,TNAME,PRAC,PNAME,POSN,TPI,PRCP) ; - ;setup data - S IIEN=+$P($G(^SCTM(404.51,TIEN,0)),"^",7) ;institution ien - S INAME=$P($G(^DIC(4,IIEN,0)),"^") ;institution name - I INAME="" S INAME="[BAD DATA]" - ; - I PNAME="" S PNAME="[BAD DATA]" - I TNAME="" S TNAME="[BAD DATA]" - I $G(SORT)=3 S IIEN=1,TIEN=1 - I '$D(@STORE@("PN",IIEN,PRAC,TIEN,TPI)) S @STORE@("PN",IIEN,PRAC,TIEN,TPI)="Practitioner: "_PNAME_$S(SORT=3:"",1:" ("_POSN_")") - I $L(PRCP) S @STORE@("PN",IIEN,PRAC,TIEN,TPI,"PRCP")=" Preceptor: "_PRCP - I '$D(@STORE@("TN",IIEN,$S($G(SORT)=3:1,1:TIEN))) S @STORE@("TN",IIEN,$S($G(SORT)=3:1,1:TIEN))=" Team: "_TNAME - ; - I '$D(@STORE@("I",$S($G(SORT)=3:"S3",1:INAME),IIEN)) S @STORE@("I",$S($G(SORT)=3:"S3",1:INAME),IIEN)="",@STORE@(IIEN)=$S(SORT=3:"",1:" Division: "_INAME) - S @STORE@("T",IIEN,$S($G(SORT)=3:"T3",1:TNAME),$S($G(SORT)=3:1,1:TIEN))="" - I '$D(@STORE@("P",IIEN,PNAME,PRAC,TPI)) S @STORE@("P",IIEN,PNAME,PRAC,TPI)="" - I '$D(@STORE@("TOTAL",IIEN,PRAC,0)) S @STORE@("TOTAL",IIEN,PRAC,0)=0 - I '$D(@STORE@("TOTAL",IIEN,PRAC,TIEN)) S @STORE@("TOTAL",IIEN,PRAC,TIEN)=0 - ; - S @STORE@("TH",IIEN,PRAC)="Patient Count for "_PNAME_": " - S @STORE@("TH",IIEN,PRAC,TIEN,TPI)="Patient Count for "_PNAME_": " - N SCX - S SCX=$E(PNAME,1,22),$E(SCX,25)=$E(POSN,1,22),$E(SCX,49)=$E(TNAME,1,22) - S @STORE@("SUM0",IIEN,PRAC,TIEN,TPI)=SCX - ; - S @STORE@("TH",IIEN)="** Note: Patient Panel Count is a count of unique patients for each practitioner" - Q 0 +SCRPPAT3 ;ALB/CMM - Practitioner's Patients ; 8/30/99 3:14pm + ;;5.3;Scheduling;**41,52,148,174,181,177,297**;AUG 13, 1993 + ; + ;Listing of Practitioner's Patients + ; +PAT(INS,SEC,TRD,SEC3,ST3,ST4,POS) ; + ;writes patients for position/practitioner + N PTN,PT,FIRST + S PTN="",FIRST=1 + I SUMM D TOTAL1^SCRPPAT3(INS,SEC,TRD,POS) Q ;Summary only + F S PTN=$O(@STORE@("PT",INS,SEC,TRD,POS,PTN)) Q:PTN=""!(STOP) D + .S PT=0 + .F S PT=$O(@STORE@("PT",INS,SEC,TRD,POS,PTN,PT)) Q:'PT!(STOP) D + ..I (IOST'?1"C-".E),$Y>(IOSL-5) S MORE=0 D NEWP1^SCRPU3(.PAGE,TITL) D:'STOP HEAD2(INS,SEC,TRD,SEC3,ST3,ST4,POS) D:(('FIRST&'STOP)!($G(SORT)=3)) HEADER + ..I (IOST?1"C-".E),$Y>(IOSL-5) S MORE=0 D HOLD^SCRPU3(.PAGE,TITL) D:'STOP HEAD2(INS,SEC,TRD,SEC3,ST3,ST4,POS) D:'FIRST&'STOP HEADER + ..Q:STOP + ..I FIRST D HEADER S FIRST=0 + ..W !,$G(@STORE@(INS,SEC,TRD,POS,PT)) ;print patient detail line + ..Q + .Q + Q + ; +SPRINT(STORE,IOP,TITL,SORT) ; Summary Print Only + ;STORE - global location of data + ;IOP - device to print to + ;TITL - title of report + ;SORT - sort order 1-div,team,pract/2-div,pract,team + ; + N PAGE + S PAGE=1,STOP=0 + D OPEN^SCRPU3 + Q:$G(POP) + D TITLE^SCRPU3(.PAGE,TITL) + D CLOSE^SCRPU3 + Q + ; +TOTAL1(INS,SEC,TRD,POS) ; + ;print team/practitioner total + N TEM,PRC + I SORT=1 S TEM=SEC,PRC=TRD + I SORT=2!(SORT=3) S TEM=TRD,PRC=SEC + W !!,$G(@STORE@("TH",INS,PRC,TEM,POS)),$G(@STORE@("TOTAL",INS,PRC,TEM,POS)) + Q + ; +HEAD2(INS,SEC,TRD,SEC3,ST3,ST4,POS) ; + I (SEC3="""TN""")&($D(@ST4@(INS,TRD,SEC))) D + .W !,$G(@ST3@(INS,SEC)) ;write team (sort 1) + .W !,$G(@STORE@(INS)) + .W !,$G(@ST4@(INS,TRD,SEC,POS)) ;write practitioner (sort 2) + .I $L($G(@STORE@("PN",INS,TRD,SEC,POS,"PRCP"))) W !,@STORE@("PN",INS,TRD,SEC,POS,"PRCP") + .W ! + I (SEC3="""PN""")&($D(@ST3@(INS,SEC,TRD))) D + .W !,$G(@ST3@(INS,SEC,TRD,POS)) ;write practitioner (sort 1) + .I $G(SORT)'=3 I $L($G(@STORE@("PN",INS,SEC,TRD,POS,"PRCP"))) W !,@STORE@("PN",INS,SEC,TRD,POS,"PRCP") + .I $G(SORT)'=3 W !,$G(@ST4@(INS,TRD)) ;write team (sort 2) + .W !,$G(@STORE@(INS)) + Q + ; +HEADER ; + Q:$G(MORE) + I SORT=3 S MORE=1 + N NXT + F NXT="H1","H2","H3" W !,$G(@STORE@(NXT)) + W ! + Q + ; +SHEAD ; + S @STORE@("H2")="Pt Name" + S $E(@STORE@("H2"),18)="Pt ID" + S $E(@STORE@("H1"),25)="M.T." + S $E(@STORE@("H2"),25)="Stat" + S $E(@STORE@("H1"),31)="Prim" + S $E(@STORE@("H2"),31)="Elig" + ;Removed by patch 174 + ;S $E(@STORE@("H1"),39)="Pat" + ;S $E(@STORE@("H2"),39)="Stat" + S $E(@STORE@("H1"),42)="Last" + S $E(@STORE@("H2"),42)="Appt" + S $E(@STORE@("H1"),54)="Next" + S $E(@STORE@("H2"),54)="Appt" + S $E(@STORE@("H2"),66)="Clinic" + S $P(@STORE@("H3"),"=",81)="" + Q +ALL ; + ;get all practitioners for all teams selected + I TEAM=1 D TALL ;all teams selected + N TIEN,OKAY,XLIST,YLIST,SCTP,SCI,SCDT + S TIEN="" + F S TIEN=$O(TEAM(TIEN)) Q:TIEN=""!(TIEN'?.N) D + .I $D(TEAM(TIEN)) D + ..K XLIST + ..S OKAY=$$TPTM^SCAPMC(TIEN,"","","","XLIST","ERROR") + ..S SCTP=0 F S SCTP=$O(XLIST("SCTP",TIEN,SCTP)) Q:'SCTP D + ...K YLIST S SCDT="SCDT",(SCDT("BEGIN"),SCDT("END"))=DT,SCDT("INCL")=0 + ...S OKAY=$$PRTP^SCAPMC(SCTP,.SCDT,"YLIST","ERROR",1,0) + ...S SCI=0 F S SCI=$O(YLIST(SCI)) Q:'SCI D + ....S @TPRC@(0)=$G(@TPRC@(0))+1 + ....S @TPRC@(@TPRC@(0))=YLIST(SCI) + Q + ; +TALL ; + ;get all active team for divisions selected + N NXT,IIEN,NODE + S NXT=0,IIEN="" + ;$O through team file and find all active teams for selected divisions + F S IIEN=$O(^SCTM(404.51,"AINST",IIEN)) Q:IIEN="" D + .I INST=1!$D(INST(IIEN)) D + ..S TIEN=0 + ..F S TIEN=$O(^SCTM(404.51,"AINST",IIEN,TIEN)) Q:TIEN="" D + ...I $$ACTTM^SCMCTMU(TIEN) S TEAM(TIEN)="" + Q + ; +SETUP(IIEN,INAME,TIEN,TNAME,PRAC,PNAME,POSN,TPI,PRCP) ; + ;setup data + S IIEN=+$P($G(^SCTM(404.51,TIEN,0)),"^",7) ;institution ien + S INAME=$P($G(^DIC(4,IIEN,0)),"^") ;institution name + I INAME="" S INAME="[BAD DATA]" + ; + I PNAME="" S PNAME="[BAD DATA]" + I TNAME="" S TNAME="[BAD DATA]" + I $G(SORT)=3 S IIEN=1,TIEN=1 + I '$D(@STORE@("PN",IIEN,PRAC,TIEN,TPI)) S @STORE@("PN",IIEN,PRAC,TIEN,TPI)="Practitioner: "_PNAME_$S(SORT=3:"",1:" ("_POSN_")") + I $L(PRCP) S @STORE@("PN",IIEN,PRAC,TIEN,TPI,"PRCP")=" Preceptor: "_PRCP + I '$D(@STORE@("TN",IIEN,$S($G(SORT)=3:1,1:TIEN))) S @STORE@("TN",IIEN,$S($G(SORT)=3:1,1:TIEN))=" Team: "_TNAME + ; + I '$D(@STORE@("I",$S($G(SORT)=3:"S3",1:INAME),IIEN)) S @STORE@("I",$S($G(SORT)=3:"S3",1:INAME),IIEN)="",@STORE@(IIEN)=$S(SORT=3:"",1:" Division: "_INAME) + S @STORE@("T",IIEN,$S($G(SORT)=3:"T3",1:TNAME),$S($G(SORT)=3:1,1:TIEN))="" + I '$D(@STORE@("P",IIEN,PNAME,PRAC,TPI)) S @STORE@("P",IIEN,PNAME,PRAC,TPI)="" + I '$D(@STORE@("TOTAL",IIEN,PRAC,0)) S @STORE@("TOTAL",IIEN,PRAC,0)=0 + I '$D(@STORE@("TOTAL",IIEN,PRAC,TIEN)) S @STORE@("TOTAL",IIEN,PRAC,TIEN)=0 + ; + S @STORE@("TH",IIEN,PRAC)="Patient Count for "_PNAME_": " + S @STORE@("TH",IIEN,PRAC,TIEN,TPI)="Patient Count for "_PNAME_": " + N SCX + S SCX=$E(PNAME,1,22),$E(SCX,25)=$E(POSN,1,22),$E(SCX,49)=$E(TNAME,1,22) + S @STORE@("SUM0",IIEN,PRAC,TIEN,TPI)=SCX + ; + S @STORE@("TH",IIEN)="** Note: Patient Panel Count is a count of unique patients for each practitioner" + Q 0 diff --git a/r/SCHEDULING-SD-SC/SCRPRAC2.m b/r/SCHEDULING-SD-SC/SCRPRAC2.m index f2fdcb8d..3559f65e 100644 --- a/r/SCHEDULING-SD-SC/SCRPRAC2.m +++ b/r/SCHEDULING-SD-SC/SCRPRAC2.m @@ -1,125 +1,113 @@ -SCRPRAC2 ;ALB/CMM - Practitioner Demographics continued ; 29 Jun 99 04:11PM - ;;5.3;Scheduling;**41,177,520**;AUG 13, 1993;Build 26 - ; - ;Practitioner Demographics Report - ; -GATHER(PARRAY,PRAC) ; - ;get practitioner data - N ANODE,TIEN,PNAME,POS,STROL,USCL,TNAME,MAX,PHONE,ASSIGN,ROOM,SERV - N NODE,PIEN,CNAME,PCLASS,PRCP,PRCPCNT,SCLN,SCI,NXT,PRCPCT,PRCPOS - N PRCPTE,SCDT,SCRATCH - S NXT=0 - F S NXT=$O(@PARRAY@(NXT)) Q:NXT=""!(NXT'?.N) D - .S (PNAME,PHONE,SERV,ROOM)="" - .D PINFO(PRAC,.PNAME,.PHONE,.ROOM,.SERV) - .;get provider name, office phone, room, service/section, person class - .; - .S ANODE=$G(@PARRAY@(NXT)) - .Q:ANODE="" - .S PIEN=+$P(ANODE,"^") ;position ien - .; - .;Get precepted provider information - .S PRCPCNT=0 - .S SCDT="SCDT",(SCDT("BEGIN"),SCDT("END"))="DT",SCDT("INCL")=0 - .K ^TMP("SCRATCH",$J),^TMP("SCRATCH1",$J) S SCI="^TMP(""SCRATCH1"",$J)" - .S SCI=$$PRECHIS^SCMCLK(PIEN,.SCDT,SCI),SCI=0 - .F S SCI=$O(^TMP("SCRATCH1",$J,SCI)) Q:'SCI D - ..N SCPRCD,SCTP - ..S SCPRCD=^TMP("SCRATCH1",$J,SCI),SCTP=$P(SCPRCD,U,3) - ..S PRCPTE=$P(SCPRCD,U,2) S:'$L(PRCPTE) PRCPTE="[unknown]" - ..S PRCPOS=$P($G(SCRATCH(1)),U,4) - ..S PRCPCT=$$PCPOSCNT^SCAPMCU1(SCTP,DT,0) - ..S PRCPCNT=PRCPCNT+PRCPCT - ..S ^TMP("SCRATCH",$J,PRCPTE,SCTP)=PRCPOS_U_PRCPCT - ..Q - .; - .S POS=$P(ANODE,"^",2) ;position name - .S STROL=$P(ANODE,"^",8) ;standard role name - .S USCL=$P(ANODE,"^",10) ;user class name - .S NODE=$G(^SCTM(404.57,PIEN,0)) - .S MAX=$P(NODE,"^",8) ;max patient assignments to position - .S ASSIGN=+$$PCPOSCNT^SCAPMCU1(PIEN,DT,0) ;assigned patients - .N CNAME,SCCLIEN - .D SETASCL(PIEN,.CNAME,.SCCLIEN) ;associated clinics - .; - .;Get preceptor - .S PRCP=$P($$OKPREC2^SCMCLK(PIEN,DT),U,2) - .; - .S TIEN=+$P(ANODE,"^",3) ;team ien - .S TNAME=$P($G(^SCTM(404.51,TIEN,0)),"^") ;team name - .; - .;Set array for output - .S SCLN=0 - .D SET1("Name",PNAME),SET2("Serv./Sect.",SERV) - .D SET1("Team",TNAME),SET2("Position",POS) - .D SET1("Role",STROL),SET2("User Class",USCL) - .D SET1("Room",ROOM),SET2("Pts. Allowed",MAX) - .D SET1("Phone",PHONE),SET2("Pts. Assigned",ASSIGN) - .I $L($G(PRCP)) D SET3(1,"Preceptor: "_PRCP) - .D SET3(4,"Assoc. Clinic: ") - .D SETCNAME(.CNAME) - .I $L(PCLASS(1)) D - ..D SET3(4,"Person"),SET3(5,"Class: "_PCLASS(1)) D - ..I $L(PCLASS(2)) D SET3(15,PCLASS(2)) D - ...I $L(PCLASS(3)) D SET3(18,PCLASS(3)) - ...Q - ..Q - .Q:'$D(^TMP("SCRATCH",$J)) - .D SET3(1,"") - .D SET4("Precepted Provider","Precepted Position","Pts. Precepted") - .S SCI="",$P(SCI,"-",31)="" D SET4(SCI,SCI,$E(SCI,1,14)) - .S PRCPTE="" F S PRCPTE=$O(^TMP("SCRATCH",$J,PRCPTE)) Q:PRCPTE="" D - ..S SCTP=0 F S SCTP=$O(^TMP("SCRATCH",$J,PRCPTE,SCTP)) Q:'SCTP D - ...S PRCPOS=^TMP("SCRATCH",$J,PRCPTE,SCTP) - ...S PRCPCT=+$P(PRCPOS,U,2),PRCPOS=$P(PRCPOS,U) - ...D SET4(PRCPTE,PRCPOS,PRCPCT_" ") - ...Q - ..Q - .D SET3(1,"") S SCI=" Total precepted patients: "_PRCPCNT - .S $E(SCI,37)=$J(("Total assigned/precepted patients: "_(PRCPCNT+ASSIGN)),42) - .D SET3(1,SCI) - .K ^TMP("SCRATCH",$J),^TMP("SCRATCH1",$J) - .Q - Q - ; -SETASCL(PIEN,CNAME,SCCLIEN) ;SET ASSOCIATED CLINICS - N I,CNT1 - S CNT1=0,I=0 - F S I=$O(^SCTM(404.57,PIEN,5,I)) Q:'I D - .S SCCLIEN(CNT1)=I,CNAME(CNT1)=$P($G(^SC(I,0)),U),CNT1=CNT1+1 - Q -SET1(LABEL,VALUE) ;Set output line - S SCLN=SCLN+1 - S @STORE@(PNAME,PIEN,SCLN)=$J(LABEL,9)_": "_$E(VALUE,1,26) - Q - ; -SET2(LABEL,VALUE) ;Set second column of output line - S $E(@STORE@(PNAME,PIEN,SCLN),40)=$J(LABEL,13)_": "_$E(VALUE,1,26) - Q - ; -SET3(COL,VALUE) ;Set output line - N SCX - S SCLN=SCLN+1,SCX="",$E(SCX,COL)=$E(VALUE,1,(80-(COL-1))) - S @STORE@(PNAME,PIEN,SCLN)=SCX - Q - ; -SET4(V1,V2,V3) ;Set output line - S SCLN=SCLN+1,V1=" "_V1,$E(V1,35)=V2,$E(V1,67)=$J(V3,14) - S @STORE@(PNAME,PIEN,SCLN)=V1 - Q - ; -SETCNAME(CNAME) ;associated clinics - N A - S A="" F S A=$O(CNAME(A)) Q:A="" D SET3(12,CNAME(A)) - Q - ; -PINFO(VAE,PRACT,OPH,ROOM,SERV) ; - ;practitioner information from new person file - S PRACT=$P($G(^VA(200,VAE,0)),"^") ;practitioner name - S OPH=$P($G(^VA(200,VAE,.13)),"^",2) ;office phone - S ROOM=$P($G(^VA(200,VAE,.14)),"^") ;room - S SERV=$P($G(^VA(200,VAE,5)),"^") ;service/section ien - S SERV=$P($G(^DIC(49,+SERV,0)),"^") ;service/section name - S PCLASS=$$GET^XUA4A72(VAE) ;Person class - N SCI F SCI=1,2,3 S PCLASS(SCI)=$P(PCLASS,U,(SCI+1)) - Q +SCRPRAC2 ;ALB/CMM - Practitioner Demographics continued ; 29 Jun 99 04:11PM + ;;5.3;Scheduling;**41,177**;AUG 13, 1993 + ; + ;Practitioner Demographics Report + ; +GATHER(PARRAY,PRAC) ; + ;get practitioner data + N ANODE,TIEN,PNAME,POS,STROL,USCL,TNAME,MAX,PHONE,ASSIGN,ROOM,SERV + N NODE,PIEN,CNAME,PCLASS,PRCP,PRCPCNT,SCLN,SCI,NXT,PRCPCT,PRCPOS + N PRCPTE,SCDT,SCRATCH + S NXT=0 + F S NXT=$O(@PARRAY@(NXT)) Q:NXT=""!(NXT'?.N) D + .S (PNAME,PHONE,SERV,ROOM)="" + .D PINFO(PRAC,.PNAME,.PHONE,.ROOM,.SERV) + .;get provider name, office phone, room, service/section, person class + .; + .S ANODE=$G(@PARRAY@(NXT)) + .Q:ANODE="" + .S PIEN=+$P(ANODE,"^") ;position ien + .; + .;Get precepted provider information + .S PRCPCNT=0 + .S SCDT="SCDT",(SCDT("BEGIN"),SCDT("END"))="DT",SCDT("INCL")=0 + .K ^TMP("SCRATCH",$J),^TMP("SCRATCH1",$J) S SCI="^TMP(""SCRATCH1"",$J)" + .S SCI=$$PRECHIS^SCMCLK(PIEN,.SCDT,SCI),SCI=0 + .F S SCI=$O(^TMP("SCRATCH1",$J,SCI)) Q:'SCI D + ..N SCPRCD,SCTP + ..S SCPRCD=^TMP("SCRATCH1",$J,SCI),SCTP=$P(SCPRCD,U,3) + ..S PRCPTE=$P(SCPRCD,U,2) S:'$L(PRCPTE) PRCPTE="[unknown]" + ..S PRCPOS=$P($G(SCRATCH(1)),U,4) + ..S PRCPCT=$$PCPOSCNT^SCAPMCU1(SCTP,DT,0) + ..S PRCPCNT=PRCPCNT+PRCPCT + ..S ^TMP("SCRATCH",$J,PRCPTE,SCTP)=PRCPOS_U_PRCPCT + ..Q + .; + .S POS=$P(ANODE,"^",2) ;position name + .S STROL=$P(ANODE,"^",8) ;standard role name + .S USCL=$P(ANODE,"^",10) ;user class name + .S NODE=$G(^SCTM(404.57,PIEN,0)) + .S MAX=$P(NODE,"^",8) ;max patient assignments to position + .S ASSIGN=+$$PCPOSCNT^SCAPMCU1(PIEN,DT,0) ;assigned patients + .S CNAME=$P($G(^SC(+$P(NODE,U,9),0)),U) ;associated clinic + .; + .;Get preceptor + .S PRCP=$P($$OKPREC2^SCMCLK(PIEN,DT),U,2) + .; + .S TIEN=+$P(ANODE,"^",3) ;team ien + .S TNAME=$P($G(^SCTM(404.51,TIEN,0)),"^") ;team name + .; + .;Set array for output + .S SCLN=0 + .D SET1("Name",PNAME),SET2("Serv./Sect.",SERV) + .D SET1("Team",TNAME),SET2("Position",POS) + .D SET1("Role",STROL),SET2("User Class",USCL) + .D SET1("Room",ROOM),SET2("Pts. Allowed",MAX) + .D SET1("Phone",PHONE),SET2("Pts. Assigned",ASSIGN) + .I $L($G(PRCP)) D SET3(1,"Preceptor: "_PRCP) + .D SET3(4,"Assoc.") + .D SET3(4,"Clinic: "_CNAME) + .I $L(PCLASS(1)) D + ..D SET3(4,"Person"),SET3(5,"Class: "_PCLASS(1)) D + ..I $L(PCLASS(2)) D SET3(15,PCLASS(2)) D + ...I $L(PCLASS(3)) D SET3(18,PCLASS(3)) + ...Q + ..Q + .Q:'$D(^TMP("SCRATCH",$J)) + .D SET3(1,"") + .D SET4("Precepted Provider","Precepted Position","Pts. Precepted") + .S SCI="",$P(SCI,"-",31)="" D SET4(SCI,SCI,$E(SCI,1,14)) + .S PRCPTE="" F S PRCPTE=$O(^TMP("SCRATCH",$J,PRCPTE)) Q:PRCPTE="" D + ..S SCTP=0 F S SCTP=$O(^TMP("SCRATCH",$J,PRCPTE,SCTP)) Q:'SCTP D + ...S PRCPOS=^TMP("SCRATCH",$J,PRCPTE,SCTP) + ...S PRCPCT=+$P(PRCPOS,U,2),PRCPOS=$P(PRCPOS,U) + ...D SET4(PRCPTE,PRCPOS,PRCPCT_" ") + ...Q + ..Q + .D SET3(1,"") S SCI=" Total precepted patients: "_PRCPCNT + .S $E(SCI,37)=$J(("Total assigned/precepted patients: "_(PRCPCNT+ASSIGN)),42) + .D SET3(1,SCI) + .K ^TMP("SCRATCH",$J),^TMP("SCRATCH1",$J) + .Q + Q + ; +SET1(LABEL,VALUE) ;Set output line + S SCLN=SCLN+1 + S @STORE@(PNAME,PIEN,SCLN)=$J(LABEL,9)_": "_$E(VALUE,1,26) + Q + ; +SET2(LABEL,VALUE) ;Set second column of output line + S $E(@STORE@(PNAME,PIEN,SCLN),40)=$J(LABEL,13)_": "_$E(VALUE,1,26) + Q + ; +SET3(COL,VALUE) ;Set output line + N SCX + S SCLN=SCLN+1,SCX="",$E(SCX,COL)=$E(VALUE,1,(80-(COL-1))) + S @STORE@(PNAME,PIEN,SCLN)=SCX + Q + ; +SET4(V1,V2,V3) ;Set output line + S SCLN=SCLN+1,V1=" "_V1,$E(V1,35)=V2,$E(V1,67)=$J(V3,14) + S @STORE@(PNAME,PIEN,SCLN)=V1 + Q + ; +PINFO(VAE,PRACT,OPH,ROOM,SERV) ; + ;practitioner information form new person file + S PRACT=$P($G(^VA(200,VAE,0)),"^") ;practitioner name + S OPH=$P($G(^VA(200,VAE,.13)),"^",2) ;office phone + S ROOM=$P($G(^VA(200,VAE,.14)),"^") ;room + S SERV=$P($G(^VA(200,VAE,5)),"^") ;service/section ien + S SERV=$P($G(^DIC(49,+SERV,0)),"^") ;service/section name + S PCLASS=$$GET^XUA4A72(VAE) ;Person class + N SCI F SCI=1,2,3 S PCLASS(SCI)=$P(PCLASS,U,(SCI+1)) + Q diff --git a/r/SCHEDULING-SD-SC/SCRPSLT.m b/r/SCHEDULING-SD-SC/SCRPSLT.m index 6632f74b..c8a58945 100644 --- a/r/SCHEDULING-SD-SC/SCRPSLT.m +++ b/r/SCHEDULING-SD-SC/SCRPSLT.m @@ -1,147 +1,143 @@ -SCRPSLT ;ALB/CMM - Summary Listing of Teams ; 29 Jun 99 04:11PM - ;;5.3;Scheduling;**41,52,177,231,520**;AUG 13, 1993;Build 26 - ; - ;Summary Listing of Teams Report - ; -PROMPTS ; - ;Prompt for Institution, Team, Role and Print device - ; - N VAUTD,VAUTT,VAUTR,QTIME,PRNT,NUMBER - K VAUTD,VAUTT,VAUTR,SCUP - S QTIME="" - W ! D INST^SCRPU1 I Y=-1 G ERR - W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR - W ! K Y D ROLE^SCRPU1 I '$D(VAUTR) G ERR - W !!,"This report requires 132 column output!" - D QUE(.VAUTD,.VAUTT,.VAUTR) Q - ; -QUE(INST,TEAM,ROLE) ;queue report - ;Input Parameters: - ;INST - institutions selected (variable and array) - ;TEAM - teams selected (variable and array) - ;ROLE - roles selected (variable and array) - N ZTSAVE,II - F II="INST","TEAM","ROLE","INST(","TEAM(","ROLE(" S ZTSAVE(II)="" - W ! D EN^XUTMDEVQ("QENTRY^SCRPSLT","Summary Listing of Teams",.ZTSAVE) - Q - ; -ENTRY2(INST,TEAM,ROLE,IOP,ZTDTH) ; - ;Second entry point for GUI to use - ;Input Parameters: - ;INST - institutions selected (variable and array) - ;TEAM - teams selected (variable and array) - ;ROLE - roles selected (variable and array) - ;IOP - print device - ;ZTDTH - queue time (optional) - ; - ;validate parameters - I '$D(INST)!'$D(TEAM)!'$D(ROLE)!'$D(IOP)!(IOP="") Q - ; - N NUMBER - S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^") - I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2) - I IOST?1"C-".E D QENTRY G RET - I ZTDTH="" S ZTDTH=$H - S ZTRTN="QENTRY^SCRPSLT" - S ZTDESC="Summary Listing Of Teams",ZTIO=IOP - N II - F II="INST","TEAM","ROLE","INST(","TEAM(","ROLE(","IOP" S ZTSAVE(II)="" - D ^%ZTLOAD -RET S NUMBER=0 - I $D(ZTSK) S NUMBER=ZTSK - D EXIT1 - Q NUMBER - ; -QENTRY ; - ;driver entry point - S TITL="Summary Listing of Teams" - S STORE="^TMP("_$J_",""SCRPSLT"")" - K @STORE - S @STORE=0 - I TEAM=1 D TALL^SCRPPAT3 S TEAM=0 - D FIND - I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL) - I '$D(NODATA) D PRINTIT(STORE,TITL) - D EXIT2 - Q - ; -ERR ; -EXIT1 ; - K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE,SCUP - Q - ; -EXIT2 ; - K @STORE - K STOP,STORE,TITL,IOP,TEAM,INST,ROLE,NODATA - Q - ; -FIND ; - N TM,EN2,EN,ROL,NODE,TEND,ACT,INA,TPASS,TPCN,TMAX,TMP,TOA,TNPC - S TM="" - F S TM=$O(^SCTM(404.57,"C",TM)) Q:TM="" D - .;$O through team position file - .I '$D(TEAM(TM))&(TEAM'=1) Q - .;Q above, not a selected team - .;selected team - .S EN="" - .S TPASS(TM)=0,TMAX(TM)=0,TPCN(TM)=0 - .F S EN=$O(^SCTM(404.57,"C",TM,EN)) Q:EN="" D - ..I '$D(^SCTM(404.57,EN,0)) Q - ..S NODE=$G(^SCTM(404.57,EN,0)) - ..Q:NODE="" - ..S ROL=+$P(NODE,"^",3) ;role ien - ..I '$D(ROLE(ROL))&(ROLE'=1) Q - ..;Q above not a selected role - ..;find active position during date range - ..S TMP=$$DATES^SCAPMCU1(404.52,EN,DT) - ..I +TMP=0 Q - ..S EN2=+$P(TMP,"^",4) - ..D KEEP^SCRPSLT2(NODE,EN,EN2,ROL,TM,.TPCN,.TNPC) - ..S TPASS(TM)=$$TEAMCNT^SCAPMCU1(TM,DT) - ..S TMAX(TM)=+$P($G(^SCTM(404.51,+TM,0)),U,8) - ..S TOA(TM)=TMAX(TM)-TPASS(TM) S:TOA(TM)<0 TOA(TM)=0 - ..D TEAMT^SCRPSLT2(TM,.TPASS,.TMAX,.TPCN,.TOA,.TNPC) - Q - ; -PRINTIT(STORE,TITL) ; - N INST,EINST,ETEAM,TEM,EPRACT,PRACT,NXT,PAGE,NPAGE,NEW,POS,SCAC - S (INST,EINST)="",(NPAGE,STOP)=0,PAGE=1 W:$E(IOST)="C" @IOF - D TITLE^SCRPU3(.PAGE,TITL) - D FORHEAD^SCRPSLT2 - F S EINST=$O(@STORE@("I",EINST)) Q:EINST=""!(STOP) D - .S INST=$O(@STORE@("I",EINST,"")) - .I INST="" Q - .S (TEM,ETEAM)="" - .F S ETEAM=$O(@STORE@("T",INST,ETEAM)) Q:ETEAM=""!(STOP) D - ..S TEM=$O(@STORE@("T",INST,ETEAM,"")) - ..I TEM="" Q - ..K NEW - ..I NPAGE,(IOST'?1"C-".E) D NEWP^SCRPSLT2(INST,TEM,TITL,.PAGE) S NEW="" - ..I NPAGE,(IOST?1"C-".E) D HOLD1^SCRPSLT2(.PAGE,TITL,INST,TEM) S NEW="" - ..S NPAGE=1 I STOP Q - ..I IOST'?1"C-".E,$Y>(IOSL-8) D NEWP^SCRPSLT2(INST,TEM,TITL,.PAGE) S NEW="" - ..I IOST?1"C-".E,$Y>(IOSL-8) D HOLD1^SCRPSLT2(.PAGE,TITL,INST,TEM) S NEW="" - ..I STOP Q - ..I '$D(NEW) D HEADER^SCRPSLT2(INST,TEM) - ..S (PRACT,EPRACT)="" - ..F S EPRACT=$O(@STORE@("PN",INST,TEM,EPRACT)) Q:EPRACT=""!(STOP) D - ...S PRACT=$O(@STORE@("PN",INST,TEM,EPRACT,"")) - ...I PRACT="" Q - ...S POS="" - ...F S POS=$O(@STORE@(INST,TEM,PRACT,POS)) Q:POS=""!(STOP) D - ....W !,$G(@STORE@(INST,TEM,PRACT,POS)) - ....S SCAC="" - ....F S SCAC=$O(@STORE@(INST,TEM,PRACT,POS,SCAC)) Q:SCAC=""!(STOP) D - .....W !,$G(@STORE@(INST,TEM,PRACT,POS,SCAC)) - .....I IOST'?1"C-".E,$Y>(IOSL-4) D NEWP^SCRPSLT2(INST,TEM,TITL,.PAGE) - .....I IOST?1"C-".E,$Y>(IOSL-4) D HOLD1^SCRPSLT2(.PAGE,TITL,INST,TEM) - .....I STOP Q - ....;W !,$G(@STORE@(INST,TEM,PRACT,POS)) ;writes info - ..Q:STOP - ..I IOST'?1"C-".E,$Y>(IOSL-8) D NEWP^SCRPSLT2(INST,TEM,TITL,.PAGE,1) - ..I IOST?1"C-".E,$Y>(IOSL-8) D HOLD1^SCRPSLT2(.PAGE,TITL,INST,TEM,1) - ..D TOTAL^SCRPSLT2(INST,TEM) - .I STOP Q - .S NPAGE=1 - I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" D ^DIR - Q +SCRPSLT ;ALB/CMM - Summary Listing of Teams ; 29 Jun 99 04:11PM + ;;5.3;Scheduling;**41,52,177,231**;AUG 13, 1993 + ; + ;Summary Listing of Teams Report + ; +PROMPTS ; + ;Prompt for Institution, Team, Role and Print device + ; + N VAUTD,VAUTT,VAUTR,QTIME,PRNT,NUMBER + K VAUTD,VAUTT,VAUTR,SCUP + S QTIME="" + W ! D INST^SCRPU1 I Y=-1 G ERR + W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR + W ! K Y D ROLE^SCRPU1 I '$D(VAUTR) G ERR + W !!,"This report requires 132 column output!" + D QUE(.VAUTD,.VAUTT,.VAUTR) Q + ; +QUE(INST,TEAM,ROLE) ;queue report + ;Input Parameters: + ;INST - institutions selected (variable and array) + ;TEAM - teams selected (variable and array) + ;ROLE - roles selected (variable and array) + N ZTSAVE,II + F II="INST","TEAM","ROLE","INST(","TEAM(","ROLE(" S ZTSAVE(II)="" + W ! D EN^XUTMDEVQ("QENTRY^SCRPSLT","Summary Listing of Teams",.ZTSAVE) + Q + ; +ENTRY2(INST,TEAM,ROLE,IOP,ZTDTH) ; + ;Second entry point for GUI to use + ;Input Parameters: + ;INST - institutions selected (variable and array) + ;TEAM - teams selected (variable and array) + ;ROLE - roles selected (variable and array) + ;IOP - print device + ;ZTDTH - queue time (optional) + ; + ;validate parameters + I '$D(INST)!'$D(TEAM)!'$D(ROLE)!'$D(IOP)!(IOP="") Q + ; + N NUMBER + S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^") + I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2) + I IOST?1"C-".E D QENTRY G RET + I ZTDTH="" S ZTDTH=$H + S ZTRTN="QENTRY^SCRPSLT" + S ZTDESC="Summary Listing Of Teams",ZTIO=IOP + N II + F II="INST","TEAM","ROLE","INST(","TEAM(","ROLE(","IOP" S ZTSAVE(II)="" + D ^%ZTLOAD +RET S NUMBER=0 + I $D(ZTSK) S NUMBER=ZTSK + D EXIT1 + Q NUMBER + ; +QENTRY ; + ;driver entry point + S TITL="Summary Listing of Teams" + S STORE="^TMP("_$J_",""SCRPSLT"")" + K @STORE + S @STORE=0 + I TEAM=1 D TALL^SCRPPAT3 S TEAM=0 + D FIND + I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL) + I '$D(NODATA) D PRINTIT(STORE,TITL) + D EXIT2 + Q + ; +ERR ; +EXIT1 ; + K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE,SCUP + Q + ; +EXIT2 ; + K @STORE + K STOP,STORE,TITL,IOP,TEAM,INST,ROLE,NODATA + Q + ; +FIND ; + N TM,EN2,EN,ROL,NODE,TEND,ACT,INA,TPASS,TPCN,TMAX,TMP,TOA,TNPC + S TM="" + F S TM=$O(^SCTM(404.57,"C",TM)) Q:TM="" D + .;$O through team position file + .I '$D(TEAM(TM))&(TEAM'=1) Q + .;Q above, not a selected team + .;selected team + .S EN="" + .S TPASS(TM)=0,TMAX(TM)=0,TPCN(TM)=0 + .F S EN=$O(^SCTM(404.57,"C",TM,EN)) Q:EN="" D + ..I '$D(^SCTM(404.57,EN,0)) Q + ..S NODE=$G(^SCTM(404.57,EN,0)) + ..Q:NODE="" + ..S ROL=+$P(NODE,"^",3) ;role ien + ..I '$D(ROLE(ROL))&(ROLE'=1) Q + ..;Q above not a selected role + ..;find active position during date range + ..S TMP=$$DATES^SCAPMCU1(404.52,EN,DT) + ..I +TMP=0 Q + ..S EN2=+$P(TMP,"^",4) + ..D KEEP^SCRPSLT2(NODE,EN,EN2,ROL,TM,.TPCN,.TNPC) + ..S TPASS(TM)=$$TEAMCNT^SCAPMCU1(TM,DT) + ..S TMAX(TM)=+$P($G(^SCTM(404.51,+TM,0)),U,8) + ..S TOA(TM)=TMAX(TM)-TPASS(TM) S:TOA(TM)<0 TOA(TM)=0 + ..D TEAMT^SCRPSLT2(TM,.TPASS,.TMAX,.TPCN,.TOA,.TNPC) + Q + ; +PRINTIT(STORE,TITL) ; + N INST,EINST,ETEAM,TEM,EPRACT,PRACT,NXT,PAGE,NPAGE,NEW,POS + S (INST,EINST)="",(NPAGE,STOP)=0,PAGE=1 W:$E(IOST)="C" @IOF + D TITLE^SCRPU3(.PAGE,TITL) + D FORHEAD^SCRPSLT2 + F S EINST=$O(@STORE@("I",EINST)) Q:EINST=""!(STOP) D + .S INST=$O(@STORE@("I",EINST,"")) + .I INST="" Q + .S (TEM,ETEAM)="" + .F S ETEAM=$O(@STORE@("T",INST,ETEAM)) Q:ETEAM=""!(STOP) D + ..S TEM=$O(@STORE@("T",INST,ETEAM,"")) + ..I TEM="" Q + ..K NEW + ..I NPAGE,(IOST'?1"C-".E) D NEWP^SCRPSLT2(INST,TEM,TITL,.PAGE) S NEW="" + ..I NPAGE,(IOST?1"C-".E) D HOLD1^SCRPSLT2(.PAGE,TITL,INST,TEM) S NEW="" + ..S NPAGE=1 I STOP Q + ..I IOST'?1"C-".E,$Y>(IOSL-8) D NEWP^SCRPSLT2(INST,TEM,TITL,.PAGE) S NEW="" + ..I IOST?1"C-".E,$Y>(IOSL-8) D HOLD1^SCRPSLT2(.PAGE,TITL,INST,TEM) S NEW="" + ..I STOP Q + ..I '$D(NEW) D HEADER^SCRPSLT2(INST,TEM) + ..S (PRACT,EPRACT)="" + ..F S EPRACT=$O(@STORE@("PN",INST,TEM,EPRACT)) Q:EPRACT=""!(STOP) D + ...S PRACT=$O(@STORE@("PN",INST,TEM,EPRACT,"")) + ...I PRACT="" Q + ...S POS="" + ...F S POS=$O(@STORE@(INST,TEM,PRACT,POS)) Q:POS=""!(STOP) D + ....I IOST'?1"C-".E,$Y>(IOSL-4) D NEWP^SCRPSLT2(INST,TEM,TITL,.PAGE) + ....I IOST?1"C-".E,$Y>(IOSL-4) D HOLD1^SCRPSLT2(.PAGE,TITL,INST,TEM) + ....I STOP Q + ....W !,$G(@STORE@(INST,TEM,PRACT,POS)) ;writes info + ..Q:STOP + ..I IOST'?1"C-".E,$Y>(IOSL-8) D NEWP^SCRPSLT2(INST,TEM,TITL,.PAGE,1) + ..I IOST?1"C-".E,$Y>(IOSL-8) D HOLD1^SCRPSLT2(.PAGE,TITL,INST,TEM,1) + ..D TOTAL^SCRPSLT2(INST,TEM) + .I STOP Q + .S NPAGE=1 + I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" D ^DIR + Q diff --git a/r/SCHEDULING-SD-SC/SCRPSLT2.m b/r/SCHEDULING-SD-SC/SCRPSLT2.m index c6c15b36..80c2a2f1 100644 --- a/r/SCHEDULING-SD-SC/SCRPSLT2.m +++ b/r/SCHEDULING-SD-SC/SCRPSLT2.m @@ -1,170 +1,162 @@ -SCRPSLT2 ;ALB/CMM - Summary Listing of Teams Continued ; 9/15/99 10:43am - ;;5.3;Scheduling;**41,174,177,231,520**;AUG 13, 1993;Build 26 - ; - ;Summary Listing of Teams Report - ; -KEEP(TNODE,APOS,TPOS,ROL,TM,TPCN,TNPC) ; - ;TNODE - zero node of the team position file - ;APOS - ien of team position file - ;TPOS - ien of position assignment history file - ;ROL - ien of role - ;TM - ien of team - ; - N POS,TNAME,TPHONE,TPC,TDIV,TEN,TMN,DIV,PPC,PCLIN,VAE,PRACT,NPC,MAX - N PCN,ROLN,PRCTP,PRCPC,PRCNPC,PRCPTE,SCPC,SCNPC,XDAT,SCDT,SCI - ; - S TEN=+$P(TNODE,"^",2) ;team file pointer - S TMN=$G(^SCTM(404.51,TEN,0)) - S TNAME=$P(TMN,"^") ;team name - S DIV=+$P(TMN,"^",7) ;division ien - S TDIV=$P($G(^DIC(4,DIV,0)),"^") ;team division - D KTEAM(TNAME,TDIV,TM,DIV) - ; - S POS=$P(TNODE,"^") ;position name - ;SD*5.3*231 - call SCMCLK to determine in AP or not - S PPC=$S($P(TNODE,"^",4)<1:"NPC",+$$OKPREC3^SCMCLK(APOS,DT)>0:" AP",1:"PCP") ;PC? - ;S PCLIN=$P($G(^SC(+$P(TNODE,"^",9),0)),"^") ;associated clinic - D SETASCL^SCRPRAC2(APOS,.PCLIN) - S PCLIN=$G(PCLIN(0)) - S ROLN=$P($G(^SD(403.46,+ROL,0)),U) ;role name - ; - S (PRCPC,PRCNPC)="",SCI="^TMP(""SCRATCH"",$J)" - K @SCI - S (SCDT("BEGIN"),SCDT("END"))=DT,SCDT("INCL")=0,SCDT="SCDT" - S SCI=$$PRECHIS^SCMCLK(APOS,.SCDT,SCI) - I SCI=1 S SCI=0 F S SCI=$O(^TMP("SCRATCH",$J,SCI)) Q:'SCI D - .N SCPRCD - .S SCPRCD=^TMP("SCRATCH",$J,SCI),PRCPTE=$P(SCPRCD,U,3) Q:'PRCPTE - .S SCPC=$$PCPOSCNT^SCAPMCU1(PRCPTE,DT,1) ;precepted PC patients - .S:SCPC<0 SCPC=0 S PRCPC=PRCPC+SCPC - .S SCNPC=$$PCPOSCNT^SCAPMCU1(PRCPTE,DT,0) ;all precepted patients - .S:SCNPC<0 SCNPC=0 S SCNPC=SCNPC-SCPC S:SCNPC<0 SCNPC=0 - .S PRCNPC=PRCNPC+SCNPC - .Q - ; - S XDAT=ROLN_U_PRCPC_U_PRCNPC ;extra data - ; - S VAE=+$P($G(^SCTM(404.52,TPOS,0)),"^",3) ;ien of new person file - S PRACT=$P($G(^VA(200,VAE,0)),"^") ;practitioner name - I PRACT="" S PRACT="[Not Assigned]" - ; - S MAX=+$P(TNODE,"^",8) I MAX<0 S MAX=0 - S PCN=$$PCPOSCNT^SCAPMCU1(APOS,DT) S:PCN=-1 PCN=0 - S TPCN(TM)=$G(TPCN(TM))+PCN - S NPC=$$PCPOSCNT^SCAPMCU1(APOS,DT,0) S:NPC=-1 NPC=0 - S NPC=NPC-PCN S:NPC<0 NPC=0 - S TNPC(TM)=$G(TNPC(TM))+NPC - ; - D FORMAT(APOS,POS,PCLIN,VAE,PRACT,PPC,DIV,TM,NPC,MAX,PCN,XDAT) - N SCAC - S SCAC=0 - F S SCAC=$O(PCLIN(SCAC)) Q:SCAC="" D FORMATAC(APOS,POS,PCLIN(SCAC),VAE,DIV,TM) - Q - ; -TEAMT(TM,TPASS,TMAX,TPCN,TOA,TNPC) ; - ;set team totals into global - S @STORE@("TOTALS",TM,"H1")=" Team Totals:" - S @STORE@("TOTALS",TM,"H2")="------------------------------------" - S @STORE@("TOTALS",TM,"H3")=" Primary Care Assignments: "_$J($G(TPCN(TM)),6,0) - S @STORE@("TOTALS",TM,"H4")=" Non-PC Assignments: "_$J($G(TNPC(TM)),6,0) - S @STORE@("TOTALS",TM,"H5")=" Unique Patients Assigned: "_$J($G(TPASS(TM)),6,0) - S @STORE@("TOTALS",TM,"H6")=" Maximum Patients Allowed: "_$J($G(TMAX(TM)),6,0) - S @STORE@("TOTALS",TM,"H7")=" Total Open Assignments: "_$J($G(TOA(TM)),6,0) - Q - ; -FORMAT(APOS,POS,PCLIN,VAE,PRACT,PPC,DIV,TM,NPC,MX,PC,XDAT) ; - ; - NEW TMP - I PRACT="" S PRACT="Bad Data" - S @STORE@("PN",DIV,TM,PRACT,VAE)="" - S @STORE@(DIV,TM,VAE,APOS)=$E(PRACT,1,20) ;practitioner name - S $E(@STORE@(DIV,TM,VAE,APOS),23)=$E(POS,1,20) ;position - S $E(@STORE@(DIV,TM,VAE,APOS),45)=PPC ;PC? - S $E(@STORE@(DIV,TM,VAE,APOS),50)=$E($P(XDAT,U),1,20) ;role - S $E(@STORE@(DIV,TM,VAE,APOS),72)=$E(PCLIN,1,25) ;assoc. clinic - S $E(@STORE@(DIV,TM,VAE,APOS),99)=$J(MX,6,0) ;max pts. - S $E(@STORE@(DIV,TM,VAE,APOS),107)=$J(PC,5,0) ;PC pts. - S $E(@STORE@(DIV,TM,VAE,APOS),114)=$J(NPC,5,0) ;non-PC pts. - ; - ;bp/djb 'Precepted Patients' column should be zero for APs. - ;Old code begins - ;S $E(@STORE@(DIV,TM,VAE,APOS),121)=$J($P(XDAT,U,2),5,0) ;precept PC - ;S $E(@STORE@(DIV,TM,VAE,APOS),128)=$J($P(XDAT,U,3),5,0) ;precept NPC - ;Old code ends - ;New code begins - S (TMP(1),TMP(2))=0 I PPC'["AP" D ;APs should be zero - .S TMP(1)=$P(XDAT,U,2) - .S TMP(2)=$P(XDAT,U,3) - S $E(@STORE@(DIV,TM,VAE,APOS),121)=$J(TMP(1),5,0) ;precepted PC - S $E(@STORE@(DIV,TM,VAE,APOS),128)=$J(TMP(2),5,0) ;precepted NPC - ;New code ends - Q -FORMATAC(APOS,POS,PCLIN,VAE,DIV,TM) ;clinic multiples - S $E(@STORE@(DIV,TM,VAE,APOS,SCAC),72)=$E(PCLIN,1,30) - Q - ; -TOTAL(INST,TEM) ; - ;Prints team totals - N NXT - S NXT="" - W ! - F S NXT=$O(@STORE@("TOTALS",TEM,NXT)) Q:NXT="" D - .;bp/djb Stop displaying certain 'Team Totals:' lines. - .;New code begin - .Q:$G(@STORE@("TOTALS",TEM,NXT))["Unique Patients Assigned" - .Q:$G(@STORE@("TOTALS",TEM,NXT))["Maximum Patients Allowed" - .Q:$G(@STORE@("TOTALS",TEM,NXT))["Total Open Assignments" - .;New code end - .W !,$G(@STORE@("TOTALS",TEM,NXT)) - W ! - Q - ; -KTEAM(TNAME,TDIV,TIEN,IEND) ; - ;store team information - I TNAME="" S TNAME="[BAD DATA]" - I TDIV="" S TDIV="[BAD DATA]" - S @STORE@("I",TDIV,IEND)="" - S @STORE@("T",IEND,TNAME,TIEN)="" - S @STORE@(IEND)=" Division: "_TDIV - S @STORE@(IEND,TIEN)="Team Name: "_TNAME - Q - ; -FORHEAD ; - S @STORE@("H3")="Practitioner" - S $E(@STORE@("H3"),23)="Position" - S $E(@STORE@("H3"),45)="PC?" - S $E(@STORE@("H3"),50)="Standard Role" - S $E(@STORE@("H3"),72)="Associated Clinic" - S $E(@STORE@("H1"),101)="Max." - S $E(@STORE@("H2"),101)="Pts." - S $E(@STORE@("H3"),99)="Allow." - S $E(@STORE@("H1"),107)="--Assigned--" - S $E(@STORE@("H2"),107)="--Patients--" - S $E(@STORE@("H3"),107)="PC NonPC" - S $E(@STORE@("H1"),121)="--Precepted-" - S $E(@STORE@("H2"),121)="--Patients--" - S $E(@STORE@("H3"),121)="PC NonPC" - S $P(@STORE@("H4"),"=",133)="" - Q -HEADER(INST,TEM,TEND) ; - N NXT - S NXT="H",TEND=$G(TEND) - W !!,@STORE@(INST) - W !!,@STORE@(INST,TEM) - I 'TEND F S NXT=$O(@STORE@(NXT)) Q:NXT'?1"H".E D - .W !,@STORE@(NXT) - W ! - Q -NEWP(INST,TEM,TITL,PAGE,TEND) ; - S TEND=$G(TEND) - D NEWP1^SCRPU3(.PAGE,TITL) - I STOP Q - D HEADER(INST,TEM,TEND) - Q -HOLD1(PAGE,TITL,INST,TEM,TEND) ; - ;device is home, reached end of page - S TEND=$G(TEND) - D HOLD^SCRPU3(.PAGE,TITL) - I STOP Q - D HEADER(INST,TEM,TEND) - Q +SCRPSLT2 ;ALB/CMM - Summary Listing of Teams Continued ; 9/15/99 10:43am + ;;5.3;Scheduling;**41,174,177,231**;AUG 13, 1993 + ; + ;Summary Listing of Teams Report + ; +KEEP(TNODE,APOS,TPOS,ROL,TM,TPCN,TNPC) ; + ;TNODE - zero node of the team position file + ;APOS - ien of team position file + ;TPOS - ien of position assignment history file + ;ROL - ien of role + ;TM - ien of team + ; + N POS,TNAME,TPHONE,TPC,TDIV,TEN,TMN,DIV,PPC,PCLIN,VAE,PRACT,NPC,MAX + N PCN,ROLN,PRCTP,PRCPC,PRCNPC,PRCPTE,SCPC,SCNPC,XDAT,SCDT,SCI + ; + S TEN=+$P(TNODE,"^",2) ;team file pointer + S TMN=$G(^SCTM(404.51,TEN,0)) + S TNAME=$P(TMN,"^") ;team name + S DIV=+$P(TMN,"^",7) ;division ien + S TDIV=$P($G(^DIC(4,DIV,0)),"^") ;team division + D KTEAM(TNAME,TDIV,TM,DIV) + ; + S POS=$P(TNODE,"^") ;position name + ;SD*5.3*231 - call SCMCLK to determine in AP or not + S PPC=$S($P(TNODE,"^",4)<1:"NPC",+$$OKPREC3^SCMCLK(APOS,DT)>1:" AP",1:"PCP") ;PC? + S PCLIN=$P($G(^SC(+$P(TNODE,"^",9),0)),"^") ;associated clinic + S ROLN=$P($G(^SD(403.46,+ROL,0)),U) ;role name + ; + S (PRCPC,PRCNPC)="",SCI="^TMP(""SCRATCH"",$J)" + K @SCI + S (SCDT("BEGIN"),SCDT("END"))=DT,SCDT("INCL")=0,SCDT="SCDT" + S SCI=$$PRECHIS^SCMCLK(APOS,.SCDT,SCI) + I SCI=1 S SCI=0 F S SCI=$O(^TMP("SCRATCH",$J,SCI)) Q:'SCI D + .N SCPRCD + .S SCPRCD=^TMP("SCRATCH",$J,SCI),PRCPTE=$P(SCPRCD,U,3) Q:'PRCPTE + .S SCPC=$$PCPOSCNT^SCAPMCU1(PRCPTE,DT,1) ;precepted PC patients + .S:SCPC<0 SCPC=0 S PRCPC=PRCPC+SCPC + .S SCNPC=$$PCPOSCNT^SCAPMCU1(PRCPTE,DT,0) ;all precepted patients + .S:SCNPC<0 SCNPC=0 S SCNPC=SCNPC-SCPC S:SCNPC<0 SCNPC=0 + .S PRCNPC=PRCNPC+SCNPC + .Q + ; + S XDAT=ROLN_U_PRCPC_U_PRCNPC ;extra data + ; + S VAE=+$P($G(^SCTM(404.52,TPOS,0)),"^",3) ;ien of new person file + S PRACT=$P($G(^VA(200,VAE,0)),"^") ;practitioner name + I PRACT="" S PRACT="[Not Assigned]" + ; + S MAX=+$P(TNODE,"^",8) I MAX<0 S MAX=0 + S PCN=$$PCPOSCNT^SCAPMCU1(APOS,DT) S:PCN=-1 PCN=0 + S TPCN(TM)=$G(TPCN(TM))+PCN + S NPC=$$PCPOSCNT^SCAPMCU1(APOS,DT,0) S:NPC=-1 NPC=0 + S NPC=NPC-PCN S:NPC<0 NPC=0 + S TNPC(TM)=$G(TNPC(TM))+NPC + ; + D FORMAT(APOS,POS,PCLIN,VAE,PRACT,PPC,DIV,TM,NPC,MAX,PCN,XDAT) + Q + ; +TEAMT(TM,TPASS,TMAX,TPCN,TOA,TNPC) ; + ;set team totals into global + S @STORE@("TOTALS",TM,"H1")=" Team Totals:" + S @STORE@("TOTALS",TM,"H2")="------------------------------------" + S @STORE@("TOTALS",TM,"H3")=" Primary Care Assignments: "_$J($G(TPCN(TM)),6,0) + S @STORE@("TOTALS",TM,"H4")=" Non-PC Assignments: "_$J($G(TNPC(TM)),6,0) + S @STORE@("TOTALS",TM,"H5")=" Unique Patients Assigned: "_$J($G(TPASS(TM)),6,0) + S @STORE@("TOTALS",TM,"H6")=" Maximum Patients Allowed: "_$J($G(TMAX(TM)),6,0) + S @STORE@("TOTALS",TM,"H7")=" Total Open Assignments: "_$J($G(TOA(TM)),6,0) + Q + ; +FORMAT(APOS,POS,PCLIN,VAE,PRACT,PPC,DIV,TM,NPC,MX,PC,XDAT) ; + ; + NEW TMP + I PRACT="" S PRACT="Bad Data" + S @STORE@("PN",DIV,TM,PRACT,VAE)="" + S @STORE@(DIV,TM,VAE,APOS)=$E(PRACT,1,20) ;practitioner name + S $E(@STORE@(DIV,TM,VAE,APOS),23)=$E(POS,1,20) ;position + S $E(@STORE@(DIV,TM,VAE,APOS),45)=PPC ;PC? + S $E(@STORE@(DIV,TM,VAE,APOS),50)=$E($P(XDAT,U),1,20) ;role + S $E(@STORE@(DIV,TM,VAE,APOS),72)=$E(PCLIN,1,25) ;assoc. clinic + S $E(@STORE@(DIV,TM,VAE,APOS),99)=$J(MX,6,0) ;max pts. + S $E(@STORE@(DIV,TM,VAE,APOS),107)=$J(PC,5,0) ;PC pts. + S $E(@STORE@(DIV,TM,VAE,APOS),114)=$J(NPC,5,0) ;non-PC pts. + ; + ;bp/djb 'Precepted Patients' column should be zero for APs. + ;Old code begins + ;S $E(@STORE@(DIV,TM,VAE,APOS),121)=$J($P(XDAT,U,2),5,0) ;precept PC + ;S $E(@STORE@(DIV,TM,VAE,APOS),128)=$J($P(XDAT,U,3),5,0) ;precept NPC + ;Old code ends + ;New code begins + S (TMP(1),TMP(2))=0 I PPC'["AP" D ;APs should be zero + .S TMP(1)=$P(XDAT,U,2) + .S TMP(2)=$P(XDAT,U,3) + S $E(@STORE@(DIV,TM,VAE,APOS),121)=$J(TMP(1),5,0) ;precepted PC + S $E(@STORE@(DIV,TM,VAE,APOS),128)=$J(TMP(2),5,0) ;precepted NPC + ;New code ends + Q + ; +TOTAL(INST,TEM) ; + ;Prints team totals + N NXT + S NXT="" + W ! + F S NXT=$O(@STORE@("TOTALS",TEM,NXT)) Q:NXT="" D + .;bp/djb Stop displaying certain 'Team Totals:' lines. + .;New code begin + .Q:$G(@STORE@("TOTALS",TEM,NXT))["Unique Patients Assigned" + .Q:$G(@STORE@("TOTALS",TEM,NXT))["Maximum Patients Allowed" + .Q:$G(@STORE@("TOTALS",TEM,NXT))["Total Open Assignments" + .;New code end + .W !,$G(@STORE@("TOTALS",TEM,NXT)) + W ! + Q + ; +KTEAM(TNAME,TDIV,TIEN,IEND) ; + ;store team information + I TNAME="" S TNAME="[BAD DATA]" + I TDIV="" S TDIV="[BAD DATA]" + S @STORE@("I",TDIV,IEND)="" + S @STORE@("T",IEND,TNAME,TIEN)="" + S @STORE@(IEND)=" Division: "_TDIV + S @STORE@(IEND,TIEN)="Team Name: "_TNAME + Q + ; +FORHEAD ; + S @STORE@("H3")="Practitioner" + S $E(@STORE@("H3"),23)="Position" + S $E(@STORE@("H3"),45)="PC?" + S $E(@STORE@("H3"),50)="Standard Role" + S $E(@STORE@("H3"),72)="Associated Clinic" + S $E(@STORE@("H1"),101)="Max." + S $E(@STORE@("H2"),101)="Pts." + S $E(@STORE@("H3"),99)="Allow." + S $E(@STORE@("H1"),107)="--Assigned--" + S $E(@STORE@("H2"),107)="--Patients--" + S $E(@STORE@("H3"),107)="PC NonPC" + S $E(@STORE@("H1"),121)="--Precepted-" + S $E(@STORE@("H2"),121)="--Patients--" + S $E(@STORE@("H3"),121)="PC NonPC" + S $P(@STORE@("H4"),"=",133)="" + Q +HEADER(INST,TEM,TEND) ; + N NXT + S NXT="H",TEND=$G(TEND) + W !!,@STORE@(INST) + W !!,@STORE@(INST,TEM) + I 'TEND F S NXT=$O(@STORE@(NXT)) Q:NXT'?1"H".E D + .W !,@STORE@(NXT) + W ! + Q +NEWP(INST,TEM,TITL,PAGE,TEND) ; + S TEND=$G(TEND) + D NEWP1^SCRPU3(.PAGE,TITL) + I STOP Q + D HEADER(INST,TEM,TEND) + Q +HOLD1(PAGE,TITL,INST,TEM,TEND) ; + ;device is home, reached end of page + S TEND=$G(TEND) + D HOLD^SCRPU3(.PAGE,TITL) + I STOP Q + D HEADER(INST,TEM,TEND) + Q diff --git a/r/SCHEDULING-SD-SC/SCRPTA.m b/r/SCHEDULING-SD-SC/SCRPTA.m index 890f3182..8fee3176 100644 --- a/r/SCHEDULING-SD-SC/SCRPTA.m +++ b/r/SCHEDULING-SD-SC/SCRPTA.m @@ -1,160 +1,160 @@ -SCRPTA ;ALB/CMM - Patient Listing w/Team Assignment Data ; 29 Jun 99 04:11PM - ;;5.3;Scheduling;**41,48,52,114,174,181,177,526**;AUG 13, 1993;Build 8 - ; - ;Patient Listing w/Team Assignment Data Report - ; -PROMPTS ; - ;Prompt for Institution, Team, Role, Practitioner and Print device - ; - N PRNT,QTIME,NUMBER - K VAUTD,VAUTT,VAUTR,VAUTP,VAUTPP,SCUP - S QTIME="" - W ! D INST^SCRPU1 I Y=-1 G ERR - W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR - W ! K Y D ROLE^SCRPU1 I '$D(VAUTR) G ERR - W ! K Y S VAUTPP="" D PRACT^SCRPU1 K VAUTPP I '$D(VAUTP) G ERR - W !!,"This report requires 132 column output!" - D QUE(.VAUTD,.VAUTT,.VAUTR,.VAUTP) Q - ; -QUE(INST,TEAM,ROLE,PRACT) ; - ;Input Parameters: - ;INST - institutions selected (variable and array) - ;TEAM - teams selected (variable and array) - ;ROLE - roles selected (variable and array) - ;PRACT - practitioners selected (variable and array) - N ZTSAVE,II - F II="INST","TEAM","ROLE","INST(","TEAM(","PRACT","PRACT(","ROLE(" S ZTSAVE(II)="" - W ! D EN^XUTMDEVQ("QENTRY^SCRPTA","Patient Listing for Team Assignments",.ZTSAVE) - Q - ; -ENTRY2(INST,TEAM,ROLE,PRACT,IOP,ZTDTH) ; - ;Second entry point for GUI to use - ;Input Parameters: - ;INST - institutions selected (variable and array) - ;TEAM - teams selected (variable and array) - ;ROLE - roles selected (variable and array) - ;PRACT - practitioners selected (variable and array) - ;IOP - print device - ;ZTDTH - queue time (optional) - ; - ;validate parameters - I '$D(INST)!'$D(TEAM)!'$D(ROLE)!'$D(PRACT)!'$D(IOP)!(IOP="") Q - ; - N NUMBER - S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^") - I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2) - I IOST?1"C-".E D QENTRY G RET - I ZTDTH="" S ZTDTH=$H - S ZTRTN="QENTRY^SCRPTA" - S ZTDESC="Patient Listing w/Team Assignment",ZTIO=IOP - N II - F II="INST","TEAM","ROLE","INST(","TEAM(","PRACT","PRACT(","ROLE(","IOP" S ZTSAVE(II)="" - D ^%ZTLOAD -RET S NUMBER=0 - I $D(ZTSK) S NUMBER=ZTSK - D EXIT1 - Q NUMBER - ; -QENTRY ; - ;driver entry point - S TITL="Patient Listing For Team Assignments" - S STORE="^TMP("_$J_",""SCRPTA"")" - K @STORE - S @STORE=0 - I TEAM=1 D TALL^SCRPPAT3 S TEAM=0 - D FIND - I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL) - I '$D(NODATA) D PRINTIT(STORE,TITL) - D EXIT2 - Q - ; -ERR ; -EXIT1 ; - K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE,Y,SCUP - Q - ; -EXIT2 ; - K @STORE - K STOP,STORE,TITL,IOP,TEAM,INST,ROLE,NODATA,PRACT - Q - ; -FIND ; - N NXT,TLIST,TERR,CNT,ERR1,TNODE,NODE1,PIEN,PTAIEN - S NXT=0,TLIST="^TMP("_$J_",""SCRPTA"",""LIST1"")",TERR="ERR1" - K @TLIST,@TERR - F S NXT=$O(TEAM(NXT)) Q:NXT=""!(NXT'?.N) D - .S ERR1=$$PTTM^SCAPMC2(NXT,,.TLIST,.TERR) ;Patients assigned to team NXT - .Q:ERR1=0 - .S CNT=0 - .F S CNT=$O(@TLIST@(CNT)) Q:CNT=""!(CNT'?.N) D - ..S TNODE=$G(@TLIST@(CNT)) - ..Q:TNODE="" - ..S PIEN=+$P(TNODE,"^") ;patient ien - ..S PTAIEN=+$P(TNODE,"^",3) ;ien Patient Team Assignment #404.42 - ..D CHK^SCRPTA2(PTAIEN,PIEN) - .K @TLIST,@TERR - K @TLIST,@TERR - Q - ; -PRINTIT(STORE,TITL) ; - N NXT,PAGE,NPAGE,INTN,TMN,INT,TM,PRN,PR,POS - S (NPAGE,STOP,PAGE)=0,INTN="" W:$E(IOST)="C" @IOF - D SHEAD ;setup headers - F S INTN=$O(@STORE@("I",INTN)) Q:INTN=""!(STOP) D - .S INT=$O(@STORE@("I",INTN,"")) ;institution - .Q:INT="" - .S TMN="" - .F S TMN=$O(@STORE@("T",INT,TMN)) Q:TMN=""!(STOP) D - ..S TM=$O(@STORE@("T",INT,TMN,"")) ;team - ..Q:TM="" - ..D NEWP1^SCRPU3(.PAGE,TITL,132) W !,$G(@STORE@(INT)),!!,$G(@STORE@(INT,TM)) - ..Q:STOP - ..S PRN="" - ..D HEADER - ..F S PRN=$O(@STORE@("P",INT,TM,PRN)) Q:PRN=""!(STOP) D - ...S PR=$O(@STORE@("P",INT,TM,PRN,"")) ;practitioner - ...Q:PR="" - ...S POS="" - ...F S POS=$O(@STORE@("P",INT,TM,PRN,PR,POS)) Q:POS=""!(STOP) D - ....D PRNT(INT,TM,PR,POS) - I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR - Q - ; -PRNT(INT,TM,PR,POS) ; - ;INT - institution ien - ;TM - team ien - ;PR - practitioner ien - ;POS - position ien - ; - N PTIEN,PTNAME - S PTNAME="" - F S PTNAME=$O(@STORE@(INT,TM,PR,POS,PTNAME)) Q:PTNAME=""!(STOP) D - .S PTIEN="" - .F S PTIEN=$O(@STORE@(INT,TM,PR,POS,PTNAME,PTIEN)) Q:PTIEN=""!(STOP) D - ..I (IOST'?1"C-".E),$Y>(IOSL-4) D NEWP1^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INT)),!!,$G(@STORE@(INT,TM)) D:'STOP HEADER - ..I (IOST?1"C-".E),$Y>(IOSL-4) D HOLD^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INT)),!!,$G(@STORE@(INT,TM)) D:'STOP HEADER - ..Q:STOP - ..W !,$G(@STORE@(INT,TM,PR,POS,PTNAME,PTIEN)) - .Q - Q - ; -HEADER ; - ;write column headers - N EN - W ! - F EN="H1","H2","H3" D - .W !,$G(@STORE@(EN)) - Q -SHEAD ; - ;setup column headers - S @STORE@("H2")="Patient Name" - S $E(@STORE@("H2"),19)="Pt ID" - S $E(@STORE@("H1"),31)="Date" - S $E(@STORE@("H2"),31)="Assigned" - S $E(@STORE@("H2"),43)="PC?" - S $E(@STORE@("H2"),49)="Practitioner" - S $E(@STORE@("H2"),70)="Position" - S $E(@STORE@("H2"),92)="Standard Role" - S $E(@STORE@("H2"),113)="Preceptor" - S $P(@STORE@("H3"),"=",133)="" - Q +SCRPTA ;ALB/CMM - Patient Listing w/Team Assignment Data ; 29 Jun 99 04:11PM + ;;5.3;Scheduling;**41,48,52,114,174,181,177**;AUG 13, 1993 + ; + ;Patient Listing w/Team Assignment Data Report + ; +PROMPTS ; + ;Prompt for Institution, Team, Role, Practitioner and Print device + ; + N PRNT,QTIME,NUMBER + K VAUTD,VAUTT,VAUTR,VAUTP,VAUTPP,SCUP + S QTIME="" + W ! D INST^SCRPU1 I Y=-1 G ERR + W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR + W ! K Y D ROLE^SCRPU1 I '$D(VAUTR) G ERR + W ! K Y S VAUTPP="" D PRACT^SCRPU1 K VAUTPP I '$D(VAUTP) G ERR + W !!,"This report requires 132 column output!" + D QUE(.VAUTD,.VAUTT,.VAUTR,.VAUTP) Q + ; +QUE(INST,TEAM,ROLE,PRACT) ; + ;Input Parameters: + ;INST - institutions selected (variable and array) + ;TEAM - teams selected (variable and array) + ;ROLE - roles selected (variable and array) + ;PRACT - practitioners selected (variable and array) + N ZTSAVE,II + F II="INST","TEAM","ROLE","INST(","TEAM(","PRACT","PRACT(","ROLE(" S ZTSAVE(II)="" + W ! D EN^XUTMDEVQ("QENTRY^SCRPTA","Patient Listing for Team Assignments",.ZTSAVE) + Q + ; +ENTRY2(INST,TEAM,ROLE,PRACT,IOP,ZTDTH) ; + ;Second entry point for GUI to use + ;Input Parameters: + ;INST - institutions selected (variable and array) + ;TEAM - teams selected (variable and array) + ;ROLE - roles selected (variable and array) + ;PRACT - practitioners selected (variable and array) + ;IOP - print device + ;ZTDTH - queue time (optional) + ; + ;validate parameters + I '$D(INST)!'$D(TEAM)!'$D(ROLE)!'$D(PRACT)!'$D(IOP)!(IOP="") Q + ; + N NUMBER + S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^") + I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2) + I IOST?1"C-".E D QENTRY G RET + I ZTDTH="" S ZTDTH=$H + S ZTRTN="QENTRY^SCRPTA" + S ZTDESC="Patient Listing w/Team Assignment",ZTIO=IOP + N II + F II="INST","TEAM","ROLE","INST(","TEAM(","PRACT","PRACT(","ROLE(","IOP" S ZTSAVE(II)="" + D ^%ZTLOAD +RET S NUMBER=0 + I $D(ZTSK) S NUMBER=ZTSK + D EXIT1 + Q NUMBER + ; +QENTRY ; + ;driver entry point + S TITL="Patient Listing For Team Assignments" + S STORE="^TMP("_$J_",""SCRPTA"")" + K @STORE + S @STORE=0 + I TEAM=1 D TALL^SCRPPAT3 S TEAM=0 + D FIND + I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL) + I '$D(NODATA) D PRINTIT(STORE,TITL) + D EXIT2 + Q + ; +ERR ; +EXIT1 ; + K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE,Y,SCUP + Q + ; +EXIT2 ; + K @STORE + K STOP,STORE,TITL,IOP,TEAM,INST,ROLE,NODATA,PRACT + Q + ; +FIND ; + N NXT,TLIST,TERR,CNT,ERR1,TNODE,NODE1,PIEN,PTAIEN + S NXT=0,TLIST="^TMP("_$J_",""SCRPTA"",""LIST1"")",TERR="ERR1" + K @TLIST,@TERR + F S NXT=$O(TEAM(NXT)) Q:NXT=""!(NXT'?.N) D + .S ERR1=$$PTTM^SCAPMC2(NXT,,.TLIST,.TERR) ;Patients assigned to team NXT + .Q:ERR1=0 + .S CNT=0 + .F S CNT=$O(@TLIST@(CNT)) Q:CNT=""!(CNT'?.N) D + ..S TNODE=$G(@TLIST@(CNT)) + ..Q:TNODE="" + ..S PIEN=+$P(TNODE,"^") ;patient ien + ..S PTAIEN=+$P(TNODE,"^",3) ;ien Patient Team Assignment #404.42 + ..D CHK^SCRPTA2(PTAIEN,PIEN) + .K @TLIST,@TERR + K @TLIST,@TERR + Q + ; +PRINTIT(STORE,TITL) ; + N NXT,PAGE,NPAGE,INTN,TMN,INT,TM,PRN,PR,POS + S (NPAGE,STOP,PAGE)=0,INTN="" W:$E(IOST)="C" @IOF + D SHEAD ;setup headers + F S INTN=$O(@STORE@("I",INTN)) Q:INTN=""!(STOP) D + .S INT=$O(@STORE@("I",INTN,"")) ;institution + .Q:INT="" + .S TMN="" + .F S TMN=$O(@STORE@("T",INT,TMN)) Q:TMN=""!(STOP) D + ..S TM=$O(@STORE@("T",INT,TMN,"")) ;team + ..Q:TM="" + ..D NEWP1^SCRPU3(.PAGE,TITL,132) W !,$G(@STORE@(INT)),!!,$G(@STORE@(INT,TM)) + ..Q:STOP + ..S PRN="" + ..D HEADER + ..F S PRN=$O(@STORE@("P",INT,TM,PRN)) Q:PRN=""!(STOP) D + ...S PR=$O(@STORE@("P",INT,TM,PRN,"")) ;practitioner + ...Q:PR="" + ...S POS="" + ...F S POS=$O(@STORE@("P",INT,TM,PRN,PR,POS)) Q:POS=""!(STOP) D + ....D PRNT(INT,TM,PR,POS) + I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR + Q + ; +PRNT(INT,TM,PR,POS) ; + ;INT - institution ien + ;TM - team ien + ;PR - practitioner ien + ;POS - position ien + ; + N PTIEN,PTNAME + S PTNAME="" + F S PTNAME=$O(@STORE@(INT,TM,PR,POS,PTNAME)) Q:PTNAME=""!(STOP) D + .S PTIEN="" + .F S PTIEN=$O(@STORE@(INT,TM,PR,POS,PTNAME,PTIEN)) Q:PTIEN=""!(STOP) D + ..I (IOST'?1"C-".E),$Y>(IOSL-4) D NEWP1^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INT)),!!,$G(@STORE@(INT,TM)) D:'STOP HEADER + ..I (IOST?1"C-".E),$Y>(IOSL-4) D HOLD^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INT)),!!,$G(@STORE@(INT,TM)) D:'STOP HEADER + ..Q:STOP + ..W !,$G(@STORE@(INT,TM,PR,POS,PTNAME,PTIEN)) + .Q + Q + ; +HEADER ; + ;write column headers + N EN + W ! + F EN="H1","H2","H3" D + .W !,$G(@STORE@(EN)) + Q +SHEAD ; + ;setup column headers + S @STORE@("H2")="Patient Name" + S $E(@STORE@("H2"),24)="Pt ID" + S $E(@STORE@("H1"),31)="Date" + S $E(@STORE@("H2"),31)="Assigned" + S $E(@STORE@("H2"),43)="PC?" + S $E(@STORE@("H2"),49)="Practitioner" + S $E(@STORE@("H2"),70)="Position" + S $E(@STORE@("H2"),92)="Standard Role" + S $E(@STORE@("H2"),113)="Preceptor" + S $P(@STORE@("H3"),"=",133)="" + Q diff --git a/r/SCHEDULING-SD-SC/SCRPTA2.m b/r/SCHEDULING-SD-SC/SCRPTA2.m index 2f3bdac7..edb94079 100644 --- a/r/SCHEDULING-SD-SC/SCRPTA2.m +++ b/r/SCHEDULING-SD-SC/SCRPTA2.m @@ -1,153 +1,152 @@ -SCRPTA2 ;ALB/CMM - Patient Listing w/Team Assignment Data ; 30 Jun 99 1:33 PM - ;;5.3;Scheduling;**41,88,140,148,174,181,177,526**;AUG 13, 1993;Build 8 - ; - ;Patient Listing w/Team Assignment Data Report continued - ; -CHK(PTIEN,PIEN) ;assigned to a position - ;PTIEN - ien of 404.42 Patient Team Assignment file - ;PIEN - ien of patient file #2 - ; - N NODE,START,TPIEN,TPNODE,ROL,PRAC,ROLN,PCAP,PRCN - S START="" - Q:'$D(^SCPT(404.43,"B",PTIEN))&(PRACT'="") - I '$D(^SCPT(404.43,"B",PTIEN))&(PRACT="") D NOTA(PTIEN,PIEN) Q - F S START=$O(^SCPT(404.43,"B",PTIEN,START)) Q:START="" D - .S NODE=$G(^SCPT(404.43,START,0)) - .Q:NODE="" - .Q:($P(NODE,"^",4)'="")&($P(NODE,"^",4)0:" AP",1:"PCP") ; PC? - .S PRCN=$P($$OKPREC2^SCMCLK(TPIEN,DT),U,2) ;preceptor name - .; - .S ROL=+$P(TPNODE,"^",3) ;role for position (ien) - .Q:'$D(ROLE(ROL))&(ROLE'=1) ;not a selected role - .S ROLN=$P($G(^SD(403.46,ROL,0)),U) ;role name - .; - .S PRAC=$$PRACI(TPIEN) ;practitioner information - .I +PRAC=-1 D NOTA(PTIEN,PIEN) Q - .I (PRACT'=1)&('$D(PRACT(+PRAC)))&(+PRAC'=0) Q - .; ^ not a selected practitioner - .; - .S POS=$P($G(^SCTM(404.57,TPIEN,0)),"^") - .D FOUND2(START,NODE,TPIEN,POS,TPNODE,PRAC,PIEN,ROLN,PCAP,PRCN) - Q -PRACI(TPIEN) ; - ;TPIEN - team position ien (404.57) - ; - N EN,TPLIST,TPERR,NAME,POS,ERR,NPIEN,NODE,POSIEN - S TPLIST="TPLST",TPERR="ERR2" - K @TPLIST,@TPERR - S ERR=$$PRTP^SCAPMC8(TPIEN,,.TPLIST,.TPERR) - Q:ERR=0!($D(@TPERR)) -1 - S NODE=$G(@TPLIST@(1)) - Q:NODE="" "0^[Not Assigned]" - S NAME=$P(NODE,"^",2) ;practitioner name - S NPIEN=+$P(NODE,"^") ;practitioner ien - S POS=$P(NODE,"^",4) ;position name - S POSIEN=+$P(NODE,"^",3) ;position ien - I POS="" S POS="[Not Assigned]",POSIEN=0 - I NAME="" S NAME="[Not Assigned]",NPIEN=0 - K @TPLIST,@TPERR - Q NPIEN_"^"_NAME_"^"_POS_"^"_POSIEN - ; -FOUND2(START,NODE,TPIEN,POS,TPNODE,PRAC,PIEN,ROLN,PCAP,PRCN) ; - ;START - patient team assignment position ien - ;NODE - patient team position assignment node - ;TPIEN - team position ien (404.57) - ;POS - team position - ;TPNODE - team position node (404.57) - ;PRAC - practitioner info. NAME IEN^NAME^POS^POSIEN - ;ROLN - role name - ;PCAP - PC/AP/NPC assignment? - ;PRCN - preceptor name - ; - N PTNAME,PID,ADATE - S PTNAME=$P($G(^DPT(PIEN,0)),"^") ;patient name - S PID=$P($G(^DPT(PIEN,.36)),"^",3),PID=$TR(PID,"-","") - ;9 digit ssn SD*5.3*526 - dmr - ;S PID=$E(PID,6,10) ;last four pid include 5th for pseudo notation - ; - S ADATE=$P(NODE,"^",3) ;position assignment date - fm format - ;convert to external format - I ADATE'="" S ADATE=$TR($$FMTE^XLFDT(ADATE,"5DF")," ","0") - ; - S PNAME=$P(PRAC,"^",2) ;practitioner name - S PNIEN=$P(PRAC,"^") ;practitioner ien - ; - S TIEN=+$P(TPNODE,"^",2) ;ien team file 404.51 - S TMN=$G(^SCTM(404.51,TIEN,0)) - Q:TMN="" - S TNAME=$P(TMN,"^") ;team name - S PC=$P(TMN,"^",5) ;primary care team 1/0 - S IIEN=+$P(TMN,"^",7) ;institution ien - S INAME=$P($G(^DIC(4,IIEN,0)),"^") ;institution - ; - D FORMAT(IIEN,INAME,TNAME,TIEN,PC,PTNAME,PID,PNAME,PNIEN,POS,TPIEN,ADATE,PIEN,ROLN,PCAP,PRCN) - Q - ; -FORMAT(IIEN,INAME,TNAME,TIEN,PC,PTNAME,PID,PNAME,PIEN,POS,TPIEN,ADATE,PTIEN,ROLN,PCAP,PRCN) ; - ;IIEN - institution ien - ;INAME - institution name - ;TNAME - team name - ;TIEN - team ien - ;PC - primary care 1/0 - ;PTNAME - patient name - ;PID - last 4 pid plus 5th pseudo - ;PNAME - practitioner name - ;PIEN - practitioner ien - ;POS - position name - ;TPIEN - position ien - ;ADATE - assignment date - ;PTIEN - patient ien - ;ROLN - role name - ;PCAP - PC/AP/NPC assignment? - ;PRCN - preceptor name - ; - I INAME="" S INAME="[BAD DATA]" - I TNAME="" S TNAME="[BAD DATA]" - I PNAME="" S PNAME="[BAD DATA]" - I '$D(@STORE@("I",INAME,IIEN)) S @STORE@("I",INAME,IIEN)="" - I '$D(@STORE@("T",IIEN,TNAME,TIEN)) S @STORE@("T",IIEN,TNAME,TIEN)="" - I '$D(@STORE@("P",IIEN,TIEN,PNAME,PIEN,TPIEN)) S @STORE@("P",IIEN,TIEN,PNAME,PIEN,TPIEN)="" - S @STORE@(IIEN)="Division: "_INAME - S @STORE@(IIEN,TIEN)="Team: "_TNAME - S $E(@STORE@(IIEN,TIEN),40)="Primary Care Team: "_$S(PC=1:"YES",1:"NO") - ; - S @STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN)=$E(PTNAME,1,17) - S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),19)=PID - S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),31)=ADATE - S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),43)=PCAP - S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),49)=$E(PNAME,1,21) - S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),70)=$E(POS,1,20) - S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),92)=$E(ROLN,1,20) - S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),113)=$E(PRCN,1,20) - Q - ; -NOTA(PTIEN,PIEN) ; - ;PTIEN - patient team assignment (#404.42) - ;PIEN - patient ien - N IIEN,INAME,TNAME,TIEN,PC,PTNAME,PID,PNAME,PNIEN,POSIEN,POS,TPIEN - N ROLN,PCAP,PRCN,ADATE - S POS="[Not Assigned]",POSIEN=0 - S PNAME="[Not Assigned]",PNIEN=0 - S (ROLN,PCAP,PRCN,ADATE)="" - ; - S PTNAME=$E($P($G(^DPT(PIEN,0)),"^"),1,20) ;patient name - S PID=$P($G(^DPT(PIEN,.36)),"^",3),PID=$TR(PID,"-","") - ;S PID=$E(PID,6,10) ;9 digit ssn patch 526 - ; - S TIEN=+$P($G(^SCPT(404.42,PTIEN,0)),"^",3) ;team ien - S TMN=$G(^SCTM(404.51,TIEN,0)) - Q:TMN="" - S TNAME=$P(TMN,"^") ;team name - S PC=$P(TMN,"^",5) ;primary care team 1/0 - S IIEN=+$P(TMN,"^",7) ;institution ien - S INAME=$P($G(^DIC(4,IIEN,0)),"^") ;institution name - ; - D FORMAT(IIEN,INAME,TNAME,TIEN,PC,PTNAME,PID,PNAME,PNIEN,POS,POSIEN,ADATE,PIEN,ROLN,PCAP,PRCN) - Q +SCRPTA2 ;ALB/CMM - Patient Listing w/Team Assignment Data ; 30 Jun 99 1:33 PM + ;;5.3;Scheduling;**41,88,140,148,174,181,177**;AUG 13, 1993 + ; + ;Patient Listing w/Team Assignment Data Report continued + ; +CHK(PTIEN,PIEN) ;assigned to a position + ;PTIEN - ien of 404.42 Patient Team Assignment file + ;PIEN - ien of patient file #2 + ; + N NODE,START,TPIEN,TPNODE,ROL,PRAC,ROLN,PCAP,PRCN + S START="" + Q:'$D(^SCPT(404.43,"B",PTIEN))&(PRACT'="") + I '$D(^SCPT(404.43,"B",PTIEN))&(PRACT="") D NOTA(PTIEN,PIEN) Q + F S START=$O(^SCPT(404.43,"B",PTIEN,START)) Q:START="" D + .S NODE=$G(^SCPT(404.43,START,0)) + .Q:NODE="" + .Q:($P(NODE,"^",4)'="")&($P(NODE,"^",4)0:" AP",1:"PCP") ; PC? + .S PRCN=$P($$OKPREC2^SCMCLK(TPIEN,DT),U,2) ;preceptor name + .; + .S ROL=+$P(TPNODE,"^",3) ;role for position (ien) + .Q:'$D(ROLE(ROL))&(ROLE'=1) ;not a selected role + .S ROLN=$P($G(^SD(403.46,ROL,0)),U) ;role name + .; + .S PRAC=$$PRACI(TPIEN) ;practitioner information + .I +PRAC=-1 D NOTA(PTIEN,PIEN) Q + .I (PRACT'=1)&('$D(PRACT(+PRAC)))&(+PRAC'=0) Q + .; ^ not a selected practitioner + .; + .S POS=$P($G(^SCTM(404.57,TPIEN,0)),"^") + .D FOUND2(START,NODE,TPIEN,POS,TPNODE,PRAC,PIEN,ROLN,PCAP,PRCN) + Q +PRACI(TPIEN) ; + ;TPIEN - team position ien (404.57) + ; + N EN,TPLIST,TPERR,NAME,POS,ERR,NPIEN,NODE,POSIEN + S TPLIST="TPLST",TPERR="ERR2" + K @TPLIST,@TPERR + S ERR=$$PRTP^SCAPMC8(TPIEN,,.TPLIST,.TPERR) + Q:ERR=0!($D(@TPERR)) -1 + S NODE=$G(@TPLIST@(1)) + Q:NODE="" "0^[Not Assigned]" + S NAME=$P(NODE,"^",2) ;practitioner name + S NPIEN=+$P(NODE,"^") ;practitioner ien + S POS=$P(NODE,"^",4) ;position name + S POSIEN=+$P(NODE,"^",3) ;position ien + I POS="" S POS="[Not Assigned]",POSIEN=0 + I NAME="" S NAME="[Not Assigned]",NPIEN=0 + K @TPLIST,@TPERR + Q NPIEN_"^"_NAME_"^"_POS_"^"_POSIEN + ; +FOUND2(START,NODE,TPIEN,POS,TPNODE,PRAC,PIEN,ROLN,PCAP,PRCN) ; + ;START - patient team assignment position ien + ;NODE - patient team position assignment node + ;TPIEN - team position ien (404.57) + ;POS - team position + ;TPNODE - team position node (404.57) + ;PRAC - practitioner info. NAME IEN^NAME^POS^POSIEN + ;ROLN - role name + ;PCAP - PC/AP/NPC assignment? + ;PRCN - preceptor name + ; + N PTNAME,PID,ADATE + S PTNAME=$P($G(^DPT(PIEN,0)),"^") ;patient name + S PID=$P($G(^DPT(PIEN,.36)),"^",3),PID=$TR(PID,"-","") + S PID=$E(PID,6,10) ;last four pid include 5th for pseudo notation + ; + S ADATE=$P(NODE,"^",3) ;position assignment date - fm format + ;convert to external format + I ADATE'="" S ADATE=$TR($$FMTE^XLFDT(ADATE,"5DF")," ","0") + ; + S PNAME=$P(PRAC,"^",2) ;practitioner name + S PNIEN=$P(PRAC,"^") ;practitioner ien + ; + S TIEN=+$P(TPNODE,"^",2) ;ien team file 404.51 + S TMN=$G(^SCTM(404.51,TIEN,0)) + Q:TMN="" + S TNAME=$P(TMN,"^") ;team name + S PC=$P(TMN,"^",5) ;primary care team 1/0 + S IIEN=+$P(TMN,"^",7) ;institution ien + S INAME=$P($G(^DIC(4,IIEN,0)),"^") ;institution + ; + D FORMAT(IIEN,INAME,TNAME,TIEN,PC,PTNAME,PID,PNAME,PNIEN,POS,TPIEN,ADATE,PIEN,ROLN,PCAP,PRCN) + Q + ; +FORMAT(IIEN,INAME,TNAME,TIEN,PC,PTNAME,PID,PNAME,PIEN,POS,TPIEN,ADATE,PTIEN,ROLN,PCAP,PRCN) ; + ;IIEN - institution ien + ;INAME - institution name + ;TNAME - team name + ;TIEN - team ien + ;PC - primary care 1/0 + ;PTNAME - patient name + ;PID - last 4 pid plus 5th pseudo + ;PNAME - practitioner name + ;PIEN - practitioner ien + ;POS - position name + ;TPIEN - position ien + ;ADATE - assignment date + ;PTIEN - patient ien + ;ROLN - role name + ;PCAP - PC/AP/NPC assignment? + ;PRCN - preceptor name + ; + I INAME="" S INAME="[BAD DATA]" + I TNAME="" S TNAME="[BAD DATA]" + I PNAME="" S PNAME="[BAD DATA]" + I '$D(@STORE@("I",INAME,IIEN)) S @STORE@("I",INAME,IIEN)="" + I '$D(@STORE@("T",IIEN,TNAME,TIEN)) S @STORE@("T",IIEN,TNAME,TIEN)="" + I '$D(@STORE@("P",IIEN,TIEN,PNAME,PIEN,TPIEN)) S @STORE@("P",IIEN,TIEN,PNAME,PIEN,TPIEN)="" + S @STORE@(IIEN)="Division: "_INAME + S @STORE@(IIEN,TIEN)="Team: "_TNAME + S $E(@STORE@(IIEN,TIEN),40)="Primary Care Team: "_$S(PC=1:"YES",1:"NO") + ; + S @STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN)=$E(PTNAME,1,21) + S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),24)=PID + S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),31)=ADATE + S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),43)=PCAP + S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),49)=$E(PNAME,1,21) + S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),70)=$E(POS,1,20) + S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),92)=$E(ROLN,1,20) + S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),113)=$E(PRCN,1,20) + Q + ; +NOTA(PTIEN,PIEN) ; + ;PTIEN - patient team assignment (#404.42) + ;PIEN - patient ien + N IIEN,INAME,TNAME,TIEN,PC,PTNAME,PID,PNAME,PNIEN,POSIEN,POS,TPIEN + N ROLN,PCAP,PRCN,ADATE + S POS="[Not Assigned]",POSIEN=0 + S PNAME="[Not Assigned]",PNIEN=0 + S (ROLN,PCAP,PRCN,ADATE)="" + ; + S PTNAME=$E($P($G(^DPT(PIEN,0)),"^"),1,20) ;patient name + S PID=$P($G(^DPT(PIEN,.36)),"^",3),PID=$TR(PID,"-","") + S PID=$E(PID,6,10) ;last 4 plus 5th for psuedo + ; + S TIEN=+$P($G(^SCPT(404.42,PTIEN,0)),"^",3) ;team ien + S TMN=$G(^SCTM(404.51,TIEN,0)) + Q:TMN="" + S TNAME=$P(TMN,"^") ;team name + S PC=$P(TMN,"^",5) ;primary care team 1/0 + S IIEN=+$P(TMN,"^",7) ;institution ien + S INAME=$P($G(^DIC(4,IIEN,0)),"^") ;institution name + ; + D FORMAT(IIEN,INAME,TNAME,TIEN,PC,PTNAME,PID,PNAME,PNIEN,POS,POSIEN,ADATE,PIEN,ROLN,PCAP,PRCN) + Q diff --git a/r/SCHEDULING-SD-SC/SCRPTM.m b/r/SCHEDULING-SD-SC/SCRPTM.m index 6e0d6a23..596322b1 100644 --- a/r/SCHEDULING-SD-SC/SCRPTM.m +++ b/r/SCHEDULING-SD-SC/SCRPTM.m @@ -1,166 +1,163 @@ -SCRPTM ;ALB/CMM - List of Team's Members Report ; 29 Jun 99 04:11PM - ;;5.3;Scheduling;**41,48,52,181,177,520**;AUG 13, 1993;Build 26 - ; - ;List of Team's Members Report - ; -PROMPTS ; - ;Prompt for Institution, Team, Date Range, User Class, Role - ;and Print device - ; - N VAUTD,VAUTT,VAUTUC,VAUTR,QTIME,RANG,PRNT,NUMBER - K VAUTD,VAUTT,VAUTUC,VAUTR,SCUP - S QTIME="" - W ! D INST^SCRPU1 I Y=-1 G ERR - W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR - W ! K Y S RANG=$$DTRANG^SCRPU2() I +RANG=-1 G ERR - W ! K Y D USER^SCRPU1 I '$D(VAUTUC)&($P($G(^SD(404.91,1,"PCMM")),"^")=1) G ERR - W ! K Y D ROLE^SCRPU1 I '$D(VAUTR) G ERR - D QUE(.VAUTD,.VAUTT,.VAUTUC,.VAUTR,RANG) Q - ; -QUE(INST,TEAM,USERC,ROLE,RANGE) ;queue report - ;Input Parameters: - ;INST - institutions selected (variable and array) - ;TEAM - teams selected (variable and array) - ;USERC - user classes selected (variable and array) - ;ROLE - roles selected (variable and array) - ;RANGE - date range selected (begin date ^ end date) - N ZTSAVE,II - F II="INST","TEAM","USERC","ROLE","INST(","TEAM(","USERC(","ROLE(","RANGE" S ZTSAVE(II)="" - W ! D EN^XUTMDEVQ("QENTRY^SCRPTM","Team Member Listing",.ZTSAVE) - Q - ; -ENTRY2(INST,TEAM,USERC,ROLE,RANGE,IOP,ZTDTH) ; - ;Second entry point for GUI to use - ;Input Parameters: - ;INST - institutions selected (variable and array) - ;TEAM - teams selected (variable and array) - ;USERC - user classes selected (variable and array) - ;ROLE - roles selected (variable and array) - ;RANGE - date range selected (begin date ^ end date) - ;IOP - print device - ;ZTDTH - queue time (optional) - ; - ;validate parameters - I '$D(INST)!'$D(TEAM)!'$D(ROLE)!'$D(RANGE)!'$D(IOP)!(IOP="") Q - ; - N NUMBER - S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^") - I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2) - I IOST?1"C-".E D QENTRY G RET - I ZTDTH="" S ZTDTH=$H - S ZTRTN="QENTRY^SCRPTM" - S ZTDESC="List of Team's Members",ZTIO=IOP - N II - F II="INST","TEAM","USERC","ROLE","INST(","TEAM(","USERC(","ROLE(","RANGE","IOP" S ZTSAVE(II)="" - D ^%ZTLOAD -RET S NUMBER=0 - I $D(ZTSK) S NUMBER=ZTSK - D EXIT1 - Q NUMBER - ; -QENTRY ; - ;driver entry point - S TITL="Team Member Listing" - S STORE="^TMP("_$J_",""SCRPTM"")" - K @STORE - S @STORE=0 - D BUILD - I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL) - I '$D(NODATA) D PRINTIT(STORE,TITL) - D EXIT2 - Q - ; -ERR ; -EXIT1 ; - K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE,SCUP - Q -EXIT2 ; - K @STORE - K STOP,STORE,TITL,IOP,TEAM,INST,NODATA,RANGE,ROLE,USERC - Q - ; -BUILD ;get report data - ;get all practitioners for all teams selected - I TEAM=1 D TALL ;all teams selected - N TIEN,OKAY,XLIST,YLIST,SCTP,SCI,SCDT,PLIST - S SCDT("BEGIN")=$P(RANGE,U),SCDT("END")=$P(RANGE,U,2) - S SCDT("INCL")=0,SCDT="SCDT" - S TIEN="",PLIST="^TMP(""SCRP"",$J,""LIST"")" - F S TIEN=$O(TEAM(TIEN)) Q:TIEN=""!(TIEN'?.N) D - .K XLIST,@PLIST - .S OKAY=$$TPTM^SCAPMC(TIEN,.SCDT,"","","XLIST","ERROR") - .S SCTP=0 F S SCTP=$O(XLIST("SCTP",TIEN,SCTP)) Q:'SCTP D - ..S SCTP0=$G(^SCTM(404.57,SCTP,0)) Q:'$L(SCTP0) - ..I ROLE'=1,'$D(ROLE(+$P(SCTP0,U,3))) Q ;not a selected role - ..I $D(USERC),USERC'=1,'$D(USERC(+$P(SCTP0,U,13))) Q ;not a selected user class - ..K YLIST - ..S OKAY=$$PRTP^SCAPMC(SCTP,.SCDT,"YLIST","ERROR",1,0) - ..S SCI=0 F S SCI=$O(YLIST(SCI)) Q:'SCI D - ...S @PLIST@(0)=$G(@PLIST@(0))+1 - ...S @PLIST@(@PLIST@(0))=YLIST(SCI) - ...Q - ..Q - .I OKAY D PULL^SCRPTM2(TIEN,.PLIST) - .Q - Q - ; -TALL ; - ;get all active team for divisions selected - N NXT,IIEN,NODE - S NXT=0,IIEN="" - ;$O through team file and find all active teams for selected divisions - F S IIEN=$O(^SCTM(404.51,"AINST",IIEN)) Q:IIEN="" D - .I INST=1!$D(INST(IIEN)) D - ..S TIEN=0 - ..F S TIEN=$O(^SCTM(404.51,"AINST",IIEN,TIEN)) Q:TIEN="" D - ...I $$ACTTM^SCMCTMU(TIEN) S TEAM(TIEN)="" - Q - ; -PRINTIT(STORE,TITL) ; - N INST,EINST,ETEAM,TEM,EPRACT,PRACT,PAGE,NXT,NPAGE,CNT,HEAD,POS - S EINST="",(NPAGE,STOP,HEAD)=0,PAGE=1 W:$E(IOST)="C" @IOF - D TITLE^SCRPU3(.PAGE,TITL) - F S EINST=$O(@STORE@("I",EINST)) Q:EINST=""!(STOP) D - .S INST=$O(@STORE@("I",EINST,"")) - .Q:INST="" - .I 'NPAGE W !,$G(@STORE@(INST)) ;write institution line - .S (ETEAM,TEM)="" - .F S ETEAM=$O(@STORE@("T",INST,ETEAM)) Q:ETEAM=""!(STOP) D - ..S TEM=$O(@STORE@("T",INST,ETEAM,0)) - ..I TEM="" Q - ..S NXT="H" - ..I NPAGE,(IOST'?1"C-".E) D NEWP^SCRPTM2(INST,TEM,TITL,.PAGE,.HEAD) S NPAGE=0 - ..I NPAGE,(IOST?1"C-".E) D HOLD1^SCRPTM2(.PAGE,TITL,INST,TEM,.HEAD) S NPAGE=0 - ..I STOP Q - ..I IOST'?1"C-".E,$Y>(IOSL-5) D NEWP^SCRPTM2(INST,TEM,TITL,.PAGE,.HEAD) - ..I IOST?1"C-".E,$Y>(IOSL-5) D HOLD1^SCRPTM2(.PAGE,TITL,INST,TEM,.HEAD) - ..I STOP Q - ..F S NXT=$O(@STORE@(INST,TEM,NXT)) Q:NXT'?1"H".E!(STOP) D - ...I 'HEAD W !,$G(@STORE@(INST,TEM,NXT)) S HEAD=0 ;writes team info - ..S (EPRACT,PRACT)="" - ..W ! ;extra line between members and practioner list - ..F S EPRACT=$O(@STORE@("PN",INST,TEM,EPRACT)) Q:EPRACT=""!(STOP) D - ...F S PRACT=$O(@STORE@("PN",INST,TEM,EPRACT,PRACT)) Q:PRACT=""!(STOP) D - ....I PRACT="" Q - ....S POS="" - ....F S POS=$O(@STORE@("PN",INST,TEM,EPRACT,PRACT,POS)) Q:POS=""!(STOP) D - .....D PRNTD(INST,TEM,PRACT,POS,TITL,.PAGE,.HEAD) - .....W ! ;seperated positions - ....W ! ;separates practitioners - .S NPAGE=1 - I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR - Q - ; -PRNTD(INST,TEM,PRACT,POS,TITL,PAGE,HEAD) ; - ; - N CNT,SCAC - S CNT="" - I IOST'?1"C-".E,$Y>(IOSL-11) D NEWP^SCRPTM2(INST,TEM,TITL,.PAGE,.HEAD) - I IOST?1"C-".E,$Y>(IOSL-11) D HOLD1^SCRPTM2(.PAGE,TITL,INST,TEM,.HEAD) - I STOP Q - F S CNT=$O(@STORE@(INST,TEM,PRACT,POS,CNT)) Q:CNT=""!(STOP) D - .W !,$G(@STORE@(INST,TEM,PRACT,POS,CNT)) - .S SCAC="" I CNT=4 D - ..F S SCAC=$O(@STORE@(INST,TEM,PRACT,POS,4,SCAC)) Q:SCAC=""!(STOP) D - ...W !,$G(@STORE@(INST,TEM,PRACT,POS,4,SCAC)) - Q +SCRPTM ;ALB/CMM - List of Team's Members Report ; 29 Jun 99 04:11PM + ;;5.3;Scheduling;**41,48,52,181,177**;AUG 13, 1993 + ; + ;List of Team's Members Report + ; +PROMPTS ; + ;Prompt for Institution, Team, Date Range, User Class, Role + ;and Print device + ; + N VAUTD,VAUTT,VAUTUC,VAUTR,QTIME,RANG,PRNT,NUMBER + K VAUTD,VAUTT,VAUTUC,VAUTR,SCUP + S QTIME="" + W ! D INST^SCRPU1 I Y=-1 G ERR + W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR + W ! K Y S RANG=$$DTRANG^SCRPU2() I +RANG=-1 G ERR + W ! K Y D USER^SCRPU1 I '$D(VAUTUC)&($P($G(^SD(404.91,1,"PCMM")),"^")=1) G ERR + W ! K Y D ROLE^SCRPU1 I '$D(VAUTR) G ERR + D QUE(.VAUTD,.VAUTT,.VAUTUC,.VAUTR,RANG) Q + ; +QUE(INST,TEAM,USERC,ROLE,RANGE) ;queue report + ;Input Parameters: + ;INST - institutions selected (variable and array) + ;TEAM - teams selected (variable and array) + ;USERC - user classes selected (variable and array) + ;ROLE - roles selected (variable and array) + ;RANGE - date range selected (begin date ^ end date) + N ZTSAVE,II + F II="INST","TEAM","USERC","ROLE","INST(","TEAM(","USERC(","ROLE(","RANGE" S ZTSAVE(II)="" + W ! D EN^XUTMDEVQ("QENTRY^SCRPTM","Team Member Listing",.ZTSAVE) + Q + ; +ENTRY2(INST,TEAM,USERC,ROLE,RANGE,IOP,ZTDTH) ; + ;Second entry point for GUI to use + ;Input Parameters: + ;INST - institutions selected (variable and array) + ;TEAM - teams selected (variable and array) + ;USERC - user classes selected (variable and array) + ;ROLE - roles selected (variable and array) + ;RANGE - date range selected (begin date ^ end date) + ;IOP - print device + ;ZTDTH - queue time (optional) + ; + ;validate parameters + I '$D(INST)!'$D(TEAM)!'$D(ROLE)!'$D(RANGE)!'$D(IOP)!(IOP="") Q + ; + N NUMBER + S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^") + I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2) + I IOST?1"C-".E D QENTRY G RET + I ZTDTH="" S ZTDTH=$H + S ZTRTN="QENTRY^SCRPTM" + S ZTDESC="List of Team's Members",ZTIO=IOP + N II + F II="INST","TEAM","USERC","ROLE","INST(","TEAM(","USERC(","ROLE(","RANGE","IOP" S ZTSAVE(II)="" + D ^%ZTLOAD +RET S NUMBER=0 + I $D(ZTSK) S NUMBER=ZTSK + D EXIT1 + Q NUMBER + ; +QENTRY ; + ;driver entry point + S TITL="Team Member Listing" + S STORE="^TMP("_$J_",""SCRPTM"")" + K @STORE + S @STORE=0 + D BUILD + I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL) + I '$D(NODATA) D PRINTIT(STORE,TITL) + D EXIT2 + Q + ; +ERR ; +EXIT1 ; + K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE,SCUP + Q +EXIT2 ; + K @STORE + K STOP,STORE,TITL,IOP,TEAM,INST,NODATA,RANGE,ROLE,USERC + Q + ; +BUILD ;get report data + ;get all practitioners for all teams selected + I TEAM=1 D TALL ;all teams selected + N TIEN,OKAY,XLIST,YLIST,SCTP,SCI,SCDT,PLIST + S SCDT("BEGIN")=$P(RANGE,U),SCDT("END")=$P(RANGE,U,2) + S SCDT("INCL")=0,SCDT="SCDT" + S TIEN="",PLIST="^TMP(""SCRP"",$J,""LIST"")" + F S TIEN=$O(TEAM(TIEN)) Q:TIEN=""!(TIEN'?.N) D + .K XLIST,@PLIST + .S OKAY=$$TPTM^SCAPMC(TIEN,.SCDT,"","","XLIST","ERROR") + .S SCTP=0 F S SCTP=$O(XLIST("SCTP",TIEN,SCTP)) Q:'SCTP D + ..S SCTP0=$G(^SCTM(404.57,SCTP,0)) Q:'$L(SCTP0) + ..I ROLE'=1,'$D(ROLE(+$P(SCTP0,U,3))) Q ;not a selected role + ..I $D(USERC),USERC'=1,'$D(USERC(+$P(SCTP0,U,13))) Q ;not a selected user class + ..K YLIST + ..S OKAY=$$PRTP^SCAPMC(SCTP,.SCDT,"YLIST","ERROR",1,0) + ..S SCI=0 F S SCI=$O(YLIST(SCI)) Q:'SCI D + ...S @PLIST@(0)=$G(@PLIST@(0))+1 + ...S @PLIST@(@PLIST@(0))=YLIST(SCI) + ...Q + ..Q + .I OKAY D PULL^SCRPTM2(TIEN,.PLIST) + .Q + Q + ; +TALL ; + ;get all active team for divisions selected + N NXT,IIEN,NODE + S NXT=0,IIEN="" + ;$O through team file and find all active teams for selected divisions + F S IIEN=$O(^SCTM(404.51,"AINST",IIEN)) Q:IIEN="" D + .I INST=1!$D(INST(IIEN)) D + ..S TIEN=0 + ..F S TIEN=$O(^SCTM(404.51,"AINST",IIEN,TIEN)) Q:TIEN="" D + ...I $$ACTTM^SCMCTMU(TIEN) S TEAM(TIEN)="" + Q + ; +PRINTIT(STORE,TITL) ; + N INST,EINST,ETEAM,TEM,EPRACT,PRACT,PAGE,NXT,NPAGE,CNT,HEAD,POS + S EINST="",(NPAGE,STOP,HEAD)=0,PAGE=1 W:$E(IOST)="C" @IOF + D TITLE^SCRPU3(.PAGE,TITL) + F S EINST=$O(@STORE@("I",EINST)) Q:EINST=""!(STOP) D + .S INST=$O(@STORE@("I",EINST,"")) + .Q:INST="" + .I 'NPAGE W !,$G(@STORE@(INST)) ;write institution line + .S (ETEAM,TEM)="" + .F S ETEAM=$O(@STORE@("T",INST,ETEAM)) Q:ETEAM=""!(STOP) D + ..S TEM=$O(@STORE@("T",INST,ETEAM,0)) + ..I TEM="" Q + ..S NXT="H" + ..I NPAGE,(IOST'?1"C-".E) D NEWP^SCRPTM2(INST,TEM,TITL,.PAGE,.HEAD) S NPAGE=0 + ..I NPAGE,(IOST?1"C-".E) D HOLD1^SCRPTM2(.PAGE,TITL,INST,TEM,.HEAD) S NPAGE=0 + ..I STOP Q + ..I IOST'?1"C-".E,$Y>(IOSL-5) D NEWP^SCRPTM2(INST,TEM,TITL,.PAGE,.HEAD) + ..I IOST?1"C-".E,$Y>(IOSL-5) D HOLD1^SCRPTM2(.PAGE,TITL,INST,TEM,.HEAD) + ..I STOP Q + ..F S NXT=$O(@STORE@(INST,TEM,NXT)) Q:NXT'?1"H".E!(STOP) D + ...I 'HEAD W !,$G(@STORE@(INST,TEM,NXT)) S HEAD=0 ;writes team info + ..S (EPRACT,PRACT)="" + ..W ! ;extra line between members and practioner list + ..F S EPRACT=$O(@STORE@("PN",INST,TEM,EPRACT)) Q:EPRACT=""!(STOP) D + ...F S PRACT=$O(@STORE@("PN",INST,TEM,EPRACT,PRACT)) Q:PRACT=""!(STOP) D + ....I PRACT="" Q + ....S POS="" + ....F S POS=$O(@STORE@("PN",INST,TEM,EPRACT,PRACT,POS)) Q:POS=""!(STOP) D + .....D PRNTD(INST,TEM,PRACT,POS,TITL,.PAGE,.HEAD) + .....W ! ;seperated positions + ....W ! ;separates practitioners + .S NPAGE=1 + I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR + Q + ; +PRNTD(INST,TEM,PRACT,POS,TITL,PAGE,HEAD) ; + ; + N CNT + S CNT="" + I IOST'?1"C-".E,$Y>(IOSL-11) D NEWP^SCRPTM2(INST,TEM,TITL,.PAGE,.HEAD) + I IOST?1"C-".E,$Y>(IOSL-11) D HOLD1^SCRPTM2(.PAGE,TITL,INST,TEM,.HEAD) + I STOP Q + F S CNT=$O(@STORE@(INST,TEM,PRACT,POS,CNT)) Q:CNT=""!(STOP) D + .W !,$G(@STORE@(INST,TEM,PRACT,POS,CNT)) + Q diff --git a/r/SCHEDULING-SD-SC/SCRPTM2.m b/r/SCHEDULING-SD-SC/SCRPTM2.m index 963b7f90..7754b6cf 100644 --- a/r/SCHEDULING-SD-SC/SCRPTM2.m +++ b/r/SCHEDULING-SD-SC/SCRPTM2.m @@ -1,137 +1,128 @@ -SCRPTM2 ;ALB/CMM - List of Team's Members Report Continued;01/29/96 ; 29 Jun 99 04:11PM - ;;5.3;Scheduling;**41,140,177,520**;AUG 13, 1993;Build 26 - ; - ;List of Team's Members Report - ; -PULL(TIEN,PLIST) ; - ;TIEN - team file ien - ;PLIST - array of positions and their practitioners - ; - N PNAME,TPIEN,ACT,INACT,RNAME,UNAME,CNT,NODE,TNODE,PCLIN,TNAME,SCI - N TPHONE,TPC,INS,INAME,PRIEN,PRNAME,OPH,ROOM,SERV,TPNODE,PRCP,PCLASS - ; - S CNT=0 - F S CNT=$O(@PLIST@(CNT)) Q:CNT=""!(CNT'?.N) D - .;get each practitioner/position - .S NODE=$G(@PLIST@(CNT)) - .S TPIEN=+$P(NODE,"^",3) ;team position ien - .S PNAME=$P(NODE,"^",4) ;position name - .S ACT=$P(NODE,"^",9) ;active date (fm) - .I ACT'=""&(ACT'=0) S ACT=$TR($$FMTE^XLFDT(ACT,"5DF")," ","0") - .S INACT=$P(NODE,"^",10) ;inactive date (fm) - .I INACT'=""&(INACT'=0) S INACT=$TR($$FMTE^XLFDT(INACT,"5DF")," ","0") - .S RNAME=$P(NODE,"^",8) ;standard role name - .S UNAME=$P(NODE,"^",6) ;user class name - .S PRIEN=+$P(NODE,"^") ;practitioner ien - .S PRNAME=$P(NODE,"^",2) ;practitioner name - .; - .;Get person class information - .S PCLASS=$$GET^XUA4A72(PRIEN) - .F SCI=1,2,3 S PCLASS(SCI)=$P(PCLASS,U,(SCI+1)) - .; - .S TPNODE=$G(^SCTM(404.57,+TPIEN,0)) - .D SETASCL^SCRPRAC2(TPIEN,.PCLIN) - .S PCLIN=$G(PCLIN(0)) - .;S PCLIN=+$P(TPNODE,"^",9) ;associated clinic ien - .;S PCLIN=$P($G(^SC(PCLIN,0)),"^") ;associated clinic name - .; - .;Get preceptor - .S PRCP=$P($$OKPREC2^SCMCLK(TPIEN,DT),U,2) - .; - .S TNODE=$G(^SCTM(404.51,TIEN,0)) ;team node - .S TNAME=$P(TNODE,"^") ;team name - .S TPHONE=$P(TNODE,"^",2) ;team phone - .S TPC=$S($P(TNODE,"^",5)=1:"YES",1:"NO") ;primary care? - .S INS=+$P(TNODE,"^",7) ;team division ien - .S INAME=$P($G(^DIC(4,INS,0)),"^") ;team division name - .D KTEAM(TNAME,TPHONE,TPC,INAME,TIEN,INS) - .; - .S OPH=$P($G(^VA(200,PRIEN,.13)),"^",2) ;office phone - .S ROOM=$P($G(^VA(200,PRIEN,.14)),"^") ;room - .S SERV=+$P($G(^VA(200,PRIEN,5)),"^") ;service/section ien - .S SERV=$P($G(^DIC(49,SERV,0)),"^") ;service/section name - .; - .D FORMAT(PNAME,TPIEN,PCLIN,RNAME,UNAME,ACT,INACT,PRIEN,PRNAME,OPH,ROOM,SERV,INS,TIEN,PRCP,.PCLASS) - .N SCAC - .S SCAC=0 - .F S SCAC=$O(PCLIN(SCAC)) Q:SCAC="" D FORMATAC(INS,TIEN,PRIEN,TPIEN,PCLIN(SCAC)) - Q - ; -KTEAM(TNAME,TPHONE,TPC,TDIV,TIEN,IEND) ; - ;store team information - I TDIV="" S TDIV="[BAD DATA]" - I TNAME="" S TNAME="[BDA DATA]" - S @STORE@("I",TDIV,IEND)="" - S @STORE@("T",IEND,TNAME,TIEN)="" - S @STORE@(IEND)="Division: "_TDIV - S @STORE@(IEND,TIEN,"H1")="Team Name: "_TNAME - S $E(@STORE@(IEND,TIEN,"H1"),40)="Team Phone: "_TPHONE - S @STORE@(IEND,TIEN,"H2")="Primary Care Team: "_TPC - S @STORE@(IEND,TIEN,"H3")="" - S @STORE@(IEND,TIEN,"H4")="Members:" - Q - ; -FORMAT(POS,TPIEN,PCLIN,SPOS,UCLASS,BEG,END,PIEN,PRACT,OPH,ROOM,SERV,DIV,TEM,PRCP,PCLASS) ; - ;POS - position name - ;TPIEN - position ien - ;PCLIN - associated clinic - ;SPOS - standard position - ;UCLASS - user class - ;BEG - begin date - ;END - end date - ;PIEN - ien of new person file - ;PRACT - practitioner name - ;OPH - office number - ;ROOM - room - ;SERV - service - ;DIV - ien of division - ;TEM - ien of team - ;PRCP - preceptor - ;PCLASS - person class - ; - N SCI - I PRACT="" S PRACT="[BAD DATA]" - S @STORE@("PN",DIV,TEM,PRACT,PIEN,TPIEN)="" - S @STORE@(DIV,TEM,PIEN,TPIEN,1)=PRACT - S $E(@STORE@(DIV,TEM,PIEN,TPIEN,1),35)="Position: "_POS - S @STORE@(DIV,TEM,PIEN,TPIEN,2)="Standard Role: "_SPOS - S @STORE@(DIV,TEM,PIEN,TPIEN,3)="User Class: "_UCLASS - S @STORE@(DIV,TEM,PIEN,TPIEN,4)=SERV - S $E(@STORE@(DIV,TEM,PIEN,TPIEN,4),35)="Assoc Clinic: "_PCLIN - S @STORE@(DIV,TEM,PIEN,TPIEN,5)="Office Phone: "_OPH - S $E(@STORE@(DIV,TEM,PIEN,TPIEN,5),35)="Room: "_ROOM - S @STORE@(DIV,TEM,PIEN,TPIEN,6)="Begin Date: "_BEG - S $E(@STORE@(DIV,TEM,PIEN,TPIEN,6),35)="End Date: "_END - S SCI=7 - I $L(PRCP) S @STORE@(DIV,TEM,PIEN,TPIEN,SCI)="Preceptor: "_PRCP,SCI=8 - I $L(PCLASS(1)) S @STORE@(DIV,TEM,PIEN,TPIEN,SCI)="Person Class: "_PCLASS(1),SCI=SCI+1 - I $L(PCLASS(2)) S @STORE@(DIV,TEM,PIEN,TPIEN,SCI)=" "_PCLASS(2),SCI=SCI+1 - I $L(PCLASS(3)) S @STORE@(DIV,TEM,PIEN,TPIEN,SCI)=" "_PCLASS(3) - Q - ; -FORMATAC(DIV,TEM,PIEN,TPIEN,PCLIN) ; - S $E(@STORE@(DIV,TEM,PIEN,TPIEN,4,SCAC),49)=$E(PCLIN,1,30) - Q - ; -NEWP(INST,TEM,TITL,PAGE,HEAD) ; - ;new page - D NEWP1^SCRPU3(.PAGE,TITL) - D HEAD1(INST,TEM,.HEAD) - Q - ; -HEAD1(INST,TEM,HEAD) ; - ;write headings - W !,$G(@STORE@(INST)) - N NXT - S NXT="H" - F S NXT=$O(@STORE@(INST,TEM,NXT)) Q:NXT'?1"H".E D - .W !,$G(@STORE@(INST,TEM,NXT)) - W ! ;extra line between MEMBERS and practitioner list - S HEAD=1 - Q -HOLD1(PAGE,TITL,INST,TEM,HEAD) ; - ;device is home, reached end of page - D HOLD^SCRPU3(.PAGE,TITL) - I STOP Q - D HEAD1(INST,TEM,.HEAD) - Q +SCRPTM2 ;ALB/CMM - List of Team's Members Report Continued;01/29/96 ; 29 Jun 99 04:11PM + ;;5.3;Scheduling;**41,140,177**;AUG 13, 1993 + ; + ;List of Team's Members Report + ; +PULL(TIEN,PLIST) ; + ;TIEN - team file ien + ;PLIST - array of positions and their practitioners + ; + N PNAME,TPIEN,ACT,INACT,RNAME,UNAME,CNT,NODE,TNODE,PCLIN,TNAME,SCI + N TPHONE,TPC,INS,INAME,PRIEN,PRNAME,OPH,ROOM,SERV,TPNODE,PRCP,PCLASS + ; + S CNT=0 + F S CNT=$O(@PLIST@(CNT)) Q:CNT=""!(CNT'?.N) D + .;get each practitioner/position + .S NODE=$G(@PLIST@(CNT)) + .S TPIEN=+$P(NODE,"^",3) ;team position ien + .S PNAME=$P(NODE,"^",4) ;position name + .S ACT=$P(NODE,"^",9) ;active date (fm) + .I ACT'=""&(ACT'=0) S ACT=$TR($$FMTE^XLFDT(ACT,"5DF")," ","0") + .S INACT=$P(NODE,"^",10) ;inactive date (fm) + .I INACT'=""&(INACT'=0) S INACT=$TR($$FMTE^XLFDT(INACT,"5DF")," ","0") + .S RNAME=$P(NODE,"^",8) ;standard role name + .S UNAME=$P(NODE,"^",6) ;user class name + .S PRIEN=+$P(NODE,"^") ;practitioner ien + .S PRNAME=$P(NODE,"^",2) ;practitioner name + .; + .;Get person class information + .S PCLASS=$$GET^XUA4A72(PRIEN) + .F SCI=1,2,3 S PCLASS(SCI)=$P(PCLASS,U,(SCI+1)) + .; + .S TPNODE=$G(^SCTM(404.57,+TPIEN,0)) + .S PCLIN=+$P(TPNODE,"^",9) ;associated clinic ien + .S PCLIN=$P($G(^SC(PCLIN,0)),"^") ;associated clinic name + .; + .;Get preceptor + .S PRCP=$P($$OKPREC2^SCMCLK(TPIEN,DT),U,2) + .; + .S TNODE=$G(^SCTM(404.51,TIEN,0)) ;team node + .S TNAME=$P(TNODE,"^") ;team name + .S TPHONE=$P(TNODE,"^",2) ;team phone + .S TPC=$S($P(TNODE,"^",5)=1:"YES",1:"NO") ;primary care? + .S INS=+$P(TNODE,"^",7) ;team division ien + .S INAME=$P($G(^DIC(4,INS,0)),"^") ;team division name + .D KTEAM(TNAME,TPHONE,TPC,INAME,TIEN,INS) + .; + .S OPH=$P($G(^VA(200,PRIEN,.13)),"^",2) ;office phone + .S ROOM=$P($G(^VA(200,PRIEN,.14)),"^") ;room + .S SERV=+$P($G(^VA(200,PRIEN,5)),"^") ;service/section ien + .S SERV=$P($G(^DIC(49,SERV,0)),"^") ;service/section name + .; + .D FORMAT(PNAME,TPIEN,PCLIN,RNAME,UNAME,ACT,INACT,PRIEN,PRNAME,OPH,ROOM,SERV,INS,TIEN,PRCP,.PCLASS) + Q + ; +KTEAM(TNAME,TPHONE,TPC,TDIV,TIEN,IEND) ; + ;store team information + I TDIV="" S TDIV="[BAD DATA]" + I TNAME="" S TNAME="[BDA DATA]" + S @STORE@("I",TDIV,IEND)="" + S @STORE@("T",IEND,TNAME,TIEN)="" + S @STORE@(IEND)="Division: "_TDIV + S @STORE@(IEND,TIEN,"H1")="Team Name: "_TNAME + S $E(@STORE@(IEND,TIEN,"H1"),40)="Team Phone: "_TPHONE + S @STORE@(IEND,TIEN,"H2")="Primary Care Team: "_TPC + S @STORE@(IEND,TIEN,"H3")="" + S @STORE@(IEND,TIEN,"H4")="Members:" + Q + ; +FORMAT(POS,TPIEN,PCLIN,SPOS,UCLASS,BEG,END,PIEN,PRACT,OPH,ROOM,SERV,DIV,TEM,PRCP,PCLASS) ; + ;POS - position name + ;TPIEN - position ien + ;PCLIN - associated clinic + ;SPOS - standard position + ;UCLASS - user class + ;BEG - begin date + ;END - end date + ;PIEN - ien of new person file + ;PRACT - practitioner name + ;OPH - office number + ;ROOM - room + ;SERV - service + ;DIV - ien of division + ;TEM - ien of team + ;PRCP - preceptor + ;PCLASS - person class + ; + N SCI + I PRACT="" S PRACT="[BAD DATA]" + S @STORE@("PN",DIV,TEM,PRACT,PIEN,TPIEN)="" + S @STORE@(DIV,TEM,PIEN,TPIEN,1)=PRACT + S $E(@STORE@(DIV,TEM,PIEN,TPIEN,1),35)="Position: "_POS + S @STORE@(DIV,TEM,PIEN,TPIEN,2)="Standard Role: "_SPOS + S @STORE@(DIV,TEM,PIEN,TPIEN,3)="User Class: "_UCLASS + S @STORE@(DIV,TEM,PIEN,TPIEN,4)=SERV + S $E(@STORE@(DIV,TEM,PIEN,TPIEN,4),35)="Assoc Clinic: "_PCLIN + S @STORE@(DIV,TEM,PIEN,TPIEN,5)="Office Phone: "_OPH + S $E(@STORE@(DIV,TEM,PIEN,TPIEN,5),35)="Room: "_ROOM + S @STORE@(DIV,TEM,PIEN,TPIEN,6)="Begin Date: "_BEG + S $E(@STORE@(DIV,TEM,PIEN,TPIEN,6),35)="End Date: "_END + S SCI=7 + I $L(PRCP) S @STORE@(DIV,TEM,PIEN,TPIEN,SCI)="Preceptor: "_PRCP,SCI=8 + I $L(PCLASS(1)) S @STORE@(DIV,TEM,PIEN,TPIEN,SCI)="Person Class: "_PCLASS(1),SCI=SCI+1 + I $L(PCLASS(2)) S @STORE@(DIV,TEM,PIEN,TPIEN,SCI)=" "_PCLASS(2),SCI=SCI+1 + I $L(PCLASS(3)) S @STORE@(DIV,TEM,PIEN,TPIEN,SCI)=" "_PCLASS(3) + Q + ; +NEWP(INST,TEM,TITL,PAGE,HEAD) ; + ;new page + D NEWP1^SCRPU3(.PAGE,TITL) + D HEAD1(INST,TEM,.HEAD) + Q + ; +HEAD1(INST,TEM,HEAD) ; + ;write headings + W !,$G(@STORE@(INST)) + N NXT + S NXT="H" + F S NXT=$O(@STORE@(INST,TEM,NXT)) Q:NXT'?1"H".E D + .W !,$G(@STORE@(INST,TEM,NXT)) + W ! ;extra line between MEMBERS and practitioner list + S HEAD=1 + Q +HOLD1(PAGE,TITL,INST,TEM,HEAD) ; + ;device is home, reached end of page + D HOLD^SCRPU3(.PAGE,TITL) + I STOP Q + D HEAD1(INST,TEM,.HEAD) + Q diff --git a/r/SCHEDULING-SD-SC/SCRPTP.m b/r/SCHEDULING-SD-SC/SCRPTP.m index bc97c7e5..2b59ee59 100644 --- a/r/SCHEDULING-SD-SC/SCRPTP.m +++ b/r/SCHEDULING-SD-SC/SCRPTP.m @@ -1,177 +1,148 @@ -SCRPTP ;ALB/CMM - List of Team's Patients ; 29 Jun 99 04:11PM - ;;5.3;Scheduling;**41,48,174,177,526,520**;AUG 13, 1993;Build 26 - ; -PROMPTS ;Prompt for Institution, Team, Role, Patient Status and Print device - N QTIME,PRNT,VAUTD,VAUTT,VAUTR,VAUTPS,NUMBER - K SCUP - S QTIME="" - W ! D INST^SCRPU1 I Y=-1 G ERR - W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR - W ! K Y D ROLE^SCRPU1 I '$D(VAUTR) G ERR - W ! K Y D PTSTAT^SCRPU2 I '$D(VAUTPS) G ERR - W ! K Y S SORT=$$SORT2^SCRPU2() - I SORT<1 G ERR - W !!,"This report requires 132 column output!" - D QUE(.VAUTD,.VAUTT,.VAUTR,VAUTPS,SORT) Q - ; -QUE(INST,TEAM,ROLE,PSTAT,SORT,IOP,ZTDTH) ;queue report - ;INST - institutions selected (variable and array) - ;TEAM - teams selected (variable and array) - ;ROLE - roles selected (variable and array) - ;PSTAT - patient status - 1=all or OPT or AC - ;SORT - 1=d,t,ptname 2=d,t,Pt ID 3=d,t,pract,pt name 4=d,t,pract,Pt ID - N ZTSAVE,II - F II="INST","TEAM","ROLE","ROLE(","SORT","PSTAT","INST(","TEAM(" S ZTSAVE(II)="" - W ! D EN^XUTMDEVQ("QENTRY^SCRPTP","Team Patient Listing",.ZTSAVE) - Q - ; -ENTRY2(INST,TEAM,ROLE,PSTAT,SORT,IOP,ZTDTH) ;Second entry point for GUI to use - ;INST - institutions selected (variable and array) - ;TEAM - teams selected (variable and array) - ;ROLE - roles selected (variable and array) - ;PSTAT - patient status - 1=all or OPT or AC - ;SORT - 1=d,t,ptname 2=d,t,Pt ID 3=d,t,pract,pt name 4=d,t,pract,Pt ID - ;IOP - print device - ;ZTDTH - queue time (optional) - ; - ;validate parameters - I '$D(INST)!'$D(TEAM)!'$D(ROLE)!'$D(PSTAT)!'$D(SORT)!'$D(IOP)!(IOP="") Q - N NUMBER - S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^") - I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2) - I IOST?1"C-".E D QENTRY G RET - I ZTDTH="" S ZTDTH=$H - S ZTRTN="QENTRY^SCRPTP" - S ZTDESC="List of Team's Patients",ZTIO=IOP - N II - F II="INST","TEAM","ROLE","ROLE(","SORT","PSTAT","INST(","TEAM(","IOP" S ZTSAVE(II)="" - D ^%ZTLOAD -RET S NUMBER=0 - I $D(ZTSK) S NUMBER=ZTSK - D EXIT1 - Q NUMBER - ; -QENTRY ;driver entry point - S TITL="Team Patient Listing",STORE="^TMP("_$J_",""SCRPTP"")" - K @STORE - S @STORE=0 - D FIND - I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL) - I '$D(NODATA) D PRINTIT^SCRPTP2(STORE,TITL) - D EXIT2 - Q -ERR ; -EXIT1 ; - K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE,SCUP - Q -EXIT2 ; - K @STORE - K STOP,STORE,TITL,IOP,TEAM,INST,ROLE,PSTAT,SORT,NODATA - Q -FIND ; - N TIEN,ERR,LIST,OKAY - I TEAM=1 D TALL^SCRPPAT3 ;gets all teams for all divisions selected - S TIEN="",LIST="^TMP("_$J_",""SCRPTP ARRAY"")",ERR="ERROR" - K @LIST,@ERR - F S TIEN=$O(TEAM(TIEN)) Q:TIEN="" D - .;TIEN - team ien - .S OKAY=$$PTTM^SCAPMC2(TIEN,"",LIST,ERR) - .; gets all patients for given team - .D HITS^SCRPTP3(LIST,TIEN) - .K @LIST,@ERR - K @LIST,@ERR - Q -TINF(TIEN) ;team information - ;TIEN - team ien - ;returns: institution ien ^ team name ^ primary care ^ team phone - N PC,PHONE,TNODE,TNAME - S TNODE=$G(^SCTM(404.51,TIEN,0)) - S TNAME=$P(TNODE,"^") ;team name - S PC=$S($P(TNODE,"^",5)=1:"YES",1:"NO") ;primary care team - S PHONE=$P(TNODE,"^",2) ;team phone - S INS=+$P(TNODE,"^",7) ;institution ien - D TDESC^SCRPITP2(TIEN,INS) ;gets team description - Q INS_"^"_TNAME_"^"_PC_"^"_PHONE - ; -PST(PTIEN,CLIEN) ; - ;PTIEN - patient ien - ;CLIEN - associated clinic ien - ;returns 1=selected patient status, 0=not selected patient status - ; - N EN,NXT,FOUND,ENODE - S EN="",(FOUND,NXT)=0 - Q:'$D(^DPT(PTIEN,"DE","B",CLIEN)) FOUND - S EN=$O(^DPT(PTIEN,"DE","B",CLIEN,"")) - I EN=""&(PSTAT=1) S FOUND=1 Q FOUND - Q:EN=""!'$D(^DPT(PTIEN,"DE",EN,1)) FOUND - F S NXT=$O(^DPT(PTIEN,"DE",EN,1,NXT)) Q:(FOUND)!(NXT="")!(NXT'?.N) D - .;check if active enrollment - .S ENODE=$G(^DPT(PTIEN,"DE",EN,1,NXT,0)) - .I $P(ENODE,"^",3)'="",$P(ENODE,"^",3)DT Q ;not active enrollment - .; ^ discharge date ^ enrollment date - .Q:$P(ENODE,"^",2)'=$E(PSTAT,1)&(PSTAT'=1) ;not selected patient status - .S FOUND=1 - Q FOUND - ; -FORMAT(INS,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,CNAME,PINF,ROLN,PCAP) ;Format column information - ;INS - Institution ien - ;TIEN - team ien - ;PTIEN - patient ien - ;PTNAME - patient name - ;PID - SSN - ;PIEN - practitioner ien - ;PNAME - practitioner name - ;CNAME - clinic name - ;LAST - last appointment - ;NEXT - next appointment - ;ROLN - role name - ;PCAP - PC? - ; - N SEC,TRD - I PNAME="" S PNAME="[BAD DATA]" - I PTNAME="" S PTNAME="[BAD DATA]" - I PID="" S PID="*********" - S @STORE@("P",INS,TIEN,PNAME,PIEN)="" ;practitioner - S @STORE@("PT",INS,TIEN,PTNAME,PTIEN)="" ;patient - S @STORE@("PID",INS,TIEN,PID,PTIEN)="" - I (SORT=1)!(SORT=2) S SEC=PTIEN,TRD=PIEN ;sort doesn't include practitioner - I (SORT=3)!(SORT=4) S SEC=PIEN,TRD=PTIEN ;sort includes practitioner - S @STORE@(INS,TIEN,SEC,TRD)=$E(PTNAME,1,15) ;patient name - S $E(@STORE@(INS,TIEN,SEC,TRD),18)=PID ;9 digit pid - S $E(@STORE@(INS,TIEN,SEC,TRD),32)=$E(PNAME,1,22) ;practitioner name - S $E(@STORE@(INS,TIEN,SEC,TRD),56)=$E($G(ROLN),1,22) ;role name - S $E(@STORE@(INS,TIEN,SEC,TRD),80)=$G(PCAP) ;PC? - S $E(@STORE@(INS,TIEN,SEC,TRD),85)=$P(PINF,"^",8) ;last appointment - S $E(@STORE@(INS,TIEN,SEC,TRD),97)=$P(PINF,"^",9) ;next appointment - S $E(@STORE@(INS,TIEN,SEC,TRD),109)=$E(CNAME,1,24) ;clinic name - Q -FORMATAC(SCCNT,CNAME,PINF,INS,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,ROLN,PCAP) ;Format MULTIPLES - ;INS - Institution ien - ;TIEN - team ien - ;PTIEN - patient ien - ;PTNAME - patient name - ;PID - last 4 PID - includes pseudo notation as 5th - ;PIEN - practitioner ien - ;PNAME - practitioner name - ;CNAME - clinic name - ;LAST - last appointment - ;NEXT - next appointment - ;ROLN - role name - ;PCAP - PC? - ; - N SEC,TRD - I PNAME="" S PNAME="[BAD DATA]" - I PTNAME="" S PTNAME="[BAD DATA]" - I PID="" S PID="****" - S @STORE@("P",INS,TIEN,PNAME,PIEN)="" ;practitioner - S @STORE@("PT",INS,TIEN,PTNAME,PTIEN)="" ;patient - S @STORE@("PID",INS,TIEN,PID,PTIEN)="" ;last 4 pid - N TRD - I (SORT=1)!(SORT=2) S SEC=PTIEN,TRD=PIEN ;sort doesn't include practitioner - I (SORT=3)!(SORT=4) S SEC=PIEN,TRD=PTIEN ;sort includes practitioner - I '$D(@STORE@(INS,TIEN,SEC,TRD,SCCNT)) D - .S $E(@STORE@(INS,TIEN,SEC,TRD,SCCNT),85)=$P(PINF,"^",8) ;last appointment - .S $E(@STORE@(INS,TIEN,SEC,TRD,SCCNT),97)=$P(PINF,"^",9) ;next appointment - .S $E(@STORE@(INS,TIEN,SEC,TRD,SCCNT),109)=$E(CNAME,1,24) ;clinic name - .Q - Q +SCRPTP ;ALB/CMM - List of Team's Patients ; 29 Jun 99 04:11PM + ;;5.3;Scheduling;**41,48,174,177**;AUG 13, 1993 + ; +PROMPTS ;Prompt for Institution, Team, Role, Patient Status and Print device + N QTIME,PRNT,VAUTD,VAUTT,VAUTR,VAUTPS,NUMBER + K SCUP + S QTIME="" + W ! D INST^SCRPU1 I Y=-1 G ERR + W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR + W ! K Y D ROLE^SCRPU1 I '$D(VAUTR) G ERR + W ! K Y D PTSTAT^SCRPU2 I '$D(VAUTPS) G ERR + W ! K Y S SORT=$$SORT2^SCRPU2() + I SORT<1 G ERR + W !!,"This report requires 132 column output!" + D QUE(.VAUTD,.VAUTT,.VAUTR,VAUTPS,SORT) Q + ; +QUE(INST,TEAM,ROLE,PSTAT,SORT,IOP,ZTDTH) ;queue report + ;INST - institutions selected (variable and array) + ;TEAM - teams selected (variable and array) + ;ROLE - roles selected (variable and array) + ;PSTAT - patient status - 1=all or OPT or AC + ;SORT - 1=d,t,ptname 2=d,t,last 4 Pt ID 3=d,t,pract,pt name 4=d,t,pract,last 4 Pt ID + N ZTSAVE,II + F II="INST","TEAM","ROLE","ROLE(","SORT","PSTAT","INST(","TEAM(" S ZTSAVE(II)="" + W ! D EN^XUTMDEVQ("QENTRY^SCRPTP","Team Patient Listing",.ZTSAVE) + Q + ; +ENTRY2(INST,TEAM,ROLE,PSTAT,SORT,IOP,ZTDTH) ;Second entry point for GUI to use + ;INST - institutions selected (variable and array) + ;TEAM - teams selected (variable and array) + ;ROLE - roles selected (variable and array) + ;PSTAT - patient status - 1=all or OPT or AC + ;SORT - 1=d,t,ptname 2=d,t,last 4 Pt ID 3=d,t,pract,pt name 4=d,t,pract,last 4 Pt ID + ;IOP - print device + ;ZTDTH - queue time (optional) + ; + ;validate parameters + I '$D(INST)!'$D(TEAM)!'$D(ROLE)!'$D(PSTAT)!'$D(SORT)!'$D(IOP)!(IOP="") Q + N NUMBER + S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^") + I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2) + I IOST?1"C-".E D QENTRY G RET + I ZTDTH="" S ZTDTH=$H + S ZTRTN="QENTRY^SCRPTP" + S ZTDESC="List of Team's Patients",ZTIO=IOP + N II + F II="INST","TEAM","ROLE","ROLE(","SORT","PSTAT","INST(","TEAM(","IOP" S ZTSAVE(II)="" + D ^%ZTLOAD +RET S NUMBER=0 + I $D(ZTSK) S NUMBER=ZTSK + D EXIT1 + Q NUMBER + ; +QENTRY ;driver entry point + S TITL="Team Patient Listing",STORE="^TMP("_$J_",""SCRPTP"")" + K @STORE + S @STORE=0 + D FIND + I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL) + I '$D(NODATA) D PRINTIT^SCRPTP2(STORE,TITL) + D EXIT2 + Q +ERR ; +EXIT1 ; + K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE,SCUP + Q +EXIT2 ; + K @STORE + K STOP,STORE,TITL,IOP,TEAM,INST,ROLE,PSTAT,SORT,NODATA + Q +FIND ; + N TIEN,ERR,LIST,OKAY + I TEAM=1 D TALL^SCRPPAT3 ;gets all teams for all divisions selected + S TIEN="",LIST="^TMP("_$J_",""SCRPTP ARRAY"")",ERR="ERROR" + K @LIST,@ERR + F S TIEN=$O(TEAM(TIEN)) Q:TIEN="" D + .;TIEN - team ien + .S OKAY=$$PTTM^SCAPMC2(TIEN,"",LIST,ERR) + .; gets all patients for given team + .D HITS^SCRPTP3(LIST,TIEN) + .K @LIST,@ERR + K @LIST,@ERR + Q +TINF(TIEN) ;team information + ;TIEN - team ien + ;returns: institution ien ^ team name ^ primary care ^ team phone + N PC,PHONE,TNODE,TNAME + S TNODE=$G(^SCTM(404.51,TIEN,0)) + S TNAME=$P(TNODE,"^") ;team name + S PC=$S($P(TNODE,"^",5)=1:"YES",1:"NO") ;primary care team + S PHONE=$P(TNODE,"^",2) ;team phone + S INS=+$P(TNODE,"^",7) ;institution ien + D TDESC^SCRPITP2(TIEN,INS) ;gets team description + Q INS_"^"_TNAME_"^"_PC_"^"_PHONE + ; +PST(PTIEN,CLIEN) ; + ;PTIEN - patient ien + ;CLIEN - associated clinic ien + ;returns 1=selected patient status, 0=not selected patient status + ; + N EN,NXT,FOUND,ENODE + S EN="",(FOUND,NXT)=0 + Q:'$D(^DPT(PTIEN,"DE","B",CLIEN)) FOUND + S EN=$O(^DPT(PTIEN,"DE","B",CLIEN,"")) + I EN=""&(PSTAT=1) S FOUND=1 Q FOUND + Q:EN=""!'$D(^DPT(PTIEN,"DE",EN,1)) FOUND + F S NXT=$O(^DPT(PTIEN,"DE",EN,1,NXT)) Q:(FOUND)!(NXT="")!(NXT'?.N) D + .;check if active enrollment + .S ENODE=$G(^DPT(PTIEN,"DE",EN,1,NXT,0)) + .I $P(ENODE,"^",3)'="",$P(ENODE,"^",3)DT Q ;not active enrollment + .; ^ discharge date ^ enrollment date + .Q:$P(ENODE,"^",2)'=$E(PSTAT,1)&(PSTAT'=1) ;not selected patient status + .S FOUND=1 + Q FOUND + ; +FORMAT(INS,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,CNAME,LAST,NEXT,ROLN,PCAP) ;Format column information + ;INS - Institution ien + ;TIEN - team ien + ;PTIEN - patient ien + ;PTNAME - patient name + ;PID - last 4 PID - includes pseudo notation as 5th + ;PIEN - practitioner ien + ;PNAME - practitioner name + ;CNAME - clinic name + ;LAST - last appointment + ;NEXT - next appointment + ;ROLN - role name + ;PCAP - PC? + ; + N SEC,TRD + I PNAME="" S PNAME="[BAD DATA]" + I PTNAME="" S PTNAME="[BAD DATA]" + I PID="" S PID="****" + S @STORE@("P",INS,TIEN,PNAME,PIEN)="" ;practitioner + S @STORE@("PT",INS,TIEN,PTNAME,PTIEN)="" ;patient + S @STORE@("PID",INS,TIEN,PID,PTIEN)="" ;last 4 pid + N TRD + I (SORT=1)!(SORT=2) S SEC=PTIEN,TRD=PIEN ;sort doesn't include practitioner + I (SORT=3)!(SORT=4) S SEC=PIEN,TRD=PTIEN ;sort includes practitioner + S @STORE@(INS,TIEN,SEC,TRD)=$E(PTNAME,1,22) ;patient name + S $E(@STORE@(INS,TIEN,SEC,TRD),25)=PID ;last 4 pid + S $E(@STORE@(INS,TIEN,SEC,TRD),32)=$E(PNAME,1,22) ;practitioner name + S $E(@STORE@(INS,TIEN,SEC,TRD),56)=$E($G(ROLN),1,22) ;role name + S $E(@STORE@(INS,TIEN,SEC,TRD),80)=$G(PCAP) ;PC? + S $E(@STORE@(INS,TIEN,SEC,TRD),85)=LAST ;last appointment + S $E(@STORE@(INS,TIEN,SEC,TRD),97)=NEXT ;next appointment + S $E(@STORE@(INS,TIEN,SEC,TRD),109)=$E(CNAME,1,24) ;clinic name + Q diff --git a/r/SCHEDULING-SD-SC/SCRPTP2.m b/r/SCHEDULING-SD-SC/SCRPTP2.m index 2735d77d..ae1f7287 100644 --- a/r/SCHEDULING-SD-SC/SCRPTP2.m +++ b/r/SCHEDULING-SD-SC/SCRPTP2.m @@ -1,149 +1,143 @@ -SCRPTP2 ;ALB/CMM - List of Team's Patients ; 29 Jun 99 04:11PM - ;;5.3;Scheduling;**41,53,52,174,177,231,526,520**;AUG 13, 1993;Build 26 - ; - ;List of Team's Patients Report - ; -TFORMAT(INST,INAME,TIEN,TNAME,PHONE,PC) ; Format team information - ;INST - institution ien - ;INAME - institution name - ;TIEN - team ien - ;TNAME - team name - ;PHONE - team phone - ;PC - primary care team (yes/no) - ; - I INAME="" S INAME="[BAD DATA]" - I TNAME="" S TNAME="[BAD DATA]" - S @STORE@("I",INAME,INST)="" - S @STORE@("T",INST,TNAME,TIEN)="" - S @STORE@(INST)="Division: "_INAME - S @STORE@(INST,TIEN)="Team: "_TNAME - S $E(@STORE@(INST,TIEN),45)="Team Phone: "_PHONE - S @STORE@(INST,TIEN,1)="Primary Care Team: "_PC - Q - ; -PRINTIT(STORE,TITL) ; - N INST,INAME,TNAME,TIEN - S (NEW,PAGE)=1,STOP=0 W:$E(IOST)="C" @IOF - D TITLE^SCRPU3(.PAGE,TITL,132) ;write title - D SETH - ; - S INAME="" - F S INAME=$O(@STORE@("I",INAME)) Q:INAME=""!(STOP) D - .S INST=$O(@STORE@("I",INAME,"")) - .Q:INST="" - .I ('NEW)&(IOST'?1"C-".E) D NEWP1^SCRPU3(.PAGE,TITL,132) - .I ('NEW)&(IOST?1"C-".E) D HOLD^SCRPU3(.PAGE,TITL,132) - .Q:STOP - .W !,$G(@STORE@(INST)) ;write institution - .S TNAME="" - .F S TNAME=$O(@STORE@("T",INST,TNAME)) Q:TNAME=""!(STOP) D - ..S TIEN=$O(@STORE@("T",INST,TNAME,"")) - ..Q:TIEN="" - ..D TPRINT(INST,TIEN) ;writes team info - ..Q:STOP - ..; - ..I (IOST'?1"C-".E)&($Y>(IOSL-4)) D NEWP1^SCRPU3(.PAGE,TITL,132) - ..I (IOST?1"C-".E)&($Y>(IOSL-4)) D HOLD^SCRPU3(.PAGE,TITL,132) - ..Q:STOP - ..D HEADER - ..I (SORT=3)!(SORT=4) D PRACT(INST,TIEN,.NEW) - ..I (SORT=1)!(SORT=2) D PTP(INST,TIEN,.NEW) - K NEW,PAGE - I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR - Q - ; -PRACT(INST,TIEN,NEW) ;Print by practitioner/patient - N PNAME,PIEN,SEC2,ST1,TRD,TRDI - S PNAME="",PIEN="" - F S PNAME=$O(@STORE@("P",INST,TIEN,PNAME)) Q:PNAME=""!(STOP) D - . F S PIEN=$O(@STORE@("P",INST,TIEN,PNAME,PIEN)) Q:PIEN=""!(STOP) D - . . I (SORT=1)!(SORT=3) S SEC2="""PT""" ;sort by patient name - . . I (SORT=2)!(SORT=4) S SEC2="""PID""" ;sort by last 4 PID - . . S ST1=$E(STORE,1,$L(STORE)-1)_","_SEC2_")" - . . I (IOST'?1"C-".E)&($Y>(IOSL-4)) D NEWP1^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER - . . Q:STOP - . . I (IOST?1"C-".E)&($Y>(IOSL-4)) D HOLD^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER - . . Q:STOP - . . S (TRDI,TRD)="" - . . F S TRD=$O(@ST1@(INST,TIEN,TRD)) Q:TRD=""!(STOP) D - . . . F S TRDI=$O(@ST1@(INST,TIEN,TRD,TRDI)) Q:TRDI=""!(STOP) D - . . . . I (IOST'?1"C-".E)&($Y>(IOSL-4)) D NEWP1^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER - . . . . Q:STOP - . . . . I (IOST?1"C-".E)&($Y>(IOSL-4)) D HOLD^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER - . . . . Q:STOP - . . . . I $D(@STORE@(INST,TIEN,PIEN,TRDI)) W !,$G(@STORE@(INST,TIEN,PIEN,TRDI)) ;write column data - . . . . N SCACL - . . . . S SCACL="" F S SCACL=$O(@STORE@(INST,TIEN,PIEN,TRDI,SCACL)) Q:SCACL="" D - . . . . . W !,$G(@STORE@(INST,TIEN,PIEN,TRDI,SCACL)) - . S NEW=0 - Q - ; -PTP(INST,TIEN,NEW) ;Print by patient/practitioner - N SEC2,ST1,TRDI,TRD,PNAME,PIEN - I (SORT=1)!(SORT=3) S SEC2="""PT""" ;sort by patient name - I (SORT=2)!(SORT=4) S SEC2="""PID""" ;sort by last 4 PID - S ST1=$E(STORE,1,$L(STORE)-1)_","_SEC2_")" - I (IOST'?1"C-".E)&($Y>(IOSL-4)) D NEWP1^SCRPU3(.PAGE,TITL,132) - I (IOST?1"C-".E)&($Y>(IOSL-4)) D HOLD^SCRPU3(.PAGE,TITL,132) - Q:STOP - S (TRDI,TRD)="" - F S TRD=$O(@ST1@(INST,TIEN,TRD)) Q:TRD=""!(STOP) D - . F S TRDI=$O(@ST1@(INST,TIEN,TRD,TRDI)) Q:TRDI=""!(STOP) D - . . I (IOST'?1"C-".E)&($Y>(IOSL-4)) D NEWP1^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER - . . Q:STOP - . . I (IOST?1"C-".E)&($Y>(IOSL-4)) D HOLD^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER - . . Q:STOP - . . S PNAME="",PIEN="" - . . F S PNAME=$O(@STORE@("P",INST,TIEN,PNAME)) Q:PNAME=""!(STOP)!(PIEN=0) D - . . . F S PIEN=$O(@STORE@("P",INST,TIEN,PNAME,PIEN)) Q:PIEN=""!(STOP) D - . . . . I (IOST'?1"C-".E)&($Y>(IOSL-4)) D NEWP1^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER - . . . . Q:STOP - . . . . I (IOST?1"C-".E)&($Y>(IOSL-4)) D HOLD^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER - . . . . Q:STOP - . . . . I $D(@STORE@(INST,TIEN,TRDI,PIEN)) W !,$G(@STORE@(INST,TIEN,TRDI,PIEN)) ;write column data - . . . . N SCACL - . . . . S SCACL="" F S SCACL=$O(@STORE@(INST,TIEN,TRDI,PIEN,SCACL)) Q:SCACL="" D - . . . . . W !,$G(@STORE@(INST,TIEN,TRDI,PIEN,SCACL)) - . S NEW=0 - Q - ; -TPRINT(INST,TIEN) ; - ;prints team data - N NXT - I (IOST'?1"C-".E)&($Y>(IOSL-13)) D NEWP1^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INST)) - I (IOST?1"C-".E)&($Y>(IOSL-13)) D HOLD^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INST)) - Q:STOP - W !!,$G(@STORE@(INST,TIEN)) - S NXT=0 - W !,$G(@STORE@(INST,TIEN,1)) ;write team info - Q:'$D(@STORE@(INST,TIEN,"D")) W ! - S NXT="" - ;write team description - F S NXT=$O(@STORE@(INST,TIEN,"D",NXT)) Q:NXT=""!(STOP) D - .I (IOST'?1"C-".E)&$Y>(IOSL-13) D NEWP1^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INST)) - .I (IOST?1"C-".E)&$Y>(IOSL-13) D HOLD^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INST)) - .Q:STOP - .W !,$G(@STORE@(INST,TIEN,"D",NXT)) - W !!,"[Not Assigned] = Patient assigned to Team but not to a position/provider" - W !,"[Inactive Position] = Patient assigned to Team & Position but has no active provider" - Q - ; -HEADER ;prints column headings - N NXT - F NXT="H1","H2","H3" D - .W !,$G(@STORE@(NXT)) - Q - ; -SETH ;sets column headings - S @STORE@("H2")="Patient Name" - S $E(@STORE@("H2"),18)="Pt ID" - S $E(@STORE@("H2"),32)="Practitioner" - S $E(@STORE@("H2"),56)="Role" - S $E(@STORE@("H2"),80)="PC?" - S $E(@STORE@("H1"),85)="Last" - S $E(@STORE@("H2"),85)="Appt." - S $E(@STORE@("H1"),97)="Next" - S $E(@STORE@("H2"),97)="Appt." - S $E(@STORE@("H2"),109)="Associated Clinic" - S $P(@STORE@("H3"),"=",133)="" - Q +SCRPTP2 ;ALB/CMM - List of Team's Patients ; 29 Jun 99 04:11PM + ;;5.3;Scheduling;**41,53,52,174,177,231**;AUG 13, 1993 + ; + ;List of Team's Patients Report + ; +TFORMAT(INST,INAME,TIEN,TNAME,PHONE,PC) ; Format team information + ;INST - institution ien + ;INAME - institution name + ;TIEN - team ien + ;TNAME - team name + ;PHONE - team phone + ;PC - primary care team (yes/no) + ; + I INAME="" S INAME="[BAD DATA]" + I TNAME="" S TNAME="[BAD DATA]" + S @STORE@("I",INAME,INST)="" + S @STORE@("T",INST,TNAME,TIEN)="" + S @STORE@(INST)="Division: "_INAME + S @STORE@(INST,TIEN)="Team: "_TNAME + S $E(@STORE@(INST,TIEN),45)="Team Phone: "_PHONE + S @STORE@(INST,TIEN,1)="Primary Care Team: "_PC + Q + ; +PRINTIT(STORE,TITL) ; + N INST,INAME,TNAME,TIEN + S (NEW,PAGE)=1,STOP=0 W:$E(IOST)="C" @IOF + D TITLE^SCRPU3(.PAGE,TITL,132) ;write title + D SETH + ; + S INAME="" + F S INAME=$O(@STORE@("I",INAME)) Q:INAME=""!(STOP) D + .S INST=$O(@STORE@("I",INAME,"")) + .Q:INST="" + .I ('NEW)&(IOST'?1"C-".E) D NEWP1^SCRPU3(.PAGE,TITL,132) + .I ('NEW)&(IOST?1"C-".E) D HOLD^SCRPU3(.PAGE,TITL,132) + .Q:STOP + .W !,$G(@STORE@(INST)) ;write institution + .S TNAME="" + .F S TNAME=$O(@STORE@("T",INST,TNAME)) Q:TNAME=""!(STOP) D + ..S TIEN=$O(@STORE@("T",INST,TNAME,"")) + ..Q:TIEN="" + ..D TPRINT(INST,TIEN) ;writes team info + ..Q:STOP + ..; + ..I (IOST'?1"C-".E)&($Y>(IOSL-4)) D NEWP1^SCRPU3(.PAGE,TITL,132) + ..I (IOST?1"C-".E)&($Y>(IOSL-4)) D HOLD^SCRPU3(.PAGE,TITL,132) + ..Q:STOP + ..D HEADER + ..I (SORT=3)!(SORT=4) D PRACT(INST,TIEN,.NEW) + ..I (SORT=1)!(SORT=2) D PTP(INST,TIEN,.NEW) + K NEW,PAGE + I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR + Q + ; +PRACT(INST,TIEN,NEW) ;Print by practitioner/patient + N PNAME,PIEN,SEC2,ST1,TRD,TRDI + S PNAME="",PIEN="" + F S PNAME=$O(@STORE@("P",INST,TIEN,PNAME)) Q:PNAME=""!(STOP) D + . F S PIEN=$O(@STORE@("P",INST,TIEN,PNAME,PIEN)) Q:PIEN=""!(STOP) D + . . I (SORT=1)!(SORT=3) S SEC2="""PT""" ;sort by patient name + . . I (SORT=2)!(SORT=4) S SEC2="""PID""" ;sort by last 4 PID + . . S ST1=$E(STORE,1,$L(STORE)-1)_","_SEC2_")" + . . I (IOST'?1"C-".E)&($Y>(IOSL-4)) D NEWP1^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER + . . Q:STOP + . . I (IOST?1"C-".E)&($Y>(IOSL-4)) D HOLD^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER + . . Q:STOP + . . S (TRDI,TRD)="" + . . F S TRD=$O(@ST1@(INST,TIEN,TRD)) Q:TRD=""!(STOP) D + . . . F S TRDI=$O(@ST1@(INST,TIEN,TRD,TRDI)) Q:TRDI=""!(STOP) D + . . . . I (IOST'?1"C-".E)&($Y>(IOSL-4)) D NEWP1^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER + . . . . Q:STOP + . . . . I (IOST?1"C-".E)&($Y>(IOSL-4)) D HOLD^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER + . . . . Q:STOP + . . . . I $D(@STORE@(INST,TIEN,PIEN,TRDI)) W !,$G(@STORE@(INST,TIEN,PIEN,TRDI)) ;write column data + . S NEW=0 + Q + ; +PTP(INST,TIEN,NEW) ;Print by patient/practitioner + N SEC2,ST1,TRDI,TRD,PNAME,PIEN + I (SORT=1)!(SORT=3) S SEC2="""PT""" ;sort by patient name + I (SORT=2)!(SORT=4) S SEC2="""PID""" ;sort by last 4 PID + S ST1=$E(STORE,1,$L(STORE)-1)_","_SEC2_")" + I (IOST'?1"C-".E)&($Y>(IOSL-4)) D NEWP1^SCRPU3(.PAGE,TITL,132) + I (IOST?1"C-".E)&($Y>(IOSL-4)) D HOLD^SCRPU3(.PAGE,TITL,132) + Q:STOP + S (TRDI,TRD)="" + F S TRD=$O(@ST1@(INST,TIEN,TRD)) Q:TRD=""!(STOP) D + . F S TRDI=$O(@ST1@(INST,TIEN,TRD,TRDI)) Q:TRDI=""!(STOP) D + . . I (IOST'?1"C-".E)&($Y>(IOSL-4)) D NEWP1^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER + . . Q:STOP + . . I (IOST?1"C-".E)&($Y>(IOSL-4)) D HOLD^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER + . . Q:STOP + . . S PNAME="",PIEN="" + . . F S PNAME=$O(@STORE@("P",INST,TIEN,PNAME)) Q:PNAME=""!(STOP)!(PIEN=0) D + . . . F S PIEN=$O(@STORE@("P",INST,TIEN,PNAME,PIEN)) Q:PIEN=""!(STOP) D + . . . . I (IOST'?1"C-".E)&($Y>(IOSL-4)) D NEWP1^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER + . . . . Q:STOP + . . . . I (IOST?1"C-".E)&($Y>(IOSL-4)) D HOLD^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER + . . . . Q:STOP + . . . . I $D(@STORE@(INST,TIEN,TRDI,PIEN)) W !,$G(@STORE@(INST,TIEN,TRDI,PIEN)) ;write column data + . S NEW=0 + Q + ; +TPRINT(INST,TIEN) ; + ;prints team data + N NXT + I (IOST'?1"C-".E)&($Y>(IOSL-13)) D NEWP1^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INST)) + I (IOST?1"C-".E)&($Y>(IOSL-13)) D HOLD^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INST)) + Q:STOP + W !!,$G(@STORE@(INST,TIEN)) + S NXT=0 + W !,$G(@STORE@(INST,TIEN,1)) ;write team info + Q:'$D(@STORE@(INST,TIEN,"D")) W ! + S NXT="" + ;write team description + F S NXT=$O(@STORE@(INST,TIEN,"D",NXT)) Q:NXT=""!(STOP) D + .I (IOST'?1"C-".E)&$Y>(IOSL-13) D NEWP1^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INST)) + .I (IOST?1"C-".E)&$Y>(IOSL-13) D HOLD^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INST)) + .Q:STOP + .W !,$G(@STORE@(INST,TIEN,"D",NXT)) + W !!,"[Not Assigned] = Patient assigned to Team but not to a position/provider" + W !,"[Inactive Position] = Patient assigned to Team & Position but has no active provider" + Q + ; +HEADER ;prints column headings + N NXT + F NXT="H1","H2","H3" D + .W !,$G(@STORE@(NXT)) + Q + ; +SETH ;sets column headings + S @STORE@("H2")="Patient Name" + S $E(@STORE@("H2"),25)="Pt ID" + S $E(@STORE@("H2"),32)="Practitioner" + S $E(@STORE@("H2"),56)="Role" + S $E(@STORE@("H2"),80)="PC?" + S $E(@STORE@("H1"),85)="Last" + S $E(@STORE@("H2"),85)="Appt." + S $E(@STORE@("H1"),97)="Next" + S $E(@STORE@("H2"),97)="Appt." + S $E(@STORE@("H2"),109)="Associated Clinic" + S $P(@STORE@("H3"),"=",133)="" + Q diff --git a/r/SCHEDULING-SD-SC/SCRPTP3.m b/r/SCHEDULING-SD-SC/SCRPTP3.m index 0ca04000..dd2b6885 100644 --- a/r/SCHEDULING-SD-SC/SCRPTP3.m +++ b/r/SCHEDULING-SD-SC/SCRPTP3.m @@ -1,116 +1,148 @@ -SCRPTP3 ;ALB/CMM - List of Team's Patients ; 29 Jun 99 04:11PM - ;;5.3;Scheduling;**41,48,98,177,231,433,526,520**;AUG 13, 1993;Build 26 - ;;DMR BP-OIFO Patch SD*5.3*526 - ; - ;List of Team's Patients Report - ; -HITS(ARRY,TIEN) ; - ;ARRY - list of patients for a given team - ;TIEN - team ien - ; - N PTIEN,PIEN,PTNAME,PNAME,PTAI,NXT,NODE,CIEN,CNAME,INAME,INST,LAST,NEXT - N PAIEN,PC,PHONE,PNODE,PTPA,PTPAN,ROL,PID,TINFO,TNAME,TPIEN,TPNODE - N CNT,TPA,FLAG,DFN,VA,VAERR,PCAP,ROLN - S INACTIVE=0 - S NXT=0 - F S NXT=$O(@ARRY@(NXT)) Q:NXT=""!(NXT'?.N) D - .S NODE=$G(@ARRY@(NXT)) - .Q:NODE="" - .S PTIEN=+$P(NODE,"^") ;patient ien - .S PTNAME=$P(NODE,"^",2) ;patient name - .S PTAI=+$P(NODE,"^",3) ;patient team assignment ien (#404.42) - .; - .S PNODE=$G(^DPT(PTIEN,0)) - .Q:PNODE="" - .S DFN=PTIEN - .D PID^VADPT6 - .;S PID=VA("BID") - .S PID=$E(VA("PID"),1,3)_$E(VA("PID"),5,6)_$E(VA("PID"),8,12) - .; - .N CNAME,PINF,CLIEN - .S CNT="" - .F S CNT=$O(^SCPT(404.43,"B",PTAI,CNT)) Q:CNT=""!(CNT'?.N) D - ..D TPAR(PTAI,CNT,.PINF,.CNAME,.CLIEN,.PNAME,.ROLN,.PCAP) - Q - ; -TPAR(PTAI,START,PINF,CNAME,CLIEN,PNAME,ROLN,PCAP) ; - N PTPA,TPIEN,TPNODE,ROL,CIEN,ENROLL,OKAY,NEXT,LAST,PAIEN - I '$D(^SCPT(404.43,"B",PTAI)) Q "0^[Not Assigned]" - ; ^ no patient team position assignment - IF START="" D - .S PTPA=$O(^SCPT(404.43,"B",PTAI,START)) - ELSE D - .S PTPA=START - I PTPA="" Q "0^[Not Assigned]" - S PTPAN=$G(^SCPT(404.43,PTPA,0)) ;patient team assignment - I PTPAN=""!(PTPAN=0) Q "0^[Not Assigned]" - I $P(PTPAN,"^",4)'="",$P(PTPAN,"^",4)
0:" AP",1:"PCP") ;PC? - ; - D SETASCL^SCRPRAC2(TPIEN,.CNAME,.CLIEN) - ;next two lines commented off - SD*5.3*433 - ;S ENROLL=$$ENRL(PTIEN,CIEN) ;enrolled in associated clinic - ;I 'ENROLL S CNAME="",CIEN=0 - ; - S PAIEN=$$CHK(TPIEN) - I +PAIEN'=0 S PIEN=+PAIEN,PNAME=$P(PAIEN,"^",2) ; practitioner's name - ;SD*5.3*231 - I +PAIEN=0 S PIEN=0,PNAME="[Inactive Position]" - ; - D GETPINF^SCRPPAT2(PTIEN,.CLIEN,.PINF) ;get patient info - S CNAME=$G(CNAME(0)) - S PINF=$G(PINF(0)) - I PINF="" D - .S PINF=PIEN_"^"_$$PDATA^SCRPEC(PIEN,CNAME,CNAME,1) - I INACTIVE S @STORE@(INS,TIEN,"INACT")="" - S FLAG="Y" - S TINFO=$$TINF^SCRPTP(TIEN) ;team information - S INST=+$P(TINFO,"^") ;institution ien - S INAME=$P($G(^DIC(4,INST,0)),"^") ;institution name - S PHONE=$P(TINFO,"^",4) ;team phone - S PC=$P(TINFO,"^",3) ;primary care? - S TNAME=$P(TINFO,"^",2) ;team name - D TFORMAT^SCRPTP2(INST,INAME,TIEN,TNAME,PHONE,PC) - D FORMAT^SCRPTP(INS,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,CNAME,PINF,ROLN,PCAP) - N SCCNT - S SCCNT=0 F S SCCNT=$O(CNAME(SCCNT)) Q:SCCNT="" D FORMATAC^SCRPTP(SCCNT,CNAME(SCCNT),PINF(SCCNT),INS,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,ROLN,PCAP) - Q - ; -ENRL(PTIEN,CLIEN) ;FUNCTIONALITY DISABLED - ; - ;N FOUND,ENODE,EN,NXT - ;S FOUND=0 - ;Q:'$D(^DPT(PTIEN,"DE","B",CLIEN)) FOUND - ;S EN=$O(^DPT(PTIEN,"DE","B",CLIEN,"")) - ;Q:EN=""!'$D(^DPT(PTIEN,"DE",EN,1)) FOUND - ;S NXT="" - ;F S NXT=$O(^DPT(PTIEN,"DE",EN,1,NXT)) Q:(FOUND)!(NXT="")!(NXT'?.N) D - ;check if active enrollment - ;S ENODE=$G(^DPT(PTIEN,"DE",EN,1,NXT,0)) - ;I $P(ENODE,"^",3)'="",$P(ENODE,"^",3)DT Q ;not active enrollment - ;; ^ discharge date ^ enrollment date - S FOUND=0 - Q FOUND - ; -CHK(TPIEN) ;assigned to a position - ;TPIEN - ien of 404.57 Team Position file - ;returns: ien of 200 New Person file - N EN,PLIST,PERR,ERR,NAME - S PLIST="PLST",PERR="PRR" - K @PLIST,@PERR - S ERR=$$PRTP^SCAPMC8(TPIEN,,.PLIST,.PERR) - I '$D(@PERR) D - .S EN=$P($G(@PLIST@(1)),"^") ;ien of new person file - .S NAME=$P($G(@PLIST@(1)),"^",2) ; new person name - K @PLIST,@PERR - Q EN_"^"_NAME - ; +SCRPTP3 ;ALB/CMM - List of Team's Patients ; 29 Jun 99 04:11PM + ;;5.3;Scheduling;**41,48,98,177,231,433**;AUG 13, 1993 + ; + ;List of Team's Patients Report + ; +HITS(ARRY,TIEN) ; + ;ARRY - list of patients for a given team + ;TIEN - team ien + ; + N PTIEN,PIEN,PTNAME,PNAME,PTAI,NXT,NODE,CIEN,CNAME,INAME,INST,LAST,NEXT + N PAIEN,PC,PHONE,PNODE,PTPA,PTPAN,ROL,PID,TINFO,TNAME,TPIEN,TPNODE + N CNT,TPA,FLAG,DFN,VA,VAERR,PCAP,ROLN + S INACTIVE=0 + S NXT=0 + F S NXT=$O(@ARRY@(NXT)) Q:NXT=""!(NXT'?.N) D + .S NODE=$G(@ARRY@(NXT)) + .Q:NODE="" + .S PTIEN=+$P(NODE,"^") ;patient ien + .S PTNAME=$P(NODE,"^",2) ;patient name + .S PTAI=+$P(NODE,"^",3) ;patient team assignment ien (#404.42) + .; + .S PNODE=$G(^DPT(PTIEN,0)) + .Q:PNODE="" + .S DFN=PTIEN + .D PID^VADPT6 + .S PID=VA("BID") + .; + .S TPA=$$TPAR(PTAI,"") + .I TPA'=-1 D + ..S PIEN=$P(TPA,"^") + ..S PNAME=$P(TPA,"^",2) + ..S CNAME=$P(TPA,"^",3) + ..S LAST=$P(TPA,"^",4) + ..S NEXT=$P(TPA,"^",5) + ..; + ..S FLAG="Y" + ..S TINFO=$$TINF^SCRPTP(TIEN) ;team information + ..S INST=+$P(TINFO,"^") ;institution ien + ..S INAME=$P($G(^DIC(4,INST,0)),"^") ;institution name + ..S PHONE=$P(TINFO,"^",4) ;team phone + ..S PC=$P(TINFO,"^",3) ;primary care? + ..S TNAME=$P(TINFO,"^",2) ;team name + ..; + ..D TFORMAT^SCRPTP2(INST,INAME,TIEN,TNAME,PHONE,PC) + ..D FORMAT^SCRPTP(INST,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,CNAME,LAST,NEXT) + .; + .;check for other assignments + .N TPIN + .S CNT="" + .F S CNT=$O(^SCPT(404.43,"B",PTAI,CNT)) Q:CNT=""!(CNT'?.N) D + ..S TPIN=$$TPAR(PTAI,CNT) + ..Q:TPIN=-1 + ..S PIEN=$P(TPIN,"^") + ..S PNAME=$P(TPIN,"^",2) + ..S CNAME=$P(TPIN,"^",3) + ..S LAST=$P(TPIN,"^",4) + ..S NEXT=$P(TPIN,"^",5) + ..S ROLN=$P(TPIN,U,6) + ..S PCAP=$P(TPIN,U,7) + ..I '$D(FLAG) D + ...S TINFO=$$TINF^SCRPTP(TIEN) ;team information + ...S INST=+$P(TINFO,"^") ;institution ien + ...S INAME=$P($G(^DIC(4,INST,0)),"^") ;institution name + ...S PHONE=$P(TINFO,"^",4) ;team phone + ...S PC=$P(TINFO,"^",3) ;primary care? + ...S TNAME=$P(TINFO,"^",2) ;team name + ...; + ...D TFORMAT^SCRPTP2(INST,INAME,TIEN,TNAME,PHONE,PC) + ..D FORMAT^SCRPTP(INST,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,CNAME,LAST,NEXT,ROLN,PCAP) + I INACTIVE S @STORE@(INST,TIEN,"INACT")="" + Q + ; +TPAR(PTAI,START) ; + N PTPA,TPIEN,TPNODE,ROL,CNAME,CIEN,ENROLL,OKAY,PNAME,NEXT,LAST,PAIEN + N ROLN,PCAP + I '$D(^SCPT(404.43,"B",PTAI)) Q "0^[Not Assigned]" + ; ^ no patient team position assignment + IF START="" D + .S PTPA=$O(^SCPT(404.43,"B",PTAI,START)) + ELSE D + .S PTPA=START + I PTPA="" Q "0^[Not Assigned]" + S PTPAN=$G(^SCPT(404.43,PTPA,0)) ;patient team position assignment node + I PTPAN=""!(PTPAN=0) Q "0^[Not Assigned]" + I $P(PTPAN,"^",4)'="",$P(PTPAN,"^",4)
0:" AP",1:"PCP") ;PC? + ; + S CIEN=+$P(TPNODE,"^",9) ;associated clinic ien + S CNAME=$P($G(^SC(CIEN,0)),"^") ;clinic name + ;check patient status + S OKAY="" + I CIEN>0&(PSTAT'=1) S OKAY=$$PST^SCRPTP(PTIEN,CIEN) + Q:(CIEN>0)&('OKAY)&(PSTAT'=1) -1 + ; ^ not selected patient status + ; + ;next two lines commented off - SD*5.3*433 + ;S ENROLL=$$ENRL(PTIEN,CIEN) ;enrolled in associated clinic + ;I 'ENROLL S CNAME="",CIEN=0 + ; + S PAIEN=$$CHK(TPIEN) + I +PAIEN'=0 S PIEN=+PAIEN,PNAME=$P(PAIEN,"^",2) ; practitioner's name + ;SD*5.3*231 + I +PAIEN=0 S PIEN=0,PNAME="[Inactive Position]" + ; + S (NEXT,LAST)="" + I +CIEN>0 S NEXT=$$GETNEXT^SCRPU3(PTIEN,CIEN) ;next appointment + I +CIEN>0 S LAST=$$GETLAST^SCRPU3(PTIEN,CIEN) ;last appointment + ; + Q PIEN_U_PNAME_U_CNAME_U_LAST_U_NEXT_U_ROLN_U_PCAP + ; +ENRL(PTIEN,CLIEN) ; + ; + N FOUND,ENODE,EN,NXT + S FOUND=0 + Q:'$D(^DPT(PTIEN,"DE","B",CLIEN)) FOUND + S EN=$O(^DPT(PTIEN,"DE","B",CLIEN,"")) + Q:EN=""!'$D(^DPT(PTIEN,"DE",EN,1)) FOUND + S NXT="" + F S NXT=$O(^DPT(PTIEN,"DE",EN,1,NXT)) Q:(FOUND)!(NXT="")!(NXT'?.N) D + .;check if active enrollment + .S ENODE=$G(^DPT(PTIEN,"DE",EN,1,NXT,0)) + .I $P(ENODE,"^",3)'="",$P(ENODE,"^",3)DT Q ;not active enrollment + .; ^ discharge date ^ enrollment date + .S FOUND=1 + Q FOUND + ; +CHK(TPIEN) ;assigned to a position + ;TPIEN - ien of 404.57 Team Position file + ;returns: ien of 200 New Person file + N EN,PLIST,PERR,ERR,NAME + S PLIST="PLST",PERR="PRR" + K @PLIST,@PERR + S ERR=$$PRTP^SCAPMC8(TPIEN,,.PLIST,.PERR) + I '$D(@PERR) D + .S EN=$P($G(@PLIST@(1)),"^") ;ien of new person file + .S NAME=$P($G(@PLIST@(1)),"^",2) ; new person name + K @PLIST,@PERR + Q EN_"^"_NAME + ; diff --git a/r/SCHEDULING-SD-SC/SCRPU1.m b/r/SCHEDULING-SD-SC/SCRPU1.m index 4bf71b9e..fdbcca86 100644 --- a/r/SCHEDULING-SD-SC/SCRPU1.m +++ b/r/SCHEDULING-SD-SC/SCRPU1.m @@ -1,131 +1,131 @@ -SCRPU1 ;ALB/CMM - GENERIC PROMPTS FOR PCMM REPORTS ;1/12/96 - ;;5.3;Scheduling;**41,45,130,520**;AUG 13, 1993;Build 26 - ; -INST ;Prompt for institution - S VAUTVB="VAUTD",DIC="^DIC(4,",DIC("S")="I $D(^SCTM(404.51,""AINST"",+Y))" - S VAUTNI=2,VAUTSTR="Division" - G FIRST^VAUTOMA - ; -PRMTT ;Prompt for team. Set VAUTTN to allow not assigned to a team as a selection - I '$D(VAUTD) G ERR - S VAUTVB="VAUTT",DIC="^SCTM(404.51,",VAUTNI=2,VAUTSTR="Team",DIC("B")="" - S DIC("S")="I VAUTD=1!($D(VAUTD(+$P(^(0),U,7))))" - G FIRST - ; -CLINIC ;Prompt for Clinic - I '$D(VAUTT)&'$D(VAUTCA) G ERR - S VAUTVB="VAUTC",VAUTSTR="Clinic",VAUTNI=2,DIC="^SC(" - ;Set screen to only allow clinics and clinics that are associated to the teams selected - I '$D(VAUTCA) S DIC("S")="I $$CLSC^SCRPU1()" - ;VAUTCA allows for selection of any clinic in the selected - I $D(VAUTCA) S DIC("S")="I $$CLSC2^SCRPU1()" - G FIRST - ; -USER ;Prompt for User Class - I '$D(VAUTT) G ERR - I $P($G(^SD(404.91,1,"PCMM")),"^")'=1 Q ;user class turned off - S VAUTVB="VAUTUC",DIC="^USR(8930,",VAUTSTR="User Class",VAUTNI=2 - S DIC("S")="I $$USRCL^SCRPU1" - G FIRST - ; -USRCL() ;Screen for user class - must be related to teams selected - N STOP,ENT,NODE,TIEN - I '+$P(^(0),U,3) Q 0 - ;check for active/exiting user class - S ENT=0,STOP=0 - F S ENT=$O(^SCTM(404.57,"AUSR",+Y,ENT)) Q:ENT=""!(STOP) D - .S NODE=$G(^SCTM(404.57,ENT,0)) - .I NODE="" S STOP=0 Q - .S TIEN=+$P(NODE,"^",2) ;team ien - .I $D(VAUTT(TIEN))!(VAUTT=1) S STOP=1 Q - .I VAUTT=""&(TIEN="") S STOP=1 Q ;no team selected, no team assigned - .I VAUTT'=1&('$D(VAUTT(TIEN))) S STOP=0 - Q STOP - ; -ROLE ;Prompt for Role - I '$D(VAUTT) G ERR - S VAUTVB="VAUTR",DIC="^SD(403.46,",VAUTSTR="Role",VAUTNI=2 - S DIC("S")="I $$RL^SCRPU1()" - G FIRST - ; -RL() ;Screen for Role - screen on team - N EN,STOP,ACT,TEAM - S EN="",STOP=0 - I $D(^SCTM(404.57,"AC",+Y)) D - .F S EN=$O(^SCTM(404.57,"AC",+Y,EN)) Q:EN=""!(STOP) D - ..S ACT=+$$ACTTP^SCMCTPU(EN) ;currently active? - ..I 'ACT!('$D(^SCTM(404.57,EN,0))) Q - ..S TEAM=$P(^SCTM(404.57,EN,0),"^",2) - ..I $D(VAUTT(TEAM))!(VAUTT=1) S STOP=1 - ..I VAUTT=""&(TEAM="") S STOP=1 - Q STOP - ; -PRACT ; Prompt for One (set VAUTPO) or One,Many,All,None Practitioner(s) - I '$D(VAUTT) G ERR - S VAUTVB="VAUTP",VAUTSTR="Practitioner",VAUTNI=2,DIC="^VA(200," - S DIC("S")="I $$PRACS^SCRPU1()" - G FIRST - ; -PRACS() ;Practitioner screen - off of team selection - N EN,STOP,NODE,TEAM - S EN="",STOP=0 - I '$D(^SCTM(404.52,"C",+Y)) Q 0 - ;Position Assignment History file - F S EN=$O(^SCTM(404.52,"C",+Y,EN)) Q:EN=""!(STOP) D - .I '$D(^SCTM(404.52,EN)) Q - .S NODE=$G(^SCTM(404.52,EN,0)) - .S TEAM=+$P($G(^SCTM(404.57,$P(NODE,"^"),0)),"^",2) - .I $P(NODE,"^",4),$D(VAUTT(TEAM)) S STOP=1 - .I VAUTT=1 S STOP=1 - Q STOP - ; -FIRST ; - S DIC(0)="EQMNZ",DIC("A")="Select "_VAUTSTR_": " K @VAUTVB - S (@VAUTVB,Y)=0 -REDO W !,DIC("A") R X:DTIME G ERR:(X="^")!'$T D:X["?"!(X=""&('$G(SCOKNULL))) HELP^SCRPU3 - G:$G(SCOKNULL)&(X="") QUIT - I X="A"!(X="ALL")&'$D(VAUTNA) S @VAUTVB=1 G QUIT - ;VAUTNA doesn't allow all to be selected - ;VAUTTN allows 'Not assigned to a team' as a selection - I X="N"!(X="NOT")!(X="NONE") I $D(VAUTTN)!($D(VAUTPP)) S @VAUTVB="" G QUIT - ;VAUTPP allows 'Not assigned to a practitioner' as a selection - S DIC("A")="Select another "_VAUTSTR_": " D ^DIC G:Y'>0 FIRST D SET - I '$D(VAUTPO) F VAI=1:0:19 W !,DIC("A") R X:DTIME G ERR:(X="")!(X="^")!'$T K Y D HELP^SCRPU3:X["?" S:$E(X)="-" VAUTX=X,X=$E(VAUTX,2,999) D ^DIC I Y>0 D SET G:VAX REDO S:'VAERR VAI=VAI+1 - ;VAUTPO - only one practitioner allowed to be selected - G QUIT -SET S VAX=0 I $D(VAUTX) S J=$S(VAUTNI=2:+Y,1:$P(Y(0),"^")) K VAUTX S VAERR=$S($D(@VAUTVB@(J)):0,1:1) W $S('VAERR:"...removed from list...",1:"...not on list...can't remove") Q:VAERR S VAI=VAI-1 K @VAUTVB@(J) S:$O(@VAUTVB@(0))']"" VAX=1 Q - S VAERR=0 I $S($D(@VAUTVB@($P(Y(0),U))):1,$D(@VAUTVB@(+Y)):1,1:0) W !?3,*7,"You have already selected that ",VAUTSTR,". Try again." S VAERR=1 - S @VAUTVB@(+Y)=$P(Y(0),U) - Q - ; -ERR S Y=-1 I $O(@VAUTVB@(0))="" K @VAUTVB I X="^" S SCUP="" -QUIT S:'$D(Y) Y=1 - I $D(@VAUTVB),VAUTSTR="Team",@VAUTVB=1 D:'$G(DGQUIET) EN^DDIOL("All Teams selected, this report may take some time...","","!,?10") - K DIC,J,VAERR,VAI,VAJ,VAJ1,VAX,VAUTNI,VAUTSTR,VAUTVB,X - Q - ; -CLSC() ;screen on clinic selection, must be related to team prompt - I $P(^(0),U,3)'="C" Q 0 - N TRUE,EN,TEAM - S TRUE=0,EN="" - F S EN=$O(^SCTM(404.57,"E",+Y,EN)) Q:EN=""!(TRUE) D - .S TEAM=+$P($G(^SCTM(404.57,EN,0)),"^",2) - .I $D(VAUTT(TEAM))!(VAUTT=1) S TRUE=1 - I VAUTT="" S TRUE=1 - Q TRUE - ; -CLSC2() ;screen on clinic selection, must be a clinic - I $P(^(0),U,3)'="C" Q 0 - Q 1 - ; -CLSC2OLD() ;screen on clinic selection, must be related to division prompt - I $P(^(0),U,3)'="C" Q 0 - N TRUE,EN,INST,TDIV - S TRUE=0,EN="" - S TDIV=+$P(^(0),U,15) ;clinic's division - Q:TDIV=0 0 - S INST=+$P(^DG(40.8,TDIV,0),U,7) - I '$D(VAUTD(INST))&(VAUTD'="") S TRUE=0 - I $D(VAUTD(INST)) S TRUE=1 - I VAUTD=1 S TRUE=1 - Q TRUE +SCRPU1 ;ALB/CMM - GENERIC PROMPTS FOR PCMM REPORTS ;1/12/96 + ;;5.3;Scheduling;**41,45,130**;AUG 13, 1993 + ; +INST ;Prompt for institution + S VAUTVB="VAUTD",DIC="^DIC(4,",DIC("S")="I $D(^SCTM(404.51,""AINST"",+Y))" + S VAUTNI=2,VAUTSTR="Division" + G FIRST^VAUTOMA + ; +PRMTT ;Prompt for team. Set VAUTTN to allow not assigned to a team as a selection + I '$D(VAUTD) G ERR + S VAUTVB="VAUTT",DIC="^SCTM(404.51,",VAUTNI=2,VAUTSTR="Team",DIC("B")="" + S DIC("S")="I VAUTD=1!($D(VAUTD(+$P(^(0),U,7))))" + G FIRST + ; +CLINIC ;Prompt for Clinic + I '$D(VAUTT)&'$D(VAUTCA) G ERR + S VAUTVB="VAUTC",VAUTSTR="Clinic",VAUTNI=2,DIC="^SC(" + ;Set screen to only allow clinics and clinics that are associated to the teams selected + I '$D(VAUTCA) S DIC("S")="I $$CLSC^SCRPU1()" + ;VAUTCA allows for selection of any clinic in the selected + I $D(VAUTCA) S DIC("S")="I $$CLSC2^SCRPU1()" + G FIRST + ; +USER ;Prompt for User Class + I '$D(VAUTT) G ERR + I $P($G(^SD(404.91,1,"PCMM")),"^")'=1 Q ;user class turned off + S VAUTVB="VAUTUC",DIC="^USR(8930,",VAUTSTR="User Class",VAUTNI=2 + S DIC("S")="I $$USRCL^SCRPU1" + G FIRST + ; +USRCL() ;Screen for user class - must be related to teams selected + N STOP,ENT,NODE,TIEN + I '+$P(^(0),U,3) Q 0 + ;check for active/exiting user class + S ENT=0,STOP=0 + F S ENT=$O(^SCTM(404.57,"AUSR",+Y,ENT)) Q:ENT=""!(STOP) D + .S NODE=$G(^SCTM(404.57,ENT,0)) + .I NODE="" S STOP=0 Q + .S TIEN=+$P(NODE,"^",2) ;team ien + .I $D(VAUTT(TIEN))!(VAUTT=1) S STOP=1 Q + .I VAUTT=""&(TIEN="") S STOP=1 Q ;no team selected, no team assigned + .I VAUTT'=1&('$D(VAUTT(TIEN))) S STOP=0 + Q STOP + ; +ROLE ;Prompt for Role + I '$D(VAUTT) G ERR + S VAUTVB="VAUTR",DIC="^SD(403.46,",VAUTSTR="Role",VAUTNI=2 + S DIC("S")="I $$RL^SCRPU1()" + G FIRST + ; +RL() ;Screen for Role - screen on team + N EN,STOP,ACT,TEAM + S EN="",STOP=0 + I $D(^SCTM(404.57,"AC",+Y)) D + .F S EN=$O(^SCTM(404.57,"AC",+Y,EN)) Q:EN=""!(STOP) D + ..S ACT=+$$ACTTP^SCMCTPU(EN) ;currently active? + ..I 'ACT!('$D(^SCTM(404.57,EN,0))) Q + ..S TEAM=$P(^SCTM(404.57,EN,0),"^",2) + ..I $D(VAUTT(TEAM))!(VAUTT=1) S STOP=1 + ..I VAUTT=""&(TEAM="") S STOP=1 + Q STOP + ; +PRACT ; Prompt for One (set VAUTPO) or One,Many,All,None Practitioner(s) + I '$D(VAUTT) G ERR + S VAUTVB="VAUTP",VAUTSTR="Practitioner",VAUTNI=2,DIC="^VA(200," + S DIC("S")="I $$PRACS^SCRPU1()" + G FIRST + ; +PRACS() ;Practitioner screen - off of team selection + N EN,STOP,NODE,TEAM + S EN="",STOP=0 + I '$D(^SCTM(404.52,"C",+Y)) Q 0 + ;Position Assignment History file + F S EN=$O(^SCTM(404.52,"C",+Y,EN)) Q:EN=""!(STOP) D + .I '$D(^SCTM(404.52,EN)) Q + .S NODE=$G(^SCTM(404.52,EN,0)) + .S TEAM=+$P($G(^SCTM(404.57,$P(NODE,"^"),0)),"^",2) + .I $P(NODE,"^",4),$D(VAUTT(TEAM)) S STOP=1 + .I VAUTT=1 S STOP=1 + Q STOP + ; +FIRST ; + S DIC(0)="EQMNZ",DIC("A")="Select "_VAUTSTR_": " K @VAUTVB + S (@VAUTVB,Y)=0 +REDO W !,DIC("A") R X:DTIME G ERR:(X="^")!'$T D:X["?"!(X=""&('$G(SCOKNULL))) HELP^SCRPU3 + G:$G(SCOKNULL)&(X="") QUIT + I X="A"!(X="ALL")&'$D(VAUTNA) S @VAUTVB=1 G QUIT + ;VAUTNA doesn't allow all to be selected + ;VAUTTN allows 'Not assigned to a team' as a selection + I X="N"!(X="NOT")!(X="NONE") I $D(VAUTTN)!($D(VAUTPP)) S @VAUTVB="" G QUIT + ;VAUTPP allows 'Not assigned to a practitioner' as a selection + S DIC("A")="Select another "_VAUTSTR_": " D ^DIC G:Y'>0 FIRST D SET + I '$D(VAUTPO) F VAI=1:0:19 W !,DIC("A") R X:DTIME G ERR:(X="")!(X="^")!'$T K Y D HELP^SCRPU3:X["?" S:$E(X)="-" VAUTX=X,X=$E(VAUTX,2,999) D ^DIC I Y>0 D SET G:VAX REDO S:'VAERR VAI=VAI+1 + ;VAUTPO - only one practitioner allowed to be selected + G QUIT +SET S VAX=0 I $D(VAUTX) S J=$S(VAUTNI=2:+Y,1:$P(Y(0),"^")) K VAUTX S VAERR=$S($D(@VAUTVB@(J)):0,1:1) W $S('VAERR:"...removed from list...",1:"...not on list...can't remove") Q:VAERR S VAI=VAI-1 K @VAUTVB@(J) S:$O(@VAUTVB@(0))']"" VAX=1 Q + S VAERR=0 I $S($D(@VAUTVB@($P(Y(0),U))):1,$D(@VAUTVB@(+Y)):1,1:0) W !?3,*7,"You have already selected that ",VAUTSTR,". Try again." S VAERR=1 + S @VAUTVB@(+Y)=$P(Y(0),U) + Q + ; +ERR S Y=-1 I $O(@VAUTVB@(0))="" K @VAUTVB I X="^" S SCUP="" +QUIT S:'$D(Y) Y=1 + I $D(@VAUTVB),VAUTSTR="Team",@VAUTVB=1 D:'$G(DGQUIET) EN^DDIOL("All Teams selected, this report may take some time...","","!,?10") + K DIC,J,VAERR,VAI,VAJ,VAJ1,VAX,VAUTNI,VAUTSTR,VAUTVB,X + Q + ; +CLSC() ;screen on clinic selection, must be related to team prompt + I $P(^(0),U,3)'="C" Q 0 + N TRUE,EN,TEAM + S TRUE=0,EN="" + F S EN=$O(^SCTM(404.57,"D",+Y,EN)) Q:EN=""!(TRUE) D + .S TEAM=+$P($G(^SCTM(404.57,EN,0)),"^",2) + .I $D(VAUTT(TEAM))!(VAUTT=1) S TRUE=1 + I VAUTT="" S TRUE=1 + Q TRUE + ; +CLSC2() ;screen on clinic selection, must be a clinic + I $P(^(0),U,3)'="C" Q 0 + Q 1 + ; +CLSC2OLD() ;screen on clinic selection, must be related to division prompt + I $P(^(0),U,3)'="C" Q 0 + N TRUE,EN,INST,TDIV + S TRUE=0,EN="" + S TDIV=+$P(^(0),U,15) ;clinic's division + Q:TDIV=0 0 + S INST=+$P(^DG(40.8,TDIV,0),U,7) + I '$D(VAUTD(INST))&(VAUTD'="") S TRUE=0 + I $D(VAUTD(INST)) S TRUE=1 + I VAUTD=1 S TRUE=1 + Q TRUE diff --git a/r/SCHEDULING-SD-SC/SCRPU2.m b/r/SCHEDULING-SD-SC/SCRPU2.m index 03b5d68b..20fd8dbf 100644 --- a/r/SCHEDULING-SD-SC/SCRPU2.m +++ b/r/SCHEDULING-SD-SC/SCRPU2.m @@ -1,146 +1,146 @@ -SCRPU2 ;ALB/CMM - GENERIC PROMPTS FOR PCMM REPORTS ; 12 Jan 99 1:23 PM - ;;5.3;Scheduling;**41,174,297,526,520**;AUG 13, 1993;Build 26 - ; -DTRANG(FIRST,SECOND) ;Date Range - begin date ^ end date => fileman format - ;FIRST - first prompt (not required) - ;SECOND - second prompt (not required) - N BDATE,EDATE,DIROUT,DUOUT,DTOUT - S EDATE=-1 - S DIR(0)="D^::E",DIR("B")="Today" - I '$D(FIRST) S DIR("A")="Begin Date" - I $D(FIRST) S DIR("A")=FIRST - D ^DIR - I $D(DTOUT)!(X="Today") S BDATE=$P(DT,".") - I $D(DUOUT)!($D(DIROUT)) Q -1 - S BDATE=+Y -DEN I '$D(SECOND) S DIR("A")="End Date" - I $D(SECOND) S DIR("A")=SECOND - K DTOUT,X,Y - D ^DIR - I $D(DTOUT)!(X="Today") S EDATE=$P(DT,".") - I $D(DUOUT)!($D(DIROUT)) Q -1 - S EDATE=+Y - I EDATE fileman format + ;FIRST - first prompt (not required) + ;SECOND - second prompt (not required) + N BDATE,EDATE,DIROUT,DUOUT,DTOUT + S EDATE=-1 + S DIR(0)="D^::E",DIR("B")="Today" + I '$D(FIRST) S DIR("A")="Begin Date" + I $D(FIRST) S DIR("A")=FIRST + D ^DIR + I $D(DTOUT)!(X="Today") S BDATE=$P(DT,".") + I $D(DUOUT)!($D(DIROUT)) Q -1 + S BDATE=+Y +DEN I '$D(SECOND) S DIR("A")="End Date" + I $D(SECOND) S DIR("A")=SECOND + K DTOUT,X,Y + D ^DIR + I $D(DTOUT)!(X="Today") S EDATE=$P(DT,".") + I $D(DUOUT)!($D(DIROUT)) Q -1 + S EDATE=+Y + I EDATESDXEDT S SDXDT=$$YDTINC(SDDT) D LOOK I ^TMP("SCRPW",$J,SDIV,"YR",SDDT)>^TMP("SCRPW",$J,SDIV,"YR","MAX") S ^TMP("SCRPW",$J,SDIV,"YR","MAX")=^TMP("SCRPW",$J,SDIV,"YR",SDDT) - G:SDOUT EXIT D:$E(IOST)="C" DISP0^SCRPW23 I '$D(^TMP("SCRPW",$J)) D HDR G:SDOUT EXIT S SDX="No activity found within selected report parameters!" W !!?(IOM-$L(SDX)\2),SDX G EXIT - I $P(SDDIV,U,2)="SELECTED DIVISIONS" D - .S SDI=0 F S SDI=$O(SDDIV(SDI)) Q:'SDI S SDIV(SDDIV(SDI))=SDI - .Q - I $P(SDDIV,U,2)="ALL DIVISIONS" D - .S SDI=0 F S SDI=$O(^TMP("SCRPW",$J,SDI)) Q:'SDI S SDX=$P($G(^DG(40.8,SDI,0)),U) S:'$L(SDX) SDX="***UNKNOWN***" S SDIV(SDX)=SDI - .Q - S:$D(SDIV)'>1 SDIV($P(SDDIV,U,2))=$P(SDDIV,U,3) - G:SDOUT EXIT D:$E(IOST)="C" DISP0^SCRPW23 S SDIVN="" F S SDIVN=$O(SDIV(SDIVN)) Q:SDIVN=""!SDOUT S SDIV=SDIV(SDIVN) D DPRT(.SDIV) - G:SDOUT EXIT S SDMD=0,SDMD=$O(^TMP("SCRPW",$J,SDMD)),SDMD=$O(^TMP("SCRPW",$J,SDMD)) I SDMD S SDIV=0 D DPRT(.SDIV) - I $E(IOST)="C",'SDOUT W ! N DIR S DIR(0)="E" D ^DIR - ; -EXIT K SDIV,SDIVN,SDMD,SDOUT,SDSTOP,SDDIV,SDBDT,SDCT,SDDFN,SDDT,SDEDT,SDFIG,SDI,SDLINE,SDMAX,SDMO,SDOE,SDOE0,SDPAGE,SDPNOW,SDXDT,SDXEDT,SDXMO,SDXYR,SDYR,Y,%,SDX,SDFIG1,DTOUT,DUOUT,X,Y D END^SCRPW50 Q - ; -DPRT(SDIV) ;Print division - K SDTIT D DHDR^SCRPW46(SDIV,1,.SDTIT) I '$D(^TMP("SCRPW",$J,SDIV)) S SDX="No activity within report parameters found for this division!" D HDR Q:SDOUT W !!?(IOM-$L(SDX)\2),SDX Q - S SDDT=SDBDT D FIG,HDR,HD1 Q:SDOUT D LINE(SDDT) F S SDDT=$O(^TMP("SCRPW",$J,SDIV,"YR",SDDT)) Q:'SDDT!SDOUT D LINE(SDDT) - D:$Y>($S(IOSL<80:IOSL,1:80)-5) HDR Q:SDOUT F W ! Q:$Y>($S(IOSL<80:IOSL,1:80)-6) - W !?25,"Uniques in this report are based on OUTPATIENT ENCOUNTER file records with a" - W !?25,"status of '"_$S(SDSTA=2:"",SDSTA=8:"inpatient appointment ",1:"Out/Inpatient ")_"checked out'. This excludes any 'action required' activity." - Q - ; -DIV(SDD) ;Check division - ;Required input: MEDICAL CENTER DIVISION pointer - Q:'SDDIV 1 - Q $D(SDDIV(SDD)) - ; -SET(SDIV) ;Set TMP global - S SDSTOP=SDSTOP+1 D:SDSTOP#2000=0 STOP Q:SDOUT - Q:'SDIV D SET1(SDIV) D:SDMD SET1(0) Q - ; -SET1(SDIV) S ^TMP("SCRPW",$J,SDIV,"PT",SDDFN,$E(SDDT,1,5)_"00")="" Q - ; -OENC S SDXDT=SDBDT,SDDFN=0 - F S SDDFN=$O(^SCE("ADFN",SDDFN)) Q:'SDDFN S SDDT=SDXDT F S SDDT=$O(^SCE("ADFN",SDDFN,SDDT)) Q:'SDDT!(SDDT>SDEDT) D OENC1 - Q - ; -OENC1 S SDOE=0 F S SDOE=$O(^SCE("ADFN",SDDFN,SDDT,SDOE)) Q:'SDOE S SDOE0=$$GETOE^SDOE(SDOE) I $$OE(SDOE0,SDSTA) S SDIV=$P(SDOE0,U,11) I SDIV,$$DIV(SDIV) D SET(SDIV) - Q - ; -OE(SDOE0,SDSTA) ;Evaluate (in)outpatient encounter - ;Required input: SDOE0=OUTPATIENT ENCOUNTER zeroeth node - ; SDSTA=2 -outpatient,8 -inpatient, 2^8 -both - ;Output: '1' if checked out "parent" encounter, '0' otherwise - I $P(SDOE0,U,4),$P($G(^SC($P(SDOE0,U,4),0)),U,17)="Y" Q 0 - S SDSTA=$G(SDSTA,2),SDSTA="^"_SDSTA_"^" - Q:'$P(SDOE0,U,6)&(SDSTA[$P(SDOE0,U,12))&($P(SDOE0,U,7)'="") 1 - Q 0 - ; -STOP ;Check for stop task request - S:$G(ZTQUEUED) (SDOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q - ; -HDR D STOP Q:SDOUT I $E(IOST)="C" N DIR S DIR(0)="E" D ^DIR S SDOUT=Y'=1 Q:SDOUT - W:SDPAGE>1!($E(IOST)="C") $$XY^SCRPW50(IOF,1,0) W:$X $$XY^SCRPW50("",0,0) W SDLINE,!?36,"<*> TREND OF FACILITY UNIQUES BY 12 MONTH DATE RANGES <*>" - N SDI S SDI=$S(SDSTA=2:"Checked Out - Outpatients",SDSTA=8:"Checked Out - Inpatients",1:"Checked Out - Out/Inpatients") W !,?53,SDI ;?(132-SDI\2),SDI - S SDI=0 F S SDI=$O(SDTIT(SDI)) Q:'SDI W !?(132-$L(SDTIT(SDI))\2),SDTIT(SDI) - W !,SDLINE,!,"Date printed: ",SDPNOW,?125,"Page: ",SDPAGE,!,SDLINE S SDPAGE=SDPAGE+1 Q - ; -HD1 Q:SDOUT W !!,"12 mo. date range",?23,"Uniques",?32,"| Histogram (each ""*"" equals ",SDFIG," unique",$S(SDFIG=1:"",1:"s"),")",!,$E(SDLINE,1,SDFIG1) Q - ; -DTINC(SDDT) ;Increment date by one month - ;Required input: SDDT=date - ;Output: next month to examine - Q:$E(SDDT,4,5)=12 $E(SDDT,1,3)+1_"0100" - Q $E(SDDT,1,5)+1_"00" - ; -LOOK S ^TMP("SCRPW",$J,SDIV,"YR",SDDT)=0,SDDFN=0 F S SDDFN=$O(^TMP("SCRPW",$J,SDIV,"PT",SDDFN)) Q:'SDDFN D L1 - Q - ; -L1 I $D(^TMP("SCRPW",$J,SDIV,"PT",SDDFN,SDDT)) D LSET Q - S SDX=$O(^TMP("SCRPW",$J,SDIV,"PT",SDDFN,SDDT)) I SDX,SDX(IOSL-3) HDR,HD1 Q:SDOUT S SDCT=^TMP("SCRPW",$J,SDIV,"YR",SDDT),SDMO=$E(SDDT,4,5),SDYR=(17+$E(SDDT))_$E(SDDT,2,3),SDXMO=SDMO-1 S:SDXMO=0 SDXMO=12 S:$L(SDXMO)=1 SDXMO=0_SDXMO - S SDXYR=$S(SDXMO=12:SDYR,1:SDYR+1) - W !,SDMO,"/",SDYR," thru ",SDXMO,"/",SDXYR,?24,$J(SDCT,6,0),?32,"| " F SDI=1:1:(SDCT\SDFIG) W "*" - Q +SCRPW6 ;RENO/KEITH - Trend of Facility Uniques by 12 Month Date Ranges ; 15 Jul 98 02:38PM + ;;5.3;Scheduling;**139,144,466**;AUG 13, 1993;Build 2 + N SDDIV,SDI,SDSTA,DIR D TITL^SCRPW50("Trend of Facility Uniques by 12 Month Date Ranges") G:'$$DIVA^SCRPW17(.SDDIV) EXIT + D SUBT^SCRPW50("**** Status Selection ****") + S DIR(0)="S^1:Checked Out (Outpatients);2:Checked Out (Inpatients);3:Checked Out (Out/Inpatients)",DIR("A")="Select Status",DIR("B")="1" + D ^DIR I $D(DTOUT)!$D(DUOUT)!(+Y<0) G EXIT + S SDSTA=$S(Y=1:2,Y=2:8,1:"2^8") +QUE W !!,"This report requires 132 column output.",! + N ZTSAVE F X="SDDIV","SDDIV(","SDDNU(",SDSTA S ZTSAVE(X)="" + D EN^XUTMDEVQ("UNIQ^SCRPW6","Trend Facility Uniques",.ZTSAVE),DISP0^SCRPW23 Q +UNIQ ;Calculate/print uniques + S (SDOUT,SDSTOP)=0,SDLINE="",SDPAGE=1,$P(SDLINE,"-",133)="" D NOW^%DTC S Y=% X ^DD("DD") S SDPNOW=$P(Y,":",1,2),SDMD=$O(SDDIV(0)),SDMD=$O(SDDIV(SDMD)) S:$P(SDDIV,U,2)="ALL DIVISIONS" SDMD=1 + K ^TMP("SCRPW",$J) S SDBDT=$E(DT,1,3)-5_$E(DT,4,5)_"00",SDEDT=$E(DT,1,5)_"00",SDXEDT=$E(DT,1,3)-1_$E(DT,4,5)_"00" D OENC G:SDOUT EXIT + S SDIV="" F S SDIV=$O(^TMP("SCRPW",$J,SDIV)) Q:SDIV="" D STOP Q:SDOUT D + .S SDDT=SDBDT,SDXDT=$$YDTINC(SDDT),^TMP("SCRPW",$J,SDIV,"YR","MAX")=0 D LOOK + .F S SDDT=$$DTINC(SDDT) Q:SDDT>SDXEDT S SDXDT=$$YDTINC(SDDT) D LOOK I ^TMP("SCRPW",$J,SDIV,"YR",SDDT)>^TMP("SCRPW",$J,SDIV,"YR","MAX") S ^TMP("SCRPW",$J,SDIV,"YR","MAX")=^TMP("SCRPW",$J,SDIV,"YR",SDDT) + G:SDOUT EXIT D:$E(IOST)="C" DISP0^SCRPW23 I '$D(^TMP("SCRPW",$J)) D HDR G:SDOUT EXIT S SDX="No activity found within selected report parameters!" W !!?(IOM-$L(SDX)\2),SDX G EXIT + I $P(SDDIV,U,2)="SELECTED DIVISIONS" D + .S SDI=0 F S SDI=$O(SDDIV(SDI)) Q:'SDI S SDIV(SDDIV(SDI))=SDI + .Q + I $P(SDDIV,U,2)="ALL DIVISIONS" D + .S SDI=0 F S SDI=$O(^TMP("SCRPW",$J,SDI)) Q:'SDI S SDX=$P($G(^DG(40.8,SDI,0)),U) S:'$L(SDX) SDX="***UNKNOWN***" S SDIV(SDX)=SDI + .Q + S:$D(SDIV)'>1 SDIV($P(SDDIV,U,2))=$P(SDDIV,U,3) + G:SDOUT EXIT D:$E(IOST)="C" DISP0^SCRPW23 S SDIVN="" F S SDIVN=$O(SDIV(SDIVN)) Q:SDIVN=""!SDOUT S SDIV=SDIV(SDIVN) D DPRT(.SDIV) + G:SDOUT EXIT S SDMD=0,SDMD=$O(^TMP("SCRPW",$J,SDMD)),SDMD=$O(^TMP("SCRPW",$J,SDMD)) I SDMD S SDIV=0 D DPRT(.SDIV) + I $E(IOST)="C",'SDOUT W ! N DIR S DIR(0)="E" D ^DIR + ; +EXIT K SDIV,SDIVN,SDMD,SDOUT,SDSTOP,SDDIV,SDBDT,SDCT,SDDFN,SDDT,SDEDT,SDFIG,SDI,SDLINE,SDMAX,SDMO,SDOE,SDOE0,SDPAGE,SDPNOW,SDXDT,SDXEDT,SDXMO,SDXYR,SDYR,Y,%,SDX,SDFIG1,DTOUT,DUOUT,X,Y D END^SCRPW50 Q + ; +DPRT(SDIV) ;Print division + K SDTIT D DHDR^SCRPW46(SDIV,1,.SDTIT) I '$D(^TMP("SCRPW",$J,SDIV)) S SDX="No activity within report parameters found for this division!" D HDR Q:SDOUT W !!?(IOM-$L(SDX)\2),SDX Q + S SDDT=SDBDT D FIG,HDR,HD1 Q:SDOUT D LINE(SDDT) F S SDDT=$O(^TMP("SCRPW",$J,SDIV,"YR",SDDT)) Q:'SDDT!SDOUT D LINE(SDDT) + D:$Y>($S(IOSL<80:IOSL,1:80)-5) HDR Q:SDOUT F W ! Q:$Y>($S(IOSL<80:IOSL,1:80)-6) + W !?25,"Uniques in this report are based on OUTPATIENT ENCOUNTER file records with a" + W !?25,"status of '"_$S(SDSTA=2:"",SDSTA=8:"inpatient appointment ",1:"Out/Inpatient ")_"checked out'. This excludes any 'action required' activity." + Q + ; +DIV(SDD) ;Check division + ;Required input: MEDICAL CENTER DIVISION pointer + Q:'SDDIV 1 + Q $D(SDDIV(SDD)) + ; +SET(SDIV) ;Set TMP global + S SDSTOP=SDSTOP+1 D:SDSTOP#2000=0 STOP Q:SDOUT + Q:'SDIV D SET1(SDIV) D:SDMD SET1(0) Q + ; +SET1(SDIV) S ^TMP("SCRPW",$J,SDIV,"PT",SDDFN,$E(SDDT,1,5)_"00")="" Q + ; +OENC S SDXDT=SDBDT,SDDFN=0 + F S SDDFN=$O(^SCE("ADFN",SDDFN)) Q:'SDDFN S SDDT=SDXDT F S SDDT=$O(^SCE("ADFN",SDDFN,SDDT)) Q:'SDDT!(SDDT>SDEDT) D OENC1 + Q + ; +OENC1 S SDOE=0 F S SDOE=$O(^SCE("ADFN",SDDFN,SDDT,SDOE)) Q:'SDOE S SDOE0=$$GETOE^SDOE(SDOE) I $$OE(SDOE0,SDSTA) S SDIV=$P(SDOE0,U,11) I SDIV,$$DIV(SDIV) D SET(SDIV) + Q + ; +OE(SDOE0,SDSTA) ;Evaluate (in)outpatient encounter + ;Required input: SDOE0=OUTPATIENT ENCOUNTER zeroeth node + ; SDSTA=2 -outpatient,8 -inpatient, 2^8 -both + ;Output: '1' if checked out "parent" encounter, '0' otherwise + I $P(SDOE0,U,4),$P($G(^SC($P(SDOE0,U,4),0)),U,17)="Y" Q 0 + S SDSTA=$G(SDSTA,2),SDSTA="^"_SDSTA_"^" + Q:'$P(SDOE0,U,6)&(SDSTA[$P(SDOE0,U,12))&($P(SDOE0,U,7)'="") 1 + Q 0 + ; +STOP ;Check for stop task request + S:$G(ZTQUEUED) (SDOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q + ; +HDR D STOP Q:SDOUT I $E(IOST)="C" N DIR S DIR(0)="E" D ^DIR S SDOUT=Y'=1 Q:SDOUT + W:SDPAGE>1!($E(IOST)="C") $$XY^SCRPW50(IOF,1,0) W:$X $$XY^SCRPW50("",0,0) W SDLINE,!?36,"<*> TREND OF FACILITY UNIQUES BY 12 MONTH DATE RANGES <*>" + N SDI S SDI=$S(SDSTA=2:"Checked Out - Outpatients",SDSTA=8:"Checked Out - Inpatients",1:"Checked Out - Out/Inpatients") W !,?53,SDI ;?(132-SDI\2),SDI + S SDI=0 F S SDI=$O(SDTIT(SDI)) Q:'SDI W !?(132-$L(SDTIT(SDI))\2),SDTIT(SDI) + W !,SDLINE,!,"Date printed: ",SDPNOW,?125,"Page: ",SDPAGE,!,SDLINE S SDPAGE=SDPAGE+1 Q + ; +HD1 Q:SDOUT W !!,"12 mo. date range",?23,"Uniques",?32,"| Histogram (each ""*"" equals ",SDFIG," unique",$S(SDFIG=1:"",1:"s"),")",!,$E(SDLINE,1,SDFIG1) Q + ; +DTINC(SDDT) ;Increment date by one month + ;Required input: SDDT=date + ;Output: next month to examine + Q:$E(SDDT,4,5)=12 $E(SDDT,1,3)+1_"0100" + Q $E(SDDT,1,5)+1_"00" + ; +LOOK S ^TMP("SCRPW",$J,SDIV,"YR",SDDT)=0,SDDFN=0 F S SDDFN=$O(^TMP("SCRPW",$J,SDIV,"PT",SDDFN)) Q:'SDDFN D L1 + Q + ; +L1 I $D(^TMP("SCRPW",$J,SDIV,"PT",SDDFN,SDDT)) D LSET Q + S SDX=$O(^TMP("SCRPW",$J,SDIV,"PT",SDDFN,SDDT)) I SDX,SDX(IOSL-3) HDR,HD1 Q:SDOUT S SDCT=^TMP("SCRPW",$J,SDIV,"YR",SDDT),SDMO=$E(SDDT,4,5),SDYR=(17+$E(SDDT))_$E(SDDT,2,3),SDXMO=SDMO-1 S:SDXMO=0 SDXMO=12 S:$L(SDXMO)=1 SDXMO=0_SDXMO + S SDXYR=$S(SDXMO=12:SDYR,1:SDYR+1) + W !,SDMO,"/",SDYR," thru ",SDXMO,"/",SDXYR,?24,$J(SDCT,6,0),?32,"| " F SDI=1:1:(SDCT\SDFIG) W "*" + Q diff --git a/r/SCHEDULING-SD-SC/SCRPW62.m b/r/SCHEDULING-SD-SC/SCRPW62.m index ecc2da54..3c0de023 100644 --- a/r/SCHEDULING-SD-SC/SCRPW62.m +++ b/r/SCHEDULING-SD-SC/SCRPW62.m @@ -1,135 +1,121 @@ -SCRPW62 ;BP-CIOFO/KEITH - SC veterans awaiting appointments ; 23 August 2002@20:23 ; Compiled August 20, 2007 14:21:08 - ;;5.3;Scheduling;**267,269,358,491**;AUG 13, 1993;Build 53 - ; - ;Prompt for report parameters - ; - N SDOUT,DIR,DTOUT,DUOUT,SDFMT,SDATES,SDDIV,SDRPT,SDSCVT - N SDELIM,SDX,ZTSAVE,X,Y - S SDOUT=0 - D TITL^SCRPW50("SC Veterans Awaiting Appointments") - W !,"Note: Once the scheduling replacement application has been implemented at your" - W !,"site, this report will no longer be accurate." -RPT D SUBT^SCRPW50("**** Report Type Selection ****") - S DIR(0)="S^E:ENTERED WITH NO APPOINTMENT PROVIDED;A:APPOINTMENTS BEYOND DATE DESIRED",DIR("A")="Select report type" - S DIR("?",1)="Specify 'E' to return SC veterans entered but not yet provided an appointment," - S DIR("?")="'A' to return SC veterans with appointments beyond the date desired." - W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 G EXIT - K DIR S SDRPT=Y D ENT:SDRPT="E",APPT:SDRPT="A" G:SDOUT EXIT - D SUBT^SCRPW50("**** Patient Eligibility Selection ****") - S DIR(0)="S^1:50-100% SC Veterans;2:0-50% SC Veterans;3:All SC Veterans" - S DIR("A")="Select eligibility type" - S DIR("?")="Specify the eligibility of the patients you wish to include." - W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 G EXIT - K DIR S SDSCVT=Y -FMT D SUBT^SCRPW50("**** Report Format Selection ****") - S DIR(0)="S^D:DETAILED REPORT;S:STATISTICS ONLY" - S DIR("A")="Select report format" - S DIR("?")="Specify the report format desired." - W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 G EXIT - K DIR S SDFMT=Y - I SDFMT="S" S SDELIM=0 G QUE - D SUBT^SCRPW50("**** Output Format Selection ****") - S DIR(0)="Y",DIR("A")="Return report output in delimited format" - S DIR("B")="NO" - S DIR("?",1)="Specify if you would like the report output to be in delimited format for" - S DIR("?",2)="transfer to a spreadsheet. The delimited output will not include rated SC" - S DIR("?")="disabilities for 0-50% SC veterans (as included in the text formatted report)." - W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 G EXIT - S SDELIM=Y - ; -QUE ;Queue output - ;W !!,"This report requires ",$S(SDELIM:"greater than ",1:""),"132 columns for output!" - W !!,"This report requires the following steps to be converted to 'EXCEL':" - W !,"1 - Copy it into WORD and replace '!^p' with null" - W !,"2 - Save this file as *.txt format" - W !,"3 - Open this file in 'EXCEL' with the All Files(*.*) type of file, listing it with one delimiter: '^'." - F SDX="SDELIM","SDRPT","SDSCVT","SDATES","SDDIV","SDDIV(","SDFMT" S ZTSAVE(SDX)="" - W ! D EN^XUTMDEVQ("START^SCRPW62","SC Veterans Awaiting Appointments",.ZTSAVE) D DISP0^SCRPW23 - Q - ; -ENT ;Date entered parameters - S SDATES=1 Q - ; - ;Following logic suppressed by request - D SUBT^SCRPW50("**** Report Time Frame ****") - S DIR(0)="S^1:THE PAST YEAR;2:THE PAST TWO YEARS;3:THE PAST 3 YEARS" - S DIR("A")="Include SC veterans entered during" - S DIR("?")="Specify the time frame in which these patients were entered in VistA." - W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q - S SDATES=Y - Q - ; -APPT ;Appointment delay parameters - I '$$DIVA^SCRPW17(.SDDIV) S SDOUT=1 Q - S SDATES=30 Q - ; - ;Following logic suppressed by request - D SUBT^SCRPW50("**** Report Time Frame ****") - S DIR(0)="S^30:>30 DAYS BEYOND 'DESIRED DATE';60:>60 DAYS BEYOND 'DESIRED DATE;90:>90 DAYS BEYOND 'DESIRED DATE';180:>180 DAYS BEYOND 'DESIRED DATE'" - S DIR("A")="Include SC veterans with future appointments greater than" - S DIR("?")="Specify the difference between 'desired date' and the appointement date." - W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q - S SDATES=Y - Q - ; -START ;Gather report data - N SDSTOP,SDOUT,SDSTOP,SDPAGE,SDLINE,SDPNOW,SDT,SDX - I '$D(ZTQUEUED),$E(IOST)="C" D WAIT^DICD - K ^TMP("SCRPW",$J) S (SDSTOP,SDOUT)=0,SDPAGE=1,SDLINE="" - S $P(SDLINE,"-",(IOM+1))="" - S SDPNOW=$$FMTE^XLFDT($E($$NOW^XLFDT(),1,12)) - S SDX=$S(SDSCVT=1:"SC 50-100% ",SDSCVT=2:"SC < 50% ",1:"") - S SDT(1)="<*> SC VETERANS AWAITING APPOINTMENTS <*>" - S SDT(2)=$S(SDRPT="E":SDX_"PATIENTS ENTERED IN THE PAST "_$S(SDATES=1:"YEAR",1:SDATES_" YEARS")_" WITHOUT AN APPOINTMENT",1:SDX_"PATIENTS WAITING > "_SDATES_" DAYS BEYOND APPOINTMENT 'DESIRED DATE'") - D @(SDRPT_"^SCRPW63") W !! - D EXIT - Q - ; -SCEL(SDE,SDSCVT) ;Gather SC eligibility codes - ;Input: SDE=array to return list of codes in the format SDE(n) where - ; 'n' is the ifn in file #8 (pass by reference) - ; SDSCVT=type of SC vets to include - N SDE81,SDX,SDI,SDII - S SDI=0 F S SDI=$O(^DIC(8.1,SDI)) Q:'SDI D - .S SDX=$G(^DIC(8.1,SDI,0)) - .Q:$P(SDX,U,5)'="Y" S SDX=$P(SDX,U,4) - .I SDSCVT=1,SDX'=1 Q ;50-100% SC only - .I SDSCVT=2,SDX'=3 Q ;0-50% SC only - .I SDSCVT=3,(SDX'=1&(SDX'=3)) Q ;SC only - .S SDII=0 F S SDII=$O(^DIC(8,"D",SDI,SDII)) Q:'SDII D - ..S SDE(SDII)=SDX - ..Q - .Q - Q - ; -EXIT K ZTQUEUED,ZTSTOP,SDATES,SDDIV,SDFMT,SDRPT,SDELIM - D END^SCRPW50 Q - ; -HDR ;Print report header - N X - I SDELIM D HDRD Q - I $E(IOST)="C",SDPAGE>1 N DIR S DIR(0)="E" D ^DIR S SDOUT=Y'=1 Q:SDOUT - D STOP^SCRPW63 Q:SDOUT - W:SDPAGE>1!($E(IOST)="C") $$XY^SCRPW50(IOF,1,0) - W:$X $$XY^SCRPW50("",0,0) W SDLINE - S X=0 F S X=$O(SDT(X)) Q:'X W !?(IOM-$L(SDT(X))\2),SDT(X) - W !,SDLINE,!,"Date printed: ",SDPNOW,?((IOM-6)-$L(SDPAGE)),"Page: " - W SDPAGE,!,SDLINE S SDPAGE=SDPAGE+1 Q - ; -HDRD ;Header for delimited report - Q:SDPAGE>1 - W !,SDLINE S X=0 F S X=$O(SDT(X)) Q:'X W !,SDT(X) - W !,"Date printed: ",SDPNOW,!,SDLINE - N ARR S ARR(1)="NAME^SSN^PRIM. ELIG.^DATE ENTERED^STREET ADDRESS^CITY^STATE^ZIP^PHONE NUMBER" - S:SDRPT="A" ARR(1)=ARR(1)_"^APPOINTMENT DATE^CLINIC^CREDIT PAIR^DIVISION^DATE APPT. ENTERED^DESIRED DATE^DIFFERENCE (DESIRED DATE - APPT. DATE)^DIFFERENCE (DATE APPT. ENTERED - DESIRED DATE)" - D DELIM(.ARR) - S SDPAGE=SDPAGE+1 Q - Q - ;W !,"NAME^SSN^PRIM. ELIG.^DATE ENTERED^STREET ADDRESS^CITY^STATE^ZIP^PHONE NUMBER" - ;W:SDRPT="A" "^APPOINTMENT DATE^CLINIC^CREDIT PAIR^DIVISION^DATE APPT. ENTERED^DESIRED DATE^DIFFERENCE (DESIRED DATE - APPT. DATE)^DIFFERENCE (DATE APPT. ENTERED - DESIRED DATE)" - ;S SDPAGE=SDPAGE+1 Q -DELIM(ARR) ;enter delimiter in the end of wrapped line - ;ARR - array of lines - N DELIM,II,LN,LL,JJ - S DELIM="!" - F II=1:1 S LN=$G(ARR(II)),LL=$L(LN) Q:'LL S LN=$P(LN," ")_DELIM_$P(LN," ",2,$L(LN," ")) F JJ=1:79:LL W !,$E(LN,JJ,JJ+78) W:JJ+79 "_SDATES_" DAYS BEYOND APPOINTMENT 'DESIRED DATE'") + D @(SDRPT_"^SCRPW63") W !! + D EXIT + Q + ; +SCEL(SDE,SDSCVT) ;Gather SC eligibility codes + ;Input: SDE=array to return list of codes in the format SDE(n) where + ; 'n' is the ifn in file #8 (pass by reference) + ; SDSCVT=type of SC vets to include + N SDE81,SDX,SDI,SDII + S SDI=0 F S SDI=$O(^DIC(8.1,SDI)) Q:'SDI D + .S SDX=$G(^DIC(8.1,SDI,0)) + .Q:$P(SDX,U,5)'="Y" S SDX=$P(SDX,U,4) + .I SDSCVT=1,SDX'=1 Q ;50-100% SC only + .I SDSCVT=2,SDX'=3 Q ;0-50% SC only + .I SDSCVT=3,(SDX'=1&(SDX'=3)) Q ;SC only + .S SDII=0 F S SDII=$O(^DIC(8,"D",SDI,SDII)) Q:'SDII D + ..S SDE(SDII)=SDX + ..Q + .Q + Q + ; +EXIT K ZTQUEUED,ZTSTOP,SDATES,SDDIV,SDFMT,SDRPT,SDELIM + D END^SCRPW50 Q + ; +HDR ;Print report header + N X + I SDELIM D HDRD Q + I $E(IOST)="C",SDPAGE>1 N DIR S DIR(0)="E" D ^DIR S SDOUT=Y'=1 Q:SDOUT + D STOP^SCRPW63 Q:SDOUT + W:SDPAGE>1!($E(IOST)="C") $$XY^SCRPW50(IOF,1,0) + W:$X $$XY^SCRPW50("",0,0) W SDLINE + S X=0 F S X=$O(SDT(X)) Q:'X W !?(IOM-$L(SDT(X))\2),SDT(X) + W !,SDLINE,!,"Date printed: ",SDPNOW,?((IOM-6)-$L(SDPAGE)),"Page: " + W SDPAGE,!,SDLINE S SDPAGE=SDPAGE+1 Q + ; +HDRD ;Header for delimited report + Q:SDPAGE>1 + W !,SDLINE S X=0 F S X=$O(SDT(X)) Q:'X W !,SDT(X) + W !,"Date printed: ",SDPNOW,!,SDLINE + W !,"NAME^SSN^PRIM. ELIG.^DATE ENTERED INTO FILE^STREET ADDRESS^CITY^STATE^ZIP^PHONE NUMBER" + W:SDRPT="A" "^APPOINTMENT DATE^CLINIC^CREDIT PAIR^DIVISION^DATE APPT. ENTERED^DESIRED DATE^DIFFERENCE (DESIRED DATE - APPT. DATE)^DIFFERENCE (DATE APPT. ENTERED - DESIRED DATE)" + S SDPAGE=SDPAGE+1 Q diff --git a/r/SCHEDULING-SD-SC/SCRPW63.m b/r/SCHEDULING-SD-SC/SCRPW63.m index c72c3fac..2c504313 100644 --- a/r/SCHEDULING-SD-SC/SCRPW63.m +++ b/r/SCHEDULING-SD-SC/SCRPW63.m @@ -1,242 +1,241 @@ -SCRPW63 ;BP-CIOFO/KEITH - SC veterans awaiting appointments (cont.) ; 23 August 2002@20:23 - ;;5.3;Scheduling;**267,269,357,491**;AUG 13, 1993;Build 53 - ; -E ;Gather data for patients entered report - N DFN,SDX,SDATE,SD0,SDSCEL,SDEL,SDYR,SDREL,SDTOT,SDSDT,SDLVDT,SDEDT - N SDNAME - D SCEL^SCRPW62(.SDSCEL,SDSCVT) ;Get eligibility code pointers - S (SDSDT,SDATE)=DT-(10000*SDATES),SDSTOP=0 - ;Find the patients entered after date specified - S DFN=0 F Q:SDSTOP S DFN=$O(^DPT(DFN)) Q:'DFN D - .Q:$D(^DPT(DFN,-9)) ;Skip merged records - .I DFN#1000=0 D STOP Q:SDSTOP ;Check for stop task request - .S SDLVDT="" - .S SD0=$G(^DPT(DFN,0)) Q:'$L(SD0) - .S SDEDT=$P(SD0,U,16) S:SDEDT SDLVDT=SDEDT - .I SDEDT,SDEDT(IOSL-(4+SDREL)) HDR^SCRPW62 Q:SDOUT - ...S SDX=^TMP("SCRPW",$J,SDEL,SDNAME,DFN) D PLINE(DFN,SDX,SDEL) - ...Q - .Q - Q:SDOUT -ESUM ;Print summary - G:SDELIM EQ - S SDT(3)="STATISTICAL SUMMARY" D HDR^SCRPW62 Q:SDOUT - W !! S SDYR="",SDTOT=0 - F S SDYR=$O(^TMP("SCRPW",$J,"STATS",SDYR)) Q:SDYR="" D - .S SDEL=0 F S SDEL=$O(^TMP("SCRPW",$J,"STATS",SDYR,SDEL)) Q:'SDEL D - ..S SDX=$$CSCEL(SDEL)_" veterans entered "_$S(SDYR=0:"in the past year",SDYR=1:"two years ago",SDYR=2:"three years ago",1:"")_":" - ..W !?36,$J(SDX,45),?83,$J(^TMP("SCRPW",$J,"STATS",SDYR,SDEL),6,0) - ..S SDTOT=SDTOT+^TMP("SCRPW",$J,"STATS",SDYR,SDEL) - ..Q - .Q - W !?36,$E(SDLINE,1,53),!?75,"TOTAL:",?83,$J(SDTOT,6,0) -EQ I $E(IOST,1,2)="C-" N DIR S DIR(0)="E" W !! D ^DIR - Q - ; -SCHAPP(DFN) ;Look for scheduled appointments not cancelled by clinic - ; Input: DFN=patient ifn - ;Output: '1' if appointments exist, '0' otherwise - N SDI,SDX,SDY - S (SDI,SDY)=0 - F S SDI=$O(^DPT(DFN,"S",SDI)) Q:'SDI!SDY D - .S SDX=$G(^DPT(DFN,"S",SDI,0)) Q:'$L(SDX) - .S SDX=$P(SDX,U,2) I $L(SDX),"CA"[SDX Q - .S SDY=1 - .Q - Q SDY - ; -A ;Gather data for future appointments report - N DFN,SDA0,SDX,SDI,SDSCEL,SDEL,SDDATE,SDIFF,SDAPT,SDIVL,SDIVN - N SDREL,SDTOT,SDIV,SD0,SDNAME - D SCEL^SCRPW62(.SDSCEL,SDSCVT) ;Get eligibility code pointers - S DFN=0 F S DFN=$O(^DPT(DFN)) Q:'DFN!SDSTOP D - .I DFN#1000=0 D STOP Q:SDSTOP ;Check for stop task request - .S SDEL=+$G(^DPT(DFN,.36)) Q:'$D(SDSCEL(SDEL)) ;Only SC vets - .S SDEL=SDSCEL(SDEL) - .Q:+$G(^DPT(DFN,.35)) ;No deceased patients - .S SDI=DT F S SDI=$O(^DPT(DFN,"S",SDI)) Q:'SDI D - ..S SDDATE=+$G(^DPT(DFN,"S",SDI,1)) Q:'SDDATE Q:SDDATE>SDI - ..S SDA0=$G(^DPT(DFN,"S",SDI,0)) Q:'$L(SDA0) - ..S SDIV=$P($G(^SC(+SDA0,0)),U,15) Q:'$$DIV(.SDIV) ;Division check - ..;Exclude cancelled appointments - ..S SDX=$P(SDA0,U,2) I $L(SDX),"PCA"[SDX Q - ..S SDIFF=$$FMDIFF^XLFDT(SDI,SDDATE) Q:SDIFF'>SDATES - ..S SDNAME=$P($G(^DPT(DFN,0)),U) Q:'$L(SDNAME) - ..;Record detailed information - ..S ^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN,SDI)=SDDATE_U_SDA0 - ..S ^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN)=$G(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN))+1 - ..Q - .Q - Q:SDSTOP - ;Tally up statistics - S SDIV=0 F S SDIV=$O(^TMP("SCRPW",$J,SDIV)) Q:'SDIV D - .S SDEL=0 F S SDEL=$O(^TMP("SCRPW",$J,SDIV,SDEL)) Q:'SDEL D - ..S SDNAME="" F S SDNAME=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME)) Q:SDNAME=""!SDOUT D - ...S DFN=0 F S DFN=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN)) Q:'DFN D - ....S ^TMP("SCRPW",$J,"STATS",SDIV,SDEL,"PTS")=$G(^TMP("SCRPW",$J,"STATS",SDIV,SDEL,"PTS"))+1 - ....S SDI=0 F S SDI=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN,SDI)) Q:'SDI D - .....S ^TMP("SCRPW",$J,"STATS",SDIV,SDEL,"APPTS")=$G(^TMP("SCRPW",$J,"STATS",SDIV,SDEL,"APPTS"))+1 - .....Q - ....Q - ...Q - ..Q - .Q - Q:SDSTOP - ;Print report - S SDIV="" F S SDIV=$O(SDDIV(SDIV)) Q:'SDIV S SDIV(SDDIV(SDIV))=SDIV - I 'SDDIV,$P(SDDIV,U,2)'="ALL DIVISIONS" D - .S SDIV($P(SDDIV,U,2))=$$PRIM^VASITE() - .Q - I $P(SDDIV,U,2)="ALL DIVISIONS" S SDI=0 D - .F S SDI=$O(^TMP("SCRPW",$J,SDI)) Q:'SDI D - ..S SDX=$P($G(^DG(40.8,SDI,0)),U) S:$L(SDX) SDIV(SDX)=SDI - ..Q - .Q - D:$E(IOST)="C" DISP0^SCRPW23 - I '$D(^TMP("SCRPW",$J)) D Q ;Negative report - .S SDIV=0 D DHDR^SCRPW40(3,.SDT),HDR^SCRPW62 - .S SDX="No appointments found that meet report criteria." - .I SDELIM W !,SDX Q - .W !!?(IOM-$L(SDX)\2),SDX - .I $E(IOST)="C",'SDOUT N DIR S DIR(0)="E" D ^DIR - .Q - G:SDFMT="S" ASUM - ;Print detailed report by division - S SDIVN="" F S SDIVN=$O(SDIV(SDIVN)) Q:SDIVN=""!SDOUT D - .S SDIV=SDIV(SDIVN) D ADPRT(.SDIV) - .Q - Q:SDOUT - ;Print summary -ASUM G:SDELIM AQ - S SDT(3)="STATISTICAL SUMMARY" D HDR^SCRPW62 Q:SDOUT - W !! S (SDTOT,SDIV,SDIVL)=0,SDIVN="" - F S SDIVN=$O(SDIV(SDIVN)) Q:SDIVN="" D - .S SDIVN(SDIV(SDIVN))=SDIVN S:$L(SDIVN)>SDIVL SDIVL=$L(SDIVN) - F S SDIV=$O(^TMP("SCRPW",$J,"STATS",SDIV)) Q:'SDIV D - .S SDEL=0 F S SDEL=$O(^TMP("SCRPW",$J,"STATS",SDIV,SDEL)) Q:'SDEL D - ..S SDAPT=^TMP("SCRPW",$J,"STATS",SDIV,SDEL,"APPTS"),SDTOT=SDTOT+SDAPT - ..S SDX=$$CSCEL(SDEL)_" appointments at "_SDIVN(SDIV)_":" - ..W !?(50-SDIVL),$J(SDX,(28+SDIVL)),?80,$J(SDAPT,6,0) - ..Q - .Q - W !?(50-SDIVL),$E(SDLINE,1,(36+SDIVL)),!?72,"TOTAL:",?80,$J(SDTOT,6,0) -AQ I $E(IOST)="C",'SDOUT N DIR S DIR(0)="E" D ^DIR - Q - ; -DIV(SDIV) ;Check division - S:'$L(SDIV) SDIV=$$PRIM^VASITE() - Q:'SDDIV 1 Q $D(SDDIV(+SDIV)) - ; - ; -STOP ;Check for stop task request - S:$G(ZTQUEUED) (SDOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q - ; -ADPRT(SDIV) ;Print report for a division - D DHDR^SCRPW40(3,.SDT) S:SDELIM SDPAGE=1 - I '$D(^TMP("SCRPW",$J,SDIV)) D HDR^SCRPW62 Q:SDOUT D Q - .S SDX="No appointments found for this division within report parameters!" - .I SDELIM W !,SDX Q - .W !!?(132-$L(SDX)\2),SDX Q - D HDR^SCRPW62 Q:SDOUT - S SDEL="" F S SDEL=$O(^TMP("SCRPW",$J,SDIV,SDEL)) Q:'SDEL!SDOUT D - .S SDNAME="" F S SDNAME=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME)) Q:SDNAME=""!SDOUT D - ..S DFN=0 F S DFN=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN)) Q:'DFN!SDOUT D - ...S SD0=$G(^DPT(DFN,0)) Q:'$L(SD0) - ...S SDREL=$S(SDEL=1:0,1:+$P($G(^DPT(DFN,.372,0)),U,4)) - ...S SDREL=SDREL+^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN) - ...D:$Y>(IOSL-(4+SDREL)) HDR^SCRPW62 Q:SDOUT - ...D PLINE(DFN,SD0,SDEL) - ...Q - ..Q - .Q - Q - ; -PLINE(DFN,SD0,SDEL) ;Print patient detail line - ;Input: DFN=patient ifn - ; SD0=zeroeth node of patient record - ; SDEL=1 or 3 to denote SC > or < 50% - ; - N SDSSN,SDNAME,SDDTE,SDADD,SDST,SDX,SDI,SDY,SDELN,SDZIP,SDZ,SDZA,SDII - S SDNAME=$P(SD0,U),SDSSN=$P(SD0,U,9),SDDTE=$$FMTE^XLFDT($P(SD0,U,16)) - S SDSSN=$E(SDSSN,1,3)_"-"_$E(SDSSN,4,5)_"-"_$E(SDSSN,6,10) - S SDEL=$G(SDEL),SDELN=$$CSCEL(SDEL),SDADD=$G(^DPT(DFN,.11)) - S SDST=$P($G(^DIC(5,+$P(SDADD,U,5),0)),U,2),SDZIP=$P(SDADD,U,12) - S:$L(SDZIP)=9 SDZIP=$E(SDZIP,1,5)_"-"_$E(SDZIP,6,9) - I SDELIM D ;Set up delimited output - .S SDZ=SDNAME_U_SDSSN_U_SDELN_U_SDDTE_U_$P(SDADD,U)_U_$P(SDADD,U,4) - .S SDZ=SDZ_U_SDST_U_SDZIP_U_$P($G(^DPT(DFN,.13)),U) - .Q - I 'SDELIM D - .;Print name, SSN, eligibility, date entered, address and phone number - .W !,"Name: ",SDNAME,?39,"SSN: ",SDSSN,?58,"Prim. Elig.: ",SDELN - .W ?84,"Date entered: ",SDDTE,!?10,"Address: ",$P(SDADD,U) - .W ?55,$P(SDADD,U,4),$S($L($P(SDADD,U,4)):", ",1:""),SDST," ",SDZIP - .W ?88,"Phone number: ",$P($G(^DPT(DFN,.13)),U) - .;Print SC disabilities for 0-50% SC veterans - .I SDEL=3 S SDI=0 F S SDI=$O(^DPT(DFN,.372,SDI)) Q:'SDI D - ..S SDX=$G(^DPT(DFN,.372,SDI,0)) Q:'$P(SDX,U,3) - ..S SDY=$G(^DIC(31,+SDX,0)) Q:'$L(SDY) - ..W !?20,"SC disability: ",$P(SDY,U,3)," ",$P(SDY,U) - ..W ?89,"%SC: ",$P(SDX,U,2) - ..Q - .Q - I SDRPT="E" D Q - .I SDELIM S SDZ(1)=SDZ D DELIM^SCRPW62(.SDZ) Q ;W !,SDZ Q - .W ! - .Q - ;Print appointment details for future appointment report - S SDI=0 D - .F S SDI=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN,SDI)) Q:'SDI D - ..S SDA0=^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN,SDI) - ..I 'SDELIM D - ...W !?30,"Appointment: ",$$FMTE^XLFDT(SDI) - ...W ?63,$P($G(^SC(+$P(SDA0,U,2),0)),U),?96,"Desired date: " - ...W $$FMTE^XLFDT(+SDA0),?124,"(",$$FMDIFF^XLFDT(SDI,+SDA0),")" - ...Q - ..I SDELIM D ;Delimited output - ...N SDC0,SDCP,SDCZ,SDADM,SDADME - ...S SDC0=$G(^SC(+$P(SDA0,U,2),0)),SDCZ=$$CPAIR^SCRPW71(SDC0,.SDCP) - ...S SDII=0,(SDZA,SDADM,SDADME)="" - ...F S SDII=$O(^SC(+$P(SDA0,U,2),"S",SDI,1,SDII)) D Q:'SDII - ....Q:+$G(^SC(+$P(SDA0,U,2),"S",SDI,1,+SDII,0))'=DFN - ....S SDADM=$P(^SC(+$P(SDA0,U,2),"S",SDI,1,+SDII,0),U,7) - ....S SDADME=$$FMTE^XLFDT(SDADM),SDII=0 - ....Q - ...S SDCZ=SDCP_U_$P($$SITE^VASITE(,$P(SDC0,U,15)),U,2)_U_SDADME - ...S SDZA=SDZA_U_$$FMTE^XLFDT(SDI)_U_$P(SDC0,U)_U_SDCZ - ...S SDZA=SDZA_U_$$FMTE^XLFDT(+SDA0)_U_$$FMDIFF^XLFDT(SDI,+SDA0) - ...S SDZA=SDZA_U_$S(SDADM:$$FMDIFF^XLFDT(+SDA0,SDADM),1:"") - ...S SDZ(1)=SDZ_SDZA - ...D DELIM^SCRPW62(.SDZ) ;W !,SDZ,SDZA - ...Q - ..Q - .Q - W:'SDELIM ! Q - ; -CSCEL(SDEL) ;Convert SC elig. to external - Q $S(SDEL=1:"SC 50-100%",SDEL=3:"SC < 50%",1:"") +SCRPW63 ;BP-CIOFO/KEITH - SC veterans awaiting appointments (cont.) ; 23 August 2002@20:23 + ;;5.3;Scheduling;**267,269,357**;AUG 13, 1993 + ; +E ;Gather data for patients entered report + N DFN,SDX,SDATE,SD0,SDSCEL,SDEL,SDYR,SDREL,SDTOT,SDSDT,SDLVDT,SDEDT + N SDNAME + D SCEL^SCRPW62(.SDSCEL,SDSCVT) ;Get eligibility code pointers + S (SDSDT,SDATE)=DT-(10000*SDATES),SDSTOP=0 + ;Find the patients entered after date specified + S DFN=0 F Q:SDSTOP S DFN=$O(^DPT(DFN)) Q:'DFN D + .Q:$D(^DPT(DFN,-9)) ;Skip merged records + .I DFN#1000=0 D STOP Q:SDSTOP ;Check for stop task request + .S SDLVDT="" + .S SD0=$G(^DPT(DFN,0)) Q:'$L(SD0) + .S SDEDT=$P(SD0,U,16) S:SDEDT SDLVDT=SDEDT + .I SDEDT,SDEDT(IOSL-(4+SDREL)) HDR^SCRPW62 Q:SDOUT + ...S SDX=^TMP("SCRPW",$J,SDEL,SDNAME,DFN) D PLINE(DFN,SDX,SDEL) + ...Q + .Q + Q:SDOUT +ESUM ;Print summary + G:SDELIM EQ + S SDT(3)="STATISTICAL SUMMARY" D HDR^SCRPW62 Q:SDOUT + W !! S SDYR="",SDTOT=0 + F S SDYR=$O(^TMP("SCRPW",$J,"STATS",SDYR)) Q:SDYR="" D + .S SDEL=0 F S SDEL=$O(^TMP("SCRPW",$J,"STATS",SDYR,SDEL)) Q:'SDEL D + ..S SDX=$$CSCEL(SDEL)_" veterans entered "_$S(SDYR=0:"in the past year",SDYR=1:"two years ago",SDYR=2:"three years ago",1:"")_":" + ..W !?36,$J(SDX,45),?83,$J(^TMP("SCRPW",$J,"STATS",SDYR,SDEL),6,0) + ..S SDTOT=SDTOT+^TMP("SCRPW",$J,"STATS",SDYR,SDEL) + ..Q + .Q + W !?36,$E(SDLINE,1,53),!?75,"TOTAL:",?83,$J(SDTOT,6,0) +EQ I $E(IOST,1,2)="C-" N DIR S DIR(0)="E" W !! D ^DIR + Q + ; +SCHAPP(DFN) ;Look for scheduled appointments not cancelled by clinic + ; Input: DFN=patient ifn + ;Output: '1' if appointments exist, '0' otherwise + N SDI,SDX,SDY + S (SDI,SDY)=0 + F S SDI=$O(^DPT(DFN,"S",SDI)) Q:'SDI!SDY D + .S SDX=$G(^DPT(DFN,"S",SDI,0)) Q:'$L(SDX) + .S SDX=$P(SDX,U,2) I $L(SDX),"CA"[SDX Q + .S SDY=1 + .Q + Q SDY + ; +A ;Gather data for future appointments report + N DFN,SDA0,SDX,SDI,SDSCEL,SDEL,SDDATE,SDIFF,SDAPT,SDIVL,SDIVN + N SDREL,SDTOT,SDIV,SD0,SDNAME + D SCEL^SCRPW62(.SDSCEL,SDSCVT) ;Get eligibility code pointers + S DFN=0 F S DFN=$O(^DPT(DFN)) Q:'DFN!SDSTOP D + .I DFN#1000=0 D STOP Q:SDSTOP ;Check for stop task request + .S SDEL=+$G(^DPT(DFN,.36)) Q:'$D(SDSCEL(SDEL)) ;Only SC vets + .S SDEL=SDSCEL(SDEL) + .Q:+$G(^DPT(DFN,.35)) ;No deceased patients + .S SDI=DT F S SDI=$O(^DPT(DFN,"S",SDI)) Q:'SDI D + ..S SDDATE=+$G(^DPT(DFN,"S",SDI,1)) Q:'SDDATE Q:SDDATE>SDI + ..S SDA0=$G(^DPT(DFN,"S",SDI,0)) Q:'$L(SDA0) + ..S SDIV=$P($G(^SC(+SDA0,0)),U,15) Q:'$$DIV(.SDIV) ;Division check + ..;Exclude cancelled appointments + ..S SDX=$P(SDA0,U,2) I $L(SDX),"PCA"[SDX Q + ..S SDIFF=$$FMDIFF^XLFDT(SDI,SDDATE) Q:SDIFF'>SDATES + ..S SDNAME=$P($G(^DPT(DFN,0)),U) Q:'$L(SDNAME) + ..;Record detailed information + ..S ^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN,SDI)=SDDATE_U_SDA0 + ..S ^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN)=$G(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN))+1 + ..Q + .Q + Q:SDSTOP + ;Tally up statistics + S SDIV=0 F S SDIV=$O(^TMP("SCRPW",$J,SDIV)) Q:'SDIV D + .S SDEL=0 F S SDEL=$O(^TMP("SCRPW",$J,SDIV,SDEL)) Q:'SDEL D + ..S SDNAME="" F S SDNAME=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME)) Q:SDNAME=""!SDOUT D + ...S DFN=0 F S DFN=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN)) Q:'DFN D + ....S ^TMP("SCRPW",$J,"STATS",SDIV,SDEL,"PTS")=$G(^TMP("SCRPW",$J,"STATS",SDIV,SDEL,"PTS"))+1 + ....S SDI=0 F S SDI=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN,SDI)) Q:'SDI D + .....S ^TMP("SCRPW",$J,"STATS",SDIV,SDEL,"APPTS")=$G(^TMP("SCRPW",$J,"STATS",SDIV,SDEL,"APPTS"))+1 + .....Q + ....Q + ...Q + ..Q + .Q + Q:SDSTOP + ;Print report + S SDIV="" F S SDIV=$O(SDDIV(SDIV)) Q:'SDIV S SDIV(SDDIV(SDIV))=SDIV + I 'SDDIV,$P(SDDIV,U,2)'="ALL DIVISIONS" D + .S SDIV($P(SDDIV,U,2))=$$PRIM^VASITE() + .Q + I $P(SDDIV,U,2)="ALL DIVISIONS" S SDI=0 D + .F S SDI=$O(^TMP("SCRPW",$J,SDI)) Q:'SDI D + ..S SDX=$P($G(^DG(40.8,SDI,0)),U) S:$L(SDX) SDIV(SDX)=SDI + ..Q + .Q + D:$E(IOST)="C" DISP0^SCRPW23 + I '$D(^TMP("SCRPW",$J)) D Q ;Negative report + .S SDIV=0 D DHDR^SCRPW40(3,.SDT),HDR^SCRPW62 + .S SDX="No appointments found that meet report criteria." + .I SDELIM W !,SDX Q + .W !!?(IOM-$L(SDX)\2),SDX + .I $E(IOST)="C",'SDOUT N DIR S DIR(0)="E" D ^DIR + .Q + G:SDFMT="S" ASUM + ;Print detailed report by division + S SDIVN="" F S SDIVN=$O(SDIV(SDIVN)) Q:SDIVN=""!SDOUT D + .S SDIV=SDIV(SDIVN) D ADPRT(.SDIV) + .Q + Q:SDOUT + ;Print summary +ASUM G:SDELIM AQ + S SDT(3)="STATISTICAL SUMMARY" D HDR^SCRPW62 Q:SDOUT + W !! S (SDTOT,SDIV,SDIVL)=0,SDIVN="" + F S SDIVN=$O(SDIV(SDIVN)) Q:SDIVN="" D + .S SDIVN(SDIV(SDIVN))=SDIVN S:$L(SDIVN)>SDIVL SDIVL=$L(SDIVN) + F S SDIV=$O(^TMP("SCRPW",$J,"STATS",SDIV)) Q:'SDIV D + .S SDEL=0 F S SDEL=$O(^TMP("SCRPW",$J,"STATS",SDIV,SDEL)) Q:'SDEL D + ..S SDAPT=^TMP("SCRPW",$J,"STATS",SDIV,SDEL,"APPTS"),SDTOT=SDTOT+SDAPT + ..S SDX=$$CSCEL(SDEL)_" appointments at "_SDIVN(SDIV)_":" + ..W !?(50-SDIVL),$J(SDX,(28+SDIVL)),?80,$J(SDAPT,6,0) + ..Q + .Q + W !?(50-SDIVL),$E(SDLINE,1,(36+SDIVL)),!?72,"TOTAL:",?80,$J(SDTOT,6,0) +AQ I $E(IOST)="C",'SDOUT N DIR S DIR(0)="E" D ^DIR + Q + ; +DIV(SDIV) ;Check division + S:'$L(SDIV) SDIV=$$PRIM^VASITE() + Q:'SDDIV 1 Q $D(SDDIV(+SDIV)) + ; + ; +STOP ;Check for stop task request + S:$G(ZTQUEUED) (SDOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q + ; +ADPRT(SDIV) ;Print report for a division + D DHDR^SCRPW40(3,.SDT) S:SDELIM SDPAGE=1 + I '$D(^TMP("SCRPW",$J,SDIV)) D HDR^SCRPW62 Q:SDOUT D Q + .S SDX="No appointments found for this division within report parameters!" + .I SDELIM W !,SDX Q + .W !!?(132-$L(SDX)\2),SDX Q + D HDR^SCRPW62 Q:SDOUT + S SDEL="" F S SDEL=$O(^TMP("SCRPW",$J,SDIV,SDEL)) Q:'SDEL!SDOUT D + .S SDNAME="" F S SDNAME=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME)) Q:SDNAME=""!SDOUT D + ..S DFN=0 F S DFN=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN)) Q:'DFN!SDOUT D + ...S SD0=$G(^DPT(DFN,0)) Q:'$L(SD0) + ...S SDREL=$S(SDEL=1:0,1:+$P($G(^DPT(DFN,.372,0)),U,4)) + ...S SDREL=SDREL+^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN) + ...D:$Y>(IOSL-(4+SDREL)) HDR^SCRPW62 Q:SDOUT + ...D PLINE(DFN,SD0,SDEL) + ...Q + ..Q + .Q + Q + ; +PLINE(DFN,SD0,SDEL) ;Print patient detail line + ;Input: DFN=patient ifn + ; SD0=zeroeth node of patient record + ; SDEL=1 or 3 to denote SC > or < 50% + ; + N SDSSN,SDNAME,SDDTE,SDADD,SDST,SDX,SDI,SDY,SDELN,SDZIP,SDZ,SDZA,SDII + S SDNAME=$P(SD0,U),SDSSN=$P(SD0,U,9),SDDTE=$$FMTE^XLFDT($P(SD0,U,16)) + S SDSSN=$E(SDSSN,1,3)_"-"_$E(SDSSN,4,5)_"-"_$E(SDSSN,6,10) + S SDEL=$G(SDEL),SDELN=$$CSCEL(SDEL),SDADD=$G(^DPT(DFN,.11)) + S SDST=$P($G(^DIC(5,+$P(SDADD,U,5),0)),U,2),SDZIP=$P(SDADD,U,12) + S:$L(SDZIP)=9 SDZIP=$E(SDZIP,1,5)_"-"_$E(SDZIP,6,9) + I SDELIM D ;Set up delimited output + .S SDZ=SDNAME_U_SDSSN_U_SDELN_U_SDDTE_U_$P(SDADD,U)_U_$P(SDADD,U,4) + .S SDZ=SDZ_U_SDST_U_SDZIP_U_$P($G(^DPT(DFN,.13)),U) + .Q + I 'SDELIM D + .;Print name, SSN, eligibility, date entered, address and phone number + .W !,"Name: ",SDNAME,?39,"SSN: ",SDSSN,?58,"Prim. Elig.: ",SDELN + .W ?84,"Date entered: ",SDDTE,!?10,"Address: ",$P(SDADD,U) + .W ?55,$P(SDADD,U,4),$S($L($P(SDADD,U,4)):", ",1:""),SDST," ",SDZIP + .W ?88,"Phone number: ",$P($G(^DPT(DFN,.13)),U) + .;Print SC disabilities for 0-50% SC veterans + .I SDEL=3 S SDI=0 F S SDI=$O(^DPT(DFN,.372,SDI)) Q:'SDI D + ..S SDX=$G(^DPT(DFN,.372,SDI,0)) Q:'$P(SDX,U,3) + ..S SDY=$G(^DIC(31,+SDX,0)) Q:'$L(SDY) + ..W !?20,"SC disability: ",$P(SDY,U,3)," ",$P(SDY,U) + ..W ?89,"%SC: ",$P(SDX,U,2) + ..Q + .Q + I SDRPT="E" D Q + .I SDELIM W !,SDZ Q + .W ! + .Q + ;Print appointment details for future appointment report + S SDI=0 D + .F S SDI=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN,SDI)) Q:'SDI D + ..S SDA0=^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN,SDI) + ..I 'SDELIM D + ...W !?30,"Appointment: ",$$FMTE^XLFDT(SDI) + ...W ?63,$P($G(^SC(+$P(SDA0,U,2),0)),U),?96,"Desired date: " + ...W $$FMTE^XLFDT(+SDA0),?124,"(",$$FMDIFF^XLFDT(SDI,+SDA0),")" + ...Q + ..I SDELIM D ;Delimited output + ...N SDC0,SDCP,SDCZ,SDADM,SDADME + ...S SDC0=$G(^SC(+$P(SDA0,U,2),0)),SDCZ=$$CPAIR^SCRPW71(SDC0,.SDCP) + ...S SDII=0,(SDZA,SDADM,SDADME)="" + ...F S SDII=$O(^SC(+$P(SDA0,U,2),"S",SDI,1,SDII)) D Q:'SDII + ....Q:+$G(^SC(+$P(SDA0,U,2),"S",SDI,1,+SDII,0))'=DFN + ....S SDADM=$P(^SC(+$P(SDA0,U,2),"S",SDI,1,+SDII,0),U,7) + ....S SDADME=$$FMTE^XLFDT(SDADM),SDII=0 + ....Q + ...S SDCZ=SDCP_U_$P($$SITE^VASITE(,$P(SDC0,U,15)),U,2)_U_SDADME + ...S SDZA=SDZA_U_$$FMTE^XLFDT(SDI)_U_$P(SDC0,U)_U_SDCZ + ...S SDZA=SDZA_U_$$FMTE^XLFDT(+SDA0)_U_$$FMDIFF^XLFDT(SDI,+SDA0) + ...S SDZA=SDZA_U_$S(SDADM:$$FMDIFF^XLFDT(+SDA0,SDADM),1:"") + ...W !,SDZ,SDZA + ...Q + ..Q + .Q + W:'SDELIM ! Q + ; +CSCEL(SDEL) ;Convert SC elig. to external + Q $S(SDEL=1:"SC 50-100%",SDEL=3:"SC < 50%",1:"") diff --git a/r/SCHEDULING-SD-SC/SCRPW8.m b/r/SCHEDULING-SD-SC/SCRPW8.m index 05e7767e..c19c74a5 100644 --- a/r/SCHEDULING-SD-SC/SCRPW8.m +++ b/r/SCHEDULING-SD-SC/SCRPW8.m @@ -1,144 +1,133 @@ -SCRPW8 ;RENO/KEITH - Outpatient Encounter Workload Statistics ; 04 Feb 99 4:53 PM - ;;5.3;Scheduling;**139,145,144,176,339,466,510**;AUG 13, 1993;Build 3 -QS ;Queue outpatient encounter workload report - D PARM^SCRPW9 Q - ; -PST ;Print stats - N X,Y,% - D NOW^%DTC S Y=% X ^DD("DD") S SDPAGE=1,SDPNOW=$P(Y,":",1,2),SDDT=SDDTF,SDMC=$O(^DG(43,0)),SDMC=$G(^DG(43,+SDMC,"GL")),SDMD=$P(SDMC,U,2),(SDOUT,SDSTOP,SDFF)=0 - S SDDNAM=$P($G(^DG(40.8,+$$PRIM^VASITE(),0)),U,7),SDDNAM=$$GET1^DIQ(4,+SDDNAM,.01) S:'$L(SDDNAM) SDDNAM=$P($G(^DG(40.8,+$P(SDMC,U,3),0)),U) - F I="SCRPW","SCRPWD","SCRPWC" K ^TMP(I,$J) - F S SDDT=$O(^SCE("B",SDDT)) Q:'SDDT!(SDDT>SDDTL)!SDOUT S SDOE=0 D - .F S SDOE=$O(^SCE("B",SDDT,SDOE)) Q:'SDOE!SDOUT S SDOE0=$$GETOE^SDOE(SDOE) I $L(SDOE0),'$P(SDOE0,U,6),$P(SDOE0,U,2),$P(SDOE0,U,11),$P(SDOE0,U,12) S SDDIV=$$DIV(),SDCG=$$CLGR() D COUNT - .Q - I '$D(^TMP("SCRPW",$J)) D XHDR S SDX="No activity found within the parameters specified." W !!?(80-$L(SDX)\2),SDX G EXIT - F SDS1="SCRPW","SCRPWD","SCRPWC" S SDS2="" F S SDS2=$O(^TMP(SDS1,$J,SDS2)) Q:SDS2=""!SDOUT D STCT - G:SDOUT EXIT D:$E(IOST)="C" DISP0^SCRPW23 - F SDS1="SCRPW","SCRPWD","SCRPWC" S SDS2="" F S SDS2=$O(^TMP(SDS1,$J,SDS2)) Q:SDS2=""!SDOUT D PRPT - G:SDOUT EXIT - D:SDZ(0) DPRT^SCRPW9("SCRPW",SDDNAM) G:SDOUT EXIT D:SDUL UNARL^SCRPW9("SCRPW",SDDNAM) G EXIT - ; -STCT S (SDUNCO,SDCT,DFN)=0 D STOP Q:SDOUT - F S DFN=$O(^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN)) Q:'DFN S SDUNCO=SDUNCO+1,SDDT=0 F S SDDT=$O(^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN,SDDT)) Q:'SDDT S SDCT=SDCT+1 - S ^TMP(SDS1,$J,SDS2,"UNIQUE","UNCO")=SDUNCO,^TMP(SDS1,$J,SDS2,"VISIT","OWK")=SDCT,(SDUNAR,SDCT,DFN)=0 - S DFN=0 F S DFN=$O(^TMP(SDS1,$J,SDS2,"VISIT","OWK",DFN)) Q:'DFN D NCT1 - S DFN=0 F S DFN=$O(^TMP(SDS1,$J,SDS2,"VISIT","NWK",DFN)) Q:'DFN D CT1 - S ^TMP(SDS1,$J,SDS2,"UNIQUE","UNAR")=SDUNAR,^TMP(SDS1,$J,SDS2,"VISIT","NWK")=SDCT Q - ; -PRPT ;Print statistics page - D STOP Q:SDOUT - S SDCT=0 F SDI=1,2,3,11,14,"8-CC" S SDCT=SDCT+$G(^TMP(SDS1,$J,SDS2,SDI)) - D XHDR Q:SDOUT D SHDR("O U T P A T I E N T E N C O U N T E R W O R K L O A D") Q:SDOUT F SDI=11,14,3,1 D LIST(SDI) Q:SDOUT - I $D(^TMP(SDS1,$J,SDS2,2)) D:$Y>(IOSL-4) XHDR Q:SDOUT W !?10,"CHECKED OUT" S SDI=0 F S SDI=$O(^TMP(SDS1,$J,SDS2,2,SDI)) Q:'SDI!SDOUT S SDSTAT=$O(^TMP(SDS1,$J,SDS2,2,SDI,"")) D COT - I $D(^TMP(SDS1,$J,SDS2,"8-CC")) D:$Y>(IOSL-4) XHDR Q:SDOUT W !?10,"INPATIENT APPOINTMENT" S SDI=0 F S SDI=$O(^TMP(SDS1,$J,SDS2,"8-CC",SDI)) Q:'SDI!SDOUT S SDSTAT=$O(^TMP(SDS1,$J,SDS2,"8-CC",SDI,"")) D IAP - D TOT S (SDI,SDCT)=0 F SDI=4,5,6,7,"8-NC",9,12,13 S SDCT=SDCT+$G(^TMP(SDS1,$J,SDS2,SDI)) - W !! D SHDR("N O N - W O R K L O A D") Q:SDOUT F SDI="8-NC",12,4,6,5,7,9,10,13 D LIST(SDI) Q:SDOUT - D TOT W !! D SHDR(($$HD2()_" O U T P A T I E N T V I S I T S")) Q:SDOUT S SDCT=^TMP(SDS1,$J,SDS2,"VISIT","NWK")+^TMP(SDS1,$J,SDS2,"VISIT","OWK") - D:$Y>(IOSL-4) XHDR Q:SDOUT W !?10,"Act. Req./not accepted visits",?47,$J(^TMP(SDS1,$J,SDS2,"VISIT","NWK"),12),?62,$J($S(SDCT=0:0,1:(^TMP(SDS1,$J,SDS2,"VISIT","NWK")*100/SDCT)),8,2) - D:$Y>(IOSL-4) XHDR Q:SDOUT W !?10,"Transmitted, accepted visits",?47,$J(^TMP(SDS1,$J,SDS2,"VISIT","OWK"),12),?62,$J($S(SDCT=0:0,1:(^TMP(SDS1,$J,SDS2,"VISIT","OWK")*100/SDCT)),8,2) - D TOT - W !! D SHDR(($$HD2()_" O U T P A T I E N T U N I Q U E S")) Q:SDOUT - S SDUNCO=^TMP(SDS1,$J,SDS2,"UNIQUE","UNCO"),SDUNAR=^TMP(SDS1,$J,SDS2,"UNIQUE","UNAR"),SDCT=SDUNCO+SDUNAR - D:$Y>(IOSL-4) XHDR Q:SDOUT W !?10,"Act. Req./not accepted unique pts.",?47,$J(SDUNAR,12),?62,$J($S(SDCT=0:0,1:SDUNAR*100/SDCT),8,2) - D:$Y>(IOSL-4) XHDR Q:SDOUT W !?10,"Transmitted, accepted unique pts.",?47,$J(SDUNCO,12),?62,$J($S(SDCT=0:0,1:SDUNCO*100/SDCT),8,2) D TOT - Q - ; -XHDR I $E(IOST)="C",SDPAGE>1 N DIR S DIR(0)="E" D ^DIR S SDOUT=Y'=1 Q:SDOUT - S SDLINE="",$P(SDLINE,"-",81)="" W:SDPAGE>1!($E(IOST)="C") $$XY^SCRPW50(IOF,1,0) W:$X $$XY^SCRPW50("",0,0) W SDLINE,!?15,"<*> OUTPATIENT ENCOUNTER WORKLOAD STATISTICS <*>" - I $D(^TMP("SCRPW",$J)) S X=$$HD1() W !?(80-$L(X)\2),X - W !,SDLINE,!,"For encounter dates ",SDDTPF," to ",SDDTPL,!,"Date printed: ",SDPNOW,?(74-$L(SDPAGE)),"Page: ",SDPAGE,!,SDLINE,! S SDPAGE=SDPAGE+1 - Q - ; -EXIT K SDTOE0,SDUNCO,SDUNAR,SDCT,DFN,SDDT,SDDTF,SDDTL,SDDTPF,SDDTPL,SDI,SDLINE,SDOE,SDOE0,SDPNOW,SDSTAT,SDSTX,SDTOE,SDTOEE,SDTOE1,SDTX,SDTXS,SDX,SDZ,DTOUT,X,Y,ZTDESC,ZTRTN,ZTSAVE - D KVA^VADPT K X1,X2,SDH,SDHL,SDPNAM,SDSSN,SDPAGE,SDPT0,SDUL,DUOUT,SDARCT,SDST,SDPNOW,SDMD,SDMC,SDDIV,SDDNAM,SDS1,SDS2,SDCG,SDCLGR F I="SCRPW","SCRPWD","SCRPWC" K ^TMP(I,$J) - K I,SDFF,SDOUT,SDSTOP,SDNCOU D END^SCRPW50 Q - ; -HD1() ;Report subheader 1 - Q $S(SDS1="SCRPW":"For station: ",SDS1="SCRPWD":"For division: ",1:"For clinic group: ")_SDS2 - ; -HD2() ;Report subheader 2 - Q $S(SDS1="SCRPW":"F A C I L I T Y",SDS1="SCRPWD":"D I V I S I O N",1:"C L I N I C G R O U P") - ; -DIV() ;Return division name - N X S X=$P($G(^DG(40.8,+$P(SDOE0,U,11),0)),U) Q $S('$L(X):"***UNKNOWN***",1:X) - ; -CLGR() ;Return CLINIC GROUP pointer - N X S X=$P($G(^SC(+$P(SDOE0,U,4),0)),U,31),X=$P($G(^SD(409.67,+X,0)),U) Q $S('$L(X):"***NONE ASSIGNED***",1:X) - ; -NCT1 I '$D(^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN)) S SDUNAR=SDUNAR+1 D:SDUL&(SDS1="SCRPW") UL("OWK") - S SDDT=0 F S SDDT=$O(^TMP(SDS1,$J,SDS2,"VISIT","OWK",DFN,SDDT)) Q:'SDDT I '$D(^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN,SDDT)) S SDCT=SDCT+1 - Q - ; -CT1 I '$D(^TMP(SDS1,$J,SDS2,"VISIT","OWK",DFN)),'$D(^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN)) S SDUNAR=SDUNAR+1 D:SDUL&(SDS1="SCRPW") UL("NWK") - S SDDT=0 F S SDDT=$O(^TMP(SDS1,$J,SDS2,"VISIT","NWK",DFN,SDDT)) Q:'SDDT I '$D(^TMP(SDS1,$J,SDS2,"VISIT","OWK",DFN,SDDT)),'$D(^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN,SDDT)) S SDCT=SDCT+1 - Q - ; -UL(SDI) D ^VADPT S SDDT=0 F S SDDT=$O(^TMP(SDS1,$J,SDS2,"VISIT",SDI,DFN,SDDT)) Q:'SDDT S ^TMP(SDS1,$J,SDS2,"VISIT","UNARL",VADM(1),DFN,$P(VADM(2),U),SDDT)="" - Q - ; -TOT W !?47,"============ =========",!?39,"TOTAL:",?47,$J(SDCT,12),?64,"100.00" Q - ; -SHDR(SDTX) D:$Y>(IOSL-6) XHDR Q:SDOUT W !!?(80-$L(SDTX)\2),SDTX,!?(80-$L(SDTX)\2) F SDX=1:1:$L(SDTX) W "-" - W !!?39,"Status",?54,"Count",?63,"Percent",!?10,"----------------------------------- ------------ ---------" Q - ; -LIST(SDI) Q:'$D(^TMP(SDS1,$J,SDS2,SDI)) D:$Y>(IOSL-4) XHDR Q:SDOUT - W !?10,$P(^SD(409.63,+SDI,0),U),?47,$J(^TMP(SDS1,$J,SDS2,SDI),12),?62,$J($S(SDCT=0:0,1:(^TMP(SDS1,$J,SDS2,SDI)*100/SDCT)),8,2) - Q - ; -COT D:$Y>(IOSL-4) XHDR Q:SDOUT W !?15,SDSTAT,?47,$J(^TMP(SDS1,$J,SDS2,2,SDI,SDSTAT),12),?62,$J($S(SDCT=0:0,1:(^TMP(SDS1,$J,SDS2,2,SDI,SDSTAT)*100/SDCT)),8,2) Q - ; -IAP D:$Y>(IOSL-4) XHDR Q:SDOUT W !?15,SDSTAT,?47,$J(^TMP(SDS1,$J,SDS2,"8-CC",SDI,SDSTAT),12),?62,$J($S(SDCT=0:0,1:(^TMP(SDS1,$J,SDS2,"8-CC",SDI,SDSTAT)*100/SDCT)),8,2) Q -STOP ;Check for stop task request - S:$G(ZTQUEUED) (SDOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q - ; -COUNT ;Count encounters - S SDNCOU=$P($G(^SC(+$P(SDOE0,U,4),0)),U,17),SDNCOU=$S(SDNCOU="Y":1,1:0) - S SDSTOP=SDSTOP+1 I SDSTOP#3000=0 D STOP Q:SDOUT - D C1("SCRPW",SDDNAM) D:SDMD C1("SCRPWD",SDDIV) D:SDCLGR C1("SCRPWC",SDCG) Q - ; -C1(SDS1,SDS2) ;Set ^TMP global - ;Required input: SDS1,SDS2=subscript values - ;Because there is only 1 status (8) for INPATIENTS, 8-NC is used to - ;distinguish the non-count clinics from the count clinics, 8-CC. - S DFN=$P(SDOE0,U,2),SDSTAT=+$P(SDOE0,U,12) I SDSTAT=8 S SDSTAT=$S(SDNCOU:SDSTAT_"-NC",1:SDSTAT_"-CC") - I SDZ(0),SDZ(4)=SDDIV,SDS1="SCRPW" D DETAIL - S ^TMP(SDS1,$J,SDS2,SDSTAT)=$G(^TMP(SDS1,$J,SDS2,SDSTAT))+1 - Q:SDSTAT=4 Q:(+SDSTAT=8)&($P(SDSTAT,"-",2)="NC") D:"114238"[+SDSTAT VIS Q - ; -VIS S ^TMP(SDS1,$J,SDS2,"VISIT",$S(SDSTAT=2:"OWK",(+SDSTAT=8)&('SDNCOU):"OWK",1:"NWK"),DFN,$P(SDDT,"."))="" Q:(+SDSTAT'=2)&(+SDSTAT'=8) - I +SDSTAT=8,$P(SDOE0,U,7)="" D Q - .S ^TMP(SDS1,$J,SDS2,SDSTAT,10,"Action Required")=$G(^TMP(SDS1,$J,SDS2,SDSTAT,10,"Action Required"))+1 - S SDSTX=$$STX(SDOE,SDOE0),^TMP(SDS1,$J,SDS2,SDSTAT,$P(SDSTX,U),$P(SDSTX,U,2))=$G(^TMP(SDS1,$J,SDS2,SDSTAT,$P(SDSTX,U),$P(SDSTX,U,2)))+1 - Q:$P(SDSTX,U)'=8 S ^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN,$P(SDDT,"."))="" - Q - ; -STX(SDOE,SDOE0) ;Determine transmission status - ;Required input: SDOE=OUTPATIENT ENCOUNTER record IFN - ;Required input: SDOE0=zeroeth node of OUTPATIENT ENCOUNTER - N SDTOE,SDTOEE - Q:($P(SDOE0,U,12)'=2)&($P(SDOE0,U,12)'=8) "0^Not checked-out^Not checked-out" - S SDTOE=$O(^SD(409.73,"AENC",SDOE,0)) Q:'SDTOE!'$D(^SD(409.73,+SDTOE,0)) "1^No transmission record^No tx. record" - S SDTOE1=$G(^SD(409.73,SDTOE,1)),SDTOE0=^SD(409.73,SDTOE,0) I '$P(SDTOE0,U,4),'$P(SDTOE1,U) Q "2^Not required, not transmitted^Not req., not tx." - ; SD*5.3*339 added second I SDTOEE below - S SDTOEE=$O(^SD(409.75,"B",SDTOE,0)) I SDTOEE S SDTOEE=$P($G(^SD(409.75,SDTOEE,0)),U,2) I SDTOEE S SDTOEE=$P($G(^SD(409.76,SDTOEE,0)),U,2) Q:SDTOEE="V" "3^Rejected for transmission^Rejected for tx." - Q:'$P(SDTOE1,U) "4^Awaiting transmission^Awaiting tx." - S SDTXS=$P(SDTOE1,U,5) Q:'$L(SDTXS) "5^Transmitted, no acknowledgment^Tx., no ack." - Q:SDTXS="R" "6^Transmitted, rejected^Tx., rejected" - Q:SDTXS'="A" "7^Transmitted, error^Tx., error" - Q "8^Transmitted, accepted^Tx., accepted" - ; -DETAIL ;Set global for detailed list - N SDIF S SDIF=0 - D ^VADPT S SDPNAM=VADM(1),SDSSN=$P(VADM(2),U) - I SDZ(1)="U",+SDSTAT'=4,'SDNCOU S:"114238"[+SDSTAT ^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN)="" Q - I SDZ(1)="V",+SDSTAT'=4,'SDNCOU S:"114238"[+SDSTAT ^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN,$P(SDDT,"."))="" Q - Q:'$D(SDZ(2)) ; SD*5.3*339 - I SDZ(2)'=2,SDZ(2)=+SDSTAT D I SDIF Q - .I (SDZ(2)=8) Q:$P(SDSTAT,"-",2)="CC" I SDZ(3)'=9 S SDIF=1 Q - .D DSET S SDIF=1 - Q:("28"'[SDZ(2))!("28"'[+SDSTAT) Q:SDZ(2)'=+SDSTAT D I SDIF Q - .I +SDSTAT=8,$P(SDSTAT,"-",2)="NC" S SDIF=1 Q - .I 'SDZ(3) D DSET S SDIF=1 - D:+$$STX(SDOE,SDOE0)=SDZ(3) DSET Q - ; -DSET S ^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN,SDDT,SDOE)=+$P(SDOE0,U,4) Q +SCRPW8 ;RENO/KEITH - Outpatient Encounter Workload Statistics ; 04 Feb 99 4:53 PM + ;;5.3;Scheduling;**139,145,144,176,339,466**;AUG 13, 1993;Build 2 +QS ;Queue outpatient encounter workload report + D PARM^SCRPW9 Q + ; +PST ;Print stats + N X,Y,% + D NOW^%DTC S Y=% X ^DD("DD") S SDPAGE=1,SDPNOW=$P(Y,":",1,2),SDDT=SDDTF,SDMC=$O(^DG(43,0)),SDMC=$G(^DG(43,+SDMC,"GL")),SDMD=$P(SDMC,U,2),(SDOUT,SDSTOP,SDFF)=0 + S SDDNAM=$P($G(^DG(40.8,+$$PRIM^VASITE(),0)),U,7),SDDNAM=$$GET1^DIQ(4,+SDDNAM,.01) S:'$L(SDDNAM) SDDNAM=$P($G(^DG(40.8,+$P(SDMC,U,3),0)),U) + F I="SCRPW","SCRPWD","SCRPWC" K ^TMP(I,$J) + F S SDDT=$O(^SCE("B",SDDT)) Q:'SDDT!(SDDT>SDDTL)!SDOUT S SDOE=0 D + .F S SDOE=$O(^SCE("B",SDDT,SDOE)) Q:'SDOE!SDOUT S SDOE0=$$GETOE^SDOE(SDOE) I $L(SDOE0),'$P(SDOE0,U,6),$P(SDOE0,U,2),$P(SDOE0,U,11),$P(SDOE0,U,12) S SDDIV=$$DIV(),SDCG=$$CLGR() D COUNT + .Q + I '$D(^TMP("SCRPW",$J)) D XHDR S SDX="No activity found within the parameters specified." W !!?(80-$L(SDX)\2),SDX G EXIT + F SDS1="SCRPW","SCRPWD","SCRPWC" S SDS2="" F S SDS2=$O(^TMP(SDS1,$J,SDS2)) Q:SDS2=""!SDOUT D STCT + G:SDOUT EXIT D:$E(IOST)="C" DISP0^SCRPW23 + F SDS1="SCRPW","SCRPWD","SCRPWC" S SDS2="" F S SDS2=$O(^TMP(SDS1,$J,SDS2)) Q:SDS2=""!SDOUT D PRPT + G:SDOUT EXIT + D:SDZ(0) DPRT^SCRPW9("SCRPW",SDDNAM) G:SDOUT EXIT D:SDUL UNARL^SCRPW9("SCRPW",SDDNAM) G EXIT + ; +STCT S (SDUNCO,SDCT,DFN)=0 D STOP Q:SDOUT + F S DFN=$O(^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN)) Q:'DFN S SDUNCO=SDUNCO+1,SDDT=0 F S SDDT=$O(^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN,SDDT)) Q:'SDDT S SDCT=SDCT+1 + S ^TMP(SDS1,$J,SDS2,"UNIQUE","UNCO")=SDUNCO,^TMP(SDS1,$J,SDS2,"VISIT","OWK")=SDCT,(SDUNAR,SDCT,DFN)=0 + S DFN=0 F S DFN=$O(^TMP(SDS1,$J,SDS2,"VISIT","OWK",DFN)) Q:'DFN D NCT1 + S DFN=0 F S DFN=$O(^TMP(SDS1,$J,SDS2,"VISIT","NWK",DFN)) Q:'DFN D CT1 + S ^TMP(SDS1,$J,SDS2,"UNIQUE","UNAR")=SDUNAR,^TMP(SDS1,$J,SDS2,"VISIT","NWK")=SDCT Q + ; +PRPT ;Print statistics page + D STOP Q:SDOUT + S SDCT=0 F SDI=1,2,3,11,14,8 S SDCT=SDCT+$G(^TMP(SDS1,$J,SDS2,SDI)) + D XHDR Q:SDOUT D SHDR("O U T P A T I E N T E N C O U N T E R W O R K L O A D") Q:SDOUT F SDI=11,14,3,1 D LIST(SDI) Q:SDOUT + I $D(^TMP(SDS1,$J,SDS2,2)) D:$Y>(IOSL-4) XHDR Q:SDOUT W !?10,"CHECKED OUT" S SDI=0 F S SDI=$O(^TMP(SDS1,$J,SDS2,2,SDI)) Q:'SDI!SDOUT S SDSTAT=$O(^TMP(SDS1,$J,SDS2,2,SDI,"")) D COT + I $D(^TMP(SDS1,$J,SDS2,8)) D:$Y>(IOSL-4) XHDR Q:SDOUT W !?10,"INPATIENT APPOINTMENT" S SDI=0 F S SDI=$O(^TMP(SDS1,$J,SDS2,8,SDI)) Q:'SDI!SDOUT S SDSTAT=$O(^TMP(SDS1,$J,SDS2,8,SDI,"")) D IAP + D TOT S (SDI,SDCT)=0 F SDI=4,5,6,7,9,12,13 S SDCT=SDCT+$G(^TMP(SDS1,$J,SDS2,SDI)) + W !! D SHDR("N O N - W O R K L O A D") Q:SDOUT F SDI=12,4,6,5,7,9,10,13 D LIST(SDI) Q:SDOUT + D TOT W !! D SHDR(($$HD2()_" O U T P A T I E N T V I S I T S")) Q:SDOUT S SDCT=^TMP(SDS1,$J,SDS2,"VISIT","NWK")+^TMP(SDS1,$J,SDS2,"VISIT","OWK") + D:$Y>(IOSL-4) XHDR Q:SDOUT W !?10,"Act. Req./not accepted visits",?47,$J(^TMP(SDS1,$J,SDS2,"VISIT","NWK"),12),?62,$J($S(SDCT=0:0,1:(^TMP(SDS1,$J,SDS2,"VISIT","NWK")*100/SDCT)),8,2) + D:$Y>(IOSL-4) XHDR Q:SDOUT W !?10,"Transmitted, accepted visits",?47,$J(^TMP(SDS1,$J,SDS2,"VISIT","OWK"),12),?62,$J($S(SDCT=0:0,1:(^TMP(SDS1,$J,SDS2,"VISIT","OWK")*100/SDCT)),8,2) + D TOT + W !! D SHDR(($$HD2()_" O U T P A T I E N T U N I Q U E S")) Q:SDOUT + S SDUNCO=^TMP(SDS1,$J,SDS2,"UNIQUE","UNCO"),SDUNAR=^TMP(SDS1,$J,SDS2,"UNIQUE","UNAR"),SDCT=SDUNCO+SDUNAR + D:$Y>(IOSL-4) XHDR Q:SDOUT W !?10,"Act. Req./not accepted unique pts.",?47,$J(SDUNAR,12),?62,$J($S(SDCT=0:0,1:SDUNAR*100/SDCT),8,2) + D:$Y>(IOSL-4) XHDR Q:SDOUT W !?10,"Transmitted, accepted unique pts.",?47,$J(SDUNCO,12),?62,$J($S(SDCT=0:0,1:SDUNCO*100/SDCT),8,2) D TOT + Q + ; +XHDR I $E(IOST)="C",SDPAGE>1 N DIR S DIR(0)="E" D ^DIR S SDOUT=Y'=1 Q:SDOUT + S SDLINE="",$P(SDLINE,"-",81)="" W:SDPAGE>1!($E(IOST)="C") $$XY^SCRPW50(IOF,1,0) W:$X $$XY^SCRPW50("",0,0) W SDLINE,!?15,"<*> OUTPATIENT ENCOUNTER WORKLOAD STATISTICS <*>" + I $D(^TMP("SCRPW",$J)) S X=$$HD1() W !?(80-$L(X)\2),X + W !,SDLINE,!,"For encounter dates ",SDDTPF," to ",SDDTPL,!,"Date printed: ",SDPNOW,?(74-$L(SDPAGE)),"Page: ",SDPAGE,!,SDLINE,! S SDPAGE=SDPAGE+1 + Q + ; +EXIT K SDTOE0,SDUNCO,SDUNAR,SDCT,DFN,SDDT,SDDTF,SDDTL,SDDTPF,SDDTPL,SDI,SDLINE,SDOE,SDOE0,SDPNOW,SDSTAT,SDSTX,SDTOE,SDTOEE,SDTOE1,SDTX,SDTXS,SDX,SDZ,DTOUT,X,Y,ZTDESC,ZTRTN,ZTSAVE + D KVA^VADPT K X1,X2,SDH,SDHL,SDPNAM,SDSSN,SDPAGE,SDPT0,SDUL,DUOUT,SDARCT,SDST,SDPNOW,SDMD,SDMC,SDDIV,SDDNAM,SDS1,SDS2,SDCG,SDCLGR F I="SCRPW","SCRPWD","SCRPWC" K ^TMP(I,$J) + K I,SDFF,SDOUT,SDSTOP D END^SCRPW50 Q + ; +HD1() ;Report subheader 1 + Q $S(SDS1="SCRPW":"For station: ",SDS1="SCRPWD":"For division: ",1:"For clinic group: ")_SDS2 + ; +HD2() ;Report subheader 2 + Q $S(SDS1="SCRPW":"F A C I L I T Y",SDS1="SCRPWD":"D I V I S I O N",1:"C L I N I C G R O U P") + ; +DIV() ;Return division name + N X S X=$P($G(^DG(40.8,+$P(SDOE0,U,11),0)),U) Q $S('$L(X):"***UNKNOWN***",1:X) + ; +CLGR() ;Return CLINIC GROUP pointer + N X S X=$P($G(^SC(+$P(SDOE0,U,4),0)),U,31),X=$P($G(^SD(409.67,+X,0)),U) Q $S('$L(X):"***NONE ASSIGNED***",1:X) + ; +NCT1 I '$D(^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN)) S SDUNAR=SDUNAR+1 D:SDUL&(SDS1="SCRPW") UL("OWK") + S SDDT=0 F S SDDT=$O(^TMP(SDS1,$J,SDS2,"VISIT","OWK",DFN,SDDT)) Q:'SDDT I '$D(^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN,SDDT)) S SDCT=SDCT+1 + Q + ; +CT1 I '$D(^TMP(SDS1,$J,SDS2,"VISIT","OWK",DFN)),'$D(^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN)) S SDUNAR=SDUNAR+1 D:SDUL&(SDS1="SCRPW") UL("NWK") + S SDDT=0 F S SDDT=$O(^TMP(SDS1,$J,SDS2,"VISIT","NWK",DFN,SDDT)) Q:'SDDT I '$D(^TMP(SDS1,$J,SDS2,"VISIT","OWK",DFN,SDDT)),'$D(^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN,SDDT)) S SDCT=SDCT+1 + Q + ; +UL(SDI) D ^VADPT S SDDT=0 F S SDDT=$O(^TMP(SDS1,$J,SDS2,"VISIT",SDI,DFN,SDDT)) Q:'SDDT S ^TMP(SDS1,$J,SDS2,"VISIT","UNARL",VADM(1),DFN,$P(VADM(2),U),SDDT)="" + Q + ; +TOT W !?47,"============ =========",!?39,"TOTAL:",?47,$J(SDCT,12),?64,"100.00" Q + ; +SHDR(SDTX) D:$Y>(IOSL-6) XHDR Q:SDOUT W !!?(80-$L(SDTX)\2),SDTX,!?(80-$L(SDTX)\2) F SDX=1:1:$L(SDTX) W "-" + W !!?39,"Status",?54,"Count",?63,"Percent",!?10,"----------------------------------- ------------ ---------" Q + ; +LIST(SDI) Q:'$D(^TMP(SDS1,$J,SDS2,SDI)) D:$Y>(IOSL-4) XHDR Q:SDOUT + W !?10,$P(^SD(409.63,SDI,0),U),?47,$J(^TMP(SDS1,$J,SDS2,SDI),12),?62,$J($S(SDCT=0:0,1:(^TMP(SDS1,$J,SDS2,SDI)*100/SDCT)),8,2) + Q + ; +COT D:$Y>(IOSL-4) XHDR Q:SDOUT W !?15,SDSTAT,?47,$J(^TMP(SDS1,$J,SDS2,2,SDI,SDSTAT),12),?62,$J($S(SDCT=0:0,1:(^TMP(SDS1,$J,SDS2,2,SDI,SDSTAT)*100/SDCT)),8,2) Q + ; +IAP D:$Y>(IOSL-4) XHDR Q:SDOUT W !?15,SDSTAT,?47,$J(^TMP(SDS1,$J,SDS2,8,SDI,SDSTAT),12),?62,$J($S(SDCT=0:0,1:(^TMP(SDS1,$J,SDS2,8,SDI,SDSTAT)*100/SDCT)),8,2) Q +STOP ;Check for stop task request + S:$G(ZTQUEUED) (SDOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q + ; +COUNT ;Count encounters + S SDSTOP=SDSTOP+1 I SDSTOP#3000=0 D STOP Q:SDOUT + D C1("SCRPW",SDDNAM) D:SDMD C1("SCRPWD",SDDIV) D:SDCLGR C1("SCRPWC",SDCG) Q + ; +C1(SDS1,SDS2) ;Set ^TMP global + ;Required input: SDS1,SDS2=subscript values + S DFN=$P(SDOE0,U,2),SDSTAT=+$P(SDOE0,U,12) I SDZ(0),SDZ(4)=SDDIV,SDS1="SCRPW" D DETAIL + S ^TMP(SDS1,$J,SDS2,SDSTAT)=$G(^TMP(SDS1,$J,SDS2,SDSTAT))+1 + Q:SDSTAT=4 D:"114238"[SDSTAT VIS Q + ; +VIS S ^TMP(SDS1,$J,SDS2,"VISIT",$S(SDSTAT=2:"OWK",SDSTAT=8:"OWK",1:"NWK"),DFN,$P(SDDT,"."))="" Q:(SDSTAT'=2)&(SDSTAT'=8) + S SDSTX=$$STX(SDOE,SDOE0),^TMP(SDS1,$J,SDS2,SDSTAT,$P(SDSTX,U),$P(SDSTX,U,2))=$G(^TMP(SDS1,$J,SDS2,SDSTAT,$P(SDSTX,U),$P(SDSTX,U,2)))+1 + Q:$P(SDSTX,U)'=8 S ^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN,$P(SDDT,"."))="" + Q + ; +STX(SDOE,SDOE0) ;Determine transmission status + ;Required input: SDOE=OUTPATIENT ENCOUNTER record IFN + ;Required input: SDOE0=zeroeth node of OUTPATIENT ENCOUNTER + N SDTOE,SDTOEE + Q:($P(SDOE0,U,12)'=2)&($P(SDOE0,U,12)'=8) "0^Not checked-out^Not checked-out" + S SDTOE=$O(^SD(409.73,"AENC",SDOE,0)) Q:'SDTOE!'$D(^SD(409.73,+SDTOE,0)) "1^No transmission record^No tx. record" + S SDTOE1=$G(^SD(409.73,SDTOE,1)),SDTOE0=^SD(409.73,SDTOE,0) I '$P(SDTOE0,U,4),'$P(SDTOE1,U) Q "2^Not required, not transmitted^Not req., not tx." + ; SD*5.3*339 added second I SDTOEE below + S SDTOEE=$O(^SD(409.75,"B",SDTOE,0)) I SDTOEE S SDTOEE=$P($G(^SD(409.75,SDTOEE,0)),U,2) I SDTOEE S SDTOEE=$P($G(^SD(409.76,SDTOEE,0)),U,2) Q:SDTOEE="V" "3^Rejected for transmission^Rejected for tx." + Q:'$P(SDTOE1,U) "4^Awaiting transmission^Awaiting tx." + S SDTXS=$P(SDTOE1,U,5) Q:'$L(SDTXS) "5^Transmitted, no acknowledgment^Tx., no ack." + Q:SDTXS="R" "6^Transmitted, rejected^Tx., rejected" + Q:SDTXS'="A" "7^Transmitted, error^Tx., error" + Q "8^Transmitted, accepted^Tx., accepted" + ; +DETAIL ;Set global for detailed list + D ^VADPT S SDPNAM=VADM(1),SDSSN=$P(VADM(2),U) + I SDZ(1)="U",SDSTAT'=4 S:"114238"[SDSTAT ^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN)="" Q + I SDZ(1)="V",SDSTAT'=4 S:"114238"[SDSTAT ^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN,$P(SDDT,"."))="" Q + Q:'$D(SDZ(2)) ; SD*5.3*339 + I (SDZ(2)'=2)&(SDZ(2)'=8),SDZ(2)=SDSTAT D DSET Q + Q:("28"'[SDZ(2))!("28"'[SDSTAT)!(SDZ(2)'=SDSTAT) I 'SDZ(3) D DSET Q + D:+$$STX(SDOE,SDOE0)=SDZ(3) DSET Q + ; +DSET S ^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN,SDDT,SDOE)=+$P(SDOE0,U,4) Q diff --git a/r/SCHEDULING-SD-SC/SCRPW9.m b/r/SCHEDULING-SD-SC/SCRPW9.m index 52d81335..d4b8b7b3 100644 --- a/r/SCHEDULING-SD-SC/SCRPW9.m +++ b/r/SCHEDULING-SD-SC/SCRPW9.m @@ -1,107 +1,105 @@ -SCRPW9 ;RENO/KEITH - Outpatient Encounter Workload Statistics (cont.) ; 15 Jul 98 02:38PM - ;;5.3;Scheduling;**139,144,339,466,510**;AUG 13, 1993;Build 3 -UNARL(SDS1,SDS2) ;Print list of 'action required'/not accepted uniques - ;Required input: SDS1,SDS2=subscript values - S SDPAGE=1 D UHDR Q:SDOUT I '$D(^TMP(SDS1,$J,SDS2,"VISIT","UNARL")) W !!,"No 'action required'/not accepted unique patients identified." Q - S SDARCT=0,SDPNAM="" F S SDPNAM=$O(^TMP(SDS1,$J,SDS2,"VISIT","UNARL",SDPNAM)) Q:SDPNAM=""!SDOUT S DFN=0 F S DFN=$O(^TMP(SDS1,$J,SDS2,"VISIT","UNARL",SDPNAM,DFN)) Q:'DFN!SDOUT D UNP - Q:SDOUT D:$Y>(IOSL-3) UHDR Q:SDOUT W !!,SDARCT," 'action required'/not accepted unique patient",$S(SDARCT=1:"",1:"s")," identified." Q - ; -UNP S SDSSN=$O(^TMP(SDS1,$J,SDS2,"VISIT","UNARL",SDPNAM,DFN,"")) D:$Y>(IOSL-4) UHDR Q:SDOUT W !,$E(SDPNAM,1,18),?20,SDSSN - S SDARCT=SDARCT+1,(SDDT,SDI)=0 F S SDDT=$O(^TMP(SDS1,$J,SDS2,"VISIT","UNARL",SDPNAM,DFN,SDSSN,SDDT)) Q:'SDDT!SDOUT D:$Y>(IOSL-4) UHDR Q:SDOUT S Y=SDDT X ^DD("DD") W:SDI ! W ?31,Y S SDI=1 D UNP1 - Q - ; -UNP1 N SDII,SDDT1 S SDII=0,SDDT1=SDDT F S SDDT1=$O(^SCE("ADFN",DFN,SDDT1)) Q:'SDDT1!(SDDT1>(SDDT+.9999))!SDOUT D - .S SDOE=0 F S SDOE=$O(^SCE("ADFN",DFN,SDDT1,SDOE)) Q:'SDOE!SDOUT S SDOE0=$$GETOE^SDOE(SDOE) I $L(SDOE0),'$P(SDOE0,U,6) D UNP2 - .Q - Q - ; -UNP2 N SDCL,SDST Q:'$P(SDOE0,U,4) S SDCL=$P($G(^SC($P(SDOE0,U,4),0)),U),SDST=$P(SDOE0,U,12) Q:$P($G(^SC($P(SDOE0,U,4),0)),U,17)="Y" Q:'SDST!(SDST=12) S SDST=$S("28"'[SDST:$P(^SD(409.63,SDST,0),U),1:$P($$STX^SCRPW8(SDOE,SDOE0),U,3)) - D:$Y>(IOSL-4) UHDR Q:SDOUT W:SDII ! W ?44,$E(SDCL,1,17),?63,$E(SDST,1,17) S SDII=SDII+1 Q - ; -UHDR I $E(IOST)="C" N DIR S DIR(0)="E" D ^DIR S SDOUT=Y'=1 Q:SDOUT - D STOP^SCRPW8 Q:SDOUT - W $$XY^SCRPW50(IOF,1,0),SDLINE,!?8,"<*> LIST OF 'ACTION REQUIRED'/NOT ACCEPTED UNIQUE PATIENTS <*>",!?(66-$L(SDDNAM)\2),"For station: ",SDDNAM - W !,SDLINE,!,"For encounter dates ",SDDTPF," to ",SDDTPL,!,"Date printed: ",SDPNOW,?(74-$L(SDPAGE)),"Page: ",SDPAGE,!,SDLINE,! S SDPAGE=SDPAGE+1 - W:$D(^TMP(SDS1,$J,SDS2,"VISIT","UNARL")) !,"Name:",?20,"SSN:",?31,"Date:",?44,"Location:",?63,"Reason:",! Q - ; -DETAIL ;Ask questions for detail of encounters or uniques for a division - K SDZ S SDZ(0)=0 K DIR S DIR(0)="Y",DIR("A")="Would you like to print a detailed list of activity for a division",DIR("B")="NO" W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDZ(0)=-1 Q - S SDZ(0)=Y Q:'Y W !!!,$C(7)," WARNING: Selection high activity areas will result in lengthy output!",! - K DIR S DIR(0)="S^U:UNIQUES;V:VISITS;E:ENCOUNTERS",DIR("A")="Select type of list" D ^DIR I $D(DTOUT)!$D(DUOUT) S SDZ(0)=-1 Q - S SDZ(1)=Y G:Y'="E" ZDIV -DET1 K DIC S DIC="^SD(409.63,",DIC(0)="AEMQ",DIC("S")="I Y<4!(Y=8!(Y=12!(Y=14)))",DIC("A")="Select encounter status: " W ! D ^DIC I $D(DTOUT)!$D(DUOUT)!($G(Y)<1) S SDZ(0)=-1 Q - S SDZ(2)=$P(Y,U) G:(SDZ(2)'=2)&(SDZ(2)'=8) ZDIV K DIR S DIR("A")="Select transmission status for "_$S(SDZ(2)=2:"CHECKED OUT",1:"INPATIENT APPOINTMENT")_" encounters" - S DIR(0)="S^A:All transmission statuses;1:No transmission record;2:Not required, not transmitted;3:Rejected for transmission;4:Awaiting transmission;" - S DIR(0)=DIR(0)_"5:Transmitted, no acknowledgment;6:Transmitted, rejected;7:Transmitted, error;8:Transmitted, accepted" - I SDZ(2)=8 S DIR(0)=DIR(0)_";9:Non-Count (not transmitted)" - W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDZ(0)=-1 Q ;SD*5.3*339 add sub-zero - S SDZ(3)=+Y -ZDIV ;Get division for detail - I '$P($G(^DG(43,1,"GL")),U,2) S SDZ(4)=$P(^DG(40.8,$$PRIM^VASITE(),0),U) Q - K DIC S DIC="^DG(40.8,",DIC("A")="Select Medical Center division for detail: ",DIC(0)="AEMQ" W ! D ^DIC I $D(DTOUT)!$D(DUOUT) S SDZ(0)=-1 Q - I Y<1 W $C(7)," Required for patient detail!" G ZDIV - S SDZ(4)=$P(Y,U,2) Q - ; -DPRT(SDS1,SDS2) ;Detail print - ;Required input: SDS1,SDS2=subscript values - K SDH S SDPAGE=1,SDH(1)="<*> DETAILED LIST OF DIVISION "_$S(SDZ(1)="U":"UNIQUES",SDZ(1)="V":"VISITS",1:"ENCOUNTERS")_" <*>",SDH(2)="For division: "_SDZ(4) - I $G(SDZ(2)) S SDH(3)="Encounters with "_$P(^SD(409.63,SDZ(2),0),U)_" status" - I $G(SDZ(2))'="","28"[SDZ(2) S SDH(4)="Transmission status: "_$P($T(TXS+SDZ(3)),";",2) - D DHDR Q:SDOUT I '$D(^TMP(SDS1,$J,SDS2,"DETAIL")) W !,"No records found in this category." Q - S SDCT=0 D @SDZ(1) Q - ; -U ;Print uniques - S SDPNAM="" F S SDPNAM=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM)) Q:SDPNAM=""!SDOUT S DFN=0 F S DFN=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN)) Q:'DFN!SDOUT D U1 - Q:SDOUT W !!,SDCT," uniques identified." Q - ; -U1 S SDCT=SDCT+1,SDSSN=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,"")) D:$Y>(IOSL-4) DHDR Q:SDOUT W !,$E(SDPNAM,1,18),?21,SDSSN Q - ; -V ;Print visits - S SDPNAM="" F S SDPNAM=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM)) Q:SDPNAM=""!SDOUT S DFN=0 F S DFN=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN)) Q:'DFN!SDOUT S SDSSN=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,"")) D V1 - Q:SDOUT W !!,SDCT," visits identified." Q - ; -V1 D:$Y>(IOSL-4) DHDR Q:SDOUT W !,$E(SDPNAM,1,18),?21,SDSSN S (SDDT,SDI)=0 F S SDDT=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN,SDDT)) Q:'SDDT!SDOUT D - .D:$Y>(IOSL-3) DHDR Q:SDOUT S Y=SDDT X ^DD("DD") W:SDI ! W ?32,Y S SDCT=SDCT+1,SDI=SDI+1 - .Q - Q - ; -E ;Print encounters - S SDPNAM="" F S SDPNAM=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM)) Q:SDPNAM=""!SDOUT S DFN=0 F S DFN=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN)) Q:'DFN!SDOUT S SDSSN=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,"")) D E1 - Q:SDOUT W !!,SDCT," encounters identified." Q - ; -E1 D:$Y>(IOSL-4) DHDR Q:SDOUT W !,$E(SDPNAM,1,18),?21,SDSSN - S (SDDT,SDI)=0 F S SDDT=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN,SDDT)) Q:'SDDT!SDOUT S SDOE=0 F S SDOE=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN,SDDT,SDOE)) Q:'SDOE!SDOUT D E2 - Q - ; -E2 D:$Y>(IOSL-3) DHDR Q:SDOUT S SDHL=^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN,SDDT,SDOE),SDHL=$P($G(^SC(+SDHL,0)),U),Y=SDDT X ^DD("DD") W:SDI ! W ?32,$P(Y,":",1,2),?50,SDHL S SDCT=SDCT+1,SDI=SDI+1 Q - ; -DHDR I $E(IOST)="C" N DIR S DIR(0)="E" D ^DIR S SDOUT=Y'=1 Q:SDOUT - D STOP^SCRPW8 Q:SDOUT - W $$XY^SCRPW50(IOF,1,0),SDLINE S I=0 F S I=$O(SDH(I)) Q:'I W !?(80-$L(SDH(I))\2),SDH(I) - W !,SDLINE,!,"For date range: ",SDDTPF," to ",SDDTPL,!,"Date printed: ",SDPNOW,?(74-$L(SDPAGE)),"Page: ",SDPAGE,!,SDLINE,! S SDPAGE=SDPAGE+1 Q - ; -TXS ;All transmission statuses - ;No transmission record - ;Not required, not transmitted - ;Rejected for transmission - ;Awaiting transmission - ;Transmitted, no acknowledgment - ;Transmitted, rejected - ;Transmitted, error - ;Transmitted, accepted - ;Non-Count (not transmitted) - ; -PARM ;Prompt for report parameters - D TITL^SCRPW50("Outpatient Encounter Workload Statistics") - N %DT,DIR,DIC D SUBT^SCRPW50("*** Date Range Selection ***") -FDT W ! S %DT="AEPX",%DT("A")="Beginning date: FIRST// ",%DT(0)=2961001 D ^%DT G:X=U!$D(DTOUT) EXIT^SCRPW8 I X="" S (Y,SDDTF)=2961001 X ^DD("DD") W " ",Y,! S SDDTPF=Y G LDT - G:Y<1 FDT S SDDTF=Y X ^DD("DD") S SDDTPF=Y W ! -LDT S %DT("A")="Ending date: LAST// " D ^%DT G:X=U!$D(DTOUT) EXIT^SCRPW8 I X="" S X1=DT,X2=-1 D C^%DTC S (Y,SDDTL)=X X ^DD("DD") W " ",Y,! S SDDTPL=Y G ASK - I Y(IOSL-3) UHDR Q:SDOUT W !!,SDARCT," 'action required'/not accepted unique patient",$S(SDARCT=1:"",1:"s")," identified." Q + ; +UNP S SDSSN=$O(^TMP(SDS1,$J,SDS2,"VISIT","UNARL",SDPNAM,DFN,"")) D:$Y>(IOSL-4) UHDR Q:SDOUT W !,$E(SDPNAM,1,18),?20,SDSSN + S SDARCT=SDARCT+1,(SDDT,SDI)=0 F S SDDT=$O(^TMP(SDS1,$J,SDS2,"VISIT","UNARL",SDPNAM,DFN,SDSSN,SDDT)) Q:'SDDT!SDOUT D:$Y>(IOSL-4) UHDR Q:SDOUT S Y=SDDT X ^DD("DD") W:SDI ! W ?31,Y S SDI=1 D UNP1 + Q + ; +UNP1 N SDII,SDDT1 S SDII=0,SDDT1=SDDT F S SDDT1=$O(^SCE("ADFN",DFN,SDDT1)) Q:'SDDT1!(SDDT1>(SDDT+.9999))!SDOUT D + .S SDOE=0 F S SDOE=$O(^SCE("ADFN",DFN,SDDT1,SDOE)) Q:'SDOE!SDOUT S SDOE0=$$GETOE^SDOE(SDOE) I $L(SDOE0),'$P(SDOE0,U,6) D UNP2 + .Q + Q + ; +UNP2 N SDCL,SDST Q:'$P(SDOE0,U,4) S SDCL=$P($G(^SC($P(SDOE0,U,4),0)),U),SDST=$P(SDOE0,U,12) Q:$P($G(^SC($P(SDOE0,U,4),0)),U,17)="Y" Q:'SDST!(SDST=12) S SDST=$S("28"'[SDST:$P(^SD(409.63,SDST,0),U),1:$P($$STX^SCRPW8(SDOE,SDOE0),U,3)) + D:$Y>(IOSL-4) UHDR Q:SDOUT W:SDII ! W ?44,$E(SDCL,1,17),?63,$E(SDST,1,17) S SDII=SDII+1 Q + ; +UHDR I $E(IOST)="C" N DIR S DIR(0)="E" D ^DIR S SDOUT=Y'=1 Q:SDOUT + D STOP^SCRPW8 Q:SDOUT + W $$XY^SCRPW50(IOF,1,0),SDLINE,!?8,"<*> LIST OF 'ACTION REQUIRED'/NOT ACCEPTED UNIQUE PATIENTS <*>",!?(66-$L(SDDNAM)\2),"For station: ",SDDNAM + W !,SDLINE,!,"For encounter dates ",SDDTPF," to ",SDDTPL,!,"Date printed: ",SDPNOW,?(74-$L(SDPAGE)),"Page: ",SDPAGE,!,SDLINE,! S SDPAGE=SDPAGE+1 + W:$D(^TMP(SDS1,$J,SDS2,"VISIT","UNARL")) !,"Name:",?20,"SSN:",?31,"Date:",?44,"Location:",?63,"Reason:",! Q + ; +DETAIL ;Ask questions for detail of encounters or uniques for a division + K SDZ S SDZ(0)=0 K DIR S DIR(0)="Y",DIR("A")="Would you like to print a detailed list of activity for a division",DIR("B")="NO" W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDZ(0)=-1 Q + S SDZ(0)=Y Q:'Y W !!!,$C(7)," WARNING: Selection high activity areas will result in lengthy output!",! + K DIR S DIR(0)="S^U:UNIQUES;V:VISITS;E:ENCOUNTERS",DIR("A")="Select type of list" D ^DIR I $D(DTOUT)!$D(DUOUT) S SDZ(0)=-1 Q + S SDZ(1)=Y G:Y'="E" ZDIV +DET1 K DIC S DIC="^SD(409.63,",DIC(0)="AEMQ",DIC("S")="I Y<4!(Y=8!(Y=12!(Y=14)))",DIC("A")="Select encounter status: " W ! D ^DIC I $D(DTOUT)!$D(DUOUT)!($G(Y)<1) S SDZ(0)=-1 Q + S SDZ(2)=$P(Y,U) G:(SDZ(2)'=2)&(SDZ(2)'=8) ZDIV K DIR S DIR("A")="Select transmission status for "_$S(SDZ(2)=2:"CHECKED OUT",1:"INPATIENT APPOINTMENT")_" encounters" + S DIR(0)="S^A:All transmission statuses;1:No transmission record;2:Not required, not transmitted;3:Rejected for transmission;4:Awaiting transmission;" + S DIR(0)=DIR(0)_"5:Transmitted, no acknowledgment;6:Transmitted, rejected;7:Transmitted, error;8:Transmitted, accepted" + W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDZ(0)=-1 Q ;SD*5.3*339 add sub-zero + S SDZ(3)=+Y +ZDIV ;Get division for detail + I '$P($G(^DG(43,1,"GL")),U,2) S SDZ(4)=$P(^DG(40.8,$$PRIM^VASITE(),0),U) Q + K DIC S DIC="^DG(40.8,",DIC("A")="Select Medical Center division for detail: ",DIC(0)="AEMQ" W ! D ^DIC I $D(DTOUT)!$D(DUOUT) S SDZ(0)=-1 Q + I Y<1 W $C(7)," Required for patient detail!" G ZDIV + S SDZ(4)=$P(Y,U,2) Q + ; +DPRT(SDS1,SDS2) ;Detail print + ;Required input: SDS1,SDS2=subscript values + K SDH S SDPAGE=1,SDH(1)="<*> DETAILED LIST OF DIVISION "_$S(SDZ(1)="U":"UNIQUES",SDZ(1)="V":"VISITS",1:"ENCOUNTERS")_" <*>",SDH(2)="For division: "_SDZ(4) + I $G(SDZ(2)) S SDH(3)="Encounters with "_$P(^SD(409.63,SDZ(2),0),U)_" status" + I "28"[$G(SDZ(2)) S SDH(4)="Transmission status: "_$P($T(TXS+SDZ(3)),";",2) + D DHDR Q:SDOUT I '$D(^TMP(SDS1,$J,SDS2,"DETAIL")) W !,"No records found in this category." Q + S SDCT=0 D @SDZ(1) Q + ; +U ;Print uniques + S SDPNAM="" F S SDPNAM=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM)) Q:SDPNAM=""!SDOUT S DFN=0 F S DFN=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN)) Q:'DFN!SDOUT D U1 + Q:SDOUT W !!,SDCT," uniques identified." Q + ; +U1 S SDCT=SDCT+1,SDSSN=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,"")) D:$Y>(IOSL-4) DHDR Q:SDOUT W !,$E(SDPNAM,1,18),?21,SDSSN Q + ; +V ;Print visits + S SDPNAM="" F S SDPNAM=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM)) Q:SDPNAM=""!SDOUT S DFN=0 F S DFN=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN)) Q:'DFN!SDOUT S SDSSN=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,"")) D V1 + Q:SDOUT W !!,SDCT," visits identified." Q + ; +V1 D:$Y>(IOSL-4) DHDR Q:SDOUT W !,$E(SDPNAM,1,18),?21,SDSSN S (SDDT,SDI)=0 F S SDDT=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN,SDDT)) Q:'SDDT!SDOUT D + .D:$Y>(IOSL-3) DHDR Q:SDOUT S Y=SDDT X ^DD("DD") W:SDI ! W ?32,Y S SDCT=SDCT+1,SDI=SDI+1 + .Q + Q + ; +E ;Print encounters + S SDPNAM="" F S SDPNAM=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM)) Q:SDPNAM=""!SDOUT S DFN=0 F S DFN=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN)) Q:'DFN!SDOUT S SDSSN=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,"")) D E1 + Q:SDOUT W !!,SDCT," encounters identified." Q + ; +E1 D:$Y>(IOSL-4) DHDR Q:SDOUT W !,$E(SDPNAM,1,18),?21,SDSSN + S (SDDT,SDI)=0 F S SDDT=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN,SDDT)) Q:'SDDT!SDOUT S SDOE=0 F S SDOE=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN,SDDT,SDOE)) Q:'SDOE!SDOUT D E2 + Q + ; +E2 D:$Y>(IOSL-3) DHDR Q:SDOUT S SDHL=^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN,SDDT,SDOE),SDHL=$P($G(^SC(+SDHL,0)),U),Y=SDDT X ^DD("DD") W:SDI ! W ?32,$P(Y,":",1,2),?50,SDHL S SDCT=SDCT+1,SDI=SDI+1 Q + ; +DHDR I $E(IOST)="C" N DIR S DIR(0)="E" D ^DIR S SDOUT=Y'=1 Q:SDOUT + D STOP^SCRPW8 Q:SDOUT + W $$XY^SCRPW50(IOF,1,0),SDLINE S I=0 F S I=$O(SDH(I)) Q:'I W !?(80-$L(SDH(I))\2),SDH(I) + W !,SDLINE,!,"For date range: ",SDDTPF," to ",SDDTPL,!,"Date printed: ",SDPNOW,?(74-$L(SDPAGE)),"Page: ",SDPAGE,!,SDLINE,! S SDPAGE=SDPAGE+1 Q + ; +TXS ;All transmission statuses + ;No transmission record + ;Not required, not transmitted + ;Rejected for transmission + ;Awaiting transmission + ;Transmitted, no acknowledgment + ;Transmitted, rejected + ;Transmitted, error + ;Transmitted, accepted + ; +PARM ;Prompt for report parameters + D TITL^SCRPW50("Outpatient Encounter Workload Statistics") + N %DT,DIR,DIC D SUBT^SCRPW50("*** Date Range Selection ***") +FDT W ! S %DT="AEPX",%DT("A")="Beginning date: FIRST// ",%DT(0)=2961001 D ^%DT G:X=U!$D(DTOUT) EXIT^SCRPW8 I X="" S (Y,SDDTF)=2961001 X ^DD("DD") W " ",Y,! S SDDTPF=Y G LDT + G:Y<1 FDT S SDDTF=Y X ^DD("DD") S SDDTPF=Y W ! +LDT S %DT("A")="Ending date: LAST// " D ^%DT G:X=U!$D(DTOUT) EXIT^SCRPW8 I X="" S X1=DT,X2=-1 D C^%DTC S (Y,SDDTL)=X X ^DD("DD") W " ",Y,! S SDDTPL=Y G ASK + I Y0)!($L(M)>3)) W !,"ENTER A WHOLE NUMBER TO SELECT THE # OF COPIES OF THE APPOINTMENT LIST THAT ARE NEEDED- (1-999)" G N - S SDCOPY=M - ; -- specify device - W ! N %ZIS K IO("Q") S %ZIS="QMP" D ^%ZIS G END:POP - S SDBC=$$BARQ(+IOST(0),IOM) I SDBC="^" G END - I $D(IO("Q")) D QUE W:$D(ZTSK) " (Task#: ",ZTSK,")" G END - ; -START U IO N CNT,SDCLAR,SDCOUNT S (SDCOUNT,CNT)=0 - ;SET UP A TEMP ARRAY -SDCLAR- WITH CLASSIFICATION ABBREVIATIONS - F S CNT=$O(^SD(409.41,CNT)) Q:CNT'>0 D - .S SDCLAR(CNT)=$P(^SD(409.41,CNT,0),U,7) - S:'$D(DTIME) DTIME=300 I '$D(DT) D DT^SDUTL - S SDASH="",$P(SDASH,"_",IOM+1)="" S SDBC=+$G(SDBC),SDCOPY=$S($D(SDCOPY):+SDCOPY,$D(M):+M,1:1) - D NOW^%DTC S Y=% X ^DD("DD") S SDPNOW=$P(Y,":",1,2) - I SDBC S SDBC=$S(IOM<120:0,1:$$BARC^SDAMU(+IOST(0),.SDBCON,.SDBCOFF)) - S (SDEND,SD1,PCNT)=0,Y=DT D D^DIQ S SDNT=Y,Y=SDD,X=Y D D^DIQ S SDPD=Y D DW^%DTC S SDPD=X_" "_SDPD - ;if user has selected 'all' clinics, populate VAUTC with all uncancelled TYPE=C clinics from ^SC - I VAUTC=1 S SDIEN=0 F S SDIEN=$O(^SC(SDIEN)) Q:+SDIEN=0 D - . I $P(^SC(SDIEN,0),"^",3)="C",$G(^SC(SDIEN,"ST",SDD,1))'["CANCELLED" D - .. S SDNAME=$P(^SC(SDIEN,0),"^",1) I $G(SDNAME)]"" S VAUTC(SDNAME)=SDIEN - ;-------------CALL TO SDAPI^SDAMA301 TO RETRIEVE APPT DATA------------------ - K ^TMP($J,"SDAMA301") N SDARRAY,SDIEN,SDNAME,SDERR,SDCL,SDDFN,SDDT,SDRESULT - S SDARRAY(1)=SDD_";"_SDD,SDARRAY(3)="I;R;NT",SDARRAY("FLDS")="4;6;7;8;10;19;20;21" - ;if user has selected clinics, build clinic filter list - I VAUTC'=1 D I $L(SDARRAY(2)) S SDARRAY(2)=$E(SDARRAY(2),1,$L(SDARRAY(2))-1) ;remove last ';' from end - . S SD="" F S SD=$O(VAUTC(SD)) Q:SD']"" S SC=$G(VAUTC(SD)) I $G(SC)]"" S SDARRAY(2)=$G(SDARRAY(2))_SC_";" - ;call SDAPI to retrieve appointment data - S SDRESULT=$$SDAPI^SDAMA301(.SDARRAY) - ;I SDRESULT<0 S SDERR=$$SDAPIERR^SDAMUTDT() I $L(SDERR) S SC=0 D HED W !!,SDERR,! I $E(IOST,1,2)="C-" D OUT^SDUTL - ;if error returned from SDAPI, display on report and quit - I SDRESULT<0 S SDERR=$$SDAPIERR^SDAMUTDT() I $L(SDERR) S SC=0 S SDPAGE=1 D HED W !!,SDERR,! D:$E(IOST,1,2)="C-" OUT^SDUTL D EXIT Q - ;if appts returned from SDAPI, sort output by clinic, appt d/t, patient - I SDRESULT>0 D - . S SDCL=0 F S SDCL=$O(^TMP($J,"SDAMA301",SDCL)) Q:'SDCL D - .. S SDDFN=0 F S SDDFN=$O(^TMP($J,"SDAMA301",SDCL,SDDFN)) Q:'SDDFN D - ... S SDDT=0 F S SDDT=$O(^TMP($J,"SDAMA301",SDCL,SDDFN,SDDT)) Q:'SDDT D - .... M ^TMP($J,"SDAMA301","S",SDCL,SDDT,SDDFN)=^TMP($J,"SDAMA301",SDCL,SDDFN,SDDT) - ;--------------------------------------------------------------------------- -LOOPA ;S SD=0 F S SD=$S(VAUTC:$O(^SC("B",SD)),1:$O(VAUTC(SD))) Q:SD']""!SDEND D CLIN - ;if no error returned from SDAPI, start looping through clinics in VAUTC (sorted by name) - I SDRESULT'<0 S SD=0 F S SD=$O(VAUTC(SD)) Q:SD']""!SDEND D CLIN - G:SDEND END -OVER ;S PCNT=PCNT+1 I PCNT0!SDEND I $D(^SC(SC,0)),$P(^(0),"^",3)="C" I $S(VAUTC:1,'$D(VAUTC(SD)):0,VAUTC(SD)=SC:1,1:0) D LOOP^SDAL0 - ;process each clinic IEN from VAUTC array - S (SDFL,SC)=0 S SC=$G(VAUTC(SD)) I $G(SC)>0,$D(^SC(SC,0)) D LOOP^SDAL0 - Q - ; -BARQ(TTYPE,MARGIN) ; - N ON,OFF,Y - I MARGIN<120 S Y=0 G BARCQ - I '$$BARC^SDAMU(.TTYPE,.ON,.OFF) S Y=0 G BARCQ - S DIR(0)="Y",DIR("B")="NO",DIR("A")="SHOULD BARCODES BE PRINTED ON LIST(S)" - D ^DIR K DIR S:$D(DIRUT) Y="^" -BARCQ Q Y - ; -QUE ;Queue output - N ZTDESC,ZTSAVE,ZTRTN - K ZTSK,IO("Q") - S ZTDESC="Appointment Lists",ZTRTN="START^SDAL" - F X="VAUTD(","VAUTC(","SDCOPY","SDD","SDBC","VAUTD","VAUTC","SDCONC","SDPCMM" S ZTSAVE(X)="" - D ^%ZTLOAD - Q - ; -STOP ;Check for stop task request - S:$D(ZTQUEUED) (SDEND,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q - ; -HED ;Print report header - I SD1,$E(IOST)="C" D OUT^SDUTL Q:SDEND - D STOP Q:SDEND - S SDCOUNT=SDCOUNT+1,SD1=1 - W:SDCOUNT>1!($E(IOST)="C") $$XY^SCRPW50(IOF,1,0) W:$X $$XY^SCRPW50("",0,0) - W:SC "Appointments for ",$P(^SC(SC,0),"^",1)," clinic on ",SDPD - W:'SC "Appointments for ",SDPD - W !,"Date printed: ",SDPNOW,?(IOM-6-$L(SDPAGE)),"Page: ",SDPAGE,! - W !," Appt.",?11,"Patient Name",?44,"SSN",?53,"Lab",?62,"X-Ray",?73,"EKG" - ;W !," Time",?53,"Time",?62,"Time",?73,"Time",!,?15,"Other Information",?40,"Ward Location",!,?41,"Room-Bed" - W !," Time",?53,"Time",?62,"Time",?73,"Time",!,?15,"Other Information",?40,"Ward Location",!,?41,"Room-Bed" - W !,SDASH S SDPAGE=SDPAGE+1 - D:SDBC PAINT(SC,SDD) - Q - ; -PAINT(CLINIC,DATE) ; -- paint header barcodes - ; input: CLINIC := clinic ifn - ; DATE := appt date only - ; - W !?10,"Date",?45,"Clinic#",?85,"No",?110,"Yes",! - D BARC(10,$E(DATE,4,7)_$E(DATE,2,3)) - D BARC(45,"%"_CLINIC_"$") - D BARC(85,"N"),BARC(110,"Y") - W !!!!,SDASH - Q - ; -BARC(TAB,X) ; --print barcode - ; input: TAB := tab position - ; X := string to print - ; - W *13,?TAB W @SDBCON,X,@SDBCOFF - Q - ; +SDAL ;ALB/GRR,MJK - APPOINTMENT LIST ; 29 Jun 99 04:11PM + ;;5.3;Scheduling;**37,46,106,171,177,80,266**;Aug 13, 1993 +EN W ! S SDEND=1 D ASK2^SDDIV G:Y<0 END + W ! S VAUTNI=1 D NCOUNT^SDAL0 I SDCONC=U G END + W ! D NCLINIC^SDAL0 G:Y<0 END +RD1 W ! N %DT K DIC("S") S %DT("A")="For date: ",%DT="AEXF" D ^%DT + I (X["^")!(Y<0) K %,VAUTD,VAUTC,X,Y Q + S SDD=Y + N DIR S DIR(0)="Y",DIR("B")="NO" + S DIR("A")="Include Primary Care assignment information in the output" + W ! D ^DIR I $D(DTOUT)!$D(DUOUT) K SDD,VAUTC,VAUTD,X,Y Q + W ! S SDPCMM=Y +N K SDX,SDX1 R !,"Number of copies: 1// ",M:DTIME S:M="" M=1 + I M["^" K M,SDD,VAUTC,VAUTD,X,Y Q + I (M'?.N)!((M'>0)!($L(M)>3)) W !,"ENTER A WHOLE NUMBER TO SELECT THE # OF COPIES OF THE APPOINTMENT LIST THAT ARE NEEDED- (1-999)" G N + S SDCOPY=M + ; -- specify device + W ! N %ZIS K IO("Q") S %ZIS="QMP" D ^%ZIS G END:POP + S SDBC=$$BARQ(+IOST(0),IOM) I SDBC="^" G END + I $D(IO("Q")) D QUE W:$D(ZTSK) " (Task#: ",ZTSK,")" G END + ; +START U IO N CNT,SDCLAR,SDCOUNT S (SDCOUNT,CNT)=0 + ;SET UP A TEMP ARRAY -SDCLAR- WITH CLASSIFICATION ABBREVIATIONS + F S CNT=$O(^SD(409.41,CNT)) Q:CNT'>0 D + .S SDCLAR(CNT)=$P(^SD(409.41,CNT,0),U,7) + S:'$D(DTIME) DTIME=300 I '$D(DT) D DT^SDUTL + S SDASH="",$P(SDASH,"_",IOM+1)="" S SDBC=+$G(SDBC),SDCOPY=$S($D(SDCOPY):+SDCOPY,$D(M):+M,1:1) + D NOW^%DTC S Y=% X ^DD("DD") S SDPNOW=$P(Y,":",1,2) + I SDBC S SDBC=$S(IOM<120:0,1:$$BARC^SDAMU(+IOST(0),.SDBCON,.SDBCOFF)) + S (SDEND,SD1,PCNT)=0,Y=DT D D^DIQ S SDNT=Y,Y=SDD,X=Y D D^DIQ S SDPD=Y D DW^%DTC S SDPD=X_" "_SDPD + ;if user has selected 'all' clinics, populate VAUTC with all uncancelled TYPE=C clinics from ^SC + I VAUTC=1 S SDIEN=0 F S SDIEN=$O(^SC(SDIEN)) Q:+SDIEN=0 D + . I $P(^SC(SDIEN,0),"^",3)="C",$G(^SC(SDIEN,"ST",SDD,1))'["CANCELLED" D + .. S SDNAME=$P(^SC(SDIEN,0),"^",1) I $G(SDNAME)]"" S VAUTC(SDNAME)=SDIEN + ;-------------CALL TO SDAPI^SDAMA301 TO RETRIEVE APPT DATA------------------ + K ^TMP($J,"SDAMA301") N SDARRAY,SDIEN,SDNAME,SDERR,SDCL,SDDFN,SDDT,SDRESULT + S SDARRAY(1)=SDD_";"_SDD,SDARRAY(3)="I;R;NT",SDARRAY("FLDS")="4;6;7;8;10;19;20;21" + ;if user has selected clinics, build clinic filter list + I VAUTC'=1 D I $L(SDARRAY(2)) S SDARRAY(2)=$E(SDARRAY(2),1,$L(SDARRAY(2))-1) ;remove last ';' from end + . S SD="" F S SD=$O(VAUTC(SD)) Q:SD']"" S SC=$G(VAUTC(SD)) I $G(SC)]"" S SDARRAY(2)=$G(SDARRAY(2))_SC_";" + ;call SDAPI to retrieve appointment data + S SDRESULT=$$SDAPI^SDAMA301(.SDARRAY) + ;I SDRESULT<0 S SDERR=$$SDAPIERR^SDAMUTDT() I $L(SDERR) S SC=0 D HED W !!,SDERR,! I $E(IOST,1,2)="C-" D OUT^SDUTL + ;if error returned from SDAPI, display on report and quit + I SDRESULT<0 S SDERR=$$SDAPIERR^SDAMUTDT() I $L(SDERR) S SC=0 S SDPAGE=1 D HED W !!,SDERR,! D:$E(IOST,1,2)="C-" OUT^SDUTL D EXIT Q + ;if appts returned from SDAPI, sort output by clinic, appt d/t, patient + I SDRESULT>0 D + . S SDCL=0 F S SDCL=$O(^TMP($J,"SDAMA301",SDCL)) Q:'SDCL D + .. S SDDFN=0 F S SDDFN=$O(^TMP($J,"SDAMA301",SDCL,SDDFN)) Q:'SDDFN D + ... S SDDT=0 F S SDDT=$O(^TMP($J,"SDAMA301",SDCL,SDDFN,SDDT)) Q:'SDDT D + .... M ^TMP($J,"SDAMA301","S",SDCL,SDDT,SDDFN)=^TMP($J,"SDAMA301",SDCL,SDDFN,SDDT) + ;--------------------------------------------------------------------------- +LOOPA ;S SD=0 F S SD=$S(VAUTC:$O(^SC("B",SD)),1:$O(VAUTC(SD))) Q:SD']""!SDEND D CLIN + ;if no error returned from SDAPI, start looping through clinics in VAUTC (sorted by name) + I SDRESULT'<0 S SD=0 F S SD=$O(VAUTC(SD)) Q:SD']""!SDEND D CLIN + G:SDEND END +OVER ;S PCNT=PCNT+1 I PCNT0!SDEND I $D(^SC(SC,0)),$P(^(0),"^",3)="C" I $S(VAUTC:1,'$D(VAUTC(SD)):0,VAUTC(SD)=SC:1,1:0) D LOOP^SDAL0 + ;process each clinic IEN from VAUTC array + S (SDFL,SC)=0 S SC=$G(VAUTC(SD)) I $G(SC)>0,$D(^SC(SC,0)) D LOOP^SDAL0 + Q + ; +BARQ(TTYPE,MARGIN) ; + N ON,OFF,Y + I MARGIN<120 S Y=0 G BARCQ + I '$$BARC^SDAMU(.TTYPE,.ON,.OFF) S Y=0 G BARCQ + S DIR(0)="Y",DIR("B")="NO",DIR("A")="SHOULD BARCODES BE PRINTED ON LIST(S)" + D ^DIR K DIR S:$D(DIRUT) Y="^" +BARCQ Q Y + ; +QUE ;Queue output + N ZTDESC,ZTSAVE,ZTRTN + K ZTSK,IO("Q") + S ZTDESC="Appointment Lists",ZTRTN="START^SDAL" + F X="VAUTD(","VAUTC(","SDCOPY","SDD","SDBC","VAUTD","VAUTC","SDCONC","SDPCMM" S ZTSAVE(X)="" + D ^%ZTLOAD + Q + ; +STOP ;Check for stop task request + S:$D(ZTQUEUED) (SDEND,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q + ; +HED ;Print report header + I SD1,$E(IOST)="C" D OUT^SDUTL Q:SDEND + D STOP Q:SDEND + S SDCOUNT=SDCOUNT+1,SD1=1 + W:SDCOUNT>1!($E(IOST)="C") $$XY^SCRPW50(IOF,1,0) W:$X $$XY^SCRPW50("",0,0) + W:SC "Appointments for ",$P(^SC(SC,0),"^",1)," clinic on ",SDPD + W:'SC "Appointments for ",SDPD + W !,"Date printed: ",SDPNOW,?(IOM-6-$L(SDPAGE)),"Page: ",SDPAGE,! + W !," Appt.",?11,"Patient Name",?44,"SSN",?53,"Lab",?62,"X-Ray",?73,"EKG" + ;W !," Time",?53,"Time",?62,"Time",?73,"Time",!,?15,"Other Information",?40,"Ward Location",!,?41,"Room-Bed" + W !," Time",?53,"Time",?62,"Time",?73,"Time",!,?15,"Other Information",?40,"Ward Location",!,?41,"Room-Bed" + W !,SDASH S SDPAGE=SDPAGE+1 + D:SDBC PAINT(SC,SDD) + Q + ; +PAINT(CLINIC,DATE) ; -- paint header barcodes + ; input: CLINIC := clinic ifn + ; DATE := appt date only + ; + W !?10,"Date",?45,"Clinic#",?85,"No",?110,"Yes",! + D BARC(10,$E(DATE,4,7)_$E(DATE,2,3)) + D BARC(45,"%"_CLINIC_"$") + D BARC(85,"N"),BARC(110,"Y") + W !!!!,SDASH + Q + ; +BARC(TAB,X) ; --print barcode + ; input: TAB := tab position + ; X := string to print + ; + W *13,?TAB W @SDBCON,X,@SDBCOFF + Q + ; diff --git a/r/SCHEDULING-SD-SC/SDAM10.m b/r/SCHEDULING-SD-SC/SDAM10.m index 1ca805d3..c5209173 100644 --- a/r/SCHEDULING-SD-SC/SDAM10.m +++ b/r/SCHEDULING-SD-SC/SDAM10.m @@ -1,56 +1,54 @@ -SDAM10 ;MJK/ALB - Appt Mgt (Patient cont.); 3/18/05 3:51pm ; Compiled March 31, 2008 16:38:47 - ;;5.3;Scheduling;**189,258,403,478,491**;Aug 13, 1993;Build 53 - ; -HDR ; -- list screen header - ; input: SDFN := ifn of pat - ; output: VALMHDR() := hdr array - ; - N VAERR,VA,X - S DFN=SDFN D PID^VADPT - S VALMHDR(1)=$E($P("Patient: "_$G(^DPT(SDFN,0)),U),1,46)_" ("_VA("BID")_")" ;for proper display of patient name for SD*5.3*189 - S X=$P($$FMT^SDUTL2(SDFN),U,2),X=$S(X["GMT":X,X]"":"MT: "_X,1:"") - S VALMHDR(1)=$$SETSTR^VALM1(X,VALMHDR(1),47,15) ;repositioned header to display clinic or patient name properly for SD*5.3*189 - S X=$S($D(^DPT(SDFN,.1)):"Ward: "_^(.1),1:"Outpatient") - S VALMHDR(1)=$$SETSTR^VALM1(X,VALMHDR(1),81-$L(X),$L(X)) - Q - ; -PAT ; -- change pat - K TMP ;SD/478 - D FULL^VALM1 S VALMBCK="R" - K X I $D(XQORNOD(0)) S X=$P($P(XQORNOD(0),U,4),"=",2) - I $D(X),X="" R !!,"Select Patient: ",X:DTIME - D RT^SDAMEX S DIC="^DPT(",DIC(0)="EMQ" D ^DIC K DIC G PAT:X["?" -PAT1 S %=1 I Y>0 W !," ...OK" D YN^DICN I %=0 W " Answer with 'Yes' or 'No'" G PAT1 - I %'=1 S Y=-1 - I Y<0 D G PATQ - .I $G(DFN)>0,SDAMTYP="P" S VALMSG=$C(7)_"Patient has not been changed." - .I $G(DFN)'>0,SDAMTYP="P" S VALMSG=$C(7)_"Patient has not been selected." - .I SDAMTYP="C" S VALMSG=$C(7)_"View of clinic remains in affect." - .W !!,$G(VALMSG) H 1 - I SDAMTYP'="P" D CHGCAP^VALM("NAME","Clinic") S SDAMTYP="P" - S (DFN,SDFN)=+Y K SDCLN,VADM D DEM^VADPT D BLD^SDAM1 ;SD/491 -PATQ Q - ; -INIT ; -- init bld vars - K VALMHDR,SDDA,^TMP("SDAMIDX",$J) - D CLEAN^VALM10 - S VALMBG=1,(VALMCNT,SDACNT)=0,BL="",$P(BL," ",30)="",SDMAX=100 - S SDAMDD=$P(^DD(2.98,3,0),U,3) - ; -- format vars |- column -| |- width -| - S X=VALMDDF("APPT#"),AC=$P(X,U,2),AW=$P(X,U,3) ; A for appt - S X=VALMDDF("DATE"),XC=$P(X,U,2),XW=$P(X,U,3) ; X for date - S X=VALMDDF("NAME"),NC=$P(X,U,2),NW=$P(X,U,3) ; N for name - S X=VALMDDF("STAT"),SC=$P(X,U,2),SW=$P(X,U,3) ; S for status - S X=VALMDDF("TIME"),TC=$P(X,U,2),TW=$P(X,U,3) ; T for time - S (CC,CW)="",X=$G(VALMDDF("CONSULT")) I X'="" S CC=$P(X,U,2),CW=$P(X,U,3) ; C for Consult ;SD/478 - Q - ; -LARGE ; -- too large note - W !!?5,*7,"Note: Ending Date was changed to '",$$FDATE^VALM1(SDEND),"' because" - W !?11,"too many appointments met date range criteria." D PAUSE^VALM1 - Q - ; -NUL ; -- set nul message - I '$O(^TMP("SDAM",$J,0)) D SET^SDAM1(" "),SET^SDAM1(" No appointments meet criteria.") - Q - ; +SDAM10 ;MJK/ALB - Appt Mgt (Patient cont.); 3/18/05 3:51pm + ;;5.3;Scheduling;**189,258,403,478**;Aug 13, 1993 + ; +HDR ; -- list screen header + ; input: SDFN := ifn of pat + ; output: VALMHDR() := hdr array + ; + N VAERR,VA,X + S DFN=SDFN D PID^VADPT + S VALMHDR(1)=$E($P("Patient: "_$G(^DPT(SDFN,0)),U),1,46)_" ("_VA("BID")_")" ;for proper display of patient name for SD*5.3*189 + S X=$P($$FMT^SDUTL2(SDFN),U,2),X=$S(X["GMT":X,X]"":"MT: "_X,1:"") + S VALMHDR(1)=$$SETSTR^VALM1(X,VALMHDR(1),47,15) ;repositioned header to display clinic or patient name properly for SD*5.3*189 + S X=$S($D(^DPT(SDFN,.1)):"Ward: "_^(.1),1:"Outpatient") + S VALMHDR(1)=$$SETSTR^VALM1(X,VALMHDR(1),81-$L(X),$L(X)) + Q + ; +PAT ; -- change pat + K TMP ;SD/478 + D FULL^VALM1 S VALMBCK="R" + K X I $D(XQORNOD(0)) S X=$P($P(XQORNOD(0),U,4),"=",2) + I $D(X),X="" R !!,"Select Patient: ",X:DTIME + D RT^SDAMEX S DIC="^DPT(",DIC(0)="EMQ" D ^DIC K DIC G PAT:X["?" +PAT1 S %=1 W !," ...OK" D YN^DICN I %=0 W " Answer with 'Yes' or 'No'" G PAT1 + I %'=1 S Y=-1 + I Y<0 D G PATQ + .I SDAMTYP="P" S VALMSG=$C(7)_"Patient has not been changed." + .I SDAMTYP="C" S VALMSG=$C(7)_"View of clinic remains in affect." + I SDAMTYP'="P" D CHGCAP^VALM("NAME","Clinic") S SDAMTYP="P" + S SDFN=+Y K SDCLN D BLD^SDAM1 +PATQ Q + ; +INIT ; -- init bld vars + K VALMHDR,SDDA,^TMP("SDAMIDX",$J) + D CLEAN^VALM10 + S VALMBG=1,(VALMCNT,SDACNT)=0,BL="",$P(BL," ",30)="",SDMAX=100 + S SDAMDD=$P(^DD(2.98,3,0),U,3) + ; -- format vars |- column -| |- width -| + S X=VALMDDF("APPT#"),AC=$P(X,U,2),AW=$P(X,U,3) ; A for appt + S X=VALMDDF("DATE"),XC=$P(X,U,2),XW=$P(X,U,3) ; X for date + S X=VALMDDF("NAME"),NC=$P(X,U,2),NW=$P(X,U,3) ; N for name + S X=VALMDDF("STAT"),SC=$P(X,U,2),SW=$P(X,U,3) ; S for status + S X=VALMDDF("TIME"),TC=$P(X,U,2),TW=$P(X,U,3) ; T for time + S (CC,CW)="",X=$G(VALMDDF("CONSULT")) I X'="" S CC=$P(X,U,2),CW=$P(X,U,3) ; C for Consult ;SD/478 + Q + ; +LARGE ; -- too large note + W !!?5,*7,"Note: Ending Date was changed to '",$$FDATE^VALM1(SDEND),"' because" + W !?11,"too many appointments met date range criteria." D PAUSE^VALM1 + Q + ; +NUL ; -- set nul message + I '$O(^TMP("SDAM",$J,0)) D SET^SDAM1(" "),SET^SDAM1(" No appointments meet criteria.") + Q + ; diff --git a/r/SCHEDULING-SD-SC/SDAMODO3.m b/r/SCHEDULING-SD-SC/SDAMODO3.m index e43a254b..eabb0b17 100644 --- a/r/SCHEDULING-SD-SC/SDAMODO3.m +++ b/r/SCHEDULING-SD-SC/SDAMODO3.m @@ -1,102 +1,102 @@ -SDAMODO3 ;ALB/SCK - PROVIDER DIAGNOSTICS REPORT OUTPUT ; 05 Oct 98 8:44 PM - ;;5.3;Scheduling;**11,25,46,49,159,529**;Aug 13, 1993;Build 3 - Q -REPORT ; - I '$D(^TMP("SDRPT",$J)) D NOREP G EXIT -START ; - N SDIV,OEN,SDPRX,SUB1,SUB2,OEN,SDATA,SDX,SPRV,SDCHECK - S (SDIV,SDFIN,SDVC,SUBX,SUB1,SUB2)="",(PAGE,QFLAG,SUBCNT)=0 - W:$E(IOST,1,2)="C-" @IOF - F S SDIV=$O(^TMP("SDRPT",$J,SDIV)) Q:SDIV="" D Q:SDFIN - . I SDIV'=SDVC S SUBX=$$SUBCNT(SUB1,SUBX),SDFIN='$$HDR(SDIV) Q:SDFIN S SDVC=SDIV - . S SUB1="" F S SUB1=$O(^TMP("SDRPT",$J,SDIV,SUB1)) Q:SUB1="" D Q:SDFIN - .. I SUBX'=SUB1 S SUBX=$$SUBCNT(SUB1,SUBX) - .. I SORT1=4!(SORT1=5) I SUBX]"",SUBX'=SUB1 S SDFIN='$$HDR(SDIV) - .. S SUB2="" F S SUB2=$O(^TMP("SDRPT",$J,SDIV,SUB1,SUB2)) Q:SUB2="" D Q:SDFIN - ... S OEN=0 F S OEN=$O(^TMP("SDRPT",$J,SDIV,SUB1,SUB2,OEN)) Q:'OEN S SUBCNT=SUBCNT+1,SDCHECK="" D Q:SDFIN - .... S I=0 F S I=$O(^TMP("SDRPT",$J,SDIV,SUB1,SUB2,OEN,I)) Q:'I S SDFIN='$$PRNT(I) Q:SDFIN - S SUBX=$$SUBCNT(SUB1,SUBX) -EXIT ; - K QFLAG,PAGE,SDFIN,SDVC,SDONE,XX,^TMP("SDRPT",$J),SUBCNT,SUBX - Q - ; -SUBCNT(SB1,SB1P) ; - I SB1P']""!(SUBCNT'>0) G SUBCNTQ - W !,SUBCNT," ",$S(SORT2=1!(SORT2=2):"Primary "_$P($T(SORT+SORT2^SDAMODO1),";;",2),1:$P($T(SORT+SORT2^SDAMODO1),";;",2))," entries for ",$S(SORT1=1!(SORT1=3):$P(SB1P,"^"),SORT1=5:$P($G(^DIC(40.7,SB1P,0)),U),1:SB1P),!! - S SUBCNT=0 -SUBCNTQ Q (SB1) - ; -PRNT(I) ; - N Y,SDATA,SPRV,SDX,XX,SCODE,SDDX1,SDPRX,SDSID - S SDATA=(^TMP("SDRPT",$J,SDIV,SUB1,SUB2,OEN,I,0)) - S XX="" F S XX=$O(^TMP("SDRPT",$J,SDIV,SUB1,SUB2,OEN,I,"PRV",XX)) Q:'XX S SPRV(XX)="" - S XX="" F S XX=$O(^TMP("SDRPT",$J,SDIV,SUB1,SUB2,OEN,I,"DX",XX)) Q:XX="" S SDX(XX)="" - I SORT1=1,'$$SELPRV(SUB1) S Y=1 G PRNTQ - I SORT1=2,'$$SELDX(SUB1) S Y=1 G PRNTQ - I $Y+5>IOSL S Y='$$HDR(SDIV) G:Y PRNTQ -LINE1 ; - S SDSID=$P($G(SDATA),U,2) - W !,$P(^DPT($P($G(SDATA),U),0),U)_" "_$P(SDSID,"-",3) - S:SDCHECK="" SDCHECK=SDSID I SDSID'=SDCHECK S SUBCNT=SUBCNT+1 - W ?32,$P($$FMTE^XLFDT(OEN,1),":",1,2) ; modified to drop seconds - W ?55,$E($P(SDATA,U,3),1,25) - W ?90,$S(+$P(SDATA,U,5)>0:$P(^VA(200,+$P(SDATA,U,5),0),U),1:$P(SDATA,U,5)) - W ?117,$P(SDATA,U,6) -LINE2 ; - S SCODE=$P(SDATA,U,4) - W !?56,$P($G(^DIC(40.7,+SCODE,0)),U,2),"/",$P($G(^DIC(40.7,+SCODE,0)),U) - S SDPRX="",SDPRX=$O(SPRV(SDPRX)) I $D(SDPRX),SORT1'=1 W ?90,$S(+SDPRX>0:$P(^VA(200,SDPRX,0),U),1:"") - S SDDX1="",SDDX1=$O(SDX(SDDX1)) I $D(SDDX1),SORT1'=2 W ?117,SDDX1 - S SDONE=0 - F XX=1:1 D Q:SDONE - . I SDDX1'="" S SDDX1=$O(SDX(SDDX1)) - . I SDPRX'="" S SDPRX=$O(SPRV(SDPRX)) - . I SDPRX']""&(SDDX1']"") S SDONE=1 Q - . I $Y+5>IOSL S SDONE='$$HDR(SDIV) Q:SDONE - . W ! - . I $D(SDPRX),SORT1'=1 W ?90,$S(+SDPRX>0:$P(^VA(200,SDPRX,0),U),1:"") - . I $D(SDDX1),SORT1'=2 W ?117,SDDX1 - S Y=1 -PRNTQ S:QFLAG Y=0 Q (Y) - ; -HDR(SDIV) ; - N Y - S Y=0 - I SDVC'="",$E(IOST,1,2)="C-" D G:QFLAG HDRQ - . K DIR S DIR(0)="FO",DIR("A")="Press RETURN to continue or '^' to exit" - . S DIR("?",1)="Pressing any key other than the '^' key will scroll to the next screen",DIR("?")="The '^' key will exit the listing." - . D ^DIR K DIR I $D(DTOUT)!($D(DUOUT)) S QFLAG=1 Q - . W @IOF - S PAGE=PAGE+1 - I $E(IOST,1,2)'="C-",SDVC'="" W @IOF - W !!,"Provider/Diagnosis Encounter Report sorted by ",$P($T(SORT+SORT1^SDAMODO1),";;",2)," and ",$P($T(SORT+SORT2^SDAMODO1),";;",2) - W ?(IOM-40),"Report Date: ",$P($$NOW^VALM1,"@"),?(IOM-10),"Page: ",PAGE - W !,"Inclusion Dates: ",$P($$FMTE^XLFDT(SDBEG,1),"@")," to ",$P($$FMTE^XLFDT(SDEND,1),"@") - W !,"Division: ",$P($G(^DG(40.8,SDIV,0)),U) - W !!,"PATIENT",?32,"ENCOUNTER DATE",?55,"CLINIC/PRIMARY STOP CODE",?90,"PROVIDER",?117,"DX CODE" - W !,"-------------------",?32,"------------------",?55,"------------------------",?90,"--------------",?117,"-------" - S Y=1 -HDRQ Q (Y) - ; -NOREP ; - W !!,"Provider/Diagnosis Report sorted by ",$P($T(SORT+SORT1^SDAMODO1),";;",2)," and ",$P($T(SORT+SORT2^SDAMODO1),";;",2) - W ?(IOM-40),"Report Date: ",$P($$NOW^VALM1,"@") - W !,"Inclusion Dates: ",$P($$FMTE^XLFDT(SDBEG,1),"@")," to ",$P($$FMTE^XLFDT(SDEND,1),"@") - W !!,"No data found matching sort parameters" - Q - ; -SELPRV(PRV) ; - N Y S Y=1 - I PROVDR=1 G SELPRVQ - I $D(PROVDR($P(PRV,"^",2))) G SELPRVQ - S Y=0 -SELPRVQ Q (Y) - ; -SELDX(DX) ; - N Y S Y=1 - I PDIAG=1 G SELDXQ - S DIC="^ICD9(",DIC(0)="XMS",X=DX_" " ;SD/529 - D ^DIC K DIC I Y<0 S Y=0 G SELDXQ - I $D(PDIAG($P(Y,U))) G SELDXQ - S Y=0 -SELDXQ Q (Y) +SDAMODO3 ;ALB/SCK - PROVIDER DIAGNOSTICS REPORT OUTPUT ; 05 Oct 98 8:44 PM + ;;5.3;Scheduling;**11,25,46,49,159**;Aug 13, 1993 + Q +REPORT ; + I '$D(^TMP("SDRPT",$J)) D NOREP G EXIT +START ; + N SDIV,OEN,SDPRX,SUB1,SUB2,OEN,SDATA,SDX,SPRV,SDCHECK + S (SDIV,SDFIN,SDVC,SUBX,SUB1,SUB2)="",(PAGE,QFLAG,SUBCNT)=0 + W:$E(IOST,1,2)="C-" @IOF + F S SDIV=$O(^TMP("SDRPT",$J,SDIV)) Q:SDIV="" D Q:SDFIN + . I SDIV'=SDVC S SUBX=$$SUBCNT(SUB1,SUBX),SDFIN='$$HDR(SDIV) Q:SDFIN S SDVC=SDIV + . S SUB1="" F S SUB1=$O(^TMP("SDRPT",$J,SDIV,SUB1)) Q:SUB1="" D Q:SDFIN + .. I SUBX'=SUB1 S SUBX=$$SUBCNT(SUB1,SUBX) + .. I SORT1=4!(SORT1=5) I SUBX]"",SUBX'=SUB1 S SDFIN='$$HDR(SDIV) + .. S SUB2="" F S SUB2=$O(^TMP("SDRPT",$J,SDIV,SUB1,SUB2)) Q:SUB2="" D Q:SDFIN + ... S OEN=0 F S OEN=$O(^TMP("SDRPT",$J,SDIV,SUB1,SUB2,OEN)) Q:'OEN S SUBCNT=SUBCNT+1,SDCHECK="" D Q:SDFIN + .... S I=0 F S I=$O(^TMP("SDRPT",$J,SDIV,SUB1,SUB2,OEN,I)) Q:'I S SDFIN='$$PRNT(I) Q:SDFIN + S SUBX=$$SUBCNT(SUB1,SUBX) +EXIT ; + K QFLAG,PAGE,SDFIN,SDVC,SDONE,XX,^TMP("SDRPT",$J),SUBCNT,SUBX + Q + ; +SUBCNT(SB1,SB1P) ; + I SB1P']""!(SUBCNT'>0) G SUBCNTQ + W !,SUBCNT," ",$S(SORT2=1!(SORT2=2):"Primary "_$P($T(SORT+SORT2^SDAMODO1),";;",2),1:$P($T(SORT+SORT2^SDAMODO1),";;",2))," entries for ",$S(SORT1=1!(SORT1=3):$P(SB1P,"^"),SORT1=5:$P($G(^DIC(40.7,SB1P,0)),U),1:SB1P),!! + S SUBCNT=0 +SUBCNTQ Q (SB1) + ; +PRNT(I) ; + N Y,SDATA,SPRV,SDX,XX,SCODE,SDDX1,SDPRX,SDSID + S SDATA=(^TMP("SDRPT",$J,SDIV,SUB1,SUB2,OEN,I,0)) + S XX="" F S XX=$O(^TMP("SDRPT",$J,SDIV,SUB1,SUB2,OEN,I,"PRV",XX)) Q:'XX S SPRV(XX)="" + S XX="" F S XX=$O(^TMP("SDRPT",$J,SDIV,SUB1,SUB2,OEN,I,"DX",XX)) Q:XX="" S SDX(XX)="" + I SORT1=1,'$$SELPRV(SUB1) S Y=1 G PRNTQ + I SORT1=2,'$$SELDX(SUB1) S Y=1 G PRNTQ + I $Y+5>IOSL S Y='$$HDR(SDIV) G:Y PRNTQ +LINE1 ; + S SDSID=$P($G(SDATA),U,2) + W !,$P(^DPT($P($G(SDATA),U),0),U)_" "_$P(SDSID,"-",3) + S:SDCHECK="" SDCHECK=SDSID I SDSID'=SDCHECK S SUBCNT=SUBCNT+1 + W ?32,$P($$FMTE^XLFDT(OEN,1),":",1,2) ; modified to drop seconds + W ?55,$E($P(SDATA,U,3),1,25) + W ?90,$S(+$P(SDATA,U,5)>0:$P(^VA(200,+$P(SDATA,U,5),0),U),1:$P(SDATA,U,5)) + W ?117,$P(SDATA,U,6) +LINE2 ; + S SCODE=$P(SDATA,U,4) + W !?56,$P($G(^DIC(40.7,+SCODE,0)),U,2),"/",$P($G(^DIC(40.7,+SCODE,0)),U) + S SDPRX="",SDPRX=$O(SPRV(SDPRX)) I $D(SDPRX),SORT1'=1 W ?90,$S(+SDPRX>0:$P(^VA(200,SDPRX,0),U),1:"") + S SDDX1="",SDDX1=$O(SDX(SDDX1)) I $D(SDDX1),SORT1'=2 W ?117,SDDX1 + S SDONE=0 + F XX=1:1 D Q:SDONE + . I SDDX1'="" S SDDX1=$O(SDX(SDDX1)) + . I SDPRX'="" S SDPRX=$O(SPRV(SDPRX)) + . I SDPRX']""&(SDDX1']"") S SDONE=1 Q + . I $Y+5>IOSL S SDONE='$$HDR(SDIV) Q:SDONE + . W ! + . I $D(SDPRX),SORT1'=1 W ?90,$S(+SDPRX>0:$P(^VA(200,SDPRX,0),U),1:"") + . I $D(SDDX1),SORT1'=2 W ?117,SDDX1 + S Y=1 +PRNTQ S:QFLAG Y=0 Q (Y) + ; +HDR(SDIV) ; + N Y + S Y=0 + I SDVC'="",$E(IOST,1,2)="C-" D G:QFLAG HDRQ + . K DIR S DIR(0)="FO",DIR("A")="Press RETURN to continue or '^' to exit" + . S DIR("?",1)="Pressing any key other than the '^' key will scroll to the next screen",DIR("?")="The '^' key will exit the listing." + . D ^DIR K DIR I $D(DTOUT)!($D(DUOUT)) S QFLAG=1 Q + . W @IOF + S PAGE=PAGE+1 + I $E(IOST,1,2)'="C-",SDVC'="" W @IOF + W !!,"Provider/Diagnosis Encounter Report sorted by ",$P($T(SORT+SORT1^SDAMODO1),";;",2)," and ",$P($T(SORT+SORT2^SDAMODO1),";;",2) + W ?(IOM-40),"Report Date: ",$P($$NOW^VALM1,"@"),?(IOM-10),"Page: ",PAGE + W !,"Inclusion Dates: ",$P($$FMTE^XLFDT(SDBEG,1),"@")," to ",$P($$FMTE^XLFDT(SDEND,1),"@") + W !,"Division: ",$P($G(^DG(40.8,SDIV,0)),U) + W !!,"PATIENT",?32,"ENCOUNTER DATE",?55,"CLINIC/PRIMARY STOP CODE",?90,"PROVIDER",?117,"DX CODE" + W !,"-------------------",?32,"------------------",?55,"------------------------",?90,"--------------",?117,"-------" + S Y=1 +HDRQ Q (Y) + ; +NOREP ; + W !!,"Provider/Diagnosis Report sorted by ",$P($T(SORT+SORT1^SDAMODO1),";;",2)," and ",$P($T(SORT+SORT2^SDAMODO1),";;",2) + W ?(IOM-40),"Report Date: ",$P($$NOW^VALM1,"@") + W !,"Inclusion Dates: ",$P($$FMTE^XLFDT(SDBEG,1),"@")," to ",$P($$FMTE^XLFDT(SDEND,1),"@") + W !!,"No data found matching sort parameters" + Q + ; +SELPRV(PRV) ; + N Y S Y=1 + I PROVDR=1 G SELPRVQ + I $D(PROVDR($P(PRV,"^",2))) G SELPRVQ + S Y=0 +SELPRVQ Q (Y) + ; +SELDX(DX) ; + N Y S Y=1 + I PDIAG=1 G SELDXQ + S DIC="^ICD9(",DIC(0)="MZ",X=DX + D ^DIC K DIC I Y<0 S Y=0 G SELDXQ + I $D(PDIAG($P(Y,U))) G SELDXQ + S Y=0 +SELDXQ Q (Y) diff --git a/r/SCHEDULING-SD-SC/SDAMVSC.m b/r/SCHEDULING-SD-SC/SDAMVSC.m index 414a029e..1e4b5a10 100644 --- a/r/SCHEDULING-SD-SC/SDAMVSC.m +++ b/r/SCHEDULING-SD-SC/SDAMVSC.m @@ -1,64 +1,54 @@ -SDAMVSC ;;OIFO-BAY PINES/TEH - Appt Event Driver Utilities-Validate SC Appt type ; 12/1/91 [ 09/19/96 1:39 PM ] ; Compiled August 20, 2007 14:28:26 - ;;5.3;Scheduling;**394,417,491**;Aug 13, 1993;Build 53 - ; - ; - ;*************************************************************************************************************************** - ; - ; ***** NOTE ***** - ; - ;This software was created to be used with the SCHEDULING V5.3 appointment management package. The SRA API (SDAMA301) - ;was employed to retrieve data from the PATIENT APPOINTMENT file (2.98) due inpart to VA Fileman non-compliance. - ; - ;DBIA #4433 SUBSCRIPTION - ; - ; - ;Entry Point EN. This routine requires the OUTPATIENT ENOUNTER IEN (variable SDOE) - ; - ;GLOBALS: ^SCE(IEN,0) (#.1) APPOINTMENT TYPE [10P:409.1] - ; ^DPT(IEN,"S",DATE,0) ^ (#9.5) APPOINTMENT TYPE [16P:409.1] - ; ^SD(409.41,0)=OUTPATIENT CLASSIFCATION TYPE "Was treatment for SC Condition? " QUESTION FOR CHECKOUT. - ; - ;PROTOCOLS: This routine is called from the SDAM APPOINTMENT EVENTS. - ; - ;This validates that both the OUTPATIENT ENCOUNTER and the PATIENT SCHEDULING NODES for APPOINTMENT TYPE are (pointer to - ;409.1 APPOINTMENT TYPE) are set to the "SERVICE CONNECTED" appointment type when the response to the CLASSIFICATION TYPE - ;"Was treatment for SC Condition?" question is answered "YES". If the question is answered "NO" and the APPOINTMENT TYPE - ;is SERVICE CONNECTED, then the APPOINTMENT TYPE is reverted to REGULAR. - ; - ; - ;**************************************************************************************************************************** - Q -EN ;Entry Point - Q:'$G(SDOE) - N SDN,SDVSCL,SDVSTD,SDAPDF,SDDPTYP,SDOED,SDVSTD,SDVDPTD,SDVSCD,SDSCV,SDAPPTY,SDAPDT,SDDFN,SDVSTD,SDIENS,SDARRAY,SDAPDF - S SDOED=$G(^SCE(SDOE,0)) Q:SDOED="" - S SDDFN=$P(SDOED,U,2),SDAPDT=$P(SDOED,U) - ;GET APPOINTMENT FROM EVENT OUTPUT ARRAY - I $G(^TMP("SDAMEVT",$J,"AFTER","DPT")) S SDAPDPT=$P($G(^TMP("SDAMEVT",$J,"AFTER","DPT")),"^",16) - E S SDAPDPT=$P(SDOED,"^",10) ;APP TYPE - S SDVSCL=$P(SDOED,U,4) - S SDVSTD=$P(SDOED,U,5) - Q:'SDVSTD ; ticket #194210 ; do not proceed if no pointer to a visit - Q:'$D(^AUPNVSIT(SDVSTD,800)) - S SDSCV=+$$GET1^DIQ(9000010,SDVSTD_",",80001,"I") ;SC flag in Visit file - S SDAPDF=$$GET1^DIQ(44,SDVSCL_",",2507,"I") ;default appt type - ;find if credit stop secondary visit exists. - N SDVSTDS,SDOE1 S SDOE1="" S SDVSTDS=$O(^AUPNVSIT("AD",SDVSTD,"")) - I SDVSTDS>0 S SDOE1=$O(^SCE("AVSIT",SDVSTDS,"")) - I SDSCV I SDAPDPT'=11 S SDAPDPT=11 D APPT F SDE=SDOE,SDOE1 I SDE>0 D SCE(SDE) - I 'SDSCV I SDAPDPT=11 D D APPT F SDE=SDOE,SDOE1 I SDE>0 D SCE(SDE) - . I SDAPDF'="" S SDAPDPT=SDAPDF ; set to default if exists for this clinic - . E S SDAPDPT=9 ; set to regular - Q -SCE(SDE) ;Set FDA for SCE(ien,0) OUTPATIENT ENCOUNTER - S SDIENS=SDE_"," K ^TMP("SDAMSCE",$J) - D FDA^DILF(409.68,SDIENS,.1,,SDAPDPT,"^TMP(""SDAMSCE"",$J)","^TMP(""SDAMSCE"",$J)") - I $D(^TMP("SDAMSCE",$J,"DIERR")) D Q - .W !,"Processing Error ",^TMP("SDAMSCE",$J,"DIERR",1) Q - D FILE^DIE(,"^TMP(""SDAMSCE"",$J)","^TMP(""SDAMSCE"",$J)") - Q -APPT ;quit if clinic in event doesn't match clinic in ^DPT - ;set up app type in DPT - I +$G(^TMP("SDAMEVT",$J,"AFTER","DPT"))'=+$G(^DPT(SDDFN,"S",SDAPDT,0)) Q - I $D(^DPT(SDDFN,"S",SDAPDT,0)) S $P(^DPT(SDDFN,"S",SDAPDT,0),U,16)=SDAPDPT -END Q +SDAMVSC ;;OIFO-BAY PINES/TEH - Appt Event Driver Utilities-Validate SC Appt type ; 12/1/91 [ 09/19/96 1:39 PM ] + ;;5.3;Scheduling;**394,417**;Aug 13, 1993 + ; + ;*************************************************************************************************************************** + ; + ; ***** NOTE ***** + ; + ;This software was created to be used with the SCHEDULING V5.3 appointment management package. The SRA API (SDAMA301) + ;was employed to retrieve data from the PATIENT APPOINTMENT file (2.98) due inpart to VA Fileman non-compliance. + ; + ;DBIA #4433 SUBSCRIPTION + ; + ;Entry Point EN. This routine requires the OUTPATIENT ENOUNTER IEN (variable SDOE) + ; + ;GLOBALS: ^SCE(IEN,0) (#.1) APPOINTMENT TYPE [10P:409.1] + ; ^DPT(IEN,"S",DATE,0) ^ (#9.5) APPOINTMENT TYPE [16P:409.1] + ; ^SD(409.41,0)=OUTPATIENT CLASSIFCATION TYPE "Was treatment for SC Condition? " QUESTION FOR CHECKOUT. + ; + ;PROTOCOLS: This routine is called from the SDAM APPOINTMENT EVENTS. + ; + ;This validates that both the OUTPATIENT ENCOUNTER and the PATIENT SCHEDULING NODES for APPOINTMENT TYPE are (pointer to + ;409.1 APPOINTMENT TYPE) are set to the "SERVICE CONNECTED" appointment type when the response to the CLASSIFICATION TYPE + ;"Was treatment for SC Condition?" question is answered "YES". If the question is answered "NO" and the APPOINTMENT TYPE + ;is SERVICE CONNECTED, then the APPOINTMENT TYPE is reverted to REGULAR. + ; + ; + ;**************************************************************************************************************************** + Q +EN ;Entry Point + G END:'$D(SDOE),END:'$G(SDOE),END:SDOE="" + N SDVSCL,SDVSTD,SDAPDF,SDDPTYP,SDOED,SDVSTD,SDVDPTD,SDVSCD,SDSCV,SDAPPTY,SDAPDT,SDDFN,SDVSTD,SDIENS,SDARRAY,SDAPDF + S SDOED=$G(^SCE(SDOE,0)) G END:SDOED="" + S SDDFN=$P(SDOED,U,2),SDAPDT=$P(SDOED,U) I '$D(^DPT(SDDFN,"S",SDAPDT,0)) Q + ;GET APPOINTMENT FROM 2.98 + N SDAMIENS S SDAMIENS=SDAPDT_","_SDDFN_"," + S SDAPDPT=$$GET1^DIQ(2.98,SDAMIENS,9.5,"I") + S SDVSCL=$P(SDOED,U,4) + S SDVSTD=$P(SDOED,U,5),SDSCV=$$GET1^DIQ(9000010,SDVSTD_",",80001,"I") + S SDAPDF=$$GET1^DIQ(44,SDVSCL_",",2507,"I") + S SDAPPTY=$S(SDSCV=1:11,$D(SDAPDPT):SDAPDPT,SDAPDT'="":SDAPDF,1:9) D + .;Set FDA for SCE(ien,0) OUTPATIENT ENCOUNTER + .S SDIENS=SDOE_"," K ^TMP("SDAMSCE",$J) + .D FDA^DILF(409.68,SDIENS,.1,,SDAPPTY,"^TMP(""SDAMSCE"",$J)","^TMP(""SDAMSCE"",$J)") + .I $D(^TMP("SDAMSCE",$J,"DIERR")) D + ..W !,"Processing Error ",^TMP("SDAMSCE",$J,"DIERR",1) Q + .D FILE^DIE(,"^TMP(""SDAMSCE"",$J)","^TMP(""SDAMSCE"",$J)") + .;Set FDA for ^DPT(ien,"S") PATIENT APPOINTMENT. + .K ^TMP($J,"SDAMA301") + .N SDAMVSCX S SDARRAY(1)=SDAPDT_";"_SDAPDT,SDARRAY(4)=SDDFN,SDARRAY("FLDS")=10,SDAMVSCX=$$SDAPI^SDAMA301(.SDARRAY) + .I 'SDAMVSCX D Q + ..W !,"Processing Error " + .S SDDPTYP=+$P($G(^TMP($J,"SDAMA301",SDDFN,SDVSCL,SDAPDT)),U,10) I SDDPTYP'=SDAPPTY D + ..S $P(^DPT(SDDFN,"S",SDAPDT,0),U,16)=SDAPPTY +END Q diff --git a/r/SCHEDULING-SD-SC/SDC.m b/r/SCHEDULING-SD-SC/SDC.m index f80a292c..92089746 100644 --- a/r/SCHEDULING-SD-SC/SDC.m +++ b/r/SCHEDULING-SD-SC/SDC.m @@ -1,69 +1,67 @@ -SDC ;MAN/GRR,ALB/LDB - CANCEL A CLINIC'S AVAILABILITY ; 3/2/05 2:11pm - ;;5.3;Scheduling;**15,32,79,132,167,478,487,523**;Aug 13, 1993;Build 6 - N SDATA,SDCNHDL ; for evt dvr -SDC1 K SDLT,SDCP S NOAP="" D LO^DGUTL - S DIC=44,DIC(0)="MEQA",DIC("S")="I $P(^(0),""^"",3)=""C"",'$G(^(""OOS""))",DIC("A")="Select CLINIC NAME: " D ^DIC K DIC("S"),DIC("A") G:'$D(^SC(+Y,"SL")) END^SDC0 - S SC=+Y,SL=^("SL"),%DT="AEXF",%DT("A")="CANCEL '"_$P(Y,U,2)_"' FOR WHAT DATE: " D ^%DT K %DT G:Y<0 END^SDC0 ;NAKED REFERNCE - ^SC(IFN,"SL") - S (SD,CDATE)=Y,%=$P(SL,U,6),SI=$S(%="":4,%<3:4,%:%,1:4),%=$P(SL,U,3),STARTDAY=$S($L(%):%,1:8) D NOW^%DTC S SDTIME=% - K SDRE,SDIN,SDRE1 I $D(^SC(SC,"I")) S SDIN=+^("I"),SDRE=+$P(^("I"),"^",2),Y=SDRE D:Y DTS^SDUTL S SDRE1=$S(SDRE:" to "_Y,1:"") - I $S('$D(SDIN):0,SDIN'>0!(SDIN>SD):0,SDRE'>SD&(SDRE):0,1:1) W !,*7,"Clinic is inactive ",$S('SDRE:"as of ",1:"from ") S Y=SDIN D DTS^SDUTL W Y,SDRE1 G SDC1 - I '$D(^SC(SC,"ST",SD,1)) S DH="" D B S ^SC(SC,"ST",SD,1)=$P("SU^MO^TU^WE^TH^FR^SA",U,DOW+1)_" "_$E(SD,6,7)_$J("",SI+SI-6)_DH,^(0)=SD G N - I ^(1)["CANCELLED" W !,"APPOINTMENTS HAVE ALREADY BEEN CANCELLED",!,*7 S ANS="N",SDTIME="*",SDV1=$S($P(^SC(SC,0),"^",15):$P(^(0),"^",15),1:+$O(^DG(40.8,0))) K SDX G ASKL^SDC0 ;NAKED REFERENCE - ^SC(IFN,"ST",Date,1) -N I '$F(^SC(SC,"ST",SD,1),"[") K:^(1)?2U.E ^SC(SC,"ST",SD) W !,*7,"CLINIC DOES NOT MEET ON THAT DAY" G SDC1 ; KILLs node if not holiday - I $O(^SC(SC,"S",SD))\1-SD W *7,!?5,"NO APPOINTMENTS SCHEDULED" S NOAP=1 G W - W !,"FIRST, I'LL LIST THE EXISTING APPOINTMENTS",! - K DUOUT,DTOUT D ^SDC1 I $D(DUOUT)!$D(DTOUT) D END^SDC0 Q - I ^SC(SC,"ST",SD,1)["X" G ^SDC2 -W S DH=0,%="" W !,"WANT TO CANCEL THE WHOLE DAY" D YN^DICN I '% W !,"REPLY YES (Y) OR NO (N)" G W - I %=1 G WP:$$COED^SDC4(SC,SD,SD+.2359,1),ALL - Q:%<1 -WP S %="" W !,"WANT TO CANCEL PART OF THE DAY" D YN^DICN I '% W !,"REPLY YES (Y) OR NO (N)" G WP - Q:(%-1) -F R !,"STARTING TIME: ",X:DTIME Q:U[X D TC^SDC2 G F:Y<0 S FR=Y,ST=% -T R !,"ENDING TIME: ",X:DTIME Q:U[X D TC^SDC2 G T:Y<0 S SDHTO=X,TO=Y I TO'>FR W !,"Ending time must be greater than starting time",*7 G T - I $$COED^SDC4(SC,FR,TO,1) K FR,SDHTO,TO,ST W ! G F -ROPT R !,"Reason for cancellation: ",I:DTIME I I?1"?".E W !,"YOU MAY ENTER A MESSAGE CONCERNING THE CANCELLATION HERE" G ROPT - N CANREM S CANREM=I - Q:I["^" I '$D(^SC(SC,"SDCAN",0)) S ^SC(SC,"SDCAN",0)="^44.05D^"_FR_"^1" G SKIP - S A=^SC(SC,"SDCAN",0),SDCNT=$P(A,"^",4),^SC(SC,"SDCAN",0)=$P(A,"^",1,2)_"^"_FR_"^"_(SDCNT+1) -SKIP S ^SC(SC,"SDCAN",FR,0)=FR_"^"_SDHTO - S NOAP=$S($O(^SC(SC,"S",(FR-.0001)))'>0:1,$O(^SC(SC,"S",(FR-.0001)))>TO:1,1:0) I 'NOAP S NOAP=$S($O(^SC(SC,"S",+$O(^SC(SC,"S",(FR-.0001))),0))="MES":1,1:0) - S ^SC(SC,"S",FR,0)=FR,^("MES")="CANCELLED UNTIL "_X_$S(I?.P:"",1:" ("_I_")") D S S I=^(1),I=I_$J("",%-$L(I)),Y="" - F X=0:2:% S DH=$E(I,X+SI+SI),P=$S(X160!($L(CANREM)<3) W !,*7,"Reason must be between 3 to 160 characters long",! G ALL - D S S ^(1)=" "_$E(SD,6,7)_" **CANCELLED**",FR=SD,TO=SD+.9 ;NAKED REFERENCE - ^SC(IFN,"ST",Date,1) -C S FR=$O(^SC(SC,"S",FR)) I FR<1!(FR'0 D - .S DFN=+^SC(SC,"S",FR,1,I,0),SDCNHDL=$$HANDLE^SDAMEVT(1) - .D BEFORE^SDAMEVT(.SDATA,DFN,FR,SC,I,SDCNHDL) - .S $P(^SC(SC,"S",FR,1,I,0),"^",9)="C" - .S:$D(^DPT(DFN,"S",FR,0)) NODE=^(0) ;added SD/523 - .Q:$P(NODE,U,1)'=SC ;added SD/523 - .S ^DPT("ASDCN",SC,FR,DFN)="" - .S SDSC=SC,SDTTM=FR,SDPL=I,TDH=DH,TMPD=CANREM D CANCEL^SDCNSLT S DH=TDH ;SD/478 - .I $D(^DPT(DFN,"S",FR,0)),$P(^(0),"^",2)'["C" S $P(^(0),"^",2)="C",$P(^(0),"^",12)=DUZ,$P(^(0),"^",14)=SDTIME,DH=DH+1,TDH=DH,DIE="^DPT(DFN,"_"""S"""_",",DR="17///^S X=CANREM",DA=FR D ^DIE S DH=TDH D MORE - G C - ; -B S X=SD D DOW^SDM0 S DOW=Y,SS=+$O(^SC(SC,"T"_Y,X)) I $D(^(SS,1)),^(1)]"" S DH=^(1),DO=X+1,DA(1)=SC - Q -MORE I $D(^SC("ARAD",SC,FR,DFN)) S ^(DFN)="N" - S SDIV=$S($P(^SC(SC,0),"^",15)]"":$P(^(0),"^",15),1:" 1"),SDV1=$S(SDIV:SDIV,1:+$O(^DG(40.8,0))) I $D(^DPT("ASDPSD","C",SDIV,SC,FR,DFN)) K ^(DFN) - S SDH=DH,SDTTM=FR,SDSC=SC,SDPL=I,SDRT="D" D RT^SDUTL - S DH=SDH K SDH D CK1,EVT - K SD1,SDIV,SDPL,SDRT,SDSC,SDTTM,SDX Q -CK1 S SDX=0 F SD1=FR\1:0 S SD1=$O(^DPT(DFN,"S",SD1)) Q:'SD1!((SD1\1)'=(FR\1)) I $P(^(SD1,0),"^",2)'["C",$P(^(0),"^",2)'["N" S SDX=1 Q - Q:SDX F SD1=2,4 I $D(^SC("AAS",SD1,FR\1,DFN)) S SDX=1 Q - Q:SDX IF $D(^SCE(+$$EXAE^SDOE(DFN,FR\1,FR\1),0)) S SDX=1 - Q:SDX K ^DPT("ASDPSD","B",SDIV,FR\1,DFN) Q - ; -EVT ; -- separate tag if need to NEW vars - ; -- cancel event - N FR,I,SDTIME,DH,SC - D CANCEL^SDAMEVT(.SDATA,DFN,SDTTM,SDSC,SDPL,0,SDCNHDL) K SDATA,SDCNHDL - Q +SDC ;MAN/GRR,ALB/LDB - CANCEL A CLINIC'S AVAILABILITY ; 3/2/05 2:11pm + ;;5.3;Scheduling;**15,32,79,132,167,478,487**;Aug 13, 1993 + N SDATA,SDCNHDL ; for evt dvr +SDC1 K SDLT,SDCP S NOAP="" D LO^DGUTL + S DIC=44,DIC(0)="MEQA",DIC("S")="I $P(^(0),""^"",3)=""C"",'$G(^(""OOS""))",DIC("A")="Select CLINIC NAME: " D ^DIC K DIC("S"),DIC("A") G:'$D(^SC(+Y,"SL")) END^SDC0 + S SC=+Y,SL=^("SL"),%DT="AEXF",%DT("A")="CANCEL '"_$P(Y,U,2)_"' FOR WHAT DATE: " D ^%DT K %DT G:Y<0 END^SDC0 ;NAKED REFERNCE - ^SC(IFN,"SL") + S (SD,CDATE)=Y,%=$P(SL,U,6),SI=$S(%="":4,%<3:4,%:%,1:4),%=$P(SL,U,3),STARTDAY=$S($L(%):%,1:8) D NOW^%DTC S SDTIME=% + K SDRE,SDIN,SDRE1 I $D(^SC(SC,"I")) S SDIN=+^("I"),SDRE=+$P(^("I"),"^",2),Y=SDRE D:Y DTS^SDUTL S SDRE1=$S(SDRE:" to "_Y,1:"") + I $S('$D(SDIN):0,SDIN'>0!(SDIN>SD):0,SDRE'>SD&(SDRE):0,1:1) W !,*7,"Clinic is inactive ",$S('SDRE:"as of ",1:"from ") S Y=SDIN D DTS^SDUTL W Y,SDRE1 G SDC1 + I '$D(^SC(SC,"ST",SD,1)) S DH="" D B S ^SC(SC,"ST",SD,1)=$P("SU^MO^TU^WE^TH^FR^SA",U,DOW+1)_" "_$E(SD,6,7)_$J("",SI+SI-6)_DH,^(0)=SD G N + I ^(1)["CANCELLED" W !,"APPOINTMENTS HAVE ALREADY BEEN CANCELLED",!,*7 S ANS="N",SDTIME="*",SDV1=$S($P(^SC(SC,0),"^",15):$P(^(0),"^",15),1:+$O(^DG(40.8,0))) K SDX G ASKL^SDC0 ;NAKED REFERENCE - ^SC(IFN,"ST",Date,1) +N I '$F(^SC(SC,"ST",SD,1),"[") K:^(1)?2U.E ^SC(SC,"ST",SD) W !,*7,"CLINIC DOES NOT MEET ON THAT DAY" G SDC1 ; KILLs node if not holiday + I $O(^SC(SC,"S",SD))\1-SD W *7,!?5,"NO APPOINTMENTS SCHEDULED" S NOAP=1 G W + W !,"FIRST, I'LL LIST THE EXISTING APPOINTMENTS",! + K DUOUT,DTOUT D ^SDC1 I $D(DUOUT)!$D(DTOUT) D END^SDC0 Q + I ^SC(SC,"ST",SD,1)["X" G ^SDC2 +W S DH=0,%="" W !,"WANT TO CANCEL THE WHOLE DAY" D YN^DICN I '% W !,"REPLY YES (Y) OR NO (N)" G W + I %=1 G WP:$$COED^SDC4(SC,SD,SD+.2359,1),ALL + Q:%<1 +WP S %="" W !,"WANT TO CANCEL PART OF THE DAY" D YN^DICN I '% W !,"REPLY YES (Y) OR NO (N)" G WP + Q:(%-1) +F R !,"STARTING TIME: ",X:DTIME Q:U[X D TC^SDC2 G F:Y<0 S FR=Y,ST=% +T R !,"ENDING TIME: ",X:DTIME Q:U[X D TC^SDC2 G T:Y<0 S SDHTO=X,TO=Y I TO'>FR W !,"Ending time must be greater than starting time",*7 G T + I $$COED^SDC4(SC,FR,TO,1) K FR,SDHTO,TO,ST W ! G F +ROPT R !,"Reason for cancellation: ",I:DTIME I I?1"?".E W !,"YOU MAY ENTER A MESSAGE CONCERNING THE CANCELLATION HERE" G ROPT + N CANREM S CANREM=I + Q:I["^" I '$D(^SC(SC,"SDCAN",0)) S ^SC(SC,"SDCAN",0)="^44.05D^"_FR_"^1" G SKIP + S A=^SC(SC,"SDCAN",0),SDCNT=$P(A,"^",4),^SC(SC,"SDCAN",0)=$P(A,"^",1,2)_"^"_FR_"^"_(SDCNT+1) +SKIP S ^SC(SC,"SDCAN",FR,0)=FR_"^"_SDHTO + S NOAP=$S($O(^SC(SC,"S",(FR-.0001)))'>0:1,$O(^SC(SC,"S",(FR-.0001)))>TO:1,1:0) I 'NOAP S NOAP=$S($O(^SC(SC,"S",+$O(^SC(SC,"S",(FR-.0001))),0))="MES":1,1:0) + S ^SC(SC,"S",FR,0)=FR,^("MES")="CANCELLED UNTIL "_X_$S(I?.P:"",1:" ("_I_")") D S S I=^(1),I=I_$J("",%-$L(I)),Y="" + F X=0:2:% S DH=$E(I,X+SI+SI),P=$S(X160!($L(CANREM)<3) W !,*7,"Reason must be between 3 to 160 characters long",! G ALL + D S S ^(1)=" "_$E(SD,6,7)_" **CANCELLED**",FR=SD,TO=SD+.9 ;NAKED REFERENCE - ^SC(IFN,"ST",Date,1) +C S FR=$O(^SC(SC,"S",FR)) I FR<1!(FR'0 D + .S DFN=+^SC(SC,"S",FR,1,I,0),SDCNHDL=$$HANDLE^SDAMEVT(1) + .D BEFORE^SDAMEVT(.SDATA,DFN,FR,SC,I,SDCNHDL) + .S $P(^SC(SC,"S",FR,1,I,0),"^",9)="C" + .S ^DPT("ASDCN",SC,FR,DFN)="" + .S SDSC=SC,SDTTM=FR,SDPL=I,TDH=DH,TMPD=CANREM D CANCEL^SDCNSLT S DH=TDH ;SD/478 + .I $D(^DPT(DFN,"S",FR,0)),$P(^(0),"^",2)'["C" S $P(^(0),"^",2)="C",$P(^(0),"^",12)=DUZ,$P(^(0),"^",14)=SDTIME,DH=DH+1,TDH=DH,DIE="^DPT(DFN,"_"""S"""_",",DR="17///^S X=CANREM",DA=FR D ^DIE S DH=TDH D MORE + G C + ; +B S X=SD D DOW^SDM0 S DOW=Y,SS=+$O(^SC(SC,"T"_Y,X)) I $D(^(SS,1)),^(1)]"" S DH=^(1),DO=X+1,DA(1)=SC + Q +MORE I $D(^SC("ARAD",SC,FR,DFN)) S ^(DFN)="N" + S SDIV=$S($P(^SC(SC,0),"^",15)]"":$P(^(0),"^",15),1:" 1"),SDV1=$S(SDIV:SDIV,1:+$O(^DG(40.8,0))) I $D(^DPT("ASDPSD","C",SDIV,SC,FR,DFN)) K ^(DFN) + S SDH=DH,SDTTM=FR,SDSC=SC,SDPL=I,SDRT="D" D RT^SDUTL + S DH=SDH K SDH D CK1,EVT + K SD1,SDIV,SDPL,SDRT,SDSC,SDTTM,SDX Q +CK1 S SDX=0 F SD1=FR\1:0 S SD1=$O(^DPT(DFN,"S",SD1)) Q:'SD1!((SD1\1)'=(FR\1)) I $P(^(SD1,0),"^",2)'["C",$P(^(0),"^",2)'["N" S SDX=1 Q + Q:SDX F SD1=2,4 I $D(^SC("AAS",SD1,FR\1,DFN)) S SDX=1 Q + Q:SDX IF $D(^SCE(+$$EXAE^SDOE(DFN,FR\1,FR\1),0)) S SDX=1 + Q:SDX K ^DPT("ASDPSD","B",SDIV,FR\1,DFN) Q + ; +EVT ; -- separate tag if need to NEW vars + ; -- cancel event + N FR,I,SDTIME,DH,SC + D CANCEL^SDAMEVT(.SDATA,DFN,SDTTM,SDSC,SDPL,0,SDCNHDL) K SDATA,SDCNHDL + Q diff --git a/r/SCHEDULING-SD-SC/SDCLAS.m b/r/SCHEDULING-SD-SC/SDCLAS.m index 48a8a7b8..339020a6 100644 --- a/r/SCHEDULING-SD-SC/SDCLAS.m +++ b/r/SCHEDULING-SD-SC/SDCLAS.m @@ -1,53 +1,53 @@ -SDCLAS ;ALB/TMP,MRY - Clinic Assignment List Extract ;12/23/92 11:42 - ;;5.3;Scheduling;**63,243,517,523**;Aug 13, 1993;Build 6 - ;SD/517 CORRECTED ALL $NEXT FUNCTIONAL COMMANDS - S DIV="" D DIV^SDUTL I $T D CALST^SDDIV Q:Y<0 - S:'$D(DTIME) DTIME=300 I '$D(DT) D DT^SDUTL - S SDIFN="",SDI=0,DIC="^SC(",DIC(0)="EFMQ",DIC("S")="I $P(^(0),U,3)=""C"",'$G(^(""OOS"")),$S(DIV="""":1,$P(^(0),U,15)=DIV:1,1:0)" D SELECT^SDCLAS0 K DIC Q:X["^" - S Y=DT D DTS^SDUTL S SDTS=Y -OPT2 W !!,"Select 'As of' Date: ",SDTS," // " R X:DTIME Q:X["^" I X']"" S SDTS=DT G OVR - S %DT(0)=-DT,%DT="EPX" D ^%DT K %DT - I Y'>0 W !,*7,"A date must be entered here to get a 'snapshot' of the clinic's enrollment as of",!," this date. Date can not be in future." G OPT2 - S SDTS=+Y -OVR I SDSRT="C",SDSAV']"",SDIFN'="ALL",$S('$D(^SC(SDIFN,"I")):0,+^("I")=0:0,+^("I")>SDTS:0,+$P(^("I"),"^",2)'>SDTS&(+$P(^("I"),"^",2)'=0):0,1:1) W !,"Clinic ",$S(SDTS=DT:"is",1:"was")," inactive" W:SDTS
0 D PT - D:'SDFAST AEB^SDCLAS0 G ^SDCLAS1 -ALL S ONE=0 I SDSAV']"" S SDIFN=0 F S SDIFN=$O(^SC(SDIFN)) Q:'SDIFN I $P(^(SDIFN,0),"^",3)="C" D APPT - I SDSAV]"" D APART S SDIFN=0 F S SDIFN=$O(SDZ(SDIFN)) Q:'SDIFN I $D(^SC(SDIFN,0)),$P(^(0),"^",3)="C" D APPT - G ^SDCLAS1 -APPT D CHECK I 'POP K ^UTILITY($J,"PAT",SDIFN) D INIT F SDAPPT=SDTS:0 S SDAPPT=$O(^SC(SDIFN,"S",SDAPPT)) D:SDAPPT>0 PT I SDAPPT'>0 D:'SDFAST AEB^SDCLAS0 Q - Q -PT S SD=0 F S SD=$O(^SC(SDIFN,"S",SDAPPT,1,SD)) Q:'SD Q:'$D(^(SD,0)) S DFN=+^(0) D PT1 - Q -PT1 I '$D(^UTILITY($J,"PAT",SDIFN,DFN)),$D(^DPT(DFN,0)),$D(^("S",SDAPPT,0)),$P(^(0),"^",2)=""!($P(^(0),"^",2)="I"),$S('$D(^DPT(DFN,.35)):1,'^(.35):1,1:0) D S,EXT^SDCLAS0 - Q -S S Y(0)=^DPT(DFN,0),SDACT=1,SDENR=0 D SET1 - S I=0 F S I=$O(^DPT(DFN,"DE","B",SDIFN,I)) Q:'I I $D(^DPT(DFN,"DE",I,0)) D EDENR Q:SDENR - S ^UTILITY($J,"PAT",SDIFN,DFN)="" S:'$D(Y(1))!('SDENR) Y(1)="" I '$D(^UTILITY($J,"PAT"," ",DFN)) D MT S ^UTILITY($J,"PAT"," ",DFN)=$P(Y(0),"^",9)_"^"_SDELIG_"^"_SDZIP_"^"_$P(Y(0),"^",3)_U_SDMT - Q -EDENR K Y(1) S I1=0 F S I1=$O(^DPT(DFN,"DE",I,1,I1)) Q:'I1 S X=$P(^(I1,0),"^"),X(1)=$P(^(0),"^",3) Q:X>SDTS S:'X(1)!(X(1)>SDTS) Y(1)=^(0),SDENR=1 Q:SDENR - Q -SET1 S SDELIG=$S($D(^DPT(DFN,.36)):$P(^(.36),"^",1),1:""),SDELIG=$S($D(^DIC(8,+SDELIG,0)):SDELIG,1:""),SDELIG(1)=$S(SDELIG]"":$P(^(0),"^",5),1:""),SDZIP=$S($D(^DPT(DFN,.11)):$P(^(.11),"^",6),1:"") - Q -MT ; - S SDMT="*" Q:SDELIG(1)']"" I SDELIG(1)="N" S SDMT="N" Q - S SDMT=$$LST^DGMTU(DFN) I SDMT']"" S SDMT=$S(SDELIG'=6:"A",1:"X") Q - S:$P(SDMT,U,2)>SDTS SDMT=$$LST^DGMTU(DFN,SDTS) - I $P(SDMT,U,4)="P" S SDMT=$$PA^DGMTUTL($P(SDMT,U)),SDMT=$S('$D(SDMT):"U",SDMT="MT":"C",SDMT="GMT":"G",1:"U") - E S SDMT=$P(SDMT,U,4) - I SDMT="" S SDMT="X" - I SDMT="P" S SDMT="C" - I SDMT="R" S SDMT="U" - I SDMT="N" S SDMT="A" - D DOM^SDOPC4(DFN,SDTS_.9,.SDMT) I SDMT="X0" S SDMT="X" - K SDMT1 Q -CHECK S POP=0 I SDSRT="S",SDSTOP'="ALL",$P(^SC(SDIFN,0),"^",7)'=SDSTOP S POP=1 Q - I $S(DIV="":1,$P(^SC(SDIFN,0),"^",15)=DIV:1,1:0),$S('$D(^SC(SDIFN,"I")):1,+^("I")=0:1,+^("I")>DT:1,+$P(^("I"),"^",2)'>DT&(+$P(^("I"),"^",2)'=0):1,1:0) Q - S POP=1 Q -APART S SDZ="" F I=1:1 Q:$P(SDSAV,",",I)']"" S SDZ=$P(SDSAV,",",I) D:SDZ["--" SPLIT^SDCLAS0 I SDZ'["--" S:'$D(SDZ(+SDZ)) SDZ(+SDZ)="" - Q -INIT F I1="SDENR","SDACT" S I2="^UTILITY("_$J_","""_I1_""","_SDIFN_")",@I2=0 - Q +SDCLAS ;ALB/TMP,MRY - Clinic Assignment List Extract ;12/23/92 11:42 + ;;5.3;Scheduling;**63,243,517**;Aug 13, 1993;Build 4 + ;SD/517 CORRECTED ALL $NEXT FUNCTIONAL COMMANDS + S DIV="" D DIV^SDUTL I $T D CALST^SDDIV Q:Y<0 + S:'$D(DTIME) DTIME=300 I '$D(DT) D DT^SDUTL + S SDIFN="",SDI=0,DIC="^SC(",DIC(0)="EFMQ",DIC("S")="I $P(^(0),U,3)=""C"",'$G(^(""OOS"")),$S(DIV="""":1,$P(^(0),U,15)=DIV:1,1:0)" D SELECT^SDCLAS0 K DIC Q:X["^" + S Y=DT D DTS^SDUTL S SDTS=Y +OPT2 W !!,"Select 'As of' Date: ",SDTS," // " R X:DTIME Q:X["^" I X']"" S SDTS=DT G OVR + S %DT(0)=-DT,%DT="EPX" D ^%DT K %DT + I Y'>0 W !,*7,"A date must be entered here to get a 'snapshot' of the clinic's enrollment as of",!," this date. Date can not be in future." G OPT2 + S SDTS=+Y +OVR I SDSRT="C",SDSAV']"",SDIFN'="ALL",$S('$D(^SC(SDIFN,"I")):0,+^("I")=0:0,+^("I")>SDTS:0,+$P(^("I"),"^",2)'>SDTS&(+$P(^("I"),"^",2)'=0):0,1:1) W !,"Clinic ",$S(SDTS=DT:"is",1:"was")," inactive" W:SDTS
SDTS S:'X(1)!(X(1)>SDTS) Y(1)=^(0),SDENR=1 Q:SDENR + Q +SET1 S SDELIG=$S($D(^DPT(DFN,.36)):$P(^(.36),"^",1),1:""),SDELIG=$S($D(^DIC(8,+SDELIG,0)):SDELIG,1:""),SDELIG(1)=$S(SDELIG]"":$P(^(0),"^",5),1:""),SDZIP=$S($D(^DPT(DFN,.11)):$P(^(.11),"^",6),1:"") + Q +MT ; + S SDMT="*" Q:SDELIG(1)']"" I SDELIG(1)="N" S SDMT="N" Q + S SDMT=$$LST^DGMTU(DFN) I SDMT']"" S SDMT=$S(SDELIG'=6:"A",1:"X") Q + S:$P(SDMT,U,2)>SDTS SDMT=$$LST^DGMTU(DFN,SDTS) + I $P(SDMT,U,4)="P" S SDMT=$$PA^DGMTUTL($P(SDMT,U)),SDMT=$S('$D(SDMT):"U",SDMT="MT":"C",SDMT="GMT":"G",1:"U") + E S SDMT=$P(SDMT,U,4) + I SDMT="" S SDMT="X" + I SDMT="P" S SDMT="C" + I SDMT="R" S SDMT="U" + I SDMT="N" S SDMT="A" + D DOM^SDOPC4(DFN,SDTS_.9,.SDMT) I SDMT="X0" S SDMT="X" + K SDMT1 Q +CHECK S POP=0 I SDSRT="S",SDSTOP'="ALL",$P(^SC(SDIFN,0),"^",7)'=SDSTOP S POP=1 Q + I $S(DIV="":1,$P(^SC(SDIFN,0),"^",15)=DIV:1,1:0),$S('$D(^SC(SDIFN,"I")):1,+^("I")=0:1,+^("I")>DT:1,+$P(^("I"),"^",2)'>DT&(+$P(^("I"),"^",2)'=0):1,1:0) Q + S POP=1 Q +APART S SDZ="" F I=1:1 Q:$P(SDSAV,",",I)']"" S SDZ=$P(SDSAV,",",I) D:SDZ["--" SPLIT^SDCLAS0 I SDZ'["--" S:'$D(SDZ(+SDZ)) SDZ(+SDZ)="" + Q +INIT F I1="SDENR","SDACT" S I2="^UTILITY("_$J_","""_I1_""","_SDIFN_")",@I2=0 + Q diff --git a/r/SCHEDULING-SD-SC/SDCLAV0.m b/r/SCHEDULING-SD-SC/SDCLAV0.m index 82411d8e..9b8a25e5 100644 --- a/r/SCHEDULING-SD-SC/SDCLAV0.m +++ b/r/SCHEDULING-SD-SC/SDCLAV0.m @@ -1,48 +1,46 @@ -SDCLAV0 ;ALB/LDB - OUTPUT PATTERNS (cont.) ; 05 Mar 99 11:31 AM - ;;5.3;Scheduling;**184,439,490,517,529**;Aug 13, 1993;Build 3 - ;SD/517 CHANGED FOR LOOPS - I 'VAUTC S SDC=0 F S SDC=$O(VAUTC(SDC)) Q:'SDC S SDV=VAUTC(SDC) D:VAUTD!($D(VAUTD(+$P(^SC(SDC,0),"^",15))))!('$P(^(0),"^",15)&$D(VAUTD($P(^DG(43,1,"GL"),"^",3)))) S1 - I VAUTC S SDC=0 F S SDC=$O(^SC(SDC)) Q:'SDC I $P(^(SDC,0),"^",3)="C" D:VAUTD!($D(VAUTD(+$P(^(0),"^",15))))!('$P(^(0),"^",15)&$D(VAUTD($P(^DG(43,1,"GL"),"^",3)))) S1 - I $D(^UTILITY($J,"SDNMS")) D S2^SDCLAV1 - ;following line commented off per SD*529 - ;S DGTCH="CLINIC AVAILABILITY REPORT^CLINIC^PAGE#" D:$E(IOST,1,2)="P-" TP^DGUTL K SDBD,SDCI,SDED D END^SDCLAV Q - D END^SDCLAV Q -S1 S SD=^SC(SDC,0),D=$S($P(SD,"^",15):$P(SD,"^",15),1:$P(^DG(43,1,"GL"),"^",3)),SD5=0,SDNM=$P(SD,"^") - S $P(^UTILITY($J,"SDNMS",D,SDNM),"^",3)=SDC - Q -NM ;called by SDCLAV1 - SD/517 CHANGED FOR LOOP - S SDAP1=0 F S SDAP1=$O(^SC(SDC,"S",SDAP,1,SDAP1)) Q:'SDAP1 D NM1 - K M1,SDN1,SDN2,SDN3,SDC3,SDAP1 ; SD*5.3*439 added Kill of local vars - Q -NM1 I '$D(^SC(SDC,"S",SDAP,1,SDAP1,0)) N POP S POP=0 D CHECK,KILL Q ;added SD/517 - S SDN1=+^SC(SDC,"S",SDAP,1,SDAP1,0),M1=$P(^(0),"^",2),SDC3=$P(^(0),"^",9),SDN2=$P(^DPT(+SDN1,0),"^"),SDN3=$P(^(0),"^",9),SDN3=$S(SDN3="":"UNKNOWN",1:SDN3) I $D(SDCI) D NM2 Q - ; SD*5.3*439 added quit if clinic in "S" node not = to selected clinic - I '$D(SDCI),$D(^DPT(SDN1,"S",SDAP,0)),$P(^(0),"^",2)'["C",$P(^(0),"^",2)'="N",$P(^(0),"^",2)'="NA" Q:$P(^(0),U,1)'=SDC D NM2 Q - Q - ;SD*5.3*490 do not display appts prior to clinic start date -NM2 Q:$P(SDAP,".",1)<$O(^SC(SDC,"T",0)) ;SD*5.3*490 - S:$D(^DPT(SDN1,"S",SDAP,0)) ^UTILITY($J,"SDNMS",D,SDV,SDAP,SDN2,SDN3)=M1_$S(($P(^DPT(SDN1,"S",SDAP,0),"^",2)["C"):"^*",SDC3="C":"^*",($P(^(0),"^",2)="N"):"^**",($P(^(0),"^",2)="NA"):"^**",1:"") - S:$D(^DPT(SDN1,"S",SDAP,0)) $P(^UTILITY($J,"SDNMS",D,SDV,SDAP,SDN2,SDN3),"^",3)=$S($P(^DPT(SDN1,"S",SDAP,0),"^",7)=4:"***",1:"") - Q - ; -CHECK ;Added SD/517 - N SDIEN,NODE,NODE0,HDFN,HDNAM,HDSN,POP - S SDIEN=0,NODE="",HDAP1=SDAP1 - F S SDIEN=$O(^SCE("B",SDAP,SDIEN)) Q:'SDIEN D - .S NODE=^SCE(SDIEN,0) - .Q:$P(NODE,U,4)'=SDC - .S HDFN=$P(NODE,U,2),HDNAM=$P(^DPT(HDFN,0),U),HDSN=$P(^(0),U,9) - .Q:$D(^UTILITY($J,"SDNMS",D,SDV,SDAP,HDNAM,HDSN)) - .S POP=0 D CHECK1 Q:POP - .S SDN1=$P(NODE,U,2),SDN2=$P(^DPT(SDN1,0),U),SDN3=$P(^DPT(SDN1,0),U,9),M1="",SDC3="" - .D NM2 - Q - ; -CHECK1 ;Added SD/517 - S HDAP1=$O(^SC(SDC,"S",SDAP,1,HDAP1)) Q:'HDAP1 - Q:'$D(^SC(SDC,"S",SDAP,1,HDAP1,0)) S NODE0=^(0) - I $P(NODE0,U,1)=HDFN S POP=1 Q - Q - ; -KILL K SDIEN,NODE,NODE0,POP,HDFN,HDNAM,HDSN,HDAP1 ;added SD/517 - Q +SDCLAV0 ;ALB/LDB - OUTPUT PATTERNS (cont.) ; 05 Mar 99 11:31 AM + ;;5.3;Scheduling;**184,439,490,517**;Aug 13, 1993;Build 4 + ;SD/517 CHANGED FOR LOOPS + I 'VAUTC S SDC=0 F S SDC=$O(VAUTC(SDC)) Q:'SDC S SDV=VAUTC(SDC) D:VAUTD!($D(VAUTD(+$P(^SC(SDC,0),"^",15))))!('$P(^(0),"^",15)&$D(VAUTD($P(^DG(43,1,"GL"),"^",3)))) S1 + I VAUTC S SDC=0 F S SDC=$O(^SC(SDC)) Q:'SDC I $P(^(SDC,0),"^",3)="C" D:VAUTD!($D(VAUTD(+$P(^(0),"^",15))))!('$P(^(0),"^",15)&$D(VAUTD($P(^DG(43,1,"GL"),"^",3)))) S1 + I $D(^UTILITY($J,"SDNMS")) D S2^SDCLAV1 + S DGTCH="CLINIC AVAILABILITY REPORT^CLINIC^PAGE#" D:$E(IOST,1,2)="P-" TP^DGUTL K SDBD,SDCI,SDED D END^SDCLAV Q +S1 S SD=^SC(SDC,0),D=$S($P(SD,"^",15):$P(SD,"^",15),1:$P(^DG(43,1,"GL"),"^",3)),SD5=0,SDNM=$P(SD,"^") + S $P(^UTILITY($J,"SDNMS",D,SDNM),"^",3)=SDC + Q +NM ;called by SDCLAV1 - SD/517 CHANGED FOR LOOP + S SDAP1=0 F S SDAP1=$O(^SC(SDC,"S",SDAP,1,SDAP1)) Q:'SDAP1 D NM1 + K M1,SDN1,SDN2,SDN3,SDC3,SDAP1 ; SD*5.3*439 added Kill of local vars + Q +NM1 I '$D(^SC(SDC,"S",SDAP,1,SDAP1,0)) N POP S POP=0 D CHECK,KILL Q ;added SD/517 + S SDN1=+^SC(SDC,"S",SDAP,1,SDAP1,0),M1=$P(^(0),"^",2),SDC3=$P(^(0),"^",9),SDN2=$P(^DPT(+SDN1,0),"^"),SDN3=$P(^(0),"^",9),SDN3=$S(SDN3="":"UNKNOWN",1:SDN3) I $D(SDCI) D NM2 Q + ; SD*5.3*439 added quit if clinic in "S" node not = to selected clinic + I '$D(SDCI),$D(^DPT(SDN1,"S",SDAP,0)),$P(^(0),"^",2)'["C",$P(^(0),"^",2)'="N",$P(^(0),"^",2)'="NA" Q:$P(^(0),U,1)'=SDC D NM2 Q + Q + ;SD*5.3*490 do not display appts prior to clinic start date +NM2 Q:$P(SDAP,".",1)<$O(^SC(SDC,"T",0)) ;SD*5.3*490 + S:$D(^DPT(SDN1,"S",SDAP,0)) ^UTILITY($J,"SDNMS",D,SDV,SDAP,SDN2,SDN3)=M1_$S(($P(^DPT(SDN1,"S",SDAP,0),"^",2)["C"):"^*",SDC3="C":"^*",($P(^(0),"^",2)="N"):"^**",($P(^(0),"^",2)="NA"):"^**",1:"") + S:$D(^DPT(SDN1,"S",SDAP,0)) $P(^UTILITY($J,"SDNMS",D,SDV,SDAP,SDN2,SDN3),"^",3)=$S($P(^DPT(SDN1,"S",SDAP,0),"^",7)=4:"***",1:"") + Q + ; +CHECK ;Added SD/517 + N SDIEN,NODE,NODE0,HDFN,HDNAM,HDSN,POP + S SDIEN=0,NODE="",HDAP1=SDAP1 + F S SDIEN=$O(^SCE("B",SDAP,SDIEN)) Q:'SDIEN D + .S NODE=^SCE(SDIEN,0) + .Q:$P(NODE,U,4)'=SDC + .S HDFN=$P(NODE,U,2),HDNAM=$P(^DPT(HDFN,0),U),HDSN=$P(^(0),U,9) + .Q:$D(^UTILITY($J,"SDNMS",D,SDV,SDAP,HDNAM,HDSN)) + .S POP=0 D CHECK1 Q:POP + .S SDN1=$P(NODE,U,2),SDN2=$P(^DPT(SDN1,0),U),SDN3=$P(^DPT(SDN1,0),U,9),M1="",SDC3="" + .D NM2 + Q + ; +CHECK1 ;Added SD/517 + S HDAP1=$O(^SC(SDC,"S",SDAP,1,HDAP1)) Q:'HDAP1 + Q:'$D(^SC(SDC,"S",SDAP,1,HDAP1,0)) S NODE0=^(0) + I $P(NODE0,U,1)=HDFN S POP=1 Q + Q + ; +KILL K SDIEN,NODE,NODE0,POP,HDFN,HDNAM,HDSN,HDAP1 ;added SD/517 + Q diff --git a/r/SCHEDULING-SD-SC/SDCWL2.m b/r/SCHEDULING-SD-SC/SDCWL2.m index 8d7dfed1..198d6318 100644 --- a/r/SCHEDULING-SD-SC/SDCWL2.m +++ b/r/SCHEDULING-SD-SC/SDCWL2.m @@ -1,31 +1,31 @@ -SDCWL2 ;ALB/MLI - CONTINUATION OF CLINIC WORKLOAD REPORTS ; 07 Mar 99 6:41 PM - ;;5.3;Scheduling;**140,132,171,184,529**;Aug 13, 1993;Build 3 -PRO S SDAS=$S($P(^SC(I,"S",J,1,K,0),U,9)="C":"C",1:$P(^DPT(DFN,"S",J,0),U,2)) S SDP=$P(^DPT(DFN,"S",J,0),U,7) -PRO1 S SDP=$P(^DPT(DFN,"S",J,0),U,7) S:SDS="C" ^(SDN)=$S($D(^TMP($J,"CL",'$D(SDFL),SDN)):^(SDN),1:0) - I SDS="S" S:SDF1 ^(SDSC)=$S($D(^TMP($J,"SC",'$D(SDFL),SDSC)):^(SDSC),1:0) I SDF2 S ^(SDCR)=$S($D(^TMP($J,"SC",'$D(SDFL),SDCR)):^(SDCR),1:0) - S $P(^TMP($J,"CL",'$D(SDFL),SDN),"^")=1 I SDS="S" S:SDF1 $P(^TMP($J,"SC",'$D(SDFL),SDSC),"^")=1 I SDF2 S $P(^TMP($J,"SC",'$D(SDFL),SDCR),"^")=1 - I SDAS'["C",SDAS'="N",SDAS'="NA" S:SDS="C" $P(^(SDN),U,2)=$P(^TMP($J,"CL",'$D(SDFL),SDN),U,2)+1 I SDS="S" S:SDF1 $P(^(SDSC),U,2)=$P(^TMP($J,"SC",'$D(SDFL),SDSC),U,2)+1 I SDF2 S $P(^(SDCR),U,2)=$P(^TMP($J,"SC",'$D(SDFL),SDCR),U,2)+1 - I $D(SDFL) S:SDS="C" ^(SDN)=$S($D(^TMP($J,"CL",1,SDN)):^(SDN),1:0) I SDS="S" S:SDF1 ^(SDSC)=$S($D(^TMP($J,"SC",1,SDSC)):^(SDSC),1:0) S:SDF2 ^(SDCR)=$S($D(^TMP($J,"SC",1,SDCR)):^(SDCR),1:0) - Q:$D(SDFL)!(SDRT="B") S SDAPT=$S(SDF="D":J\1,1:J\100) S:'$D(^TMP($J,1,SDN,SDAPT)) (^(SDAPT,"CA"),^("NS"),^("IN"),^("OB"),^("UN"),^("SD"))=0 - S TIME=$E($P(J,".",2)_"0000",1,4),TIME=$E(TIME,1,2)_":"_$E(TIME,3,4) - S:SDNAM SDPN=$E($P(^DPT(DFN,0),U),1,20),SDSSN=$S($P(^(0),U,9)]"":$P(^(0),U,9),1:0),^TMP($J,1,SDN,SDAPT,"NM",SDPN,SDSSN,TIME,$S(SDAS]"":SDAS,SDOB:"OB",SDP=1:"S",SDP=3:"S",SDP=4:"U",1:" "))="" ;added SDP=1 SD*529 - K TIME I SDAS["C" S ^("CA")=^TMP($J,1,SDN,SDAPT,"CA")+1 Q - I SDAS="N"!(SDAS="NA") S ^("NS")=^TMP($J,1,SDN,SDAPT,"NS")+1 Q - I SDAS["I" S ^("IN")=^TMP($J,1,SDN,SDAPT,"IN")+1 Q - I SDOB S ^("OB")=^TMP($J,1,SDN,SDAPT,"OB")+1 Q - I SDP=4 S ^("UN")=^TMP($J,1,SDN,SDAPT,"UN")+1 Q - S ^("SD")=^TMP($J,1,SDN,SDAPT,"SD")+1 Q -PREV S SDBD=SDBD+.1,SDED=SDED-.9,SDBO=$TR($$FMTE^XLFDT(SDBD,"2FD")," ","0"),SDEO=$TR($$FMTE^XLFDT(SDED,"2FD")," ","0"),I=0,SDSUB=$S(SDS="C":"CL",1:"SC") D COMPHEAD - F I1=0:0 S I=$O(^TMP($J,SDSUB,1,I)) Q:I="" S SDCUR=+$P(^(I),"^",2),SDOLD=+$S($D(^TMP($J,SDSUB,0,I)):$P(^(I),"^",2),1:0) D:($Y>(IOSL-8)) EOP,COMPHEAD D COMPARE - D EOP Q -COMPHEAD S SDPG=SDPG+1 W @IOF,!?29,"CLINIC WORKLOAD REPORT",?71,"PAGE: ",$J(SDPG,3),!?22,"COMPARISON OF VISITS TO PREVIOUS YEAR",!?20,"FOR PERIOD COVERING: ",SDB1,"-",SDE1,!?26,"REPORT RUN ON: ",SDNOW,!! K Y S $P(Y,"_",81)="" W Y D BLANK - W !,"|",?25,"|",?29,"# OF VISITS",?43,"|",?47,"# OF VISITS",?61,"|",?64,"NET",?70,"|",?74,"%",?79,"|",!,"|",?7,$S(SDS="C":"Clinic",1:"Stop Code")," Name",?25,"|",SDB,"-",SDE,"|",SDBO,"-",SDEO,"| CHANGE | CHANGE |" D EOP,EOP,BLANK Q -COMPARE W !,"|",$S(SDS="C":$E(I,1,24),1:$J(I,15)),?25,"|",?31,$J(SDCUR,7),?43,"|",?49,$J(SDOLD,7),?61,"|" S X=SDCUR-SDOLD W $J($S(X>0:"+"_X,2:X),7,2),?70,"|",$S(SDOLD=0:" N/A",1:$J(X*100/SDOLD,7,2))," |" Q -EOP W !,"|" K Y S $P(Y,"_",25)="" W Y,"|",$E(Y,1,17),"|",$E(Y,1,17),"|",$E(Y,1,8),"|",$E(Y,1,8),"|" Q -BLANK W !,"|",?25,"|",?43,"|",?61,"|",?70,"|",?79,"|" Q -ADDON I 'SDALL&'$D(SDCL(SDSC)) Q - S J=SDOE,I=+SDOE0 - S DIV=$S($P(SDOE0,"^",11)]"":$P(SDOE0,"^",11),1:$O(^DG(40.8,0))),DFN=+$P(SDOE0,U,2) Q:'VAUTD&'$D(VAUTD(DIV)) - S $P(^TMP($J,"SC",'$D(SDFL),SDSC),"^")=1,$P(^(SDSC),"^",2)=$P(^(SDSC),"^",2)+1 Q:(SDRT="B") S ^("{")=$S($D(^(SDSC,"{")):^("{")+1,1:1),SDAPT=$S(SDF="D":I\1,1:I\100) - Q:$D(SDFL) S ^(SDAPT)=$S($D(^TMP($J,"SC",SDSC,"{",SDAPT)):^(SDAPT)+1,1:1) - Q:'SDNAM S SDNM=$P(^DPT(DFN,0),U),SDSSN=$S($P(^(0),U,9)]"":$P(^(0),U,9),1:0),^TMP($J,"SC",SDSC,"{",SDAPT,SDNM,SDSSN,I,J)="" Q +SDCWL2 ;ALB/MLI - CONTINUATION OF CLINIC WORKLOAD REPORTS ; 07 Mar 99 6:41 PM + ;;5.3;Scheduling;**140,132,171,184**;Aug 13, 1993 +PRO S SDAS=$S($P(^SC(I,"S",J,1,K,0),U,9)="C":"C",1:$P(^DPT(DFN,"S",J,0),U,2)) S SDP=$P(^DPT(DFN,"S",J,0),U,7) +PRO1 S SDP=$P(^DPT(DFN,"S",J,0),U,7) S:SDS="C" ^(SDN)=$S($D(^TMP($J,"CL",'$D(SDFL),SDN)):^(SDN),1:0) + I SDS="S" S:SDF1 ^(SDSC)=$S($D(^TMP($J,"SC",'$D(SDFL),SDSC)):^(SDSC),1:0) I SDF2 S ^(SDCR)=$S($D(^TMP($J,"SC",'$D(SDFL),SDCR)):^(SDCR),1:0) + S $P(^TMP($J,"CL",'$D(SDFL),SDN),"^")=1 I SDS="S" S:SDF1 $P(^TMP($J,"SC",'$D(SDFL),SDSC),"^")=1 I SDF2 S $P(^TMP($J,"SC",'$D(SDFL),SDCR),"^")=1 + I SDAS'["C",SDAS'="N",SDAS'="NA" S:SDS="C" $P(^(SDN),U,2)=$P(^TMP($J,"CL",'$D(SDFL),SDN),U,2)+1 I SDS="S" S:SDF1 $P(^(SDSC),U,2)=$P(^TMP($J,"SC",'$D(SDFL),SDSC),U,2)+1 I SDF2 S $P(^(SDCR),U,2)=$P(^TMP($J,"SC",'$D(SDFL),SDCR),U,2)+1 + I $D(SDFL) S:SDS="C" ^(SDN)=$S($D(^TMP($J,"CL",1,SDN)):^(SDN),1:0) I SDS="S" S:SDF1 ^(SDSC)=$S($D(^TMP($J,"SC",1,SDSC)):^(SDSC),1:0) S:SDF2 ^(SDCR)=$S($D(^TMP($J,"SC",1,SDCR)):^(SDCR),1:0) + Q:$D(SDFL)!(SDRT="B") S SDAPT=$S(SDF="D":J\1,1:J\100) S:'$D(^TMP($J,1,SDN,SDAPT)) (^(SDAPT,"CA"),^("NS"),^("IN"),^("OB"),^("UN"),^("SD"))=0 + S TIME=$E($P(J,".",2)_"0000",1,4),TIME=$E(TIME,1,2)_":"_$E(TIME,3,4) + S:SDNAM SDPN=$E($P(^DPT(DFN,0),U),1,20),SDSSN=$S($P(^(0),U,9)]"":$P(^(0),U,9),1:0),^TMP($J,1,SDN,SDAPT,"NM",SDPN,SDSSN,TIME,$S(SDAS]"":SDAS,SDOB:"OB",SDP=3:"S",SDP=4:"U",1:" "))="" + K TIME I SDAS["C" S ^("CA")=^TMP($J,1,SDN,SDAPT,"CA")+1 Q + I SDAS="N"!(SDAS="NA") S ^("NS")=^TMP($J,1,SDN,SDAPT,"NS")+1 Q + I SDAS["I" S ^("IN")=^TMP($J,1,SDN,SDAPT,"IN")+1 Q + I SDOB S ^("OB")=^TMP($J,1,SDN,SDAPT,"OB")+1 Q + I SDP=4 S ^("UN")=^TMP($J,1,SDN,SDAPT,"UN")+1 Q + S ^("SD")=^TMP($J,1,SDN,SDAPT,"SD")+1 Q +PREV S SDBD=SDBD+.1,SDED=SDED-.9,SDBO=$TR($$FMTE^XLFDT(SDBD,"2FD")," ","0"),SDEO=$TR($$FMTE^XLFDT(SDED,"2FD")," ","0"),I=0,SDSUB=$S(SDS="C":"CL",1:"SC") D COMPHEAD + F I1=0:0 S I=$O(^TMP($J,SDSUB,1,I)) Q:I="" S SDCUR=+$P(^(I),"^",2),SDOLD=+$S($D(^TMP($J,SDSUB,0,I)):$P(^(I),"^",2),1:0) D:($Y>(IOSL-8)) EOP,COMPHEAD D COMPARE + D EOP Q +COMPHEAD S SDPG=SDPG+1 W @IOF,!?29,"CLINIC WORKLOAD REPORT",?71,"PAGE: ",$J(SDPG,3),!?22,"COMPARISON OF VISITS TO PREVIOUS YEAR",!?20,"FOR PERIOD COVERING: ",SDB1,"-",SDE1,!?26,"REPORT RUN ON: ",SDNOW,!! K Y S $P(Y,"_",81)="" W Y D BLANK + W !,"|",?25,"|",?29,"# OF VISITS",?43,"|",?47,"# OF VISITS",?61,"|",?64,"NET",?70,"|",?74,"%",?79,"|",!,"|",?7,$S(SDS="C":"Clinic",1:"Stop Code")," Name",?25,"|",SDB,"-",SDE,"|",SDBO,"-",SDEO,"| CHANGE | CHANGE |" D EOP,EOP,BLANK Q +COMPARE W !,"|",$S(SDS="C":$E(I,1,24),1:$J(I,15)),?25,"|",?31,$J(SDCUR,7),?43,"|",?49,$J(SDOLD,7),?61,"|" S X=SDCUR-SDOLD W $J($S(X>0:"+"_X,2:X),7,2),?70,"|",$S(SDOLD=0:" N/A",1:$J(X*100/SDOLD,7,2))," |" Q +EOP W !,"|" K Y S $P(Y,"_",25)="" W Y,"|",$E(Y,1,17),"|",$E(Y,1,17),"|",$E(Y,1,8),"|",$E(Y,1,8),"|" Q +BLANK W !,"|",?25,"|",?43,"|",?61,"|",?70,"|",?79,"|" Q +ADDON I 'SDALL&'$D(SDCL(SDSC)) Q + S J=SDOE,I=+SDOE0 + S DIV=$S($P(SDOE0,"^",11)]"":$P(SDOE0,"^",11),1:$O(^DG(40.8,0))),DFN=+$P(SDOE0,U,2) Q:'VAUTD&'$D(VAUTD(DIV)) + S $P(^TMP($J,"SC",'$D(SDFL),SDSC),"^")=1,$P(^(SDSC),"^",2)=$P(^(SDSC),"^",2)+1 Q:(SDRT="B") S ^("{")=$S($D(^(SDSC,"{")):^("{")+1,1:1),SDAPT=$S(SDF="D":I\1,1:I\100) + Q:$D(SDFL) S ^(SDAPT)=$S($D(^TMP($J,"SC",SDSC,"{",SDAPT)):^(SDAPT)+1,1:1) + Q:'SDNAM S SDNM=$P(^DPT(DFN,0),U),SDSSN=$S($P(^(0),U,9)]"":$P(^(0),U,9),1:0),^TMP($J,"SC",SDSC,"{",SDAPT,SDNM,SDSSN,I,J)="" Q diff --git a/r/SCHEDULING-SD-SC/SDD0.m b/r/SCHEDULING-SD-SC/SDD0.m index eb191bb4..8a960fef 100644 --- a/r/SCHEDULING-SD-SC/SDD0.m +++ b/r/SCHEDULING-SD-SC/SDD0.m @@ -1,41 +1,41 @@ -SDD0 ;SF/GFT,ALB/BOK,JSH,LDB - REMAP A CLINIC ; 26 JAN 84 3:00 pm - ;;5.3;Scheduling;**167,401,529**;Aug 13, 1993;Build 3 -SETX ; - N SDDIV - S SDDIV=$P($G(SD0),"^",15) Q:SDDIV="" - I '$D(VAUTD(SDDIV)),VAUTD=0 Q - Q:'$D(^SC(SC,"SL")) S SDSL=^("SL"),SL=+^("SL"),X=$P(SDSL,U,3),STARTDAY=$S($L(X):X,1:8),X=$P(SDSL,U,6),HSI=$S('X:4,X<3:8/X,1:2),SI=$S(X:X,1:4),SDSI=SI - S:SI=1 SI=4 S:SI=2 SI=4 S SDSOH=$S($P(SDSL,U,8)']"":0,1:1) - K SDIN,SDRE,SDRE1 N SDNODE I $D(^SC(SC,"I")) S SDIN=+^("I"),SDRE=+$P(^("I"),"^",2),Y=SDRE D DTS^SDUTL S SDRE1=Y - F DATE=$$FMADD^XLFDT(SDBD,-1):0 S X1=DATE,X2=1 N X D C^%DTC S DATE=X S SDNODE=$D(^SC(SC,"ST",DATE)) Q:DATE'>0!(DATE>SDED) I $S('$D(SDIN):1,'SDIN:1,SDIN>DATE:1,SDRE'>DATE&(SDRE):1,1:0) K SM,SDHOL D CHECK ;changed 1st part of For loop SD*529 - Q -CHECK S X=DATE D DW^%DTC S DAY=$P("SUN^MON^TUES^WEDNES^THURS^FRI^SATUR",U,Y+1),DOW=Y - D APPT I $D(^SC(SC,"ST",DATE,1)),^(1)'[$E(DAY,1,2)&(^(1)["]") S MSG="Bogus clinic day"_$S(SDAPPT:"- Appts!",1:"") D PRNT - I $D(^SC(SC,"ST",DATE,1)),^(1)["CANCEL"!($E(^(1),$F(^(1),"["),999)?."X") S MSG="Cancelled" D PRNT Q - I $D(^HOLIDAY(DATE,0)),'SDSOH S SDHOL=1,X=$P(^(0),U,2) G HOLIDAY:'SDAPPT,Z:SDAPPT - K ^SC(SC,"ST",DATE) S SS=+$O(^SC(SC,"T"_DOW,DATE)),SB=STARTDAY-1/100,STR="{}&%?#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz" - I $D(^SC(SC,"OST",DATE,1)),^(1)]"" S (X,DR)=DATE D DOW^SDM0 S DOW=Y,SM=^SC(SC,"OST",DATE,1),SS=0 G:'SDAPPT OVR G I - G Z:'$D(^SC(SC,"T"_DOW,SS,1)) I ^(1)="" S MSG="no master pattern for this day" D:SDNODE PRNT Q - S DH=^(1),X=DATE G FIX ;NAKED REFERENCE ^SC(IFN,"T"_DOW,DATE,1) -HOLIDAY S ^SC(SC,"ST",DATE,1)=" "_$E(DATE,6,7)_" "_X,^(0)=DATE -Z S MSG=$S($D(SDHOL)&SDAPPT:"- Appts!",'SDSOH&$D(SDHOL):"- Inserted",1:"") I MSG]"" S MSG=X_MSG D PRNT - Q -END K %,%DT,DATE,DAY,DH,DOW,DR,DR1,HSI,I,P,POP,S,SB,SC,SDAPPT,SDAPPT1,SDBD,SDNM,SDED,SDHOL,SD0,SDIN,SDRE,SDRE1,SDSAVX,SDSL,SDSOH,SI,SM,SS,SD,SCI,SCC,ST,STARTDAY,STR,X,MSG,Y,YP,PG,DGVAR,DGPGM,VAUTD,VAUTC,SDU,BEGDATE,ENDDATE D CLOSE^DGUTQ Q -FIX ;DH=PATTERN X=DATE - D SM G:'SDAPPT OVR -I S I=DR#1-SB*100,I=I#1*SI\.6+(I\1*SI)*2,S=$E(SM,I,999),SM=$E(SM,1,I-1) - I $D(^SC(SC,"S",DR,"MES")) D CAN S X=SDSAVX K SDSAVX S DR=+$O(^SC(SC,"S",DR)) G:DR\1=X I G OVR - F Y=0:0 S Y=$O(^SC(SC,"S",DR,1,Y)) Q:Y'>0 I $P(^(Y,0),"^",9)'["C" S SDSL=$P(^(0),U,2)/SL*(SL\(60/SDSI))*HSI-HSI F I=0:HSI:SDSL S ST=$E(S,I+2) S:ST="" ST=" " S S=$E(S,1,I+2-1)_$E(STR,$F(STR,ST)-2)_$E(S,I+3,999) - S SM=SM_S,DR=$O(^SC(SC,"S",DR)) I DR\1=X G I -OVR I $L(SM)>SM S ^SC(SC,"ST",X,0)=X,^(1)=SM S:SS'>0 ^(9)=SC - G Z -SM S SM=$P("SU^MO^TU^WE^TH^FR^SA",U,DOW+1)_" "_$E(X,6,7)_$J("",SI+SI-6)_DH_$J("",64-$L(DH)) Q -APPT S DR=+$O(^SC(SC,"S",DATE)),SDAPPT=0 I DR>(DATE_.9) S DR=DATE Q - F DR1=DATE:0 S DR1=$O(^SC(SC,"S",DR1)) Q:DR1'>0!(DR1>(DATE+1))!(SDAPPT) S:$D(^(DR1,"MES")) SDAPPT=1 F SDAPPT1=0:0 S SDAPPT1=$O(^SC(SC,"S",DR1,1,SDAPPT1)) Q:SDAPPT1'>0 I $D(^(SDAPPT1,0)) S SDAPPT=$S($P(^(0),"^",9)="C":0,1:1) - Q -CAN S SDSAVX=X Q:'$D(^SC(SC,"SDCAN",DR,0)) S X=$E($P(DR,".",2)_"0000",1,4),I=SM_S D TT S ST=%,X=$P(^SC(SC,"SDCAN",DR,0),"^",2) D TT S I=I_$J("",%-$L(I)),Y="" - F X=0:2:% S S=$E(I,X+SI+SI),P=$S(X(IOSL-4) ESC^SDD W !,$E(SDNM,1,25),?27,$E(DAY,1,3)_" " S Y=DATE D DT^DIO2 W ?45,MSG Q -ESC S SDU=0 I $E(IOST,1,2)="C-" W *7 R ESC:DTIME S:U=ESC SDU=1 +SDD0 ;SF/GFT,ALB/BOK,JSH,LDB - REMAP A CLINIC ; 26 JAN 84 3:00 pm + ;;5.3;Scheduling;**167,401**;Aug 13, 1993 +SETX ; + N SDDIV + S SDDIV=$P($G(SD0),"^",15) Q:SDDIV="" + I '$D(VAUTD(SDDIV)),VAUTD=0 Q + Q:'$D(^SC(SC,"SL")) S SDSL=^("SL"),SL=+^("SL"),X=$P(SDSL,U,3),STARTDAY=$S($L(X):X,1:8),X=$P(SDSL,U,6),HSI=$S('X:4,X<3:8/X,1:2),SI=$S(X:X,1:4),SDSI=SI + S:SI=1 SI=4 S:SI=2 SI=4 S SDSOH=$S($P(SDSL,U,8)']"":0,1:1) + K SDIN,SDRE,SDRE1 N SDNODE I $D(^SC(SC,"I")) S SDIN=+^("I"),SDRE=+$P(^("I"),"^",2),Y=SDRE D DTS^SDUTL S SDRE1=Y + F DATE=SDBD-1:0 S X1=DATE,X2=1 N X D C^%DTC S DATE=X S SDNODE=$D(^SC(SC,"ST",DATE)) Q:DATE'>0!(DATE>SDED) I $S('$D(SDIN):1,'SDIN:1,SDIN>DATE:1,SDRE'>DATE&(SDRE):1,1:0) K SM,SDHOL D CHECK + Q +CHECK S X=DATE D DW^%DTC S DAY=$P("SUN^MON^TUES^WEDNES^THURS^FRI^SATUR",U,Y+1),DOW=Y + D APPT I $D(^SC(SC,"ST",DATE,1)),^(1)'[$E(DAY,1,2)&(^(1)["]") S MSG="Bogus clinic day"_$S(SDAPPT:"- Appts!",1:"") D PRNT + I $D(^SC(SC,"ST",DATE,1)),^(1)["CANCEL"!($E(^(1),$F(^(1),"["),999)?."X") S MSG="Cancelled" D PRNT Q + I $D(^HOLIDAY(DATE,0)),'SDSOH S SDHOL=1,X=$P(^(0),U,2) G HOLIDAY:'SDAPPT,Z:SDAPPT + K ^SC(SC,"ST",DATE) S SS=+$O(^SC(SC,"T"_DOW,DATE)),SB=STARTDAY-1/100,STR="{}&%?#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz" + I $D(^SC(SC,"OST",DATE,1)),^(1)]"" S (X,DR)=DATE D DOW^SDM0 S DOW=Y,SM=^SC(SC,"OST",DATE,1),SS=0 G:'SDAPPT OVR G I + G Z:'$D(^SC(SC,"T"_DOW,SS,1)) I ^(1)="" S MSG="no master pattern for this day" D:SDNODE PRNT Q + S DH=^(1),X=DATE G FIX ;NAKED REFERENCE ^SC(IFN,"T"_DOW,DATE,1) +HOLIDAY S ^SC(SC,"ST",DATE,1)=" "_$E(DATE,6,7)_" "_X,^(0)=DATE +Z S MSG=$S($D(SDHOL)&SDAPPT:"- Appts!",'SDSOH&$D(SDHOL):"- Inserted",1:"") I MSG]"" S MSG=X_MSG D PRNT + Q +END K %,%DT,DATE,DAY,DH,DOW,DR,DR1,HSI,I,P,POP,S,SB,SC,SDAPPT,SDAPPT1,SDBD,SDNM,SDED,SDHOL,SD0,SDIN,SDRE,SDRE1,SDSAVX,SDSL,SDSOH,SI,SM,SS,SD,SCI,SCC,ST,STARTDAY,STR,X,MSG,Y,YP,PG,DGVAR,DGPGM,VAUTD,VAUTC,SDU,BEGDATE,ENDDATE D CLOSE^DGUTQ Q +FIX ;DH=PATTERN X=DATE + D SM G:'SDAPPT OVR +I S I=DR#1-SB*100,I=I#1*SI\.6+(I\1*SI)*2,S=$E(SM,I,999),SM=$E(SM,1,I-1) + I $D(^SC(SC,"S",DR,"MES")) D CAN S X=SDSAVX K SDSAVX S DR=+$O(^SC(SC,"S",DR)) G:DR\1=X I G OVR + F Y=0:0 S Y=$O(^SC(SC,"S",DR,1,Y)) Q:Y'>0 I $P(^(Y,0),"^",9)'["C" S SDSL=$P(^(0),U,2)/SL*(SL\(60/SDSI))*HSI-HSI F I=0:HSI:SDSL S ST=$E(S,I+2) S:ST="" ST=" " S S=$E(S,1,I+2-1)_$E(STR,$F(STR,ST)-2)_$E(S,I+3,999) + S SM=SM_S,DR=$O(^SC(SC,"S",DR)) I DR\1=X G I +OVR I $L(SM)>SM S ^SC(SC,"ST",X,0)=X,^(1)=SM S:SS'>0 ^(9)=SC + G Z +SM S SM=$P("SU^MO^TU^WE^TH^FR^SA",U,DOW+1)_" "_$E(X,6,7)_$J("",SI+SI-6)_DH_$J("",64-$L(DH)) Q +APPT S DR=+$O(^SC(SC,"S",DATE)),SDAPPT=0 I DR>(DATE_.9) S DR=DATE Q + F DR1=DATE:0 S DR1=$O(^SC(SC,"S",DR1)) Q:DR1'>0!(DR1>(DATE+1))!(SDAPPT) S:$D(^(DR1,"MES")) SDAPPT=1 F SDAPPT1=0:0 S SDAPPT1=$O(^SC(SC,"S",DR1,1,SDAPPT1)) Q:SDAPPT1'>0 I $D(^(SDAPPT1,0)) S SDAPPT=$S($P(^(0),"^",9)="C":0,1:1) + Q +CAN S SDSAVX=X Q:'$D(^SC(SC,"SDCAN",DR,0)) S X=$E($P(DR,".",2)_"0000",1,4),I=SM_S D TT S ST=%,X=$P(^SC(SC,"SDCAN",DR,0),"^",2) D TT S I=I_$J("",%-$L(I)),Y="" + F X=0:2:% S S=$E(I,X+SI+SI),P=$S(X(IOSL-4) ESC^SDD W !,$E(SDNM,1,25),?27,$E(DAY,1,3)_" " S Y=DATE D DT^DIO2 W ?45,MSG Q +ESC S SDU=0 I $E(IOST,1,2)="C-" W *7 R ESC:DTIME S:U=ESC SDU=1 diff --git a/r/SCHEDULING-SD-SC/SDLT.m b/r/SCHEDULING-SD-SC/SDLT.m index aa9ee825..9360238a 100644 --- a/r/SCHEDULING-SD-SC/SDLT.m +++ b/r/SCHEDULING-SD-SC/SDLT.m @@ -1,83 +1,81 @@ -SDLT ;ALB/LDB - CANCELLATION LETTERS ; 14 Feb 2003 - ;;5.3;Scheduling;**185,213,281,330,398,523**;Aug 13, 1993;Build 6 - ; - ;************************************************************************** - ; MODIFICATIONS - ; - ; DATE PATCH DEVELOPER DESCRIPTION OF CHANGES - ; -------- ---------- --------- ---------------------------------------- - ; 02/14/03 SD*5.3*281 SAUNDERS Print letters to confidential address if - ; requested - ; 12/2/03 SD*5.3*330 LUNDEN Remove form feed from PRT+0 - ; - ;************************************************************************** - ; - ;WRITE GREETING AND OPENING TEXT OF LETTER -PRT S DFN=$P(A,U,1) ;SD*523 - I $D(SDNOSH) I $D(^DPT(DFN,.1)) S POP=1 Q:POP ;SD/523 - S Y=DT D DTS^SDUTL - I +$G(SDFIRST)=0 W @IOF ;SD*5.3*330 Form feed only after letter #1 - K SDFIRST - ;S SDFIRST=0 - W !,?65,Y,!,?65,$$LAST4(A),!!!! - I 'SDFORM W !!!!! D ADDR W !!!! -W1 W !,"Dear ",$S($P(^DPT(+A,0),"^",2)="M":"Mr. ",1:"Ms. ") - N DPTNAME - S DPTNAME("FILE")=2,DPTNAME("FIELD")=".01",DPTNAME("IENS")=(+A)_"," - S X=$$NAMEFMT^XLFNAME(.DPTNAME,"G","M") W X,"," - W !! K ^UTILITY($J,"W"),DIWF,DIWR,DIWF S DIWL=1,DIWF="C80WN" F Z0=0:0 S Z0=$O(^VA(407.5,SDLET,1,Z0)) Q:Z0'>0 S X=^(Z0,0) D ^DIWP - D ^DIWW K ^UTILITY($J,"W") Q -WRAPP ;WRITE APPOINTMENT INFORMATION - S:$D(SC)&'$D(SDC) SDC=SC S SDCL=$P(^SC(+SDC,0),"^",1),SDCL=SDCL_" Clinic" D FORM - S SDX1=$S($D(SDX):SDX,1:X) S:$D(SDS) S=SDS F B=3,4,5 I $P(S,"^",B)]"" S SDCL=$S(B=3:"LAB",B=4:"XRAY",1:"EKG"),SDX=$P(S,"^",B) D FORM - S (SDX,X)=SDX1 Q -FORM S:$D(SDX) X=SDX S SDHX=X D DW^%DTC S DOW=X,X=SDHX X ^DD("FUNC",2,1) S SDT0=X,SDDAT=$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",$E(SDHX,4,5))_" "_+$E(SDHX,6,7)_", "_(1700+$E(SDHX,1,3)) W !?4,DOW,?14,$J(SDDAT,12) - W ?27,$J(SDT0,8)," ",SDCL I $D(SDLT)&($Y>(IOSL-8)) W @IOF - Q -REST ;WRITE THE REMAINDER OF LETTER - I SDLET W !?12 K ^UTILITY($J,"W"),DIWL,DIWR,DIWF S DIWL=1,DIWF="C80WN" F Z5=0:0 S Z5=$O(^VA(407.5,SDLET,2,Z5)) Q:Z5'>0 S X=^(Z5,0) D ^DIWP - D ^DIWW K ^UTILITY($J,"W") Q:'SDFORM - F I=$Y:1:IOSL-12 W ! - D ADDR Q -ADDR K VAHOW S DFN=+A W !?12,$$FML^DGNFUNC(DFN) S VAHOW=2 - I $D(^DG(43,1,"BT")),'$P(^("BT"),"^",3) S VAPA("P")="" - S X1=DT,X2=5 D C^%DTC I '$D(VAPA("P")) S (VATEST("ADD",9),VATEST("ADD",10))=X - D ADD^VADPT D - .;CHANGE STATE TO ABBR. - .N SDIENS,X - .I $D(^UTILITY("VAPA",$J,5)) S SDIENS=+^UTILITY("VAPA",$J,5)_",",X=$$GET1^DIQ(5,SDIENS,1),$P(^UTILITY("VAPA",$J,5),U,2)=X - .K SDIENS Q - N SDCCACT1,SDCCACT2 - S SDCCACT1=^UTILITY("VAPA",$J,12),SDCCACT2=$P($G(^UTILITY("VAPA",$J,22,2)),"^",3) - ;if confidential address is not active for scheduling/appointment letters, print to regular address - I ($G(SDCCACT1)=0)!($G(SDCCACT2)'="Y") D - .F LL=1:1:4 W:^UTILITY("VAPA",$J,LL)]"" !,?12,^UTILITY("VAPA",$J,LL) - .W:^UTILITY("VAPA",$J,4)']"" ! I ^UTILITY("VAPA",$J,5)]"" W ", ",$P(^UTILITY("VAPA",$J,5),"^",2) - .I ^UTILITY("VAPA",$J,11)]"" W " ",$P(^UTILITY("VAPA",$J,11),U,2) - ;if confidential address is active for scheduling/appointment letters, print to confidential address - I $G(SDCCACT1)=1,$G(SDCCACT2)="Y" D - .F LL=13:1:16 W:^UTILITY("VAPA",$J,LL)]"" !,?12,^UTILITY("VAPA",$J,LL) - .W:^UTILITY("VAPA",$J,16)']"" ! I ^UTILITY("VAPA",$J,17)]"" W ", ",$P(^UTILITY("VAPA",$J,17),"^",2) - .I ^UTILITY("VAPA",$J,18)]"" W " ",$P(^UTILITY("VAPA",$J,18),U,2) - W ! D KVAR^VADPT Q - ; - ; -LAST4(DFN) ;Return patient "last four" - N SDX - S SDX=$G(^DPT(+DFN,0)) - Q $E(SDX)_$E($P(SDX,U,9),6,9) - ; -BADADD ;Print patients with a Bad Address Indicator - I '$D(^TMP($J,"BADADD")) Q - N SDHDR,SDHDR1 - W @IOF,$TR($J("",IOM)," ","*") - S SDHDR="BAD ADDRESS INDICATOR LIST" W !,?(IOM-$L(SDHDR)/2),SDHDR,! - S SDHDR1="** THE LETTER FOR THESE PATIENT(S) DID NOT PRINT DUE TO A BAD ADDRESS INDICATOR." - W !,"Last 4",!,"of SSN",?10,"Patient Name",! - W $TR($J("",IOM)," ","*") - N SDNAM,SDDFN - S SDNAM="" F S SDNAM=$O(^TMP($J,"BADADD",SDNAM)) Q:SDNAM="" D - . S SDDFN=0 F S SDDFN=$O(^TMP($J,"BADADD",SDNAM,SDDFN)) Q:'SDDFN D - . . W !,$$LAST4(SDDFN),?10,SDNAM - W !!,SDHDR1 - Q +SDLT ;ALB/LDB - CANCELLATION LETTERS ; 14 Feb 2003 + ;;5.3;Scheduling;**185,213,281,330,398**;Aug 13, 1993 + ; + ;************************************************************************** + ; MODIFICATIONS + ; + ; DATE PATCH DEVELOPER DESCRIPTION OF CHANGES + ; -------- ---------- --------- ---------------------------------------- + ; 02/14/03 SD*5.3*281 SAUNDERS Print letters to confidential address if + ; requested + ; 12/2/03 SD*5.3*330 LUNDEN Remove form feed from PRT+0 + ; + ;************************************************************************** + ; + ;WRITE GREETING AND OPENING TEXT OF LETTER +PRT S Y=DT D DTS^SDUTL + I +$G(SDFIRST)=0 W @IOF ;SD*5.3*330 Form feed only after letter #1 + K SDFIRST + ;S SDFIRST=0 + W !,?65,Y,!,?65,$$LAST4(A),!!!! + I 'SDFORM W !!!!! D ADDR W !!!! +W1 W !,"Dear ",$S($P(^DPT(+A,0),"^",2)="M":"Mr. ",1:"Ms. ") + N DPTNAME + S DPTNAME("FILE")=2,DPTNAME("FIELD")=".01",DPTNAME("IENS")=(+A)_"," + S X=$$NAMEFMT^XLFNAME(.DPTNAME,"G","M") W X,"," + W !! K ^UTILITY($J,"W"),DIWF,DIWR,DIWF S DIWL=1,DIWF="C80WN" F Z0=0:0 S Z0=$O(^VA(407.5,SDLET,1,Z0)) Q:Z0'>0 S X=^(Z0,0) D ^DIWP + D ^DIWW K ^UTILITY($J,"W") Q +WRAPP ;WRITE APPOINTMENT INFORMATION + S:$D(SC)&'$D(SDC) SDC=SC S SDCL=$P(^SC(+SDC,0),"^",1),SDCL=SDCL_" Clinic" D FORM + S SDX1=$S($D(SDX):SDX,1:X) S:$D(SDS) S=SDS F B=3,4,5 I $P(S,"^",B)]"" S SDCL=$S(B=3:"LAB",B=4:"XRAY",1:"EKG"),SDX=$P(S,"^",B) D FORM + S (SDX,X)=SDX1 Q +FORM S:$D(SDX) X=SDX S SDHX=X D DW^%DTC S DOW=X,X=SDHX X ^DD("FUNC",2,1) S SDT0=X,SDDAT=$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",$E(SDHX,4,5))_" "_+$E(SDHX,6,7)_", "_(1700+$E(SDHX,1,3)) W !?4,DOW,?14,$J(SDDAT,12) + W ?27,$J(SDT0,8)," ",SDCL I $D(SDLT)&($Y>(IOSL-8)) W @IOF + Q +REST ;WRITE THE REMAINDER OF LETTER + I SDLET W !?12 K ^UTILITY($J,"W"),DIWL,DIWR,DIWF S DIWL=1,DIWF="C80WN" F Z5=0:0 S Z5=$O(^VA(407.5,SDLET,2,Z5)) Q:Z5'>0 S X=^(Z5,0) D ^DIWP + D ^DIWW K ^UTILITY($J,"W") Q:'SDFORM + F I=$Y:1:IOSL-12 W ! + D ADDR Q +ADDR K VAHOW S DFN=+A W !?12,$$FML^DGNFUNC(DFN) S VAHOW=2 + I $D(^DG(43,1,"BT")),'$P(^("BT"),"^",3) S VAPA("P")="" + S X1=DT,X2=5 D C^%DTC I '$D(VAPA("P")) S (VATEST("ADD",9),VATEST("ADD",10))=X + D ADD^VADPT D + .;CHANGE STATE TO ABBR. + .N SDIENS,X + .I $D(^UTILITY("VAPA",$J,5)) S SDIENS=+^UTILITY("VAPA",$J,5)_",",X=$$GET1^DIQ(5,SDIENS,1),$P(^UTILITY("VAPA",$J,5),U,2)=X + .K SDIENS Q + N SDCCACT1,SDCCACT2 + S SDCCACT1=^UTILITY("VAPA",$J,12),SDCCACT2=$P($G(^UTILITY("VAPA",$J,22,2)),"^",3) + ;if confidential address is not active for scheduling/appointment letters, print to regular address + I ($G(SDCCACT1)=0)!($G(SDCCACT2)'="Y") D + .F LL=1:1:4 W:^UTILITY("VAPA",$J,LL)]"" !,?12,^UTILITY("VAPA",$J,LL) + .W:^UTILITY("VAPA",$J,4)']"" ! I ^UTILITY("VAPA",$J,5)]"" W ", ",$P(^UTILITY("VAPA",$J,5),"^",2) + .I ^UTILITY("VAPA",$J,11)]"" W " ",$P(^UTILITY("VAPA",$J,11),U,2) + ;if confidential address is active for scheduling/appointment letters, print to confidential address + I $G(SDCCACT1)=1,$G(SDCCACT2)="Y" D + .F LL=13:1:16 W:^UTILITY("VAPA",$J,LL)]"" !,?12,^UTILITY("VAPA",$J,LL) + .W:^UTILITY("VAPA",$J,16)']"" ! I ^UTILITY("VAPA",$J,17)]"" W ", ",$P(^UTILITY("VAPA",$J,17),"^",2) + .I ^UTILITY("VAPA",$J,18)]"" W " ",$P(^UTILITY("VAPA",$J,18),U,2) + W ! D KVAR^VADPT Q + ; + ; +LAST4(DFN) ;Return patient "last four" + N SDX + S SDX=$G(^DPT(+DFN,0)) + Q $E(SDX)_$E($P(SDX,U,9),6,9) + ; +BADADD ;Print patients with a Bad Address Indicator + I '$D(^TMP($J,"BADADD")) Q + N SDHDR,SDHDR1 + W @IOF,$TR($J("",IOM)," ","*") + S SDHDR="BAD ADDRESS INDICATOR LIST" W !,?(IOM-$L(SDHDR)/2),SDHDR,! + S SDHDR1="** THE LETTER FOR THESE PATIENT(S) DID NOT PRINT DUE TO A BAD ADDRESS INDICATOR." + W !,"Last 4",!,"of SSN",?10,"Patient Name",! + W $TR($J("",IOM)," ","*") + N SDNAM,SDDFN + S SDNAM="" F S SDNAM=$O(^TMP($J,"BADADD",SDNAM)) Q:SDNAM="" D + . S SDDFN=0 F S SDDFN=$O(^TMP($J,"BADADD",SDNAM,SDDFN)) Q:'SDDFN D + . . W !,$$LAST4(SDDFN),?10,SDNAM + W !!,SDHDR1 + Q diff --git a/r/SCHEDULING-SD-SC/SDN1.m b/r/SCHEDULING-SD-SC/SDN1.m index 1734da66..426295c5 100644 --- a/r/SCHEDULING-SD-SC/SDN1.m +++ b/r/SCHEDULING-SD-SC/SDN1.m @@ -1,42 +1,42 @@ -SDN1 ;BSN/GRR - NO-SHOW LETTERS ; 17 AUG 84 4:34 pm - ;;5.3;Scheduling;**330,340,398,455,523**;Aug 13, 1993;Build 6 - N SDBAD - I ANS["Y"&($D(C)) F A=0:0 S A=$O(^UTILITY($J,A)) Q:A'>0 F C=0:0 S C=$O(^(A,C)) Q:C'>0 S SC=+^(C),SDLET="" S:$D(^SC(SC,"LTR")) SDLET=+^("LTR") S:SDLET ^UTILITY($J,"SDLT",SDLET,A,C)=^UTILITY($J,A,C) S:'SDLET ^UTILITY($J,"NO",A,C)=SC D KLL - S SDFORM=$S($D(^DG(40.8,SDV1,"LTR")):^("LTR"),1:"") G:ANS["Y"&($D(C)) LST -BC K:$D(SDLT) C S:$D(SDLT) SDT=SDBD,DATEND=SDED K ^UTILITY($J) I $D(C) K VAUTC S (VAUTC,VAUTC(C))="" - I $D(VAUTC),'VAUTC F C=0:0 S C=$O(VAUTC(C)) Q:C'>0 D:$D(SDLT) LT D CHECK1 I $T D OVER - I $D(VAUTC),'VAUTC G LST -LST1 F C=0:0 S C=$O(^SC(C)) Q:C'>0 D LT,CHECK1 I $T,$S(SDV1="":1,SDV=SDV1:1,SDV="":1,1:0),'$D(SDVAUTC(+C)),$D(^SC(C,"S")) D OVER -LST N SDFIRST S SDFIRST=1 - F SDLET=0:0 S SDLET=$O(^UTILITY($J,"SDLT",SDLET)) Q:SDLET'>0 F A=0:0 S A=$O(^UTILITY($J,"SDLT",SDLET,A)) Q:A'>0 I $S('$D(^DPT(A,.35)):1,$P(^(.35),"^",1)']"":1,1:0) N POP S POP=0 D ^SDLT Q:POP D WR ;SD*523 added quit - I $D(^UTILITY($J,"NO")) W @IOF F A=0:0 S A=$O(^UTILITY($J,"NO",A)) Q:A'>0 F A1=0:0 S A1=$O(^(A,A1)) Q:A1'>0 Q:$$BADADR^DGUTL3(A) W !,$P(^DPT(A,0),"^")," ",$P(^(0),"^",9)," has failed to keep the following appointment(s):" D NDT - W:$D(^UTILITY($J,"NO")) !,"However, there are no letters assigned to the clinic(s).",!! - I $D(^TMP($J,"BADADD")) D BADADD^SDLT K ^TMP($J,"BADADD") - G END -OVER S GDATE=SDT Q:'$D(^SC(C,"S")) F J=0:0 S GDATE=$O(^SC(C,"S",GDATE)) Q:GDATE=""!(GDATE>(DATEND+.9999)) F K=0:0 S K=$O(^SC(C,"S",GDATE,1,K)) Q:K="" I $D(^(K,0)) S DFN=+^(0) D CHECK - Q -END K %,%DT,%IS,A,A0,A1,A2,ALL,ALS,ANS,BY,C,CDATE,DA,DFN,DGPGM,DGVAR,DH,DHD,DIC,DIS,DIV,DIW,DIWF,DIWL,DIWR,DIWT,DO,DOW,DN,DUPE,FLDS,F,F1,FR,GDATE,I,I1,L,L0,LET,MAX,MESS,MIN,NOAP,P,POP,SC,SD,SDFOR,SDLET,SDTIME,SI,SL,SS,ST,SDSTRTDT,TO,X,Y,ADDR,B - K CLIN,HX,LL,PDAT,S,TIME,Z,D,NDATE,ENDATE,J,SDMDT,SDMSTIME,X1,X2,SDTADE,SDADTB,SDRE,SDRE1,SDIN,SDIS,SDYES,CNN,SDT,DATEND,SDV1,K,SDR,SDJ1,^UTILITY($J),SD1,SD2,SDADD,SDC,SDCL,SDCMAX,SDCONS,SDD,SDDAT,SDDIF,SDDT,SDED,SDFORM,SDHX,SDINP,SDIP - K %ZIS,Y1,SDBD,SDCT,SDVAUTC,VAUTC,SDX,SDX1,SDNOSH,SDLT1,SDMSG,SDNODE,SDQ,SDRT,SDSOH,SDSTAT,SDT0,SDZSC,SM,SM1,STARTDAY,STIME,SDV,Z0,Z5 D CLOSE^DGUTQ Q -CHECK I $S('$D(^DPT(DFN,.35)):1,$P(^(.35),"^",1)']"":1,1:0),$D(^DPT(DFN,"S",GDATE,0)),$S($P(^(0),U,2)="N":1,$P(^(0),U,2)="NA":1,$D(SDCP)&$P(^(0),"^",2)["C":1,1:0),$P(^(0),"^",14)=SDTIME!(SDTIME="*"),'$D(^DPT(DFN,.1)) D - .D BAD Q:SDBAD - .D SET - Q ;above logic changed SD*5.3*455 -SET I SDLT1!SDLET S ^UTILITY($J,"SDLT",$S(SDLT1:SDLT1,1:SDLET),DFN,GDATE)=C_"^"_$P(^DPT(DFN,"S",GDATE,0),"^",10) Q - S ^UTILITY($J,"NO",DFN,GDATE)=C Q -CHECK1 S SDV=$P(^SC(C,0),"^",15) I $P(^(0),"^",3)="C",$S('$D(^SC(C,"I")):1,'(+^("I")):1,+^("I")>DATEND:1,+$P(^("I"),"^",2)'>DATEND&(+$P(^("I"),"^",2)):1,1:0) - Q -WR K CNN F J=0:0 S J=$O(^UTILITY($J,"SDLT",SDLET,A,J)) Q:J="" S SDR=0,SDX=J,CNN(J)=^(J),CLIN=$P(^SC(+$P(CNN(J),"^",1),0),"^",1),SDC=+CNN(J),S=$S($D(^DPT(A,"S",J,0)):^(0),1:"") D WRAPP^SDLT,SET1 - D:SDR SDR D REST^SDLT Q -SDR W !!,"The appointment(s) have been rescheduled as follows:",! - F J=0:0 S J=$O(CNN(J)) Q:J="" S SDX=$P(CNN(J),"^",2),SDC=$P(CNN(J),"^") I SDX S S=$S($D(^DPT(A,"S",SDX,0)):^(0),1:"") D WRAPP^SDLT - Q -SET1 S:'SDR SDR=$S($P(CNN(J),"^",2)]"":1,1:0) Q - Q -LT S:'SDLT1 SDLET=0 I $D(^SC(C,"LTR")),^("LTR") S SDLET=+^("LTR") - Q -NDT W !?15,$P(^SC(+^UTILITY($J,"NO",A,A1),0),"^")," on " S Y=A1 D DT^DIQ Q -KLL K ^UTILITY($J,A,C) Q -BAD S SDBAD=$$BADADR^DGUTL3(+DFN) - S:SDBAD ^TMP($J,"BADADD",$P(^DPT(+DFN,0),"^"),+DFN)="" - Q +SDN1 ;BSN/GRR - NO-SHOW LETTERS ; 17 AUG 84 4:34 pm + ;;5.3;Scheduling;**330,340,398,455**;Aug 13, 1993 + N SDBAD + I ANS["Y"&($D(C)) F A=0:0 S A=$O(^UTILITY($J,A)) Q:A'>0 F C=0:0 S C=$O(^(A,C)) Q:C'>0 S SC=+^(C),SDLET="" S:$D(^SC(SC,"LTR")) SDLET=+^("LTR") S:SDLET ^UTILITY($J,"SDLT",SDLET,A,C)=^UTILITY($J,A,C) S:'SDLET ^UTILITY($J,"NO",A,C)=SC D KLL + S SDFORM=$S($D(^DG(40.8,SDV1,"LTR")):^("LTR"),1:"") G:ANS["Y"&($D(C)) LST +BC K:$D(SDLT) C S:$D(SDLT) SDT=SDBD,DATEND=SDED K ^UTILITY($J) I $D(C) K VAUTC S (VAUTC,VAUTC(C))="" + I $D(VAUTC),'VAUTC F C=0:0 S C=$O(VAUTC(C)) Q:C'>0 D:$D(SDLT) LT D CHECK1 I $T D OVER + I $D(VAUTC),'VAUTC G LST +LST1 F C=0:0 S C=$O(^SC(C)) Q:C'>0 D LT,CHECK1 I $T,$S(SDV1="":1,SDV=SDV1:1,SDV="":1,1:0),'$D(SDVAUTC(+C)),$D(^SC(C,"S")) D OVER +LST N SDFIRST S SDFIRST=1 + F SDLET=0:0 S SDLET=$O(^UTILITY($J,"SDLT",SDLET)) Q:SDLET'>0 F A=0:0 S A=$O(^UTILITY($J,"SDLT",SDLET,A)) Q:A'>0 I $S('$D(^DPT(A,.35)):1,$P(^(.35),"^",1)']"":1,1:0) D ^SDLT,WR + I $D(^UTILITY($J,"NO")) W @IOF F A=0:0 S A=$O(^UTILITY($J,"NO",A)) Q:A'>0 F A1=0:0 S A1=$O(^(A,A1)) Q:A1'>0 Q:$$BADADR^DGUTL3(A) W !,$P(^DPT(A,0),"^")," ",$P(^(0),"^",9)," has failed to keep the following appointment(s):" D NDT + W:$D(^UTILITY($J,"NO")) !,"However, there are no letters assigned to the clinic(s).",!! + I $D(^TMP($J,"BADADD")) D BADADD^SDLT K ^TMP($J,"BADADD") + G END +OVER S GDATE=SDT Q:'$D(^SC(C,"S")) F J=0:0 S GDATE=$O(^SC(C,"S",GDATE)) Q:GDATE=""!(GDATE>(DATEND+.9999)) F K=0:0 S K=$O(^SC(C,"S",GDATE,1,K)) Q:K="" I $D(^(K,0)) S DFN=+^(0) D CHECK + Q +END K %,%DT,%IS,A,A0,A1,A2,ALL,ALS,ANS,BY,C,CDATE,DA,DFN,DGPGM,DGVAR,DH,DHD,DIC,DIS,DIV,DIW,DIWF,DIWL,DIWR,DIWT,DO,DOW,DN,DUPE,FLDS,F,F1,FR,GDATE,I,I1,L,L0,LET,MAX,MESS,MIN,NOAP,P,POP,SC,SD,SDFOR,SDLET,SDTIME,SI,SL,SS,ST,SDSTRTDT,TO,X,Y,ADDR,B + K CLIN,HX,LL,PDAT,S,TIME,Z,D,NDATE,ENDATE,J,SDMDT,SDMSTIME,X1,X2,SDTADE,SDADTB,SDRE,SDRE1,SDIN,SDIS,SDYES,CNN,SDT,DATEND,SDV1,K,SDR,SDJ1,^UTILITY($J),SD1,SD2,SDADD,SDC,SDCL,SDCMAX,SDCONS,SDD,SDDAT,SDDIF,SDDT,SDED,SDFORM,SDHX,SDINP,SDIP + K %ZIS,Y1,SDBD,SDCT,SDVAUTC,VAUTC,SDX,SDX1,SDNOSH,SDLT1,SDMSG,SDNODE,SDQ,SDRT,SDSOH,SDSTAT,SDT0,SDZSC,SM,SM1,STARTDAY,STIME,SDV,Z0,Z5 D CLOSE^DGUTQ Q +CHECK I $S('$D(^DPT(DFN,.35)):1,$P(^(.35),"^",1)']"":1,1:0),$D(^DPT(DFN,"S",GDATE,0)),$S($P(^(0),U,2)="N":1,$P(^(0),U,2)="NA":1,$D(SDCP)&$P(^(0),"^",2)["C":1,1:0),$P(^(0),"^",14)=SDTIME!(SDTIME="*"),'$D(^DPT(DFN,.1)) D + .D BAD Q:SDBAD + .D SET + Q ;above logic changed SD*5.3*455 +SET I SDLT1!SDLET S ^UTILITY($J,"SDLT",$S(SDLT1:SDLT1,1:SDLET),DFN,GDATE)=C_"^"_$P(^DPT(DFN,"S",GDATE,0),"^",10) Q + S ^UTILITY($J,"NO",DFN,GDATE)=C Q +CHECK1 S SDV=$P(^SC(C,0),"^",15) I $P(^(0),"^",3)="C",$S('$D(^SC(C,"I")):1,'(+^("I")):1,+^("I")>DATEND:1,+$P(^("I"),"^",2)'>DATEND&(+$P(^("I"),"^",2)):1,1:0) + Q +WR K CNN F J=0:0 S J=$O(^UTILITY($J,"SDLT",SDLET,A,J)) Q:J="" S SDR=0,SDX=J,CNN(J)=^(J),CLIN=$P(^SC(+$P(CNN(J),"^",1),0),"^",1),SDC=+CNN(J),S=$S($D(^DPT(A,"S",J,0)):^(0),1:"") D WRAPP^SDLT,SET1 + D:SDR SDR D REST^SDLT Q +SDR W !!,"The appointment(s) have been rescheduled as follows:",! + F J=0:0 S J=$O(CNN(J)) Q:J="" S SDX=$P(CNN(J),"^",2),SDC=$P(CNN(J),"^") I SDX S S=$S($D(^DPT(A,"S",SDX,0)):^(0),1:"") D WRAPP^SDLT + Q +SET1 S:'SDR SDR=$S($P(CNN(J),"^",2)]"":1,1:0) Q + Q +LT S:'SDLT1 SDLET=0 I $D(^SC(C,"LTR")),^("LTR") S SDLET=+^("LTR") + Q +NDT W !?15,$P(^SC(+^UTILITY($J,"NO",A,A1),0),"^")," on " S Y=A1 D DT^DIQ Q +KLL K ^UTILITY($J,A,C) Q +BAD S SDBAD=$$BADADR^DGUTL3(+DFN) + S:SDBAD ^TMP($J,"BADADD",$P(^DPT(+DFN,0),"^"),+DFN)="" + Q diff --git a/r/SCHEDULING-SD-SC/SDNOS0.m b/r/SCHEDULING-SD-SC/SDNOS0.m index f345a0df..03cffc3c 100644 --- a/r/SCHEDULING-SD-SC/SDNOS0.m +++ b/r/SCHEDULING-SD-SC/SDNOS0.m @@ -1,74 +1,73 @@ -SDNOS0 ;ALB/LDB - NO SHOW REPORT ; 07 May 99 10:21 AM - ;;5.3;Scheduling;**20,194,410,517,523**;Aug 13, 1993;Build 6 - D END1^SDNOS - S (SDV1,SDIN,SDNM,SDNM1)=0,SDDIVO=SDDIV - I $D(^DG(43,1,"GL")),$P(^("GL"),U,2) S SDV1=1 - I SDDIV'="A" S (^UTILITY($J,"SDNO",SDDIV,"***TOT***"),^UTILITY($J,"SDNO",SDDIV,"***N***","***TOT***"),^UTILITY($J,"SDNO",SDDIV,"***NA***","***TOT***"),^UTILITY($J,"SDNO",SDDIV,"***SDNMS***"))=0 - I SDDIV="A" D DIVRPT - I SDCL(1)="ALL" S SDCL=0 D SDCL - I SDCL(1)'="ALL" F SDSUB=0:0 S SDSUB=$O(SDCL(SDSUB)) Q:SDSUB="" S SDCL=SDCL(SDSUB),SDLAB=$S(SDCL?.N1"*".E:"RANGE",1:"SDTST") D @SDLAB - S (P1,SDTOT,SDTOT1)=0,DGTCH="NO-SHOW REPORT^CLINIC^PAGE#",(SDEND,SDHD)=0 - D ^SDNOS1 - Q - ; -DIVRPT F SDDIV=0:0 S SDDIV=$O(^DG(40.8,SDDIV)) Q:'SDDIV S (^UTILITY($J,"SDNO",SDDIV,"***N***","***TOT***"),^UTILITY($J,"SDNO",SDDIV,"***NA***","***TOT***"),^UTILITY($J,"SDNO",SDDIV,"***TOT***"),^UTILITY($J,"SDNO",SDDIV,"***SDNMS***"))=0 - Q - ; -SDCL F SDZ=1:1 S SDCL=$O(^SC(SDCL)) Q:'SDCL D SDTST - Q - ; -SDTST S SDNM=0,SDCL1=^SC(SDCL,0) I $P(SDCL1,U,3)'="C" Q - I SDDIVO,SDCL(1),'$D(SDR1) D DATES Q - I $S((SDDIVO&'SDCL(1)&(SDDIVO=$P(SDCL1,U,15))):1,'SDDIVO:1,$D(SDR1)&SDDIVO&($P(SDCL1,U,15)=SDDIVO):1,'$P(SDCL1,U,15)&(SDDIVO=$P(^DG(43,1,"GL"),U,3)):1,'SDV1:1,1:0) S SDIN=0 D:$D(^SC(SDCL,"I")) INAC^SDNOS1A Q:SDIN D DATES - Q - ; -DATES S:'SDDIVO SDDIV=$S($P(SDCL1,U,15)&SDV1:$P(SDCL1,U,15),$D(^DG(43,"GL")):$P(^("GL"),U,3),1:$O(^DG(40.8,0))) - Q:$D(^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***TOT***")) S ^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***TOT***")=0,^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***SDNMS***")=0 - S (SDEN,SDBEG)=0,SDBEG1=SDBD F SDZ1=1:1 S SDBEG1=$O(^SC(SDCL,"S",SDBEG1)) Q:SDBEG1'>0 D SDED Q:SDBEG!SDEN D CHK - S ^UTILITY($J,"SDNO",SDDIV,"***SDNMS***")=SDNM+^UTILITY($J,"SDNO",SDDIV,"***SDNMS***") - Q - ; -SDED S SDBEG=0,SDEN=0 I $D(SDED),(SDBEG1>(SDED+.99999)) S SDEN=1 Q - I '$D(SDED),(SDBEG1>(SDBD+.99999)) S SDBEG=1 Q - Q - ;Added 2nd Quit below SD/517 - ;SD/523 - added Q:SDPAT="" to For loop -CHK S SDAPP=0 F S SDAPP=$O(^SC(SDCL,"S",SDBEG1,1,SDAPP)) Q:'SDAPP Q:'$D(^(SDAPP,0)) I $D(^SC(SDCL,"S",SDBEG1,1,SDAPP))=10,$P(^(SDAPP,0),U,9)'="C" S SDPAT=$P(^SC(SDCL,"S",SDBEG1,1,SDAPP,0),U,1) Q:SDPAT="" I $D(^DPT(SDPAT,"S",SDBEG1)) D CHK1 - Q - ; -CHK1 S SD="SD" F SDCHK=1,2,10,12,14 S @(SD_SDCHK)=$P(^DPT(SDPAT,"S",SDBEG1,0),U,SDCHK) - S:'SDDIVO&$P(SDCL1,U,15) SDDIV=$P(SDCL1,U,15) S:'SDDIVO&'$P(SDCL1,U,15) SDDIV=$O(^DG(40.8,0)) - S:'$D(^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***TOT***")) ^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***TOT***")=0 - I SDFMT=1 D - .I (SD2="N")!(SD2="NA"),$$NOSHOW(SDPAT,SDBEG1,SDCL,$G(^DPT(SDPAT,"S",SDBEG1,0)),SDAPP) D - ..D SET,TOTAL Q - I SDFMT=2 D - .I (SD2=""&('$D(^SC(SDCL,"S",SDBEG1,1,SDAPP,"C"))))!(SD2="N")!(SD2="NA")!(SD2="NT"),$$NOSHOW(SDPAT,SDBEG1,SDCL,$G(DPT(SDPAT,"S",SDBEG1,0)),SDAPP) D - ..D SET,TOTAL Q - I SD2'["C" S SDNM=SDNM+1,^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***SDNMS***")=SDNM - Q - ; -SET S:$P(SDCL1,U,15)&SDDIVO&SDV1 SDDIV=$P(SDCL1,U,15) S ^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),SDBEG1,$P(^DPT(SDPAT,0),U),+$P(^(0),U,9))=SD2_U_SD10_U_SD12 - Q - ; -TOTAL S ^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***"_SD2_"***","***TOT***")=$S($D(^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***"_SD2_"***","***TOT***")):^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***"_SD2_"***","***TOT***")+1,1:1) - S ^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),$P(SDBEG1,"."),"***"_SD2_"***","***TOT***")=$S($D(^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),$P(SDBEG1,"."),"***"_SD2_"***","***TOT***")):^("***TOT***")+1,1:1) - S ^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***TOT***")=$S($D(^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***TOT***")):^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***TOT***")+1,1:1) - S ^("***TOT***")=^UTILITY($J,"SDNO",SDDIV,"***TOT***")+1,^("***TOT***")=$S($D(^UTILITY($J,"SDNO",SDDIV,"***"_SD2_"***","***TOT***")):^UTILITY($J,"SDNO",SDDIV,"***"_SD2_"***","***TOT***")+1,1:1) - Q - ; -RANGE S SDREST=$E(SDCL,$F(SDCL,"*"),$L(SDCL)),SDCL=$E(SDCL,1,($F(SDCL,"*")-2)),SDCL1=^SC(SDCL,0) - S:'SDDIVO SDDIV=$S($P(SDCL1,U,15):$P(SDCL1,U,15),'$P(SDCL1,U,15)&$D(^DG(43,"GL")):$P(^DG(43,"GL"),U,3),1:$O(^DG(40.8,0))) - S SDR1=1,SDR=$P(SDCL1,U) D SDTST K SDR1 - S SDREST="1"_""""_SDREST_""""_".E" F SDCXX=1:1 S SDR=$O(^SC("B",SDR)) Q:'(SDR?@SDREST)!(SDR="") S SDCL=$O(^SC("B",SDR,-1)) S SDR1=1 D RANGE1 K SDR1 - Q - ; -RANGE1 S:'SDDIVO SDDIV=$S($P(SDCL1,U,15):$P(SDCL1,U,15),'$P(SDCL1,U,15)&$D(^DG(43,"GL")):$P(^DG(43,"GL"),U,3),1:$O(^DG(40.8,0))) D SDTST - Q - ; -NOSHOW(DFN,SDT,CIFN,PAT,DA) ;Input: DFN=Patient IFN, SDT=Appointment D/T - ; CIFN=Clinic IFN, PAT=Zero node of pat. appt., DA=Clinic appt. IFN - ; Output: 1 or 0 for noshow yes/no - N NSQUERY,NS S NS=1,NSQUERY=$$STATUS^SDAM1(DFN,SDT,CIFN,PAT,DA) - I $P(NSQUERY,";",3)["ACTION REQ" S NS=0 -NOSHOWQ Q NS +SDNOS0 ;ALB/LDB - NO SHOW REPORT ; 07 May 99 10:21 AM + ;;5.3;Scheduling;**20,194,410,517**;Aug 13, 1993;Build 4 + D END1^SDNOS + S (SDV1,SDIN,SDNM,SDNM1)=0,SDDIVO=SDDIV + I $D(^DG(43,1,"GL")),$P(^("GL"),U,2) S SDV1=1 + I SDDIV'="A" S (^UTILITY($J,"SDNO",SDDIV,"***TOT***"),^UTILITY($J,"SDNO",SDDIV,"***N***","***TOT***"),^UTILITY($J,"SDNO",SDDIV,"***NA***","***TOT***"),^UTILITY($J,"SDNO",SDDIV,"***SDNMS***"))=0 + I SDDIV="A" D DIVRPT + I SDCL(1)="ALL" S SDCL=0 D SDCL + I SDCL(1)'="ALL" F SDSUB=0:0 S SDSUB=$O(SDCL(SDSUB)) Q:SDSUB="" S SDCL=SDCL(SDSUB),SDLAB=$S(SDCL?.N1"*".E:"RANGE",1:"SDTST") D @SDLAB + S (P1,SDTOT,SDTOT1)=0,DGTCH="NO-SHOW REPORT^CLINIC^PAGE#",(SDEND,SDHD)=0 + D ^SDNOS1 + Q + ; +DIVRPT F SDDIV=0:0 S SDDIV=$O(^DG(40.8,SDDIV)) Q:'SDDIV S (^UTILITY($J,"SDNO",SDDIV,"***N***","***TOT***"),^UTILITY($J,"SDNO",SDDIV,"***NA***","***TOT***"),^UTILITY($J,"SDNO",SDDIV,"***TOT***"),^UTILITY($J,"SDNO",SDDIV,"***SDNMS***"))=0 + Q + ; +SDCL F SDZ=1:1 S SDCL=$O(^SC(SDCL)) Q:'SDCL D SDTST + Q + ; +SDTST S SDNM=0,SDCL1=^SC(SDCL,0) I $P(SDCL1,U,3)'="C" Q + I SDDIVO,SDCL(1),'$D(SDR1) D DATES Q + I $S((SDDIVO&'SDCL(1)&(SDDIVO=$P(SDCL1,U,15))):1,'SDDIVO:1,$D(SDR1)&SDDIVO&($P(SDCL1,U,15)=SDDIVO):1,'$P(SDCL1,U,15)&(SDDIVO=$P(^DG(43,1,"GL"),U,3)):1,'SDV1:1,1:0) S SDIN=0 D:$D(^SC(SDCL,"I")) INAC^SDNOS1A Q:SDIN D DATES + Q + ; +DATES S:'SDDIVO SDDIV=$S($P(SDCL1,U,15)&SDV1:$P(SDCL1,U,15),$D(^DG(43,"GL")):$P(^("GL"),U,3),1:$O(^DG(40.8,0))) + Q:$D(^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***TOT***")) S ^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***TOT***")=0,^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***SDNMS***")=0 + S (SDEN,SDBEG)=0,SDBEG1=SDBD F SDZ1=1:1 S SDBEG1=$O(^SC(SDCL,"S",SDBEG1)) Q:SDBEG1'>0 D SDED Q:SDBEG!SDEN D CHK + S ^UTILITY($J,"SDNO",SDDIV,"***SDNMS***")=SDNM+^UTILITY($J,"SDNO",SDDIV,"***SDNMS***") + Q + ; +SDED S SDBEG=0,SDEN=0 I $D(SDED),(SDBEG1>(SDED+.99999)) S SDEN=1 Q + I '$D(SDED),(SDBEG1>(SDBD+.99999)) S SDBEG=1 Q + Q + ;Added 2nd Quit below SD/517 +CHK S SDAPP=0 F S SDAPP=$O(^SC(SDCL,"S",SDBEG1,1,SDAPP)) Q:'SDAPP Q:'$D(^(SDAPP,0)) I $D(^SC(SDCL,"S",SDBEG1,1,SDAPP))=10,$P(^(SDAPP,0),U,9)'="C" S SDPAT=$P(^SC(SDCL,"S",SDBEG1,1,SDAPP,0),U,1) I $D(^DPT(SDPAT,"S",SDBEG1)) D CHK1 + Q + ; +CHK1 S SD="SD" F SDCHK=1,2,10,12,14 S @(SD_SDCHK)=$P(^DPT(SDPAT,"S",SDBEG1,0),U,SDCHK) + S:'SDDIVO&$P(SDCL1,U,15) SDDIV=$P(SDCL1,U,15) S:'SDDIVO&'$P(SDCL1,U,15) SDDIV=$O(^DG(40.8,0)) + S:'$D(^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***TOT***")) ^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***TOT***")=0 + I SDFMT=1 D + .I (SD2="N")!(SD2="NA"),$$NOSHOW(SDPAT,SDBEG1,SDCL,$G(^DPT(SDPAT,"S",SDBEG1,0)),SDAPP) D + ..D SET,TOTAL Q + I SDFMT=2 D + .I (SD2=""&('$D(^SC(SDCL,"S",SDBEG1,1,SDAPP,"C"))))!(SD2="N")!(SD2="NA")!(SD2="NT"),$$NOSHOW(SDPAT,SDBEG1,SDCL,$G(DPT(SDPAT,"S",SDBEG1,0)),SDAPP) D + ..D SET,TOTAL Q + I SD2'["C" S SDNM=SDNM+1,^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***SDNMS***")=SDNM + Q + ; +SET S:$P(SDCL1,U,15)&SDDIVO&SDV1 SDDIV=$P(SDCL1,U,15) S ^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),SDBEG1,$P(^DPT(SDPAT,0),U),+$P(^(0),U,9))=SD2_U_SD10_U_SD12 + Q + ; +TOTAL S ^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***"_SD2_"***","***TOT***")=$S($D(^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***"_SD2_"***","***TOT***")):^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***"_SD2_"***","***TOT***")+1,1:1) + S ^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),$P(SDBEG1,"."),"***"_SD2_"***","***TOT***")=$S($D(^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),$P(SDBEG1,"."),"***"_SD2_"***","***TOT***")):^("***TOT***")+1,1:1) + S ^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***TOT***")=$S($D(^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***TOT***")):^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***TOT***")+1,1:1) + S ^("***TOT***")=^UTILITY($J,"SDNO",SDDIV,"***TOT***")+1,^("***TOT***")=$S($D(^UTILITY($J,"SDNO",SDDIV,"***"_SD2_"***","***TOT***")):^UTILITY($J,"SDNO",SDDIV,"***"_SD2_"***","***TOT***")+1,1:1) + Q + ; +RANGE S SDREST=$E(SDCL,$F(SDCL,"*"),$L(SDCL)),SDCL=$E(SDCL,1,($F(SDCL,"*")-2)),SDCL1=^SC(SDCL,0) + S:'SDDIVO SDDIV=$S($P(SDCL1,U,15):$P(SDCL1,U,15),'$P(SDCL1,U,15)&$D(^DG(43,"GL")):$P(^DG(43,"GL"),U,3),1:$O(^DG(40.8,0))) + S SDR1=1,SDR=$P(SDCL1,U) D SDTST K SDR1 + S SDREST="1"_""""_SDREST_""""_".E" F SDCXX=1:1 S SDR=$O(^SC("B",SDR)) Q:'(SDR?@SDREST)!(SDR="") S SDCL=$O(^SC("B",SDR,-1)) S SDR1=1 D RANGE1 K SDR1 + Q + ; +RANGE1 S:'SDDIVO SDDIV=$S($P(SDCL1,U,15):$P(SDCL1,U,15),'$P(SDCL1,U,15)&$D(^DG(43,"GL")):$P(^DG(43,"GL"),U,3),1:$O(^DG(40.8,0))) D SDTST + Q + ; +NOSHOW(DFN,SDT,CIFN,PAT,DA) ;Input: DFN=Patient IFN, SDT=Appointment D/T + ; CIFN=Clinic IFN, PAT=Zero node of pat. appt., DA=Clinic appt. IFN + ; Output: 1 or 0 for noshow yes/no + N NSQUERY,NS S NS=1,NSQUERY=$$STATUS^SDAM1(DFN,SDT,CIFN,PAT,DA) + I $P(NSQUERY,";",3)["ACTION REQ" S NS=0 +NOSHOWQ Q NS diff --git a/r/SCHEDULING-SD-SC/SDRPA00.m b/r/SCHEDULING-SD-SC/SDRPA00.m index 690710d5..83bb0665 100644 --- a/r/SCHEDULING-SD-SC/SDRPA00.m +++ b/r/SCHEDULING-SD-SC/SDRPA00.m @@ -1,198 +1,196 @@ -SDRPA00 ;BP-OIFO/OWAIN,ESW - Patient Appointment Information Transmission ; 11/2/04 11:09am ; 2/24/08 11:25am - ;;5.3;Scheduling;**290,333,349,376,491**;Aug 13,1993;Build 53 - ;SD/491 - calling SRPA03 instead of SDRPA04 (dupl) - Q -EN ;manual entry - N SDI,Y,ZTSK,ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSAVE,RUNID,REC - I '$$RUNCK^SDRPA02() W !,"You attempted to start PAIT outside the authorized transmission dates.",!,"Job has been terminated.",! Q - S RUNID=$O(^SDWL(409.6,":"),-1) - I RUNID S ZTSK=$P(^SDWL(409.6,RUNID,0),"^",2) D STAT^%ZTLOAD I ZTSK(1)=1!(ZTSK(1)=2) W !,"A task is currently active." Q - K ZTSK N SDCON S SDCON=1 - S %DT("A")="Queue to run: " - S %DT="AEFXR" W ! D ^%DT S DT=Y D:Y'=-1 Q:'SDCON - .S ZTDTH=Y,ZTRTN="START^SDRPA00",ZTIO="" - .S ZTDESC="PAIT" - .I RUNID I $P(^SDWL(409.6,RUNID,0),U,7)="" S SDCON=0 D - ..W !,"The previous run errored out, not repaired!",!,"Please address a problem and use SD-PAIT REPAIR to fix the run." - .Q:'SDCON - .F SDI=1:1:20 D ^%ZTLOAD Q:$G(ZTSK) - .I $G(ZTSK) W !,"Task # "_ZTSK_" queued!" - I '$G(ZTSK) W !!,"Task not queued, check Taskman",! Q - W !!,"Task number: ",ZTSK,! - Q -START ;Tasked entry - N SDOUT,DFN,DFNEND,SDCNT,SDCNT0,RUNID,RUNDT,SDPREV,FIRST,SDDAM,TODAY,SD6A,SD8A,SD68,RUNIDP,SDPR,ZTSKN - I '$$RUNCK^SDRPA02() Q ;check scheduling - I $G(ZTSK)="" D Q - . W !,"NOT AN INTERACTIVE OPTION...schedule through TaskMan",!! - S ZTSKN=ZTSK - S SDPR=$O(^SDWL(409.6,":"),-1) ;previous run - I SDPR N SD1 S SD1=0 D Q:SD1 ;finish if task is still running - .I $P(^SDWL(409.6,SDPR,0),U,7)'="" Q ; previous task finished - .N ZTSK - .S ZTSK=$P(^SDWL(409.6,SDPR,0),"^",2) D STAT^%ZTLOAD I ZTSK(1)=1!(ZTSK(1)=2) S SD1=1 - .;send message - .N SDAMX,XMSUB,XMY,XMTEXT,XMDUZ - .S XMSUB="PAIT BACKGROUND JOB" - .S XMY("G.SD-PAIT")="" - .S XMTEXT="SDAMX(" - .S XMDUZ="POSTMASTER" - .S SDAMX(1)="The PAIT requested task has been terminated." - .S SDAMX(2)="The previous task #: "_ZTSK_" run #: "_SDPR_" has not been completed." - .I SD1=1 S SDAMX(3)="It is still running.",SDAMX(4)="" - .E S SD1=2 D - ..S SDAMX(3)="The previous run errored out, not repaired!" - ..S SDAMX(4)="Address a problem and use option SD-PAIT REPAIR to fix the run." - .D ^XMD - S DIC=409.6,DIC(0)="X" - D NOW^%DTC S TODAY=X - K DO D FILE^DICN - S DA=+Y,DIE=DIC,DR="1///"_ZTSK D ^DIE - ;send START message - D STMES - S (SDOUT,SDCNT)=0 - K ^TMP("SDDPT",$J) - N CRUNID S CRUNID=$O(^SDWL(409.6,"AD",ZTSK,"")) - S RUNDT=$P(^SDWL(409.6,CRUNID,0),"^") - I SDPR=0 S SDPREV=3020831,FIRST=1 ;first run - E S SDPREV=$P(^SDWL(409.6,SDPR,0),U,4),FIRST=0 ; - N SDFIN,SDPEN,SDF,SDTR S (RUNID,SDFIN,SDPEN,SDTR,SDF)=0 - S SDDAM=SDPREV ;creation date - D NOW^%DTC S TODAY=X - F S SDDAM=$O(^DPT("ASADM",SDDAM)) Q:SDDAM="" Q:SDDAM=TODAY!SDOUT D - .N DFN S DFN=0 - .F S DFN=$O(^DPT("ASADM",SDDAM,DFN)) Q:+DFN'=DFN!SDOUT D - ..N SDADT S SDADT=0 ;appt date/time - ..S SDADT=0 - ..F S SDADT=$O(^DPT("ASADM",SDDAM,DFN,SDADT)) Q:+SDADT'=SDADT!SDOUT D - ...I SDADT'>3030000 Q ;only appointment scheduled for 2003 and later; sd/491 - ...I SDDAM'=$$GET1^DIQ(2.98,SDADT_","_DFN_",",20,"I") Q ;compare creation dates - ...; Check for 'stop task' request - ...S SDCNT=SDCNT+1 I SDCNT#500=0 S SDOUT=$$S^%ZTLOAD I SDOUT D N SDBCID,SDMCID,SDSTOP D SNDS19^SDRPA07(ZTSK,.SDBCID,.SDMCID) S SDSTOP=1 D MSGT^SDRPA04(CRUNID,SDPEN,SDFIN,,SDSTOP) K ^TMP("SDDPT",$J) Q - ....N DA,DIE,DR,SDD,SDLAST D - ....S SDLAST=$O(^SDWL(409.6,CRUNID,1,"B"),-1) S SDD=$P(^SDWL(409.6,CRUNID,1,SDLAST,0),U,7)-1 - ....S DA=CRUNID,DIE=409.6,DR="1.2///"_SDD D ^DIE - ...N SDCL,SDSTAT,SDSTTY - ...S SDCL=$$GET1^DIQ(2.98,SDADT_","_DFN_",",.01,"I") - ...Q:SDCL="" ; If this happens, there's something wrong. - ...; - ...; Check status. - ...; Appoinment made only before Sep 1, 2003 - ...; If it is not the first run, send but don't create a pending file - ...; Otherwise add to pending file. - ...D NOW^%DTC N STODAY S STODAY=X - ...S SDSTAT=$$STATUS^SDRPA05(DFN,SDADT,SDCL,STODAY,1) - ...I $P(SDSTAT,"^")=0 Q - ...N SDCLL S SDCLL=$P(SDSTAT,U,6) I SDCLL'="" S SDCL=SDCLL ;assign a new clinic if from matching non count with encounter - ...S SDSTTY=$P(SDSTAT,U,2),SD6A=$P(SDSTAT,U,3),SD8A=$P(SDSTAT,U,4) - ...I SDSTTY="F" Q:'$$GT90DAYS(SDDAM,3030831) ; pending and final from 09/01/2003, previously 90 days - ...I SDSTTY="F",SD6A="NM",SD8A="NC" Q ; skip non-count if not matching count and scheduled date already expired - ...N SDCOA,SDMSHA S SDCOA=$P(SDSTAT,U,5) S SDMSHA=$P(SDSTAT,U) - ...N SDCE Q:'$$DPT^SDRPA08(DFN,.SDCE) ; Create demographic node of ^TMP file. Quit if this failed. - ...N DIC,DA,X,SDRET D - ....N SDRET S SDRET=$S(SDSTTY="F":"N",1:"Y") - ....S DIC="^SDWL(409.6,"_CRUNID_",1,",DA(1)=CRUNID,DIC("P")=409.69,DIC(0)="X" - ....K DO S X=DFN D FILE^DICN - ....S DA=+Y,DIE=DIC,DR="1///"_SDADT_";4///"_SDRET_";5///"_SD6A_";6///"_SDDAM_";8///"_SD8A_";9////"_SDCL D ^DIE - ....Q - ...D APPT^SDRPA08(DFN,SDADT,$$DTCONV^SDRPA08(SDDAM),SDCL,SDSTAT) - ...S SDFF=$P(SDSTAT,"^",4) D STAT(SDSTTY,SDFF,.SDFIN,.SDPEN,.SDF) - ...S SDTR=SDTR+1 I SDTR=5000 D SNDS19^SDRPA07(ZTSK,.SDBCID,.SDMCID) K ^TMP("SDDPT",$J) S SDTR=0 - Q:SDOUT - N SDD S SDD=$O(^DPT("ASADM",TODAY),-1) ;enter the last scanned day - S DA=CRUNID,DIE=409.6,DR="1.2///"_SDD D ^DIE - ; scan the previous runs - S RUNID=0 - F S RUNID=$O(^SDWL(409.6,RUNID)) Q:+RUNID=CRUNID!SDOUT D - .N APPTID,SDADT,REC - .S APPTID=0 - .;scanning only appointments that were sent as 'pending' - .F S APPTID=$O(^SDWL(409.6,"AE","Y",RUNID,APPTID)) Q:APPTID=""!SDOUT S REC=$G(^SDWL(409.6,RUNID,1,APPTID,0)) D - ..IF REC="" K ^SDWL(409.6,"AE","Y",RUNID,APPTID) Q ;anticipate - ..S DFN=$P(REC,"^"),SDADT=$P(REC,"^",2) - ..;evaluate SDADT - appt date/time for possible removal from sending - ..I SDADT'>3030000 N DIK S DIK="^SDWL(409.6,"_RUNID_",1,",DA(1)=RUNID,DA=APPTID D ^DIK ;delete entry; not to be sent; sd/491 - ..; Check for 'stop task' - ..S SDCNT=SDCNT+1 I SDCNT#500=0 S SDOUT=$$S^%ZTLOAD I SDOUT N SDBCID,SDMCID,SDSTOP D SNDS19^SDRPA07(ZTSK,.SDBCID,.SDMCID) S SDSTOP=1 D MSGT^SDRPA04(CRUNID,SDPEN,SDFIN,,SDSTOP) K ^TMP("SDDPT",$J) Q ; - ..N SDCL,SDCLO,SDCE,SDSTAT,SDREJ,SDDAM,SDDAMO - ..S SDCLO=$P(REC,"^",10) - ..S SDREJ=$P(REC,"^",8),SDDAMO=$P(REC,"^",7) ;esw - ..I SDDAMO="" D - ...N SDD S SDD=9999999 F S SDD=$O(^DPT("ASADM",SDD),-1) Q:SDD'>0 I $D(^DPT("ASADM",SDD,DFN,SDADT)) S SDDAMO=SDD Q - ..Q:SDDAMO="" ;cannot determine what was original creation date - ..;evaluate if the same creation date - ..S SDDAM=$$GET1^DIQ(2.98,SDADT_","_DFN_",",20,"I") - ..S SDCL=$$GET1^DIQ(2.98,SDADT_","_DFN_",",.01,"I") - ..Q:SDCL="" ; - ..I SDCLO="" S SDCLO=SDCL - ..I SDDAM'?7N!(SDDAM'>3020831) S SDDAM=SDDAMO ; need to finalize the previously sent - ..; Check status. If it is a termination, continue. - ..Q:$D(^TMP("SDDPT",$J,DFN,SDADT)) ; overridden to be process next time - ..;anothercross reference entry will be created; do not need to quit - ..;Q:$D(^SDWL(409.6,"AC",DFN,SDADT,+$G(CRUNID))) ;see above - ..S SDSTAT="" - ..I SDDAM'=SDDAMO!(SDCL'=SDCLO) D - ...; create CT status; the current SDADT has different creation date - ...S SDSTAT="S15"_U_"F"_U_"CT"_U_U_U_U_U S SDDAM=SDDAMO,SDCL=SDCLO - ..I SDSTAT="" D NOW^%DTC N SDTODAY S SDTODAY=X S SDSTAT=$$STATUS^SDRPA05(DFN,SDADT,SDCL,SDTODAY,0) - ..I $P(SDSTAT,"^")=0 Q - ..N SDCOA,SDMSHA S SDCOA=$P(SDSTAT,U,5) S SDMSHA=$P(SDSTAT,U),SD6A=$P(SDSTAT,U,3),SD8A=$P(SDSTAT,U,4) - ..N SDCLL S SDCLL=$P(SDSTAT,U,6) I SDCLL'="" S SDCL=SDCLL - ..S SDSTTY=$P(SDSTAT,U,2) - ..I SDSTTY="P"&(SDREJ="") Q ;do not send in pending status if not rejected ;esw - ..N SDCE Q:'$$DPT^SDRPA08(DFN,.SDCE) ; Create demographic node of ^TMP file. Quit if this failed. - ..N DIC,DA,X D - ...N SDRET S SDRET=$S(SDSTTY="F":"N",1:"Y") - ...S DIC="^SDWL(409.6,"_CRUNID_",1,",DA(1)=CRUNID,DIC("P")=409.69,DIC(0)="X" - ...K DO S X=DFN D FILE^DICN - ...S DA=+Y,DIE=DIC,DA=+Y,DR="1///"_SDADT_";4///"_SDRET_";5///"_SD6A_";6///"_SDDAM_";8///"_SD8A_";9////"_SDCL D ^DIE - ..N DIC,DA D - ...; not rejected can be sent only as 'S'- sent as final - ...N SDRET S SDRET=$S(SDREJ'="":"R",1:"S") ; indicates that it was: R - sent as rejected, S - sent as final - ...S DIC="^SDWL(409.6,"_RUNID_",1,",DA(1)=RUNID - ...S DA=APPTID,DIE=DIC,DR="4////"_SDRET D ^DIE - ..D APPT^SDRPA08(DFN,SDADT,$$DTCONV^SDRPA08(SDDAM),SDCL,SDSTAT) - ..S SDFF=$P(SDSTAT,"^",4) D STAT(SDSTTY,SDFF,.SDFIN,.SDPEN,.SDF) - ..S SDTR=SDTR+1 I SDTR=5000 D SNDS19^SDRPA07(ZTSK,.SDBCID,.SDMCID) K ^TMP("SDDPT",$J) S SDTR=0 - .Q - Q:SDOUT - I $O(^TMP("SDDPT",$J,"")) D SNDS19^SDRPA07(ZTSK,.SDBCID,.SDMCID) - K ^TMP("SDDPT",$J) - D MSGT^SDRPA04(CRUNID,SDPEN,SDFIN) - Q -STMES ;generate start message - N SDS,SD870,SD87 - S SD870=$O(^HLCS(870,"B","SD-PAIT","")) - N ARRAY D GETS^DIQ(870,SD870_",",4,"I","ARRAY") - N SD87 S SD87=SD870_"," - S SDSTAT=ARRAY(870,SD87,4,"I") - D NOW^%DTC - N SDDT,SDST S SDDT=% - S SDST=$P($$SITE^VASITE(),"^",3) - N SDAMX,XMSUB,CMY,XMTEXT,XMDUZ - S XMSUB=$G(SDST)_" - PAIT START JOB" - S XMY("G.SD-PAIT")="" - S XMY("S.SD-PAIT-SERVER@FORUM.VA.GOV")="" - S XMTEXT="SDAMX(" - S XMDUZ="POSTMASTER" - S SDAMX(1)="The PAIT job has started - TASK #: "_ZTSK - S SDAMX(2)="Site Started SD-PAIT status Task #" - S SDAMX(3)=SDST_" |"_SDDT_" |"_SDSTAT_" |"_ZTSK - ; - I SDSTAT="Shutdown" S XMY("VHACIONHD@MED.VA.GOV")="" D - .S SDAMX(4)=" Please start a REMEDY ticket for station "_SDST - .S SDAMX(5)="SD-PAIT Logical Link has to be started." - .S SDAMX(6)="Refer the ticket to Scheduling PAIT." - .S SDAMX(7)="" - D ^XMD - Q - ; -GT90DAYS(X1,X2) ; Date is older than Sep 1st 2003, see specs. - ; X1 - creation date. More efficient to have it set at the top instead of every time this subroutine is called. - ; X2 - comparison date, now sent as Sep 1 2003, both in Vista format cyymmdd - D ^%DTC - Q X>0 ; -STAT(SDSTTY,SDFF,SDFIN,SDPEN,SDF) ;summarize pending and finals - I SDSTTY="F" S SDFIN=SDFIN+1 Q - I SDSTTY="P" S SDPEN=SDPEN+1 I SDFF="F" S SDF=SDF+1 - Q +SDRPA00 ;BP-OIFO/OWAIN,ESW - Patient Appointment Information Transmission ; 11/2/04 11:09am + ;;5.3;Scheduling;**290,333,349,376**;Aug 13,1993 + Q +EN ;manual entry + N SDI,Y,ZTSK,ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSAVE,RUNID,REC + I '$$RUNCK^SDRPA02() W !,"You attempted to start PAIT outside the authorized transmission dates.",!,"Job has been terminated.",! Q + S RUNID=$O(^SDWL(409.6,":"),-1) + I RUNID S ZTSK=$P(^SDWL(409.6,RUNID,0),"^",2) D STAT^%ZTLOAD I ZTSK(1)=1!(ZTSK(1)=2) W !,"A task is currently active." Q + K ZTSK N SDCON S SDCON=1 + S %DT("A")="Queue to run: " + S %DT="AEFXR" W ! D ^%DT S DT=Y D:Y'=-1 Q:'SDCON + .S ZTDTH=Y,ZTRTN="START^SDRPA00",ZTIO="" + .S ZTDESC="PAIT" + .I RUNID I $P(^SDWL(409.6,RUNID,0),U,7)="" S SDCON=0 D + ..W !,"The previous run errored out, not repaired!",!,"Please address a problem and then use option SD-PAIT REPAIR to fix the run." + .Q:'SDCON + .F SDI=1:1:20 D ^%ZTLOAD Q:$G(ZTSK) + .I $G(ZTSK) W !,"Task # "_ZTSK_" queued!" + I '$G(ZTSK) W !!,"Task not queued, check Taskman",! Q + W !!,"Task number: ",ZTSK,! + Q +START ;Tasked entry + N SDOUT,DFN,DFNEND,SDCNT,SDCNT0,RUNID,RUNDT,SDPREV,FIRST,SDDAM,TODAY,SD6A,SD8A,SD68,RUNIDP,SDPR,ZTSKN + I '$$RUNCK^SDRPA02() Q ;check scheduling + I $G(ZTSK)="" D Q + . W !,"NOT AN INTERACTIVE OPTION...schedule through TaskMan",!! + S ZTSKN=ZTSK + S SDPR=$O(^SDWL(409.6,":"),-1) ;previous run + I SDPR N SD1 S SD1=0 D Q:SD1 ;finish if task is still running + .I $P(^SDWL(409.6,SDPR,0),U,7)'="" Q ; previous task finished + .N ZTSK + .S ZTSK=$P(^SDWL(409.6,SDPR,0),"^",2) D STAT^%ZTLOAD I ZTSK(1)=1!(ZTSK(1)=2) S SD1=1 + .;send message + .N SDAMX,XMSUB,XMY,XMTEXT,XMDUZ + .S XMSUB="PAIT BACKGROUND JOB" + .S XMY("G.SD-PAIT")="" + .S XMTEXT="SDAMX(" + .S XMDUZ="POSTMASTER" + .S SDAMX(1)="The PAIT requested task has been terminated." + .S SDAMX(2)="The previous task #: "_ZTSK_" run #: "_SDPR_" has not been completed." + .I SD1=1 S SDAMX(3)="It is still running.",SDAMX(4)="" + .E S SD1=2 D + ..S SDAMX(3)="The previous run errored out, not repaired!" + ..S SDAMX(4)="Address a problem and use option SD-PAIT REPAIR to fix the run." + .D ^XMD + S DIC=409.6,DIC(0)="X" + D NOW^%DTC S TODAY=X + K DO D FILE^DICN + S DA=+Y,DIE=DIC,DR="1///"_ZTSK D ^DIE + ;send START message + D STMES + S (SDOUT,SDCNT)=0 + K ^TMP("SDDPT",$J) + N CRUNID S CRUNID=$O(^SDWL(409.6,"AD",ZTSK,"")) + S RUNDT=$P(^SDWL(409.6,CRUNID,0),"^") + I SDPR=0 S SDPREV=3020831,FIRST=1 ;first run + E S SDPREV=$P(^SDWL(409.6,SDPR,0),U,4),FIRST=0 ; + N SDFIN,SDPEN,SDF,SDTR S (RUNID,SDFIN,SDPEN,SDTR,SDF)=0 + S SDDAM=SDPREV ;creation date + D NOW^%DTC S TODAY=X + F S SDDAM=$O(^DPT("ASADM",SDDAM)) Q:SDDAM="" Q:SDDAM=TODAY!SDOUT D + .N DFN S DFN=0 + .F S DFN=$O(^DPT("ASADM",SDDAM,DFN)) Q:+DFN'=DFN!SDOUT D + ..N SDADT S SDADT=0 ;appt date/time + ..S SDADT=0 + ..F S SDADT=$O(^DPT("ASADM",SDDAM,DFN,SDADT)) Q:+SDADT'=SDADT!SDOUT D + ...I SDDAM'=$$GET1^DIQ(2.98,SDADT_","_DFN_",",20,"I") Q ;compare creation dates + ...; Check for 'stop task' request + ...S SDCNT=SDCNT+1 I SDCNT#500=0 S SDOUT=$$S^%ZTLOAD I SDOUT D N SDBCID,SDMCID,SDSTOP D SNDS19^SDRPA07(ZTSK,.SDBCID,.SDMCID) S SDSTOP=1 D MSGT^SDRPA03(CRUNID,SDPEN,SDFIN,,SDSTOP) K ^TMP("SDDPT",$J) Q + ....N DA,DIE,DR,SDD,SDLAST D + ....S SDLAST=$O(^SDWL(409.6,CRUNID,1,"B"),-1) S SDD=$P(^SDWL(409.6,CRUNID,1,SDLAST,0),U,7)-1 + ....S DA=CRUNID,DIE=409.6,DR="1.2///"_SDD D ^DIE + ...N SDCL,SDSTAT,SDSTTY + ...S SDCL=$$GET1^DIQ(2.98,SDADT_","_DFN_",",.01,"I") + ...Q:SDCL="" ; If this happens, there's something wrong. Do we need to handle exceptions like this? + ...; + ...; Check status. + ...; If the appointment is finalized and it is the first run, do not send if the date appoinment made is before Sep 1, 2003 + ...; If it is not the first run, send but don't create a pending file + ...; Otherwise add to pending file. + ...D NOW^%DTC N STODAY S STODAY=X + ...S SDSTAT=$$STATUS^SDRPA05(DFN,SDADT,SDCL,STODAY,1) + ...I $P(SDSTAT,"^")=0 Q + ...N SDCLL S SDCLL=$P(SDSTAT,U,6) I SDCLL'="" S SDCL=SDCLL ;assign a new clinic if from matching non count with encounter + ...S SDSTTY=$P(SDSTAT,U,2),SD6A=$P(SDSTAT,U,3),SD8A=$P(SDSTAT,U,4) + ...I SDSTTY="F" Q:'$$GT90DAYS(SDDAM,3030831) ; pending and final from 09/01/2003, previously 90 days + ...I SDSTTY="F",SD6A="NM",SD8A="NC" Q ; skip non-count if not matching count and scheduled date already expired + ...N SDCOA,SDMSHA S SDCOA=$P(SDSTAT,U,5) S SDMSHA=$P(SDSTAT,U) + ...N SDCE Q:'$$DPT^SDRPA08(DFN,.SDCE) ; Create demographic node of ^TMP file. Quit if this failed. + ...N DIC,DA,X,SDRET D + ....N SDRET S SDRET=$S(SDSTTY="F":"N",1:"Y") + ....S DIC="^SDWL(409.6,"_CRUNID_",1,",DA(1)=CRUNID,DIC("P")=409.69,DIC(0)="X" + ....K DO S X=DFN D FILE^DICN + ....S DA=+Y,DIE=DIC,DR="1///"_SDADT_";4///"_SDRET_";5///"_SD6A_";6///"_SDDAM_";8///"_SD8A_";9////"_SDCL D ^DIE + ....Q + ...D APPT^SDRPA08(DFN,SDADT,$$DTCONV^SDRPA08(SDDAM),SDCL,SDSTAT) + ...S SDFF=$P(SDSTAT,"^",4) D STAT(SDSTTY,SDFF,.SDFIN,.SDPEN,.SDF) + ...S SDTR=SDTR+1 I SDTR=5000 D SNDS19^SDRPA07(ZTSK,.SDBCID,.SDMCID) K ^TMP("SDDPT",$J) S SDTR=0 + Q:SDOUT + N SDD S SDD=$O(^DPT("ASADM",TODAY),-1) ;enter the last scanned day + S DA=CRUNID,DIE=409.6,DR="1.2///"_SDD D ^DIE + ; scan the previous runs + S RUNID=0 + F S RUNID=$O(^SDWL(409.6,RUNID)) Q:+RUNID=CRUNID!SDOUT D + .N APPTID,SDADT,REC + .S APPTID=0 + .;scanning only appointments that were sent as 'pending' + .F S APPTID=$O(^SDWL(409.6,"AE","Y",RUNID,APPTID)) Q:APPTID=""!SDOUT S REC=$G(^SDWL(409.6,RUNID,1,APPTID,0)) D + ..IF REC="" K ^SDWL(409.6,"AE","Y",RUNID,APPTID) Q ;anticipate + ..S DFN=$P(REC,"^"),SDADT=$P(REC,"^",2) + ..; Check for 'stop task' + ..S SDCNT=SDCNT+1 I SDCNT#500=0 S SDOUT=$$S^%ZTLOAD I SDOUT N SDBCID,SDMCID,SDSTOP D SNDS19^SDRPA07(ZTSK,.SDBCID,.SDMCID) S SDSTOP=1 D MSGT^SDRPA03(CRUNID,SDPEN,SDFIN,,SDSTOP) K ^TMP("SDDPT",$J) Q ; + ..N SDCL,SDCLO,SDCE,SDSTAT,SDREJ,SDDAM,SDDAMO + ..S SDCLO=$P(REC,"^",10) + ..S SDREJ=$P(REC,"^",8),SDDAMO=$P(REC,"^",7) ;esw + ..I SDDAMO="" D + ...N SDD S SDD=9999999 F S SDD=$O(^DPT("ASADM",SDD),-1) Q:SDD'>0 I $D(^DPT("ASADM",SDD,DFN,SDADT)) S SDDAMO=SDD Q + ..Q:SDDAMO="" ;cannot determine what was original creation date + ..;evaluate if the same creation date + ..S SDDAM=$$GET1^DIQ(2.98,SDADT_","_DFN_",",20,"I") + ..S SDCL=$$GET1^DIQ(2.98,SDADT_","_DFN_",",.01,"I") + ..Q:SDCL="" ; + ..I SDCLO="" S SDCLO=SDCL + ..I SDDAM'?7N!(SDDAM'>3020831) S SDDAM=SDDAMO ; need to finalize the previously sent + ..; Check status. If it is a termination, continue. + ..Q:$D(^TMP("SDDPT",$J,DFN,SDADT)) ; overridden to be process next time + ..;anothercross reference entry will be created; do not need to quit + ..;Q:$D(^SDWL(409.6,"AC",DFN,SDADT,+$G(CRUNID))) ;see above + ..S SDSTAT="" + ..I SDDAM'=SDDAMO!(SDCL'=SDCLO) D + ...; create CT status; the current SDADT has different creation date + ...S SDSTAT="S15"_U_"F"_U_"CT"_U_U_U_U_U S SDDAM=SDDAMO,SDCL=SDCLO + ..I SDSTAT="" D NOW^%DTC N SDTODAY S SDTODAY=X S SDSTAT=$$STATUS^SDRPA05(DFN,SDADT,SDCL,SDTODAY,0) + ..I $P(SDSTAT,"^")=0 Q + ..N SDCOA,SDMSHA S SDCOA=$P(SDSTAT,U,5) S SDMSHA=$P(SDSTAT,U),SD6A=$P(SDSTAT,U,3),SD8A=$P(SDSTAT,U,4) + ..N SDCLL S SDCLL=$P(SDSTAT,U,6) I SDCLL'="" S SDCL=SDCLL + ..S SDSTTY=$P(SDSTAT,U,2) + ..I SDSTTY="P"&(SDREJ="") Q ;do not send in pending status if not rejected ;esw + ..N SDCE Q:'$$DPT^SDRPA08(DFN,.SDCE) ; Create demographic node of ^TMP file. Quit if this failed. + ..N DIC,DA,X D + ...N SDRET S SDRET=$S(SDSTTY="F":"N",1:"Y") + ...S DIC="^SDWL(409.6,"_CRUNID_",1,",DA(1)=CRUNID,DIC("P")=409.69,DIC(0)="X" + ...K DO S X=DFN D FILE^DICN + ...S DA=+Y,DIE=DIC,DA=+Y,DR="1///"_SDADT_";4///"_SDRET_";5///"_SD6A_";6///"_SDDAM_";8///"_SD8A_";9////"_SDCL D ^DIE + ...Q + ..N DIC,DA D + ...; not rejected can be sent only as 'S'- sent as final + ...N SDRET S SDRET=$S(SDREJ'="":"R",1:"S") ; indicates that it was: R - sent as rejected, S - sent as final + ...S DIC="^SDWL(409.6,"_RUNID_",1,",DA(1)=RUNID + ...S DA=APPTID,DIE=DIC,DR="4////"_SDRET D ^DIE + ...Q + ..D APPT^SDRPA08(DFN,SDADT,$$DTCONV^SDRPA08(SDDAM),SDCL,SDSTAT) + ..S SDFF=$P(SDSTAT,"^",4) D STAT(SDSTTY,SDFF,.SDFIN,.SDPEN,.SDF) + ..S SDTR=SDTR+1 I SDTR=5000 D SNDS19^SDRPA07(ZTSK,.SDBCID,.SDMCID) K ^TMP("SDDPT",$J) S SDTR=0 + ..Q + .Q + Q:SDOUT + I $O(^TMP("SDDPT",$J,"")) D SNDS19^SDRPA07(ZTSK,.SDBCID,.SDMCID) + K ^TMP("SDDPT",$J) + D MSGT^SDRPA03(CRUNID,SDPEN,SDFIN) + Q +STMES ;generate start message + N SDS,SD870,SD87 + S SD870=$O(^HLCS(870,"B","SD-PAIT","")) + N ARRAY D GETS^DIQ(870,SD870_",",4,"I","ARRAY") + N SD87 S SD87=SD870_"," + S SDSTAT=ARRAY(870,SD87,4,"I") + D NOW^%DTC + N SDDT,SDST S SDDT=% + S SDST=$P($$SITE^VASITE(),"^",3) + N SDAMX,XMSUB,CMY,XMTEXT,XMDUZ + S XMSUB=$G(SDST)_" - PAIT START JOB" + S XMY("G.SD-PAIT")="" + S XMY("S.SD-PAIT-SERVER@FORUM.VA.GOV")="" + S XMTEXT="SDAMX(" + S XMDUZ="POSTMASTER" + S SDAMX(1)="The PAIT job has started - TASK #: "_ZTSK + S SDAMX(2)="Site Started SD-PAIT status Task #" + S SDAMX(3)=SDST_" |"_SDDT_" |"_SDSTAT_" |"_ZTSK + ; + I SDSTAT="Shutdown" S XMY("VHACIONHD@MED.VA.GOV")="" D + .S SDAMX(4)=" Please start NOIS call for station "_SDST + .S SDAMX(5)="SD-PAIT Logical Link has to be started." + .S SDAMX(6)="" + D ^XMD + Q + ; +GT90DAYS(X1,X2) ; Date is older than Sep 1st 2003, see specs. + ; X1 - creation date. More efficient to have it set at the top instead of every time this subroutine is called. + ; X2 - comparison date, now sent as Sep 1 2003, both in Vista format cyymmdd + D ^%DTC + Q X>0 ; +STAT(SDSTTY,SDFF,SDFIN,SDPEN,SDF) ;summarize pending and finals + I SDSTTY="F" S SDFIN=SDFIN+1 Q + I SDSTTY="P" S SDPEN=SDPEN+1 I SDFF="F" S SDF=SDF+1 + Q diff --git a/r/SCHEDULING-SD-SC/SDRPA04.m b/r/SCHEDULING-SD-SC/SDRPA04.m index 28a3ea86..7da8da92 100644 --- a/r/SCHEDULING-SD-SC/SDRPA04.m +++ b/r/SCHEDULING-SD-SC/SDRPA04.m @@ -1,143 +1,140 @@ -SDRPA04 ;BP-OIFO/ESW - SDRPA00 continuation PAIT - REPAIR ; 11/2/04 11:47am ; 5/31/07 5:29pm - ;;5.3;Scheduling;**376,491**;Aug 13, 1993;Build 53 - ;SD/491 - not to error out while repairing with acks having received - Q -MSGT(CRUNID,SDPEN,SDFIN,SDTOT,SDSTOP) ;create completion messages - ;CRUNID - current run number - ;SDPEN - pendings - ;SDFIN - finals - ;SDTOT - total - ;SDSTOP - task stop flag - N SDB,SDTRF - I '$D(SDTOT) S SDTOT=SDPEN+SDFIN - N SFF S SFF=0 - I +SDTOT=0 S (SDPEN,SDFIN)=0,SFF=1 - I '$D(SDPEN),'$D(SDFIN) S (SDPEN,SDFIN)="undetermined",SFF=1 - N SDB,SDTRF - S SDB=SDTOT\5000 I SDTOT-(5000*SDB)>0 S SDB=SDB+1 ;# of batches - N NOW S NOW=$$NOW^XLFDT S SDTRF=$$FMTE^XLFDT(NOW,2),SDTRF=$P(SDTRF,":",1,2) - N DA,DIE,DR D - .S DA=CRUNID,DIE=409.6,DR="1.3///"_SDTOT_";1.4///"_SDB_";1.5///"_NOW D ^DIE - D CLEAN(CRUNID) - N SDS,SDSTAT,SDIP,SDAR,SDAP,SDMT,SDMS,SD870 - ;SDS - STATION # - ;SDSTAT - SD-PAIT STATUS - ;SDAIP - IP ADDRESS - ;SDAR - COMMIT ACK RECEIVED - ;SDAP - COMMIT ACK PROCESSED - ;SDMT - MESSAGES (BATCHES) TO SEND - ;SDMS - MESSAGES (BATCHES) SENT - S SD870=$O(^HLCS(870,"B","SD-PAIT","")) - N ARRAY D GETS^DIQ(870,SD870_",","4;5;6;7;8;400.01","I","ARRAY") - N SD87 S SD87=SD870_"," - S SDSTAT=ARRAY(870,SD87,4,"I") - S SDAR=ARRAY(870,SD87,5,"I") - S SDAP=ARRAY(870,SD87,6,"I") - S SDMS=ARRAY(870,SD87,7,"I") - S SDMT=ARRAY(870,SD87,8,"I") - S SDIP=ARRAY(870,SD87,400.01,"I") - S SDS=$P($$SITE^VASITE(),"^",3) - ;S SDS=$E($O(^SDWL(409.6,"AMSG","")),1,3) - N SDBT,STSK,SDSL ; Starting and Last scanned date - S SDBT=$P(^SDWL(409.6,CRUNID,0),U),SDSL=$P(^SDWL(409.6,CRUNID,0),U,4) - S STSK=$P(^SDWL(409.6,CRUNID,0),U,2) - S SDBT=$$FMTE^XLFDT(SDBT,2),SDSL=$$FMTE^XLFDT(SDSL,2) -MSG ;send mail message - N SDAMX,XMSUB,XMY,XMTEXT,XMDUZ - S XMSUB=$G(SDS)_" - PAIT BACKGROUND JOB" - S XMY("G.SD-PAIT")="" - S XMY("S.SD-PAIT-SERVER@FORUM.VA.GOV")="" - S XMTEXT="SDAMX(" - S DUZ="" - S XMDUZ="POSTMASTER" - S SDAMX(1)="" - S SDAMX(2)="The PAIT job has completed - TASK #: "_STSK_" Log #: "_CRUNID_" on "_SDTRF - S SDAMX(3)="Started: "_SDBT_" Last Scanned: "_SDSL - S SDAMX(4)="Pending appointments: "_$J(SDPEN,10) - S SDAMX(5)="Final appointments: "_$J(SDFIN,10) - S SDAMX(6)=" ----------" - S SDAMX(7)="Total appointments: "_$J(SDTOT,10)_" Number of batches: "_SDB - S SDAMX(8)="" - S SDAMX(9)="Fac Log Bch Appt # Date finished IP Address Gen Sent Com R Com P Status" - S SDAMX(10)="-----------------------------------------------------------------------" - S SDAMX(11)=SDS_"|"_$J(CRUNID,3)_"|"_$J(SDB,3)_"|"_$J(SDTOT,7)_"|"_SDTRF_"|"_$J(SDIP,11)_"|"_$J(SDMT,4)_"|"_$J(SDMS,4)_"|"_$J(SDAR,4)_"|"_$J(SDAP,4)_"| "_SDSTAT - S SDAMX(12)="" - I $G(SDSTOP) S XMY("VHACIONHD@MED.VA.GOV")="" D D ^XMD Q - .S SDAMX(13)="WARNING: TASK STOPPED BY USER, NEEDS TO BE RESTARTED." - .S SDAMX(14)="Initiate a Remedy ticket TO FOLLOW UP." - I 'SFF I SDMT>0!(SDB=0) D D ^XMD K ^TMP("SDDPT",$J) Q - .I (SDMT-SDMS)=0 D Q - ..S SDAMX(13)="SUCCESS: Transmission completed." - .I (SDMT-SDMS)0 I (SDMT-SDMS)'0 I (SDMT-SDMS)'1 - W !,"The repairing in progress...",! - N SDE,SDEB,SDFE,SDLSD,SDRCNT,ZTSK - S SDE=$G(^SDWL(409.6,RUN,0)) Q:SDE="" - S ZTSK=$P(SDE,"^",2) D STAT^%ZTLOAD I ZTSK(1)=1!(ZTSK(1)=2) W !,"Task "_ZTSK_"is still active!" Q - S SDEB=+$P(SDE,"^",3) ; last batch # submitted to HL7 - S SDRCNT=$O(^SDWL(409.6,RUN,1,999999999),-1) ;last entry - I SDEB=0 S SDFE=0 S $P(^SDWL(409.6,RUN,0),U,4)=$P(^SDWL(409.6,RUN-1,0),U,4) - I +SDEB>0 D - .S SDFE=SDRCNT+1 F S SDFE=$O(^SDWL(409.6,RUN,1,SDFE),-1) I $P(^SDWL(409.6,RUN,1,SDFE,0),U,3)'>SDEB&($P(^SDWL(409.6,RUN,1,SDFE,0),U,3)'="") Q ; SD/491 - .N SDLSD1 S SDLSD1=$P(^SDWL(409.6,RUN,1,SDFE,0),U,7) ;retrieve the last used creation date of HL7 created - .N SDLSD2 S SDLSD2=$P($G(^SDWL(409.6,RUN,1,SDFE+1,0)),U,7) - .S SDLSD=$P(SDE,U,4) ; last scanned date - .I SDLSD="" D - ..S $P(^SDWL(409.6,RUN,0),U,4)=$S(SDLSD2>SDLSD1:SDLSD1,1:SDLSD1-1) - .E S $P(^SDWL(409.6,RUN,0),U,4)=SDLSD-1 - N SDS,DIK F SDS=SDFE+1:1:SDRCNT I $D(^SDWL(409.6,RUN,1,SDS,0)) D EVAL(RUN,SDS) S DIK="^SDWL(409.6,"_RUN_",1,",DA(1)=RUN,DA=SDS D ^DIK - S SDB=+$P($G(^SDWL(409.6,RUN,2,0)),U,3) - S NOW=$$NOW^XLFDT,SDFE=5000*SDB - S $P(^SDWL(409.6,RUN,0),U,5)=SDFE - S $P(^SDWL(409.6,RUN,0),U,6)=SDB - S $P(^SDWL(409.6,RUN,0),U,7)=NOW - D MSGT(RUN,,,SDFE) - W !!,"The last run number has been repaired, you may ONE TIME QUEUE the next one.",! - Q -EVAL(RUN,SDS) ; - ;evaluate if to update any 'S' or 'R' Retention Flags for - ;the previous entry if exists. - N SDSTR,DFN,SDDT S SDSTR=^SDWL(409.6,RUN,1,SDS,0) - S DFN=+SDSTR,SDDT=$P(SDSTR,"^",2) - Q:SDDT="" - ;find a prior entry SDRUN - N SDRUN S SDRUN=$O(^SDWL(409.6,"AC",DFN,SDDT,RUN),-1) Q:SDRUN="" - N SDSQ S SDSQ=$O(^SDWL(409.6,"AC",DFN,SDDT,SDRUN,"")) - N SDSTRP S SDSTRP=^SDWL(409.6,SDRUN,1,SDSQ,0) - N SDRET S SDRET=$P(SDSTRP,"^",5) - I SDRET="S"!(SDRET="R") N DIC D - .S SDRET="Y",DIC="^SDWL(409.6,"_SDRUN_",1,",DA(1)=SDRUN,DA=SDSQ,DIE=DIC,DR="4///"_SDRET D ^DIE - Q +SDRPA04 ;BP-OIFO/ESW - PAIT - REPAIR ; 11/2/04 11:47am + ;;5.3;Scheduling;**376**;Aug 13, 1993 + Q +MSGT(CRUNID,SDPEN,SDFIN,SDTOT,SDSTOP) ;create completion messages + ;CRUNID - current run number + ;SDPEN - pendings + ;SDFIN - finals + ;SDTOT - total + ;SDSTOP - task stop flag + N SDB,SDTRF + I '$D(SDTOT) S SDTOT=SDPEN+SDFIN + N SFF S SFF=0 + I +SDTOT=0 S (SDPEN,SDFIN)=0,SFF=1 + I '$D(SDPEN),'$D(SDFIN) S (SDPEN,SDFIN)="undetermined",SFF=1 + N SDB,SDTRF + S SDB=SDTOT\5000 I SDTOT-(5000*SDB)>0 S SDB=SDB+1 ;# of batches + N NOW S NOW=$$NOW^XLFDT S SDTRF=$$FMTE^XLFDT(NOW,2),SDTRF=$P(SDTRF,":",1,2) + N DA,DIE,DR D + .S DA=CRUNID,DIE=409.6,DR="1.3///"_SDTOT_";1.4///"_SDB_";1.5///"_NOW D ^DIE + D CLEAN(CRUNID) + N SDS,SDSTAT,SDIP,SDAR,SDAP,SDMT,SDMS,SD870 + ;SDS - STATION # + ;SDSTAT - SD-PAIT STATUS + ;SDAIP - IP ADDRESS + ;SDAR - COMMIT ACK RECEIVED + ;SDAP - COMMIT ACK PROCESSED + ;SDMT - MESSAGES (BATCHES) TO SEND + ;SDMS - MESSAGES (BATCHES) SENT + S SD870=$O(^HLCS(870,"B","SD-PAIT","")) + N ARRAY D GETS^DIQ(870,SD870_",","4;5;6;7;8;400.01","I","ARRAY") + N SD87 S SD87=SD870_"," + S SDSTAT=ARRAY(870,SD87,4,"I") + S SDAR=ARRAY(870,SD87,5,"I") + S SDAP=ARRAY(870,SD87,6,"I") + S SDMS=ARRAY(870,SD87,7,"I") + S SDMT=ARRAY(870,SD87,8,"I") + S SDIP=ARRAY(870,SD87,400.01,"I") + S SDS=$P($$SITE^VASITE(),"^",3) + ;S SDS=$E($O(^SDWL(409.6,"AMSG","")),1,3) + N SDBT,STSK,SDSL ; Starting and Last scanned date + S SDBT=$P(^SDWL(409.6,CRUNID,0),U),SDSL=$P(^SDWL(409.6,CRUNID,0),U,4) + S STSK=$P(^SDWL(409.6,CRUNID,0),U,2) + S SDBT=$$FMTE^XLFDT(SDBT,2),SDSL=$$FMTE^XLFDT(SDSL,2) +MSG ;send mail message + N SDAMX,XMSUB,XMY,XMTEXT,XMDUZ + S XMSUB=$G(SDS)_" - PAIT BACKGROUND JOB" + S XMY("G.SD-PAIT")="" + S XMY("S.SD-PAIT-SERVER@FORUM.VA.GOV")="" + S XMTEXT="SDAMX(" + S DUZ="" + S XMDUZ="POSTMASTER" + S SDAMX(1)="" + S SDAMX(2)="The PAIT job has completed - TASK #: "_STSK_" Log #: "_CRUNID_" on "_SDTRF + S SDAMX(3)="Started: "_SDBT_" Last Scanned: "_SDSL + S SDAMX(4)="Pending appointments: "_$J(SDPEN,10) + S SDAMX(5)="Final appointments: "_$J(SDFIN,10) + S SDAMX(6)=" ----------" + S SDAMX(7)="Total appointments: "_$J(SDTOT,10)_" Number of batches: "_SDB + S SDAMX(8)="" + S SDAMX(9)="Fac Log Bch Appt # Date finished IP Address Gen Sent Com R Com P Status" + S SDAMX(10)="-----------------------------------------------------------------------" + S SDAMX(11)=SDS_"|"_$J(CRUNID,3)_"|"_$J(SDB,3)_"|"_$J(SDTOT,7)_"|"_SDTRF_"|"_$J(SDIP,11)_"|"_$J(SDMT,4)_"|"_$J(SDMS,4)_"|"_$J(SDAR,4)_"|"_$J(SDAP,4)_"| "_SDSTAT + S SDAMX(12)="" + I $G(SDSTOP) S XMY("VHACIONHD@MED.VA.GOV")="" D D ^XMD Q + .S SDAMX(13)="WARNING: TASK STOPPED BY USER, NEEDS TO BE RESTARTED." + .S SDAMX(14)="INITIATE a NOIS TO FOLLOW UP." + I 'SFF I SDMT>0!(SDB=0) D D ^XMD Q + .I (SDMT-SDMS)=0 D Q + ..S SDAMX(13)="SUCCESS: Transmission completed." + .I (SDMT-SDMS)0 I (SDMT-SDMS)'1 + W !,"The repairing in progress...",! + N SDE,SDEB,SDFE,SDLSD,SDRCNT,ZTSK + S SDE=$G(^SDWL(409.6,RUN,0)) Q:SDE="" + S ZTSK=$P(SDE,"^",2) D STAT^%ZTLOAD I ZTSK(1)=1!(ZTSK(1)=2) W !,"Task "_ZTSK_"is still active!" Q + S SDEB=+$P(SDE,"^",3) ; last batch # submitted to HL7 + S SDRCNT=$O(^SDWL(409.6,RUN,1,999999999),-1) ;last entry + I SDEB=0 S SDFE=0 S $P(^SDWL(409.6,RUN,0),U,4)=$P(^SDWL(409.6,RUN-1,0),U,4) + I +SDEB>0 D + .S SDFE=SDRCNT+1 F S SDFE=$O(^SDWL(409.6,RUN,1,SDFE),-1) I $P(^SDWL(409.6,RUN,1,SDFE,0),U,3)=SDEB Q ; last accepted entry + .N SDLSD1 S SDLSD1=$P(^SDWL(409.6,RUN,1,SDFE,0),U,7) ;retrieve the last used creation date of HL7 created + .N SDLSD2 S SDLSD2=$P($G(^SDWL(409.6,RUN,1,SDFE+1,0)),U,7) + .S SDLSD=$P(SDE,U,4) ; last scanned date + .I SDLSD="" D + ..S $P(^SDWL(409.6,RUN,0),U,4)=$S(SDLSD2>SDLSD1:SDLSD1,1:SDLSD1-1) + .E S $P(^SDWL(409.6,RUN,0),U,4)=SDLSD-1 + N SDS,DIK F SDS=SDFE+1:1:SDRCNT D EVAL(RUN,SDS) S DIK="^SDWL(409.6,"_RUN_",1,",DA(1)=RUN,DA=SDS D ^DIK + S SDB=SDFE\5000 I SDFE-(5000*SDB)>0 S SDB=SDB+1 + S NOW=$$NOW^XLFDT + S $P(^SDWL(409.6,RUN,0),U,5)=SDFE + S $P(^SDWL(409.6,RUN,0),U,6)=SDB + S $P(^SDWL(409.6,RUN,0),U,7)=NOW + D MSGT(RUN,,,SDFE) + W !!,"The last run number has been repaired, you may ONE TIME QUEUE the next one.",! + Q +EVAL(RUN,SDS) ; + ;evaluate if to update any 'S' or 'R' Retention Flags for + ;the previous entry if exists. + N SDSTR,DFN,SDDT S SDSTR=^SDWL(409.6,RUN,1,SDS,0) + S DFN=+SDSTR,SDDT=$P(SDSTR,"^",2) + ;find a prior entry SDRUN + N SDRUN S SDRUN=$O(^SDWL(409.6,"AC",DFN,SDDT,RUN),-1) Q:SDRUN="" + N SDSQ S SDSQ=$O(^SDWL(409.6,"AC",DFN,SDDT,SDRUN,"")) + N SDSTRP S SDSTRP=^SDWL(409.6,SDRUN,1,SDSQ,0) + N SDRET S SDRET=$P(SDSTRP,"^",5) + I SDRET="S"!(SDRET="R") N DIC D + .S SDRET="Y",DIC="^SDWL(409.6,"_SDRUN_",1,",DA(1)=SDRUN,DA=SDSQ,DIE=DIC,DR="4///"_SDRET D ^DIE + Q diff --git a/r/SCHEDULING-SD-SC/SDRPA05.m b/r/SCHEDULING-SD-SC/SDRPA05.m index 860a9f6d..3a975d3a 100644 --- a/r/SCHEDULING-SD-SC/SDRPA05.m +++ b/r/SCHEDULING-SD-SC/SDRPA05.m @@ -1,105 +1,104 @@ -SDRPA05 ;BP-OIFO/ESW - Evaluate appointment status for HL7 ; 9/10/04 9:34am - ;;5.3;Scheduling;**290,333,349,376,491**;AUG 13, 2003;Build 53 - ;Evaluation of the appointment status is done from the computed field to match the displayed/printed status in the appointment management - ;SD/491 - MODIFIED $$SCHEDULE to cut off appointments considered as rescheduled by with the scheduled date<2250000 - Q - ; -STATUS(DFN,SDADT,SDCL,TODAY,SFD) ; - ;Input: - ; SDADT - Appt date/time - ; SDCL - Clinic IEN - ; SFD: - 0 - if called from scanning previous runs - update - ; - 1 - if called from scanning 2.98 - ;Output: - ; SDSTAT=SDMSH_U_SD25_U_SD6_U_SD8_U_SDCO_U_SDCLL_U_SD8RD - ; where: - ; SDMSH -HL7 segment - ; SD25 - Filler Status: - ; P - Pending - ; F - Final - ; SD6 - Event Reason - ; SD8 - Appt Type - ; SD8RD - rescheduled date/time if SD8="RS" - ; SDCO - check out date - ; SDCLL - clinic IEN from matching encounter - ; - N SD0,SDST,SD6,SD8,SD25,SDMSH,SDCO,SDSTAT,SD8S,SD8RD - S SDST=$$GET1^DIQ(2.98,SDADT_","_DFN_",",3,"I") - I SDST'="" I SDST'="NT"&(SDST'="I") D Q SDSTAT - .S SD25="F",SDCO="",SD8RD="" - .I SDST="C" S SD6="CC",SD8="",SDMSH="S15" D ;cancel by clinic - ..S SD8S=$$SCHEDULE(DFN,SDCL,SDADT),SD8=$P(SD8S,U),SD8RD=$P(SD8S,U,2) - .I SDST="CA" S SD6="CC",SD8="ABK",SDMSH="S15" ;cancel bt clinic and auto rebook - .I SDST="PC" S SD6="CP",SD8="",SDMSH="S15" D ; cancel by patient - ..S SD8S=$$SCHEDULE(DFN,SDCL,SDADT),SD8=$P(SD8S,U),SD8RD=$P(SD8S,U,2) - .I SDST="PCA" S SD6="CP",SD8="ABK",SDMSH="S15" ;cancel by patient and auto rebook - .I SDST="NA" S SD6="NS",SD8="ABK",SDMSH="S26" ;no show and auto rebook - .I SDST="N" S SD6="NS",SD8="",SDMSH="S26" ;no show - .;evaluate 'non-count' - .I $P($G(^SC(SDCL,0)),U,17)="Y" D - ..I SD8="" S SD8="NC" Q - ..I SD8="RS" S SD8="RSN" - .; - .S SDSTAT=SDMSH_U_SD25_U_SD6_U_SD8_U_SDCO_U_U_SD8RD - ;process all others - S SD0=^DPT(DFN,"S",SDADT,0) - ; check out from OUTPAT ENCOUNTER - ;N SCE S SCE=$P(SD0,"^",20) S SDCO="" I SCE>0 S SDCO=$P(^SCE(SCE,0),"^",7) - N SCE S SCE=$P(SD0,"^",20) S SDCO="" I SCE>0,$D(^SCE(SCE,0)) S SDCO=$P(^SCE(SCE,0),"^",7) - N SDSTATX,SDX3 - S SDSTATX=$$STATUS^SDAM1(DFN,SDADT,SDCL,SD0) ;call to compute the status (VistA) - ;SDSTATX=Appt status IFN in 409.63 ; status name ; print status ; check in ; check out - I SDCO="" S SDCO=$P(SDSTATX,";",5) ; check out from clinic if NULL - I SDCO'=""&(+SDSTATX'=12) D Q SDSTAT - .S SD6="CO",SD25="F",SD8="",SD8RD="",SDMSH=$S(SFD=0:"S14",1:"S12") - .I +SDSTATX=3 S SD8="AR" ; action required - .I +SDSTATX=8 S SD8="I" ;inpatient - .;I +SDSTATX=12 S SD8="NC" ;non-count excluded to be compared to possible encounter does not matter if check out - .I +SDSTATX=2 S SD8="O" ;outpatient - .S SDSTAT=SDMSH_U_SD25_U_SD6_U_SD8_U_SDCO_U_U_SD8RD - I +SDSTATX=3 D Q SDSTAT - .S SD25="P",SDMSH="S12",SDCO="",SD8RD="" - .I $P(SDSTATX,";",4)'="" S SD6="CI",SD8="AR" ;check in/action required - .E S SD6="",SD8="NAT",SD8RD="" ;no action taken - .S SDSTAT=SDMSH_U_SD25_U_SD6_U_SD8_U_SDCO_U_U_SD8RD - I +SDSTATX=8!(+SDSTATX=11) S SD25="P",SD8RD="" D Q SDSTAT - .I +SDSTATX=8 S SD6="",SD8="I",SDCO="",SDMSH="S12" ;inpatient - .I +SDSTATX=11 S SD6="",SD8="F",SDCO="",SDMSH="S12" ;future - .S SDSTAT=SDMSH_U_SD25_U_SD6_U_SD8_U_SDCO_U_U_SD8RD - ; - ;process non-count (not checked out) - I +SDSTATX=12 N SDCLL S SDCLL="" D S:SD6'="COE" SDCLL=SDCL S SDSTAT=SDMSH_U_SD25_U_SD6_U_SD8_U_SDCO_U_SDCLL Q SDSTAT - .S SD6="",SD8="NC",SDCO="",SDMSH="S12",SD25="P" - .I (SDADT\1)-(TODAY\1)>0 S SD6="",SD8="NCF",SD25="P" Q - .N SDADTC,SDSCE,SDADTCK S SDADTC=(SDADT\1)-1+.99,SDADTCK=SDADTC+1 F D Q:'SDSCE!(SD6="COE") - ..S SDSCE=$$EXAE^SDOE(DFN,SDADTC,SDADTCK) - ..I SDSCE>1 N SDDATA D GETGEN^SDOE(SDSCE,"SDDATA") D - ...N SDCL0,SDCL1,SDCL2 - ...S SDCLL=$P(SDDATA(0),"^",4) I $P(^SC(SDCLL,0),"^",17)="Y" D Q - ....S SDADTC=$P(^SCE(SDSCE,0),"^")+.000001 ; - ...S SDCL0=$P(^SC(SDCL,0),"^",7)_$P(^SC(SDCL,0),"^",18) - ...S SDCL2=$P(^SC(SDCLL,0),"^",7)_$P(^SC(SDCLL,0),"^",18) - ...I SDCL0'=SDCL2 S SDADTC=$P(^SCE(SDSCE,0),"^")+.000001 Q - ...; proceed if the same DSS IDs pairs - ...S SDCO=$P(SDDATA(0),"^",7) - ...I SDCO'="" S SD6="COE",SD25="F",SDMSH=$S(SFD=0:"S14",1:"S12") Q - ...;encounter exists but not in final (chek out) status - ...S SDADTC=$P(^SCE(SDSCE,0),"^")+.000001 - .I SD6="COE" Q - .;check out by matching encounter - .E I ((TODAY\1)-(SDADT\1))>2 D ;give 2 days to update - ..S SD6="NM",SD25="F",SDMSH=$S(SFD=0:"S14",1:0) ;no match, to be skipped - Q 0 - ; -SCHEDULE(DFN,SDCL,SDADT) ; Scheduling flag - ; If the patient has another appointment created on the same day as the cancellation date of the canceled appt, and that - ; appointment is created for a clinic with the same stop code then return "RS". - ; If there is not another appointment made on the same day, return "". - N SDCDT,SDCLN S SDCDT=$$GET1^DIQ(2.98,SDADT_","_DFN_",",15,"I") ;cancellation date - Q:'SDCDT "" - N SDCDTI S SDCDTI=SDCDT\1 - N SDRESCH S SDRESCH="" - ;exclude the same appointments - N SDAPDT S SDAPDT="" F S SDAPDT=$O(^DPT("ASADM",SDCDTI,DFN,SDAPDT)) Q:SDAPDT="" I SDAPDT>3030000 I SDAPDT'=SDADT I $D(^DPT(DFN,"S",SDAPDT)) D Q:SDRESCH'="" - .S SDCLN=+$P(^DPT(DFN,"S",SDAPDT,0),U) I $P(^SC(SDCLN,0),"^",7)=$P(^SC(SDCL,0),"^",7) S SDRESCH="RS"_"^"_SDAPDT ;compare stop code pointers - S:SDRESCH="" SDRESCH="^" Q SDRESCH +SDRPA05 ;BP-OIFO/ESW - Evaluate appointment status for HL7 ; 9/10/04 9:34am + ;;5.3;Scheduling;**290,333,349,376**;AUG 13, 2003 + ;Evaluation of the appointment status is done from the computed field to match the displayed/printed status in the appointment management + Q + ; +STATUS(DFN,SDADT,SDCL,TODAY,SFD) ; + ;Input: + ; SDADT - Appt date/time + ; SDCL - Clinic IEN + ; SFD: - 0 - if called from scanning previous runs - update + ; - 1 - if called from scanning 2.98 + ;Output: + ; SDSTAT=SDMSH_U_SD25_U_SD6_U_SD8_U_SDCO_U_SDCLL_U_SD8RD + ; where: + ; SDMSH -HL7 segment + ; SD25 - Filler Status: + ; P - Pending + ; F - Final + ; SD6 - Event Reason + ; SD8 - Appt Type + ; SD8RD - rescheduled date/time if SD8="RS" + ; SDCO - check out date + ; SDCLL - clinic IEN from matching encounter + ; + N SD0,SDST,SD6,SD8,SD25,SDMSH,SDCO,SDSTAT,SD8S,SD8RD + S SDST=$$GET1^DIQ(2.98,SDADT_","_DFN_",",3,"I") + I SDST'="" I SDST'="NT"&(SDST'="I") D Q SDSTAT + .S SD25="F",SDCO="",SD8RD="" + .I SDST="C" S SD6="CC",SD8="",SDMSH="S15" D ;cancel by clinic + ..S SD8S=$$SCHEDULE(DFN,SDCL,SDADT),SD8=$P(SD8S,U),SD8RD=$P(SD8S,U,2) + .I SDST="CA" S SD6="CC",SD8="ABK",SDMSH="S15" ;cancel bt clinic and auto rebook + .I SDST="PC" S SD6="CP",SD8="",SDMSH="S15" D ; cancel by patient + ..S SD8S=$$SCHEDULE(DFN,SDCL,SDADT),SD8=$P(SD8S,U),SD8RD=$P(SD8S,U,2) + .I SDST="PCA" S SD6="CP",SD8="ABK",SDMSH="S15" ;cancel by patient and auto rebook + .I SDST="NA" S SD6="NS",SD8="ABK",SDMSH="S26" ;no show and auto rebook + .I SDST="N" S SD6="NS",SD8="",SDMSH="S26" ;no show + .;evaluate 'non-count' + .I $P($G(^SC(SDCL,0)),U,17)="Y" D + ..I SD8="" S SD8="NC" Q + ..I SD8="RS" S SD8="RSN" + .; + .S SDSTAT=SDMSH_U_SD25_U_SD6_U_SD8_U_SDCO_U_U_SD8RD + ;process all others + S SD0=^DPT(DFN,"S",SDADT,0) + ; check out from OUTPAT ENCOUNTER + ;N SCE S SCE=$P(SD0,"^",20) S SDCO="" I SCE>0 S SDCO=$P(^SCE(SCE,0),"^",7) + N SCE S SCE=$P(SD0,"^",20) S SDCO="" I SCE>0,$D(^SCE(SCE,0)) S SDCO=$P(^SCE(SCE,0),"^",7) + N SDSTATX,SDX3 + S SDSTATX=$$STATUS^SDAM1(DFN,SDADT,SDCL,SD0) ;call to compute the status (VistA) + ;SDSTATX=Appt status IFN in 409.63 ; status name ; print status ; check in ; check out + I SDCO="" S SDCO=$P(SDSTATX,";",5) ; check out from clinic if NULL + I SDCO'=""&(+SDSTATX'=12) D Q SDSTAT + .S SD6="CO",SD25="F",SD8="",SD8RD="",SDMSH=$S(SFD=0:"S14",1:"S12") + .I +SDSTATX=3 S SD8="AR" ; action required + .I +SDSTATX=8 S SD8="I" ;inpatient + .;I +SDSTATX=12 S SD8="NC" ;non-count excluded to be compared to possible encounter does not matter if check out + .I +SDSTATX=2 S SD8="O" ;outpatient + .S SDSTAT=SDMSH_U_SD25_U_SD6_U_SD8_U_SDCO_U_U_SD8RD + I +SDSTATX=3 D Q SDSTAT + .S SD25="P",SDMSH="S12",SDCO="",SD8RD="" + .I $P(SDSTATX,";",4)'="" S SD6="CI",SD8="AR" ;check in/action required + .E S SD6="",SD8="NAT",SD8RD="" ;no action taken + .S SDSTAT=SDMSH_U_SD25_U_SD6_U_SD8_U_SDCO_U_U_SD8RD + I +SDSTATX=8!(+SDSTATX=11) S SD25="P",SD8RD="" D Q SDSTAT + .I +SDSTATX=8 S SD6="",SD8="I",SDCO="",SDMSH="S12" ;inpatient + .I +SDSTATX=11 S SD6="",SD8="F",SDCO="",SDMSH="S12" ;future + .S SDSTAT=SDMSH_U_SD25_U_SD6_U_SD8_U_SDCO_U_U_SD8RD + ; + ;process non-count (not checked out) + I +SDSTATX=12 N SDCLL S SDCLL="" D S:SD6'="COE" SDCLL=SDCL S SDSTAT=SDMSH_U_SD25_U_SD6_U_SD8_U_SDCO_U_SDCLL Q SDSTAT + .S SD6="",SD8="NC",SDCO="",SDMSH="S12",SD25="P" + .I (SDADT\1)-(TODAY\1)>0 S SD6="",SD8="NCF",SD25="P" Q + .N SDADTC,SDSCE,SDADTCK S SDADTC=(SDADT\1)-1+.99,SDADTCK=SDADTC+1 F D Q:'SDSCE!(SD6="COE") + ..S SDSCE=$$EXAE^SDOE(DFN,SDADTC,SDADTCK) + ..I SDSCE>1 N SDDATA D GETGEN^SDOE(SDSCE,"SDDATA") D + ...N SDCL0,SDCL1,SDCL2 + ...S SDCLL=$P(SDDATA(0),"^",4) I $P(^SC(SDCLL,0),"^",17)="Y" D Q + ....S SDADTC=$P(^SCE(SDSCE,0),"^")+.000001 ; + ...S SDCL0=$P(^SC(SDCL,0),"^",7)_$P(^SC(SDCL,0),"^",18) + ...S SDCL2=$P(^SC(SDCLL,0),"^",7)_$P(^SC(SDCLL,0),"^",18) + ...I SDCL0'=SDCL2 S SDADTC=$P(^SCE(SDSCE,0),"^")+.000001 Q + ...; proceed if the same DSS IDs pairs + ...S SDCO=$P(SDDATA(0),"^",7) + ...I SDCO'="" S SD6="COE",SD25="F",SDMSH=$S(SFD=0:"S14",1:"S12") Q + ...;encounter exists but not in final (chek out) status + ...S SDADTC=$P(^SCE(SDSCE,0),"^")+.000001 + .I SD6="COE" Q + .;check out by matching encounter + .E I ((TODAY\1)-(SDADT\1))>2 D ;give 2 days to update + ..S SD6="NM",SD25="F",SDMSH=$S(SFD=0:"S14",1:0) ;no match, to be skipped + Q 0 + ; +SCHEDULE(DFN,SDCL,SDADT) ; Scheduling flag + ; If the patient has another appointment created on the same day as the cancellation date of the canceled appt, and that + ; appointment is created for a clinic with the same stop code then return "RS". + ; If there is not another appointment made on the same day, return "". + N SDCDT,SDCLN S SDCDT=$$GET1^DIQ(2.98,SDADT_","_DFN_",",15,"I") ;cancellation date + Q:'SDCDT "" + N SDCDTI S SDCDTI=SDCDT\1 + N SDRESCH S SDRESCH="" + ;exclude the same appointments + N SDAPDT S SDAPDT="" F S SDAPDT=$O(^DPT("ASADM",SDCDTI,DFN,SDAPDT)) Q:SDAPDT="" I SDAPDT'=SDADT I $D(^DPT(DFN,"S",SDAPDT)) D Q:SDRESCH'="" + .S SDCLN=+$P(^DPT(DFN,"S",SDAPDT,0),U) I $P(^SC(SDCLN,0),"^",7)=$P(^SC(SDCL,0),"^",7) S SDRESCH="RS"_"^"_SDAPDT ;compare stop code pointers + S:SDRESCH="" SDRESCH="^" Q SDRESCH diff --git a/r/SCHEDULING-SD-SC/SDRPA06.m b/r/SCHEDULING-SD-SC/SDRPA06.m index f9a29911..41441786 100644 --- a/r/SCHEDULING-SD-SC/SDRPA06.m +++ b/r/SCHEDULING-SD-SC/SDRPA06.m @@ -1,214 +1,214 @@ -SDRPA06 ;bp-oifo/swo pait hl7 ack handling ; 10/31/04 3:53pm - ;;5.3;Scheduling;**290,333,349,376,491**;AUG 13, 1993;Build 53 - ;routine called from Vista HL7 when ack messages are received in response - ;to an out going HL7 message generated by protocol SC-PAIT-EVENT -ACK ;entry point from Vista HL7 - ;ACKDATE : date/time ack received - ;FLDSEP : field separator - ;CMPNTSEP : component separator - ;REPTNSEP : repetition separator - ;ACKCODE : acknowledgement code - ;ERROR : reject reason - ;BATCHID : batch control ID - ;BATCHIDO : original batch control ID - N ACKCODE,ACKDATE,BATCHID,BATCHIDO,CMPNTSEP,ERROR,FLDSEP,REPTNSEP,RUNIEN,SDZAP,V1 - ;disable automatic repair of the last run, not needed to process acks - ;NHD will be notified when the completion message does not come out - ;D RSTAT^SDRPA02 ;check the status of the last run - K ^TMP("SDRPA06",$J) - S SDZAP=0 - S ACKDATE=$$NOW^XLFDT() - S FLDSEP=HL("FS") - S CMPNTSEP=$E(HL("ECH"),1) - S REPTNSEP=$E(HL("ECH"),2) - S ACKCODE=$P(HLMSA,FLDSEP) - S ERROR=$P(HLMSA,FLDSEP,4) - S (BATCHID,BATCHIDO)=$P(HLMSA,FLDSEP,2) - S RUNIEN=$$RUNIEN(BATCHIDO) Q:'RUNIEN - S BATCHID=$$OURB(RUNIEN,BATCHIDO) ;convert to our batch id - Q:'BATCHID ;error needs to be handled - ;S V1=$O(^SDWL(409.6,"AMSG",BATCHID,"")),RUNIEN=$O(^SDWL(409.6,"AMSG",BATCHID,V1,"")) - S V1=$O(^SDWL(409.6,"AMSG",BATCHID,"")) Q:V1="" - Q:'$$DUP^SDRPA02(RUNIEN,BATCHIDO) ;check for duplicate - S ^XTMP("SDRPA-"_BATCHID,0)=$$FMADD^XLFDT($$DT^XLFDT(),3)_"^"_$$DT^XLFDT() ;set xtmp global for diagnostics - I $E(ACKCODE,1,2)="AR" D AR(BATCHID,BATCHIDO),MSG(BATCHIDO,3,RUNIEN,BATCHID) Q ;whole batch rejection - ;Q:($E(ACKCODE,1,2)'="AA") ;quit if not a application ack - ;will only be 2 ACKCODEs AA and AE so don't have to screen anymore - F X HLNEXT Q:(HLQUIT'>0) D ;start looping the msg text - . Q:($E(HLNODE,1,3)'="MSA") ;skip if not a MSA segment - . I $P(HLNODE,FLDSEP,2)="AE" D ;it's an error - .. Q:($P($P(HLNODE,FLDSEP,3),"-",2))="" ;no message number - .. S ^TMP("SDRPA06",$J,+$P($P(HLNODE,FLDSEP,3),"-",2))=+$P(HLNODE,"^",4) ;set xref with message # - I '$D(^TMP("SDRPA06",$J)) D AA(BATCHID,BATCHIDO),MSG(BATCHIDO,2,RUNIEN,BATCHID) Q ;whole batch accept - D AAAR(BATCHID,BATCHIDO),MSG(BATCHIDO,1,RUNIEN,BATCHID) ;batch accept with errors - Q -AR(BATCH,BATCHIDO) ;whole batch rejection - ;BATCH : originating batch number - ;BATCHIDO : original batch number from HL7 ACK - ;V1 : sequence # (individual message number in batch) - ;V2 : run # (ien of multiple entry) - ;V3 : ien (ien in patient multiple) - ;V4 : ien (ien batch tracking multiple) - Q:($G(BATCH)="") - N DA,DIE,DR,V1,V2,V3,V4,ZNODE - S V1=0 - F S V1=$O(^SDWL(409.6,"AMSG",BATCH,V1)) Q:'V1 D - . S V2=$O(^SDWL(409.6,"AMSG",BATCH,V1,"")) Q:'V2 - . ;batch tracking enhancement - . S V4=$O(^SDWL(409.6,V2,2,"B",BATCHIDO,"")) Q:'V4 D - .. S DA=V4,DA(1)=V2,DIE="^SDWL(409.6,"_V2_",2,",DR=".04///"_$$NOW^XLFDT_";.05///"_ACKCODE - .. D ^DIE K DIE - . S V3=0 F S V3=$O(^SDWL(409.6,"AMSG",BATCH,V1,V2,V3)) Q:'V3 D - .. S ZNODE=$G(^SDWL(409.6,V2,1,V3,0)) Q:ZNODE="" - .. ;4TH PIECE IS MESSAGE NUMBER - .. S DA=V3,DA(1)=V2,DIE="^SDWL(409.6,"_V2_",1," - .. S DR="7////"_$O(^SCPT(404.472,"B","R","")) D ^DIE - .. I $D(^SDWL(409.6,"AE","Y",V2,V3)) Q - .. I $D(^SDWL(409.6,"AE","N",V2,V3)) D - ... S DR="4///Y" D ^DIE - Q -AA(BATCH,BATCHIDO) ;whole batch accept - ;if the batch is accepted and no rejections then get the run # sequence # - ;from AMSG xref. If no "AE","Y" xref then call DIK to delete the entry - ;BATCH : originating batch number - ;BATCHIDO : original batch number from HL7 ACK - ;V1 : sequence # (individual message number in batch) - ;V2 : run # (ien of multiple entry) - ;V3 : ien (ien in patient multiple) - ;V4 : ien (ien batch tracking multiple) - Q:($G(BATCH)="") - N DA,DIK,DR,V1,V2,V3,V4,ZNODE - S V1=0 - F S V1=$O(^SDWL(409.6,"AMSG",BATCH,V1)) Q:'V1 D - . S V2=$O(^SDWL(409.6,"AMSG",BATCH,V1,"")) Q:'V2 - . ;batch tracking enhancement - . S V4=$O(^SDWL(409.6,V2,2,"B",BATCHIDO,"")) Q:'V4 D - .. S DA=V4,DA(1)=V2,DIE="^SDWL(409.6,"_V2_",2,",DR=".04///"_$$NOW^XLFDT_";.05///"_ACKCODE - .. D ^DIE K DIE - . S V3=0 F S V3=$O(^SDWL(409.6,"AMSG",BATCH,V1,V2,V3)) Q:'V3 D - .. S ZNODE=$G(^SDWL(409.6,V2,1,V3,0)) Q:ZNODE="" - .. ;4th piece is the message # - .. I '$D(^SDWL(409.6,"AE","Y",V2,V3)) D - ... S DIK="^SDWL(409.6,"_V2_",1," - ... S DA(1)=V2,DA=V3 D ^DIK - ... S ^XTMP("SDRPA-"_BATCH,+$P(ZNODE,"^",4),0)=ZNODE ;diagnostics - Q -AAAR(BATCH,BATCHIDO) ;batch accept with errors - ;BATCH : originating batch number - ;BATCHIDO : original batch number from HL7 ACK - ;V1 : sequence # (individual message number in batch) - ;V2 : run # (ien of multiple entry) - ;V3 : ien (ien in patient multiple) - ;V4 : ien (ien batch tracking multiple)) - Q:($G(BATCH)="") - N DA,DIK,DR,V1,V2,V3,V4,ZNODE - S V1=0 - F S V1=$O(^SDWL(409.6,"AMSG",BATCH,V1)) Q:'V1 D - . S V2=$O(^SDWL(409.6,"AMSG",BATCH,V1,"")) Q:'V2 - . ;batch tracking enhancement - . S V4=$O(^SDWL(409.6,V2,2,"B",BATCHIDO,"")) Q:'V4 D - .. S DA=V4,DA(1)=V2,DIE="^SDWL(409.6,"_V2_",2,",DR=".04///"_$$NOW^XLFDT_";.05///"_ACKCODE - .. D ^DIE K DIE - . S V3=0 F S V3=$O(^SDWL(409.6,"AMSG",BATCH,V1,V2,V3)) Q:'V3 D - .. S ZNODE=$G(^SDWL(409.6,V2,1,V3,0)) Q:ZNODE="" - .. ;4th piece is the message # - .. ;next line screens for accepted batch + accepted message + status final and can be deleted - .. I '$D(^SDWL(409.6,"AE","Y",V2,V3))&('$D(^TMP("SDRPA06",$J,$P(ZNODE,"^",4)))) D - ... S DIK="^SDWL(409.6,"_V2_",1," - ... S DA(1)=V2,DA=V3 D ^DIK - ... S ^XTMP("SDRPA-"_BATCH,+$P(ZNODE,"^",4),0)=ZNODE ;diagnostics - .. ;next line screens for accepted batch + error message - .. I $D(^TMP("SDRPA06",$J,$P(ZNODE,"^",4))) D - ... S DA=V3,DA(1)=V2,DIE="^SDWL(409.6,"_V2_",1," - ... S DR="7////"_$O(^SCPT(404.472,"B",$G(^TMP("SDRPA06",$J,$P(ZNODE,"^",4))),"")) D ^DIE - ... I $D(^SDWL(409.6,"AE","Y",V2,V3)) Q - ... I $D(^SDWL(409.6,"AE","N",V2,V3)) D - .... S DR="4///Y" D ^DIE - Q -CLEAN(RUN) ;housekeeping - ;clean up batch previous to current one by checking for "AE",("S" or "R") xref and - ;deleting if entry in xref exists - ;RUN : run # (ien of multiple entry) - ;V1 : previous run # (ien of multiple entry) - ;V2 : ien (ien in multiple) - Q:($G(RUN)="") - N V1,V2,V3 - S V1=$O(^SDWL(409.6,RUN),-1) Q:'V1 - F V3="R","S" S V2=0 F S V2=$O(^SDWL(409.6,"AE",V3,V1,V2)) Q:'V2 D - . S ZNODE=$G(^SDWL(409.6,V1,1,V2,0)) - . S DIK="^SDWL(409.6,"_V1_",1," - . S DA(1)=V1,DA=V2 D ^DIK - . S ^XTMP("SDRPA-"_$P(ZNODE,"^",3),"CLEAN",+$P(ZNODE,"^",4),0)=ZNODE ;diagnostics - Q -MSG(BATCHIDO,TYPE,RUNIEN,BATCHID) ;acknowledgement notification to mail group - ;BATCHID : Our Message ID - ;BATCHIDO: Batch Control ID - ;TYPE : type of message (accept with rejects - 1, whole accept 2, whole reject -3) - ;RUNIEN : run ien associated with this batch - ;SDAMX : message text array - ;XMSUB : subject - ;XMY : addressee - ;XMTEXT : location of text array - ;XMDUZ : sender of the message - ;RUNZ : zero node of run associated with this batch - N RUNZ,SDAMX,V0,V1,V2,V3,XMSUB,XMY,XMTEXT,XMDUZ - Q:BATCHID="" - L +^SDWL(409.6,RUNIEN,2,0) - S V0=$P($G(^SDWL(409.6,RUNIEN,2,0)),"^",4) - S (V1,V3)=0 F S V1=$O(^SDWL(409.6,RUNIEN,2,V1)) Q:'V1 D - . S:$P($G(^SDWL(409.6,RUNIEN,2,V1,0)),"^",4)'="" V3=V3+1 - L -^SDWL(409.6,RUNIEN,2,0) - S RUNZ=$G(^SDWL(409.6,RUNIEN,0)) - S XMSUB="PAIT BATCH ACKNOWLEGEMENT "_BATCHIDO - S XMY("G.SD-PAIT")="" - S XMY("S.SD-PAIT-SERVER@FORUM.VA.GOV")="" - S XMTEXT="SDAMX(" - S XMDUZ="POSTMASTER" - I TYPE=1 D - . S SDAMX(1)=" Station Number: "_$P($$SITE^VASITE(),"^",3) - . S SDAMX(2)="Batch Control ID: "_BATCHIDO - . S SDAMX(3)=" Message ID: "_BATCHID - . S SDAMX(4)=" Log Entry: "_RUNIEN - . S SDAMX(5)=" Run Date: "_$$FMTE^XLFDT($P(RUNZ,"^",7)) - . S SDAMX(6)=" Status: Acknowledged - with rejections " - . S SDAMX(7)=" "_V3_" of "_V0_" ACKs received for this run date" - . S SDAMX(8)="" - . S SDAMX(9)="Use option SD-PAIT REJECTED Rejected Transmissions to view the rejections." - I TYPE=2 D - . S SDAMX(1)=" Station Number: "_$P($$SITE^VASITE(),"^",3) - . S SDAMX(2)="Batch Control ID: "_BATCHIDO - . S SDAMX(3)=" Message ID: "_BATCHID - . S SDAMX(4)=" Log Entry: "_RUNIEN - . S SDAMX(5)=" Run Date: "_$$FMTE^XLFDT($P(RUNZ,"^",7)) - . S SDAMX(6)=" Status: Acknowledged - No Rejections" - . S SDAMX(7)=" "_V3_" of "_V0_" ACKs received for this run date" - I TYPE=3 D - . S SDAMX(1)=" Station Number: "_$P($$SITE^VASITE(),"^",3) - . S SDAMX(2)="Batch Control ID: "_BATCHIDO - . S SDAMX(3)=" Message ID: "_BATCHID - . S SDAMX(4)=" Log Entry: "_RUNIEN - . S SDAMX(5)=" Run Date: "_$$FMTE^XLFDT($P(RUNZ,"^",7)) - . S SDAMX(6)=" Status: Acknowledged - Entire Batch Rejected" - . S SDAMX(7)=" "_V3_" of "_V0_" ACKs received for this run date" - D ^XMD - Q -OURB(RUNIEN,BATCHIDO) ;match batch id to msg control id ("AMSG" xref) - ;RUNIEN : the ien in file 409.6 of the run - ;BATCHIDO : batchid pulled from the ACK message - ;V2 : returns 0 if none, or msg control id - N V1,V2,VNODE - S V2=0 - I '$G(RUNIEN) Q V2 - I '$G(BATCHIDO) Q V2 - I $G(^SDWL(409.6,RUNIEN,2,0))="" Q V2 - S V1=0 F S V1=$O(^SDWL(409.6,RUNIEN,2,"B",BATCHIDO,V1)) Q:'V1 D - . S VNODE=$G(^SDWL(409.6,RUNIEN,2,V1,0)) Q:VNODE="" - . I $P(VNODE,"^",3)="" Q - . S V2=$P(VNODE,"^",3) Q - Q V2 -RUNIEN(BATCHID) ;get runien - N V1,V2 - S V2=0 - S V1=999999999 F S V1=$O(^SDWL(409.6,V1),-1) Q:'V1!(V2) D - . I $O(^SDWL(409.6,V1,2,"B",BATCHID,"")) S V2=V1 Q - Q V2 +SDRPA06 ;bp-oifo/swo pait hl7 ack handling ; 10/31/04 3:53pm + ;;5.3;Scheduling;**290,333,349,376**;AUG 13, 1993 + ;routine called from Vista HL7 when ack messages are received in response + ;to an out going HL7 message generated by protocol SC-PAIT-EVENT +ACK ;entry point from Vista HL7 + ;ACKDATE : date/time ack received + ;FLDSEP : field separator + ;CMPNTSEP : component separator + ;REPTNSEP : repetition separator + ;ACKCODE : acknowledgement code + ;ERROR : reject reason + ;BATCHID : batch control ID + ;BATCHIDO : original batch control ID + N ACKCODE,ACKDATE,BATCHID,BATCHIDO,CMPNTSEP,ERROR,FLDSEP,REPTNSEP,RUNIEN,SDZAP,V1 + ;disable automatic repair of the last run, not needed to process acks + ;NHD will be notified when the completion message does not come out + ;D RSTAT^SDRPA02 ;check the status of the last run + K ^TMP("SDRPA06",$J) + S SDZAP=0 + S ACKDATE=$$NOW^XLFDT() + S FLDSEP=HL("FS") + S CMPNTSEP=$E(HL("ECH"),1) + S REPTNSEP=$E(HL("ECH"),2) + S ACKCODE=$P(HLMSA,FLDSEP) + S ERROR=$P(HLMSA,FLDSEP,4) + S (BATCHID,BATCHIDO)=$P(HLMSA,FLDSEP,2) + S RUNIEN=$$RUNIEN(BATCHIDO) Q:'RUNIEN + S BATCHID=$$OURB(RUNIEN,BATCHIDO) ;convert to our batch id + Q:'BATCHID ;error needs to be handled + ;S V1=$O(^SDWL(409.6,"AMSG",BATCHID,"")),RUNIEN=$O(^SDWL(409.6,"AMSG",BATCHID,V1,"")) + S V1=$O(^SDWL(409.6,"AMSG",BATCHID,"")) Q:V1="" + Q:'$$DUP^SDRPA02(RUNIEN,BATCHIDO) ;check for duplicate + S ^XTMP("SDRPA-"_BATCHID,0)=$$FMADD^XLFDT($$DT^XLFDT(),3)_"^"_$$DT^XLFDT() ;set xtmp global for diagnostics + I $E(ACKCODE,1,2)="AR" D AR(BATCHID,BATCHIDO),MSG(BATCHIDO,3,RUNIEN,BATCHID) Q ;whole batch rejection + ;Q:($E(ACKCODE,1,2)'="AA") ;quit if not a application ack + ;will only be 2 ACKCODEs AA and AE so don't have to screen anymore + F X HLNEXT Q:(HLQUIT'>0) D ;start looping the msg text + . Q:($E(HLNODE,1,3)'="MSA") ;skip if not a MSA segment + . I $P(HLNODE,FLDSEP,2)="AE" D ;it's an error + .. Q:($P($P(HLNODE,FLDSEP,3),"-",2))="" ;no message number + .. S ^TMP("SDRPA06",$J,+$P($P(HLNODE,FLDSEP,3),"-",2))=+$P(HLNODE,"^",4) ;set xref with message # + I '$D(^TMP("SDRPA06",$J)) D AA(BATCHID,BATCHIDO),MSG(BATCHIDO,2,RUNIEN,BATCHID) Q ;whole batch accept + D AAAR(BATCHID,BATCHIDO),MSG(BATCHIDO,1,RUNIEN,BATCHID) ;batch accept with errors + Q +AR(BATCH,BATCHIDO) ;whole batch rejection + ;BATCH : originating batch number + ;BATCHIDO : original batch number from HL7 ACK + ;V1 : sequence # (individual message number in batch) + ;V2 : run # (ien of multiple entry) + ;V3 : ien (ien in patient multiple) + ;V4 : ien (ien batch tracking multiple) + Q:($G(BATCH)="") + N DA,DIE,DR,V1,V2,V3,V4,ZNODE + S V1=0 + F S V1=$O(^SDWL(409.6,"AMSG",BATCH,V1)) Q:'V1 D + . S V2=$O(^SDWL(409.6,"AMSG",BATCH,V1,"")) Q:'V2 + . ;batch tracking enhancement + . S V4=$O(^SDWL(409.6,V2,2,"B",BATCHIDO,"")) Q:'V4 D + .. S DA=V4,DA(1)=V2,DIE="^SDWL(409.6,"_V2_",2,",DR=".04///"_$$NOW^XLFDT_";.05///"_ACKCODE + .. D ^DIE K DIE + . S V3=0 F S V3=$O(^SDWL(409.6,"AMSG",BATCH,V1,V2,V3)) Q:'V3 D + .. S ZNODE=$G(^SDWL(409.6,V2,1,V3,0)) Q:ZNODE="" + .. ;4TH PIECE IS MESSAGE NUMBER + .. S DA=V3,DA(1)=V2,DIE="^SDWL(409.6,"_V2_",1," + .. S DR="7////"_$O(^SCPT(404.472,"B","R","")) D ^DIE + .. I $D(^SDWL(409.6,"AE","Y",V2,V3)) Q + .. I $D(^SDWL(409.6,"AE","N",V2,V3)) D + ... S DR="4///Y" D ^DIE + Q +AA(BATCH,BATCHIDO) ;whole batch accept + ;if the batch is accepted and no rejections then get the run # sequence # + ;from AMSG xref. If no "AE","Y" xref then call DIK to delete the entry + ;BATCH : originating batch number + ;BATCHIDO : original batch number from HL7 ACK + ;V1 : sequence # (individual message number in batch) + ;V2 : run # (ien of multiple entry) + ;V3 : ien (ien in patient multiple) + ;V4 : ien (ien batch tracking multiple) + Q:($G(BATCH)="") + N DA,DIK,DR,V1,V2,V3,V4,ZNODE + S V1=0 + F S V1=$O(^SDWL(409.6,"AMSG",BATCH,V1)) Q:'V1 D + . S V2=$O(^SDWL(409.6,"AMSG",BATCH,V1,"")) Q:'V2 + . ;batch tracking enhancement + . S V4=$O(^SDWL(409.6,V2,2,"B",BATCHIDO,"")) Q:'V4 D + .. S DA=V4,DA(1)=V2,DIE="^SDWL(409.6,"_V2_",2,",DR=".04///"_$$NOW^XLFDT_";.05///"_ACKCODE + .. D ^DIE K DIE + . S V3=0 F S V3=$O(^SDWL(409.6,"AMSG",BATCH,V1,V2,V3)) Q:'V3 D + .. S ZNODE=$G(^SDWL(409.6,V2,1,V3,0)) Q:ZNODE="" + .. ;4th piece is the message # + .. I '$D(^SDWL(409.6,"AE","Y",V2,V3)) D + ... S DIK="^SDWL(409.6,"_V2_",1," + ... S DA(1)=V2,DA=V3 D ^DIK + ... S ^XTMP("SDRPA-"_BATCH,+$P(ZNODE,"^",4),0)=ZNODE ;diagnostics + Q +AAAR(BATCH,BATCHIDO) ;batch accept with errors + ;BATCH : originating batch number + ;BATCHIDO : original batch number from HL7 ACK + ;V1 : sequence # (individual message number in batch) + ;V2 : run # (ien of multiple entry) + ;V3 : ien (ien in patient multiple) + ;V4 : ien (ien batch tracking multiple)) + Q:($G(BATCH)="") + N DA,DIK,DR,V1,V2,V3,V4,ZNODE + S V1=0 + F S V1=$O(^SDWL(409.6,"AMSG",BATCH,V1)) Q:'V1 D + . S V2=$O(^SDWL(409.6,"AMSG",BATCH,V1,"")) Q:'V2 + . ;batch tracking enhancement + . S V4=$O(^SDWL(409.6,V2,2,"B",BATCHIDO,"")) Q:'V4 D + .. S DA=V4,DA(1)=V2,DIE="^SDWL(409.6,"_V2_",2,",DR=".04///"_$$NOW^XLFDT_";.05///"_ACKCODE + .. D ^DIE K DIE + . S V3=0 F S V3=$O(^SDWL(409.6,"AMSG",BATCH,V1,V2,V3)) Q:'V3 D + .. S ZNODE=$G(^SDWL(409.6,V2,1,V3,0)) Q:ZNODE="" + .. ;4th piece is the message # + .. ;next line screens for accepted batch + accepted message + status final and can be deleted + .. I '$D(^SDWL(409.6,"AE","Y",V2,V3))&('$D(^TMP("SDRPA06",$J,$P(ZNODE,"^",4)))) D + ... S DIK="^SDWL(409.6,"_V2_",1," + ... S DA(1)=V2,DA=V3 D ^DIK + ... S ^XTMP("SDRPA-"_BATCH,+$P(ZNODE,"^",4),0)=ZNODE ;diagnostics + .. ;next line screens for accepted batch + error message + .. I $D(^TMP("SDRPA06",$J,$P(ZNODE,"^",4))) D + ... S DA=V3,DA(1)=V2,DIE="^SDWL(409.6,"_V2_",1," + ... S DR="7////"_$O(^SCPT(404.472,"B",$G(^TMP("SDRPA06",$J,$P(ZNODE,"^",4))),"")) D ^DIE + ... I $D(^SDWL(409.6,"AE","Y",V2,V3)) Q + ... I $D(^SDWL(409.6,"AE","N",V2,V3)) D + .... S DR="4///Y" D ^DIE + Q +CLEAN(RUN) ;housekeeping + ;clean up batch previous to current one by checking for "AE",("S" or "R") xref and + ;deleting if entry in xref exists + ;RUN : run # (ien of multiple entry) + ;V1 : previous run # (ien of multiple entry) + ;V2 : ien (ien in multiple) + Q:($G(RUN)="") + N V1,V2,V3 + S V1=$O(^SDWL(409.6,RUN),-1) Q:'V1 + F V3="R","S" S V2=0 F S V2=$O(^SDWL(409.6,"AE",V3,V1,V2)) Q:'V2 D + . S ZNODE=$G(^SDWL(409.6,V1,1,V2,0)) + . S DIK="^SDWL(409.6,"_V1_",1," + . S DA(1)=V1,DA=V2 D ^DIK + . S ^XTMP("SDRPA-"_$P(ZNODE,"^",3),"CLEAN",+$P(ZNODE,"^",4),0)=ZNODE ;diagnostics + Q +MSG(BATCHIDO,TYPE,RUNIEN,BATCHID) ;acknowledgement notification to mail group + ;BATCHID : Our Message ID + ;BATCHIDO: Batch Control ID + ;TYPE : type of message (accept with rejects - 1, whole accept 2, whole reject -3) + ;RUNIEN : run ien associated with this batch + ;SDAMX : message text array + ;XMSUB : subject + ;XMY : addressee + ;XMTEXT : location of text array + ;XMDUZ : sender of the message + ;RUNZ : zero node of run associated with this batch + N RUNZ,SDAMX,V0,V1,V2,V3,XMSUB,XMY,XMTEXT,XMDUZ + Q:BATCHID="" + S V0=$P($G(^SDWL(409.6,RUNIEN,2,0)),"^",4) + S (V1,V3)=0 F S V1=$O(^SDWL(409.6,RUNIEN,2,V1)) Q:'V1 D + . S V2=$P($G(^SDWL(409.6,RUNIEN,2,V1,0)),"^",4) + . S:V2'="" V3=V3+1 + . ;S V3=V3+1 + S RUNZ=$G(^SDWL(409.6,RUNIEN,0)) + S XMSUB="PAIT BATCH ACKNOWLEGEMENT "_BATCHIDO + S XMY("G.SD-PAIT")="" + S XMY("S.SD-PAIT-SERVER@FORUM.VA.GOV")="" + S XMTEXT="SDAMX(" + S XMDUZ="POSTMASTER" + I TYPE=1 D + . S SDAMX(1)=" Station Number: "_$P($$SITE^VASITE(),"^",3) + . S SDAMX(2)="Batch Control ID: "_BATCHIDO + . S SDAMX(3)=" Message ID: "_BATCHID + . S SDAMX(4)=" Log Entry: "_RUNIEN + . S SDAMX(5)=" Run Date: "_$$FMTE^XLFDT($P(RUNZ,"^",7)) + . S SDAMX(6)=" Status: Acknowledged - with rejections " + . S SDAMX(7)=" "_V3_" of "_V0_" ACKs received for this run date" + . S SDAMX(8)="" + . S SDAMX(9)="Use option SD-PAIT REJECTED Rejected Transmissions to view the rejections." + I TYPE=2 D + . S SDAMX(1)=" Station Number: "_$P($$SITE^VASITE(),"^",3) + . S SDAMX(2)="Batch Control ID: "_BATCHIDO + . S SDAMX(3)=" Message ID: "_BATCHID + . S SDAMX(4)=" Log Entry: "_RUNIEN + . S SDAMX(5)=" Run Date: "_$$FMTE^XLFDT($P(RUNZ,"^",7)) + . S SDAMX(6)=" Status: Acknowledged - No Rejections" + . S SDAMX(7)=" "_V3_" of "_V0_" ACKs received for this run date" + I TYPE=3 D + . S SDAMX(1)=" Station Number: "_$P($$SITE^VASITE(),"^",3) + . S SDAMX(2)="Batch Control ID: "_BATCHIDO + . S SDAMX(3)=" Message ID: "_BATCHID + . S SDAMX(4)=" Log Entry: "_RUNIEN + . S SDAMX(5)=" Run Date: "_$$FMTE^XLFDT($P(RUNZ,"^",7)) + . S SDAMX(6)=" Status: Acknowledged - Entire Batch Rejected" + . S SDAMX(7)=" "_V3_" of "_V0_" ACKs received for this run date" + D ^XMD + Q +OURB(RUNIEN,BATCHIDO) ;match batch id to msg control id ("AMSG" xref) + ;RUNIEN : the ien in file 409.6 of the run + ;BATCHIDO : batchid pulled from the ACK message + ;V2 : returns 0 if none, or msg control id + N V1,V2,VNODE + S V2=0 + I '$G(RUNIEN) Q V2 + I '$G(BATCHIDO) Q V2 + I $G(^SDWL(409.6,RUNIEN,2,0))="" Q V2 + S V1=0 F S V1=$O(^SDWL(409.6,RUNIEN,2,"B",BATCHIDO,V1)) Q:'V1 D + . S VNODE=$G(^SDWL(409.6,RUNIEN,2,V1,0)) Q:VNODE="" + . I $P(VNODE,"^",3)="" Q + . S V2=$P(VNODE,"^",3) Q + Q V2 +RUNIEN(BATCHID) ;get runien + N V1,V2 + S V2=0 + S V1=999999999 F S V1=$O(^SDWL(409.6,V1),-1) Q:'V1!(V2) D + . I $O(^SDWL(409.6,V1,2,"B",BATCHID,"")) S V2=V1 Q + Q V2 diff --git a/r/SCHEDULING-SD-SC/SDWLCU3.m b/r/SCHEDULING-SD-SC/SDWLCU3.m index 82a4e4fc..b9f1e8f3 100644 --- a/r/SCHEDULING-SD-SC/SDWLCU3.m +++ b/r/SCHEDULING-SD-SC/SDWLCU3.m @@ -1,65 +1,70 @@ -SDWLCU3 ;IOFO BAY PINES/DMR - EWL FILE 409.3 CLEANUP ;2/4/03 - ;;5.3;scheduling;**280,491**;AUG 13 1993;Build 53 - ; - ;modify update of 409.32 and related 409.3 with a proper institution set up in file 44 - ;through the division path - ; -3 ;service specialty edit - S SDWLSS="",SDWLINS="",SDWLERR="" - F S SDWLINS=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS)) Q:SDWLINS="" D Q:SDWLERR=1 - .F S SDWLSS=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSS)) Q:SDWLSS="" D Q:SDWLERR=1 - ..I '$D(SDWLSSV) S SDWLSSV=SDWLSS - ..S NAME=$$GET1^DIQ(4,SDWLINS_",",.01) - ..S SDWLSSN=$P(^SDWL(409.31,SDWLSS,0),U,1) - ..W !,"SERVICE SPECIALTY: ",$$GET1^DIQ(40.7,SDWLSSN_",",.01)," INSTITUTION: ",NAME - ..S SDWLSSX=$O(^SDWL(409.31,SDWLSS,"I","B",SDWLINS,0)) D:SDWLSSX'="" SEL - S WLTC3="" - Q -SEL ;select new Insitition - N DIR - S DIR("A")="Select Institution: " - S DIR(0)="PAO^4:EMZ",DIR("S")="I $P(^DIC(4,+Y,0),U,11)=""N"",$$TF^XUAF4(+Y)" D ^DIR - I X["^" S SDWLERR=1 Q - I Y<1 W *7,"Invalid Entry" G SEL - S SDWLINSN=+Y - D C3,C31 K DIC,D0,D1 - Q -C3 ; - ;check entry to see if it already exist - S DA=SDWLSSX,DA(1)=SDWLSS - I $O(^SDWL(409.31,SDWLSS,"I","B",SDWLINSN,0)) D - . W !,"Institution already exists for this Specialty...deleting." - . S DIK="^SDWL(409.31,"_DA(1)_","_"""I"""_"," D ^DIK - E D - . W ! S DR=".01////^S X=SDWLINSN",DIE="^SDWL(409.31,"_DA(1)_","_"""I"""_"," D ^DIE - K DA,DA(1),DR,DIE,DIK - Q -C31 ;update SD WAIT LIST PATIENT file 409.3 - S SDWLDA="" F S SDWLDA=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSSV,SDWLDA)) Q:SDWLDA="" D - .S DR="2////^S X=SDWLINSN",DIE="^SDWL(409.3,",DA=SDWLDA D ^DIE - .K DR,DIE,DA - .K ^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSSV,SDWLDA),^TMP($J,"EWL",$J,SDWLDA) - Q -4 ;specific clinic edit - N SDWLERR,SDWLSC,SDWLINS S SDWLSC="",SDWLINS="",SDWLERR="" - F S SDWLINS=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS)) Q:SDWLINS="" D - .F S SDWLSC=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSC)) Q:SDWLSC="" D UPDINS^SDWLCU5(SDWLSC,.SDWLERR) - Q:SDWLERR - S WLTC4="" - K ^SDWL(409.32,"ACT") S DIK="^SDWL(409.32," D IXALL^DIK - Q -C41 ;update wait list file - S SDWLDA="" F S SDWLDA=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSC,SDWLDA)) Q:SDWLDA="" D - .S SDWLIN(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLIN","SDWLMSG") - .K ^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSC,SDWLDA),^TMP($J,"EWL",$J,SDWLDA),SDWLIN - Q -SEL1 ;select valid institution - N DIR - W !!,"Invalid Institution. Please select a National Institution.",! - W "CLINIC: ",CLNAM," INSTITUTION:",$$GET1^DIQ(4,SDWLINS_",",.01) - S DIR("A")="Select Institution: " - S DIR(0)="PAO^4:EMZ",DIR("S")="I $P(^DIC(4,+Y,0),U,11)=""N"",$$TF^XUAF4(+Y)" D ^DIR - I X["^" S SDWLERR=1 Q - I Y<1 W *7,"Invalid Entry" G SEL1 - S SDWLINSN=+Y - Q +SDWLCU3 ;IOFO BAY PINES/DMR - EWL FILE 409.3 CLEANUP ;2/4/03 + ;;5.3;scheduling;**280**;AUG 13 1993 + ; + ; + ; +3 ;service specialty edit + S SDWLSS="",SDWLINS="",SDWLERR="" + F S SDWLINS=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS)) Q:SDWLINS="" D Q:SDWLERR=1 + .F S SDWLSS=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSS)) Q:SDWLSS="" D Q:SDWLERR=1 + ..I '$D(SDWLSSV) S SDWLSSV=SDWLSS + ..S NAME=$$GET1^DIQ(4,SDWLINS_",",.01) + ..S SDWLSSN=$P(^SDWL(409.31,SDWLSS,0),U,1) + ..W !,"SERVICE SPECIALTY: ",$$GET1^DIQ(40.7,SDWLSSN_",",.01)," INSTITUTION: ",NAME + ..S SDWLSSX=$O(^SDWL(409.31,SDWLSS,"I","B",SDWLINS,0)) D:SDWLSSX'="" SEL + S WLTC3="" + Q +SEL ;select new Insitition + N DIR + S DIR("A")="Select Institution: " + S DIR(0)="PAO^4:EMZ",DIR("S")="I $P(^DIC(4,+Y,0),U,11)=""N"",$$TF^XUAF4(+Y)" D ^DIR + I X["^" S SDWLERR=1 Q + I Y<1 W *7,"Invalid Entry" G SEL + S SDWLINSN=+Y + D C3,C31 K DIC,D0,D1 + Q +C3 ; + ;check entry to see if it already exist + S DA=SDWLSSX,DA(1)=SDWLSS + I $O(^SDWL(409.31,SDWLSS,"I","B",SDWLINSN,0)) D + . W !,"Institution already exists for this Specialty...deleting." + . S DIK="^SDWL(409.31,"_DA(1)_","_"""I"""_"," D ^DIK + E D + . W ! S DR=".01////^S X=SDWLINSN",DIE="^SDWL(409.31,"_DA(1)_","_"""I"""_"," D ^DIE + K DA,DA(1),DR,DIE,DIK + Q +C31 ;update SD WAIT LIST PATIENT file 409.3 + S SDWLDA="" F S SDWLDA=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSSV,SDWLDA)) Q:SDWLDA="" D + .S DR="2////^S X=SDWLINSN",DIE="^SDWL(409.3,",DA=SDWLDA D ^DIE + .K DR,DIE,DA + .K ^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSSV,SDWLDA),^TMP($J,"EWL",$J,SDWLDA) + Q +4 ;specific clinic edit + S SDWLSC="",SDWLINS="",SDWLERR="" + F S SDWLINS=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS)) Q:SDWLINS="" D Q:SDWLERR=1 + .F S SDWLSC=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSC)) Q:SDWLSC="" D Q:SDWLERR=1 + ..S SDWLSCX=$P(^SDWL(409.32,SDWLSC,0),U,1) + ..S SDWLINSN=$P($G(^SC(SDWLSCX,0)),U,4),X=$$GET1^DIQ(4,SDWLINSN_",",11) I X'["N"!('$$TF^XUAF4(SDWLINSN)) D SEL1 + ..;Check 409.32 + ..I $P(^SDWL(409.32,SDWLSC,0),U,6)'=SDWLINSN D + ...K ^SDWL(409.32,"C",SDWLINS) S $P(^SDWL(409.32,SDWLSC,0),U,6)=SDWLINSN,^SDWL(409.32,"C",SDWLINSN,SDWLSC)="" + ...S SDWLIN(44,+$P(^SDWL(409.32,SDWLSC,0),"^")_",",3)=SDWLINSN D UPDATE^DIE("","SDWLIN","SDWLMSG") K SDWLIN + ..D C41 + S WLTC4="" + K ^SDWL(409.32,"ACT") S DIK="^SDWL(409.32," D IXALL^DIK + Q +C41 ;update wait list file + S SDWLDA="" F S SDWLDA=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSC,SDWLDA)) Q:SDWLDA="" D + .S SDWLIN(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLIN","SDWLMSG") + .K ^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSC,SDWLDA),^TMP($J,"EWL",$J,SDWLDA),SDWLIN + Q +SEL1 ;select valid institution + N DIR + W !!,"Invalid Institution. Please select a National Institution.",! + W "CLINIC: ",CLNAM," INSTITUTION:",$$GET1^DIQ(4,SDWLINS_",",.01) + S DIR("A")="Select Institution: " + S DIR(0)="PAO^4:EMZ",DIR("S")="I $P(^DIC(4,+Y,0),U,11)=""N"",$$TF^XUAF4(+Y)" D ^DIR + I X["^" S SDWLERR=1 Q + I Y<1 W *7,"Invalid Entry" G SEL1 + S SDWLINSN=+Y + Q diff --git a/r/SCHEDULING-SD-SC/SDWLCU5.m b/r/SCHEDULING-SD-SC/SDWLCU5.m index 70bc866d..61fb964a 100644 --- a/r/SCHEDULING-SD-SC/SDWLCU5.m +++ b/r/SCHEDULING-SD-SC/SDWLCU5.m @@ -1,140 +1,114 @@ -SDWLCU5 ;IOFO BAY PINES/TEH - EWL FILE 409.3 CLEANUP ;2/4/03 ; Compiled August 20, 2007 17:04:58 - ;;5.3;scheduling;**280,427,491**;AUG 13 1993;Build 53 -EN ; - W !!,"Checking file 404.51 one last time.",! - S SDWLERR="",TEAM=0 F S TEAM=$O(^SCTM(404.51,TEAM)) Q:'TEAM D Q:SDWLERR=1 - . S INST=$$GET1^DIQ(404.51,TEAM_",",.07,"I") - . S CODE=$$GET1^DIQ(4,INST_",",11,"I") - . S INCK=$$TF^XUAF4(INST) - . I CODE'="N"!('INCK) D - .. W !!,"TEAM: ",$$GET1^DIQ(404.51,TEAM_",",.01)," INSTITUTION: " - .. W $$GET1^DIQ(4,INST_",",.01) - .. D EDIT^SDWLCU2 - Q:SDWLERR=1 - ; - W !!,"Checking file 409.31 one last time.",! -40931 S SDWLSS=0 F S SDWLSS=$O(^SDWL(409.31,SDWLSS)) Q:'SDWLSS D Q:SDWLERR=1 - . S SDWLINS="" F S SDWLINS=$O(^SDWL(409.31,SDWLSS,"I","B",SDWLINS)) Q:'SDWLINS D Q:SDWLERR=1 - .. S CODE=$$GET1^DIQ(4,SDWLINS_",",11,"I") - .. S INCK=$$TF^XUAF4(SDWLINS) - .. I CODE'="N"!('INCK) D - ... W !!,"SERVICE SPECIALTY: ",$$GET1^DIQ(409.31,SDWLSS_",",.01)," INSTITUTION: " - ... W $$GET1^DIQ(4,SDWLINS_",",.01) - ... D GETINS Q:SDWLERR=1 - ... S SDWLSSX="" F S SDWLSSX=$O(^SDWL(409.31,SDWLSS,"I","B",SDWLINS,SDWLSSX)) Q:'SDWLSSX D Q:SDWLERR=1 - .... D C3^SDWLCU3 - Q:SDWLERR=1 -40932 W !!,"Checking file 409.32 one last time.",! - N INERROR S INERROR="" S SDWLSC=0 F S SDWLSC=$O(^SDWL(409.32,SDWLSC)) Q:'SDWLSC D UPDINS(SDWLSC,.INERROR) - Q:INERROR=1 - N DIK S DIK="^SDWL(409.32," D IXALL^DIK - W !!,"Checking file 409.3 one last time.",! - S SDWLERR="" - S SDWLDA=0,TAG="CHK" F S SDWLDA=$O(^SDWL(409.3,SDWLDA)) Q:SDWLDA<1 D Q:SDWLERR=1 - .S X=$G(^SDWL(409.3,SDWLDA,0)),SDWLINST=$P(X,"^",3),SDWLTY=$P(X,"^",5) - .Q:'SDWLTY!'SDWLINST - .S SDWLI=$P(X,"^",SDWLTY+5) Q:'SDWLI - .S TAG="CHK",TAG=TAG_SDWLTY,C=0 K ^TMP($J,"SDWLCU5",$J) D @TAG - W !,"Done." - Q -UPDINS(SDWLSC,INERROR) ; update 409.32 and the related entroes in 409.3 - N SDWLINS S SDWLINS=$$GET1^DIQ(409.32,SDWLSC_",",.02,"I") ; current set up IN 409.32 - ;check set up in file 44 - ;get clinic - N CL,CLN S CL=$$GET1^DIQ(409.32,SDWLSC_",",.01,"I"),CLN=$$GET1^DIQ(44,CL_",",.01) - N STR,SDWMES S SDWMES="",STR=$$CLIN^SDWLPE(CL) - S SDWMES=SDWMES_$P(STR,U,6) - I $P(STR,U,5)="L" S SDWMES=SDWMES_" - Local Institution assigned to clinic. " - I SDWMES'="" D Q - .W !!," ** Incorrect Setting up of Clinic "_CLN_" ("_CL_")"_": **" - .W !!,SDWMES - .W !!,"INSTALLATION WILL CONTINUE WITHOUT UPDATING THIS ENTRY." - .W !!,"AFTER INSTALLATION CORRECT THE CLINIC SETUP AND THEN",!," RUN OPTION SD WAIT LIST CLEANUP." - .S:INERROR="" INERROR=1 Q - I +STR'=SDWLINS W !!,"Clinic "_CLN_" ("_CL_")"_"does not have the same Institution as EWL set up." D - .W !!,"EWL Clinic INSTITUTION: ",$$GET1^DIQ(4,SDWLINS_",",.01)_" - "_$$GET1^DIQ(4,SDWLINS_",",99) - .W !,"Clinic INSTITUTION: ",$P(STR,U,3)_" - "_$P(STR,U,2) - .W !!,"EWL set up will be updated with the Clinic from the Hospital Location file," - .W !,"and the related open EWL entries will be updated as well." - .N DIE,DR,DA S DR=".02////^S X=+STR",DIE="^SDWL(409.32,",DA=SDWLSC - .L +^SDWL(409.32,DA):0 I '$T W !?5,"Another user is editing this entry. try later." Q - .D ^DIE L -^SDWL(409.32,DA) - .;loop to update EWL entries in FILE 409.3 if any - .N SCL,DA,DR,CNT S SCL="",CNT=0 F S SCL=$O(^SDWL(409.3,"SC",CL,SCL)) Q:SCL'>0 D - ..I '$D(^SDWL(409.3,SCL,0)) K ^SDWL(409.3,"SC",CL,SCL) Q - ..S DR="2////^S X=+STR",DIE="^SDWL(409.3,",DA=SCL - ..L +^SDWL(409.3,SCL):0 I '$T W !?5,"Another user is editing this entry. try later." Q - ..D ^DIE L -^SDWL(409.3,SCL) S CNT=CNT+1 - .I CNT>0 W !,CNT_" EWL entries for clinic "_CLN_" updated." - N DA I $$GET1^DIQ(409.32,SDWLSC_",",3,"I")="" I $$GET1^DIQ(409.32,SDWLSC_",",1,"I")'>0 D - .S DA=SDWLSC L +^SDWL(409.32,SDWLSC):0 I '$T W !?5,"Another user is editing this entry. try later." Q - .S DR="1////^S X=DT;2////^S X=DUZ",DIE="^SDWL(409.32," ;enter activation date and user - .D ^DIE L -^SDWL(409.32,SDWLSC) - .W !,"EWL Clinic entry for "_CLN_" updated with today's activation date." - Q -CHK1 ;CHECK FOR INSTITUTION VALIDILITY - S SDWLERR=0 - I SDWLTY=1 S SDWLI=0 F S SDWLI=$O(^SCTM(404.51,"AINST",SDWLI)) Q:SDWLI="" I $D(^DIC(4,SDWLI)) S C=C+1,^TMP($J,"SDWLCU5",$J,C,SDWLI)="",^TMP($J,"SDWLCU5",$J,"B",SDWLI)="" - I $D(^TMP($J,"SDWLCU5",$J,"B",SDWLINST)) Q - K ^TMP($J,"SDWLCU5",$J,"B") - I 'C S SDWLINSN=$S($D(DUZ(2)):DUZ(2),1:"") D CH1E Q - I C=1 S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,C,0)) D CH1E Q - W !,"Please select a valid Institution for this record from the following list for",! - D DIS - S C=0,SDWLI="" F S C=$O(^TMP($J,"SDWLCU5",$J,C)) Q:C<1 D - .F S SDWLI=$O(^TMP($J,"SDWLCU5",$J,C,SDWLI)) Q:SDWLI="" W !,?20,C,". ",$$GET1^DIQ(4,SDWLI_",",.01) S CS=C -CHK10 W ! S DIR(0)="NO^1:"_CS D ^DIR - I Y<1!($D(DUOUT)) W !,"Response Required." S SDWLERR=1 Q - S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,+Y,0)) -CH1E S SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG") - S TAG="CHK" - Q -CHK3 ; - S SDWLERR="" - S SDWLI=$P(^SDWL(409.3,SDWLDA,0),U,8) - Q:'SDWLI!'$D(^SDWL(409.31,SDWLI)) - I '$D(^SDWL(409.31,SDWLI,"I","B",SDWLINST)) D Q:SDWLERR=1 - .S SDWLIX="",C=0 F S SDWLIX=$O(^SDWL(409.31,SDWLI,"I","B",SDWLIX)) Q:SDWLIX="" S C=C+1,^TMP($J,"SDWLCU5",$J,C,SDWLIX)="",^TMP($J,"SDWLCU5",$J,"B",SDWLIX)="" - .I 'C N SITE S SITE=+$$SITE^VASITE(,) S SDWLINSN=$S(SITE>0:SITE,1:""),Y=1 D CHE3 Q - .I C=1 S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,C,0)),Y=1 D CHE3 Q - .W !,"Please select a valid Institution for this record from the following list for",! - .D DIS - .S C=0,SDWLIZ=0 F S SDWLIZ=$O(^SDWL(409.31,SDWLI,"I","B",SDWLIZ)) Q:SDWLIZ="" D - ..Q:$$GET1^DIQ(4,SDWLIZ_",",11,"I")'="N"!('$$TF^XUAF4(SDWLIZ)) - ..S C=C+1 W !,?20,C,". ",$$GET1^DIQ(4,SDWLIZ_",",.01) - .W ! S DIR(0)="NO^1:"_C D ^DIR - .I $D(DUOUT)!(Y="") S SDWLERR=1 Q - .S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,+Y,0)) - .D CHE3 - Q -CHE3 ; - G CHK3:Y<0 - S SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG") - S TAG="CHK" - Q -CHK4 ; - S SDWLI=$P(^SDWL(409.3,SDWLDA,0),U,9) - Q:'SDWLI!'$D(^SDWL(409.32,SDWLI,0)) - I $P(^SDWL(409.32,SDWLI,0),U,6)'=SDWLINST D - .D DIS - .S SDWLINSN=$P(^SDWL(409.32,SDWLI,0),U,6),SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG") - Q -CHK2 ; - S SDWLPO=$P($G(^SDWL(409.3,SDWLDA,0)),U,7),SDWLTM=$P($G(^SCTM(404.57,SDWLPO,0)),U,2),SDWLINSN=$P($G(^SCTM(404.51,SDWLTM,0)),U,7) - I SDWLINST'=SDWLINSN D - .S SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG") - S TAG="CHK" - Q -DIS ;display record - S NN=$P($G(^SDWL(409.3,SDWLDA,0)),"^"),NAME=$$GET1^DIQ(2,NN_",",.01,"E") - S SSN=$$GET1^DIQ(2,NN_",",.09) - W !,"Record#: ",SDWLDA," Patient: ",NAME," (",SSN,")",!! - Q -GETINS ;Get institution - N DIR - S DIR("A")="Select Institution: " - S DIR(0)="PAO^4:EMZ",DIR("S")="I $P(^DIC(4,+Y,0),U,11)=""N"",$$TF^XUAF4(+Y)" D ^DIR - I X["^" S SDWLERR=1 Q - I Y<1 W *7,"Invalid Entry" G GETINS - S SDWLINSN=+Y - Q +SDWLCU5 ;IOFO BAY PINES/TEH - EWL FILE 409.3 CLEANUP ;2/4/03 + ;;5.3;scheduling;**280,427**;AUG 13 1993 +EN ; + W !!,"Checking file 404.51 one last time.",! + S SDWLERR="",TEAM=0 F S TEAM=$O(^SCTM(404.51,TEAM)) Q:'TEAM D Q:SDWLERR=1 + . S INST=$$GET1^DIQ(404.51,TEAM_",",.07,"I") + . S CODE=$$GET1^DIQ(4,INST_",",11,"I") + . S INCK=$$TF^XUAF4(INST) + . I CODE'="N"!('INCK) D + .. W !!,"TEAM: ",$$GET1^DIQ(404.51,TEAM_",",.01)," INSTITUTION: " + .. W $$GET1^DIQ(4,INST_",",.01) + .. D EDIT^SDWLCU2 + Q:SDWLERR=1 + ; + W !!,"Checking file 409.31 one last time.",! +40931 S SDWLSS=0 F S SDWLSS=$O(^SDWL(409.31,SDWLSS)) Q:'SDWLSS D Q:SDWLERR=1 + . S SDWLINS="" F S SDWLINS=$O(^SDWL(409.31,SDWLSS,"I","B",SDWLINS)) Q:'SDWLINS D Q:SDWLERR=1 + .. S CODE=$$GET1^DIQ(4,SDWLINS_",",11,"I") + .. S INCK=$$TF^XUAF4(SDWLINS) + .. I CODE'="N"!('INCK) D + ... W !!,"SERVICE SPECIALTY: ",$$GET1^DIQ(409.31,SDWLSS_",",.01)," INSTITUTION: " + ... W $$GET1^DIQ(4,SDWLINS_",",.01) + ... D GETINS Q:SDWLERR=1 + ... S SDWLSSX="" F S SDWLSSX=$O(^SDWL(409.31,SDWLSS,"I","B",SDWLINS,SDWLSSX)) Q:'SDWLSSX D Q:SDWLERR=1 + .... D C3^SDWLCU3 + Q:SDWLERR=1 +40932 W !!,"Checking file 409.32 one last time.",! + S SDWLSC=0 F S SDWLSC=$O(^SDWL(409.32,SDWLSC)) Q:'SDWLSC D Q:SDWLERR=1 + . S SDWLINS=$$GET1^DIQ(409.32,SDWLSC_",",.02,"I") + . S CODE=$$GET1^DIQ(4,SDWLINS_",",11,"I") + . S INCK=$$TF^XUAF4(SDWLINS) + . I CODE'="N"!('INCK) D + .. W !!,"CLINIC: ",$$GET1^DIQ(409.32,SDWLSC_",",.01)," INSTITUTION: " + .. W $$GET1^DIQ(4,SDWLINS_",",.01) + .. D GETINS Q:SDWLERR=1 + .. K ^SDWL(409.32,"C",+SDWLINS) S $P(^SDWL(409.32,SDWLSC,0),U,6)=SDWLINSN,^SDWL(409.32,"C",SDWLINSN,SDWLSC)="" + .. S SDWLIN(44,+$P(^SDWL(409.32,SDWLSC,0),"^")_",",3)=SDWLINSN D UPDATE^DIE("","SDWLIN","SDWLMSG") K SDWLIN + K ^SDWL(409.32,"ACT") S DIK="^SDWL(409.32," D IXALL^DIK + Q:SDWLERR=1 + W !!,"Checking file 409.3 one last time.",! + S SDWLERR="" + S SDWLDA=0,TAG="CHK" F S SDWLDA=$O(^SDWL(409.3,SDWLDA)) Q:SDWLDA<1 D Q:SDWLERR=1 + .S X=$G(^SDWL(409.3,SDWLDA,0)),SDWLINST=$P(X,"^",3),SDWLTY=$P(X,"^",5) + .Q:'SDWLTY!'SDWLINST + .S SDWLI=$P(X,"^",SDWLTY+5) Q:'SDWLI + .S TAG="CHK",TAG=TAG_SDWLTY,C=0 K ^TMP($J,"SDWLCU5",$J) D @TAG + W !,"Done." + Q +CHK1 ;CHECK FOR INSTITUTION VALIDILITY + S SDWLERR=0 + I SDWLTY=1 S SDWLI=0 F S SDWLI=$O(^SCTM(404.51,"AINST",SDWLI)) Q:SDWLI="" I $D(^DIC(4,SDWLI)) S C=C+1,^TMP($J,"SDWLCU5",$J,C,SDWLI)="",^TMP($J,"SDWLCU5",$J,"B",SDWLI)="" + I $D(^TMP($J,"SDWLCU5",$J,"B",SDWLINST)) Q + K ^TMP($J,"SDWLCU5",$J,"B") + I 'C S SDWLINSN=$S($D(DUZ(2)):DUZ(2),1:"") D CH1E Q + I C=1 S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,C,0)) D CH1E Q + W !,"Please select a valid Institution for this record from the following list for",! + D DIS + S C=0,SDWLI="" F S C=$O(^TMP($J,"SDWLCU5",$J,C)) Q:C<1 D + .F S SDWLI=$O(^TMP($J,"SDWLCU5",$J,C,SDWLI)) Q:SDWLI="" W !,?20,C,". ",$$GET1^DIQ(4,SDWLI_",",.01) S CS=C +CHK10 W ! S DIR(0)="NO^1:"_CS D ^DIR + I Y<1!($D(DUOUT)) W !,"Response Required." S SDWLERR=1 Q + S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,+Y,0)) +CH1E S SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG") + S TAG="CHK" + Q +CHK3 ; + S SDWLERR="" + S SDWLI=$P(^SDWL(409.3,SDWLDA,0),U,8) + Q:'SDWLI!'$D(^SDWL(409.31,SDWLI)) + I '$D(^SDWL(409.31,SDWLI,"I","B",SDWLINST)) D Q:SDWLERR=1 + .S SDWLIX="",C=0 F S SDWLIX=$O(^SDWL(409.31,SDWLI,"I","B",SDWLIX)) Q:SDWLIX="" S C=C+1,^TMP($J,"SDWLCU5",$J,C,SDWLIX)="",^TMP($J,"SDWLCU5",$J,"B",SDWLIX)="" + .I 'C S SDWLINSN=$S($D(DUZ(2)):DUZ(2),1:""),Y=1 D CHE3 Q + .I C=1 S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,C,0)),Y=1 D CHE3 Q + .W !,"Please select a valid Institution for this record from the following list for",! + .D DIS + .S C=0,SDWLIZ=0 F S SDWLIZ=$O(^SDWL(409.31,SDWLI,"I","B",SDWLIZ)) Q:SDWLIZ="" D + ..Q:$$GET1^DIQ(4,SDWLIZ_",",11,"I")'="N"!('$$TF^XUAF4(SDWLIZ)) + ..S C=C+1 W !,?20,C,". ",$$GET1^DIQ(4,SDWLIZ_",",.01) + .W ! S DIR(0)="NO^1:"_C D ^DIR + .I $D(DUOUT)!(Y="") S SDWLERR=1 Q + .S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,+Y,0)) + .D CHE3 + Q +CHE3 ; + G CHK3:Y<0 + S SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG") + S TAG="CHK" + Q +CHK4 ; + S SDWLI=$P(^SDWL(409.3,SDWLDA,0),U,9) + Q:'SDWLI!'$D(^SDWL(409.32,SDWLI,0)) + I $P(^SDWL(409.32,SDWLI,0),U,6)'=SDWLINST D + .D DIS + .S SDWLINSN=$P(^SDWL(409.32,SDWLI,0),U,6),SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG") + Q +CHK2 ; + S SDWLPO=$P($G(^SDWL(409.3,SDWLDA,0)),U,7),SDWLTM=$P($G(^SCTM(404.57,SDWLPO,0)),U,2),SDWLINSN=$P($G(^SCTM(404.51,SDWLTM,0)),U,7) + I SDWLINST'=SDWLINSN D + .S SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG") + S TAG="CHK" + Q +DIS ;display record + S NN=$P($G(^SDWL(409.3,SDWLDA,0)),"^"),NAME=$$GET1^DIQ(2,NN_",",.01,"E") + S SSN=$$GET1^DIQ(2,NN_",",.09) + W !,"Record#: ",SDWLDA," Patient: ",NAME," (",SSN,")",!! + Q +GETINS ;Get institution + N DIR + S DIR("A")="Select Institution: " + S DIR(0)="PAO^4:EMZ",DIR("S")="I $P(^DIC(4,+Y,0),U,11)=""N"",$$TF^XUAF4(+Y)" D ^DIR + I X["^" S SDWLERR=1 Q + I Y<1 W *7,"Invalid Entry" G GETINS + S SDWLINSN=+Y + Q diff --git a/r/SCHEDULING-SD-SC/SDWLCU6.m b/r/SCHEDULING-SD-SC/SDWLCU6.m index 142d6421..cae7120c 100644 --- a/r/SCHEDULING-SD-SC/SDWLCU6.m +++ b/r/SCHEDULING-SD-SC/SDWLCU6.m @@ -1,51 +1,50 @@ -SDWLCU6 ;IOFO BAY PINES/DMR - EWL FILE 409.3 CLEANUP - print ;2/15/05 ; Compiled August 20, 2007 15:12:20 - ;;5.3;scheduling;**427,491**;AUG 13 1993;Build 53 - N XFL,XFL1,XFLG,XDATA,END,SDWLAPTD,I,J,SDWLPD,SDWLPG,SDWLWD,SDWLTP,SDWLTP1 - S (IEN,PAT)="",(CC,SDWLPG,SDWLTP)=0,U="^",END="" - D NOW^%DTC S Y=% D DD^%DT S SDWLDTP=Y - D HD - F S PAT=$O(^SDWL(409.3,"B",PAT)) Q:PAT="" D Q:END - .S IEN="" F S IEN=$O(^SDWL(409.3,"B",PAT,IEN)) Q:IEN="" D Q:END - ..S SDWLX=$G(^SDWL(409.3,IEN,0)),XFLG="",XFL=1,SDWLWD="",SDWLTP1="" - ..F I=3,5,XFL S XDATA=$P(SDWLX,U,I) S:I=5&XDATA XFL=XDATA+5 S:'XDATA XFLG=XFLG_I I I=5,XFL=1 D FIX - ..I XFLG D - ...D HD:$Y+5>IOSL Q:END - ...S NN="",NAME="" S NN=$P($G(^SDWL(409.3,IEN,0)),"^",1),NAME=$$GET1^DIQ(2,NN_",",.01,"E") - ...S SDWLAPTD=$P(SDWLX,U,16) I SDWLAPTD'="" S Y=SDWLAPTD D DD^%DT S SDWLAPTD=Y - ...W !!,IEN,?6,NAME,?40,SDWLAPTD,?54,$P(SDWLX,U,17),?58 - ...S XFL="" F I=1:1:3 Q:$E(XFLG,I)="" S XFL=XFL_$S(XFL'="":",",1:"")_$P("::INST::Type:Team:Postn:Srv/Spec:Clinic",":",$E(XFLG,I)) - ...W XFL W:SDWLTP1'="" "/++" - ...W:SDWLWD'="" !,?5,SDWLWD - ...S CC=CC+1 - Q:END - IF CC>.5 W !!,"TOTAL null field error EWL entries: "_CC - I SDWLTP>.5 W !!,"++ Missing Wait List Type and corresponding field entry (TEAM,POSITION,",!," SERVICE/SPECIALTY,CLINIC). Correct corresponding field entries",!," and running report again will correct Wait List Type field" - D CLINIC - W !!,"** End of Report **" - Q -CLINIC ;Display all clinics in file 409.32 that need to be cleaned up in file 44 in mail message - S INST="",CLINIC=0,CC=0 - F S CLINIC=$O(^SDWL(409.32,CLINIC)) Q:'CLINIC D - . N CL,INSTST S CL=+$G(^SDWL(409.32,CLINIC,0)) Q:CL'>0 - . S INSTST=$$CLIN^SDWLPE(CL) - . I $P(INSTST,U,6)'="" W !,*7,$P(INSTST,U,6) D - .. S CC=CC+1 - .. I CC=1 W !!!,"The following clinics need to have the institution updated in file 44:",!! - .. W !,?20,$$GET1^DIQ(44,+$G(^SDWL(409.32,CLINIC,0))_",",.01) - Q -FIX ;fix corrupted Wait List Type piece 5 - S XFL1=0,SDWLTP1="" - F J=6:1:9 S XDATA=$P(SDWLX,U,J) S:XDATA'="" XFL1=J - I 'XFL1 S SDWLTP=SDWLTP+1,SDWLTP1="++" Q - I XFL'=1,XFL=XFL1 Q - S $P(SDWLX,U,5)=XFL1-5,XFL=XFL1,^SDWL(409.3,IEN,0)=SDWLX - S SDWLWD="** WAIT LIST TYPE corrected to value: "_(XFL1-5)_" ("_$P("TEAM;POSITION;SERV/SPCLTY;CLINIC",";",XFL1-5)_")" - Q -HD ;HDR - I SDWLPG>0,$E(IOST,1,2)="C-" S END=$$EOP^ESPUTIL() Q:END - S SDWLPG=SDWLPG+1 W:SDWLPG'=1 @IOF - W !,?15,"Wait List Key Field 'NULL' Report" - S Y=DT D DD^%DT S SDWLPD=Y W ?57,SDWLPD,?72,"Page: ",SDWLPG - W !!,"STATION: "_+$$SITE^VASITE(,) - W !!,"IEN Patient Name",?42,"Wait Date",?53,"STS",?58,"Null Fields" - Q +SDWLCU6 ;IOFO BAY PINES/DMR - EWL FILE 409.3 CLEANUP - print ;2/15/05 + ;;5.3;scheduling;**427**;AUG 13 1993 + N XFL,XFL1,XFLG,XDATA,END,SDWLAPTD,I,J,SDWLPD,SDWLPG,SDWLWD,SDWLTP,SDWLTP1 + S (IEN,PAT)="",(CC,SDWLPG,SDWLTP)=0,U="^",END="" + D NOW^%DTC S Y=% D DD^%DT S SDWLDTP=Y + D HD + F S PAT=$O(^SDWL(409.3,"B",PAT)) Q:PAT="" D Q:END + .S IEN="" F S IEN=$O(^SDWL(409.3,"B",PAT,IEN)) Q:IEN="" D Q:END + ..S SDWLX=$G(^SDWL(409.3,IEN,0)),XFLG="",XFL=1,SDWLWD="",SDWLTP1="" + ..F I=3,5,XFL S XDATA=$P(SDWLX,U,I) S:I=5&XDATA XFL=XDATA+5 S:'XDATA XFLG=XFLG_I I I=5,XFL=1 D FIX + ..I XFLG D + ...D HD:$Y+5>IOSL Q:END + ...S NN="",NAME="" S NN=$P($G(^SDWL(409.3,IEN,0)),"^",1),NAME=$$GET1^DIQ(2,NN_",",.01,"E") + ...S SDWLAPTD=$P(SDWLX,U,16) I SDWLAPTD'="" S Y=SDWLAPTD D DD^%DT S SDWLAPTD=Y + ...W !!,IEN,?6,NAME,?40,SDWLAPTD,?54,$P(SDWLX,U,17),?58 + ...S XFL="" F I=1:1:3 Q:$E(XFLG,I)="" S XFL=XFL_$S(XFL'="":",",1:"")_$P("::INST::Type:Team:Postn:Srv/Spec:Clinic",":",$E(XFLG,I)) + ...W XFL W:SDWLTP1'="" "/++" + ...W:SDWLWD'="" !,?5,SDWLWD + ...S CC=CC+1 + Q:END + IF CC>.5 W !!,"TOTAL null field error EWL entries: "_CC + I SDWLTP>.5 W !!,"++ Missing Wait List Type and corresponding field entry (TEAM,POSITION,",!," SERVICE/SPECIALTY,CLINIC). Correct corresponding field entries",!," and running report again will correct Wait List Type field" + D CLINIC + W !!,"** End of Report **" + Q +CLINIC ;Display all clinics in file 409.32 that need to be cleaned up in file 44 in mail message + S INST="",CLINIC=0,CC=0 + F S CLINIC=$O(^SDWL(409.32,CLINIC)) Q:'CLINIC D + . S INST=$$GET1^DIQ(44,+$G(^SDWL(409.32,CLINIC,0))_",",3,"I") + . I $$GET1^DIQ(4,INST_",",11,"I")'="N"!('$$TF^XUAF4(INST)) D + .. S CC=CC+1 + .. I CC=1 W !!!,"The following clinics need to have the institution cleaned in file 44:",!! + .. W !,?20,$$GET1^DIQ(44,+$G(^SDWL(409.32,CLINIC,0))_",",.01) + Q +FIX ;fix corrupted Wait List Type piece 5 + S XFL1=0,SDWLTP1="" + F J=6:1:9 S XDATA=$P(SDWLX,U,J) S:XDATA'="" XFL1=J + I 'XFL1 S SDWLTP=SDWLTP+1,SDWLTP1="++" Q + I XFL'=1,XFL=XFL1 Q + S $P(SDWLX,U,5)=XFL1-5,XFL=XFL1,^SDWL(409.3,IEN,0)=SDWLX + S SDWLWD="** WAIT LIST TYPE corrected to value: "_(XFL1-5)_" ("_$P("TEAM;POSITION;SERV/SPCLTY;CLINIC",";",XFL1-5)_")" + Q +HD ;HDR + I SDWLPG>0,$E(IOST,1,2)="C-" S END=$$EOP^ESPUTIL() Q:END + S SDWLPG=SDWLPG+1 W:SDWLPG'=1 @IOF + W !,?15,"Wait List Key Field 'NULL' Report" + S Y=DT D DD^%DT S SDWLPD=Y W ?57,SDWLPD,?72,"Page: ",SDWLPG + W !!,"STATION: "_DUZ(2) + W !!,"IEN Patient Name",?42,"Wait Date",?53,"STS",?58,"Null Fields" + Q diff --git a/r/SCHEDULING-SD-SC/SDWLE.m b/r/SCHEDULING-SD-SC/SDWLE.m index 459c9de0..ba553cb6 100644 --- a/r/SCHEDULING-SD-SC/SDWLE.m +++ b/r/SCHEDULING-SD-SC/SDWLE.m @@ -1,130 +1,130 @@ -SDWLE ;BPOI/TEH - WAITING LIST-ENTER/EDIT;06/12/2002 - ;;5.3;scheduling;**263,415,446,524**;08/13/93;Build 29 - ; - ; - ;****************************************************************** - ; CHANGE LOG - ; - ; DATE PATCH DESCRIPTION - ; ---- ----- ----------- - ; 09JUN2005 446 Inter-Facility Transfer. - ; - ; -EN ;ENTRY POINT - INTIALIZE VARIABLES - N DTOUT,% - I $D(SDWLOPT),SDWLOPT G OPT - I $D(SDWLLIST),SDWLLIST,$D(DFN),DFN<0 K SDWLLIST - I $D(SDWLLIST),SDWLLIST,$D(DFN),DFN'="" S SDWLDFN=DFN D 1^VADPT S (SDWLTEM,SDWLPOS)=0 D HD,SB1 G EN1:'$D(DUOUT) W !,"PATIENT: ",VADM(1),?40,VA("PID") W !,*7,"PATIENT'S DATE OF DEATH HAS BEEN RECORDED" S DIR(0)="E" D ^DIR G END - K ^TMP("SDWLD",$J) D HD - D PAT G END:DFN<0 -OPT S SDWLPCMM=0,SDWLERR=0 I $D(SDWLOPT),SDWLOPT D - .S %=2 W !,"DO YOU WISH TO PLACE THIS PATIENT ON A WAITING LIST " D YN^DICN - .I %=-1!(%=2) S SDWLERR=1 Q - I $D(SDWLOPT),SDWLOPT,SDWLERR Q - S SDWLDFN=DFN - D 1^VADPT - S (SDWLTEM,SDWLPOS)=0 -EN1 N SDWLNEW,SDWLERR,SDWLCN,SDWLWTE S SDWLNEW=0,SDWLERR=0,SDWLCN=0,SDWLWTE=0 - G:$$EN^SDWLE6(SDWLDFN,.SDWLERR) EN2 ; OG ; SD*5.3*446 ; Inter-facility transfer - D DIS - I $D(^SDWL(409.3,"B",DFN)),'SDWLCN W !!,"PATIENT: ",VADM(1),?40,VA("PID") - S SDWLPS=$S(SDWLCN>1:1,SDWLCN=1:2,1:3) - I $D(SDWLOPT),SDWLOPT,SDWLPS=3 S X="Y" G ENO - I SDWLPS=1 S DIR(0)="FOA^^" S DIR("A")="Select Wait List (1-"_SDWLCN_") or Enter 'N' for New or '^' to Quit ? ",DIR("?")="Enter a Valid Number or 'N' for New." - I SDWLPS=2 S DIR(0)="FOA^^" S DIR("A")="Select Wait List (1) or Enter 'N' for New or '^' to Quit ? ",DIR("?")="Enter a '1' or 'N' for New." - I SDWLPS=3 S DIR(0)="YAO^^S X=""Y""" S DIR("A")="Patient is not on Waiting List. Do you wish to Add Patient? Yes// " - W ! D ^DIR W ! K DIR - G END:$D(DUOUT),END:$D(DTOUT) - I SDWLPS=1 D G EN3:SDWLERR=1 I SDWLERR=2 W *7," ??" G EN1 - .S SDWLERR=$S(X?1"N".E:0,X?1"n".E:0,X="":2,$D(DUOUT):1,X["^":1,$D(^TMP("SDWLD",$J,DFN,+X)):0,1:2) Q - I SDWLPS=2 D G EN3:SDWLERR=1 I SDWLERR=2 W *7," ??" G EN1 - .S SDWLERR=$S(X?1"N".E:0,X?1"n".E:0,X="":2,$D(DUOUT):1,X["^":1,$D(^TMP("SDWLD",$J,DFN,+X)):0,1:2) Q -ENO I SDWLPS=3 D G EN3:SDWLERR=1 I SDWLERR=2 W *7," ??" G EN1 - .S SDWLERR=$S(X?1"N".E:1,X?1"n".E:1,X="":0,X?1"Y".E:0,X?1"y".E:0,$D(DUOUT):1,X["^":1,1:2) Q - I SDWLPS=1!(SDWLPS=2),X?1N.N D - .N DA,SDWLDA S (DA,SDWLDA)=$P($G(^TMP("SDWLD",$J,DFN,+X)),"~",2),SDWLEDIT="" - .; - .;LOCK DATA FILE - .; - .L +^SDWL(409.3,DA):5 I '$T W !,"ANOTHER TERMINAL IS EDITING THIS ENTRY. TRY LATER." S DUOUT=1 - .I $D(DUOUT) Q - .N SDWLINNM,SDWLSTN ; OG ; This and the following six lines added for patch 415 - .I $$GETTRN^SDWLIFT1(SDWLDA,.SDWLINNM,.SDWLSTN) D S DUOUT=1 Q - ..N SDWLMSG,SDWLI - ..S SDWLMSG(0)=1,SDWLMSG(SDWLMSG(0),0)="This entry is the subject of a transfer to "_SDWLINNM_" ("_SDWLSTN_"). Editing inhibited." - ..I $L(SDWLMSG(SDWLMSG(0),0))>80 D COL80^SDWLIFT(.SDWLMSG) - ..F SDWLI=1:1:SDWLMSG(0) W !,SDWLMSG(SDWLI,0) - ..Q - .D EN^SDWLE10 - .D EDIT W !!,"Editing is Completed" S SDWLERR=1 K SDWLEDIT - G END:SDWLERR - I SDWLPS=1!(SDWLPS=2),X?1"N".E!(X?1"n".E) D NEW,EDIT S SDWLNEW="" G EN2 - I SDWLPS=3 D NEW,EDIT S SDWLNEW="" -EN2 I $D(SDWLNEW),'$D(DUOUT),'SDWLERR W !!,?15,"*** Patient has been added to Wait List ***",! - K SDWLNEW,DUOUT - ; - ;UNLOCK FILE AND KILL LOCAL VARIABLES - ; - I $D(SDWLDA) L -^SDWL(409.3,SDWLDA) - ;-exit logic -EN3 D END^SDWLE113 - Q -END D END^SDWLE113 - D EN^SDWLKIL - Q - ; - ; -PAT ;SELECT PATIENT - ; - S DIC(0)="EMNZAQ",DIC=2 D ^DIC S (SDWLDFN,DFN)=$P(Y,U,1) G PAT1:DFN<0 - S X=$$GET1^DIQ(2,DFN_",",".351") I X'="" W !,*7,"PATIENT'S DATE OF DEATH HAS BEEN RECORDED" G PAT - S SDWLSSN=$G(VA("PID")),SDWLNAM=$G(VA(1)) -PAT1 K VADM,VAIN,VAERR,VA Q - ; -DIS ;DISPLAY DATA FOR PATIENT - ; - S SDWLHDR="Wait List Enter/Edit" - D EN^SDWLD(DFN,VA("PID"),VADM(1)) - D PCM^SDWLE1,PCMD^SDWLE1 - Q - ; -NEW ; - D NEW^SDWLE11 - Q - ; -EDIT ; - D EN^SDWLE111 I $D(DUOUT) D END^SDWLE113:'$D(SDWLEDIT) Q - I SDWLTYE=4 D ED4 K DIR,DIE,DIC,DR Q - I SDWLTYE=3 D ED3 K DIR,DIE,DIC,DR Q - I SDWLTYE=2 D ED2 K DIR,DIE,DIC,DR Q - I SDWLTYE=1 D ED1 K DIR,DIE,DIC,DR Q - Q -ED1 ;-team - I $D(DUOUT) D END^SDWLE113:'$D(SDWLEDIT) Q - D EN^SDWLE3 I '$D(DUOUT) D EN^SDWLE113 Q - Q -ED2 ;-position - I $D(DUOUT) D END^SDWLE113:'$D(SDWLEDIT) Q - D EN^SDWLE5 I '$D(DUOUT) D EN^SDWLE113 Q - Q -ED3 ;-specialty - D EN^SDWLE2 I $D(DUOUT) D END^SDWLE113:'$D(SDWLEDIT) Q - D EN^SDWLE110 I $D(DUOUT) D END^SDWLE113:'$D(SDWLEDIT) Q - I '$D(DUOUT) D EN^SDWLE113 - D END^SDWLE113 - Q -ED4 ;-clinic - D EN^SDWLE4 I $D(DUOUT) D END^SDWLE113:'$D(SDWLEDIT) Q - D EN^SDWLE110 I $D(DUOUT) D END^SDWLE113:'$D(SDWLEDIT) Q - I '$D(DUOUT) D EN^SDWLE113 - D END^SDWLE113 - Q - ; -ED5 D END^SDWLE113 - Q -SB1 S X=$$GET1^DIQ(2,DFN_",",".351") I X'="" S DUOUT="" - Q -HD W:$D(IOF) @IOF W !,?80-$L("Scheduling/PCMM Enter/Edit Wait List")\2,"Scheduling/PCMM Enter/Edit Wait List",!! - I $D(DFN),DFN'="",'$D(^SDWL(409.3,"B",DFN)),$D(SDWLLIST),SDWLLIST D - .W !!,"PATIENT: ",VADM(1),?40,VA("PID") - Q +SDWLE ;;IOFO BAY PINES/TEH - WAITING LIST-ENTER/EDIT;06/12/2002 ; 20 Aug 2002 2:10 PM + ;;5.3;scheduling;**263,446**;AUG 13 1993;Build 77 + ; + ; + ;****************************************************************** + ; CHANGE LOG + ; + ; DATE PATCH DESCRIPTION + ; ---- ----- ----------- + ; 09JUN2005 446 Inter-Facility Transfer. + ; + ; +EN ;ENTRY POINT - INTIALIZE VARIABLES + N DTOUT,% + I $D(SDWLOPT),SDWLOPT G OPT + I $D(SDWLLIST),SDWLLIST,$D(DFN),DFN<0 K SDWLLIST + I $D(SDWLLIST),SDWLLIST,$D(DFN),DFN'="" S SDWLDFN=DFN D 1^VADPT S (SDWLTEM,SDWLPOS)=0 D HD,SB1 G EN1:'$D(DUOUT) W !,"PATIENT: ",VADM(1),?40,VA("PID") W !,*7,"PATIENT'S DATE OF DEATH HAS BEEN RECORDED" S DIR(0)="E" D ^DIR G END + K ^TMP("SDWLD",$J) D HD + D PAT G END:DFN<0 +OPT S SDWLPCMM=0,SDWLERR=0 I $D(SDWLOPT),SDWLOPT D + .S %=2 W !,"DO YOU WISH TO PLACE THIS PATIENT ON A WAITING LIST " D YN^DICN + .I %=-1!(%=2) S SDWLERR=1 Q + I $D(SDWLOPT),SDWLOPT,SDWLERR Q + S SDWLDFN=DFN + D 1^VADPT + S (SDWLTEM,SDWLPOS)=0 +EN1 N SDWLNEW,SDWLERR,SDWLCN,SDWLWTE S SDWLNEW=0,SDWLERR=0,SDWLCN=0,SDWLWTE=0 + G:$$EN^SDWLE6(SDWLDFN,.SDWLERR) EN2 ; OG ; SD*5.3*446 ; Inter-facility transfer + D DIS + I $D(^SDWL(409.3,"B",DFN)),'SDWLCN W !!,"PATIENT: ",VADM(1),?40,VA("PID") + S SDWLPS=$S(SDWLCN>1:1,SDWLCN=1:2,1:3) + I $D(SDWLOPT),SDWLOPT,SDWLPS=3 S X="Y" G ENO + I SDWLPS=1 S DIR(0)="FOA^^" S DIR("A")="Select Wait List (1-"_SDWLCN_") or Enter 'N' for New or '^' to Quit ? ",DIR("?")="Enter a Valid Number or 'N' for New." + I SDWLPS=2 S DIR(0)="FOA^^" S DIR("A")="Select Wait List (1) or Enter 'N' for New or '^' to Quit ? ",DIR("?")="Enter a '1' or 'N' for New." + I SDWLPS=3 S DIR(0)="YAO^^S X=""Y""" S DIR("A")="Patient is not on Waiting List. Do you wish to Add Patient? Yes// " + W ! D ^DIR W ! K DIR + G END:$D(DUOUT),END:$D(DTOUT) + I SDWLPS=1 D G EN3:SDWLERR=1 I SDWLERR=2 W *7," ??" G EN1 + .S SDWLERR=$S(X?1"N".E:0,X?1"n".E:0,X="":2,$D(DUOUT):1,X["^":1,$D(^TMP("SDWLD",$J,DFN,+X)):0,1:2) Q + I SDWLPS=2 D G EN3:SDWLERR=1 I SDWLERR=2 W *7," ??" G EN1 + .S SDWLERR=$S(X?1"N".E:0,X?1"n".E:0,X="":2,$D(DUOUT):1,X["^":1,$D(^TMP("SDWLD",$J,DFN,+X)):0,1:2) Q +ENO I SDWLPS=3 D G EN3:SDWLERR=1 I SDWLERR=2 W *7," ??" G EN1 + .S SDWLERR=$S(X?1"N".E:1,X?1"n".E:1,X="":0,X?1"Y".E:0,X?1"y".E:0,$D(DUOUT):1,X["^":1,1:2) Q + I SDWLPS=1!(SDWLPS=2),X?1N.N D + .N DA,SDWLDA S (DA,SDWLDA)=$P($G(^TMP("SDWLD",$J,DFN,+X)),"~",2),SDWLEDIT="" + .; + .;LOCK DATA FILE + .; + .L +^SDWL(409.3,DA):5 I '$T W !,"ANOTHER TERMINAL IS EDITING THIS ENTRY. TRY LATER." S DUOUT=1 + .I $D(DUOUT) Q + .N SDWLINNM,SDWLSTN ; OG ; This and the following six lines added for patch 415 + .I $$GETTRN^SDWLIFT1(SDWLDA,.SDWLINNM,.SDWLSTN) D S DUOUT=1 Q + ..N SDWLMSG,SDWLI + ..S SDWLMSG(0)=1,SDWLMSG(SDWLMSG(0),0)="This entry is the subject of a transfer to "_SDWLINNM_" ("_SDWLSTN_"). Editing inhibited." + ..I $L(SDWLMSG(SDWLMSG(0),0))>80 D COL80^SDWLIFT(.SDWLMSG) + ..F SDWLI=1:1:SDWLMSG(0) W !,SDWLMSG(SDWLI,0) + ..Q + .D EN^SDWLE10 + .D EDIT W !!,"Editing is Completed" S SDWLERR=1 K SDWLEDIT + G END:SDWLERR + I SDWLPS=1!(SDWLPS=2),X?1"N".E!(X?1"n".E) D NEW,EDIT S SDWLNEW="" G EN2 + I SDWLPS=3 D NEW,EDIT S SDWLNEW="" +EN2 I $D(SDWLNEW),'$D(DUOUT),'SDWLERR W !!,?15,"*** Patient has been added to Wait List ***",! + K SDWLNEW,DUOUT + ; + ;UNLOCK FILE AND KILL LOCAL VARIABLES + ; + I $D(SDWLDA) L -^SDWL(409.3,SDWLDA) + ;-exit logic +EN3 D END^SDWLE113 + Q +END D END^SDWLE113 + D EN^SDWLKIL + Q + ; + ; +PAT ;SELECT PATIENT + ; + S DIC(0)="EMNZAQ",DIC=2 D ^DIC S (SDWLDFN,DFN)=$P(Y,U,1) G PAT1:DFN<0 + S X=$$GET1^DIQ(2,DFN_",",".351") I X'="" W !,*7,"PATIENT'S DATE OF DEATH HAS BEEN RECORDED" G PAT + S SDWLSSN=$G(VA("PID")),SDWLNAM=$G(VA(1)) +PAT1 K VADM,VAIN,VAERR,VA Q + ; +DIS ;DISPLAY DATA FOR PATIENT + ; + S SDWLHDR="Wait List Enter/Edit" + D EN^SDWLD(DFN,VA("PID"),VADM(1)) + D PCM^SDWLE1,PCMD^SDWLE1 + Q + ; +NEW ; + D NEW^SDWLE11 + Q + ; +EDIT ; + D EN^SDWLE111 I $D(DUOUT) D END^SDWLE113:'$D(SDWLEDIT) Q + I SDWLTYE=4 D ED4 K DIR,DIE,DIC,DR Q + I SDWLTYE=3 D ED3 K DIR,DIE,DIC,DR Q + I SDWLTYE=2 D ED2 K DIR,DIE,DIC,DR Q + I SDWLTYE=1 D ED1 K DIR,DIE,DIC,DR Q + Q +ED1 ;-team + I $D(DUOUT) D END^SDWLE113:'$D(SDWLEDIT) Q + D EN^SDWLE3 I '$D(DUOUT) D EN^SDWLE113 Q + Q +ED2 ;-position + I $D(DUOUT) D END^SDWLE113:'$D(SDWLEDIT) Q + D EN^SDWLE5 I '$D(DUOUT) D EN^SDWLE113 Q + Q +ED3 ;-specialty + D EN^SDWLE2 I $D(DUOUT) D END^SDWLE113:'$D(SDWLEDIT) Q + D EN^SDWLE110 I $D(DUOUT) D END^SDWLE113:'$D(SDWLEDIT) Q + I '$D(DUOUT) D EN^SDWLE113 + D END^SDWLE113 + Q +ED4 ;-clinic + D EN^SDWLE4 I $D(DUOUT) D END^SDWLE113:'$D(SDWLEDIT) Q + D EN^SDWLE110 I $D(DUOUT) D END^SDWLE113:'$D(SDWLEDIT) Q + I '$D(DUOUT) D EN^SDWLE113 + D END^SDWLE113 + Q + ; +ED5 D END^SDWLE113 + Q +SB1 S X=$$GET1^DIQ(2,DFN_",",".351") I X'="" S DUOUT="" + Q +HD W:$D(IOF) @IOF W !,?80-$L("Scheduling/PCMM Enter/Edit Wait List")\2,"Scheduling/PCMM Enter/Edit Wait List",!! + I $D(DFN),DFN'="",'$D(^SDWL(409.3,"B",DFN)),$D(SDWLLIST),SDWLLIST D + .W !!,"PATIENT: ",VADM(1),?40,VA("PID") + Q diff --git a/r/SCHEDULING-SD-SC/SDWLI.m b/r/SCHEDULING-SD-SC/SDWLI.m index 9cce12b8..d17cd78d 100644 --- a/r/SCHEDULING-SD-SC/SDWLI.m +++ b/r/SCHEDULING-SD-SC/SDWLI.m @@ -1,168 +1,165 @@ -SDWLI ;BPOI/TEH - DISPLAY PENDING APPOINTMENTS;6/1/05 - ;;5.3;scheduling;**263,327,394,446,524**;08/13/93;Build 29 - ; - ; - ;****************************************************************** - ; CHANGE LOG - ; - ; DATE PATCH DESCRIPTION - ; ---- ----- ----------- - ; 04/22/2005 SD*5.3*327 DISPLAY APPOINTMENT INFORMATION - ; 04/22/2005 SD*5.3*327 UNDEFINED ERROR HD+1 - ; 08/07/2006 SD*5.3*446 proceed only when DFN defined - ; 04/14/2006 SD*5.3*446 INTER-FACILITY TRANSFER - ; - ; -EN ;NEW AND INITIALIZE VARIABLES - S SDWLERR=0 - I $D(SDWLLIST),SDWLLIST D Q:SDWLERR - .I '$G(DFN) S SDWLERR=1 Q - .I $D(DFN),DFN'="",'$D(^SDWL(409.3,"B",DFN)) D HD W *7,!,"This Patient has NO entries on the Electronic Wait List." S DIR(0)="E" D ^DIR S DUOUT=1 Q - I $D(DUOUT) G END - I 'SDWLERR,$D(SDWLLIST),SDWLLIST D 1^VADPT,DEM^VADPT S SDWLDFN=DFN D HD K DIR,DIC,DR,DIE,VADM S (SDWLBDT,SDWLEDT)="" K ^TMP("SDWLI",$J) G EN1 - K DIR,DIC,DR,DIE,VADM - S (SDWLBDT,SDWLEDT)="" K ^TMP("SDWLI",$J) - ; - ;OPTION HEADER - ; - D HD - ; - ;PATIENT LOOK-UP FROM WAIT LIST PATIENT FILE (^SDWL(409.3,IEN,0). - ; - D SEL G EN:$D(DUOUT) - D PAT Q:'$D(SDWLDFN) - G END:SDWLDFN<0,END:SDWLDFN="" - Q:$D(DUOUT) -EN1 K DIR,DIC,DR,DIE,SDWLDRG - D GETFILE - D DISP G EN:'$D(DUOUT) - D END - Q -PAT ;PATIENT LOOK-UP - ;PATCH SD*5.3*524 - SET DIC("S") FOR SCREEN OF OPEN/CLOSED ENTRIES - S DIC("S")="I $D(SDWLY),SDWLY,$P(^SDWL(409.3,+Y,0),U,17)=""O""" - S DIC(0)="EMNQA",DIC=409.3 D ^DIC S (SDWLDFN,DFN)=$P(Y,U,2) - G PATEND:SDWLDFN="" - Q:Y<0 - Q:$D(DUOUT) - D 1^VADPT -PATEND Q - ; - ;PROMPT FOR DISPLAY 'OPEN' WAITING LIST ONLY OR PROMPT FOR BEGINNING AND ENDING DATES - ; -SEL K SDWLDRG S DIR(0)="Y" S DIR("A")="Do You Want to View Only 'OPEN' Wait Lists",DIR("B")="YES" - S DIR("?")="'Yes' for 'Open' and these Patient Record have not been dispositioned and 'No' for all Records." - W ! D ^DIR S SDWLY=Y W ! - I X["^" S DUOUT=1 - I SDWLY=0 D SEL1 - Q -SEL1 K DIR,%DT(0) S SDWLDISC="",%DT="AE",%DT("A")="Start with Date Entered: " D ^%DT G SEL:Y<1 S SDWLBDT=Y - S %DT(0)=SDWLBDT,%DT("A")="End with Date Entered: " D ^%DT G SEL1:Y<1 S SDWLEDT=Y,SDWLDRG="" K %DT(0),%DT("A") - Q - ; -GETFILE ;GET DATA - OPTIONAL DATE RANGE IF SDWLDBT AND SDWLEDT VALID DATE RANGE - ; - K ^TMP("SDWLI",$J),SDWLDISX S SDWLDA=0,SDWLCNT=0 F S SDWLDA=$O(^SDWL(409.3,"B",SDWLDFN,SDWLDA)) Q:SDWLDA="" D - .S SDWLDATA=$G(^SDWL(409.3,SDWLDA,0)) I '$D(SDWLDRG),$P(SDWLDATA,U,17)["C" Q - .I '$P(SDWLDATA,U,3) Q - .N SDWLAPP S SDWLAPP="" I $D(^SDWL(409.3,SDWLDA,"SDAPT")) S SDWLAPP=^("SDAPT") D ;app data - ..S SDWLAPP=SDWLAPP_"~"_$P(SDWLDATA,U,23) - .N SDOP,SDOP1 S SDOP="" I $D(^SDWL(409.3,SDWLDA,1)) S SDOP=^(1),SDOP1=$$GET1^DIQ(409.3,SDWLDA_",",29),$P(SDOP,U)=SDOP1 - .I $D(^SDWL(409.3,SDWLDA,"DIS")) D - ..S SDWLDISX=$G(^SDWL(409.3,SDWLDA,"DIS")),SDWLDIS=$P(SDWLDISX,U,3),SDWLDDUZ=$P(SDWLDISX,U,2) - ..S SDWLDDT=$P(^SDWL(409.3,SDWLDA,"DIS"),U,1) - ..S SDWLDIDT="" I SDWLDDT'="" S SDWLDIDT=$E(SDWLDDT,4,5)_"/"_$E(SDWLDDT,6,7)_"/"_$E(SDWLDDT,2,3) - .I $D(^SDWL(409.3,SDWLDA,"DNR")) D - ..S SDREM=$G(^SDWL(409.3,SDWLDA,"DNR")) S SDREMD=$P(SDWLDATA,U,14),SDREMU=$P(SDWLDATA,U,15) - ..S SDREMDD="" I SDREMD'="" S SDREMDD=$E(SDREMD,4,5)_"/"_$E(SDREMD,6,7)_"/"_$E(SDREMD,2,3) - ..S SDREMR=$$GET1^DIQ(409.3,SDWLDA_",",18),SDREMRC=$$GET1^DIQ(409.3,SDWLDA_",",18.1,"I") - .S SDWLST=$P(SDWLDATA,U,6),SDWLSP=$P(SDWLDATA,U,7),SDWLSS=$P(SDWLDATA,U,8),SDWLSC=$P(SDWLDATA,U,9),SDWLDT=$P(SDWLDATA,U,2) - .S SDWLPROV=$P(SDWLDATA,U,13) I $D(SDWLDRG) D I SDNOK Q - ..S SDNOK=0 - ..I SDWLDTSDWLEDT) S SDNOK=1 Q - .; - .;IF STATUS IS CLOSED DO NOT DISPLAY RECORD - .; - .S SDWLCNT=SDWLCNT+1,^TMP("SDWLI",$J,SDWLCNT)=SDWLDATA_"~"_SDWLDA - .I $D(SDWLDISX) D - ..S ^TMP("SDWLI",$J,SDWLCNT,"DIS")=SDWLDIS_"^"_SDWLDDUZ_"^"_SDWLDIDT - ..I SDWLAPP>0 S ^TMP("SDWLI",$J,SDWLCNT,"SDAPT")=SDWLAPP - ..I SDOP'="" S ^TMP("SDWLI",$J,SDWLCNT,"SDOP")=SDOP - .I $D(SDREM) D - ..S ^TMP("SDWLI",$J,SDWLCNT,"REM")=SDREMR_U_SDREMRC_U_SDREMU_U_SDREMDD - .S ^TMP("SDWLI",$J)=SDWLCNT - .K SDWLDISX,SDREM - Q - ; -DISP ;Display Wait List Data - S (SDWLDT,SDWLCNT,SDWLCN)="",SDWLCT=$G(^TMP("SDWLI",$J)) I 'SDWLCT W !!,"No 'OPEN' Wait List Records to Display.",!! K DIR S DIR(0)="E" D ^DIR S DUOUT="" Q - F S SDWLCNT=$O(^TMP("SDWLI",$J,SDWLCNT)) Q:SDWLCNT="" D I $D(DUOUT) Q - .N SDWLDISX,SDWLR,SDWLCLPT - .I $D(^TMP("SDWLI",$J,SDWLCNT,"DIS")) S SDWLDISX=$G(^TMP("SDWLI",$J,SDWLCNT,"DIS")) - .I $D(^TMP("SDWLI",$J,SDWLCNT,"REM")) S SDWLR=$G(^TMP("SDWLI",$J,SDWLCNT,"REM")) D - ..S SDREMR=$P(SDWLR,U),SDREMRC=$P(SDWLR,U,2),SDREMU=$P(SDWLR,U,3),SDREMDD=$P(SDWLR,U,4) - .S X=$G(^TMP("SDWLI",$J,SDWLCNT)),SDWLDA=$P(X,"~",2),SDWLIN=$P(X,U,3),SDWLCL=$P(X,U,4),SDWLTY=$P(X,U,5),SDWLPRI=$P(X,U,11) - .S SDWLTYP=$S(SDWLTY=1:$P(X,U,6),SDWLTY=2:$P(X,U,7),SDWLTY=3:$P(X,U,8),SDWLTY=4:$P(X,U,9),1:"") - .S SDWLTYN=$S(SDWLTY=1:5,SDWLTY=2:6,SDWLTY=3:7,SDWLTY=4:8),SDWLCOM=$P($P(X,U,18),"~",1) - .S SDWLDUZ=$P(X,U,10),SDWLPRV=$P(X,U,12),SDWLPROV=$P(X,U,13),SDWLX=$P(X,"~",3) D - ..I $D(SDWLDISX) S SDWLDIS=$P(SDWLDISX,U,1),SDWLDDUZ=$P(SDWLDISX,U,2),SDWLDIDT=$P(SDWLDISX,U,3) - .S SDWLDT=$P(X,U,2),YY=$E(SDWLDT,1,3)+1700,YY=$E(YY,3,4),MM=$E(SDWLDT,4,5),DD=$E(SDWLDT,6,7),SDWLDTP=MM_"/"_DD_"/"_YY - .S SDWLDTD=$P(X,U,16),YY=$E(SDWLDTD,1,3)+1700,YY=$E(YY,3,4),MM=$E(SDWLDTD,4,5),DD=$E(SDWLDTD,6,7),SDWLDTD=MM_"/"_DD_"/"_YY - .;PATCH SD*5.3*394 See Note. - .N SDWLSCP - .S SDWLSCP=+$P($G(^SDWL(409.3,SDWLDA,"SC")),U,2) - .W !,"# ",$J(SDWLCNT,3),! - .W !,"Wait List - ",$$EXTERNAL^DILFD(409.3,4,,SDWLTY),?55,"Date Entered - ",SDWLDTP - .W !,?15 S X=$$EXTERNAL^DILFD(409.3,SDWLTYN,,SDWLTYP) W X - .S SDWLP=0 I SDWLPRI W !,"Priority - ",$$EXTERNAL^DILFD(409.3,10,,SDWLPRI) S SDWLP=1 - .I $D(SDWLSCP) W !,"Service Connected Priority - ",$$EXTERNAL^DILFD(409.3,15,,SDWLSCP) - .W:SDWLP ?15 W:'SDWLP ! W "Institution - ",$$EXTERNAL^DILFD(409.3,2,,SDWLIN) - .W !,"Entered by - " S X=$$EXTERNAL^DILFD(409.3,9,,SDWLDUZ) W X - .S SDWRB=0 I SDWLPRV W !,"Requested By - ",$$EXTERNAL^DILFD(409.3,11,,SDWLPRV),?55,"Date Desired - ",SDWLDTD - .I SDWLPRV=1 W !,"Provider - ",$$EXTERNAL^DILFD(409.3,12,,SDWLPROV) - .I $D(SDWLCOM),SDWLCOM'="" W !,"Comments - ",SDWLCOM - .I $D(^TMP("SDWLI",$J,SDWLCNT,"SDOP")) N SDOP S SDOP=^("SDOP") W !,"Reopen Reason: ",$P(SDOP,U) D - ..I $P(SDOP,U,2)'="" W !,"Reopen comment: ",$P(SDOP,U,2) - .I $D(^TMP("SDWLI",$J,SDWLCNT,"REM")) W !,"Non Removal Reason - ",SDREMR,!,"Non Remove Reason entered by - ",$$GET1^DIQ(200,SDREMU_",",.01,"I") D - ..I $L(SDREMRC)>0 W !,"Non Removal Comment - ",SDREMRC - ..W !,"Non Removal entry date - ",SDREMDD - .I $D(^TMP("SDWLI",$J,SDWLCNT,"DIS")) W !,"Disposition - ",$$EXTERNAL^DILFD(409.3,21,,SDWLDIS),?51,"Disposition Date - ",SDWLDIDT D - ..W !,"Dispositioned by - ",$$EXTERNAL^DILFD(409.3,20,,SDWLDDUZ) - .I $D(^TMP("SDWLI",$J,SDWLCNT,"SDAPT")) N SDAP S SDAP=^("SDAPT") D - ..W !,"Appointment scheduled for " S Y=$P(SDAP,"~",2) D DD^%DT W Y - ..W !?3,"Made on: " S Y=+SDAP D DD^%DT W Y,?30,"For clinic: " N SDC S SDC=$P(SDAP,U,2) S SDC=$$GET1^DIQ(44,SDC_",",.01) W SDC - ..N SDAIN S SDAIN=$P(SDAP,U,3),SDAIN=$$GET1^DIQ(4,SDAIN_",",.01) - ..W !?3,"Appt Institution: ",SDAIN - ..N SDCR S SDCR=$P(SDAP,U,4),SDCR=$$GET1^DIQ(40.7,SDCR_",",.01) - ..W ?40,"Appt Specialty: ",SDCR - ..N SAPS S SAPS=$P(SDAP,U,8),SAPS=$P(SAPS,"~") I SAPS="CC" W !,"Appointment Status: Canceled by Clinic" - .S SDWLCLPT=$$GET1^DIQ(409.3,SDWLDA,37,"I") ; SD*5.3*446 - .D:SDWLCLPT ; SD*5.3*446 - ..W !,"Clinic changed from: ",$$GET1^DIQ(409.3,SDWLCLPT,8) - ..W:SDWLIN'=$$GET1^DIQ(409.3,SDWLCLPT,2,"I") " (",$$GET1^DIQ(409.3,SDWLCLPT,2),")" - ..Q - .; Inter-facility Transfer. SD*5.3*446 - .I $$GETTRN^SDWLIFT1(SDWLDA,.SDWLINNM,.SDWLSTN) D ENS^%ZISS W !,IOINHI,"In transfer to ",SDWLINNM," (",SDWLSTN,")",IOINORM D KILL^%ZISS - .D GETS^DIQ(409.3,SDWLDA,"32;33;34;36;38;39","TMP") - .K SDWLIN,SDWLCL,SDWLTY,SDWLPRI,SDWLDUZ,SDWLPRV,SDWLDT,SDWLDTD,SDWLDIS,SDWLDIDT,SDWLTYN,SDWLCOM,SDWLPROV,SDWLDISX,DIR,DIE,DR,SDWLINNM,SDWLSTN - .W !,"*****",! K DIR S DIR(0)="E" D ^DIR D - ..I X["^" S DUOUT=1 Q - ..I 'Y S DUOUT=1 Q - ..D HD - Q -HD ;Header - W:$D(IOF) @IOF W !!,?80-$L("Wait List - Inquiry")\2,"Wait List - Inquiry ",! - ;SD*5.3*327 - Correct undefined. - I '$D(SDWLDFN) W !! Q - N DFN S DFN=SDWLDFN D DEM^VADPT - W:$D(VADM) !,VADM(1),?40 I $D(VA("PID")) W VA("PID") - W !! - K DUOUT - Q -END ; - K DIR,DIC,DR,DIE,SDWLDFN,DUOUT - K SDNOK,SDWLBDT,SDWLCL,SDWLCN,SDWLCNT,SDWLCOM,SDWLCT,SDWLDA,SDWLDATA,SDWLDDT,SDWLDDUZ,SDWLDFN,SDWLDIDT,SDWLDIS,SDWLDISX - K SDWLDRG,SDWLDT,SDWLDTD,SDWLDTP,SDWLDUZ,SDLWEDT,SDWLIN,SDLWP,SDWLPRI,SDWLPROV,SDLWPRV,SDWLSC,SDWLSP,SDWLSS,SDLWST,SDWLTY - K SDWLTYN,SDSWLTYP,SDLWX,SDWLY,SDWRB,SDWLBDT,SDWLDISC,SDWLERR,SDWLPRON,SDXSCAT,SDWLP,SDWLTYP - K SDREMD,SDREMDD,SDREMR,SDREMRC,SDREMU,MM,SDWLEDT,SDWLLIST,SDWLST,SDWLX,VA,X,Y,YY - Q +SDWLI ;IOFO BAY PINES/TEH - DISPLAY PENDING APPOINTMENTS ; 6/1/05 12:56pm ; Compiled April 16, 2007 10:00:47 + ;;5.3;scheduling;**263,327,394,446**;AUG 13 1993;Build 77 + ; + ; + ;****************************************************************** + ; CHANGE LOG + ; + ; DATE PATCH DESCRIPTION + ; ---- ----- ----------- + ; 04/22/2005 SD*5.3*327 DISPLAY APPOINTMENT INFORMATION + ; 04/22/2005 SD*5.3*327 UNDEFINED ERROR HD+1 + ; 08/07/2006 SD*5.3*446 proceed only when DFN defined + ; 04/14/2006 SD*5.3*446 INTER-FACILITY TRANSFER + ; + ; +EN ;NEW AND INITIALIZE VARIABLES + S SDWLERR=0 + I $D(SDWLLIST),SDWLLIST D Q:SDWLERR + .I '$G(DFN) S SDWLERR=1 Q + .I $D(DFN),DFN'="",'$D(^SDWL(409.3,"B",DFN)) D HD W *7,!,"This Patient has NO entries on the Electronic Wait List." S DIR(0)="E" D ^DIR S DUOUT=1 Q + I $D(DUOUT) G END + I 'SDWLERR,$D(SDWLLIST),SDWLLIST D 1^VADPT,DEM^VADPT S SDWLDFN=DFN D HD K DIR,DIC,DR,DIE,VADM S (SDWLBDT,SDWLEDT)="" K ^TMP("SDWLI",$J) G EN1 + K DIR,DIC,DR,DIE,VADM + S (SDWLBDT,SDWLEDT)="" K ^TMP("SDWLI",$J) + ; + ;OPTION HEADER + ; + D HD + ; + ;PATIENT LOOK-UP FROM WAIT LIST PATIENT FILE (^SDWL(409.3,IEN,0). + ; + D PAT Q:'$D(SDWLDFN) + G END:SDWLDFN<0,END:SDWLDFN="" + Q:$D(DUOUT) +EN1 K DIR,DIC,DR,DIE,SDWLDRG + D SEL G EN:$D(DUOUT) + D GETFILE + D DISP G EN:'$D(DUOUT) + D END + Q +PAT ;PATIENT LOOK-UP + S DIC(0)="EMNQA",DIC=409.3 D ^DIC S (SDWLDFN,DFN)=$P(Y,U,2) + G PATEND:SDWLDFN="" + Q:Y<0 + Q:$D(DUOUT) + D 1^VADPT +PATEND Q + ; + ;PROMPT FOR DISPLAY 'OPEN' WAITING LIST ONLY OR PROMPT FOR BEGINNING AND ENDING DATES + ; +SEL K SDWLDRG S DIR(0)="YAO^^" S DIR("A")="Do You Want to View Only 'OPEN' Wait Lists? Yes// " + S DIR("?")="'Yes' for 'Open' and these Patient Record have not been dispositioned and 'No' for all Records." + W ! D ^DIR S SDWLY=Y W ! + I X["^" S DUOUT=1 + I SDWLY=0 D SEL1 + Q +SEL1 K DIR,%DT(0) S SDWLDISC="",%DT="AE",%DT("A")="Start with Date Entered: " D ^%DT G SEL:Y<1 S SDWLBDT=Y + S %DT(0)=SDWLBDT,%DT("A")="End with Date Entered: " D ^%DT G SEL1:Y<1 S SDWLEDT=Y,SDWLDRG="" K %DT(0),%DT("A") + Q + ; +GETFILE ;GET DATA - OPTIONAL DATE RANGE IF SDWLDBT AND SDWLEDT VALID DATE RANGE + ; + K ^TMP("SDWLI",$J),SDWLDISX S SDWLDA=0,SDWLCNT=0 F S SDWLDA=$O(^SDWL(409.3,"B",SDWLDFN,SDWLDA)) Q:SDWLDA="" D + .S SDWLDATA=$G(^SDWL(409.3,SDWLDA,0)) I '$D(SDWLDRG),$P(SDWLDATA,U,17)["C" Q + .I '$P(SDWLDATA,U,3) Q + .N SDWLAPP S SDWLAPP="" I $D(^SDWL(409.3,SDWLDA,"SDAPT")) S SDWLAPP=^("SDAPT") D ;app data + ..S SDWLAPP=SDWLAPP_"~"_$P(SDWLDATA,U,23) + .N SDOP,SDOP1 S SDOP="" I $D(^SDWL(409.3,SDWLDA,1)) S SDOP=^(1),SDOP1=$$GET1^DIQ(409.3,SDWLDA_",",29),$P(SDOP,U)=SDOP1 + .I $D(^SDWL(409.3,SDWLDA,"DIS")) D + ..S SDWLDISX=$G(^SDWL(409.3,SDWLDA,"DIS")),SDWLDIS=$P(SDWLDISX,U,3),SDWLDDUZ=$P(SDWLDISX,U,2) + ..S SDWLDDT=$P(^SDWL(409.3,SDWLDA,"DIS"),U,1) + ..S SDWLDIDT="" I SDWLDDT'="" S SDWLDIDT=$E(SDWLDDT,4,5)_"/"_$E(SDWLDDT,6,7)_"/"_$E(SDWLDDT,2,3) + .I $D(^SDWL(409.3,SDWLDA,"DNR")) D + ..S SDREM=$G(^SDWL(409.3,SDWLDA,"DNR")) S SDREMD=$P(SDWLDATA,U,14),SDREMU=$P(SDWLDATA,U,15) + ..S SDREMDD="" I SDREMD'="" S SDREMDD=$E(SDREMD,4,5)_"/"_$E(SDREMD,6,7)_"/"_$E(SDREMD,2,3) + ..S SDREMR=$$GET1^DIQ(409.3,SDWLDA_",",18),SDREMRC=$$GET1^DIQ(409.3,SDWLDA_",",18.1,"I") + .S SDWLST=$P(SDWLDATA,U,6),SDWLSP=$P(SDWLDATA,U,7),SDWLSS=$P(SDWLDATA,U,8),SDWLSC=$P(SDWLDATA,U,9),SDWLDT=$P(SDWLDATA,U,2) + .S SDWLPROV=$P(SDWLDATA,U,13) I $D(SDWLDRG) D I SDNOK Q + ..S SDNOK=0 + ..I SDWLDTSDWLEDT) S SDNOK=1 Q + .; + .;IF STATUS IS CLOSED DO NOT DISPLAY RECORD + .; + .S SDWLCNT=SDWLCNT+1,^TMP("SDWLI",$J,SDWLCNT)=SDWLDATA_"~"_SDWLDA + .I $D(SDWLDISX) D + ..S ^TMP("SDWLI",$J,SDWLCNT,"DIS")=SDWLDIS_"^"_SDWLDDUZ_"^"_SDWLDIDT + ..I SDWLAPP>0 S ^TMP("SDWLI",$J,SDWLCNT,"SDAPT")=SDWLAPP + ..I SDOP'="" S ^TMP("SDWLI",$J,SDWLCNT,"SDOP")=SDOP + .I $D(SDREM) D + ..S ^TMP("SDWLI",$J,SDWLCNT,"REM")=SDREMR_U_SDREMRC_U_SDREMU_U_SDREMDD + .S ^TMP("SDWLI",$J)=SDWLCNT + .K SDWLDISX,SDREM + Q + ; +DISP ;Display Wait List Data + S (SDWLDT,SDWLCNT,SDWLCN)="",SDWLCT=$G(^TMP("SDWLI",$J)) I 'SDWLCT W !!,"No 'OPEN' Wait List Records to Display.",!! K DIR S DIR(0)="E" D ^DIR S DUOUT="" Q + F S SDWLCNT=$O(^TMP("SDWLI",$J,SDWLCNT)) Q:SDWLCNT="" D I $D(DUOUT) Q + .N SDWLDISX,SDWLR,SDWLCLPT + .I $D(^TMP("SDWLI",$J,SDWLCNT,"DIS")) S SDWLDISX=$G(^TMP("SDWLI",$J,SDWLCNT,"DIS")) + .I $D(^TMP("SDWLI",$J,SDWLCNT,"REM")) S SDWLR=$G(^TMP("SDWLI",$J,SDWLCNT,"REM")) D + ..S SDREMR=$P(SDWLR,U),SDREMRC=$P(SDWLR,U,2),SDREMU=$P(SDWLR,U,3),SDREMDD=$P(SDWLR,U,4) + .S X=$G(^TMP("SDWLI",$J,SDWLCNT)),SDWLDA=$P(X,"~",2),SDWLIN=$P(X,U,3),SDWLCL=$P(X,U,4),SDWLTY=$P(X,U,5),SDWLPRI=$P(X,U,11) + .S SDWLTYP=$S(SDWLTY=1:$P(X,U,6),SDWLTY=2:$P(X,U,7),SDWLTY=3:$P(X,U,8),SDWLTY=4:$P(X,U,9),1:"") + .S SDWLTYN=$S(SDWLTY=1:5,SDWLTY=2:6,SDWLTY=3:7,SDWLTY=4:8,1:0),SDWLCOM=$P($P(X,U,18),"~",1) + .S SDWLDUZ=$P(X,U,10),SDWLPRV=$P(X,U,12),SDWLPROV=$P(X,U,13),SDWLX=$P(X,"~",3) D + ..I $D(SDWLDISX) S SDWLDIS=$P(SDWLDISX,U,1),SDWLDDUZ=$P(SDWLDISX,U,2),SDWLDIDT=$P(SDWLDISX,U,3) + .S SDWLDT=$P(X,U,2),YY=$E(SDWLDT,1,3)+1700,YY=$E(YY,3,4),MM=$E(SDWLDT,4,5),DD=$E(SDWLDT,6,7),SDWLDTP=MM_"/"_DD_"/"_YY + .S SDWLDTD=$P(X,U,16),YY=$E(SDWLDTD,1,3)+1700,YY=$E(YY,3,4),MM=$E(SDWLDTD,4,5),DD=$E(SDWLDTD,6,7),SDWLDTD=MM_"/"_DD_"/"_YY + .;PATCH SD*5.3*394 See Note. + .N SDWLSCP + .S SDWLSCP=+$P($G(^SDWL(409.3,SDWLDA,"SC")),U,2) + .W !,"# ",$J(SDWLCNT,3),! + .W !,"Wait List - ",$$EXTERNAL^DILFD(409.3,4,,SDWLTY),?55,"Date Entered - ",SDWLDTP + .W !,?15 S X=$$EXTERNAL^DILFD(409.3,SDWLTYN,,SDWLTYP) W X + .S SDWLP=0 I SDWLPRI W !,"Priority - ",$$EXTERNAL^DILFD(409.3,10,,SDWLPRI) S SDWLP=1 + .I $D(SDWLSCP) W !,"Service Connected Priority - ",$$EXTERNAL^DILFD(409.3,15,,SDWLSCP) + .W:SDWLP ?15 W:'SDWLP ! W "Institution - ",$$EXTERNAL^DILFD(409.3,2,,SDWLIN) + .W !,"Entered by - " S X=$$EXTERNAL^DILFD(409.3,9,,SDWLDUZ) W X + .S SDWRB=0 I SDWLPRV W !,"Requested By - ",$$EXTERNAL^DILFD(409.3,11,,SDWLPRV),?55,"Date Desired - ",SDWLDTD + .I SDWLPRV=1 W !,"Provider - ",$$EXTERNAL^DILFD(409.3,12,,SDWLPROV) + .I $D(SDWLCOM),SDWLCOM'="" W !,"Comments - ",SDWLCOM + .I $D(^TMP("SDWLI",$J,SDWLCNT,"SDOP")) N SDOP S SDOP=^("SDOP") W !,"Reopen Reason: ",$P(SDOP,U) D + ..I $P(SDOP,U,2)'="" W !,"Reopen comment: ",$P(SDOP,U,2) + .I $D(^TMP("SDWLI",$J,SDWLCNT,"REM")) W !,"Non Removal Reason - ",SDREMR,!,"Non Remove Reason entered by - ",$$GET1^DIQ(200,SDREMU_",",.01,"I") D + ..I $L(SDREMRC)>0 W !,"Non Removal Comment - ",SDREMRC + ..W !,"Non Removal entry date - ",SDREMDD + .I $D(^TMP("SDWLI",$J,SDWLCNT,"DIS")) W !,"Disposition - ",$$EXTERNAL^DILFD(409.3,21,,SDWLDIS),?51,"Disposition Date - ",SDWLDIDT D + ..W !,"Dispositioned by - ",$$EXTERNAL^DILFD(409.3,20,,SDWLDDUZ) + .I $D(^TMP("SDWLI",$J,SDWLCNT,"SDAPT")) N SDAP S SDAP=^("SDAPT") D + ..W !,"Appointment scheduled for " S Y=$P(SDAP,"~",2) D DD^%DT W Y + ..W !?3,"Made on: " S Y=+SDAP D DD^%DT W Y,?30,"For clinic: " N SDC S SDC=$P(SDAP,U,2) S SDC=$$GET1^DIQ(44,SDC_",",.01) W SDC + ..N SDAIN S SDAIN=$P(SDAP,U,3),SDAIN=$$GET1^DIQ(4,SDAIN_",",.01) + ..W !?3,"Appt Institution: ",SDAIN + ..N SDCR S SDCR=$P(SDAP,U,4),SDCR=$$GET1^DIQ(40.7,SDCR_",",.01) + ..W ?40,"Appt Specialty: ",SDCR + ..N SAPS S SAPS=$P(SDAP,U,8),SAPS=$P(SAPS,"~") I SAPS="CC" W !,"Appointment Status: Canceled by Clinic" + .S SDWLCLPT=$$GET1^DIQ(409.3,SDWLDA,37,"I") ; SD*5.3*446 + .D:SDWLCLPT ; SD*5.3*446 + ..W !,"Clinic changed from: ",$$GET1^DIQ(409.3,SDWLCLPT,8) + ..W:SDWLIN'=$$GET1^DIQ(409.3,SDWLCLPT,2,"I") " (",$$GET1^DIQ(409.3,SDWLCLPT,2),")" + ..Q + .; Inter-facility Transfer. SD*5.3*446 + .I $$GETTRN^SDWLIFT1(SDWLDA,.SDWLINNM,.SDWLSTN) D ENS^%ZISS W !,IOINHI,"In transfer to ",SDWLINNM," (",SDWLSTN,")",IOINORM D KILL^%ZISS + .D GETS^DIQ(409.3,SDWLDA,"32;33;34;36;38;39","TMP") + .K SDWLIN,SDWLCL,SDWLTY,SDWLPRI,SDWLDUZ,SDWLPRV,SDWLDT,SDWLDTD,SDWLDIS,SDWLDIDT,SDWLTYN,SDWLCOM,SDWLPROV,SDWLDISX,DIR,DIE,DR,SDWLINNM,SDWLSTN + .W !,"*****",! K DIR S DIR(0)="E" D ^DIR D + ..I X["^" S DUOUT=1 Q + ..I 'Y S DUOUT=1 Q + ..D HD + Q +HD ;Header + W:$D(IOF) @IOF W !!,?80-$L("Wait List - Inquiry")\2,"Wait List - Inquiry ",! + ;SD*5.3*327 - Correct undefined. + I '$D(SDWLDFN) W !! Q + N DFN S DFN=SDWLDFN D DEM^VADPT + W:$D(VADM) !,VADM(1),?40 I $D(VA("PID")) W VA("PID") + W !! + K DUOUT + Q +END ; + K DIR,DIC,DR,DIE,SDWLDFN,DUOUT + K SDNOK,SDWLBDT,SDWLCL,SDWLCN,SDWLCNT,SDWLCOM,SDWLCT,SDWLDA,SDWLDATA,SDWLDDT,SDWLDDUZ,SDWLDFN,SDWLDIDT,SDWLDIS,SDWLDISX + K SDWLDRG,SDWLDT,SDWLDTD,SDWLDTP,SDWLDUZ,SDLWEDT,SDWLIN,SDLWP,SDWLPRI,SDWLPROV,SDLWPRV,SDWLSC,SDWLSP,SDWLSS,SDLWST,SDWLTY + K SDWLTYN,SDSWLTYP,SDLWX,SDWLY,SDWRB,SDWLBDT,SDWLDISC,SDWLERR,SDWLPRON,SDXSCAT,SDWLP,SDWLTYP + Q diff --git a/r/SCHEDULING-SD-SC/SDWLPE.m b/r/SCHEDULING-SD-SC/SDWLPE.m index c09bf4b4..8f35f31e 100644 --- a/r/SCHEDULING-SD-SC/SDWLPE.m +++ b/r/SCHEDULING-SD-SC/SDWLPE.m @@ -1,133 +1,83 @@ -SDWLPE ;IOFO BAY PINES/TEH - WAIT LIST - PARAMETER WAIT LIST ENTER/EDIT ;20 Aug 2002 ; Compiled April 22, 2008 14:13:00 - ;;5.3;scheduling;**263,280,288,397,491**;AUG 13 1993;Build 53 - ; - ;SD/491 - identify clinic institution through DIVISION ---> INSTITUTION path -EN ; - ;OPTION HEADER - ; - D HD - ; - ;SELECT FILE TO EDIT - ; -EN1 D SEL G END:X["^",END:X="" - ; - ;EDIT PARAMETER FILE - ; - D EDIT G EN:'$D(Y) - G END - Q - ; -SEL ;SELECT PARAMETER FILE - S DIR(0)="SO^1:Wait List Service/Specialty File;2:Wait List Clinic Location" - S DIR("L",1)="Select one of the following:" - S DIR("L",2)="" - S DIR("L",3)=" 1. Wait List Service/Specialty (409.31)" - S DIR("L")=" 2. Wait List Clinic Location (409.32)" - D ^DIR S SDWLF=X - K DIR,DILN,DINDEX - Q -EDIT ;EDIT FILE PARAMETERS - I SDWLF=1 D SB1 Q:$D(DUOUT) - I SDWLF=2 D SB2 Q:$D(DUOUT) - Q -SB1 S DIC(0)="AEQMZ",DIC("A")="Select DSS ID: ",DIC="^DIC(40.7,",DIC("S")="I '$P(^DIC(40.7,+Y,0),U,3)" - D ^DIC - I X["^" I $D(DA),'$D(^SDWL(409.31,DA,"I")) S DIK="^SDWL(409.31," D ^DIK S DUOUT=1 Q - Q:Y<0 Q:$D(DUOUT) S SDWLDSS=+Y - I '$D(^SDWL(409.31,"B",SDWLDSS)) D - .S DIC(0)="LX",X=SDWLDSS,DIC="^SDWL(409.31," K DO D FILE^DICN - S DA=$O(^SDWL(409.31,"B",SDWLDSS,"")) -SB1A S DIR(0)="PAO^4:EMZ" D ^DIR - I X="" W *7," Required" G SB1A - I X["^" D:'$D(^SDWL(409.31,DA,"I")) S DUOUT=1 Q - .S DIK="^SDWL(409.31," D ^DIK - S X=$$GET1^DIQ(4,+Y_",",11) - I X'["N"!'$$TF^XUAF4(+Y) W !,*7,"Invalid Entry. Must be 'National' Institution." G SB1A - I '$D(^SDWL(409.31,DA,"I","B",+Y)) D - .S DA(1)=DA,DIC="^SDWL(409.31,"_DA(1)_","_"""I"""_",",DIC("P")=409.311,X=+Y K D0 D FILE^DICN I +Y S DA=+Y - I $D(^SDWL(409.31,DA,"I","B",+Y)) S DA(1)=DA,DA=$O(^(+Y,0)) - K DIC,DIE,DIR,DR - W ! S DR="1;3",DIE="^SDWL(409.31,"_DA(1)_","_"""I"""_"," D ^DIE - I $P(^SDWL(409.31,DA(1),"I",DA,0),U,2)="" D - .W *7,!,"This ENTRY requires an ACTIVATION DATE. ENTRY deleted." - .S DIK="^SDWL(409.31,"_DA(1)_","_"""I"""_"," D ^DIK I '$P(^SDWL(409.31,DA(1),"I",0),U,3) D - ..S DIK="^SDWL(409.31,",DA=DA(1) D ^DIK - K DA,DA(1),SDWLDSS,DIC,DR,DIE,DI,DIEDA,DIG,DIH,DIIENS,DIR,DIU,DIV - Q -SB2 N STR,INST,DIC,SDWLSC,SDWLSTOP S SDWLSTOP=0 - W ! S DIC(0)="AEMNZ",DIC("A")="Select Clinic: ",DIC=44 - S DIC("S")="S SDWLX=$G(^SC(+Y,0)),SDWLY=$G(^(""I"")) I $P(SDWLX,U,3)=""C"",$P(SDWLY,U,1)'>$P(SDWLY,U,2)" - S DIC("W")="S STR=$$CLIN^SDWLPE(+Y) I STR W ?50,""- "",$E($P(STR,U,3),1,25),""("",$P(STR,U,2),"")""" - D ^DIC I Y<1 K DIC,DA Q - Q:$D(DUOUT) S SDWLSC=+Y S INST=+STR ;$$CLIN(SDWLSC) - I $P(STR,U,6)'="" W !,*7,$P(STR,U,6) G SB2 - N SDANEW S SDANEW="" - I '$D(^SDWL(409.32,"B",SDWLSC)) D - .S DIC(0)="LX",X=SDWLSC,DIC="^SDWL(409.32," D FILE^DICN - .N DA S DA=$O(^SDWL(409.32,"B",SDWLSC,"")) S SDANEW=DA - .S DIE="^SDWL(409.32,",DR=".02////^S X=INST" D ^DIE - N DA,SDA S DA=$O(^SDWL(409.32,"B",SDWLSC,"")),SDA=DA - S DR="1",DIE="^SDWL(409.32," D ^DIE - I SDANEW,'X D D ESB2 H 1 G SB2 - .W *7,!!,"This ENTRY requires an ACTIVATION DATE. ENTRY deleted." - .S DA=SDANEW S DIK="^SDWL(409.32," D ^DIK - I X S DR="2////^S X=DUZ" D ^DIE - N DIC - S SDWLSCN=$P($G(^SDWL(409.32,SDA,0)),U,1) D Q:SDWLSTOP - .I $D(^SDWL(409.3,"SC",SDWLSCN)) D - ..S SDWLN="",SDWLCNT=0 F S SDWLN=$O(^SDWL(409.3,"SC",SDWLSCN,SDWLN)) Q:SDWLN="" D - ...S X=$G(^SDWL(409.3,SDWLN,0)) I '$D(^SDWL(409.3,SDWLN,"DIS")) S SDWLCNT=SDWLCNT+1,^TMP("SDWLPE",$J,"DIS",SDWLN,SDWLCNT)=X,SDWLSTOP=1 - ..I SDWLSTOP W !,"This Clinic has Patients on the Wait List and can not be inactivated." H 2 Q - .S DR="4////^S X=DUZ" D ^DIE - S DR="3",DIE="^SDWL(409.32," D ^DIE -ESB2 ; - K DR,DIE,DIC,Y,X,SDWLY,DIC(0),DO,DA,DI,DIW,SDWLX,SDWLSCN,SDWLF - Q -SWT ;SWITCH FOR INACTIVATION OF PARAMETER FILE - Q -HD ;HEADER - W:$D(IOF) @IOF W !!,?80-$L("Wait List Parameter Enter/Edit")\2,"Wait List Parameter Enter/Edit",! - W !,?80-$L("------------------------------")\2,"------------------------------",! -END K SDWLSTOP,DIR,DIC,DR,DIK,SDWLX,SDWLSCN,SDWLF,SDWLY,SDWLSC,SDWLN,SDWLCNT,SDWLDSS,DUOUT,X,Y - Q -CLIN(CL) ;identify clinic institution through DIVISON ----> INSTITUTION path. - ; function to return: - ; 1 2 3 4 5 6 7 - ; - Institution pointer to ^DIC(4 _U_ STATION number (# 99) _U_ INST Name _U_ DIV Pointer to ^DG(40.8 _U_N/L_U_Message_U_TYPE - ; ( INST^STA NUM^SNAM^DIV^N/L^MESS^TYPE ) - ; N/L - N -National/L -Local - ; TYPE - type of entry in file # 44 (field #2) - ; C:CLINIC - ; M:MODULE - ; W:WARD - ; Z:OTHER LOCATION - ; N:NON-CLINIC STOP - ; F:FILE AREA - ; I:IMAGING - ; OR:OPERATING ROOM - ; - ; with optional Message: - ; - ; if STA="" - ; - INST^^SNAM^DIV^N/L^' - No Station Number on file' ^ TYPE - ; or - ; - 0^^^DIV^^' - No Institution has been identified '^ TYPE - ; - 0^^^-1^^' - No Division has been identified' ^ TYPE - ; - ; if entry is inactivated: - ; - ; - INST^^SNAM^DIV^N/L^' - Inactive treating medical facility' ^ TYPE - ; - -1^^^^^' - No clinic on file' ^ - ; - I +CL=0!'$D(^SC(+CL)) Q -1_"^^^^^ - No clinic on file^" - N SDWMES,STN,DIV,INS,SNL,STR,SNAM S SDWMES="",STN="" - N TYPE S TYPE=$$GET1^DIQ(44,CL_",",2,"E") - S DIV=+$$GET1^DIQ(44,CL_",",3.5,"I") - I DIV=0 S SDWMES=" - No Division has been identified" Q 0_"^^^"_-1_"^^"_SDWMES_U_TYPE - S INS=+$$GET1^DIQ(40.8,DIV_",",.07,"I") - I INS=0 S SDWMES=" - No Institution has been identified" Q 0_"^^^"_DIV_"^^"_SDWMES_U_TYPE - E S STR=$$NS^XUAF4(INS),STN=$P(STR,U,2),SNAM=$P(STR,U) ;station number and name - I STN="" S SDWMES=" - No Station Number on file" - I '$$TF^XUAF4(INS) S SDWMES=SDWMES_" - Inactive treating medical facility" - S SNL=$$GET1^DIQ(4,INS_",",11,"I") - Q INS_U_STN_U_SNAM_U_DIV_U_SNL_U_SDWMES_U_TYPE +SDWLPE ;IOFO BAY PINES/TEH - WAIT LIST - PARAMETER WAIT LIST ENTER/EDIT ;20 Aug 2002 + ;;5.3;scheduling;**263,280,288,397**;AUG 13 1993 + ; + ; +EN ; + ;OPTION HEADER + ; + D HD + ; + ;SELECT FILE TO EDIT + ; +EN1 D SEL G END:X["^",END:X="" + ; + ;EDIT PARAMETER FILE + ; + D EDIT G EN:'$D(Y) + G END + Q + ; +SEL ;SELECT PARAMETER FILE + S DIR(0)="SO^1:Wait List Service/Specialty File;2:Wait List Clinic Location" + S DIR("L",1)="Select one of the following:" + S DIR("L",2)="" + S DIR("L",3)=" 1. Wait List Service/Specialty (409.31)" + S DIR("L")=" 2. Wait List Clinic Location (409.32)" + D ^DIR S SDWLF=X + K DIR,DILN,DINDEX + Q +EDIT ;EDIT FILE PARAMETERS + I SDWLF=1 D SB1 Q:$D(DUOUT) + I SDWLF=2 D SB2 Q:$D(DUOUT) + Q +SB1 S DIC(0)="AEQMZ",DIC("A")="Select DSS ID: ",DIC="^DIC(40.7,",DIC("S")="I '$P(^DIC(40.7,+Y,0),U,3)" + D ^DIC + I X["^" I $D(DA),'$D(^SDWL(409.31,DA,"I")) S DIK="^SDWL(409.31," D ^DIK S DUOUT=1 Q + Q:Y<0 Q:$D(DUOUT) S SDWLDSS=+Y + I '$D(^SDWL(409.31,"B",SDWLDSS)) D + .S DIC(0)="LX",X=SDWLDSS,DIC="^SDWL(409.31," K DO D FILE^DICN + S DA=$O(^SDWL(409.31,"B",SDWLDSS,"")) +SB1A S DIR(0)="PAO^4:EMZ" D ^DIR + I X="" W *7," Required" G SB1A + I X["^" D:'$D(^SDWL(409.31,DA,"I")) S DUOUT=1 Q + .S DIK="^SDWL(409.31," D ^DIK + S X=$$GET1^DIQ(4,+Y_",",11) + I X'["N"!'$$TF^XUAF4(+Y) W !,*7,"Invalid Entry. Must be 'National' Institution." G SB1A + I '$D(^SDWL(409.31,DA,"I","B",+Y)) D + .S DA(1)=DA,DIC="^SDWL(409.31,"_DA(1)_","_"""I"""_",",DIC("P")=409.311,X=+Y K D0 D FILE^DICN I +Y S DA=+Y + I $D(^SDWL(409.31,DA,"I","B",+Y)) S DA(1)=DA,DA=$O(^(+Y,0)) + K DIC,DIE,DIR,DR + W ! S DR="1;3",DIE="^SDWL(409.31,"_DA(1)_","_"""I"""_"," D ^DIE + I $P(^SDWL(409.31,DA(1),"I",DA,0),U,2)="" D + .W *7," This ENTRY requires an ACTIVATION DATE. ENTRY deleted." + .S DIK="^SDWL(409.31,"_DA(1)_","_"""I"""_"," D ^DIK I '$P(^SDWL(409.31,DA(1),"I",0),U,3) D + ..S DIK="^SDWL(409.31,",DA=DA(1) D ^DIK + K DA,DA(1),SDWLDSS,DIC,DR,DIE,DI,DIEDA,DIG,DIH,DIIENS,DIR,DIU,DIV + Q +SB2 S SDWLSTOP=0 + W ! S DIC(0)="AEQMNZ",DIC("A")="Select Clinic: ",DIC=44 + S DIC("S")="S SDWLX=$G(^SC(+Y,0)),SDWLY=$G(^(""I"")) I $P(SDWLX,U,3)=""C"",$P(SDWLY,U,1)'>$P(SDWLY,U,2) I $P(^SC(+Y,0),U,4)" + S DIC("W")="I $P(^SC(+Y,0),U,4) W ?50,""- "",$E($P(^DIC(4,$P(^SC(+Y,0),U,4),0),U,1),1,25)" + D ^DIC Q:Y<1 Q:$D(DUOUT) S SDWLSC=+Y + S INST=$$GET1^DIQ(44,+Y,3,"I") + S X=$$GET1^DIQ(4,+INST_",",11) I X'["N"!'$$TF^XUAF4(+INST) W !,*7,"Invalid Entry. Must be 'National' Institution." G SB2 + I '$D(^SDWL(409.32,"B",SDWLSC)) D + .S DIC(0)="LX",X=SDWLSC,DIC="^SDWL(409.32," D FILE^DICN + S DA=$O(^SDWL(409.32,"B",SDWLSC,"")) + K DIC,DIC(0) + S SDWLSCN=$P($G(^SDWL(409.32,DA,0)),U,1) D + .I $D(^SDWL(409.3,"C",SDWLSCN)) D + ..S SDWLN="",SDWLCNT=0 F S SDWLN=$O(^SDWL(409.3,"C",SDWLSCN,SDWLN)) Q:SDWLN="" D + ...S X=$G(^SDWL(409.3,SDWLN,0)) I '$D(^SDWL(409.3,SDWLN,"DIS")) S SDWLCNT=SDWLCNT+1,^TMP("SDWLPE",$J,"DIS",SDWLN,SDWLCNT)=X,SDWLSTOP=1 + W ! I SDWLSTOP W "This Clinic has Patients on the Wait List and can not be inactivated." Q + S DR="1",DIE="^SDWL(409.32," D ^DIE I X S DR="2////^S X=DUZ" D ^DIE + S DR="3",DIE="^SDWL(409.32," D ^DIE I X S DR="4////^S X=DUZ" D ^DIE + K DR,DIE,DIC,Y,X,SDWLY,DIC(0),DO,DA,DI,DIW,SDWLX,SDWLSCN,SDWLF + Q +SWT ;SWITCH FOR INACTIVIATION OF PARAMETER FILE + Q +HD ;HEADER + W:$D(IOF) @IOF W !!,?80-$L("Wait List Parameter Enter/Edit")\2,"Wait List Parameter Enter/Edit",! + W !,?80-$L("------------------------------")\2,"------------------------------",! +END K SDWLSTOP,DIR,DIC,DR,DIK,SDWLX,SDWLSCN,SDWLF,SDWLY,SDWLSC,SDWLN,SDWLCNT,SDWLDSS,DUOUT,X,Y + Q diff --git a/r/SCHEDULING-SD-SC/SDWLQSR.m b/r/SCHEDULING-SD-SC/SDWLQSR.m index 7f87a55f..471629c9 100644 --- a/r/SCHEDULING-SD-SC/SDWLQSR.m +++ b/r/SCHEDULING-SD-SC/SDWLQSR.m @@ -1,67 +1,53 @@ -SDWLQSR ;BPOI/TEH - WAIT LIST STAT REPORT;06/12/02 - ;;5.3;scheduling;**263,425,448,524**;08/13/93;Build 29 - ; - ; - ; - ; - ; -EN N ZCODE,ZTDESC,ZTDTH,ZTIO,ZTQUEDED,ZTREQ,ZTRTN,ZTSAVE,ZTSK,POP - K ^TMP("SDWLQSR",$J) - D HD -1 D INS G END:$D(DUOUT) -2 D DATE G END:$D(DUOUT) -3 D EXCL G END:$D(DUOUT) - D QUE G END:$D(DUOUT) - Q -INS ;Get Institution - S SDWLERR=0,SDWLPROM="Select Institution ALL // ",SDWLINST="" -IN W ! S DIC(0)="QEMA",DIC("A")=SDWLPROM,DIC=4,DIC("S")="I $D(^SDWL(409.32,""C"",+Y))!$D(^SDWL(409.31,""E"",+Y))!$D(^SCTM(404.51,""AINST"",+Y))" D ^DIC I Y<0,'SDWLERR Q:$D(DUOUT) S Y="ALL" - G IN2:Y<0 Q:$D(DUOUT) - I Y<0 S SDWLINST=$S(Y="ALL":"ALL",Y="":"ALL",Y="all":"ALL",Y="All":"ALL",Y["A":"ALL",Y["a":"ALL") - I Y="All"!(Y="")!(Y="all")!(Y="ALL") S SDWLINST="ALL",^TMP("SDWLQSR",$J,"INS")="ALL" G IN3 - S SDWLINST=SDWLINST_Y_";",SDWLPROM="Another Institution: ",SDWLERR=1 G IN -IN2 S ^TMP("SDWLQSR",$J,"INS")=SDWLINST -IN3 Q -DATE ;Date range selection - K X,Y,%DT - S SDWLERR=0 W ! S %DT="AE",%DT("A")="Start Date: " D ^%DT - I X["^" S DUOUT=1 Q - I Y<0 S DUOUT=1 Q - S SDWLBDT=Y - Q:$D(DUOUT) - S %DT("A")="End Date: " D ^%DT G DATE:Y<1 S SDWLEDT=Y K %DT(0),%DT("A") - G DATE:$D(DUOUT) - I SDWLEDT(IOSL-5) D:$D(SDWLSPT) SCR Q:POP D HD,HD1 ;SD*5.3*412 added Quit for early exit - .I $$S^%ZTLOAD S DUOUT="" Q - .W !!,"INSTITUTION: ",SDWLINS,! K ^XTMP("SDWLRSR") - .S SDWLTY="" F S SDWLTY=$O(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY)) Q:SDWLTY="" D Q:POP ;SD*5.3*412 added Quit for early exit - ..S SDWLTNM=$$EXTERNAL^DILFD(409.3,4,,SDWLTY) - ..S SDWLSCN="" F S SDWLSCN=$O(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN)) Q:SDWLSCN="" D Q:POP ;SD*5.3*412 added Quit for early exit - ...S (T1,T2,T3,T4,T5,T6,T7,T8,T9,T10,T11,T12)=0 ;SD*5.3*415 - ...S SDWLSCNM="" F S SDWLSCNM=$O(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM)) Q:SDWLSCNM="" D Q:POP D T1 Q:POP ;SD*5.3*412 added Quit - ....S SDWLPRI="" F S SDWLPRI=$O(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI)) Q:SDWLPRI="" D Q:POP ;SD*5.3*412 added Quit - .....S SDWLFLG=0 - .....S SDWLPR=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"PR")) I SDWLEXCL,SDWLPR S SDWLFLG=1 - .....S SDWLCL=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"CL")) I 'SDWLFLG,SDWLEXCL,SDWLCL S SDWLFLG=1 - .....S SDWLD=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLD")) I 'SDWLFLG,SDWLEXCL,SDWLD S SDWLFLG=1 ;SD*5.3*415 - .....S SDWLNC=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLNC")) I 'SDWLFLG,SDWLEXCL,SDWLNC S SDWLFLG=1 ;SD*5.3*415 - .....S SDWLSA=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLSA")) I 'SDWLFLG,SDWLEXCL,SDWLSA S SDWLFLG=1 ;SD*5.3*415 - .....S SDWLCC=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLCC")) I 'SDWLFLG,SDWLEXCL,SDWLCC S SDWLFLG=1 ;SD*5.3*415 - .....S SDWLNN=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLNN")) I 'SDWLFLG,SDWLEXCL,SDWLNN S SDWLFLG=1 ;SD*5.3*415 - .....S SDWLER=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLER")) I 'SDWLFLG,SDWLEXCL,SDWLER S SDWLFLG=1 ;SD*5.3*415 - .....S SDWLTR=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLTR")) I 'SDWLFLG,SDWLEXCL,SDWLTR S SDWLFLG=1 ;SD*5.3*415 - .....S SDWLAD=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"AD")) I 'SDWLFLG,SDWLEXCL,SDWLAD S SDWLFLG=1 ;SD*5.3*415 - .....S SDWLRR=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"RR")) I 'SDWLFLG,SDWLEXCL,SDWLRR S SDWLFLG=1 ;SD*5.3*415 - .....S SDWLNR=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"NR")) I 'SDWLFLG,SDWLEXCL,SDWLNR S SDWLFLG=1 ;W ?72,$J(SDWLNR,3) - .....I 'SDWLEXCL,'SDWLFLG S SDWLFG=1 - .....I SDWLEXCL,'SDWLFLG Q - .....I '$D(^XTMP("SDWLRSR",$J,SDWLTNM)) W !,$E(SDWLTNM,1,15) S ^XTMP("SDWLRSR",$J,SDWLTNM)="" - .....W !?2,$E(SDWLSCNM_" "_$S(SDWLPRI="A":"ASAP",SDWLPRI="F":"FUTURE",1:""),1,17) - .....S T1=T1+SDWLPR,TT1=TT1+SDWLPR W ?21,$J(SDWLPR,3) - .....S T2=T2+SDWLCL,TT2=TT2+SDWLCL W ?26,$J(SDWLCL,3) - .....S T3=T3+SDWLD,TT3=TT3+SDWLD W ?31,$J(SDWLD,3) - .....S T4=T4+SDWLNC,TT4=TT4+SDWLNC W ?36,$J(SDWLNC,3) - .....S T5=T5+SDWLSA,TT5=TT5+SDWLSA W ?41,$J(SDWLSA,3) - .....S T6=T6+SDWLCC,TT6=TT6+SDWLCC W ?46,$J(SDWLCC,3) - .....S T7=T7+SDWLNN,TT7=TT7+SDWLNN W ?51,$J(SDWLNN,3) - .....S T8=T8+SDWLER,TT8=TT8+SDWLER W ?56,$J(SDWLER,3) - .....S T9=T9+SDWLTR,TT9=TT9+SDWLTR W ?61,$J(SDWLTR,3) ;SD*5.3*415 - .....S T10=T10+SDWLAD,TT10=TT10+SDWLAD W ?66,$J(SDWLAD,3) ;SD*5.3*415 - .....S T11=T11+SDWLRR,TT11=TT11+SDWLRR W ?71,$J(SDWLRR,3) ;SD*5.3*415 - .....S T12=T12+SDWLNR,TT12=TT12+SDWLNR W ?76,$J(SDWLNR,3) ;SD*5.3*415 - .....I $Y>(IOSL-5) D:$D(SDWLSPT) SCR Q:POP D HD,HD1 ;SD*5.3*412 - Q -SCR S DIR(0)="E" D ^DIR S:X="^" POP=1 ;SD*5.3*412 - Q -T1 ; - I 'SDWLFLG,SDWLEXCL Q - W !?20,"---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ----" ;SD*5.3*415 - W !,"Sub-Totals:" - ;write sub-totals - W ?21,$J(T1,3),?26,$J(T2,3),?31,$J(T3,3),?36,$J(T4,3),?41,$J(T5,3),?46,$J(T6,3),?51,$J(T7,3),?56,$J(T8,3),?61,$J(T9,3),?66,$J(T10,3),?71,$J(T11,3),?76,$J(T12,3),! ;SD*5.3*415 - S (T1,T2,T3,T4,T5,T6,T7,T8,T9,T10,T11,T12)=0 ;SD*5.3*415 - I $Y>(IOSL-5) D:$D(SDWLSPT) SCR Q:POP D HD,HD1 ;SD*5.3*412 - Q -T2 W !,"Institution Totals:" - W ?21,$J(TT1,3),?26,$J(TT2,3),?31,$J(TT3,3),?36,$J(TT4,3),?41,$J(TT5,3),?46,$J(TT6,3),?51,$J(TT7,3),?56,$J(TT8,3),?61,$J(TT9,3),?66,$J(TT10,3),?71,$J(TT11,3),?76,$J(TT12,3),! ;SD*5.3*415 - S (TT1,TT2,TT3,TT4,TT5,TT6,TT7,TT8,TT9,TT10,TT11,TT12)=0 ;SD*5.3*415 - I $Y>(IOSL-5) D:$D(SDWLSPT) SCR Q:POP D HD,HD1 ;SD*5.3*412 - Q -HD W:$D(IOF) @IOF S SDWLPG=SDWLPG+1 W !!,SDWLDTP,?80-$L("Wait List (Sch/PCMM) Stat Report")\2,"Wait List (Sch/PCMM) Stat Report",?65,"Page: ",SDWLPG - W !,?80-$L("STARTED Date: ")\2,"STARTED Date: " S Y=$P(SDWLDATE,U,1) D DD^%DT W Y - W !,?80-$L("FINISHED Date: ")\2,"FINISHED Date: " S Y=$P(SDWLDATE,U,2) D DD^%DT W Y - Q -HD1 ; - W !,?20,"PREV" - W ?65,"#" - W ?75,"# NOT" - W !,"WAIT LIST TYPE" - W ?20,"REMN",?25,"CLSD",?31,"DTH",?37,"NC",?42,"SA",?47,"CC",?52,"NN",?57,"ER",?61,"TR",?65,"ADD",?70,"REMN",?75,"REMVD",! ;SD*5.3*415 - Q -END D EN^SDWLKIL - K ^TMP("SDWLRSR1",$J),^TMP("SDWLRSR2",$J),SDWLY1,SDWLX1,SDWLRDT,CT,I - K T1,T2,T3,T4,T5,T6,T7,T8,T9,T10,T11,T12,SDWLAD,SDWLBD,SDWLCC,SDWLCT,SDWLDFDT,SDWLDP,SDWLED,SDWLER,SDWLERR,SDWLFLD,X1,X2,DATE ;SD*5.3*415 - K TT1,TT2,TT3,TT4,TT5,TT6,TT7,TT8,TT9,TT10,TT11,TT12,SDWLINSN,SDWLINST,SDWLNC,SDWLNN,SDWLNR,SDWLOFDT,SDWLOK1,SDWLOK2,SDWLTYPN ;SD*5.3*415 - K SDWLOK3,SDWLPR,SDWLPR,SDWLPROM,SDWLRE,SDWLRFDT,SDWLRR,SDWLSA,SDWLSCN,SDWLSCNM,SDWLTASK,SDWLTK,SDWLTNM,SDWLTYNM,SDWLTYP,X4,SDWLTR ;SD*5.3*415 - Q +SDWLRSR ;;IOFO BAY PINES/TEH/WAIT LIST STAT REPORT ; 01 Oct 2002 4:42 PM ; Compiled December 21, 2006 15:32:50 + ;;5.3;scheduling;**263,273,399,412,425,415,446**;AUG 13 1993;Build 77 + ; + ; Removed Sort logic as routine exceeded SACC maximum size of 10000 + ; New routine SDWLRSRS was created to perform the Sort functionality + ; + ; +EN ; + D INIT G END:$D(DUOUT) ;SD*5.3*415 + D SORT^SDWLRSRS(SDWLBD,SDWLED,SDWLINS,.SDWL) ; SD*5.3*415 new routine to perform sort + D:'$$S^%ZTLOAD PRT ;SD*5.3*415 + G END +INIT ; + I $D(CT) S SDWLCT2=CT + I $D(DATE) S SDWLDATE=DATE + I $D(INS) S SDWLINS=INS + I $D(ZTSAVE) D + .S SDWLCT=$G(ZTSAVE("CT")),SDWLDATE=$G(ZTSAVE("DATE")),SDWLINS=$G(ZTSAVE("INS")) + I SDWLINS'="ALL" F I=1:1 S SDWL=$P(SDWLINS,";",I) Q:SDWL="" S SDWL("INS",+SDWL)="" + S SDWLBD=$P(SDWLDATE,U,1),SDWLED=$P(SDWLDATE,U,2),SDWLPG=0 + D NOW^%DTC S Y=% D DD^%DT S SDWLDTP=Y + N POP S POP=0 ;SD*5.3*412 + Q +PRT ;PRINT REPORT + S (T1,T2,T3,T4,T5,T6,T7,T8,T9,T10,T11,T12,T13)=0 ;SD*5.3*446 + S (TT1,TT2,TT3,TT4,TT5,TT6,TT7,TT8,TT9,TT10,TT11,TT12,TT13,SDWLPG)=0 D HD,HD1 ;SD*5.3*415,446 + I '$D(^TMP("SDWLRSR1")) W !!,"No Wait List Data to Report" Q + S SDWLINS="" F S SDWLINS=$O(^TMP("SDWLRSR1",$J,SDWLINS)) Q:SDWLINS="" D Q:POP D T2 Q:POP W !,"________________" I $Y>(IOSL-8) D:$D(SDWLSPT) SCR Q:POP D HD,HD1 ;SD*5.3*412 added Quit for early exit; 446 + .I $$S^%ZTLOAD S DUOUT="" Q + .W !!,"INSTITUTION: ",SDWLINS,! + .S SDWLTY="" F S SDWLTY=$O(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY)) Q:SDWLTY="" D Q:POP ;SD*5.3*412 added Quit for early exit + ..S SDWLTNM=$$EXTERNAL^DILFD(409.3,4,,SDWLTY) W !,$E(SDWLTNM,1,15) + ..S SDWLSCN="" F S SDWLSCN=$O(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN)) Q:SDWLSCN="" D Q:POP ;SD*5.3*412 added Quit for early exit + ...S SDWLSCNM="" F S SDWLSCNM=$O(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM)) Q:SDWLSCNM="" D Q:POP D T1 Q:POP ;SD*5.3*412 added Quit + ....S SDWLPRI="" F S SDWLPRI=$O(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI)) Q:SDWLPRI="" D Q:POP ;SD*5.3*412 added Quit + .....N SDWLCLO ; SD*5.3*446 + .....W !,?2,$E(SDWLSCNM,1,10)," ",$S(SDWLPRI="A":"ASAP",SDWLPRI="F":"FUTURE",1:"") + .....S SDWLPR=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"PR")) W ?20,SDWLPR + .....S SDWLCLO=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"CL")) W ?27,SDWLCLO ;SD*5.3*446 + .....S SDWLD=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLD")) W ?34,SDWLD ;SD*5.3*415,446 + .....S SDWLNC=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLNC")) W ?41,SDWLNC ;SD*5.3*415,446 + .....S SDWLSA=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLSA")) W ?48,SDWLSA ;SD*5.3*415,446 + .....S SDWLCC=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLCC")) W ?55,SDWLCC ;SD*5.3*415,446 + .....S SDWLNN=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLNN")) W ?62,SDWLNN ;SD*5.3*415,446 + .....S SDWLER=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLER")) W ?69,SDWLER ;SD*5.3*415,446 + .....S SDWLCL=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLCL")) W ?76,SDWLCL ;SD*5.3*415,446 + .....S SDWLTR=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLTR")) W ?83,SDWLTR ;SD*5.3*415,446 + .....S SDWLAD=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"AD")) W ?90,SDWLAD ;SD*5.3*415,446 + .....S SDWLRR=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"RR")) W ?97,SDWLRR ;SD*5.3*415,446 + .....S SDWLNR=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"NR")) W ?104,SDWLNR ;SD*5.3*446 + .....S T1=T1+SDWLPR,TT1=TT1+SDWLPR + .....S T2=T2+SDWLCLO,TT2=TT2+SDWLCLO ;SD*5.3*446 + .....S T3=T3+SDWLD,TT3=TT3+SDWLD + .....S T4=T4+SDWLNC,TT4=TT4+SDWLNC + .....S T5=T5+SDWLSA,TT5=TT5+SDWLSA + .....S T6=T6+SDWLCC,TT6=TT6+SDWLCC + .....S T7=T7+SDWLNN,TT7=TT7+SDWLNN + .....S T8=T8+SDWLER,TT8=TT8+SDWLER + .....S T9=T9+SDWLCL,TT9=TT9+SDWLCL ;SD*5.3*446 + .....S T10=T10+SDWLTR,TT10=TT10+SDWLTR ;SD*5.3*446 + .....S T11=T11+SDWLAD,TT11=TT11+SDWLAD ;SD*5.3*446 + .....S T12=T12+SDWLRR,TT12=TT12+SDWLRR ;SD*5.3*446 + .....S T13=T13+SDWLNR,TT13=TT13+SDWLNR ;SD*5.3*446 + .....I $Y>(IOSL-8) D:$D(SDWLSPT) SCR Q:POP D HD,HD1 ;SD*5.3*412,446 + Q +SCR S DIR(0)="E" D ^DIR S:X="^" POP=1 ;SD*5.3*412 + Q +T1 ; + ;write sub-totals + W !?20,"------ ------ ------ ------ ------ ------ ------ ------ ------ ------ ------ ------ ------" ;SD*5.3*446 + W !,"Sub-Totals:",?20,T1,?27,T2,?34,T3,?41,T4,?48,T5,?55,T6,?62,T7,?69,T8,?76,T9,?83,T10,?90,T11,?97,T12,?104,T13 ;SD*5.3*446 + S (T1,T2,T3,T4,T5,T6,T7,T8,T9,T10,T11,T12,T13)=0 ;SD*5.3*415,446 + I $Y>(IOSL-8) D:$D(SDWLSPT) SCR Q:POP D HD,HD1 ;SD*5.3*412,446 + Q +T2 W !,"Institution Totals:" + W ?20,TT1,?27,TT2,?34,TT3,?41,TT4,?48,TT5,?55,TT6,?62,TT7,?69,TT8,?76,TT9,?83,TT10,?90,TT11,?97,TT12,?104,TT13,! ;SD*5.3*446 + S (TT1,TT2,TT3,TT4,TT5,TT6,TT7,TT8,TT9,TT10,TT11,TT12,TT13)=0 ;SD*5.3*415,446 + I $Y>(IOSL-8) D:$D(SDWLSPT) SCR Q:POP D HD,HD1 ;SD*5.3*412,446 + Q +HD W:$D(IOF) @IOF S SDWLPG=SDWLPG+1 W !!,SDWLDTP,?80-$L("Wait List (Sch/PCMM) Stat Report")\2,"Wait List (Sch/PCMM) Stat Report",?65,"Page: ",SDWLPG + W !,?80-$L("STARTED Date: ")\2,"STARTED Date: " S Y=$P(SDWLDATE,U,1) D DD^%DT W Y + W !,?80-$L("FINISHED Date: ")\2,"FINISHED Date: " S Y=$P(SDWLDATE,U,2) D DD^%DT W Y + Q +HD1 ; + W !,?20,"PREV",?90,"#",?97,"#",?104,"# NOT" ;SD*5.3*415,446 + W !,"WAIT LIST TYPE",?20,"REMN",?27,"CLSD",?34,"DTH",?41,"NC",?48,"SA",?55,"CC",?62,"NN",?69,"ER",?76,"CL",?83,"TR",?90,"ADD",?97,"REMN",?104,"REMVD" ;SD*5.3*446 + Q +END D EN^SDWLKIL + K ^TMP("SDWLRSR1",$J),^TMP("SDWLRSR2",$J),SDWLY1,SDWLX1,SDWLRDT,CT,I + K T1,T2,T3,T4,T5,T6,T7,T8,T9,T10,T11,T12,T13,SDWLAD,SDWLBD,SDWLCC,SDWLCT,SDWLDFDT,SDWLDP,SDWLED,SDWLER,SDWLERR,SDWLFLD,X1,X2,DATE ;SD*5.3*415,446 + K TT1,TT2,TT3,TT4,TT5,TT6,TT7,TT8,TT9,TT10,TT11,TT12,TT13,SDWLINSN,SDWLINST,SDWLNC,SDWLNN,SDWLNR,SDWLOFDT,SDWLOK1,SDWLOK2,SDWLTYPN ;SD*5.3*415,446 + K SDWLOK3,SDWLPR,SDWLPR,SDWLPROM,SDWLRE,SDWLRFDT,SDWLRR,SDWLSA,SDWLSCN,SDWLSCNM,SDWLTASK,SDWLTK,SDWLTNM,SDWLTYNM,SDWLTYP,X4,SDWLTR,SDWLCL ;SD*5.3*415,446 + Q diff --git a/r/SURGERY-SR/SROABCH.m b/r/SURGERY-SR/SROABCH.m index 3ca64480..3ddb3908 100644 --- a/r/SURGERY-SR/SROABCH.m +++ b/r/SURGERY-SR/SROABCH.m @@ -1,28 +1,20 @@ -SROABCH ;BIR/MAM - BATCH PRINT ASSESSMENTS ;11/28/07 - ;;3.0; Surgery ;**77,166**;24 Jun 93;Build 7 -DATE ; get dates - S (SRSOUT,SRSP)=0 W @IOF,!!,"This report will print all completed or transmitted assessments that have a",!,"date of operation within the date range selected.",! - D DATE^SROUTL(.SRASTDT,.SRAENDT,.SRSOUT) G:SRSOUT END - D SPEC - W !!,"Depending on the date range entered, this report may be very long. You should",!,"QUEUE this report to the selected printer.",! - K %ZIS,IOP,POP,IO("Q") S %ZIS="Q",%ZIS("A")="Print on which Device: " D ^%ZIS S:POP SRSOUT=1 G:POP END - I $D(IO("Q")) K IO("Q") S ZTRTN="EN^SROABCH",(ZTSAVE("SRSITE*"),ZTSAVE("SRASTDT"),ZTSAVE("SRAENDT"),ZTSAVE("SRSP"))="",ZTDESC="Batch Print Risk Assessments" D ^%ZTLOAD S SRSOUT=1 G END -EN ; entry when queued - S SRSOUT=0,SRABATCH=1 - U IO S SRAENDT=SRAENDT+.9999,SDATE=SRASTDT-.0001 F S SDATE=$O(^SRF("AC",SDATE)) Q:'SDATE!(SDATE>SRAENDT)!SRSOUT S SRTN=0 F S SRTN=$O(^SRF("AC",SDATE,SRTN)) Q:'SRTN!SRSOUT D STUFF -END I $D(ZTQUEUED) Q:$G(ZTSTOP) S ZTREQ="@" Q - D ^%ZISC K SRTN W @IOF D ^SRSKILL - Q -STUFF ; - I SRSP,$P(^SRF(SRTN,0),"^",4)'=SRSP Q - S DATE=$P(^SRF(SRTN,0),"^",9) - S SR("RA")=$G(^SRF(SRTN,"RA")),X=$P(SR("RA"),"^") I X'="T",X'="C" Q - I $P(SR("RA"),"^",6)'="Y" Q - K SRA D ^SROAPAS - Q -SPEC ; select specialty - W ! K DIR S DIR(0)="YA",DIR("A")="Print report for ALL surgical specialties ? ",DIR("B")="YES" - S DIR("?",1)="Enter YES to print the report for all surgical specialties, or NO to",DIR("?")="print the report for a specific surgical specialty." - D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q - I 'Y W ! K DIC S DIC("S")="I '$P(^(0),""^"",3)",DIC("A")="Print the Report for which Surgical Specialty: ",DIC=137.45,DIC(0)="QEAMZ" D ^DIC K DIC S:Y<0 SRSOUT=1 Q:Y<0 S SRSP=+Y - Q +SROABCH ;B'HAM ISC/MAM - BATCH PRINT ASSESSMENTS ; [ 01/08/98 9:54 AM ] + ;;3.0; Surgery ;**77**;24 Jun 93 +DATE ; get dates + S SRSOUT=0 W @IOF,!!,"This report will print all completed or transmitted assessments that have a",!,"'date completed' within the date range selected.",! + D DATE^SROUTL(.SRASTDT,.SRAENDT,.SRSOUT) G:SRSOUT END + W !!,"Depending on the date range entered, this report may be very long. You should",!,"QUEUE this report to the selected printer.",! + K %ZIS,IOP,POP,IO("Q") S %ZIS="Q",%ZIS("A")="Print on which Device: " D ^%ZIS S:POP SRSOUT=1 G:POP END + I $D(IO("Q")) K IO("Q") S ZTRTN="EN^SROABCH",(ZTSAVE("SRSITE*"),ZTSAVE("SRASTDT"),ZTSAVE("SRAENDT"))="",ZTDESC="Batch Print Risk Assessments" D ^%ZTLOAD S SRSOUT=1 G END +EN ; entry when queued + S SRSOUT=0,SRABATCH=1 + U IO S SRAENDT=SRAENDT+.9999,SDATE=SRASTDT-.0001 F S SDATE=$O(^SRF("AC",SDATE)) Q:'SDATE!(SDATE>SRAENDT)!SRSOUT S SRTN=0 F S SRTN=$O(^SRF("AC",SDATE,SRTN)) Q:'SRTN!SRSOUT D STUFF +END I $D(ZTQUEUED) Q:$G(ZTSTOP) S ZTREQ="@" Q + I $E(IOST)'="P",'SRSOUT W !!,"Press RETURN to continue " R X:DTIME + D ^%ZISC K SRTN W @IOF D ^SRSKILL + Q +STUFF S DATE=$P(^SRF(SRTN,0),"^",9) + S SR("RA")=$G(^SRF(SRTN,"RA")),X=$P(SR("RA"),"^") I X'="T",X'="C" Q + I $P(SR("RA"),"^",6)'="Y" Q + K SRA D ^SROAPAS + Q diff --git a/r/SURGERY-SR/SROACAR.m b/r/SURGERY-SR/SROACAR.m index f0f60c08..ca3ed82e 100644 --- a/r/SURGERY-SR/SROACAR.m +++ b/r/SURGERY-SR/SROACAR.m @@ -1,55 +1,43 @@ -SROACAR ;BIR/MAM - OPEATIVE DATA ;12/03/07 - ;;3.0; Surgery ;**38,71,93,95,100,125,142,153,166**;24 Jun 93;Build 7 - I '$D(SRTN) W !!,"A Surgery Risk Assessment must be selected prior to using this option.",!!,"Press to continue " R X:DTIME G END - S SRACLR=0,SRSOUT=0,SRSUPCPT=1 D ^SROAUTL -START D:SRACLR RET G:SRSOUT END S SRACLR=0 K SRA,SRAO D ^SROACR1 -ASK W !,"Select Cardiac Procedures Operative Information to Edit: " R X:DTIME I '$T!("^"[X) G END - S X=$S(X="a":"A",X="n":"N",1:X) I '$D(SRAO(X)),(X'?.N1":".N),(X'="A"),(X'="N") D HELP G:SRSOUT END G START - I X="A" S X="1:22" - I X?.N1":".N S Y=$E(X),Z=$P(X,":",2) I Y<1!(Z>22)!(Y>Z) D HELP G:SRSOUT END G START - I X="N" D G:SRSOUT END G START - .W ! K DIR S DIR(0)="Y",DIR("B")="NO",DIR("A")="Are you sure you want to set all fields on this page to NO" - .D ^DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q - .I Y D NO2ALL - D HDR^SROAUTL - I X?.N1":".N D RANGE G START - I $D(SRAO(X)),+X=X S EMILY=X D G START - .I $$LOCK^SROUTL(SRTN) W ! D ONE,UNLOCK^SROUTL(SRTN) - I $D(SRAO(X)) W ! S EMILY=X D G START - .I $$LOCK^SROUTL(SRTN) D ONE,UNLOCK^SROUTL(SRTN) -END I 'SRSOUT D ^SROACR2 - W @IOF D ^SRSKILL - Q -HELP W @IOF,!!!!,"Enter the number or range of numbers you want to edit. Examples of proper",!,"responses are listed below." - W !!,"1. Enter 'A' to update all information.",!!,"2. Enter 'N' to set all fields on this page to NO." - W !!,"3. Enter a number (1-22) to update the information in that field. (For",!," example, enter '9' to update Valve Repair.)" - W !!,"4. Enter a range of numbers (1-22) separated by a ':' to enter a range of",!," information. (For example, enter '6:8' to enter Aortic Valve",!," Replacement, Mitral Valve Replacement, and Tricuspid Valve Replacement.)" - D RET - Q -RANGE ; range of numbers - I $$LOCK^SROUTL(SRTN) D D UNLOCK^SROUTL(SRTN) - .W ! S SHEMP=$P(X,":"),CURLEY=$P(X,":",2) F EMILY=SHEMP:1:CURLEY Q:SRSOUT D ONE - Q -ONE ; edit one item - ;I EMILY=16 D MIS^SROACR1 Q - I EMILY=22 D OPS Q - K DR,DIE S DA=SRTN,DR=$P(SRAO(EMILY),"^",2)_"T",DIE=130 D ^DIE K DR I $D(Y) S SRSOUT=1 - I 'SRSOUT,EMILY=12!(EMILY=13) D OK - Q -NO2ALL ; set all fields to NO - N II K DR,DIE S DA=SRTN,DIE=130 - F II=367,368,369,371,481,483,376,380,378,377,379,373,372,505,502 S DR=$S($D(DR):DR_";",1:"")_II_"////N" - F II=365,366,464,465,416 S DR=DR_";"_II_"////0" - S DR=DR_";"_370_"////5"_";"_512_"////N" - D ^DIE K DR - Q -OK N SRISCH,SRCPB S X=$G(^SRF(SRTN,206)),SRISCH=$P(X,"^",36),SRCPB=$P(X,"^",37) - I SRISCH,SRCPB,SRISCH>SRCPB W !!," *** NOTE: Ischemic Time is greater than CPB Time!! Please check. ***",! D RET W ! - Q -RET Q:SRSOUT W ! K DIR S DIR(0)="E" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 - Q -OPS ; enter other cardiac procedures, specify - S DIE=130,DA=SRTN,DR="502T" D ^DIE K DR Q:$D(Y) - I X'="Y" K ^SRF(SRTN,209.1) Q - S DIE=130,DA=SRTN,DR="484T" D ^DIE K DR - Q +SROACAR ;BIR/MAM - OPEATIVE DATA ;03/29/06 + ;;3.0; Surgery ;**38,71,93,95,100,125,142,153**;24 Jun 93;Build 11 + I '$D(SRTN) W !!,"A Surgery Risk Assessment must be selected prior to using this option.",!!,"Press to continue " R X:DTIME G END + S SRACLR=0,SRSOUT=0,SRSUPCPT=1 D ^SROAUTL +START D:SRACLR RET G:SRSOUT END S SRACLR=0 K SRA,SRAO D ^SROACR1 +ASK W !,"Select Operative Information to Edit: " R X:DTIME I '$T!("^"[X) G END + S:X="a" X="A" I '$D(SRAO(X)),(X'?.N1":".N),(X'="A") D HELP G:SRSOUT END G START + I X="A" S X="1:22" + I X?.N1":".N S Y=$E(X),Z=$P(X,":",2) I Y<1!(Z>22)!(Y>Z) D HELP G:SRSOUT END G START + D HDR^SROAUTL + I X?.N1":".N D RANGE G START + I $D(SRAO(X)),+X=X S EMILY=X D G START + .I $$LOCK^SROUTL(SRTN) W ! D ONE,UNLOCK^SROUTL(SRTN) + I $D(SRAO(X)) W ! S EMILY=X D G START + .I $$LOCK^SROUTL(SRTN) D ONE,UNLOCK^SROUTL(SRTN) +END I 'SRSOUT D ^SROACR2 + W @IOF D ^SRSKILL + Q +HELP W @IOF,!!!!,"Enter the number or range of numbers you want to edit. Examples of proper",!,"responses are listed below." + W !!,"1. Enter 'A' to update all information.",!!,"2. Enter a number (1-22) to update the information in that field. (For",!," example, enter '9' to update Valve Repair.)" + W !!,"3. Enter a range of numbers (1-22) separated by a ':' to enter a range of",!," information. (For example, enter '6:8' to enter Aortic Valve",!," Replacement, Mitral Valve Replacement, and Tricuspid Valve Replacement.)" + D RET + Q +RANGE ; range of numbers + I $$LOCK^SROUTL(SRTN) D D UNLOCK^SROUTL(SRTN) + .W ! S SHEMP=$P(X,":"),CURLEY=$P(X,":",2) F EMILY=SHEMP:1:CURLEY Q:SRSOUT D ONE + Q +ONE ; edit one item + ;I EMILY=16 D MIS^SROACR1 Q + I EMILY=22 D OPS Q + K DR,DIE S DA=SRTN,DR=$P(SRAO(EMILY),"^",2)_"T",DIE=130 D ^DIE K DR I $D(Y) S SRSOUT=1 + I 'SRSOUT,EMILY=12!(EMILY=13) D OK + Q +OK N SRISCH,SRCPB S X=$G(^SRF(SRTN,206)),SRISCH=$P(X,"^",36),SRCPB=$P(X,"^",37) + I SRISCH,SRCPB,SRISCH>SRCPB W !!," *** NOTE: Ischemic Time is greater than CPB Time!! Please check. ***",! D RET W ! + Q +RET Q:SRSOUT W ! K DIR S DIR(0)="E" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 + Q +OPS ; enter other cardiac procedures, specify + S DIE=130,DA=SRTN,DR="502T" D ^DIE K DR Q:$D(Y) + I X'="Y" K ^SRF(SRTN,209.1) Q + S DIE=130,DA=SRTN,DR="484T" D ^DIE K DR + Q diff --git a/r/SURGERY-SR/SROACMP.m b/r/SURGERY-SR/SROACMP.m index 5d8bd83e..1472f3d3 100644 --- a/r/SURGERY-SR/SROACMP.m +++ b/r/SURGERY-SR/SROACMP.m @@ -1,93 +1,69 @@ -SROACMP ;BIR/ADM - M&M VERIFICATION REPORT ;12/19/07 - ;;3.0; Surgery ;**47,50,127,143,166**;24 Jun 93;Build 7 - S DFN=0 F S DFN=$O(^TMP("SR",$J,DFN)) Q:'DFN S SRTN=0 F S SRTN=$O(^TMP("SR",$J,DFN,SRTN)) Q:'SRTN D UTIL - I SRFORM=1,SRSP D SS - D HDR^SROACMP1 I $D(^TMP("SR",$J)) S SRPAT="" F S SRPAT=$O(^TMP("SRPAT",$J,SRPAT)) Q:SRPAT="" D Q:SRSOUT S SRNM=0 I $Y+7>> "_SRPAT_" ("_$P(SRX,"^",2)_")",SRDEATH=$P(SRX,"^",3) - .I SRDEATH S SRNAME=SRNAME_" - DIED "_$E(SRDEATH,4,5)_"/"_$E(SRDEATH,6,7)_"/"_$E(SRDEATH,2,3) S X=$E(SRDEATH,9,12) I X S X=X_"000",SRNAME=SRNAME_"@"_$E(X,1,2)_":"_$E(X,3,4) - .I $Y+9>IOSL D HDR^SROACMP1 I SRSOUT Q - .W !,SRNAME S SRNM=1,DFN=$P(SRX,"^"),SRTN=0 F S SRTN=$O(^TMP("SR",$J,DFN,SRTN)) Q:'SRTN!SRSOUT D SET - G:SRSOUT END^SROACMP1 I '$D(^TMP("SR",$J)) W !!,"There are no perioperative occurrences or deaths recorded for ",$S(SRFORM=1:"surgeries performed in the selected date range.",1:"completed assessments not yet transmitted.") - D HDR2^SROACMP1,END^SROACMP1 - Q -UTIL ; list all cases within 30 days prior to postop occurrence and/or 90 days prior to death - S SRPOST=0 F S SRPOST=$O(^SRF(SRTN,16,SRPOST)) Q:'SRPOST S SRDATE=$E($P(^SRF(SRTN,16,SRPOST,0),"^",7),1,7) I SRDATE S SRBACK=-30 D PRIOR - D DEM^VADPT S ^TMP("SRPAT",$J,VADM(1))=DFN_"^"_VA("PID")_"^"_$P(VADM(6),"^") - S SRDATE=$P(VADM(6),"^") I SRDATE S SRBACK=-90 D PRIOR - Q -PRIOR ; list cases in 30 days before this occurrence or 90 days before death - S X1=SRDATE,X2=SRBACK D C^%DTC S SDATE=X,SRCASE=0 F S SRCASE=$O(^SRF("B",DFN,SRCASE)) Q:'SRCASE I '$D(^TMP("SR",$J,DFN,SRCASE)) D - .I $D(^XUSEC("SROCHIEF",+DUZ)) Q:'$$MANDIV^SROUTL0(SRINSTP,SRTN) - .I '$D(^XUSEC("SROCHIEF",+DUZ)) Q:'$$DIV^SROUTL0(SRTN) - .I '$P($G(^SRF(SRCASE,.2)),"^",12)!$P($G(^SRF(SRCASE,30)),"^")!($P($G(^SRF(SRCASE,"NON")),"^")="Y") Q - .S SRX=$E($P(^SRF(SRCASE,0),"^",9),1,7) I SRXSRDATE) Q - .S ^TMP("SR",$J,DFN,SRCASE)=$P(^SRF(SRCASE,0),"^",4) - Q -SET ; set variables to print - N SRSEP,SRICDN - S SR(0)=^SRF(SRTN,0),(SRD,Y)=$P(SR(0),"^",9),SRSDATE=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3),Y=$P(SR(0),"^",4) I Y S SRSS=$P(^SRO(137.45,Y,0),"^") -OPS S SROPER=$P(^SRF(SRTN,"OP"),"^") - K SRP,Z S:$L(SROPER)<121 SRP(1)=SROPER I $L(SROPER)>120 S SROPER=SROPER_" " F M=1:1 D OPER Q:Z="" - N SRL S SRL=109 D CPTS^SROAUTL0 I SRPROC(1)="" S SRPROC(1)="NOT ENTERED" - S SRCHK=0 I SRDEATH S X1=SRDEATH,X2=-90 D C^%DTC I SRDIOSL D HDR^SROACMP1 I SRSOUT Q - W !!,SRSDATE,?11,SRTN,?25,SRSS,?80,SRTYPE,?98,SRSTATUS,?116,SRREL - W !,?11,SRP(1) W:$D(SRP(2)) !,?11,SRP(2) - W !,?11,"CPT Codes: ",SRPROC(1) W:$D(SRPROC(2)) !,?24,SRPROC(2) - W !,?11,"Occurrences: " I '$D(SRC(1)) S SRC(1)="NONE ENTERED" - S SRI=0 F S SRI=$O(SRC(SRI)) Q:'SRI D - .W:SRI>1 ! W ?24,$P(SRC(SRI),"^") - .I $Y+6>IOSL D HDR^SROACMP1 W ! I SRSOUT Q - .D TEXT D:SRT WP - S SRNDTH=$P($G(^SRF(SRTN,205)),"^",3) - I SRDEATH!SRNDTH D K SRNDTH - .I SRNDTH W !,?11,"Date of Death: "_$E(SRNDTH,4,5)_"/"_$E(SRNDTH,6,7)_"/"_$E(SRNDTH,2,3) S X=$E(SRNDTH,9,12) I X S X=X_"000" W "@"_$E(X,1,2)_":"_$E(X,3,4) - .W !,?11,"Review of Death Comments: " D - ..I '$O(^SRF(SRTN,47,0)) W "NONE ENTERED" Q - ..D DWP - Q -OPER ; break procedure if greater than 48 characters - S SRP(M)="" F LOOP=1:1 S Z=$P(SROPER," ") Q:Z="" Q:$L(SRP(M))+$L(Z)'<49 S SRP(M)=SRP(M)_Z_" ",SROPER=$P(SROPER," ",2,200) - Q -DATE S SRY=$S(Y:" ("_$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_")",1:" (NO DATE)") - Q -SS ; set up ^TMP for selected specialties - K ^TMP("SRSP",$J) S SRQ=0,SRNAME="" F S SRNAME=$O(^TMP("SRPAT",$J,SRNAME)) Q:SRNAME="" S DFN=$P(^TMP("SRPAT",$J,SRNAME),"^"),(SRQ,SRTN)=0 D - .F S SRTN=$O(^TMP("SR",$J,DFN,SRTN)) Q:'SRTN D Q:SRQ - ..S Y=$P(^SRF(SRTN,0),"^",4) S:'Y Y="ZZ" I $D(SRSP(Y)) S ^TMP("SRSP",$J,DFN)="",SRQ=1 Q - S SRNAME="" F S SRNAME=$O(^TMP("SRPAT",$J,SRNAME)) Q:SRNAME="" S DFN=$P(^TMP("SRPAT",$J,SRNAME),"^") I '$D(^TMP("SRSP",$J,DFN)) K ^TMP("SR",$J,DFN),^TMP("SRPAT",$J,SRNAME) - Q -WP ; print occurrence comments - N CM K ^UTILITY($J,"W") S CM=0 F S CM=$O(^SRF(SRTN,SRY,SRZ,1,CM)) Q:'CM S X=^SRF(SRTN,SRY,SRZ,1,CM,0),DIWL=30,DIWR=132 D ^DIWP - I $D(^UTILITY($J,"W")) F J=1:1:^UTILITY($J,"W",30) D - .I $Y+7>IOSL D HDR^SROACMP1 W ! I SRSOUT Q - .W !,?30,^UTILITY($J,"W",30,J,0) - Q -TEXT ; check for occurrence comments - S SRT=0,SRX=$P(SRC(SRI),"^",2) I SRX'="" S SRY=$P(SRX,";"),SRZ=$P(SRX,";",2) I $O(^SRF(SRTN,SRY,SRZ,1,0)) S SRT=1 W !,?26,">>> Comments:" - Q -DWP ; print review of death comments - N CM K ^UTILITY($J,"W") S CM=0 F S CM=$O(^SRF(SRTN,47,CM)) Q:'CM S X=^SRF(SRTN,47,CM,0),DIWL=38,DIWR=132 D ^DIWP - I $D(^UTILITY($J,"W")) F J=1:1:^UTILITY($J,"W",38) D - .I $Y+7>IOSL D HDR^SROACMP1 W ! I SRSOUT Q - .W ?38,^UTILITY($J,"W",38,J,0),! - Q +SROACMP ;BIR/ADM-M&M Verification Report ;02/20/05 + ;;3.0; Surgery ;**47,50,127,143**;24 Jun 93 + S DFN=0 F S DFN=$O(^TMP("SR",$J,DFN)) Q:'DFN S SRTN=0 F S SRTN=$O(^TMP("SR",$J,DFN,SRTN)) Q:'SRTN D UTIL + I SRFORM=1,SRSP D SS + D HDR^SROACMP1 I $D(^TMP("SR",$J)) S SRPAT="" F S SRPAT=$O(^TMP("SRPAT",$J,SRPAT)) Q:SRPAT="" D Q:SRSOUT S SRNM=0 I $Y+7>> "_SRPAT_" ("_$P(SRX,"^",2)_")",SRDEATH=$P(SRX,"^",3) + .I SRDEATH S SRNAME=SRNAME_" - DIED "_$E(SRDEATH,4,5)_"/"_$E(SRDEATH,6,7)_"/"_$E(SRDEATH,2,3) S X=$E(SRDEATH,9,12) I X S X=X_"000",SRNAME=SRNAME_"@"_$E(X,1,2)_":"_$E(X,3,4) + .I $Y+9>IOSL D HDR^SROACMP1 I SRSOUT Q + .W !,SRNAME S SRNM=1,DFN=$P(SRX,"^"),SRTN=0 F S SRTN=$O(^TMP("SR",$J,DFN,SRTN)) Q:'SRTN!SRSOUT D SET + G:SRSOUT END^SROACMP1 I '$D(^TMP("SR",$J)) W !!,"There are no perioperative occurrences or deaths recorded for ",$S(SRFORM=1:"surgeries performed in the selected date range.",1:"completed assessments not yet transmitted.") + D HDR2^SROACMP1,END^SROACMP1 + Q +UTIL ; list all cases within 90 days prior to postop occurrence and/or death + S SRPOST=0 F S SRPOST=$O(^SRF(SRTN,16,SRPOST)) Q:'SRPOST S SRDATE=$E($P(^SRF(SRTN,16,SRPOST,0),"^",7),1,7) I SRDATE S SRBACK=-30 D PRIOR + D DEM^VADPT S ^TMP("SRPAT",$J,VADM(1))=DFN_"^"_VA("PID")_"^"_$P(VADM(6),"^") + S SRDATE=$P(VADM(6),"^") I SRDATE S SRBACK=-90 D PRIOR + Q +PRIOR ; list cases in 30 days before this occurrence or 90 days before death + S X1=SRDATE,X2=SRBACK D C^%DTC S SDATE=X,SRCASE=0 F S SRCASE=$O(^SRF("B",DFN,SRCASE)) Q:'SRCASE I '$D(^TMP("SR",$J,DFN,SRCASE)) D + .I $D(^XUSEC("SROCHIEF",+DUZ)) Q:'$$MANDIV^SROUTL0(SRINSTP,SRTN) + .I '$D(^XUSEC("SROCHIEF",+DUZ)) Q:'$$DIV^SROUTL0(SRTN) + .I '$P($G(^SRF(SRCASE,.2)),"^",12)!$P($G(^SRF(SRCASE,30)),"^")!($P($G(^SRF(SRCASE,"NON")),"^")="Y") Q + .S SRX=$E($P(^SRF(SRCASE,0),"^",9),1,7) I SRXSRDATE) Q + .S ^TMP("SR",$J,DFN,SRCASE)=$P(^SRF(SRCASE,0),"^",4) + Q +SET ; set variables to print + N SRSEP + S SR(0)=^SRF(SRTN,0),(SRD,Y)=$P(SR(0),"^",9),SRSDATE=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3),Y=$P(SR(0),"^",4) I Y S SRSS=$E($P($P(^SRO(137.45,Y,0),"^")," "),1,13),SRSS=$P(SRSS," "),SRSS=$P(SRSS,"(") +OPS S SROPER=$P(^SRF(SRTN,"OP"),"^"),OPER=0 F S OPER=$O(^SRF(SRTN,13,OPER)) Q:OPER="" D OTHER + K SRP,Z S:$L(SROPER)<40 SRP(1)=SROPER I $L(SROPER)>39 S SROPER=SROPER_" " F M=1:1 D OPER Q:Z="" + S SRCHK=0 I SRDEATH S X1=SRDEATH,X2=-90 D C^%DTC I SRDIOSL D HDR^SROACMP1 I SRSOUT Q + W !!,SRSDATE,?11,SRSS,?25,SRP(1),?69,SRREL W:$D(SRC(1)) ?75,SRC(1) W ?120,SRA + F SRC=2:1 Q:'$D(SRP(SRC))&'$D(SRC(SRC)) D Q:SRSOUT + .I $Y+6>IOSL D HDR^SROACMP1 I SRSOUT Q + .W ! W:$D(SRP(SRC)) ?25,SRP(SRC) W:$D(SRC(SRC)) ?75,SRC(SRC) + Q +OTHER ; other operations + S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,OPER,0),"^"))>250 S SRLONG=0,OPER=999,SROPERS=" ..." + I SRLONG S SROPERS=$P(^SRF(SRTN,13,OPER,0),"^") + S SROPER=SROPER_$S(SROPERS=" ...":SROPERS,1:", "_SROPERS) + Q +OPER ; break procedure if greater than 40 characters + S SRP(M)="" F LOOP=1:1 S Z=$P(SROPER," ") Q:Z="" Q:$L(SRP(M))+$L(Z)'<40 S SRP(M)=SRP(M)_Z_" ",SROPER=$P(SROPER," ",2,200) + Q +DATE S SRY=$S(Y:" ("_$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_")",1:" (NO DATE)") + Q +SS ; set up ^TMP for selected specialties + K ^TMP("SRSP",$J) S SRQ=0,SRNAME="" F S SRNAME=$O(^TMP("SRPAT",$J,SRNAME)) Q:SRNAME="" S DFN=$P(^TMP("SRPAT",$J,SRNAME),"^"),(SRQ,SRTN)=0 D + .F S SRTN=$O(^TMP("SR",$J,DFN,SRTN)) Q:'SRTN D Q:SRQ + ..S Y=$P(^SRF(SRTN,0),"^",4) S:'Y Y="ZZ" I $D(SRSP(Y)) S ^TMP("SRSP",$J,DFN)="",SRQ=1 Q + S SRNAME="" F S SRNAME=$O(^TMP("SRPAT",$J,SRNAME)) Q:SRNAME="" S DFN=$P(^TMP("SRPAT",$J,SRNAME),"^") I '$D(^TMP("SRSP",$J,DFN)) K ^TMP("SR",$J,DFN),^TMP("SRPAT",$J,SRNAME) + Q diff --git a/r/SURGERY-SR/SROACMP1.m b/r/SURGERY-SR/SROACMP1.m index 9d4ae948..deab6e93 100644 --- a/r/SURGERY-SR/SROACMP1.m +++ b/r/SURGERY-SR/SROACMP1.m @@ -1,66 +1,62 @@ -SROACMP1 ;BIR/ADM - M&M VERIFICATION REPORT (CONT'D) ;11/26/07 - ;;3.0; Surgery ;**47,68,77,50,166**;24 Jun 93;Build 7 -EN ; entry point - S (SRSOUT,SRSP)=0,SRINST=$P($$SITE^SROVAR,"^",2) W @IOF,!,?28,"M&M Verification Report" - W !!,"The M&M Verification Report is a tool to assist in the review of occurrences" - W !,"and their assignment to operations and in the review of death unrelated or",!,"related assignments to operations." - W !!,"The full report includes all patients who had operations within the selected" - W !,"date range who experienced intraoperative occurrences, postoperative" - W !,"occurrences or death within 90 days of surgery. The pre-transmission report" - W !,"is similar but includes only operations with completed risk assessments that" - W !,"have not yet transmitted to the national database.",! - D SEL G:SRSOUT END I SRFORM=2 G SPEC - D DATE^SROUTL(.SRSD,.SRED,.SRSOUT) G:SRSOUT END -SPEC I $D(^XUSEC("SROCHIEF",+DUZ)) N SRINSTP S SRINST=$$INST^SROUTL0() G:SRINST="^" END S SRINSTP=$P(SRINST,U),SRINST=$S(SRINST["ALL DIVISIONS":SRINST,1:$P(SRINST,U,2)) - W !! K DIR S DIR("A")="Do you want to print this report for all Surgical Specialties ",DIR("B")="YES",DIR(0)="Y" - S DIR("?",1)="Enter RETURN to print this report for all surgical specialties, or 'NO' to",DIR("?")="select a specific specialty." - D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 G END - I 'Y D SP I SRSOUT G END -DEV K IOP,%ZIS,POP,IO("Q") S %ZIS("A")="Print the Report on which Device: ",%ZIS="QM" W !!,"This report is designed to use a 132 column format.",! D ^%ZIS I POP S SRSOUT=1 G END - I $D(IO("Q")) K IO("Q") S ZTDESC="M&M Verification Report",ZTRTN="BEG^SROACMP1",(ZTSAVE("SRFORM"),ZTSAVE("SRINST"),ZTSAVE("SRSP*"),ZTSAVE("SRINSTP"))="" S:SRFORM=1 (ZTSAVE("SRED"),ZTSAVE("SRSD"))="" D ^%ZTLOAD G END -BEG U IO S (SRHDR,SRNM,SRSOUT,SRSS)=0,PAGE=1,Y=DT X ^DD("DD") S SRPRINT="Report Generated: "_Y K ^TMP("SR",$J),^TMP("SRPAT",$J) - N SRFRTO I SRFORM=1 D - .S Y=SRSD X ^DD("DD") S SRFRTO="From: "_Y S Y=SRED X ^DD("DD") S SRFRTO=SRFRTO_" To: "_Y - .S SRSDT=SRSD-.0001,SREDT=SRED+.9999 F S SRSDT=$O(^SRF("AC",SRSDT)) Q:SRSDT>SREDT!'SRSDT!SRSOUT S SRTN=0 F S SRTN=$O(^SRF("AC",SRSDT,SRTN)) Q:'SRTN!SRSOUT D CASE - I SRFORM=2 F SRASS="C","N" S DFN=0 F S DFN=$O(^SRF("ARS",SRASS,"C",DFN)) Q:'DFN!SRSOUT S SRTN=0 F S SRTN=$O(^SRF("ARS",SRASS,"C",DFN,SRTN)) Q:'SRTN!SRSOUT D CASE - G:SRSOUT END G ^SROACMP -CASE ; examine case - Q:'$D(^SRF(SRTN,0)) - I $D(^XUSEC("SROCHIEF",+DUZ)) Q:'$$MANDIV^SROUTL0(SRINSTP,SRTN) - I '$D(^XUSEC("SROCHIEF",+DUZ)) Q:'$$DIV^SROUTL0(SRTN) - I SRFORM=2,SRSP S Y=$P(^SRF(SRTN,0),"^",4) S:'Y Y="ZZ" I '$D(SRSP(Y)) Q - I '$P($G(^SRF(SRTN,.2)),"^",12)!$P($G(^SRF(SRTN,30)),"^")!($P($G(^SRF(SRTN,"NON")),"^")="Y") Q - S DFN=$P(^SRF(SRTN,0),"^") I $O(^SRF(SRTN,10,0))!$O(^SRF(SRTN,16,0)) S ^TMP("SR",$J,DFN,SRTN)=$P(^SRF(SRTN,0),"^",4) Q - S SRDEATH=$P($G(^DPT(DFN,.35)),"^") I SRDEATH S X1=$P(^SRF(SRTN,0),"^",9),X2=90 D C^%DTC S SRDAY=X I SRDEATH'>SRDAY S ^TMP("SR",$J,DFN,SRTN)=$P(^SRF(SRTN,0),"^",4) - Q -END Q:'$D(SRSOUT) W @IOF K ^TMP("SRPAT",$J),^TMP("SRSP",$J) I $D(ZTQUEUED) K ^TMP("SR",$J) Q:$G(ZTSTOP) S ZTREQ="@" Q - D ^%ZISC,^SRSKILL K SRTN W @IOF - Q -SEL ; select report version - K DIR S DIR("A",1)="Print which report ?",DIR("A",2)=" ",DIR("A",3)="1. Full report for selected date range.",DIR("A",4)="2. Pre-transmission report for completed risk assessments." - S DIR("A",5)=" ",DIR("A")="Enter selection (1 or 2): ",DIR("B")=1,DIR("?")="Please enter the number (1 or 2) matching your choice of report",DIR(0)="NA^1:2" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q - S SRFORM=Y - Q -SP W !! S SRSP=1 K DIC S DIC("S")="I '$P(^(0),""^"",3)",DIC=137.45,DIC(0)="QEAMZ",DIC("A")="Print the report for which Specialty ? " D ^DIC I Y<0 S SRSOUT=1 Q - S SRCT=+Y,SRSP(SRCT)=+Y -MORE ; ask for more surgical specialties - K DIC S DIC("S")="I '$P(^(0),""^"",3)",DIC=137.45,DIC(0)="QEAMZ",DIC("A")="Select an Additional Specialty: " D ^DIC I Y>0 S SRCT=+Y,SRSP(SRCT)=+Y G MORE - Q -HDR ; print heading - I $D(ZTQUEUED) D ^SROSTOP I SRHALT S SRSOUT=1 Q - I SRHDR D HDR2 Q:SRSOUT S SRHDR=0 - W:$Y @IOF W !,?(132-$L(SRINST)\2),SRINST,?124,"Page ",PAGE,!,?54,"M&M Verification Report" - W:SRFORM=1 !,?(132-$L(SRFRTO)\2),SRFRTO - W:SRFORM=2 !,?41,"PRE-TRANSMISSION REPORT FOR COMPLETED ASSESSMENTS" - W ?100,"REVIEWED BY:",!,?(132-$L(SRPRINT)\2),SRPRINT,?100,"DATE REVIEWED:",! - W !,"OP DATE",?11,"CASE #",?25,"SURGICAL SPECIALTY",?80,"ASSESSMENT TYPE STATUS",?116,"DEATH RELATED",!,?11,"PRINCIPAL PROCEDURE",! F LINE=1:1:132 W "=" - I SRNM W !,SRNAME_" * * Continued from previous page * *" - S PAGE=PAGE+1,SRHDR=1 I '$D(^TMP("SR",$J)) - Q -HDR2 ; more heading - ;I $Y+6SREDT!'SRSDT!SRSOUT S SRTN=0 F S SRTN=$O(^SRF("AC",SRSDT,SRTN)) Q:'SRTN!SRSOUT D CASE + I SRFORM=2 F SRASS="C","N" S DFN=0 F S DFN=$O(^SRF("ARS",SRASS,"C",DFN)) Q:'DFN!SRSOUT S SRTN=0 F S SRTN=$O(^SRF("ARS",SRASS,"C",DFN,SRTN)) Q:'SRTN!SRSOUT D CASE + G:SRSOUT END G ^SROACMP +CASE ; examine case + Q:'$D(^SRF(SRTN,0)) + I $D(^XUSEC("SROCHIEF",+DUZ)) Q:'$$MANDIV^SROUTL0(SRINSTP,SRTN) + I '$D(^XUSEC("SROCHIEF",+DUZ)) Q:'$$DIV^SROUTL0(SRTN) + I SRFORM=2,SRSP S Y=$P(^SRF(SRTN,0),"^",4) S:'Y Y="ZZ" I '$D(SRSP(Y)) Q + I '$P($G(^SRF(SRTN,.2)),"^",12)!$P($G(^SRF(SRTN,30)),"^")!($P($G(^SRF(SRTN,"NON")),"^")="Y") Q + S DFN=$P(^SRF(SRTN,0),"^") I $O(^SRF(SRTN,10,0))!$O(^SRF(SRTN,16,0)) S ^TMP("SR",$J,DFN,SRTN)=$P(^SRF(SRTN,0),"^",4) Q + S SRDEATH=$P($G(^DPT(DFN,.35)),"^") I SRDEATH S X1=$P(^SRF(SRTN,0),"^",9),X2=90 D C^%DTC S SRDAY=X I SRDEATH'>SRDAY S ^TMP("SR",$J,DFN,SRTN)=$P(^SRF(SRTN,0),"^",4) + Q +END Q:'$D(SRSOUT) W @IOF K ^TMP("SRPAT",$J),^TMP("SRSP",$J) I $D(ZTQUEUED) K ^TMP("SR",$J) Q:$G(ZTSTOP) S ZTREQ="@" Q + D ^%ZISC,^SRSKILL K SRTN W @IOF + Q +SEL ; select report version + K DIR S DIR("A",1)="Print which variety of the report ?",DIR("A",2)=" ",DIR("A",3)="1. Print full report for selected date range.",DIR("A",4)="2. Print pre-transmission report for completed risk assessments." + S DIR("A",5)=" ",DIR("A")="Enter selection (1 or 2): ",DIR("B")=1,DIR("?")="Please enter the number (1 or 2) matching your choice of report",DIR(0)="NA^1:2" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q + S SRFORM=Y + Q +SP W !! S SRSP=1 K DIC S DIC("S")="I '$P(^(0),""^"",3)",DIC=137.45,DIC(0)="QEAMZ",DIC("A")="Print the report for which Specialty ? " D ^DIC I Y<0 S SRSOUT=1 Q + S SRCT=+Y,SRSP(SRCT)=+Y +MORE ; ask for more surgical specialties + K DIC S DIC("S")="I '$P(^(0),""^"",3)",DIC=137.45,DIC(0)="QEAMZ",DIC("A")="Select an Additional Specialty: " D ^DIC I Y>0 S SRCT=+Y,SRSP(SRCT)=+Y G MORE + Q +HDR ; print heading + I $D(ZTQUEUED) D ^SROSTOP I SRHALT S SRSOUT=1 Q + I SRHDR D HDR2 Q:SRSOUT S SRHDR=0 + W:$Y @IOF W !,?(132-$L(SRINST)\2),SRINST,?124,"Page ",PAGE,!,?54,"M&M Verification Report" + W:SRFORM=1 !,?(132-$L(SRFRTO)\2),SRFRTO + W:SRFORM=2 !,?41,"Pre-Transmission Report for Completed Assessments" + W ?100,"Reviewed By:",!,?(132-$L(SRPRINT)\2),SRPRINT,?100,"Date Reviewed:",! + W !,?68,"Death",?120,"Assessment",!,"Op Date",?11,"Specialty",?25,"Procedure(s)",?67,"Related Occurrence(s) - (Date)",?120,"Type/Status",! F LINE=1:1:132 W "=" + I SRNM W !,SRNAME_" * * Continued from previous page * *" + S PAGE=PAGE+1,SRHDR=1 I '$D(^TMP("SR",$J)) + Q +HDR2 ; more heading + I $Y+5 to print the completed assessment, or 'NO' to return to the menu." G PRINT - W ! K %ZIS,IO("Q"),POP S %ZIS("A")="Print the Completed Assessment on which Device: ",%ZIS="Q" D ^%ZIS I POP S SRSOUT=1 Q - I $D(IO("Q")) K IO("Q") S ZTDESC="Completed Surgery Risk Assessment",(ZTSAVE("SRSITE*"),ZTSAVE("SRTN"))="",ZTRTN="EN^SROACOM" D ^%ZTLOAD S SRSOUT=1 G END - D EN,END - Q -EN U IO S SRABATCH=1 D ^SROAPAS Q -END I 'SRSOUT,$E(IOST)'="P" D RET - W @IOF I $E(IOST)="P" D ^%ZISC W @IOF - D ^SRSKILL K SRMD,SRMD1,SRSFLG - Q -LIST W @IOF,!,"This assessment is missing the following items:",! S SRZ="",SRCNT=1 - F S SRZ=$O(SRX(SRZ)) Q:SRZ="" D:$Y+5>IOSL RET Q:SRSOUT W !,?5,$J(SRCNT,2)_". "_$P(SRX(SRZ),"^") S SRCNT=SRCNT+1 - S SRSOUT=0 W ! K DIR S DIR(0)="Y",DIR("A")="Do you want to enter the missing items at this time",DIR("B")="NO" D ^DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q - Q:'Y I $$LOCK^SROUTL(SRTN) D PRT,UNLOCK^SROUTL(SRTN) - Q -PRT S SRSOUT=0,(SRMD,SRMD1)="",SRCNT=0 F S SRMD=$O(SRX(SRMD)) Q:SRMD="" S SRMD1=$P(SRX(SRMD),"^",2) D Q:$G(SRSFLG) - .I $E(SRMD,1,10)="ANESTHESIA" D ANES Q - .I $E(SRMD,1,6)="POSTOP"!($E(SRMD,1,6)="SEPSIS") D POST^SROCMPS Q - .K DR,DIE S DA=SRTN,DIE=130,DR=$S($G(SRMD1):SRMD1,1:SRMD)_"T" D ^DIE K DR I $D(Y) S SRSFLG=1 - S:'$G(SRSOUT) SRSOUT=0 - Q -ANES K DR,DIE,DA S DA=SRTN,DR=.37,DR(2,130.06)=".01T;.05T;42T",DIE=130 D ^DIE S:$D(Y) SRSFLG=1 K DR - Q -RET W !! K DIR S DIR(0)="E" D ^DIR K DIR W @IOF I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 - Q -PAGE I $E(IOST)'="P" D RET Q - W @IOF,!!! - Q +SROACOM ;BIR/MAM - COMPLETE ASSESSMENT ;02/08/07 + ;;3.0; Surgery ;**38,55,63,65,88,93,95,102,100,125,134,142,160**;24 Jun 93;Build 7 + I '$D(SRTN) Q + S (SRSFLG,SRSOUT,SROVER)=0,SRA=$G(^SRF(SRTN,"RA")),Y=$P(SRA,"^") I Y'="I" W !!,"This assessment has a "_$S(Y="C":"'COMPLETE'",1:"'TRANSMITTED'")_" status.",!!,"No action taken." G END + I $P(SRA,"^",2)="N",$P(SRA,"^",6)="Y" D CHK^SROAUTL + I $P(SRA,"^",2)="N",$P(SRA,"^",6)="N" D CHK^SROAUTL3 + I $P(SRA,"^",2)="C" D CHK^SROAUTLC + S SRFLD="" I $O(SRX(SRFLD))'="" D LIST + I $P(SRA,"^",2)="C" D CHCK G:SRSOUT END +YEP I '$P($G(^SRO(136,SRTN,10)),"^")!('$P($G(^SRO(136,SRTN,0)),"^",2))!('$P($G(^SRO(136,SRTN,0)),"^",3)) W !!,?6,"The coding for Procedure and Diagnosis is not complete." + W ! S SRFLD="" K DIR S DIR("A")="Are you sure you want to complete this assessment ? ",DIR("B")=$S($O(SRX(SRFLD)):"NO",1:"YES"),DIR(0)="YA" + S DIR("?",1)="Enter YES to complete this assessment, or enter NO to leave the status",DIR("?")="unchanged." D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 G END + I 'Y W !!,"No action taken." G END + I $$LOCK^SROUTL(SRTN) D COMPLT Q + E W !!,"No action taken." G END + Q +COMPLT W !!,"Updating the current status to 'COMPLETE'..." K DR,DIE S DA=SRTN,DIE=130,DR="235///C" D ^DIE K STATUS + I $P(SRA,"^",5)="" K DR,DIE S DA=SRTN,DIE=130,DR="272///"_DT D ^DIE K STATUS + I $P(SRA,"^",2)="C" K DA,DIE,DIK,DR S DIK="^SRF(",DIK(1)=".232^AQ",DA=SRTN D EN1^DIK K DA,DIK + D UNLOCK^SROUTL(SRTN) +PRINT W !!,"Do you want to print the completed assessment ? YES// " R SRYN:DTIME I '$T!(SRYN["^") S SRSOUT=1 Q + S SRYN=$E(SRYN) S:SRYN="" SRYN="Y" I "Nn"[SRYN S SRSOUT=1 Q + I "Yy"'[SRYN W !!,"Enter to print the completed assessment, or 'NO' to return to the menu." G PRINT + W ! K %ZIS,IO("Q"),POP S %ZIS("A")="Print the Completed Assessment on which Device: ",%ZIS="Q" D ^%ZIS I POP S SRSOUT=1 Q + I $D(IO("Q")) K IO("Q") S ZTDESC="Completed Surgery Risk Assessment",(ZTSAVE("SRSITE*"),ZTSAVE("SRTN"))="",ZTRTN="EN^SROACOM" D ^%ZTLOAD S SRSOUT=1 G END + D EN,END + Q +EN U IO S SRABATCH=1 D ^SROAPAS Q +END I 'SRSOUT,$E(IOST)'="P" D RET + W @IOF I $E(IOST)="P" D ^%ZISC W @IOF + D ^SRSKILL K SRSFLG + Q +LIST W @IOF,!,"This assessment is missing the following items:",! S SRZ="",SRCNT=1 + ;I '$P($G(^SRO(136,SRTN,10)),"^")!('$P($G(^SRO(136,SRTN,0)),"^",2))!('$P($G(^SRO(136,SRTN,0)),"^",3)) W !,?6,"The coding for Procedure and Diagnosis is",!,?6,"not complete.",! + F S SRZ=$O(SRX(SRZ)) Q:SRZ="" D:$Y+5>IOSL RET Q:SRSOUT W !,?5,$J(SRCNT,2)_". "_$P(SRX(SRZ),"^") S SRCNT=SRCNT+1 + S SRSOUT=0 W ! K DIR S DIR(0)="Y",DIR("A")="Do you want to enter the missing items at this time",DIR("B")="NO" D ^DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q + Q:'Y I $$LOCK^SROUTL(SRTN) D PRT,UNLOCK^SROUTL(SRTN) + Q +PRT S SRSOUT=0,(SRMD,SRMD1)="",SRCNT=0 F S SRMD=$O(SRX(SRMD)) Q:SRMD="" S SRMD1=$P(SRX(SRMD),"^",2) D Q:$G(SRSFLG) + .I $E(SRMD,1,10)="ANESTHESIA" D ANES Q + .I $E(SRMD,1,6)="POSTOP"!($E(SRMD,1,6)="SEPSIS") D POST^SROCMPS Q + .I SRMD=240 D FUNCT Q + .I SRMD=492 D FUNCTI^SROAPRE Q + .I SRMD=485 W @IOF,! D PRIOR^SROACL2 K DR,DIE S DA=SRTN,DR="485///"_$S(X="@":"@",1:$P(Y,"^")),DIE=130 D ^DIE K DR S:$D(Y) SRSFLG=1 Q + .K DR,DIE S DA=SRTN,DIE=130,DR=$S($G(SRMD1):SRMD1,1:SRMD)_"T" D ^DIE K DR I $D(Y) S SRSFLG=1 + S:'$G(SRSOUT) SRSOUT=0 + Q +FUNCT I $P($G(^SRF(SRTN,"RA")),"^",2)="C" D FUNCT^SROACLN Q + D FUNCTJ^SROAPRE + Q +ANES K DR,DIE,DA S DA=SRTN,DR=.37,DR(2,130.06)=".01T;.05T;42T",DIE=130 D ^DIE S:$D(Y) SRSFLG=1 K DR + Q +CHCK ; cardiac checks added by SR*3*93 + N SRADM,SRDIS,SRISCH,SRCPB,SRRET S SRRET=0,X=$G(^SRF(SRTN,208)),SRADM=$P(X,"^",14),SRDIS=$P(X,"^",15),X=$G(^SRF(SRTN,206)),SRISCH=$P(X,"^",36),SRCPB=$P(X,"^",37) + I SRADM,SRDIS,SRADM'SRCPB W !!," *** NOTE: Ischemic Time is greater than CPB Time!! Please check. ***",! S SRRET=1,SRX(450)="" + I SRRET W ! K DIR S DIR(0)="E" D ^DIR K DIR S:$D(DTOUT)!$D(DUOUT) SRSOUT=1 W ! + Q +RET W !! K DIR S DIR(0)="E" D ^DIR K DIR W @IOF I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 + Q +PAGE I $E(IOST)'="P" D RET Q + W @IOF,!!! + Q diff --git a/r/SURGERY-SR/SROACOP.m b/r/SURGERY-SR/SROACOP.m index 70fa5377..2a590c9a 100644 --- a/r/SURGERY-SR/SROACOP.m +++ b/r/SURGERY-SR/SROACOP.m @@ -1,79 +1,76 @@ -SROACOP ;BIR/MAM - CARDIAC OPERATIVE RISK SUMMARY ;12/20/07 - ;;3.0; Surgery ;**38,47,71,88,95,107,100,125,142,153,160,166**;24 Jun 93;Build 7 - I '$D(SRTN) W !!,"A Surgery Risk Assessment must be selected prior to using this option.",!!,"Press to continue " R X:DTIME G END - N SRCSTAT S SRACLR=0,SRSOUT=0,SRSUPCPT=1 D ^SROAUTL -START D:SRACLR RET G:SRSOUT END S SRACLR=0 K SRA,SRAO - F I=206,206.1,208 S SRA(I)=$G(^SRF(SRTN,I)) - I $P(SRA(206),"^",41)="" K DA,DIE,DR S DA=SRTN,DIE=130,DR="472////N" D ^DIE K DA,DIE,DR S SRA(206)=$G(^SRF(SRTN,206)) - S Y=$P($G(^SRF(SRTN,1.1)),"^",3),C=$P(^DD(130,1.13,0),"^",2) D:Y'="" Y^DIQ S SRAO(2)=Y_"^1.13" - S SRAO(1)=$P(SRA(206),"^",31)_"^364",SRAO(3)=$P(SRA(208),"^",12)_"^414" - S (X,Y)=$P(SRA(206),"^",32) D:Y DT S SRAO("1A")=X_"^364.1" - S Y=$P(SRAO(3),"^") I Y'="" S C=$P(^DD(130,414,0),"^",2) D Y^DIQ S $P(SRAO(3),"^")=Y - S Y=$P(SRA(208),"^",13) D DT S SRAO("3A")=X_"^414.1" - S Y=$P($G(^SRF(SRTN,.2)),"^",2) D DT S SRAO(4)=X_"^.22" - S Y=$P($G(^SRF(SRTN,.2)),"^",3) D DT S SRAO(5)=X_"^.23" - S SRAO(6)=SRA(206.1)_"^430" - S SRCSTAT=">> Coding "_$S($P($G(^SRO(136,SRTN,10)),"^"):"",1:"Not ")_"Complete <<" - S SRPAGE="PAGE: 1" D HDR^SROAUTL S SRAO(7)="" - S (X,X1)=$P(SRAO(1),"^"),X=$S(X?1.3N:X_"%",1:X) W !," 1. Physician's Preoperative Estimate of Operative Mortality: "_X - S X=$P(SRAO("1A"),"^") I X1'=""!(X'="") W !,?3," A. Date/Time Collected: "_X - W !," 2. ASA Classification:",?31,$P(SRAO(2),"^"),!," 3. Surgical Priority:",?31,$P(SRAO(3),"^") - S X=$P(SRAO("3A"),"^") I X'="" W !,?3," A. Date/Time Collected: "_X - W !," 4. Date/Time Operation Began:",?31,$P(SRAO(4),"^"),!," 5. Date/Time Operation Ended:",?31,$P(SRAO(5),"^") - W !," 6. Preoperative Risk Factors: " - I $P(SRAO(6),"^")'="" S SRQ=0 S X=$P(SRAO(6),"^") W:$L(X)<49 X,! I $L(X)>48 S Z=$L(X) D - .I X'[" " W ?25,X Q - .S I=0,LINE=1 F S SRL=$S(LINE=1:48,1:80) D Q:SRQ - ..I $E(X,1,SRL)'[" " W X,! S SRQ=1 Q - ..S J=SRL-I,Y=$E(X,J),I=I+1 I Y=" " W $E(X,1,J-1),! S X=$E(X,J+1,Z),Z=$L(X),I=0,LINE=LINE+1 I Z7)!(Y>Z) D HELP G:SRSOUT END G START - I X'=7 D HDR^SROAUTL - I X?.N1":".N D RANGE S SROERR=SRTN D ^SROERR0 G START - I $D(SRAO(X))!(X=6) S EMILY=X D S SROERR=SRTN D ^SROERR0 G START - .I $$LOCK^SROUTL(SRTN) W !! D ONE,UNLOCK^SROUTL(SRTN) -END I '$D(SREQST) W @IOF D ^SRSKILL - Q -DT I 'Y S X="" Q - X ^DD("DD") S X=$P(Y,"@")_" "_$P(Y,"@",2) - Q -HELP W @IOF,!!!!,"Enter the number or range of numbers you want to edit. Examples of proper",!,"responses are listed below." - W !!,"1. Enter 'A' to update all information.",!!,"2. Enter the corresponding number to update the information in a particular",!," field. (For example, enter '3' to update Surgical Priority)" - W !!,"3. Enter two numbers separated by a ':' to enter a range of information.",!," (For example, enter '1:2' to update Physician's Preoperative Estimate of",!," Mortality and ASA Classification.)" - W !!,"Press ENTER to continue, or '^' to quit " R X:DTIME I '$T!(X["^") S SRSOUT=1 - Q -RANGE ; range of numbers - I $$LOCK^SROUTL(SRTN) D D UNLOCK^SROUTL(SRTN) - .W !! S SHEMP=$P(X,":"),CURLEY=$P(X,":",2) F EMILY=SHEMP:1:CURLEY Q:SRSOUT D ONE - Q -ONE ; edit one item - I EMILY=7 D DISP^SROAUTL0 Q - K DR,DIE S DA=SRTN,DIE=130,DR=$P(SRAO(EMILY),"^",2) - S DR=DR_"T",DIE=130 S DR=DR_$S(EMILY=3:";414.1T",1:"") D ^DIE K DR I $D(Y) S SRSOUT=1 - I EMILY=1 D - .I $P(^SRF(SRTN,206),"^",31)="NS" S $P(^SRF(SRTN,206),"^",32)="NS" Q - .S DR="364.1T",DIE=130 D ^DIE K DR I $D(Y) S SRSOUT=1 - Q -RET Q:SRSOUT W !!,"Press ENTER to continue, or '^' to quit " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q - Q -NOW ; update date/time of estimate of mortality - N X D NOW^%DTC S $P(^SRF(DA,206),"^",32)=$E(%,1,12) - Q -KNOW ; delete date/time of estimate of mortality - S $P(^SRF(DA,206),"^",32)="" - Q -YN ; store answer - S SHEMP=$S(NYUK="NS":"Unknown",NYUK="N":"NO",NYUK="Y":"YES",1:"") - Q -CHCK ;compare dates - N SRINO,SRSP,SREM - S SRSP=$P($G(^SRF(SRTN,208)),"^",13),SRINO=$P($G(^SRF(SRTN,.2)),"^",10),SREM=$P($G(^SRF(SRTN,206)),"^",32) - I SRSP'="",SRINO'="",SRSP' to continue " R X:DTIME G END + N SRCSTAT S SRACLR=0,SRSOUT=0,SRSUPCPT=1 D ^SROAUTL +START D:SRACLR RET G:SRSOUT END S SRACLR=0 K SRA,SRAO + F I=206,206.1,208 S SRA(I)=$G(^SRF(SRTN,I)) + I $P(SRA(206),"^",41)="" K DA,DIE,DR S DA=SRTN,DIE=130,DR="472////N" D ^DIE K DA,DIE,DR S SRA(206)=$G(^SRF(SRTN,206)) + S Y=$P($G(^SRF(SRTN,1.1)),"^",3),C=$P(^DD(130,1.13,0),"^",2) D:Y'="" Y^DIQ S SRAO(2)=Y_"^1.13" + S SRAO(1)=$P(SRA(206),"^",31)_"^364",SRAO(3)=$P(SRA(208),"^",12)_"^414" + S Y=$P(SRA(206),"^",32) D DT S SRAO("1A")=X_"^364.1" + S Y=$P(SRAO(3),"^") I Y'="" S C=$P(^DD(130,414,0),"^",2) D Y^DIQ S $P(SRAO(3),"^")=Y + S Y=$P(SRA(208),"^",13) D DT S SRAO("3A")=X_"^414.1" + S Y=$P($G(^SRF(SRTN,.2)),"^",2) D DT S SRAO(4)=X_"^.22" + S Y=$P($G(^SRF(SRTN,.2)),"^",3) D DT S SRAO(5)=X_"^.23" + S SRAO(6)=SRA(206.1)_"^430" + S SRCSTAT=">> Coding "_$S($P($G(^SRO(136,SRTN,10)),"^"):"",1:"Not ")_"Complete <<" + S SRPAGE="PAGE: 1" D HDR^SROAUTL S SRAO(7)="" + S X=$P(SRAO(1),"^"),X=$S(X?1.3N:X_"%",1:X) W !," 1. Physician's Preoperative Estimate of Operative Mortality: "_X + S X=$P(SRAO("1A"),"^") I X'="" W !,?3," A. Date/Time Collected: "_X + W !," 2. ASA Classification:",?31,$P(SRAO(2),"^"),!," 3. Surgical Priority:",?31,$P(SRAO(3),"^") + S X=$P(SRAO("3A"),"^") I X'="" W !,?3," A. Date/Time Collected: "_X + W !," 4. Date/Time Operation Began:",?31,$P(SRAO(4),"^"),!," 5. Date/Time Operation Ended:",?31,$P(SRAO(5),"^") + W !," 6. Preoperative Risk Factors: " + I $P(SRAO(6),"^")'="" S SRQ=0 S X=$P(SRAO(6),"^") W:$L(X)<49 X,! I $L(X)>48 S Z=$L(X) D + .I X'[" " W ?25,X Q + .S I=0,LINE=1 F S SRL=$S(LINE=1:48,1:80) D Q:SRQ + ..I $E(X,1,SRL)'[" " W X,! S SRQ=1 Q + ..S J=SRL-I,Y=$E(X,J),I=I+1 I Y=" " W $E(X,1,J-1),! S X=$E(X,J+1,Z),Z=$L(X),I=0,LINE=LINE+1 I Z7)!(Y>Z) D HELP G:SRSOUT END G START + I X'=7 D HDR^SROAUTL + I X?.N1":".N D RANGE S SROERR=SRTN D ^SROERR0 G START + I $D(SRAO(X))!(X=6) S EMILY=X D S SROERR=SRTN D ^SROERR0 G START + .I $$LOCK^SROUTL(SRTN) W !! D ONE,UNLOCK^SROUTL(SRTN) +END I '$D(SREQST) W @IOF D ^SRSKILL + Q +DT I 'Y S X="" Q + X ^DD("DD") S X=$P(Y,"@")_" "_$P(Y,"@",2) + Q +HELP W @IOF,!!!!,"Enter the number or range of numbers you want to edit. Examples of proper",!,"responses are listed below." + W !!,"1. Enter 'A' to update all information.",!!,"2. Enter the corresponding number to update the information in a particular",!," field. (For example, enter '3' to update Surgical Priority)" + W !!,"3. Enter two numbers separated by a ':' to enter a range of information.",!," (For example, enter '1:2' to update Physician's Preoperative Estimate of",!," Mortality and ASA Classification.)" + W !!,"Press ENTER to continue, or '^' to quit " R X:DTIME I '$T!(X["^") S SRSOUT=1 + Q +RANGE ; range of numbers + I $$LOCK^SROUTL(SRTN) D D UNLOCK^SROUTL(SRTN) + .W !! S SHEMP=$P(X,":"),CURLEY=$P(X,":",2) F EMILY=SHEMP:1:CURLEY Q:SRSOUT D ONE + Q +ONE ; edit one item + I EMILY=7 D DISP^SROAUTL0 Q + K DR,DIE S DA=SRTN,DIE=130,DR=$P(SRAO(EMILY),"^",2) + S DR=DR_"T",DIE=130 S DR=DR_$S(EMILY=1:";364.1T",EMILY=3:";414.1T",1:"") D ^DIE K DR I $D(Y) S SRSOUT=1 + Q +RET Q:SRSOUT W !!,"Press ENTER to continue, or '^' to quit " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q + Q +NOW ; update date/time of estimate of mortality + N X D NOW^%DTC S $P(^SRF(DA,206),"^",32)=$E(%,1,12) + Q +KNOW ; delete date/time of estimate of mortality + S $P(^SRF(DA,206),"^",32)="" + Q +YN ; store answer + S SHEMP=$S(NYUK="NS":"Unknown",NYUK="N":"NO",NYUK="Y":"YES",1:"") + Q +CHCK ;compare dates + N SRINO,SRSP,SREM + S SRSP=$P($G(^SRF(SRTN,208)),"^",13),SRINO=$P($G(^SRF(SRTN,.2)),"^",10),SREM=$P($G(^SRF(SRTN,206)),"^",32) + I SRSP'="",SRINO'="",SRSP' to continue " R X:DTIME G END - S SRSOUT=0,SRSUPCPT=1 D ^SROAUTL -START G:SRSOUT END D HDR^SROAUTL - S DIR("A",1)="Enter/Edit Patient Resource Data",DIR("A",2)=" ",DIR("A",3)="1. Capture Information from PIMS Records",DIR("A",4)="2. Enter, Edit, or Review Information",DIR("A",5)=" " - S DIR("?",1)="Enter '1' if you want to capture patient information from PIMS",DIR("?",2)="records. Enter '2' if you want to enter, edit, or review patient",DIR("?")="other information on this screen." - S DIR("A")="Select Number",DIR(0)="NO^1:2" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT)!'Y S SRSOUT=1 G END - I Y=1 D PIMS G START -EDIT N DAYS,HOURS,MINS - S:$P(^SRF(SRTN,206),"^",41)="" $P(^SRF(SRTN,206),"^",41)="N" - S SRR=0 S SRPAGE="PAGE: 1" D HDR^SROAUTL K DR S SRQ=0,(DR,SRDR)="418;419;440;.205;.232;470;471;473;472;431;442;513;515" - K DA,DIC,DIQ,SRY S DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="IE",DR=SRDR D EN^DIQ1 K DA,DIC,DIQ,DR - K SRZ S SRZ=0 F M=1:1 S I=$P(SRDR,";",M) Q:'I D - .D TR,GET - .S SRZ=SRZ+1,Y=$P(X,";;",2),SRFLD=$P(Y,"^"),(Z,SRZ(SRZ))=$P(Y,"^",2)_"^"_SRFLD,SREXT=SRY(130,SRTN,SRFLD,"E") - .W:M>1 ! W $J(SRZ,2)_". "_$P(Z,"^")_": " D EXT - D CHCK W ! F K=1:1:80 W "-" - D SEL G:SRR=1 EDIT - G START - Q -CHCK ; compare admission and discharge dates to each other - N SRADM,SRDIS,SROUT,SRDICU,SREXT - S SROUT=SRY(130,SRTN,.232,"I"),SRDICU=SRY(130,SRTN,471,"I"),SREXT=SRY(130,SRTN,470,"I") - S SRADM=SRY(130,SRTN,418,"I"),SRDIS=SRY(130,SRTN,419,"I") W ! - I SRADM,SRDIS,SRADM'SROUT W !,"*** NOTE: D/Time Pt Extubated should be later than the D/Time Pt Out of OR. ***" - I SREXT,SRDICU,SREXT'SREXT W !,"*** NOTE: D/Time Discharged from ICU should be > the Extubation D/Time. ***" - I SRDICU,SRDIS,SRDICU>SRDIS W !,"*** NOTE: D/Time Discharged from ICU should be <= the Hospital Discharge D/Time*" - Q -EXT I SRFLD=440&(SREXT="NS") S SREXT=SREXT_"-"_$S(SREXT="NS":"No Study",1:SREXT) - I SRFLD=470,(SREXT="NS"!(SREXT="RI")) S SREXT=SREXT_"-"_$S(SREXT="NS":"Unable to determine",SREXT="RI":"Remains intubated at 30 days",1:SREXT) - I SRFLD=470,$G(SRY(130,SRTN,470,"I")) D Q - .S X=$$FMDIFF^XLFDT(SRY(130,SRTN,470,"I"),SRY(130,SRTN,.232,"I"),2) W ?39,SREXT,!,?10,"Postop Intubation Hrs: "_$FN((X/3600),"+",1) - I SRFLD=471,(SREXT="NS"!(SREXT="RI")) S SREXT=SREXT_"-"_$S(SREXT="NS":"Unable to determine",SREXT="RI":"Remains in ICU at 30 days",1:SREXT) - I $L(SREXT)<41 W ?39,SREXT W:SRFLD=247 $S(SREXT="":"",SREXT=1:" Day",SREXT=0:" Days",SREXT>1:" Days",1:"") Q - I SRFLD=431 D - .I $L(SREXT)<52 W ?28,SREXT Q - .N I,J,X,Y S X=SREXT F D W:$L(X) ! I $L(X)<52!($L(X)>51&(X'[" ")) W ?28,X Q - ..F I=0:1:50 S J=51-I,Y=$E(X,J) I Y=" " W ?28,$E(X,1,J-1) S X=$E(X,J+1,$L(X)) Q - Q -SEL S SRSOUT=0 W !!,"Select Resource Information to Edit: " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q - Q:X="" S:X="a" X="A" I '$D(SRFLG),'$D(SRZ(X)),(X'?1.2N1":"1.2N),X'="A" D HELP S SRR=1 Q - I X?1.2N1":"1.2N S Y=$P(X,":"),Z=$P(X,":",2) I Y<1!(Z>SRZ)!(Y>Z) D HELP S SRR=1 Q - I X="A" S X="1:"_SRZ - I X?1.2N1":"1.2N D RANGE S SRR=1 Q - I $D(SRZ(X)),+X=X S EMILY=X D S SRR=1 - .I $$LOCK^SROUTL(SRTN) D ONE,UNLOCK^SROUTL(SRTN) - Q -PIMS ; get update from PIMS records - W ! K DIR S DIR("A")="Are you sure you want to retrieve information from PIMS records ? ",DIR("B")="YES",DIR(0)="YOA" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT)!'Y Q - W ! D WAIT^DICD D ^SROAPIMS - Q -HELP W @IOF,!!!!,"Enter the number or range of numbers you want to edit. Examples of proper",!,"responses are listed below." - W !!,"1. Enter 'A' to update all items.",!!,"2. Enter a number (1-"_SRZ_") to update an individual item. (For example,",!," enter '1' to update "_$P(SRZ(1),"^")_".)" - W !!,"3. Enter a range of numbers (1-"_SRZ_") separated by a ':' to enter a range",!," of items. (For example, enter '1:4' to update items 1, 2, 3 and 4.)",! - I $D(SRFLG) W !,"4. Enter 'N' or 'NO' to enter negative response for all items.",!!,"5. Enter '@' to delete information from all items.",! -PRESS W ! K DIR S DIR("A")="Press the return key to continue or '^' to exit: ",DIR(0)="FOA" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 - Q -RANGE ; range of numbers - I $$LOCK^SROUTL(SRTN) D D UNLOCK^SROUTL(SRTN) - .S SHEMP=$P(X,":"),CURLEY=$P(X,":",2) F EMILY=SHEMP:1:CURLEY Q:SRSOUT D ONE - Q -ONE ; edit one item - I EMILY=7 D LIST - I EMILY'=7 K DR,DA,DIE S DR=$P(SRZ(EMILY),"^",2)_"T",DA=SRTN,DIE=130,SRDT=$P(SRZ(EMILY),"^",3) S:SRDT DR=DR_";"_SRDT_"T" D ^DIE K DR,DA I $D(Y) S SRSOUT=1 - I 'SRSOUT,EMILY=1!(EMILY=2) D OK - I EMILY=12 D CHK - Q -OK ; compare admission date to discharge date - N SRADM,SRDIS S X=$G(^SRF(SRTN,208)),SRADM=$P(X,"^",14),SRDIS=$P(X,"^",15) - I SRADM,SRDIS,SRADM'30 S $P(^SRF(SRTN,209),"^",16)="N" Q - S $P(^SRF(SRTN,209),"^",16)="" K DR,DA,DIE S DR=$P(SRZ(13),"^",2)_"T",DA=SRTN,DIE=130,SRDT=$P(SRZ(13),"^",3) S:SRDT DR=DR_";"_SRDT_"T" D ^DIE K DR,DA I $D(Y) S SRSOUT=1 - Q -LIST ; display list of patient movements - N CNT,SRADM,SRLOC,SRMOVE,SRMVMT,SRN,SRT,SRTYPE,SRZ,SRY - S DFN=$P(^SRF(SRTN,0),"^"),SRZ=$P($G(^SRF(SRTN,.2)),"^",12) - S SRADM=0 D ADM - S CNT=0 F Q:'SRZ D:SRZ MVMT - ;Q:CNT=0 - W !!,?5,"To identify the date and time the patient was discharged from intensive",!,?5,"care following surgery, see the following list of patient movements" - W !,?5,"that occurred during the inpatient stay associated with this surgery.",! - S (CNT,SRN)=0 F S CNT=$O(SRMVMT(CNT)) Q:'CNT S X=SRMVMT(CNT),SRT=$P(X,"^",2),SRN=SRN+1 W !,$J(SRN,3)_".",?5,$P($P(X,"^"),":",1,2),?25,$P(X,"^",3),?37,$S(SRT=3:"From",1:"To")_": "_$P(X,"^",4) - I '$O(SRMVMT(0)) W !,?5,">> No postoperative patient movements were found for this patient." - W ! E K DIR S DIR("A")="Select patient movement from list",DIR(0)="NO^1:"_SRN_":0" D ^DIR K DIR I Y D Q - .S SRT=$P($P(SRMVMT(Y),"^"),":",1,2) K DA,DIE,DR S DA=SRTN,DIE=130,DR="471///"_SRT D ^DIE K DA,DIE,DR - K DA,DIE,DR S DA=SRTN,DIE=130,DR="471T" D ^DIE K DA,DIE,DR - Q -MVMT S VAIP("D")=SRZ D IN5^VADPT S SRY=$P(VAIP(3),"^") - I SRY S CNT=CNT+1 D - .S SRMOVE=$P(VAIP(3),"^",2),SRTYPE=$P(VAIP(2),"^",1,2),SRLOC=$P(VAIP(5),"^",2) - .S SRMVMT(CNT)=SRMOVE_"^"_SRTYPE_"^"_SRLOC - I 'SRY S SRZ="" Q - I VAIP(1)=VAIP(17) S SRZ="" Q - I VAIP(16),VAIP(16)=VAIP(17) S CNT=CNT+1,SRMOVE=$P(VAIP(16,1),"^",2),SRTYPE=$P(VAIP(16,2),"^",1,2),SRLOC=$P(VAIP(16,4),"^",2),SRMVMT(CNT)=SRMOVE_"^"_SRTYPE_"^"_SRLOC,SRZ="" Q - S SRZ=$P(VAIP(16,1),"^") - Q -ADM N SR24 S VAIP("D")=SRZ D IN5^VADPT - I 'VAIP(13) S X1=SRZ,X2=1 D C^%DTC S SR24=X,SRDT=$O(^DGPM("APTT1",DFN,SRZ)) Q:'SRDT!(SRDT>SR24) S VAIP("D")=SRDT D IN5^VADPT I 'VAIP(13) S SRZ="" Q - I VAIP(13) S SRZ=$P(VAIP(13,1),"^")+.000001 - Q -TR S J=I,J=$TR(J,"1234567890.","ABCDEFGHIJP") - Q -GET S X=$T(@J) - Q -END W @IOF D ^SRSKILL - Q -DAH ;;418^Hospital Admission Date -DAI ;;419^Hospital Discharge Date -DDJ ;;440^Cardiac Catheterization Date -PBJE ;;.205^Time Patient In OR -PBCB ;;.232^Time Patient Out OR -DGJ ;;470^Date/Time Patient Extubated -DGA ;;471^Date/Time Discharged from ICU -DDB ;;442^Employment Status Preoperatively -DCA ;;431^Resource Data Comments -DGC ;;473^Homeless -DGB ;;472^Surg Performed at Non-VA Facility -EAC ;;513^CT Surgery Consult Date -EAE ;;515^Cause for Delay for Surgery +SROACPM ;BIR/ADM - CARDIAC RESOURCE INFO ;08/23/07 + ;;3.0; Surgery ;**71,93,95,99,100,125,142,160,164**;24 Jun 93;Build 2 + ; + ; Reference to ^DGPM("APTT1" supported by DBIA #565 + ; + I '$D(SRTN) W !!,"A Surgery Risk Assessment must be selected prior to using this option.",!!,"Press to continue " R X:DTIME G END + S SRSOUT=0,SRSUPCPT=1 D ^SROAUTL +START G:SRSOUT END D HDR^SROAUTL + S DIR("A",1)="Enter/Edit Patient Resource Data",DIR("A",2)=" ",DIR("A",3)="1. Capture Information from PIMS Records",DIR("A",4)="2. Enter, Edit, or Review Information",DIR("A",5)=" " + S DIR("?",1)="Enter '1' if you want to capture patient information from PIMS",DIR("?",2)="records. Enter '2' if you want to enter, edit, or review patient",DIR("?")="other information on this screen." + S DIR("A")="Select Number",DIR(0)="NO^1:2" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT)!'Y S SRSOUT=1 G END + I Y=1 D PIMS G START +EDIT S:$P(^SRF(SRTN,206),"^",41)="" $P(^SRF(SRTN,206),"^",41)="N" + S SRR=0 S SRPAGE="PAGE: 1" D HDR^SROAUTL K DR S SRQ=0,(DR,SRDR)="418;419;440;.205;.232;470;471;473;472;431;442;513" + K DA,DIC,DIQ,SRY S DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="IE",DR=SRDR D EN^DIQ1 K DA,DIC,DIQ,DR + K SRZ S SRZ=0 F M=1:1 S I=$P(SRDR,";",M) Q:'I D + .D TR,GET + .S SRZ=SRZ+1,Y=$P(X,";;",2),SRFLD=$P(Y,"^"),(Z,SRZ(SRZ))=$P(Y,"^",2)_"^"_SRFLD,SREXT=SRY(130,SRTN,SRFLD,"E") + .W:M>1 ! W $J(SRZ,2)_". "_$P(Z,"^")_": " D EXT + D CHCK W ! F K=1:1:80 W "-" + D SEL G:SRR=1 EDIT + G START + Q +CHCK ; compare admission and discharge dates to each other + N SRADM,SRDIS,SROUT,SRDICU,SREXT + S SROUT=SRY(130,SRTN,.232,"I"),SRDICU=SRY(130,SRTN,471,"I"),SREXT=SRY(130,SRTN,470,"I") + S SRADM=SRY(130,SRTN,418,"I"),SRDIS=SRY(130,SRTN,419,"I") W ! + I SRADM,SRDIS,SRADM'SROUT W !,"*** NOTE: D/Time Pt Extubated should be later than the D/Time Pt Out of OR. ***" + I SREXT,SRDICU,SREXT'SREXT W !,"*** NOTE: D/Time Discharged from ICU should be > the Extubation D/Time. ***" + I SRDICU,SRDIS,SRDICU>SRDIS W !,"*** NOTE: D/Time Discharged from ICU should be <= the Hospital Discharge D/Time*" + Q +EXT I SRFLD=440&(SREXT="NS") S SREXT=SREXT_"-"_$S(SREXT="NS":"No Study",1:SREXT) + I SRFLD=470,(SREXT="NS"!(SREXT="RI")) S SREXT=SREXT_"-"_$S(SREXT="NS":"Unable to determine",SREXT="RI":"Remains intubated at 30 days",1:SREXT) + I SRFLD=471,(SREXT="NS"!(SREXT="RI")) S SREXT=SREXT_"-"_$S(SREXT="NS":"Unable to determine",SREXT="RI":"Remains in ICU at 30 days",1:SREXT) + I $L(SREXT)<41 W ?39,SREXT W:SRFLD=247 $S(SREXT="":"",SREXT=1:" Day",SREXT=0:" Days",SREXT>1:" Days",1:"") Q + I SRFLD=431 D + .I $L(SREXT)<52 W ?28,SREXT Q + .N I,J,X,Y S X=SREXT F D W:$L(X) ! I $L(X)<52!($L(X)>51&(X'[" ")) W ?28,X Q + ..F I=0:1:50 S J=51-I,Y=$E(X,J) I Y=" " W ?28,$E(X,1,J-1) S X=$E(X,J+1,$L(X)) Q + Q +SEL S SRSOUT=0 W !!,"Select number of item to edit: " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q + Q:X="" S:X="a" X="A" I '$D(SRFLG),'$D(SRZ(X)),(X'?1.2N1":"1.2N),X'="A" D HELP S SRR=1 Q + I X?1.2N1":"1.2N S Y=$P(X,":"),Z=$P(X,":",2) I Y<1!(Z>SRZ)!(Y>Z) D HELP S SRR=1 Q + I X="A" S X="1:"_SRZ + I X?1.2N1":"1.2N D RANGE S SRR=1 Q + I $D(SRZ(X)),+X=X S EMILY=X D S SRR=1 + .I $$LOCK^SROUTL(SRTN) D ONE,UNLOCK^SROUTL(SRTN) + Q +PIMS ; get update from PIMS records + W ! K DIR S DIR("A")="Are you sure you want to retrieve information from PIMS records ? ",DIR("B")="YES",DIR(0)="YOA" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT)!'Y Q + W ! D WAIT^DICD D ^SROAPIMS + Q +HELP W @IOF,!!!!,"Enter the number or range of numbers you want to edit. Examples of proper",!,"responses are listed below." + W !!,"1. Enter 'A' to update all items.",!!,"2. Enter a number (1-"_SRZ_") to update an individual item. (For example,",!," enter '1' to update "_$P(SRZ(1),"^")_".)" + W !!,"3. Enter a range of numbers (1-"_SRZ_") separated by a ':' to enter a range",!," of items. (For example, enter '1:4' to update items 1, 2, 3 and 4.)",! + I $D(SRFLG) W !,"4. Enter 'N' or 'NO' to enter negative response for all items.",!!,"5. Enter '@' to delete information from all items.",! +PRESS W ! K DIR S DIR("A")="Press the return key to continue or '^' to exit: ",DIR(0)="FOA" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 + Q +RANGE ; range of numbers + I $$LOCK^SROUTL(SRTN) D D UNLOCK^SROUTL(SRTN) + .S SHEMP=$P(X,":"),CURLEY=$P(X,":",2) F EMILY=SHEMP:1:CURLEY Q:SRSOUT D ONE + Q +ONE ; edit one item + I EMILY=7 D LIST + K DR,DA,DIE S DR=$P(SRZ(EMILY),"^",2)_"T",DA=SRTN,DIE=130,SRDT=$P(SRZ(EMILY),"^",3) S:SRDT DR=DR_";"_SRDT_"T" D ^DIE K DR,DA I $D(Y) S SRSOUT=1 + I 'SRSOUT,EMILY=1!(EMILY=2) D OK + Q +OK ; compare admission date to discharge date + N SRADM,SRDIS S X=$G(^SRF(SRTN,208)),SRADM=$P(X,"^",14),SRDIS=$P(X,"^",15) + I SRADM,SRDIS,SRADM'SR24) S VAIP("D")=SRDT D IN5^VADPT I 'VAIP(13) S SRZ="" Q + I VAIP(13) S SRZ=$P(VAIP(13,1),"^")+.000001 + Q +TR S J=I,J=$TR(J,"1234567890.","ABCDEFGHIJP") + Q +GET S X=$T(@J) + Q +END W @IOF D ^SRSKILL + Q +DAH ;;418^Hospital Admission Date +DAI ;;419^Hospital Discharge Date +DDJ ;;440^Cardiac Catheterization Date +PBJE ;;.205^Time Patient In OR +PBCB ;;.232^Time Patient Out OR +DGJ ;;470^Date/Time Patient Extubated +DGA ;;471^Date/Time Discharged from ICU +DDB ;;442^Employment Status Preoperatively +DCA ;;431^Resource Data Comments +DGC ;;473^Homeless +DGB ;;472^Surg Performed at Non-VA Facility +EAC ;;513^CT Surgery Consult Date diff --git a/r/SURGERY-SR/SROACPM1.m b/r/SURGERY-SR/SROACPM1.m index 9e7d5802..54009b95 100644 --- a/r/SURGERY-SR/SROACPM1.m +++ b/r/SURGERY-SR/SROACPM1.m @@ -1,54 +1,47 @@ -SROACPM1 ;BIR/SJA - LAB INFO ;01/14/08 - ;;3.0; Surgery ;**125,153,166**;24 Jun 93;Build 7 - I '$D(SRTN) W !!,"A Surgery Risk Assessment must be selected prior to using this option.",!!,"Press to continue " R X:DTIME G END - S SRSOUT=0 D ^SROAUTL -START G:SRSOUT END K SRA,SRAO D ^SROACPM2,DISP -ASK W !!,"Select Laboratory Information to Edit: " R X:DTIME I '$T!(X["^") S SRSOUT=1 D CONCC G END - I X="" D CONCC G END - S:X="a" X="A" I '$D(SRAO(X)),(X'?.N1":".N),(X'="A") D HELP G:SRSOUT END G START - I X="A" S X="1:10" - I X?.N1":".N S Y=$E(X),Z=$P(X,":",2) I Y<1!(Z>10)!(Y>Z) D HELP G:SRSOUT END G START - S SRPAGE="" D HDR^SROAUTL - I X?.N1":".N D RANGE G START - I $D(SRAO(X)) S EMILY=X D ONE G START -END W @IOF - Q -HELP W @IOF,!!!!,"Enter the number or range of numbers you want to edit. Examples of proper",!,"responses are listed below." - W !!,"1. Enter 'A' to update all information.",!!,"2. Enter a number (1-10) to update the information in that field. (For",!," example, enter '7' to update Serum Creatinine)" - W !!,"3. Enter a range of numbers (1-10) separated by a ':' to enter a range of",!," information. (For example, enter '5:7' to update Serum Potassium,",!," Serum Bilirubin, and Serum Creatinine)" - W !!,"Press to continue, or '^' to quit " R X:DTIME I '$T!(X["^") S SRSOUT=1 - Q -RANGE ; range of numbers - S SRNOMORE=0,SHEMP=$P(X,":"),CURLEY=$P(X,":",2) F EMILY=SHEMP:1:CURLEY Q:SRNOMORE D ONE - Q -ONE ; edit one item - K DR,DIE S DA=SRTN,DR=$P(SRAO(EMILY),"^",3)_"T;"_$P(SRAO(EMILY),"^",4)_"T",DIE=130 D ^DIE S:$D(Y) SRNOMORE=1 K DR - Q -RET Q:SRSOUT W !!,"Press to continue, or '^' to quit " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q - Q -DISP N SRX S SRPAGE="PAGE: 1",SRHDR(.5)="PREOPERATIVE LABORATORY RESULTS" D HDR^SROAUTL - S SRX=$P(SRAO(1),"^") W !," 1. HDL:",?25,$J(SRX,6),?35,$$NORCHK(21,SRX),?38,$P(SRAO(1),"^",2) - S SRX=$P(SRAO(2),"^") W !," 2. LDL:",?25,$J(SRX,6),?35,$$NORCHK(23,SRX),?38,$P(SRAO(2),"^",2) - S SRX=$P(SRAO(3),"^") W !," 3. Total Cholesterol:",?25,$J(SRX,6),?35,$$NORCHK(24,SRX),?38,$P(SRAO(3),"^",2) - S SRX=$P(SRAO(4),"^") W !," 4. Serum Triglyceride:",?25,$J(SRX,6),?35,$$NORCHK(22,SRX),?38,$P(SRAO(4),"^",2) - S SRX=$P(SRAO(5),"^") W !," 5. Serum Potassium:",?25,$J(SRX,6),?35,$$NORCHK(5,SRX),?38,$P(SRAO(5),"^",2) - S SRX=$P(SRAO(6),"^") W !," 6. Serum Bilirubin:",?25,$J(SRX,6),?35,$$NORCHK(14,SRX),?38,$P(SRAO(6),"^",2) - S SRX=$P(SRAO(7),"^") W !," 7. Serum Creatinine:",?25,$J(SRX,6),?35,$$NORCHK(7,SRX),?38,$P(SRAO(7),"^",2) - S SRX=$P(SRAO(8),"^") W !," 8. Serum Albumin:",?25,$J(SRX,6),?35,$$NORCHK(11,SRX),?38,$P(SRAO(8),"^",2) - S SRX=$P(SRAO(9),"^") W !," 9. Hemoglobin:",?25,$J(SRX,6),?35,$$NORCHK(1,SRX),?38,$P(SRAO(9),"^",2) - S SRX=$P(SRAO(10),"^") W !,"10. Hemoglobin A1c:",?25,$J(SRX,6),?35,$$NORCHK(27,SRX),?38,$P(SRAO(10),"^",2) - W !! F MOE=1:1:80 W "-" - Q -CONCC ; check for concurrent case and update if one exists - S SRCON=$P($G(^SRF(SRTN,"CON")),"^") Q:'SRCON - S SRI="" F S SRI=$O(SRAO(SRI)) Q:SRI="" S S1=$P(SRAO(SRI),"^",3),S2=$P(SRAO(SRI),"^",4) K DA,DIC,DIQ,DR,SRY D - .S DA=SRTN,DR=S1_";"_S2,DIC="^SRF(",DIQ="SRY",DIQ(0)="I" D EN^DIQ1 S P1=SRY(130,SRTN,S1,"I") S:P1="" P1="@" S P2=SRY(130,SRTN,S2,"I") S:P2="" P2="@" - .K DA,DIE,DR S DA=SRCON,DIE=130,DR=S1_"////"_P1_";"_S2_"////"_P2 D ^DIE K DR - Q -NORCHK(SRAT,RESULT) ; - I RESULT']""!(RESULT="NS") Q "" - N NODE,LOW,HIGH,SRY - S SRY="" S:"<>"[$E(RESULT) SRY=$E(RESULT),RESULT=$E(RESULT,2,99) - S NODE=$G(^SRO(139.2,SRAT,2)),LOW=$P(NODE,"^",2),HIGH=$P(NODE,"^",3) Q:LOW']""!(HIGH']"") - I SRY'="" Q $S(RESULT<(LOW+.01):"L",((RESULT>(HIGH-.01))&(SRY=">")):"H",1:"") - Q $S(RESULTHIGH:"H",1:"") +SROACPM1 ;BIR/SJA - LAB INFO ;05/04/06 + ;;3.0; Surgery ;**125,153**;24 Jun 93;Build 11 + I '$D(SRTN) W !!,"A Surgery Risk Assessment must be selected prior to using this option.",!!,"Press to continue " R X:DTIME G END + S SRSOUT=0 D ^SROAUTL +START G:SRSOUT END K SRA,SRAO D ^SROACPM2,DISP +ASK W !!,"Select Laboratory Information to Edit: " R X:DTIME I '$T!(X["^") S SRSOUT=1 D CONCC G END + I X="" D CONCC G END + S:X="a" X="A" I '$D(SRAO(X)),(X'?.N1":".N),(X'="A") D HELP G:SRSOUT END G START + I X="A" S X="1:10" + I X?.N1":".N S Y=$E(X),Z=$P(X,":",2) I Y<1!(Z>10)!(Y>Z) D HELP G:SRSOUT END G START + S SRPAGE="" D HDR^SROAUTL + I X?.N1":".N D RANGE G START + I $D(SRAO(X)) S EMILY=X D ONE G START +END W @IOF + Q +HELP W @IOF,!!!!,"Enter the number or range of numbers you want to edit. Examples of proper",!,"responses are listed below." + W !!,"1. Enter 'A' to update all information.",!!,"2. Enter a number (1-10) to update the information in that field. (For",!," example, enter '7' to update Serum Creatinine)" + W !!,"3. Enter a range of numbers (1-10) separated by a ':' to enter a range of",!," information. (For example, enter '5:7' to update Serum Potassium,",!," Serum Bilirubin, and Serum Creatinine)" + W !!,"Press to continue, or '^' to quit " R X:DTIME I '$T!(X["^") S SRSOUT=1 + Q +RANGE ; range of numbers + S SRNOMORE=0,SHEMP=$P(X,":"),CURLEY=$P(X,":",2) F EMILY=SHEMP:1:CURLEY Q:SRNOMORE D ONE + Q +ONE ; edit one item + K DR,DIE S DA=SRTN,DR=$P(SRAO(EMILY),"^",3)_"T;"_$P(SRAO(EMILY),"^",4)_"T",DIE=130 D ^DIE S:$D(Y) SRNOMORE=1 K DR + Q +RET Q:SRSOUT W !!,"Press to continue, or '^' to quit " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q + Q +DISP S SRPAGE="PAGE: 1",SRHDR(.5)="PREOPERATIVE LABORATORY RESULTS" D HDR^SROAUTL + W !," 1. HDL:",?25,$J($P(SRAO(1),"^"),6),?35,$P(SRAO(1),"^",2) + W !," 2. LDL:",?25,$J($P(SRAO(2),"^"),6),?35,$P(SRAO(2),"^",2) + W !," 3. Total Cholesterol:",?25,$J($P(SRAO(3),"^"),6),?35,$P(SRAO(3),"^",2) + W !," 4. Serum Triglyceride:",?25,$J($P(SRAO(4),"^"),6),?35,$P(SRAO(4),"^",2) + W !," 5. Serum Potassium:",?25,$J($P(SRAO(5),"^"),6),?35,$P(SRAO(5),"^",2) + W !," 6. Serum Bilirubin:",?25,$J($P(SRAO(6),"^"),6),?35,$P(SRAO(6),"^",2) + W !," 7. Serum Creatinine:",?25,$J($P(SRAO(7),"^"),6),?35,$P(SRAO(7),"^",2) + W !," 8. Serum Albumin:",?25,$J($P(SRAO(8),"^"),6),?35,$P(SRAO(8),"^",2) + W !," 9. Hemoglobin:",?25,$J($P(SRAO(9),"^"),6),?35,$P(SRAO(9),"^",2) + W !,"10. Hemoglobin A1c:",?25,$J($P(SRAO(10),"^"),6),?35,$P(SRAO(10),"^",2) + W !! F MOE=1:1:80 W "-" + Q +CONCC ; check for concurrent case and update if one exists + S SRCON=$P($G(^SRF(SRTN,"CON")),"^") Q:'SRCON + S SRI="" F S SRI=$O(SRAO(SRI)) Q:SRI="" S S1=$P(SRAO(SRI),"^",3),S2=$P(SRAO(SRI),"^",4) K DA,DIC,DIQ,DR,SRY D + .S DA=SRTN,DR=S1_";"_S2,DIC="^SRF(",DIQ="SRY",DIQ(0)="I" D EN^DIQ1 S P1=SRY(130,SRTN,S1,"I") S:P1="" P1="@" S P2=SRY(130,SRTN,S2,"I") S:P2="" P2="@" + .K DA,DIE,DR S DA=SRCON,DIE=130,DR=S1_"////"_P1_";"_S2_"////"_P2 D ^DIE K DR + Q diff --git a/r/SURGERY-SR/SROACR2.m b/r/SURGERY-SR/SROACR2.m index 880ed791..ba06cc61 100644 --- a/r/SURGERY-SR/SROACR2.m +++ b/r/SURGERY-SR/SROACR2.m @@ -1,63 +1,63 @@ -SROACR2 ;BIR/SJA - OPERATIVE DATA, PAGE 2 ;12/03/07 - ;;3.0; Surgery ;**125,153,160,166**;24 Jun 93;Build 7 - ; - I '$D(SRTN) W !!,"A Surgery Risk Assessment must be selected prior to using this option.",!!,"Press to continue " R X:DTIME G END - S SRSOUT=0 D ^SROAUTL -START G:SRSOUT END - ; -EDIT S SRR=0 S SRPAGE="PAGE: 2 OF 2" D HDR^SROAUTL W "Indicate other cardiac procedures only if done with cardiopulmonary bypass",! F K=1:1:80 W "-" - ; - K DR S SRQ=0,(DR,SRDR)="381;382;451;450;468;469" - K DA,DIC,DIQ,SRY S DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="IE",DR=SRDR D EN^DIQ1 K DA,DIC,DIQ,DR - K SRX S SRX=0 F M=1:1 S I=$P(SRDR,";",M) Q:'I D - .K SREXT D TR,GET - .S SRX=SRX+1,Y=$P(X,";;",2),SRFLD=$P(Y,"^"),(Z,SRX(SRX))=$P(Y,"^",2)_"^"_SRFLD,SREXT=SRY(130,SRTN,SRFLD,"E") - .I SRFLD=451 W !,"Other Operative Data details:",!,"------------------------------" - .W !,$J(SRX,2)_". "_$P(Z,"^")_":" D EXT - .W:SRFLD=382 ! - D CHCK W ! F K=1:1:80 W "-" - D SEL G:SRR=1 EDIT - S SRSOUT=1 G END - Q -SEL S SRSOUT=0 W !!,"Select Cardiac Procedures Operative Information to Edit: " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q - Q:X="" S:X="a" X="A" I '$D(SRFLG),'$D(SRX(X)),(X'?1.2N1":"1.2N),X'="A" D HELP S SRR=1 Q - I X?1.2N1":"1.2N S Y=$P(X,":"),Z=$P(X,":",2) I Y<1!(Z>SRX)!(Y>Z) D HELP S SRR=1 Q - I X="A" S X="1:"_SRX - I X?1.2N1":"1.2N D RANGE S SRR=1 K SREXT Q - I $D(SRX(X)),+X=X S EMILY=X D S SRR=1 - .I $$LOCK^SROUTL(SRTN) W ! D ONE,UNLOCK^SROUTL(SRTN) - Q -EXT W ?30,SREXT - Q -HELP W @IOF,!!!!,"Enter the number or range of numbers you want to edit. Examples of proper",!,"responses are listed below." - W !!,"1. Enter 'A' to update all information.",!!,"2. Enter a number (1-6) to update the information in that field. (For",!," example, enter '5' to update Incision Type.)" - W !!,"3. Enter a range of numbers (1-6) separated by a ':' to enter a range of",!," information. (For example, enter '3:5' to enter Total CPB time,",!," Total Ischemic time, and Incision Type.)" - D RET - Q -CHCK ; compare ischemic time to CPB time - I '$D(IORVON) S X="IORVON;IORVOFF" D ENDR^%ZISS - N SRISCH,SRCPB S SRISCH=SRY(130,SRTN,450,"E"),SRCPB=SRY(130,SRTN,451,"E") - I SRISCH,SRCPB,SRISCH>SRCPB W !,IORVON_"*** NOTE: Ischemic Time is greater than CPB Time!! Please check. ***"_IORVOFF - Q -RET Q:SRSOUT W ! K DIR S DIR(0)="E" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 - Q -RANGE ; range of numbers - I $$LOCK^SROUTL(SRTN) D D UNLOCK^SROUTL(SRTN) - .W ! S SHEMP=$P(X,":"),CURLEY=$P(X,":",2) F EMILY=SHEMP:1:CURLEY Q:SRSOUT D ONE - Q -ONE ; edit one item - K DR,DA,DIE S DR=$P(SRX(EMILY),"^",2)_"T",DA=SRTN,DIE=130,SRDT=$P(SRX(EMILY),"^",3) S:SRDT DR=DR_";"_SRDT_"T" D ^DIE K DR,DA I $D(Y) S SRSOUT=1 - I EMILY=3,$P($G(^SRF(SRTN,206)),"^",37)>0,($P($G(^SRF(SRTN,207)),"^",27)=1) S $P(^SRF(SRTN,207),"^",27)=5 - Q -TR S J=I,J=$TR(J,"1234567890.","ABCDEFGHIJP") - Q -GET S X=$T(@J) - Q -END W @IOF D ^SRSKILL - Q -CHA ;;381^Foreign Body Removal -CHB ;;382^Pericardiectomy -DEA ;;451^Total CPB Time -DEJ ;;450^Total Ischemic Time -DFH ;;468^Incision Type -DFI ;;469^Convert Off Pump to CPB +SROACR2 ;BIR/SJA - OPERATIVE DATA, PAGE 2 ;04/12/06 + ;;3.0; Surgery ;**125,153,160**;24 Jun 93;Build 7 + ; + I '$D(SRTN) W !!,"A Surgery Risk Assessment must be selected prior to using this option.",!!,"Press to continue " R X:DTIME G END + S SRSOUT=0 D ^SROAUTL +START G:SRSOUT END + ; +EDIT S SRR=0 S SRPAGE="PAGE: 2 OF 2" D HDR^SROAUTL W "Indicate other cardiac procedures only if done with cardiopulmonary bypass",! F K=1:1:80 W "-" + ; + K DR S SRQ=0,(DR,SRDR)="381;382;451;450;468;469" + K DA,DIC,DIQ,SRY S DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="IE",DR=SRDR D EN^DIQ1 K DA,DIC,DIQ,DR + K SRX S SRX=0 F M=1:1 S I=$P(SRDR,";",M) Q:'I D + .K SREXT D TR,GET + .S SRX=SRX+1,Y=$P(X,";;",2),SRFLD=$P(Y,"^"),(Z,SRX(SRX))=$P(Y,"^",2)_"^"_SRFLD,SREXT=SRY(130,SRTN,SRFLD,"E") + .I SRFLD=451 W !,"Other Operative Data details:",!,"------------------------------" + .W !,$J(SRX,2)_". "_$P(Z,"^")_":" D EXT + .W:SRFLD=382 ! + D CHCK W ! F K=1:1:80 W "-" + D SEL G:SRR=1 EDIT + S SRSOUT=1 G END + Q +SEL S SRSOUT=0 W !!,"Select Operative Information to Edit: " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q + Q:X="" S:X="a" X="A" I '$D(SRFLG),'$D(SRX(X)),(X'?1.2N1":"1.2N),X'="A" D HELP S SRR=1 Q + I X?1.2N1":"1.2N S Y=$P(X,":"),Z=$P(X,":",2) I Y<1!(Z>SRX)!(Y>Z) D HELP S SRR=1 Q + I X="A" S X="1:"_SRX + I X?1.2N1":"1.2N D RANGE S SRR=1 K SREXT Q + I $D(SRX(X)),+X=X S EMILY=X D S SRR=1 + .I $$LOCK^SROUTL(SRTN) W ! D ONE,UNLOCK^SROUTL(SRTN) + Q +EXT W ?30,SREXT + Q +HELP W @IOF,!!!!,"Enter the number or range of numbers you want to edit. Examples of proper",!,"responses are listed below." + W !!,"1. Enter 'A' to update all information.",!!,"2. Enter a number (1-6) to update the information in that field. (For",!," example, enter '5' to update Incision Type.)" + W !!,"3. Enter a range of numbers (1-6) separated by a ':' to enter a range of",!," information. (For example, enter '3:5' to enter Total CPB time,",!," Total Ischemic time, and Incision Type.)" + D RET + Q +CHCK ; compare ischemic time to CPB time + I '$D(IORVON) S X="IORVON;IORVOFF" D ENDR^%ZISS + N SRISCH,SRCPB S SRISCH=SRY(130,SRTN,450,"E"),SRCPB=SRY(130,SRTN,451,"E") + I SRISCH,SRCPB,SRISCH>SRCPB W !,IORVON_"*** NOTE: Ischemic Time is greater than CPB Time!! Please check. ***"_IORVOFF + Q +RET Q:SRSOUT W ! K DIR S DIR(0)="E" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 + Q +RANGE ; range of numbers + I $$LOCK^SROUTL(SRTN) D D UNLOCK^SROUTL(SRTN) + .W ! S SHEMP=$P(X,":"),CURLEY=$P(X,":",2) F EMILY=SHEMP:1:CURLEY Q:SRSOUT D ONE + Q +ONE ; edit one item + K DR,DA,DIE S DR=$P(SRX(EMILY),"^",2)_"T",DA=SRTN,DIE=130,SRDT=$P(SRX(EMILY),"^",3) S:SRDT DR=DR_";"_SRDT_"T" D ^DIE K DR,DA I $D(Y) S SRSOUT=1 + I EMILY=3,$P($G(^SRF(SRTN,206)),"^",37)>0,($P($G(^SRF(SRTN,207)),"^",27)=1) S $P(^SRF(SRTN,207),"^",27)=5 + Q +TR S J=I,J=$TR(J,"1234567890.","ABCDEFGHIJP") + Q +GET S X=$T(@J) + Q +END W @IOF D ^SRSKILL + Q +CHA ;;381^Foreign Body Removal +CHB ;;382^Pericardiectomy +DEA ;;451^Total CPB Time +DEJ ;;450^Total Ischemic Time +DFH ;;468^Incision Type +DFI ;;469^Convert Off Pump to CPB diff --git a/r/SURGERY-SR/SROALEC.m b/r/SURGERY-SR/SROALEC.m index 25f55a1c..371a3322 100644 --- a/r/SURGERY-SR/SROALEC.m +++ b/r/SURGERY-SR/SROALEC.m @@ -1,86 +1,80 @@ -SROALEC ;BIR/ADM - LIST OF ELIGIBLE CASES ;02/04/08 - ;;3.0; Surgery ;**160,166**;24 Jun 93;Build 7 - S (GRAND,SRNEW,SRSOUT,TOT)=0,(SRHDR,SRPAGE)=1,SRTITLE="CASES ELIGIBLE FOR ASSESSMENT" K ^TMP("SRA",$J) - I SRFLG,SRASP S SRSPEC=$P(^SRO(137.45,SRASP,0),"^") - F S SRSD=$O(^SRF("AC",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT S SRTN=0 F S SRTN=$O(^SRF("AC",SRSD,SRTN)) Q:'SRTN!SRSOUT I $D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D UTL - I SRSP S SRSS="" F S SRSS=$O(^TMP("SRA",$J,SRSS)) Q:SRSS="" D SRSD Q:SRSOUT D:TOT TOT - I 'SRSP S SRNEW=1,(SRSD,TOT)=0 F S SRSD=$O(^TMP("SRA",$J,SRSD)) Q:'SRSD!SRSOUT S SRTN=0 F S SRTN=$O(^TMP("SRA",$J,SRSD,SRTN)) Q:'SRTN S SRA=^(SRTN) D CASE Q:SRSOUT - Q:SRSOUT I SRSP,'SRFLG,GRAND D GRAND - I SRFLG,'GRAND S SRSS=SRSPEC D HDR,GRAND - I SRSP,'SRFLG,'GRAND S SRSS="" D HDR,GRAND - I 'SRSP,'GRAND S SRSS="" D HDR,GRAND - I 'SRSP,GRAND S SRSS="" D GRAND - Q -UTL ; set up TMP global - N SRCPLT - I '$P($G(^SRF(SRTN,.2)),"^",3)&'$P($G(^SRF(SRTN,.2)),"^",12) Q - I $P($G(^SRF(SRTN,30)),"^") Q - I SRFLG,$P(^SRF(SRTN,0),"^",4)'=SRASP Q - S SRCPLT=$P($G(^SRO(136,SRTN,10)),"^") I SRCPLT,'$$XL^SROAX(SRTN) Q - S SRA=$G(^SRF(SRTN,"RA")) - I SRAST=1 Q:'($P(SRA,"^",2)="N"!($P(SRA,"^",2)="C"))!'($P(SRA,"^",6)="Y") - I SRAST=2 Q:'($P(SRA,"^",2)="N"!($P(SRA,"^",2)="C"))!'($P(SRA,"^",6)="N") - I SRAST=3 Q:$P(SRA,"^",2)'="" - I SRSP S SRSS=$P(^SRF(SRTN,0),"^",4),SRSS=$S(SRSS:$P(^SRO(137.45,SRSS,0),"^"),1:"SPECIALTY NOT ENTERED"),^TMP("SRA",$J,SRSS,SRSD,SRTN)=SRA Q - S ^TMP("SRA",$J,SRSD,SRTN)=SRA - Q -SRSD S SRNEW=1,(SRSD,TOT)=0 F S SRSD=$O(^TMP("SRA",$J,SRSS,SRSD)) Q:'SRSD!SRSOUT S SRTN=0 F S SRTN=$O(^TMP("SRA",$J,SRSS,SRSD,SRTN)) Q:'SRTN S SRA=^(SRTN) D CASE Q:SRSOUT - Q -CASE N SRA2 S SRA2=$P(SRA,"^",2) D - .I SRA2="" S SRATYPE="NOT LOGGED" Q - .I SRA2="N" D Q - .. I $P(SRA,"^",6)="N" S SRATYPE="EXCLUDED" Q - .. S SRATYPE="NON-CARDIAC" - .I SRA2="C" S SRATYPE="CARDIAC" - S TOT=TOT+1,GRAND=GRAND+1 D PRINT - Q -PRINT ; print case info - N SRDA,SRPROCS,SRSP1,SRY S SRPROCS="" - I $Y+8>IOSL!SRNEW D PAGE I SRSOUT Q - S SRA(0)=^SRF(SRTN,0),DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANM=VADM(1),SRASSN=VA("PID") K VADM - I $L(SRANM)>19 S SRANM=$P(SRANM,",")_","_$E($P(SRANM,",",2))_"." - S SRSP1="",X=$P(SRA(0),"^",4) S:X SRSP1=$P(^SRO(137.45,X,0),"^") - S SROPER=$P(^SRF(SRTN,"OP"),"^") I $O(^SRF(SRTN,13,0)) S SROTHER=0 F I=0:0 S SROTHER=$O(^SRF(SRTN,13,SROTHER)) Q:'SROTHER D OTHER - K SROPS,MM,MMM S:$L(SROPER)<63 SROPS(1)=SROPER I $L(SROPER)>62 S SROPER=SROPER_" " F M=1:1 D LOOP Q:MMM="" - S X=$P(SRA,"^"),SRSTATUS=$S(X="T":"TRANSMITTED",X="C":"COMPLETE",X="I":"INCOMPLETE",1:"NO ASSESSMENT"),Y=SRSD D D^DIQ S SRDT=$P(Y,"@") - I $Y+7>IOSL D PAGE I SRSOUT Q - W !,SRTN,?18,SRANM_" "_VA("PID"),?53,SRATYPE,?67,SRSTATUS,!,SRDT,?18,SROPS(1),! D - .I 'SRSP W $E(SRSP1,1,17) F I=2:1 W:$D(SROPS(I)) ?18,SROPS(I),! I '$D(SROPS(I)) W ! Q - .I SRSP F I=2:1 Q:'$D(SROPS(I)) W ?18,SROPS(I),! - S SRY=$P($G(^SRO(136,SRTN,0)),"^",2) I SRY D CPT S SRPROCS=SRCODE - S SRDA=0 F S SRDA=$O(^SRO(136,SRTN,3,SRDA)) Q:'SRDA S SRY=$P($G(^SRO(136,SRTN,3,SRDA,0)),"^") I SRY D CPT D - .S SRPROCS=SRPROCS_", "_SRCODE - I '$P($G(^SRO(136,SRTN,10)),"^"),$L(SRPROCS) W !,">>> Final CPT Coding is not complete." - S:SRPROCS="" SRPROCS="NOT ENTERED" W !,"CPT Codes: ",SRPROCS - I 'SRSOUT W ! F LINE=1:1:80 W "-" - Q -CPT ; check code for exclusion and get output value - N Y,SREX S (SRCODE,SREX)="" - S Y=$$CPT^ICPTCOD(SRY,$P(SRSD,".")),SRCODE=$P(Y,"^",2) - S SREX="" I '$D(^SRO(137,SRY,0)) S SREX="*" - S SRCODE=SREX_SRCODE - Q -OTHER ; other operations - S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,SROTHER,0),"^"))>125 S SRLONG=0,SROTHER=999,SROPERS=" ..." - I SRLONG S SROPERS=$P(^SRF(SRTN,13,SROTHER,0),"^") - S SROPER=SROPER_$S(SROPERS'=" ...":", "_SROPERS,1:SROPERS) - Q -LOOP ; break procedures - S SROPS(M)="" F LOOP=1:1 S MM=$P(SROPER," "),MMM=$P(SROPER," ",2,200) Q:MMM="" Q:$L(SROPS(M))+$L(MM)'<63 S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM - Q -PAGE I $E(IOST)="P"!SRHDR G HDR - W !!,"Press to continue, or '^' to quit " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q - I X["?" W !!,"If you want to continue the listing, press the 'Enter' key.",!,"Type '^' to return to the menu." G PAGE -HDR ; print heading - W @IOF,!,?(80-$L(SRTITLE)\2),SRTITLE,?70,$J("PAGE "_SRPAGE,9) W:$E(IOST)="P" !,?(80-$L(SRINST)\2),SRINST W !,?(80-$L(SRFRTO)\2),SRFRTO - W:$E(IOST)="P" !,?(80-$L(SRPRINT)\2),SRPRINT - W !!,?50,"'*' Denotes Eligible CPT Code" I SRSP,SRSS'="" W !,">>> "_SRSS - W !!,"CASE #",?18,"PATIENT",?53,"TYPE",?67,"STATUS",!,"OP DATE",?18,"OPERATION(S)",! W:'SRSP "SURG SPECIALTY",! F LINE=1:1:80 W "=" - S SRHDR=0,SRNEW=0,SRPAGE=SRPAGE+1 - Q -TOT W !!,"TOTAL FOR "_SRSS_": ",TOT - Q -GRAND I 'SRSP W !!,"TOTAL: ",GRAND Q - I SRSP,'SRFLG W !!,"TOTAL FOR ALL SPECIALTIES: ",GRAND Q - I SRSP,SRFLG S SRSS=SRSPEC D TOT - Q +SROALEC ;BIR/ADM - LIST OF ELIGIBLE CASES ;05/04/07 + ;;3.0; Surgery ;**160**;24 Jun 93;Build 7 + S (GRAND,SRNEW,SRSOUT,TOT)=0,(SRHDR,SRPAGE)=1,SRTITLE="CASES ELIGIBLE FOR ASSESSMENT" K ^TMP("SRA",$J) + I SRFLG,SRASP S SRSPEC=$P(^SRO(137.45,SRASP,0),"^") + F S SRSD=$O(^SRF("AC",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT S SRTN=0 F S SRTN=$O(^SRF("AC",SRSD,SRTN)) Q:'SRTN!SRSOUT I $D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D UTL + I SRSP S SRSS="" F S SRSS=$O(^TMP("SRA",$J,SRSS)) Q:SRSS="" D SRSD Q:SRSOUT D:TOT TOT + I 'SRSP S SRNEW=1,(SRSD,TOT)=0 F S SRSD=$O(^TMP("SRA",$J,SRSD)) Q:'SRSD!SRSOUT S SRTN=0 F S SRTN=$O(^TMP("SRA",$J,SRSD,SRTN)) Q:'SRTN S SRA=^(SRTN) D CASE Q:SRSOUT + Q:SRSOUT I SRSP,'SRFLG,GRAND D GRAND + I SRFLG,'GRAND S SRSS=SRSPEC D HDR,GRAND + I SRSP,'SRFLG,'GRAND S SRSS="" D HDR,GRAND + I 'SRSP,'GRAND S SRSS="" D HDR,GRAND + I 'SRSP,GRAND S SRSS="" D GRAND + Q +UTL ; set up TMP global + N SRCPLT + I '$P($G(^SRF(SRTN,.2)),"^",3)&'$P($G(^SRF(SRTN,.2)),"^",12) Q + I $P($G(^SRF(SRTN,30)),"^") Q + I SRFLG,$P(^SRF(SRTN,0),"^",4)'=SRASP Q + S SRCPLT=$P($G(^SRO(136,SRTN,10)),"^") I SRCPLT,'$$XL^SROAX(SRTN) Q + S SRA=$G(^SRF(SRTN,"RA")) + I SRSP S SRSS=$P(^SRF(SRTN,0),"^",4),SRSS=$S(SRSS:$P(^SRO(137.45,SRSS,0),"^"),1:"SPECIALTY NOT ENTERED"),^TMP("SRA",$J,SRSS,SRSD,SRTN)=SRA Q + S ^TMP("SRA",$J,SRSD,SRTN)=SRA + Q +SRSD S SRNEW=1,(SRSD,TOT)=0 F S SRSD=$O(^TMP("SRA",$J,SRSS,SRSD)) Q:'SRSD!SRSOUT S SRTN=0 F S SRTN=$O(^TMP("SRA",$J,SRSS,SRSD,SRTN)) Q:'SRTN S SRA=^(SRTN) D CASE Q:SRSOUT + Q +CASE N SRA2 S SRA2=$P(SRA,"^",2) D + .I SRA2="" S SRATYPE="NOT LOGGED" Q + .I SRA2="N" D Q + .. I $P(SRA,"^",6)="N" S SRATYPE="EXCLUDED" Q + .. S SRATYPE="NON-CARDIAC" + .I SRA2="C" S SRATYPE="CARDIAC" + S TOT=TOT+1,GRAND=GRAND+1 D PRINT + Q +PRINT ; print case info + N SRDA,SRPROCS,SRY S SRPROCS="" + I $Y+6>IOSL!SRNEW D PAGE I SRSOUT Q + S SRA(0)=^SRF(SRTN,0),DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANM=VADM(1),SRASSN=VA("PID") K VADM + I $L(SRANM)>19 S SRANM=$P(SRANM,",")_","_$E($P(SRANM,",",2))_"." + S SROPER=$P(^SRF(SRTN,"OP"),"^") I $O(^SRF(SRTN,13,0)) S SROTHER=0 F I=0:0 S SROTHER=$O(^SRF(SRTN,13,SROTHER)) Q:'SROTHER D OTHER + K SROPS,MM,MMM S:$L(SROPER)<63 SROPS(1)=SROPER I $L(SROPER)>62 S SROPER=SROPER_" " F M=1:1 D LOOP Q:MMM="" + S X=$P(SRA,"^"),SRSTATUS=$S(X="T":"TRANSMITTED",X="C":"COMPLETE",X="I":"INCOMPLETE",1:"NO ASSESSMENT"),Y=SRSD D D^DIQ S SRDT=$P(Y,"@") + I $Y+5>IOSL D PAGE I SRSOUT Q + W !,SRTN,?18,SRANM_" "_VA("PID"),?53,SRATYPE,?67,SRSTATUS,!,SRDT F I=1:1 Q:'$D(SROPS(I)) W ?18,SROPS(I),! + S SRY=$P($G(^SRO(136,SRTN,0)),"^",2) I SRY D CPT S SRPROCS=SRCODE + S SRDA=0 F S SRDA=$O(^SRO(136,SRTN,3,SRDA)) Q:'SRDA S SRY=$P($G(^SRO(136,SRTN,3,SRDA,0)),"^") I SRY D CPT D + .S SRPROCS=SRPROCS_", "_SRCODE + I '$P($G(^SRO(136,SRTN,10)),"^"),$L(SRPROCS) W !,">>> Final CPT Coding is not complete." + S:SRPROCS="" SRPROCS="NOT ENTERED" W !,"CPT Codes: ",SRPROCS + I 'SRSOUT W ! F LINE=1:1:80 W "-" + Q +CPT ; check code for exclusion and get output value + N Y,SREX S (SRCODE,SREX)="" + S Y=$$CPT^ICPTCOD(SRY,$P(SRSD,".")),SRCODE=$P(Y,"^",2) + S SREX="" I '$D(^SRO(137,SRY,0)) S SREX="*" + S SRCODE=SREX_SRCODE + Q +OTHER ; other operations + S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,SROTHER,0),"^"))>125 S SRLONG=0,SROTHER=999,SROPERS=" ..." + I SRLONG S SROPERS=$P(^SRF(SRTN,13,SROTHER,0),"^") + S SROPER=SROPER_$S(SROPERS'=" ...":", "_SROPERS,1:SROPERS) + Q +LOOP ; break procedures + S SROPS(M)="" F LOOP=1:1 S MM=$P(SROPER," "),MMM=$P(SROPER," ",2,200) Q:MMM="" Q:$L(SROPS(M))+$L(MM)'<63 S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM + Q +PAGE I $E(IOST)="P"!SRHDR G HDR + W !!,"Press to continue, or '^' to quit " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q + I X["?" W !!,"If you want to continue the listing, press the 'Enter' key.",!,"Type '^' to return to the menu." G PAGE +HDR ; print heading + W @IOF,!,?(80-$L(SRTITLE)\2),SRTITLE,?70,$J("PAGE "_SRPAGE,9) W:$E(IOST)="P" !,?(80-$L(SRINST)\2),SRINST W !,?(80-$L(SRFRTO)\2),SRFRTO + W:$E(IOST)="P" !,?(80-$L(SRPRINT)\2),SRPRINT + W !!,?50,"'*' Denotes Eligible CPT Code" I SRSP,SRSS'="" W !,">>> "_SRSS + W !!,"CASE #",?18,"PATIENT",?53,"TYPE",?67,"STATUS",!,"OP DATE",?18,"OPERATION(S)",! F LINE=1:1:80 W "=" + S SRHDR=0,SRNEW=0,SRPAGE=SRPAGE+1 + Q +TOT W !!,"TOTAL FOR "_SRSS_": ",TOT + Q +GRAND I 'SRSP W !!,"TOTAL: ",GRAND Q + I SRSP,'SRFLG W !!,"TOTAL FOR ALL SPECIALTIES: ",GRAND Q + I SRSP,SRFLG S SRSS=SRSPEC D TOT + Q diff --git a/r/SURGERY-SR/SROALM.m b/r/SURGERY-SR/SROALM.m index 3c947eef..fc1e6473 100644 --- a/r/SURGERY-SR/SROALM.m +++ b/r/SURGERY-SR/SROALM.m @@ -1,67 +1,67 @@ -SROALM ;BIR/ADM - LIST OF ASSESSMENTS MISSING INFORMATION ;12/05/07 - ;;3.0; Surgery ;**38,50,88,142,153,160,166**;24 Jun 93;Build 7 - S (GRAND,SRNEW,SRSOUT,TOT)=0,(SRHDR,SRPAGE)=1,SRTITLE="COMPLETED/TRANSMITTED ASSESSMENTS MISSING INFORMATION" K ^TMP("SRA",$J) - I SRFLG,SRASP S SRSPEC=$P(^SRO(137.45,SRASP,0),"^") - F S SRSD=$O(^SRF("AC",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT S SRTN=0 F S SRTN=$O(^SRF("AC",SRSD,SRTN)) Q:'SRTN!SRSOUT D - .S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="C"!($P(SR("RA"),"^")="T"),$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D UTL - I SRSP S SRSS="" F S SRSS=$O(^TMP("SRA",$J,SRSS)) Q:SRSS="" D SRSD Q:SRSOUT D:TOT TOT - I 'SRSP S SRNEW=1,(SRSD,TOT)=0 F S SRSD=$O(^TMP("SRA",$J,SRSD)) Q:'SRSD!SRSOUT S SRTN=0 F S SRTN=$O(^TMP("SRA",$J,SRSD,SRTN)) Q:'SRTN S SRA=^(SRTN) D CASE Q:SRSOUT - Q:SRSOUT I SRSP,'SRFLG,GRAND D GRAND - I SRFLG,'GRAND S SRSS=SRSPEC D HDR,GRAND - I SRSP,'SRFLG,'GRAND S SRSS="" D HDR,GRAND - I 'SRSP,'GRAND S SRSS="" D HDR,GRAND - I 'SRSP,GRAND S SRSS="" D GRAND - Q -UTL ; set up TMP global - I SRFLG,$P(^SRF(SRTN,0),"^",4)'=SRASP Q - I SRSP S SRSS=$P(^SRF(SRTN,0),"^",4),SRSS=$S(SRSS:$P(^SRO(137.45,SRSS,0),"^"),1:"SPECIALTY NOT ENTERED"),^TMP("SRA",$J,SRSS,SRSD,SRTN)=SR("RA") Q - S ^TMP("SRA",$J,SRSD,SRTN)=SR("RA") - Q -SRSD S SRNEW=1,(SRSD,TOT)=0 F S SRSD=$O(^TMP("SRA",$J,SRSS,SRSD)) Q:'SRSD!SRSOUT S SRTN=0 F S SRTN=$O(^TMP("SRA",$J,SRSS,SRSD,SRTN)) Q:'SRTN S SRA=^(SRTN) D CASE Q:SRSOUT - Q -CASE I $P(SRA,"^",2)="N",$P(SRA,"^",6)="Y" S SRATYPE="NON-CARDIAC" D CHK^SROAUTL - I $P(SRA,"^",2)="N",$P(SRA,"^",6)="N" S SRATYPE="EXCLUDED" D CHK^SROAUTL3 - I $P(SRA,"^",2)="C" S SRATYPE="CARDIAC" D CHK^SROAUTLC - S SRFLD="" I $O(SRX(SRFLD))'="" S TOT=TOT+1,GRAND=GRAND+1 D PRINT Q - I '$P($G(^SRO(136,SRTN,10)),"^")!('$P($G(^SRO(136,SRTN,0)),"^",2))!('$P($G(^SRO(136,SRTN,0)),"^",3)) D PRINT - Q -PRINT ; print assessments - K SRCPTT S SRCPTT="NOT ENTERED" - I $Y+5>IOSL!SRNEW D PAGE I SRSOUT Q - S SRA(0)=^SRF(SRTN,0),DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANM=VADM(1),SRASSN=VA("PID") K VADM - I $L(SRANM)>19 S SRANM=$P(SRANM,",")_","_$E($P(SRANM,",",2))_"." - S SROPER=$P(^SRF(SRTN,"OP"),"^") I $O(^SRF(SRTN,13,0)) S SROTHER=0 F I=0:0 S SROTHER=$O(^SRF(SRTN,13,SROTHER)) Q:'SROTHER D OTHER - K SROPS,MM,MMM S:$L(SROPER)<63 SROPS(1)=SROPER I $L(SROPER)>62 S SROPER=SROPER_" " F M=1:1 D LOOP Q:MMM="" - S SRSTATUS=$S($P(SRA,"^")="T":"TRANSMITTED",1:"COMPLETE"),Y=SRSD D D^DIQ S SRDT=$P(Y,"@") - I $Y+5>IOSL D PAGE I SRSOUT Q - W !,SRTN,?18,SRANM_" "_VA("PID"),?53,SRATYPE,?68,SRSTATUS,!,SRDT F I=1:1 Q:'$D(SROPS(I)) W ?18,SROPS(I),! - N I,SRPROC,SRL S SRL=100 D CPTS^SROAUTL0 W ?18,"CPT Codes: " - F I=1:1 Q:'$D(SRPROC(I)) W:I=1 ?29,SRPROC(I) W:I'=1 !,?29,SRPROC(I) - S CNT=1 W !,?5,"Missing information:" - I '$P($G(^SRO(136,SRTN,10)),"^")!('$P($G(^SRO(136,SRTN,0)),"^",2))!('$P($G(^SRO(136,SRTN,0)),"^",3)) W !,$J(CNT_". ",8),"The final coding for Procedure and Diagnosis is not complete." S CNT=CNT+1 - F S SRFLD=$O(SRX(SRFLD)) Q:SRFLD="" D:$Y+5>IOSL PAGE Q:SRSOUT W !,$J(CNT_". ",8),$P(SRX(SRFLD),":") S CNT=CNT+1 - I 'SRSOUT W ! F LINE=1:1:80 W "-" - Q -OTHER ; other operations - S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,SROTHER,0),"^"))>125 S SRLONG=0,SROTHER=999,SROPERS=" ..." - I SRLONG S SROPERS=$P(^SRF(SRTN,13,SROTHER,0),"^") - S SROPER=SROPER_$S(SROPERS'=" ...":", "_SROPERS,1:SROPERS) - Q -LOOP ; break procedures - S SROPS(M)="" F LOOP=1:1 S MM=$P(SROPER," "),MMM=$P(SROPER," ",2,200) Q:MMM="" Q:$L(SROPS(M))+$L(MM)'<63 S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM - Q -PAGE I $E(IOST)="P"!SRHDR G HDR - W !!,"Press to continue, or '^' to quit " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q - I X["?" W !!,"If you want to continue listing incomplete assessments, enter . Enter",!,"'^' to return to the menu." G PAGE -HDR ; print heading - W @IOF,!,?(80-$L(SRTITLE)\2),SRTITLE,?70,$J("PAGE "_SRPAGE,9) W:$E(IOST)="P" !,?(80-$L(SRINST)\2),SRINST W !,?(80-$L(SRFRTO)\2),SRFRTO - W:$E(IOST)="P" !,?(80-$L(SRPRINT)\2),SRPRINT I SRSP,SRSS'="" W !!,"** "_SRSS - W !!,"ASSESSMENT #",?18,"PATIENT",?53,"TYPE",?68,"STATUS",!,"OPERATION DATE",?18,"OPERATION(S)",! F LINE=1:1:80 W "=" - S SRHDR=0,SRNEW=0,SRPAGE=SRPAGE+1 - Q -TOT W !!,"TOTAL FOR "_SRSS_": ",TOT - Q -GRAND I 'SRSP W !!,"TOTAL: ",GRAND Q - I SRSP,'SRFLG W !!,"TOTAL FOR ALL SPECIALTIES: ",GRAND Q - I SRSP,SRFLG S SRSS=SRSPEC D TOT - Q +SROALM ;BIR/ADM - LIST OF ASSESSMENTS MISSING INFORMATION ;02/08/07 + ;;3.0; Surgery ;**38,50,88,142,153,160**;24 Jun 93;Build 7 + S (GRAND,SRNEW,SRSOUT,TOT)=0,(SRHDR,SRPAGE)=1,SRTITLE="COMPLETED/TRANSMITTED ASSESSMENTS MISSING INFORMATION" K ^TMP("SRA",$J) + I SRFLG,SRASP S SRSPEC=$P(^SRO(137.45,SRASP,0),"^") + F S SRSD=$O(^SRF("AC",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT S SRTN=0 F S SRTN=$O(^SRF("AC",SRSD,SRTN)) Q:'SRTN!SRSOUT D + .S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="C"!($P(SR("RA"),"^")="T"),$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D UTL + I SRSP S SRSS="" F S SRSS=$O(^TMP("SRA",$J,SRSS)) Q:SRSS="" D SRSD Q:SRSOUT D:TOT TOT + I 'SRSP S SRNEW=1,(SRSD,TOT)=0 F S SRSD=$O(^TMP("SRA",$J,SRSD)) Q:'SRSD!SRSOUT S SRTN=0 F S SRTN=$O(^TMP("SRA",$J,SRSD,SRTN)) Q:'SRTN S SRA=^(SRTN) D CASE Q:SRSOUT + Q:SRSOUT I SRSP,'SRFLG,GRAND D GRAND + I SRFLG,'GRAND S SRSS=SRSPEC D HDR,GRAND + I SRSP,'SRFLG,'GRAND S SRSS="" D HDR,GRAND + I 'SRSP,'GRAND S SRSS="" D HDR,GRAND + I 'SRSP,GRAND S SRSS="" D GRAND + Q +UTL ; set up TMP global + I SRFLG,$P(^SRF(SRTN,0),"^",4)'=SRASP Q + I SRSP S SRSS=$P(^SRF(SRTN,0),"^",4),SRSS=$S(SRSS:$P(^SRO(137.45,SRSS,0),"^"),1:"SPECIALTY NOT ENTERED"),^TMP("SRA",$J,SRSS,SRSD,SRTN)=SR("RA") Q + S ^TMP("SRA",$J,SRSD,SRTN)=SR("RA") + Q +SRSD S SRNEW=1,(SRSD,TOT)=0 F S SRSD=$O(^TMP("SRA",$J,SRSS,SRSD)) Q:'SRSD!SRSOUT S SRTN=0 F S SRTN=$O(^TMP("SRA",$J,SRSS,SRSD,SRTN)) Q:'SRTN S SRA=^(SRTN) D CASE Q:SRSOUT + Q +CASE I $P(SRA,"^",2)="N",$P(SRA,"^",6)="Y" S SRATYPE="NON-CARDIAC" D CHK^SROAUTL + I $P(SRA,"^",2)="N",$P(SRA,"^",6)="N" S SRATYPE="EXCLUDED" D CHK^SROAUTL3 + I $P(SRA,"^",2)="C" S SRATYPE="CARDIAC" D CHK^SROAUTLC + S SRFLD="" I $O(SRX(SRFLD))'="" S TOT=TOT+1,GRAND=GRAND+1 D PRINT Q + I '$P($G(^SRO(136,SRTN,10)),"^")!('$P($G(^SRO(136,SRTN,0)),"^",2))!('$P($G(^SRO(136,SRTN,0)),"^",3)) D PRINT + Q +PRINT ; print assessments + K SRCPTT S SRCPTT="NOT ENTERED" + I $Y+5>IOSL!SRNEW D PAGE I SRSOUT Q + S SRA(0)=^SRF(SRTN,0),DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANM=VADM(1),SRASSN=VA("PID") K VADM + I $L(SRANM)>19 S SRANM=$P(SRANM,",")_","_$E($P(SRANM,",",2))_"." + S SROPER=$P(^SRF(SRTN,"OP"),"^") I $O(^SRF(SRTN,13,0)) S SROTHER=0 F I=0:0 S SROTHER=$O(^SRF(SRTN,13,SROTHER)) Q:'SROTHER D OTHER + K SROPS,MM,MMM S:$L(SROPER)<63 SROPS(1)=SROPER I $L(SROPER)>62 S SROPER=SROPER_" " F M=1:1 D LOOP Q:MMM="" + S SRSTATUS=$S($P(SRA,"^")="T":"TRANSMITTED",1:"COMPLETE"),Y=SRSD D D^DIQ S SRDT=$P(Y,"@") + I $Y+5>IOSL D PAGE I SRSOUT Q + W !,SRTN,?18,SRANM_" "_VA("PID"),?53,SRATYPE,?68,SRSTATUS,!,SRDT F I=1:1 Q:'$D(SROPS(I)) W ?18,SROPS(I),! + N I,SRPROC,SRL S SRL=100 D CPTS^SROAUTL0 W ?18,"CPT Codes: " + F I=1:1 Q:'$D(SRPROC(I)) W:I=1 ?29,SRPROC(I) W:I'=1 !,?29,SRPROC(I) + S CNT=1 W !,?5,"Missing information:" + I '$P($G(^SRO(136,SRTN,10)),"^")!('$P($G(^SRO(136,SRTN,0)),"^",2))!('$P($G(^SRO(136,SRTN,0)),"^",3)) W !,$J(CNT_". ",8),"The final coding for Procedure and Diagnosis is not complete." S CNT=CNT+1 + F S SRFLD=$O(SRX(SRFLD)) Q:SRFLD="" D:$Y+5>IOSL PAGE Q:SRSOUT W !,$J(CNT_". ",8),SRX(SRFLD) S CNT=CNT+1 + I 'SRSOUT W ! F LINE=1:1:80 W "-" + Q +OTHER ; other operations + S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,SROTHER,0),"^"))>125 S SRLONG=0,SROTHER=999,SROPERS=" ..." + I SRLONG S SROPERS=$P(^SRF(SRTN,13,SROTHER,0),"^") + S SROPER=SROPER_$S(SROPERS'=" ...":", "_SROPERS,1:SROPERS) + Q +LOOP ; break procedures + S SROPS(M)="" F LOOP=1:1 S MM=$P(SROPER," "),MMM=$P(SROPER," ",2,200) Q:MMM="" Q:$L(SROPS(M))+$L(MM)'<63 S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM + Q +PAGE I $E(IOST)="P"!SRHDR G HDR + W !!,"Press to continue, or '^' to quit " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q + I X["?" W !!,"If you want to continue listing incomplete assessments, enter . Enter",!,"'^' to return to the menu." G PAGE +HDR ; print heading + W @IOF,!,?(80-$L(SRTITLE)\2),SRTITLE,?70,$J("PAGE "_SRPAGE,9) W:$E(IOST)="P" !,?(80-$L(SRINST)\2),SRINST W !,?(80-$L(SRFRTO)\2),SRFRTO + W:$E(IOST)="P" !,?(80-$L(SRPRINT)\2),SRPRINT I SRSP,SRSS'="" W !!,"** "_SRSS + W !!,"ASSESSMENT #",?18,"PATIENT",?53,"TYPE",?68,"STATUS",!,"OPERATION DATE",?18,"OPERATION(S)",! F LINE=1:1:80 W "=" + S SRHDR=0,SRNEW=0,SRPAGE=SRPAGE+1 + Q +TOT W !!,"TOTAL FOR "_SRSS_": ",TOT + Q +GRAND I 'SRSP W !!,"TOTAL: ",GRAND Q + I SRSP,'SRFLG W !!,"TOTAL FOR ALL SPECIALTIES: ",GRAND Q + I SRSP,SRFLG S SRSS=SRSPEC D TOT + Q diff --git a/r/SURGERY-SR/SROALOG.m b/r/SURGERY-SR/SROALOG.m index 264469d0..b63688d0 100644 --- a/r/SURGERY-SR/SROALOG.m +++ b/r/SURGERY-SR/SROALOG.m @@ -1,71 +1,45 @@ -SROALOG ;BIR/MAM - ASSESSMENT LOG ;01/24/08 - ;;3.0; Surgery ;**38,55,62,77,50,153,160,166**;24 Jun 93;Build 7 - K SRMNA S (SRSOUT,SRFLG,SRSP,SRAST)=0,SRSRT=1 -START G:SRSOUT END W @IOF K DIR S DIR("A",1)="List of Surgery Risk Assessments",DIR("A",2)="",DIR("A",3)=" 1. List of Incomplete Assessments" - S DIR("A",4)=" 2. List of Completed Assessments",DIR("A",5)=" 3. List of Transmitted Assessments" - S DIR("A",6)=" 4. List of Non-Assessed Major Surgical Cases",DIR("A",7)=" 5. List of All Major Surgical Cases" - S DIR("A",8)=" 6. List of All Surgical Cases",DIR("A",9)=" 7. List of Completed/Transmitted Assessments Missing Information" - S DIR("A",10)=" 8. List of 1-Liner Cases Missing Information",DIR("A",11)=" 9. List of Eligible Cases" - S DIR("A",12)=" 10. List of Cases With No CPT Codes",DIR("A",13)=" 11. Summary List of Assessed Cases" - S DIR("A",14)="",DIR("A")="Select the Number of the Report Desired" - S DIR(0)="NO^1:11" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT)!'Y S SRSOUT=1 G END - S SREPORT=X -DATE I SREPORT=3 D DSORT G:SRSOUT END - D DATE^SROUTL(.SRSD,.SRED,.SRSOUT) G:SRSOUT END - I SREPORT=9 D TYPE9 I SRSOUT G END - I SREPORT=3 D TYPE3 I SRSOUT G END - D SEL G:SRSOUT END - N SRINSTP S SRINST=$$INST^SROUTL0() G:SRINST="^" END S SRINSTP=$P(SRINST,"^"),SRINST=$S(SRINST["ALL DIVISIONS":SRINST,1:$P(SRINST,"^",2)) - I SREPORT<7 W @IOF,!,"This report is designed to print to your terminal screen or a printer. When",!,"using a printer, a 132 column format is used.",! - K IOP,%ZIS,POP,IO("Q") S %ZIS("A")="Print the List of Assessments to which Device: ",%ZIS="QM" D ^%ZIS I POP S SRSOUT=1 G END - I $D(IO("Q")) K IO("Q") D S ZTREQ="@" D ^%ZTLOAD G END - .S ZTRTN="EN^SROALOG",ZTDESC="List of Surgery Risk Assessments" - .S (ZTSAVE("SRSD"),ZTSAVE("SRED"),ZTSAVE("SREPORT"),ZTSAVE("SRASP"),ZTSAVE("SRFLG"),ZTSAVE("SRSP"),ZTSAVE("SRINSTP"),ZTSAVE("SRAST"),ZTSAVE("SRSRT"))="" -EN ; entry when queued - N SRFRTO S Y=SRSD X ^DD("DD") S SRFRTO="FROM: "_Y_" TO: ",Y=SRED X ^DD("DD") S SRFRTO=SRFRTO_Y - U IO S SRSD=SRSD-.0001,SRED=SRED_".9999",Y=DT X ^DD("DD") S SRPRINT="DATE PRINTED: "_Y - S SRINST=$S(SRINSTP["ALL DIV":$P($$SITE^SROVAR,"^",2)_" - ALL DIVISIONS",1:$$GET1^DIQ(4,SRINSTP,.01)) - I SREPORT=1 D:SRSP ^SROANTS D:'SRSP ^SROANT G END - I SREPORT=2 D:SRSP ^SROALCS D:'SRSP ^SROALC G END - I SREPORT=3 D:SRSP ^SROALTS D:'SRSP ^SROALT G END - I SREPORT=4 S SRMNA=1 D:SRSP ^SROALLS D:'SRSP ^SROALL G END - I SREPORT=5 D:SRSP ^SROALLS D:'SRSP ^SROALL G END - I SREPORT=7 D ^SROALM G END - I SREPORT=8 D ^SROALMN G END - I SREPORT=9 D ^SROALEC G END - I SREPORT=10 D ^SROALNC G END - I SREPORT=11 D ^SROALSL G END - D:SRSP ^SROALSS D:'SRSP ^SROALST -END I 'SRSOUT,$E(IOST)'="P" W !!,"Press ENTER to continue " R X:DTIME - W:$E(IOST)="P" @IOF K ^TMP("SRA",$J) I $D(ZTQUEUED) Q:$G(ZTSTOP) S ZTREQ="@" Q - D ^%ZISC K SRTN,SRAST,SRSRT W @IOF D ^SRSKILL - Q -TYPE3 ; select type of eligible cases - W ! K DIR S DIR("A",1)="Print which Transmitted Cases ?",DIR("A",2)="",DIR("A",3)=" 1. Assessed Cases Only" - S DIR("A",4)=" 2. Excluded Cases Only",DIR("A",5)=" 3. Both Assessed and Excluded",DIR("A",6)="" - S DIR("A")="Select Number",DIR("B")=1,DIR(0)="N^1:3" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 - S SRAST=Y - Q -TYPE9 ; select type of transmitted case - W ! K DIR S DIR("A",1)="Print which Eligible Cases ?",DIR("A",2)="",DIR("A",3)=" 1. Assessed Cases Only" - S DIR("A",4)=" 2. Excluded Cases Only",DIR("A",5)=" 3. Non-Assessed Cases only",DIR("A",6)=" 4. All Cases",DIR("A",7)="" - S DIR("A")="Select Number",DIR("B")=1,DIR(0)="N^1:4" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 - S SRAST=Y - Q -DSORT ; sort by op date or transmit date - W ! K DIR S DIR("A",1)="Print by Date of Operation or by Date of Transmission ?",DIR("A",2)="",DIR("A",3)=" 1. Date of Operation" - S DIR("A",4)=" 2. Date of Transmission",DIR("A",5)="",DIR("A")="Select Number",DIR("B")=1,DIR(0)="N^1:2" - D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 - S SRSRT=Y - Q -SEL ; select specialty - W ! K DIR S DIR(0)="YA",DIR("A")="Print by Surgical Specialty ? ",DIR("B")="YES" - S DIR("?",1)="Enter YES to print the report by surgical specialty, or NO to print",DIR("?")="the report listing all surgical cases." - D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q - Q:'Y -SEL1 S SRSP=1 W ! K DIR S DIR(0)="YA",DIR("A")="Print report for ALL specialties ? ",DIR("B")="YES" - S DIR("?",1)="Enter YES to print the report for all surgical specialties, or NO to",DIR("?")="print the report for a specific surgical specialty." - D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q - I 'Y W ! S DIC("S")="I '$P(^(0),""^"",3)",DIC("A")="Print the Report for which Surgical Specialty: ",DIC=137.45,DIC(0)="QEAMZ" D ^DIC K DIC I Y>0 S SRASP=+Y,SRFLG=1 Q - I Y'>0 S SRSOUT=1 Q - Q +SROALOG ;BIR/MAM - ASSESSMENT LOG ;01/22/07 + ;;3.0; Surgery ;**38,55,62,77,50,153,160**;24 Jun 93;Build 7 + K SRMNA S (SRSOUT,SRFLG,SRSP)=0 +START G:SRSOUT END W @IOF,!,"List of Surgery Risk Assessments",!!," 1. List of Incomplete Assessments" + W !," 2. List of Completed Assessments",!," 3. List of Transmitted Assessments" + W !," 4. List of Non-Assessed Major Surgical Cases",!," 5. List of All Major Surgical Cases" + W !," 6. List of All Surgical Cases",!," 7. List of Completed/Transmitted Assessments Missing Information" + W !," 8. List of 1-Liner Cases Missing Information",!," 9. List of Eligible Cases" + W !!,"Select the Number of the Report Desired: " R X:DTIME I '$T!("^"[X) S SRSOUT=1 G END + I X<1!(X>9)!(X\1'=X) D HELP G START + S SREPORT=X +DATE D DATE^SROUTL(.SRSD,.SRED,.SRSOUT) G:SRSOUT END + D SEL G:SRSOUT END + N SRINSTP S SRINST=$$INST^SROUTL0() G:SRINST="^" END S SRINSTP=$P(SRINST,"^"),SRINST=$S(SRINST["ALL DIVISIONS":SRINST,1:$P(SRINST,"^",2)) + I SREPORT<7 W @IOF,!,"This report is designed to print to your terminal screen or a printer. When",!,"using a printer, a 132 column format is used.",! + K IOP,%ZIS,POP,IO("Q") S %ZIS("A")="Print the List of Assessments to which Device: ",%ZIS="QM" D ^%ZIS I POP S SRSOUT=1 G END + I $D(IO("Q")) K IO("Q") S ZTRTN="EN^SROALOG",ZTDESC="List of Surgery Risk Assessments",(ZTSAVE("SRSD"),ZTSAVE("SRED"),ZTSAVE("SREPORT"),ZTSAVE("SRASP"),ZTSAVE("SRFLG"),ZTSAVE("SRSP"),ZTSAVE("SRINSTP"))="",ZTREQ="@" D ^%ZTLOAD G END +EN ; entry when queued + N SRFRTO S Y=SRSD X ^DD("DD") S SRFRTO="FROM: "_Y_" TO: ",Y=SRED X ^DD("DD") S SRFRTO=SRFRTO_Y + U IO S SRSD=SRSD-.0001,SRED=SRED_".9999",Y=DT X ^DD("DD") S SRPRINT="DATE PRINTED: "_Y + S SRINST=$S(SRINSTP["ALL DIV":$P($$SITE^SROVAR,"^",2)_" - ALL DIVISIONS",1:$$GET1^DIQ(4,SRINSTP,.01)) + I SREPORT=1 D:SRSP ^SROANTS D:'SRSP ^SROANT G END + I SREPORT=2 D:SRSP ^SROALCS D:'SRSP ^SROALC G END + I SREPORT=3 D:SRSP ^SROALTS D:'SRSP ^SROALT G END + I SREPORT=4 S SRMNA=1 D:SRSP ^SROALLS D:'SRSP ^SROALL G END + I SREPORT=5 D:SRSP ^SROALLS D:'SRSP ^SROALL G END + I SREPORT=7 D ^SROALM G END + I SREPORT=8 D ^SROALMN G END + I SREPORT=9 D ^SROALEC G END + D:SRSP ^SROALSS D:'SRSP ^SROALST +END I 'SRSOUT,$E(IOST)'="P" W !!,"Press to continue " R X:DTIME + W:$E(IOST)="P" @IOF K ^TMP("SRA",$J) I $D(ZTQUEUED) Q:$G(ZTSTOP) S ZTREQ="@" Q + D ^%ZISC K SRTN W @IOF D ^SRSKILL + Q +HELP W !!,"Select the number corresponding to the type of report you want to print.",!!,"Press to continue " R X:DTIME I '$T!(X["^") S SRSOUT=1 + Q +SEL ; select specialty + W !!,"Print by Surgical Specialty ? YES// " R X:DTIME S:'$T X="^" I X="^" S SRSOUT=1 Q + S X=$E(X) I "YyNn"'[X W !!,"Enter to print the report by surgical specialty, or 'N' to print",!,"the report listing all surgical cases." G SEL + Q:"Yy"'[X +SEL1 S SRSP=1 W !!,"Print report for ALL specialties ? YES// " R X:DTIME S:'$T X="^" I X="^" S SRSOUT=1 Q + S X=$E(X) I "YyNn"'[X W !!,"Enter to print the report for all surgical specialties, or 'N' to ",!,"print the report for a specific surgical specialty." G SEL1 + I "Yy"'[X W ! S DIC("S")="I '$P(^(0),""^"",3)",DIC("A")="Print the Report for which Surgical Specialty: ",DIC=137.45,DIC(0)="QEAMZ" D ^DIC K DIC I Y>0 S SRASP=+Y,SRFLG=1 Q + I Y'>0 S SRSOUT=1 Q + Q diff --git a/r/SURGERY-SR/SROALT.m b/r/SURGERY-SR/SROALT.m index fe0c106f..6364a0d4 100644 --- a/r/SURGERY-SR/SROALT.m +++ b/r/SURGERY-SR/SROALT.m @@ -1,43 +1,34 @@ -SROALT ;BIR/MAM - TRANSMITTED ASSESSMENTS ;01/07/08 - ;;3.0; Surgery ;**38,50,142,153,160,166**;24 Jun 93;Build 7 - S SRFRTO=$S(SRSRT=2:"TRANSMISSION DATES ",1:"OPERATION DATES ")_SRFRTO - I $E(IOST)="P" D ^SROALTP Q - S SRSOUT=0 D HDR - I SRSRT=2 F S SRSD=$O(^SRF("AT",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT S SRTN=0 F S SRTN=$O(^SRF("AT",SRSD,SRTN)) Q:'SRTN!SRSOUT D - .S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D SET - I SRSRT=1 F S SRSD=$O(^SRF("AC",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT S SRTN=0 F S SRTN=$O(^SRF("AC",SRSD,SRTN)) Q:'SRTN!SRSOUT D - .S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D SET - Q -SET ; print assessments - K SRCPTT,SREX S SRCPTT="NOT ENTERED",SREX="" - I $Y+5>IOSL D PAGE I SRSOUT Q - S SR("RA")=^SRF(SRTN,"RA") - I SRAST=1 Q:'($P(SR("RA"),"^",2)="N"!($P(SR("RA"),"^",2)="C"))!'($P(SR("RA"),"^",6)="Y") - I SRAST=2 Q:'($P(SR("RA"),"^",2)="N"!($P(SR("RA"),"^",2)="C"))!'($P(SR("RA"),"^",6)="N") - S SRAT="",Y=$E($P(SR("RA"),"^",8),1,7) S:Y="" Y=$E($P(SR("RA"),"^",4),1,7) I Y D D^DIQ S SRAT=Y - S SRA(0)=^SRF(SRTN,0),DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANM=VADM(1),SRASSN=VA("PID") K VADM - I $L(SRANM)>19 S SRANM=$P(SRANM,",")_","_$E($P(SRANM,",",2))_"." - S SROPER=$P(^SRF(SRTN,"OP"),"^") I $O(^SRF(SRTN,13,0)) S SROTHER=0 F I=0:0 S SROTHER=$O(^SRF(SRTN,13,SROTHER)) Q:'SROTHER D OTHER - S X=$P(SR("RA"),"^",2) I X="C" S SROPER="* "_SROPER - K SROPS,MM,MMM S:$L(SROPER)<34 SROPS(1)=SROPER I $L(SROPER)>33 S SROPER=SROPER_" " F M=1:1 D LOOP Q:MMM="" - S SRSS=$P(SRA(0),"^",4),SRSS=$S(SRSS:$P(^SRO(137.45,SRSS,0),"^"),1:"SPECIALTY NOT ENTERED") - D TECH^SROPRIN - S Y=$P(SRA(0),"^",9) D D^DIQ S SRDT=$P(Y,"@") - S X=$P(SR("RA"),"^",7) I X'="" S SREX="EXCLUDED" - W !,SRTN,?20,SRANM_" "_VA("PID"),?55,$P(SRSS,"("),!,SRDT,?20,SROPS(1),?55,SRTECH,!,SRAT I $D(SROPS(2)) W ?20,SROPS(2) I $D(SROPS(3)) W !,?20,SROPS(3) - N I,SRPROC,SRL S SRL=48 D CPTS^SROAUTL0 W:$D(SROPS(2)) ! W SREX,?20,"CPT Codes: " - F I=1:1 Q:'$D(SRPROC(I)) W:I=1 ?31,SRPROC(I) W:I'=1 !,?31,SRPROC(I) - W ! F LINE=1:1:80 W "-" - Q -OTHER ; other operations - S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,SROTHER,0),"^"))>125 S SRLONG=0,SROTHER=999,SROPERS=" ..." - I SRLONG S SROPERS=$P(^SRF(SRTN,13,SROTHER,0),"^") - S SROPER=SROPER_$S(SROPERS'=" ...":", "_SROPERS,1:SROPERS) - Q -LOOP ; break procedures - S SROPS(M)="" F LOOP=1:1 S MM=$P(SROPER," "),MMM=$P(SROPER," ",2,200) Q:MMM="" Q:$L(SROPS(M))+$L(MM)'<34 S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM - Q -PAGE W !!,"Press to continue, or '^' to quit " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q - I X["?" W !!,"If you want to continue listing incomplete assessments, enter . Enter",!,"'^' to return to the menu." G PAGE -HDR W @IOF,!,?26,"TRANSMITTED RISK ASSESSMENTS",!,?(80-$L(SRFRTO)\2),SRFRTO,!!,"ASSESSMENT #",?20,"PATIENT",?55,"SURGICAL SPECIALTY",!,"OPERATION DATE",?20,"OPERATION(S)",?55,"ANESTHESIA TECHNIQUE",!,"TRANSMISSION DATE",! F LINE=1:1:80 W "=" - Q +SROALT ;BIR/MAM - TRANSMITTED ASSESSMENTS ;01/18/07 + ;;3.0; Surgery ;**38,50,142,153,160**;24 Jun 93;Build 7 + I $E(IOST)="P" D ^SROALTP Q + S SRSOUT=0 D HDR + F S SRSD=$O(^SRF("AC",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT S SRTN=0 F S SRTN=$O(^SRF("AC",SRSD,SRTN)) Q:'SRTN!SRSOUT S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D SET + Q +SET ; print assessments + K SRCPTT S SRCPTT="NOT ENTERED" + I $Y+5>IOSL D PAGE I SRSOUT Q + S SRA(0)=^SRF(SRTN,0),DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANM=VADM(1),SRASSN=VA("PID") K VADM + I $L(SRANM)>19 S SRANM=$P(SRANM,",")_","_$E($P(SRANM,",",2))_"." + S SROPER=$P(^SRF(SRTN,"OP"),"^") I $O(^SRF(SRTN,13,0)) S SROTHER=0 F I=0:0 S SROTHER=$O(^SRF(SRTN,13,SROTHER)) Q:'SROTHER D OTHER + S X=$P($G(^SRF(SRTN,"RA")),"^",2) I X="C" S SROPER="* "_SROPER + K SROPS,MM,MMM S:$L(SROPER)<34 SROPS(1)=SROPER I $L(SROPER)>33 S SROPER=SROPER_" " F M=1:1 D LOOP Q:MMM="" + S SRSS=$P(SRA(0),"^",4),SRSS=$S(SRSS:$P(^SRO(137.45,SRSS,0),"^"),1:"SPECIALTY NOT ENTERED") + D TECH^SROPRIN + S Y=$P(SRA(0),"^",9) D D^DIQ S SRDT=$P(Y,"@") + W !,SRTN,?20,SRANM_" "_VA("PID"),?55,$P(SRSS,"("),!,SRDT,?20,SROPS(1),?55,SRTECH I $D(SROPS(2)) W !,?20,SROPS(2) I $D(SROPS(3)) W !,?20,SROPS(3) + N I,SRPROC,SRL S SRL=48 D CPTS^SROAUTL0 W !,?20,"CPT Codes: " + F I=1:1 Q:'$D(SRPROC(I)) W:I=1 ?31,SRPROC(I) W:I'=1 !,?31,SRPROC(I) + W ! F LINE=1:1:80 W "-" + Q +OTHER ; other operations + S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,SROTHER,0),"^"))>125 S SRLONG=0,SROTHER=999,SROPERS=" ..." + I SRLONG S SROPERS=$P(^SRF(SRTN,13,SROTHER,0),"^") + S SROPER=SROPER_$S(SROPERS'=" ...":", "_SROPERS,1:SROPERS) + Q +LOOP ; break procedures + S SROPS(M)="" F LOOP=1:1 S MM=$P(SROPER," "),MMM=$P(SROPER," ",2,200) Q:MMM="" Q:$L(SROPS(M))+$L(MM)'<34 S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM + Q +PAGE W !!,"Press to continue, or '^' to quit " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q + I X["?" W !!,"If you want to continue listing incomplete assessments, enter . Enter",!,"'^' to return to the menu." G PAGE +HDR W @IOF,!,?26,"TRANSMITTED RISK ASSESSMENTS",!,?(80-$L(SRFRTO)\2),SRFRTO,!!,"ASSESSMENT #",?20,"PATIENT",?55,"SURGICAL SPECIALTY",!,"OPERATION DATE",?20,"OPERATION(S)",?55,"ANESTHESIA TECHNIQUE",! F LINE=1:1:80 W "=" + Q diff --git a/r/SURGERY-SR/SROALTP.m b/r/SURGERY-SR/SROALTP.m index 4e21eeee..60ba409d 100644 --- a/r/SURGERY-SR/SROALTP.m +++ b/r/SURGERY-SR/SROALTP.m @@ -1,43 +1,35 @@ -SROALTP ;BIR/MAM - TRANSMITTED ASSESSMENTS (PRINTER) ;01/07/08 - ;;3.0; Surgery ;**32,50,142,153,160,166**;24 Jun 93;Build 7 - S SRPAGE=1,(SRSOUT,SRDFN)=0 D HDR Q:SRSOUT - I SRSRT=2 F S SRSD=$O(^SRF("AT",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT S SRTN=0 F S SRTN=$O(^SRF("AT",SRSD,SRTN)) Q:'SRTN!SRSOUT D - .S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D SET - I SRSRT=1 F S SRSD=$O(^SRF("AC",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT S SRTN=0 F S SRTN=$O(^SRF("AC",SRSD,SRTN)) Q:'SRTN!SRSOUT D - .S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D SET - Q -SET ; print assessments - K SRCPTT,SREX S SRCPTT="NOT ENTERED",SREX="" - I $Y+5>IOSL S SRPAGE=SRPAGE+1 D HDR I SRSOUT Q - S SR("RA")=^SRF(SRTN,"RA") - I SRAST=1 Q:'($P(SR("RA"),"^",2)="N"!($P(SR("RA"),"^",2)="C"))!'($P(SR("RA"),"^",6)="Y") - I SRAST=2 Q:'($P(SR("RA"),"^",2)="N"!($P(SR("RA"),"^",2)="C"))!'($P(SR("RA"),"^",6)="N") - S SRAT="",Y=$E($P(SR("RA"),"^",8),1,7) S:Y="" Y=$E($P(SR("RA"),"^",4),1,7) I Y D D^DIQ S SRAT=Y - S SRA(0)=^SRF(SRTN,0),DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANM=VADM(1),SRASSN=VA("PID") K VADM - S SROPER=$P(^SRF(SRTN,"OP"),"^") I $O(^SRF(SRTN,13,0)) S SROTHER=0 F S SROTHER=$O(^SRF(SRTN,13,SROTHER)) Q:'SROTHER D OTHER - S X=$P(SR("RA"),"^",2) I X="C" S SROPER="* "_SROPER - K SROPS,MM,MMM S:$L(SROPER)<81 SROPS(1)=SROPER I $L(SROPER)>80 S SROPER=SROPER_" " F M=1:1 D LOOP Q:MMM="" - S SRSS=$P(SRA(0),"^",4),SRSS=$S(SRSS:$P(^SRO(137.45,SRSS,0),"^"),1:"SPECIALTY NOT ENTERED") - S TYPE=$P(SR("RA"),"^",2) I SRSS="SPECIALTY NOT ENTERED",TYPE="C" S SRSS="N/A" - D TECH^SROPRIN - S Y=$P(SRA(0),"^",9) D D^DIQ S SRDT=$P(Y,"@") - S X=$P(SR("RA"),"^",7) I X'="" S SREX="EXCLUDED" - W !,SRTN,?20,SRANM_" "_VA("PID"),?67,$P(SRSS,"("),?107,SRTECH,!,SRDT,?20,SROPS(1),?107,SRAT I $D(SROPS(2)) W !,?20,SROPS(2) I $D(SROPS(3)) W !,?20,SROPS(3) I $D(SROPS(4)) W !,?20,SROPS(4) - N I,SRPROC,SRL S SRL=100 D CPTS^SROAUTL0 W !,SREX,?20,"CPT Codes: " - F I=1:1 Q:'$D(SRPROC(I)) W:I=1 ?31,SRPROC(I) W:I'=1 !,?31,SRPROC(I) - W ! F LINE=1:1:132 W "-" - Q -OTHER ; other operations - S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,SROTHER,0),"^"))>165 S SRLONG=0,SROTHER=999,SROPERS=" ..." - I SRLONG S SROPERS=$P(^SRF(SRTN,13,SROTHER,0),"^") - S SROPER=SROPER_$S(SROPERS'=" ...":", "_SROPERS,1:SROPERS) - Q -LOOP ; break procedures - S SROPS(M)="" F LOOP=1:1 S MM=$P(SROPER," "),MMM=$P(SROPER," ",2,200) Q:MMM="" Q:$L(SROPS(M))+$L(MM)'<44 S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM - Q -HDR ; print heading - I $D(ZTQUEUED) D ^SROSTOP I SRHALT S SRSOUT=1 Q - W:$Y @IOF W !,?52,"TRANSMITTED RISK ASSESSMENTS",?120,"PAGE "_SRPAGE,!,?(132-$L(SRINST)\2),SRINST,!,?58,"SURGERY SERVICE",?100,"DATE REVIEWED:" - W !,?(132-$L(SRFRTO)\2),SRFRTO,?100,"REVIEWED BY:" - W !!,"ASSESSMENT #",?20,"PATIENT",?67,"SURGICAL SPECIALTY",?107,"ANESTHESIA TECHNIQUE",!,"OPERATION DATE",?20,"OPERATIVE PROCEDURE(S)",?107,"TRANSMISSION DATE",! F LINE=1:1:132 W "=" - Q +SROALTP ;BIR/MAM - TRANSMITTED ASSESSMENTS (PRINTER) ;01/18/07 + ;;3.0; Surgery ;**32,50,142,153,160**;24 Jun 93;Build 7 + S SRPAGE=1,(SRSOUT,SRDFN)=0 D HDR Q:SRSOUT + F S SRSD=$O(^SRF("AC",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT S SRTN=0 F S SRTN=$O(^SRF("AC",SRSD,SRTN)) Q:'SRTN!SRSOUT S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D SET + Q +SET ; print assessments + K SRCPTT S SRCPTT="NOT ENTERED" + I $Y+5>IOSL S SRPAGE=SRPAGE+1 D HDR I SRSOUT Q + S SRA(0)=^SRF(SRTN,0),DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANM=VADM(1),SRASSN=VA("PID") K VADM + S SROPER=$P(^SRF(SRTN,"OP"),"^") I $O(^SRF(SRTN,13,0)) S SROTHER=0 F S SROTHER=$O(^SRF(SRTN,13,SROTHER)) Q:'SROTHER D OTHER + S X=$P($G(^SRF(SRTN,"RA")),"^",2) I X="C" S SROPER="* "_SROPER + K SROPS,MM,MMM S:$L(SROPER)<81 SROPS(1)=SROPER I $L(SROPER)>80 S SROPER=SROPER_" " F M=1:1 D LOOP Q:MMM="" + S SRSS=$P(SRA(0),"^",4),SRSS=$S(SRSS:$P(^SRO(137.45,SRSS,0),"^"),1:"SPECIALTY NOT ENTERED") + S TYPE=$P(SR("RA"),"^",2) I SRSS="SPECIALTY NOT ENTERED",TYPE="C" S SRSS="N/A" + D TECH^SROPRIN + S Y=$P(SRA(0),"^",9) D D^DIQ S SRDT=$P(Y,"@") + W !,SRTN,?20,SRANM_" "_VA("PID"),?67,$P(SRSS,"("),?107,SRTECH,!,SRDT,?20,SROPS(1) I $D(SROPS(2)) W !,?20,SROPS(2) I $D(SROPS(3)) W !,?20,SROPS(3) I $D(SROPS(4)) W !,?20,SROPS(4) + N I,SRPROC,SRL S SRL=100 D CPTS^SROAUTL0 W !,?20,"CPT Codes: " + F I=1:1 Q:'$D(SRPROC(I)) W:I=1 ?31,SRPROC(I) W:I'=1 !,?31,SRPROC(I) + W ! F LINE=1:1:132 W "-" + Q +OTHER ; other operations + S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,SROTHER,0),"^"))>165 S SRLONG=0,SROTHER=999,SROPERS=" ..." + I SRLONG S SROPERS=$P(^SRF(SRTN,13,SROTHER,0),"^") + S SROPER=SROPER_$S(SROPERS'=" ...":", "_SROPERS,1:SROPERS) + Q +LOOP ; break procedures + S SROPS(M)="" F LOOP=1:1 S MM=$P(SROPER," "),MMM=$P(SROPER," ",2,200) Q:MMM="" Q:$L(SROPS(M))+$L(MM)'<44 S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM + Q +HDR ; print heading + I $D(ZTQUEUED) D ^SROSTOP I SRHALT S SRSOUT=1 Q + W:$Y @IOF W !,?52,"TRANSMITTED RISK ASSESSMENTS",?120,"PAGE "_SRPAGE,!,?(132-$L(SRINST)\2),SRINST,!,?58,"SURGERY SERVICE",?100,"DATE REVIEWED:" + W !,?(132-$L(SRFRTO)\2),SRFRTO,?100,"REVIEWED BY:" + W !!,"ASSESSMENT #",?20,"PATIENT",?67,"SURGICAL SPECIALTY",?107,"ANESTHESIA TECHNIQUE",!,"OPERATION DATE",?20,"OPERATIVE PROCEDURE(S)",! F LINE=1:1:132 W "=" + Q diff --git a/r/SURGERY-SR/SROALTS.m b/r/SURGERY-SR/SROALTS.m index 4aa4bd67..8813d73e 100644 --- a/r/SURGERY-SR/SROALTS.m +++ b/r/SURGERY-SR/SROALTS.m @@ -1,54 +1,45 @@ -SROALTS ;BIR/MAM - TRANSMITTED ASSESSMENTS ;01/07/08 - ;;3.0; Surgery ;**38,50,142,153,160,166**;24 Jun 93;Build 7 - S SRFRTO=$S(SRSRT=2:"TRANSMISSION DATES ",1:"OPERATION DATES ")_SRFRTO - I $E(IOST)="P" D ^SROALTSP Q - S SRSOUT=0 D HDR - I SRSRT=2 F S SRSD=$O(^SRF("AT",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT S SRTN=0 F S SRTN=$O(^SRF("AT",SRSD,SRTN)) Q:'SRTN!SRSOUT D - .S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D UTL - I SRSRT=1 F S SRSD=$O(^SRF("AC",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT S SRTN=0 F S SRTN=$O(^SRF("AC",SRSD,SRTN)) Q:'SRTN!SRSOUT D - .S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D UTL - S SRSS="" F S SRSS=$O(^TMP("SRA",$J,SRSS)) Q:SRSS=""!SRSOUT D SS S SRTN=0 F J=0:0 S SRTN=$O(^TMP("SRA",$J,SRSS,SRTN)) Q:'SRTN!SRSOUT D SET - I '$D(^TMP("SRA",$J)) W $$NODATA^SROUTL0() - Q -UTL ; write to ^TMP("SRA",$J) - I SRFLG,$P(^SRF(SRTN,0),"^",4)'=SRASP Q - S SRSS=$P(^SRF(SRTN,0),"^",4),SRSS=$S(SRSS:$P(^SRO(137.45,SRSS,0),"^"),1:"SPECIALTY NOT ENTERED") - S SR("RA")=^SRF(SRTN,"RA") - I SRAST=1 Q:'($P(SR("RA"),"^",2)="N"!($P(SR("RA"),"^",2)="C"))!'($P(SR("RA"),"^",6)="Y") - I SRAST=2 Q:'($P(SR("RA"),"^",2)="N"!($P(SR("RA"),"^",2)="C"))!'($P(SR("RA"),"^",6)="N") - S ^TMP("SRA",$J,SRSS,SRTN)="" - Q -SET ; print assessments - K SRCPTT,SREX S SRCPTT="NOT ENTERED",SREX="" - I $Y+5>IOSL D PAGE I SRSOUT Q - S SR("RA")=^SRF(SRTN,"RA") - S SRAT="",Y=$E($P(SR("RA"),"^",8),1,7) S:Y="" Y=$E($P(SR("RA"),"^",4),1,7) I Y D D^DIQ S SRAT=Y - S SRA(0)=^SRF(SRTN,0),DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANM=VADM(1),SRASSN=VA("PID") K VADM - I $L(SRANM)>19 S SRANM=$P(SRANM,",")_","_$E($P(SRANM,",",2))_"." - S SROPER=$P(^SRF(SRTN,"OP"),"^") I $O(^SRF(SRTN,13,0)) S SROTHER=0 F I=0:0 S SROTHER=$O(^SRF(SRTN,13,SROTHER)) Q:'SROTHER D OTHER - S X=$P(SR("RA"),"^",2) I X="C" S SROPER="* "_SROPER - K SROPS,MM,MMM S:$L(SROPER)<34 SROPS(1)=SROPER I $L(SROPER)>33 S SROPER=SROPER_" " F M=1:1 D LOOP Q:MMM="" - D TECH^SROPRIN - S Y=$P(SRA(0),"^",9) D D^DIQ S SRDT=$P(Y,"@") - S X=$P(SR("RA"),"^",7) I X'="" S SREX="EXCLUDED" - W !,SRTN,?20,SRANM_" "_VA("PID"),?55,SRAT,!,SRDT,?20,SROPS(1),?55,SRTECH S SRAO=1 F I=0:0 S SRAO=$O(SROPS(SRAO)) Q:'SRAO W !,?20,SROPS(SRAO) - N I,SRPROC,SRL S SRL=48 D CPTS^SROAUTL0 W !,SREX,?20,"CPT Codes: " - F I=1:1 Q:'$D(SRPROC(I)) W:I=1 ?31,SRPROC(I) W:I'=1 !,?31,SRPROC(I) - W ! F LINE=1:1:80 W "-" - Q -OTHER ; other operations - S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,SROTHER,0),"^"))>125 S SRLONG=0,SROTHER=999,SROPERS=" ..." - I SRLONG S SROPERS=$P(^SRF(SRTN,13,SROTHER,0),"^") - S SROPER=SROPER_$S(SROPERS'=" ...":", "_SROPERS,1:SROPERS) - Q -LOOP ; break procedures - S SROPS(M)="" F LOOP=1:1 S MM=$P(SROPER," "),MMM=$P(SROPER," ",2,200) Q:MMM="" Q:$L(SROPS(M))+$L(MM)'<34 S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM - Q -PAGE W !!,"Press to continue, or '^' to quit " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q - I X["?" W !!,"If you want to continue listing incomplete assessments, enter . Enter",!,"'^' to return to the menu." G PAGE -HDR W @IOF,!,?26,"TRANSMITTED RISK ASSESSMENTS",!,?(80-$L(SRFRTO)\2),SRFRTO,!!,"ASSESSMENT #",?20,"PATIENT",?55,"TRANSMISSION DATE",!,"OPERATION DATE",?20,"OPERATION(S)",?55,"ANESTHESIA TECHNIQUE",! F LINE=1:1:80 W "=" - Q -SS ; print surgical specialty - I $Y+5>IOSL D PAGE Q:SRSOUT - W !!,"** SURGICAL SPECIALTY: ",SRSS," **",! - Q +SROALTS ;BIR/MAM - TRANSMITTED ASSESSMENTS ;01/18/07 + ;;3.0; Surgery ;**38,50,142,153,160**;24 Jun 93;Build 7 + I $E(IOST)="P" D ^SROALTSP Q + S SRSOUT=0 D HDR + F S SRSD=$O(^SRF("AC",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT S SRTN=0 F S SRTN=$O(^SRF("AC",SRSD,SRTN)) Q:'SRTN!SRSOUT S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D UTL + S SRSS="" F S SRSS=$O(^TMP("SRA",$J,SRSS)) Q:SRSS=""!SRSOUT D SS S SRTN=0 F J=0:0 S SRTN=$O(^TMP("SRA",$J,SRSS,SRTN)) Q:'SRTN!SRSOUT D SET + I '$D(^TMP("SRA",$J)) W $$NODATA^SROUTL0() + Q +UTL ; write to ^TMP("SRA",$J) + I SRFLG,$P(^SRF(SRTN,0),"^",4)'=SRASP Q + S SRSS=$P(^SRF(SRTN,0),"^",4),SRSS=$S(SRSS:$P(^SRO(137.45,SRSS,0),"^"),1:"SPECIALTY NOT ENTERED") + S ^TMP("SRA",$J,SRSS,SRTN)="" + Q +SET ; print assessments + K SRCPTT S SRCPTT="NOT ENTERED" + I $Y+5>IOSL D PAGE I SRSOUT Q + S SR("RA")=^SRF(SRTN,"RA"),SRAT="",Y=$E($P(SR("RA"),"^",4),1,7) I Y D D^DIQ S SRAT=Y + S SRA(0)=^SRF(SRTN,0),DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANM=VADM(1),SRASSN=VA("PID") K VADM + I $L(SRANM)>19 S SRANM=$P(SRANM,",")_","_$E($P(SRANM,",",2))_"." + S SROPER=$P(^SRF(SRTN,"OP"),"^") I $O(^SRF(SRTN,13,0)) S SROTHER=0 F I=0:0 S SROTHER=$O(^SRF(SRTN,13,SROTHER)) Q:'SROTHER D OTHER + S X=$P($G(^SRF(SRTN,"RA")),"^",2) I X="C" S SROPER="* "_SROPER + K SROPS,MM,MMM S:$L(SROPER)<34 SROPS(1)=SROPER I $L(SROPER)>33 S SROPER=SROPER_" " F M=1:1 D LOOP Q:MMM="" + D TECH^SROPRIN + S Y=$P(SRA(0),"^",9) D D^DIQ S SRDT=$P(Y,"@") + W !,SRTN,?20,SRANM_" "_VA("PID"),?55,SRAT,!,SRDT,?20,SROPS(1),?55,SRTECH S SRAO=1 F I=0:0 S SRAO=$O(SROPS(SRAO)) Q:'SRAO W !,?20,SROPS(SRAO) + N I,SRPROC,SRL S SRL=48 D CPTS^SROAUTL0 W !,?20,"CPT Codes: " + F I=1:1 Q:'$D(SRPROC(I)) W:I=1 ?31,SRPROC(I) W:I'=1 !,?31,SRPROC(I) + W ! F LINE=1:1:80 W "-" + Q +OTHER ; other operations + S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,SROTHER,0),"^"))>125 S SRLONG=0,SROTHER=999,SROPERS=" ..." + I SRLONG S SROPERS=$P(^SRF(SRTN,13,SROTHER,0),"^") + S SROPER=SROPER_$S(SROPERS'=" ...":", "_SROPERS,1:SROPERS) + Q +LOOP ; break procedures + S SROPS(M)="" F LOOP=1:1 S MM=$P(SROPER," "),MMM=$P(SROPER," ",2,200) Q:MMM="" Q:$L(SROPS(M))+$L(MM)'<34 S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM + Q +PAGE W !!,"Press to continue, or '^' to quit " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q + I X["?" W !!,"If you want to continue listing incomplete assessments, enter . Enter",!,"'^' to return to the menu." G PAGE +HDR W @IOF,!,?26,"TRANSMITTED RISK ASSESSMENTS",!,?(80-$L(SRFRTO)\2),SRFRTO,!!,"ASSESSMENT #",?20,"PATIENT",?55,"TRANSMISSION DATE",!,"OPERATION DATE",?20,"OPERATION(S)",?55,"ANESTHESIA TECHNIQUE",! F LINE=1:1:80 W "=" + Q +SS ; print surgical specialty + I $Y+5>IOSL D PAGE Q:SRSOUT + W !!,"** SURGICAL SPECIALTY: ",SRSS," **",! + Q diff --git a/r/SURGERY-SR/SROALTSP.m b/r/SURGERY-SR/SROALTSP.m index fe33c063..e1c285d8 100644 --- a/r/SURGERY-SR/SROALTSP.m +++ b/r/SURGERY-SR/SROALTSP.m @@ -1,56 +1,48 @@ -SROALTSP ;BIR/MAM - TRANSMITTED ASSESSMENTS (PRINTER) ;01/07/08 - ;;3.0; Surgery ;**32,50,142,153,160,166**;24 Jun 93;Build 7 - K ^TMP("SRA",$J) S SRPAGE=0,(SRSOUT,SRDFN)=0 D HDR Q:SRSOUT - I SRSRT=2 F S SRSD=$O(^SRF("AT",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT S SRTN=0 F S SRTN=$O(^SRF("AT",SRSD,SRTN)) Q:'SRTN!SRSOUT D - .S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D UTL - I SRSRT=1 F S SRSD=$O(^SRF("AC",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT S SRTN=0 F S SRTN=$O(^SRF("AC",SRSD,SRTN)) Q:'SRTN!SRSOUT D - .S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D UTL - S SRSS="" F S SRSS=$O(^TMP("SRA",$J,SRSS)) Q:SRSS=""!SRSOUT D SS S SRTN=0 F S SRTN=$O(^TMP("SRA",$J,SRSS,SRTN)) Q:'SRTN!SRSOUT D SET - I '$D(^TMP("SRA",$J)) W $$NODATA^SROUTL0() - Q -UTL ; write to ^TMP("SRA",$J) - I SRFLG,$P(^SRF(SRTN,0),"^",4)'=SRASP Q - S SRSS=$P(^SRF(SRTN,0),"^",4),SRSS=$S(SRSS:$P(^SRO(137.45,SRSS,0),"^"),1:"SPECIALTY NOT ENTERED") - S TYPE=$P(SR("RA"),"^",2) I SRSS="SPECIALTY NOT ENTERED",TYPE="C" S SRSS="N/A" - S SR("RA")=^SRF(SRTN,"RA") - I SRAST=1 Q:'($P(SR("RA"),"^",2)="N"!($P(SR("RA"),"^",2)="C"))!'($P(SR("RA"),"^",6)="Y") - I SRAST=2 Q:'($P(SR("RA"),"^",2)="N"!($P(SR("RA"),"^",2)="C"))!'($P(SR("RA"),"^",6)="N") - S ^TMP("SRA",$J,SRSS,SRTN)="" - Q -SET ; print assessments - K SRCPTT,SREX S SRCPTT="NOT ENTERED",SREX="" - I $Y+5>IOSL D HDR I SRSOUT Q - S SR("RA")=^SRF(SRTN,"RA") - S SRAT="",Y=$E($P(SR("RA"),"^",8),1,7) S:Y="" Y=$E($P(SR("RA"),"^",4),1,7) I Y D D^DIQ S SRAT=Y - S SRA(0)=^SRF(SRTN,0),DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANM=VADM(1),SRASSN=VA("PID") K VADM - S SROPER=$P(^SRF(SRTN,"OP"),"^") I $O(^SRF(SRTN,13,0)) S SROTHER=0 F S SROTHER=$O(^SRF(SRTN,13,SROTHER)) Q:'SROTHER D OTHER - S X=$P(SR("RA"),"^",2) I X="C" S SROPER="* "_SROPER - K SROPS,MM,MMM S:$L(SROPER)<81 SROPS(1)=SROPER I $L(SROPER)>80 S SROPER=SROPER_" " F M=1:1 D LOOP Q:MMM="" - D TECH^SROPRIN - S Y=$P(SRA(0),"^",9) D D^DIQ S SRDT=$P(Y,"@") - S X=$P(SR("RA"),"^",7) I X'="" S SREX="EXCLUDED" - W !,SRTN,?20,SRANM_" "_VA("PID"),?67,SRAT,?107,SRTECH,!,SRDT,?20,SROPS(1) S SRAO=1 F S SRAO=$O(SROPS(SRAO)) Q:'SRAO W !,?20,SROPS(SRAO) - N I,SRPROC,SRL S SRL=100 D CPTS^SROAUTL0 W !,SREX,?20,"CPT Codes: " - F I=1:1 Q:'$D(SRPROC(I)) W:I=1 ?31,SRPROC(I) W:I'=1 !,?31,SRPROC(I) - D LINE - Q -OTHER ; other operations - S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,SROTHER,0),"^"))>165 S SRLONG=0,SROTHER=999,SROPERS=" ..." - I SRLONG S SROPERS=$P(^SRF(SRTN,13,SROTHER,0),"^") - S SROPER=SROPER_$S(SROPERS'=" ...":", "_SROPERS,1:SROPERS) - Q -LOOP ; break procedures - S SROPS(M)="" F LOOP=1:1 S MM=$P(SROPER," "),MMM=$P(SROPER," ",2,200) Q:MMM="" Q:$L(SROPS(M))+$L(MM)'<44 S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM - Q -HDR ; print heading - I $D(ZTQUEUED) D ^SROSTOP I SRHALT S SRSOUT=1 Q - S SRPAGE=SRPAGE+1 W:$Y @IOF W !,?52,"TRANSMITTED RISK ASSESSMENTS",?120,"PAGE "_SRPAGE,!,?(132-$L(SRINST)\2),SRINST,!,?58,"SURGERY SERVICE",?100,"DATE REVIEWED:" - W !,?(132-$L(SRFRTO)\2),SRFRTO,?100,"REVIEWED BY:" - W !!,"ASSESSMENT #",?20,"PATIENT",?67,"TRANSMISSION DATE",?107,"ANESTHESIA TECHNIQUE",!,"OPERATION DATE",?20,"OPERATIVE PROCEDURE(S)",! F LINE=1:1:132 W "=" - Q -SS ;print surgical specialty - I $Y+5>IOSL D HDR - W !!,"** SURGICAL SPECIALTY: ",SRSS," **",! - Q -LINE W ! F L=1:1:132 W "-" - Q +SROALTSP ;BIR/MAM - TRANSMITTED ASSESSMENTS (PRINTER) ;01/18/07 + ;;3.0; Surgery ;**32,50,142,153,160**;24 Jun 93;Build 7 + K ^TMP("SRA",$J) S SRPAGE=0,(SRSOUT,SRDFN)=0 D HDR Q:SRSOUT + F S SRSD=$O(^SRF("AC",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT S SRTN=0 F S SRTN=$O(^SRF("AC",SRSD,SRTN)) Q:'SRTN!SRSOUT S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D UTL + S SRSS="" F S SRSS=$O(^TMP("SRA",$J,SRSS)) Q:SRSS=""!SRSOUT D SS S SRTN=0 F S SRTN=$O(^TMP("SRA",$J,SRSS,SRTN)) Q:'SRTN!SRSOUT D SET + I '$D(^TMP("SRA",$J)) W $$NODATA^SROUTL0() + Q +UTL ; write to ^TMP("SRA",$J) + I SRFLG,$P(^SRF(SRTN,0),"^",4)'=SRASP Q + S SRSS=$P(^SRF(SRTN,0),"^",4),SRSS=$S(SRSS:$P(^SRO(137.45,SRSS,0),"^"),1:"SPECIALTY NOT ENTERED") + S TYPE=$P(SR("RA"),"^",2) I SRSS="SPECIALTY NOT ENTERED",TYPE="C" S SRSS="N/A" + S ^TMP("SRA",$J,SRSS,SRTN)="" + Q +SET ; print assessments + K SRCPTT S SRCPTT="NOT ENTERED" + I $Y+5>IOSL D HDR I SRSOUT Q + S SR("RA")=^SRF(SRTN,"RA"),SRAT="",Y=$E($P(SR("RA"),"^",4),1,7) I Y D D^DIQ S SRAT=Y + S SRA(0)=^SRF(SRTN,0),DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANM=VADM(1),SRASSN=VA("PID") K VADM + S SROPER=$P(^SRF(SRTN,"OP"),"^") I $O(^SRF(SRTN,13,0)) S SROTHER=0 F S SROTHER=$O(^SRF(SRTN,13,SROTHER)) Q:'SROTHER D OTHER + S X=$P($G(^SRF(SRTN,"RA")),"^",2) I X="C" S SROPER="* "_SROPER + K SROPS,MM,MMM S:$L(SROPER)<81 SROPS(1)=SROPER I $L(SROPER)>80 S SROPER=SROPER_" " F M=1:1 D LOOP Q:MMM="" + D TECH^SROPRIN + S Y=$P(SRA(0),"^",9) D D^DIQ S SRDT=$P(Y,"@") + W !,SRTN,?20,SRANM_" "_VA("PID"),?67,SRAT,?107,SRTECH,!,SRDT,?20,SROPS(1) S SRAO=1 F S SRAO=$O(SROPS(SRAO)) Q:'SRAO W !,?20,SROPS(SRAO) + N I,SRPROC,SRL S SRL=100 D CPTS^SROAUTL0 W !,?20,"CPT Codes: " + F I=1:1 Q:'$D(SRPROC(I)) W:I=1 ?31,SRPROC(I) W:I'=1 !,?31,SRPROC(I) + D LINE + Q +OTHER ; other operations + S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,SROTHER,0),"^"))>165 S SRLONG=0,SROTHER=999,SROPERS=" ..." + I SRLONG S SROPERS=$P(^SRF(SRTN,13,SROTHER,0),"^") + S SROPER=SROPER_$S(SROPERS'=" ...":", "_SROPERS,1:SROPERS) + Q +LOOP ; break procedures + S SROPS(M)="" F LOOP=1:1 S MM=$P(SROPER," "),MMM=$P(SROPER," ",2,200) Q:MMM="" Q:$L(SROPS(M))+$L(MM)'<44 S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM + Q +HDR ; print heading + I $D(ZTQUEUED) D ^SROSTOP I SRHALT S SRSOUT=1 Q + S SRPAGE=SRPAGE+1 W:$Y @IOF W !,?52,"TRANSMITTED RISK ASSESSMENTS",?120,"PAGE "_SRPAGE,!,?(132-$L(SRINST)\2),SRINST,!,?58,"SURGERY SERVICE",?100,"DATE REVIEWED:" + W !,?(132-$L(SRFRTO)\2),SRFRTO,?100,"REVIEWED BY:" + W !!,"ASSESSMENT #",?20,"PATIENT",?67,"TRANSMISSION DATE",?107,"ANESTHESIA TECHNIQUE",!,"OPERATION DATE",?20,"OPERATIVE PROCEDURE(S)",! F LINE=1:1:132 W "=" + Q +SS ;print surgical specialty + I $Y+5>IOSL D HDR + W !!,"** SURGICAL SPECIALTY: ",SRSS," **",! + Q +LINE W ! F L=1:1:132 W "-" + Q diff --git a/r/SURGERY-SR/SROAMEAS.m b/r/SURGERY-SR/SROAMEAS.m index d24f928f..4e262f39 100644 --- a/r/SURGERY-SR/SROAMEAS.m +++ b/r/SURGERY-SR/SROAMEAS.m @@ -1,16 +1,12 @@ -SROAMEAS ;BIR/MAM - INPUT TRANSFORMS, HEIGHT & WEIGHT ;03/20/06 - ;;3.0; Surgery ;**38,125,153,166**;24 Jun 93;Build 7 -H Q:'$D(X) I X'?.N1"C"&(X'?.N1"c"),(+X'=X) K X Q - I +X=X S X=X+.5\1 I X'>47.9!(X'<86.1) K X Q - S:X["c" X=+X_"C" - I X?.N1"C",(X'>121.9!(X'<218.1)) K X - Q -W Q:'$D(X) I +X'=X,(X'?.N1"K")&(X'?.N1"k") K X Q - I +X=X S X=X+.5\1 I X'>49.9!(X'<700.1) K X Q - S:X["k" X=+X_"K" - I X?.N1"K",(X'>22.9!(X'<318.1)) K X - Q -HWC ; reject NS entry if the case is cardiac one - S X=$S(X="ns":"NS",1:X) - I $P($G(^SRF($S($G(SRTN):SRTN,1:DA),"RA")),"^",2)="C",X="NS" S X="" - Q +SROAMEAS ;BIR/MAM - INPUT TRANSFORMS, HEIGHT & WEIGHT ;03/20/06 + ;;3.0; Surgery ;**38,125,153**;24 Jun 93;Build 11 +H Q:'$D(X) I X'?.N1"C"&(X'?.N1"c"),(+X'=X) K X Q + I +X=X S X=X+.5\1 I X'>47.9!(X'<86.1) K X Q + S:X["c" X=+X_"C" + I X?.N1"C",(X'>121.9!(X'<218.1)) K X + Q +W Q:'$D(X) I +X'=X,(X'?.N1"K")&(X'?.N1"k") K X Q + I +X=X S X=X+.5\1 I X'>49.9!(X'<700.1) K X Q + S:X["k" X=+X_"K" + I X?.N1"K",(X'>22.9!(X'<318.1)) K X + Q diff --git a/r/SURGERY-SR/SROAMIS.m b/r/SURGERY-SR/SROAMIS.m index 19756bb8..c62ab899 100644 --- a/r/SURGERY-SR/SROAMIS.m +++ b/r/SURGERY-SR/SROAMIS.m @@ -1,50 +1,48 @@ -SROAMIS ;BIR/MAM - ANESTHESIA AMIS REPORT ;11/26/07 - ;;3.0; Surgery ;**22,34,38,77,50,86,166**;24 Jun 93;Build 7 -UTL ; set up ^TMP("SROAMIS",$J - S PRIN=$P($G(^SRF(SRDFN,.3)),"^",8) I PRIN="" S PRIN="O" - S PROC=$S($D(^SRF(SRDFN,31)):$P(^(31),"^",9),1:""),DEATH="" - S:PRIN="O" TECH="L" I TECH="L",PRIN'="O" S TECH="O" - S S(0)=^SRF(SRDFN,0),DFN=$P(S(0),"^") S DEATH=$S('$D(^DPT(DFN,.35)):"",$P(^DPT(DFN,.35),"^")="":"",1:$P(^(.35),"^")) - I +DEATH S:$D(^TMP("SRTN",$J,DFN)) DEATH="" I +DEATH D DEAD - S $P(^TMP("SROAMIS",$J,"T",TECH),"^")=^TMP("SROAMIS",$J,"T",TECH)+1 I DEATH'="" S $P(^(TECH),"^",2)=$P(^(TECH),"^",2)+1 - I PROC'="Y" S $P(^TMP("SROAMIS",$J,"P","SURG",PRIN),"^")=$P(^TMP("SROAMIS",$J,"P","SURG",PRIN),"^")+1 S:DEATH'="" $P(^(PRIN),"^",2)=$P(^(PRIN),"^",2)+1 - I PROC="Y" S $P(^TMP("SROAMIS",$J,"P","DIAG",PRIN),"^")=$P(^TMP("SROAMIS",$J,"P","DIAG",PRIN),"^")+1 S:DEATH'="" $P(^(PRIN),"^",2)=$P(^(PRIN),"^",2)+1 - Q -SET ; get anesthesia info from ^SRF(SRDFN,6 - K SRTECH S (SRCNT,SRT,SRZ)=0,SRTN=SRDFN F S SRT=$O(^SRF(SRDFN,6,SRT)) Q:SRT=""!(SRZ) D ^SROPRIN S SRCNT=SRCNT+1 - I '$D(SRTECH),SRCNT=1 S SRT=$O(^SRF(SRTN,6,0)),SRTECH=$P(^SRF(SRTN,6,SRT,0),"^") - K SRTN I $D(SRTECH) Q:SRTECH="N" S TECH=SRTECH D UTL - Q -HDR ; print heading - I $D(ZTQUEUED) D ^SROSTOP I SRHALT S SRSOUT=1 Q - W:$Y @IOF W !,?(132-$L(SRINST)\2),SRINST,!,?57,"ANESTHESIA SERVICE",?100,"REVIEWED BY: ",!,?58,"ANESTHESIA AMIS",?100,"DATE REVIEWED: " - W !,?(132-$L(SRFRTO)\2),SRFRTO,?100,SRPRINT - W !!!!! F I=1:1:IOM W "=" - W !,?38,"ANESTHETICS ADMINISTERED BY PRINCIPAL TECHNIQUE USED",! F I=1:1:IOM W "-" - W !,"TOTAL NO OF ANES- | | | | | |" - W !,"THETICS ADMINISTERED | GENERAL | MAC | SPINAL | EPIDURAL | OTHER | LOCAL",! F I=1:1:IOM W "-" - Q -END W:$E(IOST)="P" @IOF K ^TMP("SROAMIS",$J),^TMP("SRTN",$J) I $D(ZTQUEUED) Q:$G(ZTSTOP) S ZTREQ="@" Q - D ^%ZISC,^SRSKILL W @IOF - Q -DEAD ; check for death within 24 hrs. - S OPDATE=$S($D(^SRF(SRDFN,.2)):$P(^(.2),"^"),1:"") S:OPDATE="" OPDATE=$P(^SRF(SRDFN,0),"^",9) S X1=OPDATE,X2=1 D C^%DTC S OPONE=X S DEATH=$S(DEATH<(OPONE+.0001):1,1:"") - I DEATH S ^TMP("SRTN",$J,DFN)="" - Q -EN ; entry for SROAMIS option - W @IOF,!,"Anesthesia AMIS",!!,"This report is no longer available.",! - K DIR S DIR(0)="E" D ^DIR K DIR D END - Q -DATE D DATE^SROUTL(.SDATE,.EDATE,.SRSOUT) G:SRSOUT END S SRD=SDATE-.0001 - N SRINSTP S SRINST=$$INST^SROUTL0() G:SRINST="^" END S SRINSTP=$P(SRINST,U),SRINST=$S(SRINST["ALL DIVISIONS":SRINST,1:$P(SRINST,U,2)) - W !!!,"This report is designed to use a 132 column format, and must be run",!,"on a printer.",!! -PTR K IOP,%ZIS,POP,IO("Q") S %ZIS("A")="Select Printer: ",%ZIS="QM" D ^%ZIS G:POP END W:$E(IOST)'="P" !!,"This report must be run on a printer.",!! G:$E(IOST)'="P" PTR - I $D(IO("Q")) K IO("Q") S ZTDESC="ANESTHESIA AMIS",ZTRTN="1^SROAMIS",(ZTSAVE("EDATE"),ZTSAVE("SDATE"),ZTSAVE("SRD"),ZTSAVE("SRINST"),ZTSAVE("SRINSTP"))="" D ^%ZTLOAD G END -1 ; entry when queued - U IO N SRFRTO K ^TMP("SROAMIS",$J),^TMP("SRTN",$J) S SRSOUT=0,Y=DT X ^DD("DD") S SRPRINT="DATE PRINTED: "_Y - S Y=SDATE X ^DD("DD") S SRFRTO="FROM: "_Y_" TO: ",Y=EDATE X ^DD("DD") S SRFRTO=SRFRTO_Y - F I="G","M","S","E","O","L" S ^TMP("SROAMIS",$J,"T",I)=0 F I="A","N","O" S ^TMP("SROAMIS",$J,"P","DIAG",I)=0,^TMP("SROAMIS",$J,"P","SURG",I)=0 K I - S SRDFN=0,Z=SRD F S Z=$O(^SRF("AC",Z)) Q:Z>(EDATE+.9999)!(Z="") F S SRDFN=$O(^SRF("AC",Z,SRDFN)) Q:SRDFN="" D - .I $D(^SRF(SRDFN,0)),$P($G(^SRF(SRDFN,.2)),"^",12)'=""!($P($G(^SRF(SRDFN,"NON")),"^")="Y"),$$MANDIV^SROUTL0(SRINSTP,SRDFN) D SET - D HDR G:SRSOUT END D PRINT^SROAMIS1 - G END +SROAMIS ;B'HAM ISC/MAM - ANESTHESIA AMIS REPORT ; [ 12/16/98 2:06 PM ] + ;;3.0; Surgery ;**22,34,38,77,50,86**;24 Jun 93 +UTL ; set up ^TMP("SROAMIS",$J + S PRIN=$P($G(^SRF(SRDFN,.3)),"^",8) I PRIN="" S PRIN="O" + S PROC=$S($D(^SRF(SRDFN,31)):$P(^(31),"^",9),1:""),DEATH="" + S:PRIN="O" TECH="L" I TECH="L",PRIN'="O" S TECH="O" + S S(0)=^SRF(SRDFN,0),DFN=$P(S(0),"^") S DEATH=$S('$D(^DPT(DFN,.35)):"",$P(^DPT(DFN,.35),"^")="":"",1:$P(^(.35),"^")) + I +DEATH S:$D(^TMP("SRTN",$J,DFN)) DEATH="" I +DEATH D DEAD + S $P(^TMP("SROAMIS",$J,"T",TECH),"^")=^TMP("SROAMIS",$J,"T",TECH)+1 I DEATH'="" S $P(^(TECH),"^",2)=$P(^(TECH),"^",2)+1 + I PROC'="Y" S $P(^TMP("SROAMIS",$J,"P","SURG",PRIN),"^")=$P(^TMP("SROAMIS",$J,"P","SURG",PRIN),"^")+1 S:DEATH'="" $P(^(PRIN),"^",2)=$P(^(PRIN),"^",2)+1 + I PROC="Y" S $P(^TMP("SROAMIS",$J,"P","DIAG",PRIN),"^")=$P(^TMP("SROAMIS",$J,"P","DIAG",PRIN),"^")+1 S:DEATH'="" $P(^(PRIN),"^",2)=$P(^(PRIN),"^",2)+1 + Q +SET ; get anesthesia info from ^SRF(SRDFN,6 + K SRTECH S (SRCNT,SRT,SRZ)=0,SRTN=SRDFN F S SRT=$O(^SRF(SRDFN,6,SRT)) Q:SRT=""!(SRZ) D ^SROPRIN S SRCNT=SRCNT+1 + I '$D(SRTECH),SRCNT=1 S SRT=$O(^SRF(SRTN,6,0)),SRTECH=$P(^SRF(SRTN,6,SRT,0),"^") + K SRTN I $D(SRTECH) Q:SRTECH="N" S TECH=SRTECH D UTL + Q +HDR ; print heading + I $D(ZTQUEUED) D ^SROSTOP I SRHALT S SRSOUT=1 Q + W:$Y @IOF W !,?(132-$L(SRINST)\2),SRINST,!,?57,"ANESTHESIA SERVICE",?100,"REVIEWED BY: ",!,?58,"ANESTHESIA AMIS",?100,"DATE REVIEWED: " + W !,?(132-$L(SRFRTO)\2),SRFRTO,?100,SRPRINT + W !!!!! F I=1:1:IOM W "=" + W !,?38,"ANESTHETICS ADMINISTERED BY PRINCIPAL TECHNIQUE USED",! F I=1:1:IOM W "-" + W !,"TOTAL NO OF ANES- | | | | | |" + W !,"THETICS ADMINISTERED | GENERAL | MAC | SPINAL | EPIDURAL | OTHER | LOCAL",! F I=1:1:IOM W "-" + Q +END W:$E(IOST)="P" @IOF K ^TMP("SROAMIS",$J),^TMP("SRTN",$J) I $D(ZTQUEUED) Q:$G(ZTSTOP) S ZTREQ="@" Q + D ^%ZISC,^SRSKILL W @IOF + Q +DEAD ; check for death within 24 hrs. + S OPDATE=$S($D(^SRF(SRDFN,.2)):$P(^(.2),"^"),1:"") S:OPDATE="" OPDATE=$P(^SRF(SRDFN,0),"^",9) S X1=OPDATE,X2=1 D C^%DTC S OPONE=X S DEATH=$S(DEATH<(OPONE+.0001):1,1:"") + I DEATH S ^TMP("SRTN",$J,DFN)="" + Q +EN ; entry for SROAMIS option + W @IOF,!,"Anesthesia AMIS",! +DATE D DATE^SROUTL(.SDATE,.EDATE,.SRSOUT) G:SRSOUT END S SRD=SDATE-.0001 + N SRINSTP S SRINST=$$INST^SROUTL0() G:SRINST="^" END S SRINSTP=$P(SRINST,U),SRINST=$S(SRINST["ALL DIVISIONS":SRINST,1:$P(SRINST,U,2)) + W !!!,"This report is designed to use a 132 column format, and must be run",!,"on a printer.",!! +PTR K IOP,%ZIS,POP,IO("Q") S %ZIS("A")="Select Printer: ",%ZIS="QM" D ^%ZIS G:POP END W:$E(IOST)'="P" !!,"This report must be run on a printer.",!! G:$E(IOST)'="P" PTR + I $D(IO("Q")) K IO("Q") S ZTDESC="ANESTHESIA AMIS",ZTRTN="1^SROAMIS",(ZTSAVE("EDATE"),ZTSAVE("SDATE"),ZTSAVE("SRD"),ZTSAVE("SRINST"),ZTSAVE("SRINSTP"))="" D ^%ZTLOAD G END +1 ; entry when queued + U IO N SRFRTO K ^TMP("SROAMIS",$J),^TMP("SRTN",$J) S SRSOUT=0,Y=DT X ^DD("DD") S SRPRINT="DATE PRINTED: "_Y + S Y=SDATE X ^DD("DD") S SRFRTO="FROM: "_Y_" TO: ",Y=EDATE X ^DD("DD") S SRFRTO=SRFRTO_Y + F I="G","M","S","E","O","L" S ^TMP("SROAMIS",$J,"T",I)=0 F I="A","N","O" S ^TMP("SROAMIS",$J,"P","DIAG",I)=0,^TMP("SROAMIS",$J,"P","SURG",I)=0 K I + S SRDFN=0,Z=SRD F S Z=$O(^SRF("AC",Z)) Q:Z>(EDATE+.9999)!(Z="") F S SRDFN=$O(^SRF("AC",Z,SRDFN)) Q:SRDFN="" D + .I $D(^SRF(SRDFN,0)),$P($G(^SRF(SRDFN,.2)),"^",12)'=""!($P($G(^SRF(SRDFN,"NON")),"^")="Y"),$$MANDIV^SROUTL0(SRINSTP,SRDFN) D SET + D HDR G:SRSOUT END D PRINT^SROAMIS1 + G END diff --git a/r/SURGERY-SR/SROAOP.m b/r/SURGERY-SR/SROAOP.m index db5235f2..cb0392c0 100644 --- a/r/SURGERY-SR/SROAOP.m +++ b/r/SURGERY-SR/SROAOP.m @@ -1,74 +1,68 @@ -SROAOP ;BIR/MAM - ENTER OPERATION INFO ;11/27/07 - ;;3.0; Surgery ;**19,38,47,63,67,81,86,97,100,125,142,153,160,166**;24 Jun 93;Build 7 - I '$D(SRTN) W !!,"A Surgery Risk Assessment must be selected prior to using this option.",!!,"Press to continue " R X:DTIME G END - S SRSOUT=0,SRSUPCPT=1 D ^SROAUTL -START G:SRSOUT END K SRAOTH,SRACON D ^SROAOP1 -ASK W !!,"Select Operative Information to Edit: " R SRASEL:DTIME I '$T!(SRASEL["^") S SRSOUT=1 G END - I SRASEL="" G END - S SRN=13 S:SRASEL="a" SRASEL="A" I '$D(SRAO(SRASEL)),(SRASEL'?.N1":".N),(SRASEL'="A") D HELP G:SRSOUT END G START - I SRASEL="A" S SRASEL="1:"_SRN - I SRASEL?.N1":".N S Y=$E(SRASEL),Z=$P(SRASEL,":",2) I Y<1!(Z>SRN)!(Y>Z) D HELP G:SRSOUT END G START - S MM=$E(SRASEL) I MM'=3,(MM'=4),(MM'=5) S SRHDR(.5)=SRDOC D HDR^SROAUTL - I SRASEL?.N1":".N D RANGE G START - Q:'$D(SRAO(SRASEL)) - S EMILY=SRASEL D G START - .I $$LOCK^SROUTL(SRTN) D ONE,UNLOCK^SROUTL(SRTN) -END I $D(SRSOUT),'SRSOUT D ^SROAOP2 - I $D(SRTN) S SROERR=SRTN D ^SROERR0 - W @IOF D ^SRSKILL - Q -HELP W @IOF,!!!!,"Enter the number or range of numbers you want to edit. Examples of proper" - W !,"responses are listed below.",!!,"1. Enter 'A' to update all information." - W !!,"2. Enter a number (1-"_SRN_") to update the information in that field. (For" - W !," example, enter '2' to update Principal Operation.)" - W !!,"3. Enter a range of numbers (1-"_SRN_") separated by a ':' to enter a range of" - W !," information. (For example, enter '6:8' to update PGY of Primary Surgeon," - W !," Surgical Priority and Wound Classification.)",! -PRESS K DIR S DIR(0)="E" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 - Q -RANGE ; range of numbers - I $$LOCK^SROUTL(SRTN) D D UNLOCK^SROUTL(SRTN) - .S SHEMP=$P(SRASEL,":"),CURLEY=$P(SRASEL,":",2) F EMILY=SHEMP:1:CURLEY Q:SRSOUT D ONE - Q -ONE ; edit one item - I EMILY=3 D DISP^SROAUTL0 Q - I EMILY=10 D ANES Q - I EMILY=4 D ^SROTHER Q - I EMILY=5 D CONCUR Q - I EMILY=6,SRASEL[":",($P(SRASEL,":")'=6) S SRPAGE="" S SRHDR(.5)=SRDOC D HDR^SROAUTL - K DR,DIE S DA=SRTN,DR=$P(SRAO(EMILY),"^",2)_"T",DIE=130 D ^DIE K DR I $D(Y) S SRSOUT=1 - I EMILY=2 D ^SROAUTL - Q -RET Q:SRSOUT W !!,"Press ENTER to continue, or '^' to quit " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q - Q -CONCUR ; concurrent case information - N SRPROC,SRCSTAT S SRLINE="" F I=1:1:80 S SRLINE=SRLINE_"-" - S CON=$P($G(^SRF(SRTN,"CON")),"^") I CON,($P($G(^SRF(CON,30)),"^")!($P($G(^SRF(CON,31)),"^",8))) S CON="" - S SRPAGE="" D HDR^SROAUTL - W !,"Concurrent case information cannot be updated using the Risk Assessment" - W !,"Module. To update the CPT code of a concurrent case, please use an option" - W !,"contained within the CPT/ICD9 Coding Menu." - I CON D CC W !!,"Concurrent Procedure: ",?22,SROPS(1) I $D(SROPS(2)) W !,?22,SROPS(2) I $D(SROPS(3)) W !,?22,SROPS(3) I $D(SROPS(4)) W !,?22,SROPS(4) - I $D(SRCSTAT) W !!,?22,SRCSTAT - W !!,"Press ENTER to continue " R X:DTIME - Q -CC ; list concurrent procedure - N SRTN,SRL,SRZ S SRCSTAT=">> Coding "_$S($P($G(^SRO(136,CON,10)),"^"):"",1:"Not ")_"Complete <<" - S SRL=55,SRTN=CON D CPTS^SROAUTL0 - I SRPROC(1)="NOT ENTERED"!'$D(SRPROC(1)) S SRPROC(1)="CPT NOT ENTERED" K SRCSTAT - S SROPER=$P(^SRF(CON,"OP"),"^")_" (" F I=1:1 Q:'$D(SRPROC(I)) S SROPER=SROPER_SRPROC(I) - S SROPER=SROPER_")" - K SROPS,MM,MMM S:$L(SROPER)<57 SROPS(1)=SROPER - I $L(SROPER)>56 S SROPER=SROPER_" " F M=1:1 D LOOP Q:MMM="" - Q -LOOP ; break procedures - S SROPS(M)="" F LOOP=1:1 S MM=$P(SROPER," "),MMM=$P(SROPER," ",2,200) Q:MMM="" Q:$L(SROPS(M))+$L(MM)'<57 S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM - Q -ANES N SRANE,SRNEW - I $P(SRAO(10),"^")="NOT ENTERED",'$O(^SRF(SRTN,6,0)) D Q - .K DIR S DIR("A")="Select ANESTHESIA TECHNIQUE: ",DIR(0)="130.06,.01OA" D ^DIR K DIR S SRANE=Y I $D(DTOUT)!$D(DUOUT)!(Y="") Q - .K DD,DO S DIC="^SRF(SRTN,6,",X=SRANE,DIC(0)="L" D FILE^DICN K DIC,DD,DO I '+Y Q - .S SRNEW=+Y - .K DA,DIE,DR S DA=SRNEW,DA(1)=SRTN,DIE="^SRF(SRTN,6,",DR=".05T;42T" D ^DIE - K DR,DIE,DA S DA=SRTN,DR=".37T",DR(2,130.06)=".01T;.05T;42T",DIE=130 D ^DIE K DR - Q +SROAOP ;BIR/MAM - ENTER OPERATION INFO ;04/24/07 + ;;3.0; Surgery ;**19,38,47,63,67,81,86,97,100,125,142,153,160**;24 Jun 93;Build 7 + I '$D(SRTN) W !!,"A Surgery Risk Assessment must be selected prior to using this option.",!!,"Press to continue " R X:DTIME G END + S SRSOUT=0,SRSUPCPT=1 D ^SROAUTL +START G:SRSOUT END K SRAOTH,SRACON D ^SROAOP1 +ASK W !!,"Select Operative Information to Edit: " R SRASEL:DTIME I '$T!(SRASEL["^") S SRSOUT=1 G END + I SRASEL="" G END + S SRN=13 S:SRASEL="a" SRASEL="A" I '$D(SRAO(SRASEL)),(SRASEL'?.N1":".N),(SRASEL'="A") D HELP G:SRSOUT END G START + I SRASEL="A" S SRASEL="1:"_SRN + I SRASEL?.N1":".N S Y=$E(SRASEL),Z=$P(SRASEL,":",2) I Y<1!(Z>SRN)!(Y>Z) D HELP G:SRSOUT END G START + S MM=$E(SRASEL) I MM'=3,(MM'=4),(MM'=5) S SRHDR(.5)=SRDOC D HDR^SROAUTL + I SRASEL?.N1":".N D RANGE G START + Q:'$D(SRAO(SRASEL)) + S EMILY=SRASEL D G START + .I $$LOCK^SROUTL(SRTN) D ONE,UNLOCK^SROUTL(SRTN) +END I $D(SRSOUT),'SRSOUT D ^SROAOP2 + I $D(SRTN) S SROERR=SRTN D ^SROERR0 + W @IOF D ^SRSKILL + Q +HELP W @IOF,!!!!,"Enter the number or range of numbers you want to edit. Examples of proper" + W !,"responses are listed below.",!!,"1. Enter 'A' to update all information." + W !!,"2. Enter a number (1-"_SRN_") to update the information in that field. (For" + W !," example, enter '2' to update Principal Operation.)" + W !!,"3. Enter a range of numbers (1-"_SRN_") separated by a ':' to enter a range of" + W !," information. (For example, enter '6:8' to update PGY of Primary Surgeon," + W !," Surgical Priority and Wound Classification.)",! +PRESS K DIR S DIR(0)="E" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 + Q +RANGE ; range of numbers + I $$LOCK^SROUTL(SRTN) D D UNLOCK^SROUTL(SRTN) + .S SHEMP=$P(SRASEL,":"),CURLEY=$P(SRASEL,":",2) F EMILY=SHEMP:1:CURLEY Q:SRSOUT D ONE + Q +ONE ; edit one item + I EMILY=3 D DISP^SROAUTL0 Q + I EMILY=10 D ANES Q + I EMILY=4 D ^SROTHER Q + I EMILY=5 D CONCUR Q + I EMILY=6,SRASEL[":",($P(SRASEL,":")'=6) S SRPAGE="" S SRHDR(.5)=SRDOC D HDR^SROAUTL + K DR,DIE S DA=SRTN,DR=$P(SRAO(EMILY),"^",2)_"T",DIE=130 D ^DIE K DR I $D(Y) S SRSOUT=1 + I EMILY=2 D ^SROAUTL + Q +RET Q:SRSOUT W !!,"Press ENTER to continue, or '^' to quit " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q + Q +CONCUR ; concurrent case information + N SRPROC,SRCSTAT S SRLINE="" F I=1:1:80 S SRLINE=SRLINE_"-" + S CON=$P($G(^SRF(SRTN,"CON")),"^") I CON,($P($G(^SRF(CON,30)),"^")!($P($G(^SRF(CON,31)),"^",8))) S CON="" + S SRPAGE="" D HDR^SROAUTL + W !,"Concurrent case information cannot be updated using the Risk Assessment" + W !,"Module. To update the CPT code of a concurrent case, please use an option" + W !,"contained within the CPT/ICD9 Coding Menu." + I CON D CC W !!,"Concurrent Procedure: ",?22,SROPS(1) I $D(SROPS(2)) W !,?22,SROPS(2) I $D(SROPS(3)) W !,?22,SROPS(3) I $D(SROPS(4)) W !,?22,SROPS(4) + I $D(SRCSTAT) W !!,?22,SRCSTAT + W !!,"Press ENTER to continue " R X:DTIME + Q +CC ; list concurrent procedure + N SRTN,SRL,SRZ S SRCSTAT=">> Coding "_$S($P($G(^SRO(136,CON,10)),"^"):"",1:"Not ")_"Complete <<" + S SRL=55,SRTN=CON D CPTS^SROAUTL0 + I SRPROC(1)="NOT ENTERED"!'$D(SRPROC(1)) S SRPROC(1)="CPT NOT ENTERED" K SRCSTAT + S SROPER=$P(^SRF(CON,"OP"),"^")_" (" F I=1:1 Q:'$D(SRPROC(I)) S SROPER=SROPER_SRPROC(I) + S SROPER=SROPER_")" + K SROPS,MM,MMM S:$L(SROPER)<57 SROPS(1)=SROPER + I $L(SROPER)>56 S SROPER=SROPER_" " F M=1:1 D LOOP Q:MMM="" + Q +LOOP ; break procedures + S SROPS(M)="" F LOOP=1:1 S MM=$P(SROPER," "),MMM=$P(SROPER," ",2,200) Q:MMM="" Q:$L(SROPS(M))+$L(MM)'<57 S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM + Q +ANES K DR,DIE,DA S DA=SRTN,DR=".37T",DR(2,130.06)=".01T;.05T;42T",DIE=130 D ^DIE K DR + Q diff --git a/r/SURGERY-SR/SROAPAS.m b/r/SURGERY-SR/SROAPAS.m index df6f9f50..2dc2554a 100644 --- a/r/SURGERY-SR/SROAPAS.m +++ b/r/SURGERY-SR/SROAPAS.m @@ -1,105 +1,103 @@ -SROAPAS ;BIR/MAM - PRINT A COMPLETE ASSESSMENT ;03/03/08 - ;;3.0; Surgery ;**38,47,81,88,111,112,100,125,153,166**;24 Jun 93;Build 7 - S SRSOUT=0,SRPG=0,SR("RA")=$G(^SRF(SRTN,"RA")),SRATYPE=$P(SR("RA"),"^",2) F I=200:1:208,200.1 S SRA(I)=$G(^SRF(SRTN,I)) - S SRA("OP")=^SRF(SRTN,"OP"),SRA("CON")=$G(^SRF(SRTN,"CON")) - S SR(0)=^SRF(SRTN,0),DFN=$P(SR(0),"^"),SRSDATE=$P(SR(0),"^",9) D DEM^VADPT S SRANM=VADM(1)_" "_VA("PID"),Z=$P(VADM(3),"^"),Y=$E(SRSDATE,1,7),AGE=$E(Y,1,3)-$E(Z,1,3)-($E(Y,4,7)<$E(Z,4,7)) - I $P(SR("RA"),"^",2)="C" D ^SROAPCA G END - W:$E(IOST)'="P" @IOF D HDR G:SRSOUT END - W !,"Medical Center: "_SRSITE("SITE") - W !,"Age: ",?16,AGE S Y=SRSDATE D D^DIQ W ?40,"Operation Date: ",?59,$P(Y,"@") - S Y=$P($G(^SRF(SRTN,208)),"^",10),C=$P(^DD(130,417,0),"^",2) D Y^DIQ S X=$S(Y'="":Y,1:"NOT ENTERED") - ; - D DEM^VADPT - ;Find patient's ethnicity - S SROETH="" - I $G(VADM(11)) S SROETH=$P(VADM(11,1),U,2) - I '$G(VADM(11)) S SROETH="UNANSWERED" - ; - ;Find all race entries and place into a string with commas inbetween - S SRORC=0,C=1,SRORACE="",SROLINE="",N=1,SROL="" - F S SRORC=$O(VADM(12,SRORC)) Q:SRORC="" Q:C=11 D - .I $G(VADM(12,SRORC)) S SRORACE(C)=$P(VADM(12,SRORC),U,2) - .I SROLINE'="" S SROLINE=SROLINE_", "_SRORACE(C) - .I SROLINE="" S SROLINE=SRORACE(C) - .S C=C+1 - ; - ;Find total length of 'race' string and wrap the text if necessary - I $L(SROLINE)=29!$L(SROLINE)<29 S SROL(N)=SROLINE,SRNUM1=2 - I $L(SROLINE)>29 D WRAP - ; - W !,"Sex: ",?16,$P(VADM(5),"^",2),?40,"Ethnicity:",?51,SROETH - W !,?40,"Race:" - I $G(VADM(12)) F D=1:1:SRNUM1-1 D - .W:D=1 ?51,SROL(D) - .W:D'=1 !,?51,SROL(D) - I '$G(VADM(12)) W ?51,"UNANSWERED" - ; - K SROL,SROLINE,SRORC,SRORACE,SROLN,SROLN1,SROWRAP,SRNUM1 - ; - S Y=$P($G(^SRF(SRTN,208)),"^",11),C=$P(^DD(130,413,0),"^",2) D Y^DIQ S X=$S(Y'="":Y,1:"NOT ENTERED") W !,"Transfer Status: ",X - F J=1,2,3 S Y=$P($G(^SRF(SRTN,208.1)),"^",J) D - .I J'=3 X:Y ^DD("DD") S Z=$P(Y,"@")_" "_$E($P(Y,"@",2),1,5) - .I J=3 S C=$P(^DD(130,454,0),"^",2) D Y^DIQ S Z=Y - .W !,"Observation "_$S(J=1:"Admission Date:",J=2:"Discharge Date:",1:"Treating Specialty:"),?47,Z - F J=14:1:17 S Y=$P($G(^SRF(SRTN,208)),"^",J) X ^DD("DD") S SRPTMODT(J)=Y - S (X,Z)=SRPTMODT(14) S:X'="" Z=$P(X,"@")_" "_$E($P(X,"@",2),1,5) W !,"Hospital Admission Date:",?47,Z - S (X,Z)=SRPTMODT(15) S:X'="" Z=$P(X,"@")_" "_$E($P(X,"@",2),1,5) W !,"Hospital Discharge Date:",?47,Z - S (X,Z)=SRPTMODT(16) S:X'="" Z=$P(X,"@")_" "_$E($P(X,"@",2),1,5) W !,"Admitted/Transferred to Surgical Service:",?47,Z - S (X,Z)=SRPTMODT(17) S:X'="" Z=$P(X,"@")_" "_$E($P(X,"@",2),1,5) W !,"Discharged/Transferred to Chronic Care:",?47,Z - W !,"In/Out-Patient Status:",?47,$S($P($G(^SRF(SRTN,0)),"^",12)="I":"INPATIENT",$P($G(^SRF(SRTN,0)),"^",12)="O":"OUTPATIENT",1:"") - S Y=$P($G(^SRF(SRTN,209)),"^",17) X ^DD("DD") W !,"Date Surgery Consult Requested:",?47,Y - S Y=$P($G(^SRF(SRTN,209)),"^",15) X ^DD("DD") W !,"Surgery Consult Date:",?47,Y - I $E(IOST)="P" W ! F MOE=1:1:80 W "-" - I $E(IOST)'="P" D PAGE I SRSOUT G END - D ^SROAPRT1 G:SRSOUT END I $Y+20>IOSL D PAGE I SRSOUT G END - D ^SROAPRT2 G:SRSOUT END I $Y+20>IOSL D PAGE I SRSOUT G END - D OPTIMES^SROAPRT3 G:SRSOUT END I $Y+20>IOSL D PAGE I SRSOUT G END - D ^SROAPRT3 G:SRSOUT END I $Y+24>IOSL D PAGE I SRSOUT G END - D ^SROAPRT4 G:SRSOUT END I $Y+20>IOSL D PAGE I SRSOUT G END - D ^SROAPRT5 G:SRSOUT END I $Y+20>IOSL D PAGE I SRSOUT G END - D ^SROAPRT6 -END Q:$D(SRABATCH) I 'SRSOUT,$E(IOST)'="P" W !!,"Press to continue " R X:DTIME - W:$E(IOST)="P" @IOF I $D(ZTQUEUED) Q:$G(ZTSTOP) S ZTREQ="@" Q - D ^%ZISC K SROETH,SRTN W @IOF D ^SRSKILL - Q - ; -WRAP ;Wrap multiple race entries so that wrapped line - ;does not break in the middle of a word - ; - S SROLNGTH=$L(SROLINE),E=29,SROWRAP="",SROLN="",SROLN1="",SROL="" - F I=1:29:SROLNGTH S SROLN(I)=SROWRAP_$E(SROLINE,I,E) D - .F K=29:-1:1 I $E(SROLN(I),K)[" " D Q ;Break lines at space - ..S SROLN1(I)=$E(SROLN(I),1,K-1) - ..S SROWRAP=$E(SROLN(I),K+1,E) - .S E=E+29 - ; - S:'$D(SROLN1(I)) SROLN1(I)=SROLN(I),SROWRAP="" - I $L(SROLN1(I))+$L(SROWRAP)>28 S SROLN1(I+1)=SROWRAP ;Last line - I $L(SROLN1(I))+$L(SROWRAP)'>28 S SROLN1(I)=SROLN1(I)_" "_SROWRAP - ; - ;Renumber the SROLN1 array to be in numeric order - S SRNUM=0,SRNUM1=1 - F S SRNUM=$O(SROLN1(SRNUM)) Q:SRNUM="" D - .S SROL(SRNUM1)=SROLN1(SRNUM) - .S SRNUM1=SRNUM1+1 - Q - ; -LOOP ; break procedures - S SROPS(M)="" F LOOP=1:1 S MM=$P(SROPER," "),MMM=$P(SROPER," ",2,200) Q:MMM="" Q:$L(SROPS(M))+$L(MM)'<55 S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM - Q -PAGE I $E(IOST)'="P" W !!,"Press to continue, or '^' to quit " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q - I X["?" W !!,"Enter to continue printing the remaining pages of this assessment, or",!,"'^' to exit this option." G PAGE - W @IOF -HDR ; print heading - I $D(ZTQUEUED) D ^SROSTOP I SRHALT S SRSOUT=1 Q - S SRPG=SRPG+1 - I $Y'=0 W @IOF - I SRATYPE="C" W !,"VA CARDIAC RISK ASSESSMENT",?70,"PAGE "_SRPG - I SRATYPE="N" W !,"VA NON-CARDIAC RISK ASSESSMENT Assessment: "_SRTN,?69,"PAGE "_SRPG - W !,"FOR "_SRANM S X=$P(SR("RA"),"^") W " ("_$S(X="I":"INCOMPLETE",X="C":"COMPLETED",X="T":"TRANSMITTED",1:"NO ASSESSMENT") I X="T" S Y=$P(SR("RA"),"^",4) W " "_$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3) - W ")",! F LINE=1:1:80 W "=" - W ! - Q -CODE ; print CPT Code - S X=$P(^SRF(SRTN,13,SR,0),"^",2) I X W " ("_$P($$CPT^ICPTCOD(X),"^",2)_")" - Q +SROAPAS ;BIR/MAM - PRINT A COMPLETE ASSESSMENT ; [ 04/13/04 2:50 PM ] + ;;3.0; Surgery ;**38,47,81,88,111,112,100,125,153**;24 Jun 93;Build 11 + S SRSOUT=0,SRPG=0,SR("RA")=$G(^SRF(SRTN,"RA")),SRATYPE=$P(SR("RA"),"^",2) F I=200:1:208,200.1 S SRA(I)=$G(^SRF(SRTN,I)) + S SRA("OP")=^SRF(SRTN,"OP"),SRA("CON")=$G(^SRF(SRTN,"CON")) + S SR(0)=^SRF(SRTN,0),DFN=$P(SR(0),"^"),SRSDATE=$P(SR(0),"^",9) D DEM^VADPT S SRANM=VADM(1)_" "_VA("PID"),Z=$P(VADM(3),"^"),Y=$E(SRSDATE,1,7),AGE=$E(Y,1,3)-$E(Z,1,3)-($E(Y,4,7)<$E(Z,4,7)) + I $P(SR("RA"),"^",2)="C" D ^SROAPCA G END + W:$E(IOST)'="P" @IOF D HDR G:SRSOUT END + W !,"Medical Center: "_SRSITE("SITE") + W !,"Age: ",?16,AGE S Y=SRSDATE D D^DIQ W ?40,"Operation Date: ",?59,$P(Y,"@") + S Y=$P($G(^SRF(SRTN,208)),"^",10),C=$P(^DD(130,417,0),"^",2) D Y^DIQ S X=$S(Y'="":Y,1:"NOT ENTERED") + ; + D DEM^VADPT + ;Find patient's ethnicity + S SROETH="" + I $G(VADM(11)) S SROETH=$P(VADM(11,1),U,2) + I '$G(VADM(11)) S SROETH="UNANSWERED" + ; + ;Find all race entries and place into a string with commas inbetween + S SRORC=0,C=1,SRORACE="",SROLINE="",N=1,SROL="" + F S SRORC=$O(VADM(12,SRORC)) Q:SRORC="" Q:C=11 D + .I $G(VADM(12,SRORC)) S SRORACE(C)=$P(VADM(12,SRORC),U,2) + .I SROLINE'="" S SROLINE=SROLINE_", "_SRORACE(C) + .I SROLINE="" S SROLINE=SRORACE(C) + .S C=C+1 + ; + ;Find total length of 'race' string and wrap the text if necessary + I $L(SROLINE)=29!$L(SROLINE)<29 S SROL(N)=SROLINE,SRNUM1=2 + I $L(SROLINE)>29 D WRAP + ; + W !,"Sex: ",?16,$P(VADM(5),"^",2),?40,"Ethnicity:",?51,SROETH + W !,?40,"Race:" + I $G(VADM(12)) F D=1:1:SRNUM1-1 D + .W:D=1 ?51,SROL(D) + .W:D'=1 !,?51,SROL(D) + I '$G(VADM(12)) W ?51,"UNANSWERED" + ; + K SROL,SROLINE,SRORC,SRORACE,SROLN,SROLN1,SROWRAP,SRNUM1 + ; + S Y=$P($G(^SRF(SRTN,208)),"^",11),C=$P(^DD(130,413,0),"^",2) D Y^DIQ S X=$S(Y'="":Y,1:"NOT ENTERED") W !,"Transfer Status: ",X + F J=1,2,3 S Y=$P($G(^SRF(SRTN,208.1)),"^",J) D + .I J'=3 X:Y ^DD("DD") S Z=$P(Y,"@")_" "_$E($P(Y,"@",2),1,5) + .I J=3 S C=$P(^DD(130,454,0),"^",2) D Y^DIQ S Z=Y + .W !,"Observation "_$S(J=1:"Admission Date:",J=2:"Discharge Date:",1:"Treating Specialty:"),?47,Z + F J=14:1:17 S Y=$P($G(^SRF(SRTN,208)),"^",J) X ^DD("DD") S SRPTMODT(J)=Y + S (X,Z)=SRPTMODT(14) S:X'="" Z=$P(X,"@")_" "_$E($P(X,"@",2),1,5) W !,"Hospital Admission Date:",?47,Z + S (X,Z)=SRPTMODT(15) S:X'="" Z=$P(X,"@")_" "_$E($P(X,"@",2),1,5) W !,"Hospital Discharge Date:",?47,Z + S (X,Z)=SRPTMODT(16) S:X'="" Z=$P(X,"@")_" "_$E($P(X,"@",2),1,5) W !,"Admitted/Transferred to Surgical Service:",?47,Z + S (X,Z)=SRPTMODT(17) S:X'="" Z=$P(X,"@")_" "_$E($P(X,"@",2),1,5) W !,"Discharged/Transferred to Chronic Care:",?47,Z + W !,"In/Out-Patient Status:",?47,$S($P($G(^SRF(SRTN,0)),"^",12)="I":"INPATIENT",$P($G(^SRF(SRTN,0)),"^",12)="O":"OUTPATIENT",1:"") + I $E(IOST)="P" W ! F MOE=1:1:80 W "-" + I $E(IOST)'="P" D PAGE I SRSOUT G END + D ^SROAPRT1 G:SRSOUT END I $Y+20>IOSL D PAGE I SRSOUT G END + D ^SROAPRT2 G:SRSOUT END I $Y+20>IOSL D PAGE I SRSOUT G END + D OPTIMES^SROAPRT3 G:SRSOUT END I $Y+20>IOSL D PAGE I SRSOUT G END + D ^SROAPRT3 G:SRSOUT END I $Y+24>IOSL D PAGE I SRSOUT G END + D ^SROAPRT4 G:SRSOUT END I $Y+20>IOSL D PAGE I SRSOUT G END + D ^SROAPRT5 G:SRSOUT END I $Y+20>IOSL D PAGE I SRSOUT G END + D ^SROAPRT6 +END Q:$D(SRABATCH) I 'SRSOUT,$E(IOST)'="P" W !!,"Press to continue " R X:DTIME + W:$E(IOST)="P" @IOF I $D(ZTQUEUED) Q:$G(ZTSTOP) S ZTREQ="@" Q + D ^%ZISC K SRTN W @IOF D ^SRSKILL + Q + ; +WRAP ;Wrap multiple race entries so that wrapped line + ;does not break in the middle of a word + ; + S SROLNGTH=$L(SROLINE),E=29,SROWRAP="",SROLN="",SROLN1="",SROL="" + F I=1:29:SROLNGTH S SROLN(I)=SROWRAP_$E(SROLINE,I,E) D + .F K=29:-1:1 I $E(SROLN(I),K)[" " D Q ;Break lines at space + ..S SROLN1(I)=$E(SROLN(I),1,K-1) + ..S SROWRAP=$E(SROLN(I),K+1,E) + .S E=E+29 + ; + S:'$D(SROLN1(I)) SROLN1(I)=SROLN(I),SROWRAP="" + I $L(SROLN1(I))+$L(SROWRAP)>28 S SROLN1(I+1)=SROWRAP ;Last line + I $L(SROLN1(I))+$L(SROWRAP)'>28 S SROLN1(I)=SROLN1(I)_" "_SROWRAP + ; + ;Renumber the SROLN1 array to be in numeric order + S SRNUM=0,SRNUM1=1 + F S SRNUM=$O(SROLN1(SRNUM)) Q:SRNUM="" D + .S SROL(SRNUM1)=SROLN1(SRNUM) + .S SRNUM1=SRNUM1+1 + Q + ; +LOOP ; break procedures + S SROPS(M)="" F LOOP=1:1 S MM=$P(SROPER," "),MMM=$P(SROPER," ",2,200) Q:MMM="" Q:$L(SROPS(M))+$L(MM)'<55 S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM + Q +PAGE I $E(IOST)'="P" W !!,"Press to continue, or '^' to quit " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q + I X["?" W !!,"Enter to continue printing the remaining pages of this assessment, or",!,"'^' to exit this option." G PAGE + W @IOF +HDR ; print heading + I $D(ZTQUEUED) D ^SROSTOP I SRHALT S SRSOUT=1 Q + S SRPG=SRPG+1 + I $Y'=0 W @IOF + I SRATYPE="C" W !,"VA CARDIAC RISK ASSESSMENT",?70,"PAGE "_SRPG + I SRATYPE="N" W !,"VA NON-CARDIAC RISK ASSESSMENT Assessment: "_SRTN,?69,"PAGE "_SRPG + W !,"FOR "_SRANM S X=$P(SR("RA"),"^") W " ("_$S(X="I":"INCOMPLETE",X="C":"COMPLETED",X="T":"TRANSMITTED",1:"NO ASSESSMENT") I X="T" S Y=$P(SR("RA"),"^",4) W " "_$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3) + W ")",! F LINE=1:1:80 W "=" + W ! + Q +CODE ; print CPT Code + S X=$P(^SRF(SRTN,13,SR,0),"^",2) I X W " ("_$P($$CPT^ICPTCOD(X),"^",2)_")" + Q diff --git a/r/SURGERY-SR/SROAPCA1.m b/r/SURGERY-SR/SROAPCA1.m index f512c886..c60d481b 100644 --- a/r/SURGERY-SR/SROAPCA1.m +++ b/r/SURGERY-SR/SROAPCA1.m @@ -1,95 +1,94 @@ -SROAPCA1 ;BIR/MAM - PRINT CARDIAC CATH INFO ;02/05/08 - ;;3.0; Surgery ;**38,63,71,88,95,125,142,153,166**;24 Jun 93;Build 7 - N SRX F I=200:1:202,206,208,209,202.1 S SRA(I)=$G(^SRF(SRTN,I)) - I $Y+14>IOSL D PAGE^SROAPCA I SRSOUT Q - D LAB^SROAPCA4 - I $Y+16>IOSL D PAGE^SROAPCA I SRSOUT Q - S Y=$P(SRA(209),"^",4),SRAO(1)=$S(Y="C":"CATH",Y="I":"IVUS",Y="B":"BOTH",Y="NS":" NS",1:"")_"^476" - S Y=$P(SRA(206),"^",24),SRX=357,SRAO(2)=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(206),"^",25),SRX=358,SRAO(3)=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(206),"^",26),SRX=359,SRAO(4)=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(206),"^",27),SRX=360,SRAO(5)=$$OUT(SRX,Y)_"^"_SRX - S NYUK=$P(SRA(206),"^",30) D LV S SRAO(6)=SHEMP_"^363" - S Y=$P(SRA(206),"^",9),SRX=415,SRAO(7)=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(209),"^",5),SRX=477,SRAO(8)=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(206),"^",28),SRX=361,SRAO(9)=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(206),"^",33),SRX=362.1,SRAO(10)=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(206),"^",34),SRX=362.2,SRAO(11)=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(206),"^",35),SRX=362.3,SRAO(12)=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(209),"^",6),SRX=478,SRAO(13)=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(209),"^",7),SRX=479,SRAO(14)=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(209),"^",8),SRX=480,SRAO(15)=$$OUT(SRX,Y)_"^"_SRX - W !!,"IV. CARDIAC CATHETERIZATION AND ANGIOGRAPHIC DATA" - S Y=$P($G(^SRF(SRTN,207)),"^",21) I Y>1 D DT S Y=X - D NS W !,"Cardiac Catheterization Date: ",$E(Y,1,8) - W !,"Procedure:",?26,$P(SRAO(1),"^"),?41,"Native Coronaries:" - S SRX=$P(SRAO(2),"^") W !,"LVEDP:",?26,$J(SRX,3) D MMHG - S SRX=$P(SRAO(9),"^") W ?41,"Left Main Stenosis:",?71,$J(SRX,3) I SRX?1.3N W "%" - S SRX=$P(SRAO(3),"^") W !,"Aortic Systolic Pressure:",?26,$J(SRX,3) D MMHG - S SRX=$P(SRAO(10),"^") W ?41,"LAD Stenosis:",?71,$J(SRX,3) I SRX?1.3N W "%" - S SRX=$P(SRAO(11),"^") W !,?41,"Right Coronary Stenosis:",?71,$J(SRX,3) I SRX?1.3N W "%" - W !,"For patients having right heart cath:" S SRX=$P(SRAO(12),"^") W ?41,"Circumflex Stenosis:",?71,$J(SRX,3) I SRX?1.3N W "%" - ; - S SRX=$P(SRAO(4),"^") W !,"PA Systolic Pressure:",?26,$J(SRX,3) D MMHG - S SRX=$P(SRAO(5),"^") W !,"PAW Mean Pressure:",?26,$J(SRX,3) D MMHG - W ?41,"If a Re-do, indicate stenosis",!,?44," in graft to:" - S SRX=$P(SRAO(13),"^") W !,?41,"LAD:",?71,$J(SRX,3) I SRX?1.3N W "%" - S SRX=$P(SRAO(14),"^") W !,?41,"Right coronary (include PDA): ",$J(SRX,3) I SRX?1.3N W "%" - S SRX=$P(SRAO(15),"^") W !,?41,"Circumflex:",?71,$J(SRX,3) I SRX?1.3N W "%" - W !,LN - W !,"LV Contraction Grade (from contrast or radionuclide angiogram or 2D Echo):",!,?7,"Grade",?17,"Ejection Fraction Range",?51,"Definition" - W !,?8,$P(SRAO(6),"^") - W !,LN,!,"Mitral Regurgitation:",?26,$P(SRAO(7),"^") - W !,"Aortic stenosis:",?26,$P(SRAO(8),"^") - I $Y+14>IOSL D PAGE^SROAPCA I SRSOUT Q - K SRAO S Y=$P(SRA(206),"^",31),SRX=364,SRAO(1)=$$OUT(SRX,Y)_"^"_SRX - S Y=$P($G(^SRF(SRTN,1.1)),"^",3),SRX=1.13,SRAO(2)=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(208),"^",12),SRX=414,SRAO(3)=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(206),"^",32),SRX=364.1 D DT S SRAO("1A")=X_"^"_SRX - S Y=$P(SRA(208),"^",13),SRX=414.1 D DT S SRAO("3A")=X_"^"_SRX - S Y=$P($G(^SRF(SRTN,.2)),"^",2),SRX=.22 D DT S SRAO(0)=X_"^"_SRX - W !!,"V. OPERATIVE RISK SUMMARY DATA" S X=$P(SRAO(0),"^") W ?40,"(Operation Began: "_X_")" - W !,?5,"Physician's Preoperative" S Y=$P($G(^SRF(SRTN,.2)),"^",3) D DT W ?40,"(Operation Ended: "_X_")" - W !,?7,"Estimate of Operative Mortality: "_$P(SRAO(1),"^") I $P(SRAO(1),"^")'=""&($P(SRAO(1),"^")'="NS") W "%" - S X=$P(SRAO("1A"),"^") I X'="" W ?57,"("_X_")" - W !,?5,"ASA Classification:",?35,$P(SRAO(2),"^") - S X=$P(SRAO(3),"^") W !,?5,"Surgical Priority:",?($S($L(X)>10:24,1:35)),X S X=$P(SRAO("3A"),"^") I X'="" W ?57,"("_X_")" - S X=$P($G(^SRO(136,SRTN,0)),"^",2) I X S Y=$P($$CPT^ICPTCOD(X),"^",2) D SSPRIN^SROCPT0 S X=Y - S X=$S(X'="":X,1:"CPT Code Missing") - W !,?5,"Principal CPT Code:",?35,X,!,?5,"Other Procedures CPT Codes: " - S CNT=32,OTH=0 F S OTH=$O(^SRO(136,SRTN,3,OTH)) Q:'OTH S CPT=$P($G(^SRO(136,SRTN,3,OTH,0)),"^") D - .I CPT S Y=$P($$CPT^ICPTCOD(CPT),"^",2) S SRDA=OTH D SSOTH^SROCPT0 S CPT=Y - .S:CPT="" CPT="NONE" S CNT=CNT+3 - .I CNT+$L(CPT)'>80 W:CNT>35 ";" W ?(CNT),CPT S CNT=CNT+$L(CPT) Q - .W !,?35,CPT S CNT=35+$L(CPT) - W !,?5,"Preoperative Risk Factors: " - I $G(^SRF(SRTN,206.1))'="" S SRQ=0 S X=$G(^SRF(SRTN,206.1)) W:$L(X)<49 X,! I $L(X)>48 S Z=$L(X) D - .I X'[" " W ?25,X Q - .S I=0,LINE=1 F S SRL=$S(LINE=1:48,1:80) D Q:SRQ - ..I $E(X,1,SRL)'[" " W X,! S SRQ=1 Q - ..S J=SRL-I,Y=$E(X,J),I=I+1 I Y=" " W $E(X,1,J-1),!,?5 S X=$E(X,J+1,Z),Z=$L(X),I=0,LINE=LINE+1 I ZIOSL D PAGE^SROAPCA I SRSOUT Q - K SRA,SRAO D ^SROAPCA2 - Q -YN ; store answer - S SHEMP=$S(NYUK="NS":"NS",NYUK="N":"NO",NYUK="Y":"YES",1:"") - Q -DT I 'Y S X="" Q - S Z=$E($P(Y,".",2),1,4),Z=Z_"0000",Z=$E(Z,1,4),X=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_" "_$E(Z,1,2)_":"_$E(Z,3,4) - Q -OUT(SRFLD,SRY) ; get data in output form - N C,Y - S Y=SRY,C=$P(^DD(130,SRFLD,0),"^",2) D:Y'="" Y^DIQ - I Y="NO STUDY" S Y="NS" Q Y - Q Y -MMHG I SRX="NO STUDY"!(SRX="NS") Q - W " mm Hg" - Q -NS S Y=$S(Y="NS":"NO STUDY",1:Y) - Q -LV K SHEMP S SHEMP=$S(NYUK="I":" I > or = 0.55 NORMAL",NYUK="II":"II 0.45-0.54 MILD DYSFUNCTION",1:NYUK) - Q:SHEMP'=NYUK S SHEMP=$S(NYUK="III":"III 0.35-0.44 MODERATE DYSFUNCTION",1:NYUK) - Q:SHEMP'=NYUK S SHEMP=$S(NYUK="IIIa":"IIIa 0.40-0.44 MODERATE DYSFUNCTION A",1:NYUK) - Q:SHEMP'=NYUK S SHEMP=$S(NYUK="IIIb":"IIIb 0.35-0.39 MODERATE DYSFUNCTION B",1:NYUK) - Q:SHEMP'=NYUK S SHEMP=$S(NYUK="IV":"IV 0.25-0.34 SEVERE DYSFUNCTION",NYUK="V":" V <0.25 VERY SEVERE DYSFUNCTION",NYUK="NS":"NO LV STUDY",1:"") - Q +SROAPCA1 ;BIR/MAM - PRINT CARDIAC CATH INFO ;04/05/04 + ;;3.0; Surgery ;**38,63,71,88,95,125,142,153**;24 Jun 93;Build 11 + N SRX F I=200:1:202,206,208,209,202.1 S SRA(I)=$G(^SRF(SRTN,I)) + I $Y+14>IOSL D PAGE^SROAPCA I SRSOUT Q + D LAB^SROAPCA4 + I $Y+16>IOSL D PAGE^SROAPCA I SRSOUT Q + S Y=$P(SRA(209),"^",4),SRAO(1)=$S(Y="C":"CATH",Y="I":"IVUS",Y="B":"BOTH",Y="NS":" NS",1:"")_"^476" + S Y=$P(SRA(206),"^",24),SRX=357,SRAO(2)=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(206),"^",25),SRX=358,SRAO(3)=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(206),"^",26),SRX=359,SRAO(4)=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(206),"^",27),SRX=360,SRAO(5)=$$OUT(SRX,Y)_"^"_SRX + S NYUK=$P(SRA(206),"^",30) D LV S SRAO(6)=SHEMP_"^363" + S Y=$P(SRA(206),"^",9),SRX=415,SRAO(7)=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(209),"^",5),SRX=477,SRAO(8)=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(206),"^",28),SRX=361,SRAO(9)=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(206),"^",33),SRX=362.1,SRAO(10)=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(206),"^",34),SRX=362.2,SRAO(11)=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(206),"^",35),SRX=362.3,SRAO(12)=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(209),"^",6),SRX=478,SRAO(13)=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(209),"^",7),SRX=479,SRAO(14)=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(209),"^",8),SRX=480,SRAO(15)=$$OUT(SRX,Y)_"^"_SRX + W !!,"IV. CARDIAC CATHETERIZATION AND ANGIOGRAPHIC DATA" + S Y=$P($G(^SRF(SRTN,207)),"^",21) I Y>1 D DT S Y=X + D NS W !,"Cardiac Catheterization Date: ",$E(Y,1,8) + W !,"Procedure:",?26,$P(SRAO(1),"^"),?41,"Native Coronaries:" + S SRX=$P(SRAO(2),"^") W !,"LVEDP:",?26,$J(SRX,3) D MMHG + S SRX=$P(SRAO(9),"^") W ?41,"Left Main Stenosis:",?71,$J(SRX,3) I SRX?1.3N W "%" + S SRX=$P(SRAO(3),"^") W !,"Aortic Systolic Pressure:",?26,$J(SRX,3) D MMHG + S SRX=$P(SRAO(10),"^") W ?41,"LAD Stenosis:",?71,$J(SRX,3) I SRX?1.3N W "%" + S SRX=$P(SRAO(11),"^") W !,?41,"Right Coronary Stenosis:",?71,$J(SRX,3) I SRX?1.3N W "%" + W !,"For patients having right heart cath:" S SRX=$P(SRAO(12),"^") W ?41,"Circumflex Stenosis:",?71,$J(SRX,3) I SRX?1.3N W "%" + ; + S SRX=$P(SRAO(4),"^") W !,"PA Systolic Pressure:",?26,$J(SRX,3) D MMHG + S SRX=$P(SRAO(5),"^") W !,"PAW Mean Pressure:",?26,$J(SRX,3) D MMHG + W ?41,"If a Re-do, indicate stenosis",!,?44," in graft to:" + S SRX=$P(SRAO(13),"^") W !,?41,"LAD:",?71,$J(SRX,3) I SRX?1.3N W "%" + S SRX=$P(SRAO(14),"^") W !,?41,"Right coronary (include PDA): ",$J(SRX,3) I SRX?1.3N W "%" + S SRX=$P(SRAO(15),"^") W !,?41,"Circumflex:",?71,$J(SRX,3) I SRX?1.3N W "%" + W !,LN + W !,"LV Contraction Grade (from contrast or radionuclide angiogram or 2D Echo):",!,?7,"Grade",?17,"Ejection Fraction Range",?51,"Definition" + W !,?8,$P(SRAO(6),"^") + W !,LN,!,"Mitral Regurgitation:",?26,$P(SRAO(7),"^") + W !,"Aortic stenosis:",?26,$P(SRAO(8),"^") + I $Y+14>IOSL D PAGE^SROAPCA I SRSOUT Q + K SRAO S Y=$P(SRA(206),"^",31),SRX=364,SRAO(1)=$$OUT(SRX,Y)_"^"_SRX + S Y=$P($G(^SRF(SRTN,1.1)),"^",3),SRX=1.13,SRAO(2)=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(208),"^",12),SRX=414,SRAO(3)=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(206),"^",32),SRX=364.1,SRAO("1A")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(208),"^",13),SRX=414.1,SRAO("3A")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P($G(^SRF(SRTN,.2)),"^",2),SRX=.22,SRAO(0)=$$OUT(SRX,Y)_"^"_SRX + W !!,"V. OPERATIVE RISK SUMMARY DATA" S X=$P(SRAO(0),"^") I X'="" W ?40,"(Operation Began: "_X_")" + W !,?5,"Physician's Preoperative" S Y=$P($G(^SRF(SRTN,.2)),"^",3) I Y'="" D DT W ?40,"(Operation Ended: "_X_")" + W !,?7,"Estimate of Operative Mortality: "_$P(SRAO(1),"^") I $P(SRAO(1),"^")'=""&($P(SRAO(1),"^")'="NS") W "%" + S X=$P(SRAO("1A"),"^") I X'="" W ?57,"("_X_")" + W !,?5,"ASA Classification:",?35,$P(SRAO(2),"^"),!,?5,"Surgical Priority:",?35,$P(SRAO(3),"^") S X=$P(SRAO("3A"),"^") I X'="" W ?57,"("_X_")" + S X=$P($G(^SRO(136,SRTN,0)),"^",2) I X S Y=$P($$CPT^ICPTCOD(X),"^",2) D SSPRIN^SROCPT0 S X=Y + S X=$S(X'="":X,1:"CPT Code Missing") + W !,?5,"Principal CPT Code:",?35,X,!,?5,"Other Procedures CPT Codes: " + S CNT=32,OTH=0 F S OTH=$O(^SRO(136,SRTN,3,OTH)) Q:'OTH S CPT=$P($G(^SRO(136,SRTN,3,OTH,0)),"^") D + .I CPT S Y=$P($$CPT^ICPTCOD(CPT),"^",2) S SRDA=OTH D SSOTH^SROCPT0 S CPT=Y + .S:CPT="" CPT="NONE" S CNT=CNT+3 + .I CNT+$L(CPT)'>80 W:CNT>35 ";" W ?(CNT),CPT S CNT=CNT+$L(CPT) Q + .W !,?35,CPT S CNT=35+$L(CPT) + W !,?5,"Preoperative Risk Factors: " + I $G(^SRF(SRTN,206.1))'="" S SRQ=0 S X=$G(^SRF(SRTN,206.1)) W:$L(X)<49 X,! I $L(X)>48 S Z=$L(X) D + .I X'[" " W ?25,X Q + .S I=0,LINE=1 F S SRL=$S(LINE=1:48,1:80) D Q:SRQ + ..I $E(X,1,SRL)'[" " W X,! S SRQ=1 Q + ..S J=SRL-I,Y=$E(X,J),I=I+1 I Y=" " W $E(X,1,J-1),!,?5 S X=$E(X,J+1,Z),Z=$L(X),I=0,LINE=LINE+1 I ZIOSL D PAGE^SROAPCA I SRSOUT Q + K SRA,SRAO D ^SROAPCA2 + Q +YN ; store answer + S SHEMP=$S(NYUK="NS":"NS",NYUK="N":"NO",NYUK="Y":"YES",1:"") + Q +DT I 'Y S X="" Q + S Z=$E($P(Y,".",2),1,4),Z=Z_"0000",Z=$E(Z,1,4),X=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_" "_$E(Z,1,2)_":"_$E(Z,3,4) + Q +OUT(SRFLD,SRY) ; get data in output form + N C,Y + S Y=SRY,C=$P(^DD(130,SRFLD,0),"^",2) D:Y'="" Y^DIQ + I Y="NO STUDY" S Y="NS" Q Y + Q Y +MMHG I SRX="NO STUDY"!(SRX="NS") Q + W " mm Hg" + Q +NS S Y=$S(Y="NS":"NO STUDY",1:Y) + Q +LV K SHEMP S SHEMP=$S(NYUK="I":" I > or = 0.55 NORMAL",NYUK="II":"II 0.45-0.54 MILD DYSFUNCTION",1:NYUK) + Q:SHEMP'=NYUK S SHEMP=$S(NYUK="III":"III 0.35-0.44 MODERATE DYSFUNCTION",1:NYUK) + Q:SHEMP'=NYUK S SHEMP=$S(NYUK="IIIa":"IIIa 0.40-0.44 MODERATE DYSFUNCTION A",1:NYUK) + Q:SHEMP'=NYUK S SHEMP=$S(NYUK="IIIb":"IIIb 0.35-0.39 MODERATE DYSFUNCTION B",1:NYUK) + Q:SHEMP'=NYUK S SHEMP=$S(NYUK="IV":"IV 0.25-0.34 SEVERE DYSFUNCTION",NYUK="V":" V <0.25 VERY SEVERE DYSFUNCTION",NYUK="NS":"NO LV STUDY",1:"") + Q diff --git a/r/SURGERY-SR/SROAPCA3.m b/r/SURGERY-SR/SROAPCA3.m index 33db1521..d003debd 100644 --- a/r/SURGERY-SR/SROAPCA3.m +++ b/r/SURGERY-SR/SROAPCA3.m @@ -1,66 +1,63 @@ -SROAPCA3 ;B'HAM ISC/MAM - CARDIAC OCCURRENCE DATA ;02/05/08 - ;;3.0; Surgery ;**38,71,95,101,125,160,164,166**;24 Jun 93;Build 7 - D EN^SROCCAT K SRA S SRA(205)=$G(^SRF(SRTN,205)),SRA(208)=$G(^SRF(SRTN,208)),SRA(206)=$G(^SRF(SRTN,206)),SRA(209)=$G(^SRF(SRTN,209)) - S NYUK=$P(SRA(208),"^") D YN S SRAO(1)=SHEMP_"^384" - S Y=$P($G(^DPT(DFN,.35)),"^") D DT^SROAPCA1 S SRAO(2)=X - S NYUK=$P(SRA(208),"^",2) D YN S SRAO(3)=SHEMP_"^385",NYUK=$P(SRA(208),"^",3) D YN S SRAO(4)=SHEMP_"^386",NYUK=$P(SRA(205),"^",17) D YN S SRAO(5)=SHEMP_"^254",NYUK=$P(SRA(209),"^",12) D YN S SRAO(6)=SHEMP_"^490" - S NYUK=$P(SRA(208),"^",5) D YN S SRAO(7)=SHEMP_"^388",NYUK=$P(SRA(208),"^",6) D YN S SRAO(8)=SHEMP_"^389",NYUK=$P(SRA(205),"^",13) D YN S SRAO(9)=SHEMP_"^285" - S NYUK=$P(SRA(208),"^",7) D YN S SRAO(10)=SHEMP_"^391",NYUK=$P(SRA(205),"^",22) D YN S SRAO(11)=SHEMP_"^410" - S NYUK=$P(SRA(205),"^",21) D YN S SRAO(12)=SHEMP_"^256",NYUK=$P(SRA(205),"^",26) D YN S SRAO(13)=SHEMP_"^411" - S NYUK=$P(SRA(206),"^",39) D YN S SRAO(14)=SHEMP_"^466" - S NYUK=$P(SRA(206),"^",40) D YN S SRAO(15)=SHEMP_"^467" - I $Y+5>IOSL D PAGE^SROAPCA I SRSOUT Q - W !!,"VII. OUTCOMES" - W !,"Operative Death:",?18,$P(SRAO(1),"^"),?43,"Date of Death:",?58,$P(SRAO(2),"^") - ;I $Y+10>IOSL D PAGE^SROAPCA I SRSOUT Q - W !!,"Perioperative (30 day) Occurrences:" - W !,?2,"Perioperative MI:",?36,$P(SRAO(3),"^"),?42,"Repeat cardiac Surg procedure:",?74,$P(SRAO(10),"^") - W !,?2,"Endocarditis:",?36,$P(SRAO(4),"^"),?42,"Tracheostomy:",?74,$P(SRAO(14),"^") - W !,?2,"Renal Failure Requiring Dialysis:",?36,$P(SRAO(5),"^"),?42,"Ventilator supp within 30 days:",?74,$P(SRAO(6),"^") - W !,?2,"Mediastinitis:",?36,$P(SRAO(7),"^"),?42,"Stroke/CVA:",?74,$P(SRAO(12),"^") - W !,?2,"Cardiac Arrest Requiring CPR:",?36,$P(SRAO(13),"^"),?42,"Coma > or = 24 Hours:",?74,$P(SRAO(11),"^") - W !,?2,"Reoperation for Bleeding:",?36,$P(SRAO(8),"^"),?42,"New Mech Circulatory Support:",?74,$P(SRAO(15),"^") - W !,?2,"On ventilator > or = 48 hr:",?36,$P(SRAO(9),"^") - D RES - Q -YN ; store answer - S SHEMP=$S(NYUK="NS":"NS",NYUK="N":"NO",NYUK="Y":"YES",1:"") - Q - ; -RES I $Y+12>IOSL D PAGE^SROAPCA I SRSOUT Q - S SRA(208)=$G(^SRF(SRTN,208)) - S SRA(.2)=$G(^SRF(SRTN,.2)) - W !!,"VIII. RESOURCE DATA" - S Y=$P(SRA(208),"^",14) D DT^SROAPCA1 W !,"Hospital Admission Date:",?47,X - S Y=$P(SRA(208),"^",15) D DT^SROAPCA1 W !,"Hospital Discharge Date:",?47,X - S Y=$P(SRA(.2),"^",10) D DT^SROAPCA1 W !,"Time Patient In OR: ",?47,X - S Y=$P(SRA(.2),"^",12) D DT^SROAPCA1 W !,"Time Patient Out OR: ",?47,X - S Y=$P(SRA(208),"^",22) I Y>1 D DT^SROAPCA1 S Y=X - S Y=$S(Y="NS":"Unable to determine",Y="RI":"Remains intubated at 30 days",1:Y) W !,"Date and Time Patient Extubated: ",?47,Y - I $P(SRA(208),"^",22)>1,$P(SRA(.2),"^",12) D - .S X=$$FMDIFF^XLFDT($P(SRA(208),"^",22),$P(SRA(.2),"^",12),2) W !,?5,"Postop Intubation Hrs: "_$FN((X/3600),"+",1) - S Y=$P(SRA(208),"^",23) I Y>1 D DT^SROAPCA1 S Y=X - S Y=$S(Y="NS":"Unable to determine",Y="RI":"Remains in ICU at 30 days",1:Y) W !,"Date and Time Patient Discharged from ICU: ",?47,Y - S Y=$P(SRA(209),"^") W !,"Patient is Homeless: ",?47,$S(Y="Y":"YES",Y="N":"NO",Y="NS":"NS",1:"") - S Y=$P(SRA(206),"^",41) W !,"Cardiac Surg Performed at Non-VA Facility: ",?47,$S(Y="Y":"YES",Y="N":"NO",Y="NS":"UNKNOWN",1:"") - S Y=$P(SRA(209),"^",15) D DT^SROAPCA1 W !,"CT Surgery Consult Date: ",?47,$P(X," ") - S Y=$P(SRA(209),"^",16),C=$P(^DD(130,515,0),"^",2) D:Y'="" Y^DIQ W !,"Cause for Delay for Surgery: ",?47,Y - W !,"Resource Data Comments: " - I $G(^SRF(SRTN,206.2))'="" S SRQ=0 S X=$G(^SRF(SRTN,206.2)) W:$L(X)<49 X,! I $L(X)>48 S Z=$L(X) D - .I X'[" " W ?25,X Q - .S I=0,LINE=1 F S SRL=$S(LINE=1:48,1:80) D Q:SRQ - ..I $E(X,1,SRL)'[" " W X,! S SRQ=1 Q - ..S J=SRL-I,Y=$E(X,J),I=I+1 I Y=" " W $E(X,1,J-1),!,?5 S X=$E(X,J+1,Z),Z=$L(X),I=0,LINE=LINE+1 I ZIOSL D PAGE^SROAPCA I SRSOUT Q - W ! F MOE=1:1:80 W "=" - W !,"IX. SOCIOECONOMIC, ETHNICITY, AND RACE" - N SREMP S SREMP=$P(SRA(208),"^",18) S SREMP=$S(SREMP=1:"EMPLOYED FULL TIME",SREMP=2:"EMPLOYED PART TIME",SREMP=3:"NOT EMPLOYED",SREMP=4:"SELF EMPLOYED",SREMP=5:"RETIRED",SREMP=6:"ACTIVE MILITARY DUTY",SREMP=9:"UNKNOWN",1:" ") - W !,?1,"Employment Status Preoperatively: ",?40,SREMP - K SRA,SRAO - ; Race/Ethnic - D ENTH^SRORACE - I $Y+7>IOSL D PAGE^SROAPCA I SRSOUT Q - D ^SROAPCA4 - W !!," *** End of report for "_SRANM_" assessment #"_SRTN_" ***" - I $E(IOST)'="P" W ! K DIR S DIR(0)="E" D ^DIR K DIR - Q +SROAPCA3 ;B'HAM ISC/MAM - CARDIAC OCCURRENCE DATA ;08/23/07 + ;;3.0; Surgery ;**38,71,95,101,125,160,164**;24 Jun 93;Build 2 + D EN^SROCCAT K SRA S SRA(205)=$G(^SRF(SRTN,205)),SRA(208)=$G(^SRF(SRTN,208)),SRA(206)=$G(^SRF(SRTN,206)),SRA(209)=$G(^SRF(SRTN,209)) + S NYUK=$P(SRA(208),"^") D YN S SRAO(1)=SHEMP_"^384" + S Y=$P($G(^DPT(DFN,.35)),"^") D DT^SROAPCA1 S SRAO(2)=X + S NYUK=$P(SRA(208),"^",2) D YN S SRAO(3)=SHEMP_"^385",NYUK=$P(SRA(208),"^",3) D YN S SRAO(4)=SHEMP_"^386",NYUK=$P(SRA(205),"^",17) D YN S SRAO(5)=SHEMP_"^254",NYUK=$P(SRA(209),"^",12) D YN S SRAO(6)=SHEMP_"^490" + S NYUK=$P(SRA(208),"^",5) D YN S SRAO(7)=SHEMP_"^388",NYUK=$P(SRA(208),"^",6) D YN S SRAO(8)=SHEMP_"^389",NYUK=$P(SRA(205),"^",13) D YN S SRAO(9)=SHEMP_"^285" + S NYUK=$P(SRA(208),"^",7) D YN S SRAO(10)=SHEMP_"^391",NYUK=$P(SRA(205),"^",22) D YN S SRAO(11)=SHEMP_"^410" + S NYUK=$P(SRA(205),"^",21) D YN S SRAO(12)=SHEMP_"^256",NYUK=$P(SRA(205),"^",26) D YN S SRAO(13)=SHEMP_"^411" + S NYUK=$P(SRA(206),"^",39) D YN S SRAO(14)=SHEMP_"^466" + S NYUK=$P(SRA(206),"^",40) D YN S SRAO(15)=SHEMP_"^467" + I $Y+5>IOSL D PAGE^SROAPCA I SRSOUT Q + W !!,"VII. OUTCOMES" + W !,"Operative Death:",?18,$P(SRAO(1),"^"),?43,"Date of Death:",?58,$P(SRAO(2),"^") + ;I $Y+10>IOSL D PAGE^SROAPCA I SRSOUT Q + W !!,"Perioperative (30 day) Occurrences:" + W !,?2,"Perioperative MI:",?36,$P(SRAO(3),"^"),?42,"Repeat cardiac Surg procedure:",?74,$P(SRAO(10),"^") + W !,?2,"Endocarditis:",?36,$P(SRAO(4),"^"),?42,"Tracheostomy:",?74,$P(SRAO(14),"^") + W !,?2,"Renal Failure Requiring Dialysis:",?36,$P(SRAO(5),"^"),?42,"Ventilator supp within 30 days:",?74,$P(SRAO(6),"^") + W !,?2,"Mediastinitis:",?36,$P(SRAO(7),"^"),?42,"Stroke/CVA:",?74,$P(SRAO(12),"^") + W !,?2,"Cardiac Arrest Requiring CPR:",?36,$P(SRAO(13),"^"),?42,"Coma > or = 24 Hours:",?74,$P(SRAO(11),"^") + W !,?2,"Reoperation for Bleeding:",?36,$P(SRAO(8),"^"),?42,"New Mech Circulatory Support:",?74,$P(SRAO(15),"^") + W !,?2,"On ventilator > or = 48 hr:",?36,$P(SRAO(9),"^") + D RES + Q +YN ; store answer + S SHEMP=$S(NYUK="NS":"NS",NYUK="N":"NO",NYUK="Y":"YES",1:"") + Q + ; +RES I $Y+12>IOSL D PAGE^SROAPCA I SRSOUT Q + S SRA(208)=$G(^SRF(SRTN,208)) + S SRA(.2)=$G(^SRF(SRTN,.2)) + W !!,"VIII. RESOURCE DATA" + S Y=$P($G(^SRF(SRTN,208)),"^",14) D DT^SROAPCA1 W !,"Hospital Admission Date:",?47,X + S Y=$P($G(^SRF(SRTN,208)),"^",15) D DT^SROAPCA1 W !,"Hospital Discharge Date:",?47,X + S Y=$P(SRA(.2),"^",10) D DT^SROAPCA1 W !,"Time Patient In OR: ",?47,X + S Y=$P(SRA(.2),"^",12) D DT^SROAPCA1 W !,"Time Patient Out OR: ",?47,X + S Y=$P($G(^SRF(SRTN,208)),"^",22) I Y>1 D DT^SROAPCA1 S Y=X + S Y=$S(Y="NS":"Unable to determine",Y="RI":"Remains intubated at 30 days",1:Y) W !,"Date and Time Patient Extubated: ",?47,Y + S Y=$P($G(^SRF(SRTN,208)),"^",23) I Y>1 D DT^SROAPCA1 S Y=X + S Y=$S(Y="NS":"Unable to determine",Y="RI":"Remains in ICU at 30 days",1:Y) W !,"Date and Time Patient Discharged from ICU: ",?47,Y + S Y=$P(SRA(209),"^") W !,"Patient is Homeless: ",?47,$S(Y="Y":"YES",Y="N":"NO",Y="NS":"NS",1:"") + S Y=$P(SRA(206),"^",41) W !,"Cardiac Surg Performed at Non-VA Facility: ",?47,$S(Y="Y":"YES",Y="N":"NO",Y="NS":"UNKNOWN",1:"") + S Y=$P(SRA(209),"^",15) D DT^SROAPCA1 W !,"CT Surgery Consult Date: ",?47,$P(X," ") + W !,"Resource Data Comments: " + I $G(^SRF(SRTN,206.2))'="" S SRQ=0 S X=$G(^SRF(SRTN,206.2)) W:$L(X)<49 X,! I $L(X)>48 S Z=$L(X) D + .I X'[" " W ?25,X Q + .S I=0,LINE=1 F S SRL=$S(LINE=1:48,1:80) D Q:SRQ + ..I $E(X,1,SRL)'[" " W X,! S SRQ=1 Q + ..S J=SRL-I,Y=$E(X,J),I=I+1 I Y=" " W $E(X,1,J-1),!,?5 S X=$E(X,J+1,Z),Z=$L(X),I=0,LINE=LINE+1 I ZIOSL D PAGE^SROAPCA I SRSOUT Q + W ! F MOE=1:1:80 W "=" + W !,"IX. SOCIOECONOMIC, ETHNICITY, AND RACE" + N SREMP S SREMP=$P(SRA(208),"^",18) S SREMP=$S(SREMP=1:"EMPLOYED FULL TIME",SREMP=2:"EMPLOYED PART TIME",SREMP=3:"NOT EMPLOYED",SREMP=4:"SELF EMPLOYED",SREMP=5:"RETIRED",SREMP=6:"ACTIVE MILITARY DUTY",SREMP=9:"UNKNOWN",1:" ") + W !,?1,"Employment Status Preoperatively: ",?40,SREMP + K SRA,SRAO + ; Race/Ethnic + D ENTH^SRORACE + I $Y+7>IOSL D PAGE^SROAPCA I SRSOUT Q + D ^SROAPCA4 + W !!," *** End of report for "_SRANM_" assessment #"_SRTN_" ***" + I $E(IOST)'="P" W ! K DIR S DIR(0)="E" D ^DIR K DIR + Q diff --git a/r/SURGERY-SR/SROAPM.m b/r/SURGERY-SR/SROAPM.m index d4ae2538..cc9c32ac 100644 --- a/r/SURGERY-SR/SROAPM.m +++ b/r/SURGERY-SR/SROAPM.m @@ -1,133 +1,124 @@ -SROAPM ;BIR/ADM - PATIENT DEMOGRAPHIC INFO ;03/03/08 - ;;3.0; Surgery ;**47,81,111,107,100,125,142,160,166**;24 Jun 93;Build 7 - I '$D(SRTN) W !!,"A Surgery Risk Assessment must be selected prior to using this option.",!!,"Press to continue " R X:DTIME G END - S SRSOUT=0,SRSUPCPT=1 D ^SROAUTL -START G:SRSOUT END D HDR^SROAUTL - S DIR("A",1)="Enter/Edit Patient Demographic Information",DIR("A",2)=" ",DIR("A",3)="1. Capture Information from PIMS Records",DIR("A",4)="2. Enter, Edit, or Review Information",DIR("A",5)=" " - S DIR("?",1)="Enter '1' if you want to capture patient movement information from PIMS",DIR("?",2)="records. Enter '2' if you want to enter, edit, or review patient",DIR("?")="movement and other information on this screen." - S DIR("A")="Select Number",DIR(0)="NO^1:2" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT)!'Y S SRSOUT=1 G END - I Y=1 D PIMS G START -EDIT S SRR=0 D HDR^SROAUTL K DR S SRQ=0,(DR,SRDR)="413;452;453;454;418;419;420;421;247;.011" - K DA,DIC,DIQ,SRY S DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="E",DR=SRDR D EN^DIQ1 K DA,DIC,DIQ,DR - K SRZ S SRZ=0 F M=1:1 S I=$P(SRDR,";",M) Q:'I D - .D TR,GET - .S SRZ=SRZ+1,Y=$P(X,";;",2),SRFLD=$P(Y,"^"),(Z,SRZ(SRZ))=$P(Y,"^",2)_"^"_SRFLD,SREXT=SRY(130,SRTN,SRFLD,"E") - .W !,$S($L(SRZ)<2:" "_SRZ,1:SRZ)_". "_$P(Z,"^")_":" D EXT - ; - D DEM^VADPT - ;Find patient's ethnicity and list it on the display - W !,"11. Patient's Ethnicity:" S SRZ(11)="" D - .I $G(VADM(11)) W ?40,$P(VADM(11,1),U,2) - .I '$G(VADM(11)) W ?40,"UNANSWERED" - ; - ;Find all race entries and place into a string with commas inbetween - S SRORC=0,C=1,SRORACE="",SROLINE="",N=1,SROL="" - F S SRORC=$O(VADM(12,SRORC)) Q:SRORC="" Q:C=11 D - .I $G(VADM(12,SRORC)) S SRORACE(C)=$P(VADM(12,SRORC),U,2) - .I SROLINE'="" S SROLINE=SROLINE_", "_SRORACE(C) - .I SROLINE="" S SROLINE=SRORACE(C) - .S C=C+1 - ; - ;Find total length of 'race' string and wrap the text if necessary - I $L(SROLINE)=40!$L(SROLINE)<40 S SROL(N)=SROLINE,SRNUM1=2 - I $L(SROLINE)>40 D WRAP - ; - W !,"12. Patient's Race:" S SRZ(12)="" - I $G(VADM(12)) F D=1:1:SRNUM1-1 D - .W:D=1 ?40,SROL(D) - .W:D'=1 !,?40,SROL(D) - ; - I '$G(VADM(12)) W ?40,"UNANSWERED" - ; - K DA,DIC,DIQ,DR,SRY S (DR,SRDR)="342;516;513",DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="E",DR=SRDR D EN^DIQ1 K DA,DIC,DIQ,DR - S SRZ=12 F M=1:1 S I=$P(SRDR,";",M) Q:'I D - .D TR,GET - .S SRZ=SRZ+1,Y=$P(X,";;",2),SRFLD=$P(Y,"^"),(Z,SRZ(SRZ))=$P(Y,"^",2)_"^"_SRFLD,SREXT=SRY(130,SRTN,SRFLD,"E") - .W !,$S($L(SRZ)<2:" "_SRZ,1:SRZ)_". "_$P(Z,"^")_":" D EXT - ;S SRZ=15,SRZ(13)="Date of Death^342",SREXT=SRY(130,SRTN,342,"E") W !,"13. Date/Time of Death:",?40,SREXT - ;S SRZ(14)="Surgery Consult Date^513",SREXT=SRY(130,SRTN,513,"E") W !,"14. Surgery Consult Date:",?40,SREXT - ;S SRZ(15)="Date Surgery Consult Requested^516",SREXT=SRY(130,SRTN,516,"E") W !,"15. Date Surgery Consult Requested:",?40,SREXT - K SROL,SROLINE,SRORC,SRORACE,SROLN,SROLN1,SROWRAP,SRNUM1 - ; - W !! F K=1:1:80 W "-" - D SEL G:SRR=1 EDIT - S SROERR=SRTN D ^SROERR0 - G START - Q - ; -WRAP ;Wrap multiple race entries so that wrapped line - ;does not break in the middle of a word - ; - N SROLNGTH S SROLNGTH=$L(SROLINE),E=40,SROWRAP="",SROLN="",SROLN1="",SROL="" - F I=1:40:SROLNGTH S SROLN(I)=SROWRAP_$E(SROLINE,I,E) D - .F K=40:-1:1 I $E(SROLN(I),K)[" " D Q ;Break lines at space - ..S SROLN1(I)=$E(SROLN(I),1,K-1) - ..S SROWRAP=$E(SROLN(I),K+1,E) - .S E=E+40 - ; - S:'$D(SROLN1(I)) SROLN1(I)=SROLN(I),SROWRAP="" - I $L(SROLN1(I))+$L(SROWRAP)>39 S SROLN1(I+1)=SROWRAP ;Last line - I $L(SROLN1(I))+$L(SROWRAP)'>39 S SROLN1(I)=SROLN1(I)_" "_SROWRAP - ; - ;Renumber the SROLN1 array to be in numeric order - S SRNUM=0,SRNUM1=1 - F S SRNUM=$O(SROLN1(SRNUM)) Q:SRNUM="" D - .S SROL(SRNUM1)=SROLN1(SRNUM) - .S SRNUM1=SRNUM1+1 - Q - ; -EXT I $L(SREXT)<40 W ?40,SREXT W:SRFLD=247 $S(SREXT="":"",SREXT=1:" Day",SREXT=0:" Days",SREXT>1:" Days",1:"") Q - N I,J,X,Y S X=SREXT F D W:$L(X) ! I $L(X)<40!(X'[" ") W ?40,X Q - .F I=0:1:38 S J=39-I,Y=$E(X,J) I Y=" " W ?40,$E(X,1,J-1) S X=$E(X,J+1,$L(X)) Q - Q -SEL W !!,"Select Patient Demographics Information to Edit: " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q - I (X=11)!(X=12) S SRR=1 W !!,"The Patient's Race and Ethnicity information cannot be updated through the" D Q - .W !,"Surgery package options." - .W !!,"Press RETURN to continue " R X:DTIME - Q:X="" S:X="a" X="A" I '$D(SRFLG),'$D(SRZ(X)),(X'?1.2N1":"1.2N),X'="A" D HELP S SRR=1 Q - I X?1.2N1":"1.2N S Y=$P(X,":"),Z=$P(X,":",2) I Y<1!(Z>SRZ)!(Y>Z) D HELP S SRR=1 Q - I X="A" S X="1:"_SRZ - I X?1.2N1":"1.2N D RANGE S SRR=1 Q - I $D(SRZ(X)),+X=X S EMILY=X D S SRR=1 - .I $$LOCK^SROUTL(SRTN) D ONE,UNLOCK^SROUTL(SRTN) - Q -PIMS ; get update from PIMS records - W ! K DIR S DIR("A")="Are you sure you want to retrieve information from PIMS records ? ",DIR("B")="YES",DIR(0)="YOA" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT)!'Y Q - I $$LOCK^SROUTL(SRTN) D D UNLOCK^SROUTL(SRTN) - .W ! D WAIT^DICD D ^SROAPIMS - Q -HELP W @IOF,!!!!,"Enter the number or range of numbers you want to edit. Examples of proper",!,"responses are listed below.",!!,"NOTE: Items 11 and 12 cannot be updated through the surgery package options." - W !!,"1. Enter 'A' to update items 1 through 10 and items 13 through 15.",!!,"2. Enter a number (1-"_SRZ_") to update an individual item. (For example,",!," enter '1' to update "_$P(SRZ(1),"^")_")" - W !!,"3. Enter a range of numbers (1-"_SRZ_") separated by a ':' to enter a range",!," of items. (For example, enter '1:4' to update items 1, 2, 3 and 4.)",! - I $D(SRFLG) W !,"4. Enter 'N' or 'NO' to enter negative response for all items.",!!,"5. Enter '@' to delete information from all items.",! -PRESS W ! K DIR S DIR("A")="Press the return key to continue or '^' to exit: ",DIR(0)="FOA" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 - Q -RANGE ; range of numbers - I $$LOCK^SROUTL(SRTN) D D UNLOCK^SROUTL(SRTN) - .S SHEMP=$P(X,":"),CURLEY=$P(X,":",2) D - ..I SHEMP<13 F EMILY=SHEMP:1:10,13:1:15 Q:SRSOUT D ONE - ..I SHEMP>12 F EMILY=SHEMP:1:15 Q:SRSOUT D ONE - Q -ONE ; edit one item - K DR,DA,DIE S DR=$P(SRZ(EMILY),"^",2)_"T",DA=SRTN,DIE=130,SRDT=$P(SRZ(EMILY),"^",3) S:SRDT DR=DR_";"_SRDT_"T" D ^DIE K DR,DA I $D(Y) S SRSOUT=1 - Q -TR S J=I,J=$TR(J,"1234567890.","ABCDEFGHIJP") - Q -GET S X=$T(@J) - Q -END W @IOF D ^SRSKILL - Q -PJAA ;;.011^In/Out-Patient Status -BDG ;;247^Length of Postop Hospital Stay -CDB ;;342^Date of Death -DAC ;;413^Transfer Status -DAG ;;417^Patient's Race -DAH ;;418^Hospital Admission Date/Time -DAI ;;419^Hospital Discharge Date/Time -DBJ ;;420^Admit/Transfer to Surgical Svc. -DBA ;;421^Discharge/Transfer to Chronic Care -DEB ;;452^Observation Admission Date/Time -DEC ;;453^Observation Discharge Date/Time -DED ;;454^Observation Treating Specialty -EAC ;;513^Surgery Consult Date -EAF ;;516^Date Surgery Consult Requested +SROAPM ;BIR/ADM - PATIENT DEMOGRAPHIC INFO ;01/23/07 + ;;3.0; Surgery ;**47,81,111,107,100,125,142,160**;24 Jun 93;Build 7 + I '$D(SRTN) W !!,"A Surgery Risk Assessment must be selected prior to using this option.",!!,"Press to continue " R X:DTIME G END + S SRSOUT=0,SRSUPCPT=1 D ^SROAUTL +START G:SRSOUT END D HDR^SROAUTL + S DIR("A",1)="Enter/Edit Patient Demographic Information",DIR("A",2)=" ",DIR("A",3)="1. Capture Information from PIMS Records",DIR("A",4)="2. Enter, Edit, or Review Information",DIR("A",5)=" " + S DIR("?",1)="Enter '1' if you want to capture patient movement information from PIMS",DIR("?",2)="records. Enter '2' if you want to enter, edit, or review patient",DIR("?")="movement and other information on this screen." + S DIR("A")="Select Number",DIR(0)="NO^1:2" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT)!'Y S SRSOUT=1 G END + I Y=1 D PIMS G START +EDIT S SRR=0 D HDR^SROAUTL K DR S SRQ=0,(DR,SRDR)="413;452;453;454;418;419;420;421;247;.011" + K DA,DIC,DIQ,SRY S DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="E",DR=SRDR D EN^DIQ1 K DA,DIC,DIQ,DR + K SRZ S SRZ=0 F M=1:1 S I=$P(SRDR,";",M) Q:'I D + .D TR,GET + .S SRZ=SRZ+1,Y=$P(X,";;",2),SRFLD=$P(Y,"^"),(Z,SRZ(SRZ))=$P(Y,"^",2)_"^"_SRFLD,SREXT=SRY(130,SRTN,SRFLD,"E") + .W !,$S($L(SRZ)<2:" "_SRZ,1:SRZ)_". "_$P(Z,"^")_":" D EXT + ; + D DEM^VADPT + ;Find patient's ethnicity and list it on the display + W !,"11. Patient's Ethnicity:" S SRZ(11)="" D + .I $G(VADM(11)) W ?40,$P(VADM(11,1),U,2) + .I '$G(VADM(11)) W ?40,"UNANSWERED" + ; + ;Find all race entries and place into a string with commas inbetween + S SRORC=0,C=1,SRORACE="",SROLINE="",N=1,SROL="" + F S SRORC=$O(VADM(12,SRORC)) Q:SRORC="" Q:C=11 D + .I $G(VADM(12,SRORC)) S SRORACE(C)=$P(VADM(12,SRORC),U,2) + .I SROLINE'="" S SROLINE=SROLINE_", "_SRORACE(C) + .I SROLINE="" S SROLINE=SRORACE(C) + .S C=C+1 + ; + ;Find total length of 'race' string and wrap the text if necessary + I $L(SROLINE)=40!$L(SROLINE)<40 S SROL(N)=SROLINE,SRNUM1=2 + I $L(SROLINE)>40 D WRAP + ; + W !,"12. Patient's Race:" S SRZ(12)="" + I $G(VADM(12)) F D=1:1:SRNUM1-1 D + .W:D=1 ?40,SROL(D) + .W:D'=1 !,?40,SROL(D) + ; + I '$G(VADM(12)) W ?40,"UNANSWERED" + ; + K DA,DIC,DIQ,DR,SRY S (DR,SRDR)="342",DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="E",DR=SRDR D EN^DIQ1 K DA,DIC,DIQ,DR + S SRZ=13,SRZ(13)="Date of Death^342",SREXT=SRY(130,SRTN,342,"E") + W !,"13. Date/Time of Death:",?40,SREXT + K SROL,SROLINE,SRORC,SRORACE,SROLN,SROLN1,SROWRAP,SRNUM1 + ; + W !! F K=1:1:80 W "-" + D SEL G:SRR=1 EDIT + S SROERR=SRTN D ^SROERR0 + G START + Q + ; +WRAP ;Wrap multiple race entries so that wrapped line + ;does not break in the middle of a word + ; + N SROLNGTH S SROLNGTH=$L(SROLINE),E=40,SROWRAP="",SROLN="",SROLN1="",SROL="" + F I=1:40:SROLNGTH S SROLN(I)=SROWRAP_$E(SROLINE,I,E) D + .F K=40:-1:1 I $E(SROLN(I),K)[" " D Q ;Break lines at space + ..S SROLN1(I)=$E(SROLN(I),1,K-1) + ..S SROWRAP=$E(SROLN(I),K+1,E) + .S E=E+40 + ; + S:'$D(SROLN1(I)) SROLN1(I)=SROLN(I),SROWRAP="" + I $L(SROLN1(I))+$L(SROWRAP)>39 S SROLN1(I+1)=SROWRAP ;Last line + I $L(SROLN1(I))+$L(SROWRAP)'>39 S SROLN1(I)=SROLN1(I)_" "_SROWRAP + ; + ;Renumber the SROLN1 array to be in numeric order + S SRNUM=0,SRNUM1=1 + F S SRNUM=$O(SROLN1(SRNUM)) Q:SRNUM="" D + .S SROL(SRNUM1)=SROLN1(SRNUM) + .S SRNUM1=SRNUM1+1 + Q + ; +EXT I $L(SREXT)<40 W ?40,SREXT W:SRFLD=247 $S(SREXT="":"",SREXT=1:" Day",SREXT=0:" Days",SREXT>1:" Days",1:"") Q + N I,J,X,Y S X=SREXT F D W:$L(X) ! I $L(X)<40!(X'[" ") W ?40,X Q + .F I=0:1:38 S J=39-I,Y=$E(X,J) I Y=" " W ?40,$E(X,1,J-1) S X=$E(X,J+1,$L(X)) Q + Q +SEL W !!,"Select number of item to edit: " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q + I (X=11)!(X=12) S SRR=1 W !!,"The Patient's Race and Ethnicity information cannot be updated through the" D Q + .W !,"Surgery package options." + .W !!,"Press RETURN to continue " R X:DTIME + Q:X="" S:X="a" X="A" I '$D(SRFLG),'$D(SRZ(X)),(X'?1.2N1":"1.2N),X'="A" D HELP S SRR=1 Q + I X?1.2N1":"1.2N S Y=$P(X,":"),Z=$P(X,":",2) I Y<1!(Z>SRZ)!(Y>Z) D HELP S SRR=1 Q + I X="A" S X="1:"_SRZ + I X?1.2N1":"1.2N D RANGE S SRR=1 Q + I $D(SRZ(X)),+X=X S EMILY=X D S SRR=1 + .I $$LOCK^SROUTL(SRTN) D ONE,UNLOCK^SROUTL(SRTN) + Q +PIMS ; get update from PIMS records + W ! K DIR S DIR("A")="Are you sure you want to retrieve information from PIMS records ? ",DIR("B")="YES",DIR(0)="YOA" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT)!'Y Q + I $$LOCK^SROUTL(SRTN) D D UNLOCK^SROUTL(SRTN) + .W ! D WAIT^DICD D ^SROAPIMS + Q +HELP W @IOF,!!!!,"Enter the number or range of numbers you want to edit. Examples of proper",!,"responses are listed below.",!!,"NOTE: Items 11 and 12 cannot be updated through the surgery package options." + W !!,"1. Enter 'A' to update items 1 through 10 and item 13.",!!,"2. Enter a number (1-"_SRZ_") to update an individual item. (For example,",!," enter '1' to update "_$P(SRZ(1),"^")_")" + W !!,"3. Enter a range of numbers (1-"_SRZ_") separated by a ':' to enter a range",!," of items. (For example, enter '1:4' to update items 1, 2, 3 and 4.)",! + I $D(SRFLG) W !,"4. Enter 'N' or 'NO' to enter negative response for all items.",!!,"5. Enter '@' to delete information from all items.",! +PRESS W ! K DIR S DIR("A")="Press the return key to continue or '^' to exit: ",DIR(0)="FOA" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 + Q +RANGE ; range of numbers + I $$LOCK^SROUTL(SRTN) D D UNLOCK^SROUTL(SRTN) + .S SHEMP=$P(X,":"),CURLEY=$P(X,":",2) F EMILY=SHEMP:1:10,13 Q:SRSOUT D ONE + Q +ONE ; edit one item + K DR,DA,DIE S DR=$P(SRZ(EMILY),"^",2)_"T",DA=SRTN,DIE=130,SRDT=$P(SRZ(EMILY),"^",3) S:SRDT DR=DR_";"_SRDT_"T" D ^DIE K DR,DA I $D(Y) S SRSOUT=1 + Q +TR S J=I,J=$TR(J,"1234567890.","ABCDEFGHIJP") + Q +GET S X=$T(@J) + Q +END W @IOF D ^SRSKILL + Q +PJAA ;;.011^In/Out-Patient Status +BDG ;;247^Length of Postop Hospital Stay +CDB ;;342^Date of Death +DAC ;;413^Transfer Status +DAG ;;417^Patient's Race +DAH ;;418^Hospital Admission Date/Time +DAI ;;419^Hospital Discharge Date/Time +DBJ ;;420^Admit/Transfer to Surgical Svc. +DBA ;;421^Discharge/Transfer to Chronic Care +DEB ;;452^Observation Admission Date/Time +DEC ;;453^Observation Discharge Date/Time +DED ;;454^Observation Treating Specialty diff --git a/r/SURGERY-SR/SROAPRE.m b/r/SURGERY-SR/SROAPRE.m index 77cc19d8..d2df02e2 100644 --- a/r/SURGERY-SR/SROAPRE.m +++ b/r/SURGERY-SR/SROAPRE.m @@ -1,52 +1,58 @@ -SROAPRE ;BIR/MAM - PREOPERATIVE INFO ;11/26/07 - ;;3.0; Surgery ;**38,47,55,88,100,125,142,166**;24 Jun 93;Build 7 - I '$D(SRTN) W !!,"A Surgery Risk Assessment must be selected prior to using this option.",!!,"Press to continue " R X:DTIME G END - S (SRSOUT,SRACLR)=0,SRSUPCPT=1 D ^SROAUTL,DUP^SROAUTL G:SRSOUT END -START D:SRACLR RET G:SRSOUT END S SRACLR=0 K SRA,SRAO D ^SROAPS1 -ASK W !,"Select Preoperative Information to Edit: " R X:DTIME I '$T!(X["^") D CONCC G END - S:X="" X="+1" S:X="a" X="A" S:X="n" X="N" - I $L(X)=2,'$D(SRAO(X)),X?1N1A S Z=$E(X,2),Z=$TR(Z,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") I $D(SRAO($E(X)_Z)) S X=$E(X)_Z - I '$D(SRAO(X)),(X'?.N1":".N),(X'="A"),(X'="N"),(X'="+1") D HELP G:SRSOUT END G START - I X="+1" D CONCC,^SROAPR2 G START - I X="A" S X="1:6" - I X?.N1":".N S Y=$E(X),Z=$P(X,":",2) I Y<1!(Z>6)!(Y>Z) D HELP G:SRSOUT END G START - I X="N" D G:SRSOUT END G START - .W ! K DIR S DIR(0)="Y",DIR("B")="NO",DIR("A")="Are you sure you want to set all fields on this page to NO" - .D ^DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q - .I Y D NO2ALL^SROAPRE1 - S SRPAGE="" D HDR^SROAUTL - I X?.N1":".N D RANGE G START - I $D(SRAO(X)),+X=X S EMILY=X D G START - .I $$LOCK^SROUTL(SRTN) W ! D:EMILY<4 ^SROAPRE1 D:EMILY>3 ^SROAPR1A D UNLOCK^SROUTL(SRTN) - I $D(SRAO(X)),$$LOCK^SROUTL(SRTN) D D UNLOCK^SROUTL(SRTN) - .I X="1H" D FUNCTH Q - .S SRX=X W ! K DR,DIE S DA=SRTN,DR=$P(SRAO(X),"^",2)_"T",DIE=130 D ^DIE K DR - G START -END I '$D(SREQST) W @IOF D ^SRSKILL - Q -FUNCTH N X K DA,DIR S DA=SRTN,DIR(0)="130,492",DIR("A")="Functional Health Status at Evaluation for Surgery" D ^DIR K DIR D Q - .I $D(DTOUT)!$D(DUOUT) Q - .I X="@" K DIE,DR S DIE=130,DR="492///@" D ^DIE K DA,DIE,DR Q - .K DIE,DR S DIE=130,DR="492////"_Y D ^DIE K DA,DIE,DR - Q -HELP W @IOF,!!!!,"Enter the number, number/letter combination, or range of numbers you want to",!,"edit. Examples of proper responses are listed below." - W !!,"1. Enter 'A' to update all information.",!!,"2. Enter 'N' to set all fields on this page to NO." - W !!,"3. Enter a number (1-6) to update the information in that group. (For",!," example, enter '5' to update all cardiac information)" - W !!,"4. Enter a number/letter combination to update a specific occurrence. (To ",!," update Current Pneumonia, enter '2C'.)" - W !!,"5. Enter a range of numbers (1-6) separated by a ':' to enter a range of",!," occurrences. (For example, enter '2:4' to enter all pulmonary,",!," hepatobiliary, and gastrointestinal information)" - W !!,"6. Press to continue to page 2 of this option." - W !!,"Press to continue, or '^' to quit " R X:DTIME I '$T!(X["^") S SRSOUT=1 - Q -RANGE ; range of numbers - I $$LOCK^SROUTL(SRTN) D D UNLOCK^SROUTL(SRTN) - .S SHEMP=$P(X,":"),CURLEY=$P(X,":",2) W:SHEMP<9 ! F EMILY=SHEMP:1:CURLEY Q:SRSOUT D:EMILY<4 ^SROAPRE1 D:EMILY>3 ^SROAPR1A - Q -RET Q:SRSOUT W !!,"Press to continue, or '^' to quit " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q - Q -CONCC ; check for concurrent case and update if one exists - S SRCON=$P($G(^SRF(SRTN,"CON")),"^") Q:'SRCON - Q:$P($G(^SRF(SRCON,"RA")),"^",2)="C" - S SRI="" F S SRI=$O(SRAO(SRI)) Q:SRI="" S SRZ=$P(SRAO(SRI),"^",2) K DA,DIC,DIQ,DR,SRY D - .S DA=SRTN,DR=SRZ,DIC="^SRF(",DIQ="SRY",DIQ(0)="I" D EN^DIQ1 S SRX=SRY(130,SRTN,SRZ,"I") S:SRX="" SRX="@" - .I $$LOCK^SROUTL(SRTN) K DA,DIE,DR S DA=SRCON,DIE=130,DR=SRZ_"////"_SRX D ^DIE K DR D UNLOCK^SROUTL(SRTN) - Q +SROAPRE ;BIR/MAM - PREOPERATIVE INFO ;06/03/05 + ;;3.0; Surgery ;**38,47,55,88,100,125,142**;24 Jun 93 + I '$D(SRTN) W !!,"A Surgery Risk Assessment must be selected prior to using this option.",!!,"Press to continue " R X:DTIME G END + S (SRSOUT,SRACLR)=0,SRSUPCPT=1 D ^SROAUTL,DUP^SROAUTL G:SRSOUT END +START D:SRACLR RET G:SRSOUT END S SRACLR=0 K SRA,SRAO D ^SROAPS1 +ASK W !,"Select Preoperative Information to Edit: " R X:DTIME I '$T!(X["^") D CONCC G END + S:X="" X="+1" S:X="a" X="A" S:X="n" X="N" + I $L(X)=2,'$D(SRAO(X)),X?1N1A S Z=$E(X,2),Z=$TR(Z,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") I $D(SRAO($E(X)_Z)) S X=$E(X)_Z + I '$D(SRAO(X)),(X'?.N1":".N),(X'="A"),(X'="N"),(X'="+1") D HELP G:SRSOUT END G START + I X="+1" D CONCC,^SROAPR2 G START + I X="A" S X="1:6" + I X?.N1":".N S Y=$E(X),Z=$P(X,":",2) I Y<1!(Z>6)!(Y>Z) D HELP G:SRSOUT END G START + I X="N" D G:SRSOUT END G START + .W ! K DIR S DIR(0)="Y",DIR("B")="NO",DIR("A")="Are you sure you want to set all fields on this page to NO" + .D ^DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q + .I Y D NO2ALL^SROAPRE1 + S SRPAGE="" D HDR^SROAUTL + I X?.N1":".N D RANGE G START + I $D(SRAO(X)),+X=X S EMILY=X D G START + .I $$LOCK^SROUTL(SRTN) W ! D:EMILY<4 ^SROAPRE1 D:EMILY>3 ^SROAPR1A D UNLOCK^SROUTL(SRTN) + I $D(SRAO(X)),$$LOCK^SROUTL(SRTN) D D UNLOCK^SROUTL(SRTN) + .I X="1J" D FUNCTI Q + .I X="1I" D FUNCTJ Q + .S SRX=X W ! K DR,DIE S DA=SRTN,DR=$P(SRAO(X),"^",2)_"T",DIE=130 D ^DIE K DR + G START +END I '$D(SREQST) W @IOF D ^SRSKILL + Q +FUNCTI N X K DA,DIR S DA=SRTN,DIR(0)="130,492",DIR("A")="Functional Health Status at Evaluation for Surgery" D ^DIR K DIR D Q + .I $D(DTOUT)!$D(DUOUT) Q + .I X="@" K DIE,DR S DIE=130,DR="492///@" D ^DIE K DA,DIE,DR Q + .K DIE,DR S DIE=130,DR="492////"_Y D ^DIE K DA,DIE,DR + Q +FUNCTJ N X K DA,DIR S DA=SRTN,DIR(0)="130,240",DIR("A")="Functional Health Status Prior to Current Illness" D ^DIR K DIR D Q + .I $D(DTOUT)!$D(DUOUT) Q + .I X="@" K DIE,DR S DIE=130,DR="240///@" D ^DIE K DA,DIE,DR Q + .K DIE,DR S DIE=130,DR="240////"_Y D ^DIE K DA,DIE,DR + Q +HELP W @IOF,!!!!,"Enter the number, number/letter combination, or range of numbers you want to",!,"edit. Examples of proper responses are listed below." + W !!,"1. Enter 'A' to update all information.",!!,"2. Enter 'N' to set all fields on this page to NO." + W !!,"3. Enter a number (1-6) to update the information in that group. (For",!," example, enter '5' to update all cardiac information)" + W !!,"4. Enter a number/letter combination to update a specific occurrence. (To ",!," update Current Pneumonia, enter '2C'.)" + W !!,"5. Enter a range of numbers (1-6) separated by a ':' to enter a range of",!," occurrences. (For example, enter '2:4' to enter all pulmonary,",!," hepatobiliary, and gastrointestinal information)" + W !!,"6. Press to continue to page 2 of this option." + W !!,"Press to continue, or '^' to quit " R X:DTIME I '$T!(X["^") S SRSOUT=1 + Q +RANGE ; range of numbers + I $$LOCK^SROUTL(SRTN) D D UNLOCK^SROUTL(SRTN) + .S SHEMP=$P(X,":"),CURLEY=$P(X,":",2) W:SHEMP<9 ! F EMILY=SHEMP:1:CURLEY Q:SRSOUT D:EMILY<4 ^SROAPRE1 D:EMILY>3 ^SROAPR1A + Q +RET Q:SRSOUT W !!,"Press to continue, or '^' to quit " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q + Q +CONCC ; check for concurrent case and update if one exists + S SRCON=$P($G(^SRF(SRTN,"CON")),"^") Q:'SRCON + Q:$P($G(^SRF(SRCON,"RA")),"^",2)="C" + S SRI="" F S SRI=$O(SRAO(SRI)) Q:SRI="" S SRZ=$P(SRAO(SRI),"^",2) K DA,DIC,DIQ,DR,SRY D + .S DA=SRTN,DR=SRZ,DIC="^SRF(",DIQ="SRY",DIQ(0)="I" D EN^DIQ1 S SRX=SRY(130,SRTN,SRZ,"I") S:SRX="" SRX="@" + .I $$LOCK^SROUTL(SRTN) K DA,DIE,DR S DA=SRCON,DIE=130,DR=SRZ_"////"_SRX D ^DIE K DR D UNLOCK^SROUTL(SRTN) + Q diff --git a/r/SURGERY-SR/SROAPRE1.m b/r/SURGERY-SR/SROAPRE1.m index 20f6258d..6a2f28a4 100644 --- a/r/SURGERY-SR/SROAPRE1.m +++ b/r/SURGERY-SR/SROAPRE1.m @@ -1,63 +1,68 @@ -SROAPRE1 ;BIR/MAM - EDIT PAGE 1 PREOP ;11/26/07 - ;;3.0; Surgery ;**38,47,125,135,141,166**;24 Jun 93;Build 7 - K DA D @EMILY Q -1 ; edit general information - W ! K DIR S X=$P(SRAO(1),"^") I X'="" S DIR("B")=X - S DIR(0)="130,402",DIR("A")="GENERAL" D ^DIR K DIR I $D(DUOUT) S SRSOUT=1 Q - I X="@" S SRCAT="General" D SURE Q:SRSOUT G:'SRYN 1 S (SRAX,X)="",$P(^SRF(SRTN,200),"^")="" D NOGEN Q - S SRAX=Y,$P(^SRF(SRTN,200),"^")=SRAX I Y["N" D NOGEN Q - I Y["Y" D GEN - Q -2 ; edit pulmonary information - W ! K DIR S X=$P(SRAO(2),"^") I X'="" S DIR("B")=X - S DIR(0)="130,241",DIR("A")="PULMONARY" D ^DIR K DIR I $D(DUOUT) S SRSOUT=1 Q - I X="@" S SRCAT="Pulmonary" D SURE Q:SRSOUT G:'SRYN 2 S (SRAX,X)="",$P(^SRF(SRTN,200),"^",9)="" D NOPULM Q - S SRAX=Y,$P(^SRF(SRTN,200),"^",9)=SRAX I Y["N" D NOPULM Q - I Y["Y" D PULM - Q -3 ; edit hepatobiliary information - W ! K DIR S X=$P(SRAO(3),"^") I X'="" S DIR("B")=X - S DIR(0)="130,244",DIR("A")="HEPATOBILIARY" D ^DIR K DIR I $D(DUOUT) S SRSOUT=1 Q - I X="@" S SRCAT="Hepatobiliary" D SURE Q:SRSOUT G:'SRYN 3 S (SRAX,X)="",$P(^SRF(SRTN,200),"^",13)="" D NOHEP Q - S SRAX=Y,$P(^SRF(SRTN,200),"^",13)=SRAX I Y["N" D NOHEP Q - I Y["Y" D HEP - Q -GEN ; general - N SRUP S SRUP="" - W ! K DR,DIE S DA=SRTN,DIE=130,DR="236T;237T;346T;202T;246T;325T;238T" D ^DIE K DIE,DR I $D(Y) Q - K DIR S DA=SRTN,DIR(0)="130,492",DIR("A")="Functional Health Status at Evaluation for Surgery" D ^DIR K DIR D - .I $D(DTOUT)!$D(DUOUT) Q - .I X="@" K DIE,DR S DIE=130,DR="492///@" D ^DIE K DA,DIE,DR Q - .K DIE,DR S DIE=130,DR="492////"_Y D ^DIE K DA,DIE,DR - S SRACLR=0 - Q -NOGEN ; no general problems - S $P(^SRF(SRTN,200),"^",6)=$S(X="":"",1:1) F I=2,3,4,7 S $P(^SRF(SRTN,200),"^",I)=SRAX - S $P(^SRF(SRTN,200.1),"^",2)=$S(X="":"",X="NS":"NS",1:1) - Q -PULM ; pulmonary - W ! K DR,DIE S DA=SRTN,DIE=130,DR="204T;203T;326T" D ^DIE K DR - S SRACLR=0 - Q -NOPULM ; no pulmonary problems - F I=10:1:12 S $P(^SRF(SRTN,200),"^",I)=SRAX - Q -HEP ; hepatobiliary - K DR,DIE S DIE=130,DA=SRTN,DR="212////Y" D ^DIE K DR - S SRACLR=0 - Q -NOHEP ; no hepatobiliary problems - S $P(^SRF(SRTN,200),"^",15)=SRAX - Q -RET W !! K DIR S DIR(0)="E" D ^DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 - Q -SURE W ! K DIR S DIR("A")=" Sure you want to delete all "_SRCAT_" information ? ",DIR("B")="NO",DIR(0)="YA" D ^DIR K DIR S SRYN=Y I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 - Q -NO2ALL ; set all fields to NO - S SRAX="N",$P(^SRF(SRTN,200),"^")=SRAX D NOGEN - S $P(^SRF(SRTN,200),"^",9)=SRAX D NOPULM - S $P(^SRF(SRTN,200),"^",13)=SRAX D NOHEP - S $P(^SRF(SRTN,200.1),"^")=SRAX D NOGAST^SROAPR1A - S $P(^SRF(SRTN,200),"^",30)=SRAX D NOCARD^SROAPR1A - S $P(^SRF(SRTN,200),"^",40)=SRAX D NOVAS^SROAPR1A - Q +SROAPRE1 ;B'HAM ISC/MAM - EDIT PAGE 1 PREOP ;01/05/05 + ;;3.0; Surgery ;**38,47,125,135,141**;24 Jun 93 + K DA D @EMILY Q +1 ; edit general information + W ! K DIR S X=$P(SRAO(1),"^") I X'="" S DIR("B")=X + S DIR(0)="130,402",DIR("A")="GENERAL" D ^DIR K DIR I $D(DUOUT) S SRSOUT=1 Q + I X="@" S SRCAT="General" D SURE Q:SRSOUT G:'SRYN 1 S (SRAX,X)="",$P(^SRF(SRTN,200),"^")="" D NOGEN Q + S SRAX=Y,$P(^SRF(SRTN,200),"^")=SRAX I Y["N" D NOGEN Q + I Y["Y" D GEN + Q +2 ; edit pulmonary information + W ! K DIR S X=$P(SRAO(2),"^") I X'="" S DIR("B")=X + S DIR(0)="130,241",DIR("A")="PULMONARY" D ^DIR K DIR I $D(DUOUT) S SRSOUT=1 Q + I X="@" S SRCAT="Pulmonary" D SURE Q:SRSOUT G:'SRYN 2 S (SRAX,X)="",$P(^SRF(SRTN,200),"^",9)="" D NOPULM Q + S SRAX=Y,$P(^SRF(SRTN,200),"^",9)=SRAX I Y["N" D NOPULM Q + I Y["Y" D PULM + Q +3 ; edit hepatobiliary information + W ! K DIR S X=$P(SRAO(3),"^") I X'="" S DIR("B")=X + S DIR(0)="130,244",DIR("A")="HEPATOBILIARY" D ^DIR K DIR I $D(DUOUT) S SRSOUT=1 Q + I X="@" S SRCAT="Hepatobiliary" D SURE Q:SRSOUT G:'SRYN 3 S (SRAX,X)="",$P(^SRF(SRTN,200),"^",13)="" D NOHEP Q + S SRAX=Y,$P(^SRF(SRTN,200),"^",13)=SRAX I Y["N" D NOHEP Q + I Y["Y" D HEP + Q +GEN ; general + N SRUP S SRUP="" + W ! K DR,DIE S DA=SRTN,DIE=130,DR="236T;237T;346T;202T;202.1T;246T;325T;238T" D ^DIE K DIE,DR I $D(Y) Q + K DIR S DA=SRTN,DIR(0)="130,240",DIR("A")="Functional Health Status Prior to Current Illness" D ^DIR K DIR D Q:SRUP + .I $D(DTOUT) Q + .I $D(DUOUT) S SRUP=1 Q + .I X="@" K DIE,DR S DIE=130,DR="240///@" D ^DIE K DA,DIE,DR Q + .K DIE,DR S DIE=130,DR="240////"_Y D ^DIE K DA,DIE,DR + S DA=SRTN,DIR(0)="130,492",DIR("A")="Functional Health Status at Evaluation for Surgery" D ^DIR K DIR D + .I $D(DTOUT)!$D(DUOUT) Q + .I X="@" K DIE,DR S DIE=130,DR="492///@" D ^DIE K DA,DIE,DR Q + .K DIE,DR S DIE=130,DR="492////"_Y D ^DIE K DA,DIE,DR + S SRACLR=0 + Q +NOGEN ; no general problems + S $P(^SRF(SRTN,200),"^",6)=$S(X="":"",1:1) F I=2,3,4,7 S $P(^SRF(SRTN,200),"^",I)=SRAX + S $P(^SRF(SRTN,200),"^",8)=$S(X="":"",X="NS":"NS",1:1),$P(^SRF(SRTN,208),"^",9)=$S(X="":"",X="NS":"NS",1:0),$P(^SRF(SRTN,200.1),"^",2)=$S(X="":"",X="NS":"NS",1:1) + Q +PULM ; pulmonary + W ! K DR,DIE S DA=SRTN,DIE=130,DR="204T;203T;326T" D ^DIE K DR + S SRACLR=0 + Q +NOPULM ; no pulmonary problems + F I=10:1:12 S $P(^SRF(SRTN,200),"^",I)=SRAX + Q +HEP ; hepatobiliary + K DR,DIE S DIE=130,DA=SRTN,DR="212////Y" D ^DIE K DR + S SRACLR=0 + Q +NOHEP ; no hepatobiliary problems + S $P(^SRF(SRTN,200),"^",15)=SRAX + Q +RET W !! K DIR S DIR(0)="E" D ^DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 + Q +SURE W ! K DIR S DIR("A")=" Sure you want to delete all "_SRCAT_" information ? ",DIR("B")="NO",DIR(0)="YA" D ^DIR K DIR S SRYN=Y I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 + Q +NO2ALL ; set all fields to NO + S SRAX="N",$P(^SRF(SRTN,200),"^")=SRAX D NOGEN + S $P(^SRF(SRTN,200),"^",9)=SRAX D NOPULM + S $P(^SRF(SRTN,200),"^",13)=SRAX D NOHEP + S $P(^SRF(SRTN,200.1),"^")=SRAX D NOGAST^SROAPR1A + S $P(^SRF(SRTN,200),"^",30)=SRAX D NOCARD^SROAPR1A + S $P(^SRF(SRTN,200),"^",40)=SRAX D NOVAS^SROAPR1A + Q diff --git a/r/SURGERY-SR/SROAPRE2.m b/r/SURGERY-SR/SROAPRE2.m index 73f41e0f..c692ea70 100644 --- a/r/SURGERY-SR/SROAPRE2.m +++ b/r/SURGERY-SR/SROAPRE2.m @@ -1,59 +1,59 @@ -SROAPRE2 ;BIR/MAM - EDIT PAGE 2 PREOP ;11/26/07 - ;;3.0; Surgery ;**38,47,125,153,166**;24 Jun 93;Build 7 - D @EMILY Q -1 ; edit renal information - W ! K DIR S X=$P(SRAO(1),"^") I X'="" S DIR("B")=X - S DIR(0)="130,243",DIR("A")="RENAL" D ^DIR K DIR I $D(DUOUT) S SRSOUT=1 Q - I X="@" S SRCAT="Renal" D SURE Q:SRSOUT G:'SRYN 1 S $P(^SRF(SRTN,200),"^",37)="" S (SRAX,X)="" D NOREN Q - S SRAX=Y,$P(^SRF(SRTN,200),"^",37)=SRAX I Y["N" D NOREN Q - I Y["Y" D REN - Q -2 ; edit CNS information - W ! K DIR S X=$P(SRAO(2),"^") I X'="" S DIR("B")=X - S DIR(0)="130,210",DIR("A")="CENTRAL NERVOUS SYSTEM" D ^DIR K DIR I $D(DUOUT) S SRSOUT=1 Q - I X="@" S SRCAT="Central Nervous System" D SURE Q:SRSOUT G:'SRYN 2 S $P(^SRF(SRTN,200),"^",18)="" S (SRAX,X)="" D NOCNS Q - S SRAX=Y,$P(^SRF(SRTN,200),"^",18)=SRAX I Y["N" D NOCNS Q - I Y["Y" D CNS - Q -3 ; edit nutritional/immune/other info - W ! K DIR S X=$P(SRAO(3),"^") I X'="" S DIR("B")=X - S DIR(0)="130,245",DIR("A")="NUTRITIONAL/IMMUNE/OTHER" D ^DIR K DIR I $D(DUOUT) S SRSOUT=1 Q - I X="@" S SRCAT="Nutritional/Immune/Other" D SURE Q:SRSOUT G:'SRYN 3 S $P(^SRF(SRTN,200),"^",44)="" S (SRAX,X)="" D NONUT Q - S SRAX=Y,$P(^SRF(SRTN,200),"^",44)=SRAX I Y["N" D NONUT Q - I Y["Y" D NUT - Q -REN ; renal - W ! K DR,DIE S DA=SRTN,DIE=130,DR="328T;211T" D ^DIE K DR - S SRACLR=0 - Q -NOREN ; no renal problems - F I=38,39 S $P(^SRF(SRTN,200),"^",I)=SRAX - Q -CNS ; cns - W ! K DR,DIE S DIE=130,DA=SRTN,DR="332T;333T;400T;334T;335T;336T;401T;" D ^DIE K DR,DIE - S SRACLR=0 - Q -NOCNS ; no CNS problems - F I=19,21,24:1:27,29 S $P(^SRF(SRTN,200),"^",I)=SRAX - Q -NUT ; nutritional/immune/other - W ! K DR,DIE S DIE=130,DA=SRTN,DR="338T;218T;339T;215T;216T;217T;338.1T;338.2T;218.1T;269T" D ^DIE K DA,DIE,DR - S SRACLR=0 - Q -NONUT ; no nutritional/immune/other - F I=45:1:50 S $P(^SRF(SRTN,200),"^",I)=SRAX - F I=3,4,8 S $P(^SRF(SRTN,206),"^",I)=SRAX - S:SRAX="N" $P(^SRF(SRTN,200.1),"^",3)=$S($P($G(VADM(5)),"^")="M":"NA",1:"NO") - S:SRAX="" $P(^SRF(SRTN,200.1),"^",3)="" - Q -RET W !! K DIR S DIR(0)="E" D ^DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 - Q -SURE W ! K DIR S DIR("A")=" Sure you want to delete all "_SRCAT_" information ? ",DIR("B")="NO",DIR(0)="YA" D ^DIR K DIR S SRYN=Y I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 - Q -DEL W !!,?10,"Deleting all "_SRCAT_" information... " - Q -NO2ALL ; set all fields to NO - S SRAX="N",$P(^SRF(SRTN,200),"^",37)=SRAX D NOREN - S $P(^SRF(SRTN,200),"^",18)=SRAX D NOCNS - S $P(^SRF(SRTN,200),"^",44)=SRAX D NONUT - Q +SROAPRE2 ;BIR/MAM - EDIT PAGE 2 PREOP ;06/27/06 + ;;3.0; Surgery ;**38,47,125,153**;24 Jun 93;Build 11 + D @EMILY Q +1 ; edit renal information + W ! K DIR S X=$P(SRAO(1),"^") I X'="" S DIR("B")=X + S DIR(0)="130,243",DIR("A")="RENAL" D ^DIR K DIR I $D(DUOUT) S SRSOUT=1 Q + I X="@" S SRCAT="Renal" D SURE Q:SRSOUT G:'SRYN 1 S $P(^SRF(SRTN,200),"^",37)="" S (SRAX,X)="" D NOREN Q + S SRAX=Y,$P(^SRF(SRTN,200),"^",37)=SRAX I Y["N" D NOREN Q + I Y["Y" D REN + Q +2 ; edit CNS information + W ! K DIR S X=$P(SRAO(2),"^") I X'="" S DIR("B")=X + S DIR(0)="130,210",DIR("A")="CENTRAL NERVOUS SYSTEM" D ^DIR K DIR I $D(DUOUT) S SRSOUT=1 Q + I X="@" S SRCAT="Central Nervous System" D SURE Q:SRSOUT G:'SRYN 2 S $P(^SRF(SRTN,200),"^",18)="" S (SRAX,X)="" D NOCNS Q + S SRAX=Y,$P(^SRF(SRTN,200),"^",18)=SRAX I Y["N" D NOCNS Q + I Y["Y" D CNS + Q +3 ; edit nutritional/immune/other info + W ! K DIR S X=$P(SRAO(3),"^") I X'="" S DIR("B")=X + S DIR(0)="130,245",DIR("A")="NUTRITIONAL/IMMUNE/OTHER" D ^DIR K DIR I $D(DUOUT) S SRSOUT=1 Q + I X="@" S SRCAT="Nutritional/Immune/Other" D SURE Q:SRSOUT G:'SRYN 3 S $P(^SRF(SRTN,200),"^",44)="" S (SRAX,X)="" D NONUT Q + S SRAX=Y,$P(^SRF(SRTN,200),"^",44)=SRAX I Y["N" D NONUT Q + I Y["Y" D NUT + Q +REN ; renal + W ! K DR,DIE S DA=SRTN,DIE=130,DR="328T;211T" D ^DIE K DR + S SRACLR=0 + Q +NOREN ; no renal problems + F I=38,39 S $P(^SRF(SRTN,200),"^",I)=SRAX + Q +CNS ; cns + W ! K DR,DIE S DIE=130,DA=SRTN,DR="332T;333T;400T;334T;335T;336T;401T;399T;398T;" D ^DIE K DR,DIE + S SRACLR=0 + Q +NOCNS ; no CNS problems + F I=19,21:1:27,29 S $P(^SRF(SRTN,200),"^",I)=SRAX + Q +NUT ; nutritional/immune/other + W ! K DR,DIE S DIE=130,DA=SRTN,DR="338T;218T;339T;215T;216T;217T;338.1T;338.2T;218.1T;269T" D ^DIE K DA,DIE,DR + S SRACLR=0 + Q +NONUT ; no nutritional/immune/other + F I=45:1:50 S $P(^SRF(SRTN,200),"^",I)=SRAX + F I=3,4,8 S $P(^SRF(SRTN,206),"^",I)=SRAX + S:SRAX="N" $P(^SRF(SRTN,200.1),"^",3)=$S($P($G(VADM(5)),"^")="M":"NA",1:"NO") + S:SRAX="" $P(^SRF(SRTN,200.1),"^",3)="" + Q +RET W !! K DIR S DIR(0)="E" D ^DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 + Q +SURE W ! K DIR S DIR("A")=" Sure you want to delete all "_SRCAT_" information ? ",DIR("B")="NO",DIR(0)="YA" D ^DIR K DIR S SRYN=Y I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 + Q +DEL W !!,?10,"Deleting all "_SRCAT_" information... " + Q +NO2ALL ; set all fields to NO + S SRAX="N",$P(^SRF(SRTN,200),"^",37)=SRAX D NOREN + S $P(^SRF(SRTN,200),"^",18)=SRAX D NOCNS + S $P(^SRF(SRTN,200),"^",44)=SRAX D NONUT + Q diff --git a/r/SURGERY-SR/SROAPRT1.m b/r/SURGERY-SR/SROAPRT1.m index c3092597..b0356f93 100644 --- a/r/SURGERY-SR/SROAPRT1.m +++ b/r/SURGERY-SR/SROAPRT1.m @@ -1,57 +1,61 @@ -SROAPRT1 ;BIR/MAM - PREOP INFO (PAGE 1) ;11/28/07 - ;;3.0; Surgery ;**38,47,125,153,166**;24 Jun 93;Build 7 - N SRX,Y F I=200,206 S SRA(I)=$G(^SRF(SRTN,I)) - S Y=$P(SRA(200),"^"),SRX=402,SRAO(1)=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(206),"^"),SRX=236,SRAO("1A")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(206),"^",2),SRX=237,SRAO("1B")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",2),SRX=346,SRAO("1C")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",3),SRX=202,SRAO("1D")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",4),SRX=246,SRAO("1E")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",6),SRX=325,SRAO("1F")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",7),SRX=238,SRAO("1G")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P($G(^SRF(SRTN,200.1)),"^",2),SRX=492,SRAO("1H")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",9),SRX=241,SRAO(2)=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",10),SRX=204,SRAO("2A")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",11),SRX=203,SRAO("2B")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",12),SRX=326,SRAO("2C")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",13),SRX=244,SRAO(3)=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",15),SRX=212,SRAO("3A")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P($G(^SRF(SRTN,200.1)),"^"),SRX=486,SRAO(4)=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",16),SRX=213,SRAO("4A")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",30),SRX=242,SRAO(5)=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",35),SRX=396,SRAO("5A")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",31),SRX=394,SRAO("5B")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",32),SRX=220,SRAO("5C")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",33),SRX=266,SRAO("5D")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",34),SRX=395,SRAO("5E")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",36),SRX=208,SRAO("5F")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",40),SRX=206,SRAO(6)=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",41),SRX=329,SRAO("6A")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",42),SRX=330,SRAO("6B")=$$OUT(SRX,Y)_"^"_SRX - W:$E(IOST)="P" ! W !,?28,"PREOPERATIVE INFORMATION",!! - W "GENERAL:",?31,$P(SRAO(1),"^"),?40,"GASTROINTESTINAL:",?72,$P(SRAO(4),"^") - W !,"Height: ",?22,$J($P(SRAO("1A"),"^"),15),?40,"Esophageal Varices:",?72,$P(SRAO("4A"),"^") - W !,"Weight:",?22,$J($P(SRAO("1B"),"^"),15) - W !,"Diabetes Mellitus:",?31,$P(SRAO("1C"),"^"),?40,"CARDIAC:",?72,$P(SRAO(5),"^") - W !,"Current Smoker W/I 1 Year:",?31,$P(SRAO("1D"),"^"),?40,"CHF Within 1 Month:",?72,$P(SRAO("5A"),"^") - W !,"ETOH > 2 Drinks/Day:",?31,$P(SRAO("1E"),"^"),?40,"MI Within 6 Months:",?72,$P(SRAO("5B"),"^") - W !,"Dyspnea: ",?13,$J($P(SRAO("1F"),"^"),25),?40,"Previous PCI:",?72,$P(SRAO("5C"),"^") - W !,"DNR Status: ",?31,$P(SRAO("1G"),"^"),?40,"Previous Cardiac Surgery:",?72,$P(SRAO("5D"),"^") - W !,"Preop Funct Status: ",$J($P(SRAO("1H"),"^"),17),?40,"Angina Within 1 Month:",?72,$P(SRAO("5E"),"^") - W !,?40,"Hypertension Requiring Meds:",?72,$P(SRAO("5F"),"^") - W !,"PULMONARY:",?31,$P(SRAO(2),"^") - W !,"Ventilator Dependent:",?31,$P(SRAO("2A"),"^"),?40,"VASCULAR:",?72,$P(SRAO(6),"^") - W !,"History of Severe COPD:",?31,$P(SRAO("2B"),"^"),?40,"Revascularization/Amputation:",?72,$P(SRAO("6A"),"^") - W !,"Current Pneumonia:",?31,$P(SRAO("2C"),"^"),?40,"Rest Pain/Gangrene:",?72,$P(SRAO("6B"),"^") - W !!,"HEPATOBILIARY:",?31,$P(SRAO(3),"^"),!,"Ascites:",?31,$P(SRAO("3A"),"^") - Q -OUT(SRFLD,SRY) ; get data in output form - N C,Y - S Y=SRY,C=$P(^DD(130,SRFLD,0),"^",2) D:Y'="" Y^DIQ - I Y="NO STUDY" S Y="NS" - I SRFLD=236!(SRFLD=237)!(SRFLD=346) S Y=$E(Y,1,15) - I SRFLD=240!(SRFLD=492) D - .I SRY=2 S Y="PARTIAL DEPENDENT" Q - .I SRY=4 S Y=Y_" " - I SRFLD=325,$L(Y)=2 S Y=Y_" " - Q Y +SROAPRT1 ;BIR/MAM - PREOP INFO (PAGE 1) ;02/23/06 + ;;3.0; Surgery ;**38,47,125,153**;24 Jun 93;Build 11 + N SRX,Y F I=200,206 S SRA(I)=$G(^SRF(SRTN,I)) + S Y=$P(SRA(200),"^"),SRX=402,SRAO(1)=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(206),"^"),SRX=236,SRAO("1A")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(206),"^",2),SRX=237,SRAO("1B")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",2),SRX=346,SRAO("1C")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",3),SRX=202,SRAO("1D")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P($G(^SRF(SRTN,208)),"^",9),SRX=202.1,SRAO("1E")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",4),SRX=246,SRAO("1F")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",6),SRX=325,SRAO("1G")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",7),SRX=238,SRAO("1H")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",8),SRX=240,SRAO("1I")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P($G(^SRF(SRTN,200.1)),"^",2),SRX=492,SRAO("1J")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",9),SRX=241,SRAO(2)=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",10),SRX=204,SRAO("2A")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",11),SRX=203,SRAO("2B")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",12),SRX=326,SRAO("2C")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",13),SRX=244,SRAO(3)=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",15),SRX=212,SRAO("3A")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P($G(^SRF(SRTN,200.1)),"^"),SRX=486,SRAO(4)=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",16),SRX=213,SRAO("4A")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",30),SRX=242,SRAO(5)=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",35),SRX=396,SRAO("5A")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",31),SRX=394,SRAO("5B")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",32),SRX=220,SRAO("5C")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",33),SRX=266,SRAO("5D")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",34),SRX=395,SRAO("5E")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",36),SRX=208,SRAO("5F")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",40),SRX=206,SRAO(6)=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",41),SRX=329,SRAO("6A")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",42),SRX=330,SRAO("6B")=$$OUT(SRX,Y)_"^"_SRX + W:$E(IOST)="P" ! W !,?28,"PREOPERATIVE INFORMATION",!! + W "GENERAL:",?31,$P(SRAO(1),"^"),?40,"HEPATOBILIARY:",?72,$P(SRAO(3),"^") + W !,"Height: ",?22,$J($P(SRAO("1A"),"^"),15),?40,"Ascites:",?72,$P(SRAO("3A"),"^") + W !,"Weight:",?22,$J($P(SRAO("1B"),"^"),15) + W !,"Diabetes Mellitus:",?31,$P(SRAO("1C"),"^"),?40,"GASTROINTESTINAL:",?72,$P(SRAO(4),"^") + W !,"Current Smoker W/I 1 Year:",?31,$P(SRAO("1D"),"^"),?40,"Esophageal Varices:",?72,$P(SRAO("4A"),"^") + W !,"Pack/Years:",?31,$P(SRAO("1E"),"^") + W !,"ETOH > 2 Drinks/Day:",?31,$P(SRAO("1F"),"^"),?40,"CARDIAC:",?72,$P(SRAO(5),"^") + W !,"Dyspnea: ",?13,$J($P(SRAO("1G"),"^"),25),?40,"CHF Within 1 Month:",?72,$P(SRAO("5A"),"^") + W !,"DNR Status: ",?31,$P(SRAO("1H"),"^"),?40,"MI Within 6 Months:",?72,$P(SRAO("5B"),"^") + W !,"Pre-illness Funct",?40,"Previous PCI:",?72,$P(SRAO("5C"),"^") + W !,?12,"Status: ",$J($P(SRAO("1I"),"^"),17),?40,"Previous Cardiac Surgery:",?72,$P(SRAO("5D"),"^") + W !,"Preop Funct Status: ",$J($P(SRAO("1J"),"^"),17),?40,"Angina Within 1 Month:",?72,$P(SRAO("5E"),"^") + W !,?40,"Hypertension Requiring Meds:",?72,$P(SRAO("5F"),"^") + W !,"PULMONARY:",?31,$P(SRAO(2),"^") + W !,"Ventilator Dependent:",?31,$P(SRAO("2A"),"^"),?40,"VASCULAR:",?72,$P(SRAO(6),"^") + W !,"History of Severe COPD:",?31,$P(SRAO("2B"),"^"),?40,"Revascularization/Amputation:",?72,$P(SRAO("6A"),"^") + W !,"Current Pneumonia:",?31,$P(SRAO("2C"),"^"),?40,"Rest Pain/Gangrene:",?72,$P(SRAO("6B"),"^") + Q +OUT(SRFLD,SRY) ; get data in output form + N C,Y + S Y=SRY,C=$P(^DD(130,SRFLD,0),"^",2) D:Y'="" Y^DIQ + I Y="NO STUDY" S Y="NS" + I SRFLD=236!(SRFLD=237)!(SRFLD=346) S Y=$E(Y,1,15) + I SRFLD=240!(SRFLD=492) D + .I SRY=2 S Y="PARTIAL DEPENDENT" Q + .I SRY=4 S Y=Y_" " + I SRFLD=325,$L(Y)=2 S Y=Y_" " + Q Y diff --git a/r/SURGERY-SR/SROAPRT2.m b/r/SURGERY-SR/SROAPRT2.m index b34ffa54..afd34f5d 100644 --- a/r/SURGERY-SR/SROAPRT2.m +++ b/r/SURGERY-SR/SROAPRT2.m @@ -1,45 +1,49 @@ -SROAPRT2 ;BIR/MAM - PRINT PREOP INFO (PAGE 2) ;11/28/07 - ;;3.0; Surgery ;**38,125,137,153,160,166**;24 Jun 93;Build 7 - I $E(IOST)'="P" W !,?28,"PREOPERATIVE INFORMATION" - N SRX,Y S SRA(200)=$G(^SRF(SRTN,200)),SRA(206)=$G(^SRF(SRTN,206)) - S Y=$P(SRA(200),"^",37),SRX=243,SRAO(1)=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",38),SRX=328,SRAO("1A")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",39),SRX=211,SRAO("1B")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",18),SRX=210,SRAO(2)=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",44),SRX=245,SRAO(3)=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",19),SRX=332,SRAO("2A")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",21),SRX=333,SRAO("2B")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",24),SRX=400,SRAO("2C")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",25),SRX=334,SRAO("2D")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",26),SRX=335,SRAO("2E")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",27),SRX=336,SRAO("2F")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",29),SRX=401,SRAO("2G")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",45),SRX=338,SRAO("3A")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",46),SRX=218,SRAO("3B")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",47),SRX=339,SRAO("3C")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",48),SRX=215,SRAO("3D")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",49),SRX=216,SRAO("3E")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",50),SRX=217,SRAO("3F")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(206),"^",3),SRX=338.1,SRAO("3G")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(206),"^",4),SRX=338.2,SRAO("3H")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(206),"^",8),SRX=218.1,SRAO("3I")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P($G(^SRF(SRTN,200.1)),"^",3),SRX=269,SRAO("3J")=$$OUT(SRX,Y)_"^"_SRX - W !!,"RENAL:",?31,$P(SRAO(1),"^"),?40,"NUTRITIONAL/IMMUNE/OTHER:",?72,$P(SRAO(3),"^") - W !,"Acute Renal Failure:",?31,$P(SRAO("1A"),"^"),?40,"Disseminated Cancer:",?72,$P(SRAO("3A"),"^") - W !,"Currently on Dialysis:",?31,$P(SRAO("1B"),"^"),?40,"Open Wound:",?72,$P(SRAO("3B"),"^") - W !,?40,"Steroid Use for Chronic Cond.:",?72,$P(SRAO("3C"),"^") - W !,"CENTRAL NERVOUS SYSTEM:",?31,$P(SRAO(2),"^"),?40,"Weight Loss > 10%:",?72,$P(SRAO("3D"),"^") - W !,"Impaired Sensorium: ",?31,$P(SRAO("2A"),"^"),?40,"Bleeding Disorders:",?72,$P(SRAO("3E"),"^") - W !,"Coma:",?31,$P(SRAO("2B"),"^"),?40,"Transfusion > 4 RBC Units:",?72,$P(SRAO("3F"),"^") - W !,"Hemiplegia:",?31,$P(SRAO("2C"),"^"),?40,"Chemotherapy W/I 30 Days:",?72,$P(SRAO("3G"),"^") - W !,"History of TIAs:",?31,$P(SRAO("2D"),"^"),?40,"Radiotherapy W/I 90 Days:",?72,$P(SRAO("3H"),"^") - W !,"CVA/Stroke w. Neuro Deficit:",?31,$P(SRAO("2E"),"^"),?40,"Preoperative Sepsis:",?(74-$L($P(SRAO("3I"),"^"))),$P(SRAO("3I"),"^") - W !,"CVA/Stroke w/o Neuro Deficit:",?31,$P(SRAO("2F"),"^"),?40,"Pregnancy:",?(74-$L($P(SRAO("3J"),"^"))),$P(SRAO("3J"),"^") - W !,"Tumor Involving CNS:",?31,$P(SRAO("2G"),"^") - I $E(IOST)="P" W ! - Q -OUT(SRFLD,SRY) ; get data in output form - N C,Y - S Y=SRY,C=$P(^DD(130,SRFLD,0),"^",2) D:Y'="" Y^DIQ - I Y="NO STUDY" S Y="NS" - Q Y +SROAPRT2 ;BIR/MAM - PRINT PREOP INFO (PAGE 2) ;04/24/07 + ;;3.0; Surgery ;**38,125,137,153,160**;24 Jun 93;Build 7 + I $E(IOST)'="P" W !,?28,"PREOPERATIVE INFORMATION" + N SRX,Y S SRA(200)=$G(^SRF(SRTN,200)),SRA(206)=$G(^SRF(SRTN,206)) + S Y=$P(SRA(200),"^",37),SRX=243,SRAO(1)=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",38),SRX=328,SRAO("1A")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",39),SRX=211,SRAO("1B")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",18),SRX=210,SRAO(2)=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",44),SRX=245,SRAO(3)=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",19),SRX=332,SRAO("2A")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",21),SRX=333,SRAO("2B")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",22),SRX=398,SRAO("2I")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",23),SRX=399,SRAO("2H")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",24),SRX=400,SRAO("2C")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",25),SRX=334,SRAO("2D")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",26),SRX=335,SRAO("2E")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",27),SRX=336,SRAO("2F")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",29),SRX=401,SRAO("2G")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",45),SRX=338,SRAO("3A")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",46),SRX=218,SRAO("3B")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",47),SRX=339,SRAO("3C")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",48),SRX=215,SRAO("3D")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",49),SRX=216,SRAO("3E")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",50),SRX=217,SRAO("3F")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(206),"^",3),SRX=338.1,SRAO("3G")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(206),"^",4),SRX=338.2,SRAO("3H")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(206),"^",8),SRX=218.1,SRAO("3I")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P($G(^SRF(SRTN,200.1)),"^",3),SRX=269,SRAO("3J")=$$OUT(SRX,Y)_"^"_SRX + W !!,"RENAL:",?31,$P(SRAO(1),"^"),?40,"NUTRITIONAL/IMMUNE/OTHER:",?72,$P(SRAO(3),"^") + W !,"Acute Renal Failure:",?31,$P(SRAO("1A"),"^"),?40,"Disseminated Cancer:",?72,$P(SRAO("3A"),"^") + W !,"Currently on Dialysis:",?31,$P(SRAO("1B"),"^"),?40,"Open Wound:",?72,$P(SRAO("3B"),"^") + W !,?40,"Steroid Use for Chronic Cond.:",?72,$P(SRAO("3C"),"^") + W !,"CENTRAL NERVOUS SYSTEM:",?31,$P(SRAO(2),"^"),?40,"Weight Loss > 10%:",?72,$P(SRAO("3D"),"^") + W !,"Impaired Sensorium: ",?31,$P(SRAO("2A"),"^"),?40,"Bleeding Disorders:",?72,$P(SRAO("3E"),"^") + W !,"Coma:",?31,$P(SRAO("2B"),"^"),?40,"Transfusion > 4 RBC Units:",?72,$P(SRAO("3F"),"^") + W !,"Hemiplegia:",?31,$P(SRAO("2C"),"^"),?40,"Chemotherapy W/I 30 Days:",?72,$P(SRAO("3G"),"^") + W !,"History of TIAs:",?31,$P(SRAO("2D"),"^"),?40,"Radiotherapy W/I 90 Days:",?72,$P(SRAO("3H"),"^") + W !,"CVA/Stroke w. Neuro Deficit:",?31,$P(SRAO("2E"),"^"),?40,"Preoperative Sepsis:",?(74-$L($P(SRAO("3I"),"^"))),$P(SRAO("3I"),"^") + W !,"CVA/Stroke w/o Neuro Deficit:",?31,$P(SRAO("2F"),"^"),?40,"Pregnancy:",?(74-$L($P(SRAO("3J"),"^"))),$P(SRAO("3J"),"^") + W !,"Tumor Involving CNS:",?31,$P(SRAO("2G"),"^") + W !,"Paraplegia:",?31,$P(SRAO("2H"),"^") + W !,"Quadriplegia:",?31,$P(SRAO("2I"),"^") + I $E(IOST)="P" W ! + Q +OUT(SRFLD,SRY) ; get data in output form + N C,Y + S Y=SRY,C=$P(^DD(130,SRFLD,0),"^",2) D:Y'="" Y^DIQ + I Y="NO STUDY" S Y="NS" + Q Y diff --git a/r/SURGERY-SR/SROAPRT4.m b/r/SURGERY-SR/SROAPRT4.m index 2fa0813a..8ed3289e 100644 --- a/r/SURGERY-SR/SROAPRT4.m +++ b/r/SURGERY-SR/SROAPRT4.m @@ -1,24 +1,24 @@ -SROAPRT4 ;BIR/MAM - PRINT ASSESSMENT (CONT.) ;01/14/08 - ;;3.0; Surgery ;**38,125,153,160,166**;24 Jun 93;Build 7 - ;K SRA S SRA(201)=$G(^SRF(SRTN,201)),SRA(202)=$G(^SRF(SRTN,202)) - K SRA F I=201,202,203,204,202.1 S SRA(I)=$G(^SRF(SRTN,I)) - W !,?20,"PREOPERATIVE LABORATORY TEST RESULTS" - W !!,$J("Anion Gap (in 48 hrs.): ",39) S X=$P(SRA(203),"^",15) W X S X=$P(SRA(204),"^",15) I X D DATE W ?48,"("_Y_")" - W !,$J("Serum Sodium: ",39) S X=$P(SRA(201),"^") W X S X=$P(SRA(202),"^") I X D DATE W ?48,"("_Y_")" - W !,$J("Serum Creatinine: ",39) S X=$P(SRA(201),"^",4) W X S X=$P(SRA(202),"^",4) I X D DATE W ?48,"("_Y_")" - W !,$J("BUN: ",39) S X=$P(SRA(201),"^",5) W X S X=$P(SRA(202),"^",5) I X D DATE W ?48,"("_Y_")" - W !,$J("Serum Albumin: ",39) S X=$P(SRA(201),"^",8) W X S X=$P(SRA(202),"^",8) I X D DATE W ?48,"("_Y_")" - W !,$J("Total Bilirubin: ",39) S X=$P(SRA(201),"^",9) W X S X=$P(SRA(202),"^",9) I X D DATE W ?48,"("_Y_")" - W !,$J("SGOT: ",39) S X=$P(SRA(201),"^",11) W X S X=$P(SRA(202),"^",11) I X D DATE W ?48,"("_Y_")" - W !,$J("Alkaline Phosphatase: ",39) S X=$P(SRA(201),"^",12) W X S X=$P(SRA(202),"^",12) I X D DATE W ?48,"("_Y_")" - W !,$J("White Blood Count: ",39) S X=$P(SRA(201),"^",13) W X S X=$P(SRA(202),"^",13) I X D DATE W ?48,"("_Y_")" - W !,$J("Hematocrit: ",39) S X=$P(SRA(201),"^",14) W X S X=$P(SRA(202),"^",14) I X D DATE W ?48,"("_Y_")" - W !,$J("Platelet Count: ",39) S X=$P(SRA(201),"^",15) W X S X=$P(SRA(202),"^",15) I X D DATE W ?48,"("_Y_")" - W !,$J("PTT: ",39) S X=$P(SRA(201),"^",16) W X S X=$P(SRA(202),"^",16) I X D DATE W ?48,"("_Y_")" - W !,$J("PT: ",39) S X=$P(SRA(201),"^",17) W X S X=$P(SRA(202),"^",17) I X D DATE W ?48,"("_Y_")" - W !,$J("INR: ",39) S X=$P(SRA(201),"^",27) W X S X=$P(SRA(202),"^",27) I X D DATE W ?48,"("_Y_")" - W !,$J("Hemoglobin A1c: ",39) S X=$P(SRA(201),"^",28) W X S X=$P(SRA(202.1),"^") I X D DATE W ?48,"("_Y_")" - I $E(IOST)="P" W !! - Q -DATE S Y=X X ^DD("DD") - Q +SROAPRT4 ;BIR/MAM - PRINT ASSESSMENT (CONT.) ;06/28/06 + ;;3.0; Surgery ;**38,125,153,160**;24 Jun 93;Build 7 + ;K SRA S SRA(201)=$G(^SRF(SRTN,201)),SRA(202)=$G(^SRF(SRTN,202)) + K SRA F I=201,202,203,204,202.1 S SRA(I)=$G(^SRF(SRTN,I)) + W !,?20,"PREOPERATIVE LABORATORY TEST RESULTS" + W !!,$J("Anion Gap (in 48 hrs.): ",39) S X=$P(SRA(203),"^",15) W X S X=$P(SRA(204),"^",15) I X D DATE W ?48,"("_Y_")" + W !,$J("Serum Sodium: ",39) S X=$P(SRA(201),"^") W X S X=$P(SRA(202),"^") I X D DATE W ?48,"("_Y_")" + W !,$J("Serum Creatinine: ",39) S X=$P(SRA(201),"^",4) W X S X=$P(SRA(202),"^",4) I X D DATE W ?48,"("_Y_")" + W !,$J("BUN: ",39) S X=$P(SRA(201),"^",5) W X I X S X=$P(SRA(202),"^",5) I X D DATE W ?48,"("_Y_")" + W !,$J("Serum Albumin: ",39) S X=$P(SRA(201),"^",8) W X I X S X=$P(SRA(202),"^",8) I X D DATE W ?48,"("_Y_")" + W !,$J("Total Bilirubin: ",39) S X=$P(SRA(201),"^",9) W X S X=$P(SRA(202),"^",9) I X D DATE W ?48,"("_Y_")" + W !,$J("SGOT: ",39) S X=$P(SRA(201),"^",11) W X I X S X=$P(SRA(202),"^",11) I X D DATE W ?48,"("_Y_")" + W !,$J("Alkaline Phosphatase: ",39) S X=$P(SRA(201),"^",12) W X I X S X=$P(SRA(202),"^",12) I X D DATE W ?48,"("_Y_")" + W !,$J("White Blood Count: ",39) S X=$P(SRA(201),"^",13) W X S X=$P(SRA(202),"^",13) I X D DATE W ?48,"("_Y_")" + W !,$J("Hematocrit: ",39) S X=$P(SRA(201),"^",14) W X I X S X=$P(SRA(202),"^",14) I X D DATE W ?48,"("_Y_")" + W !,$J("Platelet Count: ",39) S X=$P(SRA(201),"^",15) W X S X=$P(SRA(202),"^",15) I X D DATE W ?48,"("_Y_")" + W !,$J("PTT: ",39) S X=$P(SRA(201),"^",16) W X S X=$P(SRA(202),"^",16) I X D DATE W ?48,"("_Y_")" + W !,$J("PT: ",39) S X=$P(SRA(201),"^",17) W X I X S X=$P(SRA(202),"^",17) I X D DATE W ?48,"("_Y_")" + W !,$J("INR: ",39) S X=$P(SRA(201),"^",27) W X I X S X=$P(SRA(202),"^",27) I X D DATE W ?48,"("_Y_")" + W !,$J("Hemoglobin A1c: ",39) S X=$P(SRA(201),"^",28) W X I X S X=$P(SRA(202.1),"^") D DATE W ?48,"("_Y_")" + I $E(IOST)="P" W !! + Q +DATE S Y=X X ^DD("DD") + Q diff --git a/r/SURGERY-SR/SROAPRT5.m b/r/SURGERY-SR/SROAPRT5.m index 1365602c..71d01d5e 100644 --- a/r/SURGERY-SR/SROAPRT5.m +++ b/r/SURGERY-SR/SROAPRT5.m @@ -1,21 +1,21 @@ -SROAPRT5 ;BIR/MAM - PRINT ASSESSMENT (CONT) ;01/14/08 - ;;3.0; Surgery ;**38,88,153,166**;24 Jun 93;Build 7 - K SRA S SRA(203)=$G(^SRF(SRTN,203)),SRA(204)=$G(^SRF(SRTN,204)) - W:$E(IOST)="P" ! W !,?22,"POSTOPERATIVE LABORATORY RESULTS",!!,?29," * Highest Value",!,?29,"** Lowest Value" - W !!,$J("* Anion Gap: ",39) S X=$P(SRA(203),"^",16) W X S X=$P(SRA(204),"^",16) I X D DATE W ?48,"("_Y_")" - W !,$J("* Serum Sodium: ",39) S X=$P(SRA(203),"^") W X S X=$P(SRA(204),"^") I X D DATE W ?48,"("_Y_")" - W !,$J("** Serum Sodium: ",39) S X=$P(SRA(203),"^",2) W X S X=$P(SRA(204),"^",2) I X D DATE W ?48,"("_Y_")" - W !,$J("* Potassium: ",39) S X=$P(SRA(203),"^",3) W X S X=$P(SRA(204),"^",3) I X D DATE W ?48,"("_Y_")" - W !,$J("** Potassium: ",39) S X=$P(SRA(203),"^",4) W X S X=$P(SRA(204),"^",4) I X D DATE W ?48,"("_Y_")" - W !,$J("* Serum Creatinine: ",39) S X=$P(SRA(203),"^",6) W X S X=$P(SRA(204),"^",6) I X D DATE W ?48,"("_Y_")" - W !,$J("* CPK: ",39) S X=$P(SRA(203),"^",7) W X S X=$P(SRA(204),"^",7) I X D DATE W ?48,"("_Y_")" - W !,$J("* CPK-MB Band: ",39) S X=$P(SRA(203),"^",8) W X S X=$P(SRA(204),"^",8) I X D DATE W ?48,"("_Y_")" - W !,$J("* Total Bilirubin: ",39) S X=$P(SRA(203),"^",9) W X S X=$P(SRA(204),"^",9) I X D DATE W ?48,"("_Y_")" - W !,$J("* White Blood Count: ",39) S X=$P(SRA(203),"^",10) W X S X=$P(SRA(204),"^",10) I X D DATE W ?48,"("_Y_")" - W !,$J("** Hematocrit: ",39) S X=$P(SRA(203),"^",12) W X S X=$P(SRA(204),"^",12) I X D DATE W ?48,"("_Y_")" - W !,$J("* Troponin I: ",39) S X=$P(SRA(203),"^",13) W X S X=$P(SRA(204),"^",13) I X D DATE W ?48,"("_Y_")" - W !,$J("* Troponin T: ",39) S X=$P(SRA(203),"^",14) W X S X=$P(SRA(204),"^",14) I X D DATE W ?48,"("_Y_")" - I $E(IOST)="P" W !! - Q -DATE S Y=X X ^DD("DD") - Q +SROAPRT5 ;BIR/MAM - PRINT ASSESSMENT (CONT) ;06/28/06 + ;;3.0; Surgery ;**38,88,153**;24 Jun 93;Build 11 + K SRA S SRA(203)=$G(^SRF(SRTN,203)),SRA(204)=$G(^SRF(SRTN,204)) + W:$E(IOST)="P" ! W !,?22,"POSTOPERATIVE LABORATORY RESULTS",!!,?29," * Highest Value",!,?29,"** Lowest Value" + W !!,$J("* Anion Gap: ",39) S X=$P(SRA(203),"^",16) W X S X=$P(SRA(204),"^",16) I X D DATE W ?48,"("_Y_")" + W !,$J("* Serum Sodium: ",39) S X=$P(SRA(203),"^") W X S X=$P(SRA(204),"^") I X D DATE W ?48,"("_Y_")" + W !,$J("** Serum Sodium: ",39) S X=$P(SRA(203),"^",2) W X S X=$P(SRA(204),"^",2) I X D DATE W ?48,"("_Y_")" + W !,$J("* Potassium: ",39) S X=$P(SRA(203),"^",3) W X S X=$P(SRA(204),"^",3) I X D DATE W ?48,"("_Y_")" + W !,$J("** Potassium: ",39) S X=$P(SRA(203),"^",4) W X S X=$P(SRA(204),"^",4) I X D DATE W ?48,"("_Y_")" + W !,$J("* Serum Creatinine: ",39) S X=$P(SRA(203),"^",6) W X S X=$P(SRA(204),"^",6) I X D DATE W ?48,"("_Y_")" + W !,$J("* CPK: ",39) S X=$P(SRA(203),"^",7) W X I X S X=$P(SRA(204),"^",7) I X D DATE W ?48,"("_Y_")" + W !,$J("* CPK-MB Band: ",39) S X=$P(SRA(203),"^",8) W X S X=$P(SRA(204),"^",8) I X D DATE W ?48,"("_Y_")" + W !,$J("* Total Bilirubin: ",39) S X=$P(SRA(203),"^",9) W X I X S X=$P(SRA(204),"^",9) I X D DATE W ?48,"("_Y_")" + W !,$J("* White Blood Count: ",39) S X=$P(SRA(203),"^",10) W X S X=$P(SRA(204),"^",10) I X D DATE W ?48,"("_Y_")" + W !,$J("** Hematocrit: ",39) S X=$P(SRA(203),"^",12) W X S X=$P(SRA(204),"^",12) I X D DATE W ?48,"("_Y_")" + W !,$J("* Troponin I: ",39) S X=$P(SRA(203),"^",13) W X S X=$P(SRA(204),"^",13) I X D DATE W ?48,"("_Y_")" + W !,$J("* Troponin T: ",39) S X=$P(SRA(203),"^",14) W X S X=$P(SRA(204),"^",14) I X D DATE W ?48,"("_Y_")" + I $E(IOST)="P" W !! + Q +DATE S Y=X X ^DD("DD") + Q diff --git a/r/SURGERY-SR/SROAPS1.m b/r/SURGERY-SR/SROAPS1.m index 72013438..115f16b7 100644 --- a/r/SURGERY-SR/SROAPS1.m +++ b/r/SURGERY-SR/SROAPS1.m @@ -1,81 +1,73 @@ -SROAPS1 ;BIR/MAM - PREOP INFO (PAGE 1) ;12/12/07 - ;;3.0; Surgery ;**38,47,125,153,166**;24 Jun 93;Build 7 - ; - ; Reference to EN1^GMRVUT0 supported by DBIA #1446 - ; - N I S SRPAGE="PAGE: 1 OF 2" D HDR^SROAUTL,PRE1 - W ! F I=1:1:80 W "-" - Q -PRE1 N SRX,Y D HW F I=200,206 S SRA(I)=$G(^SRF(SRTN,I)) - S Y=$P(SRA(200),"^"),SRX=402,SRAO(1)=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(206),"^"),SRX=236,SRAO("1A")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(206),"^",2),SRX=237,SRAO("1B")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",2),SRX=346,SRAO("1C")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",3),SRX=202,SRAO("1D")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",4),SRX=246,SRAO("1E")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",6),SRX=325,SRAO("1F")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",7),SRX=238,SRAO("1G")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P($G(^SRF(SRTN,200.1)),"^",2),SRX=492,SRAO("1H")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",9),SRX=241,SRAO(2)=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",10),SRX=204,SRAO("2A")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",11),SRX=203,SRAO("2B")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",12),SRX=326,SRAO("2C")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",13),SRX=244,SRAO(3)=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",15),SRX=212,SRAO("3A")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P($G(^SRF(SRTN,200.1)),"^"),SRX=486,SRAO(4)=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",16),SRX=213,SRAO("4A")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",30),SRX=242,SRAO(5)=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",35),SRX=396,SRAO("5A")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",31),SRX=394,SRAO("5B")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",32),SRX=220,SRAO("5C")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",33),SRX=266,SRAO("5D")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",34),SRX=395,SRAO("5E")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",36),SRX=208,SRAO("5F")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",40),SRX=206,SRAO(6)=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",41),SRX=329,SRAO("6A")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",42),SRX=330,SRAO("6B")=$$OUT(SRX,Y)_"^"_SRX K SRA - W "1. GENERAL:",?32,$P(SRAO(1),"^"),?41,"4. GASTROINTESTINAL:",?76,$P(SRAO(4),"^") - W !," A. Height:" S Y=$P(SRAO("1A"),"^") W:Y'="NS" ?14,$J($P(Y,"^"),25) W:Y="NS" ?32,Y - W ?43,"A. Esophageal Varices:",?76,$P(SRAO("4A"),"^") - W !," B. Weight:" S Y=$P(SRAO("1B"),"^") W ?($S(Y="NS":19,1:24)),$J(Y,15) - W !," C. Diabetes Mellitus:",?32,$P(SRAO("1C"),"^"),?41,"5. CARDIAC:",?76,$P(SRAO(5),"^") - W !," D. Current Smoker W/I 1 Year:",?32,$P(SRAO("1D"),"^"),?43,"A. CHF Within 1 Month:",?76,$P(SRAO("5A"),"^") - W !," E. ETOH > 2 Drinks/Day:",?32,$P(SRAO("1E"),"^"),?43,"B. MI Within 6 Months:",?76,$P(SRAO("5B"),"^") - W !," F. Dyspnea: ",?14,$J($P(SRAO("1F"),"^"),25),?43,"C. Previous PCI:",?76,$P(SRAO("5C"),"^") - W !," G. DNR Status: ",?32,$P(SRAO("1G"),"^"),?43,"D. Previous Cardiac Surgery:",?76,$P(SRAO("5D"),"^") - W !," H. Preop Funct Status: ",$J($P(SRAO("1H"),"^"),17),?43,"E. Angina Within 1 Month:",?76,$P(SRAO("5E"),"^") - W !,?43,"F. Hypertension Requiring Meds:",?76,$P(SRAO("5F"),"^") - W !,"2. PULMONARY:",?32,$P(SRAO(2),"^") - W !," A. Ventilator Dependent:",?32,$P(SRAO("2A"),"^"),?41,"6. VASCULAR:",?76,$P(SRAO(6),"^") - W !," B. History of Severe COPD:",?32,$P(SRAO("2B"),"^"),?43,"A. Revascularization/Amputation:",?76,$P(SRAO("6A"),"^") - W !," C. Current Pneumonia:",?32,$P(SRAO("2C"),"^"),?43,"B. Rest Pain/Gangrene:",?76,$P(SRAO("6B"),"^") - W !!,"3. HEPATOBILIARY:",?32,$P(SRAO(3),"^"),!," A. Ascites:",?32,$P(SRAO("3A"),"^") - Q -OUT(SRFLD,SRY) ; get data in output form - N C,Y,Z - S Y=SRY,C=$P(^DD(130,SRFLD,0),"^",2) D:Y'="" Y^DIQ - I Y="NO STUDY" S Y="NS" - I SRFLD=237!(SRFLD=346) S Y=$E(Y,1,15) - I SRFLD=236 S Z=$P($G(^SRF(SRTN,200.1)),"^",7) I Z'="" S Y="("_$E(Z,4,5)_"/"_$E(Z,6,7)_"/"_$E(Z,2,3)_") "_Y - I SRFLD=492 D - .I SRY=2 S Y="PARTIAL DEPENDENT" Q - .I SRY=1 S Y=Y_" " Q - .I SRY=4 S Y=Y_" " - I SRFLD=325,$L(Y)=2 S Y=Y_" " - Q Y -HW ; get weight & height from Vitals - N SREND,SREQ,SREX,SREY,SRSTRT -WT I $P($G(^SRF(SRTN,206)),"^",2)="" D - .S SREND=$P($G(^SRF(SRTN,0)),"^",9),SRSTRT=$$FMADD^XLFDT(SREND,-30),SREX=$$HW^SROACL1(SRSTRT,SREND,"WT") - .I SREX'="" S SREX=SREX+.5\1 D CHK^DIE(130,237,"E",SREX,.SREY) I SREY'="^" S $P(^SRF(SRTN,206),"^",2)=SREY -HT I $P($G(^SRF(SRTN,206)),"^")'="" Q - N GMRVSTR,SRBRDT,SRBIEN,SRBDATA,SRHTDT - K ^UTILITY($J,"GMRVD"),RESULTS S SREND=$P($G(^SRF(SRTN,0)),"^",9),GMRVSTR="HT",GMRVSTR(0)="^"_SREND_"^^0" - D EN1^GMRVUT0 Q:'$D(^UTILITY($J,"GMRVD")) - S SRBRDT="",SRBRDT=$O(^UTILITY($J,"GMRVD","HT",SRBRDT)) Q:'SRBRDT D - .S SRBIEN=0 F S SRBIEN=$O(^UTILITY($J,"GMRVD","HT",SRBRDT,SRBIEN)) Q:'SRBIEN D - ..S SRBDATA=$G(^UTILITY($J,"GMRVD","HT",SRBRDT,SRBIEN)),SREX=$P(SRBDATA,"^",8) - ..I SREX'="" S SREX=SREX+.5\1 D CHK^DIE(130,236,"E",SREX,.SREY) I SREY'="^" D - ...S $P(^SRF(SRTN,206),"^")=SREY - ...S SRHTDT=$P(SRBDATA,"^") I SRHTDT'="" S $P(^SRF(SRTN,200.1),"^",7)=SRHTDT - Q +SROAPS1 ;BIR/MAM - PREOP INFO (PAGE 1) ;06/08/06 + ;;3.0; Surgery ;**38,47,125,153**;24 Jun 93;Build 11 + N I S SRPAGE="PAGE: 1 OF 2" D HDR^SROAUTL,PRE1 + W ! F I=1:1:80 W "-" + Q +PRE1 N SRX,Y D HW F I=200,206 S SRA(I)=$G(^SRF(SRTN,I)) + S Y=$P(SRA(200),"^"),SRX=402,SRAO(1)=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(206),"^"),SRX=236,SRAO("1A")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(206),"^",2),SRX=237,SRAO("1B")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",2),SRX=346,SRAO("1C")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",3),SRX=202,SRAO("1D")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P($G(^SRF(SRTN,208)),"^",9),SRX=202.1,SRAO("1E")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",4),SRX=246,SRAO("1F")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",6),SRX=325,SRAO("1G")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",7),SRX=238,SRAO("1H")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",8),SRX=240,SRAO("1I")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P($G(^SRF(SRTN,200.1)),"^",2),SRX=492,SRAO("1J")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",9),SRX=241,SRAO(2)=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",10),SRX=204,SRAO("2A")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",11),SRX=203,SRAO("2B")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",12),SRX=326,SRAO("2C")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",13),SRX=244,SRAO(3)=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",15),SRX=212,SRAO("3A")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P($G(^SRF(SRTN,200.1)),"^"),SRX=486,SRAO(4)=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",16),SRX=213,SRAO("4A")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",30),SRX=242,SRAO(5)=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",35),SRX=396,SRAO("5A")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",31),SRX=394,SRAO("5B")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",32),SRX=220,SRAO("5C")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",33),SRX=266,SRAO("5D")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",34),SRX=395,SRAO("5E")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",36),SRX=208,SRAO("5F")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",40),SRX=206,SRAO(6)=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",41),SRX=329,SRAO("6A")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",42),SRX=330,SRAO("6B")=$$OUT(SRX,Y)_"^"_SRX K SRA + W "1. GENERAL:",?32,$P(SRAO(1),"^"),?41,"3. HEPATOBILIARY:",?76,$P(SRAO(3),"^") + W !," A. Height:" S Y=$P(SRAO("1A"),"^") W ?($S(Y="NS":19,1:24)),$J($P(Y,"^"),15),?43,"A. Ascites:",?76,$P(SRAO("3A"),"^") + W !," B. Weight:" S Y=$P(SRAO("1B"),"^") W ?($S(Y="NS":19,1:24)),$J(Y,15) + W !," C. Diabetes Mellitus:",?32,$P(SRAO("1C"),"^"),?41,"4. GASTROINTESTINAL:",?76,$P(SRAO(4),"^") + W !," D. Current Smoker W/I 1 Year:",?32,$P(SRAO("1D"),"^"),?43,"A. Esophageal Varices:",?76,$P(SRAO("4A"),"^") + W !," E. Pack/Years:",?32,$P(SRAO("1E"),"^") + W !," F. ETOH > 2 Drinks/Day:",?32,$P(SRAO("1F"),"^"),?41,"5. CARDIAC:",?76,$P(SRAO(5),"^") + W !," G. Dyspnea: ",?14,$J($P(SRAO("1G"),"^"),25),?43,"A. CHF Within 1 Month:",?76,$P(SRAO("5A"),"^") + W !," H. DNR Status: ",?32,$P(SRAO("1H"),"^"),?43,"B. MI Within 6 Months:",?76,$P(SRAO("5B"),"^") + W !," I. Pre-illness Funct",?43,"C. Previous PCI:",?76,$P(SRAO("5C"),"^") + W !,?17,"Status: ",$J($P(SRAO("1I"),"^"),17),?43,"D. Previous Cardiac Surgery:",?76,$P(SRAO("5D"),"^") + W !," J. Preop Funct Status: ",$J($P(SRAO("1J"),"^"),17),?43,"E. Angina Within 1 Month:",?76,$P(SRAO("5E"),"^") + W !,?43,"F. Hypertension Requiring Meds:",?76,$P(SRAO("5F"),"^") + W !,"2. PULMONARY:",?32,$P(SRAO(2),"^") + W !," A. Ventilator Dependent:",?32,$P(SRAO("2A"),"^"),?41,"6. VASCULAR:",?76,$P(SRAO(6),"^") + W !," B. History of Severe COPD:",?32,$P(SRAO("2B"),"^"),?43,"A. Revascularization/Amputation:",?76,$P(SRAO("6A"),"^") + W !," C. Current Pneumonia:",?32,$P(SRAO("2C"),"^"),?43,"B. Rest Pain/Gangrene:",?76,$P(SRAO("6B"),"^") + Q +OUT(SRFLD,SRY) ; get data in output form + N C,Y + S Y=SRY,C=$P(^DD(130,SRFLD,0),"^",2) D:Y'="" Y^DIQ + I Y="NO STUDY" S Y="NS" + I SRFLD=236!(SRFLD=237)!(SRFLD=346) S Y=$E(Y,1,15) + I SRFLD=240!(SRFLD=492) D + .I SRY=2 S Y="PARTIAL DEPENDENT" Q + .I SRY=1 S Y=Y_" " Q + .I SRY=4 S Y=Y_" " + I SRFLD=325,$L(Y)=2 S Y=Y_" " + Q Y +HW ; get weight & height from Vitals + N SREND,SREX,SRSTRT +WT I $P($G(^SRF(SRTN,206)),"^",2)="" D + .S SREND=$P($G(^SRF(SRTN,0)),"^",9),SRSTRT=$$FMADD^XLFDT(SREND,-30),SREX=$$HW^SROACL1(SRSTRT,SREND,"WT") + .I SREX'="" S SREX=SREX+.5\1,$P(^SRF(SRTN,206),"^",2)=SREX +HT I $P($G(^SRF(SRTN,206)),"^")="" D + .S SREND=$P($G(^SRF(SRTN,0)),"^",9),SRSTRT=$$FMADD^XLFDT(SREND,-365),SREX=$$HW^SROACL1(SRSTRT,SREND,"HT") + .I SREX'="" S SREX=SREX+.5\1,$P(^SRF(SRTN,206),"^")=SREX + Q diff --git a/r/SURGERY-SR/SROAPS2.m b/r/SURGERY-SR/SROAPS2.m index 0bf028d2..42b1f04a 100644 --- a/r/SURGERY-SR/SROAPS2.m +++ b/r/SURGERY-SR/SROAPS2.m @@ -1,47 +1,51 @@ -SROAPS2 ;BIR/MAM - PREOP INFO (PAGE 2) ;11/26/07 - ;;3.0; Surgery ;**38,47,125,153,160,166**;24 Jun 93;Build 7 - S SRPAGE="PAGE: 2 OF 2" D HDR^SROAUTL,PRE2 - W !! F I=1:1:80 W "-" - Q -PRE2 N SRX,Y S Y=$P($G(^SRF(SRTN,200.1)),"^",3) I Y="",$P(VADM(5),"^")="M" S $P(^SRF(SRTN,200.1),"^",3)="NA" - S SRA(200)=$G(^SRF(SRTN,200)),SRA(206)=$G(^SRF(SRTN,206)),SRA(200.1)=$G(^SRF(SRTN,200.1)) - S Y=$P(SRA(200),"^",37),SRX=243,SRAO(1)=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",38),SRX=328,SRAO("1A")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",39),SRX=211,SRAO("1B")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",18),SRX=210,SRAO(2)=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",44),SRX=245,SRAO(3)=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",19),SRX=332,SRAO("2A")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",21),SRX=333,SRAO("2B")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",24),SRX=400,SRAO("2C")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",25),SRX=334,SRAO("2D")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",26),SRX=335,SRAO("2E")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",27),SRX=336,SRAO("2F")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",29),SRX=401,SRAO("2G")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",45),SRX=338,SRAO("3A")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",46),SRX=218,SRAO("3B")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",47),SRX=339,SRAO("3C")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",48),SRX=215,SRAO("3D")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",49),SRX=216,SRAO("3E")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200),"^",50),SRX=217,SRAO("3F")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(206),"^",3),SRX=338.1,SRAO("3G")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(206),"^",4),SRX=338.2,SRAO("3H")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(206),"^",8),SRX=218.1,SRAO("3I")=$$OUT(SRX,Y)_"^"_SRX - S Y=$P(SRA(200.1),"^",3),SRX=269,SRAO("3J")=$$OUT(SRX,Y)_"^"_SRX K SRA - W !,"1. RENAL:",?(38-$L($P(SRAO(1),"^"))),$P(SRAO(1),"^"),?40,"3. NUTRITIONAL/IMMUNE/OTHER:",?(79-$L($P(SRAO(3),"^"))),$P(SRAO(3),"^") - W !," A. Acute Renal Failure:",?(38-$L($P(SRAO("1A"),"^"))),$P(SRAO("1A"),"^"),?40," A. Disseminated Cancer:",?(79-$L($P(SRAO("3A"),"^"))),$P(SRAO("3A"),"^") - W !," B. Currently on Dialysis:",?(38-$L($P(SRAO("1B"),"^"))),$P(SRAO("1B"),"^"),?40," B. Open Wound:",?(79-$L($P(SRAO("3B"),"^"))),$P(SRAO("3B"),"^") - W !,?40," C. Steroid Use for Chronic Cond.:",?(79-$L($P(SRAO("3C"),"^"))),$P(SRAO("3C"),"^") - W !,"2. CENTRAL NERVOUS SYSTEM:",?(38-$L($P(SRAO(2),"^"))),$P(SRAO(2),"^"),?40," D. Weight Loss > 10%:",?(79-$L($P(SRAO("3D"),"^"))),$P(SRAO("3D"),"^") - W !," A. Impaired Sensorium: ",?(38-$L($P(SRAO("2A"),"^"))),$P(SRAO("2A"),"^"),?40," E. Bleeding Disorders:",?(79-$L($P(SRAO("3E"),"^"))),$P(SRAO("3E"),"^") - W !," B. Coma:",?(38-$L($P(SRAO("2B"),"^"))),$P(SRAO("2B"),"^"),?40," F. Transfusion > 4 RBC Units:",?(79-$L($P(SRAO("3F"),"^"))),$P(SRAO("3F"),"^") - W !," C. Hemiplegia:",?(38-$L($P(SRAO("2C"),"^"))),$P(SRAO("2C"),"^"),?40," G. Chemotherapy W/I 30 Days:",?(79-$L($P(SRAO("3G"),"^"))),$P(SRAO("3G"),"^") - W !," D. History of TIAs:",?(38-$L($P(SRAO("2D"),"^"))),$P(SRAO("2D"),"^"),?40," H. Radiotherapy W/I 90 Days:",?(79-$L($P(SRAO("3H"),"^"))),$P(SRAO("3H"),"^") - W !," E. CVA/Stroke w. Neuro Deficit:",?(38-$L($P(SRAO("2E"),"^"))),$P(SRAO("2E"),"^"),?40," I. Preoperative Sepsis:",?(79-$L($P(SRAO("3I"),"^"))),$P(SRAO("3I"),"^") - W !," F. CVA/Stroke w/o Neuro Deficit:",?(38-$L($P(SRAO("2F"),"^"))),$P(SRAO("2F"),"^"),?40," J. Pregnancy:",?(79-$L($P(SRAO("3J"),"^"))),$P(SRAO("3J"),"^") - W !," G. Tumor Involving CNS:",?(38-$L($P(SRAO("2G"),"^"))),$P(SRAO("2G"),"^") - Q -OUT(SRFLD,SRY) ; get data in output form - N C,Y - S Y=SRY,C=$P(^DD(130,SRFLD,0),"^",2) D:Y'="" Y^DIQ - I Y="NO STUDY" S Y="NS" - Q Y +SROAPS2 ;BIR/MAM - PREOP INFO (PAGE 2) ;04/24/07 + ;;3.0; Surgery ;**38,47,125,153,160**;24 Jun 93;Build 7 + S SRPAGE="PAGE: 2 OF 2" D HDR^SROAUTL,PRE2 + W !! F I=1:1:80 W "-" + Q +PRE2 N SRX,Y S Y=$P($G(^SRF(SRTN,200.1)),"^",3) I Y="",$P(VADM(5),"^")="M" S $P(^SRF(SRTN,200.1),"^",3)="NA" + S SRA(200)=$G(^SRF(SRTN,200)),SRA(206)=$G(^SRF(SRTN,206)),SRA(200.1)=$G(^SRF(SRTN,200.1)) + S Y=$P(SRA(200),"^",37),SRX=243,SRAO(1)=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",38),SRX=328,SRAO("1A")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",39),SRX=211,SRAO("1B")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",18),SRX=210,SRAO(2)=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",44),SRX=245,SRAO(3)=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",19),SRX=332,SRAO("2A")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",21),SRX=333,SRAO("2B")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",22),SRX=398,SRAO("2I")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",23),SRX=399,SRAO("2H")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",24),SRX=400,SRAO("2C")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",25),SRX=334,SRAO("2D")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",26),SRX=335,SRAO("2E")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",27),SRX=336,SRAO("2F")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",29),SRX=401,SRAO("2G")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",45),SRX=338,SRAO("3A")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",46),SRX=218,SRAO("3B")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",47),SRX=339,SRAO("3C")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",48),SRX=215,SRAO("3D")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",49),SRX=216,SRAO("3E")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200),"^",50),SRX=217,SRAO("3F")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(206),"^",3),SRX=338.1,SRAO("3G")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(206),"^",4),SRX=338.2,SRAO("3H")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(206),"^",8),SRX=218.1,SRAO("3I")=$$OUT(SRX,Y)_"^"_SRX + S Y=$P(SRA(200.1),"^",3),SRX=269,SRAO("3J")=$$OUT(SRX,Y)_"^"_SRX K SRA + W !,"1. RENAL:",?(38-$L($P(SRAO(1),"^"))),$P(SRAO(1),"^"),?40,"3. NUTRITIONAL/IMMUNE/OTHER:",?(79-$L($P(SRAO(3),"^"))),$P(SRAO(3),"^") + W !," A. Acute Renal Failure:",?(38-$L($P(SRAO("1A"),"^"))),$P(SRAO("1A"),"^"),?40," A. Disseminated Cancer:",?(79-$L($P(SRAO("3A"),"^"))),$P(SRAO("3A"),"^") + W !," B. Currently on Dialysis:",?(38-$L($P(SRAO("1B"),"^"))),$P(SRAO("1B"),"^"),?40," B. Open Wound:",?(79-$L($P(SRAO("3B"),"^"))),$P(SRAO("3B"),"^") + W !,?40," C. Steroid Use for Chronic Cond.:",?(79-$L($P(SRAO("3C"),"^"))),$P(SRAO("3C"),"^") + W !,"2. CENTRAL NERVOUS SYSTEM:",?(38-$L($P(SRAO(2),"^"))),$P(SRAO(2),"^"),?40," D. Weight Loss > 10%:",?(79-$L($P(SRAO("3D"),"^"))),$P(SRAO("3D"),"^") + W !," A. Impaired Sensorium: ",?(38-$L($P(SRAO("2A"),"^"))),$P(SRAO("2A"),"^"),?40," E. Bleeding Disorders:",?(79-$L($P(SRAO("3E"),"^"))),$P(SRAO("3E"),"^") + W !," B. Coma:",?(38-$L($P(SRAO("2B"),"^"))),$P(SRAO("2B"),"^"),?40," F. Transfusion > 4 RBC Units:",?(79-$L($P(SRAO("3F"),"^"))),$P(SRAO("3F"),"^") + W !," C. Hemiplegia:",?(38-$L($P(SRAO("2C"),"^"))),$P(SRAO("2C"),"^"),?40," G. Chemotherapy W/I 30 Days:",?(79-$L($P(SRAO("3G"),"^"))),$P(SRAO("3G"),"^") + W !," D. History of TIAs:",?(38-$L($P(SRAO("2D"),"^"))),$P(SRAO("2D"),"^"),?40," H. Radiotherapy W/I 90 Days:",?(79-$L($P(SRAO("3H"),"^"))),$P(SRAO("3H"),"^") + W !," E. CVA/Stroke w. Neuro Deficit:",?(38-$L($P(SRAO("2E"),"^"))),$P(SRAO("2E"),"^"),?40," I. Preoperative Sepsis:",?(79-$L($P(SRAO("3I"),"^"))),$P(SRAO("3I"),"^") + W !," F. CVA/Stroke w/o Neuro Deficit:",?(38-$L($P(SRAO("2F"),"^"))),$P(SRAO("2F"),"^"),?40," J. Pregnancy:",?(79-$L($P(SRAO("3J"),"^"))),$P(SRAO("3J"),"^") + W !," G. Tumor Involving CNS:",?(38-$L($P(SRAO("2G"),"^"))),$P(SRAO("2G"),"^") + W !," H. Paraplegia:",?(38-$L($P(SRAO("2H"),"^"))),$P(SRAO("2H"),"^") + W !," I. Quadriplegia:",?(38-$L($P(SRAO("2I"),"^"))),$P(SRAO("2I"),"^") + Q +OUT(SRFLD,SRY) ; get data in output form + N C,Y + S Y=SRY,C=$P(^DD(130,SRFLD,0),"^",2) D:Y'="" Y^DIQ + I Y="NO STUDY" S Y="NS" + Q Y diff --git a/r/SURGERY-SR/SROASS.m b/r/SURGERY-SR/SROASS.m index 34ac39d9..a2182001 100644 --- a/r/SURGERY-SR/SROASS.m +++ b/r/SURGERY-SR/SROASS.m @@ -1,46 +1,46 @@ -SROASS ;BIR/MAM - SELECT ASSESSMENT ;01/18/07 - ;;3.0; Surgery ;**38,47,64,94,121,100,160,166**;24 Jun 93;Build 7 -PST K:$D(DUZ("SAV")) SRNEW K SRTN W !! S SRSOUT=0 - N SRSEL D ^SROPSEL G:'$D(DFN) END S SRANM=VADM(1)_" "_VA("PID") -START ; start display - G:SRSOUT END W:SRSEL=1 @IOF,!,?1,SRANM - I $D(^DPT(DFN,.35)),$P(^(.35),"^") S SRDT=$P(^(.35),"^") W " * DIED "_$E(SRDT,4,5)_"/"_$E(SRDT,6,7)_"/"_$E(SRDT,2,3)_" *" - I SRSEL=2 S CNT=0 D ^SROASSN G:$D(SRTN) ENTER G PST - D ^SROASS1 I SRSOUT G END - I $D(SRTN) G ENTER - I $D(SRNEW) S CNT=CNT+1,SRCASE(CNT)="" W CNT,". ---- CREATE NEW ASSESSMENT" - I '$D(SRCASE(1)) W !!,"There are no Surgery Risk Assessments entered for "_VADM(1)_".",!! K DIR S DIR(0)="FOA",DIR("A")=" Press RETURN to continue. " D ^DIR Q -OPT W !!!,"Select Surgical Case: " R X:DTIME I '$T!("^"[X) S SRSOUT=1 G END - I '$D(SRCASE(X)) W !!,"Enter the number of the desired assessment." W:$D(SRNEW) " Select '"_CNT_"' to create an",!,"assessment for another surgical case." G OPT - I $D(SRNEW),X=CNT D ^SROANEW G END - I '$D(SRTN) S SRTN=+SRCASE(X) -ENTER ; edit, complete, or delete - I $D(SRPRINT)!'($D(SRNEW)) Q - S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T" D TRANS I 'SRYN K SRASS,SRTN S:SRSEL=2 SRSOUT=1 G START - I SRATYPE="N"&($P(SR("RA"),"^",2)="C") W !!,"You've selected a Cardiac assessment, using a Non-Cardiac Option," K DIR S DIR(0)="Y",DIR("A")="Do you wish to continue",DIR("B")="NO" D ^DIR S X=$E(X) I "Yy"'[X K SRTN S SRSOUT=1 G END - I SRATYPE="C"&($P(SR("RA"),"^",2)="N") W !!,"You've selected a Non-Cardiac assessment, using a Cardiac Option," K DIR S DIR(0)="Y",DIR("A")="Do you wish to continue",DIR("B")="NO" D ^DIR S X=$E(X) I "Yy"'[X K SRTN S SRSOUT=1 G END - W @IOF,!,?1,SRANM,!! S SRSDATE=$P(^SRF(SRTN,0),"^",9) S SRASS=SRTN D DISP^SROASS1 - I SRATYPE="N" D EXCL - W !!,"1. Enter Risk Assessment Information",!,"2. Delete Risk Assessment Entry",!,"3. Update Assessment Status to 'COMPLETE'" - W !!,"Select Number: 1// " R X:DTIME I '$T!(X["^") K SRTN,SRASS S SRSOUT=1 G END - S:X="" X=1 I X<1!(X>3)!(X'?.N) D HELP G ENTER - I X=2 D ^SROADEL W !!,"Press to continue " R X:DTIME W @IOF K SRTN G END - I X=3 D @($S($P(SR("RA"),"^",2)="C":"^SROACOM1",1:"^SROACOM")) K SRTN G END - Q -EXCL I $P($G(^SRO(136,SRTN,10)),"^"),'$$XL^SROAX(SRTN) D - .W !!,">>> Based on CPT Codes assigned for this case, this case should be excluded." Q - N SRPROC,SRL S SRL=49 D CPTS^SROAUTL0 I SRPROC(1)="NOT ENTERED" D - .W !!,">>> No CPT Codes have been assigned for this case." - Q -END S:'$D(SRSOUT) SRSOUT=1 W:SRSOUT @IOF D ^SRSKILL - Q -HELP ; - W !!,"Enter or '1' to enter or edit information related to this Risk ",!,"Assessment entry. If you want to delete the Assessment, enter '2'." - W !,"Enter '3' to update the status of this Assessment to 'COMPLETE'." - W !!,"Press to continue " R X:DTIME - Q -TRANS W @IOF,!,"This assessment has already been transmitted. The information contained",!,"in it cannot be altered unless you first change the status to 'INCOMPLETE'." - S SRYN=0 K DIR S DIR("A")="Do you wish to change the status of this assessment to 'INCOMPLETE'",DIR("B")="NO",DIR(0)="Y" D ^DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q - S SRYN=Y I 'SRYN Q - I $$LOCK^SROUTL(SRTN) K DA,DIE,DR S DIE=130,DA=SRTN,DR="235////I;393////1" D ^DIE K DA,DIE,DR D UNLOCK^SROUTL(SRTN) - Q +SROASS ;BIR/MAM - SELECT ASSESSMENT ;01/18/07 + ;;3.0; Surgery ;**38,47,64,94,121,100,160**;24 Jun 93;Build 7 +PST K:$D(DUZ("SAV")) SRNEW K SRTN W !! S SRSOUT=0 + N SRSEL D ^SROPSEL G:'$D(DFN) END S SRANM=VADM(1)_" "_VA("PID") +START ; start display + G:SRSOUT END W:SRSEL=1 @IOF,!,?1,SRANM + I $D(^DPT(DFN,.35)),$P(^(.35),"^") S SRDT=$P(^(.35),"^") W " * DIED "_$E(SRDT,4,5)_"/"_$E(SRDT,6,7)_"/"_$E(SRDT,2,3)_" *" + I SRSEL=2 S CNT=0 D ^SROASSN G:$D(SRTN) ENTER G PST + D ^SROASS1 I SRSOUT G END + I $D(SRTN) G ENTER + I $D(SRNEW) S CNT=CNT+1,SRCASE(CNT)="" W CNT,". ---- CREATE NEW ASSESSMENT" + I '$D(SRCASE(1)) W !!,"There are no Surgery Risk Assessments entered for "_VADM(1)_".",!! K DIR S DIR(0)="FOA",DIR("A")=" Press RETURN to continue. " D ^DIR Q +OPT W !!!,"Select Surgical Case: " R X:DTIME I '$T!("^"[X) S SRSOUT=1 G END + I '$D(SRCASE(X)) W !!,"Enter the number of the desired assessment." W:$D(SRNEW) " Select '"_CNT_"' to create an",!,"assessment for another surgical case." G OPT + I $D(SRNEW),X=CNT D ^SROANEW G END + I '$D(SRTN) S SRTN=+SRCASE(X) +ENTER ; edit, complete, or delete + I $D(SRPRINT)!'($D(SRNEW)) Q + S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T" D TRANS I 'SRYN K SRASS,SRTN S:SRSEL=2 SRSOUT=1 G START + I SRATYPE="N"&($P(SR("RA"),"^",2)="C") W !!,"You've selected a Cardiac assessment, using a Non-Cardiac Option," K DIR S DIR(0)="Y",DIR("A")="Do you wish to continue",DIR("B")="NO" D ^DIR S X=$E(X) I "Yy"'[X K SRTN S SRSOUT=1 G END + I SRATYPE="C"&($P(SR("RA"),"^",2)="N") W !!,"You've selected a Non-Cardiac assessment, using a Cardiac Option," K DIR S DIR(0)="Y",DIR("A")="Do you wish to continue",DIR("B")="NO" D ^DIR S X=$E(X) I "Yy"'[X K SRTN S SRSOUT=1 G END + W @IOF,!,?1,SRANM,!! S SRSDATE=$P(^SRF(SRTN,0),"^",9) S SRASS=SRTN D DISP^SROASS1 + I SRATYPE="N" D EXCL + W !!,"1. Enter Risk Assessment Information",!,"2. Delete Risk Assessment Entry",!,"3. Update Assessment Status to 'COMPLETE'" + W !!,"Select Number: 1// " R X:DTIME I '$T!(X["^") K SRTN,SRASS S SRSOUT=1 G END + S:X="" X=1 I X<1!(X>3)!(X'?.N) D HELP G ENTER + I X=2 D ^SROADEL W !!,"Press to continue " R X:DTIME W @IOF K SRTN G END + I X=3 D ^SROACOM K SRTN G END + Q +EXCL I $P($G(^SRO(136,SRTN,10)),"^"),'$$XL^SROAX(SRTN) D + .W !!,">>> Based on CPT Codes assigned for this case, this case should be excluded." Q + N SRPROC,SRL S SRL=49 D CPTS^SROAUTL0 I SRPROC(1)="NOT ENTERED" D + .W !!,">>> No CPT Codes have been assigned for this case." + Q +END S:'$D(SRSOUT) SRSOUT=1 W:SRSOUT @IOF D ^SRSKILL + Q +HELP ; + W !!,"Enter or '1' to enter or edit information related to this Risk ",!,"Assessment entry. If you want to delete the Assessment, enter '2'." + W !,"Enter '3' to update the status of this Assessment to 'COMPLETE'." + W !!,"Press to continue " R X:DTIME + Q +TRANS W @IOF,!,"This assessment has already been transmitted. The information contained",!,"in it cannot be altered unless you first change the status to 'INCOMPLETE'." + S SRYN=0 K DIR S DIR("A")="Do you wish to change the status of this assessment to 'INCOMPLETE'",DIR("B")="NO",DIR(0)="Y" D ^DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q + S SRYN=Y I 'SRYN Q + I $$LOCK^SROUTL(SRTN) K DA,DIE,DR S DIE=130,DA=SRTN,DR="235////I;393////1" D ^DIE K DA,DIE,DR D UNLOCK^SROUTL(SRTN) + Q diff --git a/r/SURGERY-SR/SROASSP.m b/r/SURGERY-SR/SROASSP.m index 8ba11b69..375a8af6 100644 --- a/r/SURGERY-SR/SROASSP.m +++ b/r/SURGERY-SR/SROASSP.m @@ -1,12 +1,12 @@ -SROASSP ;BIR/MAM - PRINT A COMPLETED ASSESSMENT ;12/05/07 - ;;3.0; Surgery ;**38,94,166**;24 Jun 93;Build 7 -BATCH ; - W ! K DIR S DIR("?",1)="Enter YES to batch print all completed or transmitted assessments for a",DIR("?",2)="selected date range. Enter NO or press return to print one specific",DIR("?")="assessment." - S DIR("A")="Do you want to batch print assessments for a specific date range ? ",DIR(0)="YA",DIR("B")="NO" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 G END - I Y D ^SROABCH Q - S SRPRINT=1 K SRNEW D ^SROASS I '$D(SRTN) S SRSOUT=1 G END - W ! K %ZIS,IO("Q"),POP S %ZIS("A")="Print the Completed Assessment on which Device: ",%ZIS="Q" D ^%ZIS I POP S SRSOUT=1 G END - I $D(IO("Q")) K IO("Q") S ZTDESC="Completed Surgery Risk Assessment",ZTSAVE("SRSITE*")="",ZTSAVE("SRTN")="",ZTRTN=$S($P($G(^SRF(SRTN,"RA")),"^",2)="C":"EN^SROACOM1",1:"EN^SROACOM") D ^%ZTLOAD G END - D @($S($P($G(^SRF(SRTN,"RA")),"^",2)="C":"EN^SROACOM1",1:"EN^SROACOM")) -END D ^%ZISC W @IOF K SRTN D ^SRSKILL - Q +SROASSP ;B'HAM ISC/MAM - PRINT A COMPLETED ASSESSMENT ; [04/06/00 12:05 PM ] + ;;3.0; Surgery ;**38,94**;24 Jun 93 +BATCH ; + W ! K DIR S DIR("?",1)="Enter YES to batch print all completed or transmitted assessments for a",DIR("?",2)="selected date range. Enter NO or press return to print one specific",DIR("?")="assessment." + S DIR("A")="Do you want to batch print assessments for a specific date range ? ",DIR(0)="YA",DIR("B")="NO" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 G END + I Y D ^SROABCH Q + S SRPRINT=1 K SRNEW D ^SROASS I '$D(SRTN) S SRSOUT=1 G END + W ! K %ZIS,IO("Q"),POP S %ZIS("A")="Print the Completed Assessment on which Device: ",%ZIS="Q" D ^%ZIS I POP S SRSOUT=1 G END + I $D(IO("Q")) K IO("Q") S ZTDESC="Completed Surgery Risk Assessment",ZTSAVE("SRSITE*")="",ZTSAVE("SRTN")="",ZTRTN="EN^SROACOM" D ^%ZTLOAD G END + D EN^SROACOM +END D ^%ZISC W @IOF K SRTN D ^SRSKILL + Q diff --git a/r/SURGERY-SR/SROATCM3.m b/r/SURGERY-SR/SROATCM3.m index ba459a5a..98642e1a 100644 --- a/r/SURGERY-SR/SROATCM3.m +++ b/r/SURGERY-SR/SROATCM3.m @@ -1,26 +1,25 @@ -SROATCM3 ;BIR/SJA - STUFF TRANMISSION IN ^TMP ;12/03/07 - ;;3.0; Surgery ;**125,135,153,164,166**;24 Jun 93;Build 7 - N SRDISP,NYUK S SRDISP="",NYUK=$P(SRRES(1),U,2),SRA(209.1)=$G(^SRF(SRTN,209.1)),SRA(207.1)=$G(^SRF(SRTN,207.1)) - I NYUK'="" D - .S SRDISP=$S(NYUK="BOARDING HOUSE":16,NYUK="COMMUNITY HOSPITAL":6,NYUK="COMMUNITY NURSING HOME":8,NYUK="FOSTER HOME":14,NYUK="HALFWAY HOUSE":15,NYUK="HOME-BASED PRIMARY CARE (HBPC)":20,1:NYUK) - .Q:SRDISP'=NYUK S SRDISP=$S(NYUK="HOSPICE CARE":22,NYUK="MILITARY HOSPITAL":3,NYUK="NURSE CARE CONTD ANOTHER COMM ":10,NYUK="NURSING CARE CONT AT SAME NURS":9,NYUK="OTHER FEDERAL HOSPITAL":4,1:NYUK) - .Q:SRDISP'=NYUK S SRDISP=$S(NYUK="OTHER GOVERNMENT HOSPITAL":5,NYUK="OTHER PLACEMENT/UNKNOWN (NOT S":19,NYUK="PENAL INSTITUTION":17,NYUK="REFER MEDICARE HOME HEALTH CAR":25,NYUK="REFER OTHER AGENCY-PD HOME HEA":26,1:NYUK) - .Q:SRDISP'=NYUK S SRDISP=$S(NYUK="REFER VA-PD HOME/COMMUNITY HEA":24,NYUK="RESIDENTIAL HOTEL/RESIDENT (IE":18,NYUK="RESPITE CARE":23,NYUK="RETURN TO COMMUNITY-INDEPENDEN":1,NYUK="SPINAL CORD INJURY-VACO APPROV":21,1:NYUK) - .Q:SRDISP'=NYUK S SRDISP=$S(NYUK="STATE HOME":11,NYUK="STATE HOME":13,NYUK="VA DOMICILLARY":12,NYUK="VA MEDICAL CENTER":2,NYUK="VA NURSING HOME CARE UNIT (NHC":7,1:"") - ; -LN26 S SHEMP=$E(SHEMP,1,11)_" 26"_$J(SRDISP,2)_$J($P(SRA(206),"^",13),2)_$J($P(SRA(206),"^",15),2)_$J($P(SRA(207),"^",6),2)_$J($P(SRA(207),"^",27),2)_$J($P(SRA(209),"^"),2)_$J($P(SRA(209),"^",2),2) - S SHEMP=SHEMP_$J($P(SRA(209),"^",3),2)_$J($P(SRA(209),"^",4),2)_$J($P(SRA(209),"^",5),2)_$J($P(SRA(209),"^",6),3)_$J($P(SRA(209),"^",7),3)_$J($P(SRA(209),"^",8),3)_$J($P(SRA(209),"^",9),2)_$J($P(SRA(209),"^",10),2) - S X=$P(SRA(206),"^",42),Y="" F I=1:1:5 S Y=Y_$P(X,",",I) - S SHEMP=SHEMP_$J($P(SRA(209),"^",11),2)_$J(Y,5) - S X=$P(SRA(209),"^",12) S:X="" X="N" S SHEMP=SHEMP_$J(X,2) - ; CT Surgery Consult Date and cause for delay - S SRDATE=$P(SRA(209),"^",15),SRDATE=$$LJ^XLFSTR(SRDATE,7,0),SHEMP=SHEMP_SRDATE - S X=$P(SRA(209),"^",16),SHEMP=SHEMP_$J(X,2) - S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SRACNT=SRACNT+1 -LN27 ;Line #27 - Other Cardiac Procedures - S SHEMP=$E(SHEMP,1,11)_" 27"_$TR($E($G(SRA(209.1)),1,65),",","^") - S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SRACNT=SRACNT+1 -LN28 ;Lines 28 - New fields added in 2006 update - S SHEMP=$E(SHEMP,1,11)_" 28"_$J($P(SRA(209),"^",13),2)_$J($P(SRA(209),"^",14),2)_$J($P(SRA(207.1),"^",2),2)_$J($P(SRA(201),"^",28),6)_$J($P(SRA(202.1),"^"),7) - S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SRACNT=SRACNT+1 - Q +SROATCM3 ;BIR/SJA - STUFF TRANMISSION IN ^TMP ;08/24/07 + ;;3.0; Surgery ;**125,135,153,164**;24 Jun 93;Build 2 + N SRDISP,NYUK S SRDISP="",NYUK=$P(SRRES(1),U,2),SRA(209.1)=$G(^SRF(SRTN,209.1)),SRA(207.1)=$G(^SRF(SRTN,207.1)) + I NYUK'="" D + .S SRDISP=$S(NYUK="BOARDING HOUSE":16,NYUK="COMMUNITY HOSPITAL":6,NYUK="COMMUNITY NURSING HOME":8,NYUK="FOSTER HOME":14,NYUK="HALFWAY HOUSE":15,NYUK="HOME-BASED PRIMARY CARE (HBPC)":20,1:NYUK) + .Q:SRDISP'=NYUK S SRDISP=$S(NYUK="HOSPICE CARE":22,NYUK="MILITARY HOSPITAL":3,NYUK="NURSE CARE CONTD ANOTHER COMM ":10,NYUK="NURSING CARE CONT AT SAME NURS":9,NYUK="OTHER FEDERAL HOSPITAL":4,1:NYUK) + .Q:SRDISP'=NYUK S SRDISP=$S(NYUK="OTHER GOVERNMENT HOSPITAL":5,NYUK="OTHER PLACEMENT/UNKNOWN (NOT S":19,NYUK="PENAL INSTITUTION":17,NYUK="REFER MEDICARE HOME HEALTH CAR":25,NYUK="REFER OTHER AGENCY-PD HOME HEA":26,1:NYUK) + .Q:SRDISP'=NYUK S SRDISP=$S(NYUK="REFER VA-PD HOME/COMMUNITY HEA":24,NYUK="RESIDENTIAL HOTEL/RESIDENT (IE":18,NYUK="RESPITE CARE":23,NYUK="RETURN TO COMMUNITY-INDEPENDEN":1,NYUK="SPINAL CORD INJURY-VACO APPROV":21,1:NYUK) + .Q:SRDISP'=NYUK S SRDISP=$S(NYUK="STATE HOME":11,NYUK="STATE HOME":13,NYUK="VA DOMICILLARY":12,NYUK="VA MEDICAL CENTER":2,NYUK="VA NURSING HOME CARE UNIT (NHC":7,1:"") + ; +LN26 S SHEMP=$E(SHEMP,1,11)_" 26"_$J(SRDISP,2)_$J($P(SRA(206),"^",13),2)_$J($P(SRA(206),"^",15),2)_$J($P(SRA(207),"^",6),2)_$J($P(SRA(207),"^",27),2)_$J($P(SRA(209),"^"),2)_$J($P(SRA(209),"^",2),2) + S SHEMP=SHEMP_$J($P(SRA(209),"^",3),2)_$J($P(SRA(209),"^",4),2)_$J($P(SRA(209),"^",5),2)_$J($P(SRA(209),"^",6),3)_$J($P(SRA(209),"^",7),3)_$J($P(SRA(209),"^",8),3)_$J($P(SRA(209),"^",9),2)_$J($P(SRA(209),"^",10),2) + S X=$P(SRA(206),"^",42),Y="" F I=1:1:5 S Y=Y_$P(X,",",I) + S SHEMP=SHEMP_$J($P(SRA(209),"^",11),2)_$J(Y,5) + S X=$P(SRA(209),"^",12) S:X="" X="N" S SHEMP=SHEMP_$J(X,2) + ; CT Surgery Consult Date + S SRDATE=$P(SRA(209),"^",15),SRDATE=$$LJ^XLFSTR(SRDATE,7,0),SHEMP=SHEMP_SRDATE + S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SRACNT=SRACNT+1 +LN27 ;Line #27 - Other Cardiac Procedures + S SHEMP=$E(SHEMP,1,11)_" 27"_$TR($E($G(SRA(209.1)),1,65),",","^") + S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SRACNT=SRACNT+1 +LN28 ;Lines 28 - New fields added in 2006 update + S SHEMP=$E(SHEMP,1,11)_" 28"_$J($P(SRA(209),"^",13),2)_$J($P(SRA(209),"^",14),2)_$J($P(SRA(207.1),"^",2),2)_$J($P(SRA(201),"^",28),6)_$J($P(SRA(202.1),"^"),7) + S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SRACNT=SRACNT+1 + Q diff --git a/r/SURGERY-SR/SROATM1.m b/r/SURGERY-SR/SROATM1.m index 0c7dffeb..4a9e3415 100644 --- a/r/SURGERY-SR/SROATM1.m +++ b/r/SURGERY-SR/SROATM1.m @@ -1,41 +1,40 @@ -SROATM1 ;BIR/MAM - NON CARDIAC TRANSMISSION ;12/10/07 - ;;3.0; Surgery ;**27,38,47,60,62,81,88,93,95,125,153,160,166**;24 Jun 93;Build 7 - ;** NOTICE: This routine is part of an implementation of a nationally - ;** controlled procedure. Local modifications to this routine - ;** are prohibited. - ; - ; Reference to ^DIC(45.3 supported by DBIA #218 - ; - N SRINTUB,SRDTH,SRPID,SRCDT,SRCREQ F I=0,200,200.1,206 S SRA(I)=$G(^SRF(SRTN,I)) - S DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANAME=VADM(1),SEX=$P(VADM(5),"^"),Z=$P(VADM(3),"^"),SRSDATE=$E($P(SRA(0),"^",9),1,12),Y=$E(SRSDATE,1,7),AGE=$E(Y,1,3)-$E(Z,1,3)-($E(Y,4,7)<$E(Z,4,7)) - S SRPID=VA("PID"),SRPID=$TR(SRPID,"-","") ; remove hyphens from PID - S X=$$SITE^SROUTL0(SRTN),SRDIV=$S(X:$P(^SRO(133,X,0),"^"),1:""),SRDIV=$S(SRDIV:$$GET1^DIQ(4,SRDIV,99),1:SRASITE) - S X=$P($G(^SRF(SRTN,205)),"^",3),SRDTH=$S(X:X,1:$P(VADM(6),"^")) - S SRCDT=$P($G(^SRF(SRTN,209)),"^",15),SRCREQ=$P($G(^SRF(SRTN,209)),"^",17) - S SHEMP=">"_$J(SRASITE,3)_$J(SRTN,7)_" 1"_DT_$J(AGE,3)_$J(SEX,1)_$J(SRSDATE,12)_$J(SRPID,20)_$J(SRDIV,6)_$J(SRDTH,12)_$J(SRCDT,7)_$J(SRCREQ,7) - S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SHEMP=$E(SHEMP,1,11)_" 2",SRACNT=SRACNT+1 - S NYUK=$P(SRA(200),"^",2) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",3) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",4) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200.1),"^",2) D ONE S SHEMP=SHEMP_MOE - S NYUK=$P(SRA(200),"^",6) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",7) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",8) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",10) D ONE S SHEMP=SHEMP_MOE - S NYUK=$P(SRA(200),"^",11) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",12) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200.1),"^",6) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",15) D ONE S SHEMP=SHEMP_MOE - S NYUK=$P(SRA(200),"^",16) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",17) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",31) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",32) D ONE S SHEMP=SHEMP_MOE - S NYUK=$P(SRA(200),"^",33) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",34) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",35) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",36) D ONE S SHEMP=SHEMP_MOE - S NYUK=$P(SRA(200),"^",38) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",39) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",41) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",42) D ONE S SHEMP=SHEMP_MOE - S NYUK=$P(SRA(200),"^",43) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",19) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",20) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",21) D ONE S SHEMP=SHEMP_MOE - S NYUK=$P(SRA(200),"^",22) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",23) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",24) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",25) D ONE S SHEMP=SHEMP_MOE - S NYUK=$P(SRA(200),"^",26) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",27) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",28) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",29) D ONE S SHEMP=SHEMP_MOE - S NYUK=$P(SRA(200),"^",45) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",46) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",47) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",48) D ONE S SHEMP=SHEMP_MOE - S NYUK=$P(SRA(200),"^",49) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",50) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200.1),"^",3),SHEMP=SHEMP_$J(NYUK,2) - S NYUK=$P(SRA(0),"^",4) S:NYUK NYUK=$E($P(^DIC(45.3,$P(^SRO(137.45,NYUK,0),"^",2),0),"^"),1,3) S SHEMP=SHEMP_$J(NYUK,3) - S NYUK=$P(SRA(200),"^",52),SHEMP=SHEMP_$J(NYUK,2),X=$P(SRA(0),"^",10),NYUK=$S(X="EM":"Y",1:"N") D ONE S SHEMP=SHEMP_MOE - S NYUK=$P($G(^SRF(SRTN,"1.0")),"^",8),SHEMP=SHEMP_$J(NYUK,2),NYUK=$P(SRA(200),"^",53) D ONE S SHEMP=SHEMP_MOE - S SRASA="",Y=$P($G(^SRF(SRTN,1.1)),"^",3) S:Y X=$P($P($G(^SRO(132.8,Y,0)),"^"),"-"),SRASA=X S NYUK=$E(SRASA,1,1) D ONE S SHEMP=SHEMP_MOE - K SRTECH,SRZ,SRTRAUMA S SRT=0 F S SRT=$O(^SRF(SRTN,6,SRT)) Q:'SRT D ^SROPRIN Q:$D(SRZ) - I $D(SRTECH) S SRTRAUMA=$P(^SRF(SRTN,6,SRT,0),"^",14),SRINTUB=$P($G(^SRF(SRTN,6,SRT,8)),"^",2) - I '$D(SRTECH) S (SRTECH,SRTRAUMA,SRINTUB)="" - S SHEMP=SHEMP_$J(SRTECH,1)_$J($E(SRASA,2),1)_$J(SRINTUB,1)_" " - S NYUK=$P(SRA(206),"^"),SHEMP=SHEMP_$J(NYUK,4),NYUK=$P(SRA(206),"^",2),SHEMP=SHEMP_$J(NYUK,4) - S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SHEMP=$E(SHEMP,1,11)_" 3",SRACNT=SRACNT+1 - D ^SROATM2 - Q -ONE S MOE=$S(NYUK="NS":"S",NYUK="":" ",1:NYUK) - Q +SROATM1 ;BIR/MAM - NON CARDIAC TRANSMISSION ;05/10/07 + ;;3.0; Surgery ;**27,38,47,60,62,81,88,93,95,125,153,160**;24 Jun 93;Build 7 + ;** NOTICE: This routine is part of an implementation of a nationally + ;** controlled procedure. Local modifications to this routine + ;** are prohibited. + ; + ; Reference to ^DIC(45.3 supported by DBIA #218 + ; + N SRINTUB,SRDTH,SRPID F I=0,200,200.1,206 S SRA(I)=$G(^SRF(SRTN,I)) + S DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANAME=VADM(1),SEX=$P(VADM(5),"^"),Z=$P(VADM(3),"^"),SRSDATE=$E($P(SRA(0),"^",9),1,12),Y=$E(SRSDATE,1,7),AGE=$E(Y,1,3)-$E(Z,1,3)-($E(Y,4,7)<$E(Z,4,7)) + S SRPID=VA("PID"),SRPID=$TR(SRPID,"-","") ; remove hyphens from PID + S X=$$SITE^SROUTL0(SRTN),SRDIV=$S(X:$P(^SRO(133,X,0),"^"),1:""),SRDIV=$S(SRDIV:$$GET1^DIQ(4,SRDIV,99),1:SRASITE) + S X=$P($G(^SRF(SRTN,205)),"^",3),SRDTH=$S(X:X,1:$P(VADM(6),"^")) + S SHEMP=">"_$J(SRASITE,3)_$J(SRTN,7)_" 1"_DT_$J(AGE,3)_$J(SEX,1)_$J(SRSDATE,12)_$J(SRPID,20)_$J(SRDIV,6)_$J(SRDTH,12) + S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SHEMP=$E(SHEMP,1,11)_" 2",SRACNT=SRACNT+1 + S NYUK=$P(SRA(200),"^",2) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",3) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",4) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200.1),"^",2) D ONE S SHEMP=SHEMP_MOE + S NYUK=$P(SRA(200),"^",6) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",7) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",8) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",10) D ONE S SHEMP=SHEMP_MOE + S NYUK=$P(SRA(200),"^",11) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",12) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200.1),"^",6) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",15) D ONE S SHEMP=SHEMP_MOE + S NYUK=$P(SRA(200),"^",16) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",17) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",31) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",32) D ONE S SHEMP=SHEMP_MOE + S NYUK=$P(SRA(200),"^",33) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",34) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",35) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",36) D ONE S SHEMP=SHEMP_MOE + S NYUK=$P(SRA(200),"^",38) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",39) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",41) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",42) D ONE S SHEMP=SHEMP_MOE + S NYUK=$P(SRA(200),"^",43) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",19) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",20) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",21) D ONE S SHEMP=SHEMP_MOE + S NYUK=$P(SRA(200),"^",22) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",23) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",24) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",25) D ONE S SHEMP=SHEMP_MOE + S NYUK=$P(SRA(200),"^",26) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",27) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",28) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",29) D ONE S SHEMP=SHEMP_MOE + S NYUK=$P(SRA(200),"^",45) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",46) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",47) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",48) D ONE S SHEMP=SHEMP_MOE + S NYUK=$P(SRA(200),"^",49) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",50) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200.1),"^",3),SHEMP=SHEMP_$J(NYUK,2) + S NYUK=$P(SRA(0),"^",4) S:NYUK NYUK=$E($P(^DIC(45.3,$P(^SRO(137.45,NYUK,0),"^",2),0),"^"),1,3) S SHEMP=SHEMP_$J(NYUK,3) + S NYUK=$P(SRA(200),"^",52),SHEMP=SHEMP_$J(NYUK,2),X=$P(SRA(0),"^",10),NYUK=$S(X="EM":"Y",1:"N") D ONE S SHEMP=SHEMP_MOE + S NYUK=$P($G(^SRF(SRTN,"1.0")),"^",8),SHEMP=SHEMP_$J(NYUK,2),NYUK=$P(SRA(200),"^",53) D ONE S SHEMP=SHEMP_MOE + S SRASA="",Y=$P($G(^SRF(SRTN,1.1)),"^",3) S:Y X=$P($P($G(^SRO(132.8,Y,0)),"^"),"-"),SRASA=X S NYUK=$E(SRASA,1,1) D ONE S SHEMP=SHEMP_MOE + K SRTECH,SRZ,SRTRAUMA S SRT=0 F S SRT=$O(^SRF(SRTN,6,SRT)) Q:'SRT D ^SROPRIN Q:$D(SRZ) + I $D(SRTECH) S SRTRAUMA=$P(^SRF(SRTN,6,SRT,0),"^",14),SRINTUB=$P($G(^SRF(SRTN,6,SRT,8)),"^",2) + I '$D(SRTECH) S (SRTECH,SRTRAUMA,SRINTUB)="" + S SHEMP=SHEMP_$J(SRTECH,1)_$J($E(SRASA,2),1)_$J(SRINTUB,1)_" " + S NYUK=$P(SRA(206),"^"),SHEMP=SHEMP_$J(NYUK,4),NYUK=$P(SRA(206),"^",2),SHEMP=SHEMP_$J(NYUK,4) + S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SHEMP=$E(SHEMP,1,11)_" 3",SRACNT=SRACNT+1 + D ^SROATM2 + Q +ONE S MOE=$S(NYUK="NS":"S",NYUK="":" ",1:NYUK) + Q diff --git a/r/SURGERY-SR/SROATMNO.m b/r/SURGERY-SR/SROATMNO.m index f79f1e13..fdd25955 100644 --- a/r/SURGERY-SR/SROATMNO.m +++ b/r/SURGERY-SR/SROATMNO.m @@ -1,77 +1,76 @@ -SROATMNO ;BIR/MAM - TRANSMIT NO ASSESSMENT ;12/18/07 - ;;3.0; Surgery ;**27,38,47,62,68,79,83,81,88,93,95,97,129,125,142,153,160,166**;24 Jun 93;Build 7 - ;** NOTICE: This routine is part of an implementation of a nationally - ;** controlled procedure. Local modifications to this routine - ;** are prohibited. - ; - ; Reference to ^DIC(45.3 supported by DBIA #218 - ; - N SR10SP,SRINTUB,SR95PO,SRLO,SRPID,TDATE K ^TMP("SRA",$J) S SRATOT=0,SRASITE=+$P($$SITE^SROVAR,"^",3),(SRAMNUM,SRACNT)=1 - S Z=$E(DT,1,3)-1,SRLO=Z_"0214" - S TDATE=0 F S TDATE=$O(^SRF("AQ",TDATE)) Q:TDATE="" I DT'5 - ..S X=$P(^SRO(136,SRTN,1,SRM,0),"^") I X S Y=$P($$MOD^ICPTMOD(X,"I"),"^",2),SRPMOD=SRPMOD_Y,SRCNT=SRCNT+1 - S DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRDOB=$E($P(VADM(3),"^"),1,7),SRDEATH=$P(VADM(6),U) - S SRPID=VA("PID"),SRPID=$TR(SRPID,"-","") ; remove hyphens from PID - S X=$$SITE^SROUTL0(SRTN),SRDIV=$S(X:$P(^SRO(133,X,0),"^"),1:""),SRDIV=$S(SRDIV:$$GET1^DIQ(4,SRDIV,99),1:SRASITE) - D RS^SROATM2 - S SRMAJMIN=$E($P($G(^SRF(SRTN,0)),U,3),1) - S SRDTHUR=$E($P($G(^SRF(SRTN,.4)),U,7),1) - S SRSTATUS=$E($P($G(^SRF(SRTN,0)),U,12),1) I SRSTATUS'="I"&(SRSTATUS'="O") S VAIP("D")=$P(SRA(0),"^",9) D IN5^VADPT S SRSTATUS=$S(VAIP(13):"I",1:"O") K VAIP - S SRAGE="" I $P(VADM(3),"^") S SRAGE=$E(DATE,1,3)-$E($P(VADM(3),"^"),1,3)-($E(DATE,4,7)<$E($P(VADM(3),"^"),4,7)) - S SRASA="",Y=$P($G(^SRF(SRTN,1.1)),"^",3) S:Y X=$P($P($G(^SRO(132.8,Y,0)),"^"),"-"),SRASA=$E(X,1,2) - ; Admission wi 14 days following outpatient surgery due to an Occurrence - S (SRADMIT,SRADMT)=0 I SRSTATUS="O" D ADM^SROQ0A S SRADMIT=$S(SRADMT=0:"0",1:"1") - S EXC=$P($G(^SRF(SRTN,"RA")),"^",7),SRWOUND=$P($G(^SRF(SRTN,"1.0")),"^",8) - D OCC - S SRNODE=" X" S:$P($G(^SRF(SRTN,"RA")),U,6)="N" SRNODE=" *" S:$P($G(^SRF(SRTN,"RA")),U,2)="C" SRNODE=" C" - S SRTEMP="/"_$J(SRASITE,3)_$J(SRTN,7)_SRNODE_$J(DATE,7)_$J(SRTECH,3)_$J(EMERG,1)_$J(SPEC,3)_$J(CPT,5)_$J(EXC,1)_$J(SRPID,20)_$J(SRDIV,6)_" " - S SRTEMP=SRTEMP_$J(SRMAJMIN,1)_$J($E(SRDEATH,1,7),7)_$J(SRDTHUR,1)_$J(SRSTATUS,1)_$J(SRAGE,3)_$J(SRASA,2)_$J(SRADMIT,1)_SRTMP - K CPT,SRMOD F SRZ=1:1:10 S (CPT(SRZ),SRMOD(SRZ))="" - S (OPS,CNT)=0 F S OPS=$O(^SRO(136,SRTN,3,OPS)) Q:'OPS!(CNT=10) S CNT=CNT+1,X=$P($G(^SRO(136,SRTN,3,OPS,0)),"^") I X S CPT(CNT)=$P($$CPT^ICPTCOD(X),"^",2) D MOD - S SRCC=$P($G(^SRF(SRTN,"CON")),"^"),SRBLANK=" " - I SRCC,$P($G(^SRF(SRCC,30)),"^")!($P($G(^SRF(SRCC,31)),"^",8)) S SRCC="" - S SRTEMP=SRTEMP_$J(CPT(1),5)_$J(CPT(2),5)_$J(CPT(3),5)_$J(CPT(4),5)_$J(CPT(5),5)_$J(CPT(6),5)_$J(CPT(7),5)_$J(CPT(8),5)_$J(CPT(9),5)_$J(CPT(10),5)_$J(SRWOUND,2)_$J(SROCTYPE,1)_SRBLANK_$J(SRCC,10)_$J(SRDEATH,12) - S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SRTEMP,SRACNT=SRACNT+1 - S SRICD=$P($G(^SRO(136,SRTN,0)),"^",3) S:SRICD SRICD=$P(^ICD9(SRICD,0),"^") - S SRA(.2)=$G(^SRF(SRTN,.2)) - S SRTEMP="/"_$J(SRASITE,3)_$J(SRTN,7)_" B"_$J($E($P(SRA(.2),"^"),1,12),12)_$J($E($P(SRA(.2),"^",4),1,12),12)_$E(SRPMOD_SR10SP,1,10) - F I=1:1:10 S SRTEMP=SRTEMP_$E(SRMOD(I)_SR10SP,1,10) - S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SRTEMP_$J(SRINTUB,1)_SR95PO_$J(SRATT,2)_$J(SRDOB,7)_$J(SRICD,6)_$J(SROC(38),2),SRACNT=SRACNT+1 - I SRACNT>100 S SRACNT=1,SRAMNUM=SRAMNUM+1 - S SRATOT=SRATOT+1 - S X=$E($P(^SRF(SRTN,0),"^",9),1,5)_"00",^TMP("SRWL",$J,X)="" - K DATE,ANES,EMERG,EXC,SPEC,SRADMIT,SRADMT,SRATT,SRBLANK,SRCC,SRDIV,SRDOB,SRDTHUR,SRICD,SRIO,SRMAJMIN,SROCTYPE,SRTEMP,SRTMP,SRWOUND,SRZ,SR14,CPT - Q -OCC ; total of each occurrence by category - N SRIOFLAG,SRPOFLAG - F SRK=1:1:38 S SROC(SRK)="" - S (SRPO,SRIOFLAG)=0 F S SRPO=$O(^SRF(SRTN,10,SRPO)) Q:'SRPO S SRSUB=$P(^SRF(SRTN,10,SRPO,0),U,2) I SRSUB'="" D - .S SROC(SRSUB)=SROC(SRSUB)+1,SRIOFLAG=1 - S (SRPO,SRPOFLAG)=0 F S SRPO=$O(^SRF(SRTN,16,SRPO)) Q:'SRPO S SRSUB=$P(^SRF(SRTN,16,SRPO,0),U,2) I SRSUB'="" D - .S SROC(SRSUB)=SROC(SRSUB)+1,SRPOFLAG=1 - S (SROCTYPE,SRTMP)="" F SRK=1:1:10 S SRTMP=SRTMP_$J(SROC(SRK),2) - S SRTMP=SRTMP_$J(SROC(37),2) F SRK=12:1:32 S SRTMP=SRTMP_$J(SROC(SRK),2) - S SR95PO=$J(SROC(33),2)_$J(SROC(34),2)_$J(SROC(35),2)_$J(SROC(36),2) - I SRIOFLAG=1,(SRPOFLAG=0) S SROCTYPE="I" - I SRIOFLAG=0,(SRPOFLAG=1) S SROCTYPE="P" - I SRIOFLAG=1,(SRPOFLAG=1) S SROCTYPE="B" - I SRIOFLAG=0,(SRPOFLAG=0) S SROCTYPE="" - Q -MOD N SRM S SRM=0,SRCNT=1 F S SRM=$O(^SRO(136,SRTN,3,OPS,1,SRM)) Q:'SRM D Q:SRCNT>5 - .S X=$P(^SRO(136,SRTN,3,OPS,1,SRM,0),"^"),Y=$P($$MOD^ICPTMOD(X,"I"),"^",2) - .I Y'="" S SRMOD(CNT)=SRMOD(CNT)_Y,SRCNT=SRCNT+1 - Q +SROATMNO ;BIR/MAM - TRANSMIT NO ASSESSMENT ;05/10/07 + ;;3.0; Surgery ;**27,38,47,62,68,79,83,81,88,93,95,97,129,125,142,153,160**;24 Jun 93;Build 7 + ;** NOTICE: This routine is part of an implementation of a nationally + ;** controlled procedure. Local modifications to this routine + ;** are prohibited. + ; + ; Reference to ^DIC(45.3 supported by DBIA #218 + ; + N SR10SP,SRINTUB,SR95PO,SRLO,SRPID,TDATE K ^TMP("SRA",$J) S SRATOT=0,SRASITE=+$P($$SITE^SROVAR,"^",3),(SRAMNUM,SRACNT)=1 + S Z=$E(DT,1,3)-1,SRLO=Z_"0214" + S TDATE=0 F S TDATE=$O(^SRF("AQ",TDATE)) Q:TDATE="" I DT'5 + ..S X=$P(^SRO(136,SRTN,1,SRM,0),"^") I X S Y=$P($$MOD^ICPTMOD(X,"I"),"^",2),SRPMOD=SRPMOD_Y,SRCNT=SRCNT+1 + S DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRDOB=$E($P(VADM(3),"^"),1,7),SRDEATH=$P(VADM(6),U) + S SRPID=VA("PID"),SRPID=$TR(SRPID,"-","") ; remove hyphens from PID + S X=$$SITE^SROUTL0(SRTN),SRDIV=$S(X:$P(^SRO(133,X,0),"^"),1:""),SRDIV=$S(SRDIV:$$GET1^DIQ(4,SRDIV,99),1:SRASITE) + D RS^SROATM2 + S SRMAJMIN=$E($P($G(^SRF(SRTN,0)),U,3),1) + S SRDTHUR=$E($P($G(^SRF(SRTN,.4)),U,7),1) + S SRSTATUS=$E($P($G(^SRF(SRTN,0)),U,12),1) I SRSTATUS'="I"&(SRSTATUS'="O") S VAIP("D")=$P(SRA(0),"^",9) D IN5^VADPT S SRSTATUS=$S(VAIP(13):"I",1:"O") K VAIP + S SRAGE="" I $P(VADM(3),"^") S SRAGE=$E(DATE,1,3)-$E($P(VADM(3),"^"),1,3)-($E(DATE,4,7)<$E($P(VADM(3),"^"),4,7)) + S SRASA="",Y=$P($G(^SRF(SRTN,1.1)),"^",3) S:Y X=$P($P($G(^SRO(132.8,Y,0)),"^"),"-"),SRASA=$E(X,1,2) + ; Admission wi 14 days following outpatient surgery due to an Occurrence + S (SRADMIT,SRADMT)=0 I SRSTATUS="O" D ADM^SROQ0A S SRADMIT=$S(SRADMT=0:"0",1:"1") + S EXC=$P($G(^SRF(SRTN,"RA")),"^",7),SRWOUND=$P($G(^SRF(SRTN,"1.0")),"^",8) + D OCC + S SRNODE=" X" S:$P($G(^SRF(SRTN,"RA")),U,6)="N" SRNODE=" *" S:$P($G(^SRF(SRTN,"RA")),U,2)="C" SRNODE=" C" + S SRTEMP="/"_$J(SRASITE,3)_$J(SRTN,7)_SRNODE_DATE_$J(SRTECH,3)_$J(EMERG,1)_$J(SPEC,3)_$J(CPT,5)_$J(EXC,1)_$J(SRPID,20)_$J(SRDIV,6)_" " + S SRTEMP=SRTEMP_$J(SRMAJMIN,1)_$J($E(SRDEATH,1,7),7)_$J(SRDTHUR,1)_$J(SRSTATUS,1)_$J(SRAGE,3)_$J(SRASA,2)_$J(SRADMIT,1)_SRTMP + K CPT,SRMOD F SRZ=1:1:10 S (CPT(SRZ),SRMOD(SRZ))="" + S (OPS,CNT)=0 F S OPS=$O(^SRO(136,SRTN,3,OPS)) Q:'OPS!(CNT=10) S CNT=CNT+1,X=$P($G(^SRO(136,SRTN,3,OPS,0)),"^") I X S CPT(CNT)=$P($$CPT^ICPTCOD(X),"^",2) D MOD + S SRCC=$P($G(^SRF(SRTN,"CON")),"^"),SRBLANK=" " + I SRCC,$P($G(^SRF(SRCC,30)),"^")!($P($G(^SRF(SRCC,31)),"^",8)) S SRCC="" + S SRTEMP=SRTEMP_$J(CPT(1),5)_$J(CPT(2),5)_$J(CPT(3),5)_$J(CPT(4),5)_$J(CPT(5),5)_$J(CPT(6),5)_$J(CPT(7),5)_$J(CPT(8),5)_$J(CPT(9),5)_$J(CPT(10),5)_$J(SRWOUND,2)_$J(SROCTYPE,1)_SRBLANK_$J(SRCC,10)_$J(SRDEATH,12) + S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SRTEMP,SRACNT=SRACNT+1 + S SRICD=$P($G(^SRO(136,SRTN,0)),"^",3) S:SRICD SRICD=$P(^ICD9(SRICD,0),"^") + S SRA(.2)=$G(^SRF(SRTN,.2)) + S SRTEMP="/"_$J(SRASITE,3)_$J(SRTN,7)_" B"_$J($E($P(SRA(.2),"^"),1,12),12)_$J($E($P(SRA(.2),"^",4),1,12),12)_$E(SRPMOD_SR10SP,1,10) + F I=1:1:10 S SRTEMP=SRTEMP_$E(SRMOD(I)_SR10SP,1,10) + S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SRTEMP_$J(SRINTUB,1)_SR95PO_$J(SRATT,2)_$J(SRDOB,7)_$J(SRICD,6)_$J(SROC(38),2),SRACNT=SRACNT+1 + I SRACNT>100 S SRACNT=1,SRAMNUM=SRAMNUM+1 + S SRATOT=SRATOT+1 + S X=$E($P(^SRF(SRTN,0),"^",9),1,5)_"00",^TMP("SRWL",$J,X)="" + K DATE,ANES,EMERG,EXC,SPEC,SRADMIT,SRADMT,SRATT,SRBLANK,SRCC,SRDIV,SRDOB,SRDTHUR,SRICD,SRIO,SRMAJMIN,SROCTYPE,SRTEMP,SRTMP,SRWOUND,SRZ,SR14,CPT + Q +OCC ; total of each occurrence by category + N SRIOFLAG,SRPOFLAG + F SRK=1:1:38 S SROC(SRK)="" + S (SRPO,SRIOFLAG)=0 F S SRPO=$O(^SRF(SRTN,10,SRPO)) Q:'SRPO S SRSUB=$P(^SRF(SRTN,10,SRPO,0),U,2) I SRSUB'="" D + .S SROC(SRSUB)=SROC(SRSUB)+1,SRIOFLAG=1 + S (SRPO,SRPOFLAG)=0 F S SRPO=$O(^SRF(SRTN,16,SRPO)) Q:'SRPO S SRSUB=$P(^SRF(SRTN,16,SRPO,0),U,2) I SRSUB'="" D + .S SROC(SRSUB)=SROC(SRSUB)+1,SRPOFLAG=1 + S (SROCTYPE,SRTMP)="" F SRK=1:1:10 S SRTMP=SRTMP_$J(SROC(SRK),2) + S SRTMP=SRTMP_$J(SROC(37),2) F SRK=12:1:32 S SRTMP=SRTMP_$J(SROC(SRK),2) + S SR95PO=$J(SROC(33),2)_$J(SROC(34),2)_$J(SROC(35),2)_$J(SROC(36),2) + I SRIOFLAG=1,(SRPOFLAG=0) S SROCTYPE="I" + I SRIOFLAG=0,(SRPOFLAG=1) S SROCTYPE="P" + I SRIOFLAG=1,(SRPOFLAG=1) S SROCTYPE="B" + I SRIOFLAG=0,(SRPOFLAG=0) S SROCTYPE="" + Q +MOD N SRM S SRM=0,SRCNT=1 F S SRM=$O(^SRO(136,SRTN,3,OPS,1,SRM)) Q:'SRM D Q:SRCNT>5 + .S X=$P(^SRO(136,SRTN,3,OPS,1,SRM,0),"^"),Y=$P($$MOD^ICPTMOD(X,"I"),"^",2) + .I Y'="" S SRMOD(CNT)=SRMOD(CNT)_Y,SRCNT=SRCNT+1 + Q diff --git a/r/SURGERY-SR/SROAUTL.m b/r/SURGERY-SR/SROAUTL.m index 63bc8854..9cb6e8d1 100644 --- a/r/SURGERY-SR/SROAUTL.m +++ b/r/SURGERY-SR/SROAUTL.m @@ -1,107 +1,107 @@ -SROAUTL ;BIR/ADM - RISK ASSESSMENT UTILITY ;03/03/08 - ;;3.0; Surgery ;**38,46,47,63,81,88,95,112,100,125,134,142,153,160,166**;24 Jun 93;Build 7 - I $G(SRSUPCPT)=2 G NCODE - N SRCMOD,SRCOMMA,X K SRHDR S DFN=$P(^SRF(SRTN,0),"^") D DEM^VADPT S SRHDR=VADM(1)_" ("_VA("PID")_") Case #"_SRTN - S Y=$E($P(^SRF(SRTN,0),"^",9),1,7) X ^DD("DD") S SRSDATE=Y - S X=^SRF(SRTN,"OP"),SROPER=$P(X,"^"),Y=$P(X,"^",2),SRCPT=$S(Y:$P($$CPT^ICPTCOD(Y),"^",2),1:"CPT MISSING") I SRCPT,$O(^SRF(SRTN,"OPMOD",0)) D - .S (SRCOMMA,SRI)=0,SRCMOD="",SRCPT=SRCPT_"-" F S SRI=$O(^SRF(SRTN,"OPMOD",SRI)) Q:'SRI D - ..S SRM=$P(^SRF(SRTN,"OPMOD",SRI,0),"^"),SRCMOD=$P($$MOD^ICPTMOD(SRM,"I"),"^",2) - ..S SRCPT=SRCPT_$S(SRCOMMA:",",1:"")_SRCMOD,SRCOMMA=1 - S SRCPT=$S($G(SRSUPCPT)=1:"",1:"("_SRCPT_")") - S SROPER=SROPER_" "_SRCPT D LOOP S SRHDR(1)=SRSDATE_" "_SRHDR(1) - Q -NCODE N SRCMOD,SRCOMMA,X K SRHDR S DFN=$P(^SRF(SRTN,0),"^") D DEM^VADPT S SRHDR=VADM(1)_" ("_VA("PID")_") Case #"_SRTN - S Y=$E($P(^SRF(SRTN,0),"^",9),1,7) X ^DD("DD") S SRSDATE=Y - S X=^SRF(SRTN,"OP"),SROPER=$P(X,"^"),Y=$P($G(^SRO(136,SRTN,0)),"^",2),SRCPT=$S(Y:$P($$CPT^ICPTCOD(Y),"^",2),1:"CPT MISSING") I SRCPT,$O(^SRO(136,SRTN,1,0)) D - .S (SRCOMMA,SRI)=0,SRCMOD="",SRCPT=SRCPT_"-" F S SRI=$O(^SRO(136,SRTN,1,SRI)) Q:'SRI D - ..S SRM=$P(^SRO(136,SRTN,1,SRI,0),"^"),SRCMOD=$P($$MOD^ICPTMOD(SRM,"I"),"^",2) - ..S SRCPT=SRCPT_$S(SRCOMMA:",",1:"")_SRCMOD,SRCOMMA=1 - S SRCPT="(CPT Code: "_SRCPT_")" - S SROPER=SROPER_" "_SRCPT D LOOP S SRHDR(1)=SRSDATE_" "_SRHDR(1) - Q -LOOP I $L(SROPER)<68 S SRHDR(1)=SROPER Q - I $L(SROPER)>67 S X=SROPER,K=1 F D I $L(X)<68 S SRHDR(K)=X Q - .F I=0:1:66 S J=67-I,Y=$E(X,J) I Y=" " S SRHDR(K)=$E(X,1,J-1),X=$E(X,J+1,$L(X)) S K=K+1 Q - Q -HDR ; print screen header - W @IOF,!,SRHDR W:$G(SRPAGE)'="" ?(79-$L(SRPAGE)),SRPAGE - S I=0 F S I=$O(SRHDR(I)) Q:'I W !,SRHDR(I) I I=.5,$L($G(SRCSTAT)) W ?(79-$L(SRCSTAT)),SRCSTAT - W:$D(SRCSTAT)&'$D(SRHDR(.5)) !,SRCSTAT - K SRHDR(.5),SRCSTAT,SRPAGE W ! F I=1:1:80 W "-" - W ! - Q -FUNCT() ; called by screen on functional health status field (#240) - N SRSCR S SRSCR="I 1" - I $$CARD S SRSCR="I Y'=4" - Q SRSCR -CARD() ; is this a cardiac assessed case? - N SRX S SRX=$S($D(SRTN):SRTN,$D(DA):DA,1:"") I 'SRX Q 0 - I $P($G(^SRF(SRX,"RA")),"^",2)="C" Q 1 - Q 0 -NC ; called from input transform to kill X if case is cardiac assessed - I $$CARD,X="NA"!(X="NS") K X - Q -DATE ; called by output transform on several date fields - I $D(Y),Y="NA"!(Y="NS") Q - N SRY S SRY=Y D DD^%DT - Q -INDX ; set airway index - S SRY=$S(SRI>4:5,SRI>3:4,SRI>2:3,SRI>0:2,1:1),$P(^SRF(DA,.3),"^",9)=SRY - K SRI,SRMS,SROP,SRY - Q -OP ; set logic for AOP cross reference on Oral-Pharyngeal field (901.1) - N SRI,SRMS,SRY S SRMS=$P(^SRF(DA,.3),"^",12) I SRMS'="" S SRMS=SRMS*.1,SRI=2.5*X-SRMS D INDX - Q -MS ; set logic for AMS cross reference on Mandibular Space field (901.2) - N SRI,SRY,SRMS,SROP S SROP=$P(^SRF(DA,.3),"^",11) I SROP'="" S SRMS=X*.1,SRI=2.5*SROP-SRMS D INDX - Q -K901 ; kill logic for AOP and AMS cross references - S $P(^SRF(DA,.3),"^",9)="" - Q -DUP ; duplicate preop information from prior operation within 60 days - S SR200=$G(^SRF(SRTN,200)) S NOGO="" F I=1,9,13,18,30,37,44 S X=$P(SR200,"^",I) I X'="" S NOGO=1 K SR200 Q - S X=$P($G(^SRF(SRTN,200.1)),"^") I X'="" S NOGO=1 - I NOGO K NOGO Q - K SRCASE S SR=^SRF(SRTN,0),DFN=$P(SR,"^"),(SRSDATE,X1)=$P(SR,"^",9),X2=-60 D C^%DTC S SRENDT=X,SRCASE=0 F S SRCASE=$O(^SRF("B",DFN,SRCASE)) Q:'SRCASE I SRCASE,SRCASE'=SRTN D - .S SRX=$P(^SRF(SRCASE,0),"^",9) I SRX>SRSDATE!(SRX67 S X=SROPER,K=1 F D I $L(X)<68 S SRHDR(K)=X Q + .F I=0:1:66 S J=67-I,Y=$E(X,J) I Y=" " S SRHDR(K)=$E(X,1,J-1),X=$E(X,J+1,$L(X)) S K=K+1 Q + Q +HDR ; print screen header + W @IOF,!,SRHDR W:$G(SRPAGE)'="" ?(79-$L(SRPAGE)),SRPAGE + S I=0 F S I=$O(SRHDR(I)) Q:'I W !,SRHDR(I) I I=.5,$L($G(SRCSTAT)) W ?(79-$L(SRCSTAT)),SRCSTAT + W:$D(SRCSTAT)&'$D(SRHDR(.5)) !,SRCSTAT + K SRHDR(.5),SRCSTAT,SRPAGE W ! F I=1:1:80 W "-" + W ! + Q +FUNCT() ; called by screen on functional health status field (#240) + N SRSCR S SRSCR="I 1" + I $$CARD S SRSCR="I Y'=4" + Q SRSCR +CARD() ; is this a cardiac assessed case? + N SRX S SRX=$S($D(SRTN):SRTN,$D(DA):DA,1:"") I 'SRX Q 0 + I $P($G(^SRF(SRX,"RA")),"^",2)="C" Q 1 + Q 0 +NC ; called from input transform to kill X if case is cardiac assessed + I $$CARD,X="NA"!(X="NS") K X + Q +DATE ; called by output transmform on several date fields + I $D(Y),Y="NA"!(Y="NS") Q + N SRY S SRY=Y D DD^%DT + Q +INDX ; set airway index + S SRY=$S(SRI>4:5,SRI>3:4,SRI>2:3,SRI>0:2,1:1),$P(^SRF(DA,.3),"^",9)=SRY + K SRI,SRMS,SROP,SRY + Q +OP ; set logic for AOP cross reference on Oral-Pharyngeal field (901.1) + N SRI,SRMS,SRY S SRMS=$P(^SRF(DA,.3),"^",12) I SRMS'="" S SRMS=SRMS*.1,SRI=2.5*X-SRMS D INDX + Q +MS ; set logic for AMS cross reference on Mandibular Space field (901.2) + N SRI,SRY,SRMS,SROP S SROP=$P(^SRF(DA,.3),"^",11) I SROP'="" S SRMS=X*.1,SRI=2.5*SROP-SRMS D INDX + Q +K901 ; kill logic for AOP and AMS cross references + S $P(^SRF(DA,.3),"^",9)="" + Q +DUP ; duplicate preop information from prior operation within 60 days + S SR200=$G(^SRF(SRTN,200)) S NOGO="" F I=1,9,13,18,30,37,44 S X=$P(SR200,"^",I) I X'="" S NOGO=1 K SR200 Q + S X=$P($G(^SRF(SRTN,200.1)),"^") I X'="" S NOGO=1 + I NOGO K NOGO Q + K SRCASE S SR=^SRF(SRTN,0),DFN=$P(SR,"^"),(SRSDATE,X1)=$P(SR,"^",9),X2=-60 D C^%DTC S SRENDT=X,SRCASE=0 F S SRCASE=$O(^SRF("B",DFN,SRCASE)) Q:'SRCASE I SRCASE,SRCASE'=SRTN D + .S SRX=$P(^SRF(SRCASE,0),"^",9) I SRX>SRSDATE!(SRX 2 Drinks/Day^ -CBE ;;325^Dyspnea^Dyspnea^ -BCH ;;238^DNR Status (Y/N)^DNR Status^ -DIB ;;492^Functional Health Status at Evaluation for Surgery^Preop Functional Status -BJD ;;204^Ventilator Dependent Greater than 48 Hrs (Y/N)^Ventilator Dependent^ -BJC ;;203^History of COPD (Y/N)^History of Severe COPD^ -CBF ;;326^Current Pneumonia (Y/N)^Current Pneumonia^ -BAB ;;212^Ascites (Y/N)^Ascites^ -CIF ;;396^CHF within One Month Preceding Surgery (Y/N)^CHF Within 1 Month^ -CBH ;;328^Acute Renal Failure (Y/N)^Acute Renal Failure^ -BAA ;;211^Currently on Dialysis (Y/N)^Currently on Dialysis^ -CCB ;;332^Impaired Sensorium (Y/N)^Impaired Sensorium^ -CCC ;;333^Coma (Y/N)^Coma^ -DJJ ;;400^Hemiplegia (Y/N)^Hemiplegia^ -CCD ;;334^History of TIAs (Y/N)^History of TIAs^ -CCE ;;335^CVA/Residual Neurologic Deficit (Y/N)^CVA/Residual Neuro Deficit^ -CCF ;;336^CVA/No Neurologic Deficit (Y/N)^CVA/No Neuro Deficit^ -DJA ;;401^Tumor Involving CNS (Y/N)^Tumor Involving CNS^ -CCH ;;338^Disseminated Cancer (Y/N)^Disseminated Cancer^ -BAH ;;218^Open Wound or Skin Infection (Y/N)^Open Wound or Infection^ -CCI ;;339^Steroid Use for Chronic Condition (Y/N)^Steroid Use for Chronic Cond.^ -BAE ;;215^Weight Loss > 10% of Usual Body Weight (Y/N)^Weight Loss > 10%^ -BAF ;;216^History of Bleeding Disorders (Y/N)^Bleeding Disorders^ -BAG ;;217^Transfusion Greater than 4 RBC Units this Admission (Y/N)^Transfusion > 4 RBC Units^ -CCHPA ;;338.1^Chemotherapy Within Last 30 Days (Y/N)^Chemotherapy W/I 30 Days^ -CCHPB ;;338.2^Radiotherapy Within Last 90 Days (Y/N)^Radiotherapy W/I 90 Days^ -BAHPA ;;218.1^Preoperative Sepsis (Y/N)^Preoperative Sepsis^ -BFI ;;269^Pregnancy Status^Pregnancy Status^ -DAC ;;413^Transfer Status^Transfer Status^ -PJAA ;;.011^In/Out-Patient Status -BDG ;;247^Length of Postoperative Hospital Stay -CDB ;;342^Date/Time of Death^Date/Time of Death -DAG ;;417^Patient's Race -DAH ;;418^Hospital Admission Date -DAI ;;419^Hospital Discharge Date -DBJ ;;420^Admitted/Transferred to Surgical Service -DBA ;;421^Discharged/Transferred to Chronic Care -DEB ;;452^Observation Admission Date/Time -DEC ;;453^Observation Discharge Date/Time -DED ;;454^Observation Treating Specialty -EAC ;;513^Surgery Consult Date -EAF ;;516^Date Surgery Consult Requested +SROAUTL1 ;BIR/ADM - RISK ASSESSMENT UTILITY ;04/24/07 + ;;3.0; Surgery ;**38,47,81,125,153,160**;24 Jun 93;Build 7 + S SRZ=0 F S SRZ=$O(SRY(130,SRTN,SRZ)) Q:'SRZ I SRY(130,SRTN,SRZ,"I")="" D TR S X=$T(@SRP),SRFLD=$P(X,";;",2),SRX(SRZ)=$P(SRFLD,"^",2) + Q +TR S SRP=SRZ,SRP=$TR(SRP,"1234567890.","ABCDEFGHIJP") + Q +GET S X=$T(@J) + Q +BJH ;;208^History of Hypertension Requiring Medication (Y/N)^Hypertension Requiring Meds^ +BAC ;;213^Esophageal Varices (Y/N)^Esophogeal Varices^ +BBJ ;;220^Previous PCI (Y/N)^Previous PCI^ +BFF ;;266^Previous Cardiac Surgery (Y/N)^Previous Cardiac Surgery^ +CBI ;;329^History of Revascularization/Amputation for PVD (Y/N)^Revascularization/Amputation^ +CCJ ;;330^Rest Pain/Gangrene (Y/N)^Rest Pain/Gangrene^ +CID ;;394^History of MI Within Past 6 Months (Y/N)^MI Within 6 Months^ +CIE ;;395^Angina within One Month Preceding Surgery (Y/N)^Angina Within 1 Month^ +CIH ;;398^Quadriplegia/Tetraplegia/Quadriparesis (Y/N)^Quadriplegia^ +CII ;;399^Paraplegia (Y/N)^Paraplegia^ +BCF ;;236^Patient's Height^Height^ +BCG ;;237^Patient's Weight^Weight^ +CDF ;;346^Diabetes^Diabetes Mellitus^ +BJB ;;202^Current Smoker within 1 Year prior to Surgery (Y/N)^Current SmokerW/I 1 Year^ +BJBPA ;;202.1^Pack/Years^Pack/Years^ +BDF ;;246^ETOH Greater than 2 Drinks/Day (Y/N)^ETOH > 2 Drinks/Day^ +CBE ;;325^Dyspnea^Dyspnea^ +BCH ;;238^DNR Status (Y/N)^DNR Status^ +BDJ ;;240^Functional Health Status Prior to Current Illness^Pre-Illness Functional Status^ +DIB ;;492^Functional Health Status at Evaluation for Surgery^Preop Functional Status +BJD ;;204^Ventilator Dependent Greater than 48 Hrs (Y/N)^Ventilator Dependent^ +BJC ;;203^History of COPD (Y/N)^History of Severe COPD^ +CBF ;;326^Current Pneumonia (Y/N)^Current Pneumonia^ +BAB ;;212^Ascites (Y/N)^Ascites^ +CIF ;;396^CHF within One Month Preceding Surgery (Y/N)^CHF Within 1 Month^ +CBH ;;328^Acute Renal Failure (Y/N)^Acute Renal Failure^ +BAA ;;211^Currently on Dialysis (Y/N)^Currently on Dialysis^ +CCB ;;332^Impaired Sensorium (Y/N)^Impaired Sensorium^ +CCC ;;333^Coma (Y/N)^Coma^ +DJJ ;;400^Hemiplegia (Y/N)^Hemiplegia^ +CCD ;;334^History of TIAs (Y/N)^History of TIAs^ +CCE ;;335^CVA/Residual Neurologic Deficit (Y/N)^CVA/Residual Neuro Deficit^ +CCF ;;336^CVA/No Neurologic Deficit (Y/N)^CVA/No Neuro Deficit^ +DJA ;;401^Tumor Involving CNS (Y/N)^Tumor Involving CNS^ +CCH ;;338^Disseminated Cancer (Y/N)^Disseminated Cancer^ +BAH ;;218^Open Wound or Skin Infection (Y/N)^Open Wound or Infection^ +CCI ;;339^Steroid Use for Chronic Condition (Y/N)^Steroid Use for Chronic Cond.^ +BAE ;;215^Weight Loss > 10% of Usual Body Weight (Y/N)^Weight Loss > 10%^ +BAF ;;216^History of Bleeding Disorders (Y/N)^Bleeding Disorders^ +BAG ;;217^Transfusion Greater than 4 RBC Units this Admission (Y/N)^Transfusion > 4 RBC Units^ +CCHPA ;;338.1^Chemotherapy Within Last 30 Days (Y/N)^Chemotherapy W/I 30 Days^ +CCHPB ;;338.2^Radiotherapy Within Last 90 Days (Y/N)^Radiotherapy W/I 90 Days^ +BAHPA ;;218.1^Preoperative Sepsis (Y/N)^Preoperative Sepsis^ +BFI ;;269^Pregnancy Status^Pregnancy Status^ +DAC ;;413^Transfer Status^Transfer Status^ +PJAA ;;.011^In/Out-Patient Status +BDG ;;247^Length of Postoperative Hospital Stay +CDB ;;342^Date/Time of Death^Date/Time of Death +DAG ;;417^Patient's Race +DAH ;;418^Hospital Admission Date +DAI ;;419^Hospital Discharge Date +DBJ ;;420^Admitted/Transferred to Surgical Service +DBA ;;421^Discharged/Transferred to Chronic Care +DEB ;;452^Observation Admission Date/Time +DEC ;;453^Observation Discharge Date/Time +DED ;;454^Observation Treating Specialty diff --git a/r/SURGERY-SR/SROAUTL3.m b/r/SURGERY-SR/SROAUTL3.m index 09fd6e08..146c9fca 100644 --- a/r/SURGERY-SR/SROAUTL3.m +++ b/r/SURGERY-SR/SROAUTL3.m @@ -1,52 +1,51 @@ -SROAUTL3 ;BIR/ADM - RISK ASSESSMENT UTILITY ;01/07/08 - ;;3.0; Surgery ;**38,47,63,77,142,163,166**;24 Jun 93;Build 7 - ; - ; Reference to ^DIC(45.3 supported by DBIA #218 - ; - Q -RISK ; allow entry of risk assessment preop information with case request - S Y=$P(^SRO(133,SRSITE,0),"^",14) I 'Y Q - W ! K DIR S DIR("A")="Enter risk assessment preop information for this patient (Y/N)",DIR(0)="Y",DIR("B")="YES" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT)!'Y Q - S SREQST=1,SRCARD=0 I $$CARD^SROAUTLC S SRSP=$P(^DIC(45.3,$P(^SRO(137.45,$P(^SRF(SRTN,0),"^",4),0),"^",2),0),"^") I SRSP=48!(SRSP=58) D I SRCARD Q - .S SRCARD=1 W ! K DIR S DIR("A")="Will this procedure require cardiopulmonary bypass (Y/N) ? ",DIR(0)="YA" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) Q - .I 'Y S SRCARD=0 Q - .D CARD S SRCARD=1 - I 'SRCARD D ^SROAPRE - Q -CARD ; allow input of cardiac risk assessment preop information - N SRSDATE,SRNM,SRSOUT - W @IOF,!,"Enter Cardiac Preoperative information",!!," 1. Clinical Information",!," 2. Cardiac Catheterization & Angiographic Data",!," 3. Operative Risk Summary Data",! - K DIR S DIR(0)="NO^1:3:0",DIR("?")="Enter the number of the selection to be edited." D ^DIR K DIR I $D(DTOUT)!$D(DUOUT)!'Y Q - I Y=1 D ^SROACLN G CARD - I Y=2 D ^SROACAT G CARD - D ^SROACOP G CARD - Q -PREOP ; print preop information (managerial) - W:$E(IOST)="P" !! D PREOP^SROAUTL0 S SRDR=DR W !,?28,"PREOPERATIVE INFORMATION",! S SRQ=1 D OUT - Q -OUT K DA,DIC,DIQ,SRY S DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="E",DR=SRDR D EN^DIQ1 K DA,DIC,DIQ,DR - K SRX S SRX=0 F M=1:1 S I=$P(SRDR,";",M) Q:'I D - .Q:I=413 D TR D:SRQ GET^SROAUTL1 D:'SRQ GET^SROAUTL2 - .S SRX=SRX+1,Y=$P(X,";;",2),SRFLD=$P(Y,"^"),(Z,SRX(SRX))=$S($P(Y,"^",3)'="":$P(Y,"^",3),1:$P(Y,"^",2))_"^"_SRFLD - .W !,$J($P(Z,"^")_": ",39) S SREXT=SRY(130,SRTN,SRFLD,"E") D EXT - Q -EXT I SRFLD=27 S SREXT=$S(SREXT="":"MISSING",1:$E(SREXT,1,5)) - I $L(SREXT)<40 W SREXT Q - N I,J,X,Y S X=SREXT F D W:$L(X) ! I $L(X)<40!(X'[" ") W ?40,X Q - .F I=0:1:38 S J=39-I,Y=$E(X,J) I Y=" " W ?40,$E(X,1,J-1) S X=$E(X,J+1,$L(X)) Q - Q -LAB ; print preoperative laboratory test information (managerial) - W !,?20,"PREOPERATIVE LABORATORY TEST INFORMATION",! - D LR^SROAUTL0 S SRDR=DR K DA,DIC,DIQ,SRY S DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="E",DR=SRDR D EN^DIQ1 K DA,DIC,DIQ,DR - K SRX S SRX=0 F M=1:2 S L=$P(SRDR,";",M) Q:'L S I=L D - .D TR D GET^SROAUTL2 S SRX=SRX+1,Y=$P(X,";;",2),SRFLD=$P(Y,"^"),SRDT=$P(Y,"^",4),(Z,SRX(SRX))=$S($P(Y,"^",3)'="":$P(Y,"^",3),1:$P(Y,"^",2))_"^"_SRFLD_"^"_SRDT - .W !,$J($P(Z,"^")_": ",39),SRY(130,SRTN,SRFLD,"E") W:SRY(130,SRTN,SRDT,"E")'="" ?50,"("_$P(SRY(130,SRTN,SRDT,"E"),"@")_")" - Q -TR S J=I,J=$TR(J,"1234567890.","ABCDEFGHIJP") - Q -NON S DR=".03;102;.035" - Q -CHK ; check for missing information for excluded cases - K SRX,DA,DIC,DIQ,DR,SRY S DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="I" D NON D EN^DIQ1 D ^SROAUTL2 - K DA,DIC,DIQ,DR,SRY,SRZ D TECH^SROPRIN I SRTECH="NOT ENTERED" S SRX("ANESTHESIA TECHNIQUE")="Anesthesia Technique" - Q +SROAUTL3 ;BIR/ADM - RISK ASSESSMENT UTILITY ;08/16/07 + ;;3.0; Surgery ;**38,47,63,77,142,163**;24 Jun 93;Build 2 + ; + ; Reference to ^DIC(45.3 supported by DBIA #218 + ; + Q +RISK ; allow entry of risk assessment preop information with case request + S Y=$P(^SRO(133,SRSITE,0),"^",14) I 'Y Q + W ! K DIR S DIR("A")="Enter risk assessment preop information for this patient (Y/N)",DIR(0)="Y",DIR("B")="YES" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT)!'Y Q + S SREQST=1,SRCARD=0 I $$CARD^SROAUTLC S SRSP=$P(^DIC(45.3,$P(^SRO(137.45,$P(^SRF(SRTN,0),"^",4),0),"^",2),0),"^") I SRSP=48!(SRSP=58) D I SRCARD Q + .S SRCARD=1 W ! K DIR S DIR("A")="Will this procedure require cardiopulmonary bypass (Y/N) ? ",DIR(0)="YA" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) Q + .I 'Y S SRCARD=0 Q + .D CARD S SRCARD=1 + I 'SRCARD D ^SROAPRE + Q +CARD ; allow input of cardiac risk assessment preop information + W @IOF,!,"Enter Cardiac Preoperative information",!!," 1. Clinical Information",!," 2. Cardiac Catheterization & Angiographic Data",!," 3. Operative Risk Summary Data",! + K DIR S DIR(0)="NO^1:3:0",DIR("?")="Enter the number of the selection to be edited." D ^DIR K DIR I $D(DTOUT)!$D(DUOUT)!'Y Q + I Y=1 D ^SROACLN G CARD + I Y=2 D ^SROACAT G CARD + D ^SROACOP G CARD + Q +PREOP ; print preop information (managerial) + W:$E(IOST)="P" !! D PREOP^SROAUTL0 S SRDR=DR W !,?28,"PREOPERATIVE INFORMATION",! S SRQ=1 D OUT + Q +OUT K DA,DIC,DIQ,SRY S DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="E",DR=SRDR D EN^DIQ1 K DA,DIC,DIQ,DR + K SRX S SRX=0 F M=1:1 S I=$P(SRDR,";",M) Q:'I D + .Q:I=413 D TR D:SRQ GET^SROAUTL1 D:'SRQ GET^SROAUTL2 + .S SRX=SRX+1,Y=$P(X,";;",2),SRFLD=$P(Y,"^"),(Z,SRX(SRX))=$S($P(Y,"^",3)'="":$P(Y,"^",3),1:$P(Y,"^",2))_"^"_SRFLD + .W !,$J($P(Z,"^")_": ",39) S SREXT=SRY(130,SRTN,SRFLD,"E") D EXT + Q +EXT I SRFLD=27 S SREXT=$S(SREXT="":"MISSING",1:$E(SREXT,1,5)) + I $L(SREXT)<40 W SREXT Q + N I,J,X,Y S X=SREXT F D W:$L(X) ! I $L(X)<40!(X'[" ") W ?40,X Q + .F I=0:1:38 S J=39-I,Y=$E(X,J) I Y=" " W ?40,$E(X,1,J-1) S X=$E(X,J+1,$L(X)) Q + Q +LAB ; print preoperative laboratory test information (managerial) + W !,?20,"PREOPERATIVE LABORATORY TEST INFORMATION",! + D LR^SROAUTL0 S SRDR=DR K DA,DIC,DIQ,SRY S DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="E",DR=SRDR D EN^DIQ1 K DA,DIC,DIQ,DR + K SRX S SRX=0 F M=1:2 S L=$P(SRDR,";",M) Q:'L S I=L D + .D TR D GET^SROAUTL2 S SRX=SRX+1,Y=$P(X,";;",2),SRFLD=$P(Y,"^"),SRDT=$P(Y,"^",4),(Z,SRX(SRX))=$S($P(Y,"^",3)'="":$P(Y,"^",3),1:$P(Y,"^",2))_"^"_SRFLD_"^"_SRDT + .W !,$J($P(Z,"^")_": ",39),SRY(130,SRTN,SRFLD,"E") W:SRY(130,SRTN,SRDT,"E")'="" ?50,"("_$P(SRY(130,SRTN,SRDT,"E"),"@")_")" + Q +TR S J=I,J=$TR(J,"1234567890.","ABCDEFGHIJP") + Q +NON S DR=".03;102;.035" + Q +CHK ; check for missing information for excluded cases + K SRX,DA,DIC,DIQ,DR,SRY S DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="I" D NON D EN^DIQ1 D ^SROAUTL2 + K DA,DIC,DIQ,DR,SRY,SRZ D TECH^SROPRIN I SRTECH="NOT ENTERED" S SRX("ANESTHESIA TECHNIQUE")="Anesthesia Technique" + Q diff --git a/r/SURGERY-SR/SROAUTL4.m b/r/SURGERY-SR/SROAUTL4.m index 45a1df01..a9801ae0 100644 --- a/r/SURGERY-SR/SROAUTL4.m +++ b/r/SURGERY-SR/SROAUTL4.m @@ -1,127 +1,122 @@ -SROAUTL4 ;BIR/ADM - RISK ASSESSMENT UTILITY ;01/10/08 - ;;3.0; Surgery ;**38,71,95,125,153,160,164,166**;24 Jun 93;Build 7 - N SRZZ,SRXX,SRX1 - S SRZ=0 F S SRZ=$O(SRY(130,SRTN,SRZ)) Q:'SRZ D - .I SRY(130,SRTN,SRZ,"I")="" D TR S (SRX1,X)=$T(@SRP),SRFLD=$P(X,";;",2) D - ..I SRZ=513,$P(^SRF(SRTN,0),"^",9)<3071001 Q - ..I SRZ=515 S X1=$P(^SRF(SRTN,0),"^",9),X2=$P($G(^SRF(SRTN,209)),"^",15) D ^%DTC I X'>30 Q - ..I SRZ=484,$P($G(^SRF(SRTN,209)),"^",13)'="Y" Q - ..S X=SRX1,SRX(SRZ)=$P(SRFLD,"^",2)_"^"_$P(X,";;",3) - .I SRY(130,SRTN,SRZ,"I")="NS" D TR S X=$T(@SRP),SRFLD=$P(X,";;",2),SRDT=$P(SRFLD,"^",4) S:SRDT'="" SRLR(SRDT)="" - S SRDT=0 F S SRDT=$O(SRLR(SRDT)) Q:'SRDT K SRX(SRDT) - Q -RED M SRZZ=SRX S SRZ=0 F S SRZ=$O(SRX(SRZ)) Q:'SRZ S SRZZ=$P($G(SRX(SRZ)),"^",2),SRXX(SRZZ)=$P($G(SRX(SRZ)),"^")_":"_SRZ - K SRX M SRX=SRXX K SRXX - Q -TR S SRP=SRZ,SRP=$TR(SRP,"1234567890.","ABCDEFGHIJP") - Q -GET S X=$T(@J) - Q -BCF ;;236^Patient's Height^Height^;;1-01 -BCG ;;237^Patient's Weight^Weight^;;1-02 -DGE ;;475^Diabetes (Cardiac);;1-03 -BJC ;;203^History of COPD (Y/N)^COPD^;;1-04 -CDG ;;347^FEV1^FEV1^;;1-05 -BJI ;;209^Cardiomegaly on Chest X-Ray (Y/N)^Cardiomegaly (X-ray)^;;1-06 -CDH ;;348^Pulmonary Rales (Y/N)^Pulmonary Rales^;;1-07 -EAJ ;;510^Current Smoker^Current Smoker^;;1-08 -CDI ;;349^Active Endocarditis (Y/N)^Active Endocarditis^;;1-09 -CEJ ;;350^Resting ST Depression (Y/N)^Resting ST Depression^;;1-10 -BDJ ;;240^Functional Health Status^Functional Status^;;1-11 -CEA ;;351^PCI Status^PCI^;;1-12 -BJE ;;205^Prior Myocardial Infarction^Prior MI^;;1-13 -CEB ;;352^Number of Prior Heart Surgeries^Number of Prior Heart Surgeries^;;1-14 -DHE ;;485^Prior Heart Surgeries;;1-15 -BFE ;;265^Peripheral Vascular Disease (Y/N)^Peripheral Vascular Disease^;;1-16 -BFD ;;264^Cerebral Vascular Disease (Y/N)^Cerebral Vascular Disease^;;1-17 -BFG ;;267^Angina (use NYHA Functional Class)^Angina (use CCS Class)^;;1-18 -BJG ;;207^Congestive Heart Failure (use NYHA Functional Class)^CHF (use NYHA Class)^;;1-19 -CEC ;;353^Current Diuretic Use (Y/N)^Current Diuretic Use^;;1-20 -CED ;;354^Current Digoxin Use (Y/N)^Current Digoxin Use^;;1-21 -CEE ;;355^IV NTG within 48 Hours Preceding Surgery (Y/N)^IV NTG within 48 Hours^;;1-22 -DGD ;;474^Preop use of circulatory Device;;1-23 -DFC ;;463^Hypertension^;;1-24 -DEG ;;457^HDL^^457.1;;2-01 -DEGPA ;;457.1^HDL, Date;;2-02 -DFA ;;461^LDL^^461.1;;2-03 -DFAPA ;;461.1^LDL, Date;;2-04 -DFB ;;462^Total Cholesterol^^462.1;;2-05 -DFBPA ;;462.1^Total Cholesterol, Date;;2-06 -DEH ;;458^Serum Triglyceride^^458.1;;2-07 -DEHPA ;;458.1^Serum Triglyceride, Date;;2-08 -DEI ;;459^Serum Potassium^^459.1;;2-09 -DEIPA ;;459.1^Serum Potassium, Date;;2-10 -DFJ ;;460^Serum Total Bilirubin^^460.1;;2-11 -DFJPA ;;460.1^Serum Total Bilirubin, Date;;2-12 -BBC ;;223^Preoperative Serum Creatinine^Creatinine^290;;2-13 -BIJ ;;290^Creatinine Date;;2-14 -BBE ;;225^Preoperative Serum Albumin^^292;;2-15 -BIB ;;292^Preoperative Serum Albumin Date;;2-16 -BAI ;;219^Preoperative Hemoglobin^^239;;2-17 -BCI ;;239^Preoperative Hemoglobin Date;;2-18 -EJD ;;504^Hemoglobin A1c^^504.1;;2-19 -EJDPA ;;504.1^Hemoglobin A1c, Date;;2-20 -DGF ;;476^Procedure Type;;3-01 -CEG ;;357^Left Ventricular End-Diastolic Pressure^LVEDP^;;3-02 -CEH ;;358^Aortic Systolic Pressure^Aortic Systolic Pressure^;;3-03 -CEI ;;359^PA Systolic Pressure^*PA Systolic Pressure^;;3-04 -CFJ ;;360^PAW Mean Pressure^*PAW Mean Pressure^;;3-05 -CFC ;;363^LV Contraction Grade^LV Contraction Grade (from contrast or radionuclide angiogram or 2D echo^;;3-06 -DAE ;;415^Mitral Regurgitation^Mitral Regurgitation^;;3-07 -DGG ;;477^Aortic Stenosis;;3-08 -CFA ;;361^Left Main Stenosis^Left Main Stenosis^;;3-09 -CFBPA ;;362.1^Left Anterior Descending (LAD) Stenosis^LAD Stenosis^;;3-10 -CFBPB ;;362.2^Right Coronary Artery Stenosis^Right Coronary Stenosis^;;3-11 -CFBPC ;;362.3^Circumflex Coronary Artery Stenosis^Circumflex Stenosis^;;3-12 -DGH ;;478^Re-Do Lad Stenosis;;3-13 -DGI ;;479^Re-Do Right Coronary Stenosis;;3-14 -DHJ ;;480^Re-Do Circumflex Stenosis;;3-15 -CFD ;;364^Physician's Preoperative Estimate of Operative Mortality^Physician's Preoperative Estimate of Operative Mortality^;;4-01 -CFDPA ;;364.1^Date/Time of Estimate of Operative Mortality^Date/Time of Estimate of Operative Mortality^;;4-02 -APAC ;;1.13^ASA Class^ASA Classification^;;4-03 -DAD ;;414^Cardiac Surgical Priority^Surgical Priority^;;4-04 -DADPA ;;414.1^Date/Time of Cardiac Surgical Priority^Date/Time of Cardiac Surgical Priority^;;4-05 -PBB ;;.22^Time the Operation Began^Date/Time Operation Began^;;4-06 -PBC ;;.23^Time the Operation Ended^Date/Time Operation Ended^;;4-07 -CFE ;;365^CABG Distal Anastomoses with Vein^^;;5-01 -CFF ;;366^CABG Distal Anastomoses with IMA^^;;5-02 -DFD ;;464^Number with Radial Artery^;;5-03 -DFE ;;465^Number with Other Artery^;;5-04 -DAF ;;416^CABG Distal Anastomoses with Other Conduit^^;;5-05 -CFG ;;367^Aortic Valve Replacement (Y/N)^Aortic Valve Replacement^;;5-06 -CFH ;;368^Mitral Valve Replacement (Y/N)^Mitral Valve Replacement^;;5-07 -CFI ;;369^Tricuspid Valve Replacement (Y/N)^Tricuspid Valve Replacement^;;5-08 -CGJ ;;370^Valve Repair (Y/N)^Valve Repair^;;5-09 -CGA ;;371^LV Aneurysmectomy (Y/N)^LV Aneurysmectomy^;;5-10 -DHA ;;481^Bridge to transplant/Device;;5-11 -DHC ;;483^Transmyocardial Laser Revascularization;;5-12 -EAB ;;512^Maze Procedure;;5-13 -CGF ;;376^ASD Repair (Y/N)^ASD Repair^;;5-14 -CHJ ;;380^VSD Repair (Y/N)^VSD Repair^;;5-15 -CGH ;;378^Myectomy for IHSS (Y/N)^Myectomy for IHSS^;;5-16 -CGG ;;377^Myxoma Resection (Y/N)^Myxoma Resection^;;5-17 -CGI ;;379^Other Tumor Resection (Y/N)^Other Tumor Resection^;;5-18 -CGC ;;373^Cardiac Transplant (Y/N)^Cardiac Transplant^;;5-19 -CGB ;;372^Great Vessel Repair(Y/N)^Great Vessel Repair^;;5-20 -EJE ;;505^Endovascular Repair of Descending Thoracic Aorta (Y/N)^Endovascular Repair;;5-21 -EJB ;;502^Other Cardiac Procedures (Y/N);;5-22 -DHD ;;484^Other cardiac procedures (specify);;5-23 -CHA ;;381^Foreign Body Removal (Y/N)^Foreign Body Removal^;;5-24 -CHB ;;382^Pericardiectomy (Y/N)^Pericardiectomy^;;5-25 -DEA ;;451^Total CPB Time;;5-26 -DEJ ;;450^Total Ischemic Time;;5-27 -DFH ;;468^Incision Type^;;5-28 -DFI ;;469^Covert From Off Pump to CPB;;5-29 -CHD ;;384^Operative Death (Y/N)^Operative Death^;;6-01 -DAH ;;418^Hospital Admission Date And Time;;7-01 -DAI ;;419^Hospital Discharge Date And Time;;7-02 -DDJ ;;440^Cardiac Catheterization Date;;7-03 -PBJE ;;.205^Time Patient In OR;;7-04 -PBCB ;;.232^Time Patient Out OR;;7-05 -DGJ ;;470^Date and Time Patient Extubated;;7-06 -DGA ;;471^Date and Time Patient Discharged from ICU;;7-07 -DGC ;;473^Homeless(Y/N);;7-08 -DGB ;;472^Cardiac Surgery to NON-VA Facility;;7-09 -DDB ;;442^Employment Status;;7-10 -EAC ;;513^CT Surgery Consult Date;;7-11 -EAE ;;515^Cause for Delay for Cardiac Surgery;;7-12 +SROAUTL4 ;BIR/ADM - RISK ASSESSMENT UTILITY ;08/24/07 + ;;3.0; Surgery ;**38,71,95,125,153,160,164**;24 Jun 93;Build 2 + S SRZ=0 F S SRZ=$O(SRY(130,SRTN,SRZ)) Q:'SRZ D + .I SRY(130,SRTN,SRZ,"I")="" D TR S X=$T(@SRP),SRFLD=$P(X,";;",2) D + ..I SRZ=451!(SRZ=450) S SRX($P(SRFLD,"^",2))=$P(SRFLD,"^",2)_"^"_SRZ Q + ..I SRZ=513,$P(^SRF(SRTN,0),"^",9)<3071001 Q + ..S SRX(SRZ)=$P(SRFLD,"^",2) + .I SRY(130,SRTN,SRZ,"I")="NS" D TR S X=$T(@SRP),SRFLD=$P(X,";;",2),SRDT=$P(SRFLD,"^",4) S:SRDT'="" SRLR(SRDT)="" + S SRDT=0 F S SRDT=$O(SRLR(SRDT)) Q:'SRDT K SRX(SRDT) + Q +TR S SRP=SRZ,SRP=$TR(SRP,"1234567890.","ABCDEFGHIJP") + Q +GET S X=$T(@J) + Q +PBB ;;.22^Time the Operation Began^Date/Time Operation Began^ +PBC ;;.23^Time the Operation Ended^Date/Time Operation Ended^ +BCF ;;236^Patient's Height^Height^ +BCG ;;237^Patient's Weight^Weight^ +CDF ;;346^Diabetes^Diabetes^ +BJC ;;203^History of COPD (Y/N)^COPD^ +CDG ;;347^FEV1^FEV1^ +BJI ;;209^Cardiomegaly on Chest X-Ray (Y/N)^Cardiomegaly (X-ray)^ +CDH ;;348^Pulmonary Rales (Y/N)^Pulmonary Rales^ +EAJ ;;510^Current Smoker^Current Smoker^ +BBC ;;223^Preoperative Serum Creatinine^Creatinine^290 +CDI ;;349^Active Endocarditis (Y/N)^Active Endocarditis^ +CEJ ;;350^Resting ST Depression (Y/N)^Resting ST Depression^ +BDJ ;;240^Functional Health Status^Functional Status^ +CEA ;;351^PCI Status^PCI^ +BJE ;;205^Prior Myocardial Infarction^Prior MI^ +CEB ;;352^Number of Prior Heart Surgeries^Number of Prior Heart Surgeries^ +BFE ;;265^Peripheral Vascular Disease (Y/N)^Peripheral Vascular Disease^ +BFD ;;264^Cerebral Vascular Disease (Y/N)^Cerebral Vascular Disease^ +BFG ;;267^Angina (use NYHA Functional Class)^Angina (use CCS Class)^ +BJG ;;207^Congestive Heart Failure (use NYHA Functional Class)^CHF (use NYHA Class)^ +CEC ;;353^Current Diuretic Use (Y/N)^Current Diuretic Use^ +CED ;;354^Current Digoxin Use (Y/N)^Current Digoxin Use^ +CEE ;;355^IV NTG within 48 Hours Preceding Surgery (Y/N)^IV NTG within 48 Hours^ +CEF ;;356^Preoperative use of IABP (Y/N)^Preop Use of IABP^ +CEG ;;357^Left Ventricular End-Diastolic Pressure^LVEDP^ +CEH ;;358^Aortic Systolic Pressure^Aortic Systolic Pressure^ +CEI ;;359^PA Systolic Pressure^*PA Systolic Pressure^ +CFJ ;;360^PAW Mean Pressure^*PAW Mean Pressure^ +CFA ;;361^Left Main Stenosis^Left Main Stenosis^ +CFBPA ;;362.1^Left Anterior Descending (LAD) Stenosis^LAD Stenosis^ +CFBPB ;;362.2^Right Coronary Artery Stenosis^Right Coronary Stenosis^ +CFBPC ;;362.3^Circumflex Coronary Artery Stenosis^Circumflex Stenosis^ +CFC ;;363^LV Contraction Grade^LV Contraction Grade (from contrast or radionuclide angiogram or 2D echo^ +DAE ;;415^Mitral Regurgitation^Mitral Regurgitation^ +CFD ;;364^Physician's Preoperative Estimate of Operative Mortality^Physician's Preoperative Estimate of Operative Mortality^ +CFDPA ;;364.1^Date/Time of Estimate of Operative Mortality^Date/Time of Estimate of Operative Mortality^ +APAC ;;1.13^ASA Class^ASA Classification^ +DAD ;;414^Cardiac Surgical Priority^Surgical Priority^ +DADPA ;;414.1^Date/Time of Cardiac Surgical Priority^Date/Time of Cardiac Surgical Priority^ +CHD ;;384^Operative Death (Y/N)^Operative Death^ +CFE ;;365^CABG Distal Anastomoses with Vein^^ +CFF ;;366^CABG Distal Anastomoses with IMA^^ +CFG ;;367^Aortic Valve Replacement (Y/N)^Aortic Valve Replacement^ +CFH ;;368^Mitral Valve Replacement (Y/N)^Mitral Valve Replacement^ +CFI ;;369^Tricuspid Valve Replacement (Y/N)^Tricuspid Valve Replacement^ +CGJ ;;370^Valve Repair (Y/N)^Valve Repair^ +CGA ;;371^LV Aneurysmectomy (Y/N)^LV Aneurysmectomy^ +CGB ;;372^Great Vessel Repair(Y/N)^Great Vessel Repair^ +EJE ;;505^Endovascular Repair of Descending Thoracic Aorta (Y/N)^Endovascular Repair +CGC ;;373^Cardiac Transplant (Y/N)^Cardiac Transplant^ +CGF ;;376^ASD Repair (Y/N)^ASD Repair^ +CHJ ;;380^VSD Repair (Y/N)^VSD Repair^ +CGG ;;377^Myxoma Resection (Y/N)^Myxoma Resection^ +CHA ;;381^Foreign Body Removal (Y/N)^Foreign Body Removal^ +CGH ;;378^Myectomy for IHSS (Y/N)^Myectomy for IHSS^ +CHB ;;382^Pericardiectomy (Y/N)^Pericardiectomy^ +CGI ;;379^Other Tumor Resection (Y/N)^Other Tumor Resection^ +DAF ;;416^CABG Distal Anastomoses with Other Conduit^^ +DDB ;;442^Employment Status +BAI ;;219^Preoperative Hemoglobin^^239 +BCI ;;239^Preoperative Hemoglobin Date +BBE ;;225^Preoperative Serum Albumin^^292 +BIB ;;292^Preoperative Serum Albumin Date +BIJ ;;290^Creatinine Date +DEA ;;451^Total CPB Time +DEJ ;;450^Total Ischemic Time +DDJ ;;440^Cardiac Catheterization Date +DAH ;;418^Hospital Admission Date And Time +DAI ;;419^Hospital Discharge Date And Time +DFC ;;463^Hypertension^ +DFD ;;464^Number with Radial Artery^ +DFE ;;465^Number with Other Artery^ +DFH ;;468^Incision Type^ +DFI ;;469^Covert From Off Pump to CPB +DGJ ;;470^Date and Time Patient Extubated +DGA ;;471^Date and Time Patient Discharged from ICU +DGB ;;472^Cardiac Surgery to NON-VA Facility +PBJE ;;.205^Time Patient In OR +PBCB ;;.232^Time Patient Out OR +DEG ;;457^HDL^^457.1 +DEGPA ;;457.1^HDL, Date +DEH ;;458^Serum Triglyceride^^458.1 +DEHPA ;;458.1^Serum Triglyceride, Date +DEI ;;459^Serum Potassium^^459.1 +DEIPA ;;459.1^Serum Potassium, Date +DFJ ;;460^Serum Total Bilirubin^^460.1 +DFJPA ;;460.1^Serum Total Bilirubin, Date +DFA ;;461^LDL^^461.1 +DFAPA ;;461.1^LDL, Date +DFB ;;462^Total Cholesterol^^462.1 +DFBPA ;;462.1^Total Cholesterol, Date +EJD ;;504^Hemoglobin A1c^^504.1 +EJDPA ;;504.1^Hemoglobin A1c, Date +DGE ;;475^Diabetes (Cardiac) +DGD ;;474^Preop use of circulatory Device +DGF ;;476^Procedure Type +DGG ;;477^Aortic Stenosis +DGH ;;478^Re-Do Lad Stenosis +DGI ;;479^Re-Do Right Coronary Stenosis +DHJ ;;480^Re-Do Circumflex Stenosis +DHA ;;481^Bridge to transplant/Device +EAB ;;512^Maze Procedure +DHC ;;483^Transmyocardial Laser Revascularization +EJB ;;502^Other Cardiac Procedures (Y/N) +DHD ;;484^Other cardiac procedures (specify) +DHE ;;485^Prior Heart Surgeries +EAC ;;513^CT Surgery Consult Date diff --git a/r/SURGERY-SR/SROAUTLC.m b/r/SURGERY-SR/SROAUTLC.m index 5ccdb11f..84374658 100644 --- a/r/SURGERY-SR/SROAUTLC.m +++ b/r/SURGERY-SR/SROAUTLC.m @@ -1,62 +1,55 @@ -SROAUTLC ;BIR/ADM - CARDIAC RISK ASSESSMENT UTILITY ;08/23/07 - ;;3.0; Surgery ;**38,71,90,88,95,97,102,96,125,153,163,164,166**;24 Jun 93;Build 7 - ; - ; Reference to ^DIC(45.3 supported by DBIA #218 - ; -SITE ; determine if site is a cardiac facility - I $$CARD Q - W @IOF,!,"The SURGERY SITE PARAMETERS file indicates this site/division does not use ",!,"the Cardiac Risk Assessment module. Therefore, this option is not available",!,"for use.",! - S XQUIT="" W !!,"Press RETURN to continue " R X:DTIME W @IOF - Q -CARD() ; extrinsic call to determine if site is cardiac facility - N CARD S CARD=0 Q:'$G(SRSITE) CARD - I $P($G(^SRO(133,SRSITE,0)),"^",5)="Y" S CARD=1 - Q CARD -NOW ; update date/time of surgical priority entry - N X I $$CARD,$P($G(^SRF(DA,208)),"^",12)'="" D NOW^%DTC S $P(^SRF(DA,208),"^",13)=$E(%,1,12) - Q -KNOW ; delete date/time of surgical priority entry - I $D(^SRF(DA,208)) S $P(^SRF(DA,208),"^",13)="" - Q -EM ; input transform logic on Case Schedule Type field (.035) - Q:'$$CARD N DIR,SREM,SRNOT,SRQ,SRSP - I X'="EM" S:X="U" $P(^SRF(DA,208),"^",12)=2 S:X'="U" $P(^SRF(DA,208),"^",12)=1 D NOW Q - S SRQ=0,SRSP=$P(^DIC(45.3,$P(^SRO(137.45,$P(^SRF(DA,0),"^",4),0),"^",2),0),"^") Q:SRSP'=48&(SRSP'=58) D:SRSP=58 YN Q:SRQ - D CAT - Q -CAT N X K DIR S DIR("A",1)="",DIR("A",2)=" Enter category of emergency.",DIR("A",3)=" 1. Emergent (ongoing ischemia)",DIR("A",4)=" 2. Emergent (hemodynamic compromise)",DIR("A",5)=" 3. Emergent (arrest with CPR)" - S DIR("A",6)="",DIR("A")=" Enter number (1, 2 or 3): ",DIR(0)="NA^1:3",DIR("?")="^D HELP^SROAUTLC" D ^DIR I $D(DTOUT)!$D(DUOUT) Q - S SREM=Y,$P(^SRF(DA,208),"^",12)=SREM+2 D NOW - Q -YN N X K DIR S DIR("A",1)="",DIR("A",2)=" Is this emergency case a cardiac procedure requiring cardiopulmonary",DIR("A")=" bypass (Y/N)? ",DIR(0)="YA" D ^DIR I $D(DTOUT)!$D(DUOUT) S SRQ=1 Q - I 'Y S SRQ=1 - Q -HELP K SRHLP S SRHLP(1)="This is the category of emergency reflecting the patient's cardiovascular",SRHLP(2)="condition at the time of transport to the operating room:",SRHLP(3)="" - S SRHLP(4)="1. Emergent (ongoing ischemia) - Clinical condition mandates immediate",SRHLP(5)="surgery usually on day of catheterization because of ischemia despite" - S SRHLP(6)="medical therapy, such as intravenous nitroglycerine. Ischemia should",SRHLP(7)="be manifested as chest pain and/or ST-segment depression." - S SRHLP(8)="",SRHLP(9)="2. Emergent (hemodynamic compromise) - Persistent hypotension (arterial",SRHLP(10)="systolic pressure < 80 mm Hg) and/or low cardiac output (cardiac index" - S SRHLP(11)="< 2.0 L/min/MxM) despite iontropic and/or mechanical circulatory",SRHLP(12)="support mandates immediates surgery within hours of the cardiac",SRHLP(13)="catheterization." - S SRHLP(14)="",SRHLP(15)="3. Emergent (arrest with CPR) - Patient is taken to the operating room in",SRHLP(16)="full cardiac arrest with the circulation supported by cardiopulmonary" - S SRHLP(17)="resuscitation (excludes patients being adequately perfused by a",SRHLP(18)="cardiopulmonary support system).",SRHLP(19)="" - S SRHLP(20)="Enter the appropriate number to designate the category of emergency.",SRHLP(21)="",SRHLP(22)="" D EN^DDIOL(.SRHLP) K SRHLP - N DIR S DIR(0)="FOA",DIR("A")="Enter RETURN to continue: " D ^DIR I $D(DTOUT)!$D(DUOUT) S SRQ=1 Q - Q -CHK ; check for missing cardiac assessment information - K SRX,SRZZ F SRC="CLIN","LAB","CATH","OP","CAR","OUT","R" K DA,DIC,DIQ,DR,SRY S DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="I" D @SRC D EN^DIQ1 D ^SROAUTL4 - D RED^SROAUTL4 - Q -CLIN S DR="236;237;475;203;347;209;348;510;349;350;240;351;205;352;485;265;264;267;207;353;354;355;474;463" - Q -CATH S DR="476;357;358;359;360;363;415;477;361;362.1;362.2;362.3;478;479;480" - Q -R S DR="418;419;440;.205;.232;470;471;473;472;442;513;515" - Q -OP S DR="364;364.1;1.13;414;414.1;.22;.23" - Q -OUT S DR="384" - Q -CAR S DR="365;366;464;465;416;367;368;369;370;371;481;483;512;376;380;378;377;379;373;372;505;502;381;382;451;450;468;469" - I $P($G(^SRF(SRTN,209)),"^",13)="Y"!($P($G(^SRF(SRTN,209)),"^",13)="") S DR=DR_";484" - Q -LAB S DR="457;457.1;461;461.1;462;462.1;458;458.1;459;459.1;460;460.1;223;290;225;292;219;239;504;504.1" - Q +SROAUTLC ;BIR/ADM - CARDIAC RISK ASSESSMENT UTILITY ;08/23/07 + ;;3.0; Surgery ;**38,71,90,88,95,97,102,96,125,153,163,164**;24 Jun 93;Build 2 + ; + ; Reference to ^DIC(45.3 supported by DBIA #218 + ; +SITE ; determine if site is a cardiac facility + I $$CARD Q + W @IOF,!,"The SURGERY SITE PARAMETERS file indicates this site/division does not use ",!,"the Cardiac Risk Assessment module. Therefore, this option is not available",!,"for use.",! + S XQUIT="" W !!,"Press RETURN to continue " R X:DTIME W @IOF + Q +CARD() ; extrinsic call to determine if site is cardiac facility + N CARD S CARD=0 Q:'$G(SRSITE) CARD + I $P($G(^SRO(133,SRSITE,0)),"^",5)="Y" S CARD=1 + Q CARD +NOW ; update date/time of surgical priority entry + N X I $$CARD,$P($G(^SRF(DA,208)),"^",12)'="" D NOW^%DTC S $P(^SRF(DA,208),"^",13)=$E(%,1,12) + Q +KNOW ; delete date/time of surgical priority entry + I $D(^SRF(DA,208)) S $P(^SRF(DA,208),"^",13)="" + Q +EM ; input transform logic on Case Schedule Type field (.035) + Q:'$$CARD N DIR,SREM,SRNOT,SRQ,SRSP + I X'="EM" S:X="U" $P(^SRF(DA,208),"^",12)=2 S:X'="U" $P(^SRF(DA,208),"^",12)=1 D NOW Q + S SRQ=0,SRSP=$P(^DIC(45.3,$P(^SRO(137.45,$P(^SRF(DA,0),"^",4),0),"^",2),0),"^") Q:SRSP'=48&(SRSP'=58) D:SRSP=58 YN Q:SRQ + D CAT + Q +CAT N X K DIR S DIR("A",1)="",DIR("A",2)=" Enter category of emergency.",DIR("A",3)=" 1. Emergent (ongoing ischemia)",DIR("A",4)=" 2. Emergent (hemodynamic compromise)",DIR("A",5)=" 3. Emergent (arrest with CPR)" + S DIR("A",6)="",DIR("A")=" Enter number (1, 2 or 3): ",DIR(0)="NA^1:3",DIR("?")="^D HELP^SROAUTLC" D ^DIR I $D(DTOUT)!$D(DUOUT) Q + S SREM=Y,$P(^SRF(DA,208),"^",12)=SREM+2 D NOW + Q +YN N X K DIR S DIR("A",1)="",DIR("A",2)=" Is this emergency case a cardiac procedure requiring cardiopulmonary",DIR("A")=" bypass (Y/N)? ",DIR(0)="YA" D ^DIR I $D(DTOUT)!$D(DUOUT) S SRQ=1 Q + I 'Y S SRQ=1 + Q +HELP K SRHLP S SRHLP(1)="This is the category of emergency reflecting the patient's cardiovascular",SRHLP(2)="condition at the time of transport to the operating room:",SRHLP(3)="" + S SRHLP(4)="1. Emergent (ongoing ischemia) - Clinical condition mandates immediate",SRHLP(5)="surgery usually on day of catheterization because of ischemia despite" + S SRHLP(6)="medical therapy, such as intravenous nitroglycerine. Ischemia should",SRHLP(7)="be manifested as chest pain and/or ST-segment depression." + S SRHLP(8)="",SRHLP(9)="2. Emergent (hemodynamic compromise) - Persistent hypotension (arterial",SRHLP(10)="systolic pressure < 80 mm Hg) and/or low cardiac output (cardiac index" + S SRHLP(11)="< 2.0 L/min/MxM) despite iontropic and/or mechanical circulatory",SRHLP(12)="support mandates immediates surgery within hours of the cardiac",SRHLP(13)="catheterization." + S SRHLP(14)="",SRHLP(15)="3. Emergent (arrest with CPR) - Patient is taken to the operating room in",SRHLP(16)="full cardiac arrest with the circulation supported by cardiopulmonary" + S SRHLP(17)="resuscitation (excludes patients being adequately perfused by a",SRHLP(18)="cardiopulmonary support system).",SRHLP(19)="" + S SRHLP(20)="Enter the appropriate number to designate the category of emergency.",SRHLP(21)="",SRHLP(22)="" D EN^DDIOL(.SRHLP) K SRHLP + N DIR S DIR(0)="FOA",DIR("A")="Enter RETURN to continue: " D ^DIR I $D(DTOUT)!$D(DUOUT) S SRQ=1 Q + Q +CHK ; check for missing cardiac assessment information + K SRX F SRC="CLIN","COC","CP","CLR" K DA,DIC,DIQ,DR,SRY S DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="I" D @SRC D EN^DIQ1 D ^SROAUTL4 + Q +CLIN S DR="236;237;475;203;347;209;348;510;223;290;219;239;225;292;349;350;240;351;205;352;485;265;264;267;207;353;354;355;463;474" + Q +COC S DR="476;477;357;358;359;360;361;362.1;362.2;362.3;363;415;474;364;364.1;1.13;414;414.1;384;.22;.23;472;478;479;480" + Q +CP S DR="365;366;464;465;416;367;368;369;370;371;372;505;450;451;373;376;380;377;381;378;382;379;468;469;.205;.232;470;471;418;419;440;481;512;483;502;513" + I $P($G(^SRF(SRTN,209)),"^",13)="Y"!($P($G(^SRF(SRTN,209)),"^",13)="") S DR=DR_";484" + Q +CLR S DR="457;457.1;458;458.1;459;459.1;460;460.1;461;461.1;462;462.1;504;504.1" + Q diff --git a/r/SURGERY-SR/SROCODE.m b/r/SURGERY-SR/SROCODE.m index e1cd97a3..03f9f399 100644 --- a/r/SURGERY-SR/SROCODE.m +++ b/r/SURGERY-SR/SROCODE.m @@ -1,32 +1,32 @@ -SROCODE ;BIR/MAM - SET UP FLAG FOR ANESTHESIA AGENTS ;01/30/08 - ;;3.0; Surgery ;**72,41,114,151,166**;24 Jun 93;Build 7 - ; - ; Reference to ENS^PSSGIU supported by DBIA #895 - ; -1 N SRTEST S SRTEST=50,SRTEST(0)="AEQSZ",SRTEST("A")="Enter the name of the drug you wish to flag: " - D DIC^PSSDI(50,"SR",.SRTEST) G:+Y<1 DONE S SROIUDA=+Y,SROIRX=$P(Y,"^",2),SROIUX="S^SURGERY" D SROIU - G 1 -SROIU Q:'$D(SROIUDA)!'$D(SROIUX) Q:SROIUX'?1E1"^"1.E - N SRRX D DATA^PSS50(SROIUDA,,,,,"SRRX") S SRRX=$G(^TMP($J,"SRRX",SROIUDA,63)) D - .S SROIUY=$S($D(SRRX):SRRX,1:""),SROIUT=$P(SROIUX,"^",2),SROIUT=$E("N","AEIOU"[$E(SROIUT))_" "_SROIUT K ^TMP($J,"SRRX",SROIUDA) - I SROIUY["S" W !!,"This drug is already flagged for SURGERY." K DIR S DIR("A")="Do you want to remove the flag (Y/N)",DIR(0)="Y" D ^DIR D:Y OFF D DONE Q - W !! K DIR S DIR("A")="Do you want to flag this drug for SURGERY (Y/N)",DIR(0)="Y" D ^DIR D:Y FLAG -DONE W @IOF K SROIRX D ^SRSKILL - Q -FLAG S PSIUDA=SROIUDA,PSIUX=SROIUX_"^1" - S X="PSSGIU" X ^%ZOSF("TEST") I $T D ENS^PSSGIU - ;HL7 master file update (addition) to anesthesia agent list - N SRTBL,SRENT,FEC,REC S SRTBL="ANESTHESIA AGENT^50^.01",FEC="UPD",REC="MAD",SRENT=SROIUDA_U_SROIRX D MSG^SRHLMFN(SRTBL,FEC,REC,SRENT) - ;A call to PDM to possibly generate an HL7 outgoing drug message - S X="PSSHUIDG" X ^%ZOSF("TEST") I $T D DRG^PSSHUIDG(PSIUDA) - K PSIUDA,PSIUX - Q -OFF S PSIUDA=SROIUDA,PSIUX=SROIUX_"^1" - S X="PSSGIU" X ^%ZOSF("TEST") I $T D END^PSSGIU - ;HL7 master file update (deletion) to anesthesia agent list - N SRTBL,SRENT,FEC,REC S SRTBL="ANESTHESIA AGENT^50^.01",FEC="UPD",REC="MDL" D DATA^PSS50(SROIUDA,,,,,"SRRX") - S SRENT=SROIUDA_U_$P($G(^TMP($J,"SRRX",SROIUDA,.01)),"^") K ^TMP($J,"SRRX",SROIUDA) D MSG^SRHLMFN(SRTBL,FEC,REC,SRENT) - ;A call to PDM to possibly generate an HL7 outgoing drug message - S X="PSSHUIDG" X ^%ZOSF("TEST") I $T D DRG^PSSHUIDG(PSIUDA) - K PSIUDA,PSIUX - Q +SROCODE ;B'HAM ISC/MAM - SET UP FLAG FOR ANESTHESIA AGENTS ; [ 05/06/98 7:14 AM ] + ;;3.0; Surgery ;**72,41,114,151**;24 Jun 93 + ; + ; Reference to ENS^PSSGIU supported by DBIA #895 + ; Reference to ^PSS50 supported by DBIA #4533 + ; +1 W !! K DIR S DIR(0)="P^50:QEAM",DIR("A")="Enter the name of the drug you wish to flag" D ^DIR G:Y<1 DONE S SROIUDA=+Y,SROIRX=$P(Y,"^",2),SROIUX="S^SURGERY" D SROIU + G 1 +SROIU Q:'$D(SROIUDA)!'$D(SROIUX) Q:SROIUX'?1E1"^"1.E + N SRRX D DATA^PSS50(SROIUDA,,,,,"SRRX") S SRRX=$G(^TMP($J,"SRRX",SROIUDA,63)) D + .S SROIUY=$S($D(SRRX):SRRX,1:""),SROIUT=$P(SROIUX,"^",2),SROIUT=$E("N","AEIOU"[$E(SROIUT))_" "_SROIUT K ^TMP($J,"SRRX",SROIUDA) + I SROIUY["S" W !!,"This drug is already flagged for SURGERY." K DIR S DIR("A")="Do you want to remove the flag (Y/N)",DIR(0)="Y" D ^DIR D:Y OFF D DONE Q + W !! K DIR S DIR("A")="Do you want to flag this drug for SURGERY (Y/N)",DIR(0)="Y" D ^DIR D:Y FLAG +DONE W @IOF K SROIRX D ^SRSKILL + Q +FLAG S PSIUDA=SROIUDA,PSIUX=SROIUX_"^1" + S X="PSSGIU" X ^%ZOSF("TEST") I $T D ENS^PSSGIU + ;HL7 master file update (addition) to anesthesia agent list + N SRTBL,SRENT,FEC,REC S SRTBL="ANESTHESIA AGENT^50^.01",FEC="UPD",REC="MAD",SRENT=SROIUDA_U_SROIRX D MSG^SRHLMFN(SRTBL,FEC,REC,SRENT) + ;A call to PDM to possibly generate an HL7 outgoing drug message + S X="PSSHUIDG" X ^%ZOSF("TEST") I $T D DRG^PSSHUIDG(PSIUDA) + K PSIUDA,PSIUX + Q +OFF S PSIUDA=SROIUDA,PSIUX=SROIUX_"^1" + S X="PSSGIU" X ^%ZOSF("TEST") I $T D END^PSSGIU + ;HL7 master file update (deletion) to anesthesia agent list + N SRTBL,SRENT,FEC,REC S SRTBL="ANESTHESIA AGENT^50^.01",FEC="UPD",REC="MDL" D DATA^PSS50(SROIUDA,,,,,"SRRX") + S SRENT=SROIUDA_U_$P($G(^TMP($J,"SRRX",SROIUDA,.01)),"^") K ^TMP($J,"SRRX",SROIUDA) D MSG^SRHLMFN(SRTBL,FEC,REC,SRENT) + ;A call to PDM to possibly generate an HL7 outgoing drug message + S X="PSSHUIDG" X ^%ZOSF("TEST") I $T D DRG^PSSHUIDG(PSIUDA) + K PSIUDA,PSIUX + Q diff --git a/r/SURGERY-SR/SROESPR1.m b/r/SURGERY-SR/SROESPR1.m index 6d18f840..5cdb3e18 100644 --- a/r/SURGERY-SR/SROESPR1.m +++ b/r/SURGERY-SR/SROESPR1.m @@ -1,189 +1,188 @@ -SROESPR1 ;BIR/ADM - SURGERY E-SIG UTILITY ; [ 04/21/04 12:08 PM ] - ;;3.0; Surgery ;**100,128,162**;24 Jun 93;Build 4 - ; - ;** NOTICE: This routine is part of an implementation of a nationally - ;** controlled procedure. Local modifications to this routine - ;** are prohibited. - ; - ; Reference to EXTRACT^TIULQ supported by DBIA #2693 - ; - ; This routine was cloned in part or in whole from TIUPRPN1. -PRINT(SRFLAG,SRSPG) ; Print Summary - ; ^TMP("SRPR",$J) is array of records passed by reference - ; SRFLAG=1 --> Chart Copy SRSPG=1 --> Contiguous - ; SRFLAG=0 --> Work Copy SRSPG=0 --> Fresh Page- each note - N SRI,SRJ,SRPAGE,SRFOOT,SRK,SRDA,SRCONT,SRPGRP,SRTYP - N SRPFHDR,SRPFNBR,SROPAGE - S SRFLAG=+$G(SRFLAG),SRSPG=+$G(SRSPG) - S SRI=0 F S SRI=$O(^TMP("SRPR",$J,SRI)) Q:SRI="" D Q:'SRCONT - . N DFN,SR,SRERR - . I SRI["$" S SRPGRP=$P(SRI,"$"),SRPFHDR=$P($P(SRI,";"),"$",2) - . E S SRPFHDR="Surgery Reports" - . I $G(SRPGRP)'=2 S SRSPG=0 - . S DFN=$P(SRI,";",2) - . D PAT^SROESPR(.SRFOOT,DFN) - . I +$G(SRSPG) D HEADER^SROESPR2(.SRFOOT,SRFLAG,.SRPFHDR) - . S SRJ=0 F S SRJ=$O(^TMP("SRPR",$J,SRI,SRJ)) Q:'SRJ D Q:'SRCONT - . . S SRK=0 F S SRK=$O(^TMP("SRPR",$J,SRI,SRJ,SRK)) Q:'SRK D Q:'+$G(SRCONT) - . . . N SRERR1,SRW K SRCONT1 S SRPFNBR=^(SRK) - . . . ; If the document has been deleted, QUIT - . . . D EXTRACT^TIULQ(SRK,"SRW",.SRERR1,".01") I $P($G(SRERR1),"^")=1 S SRCONT=1 Q - . . . I '+$G(SRSPG) D HEADER^SROESPR2(.SRFOOT,SRFLAG,.SRPFHDR) - . . . S SRDA=SRK - . . . D REPORT(SRDA) Q:'+$G(SRCONT) - . . . I '+$G(SRSPG) K SRCONT1 D SETCONT(1) - . . . I $E(IOST)="C",'$O(^TMP("SRPR",$J,SRI,SRJ,SRK)) S SRCONT=0 - . Q:'SRCONT I $E(IOST)="C" S SRCONT=$$STOP^SROESPR2() Q:'SRCONT - . I +$G(SRSPG),$E(IOST)'="C" K SRCONT1 D SETCONT(1) - Q -REPORT(SRDA) ; Report Text - N DIW,DIWF,DIWL,DIWR,DIWT,SRERR,SR,SRI,SRLINE,X,Z,SRY,LOC - K ^TMP("SRLQ",$J) - S SRLINE=0 - D EXTRACT^TIULQ(+SRDA,"^TMP(""SRLQ"",$J)",.SRERR,"",SRLINE,1) - I +$G(SRERR) W !,$P(SRERR,U,2) Q - Q:'$D(^TMP("SRLQ",$J)) - S SRY=4,SRCONT=1 - D SETCONT() Q:'SRCONT - W "NOTE DATED: " - W $$DATE^SROESPR(^TMP("SRLQ",$J,SRDA,1301,"I"),"MM/DD/CCYY HR:MIN") - W ?30,$$UP^XLFSTR(^TMP("SRLQ",$J,SRDA,.01,"E")),! - I +$G(^TMP("SRLQ",$J,SRDA,1205,"I")) D - .S LOC=$G(^TMP("SRLQ",$J,SRDA,1205,"I")) Q:'$D(^SC(LOC,0)) - .W $S($P(^SC(LOC,0),U,3)="W":"ADMITTED: ",1:"VISIT: ") - .W $$DATE^SROESPR(^TMP("SRLQ",$J,SRDA,.07,"I"),"MM/DD/CCYY HR:MIN") - .W " ",$G(^TMP("SRLQ",$J,SRDA,1205,"E")) - I ^TMP("SRLQ",$J,SRDA,1701,"E")]"" W !,"SUBJECT: ",^("E"),! - S SRCONT1=1 - I $D(^TMP("SRLQ",$J,SRDA,"PROBLEM")) D Q:'SRCONT - .D SETCONT() Q:'SRCONT - .W !,"ASSOCIATED PROBLEMS:" - .N SRI S SRI=0 - .F S SRI=$O(^TMP("SRLQ",$J,SRDA,"PROBLEM",SRI)) Q:'SRI D Q:'SRCONT - ..W !,^(SRI,0) - ..D SETCONT() Q:'SRCONT - W ! - ; - S SRI=0,DIWF="WN",DIWL=1,DIWR=79 K ^UTILITY($J,"W") - F S SRI=$O(^TMP("SRLQ",$J,SRDA,"TEXT",SRI)) Q:SRI'>0 D Q:'SRCONT ; D ^DIWW - . D SETCONT() Q:'SRCONT - . S X=^TMP("SRLQ",$J,SRDA,"TEXT",SRI,0) S:X="" X=" " D ^DIWP - D ^DIWW K ^UTILITY($J,"W") - Q:'SRCONT -RPTSIG ; Signature should be on bottom of form, Addenda on Subsequent pages - N AUTHOR,EXPSIGNR,EXPCOSNR,SIGNDATE,SIGNEDBY,SIGNNAME,SIGTITL,SIGNMODE - N COSGDATE,COSGEDBY,COSGNAME,COSGTITL,COSGMODE,SIGCHRT,COSCHRT,SRLINE - S $P(SRLINE,"-",81)="" - S AUTHOR=$G(^TMP("SRLQ",$J,SRDA,1202,"I"))_";"_$G(^("E")) - S EXPSIGNR=$G(^TMP("SRLQ",$J,SRDA,1204,"I"))_";"_$G(^("E")) - S EXPCOSNR=$G(^TMP("SRLQ",$J,SRDA,1208,"I"))_";"_$G(^("E")) - S SIGNDATE=$G(^TMP("SRLQ",$J,SRDA,1501,"I")) - S SIGNEDBY=$G(^TMP("SRLQ",$J,SRDA,1502,"I"))_";"_$G(^("E")) - S SIGNNAME=$G(^TMP("SRLQ",$J,SRDA,1503,"E")) - S SIGTITL=$G(^TMP("SRLQ",$J,SRDA,1504,"E")) - S SIGNMODE=$G(^TMP("SRLQ",$J,SRDA,1505,"I"))_";"_$G(^("E")) - S COSGDATE=$G(^TMP("SRLQ",$J,SRDA,1507,"I")) - S COSGEDBY=$G(^TMP("SRLQ",$J,SRDA,1508,"I"))_";"_$G(^("E")) - S COSGNAME=$G(^TMP("SRLQ",$J,SRDA,1509,"E")) - S COSGTITL=$G(^TMP("SRLQ",$J,SRDA,1510,"E")) - S COSGMODE=$G(^TMP("SRLQ",$J,SRDA,1511,"I"))_";"_$G(^("E")) - S SIGCHRT=$G(^TMP("SRLQ",$J,SRDA,1512,"I"))_";"_$G(^("E")) - S COSCHRT=$G(^TMP("SRLQ",$J,SRDA,1513,"I"))_";"_$G(^("E")) - D SETCONT() Q:'SRCONT W ! - D SIGBLK Q:'SRCONT -ADDENDA ; Surgery Reports Addenda - N DIW,DIWF,DIWL,DIWR,DIWT,X,Z,SRI,SRADD - S SRADD=0,DIWF="WN",DIWL=1,DIWR=79 K ^UTILITY($J,"W") - F S SRADD=$O(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD)) Q:SRADD'>0 D Q:'SRCONT - . S SRY=4 D SETCONT() Q:'SRCONT - . W !!,$$DATE^SROESPR(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1301,"I"),"MM/DD/CCYY HR:MIN"),?21,"ADDENDUM" - . W ?41,"STATUS: ",^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,.05,"E") - . S SRI=0 - . F S SRI=$O(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,"TEXT",SRI)) Q:SRI'>0 D Q:'SRCONT - . . D SETCONT() Q:'SRCONT - . . S X=^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,"TEXT",SRI,0) S:X="" X=" " D ^DIWP - . D ^DIWW - . D:SRCONT ADDENSIG - K ^UTILITY($J,"W") - ; Write 2 linefeeds between records - Q:'SRCONT W !! - Q -ADDENSIG ; - N AUTHOR,EXPSIGNR,ATTNDING,SIGNDATE,SIGNEDBY,SIGNNAME,SIGNMODE - N COSGDATE,COSGEDBY,COSGNAME,COSGMODE,SRLINE S $P(SRLINE,"-",80)="" - S AUTHOR=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1202,"I"))_";"_$G(^("E")) - S EXPSIGNR=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1204,"I"))_";"_$G(^("E")) - S ATTNDING=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1209,"I"))_";"_$G(^("E")) - S SIGNDATE=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1501,"I")) - S SIGNEDBY=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1502,"I"))_";"_$G(^("E")) - S SIGNNAME=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1503,"E")) - S SIGTITL=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1504,"E")) - S SIGNMODE=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1505,"I"))_";"_$G(^("E")) - S COSGDATE=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1507,"I")) - S COSGEDBY=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1508,"I"))_";"_$G(^("E")) - S COSGNAME=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1509,"E")) - S COSGTITL=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1510,"E")) - S COSGMODE=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1511,"I"))_";"_$G(^("E")) - S SRY=11 -SIGBLK N SRGROOT S SRGROOT=$NA(^TMP("SRLQ",$J,SRDA)) - I '+SIGNDATE D D SETCONT() Q:'SRCONT - .I $$STATUS^SROESUTL(SRDA)'=7 W !,"**DRAFT COPY - DRAFT COPY -- ABOVE NOTE IS UNSIGNED-- DRAFT COPY - DRAFT COPY**" - I SIGNEDBY]"",(+SIGNEDBY'=+AUTHOR) D - . W ?21,"Author: ",$P(AUTHOR,";",2),! - I +SIGNDATE D SETCONT() Q:'SRCONT D - . W ?18,"Signed by:",$S($P(SIGNMODE,";")="C":" /s/ ",1:" /es/ "),?34,$S(SIGNNAME]"":SIGNNAME,1:$P(SIGNEDBY,";",2)) - . W !?34,SIGTITL - . I $L(SIGTITL)>30 W !?34 - . E W " " - . W $$DATE^SROESPR(+SIGNDATE,"MM/DD/CCYY HR:MIN") - . I '+$G(SRFLAG)!($E(IOST)="C") D - . . I $P($$BEEP^SROESPR(+SIGNEDBY),U) W !?34,"Analog Pager: ",$P($$BEEP^SROESPR(+SIGNEDBY),U) - . . I $P($$BEEP^SROESPR(+SIGNEDBY),U,2) W !?34,"Digital Pager: ",$P($$BEEP^SROESPR(+SIGNEDBY),U,2) - I $G(^TMP("SRLQ",$J,SRDA,.05,"E"))="UNCOSIGNED" D - . W !?34,"**REQUIRES COSIGNATURE**",! - I +SIGCHRT,$P(SIGNMODE,";")="C" D SETCONT() Q:'SRCONT D - . W !?2,"Marked signed on chart by:",?34,$P(SIGCHRT,";",2) - I +$G(SRADD) S SRGROOT=$NA(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD)) - I +$D(@SRGROOT@("EXTRASGNR")) D - . N SRI S SRI=0 - . D SETCONT() Q:'SRCONT W !?4,"Receipt Acknowledged By:" - . F S SRI=$O(@SRGROOT@("EXTRASGNR",SRI)) Q:'SRI D - . . I +$G(@SRGROOT@("EXTRASGNR",SRI,"DATE"))'>0 Q - . . I SRI>1 D SETCONT() Q:'SRCONT W ! - . . W ?29,"/es/ ",$G(@SRGROOT@("EXTRASGNR",SRI,"NAME")) - . . W !?34,$G(@SRGROOT@("EXTRASGNR",SRI,"TITLE")) - . . I $L($G(@SRGROOT@("EXTRASGNR",SRI,"TITLE")))>30 W !?34 - . . E W " " - . . W $$DATE^SROESPR($G(@SRGROOT@("EXTRASGNR",SRI,"DATE")),"MM/DD/CCYY HR:MIN") - . . I '+$G(SRFLAG)!($E(IOST)="C") D - . . . N BEEP - . . . S BEEP=$$BEEP^SROESPR(+$G(@SRGROOT@("EXTRASGNR",SRI,"EXTRA"))) - . . . I +BEEP W !?34,"Analog Pager: ",$P(BEEP,U) - . . . I +$P(BEEP,U,2) W !?34,"Digital Pager: ",$P(BEEP,U,2) - . K @SRGROOT@("EXTRASGNR") - I +COSGDATE,(+COSGEDBY'=+SIGNEDBY) D SETCONT() Q:'SRCONT D - . W !?16,"Cosigned by:",$S($P(COSGMODE,";")="C":" /s/ ",1:" /es/ "),?34,$S(COSGNAME]"":COSGNAME,1:$P(COSGEDBY,";",2)) - . W !?34,COSGTITL," " - . W $$DATE^SROESPR(+COSGDATE,"MM/DD/CCYY HR:MIN") - . I '+$G(SRFLAG)!($E(IOST)="C") D - . . I $P($$BEEP^SROESPR(+COSGEDBY),U) W !?34,"Analog Pager: ",$P($$BEEP^SROESPR(+COSGEDBY),U) - . . I $P($$BEEP^SROESPR(+COSGEDBY),U,2) W !?34,"Digital Pager:",$P($$BEEP^SROESPR(+COSGEDBY),U,2) - I +COSCHRT,$P(COSGMODE,";")="C" D SETCONT() Q:'SRCONT D - . W !,"Marked cosigned on chart by:",?34,$P(COSCHRT,";",2) - W ! - K SRCONT1 -AMEND ; signature blocks of amender - S SRY=4 D SETCONT() Q:'SRCONT - I +$G(@SRGROOT@(1601,"I")) D - . W !!?12,"Amendment Filed:",?34,$$DATE^SROESPR(@SRGROOT@(1601,"I"),"MM/DD/CCYY HR:MIN") - . I $G(@SRGROOT@(1603,"E"))']"" D - . . W !!?29 F SRI=1:1:40 W "_" - . . W !?29,$$SIGNAME^SROESPR(@SRGROOT@(1602,"I")) - . . W !?29,$$SIGTITL^SROESPR(@SRGROOT@(1602,"I")) - . I $G(@SRGROOT@(1604,"E"))]"" D - . . W !?29,"/es/",?34,@SRGROOT@(1604,"E") - . . W !?34,@SRGROOT@(1605,"E") - Q -SETCONT(SRHEAD) ;Does footer and sets SRCONT - S SRCONT=$$FOOTER^SROESPR2(.SRFOOT,SRFLAG,SRPFNBR,$G(SRHEAD),$G(SRCONT1),SRDA) - Q +SROESPR1 ;BIR/ADM - SURGERY E-SIG UTILITY ; [ 04/21/04 12:08 PM ] + ;;3.0; Surgery ;**100,128**;24 Jun 93 + ; + ;** NOTICE: This routine is part of an implementation of a nationally + ;** controlled procedure. Local modifications to this routine + ;** are prohibited. + ; + ; Reference to EXTRACT^TIULQ supported by DBIA #2693 + ; + ; This routine was cloned in part or in whole from TIUPRPN1. +PRINT(SRFLAG,SRSPG) ; Print Summary + ; ^TMP("SRPR",$J) is array of records passed by reference + ; SRFLAG=1 --> Chart Copy SRSPG=1 --> Contiguous + ; SRFLAG=0 --> Work Copy SRSPG=0 --> Fresh Page- each note + N SRI,SRJ,SRPAGE,SRFOOT,SRK,SRDA,SRCONT,SRPGRP,SRTYP + N SRPFHDR,SRPFNBR,SROPAGE + S SRFLAG=+$G(SRFLAG),SRSPG=+$G(SRSPG) + S SRI=0 F S SRI=$O(^TMP("SRPR",$J,SRI)) Q:SRI="" D Q:'SRCONT + . N DFN,SR,SRERR + . I SRI["$" S SRPGRP=$P(SRI,"$"),SRPFHDR=$P($P(SRI,";"),"$",2) + . E S SRPFHDR="Surgery Reports" + . I $G(SRPGRP)'=2 S SRSPG=0 + . S DFN=$P(SRI,";",2) + . D PAT^SROESPR(.SRFOOT,DFN) + . I +$G(SRSPG) D HEADER^SROESPR2(.SRFOOT,SRFLAG,.SRPFHDR) + . S SRJ=0 F S SRJ=$O(^TMP("SRPR",$J,SRI,SRJ)) Q:'SRJ D Q:'SRCONT + . . S SRK=0 F S SRK=$O(^TMP("SRPR",$J,SRI,SRJ,SRK)) Q:'SRK D Q:'+$G(SRCONT) + . . . N SRERR1,SRW K SRCONT1 S SRPFNBR=^(SRK) + . . . ; If the document has been deleted, QUIT + . . . D EXTRACT^TIULQ(SRK,"SRW",.SRERR1,".01") I $P($G(SRERR1),"^")=1 S SRCONT=1 Q + . . . I '+$G(SRSPG) D HEADER^SROESPR2(.SRFOOT,SRFLAG,.SRPFHDR) + . . . S SRDA=SRK + . . . D REPORT(SRDA) Q:'+$G(SRCONT) + . . . I '+$G(SRSPG) K SRCONT1 D SETCONT(1) + . . . I $E(IOST)="C",'$O(^TMP("SRPR",$J,SRI,SRJ,SRK)) S SRCONT=0 + . Q:'SRCONT I $E(IOST)="C" S SRCONT=$$STOP^SROESPR2() Q:'SRCONT + . I +$G(SRSPG),$E(IOST)'="C" K SRCONT1 D SETCONT(1) + Q +REPORT(SRDA) ; Report Text + N DIW,DIWF,DIWL,DIWR,DIWT,SRERR,SR,SRI,SRLINE,X,Z,SRY,LOC + K ^TMP("SRLQ",$J) + S SRLINE=0 + D EXTRACT^TIULQ(+SRDA,"^TMP(""SRLQ"",$J)",.SRERR,"",SRLINE,1) + I +$G(SRERR) W !,$P(SRERR,U,2) Q + Q:'$D(^TMP("SRLQ",$J)) + S SRY=4,SRCONT=1 + D SETCONT() Q:'SRCONT + W "NOTE DATED: " + W $$DATE^SROESPR(^TMP("SRLQ",$J,SRDA,1301,"I"),"MM/DD/CCYY HR:MIN") + W ?30,$$UP^XLFSTR(^TMP("SRLQ",$J,SRDA,.01,"E")),! + I +$G(^TMP("SRLQ",$J,SRDA,1205,"I")) D + .S LOC=$G(^TMP("SRLQ",$J,SRDA,1205,"I")) Q:'$D(^SC(LOC,0)) + .W $S($P(^SC(LOC,0),U,3)="W":"ADMITTED: ",1:"VISIT: ") + .W $$DATE^SROESPR(^TMP("SRLQ",$J,SRDA,.07,"I"),"MM/DD/CCYY HR:MIN") + .W " ",$G(^TMP("SRLQ",$J,SRDA,1205,"E")) + I ^TMP("SRLQ",$J,SRDA,1701,"E")]"" W !,"SUBJECT: ",^("E"),! + S SRCONT1=1 + I $D(^TMP("SRLQ",$J,SRDA,"PROBLEM")) D Q:'SRCONT + .D SETCONT() Q:'SRCONT + .W !,"ASSOCIATED PROBLEMS:" + .N SRI S SRI=0 + .F S SRI=$O(^TMP("SRLQ",$J,SRDA,"PROBLEM",SRI)) Q:'SRI D Q:'SRCONT + ..W !,^(SRI,0) + ..D SETCONT() Q:'SRCONT + W ! + ; + S SRI=0,DIWF="WN",DIWL=1,DIWR=79 K ^UTILITY($J,"W") + F S SRI=$O(^TMP("SRLQ",$J,SRDA,"TEXT",SRI)) Q:SRI'>0 D Q:'SRCONT ; D ^DIWW + . D SETCONT() Q:'SRCONT + . S X=^TMP("SRLQ",$J,SRDA,"TEXT",SRI,0) S:X="" X=" " D ^DIWP + D ^DIWW K ^UTILITY($J,"W") + Q:'SRCONT +RPTSIG ; Signature should be on bottom of form, Addenda on Subsequent pages + N AUTHOR,EXPSIGNR,EXPCOSNR,SIGNDATE,SIGNEDBY,SIGNNAME,SIGTITL,SIGNMODE + N COSGDATE,COSGEDBY,COSGNAME,COSGTITL,COSGMODE,SIGCHRT,COSCHRT,SRLINE + S $P(SRLINE,"-",81)="" + S AUTHOR=$G(^TMP("SRLQ",$J,SRDA,1202,"I"))_";"_$G(^("E")) + S EXPSIGNR=$G(^TMP("SRLQ",$J,SRDA,1204,"I"))_";"_$G(^("E")) + S EXPCOSNR=$G(^TMP("SRLQ",$J,SRDA,1208,"I"))_";"_$G(^("E")) + S SIGNDATE=$G(^TMP("SRLQ",$J,SRDA,1501,"I")) + S SIGNEDBY=$G(^TMP("SRLQ",$J,SRDA,1502,"I"))_";"_$G(^("E")) + S SIGNNAME=$G(^TMP("SRLQ",$J,SRDA,1503,"E")) + S SIGTITL=$G(^TMP("SRLQ",$J,SRDA,1504,"E")) + S SIGNMODE=$G(^TMP("SRLQ",$J,SRDA,1505,"I"))_";"_$G(^("E")) + S COSGDATE=$G(^TMP("SRLQ",$J,SRDA,1507,"I")) + S COSGEDBY=$G(^TMP("SRLQ",$J,SRDA,1508,"I"))_";"_$G(^("E")) + S COSGNAME=$G(^TMP("SRLQ",$J,SRDA,1509,"E")) + S COSGTITL=$G(^TMP("SRLQ",$J,SRDA,1510,"E")) + S COSGMODE=$G(^TMP("SRLQ",$J,SRDA,1511,"I"))_";"_$G(^("E")) + S SIGCHRT=$G(^TMP("SRLQ",$J,SRDA,1512,"I"))_";"_$G(^("E")) + S COSCHRT=$G(^TMP("SRLQ",$J,SRDA,1513,"I"))_";"_$G(^("E")) + D SETCONT() Q:'SRCONT W ! + D SIGBLK Q:'SRCONT +ADDENDA ; Surgery Reports Addenda + N DIW,DIWF,DIWL,DIWR,DIWT,X,Z,SRI,SRADD + S SRADD=0,DIWF="WN",DIWL=1,DIWR=79 K ^UTILITY($J,"W") + F S SRADD=$O(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD)) Q:SRADD'>0 D Q:'SRCONT + . S SRY=4 D SETCONT() Q:'SRCONT + . W !!,$$DATE^SROESPR(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1301,"I"),"MM/DD/CCYY HR:MIN"),?21,"ADDENDUM" + . S SRI=0 + . F S SRI=$O(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,"TEXT",SRI)) Q:SRI'>0 D Q:'SRCONT + . . D SETCONT() Q:'SRCONT + . . S X=^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,"TEXT",SRI,0) S:X="" X=" " D ^DIWP + . D ^DIWW + . D:SRCONT ADDENSIG + K ^UTILITY($J,"W") + ; Write 2 linefeeds between records + Q:'SRCONT W !! + Q +ADDENSIG ; + N AUTHOR,EXPSIGNR,ATTNDING,SIGNDATE,SIGNEDBY,SIGNNAME,SIGNMODE + N COSGDATE,COSGEDBY,COSGNAME,COSGMODE,SRLINE S $P(SRLINE,"-",80)="" + S AUTHOR=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1202,"I"))_";"_$G(^("E")) + S EXPSIGNR=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1204,"I"))_";"_$G(^("E")) + S ATTNDING=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1209,"I"))_";"_$G(^("E")) + S SIGNDATE=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1501,"I")) + S SIGNEDBY=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1502,"I"))_";"_$G(^("E")) + S SIGNNAME=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1503,"E")) + S SIGTITL=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1504,"E")) + S SIGNMODE=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1505,"I"))_";"_$G(^("E")) + S COSGDATE=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1507,"I")) + S COSGEDBY=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1508,"I"))_";"_$G(^("E")) + S COSGNAME=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1509,"E")) + S COSGTITL=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1510,"E")) + S COSGMODE=$G(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1511,"I"))_";"_$G(^("E")) + S SRY=11 +SIGBLK N SRGROOT S SRGROOT=$NA(^TMP("SRLQ",$J,SRDA)) + I '+SIGNDATE D D SETCONT() Q:'SRCONT + .I $$STATUS^SROESUTL(SRDA)'=7 W !,"**DRAFT COPY - DRAFT COPY -- ABOVE NOTE IS UNSIGNED-- DRAFT COPY - DRAFT COPY**" + I SIGNEDBY]"",(+SIGNEDBY'=+AUTHOR) D + . W ?21,"Author: ",$P(AUTHOR,";",2),! + I +SIGNDATE D SETCONT() Q:'SRCONT D + . W ?18,"Signed by:",$S($P(SIGNMODE,";")="C":" /s/ ",1:" /es/ "),?34,$S(SIGNNAME]"":SIGNNAME,1:$P(SIGNEDBY,";",2)) + . W !?34,SIGTITL + . I $L(SIGTITL)>30 W !?34 + . E W " " + . W $$DATE^SROESPR(+SIGNDATE,"MM/DD/CCYY HR:MIN") + . I '+$G(SRFLAG)!($E(IOST)="C") D + . . I $P($$BEEP^SROESPR(+SIGNEDBY),U) W !?34,"Analog Pager: ",$P($$BEEP^SROESPR(+SIGNEDBY),U) + . . I $P($$BEEP^SROESPR(+SIGNEDBY),U,2) W !?34,"Digital Pager: ",$P($$BEEP^SROESPR(+SIGNEDBY),U,2) + I $G(^TMP("SRLQ",$J,SRDA,.05,"E"))="UNCOSIGNED" D + . W !?34,"**REQUIRES COSIGNATURE**",! + I +SIGCHRT,$P(SIGNMODE,";")="C" D SETCONT() Q:'SRCONT D + . W !?2,"Marked signed on chart by:",?34,$P(SIGCHRT,";",2) + I +$G(SRADD) S SRGROOT=$NA(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD)) + I +$D(@SRGROOT@("EXTRASGNR")) D + . N SRI S SRI=0 + . D SETCONT() Q:'SRCONT W !?4,"Receipt Acknowledged By:" + . F S SRI=$O(@SRGROOT@("EXTRASGNR",SRI)) Q:'SRI D + . . I +$G(@SRGROOT@("EXTRASGNR",SRI,"DATE"))'>0 Q + . . I SRI>1 D SETCONT() Q:'SRCONT W ! + . . W ?29,"/es/ ",$G(@SRGROOT@("EXTRASGNR",SRI,"NAME")) + . . W !?34,$G(@SRGROOT@("EXTRASGNR",SRI,"TITLE")) + . . I $L($G(@SRGROOT@("EXTRASGNR",SRI,"TITLE")))>30 W !?34 + . . E W " " + . . W $$DATE^SROESPR($G(@SRGROOT@("EXTRASGNR",SRI,"DATE")),"MM/DD/CCYY HR:MIN") + . . I '+$G(SRFLAG)!($E(IOST)="C") D + . . . N BEEP + . . . S BEEP=$$BEEP^SROESPR(+$G(@SRGROOT@("EXTRASGNR",SRI,"EXTRA"))) + . . . I +BEEP W !?34,"Analog Pager: ",$P(BEEP,U) + . . . I +$P(BEEP,U,2) W !?34,"Digital Pager: ",$P(BEEP,U,2) + . K @SRGROOT@("EXTRASGNR") + I +COSGDATE,(+COSGEDBY'=+SIGNEDBY) D SETCONT() Q:'SRCONT D + . W !?16,"Cosigned by:",$S($P(COSGMODE,";")="C":" /s/ ",1:" /es/ "),?34,$S(COSGNAME]"":COSGNAME,1:$P(COSGEDBY,";",2)) + . W !?34,COSGTITL," " + . W $$DATE^SROESPR(+COSGDATE,"MM/DD/CCYY HR:MIN") + . I '+$G(SRFLAG)!($E(IOST)="C") D + . . I $P($$BEEP^SROESPR(+COSGEDBY),U) W !?34,"Analog Pager: ",$P($$BEEP^SROESPR(+COSGEDBY),U) + . . I $P($$BEEP^SROESPR(+COSGEDBY),U,2) W !?34,"Digital Pager:",$P($$BEEP^SROESPR(+COSGEDBY),U,2) + I +COSCHRT,$P(COSGMODE,";")="C" D SETCONT() Q:'SRCONT D + . W !,"Marked cosigned on chart by:",?34,$P(COSCHRT,";",2) + W ! + K SRCONT1 +AMEND ; signature blocks of amender + S SRY=4 D SETCONT() Q:'SRCONT + I +$G(@SRGROOT@(1601,"I")) D + . W !!?12,"Amendment Filed:",?34,$$DATE^SROESPR(@SRGROOT@(1601,"I"),"MM/DD/CCYY HR:MIN") + . I $G(@SRGROOT@(1603,"E"))']"" D + . . W !!?29 F SRI=1:1:40 W "_" + . . W !?29,$$SIGNAME^SROESPR(@SRGROOT@(1602,"I")) + . . W !?29,$$SIGTITL^SROESPR(@SRGROOT@(1602,"I")) + . I $G(@SRGROOT@(1604,"E"))]"" D + . . W !?29,"/es/",?34,@SRGROOT@(1604,"E") + . . W !?34,@SRGROOT@(1605,"E") + Q +SETCONT(SRHEAD) ;Does footer and sets SRCONT + S SRCONT=$$FOOTER^SROESPR2(.SRFOOT,SRFLAG,SRPFNBR,$G(SRHEAD),$G(SRCONT1),SRDA) + Q diff --git a/r/SURGERY-SR/SROGMTS.m b/r/SURGERY-SR/SROGMTS.m index b0bd7476..9f217e44 100644 --- a/r/SURGERY-SR/SROGMTS.m +++ b/r/SURGERY-SR/SROGMTS.m @@ -1,188 +1,165 @@ -SROGMTS ;BIR/ADM - SURGERY HEALTH SUMMARY ; [ 08/08/01 7:12 AM ] - ;;3.0; Surgery ;**100,127,162**;24 Jun 93;Build 4 - ; - ;** NOTICE: This routine is part of an implementation of a nationally - ;** controlled procedure. Local modifications to this routine - ;** are prohibited. - ; - ; Reference to $$MOD^ICPTMOD supported by DBIA #1996 - ; Reference to $$CPT^ICPTCOD supported by DBIA #1995 - ; - Q -HS(X) ; return case information for a surical or non-OR case - ; X - case number (IEN) in file 130 - K REC N SRCPTM,SRSG,DA,DR,DIC,DIQ,IEN,IENS,FILE,FLD,FLDS,FLDI - N FLDA,FLDB,FLDR,FLDRT,IEN,SRI,SRRT,SRT,SRS,SRC,SRCS - S SRCPTM=1 - Q:'$D(^SRF(X,0)) S (IENS,IEN,X)=+($G(X)),U="^" - S:'$D(DT) DT=$$HTFM^XLFDT($H,1) S:'$D(DTIME) DTIME=300 - S (FILE,DIC)=130,DA=+($G(X)),DIQ="REC(",DIQ(0)="IE" - S SRSG=$$SG(IEN),REC(130,IEN,118,"E")=$S(SRSG=0:"YES",1:""),REC(130,IEN,118,"I")=$S(SRSG=0:"Y",1:"") - S:+SRSG DR=".09;.04;.14;.164;.205;.22;.23;.31;10;15;17;26;27;32;34;36;39;43;49;50" - S:'SRSG DR=".09;.31;26;27;33;50;55;59;66;121;122;123;124;125" - D EN^DIQ1 S REC(130,IEN,"STATUS")=$$OS(IEN) S:+SRSG REC(130,IEN,"VERIFIED")=$S($G(REC(130,IEN,43,"I"))'="Y":"(Unverified)",1:"") - S SRM=$G(REC(130,IEN,27,"I")) I SRM>0 D CPT(SRM,$P($G(^SRF(IEN,0)),"^",9),130,27) - D DICT^SROGMTS0,SUB,SPD - S:$D(REC(130,IEN,32)) REC(130,IEN,32,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,32,"E"))) - S:$D(REC(130,IEN,33)) REC(130,IEN,33,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,33,"E"))) - S:$D(REC(130,IEN,34)) REC(130,IEN,34,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,34,"E"))) - S:$D(REC(130,IEN,.04)) REC(130,IEN,.04,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,.04,"E"))) - S:$D(REC(130,IEN,125)) REC(130,IEN,125,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,125,"E"))) - I $L($G(REC(130,IEN,33,"S"))) D - . S:'$L($G(REC(130,IEN,66,"E"))) REC(130,IEN,33,"S")=$G(REC(130,IEN,33,"S"))_" (Unknown)" - . S:$L($G(REC(130,IEN,66,"E"))) REC(130,IEN,33,"S")=$G(REC(130,IEN,33,"S"))_" (ICD "_$G(REC(130,IEN,66,"E"))_")" - S:+($G(REC(130,IEN,.09,"I")))>0 REC(130,IEN,.09,"S")=$$ED^SROGMTS0($G(REC(130,IEN,.09,"I"))) - S:+($G(REC(130,IEN,15,"I")))>0 REC(130,IEN,15,"S")=$$EDT^SROGMTS0($G(REC(130,IEN,15,"I"))) - S:+($G(REC(130,IEN,39,"I"))) REC(130,IEN,39,"S")=$$EDT^SROGMTS0($G(REC(130,IEN,39,"I"))) - S:+SRSG REC(130,IEN,"LAB")=$S($O(REC(130,IEN,49,0))>0:"Yes",1:"") - I 'SRSG D:+($O(REC(130,IEN,55,0)))>0 WP(IEN,55,58) D:+($O(REC(130,IEN,59,0)))>0 WP(IEN,59,58) - Q -ED(X) ; external date - S X=$G(X) Q:'$L(X) "" - S X=$TR($$FMTE^XLFDT(X,"5DZ"),"@"," ") - Q X -EDT(X) ; external date and time - S X=$G(X) Q:'$L(X) "" - S X=$TR($$FMTE^XLFDT(X,"2ZM"),"@"," ") - Q X -WP(X,Y,Z) ; - N SRI,SRF,SRW,SRGI,DIWF,DIWL,DIWR - S SRI=+($G(X)) Q:SRI=0!('$D(REC(130,SRI))) - S SRF=+($G(Y)) Q:SRF=0!('$D(REC(130,SRI,SRF))) - S SRW=+($G(Z)) Q:SRW'>0!(SRW>79) - Q:+($O(REC(130,SRI,SRF,0)))'>0 - K ^UTILITY($J,"W") S DIWF="C"_SRW,DIWL=0,DIWR=0,SRGI=0 - F S SRGI=$O(REC(130,SRI,SRF,SRGI)) Q:+SRGI=0 D - . S X=$G(REC(130,SRI,SRF,SRGI)) - . D ^DIWP - S SRGI=0 F S SRGI=$O(^UTILITY($J,"W",0,SRGI)) Q:+SRGI=0 D - . S REC(130,SRI,SRF,"S",SRGI)=$G(^UTILITY($J,"W",0,SRGI,0)) - . S REC(130,SRI,SRF,"S",0)=$G(REC(130,SRI,SRF,"S",0))+1 - K ^UTILITY($J,"W") - Q -OS(X) ; Obtains status for OR procedures - N SRN S SRN=+($G(X)) S X="" I $G(REC(130,SRN,118,"I"))="Y" D Q X - . S:+($G(REC(130,SRN,122,"I")))>0 X="(Completed)" - . S:+($G(REC(130,SRN,121,"I")))>0&(+($G(REC(130,SRN,122,"I")))'>0) X="Incomplete" - . S:X="" X="Unknown" - I +($G(REC(130,SRN,17,"I")))>0 D Q X - . S X=$S(+($G(REC(130,SRN,.205,"I")))>0:"(Aborted)",1:"Cancelled") - I +($G(REC(130,SRN,.23,"I")))>0 S X="(Completed)" Q X - I +($G(REC(130,SRN,.22,"I")))>0 S X="Incomplete" Q X - I +($G(REC(130,SRN,10,"I")))>0 S X="Scheduled" Q X - I +($G(REC(130,SRN,36,"I")))>0,+($G(REC(130,SRN,.22,"I")))'>0 S X="Requested" Q X - S X="Unknown" - Q X -SUB ; - N DA,DR,DIC,DIQ,IENS,FILE,FLD,FLDS,FLDI,FLDA,FLDB,FLDR,FLDRT,SRM,SRC,SRI,SRJ,STXT,SNAM,SCOD,SUB - I +SRSG D - . ; - . ; ^SRF(DO,14,I) .72 Other Preop Diag 14;0 130.17 - . ; $P(^SRF(DO,14,I,0),U) .01 Other Preop Diag 0;1 Text - . ; - . S DA=IEN,(FILE,DIC)=130,SUB=130.17,DR=.72,DR(SUB)=".01",DIQ="REC(130,"_IEN_",",DIQ(0)="IE" - . K REC(SUB) S SRI=0 F S SRI=$O(^SRF(+($G(IEN)),14,SRI)) Q:+SRI=0 D - . . S DA(SUB)=SRI - . . D EN^DIQ1 - . . S REC(130,IEN,130.17,SRI,.01,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,130.17,SRI,.01,"E"))) - . ; - . ; ^SRF(DO,15,I) .74 Other Postop Diags 15;0 130.18 - . ; $P(^SRF(DO,15,I,0),U) .01 Other Postop Diags 0;1 Text - . ; - . S DA=IEN,(FILE,DIC)=130,SUB=130.18,DR=.74,DR(SUB)=".01",DIQ="REC(130,"_IEN_",",DIQ(0)="IE" - . K REC(SUB) S SRI=0 F S SRI=$O(^SRF(+($G(IEN)),15,SRI)) Q:+SRI=0 D - . . S DA(SUB)=SRI - . . D EN^DIQ1 - . . S REC(130,IEN,130.18,SRI,.01,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,130.18,SRI,.01,"E"))) - ; - ; ^SRF(SRN,"OPMOD",I) 28 Pri Pro CPT Mod OPMOD;0 130.028 - ; $P(^SRF(SRN,"OPMOD",I,0),U) .01 Pri Pro CPT Mod 0;1 Ptr 81.3 - ; - I SRCPTM D - . S DA=IEN,(FILE,DIC)=130,SUB=130.028,DR=28,DR(SUB)=".01",DIQ="REC(130,"_IEN_",",DIQ(0)="IE" - . K REC(SUB) S SRI=0 F S SRI=$O(^SRF(+($G(IEN)),"OPMOD",SRI)) Q:+SRI=0 D - . . S DA(SUB)=SRI - . . D EN^DIQ1 - . . S SRM=+($G(REC(130,+($G(IEN)),SUB,+($G(SRI)),.01,"I"))) I SRM>0 D MOD(SRM,FILE,SUB) - ; - ; ^SRF(DO,13,I) .42 Other Proc 13;0 130.16 - ; $P(^SRF(DO,13,I,0),U) .01 Other Proc 0;1 Text - ; $P(^SRF(DO,13,I,2),U) 3 Other Proc CPT Code 2;1 Ptr 81 - ; - S DA=IEN,(FILE,DIC)=130,SUB=130.16,DR=.42,DR(SUB)=".01;3",DIQ="REC(130,"_IEN_",",DIQ(0)="IE" - K REC(SUB) S SRI=0 F S SRI=$O(^SRF(+($G(IEN)),13,SRI)) Q:+SRI=0 D - . S DA(SUB)=SRI - . D EN^DIQ1 S SRM=+($G(REC(130,IEN,130.16,SRI,3,"I"))) - . S:SRM>0 REC(130,IEN,130.16,SRI,3,"N")=$P($$CPT^ICPTCOD(+SRM,$P($G(^SRF(IEN,0)),"^",9)),"^",3) - . N SRT,SRS,SRC S SRM=$G(REC(130,IEN,130.16,SRI,3,"I")) I SRM>0 D - . . S SRC=$$CPT^ICPTCOD(SRM,$P($G(^SRF(IEN,0)),"^",9)),(SRCS,SRS)=$$EN2^SROGMTS0($P(SRC,"^",3)) - . . S REC(130,IEN,130.16,SRI,3,"X")=$P(SRC,"^",2)_"^"_$P(SRC,"^",3) - . . S SRC=$P(SRC,"^",2) - . . S SRT=$$EN2^SROGMTS0($G(REC(130,IEN,130.16,SRI,.01,"E"))) - . . S:$L(SRS)&(SRS'=SRT) SRT=SRT_" - "_$$EN2^SROGMTS0(SRS) - . . S:$L(SRC)=5 SRT=SRT_" (CPT "_SRC_")",SRCS=SRCS_" (CPT "_SRC_")" - . . S REC(130,IEN,130.16,SRI,3,"N")=SRS - . . S REC(130,IEN,130.16,SRI,.01,"S")=SRT - . . S REC(130,IEN,130.16,SRI,3,"S")=SRCS - . ; - . ; ^SRF(8,13,2,"MOD",0) 4 Oth Proc CPT Mod MOD;0 130.164 - . ; ^SRF(8,13,2,"MOD",1,0) .01 Oth Proc CPT Mod 0;1 Ptr 81.3 - . ; - . I SRCPTM D - . . N SRJ S SRJ=0 F S SRJ=$O(^SRF(+($G(IEN)),13,SRI,"MOD",SRJ)) Q:+SRJ=0 D - . . . N DA,FILE,DIC,SUB,DR,DIQ S DA=IEN,DR=.42,FILE=130,SUB=130.16,DR(SUB)="4",DA(SUB)=SRI,SUB=130.164,DR(SUB)=".01",DA(SUB)=SRJ,DIC=130,DIQ="REC(130,"_IEN_",130.16,"_SRI_",",DIQ(0)="IE" - . . . D EN^DIQ1 - . . . S SRM=+($G(REC(130,IEN,130.16,SRI,130.164,SRJ,.01,"I"))) - . . . I SRM>0 N SRMOD1 D - . . . . S SRMOD1=$$MOD^ICPTMOD(+SRM,"I",$P($G(^SRF(IEN,0)),"^",9)) - . . . . S SRC=$P(SRMOD1,"^",2) - . . . . S SRS=$P(SRMOD1,"^",3) - . . . . S REC(130,IEN,130.16,SRI,SUB,SRJ,.01,"MID")=SRC - . . . . S REC(130,IEN,130.16,SRI,SUB,SRJ,.01,"MOD")=SRS - . . . . S REC(130,IEN,130.16,SRI,SUB,SRJ,.01,"X")=SRC_"^"_SRS - . . . . S SRT=$$EN2^SROGMTS0(SRS) S:$L(SRC) SRT=SRT_" (CPT Mod "_SRC_")" - . . . . S REC(130,IEN,130.16,SRI,SUB,SRJ,.01,"S")=SRT - . . . K REC(130,IEN,130.16,SRI,130) - Q -SG(X) ; Surgical (Operative) Record - S X=$$GET1^DIQ(130,+($G(X)),118,"I") S X=$S(X["Y":0,1:1) Q X -CPT(SRM,SRDOO,SRFIL,SRFLD) ;Set CPT code into REC array - S SRC=$$CPT^ICPTCOD(SRM,SRDOO),(SRCS,SRS)=$$EN2^SROGMTS0($P(SRC,"^",3)) - S REC(SRFIL,IEN,SRFLD,"X")=$P(SRC,"^",2)_"^"_$P(SRC,"^",3) - S SRC=$P(SRC,"^",2),SRT=$$EN2^SROGMTS0($G(REC(130,IEN,26,"E"))) - S:$L(SRS)&(SRS'=SRT) SRT=SRT_" - "_SRS - S:$L(SRC)=5 SRT=SRT_" (CPT "_SRC_")",SRCS=SRCS_" (CPT "_SRC_")" - S REC(SRFIL,IEN,SRFLD,"N")=SRS - S:SRFIL=130 REC(130,IEN,26,"S")=SRT - S REC(SRFIL,IEN,SRFLD,"S")=SRT - S REC(SRFIL,IEN,SRFLD,"S")=SRCS - Q -MOD(SRM,SRFIL,SUB) ;Set CPT Modifier into REC array - S SRMOD=$$MOD^ICPTMOD(+SRM,"I",$P($G(^SRF(IEN,0)),"^",9)) - S SRC=$P(SRMOD,"^",2) - S SRS=$P(SRMOD,"^",3) - S REC(SRFIL,IEN,SUB,SRI,.01,"MID")=SRC - S REC(SRFIL,IEN,SUB,SRI,.01,"MOD")=SRS - S SRT=$$EN2^SROGMTS0(SRS) - S:$L(SRC) SRT=SRT_" (CPT Mod "_SRC_")" - S REC(SRFIL,IEN,SUB,SRI,.01,"S")=SRT - Q -SPD ;Obtain Surgery Procedure/Diagnosis Code File entry - S (FILE,DIC)=136,DA=+($G(IEN)),DIQ="REC(",DIQ(0)="IE" - S DR=".01;.02;.03;10" - D EN^DIQ1 - Q:'+$G(REC(FILE,IEN,10,"I")) - S SRM=+$G(REC(FILE,IEN,.02,"I")) - Q:'(SRM>0) D CPT(SRM,$P($G(^SRF(IEN,0)),"^",9),FILE,.02) - S SUB=136.01,DR=1,DR(SUB)=".01",DIQ="REC(136,"_IEN_"," - K REC(FILE,IEN,SUB) S SRI=0 F S SRI=$O(^SRO(FILE,(+$G(IEN)),DR,SRI)) Q:+SRI=0 D - .S DA(SUB)=SRI - .D EN^DIQ1 - .S SRM=REC(FILE,IEN,SUB,SRI,.01,"I") I SRM>0 D MOD(SRM,FILE,SUB) - N DA S DA=IEN,SUB=136.011,DR=11,DR(SUB)=".01;1" - K REC(FILE,IEN,SUB) S SRI=0 F S SRI=$O(^SRO(FILE,(+$G(IEN)),DR,SRI)) Q:+SRI=0 D - . S DA(SUB)=SRI - . D EN^DIQ1 - S $P(REC(130,IEN,26,"S"),"-",2)=" "_REC(FILE,IEN,.02,"S") - K REC(130,IEN,130.028) M REC(130,IEN,130.028)=REC(FILE,IEN,136.01) - Q +SROGMTS ;BIR/ADM - SURGERY HEALTH SUMMARY ; [ 08/08/01 7:12 AM ] + ;;3.0; Surgery ;**100,127**;24 Jun 93 + ; + ;** NOTICE: This routine is part of an implementation of a nationally + ;** controlled procedure. Local modifications to this routine + ;** are prohibited. + ; + ; Reference to $$MOD^ICPTMOD supported by DBIA #1996 + ; Reference to $$CPT^ICPTCOD supported by DBIA #1995 + ; + Q +HS(X) ; return case information for a surical or non-OR case + ; X - case number (IEN) in file 130 + K REC N SRCPTM,SRSG,DA,DR,DIC,DIQ,IEN,IENS,FILE,FLD,FLDS,FLDI + N FLDA,FLDB,FLDR,FLDRT,IEN,SRI,SRRT,SRT,SRS,SRC,SRCS + S SRCPTM=1 + Q:'$D(^SRF(X,0)) S (IENS,IEN,X)=+($G(X)),U="^" + S:'$D(DT) DT=$$HTFM^XLFDT($H,1) S:'$D(DTIME) DTIME=300 + S (FILE,DIC)=130,DA=+($G(X)),DIQ="REC(",DIQ(0)="IE" + S SRSG=$$SG(IEN),REC(130,IEN,118,"E")=$S(SRSG=0:"YES",1:""),REC(130,IEN,118,"I")=$S(SRSG=0:"Y",1:"") + S:+SRSG DR=".09;.04;.14;.164;.205;.22;.23;.31;10;15;17;26;27;32;34;36;39;43;49;50" + S:'SRSG DR=".09;.31;26;27;33;50;55;59;66;121;122;123;124;125" + D EN^DIQ1 S REC(130,IEN,"STATUS")=$$OS(IEN) S:+SRSG REC(130,IEN,"VERIFIED")=$S($G(REC(130,IEN,43,"I"))'="Y":"(Unverified)",1:"") + S SRM=$G(REC(130,IEN,27,"I")) I SRM>0 D + . S SRC=$$CPT^ICPTCOD(SRM,$P($G(^SRF(IEN,0)),"^",9)),(SRCS,SRS)=$$EN2^SROGMTS0($P(SRC,"^",3)) + . S REC(130,IEN,27,"X")=$P(SRC,"^",2)_"^"_$P(SRC,"^",3) + . S SRC=$P(SRC,"^",2),SRT=$$EN2^SROGMTS0($G(REC(130,IEN,26,"E"))) + . S:$L(SRS)&(SRS'=SRT) SRT=SRT_" - "_SRS + . S:$L(SRC)=5 SRT=SRT_" (CPT "_SRC_")",SRCS=SRCS_" (CPT "_SRC_")" + . S REC(130,IEN,27,"N")=SRS + . S (REC(130,IEN,26,"S"),REC(130,IEN,27,"S"))=SRT + . S REC(130,IEN,27,"S")=SRCS + D DICT^SROGMTS0,SUB + S:$D(REC(130,IEN,32)) REC(130,IEN,32,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,32,"E"))) + S:$D(REC(130,IEN,33)) REC(130,IEN,33,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,33,"E"))) + S:$D(REC(130,IEN,34)) REC(130,IEN,34,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,34,"E"))) + S:$D(REC(130,IEN,.04)) REC(130,IEN,.04,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,.04,"E"))) + S:$D(REC(130,IEN,125)) REC(130,IEN,125,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,125,"E"))) + I $L($G(REC(130,IEN,33,"S"))) D + . S:'$L($G(REC(130,IEN,66,"E"))) REC(130,IEN,33,"S")=$G(REC(130,IEN,33,"S"))_" (Unknown)" + . S:$L($G(REC(130,IEN,66,"E"))) REC(130,IEN,33,"S")=$G(REC(130,IEN,33,"S"))_" (ICD "_$G(REC(130,IEN,66,"E"))_")" + S:+($G(REC(130,IEN,.09,"I")))>0 REC(130,IEN,.09,"S")=$$ED^SROGMTS0($G(REC(130,IEN,.09,"I"))) + S:+($G(REC(130,IEN,15,"I")))>0 REC(130,IEN,15,"S")=$$EDT^SROGMTS0($G(REC(130,IEN,15,"I"))) + S:+($G(REC(130,IEN,39,"I"))) REC(130,IEN,39,"S")=$$EDT^SROGMTS0($G(REC(130,IEN,39,"I"))) + S:+SRSG REC(130,IEN,"LAB")=$S($O(REC(130,IEN,49,0))>0:"Yes",1:"") + I 'SRSG D:+($O(REC(130,IEN,55,0)))>0 WP(IEN,55,58) D:+($O(REC(130,IEN,59,0)))>0 WP(IEN,59,58) + Q +ED(X) ; external date + S X=$G(X) Q:'$L(X) "" + S X=$TR($$FMTE^XLFDT(X,"5DZ"),"@"," ") + Q X +EDT(X) ; external date and time + S X=$G(X) Q:'$L(X) "" + S X=$TR($$FMTE^XLFDT(X,"2ZM"),"@"," ") + Q X +WP(X,Y,Z) ; + N SRI,SRF,SRW,SRGI,DIWF,DIWL,DIWR + S SRI=+($G(X)) Q:SRI=0!('$D(REC(130,SRI))) + S SRF=+($G(Y)) Q:SRF=0!('$D(REC(130,SRI,SRF))) + S SRW=+($G(Z)) Q:SRW'>0!(SRW>79) + Q:+($O(REC(130,SRI,SRF,0)))'>0 + K ^UTILITY($J,"W") S DIWF="C"_SRW,DIWL=0,DIWR=0,SRGI=0 + F S SRGI=$O(REC(130,SRI,SRF,SRGI)) Q:+SRGI=0 D + . S X=$G(REC(130,SRI,SRF,SRGI)) + . D ^DIWP + S SRGI=0 F S SRGI=$O(^UTILITY($J,"W",0,SRGI)) Q:+SRGI=0 D + . S REC(130,SRI,SRF,"S",SRGI)=$G(^UTILITY($J,"W",0,SRGI,0)) + . S REC(130,SRI,SRF,"S",0)=$G(REC(130,SRI,SRF,"S",0))+1 + K ^UTILITY($J,"W") + Q +OS(X) ; Obtains status for OR procedures + N SRN S SRN=+($G(X)) S X="" I $G(REC(130,SRN,118,"I"))="Y" D Q X + . S:+($G(REC(130,SRN,122,"I")))>0 X="(Completed)" + . S:+($G(REC(130,SRN,121,"I")))>0&(+($G(REC(130,SRN,122,"I")))'>0) X="Incomplete" + . S:X="" X="Unknown" + I +($G(REC(130,SRN,17,"I")))>0 D Q X + . S X=$S(+($G(REC(130,SRN,.205,"I")))>0:"(Aborted)",1:"Cancelled") + I +($G(REC(130,SRN,.23,"I")))>0 S X="(Completed)" Q X + I +($G(REC(130,SRN,.22,"I")))>0 S X="Incomplete" Q X + I +($G(REC(130,SRN,10,"I")))>0 S X="Scheduled" Q X + I +($G(REC(130,SRN,36,"I")))>0,+($G(REC(130,SRN,.22,"I")))'>0 S X="Requested" Q X + S X="Unknown" + Q X +SUB ; + N DA,DR,DIC,DIQ,IENS,FILE,FLD,FLDS,FLDI,FLDA,FLDB,FLDR,FLDRT,SRM,SRC,SRI,SRJ,STXT,SNAM,SCOD,SUB + I +SRSG D + . ; + . ; ^SRF(DO,14,I) .72 Other Preop Diag 14;0 130.17 + . ; $P(^SRF(DO,14,I,0),U) .01 Other Preop Diag 0;1 Text + . ; + . S DA=IEN,(FILE,DIC)=130,SUB=130.17,DR=.72,DR(SUB)=".01",DIQ="REC(130,"_IEN_",",DIQ(0)="IE" + . K REC(SUB) S SRI=0 F S SRI=$O(^SRF(+($G(IEN)),14,SRI)) Q:+SRI=0 D + . . S DA(SUB)=SRI + . . D EN^DIQ1 + . . S REC(130,IEN,130.17,SRI,.01,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,130.17,SRI,.01,"E"))) + . ; + . ; ^SRF(DO,15,I) .74 Other Postop Diags 15;0 130.18 + . ; $P(^SRF(DO,15,I,0),U) .01 Other Postop Diags 0;1 Text + . ; + . S DA=IEN,(FILE,DIC)=130,SUB=130.18,DR=.74,DR(SUB)=".01",DIQ="REC(130,"_IEN_",",DIQ(0)="IE" + . K REC(SUB) S SRI=0 F S SRI=$O(^SRF(+($G(IEN)),15,SRI)) Q:+SRI=0 D + . . S DA(SUB)=SRI + . . D EN^DIQ1 + . . S REC(130,IEN,130.18,SRI,.01,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,130.18,SRI,.01,"E"))) + ; + ; ^SRF(SRN,"OPMOD",I) 28 Pri Pro CPT Mod OPMOD;0 130.028 + ; $P(^SRF(SRN,"OPMOD",I,0),U) .01 Pri Pro CPT Mod 0;1 Ptr 81.3 + ; + I SRCPTM D + . S DA=IEN,(FILE,DIC)=130,SUB=130.028,DR=28,DR(SUB)=".01",DIQ="REC(130,"_IEN_",",DIQ(0)="IE" + . K REC(SUB) S SRI=0 F S SRI=$O(^SRF(+($G(IEN)),"OPMOD",SRI)) Q:+SRI=0 D + . . S DA(SUB)=SRI + . . D EN^DIQ1 + . . S SRM=+($G(REC(130,+($G(IEN)),SUB,+($G(SRI)),.01,"I"))) + . . I SRM>0 N SRMOD D + . . . S SRMOD=$$MOD^ICPTMOD(+SRM,"I",$P($G(^SRF(IEN,0)),"^",9)) + . . . S SRC=$P(SRMOD,"^",2) + . . . S SRS=$P(SRMOD,"^",3) + . . . S REC(130,IEN,SUB,SRI,.01,"MID")=SRC + . . . S REC(130,IEN,SUB,SRI,.01,"MOD")=SRS + . . . S SRT=$$EN2^SROGMTS0(SRS) + . . . S:$L(SRC) SRT=SRT_" (CPT Mod "_SRC_")" + . . . S REC(130,IEN,SUB,SRI,.01,"S")=SRT + ; + ; ^SRF(DO,13,I) .42 Other Proc 13;0 130.16 + ; $P(^SRF(DO,13,I,0),U) .01 Other Proc 0;1 Text + ; $P(^SRF(DO,13,I,2),U) 3 Other Proc CPT Code 2;1 Ptr 81 + ; + S DA=IEN,(FILE,DIC)=130,SUB=130.16,DR=.42,DR(SUB)=".01;3",DIQ="REC(130,"_IEN_",",DIQ(0)="IE" + K REC(SUB) S SRI=0 F S SRI=$O(^SRF(+($G(IEN)),13,SRI)) Q:+SRI=0 D + . S DA(SUB)=SRI + . D EN^DIQ1 S SRM=+($G(REC(130,IEN,130.16,SRI,3,"I"))) + . S:SRM>0 REC(130,IEN,130.16,SRI,3,"N")=$P($$CPT^ICPTCOD(+SRM,$P($G(^SRF(IEN,0)),"^",9)),"^",3) + . N SRT,SRS,SRC S SRM=$G(REC(130,IEN,130.16,SRI,3,"I")) I SRM>0 D + . . S SRC=$$CPT^ICPTCOD(SRM,$P($G(^SRF(IEN,0)),"^",9)),(SRCS,SRS)=$$EN2^SROGMTS0($P(SRC,"^",3)) + . . S REC(130,IEN,130.16,SRI,3,"X")=$P(SRC,"^",2)_"^"_$P(SRC,"^",3) + . . S SRC=$P(SRC,"^",2) + . . S SRT=$$EN2^SROGMTS0($G(REC(130,IEN,130.16,SRI,.01,"E"))) + . . S:$L(SRS)&(SRS'=SRT) SRT=SRT_" - "_$$EN2^SROGMTS0(SRS) + . . S:$L(SRC)=5 SRT=SRT_" (CPT "_SRC_")",SRCS=SRCS_" (CPT "_SRC_")" + . . S REC(130,IEN,130.16,SRI,3,"N")=SRS + . . S REC(130,IEN,130.16,SRI,.01,"S")=SRT + . . S REC(130,IEN,130.16,SRI,3,"S")=SRCS + . ; + . ; ^SRF(8,13,2,"MOD",0) 4 Oth Proc CPT Mod MOD;0 130.164 + . ; ^SRF(8,13,2,"MOD",1,0) .01 Oth Proc CPT Mod 0;1 Ptr 81.3 + . ; + . I SRCPTM D + . . N SRJ S SRJ=0 F S SRJ=$O(^SRF(+($G(IEN)),13,SRI,"MOD",SRJ)) Q:+SRJ=0 D + . . . N DA,FILE,DIC,SUB,DR,DIQ S DA=IEN,DR=.42,FILE=130,SUB=130.16,DR(SUB)="4",DA(SUB)=SRI,SUB=130.164,DR(SUB)=".01",DA(SUB)=SRJ,DIC=130,DIQ="REC(130,"_IEN_",130.16,"_SRI_",",DIQ(0)="IE" + . . . D EN^DIQ1 + . . . S SRM=+($G(REC(130,IEN,130.16,SRI,130.164,SRJ,.01,"I"))) + . . . I SRM>0 N SRMOD1 D + . . . . S SRMOD1=$$MOD^ICPTMOD(+SRM,"I",$P($G(^SRF(IEN,0)),"^",9)) + . . . . S SRC=$P(SRMOD1,"^",2) + . . . . S SRS=$P(SRMOD1,"^",3) + . . . . S REC(130,IEN,130.16,SRI,SUB,SRJ,.01,"MID")=SRC + . . . . S REC(130,IEN,130.16,SRI,SUB,SRJ,.01,"MOD")=SRS + . . . . S REC(130,IEN,130.16,SRI,SUB,SRJ,.01,"X")=SRC_"^"_SRS + . . . . S SRT=$$EN2^SROGMTS0(SRS) S:$L(SRC) SRT=SRT_" (CPT Mod "_SRC_")" + . . . . S REC(130,IEN,130.16,SRI,SUB,SRJ,.01,"S")=SRT + . . . K REC(130,IEN,130.16,SRI,130) + Q +SG(X) ; Surgical (Operative) Record + S X=$$GET1^DIQ(130,+($G(X)),118,"I") S X=$S(X["Y":0,1:1) Q X diff --git a/r/SURGERY-SR/SROMED.m b/r/SURGERY-SR/SROMED.m index 5cb71353..5d91b514 100644 --- a/r/SURGERY-SR/SROMED.m +++ b/r/SURGERY-SR/SROMED.m @@ -1,50 +1,46 @@ -SROMED ;BIR/MAM - ENTER/EDIT MEDICATIONS ;01/30/08 - ;;3.0; Surgery ;**21,44,79,100,151,166**;24 Jun 93;Build 7 - ; - I '$D(^XUSEC("SROEDIT",DUZ))&'$D(^XUSEC("SROANES",DUZ)) W !!!,$C(7),"You must hold the SROEDIT key or the SROANES key to use this option !",! Q - D ^SROLOCK G:SROLOCK END Q:'$D(SRTN) - N SRLCK S SRLCK=$$LOCK^SROUTL(SRTN) I 'SRLCK G END -START S SRQ=0,SRSMED=1 G:SRTN<1 END W @IOF S SRF=0 R !!,"ENTER MEDICATION/DOSE(MG)/ROUTE/TIME: ",M:DTIME S:'$T M="^" G:M=""!(M="^") END S SRM=$P(M,"/",1),SRD=$P(M,"/",2),SRR=$P(M,"/",3),SRT=$P(M,"/",4) W !! - I M="?" W !!,"Enter the medication, dose, route and time, separated by slashes (/).",!,"The Medication and time MUST be included, however the route and dose",!,"can be omitted. i.e. 'MEDICATION/DOSE//TIME' will omit the route." - I M="?" W !!,"Enter '??' to get a list of available drugs.",! D RET G:SRQ END G START - I M?.E1C.E W !!,"Your answer has a control character in it, please re-type it.",! D RET G:SRQ END G START - S (X,SRMM)=SRM D - .N SRDIC,SRD S SRDIC=50,SRDIC(0)="EMQSZ",SRD="B^C" D MIX^PSSDI(50,"SR",.SRDIC,SRD,X,,DT) - S SRM=$S(Y<0:"",1:$P(Y,"^",2)) - I SRM="",SRMM'["?" W !!,"The Drug '",SRMM,"' does not exist in your Drug file. Please re-enter. " D RET G:SRQ END G START - I SRMM="??" D RET G:SRQ END G START - D TIME G:'$D(SRT) FLAG S X=SRT D FIELD^DID(130,.204,"","INPUT TRANSFORM","SRX") S SRX=SRX("INPUT TRANSFORM") X:SRT'="" SRX S SRT=$S(X="":SRT,1:X) D ROUTE G:'$D(SRR) FLAG D DOSE G:'$D(SRD) FLAG -FLAG S SRF=$S('$D(SRT)!('$D(SRD))!('$D(SRR)):0,1:1) I 'SRF W !!!,"NO ACTION TAKEN",! H 2 G END -DIE S DA=SRTN,DIE=130,DR=".375///"_SRM,DR(2,130.33)="1///"_SRT,DR(3,130.34)="1///"_SRD_";4///"_SRR D ^DIE W !!!,"MEDICATION ENTERED ...." K DR H 2 - G START -END W @IOF D ^SRSKILL D:$G(SRLCK) UNLOCK^SROUTL(SRTN) - Q -RET R !!,"Press RETURN to Continue. ",Z:DTIME S:'$T Z="^" S:Z="^" SRQ=1 Q - Q -ROUTE ; check for route of administration - Q:SRR="" N SRHELP,SRVALUE D CHK^DIE(130.34,4,"E",SRR,.SRVALUE) I SRVALUE'="^" S SRR=SRVALUE Q - D HELP^DIE(130.34,"",4,"S","SRHELP(1)") - W !!,"Route entered is not one of the available choices.",!,"Please enter medication route again.",!! - I $G(SRHELP(1,"DIHELP")) F I=1:1:SRHELP(1,"DIHELP") W SRHELP(1,"DIHELP",I),! - S DIR("A")="Enter ROUTE",DIR(0)="130.34,4O" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRR="" Q - S SRR=$P(Y,"^") - Q -TIME ; check for time - K %DT S X=SRT,%DT="R" D ^%DT I Y>0 Q - W:SRT="" !!,"A time MUST be entered !" - I '(SRT?1N!(SRT?2N&(SRT<13))!(SRT?4N)!(SRT?3N)!(SRT?2N1":"2N)!(SRT?1N1":"2N))!(+SRT>2400)!(SRT="") S SRF=1 - I SRF W !!,?5,"Enter the time in one of the following formats:",!,?9,"7:45, 0745, 745, 07:45, Date@Time, or NOW",!!,?5,"Time is required." -T1 S:SRT="" SRF=1 Q:SRF=0 R !!,"Enter Time: ",SRT:DTIME S:'$T!(SRT="") SRT="^" G:SRT["^" END W:SRT["?" !!,"Enter a time in the format above, or RETURN to bypass. An '^' will exit this option." G:SRT["?" T1 S SRF=0 G TIME - Q -DOSE ; check dosage - Q:SRD="" I $L(SRD)>15!($L(SRD)<1) W !!,"Dosage entered incorrectly." S SRF=1 - I SRD="?" W !!,"Dosage must be 1 to 15 characters in length, i.e. 15 mg." S SRF=1 -D1 I SRF=1 R !!,"ENTER DOSE: ",SRD1:DTIME S:'$T SRD1="^" K:SRD1["^" SRD Q:SRD1["^" W:SRD1["?" !!,"Dosage must be 1 to 15 characters in length" G:SRD1["?" D1 S SRD=SRD1,SRF=0 G DOSE - Q -SCR(SRFL,SRPK) ; screening for fields point to the DRUG file (#50) - N SRDT,SRN0,SRNODE,SROK,SRY S SROK=0,SRY=+Y K ^TMP($J,"SR") - I $G(SRFL)=1 S SRTN=$S($G(SRTN):SRTN,1:DA),SRN0=$G(^SRF(SRTN,0)),SRDT=$S($P(SRN0,"^",9):$P($P(SRN0,"^",9),"."),1:DT) - D DATA^PSS50(SRY,,$S($G(SRFL):SRDT,1:""),,,"SR") - I SRPK="S" D Q SROK - .S SRNODE=$P($G(^TMP($J,"SR",SRY,63)),"^") K ^TMP($J,"SR") I SRNODE["S" S SROK=1 - S SROK=$S($P($G(^TMP($J,"SR",0)),"^")=-1:0,1:1) K ^TMP($J,"SR") Q SROK +SROMED ;B'HAM ISC/MAM - ENTER/EDIT MEDICATIONS ; [ 01/30/01 12:22 AM ] + ;;3.0; Surgery ;**21,44,79,100,151**;24 Jun 93 + ; + ; Reference to ^PSDRUG supported by DBIA #221 + ; + I '$D(^XUSEC("SROEDIT",DUZ))&'$D(^XUSEC("SROANES",DUZ)) W !!!,$C(7),"You must hold the SROEDIT key or the SROANES key to use this option !",! Q + D ^SROLOCK G:SROLOCK END Q:'$D(SRTN) + N SRLCK S SRLCK=$$LOCK^SROUTL(SRTN) I 'SRLCK G END +START S SRQ=0,SRSMED=1 G:SRTN<1 END W @IOF S SRF=0 R !!,"ENTER MEDICATION/DOSE(MG)/ROUTE/TIME: ",M:DTIME S:'$T M="^" G:M=""!(M="^") END S SRM=$P(M,"/",1),SRD=$P(M,"/",2),SRR=$P(M,"/",3),SRT=$P(M,"/",4) W !! + I M="?" W !!,"Enter the medication, dose, route and time, separated by slashes (/).",!,"The Medication and time MUST be included, however the route and dose",!,"can be omitted. i.e. 'MEDICATION/DOSE//TIME' will omit the route." + I M="?" W !!,"Enter '??' to get a list of available drugs.",! D RET G:SRQ END G START + I M?.E1C.E W !!,"Your answer has a control character in it, please re-type it.",! D RET G:SRQ END G START + S (X,SRMM)=SRM D + .I $L($T(SCREEN^PSSDI)) N SRTEST S SRTEST=50,SRTEST(0)="EQSZ" D DIC^PSSDI(50,"SR",.SRTEST,X,,DT) Q ;call PSSDI if PSS*1*104 is released + .S DIC="^PSDRUG(",DIC(0)="QEZM",DIC("S")="I $S('$G(^PSDRUG(Y,""I"")):1,DT'>^(""I""):1,1:0)" D ^DIC K DIC + S SRM=$S(Y<0:"",1:$P(Y,"^",2)) + I SRM="",SRMM'["?" W !!,"The Drug '",SRMM,"' does not exist in your Drug file. Please re-enter. " D RET G:SRQ END G START + I SRMM="??" D RET G:SRQ END G START + D TIME G:'$D(SRT) FLAG S X=SRT D FIELD^DID(130,.204,"","INPUT TRANSFORM","SRX") S SRX=SRX("INPUT TRANSFORM") X:SRT'="" SRX S SRT=$S(X="":SRT,1:X) D ROUTE G:'$D(SRR) FLAG D DOSE G:'$D(SRD) FLAG +FLAG S SRF=$S('$D(SRT)!('$D(SRD))!('$D(SRR)):0,1:1) I 'SRF W !!!,"NO ACTION TAKEN",! H 2 G END +DIE S DA=SRTN,DIE=130,DR=".375///"_SRM,DR(2,130.33)="1///"_SRT,DR(3,130.34)="1///"_SRD_";4///"_SRR D ^DIE W !!!,"MEDICATION ENTERED ...." K DR H 2 + G START +END W @IOF D ^SRSKILL D:$G(SRLCK) UNLOCK^SROUTL(SRTN) + Q +RET R !!,"Press RETURN to Continue. ",Z:DTIME S:'$T Z="^" S:Z="^" SRQ=1 Q + Q +ROUTE ; check for route of administration + Q:SRR="" N SRHELP,SRVALUE D CHK^DIE(130.34,4,"E",SRR,.SRVALUE) I SRVALUE'="^" S SRR=SRVALUE Q + D HELP^DIE(130.34,"",4,"S","SRHELP(1)") + W !!,"Route entered is not one of the available choices.",!,"Please enter medication route again.",!! + I $G(SRHELP(1,"DIHELP")) F I=1:1:SRHELP(1,"DIHELP") W SRHELP(1,"DIHELP",I),! + S DIR("A")="Enter ROUTE",DIR(0)="130.34,4O" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRR="" Q + S SRR=$P(Y,"^") + Q +TIME ; check for time + K %DT S X=SRT,%DT="R" D ^%DT I Y>0 Q + W:SRT="" !!,"A time MUST be entered !" + I '(SRT?1N!(SRT?2N&(SRT<13))!(SRT?4N)!(SRT?3N)!(SRT?2N1":"2N)!(SRT?1N1":"2N))!(+SRT>2400)!(SRT="") S SRF=1 + I SRF W !!,?5,"Enter the time in one of the following formats:",!,?9,"7:45, 0745, 745, 07:45, Date@Time, or NOW",!!,?5,"Time is required." +T1 S:SRT="" SRF=1 Q:SRF=0 R !!,"Enter Time: ",SRT:DTIME S:'$T!(SRT="") SRT="^" G:SRT["^" END W:SRT["?" !!,"Enter a time in the format above, or RETURN to bypass. An '^' will exit this option." G:SRT["?" T1 S SRF=0 G TIME + Q +DOSE ; check dosage + Q:SRD="" I $L(SRD)>15!($L(SRD)<1) W !!,"Dosage entered incorrectly." S SRF=1 + I SRD="?" W !!,"Dosage must be 1 to 15 characters in length, i.e. 15 mg." S SRF=1 +D1 I SRF=1 R !!,"ENTER DOSE: ",SRD1:DTIME S:'$T SRD1="^" K:SRD1["^" SRD Q:SRD1["^" W:SRD1["?" !!,"Dosage must be 1 to 15 characters in length" G:SRD1["?" D1 S SRD=SRD1,SRF=0 G DOSE + Q diff --git a/r/SURGERY-SR/SROWL.m b/r/SURGERY-SR/SROWL.m index 2e4fcbd8..65dc101a 100644 --- a/r/SURGERY-SR/SROWL.m +++ b/r/SURGERY-SR/SROWL.m @@ -1,79 +1,77 @@ -SROWL ;B'HAM ISC/MAM - ENTER PATIENT ON WAITING LIST ; 4/18/07 11:55am - ;;3.0;Surgery;**58,119,162**;24 Jun 93;Build 4 - ; -ENTER ; enter a patient on the waiting list - S SRSOUT=0 W @IOF K DIC S DIC(0)="QEAMZL",(DIC,DLAYGO)=133.8,DIC("A")=" Select Surgical Specialty: " D ^DIC K DIC,DLAYGO G:Y<0 END S SRSS=+Y,SRSS1=+Y(0) - S SRSSNM=$P(^SRO(137.45,SRSS1,0),"^") -PAT W ! S DIC=2,DIC(0)="QEAMZ",DIC("A")=" Select Patient: " D ^DIC K DIC I Y<0 W !!,"No action taken." G END - S DFN=+Y,SRNM=$P(Y(0),"^") I $D(^DPT(DFN,.35)),$P(^(.35),"^")'="" S Y=$E($P(^(.35),"^"),1,7) D D^DIQ W !!,"The records show that "_SRNM_" died on "_Y_".",! G PAT - I $O(^SRO(133.8,"AP",DFN,SRSS,0)) D CHK G:"Yy"'[ECYN END -OP W ! K DIR S DIR("A")=" Select Operative Procedure",DIR(0)="133.801,1" D ^DIR I $D(DTOUT)!$D(DUOUT) W !!,"No action taken." G END - S SROPER=Y - W ! D NOW^%DTC S SRSDT=% - K DD,DO,DIC,DR,DA S DIC(0)="L",DIC="^SRO(133.8,SRSS,1,",DA(1)=SRSS,X=DFN D FILE^DICN I +Y S SROFN=+Y - K DA,DIE,DR S DA=SRSS,DIE=133.8,DR="1///"_SRNM,DR(2,133.801)="1////"_SROPER_";2///"_SRSDT_";4T;W !;5T;6T;W !;3T",DR(3,133.8013)=".01T;1T;2T;3T;4T;5T" D ^DIE K DIE,DR - D WL^SROPCE1 I SRSOUT G DEL - W @IOF,!,SRNM_" has been entered on the waiting list",!,"for "_SRSSNM -END D PRESS,^SRSKILL W @IOF - Q -PRESS W ! K DIR S DIR("A")="Press RETURN to continue ",DIR(0)="FOA" D ^DIR K DIR - Q -DEL S DA(1)=SRSS,DA=SROFN,DIK="^SRO(133.8,"_DA(1)_",1," D ^DIK - W @IOF,!,"Classification information is incomplete. No action taken." G END - Q -HELP W !!,"Enter RETURN if you want to continue entering a new procedure on the waiting",!,"list for "_SRNM_". If the procedure you are about to enter appears",!,"above, enter 'NO' to quit this option." - W !!,"Press RETURN to continue " R X:DTIME - Q -CHK ; check for existing entries for a patient - W @IOF,!,"Procedure(s) already entered for "_SRNM,!,"on the Waiting List for "_SRSSNM,! - S SROFN=0 F S SROFN=$O(^SRO(133.8,"AP",DFN,SRSS,SROFN)) Q:'SROFN D LIST - W !!,"Do you wish to continue entering a new procedure for "_SRNM_" on",!,"the waiting list for "_SRSSNM_" ? YES// " R ECYN:DTIME I '$T!(ECYN["^") S ECYN="N" Q - S ECYN=$E(ECYN) S:"y"[ECYN ECYN="Y" - I "YNn"'[ECYN D HELP G CHK - Q -LIST ; list existing procedures for specialty selected - S SROPER=$P(^SRO(133.8,SRSS,1,SROFN,0),"^",2),SRDT=$P(^(0),"^",3),SROPDT=$P(^(0),"^",5),Y=SRDT D D^DIQ S SRDT=$E(Y,1,12) I SROPDT S Y=SROPDT D D^DIQ S SROPDT=$E(Y,1,12) - K SROP,MM,MMM S:$L(SROPER)<36 SROP(1)=SROPER I $L(SROPER)>35 S SROPER=SROPER_" " S SROPER=SROPER_" " F M=1:1 D LOOP Q:MMM="" - W !,SRNM,?40,"Date Entered on List:",?66,SRDT,!,?3,SROP(1),?40,"Tentative Operation Date: ",?66,SROPDT - I $D(SROP(2)) W !,?3,SROP(2) - W ! - Q -LOOP ; break procedure if greater than 36 characters - S SROP(M)="" F LOOP=1:1 S MM=$P(SROPER," "),MMM=$P(SROPER," ",2,200) Q:MMM="" Q:$L(SROP(M))+$L(MM)'<36 S SROP(M)=SROP(M)_MM_" ",SROPER=MMM - Q -REFPHY ; Look up Referring Physician in "New Person" file with filter and auto-populate Referring Physician demographic fields - N SRCONT,Y,SRDEMO - S SRCONT="" -PRMPT R !,"Is this a VA Physician from this facility? (Y/N): ",SRCONT:DTIME I '$T Q - I SRCONT["?" D G PRMPT - .W !!,"Enter 'Y' if you would like to select the Referring Physician from this facility's VA personnel.",!,"Enter 'N' to continue data entry.",! - S:SRCONT="" SRCONT="Y" - I SRCONT="^" S X="" Q - Q:(SRCONT'["Y")&(SRCONT'["y") - ; Store FileMan variables and arrays - M SRDABAK=DA,SRDICBAK=DIC,SRDZERO=D0,SRDRBAK=DR,SRXBAK=X,SRDOBAK=DO - ; Setup variables and call ^DIC to lookup REFERRING PHYSICIAN from NEW PERSON file - S DIC="^VA(200,",DIC(0)="E",DIC("B")=X - D ^DIC - ; Restore FileMan's variables and arrays - M DA=SRDABAK,DIC=SRDICBAK,D0=SRDZERO,DR=SRDRBAK,X=SRXBAK,DO=SRDOBAK - K SRCONT,SRDABAK,SRDICBAK,SRDZERO,SRDRBAK,SRXBAK,SRDOBAK - Q:Y="-1" ; Quit if no record was selected from the NEW PERSON file - S SRNPREC=$P(Y,U,1)_"," ;The record number of the NEW PERSON file - ; Retrieve demographic data from the NEW PERSON file. - D GETS^DIQ(200,SRNPREC,".01:.116;.132","","SRDEMO") - ; Build SRDEMO array for "stuffing" into REFERRING PHYSICIAN demographic fields - S X=SRDEMO(200,SRNPREC,".01") ;Name - S SRDEMO(1)=SRDEMO(200,SRNPREC,".111") ;Address - S:$L(SRDEMO(200,SRNPREC,".112"))>0 SRDEMO(1)=SRDEMO(1)_" "_SRDEMO(200,SRNPREC,".112") ;Concatenate Address 2 to single address - S:$L(SRDEMO(200,SRNPREC,".113"))>0 SRDEMO(1)=SRDEMO(1)_" "_SRDEMO(200,SRNPREC,".113") ;Concatenate Address 3 to single address - S SRDEMO(1)=$E(SRDEMO(1),1,75) - S SRDEMO(2)=SRDEMO(200,SRNPREC,".114") ;City - S SRDEMO(3)=SRDEMO(200,SRNPREC,".115") ;State - S SRDEMO(4)=SRDEMO(200,SRNPREC,".116") ;Zip - S SRDEMO(5)=SRDEMO(200,SRNPREC,".132") ;Office Phone - ; Set up DR array that FileMan will use, with a call to ^DIE, after this subroutine Quits to "stuff" the demographic data. - ; all fields except STATE will ignore input transform (SR*3.0*162) - S DIC("DR")="1////"_SRDEMO(1)_";2////"_SRDEMO(2)_";3///"_SRDEMO(3)_";4////"_SRDEMO(4)_";5////"_SRDEMO(5)_";6////"_$P(Y,U,1) - S DIC(0)="Z" ;Tells FileMan to file the data without any more user input - Q +SROWL ;B'HAM ISC/MAM - ENTER PATIENT ON WAITING LIST ;13 Feb 1989 11:32 AM + ;;3.0;Surgery;**58,119**;24 Jun 93 +ENTER ; enter a patient on the waiting list + S SRSOUT=0 W @IOF K DIC S DIC(0)="QEAMZL",(DIC,DLAYGO)=133.8,DIC("A")=" Select Surgical Specialty: " D ^DIC K DIC,DLAYGO G:Y<0 END S SRSS=+Y,SRSS1=+Y(0) + S SRSSNM=$P(^SRO(137.45,SRSS1,0),"^") +PAT W ! S DIC=2,DIC(0)="QEAMZ",DIC("A")=" Select Patient: " D ^DIC K DIC I Y<0 W !!,"No action taken." G END + S DFN=+Y,SRNM=$P(Y(0),"^") I $D(^DPT(DFN,.35)),$P(^(.35),"^")'="" S Y=$E($P(^(.35),"^"),1,7) D D^DIQ W !!,"The records show that "_SRNM_" died on "_Y_".",! G PAT + I $O(^SRO(133.8,"AP",DFN,SRSS,0)) D CHK G:"Yy"'[ECYN END +OP W ! K DIR S DIR("A")=" Select Operative Procedure",DIR(0)="133.801,1" D ^DIR I $D(DTOUT)!$D(DUOUT) W !!,"No action taken." G END + S SROPER=Y + W ! D NOW^%DTC S SRSDT=% + K DD,DO,DIC,DR,DA S DIC(0)="L",DIC="^SRO(133.8,SRSS,1,",DA(1)=SRSS,X=DFN D FILE^DICN I +Y S SROFN=+Y + K DA,DIE,DR S DA=SRSS,DIE=133.8,DR="1///"_SRNM,DR(2,133.801)="1////"_SROPER_";2///"_SRSDT_";4T;W !;5T;6T;W !;3T",DR(3,133.8013)=".01T;1T;2T;3T;4T;5T" D ^DIE K DIE,DR + D WL^SROPCE1 I SRSOUT G DEL + W @IOF,!,SRNM_" has been entered on the waiting list",!,"for "_SRSSNM +END D PRESS,^SRSKILL W @IOF + Q +PRESS W ! K DIR S DIR("A")="Press RETURN to continue ",DIR(0)="FOA" D ^DIR K DIR + Q +DEL S DA(1)=SRSS,DA=SROFN,DIK="^SRO(133.8,"_DA(1)_",1," D ^DIK + W @IOF,!,"Classification information is incomplete. No action taken." G END + Q +HELP W !!,"Enter RETURN if you want to continue entering a new procedure on the waiting",!,"list for "_SRNM_". If the procedure you are about to enter appears",!,"above, enter 'NO' to quit this option." + W !!,"Press RETURN to continue " R X:DTIME + Q +CHK ; check for existing entries for a patient + W @IOF,!,"Procedure(s) already entered for "_SRNM,!,"on the Waiting List for "_SRSSNM,! + S SROFN=0 F S SROFN=$O(^SRO(133.8,"AP",DFN,SRSS,SROFN)) Q:'SROFN D LIST + W !!,"Do you wish to continue entering a new procedure for "_SRNM_" on",!,"the waiting list for "_SRSSNM_" ? YES// " R ECYN:DTIME I '$T!(ECYN["^") S ECYN="N" Q + S ECYN=$E(ECYN) S:"y"[ECYN ECYN="Y" + I "YNn"'[ECYN D HELP G CHK + Q +LIST ; list existing procedures for specialty selected + S SROPER=$P(^SRO(133.8,SRSS,1,SROFN,0),"^",2),SRDT=$P(^(0),"^",3),SROPDT=$P(^(0),"^",5),Y=SRDT D D^DIQ S SRDT=$E(Y,1,12) I SROPDT S Y=SROPDT D D^DIQ S SROPDT=$E(Y,1,12) + K SROP,MM,MMM S:$L(SROPER)<36 SROP(1)=SROPER I $L(SROPER)>35 S SROPER=SROPER_" " S SROPER=SROPER_" " F M=1:1 D LOOP Q:MMM="" + W !,SRNM,?40,"Date Entered on List:",?66,SRDT,!,?3,SROP(1),?40,"Tentative Operation Date: ",?66,SROPDT + I $D(SROP(2)) W !,?3,SROP(2) + W ! + Q +LOOP ; break procedure if greater than 36 characters + S SROP(M)="" F LOOP=1:1 S MM=$P(SROPER," "),MMM=$P(SROPER," ",2,200) Q:MMM="" Q:$L(SROP(M))+$L(MM)'<36 S SROP(M)=SROP(M)_MM_" ",SROPER=MMM + Q +REFPHY ; Look up Referring Physician in "New Person" file with filter and auto-populate Referring Physician demographic fields + N SRCONT,Y,SRDEMO + S SRCONT="" +PRMPT R !,"Is this a VA Physician from this facility? (Y/N): ",SRCONT:DTIME I '$T Q + I SRCONT["?" D G PRMPT + .W !!,"Enter 'Y' if you would like to select the Referring Physician from this facility's VA personnel.",!,"Enter 'N' to continue data entry.",! + S:SRCONT="" SRCONT="Y" + I SRCONT="^" S X="" Q + Q:(SRCONT'["Y")&(SRCONT'["y") + ; Store FileMan variables and arrays + M SRDABAK=DA,SRDICBAK=DIC,SRDZERO=D0,SRDRBAK=DR,SRXBAK=X,SRDOBAK=DO + ; Setup variables and call ^DIC to lookup REFERRING PHYSICIAN from NEW PERSON file + S DIC="^VA(200,",DIC(0)="E",DIC("B")=X + D ^DIC + ; Restore FileMan's variables and arrays + M DA=SRDABAK,DIC=SRDICBAK,D0=SRDZERO,DR=SRDRBAK,X=SRXBAK,DO=SRDOBAK + K SRCONT,SRDABAK,SRDICBAK,SRDZERO,SRDRBAK,SRXBAK,SRDOBAK + Q:Y="-1" ; Quit if no record was selected from the NEW PERSON file + S SRNPREC=$P(Y,U,1)_"," ;The record number of the NEW PERSON file + ; Retrieve demographic data from the NEW PERSON file. + D GETS^DIQ(200,SRNPREC,".01:.116;.132","","SRDEMO") + ; Build SRDEMO array for "stuffing" into REFERRING PHYSICIAN demographic fields + S X=SRDEMO(200,SRNPREC,".01") ;Name + S SRDEMO(1)=SRDEMO(200,SRNPREC,".111") ;Address + S:$L(SRDEMO(200,SRNPREC,".112"))>0 SRDEMO(1)=SRDEMO(1)_" "_SRDEMO(200,SRNPREC,".112") ;Concatenate Address 2 to single address + S:$L(SRDEMO(200,SRNPREC,".113"))>0 SRDEMO(1)=SRDEMO(1)_" "_SRDEMO(200,SRNPREC,".113") ;Concatenate Address 3 to single address + S SRDEMO(1)=$E(SRDEMO(1),1,75) + S SRDEMO(2)=SRDEMO(200,SRNPREC,".114") ;City + S SRDEMO(3)=SRDEMO(200,SRNPREC,".115") ;State + S SRDEMO(4)=SRDEMO(200,SRNPREC,".116") ;Zip + S SRDEMO(5)=SRDEMO(200,SRNPREC,".132") ;Office Phone + ; Set up DR array that FileMan will use, with a call to ^DIE, after this subroutine Quits to "stuff" the demographic data. + S DIC("DR")="1///"_SRDEMO(1)_";2///"_SRDEMO(2)_";3///"_SRDEMO(3)_";4///"_SRDEMO(4)_";5///"_SRDEMO(5)_";6///"_$P(Y,U,1) + S DIC(0)="Z" ;Tells FileMan to file the data without any more user input + Q diff --git a/r/SURGERY-SR/SROXR4.m b/r/SURGERY-SR/SROXR4.m index f04edfee..b33d5a31 100644 --- a/r/SURGERY-SR/SROXR4.m +++ b/r/SURGERY-SR/SROXR4.m @@ -1,73 +1,57 @@ -SROXR4 ;BIR/MAM - CROSS REFERENCES ;11/05/07 - ;;3.0; Surgery ;**62,83,100,153,166**;24 Jun 93;Build 7 - Q -PRO ; stuff default prosthesis info - I '$D(SRTN) Q - S ^SRF(SRTN,1,DA,0)=^SRF(SRTN,1,DA,0)_"^"_$P(^SRO(131.9,X,0),"^",2,99) - I $D(^SRO(131.9,X,1)) S ^SRF(SRTN,1,DA,1)=^(1) - Q -CAN ; 'SET' logic of the 'ACAN' x-ref on the 'CANCEL REASON' - ; field in the SURGERY file (130) - S $P(^SRF(DA,30),"^",2)=$P(^SRO(135,X,0),"^",3) I $P(^SRO(135,X,0),"^",3)="" S $P(^SRF(DA,30),"^",2)="Y" - I $P(^SRF(DA,30),"^",3)="" S $P(^SRF(DA,30),"^",3)=DUZ - S SHEMP=$P($G(^SRF(DA,.2)),"^",10) I SHEMP,$D(^SRF(DA,"RA")) S ZTDESC="Clean up Risk Assessment Information, Canceled Case",ZTRTN="RISK^SROXR4",ZTDTH=$H,ZTSAVE("DA")="" D ^%ZTLOAD - Q -KCAN ; 'KILL' logic of the 'ACAN' x-ref on the 'CANCEL REASON' - ; field in the SURGERY file (130) - S $P(^SRF(DA,30),"^",2)="" I '$P($G(^SRF(DA,30)),"^") S $P(^SRF(DA,30),"^",3)="" - Q -AS ; 'SET' logic of the 'AS' x-ref on the SCHEDULED START TIME - ; field in the SURGERY file (130) - S OR=$P(^SRF(DA,0),"^",2) I 'OR Q - S ^SRF("AS",OR,X,DA)="" - Q -KAS ; 'KILL' logic of the 'AS' x-ref on the SCHEDULED FINISH TIME - ; field in the SURGERY file (130) - S OR=$P(^SRF(DA,0),"^",2) I 'OR Q - K ^SRF("AS",OR,X,DA) - Q -SCH ; 'SET' logic of the 'AC' x-ref of the REQUIRED FIELDS FOR SCHEDULING - ; field in the SURGERY SITE PARAMETERS file (133) - S MM=$O(^DD(130,"B",X,0)),$P(^SRO(133,DA(1),4,DA,0),"^",2)=MM K MM - Q -KSCH ; 'KILL' logic of the 'AC' x-ref of the REQUIRED FIELDS FOR SCHEDULING - ; field in the SURGERY SITE PARAMETERS file (133) - S $P(^SRO(133,DA(1),4,DA,0),"^",2)="" - Q -RISK ; clean up risk data for canceled cases - S DIE=130,DR="102///@;235///@;284///@;323///@" D ^DIE K DR,DA S ZTREQ="@" - Q -AQ ; set logic for AQ x-ref - N SRTD,SRLO D AQDT I SRTD'0 Q - . S ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+X)="" - . S ^TIU(8925.1,"ACL",38,TIUTTL,+X)="" - . D SACLKWIC(TIUTTL,TIUCLASS,+X) - . ; Now build x-ref for document classes - . S TIUCLASS=+$$DOCCLASS^TIULC1(+X) - . I TIUCLASS'>0 Q - . S ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+X)="" - . D SACLKWIC(TIUTTL,TIUCLASS,+X) - ; For Abbreviation and Print Name fields, just set the Synonym subscript - I $S(FLD=.02:1,FLD=.03:1,1:0) D Q - . N TIUDA - . Q:X']"" - . S TIUDA=$S(+$G(DA(1)):+$G(DA(1)),1:+$G(DA)) - . I $P($G(^TIU(8925.1,+TIUDA,0)),U,4)'="DOC" Q - . S TIUSTTS=$P($G(^TIU(8925.1,+TIUDA,0)),U,7) - . ;VMPELR P 224 allow the update of inactive titles - . ; Include only TEST or ACTIVE or INACTIVE TITLES - . I $S(TIUSTTS=10:0,TIUSTTS=11:0,TIUSTTS=13:0,1:1) Q - . S TIUTTL=$P($G(^TIU(8925.1,+TIUDA,0)),U) - . Q:TIUTTL']"" - . S X=$$UP^XLFSTR(X) - . Q:X=TIUTTL - . S TIUTTL=X_" <"_TIUTTL_">" - . ; First build x-ref for Clinical Documents & Immediate descendents - . S TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA) - . I TIUCLASS'>0 Q - . S ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)="" - . S ^TIU(8925.1,"ACL",38,TIUTTL,+TIUDA)="" - . ; Now build x-ref for document classes - . S TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA) - . I TIUCLASS'>0 Q - . S ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)="" - I FLD=.07 D Q - . N TIUDA - . S TIUDA=$S(+$G(DA(1)):+$G(DA(1)),1:+$G(DA)) - . I $P($G(^TIU(8925.1,+TIUDA,0)),U,4)'="DOC" Q - . S TIUSTTS=$P($G(^TIU(8925.1,+TIUDA,0)),U,7) - . ; Include only TEST or ACTIVE titles - . I $S(TIUSTTS=10:0,TIUSTTS=11:0,1:1) Q - . S TIUTTL=$P($G(^TIU(8925.1,+TIUDA,0)),U) - . Q:TIUTTL']"" - . ; First build x-ref for Clinical Documents & Immediate descendents - . S TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA) - . I TIUCLASS'>0 Q - . S ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)="" - . S ^TIU(8925.1,"ACL",38,TIUTTL,+TIUDA)="" - . D SACLKWIC(TIUTTL,TIUCLASS,+TIUDA) - . ; Now build x-ref for document classes - . S TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA) - . I TIUCLASS'>0 Q - . S ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)="" - . D SACLKWIC(TIUTTL,TIUCLASS,+TIUDA) - I FLD=.01 D - . N TIUDA - . S TIUDA=$S(+$G(DA(1)):+$G(DA(1)),1:+$G(DA)) - . I $P($G(^TIU(8925.1,+TIUDA,0)),U,4)'="DOC" Q - . S TIUSTTS=$P($G(^TIU(8925.1,+TIUDA,0)),U,7) - . ; Include only TEST or ACTIVE OR inactive titles - . I $S(TIUSTTS=10:0,TIUSTTS=11:0,TIUSTTS=13:0,1:1) Q - . ; First build x-ref for Clinical Documents & Immediate descendents - . S TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA) - . I TIUCLASS'>0 Q - . S ^TIU(8925.1,"ACL",TIUCLASS,X,+TIUDA)="" - . S ^TIU(8925.1,"ACL",38,X,+TIUDA)="" - . S TIUABV=$P($G(^TIU(8925.1,+TIUDA,0)),U,2) - . I TIUABV]"" S TIUABV=TIUABV_" <"_X_">" S ^TIU(8925.1,"ACL",TIUCLASS,TIUABV,+TIUDA)="",^TIU(8925.1,"ACL",38,TIUABV,+TIUDA)="" - . S TIUPN=$P($G(^TIU(8925.1,+TIUDA,0)),U,3) - . I TIUPN]"" S TIUPN=TIUPN_" <"_X_">" S ^TIU(8925.1,"ACL",TIUCLASS,TIUPN,+TIUDA)="",^TIU(8925.1,"ACL",38,TIUPN,+TIUDA)="" - . D SACLKWIC(X,TIUCLASS,+TIUDA) - . ; Now build x-ref for document classes - . S TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA) - . I TIUCLASS'>0 Q - . S ^TIU(8925.1,"ACL",TIUCLASS,X,+TIUDA)="" - . ;VMP/ELR PATCH 224 ADDED NEXT 4 LINES - . S TIUABV=$P($G(^TIU(8925.1,+TIUDA,0)),U,2) - . I TIUABV]"" S TIUABV=TIUABV_" <"_X_">" S ^TIU(8925.1,"ACL",TIUCLASS,TIUABV,+TIUDA)="" - . S TIUPN=$P($G(^TIU(8925.1,+TIUDA,0)),U,3) - . I TIUPN]"" S TIUPN=TIUPN_" <"_X_">" S ^TIU(8925.1,"ACL",TIUCLASS,TIUPN,+TIUDA)="" - . D SACLKWIC(X,TIUCLASS,+TIUDA) - Q -SACLKWIC(X,TIUCLASS,TIUDA) ; Set logic for KWIC analog - N TIUI,TIUJ,TIUC S TIUI=1 - F TIUJ=1:1:$L(X)+1 D - . S TIUC=$E(X,TIUJ) - . I "(,.?! '-/&:;)"[TIUC S TIUC=$E($E(X,TIUI,TIUJ-1),1,30),TIUI=TIUJ+1 - . I I $L(TIUC)>2,(^DD("KWIC")'[TIUC),(TIUC'=X) S (^TIU(8925.1,"ACL",TIUCLASS,TIUC_" <"_X_">",TIUDA),^TIU(8925.1,"ACL",38,TIUC_" <"_X_">",TIUDA))="" - Q -KACL(X,FLD) ; KILL Logic for ACL cross-reference - N TIUCLASS,TIUTTL,TIUDA - I FLD=10.01 D - . ; First remove x-ref for Clinical Documents & Immediate descendents - . S TIUCLASS=+$$CLINDOC^TIULC1(+X) - . S TIUTTL=$P($G(^TIU(8925.1,+X,0)),U) - . Q:TIUTTL']"" - . Q:X=TIUTTL - . K ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+X) - . K ^TIU(8925.1,"ACL",38,TIUTTL,+X) - . D KACLKWIC(TIUTTL,TIUCLASS,+X) - . ; Now remove x-ref for document classes - . S TIUCLASS=+$$DOCCLASS^TIULC1(+X) - . K ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+X) - . D KACLKWIC(TIUTTL,TIUCLASS,+X) - I $S(FLD=.02:1,FLD=.03:1,1:0) D Q - . N TIUDA - . Q:X']"" - . S TIUDA=$S(+$G(DA(1)):+$G(DA(1)),1:+$G(DA)) - . I $P($G(^TIU(8925.1,+TIUDA,0)),U,4)'="DOC" Q - . S TIUSTTS=$P($G(^TIU(8925.1,+TIUDA,0)),U,7) - . ; Include only TEST or ACTIVE or INACTIVE titles - . I $S(TIUSTTS=10:0,TIUSTTS=11:0,TIUSTTS=13:0,1:1) Q - . S TIUTTL=$P($G(^TIU(8925.1,+TIUDA,0)),U) - . Q:TIUTTL']"" - . S TIUTTL=X_" <"_TIUTTL_">" - . ; First build x-ref for Clinical Documents & Immediate descendents - . S TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA) - . I TIUCLASS'>0 Q - . K ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA) - . K ^TIU(8925.1,"ACL",38,TIUTTL,+TIUDA) - . ; Now build x-ref for document classes - . S TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA) - . I TIUCLASS'>0 Q - . K ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA) - I FLD=.07 D - . N TIUDA - . S TIUDA=$S(+$G(DA(1)):+$G(DA(1)),1:+$G(DA)) - . ; First remove x-ref for Clinical Documents & Immediate descendents - . S TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA) - . S TIUTTL=$P($G(^TIU(8925.1,+TIUDA,0)),U) - . Q:TIUTTL']"" - . K ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA) - . K ^TIU(8925.1,"ACL",38,TIUTTL,+TIUDA) - . D KACLKWIC(TIUTTL,TIUCLASS,+TIUDA) - . ; Now remove x-ref for document classes - . S TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA) - . K ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA) - . D KACLKWIC(TIUTTL,TIUCLASS,+TIUDA) - I FLD=.01 D - . N TIUDA,TIUABV,TIUPN - . S TIUDA=$S(+$G(DA(1)):+$G(DA(1)),1:+$G(DA)) - . ; First remove x-ref for Clinical Documents & Immediate descendents - . S TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA) - . K ^TIU(8925.1,"ACL",TIUCLASS,X,+TIUDA) - . K ^TIU(8925.1,"ACL",38,X,+TIUDA) - . S TIUABV=$P($G(^TIU(8925.1,+TIUDA,0)),U,2) - . I TIUABV]"" S TIUABV=TIUABV_" <"_X_">" K ^TIU(8925.1,"ACL",TIUCLASS,TIUABV,+TIUDA),^TIU(8925.1,"ACL",38,TIUABV,+TIUDA) - . S TIUPN=$P($G(^TIU(8925.1,+TIUDA,0)),U,3) - . I TIUPN]"" S TIUPN=TIUPN_" <"_X_">" K ^TIU(8925.1,"ACL",TIUCLASS,TIUPN,+TIUDA),^TIU(8925.1,"ACL",38,TIUPN,+TIUDA) - . D KACLKWIC(X,TIUCLASS,+TIUDA) - . ; Now remove x-ref for document classes - . S TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA) - . K ^TIU(8925.1,"ACL",TIUCLASS,X,+TIUDA) - . ;VMP/ELR PATCH 224 ADDED NEXT 4 LINES - . S TIUABV=$P($G(^TIU(8925.1,+TIUDA,0)),U,2) - . I TIUABV]"" S TIUABV=TIUABV_" <"_X_">" K ^TIU(8925.1,"ACL",TIUCLASS,TIUABV,+TIUDA) - . S TIUPN=$P($G(^TIU(8925.1,+TIUDA,0)),U,3) - . I TIUPN]"" S TIUPN=TIUPN_" <"_X_">" K ^TIU(8925.1,"ACL",TIUCLASS,TIUPN,+TIUDA) - . D KACLKWIC(X,TIUCLASS,+TIUDA) - Q -KACLKWIC(X,TIUCLASS,TIUDA) ; KILL Logic for KWIC analog - N TIUI,TIUJ,TIUC S TIUI=1 - F TIUJ=1:1:$L(X)+1 D - . S TIUC=$E(X,TIUJ) - . I "(,.?! '-/&:;)"[TIUC S TIUC=$E($E(X,TIUI,TIUJ-1),1,30),TIUI=TIUJ+1 - . I I $L(TIUC)>2 K ^TIU(8925.1,"ACL",TIUCLASS,TIUC_" <"_X_">",TIUDA),^TIU(8925.1,"ACL",38,TIUC_" <"_X_">",TIUDA) - Q +TIUDD1 ; SLC/JER - XREFs for file 8925.1 ;19-OCT-2001 10:05:37 [7/28/04 9:08am] + ;;1.0;TEXT INTEGRATION UTILITIES;**7,51,115,163**;Jun 20, 1997 +SACL(X,FLD) ; Set logic for ACL cross-reference + ; Called from fields .01 (NAME), .07 (STATUS), .03 (PRINT NAME), + ; .02 (ABBREVIATION), and Subfield .01 of ITEM sub-file + N TIUCLASS,TIUSTTS,TIUTTL + I FLD=10.01 D + . ; Include only TITLES in the index + . I $P($G(^TIU(8925.1,+X,0)),U,4)'="DOC" Q + . S TIUSTTS=$P($G(^TIU(8925.1,+X,0)),U,7) + . ; Include only TEST or ACTIVE titles + . I $S(TIUSTTS=10:0,TIUSTTS=11:0,1:1) Q + . S TIUTTL=$P($G(^TIU(8925.1,+X,0)),U) + . Q:TIUTTL']"" + . ; First build x-ref for Clinical Documents & Immediate descendents + . S TIUCLASS=+$$CLINDOC^TIULC1(+X) + . I TIUCLASS'>0 Q + . S ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+X)="" + . S ^TIU(8925.1,"ACL",38,TIUTTL,+X)="" + . D SACLKWIC(TIUTTL,TIUCLASS,+X) + . ; Now build x-ref for document classes + . S TIUCLASS=+$$DOCCLASS^TIULC1(+X) + . I TIUCLASS'>0 Q + . S ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+X)="" + . D SACLKWIC(TIUTTL,TIUCLASS,+X) + ; For Abbreviation and Print Name fields, just set the Synonym subscript + I $S(FLD=.02:1,FLD=.03:1,1:0) D Q + . N TIUDA + . Q:X']"" + . S TIUDA=$S(+$G(DA(1)):+$G(DA(1)),1:+$G(DA)) + . I $P($G(^TIU(8925.1,+TIUDA,0)),U,4)'="DOC" Q + . S TIUSTTS=$P($G(^TIU(8925.1,+TIUDA,0)),U,7) + . ; Include only TEST or ACTIVE titles + . I $S(TIUSTTS=10:0,TIUSTTS=11:0,1:1) Q + . S TIUTTL=$P($G(^TIU(8925.1,+TIUDA,0)),U) + . Q:TIUTTL']"" + . S X=$$UP^XLFSTR(X) + . Q:X=TIUTTL + . S TIUTTL=X_" <"_TIUTTL_">" + . ; First build x-ref for Clinical Documents & Immediate descendents + . S TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA) + . I TIUCLASS'>0 Q + . S ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)="" + . S ^TIU(8925.1,"ACL",38,TIUTTL,+TIUDA)="" + . ; Now build x-ref for document classes + . S TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA) + . I TIUCLASS'>0 Q + . S ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)="" + I FLD=.07 D Q + . N TIUDA + . S TIUDA=$S(+$G(DA(1)):+$G(DA(1)),1:+$G(DA)) + . I $P($G(^TIU(8925.1,+TIUDA,0)),U,4)'="DOC" Q + . S TIUSTTS=$P($G(^TIU(8925.1,+TIUDA,0)),U,7) + . ; Include only TEST or ACTIVE titles + . I $S(TIUSTTS=10:0,TIUSTTS=11:0,1:1) Q + . S TIUTTL=$P($G(^TIU(8925.1,+TIUDA,0)),U) + . Q:TIUTTL']"" + . ; First build x-ref for Clinical Documents & Immediate descendents + . S TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA) + . I TIUCLASS'>0 Q + . S ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)="" + . S ^TIU(8925.1,"ACL",38,TIUTTL,+TIUDA)="" + . D SACLKWIC(TIUTTL,TIUCLASS,+TIUDA) + . ; Now build x-ref for document classes + . S TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA) + . I TIUCLASS'>0 Q + . S ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA)="" + . D SACLKWIC(TIUTTL,TIUCLASS,+TIUDA) + I FLD=.01 D + . N TIUDA + . S TIUDA=$S(+$G(DA(1)):+$G(DA(1)),1:+$G(DA)) + . I $P($G(^TIU(8925.1,+TIUDA,0)),U,4)'="DOC" Q + . S TIUSTTS=$P($G(^TIU(8925.1,+TIUDA,0)),U,7) + . ; Include only TEST or ACTIVE titles + . I $S(TIUSTTS=10:0,TIUSTTS=11:0,1:1) Q + . ; First build x-ref for Clinical Documents & Immediate descendents + . S TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA) + . I TIUCLASS'>0 Q + . S ^TIU(8925.1,"ACL",TIUCLASS,X,+TIUDA)="" + . S ^TIU(8925.1,"ACL",38,X,+TIUDA)="" + . D SACLKWIC(X,TIUCLASS,+TIUDA) + . ; Now build x-ref for document classes + . S TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA) + . I TIUCLASS'>0 Q + . S ^TIU(8925.1,"ACL",TIUCLASS,X,+TIUDA)="" + . D SACLKWIC(X,TIUCLASS,+TIUDA) + Q +SACLKWIC(X,TIUCLASS,TIUDA) ; Set logic for KWIC analog + N TIUI,TIUJ,TIUC S TIUI=1 + F TIUJ=1:1:$L(X)+1 D + . S TIUC=$E(X,TIUJ) + . I "(,.?! '-/&:;)"[TIUC S TIUC=$E($E(X,TIUI,TIUJ-1),1,30),TIUI=TIUJ+1 + . I I $L(TIUC)>2,(^DD("KWIC")'[TIUC),(TIUC'=X) S (^TIU(8925.1,"ACL",TIUCLASS,TIUC_" <"_X_">",TIUDA),^TIU(8925.1,"ACL",38,TIUC_" <"_X_">",TIUDA))="" + Q +KACL(X,FLD) ; KILL Logic for ACL cross-reference + N TIUCLASS,TIUTTL,TIUDA + I FLD=10.01 D + . ; First remove x-ref for Clinical Documents & Immediate descendents + . S TIUCLASS=+$$CLINDOC^TIULC1(+X) + . S TIUTTL=$P($G(^TIU(8925.1,+X,0)),U) + . Q:TIUTTL']"" + . Q:X=TIUTTL + . K ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+X) + . K ^TIU(8925.1,"ACL",38,TIUTTL,+X) + . D KACLKWIC(TIUTTL,TIUCLASS,+X) + . ; Now remove x-ref for document classes + . S TIUCLASS=+$$DOCCLASS^TIULC1(+X) + . K ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+X) + . D KACLKWIC(TIUTTL,TIUCLASS,+X) + I $S(FLD=.02:1,FLD=.03:1,1:0) D Q + . N TIUDA + . Q:X']"" + . S TIUDA=$S(+$G(DA(1)):+$G(DA(1)),1:+$G(DA)) + . I $P($G(^TIU(8925.1,+TIUDA,0)),U,4)'="DOC" Q + . S TIUSTTS=$P($G(^TIU(8925.1,+TIUDA,0)),U,7) + . ; Include only TEST or ACTIVE titles + . I $S(TIUSTTS=10:0,TIUSTTS=11:0,1:1) Q + . S TIUTTL=$P($G(^TIU(8925.1,+TIUDA,0)),U) + . Q:TIUTTL']"" + . S TIUTTL=X_" <"_TIUTTL_">" + . ; First build x-ref for Clinical Documents & Immediate descendents + . S TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA) + . I TIUCLASS'>0 Q + . K ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA) + . K ^TIU(8925.1,"ACL",38,TIUTTL,+TIUDA) + . ; Now build x-ref for document classes + . S TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA) + . I TIUCLASS'>0 Q + . K ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA) + I FLD=.07 D + . N TIUDA + . S TIUDA=$S(+$G(DA(1)):+$G(DA(1)),1:+$G(DA)) + . ; First remove x-ref for Clinical Documents & Immediate descendents + . S TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA) + . S TIUTTL=$P($G(^TIU(8925.1,+TIUDA,0)),U) + . Q:TIUTTL']"" + . K ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA) + . K ^TIU(8925.1,"ACL",38,TIUTTL,+TIUDA) + . D KACLKWIC(TIUTTL,TIUCLASS,+TIUDA) + . ; Now remove x-ref for document classes + . S TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA) + . K ^TIU(8925.1,"ACL",TIUCLASS,TIUTTL,+TIUDA) + . D KACLKWIC(TIUTTL,TIUCLASS,+TIUDA) + I FLD=.01 D + . N TIUDA + . S TIUDA=$S(+$G(DA(1)):+$G(DA(1)),1:+$G(DA)) + . ; First remove x-ref for Clinical Documents & Immediate descendents + . S TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA) + . K ^TIU(8925.1,"ACL",TIUCLASS,X,+TIUDA) + . K ^TIU(8925.1,"ACL",38,X,+TIUDA) + . D KACLKWIC(X,TIUCLASS,+TIUDA) + . ; Now remove x-ref for document classes + . S TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA) + . K ^TIU(8925.1,"ACL",TIUCLASS,X,+TIUDA) + . D KACLKWIC(X,TIUCLASS,+TIUDA) + Q +KACLKWIC(X,TIUCLASS,TIUDA) ; KILL Logic for KWIC analog + N TIUI,TIUJ,TIUC S TIUI=1 + F TIUJ=1:1:$L(X)+1 D + . S TIUC=$E(X,TIUJ) + . I "(,.?! '-/&:;)"[TIUC S TIUC=$E($E(X,TIUI,TIUJ-1),1,30),TIUI=TIUJ+1 + . I I $L(TIUC)>2 K ^TIU(8925.1,"ACL",TIUCLASS,TIUC_" <"_X_">",TIUDA),^TIU(8925.1,"ACL",38,TIUC_" <"_X_">",TIUDA) + Q diff --git a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS.m b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS.m index 6125ab52..e20e1dff 100644 --- a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS.m +++ b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS.m @@ -1,8 +1,8 @@ -TIUEDS ; GENERATED FROM 'TIU ENTER/EDIT DS' INPUT TEMPLATE(#1491), FILE 8925;11/08/09 +TIUEDS ; GENERATED FROM 'TIU ENTER/EDIT DS' INPUT TEMPLATE(#1491), FILE 8925;03/29/06 D DE G BEGIN DE S DIE="^TIU(8925,",DIC=DIE,DP=8925,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^TIU(8925,DA,""))="" I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,2) S:%]"" DE(1)=% S %=$P(%Z,U,3) S:%]"" DE(2)=% S %=$P(%Z,U,7) S:%]"" DE(4)=% S %=$P(%Z,U,8) S:%]"" DE(7)=% S %=$P(%Z,U,9) S:%]"" DE(9)=% - I $D(^(12)) S %Z=^(12) S %=$P(%Z,U,2) S:%]"" DE(12)=%,DE(15)=% + I $D(^(12)) S %Z=^(12) S %=$P(%Z,U,2) S:%]"" DE(12)=% K %Z Q ; W W !?DL+DL-2,DLB_": " @@ -90,34 +90,7 @@ C1 G C1S:$D(DE(1))[0 K DB S X=DE(1),DIC=DIE D KAPTLD^TIUDD01(.02,X) C1S S X="" G:DG(DQ)=X C1F1 K DB - S X=DG(DQ),DIC=DIE - I $P($$DOCTYPE^TIULF(+DA),U)="DOC",$L($P(^TIU(8925,+DA,0),U)),(+$P(^(0),U,3)>0) S ^TIU(8925,"AA",+X,+^TIU(8925,+DA,0),(9999999-$P(+^AUPNVSIT($P(^TIU(8925,+DA,0),U,3),0),".")),+DA)="" - S X=DG(DQ),DIC=DIE - I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"APT",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" - S X=DG(DQ),DIC=DIE - I $P($$DOCTYPE^TIULF(+DA),U)="DOC",$L($P(^TIU(8925,+DA,0),U)),(+$P(^(0),U,3)>0) S ^TIU(8925,"AE",+X,(9999999-$P(+^AUPNVSIT($P(^TIU(8925,+DA,0),U,3),0),".")),+^TIU(8925,+DA,0),+DA)="" - S X=DG(DQ),DIC=DIE - S ^TIU(8925,"C",$E(X,1,30),DA)="" - S X=DG(DQ),DIC=DIE - I $P($$DOCTYPE^TIULF(+DA),U)="DOC",+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^(0)),U,3) S ^TIU(8925,"AV",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,3),+DA)="" - S X=DG(DQ),DIC=DIE - I +$$APTP^TIULX(+DA),+$P($G(^TIU(8925,+DA,15)),U) S ^TIU(8925,"APTP",+X,+$P($G(^TIU(8925,+DA,15)),U),+DA)="" - S X=DG(DQ),DIC=DIE - I +$P($G(^TIU(8925,+DA,0)),U,4),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ADCPT",+X,+$P(^TIU(8925,+DA,0),U,4),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" - S X=DG(DQ),DIC=DIE - I +$P(^TIU(8925,+DA,0),U),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"APTCL",+X,+$$CLINDOC^TIULC1(+$P(^TIU(8925,+DA,0),U),+DA),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" - S X=DG(DQ),DIC=DIE - I +$P(^TIU(8925,+DA,0),U),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"APTCL",+X,38,(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" - S X=DG(DQ),DIC=DIE - D SACLPT^TIUDD0(.02,X) - S X=DG(DQ),DIC=DIE - D SACLAU^TIUDD0(.02,X),SACLAU1^TIUDD0(.02,X) - S X=DG(DQ),DIC=DIE - D SACLEC^TIUDD0(.02,X) - S X=DG(DQ),DIC=DIE - D SACLSB^TIUDD0(.02,X) - S X=DG(DQ),DIC=DIE - D SAPTLD^TIUDD0(.02,X) + D ^TIUEDS1 C1F1 Q X1 Q 2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW="0;3",DV="P9000010'",DU="",DLB="VISIT",DIFLD=.03 @@ -145,7 +118,7 @@ C2 G C2S:$D(DE(2))[0 K DB S X=DE(2),DIC=DIE D KAPTLD^TIUDD01(.03,X) C2S S X="" G:DG(DQ)=X C2F1 K DB - D ^TIUEDS1 + D ^TIUEDS2 C2F1 Q X2 Q 3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 @@ -194,9 +167,9 @@ X11 I +$$PROVIDER^TIUPXAP1(DUZ,DT)'>0 S Y="@8" S Y=X G Y C12 G C12S:$D(DE(12))[0 K DB - D ^TIUEDS2 -C12S S X="" G:DG(DQ)=X C12F1 K DB D ^TIUEDS3 +C12S S X="" G:DG(DQ)=X C12F1 K DB + D ^TIUEDS4 C12F1 Q X12 S DIC("S")="I '+$$ISTERM^USRLM(+Y)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X Q @@ -205,19 +178,4 @@ X12 S DIC("S")="I '+$$ISTERM^USRLM(+Y)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X X13 S Y="@3" Q 14 S DQ=15 ;@8 -15 D:$D(DG)>9 F^DIE17,DE S DQ=15,DW="12;2",DV="*P200'R",DU="",DLB="AUTHOR/DICTATOR",DIFLD=1202 - S DE(DW)="C15^TIUEDS" - S DU="VA(200," - S X=$S($G(TIUAUTH):$$PERSNAME^TIULC1(TIUAUTH),1:"") - S Y=X - G Y -C15 G C15S:$D(DE(15))[0 K DB - D ^TIUEDS4 -C15S S X="" G:DG(DQ)=X C15F1 K DB - D ^TIUEDS5 -C15F1 Q -X15 S DIC("S")="I '+$$ISTERM^USRLM(+Y)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X - Q - ; -16 S DQ=17 ;@3 -17 D:$D(DG)>9 F^DIE17 G ^TIUEDS6 +15 D:$D(DG)>9 F^DIE17 G ^TIUEDS5 diff --git a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS1.m b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS1.m index a3e74cf4..7433373d 100644 --- a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS1.m +++ b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS1.m @@ -1,17 +1,29 @@ -TIUEDS1 ; ;11/08/09 +TIUEDS1 ; ;03/29/06 S X=DG(DQ),DIC=DIE - I $P($$DOCTYPE^TIULF(+DA),U)="DOC",$L($P(^TIU(8925,+DA,0),U)),(+$P(^(0),U,2)>0) S ^TIU(8925,"AA",$P(^(0),U,2),+$P(^(0),U),(9999999-$P(+$G(^AUPNVSIT(X,0)),".")),DA)="" + I $P($$DOCTYPE^TIULF(+DA),U)="DOC",$L($P(^TIU(8925,+DA,0),U)),(+$P(^(0),U,3)>0) S ^TIU(8925,"AA",+X,+^TIU(8925,+DA,0),(9999999-$P(+^AUPNVSIT($P(^TIU(8925,+DA,0),U,3),0),".")),+DA)="" S X=DG(DQ),DIC=DIE - I $P($$DOCTYPE^TIULF(+DA),U)="DOC",$L($P(^TIU(8925,+DA,0),U)),(+$P(^(0),U,2)>0) S ^TIU(8925,"AE",+$P(^TIU(8925,+DA,0),U,2),(9999999-$P(+$G(^AUPNVSIT(+X,0)),".")),+^TIU(8925,+DA,0),+DA)="" + I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"APT",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" S X=DG(DQ),DIC=DIE - I $P($$DOCTYPE^TIULF(+DA),U)="DOC",+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^(0)),U,2) S ^TIU(8925,"AV",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U),+X,+DA)="" + I $P($$DOCTYPE^TIULF(+DA),U)="DOC",$L($P(^TIU(8925,+DA,0),U)),(+$P(^(0),U,3)>0) S ^TIU(8925,"AE",+X,(9999999-$P(+^AUPNVSIT($P(^TIU(8925,+DA,0),U,3),0),".")),+^TIU(8925,+DA,0),+DA)="" S X=DG(DQ),DIC=DIE - D:$D(^AUPNVSIT(+X)) ADD^AUPNVSIT + S ^TIU(8925,"C",$E(X,1,30),DA)="" S X=DG(DQ),DIC=DIE - I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"AVSIT",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" + I $P($$DOCTYPE^TIULF(+DA),U)="DOC",+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^(0)),U,3) S ^TIU(8925,"AV",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,3),+DA)="" S X=DG(DQ),DIC=DIE - S ^TIU(8925,"V",$E(X,1,30),DA)="" + I +$$APTP^TIULX(+DA),+$P($G(^TIU(8925,+DA,15)),U) S ^TIU(8925,"APTP",+X,+$P($G(^TIU(8925,+DA,15)),U),+DA)="" S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^TIU(8925,D0,150)):^(150),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y X ^DD(8925,.03,1,7,1.1) X ^DD(8925,.03,1,7,1.4) + I +$P($G(^TIU(8925,+DA,0)),U,4),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ADCPT",+X,+$P(^TIU(8925,+DA,0),U,4),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" S X=DG(DQ),DIC=DIE - D SAPTLD^TIUDD0(.03,X) + I +$P(^TIU(8925,+DA,0),U),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"APTCL",+X,+$$CLINDOC^TIULC1(+$P(^TIU(8925,+DA,0),U),+DA),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" + S X=DG(DQ),DIC=DIE + I +$P(^TIU(8925,+DA,0),U),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"APTCL",+X,38,(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" + S X=DG(DQ),DIC=DIE + D SACLPT^TIUDD0(.02,X) + S X=DG(DQ),DIC=DIE + D SACLAU^TIUDD0(.02,X),SACLAU1^TIUDD0(.02,X) + S X=DG(DQ),DIC=DIE + D SACLEC^TIUDD0(.02,X) + S X=DG(DQ),DIC=DIE + D SACLSB^TIUDD0(.02,X) + S X=DG(DQ),DIC=DIE + D SAPTLD^TIUDD0(.02,X) diff --git a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS10.m b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS10.m index 83691141..d32842ae 100644 --- a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS10.m +++ b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS10.m @@ -1,5 +1,181 @@ -TIUEDS10 ; ;11/08/09 +TIUEDS10 ; ;03/29/06 + D DE G BEGIN +DE S DIE="^TIU(8925,",DIC=DIE,DP=8925,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^TIU(8925,DA,""))="" + I $D(^(12)) S %Z=^(12) S %=$P(%Z,U,4) S:%]"" DE(6)=% S %=$P(%Z,U,5) S:%]"" DE(12)=% S %=$P(%Z,U,8) S:%]"" DE(7)=% S %=$P(%Z,U,9) S:%]"" DE(1)=%,DE(4)=% S %=$P(%Z,U,12) S:%]"" DE(13)=% + I $D(^(14)) S %Z=^(14) S %=$P(%Z,U,1) S:%]"" DE(9)=% S %=$P(%Z,U,2) S:%]"" DE(10)=% S %=$P(%Z,U,4) S:%]"" DE(11)=% + I $D(^(15)) S %Z=^(15) S %=$P(%Z,U,6) S:%]"" DE(8)=% + K %Z Q + ; +W W !?DL+DL-2,DLB_": " + Q +O D W W Y W:$X>45 !?9 + I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 + W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q +TR R X:DTIME E S (DTOUT,X)=U W $C(7) + Q +A K DQ(DQ) S DQ=DQ+1 +B G @DQ +RE G PR:$D(DE(DQ)) D W,TR +N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A +RD G QS:X?."?" I X["^" D D G ^DIE17 + I X="@" D D G Z^DIE2 + I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X +T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V + K DDER G X +P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 + G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z + I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X +V D @("X"_DQ) K YS +Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A +X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 + S X="?BAD" +QS S DZ=X D D,QQ^DIEQ G B +D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q +Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N +PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP +R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R + I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R + X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% +RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 +I I DV'["I",DV'["#" G RD + D E^DIE0 G RD:$D(X),PR + Q +SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 + I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 + D ^DIR I 'DDER S %=Y(0),X=Y + Q +SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) + I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" + E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") + Q +NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS +KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") +BEGIN S DNM="TIUEDS10",DQ=1 +1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="12;9",DV="*P200'R",DU="",DLB="ATTENDING PHYSICIAN",DIFLD=1209 + S DU="VA(200," + G RE +X1 S DIC("S")="I '+$$ISTERM^USRLM(+Y),+$$PROVIDER^TIUPXAP1(+Y,DT)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X + Q + ; +2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X2 S Y="@10" + Q +3 S DQ=4 ;@9 +4 S DW="12;9",DV="*P200'",DU="",DLB="ATTENDING PHYSICIAN",DIFLD=1209 + S DU="VA(200," + G RE +X4 S DIC("S")="I '+$$ISTERM^USRLM(+Y),+$$PROVIDER^TIUPXAP1(+Y,DT)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X + Q + ; +5 S DQ=6 ;@10 +6 S DW="12;4",DV="P200'O",DU="",DLB="EXPECTED SIGNER",DIFLD=1204 + S DQ(6,2)="S Y(0)=Y S:+Y>0&$D(TIUSIG) Y=$S($L($P(^VA(200,+Y,20),U,2)):$P(^(20),U,2),1:$P(^VA(200,+Y,0),U)) S:+Y>0&'$D(TIUSIG) Y=$P(^VA(200,+Y,0),U)" + S DU="VA(200," + S X=$$WHOSIGNS^TIULC1(DA) + S Y=X + S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD:X="@",Z +X6 Q +7 S DW="12;8",DV="*P200'",DU="",DLB="EXPECTED COSIGNER",DIFLD=1208 + S DE(DW)="C7^TIUEDS10" + S DU="VA(200," + S X=$$WHOCOSIG^TIULC1(DA) + S Y=X + S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD:X="@",Z +C7 G C7S:$D(DE(7))[0 K DB + S X=DE(7),DIC=DIE + K ^TIU(8925,"CS",$E(X,1,30),DA) + S X=DE(7),DIC=DIE + I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ASUP",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA) + S X=DE(7),DIC=DIE + D KACLEC^TIUDD01(1208,X) +C7S S X="" G:DG(DQ)=X C7F1 K DB + S X=DG(DQ),DIC=DIE + S ^TIU(8925,"CS",$E(X,1,30),DA)="" + S X=DG(DQ),DIC=DIE + I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ASUP",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" + S X=DG(DQ),DIC=DIE + D SACLEC^TIUDD0(1208,X) +C7F1 Q +X7 Q +8 D:$D(DG)>9 F^DIE17,DE S DQ=8,DW="15;6",DV="S",DU="",DLB="COSIGNATURE NEEDED",DIFLD=1506 + S DU="1:YES;0:NO;" + S X=$S(+$P($G(^TIU(8925,+DA,12)),U,4)=+$P($G(^TIU(8925,+DA,12)),U,9):0,1:1) + S Y=X + S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD:X="@",Z +X8 Q +9 S DW="14;1",DV="P405'",DU="",DLB="PATIENT MOVEMENT RECORD",DIFLD=1401 + S DU="DGPM(" + S X=$G(TIU("AD#")) + S Y=X + S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD:X="@",Z +X9 Q +10 S DW="14;2",DV="P45.7'",DU="",DLB="TREATING SPECIALTY",DIFLD=1402 + S DE(DW)="C10^TIUEDS10" + S DU="DIC(45.7," + S X=$P($G(TIU("TS")),U) + S Y=X + S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD:X="@",Z +C10 G C10S:$D(DE(10))[0 K DB + S X=DE(10),DIC=DIE + K ^TIU(8925,"TS",$E(X,1,30),DA) + S X=DE(10),DIC=DIE + I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ATS",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA) +C10S S X="" G:DG(DQ)=X C10F1 K DB S X=DG(DQ),DIC=DIE S ^TIU(8925,"TS",$E(X,1,30),DA)="" S X=DG(DQ),DIC=DIE I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ATS",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" +C10F1 Q +X10 Q +11 D:$D(DG)>9 F^DIE17,DE S DQ=11,DW="14;4",DV="P49'",DU="",DLB="SERVICE",DIFLD=1404 + S DE(DW)="C11^TIUEDS10" + S DU="DIC(49," + S X=$P($G(TIU("SVC")),U) + S Y=X + S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD:X="@",Z +C11 G C11S:$D(DE(11))[0 K DB + S X=DE(11),DIC=DIE + I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ASVC",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA) + S X=DE(11),DIC=DIE + K ^TIU(8925,"SVC",$E(X,1,30),DA) +C11S S X="" G:DG(DQ)=X C11F1 K DB + S X=DG(DQ),DIC=DIE + I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ASVC",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" + S X=DG(DQ),DIC=DIE + S ^TIU(8925,"SVC",$E(X,1,30),DA)="" +C11F1 Q +X11 Q +12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW="12;5",DV="P44'",DU="",DLB="HOSPITAL LOCATION",DIFLD=1205 + S DE(DW)="C12^TIUEDS10" + S DU="SC(" + S X=$P($G(TIU("LOC")),U) + S Y=X + S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD:X="@",Z +C12 G C12S:$D(DE(12))[0 K DB + D ^TIUEDS11 +C12S S X="" G:DG(DQ)=X C12F1 K DB + D ^TIUEDS12 +C12F1 Q +X12 Q +13 D:$D(DG)>9 F^DIE17,DE S DQ=13,DW="12;12",DV="P4'",DU="",DLB="DIVISION",DIFLD=1212 + S DE(DW)="C13^TIUEDS10",DE(DW,"INDEX")=1 + S DU="DIC(4," + S X=$P($G(TIU("INST")),U) + S Y=X + S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD:X="@",Z +C13 G C13S:$D(DE(13))[0 K DB +C13S S X="" G:DG(DQ)=X C13F1 K DB + D ^TIUEDS13 +C13F1 S DIEZRXR(8925,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE))) + F DIXR=247 S DIEZRXR(8925,DIXR)="" + Q +X13 Q +14 G 0^DIE17 diff --git a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS11.m b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS11.m index 329b6222..cca6d4b2 100644 --- a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS11.m +++ b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS11.m @@ -1,5 +1,5 @@ -TIUEDS11 ; ;11/08/09 - S X=DE(28),DIC=DIE - I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ASVC",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA) - S X=DE(28),DIC=DIE - K ^TIU(8925,"SVC",$E(X,1,30),DA) +TIUEDS11 ; ;03/29/06 + S X=DE(12),DIC=DIE + I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ALOC",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA) + S X=DE(12),DIC=DIE + I +$P($G(^TIU(8925,+DA,15)),U) K ^TIU(8925,"ALOCP",+X,+$P($G(^TIU(8925,+DA,15)),U),+DA) diff --git a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS12.m b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS12.m index cfa42043..ad04a4a7 100644 --- a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS12.m +++ b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS12.m @@ -1,5 +1,5 @@ -TIUEDS12 ; ;11/08/09 +TIUEDS12 ; ;03/29/06 S X=DG(DQ),DIC=DIE - I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ASVC",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" + I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ALOC",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" S X=DG(DQ),DIC=DIE - S ^TIU(8925,"SVC",$E(X,1,30),DA)="" + I +$$ALOCP^TIULX(+DA),+$P($G(^TIU(8925,+DA,15)),U) S ^TIU(8925,"ALOCP",+X,+$P($G(^TIU(8925,+DA,15)),U),+DA)="" diff --git a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS13.m b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS13.m index 4c5a57fd..6366417d 100644 --- a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS13.m +++ b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS13.m @@ -1,84 +1 @@ -TIUEDS13 ; ;11/08/09 - D DE G BEGIN -DE S DIE="^TIU(8925,",DIC=DIE,DP=8925,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^TIU(8925,DA,""))="" - I $D(^(12)) S %Z=^(12) S %=$P(%Z,U,5) S:%]"" DE(1)=% S %=$P(%Z,U,12) S:%]"" DE(2)=% - K %Z Q - ; -W W !?DL+DL-2,DLB_": " - Q -O D W W Y W:$X>45 !?9 - I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 - W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q -TR R X:DTIME E S (DTOUT,X)=U W $C(7) - Q -A K DQ(DQ) S DQ=DQ+1 -B G @DQ -RE G PR:$D(DE(DQ)) D W,TR -N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A -RD G QS:X?."?" I X["^" D D G ^DIE17 - I X="@" D D G Z^DIE2 - I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X -T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V - K DDER G X -P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 - G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z - I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X -V D @("X"_DQ) K YS -Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A -X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 - S X="?BAD" -QS S DZ=X D D,QQ^DIEQ G B -D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q -Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N -PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP -R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R - I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R - X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% -RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 -I I DV'["I",DV'["#" G RD - D E^DIE0 G RD:$D(X),PR - Q -SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 - I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 - D ^DIR I 'DDER S %=Y(0),X=Y - Q -SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) - I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" - E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") - Q -NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS -KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") -BEGIN S DNM="TIUEDS13",DQ=1 -1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="12;5",DV="P44'",DU="",DLB="HOSPITAL LOCATION",DIFLD=1205 - S DE(DW)="C1^TIUEDS13" - S DU="SC(" - S X=$P($G(TIU("LOC")),U) - S Y=X - S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD:X="@",Z -C1 G C1S:$D(DE(1))[0 K DB - S X=DE(1),DIC=DIE - I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ALOC",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA) - S X=DE(1),DIC=DIE - I +$P($G(^TIU(8925,+DA,15)),U) K ^TIU(8925,"ALOCP",+X,+$P($G(^TIU(8925,+DA,15)),U),+DA) -C1S S X="" G:DG(DQ)=X C1F1 K DB - S X=DG(DQ),DIC=DIE - I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ALOC",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" - S X=DG(DQ),DIC=DIE - I +$$ALOCP^TIULX(+DA),+$P($G(^TIU(8925,+DA,15)),U) S ^TIU(8925,"ALOCP",+X,+$P($G(^TIU(8925,+DA,15)),U),+DA)="" -C1F1 Q -X1 Q -2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW="12;12",DV="P4'",DU="",DLB="DIVISION",DIFLD=1212 - S DE(DW)="C2^TIUEDS13",DE(DW,"INDEX")=1 - S DU="DIC(4," - S X=$P($G(TIU("INST")),U) - S Y=X - S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD:X="@",Z -C2 G C2S:$D(DE(2))[0 K DB -C2S S X="" G:DG(DQ)=X C2F1 K DB -C2F1 S DIEZRXR(8925,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE))) - F DIXR=247 S DIEZRXR(8925,DIXR)="" - Q -X2 Q -3 G 0^DIE17 +TIUEDS13 ; ;03/29/06 diff --git a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS14.m b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS14.m index 6e9abf33..2a065fa7 100644 --- a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS14.m +++ b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS14.m @@ -1,4 +1,4 @@ -TIUEDS14 ; ;11/08/09 +TIUEDS14 ; ;03/29/06 ;; 1 N X,X1,X2 S DIXR=247 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D diff --git a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS2.m b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS2.m index 2b01387e..7831bb64 100644 --- a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS2.m +++ b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS2.m @@ -1,11 +1,17 @@ -TIUEDS2 ; ;11/08/09 - S X=DE(12),DIC=DIE - K ^TIU(8925,"CA",$E(X,1,30),DA) - S X=DE(12),DIC=DIE - I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"AAU",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),+DA) - S X=DE(12),DIC=DIE - I +$P($G(^TIU(8925,+DA,15)),U) K ^TIU(8925,"AAUP",+X,+$P($G(^TIU(8925,+DA,15)),U),+DA) - S X=DE(12),DIC=DIE - D KACLAU^TIUDD01(1202,X) - S X=DE(12),DIC=DIE - ; +TIUEDS2 ; ;03/29/06 + S X=DG(DQ),DIC=DIE + I $P($$DOCTYPE^TIULF(+DA),U)="DOC",$L($P(^TIU(8925,+DA,0),U)),(+$P(^(0),U,2)>0) S ^TIU(8925,"AA",$P(^(0),U,2),+$P(^(0),U),(9999999-$P(+$G(^AUPNVSIT(X,0)),".")),DA)="" + S X=DG(DQ),DIC=DIE + I $P($$DOCTYPE^TIULF(+DA),U)="DOC",$L($P(^TIU(8925,+DA,0),U)),(+$P(^(0),U,2)>0) S ^TIU(8925,"AE",+$P(^TIU(8925,+DA,0),U,2),(9999999-$P(+$G(^AUPNVSIT(+X,0)),".")),+^TIU(8925,+DA,0),+DA)="" + S X=DG(DQ),DIC=DIE + I $P($$DOCTYPE^TIULF(+DA),U)="DOC",+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^(0)),U,2) S ^TIU(8925,"AV",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U),+X,+DA)="" + S X=DG(DQ),DIC=DIE + D:$D(^AUPNVSIT(+X)) ADD^AUPNVSIT + S X=DG(DQ),DIC=DIE + I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"AVSIT",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" + S X=DG(DQ),DIC=DIE + S ^TIU(8925,"V",$E(X,1,30),DA)="" + S X=DG(DQ),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^TIU(8925,D0,150)):^(150),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y X ^DD(8925,.03,1,7,1.1) X ^DD(8925,.03,1,7,1.4) + S X=DG(DQ),DIC=DIE + D SAPTLD^TIUDD0(.03,X) diff --git a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS3.m b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS3.m index b54b1ff6..ee44fe52 100644 --- a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS3.m +++ b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS3.m @@ -1,11 +1,11 @@ -TIUEDS3 ; ;11/08/09 - S X=DG(DQ),DIC=DIE - S ^TIU(8925,"CA",$E(X,1,30),DA)="" - S X=DG(DQ),DIC=DIE - I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"AAU",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),+DA)="" - S X=DG(DQ),DIC=DIE - I +$$AAUP^TIULX(+DA),+$P($G(^TIU(8925,+DA,15)),U) S ^TIU(8925,"AAUP",+X,+$P($G(^TIU(8925,+DA,15)),U),+DA)="" - S X=DG(DQ),DIC=DIE - D SACLAU^TIUDD0(1202,X) - S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I '+$$ISDS^TIULX(+$G(^TIU(8925,+DA,0))) I X S X=DIV S Y(1)=$S($D(^TIU(8925,D0,14)):^(14),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y X ^DD(8925,1202,1,5,1.1) X ^DD(8925,1202,1,5,1.4) +TIUEDS3 ; ;03/29/06 + S X=DE(12),DIC=DIE + K ^TIU(8925,"CA",$E(X,1,30),DA) + S X=DE(12),DIC=DIE + I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"AAU",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),+DA) + S X=DE(12),DIC=DIE + I +$P($G(^TIU(8925,+DA,15)),U) K ^TIU(8925,"AAUP",+X,+$P($G(^TIU(8925,+DA,15)),U),+DA) + S X=DE(12),DIC=DIE + D KACLAU^TIUDD01(1202,X) + S X=DE(12),DIC=DIE + ; diff --git a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS4.m b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS4.m index d59348d5..7704f6e0 100644 --- a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS4.m +++ b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS4.m @@ -1,11 +1,11 @@ -TIUEDS4 ; ;11/08/09 - S X=DE(15),DIC=DIE - K ^TIU(8925,"CA",$E(X,1,30),DA) - S X=DE(15),DIC=DIE - I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"AAU",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),+DA) - S X=DE(15),DIC=DIE - I +$P($G(^TIU(8925,+DA,15)),U) K ^TIU(8925,"AAUP",+X,+$P($G(^TIU(8925,+DA,15)),U),+DA) - S X=DE(15),DIC=DIE - D KACLAU^TIUDD01(1202,X) - S X=DE(15),DIC=DIE - ; +TIUEDS4 ; ;03/29/06 + S X=DG(DQ),DIC=DIE + S ^TIU(8925,"CA",$E(X,1,30),DA)="" + S X=DG(DQ),DIC=DIE + I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"AAU",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),+DA)="" + S X=DG(DQ),DIC=DIE + I +$$AAUP^TIULX(+DA),+$P($G(^TIU(8925,+DA,15)),U) S ^TIU(8925,"AAUP",+X,+$P($G(^TIU(8925,+DA,15)),U),+DA)="" + S X=DG(DQ),DIC=DIE + D SACLAU^TIUDD0(1202,X) + S X=DG(DQ),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I '+$$ISDS^TIULX(+$G(^TIU(8925,+DA,0))) I X S X=DIV S Y(1)=$S($D(^TIU(8925,D0,14)):^(14),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y X ^DD(8925,1202,1,5,1.1) X ^DD(8925,1202,1,5,1.4) diff --git a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS5.m b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS5.m index 951d7fa4..e258b3a7 100644 --- a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS5.m +++ b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS5.m @@ -1,4 +1,74 @@ -TIUEDS5 ; ;11/08/09 +TIUEDS5 ; ;03/29/06 + D DE G BEGIN +DE S DIE="^TIU(8925,",DIC=DIE,DP=8925,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^TIU(8925,DA,""))="" + I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,12) S:%]"" DE(7)=% + I $D(^(12)) S %Z=^(12) S %=$P(%Z,U,1) S:%]"" DE(17)=% S %=$P(%Z,U,2) S:%]"" DE(1)=% + I $D(^(13)) S %Z=^(13) S %=$P(%Z,U,1) S:%]"" DE(9)=% S %=$P(%Z,U,2) S:%]"" DE(11)=% S %=$P(%Z,U,3) S:%]"" DE(14)=% S %=$P(%Z,U,7) S:%]"" DE(3)=% + K %Z Q + ; +W W !?DL+DL-2,DLB_": " + Q +O D W W Y W:$X>45 !?9 + I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 + W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q +TR R X:DTIME E S (DTOUT,X)=U W $C(7) + Q +A K DQ(DQ) S DQ=DQ+1 +B G @DQ +RE G PR:$D(DE(DQ)) D W,TR +N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A +RD G QS:X?."?" I X["^" D D G ^DIE17 + I X="@" D D G Z^DIE2 + I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X +T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V + K DDER G X +P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 + G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z + I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X +V D @("X"_DQ) K YS +Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A +X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 + S X="?BAD" +QS S DZ=X D D,QQ^DIEQ G B +D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q +Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N +PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP +R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R + I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R + X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% +RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 +I I DV'["I",DV'["#" G RD + D E^DIE0 G RD:$D(X),PR + Q +SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 + I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 + D ^DIR I 'DDER S %=Y(0),X=Y + Q +SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) + I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" + E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") + Q +NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS +KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") +BEGIN S DNM="TIUEDS5",DQ=1 +1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="12;2",DV="*P200'R",DU="",DLB="AUTHOR/DICTATOR",DIFLD=1202 + S DE(DW)="C1^TIUEDS5" + S DU="VA(200," + S X=$S($G(TIUAUTH):$$PERSNAME^TIULC1(TIUAUTH),1:"") + S Y=X + G Y +C1 G C1S:$D(DE(1))[0 K DB + S X=DE(1),DIC=DIE + K ^TIU(8925,"CA",$E(X,1,30),DA) + S X=DE(1),DIC=DIE + I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"AAU",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),+DA) + S X=DE(1),DIC=DIE + I +$P($G(^TIU(8925,+DA,15)),U) K ^TIU(8925,"AAUP",+X,+$P($G(^TIU(8925,+DA,15)),U),+DA) + S X=DE(1),DIC=DIE + D KACLAU^TIUDD01(1202,X) + S X=DE(1),DIC=DIE + ; +C1S S X="" G:DG(DQ)=X C1F1 K DB S X=DG(DQ),DIC=DIE S ^TIU(8925,"CA",$E(X,1,30),DA)="" S X=DG(DQ),DIC=DIE @@ -9,3 +79,109 @@ TIUEDS5 ; ;11/08/09 D SACLAU^TIUDD0(1202,X) S X=DG(DQ),DIC=DIE K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I '+$$ISDS^TIULX(+$G(^TIU(8925,+DA,0))) I X S X=DIV S Y(1)=$S($D(^TIU(8925,D0,14)):^(14),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y X ^DD(8925,1202,1,5,1.1) X ^DD(8925,1202,1,5,1.4) +C1F1 Q +X1 S DIC("S")="I '+$$ISTERM^USRLM(+Y)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X + Q + ; +2 S DQ=3 ;@3 +3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW="13;7",DV="DR",DU="",DLB="DICTATION DATE",DIFLD=1307 + G RE +X3 S %DT="ETX" D ^%DT S X=Y K:Y<1 X + Q + ; +4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 G A +5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X5 S TIUREFDT=$$REFDATE^TIULC1(.TIU,+X) + Q +6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X6 I +$P(TIUREFDT,U,2)'>0 S Y="@4" + Q +7 S DW="0;12",DV="S",DU="",DLB="MARK DISCH DT FOR CORRECTION",DIFLD=.12 + S DE(DW)="C7^TIUEDS5" + S DU="1:YES;" + S X=1 + S Y=X + S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD:X="@",Z +C7 G C7S:$D(DE(7))[0 K DB + S X=DE(7),DIC=DIE + K ^TIU(8925,"FIX",$E(X,1,30),DA) +C7S S X="" G:DG(DQ)=X C7F1 K DB + S X=DG(DQ),DIC=DIE + S ^TIU(8925,"FIX",$E(X,1,30),DA)="" +C7F1 Q +X7 Q +8 S DQ=9 ;@4 +9 D:$D(DG)>9 F^DIE17,DE S DQ=9,DW="13;1",DV="D",DU="",DLB="REFERENCE DATE",DIFLD=1301 + S DE(DW)="C9^TIUEDS5",DE(DW,"INDEX")=1 + S X=$P(TIUREFDT,U) + S Y=X + S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD:X="@",Z +C9 G C9S:$D(DE(9))[0 K DB + D ^TIUEDS6 +C9S S X="" G:DG(DQ)=X C9F1 K DB + D ^TIUEDS7 +C9F1 S DIEZRXR(8925,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE))) + F DIXR=247 S DIEZRXR(8925,DIXR)="" + Q +X9 Q +10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X10 I +$P($G(^TIU(8925,+DA,13)),U,2) S Y="@5" + Q +11 D:$D(DG)>9 F^DIE17,DE S DQ=11,DW="13;2",DV="P200'O",DU="",DLB="ENTERED BY",DIFLD=1302 + S DQ(11,2)="S Y(0)=Y S Y=$S(+$G(TIUINI):$$LOWER^TIULS($P($G(^VA(200,+Y(0),0)),U,2)),1:$P($G(^VA(200,+Y(0),0)),U,2))" + S DE(DW)="C11^TIUEDS5" + S DU="VA(200," + S X=DUZ + S Y=X + S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD:X="@",Z +C11 G C11S:$D(DE(11))[0 K DB + S X=DE(11),DIC=DIE + K ^TIU(8925,"TC",$E(X,1,30),DA) + S X=DE(11),DIC=DIE + I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ATC",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA) + S X=DE(11),DIC=DIE + D KACLAU1^TIUDD01(1302,X) +C11S S X="" G:DG(DQ)=X C11F1 K DB + S X=DG(DQ),DIC=DIE + S ^TIU(8925,"TC",$E(X,1,30),DA)="" + S X=DG(DQ),DIC=DIE + I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ATC",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" + S X=DG(DQ),DIC=DIE + D SACLAU1^TIUDD0(1302,X) +C11F1 Q +X11 Q +12 S DQ=13 ;@5 +13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X13 I $P($G(^TIU(8925,+DA,13)),U,3)]"" S Y="@6" + Q +14 D:$D(DG)>9 F^DIE17,DE S DQ=14,DW="13;3",DV="S",DU="",DLB="CAPTURE METHOD",DIFLD=1303 + S DU="D:direct;U:upload;C:converted;R:remote procedure;O:copy;" + S X="D" + S Y=X + S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD:X="@",Z +X14 Q +15 S DQ=16 ;@6 +16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X16 I +$P($G(^TIU(8925,+DA,12)),U) S Y="@7" + Q +17 S DW="12;1",DV="D",DU="",DLB="ENTRY DATE/TIME",DIFLD=1201 + S DE(DW)="C17^TIUEDS5" + S X=$$NOW^TIULC + S Y=X + S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD:X="@",Z +C17 G C17S:$D(DE(17))[0 K DB + D ^TIUEDS8 +C17S S X="" G:DG(DQ)=X C17F1 K DB + D ^TIUEDS9 +C17F1 Q +X17 Q +18 S DQ=19 ;@7 +19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X19 I +$$PROVIDER^TIUPXAP1(DUZ,DT)'>0 S Y="@9" + Q +20 D:$D(DG)>9 F^DIE17 G ^TIUEDS10 diff --git a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS6.m b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS6.m index 6a6ae701..53885303 100644 --- a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS6.m +++ b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS6.m @@ -1,246 +1,39 @@ -TIUEDS6 ; ;11/08/09 - D DE G BEGIN -DE S DIE="^TIU(8925,",DIC=DIE,DP=8925,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^TIU(8925,DA,""))="" - I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,12) S:%]"" DE(5)=% - I $D(^(12)) S %Z=^(12) S %=$P(%Z,U,1) S:%]"" DE(15)=% S %=$P(%Z,U,4) S:%]"" DE(23)=% S %=$P(%Z,U,8) S:%]"" DE(24)=% S %=$P(%Z,U,9) S:%]"" DE(18)=%,DE(21)=% - I $D(^(13)) S %Z=^(13) S %=$P(%Z,U,1) S:%]"" DE(7)=% S %=$P(%Z,U,2) S:%]"" DE(9)=% S %=$P(%Z,U,3) S:%]"" DE(12)=% S %=$P(%Z,U,7) S:%]"" DE(1)=% - I $D(^(14)) S %Z=^(14) S %=$P(%Z,U,1) S:%]"" DE(26)=% S %=$P(%Z,U,2) S:%]"" DE(27)=% S %=$P(%Z,U,4) S:%]"" DE(28)=% - I $D(^(15)) S %Z=^(15) S %=$P(%Z,U,6) S:%]"" DE(25)=% - K %Z Q - ; -W W !?DL+DL-2,DLB_": " - Q -O D W W Y W:$X>45 !?9 - I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 - W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q -TR R X:DTIME E S (DTOUT,X)=U W $C(7) - Q -A K DQ(DQ) S DQ=DQ+1 -B G @DQ -RE G PR:$D(DE(DQ)) D W,TR -N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A -RD G QS:X?."?" I X["^" D D G ^DIE17 - I X="@" D D G Z^DIE2 - I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X -T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V - K DDER G X -P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 - G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z - I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X -V D @("X"_DQ) K YS -Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A -X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 - S X="?BAD" -QS S DZ=X D D,QQ^DIEQ G B -D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q -Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N -PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP -R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R - I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R - X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% -RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 -I I DV'["I",DV'["#" G RD - D E^DIE0 G RD:$D(X),PR - Q -SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 - I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 - D ^DIR I 'DDER S %=Y(0),X=Y - Q -SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) - I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" - E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") - Q -NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS -KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") -BEGIN S DNM="TIUEDS6",DQ=1 -1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="13;7",DV="DR",DU="",DLB="DICTATION DATE",DIFLD=1307 - G RE -X1 S %DT="ETX" D ^%DT S X=Y K:Y<1 X - Q - ; -2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 G A -3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X3 S TIUREFDT=$$REFDATE^TIULC1(.TIU,+X) - Q -4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X4 I +$P(TIUREFDT,U,2)'>0 S Y="@4" - Q -5 S DW="0;12",DV="S",DU="",DLB="MARK DISCH DT FOR CORRECTION",DIFLD=.12 - S DE(DW)="C5^TIUEDS6" - S DU="1:YES;" - S X=1 - S Y=X - S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD:X="@",Z -C5 G C5S:$D(DE(5))[0 K DB - S X=DE(5),DIC=DIE - K ^TIU(8925,"FIX",$E(X,1,30),DA) -C5S S X="" G:DG(DQ)=X C5F1 K DB - S X=DG(DQ),DIC=DIE - S ^TIU(8925,"FIX",$E(X,1,30),DA)="" -C5F1 Q -X5 Q -6 S DQ=7 ;@4 -7 D:$D(DG)>9 F^DIE17,DE S DQ=7,DW="13;1",DV="D",DU="",DLB="REFERENCE DATE",DIFLD=1301 - S DE(DW)="C7^TIUEDS6",DE(DW,"INDEX")=1 - S X=$P(TIUREFDT,U) - S Y=X - S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD:X="@",Z -C7 G C7S:$D(DE(7))[0 K DB - D ^TIUEDS7 -C7S S X="" G:DG(DQ)=X C7F1 K DB - D ^TIUEDS8 -C7F1 S DIEZRXR(8925,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE))) - F DIXR=247 S DIEZRXR(8925,DIXR)="" - Q -X7 Q -8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X8 I +$P($G(^TIU(8925,+DA,13)),U,2) S Y="@5" - Q -9 D:$D(DG)>9 F^DIE17,DE S DQ=9,DW="13;2",DV="P200'O",DU="",DLB="ENTERED BY",DIFLD=1302 - S DQ(9,2)="S Y(0)=Y S Y=$S(+$G(TIUINI):$$LOWER^TIULS($P($G(^VA(200,+Y(0),0)),U,2)),1:$P($G(^VA(200,+Y(0),0)),U,2))" - S DE(DW)="C9^TIUEDS6" - S DU="VA(200," - S X=DUZ - S Y=X - S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD:X="@",Z -C9 G C9S:$D(DE(9))[0 K DB +TIUEDS6 ; ;03/29/06 S X=DE(9),DIC=DIE - K ^TIU(8925,"TC",$E(X,1,30),DA) + I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"AAU",+$P(^TIU(8925,+DA,12),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) S X=DE(9),DIC=DIE - I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ATC",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA) + I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,8),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ASUP",+$P(^TIU(8925,+DA,12),U,8),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) S X=DE(9),DIC=DIE - D KACLAU1^TIUDD01(1302,X) -C9S S X="" G:DG(DQ)=X C9F1 K DB - S X=DG(DQ),DIC=DIE - S ^TIU(8925,"TC",$E(X,1,30),DA)="" - S X=DG(DQ),DIC=DIE - I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ATC",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" - S X=DG(DQ),DIC=DIE - D SACLAU1^TIUDD0(1302,X) -C9F1 Q -X9 Q -10 S DQ=11 ;@5 -11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X11 I $P($G(^TIU(8925,+DA,13)),U,3)]"" S Y="@6" - Q -12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW="13;3",DV="S",DU="",DLB="CAPTURE METHOD",DIFLD=1303 - S DU="D:direct;U:upload;C:converted;R:remote procedure;O:copy;" - S X="D" - S Y=X - S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD:X="@",Z -X12 Q -13 S DQ=14 ;@6 -14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X14 I +$P($G(^TIU(8925,+DA,12)),U) S Y="@7" - Q -15 S DW="12;1",DV="D",DU="",DLB="ENTRY DATE/TIME",DIFLD=1201 - S DE(DW)="C15^TIUEDS6" - S X=$$NOW^TIULC - S Y=X - S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD:X="@",Z -C15 G C15S:$D(DE(15))[0 K DB - S X=DE(15),DIC=DIE - K ^TIU(8925,"F",$E(X,1,30),DA) -C15S S X="" G:DG(DQ)=X C15F1 K DB - S X=DG(DQ),DIC=DIE - S ^TIU(8925,"F",$E(X,1,30),DA)="" -C15F1 Q -X15 Q -16 S DQ=17 ;@7 -17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X17 I +$$PROVIDER^TIUPXAP1(DUZ,DT)'>0 S Y="@9" - Q -18 D:$D(DG)>9 F^DIE17,DE S DQ=18,DW="12;9",DV="*P200'XR",DU="",DLB="ATTENDING PHYSICIAN",DIFLD=1209 - S DU="VA(200," - G RE -X18 S DIC("S")="I +$G(DA),+$$SCRATT^TIULA3(+DA,+Y)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X - Q - ; -19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X19 S Y="@10" - Q -20 S DQ=21 ;@9 -21 S DW="12;9",DV="*P200'X",DU="",DLB="ATTENDING PHYSICIAN",DIFLD=1209 - S DU="VA(200," - G RE -X21 S DIC("S")="I +$G(DA),+$$SCRATT^TIULA3(+DA,+Y)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X - Q - ; -22 S DQ=23 ;@10 -23 S DW="12;4",DV="P200'O",DU="",DLB="EXPECTED SIGNER",DIFLD=1204 - S DQ(23,2)="S Y(0)=Y S:+Y>0&$D(TIUSIG) Y=$S($L($P(^VA(200,+Y,20),U,2)):$P(^(20),U,2),1:$P(^VA(200,+Y,0),U)) S:+Y>0&'$D(TIUSIG) Y=$P(^VA(200,+Y,0),U)" - S DU="VA(200," - S X=$$WHOSIGNS^TIULC1(DA) - S Y=X - S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD:X="@",Z -X23 Q -24 S DW="12;8",DV="*P200'",DU="",DLB="EXPECTED COSIGNER",DIFLD=1208 - S DE(DW)="C24^TIUEDS6" - S DU="VA(200," - S X=$$WHOCOSIG^TIULC1(DA) - S Y=X - S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD:X="@",Z -C24 G C24S:$D(DE(24))[0 K DB - S X=DE(24),DIC=DIE - K ^TIU(8925,"CS",$E(X,1,30),DA) - S X=DE(24),DIC=DIE - I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ASUP",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA) - S X=DE(24),DIC=DIE - D KACLEC^TIUDD01(1208,X) -C24S S X="" G:DG(DQ)=X C24F1 K DB - S X=DG(DQ),DIC=DIE - S ^TIU(8925,"CS",$E(X,1,30),DA)="" - S X=DG(DQ),DIC=DIE - I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ASUP",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" - S X=DG(DQ),DIC=DIE - D SACLEC^TIUDD0(1208,X) -C24F1 Q -X24 Q -25 D:$D(DG)>9 F^DIE17,DE S DQ=25,DW="15;6",DV="S",DU="",DLB="COSIGNATURE NEEDED",DIFLD=1506 - S DU="1:YES;0:NO;" - S X=$S(+$P($G(^TIU(8925,+DA,12)),U,4)=+$P($G(^TIU(8925,+DA,12)),U,9):0,1:1) - S Y=X - S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD:X="@",Z -X25 Q -26 S DW="14;1",DV="P405'",DU="",DLB="PATIENT MOVEMENT RECORD",DIFLD=1401 - S DU="DGPM(" - S X=$G(TIU("AD#")) - S Y=X - S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD:X="@",Z -X26 Q -27 S DW="14;2",DV="P45.7'",DU="",DLB="TREATING SPECIALTY",DIFLD=1402 - S DE(DW)="C27^TIUEDS6" - S DU="DIC(45.7," - S X=$P($G(TIU("TS")),U) - S Y=X - S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD:X="@",Z -C27 G C27S:$D(DE(27))[0 K DB - D ^TIUEDS9 -C27S S X="" G:DG(DQ)=X C27F1 K DB - D ^TIUEDS10 -C27F1 Q -X27 Q -28 D:$D(DG)>9 F^DIE17,DE S DQ=28,DW="14;4",DV="P49'",DU="",DLB="SERVICE",DIFLD=1404 - S DE(DW)="C28^TIUEDS6" - S DU="DIC(49," - S X=$P($G(TIU("SVC")),U) - S Y=X - S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD:X="@",Z -C28 G C28S:$D(DE(28))[0 K DB - D ^TIUEDS11 -C28S S X="" G:DG(DQ)=X C28F1 K DB - D ^TIUEDS12 -C28F1 Q -X28 Q -29 D:$D(DG)>9 F^DIE17 G ^TIUEDS13 + I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"APT",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) + S X=DE(9),DIC=DIE + I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,14)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ATS",+$P(^TIU(8925,+DA,14),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) + S X=DE(9),DIC=DIE + I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ATC",+$P(^TIU(8925,+DA,13),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) + S X=DE(9),DIC=DIE + I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ALL","ANY",+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) + S X=DE(9),DIC=DIE + I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),$L($P($G(^TIU(8925,+DA,17)),U)) D ASUBK^TIUDD($P($G(^TIU(8925,+DA,17)),U),+$G(^TIU(8925,+DA,0)),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-+X),DA) + S X=DE(9),DIC=DIE + I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,14)),U,4),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ASVC",+$P(^TIU(8925,+DA,14),U,4),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) + S X=DE(9),DIC=DIE + I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),+$O(^TIU(8925.9,"B",+DA,0)) D APRBK^TIUDD(+$G(^TIU(8925,+DA,0)),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-+X),DA) + S X=DE(9),DIC=DIE + I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,3),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"AVSIT",+$P(^TIU(8925,+DA,0),U,3),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),DA) + S X=DE(9),DIC=DIE + I +$P($G(^TIU(8925,+DA,0)),U,4),+$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ADCPT",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U,4),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),DA) + S X=DE(9),DIC=DIE + K ^TIU(8925,"D",$E(X,1,30),DA) + S X=DE(9),DIC=DIE + I +$P(^TIU(8925,+DA,0),U),+$P($G(^TIU(8925,+DA,0)),U,2) K ^TIU(8925,"APTCL",+$P(^TIU(8925,+DA,0),U,2),+$$CLINDOC^TIULC1(+$P(^TIU(8925,+DA,0),U),+DA),(9999999-X),DA) + S X=DE(9),DIC=DIE + I +$P(^TIU(8925,+DA,0),U),+$P($G(^TIU(8925,+DA,0)),U,2) K ^TIU(8925,"APTCL",+$P(^TIU(8925,+DA,0),U,2),38,(9999999-X),DA) + S X=DE(9),DIC=DIE + I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,5),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ALOC",+$P(^TIU(8925,+DA,12),U,5),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) + S X=DE(9),DIC=DIE + D KACLPT^TIUDD01(1301,X) + S X=DE(9),DIC=DIE + D KACLAU^TIUDD01(1301,X),KACLAU1^TIUDD01(1301,X) + S X=DE(9),DIC=DIE + D KACLEC^TIUDD01(1301,X) + S X=DE(9),DIC=DIE + D KACLSB^TIUDD01(1301,X) diff --git a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS7.m b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS7.m index 6007b552..2f938f3d 100644 --- a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS7.m +++ b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS7.m @@ -1,39 +1,39 @@ -TIUEDS7 ; ;11/08/09 - S X=DE(7),DIC=DIE - I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"AAU",+$P(^TIU(8925,+DA,12),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) - S X=DE(7),DIC=DIE - I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,8),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ASUP",+$P(^TIU(8925,+DA,12),U,8),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) - S X=DE(7),DIC=DIE - I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"APT",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) - S X=DE(7),DIC=DIE - I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,14)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ATS",+$P(^TIU(8925,+DA,14),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) - S X=DE(7),DIC=DIE - I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ATC",+$P(^TIU(8925,+DA,13),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) - S X=DE(7),DIC=DIE - I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ALL","ANY",+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) - S X=DE(7),DIC=DIE - I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),$L($P($G(^TIU(8925,+DA,17)),U)) D ASUBK^TIUDD($P($G(^TIU(8925,+DA,17)),U),+$G(^TIU(8925,+DA,0)),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-+X),DA) - S X=DE(7),DIC=DIE - I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,14)),U,4),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ASVC",+$P(^TIU(8925,+DA,14),U,4),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) - S X=DE(7),DIC=DIE - I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),+$O(^TIU(8925.9,"B",+DA,0)) D APRBK^TIUDD(+$G(^TIU(8925,+DA,0)),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-+X),DA) - S X=DE(7),DIC=DIE - I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,3),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"AVSIT",+$P(^TIU(8925,+DA,0),U,3),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),DA) - S X=DE(7),DIC=DIE - I +$P($G(^TIU(8925,+DA,0)),U,4),+$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ADCPT",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U,4),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),DA) - S X=DE(7),DIC=DIE - K ^TIU(8925,"D",$E(X,1,30),DA) - S X=DE(7),DIC=DIE - I +$P(^TIU(8925,+DA,0),U),+$P($G(^TIU(8925,+DA,0)),U,2) K ^TIU(8925,"APTCL",+$P(^TIU(8925,+DA,0),U,2),+$$CLINDOC^TIULC1(+$P(^TIU(8925,+DA,0),U),+DA),(9999999-X),DA) - S X=DE(7),DIC=DIE - I +$P(^TIU(8925,+DA,0),U),+$P($G(^TIU(8925,+DA,0)),U,2) K ^TIU(8925,"APTCL",+$P(^TIU(8925,+DA,0),U,2),38,(9999999-X),DA) - S X=DE(7),DIC=DIE - I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,5),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ALOC",+$P(^TIU(8925,+DA,12),U,5),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) - S X=DE(7),DIC=DIE - D KACLPT^TIUDD01(1301,X) - S X=DE(7),DIC=DIE - D KACLAU^TIUDD01(1301,X),KACLAU1^TIUDD01(1301,X) - S X=DE(7),DIC=DIE - D KACLEC^TIUDD01(1301,X) - S X=DE(7),DIC=DIE - D KACLSB^TIUDD01(1301,X) +TIUEDS7 ; ;03/29/06 + S X=DG(DQ),DIC=DIE + I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"AAU",+$P(^TIU(8925,+DA,12),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" + S X=DG(DQ),DIC=DIE + I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,8),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ASUP",+$P(^TIU(8925,+DA,12),U,8),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" + S X=DG(DQ),DIC=DIE + I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"APT",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" + S X=DG(DQ),DIC=DIE + I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,14)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ATS",+$P(^TIU(8925,+DA,14),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" + S X=DG(DQ),DIC=DIE + I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ATC",+$P(^TIU(8925,+DA,13),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" + S X=DG(DQ),DIC=DIE + I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ALL","ANY",+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" + S X=DG(DQ),DIC=DIE + I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),$L($P($G(^TIU(8925,+DA,17)),U)) D ASUBS^TIUDD($P($G(^TIU(8925,+DA,17)),U),+$G(^TIU(8925,+DA,0)),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-+X),DA) + S X=DG(DQ),DIC=DIE + I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,14)),U,4),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ASVC",+$P(^TIU(8925,+DA,14),U,4),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" + S X=DG(DQ),DIC=DIE + I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),+$O(^TIU(8925.9,"B",+DA,0)) D APRBS^TIUDD(+$G(^TIU(8925,+DA,0)),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-+X),DA) + S X=DG(DQ),DIC=DIE + I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,3),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"AVSIT",+$P(^TIU(8925,+DA,0),U,3),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),DA)="" + S X=DG(DQ),DIC=DIE + I +$P($G(^TIU(8925,+DA,0)),U,4),+$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ADCPT",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U,4),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),DA)="" + S X=DG(DQ),DIC=DIE + S ^TIU(8925,"D",$E(X,1,30),DA)="" + S X=DG(DQ),DIC=DIE + I +$P(^TIU(8925,+DA,0),U),+$P($G(^TIU(8925,+DA,0)),U,2) S ^TIU(8925,"APTCL",+$P(^TIU(8925,+DA,0),U,2),+$$CLINDOC^TIULC1(+$P(^TIU(8925,+DA,0),U),+DA),(9999999-X),DA)="" + S X=DG(DQ),DIC=DIE + I +$P(^TIU(8925,+DA,0),U),+$P($G(^TIU(8925,+DA,0)),U,2) S ^TIU(8925,"APTCL",+$P(^TIU(8925,+DA,0),U,2),38,(9999999-X),DA)="" + S X=DG(DQ),DIC=DIE + I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,5),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ALOC",+$P(^TIU(8925,+DA,12),U,5),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" + S X=DG(DQ),DIC=DIE + D SACLPT^TIUDD0(1301,X) + S X=DG(DQ),DIC=DIE + D SACLAU^TIUDD0(1301,X),SACLAU1^TIUDD0(1301,X) + S X=DG(DQ),DIC=DIE + D SACLEC^TIUDD0(1301,X) + S X=DG(DQ),DIC=DIE + D SACLSB^TIUDD0(1301,X) diff --git a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS8.m b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS8.m index 8d94be8a..c2a222cd 100644 --- a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS8.m +++ b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS8.m @@ -1,39 +1,3 @@ -TIUEDS8 ; ;11/08/09 - S X=DG(DQ),DIC=DIE - I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"AAU",+$P(^TIU(8925,+DA,12),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" - S X=DG(DQ),DIC=DIE - I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,8),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ASUP",+$P(^TIU(8925,+DA,12),U,8),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" - S X=DG(DQ),DIC=DIE - I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"APT",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" - S X=DG(DQ),DIC=DIE - I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,14)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ATS",+$P(^TIU(8925,+DA,14),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" - S X=DG(DQ),DIC=DIE - I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ATC",+$P(^TIU(8925,+DA,13),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" - S X=DG(DQ),DIC=DIE - I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ALL","ANY",+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" - S X=DG(DQ),DIC=DIE - I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),$L($P($G(^TIU(8925,+DA,17)),U)) D ASUBS^TIUDD($P($G(^TIU(8925,+DA,17)),U),+$G(^TIU(8925,+DA,0)),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-+X),DA) - S X=DG(DQ),DIC=DIE - I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,14)),U,4),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ASVC",+$P(^TIU(8925,+DA,14),U,4),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" - S X=DG(DQ),DIC=DIE - I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),+$O(^TIU(8925.9,"B",+DA,0)) D APRBS^TIUDD(+$G(^TIU(8925,+DA,0)),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-+X),DA) - S X=DG(DQ),DIC=DIE - I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,3),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"AVSIT",+$P(^TIU(8925,+DA,0),U,3),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),DA)="" - S X=DG(DQ),DIC=DIE - I +$P($G(^TIU(8925,+DA,0)),U,4),+$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ADCPT",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U,4),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),DA)="" - S X=DG(DQ),DIC=DIE - S ^TIU(8925,"D",$E(X,1,30),DA)="" - S X=DG(DQ),DIC=DIE - I +$P(^TIU(8925,+DA,0),U),+$P($G(^TIU(8925,+DA,0)),U,2) S ^TIU(8925,"APTCL",+$P(^TIU(8925,+DA,0),U,2),+$$CLINDOC^TIULC1(+$P(^TIU(8925,+DA,0),U),+DA),(9999999-X),DA)="" - S X=DG(DQ),DIC=DIE - I +$P(^TIU(8925,+DA,0),U),+$P($G(^TIU(8925,+DA,0)),U,2) S ^TIU(8925,"APTCL",+$P(^TIU(8925,+DA,0),U,2),38,(9999999-X),DA)="" - S X=DG(DQ),DIC=DIE - I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,5),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ALOC",+$P(^TIU(8925,+DA,12),U,5),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" - S X=DG(DQ),DIC=DIE - D SACLPT^TIUDD0(1301,X) - S X=DG(DQ),DIC=DIE - D SACLAU^TIUDD0(1301,X),SACLAU1^TIUDD0(1301,X) - S X=DG(DQ),DIC=DIE - D SACLEC^TIUDD0(1301,X) - S X=DG(DQ),DIC=DIE - D SACLSB^TIUDD0(1301,X) +TIUEDS8 ; ;03/29/06 + S X=DE(17),DIC=DIE + K ^TIU(8925,"F",$E(X,1,30),DA) diff --git a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS9.m b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS9.m index 7442035a..17266c6a 100644 --- a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS9.m +++ b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS9.m @@ -1,5 +1,3 @@ -TIUEDS9 ; ;11/08/09 - S X=DE(27),DIC=DIE - K ^TIU(8925,"TS",$E(X,1,30),DA) - S X=DE(27),DIC=DIE - I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ATS",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA) +TIUEDS9 ; ;03/29/06 + S X=DG(DQ),DIC=DIE + S ^TIU(8925,"F",$E(X,1,30),DA)="" diff --git a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUFLF4.m b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUFLF4.m index bdf578f1..f41902f3 100644 --- a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUFLF4.m +++ b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUFLF4.m @@ -1,115 +1,115 @@ -TIUFLF4 ; SLC/MAM - Lib; ANCESTOR(FILEDA,NODE0,ANCESTOR,DOCFLAG), ORPHAN(FILEDA,NODE0,ANCESTOR), STUFFLDS(FILEDA,PFILEDA), ADDTEN(PFILEDA,FILEDA,NODE0,TENDA),NUMITEMS(FILEDA), MISSITEM(FILEDA) ;4/23/97 11:02 - ;;1.0;TEXT INTEGRATION UTILITIES;**11,43,236**;Jun 20, 1997;Build 2 - ; -NUMITEMS(FILEDA) ; Function returns Number of Items of FILEDA; Possibly 0 - N ITEMSANS,TIUFI - S (ITEMSANS,TIUFI)=0 - F S TIUFI=$O(^TIU(8925.1,FILEDA,10,TIUFI)) G:'TIUFI NUMIX S ITEMSANS=ITEMSANS+1 -NUMIX Q ITEMSANS - ; -MISSITEM(FILEDA) ; Function Checks FILEDA Items (doesn't check subitems etc.) for existence only. Returns IFN of first missing item it finds, else 0. - ; Requires FILEDA. - N TIUI,IFILEDA,MISSANS - S TIUI=0,MISSANS=0 - F S TIUI=$O(^TIU(8925.1,FILEDA,10,TIUI)) Q:'TIUI!MISSANS D - . S IFILEDA=+^TIU(8925.1,FILEDA,10,TIUI,0) - . I '$D(^TIU(8925.1,IFILEDA,0)) S MISSANS=IFILEDA - Q MISSANS - ; -ANCESTOR(FILEDA,NODE0,ANCESTOR,DOCFLAG) ; Module traces ancestors of FILEDA, - ;creates array ANCESTOR, - ; where ANCESTOR(0)=FILEDA, - ; where ANCESTOR(1)=Parent IFN of FILEDA, - ; ANCESTOR(2)=Parent IFN of ANCESTOR(1) - ; ... - ; ANCESTOR(last subscript)=IFN of oldest ancestor of FILEDA if - ; '$G(DOCFLAG) - ; OR - ; IFN of oldest ancestor of FILEDA NOT - ; OF TYPE DC OR CL if $G(DOCFLAG) - ; Don't stop the array for problems like bad type, no type, type object. - ; If DOCFLAG, DON'T GET DC or CL; don't want array to mistakenly - ;go all the way to CLinical Documents. - ; Array may not EXIST if DOCFLAG - ; Requires FILEDA, NODE0= 0 Node; - ; DOCFLAG optional, 0 or 1 - N TIUI,QUIT,ANODE0 - S DOCFLAG=+$G(DOCFLAG) - I DOCFLAG,($P(NODE0,U,4)="DC")!($P(NODE0,U,4)="CL") G ANCEX - S TIUI=0,ANCESTOR(0)=FILEDA - F D Q:$G(QUIT) - . S ANCESTOR(TIUI+1)=$O(^TIU(8925.1,"AD",ANCESTOR(TIUI),0)) - . I 'ANCESTOR(TIUI+1) K ANCESTOR(TIUI+1) S QUIT=1 Q - . I DOCFLAG S ANODE0=^TIU(8925.1,ANCESTOR(TIUI+1),0) I ($P(ANODE0,U,4)="DC")!($P(ANODE0,U,4)="CL") K ANCESTOR(TIUI+1) S QUIT=1 Q - . S TIUI=TIUI+1 -ANCEX Q - ; -ORPHAN(FILEDA,NODE0,ANCESTOR) ; Function traces ancestors of FILEDA, - ; Returns NA if FILEDA is Object or Shared Component, - ; NO if NOT NA AND FILEDA belongs to Clinical Docmts Hierarchy, - ; YES if NOT NA, AND doesn't belong. - ; Requires FILEDA, NODE0= 0 Node; - N ORPHAN,LAST - I $P(NODE0,U,4)="O" S ORPHAN="NA" G ORPHX - I '$D(ANCESTOR) D ANCESTOR(FILEDA,NODE0,.ANCESTOR) - I '$D(^TMP("TIUF",$J,"CLINDOC")) D G:Y=-1 ORPHX - . N DIC,X,Y - . S DIC=8925.1,DIC(0)="X",X="CLINICAL DOCUMENTS" D ^DIC - . I Y=-1 S ORPHAN="UNKNOWN" Q - . S ^TMP("TIUF",$J,"CLINDOC")=+Y - S LAST=$O(ANCESTOR(100),-1) I ANCESTOR(LAST)=^TMP("TIUF",$J,"CLINDOC") S ORPHAN="NO" G ORPHX - S ORPHAN="YES" -ORPHX Q ORPHAN - ; -STUFFLDS(FILEDA,PFILEDA) ; Stuff fields .03, .04 (tries), .07, [.1] - ;for 8925.1 entry FILEDA. - ; Requires FILEDA. - ; Requires TIUFTLST as set in TYPELIST^TIUFLF7 - ; Requires PFILEDA if entry has prospective (as in Create and Add Item) - ;or actual parent in order to try to stuff Type. - ; Stuffs .03 Print Name = First 60 chars of .01 Name if not from copy - ;action. - ; Stuffs .04 Type if only 1 possible type in TIUFTLST (because of parent - ;or duplicates or option e.g. create objects). - ; Stuffs .07 Status = Inactive. - ; If receives parent PFILEDA, parent is Shared, then - ;stuffs .1 Shared = 1 - ; Should Lock FILEDA before calling STUFFLDS. - N DIE,DA,DR,Y,NAME,PRINTDR,TYPEDR,STATUSDR,SHAREDR - N NATL,NATLDR,NODE0,TYPE - I '$G(PFILEDA) S PFILEDA=0 - S DIE=8925.1,DA=FILEDA - S NODE0=^TIU(8925.1,FILEDA,0),NAME=$P(NODE0,U),PRINTDR=".03///^S X=NAME" - I $L(TIUFTLST,U)=3 S TYPE=$P(TIUFTLST,U,2),TYPEDR=".04////^S X=TYPE" - S STATUSDR=".07///INACTIVE" - S SHAREDR=".1////1" - I $G(XQORNOD(0))'["Copy" S DR=PRINTDR - I $G(TYPEDR) S DR=$S($D(DR):DR_";"_TYPEDR,1:TYPEDR) - S DR=$S($D(DR):DR_";"_STATUSDR,1:STATUSDR) - I $P($G(^TIU(8925.1,PFILEDA,0)),U,10) S DR=DR_";"_SHAREDR - D ^DIE -STUFFX Q - ; -ADDTEN(PFILEDA,FILEDA,NODE0,TENDA) ; Add item FILEDA to 10 NODE of - ;File 8925.1 entry PFILEDA. Stuff item Menu Text - ; Requires PFILEDA = 8925.1 IFN of parent of FILEDA. - ; Requires FILEDA, Requires NODE0 = ^TIU(8925.1,FILEDA,0) - ; Returns TENDA = 10 node DA of new item. - ; Returns TENDA="" if fails lookup. Screen on fld 10, subfld .01 - ;prevents lookup failure due to duplicate names by allowing only - ;FILEDA to pass screen. - ;Should Lock PFILEDA before calling ADDTEN. - N X,Y,DIE,DR,NAME,DA,DIC,DLAYGO,TIUFISCR,MSG,DUPITEM - S TENDA="" - I ('$G(PFILEDA))!('$G(FILEDA)) G ADDTX - S NAME=$P(NODE0,U) - I '$D(TIUFTLST) S DUPITEM=0,DUPITEM=$$DUPITEM^TIUFLF7(NAME,PFILEDA) I DUPITEM S MSG=" Can't add Item; Parent already has Item with the same Name" W !!,MSG,! G ADDTX ; possibly needed when called from TIU rather than from TIUF. - S X=""""_NAME_"""" - S DA(1)=PFILEDA,DLAYGO=8925.1 - S TIUFISCR=FILEDA ; activates screen on fld 10, Subfld .01 in DD - S DIC="^TIU(8925.1,DA(1),10,",DIC(0)="L",DIC("P")=$P(^DD(8925.1,10,0),U,2) - D ^DIC S TENDA=+Y I Y=-1 S TENDA="" G ADDTX - K DIC - S DA=TENDA,DA(1)=PFILEDA D MTXTCHEC^TIUFT1(.DA,FILEDA,1) -ADDTX Q - ; +TIUFLF4 ; SLC/MAM - Lib; ANCESTOR(FILEDA,NODE0,ANCESTOR,DOCFLAG), ORPHAN(FILEDA,NODE0,ANCESTOR), STUFFLDS(FILEDA,PFILEDA), ADDTEN(PFILEDA,FILEDA,NODE0,TENDA),NUMITEMS(FILEDA), MISSITEM(FILEDA) ;4/23/97 11:02 + ;;1.0;TEXT INTEGRATION UTILITIES;**11,43**;Jun 20, 1997 + ; +NUMITEMS(FILEDA) ; Function returns Number of Items of FILEDA; Possibly 0 + N ITEMSANS,TIUFI + S (ITEMSANS,TIUFI)=0 + F S TIUFI=$O(^TIU(8925.1,FILEDA,10,TIUFI)) G:'TIUFI NUMIX S ITEMSANS=ITEMSANS+1 +NUMIX Q ITEMSANS + ; +MISSITEM(FILEDA) ; Function Checks FILEDA Items (doesn't check subitems etc.) for existence only. Returns IFN of first missing item it finds, else 0. + ; Requires FILEDA. + N TIUI,IFILEDA,MISSANS + S TIUI=0,MISSANS=0 + F S TIUI=$O(^TIU(8925.1,FILEDA,10,TIUI)) Q:'TIUI!MISSANS D + . S IFILEDA=+^TIU(8925.1,FILEDA,10,TIUI,0) + . I '$D(^TIU(8925.1,IFILEDA,0)) S MISSANS=IFILEDA + Q MISSANS + ; +ANCESTOR(FILEDA,NODE0,ANCESTOR,DOCFLAG) ; Module traces ancestors of FILEDA, + ;creates array ANCESTOR, + ; where ANCESTOR(0)=FILEDA, + ; where ANCESTOR(1)=Parent IFN of FILEDA, + ; ANCESTOR(2)=Parent IFN of ANCESTOR(1) + ; ... + ; ANCESTOR(last subscript)=IFN of oldest ancestor of FILEDA if + ; '$G(DOCFLAG) + ; OR + ; IFN of oldest ancestor of FILEDA NOT + ; OF TYPE DC OR CL if $G(DOCFLAG) + ; Don't stop the array for problems like bad type, no type, type object. + ; If DOCFLAG, DON'T GET DC or CL; don't want array to mistakenly + ;go all the way to CLinical Documents. + ; Array may not EXIST if DOCFLAG + ; Requires FILEDA, NODE0= 0 Node; + ; DOCFLAG optional, 0 or 1 + N TIUI,QUIT,ANODE0 + S DOCFLAG=+$G(DOCFLAG) + I DOCFLAG,($P(NODE0,U,4)="DC")!($P(NODE0,U,4)="CL") G ANCEX + S TIUI=0,ANCESTOR(0)=FILEDA + F D Q:$G(QUIT) + . S ANCESTOR(TIUI+1)=$O(^TIU(8925.1,"AD",ANCESTOR(TIUI),0)) + . I 'ANCESTOR(TIUI+1) K ANCESTOR(TIUI+1) S QUIT=1 Q + . I DOCFLAG S ANODE0=^TIU(8925.1,ANCESTOR(TIUI+1),0) I ($P(ANODE0,U,4)="DC")!($P(ANODE0,U,4)="CL") K ANCESTOR(TIUI+1) S QUIT=1 Q + . S TIUI=TIUI+1 +ANCEX Q + ; +ORPHAN(FILEDA,NODE0,ANCESTOR) ; Function traces ancestors of FILEDA, + ; Returns NA if FILEDA is Object or Shared Component, + ; NO if NOT NA AND FILEDA belongs to Clinical Docmts Hierarchy, + ; YES if NOT NA, AND doesn't belong. + ; Requires FILEDA, NODE0= 0 Node; + N ORPHAN,LAST + I $P(NODE0,U,4)="O" S ORPHAN="NA" G ORPHX + I '$D(ANCESTOR) D ANCESTOR(FILEDA,NODE0,.ANCESTOR) + I '$D(^TMP("TIUF",$J,"CLINDOC")) D G:Y=-1 ORPHX + . N DIC,X,Y + . S DIC=8925.1,DIC(0)="X",X="CLINICAL DOCUMENTS" D ^DIC + . I Y=-1 S ORPHAN="UNKNOWN" Q + . S ^TMP("TIUF",$J,"CLINDOC")=+Y + S LAST=$O(ANCESTOR(100),-1) I ANCESTOR(LAST)=^TMP("TIUF",$J,"CLINDOC") S ORPHAN="NO" G ORPHX + S ORPHAN="YES" +ORPHX Q ORPHAN + ; +STUFFLDS(FILEDA,PFILEDA) ; Stuff fields .03, .04 (tries), .07, [.1] + ;for 8925.1 entry FILEDA. + ; Requires FILEDA. + ; Requires TIUFTLST as set in TYPELIST^TIUFLF7 + ; Requires PFILEDA if entry has prospective (as in Create and Add Item) + ;or actual parent in order to try to stuff Type. + ; Stuffs .03 Print Name = First 60 chars of .01 Name if not from copy + ;action. + ; Stuffs .04 Type if only 1 possible type in TIUFTLST (because of parent + ;or duplicates or option e.g. create objects). + ; Stuffs .07 Status = Inactive. + ; If receives parent PFILEDA, parent is Shared, then + ;stuffs .1 Shared = 1 + ; Should Lock FILEDA before calling STUFFLDS. + N DIE,DA,DR,Y,NAME,PRINTDR,TYPEDR,STATUSDR,SHAREDR + N NATL,NATLDR,NODE0,TYPE + I '$G(PFILEDA) S PFILEDA=0 + S DIE=8925.1,DA=FILEDA + S NODE0=^TIU(8925.1,FILEDA,0),NAME=$P(NODE0,U),PRINTDR=".03///^S X=NAME" + I $L(TIUFTLST,U)=3 S TYPE=$P(TIUFTLST,U,2),TYPEDR=".04////^S X=TYPE" + S STATUSDR=".07///INACTIVE" + S SHAREDR=".1////1" + I $G(XQORNOD(0))'["Copy" S DR=PRINTDR + I $G(TYPEDR) S DR=$S($D(DR):DR_";"_TYPEDR,1:TYPEDR) + S DR=$S($D(DR):DR_";"_STATUSDR,1:STATUSDR) + I $P($G(^TIU(8925.1,PFILEDA,0)),U,10) S DR=DR_";"_SHAREDR + D ^DIE +STUFFX Q + ; +ADDTEN(PFILEDA,FILEDA,NODE0,TENDA) ; Add item FILEDA to 10 NODE of + ;File 8925.1 entry PFILEDA. Stuff item Menu Text + ; Requires PFILEDA = 8925.1 IFN of parent of FILEDA. + ; Requires FILEDA, Requires NODE0 = ^TIU(8925.1,FILEDA,0) + ; Returns TENDA = 10 node DA of new item. + ; Returns TENDA="" if fails lookup. Screen on fld 10, subfld .01 + ;prevents lookup failure due to duplicate names by allowing only + ;FILEDA to pass screen. + ;Should Lock PFILEDA before calling ADDTEN. + N X,Y,DIE,DR,NAME,DA,DIC,DLAYGO,TIUFISCR,MSG,DUPITEM + S TENDA="" + I ('$G(PFILEDA))!('$G(FILEDA)) G ADDTX + S NAME=$P(NODE0,U) + I '$D(TIUFTLST) S DUPITEM=0,DUPITEM=$$DUPITEM^TIUFLF7(NAME,PFILEDA) I DUPITEM S MSG=" Can't add Item; Parent already has Item with the same Name" W !!,MSG,! G ADDTX ; possibly needed when called from TIU rather than from TIUF. + S X=""""_NAME_"""" + S DA(1)=PFILEDA,DLAYGO=8925.1 + S TIUFISCR=FILEDA ; activates screen on fld 10, Subfld .01 in DD + S DIC="^TIU(8925.1,DA(1),10,",DIC(0)="L",DIC("P")=$P(^DD(8925.1,10,0),U,2) + D ^DIC S TENDA=+Y I Y=-1 S TENDA="" G ADDTX + K DIC + S DA=TENDA,DA(1)=PFILEDA D MTXTCHEC^TIUFT1(.DA,FILEDA,1) +ADDTX Q + ; diff --git a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUHL7.m b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUHL7.m index e67bc74e..bd719921 100644 --- a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUHL7.m +++ b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUHL7.m @@ -1,94 +1,93 @@ -TIUHL7 ; SLC/AJB - TIUHL7 Msg Mgr ; 10OCT05 - ;;1.0;TEXT INTEGRATION UTILITIES;**200,228**;Jun 20, 1997 - Q -ACTION(ACT) ; - N TIUMSG,TIUSEL - D FULL^VALM1 - I VALMCNT=0 W !,"No documents to select." H 3 Q - S TIUSEL=$P(XQORNOD(0),"=",2) - I TIUSEL="" D Q:'+TIUSEL - . I VALMLST=1 S TIUSEL=1 Q - . N DIR,X,Y - . S DIR("A")=$S(ACT="DELETE":"Select Message(s) to Delete",ACT="VIEW":"Select Message to View")_": (1-"_VALMLST_") " - . S DIR("?")=$S(ACT="DELETE":"Select one or more messages to be deleted",ACT="VIEW":"Select one message to view") - . S DIR(0)=$S(ACT="DELETE":"L",ACT="VIEW":"N")_"OA^1:"_VALMLST - . D ^DIR S TIUSEL=Y - I TIUSEL["," S TIUSEL=$E(TIUSEL,1,($L(TIUSEL)-1)) - F X=1:1:$L(TIUSEL,",") S TIUMSG($P(TIUSEL,",",X))=$O(@VALMAR@("IDX",$P(TIUSEL,",",X),"")) - I ACT="SELECT" S ACT=$S(+$L(TIUSEL,",")=1:"VIEW",1:"DELETE") - D @ACT - Q -DELETE ; - D FULL^VALM1 - W @IOF,"Deleting the following message(s):",! - W !," Receiving Sending Message",! - W IOUON," Message ID Date/Time Processed Application Application Status ",!,IOUOFF - S TIUSEL="" F S TIUSEL=$O(TIUMSG(TIUSEL)) Q:'+TIUSEL W @VALMAR@(TIUSEL,0),! ; TIUSEL," ",TIUMSG(TIUSEL),! - I $$READ^TIUU("Y","Delete message(s)") D - . S TIUSEL="" F S TIUSEL=$O(TIUMSG(TIUSEL)) Q:'+TIUSEL K ^XTMP("TIUHL7",$P(TIUMSG(TIUSEL),U,2),$P(TIUMSG(TIUSEL),U)) - . W !!,"Deleting...finished." - W ! I $$READ^TIUU("EA","Press to continue") - D CLEAN^VALM10,INIT,RE^VALM4 - S VALMBG=1 - Q -REFRESH ; - D CLEAN^VALM10,INIT,RE^VALM4 - S VALMBG=1 - Q -VIEW ; - D EN^TIUHL7A - D CLEAN^VALM10,INIT,RE^VALM4 - S VALMBG=1 - Q -EN ; main entry point for TIUHL7 MSG MGR - N POP - D EN^VALM("TIUHL7 MSG MGR") - Q -HDR ; header code - N HDR S HDR="TIUHL7 Received Messages" - S VALMHDR(1)=$$SETSTR^VALM1(HDR,"",(IOM-$L(HDR))/2,$L(HDR)) - S VALMHDR(2)="" - S VALMHDR(3)=" Receiving Sending Message" - D XQORM - Q -INIT ; init variables and list array - N TIU,TIUDISP,TIUDT,TIUFS,TIUMID - S TIU("CUOFF")=$C(27)_"[?25l",TIU("CUON")=$C(27)_"[?25h" ; cursor values - W TIU("CUOFF"),!!,"Searching for messages..." - S (TIUDT,VALMCNT)=0,(TIUDISP,TIUMID)="" - F S TIUDT=$O(^XTMP("TIUHL7",TIUDT)) Q:'+TIUDT F S TIUMID=$O(^XTMP("TIUHL7",TIUDT,TIUMID)) Q:'+TIUMID D - . S VALMCNT=VALMCNT+1 W:VALMCNT#3=0 "." - . S TIUFS=$E($G(^XTMP("TIUHL7",TIUDT,TIUMID,"MSGRESULT",1)),4) - . S TIUDISP=$$SETSTR^VALM1(VALMCNT,"",1,8) - . S TIUDISP=$$SETFLD^VALM1($P($G(^XTMP("TIUHL7",TIUDT,TIUMID,"MSGRESULT",1)),TIUFS,3),TIUDISP,"Message ID") - . S TIUDISP=$$SETFLD^VALM1($$FMTE^XLFDT(TIUDT),TIUDISP,"Date/Time Processed") - . S TIUDISP=$$SETFLD^VALM1($P($G(^XTMP("TIUHL7",TIUDT,TIUMID,"MSGRESULT",1)),TIUFS,4),TIUDISP,"RecApp") - . S TIUDISP=$$SETFLD^VALM1($P($G(^XTMP("TIUHL7",TIUDT,TIUMID,"MSGRESULT",1)),TIUFS,5),TIUDISP,"SendApp") - . S TIU=$P($G(^XTMP("TIUHL7",TIUDT,TIUMID,"MSGRESULT",1)),TIUFS,2),TIU=$S(TIU="AR":"Rejected",TIU="AA":"Accepted",1:"Unknown") - . S TIUDISP=$$SETFLD^VALM1(TIU,TIUDISP,"Status") - . D SET^VALM10(VALMCNT,TIUDISP,TIUMID_U_TIUDT) - ; - I VALMCNT=0 D - . S TIU="No records found to satisfy search criteria." - . D SET^VALM10(2,$$SETSTR^VALM1(TIU,"",(IOM-$L(TIU))/2,$L(TIU)),0) - Q -HELP ; help code - I X="?" S POP=1 - D FULL^VALM1 - W !!,"The following actions are available:" - W !!,"View a Message - View a selected message" - W !,"Delete Message(s) - Delete selected message(s)" - W !,"Refresh Message List - Refresh display" - W !!,"If ONE message is selected, default action is VIEW" - W !,"If multiple messages are selected, default action is DELETE",! - I +$G(POP) I $$READ^TIUU("EA","Press to continue") - S VALMBCK="R",POP=0 - Q -EXIT ; exit code - D XQORM - Q -EXPND ; expand code - Q -XQORM ; default action for list manager - S XQORM("#")=$O(^ORD(101,"B","TIUHL7 MSG MGR SELECT",0))_U_"1:"_VALMCNT - Q +TIUHL7 ; SLC/AJB - TIUHL7 Msg Mgr ; 10OCT05 + ;;1.0;TEXT INTEGRATION UTILITIES;**200**;Jun 20, 1997 + Q +ACTION(ACT) ; + N TIUMSG,TIUSEL + D FULL^VALM1 + I VALMCNT=0 W !,"No documents to select." H 3 Q + S TIUSEL=$P(XQORNOD(0),"=",2) + I TIUSEL="" D Q:'+TIUSEL + . I VALMLST=1 S TIUSEL=1 Q + . N DIR,X,Y + . S DIR("A")=$S(ACT="DELETE":"Select Message(s) to Delete",ACT="VIEW":"Select Message to View")_": (1-"_VALMLST_") " + . S DIR("?")=$S(ACT="DELETE":"Select one or more messages to be deleted",ACT="VIEW":"Select one message to view") + . S DIR(0)=$S(ACT="DELETE":"L",ACT="VIEW":"N")_"OA^1:"_VALMLST + . D ^DIR S TIUSEL=Y + I TIUSEL["," S TIUSEL=$E(TIUSEL,1,($L(TIUSEL)-1)) + F X=1:1:$L(TIUSEL,",") S TIUMSG($P(TIUSEL,",",X))=$O(@VALMAR@("IDX",$P(TIUSEL,",",X),"")) + I ACT="SELECT" S ACT=$S(+$L(TIUSEL,",")=1:"VIEW",1:"DELETE") + D @ACT + Q +DELETE ; + D FULL^VALM1 + W @IOF,"Deleting the following message(s):",! + W !," Receiving Sending Message",! + W IOUON," Message ID Date/Time Processed Application Application Status ",!,IOUOFF + S TIUSEL="" F S TIUSEL=$O(TIUMSG(TIUSEL)) Q:'+TIUSEL W @VALMAR@(TIUSEL,0),! ; TIUSEL," ",TIUMSG(TIUSEL),! + I $$READ^TIUU("Y","Delete message(s)") D + . S TIUSEL="" F S TIUSEL=$O(TIUMSG(TIUSEL)) Q:'+TIUSEL K ^XTMP("TIUHL7",$P(TIUMSG(TIUSEL),U,2),$P(TIUMSG(TIUSEL),U)) + . W !!,"Deleting...finished." + W ! I $$READ^TIUU("EA","Press to continue") + D CLEAN^VALM10,INIT,RE^VALM4 + S VALMBG=1 + Q +REFRESH ; + D CLEAN^VALM10,INIT,RE^VALM4 + S VALMBG=1 + Q +VIEW ; + D EN^TIUHL7A + D CLEAN^VALM10,INIT,RE^VALM4 + S VALMBG=1 + Q +EN ; main entry point for TIUHL7 MSG MGR + N POP + D EN^VALM("TIUHL7 MSG MGR") + Q +HDR ; header code + N HDR S HDR="TIUHL7 Received Messages" + S VALMHDR(1)=$$SETSTR^VALM1(HDR,"",(IOM-$L(HDR))/2,$L(HDR)) + S VALMHDR(2)="" + S VALMHDR(3)=" Receiving Sending Message" + D XQORM + Q +INIT ; init variables and list array + N TIU,TIUDISP,TIUDT,TIUMID + S TIU("CUOFF")=$C(27)_"[?25l",TIU("CUON")=$C(27)_"[?25h" ; cursor values + W TIU("CUOFF"),!!,"Searching for messages..." + S (TIUDT,VALMCNT)=0,(TIUDISP,TIUMID)="" + F S TIUDT=$O(^XTMP("TIUHL7",TIUDT)) Q:'+TIUDT F S TIUMID=$O(^XTMP("TIUHL7",TIUDT,TIUMID)) Q:'+TIUMID D + . S VALMCNT=VALMCNT+1 W:VALMCNT#3=0 "." + . S TIUDISP=$$SETSTR^VALM1(VALMCNT,"",1,8) + . S TIUDISP=$$SETFLD^VALM1($P($G(^XTMP("TIUHL7",TIUDT,TIUMID,"MSGRESULT",1)),U,3),TIUDISP,"Message ID") + . S TIUDISP=$$SETFLD^VALM1($$FMTE^XLFDT(TIUDT),TIUDISP,"Date/Time Processed") + . S TIUDISP=$$SETFLD^VALM1($P($G(^XTMP("TIUHL7",TIUDT,TIUMID,"MSGRESULT",1)),U,4),TIUDISP,"RecApp") + . S TIUDISP=$$SETFLD^VALM1($P($G(^XTMP("TIUHL7",TIUDT,TIUMID,"MSGRESULT",1)),U,5),TIUDISP,"SendApp") + . S TIU=$P($G(^XTMP("TIUHL7",TIUDT,TIUMID,"MSGRESULT",1)),U,2),TIU=$S(TIU="AR":"Rejected",TIU="AA":"Accepted",1:"Unknown") + . S TIUDISP=$$SETFLD^VALM1(TIU,TIUDISP,"Status") + . D SET^VALM10(VALMCNT,TIUDISP,TIUMID_U_TIUDT) + ; + I VALMCNT=0 D + . S TIU="No records found to satisfy search criteria." + . D SET^VALM10(2,$$SETSTR^VALM1(TIU,"",(IOM-$L(TIU))/2,$L(TIU)),0) + Q +HELP ; help code + I X="?" S POP=1 + D FULL^VALM1 + W !!,"The following actions are available:" + W !!,"View a Message - View a selected message" + W !,"Delete Message(s) - Delete selected message(s)" + W !,"Refresh Message List - Refresh display" + W !!,"If ONE message is selected, default action is VIEW" + W !,"If multiple messages are selected, default action is DELETE",! + I +$G(POP) I $$READ^TIUU("EA","Press to continue") + S VALMBCK="R",POP=0 + Q +EXIT ; exit code + D XQORM + Q +EXPND ; expand code + Q +XQORM ; default action for list manager + S XQORM("#")=$O(^ORD(101,"B","TIUHL7 MSG MGR SELECT",0))_U_"1:"_VALMCNT + Q diff --git a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUHL7A.m b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUHL7A.m index dacc1143..45e4547a 100644 --- a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUHL7A.m +++ b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUHL7A.m @@ -1,48 +1,48 @@ -TIUHL7A ; SLC/AJB - TIUHL7 Msg Mgr ; 10OCT05 - ;;1.0;TEXT INTEGRATION UTILITIES;**200,228**;Jun 20, 1997 - Q -DELETE ; - D FULL^VALM1 - W ! I $$READ^TIUU("Y","Are you sure you wish to delete this message") D - . K ^XTMP("TIUHL7",$P(TIUMSG(TIUSEL),U,2),$P(TIUMSG(TIUSEL),U)) - . W !!,"Message deleted." - W ! I $$READ^TIUU("EA","Press to continue") - Q -REPROC ; - N HL771RF,HL771SF,HLCS,HLDOM,HLINSTN,HLPARAM,HLPID,HLREC,HLRFREQ,HLSFREQ - D FULL^VALM1 - W !!,"Reprocessing message..." - I '$$REPROC^HLUTIL($P(TIUMSG(TIUSEL),U),"PROCMSG^TIUHL7P1") W !,"finished.",! I $$READ^TIUU("EA","Press to continue") Q - W "ERROR. Unable to reprocess this message.",! - I $$READ^TIUU("EA","Press to continue") - Q -EN ; main entry point for TIUHL7 MSG VIEW - N TIULVL - D EN^VALM("TIUHL7 MSG VIEW") - K ^TMP("VALMAR",$J,TIULVL) - Q -HDR ; - Q -INIT ; - N TIULINE,TIUX - S TIULVL=VALMEVL,VALMCNT=0 - F TIUX="MSGRESULT","MSG" D - . N TIUCNT,TIUTEXT,TIUVAL S TIUVAL=80 ; TIUVAL is column width for display in LM - each line will be <=TIUVAL - . S TIULINE="" F S TIULINE=$O(^XTMP("TIUHL7",$P(TIUMSG(TIUSEL),U,2),$P(TIUMSG(TIUSEL),U),TIUX,TIULINE)) Q:'+TIULINE D - . . S TIUTEXT=^XTMP("TIUHL7",$P(TIUMSG(TIUSEL),U,2),$P(TIUMSG(TIUSEL),U),TIUX,TIULINE) - . . F TIUCNT=1:1:(($L(TIUTEXT)\TIUVAL)+1) S VALMCNT=VALMCNT+1 D SET^VALM10(VALMCNT,$E(TIUTEXT,(TIUVAL*(TIUCNT-1)+1),(TIUVAL*TIUCNT))) - . S VALMCNT=VALMCNT+1 D SET^VALM10(VALMCNT,"") - Q -HELP ; help code - I X="?" S POP=1 - D FULL^VALM1 - W !!,"The following actions are available:" - W !!,"Delete Message - Delete the current message" - W !,"Reprocess Message - Reprocess the current message",! - I +$G(POP) I $$READ^TIUU("EA","Press to continue") - S VALMBCK="R",POP=0 - Q -EXIT ; exit code - Q -EXPND ; expand code - Q +TIUHL7A ; SLC/AJB - TIUHL7 Msg Mgr ; 10OCT05 + ;;1.0;TEXT INTEGRATION UTILITIES;**200**;Jun 20, 1997 + Q +DELETE ; + D FULL^VALM1 + W ! I $$READ^TIUU("Y","Are you sure you wish to delete this message") D + . K ^XTMP("TIUHL7",$P(TIUMSG(TIUSEL),U,2),$P(TIUMSG(TIUSEL),U)) + . W !!,"Message deleted." + W ! I $$READ^TIUU("EA","Press to continue") + Q +REPROC ; + N HL771RF,HL771SF,HLCS,HLDOM,HLINSTN,HLPARAM,HLPID,HLREC,HLRFREQ,HLSFREQ + D FULL^VALM1 + W !!,"Reprocessing message..." + I '$$REPROC^HLUTIL($P(TIUMSG(TIUSEL),U),"PROCMSG^TIUHL7P1") W !,"finished.",! I $$READ^TIUU("EA","Press to continue") Q + W "ERROR. Unable to reprocess this message.",! + I $$READ^TIUU("EA","Press to continue") + Q +EN ; main entry point for TIUHL7 MSG VIEW + N TIULVL + D EN^VALM("TIUHL7 MSG VIEW") + K ^XTMP("VALMAR",$J,TIULVL) + Q +HDR ; + Q +INIT ; + N TIULINE,TIUX + S TIULVL=VALMEVL,VALMCNT=0 + F TIUX="MSGRESULT","MSG" D + . N TIUCNT,TIUTEXT,TIUVAL S TIUVAL=80 ; TIUVAL is column width for display in LM - each line will be <=TIUVAL + . S TIULINE="" F S TIULINE=$O(^XTMP("TIUHL7",$P(TIUMSG(TIUSEL),U,2),$P(TIUMSG(TIUSEL),U),TIUX,TIULINE)) Q:'+TIULINE D + . . S TIUTEXT=^XTMP("TIUHL7",$P(TIUMSG(TIUSEL),U,2),$P(TIUMSG(TIUSEL),U),TIUX,TIULINE) + . . F TIUCNT=1:1:(($L(TIUTEXT)\TIUVAL)+1) S VALMCNT=VALMCNT+1 D SET^VALM10(VALMCNT,$E(TIUTEXT,(TIUVAL*(TIUCNT-1)+1),(TIUVAL*TIUCNT))) + . S VALMCNT=VALMCNT+1 D SET^VALM10(VALMCNT,"") + Q +HELP ; help code + I X="?" S POP=1 + D FULL^VALM1 + W !!,"The following actions are available:" + W !!,"Delete Message - Delete the current message" + W !,"Reprocess Message - Reprocess the current message",! + I +$G(POP) I $$READ^TIUU("EA","Press to continue") + S VALMBCK="R",POP=0 + Q +EXIT ; exit code + Q +EXPND ; expand code + Q diff --git a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUHL7P1.m b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUHL7P1.m index 216f0278..14e3b472 100644 --- a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUHL7P1.m +++ b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUHL7P1.m @@ -1,132 +1,130 @@ -TIUHL7P1 ; SLC/AJB - TIUHL7 Msg Processing; January 6, 2006 - ;;1.0;TEXT INTEGRATION UTILITIES;**200,228**;Jun 20, 1997 - Q -PROCMSG ; - N DFN,DUZ,TIU,TIUDA,TIUDPRM,TIUDT,TIUERR,TIUI,TIUJ,TIUMSG,TIUNAME,TIUTMP,TIUFS,TIUCS,TIURS,TIUES,TIUSS,TIUZ - ; - ; quit if HL7 Message IEN is not present - ;I '+$G(HLMTIENS) Q - ; - ; remove HL7 message entries 7 days or older - D CLEAN^TIUHL7U1 - ; - ; sets field, component and repetition separators from HL7 Message - S TIUFS=$G(HL("FS")),TIUJ=0 F TIUI="TIUCS","TIURS","TIUES","TIUSS" S TIUJ=TIUJ+1 S @TIUI=$E(HL("ECH"),TIUJ,TIUJ) - ; - ; initializes variables and ^XTMP expiration - S TIU="TIU",(TIU("EC"),TIUDA)=0,TIUDT=+$$NOW^XLFDT,TIUNAME=$NA(^XTMP("TIUHL7",TIUDT,HLMTIENS)),^XTMP("TIUHL7",0)=$$FMADD^XLFDT(TIUDT,7)_U_TIUDT - ; - ; retrieves HL7 message and stores to temporary global - F TIUI=1:1 X HLNEXT Q:HLQUIT'>0 D - . S @TIUNAME@("MSG",TIUI)=HLNODE,TIUJ=0 - . F S TIUJ=$O(HLNODE(TIUJ)) Q:'TIUJ S @TIUNAME@("MSG",TIUI)=@TIUNAME@("MSG",TIUI)_HLNODE(TIUJ) - ; - ; places temporary global in local meory & adds EOM flag - M TIUMSG=@TIUNAME@("MSG") - S TIU("XTMP")=TIUNAME,TIUNAME="TIUMSG",TIUI="",TIUI=$O(TIUMSG(TIUI),-1),TIUI=TIUI+1,TIUMSG(TIUI)="EOM" - ; - ; verify message format - S TIUI="" F S TIUI=$O(@TIUNAME@(TIUI)) Q:@TIUNAME@(TIUI)="EOM" D - . S TIUJ=$S(TIUI=1:"MSH",TIUI=2:"EVN",TIUI=3:"PID",TIUI=4:"PV1",TIUI=5:"TXA",TIUI=6:"OBX",1:"OBX") - . I $P(@TIUNAME@(TIUI),TIUFS)'=TIUJ D ERR^TIUHL7U1("MSG",1,"000.000","Improper/missing message format: "_TIUJ_" segment.") - ; - ; if message fails check, quit processing - I +TIU("EC") D ACK^TIUHL7U1("AR",TIUNAME,-1) Q - ; - ; get patient name [required] - S TIU("PTNAME")=$$UPPER^HLFNC($$FMNAME^HLFNC($P($P($G(@TIUNAME@(3)),TIUFS,6),TIUCS,1,4),TIUCS)),TIU("PTNAME")=$$REMESC^TIUHL7U1(TIU("PTNAME")) - ; - ; get patient ICN/SSN/DFN - order may vary [conditionally required] - S (TIU("DFN"),TIU("ICN"),TIU("SSN"))="" F TIUI=1:1:$L($P($G(@TIUNAME@(3)),TIUFS,4),TIURS) S TIUJ=$P($P($G(@TIUNAME@(3)),TIUFS,4),TIURS,TIUI) I +TIUJ>0 D - . S TIUTMP=$S($P(TIUJ,TIUCS,5)="NI":"ICN",$P(TIUJ,TIUCS,5)="SS":"SSN",$P(TIUJ,TIUCS,5)="PI":"DFN",1:"UNK") - . S @TIU@(TIUTMP)=$$REMESC^TIUHL7U1($P(TIUJ,TIUCS)) I TIUTMP="ICN",@TIU@(TIUTMP)["V" S @TIU@(TIUTMP)=$P(@TIU@(TIUTMP),"V") - ; - ; get PATIENT DOB (optional) - S TIU("DOB")=$$HL7TFM^XLFDT($$REMESC^TIUHL7U1($P($G(@TIUNAME@(3)),TIUFS,8))) - ; - ; get DOCUMENT TITLE (#8925.1) [required] & set IEN - S TIU("TITLE")=$$UPPER^HLFNC($P($G(@TIUNAME@(5)),TIUFS,17)),TIU("TITLE")=$$REMESC^TIUHL7U1(TIU("TITLE")) - S TIU("TDA")=$$LU^TIUHL7U1(8925.1,TIU("TITLE"),"X","I $P(^TIU(8925.1,+Y,0),U,4)=""DOC""") I $L(TIU("TITLE"))'>0 S TIU("TITLE")="[UNKNOWN]" - ; - ; get DOCUMENT AVAILABILITY [optional] - S TIU("AVAIL")=$$REMESC^TIUHL7U1($P($G(@TIUNAME@(5)),TIUFS,20)) - ; - ;gets DOCUMENT COMPLETION STATUS [optional] - S TIU("COMP")=$$REMESC^TIUHL7U1($P($G(@TIUNAME@(5)),TIUFS,18)) - ; - ; get REFERENCE DATE [required] - S TIU("RFDT")=$$HL7TFM^XLFDT($$REMESC^TIUHL7U1($P($G(@TIUNAME@(5)),TIUFS,5))) I TIU("RFDT")'>-1 D ERR^TIUHL7U1("TXA",4,"0000.00","Invalid HL7 date format for ACTIVITY DATE/TIME[REFERENCE DATE/TIME].") - I +$P(TIU("RFDT"),"."),'+$P(TIU("RFDT"),".",2) S $P(TIU("RFDT"),".",2)=$P($$NOW^XLFDT,".",2) - ; - ; get EPISODE BEGIN DT/TIME [conditionally required for DISCHARGE SUMMARIES] - S TIU("EPDT")=$$HL7TFM^XLFDT($$REMESC^TIUHL7U1($P($G(@TIUNAME@(4)),TIUFS,45))) I TIU("EPDT")'>-1 D ERR^TIUHL7U1("PV1",44,"0000.00","Invalid HL7 date format for ADMIT DATE/TIME [EPISODE BEGIN DATE/TIME].") - I +$P(TIU("EPDT"),"."),'+$P(TIU("EPDT"),".",2) S $P(TIU("EPDT"),".",2)=$P($$NOW^XLFDT,".",2) - ; - ; get DICTATION DT/TIME [optional] - S TIU("DICDT")=$$HL7TFM^XLFDT($$REMESC^TIUHL7U1($P($G(@TIUNAME@(5)),TIUFS,7))) I TIU("DICDT")'>-1 D ERR^TIUHL7U1("TXA",6,"0000.00","Invalid HL7 date format for TRANSCRIPTION DATE/TIME[DICTATION DATE/TIME].") - I +$P(TIU("DICDT"),"."),'+$P(TIU("DICDT"),".",2) S $P(TIU("DICDT"),".",2)=$P($$NOW^XLFDT,".",2) - ; - ; get VISIT # [optional] - S TIU("VNUM")=$$REMESC^TIUHL7U1($P($G(@TIUNAME@(4)),TIUFS,20)) - ; - ; get HOSPITAL LOCATION [conditionally required for NEW VISITS] - S TIU("HLOC")=$$REMESC^TIUHL7U1($P($P($G(@TIUNAME@(4)),TIUFS,4),TIUCS)) I +$L(TIU("HLOC")) S TIU("HLOC")=+$$LU^TIUHL7U1(44,TIU("HLOC")) - ; - ; get AUTHOR/DICTATOR SSN or IEN [optional] & NAME [required] - S TIUTMP=$S($P($P($G(@TIUNAME@(5)),TIUFS,10),TIUCS,9)'="USSSA":"AUDA",1:"AUSSN") S @TIU@(TIUTMP)=$P($P($G(@TIUNAME@(5)),TIUFS,10),TIUCS) - S TIU("AUNAME")=$$UPPER^HLFNC($$FMNAME^HLFNC($P($P($G(@TIUNAME@(5)),TIUFS,10),TIUCS,2,4),TIUCS)),TIU("AUNAME")=$$REMESC^TIUHL7U1(TIU("AUNAME")) - ; - ; get EXPECTED COSIGNER SSN or IEN [optional] & NAME [conditionally required] - S TIUTMP=$S($P($P($G(@TIUNAME@(5)),TIUFS,11),TIUCS,9)'="USSSA":"CSDA",1:"CSSSN") S @TIU@(TIUTMP)=$P($P($G(@TIUNAME@(5)),TIUFS,11),TIUCS) - S TIU("CSNAME")=$$UPPER^HLFNC($$FMNAME^HLFNC($P($P($G(@TIUNAME@(5)),TIUFS,11),TIUCS,2,4),TIUCS)),TIU("CSNAME")=$$REMESC^TIUHL7U1(TIU("CSNAME")) - ; - ; get ENTERED BY SSN or IEN [optional] & NAME [optional] - S TIUTMP=$S($P($P($G(@TIUNAME@(5)),TIUFS,12),TIUCS,9)'="USSSA":"EBDA",1:"EBSSN") S @TIU@(TIUTMP)=$P($P($G(@TIUNAME@(5)),TIUFS,12),TIUCS) - S TIU("EBNAME")=$$UPPER^HLFNC($$FMNAME^HLFNC($P($P($G(@TIUNAME@(5)),TIUFS,12),TIUCS,2,4),TIUCS)),TIU("EBNAME")=$$REMESC^TIUHL7U1(TIU("EBNAME")) - ; - ; get SURGICAL CASE or CONSULT # [conditionally required for SURGICAL REPORTS or CONSULT titles] - S TIUTMP=$S($$MEMBEROF^TIUHL7U1(TIU("TITLE"),"CONSULTS"):"CNCN",1:"SRCN") S @TIU@(TIUTMP)=$$REMESC^TIUHL7U1($P($P($G(@TIUNAME@(5)),TIUFS,13),TIUCS)) - ; - ; gets SIGNATURE/COSIGNATURE DATE/TIME [optional] - S TIU("SIGNED")=$$REMESC^TIUHL7U1($P($P($G(@TIUNAME@(5)),TIUFS,23),TIUCS,15)),TIU("CSIGNED")=$$REMESC^TIUHL7U1($P($P($G(@TIUNAME@(5)),TIUFS,23),TIUCS,29)) - ; - ; get DOCUMENT TEXT [required] - S TIUTMP="" F S TIUTMP=$O(@TIUNAME@(TIUTMP)) Q:TIUTMP="" D:$P($G(@TIUNAME@(TIUTMP)),TIUFS)="OBX" - . I $P(@TIUNAME@(TIUTMP),TIUFS,2)=1,$L($G(TIU("SUB")))'>0 S TIU("SUB")=$P($P(@TIUNAME@(TIUTMP),TIUFS,4),TIUCS,2),TIU("SUB")=$$REMESC^TIUHL7U1(TIU("SUB")) - . F TIUI=1:1:$L($P(@TIUNAME@(TIUTMP),TIUFS,6),TIURS) S TIUZ("TEXT",TIUI,0)=$P($P(@TIUNAME@(TIUTMP),TIUFS,6),TIURS,TIUI),TIUZ("TEXT",TIUI,0)=$$STRIP^TIUHL7U2($$REMESC^TIUHL7U1(TIUZ("TEXT",TIUI,0))) - ; - ; begin data verification - ; PATIENT IDENTIFICATION - D - . N TIUI,TIUJ,TIUERR,TIUN,TIUOUT,TIUTMP,TIUQUIT - . I '+$L($G(TIU("PTNAME"))) D ERR^TIUHL7U1("PID",5,"0000.00","Missing PATIENT NAME.") - . ; verify there is at least one piece of numeric PATIENT ID - . S TIUJ=0 F TIUI="ICN","DFN","SSN" S:+$G(TIU(TIUI)) TIUJ=TIUJ+1 - . I '+TIUJ D ERR^TIUHL7U1("PID",5,"0000.00","Missing numeric PATIENT ID data; at least one numeric identifier [ICN,SSN,DFN] must be sent.") Q - . I +TIUJ=1 D - . . I '+$L($P(TIU("PTNAME"),",",2)) D ERR^TIUHL7U1("PID",5,"0000.00","FIRST NAME/INITIAL missing with only one numeric identifier sent.") - . . S TIUN("PT")=$$PNAME^TIUHL7U1(TIU("PTNAME")),TIUTMP=1 - . E S TIUN("PT")=$P(TIU("PTNAME"),",") - . S TIUJ=0 - . ; check DFN if available - . I +$G(TIU("DFN")) S TIUJ=TIUJ+1,DFN(TIUJ)=TIU("DFN") D - . . I +$G(TIUTMP) S TIUN("DFN")=$$PNAME^TIUHL7U1($$GET1^DIQ(2,TIU("DFN"),.01)) - . . E S TIUN("DFN")=$P($$GET1^DIQ(2,TIU("DFN"),.01),",") - . . I '$$COMPARE^TIUHL7U1(TIUN("DFN"),TIUN("PT")) D ERR^TIUHL7U1("PID",5,"0000.00","PATIENT NAME discrepancy between HL7 message name ["_TIU("PTNAME")_"] & the HL7 message DFN #"_TIU("DFN")_" ["_$$GET1^DIQ(2,DFN(TIUJ),.01)_"].") - . ; check ICN if available - . I +$G(TIU("ICN")) S TIUJ=TIUJ+1,DFN(TIUJ)=+$$FIND1^DIC(2,"","X",TIU("ICN"),"AICN") D - . . I +$G(TIUTMP) S TIUN("ICN")=$$PNAME^TIUHL7U1($$GET1^DIQ(2,DFN(TIUJ),.01)) - . . E S TIUN("ICN")=$P($$GET1^DIQ(2,DFN(TIUJ),.01),",") - . . I '$$COMPARE^TIUHL7U1(TIUN("ICN"),TIUN("PT")) D ERR^TIUHL7U1("PID",5,"0000.00","PATIENT NAME discrepancy between HL7 message name ["_TIU("PTNAME")_"] & the HL7 message ICN #"_TIU("ICN")_" ["_$$GET1^DIQ(2,DFN(TIUJ),.01)_"].") - . ; check SSN if available - . I +$G(TIU("SSN")) S TIUJ=TIUJ+1,DFN(TIUJ)=+$$FIND1^DIC(2,"","X",TIU("SSN"),"SSN") D - . . I +$G(TIUTMP) S TIUN("SSN")=$$PNAME^TIUHL7U1($$GET1^DIQ(2,DFN(TIUJ),.01)) - . . E S TIUN("SSN")=$P($$GET1^DIQ(2,DFN(TIUJ),.01),",") - . . I '$$COMPARE^TIUHL7U1(TIUN("SSN"),TIUN("PT")) D ERR^TIUHL7U1("PID",5,"0000.00","PATIENT NAME discrepancy between HL7 message name ["_TIU("PTNAME")_"] & the HL7 message SSN #"_TIU("SSN")_" ["_$$GET1^DIQ(2,DFN(TIUJ),.01)_"].") - . ; compare DFN lookup values - . I TIUJ>1 S (TIUI,TIUJ)=0 F S TIUI=$O(DFN(TIUI)) Q:'TIUI I TIUI>1 S TIUJ=TIUI-1 I DFN(TIUI)'=DFN(TIUJ) D ERR^TIUHL7U1("PID",5,"0000.00","PATIENT IEN discrepancies between the numeric lookups.") Q - . I TIU("EC") Q - . S DFN=DFN(1) - ; - D CONTINUE^TIUHL7P2 - Q +TIUHL7P1 ; SLC/AJB - TIUHL7 Msg Processing; January 6, 2006 + ;;1.0;TEXT INTEGRATION UTILITIES;**200**;Jun 20, 1997 + Q +PROCMSG ; + N DFN,DUZ,TIU,TIUDA,TIUDPRM,TIUDT,TIUERR,TIUI,TIUJ,TIUMSG,TIUNAME,TIUTMP,TIUFS,TIUCS,TIURS,TIUES,TIUSS,TIUZ + ; + ; quit if HL7 Message IEN is not present + I '+$G(HLMTIENS) Q + ; + ; remove HL7 message entries 7 days or older + D CLEAN^TIUHL7U1 + ; + ; sets field, component and repetition separators from HL7 Message + S TIUFS=$G(HL("FS")),TIUJ=0 F TIUI="TIUCS","TIURS","TIUES","TIUSS" S TIUJ=TIUJ+1 S @TIUI=$E(HL("ECH"),TIUJ,TIUJ) + ; + ; initializes variables and ^XTMP expiration + S TIU="TIU",(TIU("EC"),TIUDA)=0,TIUDT=+$$NOW^XLFDT,TIUNAME=$NA(^XTMP("TIUHL7",TIUDT,HLMTIENS)),^XTMP("TIUHL7",0)=$$FMADD^XLFDT(TIUDT,7)_U_TIUDT + ; + ; retrieves HL7 message and stores to temporary global + F TIUI=1:1 X HLNEXT Q:HLQUIT'>0 D + . S @TIUNAME@("MSG",TIUI)=HLNODE,TIUJ=0 + . F S TIUJ=$O(HLNODE(TIUJ)) Q:'TIUJ S @TIUNAME@("MSG",TIUI)=@TIUNAME@("MSG",TIUI)_HLNODE(TIUJ) + ; + ; places temporary global in local memory + S TIUI="" F S TIUI=$O(@TIUNAME@("MSG",TIUI)) Q:'+TIUI S TIUMSG(TIUI)=@TIUNAME@("MSG",TIUI) + S TIU("XTMP")=TIUNAME,TIUNAME="TIUMSG" + ; + ; verifies message format + S TIUI="" F S TIUI=$O(@TIUNAME@(TIUI)) Q:'+TIUI D + . S TIUI=0 F TIUJ="MSH","EVN","PID","PV1","TXA","OBX" S TIUI=TIUI+1 D + . . I $P(@TIUNAME@(TIUI),TIUFS)'=TIUJ D ERR^TIUHL7U1("MSG",1,"000.000","Improper message format: "_TIUJ_" segment.") + ; + ; parse message data + ; get patient name [required] + S TIU("PTNAME")=$$UPPER^HLFNC($$FMNAME^HLFNC($P($P($G(@TIUNAME@(3)),TIUFS,6),TIUCS,1,4),TIUCS)),TIU("PTNAME")=$$REMESC^TIUHL7U1(TIU("PTNAME")) + ; + ; get patient ICN/SSN/DFN - order may vary [conditionally required] + S (TIU("DFN"),TIU("ICN"),TIU("SSN"))="" F TIUI=1:1:$L($P($G(@TIUNAME@(3)),TIUFS,4),TIURS) S TIUJ=$P($P($G(@TIUNAME@(3)),TIUFS,4),TIURS,TIUI) I +TIUJ>0 D + . S TIUTMP=$S($P(TIUJ,TIUCS,5)="NI":"ICN",$P(TIUJ,TIUCS,5)="SS":"SSN",$P(TIUJ,TIUCS,5)="PI":"DFN",1:"UNK") + . S @TIU@(TIUTMP)=$$REMESC^TIUHL7U1($P(TIUJ,TIUCS)) I TIUTMP="ICN",@TIU@(TIUTMP)["V" S @TIU@(TIUTMP)=$P(@TIU@(TIUTMP),"V") + ; + ; get PATIENT DOB (optional) + S TIU("DOB")=$$HL7TFM^XLFDT($$REMESC^TIUHL7U1($P($G(@TIUNAME@(3)),TIUFS,8))) + ; + ; get DOCUMENT TITLE (#8925.1) [required] & set IEN + S TIU("TITLE")=$$UPPER^HLFNC($P($G(@TIUNAME@(5)),TIUFS,17)),TIU("TITLE")=$$REMESC^TIUHL7U1(TIU("TITLE")) + S TIU("TDA")=$$LU^TIUHL7U1(8925.1,TIU("TITLE"),"X","I $P(^TIU(8925.1,+Y,0),U,4)=""DOC""") I $L(TIU("TITLE"))'>0 S TIU("TITLE")="[UNKNOWN]" + ; + ; get DOCUMENT AVAILABILITY [optional] + S TIU("AVAIL")=$$REMESC^TIUHL7U1($P($G(@TIUNAME@(5)),TIUFS,20)) + ; + ;gets DOCUMENT COMPLETION STATUS [optional] + S TIU("COMP")=$$REMESC^TIUHL7U1($P($G(@TIUNAME@(5)),TIUFS,18)) + ; + ; get REFERENCE DATE [required] + S TIU("RFDT")=$$HL7TFM^XLFDT($$REMESC^TIUHL7U1($P($G(@TIUNAME@(5)),TIUFS,5))) I TIU("RFDT")'>-1 D ERR^TIUHL7U1("TXA",4,"0000.00","Invalid HL7 date format for ACTIVITY DATE/TIME[REFERENCE DATE/TIME].") + I +$P(TIU("RFDT"),"."),'+$P(TIU("RFDT"),".",2) S $P(TIU("RFDT"),".",2)=$P($$NOW^XLFDT,".",2) + ; + ; get EPISODE BEGIN DT/TIME [conditionally required for DISCHARGE SUMMARIES] + S TIU("EPDT")=$$HL7TFM^XLFDT($$REMESC^TIUHL7U1($P($G(@TIUNAME@(4)),TIUFS,45))) I TIU("EPDT")'>-1 D ERR^TIUHL7U1("PV1",44,"0000.00","Invalid HL7 date format for ADMIT DATE/TIME [EPISODE BEGIN DATE/TIME].") + I +$P(TIU("EPDT"),"."),'+$P(TIU("EPDT"),".",2) S $P(TIU("EPDT"),".",2)=$P($$NOW^XLFDT,".",2) + ; + ; get DICTATION DT/TIME [optional] + S TIU("DICDT")=$$HL7TFM^XLFDT($$REMESC^TIUHL7U1($P($G(@TIUNAME@(5)),TIUFS,7))) I TIU("DICDT")'>-1 D ERR^TIUHL7U1("TXA",6,"0000.00","Invalid HL7 date format for TRANSCRIPTION DATE/TIME[DICTATION DATE/TIME].") + I +$P(TIU("DICDT"),"."),'+$P(TIU("DICDT"),".",2) S $P(TIU("DICDT"),".",2)=$P($$NOW^XLFDT,".",2) + ; + ; get VISIT # [optional] + S TIU("VNUM")=$$REMESC^TIUHL7U1($P($G(@TIUNAME@(4)),TIUFS,20)) + ; + ; get HOSPITAL LOCATION [conditionally required for NEW VISITS] + S TIU("HLOC")=$$REMESC^TIUHL7U1($P($P($G(@TIUNAME@(4)),TIUFS,4),TIUCS)) I +$L(TIU("HLOC")) S TIU("HLOC")=+$$LU^TIUHL7U1(44,TIU("HLOC")) + ; + ; get AUTHOR/DICTATOR SSN or IEN [optional] & NAME [required] + S TIUTMP=$S($P($P($G(@TIUNAME@(5)),TIUFS,10),TIUCS,9)'="USSSA":"AUDA",1:"AUSSN") S @TIU@(TIUTMP)=$P($P($G(@TIUNAME@(5)),TIUFS,10),TIUCS) + S TIU("AUNAME")=$$UPPER^HLFNC($$FMNAME^HLFNC($P($P($G(@TIUNAME@(5)),TIUFS,10),TIUCS,2,4),TIUCS)),TIU("AUNAME")=$$REMESC^TIUHL7U1(TIU("AUNAME")) + ; + ; get EXPECTED COSIGNER SSN or IEN [optional] & NAME [conditionally required] + S TIUTMP=$S($P($P($G(@TIUNAME@(5)),TIUFS,11),TIUCS,9)'="USSSA":"CSDA",1:"CSSSN") S @TIU@(TIUTMP)=$P($P($G(@TIUNAME@(5)),TIUFS,11),TIUCS) + S TIU("CSNAME")=$$UPPER^HLFNC($$FMNAME^HLFNC($P($P($G(@TIUNAME@(5)),TIUFS,11),TIUCS,2,4),TIUCS)),TIU("CSNAME")=$$REMESC^TIUHL7U1(TIU("CSNAME")) + ; + ; get ENTERED BY SSN or IEN [optional] & NAME [optional] + S TIUTMP=$S($P($P($G(@TIUNAME@(5)),TIUFS,12),TIUCS,9)'="USSSA":"EBDA",1:"EBSSN") S @TIU@(TIUTMP)=$P($P($G(@TIUNAME@(5)),TIUFS,12),TIUCS) + S TIU("EBNAME")=$$UPPER^HLFNC($$FMNAME^HLFNC($P($P($G(@TIUNAME@(5)),TIUFS,12),TIUCS,2,4),TIUCS)),TIU("EBNAME")=$$REMESC^TIUHL7U1(TIU("EBNAME")) + ; + ; get SURGICAL CASE or CONSULT # [conditionally required for SURGICAL REPORTS or CONSULT titles] + S TIUTMP=$S($$MEMBEROF^TIUHL7U1(TIU("TITLE"),"CONSULTS"):"CNCN",1:"SRCN") S @TIU@(TIUTMP)=$$REMESC^TIUHL7U1($P($P($G(@TIUNAME@(5)),TIUFS,13),TIUCS)) + ; + ; gets SIGNATURE/COSIGNATURE DATE/TIME [optional] + S TIU("SIGNED")=$$REMESC^TIUHL7U1($P($P($G(@TIUNAME@(5)),TIUFS,23),TIUCS,15)),TIU("CSIGNED")=$$REMESC^TIUHL7U1($P($P($G(@TIUNAME@(5)),TIUFS,23),TIUCS,29)) + ; + ; get DOCUMENT TEXT [required] + S TIUTMP="" F S TIUTMP=$O(@TIUNAME@(TIUTMP)) Q:TIUTMP="" D:$P($G(@TIUNAME@(TIUTMP)),TIUFS)="OBX" + . I $P(@TIUNAME@(TIUTMP),TIUFS,2)=1,$L($G(TIU("SUB")))'>0 S TIU("SUB")=$P($P(@TIUNAME@(TIUTMP),TIUFS,4),TIUCS,2),TIU("SUB")=$$REMESC^TIUHL7U1(TIU("SUB")) + . F TIUI=1:1:$L($P(@TIUNAME@(TIUTMP),TIUFS,6),TIURS) S TIUZ("TEXT",TIUI,0)=$P($P(@TIUNAME@(TIUTMP),TIUFS,6),TIURS,TIUI),TIUZ("TEXT",TIUI,0)=$$STRIP^TIUHL7U2($$REMESC^TIUHL7U1(TIUZ("TEXT",TIUI,0))) + ; + ; begin data verification + ; PATIENT IDENTIFICATION + D + . N TIUI,TIUJ,TIUERR,TIUN,TIUOUT,TIUTMP,TIUQUIT + . I '+$L($G(TIU("PTNAME"))) D ERR^TIUHL7U1("PID",5,"0000.00","Missing PATIENT NAME.") + . ; verify there is at least one piece of numeric PATIENT ID + . S TIUJ=0 F TIUI="ICN","DFN","SSN" S:+$G(TIU(TIUI)) TIUJ=TIUJ+1 + . I '+TIUJ D ERR^TIUHL7U1("PID",5,"0000.00","Missing numeric PATIENT ID data; at least one numeric identifier [ICN,SSN,DFN] must be sent.") Q + . I +TIUJ=1 D + . . I '+$L($P(TIU("PTNAME"),",",2)) D ERR^TIUHL7U1("PID",5,"0000.00","FIRST NAME/INITIAL missing with only one numeric identifier sent.") + . . S TIUN("PT")=$$PNAME^TIUHL7U1(TIU("PTNAME")),TIUTMP=1 + . E S TIUN("PT")=$P(TIU("PTNAME"),",") + . S TIUJ=0 + . ; check DFN if available + . I +$G(TIU("DFN")) S TIUJ=TIUJ+1,DFN(TIUJ)=TIU("DFN") D + . . I +$G(TIUTMP) S TIUN("DFN")=$$PNAME^TIUHL7U1($$GET1^DIQ(2,TIU("DFN"),.01)) + . . E S TIUN("DFN")=$P($$GET1^DIQ(2,TIU("DFN"),.01),",") + . . I '$$COMPARE^TIUHL7U1(TIUN("DFN"),TIUN("PT")) D ERR^TIUHL7U1("PID",5,"0000.00","PATIENT NAME discrepancy between HL7 message name ["_TIU("PTNAME")_"] & the HL7 message DFN #"_TIU("DFN")_" ["_$$GET1^DIQ(2,DFN(TIUJ),.01)_"].") + . ; check ICN if available + . I +$G(TIU("ICN")) S TIUJ=TIUJ+1,DFN(TIUJ)=+$$FIND1^DIC(2,"","X",TIU("ICN"),"AICN") D + . . I +$G(TIUTMP) S TIUN("ICN")=$$PNAME^TIUHL7U1($$GET1^DIQ(2,DFN(TIUJ),.01)) + . . E S TIUN("ICN")=$P($$GET1^DIQ(2,DFN(TIUJ),.01),",") + . . I '$$COMPARE^TIUHL7U1(TIUN("ICN"),TIUN("PT")) D ERR^TIUHL7U1("PID",5,"0000.00","PATIENT NAME discrepancy between HL7 message name ["_TIU("PTNAME")_"] & the HL7 message ICN #"_TIU("ICN")_" ["_$$GET1^DIQ(2,DFN(TIUJ),.01)_"].") + . ; check SSN if available + . I +$G(TIU("SSN")) S TIUJ=TIUJ+1,DFN(TIUJ)=+$$FIND1^DIC(2,"","X",TIU("SSN"),"SSN") D + . . I +$G(TIUTMP) S TIUN("SSN")=$$PNAME^TIUHL7U1($$GET1^DIQ(2,DFN(TIUJ),.01)) + . . E S TIUN("SSN")=$P($$GET1^DIQ(2,DFN(TIUJ),.01),",") + . . I '$$COMPARE^TIUHL7U1(TIUN("SSN"),TIUN("PT")) D ERR^TIUHL7U1("PID",5,"0000.00","PATIENT NAME discrepancy between HL7 message name ["_TIU("PTNAME")_"] & the HL7 message SSN #"_TIU("SSN")_" ["_$$GET1^DIQ(2,DFN(TIUJ),.01)_"].") + . ; compare DFN lookup values + . I TIUJ>1 S (TIUI,TIUJ)=0 F S TIUI=$O(DFN(TIUI)) Q:'TIUI I TIUI>1 S TIUJ=TIUI-1 I DFN(TIUI)'=DFN(TIUJ) D ERR^TIUHL7U1("PID",5,"0000.00","PATIENT IEN discrepancies between the numeric lookups.") Q + . I TIU("EC") Q + . S DFN=DFN(1) + ; + D CONTINUE^TIUHL7P2 + Q diff --git a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUHL7P2.m b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUHL7P2.m index 970e050e..d7e32f39 100644 --- a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUHL7P2.m +++ b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUHL7P2.m @@ -1,74 +1,73 @@ -TIUHL7P2 ; SLC/AJB - TIUHL7 Msg Processing; March 23, 2005 - ;;1.0;TEXT INTEGRATION UTILITIES;**200,228**;Jun 20, 1997 - Q -CONTINUE ; data verification - ; - ; DOCUMENT TEXT - D - . N TIUI S TIUTMP=0 F S TIUTMP=$O(TIUZ("TEXT",TIUTMP)) Q:'TIUTMP I +$L(TIUZ("TEXT",TIUTMP,0)) S TIUI=1 - . I '+$G(TIUI) D ERR^TIUHL7U1("OBX",1,"0000.00","Missing DOCUMENT TEXT.") - ; - ; DOCUMENT TITLE - I +TIU("TDA")'>0 D ERR^TIUHL7U1("TXA",16,"0000.00","Could not resolve the document title "_TIU("TITLE")_".") - I +$$GET1^DIQ(8925.1,TIU("TDA"),.07,"I")'=11 D ERR^TIUHL7U1("TXA",16,"0000.00","The document title "_TIU("TITLE")_" must be ACTIVE before use.") - ; - ; AUTHOR/DICTATOR - D - . I '+$L(TIU("AUNAME")) D ERR^TIUHL7U1("TXA",9,"0000.00","Missing AUTHOR/DICTATOR name from HL7 message.") Q - . I '+$G(TIU("AUDA")),'+$G(TIU("AUSSN")) S TIU("AUDA")=$$LU^TIUHL7U1(200,TIU("AUNAME"),"X") I '+TIU("AUDA") D ERR^TIUHL7U1("TXA",9,"0000.00","AUTHOR/DICTATOR name lookup failed for ["_TIU("AUNAME")_"].") Q - . I '+$G(TIU("AUDA")),+$G(TIU("AUSSN")) S TIU("AUDA")=+$$FIND1^DIC(200,"","X",+$G(TIU("AUSSN")),"SSN") I '+TIU("AUDA") D ERR^TIUHL7U1("TXA",9,"0000.00","SSN ["_TIU("AUSSN")_"] lookup failed for AUTHOR/DICTATOR.") Q - . I '$$COMPARE^TIUHL7U1($$GET1^DIQ(200,TIU("AUDA"),.01),TIU("AUNAME")) D - . . D ERR^TIUHL7U1("TXA",9,"0000.00","AUTHOR/DICTATOR name discrepancy between HL7 message IEN/SSN ["_$$GET1^DIQ(200,TIU("AUDA"),.01)_"]"_" & the HL7 message name ["_TIU("AUNAME")_"].") - ; - ; EXPECTED CO-SIGNER [ignored if AUTHOR/DICTATOR does not require] - I $$REQCOSIG^TIULP($G(TIU("TDA")),,$G(TIU("AUDA")),$G(TIU("RFDT"))) D - . N TIUTMP - . S TIUZ(1506)=1 - . I +$L($G(TIU("CSNAME")))!(+$G(TIU("CSDA")))!(+$G(TIU("CSSSN"))) D - . . I '+$L($G(TIU("CSNAME"))) D ERR^TIUHL7U1("TXA",10,"0000.00","Missing EXPECTED COSIGNER name from HL7 message.") Q - . . I '+$G(TIU("CSDA")),'+$G(TIU("CSSSN")) S TIU("CSDA")=$$LU^TIUHL7U1(200,TIU("CSNAME"),"X") I '+TIU("CSDA") D ERR^TIUHL7U1("TXA",10,"0000.000","EXPECTED COSIGNER name lookup failed for ["_TIU("CSNAME")_"].") Q - . . I '+$G(TIU("CSDA")),+$G(TIU("CSSSN")) S TIU("CSDA")=+$$FIND1^DIC(200,"","X",+$G(TIU("CSSSN")),"SSN") I '+TIU("CSDA") D ERR^TIUHL7U1("TXA",10,"0000.00","SSN ["_TIU("CSSSN")_"] lookup failed for EXPECTED COSIGNER.") Q - . . I '$$COMPARE^TIUHL7U1($$GET1^DIQ(200,TIU("CSDA"),.01),TIU("CSNAME")) D - . . . D ERR^TIUHL7U1("TXA",10,"0000.00","EXPECTED COSIGNER name discrepancy between HL7 message IEN/SSN ["_$$GET1^DIQ(200,TIU("CSDA"),.01)_"]"_" & HL7 message name ["_TIU("CSNAME")_"].") - . I '+$G(TIU("CSDA")) D ERR^TIUHL7U1("TXA",10,"0000.000","Unable to resolve EXPECTED COSIGNER; the AUTHOR/DICTATOR ["_TIU("AUNAME")_"] requires COSIGNATURE.") - ; - ; ENTERED BY [optional] - I +$L($G(TIU("EBNAME")))!(+$G(TIU("EBDA")))!(+$G(TIU("EBSSN"))) D - . I '+$L($G(TIU("EBNAME"))) D ERR^TIUHL7U1("TXA",11,"0000.00","Missing ENTERED BY name from HL7 message.") Q - . I '+$G(TIU("EBDA")),'+$G(TIU("EBSSN")) S TIU("EBDA")=$$LU^TIUHL7U1(200,TIU("EBNAME"),"X") I '+TIU("EBDA") D ERR^TIUHL7U1("TXA",11,"0000.000","ENTERED BY name lookup failed for ["_TIU("EBNAME")_"].") Q - . I '+$G(TIU("EBDA")),+$G(TIU("EBSSN")) S TIU("EBDA")=+$$FIND1^DIC(200,"","X",+$G(TIU("EBSSN")),"SSN") I '+TIU("EBDA") D ERR^TIUHL7U1("TXA",11,"0000.00","SSN ["_TIU("EBSSN")_"] lookup failed for ENTERED BY.") Q - . I '$$COMPARE^TIUHL7U1($$GET1^DIQ(200,TIU("EBDA"),.01),TIU("EBNAME")) D - . . D ERR^TIUHL7U1("TXA",11,"0000.00","ENTERED BY name discrepancy between HL7 message IEN/SSN ["_$$GET1^DIQ(200,TIU("EBDA"),.01)_"]"_" & HL7 message name ["_TIU("EBNAME")_"].") - ; - ; EPISODE BEGIN DATE/TIME for DISCHARGE SUMMARIES - I $$MEMBEROF^TIUHL7U1(TIU("TITLE"),"DISCHARGE SUMMARIES") D - . I '+$G(TIU("CSDA")) D ERR^TIUHL7U1("TXA",10,"0000.000","DISCHARGE SUMMARIES require an ATTENDING PHYSICIAN (EXPECTED COSIGNER).") - . S TIUZ(1209)=$G(TIU("CSDA")) - . I +TIU("VNUM") D Q - . . I '$$COMPARE^TIUHL7U1($$GET1^DIQ(9000010,TIU("VNUM"),.05),$S(+$G(DFN):$$GET1^DIQ(2,DFN,.01),1:TIU("PTNAME"))) D - . . . D ERR^TIUHL7U1("PV1",19,"0000.00","HL7 message PATIENT NAME ["_TIU("PTNAME")_"] does not match VISIT PATIENT NAME ["_$$GET1^DIQ(9000010,TIU("VNUM"),.05)_"].") Q - . . S TIU("EPDT")=$$GET1^DIQ(9000010,TIU("VNUM"),.01,"I"),TIU("VSTR")=$$VSTRBLD^TIUSRVP(TIU("VNUM")) - . I '+TIU("EPDT") D ERR^TIUHL7U1("PV1",44,"0000.000",TIU("TITLE")_" requires an EPISODE BEGIN DATE/TIME.") Q - . I '+$$GETADMIT^TIUHL7U1(+$G(DFN),TIU("EPDT")) D ERR^TIUHL7U1("PV1","44","0000.00","Could not resolve ADMISSION DT[TIME] for "_$$FMTE^XLFDT(TIUDT)_".") - ; - ; VISIT information for PROGRESS NOTES - I $$MEMBEROF^TIUHL7U1(TIU("TITLE"),"PROGRESS NOTES") D - . I TIU("VNUM")="NEW" D Q - . . N TYP - . . I '+TIU("HLOC"),TIU("AVAIL")'="AV" D ERR^TIUHL7U1("PV1",4,"0000.00","Missing/Invalid HOSPITAL LOCATION ('AV' not set); required for NEW visits.") Q - . . I +TIU("EPDT")'>0 S TIU("EPDT")=$$NOW^XLFDT - . . I $L(TIU("EPDT"),".")=1 S TIU("EPDT")=TIU("EPDT")_"."_$P($$NOW^XLFDT,".",2) - . . I +TIU("HLOC") I $$GET1^DIQ(44,TIU("HLOC"),2,"I")="W" S TYP="I" - . . I +TIU("HLOC")'>0 S TIU("HLOC")="" - . . S TIU("VSTR")=TIU("HLOC")_";"_TIU("EPDT")_";"_$S($G(TYP)="I":"I",TIU("AVAIL")="AV":"E",1:"A") - . I +TIU("VNUM") D Q - . . I '$$COMPARE^TIUHL7U1($$GET1^DIQ(9000010,TIU("VNUM"),.05),$S(+$G(DFN):$$GET1^DIQ(2,DFN,.01),1:TIU("PTNAME"))) D Q - . . . D ERR^TIUHL7U1("PV1",19,"0000.00","HL7 message PATIENT NAME ["_TIU("PTNAME")_"] does not match VISIT PATIENT NAME ["_$$GET1^DIQ(9000010,TIU("VNUM"),.05)_"].") - . . S TIU("EPDT")=$$GET1^DIQ(9000010,TIU("VNUM"),.01,"I"),TIU("VSTR")=$$VSTRBLD^TIUSRVP(TIU("VNUM")) - . I '+TIU("VNUM") D - . . I +TIU("EPDT") I '+$$GETADMIT^TIUHL7U1(+$G(DFN),TIU("EPDT")),TIU("AVAIL")'="AV" D ERR^TIUHL7U1("PV1","44","0000.00","Could not find a visit for "_$$FMTE^XLFDT(TIU("EPDT"))_".") Q - . . I '+$$GETVISIT^TIUHL7U1(+$G(DFN),TIU("RFDT")),TIU("AVAIL")'="AV" D ERR^TIUHL7U1("PV1","44","0000.00","Could not find a visit for "_$$FMTE^XLFDT(TIU("RFDT"))_".") Q - . . S TIU("VSTR")=TIU("HLOC")_";"_$$NOW^XLFDT_";E" - ; - D CONTINUE^TIUHL7P3 - Q +TIUHL7P2 ; SLC/AJB - TIUHL7 Msg Processing; March 23, 2005 + ;;1.0;TEXT INTEGRATION UTILITIES;**200**;Jun 20, 1997 + Q +CONTINUE ; data verification + ; + ; DOCUMENT TEXT + D + . N TIUI S TIUTMP=0 F S TIUTMP=$O(TIUZ("TEXT",TIUTMP)) Q:'TIUTMP I +$L(TIUZ("TEXT",TIUTMP,0)) S TIUI=1 + . I '+$G(TIUI) D ERR^TIUHL7U1("OBX",1,"0000.00","Missing DOCUMENT TEXT.") + ; + ; DOCUMENT TITLE + I +TIU("TDA")'>0 D ERR^TIUHL7U1("TXA",16,"0000.00","Could not resolve the document title "_TIU("TITLE")_".") + I +$$GET1^DIQ(8925.1,TIU("TDA"),.07,"I")'=11 D ERR^TIUHL7U1("TXA",16,"0000.00","The document title "_TIU("TITLE")_" must be ACTIVE before use.") + ; + ; AUTHOR/DICTATOR + D + . I '+$L(TIU("AUNAME")) D ERR^TIUHL7U1("TXA",9,"0000.00","Missing AUTHOR/DICTATOR name from HL7 message.") Q + . I '+$G(TIU("AUDA")),'+$G(TIU("AUSSN")) S TIU("AUDA")=$$LU^TIUHL7U1(200,TIU("AUNAME"),"X") I '+TIU("AUDA") D ERR^TIUHL7U1("TXA",9,"0000.00","AUTHOR/DICTATOR name lookup failed for ["_TIU("AUNAME")_"].") Q + . I '+$G(TIU("AUDA")),+$G(TIU("AUSSN")) S TIU("AUDA")=+$$FIND1^DIC(200,"","X",+$G(TIU("AUSSN")),"SSN") I '+TIU("AUDA") D ERR^TIUHL7U1("TXA",9,"0000.00","SSN ["_TIU("AUSSN")_"] lookup failed for AUTHOR/DICTATOR.") Q + . I '$$COMPARE^TIUHL7U1($$GET1^DIQ(200,TIU("AUDA"),.01),TIU("AUNAME")) D + . . D ERR^TIUHL7U1("TXA",9,"0000.00","AUTHOR/DICTATOR name discrepancy between HL7 message IEN/SSN ["_$$GET1^DIQ(200,TIU("AUDA"),.01)_"]"_" & the HL7 message name ["_TIU("AUNAME")_"].") + ; + ; EXPECTED CO-SIGNER [ignored if AUTHOR/DICTATOR does not require] + I $$REQCOSIG^TIULP($G(TIU("TDA")),,$G(TIU("AUDA")),$G(TIU("RFDT"))) D + . N TIUTMP + . S TIUZ(1506)=1 + . I +$L($G(TIU("CSNAME")))!(+$G(TIU("CSDA")))!(+$G(TIU("CSSSN"))) D + . . I '+$L($G(TIU("CSNAME"))) D ERR^TIUHL7U1("TXA",10,"0000.00","Missing EXPECTED COSIGNER name from HL7 message.") Q + . . I '+$G(TIU("CSDA")),'+$G(TIU("CSSSN")) S TIU("CSDA")=$$LU^TIUHL7U1(200,TIU("CSNAME"),"X") I '+TIU("CSDA") D ERR^TIUHL7U1("TXA",10,"0000.000","EXPECTED COSIGNER name lookup failed for ["_TIU("CSNAME")_"].") Q + . . I '+$G(TIU("CSDA")),+$G(TIU("CSSSN")) S TIU("CSDA")=+$$FIND1^DIC(200,"","X",+$G(TIU("CSSSN")),"SSN") I '+TIU("CSDA") D ERR^TIUHL7U1("TXA",10,"0000.00","SSN ["_TIU("CSSSN")_"] lookup failed for EXPECTED COSIGNER.") Q + . . I '$$COMPARE^TIUHL7U1($$GET1^DIQ(200,TIU("CSDA"),.01),TIU("CSNAME")) D + . . . D ERR^TIUHL7U1("TXA",10,"0000.00","EXPECTED COSIGNER name discrepancy between HL7 message IEN/SSN ["_$$GET1^DIQ(200,TIU("CSDA"),.01)_"]"_" & HL7 message name ["_TIU("CSNAME")_"].") + . I '+$G(TIU("CSDA")) D ERR^TIUHL7U1("TXA",10,"0000.000","Unable to resolve EXPECTED COSIGNER; the AUTHOR/DICTATOR ["_TIU("AUNAME")_"] requires COSIGNATURE.") + ; + ; ENTERED BY [optional] + I +$L($G(TIU("EBNAME")))!(+$G(TIU("EBDA")))!(+$G(TIU("EBSSN"))) D + . I '+$L($G(TIU("EBNAME"))) D ERR^TIUHL7U1("TXA",11,"0000.00","Missing ENTERED BY name from HL7 message.") Q + . I '+$G(TIU("EBDA")),'+$G(TIU("EBSSN")) S TIU("EBDA")=$$LU^TIUHL7U1(200,TIU("EBNAME"),"X") I '+TIU("EBDA") D ERR^TIUHL7U1("TXA",11,"0000.000","ENTERED BY name lookup failed for ["_TIU("EBNAME")_"].") Q + . I '+$G(TIU("EBDA")),+$G(TIU("EBSSN")) S TIU("EBDA")=+$$FIND1^DIC(200,"","X",+$G(TIU("EBSSN")),"SSN") I '+TIU("EBDA") D ERR^TIUHL7U1("TXA",11,"0000.00","SSN ["_TIU("EBSSN")_"] lookup failed for ENTERED BY.") Q + . I '$$COMPARE^TIUHL7U1($$GET1^DIQ(200,TIU("EBDA"),.01),TIU("EBNAME")) D + . . D ERR^TIUHL7U1("TXA",11,"0000.00","ENTERED BY name discrepancy between HL7 message IEN/SSN ["_$$GET1^DIQ(200,TIU("EBDA"),.01)_"]"_" & HL7 message name ["_TIU("EBNAME")_"].") + ; + ; EPISODE BEGIN DATE/TIME for DISCHARGE SUMMARIES + I $$MEMBEROF^TIUHL7U1(TIU("TITLE"),"DISCHARGE SUMMARIES") D + . I '+$G(TIU("CSDA")) D ERR^TIUHL7U1("TXA",10,"0000.000","DISCHARGE SUMMARIES require an ATTENDING PHYSICIAN (EXPECTED COSIGNER).") + . S TIUZ(1209)=$G(TIU("CSDA")) + . I +TIU("VNUM") D Q + . . I '$$COMPARE^TIUHL7U1($$GET1^DIQ(9000010,TIU("VNUM"),.05),$S(+$G(DFN):$$GET1^DIQ(2,DFN,.01),1:TIU("PTNAME"))) D + . . . D ERR^TIUHL7U1("PV1",19,"0000.00","HL7 message PATIENT NAME ["_TIU("PTNAME")_"] does not match VISIT PATIENT NAME ["_$$GET1^DIQ(9000010,TIU("VNUM"),.05)_"].") Q + . . S TIU("EPDT")=$$GET1^DIQ(9000010,TIU("VNUM"),.01,"I"),TIU("VSTR")=$$VSTRBLD^TIUSRVP(TIU("VNUM")) + . I '+TIU("EPDT") D ERR^TIUHL7U1("PV1",44,"0000.000",TIU("TITLE")_" requires an EPISODE BEGIN DATE/TIME.") Q + . I '+$$GETADMIT^TIUHL7U1(+$G(DFN),TIU("EPDT")) D ERR^TIUHL7U1("PV1","44","0000.00","Could not resolve ADMISSION DT[TIME] for "_$$FMTE^XLFDT(TIUDT)_".") + ; + ; VISIT information for PROGRESS NOTES + I $$MEMBEROF^TIUHL7U1(TIU("TITLE"),"PROGRESS NOTES") D + . I TIU("VNUM")="NEW" D Q + . . N TYP + . . I '+TIU("HLOC"),TIU("AVAIL")'="AV" D ERR^TIUHL7U1("PV1",4,"0000.00","Missing/Invalid HOSPITAL LOCATION ('AV' not set); required for NEW visits.") Q + . . I +TIU("EPDT")'>0 S TIU("EPDT")=$$NOW^XLFDT + . . I $L(TIU("EPDT"),".")=1 S TIU("EPDT")=TIU("EPDT")_"."_$P($$NOW^XLFDT,".",2) + . . I +TIU("HLOC") I $$GET1^DIQ(44,TIU("HLOC"),2,"I")="W" S TYP="I" + . . S TIU("VSTR")=TIU("HLOC")_";"_TIU("EPDT")_";"_$S(+$D(TYP):"I",TIU("AVAIL")="AV":"E",1:"A") + . I +TIU("VNUM") D Q + . . I '$$COMPARE^TIUHL7U1($$GET1^DIQ(9000010,TIU("VNUM"),.05),$S(+$G(DFN):$$GET1^DIQ(2,DFN,.01),1:TIU("PTNAME"))) D Q + . . . D ERR^TIUHL7U1("PV1",19,"0000.00","HL7 message PATIENT NAME ["_TIU("PTNAME")_"] does not match VISIT PATIENT NAME ["_$$GET1^DIQ(9000010,TIU("VNUM"),.05)_"].") + . . S TIU("EPDT")=$$GET1^DIQ(9000010,TIU("VNUM"),.01,"I"),TIU("VSTR")=$$VSTRBLD^TIUSRVP(TIU("VNUM")) + . I '+TIU("VNUM") D + . . I +TIU("EPDT") I '+$$GETADMIT^TIUHL7U1(+$G(DFN),TIU("EPDT")),TIU("AVAIL")'="AV" D ERR^TIUHL7U1("PV1","44","0000.00","Could not find a visit for "_$$FMTE^XLFDT(TIU("EPDT"))_".") Q + . . I '+$$GETVISIT^TIUHL7U1(+$G(DFN),TIU("RFDT")),TIU("AVAIL")'="AV" D ERR^TIUHL7U1("PV1","44","0000.00","Could not find a visit for "_$$FMTE^XLFDT(TIU("RFDT"))_".") Q + . . S TIU("VSTR")=TIU("HLOC")_";"_$$NOW^XLFDT_";E" + ; + D CONTINUE^TIUHL7P3 + Q diff --git a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUHL7U1.m b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUHL7U1.m index 75ae4043..d2a8ef93 100644 --- a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUHL7U1.m +++ b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUHL7U1.m @@ -1,154 +1,137 @@ -TIUHL7U1 ; SLC/AJB - TIUHL7 Utilities; March 23, 2005 - ;;1.0;TEXT INTEGRATION UTILITIES;**200,228**;Jun 20, 1997 - Q -ACK(CODE,ERLOC,TIUDA) ; - N HLA,RESULT,TIUMID,TIUREC,TIUSND - S HLA("HLA",1)="MSA"_HL("FS")_CODE_HL("FS")_HL("MID")_HL("FS")_$G(HL("RAN"))_HL("FS")_$G(HL("SAN")) - S TIUMID=$G(HL("MID")),TIUREC=HL("RAN"),TIUSND=HL("SAN") - I CODE="AR" D - . N TIUCNT - . S TIUCNT=0 F S TIUCNT=$O(@ERLOC@("MSGERR",TIUCNT)) Q:'+TIUCNT S HLA("HLA",(TIUCNT+1))=@ERLOC@("MSGERR",TIUCNT) - . I +$E($G(TIU("SSN")),1,5) D SNDALRT("TIUHL7 rejected an incoming HL7 message from "_TIUSND_" (Msg ID "_TIUMID_".") - I CODE="AA" D - . S HLA("HLA",2)="ERR"_TIUFS_TIUFS_TIUFS_TIUFS_+$G(TIUDA)_TIUCS_"Document creation successful." - I HL("SAN")="HTAPPL" D M @TIU("XTMP")@("MSGRESULT")=HLA("HLS") Q - . N HL,HLL,HLP,TIUDNS,TIUEVT,TIUFAC,TIULLNK,TIUSUB - . M HLA("HLS")=HLA("HLA") K HLA("HLA") - . S TIUEVT="TIUHL7 HTAPPL ACK EVT",TIUSUB="TIUHL7 HTAPPL ACK SUB" - . I '+$$LU^TIUHL7U1(101,TIUEVT) D SNDALRT("Unable to resolve Event Protocol for ACK to "_TIUSND_".") - . I '+$$LU^TIUHL7U1(101,TIUSUB) D SNDALRT("Unable to resolve Subscriber Protocol for ACK to "_TIUSND_".") - . S TIUFAC=$P(TIUMSG(1),TIUFS,4),TIUDNS=$P(TIUFAC,TIUCS,2) ; set facility & DNS address - . S TIULLNK(1)=$$LU^TIUHL7U1(870,$$UP^XLFSTR(TIUDNS),,,"DNS"),TIULLNK(2)=$$LU^TIUHL7U1(870,$$LOW^XLFSTR(TIUDNS),,,"DNS") - . S TIULLNK=$S(+TIULLNK(1):TIULLNK(1),+TIULLNK(2):TIULLNK(2),1:0) I '+TIULLNK D SNDALRT("Unable to resolve DNS for ACK to "_TIUSND_".") - . S TIULLNK=$$GET1^DIQ(870,TIULLNK,.01) ; get logical link associated with DNS - . D INIT^HLFNC2(TIUEVT,.HL) I +$G(HL) Q - . S HLP("SUBSCRIBER")="^^^^"_TIUFAC - . S HLL("LINKS",1)=TIUSUB_U_TIULLNK - . D GENERATE^HLMA(TIUEVT,"LM",1,.TIURSLT,"",.HLP) - D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.TIURSLT) - M @TIU("XTMP")@("MSGRESULT")=HLA("HLA") - Q -SNDALRT(MSG) ; - N XQA,XQAMSG - S MSG("RECEIVER")=$P($$GETAPP^HLCS2(TIUREC),U),MSG("SENDER")=$P($$GETAPP^HLCS2(TIUSND),U) - I '+$L(MSG("RECEIVER")),'+$L(MSG("SENDER")) Q - I +$L(MSG("RECEIVER")) S XQA("G."_MSG("RECEIVER"))="" - I +$L(MSG("SENDER")) S XQA("G."_MSG("SENDER"))="" - S XQAMSG=MSG - I $$SETUP1^XQALERT - Q -AUDIT(TIUDA,TIUCKSM0,TIUCKSM1) ; Update audit trail - N DA,DIC,DIE,DLAYGO,DR,X,Y - S X=""""_"`"_TIUDA_"""",(DIC,DLAYGO)=8925.5,DIC(0)="FLX" D ^DIC Q:+Y'>0 - S DIE=DIC,DR=".02////"_$$NOW^TIULC_";.03////"_TIU("EBDA")_";.04////"_TIUCKSM0_";.05////"_TIUCKSM1 - S DA=+Y D ^DIE - Q -CANEDIT(DA) ; check whether or not document is released - Q $S(+$P($G(^TIU(8925,+DA,0)),U,5)<4:1,1:0) -CLASS(CLNAME) ; - N TIUY S TIUY=+$O(^TIU(8925.1,"B",CLNAME,0)) - I +TIUY>0,$S($P($G(^TIU(8925.1,+TIUY,0)),U,4)="CL":0,$P($G(^(0)),U,4)="DC":0,1:1) S TIUY=0 - Q TIUY -CLEAN ; removes messages older than 7 days - N TIUDT - S TIUDT=0 - F S TIUDT=$O(^XTMP("TIUHL7",TIUDT)) Q:'+TIUDT D - . I $$FMDIFF^XLFDT($$NOW^XLFDT,TIUDT)'<7 K ^XTMP("TIUHL7",TIUDT) - Q -COMPARE(NAME1,NAME2) ; compare first and last names only - N NAME,TIUX,TIUY - S TIUY=0 - I $L(NAME1,",")=1,$L(NAME2,",")=1 S:NAME1=NAME2 TIUY=1 Q TIUY - S NAME("L1")=$P(NAME1,","),NAME("F1")=$P(NAME1,",",2),NAME("F1")=$P(NAME("F1")," ") - S NAME("L2")=$P(NAME2,","),NAME("F2")=$P(NAME2,",",2),NAME("F2")=$P(NAME("F2")," ") - I NAME("L1")=NAME("L2"),NAME("F1")=NAME("F2") S TIUY=1 - Q TIUY -DELDOC(TIUDA) ; - N ERR - D DELETE^TIUSRVP(.ERR,TIUDA,"",1) - Q -ERR(TIUSEG,TIUP,TIUNUM,TIUTXT) ; - S TIU("EC")=TIU("EC")+1 - S @TIUNAME@("MSGERR",TIU("EC"))="ERR"_TIUFS_TIUSEG_TIUFS_TIUP_TIUFS_TIUFS_TIUNUM_TIUCS_TIUTXT - Q -GETADMIT(DFN,TIUDT) ; - N TIUCNT,TIULIST,TIUY S (TIUCNT,TIUY)=0 - I '+$G(TIUDT) Q TIUY - D:+$G(DFN) ADMITLST^ORWPT(.TIULIST,DFN) - I $D(TIULIST) D - . S TIULIST="" F S TIULIST=$O(TIULIST(TIULIST)) Q:'+TIULIST I $P($P(TIULIST(TIULIST),U),".")=$P(TIUDT,".") S TIUCNT=TIUCNT+1,TIUCNT(TIULIST)=TIULIST(TIULIST) - . I TIUCNT=0 D ERR("ERR","44","0000.00","ADMISSION not found for "_$$FMTE^XLFDT(TIUDT)_".") Q - . I TIUCNT=1 S TIULIST="",TIULIST=$O(TIUCNT(TIULIST)),TIU("VSTR")=$P(TIULIST(TIULIST),U,2)_";"_$P(TIULIST(TIULIST),U)_";H",TIUY=1 Q - . I +TIU("HLOC") D - . . S TIULIST="" F S TIULIST=$O(TIUCNT(TIULIST)) Q:'+TIULIST!(+TIUY) I $P(TIUCNT(TIULIST),U,2)=TIU("HLOC") S TIU("VSTR")=TIU("HLOC")_";"_$P(TIUCNT(TIULIST),U)_";H",TIUY=1 - Q TIUY -GETDIV(USER) ; - N TIUY - D DIV4^XUSER(.TIUY,USER) I +$D(TIUY) S TIUY="",TIUY=$O(TIUY(TIUY)) - I +$G(TIUY)'>0 S TIUY=$$GET1^DIQ(8989.3,1,217,"I") - Q TIUY -GETVISIT(DFN,TIUDT) ; - N TIUCNT,TIULIST,TIUY - S (TIUCNT,TIUY)=0 - I '+$G(TIUDT) Q TIUY - D:+$G(DFN) VST1^ORWCV(.TIULIST,DFN,$P(TIUDT,"."),$$FMADD^XLFDT(TIUDT,1),1) - I $D(TIULIST) D - . S TIULIST="" F S TIULIST=$O(TIULIST(TIULIST)) Q:'+TIULIST I $P($P(TIULIST(TIULIST),U,2),".")=$P(TIUDT,".") S TIUCNT=TIUCNT+1,TIUCNT(TIULIST)=TIULIST(TIULIST) - . I TIUCNT=1 S TIULIST="",TIULIST=$O(TIUCNT(TIULIST)),TIU("VSTR")=$P($P(TIULIST(TIULIST),U),";",3)_";"_$P(TIULIST(TIULIST),U,2)_";"_$S(TIU("AVAIL")="AV":"E",1:"A"),TIUY=1 Q - . I +TIU("HLOC") D - . . S TIULIST="" F S TIULIST=$O(TIUCNT(TIULIST)) Q:'+TIULIST!(+TIUY) I $P($P(TIULIST(TIULIST),U),";",3)=TIU("HLOC") S TIU("VSTR")=TIU("HLOC")_";"_$P(TIULIST(TIULIST),U,2)_";"_$S(TIU("AVAIL")="AV":"E",1:"A"),TIUY=1 - Q TIUY -LU(FILE,NAME,FLAGS,SCREEN,INDEXES) ; - Q $$FIND1^DIC(FILE,"",$G(FLAGS),NAME,$G(INDEXES),$G(SCREEN),"TIUERR") -MEMBEROF(TITLE,CLASS) ; - N TIUY S TIUY=0 - S CLASS=+$$CLASS(CLASS) Q:+CLASS'>0 TIUY - S TITLE=$$LU(8925.1,TITLE,"X","I $P(^(0),U,4)=""DOC""") Q:+TITLE'>0 TIUY - S TIUY=+$$ISA^TIULX(TITLE,CLASS) - Q TIUY -PNAME(NAME) ; - N LAST,FIRST - S LAST=$P(NAME,","),FIRST=$E($P(NAME,",",2),1) - Q LAST_","_FIRST -REMESC(TIUSTR) ; - ; Remove Escape Characters from HL7 Message Text - ; Escape Sequence codes: - ; F = field separator (TIUFS) - ; S = component separator (TIUCS) - ; R = repitition separator (TIURS) - ; E = escape character (TIUES) - ; T = subcomponent separator (TIUSS) - N I1,I2,J1,J2,K,TIUCHR,TIUREP,VALUE - F TIUCHR="F","S","R","E","T" S TIUREP(TIUES_TIUCHR_TIUES)=$S(TIUCHR="F":TIUFS,TIUCHR="S":TIUCS,TIUCHR="R":TIURS,TIUCHR="E":TIUES,TIUCHR="T":TIUSS) - S TIUSTR=$$REPLACE^XLFSTR(TIUSTR,.TIUREP) - F S I1=$P(TIUSTR,TIUES_"X") Q:$L(I1)=$L(TIUSTR) D - .S I2=$P(TIUSTR,TIUES_"X",2,99) - .S J1=$P(I2,TIUES) Q:'$L(J1) - .S J2=$P(I2,TIUES,2,99) - .S VALUE=$$BASE^XLFUTL($$UP^XLFSTR(J1),16,10) - .S K=$S(VALUE>255:"?",VALUE<32!(VALUE>127&(VALUE<160)):"",1:$C(VALUE)) - .S TIUSTR=I1_K_J2 - Q TIUSTR -SIGNDOC(TIUDA) ; - N TIUDEL - I $G(TIU("COMP"))="LA",'+TIU("EC") D - . I '+$G(TIU("SIGNED")),'+$G(TIU("CSIGNED")) D Q - . . I TIU("AVAIL")'="AV" D DELDOC(TIUDA),ERR("TIU","","2100.040","SIGNATURE DATE[TIME] missing from HL7 message & availability not 'AV'; document has been deleted.") - . I +TIU("SIGNED") D - . . N TIUACT,TIUAUTH,TIUES,TIUSTAT S TIUACT="SIGNATURE",TIUAUTH=$$CANDO^TIULP(TIUDA,TIUACT,TIU("AUDA")) I '+TIUAUTH D - . . . D ERR("TIU","15","0000.000",$P(TIUAUTH,U,2)) I TIU("AVAIL")="AV" Q - . . . S TIUDEL=1 D ERR("TIU","","0000.000","Legal authentication failed & availability not 'AV'; document has been deleted.") - . . I '+$G(TIUDEL) S TIUES=1_U_$$GET1^DIQ(200,TIU("AUDA"),20.2)_U_$$GET1^DIQ(200,TIU("AUDA"),20.3) - . . I '+$G(TIUDEL) D ES^TIUHL7U2(TIUDA,TIUES,"",TIU("AUDA")) - . . I '+$G(TIUDEL) S TIUSTAT=$P($G(^TIU(8925,TIUDA,0)),U,5) I TIUSTAT<6,TIU("AVAIL")'="AV" D - . . . S TIUDEL=1 D ERR("TIU","","0000.000","Legal authentication failed & availability not 'AV'; document has been deleted.") - . I +TIU("CSIGNED") D - . . N TIUACT,TIUAUTH,TIUES,TIUSTAT S TIUACT="COSIGNATURE",TIUAUTH=$$CANDO^TIULP(TIUDA,TIUACT,TIU("CSDA")) I '+TIUAUTH D - . . . D ERR("TIU","29","0000.000",$P(TIUAUTH,U,2)) I TIU("AVAIL")="AV" Q - . . . S TIUDEL=1 D ERR("TIU","29","0000.000","Legal authentication failed & availability not 'AV'; document has been deleted.") - . . I '+$G(TIUDEL) S TIUES=1_U_$$GET1^DIQ(200,TIU("CSDA"),20.2)_U_$$GET1^DIQ(200,TIU("CSDA"),20.3) - . . I '+$G(TIUDEL) D ES^TIURS(TIUDA,TIUES,"",TIU("CSDA")) - . . I '+$G(TIUDEL) S TIUSTAT=$P($G(^TIU(8925,TIUDA,0)),U,5) I TIUSTAT'=7,TIU("AVAIL")'="AV" D - . . . S TIUDEL=1 D ERR("TIU","29","0000.000","Legal authentication failed & availability not 'AV'; document has been deleted.") - I +$G(TIUDEL) D DELDOC(TIUDA) - Q +TIUHL7U1 ; SLC/AJB - TIUHL7 Utilities; March 23, 2005 + ;;1.0;TEXT INTEGRATION UTILITIES;**200**;Jun 20, 1997 + Q +ACK(CODE,ERLOC,TIUDA) ; + N HLA,RESULT + S HLA("HLA",1)="MSA"_HL("FS")_CODE_HL("FS")_HL("MID")_HL("FS")_$G(HL("RAN"))_HL("FS")_$G(HL("SAN")) + I CODE="AR" D + . N TIUCNT + . S TIUCNT=0 F S TIUCNT=$O(@ERLOC@("MSGERR",TIUCNT)) Q:'+TIUCNT S HLA("HLA",(TIUCNT+1))=@ERLOC@("MSGERR",TIUCNT) + . D SNDALRT + I CODE="AA" D + . S HLA("HLA",2)=+$G(TIUDA)_TIUCS_"Document creation successful." + D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.RESULT) + M @TIU("XTMP")@("MSGRESULT")=HLA("HLA") + Q +AUDIT(TIUDA,TIUCKSM0,TIUCKSM1) ; Update audit trail + N DIC,DIE,DA,DR,X,Y + S X=""""_"`"_TIUDA_"""",(DIC,DLAYGO)=8925.5,DIC(0)="FLX" D ^DIC Q:+Y'>0 + S DIE=DIC,DR=".02////"_$$NOW^TIULC_";.03////"_TIU("EBDA")_";.04////"_TIUCKSM0_";.05////"_TIUCKSM1 + S DA=+Y D ^DIE + Q +CANEDIT(DA) ; check whether or not document is released + Q $S(+$P($G(^TIU(8925,+DA,0)),U,5)<4:1,1:0) +CLASS(CLNAME) ; + N TIUY S TIUY=+$O(^TIU(8925.1,"B",CLNAME,0)) + I +TIUY>0,$S($P($G(^TIU(8925.1,+TIUY,0)),U,4)="CL":0,$P($G(^(0)),U,4)="DC":0,1:1) S TIUY=0 + Q TIUY +CLEAN ; removes messages older than 7 days + N TIUDT + S TIUDT=0 + F S TIUDT=$O(^XTMP("TIUHL7",TIUDT)) Q:'+TIUDT D + . I $$FMDIFF^XLFDT($$NOW^XLFDT,TIUDT)'<7 K ^XTMP("TIUHL7",TIUDT) + Q +COMPARE(NAME1,NAME2) ; compare first and last names only + N NAME,TIUX,TIUY + S TIUY=0 + I $L(NAME1,",")=1,$L(NAME2,",")=1 S:NAME1=NAME2 TIUY=1 Q TIUY + S NAME("L1")=$P(NAME1,","),NAME("F1")=$P(NAME1,",",2),NAME("F1")=$P(NAME("F1")," ") + S NAME("L2")=$P(NAME2,","),NAME("F2")=$P(NAME2,",",2),NAME("F2")=$P(NAME("F2")," ") + I NAME("L1")=NAME("L2"),NAME("F1")=NAME("F2") S TIUY=1 + Q TIUY +DELDOC(TIUDA) ; + N ERR + D DELETE^TIUSRVP(.ERR,TIUDA,"",1) + Q +ERR(TIUSEG,TIUP,TIUNUM,TIUTXT) ; + S TIU("EC")=TIU("EC")+1 + S @TIUNAME@("MSGERR",TIU("EC"))="ERR"_TIUFS_TIUSEG_TIUFS_TIUP_TIUFS_TIUFS_TIUNUM_TIUCS_TIUTXT + Q +GETADMIT(DFN,TIUDT) ; + N TIUCNT,TIULIST,TIUY S (TIUCNT,TIUY)=0 + I '+$G(TIUDT) Q TIUY + D:+$G(DFN) ADMITLST^ORWPT(.TIULIST,DFN) + I $D(TIULIST) D + . S TIULIST="" F S TIULIST=$O(TIULIST(TIULIST)) Q:'+TIULIST I $P($P(TIULIST(TIULIST),U),".")=$P(TIUDT,".") S TIUCNT=TIUCNT+1,TIUCNT(TIULIST)=TIULIST(TIULIST) + . I TIUCNT=0 D ERR("ERR","44","0000.00","ADMISSION not found for "_$$FMTE^XLFDT(TIUDT)_".") Q + . I TIUCNT=1 S TIULIST="",TIULIST=$O(TIUCNT(TIULIST)),TIU("VSTR")=$P(TIULIST(TIULIST),U,2)_";"_$P(TIULIST(TIULIST),U)_";H",TIUY=1 Q + . I +TIU("HLOC") D + . . S TIULIST="" F S TIULIST=$O(TIUCNT(TIULIST)) Q:'+TIULIST!(+TIUY) I $P(TIUCNT(TIULIST),U,2)=TIU("HLOC") S TIU("VSTR")=TIU("HLOC")_";"_$P(TIUCNT(TIULIST),U)_";H",TIUY=1 + Q TIUY +GETDIV(USER) ; + N TIUY + D DIV4^XUSER(.TIUY,USER) I +$D(TIUY) S TIUY="",TIUY=$O(TIUY(TIUY)) + I +$G(TIUY)'>0 S TIUY=$$GET1^DIQ(8989.3,1,217,"I") + Q TIUY +GETVISIT(DFN,TIUDT) ; + N TIUCNT,TIULIST,TIUY + S (TIUCNT,TIUY)=0 + I '+$G(TIUDT) Q TIUY + D:+$G(DFN) VST1^ORWCV(.TIULIST,DFN,$P(TIUDT,"."),$$FMADD^XLFDT(TIUDT,1),1) + I $D(TIULIST) D + . S TIULIST="" F S TIULIST=$O(TIULIST(TIULIST)) Q:'+TIULIST I $P($P(TIULIST(TIULIST),U,2),".")=$P(TIUDT,".") S TIUCNT=TIUCNT+1,TIUCNT(TIULIST)=TIULIST(TIULIST) + . I TIUCNT=1 S TIULIST="",TIULIST=$O(TIUCNT(TIULIST)),TIU("VSTR")=$P($P(TIULIST(TIULIST),U),";",3)_";"_$P(TIULIST(TIULIST),U,2)_";"_$S(TIU("AVAIL")="AV":"E",1:"A"),TIUY=1 Q + . I +TIU("HLOC") D + . . S TIULIST="" F S TIULIST=$O(TIUCNT(TIULIST)) Q:'+TIULIST!(+TIUY) I $P($P(TIULIST(TIULIST),U),";",3)=TIU("HLOC") S TIU("VSTR")=TIU("HLOC")_";"_$P(TIULIST(TIULIST),U,2)_";"_$S(TIU("AVAIL")="AV":"E",1:"A"),TIUY=1 + Q TIUY +LU(FILE,NAME,FLAGS,SCREEN,INDEXES) ; + Q $$FIND1^DIC(FILE,"",$G(FLAGS),NAME,$G(INDEXES),$G(SCREEN),"TIUERR") +MEMBEROF(TITLE,CLASS) ; + N TIUY S TIUY=0 + S CLASS=+$$CLASS(CLASS) Q:+CLASS'>0 TIUY + S TITLE=$$LU(8925.1,TITLE,"X","I $P(^(0),U,4)=""DOC""") Q:+TITLE'>0 TIUY + S TIUY=+$$ISA^TIULX(TITLE,CLASS) + Q TIUY +PNAME(NAME) ; + N LAST,FIRST + S LAST=$P(NAME,","),FIRST=$E($P(NAME,",",2),1) + Q LAST_","_FIRST +REMESC(TIUSTR) ; + ; Remove Escape Characters from HL7 Message Text + ; Escape Sequence codes: + ; F = field separator (TIUFS) + ; S = component separator (TIUCS) + ; R = repitition separator (TIURS) + ; E = escape character (TIUES) + ; T = subcomponent separator (TIUSS) + N I1,I2,J1,J2,K,TIUCHR,TIUREP,VALUE + F TIUCHR="F","S","R","E","T" S TIUREP(TIUES_TIUCHR_TIUES)=$S(TIUCHR="F":TIUFS,TIUCHR="S":TIUCS,TIUCHR="R":TIURS,TIUCHR="E":TIUES,TIUCHR="T":TIUSS) + S TIUSTR=$$REPLACE^XLFSTR(TIUSTR,.TIUREP) + F S I1=$P(TIUSTR,TIUES_"X") Q:$L(I1)=$L(TIUSTR) D + .S I2=$P(TIUSTR,TIUES_"X",2,99) + .S J1=$P(I2,TIUES) Q:'$L(J1) + .S J2=$P(I2,TIUES,2,99) + .S VALUE=$$BASE^XLFUTL($$UP^XLFSTR(J1),16,10) + .S K=$S(VALUE>255:"?",VALUE<32!(VALUE>127&(VALUE<160)):"",1:$C(VALUE)) + .S TIUSTR=I1_K_J2 + Q TIUSTR +SIGNDOC(TIUDA) ; + N TIUDEL + I $G(TIU("COMP"))="LA",'+TIU("EC") D + . I '+$G(TIU("SIGNED")),'+$G(TIU("CSIGNED")) D Q + . . I TIU("AVAIL")'="AV" D DELDOC(TIUDA),ERR("TIU","","2100.040","SIGNATURE DATE[TIME] missing from HL7 message & availability not 'AV'; document has been deleted.") + . I +TIU("SIGNED") D + . . N TIUACT,TIUAUTH,TIUES,TIUSTAT S TIUACT="SIGNATURE",TIUAUTH=$$CANDO^TIULP(TIUDA,TIUACT,TIU("AUDA")) I '+TIUAUTH D + . . . D ERR("TIU","15","0000.000",$P(TIUAUTH,U,2)) I TIU("AVAIL")="AV" Q + . . . S TIUDEL=1 D ERR("TIU","","0000.000","Legal authentication failed & availability not 'AV'; document has been deleted.") + . . I '+$G(TIUDEL) S TIUES=1_U_$$GET1^DIQ(200,TIU("AUDA"),20.2)_U_$$GET1^DIQ(200,TIU("AUDA"),20.3) + . . I '+$G(TIUDEL) D ES^TIUHL7U2(TIUDA,TIUES,"",TIU("AUDA")) + . . I '+$G(TIUDEL) S TIUSTAT=$P($G(^TIU(8925,TIUDA,0)),U,5) I TIUSTAT<6,TIU("AVAIL")'="AV" D + . . . S TIUDEL=1 D ERR("TIU","","0000.000","Legal authentication failed & availability not 'AV'; document has been deleted.") + . I +TIU("CSIGNED") D + . . N TIUACT,TIUAUTH,TIUES,TIUSTAT S TIUACT="COSIGNATURE",TIUAUTH=$$CANDO^TIULP(TIUDA,TIUACT,TIU("CSDA")) I '+TIUAUTH D + . . . D ERR("TIU","29","0000.000",$P(TIUAUTH,U,2)) I TIU("AVAIL")="AV" Q + . . . S TIUDEL=1 D ERR("TIU","29","0000.000","Legal authentication failed & availability not 'AV'; document has been deleted.") + . . I '+$G(TIUDEL) S TIUES=1_U_$$GET1^DIQ(200,TIU("CSDA"),20.2)_U_$$GET1^DIQ(200,TIU("CSDA"),20.3) + . . I '+$G(TIUDEL) D ES^TIURS(TIUDA,TIUES,"",TIU("CSDA")) + . . I '+$G(TIUDEL) S TIUSTAT=$P($G(^TIU(8925,TIUDA,0)),U,5) I TIUSTAT'=7,TIU("AVAIL")'="AV" D + . . . S TIUDEL=1 D ERR("TIU","29","0000.000","Legal authentication failed & availability not 'AV'; document has been deleted.") + I +$G(TIUDEL) D DELDOC(TIUDA) + Q +SNDALRT ; + N TIUCNT,XQA,XQAMSG + I '+$G(TIUDPRM(4)) Q + F TIUCNT=1:1:$L(TIUDPRM(4),U) S:+$P(TIUDPRM(4),U,TIUCNT) XQA($P(TIUDPRM(4),U,TIUCNT))="" + S XQAMSG="TIUHL7 has encountered an error during message ["_HL("MID")_"] processing." + D SETUP^XQALERT + Q diff --git a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIULA3.m b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIULA3.m index 620f244b..cecf3b05 100644 --- a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIULA3.m +++ b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIULA3.m @@ -1,107 +1,84 @@ -TIULA3 ; SLC/JER - Still more interactive functions ;1/31/08 - ;;1.0;TEXT INTEGRATION UTILITIES;**50,79,98,219**;Jun 20, 1997;Build 11 -TITLE ; Title Look-up - N TIUI,TYPE,TIUCLASS S TIUI=0 - S TIUTYP=$NA(^TMP("TIUTYP",$J)) - K @TIUTYP - I +$G(TIUPICT)'>0 Q - I $P($G(TIUPICT(1)),U,4)="ALL" D - . S TIUCLASS=+$O(^TIU(8925.1,"AD",+$P(TIUPICT(1),U,2),0)) - . K TIUPICT - . S TIUPICT=1,TIUPICT(1)="1^"_TIUCLASS_U_$$PNAME^TIULC1(TIUCLASS) - F S TIUI=$O(TIUPICT(TIUI)) Q:+TIUI'>0 D - . S TIUCLASS=$P(TIUPICT(TIUI),U,2) - . W !!,"For ",$$UP^XLFSTR($$PNAME^TIULC1(TIUCLASS)),": " - . D TITLPICK(.TYPE,TIUCLASS) - M @TIUTYP=TYPE - S Y="ANY" - Q -TITLPICK(TIUTYP,CLASS) ; Select multiple titles - N TIUI,TYPE,TIUPRMT S TIUI=0 - W !!,"Please Select the ",$$UP^XLFSTR($$PNAME^TIULC1(CLASS)) - W " TITLES to search for:",! - F D Q:+$G(TYPE)'>0 - . K TYPE - . S TIUI=TIUI+1,TIUPRMT=$J(TIUI,3)_") " - . D DOCSPICK^TIULA2(.TYPE,CLASS,"A",0,TIUPRMT) - . I +TYPE>0 S TIUTYP=+$G(TIUTYP)+1,TIUTYP(TIUTYP)=$G(TYPE(1)) - . I I $P(TYPE(1),U,4)="SINGLE ITEM" D - . . W !,"There is only one TITLE under ",$$UP^XLFSTR($$PNAME^TIULC1(CLASS)) - . . S TYPE=0 - . I $S($D(DTOUT):1,$D(DUOUT):1,(+TYPE'>0&'$D(TIUTYP)):1,1:0) S TIUQUIT=1 - W ! - Q -ASKTITLE(CLASS,TIUTTL) ; Ask for a different title, same class - N TIUY,TIUTYP,DFLT,SCREEN,X,Y - S DFLT=$$RSLVTITL(TIUTTL) - S SCREEN="I $P(^TIU(8925.1,+Y,0),U,4)=""DOC"",($P(^(0),U)'[""ADDENDUM""),+$$ISA^TIULX(+Y,CLASS),+$$CANPICK^TIULP(+Y),+$$CANENTR^TIULP(+Y)" - S TIUY=+$$ASKTYP^TIULA2(+CLASS,DFLT,SCREEN,"TITLE: ") - I +$G(TIUY)'>0 S TIUY=TIUTTL - Q TIUY -RSLVTITL(TIUTTL) ; Resolve pointers to titles - Q $P($G(^TIU(8925.1,+TIUTTL,0)),U) -ASKSEQ(TIUDFLT) ; Ask preferred sort sequence - N TIUPRMT,TIUSET,TIUY S TIUDFLT=$G(TIUDFLT,"D") - S TIUPRMT="Please Specify Sort Order: " - S TIUSET="A:ascending (OLDEST FIRST);D:descending (NEWEST FIRST)" - S TIUY=$$READ^TIUU("SA^"_TIUSET,TIUPRMT,$S(TIUDFLT="A":"ascending",1:"descending")) - Q TIUY -DATENOTE(X) ; Ask for date/time of note - N %DT,Y - ;S TIUPRMT="DATE/TIME OF NOTE" - ;S TIUY=$$READ^TIUU("D^:NOW:RS",TIUPRMT,$G(DFLT,"NOW"),TIUHLP) - ;I +TIUY W " ",$P(TIUY,U,2) - S %DT="RSX",%DT(0)="-NOW" D ^%DT - I +Y'>0 D - . W !,$C(7),"Enter DATE AND TIME of the note [TIME REQUIRED] (future dates prohibited)." - Q +$G(Y) -SCRCSNR(TIUDA,Y) ; Evaluate whether a person may be selected to cosign - N TIUI,TIUY,TIUD0,TIUD12 S TIUY=1 ; most people may be selected - S TIUD0=$G(^TIU(8925,+TIUDA,0)),TIUD12=$G(^TIU(8925,+TIUDA,12)) - ; If he requires cosignature for this document a user may NOT select - ; himself - I +$$REQCOSIG^TIULP(+TIUD0,+TIUDA,+$G(DUZ)),(Y=+$G(DUZ)) S TIUY=0 G SCREENX - ; A TERMINATED User may NOT be selected - I +$$ACTIVE^XUSER(+Y)'>0 S TIUY=0 G SCREENX - ; A non-PROVIDER may NOT be selected - I +$$PROVIDER^TIUPXAP1(+Y,DT)'>0 S TIUY=0 G SCREENX - ; Author may NOT be selected - I Y=+$P(TIUD12,U,2) S TIUY=0 G SCREENX - ; Expected Signer may NOT be selected - I Y=+$P(TIUD12,U,4) S TIUY=0 G SCREENX - ; Others who require Cosignature may NOT be selected - I +$$REQCOSIG^TIULP(+TIUD0,+TIUDA,+Y) S TIUY=0 -SCREENX Q +$G(TIUY) - ; -SCRATT(TIUDA,PERSON) ; Can a person be an Attending for a given docmt? - N TIUD0,TIUTYP,CANSEL,DICTDT,TIUISDS,TIUPRNT,TIUPTYP,TIUPD0,TIUISAD - S PERSON=+PERSON,TIUDA=+TIUDA,CANSEL=1 - S TIUD0=$G(^TIU(8925,TIUDA,0)),TIUPRNT=+$P(TIUD0,U,6) - S DICTDT=+$P($G(^TIU(8925,+TIUDA,13)),U,7) - I DICTDT>0 S DICTDT=$P(DICTDT,".") - ; Is Docmt an Addendum, a DS? - S TIUTYP=+TIUD0,(TIUPTYP,TIUISAD)=0 - I TIUPRNT>0 S TIUPTYP=+$G(^TIU(8925,TIUPRNT,0)) - I TIUPTYP>0,$P($G(^TIU(8925.1,TIUTYP,0)),U)["ADDENDUM" S TIUISAD=1 - S TIUISDS=+$S('TIUISAD:$$ISDS^TIULX(TIUTYP),1:$$ISDS^TIULX(TIUPTYP)) - ; A TERMINATED (as of NOW) User may NOT be selected: - I $$ISTERM^USRLM(PERSON) S CANSEL=0 G SCRATTX - ; If not DS, is person an active provider? - I 'TIUISDS S:'$$PROVIDER^TIUPXAP1(PERSON,DT) CANSEL=0 G SCRATTX - ; TIUDA is a DS: - ; Attendings must be in USR Class PROVIDER NOW: - I '$$ISA^USRLM(+PERSON,"PROVIDER") S CANSEL=0 G SCRATTX - ; Persons who require Cosignature on Dictation Dt may NOT be selected: - I +$$REQCOSIG^TIULP(TIUTYP,+TIUDA,PERSON,DICTDT) S CANSEL=0 -SCRATTX Q +$G(CANSEL) - ; -SCRDFCS(USER,Y) ; Screen Default Cosigner selection for USER - N TIUY S TIUY=1 - S USER=$G(USER,DUZ) - ; A user may NOT select himself - I Y=USER S TIUY=0 G SCRDFX - ; A TERMINATED User may NOT be selected - I +$$ACTIVE^XUSER(+Y)'>0 S TIUY=0 G SCREENX - ; A non-PROVIDER may NOT be selected - I +$$PROVIDER^TIUPXAP1(+Y,DT)'>0 S TIUY=0 G SCREENX -SCRDFX Q TIUY +TIULA3 ; SLC/JER - Still more interactive functions ;24-FEB-2000 12:22:04 + ;;1.0;TEXT INTEGRATION UTILITIES;**50,79,98**;Jun 20, 1997 +TITLE ; Title Look-up + N TIUI,TYPE,TIUCLASS S TIUI=0 + S TIUTYP=$NA(^TMP("TIUTYP",$J)) + K @TIUTYP + I +$G(TIUPICT)'>0 Q + I $P($G(TIUPICT(1)),U,4)="ALL" D + . S TIUCLASS=+$O(^TIU(8925.1,"AD",+$P(TIUPICT(1),U,2),0)) + . K TIUPICT + . S TIUPICT=1,TIUPICT(1)="1^"_TIUCLASS_U_$$PNAME^TIULC1(TIUCLASS) + F S TIUI=$O(TIUPICT(TIUI)) Q:+TIUI'>0 D + . S TIUCLASS=$P(TIUPICT(TIUI),U,2) + . W !!,"For ",$$UP^XLFSTR($$PNAME^TIULC1(TIUCLASS)),": " + . D TITLPICK(.TYPE,TIUCLASS) + M @TIUTYP=TYPE + S Y="ANY" + Q +TITLPICK(TIUTYP,CLASS) ; Select multiple titles + N TIUI,TYPE,TIUPRMT S TIUI=0 + W !!,"Please Select the ",$$UP^XLFSTR($$PNAME^TIULC1(CLASS)) + W " TITLES to search for:",! + F D Q:+$G(TYPE)'>0 + . K TYPE + . S TIUI=TIUI+1,TIUPRMT=$J(TIUI,3)_") " + . D DOCSPICK^TIULA2(.TYPE,CLASS,"A",0,TIUPRMT) + . I +TYPE>0 S TIUTYP=+$G(TIUTYP)+1,TIUTYP(TIUTYP)=$G(TYPE(1)) + . I I $P(TYPE(1),U,4)="SINGLE ITEM" D + . . W !,"There is only one TITLE under ",$$UP^XLFSTR($$PNAME^TIULC1(CLASS)) + . . S TYPE=0 + . I $S($D(DTOUT):1,$D(DUOUT):1,(+TYPE'>0&'$D(TIUTYP)):1,1:0) S TIUQUIT=1 + W ! + Q +ASKTITLE(CLASS,TIUTTL) ; Ask for a different title, same class + N TIUY,TIUTYP,DFLT,SCREEN,X,Y + S DFLT=$$RSLVTITL(TIUTTL) + S SCREEN="I $P(^TIU(8925.1,+Y,0),U,4)=""DOC"",($P(^(0),U)'[""ADDENDUM""),+$$ISA^TIULX(+Y,CLASS),+$$CANPICK^TIULP(+Y),+$$CANENTR^TIULP(+Y)" + S TIUY=+$$ASKTYP^TIULA2(+CLASS,DFLT,SCREEN,"TITLE: ") + I +$G(TIUY)'>0 S TIUY=TIUTTL + Q TIUY +RSLVTITL(TIUTTL) ; Resolve pointers to titles + Q $P($G(^TIU(8925.1,+TIUTTL,0)),U) +ASKSEQ(TIUDFLT) ; Ask preferred sort sequence + N TIUPRMT,TIUSET,TIUY S TIUDFLT=$G(TIUDFLT,"D") + S TIUPRMT="Please Specify Sort Order: " + S TIUSET="A:ascending (OLDEST FIRST);D:descending (NEWEST FIRST)" + S TIUY=$$READ^TIUU("SA^"_TIUSET,TIUPRMT,$S(TIUDFLT="A":"ascending",1:"descending")) + Q TIUY +DATENOTE(X) ; Ask for date/time of note + N %DT,Y + ;S TIUPRMT="DATE/TIME OF NOTE" + ;S TIUY=$$READ^TIUU("D^:NOW:RS",TIUPRMT,$G(DFLT,"NOW"),TIUHLP) + ;I +TIUY W " ",$P(TIUY,U,2) + S %DT="RSX",%DT(0)="-NOW" D ^%DT + I +Y'>0 D + . W !,$C(7),"Enter DATE AND TIME of the note [TIME REQUIRED] (future dates prohibited)." + Q +$G(Y) +SCRCSNR(TIUDA,Y) ; Evaluate whether a person may be selected to cosign + N TIUI,TIUY,TIUD0,TIUD12 S TIUY=1 ; most people may be selected + S TIUD0=$G(^TIU(8925,+TIUDA,0)),TIUD12=$G(^TIU(8925,+TIUDA,12)) + ; If he requires cosignature for this document a user may NOT select + ; himself + I +$$REQCOSIG^TIULP(+TIUD0,+TIUDA,+$G(DUZ)),(Y=+$G(DUZ)) S TIUY=0 G SCREENX + ; A TERMINATED User may NOT be selected + I +$$ACTIVE^XUSER(+Y)'>0 S TIUY=0 G SCREENX + ; A non-PROVIDER may NOT be selected + I +$$PROVIDER^TIUPXAP1(+Y,DT)'>0 S TIUY=0 G SCREENX + ; Author may NOT be selected + I Y=+$P(TIUD12,U,2) S TIUY=0 G SCREENX + ; Expected Signer may NOT be selected + I Y=+$P(TIUD12,U,4) S TIUY=0 G SCREENX + ; Others who require Cosignature may NOT be selected + I +$$REQCOSIG^TIULP(+TIUD0,+TIUDA,+Y) S TIUY=0 +SCREENX Q +$G(TIUY) +SCRDFCS(USER,Y) ; Screen Default Cosigner selection for USER + N TIUY S TIUY=1 + S USER=$G(USER,DUZ) + ; A user may NOT select himself + I Y=USER S TIUY=0 G SCRDFX + ; A TERMINATED User may NOT be selected + I +$$ACTIVE^XUSER(+Y)'>0 S TIUY=0 G SCREENX + ; A non-PROVIDER may NOT be selected + I +$$PROVIDER^TIUPXAP1(+Y,DT)'>0 S TIUY=0 G SCREENX +SCRDFX Q TIUY diff --git a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIULMED.m b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIULMED.m index ff7aa631..bb14fdbb 100644 --- a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIULMED.m +++ b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIULMED.m @@ -1,187 +1,182 @@ -TIULMED ; SLC/JM,JH,AJB - Active/Recent Med Objects Routine ; 12/18/07 - ;;1.0;TEXT INTEGRATION UTILITIES;**38,73,92,94,183,193,197,198,202,213,238**;Jun 20, 1997;Build 6 - Q -LIST(DFN,TARGET,ACTVONLY,DETAILED,ALLMEDS,ONELIST,CLASSORT,SUPPLIES) ; - ; This is the TIU Medication objects API. Optional parameters not - ; provided default to 0 (with the exception of SUPPLIES). - ;Required Parameters: - ; DFN Patient identifier - ; TARGET Where the medication data will be stored - ;Optional Parameters: - ; ACTVONLY 0 - Active and recently expired meds - ; 1 - Active meds only - ; 2 - Recently expired meds only - ; DETAILED 0 - One line per med only - ; 1 - Detailed information on each med - ; ALLMEDS 0 - Specifies Inpatient Meds if patient is an - ; Inpatient, or Outpatient Meds if patient - ; is an Outpatient - ; 1 - Specifies both Inpatient and Outpatient - ; 2 or "I" - Specifies Inpatient only - ; 3 or "O" - Specifies Outpatient only - ; ONELIST 0 - Separates Active, Pending and Inactive - ; medications into separate lists - ; 1 - Combines Active, Pending and Inactive - ; medications into the same list - ; CLASSORT 0 - Sort meds alphabetically - ; 1 - Sort meds by drug class, and within the - ; same drug class, sort alphabetically - ; 2 - Same as #1, but show drug class in header - ; SUPPLIES 0 - Supplies are excluded - ; 1 - Supplies are included (Default) - N NEXTLINE,EMPTY,INDEX,NODE,ISINP,KEEPMED,STATUS,ASTATS,PSTATS,OK - N STATIDX,INPTYPE,OUTPTYPE,TYPE,MEDTYPE,MED,IDATE,XSTR,LLEN - N SPACE60,DASH73,LINE,TAB,HEADER - N DRUGCLAS,DRUGIDX,UNKNOWNS - N NVATYPE,NVAMED,NVASTR,TIUXSTAT - N %,%H,STOP,LSTFD ;Clean up after external calls... - S (NEXTLINE,TAB,HEADER,UNKNOWNS)=0,LLEN=47 - S $P(SPACE60," ",60)=" ",$P(DASH73,"=",73)="=" - K @TARGET,^TMP("PS",$J) - ; Check for Pharmacy Package and required patches - I '$$PATCHSOK^TIULMED3 G LISTX ;P213 - I '+$G(ACTVONLY) S ACTVONLY=0 - I '+$G(DETAILED) S DETAILED=0 - I +$D(ALLMEDS) D - .I ALLMEDS="I" S ALLMEDS=2 - .E I ALLMEDS="O" S ALLMEDS=3 - I '+$G(ALLMEDS) S ALLMEDS=0 - I '+$G(ONELIST) S ONELIST=0 - I '+$G(CLASSORT) S CLASSORT=0 - I $G(SUPPLIES)'="0" S SUPPLIES=1 - S (EMPTY,HEADER)=1 - I ONELIST,'ALLMEDS,'DETAILED,'CLASSORT S HEADER=0 - I 'DETAILED S LLEN=60 - S ASTATS="^ACTIVE^REFILL^HOLD^PROVIDER HOLD^ON CALL^ACTIVE (S)^" - S PSTATS="^NON-VERIFIED^DRUG INTERACTIONS^INCOMPLETE^PENDING^" - S ISINP=($G(^DPT(DFN,.1))'="") ; Is this an inpatient? IA 10035 - I ISINP S INPTYPE=1,OUTPTYPE=2 - E S INPTYPE=2,OUTPTYPE=1 - S NVATYPE=3 - D ADDTITLE^TIULMED1 - ; - ; *** Scan medication data and skip unwanted meds *** - ; Changes for *238 required by PSO*7*294 - D - . I $$PATCH^XPDUTL("PSO*7.0*294"),+$D(TIUDATE) S TIUDATE=$$FMADD^XLFDT(DT,-$G(TIUDATE)) D OCL^PSOQ0496(DFN,TIUDATE,"") Q ; IA 2400 - . D OCL^PSOORRL(DFN,"","") ; IA 2400 - ; - S INDEX=0 - F S INDEX=$O(^TMP("PS",$J,INDEX)) Q:INDEX'>0 D - .S NODE=$G(^TMP("PS",$J,INDEX,0)) - .S KEEPMED=($L($P(NODE,U,2))>0) ;Discard Blank Meds - .I KEEPMED D - ..S STATUS=$P(NODE,U,9) - ..I STATUS="ACTIVE/SUSP" S STATUS="ACTIVE (S)" - ..I $F(ASTATS,"^"_STATUS_"^")>0 S STATIDX=1 - ..E I ($F(PSTATS,"^"_STATUS_"^")>0) S STATIDX=2 - ..E S STATIDX=3 - ..S TIUXSTAT=STATUS - ..I ACTVONLY=1 S KEEPMED=(STATIDX<3) - ..I ACTVONLY=2 S KEEPMED=(STATIDX=3) - ..I +ONELIST S STATIDX=1 - ..; Changes for *238 required by PSO*7*294 - ..I $$PATCH^XPDUTL("PSO*7.0*294"),+$D(TIUDATE),STATUS["DISCONTINUED" S KEEPMED=0 - .I KEEPMED D - ..S TYPE=$P($P(NODE,U),";",2) - ..S TYPE=$S(TYPE="O":"OP",TYPE="I":"UD",1:"") - ..S NVAMED=$P($P(NODE,U),";") - ..S NVAMED=$E(NVAMED,$L(NVAMED)) - ..S KEEPMED=(TYPE'="") - .I KEEPMED D - ..I $O(^TMP("PS",$J,INDEX,"A",0))>0 S TYPE="IV" - ..E I $O(^TMP("PS",$J,INDEX,"B",0))>0 S TYPE="IV" - ..I TYPE="OP" S MEDTYPE=OUTPTYPE - ..E S MEDTYPE=INPTYPE - ..I NVAMED="N" S MEDTYPE=NVATYPE - ..I ALLMEDS=0 D I 1 - ...I MEDTYPE=INPTYPE S KEEPMED=ISINP - ...E S KEEPMED='ISINP - ..E I ALLMEDS=2 S KEEPMED=(MEDTYPE=INPTYPE) - ..E I ALLMEDS=3 S KEEPMED=(MEDTYPE=OUTPTYPE!(MEDTYPE=NVATYPE)) - .S DRUGCLAS=" " - .S MED=$P(NODE,U,2) - .I KEEPMED,(CLASSORT!('SUPPLIES)) D - ..S DRUGIDX=$$IENNAME^TIULMED2(MED) - ..D GETCLASS - .. ; If DRUGIDX="" (MED not in Drug File 50), get info - .. ; via Orderable Item instead. - ..I KEEPMED,+DRUGIDX=0 D - ...N IDX,ID,ORDIDX,TMPCLASS,CDONE,SDONE,TMPIDX,TMPNODE,ISSUPPLY - ...S ID=$P(NODE,U),IDX=+ID,ID=$E(ID,$L(IDX)+1,$L(ID)) - ...S (DRUGIDX,ORDIDX)=0 - ...K ^TMP($J,"TIULMED") - ...; IDX is Order #; ID indicates what file. See IA 2400 - ...; R;O MED will always be in Drug File (Unless Drug File entry was - ...; changed after ordering. - ...I ID="R;O" D ;R;O = prescription (file #52). P213 - ....D RX^PSO52API(DFN,"TIULMED",IDX,"","0,O") ; IA 4820 - ....S DRUGIDX=+$G(^TMP($J,"TIULMED",DFN,IDX,6)) - ....S ORDIDX=+$G(^TMP($J,"TIULMED",DFN,IDX,"OI")) - ...; - ...I ID="P;O" D ;P;O = pending outpatient order (file #52.41). P213 - ....D PEN^PSO5241(DFN,"TIULMED",IDX) ; IA 4821 - ....S DRUGIDX=+$G(^TMP($J,"TIULMED",DFN,IDX,11)) - ....S ORDIDX=+$G(^TMP($J,"TIULMED",DFN,IDX,8)) - ...; - ...I ID="P;I" D ;P;I = pending inpatient order (file #53.1) - ....I $P($G(^PS(53.1,IDX,1,0)),U,4)=1 D ; IA 2907 - .....S TMPIDX=$O(^PS(53.1,IDX,1,0)) I +TMPIDX D - ......S DRUGIDX=$P($G(^PS(53.1,IDX,1,TMPIDX,0)),U) - ....S ORDIDX=+$P($G(^PS(53.1,IDX,.2)),U) - ...; - ...I ID="U;I" D ;U;I = unit dose order (file #55, subfile 55.06) P213 - ....D PSS431^PSS55(DFN,IDX,"","","TIULMED") ; IA 4826 - ....I +$G(^TMP($J,"TIULMED",IDX,"DDRUG",0))=1 D - .....S TMPIDX=$O(^TMP($J,"TIULMED",IDX,"DDRUG",0)) Q:TMPIDX'>0 - .....S DRUGIDX=+$G(^TMP($J,"TIULMED",IDX,"DDRUG",TMPIDX,.01)) - .....S ORDIDX=+$G(^TMP($J,"TIULMED",IDX,108)) - ...; - ...I ID="V;I" D ;V;I = IV order (file #55, subfile 55.01). P213 - ....D PSS436^PSS55(DFN,IDX,"TIULMED") ; IA 4826 - ....; Get ORDIDX before DRUGIDX since global is not there after DRUGIDX - ....S ORDIDX=+$G(^TMP($J,"TIULMED",IDX,130)) - ....I ^TMP($J,"TIULMED",IDX,"ADD",0)=1 D - .....S TMPIDX=$O(^TMP($J,"TIULMED",IDX,"ADD",0)) I +TMPIDX D - ......S TMPIDX=+$G(^TMP($J,"TIULMED",IDX,"ADD",TMPIDX,.01)) - ......I +TMPIDX S DRUGIDX=$$DRGIEN^TIULMED2(TMPIDX) ; IA 4662 - ...; - ...S DRUGCLAS="" - ...D GETCLASS - ...I KEEPMED,+DRUGIDX=0,+ORDIDX,DRUGCLAS="" D - ....S IDX=0,ISSUPPLY=2,CDONE='CLASSORT,SDONE=+SUPPLIES - ....N LIST S LIST="TIULMED" K ^TMP($J,LIST) - ....D DRGIEN^PSS50P7(ORDIDX,"",LIST) ; IA 4662 - ....F S IDX=$O(^TMP($J,LIST,IDX)) Q:'IDX D Q:(CDONE&SDONE) - .....S TMPCLASS=$$DRGCLASS^TIULMED2(IDX) - .....S TMPNODE=U_TMPCLASS_U_$$DEA^TIULMED2(IDX) - .....I 'CDONE,TMPCLASS="" S CDONE=1,DRUGCLAS="" - .....I 'CDONE D - ......I DRUGCLAS="" S DRUGCLAS=TMPCLASS - ......E I DRUGCLAS'=TMPCLASS S CDONE=1,DRUGCLAS="" - .....I 'SDONE D - ......S ISSUPPLY=(($E(TMPCLASS,1,2)="XA")&($P(TMPNODE,U,3)["S")) - ......I 'ISSUPPLY S SDONE=1 - ....I 'SUPPLIES,(ISSUPPLY=1) S KEEPMED=0 - ..I (DRUGCLAS="")!('CLASSORT) S DRUGCLAS=" " - .; - .; *** Save wanted meds in "B" temp xref, removing duplicates *** - .; - .I KEEPMED D - ..D ADDMED^TIULMED1(1) ; Get XSTR to check for duplicates - ..;VMP OIFO BAY PINES;ELR;TIU*1.0*198;ADDED TIUXSTAT TO TMP GLOBAL - ..S IDATE=$P(NODE,U,15) - ..S OK='$D(@TARGET@("B",MED,XSTR,TIUXSTAT)) - ..I 'OK,(IDATE>@TARGET@("B",MED,XSTR,TIUXSTAT)) S OK=1 - ..I OK D - ...S @TARGET@("B",MED,XSTR,TIUXSTAT)=IDATE_U_INDEX_U_MEDTYPE_STATIDX_U_TYPE_U_DRUGCLAS - ...S EMPTY=0 - ...I DRUGCLAS=" " S UNKNOWNS=1 - ; - D SORTSAVE^TIULMED3 K @TARGET@("B"),@TARGET@("C") ;P213 -LISTX K ^TMP("PS",$J),^TMP($J,"TIULMED"),TIUDATE ; K TIUDATE added for PSO*7*294 - Q "~@"_$NA(@TARGET) - ; -GETCLASS ; - D GETCLASS^TIULMED3 - Q +TIULMED ; SLC/JM,JH - Active/Recent Med Objects Routine ;1/23/07 + ;;1.0;TEXT INTEGRATION UTILITIES;**38,73,92,94,183,193,197,198,202,213**;Jun 20, 1997;Build 3 + Q +LIST(DFN,TARGET,ACTVONLY,DETAILED,ALLMEDS,ONELIST,CLASSORT,SUPPLIES) ; + ; This is the TIU Medication objects API. Optional parameters not + ; provided default to 0 (with the exception of SUPPLIES). + ;Required Parameters: + ; DFN Patient identifier + ; TARGET Where the medication data will be stored + ;Optional Parameters: + ; ACTVONLY 0 - Active and recently expired meds + ; 1 - Active meds only + ; 2 - Recently expired meds only + ; DETAILED 0 - One line per med only + ; 1 - Detailed information on each med + ; ALLMEDS 0 - Specifies Inpatient Meds if patient is an + ; Inpatient, or Outpatient Meds if patient + ; is an Outpatient + ; 1 - Specifies both Inpatient and Outpatient + ; 2 or "I" - Specifies Inpatient only + ; 3 or "O" - Specifies Outpatient only + ; ONELIST 0 - Separates Active, Pending and Inactive + ; medications into separate lists + ; 1 - Combines Active, Pending and Inactive + ; medications into the same list + ; CLASSORT 0 - Sort meds alphabetically + ; 1 - Sort meds by drug class, and within the + ; same drug class, sort alphabetically + ; 2 - Same as #1, but show drug class in header + ; SUPPLIES 0 - Supplies are excluded + ; 1 - Supplies are included (Default) + N NEXTLINE,EMPTY,INDEX,NODE,ISINP,KEEPMED,STATUS,ASTATS,PSTATS,OK + N STATIDX,INPTYPE,OUTPTYPE,TYPE,MEDTYPE,MED,IDATE,XSTR,LLEN + N SPACE60,DASH73,LINE,TAB,HEADER + N DRUGCLAS,DRUGIDX,UNKNOWNS + N NVATYPE,NVAMED,NVASTR,TIUXSTAT + N %,%H,STOP,LSTFD ;Clean up after external calls... + S (NEXTLINE,TAB,HEADER,UNKNOWNS)=0,LLEN=47 + S $P(SPACE60," ",60)=" ",$P(DASH73,"=",73)="=" + K @TARGET,^TMP("PS",$J) + ; Check for Pharmacy Package and required patches + I '$$PATCHSOK^TIULMED3 G LISTX ;P213 + I '+$G(ACTVONLY) S ACTVONLY=0 + I '+$G(DETAILED) S DETAILED=0 + I +$D(ALLMEDS) D + .I ALLMEDS="I" S ALLMEDS=2 + .E I ALLMEDS="O" S ALLMEDS=3 + I '+$G(ALLMEDS) S ALLMEDS=0 + I '+$G(ONELIST) S ONELIST=0 + I '+$G(CLASSORT) S CLASSORT=0 + I $G(SUPPLIES)'="0" S SUPPLIES=1 + S (EMPTY,HEADER)=1 + I ONELIST,'ALLMEDS,'DETAILED,'CLASSORT S HEADER=0 + I 'DETAILED S LLEN=60 + S ASTATS="^ACTIVE^REFILL^HOLD^PROVIDER HOLD^ON CALL^ACTIVE (S)^" + S PSTATS="^NON-VERIFIED^DRUG INTERACTIONS^INCOMPLETE^PENDING^" + S ISINP=($G(^DPT(DFN,.1))'="") ; Is this an inpatient? IA 10035 + I ISINP S INPTYPE=1,OUTPTYPE=2 + E S INPTYPE=2,OUTPTYPE=1 + S NVATYPE=3 + D ADDTITLE^TIULMED1 + ; + ; *** Scan medication data and skip unwanted meds *** + ; + D OCL^PSOORRL(DFN,"","") ; IA 2400 + S INDEX=0 + F S INDEX=$O(^TMP("PS",$J,INDEX)) Q:INDEX'>0 D + .S NODE=$G(^TMP("PS",$J,INDEX,0)) + .S KEEPMED=($L($P(NODE,U,2))>0) ;Discard Blank Meds + .I KEEPMED D + ..S STATUS=$P(NODE,U,9) + ..I STATUS="ACTIVE/SUSP" S STATUS="ACTIVE (S)" + ..I $F(ASTATS,"^"_STATUS_"^")>0 S STATIDX=1 + ..E I ($F(PSTATS,"^"_STATUS_"^")>0) S STATIDX=2 + ..E S STATIDX=3 + ..S TIUXSTAT=STATUS + ..I ACTVONLY=1 S KEEPMED=(STATIDX<3) + ..I ACTVONLY=2 S KEEPMED=(STATIDX=3) + ..I +ONELIST S STATIDX=1 + .I KEEPMED D + ..S TYPE=$P($P(NODE,U),";",2) + ..S TYPE=$S(TYPE="O":"OP",TYPE="I":"UD",1:"") + ..S NVAMED=$P($P(NODE,U),";") + ..S NVAMED=$E(NVAMED,$L(NVAMED)) + ..S KEEPMED=(TYPE'="") + .I KEEPMED D + ..I $O(^TMP("PS",$J,INDEX,"A",0))>0 S TYPE="IV" + ..E I $O(^TMP("PS",$J,INDEX,"B",0))>0 S TYPE="IV" + ..I TYPE="OP" S MEDTYPE=OUTPTYPE + ..E S MEDTYPE=INPTYPE + ..I NVAMED="N" S MEDTYPE=NVATYPE + ..I ALLMEDS=0 D I 1 + ...I MEDTYPE=INPTYPE S KEEPMED=ISINP + ...E S KEEPMED='ISINP + ..E I ALLMEDS=2 S KEEPMED=(MEDTYPE=INPTYPE) + ..E I ALLMEDS=3 S KEEPMED=(MEDTYPE=OUTPTYPE!(MEDTYPE=NVATYPE)) + .S DRUGCLAS=" " + .S MED=$P(NODE,U,2) + .I KEEPMED,(CLASSORT!('SUPPLIES)) D + ..S DRUGIDX=$$IENNAME^TIULMED2(MED) + ..D GETCLASS + .. ; If DRUGIDX="" (MED not in Drug File 50), get info + .. ; via Orderable Item instead. + ..I KEEPMED,+DRUGIDX=0 D + ...N IDX,ID,ORDIDX,TMPCLASS,CDONE,SDONE,TMPIDX,TMPNODE,ISSUPPLY + ...S ID=$P(NODE,U),IDX=+ID,ID=$E(ID,$L(IDX)+1,$L(ID)) + ...S (DRUGIDX,ORDIDX)=0 + ...K ^TMP($J,"TIULMED") + ...; IDX is Order #; ID indicates what file. See IA 2400 + ...; R;O MED will always be in Drug File (Unless Drug File entry was + ...; changed after ordering. + ...I ID="R;O" D ;R;O = prescription (file #52). P213 + ....D RX^PSO52API(DFN,"TIULMED",IDX,"","0,O") ; IA 4820 + ....S DRUGIDX=+$G(^TMP($J,"TIULMED",DFN,IDX,6)) + ....S ORDIDX=+$G(^TMP($J,"TIULMED",DFN,IDX,"OI")) + ...; + ...I ID="P;O" D ;P;O = pending outpatient order (file #52.41). P213 + ....D PEN^PSO5241(DFN,"TIULMED",IDX) ; IA 4821 + ....S DRUGIDX=+$G(^TMP($J,"TIULMED",DFN,IDX,11)) + ....S ORDIDX=+$G(^TMP($J,"TIULMED",DFN,IDX,8)) + ...; + ...I ID="P;I" D ;P;I = pending inpatient order (file #53.1) + ....I $P($G(^PS(53.1,IDX,1,0)),U,4)=1 D ; IA 2907 + .....S TMPIDX=$O(^PS(53.1,IDX,1,0)) I +TMPIDX D + ......S DRUGIDX=$P($G(^PS(53.1,IDX,1,TMPIDX,0)),U) + ....S ORDIDX=+$P($G(^PS(53.1,IDX,.2)),U) + ...; + ...I ID="U;I" D ;U;I = unit dose order (file #55, subfile 55.06) P213 + ....D PSS431^PSS55(DFN,IDX,"","","TIULMED") ; IA 4826 + ....I +$G(^TMP($J,"TIULMED",IDX,"DDRUG",0))=1 D + .....S TMPIDX=$O(^TMP($J,"TIULMED",IDX,"DDRUG",0)) Q:TMPIDX'>0 + .....S DRUGIDX=+$G(^TMP($J,"TIULMED",IDX,"DDRUG",TMPIDX,.01)) + .....S ORDIDX=+$G(^TMP($J,"TIULMED",IDX,108)) + ...; + ...I ID="V;I" D ;V;I = IV order (file #55, subfile 55.01). P213 + ....D PSS436^PSS55(DFN,IDX,"TIULMED") ; IA 4826 + ....; Get ORDIDX before DRUGIDX since global is not there after DRUGIDX + ....S ORDIDX=+$G(^TMP($J,"TIULMED",IDX,130)) + ....I ^TMP($J,"TIULMED",IDX,"ADD",0)=1 D + .....S TMPIDX=$O(^TMP($J,"TIULMED",IDX,"ADD",0)) I +TMPIDX D + ......S TMPIDX=+$G(^TMP($J,"TIULMED",IDX,"ADD",TMPIDX,.01)) + ......I +TMPIDX S DRUGIDX=$$DRGIEN^TIULMED2(TMPIDX) ; IA 4662 + ...; + ...S DRUGCLAS="" + ...D GETCLASS + ...I KEEPMED,+DRUGIDX=0,+ORDIDX,DRUGCLAS="" D + ....S IDX=0,ISSUPPLY=2,CDONE='CLASSORT,SDONE=+SUPPLIES + ....N LIST S LIST="TIULMED" K ^TMP($J,LIST) + ....D DRGIEN^PSS50P7(ORDIDX,"",LIST) ; IA 4662 + ....F S IDX=$O(^TMP($J,LIST,IDX)) Q:'IDX D Q:(CDONE&SDONE) + .....S TMPCLASS=$$DRGCLASS^TIULMED2(IDX) + .....S TMPNODE=U_TMPCLASS_U_$$DEA^TIULMED2(IDX) + .....I 'CDONE,TMPCLASS="" S CDONE=1,DRUGCLAS="" + .....I 'CDONE D + ......I DRUGCLAS="" S DRUGCLAS=TMPCLASS + ......E I DRUGCLAS'=TMPCLASS S CDONE=1,DRUGCLAS="" + .....I 'SDONE D + ......S ISSUPPLY=(($E(TMPCLASS,1,2)="XA")&($P(TMPNODE,U,3)["S")) + ......I 'ISSUPPLY S SDONE=1 + ....I 'SUPPLIES,(ISSUPPLY=1) S KEEPMED=0 + ..I (DRUGCLAS="")!('CLASSORT) S DRUGCLAS=" " + .; + .; *** Save wanted meds in "B" temp xref, removing duplicates *** + .; + .I KEEPMED D + ..D ADDMED^TIULMED1(1) ; Get XSTR to check for duplicates + ..;VMP OIFO BAY PINES;ELR;TIU*1.0*198;ADDED TIUXSTAT TO TMP GLOBAL + ..S IDATE=$P(NODE,U,15) + ..S OK='$D(@TARGET@("B",MED,XSTR,TIUXSTAT)) + ..I 'OK,(IDATE>@TARGET@("B",MED,XSTR,TIUXSTAT)) S OK=1 + ..I OK D + ...S @TARGET@("B",MED,XSTR,TIUXSTAT)=IDATE_U_INDEX_U_MEDTYPE_STATIDX_U_TYPE_U_DRUGCLAS + ...S EMPTY=0 + ...I DRUGCLAS=" " S UNKNOWNS=1 + ; + D SORTSAVE^TIULMED3 K @TARGET@("B"),@TARGET@("C") ;P213 +LISTX K ^TMP("PS",$J),^TMP($J,"TIULMED") + Q "~@"_$NA(@TARGET) + ; +GETCLASS ; + D GETCLASS^TIULMED3 + Q diff --git a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIULP.m b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIULP.m index 54082a87..d713d736 100644 --- a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIULP.m +++ b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIULP.m @@ -1,164 +1,162 @@ -TIULP ; SLC/JER - Functions determining privilege ;11/13/07 - ;;1.0;TEXT INTEGRATION UTILITIES;**98,100,116,109,138,152,175,157,182,184,217,236,234**;Jun 20, 1997;Build 6 - ; CANDO^USRLA: ICA 2325, ISA^USRLM: ICA 2324 - ; 8930.1,2,8: IACS 3129,3128,3104 -CANDO(TIUDA,TIUACT,PERSON) ; Can PERSON perform action now - ; Receives: TIUDA=Record number in file 8925 - ; TIUACT=Name of user action in 8930.8 (USR ACTION) - ; PERSON=New Person file IFN. - ; Assumed to be DUZ if not received. - ; New **100** ID param, backward compatible. - ; Returns: TIUY=1:yes,0:no_"^"_why not message - N TIUI,TIUTYP,TIUROLE,STATUS,TIUY,TIUATYP,MSG,WHO,MODIFIER,TIUD0,TIUACTW - S TIUY=0 I '$G(PERSON) S PERSON=DUZ - S TIUD0=$G(^TIU(8925,+TIUDA,0)) I 'TIUD0 G CANDOX - I $$ISPRFDOC^TIUPRF(TIUDA),((TIUACT="ATTACH ID ENTRY")!(TIUACT="ATTACH TO ID NOTE")) S TIUY="0^Patient Record Flag notes may not be used as Interdisciplinary notes." G CANDOX - S TIUACTW=$G(TIUACT) - ;**100** was I +TIUACT'>0 S TIUACT etc. - S TIUACT=$$USREVNT(TIUACT) I +TIUACT'>0 G CANDOX - ; -- Historical Procedures - Prohibit actions detailed in - ; HPCAN^TIUCP: P182 - N HPCAN I $$ISHISTCP^TIUCP(+TIUD0) S HPCAN=$$HPCAN^TIUCP(+TIUACT) I 'HPCAN S TIUY=HPCAN G CANDOX - ; **152 Get status - S STATUS=+$P(TIUD0,U,5) - ; **152[234] prevents editing or sending back a completed or uncosigned document. - I STATUS>5,(+TIUACT=9)!(+TIUACT=17) D G CANDOX - . ; **152[234] Displays message to user - . I +TIUACT=9 S TIUY="0^ You may not edit uncosigned or completed documents." - . I +TIUACT=17 S TIUY="0^You may not send back uncosigned or completed documents." - ; -- In case business rules have changed, & children already existed: - I +TIUACT=24,$D(^TIU(8925,"GDAD",TIUDA)) D G CANDOX - . S TIUY="0^ This note cannot be attached; it has its own children." - I +TIUACT=25,+$G(^TIU(8925,TIUDA,21)) D G CANDOX - . S TIUY="0^ This note cannot receive interdisciplinary children; it is itself a child." - I +TIUACT=4!(+TIUACT=5),+$$BLANK^TIULC(TIUDA) D G CANDOX ;Sets TIUPRM1 - . S TIUY="0^ Contains blanks ("_$P(TIUPRM1,U,6)_") which must be filled before "_$P(TIUACT,U,2)_"ATURE." - S TIUROLE=$$USRROLE(TIUDA,PERSON) - S TIUTYP=+TIUD0 - I $$ISADDNDM^TIULC1(+TIUDA) S TIUATYP=TIUTYP,TIUTYP=+$G(^TIU(8925,+$P(TIUD0,U,6),0)) - I TIUROLE']"" S TIUY=$$CANDO^USRLA(TIUTYP,STATUS,+TIUACT,PERSON) - F TIUI=1:1:($L(TIUROLE,U)-1) D Q:+$G(TIUY)>0 - . S TIUY=$$CANDO^USRLA(TIUTYP,STATUS,+TIUACT,PERSON,$P(TIUROLE,U,TIUI)) - I +$G(TIUATYP) S TIUTYP=+$G(TIUATYP) - ;**100** update for PERSON param; update for verb modifier: - I +TIUY'>0 D G CANDOX - . S WHO=" You" - . ;I PERSON'=DUZ S WHO=$P(^VA(200,PERSON,0),U),WHO=$$NAME^TIULS(WHO,"FIRST LAST") - . I PERSON'=DUZ S WHO=$$NAME^TIULS($$GET1^DIQ(200,PERSON,.01),"FIRST LAST") ;P182 - . S MODIFIER=$P(TIUACT,U,3) I $L(MODIFIER) S MODIFIER=" "_MODIFIER - . ;e.g. "You may not ATTACH this UNSIGNED TELEPHONE NOTE TO AN ID NOTE." - . S MSG=WHO_" may not "_$P(TIUACT,U,2)_" this "_$P($G(^TIU(8925.6,+STATUS,0)),U)_" "_$$PNAME^TIULC1(TIUTYP)_MODIFIER_"." - . S TIUY=TIUY_U_MSG - I +TIUACT=15,$$HASIMG^TIURB2(+TIUDA) D G CANDOX - . S TIUY="0^ This document contains linked images. You must ""delete"" the Images using the Imaging package before proceeding." - ;VMP/ELR P217. Do not allow deletion of a parent with child - I $G(TIUACTW)["DELETE RECORD",$$HASIDKID^TIUGBR(+TIUDA) D G CANDOX - . S TIUY="0^ "_$$EZBLD^DIALOG(89250013) -CANDOX Q TIUY - ; -CANLINK(TIUTYP) ; Can user (DUZ) link (attach) a document of a particular type - ;to an ID note. - ; For use in ADD NEW ID NOTE, where docmt is not entered yet. - ; Assume most favorable circumstances (user will complete - ;the note, so if user still can't attach, can tell them no, - ;when they first select title for the new entry. - ; Rule out if TIUTYP can be an ID parent, since ID parent - ;and ID kid function as mutually exclusive, (regardless of - ;business rules). - N TIUACT,STATUS,USRROLE,TIUY - S TIUACT=$$USREVNT("ATTACH TO ID NOTE"),STATUS=7 ; complete - S USRROLE=+$O(^USR(8930.2,"B","COMPLETER",0)) - S TIUY=$$CANDO^USRLA(TIUTYP,STATUS,+TIUACT,DUZ,USRROLE) - I '$G(TIUY) S TIUY="0^ You may not use this title for interdisciplinary child entries." Q TIUY - ; -- If user can attach a certain note, but note can also receive - ; ID entries, don't let user attach it. -- - I $$POSSPRNT^TIULP(TIUTYP) S TIUY="0^ This interdisciplinary PARENT title cannot be used for CHILD entries." - ; -- If selected type is a CWAD, don't let user attach it: -- - I $$ISCWAD^TIULX(TIUTYP) S TIUY="0^ CWAD titles cannot be used for interdisciplinary entries." - ; -- If selected type is a PRF, don't let user attach it: -- - I $$ISPFTTL^TIUPRFL(TIUTYP) S TIUY="0^ Patient Record Flag titles cannot be used for interdisciplinary entries." - ; -- If selected type is a consult, don't let user attach it: -- - I $$ISA^TIULX(TIUTYP,+$$CLASS^TIUCNSLT) S TIUY="0^ Consult titles cannot be used for interdisciplinary entries." - Q TIUY - ; -POSSPRNT(TIUTYP) ; Is a docmt intended as a possible ID parent? - ;Returns 1^WHYCAN'TATTACH if there are business rules permitting ANYONE - ;to attach ID entries to notes of type TIUTYP. - ;Else returns 0. - N TIUACT,STATUS,TIUY,DADTYP - S TIUY=0,TIUACT=+$$USREVNT("ATTACH ID ENTRY") - F STATUS=6,7,8 D G:TIUY POSSX - . I $O(^USR(8930.1,"AR",TIUTYP,STATUS,TIUACT,0)) S TIUY=1 Q - . I $O(^USR(8930.1,"AC",TIUTYP,STATUS,TIUACT,0)) S TIUY=1 - ; -- If no rules for TIUTYP, try its parent: -- - S DADTYP=$O(^TIU(8925.1,"AD",TIUTYP,0)) G:DADTYP'>0 POSSX - S TIUY=$$POSSPRNT(DADTYP) -POSSX I TIUY S TIUY="1^ Interdisciplinary PARENT notes cannot be attached as CHILD entries." - Q TIUY - ; -CANENTR(TIUTYP) ; Evaluate privilege to enter a document of a particular type - N TIUACT,STATUS,USRROLE,TIUY - S TIUACT=$$USREVNT("ENTRY"),STATUS=2 ; untranscribed - S USRROLE=3 ; transcriber - S TIUY=$$CANDO^USRLA(TIUTYP,STATUS,+TIUACT,DUZ,USRROLE) - Q TIUY -USRROLE(TIUDA,PERSON) ; Identify the user's role with respect to the document - ; 3/20/00 **100** Added role COMPLETER - ; 3/20/00 **100** Added PERSON param - N TIU0,TIU12,TIU13,TIUY,TIU15,COMPLTR,STATUS - S PERSON=$G(PERSON,DUZ) - S TIU0=$G(^TIU(8925,+TIUDA,0)),STATUS=$P(TIU0,U,5) - S TIU12=$G(^TIU(8925,+TIUDA,12)) - S TIU13=$G(^TIU(8925,+TIUDA,13)),TIU15=$G(^TIU(8925,+TIUDA,15)) - I PERSON=+$P(TIU13,U,2) S TIUY=+$O(^USR(8930.2,"B","TRANSCRIBER",0))_U - I PERSON=+$P(TIU12,U,2) S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","AUTHOR/DICTATOR",0))_U - I PERSON=+$P(TIU12,U,9) S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","ATTENDING PHYSICIAN",0))_U - I PERSON=+$P(TIU12,U,4) S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","EXPECTED SIGNER",0))_U - I PERSON=+$P(TIU12,U,8) S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","EXPECTED COSIGNER",0))_U - I $$ASURG^TIUADSIG(TIUDA) S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","SURROGATE",0))_U ;P157 - ;Check if the person can be an Interpreter for this document via a Consult API - I $$CPINTERP^GMRCCP(+TIUDA,PERSON) S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","INTERPRETER",0))_U - I STATUS>6 D I COMPLTR S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","COMPLETER",0))_U - . S COMPLTR=0 - . I PERSON=+$P(TIU15,U,8) S COMPLTR=1 Q - . I '$P(TIU15,U,8),PERSON=+$P(TIU15,U,2) S COMPLTR=1 - I +$O(^TIU(8925.7,"AE",+TIUDA,+PERSON,0)) D - . N TIUXTRA S TIUXTRA=+$O(^TIU(8925.7,"AE",+TIUDA,+PERSON,0)) - . I +$P($G(^TIU(8925.7,+TIUXTRA,0)),U,4) Q - . S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","ADDITIONAL SIGNER",0))_U - Q $G(TIUY) -USREVNT(EVENT) ; Given event name, return: - ;EVENT = event pointer^user verb^verb modifier - ; **100** added verb modifier piece (.07) - N TIUY,TIUDA,NODE0 - S TIUDA=+$O(^USR(8930.8,"B",EVENT,0)) - S NODE0=$G(^USR(8930.8,TIUDA,0)) - S TIUY=TIUDA_U_$P(NODE0,U,5)_U_$P(NODE0,U,7) - Q TIUY -CANPICK(TIUTYP) ; Screens selection of title by title status and - ;(for status TEST), by owner. - N TIUPOWN,TIUCOWN,TIUT0,TIUTSTAT,TIUY S TIUY=0 - S TIUT0=$G(^TIU(8925.1,+TIUTYP,0)),TIUTSTAT=$P(TIUT0,U,7) - I TIUTSTAT']"" S TIUY=0 G CANPIX - I TIUTSTAT=13 S TIUY=0 G CANPIX - I TIUTSTAT=11 S TIUY=1 G CANPIX - S TIUPOWN=$P(TIUT0,U,5),TIUCOWN=+$P(TIUT0,U,6) - I TIUTSTAT=10 S TIUY=$S(TIUPOWN=DUZ:1,+$$ISA^USRLM(DUZ,TIUCOWN):1,1:0) -CANPIX Q +$G(TIUY) -REQCOSIG(TIUTYP,TIUDA,USER,TIUDT) ; Evaluate whether user requires cosignature - N TIUI,TIUY,TIUDPRM S USER=$S(+$G(USER):+$G(USER),1:+$G(DUZ)) - D DOCPRM^TIULC1(TIUTYP,.TIUDPRM,+$G(TIUDA)) - I $G(TIUDPRM(5))="" G REQCOSX - I +$G(TIUDT)'>0 S TIUDT=+$P($P(+$G(^TIU(8925,+$G(TIUDA),13)),U),".") - F TIUI=1:1:$L(TIUDPRM(5),U) D Q:+TIUY>0 - . S TIUY=+$$ISA^USRLM(+USER,+$P(TIUDPRM(5),U,TIUI),,+$G(TIUDT)) -REQCOSX Q +$G(TIUY) - ; -REQCPF(TIUCDA) ;Check if clinical procedure fields are required - ; Input -- TIUCDA Request/Consult File (#123) IEN - ; Output -- 1=Required and 0=Not Required - N TIUCPACT,REQF - I '$G(TIUCDA) G REQCPFQ - S TIUCPACT=$$CPACTM^GMRCCP(TIUCDA) - I TIUCPACT=1!(TIUCPACT=3) S REQF=1 -REQCPFQ Q +$G(REQF) +TIULP ; SLC/JER - Functions determining privilege ;7/29/05 + ;;1.0;TEXT INTEGRATION UTILITIES;**98,100,116,109,138,152,175,157,182,184,217**;Jun 20, 1997 +CANDO(TIUDA,TIUACT,PERSON) ; Can PERSON perform action now + ; Receives: TIUDA=Record number in file 8925 + ; TIUACT=Name of user action in 8930.8 (USR ACTION) + ; PERSON=New Person file IFN. + ; Assumed to be DUZ if not received. + ; New **100** ID param, backward compatible. + ; Returns: TIUY=1:yes,0:no_"^"_why not message + N TIUI,TIUTYP,TIUROLE,STATUS,TIUY,TIUATYP,MSG,WHO,MODIFIER,TIUD0,TIUACTW + S TIUY=0 I '$G(PERSON) S PERSON=DUZ + S TIUD0=$G(^TIU(8925,+TIUDA,0)) I 'TIUD0 G CANDOX + I $$ISPRFDOC^TIUPRF(TIUDA),((TIUACT="ATTACH ID ENTRY")!(TIUACT="ATTACH TO ID NOTE")) S TIUY="0^Patient Record Flag notes may not be used as Interdisciplinary notes." G CANDOX + S TIUACTW=$G(TIUACT) + ;**100** was I +TIUACT'>0 S TIUACT etc. + S TIUACT=$$USREVNT(TIUACT) I +TIUACT'>0 G CANDOX + ; -- Historical Procedures - Prohibit actions detailed in + ; HPCAN^TIUCP: P182 + N HPCAN I $$ISHISTCP^TIUCP(+TIUD0) S HPCAN=$$HPCAN^TIUCP(+TIUACT) I 'HPCAN S TIUY=HPCAN G CANDOX + ; **152 Get status to evaluate for completed document. + S STATUS=+$P(TIUD0,U,5) + ; **152 prevents editing or sending back a completed document. + I STATUS>6,(+TIUACT=9)!(+TIUACT=17) D G CANDOX + .; **152 Displays message to user + . I +TIUACT=9 S TIUY="0^ You may not edit a completed document." + . I +TIUACT=17 S TIUY="0^You may not send back this completed document." + ; -- In case business rules have changed, & children already existed: + I +TIUACT=24,$D(^TIU(8925,"GDAD",TIUDA)) D G CANDOX + . S TIUY="0^ This note cannot be attached; it has its own children." + I +TIUACT=25,+$G(^TIU(8925,TIUDA,21)) D G CANDOX + . S TIUY="0^ This note cannot receive interdisciplinary children; it is itself a child." + I +TIUACT=4!(+TIUACT=5),+$$BLANK^TIULC(TIUDA) D G CANDOX + . S TIUY="0^ Contains blanks ("_$P(TIUPRM1,U,6)_") which must be filled before "_$P(TIUACT,U,2)_"ATURE." + S TIUROLE=$$USRROLE(TIUDA,PERSON) + S TIUTYP=+TIUD0 + I $$ISADDNDM^TIULC1(+TIUDA) S TIUATYP=TIUTYP,TIUTYP=+$G(^TIU(8925,+$P(TIUD0,U,6),0)) + I TIUROLE']"" S TIUY=$$CANDO^USRLA(TIUTYP,STATUS,+TIUACT,PERSON) + F TIUI=1:1:($L(TIUROLE,U)-1) D Q:+$G(TIUY)>0 + . S TIUY=$$CANDO^USRLA(TIUTYP,STATUS,+TIUACT,PERSON,$P(TIUROLE,U,TIUI)) + I +$G(TIUATYP) S TIUTYP=+$G(TIUATYP) + ;**100** update for PERSON param; update for verb modifier: + I +TIUY'>0 D G CANDOX + . S WHO=" You" + . ;I PERSON'=DUZ S WHO=$P(^VA(200,PERSON,0),U),WHO=$$NAME^TIULS(WHO,"FIRST LAST") + . I PERSON'=DUZ S WHO=$$NAME^TIULS($$GET1^DIQ(200,PERSON,.01),"FIRST LAST") ;P182 + . S MODIFIER=$P(TIUACT,U,3) I $L(MODIFIER) S MODIFIER=" "_MODIFIER + . ;e.g. "You may not ATTACH this UNSIGNED TELEPHONE NOTE TO AN ID NOTE." + . S MSG=WHO_" may not "_$P(TIUACT,U,2)_" this "_$P($G(^TIU(8925.6,+STATUS,0)),U)_" "_$$PNAME^TIULC1(TIUTYP)_MODIFIER_"." + . S TIUY=TIUY_U_MSG + I +TIUACT=15,$$HASIMG^TIURB2(+TIUDA) D G CANDOX + . S TIUY="0^ This document contains linked images. You must ""delete"" the Images using the Imaging package before proceeding." + ;VMP/ELR P217. Do not allow deletion of a parent with child + I $G(TIUACTW)["DELETE RECORD",$$HASIDKID^TIUGBR(+TIUDA) D G CANDOX + . S TIUY="0^ "_$$EZBLD^DIALOG(89250013) +CANDOX Q TIUY + ; +CANLINK(TIUTYP) ; Can user (DUZ) link (attach) a document of a particular type + ;to an ID note. + ; For use in ADD NEW ID NOTE, where docmt is not entered yet. + ; Assume most favorable circumstances (user will complete + ;the note, so if user still can't attach, can tell them no, + ;when they first select title for the new entry. + ; Rule out if TIUTYP can be an ID parent, since ID parent + ;and ID kid function as mutually exclusive, (regardless of + ;business rules). + N TIUACT,STATUS,USRROLE,TIUY + S TIUACT=$$USREVNT("ATTACH TO ID NOTE"),STATUS=7 ; complete + S USRROLE=+$O(^USR(8930.2,"B","COMPLETER",0)) + S TIUY=$$CANDO^USRLA(TIUTYP,STATUS,+TIUACT,DUZ,USRROLE) + I '$G(TIUY) S TIUY="0^ You may not use this title for interdisciplinary child entries." Q TIUY + ; -- If user can attach a certain note, but note can also receive + ; ID entries, don't let user attach it. -- + I $$POSSPRNT^TIULP(TIUTYP) S TIUY="0^ This interdisciplinary PARENT title cannot be used for CHILD entries." + ; -- If selected type is a CWAD, don't let user attach it: -- + I $$ISCWAD^TIULX(TIUTYP) S TIUY="0^ CWAD titles cannot be used for interdisciplinary entries." + ; -- If selected type is a PRF, don't let user attach it: -- + I $$ISPFTTL^TIUPRFL(TIUTYP) S TIUY="0^ Patient Record Flag titles cannot be used for interdisciplinary entries." + ; -- If selected type is a consult, don't let user attach it: -- + I $$ISA^TIULX(TIUTYP,+$$CLASS^TIUCNSLT) S TIUY="0^ Consult titles cannot be used for interdisciplinary entries." + Q TIUY + ; +POSSPRNT(TIUTYP) ; Is a docmt intended as a possible ID parent? + ;Returns 1^WHYCAN'TATTACH if there are business rules permitting ANYONE + ;to attach ID entries to notes of type TIUTYP. + ;Else returns 0. + N TIUACT,STATUS,TIUY,DADTYP + S TIUY=0,TIUACT=+$$USREVNT("ATTACH ID ENTRY") + F STATUS=6,7,8 D G:TIUY POSSX + . I $O(^USR(8930.1,"AR",TIUTYP,STATUS,TIUACT,0)) S TIUY=1 Q + . I $O(^USR(8930.1,"AC",TIUTYP,STATUS,TIUACT,0)) S TIUY=1 + ; -- If no rules for TIUTYP, try its parent: -- + S DADTYP=$O(^TIU(8925.1,"AD",TIUTYP,0)) G:DADTYP'>0 POSSX + S TIUY=$$POSSPRNT(DADTYP) +POSSX I TIUY S TIUY="1^ Interdisciplinary PARENT notes cannot be attached as CHILD entries." + Q TIUY + ; +CANENTR(TIUTYP) ; Evaluate privilege to enter a document of a particular type + N TIUACT,STATUS,USRROLE,TIUY + S TIUACT=$$USREVNT("ENTRY"),STATUS=2 ; untranscribed + S USRROLE=3 ; transcriber + S TIUY=$$CANDO^USRLA(TIUTYP,STATUS,+TIUACT,DUZ,USRROLE) + Q TIUY +USRROLE(TIUDA,PERSON) ; Identify the user's role with respect to the document + ; 3/20/00 **100** Added role COMPLETER + ; 3/20/00 **100** Added PERSON param + N TIU0,TIU12,TIU13,TIUY,TIU15,COMPLTR,STATUS + S PERSON=$G(PERSON,DUZ) + S TIU0=$G(^TIU(8925,+TIUDA,0)),STATUS=$P(TIU0,U,5) + S TIU12=$G(^TIU(8925,+TIUDA,12)) + S TIU13=$G(^TIU(8925,+TIUDA,13)),TIU15=$G(^TIU(8925,+TIUDA,15)) + I PERSON=+$P(TIU13,U,2) S TIUY=+$O(^USR(8930.2,"B","TRANSCRIBER",0))_U + I PERSON=+$P(TIU12,U,2) S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","AUTHOR/DICTATOR",0))_U + I PERSON=+$P(TIU12,U,9) S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","ATTENDING PHYSICIAN",0))_U + I PERSON=+$P(TIU12,U,4) S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","EXPECTED SIGNER",0))_U + I PERSON=+$P(TIU12,U,8) S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","EXPECTED COSIGNER",0))_U + I $$ASURG^TIUADSIG(TIUDA) S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","SURROGATE",0))_U ;P157 + ;Check if the person can be an Interpreter for this document via a Consult API + I $$CPINTERP^GMRCCP(+TIUDA,PERSON) S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","INTERPRETER",0))_U + I STATUS>6 D I COMPLTR S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","COMPLETER",0))_U + . S COMPLTR=0 + . I PERSON=+$P(TIU15,U,8) S COMPLTR=1 Q + . I '$P(TIU15,U,8),PERSON=+$P(TIU15,U,2) S COMPLTR=1 + I +$O(^TIU(8925.7,"AE",+TIUDA,+PERSON,0)) D + . N TIUXTRA S TIUXTRA=+$O(^TIU(8925.7,"AE",+TIUDA,+PERSON,0)) + . I +$P($G(^TIU(8925.7,+TIUXTRA,0)),U,4) Q + . S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","ADDITIONAL SIGNER",0))_U + Q $G(TIUY) +USREVNT(EVENT) ; Given event name, return: + ;EVENT = event pointer^user verb^verb modifier + ; **100** added verb modifier piece (.07) + N TIUY,TIUDA,NODE0 + S TIUDA=+$O(^USR(8930.8,"B",EVENT,0)) + S NODE0=$G(^USR(8930.8,TIUDA,0)) + S TIUY=TIUDA_U_$P(NODE0,U,5)_U_$P(NODE0,U,7) + Q TIUY +CANPICK(TIUTYP) ; Screens selection of title by title status and + ;(for status TEST), by owner. + N TIUPOWN,TIUCOWN,TIUT0,TIUTSTAT,TIUY S TIUY=0 + S TIUT0=$G(^TIU(8925.1,+TIUTYP,0)),TIUTSTAT=$P(TIUT0,U,7) + I TIUTSTAT']"" S TIUY=0 G CANPIX + I TIUTSTAT=13 S TIUY=0 G CANPIX + I TIUTSTAT=11 S TIUY=1 G CANPIX + S TIUPOWN=$P(TIUT0,U,5),TIUCOWN=+$P(TIUT0,U,6) + I TIUTSTAT=10 S TIUY=$S(TIUPOWN=DUZ:1,+$$ISA^USRLM(DUZ,TIUCOWN):1,1:0) +CANPIX Q +$G(TIUY) +REQCOSIG(TIUTYP,TIUDA,USER,TIUDT) ; Evaluate whether user requires cosignature + N TIUI,TIUY,TIUDPRM S USER=$S(+$G(USER):+$G(USER),1:+$G(DUZ)) + D DOCPRM^TIULC1(TIUTYP,.TIUDPRM,+$G(TIUDA)) + I $G(TIUDPRM(5))="" G REQCOSX + I +$G(TIUDT)'>0 S TIUDT=+$P($P(+$G(^TIU(8925,+$G(TIUDA),13)),U),".") + F TIUI=1:1:$L(TIUDPRM(5),U) D Q:+TIUY>0 + . S TIUY=+$$ISA^USRLM(+USER,+$P(TIUDPRM(5),U,TIUI),,+$G(TIUDT)) +REQCOSX Q +$G(TIUY) + ; +REQCPF(TIUCDA) ;Check if clinical procedure fields are required + ; Input -- TIUCDA Request/Consult File (#123) IEN + ; Output -- 1=Required and 0=Not Required + N TIUCPACT,REQF + I '$G(TIUCDA) G REQCPFQ + S TIUCPACT=$$CPACTM^GMRCCP(TIUCDA) + I TIUCPACT=1!(TIUCPACT=3) S REQF=1 +REQCPFQ Q +$G(REQF) diff --git a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIULX.m b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIULX.m index d75e1ad0..acf3884a 100644 --- a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIULX.m +++ b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIULX.m @@ -1,176 +1,160 @@ -TIULX ; SLC/JER - Cross-reference library functions ;6/21/06 - ;;1.0;TEXT INTEGRATION UTILITIES;**1,28,79,100,136,219**;Jun 20, 1997;Build 11 - ; File 200 - IA 10060 - ; ^ORD(101 - IA 872 - ; ^DISV - IA 510 -ALOCP(DA) ; Should record be included in daily print queue by location? - ; Receives DA = record # in 8925 - Q +$$ISPN(+$G(^TIU(8925,+DA,0))) -APTP(DA) ; Should record be included in daily print queue by patient? - ; Receives DA = record # in 8925 - Q +$$ISPN(+$G(^TIU(8925,+DA,0))) -AAUP(DA) ; Should record be included in daily print queue by author? - ; Receives DA = record # in 8925 - Q +$$ISPN(+$G(^TIU(8925,+DA,0))) -BELONGS(TIUDA,CLASS) ; Evaluate whether a given document belongs to a - ; particular document class - N TIUY - I +$$ISADDNDM^TIULC1(TIUDA) S TIUDA=+$P($G(^TIU(8925,+TIUDA,0)),U,6) - S TIUY=+$$ISA(+$G(^TIU(8925,+TIUDA,0)),CLASS) - Q TIUY -ISA(DA,CLASS) ; Evaluate whether a given document type is a member of a - ; particular document class - ; Receives DA = record # in 8925.1, and - ; CLASS = record # of class in 8925.1 - N TIUI,TIUY S (TIUI,TIUY)=0 - F S TIUI=$O(^TIU(8925.1,"AD",DA,TIUI)) Q:+TIUI'>0!(TIUY=1) D - . I TIUI=CLASS S TIUY=1 Q - . S TIUY=$$ISA(TIUI,CLASS) - Q TIUY -ISPN(DA) ; Evaluate whether a given document is a Progress Note - ; Receives DA = record # in 8925.1 - N TIUI,TIUY S (TIUI,TIUY)=0 - F S TIUI=$O(^TIU(8925.1,"AD",DA,TIUI)) Q:+TIUI'>0!(TIUY=1) D - . I TIUI=3 S TIUY=1 Q - . S TIUY=$$ISPN(TIUI) - Q TIUY -ISCWAD(DA) ; Evaluate whether a given title is a CWAD - ;Is the given title in a CWAD document class? - ;New for ID notes - ; Receives DA = record # in 8925.1 - Q $S($$ISA(DA,25):1,$$ISA(DA,27):1,$$ISA(DA,30):1,$$ISA(DA,31):1,1:0) -ISDS(DA) ; Evaluate whether a given document is a Discharge Summary - ; Receives DA = record # in 8925.1 - N TIUI,TIUY S (TIUI,TIUY)=0 - F S TIUI=$O(^TIU(8925.1,"AD",DA,TIUI)) Q:+TIUI'>0!(TIUY=1) D - . I TIUI=244 S TIUY=1 Q - . S TIUY=$$ISDS(TIUI) - Q TIUY -TRNSFRM(RTYPE,FLD,X) ; Executes Transform code for a given header field - N XFORM - S FLD=$O(^TIU(8925.1,+RTYPE("TYPE"),"HEAD","D",+FLD,0)) - I +FLD'>0 G TRNSFRMX - S XFORM=$G(^TIU(8925.1,+RTYPE("TYPE"),"HEAD",+FLD,1)) - I XFORM']"" G TRNSFRMX - X XFORM -TRNSFRMX Q X -MENUS ; Evaluate/enforce user's menu display preference - N TIUI,TIUPREF S TIUPREF=$$PERSPRF^TIULE(DUZ),TIUI=0 - F S TIUI=$O(^DISV(DUZ,"VALMMENU",TIUI)) Q:+TIUI'>0 D - . I $P($G(^ORD(101,+TIUI,0)),U)["TIU" S ^DISV(DUZ,"VALMMENU",TIUI)=$S($P(TIUPREF,U,5)=0:0,1:1) - Q -XTRASIGN(TIUY,TIUDA) ; Get list of extra signers for a document - N TIUI,TIUJ,TIUL,DA,DR,DIC,DIQ,TIUXTRA S (TIUI,TIUJ,TIUL)=0 - S DIC="^TIU(8925.7,",DIQ="TIUXTRA" - F S TIUI=$O(^TIU(8925.7,"B",TIUDA,TIUI)) Q:+TIUI'>0 D - . N TIUX,TIUSGNR - . S DA=TIUI,DR=".03;.04" D EN^DIQ1 Q:+$D(TIUXTRA)'>9 - . I $L($G(TIUXTRA(8925.7,DA,.04))) Q - . S TIUJ=+$G(TIUJ)+1,TIUL=+$G(TIUL)+1 - . S TIUSGNR=$G(TIUXTRA(8925.7,DA,.03)) - . S TIUX=$$SETSTR^VALM1($G(TIUJ)_") "_TIUSGNR,$G(TIUX),1,39) - . S TIUY(TIUL)=DA_U_TIUX - Q -ASKSIGN(TIUY) ; Identify which Signature to edit - N I,L,Y - W !!,"Please Indicate Which Expected Signer to Change:",! - S (I,L,Y)=0 F S I=$O(TIUY(I)) Q:+I'>0!+Y D - . W:$P(TIUY(I),U)]"" !,$P(TIUY(I),U,2) - . I I#20=0 S Y=$P($$PICK(1,I,"Select Signer","NO"),U) - . S L=I - I L#20,'+Y S Y=$P($$PICK(1,L,"Select Signer","NO"),U) - I +Y,+$G(TIUY(+Y)) S Y=+$G(TIUY(+Y)) - Q Y -PICK(LOW,HIGH,PROMPT,TYPE) ; List selection - N X,Y S PROMPT=$G(PROMPT,"Select Item"),TYPE=$G(TYPE,"LO") - W ! - S Y=$$READ^TIUU(TYPE_U_LOW_":"_HIGH,PROMPT) - W ! - Q Y -CWAD ; Entry action for CWAD protocol - N GMRPALG,GMRPCWAD,GMRPDFN,GMRPOPT,GMRPEN,GMRPAGE,GMRPCWAD,GMRPDOB - N GMRPLOC,GMRPRB,GMRPSSN,GMRPQT - I $G(TIUGLINK) W !,"Please finish attaching the interdisciplinay note before displaying alerts.",! H 3 Q - D FULL^VALM1 - I '+$G(DFN),'+$G(ORVP) D Q - . W !!,"No Patient Selected...",! - . I $$READ^TIUU("EA","Press RETURN to continue...") ; pause - . S VALMBCK="R" - D PAT^GMRPNOR1 I $D(GMRPQT) S VALMBCK="R" Q - S Y=GMRPDFN,GMRPOPT=1,GMRPEN=1 W !!,"** Current Patient: "_$P(Y,U,2) - D ENPAT^GMRPNCW S VALMBCK="R" - Q -IDSIGNRS(TIUY,TIUDA,TIULIST) ; Add list of Add'l Signers for a TIU Document - ; TIULIST(TIUI) [By Ref] = array of users to add/remove as signers - ; TIUDA = IEN in ^TIU(8925, - N TIUI S TIUI=0 - F S TIUI=$O(TIULIST(TIUI)) Q:+TIUI'>0 D - . N DA,DIC,DLAYGO,DIE,DR,X,Y - . ; if current user is already an additional signer, and current user - . ; is NOT being removed as an additional signer, then QUIT - . I +$O(^TIU(8925.7,"AE",TIUDA,+TIULIST(TIUI),0)),($P(TIULIST(TIUI),U,3)'="REMOVE") Q - . ; if current user is being removed as a cosigner, then remove him - . I $P(TIULIST(TIUI),U,3)="REMOVE" D REMSIGNR(TIUDA,+TIULIST(TIUI)) Q - . ; otherwise, add the current user as an additional signer - . S X=""""_"`"_TIUDA_"""",(DIC,DLAYGO)=8925.7,DIC(0)="LX" D ^DIC Q:+Y'>0 - . S DIE=DIC,TIUY=$G(TIUY)_$S($G(TIUY)]"":U,1:"")_+TIULIST(TIUI) - . S DR=".02////"_0_";.03////"_+$G(TIULIST(TIUI)) - . D ^DIE - . D SEND^TIUALRT(TIUDA) - Q -REMSIGNR(TIUDA,TIUDUZ) ; Remove user from additional signer list - N DA,DIE,DR,DIDEL - S DA=+$O(^TIU(8925.7,"AE",TIUDA,TIUDUZ,0)) Q:+DA'>0 - S (DIDEL,DIE)=8925.7,DR=".01///@" D ^DIE - D SEND^TIUALRT(TIUDA) - Q -GETSIGNR(TIUY,TIUDA) ; RPC to Get list of extra signers for a document - N TIUI,DA,DR,DIC,DIQ,TIUXTRA,TIUD12,TIUAU,TIUEC S (DA,TIUI)=0 - S DIC="^TIU(8925.7,",DIQ="TIUXTRA" - F S DA=$O(^TIU(8925.7,"B",TIUDA,DA)) Q:+DA'>0 D - . N TIUX,TIUSGNR - . S DR=".03;.04",DIQ(0)="IE" D EN^DIQ1 Q:+$D(TIUXTRA)'>9 - . I +$G(TIUXTRA(8925.7,DA,.04,"I")) Q - . S TIUI=+$G(TIUI)+1 - . S TIUY(TIUI)=$G(TIUXTRA(8925.7,DA,.03,"I"))_U_$G(TIUXTRA(8925.7,DA,.03,"E")) - S TIUD12=$G(^TIU(8925,TIUDA,12)) - S TIUAU=$P(TIUD12,U,4),TIUEC=$P(TIUD12,U,8) - S TIUI=+$G(TIUI)+1,TIUY(TIUI)=TIUAU_U_$$PERSNAME^TIULC1(TIUAU)_U_"AUTHOR" - I +TIUEC'>0 Q - I '$$FIND1^DIC(200,"","","`"_+TIUEC) D CLEAN^DILF Q - S TIUI=+$G(TIUI)+1,TIUY(TIUI)=TIUEC_U_$$PERSNAME^TIULC1(TIUEC)_U_"EXPECTED COSIGNER" - Q -HASDS(DFN,VSTR) ; Does an admission have a Discharge Summary? - N TITLE,TIUDA S (TIUDA,TITLE)=0 - F S TITLE=$O(^TIU(8925,"APTLD",DFN,TITLE)) Q:+TITLE'>0 D Q:+TIUDA>0 - . N STATUS,CONTEXT S TIUDA=0 - . I '+$$ISDS(TITLE) S TIUDA=0_U_0 Q - . F S TIUDA=$O(^TIU(8925,"APTLD",DFN,TITLE,VSTR,+TIUDA)) Q:+TIUDA'>0 D Q:+$P(TIUDA,U,2) - . . S STATUS=+$P($G(^TIU(8925,+TIUDA,0)),U,5) - . . S CONTEXT=$S(STATUS=0:0,STATUS>13:0,STATUS'>5:2,1:1) - . . S TIUDA=TIUDA_U_CONTEXT - I '+TIUDA,($L(TIUDA,U)<2) S TIUDA=TIUDA_U_0 - Q TIUDA -NEEDSIG(TIUY,USER,CLASS) ; Get list of documents for which USER is an additional signer - N TIUDA,TIUI,TIUJ S (TIUDA,TIUJ)=0 - S USER=$G(USER,DUZ),CLASS=$G(CLASS,38),TIUY=$NA(^TMP("TIUSIGN",$J)) - K @TIUY ; Clear out return array before query - F S TIUDA=$O(^TIU(8925.7,"AES",USER,TIUDA)) Q:+TIUDA'>0 D - . S TIUI=0 F S TIUI=$O(^TIU(8925.7,"AES",USER,TIUDA,TIUI)) Q:+TIUI'>0 D - . . N TIUD0 S TIUD0=$G(^TIU(8925.7,TIUI,0)) Q:+$P(TIUD0,U,4) - . . Q:'+$$ISA(+$G(^TIU(8925,TIUDA,0)),CLASS) - . . S TIUJ=+$G(TIUJ)+1,@TIUY@(TIUJ)=TIUDA - Q -TITLIENS ; Get IENs of DDEF entries that have type Title - ; in Document Definition file 8925.1 - ;Creates array ^TMP("TIUTLS,$J,TLIEN)= - ;Caller must kill ^TMP("TIUTLS",$J) when finished with the global. - N TIUIDX S TIUIDX=0 K ^TMP("TIUTLS",$J) - F S TIUIDX=$O(^TIU(8925.1,"AT","DOC",TIUIDX)) Q:TIUIDX'>0 D - . S ^TMP("TIUTLS",$J,TIUIDX)="" - Q -HASDOCMT(DFN) ;Does patient have ANY entries in TIU DOCUMENT file 8925? - ;Any entries includes original documents, addenda, components - ;(like S in SOAP notes), "deleted" documents, retracted documents, etc! - Q $O(^TIU(8925,"C",+$G(DFN),0))>0 - +TIULX ; SLC/JER - Cross-reference library functions ;18-JUN-2002 10:18:05 + ;;1.0;TEXT INTEGRATION UTILITIES;**1,28,79,100,136**;Jun 20, 1997 +ALOCP(DA) ; Should record be included in daily print queue by location? + ; Receives DA = record # in 8925 + Q +$$ISPN(+$G(^TIU(8925,+DA,0))) +APTP(DA) ; Should record be included in daily print queue by patient? + ; Receives DA = record # in 8925 + Q +$$ISPN(+$G(^TIU(8925,+DA,0))) +AAUP(DA) ; Should record be included in daily print queue by author? + ; Receives DA = record # in 8925 + Q +$$ISPN(+$G(^TIU(8925,+DA,0))) +BELONGS(TIUDA,CLASS) ; Evaluate whether a given document belongs to a + ; particular document class + N TIUY + I +$$ISADDNDM^TIULC1(TIUDA) S TIUDA=+$P($G(^TIU(8925,+TIUDA,0)),U,6) + S TIUY=+$$ISA(+$G(^TIU(8925,+TIUDA,0)),CLASS) + Q TIUY +ISA(DA,CLASS) ; Evaluate whether a given document type is a member of a + ; particular document class + ; Receives DA = record # in 8925.1, and + ; CLASS = record # of class in 8925.1 + N TIUI,TIUY S (TIUI,TIUY)=0 + F S TIUI=$O(^TIU(8925.1,"AD",DA,TIUI)) Q:+TIUI'>0!(TIUY=1) D + . I TIUI=CLASS S TIUY=1 Q + . S TIUY=$$ISA(TIUI,CLASS) + Q TIUY +ISPN(DA) ; Evaluate whether a given document is a Progress Note + ; Receives DA = record # in 8925.1 + N TIUI,TIUY S (TIUI,TIUY)=0 + F S TIUI=$O(^TIU(8925.1,"AD",DA,TIUI)) Q:+TIUI'>0!(TIUY=1) D + . I TIUI=3 S TIUY=1 Q + . S TIUY=$$ISPN(TIUI) + Q TIUY +ISCWAD(DA) ; Evaluate whether a given title is a CWAD + ;Is the given title in a CWAD document class? + ;New for ID notes + ; Receives DA = record # in 8925.1 + Q $S($$ISA(DA,25):1,$$ISA(DA,27):1,$$ISA(DA,30):1,$$ISA(DA,31):1,1:0) +ISDS(DA) ; Evaluate whether a given document is a Discharge Summary + ; Receives DA = record # in 8925.1 + N TIUI,TIUY S (TIUI,TIUY)=0 + F S TIUI=$O(^TIU(8925.1,"AD",DA,TIUI)) Q:+TIUI'>0!(TIUY=1) D + . I TIUI=244 S TIUY=1 Q + . S TIUY=$$ISDS(TIUI) + Q TIUY +TRNSFRM(RTYPE,FLD,X) ; Executes Transform code for a given header field + N XFORM + S FLD=$O(^TIU(8925.1,+RTYPE("TYPE"),"HEAD","D",+FLD,0)) + I +FLD'>0 G TRNSFRMX + S XFORM=$G(^TIU(8925.1,+RTYPE("TYPE"),"HEAD",+FLD,1)) + I XFORM']"" G TRNSFRMX + X XFORM +TRNSFRMX Q X +MENUS ; Evaluate/enforce user's menu display preference + N TIUI,TIUPREF S TIUPREF=$$PERSPRF^TIULE(DUZ),TIUI=0 + F S TIUI=$O(^DISV(DUZ,"VALMMENU",TIUI)) Q:+TIUI'>0 D + . I $P($G(^ORD(101,+TIUI,0)),U)["TIU" S ^DISV(DUZ,"VALMMENU",TIUI)=$S($P(TIUPREF,U,5)=0:0,1:1) + Q +XTRASIGN(TIUY,TIUDA) ; Get list of extra signers for a document + N TIUI,TIUJ,TIUL,DA,DR,DIC,DIQ,TIUXTRA S (TIUI,TIUJ,TIUL)=0 + S DIC="^TIU(8925.7,",DIQ="TIUXTRA" + F S TIUI=$O(^TIU(8925.7,"B",TIUDA,TIUI)) Q:+TIUI'>0 D + . N TIUX,TIUSGNR + . S DA=TIUI,DR=".03;.04" D EN^DIQ1 Q:+$D(TIUXTRA)'>9 + . I $L($G(TIUXTRA(8925.7,DA,.04))) Q + . S TIUJ=+$G(TIUJ)+1,TIUL=+$G(TIUL)+1 + . S TIUSGNR=$G(TIUXTRA(8925.7,DA,.03)) + . S TIUX=$$SETSTR^VALM1($G(TIUJ)_") "_TIUSGNR,$G(TIUX),1,39) + . S TIUY(TIUL)=DA_U_TIUX + Q +ASKSIGN(TIUY) ; Identify which Signature to edit + N I,L,Y + W !!,"Please Indicate Which Expected Signer to Change:",! + S (I,L,Y)=0 F S I=$O(TIUY(I)) Q:+I'>0!+Y D + . W:$P(TIUY(I),U)]"" !,$P(TIUY(I),U,2) + . I I#20=0 S Y=$P($$PICK(1,I,"Select Signer","NO"),U) + . S L=I + I L#20,'+Y S Y=$P($$PICK(1,L,"Select Signer","NO"),U) + I +Y,+$G(TIUY(+Y)) S Y=+$G(TIUY(+Y)) + Q Y +PICK(LOW,HIGH,PROMPT,TYPE) ; List selection + N X,Y S PROMPT=$G(PROMPT,"Select Item"),TYPE=$G(TYPE,"LO") + W ! + S Y=$$READ^TIUU(TYPE_U_LOW_":"_HIGH,PROMPT) + W ! + Q Y +CWAD ; Entry action for CWAD protocol + N GMRPALG,GMRPCWAD,GMRPDFN,GMRPOPT,GMRPEN,GMRPAGE,GMRPCWAD,GMRPDOB + N GMRPLOC,GMRPRB,GMRPSSN,GMRPQT + I $G(TIUGLINK) W !,"Please finish attaching the interdisciplinay note before displaying alerts.",! H 3 Q + D FULL^VALM1 + I '+$G(DFN),'+$G(ORVP) D Q + . W !!,"No Patient Selected...",! + . I $$READ^TIUU("EA","Press RETURN to continue...") ; pause + . S VALMBCK="R" + D PAT^GMRPNOR1 I $D(GMRPQT) S VALMBCK="R" Q + S Y=GMRPDFN,GMRPOPT=1,GMRPEN=1 W !!,"** Current Patient: "_$P(Y,U,2) + D ENPAT^GMRPNCW S VALMBCK="R" + Q +IDSIGNRS(TIUY,TIUDA,TIULIST) ; Add list of Add'l Signers for a TIU Document + ; TIULIST(TIUI) [By Ref] = array of users to add/remove as signers + ; TIUDA = IEN in ^TIU(8925, + N TIUI S TIUI=0 + F S TIUI=$O(TIULIST(TIUI)) Q:+TIUI'>0 D + . N DA,DIC,DLAYGO,DIE,DR,X,Y + . ; if current user is already an additional signer, and current user + . ; is NOT being removed as an additional signer, then QUIT + . I +$O(^TIU(8925.7,"AE",TIUDA,+TIULIST(TIUI),0)),($P(TIULIST(TIUI),U,3)'="REMOVE") Q + . ; if current user is being removed as a cosigner, then remove him + . I $P(TIULIST(TIUI),U,3)="REMOVE" D REMSIGNR(TIUDA,+TIULIST(TIUI)) Q + . ; otherwise, add the current user as an additional signer + . S X=""""_"`"_TIUDA_"""",(DIC,DLAYGO)=8925.7,DIC(0)="LX" D ^DIC Q:+Y'>0 + . S DIE=DIC,TIUY=$G(TIUY)_$S($G(TIUY)]"":U,1:"")_+TIULIST(TIUI) + . S DR=".02////"_0_";.03////"_+$G(TIULIST(TIUI)) + . D ^DIE + . D SEND^TIUALRT(TIUDA) + Q +REMSIGNR(TIUDA,TIUDUZ) ; Remove user from additional signer list + N DA,DIE,DR,DIDEL + S DA=+$O(^TIU(8925.7,"AE",TIUDA,TIUDUZ,0)) Q:+DA'>0 + S (DIDEL,DIE)=8925.7,DR=".01///@" D ^DIE + D SEND^TIUALRT(TIUDA) + Q +GETSIGNR(TIUY,TIUDA) ; RPC to Get list of extra signers for a document + N TIUI,DA,DR,DIC,DIQ,TIUXTRA,TIUD12,TIUAU,TIUEC S (DA,TIUI)=0 + S DIC="^TIU(8925.7,",DIQ="TIUXTRA" + F S DA=$O(^TIU(8925.7,"B",TIUDA,DA)) Q:+DA'>0 D + . N TIUX,TIUSGNR + . S DR=".03;.04",DIQ(0)="IE" D EN^DIQ1 Q:+$D(TIUXTRA)'>9 + . I +$G(TIUXTRA(8925.7,DA,.04,"I")) Q + . S TIUI=+$G(TIUI)+1 + . S TIUY(TIUI)=$G(TIUXTRA(8925.7,DA,.03,"I"))_U_$G(TIUXTRA(8925.7,DA,.03,"E")) + S TIUD12=$G(^TIU(8925,TIUDA,12)) + S TIUAU=$P(TIUD12,U,4),TIUEC=$P(TIUD12,U,8) + S TIUI=+$G(TIUI)+1,TIUY(TIUI)=TIUAU_U_$$PERSNAME^TIULC1(TIUAU)_U_"AUTHOR" + I $S(+TIUEC'>0:1,'$L($G(^VA(200,+TIUEC,0))):1,1:0) Q + S TIUI=+$G(TIUI)+1,TIUY(TIUI)=TIUEC_U_$$PERSNAME^TIULC1(TIUEC)_U_"EXPECTED COSIGNER" + Q +HASDS(DFN,VSTR) ; Does an admission have a Discharge Summary? + N TITLE,TIUDA S (TIUDA,TITLE)=0 + F S TITLE=$O(^TIU(8925,"APTLD",DFN,TITLE)) Q:+TITLE'>0 D Q:+TIUDA>0 + . N STATUS,CONTEXT S TIUDA=0 + . I '+$$ISDS(TITLE) S TIUDA=0_U_0 Q + . F S TIUDA=$O(^TIU(8925,"APTLD",DFN,TITLE,VSTR,+TIUDA)) Q:+TIUDA'>0 D Q:+$P(TIUDA,U,2) + . . S STATUS=+$P($G(^TIU(8925,+TIUDA,0)),U,5) + . . S CONTEXT=$S(STATUS=0:0,STATUS>13:0,STATUS'>5:2,1:1) + . . S TIUDA=TIUDA_U_CONTEXT + I '+TIUDA,($L(TIUDA,U)<2) S TIUDA=TIUDA_U_0 + Q TIUDA +NEEDSIG(TIUY,USER,CLASS) ; Get list of documents for which USER is an additional signer + N TIUDA,TIUI,TIUJ S (TIUDA,TIUJ)=0 + S USER=$G(USER,DUZ),CLASS=$G(CLASS,38),TIUY=$NA(^TMP("TIUSIGN",$J)) + K @TIUY ; Clear out return array before query + F S TIUDA=$O(^TIU(8925.7,"AES",USER,TIUDA)) Q:+TIUDA'>0 D + . S TIUI=0 F S TIUI=$O(^TIU(8925.7,"AES",USER,TIUDA,TIUI)) Q:+TIUI'>0 D + . . N TIUD0 S TIUD0=$G(^TIU(8925.7,TIUI,0)) Q:+$P(TIUD0,U,4) + . . Q:'+$$ISA(+$G(^TIU(8925,TIUDA,0)),CLASS) + . . S TIUJ=+$G(TIUJ)+1,@TIUY@(TIUJ)=TIUDA + Q + diff --git a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUPREL.m b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUPREL.m index 78273d4d..004bae05 100644 --- a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUPREL.m +++ b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUPREL.m @@ -1,4 +1,4 @@ -TIUPREL ; GENERATED FROM 'TIU PRINT REL/UNV' PRINT TEMPLATE (#1350) ; 12/13/08 ; (FILE 8925, MARGIN=132) +TIUPREL ; GENERATED FROM 'TIU RELEASED/UNVERIFIED PRINT' PRINT TEMPLATE (#1115) ; 07/02/04 ; (FILE 8925, MARGIN=132) G BEGIN CP G CP^DIO2 C S DQ(C)=Y @@ -20,7 +20,7 @@ M D @DIXX Q BEGIN ; S:'$D(DN) DN=1 S DISTP=$G(DISTP),DILCT=$G(DILCT) - I $D(DXS)<9 M DXS=^DIPT(1350,"DXS") + I $D(DXS)<9 M DXS=^DIPT(1115,"DXS") S I(0)="^TIU(8925,",J(0)=8925 S X=$G(^TIU(8925,D0,0)) W ?0 S Y=$P(X,U,2) S Y=$S(Y="":Y,$D(^AUPNPAT(Y,0))#2:$P(^(0),U),1:Y) S Y=$S(Y="":Y,$D(^DPT(Y,0))#2:$P(^(0),U),1:Y) W $E(Y,1,30) S I(100)="^AUPNPAT(",J(100)=9000001 S I(0,0)=D0 S DIP(1)=$S($D(^TIU(8925,D0,0)):^(0),1:"") S X=$P(DIP(1),U,2),X=X S D(0)=+X S D0=D(0) I D0>0 D A1 @@ -38,7 +38,7 @@ A1R ; K J(100),I(100) S:$D(I(0,0)) D0=I(0,0) W ?44 S DIP(1)=$S($D(^TIU(8925,D0,0)):^(0),1:"") S X=$P(DIP(1),U,7) S:X X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3) K DIP K:DN Y W X W ?55 S DIP(1)=$S($D(^TIU(8925,D0,0)):^(0),1:"") S X=$P(DIP(1),U,8) S:X X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3) K DIP K:DN Y W X - W ?66 X DXS(1,9.2) S X1=DIP(1) X "S X=$$NAME^TIULS(X,X1)" K DIP K:DN Y W $E(X,1,15) + W ?66 X DXS(1,9.2) S X1=DIP(1) S X=$$NAME^TIULS(X,X1) K DIP K:DN Y W $E(X,1,15) S X=$G(^TIU(8925,D0,0)) W ?83 S Y=$P(X,U,9) W:Y]"" $S($D(DXS(2,Y)):DXS(2,Y),1:Y) W ?93 S Y=$P(X,U,10),C=1 D A:Y]"" W $E(Y,1,8) W ?103 S Y=$P(X,U,1) S Y(0)=Y S Y=$S($$PNAME^TIULC1(+Y)]"":$$PNAME^TIULC1(+Y),$P(^TIU(8925.1,+Y,0),U,3)]"":$P(^TIU(8925.1,+Y,0),U,3),1:Y) W $E(Y,1,8) diff --git a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUPRPN1.m b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUPRPN1.m index d18b39af..a9ad56b0 100644 --- a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUPRPN1.m +++ b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUPRPN1.m @@ -1,180 +1,180 @@ -TIUPRPN1 ;SLC/JER - Print SF 509-Progress Notes ;11/23/07 - ;;1.0;TEXT INTEGRATION UTILITIES;**45,52,87,100,162,182,211,222,234**;Jun 20, 1997;Build 6 - ; DBIA 908 ^SC(D0,0) -PRINT(TIUFLAG,TIUSPG) ; Print Document - ; ^TMP("TIUPR",$J) is array of records to be printed - ; TIUFLAG=1 --> Chart Copy TIUSPG=1 --> Contiguous - ; TIUFLAG=0 --> Work Copy TIUSPG=0 --> Fresh Page- each note - ; TIUCONT=1 --> Continue printing - ; TIUCONT1=1 --> Write "Continue to next/from previous-page" msgs - ; TIUPFNBR ---> Print Form # like vice 509 - ; TIUMISC=TIUFLAG_U_TIUPFNBR_U_TIUDA - N CONT,TIUASK,TIUI,TIUJ,TIUKID,TIUPAGE,TIUFOOT,TIUK,TIUDA,TIUCONT,TIUPGRP,TIUTYP - N TIUPFHDR,TIUPFNBR,TIUMISC,TIUCONT1,TIUIDONE,TMP - S TIUFLAG=+$G(TIUFLAG),TIUSPG=+$G(TIUSPG) - S (CONT,TIUCONT)=1,(TIUASK,TIUCONT1)=0 - S TIUI=0 F S TIUI=$O(^TMP("TIUPR",$J,TIUI)) Q:TIUI="" D Q:'TIUCONT - . N DFN,TIU - . ; -- P182 TIUI has form PGRP$PFHDR;DFN with PGRP possibly 0, and - . ; PFHDR possibly null (see TIURA): - . S TIUPGRP=+$P(TIUI,"$"),TIUPFHDR=$P($P(TIUI,";"),"$",2) - . I TIUPFHDR']"" S TIUPFHDR="Progress Notes" - . S DFN=$P(TIUI,";",2) - . I $G(TIUPGRP)>2 S TIUSPG=0 - . D PATPN^TIULV(.TIUFOOT,DFN) - . I +$G(TIUSPG) D HEADER^TIUPRPN2(.TIUFOOT,TIUFLAG,.TIUPFHDR,TIUCONT1) - . ; Use TIUJ="" (not TIUJ=0), to print "complete" notes w/o sigdt: - . S TIUJ="" F S TIUJ=$O(^TMP("TIUPR",$J,TIUI,TIUJ)) Q:TIUJ="" D Q:'TIUCONT - . . S TIUK=0 F S TIUK=$O(^TMP("TIUPR",$J,TIUI,TIUJ,TIUK)) Q:'TIUK D Q:'TIUCONT - . . . S TIUCONT1=0 S TIUPFNBR=^TMP("TIUPR",$J,TIUI,TIUJ,TIUK) - . . . ; Note: TIUPFNBR may be null - . . . ;P182 Set TIUMISC BEFORE quitting if deleted - . . . S TIUDA=TIUK,TIUMISC=TIUFLAG_U_TIUPFNBR_U_TIUDA - . . . ; Quit docmt if deleted: - . . . I '$D(^TIU(8925,+TIUDA,0)) D Q - . . . . S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT - . . . . W !!,"NOTE DATED:",!,"Document #",TIUDA," for ",$G(TIUFOOT("PNMP")),!,"no longer exists in the TIU DOCUMENT file.",!!! - . . . . S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) - . . . N TIUROOT - . . . I '+$G(TIUSPG) D HEADER^TIUPRPN2(.TIUFOOT,TIUFLAG,.TIUPFHDR,TIUCONT1) - . . . K ^TMP("TIULQ",$J) - . . . D EXTRACT^TIULQ(+TIUDA,"^TMP(""TIULQ"",$J)",.TIUERR,"","",1) - . . . I +$G(TIUERR) W !,$P(TIUERR,U,2) Q - . . . Q:'$D(^TMP("TIULQ",$J)) - . . . S TIUROOT="^TMP(""TIULQ"",$J,"_TIUDA_")" - . . . D REPORT(TIUROOT,.TIUFOOT,TIUMISC,.TIUCONT) Q:'TIUCONT - . . . D IDKIDS(TIUROOT,.TIUFOOT,TIUMISC,TIUCONT1,.TIUCONT) Q:'TIUCONT - . . . I '+$G(TIUKID),'+$G(TIUSPG) S TIUCONT1=0 S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,1,$G(TIUROOT)) - . Q:'TIUCONT - . I $E(IOST,1,2)="C-" S TIUCONT=$$STOP^TIUPRPN2() Q:'TIUCONT - . I '+$G(TIUKID),+$G(TIUSPG),$E(IOST,1,2)'="C-" S TIUCONT1=0 S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,1,$G(TIUROOT)) - Q - ; -REPORT(TIUROOT,TIUFOOT,TIUMISC,TIUCONT,TIUIDEND) ; Report Text - ; Requires array TIUFOOT, vars TIUMISC, TIUCONT - ; Requires TIUROOT = - ; ^TMP("TIULQ",$J,NOTEIFN) for parent/stand-alone note, or - ; ^TMP("TIULQ",$J,NOTEIFN,"ZADD",ADDMIFN) for addendum, or - ; ^TMP("TIULQ",$J,NOTEIFN,"ZZID",KIDSEQ#,IDKIDIFN) for ID kid, or - ; ^TMP("TIULQ",$J,NOTEIFN,"ZZID",KIDSEQ#,IDKIDIFN,"ZADD",KIDADDMIFN) - ; for ID kid addm. - N DIW,DIWF,DIWL,DIWR,DIWT,TIUERR,TIU,TIUI,X,Z,LOC - N REFDT,TITLE,LOINCNM,ADT,HLOC,SUBJ - N TIUDA,TIUCONT1,HASIDKID,HASIDDAD - S TIUDA=$P(TIUMISC,U,3),TIUCONT1=0 - S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT - S HASIDKID=$G(^TMP("TIULQ",$J,TIUDA,"ZZID",0)) ;how many ID kids - S HASIDDAD=$S(TIUROOT["ZZID":1,1:0) - I HASIDKID W "<< Interdisciplinary Note - Begin >>",! - I HASIDDAD W "<< Interdisciplinary Note - Cont. >>",! - W $S('HASIDKID&'HASIDDAD:"NOTE DATED: ",1:"ENTRY DATED: ") - S REFDT=@TIUROOT@(1301,"I") - W $$DATE^TIULS(REFDT,"MM/DD/CCYY HR:MIN") - S TITLE=@TIUROOT@(.01,"E"),LOINCNM=@TIUROOT@(89261,"E") - W !,"LOCAL TITLE: ",$$UP^XLFSTR(TITLE),! - I $L(LOINCNM)>1 W "STANDARD TITLE: ",$$UP^XLFSTR(LOINCNM),! - S LOC=$G(@TIUROOT@(1205,"I")) - I +LOC D - . W $S($P(^SC(LOC,0),U,3)="W":"ADMITTED: ",1:"VISIT: ") - . S ADT=$G(@TIUROOT@(.07,"I")) - . W $$DATE^TIULS(ADT,"MM/DD/CCYY HR:MIN") - . S HLOC=$G(@TIUROOT@(1205,"E")) - . W " ",HLOC - S SUBJ=$G(@TIUROOT@(1701,"E")) - I SUBJ]"" W !,"SUBJECT: ",^("E"),! ; @TIUROOT@(1701,"E") - S TIUCONT1=1 - I $D(@TIUROOT@("PROBLEM")) D Q:'TIUCONT - . S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT - . W !,"ASSOCIATED PROBLEMS:" - . N TIUI S TIUI=0 - . F S TIUI=$O(@TIUROOT@("PROBLEM",TIUI)) Q:'TIUI D Q:'TIUCONT - ..W !,^(TIUI,0) ; @TIUROOT@("PROBLEM",TIUI,0) - ..S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT - W ! - S TIUI=0,DIWF="WN",DIWL=1,DIWR=79 K ^UTILITY($J,"W") - F S TIUI=$O(@TIUROOT@("TEXT",TIUI)) Q:TIUI'>0 D Q:'TIUCONT ; D ^DIWW - . S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT - . S X=@TIUROOT@("TEXT",TIUI,0) S:X="" X=" " D ^DIWP - D ^DIWW K ^UTILITY($J,"W") - Q:'TIUCONT - D GETSIG(TIUROOT,.TIUSIG) - S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT - W ! - D SIGBLK^TIUPRPN8(.TIUFOOT,TIUMISC,TIUCONT1,.TIUCONT,.TIUSIG,TIUROOT) - Q:'TIUCONT -ADDENDA ; Fall through and do Addenda of docmt TIUDA - N DIW,DIWF,DIWL,DIWR,DIWT,X,Z,TIUI,TIUADD,ADDMRDT - S TIUADD=0,DIWF="WN",DIWL=1,DIWR=79 K ^UTILITY($J,"W") - F S TIUADD=$O(@TIUROOT@("ZADD",TIUADD)) Q:TIUADD'>0 D Q:'TIUCONT - . S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT - . S ADDMRDT=@TIUROOT@("ZADD",TIUADD,1301,"I") - . W !!,$$DATE^TIULS(ADDMRDT,"MM/DD/CCYY HR:MIN"),?21,"ADDENDUM" - . W ?39,"STATUS: ",@TIUROOT@("ZADD",TIUADD,.05,"E") ;P162 - . S TIUI=0 - . F S TIUI=$O(@TIUROOT@("ZADD",TIUADD,"TEXT",TIUI)) Q:TIUI'>0 D Q:'TIUCONT - . . S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT - . . S X=@TIUROOT@("ZADD",TIUADD,"TEXT",TIUI,0) S:X="" X=" " D ^DIWP - . D ^DIWW - . Q:'TIUCONT - . N TIUADRT - . S TIUADRT=$P(TIUROOT,")")_",""ZADD"","_TIUADD_")" - . D GETSIG(TIUADRT,.TIUSIG) - . D SIGBLK^TIUPRPN8(.TIUFOOT,TIUMISC,TIUCONT1,.TIUCONT,.TIUSIG,TIUADRT) - ; Need ! in front for amended notes: - I $G(TIUIDEND) W !,"<< Interdisciplinary Note - End >>",! - K ^UTILITY($J,"W") - ; Write 2 linefeeds between records - S:$E(IOST,1,2)="C-" TIUCONT=$$STOP^TIUFLP1,TIUASK=1 - W:TIUCONT !! - Q - ; -IDKIDS(TIUROOT,TIUFOOT,TIUMISC,TIUCONT1,TIUCONT) ; Print ID kids - ;of docmt TIUDA (each kid does its own addenda) - N TIUL,KIDDA,TIUDA,TIUSORT,TIUIDRT,TIUIDEND - S TIUDA=$P(TIUMISC,U,3),TIUIDEND=0 - S TIUL=0 - F S TIUL=$O(^TMP("TIULQ",$J,TIUDA,"ZZID",TIUL)) Q:'TIUL D Q:'TIUCONT - . S KIDDA=$O(^TMP("TIULQ",$J,TIUDA,"ZZID",TIUL,0)) - . I +$$MEMBEROF^TIUPR222(+$G(^TIU(8925,+KIDDA,0)),"FORM LETTERS") D Q ; hand off to TIUFLP1 (Form Letter Print) - . . I '+$G(TIUKID),'+$G(TIUSPG) S TIUCONT1=0 S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,1,$G(TIUROOT)) - . . I 'TIUCONT!'CONT Q - . . I $E(IOST,1,2)="C-",'+TIUASK S CONT=$$STOP^TIUFLP1,TIUCONT=CONT Q:'+CONT - . . S TIUASK=0,TIUKID=1 D IDKID^TIUFLP1(TIUDA,KIDDA) - . S TIUMISC=TIUFLAG_U_TIUPFNBR_U_KIDDA - . S TIUIDRT="^TMP(""TIULQ"",$J,"_TIUDA_",""ZZID"","_TIUL_","_KIDDA_")" - . I '$O(^TMP("TIULQ",$J,TIUDA,"ZZID",TIUL)) S TIUIDEND=1 - . D REPORT(TIUIDRT,.TIUFOOT,TIUMISC,.TIUCONT,TIUIDEND) - Q - ; -GETSIG(TIUROOT,TIUSIG) ; Get signature info from TIULQ global; - ; Set info into TIUSIG array **100** - ; Requires array name TIUROOT; passes back array TIUSIG - ; TIUROOT = ^TMP("TIULQ",$J,NOTEIFN) for parent note, or - ; ^TMP("TIULQ",$J,NOTEIFN,"ZADD",ADDMIFN) for addendum, or - ; ^TMP("TIULQ",$J,NOTEIFN,"ZZID",IDKIDIFN) for ID kid. - ; Signature should be on bottom of form, Addenda on Subsequent pages - N TIULINE S $P(TIULINE,"-",81)="" - S TIUSIG("AUTHOR")=$G(@TIUROOT@(1202,"I"))_";"_$G(^("E")) - S TIUSIG("EXPSIGNR")=$G(@TIUROOT@(1204,"I"))_";"_$G(^("E")) - S TIUSIG("EXPCOSNR")=$G(@TIUROOT@(1208,"I"))_";"_$G(^("E")) - S TIUSIG("SIGNDATE")=$G(@TIUROOT@(1501,"I")) - S TIUSIG("SIGNEDBY")=$G(@TIUROOT@(1502,"I"))_";"_$G(^("E")) - S TIUSIG("SIGNNAME")=$G(@TIUROOT@(1503,"E")) - S TIUSIG("SIGTITL")=$G(@TIUROOT@(1504,"E")) - S TIUSIG("SIGNMODE")=$G(@TIUROOT@(1505,"I"))_";"_$G(^("E")) - S TIUSIG("COSGDATE")=$G(@TIUROOT@(1507,"I")) - S TIUSIG("COSGEDBY")=$G(@TIUROOT@(1508,"I"))_";"_$G(^("E")) - S TIUSIG("COSGNAME")=$G(@TIUROOT@(1509,"E")) - S TIUSIG("COSGTITL")=$G(@TIUROOT@(1510,"E")) - S TIUSIG("COSGMODE")=$G(@TIUROOT@(1511,"I"))_";"_$G(^("E")) - S TIUSIG("SIGCHRT")=$G(@TIUROOT@(1512,"I"))_";"_$G(^("E")) - S TIUSIG("COSCHRT")=$G(@TIUROOT@(1513,"I"))_";"_$G(^("E")) - ; -- P182 Set Admin Clos Date: - S TIUSIG("ADMINCDT")=$G(@TIUROOT@(1606,"I"))_";"_$G(^("E")) - Q - ; -SETCONT(TIUFOOT,TIUMISC,TIUCONT1,TIUHEAD,TIUROOT) ;Does footer - ;and returns TIUCONT - ; Requires array TIUFOOT, vars TIUMISC,TIUCONT1; optional TIUHEAD - ; Optional TIUROOT - Q $$FOOTER^TIUPRPN2(.TIUFOOT,TIUMISC,TIUCONT1,TIUHEAD,$G(TIUROOT)) +TIUPRPN1 ;SLC/JER - Print SF 509-Progress Notes ;10/5/04 + ;;1.0;TEXT INTEGRATION UTILITIES;**45,52,87,100,162,182,211,222**;Jun 20, 1997 + ; DBIA 908 ^SC(D0,0) +PRINT(TIUFLAG,TIUSPG) ; Print Document + ; ^TMP("TIUPR",$J) is array of records to be printed + ; TIUFLAG=1 --> Chart Copy TIUSPG=1 --> Contiguous + ; TIUFLAG=0 --> Work Copy TIUSPG=0 --> Fresh Page- each note + ; TIUCONT=1 --> Continue printing + ; TIUCONT1=1 --> Write "Continue to next/from previous-page" msgs + ; TIUPFNBR ---> Print Form # like vice 509 + ; TIUMISC=TIUFLAG_U_TIUPFNBR_U_TIUDA + N CONT,TIUASK,TIUI,TIUJ,TIUKID,TIUPAGE,TIUFOOT,TIUK,TIUDA,TIUCONT,TIUPGRP,TIUTYP + N TIUPFHDR,TIUPFNBR,TIUMISC,TIUCONT1,TIUIDONE,TMP + S TIUFLAG=+$G(TIUFLAG),TIUSPG=+$G(TIUSPG) + S (CONT,TIUCONT)=1,(TIUASK,TIUCONT1)=0 + S TIUI=0 F S TIUI=$O(^TMP("TIUPR",$J,TIUI)) Q:TIUI="" D Q:'TIUCONT + . N DFN,TIU + . ; -- P182 TIUI has form PGRP$PFHDR;DFN with PGRP possibly 0, and + . ; PFHDR possibly null (see TIURA): + . S TIUPGRP=+$P(TIUI,"$"),TIUPFHDR=$P($P(TIUI,";"),"$",2) + . I TIUPFHDR']"" S TIUPFHDR="Progress Notes" + . S DFN=$P(TIUI,";",2) + . I $G(TIUPGRP)>2 S TIUSPG=0 + . D PATPN^TIULV(.TIUFOOT,DFN) + . I +$G(TIUSPG) D HEADER^TIUPRPN2(.TIUFOOT,TIUFLAG,.TIUPFHDR,TIUCONT1) + . ; Use TIUJ="" (not TIUJ=0), to print "complete" notes w/o sigdt: + . S TIUJ="" F S TIUJ=$O(^TMP("TIUPR",$J,TIUI,TIUJ)) Q:TIUJ="" D Q:'TIUCONT + . . S TIUK=0 F S TIUK=$O(^TMP("TIUPR",$J,TIUI,TIUJ,TIUK)) Q:'TIUK D Q:'TIUCONT + . . . S TIUCONT1=0 S TIUPFNBR=^TMP("TIUPR",$J,TIUI,TIUJ,TIUK) + . . . ; Note: TIUPFNBR may be null + . . . ;P182 Set TIUMISC BEFORE quitting if deleted + . . . S TIUDA=TIUK,TIUMISC=TIUFLAG_U_TIUPFNBR_U_TIUDA + . . . ; Quit docmt if deleted: + . . . I '$D(^TIU(8925,+TIUDA,0)) D Q + . . . . S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT + . . . . W !!,"NOTE DATED:",!,"Document #",TIUDA," for ",$G(TIUFOOT("PNMP")),!,"no longer exists in the TIU DOCUMENT file.",!!! + . . . . S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) + . . . N TIUROOT + . . . I '+$G(TIUSPG) D HEADER^TIUPRPN2(.TIUFOOT,TIUFLAG,.TIUPFHDR,TIUCONT1) + . . . K ^TMP("TIULQ",$J) + . . . D EXTRACT^TIULQ(+TIUDA,"^TMP(""TIULQ"",$J)",.TIUERR,"","",1) + . . . I +$G(TIUERR) W !,$P(TIUERR,U,2) Q + . . . Q:'$D(^TMP("TIULQ",$J)) + . . . S TIUROOT="^TMP(""TIULQ"",$J,"_TIUDA_")" + . . . D REPORT(TIUROOT,.TIUFOOT,TIUMISC,.TIUCONT) Q:'TIUCONT + . . . D IDKIDS(TIUROOT,.TIUFOOT,TIUMISC,TIUCONT1,.TIUCONT) Q:'TIUCONT + . . . I '+$G(TIUKID),'+$G(TIUSPG) S TIUCONT1=0 S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,1,$G(TIUROOT)) + . Q:'TIUCONT + . I $E(IOST,1,2)="C-" S TIUCONT=$$STOP^TIUPRPN2() Q:'TIUCONT + . I '+$G(TIUKID),+$G(TIUSPG),$E(IOST,1,2)'="C-" S TIUCONT1=0 S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,1,$G(TIUROOT)) + Q + ; +REPORT(TIUROOT,TIUFOOT,TIUMISC,TIUCONT,TIUIDEND) ; Report Text + ; Requires array TIUFOOT, vars TIUMISC, TIUCONT + ; Requires TIUROOT = + ; ^TMP("TIULQ",$J,NOTEIFN) for parent/stand-alone note, or + ; ^TMP("TIULQ",$J,NOTEIFN,"ZADD",ADDMIFN) for addendum, or + ; ^TMP("TIULQ",$J,NOTEIFN,"ZZID",KIDSEQ#,IDKIDIFN) for ID kid, or + ; ^TMP("TIULQ",$J,NOTEIFN,"ZZID",KIDSEQ#,IDKIDIFN,"ZADD",KIDADDMIFN) + ; for ID kid addm. + N DIW,DIWF,DIWL,DIWR,DIWT,TIUERR,TIU,TIUI,X,Z,LOC + N REFDT,TITLE,LOINCNM,ADT,HLOC,SUBJ + N TIUDA,TIUCONT1,HASIDKID,HASIDDAD + S TIUDA=$P(TIUMISC,U,3),TIUCONT1=0 + S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT + S HASIDKID=$G(^TMP("TIULQ",$J,TIUDA,"ZZID",0)) ;how many ID kids + S HASIDDAD=$S(TIUROOT["ZZID":1,1:0) + I HASIDKID W "<< Interdisciplinary Note - Begin >>",! + I HASIDDAD W "<< Interdisciplinary Note - Cont. >>",! + W $S('HASIDKID&'HASIDDAD:"NOTE DATED: ",1:"ENTRY DATED: ") + S REFDT=@TIUROOT@(1301,"I") + W $$DATE^TIULS(REFDT,"MM/DD/CCYY HR:MIN") + S TITLE=@TIUROOT@(.01,"E") ; ,LOINCNM=@TIUROOT@(89261,"E") + W !,"LOCAL TITLE: ",$$UP^XLFSTR(TITLE),! + ; I $L(LOINCNM)>1 W "STANDARD TITLE: ",$$UP^XLFSTR(LOINCNM),! + S LOC=$G(@TIUROOT@(1205,"I")) + I +LOC D + . W $S($P(^SC(LOC,0),U,3)="W":"ADMITTED: ",1:"VISIT: ") + . S ADT=$G(@TIUROOT@(.07,"I")) + . W $$DATE^TIULS(ADT,"MM/DD/CCYY HR:MIN") + . S HLOC=$G(@TIUROOT@(1205,"E")) + . W " ",HLOC + S SUBJ=$G(@TIUROOT@(1701,"E")) + I SUBJ]"" W !,"SUBJECT: ",^("E"),! + S TIUCONT1=1 + I $D(@TIUROOT@("PROBLEM")) D Q:'TIUCONT + . S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT + . W !,"ASSOCIATED PROBLEMS:" + . N TIUI S TIUI=0 + . F S TIUI=$O(@TIUROOT@("PROBLEM",TIUI)) Q:'TIUI D Q:'TIUCONT + ..W !,^(TIUI,0) + ..S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT + W ! + S TIUI=0,DIWF="WN",DIWL=1,DIWR=79 K ^UTILITY($J,"W") + F S TIUI=$O(@TIUROOT@("TEXT",TIUI)) Q:TIUI'>0 D Q:'TIUCONT ; D ^DIWW + . S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT + . S X=@TIUROOT@("TEXT",TIUI,0) S:X="" X=" " D ^DIWP + D ^DIWW K ^UTILITY($J,"W") + Q:'TIUCONT + D GETSIG(TIUROOT,.TIUSIG) + S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT + W ! + D SIGBLK^TIUPRPN8(.TIUFOOT,TIUMISC,TIUCONT1,.TIUCONT,.TIUSIG,TIUROOT) + Q:'TIUCONT +ADDENDA ; Fall through and do Addenda of docmt TIUDA + N DIW,DIWF,DIWL,DIWR,DIWT,X,Z,TIUI,TIUADD,ADDMRDT + S TIUADD=0,DIWF="WN",DIWL=1,DIWR=79 K ^UTILITY($J,"W") + F S TIUADD=$O(@TIUROOT@("ZADD",TIUADD)) Q:TIUADD'>0 D Q:'TIUCONT + . S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT + . S ADDMRDT=@TIUROOT@("ZADD",TIUADD,1301,"I") + . W !!,$$DATE^TIULS(ADDMRDT,"MM/DD/CCYY HR:MIN"),?21,"ADDENDUM" + . W ?39,"STATUS: ",@TIUROOT@("ZADD",TIUADD,.05,"E") ;P162 + . S TIUI=0 + . F S TIUI=$O(@TIUROOT@("ZADD",TIUADD,"TEXT",TIUI)) Q:TIUI'>0 D Q:'TIUCONT + . . S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT + . . S X=@TIUROOT@("ZADD",TIUADD,"TEXT",TIUI,0) S:X="" X=" " D ^DIWP + . D ^DIWW + . Q:'TIUCONT + . N TIUADRT + . S TIUADRT=$P(TIUROOT,")")_",""ZADD"","_TIUADD_")" + . D GETSIG(TIUADRT,.TIUSIG) + . D SIGBLK^TIUPRPN8(.TIUFOOT,TIUMISC,TIUCONT1,.TIUCONT,.TIUSIG,TIUADRT) + ; Need ! in front for amended notes: + I $G(TIUIDEND) W !,"<< Interdisciplinary Note - End >>",! + K ^UTILITY($J,"W") + ; Write 2 linefeeds between records + S:$E(IOST,1,2)="C-" TIUCONT=$$STOP^TIUFLP1,TIUASK=1 + W:TIUCONT !! + Q + ; +IDKIDS(TIUROOT,TIUFOOT,TIUMISC,TIUCONT1,TIUCONT) ; Print ID kids + ;of docmt TIUDA (each kid does its own addenda) + N TIUL,KIDDA,TIUDA,TIUSORT,TIUIDRT,TIUIDEND + S TIUDA=$P(TIUMISC,U,3),TIUIDEND=0 + S TIUL=0 + F S TIUL=$O(^TMP("TIULQ",$J,TIUDA,"ZZID",TIUL)) Q:'TIUL D Q:'TIUCONT + . S KIDDA=$O(^TMP("TIULQ",$J,TIUDA,"ZZID",TIUL,0)) + . I +$$MEMBEROF^TIUPR222(+$G(^TIU(8925,+KIDDA,0)),"FORM LETTERS") D Q ; hand off to TIUFLP1 (Form Letter Print) + . . I '+$G(TIUKID),'+$G(TIUSPG) S TIUCONT1=0 S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,1,$G(TIUROOT)) + . . I 'TIUCONT!'CONT Q + . . I $E(IOST,1,2)="C-",'+TIUASK S CONT=$$STOP^TIUFLP1,TIUCONT=CONT Q:'+CONT + . . S TIUASK=0,TIUKID=1 D IDKID^TIUFLP1(TIUDA,KIDDA) + . S TIUMISC=TIUFLAG_U_TIUPFNBR_U_KIDDA + . S TIUIDRT="^TMP(""TIULQ"",$J,"_TIUDA_",""ZZID"","_TIUL_","_KIDDA_")" + . I '$O(^TMP("TIULQ",$J,TIUDA,"ZZID",TIUL)) S TIUIDEND=1 + . D REPORT(TIUIDRT,.TIUFOOT,TIUMISC,.TIUCONT,TIUIDEND) + Q + ; +GETSIG(TIUROOT,TIUSIG) ; Get signature info from TIULQ global; + ; Set info into TIUSIG array **100** + ; Requires array name TIUROOT; passes back array TIUSIG + ; TIUROOT = ^TMP("TIULQ",$J,NOTEIFN) for parent note, or + ; ^TMP("TIULQ",$J,NOTEIFN,"ZADD",ADDMIFN) for addendum, or + ; ^TMP("TIULQ",$J,NOTEIFN,"ZZID",IDKIDIFN) for ID kid. + ; Signature should be on bottom of form, Addenda on Subsequent pages + N TIULINE S $P(TIULINE,"-",81)="" + S TIUSIG("AUTHOR")=$G(@TIUROOT@(1202,"I"))_";"_$G(^("E")) + S TIUSIG("EXPSIGNR")=$G(@TIUROOT@(1204,"I"))_";"_$G(^("E")) + S TIUSIG("EXPCOSNR")=$G(@TIUROOT@(1208,"I"))_";"_$G(^("E")) + S TIUSIG("SIGNDATE")=$G(@TIUROOT@(1501,"I")) + S TIUSIG("SIGNEDBY")=$G(@TIUROOT@(1502,"I"))_";"_$G(^("E")) + S TIUSIG("SIGNNAME")=$G(@TIUROOT@(1503,"E")) + S TIUSIG("SIGTITL")=$G(@TIUROOT@(1504,"E")) + S TIUSIG("SIGNMODE")=$G(@TIUROOT@(1505,"I"))_";"_$G(^("E")) + S TIUSIG("COSGDATE")=$G(@TIUROOT@(1507,"I")) + S TIUSIG("COSGEDBY")=$G(@TIUROOT@(1508,"I"))_";"_$G(^("E")) + S TIUSIG("COSGNAME")=$G(@TIUROOT@(1509,"E")) + S TIUSIG("COSGTITL")=$G(@TIUROOT@(1510,"E")) + S TIUSIG("COSGMODE")=$G(@TIUROOT@(1511,"I"))_";"_$G(^("E")) + S TIUSIG("SIGCHRT")=$G(@TIUROOT@(1512,"I"))_";"_$G(^("E")) + S TIUSIG("COSCHRT")=$G(@TIUROOT@(1513,"I"))_";"_$G(^("E")) + ; -- P182 Set Admin Clos Date: + S TIUSIG("ADMINCDT")=$G(@TIUROOT@(1606,"I"))_";"_$G(^("E")) + Q + ; +SETCONT(TIUFOOT,TIUMISC,TIUCONT1,TIUHEAD,TIUROOT) ;Does footer + ;and returns TIUCONT + ; Requires array TIUFOOT, vars TIUMISC,TIUCONT1; optional TIUHEAD + ; Optional TIUROOT + Q $$FOOTER^TIUPRPN2(.TIUFOOT,TIUMISC,TIUCONT1,TIUHEAD,$G(TIUROOT)) diff --git a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUPRPN8.m b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUPRPN8.m index 2a7462f3..181daccb 100644 --- a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUPRPN8.m +++ b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUPRPN8.m @@ -1,116 +1,114 @@ -TIUPRPN8 ;SLC/MAM - Print SF 509-Progress Notes, Cont ;11/10/04 [1/4/05 12:17pm] - ;;1.0;TEXT INTEGRATION UTILITIES;**100,176,157,182,224**;Jun 20, 1997;Build 7 - ; -SIGBLK(TIUFOOT,TIUMISC,TIUCONT1,TIUCONT,TIUSIG,TIUROOT) ; Print signature block info - ; Requires array TIUFOOT, requires TIUMISC - ; Requires TIUCONT1 - ; Receives TIUCONT by ref (req'd) - ; Receives array TIUSIG by ref, required. - ; Requires TIUROOT - N TIUDA,TIUFLAG - S TIUCONT=1,TIUDA=$P(TIUMISC,U,3),TIUFLAG=$P(TIUMISC,U) - ;S TIUGROOT=$NA(^TMP("TIULQ",$J,TIUDA)) - ; -- P182 Don't marked admin signed notes as draft: - I '+TIUSIG("SIGNDATE"),'+TIUSIG("ADMINCDT") D Q:'TIUCONT - . W "**DRAFT COPY - DRAFT COPY -- ABOVE NOTE IS UNSIGNED--" - . W " DRAFT COPY - DRAFT COPY**",! - . S TIUCONT=$$SETCONT^TIUPRPN1(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) - ;I TIUSIG("SIGNEDBY")]"",(+TIUSIG("SIGNEDBY")'=+TIUSIG("AUTHOR")) D - ;. W ?21,"Author: ",$P(TIUSIG("AUTHOR"),";",2),! - I +TIUSIG("SIGNDATE") D Q:'TIUCONT - . S TIUCONT=$$SETCONT^TIUPRPN1(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT - . W ?18,"Signed by:",$S($P(TIUSIG("SIGNMODE"),";")="C":" /s/ ",1:" /es/ "),?34,$S(TIUSIG("SIGNNAME")]"":TIUSIG("SIGNNAME"),1:$P(TIUSIG("SIGNEDBY"),";",2)) - . I $L(TIUSIG("SIGTITL"))>45 D - . . N TIUFT - . . D WRAP^TIUFLD(TIUSIG("SIGTITL"),45) - . . W !?34,$G(TIUFT(1)) - . . W !?39,$G(TIUFT(2)) - . I $L(TIUSIG("SIGTITL"))<46,TIUSIG("SIGTITL")]"" W !?34,TIUSIG("SIGTITL") - . W !?34,$$DATE^TIULS(+TIUSIG("SIGNDATE"),"MM/DD/CCYY HR:MIN") - . I '+$G(TIUFLAG)!($E(IOST)="C-") D - . . I $P($$BEEP^TIULC1(+TIUSIG("SIGNEDBY")),U) W !?34,"Analog Pager: ",$P($$BEEP^TIULC1(+TIUSIG("SIGNEDBY")),U) - . . I $P($$BEEP^TIULC1(+TIUSIG("SIGNEDBY")),U,2) W !?34,"Digital Pager: ",$P($$BEEP^TIULC1(+TIUSIG("SIGNEDBY")),U,2) - I $P(TIUSIG("SIGNMODE"),";")="C" D Q:'TIUCONT - . S TIUCONT=$$SETCONT^TIUPRPN1(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT - . N TIUONCH - . S TIUONCH=$P(TIUSIG("SIGCHRT"),";",2) - . I TIUONCH']"" S TIUONCH=$P(TIUSIG("COSCHRT"),";",2) - . W !?2,"Marked signed on chart by:",?34,$G(TIUONCH) - ; -- If signer is not author, write "for the author": - ; P182 SIGNEDBY may =";" and follow null even when no signer: - ;I TIUSIG("SIGNEDBY")]"",(+TIUSIG("SIGNEDBY")'=+TIUSIG("AUTHOR")) D - I TIUSIG("SIGNEDBY")]"",(TIUSIG("SIGNEDBY")'=";"),(+TIUSIG("SIGNEDBY")'=+TIUSIG("AUTHOR")) D - . N TIUSIGTL - . W !?34,"for ",$P(TIUSIG("AUTHOR"),";",2) - . S TIUSIGTL=$$GET1^DIQ(200,$P(TIUSIG("AUTHOR"),";",1),20.3) - . I $D(TIUSIGTL) D - . . N TIUFT - . . D WRAP^TIUFLD(TIUSIGTL,45) - . . W !?34,$G(TIUFT(1)) - . . W !?39,$G(TIUFT(2)) - I $G(@TIUROOT@(.05,"E"))="UNCOSIGNED" D - . W !?34,"**REQUIRES COSIGNATURE**",! - ;I +$G(TIUADD) S TIUGROOT=$NA(^TMP("TIULQ",$J,TIUDA,"ZADD",TIUADD)) - I +$D(@TIUROOT@("EXTRASGNR")) D Q:'TIUCONT ;**100** added the quit - . N TIUI S TIUI=0 - . S TIUCONT=$$SETCONT^TIUPRPN1(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT - . F S TIUI=$O(@TIUROOT@("EXTRASGNR",TIUI)) Q:'TIUI D - . . W !!?4,"Receipt Acknowledged By:" - . . ;VMP/ELR P224 ADDED code to print awaiting signature and expected additional signer name - . . I +$G(@TIUROOT@("EXTRASGNR",TIUI,"DATE"))'>0 D Q - . . . W !,?4,"* AWAITING SIGNATURE *",?30,$G(@TIUROOT@("EXTRASGNR",TIUI,"EXPNAME")) - . . I TIUI>1 S TIUCONT=$$SETCONT^TIUPRPN1(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT - . . W !?29,"/es/ ",$G(@TIUROOT@("EXTRASGNR",TIUI,"NAME")) - . . I $L($G(@TIUROOT@("EXTRASGNR",TIUI,"TITLE")))>45 D - . . . N TIUFT - . . . D WRAP^TIUFLD($G(@TIUROOT@("EXTRASGNR",TIUI,"TITLE")),45) - . . . W !?34,$G(TIUFT(1)) - . . . W !?39,$G(TIUFT(2)) - . . I $L($G(@TIUROOT@("EXTRASGNR",TIUI,"TITLE")))<46 W !?34,$G(@TIUROOT@("EXTRASGNR",TIUI,"TITLE")) - . . I $G(@TIUROOT@("EXTRASGNR",TIUI,"EXTRA")),$G(@TIUROOT@("EXTRASGNR",TIUI,"EXPIEN"))'=$G(@TIUROOT@("EXTRASGNR",TIUI,"EXTRA")) D - . . . W !?30,"for ",$P($G(@TIUROOT@("EXTRASGNR",TIUI,"EXPNAME")),",",2) - . . . W " ",$P($G(@TIUROOT@("EXTRASGNR",TIUI,"EXPNAME")),",") - . . W !?34,$$DATE^TIULS($G(@TIUROOT@("EXTRASGNR",TIUI,"DATE")),"MM/DD/CCYY HR:MIN") - . . I '+$G(TIUFLAG)!($E(IOST)="C-") D - . . . N BEEP - . . . S BEEP=$$BEEP^TIULC1(+$G(@TIUROOT@("EXTRASGNR",TIUI,"EXTRA"))) - . . . I +BEEP W !?34,"Analog Pager: ",$P(BEEP,U) - . . . I +$P(BEEP,U,2) W !?34,"Digital Pager: ",$P(BEEP,U,2) - . ;K @TIUROOT@("EXTRASGNR") ;**100** commented out - ;I +TIUSIG("COSGDATE"),(+TIUSIG("COSGEDBY")'=+TIUSIG("SIGNEDBY")) D Q:'TIUCONT - I +TIUSIG("COSGDATE") D Q:'TIUCONT - . S TIUCONT=$$SETCONT^TIUPRPN1(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT - . W !!?16,"Cosigned by:",$S($P(TIUSIG("COSGMODE"),";")="C":" /s/ ",1:" /es/ "),?34,$S(TIUSIG("COSGNAME")]"":TIUSIG("COSGNAME"),1:$P(TIUSIG("COSGEDBY"),";",2)) - . I $L(TIUSIG("COSGTITL"))>45 D - . . N TIUFT - . . D WRAP^TIUFLD(TIUSIG("COSGTITL"),45) - . . W !?34,$G(TIUFT(1)) - . . W !?39,$G(TIUFT(2)) - . I $L(TIUSIG("COSGTITL"))<46 W !?34,TIUSIG("COSGTITL") - . W !?34,$$DATE^TIULS(+TIUSIG("COSGDATE"),"MM/DD/CCYY HR:MIN") - . I '+$G(TIUFLAG)!($E(IOST)="C-") D - . . I $P($$BEEP^TIULC1(+TIUSIG("COSGEDBY")),U) W !?34,"Analog Pager: ",$P($$BEEP^TIULC1(+TIUSIG("COSGEDBY")),U) - . . I $P($$BEEP^TIULC1(+TIUSIG("COSGEDBY")),U,2) W !?34,"Digital Pager: ",$P($$BEEP^TIULC1(+TIUSIG("COSGEDBY")),U,2) - ;I +TIUSIG("COSCHRT"),$P(TIUSIG("COSGMODE"),";")="C" D Q:'TIUCONT - I $P(TIUSIG("COSGMODE"),";")="C" D Q:'TIUCONT - . S TIUCONT=$$SETCONT^TIUPRPN1(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT - . W !,"Marked cosigned on chart by:",?34,$P(TIUSIG("COSCHRT"),";",2) - W ! - ;K TIUCONT1 ; kills the cont on next page msgs since no longer in middle - ;of a note. **100** moved down to amend code -AMEND ; signature blocks of amender - ;N TIUY S TIUY=4 ;I don't think we need TIUY anymore **100** - I '$G(@TIUROOT@(1601,"I")) K TIUCONT1 Q - S TIUCONT=$$SETCONT^TIUPRPN1(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) - K TIUCONT1 Q:'TIUCONT - I +$G(@TIUROOT@(1601,"I")) D - . W !!?12,"Amendment Filed:",?34,$$DATE^TIULS(@TIUROOT@(1601,"I"),"MM/DD/CCYY HR:MIN") - . I $G(@TIUROOT@(1603,"E"))']"" D - . . W !!?29 F TIUI=1:1:40 W "_" - . . W !?29,$$SIGNAME^TIULS(@TIUROOT@(1602,"I")) - . . W !?29,$$SIGTITL^TIULS(@TIUROOT@(1602,"I")) - . I $G(@TIUROOT@(1604,"E"))]"" D - . . W !?29,"/es/",?34,@TIUROOT@(1604,"E") - . . W !?34,@TIUROOT@(1605,"E") - Q - ; +TIUPRPN8 ;SLC/MAM - Print SF 509-Progress Notes, Cont ;11/10/04 [1/4/05 12:17pm] + ;;1.0;TEXT INTEGRATION UTILITIES;**100,176,157,182**;Jun 20, 1997 + ; +SIGBLK(TIUFOOT,TIUMISC,TIUCONT1,TIUCONT,TIUSIG,TIUROOT) ; Print signature block info + ; Requires array TIUFOOT, requires TIUMISC + ; Requires TIUCONT1 + ; Receives TIUCONT by ref (req'd) + ; Receives array TIUSIG by ref, required. + ; Requires TIUROOT + N TIUDA,TIUFLAG + S TIUCONT=1,TIUDA=$P(TIUMISC,U,3),TIUFLAG=$P(TIUMISC,U) + ;S TIUGROOT=$NA(^TMP("TIULQ",$J,TIUDA)) + ; -- P182 Don't marked admin signed notes as draft: + I '+TIUSIG("SIGNDATE"),'+TIUSIG("ADMINCDT") D Q:'TIUCONT + . W "**DRAFT COPY - DRAFT COPY -- ABOVE NOTE IS UNSIGNED--" + . W " DRAFT COPY - DRAFT COPY**",! + . S TIUCONT=$$SETCONT^TIUPRPN1(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) + ;I TIUSIG("SIGNEDBY")]"",(+TIUSIG("SIGNEDBY")'=+TIUSIG("AUTHOR")) D + ;. W ?21,"Author: ",$P(TIUSIG("AUTHOR"),";",2),! + I +TIUSIG("SIGNDATE") D Q:'TIUCONT + . S TIUCONT=$$SETCONT^TIUPRPN1(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT + . W ?18,"Signed by:",$S($P(TIUSIG("SIGNMODE"),";")="C":" /s/ ",1:" /es/ "),?34,$S(TIUSIG("SIGNNAME")]"":TIUSIG("SIGNNAME"),1:$P(TIUSIG("SIGNEDBY"),";",2)) + . I $L(TIUSIG("SIGTITL"))>45 D + . . N TIUFT + . . D WRAP^TIUFLD(TIUSIG("SIGTITL"),45) + . . W !?34,$G(TIUFT(1)) + . . W !?39,$G(TIUFT(2)) + . I $L(TIUSIG("SIGTITL"))<46,TIUSIG("SIGTITL")]"" W !?34,TIUSIG("SIGTITL") + . W !?34,$$DATE^TIULS(+TIUSIG("SIGNDATE"),"MM/DD/CCYY HR:MIN") + . I '+$G(TIUFLAG)!($E(IOST)="C-") D + . . I $P($$BEEP^TIULC1(+TIUSIG("SIGNEDBY")),U) W !?34,"Analog Pager: ",$P($$BEEP^TIULC1(+TIUSIG("SIGNEDBY")),U) + . . I $P($$BEEP^TIULC1(+TIUSIG("SIGNEDBY")),U,2) W !?34,"Digital Pager: ",$P($$BEEP^TIULC1(+TIUSIG("SIGNEDBY")),U,2) + I $P(TIUSIG("SIGNMODE"),";")="C" D Q:'TIUCONT + . S TIUCONT=$$SETCONT^TIUPRPN1(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT + . N TIUONCH + . S TIUONCH=$P(TIUSIG("SIGCHRT"),";",2) + . I TIUONCH']"" S TIUONCH=$P(TIUSIG("COSCHRT"),";",2) + . W !?2,"Marked signed on chart by:",?34,$G(TIUONCH) + ; -- If signer is not author, write "for the author": + ; P182 SIGNEDBY may =";" and follow null even when no signer: + ;I TIUSIG("SIGNEDBY")]"",(+TIUSIG("SIGNEDBY")'=+TIUSIG("AUTHOR")) D + I TIUSIG("SIGNEDBY")]"",(TIUSIG("SIGNEDBY")'=";"),(+TIUSIG("SIGNEDBY")'=+TIUSIG("AUTHOR")) D + . N TIUSIGTL + . W !?34,"for ",$P(TIUSIG("AUTHOR"),";",2) + . S TIUSIGTL=$$GET1^DIQ(200,$P(TIUSIG("AUTHOR"),";",1),20.3) + . I $D(TIUSIGTL) D + . . N TIUFT + . . D WRAP^TIUFLD(TIUSIGTL,45) + . . W !?34,$G(TIUFT(1)) + . . W !?39,$G(TIUFT(2)) + I $G(@TIUROOT@(.05,"E"))="UNCOSIGNED" D + . W !?34,"**REQUIRES COSIGNATURE**",! + ;I +$G(TIUADD) S TIUGROOT=$NA(^TMP("TIULQ",$J,TIUDA,"ZADD",TIUADD)) + I +$D(@TIUROOT@("EXTRASGNR")) D Q:'TIUCONT ;**100** added the quit + . N TIUI S TIUI=0 + . S TIUCONT=$$SETCONT^TIUPRPN1(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT + . W !?4,"Receipt Acknowledged By:" + . F S TIUI=$O(@TIUROOT@("EXTRASGNR",TIUI)) Q:'TIUI D + . . I +$G(@TIUROOT@("EXTRASGNR",TIUI,"DATE"))'>0 Q + . . I TIUI>1 S TIUCONT=$$SETCONT^TIUPRPN1(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT + . . W !?29,"/es/ ",$G(@TIUROOT@("EXTRASGNR",TIUI,"NAME")) + . . I $L($G(@TIUROOT@("EXTRASGNR",TIUI,"TITLE")))>45 D + . . . N TIUFT + . . . D WRAP^TIUFLD($G(@TIUROOT@("EXTRASGNR",TIUI,"TITLE")),45) + . . . W !?34,$G(TIUFT(1)) + . . . W !?39,$G(TIUFT(2)) + . . I $L($G(@TIUROOT@("EXTRASGNR",TIUI,"TITLE")))<46 W !?34,$G(@TIUROOT@("EXTRASGNR",TIUI,"TITLE")) + . . I $G(@TIUROOT@("EXTRASGNR",TIUI,"EXTRA")),$G(@TIUROOT@("EXTRASGNR",TIUI,"EXPIEN"))'=$G(@TIUROOT@("EXTRASGNR",TIUI,"EXTRA")) D + . . . W !?30,"for ",$P($G(@TIUROOT@("EXTRASGNR",TIUI,"EXPNAME")),",",2) + . . . W " ",$P($G(@TIUROOT@("EXTRASGNR",TIUI,"EXPNAME")),",") + . . W !?34,$$DATE^TIULS($G(@TIUROOT@("EXTRASGNR",TIUI,"DATE")),"MM/DD/CCYY HR:MIN") + . . I '+$G(TIUFLAG)!($E(IOST)="C-") D + . . . N BEEP + . . . S BEEP=$$BEEP^TIULC1(+$G(@TIUROOT@("EXTRASGNR",TIUI,"EXTRA"))) + . . . I +BEEP W !?34,"Analog Pager: ",$P(BEEP,U) + . . . I +$P(BEEP,U,2) W !?34,"Digital Pager: ",$P(BEEP,U,2) + . ;K @TIUROOT@("EXTRASGNR") ;**100** commented out + ;I +TIUSIG("COSGDATE"),(+TIUSIG("COSGEDBY")'=+TIUSIG("SIGNEDBY")) D Q:'TIUCONT + I +TIUSIG("COSGDATE") D Q:'TIUCONT + . S TIUCONT=$$SETCONT^TIUPRPN1(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT + . W !!?16,"Cosigned by:",$S($P(TIUSIG("COSGMODE"),";")="C":" /s/ ",1:" /es/ "),?34,$S(TIUSIG("COSGNAME")]"":TIUSIG("COSGNAME"),1:$P(TIUSIG("COSGEDBY"),";",2)) + . I $L(TIUSIG("COSGTITL"))>45 D + . . N TIUFT + . . D WRAP^TIUFLD(TIUSIG("COSGTITL"),45) + . . W !?34,$G(TIUFT(1)) + . . W !?39,$G(TIUFT(2)) + . I $L(TIUSIG("COSGTITL"))<46 W !?34,TIUSIG("COSGTITL") + . W !?34,$$DATE^TIULS(+TIUSIG("COSGDATE"),"MM/DD/CCYY HR:MIN") + . I '+$G(TIUFLAG)!($E(IOST)="C-") D + . . I $P($$BEEP^TIULC1(+TIUSIG("COSGEDBY")),U) W !?34,"Analog Pager: ",$P($$BEEP^TIULC1(+TIUSIG("COSGEDBY")),U) + . . I $P($$BEEP^TIULC1(+TIUSIG("COSGEDBY")),U,2) W !?34,"Digital Pager: ",$P($$BEEP^TIULC1(+TIUSIG("COSGEDBY")),U,2) + ;I +TIUSIG("COSCHRT"),$P(TIUSIG("COSGMODE"),";")="C" D Q:'TIUCONT + I $P(TIUSIG("COSGMODE"),";")="C" D Q:'TIUCONT + . S TIUCONT=$$SETCONT^TIUPRPN1(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT + . W !,"Marked cosigned on chart by:",?34,$P(TIUSIG("COSCHRT"),";",2) + W ! + ;K TIUCONT1 ; kills the cont on next page msgs since no longer in middle + ;of a note. **100** moved down to amend code +AMEND ; signature blocks of amender + ;N TIUY S TIUY=4 ;I don't think we need TIUY anymore **100** + I '$G(@TIUROOT@(1601,"I")) K TIUCONT1 Q + S TIUCONT=$$SETCONT^TIUPRPN1(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) + K TIUCONT1 Q:'TIUCONT + I +$G(@TIUROOT@(1601,"I")) D + . W !!?12,"Amendment Filed:",?34,$$DATE^TIULS(@TIUROOT@(1601,"I"),"MM/DD/CCYY HR:MIN") + . I $G(@TIUROOT@(1603,"E"))']"" D + . . W !!?29 F TIUI=1:1:40 W "_" + . . W !?29,$$SIGNAME^TIULS(@TIUROOT@(1602,"I")) + . . W !?29,$$SIGTITL^TIULS(@TIUROOT@(1602,"I")) + . I $G(@TIUROOT@(1604,"E"))]"" D + . . W !?29,"/es/",?34,@TIUROOT@(1604,"E") + . . W !?34,@TIUROOT@(1605,"E") + Q + ; diff --git a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUR.m b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUR.m index c964b868..927dd4f4 100644 --- a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUR.m +++ b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUR.m @@ -1,156 +1,153 @@ -TIUR ; SLC/JER - Integrated Document Review ;11/01/03 - ;;1.0;TEXT INTEGRATION UTILITIES;**74,79,58,100,113,112,207,224**;Jun 20, 1997;Build 7 - ; 11/30/00 Moved PUTLIST & ADDELMNT to TIUR1 -MAKELIST(TIUCLASS,TIUCHVW) ; Get Search Criteria - N DIRUT,DTOUT,DUOUT,TIUI,SCREEN,STATUS,TIUTYP,TIUSTAT,TIUEDFLT,TIUDCL - N TIUDPRMT,TIUPICT,TIUOUT,STATWORD,STATIFN,NOWFLAG,TIUSC207,TIU1DOC - K DIROUT - D INITRR^TIULRR(0) - ; TIURPN used in Order Entry 2.5, OR OE/RR MENU CLIN: - I +$G(ORVP),(+$G(TIUCHVW)'>0) D EN^TIURPN(TIUCLASS,+ORVP) Q -STATUS S STATUS=$$STAT - ;VMP/ELR changed status ck from <0 TO <1 to account for entering an * p224 - I +STATUS<1 S VALMQUIT=1 Q - S TIUI=0 - F S TIUI=$O(TIUSTAT(TIUI)) Q:'TIUI!(+$G(TIUOUT)) D - . I $P($G(TIUSTAT(TIUI)),U,3)="" S TIUOUT=1 Q - . S STATIFN=$O(^TIU(8925.6,"B",$$UPPER^TIULS($P(TIUSTAT(TIUI),U,3)),0)) - . Q:'STATIFN - . S STATUS("IFNS")=$G(STATUS("IFNS"))_STATIFN_";" - I +$G(TIUOUT) S VALMQUIT=1 Q - S TIUI=1,STATWORD=$$UPPER^TIULS($P(TIUSTAT(1),U,3)) - I +$G(TIUSTAT(4))'>0 F S TIUI=$O(TIUSTAT(TIUI)) Q:+TIUI'>0 D - . S STATWORD=STATWORD_$S(TIUI=+TIUSTAT(1):" & ",1:", ")_$$UPPER^TIULS($P(TIUSTAT(TIUI),U,3)) - I +$G(TIUSTAT(4))>0 S STATWORD=$S($P(TIUSTAT(4),U,4)="ALL":"ALL",1:STATWORD_", OTHER") - S STATUS("WORDS")=STATWORD -DOCTYPE ; Select Document Type(s) - ; TIU207-If only 1 docytyp and have been to screen prompt then go back another level to avoid loop with next prompt. - I $G(TIUSC207)=1,$G(TIU1DOC)=1 D G STATUS - .S (TIUSC207,TIU1DOC)=0 - S (TIUSC207,TIU1DOC)=0 - N TIUDCL K TIUPICT - I $S(('$D(TIUQUIK)&'$D(ORVP)):1,($D(ORVP)&+$G(TIUCHVW)):1,1:0) D SELTYP^TIULA(TIUCLASS,.TIUTYP,"A","LAST","DOC",0,.TIUDCL,.TIUPICT) - S TIU1DOC=+$P($G(^TIU(8925.1,+TIUCLASS,10,0)),U,3) - ; SELTYP sets array ^TMP("TIUTYP",$J); - ; SELTYP used to set data into TIUTYP array - ; Now TIUTYP just ="^TMP("TIUTYP",$J)" - I $S($D(TIUQUIK):1,($D(ORVP)&'+$G(TIUCHVW)):1,1:0) D SELTYP^TIULA(TIUCLASS,.TIUTYP,"F","ALL","DOC",0) - I +$G(DIROUT) S VALMQUIT=1 Q - I +$G(@TIUTYP)'>0,'$D(TIUQUIK) G STATUS -SCREEN ; - S TIUSC207=1 - N TIUNAME,TIUOVER - S TIUNAME=$P($G(^VA(200,+DUZ,0)),U) - I $D(TIUQUIK) D I 1 ; all my unsigned TIUQUIK=1 - . I $G(TIUQUIK)=3 S SCREEN(1)="ALL^ANY" Q - . S SCREEN(1)="AAU^"_DUZ_U_TIUNAME - . S:$G(TIUQUIK)=1 SCREEN(2)="ASUP^"_DUZ - . S SCREEN="ALL" - E I $D(ORVP),'+$G(TIUCHVW) S SCREEN(1)="APT^"_+ORVP_U_$P($G(^DPT(+ORVP,0)),U) I 1 - S TIUOVER="" - E D SELCAT^TIULA1(.SCREEN,"A","AUTHOR",.TIUOVER) - I +$G(DIROUT) S VALMQUIT=1 Q - I $D(SCREEN)'>9 K @TIUTYP G DOCTYPE - I $D(@TIUTYP)'>9 W !,$C(7),"You must select one or more TITLES..." G SCREEN - I $G(SCREEN(1))="ALL^ANY",+$G(ORVP) S SCREEN(1)="APT^"_+$G(ORVP)_U_$P($G(^DPT(+$G(ORVP),0)),U) - D CHECKADD -ERLY S TIUEDFLT=$S(TIUCLASS=3:"T-2",TIUCLASS=244:"T-30",1:"T-7") - S TIUDPRMT=$S(TIUCLASS=244:"Discharge",1:"Reference") - S TIUEDT=$S($D(TIUQUIK):1,$D(ORVP)&(+$G(TIUCHVW)'>0):$$FMADD^XLFDT(DT,$S($D(^DPT(+$G(ORVP),.1))'>0:-180,1:-30)),1:$P($$EDATE^TIULA(TIUDPRMT,"",TIUEDFLT),U)) - I +$G(DIROUT) S VALMQUIT=1 Q - I TIUEDT'>0 G SCREEN - S TIULDT=$S($D(TIUQUIK):9999999,$D(ORVP)&(+$G(TIUCHVW)'>0):+$$NOW^XLFDT,1:$P($$LDATE^TIULA(TIUDPRMT),U)) - I +$G(DIROUT) S VALMQUIT=1 Q - I TIULDT'>0 G ERLY - I TIUEDT>TIULDT D SWAP(.TIUEDT,.TIULDT) - I $L(TIULDT,".")=1 D EXPRANGE(.TIUEDT,.TIULDT) - ; -- Reset late date to NOW on rebuild: - S NOWFLAG=$S(TIULDT-$$NOW^XLFDT<.0001:1,1:0) - I '$G(TIURBLD) W !,"Searching for the documents." - D BUILD(TIUCLASS,.STATUS,.SCREEN,TIUEDT,TIULDT,NOWFLAG) ;11/30/00 removed param TIUTYP since BUILD uses global now. - ; -- If attaching ID note & changed view, - ; update video for line to be attached: -- - I $G(TIUGLINK) D RESTOREG^TIULM(.TIUGLINK) - ;K @TIUTYP ;11/30/00 keep ^TMP("TIUTYP",$J) for rebuild - Q -STAT() ; Determine status - N TIUY - I +$G(TIUQUIK) D G STATX - . S TIUY=$$SELSTAT^TIULA(.TIUSTAT,"F",$S(TIUQUIK=1:"UNSIGNED,UNCOSIGNED",TIUQUIK>1:"UNDICTATED,UNTRANSCRIBED")) - I $D(ORVP),'+$G(TIUCHVW) D G STATX - . S TIUY=$$SELSTAT^TIULA(.TIUSTAT,"F","COMPLETED") - S TIUY=$$SELSTAT^TIULA(.TIUSTAT,"A",$$DFLTSTAT^TIURM(DUZ)) -STATX Q TIUY -CHECKADD ; Checks whether Addendum is included in the list of types - N TIUI,HIT,NUMTYPS - S (TIUI,HIT)=0 - F S TIUI=$O(^TMP("TIUTYP",$J,TIUI)) Q:+TIUI'>0!+HIT I $$UP^XLFSTR(^TMP("TIUTYP",$J,TIUI))["ADDENDUM" S HIT=1 - S NUMTYPS=^TMP("TIUTYP",$J) - I +HIT'>0 S ^TMP("TIUTYP",$J,NUMTYPS+1)=+^TMP("TIUTYP",$J,NUMTYPS)+1_U_"81^Addendum^NOT PICKED",^TMP("TIUTYP",$J)=^TMP("TIUTYP",$J)+1 - Q - ; -SWAP(TIUX,TIUY) ; Swap variables - N TIUTMP S TIUTMP=TIUX,TIUX=TIUY,TIUY=TIUTMP - Q -EXPRANGE(TIUX,TIUY) ; Expand late date to include time - ;P74 If user entered date/time = T, then numerical date time is FIRST ^ PIECE ONLY of TIUX & TIUY. - I $P(TIUY,U)=DT S TIUY=$$NOW^XLFDT I 1 - E S TIUY=$P(TIUY,U)_"."_235959 ;P74 Add seconds - Q -BUILD(TIUCLASS,STATUS,SCREEN,EARLY,LATE,NOWFLAG) ; Build List. - ;11/30/00 - removed param TYPES. 12/3 added param TIUCLASS - ; BUILD (GATHER) uses docmt type info from ^TMP("TIUTYP",$J) - N TIUDT,TIUI,TIUK - N TIUT,TIUTP,XREF,TIUS,TIUPREF - S TIUPREF=$$PERSPRF^TIULE(DUZ),(TIUK,VALMCNT)=0 - K ^TMP("TIUR",$J),^TMP("TIURIDX",$J),^TMP("TIUI",$J) - ; If user entered NOW at first build, update NOW for rebuild; - ; Save data in ^TMP("TIURIDX",$J,0) for rebuild: - I $G(TIURBLD),$G(NOWFLAG) S LATE=$$NOW^XLFDT - S ^TMP("TIURIDX",$J,0)=+EARLY_U_+LATE_U_$G(STATUS("IFNS"))_U_NOWFLAG - S ^TMP("TIUR",$J,"RTN")="TIUR" - S ^TMP("TIUR",$J,"TITLE OVERRIDE")=$G(TIUOVER) - I '$D(TIUPRM0) D SETPARM^TIULE - S EARLY=9999999-+$G(EARLY),LATE=9999999-$S(+$G(LATE):+$G(LATE),1:3333333) - F S TIUK=$O(SCREEN(TIUK)) Q:TIUK'>0 D - . I $G(SCREEN)'="ALL" S SCREEN=$G(TIUK) - . S XREF=$P(SCREEN(TIUK),U) - . I XREF'="ASUB" D - . . S TIUI=$S(XREF'="APRB":$P(SCREEN(TIUK),U,2),1:$$UPPER^TIULS($P(SCREEN(TIUK),U,3))) - . . D GATHER^TIUR1(TIUI,TIUPREF,TIUCLASS,STATUS("IFNS"),EARLY,LATE,XREF,SCREEN) - . I XREF="ASUB" D - . . S TIUI=$O(^TIU(8925,XREF,$P(SCREEN(TIUK),U,2)),-1) - . . F S TIUI=$O(^TIU(8925,XREF,TIUI)) Q:TIUI=""!(TIUI'[$P(SCREEN(TIUK),U,2)) D GATHER^TIUR1(TIUI,TIUPREF,TIUCLASS,STATUS("IFNS"),EARLY,LATE,XREF,SCREEN) - D PUTLIST^TIUR2(TIUPREF,TIUCLASS,.STATUS,.SCREEN) - K ^TMP("TIUI",$J) - Q - ; -CLEAN ; Clean up your mess! - K ^TMP("TIUR",$J),^TMP("TIURIDX",$J) D CLEAN^VALM10,KILLRR^TIULRR - K VALMY - K ^TMP("TIUTYP",$J) - Q - ; -RBLD ; Rebuild list after actions 11/30/00 - N TIUEXP,TIUR0,TIURIDX0,TIUSCRN,TMP,TIUEDT,TIULDT,TIUSTAT - N TIURBLD,TIUI,TIUCLASS,NOWFLAG - S TIURBLD=1 - D FIXLSTNW^TIULM ;restore video for elements added to end of list - I +$O(^TMP("TIUR",$J,"EXPAND",0)) D - . M TIUEXP=^TMP("TIUR",$J,"EXPAND") - S TIUR0=^TMP("TIUR",$J,0),TIURIDX0=^TMP("TIURIDX",$J,0) - S TIUSCRN=$P(TIUR0,U,3,99),TIUCLASS=^TMP("TIUR",$J,"CLASS") - S TIUI=1 - F S TMP=$P(TIUSCRN,";",TIUI) Q:TMP="" D - . S TIUSCRN(TIUI)=TMP,TIUI=TIUI+1 - S TIUSCRN=$L(TIUSCRN,";") - S STATUS("WORDS")=$P(TIUR0,U,2) - S STATUS("IFNS")=$P(TIURIDX0,U,3) - S TIUEDT=$P(TIURIDX0,U),TIULDT=$P(TIURIDX0,U,2),NOWFLAG=+$P(TIURIDX0,U,4) - ;VMP/ELR ADDED THE FOLLOWING LINE IN PATCH 224 - S TIUSCRN="ALL" - D BUILD(TIUCLASS,.STATUS,.TIUSCRN,TIUEDT,TIULDT,NOWFLAG) - ; Reexpand previously expanded items: - D RELOAD^TIUROR1(.TIUEXP) - D BREATHE^TIUROR1(1) - Q +TIUR ; SLC/JER - Integrated Document Review ;11/01/03 + ;;1.0;TEXT INTEGRATION UTILITIES;**74,79,58,100,113,112,207**;Jun 20, 1997 + ; 11/30/00 Moved PUTLIST & ADDELMNT to TIUR1 +MAKELIST(TIUCLASS,TIUCHVW) ; Get Search Criteria + N DIRUT,DTOUT,DUOUT,TIUI,SCREEN,STATUS,TIUTYP,TIUSTAT,TIUEDFLT,TIUDCL + N TIUDPRMT,TIUPICT,TIUOUT,STATWORD,STATIFN,NOWFLAG,TIUSC207,TIU1DOC + K DIROUT + D INITRR^TIULRR(0) + ; TIURPN used in Order Entry 2.5, OR OE/RR MENU CLIN: + I +$G(ORVP),(+$G(TIUCHVW)'>0) D EN^TIURPN(TIUCLASS,+ORVP) Q +STATUS S STATUS=$$STAT + I +STATUS<0 S VALMQUIT=1 Q + S TIUI=0 + F S TIUI=$O(TIUSTAT(TIUI)) Q:'TIUI!(+$G(TIUOUT)) D + . I $P($G(TIUSTAT(TIUI)),U,3)="" S TIUOUT=1 Q + . S STATIFN=$O(^TIU(8925.6,"B",$$UPPER^TIULS($P(TIUSTAT(TIUI),U,3)),0)) + . Q:'STATIFN + . S STATUS("IFNS")=$G(STATUS("IFNS"))_STATIFN_";" + I +$G(TIUOUT) S VALMQUIT=1 Q + S TIUI=1,STATWORD=$$UPPER^TIULS($P(TIUSTAT(1),U,3)) + I +$G(TIUSTAT(4))'>0 F S TIUI=$O(TIUSTAT(TIUI)) Q:+TIUI'>0 D + . S STATWORD=STATWORD_$S(TIUI=+TIUSTAT(1):" & ",1:", ")_$$UPPER^TIULS($P(TIUSTAT(TIUI),U,3)) + I +$G(TIUSTAT(4))>0 S STATWORD=$S($P(TIUSTAT(4),U,4)="ALL":"ALL",1:STATWORD_", OTHER") + S STATUS("WORDS")=STATWORD +DOCTYPE ; Select Document Type(s) + ; TIU207-If only 1 docytyp and have been to screen prompt then go back another level to avoid loop with next prompt. + I $G(TIUSC207)=1,$G(TIU1DOC)=1 D G STATUS + .S (TIUSC207,TIU1DOC)=0 + S (TIUSC207,TIU1DOC)=0 + N TIUDCL K TIUPICT + I $S(('$D(TIUQUIK)&'$D(ORVP)):1,($D(ORVP)&+$G(TIUCHVW)):1,1:0) D SELTYP^TIULA(TIUCLASS,.TIUTYP,"A","LAST","DOC",0,.TIUDCL,.TIUPICT) + S TIU1DOC=+$P($G(^TIU(8925.1,+TIUCLASS,10,0)),U,3) + ; SELTYP sets array ^TMP("TIUTYP",$J); + ; SELTYP used to set data into TIUTYP array + ; Now TIUTYP just ="^TMP("TIUTYP",$J)" + I $S($D(TIUQUIK):1,($D(ORVP)&'+$G(TIUCHVW)):1,1:0) D SELTYP^TIULA(TIUCLASS,.TIUTYP,"F","ALL","DOC",0) + I +$G(DIROUT) S VALMQUIT=1 Q + I +$G(@TIUTYP)'>0,'$D(TIUQUIK) G STATUS +SCREEN ; + S TIUSC207=1 + N TIUNAME,TIUOVER + S TIUNAME=$P($G(^VA(200,+DUZ,0)),U) + I $D(TIUQUIK) D I 1 ; all my unsigned TIUQUIK=1 + . I $G(TIUQUIK)=3 S SCREEN(1)="ALL^ANY" Q + . S SCREEN(1)="AAU^"_DUZ_U_TIUNAME + . S:$G(TIUQUIK)=1 SCREEN(2)="ASUP^"_DUZ + . S SCREEN="ALL" + E I $D(ORVP),'+$G(TIUCHVW) S SCREEN(1)="APT^"_+ORVP_U_$P($G(^DPT(+ORVP,0)),U) I 1 + S TIUOVER="" + E D SELCAT^TIULA1(.SCREEN,"A","AUTHOR",.TIUOVER) + I +$G(DIROUT) S VALMQUIT=1 Q + I $D(SCREEN)'>9 K @TIUTYP G DOCTYPE + I $D(@TIUTYP)'>9 W !,$C(7),"You must select one or more TITLES..." G SCREEN + I $G(SCREEN(1))="ALL^ANY",+$G(ORVP) S SCREEN(1)="APT^"_+$G(ORVP)_U_$P($G(^DPT(+$G(ORVP),0)),U) + D CHECKADD +ERLY S TIUEDFLT=$S(TIUCLASS=3:"T-2",TIUCLASS=244:"T-30",1:"T-7") + S TIUDPRMT=$S(TIUCLASS=244:"Discharge",1:"Reference") + S TIUEDT=$S($D(TIUQUIK):1,$D(ORVP)&(+$G(TIUCHVW)'>0):$$FMADD^XLFDT(DT,$S($D(^DPT(+$G(ORVP),.1))'>0:-180,1:-30)),1:$P($$EDATE^TIULA(TIUDPRMT,"",TIUEDFLT),U)) + I +$G(DIROUT) S VALMQUIT=1 Q + I TIUEDT'>0 G SCREEN + S TIULDT=$S($D(TIUQUIK):9999999,$D(ORVP)&(+$G(TIUCHVW)'>0):+$$NOW^XLFDT,1:$P($$LDATE^TIULA(TIUDPRMT),U)) + I +$G(DIROUT) S VALMQUIT=1 Q + I TIULDT'>0 G ERLY + I TIUEDT>TIULDT D SWAP(.TIUEDT,.TIULDT) + I $L(TIULDT,".")=1 D EXPRANGE(.TIUEDT,.TIULDT) + ; -- Reset late date to NOW on rebuild: + S NOWFLAG=$S(TIULDT-$$NOW^XLFDT<.0001:1,1:0) + I '$G(TIURBLD) W !,"Searching for the documents." + D BUILD(TIUCLASS,.STATUS,.SCREEN,TIUEDT,TIULDT,NOWFLAG) ;11/30/00 removed param TIUTYP since BUILD uses global now. + ; -- If attaching ID note & changed view, + ; update video for line to be attached: -- + I $G(TIUGLINK) D RESTOREG^TIULM(.TIUGLINK) + ;K @TIUTYP ;11/30/00 keep ^TMP("TIUTYP",$J) for rebuild + Q +STAT() ; Determine status + N TIUY + I +$G(TIUQUIK) D G STATX + . S TIUY=$$SELSTAT^TIULA(.TIUSTAT,"F",$S(TIUQUIK=1:"UNSIGNED,UNCOSIGNED",TIUQUIK>1:"UNDICTATED,UNTRANSCRIBED")) + I $D(ORVP),'+$G(TIUCHVW) D G STATX + . S TIUY=$$SELSTAT^TIULA(.TIUSTAT,"F","COMPLETED") + S TIUY=$$SELSTAT^TIULA(.TIUSTAT,"A",$$DFLTSTAT^TIURM(DUZ)) +STATX Q TIUY +CHECKADD ; Checks whether Addendum is included in the list of types + N TIUI,HIT,NUMTYPS + S (TIUI,HIT)=0 + F S TIUI=$O(^TMP("TIUTYP",$J,TIUI)) Q:+TIUI'>0!+HIT I $$UP^XLFSTR(^TMP("TIUTYP",$J,TIUI))["ADDENDUM" S HIT=1 + S NUMTYPS=^TMP("TIUTYP",$J) + I +HIT'>0 S ^TMP("TIUTYP",$J,NUMTYPS+1)=+^TMP("TIUTYP",$J,NUMTYPS)+1_U_"81^Addendum^NOT PICKED",^TMP("TIUTYP",$J)=^TMP("TIUTYP",$J)+1 + Q + ; +SWAP(TIUX,TIUY) ; Swap variables + N TIUTMP S TIUTMP=TIUX,TIUX=TIUY,TIUY=TIUTMP + Q +EXPRANGE(TIUX,TIUY) ; Expand late date to include time + ;P74 If user entered date/time = T, then numerical date time is FIRST ^ PIECE ONLY of TIUX & TIUY. + I $P(TIUY,U)=DT S TIUY=$$NOW^XLFDT I 1 + E S TIUY=$P(TIUY,U)_"."_235959 ;P74 Add seconds + Q +BUILD(TIUCLASS,STATUS,SCREEN,EARLY,LATE,NOWFLAG) ; Build List. + ;11/30/00 - removed param TYPES. 12/3 added param TIUCLASS + ; BUILD (GATHER) uses docmt type info from ^TMP("TIUTYP",$J) + N TIUDT,TIUI,TIUK + N TIUT,TIUTP,XREF,TIUS,TIUPREF + S TIUPREF=$$PERSPRF^TIULE(DUZ),(TIUK,VALMCNT)=0 + K ^TMP("TIUR",$J),^TMP("TIURIDX",$J),^TMP("TIUI",$J) + ; If user entered NOW at first build, update NOW for rebuild; + ; Save data in ^TMP("TIURIDX",$J,0) for rebuild: + I $G(TIURBLD),$G(NOWFLAG) S LATE=$$NOW^XLFDT + S ^TMP("TIURIDX",$J,0)=+EARLY_U_+LATE_U_$G(STATUS("IFNS"))_U_NOWFLAG + S ^TMP("TIUR",$J,"RTN")="TIUR" + S ^TMP("TIUR",$J,"TITLE OVERRIDE")=$G(TIUOVER) + I '$D(TIUPRM0) D SETPARM^TIULE + S EARLY=9999999-+$G(EARLY),LATE=9999999-$S(+$G(LATE):+$G(LATE),1:3333333) + F S TIUK=$O(SCREEN(TIUK)) Q:TIUK'>0 D + . I $G(SCREEN)'="ALL" S SCREEN=$G(TIUK) + . S XREF=$P(SCREEN(TIUK),U) + . I XREF'="ASUB" D + . . S TIUI=$S(XREF'="APRB":$P(SCREEN(TIUK),U,2),1:$$UPPER^TIULS($P(SCREEN(TIUK),U,3))) + . . D GATHER^TIUR1(TIUI,TIUPREF,TIUCLASS,STATUS("IFNS"),EARLY,LATE,XREF,SCREEN) + . I XREF="ASUB" D + . . S TIUI=$O(^TIU(8925,XREF,$P(SCREEN(TIUK),U,2)),-1) + . . F S TIUI=$O(^TIU(8925,XREF,TIUI)) Q:TIUI=""!(TIUI'[$P(SCREEN(TIUK),U,2)) D GATHER^TIUR1(TIUI,TIUPREF,TIUCLASS,STATUS("IFNS"),EARLY,LATE,XREF,SCREEN) + D PUTLIST^TIUR2(TIUPREF,TIUCLASS,.STATUS,.SCREEN) + K ^TMP("TIUI",$J) + Q + ; +CLEAN ; Clean up your mess! + K ^TMP("TIUR",$J),^TMP("TIURIDX",$J) D CLEAN^VALM10,KILLRR^TIULRR + K VALMY + K ^TMP("TIUTYP",$J) + Q + ; +RBLD ; Rebuild list after actions 11/30/00 + N TIUEXP,TIUR0,TIURIDX0,TIUSCRN,TMP,TIUEDT,TIULDT,TIUSTAT + N TIURBLD,TIUI,TIUCLASS,NOWFLAG + S TIURBLD=1 + D FIXLSTNW^TIULM ;restore video for elements added to end of list + I +$O(^TMP("TIUR",$J,"EXPAND",0)) D + . M TIUEXP=^TMP("TIUR",$J,"EXPAND") + S TIUR0=^TMP("TIUR",$J,0),TIURIDX0=^TMP("TIURIDX",$J,0) + S TIUSCRN=$P(TIUR0,U,3,99),TIUCLASS=^TMP("TIUR",$J,"CLASS") + S TIUI=1 + F S TMP=$P(TIUSCRN,";",TIUI) Q:TMP="" D + . S TIUSCRN(TIUI)=TMP,TIUI=TIUI+1 + S TIUSCRN=$L(TIUSCRN,";") + S STATUS("WORDS")=$P(TIUR0,U,2) + S STATUS("IFNS")=$P(TIURIDX0,U,3) + S TIUEDT=$P(TIURIDX0,U),TIULDT=$P(TIURIDX0,U,2),NOWFLAG=+$P(TIURIDX0,U,4) + D BUILD(TIUCLASS,.STATUS,.TIUSCRN,TIUEDT,TIULDT,NOWFLAG) + ; Reexpand previously expanded items: + D RELOAD^TIUROR1(.TIUEXP) + D BREATHE^TIUROR1(1) + Q diff --git a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIURA3.m b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIURA3.m index bf868a73..12a6a127 100644 --- a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIURA3.m +++ b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIURA3.m @@ -1,140 +1,109 @@ -TIURA3 ; SLC/JER - Review screen actions ; 11/21/07 - ;;1.0;TEXT INTEGRATION UTILITIES;**220,234**;Jun 20, 1997;Build 6 - ; Call to ISA^USRLM supported by DBIA 2324 - ; Call to ISTERM^USRLM supported by DBIA 2712 -EDITCOS ; Edit Expected Cosigner - N TIUDA,TIUDATA,TIUCHNG,TIUI,DIROUT,TIUDAARY - N TIULST,MSGVERB,TIUXNOD - S TIUXNOD=$G(XQORNOD(0)) - I $P(TIUXNOD,U,3)="EC" W "Edit Cosigner",! S $P(TIUXNOD,U,4)="EC="_$P($P(TIUXNOD,U,4),"==",2) - S TIUI=0 - I '$D(VALMY) D EN^VALM2(TIUXNOD) - F S TIUI=$O(VALMY(TIUI)) Q:+TIUI'>0 D Q:$D(DIROUT) - . N RSTRCTD - . S TIUDATA=$G(^TMP("TIURIDX",$J,TIUI)) - . D CLEAR^VALM1 W !!,"Editing #",+TIUDATA - . S TIUDA=+$P(TIUDATA,U,2) S RSTRCTD=$$DOCRES^TIULRR(TIUDA) - . I RSTRCTD D Q - . . W !!,$C(7),"Ok, no harm done...",! - . . I $$READ^TIUU("EA","RETURN to continue...") ; pause - . S TIUDAARY(TIUI)=TIUDA - . S TIUCHNG=0 - . I +$D(^TIU(8925,+TIUDA,0)) D EDITCOS1 - . I +$G(TIUCHNG) D - . . S TIULST=$G(TIULST)_$S($G(TIULST)]"":",",1:"")_TIUI - ; -- Update or Rebuild list, restore video: -- - S TIUCHNG("UPDATE")=1 - D UPRBLD^TIURL(.TIUCHNG,.VALMY) K VALMY - S VALMBCK="R" - S MSGVERB="edited" - D VMSG^TIURS1($G(TIULST),.TIUDAARY,MSGVERB) - Q -EDITCOS1 ; Edit expected cosigner/attending for single record - ; Receives TIUDA - I '+$G(TIUDA) W !,"No Documents selected." H 2 Q - ; Evaluate edit privilege - N NODE0,STATUS,OK2CHNG,NODE12,REQCOSIG - N ECSIGNER,ESIGNER,OKCLASS,TIUISDS,DA,DR,DIE,X - N ALTNODE0,ALTTIUDA,NESIGNR,NECSIGNR,ATTEND,NATTEND,CHKSUM,LNO,MSGNO - N CANDO,TIUISCP,TIUISCST,TIUISPN,MSG - ; NECSIGNER,NATTEND etc,(N for new) means post-edit. It may not differ - ;from the original. It may be null if the original was null. - S NODE0=^TIU(8925,TIUDA,0),STATUS=$P(NODE0,U,5),(OK2CHNG,OKCLASS)=1 - S ALTNODE0=NODE0,ALTTIUDA=TIUDA,NODE12=$G(^TIU(8925,TIUDA,12)) - I $$ISADDNDM^TIULC1(TIUDA) D - . S ALTTIUDA=$P(NODE0,U,6) - . S ALTNODE0=^TIU(8925,ALTTIUDA,0) - S TIUISDS=$$ISDS^TIULX(+ALTNODE0),TIUISPN=$$ISPN^TIULX(+ALTNODE0) - S TIUISCST=$$ISA^TIULX(+ALTNODE0,$$CLASS^TIUCNSLT()) - S TIUISCP=$$ISA^TIULX(+ALTNODE0,$$CLASS^TIUCP()) - I 'TIUISDS,'TIUISPN,'TIUISCST,'TIUISCP D G COS1X - . S MSG(1,1)=" This action is permitted only for Progress Notes, Discharge" - . S MSG(1,2)="Summaries, Clinical Procedures and Consults." - I STATUS>6 S MSG(2,1)=" This document has already been Completed!" G COS1X - I STATUS<5 S MSG(3,1)=" This document still needs Release or Verification!" G COS1X - ; Status = 5 unsigned or 6 uncosigned: - ; Try rules for EDIT COSIGNER: - S CANDO=$$CANDO^TIULP(TIUDA,"EDIT COSIGNER") - I 'CANDO S MSG(4,1)=" "_$P(CANDO,U,2) G:STATUS=6 COS1X - ; If docmt is unsigned and EDIT COSIGNER rules failed, - ; try EDIT RECORD rules: - I STATUS=5,'CANDO D G:'CANDO COS1X - . S CANDO=$$CANDO^TIULP(TIUDA,"EDIT RECORD") - . I CANDO K MSG(4) Q - . S MSG(5,1)=" You are not authorized to edit any aspect of this document." - ; User authorized to change Expected Cosigner/attending: - S DA=TIUDA,DIE=8925 - ; - ; **Docmt is PN, CP or Consult** - I 'TIUISDS D G COS1X - . S ESIGNER=$P(NODE12,U,4) - . S ECSIGNER=$P(NODE12,U,8) - . I ESIGNER'>0 S MSG(6,1)=" This document has no Expected Signer!" Q - . S REQCOSIG=$$REQCOSIG^TIULP(+NODE0,+TIUDA,ESIGNER) - . ; - . ; **Cosig NOT REQUIRED:** - . I 'REQCOSIG D Q - . . ; Status Uncosigned - Do not permit completion of notes: - . . I STATUS=6 D Q - . . . S MSG(7,1)=" Cosignature is not currently required. This option cannot be" - . . . S MSG(7,2)="used to change document status to COMPLETED. It looks like the author's" - . . . S MSG(7,3)="requirement has changed since this document was written." - . . . S MSG(7,4)="Please contact your CAC and/or HIMS for assistance." - . . ; Unsigned, Has no EC: - . . I ECSIGNER']"" S MSG(8,1)=" ?? Cosignature not required." Q - . . ; Unsigned, Has EC: - . . S MSG(8,1)=" Cosignature not required. Expected Cosigner deleted." - . . S DR="1208///@;1506///@" D ^DIE S TIUCHNG=1 - . . ; - . ; **Cosig REQUIRED:** - . W !!," You may edit the Expected Cosigner:" - . S DR="1208R//;1506////1" D ^DIE - . S NECSIGNR=$P(^TIU(8925,TIUDA,12),U,8) - . I NECSIGNR']"" D Q - . . S MSG(9,1)=" Cosignature is required! Expected Cosigners cannot be alerted " - . . S MSG(9,2)="until they are designated. " - . . I STATUS=6 S MSG(9,3)="Please designate an Expected Cosigner as soon as possible!!" - . I NECSIGNR=ECSIGNER D Q - . . W !!," Expected Cosigner not changed." H 1 - . W !!," Expected Cosigner edited." H 1 S TIUCHNG=1 Q - ; - ; **Docmt is a Discharge Summary. Attending required: ** - S ATTEND=$P($G(^TIU(8925,TIUDA,12)),U,9) - W !!,"You may edit the Attending Physician:" - S DR="1209R//" D ^DIE - S NATTEND=$P(^TIU(8925,TIUDA,12),U,9) - S MSG("ALERT")=" Attendings cannot be alerted until designated!" - I NATTEND']0 S MSG(1,1)=" Attending is Required!",MSG(1,2)=MSG("ALERT") G COS1X - ; NATTEND is not null. Does it pass screen from TIU*1*219? - ; (Needed even after 219 for ^ or Return with no Attending) - ; Overwrite most likely msgs with least likely: - I +$$REQCOSIG^TIULP(+NODE0,+TIUDA,NATTEND) S MSG(2,1)=" This person requires a cosignature. Please select a different Attending.",MSG(2,2)=MSG("ALERT") - I '$$ISA^USRLM(NATTEND,"PROVIDER") D - . K MSG(2) - . S MSG(2,1)=" This person is not in User Class PROVIDER. Please check User " - . S MSG(2,2)="Class or select a different Attending." - . S MSG(2,3)=MSG("ALERT") - I $$ISTERM^USRLM(NATTEND) K MSG(2) S MSG(2,1)=" This person is terminated! Please select a different Attending.",MSG(2,2)=MSG("ALERT") - ; Att fails. Restore old att: - I $D(MSG(2)) D G COS1X - . S X=$S((STATUS=5)&(ATTEND']""):"@",1:ATTEND),DR="1209////" D ^DIE - ; Attending exists and is good: - S NESIGNR=$$WHOSIGNS^TIULC1(DA),NECSIGNR=$$WHOCOSIG^TIULC1(DA) - S DR="1204////^S X=NESIGNR" - S DR=DR_";1208////^S X=NECSIGNR" - S DR=DR_";1506////^S X=$S(+NESIGNR=+NATTEND:0,1:1)" - D ^DIE - I NATTEND=ATTEND D G COS1X - . W !!," Attending Physician not changed." H 1 - ; New Attend Changed - Go on to audit - W !!," Attending Physician edited." S TIUCHNG=1 H 1 -COS1X ; - I $G(TIUCHNG) D - . D SEND^TIUALRT(TIUDA) - . Q:$G(STATUS)'=6 D ; Audit uncosigned docmts only - . S CHKSUM=+$$CHKSUM^TIULC("^TIU(8925,"_+TIUDA_",""TEXT"")") - . D AUDIT^TIUEDI1(TIUDA,CHKSUM,CHKSUM) - I $D(MSG) W ! F MSGNO=1:1:9 D - . F LNO=1:1:10 Q:'$D(MSG(MSGNO,LNO)) W !,MSG(MSGNO,LNO) - I $D(MSG),$$READ^TIUU("EA","RETURN to continue...") - Q +TIURA3 ; SLC/JER - Review screen actions ; 11/7/06 + ;;1.0;TEXT INTEGRATION UTILITIES;**220**;Jun 20, 1997;Build 4 + ; Call to ISA^USRLM supported by DBIA 2324 +EDITCOS ; Edit Expected Cosigner + ; Modeled after EDIT^TIURA + N TIUDA,TIUDATA,TIUCHNG,TIUI,DIROUT,TIUDAARY + N TIULST,MSGVERB,TIUXNOD + S TIUXNOD=$G(XQORNOD(0)) + I $P(TIUXNOD,U,3)="EC" W "Edit Cosigner",! S $P(TIUXNOD,U,4)="EC="_$P($P(TIUXNOD,U,4),"==",2) + S TIUI=0 + I '$D(VALMY) D EN^VALM2(TIUXNOD) + F S TIUI=$O(VALMY(TIUI)) Q:+TIUI'>0 D Q:$D(DIROUT) + . N RSTRCTD + . S TIUDATA=$G(^TMP("TIURIDX",$J,TIUI)) + . D CLEAR^VALM1 W !!,"Editing #",+TIUDATA + . S TIUDA=+$P(TIUDATA,U,2) S RSTRCTD=$$DOCRES^TIULRR(TIUDA) + . I RSTRCTD D Q + . . W !!,$C(7),"Ok, no harm done...",! + . . I $$READ^TIUU("EA","RETURN to continue...") ; pause + . S TIUDAARY(TIUI)=TIUDA + . S TIUCHNG=0 + . I +$D(^TIU(8925,+TIUDA,0)) D EDITCOS1 + . I +$G(TIUCHNG) D + . . S TIULST=$G(TIULST)_$S($G(TIULST)]"":",",1:"")_TIUI + ; -- Update or Rebuild list, restore video: -- + S TIUCHNG("UPDATE")=1 + D UPRBLD^TIURL(.TIUCHNG,.VALMY) K VALMY + S VALMBCK="R" + S MSGVERB="edited" + D VMSG^TIURS1($G(TIULST),.TIUDAARY,MSGVERB) + Q +EDITCOS1 ; Edit expected cosigner/attending for single record + ; Receives TIUDA + ; Modeled after Input template for document type + I '+$G(TIUDA) W !,"No Documents selected." H 2 Q + ; Evaluate edit privilege + N NODE0,STATUS,OK2CHNG,CANTMSG,NODE12,REQCOSIG,PROBMSG + N ECSIGNER,ESIGNER,OKCLASS,TIUISDS,DA,DR,DIE,X + N ALTNODE0,ALTTIUDA,NESIGNR,NECSIGNR,ATTEND,NATTEND,CHKSUM + S NODE0=^TIU(8925,TIUDA,0),STATUS=$P(NODE0,U,5),(OK2CHNG,OKCLASS)=1 + S ALTNODE0=NODE0,ALTTIUDA=TIUDA,NODE12=$G(^TIU(8925,TIUDA,12)) + I $$ISADDNDM^TIULC1(TIUDA) D + . S ALTTIUDA=$P(NODE0,U,6) + . S ALTNODE0=^TIU(8925,ALTTIUDA,0) + S TIUISDS=$$ISDS^TIULX(+ALTNODE0) + I '$$ISPN^TIULX(+ALTNODE0),'TIUISDS,'$$ISA^TIULX(+ALTNODE0,$$CLASS^TIUCNSLT()) S OKCLASS=0 + I 'OKCLASS S PROBMSG="This action is valid only for Progress Notes, Discharge Summaries, and Consults." G COS1X + I STATUS>6 S PROBMSG="This document is already Complete!" G COS1X + I STATUS<5 S PROBMSG="This document still needs Release or Verification!" G COS1X + ; -- Status = 5 unsigned or 6 uncosigned. + ; Try rules for EDIT COSIGNER: + S OK2CHNG=$$CANDO^TIULP(TIUDA,"EDIT COSIGNER") + I 'OK2CHNG S CANTMSG=OK2CHNG G:STATUS=6 COS1X + ; -- If docmt is unsigned and EDIT COSIGNER rules failed, + ; try EDIT RECORD rules: + I STATUS=5,'OK2CHNG D G:'OK2CHNG COS1X + . S OK2CHNG=$$CANDO^TIULP(TIUDA,"EDIT RECORD") + . I 'OK2CHNG S CANTMSG="0^You are not authorized to edit this document." + ; -- DUZ may change Expected Cosigner/attending. + S DA=TIUDA,DIE=8925 + ; -- If docmt is a Progress Note or Consult: + I 'TIUISDS D G COS1X + . ; -- Does Expected Signer Require Cosignature? + . S ESIGNER=$P(NODE12,U,4) + . S ECSIGNER=$P(NODE12,U,8) + . I ESIGNER']"" S PROBMSG="This document has no Expected Signer!" Q + . S REQCOSIG=$$REQCOSIG^TIULP(+NODE0,+TIUDA,ESIGNER) + . ; -- If cosig not required: + . I 'REQCOSIG D Q + . . ; -- If status is uncosigned, "see IRM" and quit: + . . I STATUS=6 S PROBMSG="Cosignature not required! See IRM." Q + . . ; -- If (status is unsigned) & has no exp cosgnr, say so and quit: + . . I ECSIGNER="" S PROBMSG="Cosignature not required." Q + . . ; -- If (status is unsigned), has exp cosgnr, fix it: + . . I ECSIGNER]"" D Q + . . . S PROBMSG="Cosignature not required. Expected Cosigner deleted." + . . . S DR="1208///@;1506///@" D ^DIE + . ; --Cosig is required so get it or change it: + . W !!,"You may edit the Expected Cosigner:" + . S DR="1208R//;1506////1" D ^DIE + . S NECSIGNR=$P(^TIU(8925,TIUDA,12),U,8) + . I NECSIGNR'=ECSIGNER D Q + . . W !!,"Expected Cosigner edited." H 1 S TIUCHNG=1 + ; -- Docmt is a Discharge Summary: + S ATTEND=$P($G(^TIU(8925,TIUDA,12)),U,9) + W !!,"You may edit the Attending Physician:" + S DR="1209R//" D ^DIE + S NATTEND=$P(^TIU(8925,TIUDA,12),U,9) + I STATUS=6,NATTEND=$P(NODE12,U,2) D G COS1X + . S PROBMSG="You may not change the Attending of a signed" + . S PROBMSG=PROBMSG_" summary to the author." + . S DR="1209////^S X=ATTEND" D ^DIE + S NESIGNR=$$WHOSIGNS^TIULC1(DA),NECSIGNR=$$WHOCOSIG^TIULC1(DA) + S DR="1204////^S X=NESIGNR" + S DR=DR_";1208////^S X=NECSIGNR" + S DR=DR_";1506////^S X=$S(+NESIGNR=+NATTEND:0,1:1)" + D ^DIE + I NATTEND'=ATTEND D + . W !!,"Attending Physician edited" H 1 S TIUCHNG=1 +COS1X ; + I $G(TIUCHNG),$G(STATUS)=6 D ; Audit uncosigned docmts only + . S CHKSUM=+$$CHKSUM^TIULC("^TIU(8925,"_+TIUDA_",""TEXT"")") + . D AUDIT^TIUEDI1(TIUDA,CHKSUM,CHKSUM) + I $D(PROBMSG) W !!,PROBMSG + I 'OK2CHNG W !!,$P(CANTMSG,U,2) + I $D(PROBMSG)!'OK2CHNG I $$READ^TIUU("EA","RETURN to continue...") + D SEND^TIUALRT(TIUDA) + Q + ; diff --git a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIURB.m b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIURB.m index 6f7e1573..eef94c0d 100644 --- a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIURB.m +++ b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIURB.m @@ -1,172 +1,169 @@ -TIURB ; SLC/JER - More Review Screen Actions ;12/11/07 - ;;1.0;TEXT INTEGRATION UTILITIES;**4,32,52,78,58,100,109,155,184,234**;Jun 20, 1997;Build 6 - ; DBIA 3473 TIU use of GMRCTIU -AMEND ; Amendment action - N TIUDA,DFN,DIE,DR,TIU,TIUDATA,TIUI,TIUSIG,TIUY,X,X1,Y - N DIROUT,TIUCHNG,TIUDAARY,TIULST - I '$D(VALMY) D EN^VALM2(XQORNOD(0)) - S TIUI=0 - F S TIUI=$O(VALMY(TIUI)) Q:+TIUI'>0 D Q:$D(DIROUT) - . N RSTRCTD - . S TIUDATA=$G(^TMP("TIURIDX",$J,TIUI)) - . S TIUDA=+$P(TIUDATA,U,2) S RSTRCTD=$$DOCRES^TIULRR(TIUDA) - . I RSTRCTD D Q - . . W !!,$C(7),"Ok, no harm done...",! ; Echo denial message - . . I $$READ^TIUU("EA","RETURN to continue...") ; pause - . W !!,"Amending #",+TIUDATA - . S TIUCHNG=0 - . D AMEND1 - . I $G(TIUDAARY(TIUI)) D - . . S TIULST=$G(TIULST)_$S($G(TIULST)]"":",",1:"")_TIUI - ; -- Update or Rebuild list, restore video: - D UPRBLD^TIURL(.TIUCHNG,.VALMY) K VALMY - S VALMBCK="R" - D VMSG^TIURS1($G(TIULST),.TIUDAARY,"amended") - Q -AMEND1 ; Single record amend - N TIUCMT,TIUT0,TIUTYP,TIUAMND,TIUSNM,TIUSBLK,TIUCSNM,TIUCSBLK,DIE,DR - N DA,DFN,DIWESUB,TIU,TIUODA,TIUTITL,TIUCLSS,TIUCON,TIUCNSLT,TIUPRF,TIUFLAG - K ^TMP("TIURTRCT",$J) - ; TIU*155 Gets consult data if exists - S TIUTITL=$P($G(^TIU(8925,TIUDA,0)),U) - S TIUCLSS=$$CLASS^TIUCNSLT() - S TIUCON=+$$ISA^TIULX(TIUTITL,TIUCLSS) - S TIUCNSLT=+$P($G(^TIU(8925,TIUDA,14)),U,5) - S TIUPRF=0,TIUFLAG=0 - D ISPRFTTL^TIUPRF2(.TIUPRF,TIUTITL) - I TIUPRF S TIUFLAG=$$FNDACTIF^TIUPRFL(TIUDA) - L +^TIU(8925,+TIUDA):1 - E D Q - . W !?5,$C(7),"Another user is editing this entry." H 3 - . S TIUCHNG("REFRESH")=1 - I +$P($G(^TIU(8925,+TIUDA,0)),U,5)'>6 D Q - . W !?5,$C(7),"Only SIGNED Documents may be amended." - . I $$READ^TIUU("EA","Press RETURN to continue...") ; pause - . S TIUCHNG("REFRESH")=1 - I '$$ISA^USRLM(+$G(DUZ),"PRIVACY ACT OFFICER"),'$$ISA^USRLM(+$G(DUZ),"CHIEF, MIS"),'$$ISA^USRLM(+$G(DUZ),"CHIEF, HIM") D Q - . W !?5,$C(7),"Only Privacy Act Officers or MIS/HIM Chiefs may amend documents." - . I $$READ^TIUU("EA","Press RETURN to continue...") ; pause - . S TIUCHNG("REFRESH")=1 - I +$$HASIMG^TIURB2(TIUDA) D IMGNOTE^TIURB2 Q - ;S TIUAMND=$$CANDO^TIULP(TIUDA,"AMENDMENT") - ;I +TIUAMND'>0 D Q - ;. W !!,$C(7),$C(7),$C(7),$P(TIUAMND,U,2),! - ;. S TIUCHNG("REFRESH")=1 - ;. I $$READ^TIUU("EA","Press RETURN to continue...") ; pause - W !!,"Before proceeding, please enter your Electronic Signature Code..." - S TIUAMND=$$GETSIG^TIURD2 - I +TIUAMND'>0 D Q - . W !!," Ok, no harm done...",! - . S TIUCHNG("REFRESH")=1 - . I $$READ^TIUU("EA","Press RETURN to continue...") ; pause - W !!,"The ORIGINAL document will be RETRACTED, and a copy will be amended...",! - S TIUODA=TIUDA - S TIUDA=+$$RETRACT^TIURD2(TIUDA,"",7) - I '+TIUDA D Q - . W !!,$C(7),$C(7),$C(7),"Retraction of Original Document Failed.",! - . I $$READ^TIUU("EA","Press RETURN to continue...") ; pause - . S TIUDA=TIUODA,TIUCHNG("REFRESH")=1 - L +^TIU(8925,TIUDA):1 - E D Q - . W !?5,$C(7),"Another user is editing this entry." - . D RECOVER^TIURD4(TIUODA,TIUDA) H 3 - . S TIUPRF=$$LINK^TIUPRF1(TIUODA,+TIUFLAG,$P(TIUFLAG,U,2),$P($G(^TIU(8925,TIUODA,0)),U,2)) - . S TIUDA=TIUODA,TIUCHNG("REFRESH")=1 - S TIUSNM=$$DECRYPT^TIULC1($P(^TIU(8925,TIUDA,15),U,3),1,$$CHKSUM^TIULC("^TIU(8925,"_TIUDA_",""TEXT"")")) - S TIUSBLK=$$DECRYPT^TIULC1($P($G(^TIU(8925,TIUDA,15)),U,4),1,$$CHKSUM^TIULC("^TIU(8925,"_TIUDA_",""TEXT"")")) - S TIUCSNM=$$DECRYPT^TIULC1($P(^TIU(8925,TIUDA,15),U,9),1,$$CHKSUM^TIULC("^TIU(8925,"_TIUDA_",""TEXT"")")) - S TIUCSBLK=$$DECRYPT^TIULC1($P($G(^TIU(8925,TIUDA,15)),U,10),1,$$CHKSUM^TIULC("^TIU(8925,"_TIUDA_",""TEXT"")")) - S TIUTYP=+$G(^TIU(8925,+TIUDA,0)),TIUT0=$G(^TIU(8925.1,+TIUTYP,0)) - S TIUTYP(1)="1^"_+TIUTYP_U_$P(TIUT0,U,3)_U - S DFN=$P($G(^TIU(8925,+TIUDA,0)),U,2) - D GETTIU^TIULD(.TIU,TIUDA) - S DIWESUB="Patient: "_$G(TIU("PNM")) - S TIUCHNG=0 D FULL^VALM1,TEXTEDIT^TIUEDI4(TIUDA,.TIUCMT,.TIUCHNG) - I '+$G(TIUCHNG) D Q - . L -^TIU(8925,TIUDA) - . D RECOVER^TIURD4(TIUODA,TIUDA) - . S TIUPRF=$$LINK^TIUPRF1(TIUODA,+TIUFLAG,$P(TIUFLAG,U,2),$P($G(^TIU(8925,TIUODA,0)),U,2)) - . L -^TIU(8925,TIUODA) H 3 - . S TIUDA=TIUODA,TIUCHNG("REFRESH")=1 - I +$G(TIUCHNG) D - . S DR=".05///AMENDED;1601////"_$$NOW^XLFDT_";1602////"_DUZ,DA=TIUDA,TIUSIG=0 - . S DR=DR_";1603////"_$$NOW^XLFDT_";1604///^S X=$$SIGNAME^TIULS(DUZ);1605///^S X=$$SIGTITL^TIULS(DUZ)",TIUSIG=1 - . S DIE=8925 D ^DIE - . ; Refile /es/-block fields - . S DR="1503///^S X=TIUSNM;1504///^S X=TIUSBLK;1509///^S X=TIUCSNM;1510///^S X=TIUCSBLK" - . D ^DIE - ; Drop Locks on both documents - L -^TIU(8925,+TIUDA) - L -^TIU(8925,+TIUODA) - S TIUDAARY(TIUI)=TIUDA - S TIUCHNG("RBLD")=1 - ; if note is associated with a patient record flag - clean up - I +TIUFLAG S TIUPRF=$$LINK^TIUPRF1(TIUDA,+TIUFLAG,$P(TIUFLAG,U,2),$P($G(^TIU(8925,TIUDA,0)),U,2)) - ; TIU*155 If note is associated with a consult update ^GMR global - ; to include the amended note - ; Rollback retracted note from ^GMR(123 node 50 - I $G(TIUCON)=1 D - . N STATUS,GMRCSTAT,TIUAUTH - . S STATUS=$P($G(^TIU(8925,TIUDA,0)),U,5) - . S GMRCSTAT=$S(STATUS>6:"COMPLETED",1:"INCOMPLETE") - . S TIUAUTH=$P($G(^TIU(8925,TIUDA,12)),U,2) - . D ROLLBACK^TIUCNSLT(TIUODA) - . D GET^GMRCTIU(TIUCNSLT,TIUDA,GMRCSTAT,TIUAUTH) - Q -SENDBACK ; Send back a Document to transcription - N TIUDA,DFN,TIU,TIUDATA,TIUCHNG,TIUI,TIUY,Y,DIROUT,TIULST - N TIUDAARY - I '$D(VALMY) D EN^VALM2(XQORNOD(0)) - S TIUI=0 - I +$O(VALMY(0)) D CLEAR^VALM1 - F S TIUI=$O(VALMY(TIUI)) Q:+TIUI'>0 D Q:$D(DIROUT) - . N TIU,RSTRCTD - . S TIUDATA=$G(^TMP("TIURIDX",$J,TIUI)) - . S TIUDA=+$P(TIUDATA,U,2) S RSTRCTD=$$DOCRES^TIULRR(TIUDA) - . I RSTRCTD D Q - . . W !!,$C(7),"Ok, no harm done...",! ; Echo denial message - . . I $$READ^TIUU("EA","RETURN to continue...") ; pause - . S TIUDAARY(TIUI)=TIUDA - . S TIUCHNG=0 - . D EN^VALM("TIU SEND BACK") - . I +$G(TIUCHNG) D - . . S TIULST=$G(TIULST)_$S($G(TIULST)]"":",",1:"")_TIUI -SENDX ; Revise list and cycle back as appropriate - I $G(TIUCHNG("ADDM"))!$G(TIUCHNG("DELETE")) S TIUCHNG("RBLD")=1 - E S TIUCHNG("UPDATE")=1 - D UPRBLD^TIURL(.TIUCHNG,.VALMY) K VALMY - S VALMBCK="R" - D VMSG^TIURS1($G(TIULST),.TIUDAARY,"sent back") - Q -LINK ; Link to problem(s) - N TIUCHNG,TIUDA,DFN,TIU,TIUDATA,TIUEDIT,TIUI,TIUY,TIULST,Y,DIROUT - N TIUDAARY - I '$D(VALMY) D EN^VALM2(XQORNOD(0)) - S TIUI=0 - I +$O(VALMY(0)) D CLEAR^VALM1 - F S TIUI=$O(VALMY(TIUI)) Q:+TIUI'>0 D Q:$D(DIROUT) - . N TIU,VALMY,XQORM,VA,VADM,GMPDFN,GMPLUSER,RSTRCTD - . S TIUDATA=$G(^TMP("TIURIDX",$J,TIUI)) - . S TIUDA=+$P(TIUDATA,U,2),GMPLUSER=1 - . I '$D(^TIU(8925,+TIUDA,0)) D Q - . . W !,$C(7),"Document no longer exists.",! - . . I $$READ^TIUU("EA","Press RETURN to continue...") W "" - . S RSTRCTD=$$DOCRES^TIULRR(TIUDA) - . I RSTRCTD D Q - . . W !!,$C(7),"Ok, no harm done...",! ; Echo denial message - . . I $$READ^TIUU("EA","RETURN to continue...") ; pause - . S TIUDAARY(TIUI)=TIUDA - . S DFN=+$P($G(^TIU(8925,+TIUDA,0)),U,2) - . I +DFN D DEM^VADPT S GMPDFN=DFN_U_VADM(1)_U_$E(VADM(1))_VA("BID") - . S TIUCHNG=0 - . D EN^VALM("TIU LINK TO PROBLEM") - . I +$G(TIUCHNG) S TIULST=$G(TIULST)_$S($G(TIULST)]"":",",1:"")_TIUI -LINKX ; Revise list and cycle back as appropriate - S TIUCHNG("REFRESH")=1 - D UPRBLD^TIURL(.TIUCHNG,.VALMY) K VALMY - S VALMBCK="R" - D VMSG^TIURS1($G(TIULST),.TIUDAARY,"linked to problems") - Q -DEL(DA) ; -- Call to DEL for backward compatibility - G GODEL^TIURB2 - Q +TIURB ; SLC/JER - More Review Screen Actions ;4/11/05 + ;;1.0;TEXT INTEGRATION UTILITIES;**4,32,52,78,58,100,109,155,184**;Jun 20, 1997 + ; **100** Moved DELETE, DEL, DELTEXT, DIK to new rtn TIURB2 + ; DBIA 3576 TIU use of GMRCTIU +AMEND ; Amendment action + N TIUDA,DFN,DIE,DR,TIU,TIUDATA,TIUI,TIUSIG,TIUY,X,X1,Y + N DIROUT,TIUCHNG,TIUDAARY,TIULST + I '$D(VALMY) D EN^VALM2(XQORNOD(0)) + S TIUI=0 + F S TIUI=$O(VALMY(TIUI)) Q:+TIUI'>0 D Q:$D(DIROUT) + . N RSTRCTD + . S TIUDATA=$G(^TMP("TIURIDX",$J,TIUI)) + . S TIUDA=+$P(TIUDATA,U,2) S RSTRCTD=$$DOCRES^TIULRR(TIUDA) + . I RSTRCTD D Q + . . W !!,$C(7),"Ok, no harm done...",! ; Echo denial message + . . I $$READ^TIUU("EA","RETURN to continue...") ; pause + . W !!,"Amending #",+TIUDATA + . S TIUCHNG=0 + . D AMEND1 + . I $G(TIUDAARY(TIUI)) D + . . S TIULST=$G(TIULST)_$S($G(TIULST)]"":",",1:"")_TIUI + ; -- Update or Rebuild list, restore video: + D UPRBLD^TIURL(.TIUCHNG,.VALMY) K VALMY + S VALMBCK="R" + D VMSG^TIURS1($G(TIULST),.TIUDAARY,"amended") + Q +AMEND1 ; Single record amend + N TIUCMT,TIUT0,TIUTYP,TIUAMND,TIUSNM,TIUSBLK,TIUCSNM,TIUCSBLK,DIE,DR + N DA,DFN,DIWESUB,TIU,TIUODA,TIUTITL,TIUCLSS,TIUCON,TIUCNSLT,TIUPRF,TIUFLAG + K ^TMP("TIURTRCT",$J) + ; TIU*155 Gets consult data if exists + S TIUTITL=$P($G(^TIU(8925,TIUDA,0)),U) + S TIUCLSS=$$CLASS^TIUCNSLT() + S TIUCON=+$$ISA^TIULX(TIUTITL,TIUCLSS) + S TIUCNSLT=+$P($G(^TIU(8925,TIUDA,14)),U,5) + S TIUPRF=0,TIUFLAG=0 + D ISPRFTTL^TIUPRF2(.TIUPRF,TIUTITL) + I TIUPRF S TIUFLAG=$$FNDACTIF^TIUPRFL(TIUDA) + L +^TIU(8925,+TIUDA):1 + E D Q + . W !?5,$C(7),"Another user is editing this entry." H 3 + . S TIUCHNG("REFRESH")=1 + I +$P($G(^TIU(8925,+TIUDA,0)),U,5)'>6 D Q + . W !?5,$C(7),"Only SIGNED Documents may be amended." + . I $$READ^TIUU("EA","Press RETURN to continue...") ; pause + . S TIUCHNG("REFRESH")=1 + I +$$HASIMG^TIURB2(TIUDA) D IMGNOTE^TIURB2 Q + S TIUAMND=$$CANDO^TIULP(TIUDA,"AMENDMENT") + I +TIUAMND'>0 D Q + . W !!,$C(7),$C(7),$C(7),$P(TIUAMND,U,2),! + . S TIUCHNG("REFRESH")=1 + . I $$READ^TIUU("EA","Press RETURN to continue...") ; pause + W !!,"Before proceeding, please enter your Electronic Signature Code..." + S TIUAMND=$$GETSIG^TIURD2 + I +TIUAMND'>0 D Q + . W !!," Ok, no harm done...",! + . S TIUCHNG("REFRESH")=1 + . I $$READ^TIUU("EA","Press RETURN to continue...") ; pause + W !!,"The ORIGINAL document will be RETRACTED, and a copy will be amended...",! + S TIUODA=TIUDA + S TIUDA=+$$RETRACT^TIURD2(TIUDA,"",7) + I '+TIUDA D Q + . W !!,$C(7),$C(7),$C(7),"Retraction of Original Document Failed.",! + . I $$READ^TIUU("EA","Press RETURN to continue...") ; pause + . S TIUDA=TIUODA,TIUCHNG("REFRESH")=1 + L +^TIU(8925,TIUDA):1 + E D Q + . W !?5,$C(7),"Another user is editing this entry." + . D RECOVER^TIURD4(TIUODA,TIUDA) H 3 + . S TIUPRF=$$LINK^TIUPRF1(TIUODA,+TIUFLAG,$P(TIUFLAG,U,2),$P($G(^TIU(8925,TIUODA,0)),U,2)) + . S TIUDA=TIUODA,TIUCHNG("REFRESH")=1 + S TIUSNM=$$DECRYPT^TIULC1($P(^TIU(8925,TIUDA,15),U,3),1,$$CHKSUM^TIULC("^TIU(8925,"_TIUDA_",""TEXT"")")) + S TIUSBLK=$$DECRYPT^TIULC1($P($G(^TIU(8925,TIUDA,15)),U,4),1,$$CHKSUM^TIULC("^TIU(8925,"_TIUDA_",""TEXT"")")) + S TIUCSNM=$$DECRYPT^TIULC1($P(^TIU(8925,TIUDA,15),U,9),1,$$CHKSUM^TIULC("^TIU(8925,"_TIUDA_",""TEXT"")")) + S TIUCSBLK=$$DECRYPT^TIULC1($P($G(^TIU(8925,TIUDA,15)),U,10),1,$$CHKSUM^TIULC("^TIU(8925,"_TIUDA_",""TEXT"")")) + S TIUTYP=+$G(^TIU(8925,+TIUDA,0)),TIUT0=$G(^TIU(8925.1,+TIUTYP,0)) + S TIUTYP(1)="1^"_+TIUTYP_U_$P(TIUT0,U,3)_U + S DFN=$P($G(^TIU(8925,+TIUDA,0)),U,2) + D GETTIU^TIULD(.TIU,TIUDA) + S DIWESUB="Patient: "_$G(TIU("PNM")) + S TIUCHNG=0 D FULL^VALM1,TEXTEDIT^TIUEDI4(TIUDA,.TIUCMT,.TIUCHNG) + I '+$G(TIUCHNG) D Q + . L -^TIU(8925,TIUDA) + . D RECOVER^TIURD4(TIUODA,TIUDA) + . S TIUPRF=$$LINK^TIUPRF1(TIUODA,+TIUFLAG,$P(TIUFLAG,U,2),$P($G(^TIU(8925,TIUODA,0)),U,2)) + . L -^TIU(8925,TIUODA) H 3 + . S TIUDA=TIUODA,TIUCHNG("REFRESH")=1 + I +$G(TIUCHNG) D + . S DR=".05///AMENDED;1601////"_$$NOW^XLFDT_";1602////"_DUZ,DA=TIUDA,TIUSIG=0 + . S DR=DR_";1603////"_$$NOW^XLFDT_";1604///^S X=$$SIGNAME^TIULS(DUZ);1605///^S X=$$SIGTITL^TIULS(DUZ)",TIUSIG=1 + . S DIE=8925 D ^DIE + . ; Refile /es/-block fields + . S DR="1503///^S X=TIUSNM;1504///^S X=TIUSBLK;1509///^S X=TIUCSNM;1510///^S X=TIUCSBLK" + . D ^DIE + ; Drop Locks on both documents + L -^TIU(8925,+TIUDA) + L -^TIU(8925,+TIUODA) + S TIUDAARY(TIUI)=TIUDA + S TIUCHNG("RBLD")=1 + ; if note is associated with a patient record flag - clean up + I +TIUFLAG S TIUPRF=$$LINK^TIUPRF1(TIUDA,+TIUFLAG,$P(TIUFLAG,U,2),$P($G(^TIU(8925,TIUDA,0)),U,2)) + ; TIU*155 If note is associated with a consult update ^GMR global + ; to include the amended note + ; Rollback retracted note from ^GMR(123 node 50 + I $G(TIUCON)=1 D + . N STATUS,GMRCSTAT,TIUAUTH + . S STATUS=$P($G(^TIU(8925,TIUDA,0)),U,5) + . S GMRCSTAT=$S(STATUS>6:"COMPLETED",1:"INCOMPLETE") + . S TIUAUTH=$P($G(^TIU(8925,TIUDA,12)),U,2) + . D ROLLBACK^TIUCNSLT(TIUODA) + . D GET^GMRCTIU(TIUCNSLT,TIUDA,GMRCSTAT,TIUAUTH) + Q +SENDBACK ; Send back a Document to transcription + N TIUDA,DFN,TIU,TIUDATA,TIUCHNG,TIUI,TIUY,Y,DIROUT,TIULST + N TIUDAARY + I '$D(VALMY) D EN^VALM2(XQORNOD(0)) + S TIUI=0 + I +$O(VALMY(0)) D CLEAR^VALM1 + F S TIUI=$O(VALMY(TIUI)) Q:+TIUI'>0 D Q:$D(DIROUT) + . N TIU,RSTRCTD + . S TIUDATA=$G(^TMP("TIURIDX",$J,TIUI)) + . S TIUDA=+$P(TIUDATA,U,2) S RSTRCTD=$$DOCRES^TIULRR(TIUDA) + . I RSTRCTD D Q + . . W !!,$C(7),"Ok, no harm done...",! ; Echo denial message + . . I $$READ^TIUU("EA","RETURN to continue...") ; pause + . S TIUDAARY(TIUI)=TIUDA + . S TIUCHNG=0 + . D EN^VALM("TIU SEND BACK") + . I +$G(TIUCHNG) D + . . S TIULST=$G(TIULST)_$S($G(TIULST)]"":",",1:"")_TIUI +SENDX ; Revise list and cycle back as appropriate + I $G(TIUCHNG("ADDM"))!$G(TIUCHNG("DELETE")) S TIUCHNG("RBLD")=1 + E S TIUCHNG("UPDATE")=1 + D UPRBLD^TIURL(.TIUCHNG,.VALMY) K VALMY + S VALMBCK="R" + D VMSG^TIURS1($G(TIULST),.TIUDAARY,"sent back") + Q +LINK ; Link to problem(s) + N TIUCHNG,TIUDA,DFN,TIU,TIUDATA,TIUEDIT,TIUI,TIUY,TIULST,Y,DIROUT + N TIUDAARY + I '$D(VALMY) D EN^VALM2(XQORNOD(0)) + S TIUI=0 + I +$O(VALMY(0)) D CLEAR^VALM1 + F S TIUI=$O(VALMY(TIUI)) Q:+TIUI'>0 D Q:$D(DIROUT) + . N TIU,VALMY,XQORM,VA,VADM,GMPDFN,GMPLUSER,RSTRCTD + . S TIUDATA=$G(^TMP("TIURIDX",$J,TIUI)) + . S TIUDA=+$P(TIUDATA,U,2),GMPLUSER=1 + . I '$D(^TIU(8925,+TIUDA,0)) D Q + . . W !,$C(7),"Document no longer exists.",! + . . I $$READ^TIUU("EA","Press RETURN to continue...") W "" + . S RSTRCTD=$$DOCRES^TIULRR(TIUDA) + . I RSTRCTD D Q + . . W !!,$C(7),"Ok, no harm done...",! ; Echo denial message + . . I $$READ^TIUU("EA","RETURN to continue...") ; pause + . S TIUDAARY(TIUI)=TIUDA + . S DFN=+$P($G(^TIU(8925,+TIUDA,0)),U,2) + . I +DFN D DEM^VADPT S GMPDFN=DFN_U_VADM(1)_U_$E(VADM(1))_VA("BID") + . S TIUCHNG=0 + . D EN^VALM("TIU LINK TO PROBLEM") + . I +$G(TIUCHNG) S TIULST=$G(TIULST)_$S($G(TIULST)]"":",",1:"")_TIUI +LINKX ; Revise list and cycle back as appropriate + S TIUCHNG("REFRESH")=1 + D UPRBLD^TIURL(.TIUCHNG,.VALMY) K VALMY + S VALMBCK="R" + D VMSG^TIURS1($G(TIULST),.TIUDAARY,"linked to problems") + Q +DEL(DA) ; -- Call to DEL for backward compatibility + G GODEL^TIURB2 + Q diff --git a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIURL.m b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIURL.m index c7877e08..21a3181a 100644 --- a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIURL.m +++ b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIURL.m @@ -1,99 +1,94 @@ -TIURL ; SLC/JER - List Management Library ;2/21/01 - ;;1.0;TEXT INTEGRATION UTILITIES;**88,100,224**;Jun 20, 1997;Build 7 - ; 11/14/00 Moved UPDATEID, etc to TIURL1 - ; -UPRBLD(TIUCHNG,ITEMS) ; Refreshes, updates, or rebuilds the list - ;after various actions. Also restores video. - ; Receives optional arrays TIUCHNG, ITEMS by ref. - ; Checks TIUCHNG("RBLD"),TIUCHNG("UPDATE"), & TIUCHNG("REFRESH"); - ;does nothing if none of these is defined. - ; Items in ITEMS list are updated (depending on TIUCHNG), and - ;their video attributes are restored. - N TIUI,TIUREC,TIUJ,RTN - S RTN=$G(^TMP("TIUR",$J,"RTN")) - ; -- Restore video attributes for selected items: - ; (Rebuild code, except for TIUROR, does its own video restore) - I '$G(TIUCHNG("RBLD"))!(RTN="TIUROR") D - . S TIUJ=0 - . F S TIUJ=$O(ITEMS(TIUJ)) Q:'TIUJ D - . . Q:TIUJ=$P($G(TIUGLINK),U,2) ; Don't restore midattach ID child - . . D RESTORE^VALM10(TIUJ) - ; -- If TIUROR screen needs changes, it is always - ; rebuilt, not updated: - I RTN="TIUROR",$G(TIUCHNG("UPDATE")) S TIUCHNG("RBLD")=1 - ;VMP/ELR ADDED THE FOLLOWING 2 LINES IN PATCH 224 - I RTN="TIUR",$G(TIUCHNG("UPDATE")) S TIUCHNG("RBLD")=1 - I RTN="TIURM",$G(TIUCHNG("UPDATE")) S TIUCHNG("RBLD")=1 - ; -- Rebuild, Update, or Refresh list: - ; (In cases (e.g.browse) where more than one action - ; was performed, TIUCHNG("RBLD") may coexist w TIUCHNG("UPDATE"), - ; etc., so order is important.) - I $G(TIUCHNG("RBLD")) D Q - . W !,"Rebuilding the list..." - . I RTN="TIUROR" D RBLD^TIUROR Q - . ; -- If not in 2b, pause for feedback ("Rebuilding", - . ; "Entry deleted", etc): - . H 2 - . I RTN="TIURM" D RBLD^TIURM Q - . I RTN="TIURPTTL" D RBLD^TIURPTTL Q - . I RTN="TIURTITL" D RBLD^TIURTITL Q - . I RTN="TIUR" D RBLD^TIUR - I $G(TIUCHNG("UPDATE")),$D(ITEMS) D Q - . S TIUI="" - . W !,"Updating the list..." - . F S TIUI=$O(ITEMS(TIUI)) Q:'TIUI D - . . D SETREC(TIUI,.TIUREC) - . . ;VMP/ELR ADDED THE FOLLOWING LINE IN PATCH 224 - . . I $G(TIUREC)="" Q - . . S ^TMP("TIUR",$J,TIUI,0)=TIUREC - I $G(TIUCHNG("REFRESH")) D Q - . W !,"Refreshing the list..." - Q - ; -SETREC(LINENO,TIUREC,PFIXFLAG) ; Update line LINENO with [new prefix], new flds - ; Combined fields so that SETREC works for MIS as well as - ;CLINICIAN LM templates - ; PFIXFLAG=1: update prefix (as well as other flds). - ; New prefix is for unexpanded state of line. - N DIC,DIQ,DA,DR,TIUR,ADT,DDT,LCT,AUT,AMD,EDT,SDT,TIULST4 - N MOM,DOC,MISEDT,ITEMNODE - S ITEMNODE=^TMP("TIURIDX",$J,LINENO) - S DA=+$P(ITEMNODE,U,2) - S DIQ="TIUR",DIC=8925,DIQ(0)="IE" - S DR=".01;.02;.05;.07;.08;.1;1202;1204;1208;1209;1301;1307;1501;1507" - D EN^DIQ1 Q:$D(TIUR)'>9 - S DOC=$$PNAME^TIULC1(+TIUR(8925,DA,.01,"I")) - I DOC="Addendum" D - . S MOM=+$P(^TIU(8925,DA,0),U,6) - . S DOC=DOC_" to "_$$PNAME^TIULC1(+$G(^TIU(8925,MOM,0))) - S TIULST4=$E($P($G(^DPT(TIUR(8925,DA,.02,"I"),0)),U,9),6,9) - S TIULST4="("_$E(TIUR(8925,DA,.02,"E"))_TIULST4_")" - S ADT=$$DATE^TIULS(TIUR(8925,DA,.07,"I"),"MM/DD/YY") - S DDT=$$DATE^TIULS(TIUR(8925,DA,.08,"I"),"MM/DD/YY") - S AMD=$$NAME^TIULS(TIUR(8925,DA,1208,"E"),"LAST, FI MI") - S AUT=$$NAME^TIULS(TIUR(8925,DA,1202,"E"),"LAST, FI MI") - S EDT=$$DATE^TIULS(TIUR(8925,DA,1301,"I"),"MM/DD/YY") - S MISEDT=$$DATE^TIULS(TIUR(8925,DA,1307,"I"),"MM/DD/YY") - S SDT=$S(+TIUR(8925,DA,1507,"I"):TIUR(8925,DA,1507,"I"),TIUR(8925,DA,.05,"I")'<7:+TIUR(8925,DA,1501,"I"),1:"") - S SDT=$$DATE^TIULS(SDT,"MM/DD/YY") - S LCT=$G(TIUR(8925,DA,.1,"E")) - ; -- Set prefix_patient/title into ^TMP("TIUR",$J,LINENO,0), - ; then into TIUREC: -- - I $G(PFIXFLAG) D SETPT^TIURL1(LINENO) - S TIUREC=^TMP("TIUR",$J,LINENO,0) - ; -- Set other fields into TIUREC: -- - S TIUREC=$$SETFLD^VALM1(LINENO,TIUREC,"NUMBER") - S TIUREC=$$SETFLD^VALM1($$LOWER^TIULS(TIUR(8925,DA,.05,"E")),TIUREC,"STATUS") - S TIUREC=$$SETFLD^VALM1(TIULST4,TIUREC,"LAST I/LAST 4") - S TIUREC=$$SETFLD^VALM1(DOC,TIUREC,"DOCUMENT TYPE") - S:$D(VALMDDF("ADMISSION DATE")) TIUREC=$$SETFLD^VALM1(ADT,TIUREC,"ADMISSION DATE") - S:$D(VALMDDF("DISCH DATE")) TIUREC=$$SETFLD^VALM1(AMD,TIUREC,"DISCH DATE") - S:$D(VALMDDF("DICT DATE")) TIUREC=$$SETFLD^VALM1(MISEDT,TIUREC,"DICT DATE") - S:$D(VALMDDF("LINE COUNT")) TIUREC=$$SETFLD^VALM1(LCT,TIUREC,"LINE COUNT") - S:$D(VALMDDF("REF DATE")) TIUREC=$$SETFLD^VALM1(EDT,TIUREC,"REF DATE") - S:$D(VALMDDF("SIG DATE")) TIUREC=$$SETFLD^VALM1(SDT,TIUREC,"SIG DATE") - S TIUREC=$$SETFLD^VALM1(AUT,TIUREC,"AUTHOR") - S:$D(VALMDDF("COSIGNER")) TIUREC=$$SETFLD^VALM1(AMD,TIUREC,"COSIGNER") - S:$D(VALMDDF("ATTENDING")) TIUREC=$$SETFLD^VALM1(AMD,TIUREC,"ATTENDING") - S ^TMP("TIUR",$J,LINENO,0)=TIUREC - Q +TIURL ; SLC/JER - List Management Library ;2/21/01 + ;;1.0;TEXT INTEGRATION UTILITIES;**88,100**;Jun 20, 1997 + ; 11/14/00 Moved UPDATEID, etc to TIURL1 + ; +UPRBLD(TIUCHNG,ITEMS) ; Refreshes, updates, or rebuilds the list + ;after various actions. Also restores video. + ; Receives optional arrays TIUCHNG, ITEMS by ref. + ; Checks TIUCHNG("RBLD"),TIUCHNG("UPDATE"), & TIUCHNG("REFRESH"); + ;does nothing if none of these is defined. + ; Items in ITEMS list are updated (depending on TIUCHNG), and + ;their video attributes are restored. + N TIUI,TIUREC,TIUJ,RTN + S RTN=$G(^TMP("TIUR",$J,"RTN")) + ; -- Restore video attributes for selected items: + ; (Rebuild code, except for TIUROR, does its own video restore) + I '$G(TIUCHNG("RBLD"))!(RTN="TIUROR") D + . S TIUJ=0 + . F S TIUJ=$O(ITEMS(TIUJ)) Q:'TIUJ D + . . Q:TIUJ=$P($G(TIUGLINK),U,2) ; Don't restore midattach ID child + . . D RESTORE^VALM10(TIUJ) + ; -- If TIUROR screen needs changes, it is always + ; rebuilt, not updated: + I RTN="TIUROR",$G(TIUCHNG("UPDATE")) S TIUCHNG("RBLD")=1 + ; -- Rebuild, Update, or Refresh list: + ; (In cases (e.g.browse) where more than one action + ; was performed, TIUCHNG("RBLD") may coexist w TIUCHNG("UPDATE"), + ; etc., so order is important.) + I $G(TIUCHNG("RBLD")) D Q + . W !,"Rebuilding the list..." + . I RTN="TIUROR" D RBLD^TIUROR Q + . ; -- If not in 2b, pause for feedback ("Rebuilding", + . ; "Entry deleted", etc): + . H 2 + . I RTN="TIURM" D RBLD^TIURM Q + . I RTN="TIURPTTL" D RBLD^TIURPTTL Q + . I RTN="TIURTITL" D RBLD^TIURTITL Q + . I RTN="TIUR" D RBLD^TIUR + I $G(TIUCHNG("UPDATE")),$D(ITEMS) D Q + . S TIUI="" + . W !,"Updating the list..." + . F S TIUI=$O(ITEMS(TIUI)) Q:'TIUI D + . . D SETREC(TIUI,.TIUREC) + . . S ^TMP("TIUR",$J,TIUI,0)=TIUREC + I $G(TIUCHNG("REFRESH")) D Q + . W !,"Refreshing the list..." + Q + ; +SETREC(LINENO,TIUREC,PFIXFLAG) ; Update line LINENO with [new prefix], new flds + ; Combined fields so that SETREC works for MIS as well as + ;CLINICIAN LM templates + ; PFIXFLAG=1: update prefix (as well as other flds). + ; New prefix is for unexpanded state of line. + N DIC,DIQ,DA,DR,TIUR,ADT,DDT,LCT,AUT,AMD,EDT,SDT,TIULST4 + N MOM,DOC,MISEDT,ITEMNODE + S ITEMNODE=^TMP("TIURIDX",$J,LINENO) + S DA=+$P(ITEMNODE,U,2) + S DIQ="TIUR",DIC=8925,DIQ(0)="IE" + S DR=".01;.02;.05;.07;.08;.1;1202;1204;1208;1209;1301;1307;1501;1507" + D EN^DIQ1 Q:$D(TIUR)'>9 + S DOC=$$PNAME^TIULC1(+TIUR(8925,DA,.01,"I")) + I DOC="Addendum" D + . S MOM=+$P(^TIU(8925,DA,0),U,6) + . S DOC=DOC_" to "_$$PNAME^TIULC1(+$G(^TIU(8925,MOM,0))) + S TIULST4=$E($P($G(^DPT(TIUR(8925,DA,.02,"I"),0)),U,9),6,9) + S TIULST4="("_$E(TIUR(8925,DA,.02,"E"))_TIULST4_")" + S ADT=$$DATE^TIULS(TIUR(8925,DA,.07,"I"),"MM/DD/YY") + S DDT=$$DATE^TIULS(TIUR(8925,DA,.08,"I"),"MM/DD/YY") + S AMD=$$NAME^TIULS(TIUR(8925,DA,1208,"E"),"LAST, FI MI") + S AUT=$$NAME^TIULS(TIUR(8925,DA,1202,"E"),"LAST, FI MI") + S EDT=$$DATE^TIULS(TIUR(8925,DA,1301,"I"),"MM/DD/YY") + S MISEDT=$$DATE^TIULS(TIUR(8925,DA,1307,"I"),"MM/DD/YY") + S SDT=$S(+TIUR(8925,DA,1507,"I"):TIUR(8925,DA,1507,"I"),TIUR(8925,DA,.05,"I")'<7:+TIUR(8925,DA,1501,"I"),1:"") + S SDT=$$DATE^TIULS(SDT,"MM/DD/YY") + S LCT=$G(TIUR(8925,DA,.1,"E")) + ; -- Set prefix_patient/title into ^TMP("TIUR",$J,LINENO,0), + ; then into TIUREC: -- + I $G(PFIXFLAG) D SETPT^TIURL1(LINENO) + S TIUREC=^TMP("TIUR",$J,LINENO,0) + ; -- Set other fields into TIUREC: -- + S TIUREC=$$SETFLD^VALM1(LINENO,TIUREC,"NUMBER") + S TIUREC=$$SETFLD^VALM1($$LOWER^TIULS(TIUR(8925,DA,.05,"E")),TIUREC,"STATUS") + S TIUREC=$$SETFLD^VALM1(TIULST4,TIUREC,"LAST I/LAST 4") + S TIUREC=$$SETFLD^VALM1(DOC,TIUREC,"DOCUMENT TYPE") + S:$D(VALMDDF("ADMISSION DATE")) TIUREC=$$SETFLD^VALM1(ADT,TIUREC,"ADMISSION DATE") + S:$D(VALMDDF("DISCH DATE")) TIUREC=$$SETFLD^VALM1(AMD,TIUREC,"DISCH DATE") + S:$D(VALMDDF("DICT DATE")) TIUREC=$$SETFLD^VALM1(MISEDT,TIUREC,"DICT DATE") + S:$D(VALMDDF("LINE COUNT")) TIUREC=$$SETFLD^VALM1(LCT,TIUREC,"LINE COUNT") + S:$D(VALMDDF("REF DATE")) TIUREC=$$SETFLD^VALM1(EDT,TIUREC,"REF DATE") + S:$D(VALMDDF("SIG DATE")) TIUREC=$$SETFLD^VALM1(SDT,TIUREC,"SIG DATE") + S TIUREC=$$SETFLD^VALM1(AUT,TIUREC,"AUTHOR") + S:$D(VALMDDF("COSIGNER")) TIUREC=$$SETFLD^VALM1(AMD,TIUREC,"COSIGNER") + S:$D(VALMDDF("ATTENDING")) TIUREC=$$SETFLD^VALM1(AMD,TIUREC,"ATTENDING") + S ^TMP("TIUR",$J,LINENO,0)=TIUREC + Q diff --git a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIURM.m b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIURM.m index 1b64cc01..a3ef20b6 100644 --- a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIURM.m +++ b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIURM.m @@ -1,123 +1,120 @@ -TIURM ; SLC/JER - MIS Document Review ;9/24/03 - ;;1.0;TEXT INTEGRATION UTILITIES;**74,79,58,100,113,216,224**;Jun 20, 1997;Build 7 - ;12/7/00 split TIURM into TIURM & TIURM1 -MAKELIST(TIUCLASS) ; Get Search Criteria - N DIRUT,DTOUT,DUOUT,TIUI,STATUS,TIUTYP,TIUSTAT,TIUEDFLT,TIUDCL - N TIUDPRMT,STATWORD,STATIFN,NOWFLAG,TIUK - K DIROUT - D INITRR^TIULRR(0) -DIVISION ; Select Division(s) - D SELDIV^TIULA - I SELDIV'>0 S VALMQUIT=1 Q - I $D(TIUDI) D - . S TIUK=0 F S TIUK=$O(TIUDI(TIUK)) Q:'TIUK D - . . S TIUDI("ENTRIES")=$G(TIUDI("ENTRIES"))_TIUK_";" - E S TIUDI("ENTRIES")="ALL DIVISIONS" -STATUS S STATUS=$S($D(TIUQUIK):$$SELSTAT^TIULA(.TIUSTAT,"F","UNSIGNED,UNCOSIGNED"),1:$$SELSTAT^TIULA(.TIUSTAT,"A",$$DFLTSTAT(DUZ))) - ;VMP/ELR changed status ck from <0 TO <1 to account for entering an * p224 - I +STATUS<1 S VALMQUIT=1 Q - S TIUI=0 - F S TIUI=$O(TIUSTAT(TIUI)) Q:'TIUI D - . S STATIFN=$O(^TIU(8925.6,"B",$$UPPER^TIULS($P(TIUSTAT(TIUI),U,3)),0)) - . Q:'STATIFN - . S STATUS("IFNS")=$G(STATUS("IFNS"))_STATIFN_";" - S TIUI=1,STATWORD=$$UPPER^TIULS($P(TIUSTAT(1),U,3)) - I +$G(TIUSTAT(4))'>0 F S TIUI=$O(TIUSTAT(TIUI)) Q:+TIUI'>0 D - . S STATWORD=STATWORD_$S(TIUI=+TIUSTAT(1):" & ",1:", ")_$$UPPER^TIULS($P(TIUSTAT(TIUI),U,3)) - I +$G(TIUSTAT(4))>0 S STATWORD=$S($P(TIUSTAT(4),U,4)="ALL":"ALL",1:STATWORD_", OTHER") - S STATUS("WORDS")=STATWORD -DOCTYPE ; Select Document Type(s) - N TIUDCL - ; -- Ask user for docmt types and set ^TMP("TIUTYP",$J): - D SELTYP^TIULA(TIUCLASS,.TIUTYP,"A","LAST","DOC",0,.TIUDCL) - I +$G(DIROUT) S VALMQUIT=1 Q - I +$G(@TIUTYP)'>0,'$D(TIUQUIK) K @TIUTYP G STATUS - D CHECKADD -ERLY S TIUEDFLT=$S(TIUCLASS=3:"T-2",TIUCLASS=244:"T-30",1:"T-7") - S TIUDPRMT="Entry" - S TIUEDT=$S($D(TIUQUIK):1,1:$$EDATE^TIULA(TIUDPRMT,"",TIUEDFLT)) - I +$G(DIROUT) S VALMQUIT=1 Q - I TIUEDT'>0 K @TIUTYP G DOCTYPE -LATE S TIULDT=$S($D(TIUQUIK):9999999,1:$$LDATE^TIULA(TIUDPRMT)) - I +$G(DIROUT) S VALMQUIT=1 Q - I TIULDT'>0 G ERLY - I TIUEDT>TIULDT D SWAP(.TIUEDT,.TIULDT) - I $L(TIULDT,".")=1 D EXPRANGE(.TIUEDT,.TIULDT) ; P74. Add late date time whether or not late date is same as early date. - ; -- Reset late date to NOW on rebuild: - S NOWFLAG=$S(TIULDT-$$NOW^XLFDT<.0001:1,1:0) - I '$G(TIURBLD) W !,"Searching for the documents." - D BUILD(TIUCLASS,.STATUS,TIUEDT,TIULDT,NOWFLAG,.TIUDI) - ; -- If attaching ID note & changed view, - ; update video for line to be attached: -- - I $G(TIUGLINK) D RESTOREG^TIULM(.TIUGLINK) - K TIUDI,SELDIV - Q -CHECKADD ; Checks whether Addendum is included in the list of types - N TIUI,HIT,NUMTYPS - S (TIUI,HIT)=0 - F S TIUI=$O(^TMP("TIUTYP",$J,TIUI)) Q:+TIUI'>0!+HIT I $$UP^XLFSTR(^TMP("TIUTYP",$J,TIUI))["ADDENDUM" S HIT=1 - S NUMTYPS=^TMP("TIUTYP",$J) - I +HIT'>0 S ^TMP("TIUTYP",$J,NUMTYPS+1)=+^TMP("TIUTYP",$J,NUMTYPS)+1_U_"81^Addendum^NOT PICKED",^TMP("TIUTYP",$J)=^TMP("TIUTYP",$J)+1 - Q -SWAP(TIUX,TIUY) ; Swap any two variables - N TIUTMP S TIUTMP=TIUX,TIUX=TIUY,TIUY=TIUTMP - Q -EXPRANGE(TIUX,TIUY) ; Expand late date to include time - ;P74 If user entered date/time = T, then numerical date time is FIRST ^ PIECE ONLY of TIUX & TIUY. - I $P(TIUY,U)=DT S TIUY=$$NOW^XLFDT I 1 - E S TIUY=$P(TIUY,U)_"."_235959 ;P74 Add seconds - Q -BUILD(TIUCLASS,STATUS,EARLY,LATE,NOWFLAG,TIUDI) ; Build List - N TIUPREF - S TIUPREF=$$PERSPRF^TIULE(DUZ) - K ^TMP("TIUR",$J),^TMP("TIURIDX",$J),^TMP("TIUI",$J) - ; If user entered NOW at first build, update NOW for rebuild; - ; Save data in ^TMP("TIURIDX",$J,0) for rebuild: - I $G(TIURBLD),$G(NOWFLAG) S LATE=$$NOW^XLFDT - S ^TMP("TIURIDX",$J,0)=+EARLY_U_+LATE_U_$G(STATUS("IFNS"))_U_NOWFLAG - S ^TMP("TIUR",$J,"RTN")="TIURM" - I '$D(TIUPRM0)!'$D(TIUPRM0) D SETPARM^TIULE - S EARLY=+$G(EARLY,0),LATE=+$G(LATE,3333333) - D GATHER^TIURM1(TIUPREF,TIUCLASS,STATUS("IFNS"),EARLY,LATE,.TIUDI) - D PUTLIST^TIURM1(TIUPREF,TIUCLASS,.STATUS,.TIUDI) - K ^TMP("TIUI",$J) - Q -CLEAN ; Clean up your mess! - K ^TMP("TIUR",$J),^TMP("TIURIDX",$J) D CLEAN^VALM10,KILLRR^TIULRR - K VALMY - K ^TMP("TIUTYP",$J) - Q -URGENCY(TIUDA) ; What is the urgency of the current document - N TIUY,TIUD0,TIUDSTAT,TIUDURG - S TIUD0=$G(^TIU(8925,+TIUDA,0)),TIUDSTAT=$P(TIUD0,U,5) - S TIUDURG=$P(TIUD0,U,9) - S TIUY=$S(TIUDSTAT<7:$S(TIUDURG="P":1,1:2),1:3) - Q TIUY -DFLTSTAT(USER) ; Set default STATUS for current user - N TIUMIS,TIUMD,TIUY,TIUDPRM D DOCPRM^TIULC1(244,.TIUDPRM) - S TIUMIS=$$ISA^USRLM(DUZ,"MEDICAL INFORMATION SECTION") - I +TIUMIS,+$P($G(TIUDPRM(0)),U,3) S TIUY="UNVERIFIED" G DFLTX - I $$ISA^USRLM(DUZ,"PROVIDER") S TIUY="COMPLETED" G DFLTX - S TIUY="COMPLETED" -DFLTX Q TIUY - ; -RBLD ; Rebuild list after actions 11/30/00 - N TIUEXP,TIUR0,TIURIDX0,TIUEDT,TIULDT - N TIURBLD,TIUI,TIUCLASS,TIUDI,TIUSCRN - S TIURBLD=1 - D FIXLSTNW^TIULM ;restore video for elements added to end of list - I +$O(^TMP("TIUR",$J,"EXPAND",0)) D - . M TIUEXP=^TMP("TIUR",$J,"EXPAND") - S TIUR0=^TMP("TIUR",$J,0),TIURIDX0=^TMP("TIURIDX",$J,0) - S TIUCLASS=^TMP("TIUR",$J,"CLASS") - S STATUS("WORDS")=$P(TIUR0,U,2) - S STATUS("IFNS")=$P(TIURIDX0,U,3) - S TIUEDT=$P(TIURIDX0,U),TIULDT=$P(TIURIDX0,U,2),NOWFLAG=+$P(TIURIDX0,U,4) - M TIUDI=^TMP("TIUR",$J,"DIV") - ;VMP/ELR ADDED THE FOLLOWING LINE IN PATCH 224 - S TIUSCRN="ALL" - D BUILD(TIUCLASS,.STATUS,TIUEDT,TIULDT,NOWFLAG,.TIUDI) - ; Reexpand previously expanded items: - D RELOAD^TIUROR1(.TIUEXP) - D BREATHE^TIUROR1(1) - Q +TIURM ; SLC/JER - MIS Document Review ;9/24/03 + ;;1.0;TEXT INTEGRATION UTILITIES;**74,79,58,100,113,216**;Jun 20, 1997 + ;12/7/00 split TIURM into TIURM & TIURM1 +MAKELIST(TIUCLASS) ; Get Search Criteria + N DIRUT,DTOUT,DUOUT,TIUI,STATUS,TIUTYP,TIUSTAT,TIUEDFLT,TIUDCL + N TIUDPRMT,STATWORD,STATIFN,NOWFLAG,TIUK + K DIROUT + D INITRR^TIULRR(0) +DIVISION ; Select Division(s) + D SELDIV^TIULA + I SELDIV'>0 S VALMQUIT=1 Q + I $D(TIUDI) D + . S TIUK=0 F S TIUK=$O(TIUDI(TIUK)) Q:'TIUK D + . . S TIUDI("ENTRIES")=$G(TIUDI("ENTRIES"))_TIUK_";" + E S TIUDI("ENTRIES")="ALL DIVISIONS" +STATUS S STATUS=$S($D(TIUQUIK):$$SELSTAT^TIULA(.TIUSTAT,"F","UNSIGNED,UNCOSIGNED"),1:$$SELSTAT^TIULA(.TIUSTAT,"A",$$DFLTSTAT(DUZ))) + I +STATUS<0 S VALMQUIT=1 Q + S TIUI=0 + F S TIUI=$O(TIUSTAT(TIUI)) Q:'TIUI D + . S STATIFN=$O(^TIU(8925.6,"B",$$UPPER^TIULS($P(TIUSTAT(TIUI),U,3)),0)) + . Q:'STATIFN + . S STATUS("IFNS")=$G(STATUS("IFNS"))_STATIFN_";" + S TIUI=1,STATWORD=$$UPPER^TIULS($P(TIUSTAT(1),U,3)) + I +$G(TIUSTAT(4))'>0 F S TIUI=$O(TIUSTAT(TIUI)) Q:+TIUI'>0 D + . S STATWORD=STATWORD_$S(TIUI=+TIUSTAT(1):" & ",1:", ")_$$UPPER^TIULS($P(TIUSTAT(TIUI),U,3)) + I +$G(TIUSTAT(4))>0 S STATWORD=$S($P(TIUSTAT(4),U,4)="ALL":"ALL",1:STATWORD_", OTHER") + S STATUS("WORDS")=STATWORD +DOCTYPE ; Select Document Type(s) + N TIUDCL + ; -- Ask user for docmt types and set ^TMP("TIUTYP",$J): + D SELTYP^TIULA(TIUCLASS,.TIUTYP,"A","LAST","DOC",0,.TIUDCL) + I +$G(DIROUT) S VALMQUIT=1 Q + I +$G(@TIUTYP)'>0,'$D(TIUQUIK) K @TIUTYP G STATUS + D CHECKADD +ERLY S TIUEDFLT=$S(TIUCLASS=3:"T-2",TIUCLASS=244:"T-30",1:"T-7") + S TIUDPRMT="Entry" + S TIUEDT=$S($D(TIUQUIK):1,1:$$EDATE^TIULA(TIUDPRMT,"",TIUEDFLT)) + I +$G(DIROUT) S VALMQUIT=1 Q + I TIUEDT'>0 K @TIUTYP G DOCTYPE +LATE S TIULDT=$S($D(TIUQUIK):9999999,1:$$LDATE^TIULA(TIUDPRMT)) + I +$G(DIROUT) S VALMQUIT=1 Q + I TIULDT'>0 G ERLY + I TIUEDT>TIULDT D SWAP(.TIUEDT,.TIULDT) + I $L(TIULDT,".")=1 D EXPRANGE(.TIUEDT,.TIULDT) ; P74. Add late date time whether or not late date is same as early date. + ; -- Reset late date to NOW on rebuild: + S NOWFLAG=$S(TIULDT-$$NOW^XLFDT<.0001:1,1:0) + I '$G(TIURBLD) W !,"Searching for the documents." + D BUILD(TIUCLASS,.STATUS,TIUEDT,TIULDT,NOWFLAG,.TIUDI) + ; -- If attaching ID note & changed view, + ; update video for line to be attached: -- + I $G(TIUGLINK) D RESTOREG^TIULM(.TIUGLINK) + K TIUDI,SELDIV + Q +CHECKADD ; Checks whether Addendum is included in the list of types + N TIUI,HIT,NUMTYPS + S (TIUI,HIT)=0 + F S TIUI=$O(^TMP("TIUTYP",$J,TIUI)) Q:+TIUI'>0!+HIT I $$UP^XLFSTR(^TMP("TIUTYP",$J,TIUI))["ADDENDUM" S HIT=1 + S NUMTYPS=^TMP("TIUTYP",$J) + I +HIT'>0 S ^TMP("TIUTYP",$J,NUMTYPS+1)=+^TMP("TIUTYP",$J,NUMTYPS)+1_U_"81^Addendum^NOT PICKED",^TMP("TIUTYP",$J)=^TMP("TIUTYP",$J)+1 + Q +SWAP(TIUX,TIUY) ; Swap any two variables + N TIUTMP S TIUTMP=TIUX,TIUX=TIUY,TIUY=TIUTMP + Q +EXPRANGE(TIUX,TIUY) ; Expand late date to include time + ;P74 If user entered date/time = T, then numerical date time is FIRST ^ PIECE ONLY of TIUX & TIUY. + I $P(TIUY,U)=DT S TIUY=$$NOW^XLFDT I 1 + E S TIUY=$P(TIUY,U)_"."_235959 ;P74 Add seconds + Q +BUILD(TIUCLASS,STATUS,EARLY,LATE,NOWFLAG,TIUDI) ; Build List + N TIUPREF + S TIUPREF=$$PERSPRF^TIULE(DUZ) + K ^TMP("TIUR",$J),^TMP("TIURIDX",$J),^TMP("TIUI",$J) + ; If user entered NOW at first build, update NOW for rebuild; + ; Save data in ^TMP("TIURIDX",$J,0) for rebuild: + I $G(TIURBLD),$G(NOWFLAG) S LATE=$$NOW^XLFDT + S ^TMP("TIURIDX",$J,0)=+EARLY_U_+LATE_U_$G(STATUS("IFNS"))_U_NOWFLAG + S ^TMP("TIUR",$J,"RTN")="TIURM" + I '$D(TIUPRM0)!'$D(TIUPRM0) D SETPARM^TIULE + S EARLY=+$G(EARLY,0),LATE=+$G(LATE,3333333) + D GATHER^TIURM1(TIUPREF,TIUCLASS,STATUS("IFNS"),EARLY,LATE,.TIUDI) + D PUTLIST^TIURM1(TIUPREF,TIUCLASS,.STATUS,.TIUDI) + K ^TMP("TIUI",$J) + Q +CLEAN ; Clean up your mess! + K ^TMP("TIUR",$J),^TMP("TIURIDX",$J) D CLEAN^VALM10,KILLRR^TIULRR + K VALMY + K ^TMP("TIUTYP",$J) + Q +URGENCY(TIUDA) ; What is the urgency of the current document + N TIUY,TIUD0,TIUDSTAT,TIUDURG + S TIUD0=$G(^TIU(8925,+TIUDA,0)),TIUDSTAT=$P(TIUD0,U,5) + S TIUDURG=$P(TIUD0,U,9) + S TIUY=$S(TIUDSTAT<7:$S(TIUDURG="P":1,1:2),1:3) + Q TIUY +DFLTSTAT(USER) ; Set default STATUS for current user + N TIUMIS,TIUMD,TIUY,TIUDPRM D DOCPRM^TIULC1(244,.TIUDPRM) + S TIUMIS=$$ISA^USRLM(DUZ,"MEDICAL INFORMATION SECTION") + I +TIUMIS,+$P($G(TIUDPRM(0)),U,3) S TIUY="UNVERIFIED" G DFLTX + I $$ISA^USRLM(DUZ,"PROVIDER") S TIUY="COMPLETED" G DFLTX + S TIUY="COMPLETED" +DFLTX Q TIUY + ; +RBLD ; Rebuild list after actions 11/30/00 + N TIUEXP,TIUR0,TIURIDX0,TIUEDT,TIULDT + N TIURBLD,TIUI,TIUCLASS,TIUDI + S TIURBLD=1 + D FIXLSTNW^TIULM ;restore video for elements added to end of list + I +$O(^TMP("TIUR",$J,"EXPAND",0)) D + . M TIUEXP=^TMP("TIUR",$J,"EXPAND") + S TIUR0=^TMP("TIUR",$J,0),TIURIDX0=^TMP("TIURIDX",$J,0) + S TIUCLASS=^TMP("TIUR",$J,"CLASS") + S STATUS("WORDS")=$P(TIUR0,U,2) + S STATUS("IFNS")=$P(TIURIDX0,U,3) + S TIUEDT=$P(TIURIDX0,U),TIULDT=$P(TIURIDX0,U,2),NOWFLAG=+$P(TIURIDX0,U,4) + M TIUDI=^TMP("TIUR",$J,"DIV") + D BUILD(TIUCLASS,.STATUS,TIUEDT,TIULDT,NOWFLAG,.TIUDI) + ; Reexpand previously expanded items: + D RELOAD^TIUROR1(.TIUEXP) + D BREATHE^TIUROR1(1) + Q diff --git a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUSRVA.m b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUSRVA.m index 6f237b7c..cd5f5a56 100644 --- a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUSRVA.m +++ b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUSRVA.m @@ -1,118 +1,118 @@ -TIUSRVA ; SLC/JER,AJB - API's for Authorization ; 11/13/07 - ;;1.0;TEXT INTEGRATION UTILITIES;**19,28,47,80,100,116,152,160,178,175,157,236,234**;Jun 20, 1997;Build 6 - ; - ;External reference to File ^AUPNVSIT supported by DBIA 3580 -REQCOS(TIUY,TIUTYP,TIUDA,TIUSER,TIUDT) ; Evaluate cosignature requirement - ; Initialize return value - N TIUDPRM - S TIUY=0 - I +$G(TIUTYP)'>0,'+$G(TIUDA) Q - I +$G(TIUDA) S TIUTYP=+$G(^TIU(8925,+$G(TIUDA),0)) - S:'+$G(TIUSER) TIUSER=+$G(DUZ) - S TIUY=+$$REQCOSIG^TIULP(TIUTYP,+$G(TIUDA),+$G(TIUSER),+$G(TIUDT)) - Q -URGENCY(TIUY) ; -- retrieve set values from dd for discharge summary urgency - N TIUDD,TIUI,TIUX - D FIELD^DID(8925,.09,"","POINTER","TIUDD") - F TIUI=1:1 S TIUX=$P(TIUDD("POINTER"),";",TIUI) Q:TIUX="" S TIUY(TIUI)=$TR(TIUX,":","^") - Q -CANDO(TIUY,TIUDA,TIUACT) ; Boolean function to evaluate privilege - N TIUPOP,TIUDPRM S TIUPOP=0 - ; **152** prevent editing completed [uncosigned] documents. - I $P($G(^TIU(8925,TIUDA,0)),U,5)>5,(TIUACT="EDIT RECORD") S TIUY="0^ You may not edit uncosigned or completed documents" Q - I $S(TIUACT["SIGN":1,TIUACT="EDIT RECORD":1,TIUACT="DELETE RECORD":1,1:0) D Q:+TIUPOP=1 - . L +^TIU(8925,+TIUDA):1 - . E S TIUY="0^ Another session is editing this entry.",TIUPOP=1 - . L -^TIU(8925,+TIUDA) - I TIUACT["SIGN",+$$NEEDCS(TIUDA) S TIUY="0^ You must name a cosigner before signing this document." Q - S TIUY=$$CANDO^TIULP(TIUDA,TIUACT) - Q -NEEDCS(TIUDA) ; Does user need a cosigner? - N TIUD0,TIUD12,TIUY,SIGNER,COSIGNER,XTRASGNR - S TIUD0=$G(^TIU(8925,TIUDA,0)),TIUD12=$G(^(12)) - S SIGNER=$P(TIUD12,U,4),COSIGNER=$P(TIUD12,U,8),XTRASGNR=0 - I (DUZ'=SIGNER),(DUZ'=COSIGNER) S XTRASGNR=+$O(^TIU(8925.7,"AE",+TIUDA,+DUZ,0)) - I +XTRASGNR S TIUY=0 - E I +$$REQCOSIG^TIULP(+TIUD0,TIUDA,DUZ),(+$P(TIUD12,U,8)'>0) S TIUY=1 - Q +$G(TIUY) -USRINACT(TIUY,TIUDA) ; Is user inactive? - S TIUY=+$$GET1^DIQ(200,TIUDA_",",7,"I") - Q -AUTHSIGN(TIUY,TIUDA,TIUUSR) ; Has Author signed? - ; if TIUY = - ; 0 = Author has NOT signed & TIUUSR = Expected Cosigner - ; 1 = Author HAS signed or TIUUSR '= Expected Cosigner - ; - N TIUD12,TIUD15 - S TIUD12=$G(^TIU(8925,TIUDA,12)),TIUD15=$G(^(15)) - S TIUY=1 - D:$P(TIUD12,U,8)=TIUUSR Q - . S:$P(TIUD12,U,2)'=$P(TIUD15,U,2) TIUY=0 - Q -TIUVISIT(TIUY,DOCTYP,DFN,VISIT) ; Check for a 1 time only doc - ; TIUY = return value - ; = 0 if can add more than one or none already exist - ; = 1 if cannot add more than one and one already exists - ; DOCTYP = Pointer to ^TUI(8925.1, TIU DOCUMENT DEFINITION - ; DFN = Patient IEN - ; VISIT = Visit String "LOC;VDATE;VTYP" - I $$PATCH^XPDUTL("OR*3.0*195") D - . Q:($G(DOCTYP)="")!($G(DFN)="")!($G(VISIT)="") - . N TIUDPRM,TIUTEST - . D DOCPRM^TIULC1(DOCTYP,.TIUDPRM) - . S TIUY=$S($P(TIUDPRM(0),U,10)="":1,1:$P(TIUDPRM(0),U,10)) - . I TIUY=1 S TIUY=0 Q - . I $L(VISIT,";")=3 D - . . S TIUTEST=$$EXIST^TIUEDI3(DFN,DOCTYP,VISIT) - . . I TIUTEST S TIUY=1 - . . I 'TIUTEST S TIUY=0 - I '$$PATCH^XPDUTL("OR*3.0*195") D - . Q:($G(DOCTYP)="")!($G(DFN)="")!($G(VISIT)="") - . N TIUX3 - . S TIUX3=+$O(^TIU(8925.95,"B",DOCTYP,"")) - . S TIUY=$P($G(^TIU(8925.95,TIUX3,0)),U,10) S TIUY=$S(TIUY=0:1,1:0) - . Q:'TIUY - . S VISIT=((9999999-$P(VISIT,"."))_"."_$P(VISIT,".",2)) - . S VISIT=+$O(^AUPNVSIT("AA",DFN,VISIT,"")) - . S TIUY=$S($D(^TIU(8925,"AV",DFN,DOCTYP,VISIT)):0,1:1) - . S TIUY=$S(TIUY=0:1,1:0) - Q -WHATACT(TIUY,TIUDA) ; Evaluate/return whether signature or cosignature - N TIUD0,TIUD12,TIUSTAT,SIGNER,COSIGNER,XTRASGNR - S TIUD0=$G(^TIU(8925,+TIUDA,0)),TIUD12=$G(^TIU(8925,+TIUDA,12)) - S SIGNER=$P(TIUD12,U,4),COSIGNER=$P(TIUD12,U,8) - I (DUZ'=SIGNER),(DUZ'=COSIGNER) S XTRASGNR=+$O(^TIU(8925.7,"AE",+TIUDA,+DUZ,0)) - I '$G(XTRASGNR) S XTRASGNR=$$ASURG^TIUADSIG(TIUDA) - S TIUSTAT=+$P(TIUD0,U,5) - S TIUY=$S(TIUSTAT'>5:"SIGNATURE",+$G(XTRASGNR):"SIGNATURE",1:"COSIGNATURE") - Q -CANCHCOS(TIUY,TIUDA) ; Evaluate/return whether user can change cosigner - S TIUY=$$MAYCHNG^TIURA1(TIUDA) - Q -NEEDJUST(TIUY,TIUDA) ; Is justification required for deletion? - N TIUD0 S TIUD0=$G(^TIU(8925,+TIUDA,0)),TIUY=0 - I +$P(TIUD0,U,5)'<6 S TIUY=1 - Q -GETTITLE(TIUY,TIUDA) ; Get the title from a TIU Document Record - S TIUY=+$G(^TIU(8925,+TIUDA,0)) - Q -CANATTCH(TIUY,TIUDA) ; Can this document be attached as an ID Child - N TITLEDA,PARENTDA - S TITLEDA=+$G(^TIU(8925,TIUDA,0)) - I TITLEDA'>0 S TIUY="0^Document #"_TIUDA_" does not exist." Q - S PARENTDA=+$G(^TIU(8925,TIUDA,21)) - S TIUY=$$POSSPRNT^TIULP(TITLEDA) - I +TIUY S TIUY="-1"_U_$P(TIUY,U,2) Q - I +$$ISCWAD^TIULX(TITLEDA) D Q - . S TIUY="0^ CWAD Documents may not be Attached as Interdisciplinary Entries." - I +$$ISA^TIULX(TITLEDA,+$$CLASS^TIUCNSLT) D Q - . S TIUY="0^ Consult Results may not be Attached as Interdisciplinary Entries." - S TIUY=$$CANDO^TIULP(TIUDA,"ATTACH TO ID NOTE") - I PARENTDA D ; action must be "detach" - . I 'TIUY S TIUY="0^ You may not detach this note from an interdisciplinary note." Q - . S TIUY=$$CANDO^TIULP(PARENTDA,"ATTACH ID ENTRY") - . I 'TIUY S TIUY="0^ You may not detach this note from its interdisciplinary note." - Q -CANRCV(TIUY,TIUDA) ; Can this document receive an ID Child? - S TIUY=$$CANDO^TIULP(TIUDA,"ATTACH ID ENTRY") - Q +TIUSRVA ; SLC/JER,AJB - API's for Authorization ; 03/18/04 [10/19/04 1:21pm] + ;;1.0;TEXT INTEGRATION UTILITIES;**19,28,47,80,100,116,152,160,178,175,157**;Jun 20, 1997 + ; + ;External reference to File ^AUPNVSIT supported by DBIA 3580 +REQCOS(TIUY,TIUTYP,TIUDA,TIUSER,TIUDT) ; Evaluate cosignature requirement + ; Initialize return value + N TIUDPRM + S TIUY=0 + I +$G(TIUTYP)'>0,'+$G(TIUDA) Q + I +$G(TIUDA) S TIUTYP=+$G(^TIU(8925,+$G(TIUDA),0)) + S:'+$G(TIUSER) TIUSER=+$G(DUZ) + S TIUY=+$$REQCOSIG^TIULP(TIUTYP,+$G(TIUDA),+$G(TIUSER),+$G(TIUDT)) + Q +URGENCY(Y) ; -- retrieve set values from dd for discharge summary urgency + N TIUDD,I,X + D FIELD^DID(8925,.09,"","POINTER","TIUDD") + F I=1:1 S X=$P(TIUDD("POINTER"),";",I) Q:X="" S Y(I)=$TR(X,":","^") + Q +CANDO(Y,TIUDA,TIUACT) ; Boolean function to evaluate privilege + N TIUPOP,TIUDPRM S TIUPOP=0 + ; **152** code added to prevent editing a completed document. + I $P($G(^TIU(8925,TIUDA,0)),U,5)>6,(TIUACT="EDIT RECORD") S Y="0^ You may not edit a completed document" Q + I $S(TIUACT["SIGN":1,TIUACT="EDIT RECORD":1,TIUACT="DELETE RECORD":1,1:0) D Q:+TIUPOP=1 + . L +^TIU(8925,+TIUDA):1 + . E S Y="0^ Another session is editing this entry.",TIUPOP=1 + . L -^TIU(8925,+TIUDA) + I TIUACT["SIGN",+$$NEEDCS(TIUDA) S Y="0^ You must name a cosigner before signing this document." Q + S Y=$$CANDO^TIULP(TIUDA,TIUACT) + Q +NEEDCS(TIUDA) ; Does user need a cosigner? + N TIUD0,TIUD12,TIUY,SIGNER,COSIGNER,XTRASGNR + S TIUD0=$G(^TIU(8925,TIUDA,0)),TIUD12=$G(^(12)) + S SIGNER=$P(TIUD12,U,4),COSIGNER=$P(TIUD12,U,8),XTRASGNR=0 + I (DUZ'=SIGNER),(DUZ'=COSIGNER) S XTRASGNR=+$O(^TIU(8925.7,"AE",+TIUDA,+DUZ,0)) + I +XTRASGNR S TIUY=0 + E I +$$REQCOSIG^TIULP(+TIUD0,TIUDA,DUZ),(+$P(TIUD12,U,8)'>0) S TIUY=1 + Q +$G(TIUY) +USRINACT(TIUY,TIUDA) ; Is user inactive? + S TIUY=+$$GET1^DIQ(200,TIUDA_",",7,"I") + Q +AUTHSIGN(TIUY,TIUDA,TIUUSR) ; Has Author signed? + ; if TIUY = + ; 0 = Author has NOT signed & TIUUSR = Expected Cosigner + ; 1 = Author HAS signed or TIUUSR '= Expected Cosigner + ; + N TIUD12,TIUD15 + S TIUD12=$G(^TIU(8925,TIUDA,12)),TIUD15=$G(^(15)) + S TIUY=1 + D:$P(TIUD12,U,8)=TIUUSR Q + . S:$P(TIUD12,U,2)'=$P(TIUD15,U,2) TIUY=0 + Q +TIUVISIT(TIUY,DOCTYP,DFN,VISIT) ; Check for a 1 time only doc + ; TIUY = return value + ; = 0 if can add more than one or none already exist + ; = 1 if cannot add more than one and one already exists + ; DOCTYP = Pointer to ^TUI(8925.1, TIU DOCUMENT DEFINITION + ; DFN = Patient IEN + ; VISIT = Visit String "LOC;VDATE;VTYP" + I $$PATCH^XPDUTL("OR*3.0*195") D + . Q:($G(DOCTYP)="")!($G(DFN)="")!($G(VISIT)="") + . N TIUDPRM,TIUTEST + . D DOCPRM^TIULC1(DOCTYP,.TIUDPRM) + . S TIUY=$S($P(TIUDPRM(0),U,10)="":1,1:$P(TIUDPRM(0),U,10)) + . I TIUY=1 S TIUY=0 Q + . I $L(VISIT,";")=3 D + . . S TIUTEST=$$EXIST^TIUEDI3(DFN,DOCTYP,VISIT) + . . I TIUTEST S TIUY=1 + . . I 'TIUTEST S TIUY=0 + I '$$PATCH^XPDUTL("OR*3.0*195") D + . Q:($G(DOCTYP)="")!($G(DFN)="")!($G(VISIT)="") + . N X3 + . S X3=+$O(^TIU(8925.95,"B",DOCTYP,"")) + . S TIUY=$P($G(^TIU(8925.95,X3,0)),U,10) S TIUY=$S(TIUY=0:1,1:0) + . Q:'TIUY + . S VISIT=((9999999-$P(VISIT,"."))_"."_$P(VISIT,".",2)) + . S VISIT=+$O(^AUPNVSIT("AA",DFN,VISIT,"")) + . S TIUY=$S($D(^TIU(8925,"AV",DFN,DOCTYP,VISIT)):0,1:1) + . S TIUY=$S(TIUY=0:1,1:0) + Q +WHATACT(Y,TIUDA) ; Evaluate/return whether signature or cosignature + N TIUD0,TIUD12,TIUSTAT,SIGNER,COSIGNER,XTRASGNR + S TIUD0=$G(^TIU(8925,+TIUDA,0)),TIUD12=$G(^TIU(8925,+TIUDA,12)) + S SIGNER=$P(TIUD12,U,4),COSIGNER=$P(TIUD12,U,8) + I (DUZ'=SIGNER),(DUZ'=COSIGNER) S XTRASGNR=+$O(^TIU(8925.7,"AE",+TIUDA,+DUZ,0)) + I '$G(XTRASGNR) S XTRASGNR=$$ASURG^TIUADSIG(TIUDA) + S TIUSTAT=+$P(TIUD0,U,5) + S Y=$S(TIUSTAT'>5:"SIGNATURE",+$G(XTRASGNR):"SIGNATURE",1:"COSIGNATURE") + Q +CANCHCOS(Y,TIUDA) ; Evaluate/return whether user can change cosigner + S Y=$$MAYCHNG^TIURA1(TIUDA) + Q +NEEDJUST(Y,TIUDA) ; Is justification required for deletion? + N TIUD0 S TIUD0=$G(^TIU(8925,+TIUDA,0)),Y=0 + I +$P(TIUD0,U,5)'<6 S Y=1 + Q +GETTITLE(Y,TIUDA) ; Get the title from a TIU Document Record + S Y=+$G(^TIU(8925,+TIUDA,0)) + Q +CANATTCH(Y,TIUDA) ; Can this document be attached as an ID Child + N TITLEDA,PARENTDA + S TITLEDA=+$G(^TIU(8925,TIUDA,0)) + I TITLEDA'>0 S Y="0^Document #"_TIUDA_" does not exist." Q + S PARENTDA=+$G(^TIU(8925,TIUDA,21)) + S Y=$$POSSPRNT^TIULP(TITLEDA) + I +Y S Y="-1"_U_$P(Y,U,2) Q + I +$$ISCWAD^TIULX(TITLEDA) D Q + . S Y="0^ CWAD Documents may not be Attached as Interdisciplinary Entries." + I +$$ISA^TIULX(TITLEDA,+$$CLASS^TIUCNSLT) D Q + . S Y="0^ Consult Results may not be Attached as Interdisciplinary Entries." + S Y=$$CANDO^TIULP(TIUDA,"ATTACH TO ID NOTE") + I PARENTDA D ; action must be "detach" + . I 'Y S Y="0^ You may not detach this note from an interdisciplinary note." Q + . S Y=$$CANDO^TIULP(PARENTDA,"ATTACH ID ENTRY") + . I 'Y S Y="0^ You may not detach this note from its interdisciplinary note." + Q +CANRCV(Y,TIUDA) ; Can this document receive an ID Child? + S Y=$$CANDO^TIULP(TIUDA,"ATTACH ID ENTRY") + Q diff --git a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUSRVP1.m b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUSRVP1.m index 9dc44e26..dc24792d 100644 --- a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUSRVP1.m +++ b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUSRVP1.m @@ -1,169 +1,159 @@ -TIUSRVP1 ; SLC/JER - More API's in support of PUT ;8/14/07 - ;;1.0;TEXT INTEGRATION UTILITIES;**19,59,89,100,109,167,113,112,219**;Jun 20, 1997;Build 11 -SITEPARM(TIUY) ; Get site parameters for GUI - N TIUPRM0,TIUPRM1 - D SETPARM^TIULE - S TIUY=TIUPRM0 - Q -DEFDOC(TIUY,HLOC,USER,TIUDT,TIUIEN) ; Get default primary provider - N TIUSPRM,TIUDDOC,TIUAUTH - D SITEPARM(.TIUSPRM) - S TIUDDOC=+$P(TIUSPRM,U,8) - S TIUAUTH=$S((+$G(USER)!('+$G(TIUIEN))):0,1:+$P($G(^TIU(8925,+$G(TIUIEN),12)),U,2)) - S USER=$S(+$G(USER):+$G(USER),+$G(TIUAUTH):+$G(TIUAUTH),1:DUZ) - S TIUDT=$S(+$G(TIUDT):+$G(TIUDT),1:DT) - S TIUY=$S(TIUDDOC=1:$$DFLTDOC^TIUPXAPI(HLOC),TIUDDOC=2:$$CURDOC(USER),1:"0^") - Q -CURDOC(USER,TIUDT) ; Is the current user a known Provider? - N TIUY,TIUPROV S TIUY="0^" - S USER=$S(+$G(USER):+$G(USER),1:DUZ) - S TIUDT=$S(+$G(TIUDT):+$G(TIUDT),1:DT) - S TIUPROV=$$PROVIDER^TIUPXAP1(USER,TIUDT) - I +TIUPROV S TIUY=USER_U_$$PERSNAME^TIULC1(USER) - Q TIUY -ISAPROV(TIUY,USER,DATE) ; Is user a provider? - ; Checks USR CLASS PROVIDER AND 200 Person Class - ; DATE must not include time (for ISA^USRLM) - S USER=$G(USER,DUZ) - S DATE=$G(DATE,DT) - S TIUY=$$PROVIDER^TIUPXAP1(USER,DATE) - Q -USRPROV(TIUY,USER,DATE) ; Is USER a USR CLASS provider? - ; Checks USR CLASS PROVIDER only - ; DATE must not include time - N TIUERR - S USER=$G(USER,DUZ) - S DATE=$G(DATE,DT),TIUY=0 - I +$$ISA^USRLM(USER,"PROVIDER",.TIUERR,DATE) S TIUY=1 ; DBIA/ICR 2324 - Q -DOCPARM(TIUY,TIUDA,TIUTYP) ; Get document parameters for GUI - I '+$G(TIUTYP),+$G(TIUDA) S TIUTYP=+$G(^TIU(8925,+TIUDA,0)) - I '+$G(TIUTYP) S TIUY(0)="" Q - D DOCPRM^TIULC1(TIUTYP,.TIUY,$G(TIUDA)) - I '$D(TIUY) S TIUY(0)="" - Q -CONSTUB(TIUDA,GMRCVP,DFN) ; Create a stub for a Consult Report - N DIE,DR,DA - D STUB(.TIUDA,"CONSULT REPORT",DFN) - I +TIUDA'>0 Q - S DIE=8925,DA=+TIUDA,DR="1405////^S X=GMRCVP" - D ^DIE - Q -STUB(TIUDA,TIUTITL,DFN) ; Create a stub - N TIUVSIT,TIUFPRIV,DIC,DIE,DR,DA,DLAYGO,X,Y S TIUFPRIV=1 - I +$G(TIUTITL)'>0 S TIUTITL=$$WHATITLE^TIUPUTU(TIUTITL) - I +TIUTITL'>0 S TIUDA=-1 Q - S (DIC,DLAYGO)=8925,DIC(0)="LF" - S X=""""_"`"_+TIUTITL_"""" - D ^DIC S TIUDA=+Y Q:+Y'>0 - D EVENT(.TIU,DFN) I $L($G(TIU("VSTR")))'>0 S TIUDA=-1 Q - S DIE=DIC,DA=TIUDA - S DR=".02////"_+DFN_";.03////"_$P($G(TIU("VISIT")),U)_";.04////"_+$$DOCCLASS^TIULC1(TIUTITL)_";.05///UNDICTATED;.13////E;1301////"_+$$NOW^XLFDT - D ^DIE - Q -EVENT(TIUY,DFN) ; Create an Event-type Visit Entry - N VDT,VSTR,DGPM - S DGPM=$G(^DPT(DFN,.105)) ;DBIA/ICR 10035 - I +DGPM'>0 D - . S VDT=$$NOW^XLFDT - . S VSTR=";"_VDT_";"_"E" - D PATVADPT^TIULV(.TIUY,+DFN,DGPM,$G(VSTR)) - I $G(TIUY("LOC"))="",+DUZ D - .N TIUPREF,IDX - .S TIUPREF=$$PERSPRF^TIULE(DUZ) - .S IDX=+$P(TIUPREF,U,2) - .I IDX S TIUY("LOC")=IDX_U_$P($G(^SC(IDX,0)),U,1) ; DBIA/ICR 10040 - Q -GETPNAME(TIUY,TIUTYPE) ; Get Print Name of a Document - S TIUY=$$PNAME^TIULC1(TIUTYPE) - Q -SAVED(TIUY,TIUDA) ; Was the document committed to the database? - N TIUD12,TIUD13,TIUEBY,TIUAUT,TIUECS S TIUY=1 - S TIUD12=$G(^TIU(8925,TIUDA,12)),TIUD13=$G(^(13)) - S TIUEBY=$P(TIUD13,U,2),TIUAUT=$P(TIUD12,U,2),TIUECS=$P(TIUD12,U,8) - I $D(^TIU(8925,"ASAVE",+DUZ,TIUDA)) D Q - . S TIUY="0^You appear to have been disconnected..." - I DUZ'=TIUEBY,(TIUEBY'=TIUAUT),$D(^TIU(8925,"ASAVE",+TIUEBY,TIUDA)) D Q - . S TIUY="0^The transcriber appears to have been disconnected..." - I DUZ'=TIUAUT,$D(^TIU(8925,"ASAVE",+TIUAUT,TIUDA)) D Q - . S TIUY="0^The author appears to have been disconnected..." - I DUZ'=TIUECS,$D(^TIU(8925,"ASAVE",+TIUECS,TIUDA)) D Q - . S TIUY="0^The expected cosigner appears to have been disconnected..." - Q -STUFREC(TIUDA,TIUREC,DFN,PARENT,TITLE,TIU) ; load TIUREC for create - N TIUREQCS,TIUSCAT,TIUSTAT,TIUCPF - ;Set a flag to indicate whether or not a Title is a member of the - ;Clinical Procedures Class (1=Yes and 0=No) - S TIUCPF=+$$ISA^TIULX(TITLE,+$$CLASS^TIUCP) - S TIUSTAT=$$STATUS(TIUDA,+$G(SUPPRESS),$G(TITLE)) - D REQCOS^TIUSRVA(.TIUREQCS,+TITLE,"",$S(+$G(TIUREC(1202)):+$G(TIUREC(1202)),1:DUZ)) - I +$G(PARENT)'>0 D - . S TIUREC(.02)=$G(DFN),TIUREC(.03)=$P($G(TIU("VISIT")),U) - . S TIUREC(.05)=$S(+$G(TIUREC(.05)):+$G(TIUREC(.05)),+TIUSTAT:TIUSTAT,1:5) - . S TIUREC(.07)=$P($G(TIU("EDT")),U),TIUREC(.08)=$P($G(TIU("LDT")),U) - . S TIUREC(1401)=$P($G(TIU("AD#")),U) - . S TIUREC(1402)=$P($G(TIU("TS")),U) - . S TIUREC(1404)=$P($G(TIU("SVC")),U) - I +$G(PARENT)>0 D - . S TIUREC(.02)=+$P($G(^TIU(8925,+PARENT,0)),U,2) - . S TIUREC(.03)=+$P($G(^TIU(8925,+PARENT,0)),U,3) - . S TIUREC(.05)=$S(+$G(TIUREC(.05)):+$G(TIUREC(.05)),+TIUSTAT:TIUSTAT,1:5) - . S TIUREC(.06)=PARENT,TIUREC(.07)=$P(TIU("EDT"),U) - . S TIUREC(.08)=$P(TIU("LDT"),U) - . S TIUREC(1401)=$P($G(^TIU(8925,+PARENT,14)),U) - . S TIUREC(1402)=$P($G(^TIU(8925,+PARENT,14)),U,2) - . S TIUREC(1404)=$P($G(^TIU(8925,+PARENT,14)),U,4) - . S TIUREC(1405)=$P($G(^TIU(8925,+PARENT,14)),U,5) - S TIUREC(.04)=$$DOCCLASS^TIULC1(TITLE) - S TIUSCAT=$S(+$L($P($G(TIU("CAT")),U)):$P($G(TIU("CAT")),U),+$L($P($G(TIU("VSTR")),";",3)):$P($G(TIU("VSTR")),";",3),1:"") - S TIUREC(.13)=TIUSCAT - ;If the document is a member of the Clinical Procedures Class, set the - ;Author/Dictator and the Expected Signer fields to Null - S (TIUREC(1202),TIUREC(1204))=$S(+$G(TIUREC(1202)):+$G(TIUREC(1202)),TIUCPF:"",1:+$G(DUZ)) - S TIUREC(1212)=$P($G(TIU("INST")),U) - S TIUREC(1205)=$P($G(TIU("LOC")),U) - S TIUREC(1211)=$P($G(TIU("VLOC")),U) - S TIUREC(1201)=$$NOW^XLFDT - S TIUREC(1301)=$S($G(TIUREC(1301))]"":$P(TIUREC(1301),U),1:$$NOW^XLFDT) - I +$$ISDS^TIULX(TITLE) D - . I +$G(TIU("LDT"))'>0 S TIUREC(.12)=1 - . S TIUREC(.13)="H" - . D REFDT(.TIUREC) - ;If the document is a member of the Clinical Procedures Class, set the - ;Entered By field to Null - S TIUREC(1303)="R",TIUREC(1302)=$S(TIUCPF:"",1:$G(DUZ)) - I $S(+$G(TIUREC(1208))&(+$G(TIUREC(1204))'=+$G(TIUREC(1208))):1,+$G(TIUREQCS):1,1:0) S TIUREC(1506)=1 - Q -REFDT(TIUX) ; Hack Ref Date/time for DS's - S TIUX(1301)=$S(+$G(TIU("LDT")):+$G(TIU("LDT")),1:$G(TIUX(1301))) - Q -STATUS(TIUDA,SUPPRESS,TITLE) ; Compute the status of the current record - N TIUDPRM,TIUY - ; If the document is an addendum, compute status based on processing - ; requirements of the Parent document or its ancestors - I +$$ISADDNDM^TIULC1(TIUDA) D - . S TIUDA=$S(+$P(^TIU(8925,TIUDA,0),U,6):$P(^(0),U,6),1:TIUDA) - . S TITLE=+$G(^TIU(8925,TIUDA,0)) - D DOCPRM^TIULC1(TITLE,.TIUDPRM,$G(TIUDA)) - I +$P(TIUDPRM(0),U,2),+$G(SUPPRESS) S TIUY=3 G STATUX - S TIUY=$S(+$$REQVER^TIULC(+TIUDA,+$P($G(TIUDPRM(0)),U,3)):4,1:5) -STATUX Q TIUY -IDATTCH(TIUY,TIUDA,TIUDAD) ; Attach TIUDA as ID Child entry to TIUDAD - N TIUX - S TIUX(2101)=TIUDAD - D FILE^TIUSRVP(.TIUY,TIUDA,.TIUX,1) - D AUDLINK^TIUGR1(TIUDA,"a",TIUDAD) - D SENDID^TIUALRT1(TIUDA) - Q -IDDTCH(TIUY,TIUDA) ; Detach TIUDA from its ID Parent - N TIUX,IDDAD - I '+$G(^TIU(8925,TIUDA,21)) D Q - . S TIUY="0^Record #"_TIUDA_" is NOT an ID Entry." - S IDDAD=+$G(^TIU(8925,TIUDA,21)) - S TIUX(2101)="@" - D FILE^TIUSRVP(.TIUY,TIUDA,.TIUX,1) - D AUDLINK^TIUGR1(TIUDA,"d",IDDAD) - D IDDEL^TIUALRT1(TIUDA) - Q -CANDEL(TIUDA) ; Boolean function to evaluate delete request - Q $S($P(^TIU(8925,TIUDA,0),U,5)>3:0,'+$$EMPTYDOC^TIULF(TIUDA):0,1:1) +TIUSRVP1 ; SLC/JER - More API's in support of PUT ;11/01/03 + ;;1.0;TEXT INTEGRATION UTILITIES;**19,59,89,100,109,167,113,112**;Jun 20, 1997 +SITEPARM(TIUY) ; Get site parameters for GUI + N TIUPRM0,TIUPRM1 + D SETPARM^TIULE + S TIUY=TIUPRM0 + Q +DEFDOC(TIUY,HLOC,USER,TIUDT,TIUIEN) ; Get default primary provider + N TIUSPRM,TIUDDOC,TIUAUTH + D SITEPARM(.TIUSPRM) + S TIUDDOC=+$P(TIUSPRM,U,8) + S TIUAUTH=$S((+$G(USER)!('+$G(TIUIEN))):0,1:+$P($G(^TIU(8925,+$G(TIUIEN),12)),U,2)) + S USER=$S(+$G(USER):+$G(USER),+$G(TIUAUTH):+$G(TIUAUTH),1:DUZ) + S TIUDT=$S(+$G(TIUDT):+$G(TIUDT),1:DT) + S TIUY=$S(TIUDDOC=1:$$DFLTDOC^TIUPXAPI(HLOC),TIUDDOC=2:$$CURDOC(USER),1:"0^") + Q +CURDOC(USER,TIUDT) ; Is the current user a known Provider? + N TIUY,TIUPROV S TIUY="0^" + S USER=$S(+$G(USER):+$G(USER),1:DUZ) + S TIUDT=$S(+$G(TIUDT):+$G(TIUDT),1:DT) + S TIUPROV=$$PROVIDER^TIUPXAP1(USER,TIUDT) + I +TIUPROV S TIUY=USER_U_$$PERSNAME^TIULC1(USER) + Q TIUY +ISAPROV(TIUY,USER,DATE) ; Is user a provider? + S USER=$G(USER,DUZ) + S DATE=$G(DATE,DT) + S TIUY=$$PROVIDER^TIUPXAP1(USER,DATE) + Q +DOCPARM(TIUY,TIUDA,TIUTYP) ; Get document parameters for GUI + I '+$G(TIUTYP),+$G(TIUDA) S TIUTYP=+$G(^TIU(8925,+TIUDA,0)) + I '+$G(TIUTYP) S TIUY(0)="" Q + D DOCPRM^TIULC1(TIUTYP,.TIUY,$G(TIUDA)) + I '$D(TIUY) S TIUY(0)="" + Q +CONSTUB(TIUDA,GMRCVP,DFN) ; Create a stub for a Consult Report + N DIE,DR,DA + D STUB(.TIUDA,"CONSULT REPORT",DFN) + I +TIUDA'>0 Q + S DIE=8925,DA=+TIUDA,DR="1405////^S X=GMRCVP" + D ^DIE + Q +STUB(TIUDA,TIUTITL,DFN) ; Create a stub + N TIUVSIT,TIUFPRIV,DIC,DIE,DR,DA,DLAYGO,X,Y S TIUFPRIV=1 + I +$G(TIUTITL)'>0 S TIUTITL=$$WHATITLE^TIUPUTU(TIUTITL) + I +TIUTITL'>0 S TIUDA=-1 Q + S (DIC,DLAYGO)=8925,DIC(0)="LF" + S X=""""_"`"_+TIUTITL_"""" + D ^DIC S TIUDA=+Y Q:+Y'>0 + D EVENT(.TIU,DFN) I $L($G(TIU("VSTR")))'>0 S TIUDA=-1 Q + S DIE=DIC,DA=TIUDA + S DR=".02////"_+DFN_";.03////"_$P($G(TIU("VISIT")),U)_";.04////"_+$$DOCCLASS^TIULC1(TIUTITL)_";.05///UNDICTATED;.13////E;1301////"_+$$NOW^XLFDT + D ^DIE + Q +EVENT(TIUY,DFN) ; Create an Event-type Visit Entry + N VDT,VSTR,DGPM + S DGPM=$G(^DPT(DFN,.105)) + I +DGPM'>0 D + . S VDT=$$NOW^XLFDT + . S VSTR=";"_VDT_";"_"E" + D PATVADPT^TIULV(.TIUY,+DFN,DGPM,$G(VSTR)) + I $G(TIUY("LOC"))="",+DUZ D + .N TIUPREF,IDX + .S TIUPREF=$$PERSPRF^TIULE(DUZ) + .S IDX=+$P(TIUPREF,U,2) + .I IDX S TIUY("LOC")=IDX_U_$P($G(^SC(IDX,0)),U,1) + Q +GETPNAME(TIUY,TIUTYPE) ; Get Print Name of a Document + S TIUY=$$PNAME^TIULC1(TIUTYPE) + Q +SAVED(TIUY,TIUDA) ; Was the document committed to the database? + N TIUD12,TIUD13,TIUEBY,TIUAUT,TIUECS S TIUY=1 + S TIUD12=$G(^TIU(8925,TIUDA,12)),TIUD13=$G(^(13)) + S TIUEBY=$P(TIUD13,U,2),TIUAUT=$P(TIUD12,U,2),TIUECS=$P(TIUD12,U,8) + I $D(^TIU(8925,"ASAVE",+DUZ,TIUDA)) D Q + . S TIUY="0^You appear to have been disconnected..." + I DUZ'=TIUEBY,(TIUEBY'=TIUAUT),$D(^TIU(8925,"ASAVE",+TIUEBY,TIUDA)) D Q + . S TIUY="0^The transcriber appears to have been disconnected..." + I DUZ'=TIUAUT,$D(^TIU(8925,"ASAVE",+TIUAUT,TIUDA)) D Q + . S TIUY="0^The author appears to have been disconnected..." + I DUZ'=TIUECS,$D(^TIU(8925,"ASAVE",+TIUECS,TIUDA)) D Q + . S TIUY="0^The expected cosigner appears to have been disconnected..." + Q +STUFREC(TIUDA,TIUREC,DFN,PARENT,TITLE,TIU) ; load TIUREC for create + N TIUREQCS,TIUSCAT,TIUSTAT,TIUCPF + ;Set a flag to indicate whether or not a Title is a member of the + ;Clinical Procedures Class (1=Yes and 0=No) + S TIUCPF=+$$ISA^TIULX(TITLE,+$$CLASS^TIUCP) + S TIUSTAT=$$STATUS(TIUDA,+$G(SUPPRESS),$G(TITLE)) + D REQCOS^TIUSRVA(.TIUREQCS,+TITLE,"",$S(+$G(TIUREC(1202)):+$G(TIUREC(1202)),1:DUZ)) + I +$G(PARENT)'>0 D + . S TIUREC(.02)=$G(DFN),TIUREC(.03)=$P($G(TIU("VISIT")),U) + . S TIUREC(.05)=$S(+$G(TIUREC(.05)):+$G(TIUREC(.05)),+TIUSTAT:TIUSTAT,1:5) + . S TIUREC(.07)=$P($G(TIU("EDT")),U),TIUREC(.08)=$P($G(TIU("LDT")),U) + . S TIUREC(1401)=$P($G(TIU("AD#")),U) + . S TIUREC(1402)=$P($G(TIU("TS")),U) + . S TIUREC(1404)=$P($G(TIU("SVC")),U) + I +$G(PARENT)>0 D + . S TIUREC(.02)=+$P($G(^TIU(8925,+PARENT,0)),U,2) + . S TIUREC(.03)=+$P($G(^TIU(8925,+PARENT,0)),U,3) + . S TIUREC(.05)=$S(+$G(TIUREC(.05)):+$G(TIUREC(.05)),+TIUSTAT:TIUSTAT,1:5) + . S TIUREC(.06)=PARENT,TIUREC(.07)=$P(TIU("EDT"),U) + . S TIUREC(.08)=$P(TIU("LDT"),U) + . S TIUREC(1401)=$P($G(^TIU(8925,+PARENT,14)),U) + . S TIUREC(1402)=$P($G(^TIU(8925,+PARENT,14)),U,2) + . S TIUREC(1404)=$P($G(^TIU(8925,+PARENT,14)),U,4) + . S TIUREC(1405)=$P($G(^TIU(8925,+PARENT,14)),U,5) + S TIUREC(.04)=$$DOCCLASS^TIULC1(TITLE) + S TIUSCAT=$S(+$L($P($G(TIU("CAT")),U)):$P($G(TIU("CAT")),U),+$L($P($G(TIU("VSTR")),";",3)):$P($G(TIU("VSTR")),";",3),1:"") + S TIUREC(.13)=TIUSCAT + ;If the document is a member of the Clinical Procedures Class, set the + ;Author/Dictator and the Expected Signer fields to Null + S (TIUREC(1202),TIUREC(1204))=$S(+$G(TIUREC(1202)):+$G(TIUREC(1202)),TIUCPF:"",1:+$G(DUZ)) + S TIUREC(1212)=$P($G(TIU("INST")),U) + S TIUREC(1205)=$P($G(TIU("LOC")),U) + S TIUREC(1211)=$P($G(TIU("VLOC")),U) + S TIUREC(1201)=$$NOW^XLFDT + S TIUREC(1301)=$S($G(TIUREC(1301))]"":$P(TIUREC(1301),U),1:$$NOW^XLFDT) + I +$$ISDS^TIULX(TITLE) D + . I +$G(TIU("LDT"))'>0 S TIUREC(.12)=1 + . S TIUREC(.13)="H" + . D REFDT(.TIUREC) + ;If the document is a member of the Clinical Procedures Class, set the + ;Entered By field to Null + S TIUREC(1303)="R",TIUREC(1302)=$S(TIUCPF:"",1:$G(DUZ)) + I $S(+$G(TIUREC(1208))&(+$G(TIUREC(1204))'=+$G(TIUREC(1208))):1,+$G(TIUREQCS):1,1:0) S TIUREC(1506)=1 + Q +REFDT(TIUX) ; Hack Ref Date/time for DS's + S TIUX(1301)=$S(+$G(TIU("LDT")):+$G(TIU("LDT")),1:$G(TIUX(1301))) + Q +STATUS(TIUDA,SUPPRESS,TITLE) ; Compute the status of the current record + N TIUDPRM,TIUY + ; If the document is an addendum, compute status based on processing + ; requirements of the Parent document or its ancestors + I +$$ISADDNDM^TIULC1(TIUDA) D + . S TIUDA=$S(+$P(^TIU(8925,TIUDA,0),U,6):$P(^(0),U,6),1:TIUDA) + . S TITLE=+$G(^TIU(8925,TIUDA,0)) + D DOCPRM^TIULC1(TITLE,.TIUDPRM,$G(TIUDA)) + I +$P(TIUDPRM(0),U,2),+$G(SUPPRESS) S TIUY=3 G STATUX + S TIUY=$S(+$$REQVER^TIULC(+TIUDA,+$P($G(TIUDPRM(0)),U,3)):4,1:5) +STATUX Q TIUY +IDATTCH(TIUY,TIUDA,TIUDAD) ; Attach TIUDA as ID Child entry to TIUDAD + N TIUX + S TIUX(2101)=TIUDAD + D FILE^TIUSRVP(.TIUY,TIUDA,.TIUX,1) + D AUDLINK^TIUGR1(TIUDA,"a",TIUDAD) + D SENDID^TIUALRT1(TIUDA) + Q +IDDTCH(TIUY,TIUDA) ; Detach TIUDA from its ID Parent + N TIUX,IDDAD + I '+$G(^TIU(8925,TIUDA,21)) D Q + . S TIUY="0^Record #"_TIUDA_" is NOT an ID Entry." + S IDDAD=+$G(^TIU(8925,TIUDA,21)) + S TIUX(2101)="@" + D FILE^TIUSRVP(.TIUY,TIUDA,.TIUX,1) + D AUDLINK^TIUGR1(TIUDA,"d",IDDAD) + D IDDEL^TIUALRT1(TIUDA) + Q +CANDEL(TIUDA) ; Boolean function to evaluate delete request + Q $S($P(^TIU(8925,TIUDA,0),U,5)>3:0,'+$$EMPTYDOC^TIULF(TIUDA):0,1:1) diff --git a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUSRVR2.m b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUSRVR2.m index acb96195..e3205d57 100644 --- a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUSRVR2.m +++ b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUSRVR2.m @@ -1,151 +1,151 @@ -TIUSRVR2 ; SLC/JER - RPC for record-wise GET ; 11/23/07 - ;;1.0;TEXT INTEGRATION UTILITIES;**100,109,162,222,234**;Jun 20, 1997;Build 6 - ; 4/12/01 Moved signature modules to new rtn TIUSRVR3 -LOADREC(TIUDA,TIUL,TIUGDATA,TIUGWHOL,ACTION) ; Load ^TMP - ;Requires TIUDA, array TIUL, TIUGDATA - ;optional TIUGWHOL = 1 if we're mid-load for browse, and we're already - ; loading the whole note after the original entry, - ; so DON'T load the whole note again. - N TIUKID,TIUDADT,TIUI,CANSEE - N TIUPARNT,TIUPNAME,TIUPDATE - N TIUGPRNT,TIUGPNM,TIUGPDT,TIUPDATA,TIUHASKD - S ACTION=$G(ACTION,"VIEW") - ; ---- If user cannot view, say so and quit: ---- - ; TIU*1*100 - S CANSEE=$S(+$$ISCOMP^TIUSRVR1(TIUDA)>0:1,1:$$CANDO^TIULP(+TIUDA,ACTION)) - I +CANSEE'>0 D Q - . S TIUL=TIUL+1,@TIUARR@(TIUL)=$P(CANSEE,U,2) - ; ---- Load text of TIUDA: ---- - S TIUI=0 - F S TIUI=$O(^TIU(8925,+TIUDA,"TEXT",TIUI)) Q:+TIUI'>0 D - . S TIUL=TIUL+1,@TIUARR@(TIUL)=$G(^TIU(8925,+TIUDA,"TEXT",+TIUI,0)) - ; ---- if TIUDA is a COMPONENT, QUIT - Q:+$$ISCOMP^TIUSRVR1(TIUDA) - ; ---- If TIUDA **IS** an addendum, load addm signature, - ; load original document, quit: ---- - I +$$ISADDNDM^TIULC1(+TIUDA) D Q - . N TIULINE,TIUPARNT S $P(TIULINE,"=",79)="" - . D LOADSIG^TIUSRVR3(TIUDA,.TIUL) - . S TIUL=TIUL+1,@TIUARR@(TIUL)="" - . S TIUL=TIUL+1,@TIUARR@(TIUL)=TIULINE - . S TIUL=TIUL+1,@TIUARR@(TIUL)="" - . S TIUPARNT=+$P(^TIU(8925,+TIUDA,0),U,6) - . S TIUPNAME=$$PNAME^TIULC1(+^TIU(8925,TIUPARNT,0)) - . S TIUPDATE=+$G(^TIU(8925,TIUPARNT,13)) - . S TIUPDATE=$$DATE^TIULS(TIUPDATE,"MM/DD/YY") - . S TIUPDATA=$$IDDATA^TIURECL1(TIUPARNT) - . S TIUHASKD=$P(TIUPDATA,U,2),TIUGPRNT=+$P(TIUPDATA,U,3) - . S TIUL=+$G(TIUL)+1 - . I TIUHASKD D - . . S @TIUARR@(TIUL)=" --- Original Addended Interdisciplinary Entry ---" - . I TIUGPRNT D - . . S @TIUARR@(TIUL)=" --- Original Addended Interdisciplinary Entry ---" - . . S TIUGPNM=$$PNAME^TIULC1(+^TIU(8925,TIUGPRNT,0)) - . . S TIUGPDT=+$G(^TIU(8925,TIUGPRNT,13)) - . . S TIUGPDT=$$DATE^TIULS(TIUGPDT,"MM/DD/YY") - . I 'TIUHASKD,'TIUGPRNT S @TIUARR@(TIUL)=" --- Original Document ---" - . S TIUL=+$G(TIUL)+1,@TIUARR@(TIUL)="" - . S TIUL=+$G(TIUL)+1 - . I TIUHASKD D - . . S @TIUARR@(TIUL)=" << Addended Interdisciplinary Entry >>" - . . S TIUL=+$G(TIUL)+1 - . . S @TIUARR@(TIUL)=TIUPDATE_" "_TIUPNAME_":" - . I TIUGPRNT D - . . S @TIUARR@(TIUL)=" << Interdisciplinary Note >>" - . . S TIUL=+$G(TIUL)+1 - . . S @TIUARR@(TIUL)=TIUGPDT_" "_TIUGPNM - . . S TIUL=+$G(TIUL)+1 - . . S @TIUARR@(TIUL)=" << Addended Interdisciplinary Entry >>" - . . S TIUL=+$G(TIUL)+1,@TIUARR@(TIUL)=TIUPDATE_" "_TIUPNAME_":" - . I 'TIUHASKD,'TIUGPRNT D - . . S @TIUARR@(TIUL)=TIUPDATE_" "_TIUPNAME_":" - . D LOADREC(TIUPARNT,.TIUL,TIUGDATA) - ; ---- Load components of TIUDA: ---- - S TIUKID=0 - F S TIUKID=$O(^TIU(8925,"DAD",+TIUDA,TIUKID)) Q:+TIUKID'>0 D - . I +$$ISADDNDM^TIULC1(TIUKID)'>0 D LOADREC(TIUKID,.TIUL,$G(TIUGDATA)) - ; ---- Load signature of TIUDA if TIUDA is not addm - ; or comp: ---- - ; *222 don't display sig info. for FORM LETTERS - I '+$$MEMBEROF^TIUPR222(+$G(^TIU(8925,+TIUDA,0)),"FORM LETTERS") D - . I '$$ISCOMP^TIUSRVR1(TIUDA) D LOADSIG^TIUSRVR3(TIUDA,.TIUL) - ; ---- Load addenda of TIUDA: ---- - S TIUKID=0 - F S TIUKID=$O(^TIU(8925,"DAD",+TIUDA,TIUKID)) Q:+TIUKID'>0 D - . ; If acting on an addendum, don't show it again. - . I +TIUKID=+$G(^TMP("TIU FOCUS",$J)) Q - . I +$$ISADDNDM^TIULC1(TIUKID) D LOADADD(TIUKID,.TIUL) - N IDDAD - S IDDAD=+$P(TIUGDATA,U,3) - ; ---- If Browsed Record is an ID Note, & this cycle has - ; just loaded the parent entry, then load ID kids - ; and quit: **100** ---- - I $P(TIUGDATA,U,2),TIUDA=+TIUGDATA D LOADKIDS(TIUDA,.TIUL,TIUGDATA) Q - ; ---- If Browsed Record is an ID Entry, & this cycle hasn't begun - ; loading the whole note, then load the whole ID Note after - ; the browsed entry and quit: ---- - I IDDAD,'$G(TIUGWHOL) D Q - . S TIUGWHOL=1 - . N TIULINE S $P(TIULINE,"=",79)="" - . S TIUL=TIUL+1,@TIUARR@(TIUL)="" - . S TIUL=TIUL+1,@TIUARR@(TIUL)=TIULINE - . S TIUL=TIUL+1,@TIUARR@(TIUL)="" - . S TIUL=TIUL+1,@TIUARR@(TIUL)=" --- Interdisciplinary Note ---" - . S TIUL=TIUL+1,@TIUARR@(TIUL)="" - . D LOADID(IDDAD,.TIUL,TIUGDATA,TIUGWHOL) - ; ---- If Browsed Record is an ID Entry, & this cycle has begun - ; loading the whole ID note, and is currently loading the first - ; entry of the whole note, then load kids and quit: ---- - I IDDAD,$G(TIUGWHOL),TIUDA=IDDAD D LOADKIDS(TIUDA,.TIUL,TIUGDATA,TIUGWHOL) K TIUGWHOL - Q - ; -LOADKIDS(TIUDA,TIUL,TIUGDATA,TIUGWHOL) ; Load ID kids of TIUDA - ; Requires TIUDA, array TIUL, TIUGDATA - N TIUK,PRMSORT,KIDDA,TIUD0,TIUD21 - I $G(^TMP("TIUR",$J,"IDDATA",TIUDA)) S PRMSORT=$P(^TMP("TIUR",$J,"IDDATA",TIUDA),U,4) - E S TIUD0=$G(^TIU(8925,TIUDA,0)),TIUD21=$G(^TIU(8925,TIUDA,21)),PRMSORT=$P($$IDDATA^TIURECL1(TIUDA,TIUD0,TIUD21),U,4) - D GETIDKID^TIURECL2(TIUDA,PRMSORT) ; sets array ^TMP("TIUIDKID",$J, - S TIUK=0 - F S TIUK=$O(^TMP("TIUIDKID",$J,TIUDA,TIUK)) Q:+TIUK'>0 D - . S KIDDA=^TMP("TIUIDKID",$J,TIUDA,TIUK) - . D LOADID(KIDDA,.TIUL,TIUGDATA,$G(TIUGWHOL)) - K ^TMP("TIUIDKID",$J) - Q - ; -LOADID(TIUDA,TIUL,TIUGDATA,TIUWHOL) ; Load ID note for browse - N TIUREC,TIU - I '$D(^TIU(8925,+TIUDA,0)) Q - ; ---- If ID Kid has focus, don't show it again ---- - ; I TIUDA=+$G(^TMP("TIU FOCUS",$J)) Q - S TIUL=TIUL+1,@TIUARR@(TIUL)="" - D GETTIU^TIULD(.TIU,+TIUDA) - D INQUIRE(TIUDA,.TIUREC) - ; ---- Load info missing from header since this is ID note entry: ---- - ; ---- Load dictation, transcription data, etc.: ---- - D LOADTOP^TIUSRVR1(.TIUREC,TIUDA,.TIUL,$G(TIUGDATA)) - ; ---- Load the remainder of the record: ---- - D LOADREC(TIUDA,.TIUL,$G(TIUGDATA),$G(TIUWHOL)) - Q - ; -INQUIRE(TIUDA,TIUREC,TIUCPF) ; Inquire to document TIUDA and set TIUREC - N DA,DIC,DIQ,DR - S DA=TIUDA,DIC=8925,DIQ="TIUREC(" - S DR=".01;.02;.05;.09;1201;1202;1208;1209;1301;1307;1501;1502;1505;1506;89261" - ;If the document is a member of the Clinical Procedures Class, include the - ;Procedure Summary Code field and the Date/Time Performed field - I $G(TIUCPF) S DR=DR_";70201;70202" - D EN^DIQ1 - Q -LOADADD(TIUDADD,TIUL) ; Load addenda - N TIUDAUTH,TIUDATT,TIUJ,TIUSIG,TIUCSIG,TIUVIEW - S TIUL=TIUL+1,@TIUARR@(TIUL)="" - S TIUDADT=$$DATE^TIULS($P($G(^TIU(8925,+TIUDADD,13)),U),"MM/DD/CCYY") - S TIUL=TIUL+1,@TIUARR@(TIUL)=TIUDADT_" ADDENDUM"_" STATUS: "_$$STATUS^TIULF(TIUDADD) ;P162 - S TIUVIEW=$$CANDO^TIULP(+TIUDADD,"VIEW") - I '+TIUVIEW D Q - . S TIUL=TIUL+1,@TIUARR@(TIUL)=$P(TIUVIEW,U,2) - S TIUJ=0 - F S TIUJ=$O(^TIU(8925,+TIUDADD,"TEXT",TIUJ)) Q:+TIUJ'>0 D - . S TIUL=TIUL+1,@TIUARR@(TIUL)=$G(^TIU(8925,+TIUDADD,"TEXT",TIUJ,0)) - D LOADSIG^TIUSRVR3(TIUDADD,.TIUL) - Q +TIUSRVR2 ; SLC/JER - RPC for record-wise GET ; 4/14/03 + ;;1.0;TEXT INTEGRATION UTILITIES;**100,109,162,222**;Jun 20, 1997 + ; 4/12/01 Moved signature modules to new rtn TIUSRVR3 +LOADREC(TIUDA,TIUL,TIUGDATA,TIUGWHOL,ACTION) ; Load ^TMP + ;Requires TIUDA, array TIUL, TIUGDATA + ;optional TIUGWHOL = 1 if we're mid-load for browse, and we're already + ; loading the whole note after the original entry, + ; so DON'T load the whole note again. + N TIUKID,TIUDADT,TIUI,CANSEE + N TIUPARNT,TIUPNAME,TIUPDATE + N TIUGPRNT,TIUGPNM,TIUGPDT,TIUPDATA,TIUHASKD + S ACTION=$G(ACTION,"VIEW") + ; ---- If user cannot view, say so and quit: ---- + ; TIU*1*100 + S CANSEE=$S(+$$ISCOMP^TIUSRVR1(TIUDA)>0:1,1:$$CANDO^TIULP(+TIUDA,ACTION)) + I +CANSEE'>0 D Q + . S TIUL=TIUL+1,@TIUARR@(TIUL)=$P(CANSEE,U,2) + ; ---- Load text of TIUDA: ---- + S TIUI=0 + F S TIUI=$O(^TIU(8925,+TIUDA,"TEXT",TIUI)) Q:+TIUI'>0 D + . S TIUL=TIUL+1,@TIUARR@(TIUL)=$G(^TIU(8925,+TIUDA,"TEXT",+TIUI,0)) + ; ---- if TIUDA is a COMPONENT, QUIT + Q:+$$ISCOMP^TIUSRVR1(TIUDA) + ; ---- If TIUDA **IS** an addendum, load addm signature, + ; load original document, quit: ---- + I +$$ISADDNDM^TIULC1(+TIUDA) D Q + . N TIULINE,TIUPARNT S $P(TIULINE,"=",79)="" + . D LOADSIG^TIUSRVR3(TIUDA,.TIUL) + . S TIUL=TIUL+1,@TIUARR@(TIUL)="" + . S TIUL=TIUL+1,@TIUARR@(TIUL)=TIULINE + . S TIUL=TIUL+1,@TIUARR@(TIUL)="" + . S TIUPARNT=+$P(^TIU(8925,+TIUDA,0),U,6) + . S TIUPNAME=$$PNAME^TIULC1(+^TIU(8925,TIUPARNT,0)) + . S TIUPDATE=+$G(^TIU(8925,TIUPARNT,13)) + . S TIUPDATE=$$DATE^TIULS(TIUPDATE,"MM/DD/YY") + . S TIUPDATA=$$IDDATA^TIURECL1(TIUPARNT) + . S TIUHASKD=$P(TIUPDATA,U,2),TIUGPRNT=+$P(TIUPDATA,U,3) + . S TIUL=+$G(TIUL)+1 + . I TIUHASKD D + . . S @TIUARR@(TIUL)=" --- Original Addended Interdisciplinary Entry ---" + . I TIUGPRNT D + . . S @TIUARR@(TIUL)=" --- Original Addended Interdisciplinary Entry ---" + . . S TIUGPNM=$$PNAME^TIULC1(+^TIU(8925,TIUGPRNT,0)) + . . S TIUGPDT=+$G(^TIU(8925,TIUGPRNT,13)) + . . S TIUGPDT=$$DATE^TIULS(TIUGPDT,"MM/DD/YY") + . I 'TIUHASKD,'TIUGPRNT S @TIUARR@(TIUL)=" --- Original Document ---" + . S TIUL=+$G(TIUL)+1,@TIUARR@(TIUL)="" + . S TIUL=+$G(TIUL)+1 + . I TIUHASKD D + . . S @TIUARR@(TIUL)=" << Addended Interdisciplinary Entry >>" + . . S TIUL=+$G(TIUL)+1 + . . S @TIUARR@(TIUL)=TIUPDATE_" "_TIUPNAME_":" + . I TIUGPRNT D + . . S @TIUARR@(TIUL)=" << Interdisciplinary Note >>" + . . S TIUL=+$G(TIUL)+1 + . . S @TIUARR@(TIUL)=TIUGPDT_" "_TIUGPNM + . . S TIUL=+$G(TIUL)+1 + . . S @TIUARR@(TIUL)=" << Addended Interdisciplinary Entry >>" + . . S TIUL=+$G(TIUL)+1,@TIUARR@(TIUL)=TIUPDATE_" "_TIUPNAME_":" + . I 'TIUHASKD,'TIUGPRNT D + . . S @TIUARR@(TIUL)=TIUPDATE_" "_TIUPNAME_":" + . D LOADREC(TIUPARNT,.TIUL,TIUGDATA) + ; ---- Load components of TIUDA: ---- + S TIUKID=0 + F S TIUKID=$O(^TIU(8925,"DAD",+TIUDA,TIUKID)) Q:+TIUKID'>0 D + . I +$$ISADDNDM^TIULC1(TIUKID)'>0 D LOADREC(TIUKID,.TIUL,$G(TIUGDATA)) + ; ---- Load signature of TIUDA if TIUDA is not addm + ; or comp: ---- + ; *222 don't display sig info. for FORM LETTERS + I '+$$MEMBEROF^TIUPR222(+$G(^TIU(8925,+TIUDA,0)),"FORM LETTERS") D + . I '$$ISCOMP^TIUSRVR1(TIUDA) D LOADSIG^TIUSRVR3(TIUDA,.TIUL) + ; ---- Load addenda of TIUDA: ---- + S TIUKID=0 + F S TIUKID=$O(^TIU(8925,"DAD",+TIUDA,TIUKID)) Q:+TIUKID'>0 D + . ; If acting on an addendum, don't show it again. + . I +TIUKID=+$G(^TMP("TIU FOCUS",$J)) Q + . I +$$ISADDNDM^TIULC1(TIUKID) D LOADADD(TIUKID,.TIUL) + N IDDAD + S IDDAD=+$P(TIUGDATA,U,3) + ; ---- If Browsed Record is an ID Note, & this cycle has + ; just loaded the parent entry, then load ID kids + ; and quit: **100** ---- + I $P(TIUGDATA,U,2),TIUDA=+TIUGDATA D LOADKIDS(TIUDA,.TIUL,TIUGDATA) Q + ; ---- If Browsed Record is an ID Entry, & this cycle hasn't begun + ; loading the whole note, then load the whole ID Note after + ; the browsed entry and quit: ---- + I IDDAD,'$G(TIUGWHOL) D Q + . S TIUGWHOL=1 + . N TIULINE S $P(TIULINE,"=",79)="" + . S TIUL=TIUL+1,@TIUARR@(TIUL)="" + . S TIUL=TIUL+1,@TIUARR@(TIUL)=TIULINE + . S TIUL=TIUL+1,@TIUARR@(TIUL)="" + . S TIUL=TIUL+1,@TIUARR@(TIUL)=" --- Interdisciplinary Note ---" + . S TIUL=TIUL+1,@TIUARR@(TIUL)="" + . D LOADID(IDDAD,.TIUL,TIUGDATA,TIUGWHOL) + ; ---- If Browsed Record is an ID Entry, & this cycle has begun + ; loading the whole ID note, and is currently loading the first + ; entry of the whole note, then load kids and quit: ---- + I IDDAD,$G(TIUGWHOL),TIUDA=IDDAD D LOADKIDS(TIUDA,.TIUL,TIUGDATA,TIUGWHOL) K TIUGWHOL + Q + ; +LOADKIDS(TIUDA,TIUL,TIUGDATA,TIUGWHOL) ; Load ID kids of TIUDA + ; Requires TIUDA, array TIUL, TIUGDATA + N TIUK,PRMSORT,KIDDA,TIUD0,TIUD21 + I $G(^TMP("TIUR",$J,"IDDATA",TIUDA)) S PRMSORT=$P(^TMP("TIUR",$J,"IDDATA",TIUDA),U,4) + E S TIUD0=$G(^TIU(8925,TIUDA,0)),TIUD21=$G(^TIU(8925,TIUDA,21)),PRMSORT=$P($$IDDATA^TIURECL1(TIUDA,TIUD0,TIUD21),U,4) + D GETIDKID^TIURECL2(TIUDA,PRMSORT) ; sets array ^TMP("TIUIDKID",$J, + S TIUK=0 + F S TIUK=$O(^TMP("TIUIDKID",$J,TIUDA,TIUK)) Q:+TIUK'>0 D + . S KIDDA=^TMP("TIUIDKID",$J,TIUDA,TIUK) + . D LOADID(KIDDA,.TIUL,TIUGDATA,$G(TIUGWHOL)) + K ^TMP("TIUIDKID",$J) + Q + ; +LOADID(TIUDA,TIUL,TIUGDATA,TIUWHOL) ; Load ID note for browse + N TIUREC,TIU + I '$D(^TIU(8925,+TIUDA,0)) Q + ; ---- If ID Kid has focus, don't show it again ---- + ; I TIUDA=+$G(^TMP("TIU FOCUS",$J)) Q + S TIUL=TIUL+1,@TIUARR@(TIUL)="" + D GETTIU^TIULD(.TIU,+TIUDA) + D INQUIRE(TIUDA,.TIUREC) + ; ---- Load info missing from header since this is ID note entry: ---- + ; ---- Load dictation, transcription data, etc.: ---- + D LOADTOP^TIUSRVR1(.TIUREC,TIUDA,.TIUL,$G(TIUGDATA)) + ; ---- Load the remainder of the record: ---- + D LOADREC(TIUDA,.TIUL,$G(TIUGDATA),$G(TIUWHOL)) + Q + ; +INQUIRE(TIUDA,TIUREC,TIUCPF) ; Inquire to document TIUDA and set TIUREC + N DA,DIC,DIQ,DR + S DA=TIUDA,DIC=8925,DIQ="TIUREC(" + S DR=".01;.02;.05;.09;1201;1202;1208;1209;1301;1307;1501;1502;1505;1506" + ;If the document is a member of the Clinical Procedures Class, include the + ;Procedure Summary Code field and the Date/Time Performed field + I $G(TIUCPF) S DR=DR_";70201;70202" + D EN^DIQ1 + Q +LOADADD(TIUDADD,TIUL) ; Load addenda + N TIUDAUTH,TIUDATT,TIUJ,TIUSIG,TIUCSIG,TIUVIEW + S TIUL=TIUL+1,@TIUARR@(TIUL)="" + S TIUDADT=$$DATE^TIULS($P($G(^TIU(8925,+TIUDADD,13)),U),"MM/DD/CCYY") + S TIUL=TIUL+1,@TIUARR@(TIUL)=TIUDADT_" ADDENDUM"_" STATUS: "_$$STATUS^TIULF(TIUDADD) ;P162 + S TIUVIEW=$$CANDO^TIULP(+TIUDADD,"VIEW") + I '+TIUVIEW D Q + . S TIUL=TIUL+1,@TIUARR@(TIUL)=$P(TIUVIEW,U,2) + S TIUJ=0 + F S TIUJ=$O(^TIU(8925,+TIUDADD,"TEXT",TIUJ)) Q:+TIUJ'>0 D + . S TIUL=TIUL+1,@TIUARR@(TIUL)=$G(^TIU(8925,+TIUDADD,"TEXT",TIUJ,0)) + D LOADSIG^TIUSRVR3(TIUDADD,.TIUL) + Q diff --git a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC.m b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC.m index c77cedc4..7bc5d0d7 100644 --- a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC.m +++ b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC.m @@ -1,4 +1,4 @@ -TIUXRC ; DRIVER FOR COMPILED XREFS FOR FILE #8925 ; 11/08/09 +TIUXRC ; DRIVER FOR COMPILED XREFS FOR FILE #8925 ; 12/25/06 ; N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2 I '$D(DIKSAT) S DIKLK=DIK_DA_")" L +@DIKLK:10 K:'$T DIKLK @@ -6,9 +6,9 @@ TIUXRC ; DRIVER FOR COMPILED XREFS FOR FILE #8925 ; 11/08/09 G Q DI S DIKM1=0,DIKUM=0,DA(0)="",DV=0 F S DV=$O(DA(DV)) Q:DV'>0 S DIKUM=DIKUM+1,DIKUP(DV)=DA(DV) S:DV="" DV=-1 S DH(1)=8925,DIKUP=DA - I $D(DIKKS) D:DIKZ1=DH(1) ^TIUXRC1 S DA=DIKUP D:DIKZ1=DH(1) ^TIUXRC3 D:DIKZ1'=DH(1) KILL D:DIKZ1'=DH(1) DA D:DIKZ1'=DH(1) SET D DA Q + I $D(DIKKS) D:DIKZ1=DH(1) ^TIUXRC1 S DA=DIKUP D:DIKZ1=DH(1) ^TIUXRC4 D:DIKZ1'=DH(1) KILL D:DIKZ1'=DH(1) DA D:DIKZ1'=DH(1) SET D DA Q I $D(DIKIL) D:DIKZ1=DH(1) ^TIUXRC1 S:DIKZ1=DH(1) DIKM1=1 D:DIKZ1'=DH(1) KILL S DA=DIKUP D:DIKM1>0 KIL1 D DA Q - I $D(DIKST) D:DIKZ1=DH(1) ^TIUXRC3 D:DIKZ1'=DH(1) SET D DA Q + I $D(DIKST) D:DIKZ1=DH(1) ^TIUXRC4 D:DIKZ1'=DH(1) SET D DA Q I $D(DIKSAT) D SET1 D DA Q Q DA K DA F DV=1:1 Q:'$D(DIKUP(DV)) S DA(DV)=DIKUP(DV) @@ -16,7 +16,7 @@ DA K DA F DV=1:1 Q:'$D(DIKUP(DV)) S DA(DV)=DIKUP(DV) SET1 S (DA,DCNT)=0 S DU=$E(DIK,1,$L(DIK)-1),DIKLK=$S(DIK[",":DU_")",1:DU) L +@DIKLK:10 K:'$T DIKLK C I @("$O("_DIK_"DA))'>0") S DA=$$C1(DA),^(0)=$P(@(DIK_"0)"),U,1,2)_U_DA_U_DCNT K DCNT L:$D(DIKLK) -@DIKLK Q - S (DIKY,DA)=$O(^(DA)) G C:$P($G(^(DA,0)),U)']"" S DU=1,DCNT=DCNT+1 S:DA="" (DIKY,DA)=-1 D:DIKZ1=DH(1) ^TIUXRC3 D:DIKZ1'=DH(1) SET D:DIKZ1'=DH(1) DA K DB(0) S DA=DIKY G C + S (DIKY,DA)=$O(^(DA)) G C:$P($G(^(DA,0)),U)']"" S DU=1,DCNT=DCNT+1 S:DA="" (DIKY,DA)=-1 D:DIKZ1=DH(1) ^TIUXRC4 D:DIKZ1'=DH(1) SET D:DIKZ1'=DH(1) DA K DB(0) S DA=DIKY G C Q C1(A) Q:$P($G(@(DIK_"A,0)")),U)]"" A F S @("A=+$O("_DIK_"A),-1)") Q:$P($G(@(DIK_"A,0)")),U)]""!(A'>0) diff --git a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC1.m b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC1.m index 579b4f9c..e6a14782 100644 --- a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC1.m +++ b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC1.m @@ -1,4 +1,4 @@ -TIUXRC1 ; COMPILED XREF FOR FILE #8925 ; 11/08/09 +TIUXRC1 ; COMPILED XREF FOR FILE #8925 ; 12/25/06 ; S DIKZK=2 S DIKZ(0)=$G(^TIU(8925,DA,0)) @@ -116,21 +116,4 @@ TIUXRC1 ; COMPILED XREF FOR FILE #8925 ; 11/08/09 I X'="" D KAPTLD^TIUDD01(1211,X) S DIKZ(13)=$G(^TIU(8925,DA,13)) S X=$P(DIKZ(13),U,1) - I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"AAU",+$P(^TIU(8925,+DA,12),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) - S X=$P(DIKZ(13),U,1) - I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,8),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ASUP",+$P(^TIU(8925,+DA,12),U,8),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) - S X=$P(DIKZ(13),U,1) - I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"APT",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) - S X=$P(DIKZ(13),U,1) - I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,14)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ATS",+$P(^TIU(8925,+DA,14),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) - S X=$P(DIKZ(13),U,1) - I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ATC",+$P(^TIU(8925,+DA,13),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) - S X=$P(DIKZ(13),U,1) - I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ALL","ANY",+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) - S X=$P(DIKZ(13),U,1) - I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),$L($P($G(^TIU(8925,+DA,17)),U)) D ASUBK^TIUDD($P($G(^TIU(8925,+DA,17)),U),+$G(^TIU(8925,+DA,0)),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-+X),DA) - S X=$P(DIKZ(13),U,1) - I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,14)),U,4),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ASVC",+$P(^TIU(8925,+DA,14),U,4),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) - S X=$P(DIKZ(13),U,1) - I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),+$O(^TIU(8925.9,"B",+DA,0)) D APRBK^TIUDD(+$G(^TIU(8925,+DA,0)),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-+X),DA) END G ^TIUXRC2 diff --git a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC2.m b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC2.m index b03772c8..4cb29b47 100644 --- a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC2.m +++ b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC2.m @@ -1,6 +1,23 @@ -TIUXRC2 ; COMPILED XREF FOR FILE #8925 ; 11/08/09 +TIUXRC2 ; COMPILED XREF FOR FILE #8925 ; 12/25/06 ; -END G ^TIUXRC2 + I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"AAU",+$P(^TIU(8925,+DA,12),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) + S X=$P(DIKZ(13),U,1) + I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,8),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ASUP",+$P(^TIU(8925,+DA,12),U,8),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) + S X=$P(DIKZ(13),U,1) + I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"APT",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) + S X=$P(DIKZ(13),U,1) + I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,14)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ATS",+$P(^TIU(8925,+DA,14),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) + S X=$P(DIKZ(13),U,1) + I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ATC",+$P(^TIU(8925,+DA,13),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) + S X=$P(DIKZ(13),U,1) + I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ALL","ANY",+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) + S X=$P(DIKZ(13),U,1) + I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),$L($P($G(^TIU(8925,+DA,17)),U)) D ASUBK^TIUDD($P($G(^TIU(8925,+DA,17)),U),+$G(^TIU(8925,+DA,0)),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-+X),DA) + S X=$P(DIKZ(13),U,1) + I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,14)),U,4),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ASVC",+$P(^TIU(8925,+DA,14),U,4),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA) + S X=$P(DIKZ(13),U,1) + I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),+$O(^TIU(8925.9,"B",+DA,0)) D APRBK^TIUDD(+$G(^TIU(8925,+DA,0)),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-+X),DA) + S X=$P(DIKZ(13),U,1) I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,3),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"AVSIT",+$P(^TIU(8925,+DA,0),U,3),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),DA) S X=$P(DIKZ(13),U,1) I X'="" I +$P($G(^TIU(8925,+DA,0)),U,4),+$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ADCPT",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U,4),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),DA) @@ -88,50 +105,4 @@ END G ^TIUXRC2 S X=$P(DIKZ(0),U,1) I X'="" I $L($P($G(^TIU(8925,+DA,17)),U)),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) D ASUBK^TIUDD($P($G(^TIU(8925,+DA,17)),U),+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-+$G(^TIU(8925,+DA,13))),DA) S X=$P(DIKZ(0),U,1) - I X'="" I +$P($G(^TIU(8925,+DA,14)),U,4),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ASVC",+$P($G(^TIU(8925,+DA,14)),U,4),+X,+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA) - S X=$P(DIKZ(0),U,1) - I X'="" I $L($P(^TIU(8925,+DA,0),U)),(+$P(^(0),U,3)>0) K ^TIU(8925,"AE",+$P($G(^TIU(8925,+DA,0)),U,2),(9999999-$P(+^AUPNVSIT(+$P(^TIU(8925,+DA,0),U,3),0),".")),+X,+DA) - S X=$P(DIKZ(0),U,1) - I X'="" I +$P($G(^TIU(8925,+DA,12)),U,5),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ALOC",+$P($G(^TIU(8925,+DA,12)),U,5),+X,+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA) - S X=$P(DIKZ(0),U,1) - I X'="" I +$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5),+$O(^TIU(8925.9,"B",+DA,0)) D APRBK^TIUDD(+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-+$G(^TIU(8925,+DA,13))),DA) - S X=$P(DIKZ(0),U,1) - I X'="" I +$P(^TIU(8925,+DA,0),U,3),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"AVSIT",+$P(^TIU(8925,+DA,0),U,3),+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),DA) - S X=$P(DIKZ(0),U,1) - I X'="" I +$P(^TIU(8925,+DA,0),U,2),+$P($G(^TIU(8925,+DA,13)),U) K ^TIU(8925,"APTCL",+$P(^TIU(8925,+DA,0),U,2),+$$CLINDOC^TIULC1(+X,+DA),(9999999-$P(^TIU(8925,+DA,13),U)),DA) - S X=$P(DIKZ(0),U,1) - I X'="" I +$P(^TIU(8925,+DA,0),U,2),+$P($G(^TIU(8925,+DA,13)),U) K ^TIU(8925,"APTCL",+$P(^TIU(8925,+DA,0),U,2),38,(9999999-$P(^TIU(8925,+DA,13),U)),DA) - S X=$P(DIKZ(0),U,1) - I X'="" D KACLPT^TIUDD01(.01,X) - S X=$P(DIKZ(0),U,1) - I X'="" D KACLAU^TIUDD01(.01,X),KACLAU1^TIUDD01(.01,X) - S X=$P(DIKZ(0),U,1) - I X'="" D KACLEC^TIUDD01(.01,X) - S X=$P(DIKZ(0),U,1) - I X'="" D KACLSB^TIUDD01(.01,X) - S X=$P(DIKZ(0),U,1) - I X'="" D KAPTLD^TIUDD01(.01,X) -CR1 S DIXR=247 - K X - S X(1)=$P(DIKZ(12),U,12) - S X(2)=$P(DIKZ(0),U,1) - S X(3)=$P(DIKZ(0),U,5) - S X=$P(DIKZ(13),U,1) - I $G(X)]"" S X=9999999-X - S:$D(X)#2 X(4)=X - S X=$G(X(1)) - I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D - . K X1,X2 M X1=X,X2=X - . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4))="" - . K ^TIU(8925,"ADIV",X(1),X(2),X(3),X(4),DA) -CR2 S DIXR=413 - K X - S DIKZ(12)=$G(^TIU(8925,DA,12)) - S X(1)=$P(DIKZ(12),U,7) - S X=$G(X(1)) - I $G(X(1))]"" D - . K X1,X2 M X1=X,X2=X - . S:$D(DIKIL) (X2,X2(1))="" - . K ^TIU(8925,"VS",X,DA) -CR3 K X -END Q +END G ^TIUXRC3 diff --git a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC3.m b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC3.m index 04f27b53..27bf858a 100644 --- a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC3.m +++ b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC3.m @@ -1,119 +1,49 @@ -TIUXRC3 ; COMPILED XREF FOR FILE #8925 ; 11/08/09 +TIUXRC3 ; COMPILED XREF FOR FILE #8925 ; 12/25/06 ; - S DIKZK=1 - S DIKZ(0)=$G(^TIU(8925,DA,0)) + I X'="" I +$P($G(^TIU(8925,+DA,14)),U,4),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ASVC",+$P($G(^TIU(8925,+DA,14)),U,4),+X,+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA) S X=$P(DIKZ(0),U,1) - I X'="" S ^TIU(8925,"B",$E(X,1,30),DA)="" + I X'="" I $L($P(^TIU(8925,+DA,0),U)),(+$P(^(0),U,3)>0) K ^TIU(8925,"AE",+$P($G(^TIU(8925,+DA,0)),U,2),(9999999-$P(+^AUPNVSIT(+$P(^TIU(8925,+DA,0),U,3),0),".")),+X,+DA) S X=$P(DIKZ(0),U,1) - I X'="" I +$P(^TIU(8925,+DA,0),U,2),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"APT",+$P(^TIU(8925,+DA,0),U,2),+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" + I X'="" I +$P($G(^TIU(8925,+DA,12)),U,5),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ALOC",+$P($G(^TIU(8925,+DA,12)),U,5),+X,+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA) S X=$P(DIKZ(0),U,1) - I X'="" I +$P($G(^TIU(8925,+DA,12)),U,2),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"AAU",+$P($G(^TIU(8925,+DA,12)),U,2),+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" + I X'="" I +$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5),+$O(^TIU(8925.9,"B",+DA,0)) D APRBK^TIUDD(+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-+$G(^TIU(8925,+DA,13))),DA) S X=$P(DIKZ(0),U,1) - I X'="" I +$P($G(^TIU(8925,+DA,12)),U,8),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ASUP",+$P($G(^TIU(8925,+DA,12)),U,8),+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" + I X'="" I +$P(^TIU(8925,+DA,0),U,3),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"AVSIT",+$P(^TIU(8925,+DA,0),U,3),+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),DA) S X=$P(DIKZ(0),U,1) - I X'="" I $P($$DOCTYPE^TIULF(+DA),U)="DOC",+$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^(0)),U,3) S ^TIU(8925,"AV",+$P(^TIU(8925,+DA,0),U,2),+X,+$P(^TIU(8925,+DA,0),U,3),+DA)="" + I X'="" I +$P(^TIU(8925,+DA,0),U,2),+$P($G(^TIU(8925,+DA,13)),U) K ^TIU(8925,"APTCL",+$P(^TIU(8925,+DA,0),U,2),+$$CLINDOC^TIULC1(+X,+DA),(9999999-$P(^TIU(8925,+DA,13),U)),DA) S X=$P(DIKZ(0),U,1) - I X'="" I +$P($G(^TIU(8925,+DA,14)),U,2),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ATS",+$P($G(^TIU(8925,+DA,14)),U,2),+X,+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" + I X'="" I +$P(^TIU(8925,+DA,0),U,2),+$P($G(^TIU(8925,+DA,13)),U) K ^TIU(8925,"APTCL",+$P(^TIU(8925,+DA,0),U,2),38,(9999999-$P(^TIU(8925,+DA,13),U)),DA) S X=$P(DIKZ(0),U,1) - I X'="" I +$P($G(^TIU(8925,+DA,13)),U,2),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ATC",+$P($G(^TIU(8925,+DA,13)),U,2),+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" + I X'="" D KACLPT^TIUDD01(.01,X) S X=$P(DIKZ(0),U,1) - I X'="" I +$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ALL","ANY",+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" + I X'="" D KACLAU^TIUDD01(.01,X),KACLAU1^TIUDD01(.01,X) S X=$P(DIKZ(0),U,1) - I X'="" I $P($$DOCTYPE^TIULF(+DA),U)="DOC",$L($P(^TIU(8925,+DA,0),U,2)),(+$P(^(0),U,3)>0) S ^TIU(8925,"AA",+$P(^(0),U,2),+X,(9999999-$P(+^AUPNVSIT(+$P(^TIU(8925,+DA,0),U,3),0),".")),DA)="" + I X'="" D KACLEC^TIUDD01(.01,X) S X=$P(DIKZ(0),U,1) - I X'="" I $L($P($G(^TIU(8925,+DA,17)),U)),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) D ASUBS^TIUDD($P($G(^TIU(8925,+DA,17)),U),+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-+$G(^TIU(8925,+DA,13))),DA) + I X'="" D KACLSB^TIUDD01(.01,X) S X=$P(DIKZ(0),U,1) - I X'="" I +$P($G(^TIU(8925,+DA,14)),U,4),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ASVC",+$P($G(^TIU(8925,+DA,14)),U,4),+X,+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" - S X=$P(DIKZ(0),U,1) - I X'="" I $P($$DOCTYPE^TIULF(+DA),U)="DOC",+$P($G(^TIU(8925,+DA,0)),U,2),(+$P($G(^(0)),U,3)>0) S ^TIU(8925,"AE",+$P($G(^TIU(8925,+DA,0)),U,2),(9999999-$P(+^AUPNVSIT(+$P(^TIU(8925,+DA,0),U,3),0),".")),+X,+DA)="" - S X=$P(DIKZ(0),U,1) - I X'="" I +$P($G(^TIU(8925,+DA,12)),U,5),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ALOC",+$P($G(^TIU(8925,+DA,12)),U,5),+X,+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" - S X=$P(DIKZ(0),U,1) - I X'="" I +$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5),+$O(^TIU(8925.9,"B",+DA,0)) D APRBS^TIUDD(+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-+$G(^TIU(8925,+DA,13))),DA) - S X=$P(DIKZ(0),U,1) - I X'="" I +$P(^TIU(8925,+DA,0),U,3),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"AVSIT",+$P(^TIU(8925,+DA,0),U,3),+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" - S X=$P(DIKZ(0),U,1) - I X'="" I +$P(^TIU(8925,+DA,0),U,2),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"APTCL",+$P(^TIU(8925,+DA,0),U,2),+$$CLINDOC^TIULC1(+X,+DA),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" - S X=$P(DIKZ(0),U,1) - I X'="" I +$P(^TIU(8925,+DA,0),U,2),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"APTCL",+$P(^TIU(8925,+DA,0),U,2),38,(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" - S X=$P(DIKZ(0),U,1) - I X'="" D SACLPT^TIUDD0(.01,X) - S X=$P(DIKZ(0),U,1) - I X'="" D SACLAU^TIUDD0(.01,X),SACLAU1^TIUDD0(.01,X) - S X=$P(DIKZ(0),U,1) - I X'="" D SACLEC^TIUDD0(.01,X) - S X=$P(DIKZ(0),U,1) - I X'="" D SACLSB^TIUDD0(.01,X) - S X=$P(DIKZ(0),U,1) - I X'="" D SAPTLD^TIUDD0(.01,X) - S X=$P(DIKZ(0),U,2) - I X'="" I $P($$DOCTYPE^TIULF(+DA),U)="DOC",$L($P(^TIU(8925,+DA,0),U)),(+$P(^(0),U,3)>0) S ^TIU(8925,"AA",+X,+^TIU(8925,+DA,0),(9999999-$P(+^AUPNVSIT($P(^TIU(8925,+DA,0),U,3),0),".")),+DA)="" - S X=$P(DIKZ(0),U,2) - I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"APT",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" - S X=$P(DIKZ(0),U,2) - I X'="" I $P($$DOCTYPE^TIULF(+DA),U)="DOC",$L($P(^TIU(8925,+DA,0),U)),(+$P(^(0),U,3)>0) S ^TIU(8925,"AE",+X,(9999999-$P(+^AUPNVSIT($P(^TIU(8925,+DA,0),U,3),0),".")),+^TIU(8925,+DA,0),+DA)="" - S X=$P(DIKZ(0),U,2) - I X'="" S ^TIU(8925,"C",$E(X,1,30),DA)="" - S X=$P(DIKZ(0),U,2) - I X'="" I $P($$DOCTYPE^TIULF(+DA),U)="DOC",+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^(0)),U,3) S ^TIU(8925,"AV",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,3),+DA)="" - S X=$P(DIKZ(0),U,2) - I X'="" I +$$APTP^TIULX(+DA),+$P($G(^TIU(8925,+DA,15)),U) S ^TIU(8925,"APTP",+X,+$P($G(^TIU(8925,+DA,15)),U),+DA)="" - S X=$P(DIKZ(0),U,2) - I X'="" I +$P($G(^TIU(8925,+DA,0)),U,4),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ADCPT",+X,+$P(^TIU(8925,+DA,0),U,4),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" - S X=$P(DIKZ(0),U,2) - I X'="" I +$P(^TIU(8925,+DA,0),U),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"APTCL",+X,+$$CLINDOC^TIULC1(+$P(^TIU(8925,+DA,0),U),+DA),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" - S X=$P(DIKZ(0),U,2) - I X'="" I +$P(^TIU(8925,+DA,0),U),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"APTCL",+X,38,(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" - S X=$P(DIKZ(0),U,2) - I X'="" D SACLPT^TIUDD0(.02,X) - S X=$P(DIKZ(0),U,2) - I X'="" D SACLAU^TIUDD0(.02,X),SACLAU1^TIUDD0(.02,X) - S X=$P(DIKZ(0),U,2) - I X'="" D SACLEC^TIUDD0(.02,X) - S X=$P(DIKZ(0),U,2) - I X'="" D SACLSB^TIUDD0(.02,X) - S X=$P(DIKZ(0),U,2) - I X'="" D SAPTLD^TIUDD0(.02,X) - S X=$P(DIKZ(0),U,3) - I X'="" I $P($$DOCTYPE^TIULF(+DA),U)="DOC",$L($P(^TIU(8925,+DA,0),U)),(+$P(^(0),U,2)>0) S ^TIU(8925,"AA",$P(^(0),U,2),+$P(^(0),U),(9999999-$P(+$G(^AUPNVSIT(X,0)),".")),DA)="" - S X=$P(DIKZ(0),U,3) - I X'="" I $P($$DOCTYPE^TIULF(+DA),U)="DOC",$L($P(^TIU(8925,+DA,0),U)),(+$P(^(0),U,2)>0) S ^TIU(8925,"AE",+$P(^TIU(8925,+DA,0),U,2),(9999999-$P(+$G(^AUPNVSIT(+X,0)),".")),+^TIU(8925,+DA,0),+DA)="" - S X=$P(DIKZ(0),U,3) - I X'="" I $P($$DOCTYPE^TIULF(+DA),U)="DOC",+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^(0)),U,2) S ^TIU(8925,"AV",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U),+X,+DA)="" - S X=$P(DIKZ(0),U,3) - I X'="" D:$D(^AUPNVSIT(+X)) ADD^AUPNVSIT - S X=$P(DIKZ(0),U,3) - I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"AVSIT",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" - S X=$P(DIKZ(0),U,3) - I X'="" S ^TIU(8925,"V",$E(X,1,30),DA)="" - S X=$P(DIKZ(0),U,3) - I X'="" D - .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^TIU(8925,D0,150)):^(150),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y X ^DD(8925,.03,1,7,1.1) X ^DD(8925,.03,1,7,1.4) - S X=$P(DIKZ(0),U,3) - I X'="" D SAPTLD^TIUDD0(.03,X) - S DIKZ(0)=$G(^TIU(8925,DA,0)) - S X=$P(DIKZ(0),U,4) - I X'="" I +$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ADCPT",+$P(^TIU(8925,+DA,0),U,2),+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" - S X=$P(DIKZ(0),U,5) - I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,8),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ASUP",+$P(^TIU(8925,+DA,12),U,8),+$P(^TIU(8925,+DA,0),U),+X,(9999999-+$P(^TIU(8925,+DA,13),U)),+DA)="" - S X=$P(DIKZ(0),U,5) - I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,2),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"AAU",+$P(^TIU(8925,+DA,12),U,2),+$P(^TIU(8925,+DA,0),U),+X,(9999999-$P(^TIU(8925,+DA,13),U)),+DA)="" - S X=$P(DIKZ(0),U,5) - I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"APT",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U),+X,(9999999-$P(^TIU(8925,+DA,13),U)),+DA)="" - S X=$P(DIKZ(0),U,5) - I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U,2),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"ATC",+$P($G(^TIU(8925,+DA,13)),U,2),+$P(^TIU(8925,+DA,0),U),+X,(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" - S X=$P(DIKZ(0),U,5) - I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,14)),U,2),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"ATS",+$P($G(^TIU(8925,+DA,14)),U,2),+$P(^TIU(8925,+DA,0),U),+X,(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" - S X=$P(DIKZ(0),U,5) - I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"ALL","ANY",+$P(^TIU(8925,+DA,0),U),+X,(9999999-$P(^TIU(8925,+DA,13),U)),+DA)="" - S X=$P(DIKZ(0),U,5) - I X'="" I +$P($G(^TIU(8925,+DA,0)),U),$L($P($G(^TIU(8925,+DA,17)),U)),+$P($G(^TIU(8925,+DA,13)),U) D ASUBS^TIUDD($P($G(^TIU(8925,+DA,17)),U),+$G(^TIU(8925,+DA,0)),+X,(9999999-+$G(^TIU(8925,+DA,13))),DA) - S X=$P(DIKZ(0),U,5) - I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,14)),U,4),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"ASVC",+$P($G(^TIU(8925,+DA,14)),U,4),+$P(^TIU(8925,+DA,0),U),+X,(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" - S X=$P(DIKZ(0),U,5) - I X'="" I +$P($G(^TIU(8925,+DA,12)),U,5),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U) S ^TIU(8925,"ALOC",+$P($G(^TIU(8925,+DA,12)),U,5),+$P($G(^TIU(8925,+DA,0)),U),+X,(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" - S X=$P(DIKZ(0),U,5) - I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$O(^TIU(8925.9,"B",+DA,0)) D APRBS^TIUDD(+$G(^TIU(8925,+DA,0)),+X,(9999999-+$G(^TIU(8925,+DA,13))),DA) - S X=$P(DIKZ(0),U,5) -END G ^TIUXRC4 + I X'="" D KAPTLD^TIUDD01(.01,X) +CR1 S DIXR=247 + K X + S X(1)=$P(DIKZ(12),U,12) + S X(2)=$P(DIKZ(0),U,1) + S X(3)=$P(DIKZ(0),U,5) + S X=$P(DIKZ(13),U,1) + I $G(X)]"" S X=9999999-X + S:$D(X)#2 X(4)=X + S X=$G(X(1)) + I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D + . K X1,X2 M X1=X,X2=X + . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4))="" + . K ^TIU(8925,"ADIV",X(1),X(2),X(3),X(4),DA) +CR2 S DIXR=413 + K X + S DIKZ(12)=$G(^TIU(8925,DA,12)) + S X(1)=$P(DIKZ(12),U,7) + S X=$G(X(1)) + I $G(X(1))]"" D + . K X1,X2 M X1=X,X2=X + . S:$D(DIKIL) (X2,X2(1))="" + . K ^TIU(8925,"VS",X,DA) +CR3 K X +END Q diff --git a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC4.m b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC4.m index a12f6126..9bb7b658 100644 --- a/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC4.m +++ b/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC4.m @@ -1,158 +1,101 @@ -TIUXRC4 ; COMPILED XREF FOR FILE #8925 ; 11/08/09 +TIUXRC4 ; COMPILED XREF FOR FILE #8925 ; 12/25/06 ; -END G ^TIUXRC4 - S X=$P(DIKZ(0),U,5) - I X'="" I +$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,4) S ^TIU(8925,"ADCPT",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U,4),+X,(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" - S X=$P(DIKZ(0),U,5) - I X'="" D SACLPT^TIUDD0(.05,X) - S X=$P(DIKZ(0),U,5) - I X'="" D SACLEC^TIUDD0(.05,X) - S X=$P(DIKZ(0),U,5) - I X'="" D SACLAU^TIUDD0(.05,X),SACLAU1^TIUDD0(.05,X) - S X=$P(DIKZ(0),U,6) - I X'="" S ^TIU(8925,"DAD",$E(X,1,30),DA)="" - S X=$P(DIKZ(0),U,7) - I X'="" D SAPTLD^TIUDD0(.07,X) - S X=$P(DIKZ(0),U,12) - I X'="" S ^TIU(8925,"FIX",$E(X,1,30),DA)="" - S X=$P(DIKZ(0),U,13) - I X'="" D SAPTLD^TIUDD0(.13,X) - S DIKZ(12)=$G(^TIU(8925,DA,12)) - S X=$P(DIKZ(12),U,1) - I X'="" S ^TIU(8925,"F",$E(X,1,30),DA)="" - S X=$P(DIKZ(12),U,2) - I X'="" S ^TIU(8925,"CA",$E(X,1,30),DA)="" - S X=$P(DIKZ(12),U,2) - I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"AAU",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),+DA)="" - S X=$P(DIKZ(12),U,2) - I X'="" I +$$AAUP^TIULX(+DA),+$P($G(^TIU(8925,+DA,15)),U) S ^TIU(8925,"AAUP",+X,+$P($G(^TIU(8925,+DA,15)),U),+DA)="" - S X=$P(DIKZ(12),U,2) - I X'="" D SACLAU^TIUDD0(1202,X) - S X=$P(DIKZ(12),U,2) + S DIKZK=1 + S DIKZ(0)=$G(^TIU(8925,DA,0)) + S X=$P(DIKZ(0),U,1) + I X'="" S ^TIU(8925,"B",$E(X,1,30),DA)="" + S X=$P(DIKZ(0),U,1) + I X'="" I +$P(^TIU(8925,+DA,0),U,2),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"APT",+$P(^TIU(8925,+DA,0),U,2),+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" + S X=$P(DIKZ(0),U,1) + I X'="" I +$P($G(^TIU(8925,+DA,12)),U,2),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"AAU",+$P($G(^TIU(8925,+DA,12)),U,2),+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" + S X=$P(DIKZ(0),U,1) + I X'="" I +$P($G(^TIU(8925,+DA,12)),U,8),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ASUP",+$P($G(^TIU(8925,+DA,12)),U,8),+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" + S X=$P(DIKZ(0),U,1) + I X'="" I $P($$DOCTYPE^TIULF(+DA),U)="DOC",+$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^(0)),U,3) S ^TIU(8925,"AV",+$P(^TIU(8925,+DA,0),U,2),+X,+$P(^TIU(8925,+DA,0),U,3),+DA)="" + S X=$P(DIKZ(0),U,1) + I X'="" I +$P($G(^TIU(8925,+DA,14)),U,2),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ATS",+$P($G(^TIU(8925,+DA,14)),U,2),+X,+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" + S X=$P(DIKZ(0),U,1) + I X'="" I +$P($G(^TIU(8925,+DA,13)),U,2),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ATC",+$P($G(^TIU(8925,+DA,13)),U,2),+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" + S X=$P(DIKZ(0),U,1) + I X'="" I +$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ALL","ANY",+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" + S X=$P(DIKZ(0),U,1) + I X'="" I $P($$DOCTYPE^TIULF(+DA),U)="DOC",$L($P(^TIU(8925,+DA,0),U,2)),(+$P(^(0),U,3)>0) S ^TIU(8925,"AA",+$P(^(0),U,2),+X,(9999999-$P(+^AUPNVSIT(+$P(^TIU(8925,+DA,0),U,3),0),".")),DA)="" + S X=$P(DIKZ(0),U,1) + I X'="" I $L($P($G(^TIU(8925,+DA,17)),U)),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) D ASUBS^TIUDD($P($G(^TIU(8925,+DA,17)),U),+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-+$G(^TIU(8925,+DA,13))),DA) + S X=$P(DIKZ(0),U,1) + I X'="" I +$P($G(^TIU(8925,+DA,14)),U,4),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ASVC",+$P($G(^TIU(8925,+DA,14)),U,4),+X,+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" + S X=$P(DIKZ(0),U,1) + I X'="" I $P($$DOCTYPE^TIULF(+DA),U)="DOC",+$P($G(^TIU(8925,+DA,0)),U,2),(+$P($G(^(0)),U,3)>0) S ^TIU(8925,"AE",+$P($G(^TIU(8925,+DA,0)),U,2),(9999999-$P(+^AUPNVSIT(+$P(^TIU(8925,+DA,0),U,3),0),".")),+X,+DA)="" + S X=$P(DIKZ(0),U,1) + I X'="" I +$P($G(^TIU(8925,+DA,12)),U,5),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ALOC",+$P($G(^TIU(8925,+DA,12)),U,5),+X,+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" + S X=$P(DIKZ(0),U,1) + I X'="" I +$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5),+$O(^TIU(8925.9,"B",+DA,0)) D APRBS^TIUDD(+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-+$G(^TIU(8925,+DA,13))),DA) + S X=$P(DIKZ(0),U,1) + I X'="" I +$P(^TIU(8925,+DA,0),U,3),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"AVSIT",+$P(^TIU(8925,+DA,0),U,3),+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" + S X=$P(DIKZ(0),U,1) + I X'="" I +$P(^TIU(8925,+DA,0),U,2),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"APTCL",+$P(^TIU(8925,+DA,0),U,2),+$$CLINDOC^TIULC1(+X,+DA),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" + S X=$P(DIKZ(0),U,1) + I X'="" I +$P(^TIU(8925,+DA,0),U,2),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"APTCL",+$P(^TIU(8925,+DA,0),U,2),38,(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" + S X=$P(DIKZ(0),U,1) + I X'="" D SACLPT^TIUDD0(.01,X) + S X=$P(DIKZ(0),U,1) + I X'="" D SACLAU^TIUDD0(.01,X),SACLAU1^TIUDD0(.01,X) + S X=$P(DIKZ(0),U,1) + I X'="" D SACLEC^TIUDD0(.01,X) + S X=$P(DIKZ(0),U,1) + I X'="" D SACLSB^TIUDD0(.01,X) + S X=$P(DIKZ(0),U,1) + I X'="" D SAPTLD^TIUDD0(.01,X) + S X=$P(DIKZ(0),U,2) + I X'="" I $P($$DOCTYPE^TIULF(+DA),U)="DOC",$L($P(^TIU(8925,+DA,0),U)),(+$P(^(0),U,3)>0) S ^TIU(8925,"AA",+X,+^TIU(8925,+DA,0),(9999999-$P(+^AUPNVSIT($P(^TIU(8925,+DA,0),U,3),0),".")),+DA)="" + S X=$P(DIKZ(0),U,2) + I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"APT",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" + S X=$P(DIKZ(0),U,2) + I X'="" I $P($$DOCTYPE^TIULF(+DA),U)="DOC",$L($P(^TIU(8925,+DA,0),U)),(+$P(^(0),U,3)>0) S ^TIU(8925,"AE",+X,(9999999-$P(+^AUPNVSIT($P(^TIU(8925,+DA,0),U,3),0),".")),+^TIU(8925,+DA,0),+DA)="" + S X=$P(DIKZ(0),U,2) + I X'="" S ^TIU(8925,"C",$E(X,1,30),DA)="" + S X=$P(DIKZ(0),U,2) + I X'="" I $P($$DOCTYPE^TIULF(+DA),U)="DOC",+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^(0)),U,3) S ^TIU(8925,"AV",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,3),+DA)="" + S X=$P(DIKZ(0),U,2) + I X'="" I +$$APTP^TIULX(+DA),+$P($G(^TIU(8925,+DA,15)),U) S ^TIU(8925,"APTP",+X,+$P($G(^TIU(8925,+DA,15)),U),+DA)="" + S X=$P(DIKZ(0),U,2) + I X'="" I +$P($G(^TIU(8925,+DA,0)),U,4),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ADCPT",+X,+$P(^TIU(8925,+DA,0),U,4),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" + S X=$P(DIKZ(0),U,2) + I X'="" I +$P(^TIU(8925,+DA,0),U),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"APTCL",+X,+$$CLINDOC^TIULC1(+$P(^TIU(8925,+DA,0),U),+DA),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" + S X=$P(DIKZ(0),U,2) + I X'="" I +$P(^TIU(8925,+DA,0),U),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"APTCL",+X,38,(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" + S X=$P(DIKZ(0),U,2) + I X'="" D SACLPT^TIUDD0(.02,X) + S X=$P(DIKZ(0),U,2) + I X'="" D SACLAU^TIUDD0(.02,X),SACLAU1^TIUDD0(.02,X) + S X=$P(DIKZ(0),U,2) + I X'="" D SACLEC^TIUDD0(.02,X) + S X=$P(DIKZ(0),U,2) + I X'="" D SACLSB^TIUDD0(.02,X) + S X=$P(DIKZ(0),U,2) + I X'="" D SAPTLD^TIUDD0(.02,X) + S X=$P(DIKZ(0),U,3) + I X'="" I $P($$DOCTYPE^TIULF(+DA),U)="DOC",$L($P(^TIU(8925,+DA,0),U)),(+$P(^(0),U,2)>0) S ^TIU(8925,"AA",$P(^(0),U,2),+$P(^(0),U),(9999999-$P(+$G(^AUPNVSIT(X,0)),".")),DA)="" + S X=$P(DIKZ(0),U,3) + I X'="" I $P($$DOCTYPE^TIULF(+DA),U)="DOC",$L($P(^TIU(8925,+DA,0),U)),(+$P(^(0),U,2)>0) S ^TIU(8925,"AE",+$P(^TIU(8925,+DA,0),U,2),(9999999-$P(+$G(^AUPNVSIT(+X,0)),".")),+^TIU(8925,+DA,0),+DA)="" + S X=$P(DIKZ(0),U,3) + I X'="" I $P($$DOCTYPE^TIULF(+DA),U)="DOC",+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^(0)),U,2) S ^TIU(8925,"AV",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U),+X,+DA)="" + S X=$P(DIKZ(0),U,3) + I X'="" D:$D(^AUPNVSIT(+X)) ADD^AUPNVSIT + S X=$P(DIKZ(0),U,3) + I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"AVSIT",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" + S X=$P(DIKZ(0),U,3) + I X'="" S ^TIU(8925,"V",$E(X,1,30),DA)="" + S X=$P(DIKZ(0),U,3) I X'="" D .N DIK,DIV,DIU,DIN - .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I '+$$ISDS^TIULX(+$G(^TIU(8925,+DA,0))) I X S X=DIV S Y(1)=$S($D(^TIU(8925,D0,14)):^(14),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y X ^DD(8925,1202,1,5,1.1) X ^DD(8925,1202,1,5,1.4) - S DIKZ(12)=$G(^TIU(8925,DA,12)) - S X=$P(DIKZ(12),U,5) - I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ALOC",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" - S X=$P(DIKZ(12),U,5) - I X'="" I +$$ALOCP^TIULX(+DA),+$P($G(^TIU(8925,+DA,15)),U) S ^TIU(8925,"ALOCP",+X,+$P($G(^TIU(8925,+DA,15)),U),+DA)="" - S X=$P(DIKZ(12),U,7) - I X'="" D:$D(^AUPNVSIT(+X)) ADD^AUPNVSIT - S X=$P(DIKZ(12),U,8) - I X'="" S ^TIU(8925,"CS",$E(X,1,30),DA)="" - S X=$P(DIKZ(12),U,8) - I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ASUP",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" - S X=$P(DIKZ(12),U,8) - I X'="" D SACLEC^TIUDD0(1208,X) - S X=$P(DIKZ(12),U,11) - I X'="" D SAPTLD^TIUDD0(1211,X) - S DIKZ(13)=$G(^TIU(8925,DA,13)) - S X=$P(DIKZ(13),U,1) - I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"AAU",+$P(^TIU(8925,+DA,12),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" - S X=$P(DIKZ(13),U,1) - I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,8),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ASUP",+$P(^TIU(8925,+DA,12),U,8),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" - S X=$P(DIKZ(13),U,1) - I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"APT",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" - S X=$P(DIKZ(13),U,1) - I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,14)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ATS",+$P(^TIU(8925,+DA,14),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" - S X=$P(DIKZ(13),U,1) - I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ATC",+$P(^TIU(8925,+DA,13),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" - S X=$P(DIKZ(13),U,1) - I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ALL","ANY",+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" - S X=$P(DIKZ(13),U,1) - I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),$L($P($G(^TIU(8925,+DA,17)),U)) D ASUBS^TIUDD($P($G(^TIU(8925,+DA,17)),U),+$G(^TIU(8925,+DA,0)),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-+X),DA) - S X=$P(DIKZ(13),U,1) - I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,14)),U,4),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ASVC",+$P(^TIU(8925,+DA,14),U,4),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" - S X=$P(DIKZ(13),U,1) - I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),+$O(^TIU(8925.9,"B",+DA,0)) D APRBS^TIUDD(+$G(^TIU(8925,+DA,0)),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-+X),DA) - S X=$P(DIKZ(13),U,1) - I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,3),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"AVSIT",+$P(^TIU(8925,+DA,0),U,3),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),DA)="" - S X=$P(DIKZ(13),U,1) - I X'="" I +$P($G(^TIU(8925,+DA,0)),U,4),+$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ADCPT",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U,4),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),DA)="" - S X=$P(DIKZ(13),U,1) - I X'="" S ^TIU(8925,"D",$E(X,1,30),DA)="" - S X=$P(DIKZ(13),U,1) - I X'="" I +$P(^TIU(8925,+DA,0),U),+$P($G(^TIU(8925,+DA,0)),U,2) S ^TIU(8925,"APTCL",+$P(^TIU(8925,+DA,0),U,2),+$$CLINDOC^TIULC1(+$P(^TIU(8925,+DA,0),U),+DA),(9999999-X),DA)="" - S X=$P(DIKZ(13),U,1) - I X'="" I +$P(^TIU(8925,+DA,0),U),+$P($G(^TIU(8925,+DA,0)),U,2) S ^TIU(8925,"APTCL",+$P(^TIU(8925,+DA,0),U,2),38,(9999999-X),DA)="" - S X=$P(DIKZ(13),U,1) - I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,5),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ALOC",+$P(^TIU(8925,+DA,12),U,5),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)="" - S X=$P(DIKZ(13),U,1) - I X'="" D SACLPT^TIUDD0(1301,X) - S X=$P(DIKZ(13),U,1) - I X'="" D SACLAU^TIUDD0(1301,X),SACLAU1^TIUDD0(1301,X) - S X=$P(DIKZ(13),U,1) - I X'="" D SACLEC^TIUDD0(1301,X) - S X=$P(DIKZ(13),U,1) - I X'="" D SACLSB^TIUDD0(1301,X) - S X=$P(DIKZ(13),U,2) - I X'="" S ^TIU(8925,"TC",$E(X,1,30),DA)="" - S X=$P(DIKZ(13),U,2) - I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ATC",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" - S X=$P(DIKZ(13),U,2) - I X'="" D SACLAU1^TIUDD0(1302,X) - S X=$P(DIKZ(13),U,4) - I X'="" S ^TIU(8925,"E",$E(X,1,30),DA)="" - S DIKZ(14)=$G(^TIU(8925,DA,14)) - S X=$P(DIKZ(14),U,2) - I X'="" S ^TIU(8925,"TS",$E(X,1,30),DA)="" - S X=$P(DIKZ(14),U,2) - I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ATS",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" - S X=$P(DIKZ(14),U,4) - I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ASVC",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)="" - S X=$P(DIKZ(14),U,4) - I X'="" S ^TIU(8925,"SVC",$E(X,1,30),DA)="" - S X=$P(DIKZ(14),U,5) - I X'="" S ^TIU(8925,"G",$E(X,1,30),DA)="" - S DIKZ(15)=$G(^TIU(8925,DA,15)) - S X=$P(DIKZ(15),U,1) - I X'="" I +$$ALOCP^TIULX(+DA),+$P($G(^TIU(8925,+DA,12)),U,5) S ^TIU(8925,"ALOCP",+$P($G(^TIU(8925,+DA,12)),U,5),+X,+DA)="" - S X=$P(DIKZ(15),U,1) - I X'="" I +$$APTP^TIULX(+DA),+$P($G(^TIU(8925,+DA,0)),U,2) S ^TIU(8925,"APTP",+$P($G(^TIU(8925,+DA,0)),U,2),+X,+DA)="" - S X=$P(DIKZ(15),U,1) - I X'="" I +$$AAUP^TIULX(+DA),+$P($G(^TIU(8925,+DA,12)),U,2) S ^TIU(8925,"AAUP",+$P($G(^TIU(8925,+DA,12)),U,2),+X,+DA)="" - S X=$P(DIKZ(15),U,1) - I X'="" D SACLPT^TIUDD0(1501,X) - S X=$P(DIKZ(15),U,1) - I X'="" D SACLEC^TIUDD0(1501,X) - S X=$P(DIKZ(15),U,1) - I X'="" D KACLAU^TIUDD01(1501,X),KACLAU1^TIUDD01(1501,X) - S X=$P(DIKZ(15),U,2) - I X'="" D SACLSB^TIUDD0(1502,X) - S X=$P(DIKZ(15),U,7) - I X'="" D KACLEC^TIUDD01(1507,X) - S X=$P(DIKZ(15),U,7) - I X'="" D SACLPT^TIUDD0(1507,X) - S DIKZ(17)=$G(^TIU(8925,DA,17)) - S X=$P(DIKZ(17),U,1) - I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),+$P($G(^TIU(8925,+DA,13)),U) D ASUBS^TIUDD($G(X),+$G(^TIU(8925,+DA,0)),+$P(^TIU(8925,+DA,0),U,5),(9999999-+$G(^TIU(8925,+DA,13))),DA) - S DIKZ(21)=$G(^TIU(8925,DA,21)) - S X=$P(DIKZ(21),U,1) - I X'="" S ^TIU(8925,"GDAD",$E(X,1,30),DA)="" - S DIKZ(150)=$G(^TIU(8925,DA,150)) - S X=$P(DIKZ(150),U,1) - I X'="" S ^TIU(8925,"VID",$E(X,1,30),DA)="" -CR1 S DIXR=247 - K X - S X(1)=$P(DIKZ(12),U,12) + .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^TIU(8925,D0,150)):^(150),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y X ^DD(8925,.03,1,7,1.1) X ^DD(8925,.03,1,7,1.4) + S X=$P(DIKZ(0),U,3) + I X'="" D SAPTLD^TIUDD0(.03,X) S DIKZ(0)=$G(^TIU(8925,DA,0)) - S X(2)=$P(DIKZ(0),U,1) - S X(3)=$P(DIKZ(0),U,5) - S X=$P(DIKZ(13),U,1) - I $G(X)]"" S X=9999999-X - S:$D(X)#2 X(4)=X - S X=$G(X(1)) - I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D - . K X1,X2 M X1=X,X2=X - . S ^TIU(8925,"ADIV",X(1),X(2),X(3),X(4),DA)="" -CR2 S DIXR=413 - K X - S DIKZ(12)=$G(^TIU(8925,DA,12)) - S X(1)=$P(DIKZ(12),U,7) - S X=$G(X(1)) - I $G(X(1))]"" D - . K X1,X2 M X1=X,X2=X - . S ^TIU(8925,"VS",X,DA)="" -CR3 K X -END Q + S X=$P(DIKZ(0),U,4) + I X'="" I +$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ADCPT",+$P(^TIU(8925,+DA,0),U,2),+X,+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),DA)="" + S X=$P(DIKZ(0),U,5) + I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,8),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ASUP",+$P(^TIU(8925,+DA,12),U,8),+$P(^TIU(8925,+DA,0),U),+X,(9999999-+$P(^TIU(8925,+DA,13),U)),+DA)="" + S X=$P(DIKZ(0),U,5) +END G ^TIUXRC5 diff --git a/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XDRDSHOW.m b/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XDRDSHOW.m index 9af4e00f..461e4997 100644 --- a/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XDRDSHOW.m +++ b/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XDRDSHOW.m @@ -1,151 +1,149 @@ -XDRDSHOW ;SF-IRMFO.SEA/JLI - DISPLAY DATA IN FIELDS, GET OVERWRITES ;01/30/2008 - ;;7.3;TOOLKIT;**23,49,78,112**;Apr 25, 1995;Build 1 - ;; -SHOW(FILE,REC1,REC2,FLDS,REVIEW) ; - N FILDIC,MULT,DDVAL,NAMIEN1,NAMIEN2,NAMREC1,NAMREC2,FIRSTIME,MPIMB - S FILDIC=$G(^DIC(FILE,0,"GL")) Q:FILDIC="" - S REVIEW=+$G(REVIEW) - S FILREC1=FILDIC_"REC1)" - S FILREC2=FILDIC_"REC2)" - S NAMREC1=$P($G(@FILREC1@(0)),U) I NAMREC1="" Q - S NAMREC2=$P($G(@FILREC2@(0)),U) I NAMREC2="" Q - I FILE=63 D - . S NAMIEN1=+$P(@FILREC1@(0),U,3),NAMIEN2=+$P(@FILREC2@(0),U,3) - . S NAMREC1=$P(^DPT(NAMIEN1,0),U),NAMREC2=$P(^DPT(NAMIEN2,0),U) - I $P(^DD(FILE,.01,0),U,2)["P" D - . N XFIL - . S XFIL=+$P($P($G(^DD(FILE,.01,0)),U,2),"P",2) Q:XFIL'>0 - . S XFIL=$G(^DIC(XFIL,0,"GL")) Q:XFIL="" - . S NAMREC1=$P(@(XFIL_NAMREC1_",0)"),U) - . S NAMREC2=$P(@(XFIL_NAMREC2_",0)"),U) - ; - ; recalc CMOR scores - I FILE=2,$D(^DD(FILE,991.06)) D - . N RGDFN S RGDFN=REC1 D CALC^RGVCCMR2 - . N RGDFN S RGDFN=REC2 D CALC^RGVCCMR2 - . Q - ; - ; check for multiple birth indicator in MPI - S FIRSTIME=1 - I FILE=2 D - . I $G(^DPT(REC1,"MPIMB"))="Y"!($G(^DPT(REC2,"MPIMB"))="Y") S MPIMB=1 - . E S MPIMB=0 - ; - D HEADER -LOOP ; - S FLD=0 - F FLD=0:0 S FLD=$O(^DD(FILE,FLD)) Q:FLD'>0 D I NLIN<6 D PAGE Q:$D(DIRUT) D HEADER - . I FILE=63,$P($G(^DD(FILE,FLD,0)),U)="NAME" Q ;scrn patient file data. From Lab - . I FILE'=2,$P($G(^DD(FILE,FLD,0)),U,2)["P2" Q ;From DINUM pointers. - . S DDVAL=$G(^DD(FILE,FLD,0)) - . S NODE=$P($P(DDVAL,U,4),";") - . S PIECE=$P($P(DDVAL,U,4),";",2) - . I PIECE=0 S MULT(FLD)="" - . I PIECE>0 D - . . S X1=$P($G(@FILREC1@(NODE)),U,PIECE),X1=$$TYPE(X1,$P(DDVAL,U,2),DDVAL,REC1) - . . S X2=$P($G(@FILREC2@(NODE)),U,PIECE),X2=$$TYPE(X2,$P(DDVAL,U,2),DDVAL,REC2) - . . I X1'=""!(X2'="") D - . . . S X0=" " - . . . S XN=$P(DDVAL,U) - . . . S XDRA=0 - . . . I X1'=""&(X2'=""),X1'=X2 D - . . . . I FILE=2,((FLD=991.01)!(FLD=991.02)) Q ;jds restrict ICN overwrites for MPI - . . . . S X0=$S($D(FLDS(FLD)):"||||",1:"****"),NDIFFS=NDIFFS+1,DIFFS(NDIFFS)=FLD,XDRA=1 I REVIEW S NLIN=NLIN-1 - . . . I 'REVIEW!XDRA D - . . . . W ! S NLIN=NLIN-1 - . . . . F Q:XN=""&(X1="")&(X2="") D - . . . . . W !,X0," ",$E(XN,1,20),?30,$E(X1,1,20),?55,$E(X2,1,20) - . . . . . S NLIN=NLIN-1 - . . . . . S X0=" ",XN=$E(XN,21,$L(XN)) - . . . . . S X1=$E(X1,21,$L(X1)) - . . . . . S X2=$E(X2,21,$L(X2)) -MULT I '$D(DIRUT) D - . I $G(NDIFFS)>0 D PAGE Q:$D(DIRUT) D HEADER - . I $D(MULT) D - . . F FLD=0:0 S FLD=$O(MULT(FLD)) Q:FLD'>0 D I NLIN<6 D PAGE Q:$D(DIRUT) D HEADER - . . . S DDVAL=^DD(FILE,FLD,0) - . . . S NAME=$P(DDVAL,U) - . . . S NODE=$P($P(DDVAL,U,4),";") - . . . S NOD1=$NA(@FILREC1@(NODE)) - . . . S NOD2=$NA(@FILREC2@(NODE)) - . . . S N1=0,N2=0 - . . . F I=0:0 S I=$O(@NOD1@(I)) Q:I'>0 S N1=N1+1 - . . . F I=0:0 S I=$O(@NOD2@(I)) Q:I'>0 S N2=N2+1 - . . . I N1'=0!(N2'=0) D - . . . . S N1=$S(N1>1:N1_" entries",N1>0:N1_" entry",1:"---") - . . . . S N2=$S(N2>1:N2_" entries",N2>0:N2_" entry",1:"---") - . . . . W !!,$E(NAME,1,25),?30,N1,?55,N2 - . . . . S NLIN=NLIN-2 - Q -PAGE ; - I IOST'["C-"!$D(ZTQUEUED) Q - W ! - I '$D(DIFFS)!'REVIEW S DIR(0)="E" D ^DIR K DIR - I $D(DIFFS)&REVIEW D - . S DIR(0)="LO^1:"_NDIFFS,DIR("A")="OVERWRITE data for selected fields" - . F I=1:1:NDIFFS W !,I," ",$P(^DD(FILE,DIFFS(I),0),U) - . W ! D ^DIR K DIR - . I X="",$D(DIRUT) K DIRUT - . S I="" F S I=$O(Y(I)) Q:I="" S Y=Y(I) K Y(I) D - . . F Q:Y="," Q:Y="" S X=$D(FLDS(DIFFS(+Y))) K:X=1 FLDS(DIFFS(+Y)) S:X=0 FLDS(DIFFS(+Y))="" S Y=$P(Y,",",2,999) - Q - ; -HEADER ; - N REC1MB,REC2MB - I '$G(FIRSTIME),$D(IOF) W @IOF - I $G(FIRSTIME),$G(MPIMB) D WARNING - S FIRSTIME=0 - K DIFFS S NDIFFS=0 - S NLIN=IOSL-4 - I $D(MPIMB) S NLIN=NLIN-4,MPIMB=0 - I '$D(PACKAGE) S PACKAGE="PRIMARY" - ;REM - modified next two lines to include IENs in review display - W !,?30,$S(PACKAGE="PRIMARY":"RECORD1 [#"_REC1_"]",PACKAGE="LABORATORY":"MERGE FROM [#"_NAMIEN1_"]",1:"MERGE FROM [#"_REC1_"]") - W ?55,$S(PACKAGE="PRIMARY":"RECORD2 [#"_REC2_"]",PACKAGE="LABORATORY":"MERGE TO [#"_NAMIEN2_"]",1:"MERGE TO [#"_REC2_"]") - ;I FILE=63 W !?38,"[#"_NAMIEN1_"]",?55,"[#"_NAMIEN2_"]" - W !,?30,$E(NAMREC1,1,20),?55,$E(NAMREC2,1,20) - S NLIN=NLIN-2 - I $E(NAMREC1,21,40)'=""!($E(NAMREC2,21,40)'="") D - . W !,?30,$E(NAMREC1,21,40),?55,$E(NAMREC2,21,40) - . S NLIN=NLIN-1 - ; - ; add CMOR scores to header - I $D(^DD(FILE,991.06)) D - . W !,?30,"CMOR SCORE = "_$S($P($G(^DPT(REC1,"MPI")),U,6):$P(^DPT(REC1,"MPI"),U,6),1:"NULL"),?55,"CMOR SCORE = "_$S($P($G(^DPT(REC2,"MPI")),U,6):$P(^DPT(REC2,"MPI"),U,6),1:"NULL") - . S NLIN=NLIN-1 - ; - ; add MULTIBLE BIRTH indicator to header - S (REC1MB,REC2MB)=0 - I $G(^DPT(REC1,"MPIMB"))="Y" S REC1MB=1 - I $G(^DPT(REC2,"MPIMB"))="Y" S REC2MB=1 - I REC1MB!REC2MB D - . W !,?30,$S(REC1MB:"**MULTIPLE BIRTH**",1:""),?55,$S(REC2MB:"**MULTIPLE BIRTH**",1:"") - . S NLIN=NLIN-1 - ; - W !,"----------------------------------------------------------------------------" - S NLIN=NLIN-1 - Q - ; -POINT(VAL,FILE) ; - N X,Y - I +VAL'=VAL Q "BAD POINTER VALUE IN FILE" - S Y=$G(^DIC(FILE,0,"GL")) Q:Y="" "" - S Y=Y_VAL_",0)" - S Y=$P($G(@Y),U) I Y'=""&($P(^DD(FILE,.01,0),U,2)["P") S Y=$$POINT(Y,+$P($P(^DD(FILE,.01,0),U,2),"P",2)) - S:Y="" Y="** Missing Entry in File "_FILE_"." ;REM - 9/6/96 When a pointer node is missing. - Q Y -TYPE(VAL,TYPE,DDNODE0,REC) ; - I TYPE["O",$D(^DD(FILE,FLD,2)) S Y=VAL,D0=REC X ^DD(FILE,FLD,2) S VAL=Y Q VAL - I TYPE["F",VAL'="" S VAL=""""_VAL_"""" Q VAL - I TYPE["P",VAL>0 S VAL=$$POINT(VAL,+$P(TYPE,"P",2)) Q VAL - I TYPE["D",VAL>0 D Q VAL - . S VAL=$TR($$FMTE^XLFDT(VAL,2),"@"," ") - I TYPE["S" D Q VAL - . N X S X=";"_$P(DDNODE0,U,3) - . S X=$P($P(X,(";"_VAL_":"),2),";") - . I X'="" S VAL=X - Q VAL - ; -WARNING ; - W !,?2,"*** WARNING!!! One or both of these records indicated MULTIPLE BIRTH. ***",!,?2,"Use caution to ensure that these records are truly duplicates and not",!,?2,"siblings before proceeding.",! - Q +XDRDSHOW ;SF-IRMFO.SEA/JLI - DISPLAY DATA IN FIELDS, GET OVERWRITES ;02/11/2004 08:56 + ;;7.3;TOOLKIT;**23,49,78**;Apr 25, 1995 + ;; +SHOW(FILE,REC1,REC2,FLDS,REVIEW) ; + N FILDIC,MULT,DDVAL,NAMIEN1,NAMIEN2,NAMREC1,NAMREC2,FIRSTIME,MPIMB + S FILDIC=$G(^DIC(FILE,0,"GL")) Q:FILDIC="" + S REVIEW=+$G(REVIEW) + S FILREC1=FILDIC_"REC1)" + S FILREC2=FILDIC_"REC2)" + S NAMREC1=$P($G(@FILREC1@(0)),U) I NAMREC1="" Q + S NAMREC2=$P($G(@FILREC2@(0)),U) I NAMREC2="" Q + I FILE=63 D + . S NAMIEN1=+$P(@FILREC1@(0),U,3),NAMIEN2=+$P(@FILREC2@(0),U,3) + . S NAMREC1=$P(^DPT(NAMIEN1,0),U),NAMREC2=$P(^DPT(NAMIEN2,0),U) + I $P(^DD(FILE,.01,0),U,2)["P" D + . N XFIL + . S XFIL=+$P($P($G(^DD(FILE,.01,0)),U,2),"P",2) Q:XFIL'>0 + . S XFIL=$G(^DIC(XFIL,0,"GL")) Q:XFIL="" + . S NAMREC1=$P(@(XFIL_NAMREC1_",0)"),U) + . S NAMREC2=$P(@(XFIL_NAMREC2_",0)"),U) + ; + ; recalc CMOR scores + I FILE=2,$D(^DD(FILE,991.06)) D + . N RGDFN S RGDFN=REC1 D CALC^RGVCCMR2 + . N RGDFN S RGDFN=REC2 D CALC^RGVCCMR2 + . Q + ; + ; check for multiple birth indicator in MPI + S FIRSTIME=1 + I FILE=2 D + . I $G(^DPT(REC1,"MPIMB"))="Y"!($G(^DPT(REC2,"MPIMB"))="Y") S MPIMB=1 + . E S MPIMB=0 + ; + D HEADER +LOOP ; + S FLD=0 + F FLD=0:0 S FLD=$O(^DD(FILE,FLD)) Q:FLD'>0 D I NLIN<6 D PAGE Q:$D(DIRUT) D HEADER + . I FILE=63,$P($G(^DD(FILE,FLD,0)),U)="NAME" Q ;scrn patient file data. From Lab + . I FILE'=2,$P($G(^DD(FILE,FLD,0)),U,2)["P2" Q ;From DINUM pointers. + . S DDVAL=$G(^DD(FILE,FLD,0)) + . S NODE=$P($P(DDVAL,U,4),";") + . S PIECE=$P($P(DDVAL,U,4),";",2) + . I PIECE=0 S MULT(FLD)="" + . I PIECE>0 D + . . S X1=$P($G(@FILREC1@(NODE)),U,PIECE),X1=$$TYPE(X1,$P(DDVAL,U,2),DDVAL,REC1) + . . S X2=$P($G(@FILREC2@(NODE)),U,PIECE),X2=$$TYPE(X2,$P(DDVAL,U,2),DDVAL,REC2) + . . I X1'=""!(X2'="") D + . . . S X0=" " + . . . S XN=$P(DDVAL,U) + . . . S XDRA=0 + . . . I X1'=""&(X2'=""),X1'=X2 S X0=$S($D(FLDS(FLD)):"||||",1:"****"),NDIFFS=NDIFFS+1,DIFFS(NDIFFS)=FLD,XDRA=1 I REVIEW S NLIN=NLIN-1 + . . . I 'REVIEW!XDRA D + . . . . W ! S NLIN=NLIN-1 + . . . . F Q:XN=""&(X1="")&(X2="") D + . . . . . W !,X0," ",$E(XN,1,20),?30,$E(X1,1,20),?55,$E(X2,1,20) + . . . . . S NLIN=NLIN-1 + . . . . . S X0=" ",XN=$E(XN,21,$L(XN)) + . . . . . S X1=$E(X1,21,$L(X1)) + . . . . . S X2=$E(X2,21,$L(X2)) +MULT I '$D(DIRUT) D + . I $G(NDIFFS)>0 D PAGE Q:$D(DIRUT) D HEADER + . I $D(MULT) D + . . F FLD=0:0 S FLD=$O(MULT(FLD)) Q:FLD'>0 D I NLIN<6 D PAGE Q:$D(DIRUT) D HEADER + . . . S DDVAL=^DD(FILE,FLD,0) + . . . S NAME=$P(DDVAL,U) + . . . S NODE=$P($P(DDVAL,U,4),";") + . . . S NOD1=$NA(@FILREC1@(NODE)) + . . . S NOD2=$NA(@FILREC2@(NODE)) + . . . S N1=0,N2=0 + . . . F I=0:0 S I=$O(@NOD1@(I)) Q:I'>0 S N1=N1+1 + . . . F I=0:0 S I=$O(@NOD2@(I)) Q:I'>0 S N2=N2+1 + . . . I N1'=0!(N2'=0) D + . . . . S N1=$S(N1>1:N1_" entries",N1>0:N1_" entry",1:"---") + . . . . S N2=$S(N2>1:N2_" entries",N2>0:N2_" entry",1:"---") + . . . . W !!,$E(NAME,1,25),?30,N1,?55,N2 + . . . . S NLIN=NLIN-2 + Q +PAGE ; + I IOST'["C-"!$D(ZTQUEUED) Q + W ! + I '$D(DIFFS)!'REVIEW S DIR(0)="E" D ^DIR K DIR + I $D(DIFFS)&REVIEW D + . S DIR(0)="LO^1:"_NDIFFS,DIR("A")="OVERWRITE data for selected fields" + . F I=1:1:NDIFFS W !,I," ",$P(^DD(FILE,DIFFS(I),0),U) + . W ! D ^DIR K DIR + . I X="",$D(DIRUT) K DIRUT + . S I="" F S I=$O(Y(I)) Q:I="" S Y=Y(I) K Y(I) D + . . F Q:Y="," Q:Y="" S X=$D(FLDS(DIFFS(+Y))) K:X=1 FLDS(DIFFS(+Y)) S:X=0 FLDS(DIFFS(+Y))="" S Y=$P(Y,",",2,999) + Q + ; +HEADER ; + N REC1MB,REC2MB + I '$G(FIRSTIME),$D(IOF) W @IOF + I $G(FIRSTIME),$G(MPIMB) D WARNING + S FIRSTIME=0 + K DIFFS S NDIFFS=0 + S NLIN=IOSL-4 + I $D(MPIMB) S NLIN=NLIN-4,MPIMB=0 + I '$D(PACKAGE) S PACKAGE="PRIMARY" + ;REM - modified next two lines to include IENs in review display + W !,?30,$S(PACKAGE="PRIMARY":"RECORD1 [#"_REC1_"]",PACKAGE="LABORATORY":"MERGE FROM [#"_NAMIEN1_"]",1:"MERGE FROM [#"_REC1_"]") + W ?55,$S(PACKAGE="PRIMARY":"RECORD2 [#"_REC2_"]",PACKAGE="LABORATORY":"MERGE TO [#"_NAMIEN2_"]",1:"MERGE TO [#"_REC2_"]") + ;I FILE=63 W !?38,"[#"_NAMIEN1_"]",?55,"[#"_NAMIEN2_"]" + W !,?30,$E(NAMREC1,1,20),?55,$E(NAMREC2,1,20) + S NLIN=NLIN-2 + I $E(NAMREC1,21,40)'=""!($E(NAMREC2,21,40)'="") D + . W !,?30,$E(NAMREC1,21,40),?55,$E(NAMREC2,21,40) + . S NLIN=NLIN-1 + ; + ; add CMOR scores to header + I $D(^DD(FILE,991.06)) D + . W !,?30,"CMOR SCORE = "_$S($P($G(^DPT(REC1,"MPI")),U,6):$P(^DPT(REC1,"MPI"),U,6),1:"NULL"),?55,"CMOR SCORE = "_$S($P($G(^DPT(REC2,"MPI")),U,6):$P(^DPT(REC2,"MPI"),U,6),1:"NULL") + . S NLIN=NLIN-1 + ; + ; add MULTIBLE BIRTH indicator to header + S (REC1MB,REC2MB)=0 + I $G(^DPT(REC1,"MPIMB"))="Y" S REC1MB=1 + I $G(^DPT(REC2,"MPIMB"))="Y" S REC2MB=1 + I REC1MB!REC2MB D + . W !,?30,$S(REC1MB:"**MULTIPLE BIRTH**",1:""),?55,$S(REC2MB:"**MULTIPLE BIRTH**",1:"") + . S NLIN=NLIN-1 + ; + W !,"----------------------------------------------------------------------------" + S NLIN=NLIN-1 + Q + ; +POINT(VAL,FILE) ; + N X,Y + I +VAL'=VAL Q "BAD POINTER VALUE IN FILE" + S Y=$G(^DIC(FILE,0,"GL")) Q:Y="" "" + S Y=Y_VAL_",0)" + S Y=$P($G(@Y),U) I Y'=""&($P(^DD(FILE,.01,0),U,2)["P") S Y=$$POINT(Y,+$P($P(^DD(FILE,.01,0),U,2),"P",2)) + S:Y="" Y="** Missing Entry in File "_FILE_"." ;REM - 9/6/96 When a pointer node is missing. + Q Y +TYPE(VAL,TYPE,DDNODE0,REC) ; + I TYPE["O",$D(^DD(FILE,FLD,2)) S Y=VAL,D0=REC X ^DD(FILE,FLD,2) S VAL=Y Q VAL + I TYPE["F",VAL'="" S VAL=""""_VAL_"""" Q VAL + I TYPE["P",VAL>0 S VAL=$$POINT(VAL,+$P(TYPE,"P",2)) Q VAL + I TYPE["D",VAL>0 D Q VAL + . S VAL=$TR($$FMTE^XLFDT(VAL,2),"@"," ") + I TYPE["S" D Q VAL + . N X S X=";"_$P(DDNODE0,U,3) + . S X=$P($P(X,(";"_VAL_":"),2),";") + . I X'="" S VAL=X + Q VAL + ; +WARNING ; + W !,?2,"*** WARNING!!! One or both of these records indicated MULTIPLE BIRTH. ***",!,?2,"Use caution to ensure that these records are truly duplicates and not",!,?2,"siblings before proceeding.",! + Q diff --git a/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XTPMKPCF.m b/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XTPMKPCF.m index 0ce78d1b..fb44e9c6 100644 --- a/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XTPMKPCF.m +++ b/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XTPMKPCF.m @@ -1,79 +1,70 @@ -XTPMKPCF ;OAK/BP - COMPUTED FIELDS AND OTHER ODDITIES FOR PATCH MONITOR; - ;;7.3;TOOLKIT;**98,106**; Apr 25, 1995;Build 1 - ; - ; computed fields -INSTALL ; returns the patch installation information from the INSTALL file. - ; note: Fileman variables are NOT killed because they are used in output. - ; read the index backwards and select the last patch reference because TEST - ; patches may be involved. If a test patch, null the pointer, like nothing is there. - S X=$P($G(^XPD(9.9,D0,0)),U,8) Q:X="" - S X=$O(^XPD(9.7,"B",X,9999999999),-1) I $G(^XPD(9.7,+X,2))["TEST v" S X="" Q - S X=$P($G(^XPD(9.7,+X,1)),U,3) - I X="" Q - S Y=X D DD^%DT S X=$P(Y,"@") K Y - Q - ; -WHO ; returns who installed the patch - S X=$P($G(^XPD(9.9,D0,0)),U,8) Q:X="" - S X=$O(^XPD(9.7,"B",X,9999999999),-1) I $G(^XPD(9.7,+X,2))["TEST v" S X="" - S X=$P($G(^XPD(9.7,+X,0)),U,11) - S X=$P($G(^VA(200,+X,0)),U) - Q - ; - ; other utility items - ; patch inquiry -INQUIRE S IOP="HOME" D ^%ZIS K IOP S $P(DASH,"-",75)="" - S HD="Patch Inquiry for "_^DD("SITE") - W @IOF,!,HD,!!! K DIC,X,Y - S DIC("A")="Enter PATCH NAME: ",DIC="^XPD(9.9,",DIC(0)="AEQM" - D ^DIC G:Y<0 EXITI S DA=+Y - ; -LOOKUP W @IOF,! S DR="0:9",DIQ(0)="C" - S DA=+Y W @IOF,HD,!!!!!,DASH D EN1^DIQ W DASH - ; -CONT W !!!,"Press RETURN to continue or '^' to exit " R ANS:DTIME G:'$T EXITI - G:ANS[U EXITI - G INQUIRE - ; -EXITI I IOST?1"C-".E W @IOF,! - ; clean up FM vars left - K %,%X,A,ANS,D0,D1,D2,DA,DIC,DIK,DL,DX,HD - K I,POP,S,DASH,DR,X,Y,DK,DIQ,IOP - Q - ; -PKGLOOK ; used for free-text lookup in monitoring of namespaces - N DIC,Y,D0,DO,DA,DICR - S DIC(0)="EQM",DIC="^DIC(9.4," D ^DIC - I Y<0 K X Q - S X=$P($G(^DIC(9.4,+Y,0)),U,2) ; get package prefix - Q -CMPDTCG ; Compliance Date change - K XTBCMDCG - S XTBMLN1=$G(^XMB(3.9,XMZ,0)) I XTBMLN1["COMPLIANCE DATE CHANGE" DO - .F XTBX=0:0 S XTBX=$O(^XMB(3.9,XMZ,2,XTBX)) Q:XTBX=""!(+XTBX=0) S XTBY=$G(^XMB(3.9,XMZ,2,XTBX,0)) DO - ..I XTBY["PATCH " S XTBDESG=$P($P(XTBY,"PATCH ",2)," ",1) Q - ..I $D(XTBDESG),XTBY["The Compliance Date for patch"&(XTBY["has been changed to") DO - ...S XTBTCMPD=$P(XTBY,"has been changed to ",2) - ...S DIC(0)="M",(DIC,DIE)="^XPD(9.9,",X=XTBDESG D ^DIC I Y<0 S XTBX=9999999 Q - ...S DA=+Y,DR="8///"_XTBTCMPD D ^DIE - ...S XTBCMDCG=1 - .K DR,DIC,DIE,DA,X,Y,XTBDESG,XTBTCMPD - Q - ; -EXITA D ^%ZISC - K ^TMP($J) - K XTBDESG,XTBI,XTBINST,XTBINSTX,XTBPKG,XTBPRIO,XTBSEQ,XTBSUB,%ZIS,XTBANS,XTBCOMPD,XTBPURGI - K XTBVER,XTBX,XTBY,XTBZ,DIC,DIE,DO,DD,X,XMB,XMER,XMREC,XMRG,XX,XTBXX,XTBHDR,PG,POP,XTBMLN1 - K XTBDA,XTBLIMIT,XTBLN,XTBPTNM,XTBRECPT,XTBRUNDT,XTBSUBJ,ZTDESC,XTBCNT - K XTBX,XTBDTA,XTBDTA,X1,X2,XMDUZ,XMSUB,XMTEXT,XMY,XMZ,Y,XTBRCPDT,XTBMG,XTBMGN - K XTBINSDA,XTBISTAT,NOFILE,XTBPTYPE,XTBPLVER,XTBPKGPT,XTBPCTVR,YY1 - K XTBX1,XTBZ,NIGHT,XTBCMPDT,ZTSK,ZTIO,ZTRTN,ZTSAVE - Q - ; -INSDATE ;Print out Installed Date - N X,X1 - S X=$P($G(^XPD(9.9,D0,0)),U,8) Q:X="" - S X1=$P($G(^XPD(9.9,D0,0)),U,11) I X1>0 W $$FMTE^XLFDT(X1,"2Z") Q - S X=$O(^XPD(9.7,"B",X,9999999999),-1) I $G(^XPD(9.7,+X,2))["TEST v" S X="" Q - S X=$P($G(^XPD(9.7,+X,1)),U,3) W $$FMTE^XLFDT($P(X,"."),"2Z") - Q +XTPMKPCF ;OAK/BP - COMPUTED FIELDS AND OTHER ODDITIES FOR PATCH MONITOR; [8/9/05 9:23am] + ;;7.3;TOOLKIT;**98**; Apr 25, 1995 + ; + ; computed fields +INSTALL ; returns the patch installation information from the INSTALL file. + ; note: Fileman variables are NOT killed because they are used in output. + ; read the index backwards and select the last patch reference because TEST + ; patches may be involved. If a test patch, null the pointer, like nothing is there. + S X=$P($G(^XPD(9.9,D0,0)),U,8) Q:X="" + S X=$O(^XPD(9.7,"B",X,9999999999),-1) I $G(^XPD(9.7,+X,2))["TEST v" S X="" + S X=$P($G(^XPD(9.7,+X,1)),U,3) + S X=$E(X,1,7) + Q + ; +WHO ; returns who installed the patch + S X=$P($G(^XPD(9.9,D0,0)),U,8) Q:X="" + S X=$O(^XPD(9.7,"B",X,9999999999),-1) I $G(^XPD(9.7,+X,2))["TEST v" S X="" + S X=$P($G(^XPD(9.7,+X,0)),U,11) + S X=$P($G(^VA(200,+X,0)),U) + Q + ; + ; other utility items + ; patch inquiry +INQUIRE S IOP="HOME" D ^%ZIS K IOP S $P(DASH,"-",75)="" + S HD="Patch Inquiry for "_^DD("SITE") + W @IOF,!,HD,!!! K DIC,X,Y + S DIC("A")="Enter PATCH NAME: ",DIC="^XPD(9.9,",DIC(0)="AEQM" + D ^DIC G:Y<0 EXITI S DA=+Y + ; +LOOKUP W @IOF,! S DR="0:9",DIQ(0)="C" + S DA=+Y W @IOF,HD,!!!!!,DASH D EN1^DIQ W DASH + ; +CONT W !!!,"Press RETURN to continue or '^' to exit " R ANS:DTIME G:'$T EXITI + G:ANS[U EXITI + G INQUIRE + ; +EXITI I IOST?1"C-".E W @IOF,! + ; clean up FM vars left + K %,%X,A,ANS,D0,D1,D2,DA,DIC,DIK,DL,DX,HD + K I,POP,S,DASH,DR,X,Y,DK,DIQ,IOP + Q + ; +PKGLOOK ; used for free-text lookup in monitoring of namespaces + N DIC,Y,D0,DO,DA,DICR + S DIC(0)="EQM",DIC="^DIC(9.4," D ^DIC + I Y<0 K X Q + S X=$P($G(^DIC(9.4,+Y,0)),U,2) ; get package prefix + Q +CMPDTCG ; Compliance Date change + K XTBCMDCG + S XTBMLN1=$G(^XMB(3.9,XMZ,0)) I XTBMLN1["COMPLIANCE DATE CHANGE" DO + .F XTBX=0:0 S XTBX=$O(^XMB(3.9,XMZ,2,XTBX)) Q:XTBX=""!(+XTBX=0) S XTBY=$G(^XMB(3.9,XMZ,2,XTBX,0)) DO + ..I XTBY["PATCH " S XTBDESG=$P($P(XTBY,"PATCH ",2)," ",1) Q + ..I $D(XTBDESG),XTBY["The Compliance Date for patch"&(XTBY["has been changed to") DO + ...S XTBTCMPD=$P(XTBY,"has been changed to ",2) + ...S DIC(0)="M",(DIC,DIE)="^XPD(9.9,",X=XTBDESG D ^DIC I Y<0 S XTBX=9999999 Q + ...S DA=+Y,DR="8///"_XTBTCMPD D ^DIE + ...S XTBCMDCG=1 + .K DR,DIC,DIE,DA,X,Y,XTBDESG,XTBTCMPD + Q + ; +EXITA D ^%ZISC + K ^TMP($J) + K XTBDESG,XTBI,XTBINST,XTBINSTX,XTBPKG,XTBPRIO,XTBSEQ,XTBSUB,%ZIS,XTBANS,XTBCOMPD,XTBPURGI + K XTBVER,XTBX,XTBY,XTBZ,DIC,DIE,DO,DD,X,XMB,XMER,XMREC,XMRG,XX,XTBXX,XTBHDR,PG,POP,XTBMLN1 + K XTBDA,XTBLIMIT,XTBLN,XTBPTNM,XTBRECPT,XTBRUNDT,XTBSUBJ,ZTDESC,XTBCNT + K XTBX,XTBDTA,XTBDTA,X1,X2,XMDUZ,XMSUB,XMTEXT,XMY,XMZ,Y,XTBRCPDT,XTBMG,XTBMGN + K XTBINSDA,XTBISTAT,NOFILE,XTBPTYPE,XTBPLVER,XTBPKGPT,XTBPCTVR,YY1 + K XTBX1,XTBZ,NIGHT,XTBCMPDT,ZTSK,ZTIO,ZTRTN,ZTSAVE + Q diff --git a/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XTPMSTA2.m b/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XTPMSTA2.m index 54dd08f3..439896ca 100644 --- a/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XTPMSTA2.m +++ b/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XTPMSTA2.m @@ -1,79 +1,79 @@ -XTPMSTA2 ;OAK/BP - PRINT PATCH STATISTICS BY COMPLIANCE DATE; - ;;7.3;TOOLKIT;**98,100,106**; Apr 25, 1995;Build 1 - ; - S IOP="HOME" D ^%ZIS K IOP -EN W @IOF,"Patch Monitor Statistics By Compliance Date",!!! - ; -DATE W ! S %DT="AEP" - S %DT("A")="Enter BEGINNING Compliance date: " D ^%DT G:Y<0 EXIT S XTBBDT=Y X ^DD("DD") S XTBBDT1=Y - S %DT="AE",%DT("A")=" and ENDING Compliance date: " D ^%DT G:Y<0 EXIT S XTBEDT=Y X ^DD("DD") S XTBEDT1=Y - I XTBEDTXTBEDT) DO - .F XTBDA=0:0 S XTBDA=$O(^XPD(9.9,"D",XTBCPLDT,XTBDA)) Q:XTBDA="" DO - ..S XTBDTA=$G(^XPD(9.9,XTBDA,0)) Q:XTBDTA="" - ..S XTBPTNAM=$P(XTBDTA,U,1),XTBNMSP=$P($P(XTBDTA,U,4)," - ",1) Q:XTBNMSP="" ;parent package missing in file - ..S XTBRELDT=$P(XTBDTA,U,2),XTBPRIOR=$P(XTBDTA,U,3) - ..S ^TMP($J,XTBCPLDT,XTBPTNAM,XTBDA)=XTBRELDT_U_XTBPRIOR -PRINT ; - S Y=DT X ^DD("DD") S XTBCURDT=Y - K XTBLINE S $P(XTBLINE,"-",(IOM-2))="-" - S PG=0 D HDR ; first header - S XTBPTNAM="",(XTBTPTCH,XTBTLATE)=0 - F XTBCPLDT=0:0 S XTBCPLDT=$O(^TMP($J,XTBCPLDT)) Q:XTBCPLDT="" F S XTBPTNAM=$O(^TMP($J,XTBCPLDT,XTBPTNAM)) Q:XTBPTNAM="" DO Q:$D(XTBOUT) - .F XTBDA=0:0 S XTBDA=$O(^TMP($J,XTBCPLDT,XTBPTNAM,XTBDA)) Q:XTBDA="" DO Q:$D(XTBOUT) - ..S XTBTPTCH=XTBTPTCH+1 - ..S XTBDTA=^TMP($J,XTBCPLDT,XTBPTNAM,XTBDA) - ..S XTBRELDT=$P(XTBDTA,U),XTBPRIOR=$P(XTBDTA,U,2) - ..S XTBRCVDT=$P($G(^XPD(9.9,XTBDA,0)),U,2) - ..S XTBPTYPE=$P($G(^XPD(9.9,XTBDA,0)),U,10) - ..I +XTBPTYPE=0 S D0=XTBDA D ^XTPMKPCF S XTBINSDT=X K D0 - ..I +XTBPTYPE=1 S XTBINSDT=$P($G(^XPD(9.9,XTBDA,0)),U,11) - ..I XTBINSDT]"" S X1=XTBINSDT,X2=XTBCPLDT D ^%DTC S XTBDAYLT=X - ..I XTBINSDT="" S X1=DT,X2=XTBCPLDT D ^%DTC S XTBDAYLT=X - ..S Y=XTBINSDT X ^DD("DD") I Y'="" S XTBINSDT=$P(Y,",",1)_","_$E($P(Y,",",2),2,5) ;set date format "MON DD,YYYY" - ..S Y=XTBCPLDT X ^DD("DD") S XTBCPLDX=Y - ..S Y=XTBRELDT X ^DD("DD") S XTBRELDT=Y - ..S XTBPRIOR=$S(XTBPRIOR="m":"Mandatory",XTBPRIOR="e":"Emergency",1:"Unknown") - ..I XTBVIEW=1 W XTBCPLDX,?14,XTBPTNAM,?27,XTBRELDT,?41,XTBINSDT,?55,XTBPRIOR - ..I XTBVIEW=1,XTBDAYLT>0 W ?67,$J(XTBDAYLT,3,0)_$S(XTBDAYLT>1:" days",1:" day") - ..I XTBDAYLT>0 S XTBTLATE=XTBTLATE+1 - ..I XTBVIEW=1 W ! I $Y>(IOSL-6),IOST?1"C-".E D PAUSE Q:$D(XTBOUT) - ..I XTBVIEW=1 I $Y>(IOSL-6) D HDR - G:$D(XTBOUT) EXIT - I $Y>(IOSL-6),IOST?1"C-".E D HDR - W !!?6,"Totals patches received for date range: ",XTBTPTCH,! - W "Total patches installed past compliance date: ",XTBTLATE,!! - S XTBDIVOK=0 I XTBTPTCH>0 S XTBDIVOK=1 - W ?25,"Delinquent patch % : ",$S(XTBDIVOK=1:$J((XTBTLATE/XTBTPTCH*100),6,2),1:100)_" %",! - W ?25," Compliance % : ",$S(XTBDIVOK=1:$J(100-(XTBTLATE/XTBTPTCH*100),6,2),1:100)," %",! - I IOST?1"C-".E K XTBANS W !!,"Press ENTER to end " R XTBANS:DTIME - ; -EXIT I IOST?1"C-".E W @IOF,! - D ^%ZISC - K %,%DT,%ZIS,XTBNMSP,XTBANS,XTBBDT,XTBBDT1,XTBCPLDT,XTBCPLDX,XTBDA,XTBEDT,XTBEDT1,XTBDAYLT - K XTBINSDT,XTBLINE,XTBNMSP,XTBOLDNM,XTBNMSP,XTBPTNAM,XTBPTYPE,XTBDTA,XTBGPDA - K XTBRCVDT,XTBTLATE,XTBTPTCH,D0,DIC,PG,POP,X,X1,X2,Y,ZTDESC,ZTIO,ZTRTN,ZTSAVE,%T,%Y - K ^TMP($J),XTBOUT,XTBPGF,XTBOLGRP,ZTSK,XTBRELDT,XTBPRIOR,XTBCURDT,XTBDIVOK,XTBVIEW - Q - ; -HDR S PG=PG+1 I IOST?1"P-".E,PG>1 W @IOF - I IOST?1"C-".E W @IOF - W XTBCURDT S X="Patch Statistical Report for "_^DD("SITE") - W ?(IOM-$L(X)\2),X,?(IOM-12),"Page: ",PG,!,?31,"By Compliance Date",! - S X="Date range: "_XTBBDT1_" to "_XTBEDT1 W ?(IOM-$L(X)\2),X,! - W !,"Compliance",?14,"Patch",?27,"Release",?41,"Install",?67,"# Days",! - W "Date",?14,"Number",?27,"Date",?41,"Date",?55,"Priority",?67,"Delinquent",!,XTBLINE,! - Q - ; -PAUSE Q:IOST'?1"C-".E - K XTBANS,XTBOUT W !!,"Press ENTER to continue or '^' to end " R XTBANS:DTIME - I XTBANS[U!('$T) S (XTBNMSP,XTBPTNAM,XTBCPLDT,XTBDA)="99999999",XTBOUT=1 - Q +XTPMSTA2 ;OAK/BP - PRINT PATCH STATISTICS BY COMPLIANCE DATE; [1/4/06 9:33am] + ;;7.3;TOOLKIT;**98,100**; Apr 25, 1995;Build 4 + ; + S IOP="HOME" D ^%ZIS K IOP +EN W @IOF,"Patch Monitor Statistics By Compliance Date",!!! + ; +DATE W ! S %DT="AEP" + S %DT("A")="Enter BEGINNING Compliance date: " D ^%DT G:Y<0 EXIT S XTBBDT=Y X ^DD("DD") S XTBBDT1=Y + S %DT="AE",%DT("A")=" and ENDING Compliance date: " D ^%DT G:Y<0 EXIT S XTBEDT=Y X ^DD("DD") S XTBEDT1=Y + I XTBEDTXTBEDT) DO + .F XTBDA=0:0 S XTBDA=$O(^XPD(9.9,"D",XTBCPLDT,XTBDA)) Q:XTBDA="" DO + ..S XTBDTA=$G(^XPD(9.9,XTBDA,0)) Q:XTBDTA="" + ..S XTBPTNAM=$P(XTBDTA,U,1),XTBNMSP=$P($P(XTBDTA,U,4)," - ",1) Q:XTBNMSP="" ;parent package missing in file + ..S XTBRELDT=$P(XTBDTA,U,2),XTBPRIOR=$P(XTBDTA,U,3) + ..S ^TMP($J,XTBCPLDT,XTBPTNAM,XTBDA)=XTBRELDT_U_XTBPRIOR +PRINT ; + S Y=DT X ^DD("DD") S XTBCURDT=Y + K XTBLINE S $P(XTBLINE,"-",(IOM-2))="-" + S PG=0 D HDR ; first header + S XTBPTNAM="",(XTBTPTCH,XTBTLATE)=0 + F XTBCPLDT=0:0 S XTBCPLDT=$O(^TMP($J,XTBCPLDT)) Q:XTBCPLDT="" F S XTBPTNAM=$O(^TMP($J,XTBCPLDT,XTBPTNAM)) Q:XTBPTNAM="" DO Q:$D(XTBOUT) + .F XTBDA=0:0 S XTBDA=$O(^TMP($J,XTBCPLDT,XTBPTNAM,XTBDA)) Q:XTBDA="" DO Q:$D(XTBOUT) + ..S XTBTPTCH=XTBTPTCH+1 + ..S XTBDTA=^TMP($J,XTBCPLDT,XTBPTNAM,XTBDA) + ..S XTBRELDT=$P(XTBDTA,U),XTBPRIOR=$P(XTBDTA,U,2) + ..S XTBRCVDT=$P($G(^XPD(9.9,XTBDA,0)),U,2) + ..S XTBPTYPE=$P($G(^XPD(9.9,XTBDA,0)),U,10) + ..I +XTBPTYPE=0 S D0=XTBDA D ^XTPMKPCF S XTBINSDT=X K D0 + ..I +XTBPTYPE=1 S XTBINSDT=$P($G(^XPD(9.9,XTBDA,0)),U,11) + ..I XTBINSDT]"" S X1=XTBINSDT,X2=XTBCPLDT D ^%DTC S XTBDAYLT=X + ..I XTBINSDT="" S X1=DT,X2=XTBCPLDT D ^%DTC S XTBDAYLT=X + ..S Y=XTBINSDT X ^DD("DD") S XTBINSDT=Y + ..S Y=XTBCPLDT X ^DD("DD") S XTBCPLDX=Y + ..S Y=XTBRELDT X ^DD("DD") S XTBRELDT=Y + ..S XTBPRIOR=$S(XTBPRIOR="m":"Mandatory",XTBPRIOR="e":"Emergency",1:"Unknown") + ..I XTBVIEW=1 W XTBCPLDX,?14,XTBPTNAM,?27,XTBRELDT,?41,XTBINSDT,?55,XTBPRIOR + ..I XTBVIEW=1,XTBDAYLT>0 W ?67,$J(XTBDAYLT,3,0)_$S(XTBDAYLT>1:" days",1:" day") + ..I XTBDAYLT>0 S XTBTLATE=XTBTLATE+1 + ..I XTBVIEW=1 W ! I $Y>(IOSL-6),IOST?1"C-".E D PAUSE Q:$D(XTBOUT) + ..I XTBVIEW=1 I $Y>(IOSL-6) D HDR + G:$D(XTBOUT) EXIT + I $Y>(IOSL-6),IOST?1"C-".E D HDR + W !!?6,"Totals patches received for date range: ",XTBTPTCH,! + W "Total patches installed past compliance date: ",XTBTLATE,!! + S XTBDIVOK=0 I XTBTPTCH>0 S XTBDIVOK=1 + W ?25,"Delinquent patch % : ",$S(XTBDIVOK=1:$J((XTBTLATE/XTBTPTCH*100),6,2),1:100)_" %",! + W ?25," Compliance % : ",$S(XTBDIVOK=1:$J(100-(XTBTLATE/XTBTPTCH*100),6,2),1:100)," %",! + I IOST?1"C-".E K XTBANS W !!,"Press ENTER to end " R XTBANS:DTIME + ; +EXIT I IOST?1"C-".E W @IOF,! + D ^%ZISC + K %,%DT,%ZIS,XTBNMSP,XTBANS,XTBBDT,XTBBDT1,XTBCPLDT,XTBCPLDX,XTBDA,XTBEDT,XTBEDT1,XTBDAYLT + K XTBINSDT,XTBLINE,XTBNMSP,XTBOLDNM,XTBNMSP,XTBPTNAM,XTBPTYPE,XTBDTA,XTBGPDA + K XTBRCVDT,XTBTLATE,XTBTPTCH,D0,DIC,PG,POP,X,X1,X2,Y,ZTDESC,ZTIO,ZTRTN,ZTSAVE,%T,%Y + K ^TMP($J),XTBOUT,XTBPGF,XTBOLGRP,ZTSK,XTBRELDT,XTBPRIOR,XTBCURDT,XTBDIVOK,XTBVIEW + Q + ; +HDR S PG=PG+1 I IOST?1"P-".E,PG>1 W @IOF + I IOST?1"C-".E W @IOF + W XTBCURDT S X="Patch Statistical Report for "_^DD("SITE") + W ?(IOM-$L(X)\2),X,?(IOM-12),"Page: ",PG,!,?31,"By Compliance Date",! + S X="Date range: "_XTBBDT1_" to "_XTBEDT1 W ?(IOM-$L(X)\2),X,! + W !,"Compliance",?14,"Patch",?27,"Release",?41,"Install",?67,"# Days",! + W "Date",?14,"Number",?27,"Date",?41,"Date",?55,"Priority",?67,"Delinquent",!,XTBLINE,! + Q + ; +PAUSE Q:IOST'?1"C-".E + K XTBANS,XTBOUT W !!,"Press ENTER to continue or '^' to end " R XTBANS:DTIME + I XTBANS[U!('$T) S (XTBNMSP,XTBPTNAM,XTBCPLDT,XTBDA)="99999999",XTBOUT=1 + Q diff --git a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIA.m b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIA.m index dc7090b4..dd8c818d 100644 --- a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIA.m +++ b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIA.m @@ -1,84 +1,70 @@ -DIA ;SFISC/GFT-SELECT FIELDS TO EDIT ;4JUNE2008 - ;;22.0;VA FileMan;**159**;Mar 30, 1999;Build 8 - ;Per VHA Directive 2004-038, this routine should not be modified. - D DICS -1 D F W !?F*3,"EDIT WHICH "_X I $S(DB:DIAT="",1:1) R ": ALL// ",X:DTIME S:'$T X=U,DTOUT=1 G ALL^DIA1:X=""!(X="ALL"),TEMP^DIA1:X?1"[".E&'F,L -ED G NDB:DIAT="" -GDB S Y=$P(DIAT,";",DB) I "Q"[Y G NDB:Y="" D DB G GDB - I Y?.NP,$P(Y,":",2),Y'["/" S Y=+Y_"-"_$P(Y,":",2) - S %=$G(DI(DB,DIARTLVL-1,DI,DIAO)) I %]"" S Y=% - E I Y?1"^"1N1"."1.2N S DB=DB+1 G GDB ;WPB-0804-30857 - W ": "_Y D RW - I X="" S X=Y I X="ALL" G ALL^DIA1 -L S DSC=X?1"^".E I DSC S X=$E(X,2,999) I U[X K DR Q - I $A(X)=64 G X:X'?1P.N,P:$L(X)>1,X:'DB S DB=DB+1 G 2 - K DIC,DIAB D DICS S DV="",J=$P(X,"-",2) I +J=J,$P(X,"-",1)=+X,J>X S D(F)=J K DA D RANGE^DIA1 K D S Y=DA G X:Y="" D DB G 2 -DIC ; - S DIC(0)="EZI",DIC="^DD(DI,",Y=-1 G X^DIA3:X[";" S DIC("W")="S %=$P(^(0),U,2) I % W $S($P(^DD(+%,.01,0),U,2)[""W"":"" (word-processing)"",1:"" (multiple)"")" D ^DIC Q:$D(DTOUT) - I Y>0 D SET S Y=$P(Y(0),U,2) G 2:'Y S L=L+1,(DI,J(L))=+Y,I(L)=""""_$P($P(Y(0),U,4),";")_"""" G DOWN - I $E(X)="]" S DRS=9,X=$E(X,2,999) G DIC:X]"",2 - G DIA^DIQQQ:X?."?" I $D(^DD(DI,"GR")) K Y S Y=-1 D:$L(X)<31 - . N I,DIGRP,DTOUT,DUOUT,DIRUT,DIROUT,DIYN S DIGRP=X,DIYN=0 - . D:$D(^DD(DI,"GR",DIGRP)) Q:DIYN F S DIGRP=$O(^DD(DI,"GR",DIGRP)) Q:$E(DIGRP,1,$L(X))'=X D Q:DIYN - .. N X,I - .. F I=0:0 S I=$O(^DD(DI,"GR",DIGRP,I)) Q:'I I $G(^DD(DI,I,0))]"" S I(I)=I_U_$P(^(0),U) - .. Q:'$O(I(0)) - .. W !!,"Fields in Group: ",DIGRP F I=0:0 S I=$O(I(I)) Q:'I W !,?2,I,?10,$P(I(I),U,2) - .. D Q:DIYN'=1 - ... N X,Y S DIR(0)="Y",DIR("A")="Edit this GROUP of fields",DIR("B")="YES" D ^DIR S DIYN=$S(Y=1:1,$G(DIRUT):2,1:0) Q - .. M Y=I S Y=0 Q - . Q - K DIYN G X^DIA3 - ; -F S X=$P(^DD(DI,0),U) I F,X="FIELD" S X=$O(^(0,"NM",0))_" "_X - Q - ; -X ; - W $C(7),"??" D DICS -2 ; - G 1:'$D(DR(F+1,DI)) D F W !?F*3,"THEN EDIT "_X G ED:DB -R R ": ",X:DTIME E W $C(7) S X=U,DTOUT=1 - I X]"" G L -UP ; - G ^DIA1:'F K I(L),J(L) S L=L-1 I '$D(J(L)) F L=L-99:1 Q:'$D(J(L+1)) - I DB S DB=DB(F),DIARTLVL=DIARTLVL(F),DIAO=DIAO(F),DIAT=$S(DIAO<0:"",DIAO:$G(^DIE(DIAA,"DR",DIARTLVL,J(L),DIAO)),$D(^DIE(DIAA,"DR",DIARTLVL,J(L))):^(J(L)),1:"") - S DIARLVL=DIARLVL(F),DIAP=DIAP(F),DI=J(L),F=F-1 G 2 - ; -NDB I DB,DIAO'<0 S DIAO=DIAO+1 I $D(^DIE(DIAA,"DR",DIARLVL,DI,DIAO)) S DIAT=^(DIAO),DB=1 G GDB - S DIAO=-1 G R - ; - ; - ; -EN ;Entry point from DIB routine - N DIARTLVL,DIARLVL,DIAL,DIESP,DRR D OS^DII:'$D(DISYS) -FILETOP D DICS ;Enter from DIA3 when there is a file jump -DOWN S F=F+1,DIAL(F)=+$G(DIAL),DIARLVL(F)=+$G(DIARLVL) F %=F+1:.01 I '$D(DR(%,DI)) Q ;Find 2.01 if we have already gone down to DR(2,DI) -- WPB-0804-30857 - S:%["." @DRR=@DRR_U_%_";",DIAP=DIAP+1 S DIARLVL=% - S DIAP(F)=DIAP,DIAP=0 - I DB S DIARTLVL(F)=DIARTLVL D S DB(F)=DB,DB=1,DIAO(F)=DIAO,DIAO=0,DIAT=$G(^DIE(DIAA,"DR",DIARTLVL,DI)),DIARTLVL(DIARTLVL,DI)="" - .S %=$P(DIAT,";",DB) I %?1"^"1.NP S DIARTLVL=$P(%,U,2),DB=DB+1 Q - .F DIARTLVL=F+1:.01 I '$D(DIARTLVL(DIARTLVL,DI)) Q - G 1:$P(^DD(DI,.01,0),U,2)'["W",1:L#100=0,UP - ; -DICS ; - S DIC("S")="I Y>.001,$P(^(0),U,2)'[""C"""_$S(DUZ(0)="@":"",1:",$P(^(0),U,2)'[""K""")_" Q:'$D(^(9)) I ^(9)'=U"_$S(DUZ(0)'="@":" F DW=1:1:$L(^(9)) I DUZ(0)[$E(^(9),DW) Q",1:"") Q - ; -P ; - S DRS=99,Y=X D DB G 2 - ; -SET S Y=+Y_DV -DB ; - I DB,'DSC S DB=DB+1 -D ;takes 'Y' and puts it into 'DR' array -- Also called from DIA3 - N %,B - S (DRR,B)=$NA(DR(DIARLVL,DI)),%=$O(@DRR@(""),-1) - I % S DRR=$NA(@DRR@(%)) - I '$D(@DRR) S @DRR="",DIAP=0 - E I $L(Y)+$L(@DRR)>230 S DRR=$NA(@B@(%+1)),DIAP=DIAP\1000+1*1000,@DRR="" - S @DRR=@DRR_Y_";",DRS=$G(DRS)+1 - S DIAP=DIAP+1 -DIAB I $D(DIAB) S ^UTILITY($J,DIAP#1000,DIARLVL-1,DI,DIAP\1000)=DIAB K DIAB - Q - ; -RW I $L(Y)>19 D RW^DIR2 Q - W "// " R X:DTIME I '$T S X=U,DTOUT=1 W $C(7) +DIA ;SFISC/GFT-SELECT FIELDS TO EDIT ;7/10/97 11:37 + ;;22.0;VA FileMan;;Mar 30, 1999 + ;Per VHA Directive 10-93-142, this routine should not be modified. + ;12999;7752413;3179; + ; + D DICS +1 D F W !?F*3,"EDIT WHICH "_X I $S(DB:DIAT="",1:1) R ": ALL// ",X:DTIME S:'$T X=U,DTOUT=1 G ALL^DIA1:X=""!(X="ALL"),TEMP^DIA1:X?1"[".E&'F,L +ED G NDB:DIAT="" +GDB S Y=$P(DIAT,";",DB) I "Q"[Y G NDB:Y="" D DB G GDB + I Y?.NP,$P(Y,":",2),Y'["/" S Y=+Y_"-"_$P(Y,":",2) + I $D(DI(DB)),$D(DI(DB,F,DI,DIAO)) S Y=DI(DB,F,DI,DIAO) + W ": "_Y D RW + I X="" S X=Y I X="ALL" G ALL^DIA1 +L S DSC=X?1"^".E I DSC S X=$E(X,2,999) I U[X K DR Q + I $A(X)=64 G X:X'?1P.N,P:$L(X)>1,X:'DB S DB=DB+1 G 2 + K DIC,DIAB D DICS S DV="",J=$P(X,"-",2) I +J=J,$P(X,"-",1)=+X,J>X S D(F)=J K DA D RANGE^DIA1 K D S Y=DA G X:Y="" D DB G 2 +DIC ; + S DIC(0)="EZI",DIC="^DD(DI,",Y=-1 G X^DIA3:X[";" S DIC("W")="S %=$P(^(0),U,2) I % W $S($P(^DD(+%,.01,0),U,2)[""W"":"" (word-processing)"",1:"" (multiple)"")" D ^DIC Q:$D(DTOUT) + I Y>0 D SET S Y=$P(Y(0),U,2) G 2:'Y S L=L+1,(DI,J(L))=+Y,I(L)=""""_$P($P(Y(0),U,4),";",1)_"""" G DOWN + I $E(X)="]" S DRS=9,X=$E(X,2,999) G DIC:X]"",2 + G DIA^DIQQQ:X?."?" I $D(^DD(DI,"GR")) K Y S Y=-1 D:$L(X)<31 + . N I,DIGRP,DTOUT,DUOUT,DIRUT,DIROUT,DIYN S DIGRP=X,DIYN=0 + . D:$D(^DD(DI,"GR",DIGRP)) Q:DIYN F S DIGRP=$O(^DD(DI,"GR",DIGRP)) Q:$E(DIGRP,1,$L(X))'=X D Q:DIYN + .. N X,I + .. F I=0:0 S I=$O(^DD(DI,"GR",DIGRP,I)) Q:'I I $G(^DD(DI,I,0))]"" S I(I)=I_U_$P(^(0),U) + .. Q:'$O(I(0)) + .. W !!,"Fields in Group: ",DIGRP F I=0:0 S I=$O(I(I)) Q:'I W !,?2,I,?10,$P(I(I),U,2) + .. D Q:DIYN'=1 + ... N X,Y S DIR(0)="Y",DIR("A")="Edit this GROUP of fields",DIR("B")="YES" D ^DIR S DIYN=$S(Y=1:1,$G(DIRUT):2,1:0) Q + .. M Y=I S Y=0 Q + . Q + K DIYN G X^DIA3 + ; +F S X=$P(^DD(DI,0),U,1) I F,X="FIELD" S X=$O(^(0,"NM",0))_" "_X + Q + ; +X ; + W $C(7),"??" D DICS +2 ; + G 1:'$D(DR(F+1,DI)) D F W !?F*3,"THEN EDIT "_X G ED:DB +R R ": ",X:DTIME E W $C(7) S X=U,DTOUT=1 + I X]"" G L +UP ; + G ^DIA1:'F K I(L),J(L) S L=L-1 I '$D(J(L)) F L=L-99:1 Q:'$D(J(L+1)) + I DB S DB=DB(F),DIAO=DIAO(F),DIAT=$S(DIAO<0:"",DIAO:^DIE(DIAA,"DR",F,J(L),DIAO),$D(^DIE(DIAA,"DR",F,J(L))):^(J(L)),1:"") + S DIAP=DIAP(F),DI=J(L),F=F-1 G 2 + ; +NDB I DB,DIAO'<0 S DIAO=DIAO+1 I $D(^DIE(DIAA,"DR",F+1,DI,DIAO)) S DIAT=^(DIAO),DB=1 G GDB + S DIAO=-1 G R + ; +EN ; + D OS^DII:'$D(DISYS),DICS +DOWN S F=F+1,DIAP(F)=DIAP,DIAP=0 I DB S DB(F)=DB,DB=1,DIAO(F)=DIAO,DIAO=0,DIAT=$S($D(^DIE(DIAA,"DR",F+1,DI)):^(DI),1:"") + G 1:$P(^DD(DI,.01,0),U,2)'["W",1:L#100=0,UP +DICS ; + S DIC("S")="I Y>.001,$P(^(0),U,2)'[""C"""_$S(DUZ(0)="@":"",1:",$P(^(0),U,2)'[""K""")_" Q:'$D(^(9)) I ^(9)'=U"_$S(DUZ(0)'="@":" F DW=1:1:$L(^(9)) I DUZ(0)[$E(^(9),DW) Q",1:"") Q + ; +P ; + S DRS=99,Y=X D DB G 2 + ; +SET S Y=+Y_DV +DB ; + I DB,'DSC S DB=DB+1 +D ; + I '$D(DR(F+1,DI)) S DR(F+1,DI)="",DIAP=0 + E I $L(DR(F+1,DI))+$L(Y)>230 F %=0:1 I '$D(DW(DI,%)) S DIAP=DIAP\1000+1*1000,DW(DI)=F+1,DW(DI,%)=DR(F+1,DI),DR(F+1,DI)="" Q + S DR(F+1,DI)=DR(F+1,DI)_Y_";",DRS=DRS+1,DIAP=DIAP+1 I $D(DIAB) S ^UTILITY($J,DIAP#1000,F,DI,DIAP\1000)=DIAB K DIAB + Q +RW I $L(Y)>19 D RW^DIR2 Q + W "// " R X:DTIME I '$T S X=U,DTOUT=1 W $C(7) diff --git a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIA1.m b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIA1.m index c6afba40..2a641049 100644 --- a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIA1.m +++ b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIA1.m @@ -1,51 +1,53 @@ -DIA1 ;SFISC/GFT-PROCESS TEMPLATES, RANGES FOR INPUT ;20MAR2006 - ;;22.0;VA FileMan;**159**;Mar 30, 1999;Build 8 - ;Per VHA Directive 2004-038, this routine should not be modified. -S D NOW^%DTC S DIADT=+$J(%,0,4) K %,DW G Q:DRS<5 R !,"STORE THESE FIELDS IN TEMPLATE: ",X:DTIME S:'$T DTOUT=1 G Q:X="" S DIC(0)="LZSEQ",DLAYGO=0 D T K DLAYGO,DIC I Y<0 G S:X'[U K DR G Q - S X=$P(^(0),U,6) I DUZ(0)'["@",X]"" F %=1:1 I DUZ(0)[$E(X,%) Q:%'>$L(X) W !?7,$C(7),"YOU HAVE NO 'WRITE ACCESS' TO THIS TEMPLATE",! G S - S DW=$S('$D(^("ROU")):1,^("ROU")'[U:1,$D(^("ROUOLD")):^("ROUOLD"),1:1),%=0,X=$P(Y,U,2) - I $O(^(0))]"" W $C(7),!,X_" TEMPLATE ALREADY EXISTS.... OK TO REPLACE" D YN^DICN W ! G S:%-1 L +^DIE(+Y) S %Y="" F %X=0:0 S %Y=$O(^DIE(+Y,%Y)) Q:%Y="" K:",%D,ROUOLD,W,"'[(","_%Y_",") ^(%Y) - S ^DIE(+Y,0)=X_U_DIADT_U_$S('%:DUZ(0),1:$P(Y(0),U,3))_U_DI_U_DUZ_U_$S('%:DUZ(0),1:$P(Y(0),U,6))_U_DT,^DIE("F"_DI,X,+Y)=1 L -^DIE(+Y) -M S %X="DR(",%Y="^DIE(+Y,""DR""," D %XY^%RCR M ^DIE(+Y,"DIAB")=^UTILITY($J) - S X=DW,DP=DIA("P"),DMAX=^DD("ROU") I X'=1,$D(^DD("OS",DISYS,"ZS")) D EN^DIEZ S DR(1,DIA("P"))=U_DNM -Q K DNM,DIAO,DI,DIAP,%,%I,DIADT,DIAT,DIE,DMAX,%X,%Y Q - ; -ALL ;Called by DIETED, DIA - S %=DI,^UTILITY($J,1,F,%,DIAP\1000)="ALL" K DA D G UP^DIA:F,S:$D(DRS) Q - .N DIA1 S DIA1=DIARLVL D A - ; -RANGE ;called by DIA, DIE17, DIETED - N DIA1 S DIA1=F+1 S %=DI I X>0 S Y=X-.000001 G B -A S Y=0 -B S DA="",X=0 -G S DG=Y -DR S Y=$O(^DD(%,Y)) S:Y="" Y=-1 I $D(D(F)),Y'>0!(Y>D(F)) D DG:X Q - I Y'>0 D DG:X S:$D(DR(DIA1,%))[0 DR(DIA1,%)=DA Q - I $D(^(Y,0)),X X DIC("S") G G:$T D DG G DR - X DIC("S") E G DR - S X=Y G G - ; -DG S DA=DA_$E(";",1,$L(DA))_X_$P(":"_DG,U,X'=DG) - S DQ=0 F S DQ=$O(^DD(%,"SB",DQ)) Q:DQ="" S DP=$O(^(DQ,0)) I DP'DG S Y(F,DQ)="" - S DQ=-1 -Y S X=$O(Y(F,0)) I X>0 K Y(F,X) S DA(F)=DA,Y(F)=Y,%(F)=%,F=F+1,DIA1=DIA1+1,%=X D A S F=F-1,DIA1=DIA1-1,%=%(F),Y=Y(F),DA=DA(F) G Y - S X="",DG=0 K DP Q - ; -TEMP ; - S DIC(0)="ZSEQ" D T K DIC Q:$D(DTOUT) G DB:Y<0 - S %=$P(Y(0),U,6) G ED:DUZ(0)="@"!'$L(%) F X=1:1:$L(%) I DUZ(0)[$E(%,X) G ED -GT I $G(^("ROU"))[U S DR(1,DIA("P"))=^("ROU") - E S:$D(^("W")) DIE("W")=^("W") S %X="^DIE(+Y,""DR"",",%Y="DR(" D %XY^%RCR - S $P(^DIE(+Y,0),U,7)=DT - Q - ; -T K DIC("W") S D="F"_DI,X=$P(X,"]",1),X=$P(X,"[",1)_$P(X,"[",2),DIC="^DIE(",DIC("S")="I $P(^(0),U,4)=DI"_$P(" S %=$P(^(0),U,3) F DW=1:1:$L(%) I DUZ(0)[$E(%,DW) Q",9,DUZ(0)'="@") G IX^DIC - ; -ED I Y<1 G GT - S %=2 W !,"WANT TO EDIT '",$P(Y,U,2),"' INPUT TEMPLATE" D YN^DICN G GT:%-1 - S DIE="^DIE(",DA=+Y,DR=".01;3;6" D ^DIE K DR I '$D(DA) S DB=0 G DB - S:$D(^DIE(DA,"DR"))#2 ^("DR",1,J(0))=^("DR") - S DIAA=DA,DRS=9,DIAT=$S($D(^DIE(DA,"DR",1,J(0))):^(J(0)),1:"") - M DI=^DIE(DA,"DIAB") - S F=0,(DIARTLVL,DB)=1,DIAO=0 F DXS=1:1 Q:'$D(DR(99,DXS)) -DB S DI=J(0) G ^DIA +DIA1 ;SFISC/GFT-PROCESS TEMPLATES, RANGES FOR INPUT ;2/22/93 3:29 PM + ;;22.0;VA FileMan;;Mar 30, 1999 + ;Per VHA Directive 10-93-142, this routine should not be modified. + S X="" F S X=$O(DW(X)) Q:X'>0 S F=DW(X),J=DR(F,X),DR(F,X)=DW(X,0),I=1 D OV +S D NOW^%DTC S DIADT=+$J(%,0,4) K %,DW G Q:DRS<5 R !,"STORE THESE FIELDS IN TEMPLATE: ",X:DTIME S:'$T DTOUT=1 G Q:X="" S DIC(0)="LZSEQ",DLAYGO=0 D T K DLAYGO,DIC I Y<0 G S:X'[U K DR G Q + S X=$P(^(0),U,6) I DUZ(0)'["@",X]"" F %=1:1 I DUZ(0)[$E(X,%) Q:%'>$L(X) W !?7,$C(7),"YOU HAVE NO 'WRITE ACCESS' TO THIS TEMPLATE",! G S + S DW=$S('$D(^("ROU")):1,^("ROU")'[U:1,$D(^("ROUOLD")):^("ROUOLD"),1:1),%=0,X=$P(Y,U,2) + I $O(^(0))]"" W $C(7),!,X_" TEMPLATE ALREADY EXISTS.... OK TO REPLACE" D YN^DICN W ! G S:%-1 L +^DIE(+Y) S %Y="" F %X=0:0 S %Y=$O(^DIE(+Y,%Y)) Q:%Y="" K:",%D,ROUOLD,W,"'[(","_%Y_",") ^(%Y) + S ^DIE(+Y,0)=X_U_DIADT_U_$S('%:DUZ(0),1:$P(Y(0),U,3))_U_DI_U_DUZ_U_$S('%:DUZ(0),1:$P(Y(0),U,6))_U_DT,^DIE("F"_DI,X,+Y)=1 L -^DIE(+Y) + S %X="DR(",%Y="^DIE(+Y,""DR""," D %XY^%RCR S %X="^UTILITY($J,",%Y="^DIE(+Y,""DIAB""," D %XY^%RCR S X=DW,DP=DIA("P"),DMAX=^DD("ROU") I X'=1,$D(^DD("OS",DISYS,"ZS")) D EN^DIEZ S DR(1,DIA("P"))=U_DNM +Q K DNM,DIAO,DI,DIAP,%,%I,DIADT,DIAT,DIE,DMAX,%X,%Y Q + ; +ALL ; + S %=DI,^UTILITY($J,1,F,%,DIAP\1000)="ALL" K DA D A G UP^DIA:F,S:$D(DRS) Q + ; +RANGE ; + S %=DI I X>0 S Y=X-.000001 G B +A S Y=0 +B S DA="",X=0 +G S DG=Y +DR S Y=$O(^DD(%,Y)) S:Y="" Y=-1 I $D(D(F)),Y'>0!(Y>D(F)) D DG:X Q + I Y'>0 D DG:X S:$D(DR(F+1,%))[0 DR(F+1,%)=DA Q + I $D(^(Y,0)),X X DIC("S") G G:$T D DG G DR + X DIC("S") E G DR + S X=Y G G + ; +DG S DA=DA_$E(";",1,$L(DA))_X_$P(":"_DG,U,X'=DG) + S DQ=0 F S DQ=$O(^DD(%,"SB",DQ)) Q:DQ="" S DP=$O(^(DQ,0)) I DP'DG S Y(F,DQ)="" + S DQ=-1 +Y S X=$O(Y(F,0)) I X>0 K Y(F,X) S DA(F)=DA,Y(F)=Y,%(F)=%,F=F+1,%=X D A S F=F-1,%=%(F),Y=Y(F),DA=DA(F) G Y + S X="",DG=0 K DP Q + ; +TEMP ; + S DIC(0)="ZSEQ" D T K DIC Q:$D(DTOUT) G DB:Y<0 + S %=$P(Y(0),U,6) G ED:DUZ(0)="@"!'$L(%) F X=1:1:$L(%) I DUZ(0)[$E(%,X) G ED +GT I $D(^("ROU")),^("ROU")[U S DR(1,DIA("P"))=^("ROU") + E S:$D(^("W")) DIE("W")=^("W") S:$D(^("DR"))#2 ^("DR",1,DIA("P"))=^("DR") S %X="^DIE(+Y,""DR"",",%Y="DR(" D %XY^%RCR + S $P(^DIE(+Y,0),U,7)=DT + Q + ; +T K DIC("W") S D="F"_DI,X=$P(X,"]",1),X=$P(X,"[",1)_$P(X,"[",2),DIC="^DIE(",DIC("S")="I $P(^(0),U,4)=DI"_$P(" S %=$P(^(0),U,3) F DW=1:1:$L(%) I DUZ(0)[$E(%,DW) Q",9,DUZ(0)'="@") G IX^DIC + ; +ED I Y<1 G GT + S %=2 W !,"WANT TO EDIT '",$P(Y,U,2),"' INPUT TEMPLATE" D YN^DICN G GT:%-1 + S DIE="^DIE(",DA=+Y,DR=".01;3;6" D ^DIE K DR I '$D(DA) S DB=0 G DB + S:$D(^DIE(DA,"DR"))#2 ^("DR",1,J(0))=^("DR") + S DIAA=DA,DRS=9,DIAT=$S($D(^DIE(DA,"DR",1,J(0))):^(J(0)),1:"") + I $D(^DIE(DA,"DIAB")) S %X="^DIE(DA,""DIAB"",",%Y="DI(" D %XY^%RCR + S F=0,DB=1,DIAO=0 F DXS=1:1 Q:'$D(DR(99,DXS)) +DB S DI=J(0) G ^DIA + ; +OV I '$D(DW(X,I)) S DR(F,X,I)=J Q + S DR(F,X,I)=DW(X,I),I=I+1 G OV diff --git a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIA3.m b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIA3.m index 52f3be20..e7094b9c 100644 --- a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIA3.m +++ b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIA3.m @@ -1,51 +1,54 @@ -DIA3 ;SFISC/GFT-UPDATE POINTERS, CHECK CODE IN INPUT STRING, CHECK FILE ACCESS ;19SEP2004 - ;;22.0;VA FileMan;**159**;Mar 30, 1999;Build 8 - ;Per VHA Directive 2004-038, this routine should not be modified. - S Y=DIA("P"),DH=1,DTO=DIA D PTS^DIT:'$D(^UTILITY("DIT",$J,0)) S ^UTILITY("DIT",$J,0)=0 Q:$D(^(0))<9 - D ASK^DITP Q:%-1 - S Y=0 I @("$O("_DIC_"0))'>0") G D -C W !,"WHICH DO YOU WANT TO DO? --",!?4,"1) DELETE ALL SUCH POINTERS",!?4,"2) CHANGE ALL SUCH POINTERS TO POINT TO A DIFFERENT '"_$P(^(0),U,1)_"' ENTRY",!!,"CHOOSE 1) OR 2): " R %:DTIME G F:U[%,W:%=2,C:%'=1 -D W !,"DELETE ALL POINTERS" D YN^DICN G F:%<0,C:%-1,DITP -W W !,"THEN PLEASE INDICATE WHICH ENTRY SHOULD BE POINTED TO" D L^DIA2 G DITP:Y>0 -F W $C(7),!,"OK... FORGET IT... LET'S GO ON TO EDIT ANOTHER ENTRY" Q -DITP S (^UTILITY("DIT",$J,DIA(1)),^(DIA(1)_";"_$E(DIA,2,999)))=+Y_";"_$E(DIA,2,999) - W !?4,"("_$P("DELETION^RE-POINTING",U,''Y+1)_" WILL OCCUR WHEN YOU LEAVE 'ENTER/EDIT' OPTION)" - Q - ; -FIXPT(DIFLG,DIFILE,DIDELIEN,DIPTIEN) ;DELETE OR REPOINT POINTERS - ;In V21, will just delete pointers. Later, DIPTIEN will be record to repoint to. - ;DIFLG="D" (delete), DIFILE=File# previously pointed to, DIDELIEN=Record# previously pointed to, DIPTIEN=New pointed-to record(future) - N %X,%Y,X,Y,DIPTIEN,DIFIXPT,DIFIXPTC,DIFIXPTH D I $G(X)]"" D BLD^DIALOG(201,X) Q - . S X="DIFLG" Q:$G(DIFLG)'="D" S X="DIDELIEN" Q:'$G(DIDELIEN) S X="DIFILE" Q:'$G(DIFILE) Q:$G(^DIC(DIFILE,0,"GL"))="" - . S X="DIPTIEN" I $G(DIPTIEN) S Y=$G(^DD(DIFILE,0,"GL")) Q:Y="" I '$D(@(Y_DIPTIEN_",0)")) Q - . K X Q - S DIPTIEN=+$G(DIPTIEN),(DIFIXPT,DIFIXPTC)=1 - N %,BY,D,DHD,DHIT,DIA,DIC,DISTOP,DL,DR,DTO,FLDS,FR,IOP,L,TO,X,Y,Z K ^UTILITY("DIT",$J),^TMP("DIFIXPT",$J) - S (DIFILE,DIA("P"),Y)=+DIFILE,(DIA,DTO)=^DIC(DIFILE,0,"GL"),DIA(1)=DIDELIEN - D PTS^DIT S ^UTILITY("DIT",$J,0)=0 G:$D(^(0))<9 QFIXPT - S (^UTILITY("DIT",$J,DIA(1)),^(DIA(1)_";"_$E(DIA,2,999)))=DIPTIEN_";"_$E(DIA,2,999) - D P^DITP -QFIXPT K ^UTILITY("DIT",$J),DIFLG,DIFILE,DIDELIEN,DIIOP,DIPTIEN Q - ; -X ; - I 'Y S:'DSC&DB DB=DB+1 S Y=0 F S Y=$O(Y(Y)) D D^DIA:Y'="" I Y="" S Y=-1 G 2^DIA - S Y=X I DUZ(0)="@",X'?.E1":" S X=$S(X["//^":$P(X,"//^",2),1:X),X=$S(X[";":$P(X,";"),1:X) D ^DIM G:$D(X) P^DIA:X=Y I Y["//^",'$D(X) G BAD - I Y[";" F %=2:1 S D=$P(Y,";",%) Q:D="" S D=$S(D="DUP":"d",D="REQ":"R","""R""d"""[D:"",$A(D)=34:$E(D,2,$F(D,"""",2)-2),D="T":D,1:"") G BAD:D="",DIA3^DIQQQ:$A(D)>45&($A(D)<58)!(D[":") S DV=D_$C(126)_DV - I Y[";" S X=$P(Y,";",1) S:'$D(DIAB) DIAB=Y G DIC^DIA - F DK="///+","//+","///","//" I Y[DK S DP=$P(Y,DK,2,9) I DP'?1"/".E&(DP'?1"^".E)!(DUZ(0)="@") G DEF - G BAD:Y'?.E1":" -E K X S:'$D(DIAB) DIAB=Y S DICOMP=L_"WE?",DQI="Y(",DA="DR(99,"_DXS_",",X=Y,DICMX=1 D ^DICOMPW I '$D(X) K DIAB G BAD:'$D(DP),ACC -L I $D(X)>1 S DXS=DXS+1,%=0 F S %=$O(X(%)) Q:%="" S @(DA_"%)=X(%)") - S %=-1 S L=$S(Y>L:+Y,1:L\100+1*100),Y=U_DP_U_U_X_" S X=$S(D(0)>0:D(0),1:"""")",DRS=99 K X D DB^DIA S DI=+DP G FILETOP^DIA - ; -DEF S X="DA,DV,DWLC,0)=X" F J=L:-1 Q:I(J)[U S X="DA("_(L-J+1)_"),"_I(J)_","_X - S DICMX="S DWLC=DWLC+1,"_DIA_X,DA="DR(99,"_DXS_",",DHIT=Y,X=DP,DQI="X(",DICOMP=L_"T?" D EN^DICOMP,DICS^DIA,XEC K X S X=$P(DHIT,DK,1),DV=DV_DK_DP G DIC^DIA:DV'[";" -BAD Q:$D(DTOUT) G X^DIA -ACC K DIAB W !?9,"YOU HAVE NO WRITE ACCESS TO FILE "_+DP G BAD - Q - ; -XEC I $D(X),Y["m" S DIC("S")="S %=$P(^(0),U,2) I %,$D(^DD(+%,.01,0)),$P(^(0),U,2)[""W"",$D(^DD(DI,Y,0)) "_DIC("S") - S Y=0 F S Y=$O(X(Y)) Q:Y="" S @(DA_"Y)=X(Y)") - S Y=-1 I $D(X) S %=1,Y="DO YOU MEAN '"_DP_"' AS A VARIABLE" W !?63-$L(Y),Y D YN^DICN Q:%-1 S Y="Q",DXS=DXS+1,DP=U_X,DRS=99 D D^DIA:$S(DIAP:$P(DR(F+1,DI),";",DIAP#1000)'="Q",1:1) S:'$D(DIAB) DIAB=DHIT - Q:DP'="@" I DK="//" S DA=U_U Q - W !,$C(7)," WARNING: THIS MEANS AUTOMATIC DELETION!!" +DIA3 ;SFISC/GFT-UPDATE POINTERS, CHECK CODE IN INPUT STRING, CHECK FILE ACCESS ;9/7/94 09:57 + ;;22.0;VA FileMan;;Mar 30, 1999 + ;Per VHA Directive 10-93-142, this routine should not be modified. + S Y=DIA("P"),DH=1,DTO=DIA D PTS^DIT:'$D(^UTILITY("DIT",$J,0)) S ^UTILITY("DIT",$J,0)=0 Q:$D(^(0))<9 + D ASK^DITP Q:%-1 + S Y=0 I @("$O("_DIC_"0))'>0") G D +C W !,"WHICH DO YOU WANT TO DO? --",!?4,"1) DELETE ALL SUCH POINTERS",!?4,"2) CHANGE ALL SUCH POINTERS TO POINT TO A DIFFERENT '"_$P(^(0),U,1)_"' ENTRY",!!,"CHOOSE 1) OR 2): " R %:DTIME G F:U[%,W:%=2,C:%'=1 +D W !,"DELETE ALL POINTERS" D YN^DICN G F:%<0,C:%-1,DITP +W W !,"THEN PLEASE INDICATE WHICH ENTRY SHOULD BE POINTED TO" D L^DIA2 G DITP:Y>0 +F W $C(7),!,"OK... FORGET IT... LET'S GO ON TO EDIT ANOTHER ENTRY" Q +DITP S (^UTILITY("DIT",$J,DIA(1)),^(DIA(1)_";"_$E(DIA,2,999)))=+Y_";"_$E(DIA,2,999) + W !?4,"("_$P("DELETION^RE-POINTING",U,''Y+1)_" WILL OCCUR WHEN YOU LEAVE 'ENTER/EDIT' OPTION)" + Q + ; +FIXPT(DIFLG,DIFILE,DIDELIEN,DIPTIEN) ;DELETE OR REPOINT POINTERS + ;In V21, will just delete pointers. Later, DIPTIEN will be record to repoint to. + ;DIFLG="D" (delete), DIFILE=File# previously pointed to, DIDELIEN=Record# previously pointed to, DIPTIEN=New pointed-to record(future) + N %X,%Y,X,Y,DIPTIEN,DIFIXPT,DIFIXPTC,DIFIXPTH D I $G(X)]"" D BLD^DIALOG(201,X) Q + . S X="DIFLG" Q:$G(DIFLG)'="D" S X="DIDELIEN" Q:'$G(DIDELIEN) S X="DIFILE" Q:'$G(DIFILE) Q:$G(^DIC(DIFILE,0,"GL"))="" + . S X="DIPTIEN" I $G(DIPTIEN) S Y=$G(^DD(DIFILE,0,"GL")) Q:Y="" I '$D(@(Y_DIPTIEN_",0)")) Q + . K X Q + S DIPTIEN=+$G(DIPTIEN),(DIFIXPT,DIFIXPTC)=1 + N %,BY,D,DHD,DHIT,DIA,DIC,DISTOP,DL,DR,DTO,FLDS,FR,IOP,L,TO,X,Y,Z K ^UTILITY("DIT",$J),^TMP("DIFIXPT",$J) + S (DIFILE,DIA("P"),Y)=+DIFILE,(DIA,DTO)=^DIC(DIFILE,0,"GL"),DIA(1)=DIDELIEN + D PTS^DIT S ^UTILITY("DIT",$J,0)=0 G:$D(^(0))<9 QFIXPT + S (^UTILITY("DIT",$J,DIA(1)),^(DIA(1)_";"_$E(DIA,2,999)))=DIPTIEN_";"_$E(DIA,2,999) + D P^DITP +QFIXPT K ^UTILITY("DIT",$J),DIFLG,DIFILE,DIDELIEN,DIIOP,DIPTIEN Q + ; +X ; + I 'Y S:'DSC&DB DB=DB+1 S Y=0 F S Y=$O(Y(Y)) D D^DIA:Y'="" I Y="" S Y=-1 G 2^DIA + S Y=X I DUZ(0)="@",X'?.E1":" S X=$S(X["//^":$P(X,"//^",2),1:X),X=$S(X[";":$P(X,";"),1:X) D ^DIM G:$D(X) P^DIA:X=Y I Y["//^",'$D(X) G BAD + I Y[";" F %=2:1 S D=$P(Y,";",%) Q:D="" S D=$S(D="DUP":"d",D="REQ":"R","""R""d"""[D:"",$A(D)=34:$E(D,2,$F(D,"""",2)-2),1:D) G BAD:D="",DIA3^DIQQQ:$A(D)>45&($A(D)<58)!(D[":") S DV=D_$C(126)_DV + I Y[";" S X=$P(Y,";",1) S:'$D(DIAB) DIAB=Y G DIC^DIA + F DK="///+","//+","///","//" I Y[DK S DP=$P(Y,DK,2,9) I DP'?1"/".E&(DP'?1"^".E)!(DUZ(0)="@") G DEF + G BAD:Y'?.E1":" +E K X S:'$D(DIAB) DIAB=Y S DICOMP=L_"WE?",DQI="Y(",DA="DR(99,"_DXS_",",X=Y,DICMX=1 D ^DICOMPW I '$D(X) K DIAB G BAD:'$D(DP),ACC + ;G L:DUZ(0)="@" + ;I $D(^DIC(3,"AFOF")) G ACC:'$D(^DIC(3,DUZ,"FOF",+DP,0)),ACC:'$P(^(0),U,6),L + ;I $D(^DIC(+DP,0,"WR")) F D=1:1 S %=$E(^("WR"),D) I DUZ(0)[% Q:%]"" G ACC +L I $D(X)>1 S DXS=DXS+1,%=0 F S %=$O(X(%)) Q:%="" S @(DA_"%)=X(%)") + S %=-1 S L=$S(Y>L:+Y,1:L\100+1*100),Y=U_DP_U_U_X_" S X=$S(D(0)>0:D(0),1:"""")",DRS=99 K X D DB^DIA S DI=+DP G EN^DIA + ; +DEF S X="DA,DV,DWLC,0)=X" F J=L:-1 Q:I(J)[U S X="DA("_(L-J+1)_"),"_I(J)_","_X + S DICMX="S DWLC=DWLC+1,"_DIA_X,DA="DR(99,"_DXS_",",DHIT=Y,X=DP,DQI="X(",DICOMP=L_"T?" D EN^DICOMP,DICS^DIA,XEC K X S X=$P(DHIT,DK,1),DV=DV_DK_DP G DIC^DIA:DV'[";" +BAD Q:$D(DTOUT) G X^DIA +ACC K DIAB W !?9,"YOU HAVE NO WRITE ACCESS TO FILE "_+DP G BAD + Q + ; +XEC I $D(X),Y["m" S DIC("S")="S %=$P(^(0),U,2) I %,$D(^DD(+%,.01,0)),$P(^(0),U,2)[""W"",$D(^DD(DI,Y,0)) "_DIC("S") + S Y=0 F S Y=$O(X(Y)) Q:Y="" S @(DA_"Y)=X(Y)") + S Y=-1 I $D(X) S %=1,Y="DO YOU MEAN '"_DP_"' AS A VARIABLE" W !?63-$L(Y),Y D YN^DICN Q:%-1 S Y="Q",DXS=DXS+1,DP=U_X,DRS=99 D D^DIA:$S(DIAP:$P(DR(F+1,DI),";",DIAP#1000)'="Q",1:1) S:'$D(DIAB) DIAB=DHIT + Q:DP'="@" I DK="//" S DA=U_U Q + W !,$C(7)," WARNING: THIS MEANS AUTOMATIC DELETION!!" diff --git a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIC3.m b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIC3.m index 729af7bf..3ebf8199 100644 --- a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIC3.m +++ b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIC3.m @@ -1,155 +1,154 @@ -DIC3 ;SFISC/XAK,TKW,SEA/TOAD-VA FileMan: Lookup, Part 1 (called from DIC) ;31JUL2007 - ;;22.0;VA FileMan;**1,16,4,17,20,28,40,86,70,159**;Mar 30, 1999;Build 8 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; -SEARCH ; Begin search through x-refs. - I DIC(0)["T",'$G(DICR) N:'$D(DICR(1)) DICR S DICR=0 D:DIC(0)["O" - . I DIC(0)'["X" S DIC(0)=DIC(0)_"X" Q - . S DIC(0)=$TR(DIC(0),"X") Q - I X?1"`".NP D ^DICM Q - I $L(X)>100,'$G(DILONGX) D ^DICM Q - N DIOK,DIEXACTN K % I $G(DISKIPIX)=D K DISKIPIX G M -EXACT ; Find all exact matches to the lookup values - S DISAVDS=DS,DIEXACTN=0 - I $G(DILONGX) G:$L(DICR(DICR,"ORG"))'>DINDEX(1,"LENGTH") M D - . S (X,X(1),DIVAL,DIVAL(1))=$E(DICR(DICR,"ORG"),1,DINDEX(1,"LENGTH")) Q - I DINDEX("#")>1,($G(DIALLVAL)!($G(DICR))),(DIC(0)["X"!(DIC(0)["O")) D EXACT^DIC4,SET^DIC4 - I DINDEX("#")'>1 S Y=0,DIX=X F D MOREX Q:Y=-1!(DS(0)) - I DS(0) Q:DIC(0)'["T" Q:$P(DS(0),U,2)'="U"!($G(DIROUT)) S DS(0)=0 - I DIC(0)["T",DIC(0)["E",$G(DUOUT) D ;22*70 - . ; Set up variables for next index lookup - . K DS,DUOUT - . S (DS,DS(0),DS("DD"))=0 - . S X=DIVAL(1) - . Q - I DISAVDS=0,DS=1,DIC(0)["O"!(DIC(0)'["E"),DIC(0)'["T" D Q:Y>0!($D(DIROUT)) ;Good IEN returned or user bailed out - . I DINDEX("#")'>1,DIEXACTN>1,DINDEX'="B" S Y=-1 Q - . S Y=+DS(1),DS("DD")=1 - . I DINDEX("#")'>1,DIEXACTN'>1 S DIY=1 D C^DIC2 Q - . D G^DIC2 Q - ; -PARTIAL ; Find all partial matches to the lookup values - I DIC(0)'["X",DINDEX("#")>1 D PARTIAL^DIC4,SET^DIC4 - I DIC(0)'["X",DINDEX("#")'>1 F D Q:$G(DIX)=""!(DS(0)) - . N DITYP S DITYP=$G(DINDEX(1,"TYPE")) - . D - . . I DIC(0)["E",(DITYP["F"!(DITYP["S")) Q:DIC(0)["n" - . . I $TR(X,"-.")?.N,DO(2)'["D",'$D(DIDA) S DIX=$O(@(DIC_"D,DIX_"" "")"),-1) - . . Q - . S DIX=$O(@(DIC_"D,DIX)")) - . Q:DIX="" - . I $P(DIX,X)'="" D Q:DIX="" - . . I +$P(X,"E")'=X!(DIC(0)'["E") S DIX="" Q - . . I DIC(0)'["n"!(DITYP'["F"&(DITYP'["S")) S DIX="" Q - . . D FINDMORE^DICLIX0(1,.DIX,X,.DINDEX) - . . S:$P(DIX,X)'="" DIX="" Q - . S Y=0 F D MOREX Q:Y=-1!(DS(0)) - . Q - I DS(0) Q:DIC(0)'["T" Q:$P(DS(0),U,2)'="U"!($G(DIROUT)) S DS(0)=0 - I DIC(0)["T",DIC(0)["E",$G(DUOUT) D ;22*70 - . ; Set up variables for next index lookup - . K DS,DUOUT - . S (DS,DS(0),DS("DD"))=0 - . S X=DIVAL(1) - . Q - ; -M ; Find the next index. At end, display the rest - I DIC(0)["T" D KEEPON^DIC5 I DS(0) Q:$P(DS(0),U,2)'="U"!($G(DIROUT)) - I DIC(0)["M" S DIOK=0 F D Q:DIOK - . N Y S Y=DINDEX("START") K DINDEX S DINDEX("WAY")=1,DINDEX("START")=Y,DINDEX("#")=1 - . S (D,DINDEX)=$S($D(DID):$P(DID,U,DID(1)),1:$O(@(DIC_"D)"))) - . S:$D(DID) DID(1)=DID(1)+1 - . I D=""!(D=-1) S D="",DIOK=1 Q - . I $D(@(DIC_"D)"))-10 Q - . ; Check Index, build index info - . D IXCHK^DIC4(.DIFILEI,.DINDEX,.DIOK,.DIALLVAL,.DIVAL,$G(DID)) Q - I DIC(0)["M",D]"" G EXACT - D:DIC(0)["M" D^DIC0 - I DS=1 S DS("DD")=1 D G^DIC2 Q - I DS D Y^DIC1 Q:DS(0) I DINDEX("#")'>1 D:DO(2)["O"&(DO(2)'["A") L^DICM Q - I $G(DILONGX) S X=$E(DICR(DICR,"ORG"),1,30) - I DIC(0)["T",'$G(DICR),DIC(0)["O",DIC(0)["X" G SEARCH - I DINDEX("#")>1,'$G(DICR) D:DIC(0)["L" D:Y=-1 BAD^DIC1 Q - . S Y=-1 I $G(DICR)="" N DICR S DICR=0 - . I $A(X)=34,X?.E1"""" D N^DICM Q - . K DD D L^DICM Q - D ^DICM Q - ; - ; -MOREX ; Find more exact matches to lookup value DIX - S Y=$O(@(DIC_"D,DIX,Y)")) I 'Y S Y=-1 Q - I $D(DIEXACTN)#2 S DIEXACTN=DIEXACTN+1 - D MN Q:'$T D K Q:$G(DS(0)) - I DS>1,DIC(0)'["E",DIC(0)'["Y" K DS S DS=0,DS(0)=1,Y=-1 - Q - ; -MN N DZ S DZ=$S((DIC(0)["D"&(DINDEX="B")):1,$G(DINDEX("#"))>1:0,$G(@(DIC_"D,DIX,Y)")):1,1:0) S DIYX=0 - D:'$D(DO) GETFA^DIC1(.DIC,.DO) - I D="B",'DZ,'($D(@(DIC_"D,DIX,Y)"))#2) D - . N I S I=Y F S DZ=$G(^(I)),I=$O(^(I,0)) Q:I="" - . Q - S DIY="" I '$D(@(DIC_"Y,0)")) X "I 0" Q - I D="B",'DZ,'$D(DO("SCR")),$L(DIX)<30,'$D(DIC("S")),'$D(@(DIC_"Y,-9)")),'$G(DINDEX("OLDSUB")) D ADDKEY I 1 Q - D S I D - . I DINDEX("FLISTD")["^.01^",DINDEX("#")=1,'DZ,$P(DIY,DIX)="",'$G(DINDEX("OLDSUB")) D Q - . . N I S I=$S($G(DILONGX):DICR(DICR,"ORG"),1:DIX) - . . S DIY=$P(DIY,I,2,9),DIYX=1 D ADDKEY Q - . Q:DIC(0)["Y" - . I ($G(DINDEX("#"))>1)!($G(DINDEX("OLDSUB"))) D Q - . . D ADDIX^DIC4(.DIFILEI,Y,.DINDEX,.DIX,.DISCREEN) - . . D ADDKEY Q - . D ADDKEY - . I DINDEX("FLISTD")["^.01^",'DZ S DIY="" - . Q - Q - ; -S D:'$D(DO) GETFA^DIC1(.DIC,.DO) - I $D(@(DIC_"Y,0)")),'$D(^(-9)) S DIY=$P(^(0),U) - E S DIY="" Q - I '$D(DIC("S")),'$D(DO("SCR")) Q - I $G(DINDEX("#"))>1!($G(DINDEX("OLDSUB"))) Q - I $G(DILONGX) N DI0NODE,DIVAL D - . N % S %=DINDEX(1,"GET") - . I %="DIVAL=DINDEX(DISUB)" S DIVAL=X Q - . I %["DI0NODE" S DI0NODE=@(DIC_"Y,0)") - . N DIFILE S DIFILE=DIFILEI,DIFILE(DIFILE)=DIFILEI(DIFILEI) - . N DIEN S DIEN=Y_DIENS - . S @% Q - N DIAC,DIFILE,DISAVEX,DISAVEY,DISAVED - M DISAVEX=X,DISAVEY=Y S DISAVED=D I $D(@(DIC_"Y,0)")) - I $D(DIVAL(1)),$D(DIVAL)=10 S DIVAL=DIVAL(1) ;*159 - I 1 X:$D(DIC("S")) DIC("S") K DIAC,DIFILE D:$D(DIC("S")) SX Q:'$T - I $D(DO("SCR")),$D(@(DIC_"Y,0)")) X DO("SCR") D SX Q:'$T - I 1 Q - ; -SX M X=DISAVEX,Y=DISAVEY S D=DISAVED Q - ; -ADDKEY ; Put KEY values into output array for display - S DIX("F")="" I DIC(0)'["U" S DIX("F")=$G(DINDEX("FLISTD")) - Q:'$D(DIFILEI(DIFILEI,"KEY")) Q:DIC(0)["S" - N DIKX,DII,DIFLD,DIERR,I - M DIKX=DIFILEI(DIFILEI,"KEY",DIFILEI) Q:'$D(DIKX) - K DIX("K") - F I=0:0 S I=$O(DIKX(I)) Q:'I F DIFLD=0:0 S DIFLD=$O(DIKX(I,DIFLD)) Q:'DIFLD D - . I DIFLD=.01,$G(DZ)=0 S DIY="" - . S DIX("K",I,DIFLD)=$$GET1^DIQ(DIFILEI,Y_DIFILEI(DIFILEI,"KEY","IEN"),DIFLD,"","","DIERR") Q - Q - ; -K ; Put an IEN into the DS array for display - N DZ,I S DZ=$O(DS(0)) F I=DZ:1:DS I +$G(DS(I))=Y,DIC(0)'["C" S I=-1 Q - I I'=-1,DIC(0)["T" D - . Q:'$D(^TMP($J,"DICSEEN",DIFILEI)) - . I $D(^TMP($J,"DICSEEN",DIFILEI,Y)) S I=-1 Q - . S ^TMP($J,"DICSEEN",DIFILEI,Y)="" Q - I I=-1 S I=DIX K DIX S DIX=I,I=-1 Q - I DS-DZ>100 D - . N D1,D2 S D2=DZ+19 F D1=DZ:1:D2 K DS(D1),DIY(D1),DIYX(D1) - . Q - S DS=DS+1 D - . S I=DS M DS(DS)=DIX S DS=I,I=DIX K DIX S DIX=I - . S DS(DS)=Y_"^"_$P(DIX,X,2,99) Q - S DIY(DS)=DIY S:DIY]""&$G(DIYX) DIYX(DS)=1 - I DS#5-1!(DS=1)!(DIC(0)["Y") Q - D Y^DIC1 Q - ; - ; +DIC3 ;SFISC/XAK,TKW,SEA/TOAD-VA FileMan: Lookup, Part 1 (called from DIC) ;7:29 AM 23 Sep 2002 + ;;22.0;VA FileMan;**1,16,4,17,20,28,40,86,70**;Mar 30, 1999 + ;Per VHA Directive 10-93-142, this routine should not be modified. + ; +SEARCH ; Begin search through x-refs. + I DIC(0)["T",'$G(DICR) N:'$D(DICR(1)) DICR S DICR=0 D:DIC(0)["O" + . I DIC(0)'["X" S DIC(0)=DIC(0)_"X" Q + . S DIC(0)=$TR(DIC(0),"X") Q + I X?1"`".NP D ^DICM Q + I $L(X)>100,'$G(DILONGX) D ^DICM Q + N DIOK,DIEXACTN K % I $G(DISKIPIX)=D K DISKIPIX G M +EXACT ; Find all exact matches to the lookup values + S DISAVDS=DS,DIEXACTN=0 + I $G(DILONGX) G:$L(DICR(DICR,"ORG"))'>DINDEX(1,"LENGTH") M D + . S (X,X(1),DIVAL,DIVAL(1))=$E(DICR(DICR,"ORG"),1,DINDEX(1,"LENGTH")) Q + I DINDEX("#")>1,($G(DIALLVAL)!($G(DICR))),(DIC(0)["X"!(DIC(0)["O")) D EXACT^DIC4,SET^DIC4 + I DINDEX("#")'>1 S Y=0,DIX=X F D MOREX Q:Y=-1!(DS(0)) + I DS(0) Q:DIC(0)'["T" Q:$P(DS(0),U,2)'="U"!($G(DIROUT)) S DS(0)=0 + I DIC(0)["T",DIC(0)["E",$G(DUOUT) D ;22*70 + . ; Set up variables for next index lookup + . K DS,DUOUT + . S (DS,DS(0),DS("DD"))=0 + . S X=DIVAL(1) + . Q + I DISAVDS=0,DS=1,DIC(0)["O"!(DIC(0)'["E"),DIC(0)'["T" D Q:Y>0!($D(DIROUT)) ;Good IEN returned or user bailed out + . I DINDEX("#")'>1,DIEXACTN>1,DINDEX'="B" S Y=-1 Q + . S Y=+DS(1),DS("DD")=1 + . I DINDEX("#")'>1,DIEXACTN'>1 S DIY=1 D C^DIC2 Q + . D G^DIC2 Q + ; +PARTIAL ; Find all partial matches to the lookup values + I DIC(0)'["X",DINDEX("#")>1 D PARTIAL^DIC4,SET^DIC4 + I DIC(0)'["X",DINDEX("#")'>1 F D Q:$G(DIX)=""!(DS(0)) + . N DITYP S DITYP=$G(DINDEX(1,"TYPE")) + . D + . . I DIC(0)["E",(DITYP["F"!(DITYP["S")) Q:DIC(0)["n" + . . I $TR(X,"-.")?.N,DO(2)'["D",'$D(DIDA) S DIX=$O(@(DIC_"D,DIX_"" "")"),-1) + . . Q + . S DIX=$O(@(DIC_"D,DIX)")) + . Q:DIX="" + . I $P(DIX,X)'="" D Q:DIX="" + . . I +$P(X,"E")'=X!(DIC(0)'["E") S DIX="" Q + . . I DIC(0)'["n"!(DITYP'["F"&(DITYP'["S")) S DIX="" Q + . . D FINDMORE^DICLIX0(1,.DIX,X,.DINDEX) + . . S:$P(DIX,X)'="" DIX="" Q + . S Y=0 F D MOREX Q:Y=-1!(DS(0)) + . Q + I DS(0) Q:DIC(0)'["T" Q:$P(DS(0),U,2)'="U"!($G(DIROUT)) S DS(0)=0 + I DIC(0)["T",DIC(0)["E",$G(DUOUT) D ;22*70 + . ; Set up variables for next index lookup + . K DS,DUOUT + . S (DS,DS(0),DS("DD"))=0 + . S X=DIVAL(1) + . Q + ; +M ; Find the next index. At end, display the rest + I DIC(0)["T" D KEEPON^DIC5 I DS(0) Q:$P(DS(0),U,2)'="U"!($G(DIROUT)) + I DIC(0)["M" S DIOK=0 F D Q:DIOK + . N Y S Y=DINDEX("START") K DINDEX S DINDEX("WAY")=1,DINDEX("START")=Y,DINDEX("#")=1 + . S (D,DINDEX)=$S($D(DID):$P(DID,U,DID(1)),1:$O(@(DIC_"D)"))) + . S:$D(DID) DID(1)=DID(1)+1 + . I D=""!(D=-1) S D="",DIOK=1 Q + . I $D(@(DIC_"D)"))-10 Q + . ; Check Index, build index info + . D IXCHK^DIC4(.DIFILEI,.DINDEX,.DIOK,.DIALLVAL,.DIVAL,$G(DID)) Q + I DIC(0)["M",D]"" G EXACT + D:DIC(0)["M" D^DIC0 + I DS=1 S DS("DD")=1 D G^DIC2 Q + I DS D Y^DIC1 Q:DS(0) I DINDEX("#")'>1 D:DO(2)["O"&(DO(2)'["A") L^DICM Q + I $G(DILONGX) S X=$E(DICR(DICR,"ORG"),1,30) + I DIC(0)["T",'$G(DICR),DIC(0)["O",DIC(0)["X" G SEARCH + I DINDEX("#")>1,'$G(DICR) D:DIC(0)["L" D:Y=-1 BAD^DIC1 Q + . S Y=-1 I $G(DICR)="" N DICR S DICR=0 + . I $A(X)=34,X?.E1"""" D N^DICM Q + . K DD D L^DICM Q + D ^DICM Q + ; + ; +MOREX ; Find more exact matches to lookup value DIX + S Y=$O(@(DIC_"D,DIX,Y)")) I 'Y S Y=-1 Q + I $D(DIEXACTN)#2 S DIEXACTN=DIEXACTN+1 + D MN Q:'$T D K Q:$G(DS(0)) + I DS>1,DIC(0)'["E",DIC(0)'["Y" K DS S DS=0,DS(0)=1,Y=-1 + Q + ; +MN N DZ S DZ=$S((DIC(0)["D"&(DINDEX="B")):1,$G(DINDEX("#"))>1:0,$G(@(DIC_"D,DIX,Y)")):1,1:0) S DIYX=0 + D:'$D(DO) GETFA^DIC1(.DIC,.DO) + I D="B",'DZ,'($D(@(DIC_"D,DIX,Y)"))#2) D + . N I S I=Y F S DZ=$G(^(I)),I=$O(^(I,0)) Q:I="" + . Q + S DIY="" I '$D(@(DIC_"Y,0)")) X "I 0" Q + I D="B",'DZ,'$D(DO("SCR")),$L(DIX)<30,'$D(DIC("S")),'$D(@(DIC_"Y,-9)")),'$G(DINDEX("OLDSUB")) D ADDKEY I 1 Q + D S I D + . I DINDEX("FLISTD")["^.01^",DINDEX("#")=1,'DZ,$P(DIY,DIX)="",'$G(DINDEX("OLDSUB")) D Q + . . N I S I=$S($G(DILONGX):DICR(DICR,"ORG"),1:DIX) + . . S DIY=$P(DIY,I,2,9),DIYX=1 D ADDKEY Q + . Q:DIC(0)["Y" + . I ($G(DINDEX("#"))>1)!($G(DINDEX("OLDSUB"))) D Q + . . D ADDIX^DIC4(.DIFILEI,Y,.DINDEX,.DIX,.DISCREEN) + . . D ADDKEY Q + . D ADDKEY + . I DINDEX("FLISTD")["^.01^",'DZ S DIY="" + . Q + Q + ; +S D:'$D(DO) GETFA^DIC1(.DIC,.DO) + I $D(@(DIC_"Y,0)")),'$D(^(-9)) S DIY=$P(^(0),U) + E S DIY="" Q + I '$D(DIC("S")),'$D(DO("SCR")) Q + I $G(DINDEX("#"))>1!($G(DINDEX("OLDSUB"))) Q + I $G(DILONGX) N DI0NODE,DIVAL D + . N % S %=DINDEX(1,"GET") + . I %="DIVAL=DINDEX(DISUB)" S DIVAL=X Q + . I %["DI0NODE" S DI0NODE=@(DIC_"Y,0)") + . N DIFILE S DIFILE=DIFILEI,DIFILE(DIFILE)=DIFILEI(DIFILEI) + . N DIEN S DIEN=Y_DIENS + . S @% Q + N DIAC,DIFILE,DISAVEX,DISAVEY,DISAVED + M DISAVEX=X,DISAVEY=Y S DISAVED=D I $D(@(DIC_"Y,0)")) + I 1 X:$D(DIC("S")) DIC("S") K DIAC,DIFILE D:$D(DIC("S")) SX Q:'$T + I $D(DO("SCR")),$D(@(DIC_"Y,0)")) X DO("SCR") D SX Q:'$T + I 1 Q + ; +SX M X=DISAVEX,Y=DISAVEY S D=DISAVED Q + ; +ADDKEY ; Put KEY values into output array for display + S DIX("F")="" I DIC(0)'["U" S DIX("F")=$G(DINDEX("FLISTD")) + Q:'$D(DIFILEI(DIFILEI,"KEY")) Q:DIC(0)["S" + N DIKX,DII,DIFLD,DIERR,I + M DIKX=DIFILEI(DIFILEI,"KEY",DIFILEI) Q:'$D(DIKX) + K DIX("K") + F I=0:0 S I=$O(DIKX(I)) Q:'I F DIFLD=0:0 S DIFLD=$O(DIKX(I,DIFLD)) Q:'DIFLD D + . I DIFLD=.01,$G(DZ)=0 S DIY="" + . S DIX("K",I,DIFLD)=$$GET1^DIQ(DIFILEI,Y_DIFILEI(DIFILEI,"KEY","IEN"),DIFLD,"","","DIERR") Q + Q + ; +K ; Put an IEN into the DS array for display + N DZ,I S DZ=$O(DS(0)) F I=DZ:1:DS I +$G(DS(I))=Y,DIC(0)'["C" S I=-1 Q + I I'=-1,DIC(0)["T" D + . Q:'$D(^TMP($J,"DICSEEN",DIFILEI)) + . I $D(^TMP($J,"DICSEEN",DIFILEI,Y)) S I=-1 Q + . S ^TMP($J,"DICSEEN",DIFILEI,Y)="" Q + I I=-1 S I=DIX K DIX S DIX=I,I=-1 Q + I DS-DZ>100 D + . N D1,D2 S D2=DZ+19 F D1=DZ:1:D2 K DS(D1),DIY(D1),DIYX(D1) + . Q + S DS=DS+1 D + . S I=DS M DS(DS)=DIX S DS=I,I=DIX K DIX S DIX=I + . S DS(DS)=Y_"^"_$P(DIX,X,2,99) Q + S DIY(DS)=DIY S:DIY]""&$G(DIYX) DIYX(DS)=1 + I DS#5-1!(DS=1)!(DIC(0)["Y") Q + D Y^DIC1 Q + ; + ; diff --git a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIC5.m b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIC5.m index 8eda08b5..880dbc22 100644 --- a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIC5.m +++ b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIC5.m @@ -1,70 +1,69 @@ -DIC5 ;SFISC/XAK,TKW,SEA/TOAD-VA FileMan: Lookup, Part 1 (utilities) ;05/28/2008 - ;;22.0;VA FileMan;**4,20,31,70,159**;Mar 30, 1999;Build 8 - ;Per VHA Directive 2004-038, this routine should not be modified. -NODE75 ; Do after executing 7.5 node on DD, called from ^DIC - I $D(X)#2 S (DIVAL,DIVAL(1))=X Q - S Y=-1 Q:DIC(0)'["Q"!(DIC(0)'["E") - W $C(7) Q:$D(DDS) - W !,$$EZBLD^DIALOG(120,$$EZBLD^DIALOG(8090)) Q - ; -BYIEN1 ; Lookup record by IEN when user enters `n for a number 'n', called from ^DIC - S Y=$E(X,2,30) I Y="" S Y=-1 Q - N % S %=DINDEX("START") N DINDEX S DINDEX="",DINDEX("#")=1,DINDEX("START")=% - D S^DIC3 I '$T S Y=-1 Q - N DD,DS,DZ S DS=1,DD=Y,DIX=X D ADDKEY^DIC3,GOT^DIC2 - Q - ; -BYIEN2 ; Lookup record by IEN when user enters a numeric lookup value, called from ^DIC - Q:DO(2)<0!($D(DF)) - N T S T=DINDEX(1,"TYPE") - I $D(@(DIC_"X,0)")) D Q:Y>0 - . N DD S DD=$D(^DD(DIFILEI,.001)) - . I 'DD Q:T["N" I '$O(@(DIC_"""A["")")),$O(^("A["))]"" Q - . N % S %=DINDEX("START") N DINDEX S DINDEX="",DINDEX("#")=1,DINDEX("START")=% - . S Y=X D S^DIC3 I '$T S Y=-1 Q - . N DZ,DS,DIX,DIC5D S DIC5D=D,DS=1,DIX=X D ADDKEY^DIC3,GOT^DIC2 Q:Y>0 - . D DO^DIC1 S D=DIC5D - I T["P"!(T["V"),DIC(0)'["U" S DISKIPIX=D - Q - ; -SPACEBAR ; Lookup last record selected by this user when user enters space bar return. Called from ^DIC - N % S %=DINDEX("START") N DINDEX S DINDEX="",DINDEX("#")=1,DINDEX("START")=% - D S^DIC3 I '$T S Y=-1 Q - N DZ,DS,DIX S DS=1,DIX=X D ADDKEY^DIC3,GOT^DIC2 Q - ; -KEEPON ; If DIC(0)["T", display entries found so far, then check for internal value if index is date, set, pointer, VP. Called from ^DIC3. - I DS D Q:Y>0!($G(DTOUT))!($G(DIROUT)) - . N I M I=X N X M X=I S I=D N D S D=I K I - . I DS=1 D - . . S DS("DD")=1 D G^DIC2 Q - . E I $G(DS("DD"))'=DS D Y^DIC1 I '$D(DIROUT),$D(DUOUT) K DUOUT ;22*70 - . K DD,DS,DIX,DIYX S (DD,DS,DS("DD"))=0 - . S:DIC(0)["E" DS(0,"HDRDSP",DIFILEI)=1 - . S DS(0)=$S(Y>0:"1^"_+Y,$G(DTOUT):"1^T",$G(DIROUT):"1^U",1:0) - . Q - Q:DIC(0)["U" I DINDEX=DINDEX("START"),$G(DINDEX("#"))>1 Q - N I M I=X N X M X=I S I=D N D S D=I K I - D 1^DICM - K DD,DS,DIX,DIYX S (DD,DS,DS("DD"))=0 - S DS(0)=$S(Y>0:"1^"_+Y,$G(DTOUT):"1^T",$G(DIROUT):"1^U",1:0) - Q - ; -PTRID(DO,DIC) ; Build code in DIC("W") to display Identifiers on pointed-to files - N DIFILEI,DIGBL,DIOGBL S DIFILEI=+DO(2),DIOGBL=DIC - F S DIFILEI=+$P($P($G(^DD(DIFILEI,.01,0)),U,2),"P",2) Q:'DIFILEI S DIGBL=$G(^DIC(DIFILEI,0,"GL")) Q:DIGBL="" D Q - Q -Q ; Build Identifier code for a single pointed-to file - N DIGBL1 S DIGBL1=DIGBL - I DIGBL[$C(34) S DIGBL1=$$CONVQQ^DILIBF(DIGBL) - N N,O,% S N=$O(DIC("W",999999),-1) - S O=$S(N:DIC("W",N),1:DIC("W")) - N % S %="I '$G(DICR) S DIEN=+"_DIOGBL_"DIEN,0) I $D("_DIGBL_"DIEN,0)) S DIFILEI="_DIFILEI_",DIGBL="""_DIGBL1_""" D WOV^DICQ1" - S DIOGBL=DIGBL - I ($L(O)+$L(%))<230 D Q - . I 'N S DIC("W")=DIC("W")_" "_% Q - . S DIC("W",N)=DIC("W",N)_" "_% Q - S N=N+1,DIC("W",N)=% - I N=1 S DIC("W")=DIC("W")_" X DIC(""W"",1)" Q - S DIC("W",N-1)=DIC("W",N-1)_" X DIC(""W"","_N_")" - Q - ; +DIC5 ;SFISC/XAK,TKW,SEA/TOAD-VA FileMan: Lookup, Part 1 (utilities) ;1:56 PM 19 Sep 2002 + ;;22.0;VA FileMan;**4,20,31,70**;Mar 30, 1999 + ;Per VHA Directive 10-93-142, this routine should not be modified. +NODE75 ; Do after executing 7.5 node on DD, called from ^DIC + I $D(X)#2 S (DIVAL,DIVAL(1))=X Q + S Y=-1 Q:DIC(0)'["Q"!(DIC(0)'["E") + W $C(7) Q:$D(DDS) + W !,$$EZBLD^DIALOG(120,$$EZBLD^DIALOG(8090)) Q + ; +BYIEN1 ; Lookup record by IEN when user enters `n for a number 'n', called from ^DIC + S Y=$E(X,2,30) I Y="" S Y=-1 Q + N % S %=DINDEX("START") N DINDEX S DINDEX="",DINDEX("#")=1,DINDEX("START")=% + D S^DIC3 I '$T S Y=-1 Q + N DD,DS,DZ S DS=1,DD=Y,DIX=X D ADDKEY^DIC3,GOT^DIC2 + Q + ; +BYIEN2 ; Lookup record by IEN when user enters a numeric lookup value, called from ^DIC + Q:DO(2)<0!($D(DF)) + N T S T=DINDEX(1,"TYPE") + I $D(@(DIC_"X,0)")) D Q:Y>0 + . N DD S DD=$D(^DD(DIFILEI,.001)) + . I 'DD Q:T["N" I '$O(@(DIC_"""A["")")),$O(^("A["))]"" Q + . N % S %=DINDEX("START") N DINDEX S DINDEX="",DINDEX("#")=1,DINDEX("START")=% + . S Y=X D S^DIC3 I '$T S Y=-1 Q + . N DZ,DS,DIX S DS=1,DIX=X D ADDKEY^DIC3,GOT^DIC2 Q + I T["P"!(T["V"),DIC(0)'["U" S DISKIPIX=D + Q + ; +SPACEBAR ; Lookup last record selected by this user when user enters space bar return. Called from ^DIC + N % S %=DINDEX("START") N DINDEX S DINDEX="",DINDEX("#")=1,DINDEX("START")=% + D S^DIC3 I '$T S Y=-1 Q + N DZ,DS,DIX S DS=1,DIX=X D ADDKEY^DIC3,GOT^DIC2 Q + ; +KEEPON ; If DIC(0)["T", display entries found so far, then check for internal value if index is date, set, pointer, VP. Called from ^DIC3. + I DS D Q:Y>0!($G(DTOUT))!($G(DIROUT)) + . N I M I=X N X M X=I S I=D N D S D=I K I + . I DS=1 D + . . S DS("DD")=1 D G^DIC2 Q + . E I $G(DS("DD"))'=DS D Y^DIC1 I '$D(DIROUT),$D(DUOUT) K DUOUT ;22*70 + . K DD,DS,DIX,DIYX S (DD,DS,DS("DD"))=0 + . S:DIC(0)["E" DS(0,"HDRDSP",DIFILEI)=1 + . S DS(0)=$S(Y>0:"1^"_+Y,$G(DTOUT):"1^T",$G(DIROUT):"1^U",1:0) + . Q + Q:DIC(0)["U" I DINDEX=DINDEX("START"),$G(DINDEX("#"))>1 Q + N I M I=X N X M X=I S I=D N D S D=I K I + D 1^DICM + K DD,DS,DIX,DIYX S (DD,DS,DS("DD"))=0 + S DS(0)=$S(Y>0:"1^"_+Y,$G(DTOUT):"1^T",$G(DIROUT):"1^U",1:0) + Q + ; +PTRID(DO,DIC) ; Build code in DIC("W") to display Identifiers on pointed-to files + N DIFILEI,DIGBL,DIOGBL S DIFILEI=+DO(2),DIOGBL=DIC + F S DIFILEI=+$P($P($G(^DD(DIFILEI,.01,0)),U,2),"P",2) Q:'DIFILEI S DIGBL=$G(^DIC(DIFILEI,0,"GL")) Q:DIGBL="" D Q + Q +Q ; Build Identifier code for a single pointed-to file + N DIGBL1 S DIGBL1=DIGBL + I DIGBL[$C(34) S DIGBL1=$$CONVQQ^DILIBF(DIGBL) + N N,O,% S N=$O(DIC("W",999999),-1) + S O=$S(N:DIC("W",N),1:DIC("W")) + N % S %="I '$G(DICR) S DIEN=+"_DIOGBL_"DIEN,0) I $D("_DIGBL_"DIEN,0)) S DIFILEI="_DIFILEI_",DIGBL="""_DIGBL1_""" D WOV^DICQ1" + S DIOGBL=DIGBL + I ($L(O)+$L(%))<230 D Q + . I 'N S DIC("W")=DIC("W")_" "_% Q + . S DIC("W",N)=DIC("W",N)_" "_% Q + S N=N+1,DIC("W",N)=% + I N=1 S DIC("W")=DIC("W")_" X DIC(""W"",1)" Q + S DIC("W",N-1)=DIC("W",N-1)_" X DIC(""W"","_N_")" + Q + ; diff --git a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICATT2.m b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICATT2.m index be8afc89..2bd631b3 100644 --- a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICATT2.m +++ b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICATT2.m @@ -1,59 +1,49 @@ -DICATT2 ;SFISC/GFT,XAK-DEFINING MULTIPLES ;9APR2007 - ;;22.0;VA FileMan;**89,152**;Mar 30, 1999;Build 10 - ;Per VHA Directive 2004-038, this routine should not be modified. - S T=$E(Z) G CHECK^DICATT:$D(DTOUT) - F P="I","O","L","x" S:$P(O,U,2)[P Z=$P(Z,U)_P_U_$P(Z,U,2) -1 K DS S:$P(Z,U)'["K" V=W[";0" - S P=0,N=DICL,DQ=4,DP=6,DQI=" S:$D(X) DINUM=+X",DREF=$F(O,DQI)-1=$L(O),DE(7,0)="NO",DG(7)="N" - S:T="*" T=$S($P(Z,U)["S":"S",1:"P") G 1^DICATT22:DA=.001 - G W:T="W" S:$D(DTIME)[0 DTIME=300 - I T'["F",T'["S",T'["K",'O!DREF S:DREF DE(7,0)="YES",DG(7)="Y" -S F Y=4:1:6 S DQ(Y)=$P($T(DQ+Y),";",3)_F_$P($T(DQ+Y),";",4)_" (Y/N)^RS^Y:YES;N:NO^"_Y_"^Q" I 'V,DA-.01!'N Q - S DG(5)="Y",DE(4,0)="NO",DP=-1,DL=1 - I T["P"!(T["N") S DE(5,0)="YES" - I O S DE(6,0)=$E("NY",$P(O,U,2)["M"+1) S:$P(O,U,2)["R" DE(4,0)="Y" I DA=.01,N S P=$O(^DD(J(N-1),"SB",A,0)) S:P="" P=-1 S Y=$P(^DD(J(N-1),P,0),U,2),DE(5,0)=$E("YN",Y["A"+1) - K Y S DIFLD=-1 D RE^DIED K DQ,DIFLD G:$D(Y) N^DICATT:$P(Z,U)["X",CHECK^DICATT I $D(DTOUT) K DTOUT G CHECK^DICATT - S:DG(5)="N" T=T_"A" I DG(4)="Y",$P(Z,U)'["R" S Z="R"_Z - I $D(DG(6)),DG(6)="Y",$P(Z,U)'["M" S Z="M"_Z -G S DIZ=Z G ^DICATT22 -Q ; - K T,B,A,J,DA,DIC,E,DR,W,S,Q,P,N,V,I,L,F,DQI,DIK,C,Z,Y,DE,O,DICS,DICL,DDA Q - ; -W S %=Z["L"+1 W !,"SHALL THIS TEXT NORMALLY APPEAR IN WORD-WRAP MODE" D YN^DICN - G CHECK^DICATT:%<0 I % S Z=$P($TR(Z,"L"),U)_$E("L",%=2)_U G WINDOW - W !,"ANSWER 'YES' IF THE INTERNALLY-STORED '"_F_"' TEXT" - W !?5,"SHOULD NORMALLY BE PRINTED OUT IN FULL LINES, BREAKING AT WORD BOUNDARIES." - W !?2,"ANSWER 'NO' IF THE INTERNAL TEXT SHOULD NORMALLY BE PRINTED OUT" - W !?5,"LINE-FOR-LINE AS IT STANDS.",! G W - ; - ; -WINDOW S %=2-(Z["x"!'O) W !,"SHALL ""|"" CHARACTERS IN THIS TEXT BE TREATED LIKE ANY OTHER CHARACTERS" D YN^DICN - G CHECK^DICATT:%<0 I % S Z=$P($TR(Z,"x"),U)_$E("x",%=1)_U G G - W !,"ANSWER 'YES' IF THE INTERNALLY-STORED '"_F_"' TEXT MAY HAVE ""|"" CHARACTERS" - W !?3,"IN IT (SUCH AS HL7 MESSAGES) THAT NEED TO DISPLAY EXACTLY AS THEY ARE STORED." - W !,"ANSWER 'NO' IF THE INTERNAL TEXT SHOULD NORMALLY BE PRINTED OUT WITH ANYTHING" - W !?3,"THAT IS DELIMITED BY ""|"" CHARACTERS INTERPRETED AS VARIABLE TEXT.",! G WINDOW - ; - ; - ; -X ; - W " (FIELD DEFINITION IS NOT EDITABLE)" S T=$E(^(0)),Z=$P(Y,U,2),Z=$P(Z,"M")_$P(Z,"M",2),Z=$P(Z,"R")_$P(Z,"R",2)_U_$P(Y,U,3),W=$P(Y,U,4),C=$P(Y,U,5,99) S:Z["K" V=0 G N^DICATT:N=6,1 - ; -NO ; - W !,$C(7)," " I $P(Z,U)["K"&(DUZ(0)'="@") G N^DICATT -TYPE K Y,M,DE,DIE,DQ,DG G Q^DIB:$D(DTOUT) S N=0,DQI=DICL+9,Y=^DD(A,DA,0),F=$P(Y,U),Z="" W !!,"DATA TYPE OF ",F,": " I 'O R X:DTIME S:'$T DTOUT=1 G X^DICATT:X[U!'$T S:DUZ(0)'="@" DIC("S")="I Y-9" S:DA=.001 DIC("S")="I Y<4!(Y=7)" G NEW - F N=9:-1:5,1:1:4 Q:$P(Y,U,2)[$E("DNSFWCPVK",N) - W $P(^DOPT("DICATT",N,0),U) G X:$P(Y,U,2)["K"&(DUZ(0)'="@") - G X:$P(Y,U,2)["X",6^DICATT:N=6 R "// ",X:DTIME S:'$T DTOUT=1 G N^DICATT:X[U!'$T,0^DICATT:X="" S DIC("S")="I Y-6,Y-9"_$P(",Y-5",U,N\2-2!(A=B)!(DA-.01)!$O(^DD(A,DA))>0),DIC("S")=DIC("S")_$S(N=7:",Y-8",N=8:",Y-7",1:"") -NEW I 'O,X=" ",E,$P(^DD(A,E,0),U,2)'["P",$P(^(0),U,2)'["V" W " <",$C(7) D E^DICATT W " DUPLICATED>" S DIZ=$S($D(DIZ):DIZ,1:DIZZ) G E^DICATT1 - S DIC(0)="QEI",DIC="^DOPT(""DICATT""," D ^DIC I Y>0 S:N-Y&O M="",O=$P(O,U,1,2)_U_U_$P(O,U,4) S N=+Y G 0^DICATT - I 'O,X["?",E,$P(^DD(A,E,0),U,2)'["P",$P(^(0),U,2)'["V" D DICATT^DIQQQ,E^DICATT W ", JUST HIT THE SPACE KEY" - G TYPE - ; -DQ ;; - ; - ; - ; - ;;IS ; ENTRY MANDATORY - ;;SHOULD USER SEE AN "ADDING A NEW ;?" MESSAGE FOR NEW ENTRIES - ;;HAVING ENTERED OR EDITED ONE ;, SHOULD USER BE ASKED ANOTHER +DICATT2 ;SFISC/GFT,XAK-DEFINING MULTIPLES ;02:13 PM 24 Dec 2001 + ;;22.0;VA FileMan;**89**;Mar 30, 1999 + ;Per VHA Directive 10-93-142, this routine should not be modified. + S T=$E(Z) G CHECK^DICATT:$D(DTOUT) + F P="I","O","L" S:$P(O,U,2)[P Z=$P(Z,U)_P_U_$P(Z,U,2) +1 K DS S:$P(Z,U)'["K" V=W[";0" + S P=0,N=DICL,DQ=4,DP=6,DQI=" S:$D(X) DINUM=+X",DREF=$F(O,DQI)-1=$L(O),DE(7,0)="NO",DG(7)="N" + S:T="*" T=$S($P(Z,U)["S":"S",1:"P") G 1^DICATT22:DA=.001 + G W:T="W" S:$D(DTIME)[0 DTIME=300 + I T'["F",T'["S",T'["K",'O!DREF S:DREF DE(7,0)="YES",DG(7)="Y" +S F Y=4:1:6 S DQ(Y)=$P($T(DQ+Y),";",3)_F_$P($T(DQ+Y),";",4)_" (Y/N)^RS^Y:YES;N:NO^"_Y_"^Q" I 'V,DA-.01!'N Q + S DG(5)="Y",DE(4,0)="NO",DP=-1,DL=1 + I T["P"!(T["N") S DE(5,0)="YES" + I O S DE(6,0)=$E("NY",$P(O,U,2)["M"+1) S:$P(O,U,2)["R" DE(4,0)="Y" I DA=.01,N S P=$O(^DD(J(N-1),"SB",A,0)) S:P="" P=-1 S Y=$P(^DD(J(N-1),P,0),U,2),DE(5,0)=$E("YN",Y["A"+1) + K Y S DIFLD=-1 D RE^DIED K DQ,DIFLD G:$D(Y) N^DICATT:$P(Z,U)["X",CHECK^DICATT I $D(DTOUT) K DTOUT G CHECK^DICATT + S:DG(5)="N" T=T_"A" I DG(4)="Y",$P(Z,U)'["R" S Z="R"_Z + I $D(DG(6)),DG(6)="Y",$P(Z,U)'["M" S Z="M"_Z +G S DIZ=Z G ^DICATT22 +Q ; + K T,B,A,J,DA,DIC,E,DR,W,S,Q,P,N,V,I,L,F,DQI,DIK,C,Z,Y,DE,O,DICS,DICL,DDA Q + ; +W S %=Z["L"+1 W !,"SHALL THIS TEXT NORMALLY APPEAR IN WORD-WRAP MODE" D YN^DICN + G CHECK^DICATT:%<0 I % S Z=$P($P(Z,"L")_$P(Z,"L",2),U)_$E("L",%=2)_U G G + W !?3,"ANSWER 'YES' IF THE INTERNALLY-STORED '"_F_"' TEXT" + W !?5,"SHOULD NORMALLY BE PRINTED OUT IN FULL LINES, BREAKING AT WORD BOUNDARIES." + W !?2,"ANSWER 'NO' IF THE INTERNAL TEXT SHOULD NORMALLY BE PRINTED OUT" + W !?5,"LINE-FOR-LINE AS IT STANDS.",! G W + ; +X ; + W " (FIELD DEFINITION IS NOT EDITABLE)" S T=$E(^(0)),Z=$P(Y,U,2),Z=$P(Z,"M")_$P(Z,"M",2),Z=$P(Z,"R")_$P(Z,"R",2)_U_$P(Y,U,3),W=$P(Y,U,4),C=$P(Y,U,5,99) S:Z["K" V=0 G N^DICATT:N=6,1 + ; +NO ; + W !,$C(7)," " I $P(Z,U)["K"&(DUZ(0)'="@") G N^DICATT +TYPE K Y,M,DE,DIE,DQ,DG G Q^DIB:$D(DTOUT) S N=0,DQI=DICL+9,Y=^DD(A,DA,0),F=$P(Y,U),Z="" W !!,"DATA TYPE OF ",F,": " I 'O R X:DTIME S:'$T DTOUT=1 G X^DICATT:X[U!'$T S:DUZ(0)'="@" DIC("S")="I Y-9" S:DA=.001 DIC("S")="I Y<4!(Y=7)" G NEW + F N=9:-1:5,1:1:4 Q:$P(Y,U,2)[$E("DNSFWCPVK",N) + W $P(^DOPT("DICATT",N,0),U) G X:$P(Y,U,2)["K"&(DUZ(0)'="@") + G X:$P(Y,U,2)["X",6^DICATT:N=6 R "// ",X:DTIME S:'$T DTOUT=1 G N^DICATT:X[U!'$T,0^DICATT:X="" S DIC("S")="I Y-6,Y-9"_$P(",Y-5",U,N\2-2!(A=B)!(DA-.01)!$O(^DD(A,DA))>0),DIC("S")=DIC("S")_$S(N=7:",Y-8",N=8:",Y-7",1:"") +NEW I 'O,X=" ",E,$P(^DD(A,E,0),U,2)'["P",$P(^(0),U,2)'["V" W " <",$C(7) D E^DICATT W " DUPLICATED>" S DIZ=$S($D(DIZ):DIZ,1:DIZZ) G E^DICATT1 + S DIC(0)="QEI",DIC="^DOPT(""DICATT""," D ^DIC I Y>0 S:N-Y&O M="",O=$P(O,U,1,2)_U_U_$P(O,U,4) S N=+Y G 0^DICATT + I 'O,X["?",E,$P(^DD(A,E,0),U,2)'["P",$P(^(0),U,2)'["V" D DICATT^DIQQQ,E^DICATT W ", JUST HIT THE SPACE KEY" + G TYPE + ; +DQ ;; + ; + ; + ; + ;;IS ; ENTRY MANDATORY + ;;SHOULD USER SEE AN "ADDING A NEW ;?" MESSAGE FOR NEW ENTRIES + ;;HAVING ENTERED OR EDITED ONE ;, SHOULD USER BE ASKED ANOTHER diff --git a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICM.m b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICM.m index 23cf7cfb..335637ac 100644 --- a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICM.m +++ b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICM.m @@ -1,146 +1,142 @@ -DICM ;SFISC/GFT,XAK,TKW-MULTIPLE LOOKUP FOR FLDS WHICH MUST BE TRANSFORMED ;4AUG2007 - ;;22.0;VA FileMan;**4,20,31,40,149,159**;Mar 30, 1999;Build 8 - ;Per VHA Directive 2004-038, this routine should not be modified. - I '$D(DICR(1)),DIC(0)'["T" N DICR S DICR=0 - I $A(X)=34,X?.E1"""" G N - I $G(^DD(+DO(2),0,"LOOK"))]"",^("LOOK")'="SOUNDEX" G @^("LOOK") - I DIC(0)["U" S DD=0 G W - I DIC(0)["T" G 2 -R N DIFLAGS S DIFLAGS="4l"_$P("M^",U,DIC(0)["M") - N DIFORCE D - . S DIFORCE=0 I DIC(0)'["M"!($D(DID)) S DIFORCE=1 - . S DIFORCE(0)=$S(DIC(0)'["M":DINDEX,$D(DID):DID,1:"*"),DIFORCE(1)=1 - F D 1 I DINDEX=""!(Y>0)!($G(DTOUT))!($G(DIROUT)) Q - G 2 - ; -1 N DS,%Y,DIV - I $G(DINDEX("IXFILE")) S Y=DINDEX(1,"FILE"),%Y=DINDEX(1,"FIELD") - E S Y=$O(^DD(+DO(2),0,"IX",DINDEX,0)) S:Y="" Y=-1 S %Y=+$O(^(Y,0)) - I Y=-1,DINDEX="B" S Y=+DO(2),%Y=.01 - S:Y="" Y=-1 S:%Y="" %Y=-1 - I $D(DICR(U,Y,%Y,DINDEX)) S Y=-1 - E I %Y=.01,DINDEX'="B",Y=+DO(2),$D(DICR(U,Y,%Y,"B")),$G(DINDEX(1,"TRANCODE"))="" S Y=-1 - I Y'<0 D - . S DS=$G(^DD(Y,%Y,0)) I DS="" S Y=-1 Q - . S %=DINDEX,DICR(U,Y,%Y,DINDEX)=0 - . I $D(^DD(Y,%Y,7)) D RS K DS X ^(7) Q - . I $G(DINDEX("IXTYPE"))="S" D A,SOU^DICM1,D Q:Y>0 S Y=-1 Q - . S DIX=Y,Y=$P(DS,U,2) - . S Y=$S(Y["P":"P",Y["D":"D",Y["S":"S",Y["V":"V",1:"") - . I Y]"" D A D:'Y ^DICM1,D Q:Y>0 S Y=-1 Q - . I $G(DINDEX(1,"TRANCODE"))]"" S Y="T" D A,^DICM1 N DITRANX S DITRANX=1 D D - . Q:Y>0 S Y=-1 Q - Q:Y>0!(DIC(0)["T") D - . K DIV M DIV=X S DIV(1)=X N X,Y - . D NXTINDX^DICF2(.DINDEX,.DIFORCE,.DIFILEI,DIFLAGS,.DIV,"*") Q - Q - ; -2 D D^DIC0 S %=D - G K:Y>0!($G(DIROUT)) - I X?.E1L.E,DIC(0)'["X" D G K:$G(DIROUT) - . D % N DIFILEI,DINDEX - . S DIC(0)=$TR(DIC(0),"L"),X=$$UP^DILIBF(X) S:$G(DILONGX) DICR(DICR,"ORG")=X - . D DIC Q - I Y'>0,X["," S DS="",DIX=$P(X,",") I DIC(0)'["X",$L(DIX)<31 D G K:$G(DIROUT) ;COMMA-PIECING - . F %=2:1 S DD=$P(X,",",%) I DD'["""" D Q:DD="" - . . F Q:$A(DD)-32 S DD=$E(DD,2,999) - . . F Q:$A(DD,$L(DD))-32 S DD=$E(DD,1,$L(DD)-1) - . . I $L(DD)*2+$L(DS)>200!(DD="") S DD="" Q - . . S DS=DS_" I %?.E1P1"""_DD_""".E!(D'=""B""&(%?1"""_DD_""".E))" Q - . Q:DS="" S %=D - . D % S X=DIX N DILONGX - . S DS="S %=$P(^(0),U)"_DS,DIC(0)=DIC(0)_"D" D 7 Q - I Y'>0,$L(X)>30 D - . N DILONGX S DILONGX=1 - . S %=D D % S Y="DICR("_DICR_")",DICR(DICR,"ORG")=X - . S DS=$S(DIC(0)["X":"I DIVAL="_Y,1:"I '$L($P(DIVAL,"_Y_"))") - . S:DIC(0)["O"&(DIC(0)'["E") DS=DS_",'$L($P(DIVAL,"_Y_",2))" - . D 7 I Y>0!(X'?.E1L.E)!(DIC(0)["X") K DILONGX Q - . S %=D D % S (X,DICR(DICR,"ORG"))=$$UP^DILIBF(X) - . S Y="DICR("_DICR_",""ORG"")" - . S DS="I '$L($P(DIVAL,"_Y_"))" S:DIC(0)["O"&(DIC(0)'["E") DS=DS_",'$L($P(DIVAL,"_Y_",2))" - . D 7 K DILONGX Q - ; -K S DICR=+$G(DICR),DD=$D(DICR(DICR,6)) K:'DICR DICR - I Y>0 K DIC("W") D R^DIC2 Q - I $G(DTOUT)!($G(DIROUT)) Q -W I @("$O("_DIC_"""A[""))]""""") G NL:DIC(0)["N",DD - I DO(2)'["Z" S Y=0 D Q:Y>0!($G(DIROUT)) -DINUM .I $G(DINDEX("1","FIELD"))=.01,X?1.15NP,$P($G(^DD(+DO(2),.01,0)),U,5,99)["DINUM=X",$D(@(DIC_"X,0)")) D Q:Y>0 - ..S Y=X I 1 X:$D(DIC("S")) DIC("S") I S DIY="",DS=1 N DZ,DD D ADDKEY^DIC3,GOT^DIC2 Q - ..S Y=0 - .N DIOUT S DIOUT=0 F DS=1:1 S @("Y=$O("_DIC_"Y))") D Q:DIOUT - . . I 'Y S Y=-1,DIOUT=1 Q - . . W:DIC(0)["E"&(DS#20=0) ".." - . . I $D(@(DIC_Y_",0)")),$P(^(0),U)=X X:$D(DIC("S")) DIC("S") I S DIOUT=1 - . . I DIOUT S DIY="",DS=1 N DZ,DD D ADDKEY^DIC3,GOT^DIC2 - . . Q -NL I '$G(DICR) D NQ I $T D Q:Y>0!($G(DTOUT))!($G(DIROUT)) - . N:'$G(DIASKOK) DIASKOK S (DS,DIASKOK)=1 N DZ,DD - . D ADDKEY^DIC3,GOT^DIC2 Q -DD S Y=-1 I DD D BAD^DIC1 Q -L I DIC(0)["L" K DD G ^DICN -B D BAD^DIC1 Q - ; -N D RS S X=$E(X,2,$L(X)-1),%=D D - . I DINDEX("#")>1 S %Y=+$G(DINDEX(1,"FIELD")),DS=$G(^DD(+$G(DINDEX(1,"FILE")),%Y,0)) Q:DS]"" - . S DS=^DD(+DO(2),.01,0),%Y=.01 Q - F Y="P","D","S","V" I $P(DS,U,2)[Y K:Y="P" DO D ^DICM1 S:$D(X)#2 DS("INT")=X Q - I $D(X),DINDEX("#")>1 S X(1)=X - S Y=-1 D L:$D(X),E - I Y'>0 K DUOUT D BAD^DIC1 Q - G 2 - ; -A ; Set variables needed for transforming date/set/ptr/var.ptr - S DICR(DICR+1,4)=% - D % K DF,DID,DINUM Q - ; -% ; Set variables up before doing lookup w/transformed value - I DIC(0)'["L" S DICR(DICR+1,8)=1 - E I '$$OKTOADD^DICM0(.DIFILEI,.DINDEX,.DIFINDER) S DICR(DICR+1,8)=1 - I $G(DINUM)]"" S DICR(DICR+1,10)=DINUM - I $D(DF) S DICR(DICR+1,9)=DF S:$G(DID)]"" DICR(DICR+1,9.1)=$G(DID(1))_U_DID -RS S DICR=DICR+1,DICR(DICR)=X,DICR(DICR,0)=DIC(0),DIC(0)=$TR(DIC(0),"A"),DIC(0)=$TR(DIC(0),"Q") Q - ; -D S:$G(DICR(DICR,10))]"" DINUM=DICR(DICR,10) - S (D,DF)=DICR(DICR,4) D - . N T S T=$P($G(DS),U,2) - . S DIC(0)=$TR(DIC(0),"M","") I T["V" S DIC(0)=$TR(DIC(0),"A","") - . I D="B",T'["D",'$G(DITRANX) S DIC(0)=DIC(0)_"s" - . I T["P"!(T["V")!(T["S") S DIC(0)=DIC(0)_"X" - . Q - I DICR(DICR,4)=DINDEX N I M I=DINDEX N DINDEX M DINDEX=I K I S DINDEX("START")=DINDEX - E N DINDEX D - . S (DINDEX,DINDEX("START"))=DICR(DICR,4),DINDEX("WAY")=1 - . D INDEX^DICUIX(.DIFILEI,DIFLAGS,.DINDEX,"",.DIVALUE) Q - I DINDEX("#")>1 S (DINDEX(1),DINDEX(1,"FROM"),DINDEX(1,"PART"))=$G(X) -RCR S:'$D(DIDA) DICRS=1 -DIC ; - I $D(DICR(DICR,8)) S DIC(0)=$TR(DIC(0),"L") - S Y=-1 I $D(X) D ;*159 WAS: I $D(X),$L(X)<31 D - . N DIVAL S (DIVAL,DIVAL(1))=X N X S (X,X(1))=DIVAL - . D RENUM^DIC1 K DIDA Q - S:DIC(0)["L" DICR(DICR-1,6)=1 K:$D(DICR(DICR,4)) DF -E S D="B" Q:'$G(DICR) ;**GFT - S %=DICR,X=DICR(%),DIC(0)=DICR(%,0),DICR=%-1 - S:$G(DICR(%,10))]"" DINUM=DICR(%,10) - S:$D(DICR(%,9)) (D,DF)=DICR(%,9) I $G(DICR(%,9.1))]"" S:$P(DICR(%,9.1),U)]"" DID(1)=$P(DICR(%,9.1),U) S DID=$P(DICR(%,9.1),U,2,999) - K DICRS,DICR(%) D DO^DIC1:'$D(DO(2)) Q - ; -NQ I $L(X)<14,X?.NP,+X=X,@("$D("_DIC_"X,0))") S Y=X D S^DIC3 - Q - ; -SOUNDEX I DIC(0)["E",'$D(DICRS) W " " D RS,SOU S DIC(0)=$TR(DIC(0),"L") D RCR Q:Y>0 - G R - ; -7 S Y=-1 N % S %=$S($D(DIC("S")):DIC("S"),1:1) - I $D(DS),'$D(DIC("S1")) D - . S DIC("S")=DS I '% S DIC("S")=DIC("S")_" X DIC(""S1"")",DIC("S1")=% - . I X]"" D - . . N DIVAL S (DIVAL,DIVAL(1))=X,DIVAL(0)=1 N X S (X,X(1))=DIVAL - . . N DINDEX,DIFILEI - . . S DIC(0)=$TR(DIC(0),"L") D F^DIC - . K DIC("S") S:$D(DIC("S1")) DIC("S")=DIC("S1") K DIC("S1") - D E Q - ; -SOU D SOU^DICM1 Q +DICM ;SFISC/GFT,XAK,TKW-MULTIPLE LOOKUP FOR FLDS WHICH MUST BE TRANSFORMED ;26JUN2006 + ;;22.0;VA FileMan;**4,20,31,40,149**;Mar 30, 1999;Build 2 + ;Per VHA Directive 10-93-142, this routine should not be modified. + I '$D(DICR(1)),DIC(0)'["T" N DICR S DICR=0 + I $A(X)=34,X?.E1"""" G N + I $G(^DD(+DO(2),0,"LOOK"))]"",^("LOOK")'="SOUNDEX" G @^("LOOK") + I DIC(0)["U" S DD=0 G W + I DIC(0)["T" G 2 +R N DIFLAGS S DIFLAGS="4l"_$P("M^",U,DIC(0)["M") + N DIFORCE D + . S DIFORCE=0 I DIC(0)'["M"!($D(DID)) S DIFORCE=1 + . S DIFORCE(0)=$S(DIC(0)'["M":DINDEX,$D(DID):DID,1:"*"),DIFORCE(1)=1 + F D 1 I DINDEX=""!(Y>0)!($G(DTOUT))!($G(DIROUT)) Q + G 2 + ; +1 N DS,%Y,DIV + I $G(DINDEX("IXFILE")) S Y=DINDEX(1,"FILE"),%Y=DINDEX(1,"FIELD") + E S Y=$O(^DD(+DO(2),0,"IX",DINDEX,0)) S:Y="" Y=-1 S %Y=+$O(^(Y,0)) + I Y=-1,DINDEX="B" S Y=+DO(2),%Y=.01 + S:Y="" Y=-1 S:%Y="" %Y=-1 + I $D(DICR(U,Y,%Y,DINDEX)) S Y=-1 + E I %Y=.01,DINDEX'="B",Y=+DO(2),$D(DICR(U,Y,%Y,"B")),$G(DINDEX(1,"TRANCODE"))="" S Y=-1 + I Y'<0 D + . S DS=$G(^DD(Y,%Y,0)) I DS="" S Y=-1 Q + . S %=DINDEX,DICR(U,Y,%Y,DINDEX)=0 + . I $D(^DD(Y,%Y,7)) D RS K DS X ^(7) Q + . I $G(DINDEX("IXTYPE"))="S" D A,SOU^DICM1,D Q:Y>0 S Y=-1 Q + . S DIX=Y,Y=$P(DS,U,2) + . S Y=$S(Y["P":"P",Y["D":"D",Y["S":"S",Y["V":"V",1:"") + . I Y]"" D A D:'Y ^DICM1,D Q:Y>0 S Y=-1 Q + . I $G(DINDEX(1,"TRANCODE"))]"" S Y="T" D A,^DICM1 N DITRANX S DITRANX=1 D D + . Q:Y>0 S Y=-1 Q + Q:Y>0!(DIC(0)["T") D + . K DIV M DIV=X S DIV(1)=X N X,Y + . D NXTINDX^DICF2(.DINDEX,.DIFORCE,.DIFILEI,DIFLAGS,.DIV,"*") Q + Q + ; +2 D D^DIC0 S %=D + G K:Y>0!($G(DIROUT)) + I X?.E1L.E,DIC(0)'["X" D G K:$G(DIROUT) + . D % N DIFILEI,DINDEX + . S DIC(0)=$TR(DIC(0),"L"),X=$$UP^DILIBF(X) S:$G(DILONGX) DICR(DICR,"ORG")=X + . D DIC Q + I Y'>0,X["," S DS="",DIX=$P(X,",",1) I DIC(0)'["X",$L(DIX)<31 D G K:$G(DIROUT) + . F %=2:1 S DD=$P(X,",",%) I DD'["""" D Q:DD="" + . . F Q:$A(DD)-32 S DD=$E(DD,2,999) + . . F Q:$A(DD,$L(DD))-32 S DD=$E(DD,1,$L(DD)-1) + . . I $L(DD)*2+$L(DS)>200!(DD="") S DD="" Q + . . S DS=DS_" I %?.E1P1"""_DD_""".E!(D'=""B""&(%?1"""_DD_""".E))" Q + . Q:DS="" S %=D + . D % S X=DIX N DILONGX + . S DS="S %=$P(^(0),U,1)"_DS,DIC(0)=DIC(0)_"D" D 7 Q + I Y'>0,$L(X)>30 D + . N DILONGX S DILONGX=1 + . S %=D D % S Y="DICR("_DICR_")",DICR(DICR,"ORG")=X + . S DS=$S(DIC(0)["X":"I DIVAL="_Y,1:"I '$L($P(DIVAL,"_Y_"))") + . S:DIC(0)["O"&(DIC(0)'["E") DS=DS_",'$L($P(DIVAL,"_Y_",2))" + . D 7 I Y>0!(X'?.E1L.E)!(DIC(0)["X") K DILONGX Q + . S %=D D % S (X,DICR(DICR,"ORG"))=$$UP^DILIBF(X) + . S Y="DICR("_DICR_",""ORG"")" + . S DS="I '$L($P(DIVAL,"_Y_"))" S:DIC(0)["O"&(DIC(0)'["E") DS=DS_",'$L($P(DIVAL,"_Y_",2))" + . D 7 K DILONGX Q + ; +K S DD=$D(DICR(DICR,6)) K:'DICR DICR + I Y>0 K DIC("W") D R^DIC2 Q + I $G(DTOUT)!($G(DIROUT)) Q +W I @("$O("_DIC_"""A[""))]""""") G NL:DIC(0)["N",DD + I DO(2)'["Z" S Y=0 D Q:Y>0!($G(DIROUT)) + . N DIOUT S DIOUT=0 F DS=1:1 S @("Y=$O("_DIC_"Y))") D Q:DIOUT + . . I 'Y S Y=-1,DIOUT=1 Q + . . W:DIC(0)["E"&(DS#20=0) ".." + . . I $D(@(DIC_Y_",0)")),$P(^(0),U)=X X:$D(DIC("S")) DIC("S") I S DIOUT=1 + . . I DIOUT S DIY="",DS=1 N DZ,DD D ADDKEY^DIC3,GOT^DIC2 + . . Q +NL I '$G(DICR) D NQ I $T D Q:Y>0!($G(DTOUT))!($G(DIROUT)) + . N:'$G(DIASKOK) DIASKOK S (DS,DIASKOK)=1 N DZ,DD + . D ADDKEY^DIC3,GOT^DIC2 Q +DD S Y=-1 I DD D BAD^DIC1 Q +L I DIC(0)["L" K DD G ^DICN +B D BAD^DIC1 Q + ; +N D RS S X=$E(X,2,$L(X)-1),%=D D + . I DINDEX("#")>1 S %Y=+$G(DINDEX(1,"FIELD")),DS=$G(^DD(+$G(DINDEX(1,"FILE")),%Y,0)) Q:DS]"" + . S DS=^DD(+DO(2),.01,0),%Y=.01 Q + F Y="P","D","S","V" I $P(DS,U,2)[Y K:Y="P" DO D ^DICM1 S:$D(X)#2 DS("INT")=X Q + I $D(X),DINDEX("#")>1 S X(1)=X + S Y=-1 D L:$D(X),E + I Y'>0 K DUOUT D BAD^DIC1 Q + G 2 + ; +A ; Set variables needed for transforming date/set/ptr/var.ptr + S DICR(DICR+1,4)=% + D % K DF,DID,DINUM Q + ; +% ; Set variables up before doing lookup w/transformed value + I DIC(0)'["L" S DICR(DICR+1,8)=1 + E I '$$OKTOADD^DICM0(.DIFILEI,.DINDEX,.DIFINDER) S DICR(DICR+1,8)=1 + I $G(DINUM)]"" S DICR(DICR+1,10)=DINUM + I $D(DF) S DICR(DICR+1,9)=DF S:$G(DID)]"" DICR(DICR+1,9.1)=$G(DID(1))_U_DID +RS S DICR=DICR+1,DICR(DICR)=X,DICR(DICR,0)=DIC(0),DIC(0)=$TR(DIC(0),"A"),DIC(0)=$TR(DIC(0),"Q") Q + ; +D S:$G(DICR(DICR,10))]"" DINUM=DICR(DICR,10) + S (D,DF)=DICR(DICR,4) D + . N T S T=$P($G(DS),U,2) + . S DIC(0)=$TR(DIC(0),"M","") I T["V" S DIC(0)=$TR(DIC(0),"A","") + . I D="B",T'["D",'$G(DITRANX) S DIC(0)=DIC(0)_"s" + . I T["P"!(T["V")!(T["S") S DIC(0)=DIC(0)_"X" + . Q + I DICR(DICR,4)=DINDEX N I M I=DINDEX N DINDEX M DINDEX=I K I S DINDEX("START")=DINDEX + E N DINDEX D + . S (DINDEX,DINDEX("START"))=DICR(DICR,4),DINDEX("WAY")=1 + . D INDEX^DICUIX(.DIFILEI,DIFLAGS,.DINDEX,"",.DIVALUE) Q + I DINDEX("#")>1 S (DINDEX(1),DINDEX(1,"FROM"),DINDEX(1,"PART"))=$G(X) +RCR S:'$D(DIDA) DICRS=1 +DIC ; + I $D(DICR(DICR,8)) S DIC(0)=$TR(DIC(0),"L") + S Y=-1 I $D(X),$L(X)<31 D + . N DIVAL S (DIVAL,DIVAL(1))=X N X S (X,X(1))=DIVAL + . D RENUM^DIC1 K DIDA Q + S:DIC(0)["L" DICR(DICR-1,6)=1 K:$D(DICR(DICR,4)) DF +E S D="B",%=DICR,X=DICR(%),DIC(0)=DICR(%,0),DICR=%-1 + S:$G(DICR(%,10))]"" DINUM=DICR(%,10) + S:$D(DICR(%,9)) (D,DF)=DICR(%,9) I $G(DICR(%,9.1))]"" S:$P(DICR(%,9.1),U)]"" DID(1)=$P(DICR(%,9.1),U) S DID=$P(DICR(%,9.1),U,2,999) + K DICRS,DICR(%) D DO^DIC1:'$D(DO) Q + ; +NQ I $L(X)<14,X?.NP,+X=X,@("$D("_DIC_"X,0))") S Y=X D S^DIC3 + Q + ; +SOUNDEX I DIC(0)["E",'$D(DICRS) W " " D RS,SOU S DIC(0)=$TR(DIC(0),"L") D RCR Q:Y>0 + G R + ; +7 S Y=-1 N % S %=$S($D(DIC("S")):DIC("S"),1:1) + I $D(DS),'$D(DIC("S1")) D + . S DIC("S")=DS I '% S DIC("S")=DIC("S")_" X DIC(""S1"")",DIC("S1")=% + . I X]"" D + . . N DIVAL S (DIVAL,DIVAL(1))=X,DIVAL(0)=1 N X S (X,X(1))=DIVAL + . . N DINDEX,DIFILEI + . . S DIC(0)=$TR(DIC(0),"L") D F^DIC + . K DIC("S") S:$D(DIC("S1")) DIC("S")=DIC("S1") K DIC("S1") + D E Q + ; +SOU D SOU^DICM1 Q diff --git a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICOMP0.m b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICOMP0.m index e0c467b6..25d30073 100644 --- a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICOMP0.m +++ b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICOMP0.m @@ -1,62 +1,61 @@ -DICOMP0 ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;5NOV2007 - ;;22.0;VA FileMan;**6,76,114,144,152**;;Build 10 - ;Per VHA Directive 2004-038, this routine should not be modified. - N DICOMPI -SETFUNC I DPS,$D(DPS(DPS,"SET")),'$D(W(DPS)) S T="""",D=$P(X,T)_$P(X,T,2) G BAD:$L(D)+2\5-1!(D'?.UN)!(D?1"D".E)!(DUZ(0)'="@") S X=T_D_T,DICOMPX(D)=D,Y=0 Q -LIT I X?1"""".E1"""" S Y=0,%=$E(X,2,$L(X)-1) K:%[""" X "!(%[""" D @") Y S X=""""_$$CONVQQ^DILIBF(%)_"""" Q -L S T=DLV,DICN=X -TRY G M:'$D(J(T))!'$D(I(T)),M:+J(T)'=J(T),M:$G(^DD(J(T),.01,0))="",UP:$P(^(0),U,2)["W" S DIC="^DD("_J(T)_",",DG=$O(^DD(J(T),0,"NM",0))_" " - S DIC("S")=$S(W="["!($E(I,M,M+1)="'[")!$D(DICMX):"I ",1:"S %=$P(^(0),U,2) I '%,%'[""m"",")_"$$SCREEN^DICOMP0" - D DICS^DICOMPY:DUZ(0)'="@" -R I X?1"#"1.NP S X=$E(X,2,99) D ^DIC G:Y>0 A:DLV,X S X="#"_X - D ^DIC G A:Y>0 -N I $P(X,DG)="",X=DICN S X=$P(X,DG,2,9) G R -NUMBER I X="NUMBER" S Y=.001,Y(0)=0 G D -UP S T=T-1,X=DICN G M:T<0,TRY:$D(J(T)) F T=T-99:1 G TRY:'$D(J(T+1)) - ; -A F D=M:1:$L(I)+1 Q:$F(X,$E(I,1,D))-1-D S W=$E(I,D+1) - I DICOMP["?",DICN'="#.01",$P(Y,U,2)'=DICN,DG_$P(Y,U,2)'=DICN D G BAD:%<0,N:%-1 - .W !?3,"By '"_DICN_"', do you mean "_DG_"'"_$P(Y,U,2)_"'" S %=1 D YN^DICN - E S DICO("BACK",T)=+Y - S M=D -X I $D(DICOMPX)#2 S %Y=J(T)_U_+Y_$E(";",1,$L(DICOMPX)) S:";"_DICOMPX_";"'[(";"_%Y) DICOMPX=%Y_DICOMPX -D S D=$P(Y(0),"^",2),%=T\100*100,DICN=+Y,DICOMPI=W=")"&$D(DPS($$NEST^DICOMP,"INTERNAL")) D DATE:D["D"&'DICOMPI - I D["m"!D D MUL^DICOMPZ(D) Q - I $D(DICOMPX(1,J(T),+Y)) S X=DICOMPX(1,J(T),+Y) G O - I D["C" S:'$D(DG(%,T,+Y)) DG(%)=DG(%)+1,DG(%,T,+Y)=DG(%) S X=DQI_DG(%,T,+Y)_")" Q:D'["p"!DICOMPI S DICN=+$P(D,"p",2),%Y=$G(^DIC(DICN,0,"GL")) Q:%Y="" G POINT -GET I DICOMP["G",T#100=0 S X="$$GET^DDSVAL("_J(T)_",D0,"_+Y_",,"""_$E("E",'DICOMPI)_""")" G O - D G^DICOMPY -O Q:DICOMPI - S T=J(T) -S ; - S %=DLV0,DG=W=":"&'$D(DPS(DPS,"$S")) -OUT I D["O"&(D'["P"!'DG)!(D["V"&'$D(DPS(DPS,"FILE"))) D Q - .S X="$$EXTERNAL^DIDU("_T_","_DICN_","""","_X_")",DICO("DIERR")=1 -SET I D["S" S DG(%)=DG(%)+1,DG(%,DG(%))="$C(59)_$P($G(^DD("_T_","_DICN_",0)),U,3)",X="$P($P("_DQI_DG(%)_"),$C(59)_"_X_"_"":"",2),$C(59))" - Q:D'["P" S %Y=U_$P(Y(0),U,3),DICN=+$P(@(%Y_"0)"),U,2) -POINT I W=":" G MR:'$$OKFILE^DICOMPX(DICN,DICOMP) - I W'=":" S D=$P($G(^DD(DICN,.01,0)),U,2) I D'["V",D'["S",D'["P" D DATE:D["D" S X="$P($G("_%Y_"+"_X_",0)),U)" Q -P G P^DICOMPX - ; -M S T=$F(X," IN ") I T S X=$E(X,1,T-5),W=":",M=T-4,I=X_W_$E(I,T,999),T=$F(I," FILE",M) S:T&$F(DPUNC,$E(I,T)) I=$E(I,1,T-6)_$E(I,T,999) G DICOMP0 - G MR:$L(X)>30 S DICF=X,T=$O(^DD("FUNC","B",X,0)) - G LITDATE:'$D(^DD("FUNC",+T,3)),LITDATE:^(3) - I $G(^(1))'="" D 2^DICOMP S Y(0)=0,K=K+1,K(K)=X D DATE:$G(^(2))?1"D".E,DPS^DICOMPW Q - G MR:X'?1"PRIOR"4.U S Y=X,X="$P($$LAST^DIAUTL("_J(DLV0)_",D0,""*""),U)" I Y["USER",$D(^VA(200)) S $E(X,$L(X))=",2)",DICN=200,%Y="^VA(200," G POINT - G DATE - ; -LITDATE S %DT="T" I $L(X)>2 D ^%DT I Y>0 S X=Y,Y(0)=0 D DATE Q ;may be a literal date -BACKPNT S T=$O(^DIC("B",X)) I T]"",$P(T,X)=""!$D(^(X)),$D(J(0)) S T=DLV0 D ^DICOMPV I D>0 Q ;try backwards-pointer TOOK OFF CHECK FOR DICOMPW VARIABLE 3/28/2000 -MR I M'>$L(I),+X'=X D MR^DICOMP G L:X]"" -BAD K Y Q - ; -DATE ; - S DATE(K+1)=1 Q - ; -SCREEN() ;Screen out certain fields as we process an atom - I $D(DICO("BACK"))=11,$G(DICO("BACK",T))=Y Q 0 - I Y=DA,DICO(1)=T Q 0 ;Computed field cannot refer to itself! - I $P(^(0),U,2) Q '$G(DBOOL) ;A multiple cannot be manipulated as a Boolean! - I $P(^(0),U,2)'["P" Q 1 - N P S P=$P(^(0),U,3) I P]"",$D(@(U_P_"0)")) Q 1 ;Only allow a pointer that points to an existing file! - Q 0 +DICOMP0 ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;2DEC2006 + ;;22.0;VA FileMan;**6,76,114,144**;;Build 5 + ;Per VHA Directive 2004-038, this routine should not be modified. + N DICOMPI +SETFUNC I DPS,$D(DPS(DPS,"SET")),'$D(W(DPS)) S T="""",D=$P(X,T)_$P(X,T,2) G BAD:$L(D)+2\5-1!(D'?.UN)!(D?1"D".E)!(DUZ(0)'="@") S X=T_D_T,DICOMPX(D)=D,Y=0 Q +LIT I X?1"""".E1"""" S Y=0,%=$E(X,2,$L(X)-1) K:%[""" X "!(%[""" D @") Y S X=""""_$$CONVQQ^DILIBF(%)_"""" Q +L S T=DLV,DICN=X +TRY G M:'$D(J(T))!'$D(I(T)),M:+J(T)'=J(T),M:$D(^DD(J(T)))<9 S DIC="^DD("_J(T)_",",DG=$O(^DD(J(T),0,"NM",0))_" " + S DIC("S")=$S(W="["!($E(I,M,M+1)="'[")!$D(DICMX):"I ",1:"S %=$P(^(0),U,2) I '%,%'[""m"",")_"$$SCREEN^DICOMP0" + D DICS^DICOMPY:DUZ(0)'="@" +R I X?1"#"1.NP S X=$E(X,2,99) D ^DIC G:Y>0 A:DLV,X S X="#"_X + D ^DIC G A:Y>0 +N I $P(X,DG)="",X=DICN S X=$P(X,DG,2,9) G R +NUMBER I X="NUMBER" S Y=.001,Y(0)=0 G D + S T=T-1,X=DICN G M:T<0,TRY:$D(J(T)) F T=T-99:1 G TRY:'$D(J(T+1)) + ; +A F D=M:1:$L(I)+1 Q:$F(X,$E(I,1,D))-1-D S W=$E(I,D+1) + I DICOMP["?",DICN'="#.01",$P(Y,U,2)'=DICN,DG_$P(Y,U,2)'=DICN D G BAD:%<0,N:%-1 + .W !?3,"By '"_DICN_"', do you mean "_DG_"'"_$P(Y,U,2)_"'" S %=1 D YN^DICN + E S DICO("BACK",T)=+Y + S M=D +X I $D(DICOMPX)#2 S %Y=J(T)_U_+Y_$E(";",1,$L(DICOMPX)) S:";"_DICOMPX_";"'[(";"_%Y) DICOMPX=%Y_DICOMPX +D S D=$P(Y(0),"^",2),%=T\100*100,DICN=+Y,DICOMPI=W=")"&$D(DPS($$NEST^DICOMP,"INTERNAL")) D DATE:D["D"&'DICOMPI + I D["m"!D D MUL^DICOMPZ(D) Q + I $D(DICOMPX(1,J(T),+Y)) S X=DICOMPX(1,J(T),+Y) G O + I D["C" S:'$D(DG(%,T,+Y)) DG(%)=DG(%)+1,DG(%,T,+Y)=DG(%) S X=DQI_DG(%,T,+Y)_")" Q:D'["p"!DICOMPI S DICN=+$P(D,"p",2),%Y=$G(^DIC(DICN,0,"GL")) Q:%Y="" G POINT +GET I DICOMP["G",T#100=0 S X="$$GET^DDSVAL("_J(T)_",D0,"_+Y_",,"""_$E("E",'DICOMPI)_""")" G O + D G^DICOMPY +O Q:DICOMPI + S T=J(T) +S ; + S %=DLV0,DG=W=":"&'$D(DPS(DPS,"$S")) + I D["O"&(D'["P"!'DG)!(D["V"&'$D(DPS(DPS,"FILE"))) D DIMP^DICOMPZ("N C S Y="_X_",C="""_D_""" D:$D(^DD("_T_","_DICN_",0)) Y^DIQ") S X=X_" S X=Y" Q +SET I D["S" S DG(%)=DG(%)+1,DG(%,DG(%))="$C(59)_$P($G(^DD("_T_","_DICN_",0)),U,3)",X="$P($P("_DQI_DG(%)_"),$C(59)_"_X_"_"":"",2),$C(59))" + Q:D'["P" S %Y=U_$P(Y(0),U,3),DICN=+$P(@(%Y_"0)"),U,2) +POINT I W=":" G MR:'$$OKFILE^DICOMPX(DICN,DICOMP) + I W'=":" S D=$P($G(^DD(DICN,.01,0)),U,2) I D'["V",D'["S",D'["P" D DATE:D["D" S X="$P($G("_%Y_"+"_X_",0)),U)" Q +P G P^DICOMPX + ; +M S T=$F(X," IN ") I T S X=$E(X,1,T-5),W=":",M=T-4,I=X_W_$E(I,T,999),T=$F(I," FILE",M) S:T&$F(DPUNC,$E(I,T)) I=$E(I,1,T-6)_$E(I,T,999) G DICOMP0 + G MR:$L(X)>30 S DICF=X,T=$O(^DD("FUNC","B",X,0)) + G LITDATE:'$D(^DD("FUNC",+T,3)),LITDATE:^(3) + I $G(^(1))'="" D 2^DICOMP S Y(0)=0,K=K+1,K(K)=X D DATE:$G(^(2))?1"D".E,DPS^DICOMPW Q + G MR:X'?1"PRIOR"4.U S Y=X,X="$P($$LAST^DIAUTL("_J(DLV0)_",D0,""*""),U)" I Y["USER",$D(^VA(200)) S $E(X,$L(X))=",2)",DICN=200,%Y="^VA(200," G POINT + G DATE + ; +LITDATE S %DT="T" I $L(X)>2 D ^%DT I Y>0 S X=Y,Y(0)=0 D DATE Q ;may be a literal date +BACKPNT S T=$O(^DIC("B",X)) I T]"",$P(T,X)=""!$D(^(X)),$D(J(0)) S T=DLV0 D ^DICOMPV I D>0 Q ;try backwards-pointer TOOK OFF CHECK FOR DICOMPW VARIABLE 3/28/2000 +MR I M'>$L(I),+X'=X D MR^DICOMP G L:X]"" +BAD K Y Q + ; +DATE ; + S DATE(K+1)=1 Q + ; +SCREEN() ;Screen out certain fields as we process an atom + I $D(DICO("BACK"))=11,$G(DICO("BACK",T))=Y Q 0 + I Y=DA,DICO(1)=T Q 0 ;Computed field cannot refer to itself! + I $P(^(0),U,2) Q '$G(DBOOL) ;A multiple cannot be manipulated as a Boolean! + I $P(^(0),U,2)'["P" Q 1 + N P S P=$P(^(0),U,3) I P]"",$D(@(U_P_"0)")) Q 1 ;Only allow a pointer that points to an existing file! + Q 0 diff --git a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICOMP1.m b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICOMP1.m index 44e1baae..e4bc11de 100644 --- a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICOMP1.m +++ b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICOMP1.m @@ -1,79 +1,79 @@ -DICOMP1 ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;19JUNE2007 - ;;22.0;VA FileMan;**6,44,76,152**;Mar 30, 1999;Build 10 - ;Per VHA Directive 2004-038, this routine should not be modified. - F Q:'$D(DPS(DPS,"ST")) D DPS^DICOMPW S K=K+1,K(K)=X - G 0:DPS -INIT S T=99,DLV0=0,X="",K=1 D ST ;ST will build code to get top=level values -NN I $D(K(K,1)) S DLV0=K(K,1) K K(K,1) D ST ;'1' flags a change in levels - I $D(K(K,9)) F %=1:1:K K DATE(%) - G S:$D(K(K))[0,K1:K(K)="" - I " "[$E(K(K)) D - .Q:X="" - .I K(K)?1" S ".E D Q -AS ..D EX I $L(K(K))+$L(X)>160 D M Q - ..S K(K)=$E(K(K),4,999),X=X_"," - .D EX:W,M:$L(X)+$L(K(K))>180 - E I 'W D M:$L(X)+$L(K(K))>165 S X=X_" S X=",W=6 - D:K(K)?1P -P .I "\/"[K(K),$G(K(K+1))'?.NP S K=K+1,K(K)=",X=$S("_K(K)_":X"_K(K-1)_K(K)_",1:""*******"")" - .I $L(X)>150,$F(DPUNC,K(K))>3 D M,SX - G A:'$D(DATE(K)) -DATE I $G(K(K-1))="_",X?.E1"_" S X=$E(X,1,$L(X)-1) D EXTRASB S Y=$$DGI^DICOMP,X=X_" S "_Y_"=X,X="_K(K)_" S Y=X X ^DD(""DD"") S X="_Y_"_Y",K(K)="" G A - S Y=1 I $G(K(K-1))="+" S X=X_"0,X2=X,X1="_K(K) G DTC -2 G A:$D(K(K+2))[0 - K DATE(K) - I $D(DATE(K+2))[0,$F("+-",K(K+1))>1 S X=X_K(K)_",X1=X,X2="_K(K+1)_K(K+2),DATE(K+2)=1 - E G A:K(K+1)'="-" K DATE(K+2) S X=X_K(K)_",X1=X,X2="_K(K+2),Y=0 - S K=K+2 -DTC S K=K+1,X=X_",X="""" D"_$P(":X2 ^ C",U,Y+1)_"^%DTC:X1" G S:'$D(K(K)) D SX G NN:'Y S K=K-1,K(K)="" G 2 - ; -A S W='$D(K(K,2)),X=X_K(K) -K1 S K=K+1 G NN:$D(K(K))#2 -S S I="" F S I=$O(M(I)),W=0 Q:I="" D M:$L(X)>235 S K=$O(M(I,"")),X=X_" S D"_I_"="_$S(DA:DQI_(K+80),1:"I("_K_",0")_")" - S I=-1 D SS S:X?.E1" S X=X" X=$E(X,1,$L(X)-6) I X'?1"S X="1N.NP!(DICOMP["Z") G Q -0 ;NO GOT! Come here when parsing fails - K X,DIM,DATE I DUZ(0)="@",DICOMP'["X" D - .Q:DICO'[" " - .S DIM=1 I $L(DICO," ")=2 F Y="OPEN","CLOSE","BREAK","USE" D I '$D(DIM) Q - ..I $E(Y)=$P(DICO," ")!(Y=$P(DICO," ")) K DIM - .I $D(DIM) S X=DICO D ^DIM - S DICOMP="",DLV=DICO(1) -Q I DICOMP'["S" S K=DICO(1) F S K=$O(I(K)) Q:K="" K I(K),J(K) - I $D(X) S:$D(DICO("DIERR")) X="N DIERR "_X I $G(DICOMPQI) S X="N Y "_X -Y K Y I $D(DICO("RCR")) S Y=DICO("RCR") - E S Y=DLV_$E("W",$D(DPS("W")))_$S($G(DBOOL)=1:"B",$D(DATE)>9:"D",1:"")_$E("X",$D(DIM))_$E("L",$D(DICO(2))) - S Y=Y_DIMW - I $D(DICO("PT")) S Y=Y_"p"_DICO("PT") - K K,DLV,DICOMP,DICMX Q - ; -ST S W=0,DG="" F S DG=$O(DG(DLV0,DG)),Y=$P(DG,U,2) Q:DG="" D - .I Y]"" S:+Y'=Y Y=""""_Y_"""" S I=DQI_DG(DLV0,DG)_")=$S($D(^(" D:T-DG!(DG180 S X=X_I - .Q:$D(DG(DLV0,DG))[0 - .S I=DG(DLV0,DG) I I?.N S I=$S(DA:DQI_(DLV0+I+80),1:"I("_(DLV0+I)_",0")_")=$G(D"_I_")" - .E S I=DQI_+DG_")="_I - .K DG(DLV0,DG) G OV:DG?.N1A -VP .I $G(DICV)["V" S I=I_"_$C(59)_"""_$E(I(0),2,99)_"""" -OV .I $L(I)+$L(X)>180 D M - .S:'W X=X_" S " S X=X_I_",",W=2 - D EX S W=0 Q - ; -M D SS,EX -EXTRASB D DIMP^DICOMPZ(X) S W=0 Q - ; -SS Q:$A(X)-32 S X=$E(X,2,999) G SS - ; -EX S X=$E(X,1,$L(X)-W+1) Q - ; -SX S X=X_" S X=X",W=1 - Q +DICOMP1 ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;12:45 PM 9 Sep 2002 + ;;22.0;VA FileMan;**6,44,76**;Mar 30, 1999 + ;Per VHA Directive 10-93-142, this routine should not be modified. + F Q:'$D(DPS(DPS,"ST")) D DPS^DICOMPW S K=K+1,K(K)=X + G 0:DPS +INIT S T=99,DLV0=0,X="",K=1 D ST ;ST will build code to get top=level values +NN I $D(K(K,1)) S DLV0=K(K,1) K K(K,1) D ST ;'1' flags a change in levels + I $D(K(K,9)) F %=1:1:K K DATE(%) + G S:$D(K(K))[0,K1:K(K)="" + I " "[$E(K(K)) D + .Q:X="" + .I K(K)?1" S ".E D Q +AS ..D EX I $L(K(K))+$L(X)>160 D M Q + ..S K(K)=$E(K(K),4,999),X=X_"," + .D EX:W,M:$L(X)+$L(K(K))>180 + E I 'W D M:$L(X)+$L(K(K))>165 S X=X_" S X=",W=6 + D:K(K)?1P +P .I "\/"[K(K),$G(K(K+1))'?.NP S K=K+1,K(K)=",X=$S("_K(K)_":X"_K(K-1)_K(K)_",1:""*******"")" + .I $L(X)>150,$F(DPUNC,K(K))>3 D M,SX + G A:'$D(DATE(K)) +DATE I $G(K(K-1))="_",X?.E1"_" S X=$E(X,1,$L(X)-1) D EXTRASB S Y=$$DGI^DICOMP,X=X_" S "_Y_"=X,X="_K(K)_" S Y=X X ^DD(""DD"") S X="_Y_"_Y",K(K)="" G A + S Y=1 I $G(K(K-1))="+" S X=X_"0,X2=X,X1="_K(K) G DTC +2 G A:$D(K(K+2))[0 + K DATE(K) + I $D(DATE(K+2))[0,$F("+-",K(K+1))>1 S X=X_K(K)_",X1=X,X2="_K(K+1)_K(K+2),DATE(K+2)=1 + E G A:K(K+1)'="-" K DATE(K+2) S X=X_K(K)_",X1=X,X2="_K(K+2),Y=0 + S K=K+2 +DTC S K=K+1,X=X_",X="""" D"_$P(":X2 ^ C",U,Y+1)_"^%DTC:X1" G S:'$D(K(K)) D SX G NN:'Y S K=K-1,K(K)="" G 2 + ; +A S W='$D(K(K,2)),X=X_K(K) +K1 S K=K+1 G NN:$D(K(K))#2 +S S I="" F S I=$O(M(I)),W=0 Q:I="" D M:$L(X)>235 S K=$O(M(I,"")),X=X_" S D"_I_"="_$S(DA:DQI_(K+80),1:"I("_K_",0")_")" + S I=-1 D SS S:X?.E1" S X=X" X=$E(X,1,$L(X)-6) I X'?1"S X="1N.NP!(DICOMP["Z") G Q +0 ;NO GOT! Come here when parsing fails + K X,DIM,DATE I DUZ(0)="@",DICOMP'["X" D + .Q:DICO'[" " + .S DIM=1 I $L(DICO," ")=2 F Y="OPEN","CLOSE","BREAK","USE" D I '$D(DIM) Q + ..I $E(Y)=$P(DICO," ")!(Y=$P(DICO," ")) K DIM + .I $D(DIM) S X=DICO D ^DIM + S DICOMP="",DLV=DICO(1) +Q I DICOMP'["S" S K=DICO(1) F S K=$O(I(K)) Q:K="" K I(K),J(K) + I $G(DICOMPQI),$D(X) S X="N Y "_X +Y K Y I $D(DICO("RCR")) S Y=DICO("RCR") + E S Y=DLV_$E("W",$D(DPS("W")))_$S($G(DBOOL)=1:"B",$D(DATE)>9:"D",1:"")_$E("X",$D(DIM))_$E("L",$D(DICO(2))) + S Y=Y_DIMW + I $D(DICO("PT")) S Y=Y_"p"_DICO("PT") + K K,DLV,DICOMP,DICMX Q + ; +ST S W=0,DG="" F S DG=$O(DG(DLV0,DG)),Y=$P(DG,U,2) Q:DG="" D + .I Y]"" S:+Y'=Y Y=""""_Y_"""" S I=DQI_DG(DLV0,DG)_")=$S($D(^(" D:T-DG!(DG180 S X=X_I + .Q:$D(DG(DLV0,DG))[0 + .S I=DG(DLV0,DG) I I?.N S I=$S(DA:DQI_(DLV0+I+80),1:"I("_(DLV0+I)_",0")_")=$G(D"_I_")" + .E S I=DQI_+DG_")="_I + .K DG(DLV0,DG) G OV:DG?.N1A +VP .I $G(DICV)["V" S I=I_"_$C(59)_"""_$E(I(0),2,99)_"""" +OV .I $L(I)+$L(X)>180 D M + .S:'W X=X_" S " S X=X_I_",",W=2 + D EX S W=0 Q + ; +M D SS,EX +EXTRASB D DIMP^DICOMPZ(X) S W=0 Q + ; +SS Q:$A(X)-32 S X=$E(X,2,999) G SS + ; +EX S X=$E(X,1,$L(X)-W+1) Q + ; +SX S X=X_" S X=X",W=1 + Q diff --git a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICOMPZ.m b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICOMPZ.m index 045c8083..5e51dcbb 100644 --- a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICOMPZ.m +++ b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICOMPZ.m @@ -1,107 +1,106 @@ -DICOMPZ ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;9APR2007 - ;;22.0;VA FileMan;**6,76,114,152**;Mar 30, 1999;Build 10 - ;Per VHA Directive 2004-038, this routine should not be modified. - ; -PRIOR ;from DICOMP -- PRIOR.. Functions get archived values - N DIC,DICOMPSP,DICOMPXE,DICOPS - S X=$E(X,6,99),DICOMPSP=$E("D",X="DATE"),DICOMPXE="D "_X_"^DIAUTL(",W=$F(I,")",M) S:X="USER"&$D(^VA(200)) DICO("PT")=200,DICOMPSP="p200" I 'W!'$D(DICMX)!'$D(J(0)) K Y Q - S X=$E(I,M+1,W-2),M=W,W=$E(I,M) S:X?1"#"1.NP X=$E(X,2,999) - S DIC="^DD("_J(DLV)_",",DIC(0)="",DIC("S")="I '$P(^(0),U,2),$P(^(0),U,2)'[""C""" D DICS^DICOMPY,^DIC K DIC I Y<0 K Y Q ;Find Field that is the argument of PRIOR function - S DICOMPXE=DICOMPXE_+J(DLV)_","_+Y_")" - S DICOPS="><[]=",DIMW="m" - G INSERT - ; -BACKPNT ;from DICOMPV -- Backwards Pointer - N DICOPS,D - S DICOPS="><[]=" - G COLON - ; -MUL(DICOMPSP) ;DICOMPSP is the SPECIFIER of the Field we have encountered - N DICOXR,DICOMPXE,DICOPS S DICOPS="><][=" - I DICOMPSP S X=$P(^DD(+DICOMPSP,.01,0),U,2) G WP:X["W" D S DLV=DLV+1,I(DLV)=""""_$P($P(Y(0),U,4),";")_"""",J(DLV)=+DICOMPSP D X G FOR - .I T0 I $D(^("_DICOMPXE ;We will go thru the muliple by ien - E D DIMP(D_"""B"",DICOB,D)) Q:D'>0 I $D("_DICOR_DICOMPXE) S D="N DICOB S DICOB="""" F S DICOB=$O("_DICOR_"""B"",DICOB)) Q:DICOB="""" "_X_" Q:'$D(D)" ;We will go thru the multiple using the B X-ref - D DIMP($$I(Y)_D) - S (T,DG(DLV0))=DG(DLV0)+1,K(K+1,2)=1,K(K+2,1)=DLV0,DG(DLV0,T)=Y,M(Y,DLV0+Y)=T - S X=X_":D"_(Y-1)_">0" -DICOXR S X=X_" S X="_$S(DIMW["m"!'$D(DICOXR):"""""",1:DICOXR) - Q - ; -CONTAINS N DICON - S DICON=W="'",%=$E(I,M+DICON) I %=""!(W=")") S Y=0 Q - I DICOPS[% S DICOPS=% D R($E(I,M+DICON+1,999)) Q:'$D(Y) D Q - .S DICOXR=$$DGI^DICOMP - .D DIMP("S Y=X "_X_" I Y"_DICOPS_"X S "_DICOXR_"="_'DICON_" K D") S DICMX=X - .S K(K+1)=" S "_DICOXR_"="_DICON,K=K+1 - .S DBOOL=1,DIMW="" -COLON I W'=":" Q:W="" S DICOMPX("X")="X",I="X"_$E(I,M,999),M=0 I DICOPS="[" K Y Q - N DQI D R($E(I,M+1,999)) Q:'$D(Y) I '$D(DICO("RCR")) S DICO("RCR")=Y - I Y#100=0 S W=$G(J(+Y)) I W S DICO("PT")=W - S DICMX=X_" "_$G(DICMX) Q ;The 'X" code that we got back from RCR becomes what we eXecute for every multiple! - ; -R(DICORM) N DICOLEFT,DICOX S DICOLEFT="",DICOX=0 F %=1:1 S W=$E(DICORM,%) Q:W="" S:W="(" DICOX=DICOX+1 I W=")" S DICOX=DICOX-1 I DICOX<0 S DICOLEFT=$E(DICORM,%,999),DICORM=$E(DICORM,1,%-1) - S DICOX=$G(X) D RCR(DICORM) - S W="",M=0,I=DICOLEFT S:'$D(Y) I=DICORM,X=DICOX Q - ; -RCR(W) ;Tricky and important! What we get from this recursion will be inserted into the larger expression. - N D - S:+W=W W=""""_W_"""" S D="ZXM"_$$DIMC_" S"_DICOMP D ;Don't allow MUMPS. Remember where to start more nodes in X array. Allow simple numeric. - .N X,DICOMP,DLV,DICMXSV,K - .S X=W,DICOMP=D I $D(DICMX) S DICMXSV=DICMX -DQI .I $D(DQI) S %=DQI N DQI S DQI=%_$$DIMC_"," - .D EN1^DICOMP ;Here is the recursion! I & J, the context, will be preserved by this entry point - .I '$D(X) K Y Q - .K W M W=X - .I Y["m" K DICMXSV - .I $D(DICMXSV) S DICMX=DICMXSV - I $D(Y) M X=W D DIMP(X),DATE^DICOMP0:Y["D" ;Remember if it's a DATE - Q - ; -DIMP(D) ; - N DIM - S DIM=$$DIMC,DIM=DIM+$S(DIM<9.8:.1,1:.01) - S X(DIM)=D,X=" X "_$$DA_DIM_")" Q - ; -DA() Q $S(DA:"^DD("_A_","_DA_",",1:DA) - ; -DIMC() N DIM - S DIM=$O(X(99),-1) I 'DIM S DIM=+$P(DICOMP,"M",2) I 'DIM S DIM=9.1 - Q DIM - ; -X ; - S X="S X=$P(^(0),U)"_$S(X["D"&'$D(DPS($$NEST^DICOMP,"INTERNAL")):",Y=X X ^DD(""DD"") S X=Y",X["P":" S:$D(^"_$P(^(0),U,3)_"+X,0)) X=$P(^(0),U)",X["S":",Y=$F(^DD("_+D_",.01,0),X_$C(58)) S:Y X=$P($E(^(0),Y,999),$C(59),1)",1:""),DIMW="m" Q - ; -I(LEV) N S - S S=DLV0+LEV I DICOMP'["I"!'$D(I(S)) Q "" - Q "S I("_S_")="""_$$CONVQQ^DILIBF(I(S))_""",J("_S_")="_J(S)_" " - ; -REF(T) ; - N L,D,X,V - F L=T\100*100:1:T S D=I(L) S X=$G(X)_D_$E(",",$D(X))_$S(L0 I $D(^("_DICOMPXE ;We will go thru the muliple by ien + E D DIMP(D_"""B"",DICOB,D)) Q:D'>0 I $D("_DICOR_DICOMPXE) S D="N DICOB S DICOB="""" F S DICOB=$O("_DICOR_"""B"",DICOB)) Q:DICOB="""" "_X_" Q:'$D(D)" ;We will go thru the multiple using the B X-ref + D DIMP($$I(Y)_D) + S (T,DG(DLV0))=DG(DLV0)+1,K(K+1,2)=1,K(K+2,1)=DLV0,DG(DLV0,T)=Y,M(Y,DLV0+Y)=T + S X=X_":D"_(Y-1)_">0" +DICOXR S X=X_" S X="_$S(DIMW["m"!'$D(DICOXR):"""""",1:DICOXR) + Q + ; +CONTAINS N DICON + S DICON=W="'",%=$E(I,M+DICON) I %="" S Y=0 Q + I DICOPS[% S DICOPS=% D R($E(I,M+DICON+1,999)) Q:'$D(Y) D Q + .S DICOXR=$$DGI^DICOMP + .D DIMP("S Y=X "_X_" I Y"_DICOPS_"X S "_DICOXR_"="_'DICON_" K D") S DICMX=X + .S K(K+1)=" S "_DICOXR_"="_DICON,K=K+1 + .S DBOOL=1,DIMW="" +COLON I W'=":" Q:W="" S DICOMPX("X")="X",I="X"_$E(I,M,999),M=0 I DICOPS="[" K Y Q + N DQI D R($E(I,M+1,999)) Q:'$D(Y) I '$D(DICO("RCR")) S DICO("RCR")=Y + I Y#100=0 S W=$G(J(+Y)) I W S DICO("PT")=W + S DICMX=X_" "_$G(DICMX) Q ;The 'X" code that we got back from RCR becomes what we eXecute for every multiple! + ; +R(DICORM) N DICOLEFT,DICOX S DICOLEFT="",DICOX=0 F %=1:1 S W=$E(DICORM,%) Q:W="" S:W="(" DICOX=DICOX+1 I W=")" S DICOX=DICOX-1 I DICOX<0 S DICOLEFT=$E(DICORM,%,999),DICORM=$E(DICORM,1,%-1) + S DICOX=$G(X) D RCR(DICORM) + S W="",M=0,I=DICOLEFT S:'$D(Y) I=DICORM,X=DICOX Q + ; +RCR(W) ;Tricky and important! What we get from this recursion will be inserted into the larger expression. + N D + S:+W=W W=""""_W_"""" S D="ZXM"_$$DIMC_" S"_DICOMP D ;Don't allow MUMPS. Remember where to start more nodes in X array. Allow simple numeric. + .N X,DICOMP,DLV,DICMXSV,K + .S X=W,DICOMP=D I $D(DICMX) S DICMXSV=DICMX +DQI .I $D(DQI) S %=DQI N DQI S DQI=%_$$DIMC_"," + .D EN1^DICOMP ;Here is the recursion! I & J, the context, will be preserved by this entry point + .I '$D(X) K Y Q + .K W M W=X + .I Y["m" K DICMXSV + .I $D(DICMXSV) S DICMX=DICMXSV + I $D(Y) M X=W D DIMP(X),DATE^DICOMP0:Y["D" ;Remember if it's a DATE + Q + ; +DIMP(D) ; + N DIM + S DIM=$$DIMC,DIM=DIM+$S(DIM<9.8:.1,1:.01) + S X(DIM)=D,X=" X "_$$DA_DIM_")" Q + ; +DA() Q $S(DA:"^DD("_A_","_DA_",",1:DA) + ; +DIMC() N DIM + S DIM=$O(X(99),-1) I 'DIM S DIM=+$P(DICOMP,"M",2) I 'DIM S DIM=9.1 + Q DIM + ; +X ; + S X="S X=$P(^(0),U)"_$S(X["D"&'$D(DPS($$NEST^DICOMP,"INTERNAL")):",Y=X X ^DD(""DD"") S X=Y",X["P":" S:$D(^"_$P(^(0),U,3)_"+X,0)) X=$P(^(0),U)",X["S":",Y=$F(^DD("_+D_",.01,0),X_$C(58)) S:Y X=$P($E(^(0),Y,999),$C(59),1)",1:""),DIMW="m" Q + ; +I(LEV) N S + S S=DLV0+LEV I DICOMP'["I"!'$D(I(S)) Q "" + Q "S I("_S_")="""_$$CONVQQ^DILIBF(I(S))_""",J("_S_")="_J(S)_" " + ; +REF(T) ; + N L,D,X,V + F L=T\100*100:1:T S D=I(L) S X=$G(X)_D_$E(",",$D(X))_$S(L0 S:DJ(Z)="" DJ(Z)=-1 W !! S Z=Z-1 Q -B S N=^DD(F(Z),DJ(Z),0) K DDF I $D(DIGR),Z<2!(DJ(Z)-.01) X DIGR E G ND - D HD:$Y+6>IOSL Q:M=U W !!,F(Z),",",DJ(Z) - W ?(Z+Z+12),$P(N,U,1),?DDL2+4," "_$P(N,U,4) - S X=$P(N,U,2) -WP I X,$D(^DD(+X,.01,0)) S W=$P(^(0),U,2) I W["W" D - .S X="WORD-PROCESSING #"_+X D S X="(NOWRAP)" D:W["L" S X="(IGNORE ""|"")" D:W["X"!(W["x") S X="(UNEDITABLE)" D:W["I" S X="" - ..W:$L(X)+$X+5>IOM !?18 W " ",X - F W="BOOLEAN","COMPUTED","FREE TEXT","SET","DATE","NUMBER","POINTER","K","VARIABLE POINTER","p" I X[$E(W) D VP^DIDX:$E(W)="V" S:W="K" W="MUMPS" S:W="p" W="POINTER" W ?40," "_W G ND:M=U - I +X S W=" Multiple" S W=W_" #"_+X D W G ND:M=U - I X["V" S I=0 F S I=$O(^DD(F(Z),D0,"V",I)) Q:I'>0 S %Y=$P(^(I,0),U) I $D(^DIC(%Y,0)),$D(@(^(0,"GL")_"0)")) S ^UTILITY($J,"P",$E($P(^(0),U),1,30),0)=%Y,^(F(Z),DJ(Z))=0 - S:I="" I=-1 G MP:X'["P"!X S Y=$P(N,U,3) I Y]"",$D(@("^"_Y_"0)")) S %Y=+$P(X,"P",2),W=" TO "_$P(^(0),U,1)_" FILE (#"_%Y_")",^UTILITY($J,"P",$E($P(^(0),U,1),1,30),0)=%Y,^(F(Z),DJ(Z))=0 D W G ND:M=U,MP - S W=" ** TO AN UNDEFINED FILE ** " W:($L(W)+$X)'0 W=W_$P(^DD(+X,%,0),U)_"(#"_%_")"_$S($P(^(0),U,2)["R":"[R]",1:"")_", " I %'>0 S:W?.E1", " W=$E(W,1,$L(W)-2) D W G ND:M=U Q - ; - ;Print "WRITE" identifiers - I '$D(DINM) S %=" " F S %=$O(^DD(+X,0,"ID",%)) Q:%="" D Q:M=U - . N DIDLN,DIDPG - . S DIDLN(1)=$G(^DD(+X,0,"ID",%)) Q:DIDLN(1)?."^" - . S DIDLN(0)=""""_%_""": " - . S DIDLN(0)=$J("",DDL2-DDL1-$L(DIDLN(0)))_DIDLN(0) - . S DIDPG("H")="W """" D H^DIDH S:M=U PAGE(U)=1" - . D WRPHI^DIKCP1(.DIDLN,IOM-1-DDL2,DDL1,DDL2-DDL1,1,.DIDPG) - G:M=U ND - ; - I $D(^DD("KEY","B",+X)) D G:M=U ND - . N DIDPG - . S DIDPG("H")="W """" S DC=DC+1 D ^DIDH1 S:M=U PAGE(U)=1" - . D PRINT^DIKKP(+X,"","L"_DDL1_"C"_(DDL2-DDL1),.DIDPG) - I $D(^DD("IX","B",+X)) D G:M=U ND - . N DIDPG - . S DIDPG("H")="W """" S DC=DC+1 D ^DIDH1 S:M=U PAGE(U)=1" - . D LIST^DIKCP(+X,"","L"_DDL1_"C"_(DDL2-DDL1),.DIDPG) - S Z=Z+1,DDL1=DDL1+2,DDL2=DDL2+2,F(Z)=+X - D L -N K DDN1 I X["X" S DDN1=1 W !,?DDL1,"NOTES:",?DDL2,"XXXX--CAN'T BE ALTERED EXCEPT BY PROGRAMMER" W ! G ND:M=U - S W=0 I $O(^DD(F(Z),DJ(Z),5,W))'="",'$D(DDN1) W !?DDL1,"NOTES:" -TR S W=$O(^DD(F(Z),DJ(Z),5,W)) S:W="" W=-1 G IX:W'>0 S I=^(W,0),%=+I I '$D(^DD(%,$P(I,U,2),0))!$D(W(I)) K ^DD(F(Z),DJ(Z),5,W) G TR - S W(I)=0 S WS=W D WR^DIDH1 W ! S W=WS K WS G TR -IX S F=0 F G ND:M=U S F=$O(^DD(F(Z),DJ(Z),1,F)) Q:F'>0 W !?DDL1,"CROSS-REFERENCE:" D IX1 - S:F="" F=-1 - I $D(^DD("IX","F",F(Z),DJ(Z))) D S:M=U DN=0 - . N DIDPG,DIDFLAG - . S DIDPG("H")="W """" S DC=DC+1 D ^DIDH1 S:M=U PAGE(U)=1" - . S DIDFLAG="L"_DDL1_"C"_(DDL2-DDL1)_"T1" - . D PRINT^DIKCP(F(Z),DJ(Z),$E("R",$G(DIDRANGE))_"FS"_DIDFLAG_$E("N",$D(DINM)#2),.DIDPG) Q:M=U - . D:'$G(DIDRANGE) LIST^DIKCP(F(Z),DJ(Z),"RS"_DIDFLAG,.DIDPG) -ND S X="" G:M'=U A:Z>1 Q -IX1 S W=^(F,0)_" " K DDF W ?DDL2,W,! G ND:M=U D TP:$P(W,U,3)["TRIG" I '$D(DINM) S X=0 F %=0:0 S X=$O(^DD(F(Z),DJ(Z),1,F,X)) Q:X="" I X'="%D",X'="DT" S W=^(X) S:$L(W)<248 W=X_")= "_W K:X=3 DDF D W W ! G ND:M=U - Q:'$D(^("%D")) - ; - N DIDI,DIDN,DIDZ,DIWF,DIWL,DIWR,X - K ^UTILITY($J,"W") - S DIWF="W",DIWL=DDL2+1,DIWR=IOM,DIDZ=Z - S DIDN=$P($G(^DD(F(DIDZ),DJ(DIDZ),1,F,"%D",0)),U,3),DIDI=0 - F S DIDI=$O(^DD(F(DIDZ),DJ(DIDZ),1,F,"%D",DIDI)) Q:'DIDI!(DIDN&(DIDI>DIDN)) S X=^(DIDI,0) D ^DIWP I $D(DN),'DN S M=U Q - I M'=U D ^DIWW I $D(DN),'DN S M=U - I M'=U W ! - E K DIOEND - S Z=DIDZ - K ^UTILITY($J,"W") - Q - ; -TP S X=+$P(^(0),U,4) I F(Z)-X,$D(^DIC(X,0))#2 S ^UTILITY($J,"P",$E($P(^(0),U,1),1,30),0)=X,^(F(Z),DJ(Z))=6 - Q -W F K=0:0 W:$D(DDF) ! S:(($L(W)+DDL2)>IOM) DDL2=32 W ?DDL2 S %Y=$E(W,IOM-$X,999) W $E(W,1,IOM-$X-1) Q:%Y="" S W=%Y,DDF=1 - K:'X DDF Q:$Y+60 S:DJ(Z)="" DJ(Z)=-1 W !! S Z=Z-1 Q +B S N=^DD(F(Z),DJ(Z),0) K DDF I $D(DIGR),Z<2!(DJ(Z)-.01) X DIGR E G ND + D HD:$Y+6>IOSL Q:M=U W !!,F(Z),",",DJ(Z) + W ?(Z+Z+12),$P(N,U,1),?DDL2+4," "_$P(N,U,4) + S X=$P(N,U,2) I X,$D(^DD(+X,.01,0)) S W=$P(^(0),U,2) I W["W" W " WORD-PROCESSING #",+X W:W["L" " (NOWRAP)" S X="" + F W="BOOLEAN","COMPUTED","FREE TEXT","SET","DATE","NUMBER","POINTER","K","VARIABLE POINTER","p" I X[$E(W) D VP^DIDX:$E(W)="V" S:W="K" W="MUMPS" S:W="p" W="POINTER" W ?40," "_W G ND:M=U + I +X S W=" Multiple" S W=W_" #"_+X D W G ND:M=U + I X["V" S I=0 F S I=$O(^DD(F(Z),D0,"V",I)) Q:I'>0 S %Y=$P(^(I,0),U) I $D(^DIC(%Y,0)),$D(@(^(0,"GL")_"0)")) S ^UTILITY($J,"P",$E($P(^(0),U),1,30),0)=%Y,^(F(Z),DJ(Z))=0 + S:I="" I=-1 G MP:X'["P"!X S Y=$P(N,U,3) I Y]"",$D(@("^"_Y_"0)")) S %Y=+$P(X,"P",2),W=" TO "_$P(^(0),U,1)_" FILE (#"_%Y_")",^UTILITY($J,"P",$E($P(^(0),U,1),1,30),0)=%Y,^(F(Z),DJ(Z))=0 D W G ND:M=U,MP + S W=" ** TO AN UNDEFINED FILE ** " W:($L(W)+$X)'0 W=W_$P(^DD(+X,%,0),U)_"(#"_%_")"_$S($P(^(0),U,2)["R":"[R]",1:"")_", " I %'>0 S:W?.E1", " W=$E(W,1,$L(W)-2) D W G ND:M=U Q + ; + ;Print "WRITE" identifiers + I '$D(DINM) S %=" " F S %=$O(^DD(+X,0,"ID",%)) Q:%="" D Q:M=U + . N DIDLN,DIDPG + . S DIDLN(1)=$G(^DD(+X,0,"ID",%)) Q:DIDLN(1)?."^" + . S DIDLN(0)=""""_%_""": " + . S DIDLN(0)=$J("",DDL2-DDL1-$L(DIDLN(0)))_DIDLN(0) + . S DIDPG("H")="W """" D H^DIDH S:M=U PAGE(U)=1" + . D WRPHI^DIKCP1(.DIDLN,IOM-1-DDL2,DDL1,DDL2-DDL1,1,.DIDPG) + G:M=U ND + ; + I $D(^DD("KEY","B",+X)) D G:M=U ND + . N DIDPG + . S DIDPG("H")="W """" S DC=DC+1 D ^DIDH1 S:M=U PAGE(U)=1" + . D PRINT^DIKKP(+X,"","L"_DDL1_"C"_(DDL2-DDL1),.DIDPG) + I $D(^DD("IX","B",+X)) D G:M=U ND + . N DIDPG + . S DIDPG("H")="W """" S DC=DC+1 D ^DIDH1 S:M=U PAGE(U)=1" + . D LIST^DIKCP(+X,"","L"_DDL1_"C"_(DDL2-DDL1),.DIDPG) + S Z=Z+1,DDL1=DDL1+2,DDL2=DDL2+2,F(Z)=+X + D L +N K DDN1 I X["X" S DDN1=1 W !,?DDL1,"NOTES:",?DDL2,"XXXX--CAN'T BE ALTERED EXCEPT BY PROGRAMMER" W ! G ND:M=U + S W=0 I $O(^DD(F(Z),DJ(Z),5,W))'="",'$D(DDN1) W !?DDL1,"NOTES:" +TR S W=$O(^DD(F(Z),DJ(Z),5,W)) S:W="" W=-1 G IX:W'>0 S I=^(W,0),%=+I I '$D(^DD(%,$P(I,U,2),0))!$D(W(I)) K ^DD(F(Z),DJ(Z),5,W) G TR + S W(I)=0 S WS=W D WR^DIDH1 W ! S W=WS K WS G TR +IX S F=0 F G ND:M=U S F=$O(^DD(F(Z),DJ(Z),1,F)) Q:F'>0 W !?DDL1,"CROSS-REFERENCE:" D IX1 + S:F="" F=-1 + I $D(^DD("IX","F",F(Z),DJ(Z))) D S:M=U DN=0 + . N DIDPG,DIDFLAG + . S DIDPG("H")="W """" S DC=DC+1 D ^DIDH1 S:M=U PAGE(U)=1" + . S DIDFLAG="L"_DDL1_"C"_(DDL2-DDL1)_"T1" + . D PRINT^DIKCP(F(Z),DJ(Z),$E("R",$G(DIDRANGE))_"FS"_DIDFLAG_$E("N",$D(DINM)#2),.DIDPG) Q:M=U + . D:'$G(DIDRANGE) LIST^DIKCP(F(Z),DJ(Z),"RS"_DIDFLAG,.DIDPG) +ND S X="" G:M'=U A:Z>1 Q +IX1 S W=^(F,0)_" " K DDF W ?DDL2,W,! G ND:M=U D TP:$P(W,U,3)["TRIG" I '$D(DINM) S X=0 F %=0:0 S X=$O(^DD(F(Z),DJ(Z),1,F,X)) Q:X="" I X'="%D",X'="DT" S W=^(X) S:$L(W)<248 W=X_")= "_W K:X=3 DDF D W W ! G ND:M=U + Q:'$D(^("%D")) + ; + N DIDI,DIDN,DIDZ,DIWF,DIWL,DIWR,X + K ^UTILITY($J,"W") + S DIWF="W",DIWL=DDL2+1,DIWR=IOM,DIDZ=Z + S DIDN=$P($G(^DD(F(DIDZ),DJ(DIDZ),1,F,"%D",0)),U,3),DIDI=0 + F S DIDI=$O(^DD(F(DIDZ),DJ(DIDZ),1,F,"%D",DIDI)) Q:'DIDI!(DIDN&(DIDI>DIDN)) S X=^(DIDI,0) D ^DIWP I $D(DN),'DN S M=U Q + I M'=U D ^DIWW I $D(DN),'DN S M=U + I M'=U W ! + E K DIOEND + S Z=DIDZ + K ^UTILITY($J,"W") + Q + ; +TP S X=+$P(^(0),U,4) I F(Z)-X,$D(^DIC(X,0))#2 S ^UTILITY($J,"P",$E($P(^(0),U,1),1,30),0)=X,^(F(Z),DJ(Z))=6 + Q +W F K=0:0 W:$D(DDF) ! S:(($L(W)+DDL2)>IOM) DDL2=32 W ?DDL2 S %Y=$E(W,IOM-$X,999) W $E(W,1,IOM-$X-1) Q:%Y="" S W=%Y,DDF=1 + K:'X DDF Q:$Y+60 K DE,DOV,DIOV,DIEC,DTOUT N DIEDA D - . N % - . F %=1:1 Q:'$G(DA(%)) S DIEDA(%)=DA(%) - . S DIEDA=DA - . Q - I $D(DIETMP)[0 N DIETMP S DIETMP=$$GETTMP^DIKC1("DIE") - N DIEFXREF,DIIENS,DIE1,DIE1N K DIEFIRE,DIEBADK,DIESP S DIIENS=$$IENS^DIKCU(DP,.DA) - S DL=1,DIE1=1,D0=DA,DI=DP,DR(1,DP)=DR D INI I $E(DR)'="[" D DR^DIE17 - S DP=DI,DA=D0,(DQ,DIEL,DK,DP(0))=0 K DIC("S") -MR S DK=DK+1,DH=$P(DR,";",DK) I +DH=DH S (DI,DM)=DH G S:$D(^DD(DP,DI)),MR - S DI=$P(DH,":",1) I 'DI G K:DI=0,PB -J I DH["//" S DE(DQ+1,0)=$P(DH,"//",2,9),DI=$P(DI,"//",1),DH="" - G K:+DI=DI S DM=+DI,Y=$P(DI,DM,2,99),DI=DM G MR:Y=""!'$D(^DD(DP,DI,0)) S DQ=DQ+1,(DZ,DQ(DQ))=^(0),DIFLD(DQ)=DI -SPC F %=1:1 S DIESP=$P(Y,$C(126),%) Q:DIESP="" D - .I DIESP="d"!(DIESP="R") S $P(DZ,U,2)=$P(DZ,U,2)_DIESP Q - .I DIESP="T"!(DIESP="t") S:$G(^DD(DP,DI,.1))]"" $P(DZ,U)=^(.1) Q - .S $P(DZ,U)=DIESP,DQ(DQ,"CAPTION")=DIESP - S:DH'[$C(126) DH=DH_$C(126) S DQ(DQ)=DZ K DZ G Y - ; -K S DM=$P(DH,":",2),DM=$S(DM:DM,1:DI) I DI,$D(^DD(DP,DI)) G S -NX S DI=$O(^DD(DP,DI)) S:DI="" DI=-1 G MR:DI'>0,MR:DI>DM -S I DQ'<50,'$D(DE(DQ+1)) G H - S DQ=DQ+1,DQ(DQ)=^(DI,0),DIFLD(DQ)=DI -Y S Y=$P(DQ(DQ),"^",4),DG=$P(Y,";",1) - ;Determine whether field has a xref defined in the Index file - S DIEXREF=0 F S DIEXREF=$O(^DD("IX","F",DP,DI,DIEXREF)) Q:'DIEXREF I $P($G(^DD("IX",DIEXREF,0)),U) S DIEXREF=1 Q - I $D(^DD(DP,DI,1))!($P(DQ(DQ),U,2)["a")!DIEXREF S DE=0,DB=DM,DM=0,DE(Y)=DQ K DIEXREF F DW=1:1 S DE=$O(^DD(DP,DI,1,DE)) Q:DE<1 S DE(Y,DW,1)=^(DE,1),DE(Y,DW,2)=^(2) - I S:DE="" DE=-1 - I $P(DQ(DQ),U,2)["a" S DE(Y,DW,2)="S DIIX=2_U_DIFLD(DE(DQ)) D AUDIT^DIET",DE(Y,DW,1)="S DIIX=3_U_DIFLD(DE(DQ)) D AUDIT^DIET",DE(Y)=DQ I ^DD(DP,DI,"AUDIT")="e" S DE(Y,DW,1)="I $D(DE(DE(DQ)))#2 "_DE(Y,DW,1) - S Y=$P(Y,";",2) I DU'=DG S D="",DU=DG,@DC G M:Y=0,B:DU=" ",EQ:DW[0 S D=^(DG) - I Y S:$P(D,"^",Y)]"" DE(DQ)=$P(D,"^",Y) - E S Y=$E(D,+$E(Y,2,9),$P(Y,",",2)) S:Y'?." " DE(DQ)=Y -EQ G MR:DI=DM,NX:DM S DM=DB K DB G D - ; -INI K DIC("S") S DIC=DIE,DU=-1,DC="DW=$D("_DIE_DA_",DG))" -Q Q - ; - ; -MORE ;from ^DIE1 - D INI G MR:DI=DM,NX:DI'[U,MR:'$D(^DD(DP,+DI)) S %=$P(DI,U,2),DI=+DI S:%]"" DQ(DQ+1,"CAPTION")=% G S - ; - ; -JMP ;from ^DIE0 - D INI G J - ; -PB I DH="" G D:$D(DR(DIE1,DP))<9 S:'$D(DOV) DOV=0,DR(DIE1,DP)=DR S DOV=$O(DR(DIE1,DP,DOV)) S:DOV="" DOV=-1 G D:DOV'>0 S DR=DR(DIE1,DP,DOV),DK=0 G MR - G MR:DH?1"@".N I 'DQ G TEM:DH?1"[".E S:"Q"'=DH DQ=1,DQ(0,1)=DH G MR:$A(DH)-94 S DC=$P(DH,U,1,4) X $P(DH,U,5,999) D DIE1N G O^DIE0 -E S DK=DK-1,(DI,DM)=1 -D G DQ^DIED - ; -H S DI=DI_U G D - ;Multiple field -M S Y=$P(DQ(DQ),U,2)_U_DG G DC:DW<9 - I $D(DSC(+Y))#2,$P(DSC(+Y),"I $D(^UTILITY(",1)="" S D=DIEL+1 D D1 X DSC(+Y) S D=$O(^(0)) S:D="" D=-1 S @DC S DC=$O(^(DG,0)) S:DC="" DC=-1 G DE - I $D(^(DG,0)) S D=$P(^(0),U,3,4) S:$P(^(0),U,2)'=$P(Y,U) $P(^(0),U,2)=$P(Y,U) ;HMMM - E S D=$O(^(0)) S:D="" D=-1 -DE I D>0 S Y=Y_U_D I DP(0)-Y!($P(DP(0),U,2)-DK),$D(^(+D,0)) S DE(DQ)=$P(^(0),U) ;Default value if this isn't same multiple we were down in before -DC S DC=$P(^DD(+Y,0),U,4)_U_Y,%=DQ(DQ),Y=^(.01,0) -MUL I $P(Y,U,2)'["W" S DQ(DQ)=$P($$EZBLD^DIALOG(8042,$G(DQ(DQ,"CAPTION"),$P(Y,U))),": ")_U_1_$P(Y,U,2,99) D DIE1N G D ;MULTIPLE-FIELD LABEL - I DQ>1 K DQ(DQ) G E:$D(DE(DQ,0)),H - D - .Q:DH'[$C(126) - .N DIEA S DIEA=$P($P(DH,+DH,2),$C(126)) Q:DIEA=""!(DIEA="d")!(DIEA="R") - .I DIEA="T"!(DIEA="t") S:$D(^DD(+$P(%,U,2),.01,.1)) DQ(DQ,"CAPTION")=^(.1) Q - .S DQ(DQ,"CAPTION")=DIEA -DIWE S Y=$G(DQ(DQ,"CAPTION"),$P(%,U))_U_$P(Y,U,2) D DIEN^DIWE K DQ,DG,DE S DQ=0 G QY^DIE1:$D(DTOUT) G MORE ;WORD-PROCESSING FIELD LABEL - ; -D1 Q:D'>0 S:'$D(@("D"_D)) @("D"_D)=0 S D=D-1 G D1 - ; -DIE1N N M,I S DIE1N="" F I=DK,DK+1 S M=$P(DR,";",I) I M?1"^"1.NP S DIE1N=$P(M,U,2) S:I>DK DK=DK+1 Q ;WPB-0804-30857 - Q - ; - ; -B K DQ(DQ) S DQ=DQ-1,DU=-9 G EQ - ; -TEM K:$D(DIETMP)#2 @DIETMP,DIETMP - S Y=0 F S Y=$O(^DIE("B",$P($E(DR,2,99),"]",1),Y)) S:Y="" Y=-1 G Q:Y=-1,Q:'$D(^DIE(+Y,0)) Q:$P(^(0),U,4)=DP - S $P(^(0),U,7)=DT I $G(^("ROU"))[U,$$ROUEXIST^DILIBF($P(^("ROU"),U,2)) G @^DIE(+Y,"ROU") - S:$D(^("W")) DIE("W")=^("W") S %X="^DIE(+Y,""DR"",",%Y="DR(" D %XY^%RCR - S DIE("^")=DR,DR=$S($D(^DIE(Y,"DR"))#2:^("DR"),1:DR(1,DP)) D DIE K DR S DR=DIE(U) - Q - ; - ;Silent call concerning editing and filing of data. - ; -FILE(DIEFFLAG,DIEFAR,DIEFOUT) ; - G FILEX^DIEF - ; -WP(DIEFF,DIEFIEN,DIEFFLD,DIEFWPFL,DIEFTSRC,DIEFOUT) ; - G WPX^DIEFW - ; -HELP(DIEHF,DIEHIEN,DIEHFLD,DIEHFLG,DIEHOUT) ; - G GETX^DIEH - ; -VAL(DIEVF,DIEVIEN,DIEVFLD,DIEVFLG,DIEVAL,DIEVANS,DIEVFAR,DIOUTAR) ; - G VALX^DIEV - ; -KEYVAL(DIVKFLAG,DIVKFDA,DIVKOUT) ; - G KEYVALX^DIEVK - ; -VALS(DIVSFLAG,DIVSEFDA,DIVSIFDA,DIVSMSG) ; - G VALSX^DIEVS - ; -CHK(DIEVF,DIEVFLD,DIEVFLG,DIEVAL,DIEVANS,DIOUTAR) ; - G CHKX^DIEV - ; -UPDATE(DIFLAGS,DIFDA,DIEN,DIMSGA) ;SEA/TOAD - ; ENTRY POINT--update database - ; procedure, all passed by value - G ADDX^DICA - ; +DIE ;SFISC/GFT,XAK-PROC.DR-STR ;2:40 PM 17 Sep 2002 + ;;22.0;VA FileMan;**1,4,8,11,59,95**;Mar 30, 1999 + ;Per VHA Directive 10-93-142, this routine should not be modified. + N DG,DNM,DICRREC K DB I DIE S DIE=^DIC(DIE,0,"GL") + Q:$D(@(DIE_DA_",-9)")) Q:'$D(@(DIE_"0)")) S U="^",DP=+$P(^(0),U,2) Q:$P($G(^DD($$FNO^DILIBF(DP),0,"DI")),U,2)["Y"&'$D(DIOVRD)&'$G(DIFROM) +GO Q:DIE?1"^DIA(".E K DE,DOV,DIOV,DIEC,DTOUT N DIEDA D + . N % + . F %=1:1 Q:'$G(DA(%)) S DIEDA(%)=DA(%) + . S DIEDA=DA + . Q + I $D(DIETMP)[0 N DIETMP S DIETMP=$$GETTMP^DIKC1("DIE") + N DIEFXREF,DIIENS K DIEFIRE,DIEBADK S DIIENS=$$IENS^DIKCU(DP,.DA) + S DL=1,D0=DA,DI=DP,DR(1,DP)=DR D INI I $E(DR)'="[" D DR^DIE17 + S DP=DI,DA=D0,(DQ,DIEL,DK,DP(0))=0 K DIC("S") +MR S DK=DK+1,DH=$P(DR,";",DK) I +DH=DH S (DI,DM)=DH G S:$D(^DD(DP,DI)),MR + S DI=$P(DH,":",1) I 'DI G K:DI=0,PB +J I DH["//" S DE(DQ+1,0)=$P(DH,"//",2,9),DI=$P(DI,"//",1),DH="" + G K:+DI=DI S DM=+DI,Y=$P(DI,DM,2,99),DI=DM G MR:Y=""!'$D(^DD(DP,DI,0)) S DQ=DQ+1,(DZ,DQ(DQ))=^(0),DIFLD(DQ)=DI + F %=1:1 S DIG=$P(Y,$C(126),%) Q:DIG="" S DZ=$S(DIG="d"!(DIG="R"):$P(DZ,U,1,2)_DIG_U_$P(DZ,U,3,99),DIG="T":$S($D(^(.1)):^(.1),1:$P(DZ,U))_U_$P(DZ,U,2,99),1:DIG_U_$P(DZ,U,2,99)) + S:DH'[$C(126) DH=DH_$C(126) S DQ(DQ)=DZ K DZ,DIG G Y +K S DM=$P(DH,":",2),DM=$S(DM:DM,1:DI) I DI,$D(^DD(DP,DI)) G S +NX S DI=$O(^DD(DP,DI)) S:DI="" DI=-1 G MR:DI'>0,MR:DI>DM +S I DQ'<50,'$D(DE(DQ+1)) G H + S DQ=DQ+1,DQ(DQ)=^(DI,0),DIFLD(DQ)=DI +Y S Y=$P(DQ(DQ),"^",4),DG=$P(Y,";",1) + ;Determine whether field has a xref defined in the Index file + S DIEXREF=0 F S DIEXREF=$O(^DD("IX","F",DP,DI,DIEXREF)) Q:'DIEXREF I $P($G(^DD("IX",DIEXREF,0)),U) S DIEXREF=1 Q + I $D(^DD(DP,DI,1))!($P(DQ(DQ),U,2)["a")!DIEXREF S DE=0,DB=DM,DM=0,DE(Y)=DQ K DIEXREF F DW=1:1 S DE=$O(^DD(DP,DI,1,DE)) Q:DE<1 S DE(Y,DW,1)=^(DE,1),DE(Y,DW,2)=^(2) + I S:DE="" DE=-1 + I $P(DQ(DQ),U,2)["a" S DE(Y,DW,2)="S DIIX=2_U_DIFLD(DE(DQ)) D AUDIT^DIET",DE(Y,DW,1)="S DIIX=3_U_DIFLD(DE(DQ)) D AUDIT^DIET",DE(Y)=DQ I ^DD(DP,DI,"AUDIT")="e" S DE(Y,DW,1)="I $D(DE(DE(DQ)))#2 "_DE(Y,DW,1) + S Y=$P(Y,";",2) I DU'=DG S D="",DU=DG,@DC G M:Y=0,B:DU=" ",EQ:DW[0 S D=^(DG) + I Y S:$P(D,"^",Y)]"" DE(DQ)=$P(D,"^",Y) + E S Y=$E(D,+$E(Y,2,9),$P(Y,",",2)) S:Y'?." " DE(DQ)=Y +EQ G MR:DI=DM,NX:DM S DM=DB K DB G D + ; +INI K DIC("S") S DIC=DIE,DU=-1,DC="DW=$D("_DIE_DA_",DG))" +Q Q +MORE ; + D INI G MR:DI=DM,NX:DI'[U S DI=+DI G S:$D(^DD(DP,DI)),MR +JMP ; + D INI G J + ; +PB I DH="" G D:$D(DR(DL,DP))<9 S:'$D(DOV) DOV=0,DR(DL,DP)=DR S DOV=$O(DR(DL,DP,DOV)) S:DOV="" DOV=-1 G D:DOV'>0 S DR=DR(DL,DP,DOV),DK=0 G MR + G MR:DH?1"@".N I 'DQ G TEM:DH?1"[".E S:"Q"'=DH DQ=1,DQ(0,1)=DH G MR:$A(DH)-94 S DC=$P(DH,U,1,4) X $P(DH,U,5,999) G O^DIE0 +E S DK=DK-1,(DI,DM)=1 +D G DQ^DIED +H S DI=DI_U G D +M S Y=$P(DQ(DQ),U,2)_U_DG G DC:DW<9 + I $D(DSC(+Y))#2,$P(DSC(+Y),"I $D(^UTILITY(",1)="" S D=DIEL+1 D D1 X DSC(+Y) S D=$O(^(0)) S:D="" D=-1 S @DC S DC=$O(^(DG,0)) S:DC="" DC=-1 G DE + I $D(^(DG,0)) S D=$P(^(0),U,3,4) S:$P(^(0),U,2)'=$P(Y,U) $P(^(0),U,2)=$P(Y,U) + E S D=$O(^(0)) S:D="" D=-1 +DE I D>0 S Y=Y_U_D I DP(0)-Y,$D(^(+D,0)) S DE(DQ)=$P(^(0),U,1) +DC S DC=$P(^DD(+Y,0),U,4)_U_Y,%=DQ(DQ),Y=^(.01,0) I $P(Y,U,2)'["W" S DQ(DQ)="Select "_$P(Y,U,1)_U_1_$P(Y,U,2,99) G D + I DQ>1 K DQ(DQ) G E:$D(DE(DQ,0)),H + D + .Q:DH'[$C(126) + .N DIEA S DIEA=$P($P(DH,+DH,2),$C(126)) Q:DIEA=""!(DIEA="d")!(DIEA="R") + .S $P(%,U)=$S(DIEA="T"&$D(^DD(+$P(%,U,2),.01,.1)):^(.1),1:DIEA) + .Q + S Y=$P(%,U,1)_U_$P(Y,U,2) D DIEN^DIWE K DQ,DG,DE S DQ=0 G QY^DIE1:$D(DTOUT) G MORE + ; +D1 Q:D'>0 S:'$D(@("D"_D)) @("D"_D)=0 S D=D-1 G D1 + ; +B K DQ(DQ) S DQ=DQ-1,DU=-9 G EQ + ; +TEM K:$D(DIETMP)#2 @DIETMP,DIETMP + S Y=0 F S Y=$O(^DIE("B",$P($E(DR,2,99),"]",1),Y)) S:Y="" Y=-1 G Q:Y=-1,Q:'$D(^DIE(+Y,0)) Q:$P(^(0),U,4)=DP + S $P(^(0),U,7)=DT I $G(^("ROU"))[U,$$ROUEXIST^DILIBF($P(^("ROU"),U,2)) G @^DIE(+Y,"ROU") + S:$D(^("W")) DIE("W")=^("W") S %X="^DIE(+Y,""DR"",",%Y="DR(" D %XY^%RCR + S DIE("^")=DR,DR=$S($D(^DIE(Y,"DR"))#2:^("DR"),1:DR(1,DP)) D DIE K DR S DR=DIE(U) + Q + ; + ;Silent call concerning editing and filing of data. + ; +FILE(DIEFFLAG,DIEFAR,DIEFOUT) ; + G FILEX^DIEF + ; +WP(DIEFF,DIEFIEN,DIEFFLD,DIEFWPFL,DIEFTSRC,DIEFOUT) ; + G WPX^DIEFW + ; +HELP(DIEHF,DIEHIEN,DIEHFLD,DIEHFLG,DIEHOUT) ; + G GETX^DIEH + ; +VAL(DIEVF,DIEVIEN,DIEVFLD,DIEVFLG,DIEVAL,DIEVANS,DIEVFAR,DIOUTAR) ; + G VALX^DIEV + ; +KEYVAL(DIVKFLAG,DIVKFDA,DIVKOUT) ; + G KEYVALX^DIEVK + ; +VALS(DIVSFLAG,DIVSEFDA,DIVSIFDA,DIVSMSG) ; + G VALSX^DIEVS + ; +CHK(DIEVF,DIEVFLD,DIEVFLG,DIEVAL,DIEVANS,DIOUTAR) ; + G CHKX^DIEV + ; +UPDATE(DIFLAGS,DIFDA,DIEN,DIMSGA) ;SEA/TOAD + ; ENTRY POINT--update database + ; procedure, all passed by value + G ADDX^DICA + ; diff --git a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIE0.m b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIE0.m index 9fbb8253..e8df96ca 100644 --- a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIE0.m +++ b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIE0.m @@ -1,71 +1,74 @@ -DIE0 ;SFISC/GFT-BRANCHING, UP-ARROWING ;27MAR2006 - ;;22.0;VA FileMan;**60,159**;Mar 30, 1999;Build 8 - ;Per VHA Directive 2004-038, this routine should not be modified. - G Q^DIE1:$D(DTOUT) G:X'?1"^".E T^DIED:$P($P(DQ(DQ),U,4),";E",2),X - I $D(DIE("NO^")),X=U,DIE("NO^")'["OUTOK" W !?3,"EXIT NOT ALLOWED " G X - I $D(DIE("NO^")),X?1"^"1E.E,DIE("NO^")'["BACK" W !?3,"JUMPING NOT ALLOWED " G X - I $L(X,"^")-1>1 S X=$E(X,2,99) G DIE0 - S X=$P(X,U,2),DIC(0)="E" -OUT I X=""!(DP<0) S DIK=X,DC=$S($D(DQ(DQ))#2:$P(DQ(DQ),U,4),1:DQ) G OUT^DIE1 - I DR]"" G A:X?1"@".N S DIC("S")="D S^DIE0" S:'$D(DR(DIE1,DP)) DR(DIE1,DP)=DR - S DDBK=0,DIC="^DD("_DP_"," D ^DIC I Y>0 D S - E W:DDBK !?3,"JUMPING FORWARD NOT ALLOWED " - K DTOUT,DIC,DDBK,DDFND,DDONE,A0,A1,A2 - I Y<0 S DG=DK,DH=":"_DM G X - S DI=$S(DH[":":+Y,1:DH),DK=DG D ^DIE1:$D(DG)>9 K DG,DB,DE,DQ,DIFLD S DQ=0 G JMP^DIE -X W:X'["?"&'$D(ZTQUEUED) $C(7),"??" G B^DIED:'$D(DB(DQ)),B^DIE1 - ; -BR ;From ^DIED - S Y=U,X=$G(X) X DQ(0,DQ) D:$D(DIEFIRE)#2 FIREREC^DIE1 G A^DIED:$D(Y)[0,A^DIED:Y=U S D=$S(+Y=Y:9999,1:DQ),X="" I 0[Y S DQ=0 G OUT -D S D=D+1 I '$D(DQ(D)) G D:$D(DQ(0,D)) S DQ=9999,X=Y,DIC(0)="FO" G OUT - G D:$P(DQ(D),Y,1)]"" S DQ=D G RE^DIED - ; -O ;From ^DIE - K DQ S (DI,DV,DM)=0 I X]"",$D(@(U_$P(DC,U,3)_X_",0)"))#2 D S^DIE1,DIEC - S DQ=0 G MORE^DIE - ; -DIEC S DIE=U_$P(DC,U,3),DIEC(DL)=DA F %=1:1 Q:'$D(DA(%)) S DIEC(DL,%)=DA(%) - K DA,DB,DE,DG F %=0:1:DIEL-1 S DA="D"_%,DIEC(DL,0,%)=@DA K @DA - S:$D(DIETMP)#2 DIEC(DL,"IENS")=DIIENS,DIIENS=X_"," - S DIEL=0,(D0,DA)=X Q - ; -DIEZ ; - I X="" G @("A"_U_DNM) - S D=0,DL=DL+1,DNM(DL)=DNM,DNM(DL,0)=DQ,DIEL=DIEL+1 D DIEC G @DGO - ; -A I $D(DR(DIE1,DP))>9 D OA ;Branching to "@N" - E F DG=1:1 S DH=$P(DR(DIE1,DP),";",DG) G X:DH="" I DH=X S:$D(DOV) DOV=0 S DR=DR(DIE1,DP) Q - S DK=DG,DI=X D ^DIE1 G JMP^DIE -OA S %=0 F S %=$O(DR(DIE1,DP,%)) Q:%="" F DG=1:1 S DH=$P(DR(DIE1,DP,%),";",DG) Q:DH="" I DH=X S DR=DR(DIE1,DP,%),DOV=%,%=9999 Q - S %=-1 Q - ; -E ;UNEDITABLE & DINUM fields - I X="@" Q:DV'["I" G NO - Q:X[U!(X?."?")!DV!$D(DITC) -NO W:'$D(DB(DQ)) $C(7)," NO EDITING!!" K X -Q Q - ; - ; - ; -S ;SCREEN fields; out= $T - N DDR S (%,DDFND)=0,DDR=DR(DIE1,DP),DDBK=0,Y=+Y - I $D(DIE("NO^")),DIE("NO^")["BACK" S DDBK=1 - D S1 I DDFND Q - I 'DDONE,$D(DR(DL,DP))>9 F %=-1:0 S %=$O(DR(DIE1,DP,%)) Q:%="" S DDR=DR(DIE1,DP,%) D S1 Q:DDONE!DDFND - Q -S1 ;selectable? - S DDONE=0 F DG=1:1 D S2 Q:DDFND!DDONE!(DH="") - I DDFND S DOV=%,DR=$G(DR(DIE1,DP,%),$G(DR(DIE1,DP))) - Q -S2 ;parse for ;-piece - S DH=$P(DDR,";",DG) Q:(DH["///"&(DIC(0)'["F"))!'DH - ;list - I 'DDBK,+DH=Y S DDFND=1 Q - I DDBK,+DH=DIFLD,+DH'=Y S DDONE=1 Q - I DDBK,+DH=Y S DDFND=1 Q - Q:$P(DH,"//")'[":" - ;range - S A0=+$P(DH,":",1),A1=+$P(DH,":",2) - I 'DDBK,Y'A1 S DDFND=1 Q - F A2=A0-.000001:0 S A2=$O(^DD(DP,A2)) Q:A2>A1!'A2 S:A2=DIFLD&(A2'=Y)&DDBK DDONE=1 Q:DDONE I A2=Y,(A2'>DIFLD) S DDFND=1 Q - Q +DIE0 ;SFISC/GFT-BRANCHING, UP-ARROWING ;5:49 AM 21 Sep 2000 + ;;22.0;VA FileMan;**60**;Mar 30, 1999 + ;Per VHA Directive 10-93-142, this routine should not be modified. + G Q^DIE1:$D(DTOUT) G:X'?1"^".E T^DIED:$P($P(DQ(DQ),U,4),";E",2),X + I $D(DIE("NO^")),X=U,DIE("NO^")'["OUTOK" W !?3,"EXIT NOT ALLOWED " G X + I $D(DIE("NO^")),X?1"^"1E.E,DIE("NO^")'["BACK" W !?3,"JUMPING NOT ALLOWED " G X + I $L(X,"^")-1>1 S X=$E(X,2,99) G DIE0 + S X=$P(X,U,2),DIC(0)="E" +OUT I X=""!(DP<0) S DIK=X,DC=$S($D(DQ(DQ))#2:$P(DQ(DQ),U,4),1:DQ) G OUT^DIE1 + I DR]"" G A:X?1"@".N S DIC("S")="D S^DIE0" S:'$D(DR(DL,DP)) DR(DL,DP)=DR + S DDBK=0,DIC="^DD("_DP_"," D ^DIC I Y>0 D S + E W:DDBK !?3,"JUMPING FORWARD NOT ALLOWED " + K DTOUT,DIC,DDR,DDBK,DDFND,DDONE,A0,A1,A2 + I Y<0 S DG=DK,DH=":"_DM G X + S DI=$S(DH[":":+Y,1:DH),DK=DG D ^DIE1:$D(DG)>9 K DG,DB,DE,DQ,DIFLD S DQ=0 G JMP^DIE +X W:X'["?"&'$D(ZTQUEUED) $C(7),"??" G B^DIED:'$D(DB(DQ)),B^DIE1 + ; +BR ; + S Y=U X DQ(0,DQ) D:$D(DIEFIRE)#2 FIREREC^DIE1 G A^DIED:$D(Y)[0,A^DIED:Y=U S D=$S(+Y=Y:9999,1:DQ),X="" I 0[Y S DQ=0 G OUT +D S D=D+1 I '$D(DQ(D)) G D:$D(DQ(0,D)) S DQ=9999,X=Y,DIC(0)="FO" G OUT + G D:$P(DQ(D),Y,1)]"" S DQ=D G RE^DIED + ; +O ; + K DQ S (DI,DV,DM)=0 D DUZ I X]"",$D(@(U_$P(DC,U,3)_X_",0)"))#2 D S^DIE1,DIEC + S DQ=0 G MORE^DIE + ; +DIEC S DIE=U_$P(DC,U,3),DIEC(DL)=DA F %=1:1 Q:'$D(DA(%)) S DIEC(DL,%)=DA(%) + K DA,DB,DE,DG F %=0:1:DIEL-1 S DA="D"_%,DIEC(DL,0,%)=@DA K @DA + S:$D(DIETMP)#2 DIEC(DL,"IENS")=DIIENS,DIIENS=X_"," + S DIEL=0,(D0,DA)=X Q + ; +DUZ Q:X=""!(DUZ(0)="@") + ;S DIFILE=$P(DC,U,2),DIAC="WR" D ^DIAC K DIAC,DIFILE G:'% 3 + Q +3 ;W $C(7),!?7,"(YOU DO NOT HAVE 'WRITE ACCESS' TO THE '"_$P(^DIC($P(DC,U,2),0),U)_"' FILE)" S X="" + Q + ; +DIEZ ; + D DUZ I X="" G @("A"_U_DNM) + S D=0,DL=DL+1,DNM(DL)=DNM,DNM(DL,0)=DQ,DIEL=DIEL+1 D DIEC G @DGO + ; +A I $D(DR(DL,DP))>9 D OA + E F DG=1:1 S DH=$P(DR(DL,DP),";",DG) G X:DH="" I DH=X S:$D(DOV) DOV=0 S DR=DR(DL,DP) Q + S DK=DG,DI=X D ^DIE1 G JMP^DIE +OA S %=0 F S %=$O(DR(DL,DP,%)) Q:%="" F DG=1:1 S DH=$P(DR(DL,DP,%),";",DG) Q:DH="" I DH=X S DR=DR(DL,DP,%),DOV=%,%=9999 Q + S %=-1 Q + ; +E ; + I X="@" Q:DV'["I" G NO + Q:X[U!(X?."?")!DV!$D(DITC) +NO W:'$D(DB(DQ)) $C(7)," NO EDITING!!" K X +Q Q +S ;reg or ovfl, out= $T + S (%,DDFND)=0,DDR=DR(DL,DP),DDBK=0,Y=+Y + I $D(DIE("NO^")),DIE("NO^")["BACK" S DDBK=1 + D S1 I DDFND Q + I 'DDONE,$D(DR(DL,DP))>9 F %=-1:0 S %=$O(DR(DL,DP,%)) Q:%="" S DDR=DR(DL,DP,%) D S1 Q:DDONE!DDFND + Q +S1 ;selectable? + S DDONE=0 F DG=1:1 D S2 Q:DDFND!DDONE!(DH="") + I DDFND S DOV=%,DR=$S($D(DR(DL,DP,%)):DR(DL,DP,%),$D(DR(DL,DP)):DR(DL,DP),1:"") + Q +S2 ;parse for ;-piece + S DH=$P(DDR,";",DG) Q:(DH["///"&(DIC(0)'["F"))!'DH + ;list + I 'DDBK,+DH=Y S DDFND=1 Q + I DDBK,+DH=DIFLD,+DH'=Y S DDONE=1 Q + I DDBK,+DH=Y S DDFND=1 Q + Q:$P(DH,"//")'[":" + ;range + S A0=+$P(DH,":",1),A1=+$P(DH,":",2) + I 'DDBK,Y'A1 S DDFND=1 Q + F A2=A0-.000001:0 S A2=$O(^DD(DP,A2)) Q:A2>A1!'A2 S:A2=DIFLD&(A2'=Y)&DDBK DDONE=1 Q:DDONE I A2=Y,(A2'>DIFLD) S DDFND=1 Q + Q diff --git a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIE1.m b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIE1.m index 2fe478e9..ab30f7cd 100644 --- a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIE1.m +++ b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIE1.m @@ -1,151 +1,146 @@ -DIE1 ;SFISC/GFT-FILE DATA, XREF IT, GO UP AND DOWN MULTIPLES ;28MAY2008 - ;;22.0;VA FileMan;**1,4,11,159**;Mar 30, 1999;Build 8 - ;Per VHA Directive 2004-038, this routine should not be modified. - K DQ,DB G E1:$D(DG)<9 I DP<0 K DG S DQ=0 Q - S DQ="",DU=-2,DG="$D("_DIE_DA_",DU))" -Y S DQ=$O(DG(DQ)),DW=$P(DQ,";",2) G DE:$P(DQ,";")=DU - I DU'<0 S ^(DU)=DV,DU=-2 - G IX:DQ="" S DU=$P(DQ,";",1),DV="" I @DG S DV=^(DU) -DE I 'DW S DW=$E(DW,2,99),DE=DW-$L(DV)-1,%=$P(DW,",",2)+1,X=$E(DV,%,999),DV=$E(DV,0,DW-1)_$J("",$S(DE>0:DE,1:0))_DG(DQ) S:X'?." " DV=DV_$J("",%-DW-$L(DG(DQ)))_X G Y -PC S $P(DV,"^",DW)=DG(DQ) G Y - ; -IX S DICRREC="LOADXR^DIED",DQ=$O(DE(" ")) G E1:DQ="",E1:'$D(DG(DQ)) I $D(DE(DE(DQ)))#2 F DG=1:1 Q:'$D(DE(DQ,DG)) S DIC=DIE,X=DE(DE(DQ)) X DE(DQ,DG,2) - S X="" I DG(DQ)]"" F DG=1:1 Q:'$D(DE(DQ,DG)) S DIC=DIE,X=DG(DQ) X DE(DQ,DG,1) - D:$D(DIEFXREF) FIREFLD -E1 K DICRREC,DIFLD,DG,DB,DE,DIANUM S DQ=0 Q - ; -B ; - I '$D(DB(DQ)) S X="?BAD" G ^DIEQ - S DC=DQ,DIK="",DL=1 -OUT ; - D DIE1 S Y(DC)=DIK G UP:DL>1,Q:DC=0,QY - ; -E ; - I DP'<0 S DC=$S($D(X)#2:X,1:"") D DIE1 S X=DC G G:DI>0,UP:DL>1 -Q K Y -QY I $D(DTOUT),$D(DIEDA) D - . N % K DA - . F %=1:1 Q:'$D(DIEDA(%)) S DA(%)=DIEDA(%) - . S DA=DIEDA - . Q - K:$D(DTOUT) DG,DQ - I $D(DIETMP)#2 D FIREREC K @DIETMP,DIETMP - K DIEBADK,DIEFIRE,DIEXREF,DIEFXREF,DIIENS,DIE1,DIESP - K DIP,DB,DE,DM,DK,DL,DH,DU,DV,DW,DP,DC,DIK,DOV,DIEL,DIFLD Q - ; -M ; - S DD=X,DIC(0)="LM"_$S($D(DB(DQ)):"X",1:"QE"),DO(2)=$P(DC,"^",2),DO=$P($P(DQ(DQ),U)," ",2,99)_"^"_DO(2)_"^"_$P(DC,"^",4,5) D DOWN I @("'$D("_DIC_"0))") S ^(0)="^"_DO(2) - E I DO(2)["I" S %=0,DIC("W")="" D W^DIC1 - K DIC("PTRIX") M DIC("PTRIX")=DIE("PTRIX") -DIC S D="B",DLAYGO=DP\1,X=DD D K DIC("PTRIX") - .N DIETMP,DICR D X^DIC - I Y>0 S DA=+Y,DI=0,X=$P(Y,U,2) S:$D(DIETMP)#2 $P(DIIENS,",")=DA S:+DR=.01!(DR="")&$P(Y,U,3) DI=.01,DK=1,DM=$P($P(DR,";",1),":",2),DM=$S(DR="":9999999,DM="":+DR,1:DM) G D1 - S DI(DL-1)=DI(DL-1)_U K DUOUT,DTOUT G U1 - ; -DOWN D S,DIE1,DDA S DIE=DIC Q - ; -S ;CALLED BY O+1^DIE0 - S DIOV(DL)=$G(DOV,0) K DOV - S DIE1N(DL)=$G(DIE1N),DP(DL)=DP,DP=+$P(DC,"^",2),DI(DL)=$S(DV'["M":DI,$D(DSC(DP))!$D(DB(DQ)):DI,1:DI_U_$G(DQ(DQ,"CAPTION"))),DIE(DL)=DIE,DK(DL)=DK,DR(DL)=DR - S DM(DL)=DM,DK=0,DIE1(DL)=DIE1,DL=DL+1,DIE1=$S($G(DIE1N):DIE1N,1:DL),DIEL=DIEL+1,DM=9999999,DR="" - I $D(DR(DIE1,DP)) S DM=0,DR=DR(DIE1,DP) - Q - ; -DDA N T,X - S T=$T - F X=+$O(DA(" "),-1):-1:1 K DA(X+1) S:$D(DA(X))#2 DA(X+1)=DA(X) - K DA(1) S:$D(DA)#2 DA(1)=DA - S DIC=DIE_DA_","""_$P(DC,U,3)_"""," - S:$D(DIETMP)#2 DIIENS=","_DIIENS - I T - Q - ; -UDA N T,X - S T=$T - S DA=$G(DA(1)) ;K DA(1) - F X=2:1:+$O(DA(" "),-1) I $D(DA(X))#2 S DA(X-1)=DA(X) K DA(X) - S:$D(DIETMP)#2 DIIENS=$P(DIIENS,",",2,999) - I T - Q -N ; - D DOWN S DA=$P(DC,U,4),DI=.01 S:$D(DIETMP)#2 $P(DIIENS,",")=DA S ^DISV(DUZ,$E(DIC,1,28))=$E(DIC,29,999)_DA -D1 S @("D"_DIEL)=DA -G G MORE^DIE - ; -UP ; - Q:$D(DTOUT) - S DP(0)=DP_U_DK(DL-1) I $D(DIEC(DL)) D DIEC G U -U1 D UDA S DIEL=DIEL-1 -U S DQ=0,DL=DL-1,DIE1N=DIE1N(DL),DIE=DIE(DL),DM=DM(DL),DI=DI(DL),DP=DP(DL),DR=DR(DL),DK=DK(DL),DIE1=DIE1(DL) I $D(DIOV(DL)) S DOV=DIOV(DL) K DIOV(DL) - G G - ; -DIEC K DA S DA=DIEC(DL) F %=1:1 Q:'$D(DIEC(DL,%)) S DA(%)=DIEC(DL,%) - F DIEL=0:1 Q:'$D(DIEC(DL,0,DIEL)) S @("D"_DIEL)=DIEC(DL,0,DIEL) - S:$D(DIETMP)#2 DIIENS=DIEC(DL,"IENS") - S DIEL=DIEL-1 K DIEC(DL) - Q - ; -FIREFLD ;Fire field-level xrefs stored in DIEFXREF - D:$D(DIEFXREF)>2 FIRE^DIKC(DP,.DA,"KS","DIEFXREF","O","",$E("C",$G(DIOPER)="A")) - K DIEFXREF - Q - ; -FIREREC ;Fire record-level xrefs accumulated in ^TMP - Q:$D(DIETMP)[0 Q:$D(@DIETMP@("R"))<2 - N DP,DIIENS,DIE,DA,DIKEY,Y - ; - S DP=0 F S DP=$O(@DIETMP@("R",DP)) Q:'DP D - . S DIIENS=" " F S DIIENS=$O(@DIETMP@("R",DP,DIIENS)) Q:DIIENS="" D - .. D DA^DILF(DIIENS,.DA) - .. D FIRE^DIKC(DP,.DA,"KS",$NA(@DIETMP@("R")),"F^^K",.DIKEY,$E("C",$G(DIOPER)="A")) - ; - ;If any keys are invalid, restore values - D:$D(DIKEY)>9 RESTORE(.DIKEY,DIETMP) - ; - K DIEFIRE,@DIETMP@("R"),@DIETMP@("V") - Q - ; -RESTORE(DIKEY,DIETMP) ;Restore key fields to their pre-edited values - N DA - K DIEBADK - S:$D(DIEFIRE)#2 X="BADKEY" - ; - ;Set "write" and "restore" flags - N DIEWR,DIEREST - I '$D(ZTQUEUED),'$D(DDS),$D(DIEFIRE)[0!($G(DIEFIRE)["M") S DIEWR=1 - E S DIEWR=0 - I $D(DIEFIRE)#2,DIEFIRE'["R" S DIEREST=0 - E S DIEREST=1 - I '$G(DIEWR),'$G(DIEREST),$G(DIEFIRE)'["L" Q - ; - N DIEFDA,DIEKK,DIEMSG,DIFIL,DIFLD,DIFLDI,DIIENS,DIIENSA - N DINEW,DIOLD,DIRFIL,X - ; - ;Loop through all keys that are not unique and build FDA - K DIEFDA - S DIRFIL=0 F S DIRFIL=$O(DIKEY(DIRFIL)) Q:'DIRFIL D - . S DIEKK=0 F S DIEKK=$O(DIKEY(DIRFIL,DIEKK)) Q:'DIEKK D - .. Q:$D(^DD("KEY",DIEKK,0))[0 - .. K DIFLD - .. S DIFLDI=0 F S DIFLDI=$O(^DD("KEY",DIEKK,2,DIFLDI)) Q:'DIFLDI D - ... S DIFLD=$P($G(^DD("KEY",DIEKK,2,DIFLDI,0)),U),DIFIL=$P($G(^(0)),U,2) - ... Q:'DIFLD!'DIFIL - ... S DIFLD(DIFIL,DIFLD)=$$FLEVDIFF^DIKCU(DIRFIL,DIFIL) - .. S DIIENS=" " S DIIENS=$O(DIKEY(DIRFIL,DIEKK,DIIENS)) Q:DIIENS="" D - ... S DIFIL=0 F S DIFIL=$O(DIFLD(DIFIL)) Q:'DIFIL D - .... S DIFLD=0 F S DIFLD=$O(DIFLD(DIFIL,DIFLD)) Q:'DIFLD D - ..... Q:$D(^DD(DIFIL,DIFLD,0))[0 - ..... S DIIENSA=$P(DIIENS,",",DIFLD(DIFIL,DIFLD)+1,999) - ..... Q:$D(@DIETMP@("V",DIFIL,DIIENSA,DIFLD,"F"))[0!$D(^("4/")) S DIOLD=^("F") - ..... K DA D DA^DILF(DIIENSA,.DA) - ..... S X=$$DEC^DIKC2(DIFIL,DIFLD) Q:X="" X X S DINEW=X - ..... I DIEREST S DIEFDA(DIFIL,DIIENSA,DIFLD)=DIOLD - ..... I DIEWR!($G(DIEFIRE)["L") D - ...... S DIEBADK(DIRFIL,DIEKK,DIFIL,DIIENSA,DIFLD,"O")=DIOLD - ...... S DIEBADK(DIRFIL,DIEKK,DIFIL,DIIENSA,DIFLD,"N")=DINEW - ; - I DIEREST,$D(DIEFDA) D FILE^DIE("U","DIEFDA","DIEMSG") K DIERR - I DIEWR,$D(DIEBADK) D MSG^DIEKMSG(.DIEBADK,DIEREST) - ; - I $G(DIEFIRE)'["L" K DIEBADK - Q +DIE1 ;SFISC/GFT-FILE DATA, XREF IT, GO UP AND DOWN MULTIPLES ;2:51 PM 21 Oct 1999 + ;;22.0;VA FileMan;**1,4,11**;Mar 30, 1999 + ;Per VHA Directive 10-93-142, this routine should not be modified. + K DQ,DB G E1:$D(DG)<9 I DP<0 K DG S DQ=0 Q + S DQ="",DU=-2,DG="$D("_DIE_DA_",DU))" +Y S DQ=$O(DG(DQ)),DW=$P(DQ,";",2) G DE:$P(DQ,";",1)=DU + I DU'<0 S ^(DU)=DV,DU=-2 + G IX:DQ="" S DU=$P(DQ,";",1),DV="" I @DG S DV=^(DU) +DE I 'DW S DW=$E(DW,2,99),DE=DW-$L(DV)-1,%=$P(DW,",",2)+1,X=$E(DV,%,999),DV=$E(DV,0,DW-1)_$J("",$S(DE>0:DE,1:0))_DG(DQ) S:X'?." " DV=DV_$J("",%-DW-$L(DG(DQ)))_X G Y +PC S $P(DV,"^",DW)=DG(DQ) G Y + ; +IX S DICRREC="LOADXR^DIED",DQ=$O(DE(" ")) G E1:DQ="",E1:'$D(DG(DQ)) I $D(DE(DE(DQ)))#2 F DG=1:1 Q:'$D(DE(DQ,DG)) S DIC=DIE,X=DE(DE(DQ)) X DE(DQ,DG,2) + S X="" I DG(DQ)]"" F DG=1:1 Q:'$D(DE(DQ,DG)) S DIC=DIE,X=DG(DQ) X DE(DQ,DG,1) + D:$D(DIEFXREF) FIREFLD +E1 K DICRREC,DIFLD,DG,DB,DE,DIANUM S DQ=0 Q + ; +B ; + I '$D(DB(DQ)) S X="?BAD" G ^DIEQ + S DC=DQ,DIK="",DL=1 +OUT ; + D DIE1 S Y(DC)=DIK G UP:DL>1,Q:DC=0,QY + ; +E ; + I DP'<0 S DC=$S($D(X)#2:X,1:"") D DIE1 S X=DC G G:DI>0,UP:DL>1 +Q K Y +QY I $D(DTOUT),$D(DIEDA) D + . N % K DA + . F %=1:1 Q:'$D(DIEDA(%)) S DA(%)=DIEDA(%) + . S DA=DIEDA + . Q + K:$D(DTOUT) DG,DQ + I $D(DIETMP)#2 D FIREREC K @DIETMP,DIETMP + K DIEBADK,DIEFIRE,DIEXREF,DIEFXREF,DIIENS + K DIP,DB,DE,DM,DK,DL,DH,DU,DV,DW,DP,DC,DIK,DOV,DIEL,DIFLD Q + ; +M ; + S DD=X,DIC(0)="LM"_$S($D(DB(DQ)):"X",1:"QE"),DO(2)=$P(DC,"^",2),DO=$E($P(DQ(DQ),"^",1),8,99)_"^"_DO(2)_"^"_$P(DC,"^",4,5) D DOWN I @("'$D("_DIC_"0))") S ^(0)="^"_DO(2) + E I DO(2)["I" S %=0,DIC("W")="" D W^DIC1 + K DIC("PTRIX") M DIC("PTRIX")=DIE("PTRIX") + K DICR S D="B",DLAYGO=DP\1,X=DD D X^DIC K DIC("PTRIX") + I Y>0 S DA=+Y,DI=0,X=$P(Y,U,2) S:$D(DIETMP)#2 $P(DIIENS,",")=DA S:+DR=.01!(DR="")&$P(Y,U,3) DI=.01,DK=1,DM=$P($P(DR,";",1),":",2),DM=$S(DR="":9999999,DM="":+DR,1:DM) G D1 + S DI(DL-1)=DI(DL-1)_U K DUOUT,DTOUT G U1 + ; +DOWN D S,DIE1,DDA S DIE=DIC Q + ; +S S DIOV(DL)=$S('$D(DOV):0,1:DOV) K DOV + S DP(DL)=DP,DP=+$P(DC,"^",2),DI(DL)=$S(DV'["M":DI,$D(DSC(DP))!$D(DB(DQ)):DI,1:DI_U),DIE(DL)=DIE,DK(DL)=DK,DR(DL)=DR,DM(DL)=DM,DK=0,DL=DL+1,DIEL=DIEL+1,DM=9999999,DR="" I $D(DR(DL,DP)) S DM=0,DR=DR(DL,DP) + Q + ; +DDA N T,X + S T=$T + F X=+$O(DA(" "),-1):-1:1 K DA(X+1) S:$D(DA(X))#2 DA(X+1)=DA(X) + K DA(1) S:$D(DA)#2 DA(1)=DA + S DIC=DIE_DA_","""_$P(DC,U,3)_"""," + S:$D(DIETMP)#2 DIIENS=","_DIIENS + I T + Q + ; +UDA N T,X + S T=$T + S DA=$G(DA(1)) ;K DA(1) + F X=2:1:+$O(DA(" "),-1) I $D(DA(X))#2 S DA(X-1)=DA(X) K DA(X) + S:$D(DIETMP)#2 DIIENS=$P(DIIENS,",",2,999) + I T + Q +N ; + D DOWN S DA=$P(DC,U,4),DI=.01 S:$D(DIETMP)#2 $P(DIIENS,",")=DA S ^DISV(DUZ,$E(DIC,1,28))=$E(DIC,29,999)_DA +D1 S @("D"_DIEL)=DA +G G MORE^DIE + ; +UP ; + Q:$D(DTOUT) S DP(0)=DP I $D(DIEC(DL)) D DIEC G U +U1 D UDA S DIEL=DIEL-1 +U S DQ=0,DL=DL-1,DIE=DIE(DL),DM=DM(DL),DI=DI(DL),DP=DP(DL),DR=DR(DL),DK=DK(DL) I $D(DIOV(DL)) S DOV=DIOV(DL) K DIOV(DL) + G G + ; +DIEC K DA S DA=DIEC(DL) F %=1:1 Q:'$D(DIEC(DL,%)) S DA(%)=DIEC(DL,%) + F DIEL=0:1 Q:'$D(DIEC(DL,0,DIEL)) S @("D"_DIEL)=DIEC(DL,0,DIEL) + S:$D(DIETMP)#2 DIIENS=DIEC(DL,"IENS") + S DIEL=DIEL-1 K DIEC(DL) + Q + ; +FIREFLD ;Fire field-level xrefs stored in DIEFXREF + D:$D(DIEFXREF)>2 FIRE^DIKC(DP,.DA,"KS","DIEFXREF","O","",$E("C",$G(DIOPER)="A")) + K DIEFXREF + Q + ; +FIREREC ;Fire record-level xrefs accumulated in ^TMP + Q:$D(DIETMP)[0 Q:$D(@DIETMP@("R"))<2 + N DP,DIIENS,DIE,DA,DIKEY,Y + ; + S DP=0 F S DP=$O(@DIETMP@("R",DP)) Q:'DP D + . S DIIENS=" " F S DIIENS=$O(@DIETMP@("R",DP,DIIENS)) Q:DIIENS="" D + .. D DA^DILF(DIIENS,.DA) + .. D FIRE^DIKC(DP,.DA,"KS",$NA(@DIETMP@("R")),"F^^K",.DIKEY,$E("C",$G(DIOPER)="A")) + ; + ;If any keys are invalid, restore values + D:$D(DIKEY)>9 RESTORE(.DIKEY,DIETMP) + ; + K DIEFIRE,@DIETMP@("R"),@DIETMP@("V") + Q + ; +RESTORE(DIKEY,DIETMP) ;Restore key fields to their pre-edited values + N DA + K DIEBADK + S:$D(DIEFIRE)#2 X="BADKEY" + ; + ;Set "write" and "restore" flags + N DIEWR,DIEREST + I '$D(ZTQUEUED),'$D(DDS),$D(DIEFIRE)[0!($G(DIEFIRE)["M") S DIEWR=1 + E S DIEWR=0 + I $D(DIEFIRE)#2,DIEFIRE'["R" S DIEREST=0 + E S DIEREST=1 + I '$G(DIEWR),'$G(DIEREST),$G(DIEFIRE)'["L" Q + ; + N DIEFDA,DIEKK,DIEMSG,DIFIL,DIFLD,DIFLDI,DIIENS,DIIENSA + N DINEW,DIOLD,DIRFIL,X + ; + ;Loop through all keys that are not unique and build FDA + K DIEFDA + S DIRFIL=0 F S DIRFIL=$O(DIKEY(DIRFIL)) Q:'DIRFIL D + . S DIEKK=0 F S DIEKK=$O(DIKEY(DIRFIL,DIEKK)) Q:'DIEKK D + .. Q:$D(^DD("KEY",DIEKK,0))[0 + .. K DIFLD + .. S DIFLDI=0 F S DIFLDI=$O(^DD("KEY",DIEKK,2,DIFLDI)) Q:'DIFLDI D + ... S DIFLD=$P($G(^DD("KEY",DIEKK,2,DIFLDI,0)),U),DIFIL=$P($G(^(0)),U,2) + ... Q:'DIFLD!'DIFIL + ... S DIFLD(DIFIL,DIFLD)=$$FLEVDIFF^DIKCU(DIRFIL,DIFIL) + .. S DIIENS=" " S DIIENS=$O(DIKEY(DIRFIL,DIEKK,DIIENS)) Q:DIIENS="" D + ... S DIFIL=0 F S DIFIL=$O(DIFLD(DIFIL)) Q:'DIFIL D + .... S DIFLD=0 F S DIFLD=$O(DIFLD(DIFIL,DIFLD)) Q:'DIFLD D + ..... Q:$D(^DD(DIFIL,DIFLD,0))[0 + ..... S DIIENSA=$P(DIIENS,",",DIFLD(DIFIL,DIFLD)+1,999) + ..... Q:$D(@DIETMP@("V",DIFIL,DIIENSA,DIFLD,"F"))[0!$D(^("4/")) S DIOLD=^("F") + ..... K DA D DA^DILF(DIIENSA,.DA) + ..... S X=$$DEC^DIKC2(DIFIL,DIFLD) Q:X="" X X S DINEW=X + ..... I DIEREST S DIEFDA(DIFIL,DIIENSA,DIFLD)=DIOLD + ..... I DIEWR!($G(DIEFIRE)["L") D + ...... S DIEBADK(DIRFIL,DIEKK,DIFIL,DIIENSA,DIFLD,"O")=DIOLD + ...... S DIEBADK(DIRFIL,DIEKK,DIFIL,DIIENSA,DIFLD,"N")=DINEW + ; + I DIEREST,$D(DIEFDA) D FILE^DIE("U","DIEFDA","DIEMSG") K DIERR + I DIEWR,$D(DIEBADK) D MSG^DIEKMSG(.DIEBADK,DIEREST) + ; + I $G(DIEFIRE)'["L" K DIEBADK + Q diff --git a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIETED.m b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIETED.m index a7768ae2..8a452f57 100644 --- a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIETED.m +++ b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIETED.m @@ -1,153 +1,142 @@ -DIETED ;SFISC/GFT SCREEN-EDIT AN INPUT TEMPLATE ;22MAY2006 - ;;22.0;VA FileMan;**111,159**;Mar 30, 1999;Build 8 - ;Per VHA Directive 2004-038, this routine should not be modified. - N DIC,DIET,DRK,DIETED,I,J,DDSCHG - S DIC=.402,DIC(0)="AEQ" D ^DIC Q:Y<1 - S DIET=+Y D E - D PUT -K K ^UTILITY("DIETEDIAB",$J),^UTILITY("DIETED",$J) - Q - ; -EDIT(DIET) ; Edit Template using Screen Editor - N DRK,DIETED,I,J -E N DUOUT,DTOUT,DP,DI,D0,DIETROW,DIETEDER,DIETH,DR,F,L,DB - X ^%ZOSF("EON") - I '$D(^DIE(DIET,0)) W !,"NO TEMPLATE SELECTED",! Q - S DIETED="Input Template """_$P(^(0),U)_"""" - W "..." - D GET("^TMP(""DIETED"",$J)") - S DIETH="Editing "_DIETED,DIETROW=1,DRK=$P(^DIE(DIET,0),U,4) -DDW D EDIT^DDW("^TMP(""DIETED"",$J)","M",DIETH,"(File "_DRK_")",DIETROW) - I $D(DUOUT)!$D(DTOUT) K DR G KL - D K K I,J - D PROCESS("^TMP(""DIETED"",$J)") - X ^%ZOSF("EON") - S DIETROW=$O(DIETEDER(0)) I DIETROW S DIETH="ERROR! Re-editing "_DIETED K DIETEDER G DDW - S DDSCHG=1 -KL K ^TMP("DIETED",$J) - I '$D(DR) W $C(7),$$EZBLD^DIALOG(8077) Q - M ^UTILITY("DIETED",$J)=DR - Q - ; -GET(DIETA,DIT) ;put displayable template into @DIETA - N DIAO,DIETREL,DIETAD,DB,DIAT,I,J,L,DIAR,DIAB - K @DIETA - I '$D(DIT) S DIT=$NA(^DIE(DIET)) - S (DR,DIAT)="",(DIETAD,L,DIAO,DB,DIAR)=0,F=-1 - S J(0)=$P(@DIT@(0),U,4) - M DI=^("DIAB") S DI=J(0) - D DOWN -1 S Y=$P(DIAT,";",DB) I "Q"[Y G NDB:Y="" S DB=DB+1 G 1 - S %=+Y I Y?.NP,$P(Y,":",2),Y'["/" S Y=+Y_"-"_$P(Y,":",2),%="" - I %_"T~"=Y!(%_"t~"=Y),$P($G(^DD(DI,%,0)),U,2) S Y=% ;HWH-1103-40934 -- ignore TITLE of MULTIPLE - S DIETREL="",DIAB=$G(DI(DB,DIAR-1,DI,DIAO)) E S:Y?1"^".E DIETREL=Y S:DIAB]"" Y=DIAB - I Y?1"]".E S Y=$E(Y,2,999) - I DIAB="",%,$D(^DD(DI,%,0)) S Y=$P(^(0),U)_$P(Y,%,2,999) - S DB=DB+1,DIETAD=DIETAD+1,@DIETA@(DIETAD)=$J("",F*3)_Y I DIETREL]"" D G 1 ;Put it in! - .S L=L\100+1*100,(J(L),DI)=$P(DIETREL,U,2) D DOWN ;Relational jump - I % S %=+$P($G(^DD(DI,%,0)),U,2) I %,$P($G(^DD(%,.01,0)),U,2)'["W" S L=L+1,(J(L),DI)=% D DOWN ;Down to a multiple - I Y="ALL" G UP - G 1 - ; -DOWN S F=F+1,DIAR(F)=DIAR,DIAR=DIAR+1,%=$P(DIAT,";",DB) S:%?1"^"1.NP DB=DB+1,DIAR=$P(%,U,2) - S DB(F)=DB,DB=1,DIAO(F)=DIAO,DIAO=0 -DIAT S DIAT=$G(@DIT@("DR",DIAR,DI),"ALL") Q - ; -NDB I DIAO'<0 S DIAO=DIAO+1 I $D(@DIT@("DR",DIAR,DI,DIAO)) S DIAT=^(DIAO),DB=1 G 1 - S DIAO=-1 -UP Q:'F K I(L),J(L) S L=$O(J(L),-1) - S DIAR=DIAR(F),DB=DB(F),DIAO=DIAO(F),DI=J(L),DIAT=$S(DIAO<0:"",DIAO:@DIT@("DR",DIAR,J(L),DIAO),1:$G(@DIT@("DR",DIAR,DI))),F=F-1 G 1 - ; - ; - ; - ; -PROCESS(DIETA) ;puts nodes into ^UTILITY("DIETED") - N DIAB,LINE,DXS,L,DIAP,DIETSL,DQI,DIETSAVE,DIETAB,ERR,DIAR - K DR S F=0,(DI,J(0))=DRK,I(0)=^DIC(J(0),0,"GL"),DIAP="",(L,DIETAB)=0,DXS=1,DIAR=1 - F LINE=1:1 Q:'$D(@DIETA@(LINE)) K ERR S X=^(LINE) D - .I X?1"^".E S LINE=999999999 K DR Q - .D LINE(X) - .I $D(ERR) W "LINE ",LINE S DIETEDER(LINE)=ERR,LINE=-LINE Q ;stop if we find one error - I LINE<0 W " ERROR!" - Q - ; -LINE(X) ;Process one LINE from the screen - N D,DIC,DICMX,DV,DATE,Y,DICOMPX,DICOMP,DRR - F D=$L(X):-1:1 Q:$A(X,D)>32 S X=$E(X,1,D-1) - F D=0:1 Q:$A(X)-32 S X=$E(X,2,999) ;strip off 'D' leading spaces - Q:X="" -OUT I DX D G X:Y="",DR - .N D,DA,DG S D(F)=J D RANGE^DIA1 S Y=DA -SEMIC I X[";" S Y=X,X=$P(X,";") D G X:'$D(Y) S DIAB=Y - .F %=2:1:$L(Y,";") S D=$P(Y,";",%),D=$S(D="DUP":"d",D="REQ":"R","""R""d"""[D:"",$A(D)=34:$E(D,2,$F(D,"""",2)-2),D="T":D,1:""),DV=D_$C(126)_DV I $A(D)>45&($A(D)<58)!(D[":")!(D="") K Y Q -DIC S DIC(0)="OZ",DIC="^DD(DI," D ^DIC - I Y>0 S Y=+Y_DV D DR S %=+$P(Y(0),U,2) D:% Q - .I $P($G(^DD(+%,.01,0)),U,2)["W" Q - .S L=L+1,(DI,J(L))=+%,I(L)=""""_$P($P(Y(0),U,4),";")_"""" D D - S (Y,DIETSAVE)=X I DUZ(0)="@",X'?.E1":" S X=$S(X["//^":$P(X,"//^",2),1:X),X=$S(X[";":$P(X,";"),1:X) D ^DIM G:$D(X) DR:X=DIETSAVE I DIETSAVE["//^",'$D(X) G X - F DIETSL="///+","//+","///","//" I DIETSAVE[DIETSL S DP=$P(DIETSAVE,DIETSL,2,9) I DP'?1"/".E&(DP'?1"^".E)!(DUZ(0)="@") G DEF - I DIETSAVE?.E1":" S:'$D(DIAB) DIAB=DIETSAVE K X S X=DIETSAVE,DICOMP=L_"WE",DQI="Y(",DA="DR(99,"_DXS_",",DICMX=1 D ^DICOMPW G L:$D(X) ;as in E^DIA3 -X S ERR=1 Q - ; -L I $D(X)>1 M DR(99,DXS)=X S DXS=DXS+1 - S %=-1,L=$S(Y>L:+Y,1:L\100+1*100),Y=U_DP_U_U_X_" S X=$S(D(0)>0:D(0),1:"""")" K X - D DR S DI=+DP D D - Q - ; -D N % S F=F+1,DIAR(F)=DIAR F %=F+1:.01 Q:'$D(DR(%,DI)) - S:%["." @DRR=@DRR_U_%_";",DIAP=DIAP+1 S DIAR=% - S DIAP(F)=DIAP,DIAP=0,DIETAB(F)=DIETAB Q - ; -DEF S X=DIETSAVE D S X=$P(DIETSAVE,DIETSL),DV=DV_DIETSL_DP G X:DV[";",DIC ;as in DEF^DIA3 - .S X="DA,DV,DWLC,0)=X" F J=L:-1 Q:I(J)[U S X="DA("_(L-J+1)_"),"_I(J)_","_X - .S DICMX="S DWLC=DWLC+1,"_I(J)_X,DA="DR(99,"_DXS_",",X=DP,DQI="X(",DICOMP=L_"T" - .D EN^DICOMP,DICS^DIA -XEC .I $D(X),Y["m" S DIC("S")="S %=$P(^(0),U,2) I %,$D(^DD(+%,.01,0)),$P(^(0),U,2)[""W"",$D(^DD(DI,Y,0)) "_DIC("S") ;as in XEC^DIA3 - .S Y=0 F S Y=$O(X(Y)) Q:Y="" S @(DA_"Y)=X(Y)") - .S Y=-1 I $D(X) S Y="Q",DXS=DXS+1,DP=U_X D - ..D S:'$D(DIAB) DIAB=DIETSAVE ;assume "YOU MEAN as a VARIABLE" - ...N DIAB D DR - .I DP="@",DIETSL="//" S DA=U_U - .Q - ; -DR ;takes 'Y' and puts it into 'DR' array - N %,B - S (DRR,B)=$NA(DR(DIAR,DI)),%=$O(@DRR@(""),-1) - I % S DRR=$NA(@DRR@(%)) - I '$D(@DRR) S @DRR="",DIAP=0 - I $L(Y)+$L(@DRR)>230 S DRR=$NA(@B@(%+1)),DIAP=DIAP\1000+1*1000,@DRR="" - S @DRR=@DRR_Y_";" - S DIAP=DIAP+1 -DIAB I $D(DIAB) S ^UTILITY("DIETEDIAB",$J,DIAP#1000,DIAR-1,DI,DIAP\1000)=DIAB K DIAB - Q - ; -PUT ;save template - I '$D(^UTILITY("DIETED",$J)) Q - N DIC - S DIC("B")=DIET -SAVEAS S DIC=.402,DIC("A")="Save revised "_DIETED_" as: ",DIC(0)="AEQL",DIC("S")="I $P(^(0),U,4)=DRK" - D ^DIC - Q:Y<0 I $O(^DIE(+Y,0))]"" W !,$C(7),"Are you sure you want to overwrite this '",$P(Y,U,2)," 'Template" S %=1 D YN^DICN I %-1 Q:%<2 K DIC("B") G SAVEAS - L +^DIE(+Y) - S ^DIE("F"_J(0),$P(Y,U,2),+Y)=1 - S $P(^DIE(+Y,0),U,4)=J(0) - L -^DIE(+Y) - D SAVEFLDS(+Y) - Q - ; -SAVEFLDS(Y) ; - N X,DP,DMAX - Q:'$D(^UTILITY("DIETED",$J))!'$G(Y) -NOW D NOW^%DTC S $P(^DIE(Y,0),U,2)=+$J(%,0,4) - S $P(^DIE(Y,0),U,5)=$G(DUZ) - K ^DIE(Y,"DR") M ^DIE(+Y,"DR")=^UTILITY("DIETED",$J) - K ^DIE(Y,"DIAB") M ^DIE(+Y,"DIAB")=^UTILITY("DIETEDIAB",$J) - S X=$S('$D(^DIE(+Y,"ROU")):1,^("ROU")'[U:1,$D(^("ROUOLD")):^("ROUOLD"),1:1),DP=+$P(^(0),U,4),DMAX=^DD("ROU") I X'=1,$D(^DD("OS",DISYS,"ZS")) D EN^DIEZ - D K - Q +DIETED ;SFISC/GFT SCREEN-EDIT AN INPUT TEMPLATE ;07:04 PM 15 Jul 2002 + ;;22.0;VA FileMan;**111**;Mar 30, 1999 + ;Per VHA Directive 10-93-142, this routine should not be modified. + N DIC,DIET,DRK,DIETED,I,J,DDSCHG + S DIC=.402,DIC(0)="AEQ" D ^DIC Q:Y<1 + S DIET=+Y D E + D PUT +K K ^UTILITY("DIETEDIAB",$J),^UTILITY("DIETED",$J) + Q + ; +EDIT(DIET) ; Edit Template using Screen Editor + N DRK,DIETED,I,J +E N DUOUT,DTOUT,DP,DI,D0,DIETROW,DIETEDER,DIETH,DR,F,L,DB + X ^%ZOSF("EON") + I '$D(^DIE(DIET,0)) W !,"NO TEMPLATE SELECTED",! Q + S DIETED="Input Template """_$P(^(0),U)_"""" + W "..." + D GET("^TMP(""DIETED"",$J)") + S DIETH="Editing "_DIETED,DIETROW=1,DRK=$P(^DIE(DIET,0),U,4) +DDW D EDIT^DDW("^TMP(""DIETED"",$J)","M",DIETH,"(File "_DRK_")",DIETROW) + I $D(DUOUT)!$D(DTOUT) K DR G KL + D K K I,J + D PROCESS("^TMP(""DIETED"",$J)") + X ^%ZOSF("EON") + S DIETROW=$O(DIETEDER(0)) I DIETROW S DIETH="ERROR! Re-editing "_DIETED K DIETEDER G DDW + S DDSCHG=1 +KL K ^TMP("DIETED",$J) + I '$D(DR) W $C(7),$$EZBLD^DIALOG(8077) Q + M ^UTILITY("DIETED",$J)=DR + Q + ; +GET(DIETA) ;put displayable template into @DIETA + N DIAO,DIETREL,DIETAD,DB,DIAT,I,J,L + K @DIETA + S DR="",(DIETAD,L,DIAO,DB)=0,F=-1 + S (DI,J(0))=$P(^DIE(DIET,0),U,4) + M DI=^("DIAB") + D DOWN +1 S Y=$P(DIAT,";",DB) I "Q"[Y G NDB:Y="" S DB=DB+1 G 1 + S %=+Y I Y?.NP,$P(Y,":",2),Y'["/" S Y=+Y_"-"_$P(Y,":",2),%="" + S DIETREL="" I $D(DI(DB,F,DI,DIAO)) S:Y?1"^".E DIETREL=Y S Y=DI(DB,F,DI,DIAO),%=+Y + I Y?1"]".E S Y=$E(Y,2,999) + I %,$D(^DD(DI,%,0)) S Y=$P(^(0),U)_$P(Y,%,2,999) + S DB=DB+1,DIETAD=DIETAD+1,@DIETA@(DIETAD)=$J("",F*3)_Y I DIETREL]"" D G 1 + .S L=L\100+1*100,(J(L),DI)=$P(DIETREL,U,2) D DOWN + I % S %=+$P($G(^DD(DI,%,0)),U,2) I %,$P($G(^DD(%,.01,0)),U,2)'["W" S L=L+1,(J(L),DI)=% D DOWN + I Y="ALL" G UP + G 1 +DOWN S F=F+1,DB(F)=DB,DB=1,DIAO(F)=DIAO,DIAO=0 +DIAT S DIAT=$G(^DIE(DIET,"DR",F+1,DI),"ALL") Q + ; +NDB I DIAO'<0 S DIAO=DIAO+1 I $D(^DIE(DIET,"DR",F+1,DI,DIAO)) S DIAT=^(DIAO),DB=1 G 1 + S DIAO=-1 +UP Q:'F K I(L),J(L) S L=$O(J(L),-1) + S DB=DB(F),DIAO=DIAO(F),DI=J(L),DIAT=$S(DIAO<0:"",DIAO:^DIE(DIET,"DR",F,J(L),DIAO),1:$G(^DIE(DIET,"DR",F,DI))),F=F-1 G 1 + ; +PROCESS(DIETA) ;puts nodes into ^UTILITY("DIETED") + N DIAB,LINE,DXS,L,DIAP,DIETSL,DQI,DIETSAVE,DIETAB,ERR + K DR S F=0,(DI,J(0))=DRK,I(0)=^DIC(J(0),0,"GL"),DIAP="",(L,DIETAB)=0,DXS=1 + F LINE=1:1 Q:'$D(@DIETA@(LINE)) K ERR S X=^(LINE) D + .I X?1"^".E S LINE=999999999 K DR Q + .D LINE(X) + .I $D(ERR) W "LINE ",LINE S DIETEDER(LINE)=ERR,LINE=-LINE Q ;stop if we find one error + I LINE<0 W " ERROR!" + Q +LINE(X) ;Process one LINE from the screen + N D,DIC,DICMX,DV,DATE,Y,DICOMPX,DICOMP + F D=$L(X):-1:1 Q:$A(X,D)>32 S X=$E(X,1,D-1) + F D=0:1 Q:$A(X)-32 S X=$E(X,2,999) ;strip off 'D' leading spaces + Q:X="" + I DX D G X:Y="",DR + .N D,DA,DG S D(F)=J D RANGE^DIA1 S Y=DA +SEMIC I X[";" S Y=X,X=$P(X,";") D G X:'$D(Y) S DIAB=Y + .F %=2:1:$L(Y,";") S D=$P(Y,";",%),D=$S(D="DUP":"d",D="REQ":"R","""R""d"""[D:"",$A(D)=34:$E(D,2,$F(D,"""",2)-2),1:D),DV=D_$C(126)_DV I $A(D)>45&($A(D)<58)!(D[":")!(D="") K Y Q +DIC S DIC(0)="OZ",DIC="^DD(DI," D ^DIC + I Y>0 S Y=+Y_DV D DR S %=+$P(Y(0),U,2) D:% Q + .I $P($G(^DD(+%,.01,0)),U,2)["W" Q + .S L=L+1,(DI,J(L))=+%,I(L)=""""_$P($P(Y(0),U,4),";")_"""" D D + S (Y,DIETSAVE)=X I DUZ(0)="@",X'?.E1":" S X=$S(X["//^":$P(X,"//^",2),1:X),X=$S(X[";":$P(X,";"),1:X) D ^DIM G:$D(X) DR:X=DIETSAVE I DIETSAVE["//^",'$D(X) G X + F DIETSL="///+","//+","///","//" I DIETSAVE[DIETSL S DP=$P(DIETSAVE,DIETSL,2,9) I DP'?1"/".E&(DP'?1"^".E)!(DUZ(0)="@") G DEF + I DIETSAVE?.E1":" S:'$D(DIAB) DIAB=DIETSAVE K X S X=DIETSAVE,DICOMP=L_"WE",DQI="Y(",DA="DR(99,"_DXS_",",DICMX=1 D ^DICOMPW G L:$D(X) ;as in E^DIA3 +X S ERR=1 Q + ; +L I $D(X)>1 M DR(99,DXS)=X S DXS=DXS+1 + S %=-1,L=$S(Y>L:+Y,1:L\100+1*100),Y=U_DP_U_U_X_" S X=$S(D(0)>0:D(0),1:"""")" K X + D DR,D + S DI=+DP Q + ; +D S F=F+1,DIAP(F)=DIAP,DIAP=0 Q + ; +DEF S X=DIETSAVE D S X=$P(DIETSAVE,DIETSL),DV=DV_DIETSL_DP G X:DV[";",DIC ;as in DEF^DIA3 + .S X="DA,DV,DWLC,0)=X" F J=L:-1 Q:I(J)[U S X="DA("_(L-J+1)_"),"_I(J)_","_X + .S DICMX="S DWLC=DWLC+1,"_I(J)_X,DA="DR(99,"_DXS_",",X=DP,DQI="X(",DICOMP=L_"T" + .D EN^DICOMP,DICS^DIA +XEC .I $D(X),Y["m" S DIC("S")="S %=$P(^(0),U,2) I %,$D(^DD(+%,.01,0)),$P(^(0),U,2)[""W"",$D(^DD(DI,Y,0)) "_DIC("S") ;as in XEC^DIA3 + .S Y=0 F S Y=$O(X(Y)) Q:Y="" S @(DA_"Y)=X(Y)") + .S Y=-1 I $D(X) S Y="Q",DXS=DXS+1,DP=U_X D + ..D S:'$D(DIAB) DIAB=DIETSAVE ;assume "YOU MEAN as a VARIABLE" + ...N DIAB D DR + .I DP="@",DIETSL="//" S DA=U_U + .Q + ; +DR ;takes 'Y' and puts it into 'DR' array + N %,N,B + S (N,B)=$NA(DR(F+1,DI)),%=$O(@N@(""),-1) + I % S N=$NA(@N@(%)) + I '$D(@N) S @N="",DIAP=0 + I $L(Y)+$L(@N)>230 S N=$NA(@B@(%+1)),DIAP=DIAP\1000+1*1000,@N="" + S @N=@N_Y_";" + S DIAP=DIAP+1 +DIAB I $D(DIAB) S ^UTILITY("DIETEDIAB",$J,DIAP#1000,F,DI,DIAP\1000)=DIAB K DIAB + Q + ; +PUT ;save template + I '$D(^UTILITY("DIETED",$J)) Q + N DIC + S DIC("B")=DIET +SAVEAS S DIC=.402,DIC("A")="Save revised "_DIETED_" as: ",DIC(0)="AEQL",DIC("S")="I $P(^(0),U,4)=DRK" + D ^DIC + Q:Y<0 I $O(^DIE(+Y,0))]"" W !,$C(7),"Are you sure you want to overwrite this '",$P(Y,U,2)," 'Template" S %=1 D YN^DICN I %-1 Q:%<2 K DIC("B") G SAVEAS + L +^DIE(+Y) + S ^DIE("F"_J(0),$P(Y,U,2),+Y)=1 + S $P(^DIE(+Y,0),U,4)=J(0) + L -^DIE(+Y) + D SAVEFLDS(+Y) + Q + ; +SAVEFLDS(Y) ; + N X,DP,DMAX + Q:'$D(^UTILITY("DIETED",$J))!'$G(Y) +NOW D NOW^%DTC S $P(^DIE(Y,0),U,2)=+$J(%,0,4) + S $P(^DIE(Y,0),U,5)=$G(DUZ) + K ^DIE(Y,"DR") M ^DIE(+Y,"DR")=^UTILITY("DIETED",$J) + K ^DIE(Y,"DIAB") M ^DIE(+Y,"DIAB")=^UTILITY("DIETEDIAB",$J) + S X=$S('$D(^DIE(+Y,"ROU")):1,^("ROU")'[U:1,$D(^("ROUOLD")):^("ROUOLD"),1:1),DP=+$P(^(0),U,4),DMAX=^DD("ROU") I X'=1,$D(^DD("OS",DISYS,"ZS")) D EN^DIEZ + D K + Q diff --git a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIEZ.m b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIEZ.m index 460da6e8..e686ca48 100644 --- a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIEZ.m +++ b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIEZ.m @@ -1,97 +1,97 @@ -DIEZ ;SFISC/GFT-COMPILE INPUT TEMPLATE ;13SEP2004 - ;;22.0;VA FileMan;**1,11,159**;Mar 30, 1999;Build 8 - ;Per VHA Directive 2004-038, this routine should not be modified. - I $G(DUZ(0))'="@" W $C(7),$$EZBLD^DIALOG(101) G K -EN1 D:'$D(DISYS) OS^DII I '$D(^DD("OS",DISYS,"ZS")) W $$EZBLD^DIALOG(820),$C(7) G K - S U="^" S:'$G(DTIME) DTIME=300 N L,DNM - D SIZ^DIPZ0(8033) G:$D(DTOUT)!($D(DUOUT))!('X) K S DMAX=X Q:$D(DIX) -TEM K DIC S DIC="^DIE(",DIC(0)="AEQ",DIC("W")="W ?40,""FILE #"",$P(^(0),U,4) W:$D(^(""ROU"")) ?60,^(""ROU"")",DIC("S")="I Y'<1" D ^DIC G:'$D(^DIE(+Y,"DR")) K S DIPZ=+Y - D RNM^DIPZ0(8033) G:$D(DTOUT)!($D(DUOUT))!(X="") K S DNM=X K DIC - W ! S DIR(0)="Y",DIR("A")=$$EZBLD^DIALOG(8020) D ^DIR K DIR G:'Y!($D(DIRUT)) K - S X=DNM,Y=DIPZ K DIPZ -EN ; - W:'$G(DIEZS) ! K ^UTILITY($J),DRN N L,DIEZQ,DIR S DMAX=DMAX-2150,DNM=X,DIEZ=+Y,DRN="",DRD=0,DIEZQ=0 - S DP=$P(^DIE(DIEZ,0),U,4),DIE=^DIC(DP,0,"GL") - I '$D(^DIE(DIEZ,"DR",1,DP)) S ^DIE(DIEZ,"DR",1,DP)=^DIE(DIEZ,"DR") - D DT^DICRW S X=-1 - K T S T(1)=$P(^DIE(DIEZ,0),U),T(2)=$$EZBLD^DIALOG(8033),T(3)=DP D BLD^DIALOG(8024,.T,"","DIR") W:'$G(DIEZS) !,DIR K T - D UNCAF(DIEZ) - K DOV,^DIE(DIEZ,"RD"),DR S DR=^("DR",1,DP),(DIER,DL)=1,DIEZL=0,DIEZAB=U - D NEWROU F %=0:0 S %=$O(^DIE(DIEZ,"DR",99,%)) Q:%="" F %Y=0:0 S %Y=$O(^DIE(DIEZ,"DR",99,%,%Y)) Q:%Y="" S F=0,Q=^DIE(DIEZ,"DR",99,%,%Y) D QFF^DIEZ2 S X=" S DR(99,"_%_","_%Y_")="_Q D L^DIEZ2 - S X=" N DIEZTMP,DIEZAR,DIEZRXR,DIIENS,DIXR K DIEFIRE,DIEBADK S DIEZTMP=$$GETTMP^DIKC1(""DIEZ"")" D L^DIEZ2 - S X=" M DIEZAR=^DIE("_DIEZ_",""AR"") S DICRREC=""TRIG^DIE17""" D L^DIEZ2 - N DIEZTMP S DIEZTMP=$$GETTMP^DIKC1("DIEZ") - S X=" S:$D(DTIME)[0 DTIME=300 S D0=DA,DIIENS=DA_"","",DIEZ="_DIEZ_",U=""^""" G ^DIEZ0 - ; -NEWROU ; - K ^UTILITY($J,0) S DQ=0,T=99,L=3 - S ^UTILITY($J,0,1)=DNM_DRN_" ; "_$P("GENERATED FROM '"_$P(^DIE(DIEZ,0),U,1)_"' INPUT TEMPLATE(#"_DIEZ_"), FILE "_DP,U,DRN="")_";"_$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3) - S ^UTILITY($J,0,2)=" D DE G BEGIN" - S ^UTILITY($J,0,3)="BEGIN S DNM="""_DNM_DRN_""",DQ=1" - I '$D(DRN(+DRN)) S DRN(+DRN)=U - Q - ; -EN2(Y,DIEZFLGS,X,DMAX,DIEZRLA,DIEZZMSG) ;Silent or Talking with parameter passing - ;and optionally return list of routines built and if successful - ;IEN,FLAGS,ROUTINE,RTNMAXSIZE,RTNLISTARRAY,MSGARRAY - ;Y=TEMPLATE IEN (required) - ;FLAGS="T"alk (optional) - ;X=ROUTINE NAME (required) - ;DMAX=ROUTINE SIZE (optional) - ;DIEZRLA=ROUTINE LIST ARRAY, by value (optional) - ;DIEZZMSG=MESSAGE ARRAY (optional) (default ^TMP) - ;* - ;DIEZS will be used to indicate "silent" if set to 1 - ;Write statements are made conditional, if not "silent" - ;* - N DIEZS,DNM,DIQUIET,DIEZRIEN,DIEZRLAZ,DIEZRLAF - N DIK,DIC,%I,DICS - S DIEZS=$G(DIEZFLGS)'["T" - S:DIEZS DIQUIET=1 - I '$D(DIFM) N DIFM S DIFM=1 D - .N Y,DIEZFLGS,X,DMAX,DIEZRLA,DIEZS - .D INIZE^DIEFU - I $G(Y)'>0 D BLD^DIALOG(1700,"IEN for Edit Template missing or invalid") G EN2E - I '$D(^DIE(Y,0)) D BLD^DIALOG(1700,"No Edit Template on file with IEN="_Y) G EN2E - I $G(X)']"" D BLD^DIALOG(1700,"Routine name missing this Edit Template, IEN="_Y) G EN2E - I X'?1U.NU&(X'?1"%"1U.NU) D BLD^DIALOG(1700,"Routine name invalid") G EN2E - I $L(X)>7 D BLD^DIALOG(1700,"Routine name too long") G EN2E - S DIEZRLA=$G(DIEZRLA,"DIEZRLAZ"),DIEZRIEN=Y - S:DIEZRLA="" DIEZRLA="DIEZRLAZ" S:$G(DMAX)<2500!($G(DMAX)>^DD("ROU")) DMAX=^DD("ROU") - S DIEZRLAF="" - K @DIEZRLA - D EN - G:'DIEZS!(DIEZRLAF) EN2E - D BLD^DIALOG(1700,"Compiling Edit Template (IEN="_DIEZRIEN_")"_$S(DIEZRLAF=0:", routine name too long",1:"")) -EN2E I 'DIEZS D MSG^DIALOG() Q - I $G(DIEZZMSG)]"" D CALLOUT^DIEFU(DIEZZMSG) - Q - ; -RECOMP S DIX=1 D DIEZ Q:'$D(DIX) N DIMAX S DIMAX=DMAX - F DIX=0:0 S DIX=$O(^DIE(DIX)) Q:DIX'>0 I $D(^(DIX,0)),$D(^("ROU")) S %=$P(^(0),"^",1),X=$E(^("ROU"),2,99) I X]"" S Y=DIX,DMAX=DIMAX D EN - ; -K K %,DDH,DIC,DIX,DIPZ,DMAX,DNM,DTOUT,DIRUT,DIROUT,DUOUT,X,Y Q - ;DIALOG #101 'only those with programmer's access' - ; #820 'no way to save routines on the system' - ; #8020 'Should the compilation run now?' - ; #8024 'Compiling template name Input template of file n' - ; #8033 'Input template' -UNCAF(DIEZ) ; - ; for one compiled input template (DIEZ), delete its "AF" entries - N %,X S X="" - F S X=$O(^DIE("AF",X)) Q:X="" K:'X ^(X,DIEZ) S %=0 F S %=$O(^DIE("AF",X,%)) Q:%'>0 K:$D(^(%,DIEZ)) ^(DIEZ) - Q - ; -UNC(DIEZ,DIFLAGS) ; - ; DBS: silent entry point to uncompile an input template - ; DIEZ = IEN of input template to uncompile - ; DIFLAGS = flags: - ; D = compiled routines are also deleted - K ^DIE(DIEZ,"ROU") - D UNCAF(DIEZ) - I $G(DIFLAGS)["D" D - . N DINAME S DINAME=$G(^DIE(DIEZ,"ROUOLD")) Q:DINAME="" - . N DIROU,DISUF F DISUF="",1:1 D Q:DIROU="" - . . S DIROU=DINAME_DISUF I '$$ROUEXIST^DILIBF(DIROU) S DIROU="" Q - . . N X S X=DIROU X ^%ZOSF("DEL") - Q +DIEZ ;SFISC/GFT-COMPILE INPUT TEMPLATE ;2:00 PM 30 Jul 1999 + ;;22.0;VA FileMan;**1,11**;Mar 30, 1999 + ;Per VHA Directive 10-93-142, this routine should not be modified. + I $G(DUZ(0))'="@" W $C(7),$$EZBLD^DIALOG(101) G K +EN1 D:'$D(DISYS) OS^DII I '$D(^DD("OS",DISYS,"ZS")) W $$EZBLD^DIALOG(820),$C(7) G K + S U="^" S:'$G(DTIME) DTIME=300 N L,DNM + D SIZ^DIPZ0(8033) G:$D(DTOUT)!($D(DUOUT))!('X) K S DMAX=X Q:$D(DIX) +TEM K DIC S DIC="^DIE(",DIC(0)="AEQ",DIC("W")="W ?40,""FILE #"",$P(^(0),U,4) W:$D(^(""ROU"")) ?60,^(""ROU"")",DIC("S")="I Y'<1" D ^DIC G:'$D(^DIE(+Y,"DR")) K S DIPZ=+Y + D RNM^DIPZ0(8033) G:$D(DTOUT)!($D(DUOUT))!(X="") K S DNM=X K DIC + W ! S DIR(0)="Y",DIR("A")=$$EZBLD^DIALOG(8020) D ^DIR K DIR G:'Y!($D(DIRUT)) K + S X=DNM,Y=DIPZ K DIPZ +EN ; + W:'$G(DIEZS) ! K ^UTILITY($J),DRN N L,DIEZQ,DIR S DMAX=DMAX-2150,DNM=X,DIEZ=+Y,DRN="",DRD=0,DIEZQ=0 + S DP=$P(^DIE(DIEZ,0),U,4),DIE=^DIC(DP,0,"GL") + I '$D(^DIE(DIEZ,"DR",1,DP)) S ^DIE(DIEZ,"DR",1,DP)=^DIE(DIEZ,"DR") + D DT^DICRW S X=-1 + K T S T(1)=$P(^DIE(DIEZ,0),U),T(2)=$$EZBLD^DIALOG(8033),T(3)=DP D BLD^DIALOG(8024,.T,"","DIR") W:'$G(DIEZS) !,DIR K T + D UNCAF(DIEZ) + K DOV,^DIE(DIEZ,"RD"),DR S DR=^("DR",1,DP),DL=1,DIEZL=0,DIEZAB=U + D NEWROU F %=0:0 S %=$O(^DIE(DIEZ,"DR",99,%)) Q:%="" F %Y=0:0 S %Y=$O(^DIE(DIEZ,"DR",99,%,%Y)) Q:%Y="" S F=0,Q=^DIE(DIEZ,"DR",99,%,%Y) D QFF^DIEZ2 S X=" S DR(99,"_%_","_%Y_")="_Q D L^DIEZ2 + S X=" N DIEZTMP,DIEZAR,DIEZRXR,DIIENS,DIXR K DIEFIRE,DIEBADK S DIEZTMP=$$GETTMP^DIKC1(""DIEZ"")" D L^DIEZ2 + S X=" M DIEZAR=^DIE("_DIEZ_",""AR"") S DICRREC=""TRIG^DIE17""" D L^DIEZ2 + N DIEZTMP S DIEZTMP=$$GETTMP^DIKC1("DIEZ") + S X=" S:$D(DTIME)[0 DTIME=300 S D0=DA,DIIENS=DA_"","",DIEZ="_DIEZ_",U=""^""" G ^DIEZ0 + ; +NEWROU ; + K ^UTILITY($J,0) S DQ=0,T=99,L=3 + S ^UTILITY($J,0,1)=DNM_DRN_" ; "_$P("GENERATED FROM '"_$P(^DIE(DIEZ,0),U,1)_"' INPUT TEMPLATE(#"_DIEZ_"), FILE "_DP,U,DRN="")_";"_$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3) + S ^UTILITY($J,0,2)=" D DE G BEGIN" + S ^UTILITY($J,0,3)="BEGIN S DNM="""_DNM_DRN_""",DQ=1" + I '$D(DRN(+DRN)) S DRN(+DRN)=U + Q + ; +EN2(Y,DIEZFLGS,X,DMAX,DIEZRLA,DIEZZMSG) ;Silent or Talking with parameter passing + ;and optionally return list of routines built and if successful + ;IEN,FLAGS,ROUTINE,RTNMAXSIZE,RTNLISTARRAY,MSGARRAY + ;Y=TEMPLATE IEN (required) + ;FLAGS="T"alk (optional) + ;X=ROUTINE NAME (required) + ;DMAX=ROUTINE SIZE (optional) + ;DIEZRLA=ROUTINE LIST ARRAY, by value (optional) + ;DIEZZMSG=MESSAGE ARRAY (optional) (default ^TMP) + ;* + ;DIEZS will be used to indicate "silent" if set to 1 + ;Write statements are made conditional, if not "silent" + ;* + N DIEZS,DNM,DIQUIET,DIEZRIEN,DIEZRLAZ,DIEZRLAF + N DIK,DIC,%I,DICS + S DIEZS=$G(DIEZFLGS)'["T" + S:DIEZS DIQUIET=1 + I '$D(DIFM) N DIFM S DIFM=1 D + .N Y,DIEZFLGS,X,DMAX,DIEZRLA,DIEZS + .D INIZE^DIEFU + I $G(Y)'>0 D BLD^DIALOG(1700,"IEN for Edit Template missing or invalid") G EN2E + I '$D(^DIE(Y,0)) D BLD^DIALOG(1700,"No Edit Template on file with IEN="_Y) G EN2E + I $G(X)']"" D BLD^DIALOG(1700,"Routine name missing this Edit Template, IEN="_Y) G EN2E + I X'?1U.NU&(X'?1"%"1U.NU) D BLD^DIALOG(1700,"Routine name invalid") G EN2E + I $L(X)>7 D BLD^DIALOG(1700,"Routine name too long") G EN2E + S DIEZRLA=$G(DIEZRLA,"DIEZRLAZ"),DIEZRIEN=Y + S:DIEZRLA="" DIEZRLA="DIEZRLAZ" S:$G(DMAX)<2500!($G(DMAX)>^DD("ROU")) DMAX=^DD("ROU") + S DIEZRLAF="" + K @DIEZRLA + D EN + G:'DIEZS!(DIEZRLAF) EN2E + D BLD^DIALOG(1700,"Compiling Edit Template (IEN="_DIEZRIEN_")"_$S(DIEZRLAF=0:", routine name too long",1:"")) +EN2E I 'DIEZS D MSG^DIALOG() Q + I $G(DIEZZMSG)]"" D CALLOUT^DIEFU(DIEZZMSG) + Q + ; +RECOMP S DIX=1 D DIEZ Q:'$D(DIX) N DIMAX S DIMAX=DMAX + F DIX=0:0 S DIX=$O(^DIE(DIX)) Q:DIX'>0 I $D(^(DIX,0)),$D(^("ROU")) S %=$P(^(0),"^",1),X=$E(^("ROU"),2,99) I X]"" S Y=DIX,DMAX=DIMAX D EN + ; +K K %,DDH,DIC,DIX,DIPZ,DMAX,DNM,DTOUT,DIRUT,DIROUT,DUOUT,X,Y Q + ;DIALOG #101 'only those with programmer's access' + ; #820 'no way to save routines on the system' + ; #8020 'Should the compilation run now?' + ; #8024 'Compiling template name Input template of file n' + ; #8033 'Input template' +UNCAF(DIEZ) ; + ; for one compiled input template (DIEZ), delete its "AF" entries + N %,X S X="" + F S X=$O(^DIE("AF",X)) Q:X="" K:'X ^(X,DIEZ) S %=0 F S %=$O(^DIE("AF",X,%)) Q:%'>0 K:$D(^(%,DIEZ)) ^(DIEZ) + Q + ; +UNC(DIEZ,DIFLAGS) ; + ; DBS: silent entry point to uncompile an input template + ; DIEZ = IEN of input template to uncompile + ; DIFLAGS = flags: + ; D = compiled routines are also deleted + K ^DIE(DIEZ,"ROU") + D UNCAF(DIEZ) + I $G(DIFLAGS)["D" D + . N DINAME S DINAME=$G(^DIE(DIEZ,"ROUOLD")) Q:DINAME="" + . N DIROU,DISUF F DISUF="",1:1 D Q:DIROU="" + . . S DIROU=DINAME_DISUF I '$$ROUEXIST^DILIBF(DIROU) S DIROU="" Q + . . N X S X=DIROU X ^%ZOSF("DEL") + Q diff --git a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIEZ0.m b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIEZ0.m index ab70fd9e..e0ff9bcc 100644 --- a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIEZ0.m +++ b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIEZ0.m @@ -1,64 +1,64 @@ -DIEZ0 ;SFISC/GFT-COMPILE INPUT TEMPLATE ;13SEP2004 - ;;22.0;VA FileMan;**159**;Mar 30, 1999;Build 8 - ;Per VHA Directive 2004-038, this routine should not be modified. - D L -DL S DQ=0,DK=0,DQFF=0 -MR S DK=DK+1,DH=$P(DR,";",DK),DI=$P(DH,":",1),(DIEZP,DIEZDUP,DIEZR)="" G:'DI K:DI=0,PB S DPR=$P(DH,"//",2,99),DM=+DI S:DPR]"" DI=$P(DI,"//",1),DH="" - G K:DM=DI S Y=$P(DI,DM,2,99) G MR:Y=""!'$D(^DD(DP,DM,0)) F %=1:1 S X=$P(Y,$C(126),%) Q:X="" S:X="d" DIEZDUP=X S:X="R" DIEZR=X S:X'="d"&(X'="R")&(X'="T") DIEZP=X D:X="T" - .I $D(^DD(DP,DM,.1)) S DIEZP=^(.1) Q - .I +$P(^DD(DP,DM,0),U,2),$P(^DD(+$P(^(0),U,2),.01,0),U,2)["W",$D(^(.1)) S DIEZP=^(.1) - .Q - S (DI,DM)=+DI G S -K S DM=$P(DH,":",2),DM=$S(DM:DM,1:+DI) I DI,$D(^DD(DP,+DI)) G S -NX ; - S DI=$O(^DD(DP,+DI)),DIEZP="" S:DI="" DI=-1 G MR:DI'>0,MR:DI>DM -S S Y=^DD(DP,+DI,0),DV=$P(Y,U,2)_$E("#",Y["DINUM")_DIEZR_DIEZDUP S:DIEZP=""&'DV DIEZP=$P(Y,U,1) - S X=DIEZP,DW=$P(Y,U,4) G NX:$A(DW)=32 I T>DMAX D SV G:DIEZQ K^DIEZ2 G S - W:'$G(DIEZS) "." S DQ=DQ+1,DI=+DI,DU=$P(Y,U,3),%=" S " - K DIEZOT I DV["O",$D(^(2)) D O^DIEZ2 - I DQFF S %=" D:$D(DG)>9 F^DIE17,DE S DQ="_DQ_",",DQFF=0 - I DV S Y=X,X=DQ_%_"D=0 K DE(1) ;"_DI D L,DRN G MUL^DIEZ2 - S ^UTILITY($J,U,$P(DW,";",1),$P(DW,";",2),DQ)="",T=T+35,X=DQ_%_"DW="""_DW_""",DV="""_DV_""",DU="""",DLB="""_X_""",DIFLD="_DI D L - I $D(DIEZOT) S X=DIEZOT D L K DIEZOT - S DIEZXREF=$O(^DD("IX","F",DP,DI,0)) - I $O(^DD(DP,DI,1,0))>0!(DV["a")!DIEZXREF D - . S DQFF=1,X=" S DE(DW)=""C"_DQ_U_DNM_DRN_"""" - . S:DIEZXREF X=X_",DE(DW,""INDEX"")=1" - . ;Determine whether this field is part of a field-level key. - . ;Also, build list: DIEZKEY(uniquenessIndex)="" - . ;for those indexes that are uniqueness indexes for keys. - . N DIEZK,DIEZUI - . K DIEZKEY S DIEZK=0 - . F S DIEZK=$O(^DD("KEY","F",DP,DI,DIEZK)) Q:'DIEZK D - .. S DIEZUI=$P($G(^DD("KEY",DIEZK,0)),U,4) Q:'DIEZUI - .. S:$P($G(^DD("IX",DIEZUI,0)),U,6)="F" DIEZKEY(DIEZUI)="" - . S:$D(DIEZKEY) X=X_",DE(DW,""KEY"")=""$$K"_DQ_"""" - . D L - K DIEZXREF -X D PR,XREF^DIEZ2:DQFF S %=$P(Y,U,5,99),X=$F(%,"%DT=""") I X,DPR?1"/".E S Y=$F(%,"E",X) I Y S %=$E(%,1,Y-2)_$E(%,Y,999) - I DPR?1"//".E S %="" - D AF^DIEZ2 S X="X"_DQ_" " I "Q"[% S X=X_"Q" D L G NX - S X=X_% D L I DV["F" S X=" I $D(X),X'?.ANP K X" D L - S X=" Q" D L S X=" ;" D L G NX - ; -PB I DH="" S:'$D(DOV(DL)) DOV(DL)=0 S DOV(DL)=$O(^DIE(DIEZ,"DR",DIER,DP,DOV(DL))) S:DOV(DL)="" DOV(DL)=-1 G UP:DOV(DL)<0 S DR=^(DOV(DL)),DK=0 G MR - S DQ=DQ+1 I DH?1"@".N S X=DQ_" S DQ="_(DQ+1)_" ;"_DH,^UTILITY($J,"AB",DIEZAB,DH)=DQ_U_DNM_DRN G M - S X=DQ_" D:$D(DG)>9 F^DIE17,DE S Y=U,DQ="_DQ_" " I "Q"[DH S X=X_"G A" G M - I DH?1"^".E S F=0,X=X_$P(DH,U,5,999),Q=$P(DH,U,1,3) D L,DRN,QFF^DIEZ2,DIERN^DIEZ2 S X=" S DGO=""^"_DNM_%_""",DC="_Q_" G DIEZ^DIE0",DRN(%)=$P(DH,U,2)_U_DIERN_U_$P(DH,U,3)_U_U_DQ_U_DRN D L S X="R"_DQ_" D DE G A" D L S X=" ;" G M - S X=X_"D X"_DQ_" D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)=""F"",DW=DQ G OUT^DIE17" D L S X="X"_DQ_" "_DH D L S X=" Q" -M D L G MR - ; -UP S DQ=DQ+1,X=DQ_" G "_(DL>1)_"^DIE17" D L,^DIEZ1 G:DIEZQ K^DIEZ2 S Y=0 -LV S Y=$O(DRN(Y)) S:Y="" Y=-1 I Y<0 G ^DIEZ2 - S X=DRN(Y) G LV:X=U S DRN=Y,DP=+X,DIER=$P(X,U,2),DL=DIER\1,DIE=U_$P(X,U,3),DIEZL=+$P(X,U,4),DIEZAB=$P(X,U,5)_U_DNM_$P(X,U,6),DR=$S($D(^DIE(DIEZ,"DR",DIER,DP)):^(DP),1:"0:9999999"),DRN(Y)=U D N S:+DR=.01!(DR?1"0:".E) ^(3)=^(3)_"+D G B" G DL - ; -PR ; - D DU^DIEZ2:DU]"" S X=" G RE" I DW="0;1",DL>1,DQ=1 S X=X_":'D S DQ=2 G 2" - D PR^DIEZ2:DPR]"" -L S L=L+1,^UTILITY($J,0,L)=X,T=T+$L(X)+2 S:X?1N.E T=T+15 Q - ; -SV D DRN - S X=DQ+1_" D:$D(DG)>9 F^DIE17 G ^"_DNM_%,DQ=% D L,^DIEZ1 Q:DIEZQ -N G NEWROU^DIEZ - ; -DRN F %=DRN+1:1 Q:'$D(DRN(%)) +DIEZ0 ;SFISC/GFT-COMPILE INPUT TEMPLATE ;12:47 PM 24 Apr 1997 + ;;22.0;VA FileMan;;Mar 30, 1999 + ;Per VHA Directive 10-93-142, this routine should not be modified. + D L +DL S DQ=0,DK=0,DQFF=0 +MR S DK=DK+1,DH=$P(DR,";",DK),DI=$P(DH,":",1),(DIEZP,DIEZDUP,DIEZR)="" G:'DI K:DI=0,PB S DPR=$P(DH,"//",2,99),DM=+DI S:DPR]"" DI=$P(DI,"//",1),DH="" + G K:DM=DI S Y=$P(DI,DM,2,99) G MR:Y=""!'$D(^DD(DP,DM,0)) F %=1:1 S X=$P(Y,$C(126),%) Q:X="" S:X="d" DIEZDUP=X S:X="R" DIEZR=X S:X'="d"&(X'="R")&(X'="T") DIEZP=X D:X="T" + .I $D(^DD(DP,DM,.1)) S DIEZP=^(.1) Q + .I +$P(^DD(DP,DM,0),U,2),$P(^DD(+$P(^(0),U,2),.01,0),U,2)["W",$D(^(.1)) S DIEZP=^(.1) + .Q + S (DI,DM)=+DI G S +K S DM=$P(DH,":",2),DM=$S(DM:DM,1:+DI) I DI,$D(^DD(DP,+DI)) G S +NX ; + S DI=$O(^DD(DP,+DI)),DIEZP="" S:DI="" DI=-1 G MR:DI'>0,MR:DI>DM +S S Y=^DD(DP,+DI,0),DV=$P(Y,U,2)_$E("#",Y["DINUM")_DIEZR_DIEZDUP S:DIEZP=""&'DV DIEZP=$P(Y,U,1) + S X=DIEZP,DW=$P(Y,U,4) G NX:$A(DW)=32 I T>DMAX D SV G:DIEZQ K^DIEZ2 G S + W:'$G(DIEZS) "." S DQ=DQ+1,DI=+DI,DU=$P(Y,U,3),%=" S " + K DIEZOT I DV["O",$D(^(2)) D O^DIEZ2 + I DQFF S %=" D:$D(DG)>9 F^DIE17,DE S DQ="_DQ_",",DQFF=0 + I DV S Y=X,X=DQ_%_"D=0 K DE(1) ;"_DI D L,DRN G MUL^DIEZ2 + S ^UTILITY($J,U,$P(DW,";",1),$P(DW,";",2),DQ)="",T=T+35,X=DQ_%_"DW="""_DW_""",DV="""_DV_""",DU="""",DLB="""_X_""",DIFLD="_DI D L + I $D(DIEZOT) S X=DIEZOT D L K DIEZOT + S DIEZXREF=$O(^DD("IX","F",DP,DI,0)) + I $O(^DD(DP,DI,1,0))>0!(DV["a")!DIEZXREF D + . S DQFF=1,X=" S DE(DW)=""C"_DQ_U_DNM_DRN_"""" + . S:DIEZXREF X=X_",DE(DW,""INDEX"")=1" + . ;Determine whether this field is part of a field-level key. + . ;Also, build list: DIEZKEY(uniquenessIndex)="" + . ;for those indexes that are uniqueness indexes for keys. + . N DIEZK,DIEZUI + . K DIEZKEY S DIEZK=0 + . F S DIEZK=$O(^DD("KEY","F",DP,DI,DIEZK)) Q:'DIEZK D + .. S DIEZUI=$P($G(^DD("KEY",DIEZK,0)),U,4) Q:'DIEZUI + .. S:$P($G(^DD("IX",DIEZUI,0)),U,6)="F" DIEZKEY(DIEZUI)="" + . S:$D(DIEZKEY) X=X_",DE(DW,""KEY"")=""$$K"_DQ_"""" + . D L + K DIEZXREF +X D PR,XREF^DIEZ2:DQFF S %=$P(Y,U,5,99),X=$F(%,"%DT=""") I X,DPR?1"/".E S Y=$F(%,"E",X) I Y S %=$E(%,1,Y-2)_$E(%,Y,999) + I DPR?1"//".E S %="" + D AF^DIEZ2 S X="X"_DQ_" " I "Q"[% S X=X_"Q" D L G NX + S X=X_% D L I DV["F" S X=" I $D(X),X'?.ANP K X" D L + S X=" Q" D L S X=" ;" D L G NX + ; +PB I DH="" S:'$D(DOV(DL)) DOV(DL)=0 S DOV(DL)=$O(^DIE(DIEZ,"DR",DL,DP,DOV(DL))) S:DOV(DL)="" DOV(DL)=-1 G UP:DOV(DL)<0 S DR=^(DOV(DL)),DK=0 G MR + S DQ=DQ+1 I DH?1"@".N S X=DQ_" S DQ="_(DQ+1)_" ;"_DH,^UTILITY($J,"AB",DIEZAB,DH)=DQ_U_DNM_DRN G M + S X=DQ_" D:$D(DG)>9 F^DIE17,DE S Y=U,DQ="_DQ_" " I "Q"[DH S X=X_"G A" G M + I DH?1"^".E S F=0,X=X_$P(DH,U,5,999),Q=$P(DH,U,1,3) D L,DRN,QFF^DIEZ2 S X=" S DGO=""^"_DNM_%_""",DC="_Q_" G DIEZ^DIE0",DRN(%)=$P(DH,U,2)_U_(DL+1)_U_$P(DH,U,3)_U_U_DQ_U_DRN D L S X="R"_DQ_" D DE G A" D L S X=" ;" G M + S X=X_"D X"_DQ_" D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)=""F"",DW=DQ G OUT^DIE17" D L S X="X"_DQ_" "_DH D L S X=" Q" +M D L G MR + ; +UP S DQ=DQ+1,X=DQ_" G "_(DL>1)_"^DIE17" D L,^DIEZ1 G:DIEZQ K^DIEZ2 S Y=0 +LV S Y=$O(DRN(Y)) S:Y="" Y=-1 I Y<0 G ^DIEZ2 + S X=DRN(Y) G LV:X=U S DRN=Y,DP=+X,DL=$P(X,U,2),DIE=U_$P(X,U,3),DIEZL=+$P(X,U,4),DIEZAB=$P(X,U,5)_U_DNM_$P(X,U,6),DR=$S($D(^DIE(DIEZ,"DR",DL,DP)):^(DP),1:"0:9999999"),DRN(Y)=U D N S:+DR=.01!(DR?1"0:".E) ^(3)=^(3)_"+D G B" G DL + ; +PR ; + D DU^DIEZ2:DU]"" S X=" G RE" I DW="0;1",DL>1,DQ=1 S X=X_":'D S DQ=2 G 2" + D PR^DIEZ2:DPR]"" +L S L=L+1,^UTILITY($J,0,L)=X,T=T+$L(X)+2 S:X?1N.E T=T+15 Q + ; +SV D DRN + S X=DQ+1_" D:$D(DG)>9 F^DIE17 G ^"_DNM_%,DQ=% D L,^DIEZ1 Q:DIEZQ +N G NEWROU^DIEZ + ; +DRN F %=DRN+1:1 Q:'$D(DRN(%)) diff --git a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIEZ2.m b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIEZ2.m index c81d9bb1..75ff916c 100644 --- a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIEZ2.m +++ b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIEZ2.m @@ -1,198 +1,195 @@ -DIEZ2 ;SFISC/GFT-COMPILE INPUT TEMPLATE ;20SEP2004 - ;;22.0;VA FileMan;**11,95,159**;Mar 30, 1999;Build 8 - ;Per VHA Directive 2004-038, this routine should not be modified. - K DIEZAR D RECXR^DIEZ4(.DIEZAR) - K ^DIE(DIEZ,"AR") M:$D(DIEZAR) ^DIE(DIEZ,"AR")=DIEZAR - S %X="^UTILITY($J,""AF"",",%Y="^DIE(""AF""," D %XY^%RCR - K ^DIE(DIEZ,"AB") S %X="^UTILITY($J,""AB"",",%Y="^DIE(DIEZ,""AB""," D %XY^%RCR - S ^DIE(DIEZ,"ROUOLD")=DNM,^("ROU")=U_DNM -K K ^DIBT(.402,1,DIEZ),^UTILITY($J) - K @DIEZTMP,DIEZTMP,DIEZAR,DIER,DIERN - K DIE,DINC,DK,DL,DMAX,DNR,DP,DQ,DQFF,DRD,DS,DSN,DV,DW,DI,DH,%,%X,%Y,%H,X,Y - K DIEZ,DIEZDUP,DIEZR,Q,DPP,DPR,DM,DR,DU,T,F,DRN,DOV,DIEZL,DIEZP,DIEZAB - Q - ; -XREF ; - N DIEZR,DIEZX,DIEZLN - S X="C"_DQ_" G C"_DQ_"S:$D(DE("_DQ_"))[0 K DB" D L - S DIEZX=L,DIEZLN=0 ;remember cross-refs will start after 'L' - F %=0:0 S %=$O(^DD(DP,DI,1,%)) Q:%'>0 S DW=^(%,2),X=" S X=DE("_DQ_"),DIC=DIE" D SK ;first build the KILL XREFS - I DV["a" S X=" S X=DE("_DQ_"),DIIX=2_U_DIFLD D AUDIT^DIET" D X - ;I X]"" S X="C"_DQ_" ;" D L - D OVERFLO - S X="C"_DQ_"S S X="""" G:DG(DQ)=X C"_DQ_"F1 K DB" D L S X="" - S DIEZX=L,DIEZLN=L - F %=0:0 S %=$O(^DD(DP,DI,1,%)) Q:%'>0 S DW=^(%,1),X=X_" S X=DG(DQ),DIC=DIE" D SK ;then the SET XREFS - I DV["a" S X=X_" I $D(DE("_DQ_"))'[0!(^DD(DP,DIFLD,""AUDIT"")'=""e"") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET" D X - D OVERFLO - ;Build index code and code to check key - D INDEX - S X=X_" Q" D L - I $D(DIEZKEY) D GETKEY^DIEZ3(DP,DI,.DIEZKEY,DQ) K DIEZKEY - Q - ; -SK D X I "Q"[DW S X=" ;" G X - I DW["Q",^DD(DP,DI,1,%,0)["MUMPS" S Q=DW,F=0 D QFF S X=" X "_Q G X - S X=" "_DW -X D L S DIEZLN=DIEZLN+$L(X),X="" Q - ; -OVERFLO I DIEZLN+T+1000 S DC=DC_D I $D("_DIE_"DA,"_DW_",+D,0)) S DE("_DQ_")=$P(^(0),U,1)" D L - D PR^DIEZ0 S X="R"_DQ_" D DE" D L - S X=$S(DPP:" S D=$S($D("_DIE_"DA,"_DW_",0)):$P(^(0),U,3,4),1:1) G "_DQ_"+1",1:" G A") D L S X=" ;" D L,AF,DIERN - S DRN(DNR)=+DV_U_DIERN_DIE_"D"_DIEZL_","_DW_","_U_(DIEZL+1)_U_DQ_U_DRN G NX^DIEZ0 - ; -DIERN ; - N M S DIERN=DL+1,M=$P(DR,";",DK+1) S:M?1"^"1.NP DK=DK+1,DIERN=$P(M,U,2) Q - ; -AF ; - S ^UTILITY($J,"AF",DP,DI,DIEZ)="" -AB I '$D(^UTILITY($J,"AB",DIEZAB,DI)) S ^(DI)=DQ_U_DNM_DRN S:DPR?1"/".E ^(DI,"///")="" - Q - ; -DU S F=0,Q=DU D QFF S X=" S DU="_Q,DU="" -L S L=L+1,^UTILITY($J,0,L)=X,T=T+$L(X)+2 Q - ; -O ; - S F=0,Q=^(2) D QFF S DIEZOT=" S DQ("_DQ_",2)="_Q Q - ; -PR ; - F %=1,2,3 Q:$E(DPR,%)'="/" - S X=$E(DPR,%,999),Q=X,F=0 D QFF I $A(X)-94 S X=" S Y="_Q - E S X=" "_$E(X,2,999) D L S X=" S Y=X" - D L S X=" G Y" I %>1 S DPP=0,X=" S X=Y,DB(DQ)=1"_$S(%=3:",DE(DW,""4/"")=""""",1:"")_" G:X="""" N^DIE17:DV,A I $D(DE(DQ)),DV[""I""!(DV[""#"") D E^DIE0 G A:'$D(X)" D L S X=" G "_$S(%=3:"RD:X=""@"",Z",1:"RD") - Q -QF ; - S F=0,Q=DIE -QFF ; - S F=$F(Q,"""",F) I F S Q=$E(Q,1,F-1)_$E(Q,F-1,999),F=F+1 G QFF - S Q=""""_Q_"""" - Q - ; -INDEX ;Build code field and record level cross references. - ;In: - ; DP = file # - ; DI = field # - ; DIEZKEY(xref#) = "" : for each xref that is a Uniqueness Index - ; for a simple (single-field key) - N DIEZCNT,DIEZFLST,DIEZI,DIEZRLST,DIEZXR,DIEZXREF - S DIEZCNT=0 - ; - ;Get field- and record-level xrefs - D LOADFLD^DIKC1(DP,DI,"KS","","@DIEZTMP@(""V"",","DIEZXREF",$NA(@DIEZTMP@("R")),.DIEZFLST,.DIEZRLST) - I DIEZFLST="",DIEZRLST="" S X="C"_DQ_"F1" Q - ; - ;Build code for each field-level xref - ;Save DIEZKEY(uniquenessIndex)=index tag # (DIEZCNT) - I DIEZFLST]"" S DIEZXR=0 F S DIEZXR=$O(DIEZXREF(DP,DIEZXR)) Q:'DIEZXR D - . D GETXR(DIEZXR,.DIEZCNT) - . S:$D(DIEZKEY(DIEZXR))#2 DIEZKEY(DIEZXR)=DIEZCNT - ; - ;Build code to set the DIEZRXR array for each record-level xref - S X="C"_DQ_"F"_(DIEZCNT+1) - Q:DIEZRLST="" - S X=X_" S DIEZRXR("_DP_",DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))" D L - S X=" F DIXR="_$TR(DIEZRLST,U,",")_" S DIEZRXR("_DP_",DIXR)=""""" D L - S DIEZI=0 F S DIEZI=$O(DIEZRLST(DIEZI)) Q:'DIEZI D - . S X=" F DIXR="_$TR(DIEZRLST(DIEZI),U,",")_" S DIEZRXR("_DP_",DIEZIENS)=""""" D L - ; - S X="" - Q - ; -GETXR(DIEZXR,DIEZCNT) ;Get code for one index DIEZXR - N DIEZCOD,DIEZF,DIEZKLOG,DIEZNSS,DIEZSLOG,DIEZO - S DIEZCNT=$G(DIEZCNT)+1 - ; - ;Build code to call subroutine to set X array - S X="C"_DQ_"F"_DIEZCNT_$S(DIEZCNT=1:" N X,X1,X2",1:"")_" S DIXR="_DIEZXR_" D C"_DQ_"X"_DIEZCNT_"(U) K X2 M X2=X D C"_DQ_"X"_DIEZCNT_"(""O"") K X1 M X1=X" - D L - ; - ;Build code to check for null subscripts - S DIEZNSS="",DIEZO=0 - F S DIEZO=$O(DIEZXREF(DP,DIEZXR,DIEZO)) Q:'DIEZO D - . Q:'$G(DIEZXREF(DP,DIEZXR,DIEZO,"SS")) - . I DIEZNSS="" S DIEZNSS="$G(X("_DIEZO_"))]""""" - . E S DIEZNSS=DIEZNSS_",$G(X("_DIEZO_"))]""""" - I DIEZNSS]"" S DIEZNSS=" I "_DIEZNSS_" D" - E S DIEZNSS=" D" - ; - ;Get kill logic and condition - S DIEZKLOG=$G(DIEZXREF(DP,DIEZXR,"K")) - I DIEZKLOG'?."^" D - . S X=DIEZNSS D L - . ;Get kill condition code - . S DIEZCOD=$G(DIEZXREF(DP,DIEZXR,"KC")) - . I DIEZCOD'?."^" D - .. S X=" . N DIEXARR M DIEXARR=X S DIEZCOND=1" D L - .. S X=" . "_DIEZCOD D L - .. S X=" . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND" D L - . ;Get kill logic - . S X=" . "_DIEZKLOG D L - ; - ;Get set logic and condition - S DIEZSLOG=$G(DIEZXREF(DP,DIEZXR,"S")) - I DIEZSLOG'?."^" D - . S X=" K X M X=X2"_DIEZNSS D L - . ;Get set condition code - . S DIEZCOD=$G(DIEZXREF(DP,DIEZXR,"SC")) - . I DIEZCOD'?."^" D - .. S X=" . N DIEXARR M DIEXARR=X S DIEZCOND=1" D L - .. S X=" . "_DIEZCOD D L - .. S X=" . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND" D L - . ;Get set logic - . S X=" . "_DIEZSLOG D L - ; - S X=" G C"_DQ_"F"_(DIEZCNT+1) D L - ; - ;Build code to set X array - S DIEZF=$O(DIEZXREF(DP,DIEZXR,0)) - S X="C"_DQ_"X"_DIEZCNT_"(DION) K X" D L - S DIEZO=0 - F S DIEZO=$O(DIEZXREF(DP,DIEZXR,DIEZO)) Q:'DIEZO D - . D BLDDEC(DP,DIEZXR,DIEZO) - S X=" S X=$G(X("_DIEZF_"))" D L - S X=" Q" D L - Q - ; -BLDDEC(DP,DIEZXR,DIEZO) ;Build data extraction code - N CODE,NODE,TRANS - ; - S CODE=$G(DIEZXREF(DP,DIEZXR,DIEZO)) Q:CODE?."^" - S TRANS=$G(DIEZXREF(DP,DIEZXR,DIEZO,"T")) - I TRANS'?."^" D - . S X=" "_CODE D L - . D DOTLINE(" I $D(X)#2 "_TRANS) - . S X=" S:$D(X)#2 X("_DIEZO_")=X" D L - E I $D(DIEZXREF(DP,DIEZXR,DIEZO,"F"))#2,CODE?1"S X=".E D - . S X=" S X("_DIEZO_")"_$E(CODE,4,999) D L - E D - . S X=" "_CODE D L - . S X=" S:$D(X)#2 X("_DIEZO_")=X" D L - Q - ; -DOTLINE(CODE) ; - I CODE[" Q"!(CODE[" Q:") D - . S X=" D" D L - . S X=" ."_CODE D L - E S X=CODE D L - Q +DIEZ2 ;SFISC/GFT-COMPILE INPUT TEMPLATE ;12:45 PM 17 Sep 2002 + ;;22.0;VA FileMan;**11,95**;Mar 30, 1999 + ;Per VHA Directive 10-93-142, this routine should not be modified. + K DIEZAR D RECXR^DIEZ4(.DIEZAR) + K ^DIE(DIEZ,"AR") M:$D(DIEZAR) ^DIE(DIEZ,"AR")=DIEZAR + S %X="^UTILITY($J,""AF"",",%Y="^DIE(""AF""," D %XY^%RCR + K ^DIE(DIEZ,"AB") S %X="^UTILITY($J,""AB"",",%Y="^DIE(DIEZ,""AB""," D %XY^%RCR + S ^DIE(DIEZ,"ROUOLD")=DNM,^("ROU")=U_DNM +K K ^DIBT(.402,1,DIEZ),^UTILITY($J) + K @DIEZTMP,DIEZTMP,DIEZAR + K DIE,DINC,DK,DL,DMAX,DNR,DP,DQ,DQFF,DRD,DS,DSN,DV,DW,DI,DH,%,%X,%Y,%H,X,Y + K DIEZ,DIEZDUP,DIEZR,Q,DPP,DPR,DM,DR,DU,T,F,DRN,DOV,DIEZL,DIEZP,DIEZAB + Q + ; +XREF ; + N DIEZR,DIEZX,DIEZLN + S X="C"_DQ_" G C"_DQ_"S:$D(DE("_DQ_"))[0 K DB" D L + S DIEZX=L,DIEZLN=0 ;remember cross-refs will start after 'L' + F %=0:0 S %=$O(^DD(DP,DI,1,%)) Q:%'>0 S DW=^(%,2),X=" S X=DE("_DQ_"),DIC=DIE" D SK ;first build the KILL XREFS + I DV["a" S X=" S X=DE("_DQ_"),DIIX=2_U_DIFLD D AUDIT^DIET" D X + ;I X]"" S X="C"_DQ_" ;" D L + D OVERFLO + S X="C"_DQ_"S S X="""" G:DG(DQ)=X C"_DQ_"F1 K DB" D L S X="" + S DIEZX=L,DIEZLN=L + F %=0:0 S %=$O(^DD(DP,DI,1,%)) Q:%'>0 S DW=^(%,1),X=X_" S X=DG(DQ),DIC=DIE" D SK ;then the SET XREFS + I DV["a" S X=X_" I $D(DE("_DQ_"))'[0!(^DD(DP,DIFLD,""AUDIT"")'=""e"") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET" D X + D OVERFLO + ;Build index code and code to check key + D INDEX + S X=X_" Q" D L + I $D(DIEZKEY) D GETKEY^DIEZ3(DP,DI,.DIEZKEY,DQ) K DIEZKEY + Q + ; +SK D X I "Q"[DW S X=" ;" G X + I DW["Q",^DD(DP,DI,1,%,0)["MUMPS" S Q=DW,F=0 D QFF S X=" X "_Q G X + S X=" "_DW +X D L S DIEZLN=DIEZLN+$L(X),X="" Q + ; +OVERFLO I DIEZLN+T+1000 S DC=DC_D I $D("_DIE_"DA,"_DW_",+D,0)) S DE("_DQ_")=$P(^(0),U,1)" D L + D PR^DIEZ0 S X="R"_DQ_" D DE" D L + S X=$S(DPP:" S D=$S($D("_DIE_"DA,"_DW_",0)):$P(^(0),U,3,4),1:1) G "_DQ_"+1",1:" G A") D L S X=" ;" D L,AF + S DRN(DNR)=+DV_U_(DL+1)_DIE_"D"_DIEZL_","_DW_","_U_(DIEZL+1)_U_DQ_U_DRN G NX^DIEZ0 + ; +AF ; + S ^UTILITY($J,"AF",DP,DI,DIEZ)="" +AB I '$D(^UTILITY($J,"AB",DIEZAB,DI)) S ^(DI)=DQ_U_DNM_DRN S:DPR?1"/".E ^(DI,"///")="" + Q + ; +DU S F=0,Q=DU D QFF S X=" S DU="_Q,DU="" +L S L=L+1,^UTILITY($J,0,L)=X,T=T+$L(X)+2 Q + ; +O ; + S F=0,Q=^(2) D QFF S DIEZOT=" S DQ("_DQ_",2)="_Q Q + ; +PR ; + F %=1,2,3 Q:$E(DPR,%)'="/" + S X=$E(DPR,%,999),Q=X,F=0 D QFF I $A(X)-94 S X=" S Y="_Q + E S X=" "_$E(X,2,999) D L S X=" S Y=X" + D L S X=" G Y" I %>1 S DPP=0,X=" S X=Y,DB(DQ)=1"_$S(%=3:",DE(DW,""4/"")=""""",1:"")_" G:X="""" N^DIE17:DV,A I $D(DE(DQ)),DV[""I""!(DV[""#"") D E^DIE0 G A:'$D(X)" D L S X=" G "_$S(%=3:"RD:X=""@"",Z",1:"RD") + Q +QF ; + S F=0,Q=DIE +QFF ; + S F=$F(Q,"""",F) I F S Q=$E(Q,1,F-1)_$E(Q,F-1,999),F=F+1 G QFF + S Q=""""_Q_"""" + Q + ; +INDEX ;Build code field and record level cross references. + ;In: + ; DP = file # + ; DI = field # + ; DIEZKEY(xref#) = "" : for each xref that is a Uniqueness Index + ; for a simple (single-field key) + N DIEZCNT,DIEZFLST,DIEZI,DIEZRLST,DIEZXR,DIEZXREF + S DIEZCNT=0 + ; + ;Get field- and record-level xrefs + D LOADFLD^DIKC1(DP,DI,"KS","","@DIEZTMP@(""V"",","DIEZXREF",$NA(@DIEZTMP@("R")),.DIEZFLST,.DIEZRLST) + I DIEZFLST="",DIEZRLST="" S X="C"_DQ_"F1" Q + ; + ;Build code for each field-level xref + ;Save DIEZKEY(uniquenessIndex)=index tag # (DIEZCNT) + I DIEZFLST]"" S DIEZXR=0 F S DIEZXR=$O(DIEZXREF(DP,DIEZXR)) Q:'DIEZXR D + . D GETXR(DIEZXR,.DIEZCNT) + . S:$D(DIEZKEY(DIEZXR))#2 DIEZKEY(DIEZXR)=DIEZCNT + ; + ;Build code to set the DIEZRXR array for each record-level xref + S X="C"_DQ_"F"_(DIEZCNT+1) + Q:DIEZRLST="" + S X=X_" S DIEZRXR("_DP_",DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))" D L + S X=" F DIXR="_$TR(DIEZRLST,U,",")_" S DIEZRXR("_DP_",DIXR)=""""" D L + S DIEZI=0 F S DIEZI=$O(DIEZRLST(DIEZI)) Q:'DIEZI D + . S X=" F DIXR="_$TR(DIEZRLST(DIEZI),U,",")_" S DIEZRXR("_DP_",DIEZIENS)=""""" D L + ; + S X="" + Q + ; +GETXR(DIEZXR,DIEZCNT) ;Get code for one index DIEZXR + N DIEZCOD,DIEZF,DIEZKLOG,DIEZNSS,DIEZSLOG,DIEZO + S DIEZCNT=$G(DIEZCNT)+1 + ; + ;Build code to call subroutine to set X array + S X="C"_DQ_"F"_DIEZCNT_$S(DIEZCNT=1:" N X,X1,X2",1:"")_" S DIXR="_DIEZXR_" D C"_DQ_"X"_DIEZCNT_"(U) K X2 M X2=X D C"_DQ_"X"_DIEZCNT_"(""O"") K X1 M X1=X" + D L + ; + ;Build code to check for null subscripts + S DIEZNSS="",DIEZO=0 + F S DIEZO=$O(DIEZXREF(DP,DIEZXR,DIEZO)) Q:'DIEZO D + . Q:'$G(DIEZXREF(DP,DIEZXR,DIEZO,"SS")) + . I DIEZNSS="" S DIEZNSS="$G(X("_DIEZO_"))]""""" + . E S DIEZNSS=DIEZNSS_",$G(X("_DIEZO_"))]""""" + I DIEZNSS]"" S DIEZNSS=" I "_DIEZNSS_" D" + E S DIEZNSS=" D" + ; + ;Get kill logic and condition + S DIEZKLOG=$G(DIEZXREF(DP,DIEZXR,"K")) + I DIEZKLOG'?."^" D + . S X=DIEZNSS D L + . ;Get kill condition code + . S DIEZCOD=$G(DIEZXREF(DP,DIEZXR,"KC")) + . I DIEZCOD'?."^" D + .. S X=" . N DIEXARR M DIEXARR=X S DIEZCOND=1" D L + .. S X=" . "_DIEZCOD D L + .. S X=" . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND" D L + . ;Get kill logic + . S X=" . "_DIEZKLOG D L + ; + ;Get set logic and condition + S DIEZSLOG=$G(DIEZXREF(DP,DIEZXR,"S")) + I DIEZSLOG'?."^" D + . S X=" K X M X=X2"_DIEZNSS D L + . ;Get set condition code + . S DIEZCOD=$G(DIEZXREF(DP,DIEZXR,"SC")) + . I DIEZCOD'?."^" D + .. S X=" . N DIEXARR M DIEXARR=X S DIEZCOND=1" D L + .. S X=" . "_DIEZCOD D L + .. S X=" . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND" D L + . ;Get set logic + . S X=" . "_DIEZSLOG D L + ; + S X=" G C"_DQ_"F"_(DIEZCNT+1) D L + ; + ;Build code to set X array + S DIEZF=$O(DIEZXREF(DP,DIEZXR,0)) + S X="C"_DQ_"X"_DIEZCNT_"(DION) K X" D L + S DIEZO=0 + F S DIEZO=$O(DIEZXREF(DP,DIEZXR,DIEZO)) Q:'DIEZO D + . D BLDDEC(DP,DIEZXR,DIEZO) + S X=" S X=$G(X("_DIEZF_"))" D L + S X=" Q" D L + Q + ; +BLDDEC(DP,DIEZXR,DIEZO) ;Build data extraction code + N CODE,NODE,TRANS + ; + S CODE=$G(DIEZXREF(DP,DIEZXR,DIEZO)) Q:CODE?."^" + S TRANS=$G(DIEZXREF(DP,DIEZXR,DIEZO,"T")) + I TRANS'?."^" D + . S X=" "_CODE D L + . D DOTLINE(" I $D(X)#2 "_TRANS) + . S X=" S:$D(X)#2 X("_DIEZO_")=X" D L + E I $D(DIEZXREF(DP,DIEZXR,DIEZO,"F"))#2,CODE?1"S X=".E D + . S X=" S X("_DIEZO_")"_$E(CODE,4,999) D L + E D + . S X=" "_CODE D L + . S X=" S:$D(X)#2 X("_DIEZO_")=X" D L + Q + ; +DOTLINE(CODE) ; + I CODE[" Q"!(CODE[" Q:") D + . S X=" D" D L + . S X=" ."_CODE D L + E S X=CODE D L + Q diff --git a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIL11.m b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIL11.m index 817b3fc1..2cffc551 100644 --- a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIL11.m +++ b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIL11.m @@ -1,30 +1,28 @@ -DIL11 ;SFISC/GFT-TURN PRINT FLDS INTO CODE ;5APR2007 - ;;22.0;VA FileMan;**152**;Mar 30, 1999;Build 10 - ;Per VHA Directive 2004-038, this routine should not be modified. -DOWN ; - I W>0,'$D(^DD(DP,+W,0)) Q ;IN CASE FIELD IS GONE FOR SOME REASON! - S DN=-6,DY(DM)=DY,DP(DM)=DP,DI(DM)=DI G F:W'>0 S X=^DD(DP,+W,0),DU=$P($P(X,U,4),";") S:+DU'=DU DU=""""_DU_"""" - S W=$P(W,","),DY="D"_(DIL-DIL0+1),DI=DI_","_DU_","_DY,%=":0 Q:$O("_DI_"))'>0 ",DP=+$P(X,U,2),M(DP)=1,D=$P("""""",U,+DU'=DU),D=" S I("_(DIL+1)_")="_D_DU_D_",J("_(DIL+1)_")="_DP,Y=" S "_DY_"=$O(^("_DY_"))" -W I $P(^DD(DP,.01,0),U,2)["W" D:$P(^(0),U,2)["x"!($P(^(0),U,2)["X") G P ;**DI*22*152** - .S D=D_",D"_(DIL+1)_"=$G(DIWF) N DIWF S DIWF=D"_(DIL+1)_"_""X""" - I DHT+1 F X=1:1 G P:X>DPP,DPP:+DPP(X)=DP!$D(DPP(X,DP)) -DPP S %=%_" X:$D(DSC("_DP_")) DSC("_DP_")",Y=Y_" Q:"_DY_"'>0" I $T,"@"[$P(DPP(X),U,4),$P(DPP(X),U,2)=0 S DPP(X,U)="" G R:$D(DPP(X,"F")) - S Y=Y_" " -P S Y=D_" F "_DY_"=0"_%_Y_$S($D(DIARP(DP)):" X DIARP("_DP_") I $T",1:"") - G S -R S V=$P(DPP(X,"T"),U),Y=D_" F "_DY_"="_$P(DPP(X,"F"),U)_%_Y_$S(V:"!("_DY_">"_V_") ",1:" ") -S S:($G(DDXP)'=4) %=" D:$X>"_DG,Y=Y_%_$S($D(DIWR):" NX^DIWW",1:" T Q:'DN ") I DHT>0 S ^UTILITY($J,DV)="I "_DY_"'>0 S "_DY_"=0 "_$P(Y," ",2,9),DV=DV+1 - G D^DIL - ; -F ; - S DP=-W,X=$P(W,U,2),DD=DD+1,M(DP)=1,DIL(DM)=DIL,DIL(DM,0)=DIL0,Y=0,DIL0=DIL0+100,%=X["(" I % S (X,DI)=U_X,DIL=DIL0 - E S DI=DI(DM)_","""_X_""",",DIL=DIL+101 -QT S Y=$F(X,"""",Y) I Y S X=$E(X,1,Y-1)_$E(X,Y-1,999),Y=Y+1 G QT - S Y=" S I("_DIL_")="""_X_""",J("_DIL_")="_DP - S X=" "_$P($P(W,U,4,99),";") - S DY="D"_(DIL-DIL0),DI=DI_DY,DIL=DIL-1 I $P(W,U,3)="" S W=+W,Y=Y_X_" S D0=D(0) I D0>0" G D^DIL - S %="I("_(DIL0-100)_",0)=D0" I X'[% S X=","_%_X - I DHT=-1 D DREL^DIPZ1 G END - F %=900:1 I '$D(^UTILITY($J,99,%)) S ^(%)="I 1 X:$D(DSC("_DP_")) DSC("_DP_") I D T:$X>"_DG_" Q:'DN "_Y,Y=" S (DIXX,DIXX("_(DM+1)_"))="_%_X,W=+W D D^DIL K R(DX) Q -END S (F(DM-1),DX)=%,R(%)=DP(DM-1),R(%,1)=M(DP(DM-1)) - Q +DIL11 ;SFISC/GFT-TURN PRINT FLDS INTO CODE ;11/20/92 09:28 + ;;22.0;VA FileMan;;Mar 30, 1999 + ;Per VHA Directive 10-93-142, this routine should not be modified. +DOWN ; + S DN=-6,DY(DM)=DY,DP(DM)=DP,DI(DM)=DI G F:W'>0 S X=^DD(DP,+W,0),DU=$P($P(X,U,4),";",1) S:+DU'=DU DU=""""_DU_"""" + S W=$P(W,C,1),DY="D"_(DIL-DIL0+1),DI=DI_C_DU_C_DY,%=":0 Q:$O("_DI_"))'>0 ",DP=+$P(X,U,2),M(DP)=1,D=$P("""""",U,+DU'=DU),D=" S I("_(DIL+1)_")="_D_DU_D_",J("_(DIL+1)_")="_DP,Y=" S "_DY_"=$O(^("_DY_"))" + G P:$P(^DD(DP,.01,0),U,2)["W" + I DHT+1 F X=1:1 G P:X>DPP,DPP:+DPP(X)=DP!$D(DPP(X,DP)) +DPP S %=%_" X:$D(DSC("_DP_")) DSC("_DP_")",Y=Y_" Q:"_DY_"'>0" I $T,"@"[$P(DPP(X),U,4),$P(DPP(X),U,2)=0 S DPP(X,U)="" G R:$D(DPP(X,"F")) + S Y=Y_" " +P S Y=D_" F "_DY_"=0"_%_Y_$S($D(DIARP(DP)):" X DIARP("_DP_") I $T",1:"") + G S +R S V=$P(DPP(X,"T"),U),Y=D_" F "_DY_"="_$P(DPP(X,"F"),U)_%_Y_$S(V:"!("_DY_">"_V_") ",1:" ") +S S:($G(DDXP)'=4) %=" D:$X>"_DG,Y=Y_%_$S($D(DIWR):" NX^DIWW",1:" T Q:'DN ") I DHT>0 S ^UTILITY($J,DV)="I "_DY_"'>0 S "_DY_"=0 "_$P(Y," ",2,9),DV=DV+1 + G D^DIL + ; +F ; + S DP=-W,X=$P(W,U,2),DD=DD+1,M(DP)=1,DIL(DM)=DIL,DIL(DM,0)=DIL0,Y=0,DIL0=DIL0+100,%=X["(" I % S (X,DI)=U_X,DIL=DIL0 + E S DI=DI(DM)_","""_X_""",",DIL=DIL+101 +QT S Y=$F(X,"""",Y) I Y S X=$E(X,1,Y-1)_$E(X,Y-1,999),Y=Y+1 G QT + S Y=" S I("_DIL_")="""_X_""",J("_DIL_")="_DP + S X=" "_$P($P(W,U,4,99),";",1) + S DY="D"_(DIL-DIL0),DI=DI_DY,DIL=DIL-1 I $P(W,U,3)="" S W=+W,Y=Y_X_" S D0=D(0) I D0>0" G D^DIL + S %="I("_(DIL0-100)_",0)=D0" I X'[% S X=C_%_X + I DHT=-1 D DREL^DIPZ1 G END + F %=900:1 I '$D(^UTILITY($J,99,%)) S ^(%)="I 1 X:$D(DSC("_DP_")) DSC("_DP_") I D T:$X>"_DG_" Q:'DN "_Y,Y=" S (DIXX,DIXX("_(DM+1)_"))="_%_X,W=+W D D^DIL K R(DX) Q +END S (F(DM-1),DX)=%,R(%)=DP(DM-1),R(%,1)=M(DP(DM-1)) + Q diff --git a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DINIT0F0.m b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DINIT0F0.m index 71060bbe..ae5b113e 100644 --- a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DINIT0F0.m +++ b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DINIT0F0.m @@ -1,229 +1,229 @@ -DINIT0F0 ;SFISC/MKO-DATA FOR FORM AND BLOCK FILES ;4APR2007 - ;;22.0;VA FileMan;**152**;Mar 30, 1999;Build 10 - ;Per VHA Directive 2004-038, this routine should not be modified. - D PRE^DINIT29P - F I=1:2 S X=$T(ENTRY+I) G:X="" ^DINIT0F1 S Y=$E($T(ENTRY+I+1),5,999),X=$E(X,4,999),@X=Y - Q -ENTRY ; - ;;^DIST(.403,.001,0) - ;;=DICATT^@^@^^2981031.1257^2990319.1306^^1^0^1^1 - ;;^DIST(.403,.001,1) - ;;=2000000 - ;;^DIST(.403,.001,3) - ;;=3000000 - ;;^DIST(.403,.001,4) - ;;=N - ;;^DIST(.403,.001,5) - ;;=Y - ;;^DIST(.403,.001,6) - ;;=N - ;;^DIST(.403,.001,7) - ;;=N - ;;^DIST(.403,.001,15,0) - ;;=^^36^36^2981214 - ;;^DIST(.403,.001,15,1,0) - ;;=Pages: 1 Main form - ;;^DIST(.403,.001,15,2,0) - ;;= 1.1, 1.2 DESCRIPTION and TECHNICAL DESCRIPTION text - ;;^DIST(.403,.001,15,3,0) - ;;= 2.1-2.8 TYPE-specific (2.1=DATE, etc) - ;;^DIST(.403,.001,15,4,0) - ;;= 3 SUBSCRIPT & PIECE-position - ;;^DIST(.403,.001,15,5,0) - ;;= 4 SUBSCRIPT & SUB-DICTIONARY NUMBER - ;;^DIST(.403,.001,15,6,0) - ;;= 5 Multiples - ;;^DIST(.403,.001,15,7,0) - ;;= 6 SCREEN for Pointers & Sets - ;;^DIST(.403,.001,15,8,0) - ;;= 8 VARIABLE-POINTER extra fields for each pointer - ;;^DIST(.403,.001,15,9,0) - ;;= 9 "ARE YOU SURE YOU WANT TO DELETE THE ENTIRE FIELD?" - ;;^DIST(.403,.001,15,10,0) - ;;= 10 Multiple-field - ;;^DIST(.403,.001,15,11,0) - ;;= - ;;^DIST(.403,.001,15,12,0) - ;;= - ;;^DIST(.403,.001,15,13,0) - ;;= - ;;^DIST(.403,.001,15,14,0) - ;;=Branching logic: - ;;^DIST(.403,.001,15,15,0) - ;;= From Field 20.5 ("MULTIPLE?") - ;;^DIST(.403,.001,15,16,0) - ;;= IS THIS FIELD NEW AND IS THE USER A PROGRAMMER? - ;;^DIST(.403,.001,15,17,0) - ;;= | | - ;;^DIST(.403,.001,15,18,0) - ;;= NO YES - ;;^DIST(.403,.001,15,19,0) - ;;= | | - ;;^DIST(.403,.001,15,20,0) - ;;= | IS FIELD MULTIPLE? - ;;^DIST(.403,.001,15,21,0) - ;;= | | | - ;;^DIST(.403,.001,15,22,0) - ;;= | YES NO - ;;^DIST(.403,.001,15,23,0) - ;;= | | | - ;;^DIST(.403,.001,15,24,0) - ;;=IS FIELD EDITABLE & MULTIPLE? | | - ;;^DIST(.403,.001,15,25,0) - ;;= | | | | - ;;^DIST(.403,.001,15,26,0) - ;;= | YES ---------> Page 5 Page 3 - ;;^DIST(.403,.001,15,27,0) - ;;= | | | - ;;^DIST(.403,.001,15,28,0) - ;;= | PROGRAMMER? | - ;;^DIST(.403,.001,15,29,0) - ;;= | | | | - ;;^DIST(.403,.001,15,30,0) - ;;= | YES NO | - ;;^DIST(.403,.001,15,31,0) - ;;= | | | | - ;;^DIST(.403,.001,15,32,0) - ;;= | Page 4 | | - ;;^DIST(.403,.001,15,33,0) - ;;= | | | | - ;;^DIST(.403,.001,15,34,0) - ;;= --------------------------------->|<------------------ - ;;^DIST(.403,.001,15,35,0) - ;;= | - ;;^DIST(.403,.001,15,36,0) - ;;= Field 98 (HELP-PROMPT) - ;;^DIST(.403,.001,20) - ;;=D POST^DICATTDE - ;;^DIST(.403,.001,40,0) - ;;=^.4031I^21^18 - ;;^DIST(.403,.001,40,1,0) - ;;=1^^1,1 - ;;^DIST(.403,.001,40,1,1) - ;;=Page 1 - ;;^DIST(.403,.001,40,1,40,0) - ;;=^.4032IP^.00101^1 - ;;^DIST(.403,.001,40,1,40,.00101,0) - ;;=.00101^1^1,1^e - ;;^DIST(.403,.001,40,1,40,.00101,11) - ;;=D PRE^DICATTD - ;;^DIST(.403,.001,40,2,0) - ;;=2.1^^4,3^^^1^12,70 - ;;^DIST(.403,.001,40,2,1) - ;;=Page 2.1 - ;;^DIST(.403,.001,40,2,12) - ;;=D POST1^DICATTD1 - ;;^DIST(.403,.001,40,2,40,0) - ;;=^.4032IP^.00102^1 - ;;^DIST(.403,.001,40,2,40,.00102,0) - ;;=.00102^1^2,3^e - ;;^DIST(.403,.001,40,3,0) - ;;=2.2^^4,3^^^1^9,70 - ;;^DIST(.403,.001,40,3,1) - ;;=Page 2.2 - ;;^DIST(.403,.001,40,3,12) - ;;=D POST2^DICATTD2 - ;;^DIST(.403,.001,40,3,40,0) - ;;=^.4032IP^.00103^1 - ;;^DIST(.403,.001,40,3,40,.00103,0) - ;;=.00103^1^2,3^e - ;;^DIST(.403,.001,40,6,0) - ;;=2.4^^3,8^^^1^7,67 - ;;^DIST(.403,.001,40,6,1) - ;;=Page 2.4 - ;;^DIST(.403,.001,40,6,12) - ;;=D POST4^DICATTD4 - ;;^DIST(.403,.001,40,6,40,0) - ;;=^.4032IP^.00104^1 - ;;^DIST(.403,.001,40,6,40,.00104,0) - ;;=.00104^1^1,1^e - ;;^DIST(.403,.001,40,7,0) - ;;=2.5^^4,2^^^1^8,78 - ;;^DIST(.403,.001,40,7,1) - ;;=Page 2.5 - ;;^DIST(.403,.001,40,7,40,0) - ;;=^.4032IP^.00105^1 - ;;^DIST(.403,.001,40,7,40,.00105,0) - ;;=.00105^1^1,1^e - ;;^DIST(.403,.001,40,8,0) - ;;=2.6^^3,2^^^1^11,77 - ;;^DIST(.403,.001,40,8,1) - ;;=Page 2.6 - ;;^DIST(.403,.001,40,8,12) - ;;=D POST6^DICATTD6 - ;;^DIST(.403,.001,40,8,40,0) - ;;=^.4032IP^.00106^1 - ;;^DIST(.403,.001,40,8,40,.00106,0) - ;;=.00106^1^1,1^e - ;;^DIST(.403,.001,40,9,0) - ;;=2.7^^3,2^^^1^8,75 - ;;^DIST(.403,.001,40,9,1) - ;;=Page 2.7 - ;;^DIST(.403,.001,40,9,12) - ;;=D POST7^DICATTD7 - ;;^DIST(.403,.001,40,9,40,0) - ;;=^.4032IP^.00107^1 - ;;^DIST(.403,.001,40,9,40,.00107,0) - ;;=.00107^1^1,1^e - ;;^DIST(.403,.001,40,10,0) - ;;=2.8^^3,3^^^1^11,77 - ;;^DIST(.403,.001,40,10,1) - ;;=Page 2.8 - ;;^DIST(.403,.001,40,10,40,0) - ;;=^.4032IP^.00108^1 - ;;^DIST(.403,.001,40,10,40,.00108,0) - ;;=.00108^1^1,1^e - ;;^DIST(.403,.001,40,11,0) - ;;=2.3^^3,6^^^1^17,70 - ;;^DIST(.403,.001,40,11,1) - ;;=Page 2.3 - ;;^DIST(.403,.001,40,11,12) - ;;=D POST3^DICATTD3 - ;;^DIST(.403,.001,40,11,40,0) - ;;=^.4032IP^.00109^1 - ;;^DIST(.403,.001,40,11,40,.00109,0) - ;;=.00109^1^1,1^e - ;;^DIST(.403,.001,40,12,0) - ;;=1.1^^1,1^^1 - ;;^DIST(.403,.001,40,12,1) - ;;=Page 1.1 - ;;^DIST(.403,.001,40,12,40,0) - ;;=^.4032IP^.0011^1 - ;;^DIST(.403,.001,40,12,40,.0011,0) - ;;=.0011^1^1,1^e - ;;^DIST(.403,.001,40,12,40,.0011,11) - ;;=D WORD^DICATTD0(21) - ;;^DIST(.403,.001,40,13,0) - ;;=1.2^^1,1 - ;;^DIST(.403,.001,40,13,1) - ;;=Page 1.2 - ;;^DIST(.403,.001,40,13,40,0) - ;;=^.4032IP^.00111^1 - ;;^DIST(.403,.001,40,13,40,.00111,0) - ;;=.00111^1^1,1^e - ;;^DIST(.403,.001,40,15,0) - ;;=3^^4,8^^^1^7,64 - ;;^DIST(.403,.001,40,15,1) - ;;=Page 3 - ;;^DIST(.403,.001,40,15,12) - ;;=D POST^DICATTDM - ;;^DIST(.403,.001,40,15,40,0) - ;;=^.4032IP^.00112^1 - ;;^DIST(.403,.001,40,15,40,.00112,0) - ;;=.00112^1^2,2^e - ;;^DIST(.403,.001,40,16,0) - ;;=9^^3,10^^^1^7,70 - ;;^DIST(.403,.001,40,16,1) - ;;=Page 9 - ;;^DIST(.403,.001,40,16,40,0) - ;;=^.4032IP^.00113^1 - ;;^DIST(.403,.001,40,16,40,.00113,0) - ;;=.00113^1^1,1^e - ;;^DIST(.403,.001,40,17,0) - ;;=4^^9,5^^^1^12,75 - ;;^DIST(.403,.001,40,17,1) - ;;=Page 4 - ;;^DIST(.403,.001,40,17,40,0) - ;;=^.4032IP^.00114^1 - ;;^DIST(.403,.001,40,17,40,.00114,0) - ;;=.00114^1^1,1^e +DINIT0F0 ;SFISC/MKO-DATA FOR FORM AND BLOCK FILES ;10:49 AM 30 Mar 1999 + ;;22.0;VA FileMan;;Mar 30, 1999 + ;Per VHA Directive 10-93-142, this routine should not be modified. + D PRE^DINIT29P + F I=1:2 S X=$T(ENTRY+I) G:X="" ^DINIT0F1 S Y=$E($T(ENTRY+I+1),5,999),X=$E(X,4,999),@X=Y + Q +ENTRY ; + ;;^DIST(.403,.001,0) + ;;=DICATT^@^@^^2981031.1257^2990319.1306^^1^0^1^1 + ;;^DIST(.403,.001,1) + ;;=2000000 + ;;^DIST(.403,.001,3) + ;;=3000000 + ;;^DIST(.403,.001,4) + ;;=N + ;;^DIST(.403,.001,5) + ;;=Y + ;;^DIST(.403,.001,6) + ;;=N + ;;^DIST(.403,.001,7) + ;;=N + ;;^DIST(.403,.001,15,0) + ;;=^^36^36^2981214 + ;;^DIST(.403,.001,15,1,0) + ;;=Pages: 1 Main form + ;;^DIST(.403,.001,15,2,0) + ;;= 1.1, 1.2 DESCRIPTION and TECHNICAL DESCRIPTION text + ;;^DIST(.403,.001,15,3,0) + ;;= 2.1-2.8 TYPE-specific (2.1=DATE, etc) + ;;^DIST(.403,.001,15,4,0) + ;;= 3 SUBSCRIPT & PIECE-position + ;;^DIST(.403,.001,15,5,0) + ;;= 4 SUBSCRIPT & SUB-DICTIONARY NUMBER + ;;^DIST(.403,.001,15,6,0) + ;;= 5 Multiples + ;;^DIST(.403,.001,15,7,0) + ;;= 6 SCREEN for Pointers & Sets + ;;^DIST(.403,.001,15,8,0) + ;;= 8 VARIABLE-POINTER extra fields for each pointer + ;;^DIST(.403,.001,15,9,0) + ;;= 9 "ARE YOU SURE YOU WANT TO DELETE THE ENTIRE FIELD?" + ;;^DIST(.403,.001,15,10,0) + ;;= 10 Multiple-field + ;;^DIST(.403,.001,15,11,0) + ;;= + ;;^DIST(.403,.001,15,12,0) + ;;= + ;;^DIST(.403,.001,15,13,0) + ;;= + ;;^DIST(.403,.001,15,14,0) + ;;=Branching logic: + ;;^DIST(.403,.001,15,15,0) + ;;= From Field 20.5 ("MULTIPLE?") + ;;^DIST(.403,.001,15,16,0) + ;;= IS THIS FIELD NEW AND IS THE USER A PROGRAMMER? + ;;^DIST(.403,.001,15,17,0) + ;;= | | + ;;^DIST(.403,.001,15,18,0) + ;;= NO YES + ;;^DIST(.403,.001,15,19,0) + ;;= | | + ;;^DIST(.403,.001,15,20,0) + ;;= | IS FIELD MULTIPLE? + ;;^DIST(.403,.001,15,21,0) + ;;= | | | + ;;^DIST(.403,.001,15,22,0) + ;;= | YES NO + ;;^DIST(.403,.001,15,23,0) + ;;= | | | + ;;^DIST(.403,.001,15,24,0) + ;;=IS FIELD EDITABLE & MULTIPLE? | | + ;;^DIST(.403,.001,15,25,0) + ;;= | | | | + ;;^DIST(.403,.001,15,26,0) + ;;= | YES ---------> Page 5 Page 3 + ;;^DIST(.403,.001,15,27,0) + ;;= | | | + ;;^DIST(.403,.001,15,28,0) + ;;= | PROGRAMMER? | + ;;^DIST(.403,.001,15,29,0) + ;;= | | | | + ;;^DIST(.403,.001,15,30,0) + ;;= | YES NO | + ;;^DIST(.403,.001,15,31,0) + ;;= | | | | + ;;^DIST(.403,.001,15,32,0) + ;;= | Page 4 | | + ;;^DIST(.403,.001,15,33,0) + ;;= | | | | + ;;^DIST(.403,.001,15,34,0) + ;;= --------------------------------->|<------------------ + ;;^DIST(.403,.001,15,35,0) + ;;= | + ;;^DIST(.403,.001,15,36,0) + ;;= Field 98 (HELP-PROMPT) + ;;^DIST(.403,.001,20) + ;;=D POST^DICATTDE + ;;^DIST(.403,.001,40,0) + ;;=^.4031I^21^18 + ;;^DIST(.403,.001,40,1,0) + ;;=1^^1,1 + ;;^DIST(.403,.001,40,1,1) + ;;=Page 1 + ;;^DIST(.403,.001,40,1,40,0) + ;;=^.4032IP^.00101^1 + ;;^DIST(.403,.001,40,1,40,.00101,0) + ;;=.00101^1^1,1^e + ;;^DIST(.403,.001,40,1,40,.00101,11) + ;;=D PRE^DICATTD + ;;^DIST(.403,.001,40,2,0) + ;;=2.1^^4,3^^^1^12,70 + ;;^DIST(.403,.001,40,2,1) + ;;=Page 2.1 + ;;^DIST(.403,.001,40,2,12) + ;;=D POST1^DICATTD1 + ;;^DIST(.403,.001,40,2,40,0) + ;;=^.4032IP^.00102^1 + ;;^DIST(.403,.001,40,2,40,.00102,0) + ;;=.00102^1^2,3^e + ;;^DIST(.403,.001,40,3,0) + ;;=2.2^^4,3^^^1^9,70 + ;;^DIST(.403,.001,40,3,1) + ;;=Page 2.2 + ;;^DIST(.403,.001,40,3,12) + ;;=D POST2^DICATTD2 + ;;^DIST(.403,.001,40,3,40,0) + ;;=^.4032IP^.00103^1 + ;;^DIST(.403,.001,40,3,40,.00103,0) + ;;=.00103^1^2,3^e + ;;^DIST(.403,.001,40,6,0) + ;;=2.4^^3,8^^^1^7,67 + ;;^DIST(.403,.001,40,6,1) + ;;=Page 2.4 + ;;^DIST(.403,.001,40,6,12) + ;;=D POST4^DICATTD4 + ;;^DIST(.403,.001,40,6,40,0) + ;;=^.4032IP^.00104^1 + ;;^DIST(.403,.001,40,6,40,.00104,0) + ;;=.00104^1^1,1^e + ;;^DIST(.403,.001,40,7,0) + ;;=2.5^^4,6^^^1^6,75 + ;;^DIST(.403,.001,40,7,1) + ;;=Page 2.5 + ;;^DIST(.403,.001,40,7,40,0) + ;;=^.4032IP^.00105^1 + ;;^DIST(.403,.001,40,7,40,.00105,0) + ;;=.00105^1^1,1^e + ;;^DIST(.403,.001,40,8,0) + ;;=2.6^^3,2^^^1^11,77 + ;;^DIST(.403,.001,40,8,1) + ;;=Page 2.6 + ;;^DIST(.403,.001,40,8,12) + ;;=D POST6^DICATTD6 + ;;^DIST(.403,.001,40,8,40,0) + ;;=^.4032IP^.00106^1 + ;;^DIST(.403,.001,40,8,40,.00106,0) + ;;=.00106^1^1,1^e + ;;^DIST(.403,.001,40,9,0) + ;;=2.7^^3,2^^^1^8,75 + ;;^DIST(.403,.001,40,9,1) + ;;=Page 2.7 + ;;^DIST(.403,.001,40,9,12) + ;;=D POST7^DICATTD7 + ;;^DIST(.403,.001,40,9,40,0) + ;;=^.4032IP^.00107^1 + ;;^DIST(.403,.001,40,9,40,.00107,0) + ;;=.00107^1^1,1^e + ;;^DIST(.403,.001,40,10,0) + ;;=2.8^^3,3^^^1^11,77 + ;;^DIST(.403,.001,40,10,1) + ;;=Page 2.8 + ;;^DIST(.403,.001,40,10,40,0) + ;;=^.4032IP^.00108^1 + ;;^DIST(.403,.001,40,10,40,.00108,0) + ;;=.00108^1^1,1^e + ;;^DIST(.403,.001,40,11,0) + ;;=2.3^^3,6^^^1^17,70 + ;;^DIST(.403,.001,40,11,1) + ;;=Page 2.3 + ;;^DIST(.403,.001,40,11,12) + ;;=D POST3^DICATTD3 + ;;^DIST(.403,.001,40,11,40,0) + ;;=^.4032IP^.00109^1 + ;;^DIST(.403,.001,40,11,40,.00109,0) + ;;=.00109^1^1,1^e + ;;^DIST(.403,.001,40,12,0) + ;;=1.1^^1,1^^1 + ;;^DIST(.403,.001,40,12,1) + ;;=Page 1.1 + ;;^DIST(.403,.001,40,12,40,0) + ;;=^.4032IP^.0011^1 + ;;^DIST(.403,.001,40,12,40,.0011,0) + ;;=.0011^1^1,1^e + ;;^DIST(.403,.001,40,12,40,.0011,11) + ;;=D WORD^DICATTD0(21) + ;;^DIST(.403,.001,40,13,0) + ;;=1.2^^1,1 + ;;^DIST(.403,.001,40,13,1) + ;;=Page 1.2 + ;;^DIST(.403,.001,40,13,40,0) + ;;=^.4032IP^.00111^1 + ;;^DIST(.403,.001,40,13,40,.00111,0) + ;;=.00111^1^1,1^e + ;;^DIST(.403,.001,40,15,0) + ;;=3^^4,8^^^1^7,64 + ;;^DIST(.403,.001,40,15,1) + ;;=Page 3 + ;;^DIST(.403,.001,40,15,12) + ;;=D POST^DICATTDM + ;;^DIST(.403,.001,40,15,40,0) + ;;=^.4032IP^.00112^1 + ;;^DIST(.403,.001,40,15,40,.00112,0) + ;;=.00112^1^2,2^e + ;;^DIST(.403,.001,40,16,0) + ;;=9^^3,10^^^1^7,70 + ;;^DIST(.403,.001,40,16,1) + ;;=Page 9 + ;;^DIST(.403,.001,40,16,40,0) + ;;=^.4032IP^.00113^1 + ;;^DIST(.403,.001,40,16,40,.00113,0) + ;;=.00113^1^1,1^e + ;;^DIST(.403,.001,40,17,0) + ;;=4^^9,5^^^1^12,75 + ;;^DIST(.403,.001,40,17,1) + ;;=Page 4 + ;;^DIST(.403,.001,40,17,40,0) + ;;=^.4032IP^.00114^1 + ;;^DIST(.403,.001,40,17,40,.00114,0) + ;;=.00114^1^1,1^e diff --git a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DINIT0F5.m b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DINIT0F5.m index 1bb76c44..cc488065 100644 --- a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DINIT0F5.m +++ b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DINIT0F5.m @@ -1,266 +1,244 @@ -DINIT0F5 ;SFISC/MKO-DATA FOR FORM AND BLOCK FILES ;9APR2007 - ;;22.0;VA FileMan;**76,152**;Mar 30, 1999;Build 10 - ;Per VHA Directive 2004-038, this routine should not be modified. - F I=1:2 S X=$T(ENTRY+I) G:X="" ^DINIT0F6 S Y=$E($T(ENTRY+I+1),5,999),X=$E(X,4,999),@X=Y - Q -ENTRY ; - ;;^DIST(.404,.00102,40,4,20) - ;;=Y - ;;^DIST(.404,.00102,40,4,21,0) - ;;=^^1^1^2981102 - ;;^DIST(.404,.00102,40,4,21,1,0) - ;;=Can user enter time along with date, as in 'FEB23, 1999@7:30' - ;;^DIST(.404,.00102,40,5,0) - ;;=25^CAN SECONDS BE ENTERED^2^^SECONDS - ;;^DIST(.404,.00102,40,5,2) - ;;=5,29^3^5,5 - ;;^DIST(.404,.00102,40,5,3) - ;;=!M - ;;^DIST(.404,.00102,40,5,3.1) - ;;=S Y=$E("NY",$P(DICATT5,"""",2)["S"+1) - ;;^DIST(.404,.00102,40,5,20) - ;;=Y - ;;^DIST(.404,.00102,40,6,0) - ;;=26^IS TIME REQUIRED^2^^IS TIME REQUIRED - ;;^DIST(.404,.00102,40,6,2) - ;;=6,29^3^6,11 - ;;^DIST(.404,.00102,40,6,3) - ;;=!M - ;;^DIST(.404,.00102,40,6,3.1) - ;;=S Y=$E("NY",$P(DICATT5,"""",2)["R"+1) - ;;^DIST(.404,.00102,40,6,20) - ;;=Y - ;;^DIST(.404,.00102,40,6,21,0) - ;;=^^1^1^2981102 - ;;^DIST(.404,.00102,40,6,21,1,0) - ;;=Must user enter TIME along with DATE? - ;;^DIST(.404,.00103,0) - ;;=DICATT2^1 - ;;^DIST(.404,.00103,40,0) - ;;=^.4044I^4^4 - ;;^DIST(.404,.00103,40,1,0) - ;;=31^INCLUSIVE LOWER BOUND^2^^LOWER BOUND - ;;^DIST(.404,.00103,40,1,2) - ;;=1,38^20^1,15 - ;;^DIST(.404,.00103,40,1,3) - ;;=!M - ;;^DIST(.404,.00103,40,1,3.1) - ;;=I DICATT5["X<" S Y=+$P(DICATT5,"X<",2) - ;;^DIST(.404,.00103,40,1,4) - ;;=1 - ;;^DIST(.404,.00103,40,1,20) - ;;=F^^1:20 - ;;^DIST(.404,.00103,40,1,21,0) - ;;=^^1^1^2990219 - ;;^DIST(.404,.00103,40,1,21,1,0) - ;;=Enter the lowest allowable number - ;;^DIST(.404,.00103,40,1,22) - ;;=K:+X'=X!(X'["."&($L(X)>15))!(X["."&($L($P(+X,"."))+$L($P(+X,".",2))>15)) X - ;;^DIST(.404,.00103,40,2,0) - ;;=32^INCLUSIVE UPPER BOUND^2^^UPPER BOUND - ;;^DIST(.404,.00103,40,2,2) - ;;=2,38^20^2,15 - ;;^DIST(.404,.00103,40,2,3) - ;;=!M - ;;^DIST(.404,.00103,40,2,3.1) - ;;=I DICATT5["X>" S Y=+$P(DICATT5,"X>",2) - ;;^DIST(.404,.00103,40,2,4) - ;;=1 - ;;^DIST(.404,.00103,40,2,20) - ;;=F^^1:20 - ;;^DIST(.404,.00103,40,2,21,0) - ;;=^^1^1^2990219 - ;;^DIST(.404,.00103,40,2,21,1,0) - ;;=Enter the highest allowable number - ;;^DIST(.404,.00103,40,2,22) - ;;=K:+X'=X!(X'["."&($L(X)>15))!(X["."&($L($P(+X,"."))+$L($P(+X,"."))>15)) X - ;;^DIST(.404,.00103,40,3,0) - ;;=33^IS THIS A DOLLAR AMOUNT^2^^DOLLAR AMOUNT - ;;^DIST(.404,.00103,40,3,2) - ;;=3,38^3^3,13 - ;;^DIST(.404,.00103,40,3,3) - ;;=!M - ;;^DIST(.404,.00103,40,3,3.1) - ;;=S Y=$E("NY",DICATT5["""$"""+1) - ;;^DIST(.404,.00103,40,3,12) - ;;=I X=1 D PUT^DDSVALF(34,,,2,"") S DDSBR="COM" - ;;^DIST(.404,.00103,40,3,20) - ;;=Y - ;;^DIST(.404,.00103,40,4,0) - ;;=34^MAXIMUM NUMBER OF FRACTIONAL DIGITS^2^^FRACTIONAL DIGITS - ;;^DIST(.404,.00103,40,4,2) - ;;=4,38^1^4,1 - ;;^DIST(.404,.00103,40,4,3) - ;;=!M - ;;^DIST(.404,.00103,40,4,3.1) - ;;=S Y=$S(DICATT5["""$""":2,1:$P(DICATT5,"1"".""",2)-1) S:Y<0 Y=0 - ;;^DIST(.404,.00103,40,4,4) - ;;=0 - ;;^DIST(.404,.00103,40,4,20) - ;;=N^^0:9 - ;;^DIST(.404,.00104,0) - ;;=DICATT4^1 - ;;^DIST(.404,.00104,40,0) - ;;=^.4044I^3^3 - ;;^DIST(.404,.00104,40,1,0) - ;;=68^MINIMUM LENGTH^2^^MINIMUM LENGTH - ;;^DIST(.404,.00104,40,1,2) - ;;=2,27^3^2,11 - ;;^DIST(.404,.00104,40,1,3) - ;;=!M - ;;^DIST(.404,.00104,40,1,3.1) - ;;=S Y=+$P(DICATT5,"$L(X)<",2) - ;;^DIST(.404,.00104,40,1,4) - ;;=1 - ;;^DIST(.404,.00104,40,1,20) - ;;=N^^1:250:0 - ;;^DIST(.404,.00104,40,2,0) - ;;=69^MAXIMUM LENGTH^2^^MAXIMUM LENGTH - ;;^DIST(.404,.00104,40,2,2) - ;;=3,27^3^3,11 - ;;^DIST(.404,.00104,40,2,3) - ;;=!M - ;;^DIST(.404,.00104,40,2,3.1) - ;;=S Y=+$P(DICATT5,"$L(X)>",2) - ;;^DIST(.404,.00104,40,2,4) - ;;=1 - ;;^DIST(.404,.00104,40,2,20) - ;;=N^^1:250:0 - ;;^DIST(.404,.00104,40,3,0) - ;;=70^PATTERN MATCH (IN 'X')^2^^PATTERN MATCH - ;;^DIST(.404,.00104,40,3,2) - ;;=4,27^30^4,3 - ;;^DIST(.404,.00104,40,3,3) - ;;=!M - ;;^DIST(.404,.00104,40,3,3.1) - ;;=D PRE4^DICATTD4 - ;;^DIST(.404,.00104,40,3,20) - ;;=F^U^3:80 - ;;^DIST(.404,.00104,40,3,21,0) - ;;=^^1^1^2981104 - ;;^DIST(.404,.00104,40,3,21,1,0) - ;;=Example: "X?1.A" or "X'?.P" - ;;^DIST(.404,.00105,0) - ;;=DICATT5^1 - ;;^DIST(.404,.00105,40,0) - ;;=^.4044I^2^2 - ;;^DIST(.404,.00105,40,1,0) - ;;=75^SHALL THIS TEXT NORMALLY APPEAR IN WORD-WRAP MODE^2^^WORD-WRAP - ;;^DIST(.404,.00105,40,1,2) - ;;=2,53^3^2,2 - ;;^DIST(.404,.00105,40,1,3) - ;;=!M - ;;^DIST(.404,.00105,40,1,3.1) - ;;=S Y=$E("YN",DICATT2["L"+1) - ;;^DIST(.404,.00105,40,1,12) - ;;=S DICATTMN="",DICATT2N="W"_$TR($G(DICATT2N),"WL")_$E("L",'X) - ;;^DIST(.404,.00105,40,1,20) - ;;=Y - ;;^DIST(.404,.00105,40,1,21,0) - ;;=^^4^4^2981120 - ;;^DIST(.404,.00105,40,1,21,1,0) - ;;=Answer 'YES' if the text should normally be printed out in full lines, - ;;^DIST(.404,.00105,40,1,21,2,0) - ;;=breaking at word boundaries. - ;;^DIST(.404,.00105,40,1,21,3,0) - ;;=Answer 'NO' if the text should normally be printed out line-for-line as - ;;^DIST(.404,.00105,40,1,21,4,0) - ;;=it was entered. - ;;^DIST(.404,.00105,40,2,0) - ;;=76^SHALL "|" CHARACTERS IN THIS TEXT BE TREATED LIKE ANY OTHER CHARACTERS^2^^"|" - ;;^DIST(.404,.00105,40,2,2) - ;;=3,74^3^3,2 - ;;^DIST(.404,.00105,40,2,3) - ;;=!M - ;;^DIST(.404,.00105,40,2,3.1) - ;;=S Y=$S(DICATT2["X"!(DICATT2["x")!(DICATT2=""):"Y",1:"N") - ;;^DIST(.404,.00105,40,2,12) - ;;=S DICATTMN="",DICATT2N="W"_$TR($G(DICATT2N),"WxX")_$E("x",X>0) I DUZ(0)="@",DICATT4="" S DDSSTACK=4 - ;;^DIST(.404,.00105,40,2,20) - ;;=Y - ;;^DIST(.404,.00105,40,2,21,0) - ;;=^^4^4^2981120 - ;;^DIST(.404,.00105,40,2,21,1,0) - ;;=Answer 'YES' if the internally-stored text may have "|" characters in it - ;;^DIST(.404,.00105,40,2,21,2,0) - ;;=(such as HL7 messages) that need to display exactly as they are stored. - ;;^DIST(.404,.00105,40,2,21,3,0) - ;;=Answer 'NO' if the internal text should normally be printed out with - ;;^DIST(.404,.00105,40,2,21,4,0) - ;;=anything that is delimited by "|" characters interpreted as variable. - ;;^DIST(.404,.00106,0) - ;;=DICATT6^1 - ;;^DIST(.404,.00106,40,0) - ;;=^.4044I^8^8 - ;;^DIST(.404,.00106,40,1,0) - ;;=78^^2^^COMPUTED EXPRESSION - ;;^DIST(.404,.00106,40,1,2) - ;;=3,2^73 - ;;^DIST(.404,.00106,40,1,3) - ;;=!M - ;;^DIST(.404,.00106,40,1,3.1) - ;;=S Y=$G(^DD(DICATTA,DICATTF,9.1)) - ;;^DIST(.404,.00106,40,1,4) - ;;=1 - ;;^DIST(.404,.00106,40,1,13) - ;;=D VAL6^DICATTD6 - ;;^DIST(.404,.00106,40,1,20) - ;;=F^U^1:250 - ;;^DIST(.404,.00106,40,1,21,0) - ;;=^^3^3^2981118 - ;;^DIST(.404,.00106,40,1,21,1,0) - ;;=A Computed Expression consists of Field Names, Operators (including "_" - ;;^DIST(.404,.00106,40,1,21,2,0) - ;;=for concatenation), Functions, and literal strings (e.g., "Name: ") and - ;;^DIST(.404,.00106,40,1,21,3,0) - ;;=digits. - ;;^DIST(.404,.00106,40,2,0) - ;;=77^COMPUTED-FIELD EXPRESSION:^1^^COMP - ;;^DIST(.404,.00106,40,2,2) - ;;=^^2,2 - ;;^DIST(.404,.00106,40,3,0) - ;;=80^NUMBER OF FRACTIONAL DIGITS TO OUTPUT^2^^FRACTIONAL DIGITS - ;;^DIST(.404,.00106,40,3,2) - ;;=5,65^1^5,26 - ;;^DIST(.404,.00106,40,3,3) - ;;=!M - ;;^DIST(.404,.00106,40,3,3.1) - ;;=S Y=$P($P(DICATT2,"J",2),",",2),Y=$S(Y?1N.E:+Y,1:"") - ;;^DIST(.404,.00106,40,3,20) - ;;=N^^0:9:0 - ;;^DIST(.404,.00106,40,3,21,0) - ;;=^^2^2^2981118 - ;;^DIST(.404,.00106,40,3,21,1,0) - ;;=Enter the number of digits that should normally appear to the - ;;^DIST(.404,.00106,40,3,21,2,0) - ;;=right of the decimal point when this Field's value is displayed. - ;;^DIST(.404,.00106,40,4,0) - ;;=79^TYPE OF RESULT^2^^COMPTYPE - ;;^DIST(.404,.00106,40,4,2) - ;;=4,29^17^4,13 - ;;^DIST(.404,.00106,40,4,10) - ;;=D BR79^DICATTD6 - ;;^DIST(.404,.00106,40,4,20) - ;;=S^M^D:DATE;N:NUMERIC;B:BOOLEAN;S:STRING;m:MULTIPLE-VALUED;mp:MULTIPLE POINTER;p:POINTER - ;;^DIST(.404,.00106,40,4,21,0) - ;;=^^4^4^2981118 - ;;^DIST(.404,.00106,40,4,21,1,0) - ;;=The typical Computed Field is STRING-valued, i.e., alphanumeric. - ;;^DIST(.404,.00106,40,4,21,2,0) - ;;=If NUMERIC, the indented questions will be asked. - ;;^DIST(.404,.00106,40,4,21,3,0) - ;;=BOOLEAN values are "true-false". - ;;^DIST(.404,.00106,40,4,21,4,0) - ;;=If the computation returns a number that is actually an Entry number in a File, call it a POINTER. - ;;^DIST(.404,.00106,40,8,0) - ;;=83.1^POINT TO FILE^2 - ;;^DIST(.404,.00106,40,8,2) - ;;=8,46^27^8,30 - ;;^DIST(.404,.00106,40,8,3) - ;;=!M - ;;^DIST(.404,.00106,40,8,3.1) - ;;=S Y=+$P(DICATT2,"p",2),Y=$S(Y:$P($G(^DIC(Y,0)),U),1:"") - ;;^DIST(.404,.00106,40,8,20) - ;;=P^^1:EOFIZ - ;;^DIST(.404,.00106,40,8,24) - ;;=S DIR("S")="I $$OKFILE^DICOMPX(Y,""W"")" +DINIT0F5 ;SFISC/MKO-DATA FOR FORM AND BLOCK FILES ;05:51 PM 23 Mar 2001 + ;;22.0;VA FileMan;**76**;Mar 30, 1999 + ;Per VHA Directive 10-93-142, this routine should not be modified. + F I=1:2 S X=$T(ENTRY+I) G:X="" ^DINIT0F6 S Y=$E($T(ENTRY+I+1),5,999),X=$E(X,4,999),@X=Y + Q +ENTRY ; + ;;^DIST(.404,.00102,40,4,20) + ;;=Y + ;;^DIST(.404,.00102,40,4,21,0) + ;;=^^1^1^2981102 + ;;^DIST(.404,.00102,40,4,21,1,0) + ;;=Can user enter time along with date, as in 'FEB23, 1999@7:30' + ;;^DIST(.404,.00102,40,5,0) + ;;=25^CAN SECONDS BE ENTERED^2^^SECONDS + ;;^DIST(.404,.00102,40,5,2) + ;;=5,29^3^5,5 + ;;^DIST(.404,.00102,40,5,3) + ;;=!M + ;;^DIST(.404,.00102,40,5,3.1) + ;;=S Y=$E("NY",$P(DICATT5,"""",2)["S"+1) + ;;^DIST(.404,.00102,40,5,20) + ;;=Y + ;;^DIST(.404,.00102,40,6,0) + ;;=26^IS TIME REQUIRED^2^^IS TIME REQUIRED + ;;^DIST(.404,.00102,40,6,2) + ;;=6,29^3^6,11 + ;;^DIST(.404,.00102,40,6,3) + ;;=!M + ;;^DIST(.404,.00102,40,6,3.1) + ;;=S Y=$E("NY",$P(DICATT5,"""",2)["R"+1) + ;;^DIST(.404,.00102,40,6,20) + ;;=Y + ;;^DIST(.404,.00102,40,6,21,0) + ;;=^^1^1^2981102 + ;;^DIST(.404,.00102,40,6,21,1,0) + ;;=Must user enter TIME along with DATE? + ;;^DIST(.404,.00103,0) + ;;=DICATT2^1 + ;;^DIST(.404,.00103,40,0) + ;;=^.4044I^4^4 + ;;^DIST(.404,.00103,40,1,0) + ;;=31^INCLUSIVE LOWER BOUND^2^^LOWER BOUND + ;;^DIST(.404,.00103,40,1,2) + ;;=1,38^20^1,15 + ;;^DIST(.404,.00103,40,1,3) + ;;=!M + ;;^DIST(.404,.00103,40,1,3.1) + ;;=I DICATT5["X<" S Y=+$P(DICATT5,"X<",2) + ;;^DIST(.404,.00103,40,1,4) + ;;=1 + ;;^DIST(.404,.00103,40,1,20) + ;;=F^^1:20 + ;;^DIST(.404,.00103,40,1,21,0) + ;;=^^1^1^2990219 + ;;^DIST(.404,.00103,40,1,21,1,0) + ;;=Enter the lowest allowable number + ;;^DIST(.404,.00103,40,1,22) + ;;=K:+X'=X!(X'["."&($L(X)>15))!(X["."&($L($P(+X,"."))+$L($P(+X,".",2))>15)) X + ;;^DIST(.404,.00103,40,2,0) + ;;=32^INCLUSIVE UPPER BOUND^2^^UPPER BOUND + ;;^DIST(.404,.00103,40,2,2) + ;;=2,38^20^2,15 + ;;^DIST(.404,.00103,40,2,3) + ;;=!M + ;;^DIST(.404,.00103,40,2,3.1) + ;;=I DICATT5["X>" S Y=+$P(DICATT5,"X>",2) + ;;^DIST(.404,.00103,40,2,4) + ;;=1 + ;;^DIST(.404,.00103,40,2,20) + ;;=F^^1:20 + ;;^DIST(.404,.00103,40,2,21,0) + ;;=^^1^1^2990219 + ;;^DIST(.404,.00103,40,2,21,1,0) + ;;=Enter the highest allowable number + ;;^DIST(.404,.00103,40,2,22) + ;;=K:+X'=X!(X'["."&($L(X)>15))!(X["."&($L($P(+X,"."))+$L($P(+X,"."))>15)) X + ;;^DIST(.404,.00103,40,3,0) + ;;=33^IS THIS A DOLLAR AMOUNT^2^^DOLLAR AMOUNT + ;;^DIST(.404,.00103,40,3,2) + ;;=3,38^3^3,13 + ;;^DIST(.404,.00103,40,3,3) + ;;=!M + ;;^DIST(.404,.00103,40,3,3.1) + ;;=S Y=$E("NY",DICATT5["""$"""+1) + ;;^DIST(.404,.00103,40,3,12) + ;;=I X=1 D PUT^DDSVALF(34,,,2,"") S DDSBR="COM" + ;;^DIST(.404,.00103,40,3,20) + ;;=Y + ;;^DIST(.404,.00103,40,4,0) + ;;=34^MAXIMUM NUMBER OF FRACTIONAL DIGITS^2^^FRACTIONAL DIGITS + ;;^DIST(.404,.00103,40,4,2) + ;;=4,38^1^4,1 + ;;^DIST(.404,.00103,40,4,3) + ;;=!M + ;;^DIST(.404,.00103,40,4,3.1) + ;;=S Y=$S(DICATT5["""$""":2,1:$P(DICATT5,"1"".""",2)-1) S:Y<0 Y=0 + ;;^DIST(.404,.00103,40,4,4) + ;;=0 + ;;^DIST(.404,.00103,40,4,20) + ;;=N^^0:9 + ;;^DIST(.404,.00104,0) + ;;=DICATT4^1 + ;;^DIST(.404,.00104,40,0) + ;;=^.4044I^3^3 + ;;^DIST(.404,.00104,40,1,0) + ;;=68^MINIMUM LENGTH^2^^MINIMUM LENGTH + ;;^DIST(.404,.00104,40,1,2) + ;;=2,27^3^2,11 + ;;^DIST(.404,.00104,40,1,3) + ;;=!M + ;;^DIST(.404,.00104,40,1,3.1) + ;;=S Y=+$P(DICATT5,"$L(X)<",2) + ;;^DIST(.404,.00104,40,1,4) + ;;=1 + ;;^DIST(.404,.00104,40,1,20) + ;;=N^^1:250:0 + ;;^DIST(.404,.00104,40,2,0) + ;;=69^MAXIMUM LENGTH^2^^MAXIMUM LENGTH + ;;^DIST(.404,.00104,40,2,2) + ;;=3,27^3^3,11 + ;;^DIST(.404,.00104,40,2,3) + ;;=!M + ;;^DIST(.404,.00104,40,2,3.1) + ;;=S Y=+$P(DICATT5,"$L(X)>",2) + ;;^DIST(.404,.00104,40,2,4) + ;;=1 + ;;^DIST(.404,.00104,40,2,20) + ;;=N^^1:250:0 + ;;^DIST(.404,.00104,40,3,0) + ;;=70^PATTERN MATCH (IN 'X')^2^^PATTERN MATCH + ;;^DIST(.404,.00104,40,3,2) + ;;=4,27^30^4,3 + ;;^DIST(.404,.00104,40,3,3) + ;;=!M + ;;^DIST(.404,.00104,40,3,3.1) + ;;=D PRE4^DICATTD4 + ;;^DIST(.404,.00104,40,3,20) + ;;=F^U^3:80 + ;;^DIST(.404,.00104,40,3,21,0) + ;;=^^1^1^2981104 + ;;^DIST(.404,.00104,40,3,21,1,0) + ;;=Example: "X?1.A" or "X'?.P" + ;;^DIST(.404,.00105,0) + ;;=DICATT5^1 + ;;^DIST(.404,.00105,40,0) + ;;=^.4044I^1^1 + ;;^DIST(.404,.00105,40,1,0) + ;;=75^SHALL THIS TEXT NORMALLY APPEAR IN WORD-WRAP MODE^2^^WORD-WRAP + ;;^DIST(.404,.00105,40,1,2) + ;;=2,56^3^2,5 + ;;^DIST(.404,.00105,40,1,3) + ;;=!M + ;;^DIST(.404,.00105,40,1,3.1) + ;;=S Y=$E("YN",DICATT2["L"+1) + ;;^DIST(.404,.00105,40,1,12) + ;;=S DICATTMN="" S:'X DICATT2N="WL" I DUZ(0)="@",DICATT4="" S DDSSTACK=4 + ;;^DIST(.404,.00105,40,1,20) + ;;=Y + ;;^DIST(.404,.00105,40,1,21,0) + ;;=^^4^4^2981120 + ;;^DIST(.404,.00105,40,1,21,1,0) + ;;=Answer 'YES' if the text should normally be printed out in full lines, + ;;^DIST(.404,.00105,40,1,21,2,0) + ;;=breaking at word boundaries. + ;;^DIST(.404,.00105,40,1,21,3,0) + ;;=Answer 'NO' if the text should normally be printed out line-for-line as + ;;^DIST(.404,.00105,40,1,21,4,0) + ;;=it was entered. + ;;^DIST(.404,.00106,0) + ;;=DICATT6^1 + ;;^DIST(.404,.00106,40,0) + ;;=^.4044I^8^8 + ;;^DIST(.404,.00106,40,1,0) + ;;=78^^2^^COMPUTED EXPRESSION + ;;^DIST(.404,.00106,40,1,2) + ;;=3,2^73 + ;;^DIST(.404,.00106,40,1,3) + ;;=!M + ;;^DIST(.404,.00106,40,1,3.1) + ;;=S Y=$G(^DD(DICATTA,DICATTF,9.1)) + ;;^DIST(.404,.00106,40,1,4) + ;;=1 + ;;^DIST(.404,.00106,40,1,13) + ;;=D VAL6^DICATTD6 + ;;^DIST(.404,.00106,40,1,20) + ;;=F^U^1:250 + ;;^DIST(.404,.00106,40,1,21,0) + ;;=^^3^3^2981118 + ;;^DIST(.404,.00106,40,1,21,1,0) + ;;=A Computed Expression consists of Field Names, Operators (including "_" + ;;^DIST(.404,.00106,40,1,21,2,0) + ;;=for concatenation), Functions, and literal strings (e.g., "Name: ") and + ;;^DIST(.404,.00106,40,1,21,3,0) + ;;=digits. + ;;^DIST(.404,.00106,40,2,0) + ;;=77^COMPUTED-FIELD EXPRESSION:^1^^COMP + ;;^DIST(.404,.00106,40,2,2) + ;;=^^2,2 + ;;^DIST(.404,.00106,40,3,0) + ;;=80^NUMBER OF FRACTIONAL DIGITS TO OUTPUT^2^^FRACTIONAL DIGITS + ;;^DIST(.404,.00106,40,3,2) + ;;=5,65^1^5,26 + ;;^DIST(.404,.00106,40,3,3) + ;;=!M + ;;^DIST(.404,.00106,40,3,3.1) + ;;=S Y=$P($P(DICATT2,"J",2),",",2),Y=$S(Y?1N.E:+Y,1:"") + ;;^DIST(.404,.00106,40,3,20) + ;;=N^^0:9:0 + ;;^DIST(.404,.00106,40,3,21,0) + ;;=^^2^2^2981118 + ;;^DIST(.404,.00106,40,3,21,1,0) + ;;=Enter the number of digits that should normally appear to the + ;;^DIST(.404,.00106,40,3,21,2,0) + ;;=right of the decimal point when this Field's value is displayed. + ;;^DIST(.404,.00106,40,4,0) + ;;=79^TYPE OF RESULT^2^^COMPTYPE + ;;^DIST(.404,.00106,40,4,2) + ;;=4,29^17^4,13 + ;;^DIST(.404,.00106,40,4,10) + ;;=D BR79^DICATTD6 + ;;^DIST(.404,.00106,40,4,20) + ;;=S^M^D:DATE;N:NUMERIC;B:BOOLEAN;S:STRING;m:MULTIPLE-VALUED;mp:MULTIPLE POINTER;p:POINTER + ;;^DIST(.404,.00106,40,4,21,0) + ;;=^^4^4^2981118 + ;;^DIST(.404,.00106,40,4,21,1,0) + ;;=The typical Computed Field is STRING-valued, i.e., alphanumeric. + ;;^DIST(.404,.00106,40,4,21,2,0) + ;;=If NUMERIC, the indented questions will be asked. + ;;^DIST(.404,.00106,40,4,21,3,0) + ;;=BOOLEAN values are "true-false". + ;;^DIST(.404,.00106,40,4,21,4,0) + ;;=If the computation returns a number that is actually an Entry number in a File, call it a POINTER. + ;;^DIST(.404,.00106,40,8,0) + ;;=83.1^POINT TO FILE^2 + ;;^DIST(.404,.00106,40,8,2) + ;;=8,46^27^8,30 + ;;^DIST(.404,.00106,40,8,3) + ;;=!M + ;;^DIST(.404,.00106,40,8,3.1) + ;;=S Y=+$P(DICATT2,"p",2),Y=$S(Y:$P($G(^DIC(Y,0)),U),1:"") + ;;^DIST(.404,.00106,40,8,20) + ;;=P^^1:EOFIZ + ;;^DIST(.404,.00106,40,8,24) + ;;=S DIR("S")="I $$OKFILE^DICOMPX(Y,""W"")" diff --git a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIWE1.m b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIWE1.m index 1814cc41..d34b4a20 100644 --- a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIWE1.m +++ b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIWE1.m @@ -1,77 +1,66 @@ -DIWE1 ;SFISC/GFT-WORD PROCESSING FUNCTION ;4JUN2008 - ;;22.0;VA FileMan;**159**;Mar 30, 1999;Build 8 - ;Per VHA Directive 2004-038, this routine should not be modified. - G X:$D(DTOUT) I '$D(DWL) S I=DWLC,J=$S(I<11:1,1:I-8) W:J>1 ?7,". . .",!?7,". . ." D LL -1 G X:$D(DTOUT) R !,"EDIT Option: ",X:DTIME S:'$T DTOUT=1 G X:U[X!(X=".") -LC I X?1L S X=$C($A(X)-32) - S J="^DOPT(""DIWE1""," I X?1U S I=$F(DWO,X)-1 I I>0 S ^DISV(DUZ,J)=I S I=I*2-1 G OPT - I X=" ",$D(^DISV(DUZ,J)) S I=^(J),X=$E(DWO,I) I X]"" W X S I=I*2-1 G OPT - I X?1N.N S I=9 D LN G E2:X W "OR" - W !?5,"Choose, by first letter, a Word Processing Command" - I X?2"?".E W " from the following:" F I=1:2 S Y=$T(OPT+I),J=$E(Y,1) Q:J=" " I DWO[J W !?10,$P(Y,";",4) - W !?5,"or type a Line Number to edit that line." G 1 - ; -OPT Q:$D(DTOUT) S X1=$T(OPT+I),X=$P(X1,";",3) W $E(X,'$X)_$E(X,2,99) G @$E(X1,1) -A ;;Add lines;Add Lines to End of Text - D ^DIWE2 S (DWL,DWLC)=DWI,@(DIC_"0)=DWLC") G 1:DWLC,X -B ;;Break line: ;Break a Line into Two; - D RD G B^DIWE4 -C ;;Change every: ;Change Every String to Another in a Range of Lines; - G C^DIWE2 -D ;;Delete from line: ;Delete Line(s); - D RD G D^DIWE3 -E ;;Edit line: ;Edit a Line (Replace __ With __); - D RD G OPT:X="",1:X=U,LC:X?1A,E2 -G ;;Get Data from Another Source ;Get Data from Another Source - G X^DIWE5 -I ;;Insert after line: ;Insert Line(s) after an Existing Line; - D RD G I^DIWE2 -J ;;Join line: ;Join Line to the One Following; - D RD G J^DIWE4 -L ;;List line: ;List a Range of Lines; - S DIWELAST=$S($G(DIWELAST):DIWELAST,1:1) W DIWELAST_"//" R X:DTIME S:'$T X=U,DTOUT=1 S:X="" X=DIWELAST D LN G LIST:X,1:X=U W !,$P(X1,";",3) G L -M ;;Move line: ;Move Lines to New Location within Text; - D RD G M^DIWE3 -P ;;Print from Line: 1//;Print Lines as Formatted Output; - R X:DTIME S:'$T X=U,DTOUT=1 S:X="" X=1 D LN,^DIWE4:X G 1 -R ;;Repeat line: ;Repeat Lines at a New Location - D RD G R^DIWE3 -S ;;Search for: ;Search for a String - G S^DIWE2 -T ;;Transfer incoming text after line: ;Transfer Lines From Another Document - D RD,Z^DIWE3 G DIWE1 -U ;;Utilities in Word-Processing;Utility Sub-Menu - D ^DIWE11 G 1 -Y ;;Y;Y-Programmer Edit; - G Y^DIWE4 - ;; -E2 S Y=^(0) S:Y="" Y=" " W !,$J(DWL,3)_">"_Y,! S DIRWP=1 D RW^DIR2 K DIRWP G E2:X?1."?",X:X?1."^" -TAB I X[$C(9) S X=$P(X,$C(9),1)_$C(124)_"TAB"_$C(124)_$P(X,$C(9),2,999) G TAB - S:X]"" ^(0)=X - ;check if line is greater than max, DWLW, break line up and treat as an insert - I $L(X)>DWLW D - . N I,J,DIC1 - . K ^UTILITY($J,"W") S DIC1=DIC,DIC="^UTILITY($J,""W"",",@(DIC_"0)")="" - . F DWI=1:1 Q:$L(X)'>DWLW S J=$F(X," ",DWLW-7),J=$S(J<1!(J>DWLW):DWLW,1:J),@(DIC_"DWI,0)")=$E(X,1,J-1),X=$E(X,J,256) - . S @(DIC_"DWI,0)")=X - . W !,(DWI-1)_" line"_$E("s",DWI>2)_" inserted.." - . X "F J=DWL+1:1:DWLC S DWI=DWI+1,"_DIC_"DWI,0)="_DIC1_"J,0) W "".""" - . S I=DWL X "F J=1:1 Q:'$D("_DIC_"J,0)) S "_DIC1_"I,0)=^(0),I=I+1 W "".""" - . S DWLC=I-1,DIC=DIC1 K ^UTILITY($J,"W") - E I X="@" S (DW1,DW2)=DWL W "DELETED..." D DEL^DIWE3 - W ! S I=9 G OPT - ; -RD R X:DTIME S:'$T DTOUT=1 I X?1."?" W !?5,"Enter a line number from 1 through "_DWLC,!!,$P(X1,";",3) G RD -LN I U[X!(X=".") S X=U Q - Q:I=9&(X?1A) I 'DWLC,I<27,I-13 S X=U W " THERE ARE NO LINES!",$C(7),! Q - I "+- "[$E(X,1),X?1P.N,$D(DWL) S:X?1P X=X_1 S X=X+DWL W " "_X - E S X=+X - I (I=13!(I=27)&(X=0))!$D(@(DIC_"X,0)")) S DWL=X Q - S X="" G LNQ^DIWE5 - ; -X K DIWELAST - G X^DIWE - ; -LIST W " to: "_DWLC_"// " R I:DTIME S:'$T DTOUT=1 S I=$S(I="":DWLC,1:I) I I,I>DWLC!(I<1) S I=DWLC - S J=X,DIWELAST=$S(DWLC=I:1,1:I) D LL G 1 -LL X "F J=J:1:I W !,$J(J,3)_"">""_"_DIC_"J,0)" +DIWE1 ;SFISC/GFT-WORD PROCESSING FUNCTION ;7/29/94 09:18 + ;;22.0;VA FileMan;;Mar 30, 1999 + ;Per VHA Directive 10-93-142, this routine should not be modified. + G X:$D(DTOUT) I '$D(DWL) S I=DWLC,J=$S(I<11:1,1:I-8) W:J>1 ?7,". . .",!?7,". . ." D LL +1 G X:$D(DTOUT) R !,"EDIT Option: ",X:DTIME S:'$T DTOUT=1 G X:U[X!(X=".") +LC I X?1L S X=$C($A(X)-32) + S J="^DOPT(""DIWE1""," I X?1U S I=$F(DWO,X)-1 I I>0 S ^DISV(DUZ,J)=I S I=I*2-1 G OPT + I X=" ",$D(^DISV(DUZ,J)) S I=^(J),X=$E(DWO,I) I X]"" W X S I=I*2-1 G OPT + I X?1N.N S I=9 D LN G E2:X W "OR" + W !?5,"Choose, by first letter, a Word Processing Command" + I X?2"?".E W " from the following:" F I=1:2 S Y=$T(OPT+I),J=$E(Y,1) Q:J=" " I DWO[J W !?10,$P(Y,";",4) + W !?5,"or type a Line Number to edit that line." G 1 + ; +OPT Q:$D(DTOUT) S X1=$T(OPT+I),X=$P(X1,";",3) W $E(X,'$X)_$E(X,2,99) G @$E(X1,1) +A ;;Add lines;Add Lines to End of Text + D ^DIWE2 S (DWL,DWLC)=DWI,@(DIC_"0)=DWLC") G 1:DWLC,X +B ;;Break line: ;Break a Line into Two; + D RD G B^DIWE4 +C ;;Change every: ;Change Every String to Another in a Range of Lines; + G C^DIWE2 +D ;;Delete from line: ;Delete Line(s); + D RD G D^DIWE3 +E ;;Edit line: ;Edit a Line (Replace __ With __); + D RD G OPT:X="",1:X=U,LC:X?1A,E2 +G ;;Get Data from Another Source ;Get Data from Another Source + G X^DIWE5 +I ;;Insert after line: ;Insert Line(s) after an Existing Line; + D RD G I^DIWE2 +J ;;Join line: ;Join Line to the One Following; + D RD G J^DIWE4 +L ;;List line: ;List a Range of Lines; + S DIWELAST=$S($G(DIWELAST):DIWELAST,1:1) W DIWELAST_"//" R X:DTIME S:'$T X=U,DTOUT=1 S:X="" X=DIWELAST D LN G LIST:X,1:X=U W !,$P(X1,";",3) G L +M ;;Move line: ;Move Lines to New Location within Text; + D RD G M^DIWE3 +P ;;Print from Line: 1//;Print Lines as Formatted Output; + R X:DTIME S:'$T X=U,DTOUT=1 S:X="" X=1 D LN,^DIWE4:X G 1 +R ;;Repeat line: ;Repeat Lines at a New Location + D RD G R^DIWE3 +S ;;Search for: ;Search for a String + G S^DIWE2 +T ;;Transfer incoming text after line: ;Transfer Lines From Another Document + D RD,Z^DIWE3 G DIWE1 +U ;;Utilities in Word-Processing;Utility Sub-Menu + D ^DIWE11 G 1 +Y ;;Y;Y-Programmer Edit; + G Y^DIWE4 + ;; +E2 S Y=^(0) S:Y="" Y=" " W !,$J(DWL,3)_">"_Y,! S DIRWP=1 D RW^DIR2 K DIRWP G E2:X?1."?",X:X?1."^" +TAB I X[$C(9) S X=$P(X,$C(9),1)_$C(124)_"TAB"_$C(124)_$P(X,$C(9),2,999) G TAB + S:X]"" ^(0)=X I X="@" S (DW1,DW2)=DWL W "DELETED..." D DEL^DIWE3 + W ! S I=9 G OPT + ; +RD R X:DTIME S:'$T DTOUT=1 I X?1."?" W !?5,"Enter a line number from 1 through "_DWLC,!!,$P(X1,";",3) G RD +LN I U[X!(X=".") S X=U Q + Q:I=9&(X?1A) I 'DWLC,I<27,I-13 S X=U W " THERE ARE NO LINES!",$C(7),! Q + I "+- "[$E(X,1),X?1P.N,$D(DWL) S:X?1P X=X_1 S X=X+DWL W " "_X + E S X=+X + I (I=13!(I=27)&(X=0))!$D(@(DIC_"X,0)")) S DWL=X Q + S X="" G LNQ^DIWE5 + ; +X K DIWELAST + G X^DIWE + ; +LIST W " to: "_DWLC_"// " R I:DTIME S:'$T DTOUT=1 S I=$S(I="":DWLC,1:I) I I,I>DWLC!(I<1) S I=DWLC + S J=X,DIWELAST=$S(DWLC=I:1,1:I) D LL G 1 +LL X "F J=J:1:I W !,$J(J,3)_"">""_"_DIC_"J,0)" diff --git a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIWP.m b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIWP.m index 73e3e361..ddbffc26 100644 --- a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIWP.m +++ b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIWP.m @@ -1,73 +1,52 @@ -DIWP ;SFISC/GFT-ASSEMBLE WP LINE ;10JUN2005 - ;;22.0;VA FileMan;**46,152**;Mar 30, 1999;Build 10 - ;Per VHA Directive 2004-038, this routine should not be modified. - ;The DIWF variable contains a string of one-letter codes to control W-P output. - ;"|" in DIWF means that "|"-windows are not to be evaluated, but are to be printed as - ; they stand. - ;"X" means eXactly line-for-line, with "||" printed as "||" - ;"W" in DIWF means that formatted text will be written out to - ; the current device as it is assembled. - ;"N" means NOWRAP-- text is assembled line-for-line - ;"R" means text will be assembled Right-justified - ;"D" means text will be double-spaced - ;"L" means internal line numbers appear at the left margin - ;"C" followed by a number will cause formatting of text in a column - ; width specified by the number. - ;"I" followed by a number will cause text to be indented that number - ; of columns. - ;"?" means that, if user's terminal is available, "|"-windows that cannot - ; be evaluated will be asked from the user's terminal. - ;"B" followed by number causes new page when output gets within that - ; number of lines from the bottom of the page (as defined by IOSL). - ; - ;DIWTC is a Boolean -- Are we printing out in LINE MODE? - S:'$L(X) X=" " - S DIWTC=X[($C(124)_"TAB") S:'$D(DN) DN=1 -LN S:'$D(DIWF) DIWF="" S:'DIWTC DIWTC=DIWF["N" S DIWX=X,DIW=$C(124),I=$P(DIWF,"C",2) I I S DIWR=DIWL+I-1 - I '$D(^UTILITY($J,"W",DIWL)) S ^(DIWL)=1 K DIWFU,DIWFWU,DIWLL D DIWI S:'$D(DIWT) DIWT="5,10,15,20,25" G DIW - S I=^(DIWL),DIWI=^(DIWL,I,0) I DIWI="" D DIWI G Z - D NEW:DIWTC -Z S Z=X?.P!DIWTC I X?1" ".E!Z S DIWTC=1 D NEW:DIWI]"" S DIWTC=Z -DIW ;from RCR+5^DIWW - I DIWF["X" S DIWTC=1,X=DIWX,DIWX="" D C G D ;**DI*22*152** Leave line unaltered - S X=$P(DIWX,DIW,1) D C:X]"" S X=$P(DIWX,DIW,1),DIWX=$P(DIWX,DIW,2,999) G D:DIWX="" I $D(DIWP),X'?.E1" " D ST - S X=$P(DIWX,DIW,1) I $P(X,"TAB",1)="" D TAB G N - I X="TOP" D PUT S ^("X")="S DIFF=1 X:$D(^UTILITY($J,1)) ^(1)" D NEW G N - I DIWF'[DIW G U:X="_" D PUT,RCR^DIWW G N:$D(X) - S X=DIW_$P(DIWX,DIW,1)_DIW D C -N K X S DIWX=$P(DIWX,DIW,2,99) I DIWX]"" D ST:$D(DIWP) G DIW -D K DIWP D PUT,PRE:DIWTC S:DIWTC DIWI="" Q - ; -ST S DIWI=$E(DIWI,1,$L(DIWI)-1) K DIWP Q - ; -DIWI S DIWI=$J("",+$P(DIWF,"I",2)) I DIWF["L",$D(D)#2 S DIWLL=D - Q -PUT S I=^UTILITY($J,"W",DIWL),^(DIWL,I,0)=DIWI I DIWF["L",$D(DIWLL) S ^("L")=DIWLL - Q -L ; - S DIWTC=1 G LN - ; -TAB I X="" S X=DIW G C - S J=$P(DIWT,",",DIWTC),DIWTC=DIWTC+1 S:X?3A1P.P.N.E J=$E(X,5,9) S:J?1"""".E1"""" J=$E(J,2,$L(J)-1) - I J'>0 S %=$P(DIWX,DIW,2) Q:%="" S J=$S(J<0:1-$L(%)-J,J="C":DIWR-DIWL-$L(%)\2,1:0) - S J=J-1-$L(DIWI) Q:J<1 S X=$J("",J) -C K DIWP I DIWTC S DIWI=DIWI_X Q -B S Z=DIWR-DIWL+1-$L(DIWI) G FULL:$F(X," ")-1>Z F %=Z:-1 I " "[$E(X,%) S:$E(X,%+1)=" " %=%+1 Q - S Z=$E(X,1,%-1),X=$E(X,%+1,999) I Z]"" S DIWI=DIWI_Z G S:X]"" S %=$E(Z,$L(Z)) S:%'=" " DIWI=DIWI_$J("",%="."+1),DIWP=1 Q -FULL I $P(DIWF,"I",2)'<$L(DIWI) S DIWI=DIWI_$P(X," ",1),X=$P(X," ",2,999) -S D PUT,NEW G B:X]"" Q - ; -U S I=^UTILITY($J,"W",DIWL) I $D(DIWFU) S ^(DIWL,I,"U",$L(DIWI)+1)="" K DIWFU G N - S ^(DIWL,I,"U",$L(DIWI)+1)=X,DIWFU=1 G N - ; -NEW D DIWI -PRE S I=^UTILITY($J,"W",DIWL),^(DIWL)=I+1,^(DIWL,I+1,0)="" I DIWF["D" S ^(0)=" ",^UTILITY($J,"W",DIWL)=I+2,^(DIWL,I+2,0)="" - I $D(DIWFU) S ^("U",1+$P(DIWF,"I",2))="_" - G P:DIWF'["R"!DIWTC K % Q:'$D(^UTILITY($J,"W",DIWL,I,0)) - S Y=^(0),%=$L(Y) F %=%:-1 Q:$A(Y,%)-32 - S Y=$E(Y,1,%),J=DIWR-DIWL-%+1,%X=0 G P:J<1 - F %=1:1 S %(%)=$P(Y," ",1),Y=$P(Y," ",2,999) G:Y="" PAD:%-1,P I $E(%(%),$L(%(%)))?.P S:%=1&(%(%)="") %=0,%X=%X+1 S:%&J J=J-1,%(%)=%(%)_" " -PAD I J F Y=%\2+1:1:%-1,%\2:-1 S %(Y)=%(Y)_" ",J=J-1 G PAD:Y=1!'J - S Y=%(%) F %=%-1:-1:1 S Y=%(%)_" "_Y - S ^(0)=$J("",%X)_Y K % -P I DIWF["W" G NX^DIWW +DIWP ;SFISC/GFT-ASSEMBLE WP LINE ;12:15 PM 5 Jun 2000 + ;;22.0;VA FileMan;**46**;Mar 30, 1999 + ;Per VHA Directive 10-93-142, this routine should not be modified. + S:'$L(X) X=" " + S DIWTC=X[($C(124)_"TAB") S:'$D(DN) DN=1 +LN S:'$D(DIWF) DIWF="" S:'DIWTC DIWTC=DIWF["N" S DIWX=X,DIW=$C(124),I=$P(DIWF,"C",2) I I S DIWR=DIWL+I-1 + I '$D(^UTILITY($J,"W",DIWL)) S ^(DIWL)=1 K DIWFU,DIWFWU,DIWLL D DIWI S:'$D(DIWT) DIWT="5,10,15,20,25" G DIW + S I=^(DIWL),DIWI=^(DIWL,I,0) I DIWI="" D DIWI G Z + D NEW:DIWTC +Z S Z=X?.P!DIWTC I X?1" ".E!Z S DIWTC=1 D NEW:DIWI]"" S DIWTC=Z +DIW ; + S X=$P(DIWX,DIW,1) D C:X]"" S X=$P(DIWX,DIW,1),DIWX=$P(DIWX,DIW,2,999) G D:DIWX="" I $D(DIWP),X'?.E1" " D ST + S X=$P(DIWX,DIW,1) I $P(X,"TAB",1)="" D TAB G N + I X="TOP" D PUT S ^("X")="S DIFF=1 X:$D(^UTILITY($J,1)) ^(1)" D NEW G N + I DIWF'[DIW G U:X="_" D PUT,RCR^DIWW G N:$D(X) + S X=DIW_$P(DIWX,DIW,1)_DIW D C +N K X S DIWX=$P(DIWX,DIW,2,99) I DIWX]"" D ST:$D(DIWP) G DIW +D K DIWP D PUT,PRE:DIWTC S:DIWTC DIWI="" Q + ; +ST S DIWI=$E(DIWI,1,$L(DIWI)-1) K DIWP Q + ; +DIWI S DIWI=$J("",+$P(DIWF,"I",2)) I DIWF["L",$D(D)#2 S DIWLL=D + Q +PUT S I=^UTILITY($J,"W",DIWL),^(DIWL,I,0)=DIWI I DIWF["L",$D(DIWLL) S ^("L")=DIWLL + Q +L ; + S DIWTC=1 G LN + ; +TAB I X="" S X=DIW G C + S J=$P(DIWT,",",DIWTC),DIWTC=DIWTC+1 S:X?3A1P.P.N.E J=$E(X,5,9) S:J?1"""".E1"""" J=$E(J,2,$L(J)-1) + I J'>0 S %=$P(DIWX,DIW,2) Q:%="" S J=$S(J<0:1-$L(%)-J,J="C":DIWR-DIWL-$L(%)\2,1:0) + S J=J-1-$L(DIWI) Q:J<1 S X=$J("",J) +C K DIWP I DIWTC S DIWI=DIWI_X Q +B S Z=DIWR-DIWL+1-$L(DIWI) G FULL:$F(X," ")-1>Z F %=Z:-1 I " "[$E(X,%) S:$E(X,%+1)=" " %=%+1 Q + S Z=$E(X,1,%-1),X=$E(X,%+1,999) I Z]"" S DIWI=DIWI_Z G S:X]"" S %=$E(Z,$L(Z)) S:%'=" " DIWI=DIWI_$J("",%="."+1),DIWP=1 Q +FULL I $P(DIWF,"I",2)'<$L(DIWI) S DIWI=DIWI_$P(X," ",1),X=$P(X," ",2,999) +S D PUT,NEW G B:X]"" Q + ; +U S I=^UTILITY($J,"W",DIWL) I $D(DIWFU) S ^(DIWL,I,"U",$L(DIWI)+1)="" K DIWFU G N + S ^(DIWL,I,"U",$L(DIWI)+1)=X,DIWFU=1 G N + ; +NEW D DIWI +PRE S I=^UTILITY($J,"W",DIWL),^(DIWL)=I+1,^(DIWL,I+1,0)="" I DIWF["D" S ^(0)=" ",^UTILITY($J,"W",DIWL)=I+2,^(DIWL,I+2,0)="" + I $D(DIWFU) S ^("U",1+$P(DIWF,"I",2))="_" + G P:DIWF'["R"!DIWTC K % Q:'$D(^UTILITY($J,"W",DIWL,I,0)) + S Y=^(0),%=$L(Y) F %=%:-1 Q:$A(Y,%)-32 + S Y=$E(Y,1,%),J=DIWR-DIWL-%+1,%X=0 G P:J<1 + F %=1:1 S %(%)=$P(Y," ",1),Y=$P(Y," ",2,999) G:Y="" PAD:%-1,P I $E(%(%),$L(%(%)))?.P S:%=1&(%(%)="") %=0,%X=%X+1 S:%&J J=J-1,%(%)=%(%)_" " +PAD I J F Y=%\2+1:1:%-1,%\2:-1 S %(Y)=%(Y)_" ",J=J-1 G PAD:Y=1!'J + S Y=%(%) F %=%-1:-1:1 S Y=%(%)_" "_Y + S ^(0)=$J("",%X)_Y K % +P I DIWF["W" G NX^DIWW diff --git a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIWW.m b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIWW.m index 38dd3203..26e324d6 100644 --- a/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIWW.m +++ b/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIWW.m @@ -1,59 +1,59 @@ -DIWW ;SFISC/GFT-OUTPUT WP LINE ;5NOV2007 - ;;22.0;VA FileMan;**64,144,152**;Mar 30, 1999;Build 10 - ;Per VHA Directive 2004-038, this routine should not be modified. - F I=0:1 G:$D(DN) QQ:'DN Q:$D(^UTILITY($J,"W"))<9 D T G:$D(DN) QQ:'DN D 0 -T W:$X ! -B Q:$S($D(DN):'DN,1:0) I '$D(DIWF) S DIWF="" - I '$D(DIOT(2)),$D(IOSL),$Y+$S($P(DIWF,"B",2):$P(DIWF,"B",2),1:2)'DIWL ! D B G:$D(DN) Q:'DN -0 ; - S I=999999,%="" F S %=$O(^UTILITY($J,"W",%)) Q:%="" S:$O(^(%,""))0)>% ! I DIWF["L",$D(^("L")) W $E(^("L")_" ",1,4) -O W ?%-1,^(0) -X D U:$D(^("U")) I $D(^("X")) S Y=^("X") D K X Y Q -K K ^UTILITY($J,"W",%,I) Q - ; -U Q:'$D(IOST) Q:IOST'?1"P".E W $C(13) F DE=1:1:$S($D(^("L")):%+3,1:%-1) W " " - S DE=1 -UU S %Y=$O(^UTILITY($J,"W",%,I,"U","")) I %Y="" S %Y=$L(^UTILITY($J,"W",%,I,0))+1 S:'$D(DIWFWU) DIWFWU=" " D UUU K DIWFWU Q - S Y=^(%Y) K ^(%Y) I Y="" D UUU K DIWFWU G UU - S DIWFWU=Y F DE=DE:1 G UU:DE'<%Y W " " -UUU I $D(DIWFWU) F DE=DE:1 Q:DE'<%Y W DIWFWU -Q Q -QQ K DIWI,DIWX,DIWTC Q - ; -RCR ; - N DA,M,DQI,DA - F M="DIWX","DICMX","DIC","D","D0","D1","D2","D3","D4","D5","D6","D7","Y","I","J" M %=@M N @M M @M=% - S DQI="Y(",DA="X(",DICMX="X DICMX",DICOMP="ST" S:$D(DIA("P"))#2 J(0)=DIA("P") D EN1^DICOMP - I '$D(X) Q:DIWF'["?"!(IO(0)=IO)!$D(IO("C")) U IO(0) W $C(7),!,$P(@(I(0)_"D0,0)"),U),"---",!?4,$P(DIWX,DIW)_": " R X:DTIME,! U IO G BACK - I Y["m" S DICMX=$S(Y["w":"D ^DIWP",1:"S DIWX=X,DIWTC=1 D DIW^DIWP S DIWI=$J("""","_$L(DIWI)_")") X X S X="" G BACK - I Y["X" S X=DIW_X_DIW G BACK - I $P(DIWX,"SETPAGE(",1)="" S ^(DIWL,^UTILITY($J,"W",DIWL),"X")=X,X="" G BACK - S DICMX=Y["D" X X I DICMX S Y=X X ^DD("DD") S X=Y - I $P(DIWX,"INDENT(")="" S X=$J(X,$P(DIWF,"I",2)-$L(DIWI)-1) -BACK D C^DIWP:X]"" S X="" - Q - ; -DIQ ; - S DIWF=$E("N",C["L")_"W"_$E("|X",C["X"!(C["x")+1),DIWL=2,DIWR=IOM,X=O_": " K ^UTILITY($J,"W") - S W=0 F D S W=$O(@(D(DL-1)_"W)")) Q:W'>0!(S=0) S X=^(W,0) - .D ^DIWP - .N W D LF^DIQ - G DIWW - ; -H G H^DIO2 -DT G DT^DIO2 - ; -N W ! G B +DIWW ;SFISC/GFT-OUTPUT WP LINE ;02:59 PM 18 Apr 2002 + ;;22.0;VA FileMan;**64,144**;Mar 30, 1999;Build 5 + ;Per VHA Directive 2004-038, this routine should not be modified. + F I=0:1 G:$D(DN) QQ:'DN Q:$D(^UTILITY($J,"W"))<9 D T G:$D(DN) QQ:'DN D 0 +T W:$X ! +B Q:$S($D(DN):'DN,1:0) I '$D(DIWF) S DIWF="" + I '$D(DIOT(2)),$D(IOSL),$Y+$S($P(DIWF,"B",2):$P(DIWF,"B",2),1:2)'DIWL ! D B G:$D(DN) Q:'DN +0 ; + S I=999999,%="" F S %=$O(^UTILITY($J,"W",%)) Q:%="" S:$O(^(%,""))0)>% ! I DIWF["L",$D(^("L")) W $E(^("L")_" ",1,4) +O W ?%-1,^(0) +X D U:$D(^("U")) I $D(^("X")) S Y=^("X") D K X Y Q +K K ^UTILITY($J,"W",%,I) Q + ; +U Q:'$D(IOST) Q:IOST'?1"P".E W $C(13) F DE=1:1:$S($D(^("L")):%+3,1:%-1) W " " + S DE=1 +UU S %Y=$O(^UTILITY($J,"W",%,I,"U","")) I %Y="" S %Y=$L(^UTILITY($J,"W",%,I,0))+1 S:'$D(DIWFWU) DIWFWU=" " D UUU K DIWFWU Q + S Y=^(%Y) K ^(%Y) I Y="" D UUU K DIWFWU G UU + S DIWFWU=Y F DE=DE:1 G UU:DE'<%Y W " " +UUU I $D(DIWFWU) F DE=DE:1 Q:DE'<%Y W DIWFWU +Q Q +QQ K DIWI,DIWX,DIWTC Q + ; +RCR ; + N DA,M,DQI,DA + F M="DIWX","DICMX","DIC","D","D0","D1","D2","D3","D4","D5","D6","D7","Y","I","J" M %=@M N @M M @M=% + S DQI="Y(",DA="X(",DICMX="X DICMX",DICOMP="ST" S:$D(DIA("P"))#2 J(0)=DIA("P") D EN1^DICOMP + I '$D(X) Q:DIWF'["?"!(IO(0)=IO)!$D(IO("C")) U IO(0) W $C(7),!,$P(@(I(0)_"D0,0)"),U),"---",!?4,$P(DIWX,DIW)_": " R X:DTIME,! U IO G BACK + I Y["m" S DICMX=$S(Y["w":"D ^DIWP",1:"S DIWX=X,DIWTC=1 D DIW^DIWP S DIWI=$J("""","_$L(DIWI)_")") X X S X="" G BACK + I Y["X" S X=DIW_X_DIW G BACK + I $P(DIWX,"SETPAGE(",1)="" S ^(DIWL,^UTILITY($J,"W",DIWL),"X")=X,X="" G BACK + S DICMX=Y["D" X X I DICMX S Y=X X ^DD("DD") S X=Y + I $P(DIWX,"INDENT(")="" S X=$J(X,$P(DIWF,"I",2)-$L(DIWI)-1) +BACK D C^DIWP:X]"" S X="" + Q + ; +DIQ ; + S DIWF=$E("N",C["L")_"W|",DIWL=2,DIWR=IOM,X=O_": " K ^UTILITY($J,"W") + S W=0 F D S W=$O(@(D(DL-1)_"W)")) Q:W'>0!(S=0) S X=^(W,0) + .D ^DIWP + .N W D LF^DIQ + G DIWW + ; +H G H^DIO2 +DT G DT^DIO2 + ; +N W ! G B diff --git a/r/WOMENS_HEALTH-WV/WVLABCHK.m b/r/WOMENS_HEALTH-WV/WVLABCHK.m index 537c6440..6037c4e7 100644 --- a/r/WOMENS_HEALTH-WV/WVLABCHK.m +++ b/r/WOMENS_HEALTH-WV/WVLABCHK.m @@ -1,138 +1,137 @@ -WVLABCHK ;HIOFO/FT-IS LAB TEST A PAP SMEAR? ;10/25/04 10:23 - ;;1.0;WOMEN'S HEALTH;**16,23**;Sep 30, 1998;Build 5 - ; - ; This routine uses the following IAs: - ; #525 - ^LR references (controlled) - ; #4298 - ^LR references (private) - ; #10103 - ^XLFDT calls (supported) - ; #10063 - ^%ZTLOAD (supported) - ; #10141 - ^XPDUTL (supported) - ; #10035 - ^DPT (supported) - ; - ; This routine supports the following IAs: - ; CREATE - 4525 - ; -CREATE(DFN,LRDFN,LRI,LRA,LRSS) ; - ; Add lab test to WH file (#790.08). - ; Called by REPORT RELEASE DATE/TIME field in: - ; a) File 63, Field 63.08,.11 - ; b) File 63, Field 63.09,.11 - ; Input: DFN = PATIENT DFN - ; LRDFN = FILE 63 IEN (+^DPT(DFN,"LR")) - ; LRI = INVERSE DATE/TIME OF TEST - ; LRA = ZERO NODE OF THE CY or SP ENTRY - ; LRSS = File 63 subscript (e.g., CY or SP) - ; - Q:($G(DFN)']"")!($G(LRDFN)']"")!($G(LRI)']"")!($G(LRA)']"")!($G(LRSS)']"") - Q:'$D(^WV(790.02,DUZ(2))) ;no site parameter entry - Q:'$P($G(^WV(790.02,+$G(DUZ(2)),0)),U,24) ;lab link is NO or null - N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE - S ZTRTN="CREATEQ^WVLABCHK",ZTDESC="WV CHECK SNOMED CODE CHANGES" - S ZTSAVE("DFN")="",ZTSAVE("LRDFN")="",ZTSAVE("LRI")="",ZTSAVE("LRA")="" - S ZTSAVE("LRSS")="",ZTIO="" - S ZTDTH=$$HADD^XLFDT($H,"","","",150) ;don't want the SNOMED trigger to - ; conflict with the report verification trigger - D ^%ZTLOAD - Q -CREATEQ ; Called from CREATE above - I $D(ZTQUEUED) S ZTREQ="@" - N WVDATE,WVDFN,WVDUZ2,WVIEN,WVLABAN,WVLOC,WVLRDFN,WVLRI,WVLRSS,WVNODE,WVPAP,WVPIEN,WVPROV,WVTOP,X,Y - Q:$P($G(^DPT(DFN,0)),U,2)'="F" ;not female - S WVLABAN=$P(LRA,U,6) ;lab accession# - Q:$D(^WV(790.1,"F",WVLABAN)) ;already tracked - ; check WH site parameters - Q:'$D(^WV(790.02,DUZ(2))) ;no site parameter entry - Q:'$P($G(^WV(790.02,+$G(DUZ(2)),0)),U,24) ;lab link is NO or null - Q:'$$VNVEC^WVLRLINK() ;vet/non-vet/eligibility code check - D CODES ;what SNOMED codes are we looking for? - I WVTOP(0)=0 Q ;no SNOMED codes identified - S WVPIEN=$$PAPIEN^WVRPCPR() - Q:'WVPIEN - S WVIEN=$O(^WV(790.08,"B",WVLABAN,0)) - Q:'WVIEN - S WVNODE=$G(^WV(790.08,WVIEN,0)) - Q:WVNODE="" - S WVLRDFN=$P(WVNODE,U,36) - Q:'WVLRDFN - S WVLRI=$P(WVNODE,U,37) - Q:'WVLRI - S WVLRSS=$P(WVNODE,U,38) - S WVDFN=$P(WVNODE,U,2) - S WVPROV=$P(WVNODE,U,7) - S WVLOC=$P(WVNODE,U,11) - S WVDATE=$P(WVNODE,U,12) - S WVLABAN=$P(WVNODE,U,1) - S WVDUZ2=$P(WVNODE,U,10) - I WVLRSS="CY" D Q - .S WVPAP=$$CY() - .D:WVPAP ADD - .Q - I WVLRSS="SP" D Q - .S WVPAP=$$SP() - .D:WVPAP ADD - .Q - Q - ; -CODES ; WVTOP array identifies SNOMED codes (IENS) used for pap smears - N WVPIEN,WVPIEN1,WVSNOMED - S WVTOP(0)=0 - S WVPIEN=$$PAPIEN^WVRPCPR() - I 'WVPIEN Q ;pap smear procedure not identified - S WVPIEN1=0 - F S WVPIEN1=$O(^WV(790.2,WVPIEN,2,WVPIEN1)) Q:'WVPIEN1 D - .S WVSNOMED=$P($G(^WV(790.2,WVPIEN,2,WVPIEN1,0)),U,1) - .Q:'WVSNOMED - .S WVTOP(0)=WVTOP(0)+1 - .S WVTOP(WVSNOMED)="" - .Q - Q -CY() ; Check SNOMED codes used by cytology entry - N WVFLAG,WVLOOP,WVSNOMED - S (WVFLAG,WVLOOP)=0 - ; check topography multiple - F S WVLOOP=$O(^LR(WVLRDFN,"CY",WVLRI,2,WVLOOP)) Q:'WVLOOP!(WVFLAG=1) D - .S WVSNOMED=+$P($G(^LR(WVLRDFN,"CY",WVLRI,2,WVLOOP,0)),U,1) - .Q:'WVSNOMED - .I $D(WVTOP(WVSNOMED)) S WVFLAG=1 - .Q - Q WVFLAG - ; -SP() ; Check SNOMED codes used by surgical pathology entry - N WVFLAG,WVLOOP,WVSNOMED - ; check topography multiple - S (WVFLAG,WVLOOP)=0 - F S WVLOOP=$O(^LR(WVLRDFN,"SP",WVLRI,2,WVLOOP)) Q:'WVLOOP!(WVFLAG=1) D - .S WVSNOMED=+$P($G(^LR(WVLRDFN,"SP",WVLRI,2,WVLOOP,0)),U,1) - .Q:'WVSNOMED - .I $D(WVTOP(WVSNOMED)) S WVFLAG=1 - .Q - Q WVFLAG - ; -ADD ; Add pap smear to FILE 790.1 - N WVDR,WVERR - S WVERR=0 - I '$D(^WV(790,WVDFN,0)) D ;add patient to File 790, if not there - .D AUTOADD^WVPATE(WVDFN,WVDUZ2,.WVERR) - .Q - Q:WVERR<0 ;quit if new patient could not be added to File 790 - S WVDR=".02////"_WVDFN - S WVDR=WVDR_";.04////"_WVPIEN ;File 790.2 pointer - S:WVPROV]"" WVDR=WVDR_";.07////"_WVPROV ;provider - S WVDR=WVDR_";.1////"_WVDUZ2 ;health care facility - S:WVLOC]"" WVDR=WVDR_";.11////"_WVLOC ;patient location - S WVDR=WVDR_";.12////"_WVDATE ;procedure date/time - S WVDR=WVDR_";.14////"_"o" ;status - S WVDR=WVDR_";.18////.5;.19////"_DT ;entering user and date - S WVDR=WVDR_";.34////"_WVDUZ2 ;accessioning facility - S WVDR=WVDR_";2.17////"_WVLABAN ;lab accession# - S WVDR=WVDR_";2.18////"_WVLRDFN ;Lab Data file (#63) pointer - S WVDR=WVDR_";2.19////"_WVLRI ;Lab Data file inverse d/t - S WVDR=WVDR_";2.2////"_WVLRSS ;Lab Data file subscript (CY/SP) - ; add procedure to File 790.1 - D NEW2^WVPROC(WVDFN,WVPIEN,WVDATE,WVDR,"","",.WVERR) - Q:'Y - I $$PATCH^XPDUTL("OR*3.0*210") D - .D CPRS^WVSNOMED(70,WVDFN,"",WVPROV,"Pap Smear results available.",WVLRSS_U_WVLABAN_U_WVLRI) - .D DELETE^WVLABADD(WVIEN) - .Q - Q +WVLABCHK ;HIOFO/FT-IS LAB TEST A PAP SMEAR? ;10/25/04 10:23 + ;;1.0;WOMEN'S HEALTH;**16**;Sep 30, 1998 + ; + ; This routine uses the following IAs: + ; #525 - ^LR references (controlled) + ; #4298 - ^LR references (private) + ; #10103 - ^XLFDT calls (supported) + ; #10063 - ^%ZTLOAD (supported) + ; #10141 - ^XPDUTL (supported) + ; + ; This routine supports the following IAs: + ; CREATE - 4525 + ; +CREATE(DFN,LRDFN,LRI,LRA,LRSS) ; + ; Add lab test to WH file (#790.08). + ; Called by REPORT RELEASE DATE/TIME field in: + ; a) File 63, Field 63.08,.11 + ; b) File 63, Field 63.09,.11 + ; Input: DFN = PATIENT DFN + ; LRDFN = FILE 63 IEN (+^DPT(DFN,"LR")) + ; LRI = INVERSE DATE/TIME OF TEST + ; LRA = ZERO NODE OF THE CY or SP ENTRY + ; LRSS = File 63 subscript (e.g., CY or SP) + ; + Q:($G(DFN)']"")!($G(LRDFN)']"")!($G(LRI)']"")!($G(LRA)']"")!($G(LRSS)']"") + Q:'$D(^WV(790.02,DUZ(2))) ;no site parameter entry + Q:'$P($G(^WV(790.02,+$G(DUZ(2)),0)),U,24) ;lab link is NO or null + N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE + S ZTRTN="CREATEQ^WVLABCHK",ZTDESC="WV CHECK SNOMED CODE CHANGES" + S ZTSAVE("DFN")="",ZTSAVE("LRDFN")="",ZTSAVE("LRI")="",ZTSAVE("LRA")="" + S ZTSAVE("LRSS")="",ZTIO="" + S ZTDTH=$$HADD^XLFDT($H,"","","",150) ;don't want the SNOMED trigger to + ; conflict with the report verification trigger + D ^%ZTLOAD + Q +CREATEQ ; Called from CREATE above + I $D(ZTQUEUED) S ZTREQ="@" + N WVDATE,WVDFN,WVDUZ2,WVIEN,WVLABAN,WVLOC,WVLRDFN,WVLRI,WVLRSS,WVNODE,WVPAP,WVPIEN,WVPROV,WVTOP,X,Y + Q:$P($G(^DPT(DFN,0)),U,2)'="F" ;not female + S WVLABAN=$P(LRA,U,6) ;lab accession# + Q:$D(^WV(790.1,"F",WVLABAN)) ;already tracked + ; check WH site parameters + Q:'$D(^WV(790.02,DUZ(2))) ;no site parameter entry + Q:'$P($G(^WV(790.02,+$G(DUZ(2)),0)),U,24) ;lab link is NO or null + Q:'$$VNVEC^WVLRLINK() ;vet/non-vet/eligibility code check + D CODES ;what SNOMED codes are we looking for? + I WVTOP(0)=0 Q ;no SNOMED codes identified + S WVPIEN=$$PAPIEN^WVRPCPR() + Q:'WVPIEN + S WVIEN=$O(^WV(790.08,"B",WVLABAN,0)) + Q:'WVIEN + S WVNODE=$G(^WV(790.08,WVIEN,0)) + Q:WVNODE="" + S WVLRDFN=$P(WVNODE,U,36) + Q:'WVLRDFN + S WVLRI=$P(WVNODE,U,37) + Q:'WVLRI + S WVLRSS=$P(WVNODE,U,38) + S WVDFN=$P(WVNODE,U,2) + S WVPROV=$P(WVNODE,U,7) + S WVLOC=$P(WVNODE,U,11) + S WVDATE=$P(WVNODE,U,12) + S WVLABAN=$P(WVNODE,U,1) + S WVDUZ2=$P(WVNODE,U,10) + I WVLRSS="CY" D Q + .S WVPAP=$$CY() + .D:WVPAP ADD + .Q + I WVLRSS="SP" D Q + .S WVPAP=$$SP() + .D:WVPAP ADD + .Q + Q + ; +CODES ; WVTOP array identifies SNOMED codes (IENS) used for pap smears + N WVPIEN,WVPIEN1,WVSNOMED + S WVTOP(0)=0 + S WVPIEN=$$PAPIEN^WVRPCPR() + I 'WVPIEN Q ;pap smear procedure not identified + S WVPIEN1=0 + F S WVPIEN1=$O(^WV(790.2,WVPIEN,2,WVPIEN1)) Q:'WVPIEN1 D + .S WVSNOMED=$P($G(^WV(790.2,WVPIEN,2,WVPIEN1,0)),U,1) + .Q:'WVSNOMED + .S WVTOP(0)=WVTOP(0)+1 + .S WVTOP(WVSNOMED)="" + .Q + Q +CY() ; Check SNOMED codes used by cytology entry + N WVFLAG,WVLOOP,WVSNOMED + S (WVFLAG,WVLOOP)=0 + ; check topography multiple + F S WVLOOP=$O(^LR(WVLRDFN,"CY",WVLRI,2,WVLOOP)) Q:'WVLOOP!(WVFLAG=1) D + .S WVSNOMED=+$P($G(^LR(WVLRDFN,"CY",WVLRI,2,WVLOOP,0)),U,1) + .Q:'WVSNOMED + .I $D(WVTOP(WVSNOMED)) S WVFLAG=1 + .Q + Q WVFLAG + ; +SP() ; Check SNOMED codes used by surgical pathology entry + N WVFLAG,WVLOOP,WVSNOMED + ; check topography multiple + S (WVFLAG,WVLOOP)=0 + F S WVLOOP=$O(^LR(WVLRDFN,"SP",WVLRI,2,WVLOOP)) Q:'WVLOOP!(WVFLAG=1) D + .S WVSNOMED=+$P($G(^LR(WVLRDFN,"SP",WVLRI,2,WVLOOP,0)),U,1) + .Q:'WVSNOMED + .I $D(WVTOP(WVSNOMED)) S WVFLAG=1 + .Q + Q WVFLAG + ; +ADD ; Add pap smear to FILE 790.1 + N WVDR,WVERR + S WVERR=0 + I '$D(^WV(790,WVDFN,0)) D ;add patient to File 790, if not there + .D AUTOADD^WVPATE(WVDFN,WVDUZ2,.WVERR) + .Q + Q:WVERR<0 ;quit if new patient could not be added to File 790 + S WVDR=".02////"_WVDFN + S WVDR=WVDR_";.04////"_WVPIEN ;File 790.2 pointer + S:WVPROV]"" WVDR=WVDR_";.07////"_WVPROV ;provider + S WVDR=WVDR_";.1////"_WVDUZ2 ;health care facility + S:WVLOC]"" WVDR=WVDR_";.11////"_WVLOC ;patient location + S WVDR=WVDR_";.12////"_WVDATE ;procedure date/time + S WVDR=WVDR_";.14////"_"o" ;status + S WVDR=WVDR_";.18////.5;.19////"_DT ;entering user and date + S WVDR=WVDR_";.34////"_WVDUZ2 ;accessioning facility + S WVDR=WVDR_";2.17////"_WVLABAN ;lab accession# + S WVDR=WVDR_";2.18////"_WVLRDFN ;Lab Data file (#63) pointer + S WVDR=WVDR_";2.19////"_WVLRI ;Lab Data file inverse d/t + S WVDR=WVDR_";2.2////"_WVLRSS ;Lab Data file subscript (CY/SP) + ; add procedure to File 790.1 + D NEW2^WVPROC(WVDFN,WVPIEN,WVDATE,WVDR,"","",.WVERR) + Q:'Y + I $$PATCH^XPDUTL("OR*3.0*210") D + .D CPRS^WVSNOMED(70,WVDFN,"",WVPROV,"Pap Smear results available.","") + .D DELETE^WVLABADD(WVIEN) + .Q + Q diff --git a/r/WOMENS_HEALTH-WV/WVRALINK.m b/r/WOMENS_HEALTH-WV/WVRALINK.m index 6b0cbb70..ab8943c5 100644 --- a/r/WOMENS_HEALTH-WV/WVRALINK.m +++ b/r/WOMENS_HEALTH-WV/WVRALINK.m @@ -1,216 +1,215 @@ -WVRALINK ;HCIOFO/FT-RAD/NM-WOMEN'S HEALTH LINK ;6/10/04 14:51 - ;;1.0;WOMEN'S HEALTH;**3,5,7,9,10,16,18,23**;Sep 30, 1998;Build 5 - ; - ; This routine uses the following IAs: - ; #2480 - FILE 70 (private) - ; #2481 - FILE 71 (private) - ; #2482 - FILE 71.2 (private) - ; #10035 - FILE 2 (supported) - ; #10063 - ^%ZTLOAD (supported) - ; #10070 - ^XMD (supported) - ; #10141 - ^XPDUTL (supported) - ; #2541 - ^XUPARAM (supported) - ; - ;; Original routine created by IHS/ANMC/MWR - ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER * - ;; CREATE MAMMOGRAM PROCEDURE IN WOMEN'S HEALTH FOR THIS PATIENT. - ;; CALLED BY ^RART WHEN A RADIOLOGY REPORT IS VERIFIED. - ;; CALLED BY ^RARTE1 WHEN A RADIOLOGY REPORT IS UNVERIFIED. - ;; CALLED BY ^WVEXPTRA WHEN EXPORTING HISTORICAL MAMS TO WOMEN'S HEALTH - ; - ;---> REQUIRED VARIABLES: DFN = DFN OF RADIOLOGY PATIENT. - ;---> DATE = INVERSE DATE/TIME OF VISIT. - ;---> CASE = IEN OF RADIOLOGY EXAM (CASE). - ; - ;---> OPTIONAL VARIABLE: WVNEWP = TOTAL NEW WH PATIENTS ADDED. - ;---> WVMCNT = TOTAL NEW MAMS PROCEDURES ADDED. - ;---> THESE IF CALLED FROM ^WVEXPTRA ROUTINE. - ; - ;---> GENERATED VARIBLES: - ;---> WVPROC = IEN OF RADIOLOGY PROCEDURE (FILE #71), THEN IT - ;---> GETS CHANGED TO WOMEN'S HEALTH PROCEDURE TYPE - ;---> (FILE #790.2). - ;---> WVLOC = WARD/CLINIC/LOCATION (FILE #44). - ;---> WVDATE = DATE OF THE PROCEDURE. - ;---> WVPROV = ORDERING PROVIDER. - ;---> WVMOD = LEFT OR RIGHT, IF IT'S A UNILATERAL MAMMOGRAM. - ;---> WVDX = RADIOLOGY DIAGNOSTIC CODE. - ;---> WVBWDX = WOMEN'S HEALTH RESULT/DIAGNOSIS. - ; -CREATE(DFN,DATE,CASE) ; - Q:'+$$VERSION^XPDUTL("WV") - Q:($G(DFN)']"")!($G(DATE)']"")!($G(CASE)']"") - N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE - S:'$D(DUZ)#2 DUZ=.5 - S:'$D(DUZ(2))#2 DUZ(2)=$$KSP^XUPARAM("INST") - S ZTRTN="CREATEQ^WVRALINK",ZTDESC="WV CREATE MAMMOGRAM ENTRY" - S ZTSAVE("DFN")="",ZTSAVE("DATE")="",ZTSAVE("CASE")="" - S ZTIO="",ZTDTH=$H - D ^%ZTLOAD - Q -CREATEH(DFN,DATE,CASE,STATUS) ; Entry from ^WVEXPTRA which looks for exams - ; created before the WH package was installed. - Q:($G(DFN)']"")!($G(DATE)']"")!($G(CASE)']"")!($G(STATUS)']"") - ; -CREATEQ ; Queue data entry creation. Called from CREATE above - N WVPROC,WVLOC,WVDATE,WVDR,WVPROV,WVMOD,WVDX,WVBWDX,WVLEFT,WVRIGHT - N WVCASE,WVCPT,WVERR,WVCREDIT,WVEXAM0,WVZSTAT - ;---> QUIT IF RADIOLOGY DATA IS NOT DEFINED OR ="". - I $D(ZTQUEUED) S ZTREQ="@" - Q:'$D(^RADPT(DFN,"DT",DATE,"P",CASE,0)) - ; - ;---> QUIT IF THIS PROCEDURE DOES NOT HAVE A MAM CPT CODE. - ;---> QUIT IF THIS PROCEDURE DOES NOT HAVE AN ULTRASOUND CPT CODE. - ;---> WVEXAM0=ZERO NODE OF RADIOLOGY EXAM. - S WVEXAM0=^RADPT(DFN,"DT",DATE,"P",CASE,0) - S WVCPT=$$GET1^DIQ(71,$P(WVEXAM0,U,2),9,"I") Q:WVCPT="" - S WVPROC=$O(^WV(790.2,"AC",WVCPT,0)) ;cpt code x-ref to get 790.2 ien - Q:'WVPROC ;cpt code is not tracked in 790.2 - Q:$P($G(^WV(790.2,+WVPROC,0)),U,5)'="R" ;cpt is not rad/nm procedure - Q:$P($G(^DPT(DFN,0)),U,2)'="F" ;not female - ; - ;---> QUIT IF NO WOMEN'S HEALTH SITE PARAMETER FILE ON THIS MACHINE. - ; OR NO DEFAULT CASE MANAGER - Q:'$D(^WV(790.02,DUZ(2))) - Q:'$P($G(^WV(790.02,+$G(DUZ(2)),0)),U,2) - ; - ;---> IF NOT CALLED FROM ^WVEXPTRA (i.e., STATUS is undefined) CHECK - ;---> SITE PARAMETER AND QUIT IF "IMPORT MAMMOGRAMS FROM RADIOLOGY" - ;---> IS NOT SET TO "YES". CHECK VETERAN STATUS AND ELIGIBILITY CODE. - N Y S Y=^WV(790.02,DUZ(2),0) - I '$D(STATUS) Q:'$P(Y,U,10) - I '$D(STATUS) Q:'$$VNVEC^WVRALIN1() ;vet/non-vet/eligibility code check - ; - ;---> SET WVZSTAT =THE STATUS (OPEN OR CLOSED) IN WOMEN'S HEALTH. - ;---> THAT MAMMOGRAMS SHOULD RECEIVE WHEN COPIED OVER FROM RADIOLOGY. - S WVZSTAT=$P(Y,U,23) S:WVZSTAT="" WVZSTAT="o" - I $G(STATUS)]"" S WVZSTAT=$G(STATUS) ;status selected in ^WVEXPTRA - ; - D COPY(WVEXAM0) - ; -EXIT ;EP - K I,N,X - Q - ; -COPY(Y) ;EP - ;---> COPY MAM PROCEDURE DATA FROM RADIOLOGY TO WOMEN'S HEALTH. - ;---> VARIABLE DFN=PATIENT - ;---> LOCATION=DUZ(2) - ;---> WARD/CLINIC/LOCATION - N X - S WVLOC=$P(Y,U,8) - ; - ;---> WVDATE=DATE OF THE PROCEDURE. - S WVDATE=$P($P(^RADPT(DFN,"DT",DATE,0),U),".") - ; - ;---> RECONSTRUCT THE FULL CASE# FOR THIS RAD PROCEDURE. - ;---> THIS IS USED AS A LINK (XREF) BETWEEN THE RADIOLOGY PROCEDURE - ;---> AND THE WOMEN'S HEALTH PROCEDURE. - S WVCASE=$E(WVDATE,4,7)_$E(WVDATE,2,3)_"-"_$P(Y,U) - ;---> CHECK TO BE SURE THE CASE# XREF IS REALLY DOWN THERE. - S:'$D(^RADPT("ADC",WVCASE,DFN,DATE,CASE)) WVCASE="UNKNOWN" - ; - ;---> QUIT IF THIS PROCEDURE HAS ALREADY BEEN SENT TO WOMEN'S HEALTH. - Q:$D(^WV(790.1,"E",WVCASE)) - ; - ;---> REQUESTING PROVIDER/ORDERING PROVIDER - S WVPROV=$P(Y,U,14) - ; - ;---> IF UNILATERAL, ATTEMPT TO PICK UP LEFT OR RIGHT MODIFIER. - I WVPROC=26 D - .I $D(^RADPT(DFN,"DT",DATE,"P",CASE,"M",0)) D - ..N N S N=0 - ..F S N=$O(^RADPT(DFN,"DT",DATE,"P",CASE,"M",N)) Q:'N D - ...S WVMOD=$P(^RADPT(DFN,"DT",DATE,"P",CASE,"M",N,0),U) - ...S WVMOD=$$GET1^DIQ(71.2,WVMOD,.01,"I") - ...I "LEFTleft"[WVMOD S WVLEFT=1 - ...I "RIGHTright"[WVMOD S WVRIGHT=1 - ..Q:$D(WVLEFT)&($D(WVRIGHT)) - ..I $D(WVLEFT) S WVMOD="l" Q - ..I $D(WVRIGHT) S WVMOD="r" Q - ; - ;---> IF THERE'S A DIAGNOSTIC CODE, ATTEMPT TO PICK UP DIAGNOSIS. - ;---> USE "WV DIAGNOSTIC CODE TRANSLATION" FILE #790.32. - S WVDX=$P(Y,U,13) - I +WVDX I $D(^WV(790.32,"C",WVDX)) S WVBWDX=$O(^WV(790.32,"C",WVDX,0)) - ; - ;---> GET CREDIT METHOD. - S WVCREDIT=$P(Y,U,26) - ; -PATIENT ;---> IF PATIENT ISN'T IN WOMEN'S HEALTH DATABASE, ADD HER. - S WVERR=1 - I '$D(^WV(790,DFN,0)) D - .D AUTOADD^WVPATE(DFN,DUZ(2),.WVERR) - .I $D(WVNEWP) S:WVERR WVNEWP=WVNEWP+1 - Q:WVERR<0 - D FIND^WVRALIN1 ;check for 'unlinked' entry in File 790.1 - Q:$D(^WV(790.1,"E",WVCASE)) ;quit if link was made in WVRALIN1 -PROC ;---> CREATE MAMMOGRAM PROCEDURE IN WV PROCEDURE FILE #790.1. - S WVDR=".02////"_DFN_";.04////"_WVPROC - S WVDR=WVDR_";.05////"_$G(WVBWDX)_";.07////"_WVPROV - S WVDR=WVDR_";.09////"_$G(WVMOD)_";.1////"_DUZ(2)_";.11////"_WVLOC - S WVDR=WVDR_";.12////"_WVDATE_";.14////"_WVZSTAT_";.15////"_WVCASE - S WVDR=WVDR_";.18////.5;.19////"_DT_";.34////"_$G(DUZ(2))_";.35////"_WVCREDIT - ; - D NEW2^WVPROC(DFN,WVPROC,WVDATE,WVDR,"","",.WVERR) - I $D(WVMCNT) S:WVERR>-1 WVMCNT=WVMCNT+1 - Q:WVERR<0 ;procedure not added - Q:$D(WVMCNT) ;mass import of Rad/NM exams - ;Q:$P($G(^WV(790.02,+DUZ(2),0)),U,23)="c" ;Status=closed - I (WVCPT=76856)!(WVCPT=76830)!(WVCPT=76645) D Q ;not breast related - .D MAIL^WVRADWP(DFN,+Y,WVPROC,WVPROV) ;iens for patient, accession, procedure, provider/requestor - .Q - D CPRS^WVSNOMED(69,DFN,"",WVPROV,"Mammogram results available.",DATE_"~"_CASE) - Q - ; -DELETE(DFN,DATE,CASE) ;EP - ;---> MODIFY WOMEN'S HEALTH PROCEDURE TO REFLECT CHANGE. - ;---> CALLED FROM RARTE1 (DELETE A REPORT AND UNVERIFY A REPORT). - ; - Q:'+$$VERSION^XPDUTL("WV") - Q:'$D(DFN)!('$D(DATE))!('$D(CASE)) - N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE - S ZTRTN="DELETEQ^WVRALINK",ZTDESC="WV MAMMOGRAM RPT CHANGE" - S ZTSAVE("DFN")="",ZTSAVE("DATE")="",ZTSAVE("CASE")="" - S ZTIO="",ZTDTH=$H - D ^%ZTLOAD - Q -DELETEQ ; Modify WV entry when mammogram report is unverified or deleted - Q:'$D(^RADPT(DFN,"DT",DATE,"P",CASE,0)) - N WVIEN,WVDATE,WVCASE,WVCMGR,WVLOOP,WVMSG,WVPROV - N XMDUZ,XMSUB,XMTEXT,XMY ;send mail message to case manager - I $D(ZTQUEUED) S ZTREQ="@" - ; - ;---> WVDATE=DATE OF PROCEDURE. - S WVDATE=$P($P(^RADPT(DFN,"DT",DATE,0),U),".") - S WVCASE=$P(^RADPT(DFN,"DT",DATE,"P",CASE,0),U) - ; - ;---> WVCASE=RECONSTRUCTED CASE# OF PROCEDURE. - S WVCASE=$E(WVDATE,4,7)_$E(WVDATE,2,3)_"-"_WVCASE - ;---> QUIT IF NO CASE# XREF IN WOMEN'S HEALTH PROCEDURE FILE. - Q:'$D(^WV(790.1,"E",WVCASE)) - ; - S WVIEN=$O(^WV(790.1,"E",WVCASE,0)) - Q:'$D(^WV(790.1,WVIEN,0)) - D RADMOD^WVPROC(WVIEN) ;update wh status to "open" - S WVPROV=+$$GET1^DIQ(790.1,WVIEN,.07,"I") ;get provider/requestor - S WVCMGR=+$$GET1^DIQ(790,DFN,.1,"I") ;get case manager - S:WVCMGR XMY(WVCMGR)="" - ; if no case manager, then get default case manager(s) - I 'WVCMGR S WVLOOP=0 F S WVLOOP=$O(^WV(790.02,WVLOOP)) Q:'WVLOOP D - .S WVCMGR=$$GET1^DIQ(790.02,WVLOOP,.02,"I") - .S:WVCMGR XMY(WVCMGR)="" - .Q - Q:$O(XMY(0))'>0 ;no case manager(s) - S:WVPROV XMY(WVPROV)="" - S XMDUZ=.5 ;message sender - S XMSUB="RAD/NM Rpt for WH patient is UNVERIFIED/DELETED" - S WVMSG(1)=" Patient: "_$P($G(^DPT(DFN,0)),U,1)_" (SSN: "_$$SSN^WVUTL1(DFN)_")" - S WVMSG(2)=" WH Accession #: "_$P($G(^WV(790.1,+WVIEN,0)),U,1) - S WVMSG(3)=" RAD/NM Case #: "_WVCASE - S WVMSG(4)=" " - S WVMSG(5)="NOTE: THIS PROCEDURE HAS BEEN ALTERED IN RADIOLOGY/NM." - S WVMSG(6)="Follow-up is required in the WOMEN'S HEALTH package!" - S XMTEXT="WVMSG(" - D ^XMD - Q +WVRALINK ;HCIOFO/FT-RAD/NM-WOMEN'S HEALTH LINK ;6/10/04 14:51 + ;;1.0;WOMEN'S HEALTH;**3,5,7,9,10,16,18**;Sep 30, 1998 + ; + ; This routine uses the following IAs: + ; #2480 - FILE 70 (private) + ; #2481 - FILE 71 (private) + ; #2482 - FILE 71.2 (private) + ; #10035 - FILE 2 (supported) + ; #10063 - ^%ZTLOAD (supported) + ; #10070 - ^XMD (supported) + ; #10141 - ^XPDUTL (supported) + ; + ;; Original routine created by IHS/ANMC/MWR + ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER * + ;; CREATE MAMMOGRAM PROCEDURE IN WOMEN'S HEALTH FOR THIS PATIENT. + ;; CALLED BY ^RART WHEN A RADIOLOGY REPORT IS VERIFIED. + ;; CALLED BY ^RARTE1 WHEN A RADIOLOGY REPORT IS UNVERIFIED. + ;; CALLED BY ^WVEXPTRA WHEN EXPORTING HISTORICAL MAMS TO WOMEN'S HEALTH + ; + ;---> REQUIRED VARIABLES: DFN = DFN OF RADIOLOGY PATIENT. + ;---> DATE = INVERSE DATE/TIME OF VISIT. + ;---> CASE = IEN OF RADIOLOGY EXAM (CASE). + ; + ;---> OPTIONAL VARIABLE: WVNEWP = TOTAL NEW WH PATIENTS ADDED. + ;---> WVMCNT = TOTAL NEW MAMS PROCEDURES ADDED. + ;---> THESE IF CALLED FROM ^WVEXPTRA ROUTINE. + ; + ;---> GENERATED VARIBLES: + ;---> WVPROC = IEN OF RADIOLOGY PROCEDURE (FILE #71), THEN IT + ;---> GETS CHANGED TO WOMEN'S HEALTH PROCEDURE TYPE + ;---> (FILE #790.2). + ;---> WVLOC = WARD/CLINIC/LOCATION (FILE #44). + ;---> WVDATE = DATE OF THE PROCEDURE. + ;---> WVPROV = ORDERING PROVIDER. + ;---> WVMOD = LEFT OR RIGHT, IF IT'S A UNILATERAL MAMMOGRAM. + ;---> WVDX = RADIOLOGY DIAGNOSTIC CODE. + ;---> WVBWDX = WOMEN'S HEALTH RESULT/DIAGNOSIS. + ; +CREATE(DFN,DATE,CASE) ; + Q:'+$$VERSION^XPDUTL("WV") + Q:($G(DFN)']"")!($G(DATE)']"")!($G(CASE)']"") + N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE + S:'$D(DUZ)#2 DUZ=.5 + S:'$D(DUZ(2))#2 DUZ(2)=$$KSP^XUPARAM("INST") + S ZTRTN="CREATEQ^WVRALINK",ZTDESC="WV CREATE MAMMOGRAM ENTRY" + S ZTSAVE("DFN")="",ZTSAVE("DATE")="",ZTSAVE("CASE")="" + S ZTIO="",ZTDTH=$H + D ^%ZTLOAD + Q +CREATEH(DFN,DATE,CASE,STATUS) ; Entry from ^WVEXPTRA which looks for exams + ; created before the WH package was installed. + Q:($G(DFN)']"")!($G(DATE)']"")!($G(CASE)']"")!($G(STATUS)']"") + ; +CREATEQ ; Queue data entry creation. Called from CREATE above + N WVPROC,WVLOC,WVDATE,WVDR,WVPROV,WVMOD,WVDX,WVBWDX,WVLEFT,WVRIGHT + N WVCASE,WVCPT,WVERR,WVCREDIT,WVEXAM0,WVZSTAT + ;---> QUIT IF RADIOLOGY DATA IS NOT DEFINED OR ="". + I $D(ZTQUEUED) S ZTREQ="@" + Q:'$D(^RADPT(DFN,"DT",DATE,"P",CASE,0)) + ; + ;---> QUIT IF THIS PROCEDURE DOES NOT HAVE A MAM CPT CODE. + ;---> QUIT IF THIS PROCEDURE DOES NOT HAVE AN ULTRASOUND CPT CODE. + ;---> WVEXAM0=ZERO NODE OF RADIOLOGY EXAM. + S WVEXAM0=^RADPT(DFN,"DT",DATE,"P",CASE,0) + S WVCPT=$$GET1^DIQ(71,$P(WVEXAM0,U,2),9,"I") Q:WVCPT="" + S WVPROC=$O(^WV(790.2,"AC",WVCPT,0)) ;cpt code x-ref to get 790.2 ien + Q:'WVPROC ;cpt code is not tracked in 790.2 + Q:$P($G(^WV(790.2,+WVPROC,0)),U,5)'="R" ;cpt is not rad/nm procedure + Q:$P($G(^DPT(DFN,0)),U,2)'="F" ;not female + ; + ;---> QUIT IF NO WOMEN'S HEALTH SITE PARAMETER FILE ON THIS MACHINE. + ; OR NO DEFAULT CASE MANAGER + Q:'$D(^WV(790.02,DUZ(2))) + Q:'$P($G(^WV(790.02,+$G(DUZ(2)),0)),U,2) + ; + ;---> IF NOT CALLED FROM ^WVEXPTRA (i.e., STATUS is undefined) CHECK + ;---> SITE PARAMETER AND QUIT IF "IMPORT MAMMOGRAMS FROM RADIOLOGY" + ;---> IS NOT SET TO "YES". CHECK VETERAN STATUS AND ELIGIBILITY CODE. + N Y S Y=^WV(790.02,DUZ(2),0) + I '$D(STATUS) Q:'$P(Y,U,10) + I '$D(STATUS) Q:'$$VNVEC^WVRALIN1() ;vet/non-vet/eligibility code check + ; + ;---> SET WVZSTAT =THE STATUS (OPEN OR CLOSED) IN WOMEN'S HEALTH. + ;---> THAT MAMMOGRAMS SHOULD RECEIVE WHEN COPIED OVER FROM RADIOLOGY. + S WVZSTAT=$P(Y,U,23) S:WVZSTAT="" WVZSTAT="o" + I $G(STATUS)]"" S WVZSTAT=$G(STATUS) ;status selected in ^WVEXPTRA + ; + D COPY(WVEXAM0) + ; +EXIT ;EP + K I,N,X + Q + ; +COPY(Y) ;EP + ;---> COPY MAM PROCEDURE DATA FROM RADIOLOGY TO WOMEN'S HEALTH. + ;---> VARIABLE DFN=PATIENT + ;---> LOCATION=DUZ(2) + ;---> WARD/CLINIC/LOCATION + N X + S WVLOC=$P(Y,U,8) + ; + ;---> WVDATE=DATE OF THE PROCEDURE. + S WVDATE=$P($P(^RADPT(DFN,"DT",DATE,0),U),".") + ; + ;---> RECONSTRUCT THE FULL CASE# FOR THIS RAD PROCEDURE. + ;---> THIS IS USED AS A LINK (XREF) BETWEEN THE RADIOLOGY PROCEDURE + ;---> AND THE WOMEN'S HEALTH PROCEDURE. + S WVCASE=$E(WVDATE,4,7)_$E(WVDATE,2,3)_"-"_$P(Y,U) + ;---> CHECK TO BE SURE THE CASE# XREF IS REALLY DOWN THERE. + S:'$D(^RADPT("ADC",WVCASE,DFN,DATE,CASE)) WVCASE="UNKNOWN" + ; + ;---> QUIT IF THIS PROCEDURE HAS ALREADY BEEN SENT TO WOMEN'S HEALTH. + Q:$D(^WV(790.1,"E",WVCASE)) + ; + ;---> REQUESTING PROVIDER/ORDERING PROVIDER + S WVPROV=$P(Y,U,14) + ; + ;---> IF UNILATERAL, ATTEMPT TO PICK UP LEFT OR RIGHT MODIFIER. + I WVPROC=26 D + .I $D(^RADPT(DFN,"DT",DATE,"P",CASE,"M",0)) D + ..N N S N=0 + ..F S N=$O(^RADPT(DFN,"DT",DATE,"P",CASE,"M",N)) Q:'N D + ...S WVMOD=$P(^RADPT(DFN,"DT",DATE,"P",CASE,"M",N,0),U) + ...S WVMOD=$$GET1^DIQ(71.2,WVMOD,.01,"I") + ...I "LEFTleft"[WVMOD S WVLEFT=1 + ...I "RIGHTright"[WVMOD S WVRIGHT=1 + ..Q:$D(WVLEFT)&($D(WVRIGHT)) + ..I $D(WVLEFT) S WVMOD="l" Q + ..I $D(WVRIGHT) S WVMOD="r" Q + ; + ;---> IF THERE'S A DIAGNOSTIC CODE, ATTEMPT TO PICK UP DIAGNOSIS. + ;---> USE "WV DIAGNOSTIC CODE TRANSLATION" FILE #790.32. + S WVDX=$P(Y,U,13) + I +WVDX I $D(^WV(790.32,"C",WVDX)) S WVBWDX=$O(^WV(790.32,"C",WVDX,0)) + ; + ;---> GET CREDIT METHOD. + S WVCREDIT=$P(Y,U,26) + ; +PATIENT ;---> IF PATIENT ISN'T IN WOMEN'S HEALTH DATABASE, ADD HER. + S WVERR=1 + I '$D(^WV(790,DFN,0)) D + .D AUTOADD^WVPATE(DFN,DUZ(2),.WVERR) + .I $D(WVNEWP) S:WVERR WVNEWP=WVNEWP+1 + Q:WVERR<0 + D FIND^WVRALIN1 ;check for 'unlinked' entry in File 790.1 + Q:$D(^WV(790.1,"E",WVCASE)) ;quit if link was made in WVRALIN1 +PROC ;---> CREATE MAMMOGRAM PROCEDURE IN WV PROCEDURE FILE #790.1. + S WVDR=".02////"_DFN_";.04////"_WVPROC + S WVDR=WVDR_";.05////"_$G(WVBWDX)_";.07////"_WVPROV + S WVDR=WVDR_";.09////"_$G(WVMOD)_";.1////"_DUZ(2)_";.11////"_WVLOC + S WVDR=WVDR_";.12////"_WVDATE_";.14////"_WVZSTAT_";.15////"_WVCASE + S WVDR=WVDR_";.18////.5;.19////"_DT_";.34////"_$G(DUZ(2))_";.35////"_WVCREDIT + ; + D NEW2^WVPROC(DFN,WVPROC,WVDATE,WVDR,"","",.WVERR) + I $D(WVMCNT) S:WVERR>-1 WVMCNT=WVMCNT+1 + Q:WVERR<0 ;procedure not added + Q:$D(WVMCNT) ;mass import of Rad/NM exams + ;Q:$P($G(^WV(790.02,+DUZ(2),0)),U,23)="c" ;Status=closed + I (WVCPT=76856)!(WVCPT=76830)!(WVCPT=76645) D Q ;not breast related + .D MAIL^WVRADWP(DFN,+Y,WVPROC,WVPROV) ;iens for patient, accession, procedure, provider/requestor + .Q + D CPRS^WVSNOMED(69,DFN,"",WVPROV,"Mammogram results available.","") + Q + ; +DELETE(DFN,DATE,CASE) ;EP + ;---> MODIFY WOMEN'S HEALTH PROCEDURE TO REFLECT CHANGE. + ;---> CALLED FROM RARTE1 (DELETE A REPORT AND UNVERIFY A REPORT). + ; + Q:'+$$VERSION^XPDUTL("WV") + Q:'$D(DFN)!('$D(DATE))!('$D(CASE)) + N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE + S ZTRTN="DELETEQ^WVRALINK",ZTDESC="WV MAMMOGRAM RPT CHANGE" + S ZTSAVE("DFN")="",ZTSAVE("DATE")="",ZTSAVE("CASE")="" + S ZTIO="",ZTDTH=$H + D ^%ZTLOAD + Q +DELETEQ ; Modify WV entry when mammogram report is unverified or deleted + Q:'$D(^RADPT(DFN,"DT",DATE,"P",CASE,0)) + N WVIEN,WVDATE,WVCASE,WVCMGR,WVLOOP,WVMSG,WVPROV + N XMDUZ,XMSUB,XMTEXT,XMY ;send mail message to case manager + I $D(ZTQUEUED) S ZTREQ="@" + ; + ;---> WVDATE=DATE OF PROCEDURE. + S WVDATE=$P($P(^RADPT(DFN,"DT",DATE,0),U),".") + S WVCASE=$P(^RADPT(DFN,"DT",DATE,"P",CASE,0),U) + ; + ;---> WVCASE=RECONSTRUCTED CASE# OF PROCEDURE. + S WVCASE=$E(WVDATE,4,7)_$E(WVDATE,2,3)_"-"_WVCASE + ;---> QUIT IF NO CASE# XREF IN WOMEN'S HEALTH PROCEDURE FILE. + Q:'$D(^WV(790.1,"E",WVCASE)) + ; + S WVIEN=$O(^WV(790.1,"E",WVCASE,0)) + Q:'$D(^WV(790.1,WVIEN,0)) + D RADMOD^WVPROC(WVIEN) ;update wh status to "open" + S WVPROV=+$$GET1^DIQ(790.1,WVIEN,.07,"I") ;get provider/requestor + S WVCMGR=+$$GET1^DIQ(790,DFN,.1,"I") ;get case manager + S:WVCMGR XMY(WVCMGR)="" + ; if no case manager, then get default case manager(s) + I 'WVCMGR S WVLOOP=0 F S WVLOOP=$O(^WV(790.02,WVLOOP)) Q:'WVLOOP D + .S WVCMGR=$$GET1^DIQ(790.02,WVLOOP,.02,"I") + .S:WVCMGR XMY(WVCMGR)="" + .Q + Q:$O(XMY(0))'>0 ;no case manager(s) + S:WVPROV XMY(WVPROV)="" + S XMDUZ=.5 ;message sender + S XMSUB="RAD/NM Rpt for WH patient is UNVERIFIED/DELETED" + S WVMSG(1)=" Patient: "_$P($G(^DPT(DFN,0)),U,1)_" (SSN: "_$$SSN^WVUTL1(DFN)_")" + S WVMSG(2)=" WH Accession #: "_$P($G(^WV(790.1,+WVIEN,0)),U,1) + S WVMSG(3)=" RAD/NM Case #: "_WVCASE + S WVMSG(4)=" " + S WVMSG(5)="NOTE: THIS PROCEDURE HAS BEEN ALTERED IN RADIOLOGY/NM." + S WVMSG(6)="Follow-up is required in the WOMEN'S HEALTH package!" + S XMTEXT="WVMSG(" + D ^XMD + Q diff --git a/r/WOMENS_HEALTH-WV/WVSNOMED.m b/r/WOMENS_HEALTH-WV/WVSNOMED.m index 1400e87f..0fb1b2ed 100644 --- a/r/WOMENS_HEALTH-WV/WVSNOMED.m +++ b/r/WOMENS_HEALTH-WV/WVSNOMED.m @@ -1,137 +1,137 @@ -WVSNOMED ;HIOFO/FT-IS LAB TEST A PAP SMEAR? ;2/12/04 14:37 - ;;1.0;WOMEN'S HEALTH;**16,23**;Sep 30, 1998;Build 5 - ; - ; This routine uses the following IAs: - ; #1362 - ^ORB3 (controlled) - ; #525 - ^LR references (controlled) - ; #4298 - ^LR references (private) - ; #10035 - ^DPT( references (supported) - ; #10070 - ^XMD (supported) - ; #10141 - ^XPDUTL (supported) - ; -SNOMED() ; Check lab test for SNOMED codes that indicate if pap smear. - ; LRDFN,LRI,LRSS must be defined. - ; Returns: 0 - lab test is not a pap smear - ; 1 - lab test is a pap smear - ; - N WVPAP,WVPIEN,WVPIEN1,WVSNOMED,WVTOP - ; WVTOP array identifies SNOMED codes (IENS) used for pap smears - S WVTOP(0)=0 - S WVPIEN=$$PAPIEN^WVRPCPR() - I 'WVPIEN Q 0 ;pap smear procedure entry not found - S WVPIEN1=0 - F S WVPIEN1=$O(^WV(790.2,WVPIEN,2,WVPIEN1)) Q:'WVPIEN1 D - .S WVSNOMED=$P($G(^WV(790.2,WVPIEN,2,WVPIEN1,0)),U,1) - .Q:'WVSNOMED - .S WVTOP(0)=WVTOP(0)+1 - .S WVTOP(WVSNOMED)="" - .Q - I WVTOP(0)=0 Q 0 ;no SNOMED codes identified - K WVTOP(0) - S WVPAP=0 - I LRSS="CY" S WVPAP=$$CY() - I LRSS="SP" S WVPAP=$$SP() - Q WVPAP - ; -CY() ; Check SNOMED codes used by cytology entry - N WVFLAG,WVLOOP,WVLOOP1,WVSNOMED - S (WVFLAG,WVLOOP)=0 - ; check topography multiple - F S WVLOOP=$O(^LR(LRDFN,"CY",LRI,2,WVLOOP)) Q:'WVLOOP!(WVFLAG=1) D - .S WVSNOMED=+$P($G(^LR(LRDFN,"CY",LRI,2,WVLOOP,0)),U,1) - .Q:'WVSNOMED - .I $D(WVTOP(WVSNOMED)) S WVFLAG=1 - .Q - Q WVFLAG - ; -SP() ; Check SNOMED codes used by surgical pathology entry - N WVFLAG,WVLOOP,WVLOOP1,WVSNOMED - ; check topography multiple - S (WVFLAG,WVLOOP)=0 - F S WVLOOP=$O(^LR(LRDFN,"SP",LRI,2,WVLOOP)) Q:'WVLOOP!(WVFLAG=1) D - .S WVSNOMED=+$P($G(^LR(LRDFN,"SP",LRI,2,WVLOOP,0)),U,1) - .Q:'WVSNOMED - .I $D(WVTOP(WVSNOMED)) S WVFLAG=1 - .Q - Q WVFLAG - ; -ADD ; Add pap smear to FILE 790.1 - N WV7901,WVDR,WVPIEN,WVERR - S WVERR=0 - I '$D(^WV(790,DFN,0)) D ;add patient to File 790, if not there - .D AUTOADD^WVPATE(DFN,DUZ(2),.WVERR) - .Q - Q:WVERR<0 ;quit if new patient could not be added to File 790 - S WVPIEN=$$PAPIEN^WVRPCPR() - S WVDR=".02////"_DFN - S WVDR=WVDR_";.04////"_WVPIEN ;File 790.2 pointer - S:WVPROV]"" WVDR=WVDR_";.07////"_WVPROV ;provider - S WVDR=WVDR_";.1////"_$G(DUZ(2)) ;health care facility - S:WVLOC]"" WVDR=WVDR_";.11////"_WVLOC ;patient location - S WVDR=WVDR_";.12////"_WVDATE ;procedure date/time - S WVDR=WVDR_";.14////"_"o" ;status - S WVDR=WVDR_";.18////.5;.19////"_DT ;entering user and date - S WVDR=WVDR_";.34////"_$G(DUZ(2)) ;accessioning facility - S WVDR=WVDR_";2.17////"_WVLABAN ;lab accession# - S WVDR=WVDR_";2.18////"_LRDFN ;Lab Data file (#63) pointer - S WVDR=WVDR_";2.19////"_LRI ;Lab Data file inverse d/t - S WVDR=WVDR_";2.2////"_LRSS ;Lab Data file subscript (CY/SP) - ; add procedure to File 790.1 - D NEW2^WVPROC(DFN,WVPIEN,WVDATE,WVDR,"","",.WVERR) - Q:'Y - S WV7901=+Y - I $$PATCH^XPDUTL("OR*3.0*210") D Q - .D CPRS^WVSNOMED(70,DFN,"",WVPROV,"Pap Smear results available.",LRSS_U_WVLABAN_U_LRI) - .Q - D MAIL(DFN,WVLABAN,WVPROV,LRSS,WV7901) - Q -MAIL(DFN,WVLABAN,WVPROV,LRSS,WV7901) ; Send mail message to case manager - ; when pap smear added to FILE 790.1 - ; Called from above - ; DFN -> Patient ien - ; WVLABAN -> Lab Accession# (e.g., CY 99 1) - ; WVPROV -> File 200 IEN (provider/requestor) - ; LRSS -> File 63 subscript (e.g., CY or SP) - ; WV7901 -> FILE 790.1 IEN - Q:'$G(DFN)!($G(WVLABAN)="")!($G(LRSS)="") - N WVCMGR,WVLOOP,WVMSG,XMDUZ,XMSUB,XMTEXT,XMY - S WVCMGR=+$$GET1^DIQ(790,DFN,.1,"I") ;get case manager - S:WVCMGR XMY(WVCMGR)="" - ; if no case manager, then get default case manager(s) - I 'WVCMGR S WVLOOP=0 F S WVLOOP=$O(^WV(790.02,WVLOOP)) Q:'WVLOOP D - .S WVCMGR=$$GET1^DIQ(790.02,WVLOOP,.02,"I") - .S:WVCMGR XMY(WVCMGR)="" - .Q - Q:$O(XMY(0))'>0 ;no case manager(s) - S XMDUZ=.5 ;message sender - S XMSUB="Pap Smear report verified for a WH patient" - S WVMSG(1)="A "_$S(LRSS="CY":"Cytology ",LRSS="SP":"Surgical Pathology ",1:"")_"lab test was verified for:" - S WVMSG(2)=" " - S WVMSG(3)=" Patient: "_$P($G(^DPT(DFN,0)),U,1)_" (SSN: "_$$SSN^WVUTL1(DFN)_")" - S WVMSG(4)=" WH Accession #: "_$P($G(^WV(790.1,+WV7901,0)),U,1) - S WVMSG(5)=" LAB Accession #: "_WVLABAN - S WVMSG(6)="Test Requestor/Provider: "_$S(+WVPROV:$$GET1^DIQ(200,+WVPROV,.01,"E"),1:"UNKNOWN") - S WVMSG(7)=" " - S WVMSG(8)="Please use CPRS to resolve the Clinical Reminder for this procedure and" - S WVMSG(9)="complete the result." - S XMTEXT="WVMSG(" - D ^XMD - Q - ; -CPRS(WVORN,WVDFN,WVORDER,WVPROV,WVMSG,WVIEN) ; Generate a CPRS alert - ; WVORN - FILE 100.9 IEN - ; WVDFN - FILE 2 IEN - ; WVORDER - FILE 100 IEN (not currently used) - ; WVPROV - FILE 200 IEN - ; WVMSG - Free text message - ; WVIEN - IEN for a lab or radiology report (not currently used) - ; - Q:'$$PATCH^XPDUTL("OR*3.0*210") ;no pap & mam alerts - Q:'WVDFN - Q:'WVORN - I WVPROV]"" S WVARRAY(WVPROV)="" ;provider's IEN - S WVCMGR=$P($G(^WV(790,WVDFN,0)),U,10) - I WVCMGR]"" S WVARRAY(WVCMGR)="" ;women's health case manager's IEN - D EN^ORB3(WVORN,WVDFN,WVORDER,.WVARRAY,WVMSG,WVIEN) - K WVARRAY,WVCMGR - Q +WVSNOMED ;HIOFO/FT-IS LAB TEST A PAP SMEAR? ;2/12/04 14:37 + ;;1.0;WOMEN'S HEALTH;**16**;Sep 30, 1998 + ; + ; This routine uses the following IAs: + ; #1362 - ^ORB3 (controlled) + ; #525 - ^LR references (controlled) + ; #4298 - ^LR references (private) + ; #10035 - ^DPT( references (supported) + ; #10070 - ^XMD (supported) + ; #10141 - ^XPDUTL (supported) + ; +SNOMED() ; Check lab test for SNOMED codes that indicate if pap smear. + ; LRDFN,LRI,LRSS must be defined. + ; Returns: 0 - lab test is not a pap smear + ; 1 - lab test is a pap smear + ; + N WVPAP,WVPIEN,WVPIEN1,WVSNOMED,WVTOP + ; WVTOP array identifies SNOMED codes (IENS) used for pap smears + S WVTOP(0)=0 + S WVPIEN=$$PAPIEN^WVRPCPR() + I 'WVPIEN Q 0 ;pap smear procedure entry not found + S WVPIEN1=0 + F S WVPIEN1=$O(^WV(790.2,WVPIEN,2,WVPIEN1)) Q:'WVPIEN1 D + .S WVSNOMED=$P($G(^WV(790.2,WVPIEN,2,WVPIEN1,0)),U,1) + .Q:'WVSNOMED + .S WVTOP(0)=WVTOP(0)+1 + .S WVTOP(WVSNOMED)="" + .Q + I WVTOP(0)=0 Q 0 ;no SNOMED codes identified + K WVTOP(0) + S WVPAP=0 + I LRSS="CY" S WVPAP=$$CY() + I LRSS="SP" S WVPAP=$$SP() + Q WVPAP + ; +CY() ; Check SNOMED codes used by cytology entry + N WVFLAG,WVLOOP,WVLOOP1,WVSNOMED + S (WVFLAG,WVLOOP)=0 + ; check topography multiple + F S WVLOOP=$O(^LR(LRDFN,"CY",LRI,2,WVLOOP)) Q:'WVLOOP!(WVFLAG=1) D + .S WVSNOMED=+$P($G(^LR(LRDFN,"CY",LRI,2,WVLOOP,0)),U,1) + .Q:'WVSNOMED + .I $D(WVTOP(WVSNOMED)) S WVFLAG=1 + .Q + Q WVFLAG + ; +SP() ; Check SNOMED codes used by surgical pathology entry + N WVFLAG,WVLOOP,WVLOOP1,WVSNOMED + ; check topography multiple + S (WVFLAG,WVLOOP)=0 + F S WVLOOP=$O(^LR(LRDFN,"SP",LRI,2,WVLOOP)) Q:'WVLOOP!(WVFLAG=1) D + .S WVSNOMED=+$P($G(^LR(LRDFN,"SP",LRI,2,WVLOOP,0)),U,1) + .Q:'WVSNOMED + .I $D(WVTOP(WVSNOMED)) S WVFLAG=1 + .Q + Q WVFLAG + ; +ADD ; Add pap smear to FILE 790.1 + N WV7901,WVDR,WVPIEN,WVERR + S WVERR=0 + I '$D(^WV(790,DFN,0)) D ;add patient to File 790, if not there + .D AUTOADD^WVPATE(DFN,DUZ(2),.WVERR) + .Q + Q:WVERR<0 ;quit if new patient could not be added to File 790 + S WVPIEN=$$PAPIEN^WVRPCPR() + S WVDR=".02////"_DFN + S WVDR=WVDR_";.04////"_WVPIEN ;File 790.2 pointer + S:WVPROV]"" WVDR=WVDR_";.07////"_WVPROV ;provider + S WVDR=WVDR_";.1////"_$G(DUZ(2)) ;health care facility + S:WVLOC]"" WVDR=WVDR_";.11////"_WVLOC ;patient location + S WVDR=WVDR_";.12////"_WVDATE ;procedure date/time + S WVDR=WVDR_";.14////"_"o" ;status + S WVDR=WVDR_";.18////.5;.19////"_DT ;entering user and date + S WVDR=WVDR_";.34////"_$G(DUZ(2)) ;accessioning facility + S WVDR=WVDR_";2.17////"_WVLABAN ;lab accession# + S WVDR=WVDR_";2.18////"_LRDFN ;Lab Data file (#63) pointer + S WVDR=WVDR_";2.19////"_LRI ;Lab Data file inverse d/t + S WVDR=WVDR_";2.2////"_LRSS ;Lab Data file subscript (CY/SP) + ; add procedure to File 790.1 + D NEW2^WVPROC(DFN,WVPIEN,WVDATE,WVDR,"","",.WVERR) + Q:'Y + S WV7901=+Y + I $$PATCH^XPDUTL("OR*3.0*210") D Q + .D CPRS^WVSNOMED(70,DFN,"",WVPROV,"Pap Smear results available.","") + .Q + D MAIL(DFN,WVLABAN,WVPROV,LRSS,WV7901) + Q +MAIL(DFN,WVLABAN,WVPROV,LRSS,WV7901) ; Send mail message to case manager + ; when pap smear added to FILE 790.1 + ; Called from above + ; DFN -> Patient ien + ; WVLABAN -> Lab Accession# (e.g., CY 99 1) + ; WVPROV -> File 200 IEN (provider/requestor) + ; LRSS -> File 63 subscript (e.g., CY or SP) + ; WV7901 -> FILE 790.1 IEN + Q:'$G(DFN)!($G(WVLABAN)="")!($G(LRSS)="") + N WVCMGR,WVLOOP,WVMSG,XMDUZ,XMSUB,XMTEXT,XMY + S WVCMGR=+$$GET1^DIQ(790,DFN,.1,"I") ;get case manager + S:WVCMGR XMY(WVCMGR)="" + ; if no case manager, then get default case manager(s) + I 'WVCMGR S WVLOOP=0 F S WVLOOP=$O(^WV(790.02,WVLOOP)) Q:'WVLOOP D + .S WVCMGR=$$GET1^DIQ(790.02,WVLOOP,.02,"I") + .S:WVCMGR XMY(WVCMGR)="" + .Q + Q:$O(XMY(0))'>0 ;no case manager(s) + S XMDUZ=.5 ;message sender + S XMSUB="Pap Smear report verified for a WH patient" + S WVMSG(1)="A "_$S(LRSS="CY":"Cytology ",LRSS="SP":"Surgical Pathology ",1:"")_"lab test was verified for:" + S WVMSG(2)=" " + S WVMSG(3)=" Patient: "_$P($G(^DPT(DFN,0)),U,1)_" (SSN: "_$$SSN^WVUTL1(DFN)_")" + S WVMSG(4)=" WH Accession #: "_$P($G(^WV(790.1,+WV7901,0)),U,1) + S WVMSG(5)=" LAB Accession #: "_WVLABAN + S WVMSG(6)="Test Requestor/Provider: "_$S(+WVPROV:$$GET1^DIQ(200,+WVPROV,.01,"E"),1:"UNKNOWN") + S WVMSG(7)=" " + S WVMSG(8)="Please use CPRS to resolve the Clinical Reminder for this procedure and" + S WVMSG(9)="complete the result." + S XMTEXT="WVMSG(" + D ^XMD + Q + ; +CPRS(WVORN,WVDFN,WVORDER,WVPROV,WVMSG,WVIEN) ; Generate a CPRS alert + ; WVORN - FILE 100.9 IEN + ; WVDFN - FILE 2 IEN + ; WVORDER - FILE 100 IEN (not currently used) + ; WVPROV - FILE 200 IEN + ; WVMSG - Free text message + ; WVIEN - IEN for a lab or radiology report (not currently used) + ; + Q:'$$PATCH^XPDUTL("OR*3.0*210") ;no pap & mam alerts + Q:'WVDFN + Q:'WVORN + I WVPROV]"" S WVARRAY(WVPROV)="" ;provider's IEN + S WVCMGR=$P($G(^WV(790,WVDFN,0)),U,10) + I WVCMGR]"" S WVARRAY(WVCMGR)="" ;women's health case manager's IEN + D EN^ORB3(WVORN,WVDFN,WVORDER,.WVARRAY,WVMSG,WVIEN) + K WVARRAY,WVCMGR + Q diff --git a/r/WORLDVISTA-VW/VWUTIL.m b/r/WORLDVISTA-VW/VWUTIL.m index c2c57517..3805816f 100644 --- a/r/WORLDVISTA-VW/VWUTIL.m +++ b/r/WORLDVISTA-VW/VWUTIL.m @@ -1,97 +1,42 @@ -VWUTIL ;WVEHR/Maury Pepper/Skip Ormsby- World VistA Utilities;12:52 PM 11 Nov 2008 - ;;1.0;WORLD VISTA;250001,250002;;Build 4 - ; - ;Modified from FOIA VISTA, - ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;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 Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - Q - ;*WVEHR - 250001* -Q(V,D) ; Function to return $QUERY for variable V and direction D. - ; Replacement for Reverse $Q Function - ; 1/8/08 MLP - ;This function can be called for $Query -- either forward or reverse. - ;In place of $Q(V,D), use $$Q^ZDQ($NA(V),D) - ;Note: the 2nd argument is optional. - ; - S D=+$G(D,1) - Q:D=1 $Q(@V) ;Forward $Q - IF D'=-1 Q ;Will cause error due to no argument. - N S -TOP IF $QL(V)=0 Q "" ;done if unsubscripted -BKU S S=$O(@V,-1) ;backup to previous node on current level - S V=$NA(@V,$QL(V)-1) ;remove last subscript - IF S="" G DAT ;go chk for data if backed up all the way - S V=$NA(@V@(S)) ;add the subscript found when backing up. - IF $D(@V)>9 S V=$NA(@V@("")) G BKU ;if downpointer, descend and repeat -DAT IF $D(@V)#2=1 Q V ;if a data node, return with current name - G TOP - ; - ;*WVEHR 250002* -DD2 ;Weston/SO Make certain Required Fields in Patient File NOT required - ;06/30/2008 - ;Fields: - ;SOCIAL SECURITY NUMBER(#.09) - ;SERVICE CONNECTED?(#.301) - ;TYPE(#391) - ;VETERAN (Y/N)?(#1901) - ; - D DT^DICRW ;Make sure FM variables are set up - F I="SOCIAL SECURITY NUMBER","SERVICE CONNECTED?","TYPE","VETERAN (Y/N)?" D - .N FIELD S FIELD=+$O(^DD(2,"B",I,0)) Q:'FIELD ;Get field number - .N X S X=$P(^DD(2,FIELD,0),U,2) ;Get field properties - .S X=$TR(X,"R","") ;Remove the 'R'equired flag - .S $P(^DD(2,FIELD,0),U,2)=X ;Re-Set field properties - .K ^DD(2,"RQ",FIELD) ;Kill off the ReQuired Xref - .S ^DD(2,FIELD,"DT")=DT ;Set the date Last Edited - .; - .;Re-Compile any Input Templates - .D - ..N IEN S IEN=0 - ..F S IEN=$O(^DIE("AF",2,FIELD,IEN)) Q:'IEN D - ...N X,Y,DMAX - ...I '$D(^DIE(IEN,"ROU")) Q ;Not compiled - ...S X=^DIE(IEN,"ROU") - ...I X="" Q ;No routine specified - ...S X=$P(X,U,2),Y=IEN,DMAX=$$ROUSIZE^DILF - ...D EN^DIEZ - ...Q - ..Q - .; - .;Re-Compile any Print Templates - .D - ..N IEN S IEN=0 - ..F S IEN=$O(^DIPT("AF",2,FIELD,IEN)) Q:'IEN D - ...N X,Y,DMAX - ...I '$D(^DIPT(IEN,"ROU")) Q ;Not compiled - ...S X=^DIPT(IEN,"ROU") - ...I X="" Q ;No routine specified - ...S X=$P(X,U,2),Y=IEN,DMAX=$$ROUSIZE^DILF - ...D EN^DIPZ - ..Q - .Q - Q -AMA1 ;Display the AMA Copyright for 1 second - N X W !,"CPT copyright AMA 2009 American Medical Association. All rights reserved." - R X#1:1 - Q -AMA10 ;Display the AMA Copyright for 10 seconds - N X W !,"CPT copyright AMA 2009 American Medical Association. All rights reserved." - W !," Press any key to continue." - R X#1:10 - Q - ; +VWUTIL ;WVEHR/Maury Pepper/Skip Ormsby- World VistA Utilities;7:32 PM 30 Jan 2008 + ;;WVEHR-1007;WORLD VISTA;*WVEHR1*;;WorldVistA 30-Jan-08 + ; + ;Modified from FOIA VISTA, + ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;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 Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + Q + ; +Q(V,D) ; Function to return $QUERY for variable V and direction D. + ; Replacement for Reverse $Q Function + ; 1/8/08 MLP + ;This function can be called for $Query -- either forward or reverse. + ;In place of $Q(V,D), use $$Q^ZDQ($NA(V),D) + ;Note: the 2nd argument is optional. + ; + S D=+$G(D,1) + Q:D=1 $Q(@V) ;Forward $Q + IF D'=-1 Q ;Will cause error due to no argument. + N S +TOP IF $QL(V)=0 Q "" ;done if unsubscripted +BKU S S=$O(@V,-1) ;backup to previous node on current level + S V=$NA(@V,$QL(V)-1) ;remove last subscript + IF S="" G DAT ;go chk for data if backed up all the way + S V=$NA(@V@(S)) ;add the subscript found when backing up. + IF $D(@V)>9 S V=$NA(@V@("")) G BKU ;if downpointer, descend and repeat +DAT IF $D(@V)#2=1 Q V ;if a data node, return with current name + G TOP diff --git a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC.m b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC.m index 1b56d06f..217f6f4c 100644 --- a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC.m +++ b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC.m @@ -1,11 +1,10 @@ -A1CKC ; GENERATED FROM 'A1CK VARO/DHCP' INPUT TEMPLATE(#1505), FILE 2;12/13/08 +A1CKC ; GENERATED FROM 'A1CK VARO/DHCP' INPUT TEMPLATE(#1505), FILE 2;04/21/06 D DE G BEGIN DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))="" - I $D(^(.3)) S %Z=^(.3) S %=$P(%Z,U,1) S:%]"" DE(4)=%,DE(11)=% S %=$P(%Z,U,2) S:%]"" DE(5)=% + I $D(^(.3)) S %Z=^(.3) S %=$P(%Z,U,1) S:%]"" DE(4)=% S %=$P(%Z,U,2) S:%]"" DE(5)=% I $D(^(.36)) S %Z=^(.36) S %=$P(%Z,U,1) S:%]"" DE(6)=% - I $D(^(.362)) S %Z=^(.362) S %=$P(%Z,U,12) S:%]"" DE(13)=% S %=$P(%Z,U,14) S:%]"" DE(12)=% I $D(^("TYPE")) S %Z=^("TYPE") S %=$P(%Z,U,1) S:%]"" DE(7)=% - I $D(^("VET")) S %Z=^("VET") S %=$P(%Z,U,1) S:%]"" DE(3)=%,DE(10)=% + I $D(^("VET")) S %Z=^("VET") S %=$P(%Z,U,1) S:%]"" DE(3)=% K %Z Q ; W W !?DL+DL-2,DLB_": " @@ -60,7 +59,7 @@ BEGIN S DNM="A1CKC",DQ=1 X1 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) Q 2 S DQ=3 ;@10 -3 S DW="VET;1",DV="SXa",DU="",DLB="VETERAN (Y/N)?",DIFLD=1901 +3 S DW="VET;1",DV="RSXa",DU="",DLB="VETERAN (Y/N)?",DIFLD=1901 S DE(DW)="C3^A1CKC" S DU="Y:YES;N:NO;" S Y="Y" @@ -70,8 +69,6 @@ C3 G C3S:$D(DE(3))[0 K DB S X=DE(3),DIC=DIE S DFN=DA D EN^DGMTCOR K DGMTCOR S X=DE(3),DIC=DIE - S DFN=DA D EN^DGRP7CC - S X=DE(3),DIC=DIE ; S X=DE(3),DIC=DIE D AUTOUPD^DGENA2(DA) @@ -84,8 +81,6 @@ C3S S X="" G:DG(DQ)=X C3F1 K DB S X=DG(DQ),DIC=DIE S DFN=DA D EN^DGMTCOR K DGMTCOR S X=DG(DQ),DIC=DIE - S DFN=DA D EN^DGRP7CC - S X=DG(DQ),DIC=DIE X ^DD(2,1901,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV S X="N" X ^DD(2,1901,1,3,1.4) S X=DG(DQ),DIC=DIE D AUTOUPD^DGENA2(DA) @@ -98,7 +93,7 @@ C3F1 Q X3 I $D(X) S:'$D(DPTX) DFN=DA D:'$D(^XUSEC("DG ELIGIBILITY",DUZ)) VAGE^DGLOCK:X="Y" I $D(X) D:$D(DFN) EV^DGLOCK Q ; -4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW=".3;1",DV="SXa",DU="",DLB="SERVICE CONNECTED?",DIFLD=.301 +4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW=".3;1",DV="RSXa",DU="",DLB="SERVICE CONNECTED?",DIFLD=.301 S DE(DW)="C4^A1CKC" S DU="Y:YES;N:NO;" S Y="Y" @@ -186,22 +181,12 @@ C6 G C6S:$D(DE(6))[0 K DB D AUTOUPD^DGENA2(DA) S X=DE(6),DIIX=2_U_DIFLD D AUDIT^DIET C6S S X="" G:DG(DQ)=X C6F1 K DB - S X=DG(DQ),DIC=DIE - X "S DFN=DA D EN^DGMTR K DGREQF" - S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,89.4) S Y(102)=$S($D(^DPT(D0,"E",D1,0)):^(0),1:"") S X=$S('$D(^DIC(8,+$P(Y(102),U,1),0)):"",1:$P(^(0),U,1)) S D0=I(0,0) S D1=I(1,0) S DIU=X K Y S X=DIV S X=DIV,X=X X ^DD(2,.361,1,2,1.4) - S X=DG(DQ),DIC=DIE - ; - S X=DG(DQ),DIC=DIE - S ^DPT("AEL",DA,+X)="" - S X=DG(DQ),DIC=DIE - D AUTOUPD^DGENA2(DA) - I $D(DE(6))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET + D ^A1CKC1 C6F1 Q X6 S DFN=DA D EV^DGLOCK I $D(X) D ECD^DGLOCK1 Q ; -7 D:$D(DG)>9 F^DIE17,DE S DQ=7,DW="TYPE;1",DV="P391'a",DU="",DLB="TYPE",DIFLD=391 +7 D:$D(DG)>9 F^DIE17,DE S DQ=7,DW="TYPE;1",DV="RP391'a",DU="",DLB="TYPE",DIFLD=391 S DE(DW)="C7^A1CKC",DE(DW,"INDEX")=1 S DU="DG(391," S X=DZT @@ -213,9 +198,7 @@ C7 G C7S:$D(DE(7))[0 K DB I ($T(AVAFC^VAFCDD01)'="") S VAFCF="391;" D AVAFC^VAFCDD01(DA) S X=DE(7),DIIX=2_U_DIFLD D AUDIT^DIET C7S S X="" G:DG(DQ)=X C7F1 K DB - S X=DG(DQ),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF="391;" D AVAFC^VAFCDD01(DA) - I $D(DE(7))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET + D ^A1CKC2 C7F1 N X,X1,X2 S DIXR=664 D C7X1(U) K X2 M X2=X D C7X1("O") K X1 M X1=X I $G(X(1))]"" D . K ^DPT("APTYPE",X,DA) @@ -232,62 +215,4 @@ X7 Q X8 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) Q 9 S DQ=10 ;@20 -10 D:$D(DG)>9 F^DIE17,DE S DQ=10,DW="VET;1",DV="SXa",DU="",DLB="VETERAN (Y/N)?",DIFLD=1901 - S DE(DW)="C10^A1CKC" - S DU="Y:YES;N:NO;" - S Y="Y" - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -C10 G C10S:$D(DE(10))[0 K DB - D ^A1CKC1 -C10S S X="" G:DG(DQ)=X C10F1 K DB - D ^A1CKC2 -C10F1 Q -X10 I $D(X) S:'$D(DPTX) DFN=DA D:'$D(^XUSEC("DG ELIGIBILITY",DUZ)) VAGE^DGLOCK:X="Y" I $D(X) D:$D(DFN) EV^DGLOCK - Q - ; -11 D:$D(DG)>9 F^DIE17,DE S DQ=11,DW=".3;1",DV="SXa",DU="",DLB="SERVICE CONNECTED?",DIFLD=.301 - S DE(DW)="C11^A1CKC" - S DU="Y:YES;N:NO;" - S Y="N" - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -C11 G C11S:$D(DE(11))[0 K DB - D ^A1CKC3 -C11S S X="" G:DG(DQ)=X C11F1 K DB - D ^A1CKC4 -C11F1 Q -X11 S DFN=DA D EV^DGLOCK I $D(X),X="Y" D VET^DGLOCK - Q - ; -12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW=".362;14",DV="SX",DU="",DLB="RECEIVING A VA PENSION?",DIFLD=.36235 - S DE(DW)="C12^A1CKC" - S DU="Y:YES;N:NO;U:UNKNOWN;" - S X=$S(PE="Y":"Y",1:"N") - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -C12 G C12S:$D(DE(12))[0 K DB - D ^A1CKC5 -C12S S X="" G:DG(DQ)=X C12F1 K DB - D ^A1CKC6 -C12F1 Q -X12 S DFN=DA D MV^DGLOCK - Q - ; -13 D:$D(DG)>9 F^DIE17,DE S DQ=13,DW=".362;12",DV="SX",DU="",DLB="RECEIVING A&A BENEFITS?",DIFLD=.36205 - S DE(DW)="C13^A1CKC" - S DU="Y:YES;N:NO;U:UNKNOWN;" - S X=$S(AA="Y":"Y",1:"N") - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -C13 G C13S:$D(DE(13))[0 K DB - D ^A1CKC7 -C13S S X="" G:DG(DQ)=X C13F1 K DB - D ^A1CKC8 -C13F1 Q -X13 S DFN=DA D MV^DGLOCK I $D(X) S DFN=DA D EV^DGLOCK - Q - ; -14 D:$D(DG)>9 F^DIE17 G ^A1CKC9 +10 D:$D(DG)>9 F^DIE17 G ^A1CKC3 diff --git a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC1.m b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC1.m index b7e428c7..124874bb 100644 --- a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC1.m +++ b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC1.m @@ -1,14 +1,12 @@ -A1CKC1 ; ;12/13/08 - S X=DE(10),DIC=DIE - S DFN=DA D EN^DGMTCOR K DGMTCOR - S X=DE(10),DIC=DIE - S DFN=DA D EN^DGRP7CC - S X=DE(10),DIC=DIE +A1CKC1 ; ;04/21/06 + S X=DG(DQ),DIC=DIE + X "S DFN=DA D EN^DGMTR K DGREQF" + S X=DG(DQ),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,89.4) S Y(102)=$S($D(^DPT(D0,"E",D1,0)):^(0),1:"") S X=$S('$D(^DIC(8,+$P(Y(102),U,1),0)):"",1:$P(^(0),U,1)) S D0=I(0,0) S D1=I(1,0) S DIU=X K Y S X=DIV S X=DIV,X=X X ^DD(2,.361,1,2,1.4) + S X=DG(DQ),DIC=DIE ; - S X=DE(10),DIC=DIE + S X=DG(DQ),DIC=DIE + S ^DPT("AEL",DA,+X)="" + S X=DG(DQ),DIC=DIE D AUTOUPD^DGENA2(DA) - S X=DE(10),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF="1901;" D AVAFC^VAFCDD01(DA) - S X=DE(10),DIC=DIE - D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) - S X=DE(10),DIIX=2_U_DIFLD D AUDIT^DIET + I $D(DE(6))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET diff --git a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC10.m b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC10.m index 308c9692..949c24cd 100644 --- a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC10.m +++ b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC10.m @@ -1,155 +1,4 @@ -A1CKC10 ; ;12/13/08 - D DE G BEGIN -DE S DIE="^DPT(D0,.372,",DIC=DIE,DP=2.04,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DPT(D0,.372,DA,""))="" - I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% S %=$P(%Z,U,2) S:%]"" DE(2)=% S %=$P(%Z,U,3) S:%]"" DE(3)=% - K %Z Q - ; -W W !?DL+DL-2,DLB_": " - Q -O D W W Y W:$X>45 !?9 - I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 - W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q -TR R X:DTIME E S (DTOUT,X)=U W $C(7) - Q -A K DQ(DQ) S DQ=DQ+1 -B G @DQ -RE G PR:$D(DE(DQ)) D W,TR -N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A -RD G QS:X?."?" I X["^" D D G ^DIE17 - I X="@" D D G Z^DIE2 - I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X -T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V - K DDER G X -P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 - G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z - I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X -V D @("X"_DQ) K YS -Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A -X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 - S X="?BAD" -QS S DZ=X D D,QQ^DIEQ G B -D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q -Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N -PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP -R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R - I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R - X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% -RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 -I I DV'["I",DV'["#" G RD - D E^DIE0 G RD:$D(X),PR - Q -SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 - I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 - D ^DIR I 'DDER S %=Y(0),X=Y - Q -SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) - I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" - E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") - Q -NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS -KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") -BEGIN S DNM="A1CKC10",DQ=1+D G B -1 S DW="0;1",DV="MP31'X",DU="",DLB="RATED DISABILITIES (VA)",DIFLD=.01 - S DE(DW)="C1^A1CKC10",DE(DW,"INDEX")=1 - S DU="DIC(31," - S X="`"_ISC - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -C1 G C1S:$D(DE(1))[0 K DB - S X=DE(1),DIC=DIE - D EVENT^IVMPLOG($G(DA(1))) -C1S S X="" G:DG(DQ)=X C1F1 K DB +A1CKC10 ; ;04/21/06 S X=DG(DQ),DIC=DIE - D EVENT^IVMPLOG($G(DA(1))) -C1F1 N X,X1,X2 S DIXR=411 D C1X1(U) K X2 M X2=X D C1X1("O") K X1 M X1=X - D - . N DIEXARR M DIEXARR=X S DIEZCOND=1 - . I (X1(1)'=X2(1))!(X1(2)'=X2(2))!(X1(3)'=X2(3)) - . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND - . S DGRDCHG=1 - K X M X=X2 D - . N DIEXARR M DIEXARR=X S DIEZCOND=1 - . I (X1(1)'=X2(1))!(X1(2)'=X2(2))!(X1(3)'=X2(3)) - . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND - . S DGRDCHG=1 - G C1F2 -C1X1(DION) K X - S X(1)=$G(@DIEZTMP@("V",2.04,DIIENS,.01,DION),$P($G(^DPT(DA(1),.372,DA,0)),U,1)) - S X(2)=$G(@DIEZTMP@("V",2.04,DIIENS,2,DION),$P($G(^DPT(DA(1),.372,DA,0)),U,2)) - S X(3)=$G(@DIEZTMP@("V",2.04,DIIENS,3,DION),$P($G(^DPT(DA(1),.372,DA,0)),U,3)) - S X=$G(X(1)) - Q -C1F2 Q -X1 I $D(X) D EK^DGLOCK Q - Q - ; -2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW="0;2",DV="RNJ3,0X",DU="",DLB="DISABILITY %",DIFLD=2 - S DE(DW)="C2^A1CKC10",DE(DW,"INDEX")=1 - S X=+SCI(ISC) - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -C2 G C2S:$D(DE(2))[0 K DB - S X=DE(2),DIC=DIE - D EVENT^IVMPLOG($G(DA(1))) -C2S S X="" G:DG(DQ)=X C2F1 K DB - S X=DG(DQ),DIC=DIE - D EVENT^IVMPLOG($G(DA(1))) -C2F1 N X,X1,X2 S DIXR=411 D C2X1(U) K X2 M X2=X D C2X1("O") K X1 M X1=X - D - . N DIEXARR M DIEXARR=X S DIEZCOND=1 - . I (X1(1)'=X2(1))!(X1(2)'=X2(2))!(X1(3)'=X2(3)) - . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND - . S DGRDCHG=1 - K X M X=X2 D - . N DIEXARR M DIEXARR=X S DIEZCOND=1 - . I (X1(1)'=X2(1))!(X1(2)'=X2(2))!(X1(3)'=X2(3)) - . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND - . S DGRDCHG=1 - G C2F2 -C2X1(DION) K X - S X(1)=$G(@DIEZTMP@("V",2.04,DIIENS,.01,DION),$P($G(^DPT(DA(1),.372,DA,0)),U,1)) - S X(2)=$G(@DIEZTMP@("V",2.04,DIIENS,2,DION),$P($G(^DPT(DA(1),.372,DA,0)),U,2)) - S X(3)=$G(@DIEZTMP@("V",2.04,DIIENS,3,DION),$P($G(^DPT(DA(1),.372,DA,0)),U,3)) - S X=$G(X(1)) - Q -C2F2 Q -X2 K:+X'=X!(X>100)!(X<0)!(X?.E1"."1N.N) X I $D(X) D EK^DGLOCK - Q - ; -3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW="0;3",DV="SX",DU="",DLB="SERVICE CONNECTED",DIFLD=3 - S DE(DW)="C3^A1CKC10",DE(DW,"INDEX")=1 - S DU="0:NO;1:YES;" - S Y="1" - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -C3 G C3S:$D(DE(3))[0 K DB - S X=DE(3),DIC=DIE - D EVENT^IVMPLOG($G(DA(1))) -C3S S X="" G:DG(DQ)=X C3F1 K DB - S X=DG(DQ),DIC=DIE - D EVENT^IVMPLOG($G(DA(1))) -C3F1 N X,X1,X2 S DIXR=411 D C3X1(U) K X2 M X2=X D C3X1("O") K X1 M X1=X - D - . N DIEXARR M DIEXARR=X S DIEZCOND=1 - . I (X1(1)'=X2(1))!(X1(2)'=X2(2))!(X1(3)'=X2(3)) - . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND - . S DGRDCHG=1 - K X M X=X2 D - . N DIEXARR M DIEXARR=X S DIEZCOND=1 - . I (X1(1)'=X2(1))!(X1(2)'=X2(2))!(X1(3)'=X2(3)) - . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND - . S DGRDCHG=1 - G C3F2 -C3X1(DION) K X - S X(1)=$G(@DIEZTMP@("V",2.04,DIIENS,.01,DION),$P($G(^DPT(DA(1),.372,DA,0)),U,1)) - S X(2)=$G(@DIEZTMP@("V",2.04,DIIENS,2,DION),$P($G(^DPT(DA(1),.372,DA,0)),U,2)) - S X(3)=$G(@DIEZTMP@("V",2.04,DIIENS,3,DION),$P($G(^DPT(DA(1),.372,DA,0)),U,3)) - S X=$G(X(1)) - Q -C3F2 Q -X3 S DFN=DA(1) D:X SC^DGLOCK1 I $D(X) D EK^DGLOCK - Q - ; -4 G 1^DIE17 + I ($T(AVAFC^VAFCDD01)'="") S VAFCF="391;" D AVAFC^VAFCDD01(DA) + I $D(DE(7))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET diff --git a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC11.m b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC11.m index 9364c672..1cef6bb2 100644 --- a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC11.m +++ b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC11.m @@ -1,9 +1,177 @@ -A1CKC11 ; ;12/13/08 - S X=DE(19),DIC=DIE +A1CKC11 ; ;04/21/06 + D DE G BEGIN +DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))="" + I $D(^(.3)) S %Z=^(.3) S %=$P(%Z,U,11) S:%]"" DE(6)=% + I $D(^(.362)) S %Z=^(.362) S %=$P(%Z,U,12) S:%]"" DE(12)=% S %=$P(%Z,U,13) S:%]"" DE(15)=% S %=$P(%Z,U,14) S:%]"" DE(9)=% + K %Z Q + ; +W W !?DL+DL-2,DLB_": " + Q +O D W W Y W:$X>45 !?9 + I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 + W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q +TR R X:DTIME E S (DTOUT,X)=U W $C(7) + Q +A K DQ(DQ) S DQ=DQ+1 +B G @DQ +RE G PR:$D(DE(DQ)) D W,TR +N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A +RD G QS:X?."?" I X["^" D D G ^DIE17 + I X="@" D D G Z^DIE2 + I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X +T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V + K DDER G X +P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 + G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z + I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X +V D @("X"_DQ) K YS +Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A +X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 + S X="?BAD" +QS S DZ=X D D,QQ^DIEQ G B +D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q +Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N +PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP +R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R + I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R + X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% +RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 +I I DV'["I",DV'["#" G RD + D E^DIE0 G RD:$D(X),PR + Q +SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 + I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 + D ^DIR I 'DDER S %=Y(0),X=Y + Q +SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) + I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" + E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") + Q +NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS +KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") +BEGIN S DNM="A1CKC11",DQ=1 +1 D:$D(DG)>9 F^DIE17,DE S DQ=1,D=0 K DE(1) ;.3721 + S DIFLD=.3721,DGO="^A1CKC12",DC="6^2.04P^.372^",DV="2.04MP31'X",DW="0;1",DOW="RATED DISABILITIES (VA)",DLB="Select "_DOW S:D DC=DC_D + S DU="DIC(31," + G RE:D I $D(DSC(2.04))#2,$P(DSC(2.04),"I $D(^UTILITY(",1)="" X DSC(2.04) S D=$O(^(0)) S:D="" D=-1 G M1 + S D=$S($D(^DPT(DA,.372,0)):$P(^(0),U,3,4),$O(^(0))'="":$O(^(0)),1:-1) +M1 I D>0 S DC=DC_D I $D(^DPT(DA,.372,+D,0)) S DE(1)=$P(^(0),U,1) + S X="`"_ISC + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +R1 D DE + G A + ; +2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X2 S Y="@31" + Q +3 S DQ=4 ;@39 +4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X4 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) + Q +5 S DQ=6 ;@100 +6 S DW=".3;11",DV="SX",DU="",DLB="RECEIVING VA DISABILITY?",DIFLD=.3025 + S DE(DW)="C6^A1CKC11" + S DU="Y:YES;N:NO;U:UNKNOWN;" + S X=CP + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +C6 G C6S:$D(DE(6))[0 K DB + S X=DE(6),DIC=DIE + X ^DD(2,.3025,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" X ^DD(2,.3025,1,1,2.4) + S X=DE(6),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.3025,1,2,2.4) +C6S S X="" G:DG(DQ)=X C6F1 K DB + S X=DG(DQ),DIC=DIE + X ^DD(2,.3025,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" X ^DD(2,.3025,1,1,1.4) + S X=DG(DQ),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.3025,1,2,1.4) +C6F1 Q +X6 S DFN=DA D MV^DGLOCK I $D(X),X="Y" D EC^DGLOCK1 + Q + ; +7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X7 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) + Q +8 S DQ=9 ;@200 +9 D:$D(DG)>9 F^DIE17,DE S DQ=9,DW=".362;14",DV="SX",DU="",DLB="RECEIVING A VA PENSION?",DIFLD=.36235 + S DE(DW)="C9^A1CKC11" + S DU="Y:YES;N:NO;U:UNKNOWN;" + S X=PE + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +C9 G C9S:$D(DE(9))[0 K DB + S X=DE(9),DIC=DIE X ^DD(2,.36235,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,1,2.4) - S X=DE(19),DIC=DIE + S X=DE(9),DIC=DIE S DFN=DA D EN^DGMTCOR K DGMTCOR - S X=DE(19),DIC=DIE + S X=DE(9),DIC=DIE K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,3,2.4) - S X=DE(19),DIC=DIE + S X=DE(9),DIC=DIE D AUTOUPD^DGENA2(DA) +C9S S X="" G:DG(DQ)=X C9F1 K DB + S X=DG(DQ),DIC=DIE + X ^DD(2,.36235,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,1,1.4) + S X=DG(DQ),DIC=DIE + S DFN=DA D EN^DGMTCOR K DGMTCOR + S X=DG(DQ),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,3,1.4) + S X=DG(DQ),DIC=DIE + D AUTOUPD^DGENA2(DA) +C9F1 Q +X9 S DFN=DA D MV^DGLOCK + Q + ; +10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X10 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) + Q +11 S DQ=12 ;@300 +12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW=".362;12",DV="SX",DU="",DLB="RECEIVING A&A BENEFITS?",DIFLD=.36205 + S DE(DW)="C12^A1CKC11" + S DU="Y:YES;N:NO;U:UNKNOWN;" + S X=AA + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +C12 G C12S:$D(DE(12))[0 K DB + S X=DE(12),DIC=DIE + X ^DD(2,.36205,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,1,2.4) + S X=DE(12),DIC=DIE + S DFN=DA D EN^DGMTCOR K DGMTCOR + S X=DE(12),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,3,2.4) + S X=DE(12),DIC=DIE + D AUTOUPD^DGENA2(DA) +C12S S X="" G:DG(DQ)=X C12F1 K DB + D ^A1CKC13 +C12F1 Q +X12 S DFN=DA D MV^DGLOCK I $D(X) S DFN=DA D EV^DGLOCK + Q + ; +13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X13 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) + Q +14 S DQ=15 ;@400 +15 D:$D(DG)>9 F^DIE17,DE S DQ=15,DW=".362;13",DV="SX",DU="",DLB="RECEIVING HOUSEBOUND BENEFITS?",DIFLD=.36215 + S DE(DW)="C15^A1CKC11" + S DU="Y:YES;N:NO;U:UNKNOWN;" + S X=HB + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +C15 G C15S:$D(DE(15))[0 K DB + D ^A1CKC14 +C15S S X="" G:DG(DQ)=X C15F1 K DB + D ^A1CKC15 +C15F1 Q +X15 S DFN=DA D MV^DGLOCK I $D(X) S DFN=DA D EV^DGLOCK + Q + ; +16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X16 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) + Q +17 S DQ=18 ;@999 +18 G 0^DIE17 diff --git a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC12.m b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC12.m index e3a556f9..fd04d8cc 100644 --- a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC12.m +++ b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC12.m @@ -1,9 +1,143 @@ -A1CKC12 ; ;12/13/08 - S X=DG(DQ),DIC=DIE - X ^DD(2,.36235,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,1,1.4) - S X=DG(DQ),DIC=DIE - S DFN=DA D EN^DGMTCOR K DGMTCOR - S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,3,1.4) - S X=DG(DQ),DIC=DIE - D AUTOUPD^DGENA2(DA) +A1CKC12 ; ;04/21/06 + D DE G BEGIN +DE S DIE="^DPT(D0,.372,",DIC=DIE,DP=2.04,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DPT(D0,.372,DA,""))="" + I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% S %=$P(%Z,U,2) S:%]"" DE(2)=% S %=$P(%Z,U,3) S:%]"" DE(3)=% + K %Z Q + ; +W W !?DL+DL-2,DLB_": " + Q +O D W W Y W:$X>45 !?9 + I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 + W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q +TR R X:DTIME E S (DTOUT,X)=U W $C(7) + Q +A K DQ(DQ) S DQ=DQ+1 +B G @DQ +RE G PR:$D(DE(DQ)) D W,TR +N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A +RD G QS:X?."?" I X["^" D D G ^DIE17 + I X="@" D D G Z^DIE2 + I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X +T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V + K DDER G X +P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 + G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z + I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X +V D @("X"_DQ) K YS +Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A +X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 + S X="?BAD" +QS S DZ=X D D,QQ^DIEQ G B +D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q +Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N +PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP +R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R + I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R + X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% +RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 +I I DV'["I",DV'["#" G RD + D E^DIE0 G RD:$D(X),PR + Q +SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 + I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 + D ^DIR I 'DDER S %=Y(0),X=Y + Q +SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) + I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" + E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") + Q +NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS +KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") +BEGIN S DNM="A1CKC12",DQ=1+D G B +1 S DW="0;1",DV="MP31'X",DU="",DLB="RATED DISABILITIES (VA)",DIFLD=.01 + S DE(DW)="C1^A1CKC12",DE(DW,"INDEX")=1 + S DU="DIC(31," + S X="`"_ISC + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +C1 G C1S:$D(DE(1))[0 K DB +C1S S X="" G:DG(DQ)=X C1F1 K DB +C1F1 N X,X1,X2 S DIXR=411 D C1X1(U) K X2 M X2=X D C1X1("O") K X1 M X1=X + D + . N DIEXARR M DIEXARR=X S DIEZCOND=1 + . I (X1(1)'=X2(1))!(X1(2)'=X2(2))!(X1(3)'=X2(3)) + . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND + . S DGRDCHG=1 + K X M X=X2 D + . N DIEXARR M DIEXARR=X S DIEZCOND=1 + . I (X1(1)'=X2(1))!(X1(2)'=X2(2))!(X1(3)'=X2(3)) + . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND + . S DGRDCHG=1 + G C1F2 +C1X1(DION) K X + S X(1)=$G(@DIEZTMP@("V",2.04,DIIENS,.01,DION),$P($G(^DPT(DA(1),.372,DA,0)),U,1)) + S X(2)=$G(@DIEZTMP@("V",2.04,DIIENS,2,DION),$P($G(^DPT(DA(1),.372,DA,0)),U,2)) + S X(3)=$G(@DIEZTMP@("V",2.04,DIIENS,3,DION),$P($G(^DPT(DA(1),.372,DA,0)),U,3)) + S X=$G(X(1)) + Q +C1F2 Q +X1 I $D(X) D EK^DGLOCK Q + Q + ; +2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW="0;2",DV="RNJ3,0X",DU="",DLB="DISABILITY %",DIFLD=2 + S DE(DW)="C2^A1CKC12",DE(DW,"INDEX")=1 + S X=+SCI(ISC) + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +C2 G C2S:$D(DE(2))[0 K DB +C2S S X="" G:DG(DQ)=X C2F1 K DB +C2F1 N X,X1,X2 S DIXR=411 D C2X1(U) K X2 M X2=X D C2X1("O") K X1 M X1=X + D + . N DIEXARR M DIEXARR=X S DIEZCOND=1 + . I (X1(1)'=X2(1))!(X1(2)'=X2(2))!(X1(3)'=X2(3)) + . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND + . S DGRDCHG=1 + K X M X=X2 D + . N DIEXARR M DIEXARR=X S DIEZCOND=1 + . I (X1(1)'=X2(1))!(X1(2)'=X2(2))!(X1(3)'=X2(3)) + . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND + . S DGRDCHG=1 + G C2F2 +C2X1(DION) K X + S X(1)=$G(@DIEZTMP@("V",2.04,DIIENS,.01,DION),$P($G(^DPT(DA(1),.372,DA,0)),U,1)) + S X(2)=$G(@DIEZTMP@("V",2.04,DIIENS,2,DION),$P($G(^DPT(DA(1),.372,DA,0)),U,2)) + S X(3)=$G(@DIEZTMP@("V",2.04,DIIENS,3,DION),$P($G(^DPT(DA(1),.372,DA,0)),U,3)) + S X=$G(X(1)) + Q +C2F2 Q +X2 K:+X'=X!(X>100)!(X<0)!(X?.E1"."1N.N) X I $D(X) D EK^DGLOCK + Q + ; +3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW="0;3",DV="SX",DU="",DLB="SERVICE CONNECTED",DIFLD=3 + S DE(DW)="C3^A1CKC12",DE(DW,"INDEX")=1 + S DU="0:NO;1:YES;" + S Y="1" + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +C3 G C3S:$D(DE(3))[0 K DB +C3S S X="" G:DG(DQ)=X C3F1 K DB +C3F1 N X,X1,X2 S DIXR=411 D C3X1(U) K X2 M X2=X D C3X1("O") K X1 M X1=X + D + . N DIEXARR M DIEXARR=X S DIEZCOND=1 + . I (X1(1)'=X2(1))!(X1(2)'=X2(2))!(X1(3)'=X2(3)) + . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND + . S DGRDCHG=1 + K X M X=X2 D + . N DIEXARR M DIEXARR=X S DIEZCOND=1 + . I (X1(1)'=X2(1))!(X1(2)'=X2(2))!(X1(3)'=X2(3)) + . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND + . S DGRDCHG=1 + G C3F2 +C3X1(DION) K X + S X(1)=$G(@DIEZTMP@("V",2.04,DIIENS,.01,DION),$P($G(^DPT(DA(1),.372,DA,0)),U,1)) + S X(2)=$G(@DIEZTMP@("V",2.04,DIIENS,2,DION),$P($G(^DPT(DA(1),.372,DA,0)),U,2)) + S X(3)=$G(@DIEZTMP@("V",2.04,DIIENS,3,DION),$P($G(^DPT(DA(1),.372,DA,0)),U,3)) + S X=$G(X(1)) + Q +C3F2 Q +X3 S DFN=DA(1) D:X SC^DGLOCK1 I $D(X) D EK^DGLOCK + Q + ; +4 G 1^DIE17 diff --git a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC13.m b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC13.m index 7eb24464..0f78373d 100644 --- a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC13.m +++ b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC13.m @@ -1,9 +1,9 @@ -A1CKC13 ; ;12/13/08 - S X=DE(22),DIC=DIE - X ^DD(2,.36205,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,1,2.4) - S X=DE(22),DIC=DIE +A1CKC13 ; ;04/21/06 + S X=DG(DQ),DIC=DIE + X ^DD(2,.36205,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,1,1.4) + S X=DG(DQ),DIC=DIE S DFN=DA D EN^DGMTCOR K DGMTCOR - S X=DE(22),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,3,2.4) - S X=DE(22),DIC=DIE + S X=DG(DQ),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,3,1.4) + S X=DG(DQ),DIC=DIE D AUTOUPD^DGENA2(DA) diff --git a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC14.m b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC14.m index 6c37a62f..0932cb22 100644 --- a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC14.m +++ b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC14.m @@ -1,9 +1,9 @@ -A1CKC14 ; ;12/13/08 - S X=DG(DQ),DIC=DIE - X ^DD(2,.36205,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,1,1.4) - S X=DG(DQ),DIC=DIE +A1CKC14 ; ;04/21/06 + S X=DE(15),DIC=DIE + X ^DD(2,.36215,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,1,2.4) + S X=DE(15),DIC=DIE S DFN=DA D EN^DGMTCOR K DGMTCOR - S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,3,1.4) - S X=DG(DQ),DIC=DIE + S X=DE(15),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,3,2.4) + S X=DE(15),DIC=DIE D AUTOUPD^DGENA2(DA) diff --git a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC15.m b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC15.m index 3672c377..5f24ac46 100644 --- a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC15.m +++ b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC15.m @@ -1,71 +1,4 @@ -A1CKC15 ; ;12/13/08 - D DE G BEGIN -DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))="" - I $D(^(.362)) S %Z=^(.362) S %=$P(%Z,U,13) S:%]"" DE(1)=% - K %Z Q - ; -W W !?DL+DL-2,DLB_": " - Q -O D W W Y W:$X>45 !?9 - I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 - W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q -TR R X:DTIME E S (DTOUT,X)=U W $C(7) - Q -A K DQ(DQ) S DQ=DQ+1 -B G @DQ -RE G PR:$D(DE(DQ)) D W,TR -N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A -RD G QS:X?."?" I X["^" D D G ^DIE17 - I X="@" D D G Z^DIE2 - I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X -T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V - K DDER G X -P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 - G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z - I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X -V D @("X"_DQ) K YS -Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A -X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 - S X="?BAD" -QS S DZ=X D D,QQ^DIEQ G B -D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q -Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N -PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP -R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R - I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R - X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% -RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 -I I DV'["I",DV'["#" G RD - D E^DIE0 G RD:$D(X),PR - Q -SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 - I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 - D ^DIR I 'DDER S %=Y(0),X=Y - Q -SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) - I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" - E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") - Q -NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS -KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") -BEGIN S DNM="A1CKC15",DQ=1 -1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".362;13",DV="SX",DU="",DLB="RECEIVING HOUSEBOUND BENEFITS?",DIFLD=.36215 - S DE(DW)="C1^A1CKC15" - S DU="Y:YES;N:NO;U:UNKNOWN;" - S X=HB - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -C1 G C1S:$D(DE(1))[0 K DB - S X=DE(1),DIC=DIE - X ^DD(2,.36215,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,1,2.4) - S X=DE(1),DIC=DIE - S DFN=DA D EN^DGMTCOR K DGMTCOR - S X=DE(1),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,3,2.4) - S X=DE(1),DIC=DIE - D AUTOUPD^DGENA2(DA) -C1S S X="" G:DG(DQ)=X C1F1 K DB +A1CKC15 ; ;04/21/06 S X=DG(DQ),DIC=DIE X ^DD(2,.36215,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,1,1.4) S X=DG(DQ),DIC=DIE @@ -74,12 +7,3 @@ C1S S X="" G:DG(DQ)=X C1F1 K DB K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,3,1.4) S X=DG(DQ),DIC=DIE D AUTOUPD^DGENA2(DA) -C1F1 Q -X1 S DFN=DA D MV^DGLOCK I $D(X) S DFN=DA D EV^DGLOCK - Q - ; -2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X2 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) - Q -3 S DQ=4 ;@999 -4 G 0^DIE17 diff --git a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC2.m b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC2.m index fb217ce8..cead7e91 100644 --- a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC2.m +++ b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC2.m @@ -1,14 +1,4 @@ -A1CKC2 ; ;12/13/08 +A1CKC2 ; ;04/21/06 S X=DG(DQ),DIC=DIE - S DFN=DA D EN^DGMTCOR K DGMTCOR - S X=DG(DQ),DIC=DIE - S DFN=DA D EN^DGRP7CC - S X=DG(DQ),DIC=DIE - X ^DD(2,1901,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV S X="N" X ^DD(2,1901,1,3,1.4) - S X=DG(DQ),DIC=DIE - D AUTOUPD^DGENA2(DA) - S X=DG(DQ),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF="1901;" D AVAFC^VAFCDD01(DA) - S X=DG(DQ),DIC=DIE - D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) - I $D(DE(10))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET + I ($T(AVAFC^VAFCDD01)'="") S VAFCF="391;" D AVAFC^VAFCDD01(DA) + I $D(DE(7))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET diff --git a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC3.m b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC3.m index f2bba5e1..fc25f0f2 100644 --- a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC3.m +++ b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC3.m @@ -1,12 +1,245 @@ -A1CKC3 ; ;12/13/08 - S X=DE(11),DIC=DIE +A1CKC3 ; ;04/21/06 + D DE G BEGIN +DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))="" + I $D(^(.3)) S %Z=^(.3) S %=$P(%Z,U,1) S:%]"" DE(2)=% + I $D(^(.36)) S %Z=^(.36) S %=$P(%Z,U,1) S:%]"" DE(6)=% + I $D(^(.362)) S %Z=^(.362) S %=$P(%Z,U,12) S:%]"" DE(4)=% S %=$P(%Z,U,13) S:%]"" DE(5)=% S %=$P(%Z,U,14) S:%]"" DE(3)=% + I $D(^("TYPE")) S %Z=^("TYPE") S %=$P(%Z,U,1) S:%]"" DE(7)=% + I $D(^("VET")) S %Z=^("VET") S %=$P(%Z,U,1) S:%]"" DE(1)=% + K %Z Q ; - S X=DE(11),DIC=DIE +W W !?DL+DL-2,DLB_": " + Q +O D W W Y W:$X>45 !?9 + I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 + W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q +TR R X:DTIME E S (DTOUT,X)=U W $C(7) + Q +A K DQ(DQ) S DQ=DQ+1 +B G @DQ +RE G PR:$D(DE(DQ)) D W,TR +N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A +RD G QS:X?."?" I X["^" D D G ^DIE17 + I X="@" D D G Z^DIE2 + I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X +T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V + K DDER G X +P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 + G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z + I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X +V D @("X"_DQ) K YS +Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A +X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 + S X="?BAD" +QS S DZ=X D D,QQ^DIEQ G B +D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q +Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N +PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP +R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R + I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R + X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% +RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 +I I DV'["I",DV'["#" G RD + D E^DIE0 G RD:$D(X),PR + Q +SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 + I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 + D ^DIR I 'DDER S %=Y(0),X=Y + Q +SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) + I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" + E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") + Q +NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS +KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") +BEGIN S DNM="A1CKC3",DQ=1 +1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="VET;1",DV="RSXa",DU="",DLB="VETERAN (Y/N)?",DIFLD=1901 + S DE(DW)="C1^A1CKC3" + S DU="Y:YES;N:NO;" + S Y="Y" + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +C1 G C1S:$D(DE(1))[0 K DB + S X=DE(1),DIC=DIE + S DFN=DA D EN^DGMTCOR K DGMTCOR + S X=DE(1),DIC=DIE ; - S X=DE(11),DIC=DIE + S X=DE(1),DIC=DIE D AUTOUPD^DGENA2(DA) - S X=DE(11),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".301;" D AVAFC^VAFCDD01(DA) - S X=DE(11),DIC=DIE + S X=DE(1),DIC=DIE + I ($T(AVAFC^VAFCDD01)'="") S VAFCF="1901;" D AVAFC^VAFCDD01(DA) + S X=DE(1),DIC=DIE D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) - S X=DE(11),DIIX=2_U_DIFLD D AUDIT^DIET + S X=DE(1),DIIX=2_U_DIFLD D AUDIT^DIET +C1S S X="" G:DG(DQ)=X C1F1 K DB + S X=DG(DQ),DIC=DIE + S DFN=DA D EN^DGMTCOR K DGMTCOR + S X=DG(DQ),DIC=DIE + X ^DD(2,1901,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV S X="N" X ^DD(2,1901,1,3,1.4) + S X=DG(DQ),DIC=DIE + D AUTOUPD^DGENA2(DA) + S X=DG(DQ),DIC=DIE + I ($T(AVAFC^VAFCDD01)'="") S VAFCF="1901;" D AVAFC^VAFCDD01(DA) + S X=DG(DQ),DIC=DIE + D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) + I $D(DE(1))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET +C1F1 Q +X1 I $D(X) S:'$D(DPTX) DFN=DA D:'$D(^XUSEC("DG ELIGIBILITY",DUZ)) VAGE^DGLOCK:X="Y" I $D(X) D:$D(DFN) EV^DGLOCK + Q + ; +2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW=".3;1",DV="RSXa",DU="",DLB="SERVICE CONNECTED?",DIFLD=.301 + S DE(DW)="C2^A1CKC3" + S DU="Y:YES;N:NO;" + S Y="N" + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +C2 G C2S:$D(DE(2))[0 K DB + S X=DE(2),DIC=DIE + ; + S X=DE(2),DIC=DIE + ; + S X=DE(2),DIC=DIE + D AUTOUPD^DGENA2(DA) + S X=DE(2),DIC=DIE + I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".301;" D AVAFC^VAFCDD01(DA) + S X=DE(2),DIC=DIE + D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) + S X=DE(2),DIIX=2_U_DIFLD D AUDIT^DIET +C2S S X="" G:DG(DQ)=X C2F1 K DB + S X=DG(DQ),DIC=DIE + X ^DD(2,.301,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.301,1,1,1.4) + S X=DG(DQ),DIC=DIE + X ^DD(2,.301,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X="" X ^DD(2,.301,1,2,1.4) + S X=DG(DQ),DIC=DIE + D AUTOUPD^DGENA2(DA) + S X=DG(DQ),DIC=DIE + I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".301;" D AVAFC^VAFCDD01(DA) + S X=DG(DQ),DIC=DIE + D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) + I $D(DE(2))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET +C2F1 Q +X2 S DFN=DA D EV^DGLOCK I $D(X),X="Y" D VET^DGLOCK + Q + ; +3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW=".362;14",DV="SX",DU="",DLB="RECEIVING A VA PENSION?",DIFLD=.36235 + S DE(DW)="C3^A1CKC3" + S DU="Y:YES;N:NO;U:UNKNOWN;" + S X=$S(PE="Y":"Y",1:"N") + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +C3 G C3S:$D(DE(3))[0 K DB + S X=DE(3),DIC=DIE + X ^DD(2,.36235,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,1,2.4) + S X=DE(3),DIC=DIE + S DFN=DA D EN^DGMTCOR K DGMTCOR + S X=DE(3),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,3,2.4) + S X=DE(3),DIC=DIE + D AUTOUPD^DGENA2(DA) +C3S S X="" G:DG(DQ)=X C3F1 K DB + S X=DG(DQ),DIC=DIE + X ^DD(2,.36235,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,1,1.4) + S X=DG(DQ),DIC=DIE + S DFN=DA D EN^DGMTCOR K DGMTCOR + S X=DG(DQ),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,3,1.4) + S X=DG(DQ),DIC=DIE + D AUTOUPD^DGENA2(DA) +C3F1 Q +X3 S DFN=DA D MV^DGLOCK + Q + ; +4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW=".362;12",DV="SX",DU="",DLB="RECEIVING A&A BENEFITS?",DIFLD=.36205 + S DE(DW)="C4^A1CKC3" + S DU="Y:YES;N:NO;U:UNKNOWN;" + S X=$S(AA="Y":"Y",1:"N") + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +C4 G C4S:$D(DE(4))[0 K DB + S X=DE(4),DIC=DIE + X ^DD(2,.36205,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,1,2.4) + S X=DE(4),DIC=DIE + S DFN=DA D EN^DGMTCOR K DGMTCOR + S X=DE(4),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,3,2.4) + S X=DE(4),DIC=DIE + D AUTOUPD^DGENA2(DA) +C4S S X="" G:DG(DQ)=X C4F1 K DB + D ^A1CKC4 +C4F1 Q +X4 S DFN=DA D MV^DGLOCK I $D(X) S DFN=DA D EV^DGLOCK + Q + ; +5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW=".362;13",DV="SX",DU="",DLB="RECEIVING HOUSEBOUND BENEFITS?",DIFLD=.36215 + S DE(DW)="C5^A1CKC3" + S DU="Y:YES;N:NO;U:UNKNOWN;" + S X=$S(HB="Y":"Y",1:"N") + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +C5 G C5S:$D(DE(5))[0 K DB + D ^A1CKC5 +C5S S X="" G:DG(DQ)=X C5F1 K DB + D ^A1CKC6 +C5F1 Q +X5 S DFN=DA D MV^DGLOCK I $D(X) S DFN=DA D EV^DGLOCK + Q + ; +6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW=".36;1",DV="*P8'Xa",DU="",DLB="PRIMARY ELIGIBILITY CODE",DIFLD=.361 + S DE(DW)="C6^A1CKC3" + S DU="DIC(8," + S X=ELIG + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +C6 G C6S:$D(DE(6))[0 K DB + D ^A1CKC7 +C6S S X="" G:DG(DQ)=X C6F1 K DB + D ^A1CKC8 +C6F1 Q +X6 S DFN=DA D EV^DGLOCK I $D(X) D ECD^DGLOCK1 + Q + ; +7 D:$D(DG)>9 F^DIE17,DE S DQ=7,DW="TYPE;1",DV="RP391'a",DU="",DLB="TYPE",DIFLD=391 + S DE(DW)="C7^A1CKC3",DE(DW,"INDEX")=1 + S DU="DG(391," + S X=DZT2 + S Y=X + S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) + G RD +C7 G C7S:$D(DE(7))[0 K DB + D ^A1CKC9 +C7S S X="" G:DG(DQ)=X C7F1 K DB + D ^A1CKC10 +C7F1 N X,X1,X2 S DIXR=664 D C7X1(U) K X2 M X2=X D C7X1("O") K X1 M X1=X + I $G(X(1))]"" D + . K ^DPT("APTYPE",X,DA) + K X M X=X2 I $G(X(1))]"" D + . S ^DPT("APTYPE",X,DA)="" + G C7F2 +C7X1(DION) K X + S X(1)=$G(@DIEZTMP@("V",2,DIIENS,391,DION),$P($G(^DPT(DA,"TYPE")),U,1)) + S X=$G(X(1)) + Q +C7F2 Q +X7 Q +8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X8 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) + Q +9 S DQ=10 ;@30 +10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X10 I 'SCI S Y="@39" + Q +11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X11 S ISC=0 + Q +12 S DQ=13 ;@31 +13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X13 S ISC=$O(SCI(ISC)) + Q +14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 +X14 I 'ISC S Y="@39" + Q +15 D:$D(DG)>9 F^DIE17 G ^A1CKC11 diff --git a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC4.m b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC4.m index 95ea166d..f62ef3c1 100644 --- a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC4.m +++ b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC4.m @@ -1,12 +1,9 @@ -A1CKC4 ; ;12/13/08 +A1CKC4 ; ;04/21/06 S X=DG(DQ),DIC=DIE - X ^DD(2,.301,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.301,1,1,1.4) + X ^DD(2,.36205,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,1,1.4) S X=DG(DQ),DIC=DIE - X ^DD(2,.301,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X="" X ^DD(2,.301,1,2,1.4) + S DFN=DA D EN^DGMTCOR K DGMTCOR + S X=DG(DQ),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,3,1.4) S X=DG(DQ),DIC=DIE D AUTOUPD^DGENA2(DA) - S X=DG(DQ),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".301;" D AVAFC^VAFCDD01(DA) - S X=DG(DQ),DIC=DIE - D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA) - I $D(DE(11))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET diff --git a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC5.m b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC5.m index 0dda5a7e..e96ed362 100644 --- a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC5.m +++ b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC5.m @@ -1,9 +1,9 @@ -A1CKC5 ; ;12/13/08 - S X=DE(12),DIC=DIE - X ^DD(2,.36235,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,1,2.4) - S X=DE(12),DIC=DIE +A1CKC5 ; ;04/21/06 + S X=DE(5),DIC=DIE + X ^DD(2,.36215,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,1,2.4) + S X=DE(5),DIC=DIE S DFN=DA D EN^DGMTCOR K DGMTCOR - S X=DE(12),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,3,2.4) - S X=DE(12),DIC=DIE + S X=DE(5),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,3,2.4) + S X=DE(5),DIC=DIE D AUTOUPD^DGENA2(DA) diff --git a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC6.m b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC6.m index d484847d..f015689d 100644 --- a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC6.m +++ b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC6.m @@ -1,9 +1,9 @@ -A1CKC6 ; ;12/13/08 +A1CKC6 ; ;04/21/06 S X=DG(DQ),DIC=DIE - X ^DD(2,.36235,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,1,1.4) + X ^DD(2,.36215,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,1,1.4) S X=DG(DQ),DIC=DIE S DFN=DA D EN^DGMTCOR K DGMTCOR S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,3,1.4) + K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,3,1.4) S X=DG(DQ),DIC=DIE D AUTOUPD^DGENA2(DA) diff --git a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC7.m b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC7.m index f0a3df84..e1f473d2 100644 --- a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC7.m +++ b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC7.m @@ -1,9 +1,12 @@ -A1CKC7 ; ;12/13/08 - S X=DE(13),DIC=DIE - X ^DD(2,.36205,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,1,2.4) - S X=DE(13),DIC=DIE - S DFN=DA D EN^DGMTCOR K DGMTCOR - S X=DE(13),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,3,2.4) - S X=DE(13),DIC=DIE +A1CKC7 ; ;04/21/06 + S X=DE(6),DIC=DIE + ; + S X=DE(6),DIC=DIE + K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,2.2) I DIV(1)>0 S DIK(0)=DA,DIK="^DPT(DIV(0),""E"",",DA(1)=DIV(0),DA=DIV(1) D ^DIK S DA=DIK(0) K DIK + S X=DE(6),DIC=DIE + X "I $S('$D(^DIC(8,+X,0)):0,$P(^(0),""^"",1)[""DOM"":0,'$D(^DPT(DA,.36)):1,'$D(^DIC(8,+^(.36),0)):1,$P(^(0),""^"",1)'[""DOM"":1,1:0) S DGXRF=.361 D ^DGDDC Q" + S X=DE(6),DIC=DIE + K ^DPT("AEL",DA,+X) + S X=DE(6),DIC=DIE D AUTOUPD^DGENA2(DA) + S X=DE(6),DIIX=2_U_DIFLD D AUDIT^DIET diff --git a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC8.m b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC8.m index 66c7cce2..1395ba2b 100644 --- a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC8.m +++ b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC8.m @@ -1,9 +1,12 @@ -A1CKC8 ; ;12/13/08 +A1CKC8 ; ;04/21/06 S X=DG(DQ),DIC=DIE - X ^DD(2,.36205,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,1,1.4) + X "S DFN=DA D EN^DGMTR K DGREQF" S X=DG(DQ),DIC=DIE - S DFN=DA D EN^DGMTCOR K DGMTCOR + K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,89.4) S Y(102)=$S($D(^DPT(D0,"E",D1,0)):^(0),1:"") S X=$S('$D(^DIC(8,+$P(Y(102),U,1),0)):"",1:$P(^(0),U,1)) S D0=I(0,0) S D1=I(1,0) S DIU=X K Y S X=DIV S X=DIV,X=X X ^DD(2,.361,1,2,1.4) S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,3,1.4) + ; + S X=DG(DQ),DIC=DIE + S ^DPT("AEL",DA,+X)="" S X=DG(DQ),DIC=DIE D AUTOUPD^DGENA2(DA) + I $D(DE(6))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET diff --git a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC9.m b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC9.m index f0d32e8f..cc574c5a 100644 --- a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC9.m +++ b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC9.m @@ -1,251 +1,4 @@ -A1CKC9 ; ;12/13/08 - D DE G BEGIN -DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))="" - I $D(^(.3)) S %Z=^(.3) S %=$P(%Z,U,11) S:%]"" DE(16)=% - I $D(^(.36)) S %Z=^(.36) S %=$P(%Z,U,1) S:%]"" DE(2)=% - I $D(^(.362)) S %Z=^(.362) S %=$P(%Z,U,12) S:%]"" DE(22)=% S %=$P(%Z,U,13) S:%]"" DE(1)=% S %=$P(%Z,U,14) S:%]"" DE(19)=% - I $D(^("TYPE")) S %Z=^("TYPE") S %=$P(%Z,U,1) S:%]"" DE(3)=% - K %Z Q - ; -W W !?DL+DL-2,DLB_": " - Q -O D W W Y W:$X>45 !?9 - I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 - W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q -TR R X:DTIME E S (DTOUT,X)=U W $C(7) - Q -A K DQ(DQ) S DQ=DQ+1 -B G @DQ -RE G PR:$D(DE(DQ)) D W,TR -N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A -RD G QS:X?."?" I X["^" D D G ^DIE17 - I X="@" D D G Z^DIE2 - I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X -T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V - K DDER G X -P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 - G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z - I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X -V D @("X"_DQ) K YS -Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A -X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 - S X="?BAD" -QS S DZ=X D D,QQ^DIEQ G B -D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q -Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N -PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP -R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R - I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R - X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% -RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 -I I DV'["I",DV'["#" G RD - D E^DIE0 G RD:$D(X),PR - Q -SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 - I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 - D ^DIR I 'DDER S %=Y(0),X=Y - Q -SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) - I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" - E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") - Q -NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS -KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") -BEGIN S DNM="A1CKC9",DQ=1 -1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW=".362;13",DV="SX",DU="",DLB="RECEIVING HOUSEBOUND BENEFITS?",DIFLD=.36215 - S DE(DW)="C1^A1CKC9" - S DU="Y:YES;N:NO;U:UNKNOWN;" - S X=$S(HB="Y":"Y",1:"N") - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -C1 G C1S:$D(DE(1))[0 K DB - S X=DE(1),DIC=DIE - X ^DD(2,.36215,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,1,2.4) - S X=DE(1),DIC=DIE - S DFN=DA D EN^DGMTCOR K DGMTCOR - S X=DE(1),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,3,2.4) - S X=DE(1),DIC=DIE - D AUTOUPD^DGENA2(DA) -C1S S X="" G:DG(DQ)=X C1F1 K DB - S X=DG(DQ),DIC=DIE - X ^DD(2,.36215,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,1,1.4) - S X=DG(DQ),DIC=DIE - S DFN=DA D EN^DGMTCOR K DGMTCOR - S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,3,1.4) - S X=DG(DQ),DIC=DIE - D AUTOUPD^DGENA2(DA) -C1F1 Q -X1 S DFN=DA D MV^DGLOCK I $D(X) S DFN=DA D EV^DGLOCK - Q - ; -2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW=".36;1",DV="*P8'Xa",DU="",DLB="PRIMARY ELIGIBILITY CODE",DIFLD=.361 - S DE(DW)="C2^A1CKC9" - S DU="DIC(8," - S X=ELIG - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -C2 G C2S:$D(DE(2))[0 K DB - S X=DE(2),DIC=DIE - ; - S X=DE(2),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,2.2) I DIV(1)>0 S DIK(0)=DA,DIK="^DPT(DIV(0),""E"",",DA(1)=DIV(0),DA=DIV(1) D ^DIK S DA=DIK(0) K DIK - S X=DE(2),DIC=DIE - X "I $S('$D(^DIC(8,+X,0)):0,$P(^(0),""^"",1)[""DOM"":0,'$D(^DPT(DA,.36)):1,'$D(^DIC(8,+^(.36),0)):1,$P(^(0),""^"",1)'[""DOM"":1,1:0) S DGXRF=.361 D ^DGDDC Q" - S X=DE(2),DIC=DIE - K ^DPT("AEL",DA,+X) - S X=DE(2),DIC=DIE - D AUTOUPD^DGENA2(DA) - S X=DE(2),DIIX=2_U_DIFLD D AUDIT^DIET -C2S S X="" G:DG(DQ)=X C2F1 K DB - S X=DG(DQ),DIC=DIE - X "S DFN=DA D EN^DGMTR K DGREQF" - S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 X ^DD(2,.361,1,2,89.4) S Y(102)=$S($D(^DPT(D0,"E",D1,0)):^(0),1:"") S X=$S('$D(^DIC(8,+$P(Y(102),U,1),0)):"",1:$P(^(0),U,1)) S D0=I(0,0) S D1=I(1,0) S DIU=X K Y S X=DIV S X=DIV,X=X X ^DD(2,.361,1,2,1.4) - S X=DG(DQ),DIC=DIE - ; - S X=DG(DQ),DIC=DIE - S ^DPT("AEL",DA,+X)="" - S X=DG(DQ),DIC=DIE - D AUTOUPD^DGENA2(DA) - I $D(DE(2))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET -C2F1 Q -X2 S DFN=DA D EV^DGLOCK I $D(X) D ECD^DGLOCK1 - Q - ; -3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW="TYPE;1",DV="P391'a",DU="",DLB="TYPE",DIFLD=391 - S DE(DW)="C3^A1CKC9",DE(DW,"INDEX")=1 - S DU="DG(391," - S X=DZT2 - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -C3 G C3S:$D(DE(3))[0 K DB - S X=DE(3),DIC=DIE +A1CKC9 ; ;04/21/06 + S X=DE(7),DIC=DIE I ($T(AVAFC^VAFCDD01)'="") S VAFCF="391;" D AVAFC^VAFCDD01(DA) - S X=DE(3),DIIX=2_U_DIFLD D AUDIT^DIET -C3S S X="" G:DG(DQ)=X C3F1 K DB - S X=DG(DQ),DIC=DIE - I ($T(AVAFC^VAFCDD01)'="") S VAFCF="391;" D AVAFC^VAFCDD01(DA) - I $D(DE(3))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET -C3F1 N X,X1,X2 S DIXR=664 D C3X1(U) K X2 M X2=X D C3X1("O") K X1 M X1=X - I $G(X(1))]"" D - . K ^DPT("APTYPE",X,DA) - K X M X=X2 I $G(X(1))]"" D - . S ^DPT("APTYPE",X,DA)="" - G C3F2 -C3X1(DION) K X - S X(1)=$G(@DIEZTMP@("V",2,DIIENS,391,DION),$P($G(^DPT(DA,"TYPE")),U,1)) - S X=$G(X(1)) - Q -C3F2 Q -X3 Q -4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X4 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) - Q -5 S DQ=6 ;@30 -6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X6 I 'SCI S Y="@39" - Q -7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X7 S ISC=0 - Q -8 S DQ=9 ;@31 -9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X9 S ISC=$O(SCI(ISC)) - Q -10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X10 I 'ISC S Y="@39" - Q -11 D:$D(DG)>9 F^DIE17,DE S DQ=11,D=0 K DE(1) ;.3721 - S DIFLD=.3721,DGO="^A1CKC10",DC="6^2.04P^.372^",DV="2.04MP31'X",DW="0;1",DOW="RATED DISABILITIES (VA)",DLB="Select "_DOW S:D DC=DC_D - S DU="DIC(31," - G RE:D I $D(DSC(2.04))#2,$P(DSC(2.04),"I $D(^UTILITY(",1)="" X DSC(2.04) S D=$O(^(0)) S:D="" D=-1 G M11 - S D=$S($D(^DPT(DA,.372,0)):$P(^(0),U,3,4),$O(^(0))'="":$O(^(0)),1:-1) -M11 I D>0 S DC=DC_D I $D(^DPT(DA,.372,+D,0)) S DE(11)=$P(^(0),U,1) - S X="`"_ISC - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -R11 D DE - G A - ; -12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X12 S Y="@31" - Q -13 S DQ=14 ;@39 -14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X14 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) - Q -15 S DQ=16 ;@100 -16 S DW=".3;11",DV="SX",DU="",DLB="RECEIVING VA DISABILITY?",DIFLD=.3025 - S DE(DW)="C16^A1CKC9" - S DU="Y:YES;N:NO;U:UNKNOWN;" - S X=CP - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -C16 G C16S:$D(DE(16))[0 K DB - S X=DE(16),DIC=DIE - X ^DD(2,.3025,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" X ^DD(2,.3025,1,1,2.4) - S X=DE(16),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.3025,1,2,2.4) - S X=DE(16),DIC=DIE - D EVENT^IVMPLOG(DA) -C16S S X="" G:DG(DQ)=X C16F1 K DB - S X=DG(DQ),DIC=DIE - X ^DD(2,.3025,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" X ^DD(2,.3025,1,1,1.4) - S X=DG(DQ),DIC=DIE - K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$TOTCHK^DGLOCK2(DA) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,20),X=X S DIU=X K Y S X="" X ^DD(2,.3025,1,2,1.4) - S X=DG(DQ),DIC=DIE - D EVENT^IVMPLOG(DA) -C16F1 Q -X16 S DFN=DA D MV^DGLOCK I $D(X),X="Y" D EC^DGLOCK1 - Q - ; -17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X17 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) - Q -18 S DQ=19 ;@200 -19 D:$D(DG)>9 F^DIE17,DE S DQ=19,DW=".362;14",DV="SX",DU="",DLB="RECEIVING A VA PENSION?",DIFLD=.36235 - S DE(DW)="C19^A1CKC9" - S DU="Y:YES;N:NO;U:UNKNOWN;" - S X=PE - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -C19 G C19S:$D(DE(19))[0 K DB - D ^A1CKC11 -C19S S X="" G:DG(DQ)=X C19F1 K DB - D ^A1CKC12 -C19F1 Q -X19 S DFN=DA D MV^DGLOCK - Q - ; -20 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=20 D X20 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X20 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) - Q -21 S DQ=22 ;@300 -22 D:$D(DG)>9 F^DIE17,DE S DQ=22,DW=".362;12",DV="SX",DU="",DLB="RECEIVING A&A BENEFITS?",DIFLD=.36205 - S DE(DW)="C22^A1CKC9" - S DU="Y:YES;N:NO;U:UNKNOWN;" - S X=AA - S Y=X - S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) - G RD -C22 G C22S:$D(DE(22))[0 K DB - D ^A1CKC13 -C22S S X="" G:DG(DQ)=X C22F1 K DB - D ^A1CKC14 -C22F1 Q -X22 S DFN=DA D MV^DGLOCK I $D(X) S DFN=DA D EV^DGLOCK - Q - ; -23 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=23 D X23 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 -X23 S Y=$P(STR,"^"),STR=$P(STR,"^",2,99) - Q -24 S DQ=25 ;@400 -25 D:$D(DG)>9 F^DIE17 G ^A1CKC15 + S X=DE(7),DIIX=2_U_DIFLD D AUDIT^DIET diff --git a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGADTP2.m b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGADTP2.m index 87cdee6b..f77e8984 100644 --- a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGADTP2.m +++ b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGADTP2.m @@ -1,116 +1,115 @@ -RGADTP2 ;BIR/DLR-ADT PROCESSOR TO RETRIGGER A08 or A04 MESSAGES WITH AL/AL (COMMIT/APPLICATION) ACKNOWLEDGEMENTS - CONTINUED ;10/30/02 10:04 - ;;1.0;CLINICAL INFO RESOURCE NETWORK;**27,20,45,44,47,48,49,52**;30 Apr 99;Build 2 -DBIA ; - ;Reference to $$ADD^VAFCEHU1 supported by IA #2753 - ;Reference to EDIT^VAFCPTED supported by IA #2784 - Q -PROCIN(ARRAY,RGLOCAL,RGER,DFN,HL) ; - N RGRSDFN,OTHSITE,NODE,ICN,CMORIEN,CMOR,CMORDISP,SENSTVTY,RMTDOD,LOCDOD,VAFCA,VAFCA08,HERE,BOGUS,ARAY,REP - S REP=$E(HL("ECH"),2) - S HERE=$P($$SITE^VASITE,"^",3) - ;if sending site is your site quit - Q:$G(ARRAY("MPISSITE"))=$G(HERE) - S ARRAY(.097)=$P($$NOW^XLFDT,".") - I $G(ARRAY("ICN"))'="" D - .S RGRSDFN=$$GETDFN^MPIF001(+ARRAY("ICN")) I +RGRSDFN<1 S RGER=RGRSDFN_" ICN#"_$G(ARRAY("ICN")) Q ;quit and return error msg - .S OTHSITE=ARRAY("SENDING SITE") ;**40 REMOVED THE PLUS TO KEEP SUFFIX ON STATION# & CHANGED THE SITE TO BE SENDING SITE INSTEAD OF AUTHORITATIVE SOURCE - I $G(RGRSDFN)="" S RGRSDFN=$G(DFN) - I $G(RGRSDFN)="" S RGER="-1^DFN not defined" - Q:$G(RGER) - I $G(OTHSITE)="" S OTHSITE="" - S NODE=$$MPINODE^MPIFAPI(RGRSDFN) - S ICN=$P(NODE,"^") - S CMORIEN=$P(NODE,"^",3) - S CMOR=$$NS^XUAF4(CMORIEN) - S CMORDISP=$P(CMOR,"^",1) - S CMOR=$P(CMOR,"^",2) - ; - ;If patient is Sensitive at other site but not here send bulletin - I $G(ARRAY("SENSITIVITY"))'="" S SENSTVTY=$G(ARRAY("SENSITIVITY")) D - .N NAME S NAME=ARRAY("NAME") - .I '$$SENSTIVE^RGRSENS(RGRSDFN),SENSTVTY D - ..S ARAY("SSN")=ARRAY("SSN"),ARAY("SENDING SITE")=ARRAY("SENDING SITE") - ..S ARAY("SENSITIVITY USER")=ARRAY("SENSITIVITY USER"),ARAY("SENSITIVITY DATE")=ARRAY("SENSITIVITY DATE") - ..D SENSTIVE^RGRSBUL1(RGRSDFN,"ARAY",NAME) - ; - ;MPIC_772 - **52; Commented out Remote Date of Death Indicated section. - ;If patient has DATE OF DEATH (DOD) at remote site send bulletin - ;Ignore time if present with date. - ;S RMTDOD=$G(ARRAY("MPIDOD")),RMTDOD=$P(RMTDOD,".") - ;S DFN=RGRSDFN D DEM^VADPT - ;S LOCDOD=$P($P(VADM(6),"^"),".") - ;If there is a remote DOD but no local DOD OR if remote DOD is different from local DOD, send bulletin - ;I RMTDOD D - ;.N NAME S NAME=ARRAY("NAME"),ARAY("SSN")=ARRAY("SSN"),ARAY("SENDING SITE")=ARRAY("SENDING SITE") - ;.D RMTDOD^RGRSBUL1(RGRSDFN,"ARAY",NAME,RMTDOD,LOCDOD) - ;K VADM - ; -NOTLOC I 'RGLOCAL D - .;if sending site is not the CMOR AND NOT THE MPI - log update into PDR if differences exist **45 ADDED MPI - .I (OTHSITE)'=(CMOR)&(OTHSITE'="200M") D Q - ..S VAFCA=$P($$NOW^XLFDT,".")_"^"_$$NOW^XLFDT_"^"_$G(ARRAY("SENDING SITE"))_"^"_RGRSDFN - ..S ARRAY(.01)=$$FREE^RGRSPARS(ARRAY("NAME")),ARRAY(.03)=$$FREE^RGRSPARS($G(ARRAY("MPIDOB"))) - ..S ARRAY(.09)=$$FREE^RGRSPARS($G(ARRAY("SSN"))),ARRAY(.02)=$$SEX^RGRSPARS($G(ARRAY("SEX"))) - ..S ARRAY(.2403)=$$FREE^RGRSPARS($G(ARRAY("MMN"))),ARRAY(991.01)=$P($G(ARRAY("ICN")),"V") - ..N ARAY M ARAY(2)=ARRAY - ..S VAFCA08=1 ;S BOGUS=$$ADD^VAFCEHU1(VAFCA,"ARAY") comment out by RG*1*49 - .;if sending site is the CMOR OR MPI - synchronize data **45 ADDED MPI AND SSNV TO UPDATED FIELDS - .I (OTHSITE)=(CMOR)!(OTHSITE="200M") D - ..;**44 is there an outstanding edit in the ADT/HL7 PIVOT file for this patient for an identity element - ..S RGER=$$CHKPVT^RGADTP3(.ARRAY) Q:+RGER<0 - ..N DR,ARAY2 S RGER="" - ..D DIFF^RGADTP3(.ARRAY,RGRSDFN,.DR,.ARRAY) ;**47 - ..I DR'="" D - ...S VAFCA08=1,ARAY(2,.01)=ARRAY("NAME"),ARAY(2,.03)=$G(ARRAY("MPIDOB")) - ...I ARRAY("SSN")'="" S ARAY(2,.09)=$G(ARRAY("SSN")) ;**45 only set SSN to update if it isn't null - ...S ARAY(2,.02)=$G(ARRAY("SEX")),ARAY(2,.2403)=$G(ARRAY("MMN")),ARAY(2,994)=$G(ARRAY("MBI")) - ...;**48 ONLY SET SSN VERIFICATION STATUS AND PSEUDO SSN REASON IF SSN UPDATE WAS SUCCESSFUL - ...I $D(ARRAY("ALIAS")) M ARAY(2,1)=ARRAY("ALIAS") ;**48 ADD ALIAS TO MIX - ...D EDIT^VAFCPTED(RGRSDFN,"ARAY(2)",DR) - ...;check to see if edits were successful, if not set RGER="why it failed" - ...N NAME,SSN,PDOB,SEX,MMN,OLDNAME,OLDHLNAM,OLDMMN,OLDHLMMN,HLNAME,HLMMN,SSNV,MBI - ...S NAME=$$GET1^DIQ(2,+RGRSDFN_",",.01,"I"),PDOB=$$GET1^DIQ(2,+RGRSDFN_",",.03,"I") - ...S SSN=$$GET1^DIQ(2,+RGRSDFN_",",.09,"I"),SEX=$$GET1^DIQ(2,+RGRSDFN_",",.02,"I") - ...S MMN=$$GET1^DIQ(2,+RGRSDFN_",",.2403,"I"),MBI=$$GET1^DIQ(2,+RGRSDFN_",",994,"I") - ...D STDNAME^XLFNAME(.NAME,"F",.OLDNAME) S HLNAME=ARRAY("NAME") D STDNAME^XLFNAME(.HLNAME,"F",.OLDHLNAM) - ...I NAME'=$G(HLNAME) S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"Name field failure" - ...I PDOB'=$G(ARRAY("MPIDOB")) S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"DOB field failure" - ...;**48 - ...I SSN["P" D - ....;if pseudo SSN reason field has been added to the DD then attempt to set it - ....N PS,ERROR,LABEL D FIELD^DID(2,.0906,"","LABEL","LABEL","ERROR") I '$D(ERROR("DIERR"))&$D(LABEL("LABEL")) D - .....S ARAY2(2,.0906)=$G(ARRAY(.0906)),DR=".0906;" D EDIT^VAFCPTED(RGRSDFN,"ARAY2(2)",DR) - .....S PS=$$GET1^DIQ(2,+RGRSDFN_",",.0906,"I") - .....I PS=""&(ARAY2(2,.0906)="@") Q - .....I PS'=ARAY2(2,.0906) S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"Pseudo SSN Reason field failure" - .....I PS=ARAY2(2,.0906) D - ......K ARAY2 N ERROR,LABEL D FIELD^DID(2,.0907,"","LABEL","LABEL","ERROR") I '$D(ERROR("DIERR"))&$D(LABEL("LABEL")) D - ......S ARAY2(2,.0907)=$G(ARRAY(.0907)),DR=".0907;" D EDIT^VAFCPTED(RGRSDFN,"ARAY2(2)",DR) - ......S SSNV=$$GET1^DIQ(2,+RGRSDFN_",",.0907,"I") - ......S:$G(ARRAY(.0907))="@" ARRAY(.0907)="" I SSNV'=$G(ARRAY(.0907)) S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"SSN VERIFICATION field failure" - ...I $G(ARRAY("SSN"))'="",SSN'=$G(ARRAY("SSN")) D - ....I $G(ARRAY("SSN"))="P",SSN["P" Q ;**47 NEEDED TO CREATE PSEUDO AND DID - ....S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"SSN field failure" ;**45 only check if SSN is sent isn't null - ...I SSN=$G(ARRAY("SSN")) D - ....;if SSN VERIFICATION STATUS field has been added to the DD then attempt to set it - ....K ARAY2 N ERROR,LABEL D FIELD^DID(2,.0907,"","LABEL","LABEL","ERROR") I '$D(ERROR("DIERR"))&$D(LABEL("LABEL")) D - .....S ARAY2(2,.0907)=$G(ARRAY(.0907)) S DR=".0907;" D EDIT^VAFCPTED(RGRSDFN,"ARAY2(2)",DR) - .....S SSNV=$$GET1^DIQ(2,+RGRSDFN_",",.0907,"I") - .....S:$G(ARRAY(.0907))="@" ARRAY(.0907)="" I SSNV'=$G(ARRAY(.0907)) S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"SSN VERIFICATION field failure" - .....I SSNV'="" D - ......N PS,ERROR,LABEL D FIELD^DID(2,.0906,"","LABEL","LABEL","ERROR") I '$D(ERROR("DIERR"))&$D(LABEL("LABEL")) D - ......S ARAY2(2,.0906)=$G(ARRAY(.0906)) S DR=".0906;" D EDIT^VAFCPTED(RGRSDFN,"ARAY2(2)",DR) - ......S PS=$$GET1^DIQ(2,+RGRSDFN_",",.0906,"I") - ......I PS=""&(ARAY2(2,.0906)="@") Q - ......S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"Pseudo SSN Reason field failure" - ...I SEX'=$G(ARRAY("SEX")) S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"SEX field failure" - ...D STDNAME^XLFNAME(.MMN,"F",.OLDMMN) S HLMMN=ARRAY("MMN") D STDNAME^XLFNAME(.HLMMN,"F",.OLDHLMMN) - ...I MMN'=$G(HLMMN) S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"MOTHER'S MAIDEN NAME field failure" - ...;**REMOVED MBI FROM PATCH 45 PUT BACK IN **47 - ...I MBI'=$G(ARRAY("MBI")) D - ....Q:MBI=""&($G(ARRAY("MBI"))="@") ;**47 "" AND @ ARE THE SAME - ....S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"MULTIPLE BIRTH INDICATOR field failure" - ...;send the updated fields to the MPI to synch site with MPI - ...I HL("ETN")'="A31" S ZTSAVE("DFN")="",ZTRTN="MPISYN^RGADTPC",ZTDESC="Sending Synchronized Patient Data to MPI...",ZTIO="RG QUEUE",ZTDTH=$H D ^%ZTLOAD - ...;**45 ^ don't trigger A31 sync message if A31 was being processed-- ack to a31 will sync id elements on MPI - Q +RGADTP2 ;BIR/DLR-ADT PROCESSOR TO RETRIGGER A08 or A04 MESSAGES WITH AL/AL (COMMIT/APPLICATION) ACKNOWLEDGEMENTS - CONTINUED ;10/30/02 10:04 + ;;1.0;CLINICAL INFO RESOURCE NETWORK;**27,20,45,44,47,48**;30 Apr 99;Build 3 +DBIA ; + ;Reference to $$ADD^VAFCEHU1 supported by IA #2753 + ;Reference to EDIT^VAFCPTED supported by IA #2784 + Q +PROCIN(ARRAY,RGLOCAL,RGER,DFN,HL) ; + N RGRSDFN,OTHSITE,NODE,ICN,CMORIEN,CMOR,CMORDISP,SENSTVTY,RMTDOD,LOCDOD,VAFCA,VAFCA08,HERE,BOGUS,ARAY,REP + S REP=$E(HL("ECH"),2) + S HERE=$P($$SITE^VASITE,"^",3) + ;if sending site is your site quit + Q:$G(ARRAY("MPISSITE"))=$G(HERE) + S ARRAY(.097)=$P($$NOW^XLFDT,".") + I $G(ARRAY("ICN"))'="" D + .S RGRSDFN=$$GETDFN^MPIF001(+ARRAY("ICN")) I +RGRSDFN<1 S RGER=RGRSDFN_" ICN#"_$G(ARRAY("ICN")) Q ;quit and return error msg + .S OTHSITE=ARRAY("SENDING SITE") ;**40 REMOVED THE PLUS TO KEEP SUFFIX ON STATION# & CHANGED THE SITE TO BE SENDING SITE INSTEAD OF AUTHORITATIVE SOURCE + I $G(RGRSDFN)="" S RGRSDFN=$G(DFN) + I $G(RGRSDFN)="" S RGER="-1^DFN not defined" + Q:$G(RGER) + I $G(OTHSITE)="" S OTHSITE="" + S NODE=$$MPINODE^MPIFAPI(RGRSDFN) + S ICN=$P(NODE,"^") + S CMORIEN=$P(NODE,"^",3) + S CMOR=$$NS^XUAF4(CMORIEN) + S CMORDISP=$P(CMOR,"^",1) + S CMOR=$P(CMOR,"^",2) + ; + ;If patient is Sensitive at other site but not here send bulletin + I $G(ARRAY("SENSITIVITY"))'="" S SENSTVTY=$G(ARRAY("SENSITIVITY")) D + .N NAME S NAME=ARRAY("NAME") + .I '$$SENSTIVE^RGRSENS(RGRSDFN),SENSTVTY D + ..S ARAY("SSN")=ARRAY("SSN"),ARAY("SENDING SITE")=ARRAY("SENDING SITE") + ..S ARAY("SENSITIVITY USER")=ARRAY("SENSITIVITY USER"),ARAY("SENSITIVITY DATE")=ARRAY("SENSITIVITY DATE") + ..D SENSTIVE^RGRSBUL1(RGRSDFN,"ARAY",NAME) + ; + ;If patient has DATE OF DEATH (DOD) at remote site send bulletin + ;Ignore time if present with date. + S RMTDOD=$G(ARRAY("MPIDOD")),RMTDOD=$P(RMTDOD,".") + S DFN=RGRSDFN D DEM^VADPT + S LOCDOD=$P($P(VADM(6),"^"),".") + ;If there is a remote DOD but no local DOD OR if remote DOD is different from local DOD, send bulletin + I RMTDOD D + .N NAME S NAME=ARRAY("NAME"),ARAY("SSN")=ARRAY("SSN"),ARAY("SENDING SITE")=ARRAY("SENDING SITE") + .D RMTDOD^RGRSBUL1(RGRSDFN,"ARAY",NAME,RMTDOD,LOCDOD) + K VADM + ; +NOTLOC I 'RGLOCAL D + .;if sending site is not the CMOR AND NOT THE MPI - log update into PDR if differences exist **45 ADDED MPI + .I (OTHSITE)'=(CMOR)&(OTHSITE'="200M") D Q + ..S VAFCA=$P($$NOW^XLFDT,".")_"^"_$$NOW^XLFDT_"^"_$G(ARRAY("SENDING SITE"))_"^"_RGRSDFN + ..S ARRAY(.01)=$$FREE^RGRSPARS(ARRAY("NAME")),ARRAY(.03)=$$FREE^RGRSPARS($G(ARRAY("MPIDOB"))) + ..S ARRAY(.09)=$$FREE^RGRSPARS($G(ARRAY("SSN"))),ARRAY(.02)=$$SEX^RGRSPARS($G(ARRAY("SEX"))) + ..S ARRAY(.2403)=$$FREE^RGRSPARS($G(ARRAY("MMN"))),ARRAY(991.01)=$P($G(ARRAY("ICN")),"V") + ..N ARAY M ARAY(2)=ARRAY + ..S VAFCA08=1 S BOGUS=$$ADD^VAFCEHU1(VAFCA,"ARAY") + .;if sending site is the CMOR OR MPI - synchronize data **45 ADDED MPI AND SSNV TO UPDATED FIELDS + .I (OTHSITE)=(CMOR)!(OTHSITE="200M") D + ..;**44 is there an outstanding edit in the ADT/HL7 PIVOT file for this patient for an identity element + ..S RGER=$$CHKPVT^RGADTP3(.ARRAY) Q:+RGER<0 + ..N DR,ARAY2 S RGER="" + ..D DIFF^RGADTP3(.ARRAY,RGRSDFN,.DR,.ARRAY) ;**47 + ..I DR'="" D + ...S VAFCA08=1,ARAY(2,.01)=ARRAY("NAME"),ARAY(2,.03)=$G(ARRAY("MPIDOB")) + ...I ARRAY("SSN")'="" S ARAY(2,.09)=$G(ARRAY("SSN")) ;**45 only set SSN to update if it isn't null + ...S ARAY(2,.02)=$G(ARRAY("SEX")),ARAY(2,.2403)=$G(ARRAY("MMN")),ARAY(2,994)=$G(ARRAY("MBI")) + ...;**48 ONLY SET SSN VERIFICATION STATUS AND PSEUDO SSN REASON IF SSN UPDATE WAS SUCCESSFUL + ...I $D(ARRAY("ALIAS")) M ARAY(2,1)=ARRAY("ALIAS") ;**48 ADD ALIAS TO MIX + ...D EDIT^VAFCPTED(RGRSDFN,"ARAY(2)",DR) + ...;check to see if edits were successful, if not set RGER="why it failed" + ...N NAME,SSN,PDOB,SEX,MMN,OLDNAME,OLDHLNAM,OLDMMN,OLDHLMMN,HLNAME,HLMMN,SSNV,MBI + ...S NAME=$$GET1^DIQ(2,+RGRSDFN_",",.01,"I"),PDOB=$$GET1^DIQ(2,+RGRSDFN_",",.03,"I") + ...S SSN=$$GET1^DIQ(2,+RGRSDFN_",",.09,"I"),SEX=$$GET1^DIQ(2,+RGRSDFN_",",.02,"I") + ...S MMN=$$GET1^DIQ(2,+RGRSDFN_",",.2403,"I"),MBI=$$GET1^DIQ(2,+RGRSDFN_",",994,"I") + ...D STDNAME^XLFNAME(.NAME,"F",.OLDNAME) S HLNAME=ARRAY("NAME") D STDNAME^XLFNAME(.HLNAME,"F",.OLDHLNAM) + ...I NAME'=$G(HLNAME) S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"Name field failure" + ...I PDOB'=$G(ARRAY("MPIDOB")) S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"DOB field failure" + ...;**48 + ...I SSN["P" D + ....;if pseudo SSN reason field has been added to the DD then attempt to set it + ....N PS,ERROR,LABEL D FIELD^DID(2,.0906,"","LABEL","LABEL","ERROR") I '$D(ERROR("DIERR"))&$D(LABEL("LABEL")) D + .....S ARAY2(2,.0906)=$G(ARRAY(.0906)),DR=".0906;" D EDIT^VAFCPTED(RGRSDFN,"ARAY2(2)",DR) + .....S PS=$$GET1^DIQ(2,+RGRSDFN_",",.0906,"I") + .....I PS=""&(ARAY2(2,.0906)="@") Q + .....I PS'=ARAY2(2,.0906) S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"Pseudo SSN Reason field failure" + .....I PS=ARAY2(2,.0906) D + ......K ARAY2 N ERROR,LABEL D FIELD^DID(2,.0907,"","LABEL","LABEL","ERROR") I '$D(ERROR("DIERR"))&$D(LABEL("LABEL")) D + ......S ARAY2(2,.0907)=$G(ARRAY(.0907)),DR=".0907;" D EDIT^VAFCPTED(RGRSDFN,"ARAY2(2)",DR) + ......S SSNV=$$GET1^DIQ(2,+RGRSDFN_",",.0907,"I") + ......S:$G(ARRAY(.0907))="@" ARRAY(.0907)="" I SSNV'=$G(ARRAY(.0907)) S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"SSN VERIFICATION field failure" + ...I $G(ARRAY("SSN"))'="",SSN'=$G(ARRAY("SSN")) D + ....I $G(ARRAY("SSN"))="P",SSN["P" Q ;**47 NEEDED TO CREATE PSEUDO AND DID + ....S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"SSN field failure" ;**45 only check if SSN is sent isn't null + ...I SSN=$G(ARRAY("SSN")) D + ....;if SSN VERIFICATION STATUS field has been added to the DD then attempt to set it + ....K ARAY2 N ERROR,LABEL D FIELD^DID(2,.0907,"","LABEL","LABEL","ERROR") I '$D(ERROR("DIERR"))&$D(LABEL("LABEL")) D + .....S ARAY2(2,.0907)=$G(ARRAY(.0907)) S DR=".0907;" D EDIT^VAFCPTED(RGRSDFN,"ARAY2(2)",DR) + .....S SSNV=$$GET1^DIQ(2,+RGRSDFN_",",.0907,"I") + .....S:$G(ARRAY(.0907))="@" ARRAY(.0907)="" I SSNV'=$G(ARRAY(.0907)) S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"SSN VERIFICATION field failure" + .....I SSNV'="" D + ......N PS,ERROR,LABEL D FIELD^DID(2,.0906,"","LABEL","LABEL","ERROR") I '$D(ERROR("DIERR"))&$D(LABEL("LABEL")) D + ......S ARAY2(2,.0906)=$G(ARRAY(.0906)) S DR=".0906;" D EDIT^VAFCPTED(RGRSDFN,"ARAY2(2)",DR) + ......S PS=$$GET1^DIQ(2,+RGRSDFN_",",.0906,"I") + ......I PS=""&(ARAY2(2,.0906)="@") Q + ......S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"Pseudo SSN Reason field failure" + ...I SEX'=$G(ARRAY("SEX")) S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"SEX field failure" + ...D STDNAME^XLFNAME(.MMN,"F",.OLDMMN) S HLMMN=ARRAY("MMN") D STDNAME^XLFNAME(.HLMMN,"F",.OLDHLMMN) + ...I MMN'=$G(HLMMN) S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"MOTHER'S MAIDEN NAME field failure" + ...;**REMOVED MBI FROM PATCH 45 PUT BACK IN **47 + ...I MBI'=$G(ARRAY("MBI")) D + ....Q:MBI=""&($G(ARRAY("MBI"))="@") ;**47 "" AND @ ARE THE SAME + ....S RGER=$S($G(RGER)'="":$G(RGER)_REP,1:"-1^")_"MULTIPLE BIRTH INDICATOR field failure" + ...;send the updated fields to the MPI to synch site with MPI + ...I HL("ETN")'="A31" S ZTSAVE("DFN")="",ZTRTN="MPISYN^RGADTPC",ZTDESC="Sending Synchronized Patient Data to MPI...",ZTIO="RG QUEUE",ZTDTH=$H D ^%ZTLOAD + ...;**45 ^ don't trigger A31 sync message if A31 was being processed-- ack to a31 will sync id elements on MPI + Q diff --git a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGHLLOG.m b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGHLLOG.m index 986eaa5b..b85608e2 100644 --- a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGHLLOG.m +++ b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGHLLOG.m @@ -1,152 +1,150 @@ -RGHLLOG ;CAIRO/DKM-LOG MESSAGE PROCESSING INFO ;09/04/98 - ;;1.0;CLINICAL INFO RESOURCE NETWORK;**1,3,11,13,18,19,25,45,52**;30 Apr 99;Build 2 - ; - ;Reference to ^HLMA("C" supported by IA #3244 - ;================================================================= - ; Log information about message processing and exceptions - ; in CIRN HL7 Exception Log file. - ;================================================================= - ; Start time for run log -START(RGMSG,RGDC,RGPARAM) ; - ;This entry point starts the log process in the CIRN HL7 EXCEPTION LOG - ;file (#991.1), if the (#6) MINIMAL EXCEPTION LOGGING? field in - ;File #990.8 is set to 0. - ; Input: Required - ; RGMSG - IEN of message entry in File #773, usually HLMTIEN - ; Optional - ; RGDC - Event Class, associated with an entry in File # - ; RGPARAM - reprocessing routine - S U="^" - K RGLOG - S RGLOG(3)=$G(RGMSG),RGLOG(5)=$G(RGDC),RGLOG(4)=$G(RGPARAM),RGLOG(1)=$$NOW^XLFDT - I '$P(^RGSITE("COR",1,0),U,8) S RGLOG=$$CREATE - Q - ; Create a log entry -CREATE() Q:$G(RGLOG) RGLOG - L +^RGHL7(991.1,0):10 - S RGLOG=$O(^RGHL7(991.1,$C(32)),-1)+1 - S:$G(RGLOG(1))="" RGLOG(1)=$$NOW^XLFDT - S RGLOG(3)=$S($G(RGLOG(3))=0:0,$G(HL("MID"))="":"",1:$$IEN773($G(HL("MID")))) - S (DA,X)=RGLOG,DIC="^RGHL7(991.1,",DIC(0)="L",DLAYGO=991.1,DIC("DR")="1///"_$G(RGLOG(1))_";3////"_$G(RGLOG(3))_";5///"_$G(RGLOG(5))_";4////"_$G(RGLOG(4)) K DD,DO D FILE^DICN K DIC,DA,X,DLAYGO - L -^RGHL7(991.1,0) - Q RGLOG - ; Log time run completed -STOP(RGQUIT) ; - ;This entry point completes the logging process - ; Input: required - ; RGQUIT - 0 for success and 1 for failure - ; - Q:'$G(RGLOG) - L +^RGHL7(991.1,RGLOG):10 - S DIE="^RGHL7(991.1,",DR="1.5///NOW;1.6///^S X=$G(RGQUIT)",DA=RGLOG D ^DIE K DIE,DA,DR - L -^RGHL7(991.1,RGLOG) - K RGLOG,RGQUIT,X,Y,DIC,DIE - Q - ; Log unclassified exception (old entry point) -ERR(RGERR,RGSEV) ; - D EXC(18,RGERR) - S RGQUIT=$G(RGQUIT)!$G(RGSEV) - Q - ; Log an exception -EXC(RGEXC,RGERR,RGDFN,MSGID,STATNUM) ; - ;This entry point logs exceptions in the CIRN HL7 EXCEPTION LOG - ;file (#991.1) - ; Input: Required - ; RGEXC - Exception type in File #991.11 - ; RGERR - Supplemental text - ; Optional - ; RGDFN - IEN in the PATIENT file (#2) - ; MSGID - message id of the HL7 message where the exception was encountered (optional) - ; STATNUM - station # of site that encountered the error (optional) - if not defined then the local site is assumed, using $$SITE^VASITE - ; - I (RGEXC=215)!(RGEXC=216)!(RGEXC=217) Q ;**52 until MPIFBT3 call eliminates these exception types - I $L($G(HL("MID"))) Q:$$INVEXC(HL("MID")) ; is the exception valid? - N RGI,RGZ - S U="^" - S:RGEXC[U RGERR=$P(RGEXC,U,2,999),RGEXC=+RGEXC - S:RGEXC'=+RGEXC RGERR=RGEXC,RGEXC=18 - S:'$D(^RGHL7(991.11,RGEXC)) RGEXC=18 - L +^RGHL7(991.11,RGEXC):10 - S RGZ=$G(^RGHL7(991.11,RGEXC,0)) - S:$L(RGZ) $P(^RGHL7(991.11,RGEXC,0),U,5)=$P(RGZ,U,5)+1 - S:$P(RGZ,U,2)>1 RGQUIT=1 - L -^RGHL7(991.11,RGEXC) - S RGLOG=$$CREATE - L +^RGHL7(991.1,RGLOG):10 - S RGI=$O(^RGHL7(991.1,RGLOG,1,$C(32)),-1)+1 - S RGERR=$E($G(RGERR),1,250) - S DIC="^RGHL7(991.1,"_RGLOG_",1," - S X=RGI,DA(1)=RGLOG,DIC(0)="FL",DLAYGO=991.12,DIC("P")=$P(^DD(991.1,2,0),"^",2) - D ^DIC - S DIE=DIC - K DIC,DA,DR,DLAYGO - S STAT=0 - S DIC="3.8",DIC(0)="Z",X="MPIF EXCEPTIONS" D ^DIC K DIC - S RGMG=$P($G(Y),"^",1) - I $P(^RGHL7(991.11,RGEXC,0),U,4)=RGMG S STAT=1 - S DA(1)=RGLOG,DA=RGI,DR="2///"_$G(RGEXC)_";3///"_$S($G(RGDFN):"`"_RGDFN,1:"")_";6///"_$G(STAT)_";10///"_$G(RGERR) - D ^DIE K DIE,DA,DR - L -^RGHL7(991.1,RGLOG) - S RGI=$P(RGZ,U,3),RGZ=$P(RGZ,U,4) - ; - ;If the action type is for the MPI Exception Handler, send exception to the handler and quit - I (RGI=3) D SENDMPI^RGHLLOG1($G(RGEXC),$G(RGERR),$G(RGDFN),$G(MSGID),$G(STATNUM)) Q - ; - Q:'RGI!'RGZ - ;quit and don't send messages for exception types that are now being - ;handled through the MPI/PD Exception Handling option. - Q:RGEXC=234!(RGEXC=218) ;MPIC_772; **52 remove 215, 216, and 217 - S DIC="^XMB(3.8,",DIC(0)="NZ",X="`"_RGZ D ^DIC K DIC Q:+Y<1 S RGZ=$P(Y,U,2) K Y - Q:RGZ=""!$P($G(^RGSITE("COR",1,0)),U,7) - S RGERR=$$SHORT(RGEXC,RGERR),RGZ="G."_RGZ - I RGI=2 D ALERT^RGRSUTL2(RGERR,RGZ) Q - D MAIL^RGRSUTL2(RGERR,RGZ,"MPI/PD Exception: "_$$SHORT(RGEXC),"MPI/PD exception notification") - Q - ; -INVEXC(RGMID) ; determine if this exception needs to be sent to MPI/PD - ; personnel via FORUM. Return 1 to avoid messaging to FORUM, else 0. - ; IA#:3244 is applied in this functionality - N RGFLG,RGIEN S RGFLG=1 - S RGIEN=$$IEN773(RGMID) Q:'RGIEN RGFLG - S RGIEN("SND")=$$GET1^DIQ(773,RGIEN_",",13) - S RGIEN("REC")=$$GET1^DIQ(773,RGIEN_",",14) - ; check the sending application (fld:13, 0;11) & the receiving - ; application (fld:14, 0;12) to see if they are related to the MPI/PD - ; project. - I RGIEN("SND")]""!(RGIEN("REC")]"") D Q RGFLG - .S RGFLG=$$APP(RGIEN("SND")) Q:'RGFLG - .S RGFLG=$$APP(RGIEN("REC")) - .Q - ; Only if the sending/receiving applications cannot be determined from - ; the data in their respective fields, do I check the MSH multiple for - ; the MSH segment. I identify the sending/receiving application from - ; this segment. - E D - .N RG,RG1,RGMSH,RGFS - .D GETS^DIQ(773,RGIEN_",",200,,"RGMSH") ;check MSH mult for snd/rec app - .Q:'($D(RGMSH)\10) ; no data in "MSH" multiple for file 773 - .S RGIEN=RGIEN_",",RG="RGMSH(773,"""_RGIEN_""","_200_")" - .S RG1=0 F S RG1=$O(@RG@(RG1)) Q:RG1'>0 D Q:$E($G(@RG@(RG1)),1,3)="MSH" - ..I $E($G(@RG@(RG1)),1,3)="MSH" D - ...S RG(0)=$G(@RG@(RG1)),RGFS=$E(RG(0),4) - ...S:$P(RG(0),RGFS,3)]"" RGFLG=$$APP($P(RG(0),RGFS,3)) Q:'RGFLG - ...S:$P(RG(0),RGFS,5)]"" RGFLG=$$APP($P(RG(0),RGFS,5)) - ...Q - ..Q - .Q - Q RGFLG -APP(X) ; check if the sending/receiving application is relevant to the - ; MPI/PD team. Returns 1 if a non-relevant namespace, else 0 - I $E(X,1,2)="RG"!($E(X,1,2)="VA")!($E(X,1,3)="MPI") Q 0 - Q 1 - ; -IEN773(RGMID) ; find the ien of the record in the HL7 MESSAGE ADMINISTRATION - ; (#773) file based on the Message ID. Input: Message ID - ; Output: null, no record in 773, else 773 record ien. IA#: 3244 - Q:$G(RGMID)="" "" - Q $O(^HLMA("C",RGMID,0)) - ; -SHORT(RGEXC,RGTXT) ; - ; Retrieve short text description of exception - Q $G(^RGHL7(991.11,+RGEXC,10))_$S($G(RGTXT)="":"",1:": "_RGTXT) - ; +RGHLLOG ;CAIRO/DKM-LOG MESSAGE PROCESSING INFO ;09/04/98 + ;;1.0;CLINICAL INFO RESOURCE NETWORK;**1,3,11,13,18,19,25,45**;30 Apr 99;Build 9 + ;Reference to ^HLMA("C" supported by IA #3244 + ;================================================================= + ; Log information about message processing and exceptions + ; in CIRN HL7 Exception Log file. + ;================================================================= + ; Start time for run log +START(RGMSG,RGDC,RGPARAM) ; + ;This entry point starts the log process in the CIRN HL7 EXCEPTION LOG + ;file (#991.1), if the (#6) MINIMAL EXCEPTION LOGGING? field in + ;File #990.8 is set to 0. + ; Input: Required + ; RGMSG - IEN of message entry in File #773, usually HLMTIEN + ; Optional + ; RGDC - Event Class, associated with an entry in File # + ; RGPARAM - reprocessing routine + S U="^" + K RGLOG + S RGLOG(3)=$G(RGMSG),RGLOG(5)=$G(RGDC),RGLOG(4)=$G(RGPARAM),RGLOG(1)=$$NOW^XLFDT + I '$P(^RGSITE("COR",1,0),U,8) S RGLOG=$$CREATE + Q + ; Create a log entry +CREATE() Q:$G(RGLOG) RGLOG + L +^RGHL7(991.1,0):10 + S RGLOG=$O(^RGHL7(991.1,$C(32)),-1)+1 + S:$G(RGLOG(1))="" RGLOG(1)=$$NOW^XLFDT + S RGLOG(3)=$S($G(RGLOG(3))=0:0,$G(HL("MID"))="":"",1:$$IEN773($G(HL("MID")))) + S (DA,X)=RGLOG,DIC="^RGHL7(991.1,",DIC(0)="L",DLAYGO=991.1,DIC("DR")="1///"_$G(RGLOG(1))_";3////"_$G(RGLOG(3))_";5///"_$G(RGLOG(5))_";4////"_$G(RGLOG(4)) K DD,DO D FILE^DICN K DIC,DA,X,DLAYGO + L -^RGHL7(991.1,0) + Q RGLOG + ; Log time run completed +STOP(RGQUIT) ; + ;This entry point completes the logging process + ; Input: required + ; RGQUIT - 0 for success and 1 for failure + ; + Q:'$G(RGLOG) + L +^RGHL7(991.1,RGLOG):10 + S DIE="^RGHL7(991.1,",DR="1.5///NOW;1.6///^S X=$G(RGQUIT)",DA=RGLOG D ^DIE K DIE,DA,DR + L -^RGHL7(991.1,RGLOG) + K RGLOG,RGQUIT,X,Y,DIC,DIE + Q + ; Log unclassified exception (old entry point) +ERR(RGERR,RGSEV) ; + D EXC(18,RGERR) + S RGQUIT=$G(RGQUIT)!$G(RGSEV) + Q + ; Log an exception +EXC(RGEXC,RGERR,RGDFN,MSGID,STATNUM) ; + ;This entry point logs exceptions in the CIRN HL7 EXCEPTION LOG + ;file (#991.1) + ; Input: Required + ; RGEXC - Exception type in File #991.11 + ; RGERR - Supplemental text + ; Optional + ; RGDFN - IEN in the PATIENT file (#2) + ; MSGID - message id of the HL7 message where the exception was encountered (optional) + ; STATNUM - station # of site that encountered the error (optional) - if not defined then the local site is assumed, using $$SITE^VASITE + ; + I $L($G(HL("MID"))) Q:$$INVEXC(HL("MID")) ; is the exception valid? + N RGI,RGZ + S U="^" + S:RGEXC[U RGERR=$P(RGEXC,U,2,999),RGEXC=+RGEXC + S:RGEXC'=+RGEXC RGERR=RGEXC,RGEXC=18 + S:'$D(^RGHL7(991.11,RGEXC)) RGEXC=18 + L +^RGHL7(991.11,RGEXC):10 + S RGZ=$G(^RGHL7(991.11,RGEXC,0)) + S:$L(RGZ) $P(^RGHL7(991.11,RGEXC,0),U,5)=$P(RGZ,U,5)+1 + S:$P(RGZ,U,2)>1 RGQUIT=1 + L -^RGHL7(991.11,RGEXC) + S RGLOG=$$CREATE + L +^RGHL7(991.1,RGLOG):10 + S RGI=$O(^RGHL7(991.1,RGLOG,1,$C(32)),-1)+1 + S RGERR=$E($G(RGERR),1,250) + S DIC="^RGHL7(991.1,"_RGLOG_",1," + S X=RGI,DA(1)=RGLOG,DIC(0)="FL",DLAYGO=991.12,DIC("P")=$P(^DD(991.1,2,0),"^",2) + D ^DIC + S DIE=DIC + K DIC,DA,DR,DLAYGO + S STAT=0 + S DIC="3.8",DIC(0)="Z",X="MPIF EXCEPTIONS" D ^DIC K DIC + S RGMG=$P($G(Y),"^",1) + I $P(^RGHL7(991.11,RGEXC,0),U,4)=RGMG S STAT=1 + S DA(1)=RGLOG,DA=RGI,DR="2///"_$G(RGEXC)_";3///"_$S($G(RGDFN):"`"_RGDFN,1:"")_";6///"_$G(STAT)_";10///"_$G(RGERR) + D ^DIE K DIE,DA,DR + L -^RGHL7(991.1,RGLOG) + S RGI=$P(RGZ,U,3),RGZ=$P(RGZ,U,4) + ; + ;If the action type is for the MPI Exception Handler, send exception to the handler and quit + I (RGI=3) D SENDMPI^RGHLLOG1($G(RGEXC),$G(RGERR),$G(RGDFN),$G(MSGID),$G(STATNUM)) Q + ; + Q:'RGI!'RGZ + ;quit and don't send messages for exception types that are now being + ;handled through the MPI/PD Exception Handling option. + Q:RGEXC=234!((RGEXC>214)&(RGEXC<219)) + S DIC="^XMB(3.8,",DIC(0)="NZ",X="`"_RGZ D ^DIC K DIC Q:+Y<1 S RGZ=$P(Y,U,2) K Y + Q:RGZ=""!$P($G(^RGSITE("COR",1,0)),U,7) + S RGERR=$$SHORT(RGEXC,RGERR),RGZ="G."_RGZ + I RGI=2 D ALERT^RGRSUTL2(RGERR,RGZ) Q + D MAIL^RGRSUTL2(RGERR,RGZ,"MPI/PD Exception: "_$$SHORT(RGEXC),"MPI/PD exception notification") + Q + ; +INVEXC(RGMID) ; determine if this exception needs to be sent to MPI/PD + ; personnel via FORUM. Return 1 to avoid messaging to FORUM, else 0. + ; IA#:3244 is applied in this functionality + N RGFLG,RGIEN S RGFLG=1 + S RGIEN=$$IEN773(RGMID) Q:'RGIEN RGFLG + S RGIEN("SND")=$$GET1^DIQ(773,RGIEN_",",13) + S RGIEN("REC")=$$GET1^DIQ(773,RGIEN_",",14) + ; check the sending application (fld:13, 0;11) & the receiving + ; application (fld:14, 0;12) to see if they are related to the MPI/PD + ; project. + I RGIEN("SND")]""!(RGIEN("REC")]"") D Q RGFLG + .S RGFLG=$$APP(RGIEN("SND")) Q:'RGFLG + .S RGFLG=$$APP(RGIEN("REC")) + .Q + ; Only if the sending/receiving applications cannot be determined from + ; the data in their respective fields, do I check the MSH multiple for + ; the MSH segment. I identify the sending/receiving application from + ; this segment. + E D + .N RG,RG1,RGMSH,RGFS + .D GETS^DIQ(773,RGIEN_",",200,,"RGMSH") ;check MSH mult for snd/rec app + .Q:'($D(RGMSH)\10) ; no data in "MSH" multiple for file 773 + .S RGIEN=RGIEN_",",RG="RGMSH(773,"""_RGIEN_""","_200_")" + .S RG1=0 F S RG1=$O(@RG@(RG1)) Q:RG1'>0 D Q:$E($G(@RG@(RG1)),1,3)="MSH" + ..I $E($G(@RG@(RG1)),1,3)="MSH" D + ...S RG(0)=$G(@RG@(RG1)),RGFS=$E(RG(0),4) + ...S:$P(RG(0),RGFS,3)]"" RGFLG=$$APP($P(RG(0),RGFS,3)) Q:'RGFLG + ...S:$P(RG(0),RGFS,5)]"" RGFLG=$$APP($P(RG(0),RGFS,5)) + ...Q + ..Q + .Q + Q RGFLG +APP(X) ; check if the sending/receiving application is relevant to the + ; MPI/PD team. Returns 1 if a non-relevant namespace, else 0 + I $E(X,1,2)="RG"!($E(X,1,2)="VA")!($E(X,1,3)="MPI") Q 0 + Q 1 + ; +IEN773(RGMID) ; find the ien of the record in the HL7 MESSAGE ADMINISTRATION + ; (#773) file based on the Message ID. Input: Message ID + ; Output: null, no record in 773, else 773 record ien. IA#: 3244 + Q:$G(RGMID)="" "" + Q $O(^HLMA("C",RGMID,0)) + ; +SHORT(RGEXC,RGTXT) ; + ; Retrieve short text description of exception + Q $G(^RGHL7(991.11,+RGEXC,10))_$S($G(RGTXT)="":"",1:": "_RGTXT) + ; diff --git a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGMTETOT.m b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGMTETOT.m index 729c8ad8..730569e3 100644 --- a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGMTETOT.m +++ b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGMTETOT.m @@ -1,135 +1,139 @@ -RGMTETOT ;BIR/CML-Compile Totals for Site Exceptions ;11/15/01 - ;;1.0;CLINICAL INFO RESOURCE NETWORK;**20,30,43,45,52**;30 Apr 99;Build 2 - ; - ;Reference to ^DPT("AICNL" supported by IA #2070 - ; - ;Variable RGHLMQ cannot be killed in this routine, it is needed for the remote query - ; - ;Use this routine to compile totals of a site's exceptions in file #991.1 - S DUMP=0 G START - ; -DUMP1 ;Use this call to dump all data in ascii format for table - S DUMP=1 G START - ; -DUMP2 ;Use this call to dump data in ascii format for table - just for exceptions sites have to deal with - S DUMP=2 - ; -START ; - ;do purge of any dups for POTENTIAL MATCH Exceptions - K TYPEARR,^XTMP("RGMT","HLMQETOT") - S ^XTMP("RGMT",0)=$$FMADD^XLFDT(DT,30)_"^"_$$NOW^XLFDT_"^MPI/PD Maintenance Data" - D PURGE - ;create type array from file 991.11 - S TYPE=233 F S TYPE=$O(^RGHL7(991.11,TYPE)) Q:'TYPE I TYPE'=218 S TYPEARR(TYPE)=0 ;MPIC_772; **52 remove 215, 216, and 217 - ; - ;start loop - S TYPE=233 F S TYPE=$O(^RGHL7(991.1,"AC",TYPE)) Q:'TYPE D ;MPIC_772; **52 remove 215, 216, and 217 - .Q:TYPE=218 - .S IEN1=0 F S IEN1=$O(^RGHL7(991.1,"AC",TYPE,IEN1)) Q:'IEN1 D - ..S IEN2=0 F S IEN2=$O(^RGHL7(991.1,"AC",TYPE,IEN1,IEN2)) Q:'IEN2 D - ...I '$D(^RGHL7(991.1,IEN1,1,IEN2,0)) Q - ...S STAT=$P(^RGHL7(991.1,IEN1,1,IEN2,0),"^",5) I STAT<1 S TYPEARR(TYPE)=TYPEARR(TYPE)+1 - ; -PRT ; - S GRAND=0 - S SITENM=$P($$SITE^VASITE(),"^",2),$P(LN,"-",81)="" - D NOW^%DTC S RUNDT=$$FMTE^XLFDT($E(%,1,12)) - ; -PRT0 I 'DUMP D - .W !!,"Exception Totals for ",SITENM - .W !,"Printed ",RUNDT,!,LN - .S TYPE=0 F S TYPE=$O(TYPEARR(TYPE)) Q:'TYPE I +TYPEARR(TYPE) D - ..S GRAND=GRAND+TYPEARR(TYPE) - ..W !!,"TYPE: ",TYPE,?12,$P($T(@TYPE),";;",2),?67,"TOTAL = ",$J(TYPEARR(TYPE),4) - ..W !,"DESCRIPTION:" - ..S TXT=0 F S TXT=$O(^RGHL7(991.11,TYPE,99,TXT)) Q:'TXT W !,^RGHL7(991.11,TYPE,99,TXT,0) - .W !!?56,"TOTAL EXCEPTIONS: ",$J(GRAND,5) - ; -PRT1 I DUMP=1 D - .W !!,"At this point it is necessary for you to increase the right margin." - .W !,"At the DEVICE prompt enter=> ;255" - .W ! D ^%ZIS I POP W !,"DOWNLOAD ABORTED!" Q - .W !!,"Data string=Site;Run Date;Date CIRN Installed;Exceptions 218 & 234" ;MPIC_772; **52 remove 215, 216, and 217 - .S STR=SITENM_";"_RUNDT_";" - .S TYPE=0 F S TYPE=$O(TYPEARR(TYPE)) Q:'TYPE D - ..S STR=STR_";"_TYPEARR(TYPE) - .W !!,STR - ; -PRT2 I DUMP=2 D - .S ICN=0,LOCCNT=0 F S ICN=$O(^DPT("AICNL",1,ICN)) Q:'ICN S LOCCNT=LOCCNT+1 - .S SITEIEN=+$$SITE^VASITE(),STANUM=$P($$SITE^VASITE(),"^",3) - .I '$D(RGHLMQ) W !!,"Data string:" - .I '$D(RGHLMQ) W !,"Site;Sta#;;;LocICNs,218,234" ;MPIC_772; **52 remove 215, 216, and 217 - .S STR=SITENM_";"_STANUM_";;;"_LOCCNT - .F TYPE=218,234 S STR=STR_";"_TYPEARR(TYPE) ;MPIC_772; **52 remove 215, 216, and 217 - .I '$D(RGHLMQ) W !!,STR - .I $D(RGHLMQ) S ^XTMP("RGMT","HLMQETOT",STANUM,1)=STR - ; -QUIT ; - K %,CIRNIEN,CNT,DA,DIK,DUMP,DUPCNT,EXCDT,GRAND,ICN,IEN,IEN1,IEN2,LN,LOCCNT,OLDDT,OLDNODE,PTNM - K RGDFN,RUNDT,SITEIEN,SITENM,STANUM,STAT,STR,TXT,TYPE,XCNT,HOME,DFN,RCNT,VADM - K ^XTMP("RGMT","ETOT") - Q - ; -PURGE ; - I '$D(RGHLMQ) W !!,"...purging duplicate Potential Match Exceptions",! - K ^XTMP("RGMT","ETOT") - S (RGDFN,CNT,XCNT,DUPCNT)=0,HOME=$$SITE^VASITE() - F S RGDFN=$O(^RGHL7(991.1,"ADFN",218,RGDFN)) Q:'RGDFN D - .S IEN=0 - .F S IEN=$O(^RGHL7(991.1,"ADFN",218,RGDFN,IEN)) Q:'IEN D - ..S IEN2=0 - ..F S IEN2=$O(^RGHL7(991.1,"ADFN",218,RGDFN,IEN,IEN2)) Q:'IEN2 D - ...I '$D(^RGHL7(991.1,IEN,0)) Q - ...S CNT=CNT+1 - ...S EXCDT=$P(^RGHL7(991.1,IEN,0),"^",3) - ...I '$D(^XTMP("RGMT","ETOT",RGDFN)) D Q - ....S XCNT=XCNT+1 - ....D SETTMP - ...I $D(^XTMP("RGMT","ETOT",RGDFN)) D - ....S OLDNODE=^XTMP("RGMT","ETOT",RGDFN) - ....S OLDDT=$P(OLDNODE,"^") - ....I EXCDT>OLDDT D Q - .....S DA(1)=$P(OLDNODE,"^",2),DA=$P(OLDNODE,"^",3) - .....D DELDUP - .....D SETTMP - ....I OLDDT>EXCDT!(OLDDT=EXCDT) D - .....S DA(1)=IEN,DA=IEN2 - .....D DELDUP - I '$D(RGHLMQ) W !,DUPCNT," duplicate patient entries for POTENTIAL MATCH exceptions were identified" - I '$D(RGHLMQ) W !,"and deleted from the CIRN HL7 EXCEPTION LOG file (#991.1)." - ; - K ^XTMP("RGMT","ETOT") - S (RCNT,RGDFN)=0 N IEN,SUB - F S RGDFN=$O(^RGHL7(991.1,"ADFN",218,RGDFN)) Q:'RGDFN D - .;S ICN=+$$GETICN^MPIF001(RGDFN) - .;I $E(ICN,1,3)=$P(HOME,"^",3)!(ICN<0) D - .;**43 shouldn't check for locals or no ICN, check for processed/not processed - .S IEN=0 F S IEN=$O(^RGHL7(991.1,"ADFN",218,RGDFN,IEN)) Q:IEN="" D - ..S SUB=$O(^RGHL7(991.1,"ADFN",218,RGDFN,IEN,"")) - ..I $P($G(^RGHL7(991.1,IEN,1,SUB,0)),"^",5)=0 D - ...S DFN=RGDFN D DEM^VADPT - ...I VADM(1)=""!(VADM(2)="") Q - ...S RCNT=RCNT+1 - ...S ^XTMP("RGMT","ETOT",VADM(1),RGDFN)=$P(VADM(2),"^")_"^"_$P(VADM(3),"^",2) - ; - ;count the number of patients who need to be resolved - S PTNM="",CNT=0 - F S PTNM=$O(^XTMP("RGMT","ETOT",PTNM)) Q:PTNM="" D - .S RGDFN=0 - .F S RGDFN=$O(^XTMP("RGMT","ETOT",PTNM,RGDFN)) Q:'RGDFN S CNT=CNT+1 - S TYPEARR(218)=CNT - Q - ; -SETTMP ;set TMP global for patient check - S ^XTMP("RGMT","ETOT",RGDFN)=EXCDT_"^"_IEN_"^"_IEN2 - Q - ; -DELDUP ;delete patient dups from file - S DUPCNT=DUPCNT+1 - S DIK="^RGHL7(991.1,"_DA(1)_",1," - D ^DIK K DIK,DA - Q - ; -218 ;;(Potential Matches Returned) -234 ;;(Primary View Reject) +RGMTETOT ;BIR/CML-Compile Totals for Site Exceptions ;11/15/01 + ;;1.0;CLINICAL INFO RESOURCE NETWORK;**20,30,43,45**;30 Apr 99;Build 9 + ; + ;Reference to ^DPT("AICNL" supported by IA #2070 + ; + ;Variable RGHLMQ cannot be killed in this routine, it is needed for the remote query + ; + ;Use this routine to compile totals of a site's exceptions in file #991.1 + S DUMP=0 G START + ; +DUMP1 ;Use this call to dump all data in ascii format for table + S DUMP=1 G START + ; +DUMP2 ;Use this call to dump data in ascii format for table - just for exceptions sites have to deal with + S DUMP=2 + ; +START ; + ;do purge of any dups for POTENTIAL MATCH Exceptions + K TYPEARR,^XTMP("RGMT","HLMQETOT") + S ^XTMP("RGMT",0)=$$FMADD^XLFDT(DT,30)_"^"_$$NOW^XLFDT_"^MPI/PD Maintenance Data" + D PURGE + ;create type array from file 991.11 + S TYPE=214 F S TYPE=$O(^RGHL7(991.11,TYPE)) Q:'TYPE I TYPE'=218 S TYPEARR(TYPE)=0 + ; + ;start loop + S TYPE=214 F S TYPE=$O(^RGHL7(991.1,"AC",TYPE)) Q:'TYPE D + .Q:TYPE=218 + .S IEN1=0 F S IEN1=$O(^RGHL7(991.1,"AC",TYPE,IEN1)) Q:'IEN1 D + ..S IEN2=0 F S IEN2=$O(^RGHL7(991.1,"AC",TYPE,IEN1,IEN2)) Q:'IEN2 D + ...I '$D(^RGHL7(991.1,IEN1,1,IEN2,0)) Q + ...S STAT=$P(^RGHL7(991.1,IEN1,1,IEN2,0),"^",5) I STAT<1 S TYPEARR(TYPE)=TYPEARR(TYPE)+1 + ; +PRT ; + S GRAND=0 + S SITENM=$P($$SITE^VASITE(),"^",2),$P(LN,"-",81)="" + D NOW^%DTC S RUNDT=$$FMTE^XLFDT($E(%,1,12)) + ; +PRT0 I 'DUMP D + .W !!,"Exception Totals for ",SITENM + .W !,"Printed ",RUNDT,!,LN + .S TYPE=0 F S TYPE=$O(TYPEARR(TYPE)) Q:'TYPE I +TYPEARR(TYPE) D + ..S GRAND=GRAND+TYPEARR(TYPE) + ..W !!,"TYPE: ",TYPE,?12,$P($T(@TYPE),";;",2),?67,"TOTAL = ",$J(TYPEARR(TYPE),4) + ..W !,"DESCRIPTION:" + ..S TXT=0 F S TXT=$O(^RGHL7(991.11,TYPE,99,TXT)) Q:'TXT W !,^RGHL7(991.11,TYPE,99,TXT,0) + .W !!?56,"TOTAL EXCEPTIONS: ",$J(GRAND,5) + ; +PRT1 I DUMP=1 D + .W !!,"At this point it is necessary for you to increase the right margin." + .W !,"At the DEVICE prompt enter=> ;255" + .W ! D ^%ZIS I POP W !,"DOWNLOAD ABORTED!" Q + .W !!,"Data string=Site;Run Date;Date CIRN Installed;Exceptions 215-234" + .S STR=SITENM_";"_RUNDT_";" + .S TYPE=0 F S TYPE=$O(TYPEARR(TYPE)) Q:'TYPE D + ..S STR=STR_";"_TYPEARR(TYPE) + .W !!,STR + ; +PRT2 I DUMP=2 D + .S ICN=0,LOCCNT=0 F S ICN=$O(^DPT("AICNL",1,ICN)) Q:'ICN S LOCCNT=LOCCNT+1 + .S SITEIEN=+$$SITE^VASITE(),STANUM=$P($$SITE^VASITE(),"^",3) + .I '$D(RGHLMQ) W !!,"Data string:" + .I '$D(RGHLMQ) W !,"Site;Sta#;;;LocICNs,215,216,217,218,227,234" + .S STR=SITENM_";"_STANUM_";;;"_LOCCNT + .F TYPE=215,216,217,218,227,234 S STR=STR_";"_TYPEARR(TYPE) + .I '$D(RGHLMQ) W !!,STR + .I $D(RGHLMQ) S ^XTMP("RGMT","HLMQETOT",STANUM,1)=STR + ; +QUIT ; + K %,CIRNIEN,CNT,DA,DIK,DUMP,DUPCNT,EXCDT,GRAND,ICN,IEN,IEN1,IEN2,LN,LOCCNT,OLDDT,OLDNODE,PTNM + K RGDFN,RUNDT,SITEIEN,SITENM,STANUM,STAT,STR,TXT,TYPE,XCNT,HOME,DFN,RCNT,VADM + K ^XTMP("RGMT","ETOT") + Q + ; +PURGE ; + I '$D(RGHLMQ) W !!,"...purging duplicate Potential Match Exceptions",! + K ^XTMP("RGMT","ETOT") + S (RGDFN,CNT,XCNT,DUPCNT)=0,HOME=$$SITE^VASITE() + F S RGDFN=$O(^RGHL7(991.1,"ADFN",218,RGDFN)) Q:'RGDFN D + .S IEN=0 + .F S IEN=$O(^RGHL7(991.1,"ADFN",218,RGDFN,IEN)) Q:'IEN D + ..S IEN2=0 + ..F S IEN2=$O(^RGHL7(991.1,"ADFN",218,RGDFN,IEN,IEN2)) Q:'IEN2 D + ...I '$D(^RGHL7(991.1,IEN,0)) Q + ...S CNT=CNT+1 + ...S EXCDT=$P(^RGHL7(991.1,IEN,0),"^",3) + ...I '$D(^XTMP("RGMT","ETOT",RGDFN)) D Q + ....S XCNT=XCNT+1 + ....D SETTMP + ...I $D(^XTMP("RGMT","ETOT",RGDFN)) D + ....S OLDNODE=^XTMP("RGMT","ETOT",RGDFN) + ....S OLDDT=$P(OLDNODE,"^") + ....I EXCDT>OLDDT D Q + .....S DA(1)=$P(OLDNODE,"^",2),DA=$P(OLDNODE,"^",3) + .....D DELDUP + .....D SETTMP + ....I OLDDT>EXCDT!(OLDDT=EXCDT) D + .....S DA(1)=IEN,DA=IEN2 + .....D DELDUP + I '$D(RGHLMQ) W !,DUPCNT," duplicate patient entries for POTENTIAL MATCH exceptions were identified" + I '$D(RGHLMQ) W !,"and deleted from the CIRN HL7 EXCEPTION LOG file (#991.1)." + ; + K ^XTMP("RGMT","ETOT") + S (RCNT,RGDFN)=0 N IEN,SUB + F S RGDFN=$O(^RGHL7(991.1,"ADFN",218,RGDFN)) Q:'RGDFN D + .;S ICN=+$$GETICN^MPIF001(RGDFN) + .;I $E(ICN,1,3)=$P(HOME,"^",3)!(ICN<0) D + .;**43 shouldn't check for locals or no ICN, check for processed/not processed + .S IEN=0 F S IEN=$O(^RGHL7(991.1,"ADFN",218,RGDFN,IEN)) Q:IEN="" D + ..S SUB=$O(^RGHL7(991.1,"ADFN",218,RGDFN,IEN,"")) + ..I $P($G(^RGHL7(991.1,IEN,1,SUB,0)),"^",5)=0 D + ...S DFN=RGDFN D DEM^VADPT + ...I VADM(1)=""!(VADM(2)="") Q + ...S RCNT=RCNT+1 + ...S ^XTMP("RGMT","ETOT",VADM(1),RGDFN)=$P(VADM(2),"^")_"^"_$P(VADM(3),"^",2) + ; + ;count the number of patients who need to be resolved + S PTNM="",CNT=0 + F S PTNM=$O(^XTMP("RGMT","ETOT",PTNM)) Q:PTNM="" D + .S RGDFN=0 + .F S RGDFN=$O(^XTMP("RGMT","ETOT",PTNM,RGDFN)) Q:'RGDFN S CNT=CNT+1 + S TYPEARR(218)=CNT + Q + ; +SETTMP ;set TMP global for patient check + S ^XTMP("RGMT","ETOT",RGDFN)=EXCDT_"^"_IEN_"^"_IEN2 + Q + ; +DELDUP ;delete patient dups from file + S DUPCNT=DUPCNT+1 + S DIK="^RGHL7(991.1,"_DA(1)_",1," + D ^DIK K DIK,DA + Q + ; +215 ;;(Death Entry on MPI not in VISTA) +216 ;;(Death Entry on Vista not in MPI) +217 ;;(Death Entries Mismatch) +218 ;;(Potential Matches Returned) +227 ;;(Multiple ICNs) +234 ;;(Primary View Reject) diff --git a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGPVMPI.m b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGPVMPI.m index b5adc717..ead9f3e7 100644 --- a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGPVMPI.m +++ b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGPVMPI.m @@ -1,90 +1,85 @@ -RGPVMPI ;BIR/PTD-REMOTE PRIMARY VIEW DISPLAY FROM MPI ;5/17/07 - ;;1.0;CLINICAL INFO RESOURCE NETWORK;**48,53**;30 Apr 99;Build 2 - ; - ;Reference to EN1^XWB2HL7 supported by IA #3144 - ;Reference to RPCCHK^XWB2HL7 supported by IA #3144 - ; -INTRO ;Display purpose of option - W @IOF S SAPV=1 ;from stand alone option, not EH - W !,"This option sends a remote request for data to the Master Patient" - W !,"Index, using a Remote Procedure Call (RPC). When the RPC returns" - W !,"the information, you can review Primary View data as it currently" - W !,"exists on the MPI Patient Data Inquiry (PDAT) report." - ; - W !!,"Choose the patient for whom Primary View data is to be requested." - W !,"The selected patient must have an Integration Control Number (ICN)." - W !,"You can select by Patient Name, Social Security Number, or ICN.",! - ; -ASK ;Ask For Patient - S DFN="",RGICN="" K DTOUT,DUOUT - S DIC="^DPT(",DIC(0)="QEAM",DIC("A")="Select PATIENT: ",D="SSN^AICN^B^BS^BS5" - D MIX^DIC1 K DIC,D - I Y<0 G EXIT - S DFN=+Y - S RGICN=+$$GETICN^MPIF001(DFN) I RGICN<1 W !,"There is no Integration Control Number for this patient." G ASK - ; -SEND ;Send a remote query to the MPI for Primary View PDAT - ;Entry point from Exception Handler; DATA should be defined. - S (QFLG,QUIT)=0 N RETURN,RESULT,SNTDT - I SAPV=0 D I QUIT=1 G EXIT - .I DATA="" W !,"No Exception Data available." S QUIT=1 Q - .S RGICN=$P(DATA,"^",6) I RGICN="" W !,"No ICN defined." S QUIT=1 Q - .S VALMBCK="" - .D FULL^VALM1 -NOQ ;No previous query exists for this ICN - I '$D(^XTMP("RGPVMPI"_RGICN)) D RPC G DISP - ; -OLDQ ;Query previously sent for this ICN - I $D(^XTMP("RGPVMPI"_RGICN)) D - .S SNTDT=$$FMTE^XLFDT($P(^XTMP("RGPVMPI"_RGICN,"DATA"),"^",2)) - .W !,"A query was last sent for this ICN on "_SNTDT - .;Has data returned for query? - .S RETURN(0)=$P(^XTMP("RGPVMPI"_RGICN,"DATA"),"^") - .D RPCCHK^XWB2HL7(.RESULT,RETURN(0)) - .;Data has NOT returned - .I +RESULT(0)'=1 D FAIL Q ;**53 - .I +RESULT(0)=1 D ;Data has returned - ..S DIR("A")="Do you wish to view the existing query data now? ",DIR(0)="YA" - ..S DIR("?")="Enter YES to review the existing data; enter NO to send a new query" - ..S DIR("B")="YES" D ^DIR K DIR I $D(DIRUT) S QUIT=1 Q ;up-arrowed out - ..I Y>0 K DIR Q ;yes, use existing query - ..I Y=0 D Q ;no, don't use existing, send new query - ...K ^XTMP("RGPVMPI"_RGICN) - ...D RPC - ...K DIR - ; -DISP ;Display Primary View Data - I QUIT'=1 D I QFLG G EXIT - .I SAPV=1 D Q:QFLG ;Stand alone PV display - ..W !,"(Be sure HISTORY is enabled to capture data!)" - ..S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q - ..W !,@IOF D SAPV^RGEX06(RGICN) - .I SAPV=0 D EN^RGEX06(RGICN) ;Exception Handler PV display - ; -EXIT ;Kill variables and quit - K CNT,D,DFN,DIC,DIR,DIRUT,DTOUT,DUOUT,QFLG,QUIT,RGICN,SAPV,X,Y - Q - ; -RPC ;Send the Remote Query - W !!,"Sending a Remote Query to the Master Patient Index." - W !,"This will take some time; please be patient." - D EN1^XWB2HL7(.RETURN,"200M","RG PRIMARY VIEW FROM MPI",1,RGICN) I RETURN(0)'="" D Q - .S ^XTMP("RGPVMPI"_RGICN,0)=$$FMADD^XLFDT(DT,2)_"^"_DT_"^"_"PRIMARY VIEW MPI PDAT" - .S ^XTMP("RGPVMPI"_RGICN,"DATA")=RETURN(0)_"^"_$$NOW^XLFDT - .;Has data returned for this query? - .S CNT=0 F S CNT=CNT+1 D RPCCHK^XWB2HL7(.RESULT,RETURN(0)) Q:RESULT(0) H 2 I CNT>15 Q ;result(0)=status of handle - .I +RESULT(0)=1 W !,"Query data has returned from the MPI and is available for review." - .I +RESULT(0)'=1 D FAIL ;**53 - W !!,"Problem with Query: ",RETURN(0)_"^"_$G(RETURN(1)) - S QUIT=1 - I SAPV=0 D PAUSE^VALM1 - Q - ; -FAIL ;Status of RPC call - unsuccessful after 30 seconds ;**53 - W !,"Your query request has NOT returned data from the MPI after trying for" - W !,"30 seconds. This could be due to network issues. Please try again later." - K ^XTMP("RGPVMPI"_RGICN) - S QUIT=1 - I SAPV=0 D PAUSE^VALM1 - Q - ; +RGPVMPI ;BIR/PTD-REMOTE PRIMARY VIEW DISPLAY FROM MPI ;5/17/07 + ;;1.0;CLINICAL INFO RESOURCE NETWORK;**48**;30 Apr 99;Build 3 + ; + ;Reference to EN1^XWB2HL7 supported by IA #3144 + ;Reference to RPCCHK^XWB2HL7 supported by IA #3144 + ; +INTRO ;Display purpose of option + W @IOF S SAPV=1 ;from stand alone option, not EH + W !,"This option sends a remote request for data to the Master Patient" + W !,"Index, using a Remote Procedure Call (RPC). When the RPC returns" + W !,"the information, you can review Primary View data as it currently" + W !,"exists on the MPI Patient Data Inquiry (PDAT) report." + ; + W !!,"Choose the patient for whom Primary View data is to be requested." + W !,"The selected patient must have an Integration Control Number (ICN)." + W !,"You can select by Patient Name, Social Security Number, or ICN.",! + ; +ASK ;Ask For Patient + S DFN="",RGICN="" K DTOUT,DUOUT + S DIC="^DPT(",DIC(0)="QEAM",DIC("A")="Select PATIENT: ",D="SSN^AICN^B^BS^BS5" + D MIX^DIC1 K DIC,D + I Y<0 G EXIT + S DFN=+Y + S RGICN=+$$GETICN^MPIF001(DFN) I RGICN<1 W !,"There is no Integration Control Number for this patient." G ASK + ; +SEND ;Send a remote query to the MPI for Primary View PDAT + ;Entry point from Exception Handler; DATA should be defined. + S (QFLG,QUIT)=0 N RETURN,RESULT,SNTDT + I SAPV=0 D I QUIT=1 G EXIT + .I DATA="" W !,"No Exception Data available." S QUIT=1 Q + .S RGICN=$P(DATA,"^",6) I RGICN="" W !,"No ICN defined." S QUIT=1 Q + .S VALMBCK="" + .D FULL^VALM1 +NOQ ;No previous query exists for this ICN + I '$D(^XTMP("RGPVMPI",RGICN)) D RPC G DISP + ; +OLDQ ;Query previously sent for this ICN + I $D(^XTMP("RGPVMPI",RGICN)) D + .S SNTDT=$$FMTE^XLFDT($P(^XTMP("RGPVMPI",RGICN),"^",2)) + .W !,"A query was last sent for this ICN on "_SNTDT + .;Has data returned for query? + .S RETURN(0)=$P(^XTMP("RGPVMPI",RGICN),"^") + .D RPCCHK^XWB2HL7(.RESULT,RETURN(0)) + .;Data has NOT returned + .I +RESULT(0)'=1 S QUIT=1 W !,"Query data has NOT returned from the MPI; please check back later." Q + .I +RESULT(0)=1 D ;Data has returned + ..S DIR("A")="Do you wish to view the existing query data now? ",DIR(0)="YA" + ..S DIR("?")="Enter YES to review the existing data; enter NO to send a new query" + ..S DIR("B")="YES" D ^DIR K DIR I $D(DIRUT) S QUIT=1 Q ;up-arrowed out + ..I Y>0 K DIR Q ;yes, use existing query + ..I Y=0 D Q ;no, don't use existing, send new query + ...K ^XTMP("RGPVMPI",RGICN) + ...D RPC + ...K DIR + ; +DISP ;Display Primary View Data + I QUIT'=1 D I QFLG G EXIT + .I SAPV=1 D Q:QFLG ;Stand alone PV display + ..W !,"(Be sure HISTORY is enabled to capture data!)" + ..S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q + ..W !,@IOF D SAPV^RGEX06(RGICN) + .I SAPV=0 D EN^RGEX06(RGICN) ;Exception Handler PV display + ; +EXIT ;Kill variables and quit + K CNT,D,DFN,DIC,DIR,DIRUT,DTOUT,DUOUT,QFLG,QUIT,RGICN,SAPV,X,Y + Q + ; +RPC ;Send the Remote Query + W !!,"Sending a Remote Query to the Master Patient Index." + W !,"This will take some time; please be patient." + D EN1^XWB2HL7(.RETURN,"200M","RG PRIMARY VIEW FROM MPI",1,RGICN) I RETURN(0)'="" D Q + .S ^XTMP("RGPVMPI",0)=$$FMADD^XLFDT(DT,2)_"^"_DT_"^"_"PRIMARY VIEW MPI PDAT" + .S ^XTMP("RGPVMPI",RGICN)=RETURN(0)_"^"_$$NOW^XLFDT + .;Has data returned for this query? + .S CNT=0 F S CNT=CNT+1 D RPCCHK^XWB2HL7(.RESULT,RETURN(0)) Q:RESULT(0) H 2 I CNT>15 Q ;result(0)=status of handle + .I +RESULT(0)=1 W !,"Query data has returned from the MPI and is available for review." + .I +RESULT(0)'=1 D ;quit, info not back after 30 seconds + ..W !,"Query data has NOT returned from the MPI; please check back later." + ..S QUIT=1 + ..I SAPV=0 D PAUSE^VALM1 + W !!,"Problem with Query: ",RETURN(0)_"^"_$G(RETURN(1)) + S QUIT=1 + I SAPV=0 D PAUSE^VALM1 + Q + ; diff --git a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGPVREJ.m b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGPVREJ.m index 064ef320..9231f492 100644 --- a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGPVREJ.m +++ b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGPVREJ.m @@ -1,81 +1,76 @@ -RGPVREJ ;BIR/PTD-REMOTE PRIMARY VIEW REJECT (PATIENT) ;10/8/06 - ;;1.0;CLINICAL INFO RESOURCE NETWORK;**44,47,53**;30 Apr 99;Build 2 - ; - ;Reference to ^XWB2HL7 supported by IA #3144 - ;Reference to ^XWBDRPC supported by IA #3149 - ; -REJ ;Option only available for Primary View Reject exceptions - ;From within the Exception Handler, for selection, DATA should be defined. - N RGBDT,RGICN,RGSITE,PTEN,PELV - I DATA="" W !,"No Exception Data available." Q - S PTEN=$P(DATA,"^",10) ;IEN IN 991.1 - S PELV=$P(DATA,"^",11) ;IEN IN 991.12 - I $P($G(^RGHL7(991.1,PTEN,1,PELV,0)),"^",3)'=234 S VALMSG="Action is ONLY for PRIMARY VIEW REJECT exceptions!" Q - I $P($G(^RGHL7(991.1,PTEN,1,PELV,0)),"^",5)=1 S VALMSG="Exception has been PROCESSED; no longer active." Q - S RGSITE=$P($$SITE^VASITE(),"^",3) I RGSITE="" W !,"No Site Data defined." Q - S RGICN=$P(DATA,"^",6) I RGICN="" W !,"No ICN defined." Q - S RGBDT=$P(DATA,"^",3) I RGBDT="" W !,"No Exception Date defined." Q - S X=RGBDT D ^%DT S RGBDT=Y ;convert Exception Date from external format to internal - ; - S VALMBCK="",QUIT=0 - D FULL^VALM1 -SEND ;Send a remote query to the MPI for Primary View Reject report - N RETURN,RESULT,RGEDT,SNTDT - S RGEDT=$$DT^XLFDT ;End date for report internal format -NOQ ;No previous query exists for this ICN/exception date - I '$D(^XTMP("RGPVREJ"_RGICN,RGBDT)) D RPC G DISP - ; -OLDQ ;Query already sent for this ICN/ exception date - I $D(^XTMP("RGPVREJ"_RGICN,RGBDT)) D - .S SNTDT=$$FMTE^XLFDT($P(^XTMP("RGPVREJ"_RGICN,RGBDT),"^",2)) - .W !?3,"A query was last sent for this ICN/Exception Date on "_SNTDT - .S X=$P(SNTDT,"@") D ^%DT S SNTDT=Y ;convert to internal, strip time - .;Has data returned for existing query? - .S RETURN(0)=$P(^XTMP("RGPVREJ"_RGICN,RGBDT),"^") - .D RPCCHK^XWB2HL7(.RESULT,RETURN(0)) I +RESULT(0)=1 D Q ;Data has returned - ..I RGEDT=SNTDT D ;query was sent 'today', want to use that one? - ...S DIR("A")=" Do you wish to review that existing query data now? ",DIR(0)="YA" - ...S DIR("?")=" Enter YES to review the existing query; NO to send a new query" - ...S DIR("B")="YES" D ^DIR K DIR I $D(DIRUT) S QUIT=1 Q ;up-arrowed out - ...I Y>0 K DIR Q ;yes, use existing query - ...I Y=0 D Q ;no, don't use existing, send new query - ....K ^XTMP("RGPVREJ"_RGICN,RGBDT) - ....D RPC - ....K DIR - ....; - ..I RGEDT'=SNTDT D ;query was NOT sent 'today', data may be old, send new query - ...W !?3,"Previous Query data may be obsolete." - ...K ^XTMP("RGPVREJ"_RGICN,RGBDT) - ...D RPC - .;Data for existing query has NOT returned **47 - .I +RESULT(0)'=1 D FAIL ;**53 - ; -DISP ;Display Primary View Reject Data - I QUIT'=1 D EN^RGEX07(RGICN,RGBDT) -EXIT ;Kill variables and quit - K CNT,DIR,DIRUT,QUIT,X,Y - Q - ; -RPC ;Send the Remote Query - W !?3,"Sending a Remote Query to the Master Patient Index." - W !?3,"This will take some time; please be patient." - D EN1^XWB2HL7(.RETURN,"200M","RG PRIMARY VIEW REJECT",1,RGSITE,RGICN,RGBDT,RGEDT) I RETURN(0)'="" D Q - .S ^XTMP("RGPVREJ"_RGICN,0)=$$FMADD^XLFDT(DT,2)_"^"_DT_"^"_"PRIMARY VIEW REJECT" - .S ^XTMP("RGPVREJ"_RGICN,RGBDT)=RETURN(0)_"^"_$$NOW^XLFDT - .;Has data returned for this query? - .S CNT=0 F S CNT=CNT+1 D RPCCHK^XWB2HL7(.RESULT,RETURN(0)) Q:RESULT(0) H 2 I CNT>15 Q ;result(0)=status of handle - .I +RESULT(0)=1 W !?3,"Query data has returned from the MPI and is available for review." - .I +RESULT(0)'=1 D FAIL ;**53 - W !!?3,"Problem with Query: ",RETURN(0)_"^"_$G(RETURN(1)) - S QUIT=1 - D PAUSE^VALM1 - Q - ; -FAIL ;Status of RPC call - unsuccessful after 30 seconds ;**53 - W !?3,"Your query request has NOT returned data from the MPI after trying for" - W !?3,"30 seconds. This could be due to network issues. Please try again later." - K ^XTMP("RGPVREJ"_RGICN,RGBDT) - S QUIT=1 - D PAUSE^VALM1 - Q - ; +RGPVREJ ;BIR/PTD-REMOTE PRIMARY VIEW REJECT (PATIENT) ;10/8/06 + ;;1.0;CLINICAL INFO RESOURCE NETWORK;**44,47**;30 Apr 99;Build 10 + ; + ;Reference to ^XWB2HL7 supported by IA #3144 + ;Reference to ^XWBDRPC supported by IA #3149 + ; +REJ ;Option only available for Primary View Reject exceptions + ;From within the Exception Handler, for selection, DATA should be defined. + N RGBDT,RGICN,RGSITE,PTEN,PELV + I DATA="" W !,"No Exception Data available." Q + S PTEN=$P(DATA,"^",10) ;IEN IN 991.1 + S PELV=$P(DATA,"^",11) ;IEN IN 991.12 + I $P($G(^RGHL7(991.1,PTEN,1,PELV,0)),"^",3)'=234 S VALMSG="Action is ONLY for PRIMARY VIEW REJECT exceptions!" Q + I $P($G(^RGHL7(991.1,PTEN,1,PELV,0)),"^",5)=1 S VALMSG="Exception has been PROCESSED; no longer active." Q + S RGSITE=$P($$SITE^VASITE(),"^",3) I RGSITE="" W !,"No Site Data defined." Q + S RGICN=$P(DATA,"^",6) I RGICN="" W !,"No ICN defined." Q + S RGBDT=$P(DATA,"^",3) I RGBDT="" W !,"No Exception Date defined." Q + S X=RGBDT D ^%DT S RGBDT=Y ;convert Exception Date from external format to internal + ; + S VALMBCK="",QUIT=0 + D FULL^VALM1 +SEND ;Send a remote query to the MPI for Primary View Reject report + N RETURN,RESULT,RGEDT,SNTDT + S RGEDT=$$DT^XLFDT ;End date for report internal format +NOQ ;No previous query exists for this ICN/exception date + I '$D(^XTMP("RGPVREJ",RGICN,RGBDT)) D RPC G DISP + ; +OLDQ ;Query already sent for this ICN/ exception date + I $D(^XTMP("RGPVREJ",RGICN,RGBDT)) D + .S SNTDT=$$FMTE^XLFDT($P(^XTMP("RGPVREJ",RGICN,RGBDT),"^",2)) + .W !?3,"A query was last sent for this ICN/Exception Date on "_SNTDT + .S X=$P(SNTDT,"@") D ^%DT S SNTDT=Y ;convert to internal, strip time + .;Has data returned for existing query? + .S RETURN(0)=$P(^XTMP("RGPVREJ",RGICN,RGBDT),"^") + .D RPCCHK^XWB2HL7(.RESULT,RETURN(0)) I +RESULT(0)=1 D Q ;Data has returned + ..I RGEDT=SNTDT D ;query was sent 'today', want to use that one? + ...S DIR("A")=" Do you wish to review that existing query data now? ",DIR(0)="YA" + ...S DIR("?")=" Enter YES to review the existing query; NO to send a new query" + ...S DIR("B")="YES" D ^DIR K DIR I $D(DIRUT) S QUIT=1 Q ;up-arrowed out + ...I Y>0 K DIR Q ;yes, use existing query + ...I Y=0 D Q ;no, don't use existing, send new query + ....K ^XTMP("RGPVREJ",RGICN,RGBDT) + ....D RPC + ....K DIR + ....; + ..I RGEDT'=SNTDT D ;query was NOT sent 'today', data may be old, send new query + ...W !?3,"Previous Query data may be obsolete." + ...K ^XTMP("RGPVREJ",RGICN,RGBDT) + ...D RPC + .;Data for existing query has NOT returned **47 + .I +RESULT(0)'=1 S QUIT=1 W !?3,"Query data has NOT returned from the MPI; please check back later." D PAUSE^VALM1 + ; +DISP ;Display Primary View Reject Data + I QUIT'=1 D EN^RGEX07(RGICN,RGBDT) +EXIT ;Kill variables and quit + K CNT,DIR,DIRUT,QUIT,X,Y + Q + ; +RPC ;Send the Remote Query + W !?3,"Sending a Remote Query to the Master Patient Index." + W !?3,"This will take some time; please be patient." + D EN1^XWB2HL7(.RETURN,"200M","RG PRIMARY VIEW REJECT",1,RGSITE,RGICN,RGBDT,RGEDT) I RETURN(0)'="" D Q + .S ^XTMP("RGPVREJ",0)=$$FMADD^XLFDT(DT,2)_"^"_DT_"^"_"PRIMARY VIEW REJECT" + .S ^XTMP("RGPVREJ",RGICN,RGBDT)=RETURN(0)_"^"_$$NOW^XLFDT + .;Has data returned for this query? + .S CNT=0 F S CNT=CNT+1 D RPCCHK^XWB2HL7(.RESULT,RETURN(0)) Q:RESULT(0) H 2 I CNT>15 Q ;result(0)=status of handle + .I +RESULT(0)=1 W !?3,"Query data has returned from the MPI and is available for review." + .I +RESULT(0)'=1 D ;quit, info not back after 30 seconds + ..W !?3,"Query data has NOT returned from the MPI; please check back later." + ..S QUIT=1 + ..D PAUSE^VALM1 + W !!?3,"Problem with Query: ",RETURN(0)_"^"_$G(RETURN(1)) + S QUIT=1 + D PAUSE^VALM1 + Q + ; diff --git a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGRSBUL1.m b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGRSBUL1.m index e790c3c0..48dc700c 100644 --- a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGRSBUL1.m +++ b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGRSBUL1.m @@ -1,153 +1,150 @@ -RGRSBUL1 ;ALB/RJS,CML-RGRSTEXT BULLETIN ROUTINE (PART 2) ;07/24/98 - ;;1.0;CLINICAL INFO RESOURCE NETWORK;**1,3,19,52**;30 Apr 99;Build 2 - ; -SSNBULL(DFN,ARRAY,NAME,SSN,ICN,CMOR) ; - ;Entry point generates a bulletin to the RG CIRN DEMOGRAPHIC - ;ISSUES mail group about an SSN change for a given patient. - ; - ;Input: Required Variables - ; - ; DFN - IEN in the PATIENT file (#2) - ; ARRAY - Array of data containing sending sites station number - ; NAME - Patient's Name - ; SSN - Patient's SSN - ; ICN - Patient's ICN (Integration Control Number) - ; CMOR - Patient's CMOR (Coordinating Master of Record) - ; - Q:$G(DFN)=""!($G(ARRAY)="") - N LOCDATA,RGRSTEXT,INDEX,COUNTER - S RGRSTEXT(1)="The MPI/PD Package has received an SSN change from:" - S RGRSTEXT(2)=$$INST(@ARRAY@("SENDING SITE")) - S RGRSTEXT(3)=" " - S RGRSTEXT(4)="This change has been made in your local data base for:" - S RGRSTEXT(5)=NAME - S RGRSTEXT(6)=" " - S RGRSTEXT(7)="=> Local "_$P($$SITE^VASITE(),"^",2)_" data PRIOR to update:" - S RGRSTEXT(8)="NAME: "_NAME - S RGRSTEXT(9)="SSN: "_SSN - S RGRSTEXT(10)="ICN: "_ICN - S RGRSTEXT(11)="CMOR: "_CMOR - S RGRSTEXT(12)="--------------------------------------------------------" - S RGRSTEXT(13)="=> Update received from "_$P($$INST(@ARRAY@("SENDING SITE"))," -->")_":" - S RGRSTEXT(14)="SSN: "_@ARRAY@("SSN") - D BULL2^RGRSBULL("MPI/PD SSN CHANGE - "_NAME,"RGRSTEXT(") - Q - ; -NOT2(ARRAY) ; - ;Entry point generates a bulletin to the RG CIRN DEMOGRAPHIC - ;ISSUES mail group about invalid subscription information for a given - ;patient. - ; - ;Input: Required Variables - ; - ; ARRAY - Array of information regarding the invalid subscription - ; - Q:($G(ARRAY)="") - N RGRSTEXT,INDEX,COUNTER - S RGRSTEXT(1)="The MPI/PD Package has received a message from:" - S RGRSTEXT(2)=$$INST(@ARRAY@("SENDING SITE")) - S RGRSTEXT(3)="This patient has your station as a subscriber, however" - S RGRSTEXT(4)="the patient was not found in your database." - S RGRSTEXT(5)="--------------------------------------------------------" - S RGRSTEXT(6)="Remote Data" - S RGRSTEXT(7)=" " - S INDEX=0,COUNTER=8 - F S INDEX=$O(@ARRAY@("MESSAGE",INDEX)) Q:INDEX']"" D - . S RGRSTEXT(COUNTER)=@ARRAY@("MESSAGE",INDEX) - . S COUNTER=COUNTER+1 - D BULL2^RGRSBULL("MPI/PD - PATIENT NOT FOUND","RGRSTEXT(") - Q - ; -SENSTIVE(DFN,ARRAY,NAME) ;FIRES WHEN PT. IS FLAGGED AS SENSITIVE AT ANOTHER SITE - ;Entry point generates a bulletin to the RG CIRN DEMOGRAPHIC - ;ISSUES mail group when a given patient is flagged as sensitive at - ;another site. - ; - ;Input: Required Variables - ; - ; DFN - IEN in the PATIENT file (#2) - ; ARRAY - Array of data containing sending sites station number and SSN - ; NAME - Patient's name - ; CMOR - Coordinating Master of Record - ; - Q:($G(ARRAY)="")!($G(DFN)="") - N RGRSTEXT,INDEX,COUNTER,CMOR - S CMOR=$$CMOR2^MPIF001(DFN) I $P(CMOR,"^")<0 S CMOR="not assigned" - S RGRSTEXT(1)="The MPI/PD Package has received a message from:" - S RGRSTEXT(2)=$$INST(@ARRAY@("SENDING SITE")) - S RGRSTEXT(3)=" " - S RGRSTEXT(4)="This message indicates that patient "_NAME_" is flagged" - S RGRSTEXT(5)="as Sensitive at the other facility but is not flagged as" - S RGRSTEXT(6)="Sensitive at your facility." - S RGRSTEXT(7)=" " - S RGRSTEXT(8)="Remote Patient SSN: "_$S(@ARRAY@("SSN")="":"Not Available",1:@ARRAY@("SSN")) - S RGRSTEXT(9)="Remote User who Flagged the Patient as Sensitive: "_@ARRAY@("SENSITIVITY USER") - S RGRSTEXT(10)="Date/Time Remote User Flagged Patient Sensitive: "_$$FMTE^XLFDT(@ARRAY@("SENSITIVITY DATE")) - S RGRSTEXT(11)=" " - S RGRSTEXT(12)="CMOR Site: "_CMOR - D BULL2^RGRSBULL("Remote Sensitivity Indicated","RGRSTEXT(") - Q - ; - ;MPIC_772 - **52; Commented out Remote Date of Death Indicated module. - ;Only RGADTP2 and RGRSPT called this module; and both have been commented out. -RMTDOD(DFN,ARRAY,NAME,RDOD,LDOD) ;Fires when patient has a Date of Death at another site - ;Entry point generates a bulletin to the RG CIRN DEMOGRAPHIC - ;ISSUES mail group when a given patient has a Date of Death at - ;another site. - ; - ;Input: Required Variables - ; - ; DFN - IEN in the PATIENT file (#2) - ; ARRAY - Array of data containing sending sites station number and SSN - ; NAME - Patient's name - ; RDOD - Date of Death at remote site - ; LDOD - Date of Death at local site - ; CMOR - Coordinating Master of Record - ; - ;Q:($G(ARRAY)="")!($G(DFN)="") - ;Q:(RDOD=LDOD) ;If remote DOD and local DOD same, QUIT - ;N CMOR - ;S CMOR=$$CMOR2^MPIF001(DFN) I $P(CMOR,"^")<0 S CMOR="not assigned" - ;N RGRSTEXT - ;S RGRSTEXT(1)="The MPI/PD Package has received a message from:" - ;S RGRSTEXT(2)=$$INST(@ARRAY@("SENDING SITE")) - ;S RGRSTEXT(3)=" " - ;S RGRSTEXT(4)="This message indicates that patient "_NAME - ;I 'LDOD S RGRSTEXT(5)="has a date of death at the other facility but not at your facility." G RMTMSG - ;I LDOD,(LDOD'=RDOD) S RGRSTEXT(5)="has a different date of death at the other facility than at your facility." -RMTMSG ;S RGRSTEXT(6)=" " - ;S RGRSTEXT(7)="Remote Patient SSN: "_$S(@ARRAY@("SSN")="":"Not Available",1:@ARRAY@("SSN")) - ;S RGRSTEXT(8)="Date of Death from other facility: "_$$FMTE^XLFDT(RDOD) - ;I LDOD,(LDOD'=RDOD) S RGRSTEXT(9)="Date of Death at your facility: "_$$FMTE^XLFDT(LDOD) - ;S RGRSTEXT(10)=" " - ;S RGRSTEXT(11)="CMOR site: "_CMOR - ;D BULL2^RGRSBULL("Remote Date of Death Indicated","RGRSTEXT(") - Q - ; -INST(SITENUM) ; - N RETURN,IEN,DATA,NAME,NUMBER - S RETURN="" - Q:$G(SITENUM)="" RETURN - S IEN=$$LKUP^XUAF4(SITENUM) - I IEN>0 S DATA=$$NS^XUAF4(IEN) - I $G(DATA)]"" D - . S NAME=$P(DATA,"^",1),NUMBER=$P(DATA,"^",2) - . S RETURN=NAME_" --> Site Number: "_NUMBER - Q RETURN - ; -FORMAT(DATA1,DATA2) ; - N SPACES,SPACENUM,LENGTH1,LENGTH2,RETURN - S SPACES=" " - S LENGTH1=$L(DATA1),LENGTH2=$L(DATA2) - I LENGTH1>23 S DATA1=$E(DATA1,1,23) S LENGTH1=23 - I LENGTH2>22 S DATA2=$E(DATA2,1,22) - S SPACENUM=23-LENGTH1 - S SPACES=$E(SPACES,1,SPACENUM) - S RETURN=DATA1_SPACES_" "_DATA2 - Q $G(RETURN) - ; -FREE(DATA) ; - Q:$G(DATA)="" "" - Q:$G(DATA)["@" "" - Q:$G(DATA)=HL("Q") "" - Q $G(DATA) +RGRSBUL1 ;ALB/RJS,CML-RGRSTEXT BULLETIN ROUTINE (PART 2) ;07/24/98 + ;;1.0;CLINICAL INFO RESOURCE NETWORK;**1,3,19**;30 Apr 99 +SSNBULL(DFN,ARRAY,NAME,SSN,ICN,CMOR) ; + ;Entry point generates a bulletin to the RG CIRN DEMOGRAPHIC + ;ISSUES mail group about an SSN change for a given patient. + ; + ;Input: Required Variables + ; + ; DFN - IEN in the PATIENT file (#2) + ; ARRAY - Array of data containing sending sites station number + ; NAME - Patient's Name + ; SSN - Patient's SSN + ; ICN - Patient's ICN (Integration Control Number) + ; CMOR - Patient's CMOR (Coordinating Master of Record) + ; + Q:$G(DFN)=""!($G(ARRAY)="") + N LOCDATA,RGRSTEXT,INDEX,COUNTER + S RGRSTEXT(1)="The MPI/PD Package has received an SSN change from:" + S RGRSTEXT(2)=$$INST(@ARRAY@("SENDING SITE")) + S RGRSTEXT(3)=" " + S RGRSTEXT(4)="This change has been made in your local data base for:" + S RGRSTEXT(5)=NAME + S RGRSTEXT(6)=" " + S RGRSTEXT(7)="=> Local "_$P($$SITE^VASITE(),"^",2)_" data PRIOR to update:" + S RGRSTEXT(8)="NAME: "_NAME + S RGRSTEXT(9)="SSN: "_SSN + S RGRSTEXT(10)="ICN: "_ICN + S RGRSTEXT(11)="CMOR: "_CMOR + S RGRSTEXT(12)="--------------------------------------------------------" + S RGRSTEXT(13)="=> Update received from "_$P($$INST(@ARRAY@("SENDING SITE"))," -->")_":" + S RGRSTEXT(14)="SSN: "_@ARRAY@("SSN") + D BULL2^RGRSBULL("MPI/PD SSN CHANGE - "_NAME,"RGRSTEXT(") + Q + ; +NOT2(ARRAY) ; + ;Entry point generates a bulletin to the RG CIRN DEMOGRAPHIC + ;ISSUES mail group about invalid subscription information for a given + ;patient. + ; + ;Input: Required Variables + ; + ; ARRAY - Array of information regarding the invalid subscription + ; + Q:($G(ARRAY)="") + N RGRSTEXT,INDEX,COUNTER + S RGRSTEXT(1)="The MPI/PD Package has received a message from:" + S RGRSTEXT(2)=$$INST(@ARRAY@("SENDING SITE")) + S RGRSTEXT(3)="This patient has your station as a subscriber, however" + S RGRSTEXT(4)="the patient was not found in your database." + S RGRSTEXT(5)="--------------------------------------------------------" + S RGRSTEXT(6)="Remote Data" + S RGRSTEXT(7)=" " + S INDEX=0,COUNTER=8 + F S INDEX=$O(@ARRAY@("MESSAGE",INDEX)) Q:INDEX']"" D + . S RGRSTEXT(COUNTER)=@ARRAY@("MESSAGE",INDEX) + . S COUNTER=COUNTER+1 + D BULL2^RGRSBULL("MPI/PD - PATIENT NOT FOUND","RGRSTEXT(") + Q + ; +SENSTIVE(DFN,ARRAY,NAME) ;FIRES WHEN PT. IS FLAGGED AS SENSITIVE AT ANOTHER SITE + ;Entry point generates a bulletin to the RG CIRN DEMOGRAPHIC + ;ISSUES mail group when a given patient is flagged as sensitive at + ;another site. + ; + ;Input: Required Variables + ; + ; DFN - IEN in the PATIENT file (#2) + ; ARRAY - Array of data containing sending sites station number and SSN + ; NAME - Patient's name + ; CMOR - Coordinating Master of Record + ; + Q:($G(ARRAY)="")!($G(DFN)="") + N RGRSTEXT,INDEX,COUNTER,CMOR + S CMOR=$$CMOR2^MPIF001(DFN) I $P(CMOR,"^")<0 S CMOR="not assigned" + S RGRSTEXT(1)="The MPI/PD Package has received a message from:" + S RGRSTEXT(2)=$$INST(@ARRAY@("SENDING SITE")) + S RGRSTEXT(3)=" " + S RGRSTEXT(4)="This message indicates that patient "_NAME_" is flagged" + S RGRSTEXT(5)="as Sensitive at the other facility but is not flagged as" + S RGRSTEXT(6)="Sensitive at your facility." + S RGRSTEXT(7)=" " + S RGRSTEXT(8)="Remote Patient SSN: "_$S(@ARRAY@("SSN")="":"Not Available",1:@ARRAY@("SSN")) + S RGRSTEXT(9)="Remote User who Flagged the Patient as Sensitive: "_@ARRAY@("SENSITIVITY USER") + S RGRSTEXT(10)="Date/Time Remote User Flagged Patient Sensitive: "_$$FMTE^XLFDT(@ARRAY@("SENSITIVITY DATE")) + S RGRSTEXT(11)=" " + S RGRSTEXT(12)="CMOR Site: "_CMOR + D BULL2^RGRSBULL("Remote Sensitivity Indicated","RGRSTEXT(") + Q + ; +RMTDOD(DFN,ARRAY,NAME,RDOD,LDOD) ;Fires when patient has a Date of Death at another site + ;Entry point generates a bulletin to the RG CIRN DEMOGRAPHIC + ;ISSUES mail group when a given patient has a Date of Death at + ;another site. + ; + ;Input: Required Variables + ; + ; DFN - IEN in the PATIENT file (#2) + ; ARRAY - Array of data containing sending sites station number and SSN + ; NAME - Patient's name + ; RDOD - Date of Death at remote site + ; LDOD - Date of Death at local site + ; CMOR - Coordinating Master of Record + ; + Q:($G(ARRAY)="")!($G(DFN)="") + Q:(RDOD=LDOD) ;If remote DOD and local DOD same, QUIT + N CMOR + S CMOR=$$CMOR2^MPIF001(DFN) I $P(CMOR,"^")<0 S CMOR="not assigned" + N RGRSTEXT + S RGRSTEXT(1)="The MPI/PD Package has received a message from:" + S RGRSTEXT(2)=$$INST(@ARRAY@("SENDING SITE")) + S RGRSTEXT(3)=" " + S RGRSTEXT(4)="This message indicates that patient "_NAME + I 'LDOD S RGRSTEXT(5)="has a date of death at the other facility but not at your facility." G RMTMSG + I LDOD,(LDOD'=RDOD) S RGRSTEXT(5)="has a different date of death at the other facility than at your facility." +RMTMSG S RGRSTEXT(6)=" " + S RGRSTEXT(7)="Remote Patient SSN: "_$S(@ARRAY@("SSN")="":"Not Available",1:@ARRAY@("SSN")) + S RGRSTEXT(8)="Date of Death from other facility: "_$$FMTE^XLFDT(RDOD) + I LDOD,(LDOD'=RDOD) S RGRSTEXT(9)="Date of Death at your facility: "_$$FMTE^XLFDT(LDOD) + S RGRSTEXT(10)=" " + S RGRSTEXT(11)="CMOR site: "_CMOR + D BULL2^RGRSBULL("Remote Date of Death Indicated","RGRSTEXT(") + Q + ; +INST(SITENUM) ; + N RETURN,IEN,DATA,NAME,NUMBER + S RETURN="" + Q:$G(SITENUM)="" RETURN + S IEN=$$LKUP^XUAF4(SITENUM) + I IEN>0 S DATA=$$NS^XUAF4(IEN) + I $G(DATA)]"" D + . S NAME=$P(DATA,"^",1),NUMBER=$P(DATA,"^",2) + . S RETURN=NAME_" --> Site Number: "_NUMBER + Q RETURN + ; +FORMAT(DATA1,DATA2) ; + N SPACES,SPACENUM,LENGTH1,LENGTH2,RETURN + S SPACES=" " + S LENGTH1=$L(DATA1),LENGTH2=$L(DATA2) + I LENGTH1>23 S DATA1=$E(DATA1,1,23) S LENGTH1=23 + I LENGTH2>22 S DATA2=$E(DATA2,1,22) + S SPACENUM=23-LENGTH1 + S SPACES=$E(SPACES,1,SPACENUM) + S RETURN=DATA1_SPACES_" "_DATA2 + Q $G(RETURN) + ; +FREE(DATA) ; + Q:$G(DATA)="" "" + Q:$G(DATA)["@" "" + Q:$G(DATA)=HL("Q") "" + Q $G(DATA) diff --git a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGRSPT.m b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGRSPT.m index d4f2299b..f38c8afb 100644 --- a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGRSPT.m +++ b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGRSPT.m @@ -1,99 +1,98 @@ -RGRSPT ;ALB/RJS,CML-HIGH LEVEL ROUTINE FOR PARSING AND FILING ;06/25/98 - ;;1.0;CLINICAL INFO RESOURCE NETWORK;**1,3,7,8,52**;30 Apr 99;Build 2 - ; - ;Parse Incoming Message, and file. - ; - ; - Q:($G(HL("MTN"))'="ADT") - N RGRSDFN,VAFCA,RGRS,VAFCA08,RGRSARAY,BOGUS,RGDC,SENSTVTY,CMORDISP - N NAME,LASTNAME,SSN,ICN,CMOR,CMORIEN,OTHSITE,RGRSDATA,HERE,BULSUB,NODE - S RGRSARAY="RGRS(2)" - D INITIZE^RGRSUTIL ;copy HL7 message into local RGDC array - S VAFCA=$$EN^RGRSMSH() ;parse MSH for filer - D EN^RGRSPARS(RGRSARAY) ;parse HL7 message into local array RGRS - I $$SKIP^RGRSZZPT(1,RGRSARAY) D G EXIT ;skip if certain data is not there - . D SKIPBULL^RGRSBULL(RGRSARAY) - S RGRSDFN=$$GETDFN^MPIF001(@RGRSARAY@(991.01)) ;Get DFN from ICN - Q:+$$SEND2^VAFCUTL1(RGRSDFN,"T") ;safeguard to prevent the processing of test patients - S OTHSITE=@RGRSARAY@("SITENUM")\1 - S HERE=$P($$SITE^VASITE,"^",3)\1 - ; - ;If patient not known in site, send bulletin, go exit - ; - I +RGRSDFN=-1 D EXC^RGHLLOG(210,"Msg#"_$G(HL("MID"))_" Bad DFN#"_$G(RGRSDFN)_" for "_$G(@RGRSARAY@(.01))_" (ICN#"_$G(@RGRSARAY@(991.01))_")") D STOP^RGHLLOG(1) Q - ; - S NAME=$$GET1^DIQ(2,+RGRSDFN_",",.01) - S LASTNAME=$P(NAME,",",1) - S SSN=$$GET1^DIQ(2,+RGRSDFN_",",.09) - S NODE=$$MPINODE^MPIFAPI(RGRSDFN) - S ICN=$P(NODE,"^") - S CMORIEN=$P(NODE,"^",3) - S CMOR=$$NS^XUAF4(CMORIEN) - S CMORDISP=$P(CMOR,"^",1) - S CMOR=$P(CMOR,"^",2) - ; - S @RGRSARAY@("NAME")=@RGRSARAY@(.01) - S @RGRSARAY@("SSN")=@RGRSARAY@(.09) - S @RGRSARAY@("ICN")=@RGRSARAY@(991.01) - S @RGRSARAY@("CMOR")=$P($$NS^XUAF4($$LKUP^XUAF4(OTHSITE)),"^") - ; - ;If ICN or CMOR don't match, send bulletin and go exit - I '$$MATCH(RGRSDFN,RGRSARAY,,,ICN,CMOR,.BULSUB) D G EXIT - . D MTCHBULL^RGRSBULL(RGRSDFN,RGRSARAY,NAME,SSN,ICN,CMORDISP,BULSUB) - ; - ;if ICN and CMOR match, check for SSN edit from CMOR - I @RGRSARAY@("SENDING SITE")=CMOR,(SSN'=@RGRSARAY@(.09)) D - .D SSNBULL^RGRSBUL1(RGRSDFN,RGRSARAY,NAME,SSN,ICN,CMORDISP) - ; - ;If patient is Sensitive at other site but not here send bulletin - S SENSTVTY=$G(@RGRSARAY@("SENSITIVITY")) - I '$$SENSTIVE^RGRSENS(RGRSDFN),SENSTVTY D SENSTIVE^RGRSBUL1(RGRSDFN,RGRSARAY,NAME) - ; - ;MPIC_772 - **52; Commented out Remote Date of Death Indicated section. - ;If patient has DATE OF DEATH (DOD) at remote site send bulletin - ;Ignore time if present with date. - ;S RMTDOD=@RGRSARAY@(.351),RMTDOD=$P(RMTDOD,".") - ;S DFN=RGRSDFN D DEM^VADPT - ;S LOCDOD=$P($P(VADM(6),"^"),".") - ;If there is a remote DOD but no local DOD OR - ;if remote DOD is different from local DOD, send bulletin - ;I RMTDOD D RMTDOD^RGRSBUL1(RGRSDFN,RGRSARAY,NAME,RMTDOD,LOCDOD) - ;K LOCDOD,RMTDOD,VADM - ; - D G EXIT ;**7 - . ; - . ;IF it's the CMOR - review file - . ; - . I (OTHSITE)=(HERE) D Q - . . S VAFCA=VAFCA_"^"_RGRSDFN - . . S VAFCA08=1 S BOGUS=$$ADD^VAFCEHU1(VAFCA,"RGRS") - . ; - . ;IF it's not the CMOR - Don't Rebroadcast - . ; - . I (OTHSITE)'=(HERE) D Q - . . S VAFCA08=1 - . . D EDIT^VAFCPTED(RGRSDFN,RGRSARAY,".01;.03;.09;.02;.2403") ;**7 broadcasted fields - removed .05,.08,.111;.112;.113;.114;.115;.1112;.117;.131;.132;.211;.219;.31115 -EXIT ; - Q - ; -MATCH(DFN,RGRSARAY,LASTNAME,SSN,ICN,CMOR,BULSUB) ; - Q:$G(DFN)=""!($G(RGRSARAY)="") 0 - N COUNT,TRUE S (COUNT,TRUE)=0 - S BULSUB="" - I $D(LASTNAME) D - . S COUNT=COUNT+1 - . I (LASTNAME'=""),(LASTNAME=$P(@RGRSARAY@(.01),",",1)) S TRUE=TRUE+1 - I $D(SSN) D - . S COUNT=COUNT+1 - . I (SSN'=""),(SSN=$G(@RGRSARAY@(.09))) S TRUE=TRUE+1 - I $D(ICN) D - . S COUNT=COUNT+1 - . I (ICN'=""),(ICN=$G(@RGRSARAY@(991.01))) S TRUE=TRUE+1 Q - . S BULSUB=BULSUB_"ICN" - I $D(CMOR) D - . S COUNT=COUNT+1 - . I (CMOR'=""),(CMOR=$G(@RGRSARAY@("SITENUM"))) S TRUE=TRUE+1 Q - . I BULSUB]"" S BULSUB=BULSUB_" & " - . S BULSUB=BULSUB_"CMOR" - I COUNT=TRUE Q 1 - Q 0 +RGRSPT ;ALB/RJS,CML-HIGH LEVEL ROUTINE FOR PARSING AND FILING ;06/25/98 + ;;1.0;CLINICAL INFO RESOURCE NETWORK;**1,3,7,8**;30 Apr 99 + ; + ;Parse Incoming Message, and file. + ; + ; + Q:($G(HL("MTN"))'="ADT") + N RGRSDFN,VAFCA,RGRS,VAFCA08,RGRSARAY,BOGUS,RGDC,SENSTVTY,CMORDISP + N NAME,LASTNAME,SSN,ICN,CMOR,CMORIEN,OTHSITE,RGRSDATA,HERE,BULSUB,NODE + S RGRSARAY="RGRS(2)" + D INITIZE^RGRSUTIL ;copy HL7 message into local RGDC array + S VAFCA=$$EN^RGRSMSH() ;parse MSH for filer + D EN^RGRSPARS(RGRSARAY) ;parse HL7 message into local array RGRS + I $$SKIP^RGRSZZPT(1,RGRSARAY) D G EXIT ;skip if certain data is not there + . D SKIPBULL^RGRSBULL(RGRSARAY) + S RGRSDFN=$$GETDFN^MPIF001(@RGRSARAY@(991.01)) ;Get DFN from ICN + Q:+$$SEND2^VAFCUTL1(RGRSDFN,"T") ;safeguard to prevent the processing of test patients + S OTHSITE=@RGRSARAY@("SITENUM")\1 + S HERE=$P($$SITE^VASITE,"^",3)\1 + ; + ;If patient not known in site, send bulletin, go exit + ; + I +RGRSDFN=-1 D EXC^RGHLLOG(210,"Msg#"_$G(HL("MID"))_" Bad DFN#"_$G(RGRSDFN)_" for "_$G(@RGRSARAY@(.01))_" (ICN#"_$G(@RGRSARAY@(991.01))_")") D STOP^RGHLLOG(1) Q + ; + S NAME=$$GET1^DIQ(2,+RGRSDFN_",",.01) + S LASTNAME=$P(NAME,",",1) + S SSN=$$GET1^DIQ(2,+RGRSDFN_",",.09) + S NODE=$$MPINODE^MPIFAPI(RGRSDFN) + S ICN=$P(NODE,"^") + S CMORIEN=$P(NODE,"^",3) + S CMOR=$$NS^XUAF4(CMORIEN) + S CMORDISP=$P(CMOR,"^",1) + S CMOR=$P(CMOR,"^",2) + ; + S @RGRSARAY@("NAME")=@RGRSARAY@(.01) + S @RGRSARAY@("SSN")=@RGRSARAY@(.09) + S @RGRSARAY@("ICN")=@RGRSARAY@(991.01) + S @RGRSARAY@("CMOR")=$P($$NS^XUAF4($$LKUP^XUAF4(OTHSITE)),"^") + ; + ;If ICN or CMOR don't match, send bulletin and go exit + I '$$MATCH(RGRSDFN,RGRSARAY,,,ICN,CMOR,.BULSUB) D G EXIT + . D MTCHBULL^RGRSBULL(RGRSDFN,RGRSARAY,NAME,SSN,ICN,CMORDISP,BULSUB) + ; + ;if ICN and CMOR match, check for SSN edit from CMOR + I @RGRSARAY@("SENDING SITE")=CMOR,(SSN'=@RGRSARAY@(.09)) D + .D SSNBULL^RGRSBUL1(RGRSDFN,RGRSARAY,NAME,SSN,ICN,CMORDISP) + ; + ;If patient is Sensitive at other site but not here send bulletin + S SENSTVTY=$G(@RGRSARAY@("SENSITIVITY")) + I '$$SENSTIVE^RGRSENS(RGRSDFN),SENSTVTY D SENSTIVE^RGRSBUL1(RGRSDFN,RGRSARAY,NAME) + ; + ;If patient has DATE OF DEATH (DOD) at remote site send bulletin + ;Ignore time if present with date. + S RMTDOD=@RGRSARAY@(.351),RMTDOD=$P(RMTDOD,".") + S DFN=RGRSDFN D DEM^VADPT + S LOCDOD=$P($P(VADM(6),"^"),".") + ;If there is a remote DOD but no local DOD OR + ;if remote DOD is different from local DOD, send bulletin + I RMTDOD D RMTDOD^RGRSBUL1(RGRSDFN,RGRSARAY,NAME,RMTDOD,LOCDOD) + K LOCDOD,RMTDOD,VADM + ; + D G EXIT ;**7 + . ; + . ;IF it's the CMOR - review file + . ; + . I (OTHSITE)=(HERE) D Q + . . S VAFCA=VAFCA_"^"_RGRSDFN + . . S VAFCA08=1 S BOGUS=$$ADD^VAFCEHU1(VAFCA,"RGRS") + . ; + . ;IF it's not the CMOR - Don't Rebroadcast + . ; + . I (OTHSITE)'=(HERE) D Q + . . S VAFCA08=1 + . . D EDIT^VAFCPTED(RGRSDFN,RGRSARAY,".01;.03;.09;.02;.2403") ;**7 broadcasted fields - removed .05,.08,.111;.112;.113;.114;.115;.1112;.117;.131;.132;.211;.219;.31115 +EXIT ; + Q + ; +MATCH(DFN,RGRSARAY,LASTNAME,SSN,ICN,CMOR,BULSUB) ; + Q:$G(DFN)=""!($G(RGRSARAY)="") 0 + N COUNT,TRUE S (COUNT,TRUE)=0 + S BULSUB="" + I $D(LASTNAME) D + . S COUNT=COUNT+1 + . I (LASTNAME'=""),(LASTNAME=$P(@RGRSARAY@(.01),",",1)) S TRUE=TRUE+1 + I $D(SSN) D + . S COUNT=COUNT+1 + . I (SSN'=""),(SSN=$G(@RGRSARAY@(.09))) S TRUE=TRUE+1 + I $D(ICN) D + . S COUNT=COUNT+1 + . I (ICN'=""),(ICN=$G(@RGRSARAY@(991.01))) S TRUE=TRUE+1 Q + . S BULSUB=BULSUB_"ICN" + I $D(CMOR) D + . S COUNT=COUNT+1 + . I (CMOR'=""),(CMOR=$G(@RGRSARAY@("SITENUM"))) S TRUE=TRUE+1 Q + . I BULSUB]"" S BULSUB=BULSUB_" & " + . S BULSUB=BULSUB_"CMOR" + I COUNT=TRUE Q 1 + Q 0 diff --git a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGSYSTAT.m b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGSYSTAT.m index 372b7fe0..e292fd3c 100644 --- a/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGSYSTAT.m +++ b/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGSYSTAT.m @@ -1,102 +1,101 @@ -RGSYSTAT ;BAY/ALS-MPI/PD STATUS DISPLAY ;01/05/01 - ;;1.0;CLINICAL INFO RESOURCE NETWORK;**16,19,23,25,20,43,45,52**;30 Apr 99;Build 2 - ; - ;Reference to ^DGCN(391.98,"AST" supported by IA #3303 - ;Reference to ^DGCN(391.984 supported by IA #3304 - ;Reference to ^MPIF(984.9 supported by IA #3298 - ;Reference to OPTSTAT^XUTMOPT supported by IA #1472 - ;Reference to ^DPT("ACMORS", ^DPT("AICN", and ^DPT("AICNL" supported by IA #2070 - ;Reference to ^VAT(391.71 supported by IA #3422 -EN ; - ; Count exceptions on hand -EXC ; - W @IOF,"Exception Handler Entries:",!,"--------------------------" - S CNT=0,EXCTYP="",NTYP="",TOTL=0,PCNT=0 - N STAT,DFN,ICN - S HOME=$$SITE^VASITE() - F S EXCTYP=$O(^RGHL7(991.1,"AC",EXCTYP)) Q:'EXCTYP D - . I (EXCTYP=234)!(EXCTYP=218) D ;**45;MPIC_772; **52 remove 215, 216, 217, & 227 - .. I (EXCTYP'=NTYP)&(CNT>0) D - ... S ETEXT=$P($G(^RGHL7(991.11,NTYP,10)),"^",1) - ... W !,$E(ETEXT,1,47),?55,$J(CNT,6) S TOTL=TOTL+CNT,CNT=0 - .. S IEN=0,NTYP=EXCTYP - .. F S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN D - ... S IEN2=0 - ... F S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2 D - .... S STAT=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",5) I STAT<1 D - ..... S DFN=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",4) Q:'DFN - ..... S ^XTMP("RGEXC",0)=$$FMADD^XLFDT(DT,2)_"^"_DT_"^"_"MPI/PD Status Display" - ..... S ^XTMP("RGEXC",DFN)=DFN - ..... S ICN=+$$GETICN^MPIF001(DFN) - ..... I $E(ICN,1,3)=$E($P(HOME,"^",3),1,3)!(ICN<0)!(EXCTYP=234)!(EXCTYP=218) D ;**43;**45;MPIC_772; **52 remove 215, 216, and 217 - ...... S CNT=CNT+1 - I CNT>0 D - .S ETEXT=$P($G(^RGHL7(991.11,NTYP,10)),"^",1) - .W !,$E(ETEXT,1,47),?55,$J(CNT,6) S TOTL=TOTL+CNT - I TOTL=0 W !,"There are no entries in the Exception Handler." - I TOTL>0 D - . W !!,"Total number of exceptions: ",?55,$J(TOTL,6) - . S PDFN="" - . F S PDFN=$O(^XTMP("RGEXC",PDFN)) Q:'PDFN D - .. S PCNT=PCNT+1 - . W !,"Total unique patient exceptions: ",?55,$J(PCNT,6) - S STDT=$P($G(^RGSITE(991.8,1,"EXCPRG")),"^",1) - I $D(^RGSITE(991.8,1,"EXCPRG")) D - . S STDT=$$FMTE^XLFDT(STDT,1) - . W !!,"The MPI/PD Exception Purge process last ran "_STDT_"." - K CNT,EXCTYP,NTYP,ETEXT,TOTL,IEN,IEN2,HOME,PCNT,^XTMP("RGEXC"),PDFN,STDT - I $Y>21 D QUIT Q:X="^" -PDR ;Count entries in Patient Data Review ;**52 Obsolete data removed from report. - ;W !!,"Patient Data Review Entries:",!,"----------------------------" - ;S CNT=0,PDRTYP="",NTYP="",TOTL=0 - ;F S PDRTYP=$O(^DGCN(391.98,"AST",PDRTYP)) Q:'PDRTYP D - ;. I (PDRTYP'=NTYP)&(CNT>0) D - ;.. S DIC="^DGCN(391.984,",DR=".01",DA=NTYP,DIQ(0)="E",DIQ="RGPDR" - ;.. D EN^DIQ1 K DIC,DA,DR,DIQ - ;.. S PTEXT=$G(RGPDR(391.984,NTYP,.01,"E")) - ;.. W !,$E(PTEXT,1,47),?55,$J(CNT,6) S TOTL=TOTL+CNT,CNT=0 - ;. I (PDRTYP=1)!(PDRTYP=2)!(PDRTYP=5) D - ;.. S IEN=0,NTYP=PDRTYP - ;.. F S IEN=$O(^DGCN(391.98,"AST",PDRTYP,IEN)) Q:'IEN D - ;... S CNT=CNT+1 - ;I CNT>0 D - ;. S DIC="^DGCN(391.984,",DR=".01",DA=NTYP,DIQ(0)="E",DIQ="RGPDR" - ;. D EN^DIQ1 K DIC,DA,DR,DIQ - ;. S PTEXT=$G(RGPDR(391.984,NTYP,.01,"E")) - ;.W !,$E(PTEXT,1,47),?55,$J(CNT,6) S TOTL=TOTL+CNT - ;I TOTL=0 W !,"There are no entries in Patient Data Review." - ;K CNT,PDRTYP,NTYP,TOTL,IEN,PTEXT,RGPDR - ;Q - ;I $Y>20 D QUIT Q:X="^" - ; -CMOR ;CMOR Requests Status ;**52 Obsolete data removed from report. - ;W !!,"CMOR Requests Status:",!,"---------------------" - ;S CNT=0,STAT="",NSTAT="",TOTL=0 - ;F S STAT=$O(^MPIF(984.9,"AC",STAT)) Q:'STAT D - ;. I (STAT'=NSTAT)&(CNT>0) D - ;.. S TEXT=$$EXTERNAL^DILFD(984.9,.06,,NSTAT) - ;.. W !,$E(TEXT,1,47),?55,$J(CNT,6) S TOTL=TOTL+CNT,CNT=0 - ;. S IEN=0,NSTAT=STAT - ;. F S IEN=$O(^MPIF(984.9,"AC",STAT,IEN)) Q:'IEN D - ;.. S CNT=CNT+1 S TOTL=TOTL+CNT - ;I CNT>0 S TEXT=$$EXTERNAL^DILFD(984.9,.06,,NSTAT) W !,$E(TEXT,1,47),?55,$J(CNT,6) S TOTL=TOTL+CNT,CNT=0 - ;I TOTL=0 W !,"There are no outstanding CMOR Requests." - ;K CNT,STAT,NSTAT,TEXT,TOTL,IEN - ;I $Y>20 D QUIT Q:X="^" - ; - S HOME=$P($$SITE^VASITE(),"^",3) - S ICN=0,CNT=0 - F S ICN=$O(^DPT("AICN",ICN)) Q:'ICN D - .Q:$E(ICN,1,3)=HOME - .S CNT=CNT+1 - W !!,"Current total number of National ICNs = ",CNT - S ICN=0,CNT=0 - F S ICN=$O(^DPT("AICNL",1,ICN)) Q:'ICN S CNT=CNT+1 - W !,"Current total number of Local ICNs = ",CNT - K CNT,DFN,ICN - Q -QUIT S DIR(0)="E" D D ^DIR K DIR - .S SS=21-$Y F JJ=1:1:SS W ! - S $Y=0 - K JJ,SS - Q +RGSYSTAT ;BAY/ALS-MPI/PD STATUS DISPLAY ;01/05/01 + ;;1.0;CLINICAL INFO RESOURCE NETWORK;**16,19,23,25,20,43,45**;30 Apr 99;Build 9 + ;Reference to ^DGCN(391.98,"AST" supported by IA #3303 + ;Reference to ^DGCN(391.984 supported by IA #3304 + ;Reference to ^MPIF(984.9 supported by IA #3298 + ;Reference to OPTSTAT^XUTMOPT supported by IA #1472 + ;Reference to ^DPT("ACMORS", ^DPT("AICN", and ^DPT("AICNL" supported by IA #2070 + ;Reference to ^VAT(391.71 supported by IA #3422 +EN ; + ; Count exceptions on hand +EXC ; + W @IOF,"Exception Handler Entries:",!,"--------------------------" + S CNT=0,EXCTYP="",NTYP="",TOTL=0,PCNT=0 + N STAT,DFN,ICN + S HOME=$$SITE^VASITE() + F S EXCTYP=$O(^RGHL7(991.1,"AC",EXCTYP)) Q:'EXCTYP D + . I (EXCTYP=234)!(EXCTYP=227)!((EXCTYP>214)&(EXCTYP<219)) D ;**45 + .. I (EXCTYP'=NTYP)&(CNT>0) D + ... S ETEXT=$P($G(^RGHL7(991.11,NTYP,10)),"^",1) + ... W !,$E(ETEXT,1,47),?55,$J(CNT,6) S TOTL=TOTL+CNT,CNT=0 + .. S IEN=0,NTYP=EXCTYP + .. F S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN D + ... S IEN2=0 + ... F S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2 D + .... S STAT=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",5) I STAT<1 D + ..... S DFN=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",4) Q:'DFN + ..... S ^XTMP("RGEXC",0)=$$FMADD^XLFDT(DT,2)_"^"_DT_"^"_"MPI/PD Status Display" + ..... S ^XTMP("RGEXC",DFN)=DFN + ..... S ICN=+$$GETICN^MPIF001(DFN) + ..... I $E(ICN,1,3)=$E($P(HOME,"^",3),1,3)!(ICN<0)!(EXCTYP=234)!((EXCTYP>214)&(EXCTYP<219)) D ;**43,45 + ...... S CNT=CNT+1 + I CNT>0 D + .S ETEXT=$P($G(^RGHL7(991.11,NTYP,10)),"^",1) + .W !,$E(ETEXT,1,47),?55,$J(CNT,6) S TOTL=TOTL+CNT + I TOTL=0 W !,"There are no entries in the Exception Handler." + I TOTL>0 D + . W !!,"Total number of exceptions: ",?55,$J(TOTL,6) + . S PDFN="" + . F S PDFN=$O(^XTMP("RGEXC",PDFN)) Q:'PDFN D + .. S PCNT=PCNT+1 + . W !,"Total unique patient exceptions: ",?55,$J(PCNT,6) + S STDT=$P($G(^RGSITE(991.8,1,"EXCPRG")),"^",1) + I $D(^RGSITE(991.8,1,"EXCPRG")) D + . S STDT=$$FMTE^XLFDT(STDT,1) + . W !!,"The MPI/PD Exception Purge process last ran "_STDT_"." + K CNT,EXCTYP,NTYP,ETEXT,TOTL,IEN,IEN2,HOME,PCNT,^XTMP("RGEXC"),PDFN,STDT + I $Y>21 D QUIT Q:X="^" +PDR ;Count entries in Patient Data Review + W !!,"Patient Data Review Entries:",!,"----------------------------" + S CNT=0,PDRTYP="",NTYP="",TOTL=0 + F S PDRTYP=$O(^DGCN(391.98,"AST",PDRTYP)) Q:'PDRTYP D + . I (PDRTYP'=NTYP)&(CNT>0) D + .. S DIC="^DGCN(391.984,",DR=".01",DA=NTYP,DIQ(0)="E",DIQ="RGPDR" + .. D EN^DIQ1 K DIC,DA,DR,DIQ + .. S PTEXT=$G(RGPDR(391.984,NTYP,.01,"E")) + .. W !,$E(PTEXT,1,47),?55,$J(CNT,6) S TOTL=TOTL+CNT,CNT=0 + . I (PDRTYP=1)!(PDRTYP=2)!(PDRTYP=5) D + .. S IEN=0,NTYP=PDRTYP + .. F S IEN=$O(^DGCN(391.98,"AST",PDRTYP,IEN)) Q:'IEN D + ... S CNT=CNT+1 + I CNT>0 D + . S DIC="^DGCN(391.984,",DR=".01",DA=NTYP,DIQ(0)="E",DIQ="RGPDR" + . D EN^DIQ1 K DIC,DA,DR,DIQ + . S PTEXT=$G(RGPDR(391.984,NTYP,.01,"E")) + .W !,$E(PTEXT,1,47),?55,$J(CNT,6) S TOTL=TOTL+CNT + I TOTL=0 W !,"There are no entries in Patient Data Review." + K CNT,PDRTYP,NTYP,TOTL,IEN,PTEXT,RGPDR + ;Q + I $Y>20 D QUIT Q:X="^" + ; +CMOR ;CMOR Requests Status + W !!,"CMOR Requests Status:",!,"---------------------" + S CNT=0,STAT="",NSTAT="",TOTL=0 + F S STAT=$O(^MPIF(984.9,"AC",STAT)) Q:'STAT D + . I (STAT'=NSTAT)&(CNT>0) D + .. S TEXT=$$EXTERNAL^DILFD(984.9,.06,,NSTAT) + .. W !,$E(TEXT,1,47),?55,$J(CNT,6) S TOTL=TOTL+CNT,CNT=0 + . S IEN=0,NSTAT=STAT + . F S IEN=$O(^MPIF(984.9,"AC",STAT,IEN)) Q:'IEN D + .. S CNT=CNT+1 S TOTL=TOTL+CNT + I CNT>0 S TEXT=$$EXTERNAL^DILFD(984.9,.06,,NSTAT) W !,$E(TEXT,1,47),?55,$J(CNT,6) S TOTL=TOTL+CNT,CNT=0 + I TOTL=0 W !,"There are no outstanding CMOR Requests." + K CNT,STAT,NSTAT,TEXT,TOTL,IEN + I $Y>20 D QUIT Q:X="^" + ; + S HOME=$P($$SITE^VASITE(),"^",3) + S ICN=0,CNT=0 + F S ICN=$O(^DPT("AICN",ICN)) Q:'ICN D + .Q:$E(ICN,1,3)=HOME + .S CNT=CNT+1 + W !,"Current total number of National ICNs = ",CNT + S ICN=0,CNT=0 + F S ICN=$O(^DPT("AICNL",1,ICN)) Q:'ICN S CNT=CNT+1 + W !,"Current total number of Local ICNs = ",CNT + K CNT,DFN,ICN + Q +QUIT S DIR(0)="E" D D ^DIR K DIR + .S SS=21-$Y F JJ=1:1:SS W ! + S $Y=0 + K JJ,SS + Q